diff --git a/.github/workflows/cd-debian13.yml b/.github/workflows/cd-debian13.yml index 4397c47733..c37f08d4e9 100644 --- a/.github/workflows/cd-debian13.yml +++ b/.github/workflows/cd-debian13.yml @@ -66,10 +66,6 @@ jobs: libdbus-1-3 libglib2.0-0t64 libegl1 libgl-dev libxkbcommon0 \ fonts-noto-cjk \ ghostscript \ - qt6-base-dev \ - libqt6svg6-dev \ - libqt6networkauth6-dev \ - qt6-base-private-dev \ fakeroot \ debhelper \ file \ @@ -81,7 +77,7 @@ jobs: # 3. 编译流程 # ========================================== - name: Config - run: xmake config --yes -vD -m release --policies=build.ccache + run: xmake config --loro=yes --yes -vD -m release --policies=build.ccache - name: Build run: xmake build -vD stem @@ -150,4 +146,4 @@ jobs: with: prerelease: true files: | - mogan-stem-*-debian13-amd64.deb \ No newline at end of file + mogan-stem-*-debian13-amd64.deb diff --git a/.github/workflows/cd-research-mogan-app.yml b/.github/workflows/cd-research-mogan-app.yml index 071a306ba7..bcd35e106f 100644 --- a/.github/workflows/cd-research-mogan-app.yml +++ b/.github/workflows/cd-research-mogan-app.yml @@ -18,6 +18,7 @@ on: - ".github/workflows/cd-research-mogan-app.yml" - "TeXmacs/tests/*.scm" - "3rdparty/**" + - "web/**" workflow_dispatch: env: @@ -64,8 +65,27 @@ jobs: ${{ env.XMAKE_GLOBALDIR }}/.xmake/packages key: xrepo-${{ runner.os }}-${{ matrix.arch }}-${{ hashFiles('xmake/vars.lua', 'lolly/xmake.lua', 'moebius/xmake.lua') }} + # Build the React shell (web/) before the C++ link step. xmake's + # after_build copies web/dist into the stem target dir, so the Vite + # output must exist before `xmake build stem` links. + - uses: actions/setup-node@v4 + with: + node-version: '20' + cache: 'npm' + cache-dependency-path: web/package-lock.json + - name: cache npm + uses: actions/cache@v4 + with: + path: ~/.npm + key: npm-${{ runner.os }}-${{ hashFiles('web/package-lock.json') }} + - name: build react shell + run: | + cd web + npm ci + npm run build + - name: config - run: xmake config --policies=build.ccache -o ${{ runner.workspace }}/build -m release -p wasm --qt_frontend=no --pdfhummus=no --goldfish=no --yes + run: xmake config --policies=build.ccache -o ${{ runner.workspace }}/build -m release -p wasm --qt_frontend=no --pdfhummus=no --goldfish=no --loro=yes --yes - name: build run: xmake build --yes -vD stem @@ -73,8 +93,13 @@ jobs: - name: Prepare GitHub Pages files run: | echo "research.mogan.app" > ${{ runner.workspace }}/build/wasm/wasm32/release/CNAME - mv ${{ runner.workspace }}/build/wasm/wasm32/release/stem.html \ - ${{ runner.workspace }}/build/wasm/wasm32/release/index.html + # The React shell (web/dist) already provides index.html; stem.html + # is a mirror of it for the dev server. Only fall back to the legacy + # rename when the JS shell wasn't built. + if [ ! -f ${{ runner.workspace }}/build/wasm/wasm32/release/index.html ]; then + mv ${{ runner.workspace }}/build/wasm/wasm32/release/stem.html \ + ${{ runner.workspace }}/build/wasm/wasm32/release/index.html + fi rm ${{ runner.workspace }}/build/wasm/wasm32/release/*.a - name: Push diff --git a/.github/workflows/cd_on_macos_arm64.yml b/.github/workflows/cd_on_macos_arm64.yml index f02a3144cd..87fdb2bd38 100644 --- a/.github/workflows/cd_on_macos_arm64.yml +++ b/.github/workflows/cd_on_macos_arm64.yml @@ -16,9 +16,11 @@ jobs: os: [macos-14] arch: [arm64] runs-on: ${{ matrix.os }} - timeout-minutes: 45 + # Windows CD 为 45 分钟；mac 侧多出 vpk 签名 + notarytool 公证等待 + # （package.scm 时代公证单独给了 60 分钟超时），放宽到 60。 + timeout-minutes: 60 steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 with: fetch-depth: 1 - uses: xmake-io/github-action-setup-xmake@v1 @@ -27,30 +29,218 @@ jobs: actions-cache-folder: '.xmake-cache' - name: xmake repo --update run: xmake repo --update - - name: Config and build goldfish + # Noto 字体（与 Windows CD 相同来源）：原由 package.scm 内部下载， + # DMG 流程移除后必须在此落位，install 才会收进 .app 的 Resources。 + - name: Noto fonts run: | - xmake config -m release -a ${{ matrix.arch }} -vD --yes - xmake build goldfish-bin - ls -la TeXmacs/plugins/goldfish/bin/ || echo "goldfish bin dir not found" - - name: Package with Goldfish + mkdir -p TeXmacs/fonts/opentype/noto + cd TeXmacs/fonts/opentype/noto + curl -fsSLO https://github.com/XmacsLabs/mogan/releases/download/v1.2.9.7/NotoSansCJK-Bold.ttc + curl -fsSLO https://github.com/XmacsLabs/mogan/releases/download/v1.2.9.7/NotoSansCJK-Regular.ttc + curl -fsSLO https://github.com/XmacsLabs/mogan/releases/download/v1.2.9.7/NotoSerifCJK-Bold.ttc + curl -fsSLO https://github.com/XmacsLabs/mogan/releases/download/v1.2.9.7/NotoSerifCJK-Regular.ttc + - name: config + run: xmake config -m release -a ${{ matrix.arch }} -vD --loro=yes --yes + - name: build + run: xmake build -vD stem + - name: install + run: xmake install -vD stem + # vpk 1.2.0 的 apphost 需要 .NET 10 runtime；macos-14 arm64 镜像自带的 + # dotnet 版本较旧且不在 apphost 默认搜索路径（首跑实测 You must install + # .NET）。setup-dotnet 显式装 .NET 10 并设置 DOTNET_ROOT。 + - uses: actions/setup-dotnet@v4 + with: + dotnet-version: '10.0.x' + - name: Install vpk + shell: pwsh + run: | + dotnet tool install -g vpk --version 1.2.0 + # pwsh 在 Unix 无 USERPROFILE，用 HOME + Add-Content -Path $env:GITHUB_PATH -Value "$($env:HOME)/.dotnet/tools" + # Apple 签名/公证 setup（mac 独有；Windows 的正式签名在 SafeNet 签名机 + # 事后完成，mac 未签名 pkg 会被 Gatekeeper 直接拦截，故在 CI 内完成）。 + # keychain 命令序列照搬 packages/macos/package.scm 的 setup-keychain； + # 身份名动态解析后经 VPK_SIGN_* 环境变量注入 pack_velopack.lua（见 + # tools/release/pack_velopack.lua 的 mac 签名参数透传），stage 侧检测到 + # VPK_SIGN_APP_IDENTITY 即跳过 ad-hoc、交给 vpk 深签。 + - name: Setup Apple signing env: APPLE_CERTIFICATE_P12_BASE64: ${{ secrets.APPLE_CERTIFICATE_P12 }} APPLE_CERTIFICATE_PASSWORD: ${{ secrets.APPLE_CERTIFICATE_PASSWORD }} APPLE_API_KEY_ID: ${{ secrets.APPLE_API_KEY_ID }} APPLE_API_KEY_P8: ${{ secrets.APPLE_API_KEY_P8 }} APPLE_API_ISSUER_ID: ${{ secrets.APPLE_API_ISSUER_ID }} - APPLE_TEAM_ID: ${{ secrets.APPLE_TEAM_ID }} run: | - chmod +x TeXmacs/plugins/goldfish/bin/goldfish - TeXmacs/plugins/goldfish/bin/goldfish packages/macos/package.scm - - name: Upload + set -e + KEYCHAIN="$HOME/Library/Keychains/mogan-signing.keychain-db" + KEYCHAIN_PASS="$(openssl rand -base64 32)" + CERT=/tmp/mogan_cert.p12 + printf '%s' "$APPLE_CERTIFICATE_P12_BASE64" | base64 -D -o "$CERT" + security delete-keychain "$KEYCHAIN" 2>/dev/null || true + security create-keychain -p "$KEYCHAIN_PASS" "$KEYCHAIN" + security set-keychain-settings -lut 21600 "$KEYCHAIN" + security unlock-keychain -p "$KEYCHAIN_PASS" "$KEYCHAIN" + security import "$CERT" -P "$APPLE_CERTIFICATE_PASSWORD" -k "$KEYCHAIN" -T /usr/bin/codesign || + security import "$CERT" -P "$APPLE_CERTIFICATE_PASSWORD" -k "$KEYCHAIN" + curl -fsSL -o /tmp/apple_devid_ca.cer https://www.apple.com/certificateauthority/DeveloperIDCA.cer + curl -fsSL -o /tmp/apple_devid_ca_g2.cer https://www.apple.com/certificateauthority/DeveloperIDG2CA.cer + security add-certificates -k "$KEYCHAIN" /tmp/apple_devid_ca.cer /tmp/apple_devid_ca_g2.cer + security set-key-partition-list -S apple-tool:,apple:,codesign: -s -k "$KEYCHAIN_PASS" "$KEYCHAIN" + LOGIN_KC="$HOME/Library/Keychains/login.keychain-db" + if [ -f "$LOGIN_KC" ]; then + security list-keychains -d user -s "$KEYCHAIN" "$LOGIN_KC" /Library/Keychains/System.keychain + else + security list-keychains -d user -s "$KEYCHAIN" /Library/Keychains/System.keychain + fi + security default-keychain -s "$KEYCHAIN" + # notarytool 凭据 profile（App Store Connect API key，同 package.scm） + KEY_DIR="$HOME/.appstoreconnect/private_keys" + mkdir -p "$KEY_DIR" + API_KEY="$KEY_DIR/AuthKey_${APPLE_API_KEY_ID}.p8" + printf '%s' "$APPLE_API_KEY_P8" | base64 -D -o "$API_KEY" + chmod 600 "$API_KEY" + xcrun notarytool store-credentials mogan-notary \ + --key "$API_KEY" --key-id "$APPLE_API_KEY_ID" \ + --issuer "$APPLE_API_ISSUER_ID" --keychain "$KEYCHAIN" + # 身份名动态解析（P12 里证书的完整主题名因续期而变，不硬编码） + APP_IDENTITY="$(security find-identity -v -p codesigning "$KEYCHAIN" | + sed -n 's/.*"\(Developer ID Application:[^"]*\)".*/\1/p' | head -1)" + INSTALL_IDENTITY="$(security find-identity -v -p codesigning "$KEYCHAIN" | + sed -n 's/.*"\(Developer ID Installer:[^"]*\)".*/\1/p' | head -1)" + if [ -n "$APP_IDENTITY" ]; then + echo "VPK_SIGN_APP_IDENTITY=$APP_IDENTITY" >> "$GITHUB_ENV" + else + echo "::error::keychain 中未找到 Developer ID Application 证书" + exit 1 + fi + # P12 可能只含 Application 证书；缺 Installer 时 vpk 跳过 .pkg 签名并 + # 告警（app 仍签名），属可接受降级 + if [ -n "$INSTALL_IDENTITY" ]; then + echo "VPK_SIGN_INSTALL_IDENTITY=$INSTALL_IDENTITY" >> "$GITHUB_ENV" + echo "INSTALL_IDENTITY=$INSTALL_IDENTITY" + else + echo "INSTALL_IDENTITY=（未找到 Developer ID Installer，pkg 将不签名）" + fi + echo "VPK_NOTARY_PROFILE=mogan-notary" >> "$GITHUB_ENV" + echo "VPK_KEYCHAIN=$KEYCHAIN" >> "$GITHUB_ENV" + echo "APP_IDENTITY=$APP_IDENTITY" + - name: Stage Velopack + run: xmake l tools/release/stage_velopack.lua + # 从 GitHub Release 拉取上一版本的发布压缩包作为各通道的 delta 基线： + # 逻辑与 Windows CD 一致（列 100 个 release、排除 draft 与当前 tag、 + # beta 必查 + 无 -rc 才查 stable、stable 只认非 rc release、同版本跳过、 + # 解 zip 取该通道 full 包拷入 build/velopack_release_/）。 + # 与 Windows 的两处差异： + # 1) zip 匹配模式带 -osx-arm64 平台段——同一 release 上还有 Windows 的 + # mogan-release-*-win-x64-.zip，nupkg 是平台专属的，不带 + # 平台段会抓错平台基线； + # 2) 不做裸 nupkg 回退——Windows 的该回退对应其过渡期历史，mac 沿用 + # 会抓到 Windows 的旧 full 包。 + # 某通道首次发布（GitHub 上尚无 mac 归档 zip）时跳过属正常：没有基线 + # 时 pack 只出 full 包，是合法状态。 + # GITHUB_TOKEN 不会自动注入为环境变量，必须显式传入 secrets.GITHUB_TOKEN； + # 为空时回退为公开仓库的匿名访问。 + - name: Fetch delta baselines from GitHub Release + shell: pwsh + continue-on-error: true + env: + GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + run: | + $headers = @{ + Accept = "application/vnd.github+json" + "User-Agent" = "mogan-cd" + } + if ($env:GITHUB_TOKEN) { + $headers["Authorization"] = "Bearer $($env:GITHUB_TOKEN)" + } + $releases = Invoke-RestMethod -Headers $headers ` + -Uri "https://api.github.com/repos/${{ github.repository }}/releases?per_page=100" + $releases = $releases | + Where-Object { -not $_.draft -and $_.tag_name -ne $env:GITHUB_REF_NAME } + # 本次要打的通道：beta 必打；stable 仅 tag 不含 -rc 时打 + # （tag 名由 bump-version 流水线产生，-rc 与否即通道信息，无需透传）。 + $tag = "${{ github.ref_name }}" + $channels = @("beta") + if ($tag -notmatch '-rc') { $channels += "stable" } + $vars = Get-Content xmake/vars.lua -Raw + $currentVer = [regex]::Match($vars, 'XMACS_VERSION\s*=\s*"([^"]+)"').Groups[1].Value + foreach ($channel in $channels) { + Write-Host "== 通道 $channel：查找 delta 基线 ==" + foreach ($release in $releases) { + # stable 基线只认非 rc tag 的 release（rc release 无 stable 包） + if ($channel -eq "stable" -and $release.tag_name -match '-rc') { + continue + } + Remove-Item build/velopack_baseline -Recurse -Force -ErrorAction SilentlyContinue + New-Item -ItemType Directory -Path build/velopack_baseline -Force | Out-Null + # 按平台 + 通道名匹配 zip（分开上传的格式，名带平台与通道后缀， + # 只下载目标通道的归档，避免拉取无关平台的 1.5GB 包） + $zipPattern = "mogan-release-*-osx-arm64-$channel.zip" + $zip = $release.assets | + Where-Object { $_.name -like $zipPattern } | + Select-Object -First 1 + if (-not $zip) { continue } + /usr/bin/curl -fsSL "$($zip.browser_download_url)" -o build/velopack_baseline.zip + Expand-Archive -Path build/velopack_baseline.zip ` + -DestinationPath build/velopack_baseline -Force + $full = Get-ChildItem build/velopack_baseline -Filter "*-$channel-full.nupkg" | + Select-Object -First 1 + if (-not $full) { continue } + $baselineVer = $full.Name -replace '^Mogan-', '' ` + -replace "-$channel-full\.nupkg$", '' + if ($baselineVer -eq $currentVer) { + Write-Host "基线版本与当前版本相同（$baselineVer），跳过（重跑同一版本）" + break + } + $outDir = "build/velopack_release_$channel" + New-Item -ItemType Directory -Path $outDir -Force | Out-Null + Copy-Item $full.FullName $outDir/ + Write-Host "已就位 $channel delta 基线: $($full.Name)" + break + } + } + # vpk pack 在 outputDir 存在上一版本（上一步拉取的 full 包）时自动生成 + # delta 增量包；首次发布无上一版本，只有全量包。beta/stable 各用独立 + # 输出目录（vpk 把 outputDir 当 channel 累积目录，混用会互相干扰）， + # 产物文件名带 channel 后缀，最后合并进同一 release 归档。 + - name: Pack Velopack (beta) + env: + VPK_CHANNEL: beta + VPK_OUTPUT_DIR: build/velopack_release_beta + run: xmake l tools/release/pack_velopack.lua + - name: Pack Velopack (stable) + if: ${{ !contains(github.ref_name, '-rc') }} + env: + VPK_CHANNEL: stable + VPK_OUTPUT_DIR: build/velopack_release_stable + run: xmake l tools/release/pack_velopack.lua + # 每个通道各自打一个 zip（Release 资产与下游 delta 基线按通道取用）： + # 文件名带平台与通道后缀 mogan-release--osx-arm64-.zip， + # 命名规则与 Windows CD 的 win-x64 归档一致。 + - name: Create release archive + shell: pwsh + run: | + $vars = Get-Content xmake/vars.lua -Raw + $ver = [regex]::Match($vars, 'XMACS_VERSION\s*=\s*"([^"]+)"').Groups[1].Value + $dirs = Get-ChildItem build -Directory -Filter 'velopack_release_*' | + Sort-Object Name + foreach ($d in $dirs) { + $channel = $d.Name -replace '^velopack_release_', '' + $archive = "build/mogan-release-$ver-osx-arm64-$channel.zip" + Compress-Archive -Path "$($d.FullName)/*" -DestinationPath $archive ` + -CompressionLevel Optimal -Force + Get-Item $archive | Select-Object Name, Length + } + - name: Upload uses: actions/upload-artifact@v4 if: ${{ !startsWith(github.ref, 'refs/tags/') }} with: - path: build/*.dmg + path: | + build/velopack_release_*/* + build/mogan-release-*.zip - name: Release uses: softprops/action-gh-release@v1 if: startsWith(github.ref, 'refs/tags/') with: prerelease: true - files: build/*.dmg \ No newline at end of file + files: build/mogan-release-*.zip diff --git a/.github/workflows/cd_research_on_windows.yml b/.github/workflows/cd_research_on_windows.yml index ee8c1e458d..be518009fc 100644 --- a/.github/workflows/cd_research_on_windows.yml +++ b/.github/workflows/cd_research_on_windows.yml @@ -27,7 +27,7 @@ jobs: with: install_scoop: 'true' buckets: main - apps: wget pandoc ghostscript + apps: wget pandoc ghostscript dark update_path: 'true' - name: Noto fonts shell: pwsh @@ -39,49 +39,171 @@ jobs: wget https://github.com/XmacsLabs/mogan/releases/download/v1.2.9.7/NotoSerifCJK-Bold.ttc wget https://github.com/XmacsLabs/mogan/releases/download/v1.2.9.7/NotoSerifCJK-Regular.ttc - name: config - run: xmake config --yes -vD -m release + run: xmake config --loro=yes --yes -vD -m release - name: build - run: xmake build -vD stem + run: xmake build -vD stem - name: install run: xmake install -vD stem - name: gs and pandoc run: | cp ~\scoop\apps\pandoc\current\pandoc.exe D:\a\mogan\mogan\build\packages\stem\data\bin wget https://github.com/XmacsLabs/mogan/releases/download/v1.2.9.7/gs.exe - - name: Generate Installer - run: xmake pack --yes -vD stem - - name: Rename installer using XMACS_VERSION + # app-local CRT：stage 从 vc_redist.x64.exe 提取运行库 DLL 进 payload， + # 不再使用 vpk --framework（避免 Setup.exe 在用户机器上从微软 CDN 下载）。 + # vc_redist.x64.exe 由 Qt 部署（windeployqt）在 xmake install 时从构建机 + # VS 的 VC\Redist 目录自动拷入安装树 bin/（与旧 NSIS 流程一致），无需下载。 + # Velopack 已接管常规 Windows 发布（见 tools/release/*.lua）；NSIS + # （xmake pack）仅迁移期桥接保留，迁移窗口结束、NSIS 桥接发布停用后再移除。 + # 注意：CI 产物不签名（VPK_SIGN_PARAMS 为空），正式签名在 SafeNet 签名机 + # 上通过环境变量注入 signtool 参数完成；交互式令牌不允许并发签名，签名机 + # 上须固定 --signParallel 1。 + - name: Install vpk shell: pwsh run: | - $content = Get-Content "xmake/vars.lua" -Raw -ErrorAction SilentlyContinue - if ($content -match 'XMACS_VERSION.*"(.*)"') { - $ver = $Matches[1] - Write-Host "Found version: $ver" - $packDir = Join-Path -Path "build" -ChildPath "xpack/stem" - if (Test-Path $packDir) { - $exe = Get-ChildItem -Path $packDir -Filter "*.exe" | Sort-Object LastWriteTime -Descending | Select-Object -First 1 - if ($exe) { - $newName = "MoganSTEM-v${ver}-64bit-installer.exe" - Write-Host "Renaming $($exe.Name) -> $newName" - Rename-Item -Path $exe.FullName -NewName $newName -Force - Write-Host "Rename complete" + dotnet tool install -g vpk --version 1.2.0 + Add-Content -Path $env:GITHUB_PATH -Value "$env:USERPROFILE\.dotnet\tools" + # pandoc 已在 gs and pandoc 步骤落进 bin/，stage 会把它收进暂存根 bin/ + # （$TEXMACS_PATH/bin，find-binary 按此查找）。 + - name: Stage Velopack + run: xmake l tools/release/stage_velopack.lua + # 从 GitHub Release 拉取上一版本的发布压缩包作为各通道的 delta 基线： + # vpk pack 只有 outputDir 里存在上一版本 full 包时才会生成 delta。 + # 双通道规则（devel/0518.md）：beta 每次 tag 都打，基线取最新 release 的 + # beta full；stable 仅无 -rc 的 tag 打，基线向前找最近非 rc release 的 + # stable full。所有发布都标了 prerelease，releases/latest 接口拿不到， + # 这里列出最近 100 个 release，排除 draft 和当前 tag（重跑同一 tag 时 + # 避免把自己当基线），按通道各自向后遍历，wget 下载对应通道的 zip。 + # 压缩包分两种：新版每平台每通道各一个 zip（mogan-release-- + # -.zip，按平台与通道名匹配归档——mac CD 会向同一 + # release 上传 osx-arm64 归档，nupkg 是平台专属的，不带平台段会抓错 + # 基线）；旧版是全部通道合并的单一 zip（无通道后缀，仅 Windows 时代 + # 存在，兼容回退）。解压拣出对应通道的 full 包 + # （stable 需逐个 release 尝试：rc tag 的 zip 里没有 stable 包，自然 + # 跳过）。某通道首次发布或 GitHub 上尚无压缩包时跳过属正常（没有基线 + # 时 pack 只出 full 包，是合法状态）。 + # GITHUB_TOKEN 不会自动注入为环境变量，必须显式传入 secrets.GITHUB_TOKEN； + # 为空时回退为公开仓库的匿名访问。 + - name: Fetch delta baselines from GitHub Release + shell: pwsh + continue-on-error: true + env: + GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + run: | + $headers = @{ + Accept = "application/vnd.github+json" + "User-Agent" = "mogan-cd" + } + if ($env:GITHUB_TOKEN) { + $headers["Authorization"] = "Bearer $($env:GITHUB_TOKEN)" + } + # 仓库已由 XmacsLabs/mogan 改名为 MoganLab/mogan，这里跟随当前仓库， + # 避免硬编码旧名依赖 GitHub 重定向 + $releases = Invoke-RestMethod -Headers $headers ` + -Uri "https://api.github.com/repos/${{ github.repository }}/releases?per_page=100" + $releases = $releases | + Where-Object { -not $_.draft -and $_.tag_name -ne $env:GITHUB_REF_NAME } + # 本次要打的通道：beta 必打；stable 仅 tag 不含 -rc 时打 + # （tag 名由 bump-version 流水线产生，-rc 与否即通道信息，无需透传）。 + $tag = "${{ github.ref_name }}" + $channels = @("beta") + if ($tag -notmatch '-rc') { $channels += "stable" } + $vars = Get-Content xmake/vars.lua -Raw + $currentVer = [regex]::Match($vars, 'XMACS_VERSION\s*=\s*"([^"]+)"').Groups[1].Value + foreach ($channel in $channels) { + Write-Host "== 通道 $channel：查找 delta 基线 ==" + foreach ($release in $releases) { + # stable 基线只认非 rc tag 的 release（rc release 无 stable 包） + if ($channel -eq "stable" -and $release.tag_name -match '-rc') { + continue + } + Remove-Item build/velopack_baseline -Recurse -Force -ErrorAction SilentlyContinue + New-Item -ItemType Directory -Path build/velopack_baseline -Force | Out-Null + # 按平台 + 通道名匹配 zip（分开上传的新格式，名带平台与通道 + # 后缀，只下载目标通道的归档，避免拉取无关通道/平台的 1.5GB + # 包）；找不到再回退旧合并 zip（无通道后缀、仅 Windows 时代 + # 存在，内含全部通道的包）。 + $zipPattern = "mogan-release-*-win-x64-$channel.zip" + $zip = $release.assets | + Where-Object { $_.name -like $zipPattern } | + Select-Object -First 1 + if (-not $zip) { + $zip = $release.assets | + Where-Object { $_.name -like 'mogan-release-*-win-x64.zip' } | + Select-Object -First 1 + } + if ($zip) { + wget -q "$($zip.browser_download_url)" -O build/velopack_baseline.zip + Expand-Archive -Path build/velopack_baseline.zip ` + -DestinationPath build/velopack_baseline -Force } else { - Write-Warning "No .exe installer found in $packDir" + # 兼容过渡期：旧 release 直接散装上传 nupkg、没有 zip， + # 退而下载 full 包 + $asset = $release.assets | + Where-Object { $_.name -like "*-$channel-full.nupkg" } | + Select-Object -First 1 + if (-not $asset) { continue } + wget -q "$($asset.browser_download_url)" ` + -O "build/velopack_baseline/$($asset.name)" + } + $full = Get-ChildItem build/velopack_baseline -Filter "*-$channel-full.nupkg" | + Select-Object -First 1 + if (-not $full) { continue } + $baselineVer = $full.Name -replace '^Mogan-', '' ` + -replace "-$channel-full\.nupkg$", '' + if ($baselineVer -eq $currentVer) { + Write-Host "基线版本与当前版本相同（$baselineVer），跳过（重跑同一版本）" + break } - } else { - Write-Warning "Package directory '$packDir' not found" + $outDir = "build/velopack_release_$channel" + New-Item -ItemType Directory -Path $outDir -Force | Out-Null + Copy-Item $full.FullName $outDir/ + Write-Host "已就位 $channel delta 基线: $($full.Name)" + break } } - - name: Upload + # vpk pack 在 outputDir 存在上一版本（上一步拉取的 full 包）时自动生成 + # delta 增量包；首次发布无上一版本，只有全量包。beta/stable 各用独立 + # 输出目录（vpk 把 outputDir 当 channel 累积目录，混用会互相干扰）， + # 产物文件名带 channel 后缀，最后合并进同一 release 归档。 + - name: Pack Velopack (beta) + env: + VPK_CHANNEL: beta + VPK_OUTPUT_DIR: build/velopack_release_beta + run: xmake l tools/release/pack_velopack.lua + - name: Pack Velopack (stable) + if: ${{ !contains(github.ref_name, '-rc') }} + env: + VPK_CHANNEL: stable + VPK_OUTPUT_DIR: build/velopack_release_stable + run: xmake l tools/release/pack_velopack.lua + # 每个通道各自打一个 zip（Release 资产与下游 delta 基线按通道取用）： + # 文件名带通道后缀 mogan-release--win-x64-.zip。此前是 + # 全部通道合并成单一 zip，现改为分开上传，便于只下载目标通道的包。 + - name: Create release archive + shell: pwsh + run: | + $vars = Get-Content xmake/vars.lua -Raw + $ver = [regex]::Match($vars, 'XMACS_VERSION\s*=\s*"([^"]+)"').Groups[1].Value + $dirs = Get-ChildItem build -Directory -Filter 'velopack_release_*' | + Sort-Object Name + foreach ($d in $dirs) { + $channel = $d.Name -replace '^velopack_release_', '' + $archive = "build/mogan-release-$ver-win-x64-$channel.zip" + Compress-Archive -Path "$($d.FullName)/*" -DestinationPath $archive ` + -CompressionLevel Optimal -Force + Get-Item $archive | Select-Object Name, Length + } + - name: Upload uses: actions/upload-artifact@v4 if: ${{ !startsWith(github.ref, 'refs/tags/') }} with: path: | - build/xpack/stem/*.exe + build/velopack_release_*/* + build/mogan-release-*.zip - name: Release uses: softprops/action-gh-release@v1 if: startsWith(github.ref, 'refs/tags/') with: prerelease: true files: | - build/xpack/stem/*.exe + build/mogan-release-*.zip diff --git a/.github/workflows/ci-debian13.yml b/.github/workflows/ci-debian13.yml index 7a4e1997f5..c961d90557 100644 --- a/.github/workflows/ci-debian13.yml +++ b/.github/workflows/ci-debian13.yml @@ -134,7 +134,7 @@ jobs: - '3rdparty/**' - name: config - run: xmake config -vD --policies=build.ccache -o tmp/build -m releasedbg --yes + run: xmake config -vD --policies=build.ccache -o tmp/build -m releasedbg --loro=yes --yes - name: build lolly if: steps.filter.outputs.lolly == 'true' run: xmake build --yes -vD liblolly diff --git a/.github/workflows/ci-imgui-debian13.yml b/.github/workflows/ci-imgui-debian13.yml index 812899fb63..a2911b4384 100644 --- a/.github/workflows/ci-imgui-debian13.yml +++ b/.github/workflows/ci-imgui-debian13.yml @@ -79,7 +79,7 @@ jobs: key: ${{ runner.os }}-xrepo-imgui-${{ hashFiles('xmake/vars.lua', 'lolly/xmake.lua', 'moebius/xmake.lua', 'xmake/requires.lua') }} - name: config - run: xmake config -vD --qt_frontend=no --policies=build.ccache --yes + run: xmake config -vD --qt_frontend=no --loro=yes --policies=build.ccache --yes - name: build stem run: xmake b -vD stem diff --git a/.github/workflows/ci-imgui-macos.yml b/.github/workflows/ci-imgui-macos.yml index a23abf6223..f44b3d9a93 100644 --- a/.github/workflows/ci-imgui-macos.yml +++ b/.github/workflows/ci-imgui-macos.yml @@ -44,7 +44,7 @@ jobs: key: ${{ runner.os }}-xrepo-imgui-${{ matrix.arch }}-${{ hashFiles('xmake/vars.lua', 'lolly/xmake.lua', 'moebius/xmake.lua') }} - name: config - run: xmake config -vD --qt_frontend=no --policies=build.ccache --yes + run: xmake config -vD --qt_frontend=no --loro=yes --policies=build.ccache --yes - name: build stem run: xmake b -vD stem diff --git a/.github/workflows/ci-macos-arm64.yml b/.github/workflows/ci-macos-arm64.yml index 5a206be8a6..2d1a4eab4d 100644 --- a/.github/workflows/ci-macos-arm64.yml +++ b/.github/workflows/ci-macos-arm64.yml @@ -161,7 +161,7 @@ jobs: key: xrepo-${{ runner.os }}-${{ matrix.arch }}-${{ hashFiles('xmake/vars.lua', 'lolly/xmake.lua', 'moebius/xmake.lua') }} - name: config - run: xmake config --policies=build.ccache -o ${{ runner.workspace }}/build -m releasedbg --yes + run: xmake config --policies=build.ccache -o ${{ runner.workspace }}/build -m releasedbg --loro=yes --yes - name: build lolly if: steps.filter.outputs.lolly == 'true' run: xmake build --yes -vD liblolly diff --git a/.github/workflows/ci-macos-wasm.yml b/.github/workflows/ci-macos-wasm.yml index 84e0386b0c..6004c1eedd 100644 --- a/.github/workflows/ci-macos-wasm.yml +++ b/.github/workflows/ci-macos-wasm.yml @@ -18,6 +18,7 @@ on: - ".github/workflows/ci-macos-wasm.yml" - "TeXmacs/tests/*.scm" - "3rdparty/**" + - "web/**" pull_request: branches: [main] paths: @@ -36,6 +37,7 @@ on: - ".github/workflows/ci-macos-wasm.yml" - "TeXmacs/tests/*.scm" - "3rdparty/**" + - "web/**" workflow_dispatch: env: @@ -82,8 +84,21 @@ jobs: ${{ env.XMAKE_GLOBALDIR }}/.xmake/packages key: xrepo-${{ runner.os }}-${{ matrix.arch }}-${{ hashFiles('xmake/vars.lua', 'lolly/xmake.lua', 'moebius/xmake.lua') }} + # node/npm are still required: xmake's web_shell target runs + # `npm install && npm run build` during `xmake build stem`. + - uses: actions/setup-node@v4 + with: + node-version: '20' + cache: 'npm' + cache-dependency-path: web/package-lock.json + - name: cache npm + uses: actions/cache@v4 + with: + path: ~/.npm + key: npm-${{ runner.os }}-${{ hashFiles('web/package-lock.json') }} + - name: config - run: xmake config --policies=build.ccache -o ${{ runner.workspace }}/build -m releasedbg -p wasm --qt_frontend=no --pdfhummus=no --goldfish=no --yes + run: xmake config --policies=build.ccache -o ${{ runner.workspace }}/build -m releasedbg -p wasm --qt_frontend=no --pdfhummus=no --goldfish=no --loro=yes --yes - name: build run: xmake build --yes -vD stem \ No newline at end of file diff --git a/.github/workflows/ci-xmake-windows.yml b/.github/workflows/ci-xmake-windows.yml index 9946a40fdf..311a259ff6 100644 --- a/.github/workflows/ci-xmake-windows.yml +++ b/.github/workflows/ci-xmake-windows.yml @@ -141,7 +141,7 @@ jobs: ${{ github.workspace }}/build/.build_cache key: ${{ runner.os }}-${{ runner.arch }}-${{ hashFiles('xmake/vars.lua', 'lolly/xmake.lua', 'moebius/xmake.lua') }} - name: config - run: xmake config --policies=build.ccache --yes -vD -m releasedbg --plat=windows + run: xmake config --policies=build.ccache --yes -vD -m releasedbg --loro=yes --plat=windows - name: build lolly if: steps.filter.outputs.lolly == 'true' run: xmake build --yes -vD liblolly diff --git a/.github/workflows/ci_bump_version.yml b/.github/workflows/ci_bump_version.yml index 2097558689..a6832ced65 100644 --- a/.github/workflows/ci_bump_version.yml +++ b/.github/workflows/ci_bump_version.yml @@ -4,7 +4,7 @@ on: workflow_dispatch: inputs: version: - description: '新版本号 (如 v2026.2.1)' + description: '新版本号 (如 v2026.2.1、v2026.2.1-rc.1)' required: true jobs: @@ -24,8 +24,8 @@ jobs: - name: Validate version format run: | VERSION="${{ github.event.inputs.version }}" - if ! echo "$VERSION" | grep -qE '^v[0-9]{4}\.[0-9]{1,2}(\.[0-9]+)?(-rc[0-9]+)?$'; then - echo "版本格式错误，应为 v2026.2.1 或 v2026.2.1-rc1" + if ! echo "$VERSION" | grep -qE '^v[0-9]{4}\.[0-9]{1,2}(\.[0-9]+)?(-rc\.[0-9]+)?$'; then + echo "版本格式错误，应为 v2026.2.1 或 v2026.2.1-rc.1" exit 1 fi @@ -68,4 +68,4 @@ jobs: git tag ${{ env.NEW_VERSION }} git push origin ${{ github.ref_name }} - git push origin ${{ env.NEW_VERSION }} \ No newline at end of file + git push origin ${{ env.NEW_VERSION }} diff --git a/.gitignore b/.gitignore index 7682c018dd..de24151bb8 100644 --- a/.gitignore +++ b/.gitignore @@ -12,6 +12,9 @@ build __pycache__/ 3rdparty/loro/target 3rdparty/mogan-loro-ffi/target +# curl 源码包构建产物(目录名带构建哈希)与构建期改写的 CMakeLists +3rdparty/curl-*/build-*/ +3rdparty/curl-*/CMakeLists.txt # editor files *.sln @@ -69,3 +72,6 @@ tools/loro-server/node_modules/ tools/loro-server/data/ # 协作服务端从仓库根运行时产生的测试数据 /data/ + +# Reasonix +reasonix.toml diff --git a/3rdparty/curl-8.21.0/.clang-tidy.yml b/3rdparty/curl-8.21.0/.clang-tidy.yml new file mode 100644 index 0000000000..5f523fb50b --- /dev/null +++ b/3rdparty/curl-8.21.0/.clang-tidy.yml @@ -0,0 +1,59 @@ +# Copyright (C) Daniel Stenberg, , et al. +# +# SPDX-License-Identifier: curl +--- +# https://clang.llvm.org/extra/clang-tidy/ + +# https://clang.llvm.org/extra/clang-tidy/checks/list.html +Checks: + - clang-analyzer-* + - -clang-analyzer-optin.performance.Padding + - -clang-analyzer-security.ArrayBound # due to false positives with clang-tidy v21.1.0+ + - -clang-analyzer-security.insecureAPI.bzero # for FD_ZERO() (seen on macOS) + - -clang-analyzer-security.insecureAPI.DeprecatedOrUnsafeBufferHandling + - -clang-diagnostic-nullability-extension + - bugprone-assert-side-effect + - bugprone-assignment-in-if-condition + - bugprone-chained-comparison + - bugprone-dynamic-static-initializers + - bugprone-invalid-enum-default-initialization + - bugprone-macro-parentheses + - bugprone-macro-repeated-side-effects + - bugprone-misplaced-operator-in-strlen-in-alloc + - bugprone-misplaced-pointer-arithmetic-in-alloc + - bugprone-not-null-terminated-result + - bugprone-posix-return + - bugprone-redundant-branch-condition + - bugprone-signed-char-misuse + - bugprone-sizeof-expression + - bugprone-suspicious-enum-usage + - bugprone-suspicious-memset-usage + - bugprone-suspicious-missing-comma + - bugprone-suspicious-realloc-usage + - bugprone-suspicious-semicolon + # bugprone-unchecked-string-to-number-conversion # needs converting sscanf to strtol or curlx_str_* + - misc-const-correctness + - misc-header-include-cycle + # misc-redundant-expression # undesired hits due to system macros, e.g. due to POLLIN == POLLRDNORM | POLLRDBAND, then or-ing all three + - portability-* + - readability-duplicate-include + # readability-else-after-return + # readability-enum-initial-value + # readability-function-cognitive-complexity + - readability-inconsistent-declaration-parameter-name + # readability-misleading-indentation # too many false positives and oddball/conditional source + - readability-named-parameter + # readability-redundant-casting # false positives in types that change from platform to platform, even with IgnoreTypeAliases: true + - readability-redundant-control-flow + - readability-redundant-declaration + - readability-redundant-function-ptr-dereference + - readability-redundant-parentheses + - readability-redundant-preprocessor + - readability-suspicious-call-argument + - readability-uppercase-literal-suffix + +CheckOptions: + misc-header-include-cycle.IgnoredFilesList: 'curl/curl.h' + readability-inconsistent-declaration-parameter-name.Strict: true + +HeaderFilterRegex: '.*' # Default in v22.1.0+ diff --git a/3rdparty/curl-8.21.0/.editorconfig b/3rdparty/curl-8.21.0/.editorconfig new file mode 100644 index 0000000000..edcc4629fb --- /dev/null +++ b/3rdparty/curl-8.21.0/.editorconfig @@ -0,0 +1,18 @@ +# Copyright (C) Daniel Stenberg, , et al. +# +# SPDX-License-Identifier: curl + +root = true + +[*] +charset = utf-8 +insert_final_newline = true +indent_style = space +trim_trailing_whitespace = true + +[*.{c,h}] +indent_size = 2 +max_line_length = 79 + +[*.{pl,pm}] +indent_size = 4 diff --git a/3rdparty/curl-8.21.0/CHANGES.md b/3rdparty/curl-8.21.0/CHANGES.md new file mode 100644 index 0000000000..3eabec9cb8 --- /dev/null +++ b/3rdparty/curl-8.21.0/CHANGES.md @@ -0,0 +1,12 @@ + + +In a release tarball, check the RELEASE-NOTES file for what was done in the +most recent release. In a git check-out, that file mentions changes that have +been done since the previous release. + +See the online [changelog](https://curl.se/changes.html) for the edited and +human readable version of what has changed in different curl releases. diff --git a/3rdparty/curl-8.21.0/CMake/CurlSymbolHiding.cmake b/3rdparty/curl-8.21.0/CMake/CurlSymbolHiding.cmake new file mode 100644 index 0000000000..51a2d94de1 --- /dev/null +++ b/3rdparty/curl-8.21.0/CMake/CurlSymbolHiding.cmake @@ -0,0 +1,68 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +option(CURL_HIDDEN_SYMBOLS "Hide libcurl internal symbols (=hide all symbols that are not officially external)" ON) +mark_as_advanced(CURL_HIDDEN_SYMBOLS) + +if(WIN32 AND ENABLE_DEBUG) + # We need to export internal debug functions, + # e.g. curl_easy_perform_ev() or curl_dbg_*(), + # so disable symbol hiding for debug builds and for memory tracking. + set(CURL_HIDDEN_SYMBOLS OFF) +elseif(DOS OR AMIGA) + set(CURL_HIDDEN_SYMBOLS OFF) +endif() + +set(CURL_HIDES_PRIVATE_SYMBOLS FALSE) +set(CURL_EXTERN_SYMBOL "") +set(CURL_CFLAG_SYMBOLS_HIDE "") + +if(CURL_HIDDEN_SYMBOLS) + if(CMAKE_C_COMPILER_ID MATCHES "Clang" AND NOT MSVC) + set(CURL_HIDES_PRIVATE_SYMBOLS TRUE) + set(CURL_EXTERN_SYMBOL "__attribute__((__visibility__(\"default\")))") + set(CURL_CFLAG_SYMBOLS_HIDE "-fvisibility=hidden") + elseif(CMAKE_C_COMPILER_ID STREQUAL "GNU") + if(CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 3.4) + # Note: This is considered buggy prior to 4.0 but the autotools do not care, so let us ignore that fact + set(CURL_HIDES_PRIVATE_SYMBOLS TRUE) + set(CURL_EXTERN_SYMBOL "__attribute__((__visibility__(\"default\")))") + set(CURL_CFLAG_SYMBOLS_HIDE "-fvisibility=hidden") + endif() + elseif(CMAKE_C_COMPILER_ID MATCHES "SunPro" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 8.0) + set(CURL_HIDES_PRIVATE_SYMBOLS TRUE) + set(CURL_EXTERN_SYMBOL "__global") + set(CURL_CFLAG_SYMBOLS_HIDE "-xldscope=hidden") + elseif(CMAKE_C_COMPILER_ID MATCHES "Intel" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 9.0) # Requires 9.1.045 + set(CURL_HIDES_PRIVATE_SYMBOLS TRUE) + set(CURL_EXTERN_SYMBOL "__attribute__((__visibility__(\"default\")))") + set(CURL_CFLAG_SYMBOLS_HIDE "-fvisibility=hidden") + elseif(MSVC) + set(CURL_HIDES_PRIVATE_SYMBOLS TRUE) + endif() +else() + if(MSVC) + # Note: This option is prone to export non-curl extra symbols. + set(CMAKE_WINDOWS_EXPORT_ALL_SYMBOLS TRUE) + endif() +endif() diff --git a/3rdparty/curl-8.21.0/CMake/CurlTests.c b/3rdparty/curl-8.21.0/CMake/CurlTests.c new file mode 100644 index 0000000000..be3b6f73ee --- /dev/null +++ b/3rdparty/curl-8.21.0/CMake/CurlTests.c @@ -0,0 +1,401 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +#ifdef HAVE_FCNTL_O_NONBLOCK +/* headers for FCNTL_O_NONBLOCK test */ +#include +#include +#include + +#if defined(sun) || defined(__sun__) || \ + defined(__SUNPRO_C) || defined(__SUNPRO_CC) +# if defined(__SVR4) || defined(__srv4__) +# define PLATFORM_SOLARIS +# else +# define PLATFORM_SUNOS4 +# endif +#endif +#if (defined(_AIX) || defined(__xlC__)) && !defined(_AIX41) +# define PLATFORM_AIX_V3 +#endif + +#if defined(PLATFORM_SUNOS4) || defined(PLATFORM_AIX_V3) +#error "O_NONBLOCK does not work on this platform" +#endif + +int main(void) +{ + /* O_NONBLOCK source test */ + int flags = 0; + if(0 != fcntl(0, F_SETFL, flags | O_NONBLOCK)) + return 1; + return 0; +} +#endif + +/* tests for gethostbyname_r */ +#if defined(HAVE_GETHOSTBYNAME_R_3) || \ + defined(HAVE_GETHOSTBYNAME_R_3_REENTRANT) || \ + defined(HAVE_GETHOSTBYNAME_R_5) || \ + defined(HAVE_GETHOSTBYNAME_R_5_REENTRANT) || \ + defined(HAVE_GETHOSTBYNAME_R_6) || \ + defined(HAVE_GETHOSTBYNAME_R_6_REENTRANT) +#include +#include +int main(void) +{ + const char *address = "example.com"; + struct hostent h; + int rc = 0; +#if defined(HAVE_GETHOSTBYNAME_R_3) || \ + defined(HAVE_GETHOSTBYNAME_R_3_REENTRANT) + struct hostent_data hdata; +#elif defined(HAVE_GETHOSTBYNAME_R_5) || \ + defined(HAVE_GETHOSTBYNAME_R_5_REENTRANT) || \ + defined(HAVE_GETHOSTBYNAME_R_6) || \ + defined(HAVE_GETHOSTBYNAME_R_6_REENTRANT) + char buffer[8192]; + struct hostent *hp; + int h_errnop; +#endif + +#if defined(HAVE_GETHOSTBYNAME_R_3) || \ + defined(HAVE_GETHOSTBYNAME_R_3_REENTRANT) + rc = gethostbyname_r(address, &h, &hdata); + (void)hdata; +#elif defined(HAVE_GETHOSTBYNAME_R_5) || \ + defined(HAVE_GETHOSTBYNAME_R_5_REENTRANT) + rc = gethostbyname_r(address, &h, buffer, 8192, &h_errnop); + (void)hp; + (void)h_errnop; +#elif defined(HAVE_GETHOSTBYNAME_R_6) || \ + defined(HAVE_GETHOSTBYNAME_R_6_REENTRANT) + rc = gethostbyname_r(address, &h, buffer, 8192, &hp, &h_errnop); + (void)hp; + (void)h_errnop; +#endif + (void)h; + (void)rc; + return 0; +} +#endif + +#ifdef HAVE_BOOL_T +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#ifdef HAVE_STDBOOL_H +#include +#endif +int main(void) +{ + return (int)sizeof(bool *); +} +#endif + +#ifdef STDC_HEADERS +#include +#include +#include +#include +int main(void) +{ + return 0; +} +#endif + +#ifdef HAVE_FILE_OFFSET_BITS +#include +/* Check that off_t can represent 2**63 - 1 correctly. + We cannot define LARGE_OFF_T to be 9223372036854775807, + since some C++ compilers masquerading as C compilers + incorrectly reject 9223372036854775807. */ +#define LARGE_OFF_T (((off_t)1 << 62) - 1 + ((off_t)1 << 62)) +static int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721 && + LARGE_OFF_T % 2147483647 == 1) + ? 1 : -1]; +int main(void) +{ + (void)off_t_is_large; + return 0; +} +#endif + +#ifdef HAVE_IOCTLSOCKET +#ifdef _WIN32 +# include +#endif +int main(void) +{ + /* ioctlsocket source code */ + int socket = -1; + unsigned long flags = ioctlsocket(socket, FIONBIO, &flags); + (void)flags; + return 0; +} + +#endif + +#ifdef HAVE_IOCTLSOCKET_CAMEL +#include +int main(void) +{ + /* IoctlSocket source code */ + if(0 != IoctlSocket(0, 0, 0)) + return 1; + return 0; +} +#endif + +#ifdef HAVE_IOCTLSOCKET_CAMEL_FIONBIO +#include +#ifdef HAVE_SYS_IOCTL_H +# include +#endif +int main(void) +{ + /* IoctlSocket source code */ + long flags = 0; + if(0 != IoctlSocket(0, FIONBIO, &flags)) + return 1; + (void)flags; + return 0; +} +#endif + +#ifdef HAVE_IOCTLSOCKET_FIONBIO +#ifdef _WIN32 +# include +#endif +int main(void) +{ + unsigned long flags = 0; + if(0 != ioctlsocket(0, FIONBIO, &flags)) + return 1; + (void)flags; + return 0; +} +#endif + +#ifdef HAVE_IOCTL_FIONBIO +/* headers for FIONBIO test */ +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifdef HAVE_UNISTD_H +# include +#endif +#ifndef _WIN32 +# include +#endif +#ifdef HAVE_SYS_IOCTL_H +# include +#endif +#ifdef HAVE_STROPTS_H +# include +#endif +int main(void) +{ + int flags = 0; + if(0 != ioctl(0, FIONBIO, &flags)) + return 1; + (void)flags; + return 0; +} +#endif + +#ifdef HAVE_IOCTL_SIOCGIFADDR +/* headers for FIONBIO test */ +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifdef HAVE_UNISTD_H +# include +#endif +#ifndef _WIN32 +# include +#endif +#ifdef HAVE_SYS_IOCTL_H +# include +#endif +#ifdef HAVE_STROPTS_H +# include +#endif +#include +int main(void) +{ + struct ifreq ifr; + if(0 != ioctl(0, SIOCGIFADDR, &ifr)) + return 1; + (void)ifr; + return 0; +} +#endif + +#ifdef HAVE_SETSOCKOPT_SO_NONBLOCK +#ifdef _WIN32 +# include +#endif +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifndef _WIN32 +# include +#endif +int main(void) +{ + if(0 != setsockopt(0, SOL_SOCKET, SO_NONBLOCK, 0, 0)) + return 1; + return 0; +} +#endif + +#ifdef HAVE_GLIBC_STRERROR_R +#include +#include + +static void check(char c) +{ + (void)c; +} + +int main(void) +{ + char buffer[1024]; + /* This does not compile if strerror_r does not return a char* */ + /* !checksrc! disable ERRNOVAR 1 */ + check(strerror_r(EACCES, buffer, sizeof(buffer))[0]); + return 0; +} +#endif + +#ifdef HAVE_POSIX_STRERROR_R +#include +#include + +/* Float, because a pointer cannot be implicitly cast to float */ +static void check(float f) +{ + (void)f; +} + +int main(void) +{ + char buffer[1024]; + /* This does not compile if strerror_r does not return an int */ + /* !checksrc! disable ERRNOVAR 1 */ + check(strerror_r(EACCES, buffer, sizeof(buffer))); + return 0; +} +#endif + +#ifdef HAVE_FSETXATTR_6 +#include /* header from libc, not from libattr */ +int main(void) +{ + fsetxattr(0, 0, 0, 0, 0, 0); + return 0; +} +#endif + +#ifdef HAVE_FSETXATTR_5 +#include /* header from libc, not from libattr */ +int main(void) +{ + fsetxattr(0, "", 0, 0, 0); + return 0; +} +#endif + +#ifdef HAVE_CLOCK_GETTIME_MONOTONIC +#include +int main(void) +{ + struct timespec ts; + (void)clock_gettime(CLOCK_MONOTONIC, &ts); + (void)ts; + return 0; +} +#endif + +#ifdef HAVE_BUILTIN_AVAILABLE +int main(void) +{ + if(__builtin_available(macOS 10.12, iOS 5.0, *)) {} + return 0; +} +#endif + +#ifdef HAVE_ATOMIC +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifdef HAVE_UNISTD_H +# include +#endif +#ifdef HAVE_STDATOMIC_H +# include +#endif +int main(void) +{ + _Atomic int i = 1; + i = 0; /* Force an atomic-write operation. */ + return i; +} +#endif + +#ifdef HAVE_WIN32_WINNT +#ifdef _WIN32 +# ifndef NOGDI +# define NOGDI +# endif +# include +#endif + +#define enquote(x) #x +#define expand(x) enquote(x) +#pragma message("_WIN32_WINNT=" expand(_WIN32_WINNT)) + +int main(void) +{ + return 0; +} +#endif + +#ifdef MINGW64_VERSION +#ifdef __MINGW32__ +# include <_mingw.h> +#endif + +#define enquote(x) #x +#define expand(x) enquote(x) +#pragma message("MINGW64_VERSION=" \ + expand(__MINGW64_VERSION_MAJOR) "." \ + expand(__MINGW64_VERSION_MINOR)) + +int main(void) +{ + return 0; +} +#endif diff --git a/3rdparty/curl-8.21.0/CMake/FindBrotli.cmake b/3rdparty/curl-8.21.0/CMake/FindBrotli.cmake new file mode 100644 index 0000000000..bd3363cce0 --- /dev/null +++ b/3rdparty/curl-8.21.0/CMake/FindBrotli.cmake @@ -0,0 +1,96 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# Find the brotli library +# +# Input variables: +# +# - `BROTLI_INCLUDE_DIR`: Absolute path to brotli include directory. +# - `BROTLICOMMON_LIBRARY`: Absolute path to `brotlicommon` library. +# - `BROTLIDEC_LIBRARY`: Absolute path to `brotlidec` library. +# - `BROTLI_USE_STATIC_LIBS`: Configure for static brotli libraries. +# +# Defines: +# +# - `BROTLI_FOUND`: System has brotli. +# - `BROTLI_VERSION`: Version of brotli. +# - `CURL::brotli`: brotli library target. + +set(_brotli_pc_requires "libbrotlidec" "libbrotlicommon") # order is significant: brotlidec then brotlicommon + +if(CURL_USE_PKGCONFIG AND + NOT DEFINED BROTLI_INCLUDE_DIR AND + NOT DEFINED BROTLICOMMON_LIBRARY AND + NOT DEFINED BROTLIDEC_LIBRARY) + find_package(PkgConfig QUIET) + pkg_check_modules(_brotli ${_brotli_pc_requires}) +endif() + +if(_brotli_FOUND) + set(Brotli_FOUND TRUE) + set(BROTLI_FOUND TRUE) + set(BROTLI_VERSION ${_brotli_libbrotlicommon_VERSION}) + if(BROTLI_USE_STATIC_LIBS) + set(_brotli_CFLAGS "${_brotli_STATIC_CFLAGS}") + set(_brotli_INCLUDE_DIRS "${_brotli_STATIC_INCLUDE_DIRS}") + set(_brotli_LIBRARY_DIRS "${_brotli_STATIC_LIBRARY_DIRS}") + set(_brotli_LIBRARIES "${_brotli_STATIC_LIBRARIES}") + endif() + message(STATUS "Found Brotli (via pkg-config): ${_brotli_INCLUDE_DIRS} (found version \"${BROTLI_VERSION}\")") +else() + find_path(BROTLI_INCLUDE_DIR "brotli/decode.h") + if(BROTLI_USE_STATIC_LIBS) + find_library(BROTLICOMMON_LIBRARY NAMES "brotlicommon-static" "brotlicommon") + find_library(BROTLIDEC_LIBRARY NAMES "brotlidec-static" "brotlidec") + else() + find_library(BROTLICOMMON_LIBRARY NAMES "brotlicommon") + find_library(BROTLIDEC_LIBRARY NAMES "brotlidec") + endif() + + include(FindPackageHandleStandardArgs) + find_package_handle_standard_args(Brotli + REQUIRED_VARS + BROTLI_INCLUDE_DIR + BROTLIDEC_LIBRARY + BROTLICOMMON_LIBRARY + ) + + if(BROTLI_FOUND) + set(_brotli_INCLUDE_DIRS ${BROTLI_INCLUDE_DIR}) + set(_brotli_LIBRARIES ${BROTLIDEC_LIBRARY} ${BROTLICOMMON_LIBRARY}) + endif() + + mark_as_advanced(BROTLI_INCLUDE_DIR BROTLIDEC_LIBRARY BROTLICOMMON_LIBRARY) +endif() + +if(BROTLI_FOUND) + if(NOT TARGET CURL::brotli) + add_library(CURL::brotli INTERFACE IMPORTED) + set_target_properties(CURL::brotli PROPERTIES + INTERFACE_LIBCURL_PC_MODULES "${_brotli_pc_requires}" + INTERFACE_COMPILE_OPTIONS "${_brotli_CFLAGS}" + INTERFACE_INCLUDE_DIRECTORIES "${_brotli_INCLUDE_DIRS}" + INTERFACE_LINK_DIRECTORIES "${_brotli_LIBRARY_DIRS}" + INTERFACE_LINK_LIBRARIES "${_brotli_LIBRARIES}") + endif() +endif() diff --git a/3rdparty/curl-8.21.0/CMake/FindCares.cmake b/3rdparty/curl-8.21.0/CMake/FindCares.cmake new file mode 100644 index 0000000000..26efdf87ff --- /dev/null +++ b/3rdparty/curl-8.21.0/CMake/FindCares.cmake @@ -0,0 +1,132 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# Find the c-ares library +# +# Input variables: +# +# - `CARES_INCLUDE_DIR`: Absolute path to c-ares include directory. +# - `CARES_LIBRARY`: Absolute path to `cares` library. +# - `CARES_USE_STATIC_LIBS`: Configure for static c-ares libraries. +# +# Defines: +# +# - `CARES_FOUND`: System has c-ares. +# - `CARES_VERSION`: Version of c-ares. +# - `CURL::cares`: c-ares library target. + +set(_cares_pc_requires "libcares") + +if(NOT DEFINED CARES_INCLUDE_DIR AND + NOT DEFINED CARES_LIBRARY) + if(CURL_USE_PKGCONFIG) + find_package(PkgConfig QUIET) + pkg_check_modules(_cares ${_cares_pc_requires}) + endif() + if(NOT _cares_FOUND AND CURL_USE_CMAKECONFIG) + find_package(c-ares CONFIG QUIET) + endif() +endif() + +if(_cares_FOUND) + set(Cares_FOUND TRUE) + set(CARES_FOUND TRUE) + set(CARES_VERSION ${_cares_VERSION}) + if(CARES_USE_STATIC_LIBS) + set(_cares_CFLAGS "${_cares_STATIC_CFLAGS}") + set(_cares_INCLUDE_DIRS "${_cares_STATIC_INCLUDE_DIRS}") + set(_cares_LIBRARY_DIRS "${_cares_STATIC_LIBRARY_DIRS}") + set(_cares_LIBRARIES "${_cares_STATIC_LIBRARIES}") + endif() + message(STATUS "Found Cares (via pkg-config): ${_cares_INCLUDE_DIRS} (found version \"${CARES_VERSION}\")") +elseif(c-ares_CONFIG) + set(Cares_FOUND TRUE) + set(CARES_FOUND TRUE) + set(CARES_VERSION ${c-ares_VERSION}) + if(CARES_USE_STATIC_LIBS) + set(_cares_LIBRARIES c-ares::cares_static) + else() + set(_cares_LIBRARIES c-ares::cares) + endif() + message(STATUS "Found Cares (via CMake Config): ${c-ares_CONFIG} (found version \"${CARES_VERSION}\")") +else() + find_path(CARES_INCLUDE_DIR NAMES "ares.h") + if(CARES_USE_STATIC_LIBS) + set(_cares_CFLAGS "-DCARES_STATICLIB") + find_library(CARES_LIBRARY NAMES ${CARES_NAMES} "cares_static" "cares") + else() + find_library(CARES_LIBRARY NAMES ${CARES_NAMES} "cares") + endif() + + unset(CARES_VERSION CACHE) + if(CARES_INCLUDE_DIR AND EXISTS "${CARES_INCLUDE_DIR}/ares_version.h") + set(_version_regex1 "#[\t ]*define[\t ]+ARES_VERSION_MAJOR[\t ]+([0-9]+).*") + set(_version_regex2 "#[\t ]*define[\t ]+ARES_VERSION_MINOR[\t ]+([0-9]+).*") + set(_version_regex3 "#[\t ]*define[\t ]+ARES_VERSION_PATCH[\t ]+([0-9]+).*") + file(STRINGS "${CARES_INCLUDE_DIR}/ares_version.h" _version_str1 REGEX "${_version_regex1}") + file(STRINGS "${CARES_INCLUDE_DIR}/ares_version.h" _version_str2 REGEX "${_version_regex2}") + file(STRINGS "${CARES_INCLUDE_DIR}/ares_version.h" _version_str3 REGEX "${_version_regex3}") + string(REGEX REPLACE "${_version_regex1}" "\\1" _version_str1 "${_version_str1}") + string(REGEX REPLACE "${_version_regex2}" "\\1" _version_str2 "${_version_str2}") + string(REGEX REPLACE "${_version_regex3}" "\\1" _version_str3 "${_version_str3}") + set(CARES_VERSION "${_version_str1}.${_version_str2}.${_version_str3}") + unset(_version_regex1) + unset(_version_regex2) + unset(_version_regex3) + unset(_version_str1) + unset(_version_str2) + unset(_version_str3) + endif() + + include(FindPackageHandleStandardArgs) + find_package_handle_standard_args(Cares + REQUIRED_VARS + CARES_INCLUDE_DIR + CARES_LIBRARY + VERSION_VAR + CARES_VERSION + ) + + if(CARES_FOUND) + set(_cares_INCLUDE_DIRS ${CARES_INCLUDE_DIR}) + set(_cares_LIBRARIES ${CARES_LIBRARY}) + endif() + + mark_as_advanced(CARES_INCLUDE_DIR CARES_LIBRARY) +endif() + +if(CARES_FOUND) + if(WIN32) + list(APPEND _cares_LIBRARIES "iphlpapi") # for if_indextoname and others + endif() + + if(NOT TARGET CURL::cares) + add_library(CURL::cares INTERFACE IMPORTED) + set_target_properties(CURL::cares PROPERTIES + INTERFACE_LIBCURL_PC_MODULES "${_cares_pc_requires}" + INTERFACE_COMPILE_OPTIONS "${_cares_CFLAGS}" + INTERFACE_INCLUDE_DIRECTORIES "${_cares_INCLUDE_DIRS}" + INTERFACE_LINK_DIRECTORIES "${_cares_LIBRARY_DIRS}" + INTERFACE_LINK_LIBRARIES "${_cares_LIBRARIES}") + endif() +endif() diff --git a/3rdparty/curl-8.21.0/CMake/FindGSS.cmake b/3rdparty/curl-8.21.0/CMake/FindGSS.cmake new file mode 100644 index 0000000000..6f352b2e4f --- /dev/null +++ b/3rdparty/curl-8.21.0/CMake/FindGSS.cmake @@ -0,0 +1,264 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# Find the GSS Kerberos library +# +# Input variables: +# +# - `GSS_ROOT_DIR`: Absolute path to the root installation of GSS. (also supported as environment) +# +# Defines: +# +# - `GSS_FOUND`: System has GSS. +# - `GSS_VERSION`: Version of GSS. +# - `CURL::gss`: GSS library target. +# - `INTERFACE_CURL_GSS_FLAVOR`: Custom property. "GNU" or "MIT" if detected. + +set(_gnu_modname "gss") +set(_mit_modname "mit-krb5-gssapi") + +include(CheckIncludeFile) +include(CheckIncludeFiles) +include(CheckTypeSize) + +set(_gss_root_hints "${GSS_ROOT_DIR}" "$ENV{GSS_ROOT_DIR}") + +set(_gss_CFLAGS "") +set(_gss_LIBRARY_DIRS "") + +# Try to find library using system pkg-config if user did not specify root dir +if(NOT GSS_ROOT_DIR AND NOT "$ENV{GSS_ROOT_DIR}") + if(CURL_USE_PKGCONFIG) + find_package(PkgConfig QUIET) + pkg_search_module(_gss ${_mit_modname} ${_gnu_modname}) + list(APPEND _gss_root_hints "${_gss_PREFIX}") + set(_gss_version "${_gss_VERSION}") + endif() + if(WIN32) + list(APPEND _gss_root_hints "[HKEY_LOCAL_MACHINE\\SOFTWARE\\MIT\\Kerberos;InstallDir]") + endif() +endif() + +if(NOT _gss_FOUND) # Not found by pkg-config. Let us take more traditional approach. + find_file(_gss_configure_script NAMES "krb5-config" PATH_SUFFIXES "bin" HINTS ${_gss_root_hints} + NO_CMAKE_PATH NO_CMAKE_ENVIRONMENT_PATH) + # If not found in user-supplied directories, maybe system knows better + find_file(_gss_configure_script NAMES "krb5-config" PATH_SUFFIXES "bin") + + if(_gss_configure_script) + + set(_gss_INCLUDE_DIRS "") + set(_gss_LIBRARIES "") + + execute_process(COMMAND ${_gss_configure_script} "--cflags" "gssapi" + OUTPUT_VARIABLE _gss_cflags_raw + RESULT_VARIABLE _gss_configure_failed + OUTPUT_STRIP_TRAILING_WHITESPACE) + message(STATUS "FindGSS krb5-config --cflags: ${_gss_cflags_raw}") + + if(NOT _gss_configure_failed) # 0 means success + # Should also work in an odd case when multiple directories are given. + string(STRIP "${_gss_cflags_raw}" _gss_cflags_raw) + string(REGEX REPLACE " +-(I)" ";-\\1" _gss_cflags_raw "${_gss_cflags_raw}") + string(REGEX REPLACE " +-([^I][^ \\t;]*)" ";-\\1" _gss_cflags_raw "${_gss_cflags_raw}") + + foreach(_flag IN LISTS _gss_cflags_raw) + if(_flag MATCHES "^-I") + string(REGEX REPLACE "^-I" "" _flag "${_flag}") + list(APPEND _gss_INCLUDE_DIRS "${_flag}") + else() + list(APPEND _gss_CFLAGS "${_flag}") + endif() + endforeach() + endif() + + execute_process(COMMAND ${_gss_configure_script} "--libs" "gssapi" + OUTPUT_VARIABLE _gss_lib_flags + RESULT_VARIABLE _gss_configure_failed + OUTPUT_STRIP_TRAILING_WHITESPACE) + message(STATUS "FindGSS krb5-config --libs: ${_gss_lib_flags}") + + if(NOT _gss_configure_failed) # 0 means success + # This script gives us libraries and link directories. + string(STRIP "${_gss_lib_flags}" _gss_lib_flags) + string(REGEX REPLACE " +-(L|l)" ";-\\1" _gss_lib_flags "${_gss_lib_flags}") + string(REGEX REPLACE " +-([^Ll][^ \\t;]*)" ";-\\1" _gss_lib_flags "${_gss_lib_flags}") + + foreach(_flag IN LISTS _gss_lib_flags) + if(_flag MATCHES "^-l") + string(REGEX REPLACE "^-l" "" _flag "${_flag}") + list(APPEND _gss_LIBRARIES "${_flag}") + elseif(_flag MATCHES "^-L") + string(REGEX REPLACE "^-L" "" _flag "${_flag}") + list(APPEND _gss_LIBRARY_DIRS "${_flag}") + endif() + endforeach() + endif() + + execute_process(COMMAND ${_gss_configure_script} "--version" + OUTPUT_VARIABLE _gss_version + RESULT_VARIABLE _gss_configure_failed + OUTPUT_STRIP_TRAILING_WHITESPACE) + + # Older versions may not have the "--version" parameter. In this case we do not care. + if(_gss_configure_failed) + set(_gss_version 0) + else() + # Strip prefix string to leave the version number only + string(REPLACE "Kerberos 5 release " "" _gss_version "${_gss_version}") + endif() + + execute_process(COMMAND ${_gss_configure_script} "--vendor" + OUTPUT_VARIABLE _gss_vendor + RESULT_VARIABLE _gss_configure_failed + OUTPUT_STRIP_TRAILING_WHITESPACE) + + # Older versions may not have the "--vendor" parameter. In this case we do not care. + if(NOT _gss_configure_failed AND NOT _gss_vendor MATCHES "Heimdal|heimdal") + set(_gss_flavor "MIT") # assume a default, should not really matter + endif() + + else() # Either there is no config script or we are on a platform that does not provide one (Windows?) + + find_path(_gss_INCLUDE_DIRS NAMES "gssapi/gssapi.h" HINTS ${_gss_root_hints} PATH_SUFFIXES "include" "inc") + + if(_gss_INCLUDE_DIRS) # We have found something + set(_gss_libdir_suffixes "") + + cmake_push_check_state() + list(APPEND CMAKE_REQUIRED_INCLUDES "${_gss_INCLUDE_DIRS}") + check_include_files("gssapi/gssapi_generic.h;gssapi/gssapi_krb5.h" _gss_have_mit_headers) + cmake_pop_check_state() + + if(_gss_have_mit_headers) + set(_gss_flavor "MIT") + if(WIN32) + if(CMAKE_SIZEOF_VOID_P EQUAL 8) + list(APPEND _gss_libdir_suffixes "lib/AMD64") + set(_gss_libname "gssapi64") + else() + list(APPEND _gss_libdir_suffixes "lib/i386") + set(_gss_libname "gssapi32") + endif() + else() + list(APPEND _gss_libdir_suffixes "lib" "lib64") # those suffixes are not checked for HINTS + set(_gss_libname "gssapi_krb5") + endif() + endif() + else() + find_path(_gss_INCLUDE_DIRS NAMES "gss.h" HINTS ${_gss_root_hints} PATH_SUFFIXES "include") + + if(_gss_INCLUDE_DIRS) + set(_gss_flavor "GNU") + set(_gss_pc_requires ${_gnu_modname}) + set(_gss_libname "gss") + endif() + endif() + + # If we have headers, look up libraries + if(_gss_flavor) + set(_gss_libdir_hints ${_gss_root_hints}) + if(CMAKE_VERSION VERSION_GREATER_EQUAL 3.20) + cmake_path(GET _gss_INCLUDE_DIRS PARENT_PATH _gss_calculated_potential_root) + else() + get_filename_component(_gss_calculated_potential_root "${_gss_INCLUDE_DIRS}" DIRECTORY) + endif() + list(APPEND _gss_libdir_hints ${_gss_calculated_potential_root}) + + find_library(_gss_LIBRARIES NAMES ${_gss_libname} HINTS ${_gss_libdir_hints} PATH_SUFFIXES ${_gss_libdir_suffixes}) + endif() + endif() + if(NOT _gss_flavor) + message(FATAL_ERROR "GNU or MIT GSS is required") + endif() +else() + if(_gss_MODULE_NAME STREQUAL _gnu_modname) + set(_gss_flavor "GNU") + set(_gss_pc_requires ${_gnu_modname}) + elseif(_gss_MODULE_NAME STREQUAL _mit_modname) + set(_gss_flavor "MIT") + set(_gss_pc_requires ${_mit_modname}) + else() + message(FATAL_ERROR "GNU or MIT GSS is required") + endif() + message(STATUS "Found GSS/${_gss_flavor} (via pkg-config): ${_gss_INCLUDE_DIRS} (found version \"${_gss_version}\")") +endif() + +set(GSS_VERSION ${_gss_version}) + +if(NOT GSS_VERSION) + if(_gss_flavor STREQUAL "MIT" AND WIN32) + if(CMAKE_VERSION VERSION_GREATER_EQUAL 3.24) + cmake_host_system_information(RESULT _mit_version QUERY WINDOWS_REGISTRY + "HKLM/SOFTWARE/MIT/Kerberos/SDK/CurrentVersion" VALUE "VersionString") + else() + get_filename_component(_mit_version + "[HKEY_LOCAL_MACHINE\\SOFTWARE\\MIT\\Kerberos\\SDK\\CurrentVersion;VersionString]" NAME CACHE) + endif() + set(GSS_VERSION "${_mit_version}") + elseif(_gss_flavor STREQUAL "GNU") + if(_gss_INCLUDE_DIRS AND EXISTS "${_gss_INCLUDE_DIRS}/gss.h") + set(_version_regex "#[\t ]*define[\t ]+GSS_VERSION[\t ]+\"([^\"]*)\"") + file(STRINGS "${_gss_INCLUDE_DIRS}/gss.h" _version_str REGEX "${_version_regex}") + string(REGEX REPLACE "${_version_regex}" "\\1" _version_str "${_version_str}") + set(GSS_VERSION "${_version_str}") + unset(_version_regex) + unset(_version_str) + endif() + endif() +endif() + +include(FindPackageHandleStandardArgs) +find_package_handle_standard_args(GSS + REQUIRED_VARS + _gss_flavor + _gss_LIBRARIES + VERSION_VAR + GSS_VERSION + FAIL_MESSAGE + "Could NOT find GSS, try to set the absolute path to GSS installation root directory in the environment variable GSS_ROOT_DIR" +) + +mark_as_advanced( + _gss_CFLAGS + _gss_FOUND + _gss_INCLUDE_DIRS + _gss_LIBRARIES + _gss_LIBRARY_DIRS + _gss_MODULE_NAME + _gss_PREFIX + _gss_version +) + +if(GSS_FOUND) + if(NOT TARGET CURL::gss) + add_library(CURL::gss INTERFACE IMPORTED) + set_target_properties(CURL::gss PROPERTIES + INTERFACE_CURL_GSS_FLAVOR "${_gss_flavor}" + INTERFACE_LIBCURL_PC_MODULES "${_gss_pc_requires}" + INTERFACE_COMPILE_OPTIONS "${_gss_CFLAGS}" + INTERFACE_INCLUDE_DIRECTORIES "${_gss_INCLUDE_DIRS}" + INTERFACE_LINK_DIRECTORIES "${_gss_LIBRARY_DIRS}" + INTERFACE_LINK_LIBRARIES "${_gss_LIBRARIES}") + endif() +endif() diff --git a/3rdparty/curl-8.21.0/CMake/FindGnuTLS.cmake b/3rdparty/curl-8.21.0/CMake/FindGnuTLS.cmake new file mode 100644 index 0000000000..7f5b227dc2 --- /dev/null +++ b/3rdparty/curl-8.21.0/CMake/FindGnuTLS.cmake @@ -0,0 +1,92 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# Find the GnuTLS library +# +# Input variables: +# +# - `GNUTLS_INCLUDE_DIR`: Absolute path to GnuTLS include directory. +# - `GNUTLS_LIBRARY`: Absolute path to `gnutls` library. +# +# Defines: +# +# - `GNUTLS_FOUND`: System has GnuTLS. +# - `GNUTLS_VERSION`: Version of GnuTLS. +# - `CURL::gnutls`: GnuTLS library target. + +set(_gnutls_pc_requires "gnutls") + +if(CURL_USE_PKGCONFIG AND + NOT DEFINED GNUTLS_INCLUDE_DIR AND + NOT DEFINED GNUTLS_LIBRARY) + find_package(PkgConfig QUIET) + pkg_check_modules(_gnutls ${_gnutls_pc_requires}) +endif() + +if(_gnutls_FOUND) + set(GnuTLS_FOUND TRUE) + set(GNUTLS_FOUND TRUE) + set(GNUTLS_VERSION ${_gnutls_VERSION}) + message(STATUS "Found GnuTLS (via pkg-config): ${_gnutls_INCLUDE_DIRS} (found version \"${GNUTLS_VERSION}\")") +else() + find_path(GNUTLS_INCLUDE_DIR NAMES "gnutls/gnutls.h") + find_library(GNUTLS_LIBRARY NAMES "gnutls" "libgnutls") + + unset(GNUTLS_VERSION CACHE) + if(GNUTLS_INCLUDE_DIR AND EXISTS "${GNUTLS_INCLUDE_DIR}/gnutls/gnutls.h") + set(_version_regex "#[\t ]*define[\t ]+GNUTLS_VERSION[\t ]+\"([^\"]*)\"") + file(STRINGS "${GNUTLS_INCLUDE_DIR}/gnutls/gnutls.h" _version_str REGEX "${_version_regex}") + string(REGEX REPLACE "${_version_regex}" "\\1" _version_str "${_version_str}") + set(GNUTLS_VERSION "${_version_str}") + unset(_version_regex) + unset(_version_str) + endif() + + include(FindPackageHandleStandardArgs) + find_package_handle_standard_args(GnuTLS + REQUIRED_VARS + GNUTLS_INCLUDE_DIR + GNUTLS_LIBRARY + VERSION_VAR + GNUTLS_VERSION + ) + + if(GNUTLS_FOUND) + set(_gnutls_INCLUDE_DIRS ${GNUTLS_INCLUDE_DIR}) + set(_gnutls_LIBRARIES ${GNUTLS_LIBRARY}) + endif() + + mark_as_advanced(GNUTLS_INCLUDE_DIR GNUTLS_LIBRARY) +endif() + +if(GNUTLS_FOUND) + if(NOT TARGET CURL::gnutls) + add_library(CURL::gnutls INTERFACE IMPORTED) + set_target_properties(CURL::gnutls PROPERTIES + INTERFACE_LIBCURL_PC_MODULES "${_gnutls_pc_requires}" + INTERFACE_COMPILE_OPTIONS "${_gnutls_CFLAGS}" + INTERFACE_INCLUDE_DIRECTORIES "${_gnutls_INCLUDE_DIRS}" + INTERFACE_LINK_DIRECTORIES "${_gnutls_LIBRARY_DIRS}" + INTERFACE_LINK_LIBRARIES "${_gnutls_LIBRARIES}") + endif() +endif() diff --git a/3rdparty/curl-8.21.0/CMake/FindLDAP.cmake b/3rdparty/curl-8.21.0/CMake/FindLDAP.cmake new file mode 100644 index 0000000000..8902b23f8d --- /dev/null +++ b/3rdparty/curl-8.21.0/CMake/FindLDAP.cmake @@ -0,0 +1,115 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# Find the ldap library +# +# Input variables: +# +# - `LDAP_INCLUDE_DIR`: Absolute path to ldap include directory. +# - `LDAP_LIBRARY`: Absolute path to `ldap` library. +# - `LDAP_LBER_LIBRARY`: Absolute path to `lber` library. +# +# Defines: +# +# - `LDAP_FOUND`: System has ldap. +# - `LDAP_VERSION`: Version of ldap. +# - `CURL::ldap`: ldap library target. + +set(_ldap_pc_requires "ldap" "lber") + +if(CURL_USE_PKGCONFIG AND + NOT DEFINED LDAP_INCLUDE_DIR AND + NOT DEFINED LDAP_LIBRARY AND + NOT DEFINED LDAP_LBER_LIBRARY) + find_package(PkgConfig QUIET) + pkg_check_modules(_ldap ${_ldap_pc_requires}) +endif() + +if(_ldap_FOUND) + set(LDAP_FOUND TRUE) + set(LDAP_VERSION ${_ldap_ldap_VERSION}) + message(STATUS "Found LDAP (via pkg-config): ${_ldap_INCLUDE_DIRS} (found version \"${LDAP_VERSION}\")") +else() + set(_ldap_pc_requires "") # Depend on pkg-config only when found via pkg-config + + # On Apple the SDK LDAP gets picked up from + # 'MacOSX.sdk/System/Library/Frameworks/LDAP.framework/Headers', which contains + # ldap.h and lber.h both being stubs to include and . + # This causes an infinite inclusion loop in compile. Also do this for libraries + # to avoid picking up the 'ldap.framework' with a full path. + set(_save_cmake_system_framework_path ${CMAKE_SYSTEM_FRAMEWORK_PATH}) + set(CMAKE_SYSTEM_FRAMEWORK_PATH "") + find_path(LDAP_INCLUDE_DIR NAMES "ldap.h") + find_library(LDAP_LIBRARY NAMES "ldap") + find_library(LDAP_LBER_LIBRARY NAMES "lber") + set(CMAKE_SYSTEM_FRAMEWORK_PATH ${_save_cmake_system_framework_path}) + + unset(LDAP_VERSION CACHE) + if(LDAP_INCLUDE_DIR AND EXISTS "${LDAP_INCLUDE_DIR}/ldap_features.h") + set(_version_regex1 "#[\t ]*define[\t ]+LDAP_VENDOR_VERSION_MAJOR[\t ]+([0-9]+).*") + set(_version_regex2 "#[\t ]*define[\t ]+LDAP_VENDOR_VERSION_MINOR[\t ]+([0-9]+).*") + set(_version_regex3 "#[\t ]*define[\t ]+LDAP_VENDOR_VERSION_PATCH[\t ]+([0-9]+).*") + file(STRINGS "${LDAP_INCLUDE_DIR}/ldap_features.h" _version_str1 REGEX "${_version_regex1}") + file(STRINGS "${LDAP_INCLUDE_DIR}/ldap_features.h" _version_str2 REGEX "${_version_regex2}") + file(STRINGS "${LDAP_INCLUDE_DIR}/ldap_features.h" _version_str3 REGEX "${_version_regex3}") + string(REGEX REPLACE "${_version_regex1}" "\\1" _version_str1 "${_version_str1}") + string(REGEX REPLACE "${_version_regex2}" "\\1" _version_str2 "${_version_str2}") + string(REGEX REPLACE "${_version_regex3}" "\\1" _version_str3 "${_version_str3}") + set(LDAP_VERSION "${_version_str1}.${_version_str2}.${_version_str3}") + unset(_version_regex1) + unset(_version_regex2) + unset(_version_regex3) + unset(_version_str1) + unset(_version_str2) + unset(_version_str3) + endif() + + include(FindPackageHandleStandardArgs) + find_package_handle_standard_args(LDAP + REQUIRED_VARS + LDAP_INCLUDE_DIR + LDAP_LIBRARY + LDAP_LBER_LIBRARY + VERSION_VAR + LDAP_VERSION + ) + + if(LDAP_FOUND) + set(_ldap_INCLUDE_DIRS ${LDAP_INCLUDE_DIR}) + set(_ldap_LIBRARIES ${LDAP_LIBRARY} ${LDAP_LBER_LIBRARY}) + endif() + + mark_as_advanced(LDAP_INCLUDE_DIR LDAP_LIBRARY LDAP_LBER_LIBRARY) +endif() + +if(LDAP_FOUND) + if(NOT TARGET CURL::ldap) + add_library(CURL::ldap INTERFACE IMPORTED) + set_target_properties(CURL::ldap PROPERTIES + INTERFACE_LIBCURL_PC_MODULES "${_ldap_pc_requires}" + INTERFACE_COMPILE_OPTIONS "${_ldap_CFLAGS}" + INTERFACE_INCLUDE_DIRECTORIES "${_ldap_INCLUDE_DIRS}" + INTERFACE_LINK_DIRECTORIES "${_ldap_LIBRARY_DIRS}" + INTERFACE_LINK_LIBRARIES "${_ldap_LIBRARIES}") + endif() +endif() diff --git a/3rdparty/curl-8.21.0/CMake/FindLibbacktrace.cmake b/3rdparty/curl-8.21.0/CMake/FindLibbacktrace.cmake new file mode 100644 index 0000000000..59da7fdf19 --- /dev/null +++ b/3rdparty/curl-8.21.0/CMake/FindLibbacktrace.cmake @@ -0,0 +1,61 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# Find the libbacktrace library +# +# Input variables: +# +# - `LIBBACKTRACE_INCLUDE_DIR`: Absolute path to libbacktrace include directory. +# - `LIBBACKTRACE_LIBRARY`: Absolute path to `libbacktrace` library. +# +# Defines: +# +# - `LIBBACKTRACE_FOUND`: System has libbacktrace. +# - `CURL::libbacktrace`: libbacktrace library target. + +find_path(LIBBACKTRACE_INCLUDE_DIR NAMES "backtrace.h") +find_library(LIBBACKTRACE_LIBRARY NAMES "backtrace" "libbacktrace") + +include(FindPackageHandleStandardArgs) +find_package_handle_standard_args(Libbacktrace + REQUIRED_VARS + LIBBACKTRACE_INCLUDE_DIR + LIBBACKTRACE_LIBRARY +) + +if(LIBBACKTRACE_FOUND) + set(_libbacktrace_INCLUDE_DIRS ${LIBBACKTRACE_INCLUDE_DIR}) + set(_libbacktrace_LIBRARIES ${LIBBACKTRACE_LIBRARY}) + + if(NOT TARGET CURL::libbacktrace) + add_library(CURL::libbacktrace INTERFACE IMPORTED) + set_target_properties(CURL::libbacktrace PROPERTIES + INTERFACE_LIBCURL_PC_MODULES "${_libbacktrace_pc_requires}" + INTERFACE_COMPILE_OPTIONS "${_libbacktrace_CFLAGS}" + INTERFACE_INCLUDE_DIRECTORIES "${_libbacktrace_INCLUDE_DIRS}" + INTERFACE_LINK_DIRECTORIES "${_libbacktrace_LIBRARY_DIRS}" + INTERFACE_LINK_LIBRARIES "${_libbacktrace_LIBRARIES}") + endif() +endif() + +mark_as_advanced(LIBBACKTRACE_INCLUDE_DIR LIBBACKTRACE_LIBRARY) diff --git a/3rdparty/curl-8.21.0/CMake/FindLibgsasl.cmake b/3rdparty/curl-8.21.0/CMake/FindLibgsasl.cmake new file mode 100644 index 0000000000..7fbaa7128f --- /dev/null +++ b/3rdparty/curl-8.21.0/CMake/FindLibgsasl.cmake @@ -0,0 +1,91 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# Find the libgsasl library +# +# Input variables: +# +# - `LIBGSASL_INCLUDE_DIR`: Absolute path to libgsasl include directory. +# - `LIBGSASL_LIBRARY`: Absolute path to `libgsasl` library. +# +# Defines: +# +# - `LIBGSASL_FOUND`: System has libgsasl. +# - `LIBGSASL_VERSION`: Version of libgsasl. +# - `CURL::libgsasl`: libgsasl library target. + +set(_libgsasl_pc_requires "libgsasl") + +if(CURL_USE_PKGCONFIG AND + NOT DEFINED LIBGSASL_INCLUDE_DIR AND + NOT DEFINED LIBGSASL_LIBRARY) + find_package(PkgConfig QUIET) + pkg_check_modules(_libgsasl ${_libgsasl_pc_requires}) +endif() + +if(_libgsasl_FOUND) + set(Libgsasl_FOUND TRUE) + set(LIBGSASL_FOUND TRUE) + message(STATUS "Found Libgsasl (via pkg-config): ${_libgsasl_INCLUDE_DIRS} (found version \"${LIBGSASL_VERSION}\")") +else() + find_path(LIBGSASL_INCLUDE_DIR NAMES "gsasl.h") + find_library(LIBGSASL_LIBRARY NAMES "gsasl" "libgsasl") + + unset(LIBGSASL_VERSION CACHE) + if(LIBGSASL_INCLUDE_DIR AND EXISTS "${LIBGSASL_INCLUDE_DIR}/gsasl-version.h") + set(_version_regex "#[\t ]*define[\t ]+GSASL_VERSION[\t ]+\"([^\"]*)\"") + file(STRINGS "${LIBGSASL_INCLUDE_DIR}/gsasl-version.h" _version_str REGEX "${_version_regex}") + string(REGEX REPLACE "${_version_regex}" "\\1" _version_str "${_version_str}") + set(LIBGSASL_VERSION "${_version_str}") + unset(_version_regex) + unset(_version_str) + endif() + + include(FindPackageHandleStandardArgs) + find_package_handle_standard_args(Libgsasl + REQUIRED_VARS + LIBGSASL_INCLUDE_DIR + LIBGSASL_LIBRARY + VERSION_VAR + LIBGSASL_VERSION + ) + + if(LIBGSASL_FOUND) + set(_libgsasl_INCLUDE_DIRS ${LIBGSASL_INCLUDE_DIR}) + set(_libgsasl_LIBRARIES ${LIBGSASL_LIBRARY}) + endif() + + mark_as_advanced(LIBGSASL_INCLUDE_DIR LIBGSASL_LIBRARY) +endif() + +if(LIBGSASL_FOUND) + if(NOT TARGET CURL::libgsasl) + add_library(CURL::libgsasl INTERFACE IMPORTED) + set_target_properties(CURL::libgsasl PROPERTIES + INTERFACE_LIBCURL_PC_MODULES "${_libgsasl_pc_requires}" + INTERFACE_COMPILE_OPTIONS "${_libgsasl_CFLAGS}" + INTERFACE_INCLUDE_DIRECTORIES "${_libgsasl_INCLUDE_DIRS}" + INTERFACE_LINK_DIRECTORIES "${_libgsasl_LIBRARY_DIRS}" + INTERFACE_LINK_LIBRARIES "${_libgsasl_LIBRARIES}") + endif() +endif() diff --git a/3rdparty/curl-8.21.0/CMake/FindLibidn2.cmake b/3rdparty/curl-8.21.0/CMake/FindLibidn2.cmake new file mode 100644 index 0000000000..dc7873489a --- /dev/null +++ b/3rdparty/curl-8.21.0/CMake/FindLibidn2.cmake @@ -0,0 +1,92 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# Find the libidn2 library +# +# Input variables: +# +# - `LIBIDN2_INCLUDE_DIR`: Absolute path to libidn2 include directory. +# - `LIBIDN2_LIBRARY`: Absolute path to `libidn2` library. +# +# Defines: +# +# - `LIBIDN2_FOUND`: System has libidn2. +# - `LIBIDN2_VERSION`: Version of libidn2. +# - `CURL::libidn2`: libidn2 library target. + +set(_libidn2_pc_requires "libidn2") + +if(CURL_USE_PKGCONFIG AND + NOT DEFINED LIBIDN2_INCLUDE_DIR AND + NOT DEFINED LIBIDN2_LIBRARY) + find_package(PkgConfig QUIET) + pkg_check_modules(_libidn2 ${_libidn2_pc_requires}) +endif() + +if(_libidn2_FOUND) + set(Libidn2_FOUND TRUE) + set(LIBIDN2_FOUND TRUE) + set(LIBIDN2_VERSION ${_libidn2_VERSION}) + message(STATUS "Found Libidn2 (via pkg-config): ${_libidn2_INCLUDE_DIRS} (found version \"${LIBIDN2_VERSION}\")") +else() + find_path(LIBIDN2_INCLUDE_DIR NAMES "idn2.h") + find_library(LIBIDN2_LIBRARY NAMES "idn2" "libidn2") + + unset(LIBIDN2_VERSION CACHE) + if(LIBIDN2_INCLUDE_DIR AND EXISTS "${LIBIDN2_INCLUDE_DIR}/idn2.h") + set(_version_regex "#[\t ]*define[\t ]+IDN2_VERSION[\t ]+\"([^\"]*)\"") + file(STRINGS "${LIBIDN2_INCLUDE_DIR}/idn2.h" _version_str REGEX "${_version_regex}") + string(REGEX REPLACE "${_version_regex}" "\\1" _version_str "${_version_str}") + set(LIBIDN2_VERSION "${_version_str}") + unset(_version_regex) + unset(_version_str) + endif() + + include(FindPackageHandleStandardArgs) + find_package_handle_standard_args(Libidn2 + REQUIRED_VARS + LIBIDN2_INCLUDE_DIR + LIBIDN2_LIBRARY + VERSION_VAR + LIBIDN2_VERSION + ) + + if(LIBIDN2_FOUND) + set(_libidn2_INCLUDE_DIRS ${LIBIDN2_INCLUDE_DIR}) + set(_libidn2_LIBRARIES ${LIBIDN2_LIBRARY}) + endif() + + mark_as_advanced(LIBIDN2_INCLUDE_DIR LIBIDN2_LIBRARY) +endif() + +if(LIBIDN2_FOUND) + if(NOT TARGET CURL::libidn2) + add_library(CURL::libidn2 INTERFACE IMPORTED) + set_target_properties(CURL::libidn2 PROPERTIES + INTERFACE_LIBCURL_PC_MODULES "${_libidn2_pc_requires}" + INTERFACE_COMPILE_OPTIONS "${_libidn2_CFLAGS}" + INTERFACE_INCLUDE_DIRECTORIES "${_libidn2_INCLUDE_DIRS}" + INTERFACE_LINK_DIRECTORIES "${_libidn2_LIBRARY_DIRS}" + INTERFACE_LINK_LIBRARIES "${_libidn2_LIBRARIES}") + endif() +endif() diff --git a/3rdparty/curl-8.21.0/CMake/FindLibpsl.cmake b/3rdparty/curl-8.21.0/CMake/FindLibpsl.cmake new file mode 100644 index 0000000000..2287e676d3 --- /dev/null +++ b/3rdparty/curl-8.21.0/CMake/FindLibpsl.cmake @@ -0,0 +1,92 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# Find the libpsl library +# +# Input variables: +# +# - `LIBPSL_INCLUDE_DIR`: Absolute path to libpsl include directory. +# - `LIBPSL_LIBRARY`: Absolute path to `libpsl` library. +# +# Defines: +# +# - `LIBPSL_FOUND`: System has libpsl. +# - `LIBPSL_VERSION`: Version of libpsl. +# - `CURL::libpsl`: libpsl library target. + +set(_libpsl_pc_requires "libpsl") + +if(CURL_USE_PKGCONFIG AND + NOT DEFINED LIBPSL_INCLUDE_DIR AND + NOT DEFINED LIBPSL_LIBRARY) + find_package(PkgConfig QUIET) + pkg_check_modules(_libpsl ${_libpsl_pc_requires}) +endif() + +if(_libpsl_FOUND AND _libpsl_INCLUDE_DIRS) + set(Libpsl_FOUND TRUE) + set(LIBPSL_FOUND TRUE) + set(LIBPSL_VERSION ${_libpsl_VERSION}) + message(STATUS "Found Libpsl (via pkg-config): ${_libpsl_INCLUDE_DIRS} (found version \"${LIBPSL_VERSION}\")") +else() + find_path(LIBPSL_INCLUDE_DIR NAMES "libpsl.h") + find_library(LIBPSL_LIBRARY NAMES "psl" "libpsl") + + unset(LIBPSL_VERSION CACHE) + if(LIBPSL_INCLUDE_DIR AND EXISTS "${LIBPSL_INCLUDE_DIR}/libpsl.h") + set(_version_regex "#[\t ]*define[\t ]+PSL_VERSION[\t ]+\"([^\"]*)\"") + file(STRINGS "${LIBPSL_INCLUDE_DIR}/libpsl.h" _version_str REGEX "${_version_regex}") + string(REGEX REPLACE "${_version_regex}" "\\1" _version_str "${_version_str}") + set(LIBPSL_VERSION "${_version_str}") + unset(_version_regex) + unset(_version_str) + endif() + + include(FindPackageHandleStandardArgs) + find_package_handle_standard_args(Libpsl + REQUIRED_VARS + LIBPSL_INCLUDE_DIR + LIBPSL_LIBRARY + VERSION_VAR + LIBPSL_VERSION + ) + + if(LIBPSL_FOUND) + set(_libpsl_INCLUDE_DIRS ${LIBPSL_INCLUDE_DIR}) + set(_libpsl_LIBRARIES ${LIBPSL_LIBRARY}) + endif() + + mark_as_advanced(LIBPSL_INCLUDE_DIR LIBPSL_LIBRARY) +endif() + +if(LIBPSL_FOUND) + if(NOT TARGET CURL::libpsl) + add_library(CURL::libpsl INTERFACE IMPORTED) + set_target_properties(CURL::libpsl PROPERTIES + INTERFACE_LIBCURL_PC_MODULES "${_libpsl_pc_requires}" + INTERFACE_COMPILE_OPTIONS "${_libpsl_CFLAGS}" + INTERFACE_INCLUDE_DIRECTORIES "${_libpsl_INCLUDE_DIRS}" + INTERFACE_LINK_DIRECTORIES "${_libpsl_LIBRARY_DIRS}" + INTERFACE_LINK_LIBRARIES "${_libpsl_LIBRARIES}") + endif() +endif() diff --git a/3rdparty/curl-8.21.0/CMake/FindLibssh.cmake b/3rdparty/curl-8.21.0/CMake/FindLibssh.cmake new file mode 100644 index 0000000000..3837d4de62 --- /dev/null +++ b/3rdparty/curl-8.21.0/CMake/FindLibssh.cmake @@ -0,0 +1,118 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# Find the libssh library +# +# Input variables: +# +# - `LIBSSH_INCLUDE_DIR`: Absolute path to libssh include directory. +# - `LIBSSH_LIBRARY`: Absolute path to `libssh` library. +# - `LIBSSH_USE_STATIC_LIBS`: Configure for static libssh libraries. +# +# Defines: +# +# - `LIBSSH_FOUND`: System has libssh. +# - `LIBSSH_VERSION`: Version of libssh. +# - `CURL::libssh`: libssh library target. + +set(_libssh_pc_requires "libssh") + +if(CURL_USE_PKGCONFIG AND + NOT DEFINED LIBSSH_INCLUDE_DIR AND + NOT DEFINED LIBSSH_LIBRARY) + find_package(PkgConfig QUIET) + pkg_check_modules(_libssh ${_libssh_pc_requires}) +endif() + +if(_libssh_FOUND) + set(Libssh_FOUND TRUE) + set(LIBSSH_FOUND TRUE) + set(LIBSSH_VERSION ${_libssh_VERSION}) + if(LIBSSH_USE_STATIC_LIBS) + set(_libssh_CFLAGS "${_libssh_STATIC_CFLAGS}") + set(_libssh_INCLUDE_DIRS "${_libssh_STATIC_INCLUDE_DIRS}") + set(_libssh_LIBRARY_DIRS "${_libssh_STATIC_LIBRARY_DIRS}") + set(_libssh_LIBRARIES "${_libssh_STATIC_LIBRARIES}") + endif() + message(STATUS "Found Libssh (via pkg-config): ${_libssh_INCLUDE_DIRS} (found version \"${LIBSSH_VERSION}\")") +else() + find_path(LIBSSH_INCLUDE_DIR NAMES "libssh/libssh.h") + if(LIBSSH_USE_STATIC_LIBS) + set(_libssh_CFLAGS "-DLIBSSH_STATIC") + find_library(LIBSSH_LIBRARY NAMES "ssh_static" "libssh_static" "ssh" "libssh") + else() + find_library(LIBSSH_LIBRARY NAMES "ssh" "libssh") + endif() + + unset(LIBSSH_VERSION CACHE) + if(LIBSSH_INCLUDE_DIR AND EXISTS "${LIBSSH_INCLUDE_DIR}/libssh/libssh_version.h") + set(_version_regex1 "#[\t ]*define[\t ]+LIBSSH_VERSION_MAJOR[\t ]+([0-9]+).*") + set(_version_regex2 "#[\t ]*define[\t ]+LIBSSH_VERSION_MINOR[\t ]+([0-9]+).*") + set(_version_regex3 "#[\t ]*define[\t ]+LIBSSH_VERSION_MICRO[\t ]+([0-9]+).*") + file(STRINGS "${LIBSSH_INCLUDE_DIR}/libssh/libssh_version.h" _version_str1 REGEX "${_version_regex1}") + file(STRINGS "${LIBSSH_INCLUDE_DIR}/libssh/libssh_version.h" _version_str2 REGEX "${_version_regex2}") + file(STRINGS "${LIBSSH_INCLUDE_DIR}/libssh/libssh_version.h" _version_str3 REGEX "${_version_regex3}") + string(REGEX REPLACE "${_version_regex1}" "\\1" _version_str1 "${_version_str1}") + string(REGEX REPLACE "${_version_regex2}" "\\1" _version_str2 "${_version_str2}") + string(REGEX REPLACE "${_version_regex3}" "\\1" _version_str3 "${_version_str3}") + set(LIBSSH_VERSION "${_version_str1}.${_version_str2}.${_version_str3}") + unset(_version_regex1) + unset(_version_regex2) + unset(_version_regex3) + unset(_version_str1) + unset(_version_str2) + unset(_version_str3) + endif() + + include(FindPackageHandleStandardArgs) + find_package_handle_standard_args(Libssh + REQUIRED_VARS + LIBSSH_INCLUDE_DIR + LIBSSH_LIBRARY + VERSION_VAR + LIBSSH_VERSION + ) + + if(LIBSSH_FOUND) + set(_libssh_INCLUDE_DIRS ${LIBSSH_INCLUDE_DIR}) + set(_libssh_LIBRARIES ${LIBSSH_LIBRARY}) + endif() + + mark_as_advanced(LIBSSH_INCLUDE_DIR LIBSSH_LIBRARY) +endif() + +if(LIBSSH_FOUND) + if(WIN32) + list(APPEND _libssh_LIBRARIES "iphlpapi") # for if_nametoindex + endif() + + if(NOT TARGET CURL::libssh) + add_library(CURL::libssh INTERFACE IMPORTED) + set_target_properties(CURL::libssh PROPERTIES + INTERFACE_LIBCURL_PC_MODULES "${_libssh_pc_requires}" + INTERFACE_COMPILE_OPTIONS "${_libssh_CFLAGS}" + INTERFACE_INCLUDE_DIRECTORIES "${_libssh_INCLUDE_DIRS}" + INTERFACE_LINK_DIRECTORIES "${_libssh_LIBRARY_DIRS}" + INTERFACE_LINK_LIBRARIES "${_libssh_LIBRARIES}") + endif() +endif() diff --git a/3rdparty/curl-8.21.0/CMake/FindLibssh2.cmake b/3rdparty/curl-8.21.0/CMake/FindLibssh2.cmake new file mode 100644 index 0000000000..22481d67ae --- /dev/null +++ b/3rdparty/curl-8.21.0/CMake/FindLibssh2.cmake @@ -0,0 +1,117 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# Find the libssh2 library +# +# Input variables: +# +# - `LIBSSH2_INCLUDE_DIR`: Absolute path to libssh2 include directory. +# - `LIBSSH2_LIBRARY`: Absolute path to `libssh2` library. +# - `LIBSSH2_USE_STATIC_LIBS`: Configure for static libssh2 libraries. +# +# Defines: +# +# - `LIBSSH2_FOUND`: System has libssh2. +# - `LIBSSH2_VERSION`: Version of libssh2. +# - `CURL::libssh2`: libssh2 library target. + +set(_libssh2_pc_requires "libssh2") + +if(NOT DEFINED LIBSSH2_INCLUDE_DIR AND + NOT DEFINED LIBSSH2_LIBRARY) + if(CURL_USE_PKGCONFIG) + find_package(PkgConfig QUIET) + pkg_check_modules(_libssh2 ${_libssh2_pc_requires}) + endif() + if(NOT _libssh2_FOUND AND CURL_USE_CMAKECONFIG) + find_package(libssh2 CONFIG QUIET) + endif() +endif() + +if(_libssh2_FOUND AND _libssh2_INCLUDE_DIRS) + set(Libssh2_FOUND TRUE) + set(LIBSSH2_FOUND TRUE) + set(LIBSSH2_VERSION ${_libssh2_VERSION}) + if(LIBSSH2_USE_STATIC_LIBS) + set(_libssh2_CFLAGS "${_libssh2_STATIC_CFLAGS}") + set(_libssh2_INCLUDE_DIRS "${_libssh2_STATIC_INCLUDE_DIRS}") + set(_libssh2_LIBRARY_DIRS "${_libssh2_STATIC_LIBRARY_DIRS}") + set(_libssh2_LIBRARIES "${_libssh2_STATIC_LIBRARIES}") + endif() + message(STATUS "Found Libssh2 (via pkg-config): ${_libssh2_INCLUDE_DIRS} (found version \"${LIBSSH2_VERSION}\")") +elseif(libssh2_CONFIG) + set(Libssh2_FOUND TRUE) + set(LIBSSH2_FOUND TRUE) + set(LIBSSH2_VERSION ${libssh2_VERSION}) + if(LIBSSH2_USE_STATIC_LIBS) + set(_libssh2_LIBRARIES libssh2::libssh2_static) + else() + set(_libssh2_LIBRARIES libssh2::libssh2) + endif() + message(STATUS "Found Libssh2 (via CMake Config): ${libssh2_CONFIG} (found version \"${LIBSSH2_VERSION}\")") +else() + find_path(LIBSSH2_INCLUDE_DIR NAMES "libssh2.h") + if(LIBSSH2_USE_STATIC_LIBS) + find_library(LIBSSH2_LIBRARY NAMES "ssh2_static" "libssh2_static" "ssh2" "libssh2") + else() + find_library(LIBSSH2_LIBRARY NAMES "ssh2" "libssh2") + endif() + + unset(LIBSSH2_VERSION CACHE) + if(LIBSSH2_INCLUDE_DIR AND EXISTS "${LIBSSH2_INCLUDE_DIR}/libssh2.h") + set(_version_regex "#[\t ]*define[\t ]+LIBSSH2_VERSION[\t ]+\"([^\"]*)\"") + file(STRINGS "${LIBSSH2_INCLUDE_DIR}/libssh2.h" _version_str REGEX "${_version_regex}") + string(REGEX REPLACE "${_version_regex}" "\\1" _version_str "${_version_str}") + set(LIBSSH2_VERSION "${_version_str}") + unset(_version_regex) + unset(_version_str) + endif() + + include(FindPackageHandleStandardArgs) + find_package_handle_standard_args(Libssh2 + REQUIRED_VARS + LIBSSH2_INCLUDE_DIR + LIBSSH2_LIBRARY + VERSION_VAR + LIBSSH2_VERSION + ) + + if(LIBSSH2_FOUND) + set(_libssh2_INCLUDE_DIRS ${LIBSSH2_INCLUDE_DIR}) + set(_libssh2_LIBRARIES ${LIBSSH2_LIBRARY}) + endif() + + mark_as_advanced(LIBSSH2_INCLUDE_DIR LIBSSH2_LIBRARY) +endif() + +if(LIBSSH2_FOUND) + if(NOT TARGET CURL::libssh2) + add_library(CURL::libssh2 INTERFACE IMPORTED) + set_target_properties(CURL::libssh2 PROPERTIES + INTERFACE_LIBCURL_PC_MODULES "${_libssh2_pc_requires}" + INTERFACE_COMPILE_OPTIONS "${_libssh2_CFLAGS}" + INTERFACE_INCLUDE_DIRECTORIES "${_libssh2_INCLUDE_DIRS}" + INTERFACE_LINK_DIRECTORIES "${_libssh2_LIBRARY_DIRS}" + INTERFACE_LINK_LIBRARIES "${_libssh2_LIBRARIES}") + endif() +endif() diff --git a/3rdparty/curl-8.21.0/CMake/FindLibuv.cmake b/3rdparty/curl-8.21.0/CMake/FindLibuv.cmake new file mode 100644 index 0000000000..47d043cff6 --- /dev/null +++ b/3rdparty/curl-8.21.0/CMake/FindLibuv.cmake @@ -0,0 +1,102 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# Find the libuv library +# +# Input variables: +# +# - `LIBUV_INCLUDE_DIR`: Absolute path to libuv include directory. +# - `LIBUV_LIBRARY`: Absolute path to `libuv` library. +# +# Defines: +# +# - `LIBUV_FOUND`: System has libuv. +# - `LIBUV_VERSION`: Version of libuv. +# - `CURL::libuv`: libuv library target. + +set(_libuv_pc_requires "libuv") + +if(CURL_USE_PKGCONFIG AND + NOT DEFINED LIBUV_INCLUDE_DIR AND + NOT DEFINED LIBUV_LIBRARY) + find_package(PkgConfig QUIET) + pkg_check_modules(_libuv ${_libuv_pc_requires}) +endif() + +if(_libuv_FOUND) + set(Libuv_FOUND TRUE) + set(LIBUV_FOUND TRUE) + set(LIBUV_VERSION ${_libuv_VERSION}) + message(STATUS "Found Libuv (via pkg-config): ${_libuv_INCLUDE_DIRS} (found version \"${LIBUV_VERSION}\")") +else() + find_path(LIBUV_INCLUDE_DIR NAMES "uv.h") + find_library(LIBUV_LIBRARY NAMES "uv" "libuv") + + unset(LIBUV_VERSION CACHE) + if(LIBUV_INCLUDE_DIR AND EXISTS "${LIBUV_INCLUDE_DIR}/uv/version.h") + set(_version_regex1 "#[\t ]*define[\t ]+UV_VERSION_MAJOR[\t ]+([0-9]+).*") + set(_version_regex2 "#[\t ]*define[\t ]+UV_VERSION_MINOR[\t ]+([0-9]+).*") + set(_version_regex3 "#[\t ]*define[\t ]+UV_VERSION_PATCH[\t ]+([0-9]+).*") + file(STRINGS "${LIBUV_INCLUDE_DIR}/uv/version.h" _version_str1 REGEX "${_version_regex1}") + file(STRINGS "${LIBUV_INCLUDE_DIR}/uv/version.h" _version_str2 REGEX "${_version_regex2}") + file(STRINGS "${LIBUV_INCLUDE_DIR}/uv/version.h" _version_str3 REGEX "${_version_regex3}") + string(REGEX REPLACE "${_version_regex1}" "\\1" _version_str1 "${_version_str1}") + string(REGEX REPLACE "${_version_regex2}" "\\1" _version_str2 "${_version_str2}") + string(REGEX REPLACE "${_version_regex3}" "\\1" _version_str3 "${_version_str3}") + set(LIBUV_VERSION "${_version_str1}.${_version_str2}.${_version_str3}") + unset(_version_regex1) + unset(_version_regex2) + unset(_version_regex3) + unset(_version_str1) + unset(_version_str2) + unset(_version_str3) + endif() + + include(FindPackageHandleStandardArgs) + find_package_handle_standard_args(Libuv + REQUIRED_VARS + LIBUV_INCLUDE_DIR + LIBUV_LIBRARY + VERSION_VAR + LIBUV_VERSION + ) + + if(LIBUV_FOUND) + set(_libuv_INCLUDE_DIRS ${LIBUV_INCLUDE_DIR}) + set(_libuv_LIBRARIES ${LIBUV_LIBRARY}) + endif() + + mark_as_advanced(LIBUV_INCLUDE_DIR LIBUV_LIBRARY) +endif() + +if(LIBUV_FOUND) + if(NOT TARGET CURL::libuv) + add_library(CURL::libuv INTERFACE IMPORTED) + set_target_properties(CURL::libuv PROPERTIES + INTERFACE_LIBCURL_PC_MODULES "${_libuv_pc_requires}" + INTERFACE_COMPILE_OPTIONS "${_libuv_CFLAGS}" + INTERFACE_INCLUDE_DIRECTORIES "${_libuv_INCLUDE_DIRS}" + INTERFACE_LINK_DIRECTORIES "${_libuv_LIBRARY_DIRS}" + INTERFACE_LINK_LIBRARIES "${_libuv_LIBRARIES}") + endif() +endif() diff --git a/3rdparty/curl-8.21.0/CMake/FindMbedTLS.cmake b/3rdparty/curl-8.21.0/CMake/FindMbedTLS.cmake new file mode 100644 index 0000000000..21a5f4aec7 --- /dev/null +++ b/3rdparty/curl-8.21.0/CMake/FindMbedTLS.cmake @@ -0,0 +1,137 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# Find the mbedTLS library +# +# Input variables: +# +# - `MBEDTLS_INCLUDE_DIR`: Absolute path to mbedTLS include directory. +# - `MBEDTLS_LIBRARY`: Absolute path to `mbedtls` library. +# - `MBEDX509_LIBRARY`: Absolute path to `mbedx509` library. +# - `MBEDCRYPTO_LIBRARY`: Absolute path to `mbedcrypto` library. +# - `MBEDTLS_USE_STATIC_LIBS`: Configure for static mbedTLS libraries. +# +# Defines: +# +# - `MBEDTLS_FOUND`: System has mbedTLS. +# - `MBEDTLS_VERSION`: Version of mbedTLS. +# - `CURL::mbedtls`: mbedTLS library target. + +if(DEFINED MBEDTLS_INCLUDE_DIRS AND NOT DEFINED MBEDTLS_INCLUDE_DIR) + message(WARNING "MBEDTLS_INCLUDE_DIRS is deprecated, use MBEDTLS_INCLUDE_DIR instead.") + set(MBEDTLS_INCLUDE_DIR "${MBEDTLS_INCLUDE_DIRS}") + unset(MBEDTLS_INCLUDE_DIRS) +endif() + +set(_mbedtls_pc_requires "mbedtls" "mbedx509" "mbedcrypto") + +if(NOT DEFINED MBEDTLS_INCLUDE_DIR AND + NOT DEFINED MBEDTLS_LIBRARY AND + NOT DEFINED MBEDX509_LIBRARY AND + NOT DEFINED MBEDCRYPTO_LIBRARY) + if(CURL_USE_PKGCONFIG) + find_package(PkgConfig QUIET) + pkg_check_modules(_mbedtls ${_mbedtls_pc_requires}) + endif() + if(NOT _mbedtls_FOUND AND CURL_USE_CMAKECONFIG) + find_package(MbedTLS CONFIG QUIET) + endif() +endif() + +if(_mbedtls_FOUND) + set(MbedTLS_FOUND TRUE) + set(MBEDTLS_FOUND TRUE) + set(MBEDTLS_VERSION ${_mbedtls_mbedtls_VERSION}) + if(MBEDTLS_USE_STATIC_LIBS) + set(_mbedtls_CFLAGS "${_mbedtls_STATIC_CFLAGS}") + set(_mbedtls_INCLUDE_DIRS "${_mbedtls_STATIC_INCLUDE_DIRS}") + set(_mbedtls_LIBRARY_DIRS "${_mbedtls_STATIC_LIBRARY_DIRS}") + set(_mbedtls_LIBRARIES "${_mbedtls_STATIC_LIBRARIES}") + endif() + message(STATUS "Found MbedTLS (via pkg-config): ${_mbedtls_INCLUDE_DIRS} (found version \"${MBEDTLS_VERSION}\")") +elseif(MbedTLS_CONFIG) + set(MbedTLS_FOUND TRUE) + set(MBEDTLS_FOUND TRUE) + set(MBEDTLS_VERSION ${MbedTLS_VERSION}) + if(MBEDTLS_VERSION GREATER_EQUAL 4.0.0) + set(_mbedtls_LIBRARIES MbedTLS::tfpsacrypto) + else() + set(_mbedtls_LIBRARIES MbedTLS::mbedcrypto) + endif() + list(APPEND _mbedtls_LIBRARIES MbedTLS::mbedx509 MbedTLS::mbedtls) + message(STATUS "Found MbedTLS (via CMake Config): ${MbedTLS_CONFIG} (found version \"${MBEDTLS_VERSION}\")") +else() + set(_mbedtls_pc_requires "") # Depend on pkg-config only when found via pkg-config + + find_path(MBEDTLS_INCLUDE_DIR NAMES "mbedtls/ssl.h") + if(MBEDTLS_USE_STATIC_LIBS) + find_library(MBEDTLS_LIBRARY NAMES "mbedtls_static" "libmbedtls_static" "mbedtls" "libmbedtls") + find_library(MBEDX509_LIBRARY NAMES "mbedx509_static" "libmbedx509_static" "mbedx509" "libmbedx509") + find_library(MBEDCRYPTO_LIBRARY NAMES "mbedcrypto_static" "libmbedcrypto_static" "mbedcrypto" "libmbedcrypto" + "tfpsacrypto_static" "libtfpsacrypto_static" "tfpsacrypto" "libtfpsacrypto") + else() + find_library(MBEDTLS_LIBRARY NAMES "mbedtls" "libmbedtls") + find_library(MBEDX509_LIBRARY NAMES "mbedx509" "libmbedx509") + find_library(MBEDCRYPTO_LIBRARY NAMES "mbedcrypto" "libmbedcrypto" "tfpsacrypto" "libtfpsacrypto") + endif() + + unset(MBEDTLS_VERSION CACHE) + if(MBEDTLS_INCLUDE_DIR AND EXISTS "${MBEDTLS_INCLUDE_DIR}/mbedtls/build_info.h") + set(_version_regex "#[\t ]*define[\t ]+MBEDTLS_VERSION_STRING[\t ]+\"([0-9.]+)\"") + file(STRINGS "${MBEDTLS_INCLUDE_DIR}/mbedtls/build_info.h" _version_str REGEX "${_version_regex}") + string(REGEX REPLACE "${_version_regex}" "\\1" _version_str "${_version_str}") + set(MBEDTLS_VERSION "${_version_str}") + unset(_version_regex) + unset(_version_str) + endif() + + include(FindPackageHandleStandardArgs) + find_package_handle_standard_args(MbedTLS + REQUIRED_VARS + MBEDTLS_INCLUDE_DIR + MBEDTLS_LIBRARY + MBEDX509_LIBRARY + MBEDCRYPTO_LIBRARY + VERSION_VAR + MBEDTLS_VERSION + ) + + if(MBEDTLS_FOUND) + set(_mbedtls_INCLUDE_DIRS ${MBEDTLS_INCLUDE_DIR}) + set(_mbedtls_LIBRARIES ${MBEDTLS_LIBRARY} ${MBEDX509_LIBRARY} ${MBEDCRYPTO_LIBRARY}) + endif() + + mark_as_advanced(MBEDTLS_INCLUDE_DIR MBEDTLS_LIBRARY MBEDX509_LIBRARY MBEDCRYPTO_LIBRARY) +endif() + +if(MBEDTLS_FOUND) + if(NOT TARGET CURL::mbedtls) + add_library(CURL::mbedtls INTERFACE IMPORTED) + set_target_properties(CURL::mbedtls PROPERTIES + INTERFACE_LIBCURL_PC_MODULES "${_mbedtls_pc_requires}" + INTERFACE_COMPILE_OPTIONS "${_mbedtls_CFLAGS}" + INTERFACE_INCLUDE_DIRECTORIES "${_mbedtls_INCLUDE_DIRS}" + INTERFACE_LINK_DIRECTORIES "${_mbedtls_LIBRARY_DIRS}" + INTERFACE_LINK_LIBRARIES "${_mbedtls_LIBRARIES}") + endif() +endif() diff --git a/3rdparty/curl-8.21.0/CMake/FindNGHTTP2.cmake b/3rdparty/curl-8.21.0/CMake/FindNGHTTP2.cmake new file mode 100644 index 0000000000..bca7cf8a81 --- /dev/null +++ b/3rdparty/curl-8.21.0/CMake/FindNGHTTP2.cmake @@ -0,0 +1,116 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# Find the nghttp2 library +# +# Input variables: +# +# - `NGHTTP2_INCLUDE_DIR`: Absolute path to nghttp2 include directory. +# - `NGHTTP2_LIBRARY`: Absolute path to `nghttp2` library. +# - `NGHTTP2_USE_STATIC_LIBS`: Configure for static nghttp2 libraries. +# +# Defines: +# +# - `NGHTTP2_FOUND`: System has nghttp2. +# - `NGHTTP2_VERSION`: Version of nghttp2. +# - `CURL::nghttp2`: nghttp2 library target. + +set(_nghttp2_pc_requires "libnghttp2") + +if(NOT DEFINED NGHTTP2_INCLUDE_DIR AND + NOT DEFINED NGHTTP2_LIBRARY) + if(CURL_USE_PKGCONFIG) + find_package(PkgConfig QUIET) + pkg_check_modules(_nghttp2 ${_nghttp2_pc_requires}) + endif() + if(NOT _nghttp2_FOUND AND CURL_USE_CMAKECONFIG) + find_package(nghttp2 CONFIG QUIET) + endif() +endif() + +if(_nghttp2_FOUND) + set(NGHTTP2_FOUND TRUE) + set(NGHTTP2_VERSION ${_nghttp2_VERSION}) + if(NGHTTP2_USE_STATIC_LIBS) + set(_nghttp2_CFLAGS "${_nghttp2_STATIC_CFLAGS}") + set(_nghttp2_INCLUDE_DIRS "${_nghttp2_STATIC_INCLUDE_DIRS}") + set(_nghttp2_LIBRARY_DIRS "${_nghttp2_STATIC_LIBRARY_DIRS}") + set(_nghttp2_LIBRARIES "${_nghttp2_STATIC_LIBRARIES}") + endif() + message(STATUS "Found NGHTTP2 (via pkg-config): ${_nghttp2_INCLUDE_DIRS} (found version \"${NGHTTP2_VERSION}\")") +elseif(nghttp2_CONFIG) + set(NGHTTP2_FOUND TRUE) + set(NGHTTP2_VERSION ${nghttp2_VERSION}) + if(NGHTTP2_USE_STATIC_LIBS OR NOT TARGET nghttp2::nghttp2) + set(_nghttp2_LIBRARIES nghttp2::nghttp2_static) + else() + set(_nghttp2_LIBRARIES nghttp2::nghttp2) + endif() + message(STATUS "Found NGHTTP2 (via CMake Config): ${nghttp2_CONFIG} (found version \"${NGHTTP2_VERSION}\")") +else() + find_path(NGHTTP2_INCLUDE_DIR NAMES "nghttp2/nghttp2.h") + if(NGHTTP2_USE_STATIC_LIBS) + set(_nghttp2_CFLAGS "-DNGHTTP2_STATICLIB") + find_library(NGHTTP2_LIBRARY NAMES "nghttp2_static" "nghttp2") + else() + find_library(NGHTTP2_LIBRARY NAMES "nghttp2" "nghttp2_static") + endif() + + unset(NGHTTP2_VERSION CACHE) + if(NGHTTP2_INCLUDE_DIR AND EXISTS "${NGHTTP2_INCLUDE_DIR}/nghttp2/nghttp2ver.h") + set(_version_regex "#[\t ]*define[\t ]+NGHTTP2_VERSION[\t ]+\"([^\"]*)\"") + file(STRINGS "${NGHTTP2_INCLUDE_DIR}/nghttp2/nghttp2ver.h" _version_str REGEX "${_version_regex}") + string(REGEX REPLACE "${_version_regex}" "\\1" _version_str "${_version_str}") + set(NGHTTP2_VERSION "${_version_str}") + unset(_version_regex) + unset(_version_str) + endif() + + include(FindPackageHandleStandardArgs) + find_package_handle_standard_args(NGHTTP2 + REQUIRED_VARS + NGHTTP2_INCLUDE_DIR + NGHTTP2_LIBRARY + VERSION_VAR + NGHTTP2_VERSION + ) + + if(NGHTTP2_FOUND) + set(_nghttp2_INCLUDE_DIRS ${NGHTTP2_INCLUDE_DIR}) + set(_nghttp2_LIBRARIES ${NGHTTP2_LIBRARY}) + endif() + + mark_as_advanced(NGHTTP2_INCLUDE_DIR NGHTTP2_LIBRARY) +endif() + +if(NGHTTP2_FOUND) + if(NOT TARGET CURL::nghttp2) + add_library(CURL::nghttp2 INTERFACE IMPORTED) + set_target_properties(CURL::nghttp2 PROPERTIES + INTERFACE_LIBCURL_PC_MODULES "${_nghttp2_pc_requires}" + INTERFACE_COMPILE_OPTIONS "${_nghttp2_CFLAGS}" + INTERFACE_INCLUDE_DIRECTORIES "${_nghttp2_INCLUDE_DIRS}" + INTERFACE_LINK_DIRECTORIES "${_nghttp2_LIBRARY_DIRS}" + INTERFACE_LINK_LIBRARIES "${_nghttp2_LIBRARIES}") + endif() +endif() diff --git a/3rdparty/curl-8.21.0/CMake/FindNGHTTP3.cmake b/3rdparty/curl-8.21.0/CMake/FindNGHTTP3.cmake new file mode 100644 index 0000000000..ed671b7a49 --- /dev/null +++ b/3rdparty/curl-8.21.0/CMake/FindNGHTTP3.cmake @@ -0,0 +1,116 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# Find the nghttp3 library +# +# Input variables: +# +# - `NGHTTP3_INCLUDE_DIR`: Absolute path to nghttp3 include directory. +# - `NGHTTP3_LIBRARY`: Absolute path to `nghttp3` library. +# - `NGHTTP3_USE_STATIC_LIBS`: Configure for static nghttp3 libraries. +# +# Defines: +# +# - `NGHTTP3_FOUND`: System has nghttp3. +# - `NGHTTP3_VERSION`: Version of nghttp3. +# - `CURL::nghttp3`: nghttp3 library target. + +set(_nghttp3_pc_requires "libnghttp3") + +if(NOT DEFINED NGHTTP3_INCLUDE_DIR AND + NOT DEFINED NGHTTP3_LIBRARY) + if(CURL_USE_PKGCONFIG) + find_package(PkgConfig QUIET) + pkg_check_modules(_nghttp3 ${_nghttp3_pc_requires}) + endif() + if(NOT _nghttp3_FOUND AND CURL_USE_CMAKECONFIG) + find_package(nghttp3 CONFIG QUIET) + endif() +endif() + +if(_nghttp3_FOUND) + set(NGHTTP3_FOUND TRUE) + set(NGHTTP3_VERSION ${_nghttp3_VERSION}) + if(NGHTTP3_USE_STATIC_LIBS) + set(_nghttp3_CFLAGS "${_nghttp3_STATIC_CFLAGS}") + set(_nghttp3_INCLUDE_DIRS "${_nghttp3_STATIC_INCLUDE_DIRS}") + set(_nghttp3_LIBRARY_DIRS "${_nghttp3_STATIC_LIBRARY_DIRS}") + set(_nghttp3_LIBRARIES "${_nghttp3_STATIC_LIBRARIES}") + endif() + message(STATUS "Found NGHTTP3 (via pkg-config): ${_nghttp3_INCLUDE_DIRS} (found version \"${NGHTTP3_VERSION}\")") +elseif(nghttp3_CONFIG) + set(NGHTTP3_FOUND TRUE) + set(NGHTTP3_VERSION ${nghttp3_VERSION}) + if(NGHTTP3_USE_STATIC_LIBS OR NOT TARGET nghttp3::nghttp3) + set(_nghttp3_LIBRARIES nghttp3::nghttp3_static) + else() + set(_nghttp3_LIBRARIES nghttp3::nghttp3) + endif() + message(STATUS "Found NGHTTP3 (via CMake Config): ${nghttp3_CONFIG} (found version \"${NGHTTP3_VERSION}\")") +else() + find_path(NGHTTP3_INCLUDE_DIR NAMES "nghttp3/nghttp3.h") + if(NGHTTP3_USE_STATIC_LIBS) + set(_nghttp3_CFLAGS "-DNGHTTP3_STATICLIB") + find_library(NGHTTP3_LIBRARY NAMES "nghttp3_static" "nghttp3") + else() + find_library(NGHTTP3_LIBRARY NAMES "nghttp3") + endif() + + unset(NGHTTP3_VERSION CACHE) + if(NGHTTP3_INCLUDE_DIR AND EXISTS "${NGHTTP3_INCLUDE_DIR}/nghttp3/version.h") + set(_version_regex "#[\t ]*define[\t ]+NGHTTP3_VERSION[\t ]+\"([^\"]*)\"") + file(STRINGS "${NGHTTP3_INCLUDE_DIR}/nghttp3/version.h" _version_str REGEX "${_version_regex}") + string(REGEX REPLACE "${_version_regex}" "\\1" _version_str "${_version_str}") + set(NGHTTP3_VERSION "${_version_str}") + unset(_version_regex) + unset(_version_str) + endif() + + include(FindPackageHandleStandardArgs) + find_package_handle_standard_args(NGHTTP3 + REQUIRED_VARS + NGHTTP3_INCLUDE_DIR + NGHTTP3_LIBRARY + VERSION_VAR + NGHTTP3_VERSION + ) + + if(NGHTTP3_FOUND) + set(_nghttp3_INCLUDE_DIRS ${NGHTTP3_INCLUDE_DIR}) + set(_nghttp3_LIBRARIES ${NGHTTP3_LIBRARY}) + endif() + + mark_as_advanced(NGHTTP3_INCLUDE_DIR NGHTTP3_LIBRARY) +endif() + +if(NGHTTP3_FOUND) + if(NOT TARGET CURL::nghttp3) + add_library(CURL::nghttp3 INTERFACE IMPORTED) + set_target_properties(CURL::nghttp3 PROPERTIES + INTERFACE_LIBCURL_PC_MODULES "${_nghttp3_pc_requires}" + INTERFACE_COMPILE_OPTIONS "${_nghttp3_CFLAGS}" + INTERFACE_INCLUDE_DIRECTORIES "${_nghttp3_INCLUDE_DIRS}" + INTERFACE_LINK_DIRECTORIES "${_nghttp3_LIBRARY_DIRS}" + INTERFACE_LINK_LIBRARIES "${_nghttp3_LIBRARIES}") + endif() +endif() diff --git a/3rdparty/curl-8.21.0/CMake/FindNGTCP2.cmake b/3rdparty/curl-8.21.0/CMake/FindNGTCP2.cmake new file mode 100644 index 0000000000..bf2f488777 --- /dev/null +++ b/3rdparty/curl-8.21.0/CMake/FindNGTCP2.cmake @@ -0,0 +1,187 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# Find the ngtcp2 library +# +# This module accepts optional COMPONENTS to control the crypto library (these are +# mutually exclusive): +# +# - BoringSSL: Use `libngtcp2_crypto_boringssl`. (also for AWS-LC) +# - GnuTLS: Use `libngtcp2_crypto_gnutls`. +# - LibreSSL: Use `libngtcp2_crypto_libressl`. (requires ngtcp2 1.15.0+) +# - ossl: Use `libngtcp2_crypto_ossl`. +# - quictls: Use `libngtcp2_crypto_quictls`. (also for LibreSSL with ngtcp2 <1.15.0) +# - wolfSSL: Use `libngtcp2_crypto_wolfssl`. +# +# Input variables: +# +# - `NGTCP2_INCLUDE_DIR`: Absolute path to ngtcp2 include directory. +# - `NGTCP2_LIBRARY`: Absolute path to `ngtcp2` library. +# - `NGTCP2_CRYPTO_BORINGSSL_LIBRARY`: Absolute path to `ngtcp2_crypto_boringssl` library. +# - `NGTCP2_CRYPTO_GNUTLS_LIBRARY`: Absolute path to `ngtcp2_crypto_gnutls` library. +# - `NGTCP2_CRYPTO_LIBRESSL_LIBRARY`: Absolute path to `ngtcp2_crypto_libressl` library. +# - `NGTCP2_CRYPTO_OSSL_LIBRARY`: Absolute path to `ngtcp2_crypto_ossl` library. +# - `NGTCP2_CRYPTO_QUICTLS_LIBRARY`: Absolute path to `ngtcp2_crypto_quictls` library. +# - `NGTCP2_CRYPTO_WOLFSSL_LIBRARY`: Absolute path to `ngtcp2_crypto_wolfssl` library. +# - `NGTCP2_USE_STATIC_LIBS`: Configure for static ngtcp2 libraries. +# +# Defines: +# +# - `NGTCP2_FOUND`: System has ngtcp2. +# - `NGTCP2_VERSION`: Version of ngtcp2. +# - `NGTCP2_CRYPTO_BACKEND`: Name of the crypto library component. (Empty if COMPONENTS was not used.) +# - `CURL::ngtcp2`: ngtcp2 library target. + +set(NGTCP2_CRYPTO_BACKEND "") +if(NGTCP2_FIND_COMPONENTS) + foreach(_component IN LISTS NGTCP2_FIND_COMPONENTS) + if(_component MATCHES "^(BoringSSL|GnuTLS|LibreSSL|ossl|quictls|wolfSSL)") + if(NGTCP2_CRYPTO_BACKEND) + message(FATAL_ERROR "NGTCP2: Only one crypto library can be selected") + endif() + set(NGTCP2_CRYPTO_BACKEND ${_component}) + endif() + endforeach() + + if(NGTCP2_CRYPTO_BACKEND) + string(TOLOWER "ngtcp2_crypto_${NGTCP2_CRYPTO_BACKEND}" _crypto_library_lower) + string(TOUPPER "ngtcp2_crypto_${NGTCP2_CRYPTO_BACKEND}" _crypto_library_upper) + endif() +endif() + +set(_ngtcp2_pc_requires "libngtcp2") +if(NGTCP2_CRYPTO_BACKEND) + list(APPEND _ngtcp2_pc_requires "lib${_crypto_library_lower}") +endif() + +set(_tried_pkgconfig FALSE) +if(NOT DEFINED NGTCP2_INCLUDE_DIR AND + NOT DEFINED NGTCP2_LIBRARY) + if(CURL_USE_PKGCONFIG) + find_package(PkgConfig QUIET) + pkg_check_modules(_ngtcp2 ${_ngtcp2_pc_requires}) + set(_tried_pkgconfig TRUE) + endif() + if(NOT _ngtcp2_FOUND AND CURL_USE_CMAKECONFIG AND NGTCP2_CRYPTO_BACKEND) + find_package(ngtcp2 CONFIG QUIET) + # Skip using it if the crypto library target is not available + if(ngtcp2_CONFIG AND + NOT TARGET ngtcp2::${_crypto_library_lower}_static AND + NOT TARGET ngtcp2::${_crypto_library_lower}) + unset(ngtcp2_CONFIG) + endif() + endif() +endif() + +if(_ngtcp2_FOUND) + set(NGTCP2_FOUND TRUE) + set(NGTCP2_VERSION ${_ngtcp2_libngtcp2_VERSION}) + if(NGTCP2_USE_STATIC_LIBS) + set(_ngtcp2_CFLAGS "${_ngtcp2_STATIC_CFLAGS}") + set(_ngtcp2_INCLUDE_DIRS "${_ngtcp2_STATIC_INCLUDE_DIRS}") + set(_ngtcp2_LIBRARY_DIRS "${_ngtcp2_STATIC_LIBRARY_DIRS}") + set(_ngtcp2_LIBRARIES "${_ngtcp2_STATIC_LIBRARIES}") + endif() + message(STATUS "Found NGTCP2 (via pkg-config): ${_ngtcp2_INCLUDE_DIRS} (found version \"${NGTCP2_VERSION}\")") +elseif(ngtcp2_CONFIG) + set(NGTCP2_FOUND TRUE) + set(NGTCP2_VERSION ${ngtcp2_VERSION}) + if(NGTCP2_USE_STATIC_LIBS OR NOT TARGET ngtcp2::ngtcp2) + set(_ngtcp2_LIBRARIES ngtcp2::ngtcp2_static ngtcp2::${_crypto_library_lower}_static) + else() + set(_ngtcp2_LIBRARIES ngtcp2::ngtcp2 ngtcp2::${_crypto_library_lower}) + endif() + message(STATUS "Found NGTCP2 (via CMake Config): ${ngtcp2_CONFIG} (found version \"${NGTCP2_VERSION}\")") +else() + find_path(NGTCP2_INCLUDE_DIR NAMES "ngtcp2/ngtcp2.h") + if(NGTCP2_USE_STATIC_LIBS) + set(_ngtcp2_CFLAGS "-DNGTCP2_STATICLIB") + find_library(NGTCP2_LIBRARY NAMES "ngtcp2_static" "ngtcp2") + else() + find_library(NGTCP2_LIBRARY NAMES "ngtcp2") + endif() + + unset(NGTCP2_VERSION CACHE) + if(NGTCP2_INCLUDE_DIR AND EXISTS "${NGTCP2_INCLUDE_DIR}/ngtcp2/version.h") + set(_version_regex "#[\t ]*define[\t ]+NGTCP2_VERSION[\t ]+\"([^\"]*)\"") + file(STRINGS "${NGTCP2_INCLUDE_DIR}/ngtcp2/version.h" _version_str REGEX "${_version_regex}") + string(REGEX REPLACE "${_version_regex}" "\\1" _version_str "${_version_str}") + set(NGTCP2_VERSION "${_version_str}") + unset(_version_regex) + unset(_version_str) + endif() + + if(NGTCP2_CRYPTO_BACKEND) + if(CMAKE_VERSION VERSION_GREATER_EQUAL 3.20) + cmake_path(GET NGTCP2_LIBRARY PARENT_PATH _ngtcp2_library_dir) + else() + get_filename_component(_ngtcp2_library_dir "${NGTCP2_LIBRARY}" DIRECTORY) + endif() + if(NGTCP2_USE_STATIC_LIBS) + find_library(${_crypto_library_upper}_LIBRARY NAMES ${_crypto_library_lower}_static ${_crypto_library_lower} + HINTS ${_ngtcp2_library_dir}) + else() + find_library(${_crypto_library_upper}_LIBRARY NAMES ${_crypto_library_lower} + HINTS ${_ngtcp2_library_dir}) + endif() + + if(${_crypto_library_upper}_LIBRARY) + set(NGTCP2_${NGTCP2_CRYPTO_BACKEND}_FOUND TRUE) + set(NGTCP2_CRYPTO_LIBRARY ${${_crypto_library_upper}_LIBRARY}) + endif() + endif() + + include(FindPackageHandleStandardArgs) + find_package_handle_standard_args(NGTCP2 + REQUIRED_VARS + NGTCP2_INCLUDE_DIR + NGTCP2_LIBRARY + VERSION_VAR + NGTCP2_VERSION + HANDLE_COMPONENTS + ) + + if(NGTCP2_FOUND) + set(_ngtcp2_INCLUDE_DIRS ${NGTCP2_INCLUDE_DIR}) + set(_ngtcp2_LIBRARIES ${NGTCP2_LIBRARY} ${NGTCP2_CRYPTO_LIBRARY}) + endif() + + mark_as_advanced(NGTCP2_INCLUDE_DIR NGTCP2_LIBRARY NGTCP2_CRYPTO_LIBRARY) + + if(NOT NGTCP2_FOUND AND _tried_pkgconfig) # reset variables to allow another round of detection + unset(NGTCP2_INCLUDE_DIR CACHE) + unset(NGTCP2_LIBRARY CACHE) + endif() +endif() + +if(NGTCP2_FOUND) + if(NOT TARGET CURL::ngtcp2) + add_library(CURL::ngtcp2 INTERFACE IMPORTED) + set_target_properties(CURL::ngtcp2 PROPERTIES + INTERFACE_LIBCURL_PC_MODULES "${_ngtcp2_pc_requires}" + INTERFACE_COMPILE_OPTIONS "${_ngtcp2_CFLAGS}" + INTERFACE_INCLUDE_DIRECTORIES "${_ngtcp2_INCLUDE_DIRS}" + INTERFACE_LINK_DIRECTORIES "${_ngtcp2_LIBRARY_DIRS}" + INTERFACE_LINK_LIBRARIES "${_ngtcp2_LIBRARIES}") + endif() +endif() diff --git a/3rdparty/curl-8.21.0/CMake/FindNettle.cmake b/3rdparty/curl-8.21.0/CMake/FindNettle.cmake new file mode 100644 index 0000000000..c963180cba --- /dev/null +++ b/3rdparty/curl-8.21.0/CMake/FindNettle.cmake @@ -0,0 +1,97 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# Find the nettle library +# +# Input variables: +# +# - `NETTLE_INCLUDE_DIR`: Absolute path to nettle include directory. +# - `NETTLE_LIBRARY`: Absolute path to `nettle` library. +# +# Defines: +# +# - `NETTLE_FOUND`: System has nettle. +# - `NETTLE_VERSION`: Version of nettle. +# - `CURL::nettle`: nettle library target. + +set(_nettle_pc_requires "nettle") + +if(CURL_USE_PKGCONFIG AND + NOT DEFINED NETTLE_INCLUDE_DIR AND + NOT DEFINED NETTLE_LIBRARY) + find_package(PkgConfig QUIET) + pkg_check_modules(_nettle ${_nettle_pc_requires}) +endif() + +if(_nettle_FOUND) + set(Nettle_FOUND TRUE) + set(NETTLE_FOUND TRUE) + set(NETTLE_VERSION ${_nettle_VERSION}) + message(STATUS "Found Nettle (via pkg-config): ${_nettle_INCLUDE_DIRS} (found version \"${NETTLE_VERSION}\")") +else() + find_path(NETTLE_INCLUDE_DIR NAMES "nettle/sha2.h") + find_library(NETTLE_LIBRARY NAMES "nettle") + + unset(NETTLE_VERSION CACHE) + if(NETTLE_INCLUDE_DIR AND EXISTS "${NETTLE_INCLUDE_DIR}/nettle/version.h") + set(_version_regex1 "#[\t ]*define[ \t]+NETTLE_VERSION_MAJOR[ \t]+([0-9]+).*") + set(_version_regex2 "#[\t ]*define[ \t]+NETTLE_VERSION_MINOR[ \t]+([0-9]+).*") + file(STRINGS "${NETTLE_INCLUDE_DIR}/nettle/version.h" _version_str1 REGEX "${_version_regex1}") + file(STRINGS "${NETTLE_INCLUDE_DIR}/nettle/version.h" _version_str2 REGEX "${_version_regex2}") + string(REGEX REPLACE "${_version_regex1}" "\\1" _version_str1 "${_version_str1}") + string(REGEX REPLACE "${_version_regex2}" "\\1" _version_str2 "${_version_str2}") + set(NETTLE_VERSION "${_version_str1}.${_version_str2}") + unset(_version_regex1) + unset(_version_regex2) + unset(_version_str1) + unset(_version_str2) + endif() + + include(FindPackageHandleStandardArgs) + find_package_handle_standard_args(Nettle + REQUIRED_VARS + NETTLE_INCLUDE_DIR + NETTLE_LIBRARY + VERSION_VAR + NETTLE_VERSION + ) + + if(NETTLE_FOUND) + set(_nettle_INCLUDE_DIRS ${NETTLE_INCLUDE_DIR}) + set(_nettle_LIBRARIES ${NETTLE_LIBRARY}) + endif() + + mark_as_advanced(NETTLE_INCLUDE_DIR NETTLE_LIBRARY) +endif() + +if(NETTLE_FOUND) + if(NOT TARGET CURL::nettle) + add_library(CURL::nettle INTERFACE IMPORTED) + set_target_properties(CURL::nettle PROPERTIES + INTERFACE_LIBCURL_PC_MODULES "${_nettle_pc_requires}" + INTERFACE_COMPILE_OPTIONS "${_nettle_CFLAGS}" + INTERFACE_INCLUDE_DIRECTORIES "${_nettle_INCLUDE_DIRS}" + INTERFACE_LINK_DIRECTORIES "${_nettle_LIBRARY_DIRS}" + INTERFACE_LINK_LIBRARIES "${_nettle_LIBRARIES}") + endif() +endif() diff --git a/3rdparty/curl-8.21.0/CMake/FindQuiche.cmake b/3rdparty/curl-8.21.0/CMake/FindQuiche.cmake new file mode 100644 index 0000000000..137679b5b3 --- /dev/null +++ b/3rdparty/curl-8.21.0/CMake/FindQuiche.cmake @@ -0,0 +1,80 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# Find the quiche library +# +# Input variables: +# +# - `QUICHE_INCLUDE_DIR`: Absolute path to quiche include directory. +# - `QUICHE_LIBRARY`: Absolute path to `quiche` library. +# +# Defines: +# +# - `QUICHE_FOUND`: System has quiche. +# - `QUICHE_VERSION`: Version of quiche. +# - `CURL::quiche`: quiche library target. + +set(_quiche_pc_requires "quiche") + +if(CURL_USE_PKGCONFIG AND + NOT DEFINED QUICHE_INCLUDE_DIR AND + NOT DEFINED QUICHE_LIBRARY) + find_package(PkgConfig QUIET) + pkg_check_modules(_quiche ${_quiche_pc_requires}) +endif() + +if(_quiche_FOUND) + set(Quiche_FOUND TRUE) + set(QUICHE_FOUND TRUE) + set(QUICHE_VERSION ${_quiche_VERSION}) + message(STATUS "Found Quiche (via pkg-config): ${_quiche_INCLUDE_DIRS} (found version \"${QUICHE_VERSION}\")") +else() + find_path(QUICHE_INCLUDE_DIR NAMES "quiche.h") + find_library(QUICHE_LIBRARY NAMES "quiche") + + include(FindPackageHandleStandardArgs) + find_package_handle_standard_args(Quiche + REQUIRED_VARS + QUICHE_INCLUDE_DIR + QUICHE_LIBRARY + ) + + if(QUICHE_FOUND) + set(_quiche_INCLUDE_DIRS ${QUICHE_INCLUDE_DIR}) + set(_quiche_LIBRARIES ${QUICHE_LIBRARY}) + endif() + + mark_as_advanced(QUICHE_INCLUDE_DIR QUICHE_LIBRARY) +endif() + +if(QUICHE_FOUND) + if(NOT TARGET CURL::quiche) + add_library(CURL::quiche INTERFACE IMPORTED) + set_target_properties(CURL::quiche PROPERTIES + INTERFACE_LIBCURL_PC_MODULES "${_quiche_pc_requires}" + INTERFACE_COMPILE_OPTIONS "${_quiche_CFLAGS}" + INTERFACE_INCLUDE_DIRECTORIES "${_quiche_INCLUDE_DIRS}" + INTERFACE_LINK_DIRECTORIES "${_quiche_LIBRARY_DIRS}" + INTERFACE_LINK_LIBRARIES "${_quiche_LIBRARIES}") + endif() +endif() diff --git a/3rdparty/curl-8.21.0/CMake/FindRustls.cmake b/3rdparty/curl-8.21.0/CMake/FindRustls.cmake new file mode 100644 index 0000000000..1e07565189 --- /dev/null +++ b/3rdparty/curl-8.21.0/CMake/FindRustls.cmake @@ -0,0 +1,116 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# Find the Rustls library +# +# Input variables: +# +# - `RUSTLS_INCLUDE_DIR`: Absolute path to Rustls include directory. +# - `RUSTLS_LIBRARY`: Absolute path to `rustls` library. +# +# Defines: +# +# - `RUSTLS_FOUND`: System has Rustls. +# - `RUSTLS_VERSION`: Version of Rustls. +# - `CURL::rustls`: Rustls library target. + +set(_rustls_pc_requires "rustls") + +if(CURL_USE_PKGCONFIG AND + NOT DEFINED RUSTLS_INCLUDE_DIR AND + NOT DEFINED RUSTLS_LIBRARY) + find_package(PkgConfig QUIET) + pkg_check_modules(_rustls ${_rustls_pc_requires}) +endif() + +if(_rustls_FOUND) + set(Rustls_FOUND TRUE) + set(RUSTLS_FOUND TRUE) + set(RUSTLS_VERSION ${_rustls_VERSION}) + message(STATUS "Found Rustls (via pkg-config): ${_rustls_INCLUDE_DIRS} (found version \"${RUSTLS_VERSION}\")") +else() + set(_rustls_pc_requires "") # Depend on pkg-config only when found via pkg-config + + find_path(RUSTLS_INCLUDE_DIR NAMES "rustls.h") + find_library(RUSTLS_LIBRARY NAMES "rustls") + + include(FindPackageHandleStandardArgs) + find_package_handle_standard_args(Rustls + REQUIRED_VARS + RUSTLS_INCLUDE_DIR + RUSTLS_LIBRARY + ) + + if(RUSTLS_FOUND) + set(_rustls_INCLUDE_DIRS ${RUSTLS_INCLUDE_DIR}) + set(_rustls_LIBRARIES ${RUSTLS_LIBRARY}) + endif() + + mark_as_advanced(RUSTLS_INCLUDE_DIR RUSTLS_LIBRARY) +endif() + +if(RUSTLS_FOUND) + if(APPLE) + find_library(SECURITY_FRAMEWORK NAMES "Security") + mark_as_advanced(SECURITY_FRAMEWORK) + if(NOT SECURITY_FRAMEWORK) + message(FATAL_ERROR "Security framework not found") + endif() + list(APPEND _rustls_LIBRARIES "-framework Security") + + find_library(FOUNDATION_FRAMEWORK NAMES "Foundation") + mark_as_advanced(FOUNDATION_FRAMEWORK) + if(NOT FOUNDATION_FRAMEWORK) + message(FATAL_ERROR "Foundation framework not found") + endif() + list(APPEND _rustls_LIBRARIES "-framework Foundation") + elseif(NOT WIN32) + find_library(PTHREAD_LIBRARY NAMES "pthread") + if(PTHREAD_LIBRARY) + list(APPEND _rustls_LIBRARIES ${PTHREAD_LIBRARY}) + endif() + mark_as_advanced(PTHREAD_LIBRARY) + + find_library(DL_LIBRARY NAMES "dl") + if(DL_LIBRARY) + list(APPEND _rustls_LIBRARIES ${DL_LIBRARY}) + endif() + mark_as_advanced(DL_LIBRARY) + + find_library(MATH_LIBRARY NAMES "m") + if(MATH_LIBRARY) + list(APPEND _rustls_LIBRARIES ${MATH_LIBRARY}) + endif() + mark_as_advanced(MATH_LIBRARY) + endif() + + if(NOT TARGET CURL::rustls) + add_library(CURL::rustls INTERFACE IMPORTED) + set_target_properties(CURL::rustls PROPERTIES + INTERFACE_LIBCURL_PC_MODULES "${_rustls_pc_requires}" + INTERFACE_COMPILE_OPTIONS "${_rustls_CFLAGS}" + INTERFACE_INCLUDE_DIRECTORIES "${_rustls_INCLUDE_DIRS}" + INTERFACE_LINK_DIRECTORIES "${_rustls_LIBRARY_DIRS}" + INTERFACE_LINK_LIBRARIES "${_rustls_LIBRARIES}") + endif() +endif() diff --git a/3rdparty/curl-8.21.0/CMake/FindWolfSSL.cmake b/3rdparty/curl-8.21.0/CMake/FindWolfSSL.cmake new file mode 100644 index 0000000000..964320ad6b --- /dev/null +++ b/3rdparty/curl-8.21.0/CMake/FindWolfSSL.cmake @@ -0,0 +1,135 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# Find the wolfSSL library +# +# Input variables: +# +# - `WOLFSSL_INCLUDE_DIR`: Absolute path to wolfSSL include directory. +# - `WOLFSSL_LIBRARY`: Absolute path to `wolfssl` library. +# +# Defines: +# +# - `WOLFSSL_FOUND`: System has wolfSSL. +# - `WOLFSSL_VERSION`: Version of wolfSSL. +# - `CURL::wolfssl`: wolfSSL library target. + +if(DEFINED WolfSSL_INCLUDE_DIR AND NOT DEFINED WOLFSSL_INCLUDE_DIR) + message(WARNING "WolfSSL_INCLUDE_DIR is deprecated, use WOLFSSL_INCLUDE_DIR instead.") + set(WOLFSSL_INCLUDE_DIR "${WolfSSL_INCLUDE_DIR}") +endif() +if(DEFINED WolfSSL_LIBRARY AND NOT DEFINED WOLFSSL_LIBRARY) + message(WARNING "WolfSSL_LIBRARY is deprecated, use WOLFSSL_LIBRARY instead.") + set(WOLFSSL_LIBRARY "${WolfSSL_LIBRARY}") +endif() + +set(_wolfssl_pc_requires "wolfssl") + +if(NOT DEFINED WOLFSSL_INCLUDE_DIR AND + NOT DEFINED WOLFSSL_LIBRARY) + if(CURL_USE_PKGCONFIG) + find_package(PkgConfig QUIET) + pkg_check_modules(_wolfssl ${_wolfssl_pc_requires}) + endif() + if(NOT _wolfssl_FOUND AND CURL_USE_CMAKECONFIG) + find_package(wolfssl CONFIG QUIET) + endif() +endif() + +if(_wolfssl_FOUND) + set(WolfSSL_FOUND TRUE) + set(WOLFSSL_FOUND TRUE) + set(WOLFSSL_VERSION ${_wolfssl_VERSION}) + message(STATUS "Found WolfSSL (via pkg-config): ${_wolfssl_INCLUDE_DIRS} (found version \"${WOLFSSL_VERSION}\")") +elseif(wolfssl_CONFIG) + set(WolfSSL_FOUND TRUE) + set(WOLFSSL_FOUND TRUE) + set(WOLFSSL_VERSION ${wolfssl_VERSION}) + set(_wolfssl_LIBRARIES wolfssl::wolfssl) + message(STATUS "Found WolfSSL (via CMake Config): ${wolfssl_CONFIG} (found version \"${WOLFSSL_VERSION}\")") +else() + find_path(WOLFSSL_INCLUDE_DIR NAMES "wolfssl/ssl.h") + find_library(WOLFSSL_LIBRARY NAMES "wolfssl") + + unset(WOLFSSL_VERSION CACHE) + if(WOLFSSL_INCLUDE_DIR AND EXISTS "${WOLFSSL_INCLUDE_DIR}/wolfssl/version.h") + set(_version_regex "#[\t ]*define[\t ]+LIBWOLFSSL_VERSION_STRING[\t ]+\"([^\"]*)\"") + file(STRINGS "${WOLFSSL_INCLUDE_DIR}/wolfssl/version.h" _version_str REGEX "${_version_regex}") + string(REGEX REPLACE "${_version_regex}" "\\1" _version_str "${_version_str}") + set(WOLFSSL_VERSION "${_version_str}") + unset(_version_regex) + unset(_version_str) + endif() + + include(FindPackageHandleStandardArgs) + find_package_handle_standard_args(WolfSSL + REQUIRED_VARS + WOLFSSL_INCLUDE_DIR + WOLFSSL_LIBRARY + VERSION_VAR + WOLFSSL_VERSION + ) + + if(WOLFSSL_FOUND) + set(_wolfssl_INCLUDE_DIRS ${WOLFSSL_INCLUDE_DIR}) + set(_wolfssl_LIBRARIES ${WOLFSSL_LIBRARY}) + endif() + + mark_as_advanced(WOLFSSL_INCLUDE_DIR WOLFSSL_LIBRARY) +endif() + +if(WOLFSSL_FOUND) + if(APPLE) + find_library(SECURITY_FRAMEWORK NAMES "Security") + mark_as_advanced(SECURITY_FRAMEWORK) + if(NOT SECURITY_FRAMEWORK) + message(FATAL_ERROR "Security framework not found") + endif() + list(APPEND _wolfssl_LIBRARIES "-framework Security") + + find_library(COREFOUNDATION_FRAMEWORK NAMES "CoreFoundation") + mark_as_advanced(COREFOUNDATION_FRAMEWORK) + if(NOT COREFOUNDATION_FRAMEWORK) + message(FATAL_ERROR "CoreFoundation framework not found") + endif() + list(APPEND _wolfssl_LIBRARIES "-framework CoreFoundation") + elseif(WIN32) + list(APPEND _wolfssl_LIBRARIES "crypt32") + else() + find_library(MATH_LIBRARY NAMES "m") + if(MATH_LIBRARY) + list(APPEND _wolfssl_LIBRARIES ${MATH_LIBRARY}) # for log and pow + endif() + mark_as_advanced(MATH_LIBRARY) + endif() + + if(NOT TARGET CURL::wolfssl) + add_library(CURL::wolfssl INTERFACE IMPORTED) + set_target_properties(CURL::wolfssl PROPERTIES + INTERFACE_LIBCURL_PC_MODULES "${_wolfssl_pc_requires}" + INTERFACE_COMPILE_OPTIONS "${_wolfssl_CFLAGS}" + INTERFACE_INCLUDE_DIRECTORIES "${_wolfssl_INCLUDE_DIRS}" + INTERFACE_LINK_DIRECTORIES "${_wolfssl_LIBRARY_DIRS}" + INTERFACE_LINK_LIBRARIES "${_wolfssl_LIBRARIES}") + endif() +endif() diff --git a/3rdparty/curl-8.21.0/CMake/FindZstd.cmake b/3rdparty/curl-8.21.0/CMake/FindZstd.cmake new file mode 100644 index 0000000000..176645d97b --- /dev/null +++ b/3rdparty/curl-8.21.0/CMake/FindZstd.cmake @@ -0,0 +1,144 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# Find the zstd library +# +# Input variables: +# +# - `ZSTD_INCLUDE_DIR`: Absolute path to zstd include directory. +# - `ZSTD_LIBRARY`: Absolute path to `zstd` library. +# - `ZSTD_USE_STATIC_LIBS`: Configure for static zstd libraries. +# +# Defines: +# +# - `ZSTD_FOUND`: System has zstd. +# - `ZSTD_VERSION`: Version of zstd. +# - `CURL::zstd`: zstd library target. + +if(DEFINED Zstd_INCLUDE_DIR AND NOT DEFINED ZSTD_INCLUDE_DIR) + message(WARNING "Zstd_INCLUDE_DIR is deprecated, use ZSTD_INCLUDE_DIR instead.") + set(ZSTD_INCLUDE_DIR "${Zstd_INCLUDE_DIR}") +endif() +if(DEFINED Zstd_LIBRARY AND NOT DEFINED ZSTD_LIBRARY) + message(WARNING "Zstd_LIBRARY is deprecated, use ZSTD_LIBRARY instead.") + set(ZSTD_LIBRARY "${Zstd_LIBRARY}") +endif() + +set(_zstd_pc_requires "libzstd") + +if(NOT DEFINED ZSTD_INCLUDE_DIR AND + NOT DEFINED ZSTD_LIBRARY) + if(CURL_USE_PKGCONFIG) + find_package(PkgConfig QUIET) + pkg_check_modules(_zstd ${_zstd_pc_requires}) + endif() + if(NOT _zstd_FOUND AND CURL_USE_CMAKECONFIG) + find_package(zstd CONFIG QUIET) + # Skip using if older than v1.4.5 + if(zstd_CONFIG AND + NOT TARGET zstd::libzstd_static AND + NOT TARGET zstd::libzstd_shared) + unset(zstd_CONFIG) + endif() + endif() +endif() + +if(_zstd_FOUND) + set(Zstd_FOUND TRUE) + set(ZSTD_FOUND TRUE) + set(ZSTD_VERSION ${_zstd_VERSION}) + if(ZSTD_USE_STATIC_LIBS) + set(_zstd_CFLAGS "${_zstd_STATIC_CFLAGS}") + set(_zstd_INCLUDE_DIRS "${_zstd_STATIC_INCLUDE_DIRS}") + set(_zstd_LIBRARY_DIRS "${_zstd_STATIC_LIBRARY_DIRS}") + set(_zstd_LIBRARIES "${_zstd_STATIC_LIBRARIES}") + endif() + message(STATUS "Found Zstd (via pkg-config): ${_zstd_INCLUDE_DIRS} (found version \"${ZSTD_VERSION}\")") +elseif(zstd_CONFIG) + set(Zstd_FOUND TRUE) + set(ZSTD_FOUND TRUE) + set(ZSTD_VERSION ${zstd_VERSION}) + if(ZSTD_USE_STATIC_LIBS) + set(_zstd_LIBRARIES zstd::libzstd_static) + elseif(TARGET zstd::libzstd) + set(_zstd_LIBRARIES zstd::libzstd) # v1.5.6+ + else() + set(_zstd_LIBRARIES zstd::libzstd_shared) + endif() + message(STATUS "Found Zstd (via CMake Config): ${zstd_CONFIG} (found version \"${ZSTD_VERSION}\")") +else() + find_path(ZSTD_INCLUDE_DIR NAMES "zstd.h") + if(ZSTD_USE_STATIC_LIBS) + find_library(ZSTD_LIBRARY NAMES "zstd_static" "zstd") + else() + find_library(ZSTD_LIBRARY NAMES "zstd") + endif() + + unset(ZSTD_VERSION CACHE) + if(ZSTD_INCLUDE_DIR AND EXISTS "${ZSTD_INCLUDE_DIR}/zstd.h") + set(_version_regex1 "#[\t ]*define[ \t]+ZSTD_VERSION_MAJOR[ \t]+([0-9]+).*") + set(_version_regex2 "#[\t ]*define[ \t]+ZSTD_VERSION_MINOR[ \t]+([0-9]+).*") + set(_version_regex3 "#[\t ]*define[ \t]+ZSTD_VERSION_RELEASE[ \t]+([0-9]+).*") + file(STRINGS "${ZSTD_INCLUDE_DIR}/zstd.h" _version_str1 REGEX "${_version_regex1}") + file(STRINGS "${ZSTD_INCLUDE_DIR}/zstd.h" _version_str2 REGEX "${_version_regex2}") + file(STRINGS "${ZSTD_INCLUDE_DIR}/zstd.h" _version_str3 REGEX "${_version_regex3}") + string(REGEX REPLACE "${_version_regex1}" "\\1" _version_str1 "${_version_str1}") + string(REGEX REPLACE "${_version_regex2}" "\\1" _version_str2 "${_version_str2}") + string(REGEX REPLACE "${_version_regex3}" "\\1" _version_str3 "${_version_str3}") + set(ZSTD_VERSION "${_version_str1}.${_version_str2}.${_version_str3}") + unset(_version_regex1) + unset(_version_regex2) + unset(_version_regex3) + unset(_version_str1) + unset(_version_str2) + unset(_version_str3) + endif() + + include(FindPackageHandleStandardArgs) + find_package_handle_standard_args(Zstd + REQUIRED_VARS + ZSTD_INCLUDE_DIR + ZSTD_LIBRARY + VERSION_VAR + ZSTD_VERSION + ) + + if(ZSTD_FOUND) + set(_zstd_INCLUDE_DIRS ${ZSTD_INCLUDE_DIR}) + set(_zstd_LIBRARIES ${ZSTD_LIBRARY}) + endif() + + mark_as_advanced(ZSTD_INCLUDE_DIR ZSTD_LIBRARY) +endif() + +if(ZSTD_FOUND) + if(NOT TARGET CURL::zstd) + add_library(CURL::zstd INTERFACE IMPORTED) + set_target_properties(CURL::zstd PROPERTIES + INTERFACE_LIBCURL_PC_MODULES "${_zstd_pc_requires}" + INTERFACE_COMPILE_OPTIONS "${_zstd_CFLAGS}" + INTERFACE_INCLUDE_DIRECTORIES "${_zstd_INCLUDE_DIRS}" + INTERFACE_LINK_DIRECTORIES "${_zstd_LIBRARY_DIRS}" + INTERFACE_LINK_LIBRARIES "${_zstd_LIBRARIES}") + endif() +endif() diff --git a/3rdparty/curl-8.21.0/CMake/Macros.cmake b/3rdparty/curl-8.21.0/CMake/Macros.cmake new file mode 100644 index 0000000000..953c1c6ee6 --- /dev/null +++ b/3rdparty/curl-8.21.0/CMake/Macros.cmake @@ -0,0 +1,280 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# File defines convenience macros for available feature testing + +# Check if header file exists and add it to the list. +# This macro is intended to be called multiple times with a sequence of +# possibly dependent header files. Some headers depend on others to be +# compiled correctly. +macro(check_include_file_concat_curl _file _variable) + check_include_files("${CURL_INCLUDES};${_file}" ${_variable}) + if(${_variable}) + list(APPEND CURL_INCLUDES ${_file}) + endif() +endmacro() + +set(CURL_TEST_DEFINES "") # Initialize global variable + +# For other curl specific tests, use this macro. +# Return result in variable: CURL_TEST_OUTPUT +macro(curl_internal_test _curl_test) + if(NOT DEFINED "${_curl_test}") + message(STATUS "Performing Test ${_curl_test}") + try_compile(${_curl_test} + ${PROJECT_BINARY_DIR} + "${CMAKE_CURRENT_SOURCE_DIR}/CMake/CurlTests.c" + COMPILE_DEFINITIONS "-D${_curl_test}" ${CURL_TEST_DEFINES} ${CMAKE_REQUIRED_FLAGS} ${CMAKE_REQUIRED_DEFINITIONS} + LINK_LIBRARIES "${CMAKE_REQUIRED_LIBRARIES}" + OUTPUT_VARIABLE CURL_TEST_OUTPUT) + if(${_curl_test}) + set(${_curl_test} 1 CACHE INTERNAL "curl test") + message(STATUS "Performing Test ${_curl_test} - Success") + else() + set(${_curl_test} "" CACHE INTERNAL "curl test") + message(STATUS "Performing Test ${_curl_test} - Failed") + endif() + endif() +endmacro() + +# Option for dependencies that accepts an 'AUTO' value, which enables the dependency if detected. +macro(curl_dependency_option _option_name _find_name _desc_name) + set(${_option_name} "AUTO" CACHE STRING "Build curl with ${_desc_name} support (AUTO, ON or OFF)") + set_property(CACHE ${_option_name} PROPERTY STRINGS "AUTO" "ON" "OFF") + + if(${_option_name} STREQUAL "AUTO") + if(_find_name STREQUAL "ZLIB") + find_package(${_find_name}) + else() + find_package(${_find_name} MODULE) + endif() + elseif(${_option_name}) + if(_find_name STREQUAL "ZLIB") + find_package(${_find_name} REQUIRED) + else() + find_package(${_find_name} MODULE REQUIRED) + endif() + else() + string(TOUPPER "${_find_name}" _find_name_upper) + set(${_find_name}_FOUND OFF) # cmake-lint: disable=C0103 + set(${_find_name_upper}_FOUND OFF) # cmake-lint: disable=C0103 + endif() +endmacro() + +# Convert the passed paths to libpath linker options and add them to CMAKE_REQUIRED_*. +macro(curl_required_libpaths _libpaths_arg) + if(CMAKE_VERSION VERSION_LESS 3.31) + set(_libpaths "${_libpaths_arg}") + foreach(_libpath IN LISTS _libpaths) + list(APPEND CMAKE_REQUIRED_LINK_OPTIONS "${CMAKE_LIBRARY_PATH_FLAG}${_libpath}") + endforeach() + else() + list(APPEND CMAKE_REQUIRED_LINK_DIRECTORIES "${_libpaths_arg}") + endif() +endmacro() + +# Pre-fill variables set by a check_type_size() call. +macro(curl_prefill_type_size _type _size) + set(HAVE_SIZEOF_${_type} TRUE) + set(SIZEOF_${_type} ${_size}) + set(SIZEOF_${_type}_CODE "#define SIZEOF_${_type} ${_size}") +endmacro() + +# Internal: Recurse into target libraries and collect their include directories +# and macro definitions. +macro(curl_collect_target_compile_options _target) + get_target_property(_val ${_target} INTERFACE_COMPILE_DEFINITIONS) + if(_val) + list(APPEND _definitions ${_val}) + endif() + get_target_property(_val ${_target} INTERFACE_INCLUDE_DIRECTORIES) + if(_val) + list(APPEND _incsys ${_val}) + endif() + get_target_property(_val ${_target} INTERFACE_COMPILE_OPTIONS) + if(_val) + list(APPEND _options ${_val}) + endif() + get_target_property(_val ${_target} LINK_LIBRARIES) + if(_val) + foreach(_lib IN LISTS _val) + if(TARGET "${_lib}") + curl_collect_target_compile_options(${_lib}) + endif() + endforeach() + endif() + unset(_val) +endmacro() + +# Create a clang-tidy target for test targets +function(curl_add_clang_tidy_test_target _target_clang_tidy _target) + if(CURL_CLANG_TIDY) + + set(_definitions "") + set(_includes "") + set(_incsys "") + set(_options "") + + # Make a list of known system include directories + set(_sys_incdirs "${CMAKE_C_IMPLICIT_INCLUDE_DIRECTORIES}") + foreach(_inc IN LISTS CMAKE_SYSTEM_PREFIX_PATH) + if(NOT _inc MATCHES "/$") + string(APPEND _inc "/") + endif() + string(APPEND _inc "include") + if(NOT _inc IN_LIST _sys_incdirs AND IS_DIRECTORY "${_inc}") + list(APPEND _sys_incdirs "${_inc}") + endif() + endforeach() + + # Collect options applying to the directory + get_directory_property(_val COMPILE_DEFINITIONS) + if(_val) + list(APPEND _definitions ${_val}) + endif() + get_directory_property(_val INCLUDE_DIRECTORIES) + if(_val) + list(APPEND _includes ${_val}) + endif() + get_directory_property(_val COMPILE_OPTIONS) + if(_val) + list(APPEND _options ${_val}) + endif() + + # Collect options applying to the target + get_target_property(_val ${_target} COMPILE_DEFINITIONS) + if(_val) + list(APPEND _definitions ${_val}) + endif() + get_target_property(_val ${_target} INCLUDE_DIRECTORIES) + if(_val) + list(APPEND _includes ${_val}) + endif() + get_target_property(_val ${_target} COMPILE_OPTIONS) + if(_val) + list(APPEND _options ${_val}) + endif() + + # Collect header directories and macro definitions from lib dependencies + curl_collect_target_compile_options(${_target}) + + list(REMOVE_ITEM _definitions "") + string(REPLACE ";" ";-D" _definitions ";${_definitions}") + list(REMOVE_DUPLICATES _definitions) + list(SORT _definitions) # Sort like CMake does + + list(REMOVE_ITEM _includes "") + string(REPLACE ";" ";-I" _includes ";${_includes}") + list(REMOVE_DUPLICATES _includes) + + set(_incsys_tmp ${_incsys}) + list(REMOVE_DUPLICATES _incsys_tmp) + set(_incsys "") + set(_incsystop "") + foreach(_inc IN LISTS _incsys_tmp) + if(_inc IN_LIST _sys_incdirs) + list(APPEND _incsystop "${_inc}") # Save system prefixes to re-add them later to the end of list + continue() + endif() + # Avoid empty and '$' items. The latter + # evaluates to an empty path in this context. Also skip + # '$', as already present in '_includes'. + if(_inc AND + NOT _inc MATCHES "INSTALL_INTERFACE:" AND + NOT _inc MATCHES "BUILD_INTERFACE:") + list(APPEND _incsys "-isystem" "${_inc}") + endif() + endforeach() + foreach(_inc IN LISTS _incsystop) + list(APPEND _incsys "-isystem" "${_inc}") + endforeach() + + if(CMAKE_C_COMPILER_ID MATCHES "Clang") + list(REMOVE_DUPLICATES _options) # Keep the first of duplicates to imitate CMake + else() + set(_options) + endif() + + # Assemble source list + set(_sources "") + foreach(_source IN ITEMS ${ARGN}) + if(NOT EXISTS "${CMAKE_CURRENT_SOURCE_DIR}/${_source}") # if not in source tree + set(_source "${CMAKE_CURRENT_BINARY_DIR}/${_source}") # look in the build tree, for generated files, e.g. lib1521.c + endif() + list(APPEND _sources "${_source}") + endforeach() + + set(_cc "${CMAKE_C_COMPILER}") + if(CMAKE_C_COMPILER_TARGET AND CMAKE_C_COMPILE_OPTIONS_TARGET) + list(APPEND _cc "${CMAKE_C_COMPILE_OPTIONS_TARGET}${CMAKE_C_COMPILER_TARGET}") + endif() + if(APPLE AND CMAKE_OSX_SYSROOT) + list(APPEND _cc "-isysroot" "${CMAKE_OSX_SYSROOT}") + elseif(CMAKE_SYSROOT AND CMAKE_C_COMPILE_OPTIONS_SYSROOT) + list(APPEND _cc "${CMAKE_C_COMPILE_OPTIONS_SYSROOT}${CMAKE_SYSROOT}") + endif() + + # Pass -clang-diagnostic-unused-function to disable -Wunused-function implied by -Wunused + add_custom_target(${_target_clang_tidy} USES_TERMINAL + WORKING_DIRECTORY "${CMAKE_CURRENT_SOURCE_DIR}" + COMMAND ${CMAKE_C_CLANG_TIDY} + "--checks=-clang-diagnostic-unused-function" + ${_sources} -- ${_cc} ${_definitions} ${_includes} ${_incsys} ${_options} + DEPENDS ${_sources}) + add_dependencies(tests-clang-tidy ${_target_clang_tidy}) + endif() +endfunction() + +# Internal: Recurse into interface targets and collect their libraries +# and library paths. +macro(curl_collect_target_link_options _target) + get_target_property(_val ${_target} INTERFACE_LINK_DIRECTORIES) + if(_val) + list(APPEND _libdirs ${_val}) + endif() + get_target_property(_val ${_target} IMPORTED) + if(_val) + # LOCATION is empty for interface library targets and safe to ignore. + # Explicitly skip this query to avoid CMake v3.18 and older erroring out. + get_target_property(_val ${_target} TYPE) + if(NOT "${_val}" STREQUAL "INTERFACE_LIBRARY") + get_target_property(_val ${_target} LOCATION) + if(_val) + list(APPEND _libs ${_val}) + endif() + endif() + endif() + get_target_property(_val ${_target} INTERFACE_LINK_LIBRARIES) + if(_val) + foreach(_lib IN LISTS _val) + # Extract imported target name from e.g. "$" set by libssh2 + string(REGEX REPLACE "^\\\$\$" "\\1" _lib "${_lib}") + if(TARGET "${_lib}") + curl_collect_target_link_options(${_lib}) + else() + list(APPEND _libs ${_lib}) + endif() + endforeach() + endif() + unset(_val) +endmacro() diff --git a/3rdparty/curl-8.21.0/CMake/OtherTests.cmake b/3rdparty/curl-8.21.0/CMake/OtherTests.cmake new file mode 100644 index 0000000000..6619f3ab3e --- /dev/null +++ b/3rdparty/curl-8.21.0/CMake/OtherTests.cmake @@ -0,0 +1,149 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +include(CheckCSourceCompiles) +include(CheckCSourceRuns) +include(CheckTypeSize) + +# #include header if condition is true +macro(curl_add_header_include _check _header) + if(${_check}) + set(_source_epilogue "${_source_epilogue} + #include <${_header}>") + endif() +endmacro() + +set(_cmake_try_compile_target_type_save ${CMAKE_TRY_COMPILE_TARGET_TYPE}) +set(CMAKE_TRY_COMPILE_TARGET_TYPE "STATIC_LIBRARY") + +if(NOT DEFINED HAVE_STRUCT_SOCKADDR_STORAGE) + cmake_push_check_state() + set(CMAKE_EXTRA_INCLUDE_FILES "") + if(WIN32) + set(CMAKE_EXTRA_INCLUDE_FILES "winsock2.h") + list(APPEND CMAKE_REQUIRED_LIBRARIES "ws2_32") + else() + set(CMAKE_EXTRA_INCLUDE_FILES "sys/socket.h") + endif() + check_type_size("struct sockaddr_storage" SIZEOF_STRUCT_SOCKADDR_STORAGE) + set(HAVE_STRUCT_SOCKADDR_STORAGE ${HAVE_SIZEOF_STRUCT_SOCKADDR_STORAGE}) + cmake_pop_check_state() +endif() + +set(_source_epilogue "#undef inline") +check_c_source_compiles("${_source_epilogue} + #ifdef _MSC_VER + #include + #endif + #ifndef _WIN32 + #include + #endif + #include + int main(void) + { + struct timeval ts; + ts.tv_sec = 0; + ts.tv_usec = 0; + (void)ts; + return 0; + }" HAVE_STRUCT_TIMEVAL) + +set(CMAKE_TRY_COMPILE_TARGET_TYPE ${_cmake_try_compile_target_type_save}) +unset(_cmake_try_compile_target_type_save) + +# Detect HAVE_GETADDRINFO_THREADSAFE + +if(WIN32) + set(HAVE_GETADDRINFO_THREADSAFE ${HAVE_GETADDRINFO}) +elseif(NOT HAVE_GETADDRINFO) + set(HAVE_GETADDRINFO_THREADSAFE FALSE) +elseif(APPLE OR + AIX OR CMAKE_SYSTEM_NAME STREQUAL "AIX" OR + CMAKE_SYSTEM_NAME STREQUAL "FreeBSD" OR + CMAKE_SYSTEM_NAME STREQUAL "HP-UX" OR + CMAKE_SYSTEM_NAME STREQUAL "MidnightBSD" OR + CMAKE_SYSTEM_NAME STREQUAL "NetBSD" OR + CMAKE_SYSTEM_NAME STREQUAL "SunOS") + set(HAVE_GETADDRINFO_THREADSAFE TRUE) +elseif(BSD OR CMAKE_SYSTEM_NAME MATCHES "BSD") + set(HAVE_GETADDRINFO_THREADSAFE FALSE) +endif() + +if(NOT DEFINED HAVE_GETADDRINFO_THREADSAFE) + set(_source_epilogue "#undef inline + #ifndef _WIN32 + #include + #include + #endif") + curl_add_header_include(HAVE_NETDB_H "netdb.h") + check_c_source_compiles("${_source_epilogue} + int main(void) + { + #ifndef h_errno + #error force compilation error + #endif + return 0; + }" HAVE_H_ERRNO) + + if(NOT HAVE_H_ERRNO) + check_c_source_compiles("${_source_epilogue} + int main(void) + { + h_errno = 2; + return h_errno != 0 ? 1 : 0; + }" HAVE_H_ERRNO_ASSIGNABLE) + + if(NOT HAVE_H_ERRNO_ASSIGNABLE) + check_c_source_compiles("${_source_epilogue} + int main(void) + { + #if defined(_POSIX_C_SOURCE) && (_POSIX_C_SOURCE >= 200809L) + #elif defined(_XOPEN_SOURCE) && (_XOPEN_SOURCE >= 700) + #else + #error force compilation error + #endif + return 0; + }" HAVE_H_ERRNO_SBS_ISSUE_7) + endif() + endif() + + if(HAVE_H_ERRNO OR HAVE_H_ERRNO_ASSIGNABLE OR HAVE_H_ERRNO_SBS_ISSUE_7) + set(HAVE_GETADDRINFO_THREADSAFE TRUE) + endif() +endif() + +if(NOT WIN32 AND NOT DEFINED HAVE_CLOCK_GETTIME_MONOTONIC_RAW) + set(_source_epilogue "#undef inline") + curl_add_header_include(HAVE_SYS_TYPES_H "sys/types.h") + check_c_source_compiles("${_source_epilogue} + #include + #include + int main(void) + { + struct timespec ts; + (void)clock_gettime(CLOCK_MONOTONIC_RAW, &ts); + return 0; + }" HAVE_CLOCK_GETTIME_MONOTONIC_RAW) +endif() + +unset(_source_epilogue) diff --git a/3rdparty/curl-8.21.0/CMake/PickyWarnings.cmake b/3rdparty/curl-8.21.0/CMake/PickyWarnings.cmake new file mode 100644 index 0000000000..1ce5f7bda6 --- /dev/null +++ b/3rdparty/curl-8.21.0/CMake/PickyWarnings.cmake @@ -0,0 +1,462 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +include(CheckCCompilerFlag) + +set(_picky "") +set(_picky_nocheck "") # not to pass to feature checks + +if(CURL_WERROR) + if(CMAKE_VERSION VERSION_GREATER_EQUAL 3.24) + set(CMAKE_COMPILE_WARNING_AS_ERROR ON) + elseif(MSVC) + list(APPEND _picky_nocheck "-WX") + else() # llvm/clang and gcc-style options + list(APPEND _picky_nocheck "-Werror") + endif() + + if((CMAKE_C_COMPILER_ID STREQUAL "GNU" AND + NOT DOS AND # Watt-32 headers use the '#include_next' GCC extension + CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 5.0) OR + CMAKE_C_COMPILER_ID MATCHES "Clang") + list(APPEND _picky_nocheck "-pedantic-errors") + endif() +endif() + +if(APPLE AND + (CMAKE_C_COMPILER_ID STREQUAL "Clang" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 3.6) OR + (CMAKE_C_COMPILER_ID STREQUAL "AppleClang" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 6.1)) + list(APPEND _picky "-Werror=partial-availability") # clang 3.6 appleclang 6.1 +endif() + +if(CMAKE_C_COMPILER_ID STREQUAL "GNU" OR CMAKE_C_COMPILER_ID MATCHES "Clang") + list(APPEND _picky "-Werror-implicit-function-declaration") # clang 1.0 gcc 2.95 +endif() + +if(MSVC) + list(APPEND _picky "-W4") # Use the highest warning level for Visual Studio. +elseif(BORLAND) + list(APPEND _picky "-w-") # Disable warnings on Borland to avoid changing 3rd party code. +endif() + +if(PICKY_COMPILER) + # Leave disabled for GCC <4.6, because they lack #pragma features to silence locally. + if((CMAKE_C_COMPILER_ID STREQUAL "GNU" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 4.6) OR + CMAKE_C_COMPILER_ID MATCHES "Clang") + + # https://clang.llvm.org/docs/DiagnosticsReference.html + # https://gcc.gnu.org/onlinedocs/gcc/Warning-Options.html + + # _picky_enable = Options we want to enable as-is. + # _picky_detect = Options we want to test first and enable if available. + + # Prefer the -Wextra alias with clang. + if(CMAKE_C_COMPILER_ID MATCHES "Clang") + set(_picky_enable "-Wextra") + else() + set(_picky_enable "-W") + endif() + + list(APPEND _picky_enable "-Wall") + + if((CMAKE_C_COMPILER_ID STREQUAL "Clang" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 3.2) OR + (CMAKE_C_COMPILER_ID STREQUAL "AppleClang" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 4.2) OR + CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 4.8) + list(APPEND _picky_enable "-Wpedantic") # clang 3.2 gcc 4.8 appleclang 4.2 + else() + list(APPEND _picky_enable "-pedantic") + endif() + + # ---------------------------------- + # Add new options here, if in doubt: + # ---------------------------------- + set(_picky_detect + ) + + # Notes: -Wno-* options should ideally be disabled at their precise cutoff versions, + # to suppress undesired warnings in case -Weverything is passed as a custom option. + + # Assume these options always exist with both clang and gcc. + # Require clang 3.0 / gcc 2.95 or later. + list(APPEND _picky_enable + -Wbad-function-cast # clang 2.7 gcc 2.95 + -Wconversion # clang 2.7 gcc 2.95 + -Wmissing-declarations # clang 1.0 gcc 2.7 + -Wmissing-prototypes # clang 1.0 gcc 1.0 + -Wnested-externs # clang 1.0 gcc 2.7 + -Wno-long-long # clang 1.0 gcc 2.95 + -Wno-multichar # clang 1.0 gcc 2.95 + -Wpointer-arith # clang 1.0 gcc 1.4 + -Wshadow # clang 1.0 gcc 2.95 + -Wsign-compare # clang 1.0 gcc 2.95 + -Wundef # clang 1.0 gcc 2.95 + -Wunused # clang 1.1 gcc 2.95 + -Wwrite-strings # clang 1.0 gcc 1.4 + ) + + # Always enable with clang, version dependent with gcc + set(_picky_common_old + -Waddress # clang 2.7 gcc 4.3 + -Wattributes # clang 2.7 gcc 4.1 + -Wcast-align # clang 1.0 gcc 4.2 + -Wcast-qual # clang 2.7 gcc 3.4.6 + -Wdeclaration-after-statement # clang 1.0 gcc 3.4 + -Wdiv-by-zero # clang 2.7 gcc 4.1 + -Wempty-body # clang 2.7 gcc 4.3 + -Wendif-labels # clang 1.0 gcc 3.3 + -Wfloat-equal # clang 1.0 gcc 2.96 (3.0) + -Wformat-security # clang 2.7 gcc 4.1 + -Wignored-qualifiers # clang 2.8 gcc 4.3 + -Wmissing-field-initializers # clang 2.7 gcc 4.1 + -Wmissing-noreturn # clang 2.7 gcc 4.1 + -Wno-padded # clang 2.9 gcc 4.1 # Not used: We cannot change public structs + -Wno-sign-conversion # clang 2.9 gcc 4.3 + -Wno-switch-default # clang 2.7 gcc 4.1 # Not used: Annoying to fix or silence + -Wno-switch-enum # clang 2.7 gcc 4.1 # Not used: It basically disallows default case + -Wno-system-headers # clang 1.0 gcc 3.0 + -Wold-style-definition # clang 2.7 gcc 3.4 + -Wredundant-decls # clang 2.7 gcc 4.1 + -Wstrict-prototypes # clang 1.0 gcc 3.3 + -Wtype-limits # clang 2.7 gcc 4.3 + -Wunreachable-code # clang 2.7 gcc 4.1 + # -Wunused-macros # clang 2.7 gcc 4.1 # Not practical + # -Wno-error=unused-macros # clang 2.7 gcc 4.1 + -Wunused-parameter # clang 2.7 gcc 4.1 + -Wvla # clang 2.8 gcc 4.3 + ) + + if(CMAKE_C_COMPILER_ID MATCHES "Clang") + list(APPEND _picky_enable + ${_picky_common_old} + -Wconditional-uninitialized # clang 3.0 + -Wno-used-but-marked-unused # clang 2.9 # for typecheck-gcc.h with clang 14+, dependency headers + -Wshift-sign-overflow # clang 2.9 + -Wshorten-64-to-32 # clang 1.0 + -Wformat=2 # clang 2.7 gcc 4.8 + ) + if(NOT MSVC) + list(APPEND _picky_enable + -Wlanguage-extension-token # clang 3.0 + ) + endif() + # Enable based on compiler version + if(CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 3.1) + list(APPEND _picky_enable + -Wno-covered-switch-default # clang 3.1 appleclang 3.1 # Annoying to fix or silence + -Wno-disabled-macro-expansion # clang 3.1 appleclang 3.1 # for std headers, and curl/curl.h (rare combos) + ) + if(MSVC) + list(APPEND _picky_enable + -Wno-format-non-iso # clang 3.1 appleclang 3.1 # 'q' length modifier is not supported by ISO C + ) + else() + list(APPEND _picky_enable + -Wformat-non-iso # clang 3.1 appleclang 3.1 + ) + endif() + endif() + if((CMAKE_C_COMPILER_ID STREQUAL "Clang" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 3.3) OR + (CMAKE_C_COMPILER_ID STREQUAL "AppleClang" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 5.0)) + list(APPEND _picky_enable + -Wenum-conversion # clang 3.2 gcc 10.0 appleclang 4.2 g++ 11.0 + -Wmissing-variable-declarations # clang 3.2 appleclang 4.2 + -Wno-documentation-unknown-command # clang 3.3 appleclang 5.0 + -Wsometimes-uninitialized # clang 3.2 appleclang 4.2 + ) + endif() + if((CMAKE_C_COMPILER_ID STREQUAL "Clang" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 3.6) OR + (CMAKE_C_COMPILER_ID STREQUAL "AppleClang" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 6.1)) + list(APPEND _picky_enable + -Wdouble-promotion # clang 3.6 gcc 4.6 appleclang 6.1 + -Wheader-guard # clang 3.4 appleclang 5.1 + -Wpragmas # clang 3.5 gcc 4.1 appleclang 6.0 + # -Wunreachable-code-break # clang 3.5 appleclang 6.0 # Not used: Silent in "unity" builds + -Wunused-const-variable # clang 3.4 gcc 6.0 appleclang 5.1 + ) + endif() + if((CMAKE_C_COMPILER_ID STREQUAL "Clang" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 3.9) OR + (CMAKE_C_COMPILER_ID STREQUAL "AppleClang" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 8.1)) + list(APPEND _picky_enable + -Wcomma # clang 3.9 appleclang 8.1 + ) + if(MSVC) + list(APPEND _picky_enable + -Wno-nonportable-system-include-path # clang 3.9 appleclang 8.1 # No truly portable solution to this + ) + endif() + endif() + if((CMAKE_C_COMPILER_ID STREQUAL "Clang" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 7.0) OR + (CMAKE_C_COMPILER_ID STREQUAL "AppleClang" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 11)) + list(APPEND _picky_enable + -Wassign-enum # clang 7.0 appleclang 11.0 + -Wextra-semi-stmt # clang 7.0 appleclang 11.0 + ) + endif() + if((CMAKE_C_COMPILER_ID STREQUAL "Clang" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 10.0) OR + (CMAKE_C_COMPILER_ID STREQUAL "AppleClang" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 12)) + list(APPEND _picky_enable + -Wimplicit-fallthrough # clang 4.0 gcc 7.0 appleclang 9.0 # We do silencing for clang 10.0 and above only + -Wxor-used-as-pow # clang 10.0 gcc 13.0 appleclang 12.0 + ) + endif() + if((CMAKE_C_COMPILER_ID STREQUAL "Clang" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 13.0) OR + (CMAKE_C_COMPILER_ID STREQUAL "AppleClang" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 13.1)) + list(APPEND _picky_enable + -Wcast-function-type # clang 13.0 appleclang 13.1 + -Wreserved-identifier # clang 13.0 appleclang 13.1 # Keep it before -Wno-reserved-macro-identifier + -Wno-reserved-macro-identifier # clang 13.0 appleclang 13.1 # External macros have to be set sometimes + ) + endif() + if((CMAKE_C_COMPILER_ID STREQUAL "Clang" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 15.0) OR + (CMAKE_C_COMPILER_ID STREQUAL "AppleClang" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 14.0.3)) + if(CMAKE_GENERATOR STREQUAL "FASTBuild") + list(APPEND _picky_enable + -Wno-gnu-line-marker # clang 15.0 appleclang 14.0.3 + ) + endif() + endif() + if((CMAKE_C_COMPILER_ID STREQUAL "Clang" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 16.0) OR + (CMAKE_C_COMPILER_ID STREQUAL "AppleClang" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 15.0)) + list(APPEND _picky_enable + -Wno-unsafe-buffer-usage # clang 16.0 appleclang 15.0 + ) + endif() + if((CMAKE_C_COMPILER_ID STREQUAL "Clang" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 16.0) OR + (CMAKE_C_COMPILER_ID STREQUAL "AppleClang" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 16.0)) + list(APPEND _picky_enable + -Wcast-function-type-strict # clang 16.0 appleclang 16.0 + ) + endif() + if((CMAKE_C_COMPILER_ID STREQUAL "Clang" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 19.1) OR + (CMAKE_C_COMPILER_ID STREQUAL "AppleClang" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 17.0)) + list(APPEND _picky_enable + -Wformat-signedness # clang 19.1 gcc 5.1 appleclang 17.0 # In clang-cl enums are signed ints by default + ) + endif() + if((CMAKE_C_COMPILER_ID STREQUAL "Clang" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 21.1) OR + (CMAKE_C_COMPILER_ID STREQUAL "AppleClang" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 26.4)) + list(APPEND _picky_enable + -Warray-compare # clang 20.1 gcc 12.0 appleclang 26.4 + -Wc++-hidden-decl # clang 21.1 appleclang 26.4 + -Wimplicit-int-enum-cast # clang 21.1 + -Wjump-misses-init # clang 21.1 gcc 4.5 appleclang 26.4 + -Wno-implicit-void-ptr-cast # clang 21.1 appleclang 26.4 + -Wtentative-definition-compat # clang 21.1 appleclang 26.4 + ) + if(WIN32) + list(APPEND _picky_enable + -Wno-c++-keyword # clang 21.1 appleclang 26.4 # `wchar_t` triggers it on Windows + ) + else() + list(APPEND _picky_enable + -Wc++-keyword # clang 21.1 appleclang 26.4 + ) + endif() + endif() + else() # gcc + # Enable based on compiler version + if(CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 4.3) + list(APPEND _picky_enable + ${_picky_common_old} + -Wclobbered # gcc 4.3 + -Wmissing-parameter-type # gcc 4.3 + -Wold-style-declaration # gcc 4.3 + -Wpragmas # clang 3.5 gcc 4.1 appleclang 6.0 + -Wstrict-aliasing=3 # gcc 4.0 + -ftree-vrp # gcc 4.3 (required for -Warray-bounds, included in -Wall) + ) + endif() + if(CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 4.5) + list(APPEND _picky_enable + -Wjump-misses-init # clang 21.1 gcc 4.5 appleclang 26.4 + ) + if(MINGW) + list(APPEND _picky_enable + -Wno-pedantic-ms-format # gcc 4.5 (MinGW-only) + ) + endif() + endif() + if(CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 4.8) + list(APPEND _picky_enable + -Wdouble-promotion # clang 3.6 gcc 4.6 appleclang 6.1 + -Wformat=2 # clang 2.7 gcc 4.8 + -Wlogical-op # gcc 4.4 + -Wtrampolines # gcc 4.6 + ) + endif() + if(CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 5.0) + list(APPEND _picky_enable + -Warray-bounds=2 # clang 2.9 gcc 5.0 (clang default: -Warray-bounds) + -Wformat-signedness # clang 19.1 gcc 5.1 appleclang 17.0 + ) + endif() + if(CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 6.0) + list(APPEND _picky_enable + -Wduplicated-cond # gcc 6.0 + -Wnull-dereference # clang 2.9 gcc 6.0 (clang default) + -fdelete-null-pointer-checks + -Wshift-negative-value # clang 3.7 gcc 6.0 (clang default) + -Wshift-overflow=2 # clang 2.9 gcc 6.0 (clang default: -Wshift-overflow) + -Wunused-const-variable # clang 3.4 gcc 6.0 appleclang 5.1 + ) + endif() + if(CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 7.0) + list(APPEND _picky_enable + -Walloc-zero # gcc 7.0 + -Wduplicated-branches # gcc 7.0 + -Wformat-truncation=2 # gcc 7.0 + -Wimplicit-fallthrough # clang 4.0 gcc 7.0 appleclang 9.0 + -Wrestrict # gcc 7.0 + ) + endif() + if(CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 10.0) + list(APPEND _picky_enable + -Warith-conversion # gcc 10.0 + -Wenum-conversion # clang 3.2 gcc 10.0 appleclang 4.2 g++ 11.0 + ) + endif() + if(CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 13.0) + list(APPEND _picky_enable + -Warray-compare # clang 20.1 gcc 12.0 appleclang 26.4 + -Wenum-int-mismatch # gcc 13.0 + -Wxor-used-as-pow # clang 10.0 gcc 13.0 appleclang 12.0 + ) + endif() + if(CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 15.0) + list(APPEND _picky_enable + -Wleading-whitespace=spaces # gcc 15.0 + -Wtrailing-whitespace=any # gcc 15.0 + -Wunterminated-string-initialization # gcc 15.0 + ) + endif() + endif() + + # Assemble list of flags + + set(_picky_skipped "") + foreach(_ccopt IN LISTS _picky_enable) + string(REGEX MATCH "-W([a-z0-9+-]+)" _ccmatch "${_ccopt}") + string(REPLACE "+" "\\+" _cmake_match_1 "${CMAKE_MATCH_1}") # escape '+' to make it a valid regex + if(_ccmatch AND "${CMAKE_C_FLAGS} " MATCHES "-Wno-${_cmake_match_1} " AND + NOT _ccopt STREQUAL "-Wall" AND + NOT _ccopt MATCHES "^-Wno-") + string(APPEND _picky_skipped " ${_ccopt}") + else() + list(APPEND _picky "${_ccopt}") + endif() + endforeach() + if(_picky_skipped) + message(STATUS "Picky compiler options skipped due to CMAKE_C_FLAGS override:${_picky_skipped}") + endif() + + foreach(_ccopt IN LISTS _picky_detect) + # Use a unique variable name 1. for meaningful log output 2. to have a fresh, undefined variable for each detection + string(MAKE_C_IDENTIFIER "OPT${_ccopt}" _optvarname) + # GCC only warns about unknown -Wno- options if there are also other diagnostic messages, + # so test for the positive form instead + string(REPLACE "-Wno-" "-W" _ccopt_on "${_ccopt}") + check_c_compiler_flag(${_ccopt_on} ${_optvarname}) + if(${_optvarname}) + list(APPEND _picky "${_ccopt}") + endif() + endforeach() + + if(CMAKE_C_COMPILER_ID STREQUAL "GNU") + if(CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 4.0 AND CMAKE_C_COMPILER_VERSION VERSION_LESS 4.7) + list(APPEND _picky "-Wno-missing-field-initializers") # https://gcc.gnu.org/bugzilla/show_bug.cgi?id=36750 + endif() + if(CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 4.3 AND CMAKE_C_COMPILER_VERSION VERSION_LESS 4.8) + list(APPEND _picky "-Wno-type-limits") # Avoid false positives + endif() + if(CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 5.1 AND CMAKE_C_COMPILER_VERSION VERSION_LESS 5.5) + list(APPEND _picky "-Wno-conversion") # Avoid false positives + endif() + endif() + elseif(MSVC AND MSVC_VERSION LESS_EQUAL 1951) # Enable for tested versions only + list(APPEND _picky "-Wall") + list(APPEND _picky "-wd4061") # enumerator 'A' in switch of enum 'B' is not explicitly handled by a case label + list(APPEND _picky "-wd4191") # 'type cast': unsafe conversion from 'FARPROC' to 'void (__cdecl *)(void)' + list(APPEND _picky "-wd4255") # no function prototype given: converting '()' to '(void)' (in winuser.h) + list(APPEND _picky "-wd4464") # relative include path contains '..' + list(APPEND _picky "-wd4548") # expression before comma has no effect; expected expression with side-effect (in FD_SET()) + list(APPEND _picky "-wd4574") # 'M' is defined to be '0': did you mean to use '#if M'? (in ws2tcpip.h) + list(APPEND _picky "-wd4668") # 'M' is not defined as a preprocessor macro, replacing with '0' for '#if/#elif' (in winbase.h) + list(APPEND _picky "-wd4710") # 'fprintf'/'printf'/'sscanf': function not inlined (in tests, with VS2022+ Release) + list(APPEND _picky "-wd4711") # function 'A' selected for automatic inline expansion + # volatile access of '' is subject to /volatile: setting; + # consider using __iso_volatile_load/store intrinsic functions (ARM64) + list(APPEND _picky "-wd4746") + list(APPEND _picky "-wd4820") # 'A': 'N' bytes padding added after data member 'B' + if(MSVC_VERSION GREATER_EQUAL 1900) + list(APPEND _picky "-wd5045") # Compiler inserts Spectre mitigation for memory load if /Qspectre switch specified + endif() + endif() +endif() + +# clang-cl +if(CMAKE_C_COMPILER_ID STREQUAL "Clang" AND MSVC) + list(APPEND _picky "-Wno-language-extension-token") # Allow __int64 + + foreach(_wlist IN ITEMS _picky_nocheck _picky) + set(_picky_tmp "") + foreach(_ccopt IN LISTS "${_wlist}") + # Prefix -Wall, otherwise clang-cl interprets it as an MSVC option and translates it to -Weverything + if(_ccopt MATCHES "^-W" AND NOT _ccopt STREQUAL "-Wall") + list(APPEND _picky_tmp ${_ccopt}) + else() + list(APPEND _picky_tmp "-clang:${_ccopt}") + endif() + endforeach() + set("${_wlist}" ${_picky_tmp}) # cmake-lint: disable=C0103 + endforeach() +endif() + +if(CMAKE_C_STANDARD STREQUAL 90) + if((CMAKE_C_COMPILER_ID STREQUAL "Clang" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 3.0) OR + (CMAKE_C_COMPILER_ID STREQUAL "AppleClang" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 4.2)) + list(APPEND _picky "-Wno-c99-extensions") # Avoid: warning: '_Bool' is a C99 extension + endif() + if((CMAKE_C_COMPILER_ID STREQUAL "Clang" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 3.9) OR + (CMAKE_C_COMPILER_ID STREQUAL "AppleClang" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 8.1)) + list(APPEND _picky "-Wno-comma") # Silly + endif() +endif() + +if(DOS AND CMAKE_C_COMPILER_ID STREQUAL "GNU" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 10.0) + list(APPEND _picky "-Wno-arith-conversion") # Avoid warnings in DJGPP's built-in FD_SET() macro +endif() + +if(_picky_nocheck OR _picky) + set(_picky_tmp "${_picky_nocheck}" "${_picky}") + string(REPLACE ";" " " _picky_tmp "${_picky_tmp}") + string(STRIP "${_picky_tmp}" _picky_tmp) + message(STATUS "Picky compiler options: ${_picky_tmp}") + set_property(DIRECTORY APPEND PROPERTY COMPILE_OPTIONS "${_picky_nocheck}" "${_picky}") + + # Apply to all feature checks + string(REPLACE ";" " " _picky_tmp "${_picky}") + string(APPEND CMAKE_REQUIRED_FLAGS " ${_picky_tmp}") + + unset(_picky) + unset(_picky_tmp) +endif() diff --git a/3rdparty/curl-8.21.0/CMake/Utilities.cmake b/3rdparty/curl-8.21.0/CMake/Utilities.cmake new file mode 100644 index 0000000000..f86a6aa1e8 --- /dev/null +++ b/3rdparty/curl-8.21.0/CMake/Utilities.cmake @@ -0,0 +1,86 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# File containing various utilities + +# Return number of arguments that evaluate to true +function(curl_count_true _output_count_var) + set(_list_len 0) + foreach(_option_var IN LISTS ARGN) + if(${_option_var}) + math(EXPR _list_len "${_list_len} + 1") + endif() + endforeach() + set(${_output_count_var} ${_list_len} PARENT_SCOPE) +endfunction() + +# Dump all defined variables with their values +function(curl_dumpvars) + message("::group::CMake Variable Dump") + get_cmake_property(_vars VARIABLES) + foreach(_var IN ITEMS ${_vars}) + get_property(_var_type CACHE ${_var} PROPERTY TYPE) + get_property(_var_advanced CACHE ${_var} PROPERTY ADVANCED) + if(_var_type) + set(_var_type ":${_var_type}") + endif() + if(_var_advanced) + set(_var_advanced " [adv]") + endif() + message("${_var}${_var_type}${_var_advanced} = '${${_var}}'") + endforeach() + message("::endgroup::") +endfunction() + +# Dump all target properties +function(curl_dumptargetprops _target) + if(CMAKE_VERSION VERSION_GREATER_EQUAL 3.19 AND TARGET "${_target}") + execute_process(COMMAND "${CMAKE_COMMAND}" "--help-property-list" OUTPUT_VARIABLE _cmake_property_list) + string(REPLACE "\n" ";" _cmake_property_list "${_cmake_property_list}") + list(REMOVE_DUPLICATES _cmake_property_list) + list(REMOVE_ITEM _cmake_property_list "") + list(APPEND _cmake_property_list "INTERFACE_LIBCURL_PC_MODULES") + get_target_property(_target_imported ${_target} IMPORTED) + if(NOT _target_imported) + list(REMOVE_ITEM _cmake_property_list "LOCATION" "LOCATION_" "MACOSX_PACKAGE_LOCATION" "VS_DEPLOYMENT_LOCATION") + endif() + foreach(_prop IN LISTS _cmake_property_list) + if(_prop MATCHES "") + foreach(_config IN ITEMS "DEBUG" "RELEASE" "MINSIZEREL" "RELWITHDEBINFO") + string(REPLACE "" "${_config}" _propconfig "${_prop}") + get_property(_is_set TARGET "${_target}" PROPERTY "${_propconfig}" SET) + if(_is_set) + get_target_property(_val "${_target}" "${_propconfig}") + message("${_target}.${_propconfig} = '${_val}'") + endif() + endforeach() + else() + get_property(_is_set TARGET "${_target}" PROPERTY "${_prop}" SET) + if(_is_set) + get_target_property(_val "${_target}" "${_prop}") + message("${_target}.${_prop} = '${_val}'") + endif() + endif() + endforeach() + endif() +endfunction() diff --git a/3rdparty/curl-8.21.0/CMake/cmake_uninstall.in.cmake b/3rdparty/curl-8.21.0/CMake/cmake_uninstall.in.cmake new file mode 100644 index 0000000000..bb95d85a0a --- /dev/null +++ b/3rdparty/curl-8.21.0/CMake/cmake_uninstall.in.cmake @@ -0,0 +1,50 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +if(NOT EXISTS "@CMAKE_CURRENT_BINARY_DIR@/install_manifest.txt") + message(FATAL_ERROR "Cannot find install manifest: @CMAKE_CURRENT_BINARY_DIR@/install_manifest.txt") +endif() + +if(NOT DEFINED CMAKE_INSTALL_PREFIX) + set(CMAKE_INSTALL_PREFIX "@CMAKE_INSTALL_PREFIX@") +endif() +message(${CMAKE_INSTALL_PREFIX}) + +file(READ "@CMAKE_CURRENT_BINARY_DIR@/install_manifest.txt" _files) +string(REGEX REPLACE "\n" ";" _files "${_files}") +foreach(_file ${_files}) + message(STATUS "Uninstalling $ENV{DESTDIR}${_file}") + if(IS_SYMLINK "$ENV{DESTDIR}${_file}" OR EXISTS "$ENV{DESTDIR}${_file}") + execute_process( + COMMAND "@CMAKE_COMMAND@" -E remove "$ENV{DESTDIR}${_file}" + RESULT_VARIABLE rm_retval + OUTPUT_QUIET + ERROR_QUIET + ) + if(NOT "${rm_retval}" STREQUAL 0) + message(FATAL_ERROR "Problem when removing $ENV{DESTDIR}${_file}") + endif() + else() + message(STATUS "File $ENV{DESTDIR}${_file} does not exist.") + endif() +endforeach() diff --git a/3rdparty/curl-8.21.0/CMake/curl-config.in.cmake b/3rdparty/curl-8.21.0/CMake/curl-config.in.cmake new file mode 100644 index 0000000000..b4300ca210 --- /dev/null +++ b/3rdparty/curl-8.21.0/CMake/curl-config.in.cmake @@ -0,0 +1,196 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +@PACKAGE_INIT@ + +option(CURL_USE_CMAKECONFIG "Enable detecting @PROJECT_NAME@ dependencies via CMake Config. Default: @CURL_USE_CMAKECONFIG@" + "@CURL_USE_CMAKECONFIG@") +option(CURL_USE_PKGCONFIG "Enable pkg-config to detect @PROJECT_NAME@ dependencies. Default: @CURL_USE_PKGCONFIG@" + "@CURL_USE_PKGCONFIG@") + +if(CMAKE_VERSION VERSION_LESS @CMAKE_MINIMUM_REQUIRED_VERSION@) + message(STATUS "@PROJECT_NAME@: @PROJECT_NAME@-specific Find modules require " + "CMake @CMAKE_MINIMUM_REQUIRED_VERSION@ or upper, found: ${CMAKE_VERSION}.") +endif() + +include(CMakeFindDependencyMacro) + +if("@HAVE_THREADS_POSIX@" OR "@HAVE_THREADS_POSIX_BORINGSSL@") + find_dependency(Threads) # for Threads::Threads +endif() + +if("@USE_OPENSSL@") + if("@OPENSSL_VERSION_MAJOR@") + find_dependency(OpenSSL "@OPENSSL_VERSION_MAJOR@") + else() + find_dependency(OpenSSL) + endif() + # Define lib duplicate to fixup lib order for GCC binutils ld in static builds + if(TARGET OpenSSL::Crypto AND NOT TARGET CURL::OpenSSL_Crypto) + add_library(CURL::OpenSSL_Crypto INTERFACE IMPORTED) + set_target_properties(CURL::OpenSSL_Crypto PROPERTIES INTERFACE_LINK_LIBRARIES OpenSSL::Crypto) + endif() +endif() +if("@HAVE_LIBZ@") + find_dependency(ZLIB "@ZLIB_VERSION_MAJOR@") + # Define lib duplicate to fixup lib order for GCC binutils ld in static builds + if(TARGET ZLIB::ZLIB AND NOT TARGET CURL::ZLIB) + add_library(CURL::ZLIB INTERFACE IMPORTED) + set_target_properties(CURL::ZLIB PROPERTIES INTERFACE_LINK_LIBRARIES ZLIB::ZLIB) + endif() +endif() + +set(_curl_cmake_module_path_save ${CMAKE_MODULE_PATH}) +list(PREPEND CMAKE_MODULE_PATH ${CMAKE_CURRENT_LIST_DIR}) + +set(_curl_libs "") + +if("@HAVE_BROTLI@") + find_dependency(Brotli MODULE) + list(APPEND _curl_libs CURL::brotli) +endif() +if("@USE_ARES@") + find_dependency(Cares MODULE) + list(APPEND _curl_libs CURL::cares) +endif() +if("@HAVE_GSSAPI@") + find_dependency(GSS MODULE) + list(APPEND _curl_libs CURL::gss) +endif() +if("@USE_BACKTRACE@") + find_dependency(Libbacktrace MODULE) + list(APPEND _curl_libs CURL::libbacktrace) +endif() +if("@USE_GSASL@") + find_dependency(Libgsasl MODULE) + list(APPEND _curl_libs CURL::libgsasl) +endif() +if(NOT "@USE_WIN32_LDAP@" AND NOT "@CURL_DISABLE_LDAP@") + find_dependency(LDAP MODULE) + list(APPEND _curl_libs CURL::ldap) +endif() +if("@HAVE_LIBIDN2@") + find_dependency(Libidn2 MODULE) + list(APPEND _curl_libs CURL::libidn2) +endif() +if("@USE_LIBPSL@") + find_dependency(Libpsl MODULE) + list(APPEND _curl_libs CURL::libpsl) +endif() +if("@USE_LIBSSH@") + find_dependency(Libssh MODULE) + list(APPEND _curl_libs CURL::libssh) +endif() +if("@USE_LIBSSH2@") + find_dependency(Libssh2 MODULE) + list(APPEND _curl_libs CURL::libssh2) +endif() +if("@USE_LIBUV@") + find_dependency(Libuv MODULE) + list(APPEND _curl_libs CURL::libuv) +endif() +if("@USE_MBEDTLS@") + find_dependency(MbedTLS MODULE) + list(APPEND _curl_libs CURL::mbedtls) +endif() +if("@USE_NGHTTP2@") + find_dependency(NGHTTP2 MODULE) + list(APPEND _curl_libs CURL::nghttp2) +endif() +if("@USE_NGHTTP3@") + find_dependency(NGHTTP3 MODULE) + list(APPEND _curl_libs CURL::nghttp3) +endif() +if("@USE_NGTCP2@") + find_dependency(NGTCP2 MODULE COMPONENTS "@NGTCP2_CRYPTO_BACKEND@") + list(APPEND _curl_libs CURL::ngtcp2) +endif() +if("@USE_GNUTLS@") + find_dependency(GnuTLS MODULE) + list(APPEND _curl_libs CURL::gnutls) + find_dependency(Nettle MODULE) + list(APPEND _curl_libs CURL::nettle) +endif() +if("@USE_QUICHE@") + find_dependency(Quiche MODULE) + list(APPEND _curl_libs CURL::quiche) +endif() +if("@USE_RUSTLS@") + find_dependency(Rustls MODULE) + list(APPEND _curl_libs CURL::rustls) +endif() +if("@USE_WOLFSSL@") + find_dependency(WolfSSL MODULE) + list(APPEND _curl_libs CURL::wolfssl) +endif() +if("@HAVE_ZSTD@") + find_dependency(Zstd MODULE) + list(APPEND _curl_libs CURL::zstd) +endif() + +set(CMAKE_MODULE_PATH ${_curl_cmake_module_path_save}) + +# Define lib duplicate to fixup lib order for GCC binutils ld in static builds +if(WIN32 AND NOT TARGET CURL::win32_winsock) + add_library(CURL::win32_winsock INTERFACE IMPORTED) + set_target_properties(CURL::win32_winsock PROPERTIES INTERFACE_LINK_LIBRARIES "ws2_32") +endif() + +include("${CMAKE_CURRENT_LIST_DIR}/@TARGETS_EXPORT_NAME@.cmake") + +# Alias for either shared or static library +if(NOT TARGET @PROJECT_NAME@::@LIB_NAME@) + add_library(@PROJECT_NAME@::@LIB_NAME@ ALIAS @PROJECT_NAME@::@LIB_SELECTED@) +endif() + +# For compatibility with CMake's FindCURL.cmake +set(CURL_VERSION_STRING "@CURLVERSION@") +set(CURL_LIBRARIES @PROJECT_NAME@::@LIB_NAME@) +set(CURL_LIBRARIES_PRIVATE "@LIBCURL_PC_LIBS_PRIVATE_LIST@") +set_and_check(CURL_INCLUDE_DIRS "@PACKAGE_CMAKE_INSTALL_INCLUDEDIR@") + +set(CURL_SUPPORTED_PROTOCOLS "@CURL_SUPPORTED_PROTOCOLS_LIST@") +set(CURL_SUPPORTED_FEATURES "@CURL_SUPPORTED_FEATURES_LIST@") + +foreach(_curl_item IN LISTS CURL_SUPPORTED_PROTOCOLS CURL_SUPPORTED_FEATURES) + set(CURL_SUPPORTS_${_curl_item} TRUE) +endforeach() + +set(_curl_missing_req "") +foreach(_curl_item IN LISTS CURL_FIND_COMPONENTS) + if(CURL_SUPPORTS_${_curl_item}) + set(CURL_${_curl_item}_FOUND TRUE) + elseif(CURL_FIND_REQUIRED_${_curl_item}) + list(APPEND _curl_missing_req ${_curl_item}) + endif() +endforeach() + +if(_curl_missing_req) + string(REPLACE ";" " " _curl_missing_req "${_curl_missing_req}") + if(CURL_FIND_REQUIRED) + message(FATAL_ERROR "@PROJECT_NAME@: missing required components: ${_curl_missing_req}") + endif() + unset(_curl_missing_req) +endif() + +check_required_components("@PROJECT_NAME@") diff --git a/3rdparty/curl-8.21.0/CMake/unix-cache.cmake b/3rdparty/curl-8.21.0/CMake/unix-cache.cmake new file mode 100644 index 0000000000..78816499ca --- /dev/null +++ b/3rdparty/curl-8.21.0/CMake/unix-cache.cmake @@ -0,0 +1,332 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# Based on CI runs for Cygwin/MSYS2, Linux, macOS/iOS, DragonFly BSD, FreeBSD, MidnightBSD, NetBSD, OpenBSD +if(NOT UNIX) + message(FATAL_ERROR "This file should be included on Unix platforms only") +endif() + +if(APPLE OR + CYGWIN) + set(HAVE_ACCEPT4 0) +elseif(CMAKE_SYSTEM_NAME STREQUAL "Linux" OR + CMAKE_SYSTEM_NAME STREQUAL "DragonFlyBSD" OR + CMAKE_SYSTEM_NAME STREQUAL "FreeBSD" OR + CMAKE_SYSTEM_NAME STREQUAL "MidnightBSD" OR + CMAKE_SYSTEM_NAME STREQUAL "NetBSD" OR + CMAKE_SYSTEM_NAME STREQUAL "OpenBSD") + set(HAVE_ACCEPT4 1) +endif() +set(HAVE_ALARM 1) +if(ANDROID) + set(HAVE_ARC4RANDOM 1) +else() + set(HAVE_ARC4RANDOM 0) +endif() +set(HAVE_ARPA_INET_H 1) +set(HAVE_ATOMIC 1) +set(HAVE_BASENAME 1) +set(HAVE_BOOL_T 1) +if(NOT APPLE) + set(HAVE_CLOCK_GETTIME_MONOTONIC 1) + if(CMAKE_SYSTEM_NAME STREQUAL "Linux") + set(HAVE_CLOCK_GETTIME_MONOTONIC_RAW 1) + else() + set(HAVE_CLOCK_GETTIME_MONOTONIC_RAW 0) + endif() +endif() +set(HAVE_CLOSESOCKET 0) +set(HAVE_DECL_FSEEKO 1) +set(HAVE_DIRENT_H 1) +if(APPLE OR + CYGWIN OR + CMAKE_SYSTEM_NAME STREQUAL "DragonFlyBSD" OR + CMAKE_SYSTEM_NAME STREQUAL "OpenBSD") + set(HAVE_EVENTFD 0) +elseif(CMAKE_SYSTEM_NAME STREQUAL "Linux" OR + CMAKE_SYSTEM_NAME STREQUAL "FreeBSD" OR + CMAKE_SYSTEM_NAME STREQUAL "MidnightBSD" OR + CMAKE_SYSTEM_NAME STREQUAL "NetBSD") + set(HAVE_EVENTFD 1) +endif() +if(ANDROID AND ANDROID_PLATFORM_LEVEL GREATER_EQUAL 34) + set(HAVE_MEMSET_EXPLICIT 1) +endif() +if((APPLE AND CMAKE_OSX_DEPLOYMENT_TARGET VERSION_GREATER_EQUAL 10.9) OR + CMAKE_SYSTEM_NAME STREQUAL "DragonFlyBSD" OR # v6+ + CMAKE_SYSTEM_NAME STREQUAL "FreeBSD" OR # v11.2+ + CMAKE_SYSTEM_NAME STREQUAL "MidnightBSD") # v1.3+ + set(HAVE_MEMSET_S 1) +elseif(NOT APPLE) + set(HAVE_MEMSET_S 0) +endif() +set(HAVE_FCNTL 1) +set(HAVE_FCNTL_H 1) +set(HAVE_FCNTL_O_NONBLOCK 1) +set(HAVE_FILE_OFFSET_BITS 1) +set(HAVE_FNMATCH 1) +set(HAVE_FREEADDRINFO 1) +set(HAVE_FSEEKO 1) +if(APPLE) + set(HAVE_FSETXATTR 1) + set(HAVE_FSETXATTR_5 0) + set(HAVE_FSETXATTR_6 1) +elseif(CMAKE_SYSTEM_NAME STREQUAL "DragonFlyBSD" OR + CMAKE_SYSTEM_NAME STREQUAL "FreeBSD" OR + CMAKE_SYSTEM_NAME STREQUAL "MidnightBSD" OR + CMAKE_SYSTEM_NAME STREQUAL "OpenBSD") + set(HAVE_FSETXATTR 0) + set(HAVE_FSETXATTR_5 0) + set(HAVE_FSETXATTR_6 0) +elseif(CYGWIN OR + CMAKE_SYSTEM_NAME STREQUAL "Linux" OR + CMAKE_SYSTEM_NAME STREQUAL "NetBSD") + set(HAVE_FSETXATTR 1) + set(HAVE_FSETXATTR_5 1) + set(HAVE_FSETXATTR_6 0) +endif() +set(HAVE_GETADDRINFO 1) +if(CMAKE_SYSTEM_NAME STREQUAL "OpenBSD") + set(HAVE_GETADDRINFO_THREADSAFE 0) +elseif(CYGWIN OR + CMAKE_SYSTEM_NAME STREQUAL "Linux" OR + CMAKE_SYSTEM_NAME STREQUAL "DragonFlyBSD" OR + CMAKE_SYSTEM_NAME STREQUAL "FreeBSD" OR + CMAKE_SYSTEM_NAME STREQUAL "MidnightBSD" OR + CMAKE_SYSTEM_NAME STREQUAL "NetBSD") + set(HAVE_GETADDRINFO_THREADSAFE 1) +endif() +set(HAVE_GETEUID 1) +if(APPLE OR + CYGWIN OR + CMAKE_SYSTEM_NAME STREQUAL "NetBSD" OR + CMAKE_SYSTEM_NAME STREQUAL "OpenBSD") + set(HAVE_GETHOSTBYNAME_R 0) +elseif(CMAKE_SYSTEM_NAME STREQUAL "Linux" OR + CMAKE_SYSTEM_NAME STREQUAL "DragonFlyBSD" OR + CMAKE_SYSTEM_NAME STREQUAL "FreeBSD" OR + CMAKE_SYSTEM_NAME STREQUAL "MidnightBSD") + set(HAVE_GETHOSTBYNAME_R 1) +endif() +set(HAVE_GETHOSTBYNAME_R_3 0) +set(HAVE_GETHOSTBYNAME_R_3_REENTRANT 0) +set(HAVE_GETHOSTBYNAME_R_5 0) +set(HAVE_GETHOSTBYNAME_R_5_REENTRANT 0) +if(CMAKE_SYSTEM_NAME STREQUAL "Linux" OR + CMAKE_SYSTEM_NAME STREQUAL "DragonFlyBSD" OR + CMAKE_SYSTEM_NAME STREQUAL "MidnightBSD") + set(HAVE_GETHOSTBYNAME_R_6 1) + set(HAVE_GETHOSTBYNAME_R_6_REENTRANT 1) +else() + set(HAVE_GETHOSTBYNAME_R_6 0) + set(HAVE_GETHOSTBYNAME_R_6_REENTRANT 0) +endif() +set(HAVE_GETHOSTNAME 1) +if(NOT ANDROID OR ANDROID_PLATFORM_LEVEL GREATER_EQUAL 24) + set(HAVE_GETIFADDRS 1) +else() + set(HAVE_GETIFADDRS 0) +endif() +if(APPLE OR + CYGWIN OR + CMAKE_SYSTEM_NAME STREQUAL "Linux" OR + CMAKE_SYSTEM_NAME STREQUAL "DragonFlyBSD" OR + CMAKE_SYSTEM_NAME STREQUAL "FreeBSD" OR + CMAKE_SYSTEM_NAME STREQUAL "MidnightBSD" OR + CMAKE_SYSTEM_NAME STREQUAL "OpenBSD") + set(HAVE_GETPASS_R 0) +elseif(CMAKE_SYSTEM_NAME STREQUAL "NetBSD") + set(HAVE_GETPASS_R 1) +endif() +set(HAVE_GETPEERNAME 1) +set(HAVE_GETPPID 1) +set(HAVE_GETPWUID 1) +set(HAVE_GETPWUID_R 1) +set(HAVE_GETRLIMIT 1) +set(HAVE_GETSOCKNAME 1) +set(HAVE_GETTIMEOFDAY 1) +if(CMAKE_SYSTEM_NAME STREQUAL "Linux") + # Depends on C library. +else() + set(HAVE_GLIBC_STRERROR_R 0) +endif() +set(HAVE_GMTIME_R 1) +set(HAVE_IFADDRS_H 1) +set(HAVE_IF_NAMETOINDEX 1) +set(HAVE_INET_NTOP 1) +set(HAVE_INET_PTON 1) +set(HAVE_IOCTLSOCKET 0) +set(HAVE_IOCTLSOCKET_CAMEL 0) +set(HAVE_IOCTLSOCKET_CAMEL_FIONBIO 0) +set(HAVE_IOCTLSOCKET_FIONBIO 0) +set(HAVE_IOCTL_FIONBIO 1) +set(HAVE_IOCTL_SIOCGIFADDR 1) +if(CYGWIN) + set(HAVE_IO_H 1) +else() + set(HAVE_IO_H 0) +endif() +set(HAVE_LIBGEN_H 1) +if(CMAKE_SYSTEM_NAME STREQUAL "Linux") + # Requires Linux kernel userspace headers. Expected with glibc. May be missing by default with MUSL. +else() + set(HAVE_LINUX_TCP_H 0) +endif() +set(HAVE_LOCALE_H 1) +set(HAVE_LOCALTIME_R 1) +if(APPLE) + set(HAVE_MACH_ABSOLUTE_TIME 1) +endif() +if(APPLE OR + CYGWIN) + set(HAVE_MEMRCHR 0) +else() + set(HAVE_MEMRCHR 1) +endif() +set(HAVE_NETDB_H 1) +if(ANDROID) + set(HAVE_NETINET_IN6_H 1) +else() + set(HAVE_NETINET_IN6_H 0) +endif() +set(HAVE_NETINET_IN_H 1) +set(HAVE_NETINET_TCP_H 1) +set(HAVE_NETINET_UDP_H 1) +set(HAVE_NET_IF_H 1) +set(HAVE_OPENDIR 1) +set(HAVE_PIPE 1) +if(APPLE OR + CYGWIN) + set(HAVE_PIPE2 0) +elseif(CMAKE_SYSTEM_NAME STREQUAL "Linux" OR + BSD OR + CMAKE_SYSTEM_NAME STREQUAL "DragonFlyBSD" OR + CMAKE_SYSTEM_NAME STREQUAL "FreeBSD" OR + CMAKE_SYSTEM_NAME STREQUAL "MidnightBSD" OR + CMAKE_SYSTEM_NAME STREQUAL "NetBSD" OR + CMAKE_SYSTEM_NAME STREQUAL "OpenBSD" OR + CMAKE_SYSTEM_NAME STREQUAL "SunOS") + set(HAVE_PIPE2 1) +endif() +set(HAVE_POLL 1) +set(HAVE_POLL_H 1) +if(CMAKE_SYSTEM_NAME STREQUAL "Linux") + # Depends on C library. +else() + set(HAVE_POSIX_STRERROR_R 1) +endif() +set(HAVE_PWD_H 1) +set(HAVE_REALPATH 1) +set(HAVE_RECV 1) +set(HAVE_SA_FAMILY_T 1) +set(HAVE_SCHED_YIELD 1) +set(HAVE_SELECT 1) +set(HAVE_SEND 1) +if(APPLE OR + CYGWIN OR + CMAKE_SYSTEM_NAME STREQUAL "DragonFlyBSD") + set(HAVE_SENDMMSG 0) +else() + set(HAVE_SENDMMSG 1) +endif() +set(HAVE_SENDMSG 1) +set(HAVE_SETLOCALE 1) +set(HAVE_SETRLIMIT 1) +set(HAVE_SETSOCKOPT_SO_NONBLOCK 0) +set(HAVE_SIGACTION 1) +set(HAVE_SIGINTERRUPT 1) +set(HAVE_SIGNAL 1) +set(HAVE_SIGSETJMP 1) +set(HAVE_SOCKADDR_IN6_SIN6_ADDR 1) +set(HAVE_SOCKADDR_IN6_SIN6_SCOPE_ID 1) +set(HAVE_SOCKET 1) +set(HAVE_SOCKETPAIR 1) +set(HAVE_STDATOMIC_H 1) +set(HAVE_STDBOOL_H 1) +set(HAVE_STDDEF_H 1) # detected by CMake internally in check_type_size() +set(HAVE_STDINT_H 1) # detected by CMake internally in check_type_size() +set(HAVE_STRCASECMP 1) +set(HAVE_STRCMPI 0) +set(HAVE_STRERROR_R 1) +set(HAVE_STRICMP 0) +set(HAVE_STRINGS_H 1) +if(_CURL_OLD_LINUX) + set(HAVE_STROPTS_H 1) +else() + set(HAVE_STROPTS_H 0) # glibc 2.30 or newer. https://sourceware.org/legacy-ml/libc-alpha/2019-08/msg00029.html +endif() +set(HAVE_STRUCT_SOCKADDR_STORAGE 1) +set(HAVE_STRUCT_TIMEVAL 1) +if(ANDROID OR CMAKE_SYSTEM_NAME STREQUAL "iOS") + set(HAVE_SUSECONDS_T 1) +endif() +if(APPLE OR + CYGWIN OR + CMAKE_SYSTEM_NAME STREQUAL "DragonFlyBSD" OR + CMAKE_SYSTEM_NAME STREQUAL "OpenBSD") + set(HAVE_SYS_EVENTFD_H 0) +elseif(CMAKE_SYSTEM_NAME STREQUAL "Linux" OR + CMAKE_SYSTEM_NAME STREQUAL "FreeBSD" OR + CMAKE_SYSTEM_NAME STREQUAL "MidnightBSD" OR + CMAKE_SYSTEM_NAME STREQUAL "NetBSD") + set(HAVE_SYS_EVENTFD_H 1) +endif() +if(CYGWIN OR + CMAKE_SYSTEM_NAME STREQUAL "Linux") + set(HAVE_SYS_FILIO_H 0) +else() + set(HAVE_SYS_FILIO_H 1) +endif() +set(HAVE_SYS_IOCTL_H 1) +set(HAVE_SYS_PARAM_H 1) +set(HAVE_SYS_POLL_H 1) +set(HAVE_SYS_RESOURCE_H 1) +set(HAVE_SYS_SELECT_H 1) +if(CYGWIN OR + CMAKE_SYSTEM_NAME STREQUAL "Linux") + set(HAVE_SYS_SOCKIO_H 0) +else() + set(HAVE_SYS_SOCKIO_H 1) +endif() +set(HAVE_SYS_TYPES_H 1) +set(HAVE_SYS_UN_H 1) +if(CYGWIN) + set(HAVE_SYS_UTIME_H 1) +else() + set(HAVE_SYS_UTIME_H 0) +endif() +set(HAVE_TERMIOS_H 1) +if(CYGWIN OR + CMAKE_SYSTEM_NAME STREQUAL "Linux") + set(HAVE_TERMIO_H 1) +else() + set(HAVE_TERMIO_H 0) +endif() +set(HAVE_TIME_T_UNSIGNED 0) +set(HAVE_UNISTD_H 1) +set(HAVE_UTIME 1) +set(HAVE_UTIMES 1) +set(HAVE_UTIME_H 1) +set(HAVE_WRITABLE_ARGV 1) +set(STDC_HEADERS 1) +set(USE_UNIX_SOCKETS 1) diff --git a/3rdparty/curl-8.21.0/CMake/win32-cache.cmake b/3rdparty/curl-8.21.0/CMake/win32-cache.cmake new file mode 100644 index 0000000000..bd9bb6e3fc --- /dev/null +++ b/3rdparty/curl-8.21.0/CMake/win32-cache.cmake @@ -0,0 +1,192 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +if(NOT WIN32) + message(FATAL_ERROR "This file should be included on Windows platform only") +endif() + +if(MINGW) + set(HAVE_BASENAME 1) + set(HAVE_BOOL_T 1) # = HAVE_STDBOOL_H + set(HAVE_DIRENT_H 1) + set(HAVE_GETTIMEOFDAY 1) + set(HAVE_LIBGEN_H 1) + set(HAVE_OPENDIR 1) + set(HAVE_STDBOOL_H 1) + set(HAVE_STDDEF_H 1) # detected by CMake internally in check_type_size() + set(HAVE_STDINT_H 1) # detected by CMake internally in check_type_size() + set(HAVE_STRINGS_H 1) # wrapper to string.h + set(HAVE_SYS_PARAM_H 1) + set(HAVE_UNISTD_H 1) + set(HAVE_UTIME_H 1) # wrapper to sys/utime.h +else() + set(HAVE_DIRENT_H 0) + set(HAVE_GETTIMEOFDAY 0) + set(HAVE_LIBGEN_H 0) + set(HAVE_OPENDIR 0) + set(HAVE_STRINGS_H 0) + set(HAVE_SYS_PARAM_H 0) + set(HAVE_UTIME_H 0) + if(MSVC) + set(HAVE_UNISTD_H 0) + set(HAVE_STDDEF_H 1) # detected by CMake internally in check_type_size() + set(HAVE_STDINT_H 1) # detected by CMake internally in check_type_size() + if(MSVC_VERSION GREATER_EQUAL 1800) + set(HAVE_STDBOOL_H 1) + else() + set(HAVE_STDBOOL_H 0) + endif() + set(HAVE_BOOL_T "${HAVE_STDBOOL_H}") + set(HAVE_BASENAME 0) + endif() +endif() + +if((CMAKE_C_COMPILER_ID STREQUAL "GNU" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 4.9) OR + (CMAKE_C_COMPILER_ID STREQUAL "Clang" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 3.6)) + # MinGW or clang-cl + set(HAVE_STDATOMIC_H 1) + set(HAVE_ATOMIC 1) +else() + set(HAVE_STDATOMIC_H 0) + set(HAVE_ATOMIC 0) +endif() + +set(HAVE_ACCEPT4 0) +set(HAVE_ALARM 0) +set(HAVE_ARC4RANDOM 0) +set(HAVE_ARPA_INET_H 0) +set(HAVE_CLOSESOCKET 1) +set(HAVE_EVENTFD 0) +set(HAVE_FCNTL 0) +set(HAVE_FCNTL_H 1) +set(HAVE_FCNTL_O_NONBLOCK 0) +set(HAVE_FNMATCH 0) +set(HAVE_FREEADDRINFO 1) # Available in Windows XP and newer +set(HAVE_FSETXATTR 0) +set(HAVE_GETADDRINFO 1) # Available in Windows XP and newer +set(HAVE_GETEUID 0) +set(HAVE_GETHOSTBYNAME_R 0) +set(HAVE_GETHOSTBYNAME_R_3 0) +set(HAVE_GETHOSTBYNAME_R_3_REENTRANT 0) +set(HAVE_GETHOSTBYNAME_R_5 0) +set(HAVE_GETHOSTBYNAME_R_5_REENTRANT 0) +set(HAVE_GETHOSTBYNAME_R_6 0) +set(HAVE_GETHOSTBYNAME_R_6_REENTRANT 0) +set(HAVE_GETHOSTNAME 1) +set(HAVE_GETIFADDRS 0) +set(HAVE_GETPASS_R 0) +set(HAVE_GETPEERNAME 1) +set(HAVE_GETPPID 0) +set(HAVE_GETPWUID 0) +set(HAVE_GETPWUID_R 0) +set(HAVE_GETRLIMIT 0) +set(HAVE_GETSOCKNAME 1) +set(HAVE_GLIBC_STRERROR_R 0) +set(HAVE_GMTIME_R 0) +set(HAVE_IFADDRS_H 0) +set(HAVE_INET_NTOP 0) +set(HAVE_INET_PTON 0) +set(HAVE_IOCTLSOCKET 1) +set(HAVE_IOCTLSOCKET_CAMEL 0) +set(HAVE_IOCTLSOCKET_CAMEL_FIONBIO 0) +set(HAVE_IOCTLSOCKET_FIONBIO 1) +set(HAVE_IOCTL_FIONBIO 0) +set(HAVE_IOCTL_SIOCGIFADDR 0) +set(HAVE_IO_H 1) +set(HAVE_LINUX_TCP_H 0) +set(HAVE_LOCALE_H 1) +set(HAVE_LOCALTIME_R 0) +set(HAVE_MEMRCHR 0) +set(HAVE_NETDB_H 0) +set(HAVE_NETINET_IN6_H 0) +set(HAVE_NETINET_IN_H 0) +set(HAVE_NETINET_TCP_H 0) +set(HAVE_NETINET_UDP_H 0) +set(HAVE_NET_IF_H 0) +set(HAVE_PIPE 0) +set(HAVE_PIPE2 0) +set(HAVE_POLL 0) +set(HAVE_POLL_H 0) +set(HAVE_POSIX_STRERROR_R 0) +set(HAVE_PWD_H 0) +set(HAVE_RECV 1) +set(HAVE_SELECT 1) +set(HAVE_SEND 1) +set(HAVE_SENDMMSG 0) +set(HAVE_SENDMSG 0) +set(HAVE_SETLOCALE 1) +set(HAVE_SETRLIMIT 0) +set(HAVE_SETSOCKOPT_SO_NONBLOCK 0) +set(HAVE_SIGACTION 0) +set(HAVE_SIGINTERRUPT 0) +set(HAVE_SIGNAL 1) +set(HAVE_SIGSETJMP 0) +set(HAVE_SOCKADDR_IN6_SIN6_SCOPE_ID 1) +set(HAVE_SOCKET 1) +set(HAVE_SOCKETPAIR 0) +set(HAVE_STRERROR_R 0) +set(HAVE_STROPTS_H 0) +set(HAVE_STRUCT_SOCKADDR_STORAGE 1) +set(HAVE_STRUCT_TIMEVAL 1) +set(HAVE_SYS_EVENTFD_H 0) +set(HAVE_SYS_FILIO_H 0) +set(HAVE_SYS_IOCTL_H 0) +set(HAVE_SYS_POLL_H 0) +set(HAVE_SYS_RESOURCE_H 0) +set(HAVE_SYS_SELECT_H 0) +set(HAVE_SYS_SOCKIO_H 0) +set(HAVE_SYS_TYPES_H 1) +set(HAVE_SYS_UN_H 0) +set(HAVE_SYS_UTIME_H 1) +set(HAVE_TERMIOS_H 0) +set(HAVE_TERMIO_H 0) +set(HAVE_TIME_T_UNSIGNED 0) +set(HAVE_UTIME 1) +set(HAVE_UTIMES 0) +set(STDC_HEADERS 1) + +# Types and sizes + +set(HAVE_SIZEOF_SA_FAMILY_T 0) +set(HAVE_SIZEOF_SUSECONDS_T 0) + +if(MINGW OR MSVC) + curl_prefill_type_size("INT" 4) + curl_prefill_type_size("LONG" 4) + curl_prefill_type_size("__INT64" 8) + curl_prefill_type_size("CURL_OFF_T" 8) + curl_prefill_type_size("CURL_SOCKET_T" ${CMAKE_SIZEOF_VOID_P}) + curl_prefill_type_size("SIZE_T" ${CMAKE_SIZEOF_VOID_P}) + # TIME_T: 8 for _WIN64 or UCRT or MSVC, 4 otherwise + # Also 4 for non-UCRT 32-bit when _USE_32BIT_TIME_T is set. + # mingw-w64 sets _USE_32BIT_TIME_T unless __MINGW_USE_VC2005_COMPAT is explicit defined. + if(MSVC) + set(HAVE_SIZEOF_SSIZE_T 0) + set(HAVE_FILE_OFFSET_BITS 0) + curl_prefill_type_size("OFF_T" 4) + else() + curl_prefill_type_size("SSIZE_T" ${CMAKE_SIZEOF_VOID_P}) + set(HAVE_FILE_OFFSET_BITS 1) # mingw-w64 v3+ + curl_prefill_type_size("OFF_T" 8) # mingw-w64 v3+ + endif() +endif() diff --git a/3rdparty/curl-8.21.0/CMakeLists.txt b/3rdparty/curl-8.21.0/CMakeLists.txt new file mode 100644 index 0000000000..e459b3d076 --- /dev/null +++ b/3rdparty/curl-8.21.0/CMakeLists.txt @@ -0,0 +1,2506 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### + +cmake_minimum_required(VERSION 3.18 FATAL_ERROR) +message(STATUS "Using CMake version ${CMAKE_VERSION}") + +# Collect command-line arguments for buildinfo.txt. +# Must reside at the top of the script to work as expected. +set(_cmake_args "") +if(NOT "$ENV{CURL_BUILDINFO}$ENV{CURL_CI}$ENV{CI}" STREQUAL "") + get_cmake_property(_cache_vars CACHE_VARIABLES) + foreach(_cache_var IN ITEMS ${_cache_vars}) + get_property(_cache_var_helpstring CACHE ${_cache_var} PROPERTY HELPSTRING) + if(_cache_var_helpstring STREQUAL "No help, variable specified on the command line.") + get_property(_cache_var_type CACHE ${_cache_var} PROPERTY TYPE) + get_property(_cache_var_value CACHE ${_cache_var} PROPERTY VALUE) + if(_cache_var_type STREQUAL "UNINITIALIZED") + set(_cache_var_type "") + else() + set(_cache_var_type ":${_cache_var_type}") + endif() + string(APPEND _cmake_args " -D${_cache_var}${_cache_var_type}=\"${_cache_var_value}\"") + endif() + endforeach() +endif() + +list(PREPEND CMAKE_MODULE_PATH "${CMAKE_CURRENT_SOURCE_DIR}/CMake") +include(Utilities) +include(Macros) +include(CMakeDependentOption) +include(CheckCCompilerFlag) + +file(STRINGS "${CMAKE_CURRENT_SOURCE_DIR}/include/curl/curlver.h" _curl_version_h_contents REGEX "#define LIBCURL_VERSION( |_NUM )") +string(REGEX MATCH "#define LIBCURL_VERSION \"[^\"]*" _curl_version ${_curl_version_h_contents}) +string(REGEX REPLACE "[^\"]+\"" "" _curl_version ${_curl_version}) +string(REGEX MATCH "#define LIBCURL_VERSION_NUM 0x[0-9a-fA-F]+" _curl_version_num ${_curl_version_h_contents}) +string(REGEX REPLACE "[^0]+0x" "" _curl_version_num ${_curl_version_num}) +unset(_curl_version_h_contents) + +message(STATUS "curl version=[${_curl_version}]") + +string(REGEX REPLACE "([0-9]+\.[0-9]+\.[0-9]+).+" "\\1" _curl_version_sem "${_curl_version}") +project(CURL + VERSION "${_curl_version_sem}" + LANGUAGES C) + +# CMake does not recognize some targets accurately. Touch up configuration manually as a workaround. +if(WINDOWS_STORE AND MINGW) # MinGW UWP build + # CMake (as of v3.31.2) gets confused and applies the MSVC rc.exe command-line + # template to windres. Reset it to the windres template as in 'Modules/Platform/Windows-windres.cmake': + set(CMAKE_RC_COMPILE_OBJECT " -O coff ") +elseif(DOS AND CMAKE_C_COMPILER_ID STREQUAL "GNU") # DJGPP + set(CMAKE_STATIC_LIBRARY_PREFIX "lib") + set(CMAKE_STATIC_LIBRARY_SUFFIX ".a") + set(CMAKE_FIND_LIBRARY_PREFIXES "lib") + set(CMAKE_FIND_LIBRARY_SUFFIXES ".a") +endif() + +# Fill platform level variable when using CMake's built-in Android configuration +if(ANDROID AND NOT DEFINED ANDROID_PLATFORM_LEVEL AND NOT CMAKE_SYSTEM_VERSION EQUAL 1) + set(ANDROID_PLATFORM_LEVEL "${CMAKE_SYSTEM_VERSION}") +endif() + +set(_target_flags "") +if(APPLE) + string(APPEND _target_flags " APPLE") +endif() +if(UNIX) + string(APPEND _target_flags " UNIX") +endif() +if(BSD) + string(APPEND _target_flags " BSD") +endif() +if(ANDROID) + string(APPEND _target_flags " ANDROID-${ANDROID_PLATFORM_LEVEL}") +endif() +if(WIN32) + string(APPEND _target_flags " WIN32") +endif() +if(WINDOWS_STORE) + string(APPEND _target_flags " UWP") +endif() +if(CYGWIN) + string(APPEND _target_flags " CYGWIN") +endif() +if(DOS) + string(APPEND _target_flags " DOS") +endif() +if(AMIGA) + string(APPEND _target_flags " AMIGA") +endif() +if(CMAKE_C_COMPILER_ID STREQUAL "GNU") + string(APPEND _target_flags " GCC") +endif() +if(CMAKE_C_COMPILER_ID STREQUAL "AppleClang") + string(APPEND _target_flags " APPLE-CLANG") +elseif(CMAKE_C_COMPILER_ID STREQUAL "Clang" AND MSVC) + string(APPEND _target_flags " CLANG-CL") +elseif(CMAKE_C_COMPILER_ID MATCHES "Clang") + string(APPEND _target_flags " LLVM-CLANG") +endif() +if(MINGW) + string(APPEND _target_flags " MINGW") +endif() +if(MSVC) + string(APPEND _target_flags " MSVC-${MSVC_VERSION}") +endif() +if(VCPKG_TOOLCHAIN) + string(APPEND _target_flags " VCPKG") +endif() +if(CMAKE_CROSSCOMPILING) + string(APPEND _target_flags " CROSS") +endif() +if(CMAKE_C_STANDARD) + string(APPEND _target_flags " C${CMAKE_C_STANDARD}") +endif() +message(STATUS "CMake platform flags:${_target_flags}") + +if(CMAKE_CROSSCOMPILING) + message(STATUS "Cross-compiling: " + "${CMAKE_HOST_SYSTEM_NAME}/${CMAKE_HOST_SYSTEM_PROCESSOR} -> " + "${CMAKE_SYSTEM_NAME}/${CMAKE_SYSTEM_PROCESSOR}") +endif() + +if(CMAKE_C_COMPILER_TARGET) + set(CURL_OS "\"${CMAKE_C_COMPILER_TARGET}\"") +else() + set(CURL_OS "\"${CMAKE_SYSTEM_NAME}\"") +endif() + +if(CURL_PATCHSTAMP) + set(CURL_PATCHSTAMP "\"${CURL_PATCHSTAMP}\"") +endif() + +set(LIB_NAME "libcurl") +set(EXE_NAME "curl") + +set_property(DIRECTORY APPEND PROPERTY INCLUDE_DIRECTORIES "${PROJECT_SOURCE_DIR}/include") + +if(NOT DEFINED CMAKE_UNITY_BUILD_BATCH_SIZE) + set(CMAKE_UNITY_BUILD_BATCH_SIZE 0) +endif() + +# Having CMAKE_TRY_COMPILE_TARGET_TYPE set to STATIC_LIBRARY breaks certain +# 'check_function_exists()' detections (possibly more), by detecting +# non-existing features. This happens by default when using 'ios.toolchain.cmake'. +# Work it around by setting this value to `EXECUTABLE`. +if(CMAKE_TRY_COMPILE_TARGET_TYPE STREQUAL "STATIC_LIBRARY") + message(STATUS "CMAKE_TRY_COMPILE_TARGET_TYPE was found set to STATIC_LIBRARY. " + "Overriding with EXECUTABLE for feature detections to work.") + set(_cmake_try_compile_target_type_save ${CMAKE_TRY_COMPILE_TARGET_TYPE}) + set(CMAKE_TRY_COMPILE_TARGET_TYPE "EXECUTABLE") +endif() + +option(CURL_WERROR "Turn compiler warnings into errors" OFF) +option(PICKY_COMPILER "Enable picky compiler options" ON) +option(BUILD_CURL_EXE "Build curl executable" ON) +get_property(_has_shared GLOBAL PROPERTY TARGET_SUPPORTS_SHARED_LIBS) +option(BUILD_SHARED_LIBS "Build shared libraries" ${_has_shared}) +option(BUILD_STATIC_LIBS "Build static libraries" OFF) +option(BUILD_STATIC_CURL "Build curl executable with static libcurl" OFF) +option(ENABLE_ARES "Enable c-ares support" OFF) +option(CURL_DISABLE_INSTALL "Disable installation targets" OFF) +option(CURL_BUILD_EVERYTHING "Build optional build targets (examples, tests) by default" OFF) + +if(WIN32) + option(ENABLE_UNICODE "Use the Unicode version of the Windows API functions" OFF) + if(WINDOWS_STORE) + set(ENABLE_UNICODE ON) + endif() + if(ENABLE_UNICODE) + set_property(DIRECTORY APPEND PROPERTY COMPILE_DEFINITIONS "UNICODE" "_UNICODE") + if(MINGW) + set_property(DIRECTORY APPEND PROPERTY COMPILE_OPTIONS "-municode") + endif() + endif() + + # Apply to all feature checks + list(APPEND CMAKE_REQUIRED_DEFINITIONS "-DWIN32_LEAN_AND_MEAN") + + set(CURL_TARGET_WINDOWS_VERSION "" CACHE STRING "Minimum target Windows version as hex string") + if(CURL_TARGET_WINDOWS_VERSION) + if(CURL_TARGET_WINDOWS_VERSION MATCHES "^0x[0-9a-fA-F]+$") + set_property(DIRECTORY APPEND PROPERTY COMPILE_DEFINITIONS "_WIN32_WINNT=${CURL_TARGET_WINDOWS_VERSION}") + list(APPEND CMAKE_REQUIRED_DEFINITIONS "-D_WIN32_WINNT=${CURL_TARGET_WINDOWS_VERSION}") # Apply to all feature checks + else() + message(WARNING "CURL_TARGET_WINDOWS_VERSION value '${CURL_TARGET_WINDOWS_VERSION}' is not a valid hex string.") + endif() + endif() + + # Detect actual value of _WIN32_WINNT and store as HAVE_WIN32_WINNT + curl_internal_test(HAVE_WIN32_WINNT) + if(HAVE_WIN32_WINNT) + string(REGEX MATCH "_WIN32_WINNT=0x[0-9a-fA-F]+" CURL_TEST_OUTPUT "${CURL_TEST_OUTPUT}") + string(REGEX REPLACE "_WIN32_WINNT=" "" CURL_TEST_OUTPUT "${CURL_TEST_OUTPUT}") + string(REGEX REPLACE "0x([0-9a-fA-F][0-9a-fA-F][0-9a-fA-F])$" "0x0\\1" CURL_TEST_OUTPUT "${CURL_TEST_OUTPUT}") # pad to 4 digits + string(TOLOWER "${CURL_TEST_OUTPUT}" HAVE_WIN32_WINNT) + message(STATUS "Found _WIN32_WINNT=${HAVE_WIN32_WINNT}") + endif() + unset(HAVE_WIN32_WINNT CACHE) # Avoid storing in CMake cache + + if(MINGW) + # Detect __MINGW64_VERSION_MAJOR, __MINGW64_VERSION_MINOR and store as MINGW64_VERSION + curl_internal_test(MINGW64_VERSION) + if(MINGW64_VERSION) + string(REGEX MATCH "MINGW64_VERSION=[0-9]+\.[0-9]+" CURL_TEST_OUTPUT "${CURL_TEST_OUTPUT}") + string(REGEX REPLACE "MINGW64_VERSION=" "" MINGW64_VERSION "${CURL_TEST_OUTPUT}") + if(MINGW64_VERSION) + message(STATUS "Found MINGW64_VERSION=${MINGW64_VERSION}") + if(MINGW64_VERSION VERSION_LESS 3.0) + message(FATAL_ERROR "mingw-w64 3.0 or upper is required") + endif() + endif() + endif() + unset(MINGW64_VERSION CACHE) # Avoid storing in CMake cache + endif() +elseif(DOS) + set(BUILD_SHARED_LIBS OFF) + set(BUILD_STATIC_LIBS ON) +endif() +option(CURL_LTO "Enable compiler Link Time Optimizations" OFF) + +if(NOT DOS AND NOT AMIGA) + # if c-ares is used, default the threaded resolver to OFF + if(ENABLE_ARES) + set(_enable_threaded_resolver_default OFF) + else() + set(_enable_threaded_resolver_default ON) + endif() + option(ENABLE_THREADED_RESOLVER "Enable threaded DNS lookup" ${_enable_threaded_resolver_default}) +endif() + +if(CYGWIN OR CMAKE_SYSTEM_NAME STREQUAL "Linux" OR CMAKE_SYSTEM_NAME STREQUAL "GNU") + set_property(DIRECTORY APPEND PROPERTY COMPILE_DEFINITIONS "_GNU_SOURCE") # Required for accept4(), pipe2(), sendmmsg() + list(APPEND CMAKE_REQUIRED_DEFINITIONS "-D_GNU_SOURCE") # Apply to all feature checks +endif() + +option(ENABLE_DEBUG "Enable curl debug features (for developing curl itself)" OFF) +if(ENABLE_DEBUG) + message(WARNING "This curl build is Debug-enabled and insecure, do not use in production.") +endif() + +set(CURL_DEBUG_MACROS "") +if(ENABLE_DEBUG) + list(APPEND CURL_DEBUG_MACROS "DEBUGBUILD") +endif() + +option(CURL_CLANG_TIDY "Run the build through clang-tidy" OFF) +if(CURL_CLANG_TIDY) + find_program(CLANG_TIDY NAMES "clang-tidy" REQUIRED) + if(NOT CMAKE_C_COMPILER_ID MATCHES "Clang") + set(PICKY_COMPILER OFF) # Do a best effort and skip passing non-clang warning options to clang-tidy. + # This lets through warning options enabled via CURL_WERROR=ON, affecting lib and src. + endif() + set(CURL_DISABLE_TYPECHECK ON) # to improve performance (1.4x), avoid potential interference and bugprone-macro-parentheses. + set(CMAKE_C_CLANG_TIDY "${CLANG_TIDY}") + list(APPEND CMAKE_C_CLANG_TIDY "--config-file=${PROJECT_SOURCE_DIR}/.clang-tidy.yml") + if(CURL_WERROR) + list(APPEND CMAKE_C_CLANG_TIDY "--warnings-as-errors=*") + endif() + if(CURL_CLANG_TIDYFLAGS) + string(REPLACE " " ";" _tidy_flags_list "${CURL_CLANG_TIDYFLAGS}") + list(APPEND CMAKE_C_CLANG_TIDY ${_tidy_flags_list}) + endif() +endif() + +option(CURL_GCC_ANALYZER "Enable GCC --analyzer option" OFF) +if(CURL_GCC_ANALYZER AND CMAKE_C_COMPILER_ID STREQUAL "GNU" AND CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 11.0) + set(CURL_DISABLE_TYPECHECK ON) # to improve performance (1.1x). + # https://gcc.gnu.org/onlinedocs/gcc/Static-Analyzer-Options.html + set(CURL_ANALYZER_CFLAGS "-fanalyzer") + # disable checks causing false positives only + list(APPEND CURL_ANALYZER_CFLAGS "-Wno-analyzer-fd-leak" "-Wno-analyzer-fd-use-without-check" "-Wno-analyzer-file-leak") + list(APPEND CURL_ANALYZER_CFLAGS "-Wno-analyzer-infinite-loop") + list(APPEND CURL_ANALYZER_CFLAGS "-Wno-analyzer-malloc-leak") + list(APPEND CURL_ANALYZER_CFLAGS "-Wno-analyzer-out-of-bounds") +endif() + +option(CURL_CODE_COVERAGE "Enable code coverage build options" OFF) +if(CURL_CODE_COVERAGE) + if(CMAKE_C_COMPILER_ID STREQUAL "GNU") + set(CURL_COVERAGE_MACROS "NDEBUG") + set(CURL_COVERAGE_CFLAGS "-O0" "-g" "-fprofile-arcs") + if(CMAKE_C_COMPILER_VERSION VERSION_GREATER_EQUAL 4.1) + list(APPEND CURL_COVERAGE_CFLAGS "--coverage") + else() + list(APPEND CURL_COVERAGE_CFLAGS "-ftest-coverage") + endif() + set(CURL_COVERAGE_LIBS "gcov") + elseif(CMAKE_C_COMPILER_ID MATCHES "Clang") + set(CURL_COVERAGE_MACROS "NDEBUG") + set(CURL_COVERAGE_CFLAGS "-O0" "-g" "-fprofile-instr-generate" "-fcoverage-mapping") + set(CURL_COVERAGE_LDFLAGS "-fprofile-instr-generate" "-fcoverage-mapping") + else() + set(CURL_CODE_COVERAGE OFF) + endif() +endif() + +include(PickyWarnings) + +set(CURL_CFLAGS "") # C flags set for libcurl and curl tool (aka public binaries) only + +option(CURL_DROP_UNUSED "Drop unused code and data from built binaries" OFF) +if(CURL_DROP_UNUSED) + if(APPLE) + set_property(DIRECTORY APPEND PROPERTY LINK_OPTIONS "-Wl,-dead_strip") + elseif(MSVC) # Options below are toolchain defaults in Release configurations. + # This option does not seem to have an effect with VS2010: + set_property(DIRECTORY APPEND PROPERTY LINK_OPTIONS "-OPT:REF") + # Optional, but reduces binary size further, with the cost of larger objects/static libraries: + list(APPEND CURL_CFLAGS "-Gy") + elseif(CMAKE_C_COMPILER_ID STREQUAL "GNU" OR CMAKE_C_COMPILER_ID MATCHES "Clang") + if(WIN32) + # To make -Wl,--gc-sections work on Windows: https://sourceware.org/bugzilla/show_bug.cgi?id=11539 + set_property(DIRECTORY APPEND PROPERTY COMPILE_OPTIONS "-fno-asynchronous-unwind-tables") + endif() + set_property(DIRECTORY APPEND PROPERTY LINK_OPTIONS "-Wl,--gc-sections") + # Optional, but reduces binary size further, with the cost of larger objects/static libraries: + list(APPEND CURL_CFLAGS "-ffunction-sections" "-fdata-sections") + endif() +endif() + +# For debug libs and exes, add "-d" postfix +if(NOT DEFINED CMAKE_DEBUG_POSTFIX) + set(CMAKE_DEBUG_POSTFIX "-d") +endif() + +set(LIB_STATIC "libcurl_static") +set(LIB_SHARED "libcurl_shared") + +if(NOT BUILD_SHARED_LIBS AND NOT BUILD_STATIC_LIBS) + set(BUILD_STATIC_LIBS ON) +endif() +if(NOT BUILD_STATIC_CURL AND NOT BUILD_SHARED_LIBS) + set(BUILD_STATIC_CURL ON) +elseif(BUILD_STATIC_CURL AND NOT BUILD_STATIC_LIBS) + set(BUILD_STATIC_CURL OFF) +endif() + +# Lib flavor selected for curl tool +if(BUILD_STATIC_CURL) + set(LIB_SELECTED_FOR_EXE ${LIB_STATIC}) +else() + set(LIB_SELECTED_FOR_EXE ${LIB_SHARED}) +endif() + +# Lib flavor selected for example and test programs. +if(BUILD_SHARED_LIBS) + set(LIB_SELECTED ${LIB_SHARED}) +else() + set(LIB_SELECTED ${LIB_STATIC}) +endif() + +if(WIN32) + option(CURL_STATIC_CRT "Build libcurl with static CRT with MSVC (/MT)" OFF) + if(CURL_STATIC_CRT AND MSVC) + if(MSVC_VERSION GREATER_EQUAL 1900 OR BUILD_STATIC_CURL OR NOT BUILD_CURL_EXE) + set(CMAKE_MSVC_RUNTIME_LIBRARY "MultiThreaded$<$:Debug>") + set_property(DIRECTORY APPEND PROPERTY COMPILE_OPTIONS "$<$:-MT>") + set_property(DIRECTORY APPEND PROPERTY COMPILE_OPTIONS "$<$:-MTd>") + else() + message(WARNING "Static CRT requires UCRT, static libcurl or no curl executable.") + endif() + endif() +endif() + +# Override to force-disable or force-enable the use of CMake Configs. +if(MSVC AND NOT VCPKG_TOOLCHAIN AND NOT CMAKE_CROSSCOMPILING) + set(_curl_use_cmakeconfig_default ON) +else() + set(_curl_use_cmakeconfig_default OFF) +endif() +option(CURL_USE_CMAKECONFIG "Enable detecting dependencies via CMake Config" ${_curl_use_cmakeconfig_default}) + +# Override to force-disable or force-enable the use of pkg-config. +if((UNIX AND NOT ANDROID AND (NOT APPLE OR CMAKE_SYSTEM_NAME STREQUAL "Darwin")) OR + VCPKG_TOOLCHAIN OR + (MINGW AND NOT CMAKE_CROSSCOMPILING)) + set(_curl_use_pkgconfig_default ON) +else() + set(_curl_use_pkgconfig_default OFF) +endif() +option(CURL_USE_PKGCONFIG "Enable pkg-config to detect dependencies" ${_curl_use_pkgconfig_default}) + +# Initialize variables collecting system and dependency libs. +set(CURL_NETWORK_AND_TIME_LIBS "") +set(CURL_LIBS "") + +if(ENABLE_ARES) + set(USE_ARES 1) + find_package(Cares MODULE REQUIRED) + list(APPEND CURL_LIBS CURL::cares) +endif() + +include(CurlSymbolHiding) + +option(CURL_ENABLE_EXPORT_TARGET "Enable CMake export target" ON) +mark_as_advanced(CURL_ENABLE_EXPORT_TARGET) + +option(CURL_DISABLE_ALTSVC "Disable alt-svc support" OFF) +mark_as_advanced(CURL_DISABLE_ALTSVC) +option(CURL_DISABLE_SRP "Disable TLS-SRP support" OFF) +mark_as_advanced(CURL_DISABLE_SRP) +option(CURL_DISABLE_COOKIES "Disable cookies support" OFF) +mark_as_advanced(CURL_DISABLE_COOKIES) +option(CURL_DISABLE_BASIC_AUTH "Disable Basic authentication" OFF) +mark_as_advanced(CURL_DISABLE_BASIC_AUTH) +option(CURL_DISABLE_BEARER_AUTH "Disable Bearer authentication" OFF) +mark_as_advanced(CURL_DISABLE_BEARER_AUTH) +option(CURL_DISABLE_DIGEST_AUTH "Disable Digest authentication" OFF) +mark_as_advanced(CURL_DISABLE_DIGEST_AUTH) +option(CURL_DISABLE_KERBEROS_AUTH "Disable Kerberos authentication" OFF) +mark_as_advanced(CURL_DISABLE_KERBEROS_AUTH) +option(CURL_DISABLE_NEGOTIATE_AUTH "Disable negotiate authentication" OFF) +mark_as_advanced(CURL_DISABLE_NEGOTIATE_AUTH) +option(CURL_DISABLE_AWS "Disable aws-sigv4" OFF) +mark_as_advanced(CURL_DISABLE_AWS) +option(CURL_DISABLE_DICT "Disable DICT" OFF) +mark_as_advanced(CURL_DISABLE_DICT) +option(CURL_DISABLE_DOH "Disable DNS-over-HTTPS" OFF) +mark_as_advanced(CURL_DISABLE_DOH) +option(CURL_DISABLE_FILE "Disable FILE" OFF) +mark_as_advanced(CURL_DISABLE_FILE) +option(CURL_DISABLE_FTP "Disable FTP" OFF) +mark_as_advanced(CURL_DISABLE_FTP) +option(CURL_DISABLE_GETOPTIONS "Disable curl_easy_options API for existing options to curl_easy_setopt" OFF) +mark_as_advanced(CURL_DISABLE_GETOPTIONS) +option(CURL_DISABLE_GOPHER "Disable Gopher" OFF) +mark_as_advanced(CURL_DISABLE_GOPHER) +option(CURL_DISABLE_HEADERS_API "Disable headers-api support" OFF) +mark_as_advanced(CURL_DISABLE_HEADERS_API) +option(CURL_DISABLE_HSTS "Disable HSTS support" OFF) +mark_as_advanced(CURL_DISABLE_HSTS) +option(CURL_DISABLE_HTTP "Disable HTTP" OFF) +mark_as_advanced(CURL_DISABLE_HTTP) +option(CURL_DISABLE_HTTP_AUTH "Disable all HTTP authentication methods" OFF) +mark_as_advanced(CURL_DISABLE_HTTP_AUTH) +option(CURL_DISABLE_IMAP "Disable IMAP" OFF) +mark_as_advanced(CURL_DISABLE_IMAP) +option(CURL_DISABLE_LDAP "Disable LDAP" OFF) +mark_as_advanced(CURL_DISABLE_LDAP) +option(CURL_DISABLE_LDAPS "Disable LDAPS" ${CURL_DISABLE_LDAP}) +mark_as_advanced(CURL_DISABLE_LDAPS) +option(CURL_DISABLE_LIBCURL_OPTION "Disable --libcurl option from the curl tool" OFF) +mark_as_advanced(CURL_DISABLE_LIBCURL_OPTION) +option(CURL_DISABLE_MIME "Disable MIME support" OFF) +mark_as_advanced(CURL_DISABLE_MIME) +cmake_dependent_option(CURL_DISABLE_FORM_API "Disable form-api" + OFF "NOT CURL_DISABLE_MIME" + ON) +mark_as_advanced(CURL_DISABLE_FORM_API) +option(CURL_DISABLE_MQTT "Disable MQTT" OFF) +mark_as_advanced(CURL_DISABLE_MQTT) +option(CURL_DISABLE_BINDLOCAL "Disable local binding support" OFF) +mark_as_advanced(CURL_DISABLE_BINDLOCAL) +option(CURL_DISABLE_NETRC "Disable netrc parser" OFF) +mark_as_advanced(CURL_DISABLE_NETRC) +option(CURL_ENABLE_NTLM "Enable NTLM support" OFF) +mark_as_advanced(CURL_ENABLE_NTLM) +option(CURL_DISABLE_PARSEDATE "Disable date parsing" OFF) +mark_as_advanced(CURL_DISABLE_PARSEDATE) +option(CURL_DISABLE_POP3 "Disable POP3" OFF) +mark_as_advanced(CURL_DISABLE_POP3) +option(CURL_DISABLE_PROGRESS_METER "Disable built-in progress meter" OFF) +mark_as_advanced(CURL_DISABLE_PROGRESS_METER) +option(CURL_DISABLE_PROXY "Disable proxy support" OFF) +mark_as_advanced(CURL_DISABLE_PROXY) +option(CURL_DISABLE_IPFS "Disable IPFS" OFF) +mark_as_advanced(CURL_DISABLE_IPFS) +option(CURL_DISABLE_RTSP "Disable RTSP" OFF) +mark_as_advanced(CURL_DISABLE_RTSP) +option(CURL_DISABLE_SHA512_256 "Disable SHA-512/256 hash algorithm" OFF) +mark_as_advanced(CURL_DISABLE_SHA512_256) +option(CURL_DISABLE_SHUFFLE_DNS "Disable shuffle DNS feature" OFF) +mark_as_advanced(CURL_DISABLE_SHUFFLE_DNS) +option(CURL_ENABLE_SMB "Enable SMB" OFF) +mark_as_advanced(CURL_ENABLE_SMB) +option(CURL_DISABLE_SMTP "Disable SMTP" OFF) +mark_as_advanced(CURL_DISABLE_SMTP) +option(CURL_DISABLE_SOCKETPAIR "Disable use of socketpair for curl_multi_poll()" OFF) +mark_as_advanced(CURL_DISABLE_SOCKETPAIR) +option(CURL_DISABLE_WEBSOCKETS "Disable WebSocket" OFF) +mark_as_advanced(CURL_DISABLE_WEBSOCKETS) +option(CURL_DISABLE_TELNET "Disable Telnet" OFF) +mark_as_advanced(CURL_DISABLE_TELNET) +option(CURL_DISABLE_TFTP "Disable TFTP" OFF) +mark_as_advanced(CURL_DISABLE_TFTP) +option(CURL_DISABLE_TYPECHECK "Disable curl_easy_setopt()/curl_easy_getinfo() type checking" OFF) +mark_as_advanced(CURL_DISABLE_TYPECHECK) +option(CURL_DISABLE_VERBOSE_STRINGS "Disable verbose strings" OFF) +mark_as_advanced(CURL_DISABLE_VERBOSE_STRINGS) +option(CURL_DEBUG_GLOBAL_MEM "Debug curl_global_init_mem" OFF) +mark_as_advanced(CURL_DEBUG_GLOBAL_MEM) + +if(CURL_DEBUG_GLOBAL_MEM) + # Set it via the command-line to make it apply to the entire directory. + set_property(DIRECTORY APPEND PROPERTY COMPILE_DEFINITIONS "CURL_DEBUG_GLOBAL_MEM") +endif() +if(CURL_DISABLE_TYPECHECK) + # Set it via the command-line to make it apply to examples also. + set_property(DIRECTORY APPEND PROPERTY COMPILE_DEFINITIONS "CURL_DISABLE_TYPECHECK") +endif() + +if(CURL_DISABLE_HTTP) + set(CURL_DISABLE_ALTSVC ON) + set(CURL_DISABLE_HSTS ON) + set(CURL_DISABLE_IPFS ON) + set(CURL_DISABLE_RTSP ON) + set(CURL_DISABLE_WEBSOCKETS ON) +endif() + +# Corresponds to HTTP_ONLY in lib/curl_setup.h +option(HTTP_ONLY "Disable all protocols except HTTP (This overrides all CURL_DISABLE_* options)" OFF) +mark_as_advanced(HTTP_ONLY) + +if(HTTP_ONLY) + set(CURL_DISABLE_DICT ON) + set(CURL_DISABLE_FILE ON) + set(CURL_DISABLE_FTP ON) + set(CURL_DISABLE_GOPHER ON) + set(CURL_DISABLE_IMAP ON) + set(CURL_DISABLE_IPFS ON) + set(CURL_DISABLE_LDAP ON) + set(CURL_DISABLE_LDAPS ON) + set(CURL_DISABLE_MQTT ON) + set(CURL_DISABLE_POP3 ON) + set(CURL_DISABLE_RTSP ON) + set(CURL_DISABLE_SMTP ON) + set(CURL_DISABLE_TELNET ON) + set(CURL_DISABLE_TFTP ON) + set(CURL_DISABLE_WEBSOCKETS ON) +endif() + +if(WINDOWS_STORE) + set(CURL_DISABLE_TELNET ON) # telnet code needs fixing to compile for UWP. +endif() + +option(CURL_LINT "Run lint checks while building" OFF) + +find_package(Perl) + +if(PERL_EXECUTABLE) + add_custom_target(curl-ca-bundle + COMMENT "Generating a fresh ca-bundle.crt" VERBATIM USES_TERMINAL + COMMAND "${PERL_EXECUTABLE}" "${PROJECT_SOURCE_DIR}/scripts/mk-ca-bundle.pl" -b -l -u "lib/ca-bundle.crt" + DEPENDS "${PROJECT_SOURCE_DIR}/scripts/mk-ca-bundle.pl" + ) + add_custom_target(curl-ca-firefox + COMMENT "Generating a fresh ca-bundle.crt" VERBATIM USES_TERMINAL + COMMAND "${PERL_EXECUTABLE}" "${PROJECT_SOURCE_DIR}/scripts/firefox-db2pem.sh" "lib/ca-bundle.crt" + DEPENDS "${PROJECT_SOURCE_DIR}/scripts/firefox-db2pem.sh" + ) + add_custom_target(curl-lint + COMMENT "Running lint checks" VERBATIM USES_TERMINAL + WORKING_DIRECTORY ${PROJECT_SOURCE_DIR} + COMMAND "${PERL_EXECUTABLE}" "${PROJECT_SOURCE_DIR}/scripts/badwords-all" + COMMAND "${PERL_EXECUTABLE}" "${PROJECT_SOURCE_DIR}/scripts/checksrc-all.pl" + COMMAND "${PERL_EXECUTABLE}" "${PROJECT_SOURCE_DIR}/scripts/spacecheck.pl" + DEPENDS + "${PROJECT_SOURCE_DIR}/scripts/badwords-all" "${PROJECT_SOURCE_DIR}/scripts/badwords" + "${PROJECT_SOURCE_DIR}/scripts/checksrc-all.pl" "${PROJECT_SOURCE_DIR}/scripts/checksrc.pl" + "${PROJECT_SOURCE_DIR}/scripts/spacecheck.pl" + ) + if(CURL_LINT) + set_target_properties(curl-lint PROPERTIES EXCLUDE_FROM_ALL FALSE) + endif() +endif() + +option(BUILD_LIBCURL_DOCS "Build libcurl man pages" ON) +option(BUILD_MISC_DOCS "Build misc man pages (e.g. curl-config and mk-ca-bundle)" ON) +option(ENABLE_CURL_MANUAL "Build the man page for curl and enable its -M/--manual option" ON) + +if((ENABLE_CURL_MANUAL OR BUILD_LIBCURL_DOCS) AND NOT Perl_FOUND) + message(WARNING "Perl not found. Cannot build manuals.") +endif() + +# If we are on AIX, do the _ALL_SOURCE magic +if(AIX OR CMAKE_SYSTEM_NAME STREQUAL "AIX") + set_property(DIRECTORY APPEND PROPERTY COMPILE_DEFINITIONS "_ALL_SOURCE") +endif() + +# If we are on Haiku, make sure that the network library is brought in. +if(CMAKE_SYSTEM_NAME STREQUAL "Haiku") + list(APPEND CURL_NETWORK_AND_TIME_LIBS "network") +elseif(AMIGA) + list(APPEND CURL_NETWORK_AND_TIME_LIBS "net" "m" "atomic") + list(APPEND CMAKE_REQUIRED_LIBRARIES "net" "m" "atomic") +endif() + +# Include all the necessary files for macros +include(CMakePushCheckState) +include(CheckFunctionExists) +include(CheckIncludeFile) +include(CheckIncludeFiles) +include(CheckLibraryExists) +include(CheckSymbolExists) +include(CheckTypeSize) +include(CheckCSourceCompiles) + +option(_CURL_PREFILL "Fast-track known feature detection results (Windows, some Apple)" "${WIN32}") +mark_as_advanced(_CURL_PREFILL) +if(_CURL_PREFILL) + if(WIN32) + include("${CMAKE_CURRENT_SOURCE_DIR}/CMake/win32-cache.cmake") + elseif(UNIX) + include("${CMAKE_CURRENT_SOURCE_DIR}/CMake/unix-cache.cmake") + message(STATUS "Pre-filling feature detection results for UNIX") + endif() +elseif(WIN32) + message(STATUS "Pre-filling feature detection results disabled.") +elseif(APPLE) + set(HAVE_EVENTFD 0) + set(HAVE_GETPASS_R 0) + set(HAVE_WRITABLE_ARGV 1) + set(HAVE_SENDMMSG 0) +endif() + +if(AMIGA) + set(HAVE_GETADDRINFO 0) # Breaks the build when detected and used. +endif() +if(DOS OR AMIGA) + set(HAVE_TIME_T_UNSIGNED 1) +endif() + +if(NOT WIN32) + find_package(Threads) + if(CMAKE_USE_PTHREADS_INIT) + set(HAVE_THREADS_POSIX 1) + list(APPEND CURL_NETWORK_AND_TIME_LIBS Threads::Threads) + endif() +endif() + +if(ENABLE_THREADED_RESOLVER) + if(NOT WIN32 AND NOT HAVE_THREADS_POSIX) + message(FATAL_ERROR "Threaded resolver requires POSIX Threads.") + endif() + set(USE_RESOLV_THREADED ON) +elseif(USE_ARES) + set(USE_RESOLV_ARES ON) +endif() + +# Check for all needed libraries +if(DOS) + if(WATT_ROOT) + set(USE_WATT32 ON) + # FIXME upstream: must specify the full path to avoid CMake converting "watt" to "watt.lib" + list(APPEND CURL_NETWORK_AND_TIME_LIBS "${WATT_ROOT}/lib/libwatt.a") + include_directories(SYSTEM "${WATT_ROOT}/inc") + list(APPEND CMAKE_REQUIRED_INCLUDES "${WATT_ROOT}/inc") + else() + message(FATAL_ERROR "Set WATT_ROOT variable to the absolute path to the root installation of Watt-32.") + endif() +elseif(AMIGA) + if(AMISSL_INCLUDE_DIR AND AMISSL_STUBS_LIBRARY AND AMISSL_AUTO_LIBRARY) + set(USE_AMISSL ON) + list(APPEND CMAKE_REQUIRED_INCLUDES "${AMISSL_INCLUDE_DIR}") + list(APPEND CMAKE_REQUIRED_LIBRARIES "${AMISSL_STUBS_LIBRARY}" "${AMISSL_AUTO_LIBRARY}") + set(OPENSSL_INCLUDE_DIR "${AMISSL_INCLUDE_DIR}") + set(OPENSSL_SSL_LIBRARY "${AMISSL_STUBS_LIBRARY}") + set(OPENSSL_CRYPTO_LIBRARY "${AMISSL_AUTO_LIBRARY}") + set(CURL_USE_OPENSSL ON) + set(CURL_CA_FALLBACK ON CACHE BOOL "") + list(PREPEND CURL_NETWORK_AND_TIME_LIBS "${AMISSL_STUBS_LIBRARY}" "${AMISSL_AUTO_LIBRARY}") + endif() +elseif(NOT WIN32 AND NOT APPLE) + check_library_exists("socket" "connect" "" HAVE_LIBSOCKET) + if(HAVE_LIBSOCKET) + list(PREPEND CURL_NETWORK_AND_TIME_LIBS "socket") + endif() +endif() + +option(ENABLE_IPV6 "Enable IPv6 support" ON) +mark_as_advanced(ENABLE_IPV6) +if(ENABLE_IPV6) + include(CheckStructHasMember) + if(WIN32) + check_struct_has_member("struct sockaddr_in6" "sin6_scope_id" "winsock2.h;ws2tcpip.h" HAVE_SOCKADDR_IN6_SIN6_SCOPE_ID) + else() + check_struct_has_member("struct sockaddr_in6" "sin6_scope_id" "netinet/in.h" HAVE_SOCKADDR_IN6_SIN6_SCOPE_ID) + check_struct_has_member("struct sockaddr_in6" "sin6_addr" "netinet/in.h" HAVE_SOCKADDR_IN6_SIN6_ADDR) + if(NOT HAVE_SOCKADDR_IN6_SIN6_ADDR) + if(NOT DOS AND NOT AMIGA) + message(WARNING "struct sockaddr_in6 not available, disabling IPv6 support") + endif() + set(ENABLE_IPV6 OFF CACHE BOOL "Enable IPv6 support" FORCE) # Force the feature off as we use this name as guard macro + endif() + + if(CMAKE_SYSTEM_NAME STREQUAL "Darwin" AND NOT ENABLE_ARES) + set(_use_core_foundation_and_core_services ON) + + find_library(SYSTEMCONFIGURATION_FRAMEWORK NAMES "SystemConfiguration") + mark_as_advanced(SYSTEMCONFIGURATION_FRAMEWORK) + if(NOT SYSTEMCONFIGURATION_FRAMEWORK) + message(FATAL_ERROR "SystemConfiguration framework not found") + endif() + list(APPEND CURL_LIBS "-framework SystemConfiguration") + endif() + endif() +endif() +if(ENABLE_IPV6) + set(USE_IPV6 ON) +endif() + +# Check SSL libraries +option(CURL_ENABLE_SSL "Enable SSL support" ON) + +if(CURL_DEFAULT_SSL_BACKEND) + set(_valid_default_ssl_backend FALSE) +endif() + +if(WIN32) + cmake_dependent_option(CURL_USE_SCHANNEL "Enable Windows native SSL/TLS (Schannel)" OFF CURL_ENABLE_SSL OFF) + option(CURL_WINDOWS_SSPI "Enable SSPI on Windows" ${CURL_USE_SCHANNEL}) +else() + set(CURL_USE_SCHANNEL OFF) + set(CURL_WINDOWS_SSPI OFF) +endif() +cmake_dependent_option(CURL_USE_MBEDTLS "Enable mbedTLS for SSL/TLS" OFF CURL_ENABLE_SSL OFF) +cmake_dependent_option(CURL_USE_WOLFSSL "Enable wolfSSL for SSL/TLS" OFF CURL_ENABLE_SSL OFF) +cmake_dependent_option(CURL_USE_GNUTLS "Enable GnuTLS for SSL/TLS" OFF CURL_ENABLE_SSL OFF) +cmake_dependent_option(CURL_USE_RUSTLS "Enable Rustls for SSL/TLS (experimental)" OFF CURL_ENABLE_SSL OFF) + +if(WIN32 OR + CURL_USE_SCHANNEL OR + CURL_USE_MBEDTLS OR + CURL_USE_WOLFSSL OR + CURL_USE_GNUTLS OR + CURL_USE_RUSTLS) + set(_openssl_default OFF) +else() + set(_openssl_default ON) +endif() +cmake_dependent_option(CURL_USE_OPENSSL "Enable OpenSSL for SSL/TLS" ${_openssl_default} CURL_ENABLE_SSL OFF) +option(CURL_DISABLE_OPENSSL_AUTO_LOAD_CONFIG "Disable automatic loading of OpenSSL configuration" OFF) + +curl_count_true(_enabled_ssl_options_count + CURL_USE_SCHANNEL + CURL_USE_OPENSSL + CURL_USE_MBEDTLS + CURL_USE_WOLFSSL + CURL_USE_GNUTLS + CURL_USE_RUSTLS +) +if(_enabled_ssl_options_count GREATER 1) + set(CURL_WITH_MULTI_SSL ON) +elseif(_enabled_ssl_options_count EQUAL 0) + set(CURL_DISABLE_HSTS ON) +endif() + +if(CURL_USE_SCHANNEL) + if(WINDOWS_STORE) + message(FATAL_ERROR "UWP does not support Schannel.") + endif() + set(_ssl_enabled ON) + set(USE_SCHANNEL ON) # Windows native SSL/TLS support + set(USE_WINDOWS_SSPI ON) # CURL_USE_SCHANNEL requires CURL_WINDOWS_SSPI + + if(CURL_DEFAULT_SSL_BACKEND AND CURL_DEFAULT_SSL_BACKEND STREQUAL "schannel") + set(_valid_default_ssl_backend TRUE) + endif() +endif() +if(CURL_WINDOWS_SSPI AND NOT WINDOWS_STORE) + set(USE_WINDOWS_SSPI ON) +endif() + +if(APPLE) + option(USE_APPLE_SECTRUST "Use Apple OS-native certificate verification" OFF) + if(USE_APPLE_SECTRUST) + if(NOT CURL_USE_OPENSSL AND NOT CURL_USE_GNUTLS) + message(FATAL_ERROR "Apple SecTrust is only supported with Openssl/GnuTLS") + endif() + find_library(SECURITY_FRAMEWORK NAMES "Security") + mark_as_advanced(SECURITY_FRAMEWORK) + if(NOT SECURITY_FRAMEWORK) + message(FATAL_ERROR "Security framework not found") + endif() + list(APPEND CURL_LIBS "-framework Security") + + set(_use_core_foundation_and_core_services ON) + message(STATUS "Apple OS-native certificate verification enabled") + endif() +else() + set(USE_APPLE_SECTRUST OFF) +endif() + +if(_use_core_foundation_and_core_services) + find_library(COREFOUNDATION_FRAMEWORK NAMES "CoreFoundation") + mark_as_advanced(COREFOUNDATION_FRAMEWORK) + if(NOT COREFOUNDATION_FRAMEWORK) + message(FATAL_ERROR "CoreFoundation framework not found") + endif() + list(APPEND CURL_LIBS "-framework CoreFoundation") + + find_library(CORESERVICES_FRAMEWORK NAMES "CoreServices") + mark_as_advanced(CORESERVICES_FRAMEWORK) + if(NOT CORESERVICES_FRAMEWORK) + message(FATAL_ERROR "CoreServices framework not found") + endif() + list(APPEND CURL_LIBS "-framework CoreServices") +endif() + +if(CURL_USE_OPENSSL) + find_package(OpenSSL REQUIRED) + set(_ssl_enabled ON) + set(USE_OPENSSL ON) + + # Depend on OpenSSL via imported targets. This allows our dependents to + # get our dependencies transitively. + list(APPEND CURL_LIBS OpenSSL::SSL OpenSSL::Crypto) + + if(CURL_DEFAULT_SSL_BACKEND AND CURL_DEFAULT_SSL_BACKEND STREQUAL "openssl") + set(_valid_default_ssl_backend TRUE) + endif() + set(_curl_ca_bundle_supported TRUE) + + cmake_push_check_state() + list(APPEND CMAKE_REQUIRED_LIBRARIES OpenSSL::SSL OpenSSL::Crypto) + if(NOT DEFINED HAVE_AWSLC) + check_symbol_exists("OPENSSL_IS_AWSLC" "openssl/base.h" HAVE_AWSLC) + endif() + if(NOT DEFINED HAVE_BORINGSSL) + check_symbol_exists("OPENSSL_IS_BORINGSSL" "openssl/base.h" HAVE_BORINGSSL) + endif() + if(NOT DEFINED HAVE_LIBRESSL) + check_symbol_exists("LIBRESSL_VERSION_NUMBER" "openssl/opensslv.h" HAVE_LIBRESSL) + endif() + cmake_pop_check_state() + + if(HAVE_AWSLC OR HAVE_BORINGSSL) + if(NOT MSVC AND NOT ANDROID) # AWS-LC/BoringSSL MSVC builds use native Windows threads + find_package(Threads) + if(CMAKE_USE_PTHREADS_INIT) + set(HAVE_THREADS_POSIX_BORINGSSL 1) + list(APPEND CURL_NETWORK_AND_TIME_LIBS Threads::Threads) + list(APPEND CMAKE_REQUIRED_LIBRARIES Threads::Threads) + elseif(OPENSSL_USE_STATIC_LIBS) + message(WARNING "AWS-LC/BoringSSL requires POSIX Threads.") + endif() + endif() + if(OPENSSL_USE_STATIC_LIBS AND CMAKE_C_COMPILER_ID MATCHES "Clang") + list(APPEND CURL_LIBS "stdc++") + list(APPEND CMAKE_REQUIRED_LIBRARIES "stdc++") + endif() + endif() + + if(USE_AMISSL) + set(_openssl "AmiSSL") + elseif(HAVE_AWSLC) + set(_openssl "AWS-LC") + elseif(HAVE_BORINGSSL) + if(BORINGSSL_VERSION) + set(CURL_BORINGSSL_VERSION "\"${BORINGSSL_VERSION}\"") + endif() + set(_openssl "BoringSSL") + elseif(HAVE_LIBRESSL) + set(_openssl "LibreSSL") + else() + set(_openssl "OpenSSL") + endif() +endif() + +if(CURL_USE_MBEDTLS) + find_package(MbedTLS MODULE REQUIRED) + if(MBEDTLS_VERSION VERSION_LESS 3.2.0) + message(FATAL_ERROR "mbedTLS v3.2.0 or newer is required.") + endif() + set(_ssl_enabled ON) + set(USE_MBEDTLS ON) + list(APPEND CURL_LIBS CURL::mbedtls) + + if(CURL_DEFAULT_SSL_BACKEND AND CURL_DEFAULT_SSL_BACKEND STREQUAL "mbedtls") + set(_valid_default_ssl_backend TRUE) + endif() + set(_curl_ca_bundle_supported TRUE) + + if(MBEDTLS_VERSION VERSION_GREATER_EQUAL 4.0.0) + set(HAVE_MBEDTLS_DES_CRYPT_ECB 0) # pre-fill detection result + endif() + if(NOT DEFINED HAVE_MBEDTLS_DES_CRYPT_ECB) + cmake_push_check_state() + list(APPEND CMAKE_REQUIRED_LIBRARIES CURL::mbedtls) + check_function_exists("mbedtls_des_crypt_ecb" HAVE_MBEDTLS_DES_CRYPT_ECB) # in mbedTLS <4 + cmake_pop_check_state() + endif() +endif() + +if(CURL_USE_WOLFSSL) + find_package(WolfSSL MODULE REQUIRED) + set(_ssl_enabled ON) + set(USE_WOLFSSL ON) + list(APPEND CURL_LIBS CURL::wolfssl) + + if(CURL_DEFAULT_SSL_BACKEND AND CURL_DEFAULT_SSL_BACKEND STREQUAL "wolfssl") + set(_valid_default_ssl_backend TRUE) + endif() + set(_curl_ca_bundle_supported TRUE) + + if(USE_OPENSSL AND WOLFSSL_VERSION VERSION_LESS 5.7.6) + message(FATAL_ERROR "wolfSSL 5.7.6 or newer is required to coexist with OpenSSL.") + endif() + + set_property(DIRECTORY APPEND PROPERTY COMPILE_DEFINITIONS "WOLFSSL_OPTIONS_IGNORE_SYS") +endif() + +if(CURL_USE_GNUTLS) + find_package(GnuTLS MODULE REQUIRED) + list(APPEND CURL_LIBS CURL::gnutls) + find_package(Nettle MODULE REQUIRED) + list(APPEND CURL_LIBS CURL::nettle) + set(_ssl_enabled ON) + set(USE_GNUTLS ON) + + if(CURL_DEFAULT_SSL_BACKEND AND CURL_DEFAULT_SSL_BACKEND STREQUAL "gnutls") + set(_valid_default_ssl_backend TRUE) + endif() + set(_curl_ca_bundle_supported TRUE) + + if(NOT DEFINED HAVE_GNUTLS_SRP AND NOT CURL_DISABLE_SRP) + cmake_push_check_state() + list(APPEND CMAKE_REQUIRED_LIBRARIES CURL::gnutls) + # In GnuTLS 3.8.0 (2023-02-10) and upper, this check always succeeds. + # Detecting actual TLS-SRP support needs poking the API at runtime. + check_symbol_exists("gnutls_srp_verifier" "gnutls/gnutls.h" HAVE_GNUTLS_SRP) + cmake_pop_check_state() + endif() +endif() + +if(CURL_USE_RUSTLS) + find_package(Rustls MODULE REQUIRED) + set(_ssl_enabled ON) + set(USE_RUSTLS ON) + list(APPEND CURL_LIBS CURL::rustls) + + if(NOT DEFINED HAVE_RUSTLS_SUPPORTED_HPKE) + if(RUSTLS_VERSION AND RUSTLS_VERSION VERSION_GREATER_EQUAL 0.15) + set(HAVE_RUSTLS_SUPPORTED_HPKE TRUE) + elseif(NOT RUSTLS_VERSION) + cmake_push_check_state() + list(APPEND CMAKE_REQUIRED_LIBRARIES CURL::rustls) + check_symbol_exists("rustls_supported_hpke" "rustls.h" HAVE_RUSTLS_SUPPORTED_HPKE) + cmake_pop_check_state() + endif() + endif() + if(NOT HAVE_RUSTLS_SUPPORTED_HPKE) + message(FATAL_ERROR "rustls-ffi library does not provide rustls_supported_hpke function. Required version is 0.15 or newer.") + endif() + + if(CURL_DEFAULT_SSL_BACKEND AND CURL_DEFAULT_SSL_BACKEND STREQUAL "rustls") + set(_valid_default_ssl_backend TRUE) + endif() + set(_curl_ca_bundle_supported TRUE) +endif() + +if(CURL_DEFAULT_SSL_BACKEND AND NOT _valid_default_ssl_backend) + message(FATAL_ERROR "CURL_DEFAULT_SSL_BACKEND '${CURL_DEFAULT_SSL_BACKEND}' not enabled.") +endif() + +# Keep ZLIB detection after TLS detection, +# and before calling curl_openssl_check_exists(). + +set(HAVE_LIBZ OFF) +curl_dependency_option(CURL_ZLIB ZLIB "ZLIB") +if(ZLIB_FOUND) + set(HAVE_LIBZ ON) + # Depend on ZLIB via imported targets. This allows our dependents to + # get our dependencies transitively. + list(APPEND CURL_LIBS ZLIB::ZLIB) +endif() + +set(HAVE_BROTLI OFF) +curl_dependency_option(CURL_BROTLI Brotli "brotli") +if(BROTLI_FOUND) + set(HAVE_BROTLI ON) + list(APPEND CURL_LIBS CURL::brotli) +endif() + +set(HAVE_ZSTD OFF) +curl_dependency_option(CURL_ZSTD Zstd "zstd") +if(ZSTD_FOUND) + if(ZSTD_VERSION VERSION_GREATER_EQUAL 1.0.0) + set(HAVE_ZSTD ON) + list(APPEND CURL_LIBS CURL::zstd) + else() + message(WARNING "zstd v1.0.0 or newer is required, disabling zstd support.") + endif() +endif() + +# Check function in an OpenSSL-like TLS backend. +macro(curl_openssl_check_exists) + cmake_push_check_state() + if(USE_OPENSSL) + list(APPEND CMAKE_REQUIRED_LIBRARIES OpenSSL::SSL OpenSSL::Crypto) + list(APPEND CMAKE_REQUIRED_DEFINITIONS "-DOPENSSL_SUPPRESS_DEPRECATED") # for SSL_CTX_set_srp_username deprecated since 3.0.0 + if(HAVE_LIBZ) + list(APPEND CMAKE_REQUIRED_LIBRARIES ZLIB::ZLIB) + endif() + if(WIN32) + list(APPEND CMAKE_REQUIRED_LIBRARIES "bcrypt") # for OpenSSL/LibreSSL BCryptGenRandom() + endif() + endif() + if(USE_WOLFSSL) + list(APPEND CMAKE_REQUIRED_LIBRARIES CURL::wolfssl) + list(APPEND CMAKE_REQUIRED_DEFINITIONS "-DWOLFSSL_OPTIONS_IGNORE_SYS") + if(HAVE_LIBZ) + list(APPEND CMAKE_REQUIRED_LIBRARIES ZLIB::ZLIB) # Public wolfSSL headers also require zlib headers + endif() + list(APPEND CMAKE_REQUIRED_DEFINITIONS "-DHAVE_UINTPTR_T") # to pull in stdint.h (as of wolfSSL v5.5.4) + endif() + if(WIN32) + list(APPEND CMAKE_REQUIRED_LIBRARIES "ws2_32" "crypt32") # for OpenSSL/wolfSSL + endif() + if(${ARGC} EQUAL 2) + check_function_exists(${ARGN}) + else() + check_symbol_exists(${ARGN}) # Uses CMAKE_REQUIRED_INCLUDES and CMAKE_REQUIRED_DEFINITIONS + endif() + cmake_pop_check_state() +endmacro() + +# Ensure that OpenSSL (or fork) or wolfSSL actually supports QUICTLS API. +macro(curl_openssl_check_quic) + if(USE_OPENSSL) + if(OPENSSL_VERSION VERSION_GREATER_EQUAL 3.5.0) + if(NOT DEFINED HAVE_SSL_SET_QUIC_TLS_CBS) + curl_openssl_check_exists("SSL_set_quic_tls_cbs" HAVE_SSL_SET_QUIC_TLS_CBS) + endif() + else() + if(NOT DEFINED HAVE_SSL_SET_QUIC_USE_LEGACY_CODEPOINT) + curl_openssl_check_exists("SSL_set_quic_use_legacy_codepoint" HAVE_SSL_SET_QUIC_USE_LEGACY_CODEPOINT) + endif() + endif() + endif() + if(USE_WOLFSSL AND NOT DEFINED HAVE_WOLFSSL_SET_QUIC_USE_LEGACY_CODEPOINT) + curl_openssl_check_exists("wolfSSL_set_quic_use_legacy_codepoint" HAVE_WOLFSSL_SET_QUIC_USE_LEGACY_CODEPOINT) + endif() + if(NOT HAVE_SSL_SET_QUIC_TLS_CBS AND + NOT HAVE_SSL_SET_QUIC_USE_LEGACY_CODEPOINT AND + NOT HAVE_WOLFSSL_SET_QUIC_USE_LEGACY_CODEPOINT) + message(FATAL_ERROR "QUICTLS API support is missing from OpenSSL/fork/wolfSSL. Try setting -DOPENSSL_ROOT_DIR") + endif() +endmacro() + +if(USE_WOLFSSL) + curl_openssl_check_exists("wolfSSL_get_peer_certificate" HAVE_WOLFSSL_GET_PEER_CERTIFICATE) + curl_openssl_check_exists("wolfSSL_UseALPN" HAVE_WOLFSSL_USEALPN) + curl_openssl_check_exists("wolfSSL_BIO_new" HAVE_WOLFSSL_BIO_NEW) + curl_openssl_check_exists("wolfSSL_BIO_set_shutdown" HAVE_WOLFSSL_BIO_SET_SHUTDOWN) + curl_openssl_check_exists("wc_Des_EcbEncrypt" HAVE_WC_DES_ECBENCRYPT) +endif() + +if(USE_OPENSSL) + if(NOT DEFINED HAVE_DES_ECB_ENCRYPT) + curl_openssl_check_exists("DES_ecb_encrypt" "openssl/des.h" HAVE_DES_ECB_ENCRYPT) + endif() + if(NOT DEFINED HAVE_SSL_SET0_WBIO) + curl_openssl_check_exists("SSL_set0_wbio" HAVE_SSL_SET0_WBIO) + endif() + if(NOT DEFINED HAVE_OPENSSL_SRP AND NOT CURL_DISABLE_SRP) + curl_openssl_check_exists("SSL_CTX_set_srp_username" "openssl/ssl.h" HAVE_OPENSSL_SRP) + endif() +endif() + +option(USE_HTTPSRR "Enable HTTPS RR support (experimental)" OFF) +option(USE_ECH "Enable ECH support (experimental)" OFF) +if(USE_ECH) + if(USE_OPENSSL OR USE_WOLFSSL OR USE_RUSTLS) + # Be sure that the TLS library actually supports ECH. + if(USE_WOLFSSL) + curl_openssl_check_exists("wolfSSL_CTX_GenerateEchConfig" HAVE_WOLFSSL_CTX_GENERATEECHCONFIG) + endif() + if(USE_OPENSSL) + curl_openssl_check_exists("SSL_set1_ech_config_list" HAVE_SSL_SET1_ECH_CONFIG_LIST) + endif() + if(HAVE_WOLFSSL_CTX_GENERATEECHCONFIG OR + HAVE_SSL_SET1_ECH_CONFIG_LIST OR + USE_RUSTLS) + set(HAVE_ECH 1) + endif() + if(NOT HAVE_ECH) + message(FATAL_ERROR "ECH support missing in AWS-LC/BoringSSL/OpenSSL/Rustls/wolfSSL") + else() + message(STATUS "ECH enabled") + # ECH wants HTTPSRR + set(USE_HTTPSRR ON) + message(STATUS "HTTPSRR enabled") + endif() + else() + message(FATAL_ERROR "ECH requires ECH-enabled AWS-LC, BoringSSL, OpenSSL, Rustls or wolfSSL") + endif() +endif() + +option(USE_SSLS_EXPORT "Enable SSL session import/export (experimental)" OFF) +if(USE_SSLS_EXPORT) + if(_ssl_enabled) + message(STATUS "SSL export enabled.") + else() + message(WARNING "SSL session export requires SSL enabled") + endif() +endif() + +option(USE_PROXY_HTTP3 "Enable HTTP/3 proxy support (experimental)" OFF) + +option(USE_NGHTTP2 "Use nghttp2 library" ON) +if(USE_NGHTTP2) + find_package(NGHTTP2 MODULE) + if(NGHTTP2_FOUND) + list(APPEND CURL_LIBS CURL::nghttp2) + else() + set(USE_NGHTTP2 OFF) + endif() +endif() + +option(USE_NGTCP2 "Use ngtcp2 and nghttp3 libraries for HTTP/3 support" OFF) +if(USE_NGTCP2) + if(CURL_WITH_MULTI_SSL) + message(FATAL_ERROR "MultiSSL cannot be enabled with HTTP/3 and vice versa.") + elseif(USE_OPENSSL OR USE_WOLFSSL) + if(USE_WOLFSSL) + find_package(NGTCP2 MODULE REQUIRED COMPONENTS "wolfSSL") + elseif(HAVE_BORINGSSL OR HAVE_AWSLC) + find_package(NGTCP2 MODULE REQUIRED COMPONENTS "BoringSSL") + elseif(OPENSSL_VERSION VERSION_GREATER_EQUAL 3.5.0) + find_package(NGTCP2 MODULE REQUIRED COMPONENTS "ossl") + if(NGTCP2_VERSION VERSION_LESS 1.12.0) + message(FATAL_ERROR "ngtcp2 1.12.0 or upper required for OpenSSL") + endif() + set(OPENSSL_QUIC_API2 1) + elseif(HAVE_LIBRESSL) + find_package(NGTCP2 MODULE COMPONENTS "LibreSSL") + if(NOT NGTCP2_FOUND) + find_package(NGTCP2 MODULE REQUIRED COMPONENTS "quictls") # for ngtcp2 <1.15.0 + endif() + else() + find_package(NGTCP2 MODULE REQUIRED COMPONENTS "quictls") + set(_openssl "quictls") + endif() + curl_openssl_check_quic() + elseif(USE_GNUTLS) + find_package(NGTCP2 MODULE REQUIRED "GnuTLS") + else() + message(FATAL_ERROR "ngtcp2 requires a supported TLS-backend") + endif() + list(APPEND CURL_LIBS CURL::ngtcp2) + + find_package(NGHTTP3 MODULE REQUIRED) + set(USE_NGHTTP3 ON) + list(APPEND CURL_LIBS CURL::nghttp3) +endif() + +option(USE_QUICHE "Use quiche library for HTTP/3 support (experimental)" OFF) +if(USE_QUICHE) + if(USE_NGTCP2) + message(FATAL_ERROR "Only one HTTP/3 backend can be selected") + elseif(CURL_WITH_MULTI_SSL) + message(FATAL_ERROR "MultiSSL cannot be enabled with HTTP/3 and vice versa.") + endif() + find_package(Quiche MODULE REQUIRED) + if(NOT HAVE_BORINGSSL) + message(FATAL_ERROR "quiche requires BoringSSL") + endif() + curl_openssl_check_quic() + list(APPEND CURL_LIBS CURL::quiche) + if(NOT DEFINED HAVE_QUICHE_CONN_SET_QLOG_FD) + cmake_push_check_state() + list(APPEND CMAKE_REQUIRED_LIBRARIES CURL::quiche) + check_symbol_exists("quiche_conn_set_qlog_fd" "quiche.h" HAVE_QUICHE_CONN_SET_QLOG_FD) + cmake_pop_check_state() + endif() +endif() + +if(USE_PROXY_HTTP3) + if(CURL_DISABLE_PROXY) + message(FATAL_ERROR "USE_PROXY_HTTP3 requires proxy support") + elseif(CURL_DISABLE_HTTP) + message(FATAL_ERROR "USE_PROXY_HTTP3 requires HTTP support") + elseif(NOT USE_NGTCP2 OR NOT USE_NGHTTP3) + message(FATAL_ERROR "USE_PROXY_HTTP3 requires ngtcp2 + nghttp3") + elseif(NOT USE_OPENSSL) + message(FATAL_ERROR "USE_PROXY_HTTP3 currently requires OpenSSL") + else() + message(STATUS "HTTP/3 proxy support enabled (experimental)") + endif() +endif() + +if(NOT CURL_DISABLE_SRP AND (HAVE_GNUTLS_SRP OR HAVE_OPENSSL_SRP)) + set(USE_TLS_SRP 1) +endif() + +if(NOT CURL_DISABLE_LDAP) + if(WIN32 AND NOT WINDOWS_STORE) + option(USE_WIN32_LDAP "Use Windows LDAP implementation" ON) + if(USE_WIN32_LDAP) + list(APPEND CURL_LIBS "wldap32") + if(NOT CURL_DISABLE_LDAPS) + set(HAVE_LDAP_SSL ON) + endif() + endif() + endif() + + # Now that we know, we are not using Windows LDAP... + if(NOT USE_WIN32_LDAP) + # Check for LDAP + cmake_push_check_state() + if(USE_OPENSSL) + list(APPEND CMAKE_REQUIRED_LIBRARIES OpenSSL::SSL OpenSSL::Crypto) + endif() + find_package(LDAP MODULE) + if(LDAP_FOUND) + set(HAVE_LBER_H 1) + list(PREPEND CURL_LIBS CURL::ldap) + + # LDAP feature checks + + list(APPEND CMAKE_REQUIRED_DEFINITIONS "-DLDAP_DEPRECATED=1") + list(APPEND CMAKE_REQUIRED_LIBRARIES CURL::ldap) + + check_function_exists("ldap_url_parse" HAVE_LDAP_URL_PARSE) + check_function_exists("ldap_init_fd" HAVE_LDAP_INIT_FD) + + check_include_file("ldap_ssl.h" HAVE_LDAP_SSL_H) + + if(HAVE_LDAP_INIT_FD) + set(USE_OPENLDAP ON) + endif() + if(NOT CURL_DISABLE_LDAPS) + set(HAVE_LDAP_SSL ON) + endif() + else() + message(STATUS "LDAP not found. CURL_DISABLE_LDAP set ON") + set(CURL_DISABLE_LDAP ON CACHE BOOL "" FORCE) + endif() + cmake_pop_check_state() + endif() +endif() + +# No ldap, no ldaps. +if(CURL_DISABLE_LDAP) + if(NOT CURL_DISABLE_LDAPS) + message(STATUS "LDAP needs to be enabled to support LDAPS") + set(CURL_DISABLE_LDAPS ON CACHE BOOL "" FORCE) + endif() +endif() + +if(WIN32) + option(USE_WIN32_IDN "Use WinIDN for IDN support" OFF) + if(USE_WIN32_IDN) + list(APPEND CURL_LIBS "normaliz") # for IdnToAscii(), IdnToUnicode() + endif() +else() + set(USE_WIN32_IDN OFF) +endif() + +if(APPLE) + option(USE_APPLE_IDN "Use Apple built-in IDN support" OFF) + if(USE_APPLE_IDN) + cmake_push_check_state() + list(APPEND CMAKE_REQUIRED_LIBRARIES "icucore") + check_symbol_exists("uidna_openUTS46" "unicode/uidna.h" HAVE_APPLE_IDN) + cmake_pop_check_state() + if(HAVE_APPLE_IDN) + list(APPEND CURL_LIBS "icucore" "iconv") + else() + set(USE_APPLE_IDN OFF) + endif() + endif() +else() + set(USE_APPLE_IDN OFF) +endif() + +# Check for libidn2 +option(USE_LIBIDN2 "Use libidn2 for IDN support" ON) +set(HAVE_IDN2_H OFF) +set(HAVE_LIBIDN2 OFF) +if(USE_LIBIDN2 AND NOT USE_APPLE_IDN AND NOT USE_WIN32_IDN) + find_package(Libidn2 MODULE) + if(LIBIDN2_FOUND) + list(PREPEND CURL_LIBS CURL::libidn2) + set(HAVE_IDN2_H 1) + set(HAVE_LIBIDN2 1) + endif() +endif() + +# libpsl +option(CURL_USE_LIBPSL "Use libpsl" ON) +mark_as_advanced(CURL_USE_LIBPSL) +set(USE_LIBPSL OFF) +if(CURL_USE_LIBPSL) + find_package(Libpsl MODULE REQUIRED) + list(APPEND CURL_LIBS CURL::libpsl) + set(USE_LIBPSL ON) +endif() + +# libssh2 +option(CURL_USE_LIBSSH2 "Use libssh2" ON) +mark_as_advanced(CURL_USE_LIBSSH2) +set(USE_LIBSSH2 OFF) +if(CURL_USE_LIBSSH2) + find_package(Libssh2 MODULE) + if(LIBSSH2_FOUND) + list(PREPEND CURL_LIBS CURL::libssh2) # keep it before TLS-crypto, compression + set(USE_LIBSSH2 ON) + endif() +endif() + +# libssh +option(CURL_USE_LIBSSH "Use libssh" OFF) +mark_as_advanced(CURL_USE_LIBSSH) +if(NOT USE_LIBSSH2 AND CURL_USE_LIBSSH) + find_package(Libssh MODULE REQUIRED) + list(PREPEND CURL_LIBS CURL::libssh) # keep it before TLS-crypto, compression + set(USE_LIBSSH ON) +endif() + +option(CURL_USE_GSASL "Use libgsasl" OFF) +mark_as_advanced(CURL_USE_GSASL) +if(CURL_USE_GSASL) + find_package(Libgsasl MODULE REQUIRED) + list(APPEND CURL_LIBS CURL::libgsasl) + set(USE_GSASL ON) +endif() + +option(CURL_USE_GSSAPI "Use GSSAPI implementation" OFF) +mark_as_advanced(CURL_USE_GSSAPI) + +if(CURL_USE_GSSAPI) + find_package(GSS MODULE) + + set(HAVE_GSSAPI ${GSS_FOUND}) + if(GSS_FOUND) + list(APPEND CURL_LIBS CURL::gss) + + get_target_property(_gss_flavor CURL::gss INTERFACE_CURL_GSS_FLAVOR) + if(_gss_flavor STREQUAL "GNU") + set(HAVE_GSSGNU 1) + elseif(GSS_VERSION) # MIT + set(CURL_KRB5_VERSION "\"${GSS_VERSION}\"") + endif() + else() + message(WARNING "GSSAPI has been requested, but no supporting libraries found. Skipping.") + endif() +endif() + +# libbacktrace +option(CURL_USE_LIBBACKTRACE "Use libbacktrace. Requires debug-enabled build and DWARF debug information." OFF) +if(CURL_USE_LIBBACKTRACE) + if(NOT ENABLE_DEBUG) + message(FATAL_ERROR "libbacktrace requires debug-enabled build for TrackMemory") + endif() + if(NOT CMAKE_BUILD_TYPE MATCHES "(Debug|RelWithDebInfo)") + message(FATAL_ERROR "libbacktrace requires debug information") + endif() + find_package(Libbacktrace MODULE REQUIRED) + list(APPEND CURL_LIBS CURL::libbacktrace) + set(USE_BACKTRACE ON) +endif() + +# libuv +option(CURL_USE_LIBUV "Use libuv for event-based tests" OFF) +if(CURL_USE_LIBUV) + if(NOT ENABLE_DEBUG) + message(FATAL_ERROR "Using libuv without debug support enabled is useless") + endif() + find_package(Libuv MODULE REQUIRED) + list(APPEND CURL_LIBS CURL::libuv) + set(USE_LIBUV ON) + set(HAVE_UV_H ON) +endif() + +option(ENABLE_UNIX_SOCKETS "Enable Unix domain sockets support" ON) +if(ENABLE_UNIX_SOCKETS) + if(WIN32 OR DOS) + set(USE_UNIX_SOCKETS 1) + else() + include(CheckStructHasMember) + check_struct_has_member("struct sockaddr_un" "sun_path" "sys/un.h" USE_UNIX_SOCKETS) + endif() +else() + set(USE_UNIX_SOCKETS 0) + unset(USE_UNIX_SOCKETS CACHE) +endif() + +# +# CA handling +# +option(CURL_CA_NATIVE "Use native CA store" OFF) +if(CURL_CA_NATIVE) + set(_curl_disable_ca_search_default ON) +else() + set(_curl_disable_ca_search_default OFF) +endif() + +if(_curl_ca_bundle_supported) + set(_ca_opt_desc "Set 'none' to disable or 'auto' for auto-detection. Defaults to 'auto'.") + + set(CURL_CA_BUNDLE "auto" CACHE + STRING "Absolute path to the CA bundle. ${_ca_opt_desc}") + set(CURL_CA_FALLBACK OFF CACHE + BOOL "Use built-in CA store of OpenSSL. Defaults to OFF") + set(CURL_CA_PATH "auto" CACHE + STRING "Absolute path to a directory containing CA certificates stored individually. ${_ca_opt_desc}") + set(CURL_CA_EMBED "" CACHE + STRING "Absolute path to the CA bundle to embed in the curl tool.") + + if(CURL_CA_FALLBACK AND NOT CURL_USE_OPENSSL) + message(FATAL_ERROR "CURL_CA_FALLBACK only works with OpenSSL.") + endif() + + if(CURL_CA_BUNDLE STREQUAL "") + message(FATAL_ERROR "Invalid value of CURL_CA_BUNDLE. Use 'none', 'auto' or file path.") + elseif(CURL_CA_BUNDLE STREQUAL "none") + unset(CURL_CA_BUNDLE CACHE) + elseif(CURL_CA_BUNDLE STREQUAL "auto") + unset(CURL_CA_BUNDLE CACHE) + if(NOT CMAKE_CROSSCOMPILING AND NOT WIN32 AND NOT USE_APPLE_SECTRUST AND NOT CURL_CA_NATIVE) + set(_curl_ca_bundle_autodetect TRUE) + endif() + else() + set(CURL_CA_BUNDLE_SET TRUE) + endif() + mark_as_advanced(CURL_CA_BUNDLE_SET) + + if(CURL_CA_PATH STREQUAL "") + message(FATAL_ERROR "Invalid value of CURL_CA_PATH. Use 'none', 'auto' or directory path.") + elseif(CURL_CA_PATH STREQUAL "none") + unset(CURL_CA_PATH CACHE) + elseif(CURL_CA_PATH STREQUAL "auto") + unset(CURL_CA_PATH CACHE) + if(NOT CMAKE_CROSSCOMPILING AND NOT WIN32 AND NOT USE_APPLE_SECTRUST AND NOT CURL_CA_NATIVE) + set(_curl_ca_path_autodetect TRUE) + endif() + else() + set(CURL_CA_PATH_SET TRUE) + endif() + mark_as_advanced(CURL_CA_PATH_SET) + + if(CURL_CA_BUNDLE_SET AND _curl_ca_path_autodetect) + # Skip auto-detection of unset CA path because CA bundle is set explicitly + elseif(CURL_CA_PATH_SET AND _curl_ca_bundle_autodetect) + # Skip auto-detection of unset CA bundle because CA path is set explicitly + elseif(_curl_ca_bundle_autodetect OR _curl_ca_path_autodetect) + # First try auto-detecting a CA bundle, then a CA path + + if(_curl_ca_bundle_autodetect) + foreach(_search_ca_bundle_path IN ITEMS + "/etc/ssl/certs/ca-certificates.crt" + "/etc/pki/tls/certs/ca-bundle.crt" + "/usr/share/ssl/certs/ca-bundle.crt" + "/usr/local/share/certs/ca-root-nss.crt" + "/etc/ssl/cert.pem") + if(EXISTS "${_search_ca_bundle_path}") + message(STATUS "Found CA bundle: ${_search_ca_bundle_path}") + set(CURL_CA_BUNDLE "${_search_ca_bundle_path}" CACHE + STRING "Absolute path to the CA bundle. ${_ca_opt_desc}") + set(CURL_CA_BUNDLE_SET TRUE CACHE BOOL "Absolute path to the CA bundle has been set") + break() + endif() + endforeach() + endif() + + if(_curl_ca_path_autodetect AND NOT CURL_CA_PATH_SET) + set(_search_ca_path "/etc/ssl/certs") + file(GLOB _curl_ca_files_found "${_search_ca_path}/[0-9a-f][0-9a-f][0-9a-f][0-9a-f][0-9a-f][0-9a-f][0-9a-f][0-9a-f].0") + if(_curl_ca_files_found) + unset(_curl_ca_files_found) + message(STATUS "Found CA path: ${_search_ca_path}") + set(CURL_CA_PATH "${_search_ca_path}" CACHE + STRING "Absolute path to a directory containing CA certificates stored individually. ${_ca_opt_desc}") + set(CURL_CA_PATH_SET TRUE CACHE BOOL "Absolute path to the CA bundle has been set") + endif() + endif() + endif() + + set(CURL_CA_EMBED_SET FALSE) + if(BUILD_CURL_EXE AND NOT CURL_CA_EMBED STREQUAL "") + if(EXISTS "${CURL_CA_EMBED}") + set(CURL_CA_EMBED_SET TRUE) + message(STATUS "Found CA bundle to embed: ${CURL_CA_EMBED}") + else() + message(FATAL_ERROR "CA bundle to embed is missing: '${CURL_CA_EMBED}'") + endif() + endif() +endif() + +if(WIN32) + option(CURL_DISABLE_CA_SEARCH "Disable unsafe CA bundle search in PATH on Windows" ${_curl_disable_ca_search_default}) + option(CURL_CA_SEARCH_SAFE "Enable safe CA bundle search (within the curl tool directory) on Windows" OFF) +endif() + +set(CURL_INCLUDES "") + +# Check for header files +if(WIN32) + list(APPEND CURL_INCLUDES "winsock2.h") + list(APPEND CURL_INCLUDES "ws2tcpip.h") + + if(HAVE_WIN32_WINNT AND HAVE_WIN32_WINNT LESS 0x0600) + # Windows Vista is required for freeaddrinfo, getaddrinfo, if_nametoindex + message(FATAL_ERROR "Building for Windows Vista or newer is required.") + endif() +endif() + +if(NOT WIN32) + list(APPEND CURL_INCLUDES "sys/socket.h") +endif() +if(NOT WIN32 OR MINGW) + list(APPEND CURL_INCLUDES "sys/time.h") +endif() + +# Detect headers + +# Use check_include_file_concat_curl() for headers required by subsequent +# check_include_file_concat_curl() or check_symbol_exists() detections. +# Order for these is significant. +check_include_file("sys/eventfd.h" HAVE_SYS_EVENTFD_H) +check_include_file("sys/filio.h" HAVE_SYS_FILIO_H) +check_include_file("sys/ioctl.h" HAVE_SYS_IOCTL_H) +check_include_file("sys/param.h" HAVE_SYS_PARAM_H) +check_include_file("sys/poll.h" HAVE_SYS_POLL_H) +check_include_file("sys/resource.h" HAVE_SYS_RESOURCE_H) +check_include_file_concat_curl("sys/select.h" HAVE_SYS_SELECT_H) +check_include_file("sys/sockio.h" HAVE_SYS_SOCKIO_H) +check_include_file_concat_curl("sys/types.h" HAVE_SYS_TYPES_H) +check_include_file("sys/un.h" HAVE_SYS_UN_H) +check_include_file_concat_curl("sys/utime.h" HAVE_SYS_UTIME_H) # sys/types.h (AmigaOS) + +check_include_file_concat_curl("arpa/inet.h" HAVE_ARPA_INET_H) +check_include_file("dirent.h" HAVE_DIRENT_H) +check_include_file("fcntl.h" HAVE_FCNTL_H) +check_include_file_concat_curl("ifaddrs.h" HAVE_IFADDRS_H) +check_include_file("io.h" HAVE_IO_H) +check_include_file_concat_curl("libgen.h" HAVE_LIBGEN_H) +check_include_file("linux/tcp.h" HAVE_LINUX_TCP_H) +check_include_file("locale.h" HAVE_LOCALE_H) +check_include_file_concat_curl("net/if.h" HAVE_NET_IF_H) # sys/select.h (e.g. MS-DOS/Watt-32) +check_include_file_concat_curl("netdb.h" HAVE_NETDB_H) +check_include_file_concat_curl("netinet/in.h" HAVE_NETINET_IN_H) +check_include_file("netinet/in6.h" HAVE_NETINET_IN6_H) +check_include_file_concat_curl("netinet/tcp.h" HAVE_NETINET_TCP_H) # sys/types.h (e.g. Cygwin) netinet/in.h +check_include_file_concat_curl("netinet/udp.h" HAVE_NETINET_UDP_H) # sys/types.h (e.g. Cygwin) +check_include_file("poll.h" HAVE_POLL_H) +check_include_file("pwd.h" HAVE_PWD_H) +check_include_file("stdatomic.h" HAVE_STDATOMIC_H) +check_include_file("stdbool.h" HAVE_STDBOOL_H) +check_include_file("strings.h" HAVE_STRINGS_H) +check_include_file("stropts.h" HAVE_STROPTS_H) +check_include_file("termio.h" HAVE_TERMIO_H) +check_include_file("termios.h" HAVE_TERMIOS_H) +check_include_file_concat_curl("unistd.h" HAVE_UNISTD_H) +check_include_file("utime.h" HAVE_UTIME_H) + +if(AMIGA) + check_include_file_concat_curl("proto/bsdsocket.h" HAVE_PROTO_BSDSOCKET_H) +endif() + +# Pass these detection results to curl_internal_test() for use in CurlTests.c +# Add here all feature flags referenced from CurlTests.c +foreach(_variable IN ITEMS + HAVE_STDATOMIC_H + HAVE_STDBOOL_H + HAVE_STROPTS_H + HAVE_SYS_IOCTL_H + HAVE_SYS_TYPES_H + HAVE_UNISTD_H +) + if(${_variable}) + list(APPEND CURL_TEST_DEFINES "-D${_variable}") + endif() +endforeach() + +check_type_size("size_t" SIZEOF_SIZE_T) +check_type_size("ssize_t" SIZEOF_SSIZE_T) +check_type_size("long" SIZEOF_LONG) +check_type_size("int" SIZEOF_INT) +check_type_size("__int64" SIZEOF___INT64) +check_type_size("time_t" SIZEOF_TIME_T) +check_type_size("suseconds_t" SIZEOF_SUSECONDS_T) +if(NOT HAVE_SIZEOF_SSIZE_T) + if(SIZEOF_LONG EQUAL SIZEOF_SIZE_T) + set(ssize_t "long") + endif() + if(NOT ssize_t AND SIZEOF___INT64 EQUAL SIZEOF_SIZE_T) + set(ssize_t "__int64") + endif() +endif() +# off_t is sized later, after the HAVE_FILE_OFFSET_BITS test + +if(SIZEOF_SUSECONDS_T) + set(HAVE_SUSECONDS_T 1) +endif() + +# Check for some functions that are used + +# Apply to all feature checks +if(WIN32) + list(APPEND CMAKE_REQUIRED_LIBRARIES "ws2_32") + if(NOT WINDOWS_STORE) + list(APPEND CMAKE_REQUIRED_LIBRARIES "iphlpapi") + endif() +elseif(HAVE_LIBSOCKET) + list(APPEND CMAKE_REQUIRED_LIBRARIES "socket") +elseif(DOS) + list(APPEND CMAKE_REQUIRED_LIBRARIES "${WATT_ROOT}/lib/libwatt.a") +endif() + +check_function_exists("accept4" HAVE_ACCEPT4) +check_function_exists("fnmatch" HAVE_FNMATCH) +check_symbol_exists("basename" "${CURL_INCLUDES};string.h" HAVE_BASENAME) # libgen.h unistd.h +check_symbol_exists("opendir" "dirent.h" HAVE_OPENDIR) +check_function_exists("poll" HAVE_POLL) # poll.h +check_symbol_exists("socket" "${CURL_INCLUDES}" HAVE_SOCKET) # winsock2.h sys/socket.h +check_symbol_exists("socketpair" "${CURL_INCLUDES}" HAVE_SOCKETPAIR) # sys/socket.h +check_symbol_exists("recv" "${CURL_INCLUDES}" HAVE_RECV) # proto/bsdsocket.h sys/types.h sys/socket.h +check_symbol_exists("send" "${CURL_INCLUDES}" HAVE_SEND) # proto/bsdsocket.h sys/types.h sys/socket.h +check_function_exists("sendmsg" HAVE_SENDMSG) +check_function_exists("sendmmsg" HAVE_SENDMMSG) +check_symbol_exists("select" "${CURL_INCLUDES}" HAVE_SELECT) # proto/bsdsocket.h sys/select.h sys/socket.h +check_symbol_exists("memrchr" "string.h" HAVE_MEMRCHR) +check_symbol_exists("alarm" "unistd.h" HAVE_ALARM) +check_symbol_exists("fcntl" "fcntl.h" HAVE_FCNTL) +check_function_exists("getppid" HAVE_GETPPID) +check_function_exists("utimes" HAVE_UTIMES) + +check_function_exists("gettimeofday" HAVE_GETTIMEOFDAY) # sys/time.h +check_symbol_exists("closesocket" "${CURL_INCLUDES}" HAVE_CLOSESOCKET) # winsock2.h +check_symbol_exists("sigsetjmp" "setjmp.h" HAVE_SIGSETJMP) +check_function_exists("getpass_r" HAVE_GETPASS_R) +check_function_exists("getpwuid" HAVE_GETPWUID) +check_function_exists("getpwuid_r" HAVE_GETPWUID_R) +check_function_exists("geteuid" HAVE_GETEUID) +check_function_exists("utime" HAVE_UTIME) +check_symbol_exists("gmtime_r" "stdlib.h;time.h" HAVE_GMTIME_R) +check_symbol_exists("localtime_r" "stdlib.h;time.h" HAVE_LOCALTIME_R) + +check_symbol_exists("gethostbyname_r" "netdb.h" HAVE_GETHOSTBYNAME_R) +check_symbol_exists("gethostname" "${CURL_INCLUDES}" HAVE_GETHOSTNAME) # winsock2.h unistd.h proto/bsdsocket.h + +check_symbol_exists("signal" "signal.h" HAVE_SIGNAL) +check_symbol_exists("strerror_r" "stdlib.h;string.h" HAVE_STRERROR_R) +check_symbol_exists("sigaction" "signal.h" HAVE_SIGACTION) +check_symbol_exists("siginterrupt" "signal.h" HAVE_SIGINTERRUPT) +check_symbol_exists("getaddrinfo" "${CURL_INCLUDES};stdlib.h;string.h" HAVE_GETADDRINFO) # ws2tcpip.h sys/socket.h netdb.h +check_symbol_exists("getifaddrs" "${CURL_INCLUDES};stdlib.h" HAVE_GETIFADDRS) # ifaddrs.h +check_symbol_exists("freeaddrinfo" "${CURL_INCLUDES}" HAVE_FREEADDRINFO) # ws2tcpip.h sys/socket.h netdb.h +check_function_exists("pipe" HAVE_PIPE) +check_function_exists("eventfd" HAVE_EVENTFD) +check_symbol_exists("getpeername" "${CURL_INCLUDES}" HAVE_GETPEERNAME) # winsock2.h unistd.h proto/bsdsocket.h +check_symbol_exists("getsockname" "${CURL_INCLUDES}" HAVE_GETSOCKNAME) # winsock2.h unistd.h proto/bsdsocket.h +check_function_exists("getrlimit" HAVE_GETRLIMIT) +check_function_exists("setlocale" HAVE_SETLOCALE) +check_function_exists("setrlimit" HAVE_SETRLIMIT) + +if(APPLE) + check_function_exists("mach_absolute_time" HAVE_MACH_ABSOLUTE_TIME) +else() + # Apple platforms do not offer pipe2(), but the iPhone Simulator-specific + # /usr/lib/system/libsystem_sim_kernel.dylib exports it. To avoid false + # detection, omit this feature check for Apple targets. + check_function_exists("pipe2" HAVE_PIPE2) +endif() + +if(NOT WIN32) + check_function_exists("if_nametoindex" HAVE_IF_NAMETOINDEX) # net/if.h + check_function_exists("realpath" HAVE_REALPATH) + check_function_exists("sched_yield" HAVE_SCHED_YIELD) + + check_symbol_exists("inet_ntop" "${CURL_INCLUDES};stdlib.h;string.h" HAVE_INET_NTOP) # arpa/inet.h netinet/in.h sys/socket.h + check_symbol_exists("inet_pton" "${CURL_INCLUDES};stdlib.h;string.h" HAVE_INET_PTON) # arpa/inet.h netinet/in.h sys/socket.h + check_symbol_exists("strcasecmp" "string.h" HAVE_STRCASECMP) + check_symbol_exists("stricmp" "string.h" HAVE_STRICMP) + check_symbol_exists("strcmpi" "string.h" HAVE_STRCMPI) + + check_symbol_exists("memset_s" "string.h" HAVE_MEMSET_S) + if(NOT HAVE_MEMSET_S) + check_function_exists("memset_explicit" HAVE_MEMSET_EXPLICIT) + endif() +endif() + +if(AMIGA) + check_symbol_exists("CloseSocket" "${CURL_INCLUDES}" HAVE_CLOSESOCKET_CAMEL) # sys/socket.h proto/bsdsocket.h +endif() + +if(NOT _ssl_enabled) + check_symbol_exists("arc4random" "${CURL_INCLUDES};stdlib.h" HAVE_ARC4RANDOM) +endif() + +check_symbol_exists("fsetxattr" "sys/xattr.h" HAVE_FSETXATTR) +if(HAVE_FSETXATTR) + curl_internal_test(HAVE_FSETXATTR_5) + curl_internal_test(HAVE_FSETXATTR_6) +endif() + +cmake_push_check_state() +if(NOT WIN32) + list(APPEND CMAKE_EXTRA_INCLUDE_FILES "sys/socket.h") + check_type_size("sa_family_t" SIZEOF_SA_FAMILY_T) + set(HAVE_SA_FAMILY_T ${HAVE_SIZEOF_SA_FAMILY_T}) +endif() +cmake_pop_check_state() + +# Do curl specific tests +foreach(_curl_test IN ITEMS + HAVE_FCNTL_O_NONBLOCK + HAVE_IOCTLSOCKET + HAVE_IOCTLSOCKET_CAMEL + HAVE_IOCTLSOCKET_CAMEL_FIONBIO + HAVE_IOCTLSOCKET_FIONBIO + HAVE_IOCTL_FIONBIO + HAVE_IOCTL_SIOCGIFADDR + HAVE_SETSOCKOPT_SO_NONBLOCK + HAVE_GETHOSTBYNAME_R_3 + HAVE_GETHOSTBYNAME_R_5 + HAVE_GETHOSTBYNAME_R_6 + HAVE_BOOL_T + STDC_HEADERS + HAVE_ATOMIC +) + curl_internal_test(${_curl_test}) +endforeach() + +# Check for reentrant +cmake_push_check_state() +list(APPEND CMAKE_REQUIRED_DEFINITIONS "-D_REENTRANT") +foreach(_curl_test IN ITEMS + HAVE_GETHOSTBYNAME_R_3 + HAVE_GETHOSTBYNAME_R_5 + HAVE_GETHOSTBYNAME_R_6) + curl_internal_test(${_curl_test}_REENTRANT) + if(NOT ${_curl_test} AND ${_curl_test}_REENTRANT) + set(NEED_REENTRANT 1) + endif() +endforeach() +cmake_pop_check_state() + +if(NEED_REENTRANT) + foreach(_curl_test IN ITEMS + HAVE_GETHOSTBYNAME_R_3 + HAVE_GETHOSTBYNAME_R_5 + HAVE_GETHOSTBYNAME_R_6) + set(${_curl_test} 0) + if(${_curl_test}_REENTRANT) + set(${_curl_test} 1) + endif() + endforeach() +endif() + +cmake_push_check_state() +list(APPEND CMAKE_REQUIRED_DEFINITIONS "-D_FILE_OFFSET_BITS=64") +curl_internal_test(HAVE_FILE_OFFSET_BITS) +cmake_pop_check_state() + +cmake_push_check_state() +if(HAVE_FILE_OFFSET_BITS) + set(_FILE_OFFSET_BITS 64) + list(APPEND CMAKE_REQUIRED_DEFINITIONS "-D_FILE_OFFSET_BITS=64") +endif() +check_type_size("off_t" SIZEOF_OFF_T) + +if(NOT WIN32) + # fseeko may not exist with _FILE_OFFSET_BITS=64 but can exist with + # _FILE_OFFSET_BITS unset or 32 (as in Android ARMv7 with NDK 26b and API level < 24) + # so we need to test fseeko after testing for _FILE_OFFSET_BITS + check_symbol_exists("fseeko" "${CURL_INCLUDES};stdio.h" HAVE_FSEEKO) + + if(HAVE_FSEEKO) + set(HAVE_DECL_FSEEKO 1) + endif() +endif() + +# Include this header to get the type +cmake_push_check_state() +list(APPEND CMAKE_REQUIRED_INCLUDES "${PROJECT_SOURCE_DIR}/include") +list(APPEND CMAKE_EXTRA_INCLUDE_FILES "curl/system.h") +check_type_size("curl_off_t" SIZEOF_CURL_OFF_T) +list(APPEND CMAKE_EXTRA_INCLUDE_FILES "curl/curl.h") +check_type_size("curl_socket_t" SIZEOF_CURL_SOCKET_T) +cmake_pop_check_state() # pop curl system headers +cmake_pop_check_state() # pop -D_FILE_OFFSET_BITS=64 + +if(NOT WIN32 AND NOT CMAKE_CROSSCOMPILING) + # On non-Windows and not cross-compiling, check for writable argv[] + include(CheckCSourceRuns) + check_c_source_runs(" + int main(int argc, char **argv) + { + (void)argc; + argv[0][0] = ' '; + return (argv[0][0] == ' ') ? 0 : 1; + }" HAVE_WRITABLE_ARGV) +endif() + +if(NOT CMAKE_CROSSCOMPILING) + include(CheckCSourceRuns) + check_c_source_runs(" + #include + int main(void) { + time_t t = -1; + return t < 0; + }" HAVE_TIME_T_UNSIGNED) +endif() + +curl_internal_test(HAVE_GLIBC_STRERROR_R) +curl_internal_test(HAVE_POSIX_STRERROR_R) + +if(NOT WIN32) + curl_internal_test(HAVE_CLOCK_GETTIME_MONOTONIC) # Check clock_gettime(CLOCK_MONOTONIC, x) support +endif() + +if(APPLE) + curl_internal_test(HAVE_BUILTIN_AVAILABLE) # Check compiler support of __builtin_available() +endif() + +# Some other minor tests + +if(_cmake_try_compile_target_type_save) + set(CMAKE_TRY_COMPILE_TARGET_TYPE ${_cmake_try_compile_target_type_save}) + unset(_cmake_try_compile_target_type_save) +endif() + +include(CMake/OtherTests.cmake) + +set_property(DIRECTORY APPEND PROPERTY COMPILE_DEFINITIONS "HAVE_CONFIG_H") + +if(WIN32) + list(APPEND CURL_NETWORK_AND_TIME_LIBS "ws2_32") + if(NOT WINDOWS_STORE) + list(APPEND CURL_NETWORK_AND_TIME_LIBS "iphlpapi") # for if_nametoindex() + endif() + list(APPEND CURL_LIBS "bcrypt") # for BCryptGenRandom() + + # We use crypto functions that are not available for UWP apps + if(NOT WINDOWS_STORE) + set(USE_WIN32_CRYPTO ON) + endif() + + # Link required libraries for USE_WIN32_CRYPTO or USE_SCHANNEL + if(USE_WIN32_CRYPTO OR USE_SCHANNEL) + # for CryptAcquireContext(), CryptCreateHash(), CryptDestroyHash(), CryptGetHashParam(), CryptHashData(), + # CryptReleaseContext() in NTLM, md4, md5, sha256, Schannel + # for CryptDestroyKey(), CryptEncrypt(), CryptImportKey() in NTLM + list(APPEND CURL_LIBS "advapi32") + # for Cert*() in openssl.c Native CA, Schannel + # for CryptDecodeObjectEx(), CryptQueryObject(), CryptStringToBinary(), PFXImportCertStore() in Schannel + list(APPEND CURL_LIBS "crypt32") + endif() + if(USE_WINDOWS_SSPI) + list(APPEND CURL_LIBS "secur32") # for InitSecurityInterface() + endif() +endif() + +list(APPEND CURL_LIBS ${CURL_NETWORK_AND_TIME_LIBS}) +if(CURL_CODE_COVERAGE) + list(APPEND CURL_LIBS ${CURL_COVERAGE_LIBS}) +endif() + +# Hack to add some libraries to the end of the library list to make binutils ld +# for GCC find symbols when linking statically. Necessary for libs detected via +# CMake's built-in find modules, which CMake adds to the beginning of the lib +# list on the linker command-line for some reason. This makes them appear +# before dependencies detected via curl's custom Find modules, and breaks +# linkers sensitive to lib order. There must be a better solution to this. +# Enable the workaround for all compilers, to make it available when using GCC +# to consume libcurl, regardless of the compiler used to build libcurl itself. +if(CMAKE_C_COMPILER_ID STREQUAL "GNU") + if(USE_OPENSSL AND TARGET OpenSSL::Crypto) + add_library(CURL::OpenSSL_Crypto INTERFACE IMPORTED) + set_target_properties(CURL::OpenSSL_Crypto PROPERTIES INTERFACE_LINK_LIBRARIES OpenSSL::Crypto) + list(APPEND CURL_LIBS CURL::OpenSSL_Crypto) + endif() + if(HAVE_LIBZ AND TARGET ZLIB::ZLIB) + add_library(CURL::ZLIB INTERFACE IMPORTED) + set_target_properties(CURL::ZLIB PROPERTIES INTERFACE_LINK_LIBRARIES ZLIB::ZLIB) + list(APPEND CURL_LIBS CURL::ZLIB) + endif() + if(WIN32) + add_library(CURL::win32_winsock INTERFACE IMPORTED) + set_target_properties(CURL::win32_winsock PROPERTIES INTERFACE_LINK_LIBRARIES "ws2_32") + list(APPEND CURL_LIBS CURL::win32_winsock) + endif() +endif() + +if(CMAKE_C_COMPILER_ID STREQUAL "MSVC") # MSVC but exclude clang-cl + set_property(DIRECTORY APPEND PROPERTY COMPILE_OPTIONS "-MP") # Parallel compilation +endif() + +if(CURL_LTO) + include(CheckIPOSupported) + check_ipo_supported(RESULT CURL_HAS_LTO OUTPUT _lto_error LANGUAGES C) + if(CURL_HAS_LTO) + message(STATUS "LTO supported and enabled") + else() + message(FATAL_ERROR "LTO has been requested, but the compiler does not support it\n${_lto_error}") + endif() +endif() + +# Ugly (but functional) way to include "Makefile.inc" by transforming it +# (= regenerate it). +function(curl_transform_makefile_inc _input_file _output_file) + file(READ ${_input_file} _makefile_inc_text) + string(REPLACE "$(top_srcdir)" "\${PROJECT_SOURCE_DIR}" _makefile_inc_text ${_makefile_inc_text}) # cmake-lint: disable=W0106 + string(REPLACE "$(top_builddir)" "\${PROJECT_BINARY_DIR}" _makefile_inc_text ${_makefile_inc_text}) # cmake-lint: disable=W0106 + + string(REGEX REPLACE "\\\\\n" "!^!^!" _makefile_inc_text ${_makefile_inc_text}) + string(REGEX REPLACE "([a-zA-Z_][a-zA-Z0-9_]*)[\t ]*=[\t ]*([^\n]*)" "set(\\1 \\2)" _makefile_inc_text ${_makefile_inc_text}) + string(REPLACE "!^!^!" "\n" _makefile_inc_text ${_makefile_inc_text}) + + # Replace $() with ${} + string(REGEX REPLACE "\\$\\(([a-zA-Z_][a-zA-Z0-9_]*)\\)" "\${\\1}" _makefile_inc_text ${_makefile_inc_text}) + # Replace @@ with ${}, even if that may not be read by CMake scripts. + string(REGEX REPLACE "@([a-zA-Z_][a-zA-Z0-9_]*)@" "\${\\1}" _makefile_inc_text ${_makefile_inc_text}) + + file(WRITE ${_output_file} ${_makefile_inc_text}) + set_property(DIRECTORY APPEND PROPERTY CMAKE_CONFIGURE_DEPENDS "${_input_file}") +endfunction() + +include(GNUInstallDirs) + +set(_install_cmake_dir "${CMAKE_INSTALL_LIBDIR}/cmake/${PROJECT_NAME}") +set(TARGETS_EXPORT_NAME "${PROJECT_NAME}Targets") +set(_generated_dir "${CMAKE_CURRENT_BINARY_DIR}/generated") +set(_project_config "${_generated_dir}/${PROJECT_NAME}Config.cmake") +set(_version_config "${_generated_dir}/${PROJECT_NAME}ConfigVersion.cmake") + +option(BUILD_TESTING "Build tests" ON) +if(BUILD_TESTING AND Perl_FOUND) + set(CURL_BUILD_TESTING ON) +else() + set(CURL_BUILD_TESTING OFF) +endif() + +if(Perl_FOUND) + set(CURL_MANPAGE "${PROJECT_BINARY_DIR}/docs/cmdline-opts/curl.1") + set(CURL_ASCIIPAGE "${PROJECT_BINARY_DIR}/docs/cmdline-opts/curl.txt") + add_subdirectory(docs) +endif() + +add_subdirectory(scripts) # for shell completions + +add_subdirectory(lib) + +if(BUILD_CURL_EXE) + add_subdirectory(src) +endif() + +option(BUILD_EXAMPLES "Build libcurl examples" ON) +if(BUILD_EXAMPLES) + add_subdirectory(docs/examples) +endif() + +if(CURL_BUILD_TESTING) + add_subdirectory(tests) +endif() + +# Helper to populate a list (_items) with a label when conditions +# (the remaining args) are satisfied +macro(curl_add_if _label) + # Needs to be a macro to allow this indirection + if(${ARGN}) + list(APPEND _items "${_label}") + endif() +endmacro() + +# NTLM support requires crypto functions from various SSL libs. +# These conditions must match those in lib/curl_setup.h. +if(CURL_ENABLE_NTLM AND + ((USE_OPENSSL AND HAVE_DES_ECB_ENCRYPT) OR + (USE_MBEDTLS AND HAVE_MBEDTLS_DES_CRYPT_ECB) OR + USE_GNUTLS OR + USE_WIN32_CRYPTO OR + (USE_WOLFSSL AND HAVE_WC_DES_ECBENCRYPT))) + set(_use_curl_ntlm_core ON) +endif() + +# Clear list and try to detect available protocols +set(_items "") +curl_add_if("HTTP" NOT CURL_DISABLE_HTTP) +curl_add_if("HTTPS" NOT CURL_DISABLE_HTTP AND _ssl_enabled) +curl_add_if("FTP" NOT CURL_DISABLE_FTP) +curl_add_if("FTPS" NOT CURL_DISABLE_FTP AND _ssl_enabled) +curl_add_if("FILE" NOT CURL_DISABLE_FILE) +curl_add_if("TELNET" NOT CURL_DISABLE_TELNET) +curl_add_if("LDAP" NOT CURL_DISABLE_LDAP) +# CURL_DISABLE_LDAP implies CURL_DISABLE_LDAPS +curl_add_if("LDAPS" NOT CURL_DISABLE_LDAPS AND + ((USE_OPENLDAP AND _ssl_enabled) OR + (NOT USE_OPENLDAP AND HAVE_LDAP_SSL))) +curl_add_if("DICT" NOT CURL_DISABLE_DICT) +curl_add_if("TFTP" NOT CURL_DISABLE_TFTP) +curl_add_if("GOPHER" NOT CURL_DISABLE_GOPHER) +curl_add_if("GOPHERS" NOT CURL_DISABLE_GOPHER AND _ssl_enabled) +curl_add_if("POP3" NOT CURL_DISABLE_POP3) +curl_add_if("POP3S" NOT CURL_DISABLE_POP3 AND _ssl_enabled) +curl_add_if("IMAP" NOT CURL_DISABLE_IMAP) +curl_add_if("IMAPS" NOT CURL_DISABLE_IMAP AND _ssl_enabled) +curl_add_if("SMB" CURL_ENABLE_SMB AND + _use_curl_ntlm_core AND (SIZEOF_CURL_OFF_T GREATER 4)) +curl_add_if("SMBS" CURL_ENABLE_SMB AND _ssl_enabled AND + _use_curl_ntlm_core AND (SIZEOF_CURL_OFF_T GREATER 4)) +curl_add_if("SMTP" NOT CURL_DISABLE_SMTP) +curl_add_if("SMTPS" NOT CURL_DISABLE_SMTP AND _ssl_enabled) +curl_add_if("SCP" USE_LIBSSH2 OR USE_LIBSSH) +curl_add_if("SFTP" USE_LIBSSH2 OR USE_LIBSSH) +curl_add_if("IPFS" NOT CURL_DISABLE_IPFS) +curl_add_if("IPNS" NOT CURL_DISABLE_IPFS) +curl_add_if("RTSP" NOT CURL_DISABLE_RTSP) +curl_add_if("MQTT" NOT CURL_DISABLE_MQTT) +curl_add_if("MQTTS" NOT CURL_DISABLE_MQTT AND _ssl_enabled) +curl_add_if("WS" NOT CURL_DISABLE_WEBSOCKETS) +curl_add_if("WSS" NOT CURL_DISABLE_WEBSOCKETS AND _ssl_enabled) +if(_items) + list(SORT _items) +endif() +set(CURL_SUPPORTED_PROTOCOLS_LIST "${_items}") +string(REPLACE ";" " " SUPPORT_PROTOCOLS "${_items}") +string(TOLOWER "${SUPPORT_PROTOCOLS}" _support_protocols_lower) +message(STATUS "Protocols: ${_support_protocols_lower}") + +# Clear list and try to detect available features +set(_items "") +curl_add_if("SSL" _ssl_enabled) +curl_add_if("IPv6" USE_IPV6) +curl_add_if("UnixSockets" USE_UNIX_SOCKETS) +curl_add_if("libz" HAVE_LIBZ) +curl_add_if("brotli" HAVE_BROTLI) +curl_add_if("gsasl" USE_GSASL) +curl_add_if("zstd" HAVE_ZSTD) +curl_add_if("AsynchDNS" USE_RESOLV_ARES OR USE_RESOLV_THREADED) +curl_add_if("asyn-rr" USE_ARES AND USE_RESOLV_THREADED AND USE_HTTPSRR) +curl_add_if("IDN" (HAVE_LIBIDN2 AND HAVE_IDN2_H) OR + USE_WIN32_IDN OR + USE_APPLE_IDN) +curl_add_if("Largefile" (SIZEOF_CURL_OFF_T GREATER 4) AND ((SIZEOF_OFF_T GREATER 4) OR WIN32)) +curl_add_if("SSPI" USE_WINDOWS_SSPI) +curl_add_if("GSS-API" HAVE_GSSAPI) +curl_add_if("alt-svc" NOT CURL_DISABLE_ALTSVC) +curl_add_if("HSTS" NOT CURL_DISABLE_HSTS) +curl_add_if("SPNEGO" NOT CURL_DISABLE_NEGOTIATE_AUTH AND + (HAVE_GSSAPI OR USE_WINDOWS_SSPI)) +curl_add_if("Kerberos" NOT CURL_DISABLE_KERBEROS_AUTH AND + (HAVE_GSSAPI OR USE_WINDOWS_SSPI)) +curl_add_if("NTLM" CURL_ENABLE_NTLM AND + (_use_curl_ntlm_core OR USE_WINDOWS_SSPI)) +curl_add_if("TLS-SRP" USE_TLS_SRP) +curl_add_if("HTTP2" USE_NGHTTP2) +curl_add_if("HTTP3" USE_NGTCP2 OR USE_QUICHE) +curl_add_if("proxy-HTTP3" USE_PROXY_HTTP3) +curl_add_if("MultiSSL" CURL_WITH_MULTI_SSL) +curl_add_if("HTTPS-proxy" NOT CURL_DISABLE_PROXY AND _ssl_enabled AND (USE_OPENSSL OR USE_GNUTLS + OR USE_SCHANNEL OR USE_RUSTLS OR USE_MBEDTLS OR + (USE_WOLFSSL AND HAVE_WOLFSSL_BIO_NEW))) +curl_add_if("Unicode" ENABLE_UNICODE) +curl_add_if("threadsafe" HAVE_ATOMIC OR HAVE_THREADS_POSIX OR WIN32) +curl_add_if("Debug" ENABLE_DEBUG) +curl_add_if("ECH" _ssl_enabled AND HAVE_ECH) +curl_add_if("HTTPSRR" _ssl_enabled AND USE_HTTPSRR) +curl_add_if("PSL" USE_LIBPSL) +curl_add_if("CAcert" CURL_CA_EMBED_SET) +curl_add_if("SSLS-EXPORT" _ssl_enabled AND USE_SSLS_EXPORT) +curl_add_if("AppleSecTrust" USE_APPLE_SECTRUST AND _ssl_enabled AND (USE_OPENSSL OR USE_GNUTLS)) +curl_add_if("NativeCA" NOT USE_APPLE_SECTRUST AND _ssl_enabled AND CURL_CA_NATIVE) +if(_items) + list(SORT _items CASE INSENSITIVE) +endif() +set(CURL_SUPPORTED_FEATURES_LIST "${_items}") +string(REPLACE ";" " " SUPPORT_FEATURES "${_items}") +message(STATUS "Features: ${SUPPORT_FEATURES}") + +# Clear list and collect SSL backends +set(_items "") +curl_add_if("Schannel" _ssl_enabled AND USE_SCHANNEL) +curl_add_if("${_openssl}" _ssl_enabled AND USE_OPENSSL) +curl_add_if("mbedTLS" _ssl_enabled AND USE_MBEDTLS) +curl_add_if("wolfSSL" _ssl_enabled AND USE_WOLFSSL) +curl_add_if("GnuTLS" _ssl_enabled AND USE_GNUTLS) +curl_add_if("Rustls" _ssl_enabled AND USE_RUSTLS) + +if(_items) + list(SORT _items CASE INSENSITIVE) +endif() +string(REPLACE ";" " " SSL_BACKENDS "${_items}") +message(STATUS "Enabled SSL backends: ${SSL_BACKENDS}") +if(CURL_DEFAULT_SSL_BACKEND) + message(STATUS "Default SSL backend: ${CURL_DEFAULT_SSL_BACKEND}") +endif() + +if(NOT CURL_DISABLE_INSTALL) + + # curl-config needs the following options to be set. + set(CC "${CMAKE_C_COMPILER}") + set(CONFIGURE_OPTIONS "") + set(CURLVERSION "${_curl_version}") + set(VERSIONNUM "${_curl_version_num}") + set(prefix "${CMAKE_INSTALL_PREFIX}") + set(exec_prefix "\${prefix}") + if(IS_ABSOLUTE ${CMAKE_INSTALL_INCLUDEDIR}) + set(includedir "${CMAKE_INSTALL_INCLUDEDIR}") + else() + set(includedir "\${prefix}/${CMAKE_INSTALL_INCLUDEDIR}") + endif() + if(IS_ABSOLUTE ${CMAKE_INSTALL_LIBDIR}) + set(libdir "${CMAKE_INSTALL_LIBDIR}") + else() + set(libdir "\${exec_prefix}/${CMAKE_INSTALL_LIBDIR}") + endif() + # "a" (Linux) or "lib" (Windows) + string(REPLACE "." "" libext "${CMAKE_STATIC_LIBRARY_SUFFIX}") + + set(_ldflags "") + set(LIBCURL_PC_LIBS_PRIVATE "") + + # Filter CMAKE_SHARED_LINKER_FLAGS for libs and libpaths + string(STRIP "${CMAKE_SHARED_LINKER_FLAGS}" _custom_ldflags) + string(REGEX REPLACE " +-([^ \\t;]*)" ";-\\1" _custom_ldflags "${_custom_ldflags}") + + set(_custom_libs "") + set(_custom_libdirs "") + foreach(_flag IN LISTS _custom_ldflags) + if(_flag MATCHES "^-l") + string(REGEX REPLACE "^-l" "" _flag "${_flag}") + list(APPEND _custom_libs "${_flag}") + elseif(_flag MATCHES "^-framework|^-F") + list(APPEND _custom_libs "${_flag}") + elseif(_flag MATCHES "^-L") + string(REGEX REPLACE "^-L" "" _flag "${_flag}") + list(APPEND _custom_libdirs "${_flag}") + elseif(_flag MATCHES "^--library-path=") + string(REGEX REPLACE "^--library-path=" "" _flag "${_flag}") + list(APPEND _custom_libdirs "${_flag}") + endif() + endforeach() + + # Avoid getting unnecessary -L options for known system directories. + set(_sys_libdirs "${CMAKE_C_IMPLICIT_LINK_DIRECTORIES}") + foreach(_libdir IN LISTS CMAKE_SYSTEM_PREFIX_PATH) + if(_libdir MATCHES "/$") + string(APPEND _libdir "lib") + else() + string(APPEND _libdir "/lib") + endif() + if(IS_DIRECTORY "${_libdir}") + list(APPEND _sys_libdirs "${_libdir}") + endif() + if(DEFINED CMAKE_LIBRARY_ARCHITECTURE) + string(APPEND _libdir "/${CMAKE_LIBRARY_ARCHITECTURE}") + if(IS_DIRECTORY "${_libdir}") + list(APPEND _sys_libdirs "${_libdir}") + endif() + endif() + endforeach() + + set(_implicit_libs "") + if(NOT MINGW AND NOT UNIX) + set(_implicit_libs "${CMAKE_C_IMPLICIT_LINK_LIBRARIES}") + endif() + + set(_explicit_libdirs "") + set(LIBCURL_PC_REQUIRES_PRIVATE "") + set(LIBCURL_PC_LIBS_PRIVATE_LIST "") + foreach(_lib IN LISTS CURL_LIBS _custom_libs _implicit_libs) + if(TARGET "${_lib}") + set(_explicit_libs "") + get_target_property(_imported "${_lib}" IMPORTED) + if(NOT _imported) + # Reading the LOCATION property on non-imported target errors out. + # Assume the user does not need this information in the .pc file. + continue() + endif() + set(_libdirs "") + set(_libs "") + curl_collect_target_link_options("${_lib}") # look into the target recursively + list(APPEND _explicit_libdirs ${_libdirs}) + list(APPEND _explicit_libs ${_libs}) + if(NOT _libs AND NOT _libdirs AND NOT _lib STREQUAL Threads::Threads) + message(WARNING "Bad lib in library list: ${_lib}") + endif() + if(_lib STREQUAL OpenSSL::SSL AND NOT HAVE_BORINGSSL) # BoringSSL does not provide openssl.pc + set(_modules "openssl") + elseif(_lib STREQUAL ZLIB::ZLIB AND NOT ANDROID) # Android does not provide zlib.pc + set(_modules "zlib") + else() + get_target_property(_modules "${_lib}" INTERFACE_LIBCURL_PC_MODULES) + endif() + if(_modules) + list(APPEND LIBCURL_PC_REQUIRES_PRIVATE "${_modules}") + endif() + + foreach(_lib IN LISTS _explicit_libs) + if(_lib MATCHES "/") + # This gets a bit more complex, because we want to specify the + # directory separately, and only once per directory + if(CMAKE_VERSION VERSION_GREATER_EQUAL 3.20) + cmake_path(GET _lib PARENT_PATH _libdir) + cmake_path(GET _lib STEM _libname) + else() + get_filename_component(_libdir "${_lib}" DIRECTORY) + get_filename_component(_libname "${_lib}" NAME_WE) + endif() + if(_libname MATCHES "^lib") + if(CMAKE_VERSION VERSION_GREATER_EQUAL 3.20) + cmake_path(SET _libdir NORMALIZE "${_libdir}") + endif() + if(NOT _libdir IN_LIST _sys_libdirs) + list(APPEND _ldflags "-L${_libdir}") + endif() + string(REGEX REPLACE "^lib" "" _libname "${_libname}") + list(APPEND LIBCURL_PC_LIBS_PRIVATE "-l${_libname}") + list(APPEND LIBCURL_PC_LIBS_PRIVATE_LIST "${_lib}") + else() + list(APPEND LIBCURL_PC_LIBS_PRIVATE "${_lib}") + list(APPEND LIBCURL_PC_LIBS_PRIVATE_LIST "${_lib}") + endif() + elseif(_lib MATCHES "^-") # '-option' + list(APPEND _ldflags "${_lib}") + list(APPEND LIBCURL_PC_LIBS_PRIVATE_LIST "${_lib}") + else() + list(APPEND LIBCURL_PC_LIBS_PRIVATE "-l${_lib}") + list(APPEND LIBCURL_PC_LIBS_PRIVATE_LIST "${_lib}") + endif() + endforeach() + elseif(_lib MATCHES "^-") # '-framework ' + list(APPEND _ldflags "${_lib}") + list(APPEND LIBCURL_PC_LIBS_PRIVATE_LIST "${_lib}") + else() + list(APPEND LIBCURL_PC_LIBS_PRIVATE "-l${_lib}") + list(APPEND LIBCURL_PC_LIBS_PRIVATE_LIST "${_lib}") + endif() + endforeach() + + foreach(_libdir IN LISTS _custom_libdirs _explicit_libdirs) + if(CMAKE_VERSION VERSION_GREATER_EQUAL 3.20) + cmake_path(SET _libdir NORMALIZE "${_libdir}") + endif() + if(NOT _libdir IN_LIST _sys_libdirs) + list(APPEND _ldflags "-L${_libdir}") + endif() + endforeach() + + list(REMOVE_DUPLICATES _ldflags) + + if(LIBCURL_PC_REQUIRES_PRIVATE) + list(REMOVE_DUPLICATES LIBCURL_PC_REQUIRES_PRIVATE) + string(REPLACE ";" "," LIBCURL_PC_REQUIRES_PRIVATE "${LIBCURL_PC_REQUIRES_PRIVATE}") + endif() + if(LIBCURL_PC_LIBS_PRIVATE) + # Remove duplicates listed next to each other + set(_libs "") + set(_prev "") + foreach(_lib IN LISTS LIBCURL_PC_LIBS_PRIVATE) + if(NOT _prev STREQUAL _lib) + list(APPEND _libs "${_lib}") + set(_prev "${_lib}") + endif() + endforeach() + set(LIBCURL_PC_LIBS_PRIVATE "${_libs}") + + string(REPLACE ";" " " LIBCURL_PC_LIBS_PRIVATE "${LIBCURL_PC_LIBS_PRIVATE}") + endif() + if(_ldflags) + list(REMOVE_DUPLICATES _ldflags) + string(REPLACE ";" " " _ldflags "${_ldflags}") + set(LIBCURL_PC_LDFLAGS_PRIVATE "${_ldflags}") + string(STRIP "${LIBCURL_PC_LDFLAGS_PRIVATE}" LIBCURL_PC_LDFLAGS_PRIVATE) + else() + set(LIBCURL_PC_LDFLAGS_PRIVATE "") + endif() + set(LIBCURL_PC_CFLAGS_PRIVATE "-DCURL_STATICLIB") + + # Merge pkg-config private fields into public ones when static-only + if(BUILD_SHARED_LIBS) + set(ENABLE_SHARED "yes") + set(LIBCURL_PC_REQUIRES "") + set(LIBCURL_PC_LIBS "") + set(LIBCURL_PC_CFLAGS "") + else() + set(ENABLE_SHARED "no") + set(LIBCURL_PC_REQUIRES "${LIBCURL_PC_REQUIRES_PRIVATE}") + set(LIBCURL_PC_LIBS "${LIBCURL_PC_LIBS_PRIVATE}") + set(LIBCURL_PC_CFLAGS "${LIBCURL_PC_CFLAGS_PRIVATE}") + endif() + if(BUILD_STATIC_LIBS) + set(ENABLE_STATIC "yes") + else() + set(ENABLE_STATIC "no") + endif() + + # Generate a "curl-config" matching this config. + # Consumed variables: + # CC + # CONFIGURE_OPTIONS + # CURLVERSION + # CURL_CA_BUNDLE + # ENABLE_SHARED + # ENABLE_STATIC + # exec_prefix + # includedir + # LIBCURL_PC_CFLAGS + # LIBCURL_PC_LDFLAGS_PRIVATE + # LIBCURL_PC_LIBS_PRIVATE + # libdir + # libext + # prefix + # SSL_BACKENDS + # SUPPORT_FEATURES + # SUPPORT_PROTOCOLS + # VERSIONNUM + configure_file( + "${PROJECT_SOURCE_DIR}/curl-config.in" + "${PROJECT_BINARY_DIR}/curl-config" @ONLY) + install(FILES "${PROJECT_BINARY_DIR}/curl-config" + DESTINATION ${CMAKE_INSTALL_BINDIR} + PERMISSIONS + OWNER_READ OWNER_WRITE OWNER_EXECUTE + GROUP_READ GROUP_EXECUTE + WORLD_READ WORLD_EXECUTE) + + # Generate a pkg-config file matching this config. + # Consumed variables: + # CURLVERSION + # exec_prefix + # includedir + # LIBCURL_PC_CFLAGS + # LIBCURL_PC_CFLAGS_PRIVATE + # LIBCURL_PC_LDFLAGS_PRIVATE + # LIBCURL_PC_LIBS + # LIBCURL_PC_LIBS_PRIVATE + # LIBCURL_PC_REQUIRES + # LIBCURL_PC_REQUIRES_PRIVATE + # libdir + # prefix + # SUPPORT_FEATURES + # SUPPORT_PROTOCOLS + # Documentation: + # https://people.freedesktop.org/~dbn/pkg-config-guide.html + # https://manpages.debian.org/unstable/pkgconf/pkg-config.1.en.html + # https://manpages.debian.org/unstable/pkg-config/pkg-config.1.en.html + # https://www.msys2.org/docs/pkgconfig/ + configure_file( + "${PROJECT_SOURCE_DIR}/libcurl.pc.in" + "${PROJECT_BINARY_DIR}/libcurl.pc" @ONLY) + install(FILES "${PROJECT_BINARY_DIR}/libcurl.pc" + DESTINATION "${CMAKE_INSTALL_LIBDIR}/pkgconfig") + + # Install headers + install(DIRECTORY "${PROJECT_SOURCE_DIR}/include/curl" + DESTINATION ${CMAKE_INSTALL_INCLUDEDIR} + FILES_MATCHING PATTERN "*.h") + + include(CMakePackageConfigHelpers) + write_basic_package_version_file("${_version_config}" + VERSION ${_curl_version} + COMPATIBILITY SameMajorVersion) + file(READ "${_version_config}" _generated_version_config) + file(WRITE "${_version_config}" " + if(NOT PACKAGE_FIND_VERSION_RANGE AND PACKAGE_FIND_VERSION_MAJOR STREQUAL \"7\") + # Version 8 satisfies version 7... requirements + set(PACKAGE_FIND_VERSION_MAJOR 8) + set(PACKAGE_FIND_VERSION_COUNT 1) + endif() + ${_generated_version_config}") + + # Consumed custom variables: + # CMAKE_MINIMUM_REQUIRED_VERSION + # CURLVERSION + # LIBCURL_PC_LIBS_PRIVATE_LIST + # LIB_NAME + # LIB_SELECTED + # LIB_STATIC + # TARGETS_EXPORT_NAME + # CURL_SUPPORTED_FEATURES_LIST + # CURL_SUPPORTED_PROTOCOLS_LIST + # CURL_USE_CMAKECONFIG + # CURL_USE_PKGCONFIG + # HAVE_BROTLI + # HAVE_GSSAPI + # HAVE_LIBIDN2 + # HAVE_LIBZ ZLIB_VERSION_MAJOR + # HAVE_THREADS_POSIX + # HAVE_THREADS_POSIX_BORINGSSL + # HAVE_ZSTD + # USE_ARES + # USE_BACKTRACE + # USE_GNUTLS + # USE_GSASL + # USE_LIBPSL + # USE_LIBSSH + # USE_LIBSSH2 + # USE_LIBUV + # USE_MBEDTLS + # USE_NGHTTP2 + # USE_NGHTTP3 + # USE_NGTCP2 NGTCP2_CRYPTO_BACKEND + # USE_OPENSSL OPENSSL_VERSION_MAJOR + # USE_QUICHE + # USE_RUSTLS + # USE_WIN32_LDAP CURL_DISABLE_LDAP + # USE_WOLFSSL + configure_package_config_file("CMake/curl-config.in.cmake" + "${_project_config}" + INSTALL_DESTINATION ${_install_cmake_dir} + PATH_VARS CMAKE_INSTALL_INCLUDEDIR) + + if(CURL_ENABLE_EXPORT_TARGET) + install(EXPORT "${TARGETS_EXPORT_NAME}" + NAMESPACE "${PROJECT_NAME}::" + DESTINATION ${_install_cmake_dir}) + endif() + + install( + FILES + ${_version_config} + ${_project_config} + "${CMAKE_CURRENT_SOURCE_DIR}/CMake/FindBrotli.cmake" + "${CMAKE_CURRENT_SOURCE_DIR}/CMake/FindCares.cmake" + "${CMAKE_CURRENT_SOURCE_DIR}/CMake/FindGSS.cmake" + "${CMAKE_CURRENT_SOURCE_DIR}/CMake/FindGnuTLS.cmake" + "${CMAKE_CURRENT_SOURCE_DIR}/CMake/FindLDAP.cmake" + "${CMAKE_CURRENT_SOURCE_DIR}/CMake/FindLibbacktrace.cmake" + "${CMAKE_CURRENT_SOURCE_DIR}/CMake/FindLibgsasl.cmake" + "${CMAKE_CURRENT_SOURCE_DIR}/CMake/FindLibidn2.cmake" + "${CMAKE_CURRENT_SOURCE_DIR}/CMake/FindLibpsl.cmake" + "${CMAKE_CURRENT_SOURCE_DIR}/CMake/FindLibssh.cmake" + "${CMAKE_CURRENT_SOURCE_DIR}/CMake/FindLibssh2.cmake" + "${CMAKE_CURRENT_SOURCE_DIR}/CMake/FindLibuv.cmake" + "${CMAKE_CURRENT_SOURCE_DIR}/CMake/FindMbedTLS.cmake" + "${CMAKE_CURRENT_SOURCE_DIR}/CMake/FindNGHTTP2.cmake" + "${CMAKE_CURRENT_SOURCE_DIR}/CMake/FindNGHTTP3.cmake" + "${CMAKE_CURRENT_SOURCE_DIR}/CMake/FindNGTCP2.cmake" + "${CMAKE_CURRENT_SOURCE_DIR}/CMake/FindNettle.cmake" + "${CMAKE_CURRENT_SOURCE_DIR}/CMake/FindQuiche.cmake" + "${CMAKE_CURRENT_SOURCE_DIR}/CMake/FindRustls.cmake" + "${CMAKE_CURRENT_SOURCE_DIR}/CMake/FindWolfSSL.cmake" + "${CMAKE_CURRENT_SOURCE_DIR}/CMake/FindZstd.cmake" + DESTINATION ${_install_cmake_dir}) + + if(NOT TARGET curl_uninstall) + configure_file( + "${CMAKE_CURRENT_SOURCE_DIR}/CMake/cmake_uninstall.in.cmake" + "${CMAKE_CURRENT_BINARY_DIR}/CMake/cmake_uninstall.cmake" + @ONLY) + + add_custom_target(curl_uninstall + COMMAND ${CMAKE_COMMAND} -P "${CMAKE_CURRENT_BINARY_DIR}/CMake/cmake_uninstall.cmake") + endif() + + if(BUILD_CURL_EXE) + install(FILES "${PROJECT_SOURCE_DIR}/scripts/wcurl" + DESTINATION ${CMAKE_INSTALL_BINDIR} + PERMISSIONS + OWNER_READ OWNER_WRITE OWNER_EXECUTE + GROUP_READ GROUP_EXECUTE + WORLD_READ WORLD_EXECUTE) + endif() + + # The `-DEV` part is important + string(REGEX REPLACE "([0-9]+\.[0-9]+)\.([0-9]+.*)" "\\2" CPACK_PACKAGE_VERSION_PATCH "${_curl_version}") + set(CPACK_GENERATOR "TGZ") + include(CPack) +endif() + +# Save build info for test runner to pick up and log +set(_cmake_sysroot "") +if(CMAKE_OSX_SYSROOT) + set(_cmake_sysroot ${CMAKE_OSX_SYSROOT}) +elseif(CMAKE_SYSROOT) + set(_cmake_sysroot ${CMAKE_SYSROOT}) +endif() +set(_buildinfo "\ +buildinfo.configure.tool: cmake +buildinfo.configure.command: ${CMAKE_COMMAND} +buildinfo.configure.version: ${CMAKE_VERSION} +buildinfo.configure.args:${_cmake_args} +buildinfo.configure.generator: ${CMAKE_GENERATOR} +buildinfo.configure.make: ${CMAKE_MAKE_PROGRAM} +buildinfo.host.cpu: ${CMAKE_HOST_SYSTEM_PROCESSOR} +buildinfo.host.os: ${CMAKE_HOST_SYSTEM_NAME} +buildinfo.target.cpu: ${CMAKE_SYSTEM_PROCESSOR} +buildinfo.target.os: ${CMAKE_SYSTEM_NAME} +buildinfo.target.flags:${_target_flags} +buildinfo.compiler: ${CMAKE_C_COMPILER_ID} +buildinfo.compiler.version: ${CMAKE_C_COMPILER_VERSION} +buildinfo.sysroot: ${_cmake_sysroot} +") +file(WRITE "${PROJECT_BINARY_DIR}/buildinfo.txt" "# This is a generated file. Do not edit.\n${_buildinfo}") +if(NOT "$ENV{CURL_BUILDINFO}$ENV{CURL_CI}$ENV{CI}" STREQUAL "") + message(STATUS "\n${_buildinfo}") +endif() diff --git a/3rdparty/curl-8.21.0/COPYING b/3rdparty/curl-8.21.0/COPYING new file mode 100644 index 0000000000..2f71d999a9 --- /dev/null +++ b/3rdparty/curl-8.21.0/COPYING @@ -0,0 +1,22 @@ +COPYRIGHT AND PERMISSION NOTICE + +Copyright (c) 1996 - 2026, Daniel Stenberg, , and many +contributors, see the THANKS file. + +All rights reserved. + +Permission to use, copy, modify, and distribute this software for any purpose +with or without fee is hereby granted, provided that the above copyright +notice and this permission notice appear in all copies. + +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 OF THIRD PARTY RIGHTS. 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. + +Except as contained in this notice, the name of a copyright holder shall not +be used in advertising or otherwise to promote the sale, use or other dealings +in this Software without prior written authorization of the copyright holder. diff --git a/3rdparty/curl-8.21.0/Dockerfile b/3rdparty/curl-8.21.0/Dockerfile new file mode 100644 index 0000000000..369583f62f --- /dev/null +++ b/3rdparty/curl-8.21.0/Dockerfile @@ -0,0 +1,41 @@ +# Copyright (C) Daniel Stenberg, , et al. +# +# SPDX-License-Identifier: curl + +# Self-contained build environment to match the release environment. +# +# Build and set the timestamp for the date corresponding to the release +# +# docker build --build-arg SOURCE_DATE_EPOCH=1711526400 --build-arg UID=$(id -u) --build-arg GID=$(id -g) -t curl/curl . +# +# Then run commands from within the build environment, for example +# +# docker run --rm -it -u $(id -u):$(id -g) -v $(pwd):/usr/src -w /usr/src curl/curl autoreconf -fi +# docker run --rm -it -u $(id -u):$(id -g) -v $(pwd):/usr/src -w /usr/src curl/curl ./configure --without-ssl --without-libpsl +# docker run --rm -it -u $(id -u):$(id -g) -v $(pwd):/usr/src -w /usr/src curl/curl make +# docker run --rm -it -u $(id -u):$(id -g) -v $(pwd):/usr/src -w /usr/src curl/curl ./scripts/maketgz 8.7.1 +# +# or get into a shell in the build environment, for example +# +# docker run --rm -it -u $(id -u):$(id -g) -v $(pwd):/usr/src -w /usr/src curl/curl bash +# $ autoreconf -fi +# $ ./configure --without-ssl --without-libpsl +# $ make +# $ ./scripts/maketgz 8.7.1 + +# To update, get the latest digest e.g. from https://hub.docker.com/_/debian/tags +FROM debian:bookworm-slim@sha256:96e378d7e6531ac9a15ad505478fcc2e69f371b10f5cdf87857c4b8188404716 + +RUN apt-get update -qq && apt-get install -qq -y --no-install-recommends \ + build-essential make autoconf automake libtool git perl zip zlib1g-dev gawk && \ + rm -rf /var/lib/apt/lists/* + +ARG UID=1000 GID=1000 + +RUN groupadd --gid $GID dev && \ + useradd --uid $UID --gid dev --shell /bin/bash --create-home dev + +USER dev:dev + +ARG SOURCE_DATE_EPOCH +ENV SOURCE_DATE_EPOCH=${SOURCE_DATE_EPOCH:-1} diff --git a/3rdparty/curl-8.21.0/Makefile.am b/3rdparty/curl-8.21.0/Makefile.am new file mode 100644 index 0000000000..83fdadf035 --- /dev/null +++ b/3rdparty/curl-8.21.0/Makefile.am @@ -0,0 +1,185 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### + +AUTOMAKE_OPTIONS = foreign + +ACLOCAL_AMFLAGS = -I m4 + +CMAKE_DIST = \ + CMake/cmake_uninstall.in.cmake \ + CMake/curl-config.in.cmake \ + CMake/CurlSymbolHiding.cmake \ + CMake/CurlTests.c \ + CMake/FindBrotli.cmake \ + CMake/FindCares.cmake \ + CMake/FindGnuTLS.cmake \ + CMake/FindGSS.cmake \ + CMake/FindLDAP.cmake \ + CMake/FindLibbacktrace.cmake \ + CMake/FindLibgsasl.cmake \ + CMake/FindLibidn2.cmake \ + CMake/FindLibpsl.cmake \ + CMake/FindLibssh.cmake \ + CMake/FindLibssh2.cmake \ + CMake/FindLibuv.cmake \ + CMake/FindMbedTLS.cmake \ + CMake/FindNGHTTP2.cmake \ + CMake/FindNGHTTP3.cmake \ + CMake/FindNGTCP2.cmake \ + CMake/FindNettle.cmake \ + CMake/FindQuiche.cmake \ + CMake/FindRustls.cmake \ + CMake/FindWolfSSL.cmake \ + CMake/FindZstd.cmake \ + CMake/Macros.cmake \ + CMake/OtherTests.cmake \ + CMake/PickyWarnings.cmake \ + CMake/Utilities.cmake \ + CMake/unix-cache.cmake \ + CMake/win32-cache.cmake \ + CMakeLists.txt \ + tests/cmake/CMakeLists.txt \ + tests/cmake/test.c \ + tests/cmake/test.cpp \ + tests/cmake/test.sh + +EXTRA_DIST = CHANGES.md COPYING RELEASE-NOTES Dockerfile .clang-tidy.yml .editorconfig $(CMAKE_DIST) + +DISTCLEANFILES = buildinfo.txt + +bin_SCRIPTS = curl-config + +SUBDIRS = lib docs src scripts +DIST_SUBDIRS = $(SUBDIRS) tests projects include docs + +pkgconfigdir = $(libdir)/pkgconfig +pkgconfig_DATA = libcurl.pc + +dist-hook: + rm -rf $(top_builddir)/tests/log + find $(distdir) -name "*.dist" -exec rm -- {} \; + (distit=`find $(srcdir) -name "*.dist" | grep -v Makefile`; \ + for file in $$distit; do \ + strip=`echo $$file | sed -e s/^$(srcdir)// -e s/\.dist//`; \ + cp -p $$file $(distdir)$$strip; \ + done) + +check: test examples check-docs + +if CROSSCOMPILING +test-full: test +test-nonflaky: test +test-torture: test +test-event: test +test-am: test +test-ci: test +pytest: test +pytest-ci: test + +test: + @echo "NOTICE: we cannot run the tests when cross-compiling!" + +else + +test: + @(cd tests; $(MAKE) all quiet-test) + +test-full: + @(cd tests; $(MAKE) all full-test) + +test-nonflaky: + @(cd tests; $(MAKE) all nonflaky-test) + +test-torture: + @(cd tests; $(MAKE) all torture-test) + +test-event: + @(cd tests; $(MAKE) all event-test) + +test-am: + @(cd tests; $(MAKE) all am-test) + +test-ci: + @(cd tests; $(MAKE) all ci-test) + +pytest: + @(cd tests; $(MAKE) all default-pytest) + +pytest-ci: + @(cd tests; $(MAKE) all ci-pytest) + +endif + +examples: + @(cd docs/examples; $(MAKE) check) + +check-docs: + @(cd docs/libcurl; $(MAKE) check) + +# We extend the standard install with a custom hook: +if BUILD_DOCS +install-data-hook: + (cd include && $(MAKE) install) + (cd docs && $(MAKE) install) + (cd docs/libcurl && $(MAKE) install) +else +install-data-hook: + (cd include && $(MAKE) install) + (cd docs && $(MAKE) install) +endif + +# We extend the standard uninstall with a custom hook: +uninstall-hook: + (cd include && $(MAKE) uninstall) + (cd docs && $(MAKE) uninstall) + (cd docs/libcurl && $(MAKE) uninstall) + +ca-bundle: $(srcdir)/scripts/mk-ca-bundle.pl + @echo "generating a fresh ca-bundle.crt" + @perl $(srcdir)/scripts/mk-ca-bundle.pl -b -l -u lib/ca-bundle.crt + +ca-firefox: $(srcdir)/scripts/firefox-db2pem.sh + @echo "generating a fresh ca-bundle.crt" + $(srcdir)/scripts/firefox-db2pem.sh lib/ca-bundle.crt + +checksrc: + (cd lib && $(MAKE) checksrc) + (cd src && $(MAKE) checksrc) + (cd tests && $(MAKE) checksrc) + (cd include/curl && $(MAKE) checksrc) + (cd docs/examples && $(MAKE) checksrc) + (cd projects && $(MAKE) checksrc) + +badwords: + @PERL@ $(top_srcdir)/scripts/badwords-all + +lint: badwords checksrc + @PERL@ $(top_srcdir)/scripts/spacecheck.pl + +tidy: + (cd src && $(MAKE) tidy) + (cd lib && $(MAKE) tidy) + +clean-local: + (cd tests && $(MAKE) clean) diff --git a/3rdparty/curl-8.21.0/Makefile.in b/3rdparty/curl-8.21.0/Makefile.in new file mode 100644 index 0000000000..d7f5081d76 --- /dev/null +++ b/3rdparty/curl-8.21.0/Makefile.in @@ -0,0 +1,1144 @@ +# Makefile.in generated by automake 1.16.5 from Makefile.am. +# @configure_input@ + +# Copyright (C) 1994-2021 Free Software Foundation, Inc. + +# This Makefile.in is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY, to the extent permitted by law; without +# even the implied warranty of MERCHANTABILITY or FITNESS FOR A +# PARTICULAR PURPOSE. + +@SET_MAKE@ + +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### + + +VPATH = @srcdir@ +am__is_gnu_make = { \ + if test -z '$(MAKELEVEL)'; then \ + false; \ + elif test -n '$(MAKE_HOST)'; then \ + true; \ + elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \ + true; \ + else \ + false; \ + fi; \ +} +am__make_running_with_option = \ + case $${target_option-} in \ + ?) ;; \ + *) echo "am__make_running_with_option: internal error: invalid" \ + "target option '$${target_option-}' specified" >&2; \ + exit 1;; \ + esac; \ + has_opt=no; \ + sane_makeflags=$$MAKEFLAGS; \ + if $(am__is_gnu_make); then \ + sane_makeflags=$$MFLAGS; \ + else \ + case $$MAKEFLAGS in \ + *\\[\ \ ]*) \ + bs=\\; \ + sane_makeflags=`printf '%s\n' "$$MAKEFLAGS" \ + | sed "s/$$bs$$bs[$$bs $$bs ]*//g"`;; \ + esac; \ + fi; \ + skip_next=no; \ + strip_trailopt () \ + { \ + flg=`printf '%s\n' "$$flg" | sed "s/$$1.*$$//"`; \ + }; \ + for flg in $$sane_makeflags; do \ + test $$skip_next = yes && { skip_next=no; continue; }; \ + case $$flg in \ + *=*|--*) continue;; \ + -*I) strip_trailopt 'I'; skip_next=yes;; \ + -*I?*) strip_trailopt 'I';; \ + -*O) strip_trailopt 'O'; skip_next=yes;; \ + -*O?*) strip_trailopt 'O';; \ + -*l) strip_trailopt 'l'; skip_next=yes;; \ + -*l?*) strip_trailopt 'l';; \ + -[dEDm]) skip_next=yes;; \ + -[JT]) skip_next=yes;; \ + esac; \ + case $$flg in \ + *$$target_option*) has_opt=yes; break;; \ + esac; \ + done; \ + test $$has_opt = yes +am__make_dryrun = (target_option=n; $(am__make_running_with_option)) +am__make_keepgoing = (target_option=k; $(am__make_running_with_option)) +pkgdatadir = $(datadir)/@PACKAGE@ +pkgincludedir = $(includedir)/@PACKAGE@ +pkglibdir = $(libdir)/@PACKAGE@ +pkglibexecdir = $(libexecdir)/@PACKAGE@ +am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd +install_sh_DATA = $(install_sh) -c -m 644 +install_sh_PROGRAM = $(install_sh) -c +install_sh_SCRIPT = $(install_sh) -c +INSTALL_HEADER = $(INSTALL_DATA) +transform = $(program_transform_name) +NORMAL_INSTALL = : +PRE_INSTALL = : +POST_INSTALL = : +NORMAL_UNINSTALL = : +PRE_UNINSTALL = : +POST_UNINSTALL = : +build_triplet = @build@ +host_triplet = @host@ +subdir = . +ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 +am__aclocal_m4_deps = $(top_srcdir)/m4/curl-amissl.m4 \ + $(top_srcdir)/m4/curl-apple-sectrust.m4 \ + $(top_srcdir)/m4/curl-compilers.m4 \ + $(top_srcdir)/m4/curl-confopts.m4 \ + $(top_srcdir)/m4/curl-functions.m4 \ + $(top_srcdir)/m4/curl-gnutls.m4 \ + $(top_srcdir)/m4/curl-mbedtls.m4 \ + $(top_srcdir)/m4/curl-openssl.m4 \ + $(top_srcdir)/m4/curl-override.m4 \ + $(top_srcdir)/m4/curl-reentrant.m4 \ + $(top_srcdir)/m4/curl-rustls.m4 \ + $(top_srcdir)/m4/curl-schannel.m4 \ + $(top_srcdir)/m4/curl-sysconfig.m4 \ + $(top_srcdir)/m4/curl-wolfssl.m4 $(top_srcdir)/m4/libtool.m4 \ + $(top_srcdir)/m4/ltoptions.m4 $(top_srcdir)/m4/ltsugar.m4 \ + $(top_srcdir)/m4/ltversion.m4 $(top_srcdir)/m4/lt~obsolete.m4 \ + $(top_srcdir)/m4/xc-am-iface.m4 \ + $(top_srcdir)/m4/xc-cc-check.m4 \ + $(top_srcdir)/m4/xc-lt-iface.m4 \ + $(top_srcdir)/m4/xc-val-flgs.m4 \ + $(top_srcdir)/m4/zz40-xc-ovr.m4 \ + $(top_srcdir)/m4/zz50-xc-ovr.m4 $(top_srcdir)/acinclude.m4 \ + $(top_srcdir)/configure.ac +am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ + $(ACLOCAL_M4) +DIST_COMMON = $(srcdir)/Makefile.am $(top_srcdir)/configure \ + $(am__configure_deps) $(am__DIST_COMMON) +am__CONFIG_DISTCLEAN_FILES = config.status config.cache config.log \ + configure.lineno config.status.lineno +mkinstalldirs = $(install_sh) -d +CONFIG_HEADER = $(top_builddir)/lib/curl_config.h +CONFIG_CLEAN_FILES = libcurl.pc curl-config +CONFIG_CLEAN_VPATH_FILES = +am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; +am__vpath_adj = case $$p in \ + $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \ + *) f=$$p;; \ + esac; +am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`; +am__install_max = 40 +am__nobase_strip_setup = \ + srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'` +am__nobase_strip = \ + for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||" +am__nobase_list = $(am__nobase_strip_setup); \ + for p in $$list; do echo "$$p $$p"; done | \ + sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \ + $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \ + if (++n[$$2] == $(am__install_max)) \ + { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \ + END { for (dir in files) print dir, files[dir] }' +am__base_list = \ + sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \ + sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g' +am__uninstall_files_from_dir = { \ + test -z "$$files" \ + || { test ! -d "$$dir" && test ! -f "$$dir" && test ! -r "$$dir"; } \ + || { echo " ( cd '$$dir' && rm -f" $$files ")"; \ + $(am__cd) "$$dir" && rm -f $$files; }; \ + } +am__installdirs = "$(DESTDIR)$(bindir)" "$(DESTDIR)$(pkgconfigdir)" +SCRIPTS = $(bin_SCRIPTS) +AM_V_P = $(am__v_P_@AM_V@) +am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) +am__v_P_0 = false +am__v_P_1 = : +AM_V_GEN = $(am__v_GEN_@AM_V@) +am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@) +am__v_GEN_0 = @echo " GEN " $@; +am__v_GEN_1 = +AM_V_at = $(am__v_at_@AM_V@) +am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) +am__v_at_0 = @ +am__v_at_1 = +SOURCES = +DIST_SOURCES = +RECURSIVE_TARGETS = all-recursive check-recursive cscopelist-recursive \ + ctags-recursive dvi-recursive html-recursive info-recursive \ + install-data-recursive install-dvi-recursive \ + install-exec-recursive install-html-recursive \ + install-info-recursive install-pdf-recursive \ + install-ps-recursive install-recursive installcheck-recursive \ + installdirs-recursive pdf-recursive ps-recursive \ + tags-recursive uninstall-recursive +am__can_run_installinfo = \ + case $$AM_UPDATE_INFO_DIR in \ + n|no|NO) false;; \ + *) (install-info --version) >/dev/null 2>&1;; \ + esac +DATA = $(pkgconfig_DATA) +RECURSIVE_CLEAN_TARGETS = mostlyclean-recursive clean-recursive \ + distclean-recursive maintainer-clean-recursive +am__recursive_targets = \ + $(RECURSIVE_TARGETS) \ + $(RECURSIVE_CLEAN_TARGETS) \ + $(am__extra_recursive_targets) +AM_RECURSIVE_TARGETS = $(am__recursive_targets:-recursive=) TAGS CTAGS \ + cscope distdir distdir-am dist dist-all distcheck +am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) $(LISP) +# Read a list of newline-separated strings from the standard input, +# and print each of them once, without duplicates. Input order is +# *not* preserved. +am__uniquify_input = $(AWK) '\ + BEGIN { nonempty = 0; } \ + { items[$$0] = 1; nonempty = 1; } \ + END { if (nonempty) { for (i in items) print i; }; } \ +' +# Make sure the list of sources is unique. This is necessary because, +# e.g., the same source file might be shared among _SOURCES variables +# for different programs/libraries. +am__define_uniq_tagged_files = \ + list='$(am__tagged_files)'; \ + unique=`for i in $$list; do \ + if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ + done | $(am__uniquify_input)` +am__DIST_COMMON = $(srcdir)/Makefile.in $(srcdir)/curl-config.in \ + $(srcdir)/libcurl.pc.in COPYING README compile config.guess \ + config.sub depcomp install-sh ltmain.sh missing +DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) +distdir = $(PACKAGE)-$(VERSION) +top_distdir = $(distdir) +am__remove_distdir = \ + if test -d "$(distdir)"; then \ + find "$(distdir)" -type d ! -perm -200 -exec chmod u+w {} ';' \ + && rm -rf "$(distdir)" \ + || { sleep 5 && rm -rf "$(distdir)"; }; \ + else :; fi +am__post_remove_distdir = $(am__remove_distdir) +am__relativize = \ + dir0=`pwd`; \ + sed_first='s,^\([^/]*\)/.*$$,\1,'; \ + sed_rest='s,^[^/]*/*,,'; \ + sed_last='s,^.*/\([^/]*\)$$,\1,'; \ + sed_butlast='s,/*[^/]*$$,,'; \ + while test -n "$$dir1"; do \ + first=`echo "$$dir1" | sed -e "$$sed_first"`; \ + if test "$$first" != "."; then \ + if test "$$first" = ".."; then \ + dir2=`echo "$$dir0" | sed -e "$$sed_last"`/"$$dir2"; \ + dir0=`echo "$$dir0" | sed -e "$$sed_butlast"`; \ + else \ + first2=`echo "$$dir2" | sed -e "$$sed_first"`; \ + if test "$$first2" = "$$first"; then \ + dir2=`echo "$$dir2" | sed -e "$$sed_rest"`; \ + else \ + dir2="../$$dir2"; \ + fi; \ + dir0="$$dir0"/"$$first"; \ + fi; \ + fi; \ + dir1=`echo "$$dir1" | sed -e "$$sed_rest"`; \ + done; \ + reldir="$$dir2" +DIST_ARCHIVES = $(distdir).tar.gz +GZIP_ENV = --best +DIST_TARGETS = dist-gzip +# Exists only to be overridden by the user if desired. +AM_DISTCHECK_DVI_TARGET = dvi +distuninstallcheck_listfiles = find . -type f -print +am__distuninstallcheck_listfiles = $(distuninstallcheck_listfiles) \ + | sed 's|^\./|$(prefix)/|' | grep -v '$(infodir)/dir$$' +distcleancheck_listfiles = find . -type f -print +ACLOCAL = @ACLOCAL@ +AMTAR = @AMTAR@ +AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ +APXS = @APXS@ +AR = @AR@ +AR_FLAGS = @AR_FLAGS@ +AS = @AS@ +AUTOCONF = @AUTOCONF@ +AUTOHEADER = @AUTOHEADER@ +AUTOMAKE = @AUTOMAKE@ +AWK = @AWK@ +BLANK_AT_MAKETIME = @BLANK_AT_MAKETIME@ +CADDY = @CADDY@ +CC = @CC@ +CCDEPMODE = @CCDEPMODE@ +CFLAGS = @CFLAGS@ +CFLAG_CURL_SYMBOL_HIDING = @CFLAG_CURL_SYMBOL_HIDING@ +CLANG_TIDY = @CLANG_TIDY@ +CONFIGURE_OPTIONS = @CONFIGURE_OPTIONS@ +CPP = @CPP@ +CPPFLAGS = @CPPFLAGS@ +CSCOPE = @CSCOPE@ +CTAGS = @CTAGS@ +CURLVERSION = @CURLVERSION@ +CURL_CA_BUNDLE = @CURL_CA_BUNDLE@ +CURL_CA_EMBED = @CURL_CA_EMBED@ +CURL_CFLAG_EXTRAS = @CURL_CFLAG_EXTRAS@ +CURL_CPP = @CURL_CPP@ +CURL_LIBCURL_VERSIONED_SYMBOLS_PREFIX = @CURL_LIBCURL_VERSIONED_SYMBOLS_PREFIX@ +CURL_LIBCURL_VERSIONED_SYMBOLS_SONAME = @CURL_LIBCURL_VERSIONED_SYMBOLS_SONAME@ +CURL_NETWORK_AND_TIME_LIBS = @CURL_NETWORK_AND_TIME_LIBS@ +CYGPATH_W = @CYGPATH_W@ +DANTED = @DANTED@ +DEFS = @DEFS@ +DEPDIR = @DEPDIR@ +DLLTOOL = @DLLTOOL@ +DSYMUTIL = @DSYMUTIL@ +DUMPBIN = @DUMPBIN@ +ECHO_C = @ECHO_C@ +ECHO_N = @ECHO_N@ +ECHO_T = @ECHO_T@ +EGREP = @EGREP@ +ENABLE_SHARED = @ENABLE_SHARED@ +ENABLE_STATIC = @ENABLE_STATIC@ +ETAGS = @ETAGS@ +EXEEXT = @EXEEXT@ +FGREP = @FGREP@ +FILECMD = @FILECMD@ +FISH_FUNCTIONS_DIR = @FISH_FUNCTIONS_DIR@ +GCOV = @GCOV@ +GREP = @GREP@ +H2O = @H2O@ +HAVE_LIBZ = @HAVE_LIBZ@ +HTTPD = @HTTPD@ +HTTPD_NGHTTPX = @HTTPD_NGHTTPX@ +INSTALL = @INSTALL@ +INSTALL_DATA = @INSTALL_DATA@ +INSTALL_PROGRAM = @INSTALL_PROGRAM@ +INSTALL_SCRIPT = @INSTALL_SCRIPT@ +INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ +LCOV = @LCOV@ +LD = @LD@ +LDFLAGS = @LDFLAGS@ +LIBCURL_PC_CFLAGS = @LIBCURL_PC_CFLAGS@ +LIBCURL_PC_CFLAGS_PRIVATE = @LIBCURL_PC_CFLAGS_PRIVATE@ +LIBCURL_PC_LDFLAGS_PRIVATE = @LIBCURL_PC_LDFLAGS_PRIVATE@ +LIBCURL_PC_LIBS = @LIBCURL_PC_LIBS@ +LIBCURL_PC_LIBS_PRIVATE = @LIBCURL_PC_LIBS_PRIVATE@ +LIBCURL_PC_REQUIRES = @LIBCURL_PC_REQUIRES@ +LIBCURL_PC_REQUIRES_PRIVATE = @LIBCURL_PC_REQUIRES_PRIVATE@ +LIBOBJS = @LIBOBJS@ +LIBS = @LIBS@ +LIBTOOL = @LIBTOOL@ +LIPO = @LIPO@ +LN_S = @LN_S@ +LTLIBOBJS = @LTLIBOBJS@ +LT_SYS_LIBRARY_PATH = @LT_SYS_LIBRARY_PATH@ +MAINT = @MAINT@ +MAKEINFO = @MAKEINFO@ +MANIFEST_TOOL = @MANIFEST_TOOL@ +MKDIR_P = @MKDIR_P@ +NM = @NM@ +NMEDIT = @NMEDIT@ +OBJDUMP = @OBJDUMP@ +OBJEXT = @OBJEXT@ +OTOOL = @OTOOL@ +OTOOL64 = @OTOOL64@ +PACKAGE = @PACKAGE@ +PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ +PACKAGE_NAME = @PACKAGE_NAME@ +PACKAGE_STRING = @PACKAGE_STRING@ +PACKAGE_TARNAME = @PACKAGE_TARNAME@ +PACKAGE_URL = @PACKAGE_URL@ +PACKAGE_VERSION = @PACKAGE_VERSION@ +PATH_SEPARATOR = @PATH_SEPARATOR@ +PERL = @PERL@ +PKGCONFIG = @PKGCONFIG@ +RANLIB = @RANLIB@ +RC = @RC@ +SED = @SED@ +SET_MAKE = @SET_MAKE@ +SFTPD = @SFTPD@ +SHELL = @SHELL@ +SSHD = @SSHD@ +SSL_BACKENDS = @SSL_BACKENDS@ +STRIP = @STRIP@ +SUPPORT_FEATURES = @SUPPORT_FEATURES@ +SUPPORT_PROTOCOLS = @SUPPORT_PROTOCOLS@ +TEST_NGHTTPX = @TEST_NGHTTPX@ +VERSION = @VERSION@ +VERSIONNUM = @VERSIONNUM@ +VSFTPD = @VSFTPD@ +ZLIB_LIBS = @ZLIB_LIBS@ +ZSH_FUNCTIONS_DIR = @ZSH_FUNCTIONS_DIR@ +abs_builddir = @abs_builddir@ +abs_srcdir = @abs_srcdir@ +abs_top_builddir = @abs_top_builddir@ +abs_top_srcdir = @abs_top_srcdir@ +ac_ct_AR = @ac_ct_AR@ +ac_ct_CC = @ac_ct_CC@ +ac_ct_DUMPBIN = @ac_ct_DUMPBIN@ +am__include = @am__include@ +am__leading_dot = @am__leading_dot@ +am__quote = @am__quote@ +am__tar = @am__tar@ +am__untar = @am__untar@ +bindir = @bindir@ +build = @build@ +build_alias = @build_alias@ +build_cpu = @build_cpu@ +build_os = @build_os@ +build_vendor = @build_vendor@ +builddir = @builddir@ +datadir = @datadir@ +datarootdir = @datarootdir@ +docdir = @docdir@ +dvidir = @dvidir@ +exec_prefix = @exec_prefix@ +host = @host@ +host_alias = @host_alias@ +host_cpu = @host_cpu@ +host_os = @host_os@ +host_vendor = @host_vendor@ +htmldir = @htmldir@ +includedir = @includedir@ +infodir = @infodir@ +install_sh = @install_sh@ +libdir = @libdir@ +libexecdir = @libexecdir@ +libext = @libext@ +localedir = @localedir@ +localstatedir = @localstatedir@ +mandir = @mandir@ +mkdir_p = @mkdir_p@ +oldincludedir = @oldincludedir@ +pdfdir = @pdfdir@ +prefix = @prefix@ +program_transform_name = @program_transform_name@ +psdir = @psdir@ +runstatedir = @runstatedir@ +sbindir = @sbindir@ +sharedstatedir = @sharedstatedir@ +srcdir = @srcdir@ +sysconfdir = @sysconfdir@ +target_alias = @target_alias@ +top_build_prefix = @top_build_prefix@ +top_builddir = @top_builddir@ +top_srcdir = @top_srcdir@ +AUTOMAKE_OPTIONS = foreign +ACLOCAL_AMFLAGS = -I m4 +CMAKE_DIST = \ + CMake/cmake_uninstall.in.cmake \ + CMake/curl-config.in.cmake \ + CMake/CurlSymbolHiding.cmake \ + CMake/CurlTests.c \ + CMake/FindBrotli.cmake \ + CMake/FindCares.cmake \ + CMake/FindGnuTLS.cmake \ + CMake/FindGSS.cmake \ + CMake/FindLDAP.cmake \ + CMake/FindLibbacktrace.cmake \ + CMake/FindLibgsasl.cmake \ + CMake/FindLibidn2.cmake \ + CMake/FindLibpsl.cmake \ + CMake/FindLibssh.cmake \ + CMake/FindLibssh2.cmake \ + CMake/FindLibuv.cmake \ + CMake/FindMbedTLS.cmake \ + CMake/FindNGHTTP2.cmake \ + CMake/FindNGHTTP3.cmake \ + CMake/FindNGTCP2.cmake \ + CMake/FindNettle.cmake \ + CMake/FindQuiche.cmake \ + CMake/FindRustls.cmake \ + CMake/FindWolfSSL.cmake \ + CMake/FindZstd.cmake \ + CMake/Macros.cmake \ + CMake/OtherTests.cmake \ + CMake/PickyWarnings.cmake \ + CMake/Utilities.cmake \ + CMake/unix-cache.cmake \ + CMake/win32-cache.cmake \ + CMakeLists.txt \ + tests/cmake/CMakeLists.txt \ + tests/cmake/test.c \ + tests/cmake/test.cpp \ + tests/cmake/test.sh + +EXTRA_DIST = CHANGES.md COPYING RELEASE-NOTES Dockerfile .clang-tidy.yml .editorconfig $(CMAKE_DIST) +DISTCLEANFILES = buildinfo.txt +bin_SCRIPTS = curl-config +SUBDIRS = lib docs src scripts +DIST_SUBDIRS = $(SUBDIRS) tests projects include docs +pkgconfigdir = $(libdir)/pkgconfig +pkgconfig_DATA = libcurl.pc +all: all-recursive + +.SUFFIXES: +am--refresh: Makefile + @: +$(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps) + @for dep in $?; do \ + case '$(am__configure_deps)' in \ + *$$dep*) \ + echo ' cd $(srcdir) && $(AUTOMAKE) --foreign'; \ + $(am__cd) $(srcdir) && $(AUTOMAKE) --foreign \ + && exit 0; \ + exit 1;; \ + esac; \ + done; \ + echo ' cd $(top_srcdir) && $(AUTOMAKE) --foreign Makefile'; \ + $(am__cd) $(top_srcdir) && \ + $(AUTOMAKE) --foreign Makefile +Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status + @case '$?' in \ + *config.status*) \ + echo ' $(SHELL) ./config.status'; \ + $(SHELL) ./config.status;; \ + *) \ + echo ' cd $(top_builddir) && $(SHELL) ./config.status $@ $(am__maybe_remake_depfiles)'; \ + cd $(top_builddir) && $(SHELL) ./config.status $@ $(am__maybe_remake_depfiles);; \ + esac; + +$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) + $(SHELL) ./config.status --recheck + +$(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) + $(am__cd) $(srcdir) && $(AUTOCONF) +$(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps) + $(am__cd) $(srcdir) && $(ACLOCAL) $(ACLOCAL_AMFLAGS) +$(am__aclocal_m4_deps): +libcurl.pc: $(top_builddir)/config.status $(srcdir)/libcurl.pc.in + cd $(top_builddir) && $(SHELL) ./config.status $@ +curl-config: $(top_builddir)/config.status $(srcdir)/curl-config.in + cd $(top_builddir) && $(SHELL) ./config.status $@ +install-binSCRIPTS: $(bin_SCRIPTS) + @$(NORMAL_INSTALL) + @list='$(bin_SCRIPTS)'; test -n "$(bindir)" || list=; \ + if test -n "$$list"; then \ + echo " $(MKDIR_P) '$(DESTDIR)$(bindir)'"; \ + $(MKDIR_P) "$(DESTDIR)$(bindir)" || exit 1; \ + fi; \ + for p in $$list; do \ + if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ + if test -f "$$d$$p"; then echo "$$d$$p"; echo "$$p"; else :; fi; \ + done | \ + sed -e 'p;s,.*/,,;n' \ + -e 'h;s|.*|.|' \ + -e 'p;x;s,.*/,,;$(transform)' | sed 'N;N;N;s,\n, ,g' | \ + $(AWK) 'BEGIN { files["."] = ""; dirs["."] = 1; } \ + { d=$$3; if (dirs[d] != 1) { print "d", d; dirs[d] = 1 } \ + if ($$2 == $$4) { files[d] = files[d] " " $$1; \ + if (++n[d] == $(am__install_max)) { \ + print "f", d, files[d]; n[d] = 0; files[d] = "" } } \ + else { print "f", d "/" $$4, $$1 } } \ + END { for (d in files) print "f", d, files[d] }' | \ + while read type dir files; do \ + if test "$$dir" = .; then dir=; else dir=/$$dir; fi; \ + test -z "$$files" || { \ + echo " $(INSTALL_SCRIPT) $$files '$(DESTDIR)$(bindir)$$dir'"; \ + $(INSTALL_SCRIPT) $$files "$(DESTDIR)$(bindir)$$dir" || exit $$?; \ + } \ + ; done + +uninstall-binSCRIPTS: + @$(NORMAL_UNINSTALL) + @list='$(bin_SCRIPTS)'; test -n "$(bindir)" || exit 0; \ + files=`for p in $$list; do echo "$$p"; done | \ + sed -e 's,.*/,,;$(transform)'`; \ + dir='$(DESTDIR)$(bindir)'; $(am__uninstall_files_from_dir) + +mostlyclean-libtool: + -rm -f *.lo + +clean-libtool: + -rm -rf .libs _libs + +distclean-libtool: + -rm -f libtool config.lt +install-pkgconfigDATA: $(pkgconfig_DATA) + @$(NORMAL_INSTALL) + @list='$(pkgconfig_DATA)'; test -n "$(pkgconfigdir)" || list=; \ + if test -n "$$list"; then \ + echo " $(MKDIR_P) '$(DESTDIR)$(pkgconfigdir)'"; \ + $(MKDIR_P) "$(DESTDIR)$(pkgconfigdir)" || exit 1; \ + fi; \ + for p in $$list; do \ + if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ + echo "$$d$$p"; \ + done | $(am__base_list) | \ + while read files; do \ + echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(pkgconfigdir)'"; \ + $(INSTALL_DATA) $$files "$(DESTDIR)$(pkgconfigdir)" || exit $$?; \ + done + +uninstall-pkgconfigDATA: + @$(NORMAL_UNINSTALL) + @list='$(pkgconfig_DATA)'; test -n "$(pkgconfigdir)" || list=; \ + files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ + dir='$(DESTDIR)$(pkgconfigdir)'; $(am__uninstall_files_from_dir) + +# This directory's subdirectories are mostly independent; you can cd +# into them and run 'make' without going through this Makefile. +# To change the values of 'make' variables: instead of editing Makefiles, +# (1) if the variable is set in 'config.status', edit 'config.status' +# (which will cause the Makefiles to be regenerated when you run 'make'); +# (2) otherwise, pass the desired values on the 'make' command line. +$(am__recursive_targets): + @fail=; \ + if $(am__make_keepgoing); then \ + failcom='fail=yes'; \ + else \ + failcom='exit 1'; \ + fi; \ + dot_seen=no; \ + target=`echo $@ | sed s/-recursive//`; \ + case "$@" in \ + distclean-* | maintainer-clean-*) list='$(DIST_SUBDIRS)' ;; \ + *) list='$(SUBDIRS)' ;; \ + esac; \ + for subdir in $$list; do \ + echo "Making $$target in $$subdir"; \ + if test "$$subdir" = "."; then \ + dot_seen=yes; \ + local_target="$$target-am"; \ + else \ + local_target="$$target"; \ + fi; \ + ($(am__cd) $$subdir && $(MAKE) $(AM_MAKEFLAGS) $$local_target) \ + || eval $$failcom; \ + done; \ + if test "$$dot_seen" = "no"; then \ + $(MAKE) $(AM_MAKEFLAGS) "$$target-am" || exit 1; \ + fi; test -z "$$fail" + +ID: $(am__tagged_files) + $(am__define_uniq_tagged_files); mkid -fID $$unique +tags: tags-recursive +TAGS: tags + +tags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) + set x; \ + here=`pwd`; \ + if ($(ETAGS) --etags-include --version) >/dev/null 2>&1; then \ + include_option=--etags-include; \ + empty_fix=.; \ + else \ + include_option=--include; \ + empty_fix=; \ + fi; \ + list='$(SUBDIRS)'; for subdir in $$list; do \ + if test "$$subdir" = .; then :; else \ + test ! -f $$subdir/TAGS || \ + set "$$@" "$$include_option=$$here/$$subdir/TAGS"; \ + fi; \ + done; \ + $(am__define_uniq_tagged_files); \ + shift; \ + if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \ + test -n "$$unique" || unique=$$empty_fix; \ + if test $$# -gt 0; then \ + $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ + "$$@" $$unique; \ + else \ + $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ + $$unique; \ + fi; \ + fi +ctags: ctags-recursive + +CTAGS: ctags +ctags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) + $(am__define_uniq_tagged_files); \ + test -z "$(CTAGS_ARGS)$$unique" \ + || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ + $$unique + +GTAGS: + here=`$(am__cd) $(top_builddir) && pwd` \ + && $(am__cd) $(top_srcdir) \ + && gtags -i $(GTAGS_ARGS) "$$here" +cscope: cscope.files + test ! -s cscope.files \ + || $(CSCOPE) -b -q $(AM_CSCOPEFLAGS) $(CSCOPEFLAGS) -i cscope.files $(CSCOPE_ARGS) +clean-cscope: + -rm -f cscope.files +cscope.files: clean-cscope cscopelist +cscopelist: cscopelist-recursive + +cscopelist-am: $(am__tagged_files) + list='$(am__tagged_files)'; \ + case "$(srcdir)" in \ + [\\/]* | ?:[\\/]*) sdir="$(srcdir)" ;; \ + *) sdir=$(subdir)/$(srcdir) ;; \ + esac; \ + for i in $$list; do \ + if test -f "$$i"; then \ + echo "$(subdir)/$$i"; \ + else \ + echo "$$sdir/$$i"; \ + fi; \ + done >> $(top_builddir)/cscope.files + +distclean-tags: + -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags + -rm -f cscope.out cscope.in.out cscope.po.out cscope.files +distdir: $(BUILT_SOURCES) + $(MAKE) $(AM_MAKEFLAGS) distdir-am + +distdir-am: $(DISTFILES) + $(am__remove_distdir) + test -d "$(distdir)" || mkdir "$(distdir)" + @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ + topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ + list='$(DISTFILES)'; \ + dist_files=`for file in $$list; do echo $$file; done | \ + sed -e "s|^$$srcdirstrip/||;t" \ + -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ + case $$dist_files in \ + */*) $(MKDIR_P) `echo "$$dist_files" | \ + sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ + sort -u` ;; \ + esac; \ + for file in $$dist_files; do \ + if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ + if test -d $$d/$$file; then \ + dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ + if test -d "$(distdir)/$$file"; then \ + find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ + fi; \ + if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ + cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ + find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ + fi; \ + cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ + else \ + test -f "$(distdir)/$$file" \ + || cp -p $$d/$$file "$(distdir)/$$file" \ + || exit 1; \ + fi; \ + done + @list='$(DIST_SUBDIRS)'; for subdir in $$list; do \ + if test "$$subdir" = .; then :; else \ + $(am__make_dryrun) \ + || test -d "$(distdir)/$$subdir" \ + || $(MKDIR_P) "$(distdir)/$$subdir" \ + || exit 1; \ + dir1=$$subdir; dir2="$(distdir)/$$subdir"; \ + $(am__relativize); \ + new_distdir=$$reldir; \ + dir1=$$subdir; dir2="$(top_distdir)"; \ + $(am__relativize); \ + new_top_distdir=$$reldir; \ + echo " (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) top_distdir="$$new_top_distdir" distdir="$$new_distdir" \\"; \ + echo " am__remove_distdir=: am__skip_length_check=: am__skip_mode_fix=: distdir)"; \ + ($(am__cd) $$subdir && \ + $(MAKE) $(AM_MAKEFLAGS) \ + top_distdir="$$new_top_distdir" \ + distdir="$$new_distdir" \ + am__remove_distdir=: \ + am__skip_length_check=: \ + am__skip_mode_fix=: \ + distdir) \ + || exit 1; \ + fi; \ + done + $(MAKE) $(AM_MAKEFLAGS) \ + top_distdir="$(top_distdir)" distdir="$(distdir)" \ + dist-hook + -test -n "$(am__skip_mode_fix)" \ + || find "$(distdir)" -type d ! -perm -755 \ + -exec chmod u+rwx,go+rx {} \; -o \ + ! -type d ! -perm -444 -links 1 -exec chmod a+r {} \; -o \ + ! -type d ! -perm -400 -exec chmod a+r {} \; -o \ + ! -type d ! -perm -444 -exec $(install_sh) -c -m a+r {} {} \; \ + || chmod -R a+r "$(distdir)" +dist-gzip: distdir + tardir=$(distdir) && $(am__tar) | eval GZIP= gzip $(GZIP_ENV) -c >$(distdir).tar.gz + $(am__post_remove_distdir) + +dist-bzip2: distdir + tardir=$(distdir) && $(am__tar) | BZIP2=$${BZIP2--9} bzip2 -c >$(distdir).tar.bz2 + $(am__post_remove_distdir) + +dist-lzip: distdir + tardir=$(distdir) && $(am__tar) | lzip -c $${LZIP_OPT--9} >$(distdir).tar.lz + $(am__post_remove_distdir) + +dist-xz: distdir + tardir=$(distdir) && $(am__tar) | XZ_OPT=$${XZ_OPT--e} xz -c >$(distdir).tar.xz + $(am__post_remove_distdir) + +dist-zstd: distdir + tardir=$(distdir) && $(am__tar) | zstd -c $${ZSTD_CLEVEL-$${ZSTD_OPT--19}} >$(distdir).tar.zst + $(am__post_remove_distdir) + +dist-tarZ: distdir + @echo WARNING: "Support for distribution archives compressed with" \ + "legacy program 'compress' is deprecated." >&2 + @echo WARNING: "It will be removed altogether in Automake 2.0" >&2 + tardir=$(distdir) && $(am__tar) | compress -c >$(distdir).tar.Z + $(am__post_remove_distdir) + +dist-shar: distdir + @echo WARNING: "Support for shar distribution archives is" \ + "deprecated." >&2 + @echo WARNING: "It will be removed altogether in Automake 2.0" >&2 + shar $(distdir) | eval GZIP= gzip $(GZIP_ENV) -c >$(distdir).shar.gz + $(am__post_remove_distdir) + +dist-zip: distdir + -rm -f $(distdir).zip + zip -rq $(distdir).zip $(distdir) + $(am__post_remove_distdir) + +dist dist-all: + $(MAKE) $(AM_MAKEFLAGS) $(DIST_TARGETS) am__post_remove_distdir='@:' + $(am__post_remove_distdir) + +# This target untars the dist file and tries a VPATH configuration. Then +# it guarantees that the distribution is self-contained by making another +# tarfile. +distcheck: dist + case '$(DIST_ARCHIVES)' in \ + *.tar.gz*) \ + eval GZIP= gzip $(GZIP_ENV) -dc $(distdir).tar.gz | $(am__untar) ;;\ + *.tar.bz2*) \ + bzip2 -dc $(distdir).tar.bz2 | $(am__untar) ;;\ + *.tar.lz*) \ + lzip -dc $(distdir).tar.lz | $(am__untar) ;;\ + *.tar.xz*) \ + xz -dc $(distdir).tar.xz | $(am__untar) ;;\ + *.tar.Z*) \ + uncompress -c $(distdir).tar.Z | $(am__untar) ;;\ + *.shar.gz*) \ + eval GZIP= gzip $(GZIP_ENV) -dc $(distdir).shar.gz | unshar ;;\ + *.zip*) \ + unzip $(distdir).zip ;;\ + *.tar.zst*) \ + zstd -dc $(distdir).tar.zst | $(am__untar) ;;\ + esac + chmod -R a-w $(distdir) + chmod u+w $(distdir) + mkdir $(distdir)/_build $(distdir)/_build/sub $(distdir)/_inst + chmod a-w $(distdir) + test -d $(distdir)/_build || exit 0; \ + dc_install_base=`$(am__cd) $(distdir)/_inst && pwd | sed -e 's,^[^:\\/]:[\\/],/,'` \ + && dc_destdir="$${TMPDIR-/tmp}/am-dc-$$$$/" \ + && am__cwd=`pwd` \ + && $(am__cd) $(distdir)/_build/sub \ + && ../../configure \ + $(AM_DISTCHECK_CONFIGURE_FLAGS) \ + $(DISTCHECK_CONFIGURE_FLAGS) \ + --srcdir=../.. --prefix="$$dc_install_base" \ + && $(MAKE) $(AM_MAKEFLAGS) \ + && $(MAKE) $(AM_MAKEFLAGS) $(AM_DISTCHECK_DVI_TARGET) \ + && $(MAKE) $(AM_MAKEFLAGS) check \ + && $(MAKE) $(AM_MAKEFLAGS) install \ + && $(MAKE) $(AM_MAKEFLAGS) installcheck \ + && $(MAKE) $(AM_MAKEFLAGS) uninstall \ + && $(MAKE) $(AM_MAKEFLAGS) distuninstallcheck_dir="$$dc_install_base" \ + distuninstallcheck \ + && chmod -R a-w "$$dc_install_base" \ + && ({ \ + (cd ../.. && umask 077 && mkdir "$$dc_destdir") \ + && $(MAKE) $(AM_MAKEFLAGS) DESTDIR="$$dc_destdir" install \ + && $(MAKE) $(AM_MAKEFLAGS) DESTDIR="$$dc_destdir" uninstall \ + && $(MAKE) $(AM_MAKEFLAGS) DESTDIR="$$dc_destdir" \ + distuninstallcheck_dir="$$dc_destdir" distuninstallcheck; \ + } || { rm -rf "$$dc_destdir"; exit 1; }) \ + && rm -rf "$$dc_destdir" \ + && $(MAKE) $(AM_MAKEFLAGS) dist \ + && rm -rf $(DIST_ARCHIVES) \ + && $(MAKE) $(AM_MAKEFLAGS) distcleancheck \ + && cd "$$am__cwd" \ + || exit 1 + $(am__post_remove_distdir) + @(echo "$(distdir) archives ready for distribution: "; \ + list='$(DIST_ARCHIVES)'; for i in $$list; do echo $$i; done) | \ + sed -e 1h -e 1s/./=/g -e 1p -e 1x -e '$$p' -e '$$x' +distuninstallcheck: + @test -n '$(distuninstallcheck_dir)' || { \ + echo 'ERROR: trying to run $@ with an empty' \ + '$$(distuninstallcheck_dir)' >&2; \ + exit 1; \ + }; \ + $(am__cd) '$(distuninstallcheck_dir)' || { \ + echo 'ERROR: cannot chdir into $(distuninstallcheck_dir)' >&2; \ + exit 1; \ + }; \ + test `$(am__distuninstallcheck_listfiles) | wc -l` -eq 0 \ + || { echo "ERROR: files left after uninstall:" ; \ + if test -n "$(DESTDIR)"; then \ + echo " (check DESTDIR support)"; \ + fi ; \ + $(distuninstallcheck_listfiles) ; \ + exit 1; } >&2 +distcleancheck: distclean + @if test '$(srcdir)' = . ; then \ + echo "ERROR: distcleancheck can only run from a VPATH build" ; \ + exit 1 ; \ + fi + @test `$(distcleancheck_listfiles) | wc -l` -eq 0 \ + || { echo "ERROR: files left in build directory after distclean:" ; \ + $(distcleancheck_listfiles) ; \ + exit 1; } >&2 +check-am: all-am +check: check-recursive +all-am: Makefile $(SCRIPTS) $(DATA) +installdirs: installdirs-recursive +installdirs-am: + for dir in "$(DESTDIR)$(bindir)" "$(DESTDIR)$(pkgconfigdir)"; do \ + test -z "$$dir" || $(MKDIR_P) "$$dir"; \ + done +install: install-recursive +install-exec: install-exec-recursive +install-data: install-data-recursive +uninstall: uninstall-recursive + +install-am: all-am + @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am + +installcheck: installcheck-recursive +install-strip: + if test -z '$(STRIP)'; then \ + $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ + install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ + install; \ + else \ + $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ + install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ + "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \ + fi +mostlyclean-generic: + +clean-generic: + +distclean-generic: + -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) + -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) + -test -z "$(DISTCLEANFILES)" || rm -f $(DISTCLEANFILES) + +maintainer-clean-generic: + @echo "This command is intended for maintainers to use" + @echo "it deletes files that may require special tools to rebuild." +clean: clean-recursive + +clean-am: clean-generic clean-libtool clean-local mostlyclean-am + +distclean: distclean-recursive + -rm -f $(am__CONFIG_DISTCLEAN_FILES) + -rm -f Makefile +distclean-am: clean-am distclean-generic distclean-libtool \ + distclean-tags + +dvi: dvi-recursive + +dvi-am: + +html: html-recursive + +html-am: + +info: info-recursive + +info-am: + +install-data-am: install-pkgconfigDATA + @$(NORMAL_INSTALL) + $(MAKE) $(AM_MAKEFLAGS) install-data-hook +install-dvi: install-dvi-recursive + +install-dvi-am: + +install-exec-am: install-binSCRIPTS + +install-html: install-html-recursive + +install-html-am: + +install-info: install-info-recursive + +install-info-am: + +install-man: + +install-pdf: install-pdf-recursive + +install-pdf-am: + +install-ps: install-ps-recursive + +install-ps-am: + +installcheck-am: + +maintainer-clean: maintainer-clean-recursive + -rm -f $(am__CONFIG_DISTCLEAN_FILES) + -rm -rf $(top_srcdir)/autom4te.cache + -rm -f Makefile +maintainer-clean-am: distclean-am maintainer-clean-generic + +mostlyclean: mostlyclean-recursive + +mostlyclean-am: mostlyclean-generic mostlyclean-libtool + +pdf: pdf-recursive + +pdf-am: + +ps: ps-recursive + +ps-am: + +uninstall-am: uninstall-binSCRIPTS uninstall-pkgconfigDATA + @$(NORMAL_INSTALL) + $(MAKE) $(AM_MAKEFLAGS) uninstall-hook +.MAKE: $(am__recursive_targets) install-am install-data-am \ + install-strip uninstall-am + +.PHONY: $(am__recursive_targets) CTAGS GTAGS TAGS all all-am \ + am--refresh check check-am clean clean-cscope clean-generic \ + clean-libtool clean-local cscope cscopelist-am ctags ctags-am \ + dist dist-all dist-bzip2 dist-gzip dist-hook dist-lzip \ + dist-shar dist-tarZ dist-xz dist-zip dist-zstd distcheck \ + distclean distclean-generic distclean-libtool distclean-tags \ + distcleancheck distdir distuninstallcheck dvi dvi-am html \ + html-am info info-am install install-am install-binSCRIPTS \ + install-data install-data-am install-data-hook install-dvi \ + install-dvi-am install-exec install-exec-am install-html \ + install-html-am install-info install-info-am install-man \ + install-pdf install-pdf-am install-pkgconfigDATA install-ps \ + install-ps-am install-strip installcheck installcheck-am \ + installdirs installdirs-am maintainer-clean \ + maintainer-clean-generic mostlyclean mostlyclean-generic \ + mostlyclean-libtool pdf pdf-am ps ps-am tags tags-am uninstall \ + uninstall-am uninstall-binSCRIPTS uninstall-hook \ + uninstall-pkgconfigDATA + +.PRECIOUS: Makefile + + +dist-hook: + rm -rf $(top_builddir)/tests/log + find $(distdir) -name "*.dist" -exec rm -- {} \; + (distit=`find $(srcdir) -name "*.dist" | grep -v Makefile`; \ + for file in $$distit; do \ + strip=`echo $$file | sed -e s/^$(srcdir)// -e s/\.dist//`; \ + cp -p $$file $(distdir)$$strip; \ + done) + +check: test examples check-docs + +@CROSSCOMPILING_TRUE@test-full: test +@CROSSCOMPILING_TRUE@test-nonflaky: test +@CROSSCOMPILING_TRUE@test-torture: test +@CROSSCOMPILING_TRUE@test-event: test +@CROSSCOMPILING_TRUE@test-am: test +@CROSSCOMPILING_TRUE@test-ci: test +@CROSSCOMPILING_TRUE@pytest: test +@CROSSCOMPILING_TRUE@pytest-ci: test + +@CROSSCOMPILING_TRUE@test: +@CROSSCOMPILING_TRUE@ @echo "NOTICE: we cannot run the tests when cross-compiling!" + +@CROSSCOMPILING_FALSE@test: +@CROSSCOMPILING_FALSE@ @(cd tests; $(MAKE) all quiet-test) + +@CROSSCOMPILING_FALSE@test-full: +@CROSSCOMPILING_FALSE@ @(cd tests; $(MAKE) all full-test) + +@CROSSCOMPILING_FALSE@test-nonflaky: +@CROSSCOMPILING_FALSE@ @(cd tests; $(MAKE) all nonflaky-test) + +@CROSSCOMPILING_FALSE@test-torture: +@CROSSCOMPILING_FALSE@ @(cd tests; $(MAKE) all torture-test) + +@CROSSCOMPILING_FALSE@test-event: +@CROSSCOMPILING_FALSE@ @(cd tests; $(MAKE) all event-test) + +@CROSSCOMPILING_FALSE@test-am: +@CROSSCOMPILING_FALSE@ @(cd tests; $(MAKE) all am-test) + +@CROSSCOMPILING_FALSE@test-ci: +@CROSSCOMPILING_FALSE@ @(cd tests; $(MAKE) all ci-test) + +@CROSSCOMPILING_FALSE@pytest: +@CROSSCOMPILING_FALSE@ @(cd tests; $(MAKE) all default-pytest) + +@CROSSCOMPILING_FALSE@pytest-ci: +@CROSSCOMPILING_FALSE@ @(cd tests; $(MAKE) all ci-pytest) + +examples: + @(cd docs/examples; $(MAKE) check) + +check-docs: + @(cd docs/libcurl; $(MAKE) check) + +# We extend the standard install with a custom hook: +@BUILD_DOCS_TRUE@install-data-hook: +@BUILD_DOCS_TRUE@ (cd include && $(MAKE) install) +@BUILD_DOCS_TRUE@ (cd docs && $(MAKE) install) +@BUILD_DOCS_TRUE@ (cd docs/libcurl && $(MAKE) install) +@BUILD_DOCS_FALSE@install-data-hook: +@BUILD_DOCS_FALSE@ (cd include && $(MAKE) install) +@BUILD_DOCS_FALSE@ (cd docs && $(MAKE) install) + +# We extend the standard uninstall with a custom hook: +uninstall-hook: + (cd include && $(MAKE) uninstall) + (cd docs && $(MAKE) uninstall) + (cd docs/libcurl && $(MAKE) uninstall) + +ca-bundle: $(srcdir)/scripts/mk-ca-bundle.pl + @echo "generating a fresh ca-bundle.crt" + @perl $(srcdir)/scripts/mk-ca-bundle.pl -b -l -u lib/ca-bundle.crt + +ca-firefox: $(srcdir)/scripts/firefox-db2pem.sh + @echo "generating a fresh ca-bundle.crt" + $(srcdir)/scripts/firefox-db2pem.sh lib/ca-bundle.crt + +checksrc: + (cd lib && $(MAKE) checksrc) + (cd src && $(MAKE) checksrc) + (cd tests && $(MAKE) checksrc) + (cd include/curl && $(MAKE) checksrc) + (cd docs/examples && $(MAKE) checksrc) + (cd projects && $(MAKE) checksrc) + +badwords: + @PERL@ $(top_srcdir)/scripts/badwords-all + +lint: badwords checksrc + @PERL@ $(top_srcdir)/scripts/spacecheck.pl + +tidy: + (cd src && $(MAKE) tidy) + (cd lib && $(MAKE) tidy) + +clean-local: + (cd tests && $(MAKE) clean) + +# Tell versions [3.59,3.63) of GNU make to not export all variables. +# Otherwise a system limit (for SysV at least) may be exceeded. +.NOEXPORT: diff --git a/3rdparty/curl-8.21.0/README b/3rdparty/curl-8.21.0/README new file mode 100644 index 0000000000..4ee7e43a2c --- /dev/null +++ b/3rdparty/curl-8.21.0/README @@ -0,0 +1,50 @@ + _ _ ____ _ + ___| | | | _ \| | + / __| | | | |_) | | + | (__| |_| | _ <| |___ + \___|\___/|_| \_\_____| + +README + + Curl is a command line tool for transferring data specified with URL + syntax. Find out how to use curl by reading the curl.1 man page or the + MANUAL document. Find out how to install Curl by reading the INSTALL + document. + + libcurl is the library curl is using to do its job. It is readily + available to be used by your software. Read the libcurl.3 man page to + learn how. + + You find answers to the most frequent questions we get in the FAQ.md + document. + + Study the COPYING file for distribution terms. + + Those documents and more can be found in the docs/ directory. + +CONTACT + + If you have problems, questions, ideas or suggestions, please contact us + by posting to a suitable mailing list. See https://curl.se/mail/ + + All contributors to the project are listed in the THANKS document. + +WEBSITE + + Visit the curl website for the latest news and downloads: + + https://curl.se/ + +GIT + + To download the latest source code off the GIT server, do this: + + git clone https://github.com/curl/curl + + (you will get a directory named curl created, filled with the source code) + +SECURITY PROBLEMS + + Report suspected security problems privately and not in public. + + https://curl.se/dev/vuln-disclosure.html diff --git a/3rdparty/curl-8.21.0/RELEASE-NOTES b/3rdparty/curl-8.21.0/RELEASE-NOTES new file mode 100644 index 0000000000..f6f67d988c --- /dev/null +++ b/3rdparty/curl-8.21.0/RELEASE-NOTES @@ -0,0 +1,624 @@ +curl and libcurl 8.21.0 + + Public curl releases: 275 + Command line options: 274 + curl_easy_setopt() options: 308 + Public functions in libcurl: 100 + Authors: 1489 + Contributors: 3731 + +This release includes the following changes: + + o curl: named globs in output file name for upload glob references [77] + o HTTP/3: add proxy CONNECT and MASQUE CONNECT-UDP support (ngtcp2 QUIC) [53] + o http2: remove stream dependency tracking [40] + o lib: drop support for CURLAUTH_DIGEST_IE [4] + o libssh: add support for SHA256 host public keys [57] + o tool_urlglob: add named globs [92] + +This release includes the following bugfixes: + + o _ENVIRONMENT.md. Windows does case insensitive env variables [214] + o _URL.md: remove the zone-id mention [227] + o AmigaOS: curl_setup.h avoid explicit_bzero with clib2 [283] + o AmigaOS: fix build fallouts, re-add to CI [279] + o asyn-thrdd: add IPv6 guards [195] + o asyn-thrdd: fix result processing without wakeup socketpair [2] + o autotools: mbedtls detection fixes [163] + o BINDINGS: Update Hollywood link [181] + o BUFQ.md: re-sync with source code [111] + o build: enable `-Wlogical-op` picky warning for GCC 4.4+ [277] + o build: omit zlib pkg-config reference for Android [130] + o cf-h2-prox: fix peer leak [132] + o cf-h2-proxy: drop interim responses [47] + o cf-https-connect: do not engage on proxy origin [236] + o cf-ip-happy.c: minor comment typo + o cf-ip-happy: update documentation [223] + o cf-socket: make Curl_addr2string static [224] + o cf-socket: set scope_id for IPv6 link-local addresses [150] + o cf-socket: store errno from do_connect in ctx->error [199] + o cfilters: fix busy loop on blocked transfers [72] + o chunked: reject invalid bytes in trailer [210] + o CIPHERS.md: fix the example that uses only TLS 1.3 [137] + o cmake/FindGSS: drop "MIT Unknown" version value, related tidy ups [292] + o cmake/FindGSS: drop CMake <3.16 compatibility logic [291] + o cmake/FindGSS: fix comment, adjust custom flavor property name [261] + o cmake/FindGSS: prioritize MIT over GNU in pkg-config detection [196] + o cmake: auto-select static nghttp2/nghttp3/ngtcp2 Config [8] + o cmake: export/forward `NGTCP2_CRYPTO_BACKEND` [99] + o cmake: fix three issues generating lib options in config files [126] + o cmake: fix zstd CMake config name [5] + o cmake: opt in `MSVC_VERSION` 1951 to picky warnings [55] + o cmake: quote `COMPONENTS` string in `curl-config.in.cmake` [80] + o cmake: simplify `LINK_ONLY` imported target extraction [294] + o config2setopts: use default protocol properly [286] + o connect: remove deref of freed pointer in trace call [128] + o content_encoding: fix limit failure message [171] + o content_encoding: fix non-last chunked rejection [209] + o content_encoding: timeout during slow decoding [170] + o cookie: check __Secure- and __Host- case sensitively when read from file [256] + o cookie: compare path case sensitively [52] + o cookie: reject control octets in file-loaded cookies [289] + o cookie: simplify strstore(), remove outdated comment [12] + o cookie: tailmatch the domains for secure override [200] + o cookie: trim trailing dots when checking PSL [39] + o creds: add sasl service name [75] + o creds: create with empty user+pass [304] + o creds: mask OAuth bearer token in trace logs [117] + o creds: remove two unused functions [158] + o curl_easy_pause.md: rephrase the stream cache when pause clause [120] + o curl_easy_setopt.md: change options when no transfer runs [122] + o curl_formdata: fix to pass long where missing, document `CURLFORM_NAMELENGTH` [243] + o curl_multi_assign.md: clarify lifetime [264] + o curl_ntlm_core: fix nettle 4+ builds in certain MultiSSL combos [87] + o curl_ntlm_core: propagate DES `CryptEncrypt()` error [84] + o curl_sha512_256: fix result code on error [166] + o CURLINFO_CONTENT_LENGTH_UPLOAD_T.md: expand [215] + o CURLMOPT_SOCKETFUNCTION.md: this sends *all* file descriptors [266] + o CURLOPT_CHUNK_BGN_FUNCTION: target is there for symlinks only [156] + o CURLOPT_DISALLOW_USERNAME_IN_URL: is for CURLOPT_URL only [61] + o CURLOPT_DOH_URL.md: does not inherit proxy options [213] + o CURLOPT_ECH.md: simplify the description language [18] + o CURLOPT_HAPROXYPROTOCOL.md: only sent for newly setup connections [32] + o CURLOPT_MAXFILESIZE: clarify this also works for on-going transfers [78] + o CURLOPT_PINNEDPUBLICKEY.md: does not apply for other origins [152] + o CURLOPT_PORT.md: use stronger language [133] + o CURLOPT_SHARE: warn about early remove [51] + o CURLOPT_SSH_HOSTKEYFUNCTION.md: for new connections only [48] + o CURLOPT_WRITEFUNCTION.md: mention redirects [226] + o CURLOPT_WRITEFUNCTION.md: remove stray reference to HSTS [208] + o delta: harden external command invocations [98] + o digest: escape control codes too [206] + o digest: flush proxy state on proxy or credential change [225] + o digest: flush state on origin or credential change [235] + o dns-httpsrr-lookup: use origin, not peer [302] + o dnscache: remove Curl_dns_entry_link [160] + o docs/libcurl: fix the version for curl_multi_socket_action + o docs: end "...can be used several times..." sentences with period [34] + o docs: fix --follow doc typo [97] + o docs: fix a couple of typos [62] + o docs: fix grammar and wording in FAQ [66] + o docs: fix odd wording in CONTRIBUTE.md [107] + o docs: note CURLOPT_PINNEDPUBLICKEY has no effect on legacy LDAP backend [65] + o docs: returned header size reflects HTTP/1-style format [203] + o doh: cap the maximum TTL to 24 hours [234] + o doh: drop redundant `curlx_dyn_free()` call in `doh_probe_done()` [232] + o doh: stricter HTTPS RNAME parsing [233] + o ECH: cleanups [20] + o event: fix wakeup consumption [93] + o ftp: avoid accessing EPSV response one byte past the NULL [9] + o ftp: remove 2 Curl_resolv_blocking() calls [30] + o ftp: remove bits.ftp_use_control_ssl [28] + o ftplistparser: clear strings.target if not symlink [148] + o gnutls: allow building with nettle 4.0 [96] + o gnutls: fix more nettle 4+ compatibility issues [94] + o gnutls: require 3.7.2 for earlydata [103] + o gsasl: fix potential double free [56] + o gtls: fix ignored return and uninitialized status in OCSP check [49] + o gtls: fix some typos [15] + o gtls: minor fixes and improvements [190] + o gtls: use the correct return code in trace output [173] + o gtls: verify OCSP response signature in gtls_verify_ocsp_status [86] + o h3-proxy: fix callback return values, and a typo in tests [139] + o hostip: remove unused MAX_HOSTCACHE_LEN and MAX_DNS_CACHE_SIZE [101] + o hsts.md: mention multiple curl invokes effect [189] + o hsts: duplicate live HSTS data in curl_easy_duphandle [183] + o http-proxy: verify CONNECT response headers [192] + o HTTP3.md: update quiche build [229] + o http: don't pass on set cookies to new origins [140] + o http: prefer chunked encoding over Content-Length: 0 [146] + o http: reject spurious CR bytes in headers [157] + o http_digest: return better error [204] + o idn: replace header guards with forward declaration [100] + o INSTALL-CMAKE.md: document CMake environment variables [246] + o INTERNALS.md: document minimum nghttp3 and ngtcp2 versions [299] + o KNOWN_BUGS.md: remove fixed GnuTLS <-> OpenSSL incompat bug [41] + o KNOWN_BUGS: remove stale Threads::Threads entry [135] + o krb5_sspi: fix error message on `DecryptMessage()` fail [269] + o ldap: base64 encode binary LDIF values with WinLDAP [273] + o ldap: fix minor leak on write callback error [24] + o ldap: fix to not leak `attribute` on OOM (WinLDAP) [79] + o ldap: switch off chasing referrals [114] + o lib678: fix to not be perma-skipped [10] + o lib: make `__STDC_VERSION__` literals `L` (where missing) + o lib: transfer origin and proxy handling [276] + o lib: two minor typos [16] + o libcurl-easy.md: minor clarifications [19] + o libssh2: do not use deprecated macros when unavailable [177] + o libssh2: drop stray double-negative from `strncmp()` result [194] + o libssh2: fix to return error code on missing parameter [198] + o libssh2: replace macro names with non-misspelled alternatives [169] + o libssh2: save non-standard port to `known_hosts` [217] + o libssh2: sync version check with INTERNALS.md [176] + o libssh2: use non-deprecated `libssh2_knownhost_addc()` [178] + o libssh: map SSH_KNOWN_HOSTS_OTHER to CURLKHMATCH_MISMATCH [125] + o m4: drop redundant conditions in TLS library detections [155] + o Makefile.am: drop test1190 listed twice [144] + o managen: apply minor fixes and improvements [115] + o mbedtls: null-terminate the private key blob [36] + o mk-unity.pl: `#include`, and not concatenate input headers [124] + o mqtt: return error on truncated Remaining Length [230] + o mqtt: validate PINGRESP and DISCONNECT have remaining_length == 0 [7] + o multi: handle pause in multi socket callback [109] + o multi: remove a stale comment [216] + o multi: silence gcc 16 `-Wnull-dereference`, bump CI job to test [54] + o multi: xfers_really_alive [288] + o netrc: remember and check filename loaded [212] + o netrc: scanner refactor [121] + o ngtcp2: fail handshake directly [138] + o openssl: do not mix OpenSSL int result with `CURLcode` variable [265] + o os400sys: fix theoretical length overflows [141] + o peer.h: fix typo in comment [202] + o pingpong: reject nul byte in server response line [268] + o progress: fix CURLINFO time reporting [145] + o psl: require libpsl 0.16.0 (2016-12-10) or greater [188] + o pytest: pass `--disable` to curl [175] + o pytest: re-enable test test_05_01 and test_05_02 for quiche 0.29.0+ [154] + o pythonlint.sh: make it fail on error, fix ruff warnings in pytest [67] + o quic: count zero length packets against max [179] + o ratelimits: use minimal burst rate [245] + o RELEASE-PROCEDURE.md: update coming relese dates + o resolve: mention in error that IP address is expected [205] + o rtsp: bump buf after rtsp_filter_rtp() [88] + o runner.pm: apply minor correctness fix [105] + o runner.pm: set `CURL_TESTNUM` for `precheck` commands [13] + o runtests: fix tests for curl builds with embedded CA bundle [187] + o rustls: error on CURLOPT_CRLFILE with native CA store [59] + o schannel: check `schannel_sha256sum()` success, and more [165] + o schannel: enforce Extended Key Usage for custom CA roots [29] + o schannel: error on TLS 1.3-only with cipher list [136] + o schannel: fix https proxy for client cert and certinfo [280] + o schannel: fix revoke_best_effort setting for proxy [70] + o schannel: use fopen instead CreateFile [191] + o schannel_verify: avoid out of blob access [11] + o schannel_verify: simplify CryptQueryObject use [159] + o scripts: catch Credits-to contributors [127] + o SECURITY-ADVISORY.md: expand [220] + o setopt: changing the proxy port is also a proxy change [23] + o setopt: clear proxy auth properly on NULL [81] + o setopt: clear the "custom" CA booleans when set to NULL [218] + o setopt: CURLOPT_MAXCONNECTS set to 0 restores default value [161] + o setopt: defref the old referer when setting a new [168] + o setopt: fix to honor `CURLOPT_PROXY_CAINFO_BLOB` over Native CA [26] + o setopt: gate a few proxy TLS options by checking backend support [35] + o setopt: more careful cleanup of the HSTS cache [45] + o setopt: return error if received `curl_blob->data` is NULL [185] + o show-headers.md: mention bold headers and --no-styled-output [17] + o sigv4: URL encode the user name in the header [193] + o smb: constify `strchr()` result variable [257] + o smb: integer overflow proof a size check [263] + o smbserver: update internal id generation for Python 3 [238] + o socket: introduce `SOCK_EAGAIN()` and use it [278] + o socket: use name `sockerr` for socket error variables [271] + o socks_sspi: invalid response length is a fatal error [272] + o socks_sspi: store socks5_gssapi_enctype [262] + o spnego_sspi: honor CURLOPT_GSSAPI_DELEGATION for Windows SSPI [89] + o spnego_sspi: preserve distinction btw policy-only and uncond delegation [74] + o src: fix comment typos [83] + o src: sync nghttp2 versions checks with current requirements [300] + o ssl native_ca_store: always reinit [211] + o SSLCERTS: document 8.19.0 default Native CA builds (Windows) [14] + o sspi: clear SSPI credentials on AcquireCredentialsHandle failure [76] + o sspi: free libcurl allocated memory with curlx_free [274] + o telnet: drop an `int` cast no longer necessary [270] + o telnet: drop redundant interim variables [275] + o telnet: fix error message typos [186] + o telnet: fix old copy-paste typo in variable name [281] + o telnet: honor CURLOPT_TIMEOUT in send_telnet_data() [104] + o test1588: use %TESTNUMBER, not hard-coded number [118] + o test1981: explicitly set the locale [85] + o tests: add `cookies` feature to some tests [182] + o tests: add an assert to avoid IPC blocking [69] + o tests: add the "--resolve" keyword to tests that lack it [184] + o tests: fix unit1636 with --disable-progress-meter [37] + o tftp: avoid the timeout calc if the timeout is crazy [151] + o tftp: stricter option name checks [90] + o tidy-up: add space around operators, where missing [147] + o tidy-up: apply clang-format fixes [153] + o tidy-up: drop stray casts for allocated pointers [174] + o tidy-up: miscellaneous [106] + o tls: fix incomplete mTLS config in conn reuse and session cache [108] + o tls: wolfssl: fixes for PQC key shares [239] + o tool: warn when --ssl and --ftp-ssl-control override each other [129] + o tool_formparse.c: fix two minor comment typos [25] + o tool_formparse: polish error message + make two functions static [1] + o tool_formparse: tool2curlparts is no longer recursive [33] + o tool_help: rectify a bad assert [143] + o tool_operhlp: avoid NULL to %s [142] + o tool_urlglob: avoid overflow at end of range [22] + o tool_urlglob: better 'Duplicate glob name' position [82] + o tool_urlglob: make globbing error reported for correct position [91] + o tool_writeout: fix %time{} output for %s [231] + o transfer: clear referer when set to NULL [112] + o unit1675: fix potential memory leak on dynbuf fail path [197] + o unix-sockets: ignore proxy settings [6] + o URL-SYNTAX: document more URL parsing details [134] + o url: compare full origin when setting credentials [42] + o url: connection credentials origin [228] + o url: connection reuse fixes for starttls [68] + o url: detect proxy changes read from environment [110] + o url: don't log bits.close state [290] + o url: fix connection reuse for starttls protocols [27] + o url: keep the question mark for empty queries [73] + o url: remove superfluous check [131] + o url: url_match_destination fix [43] + o urlapi: accept 0X prefix in IPv4 address as well [63] + o urlapi: change more lowercase percent-encoded to uppercase [71] + o urlapi: compare zone-id in Curl_url_same_origin() [95] + o urlapi: consume trailing dots after IPv4 numerical addresses [50] + o urlapi: deny hostnames with more than one trailing dot [58] + o urlapi: drop base fragment on empty redirect [64] + o urlapi: fix an issue parsing file URLs [149] + o urlapi: fix memleaks on error in `parse_hostname_login()` [221] + o urlapi: fix redirect handling if CURLU_NO_GUESS_SCHEME is set [46] + o urlapi: forbid '|' in host [172] + o urlapi: handle redirect without set scheme with default-scheme [38] + o urlapi: URL decode hostname before IP address normalization [207] + o user-agent.md: mention double quotes too [3] + o var: use a dedicated pointer for the alloc [219] + o verify-release: verify more thoroughly with git [249] + o vquic: drop stray casts for `iovec.iov_len` [162] + o vquic: fix `-Wunused-parameter` with proxies disabled [260] + o vtls: more large buffer support and error checks for SHA-256 [164] + o vtls: use Curl_safecmp for CRLfile and pinned_key comparison [116] + o vtls_scache: include signature_algorithms in the SSL peer cache key [123] + o vtls_spack: drop redundant macro fallbacks [167] + o VULN-DISCLOSURE-POLICY.md: emphasize comm as a human [180] + o VULN-DISCLOSURE-POLICY.md: emphasize the no email thank you part [113] + o VULN-DISCLOSURE-POLICY.md: test code is not secure [119] + o VULN-DISCLOSURE-POLICY: non-released code [253] + o websockets: auto-tunnel through http proxy [102] + o websockets: buffer ugprade data at connection level [237] + o windows: update MS SDK versions in comments [60] + o winldap: avoid NULL pointer deref on `ldap_get_dn()` fail [242] + o ws: make pong sending lazy [201] + o x509asn1: fix DH public key parameter extraction [44] + o x509asn1: fix operator order in do_pubkey [21] + +This release includes the following known bugs: + + See https://curl.se/docs/knownbugs.html + +For all changes ever done in curl: + + See https://curl.se/changes.html + +Planned upcoming removals include: + + o local crypto implementations + o NTLM + o SMB + o TLS-SRP support + + See https://curl.se/dev/deprecate.html + +This release would not have looked like this without help, code, reports and +advice from friends like these: + + 0xN3R3K3, 11soda11, Ady Elouej, A Johnston, Alan De Smet, alhudz, + alienowo on hackerone, ambikeesshh, amitbidlan, Andreas Falkenhahn, + Andrei Rybak, Andrew Nesbitt, Aritra Basu, av223119 on github, + azraelxuemo on hackerone, Bartel Sielski, Bastian Jesuiter, + BazaarAcc32 on github, Bill Mill, Bryan Henderson, ByteRay on hackerone, + chrizilla on github, co-authors in libssh2, correctmost on github, + Dan Fandrich, Daniel Gustafsson, Daniel Stenberg, Dario Vinella, + Darren Banfi, Dave Walker, daviey on hackerone, dependabot[bot], + dyingc on github, Earnestly on github, Elise Vance, Emanuel Krollmann, + Eunsoo Kim, evergarden1123 on hackerone, Fabian Keil, Filipe Casal, + Gao Liyou, Guancheng Li, Guannan Wang, Harry Sintonen, Hem Parekh, htasta, + jeffhuang, Jeremy Nicoll, Jiashuo Liang, jjchuck on hackerone, + Johannes Schlatow, Josef Cejka, Joshua Rogers, Kai Pastor, Marcel Raad, + Mark Esler, Max Dymond, Michael Kaufmann, mik, Mike-menny on github, + Muhamad Arga Reksapati, mulan_dh on hackerone, netspacer.research, + oreadvanthink on github, parasol-aser, penpal, Peter Krefting, Philip H., + Rainer Jung, Randall S. Becker, Raymond Steen, Ray Satiro, + renjian on hackerone, renovate[bot], Ross Burton, Saud Alshareef, + Sergio Correia, sfan5 on github, Shintomon Mathew, sideshowbarker on github, + Sollace on github, Song X. Gao, sourceturner, Stefan Eissing, + Tatsuhiro Tsujikawa, Tim Martin, tiymat, Tobias Frauenschläger, + Trail of Bits, Vasiliy-Kkk, vectorqueue on hackerone, vegagent on hackerone, + Viktor Szakats, violet12331 on hackerone, Will Cosgrove, + wulin-nudt on github, Xi Ruoyao, x-xiang on github, Yedaya Katsman, + Zartaj Majeed, zhanhb on github, Zhanpeng Liu + (102 contributors) + +References to bug reports and discussions on issues: + + [1] = https://curl.se/bug/?i=21510 + [2] = https://curl.se/bug/?i=21476 + [3] = https://curl.se/mail/archive-2026-04/0029.html + [4] = https://curl.se/bug/?i=21486 + [5] = https://curl.se/bug/?i=21538 + [6] = https://curl.se/bug/?i=21630 + [7] = https://hackerone.com/reports/3702718 + [8] = https://curl.se/bug/?i=21470 + [9] = https://curl.se/bug/?i=21545 + [10] = https://curl.se/bug/?i=21641 + [11] = https://curl.se/bug/?i=21543 + [12] = https://curl.se/bug/?i=21541 + [13] = https://curl.se/bug/?i=21640 + [14] = https://curl.se/bug/?i=21634 + [15] = https://curl.se/bug/?i=21498 + [16] = https://curl.se/bug/?i=21496 + [17] = https://curl.se/bug/?i=21495 + [18] = https://curl.se/bug/?i=21536 + [19] = https://curl.se/bug/?i=21491 + [20] = https://curl.se/bug/?i=21532 + [21] = https://curl.se/bug/?i=21533 + [22] = https://curl.se/bug/?i=21529 + [23] = https://curl.se/bug/?i=21485 + [24] = https://curl.se/bug/?i=21530 + [25] = https://curl.se/bug/?i=21480 + [26] = https://curl.se/bug/?i=21631 + [27] = https://curl.se/bug/?i=21522 + [28] = https://curl.se/bug/?i=21521 + [29] = https://curl.se/bug/?i=21629 + [30] = https://curl.se/bug/?i=21512 + [32] = https://curl.se/bug/?i=21517 + [33] = https://curl.se/bug/?i=21518 + [34] = https://curl.se/bug/?i=21644 + [35] = https://curl.se/bug/?i=21514 + [36] = https://curl.se/bug/?i=21515 + [37] = https://curl.se/bug/?i=21500 + [38] = https://curl.se/bug/?i=21632 + [39] = https://curl.se/bug/?i=21636 + [40] = https://curl.se/bug/?i=21723 + [41] = https://curl.se/bug/?i=21720 + [42] = https://curl.se/bug/?i=21575 + [43] = https://curl.se/bug/?i=21573 + [44] = https://curl.se/bug/?i=21595 + [45] = https://curl.se/bug/?i=21615 + [46] = https://curl.se/bug/?i=21721 + [47] = https://curl.se/bug/?i=21626 + [48] = https://curl.se/bug/?i=21606 + [49] = https://curl.se/bug/?i=21679 + [50] = https://curl.se/bug/?i=21635 + [51] = https://curl.se/bug/?i=21633 + [52] = https://curl.se/bug/?i=21616 + [53] = https://curl.se/bug/?i=21153 + [54] = https://curl.se/bug/?i=21707 + [55] = https://curl.se/bug/?i=21714 + [56] = https://curl.se/bug/?i=21609 + [57] = https://curl.se/bug/?i=21605 + [58] = https://curl.se/bug/?i=21622 + [59] = https://curl.se/bug/?i=21614 + [60] = https://curl.se/bug/?i=21621 + [61] = https://curl.se/bug/?i=21890 + [62] = https://curl.se/bug/?i=21617 + [63] = https://curl.se/bug/?i=21820 + [64] = https://curl.se/bug/?i=21745 + [65] = https://curl.se/bug/?i=21682 + [66] = https://curl.se/bug/?i=21593 + [67] = https://curl.se/bug/?i=21597 + [68] = https://curl.se/bug/?i=21665 + [69] = https://curl.se/bug/?i=21688 + [70] = https://curl.se/bug/?i=21683 + [71] = https://curl.se/bug/?i=21592 + [72] = https://curl.se/bug/?i=21671 + [73] = https://curl.se/bug/?i=21544 + [74] = https://curl.se/bug/?i=21583 + [75] = https://curl.se/bug/?i=21585 + [76] = https://curl.se/bug/?i=21642 + [77] = https://curl.se/bug/?i=21407 + [78] = https://curl.se/bug/?i=21582 + [79] = https://curl.se/bug/?i=21576 + [80] = https://curl.se/bug/?i=21699 + [81] = https://curl.se/bug/?i=21696 + [82] = https://curl.se/bug/?i=21567 + [83] = https://curl.se/bug/?i=21570 + [84] = https://curl.se/bug/?i=21569 + [85] = https://curl.se/bug/?i=21749 + [86] = https://curl.se/bug/?i=21677 + [87] = https://curl.se/bug/?i=21562 + [88] = https://curl.se/bug/?i=21563 + [89] = https://curl.se/bug/?i=21528 + [90] = https://curl.se/bug/?i=21560 + [91] = https://curl.se/bug/?i=21561 + [92] = https://curl.se/bug/?i=21409 + [93] = https://curl.se/bug/?i=21547 + [94] = https://curl.se/bug/?i=21557 + [95] = https://curl.se/bug/?i=21686 + [96] = https://curl.se/bug/?i=21169 + [97] = https://curl.se/bug/?i=21553 + [98] = https://curl.se/bug/?i=21104 + [99] = https://curl.se/bug/?i=21523 + [100] = https://curl.se/bug/?i=21551 + [101] = https://curl.se/bug/?i=21550 + [102] = https://curl.se/bug/?i=21663 + [103] = https://curl.se/bug/?i=21750 + [104] = https://curl.se/bug/?i=21685 + [105] = https://curl.se/bug/?i=21672 + [106] = https://curl.se/bug/?i=21646 + [107] = https://curl.se/bug/?i=21705 + [108] = https://curl.se/bug/?i=21667 + [109] = https://curl.se/bug/?i=21748 + [110] = https://curl.se/bug/?i=21666 + [111] = https://curl.se/bug/?i=21678 + [112] = https://curl.se/bug/?i=21741 + [113] = https://curl.se/bug/?i=21747 + [114] = https://curl.se/bug/?i=21732 + [115] = https://curl.se/bug/?i=21670 + [116] = https://curl.se/bug/?i=21668 + [117] = https://curl.se/bug/?i=21659 + [118] = https://curl.se/bug/?i=21662 + [119] = https://curl.se/bug/?i=21660 + [120] = https://curl.se/bug/?i=21658 + [121] = https://curl.se/bug/?i=21624 + [122] = https://curl.se/bug/?i=21604 + [123] = https://curl.se/bug/?i=21651 + [124] = https://curl.se/bug/?i=21656 + [125] = https://curl.se/bug/?i=21724 + [126] = https://curl.se/bug/?i=21654 + [127] = https://curl.se/bug/?i=21653 + [128] = https://curl.se/bug/?i=21649 + [129] = https://curl.se/bug/?i=21887 + [130] = https://curl.se/bug/?i=21647 + [131] = https://curl.se/bug/?i=21650 + [132] = https://curl.se/bug/?i=21602 + [133] = https://curl.se/bug/?i=21886 + [134] = https://curl.se/bug/?i=21841 + [135] = https://curl.se/bug/?i=21734 + [136] = https://curl.se/bug/?i=21702 + [137] = https://curl.se/bug/?i=21719 + [138] = https://curl.se/bug/?i=21712 + [139] = https://curl.se/bug/?i=21802 + [140] = https://curl.se/bug/?i=21794 + [141] = https://curl.se/bug/?i=21840 + [142] = https://curl.se/bug/?i=21836 + [143] = https://curl.se/bug/?i=21837 + [144] = https://curl.se/bug/?i=21839 + [145] = https://curl.se/bug/?i=21828 + [146] = https://curl.se/bug/?i=21706 + [147] = https://curl.se/bug/?i=21793 + [148] = https://curl.se/bug/?i=21884 + [149] = https://curl.se/bug/?i=21743 + [150] = https://curl.se/bug/?i=21669 + [151] = https://curl.se/bug/?i=21782 + [152] = https://curl.se/bug/?i=21885 + [153] = https://curl.se/bug/?i=21786 + [154] = https://curl.se/bug/?i=21784 + [155] = https://curl.se/bug/?i=21781 + [156] = https://curl.se/bug/?i=21883 + [157] = https://curl.se/bug/?i=21882 + [158] = https://curl.se/bug/?i=21776 + [159] = https://curl.se/bug/?i=21760 + [160] = https://curl.se/bug/?i=21774 + [161] = https://curl.se/bug/?i=21829 + [162] = https://curl.se/bug/?i=21877 + [163] = https://curl.se/bug/?i=21727 + [164] = https://curl.se/bug/?i=21771 + [165] = https://curl.se/bug/?i=21739 + [166] = https://curl.se/bug/?i=21767 + [167] = https://curl.se/bug/?i=21768 + [168] = https://curl.se/bug/?i=21826 + [169] = https://curl.se/bug/?i=21876 + [170] = https://curl.se/bug/?i=21603 + [171] = https://curl.se/bug/?i=21756 + [172] = https://curl.se/bug/?i=21762 + [173] = https://curl.se/bug/?i=21766 + [174] = https://curl.se/bug/?i=21865 + [175] = https://curl.se/bug/?i=21816 + [176] = https://curl.se/bug/?i=21868 + [177] = https://curl.se/bug/?i=21867 + [178] = https://curl.se/bug/?i=21866 + [179] = https://curl.se/bug/?i=21869 + [180] = https://curl.se/bug/?i=21870 + [181] = https://curl.se/bug/?i=21862 + [182] = https://curl.se/bug/?i=21858 + [183] = https://curl.se/bug/?i=21809 + [184] = https://curl.se/bug/?i=21930 + [185] = https://curl.se/bug/?i=22129 + [186] = https://curl.se/bug/?i=21976 + [187] = https://curl.se/bug/?i=21970 + [188] = https://curl.se/bug/?i=21933 + [189] = https://curl.se/bug/?i=21851 + [190] = https://curl.se/bug/?i=21850 + [191] = https://curl.se/bug/?i=21773 + [192] = https://curl.se/bug/?i=21927 + [193] = https://curl.se/bug/?i=21923 + [194] = https://curl.se/bug/?i=22126 + [195] = https://curl.se/bug/?i=21881 + [196] = https://curl.se/bug/?i=22052 + [197] = https://curl.se/bug/?i=21922 + [198] = https://curl.se/bug/?i=22125 + [199] = https://curl.se/bug/?i=21914 + [200] = https://curl.se/bug/?i=21910 + [201] = https://curl.se/bug/?i=21911 + [202] = https://curl.se/bug/?i=21920 + [203] = https://curl.se/bug/?i=21912 + [204] = https://curl.se/bug/?i=21969 + [205] = https://curl.se/bug/?i=21913 + [206] = https://curl.se/bug/?i=21915 + [207] = https://curl.se/bug/?i=21918 + [208] = https://curl.se/bug/?i=21968 + [209] = https://curl.se/bug/?i=21966 + [210] = https://curl.se/bug/?i=21896 + [211] = https://curl.se/bug/?i=21902 + [212] = https://curl.se/bug/?i=21903 + [213] = https://curl.se/bug/?i=21904 + [214] = https://curl.se/bug/?i=21907 + [215] = https://curl.se/bug/?i=21953 + [216] = https://curl.se/bug/?i=21961 + [217] = https://curl.se/bug/?i=21863 + [218] = https://curl.se/bug/?i=21901 + [219] = https://curl.se/bug/?i=21898 + [220] = https://curl.se/bug/?i=21964 + [221] = https://curl.se/bug/?i=21879 + [223] = https://curl.se/bug/?i=21957 + [224] = https://curl.se/bug/?i=21946 + [225] = https://curl.se/bug/?i=21951 + [226] = https://curl.se/bug/?i=21945 + [227] = https://curl.se/bug/?i=22048 + [228] = https://curl.se/bug/?i=22040 + [229] = https://curl.se/bug/?i=22105 + [230] = https://curl.se/bug/?i=21949 + [231] = https://curl.se/bug/?i=22038 + [232] = https://curl.se/bug/?i=22133 + [233] = https://curl.se/bug/?i=22124 + [234] = https://curl.se/bug/?i=22122 + [235] = https://curl.se/bug/?i=21944 + [236] = https://curl.se/bug/?i=22033 + [237] = https://curl.se/bug/?i=22107 + [238] = https://curl.se/bug/?i=21937 + [239] = https://curl.se/bug/?i=22030 + [242] = https://curl.se/bug/?i=22000 + [243] = https://curl.se/bug/?i=22017 + [245] = https://curl.se/bug/?i=22016 + [246] = https://curl.se/bug/?i=22114 + [249] = https://curl.se/bug/?i=22018 + [253] = https://curl.se/bug/?i=22025 + [256] = https://curl.se/bug/?i=22085 + [257] = https://curl.se/bug/?i=22094 + [260] = https://curl.se/bug/?i=22104 + [261] = https://curl.se/bug/?i=22013 + [262] = https://curl.se/bug/?i=22004 + [263] = https://curl.se/bug/?i=22001 + [264] = https://curl.se/bug/?i=22088 + [265] = https://curl.se/bug/?i=22087 + [266] = https://curl.se/bug/?i=22081 + [268] = https://curl.se/bug/?i=21996 + [269] = https://curl.se/bug/?i=22003 + [270] = https://curl.se/bug/?i=22002 + [271] = https://curl.se/bug/?i=21998 + [272] = https://curl.se/bug/?i=21999 + [273] = https://curl.se/bug/?i=21926 + [274] = https://curl.se/bug/?i=21990 + [275] = https://curl.se/bug/?i=21995 + [276] = https://curl.se/bug/?i=21967 + [277] = https://curl.se/bug/?i=21893 + [278] = https://curl.se/bug/?i=21992 + [279] = https://curl.se/bug/?i=21993 + [280] = https://curl.se/bug/?i=21986 + [281] = https://curl.se/bug/?i=21979 + [283] = https://curl.se/bug/?i=21989 + [286] = https://curl.se/bug/?i=21983 + [288] = https://curl.se/bug/?i=22050 + [289] = https://curl.se/bug/?i=22070 + [290] = https://curl.se/bug/?i=22073 + [291] = https://curl.se/bug/?i=22072 + [292] = https://curl.se/bug/?i=22052 + [294] = https://curl.se/bug/?i=22063 + [299] = https://curl.se/bug/?i=22062 + [300] = https://curl.se/bug/?i=22061 + [302] = https://curl.se/bug/?i=22059 + [304] = https://curl.se/bug/?i=21943 diff --git a/3rdparty/curl-8.21.0/acinclude.m4 b/3rdparty/curl-8.21.0/acinclude.m4 new file mode 100644 index 0000000000..ed8b0499dd --- /dev/null +++ b/3rdparty/curl-8.21.0/acinclude.m4 @@ -0,0 +1,1583 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +#*************************************************************************** + +dnl CURL_CHECK_DEF (SYMBOL, [INCLUDES], [SILENT]) +dnl ------------------------------------------------- +dnl Use the C preprocessor to find out if the given object-style symbol +dnl is defined and get its expansion. This macro does not use default +dnl includes even if no INCLUDES argument is given. This macro runs +dnl silently when invoked with three arguments. If the expansion would +dnl result in a set of double-quoted strings the returned expansion is +dnl actually a single double-quoted string concatenating all them. + +AC_DEFUN([CURL_CHECK_DEF], [ + AC_REQUIRE([CURL_CPP_P]) + OLDCPPFLAGS=$CPPFLAGS + dnl CPPPFLAG comes from CURL_CPP_P + CPPFLAGS="$CPPFLAGS $CPPPFLAG" + AS_VAR_PUSHDEF([ac_HaveDef], [curl_cv_have_def_$1]) + AS_VAR_PUSHDEF([ac_Def], [curl_cv_def_$1]) + if test -z "$SED"; then + AC_MSG_ERROR([SED not set. Cannot continue without SED being set.]) + fi + if test -z "$GREP"; then + AC_MSG_ERROR([GREP not set. Cannot continue without GREP being set.]) + fi + ifelse($3,,[AC_MSG_CHECKING([for preprocessor definition of $1])]) + tmp_exp="" + AC_PREPROC_IFELSE([ + AC_LANG_SOURCE( + ifelse($2,,,[$2])[[ + #ifdef $1 + CURL_DEF_TOKEN $1 + #endif + ]]) + ],[ + tmp_exp=`eval "$ac_cpp conftest.$ac_ext" 2>/dev/null | \ + "$GREP" CURL_DEF_TOKEN 2>/dev/null | \ + "$SED" 's/.*CURL_DEF_TOKEN[[ ]][[ ]]*//' 2>/dev/null | \ + "$SED" 's/[["]][[ ]]*[["]]//g' 2>/dev/null` + if test -z "$tmp_exp" || test "$tmp_exp" = "$1"; then + tmp_exp="" + fi + ]) + if test -z "$tmp_exp"; then + AS_VAR_SET(ac_HaveDef, no) + ifelse($3,,[AC_MSG_RESULT([no])]) + else + AS_VAR_SET(ac_HaveDef, yes) + AS_VAR_SET(ac_Def, $tmp_exp) + ifelse($3,,[AC_MSG_RESULT([$tmp_exp])]) + fi + AS_VAR_POPDEF([ac_Def]) + AS_VAR_POPDEF([ac_HaveDef]) + CPPFLAGS=$OLDCPPFLAGS +]) + + +dnl CURL_CHECK_DEF_CC (SYMBOL, [INCLUDES], [SILENT]) +dnl ------------------------------------------------- +dnl Use the C compiler to find out only if the given symbol is defined +dnl or not, this can not find out its expansion. This macro does not use +dnl default includes even if no INCLUDES argument is given. This macro +dnl runs silently when invoked with three arguments. + +AC_DEFUN([CURL_CHECK_DEF_CC], [ + AS_VAR_PUSHDEF([ac_HaveDef], [curl_cv_have_def_$1]) + ifelse($3,,[AC_MSG_CHECKING([for compiler definition of $1])]) + AC_COMPILE_IFELSE([ + AC_LANG_SOURCE( + ifelse($2,,,[$2])[[ + int main(void) + { + #ifndef $1 + #error force compilation error + #endif + return 0; + } + ]]) + ],[ + tst_symbol_defined="yes" + ],[ + tst_symbol_defined="no" + ]) + if test "$tst_symbol_defined" = "yes"; then + AS_VAR_SET(ac_HaveDef, yes) + ifelse($3,,[AC_MSG_RESULT([yes])]) + else + AS_VAR_SET(ac_HaveDef, no) + ifelse($3,,[AC_MSG_RESULT([no])]) + fi + AS_VAR_POPDEF([ac_HaveDef]) +]) + + +dnl CURL_CHECK_LIB_XNET +dnl ------------------------------------------------- +dnl Verify if X/Open network library is required. + +AC_DEFUN([CURL_CHECK_LIB_XNET], [ + AC_MSG_CHECKING([if X/Open network library is required]) + tst_lib_xnet_required="no" + AC_COMPILE_IFELSE([ + AC_LANG_SOURCE([[ + int main(void) + { + #if defined(__hpux) && defined(_XOPEN_SOURCE) && (_XOPEN_SOURCE >= 600) + #elif defined(__hpux) && defined(_XOPEN_SOURCE_EXTENDED) + #else + #error force compilation error + #endif + return 0; + } + ]]) + ],[ + tst_lib_xnet_required="yes" + LIBS="-lxnet $LIBS" + ]) + AC_MSG_RESULT([$tst_lib_xnet_required]) +]) + + +dnl CURL_CHECK_AIX_ALL_SOURCE +dnl ------------------------------------------------- +dnl Provides a replacement of traditional AC_AIX with +dnl an uniform behavior across all autoconf versions, +dnl and with our own placement rules. + +AC_DEFUN([CURL_CHECK_AIX_ALL_SOURCE], [ + AH_VERBATIM([_ALL_SOURCE], + [/* Define to 1 if OS is AIX. */ +#ifndef _ALL_SOURCE +# undef _ALL_SOURCE +#endif]) + AC_BEFORE([$0], [AC_SYS_LARGEFILE]) + AC_BEFORE([$0], [CURL_CONFIGURE_REENTRANT]) + AC_MSG_CHECKING([if OS is AIX (to define _ALL_SOURCE)]) + AC_EGREP_CPP([yes_this_is_aix],[ +#ifdef _AIX + yes_this_is_aix +#endif + ],[ + AC_MSG_RESULT([yes]) + AC_DEFINE(_ALL_SOURCE) + ],[ + AC_MSG_RESULT([no]) + ]) +]) + + +dnl CURL_CHECK_NATIVE_WINDOWS +dnl ------------------------------------------------- +dnl Check if building a native Windows target + +AC_DEFUN([CURL_CHECK_NATIVE_WINDOWS], [ + AC_CACHE_CHECK([whether build target is a native Windows one], [curl_cv_native_windows], [ + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + ]],[[ + #ifdef _WIN32 + int dummy = 1; + (void)dummy; + #else + #error Not a native Windows build target. + #endif + ]]) + ],[ + curl_cv_native_windows="yes" + ],[ + curl_cv_native_windows="no" + ]) + ]) + AM_CONDITIONAL(DOING_NATIVE_WINDOWS, test "$curl_cv_native_windows" = "yes") +]) + + +dnl CURL_CHECK_HEADER_LBER +dnl ------------------------------------------------- +dnl Check for compilable and valid lber.h header, +dnl and check if it is needed even with ldap.h + +AC_DEFUN([CURL_CHECK_HEADER_LBER], [ + AC_REQUIRE([CURL_CHECK_NATIVE_WINDOWS]) + AC_CACHE_CHECK([for lber.h], [curl_cv_header_lber_h], [ + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + #undef inline + #ifdef _WIN32 + #ifndef WIN32_LEAN_AND_MEAN + #define WIN32_LEAN_AND_MEAN + #endif + #include + #else + #ifdef HAVE_SYS_TYPES_H + #include + #endif + #endif + #ifndef NULL + #define NULL (void *)0 + #endif + #include + ]],[[ + BerValue *bvp = NULL; + BerElement *bep = ber_init(bvp); + ber_free(bep, 1); + ]]) + ],[ + curl_cv_header_lber_h="yes" + ],[ + curl_cv_header_lber_h="no" + ]) + ]) + if test "$curl_cv_header_lber_h" = "yes"; then + AC_DEFINE_UNQUOTED(HAVE_LBER_H, 1, + [Define to 1 if you have the lber.h header file.]) + + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + #undef inline + #ifdef _WIN32 + #ifndef WIN32_LEAN_AND_MEAN + #define WIN32_LEAN_AND_MEAN + #endif + #include + #else + #ifdef HAVE_SYS_TYPES_H + #include + #endif + #endif + #ifndef NULL + #define NULL (void *)0 + #endif + #ifndef LDAP_DEPRECATED + #define LDAP_DEPRECATED 1 + #endif + #include + ]],[[ + BerValue *bvp = NULL; + BerElement *bep = ber_init(bvp); + ber_free(bep, 1); + ]]) + ],[ + curl_cv_need_header_lber_h="no" + ],[ + curl_cv_need_header_lber_h="yes" + ]) + + case "$curl_cv_need_header_lber_h" in + yes) + AC_DEFINE_UNQUOTED(NEED_LBER_H, 1, + [Define to 1 if you need the lber.h header file even with ldap.h]) + ;; + esac + fi +]) + + +dnl CURL_CHECK_HEADER_LDAP +dnl ------------------------------------------------- +dnl Check for compilable and valid ldap.h header + +AC_DEFUN([CURL_CHECK_HEADER_LDAP], [ + AC_REQUIRE([CURL_CHECK_HEADER_LBER]) + AC_CACHE_CHECK([for ldap.h], [curl_cv_header_ldap_h], [ + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + #undef inline + #ifdef _WIN32 + #ifndef WIN32_LEAN_AND_MEAN + #define WIN32_LEAN_AND_MEAN + #endif + #include + #else + #ifdef HAVE_SYS_TYPES_H + #include + #endif + #endif + #ifndef LDAP_DEPRECATED + #define LDAP_DEPRECATED 1 + #endif + #ifdef NEED_LBER_H + #include + #endif + #include + ]],[[ + LDAP *ldp = ldap_init("0.0.0.0", LDAP_PORT); + int res = ldap_unbind(ldp); + (void)res; + ]]) + ],[ + curl_cv_header_ldap_h="yes" + ],[ + curl_cv_header_ldap_h="no" + ]) + ]) + case "$curl_cv_header_ldap_h" in + yes) + AC_DEFINE_UNQUOTED(HAVE_LDAP_H, 1, + [Define to 1 if you have the ldap.h header file.]) + ;; + esac +]) + + +dnl CURL_CHECK_HEADER_LDAP_SSL +dnl ------------------------------------------------- +dnl Check for compilable and valid ldap_ssl.h header + +AC_DEFUN([CURL_CHECK_HEADER_LDAP_SSL], [ + AC_REQUIRE([CURL_CHECK_HEADER_LDAP]) + AC_CACHE_CHECK([for ldap_ssl.h], [curl_cv_header_ldap_ssl_h], [ + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + #undef inline + #ifdef _WIN32 + #ifndef WIN32_LEAN_AND_MEAN + #define WIN32_LEAN_AND_MEAN + #endif + #include + #else + #ifdef HAVE_SYS_TYPES_H + #include + #endif + #endif + #ifndef LDAP_DEPRECATED + #define LDAP_DEPRECATED 1 + #endif + #ifdef NEED_LBER_H + #include + #endif + #ifdef HAVE_LDAP_H + #include + #endif + #include + ]],[[ + LDAP *ldp = ldapssl_init("0.0.0.0", LDAPS_PORT, 1); + (void)ldp; + ]]) + ],[ + curl_cv_header_ldap_ssl_h="yes" + ],[ + curl_cv_header_ldap_ssl_h="no" + ]) + ]) + case "$curl_cv_header_ldap_ssl_h" in + yes) + AC_DEFINE_UNQUOTED(HAVE_LDAP_SSL_H, 1, + [Define to 1 if you have the ldap_ssl.h header file.]) + ;; + esac +]) + + +dnl CURL_CHECK_LIBS_WINLDAP +dnl ------------------------------------------------- +dnl Check for libraries needed for WINLDAP support, +dnl and prepended to LIBS any needed libraries. +dnl This macro can take an optional parameter with a +dnl whitespace separated list of libraries to check +dnl before the WINLDAP default ones. + +AC_DEFUN([CURL_CHECK_LIBS_WINLDAP], [ + AC_REQUIRE([CURL_CHECK_HEADER_WINBER]) + + AC_MSG_CHECKING([for WINLDAP libraries]) + + u_libs="" + + ifelse($1,,,[ + for x_lib in $1; do + case "$x_lib" in + -l*) + l_lib="$x_lib" + ;; + *) + l_lib="-l$x_lib" + ;; + esac + if test -z "$u_libs"; then + u_libs="$l_lib" + else + u_libs="$u_libs $l_lib" + fi + done + ]) + + curl_cv_save_LIBS="$LIBS" + curl_cv_ldap_LIBS="unknown" + + for x_nlibs in '' "$u_libs" \ + '-lwldap32' ; do + if test "$curl_cv_ldap_LIBS" = "unknown"; then + if test -z "$x_nlibs"; then + LIBS="$curl_cv_save_LIBS" + else + LIBS="$x_nlibs $curl_cv_save_LIBS" + fi + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([[ + #undef inline + #ifdef _WIN32 + #ifndef WIN32_LEAN_AND_MEAN + #define WIN32_LEAN_AND_MEAN + #endif + #include + #include + #ifdef HAVE_WINBER_H + #include + #endif + #endif + ]],[[ + BERVAL *bvp = NULL; + BerElement *bep = ber_init(bvp); + LDAP *ldp = ldap_init("0.0.0.0", LDAP_PORT); + ULONG res = ldap_unbind(ldp); + ber_free(bep, 1); + (void)res; + ]]) + ],[ + curl_cv_ldap_LIBS="$x_nlibs" + ]) + fi + done + + LIBS="$curl_cv_save_LIBS" + + case X-"$curl_cv_ldap_LIBS" in + X-unknown) + AC_MSG_RESULT([cannot find WINLDAP libraries]) + ;; + X-) + AC_MSG_RESULT([no additional lib required]) + ;; + *) + if test -z "$curl_cv_save_LIBS"; then + LIBS="$curl_cv_ldap_LIBS" + else + LIBS="$curl_cv_ldap_LIBS $curl_cv_save_LIBS" + fi + AC_MSG_RESULT([$curl_cv_ldap_LIBS]) + ;; + esac +]) + + +dnl CURL_CHECK_LIBS_LDAP +dnl ------------------------------------------------- +dnl Check for libraries needed for LDAP support, +dnl and prepended to LIBS any needed libraries. +dnl This macro can take an optional parameter with a +dnl whitespace separated list of libraries to check +dnl before the default ones. + +AC_DEFUN([CURL_CHECK_LIBS_LDAP], [ + AC_REQUIRE([CURL_CHECK_HEADER_LDAP]) + + AC_MSG_CHECKING([for LDAP libraries]) + + u_libs="" + + ifelse($1,,,[ + for x_lib in $1; do + case "$x_lib" in + -l*) + l_lib="$x_lib" + ;; + *) + l_lib="-l$x_lib" + ;; + esac + if test -z "$u_libs"; then + u_libs="$l_lib" + else + u_libs="$u_libs $l_lib" + fi + done + ]) + + curl_cv_save_LIBS="$LIBS" + curl_cv_ldap_LIBS="unknown" + + for x_nlibs in '' "$u_libs" \ + '-lldap' \ + '-lldap -llber' \ + '-llber -lldap' \ + '-lldapssl -lldapx -lldapsdk' \ + '-lldapsdk -lldapx -lldapssl' \ + '-lldap -llber -lssl -lcrypto'; do + + if test "$curl_cv_ldap_LIBS" = "unknown"; then + if test -z "$x_nlibs"; then + LIBS="$curl_cv_save_LIBS" + else + LIBS="$x_nlibs $curl_cv_save_LIBS" + fi + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([[ + #undef inline + #ifdef _WIN32 + #ifndef WIN32_LEAN_AND_MEAN + #define WIN32_LEAN_AND_MEAN + #endif + #include + #else + #ifdef HAVE_SYS_TYPES_H + #include + #endif + #endif + #ifndef NULL + #define NULL (void *)0 + #endif + #ifndef LDAP_DEPRECATED + #define LDAP_DEPRECATED 1 + #endif + #ifdef NEED_LBER_H + #include + #endif + #ifdef HAVE_LDAP_H + #include + #endif + ]],[[ + BerValue *bvp = NULL; + BerElement *bep = ber_init(bvp); + LDAP *ldp = ldap_init("0.0.0.0", LDAP_PORT); + int res = ldap_unbind(ldp); + ber_free(bep, 1); + (void)res; + ]]) + ],[ + curl_cv_ldap_LIBS="$x_nlibs" + ]) + fi + done + + LIBS="$curl_cv_save_LIBS" + + case X-"$curl_cv_ldap_LIBS" in + X-unknown) + AC_MSG_RESULT([cannot find LDAP libraries]) + ;; + X-) + AC_MSG_RESULT([no additional lib required]) + ;; + *) + if test -z "$curl_cv_save_LIBS"; then + LIBS="$curl_cv_ldap_LIBS" + else + LIBS="$curl_cv_ldap_LIBS $curl_cv_save_LIBS" + fi + dnl FIXME: Enable when ldap was detected via pkg-config + if false; then + LIBCURL_PC_REQUIRES_PRIVATE="ldap $LIBCURL_PC_REQUIRES_PRIVATE" + fi + AC_MSG_RESULT([$curl_cv_ldap_LIBS]) + ;; + esac +]) + + +dnl TYPE_SOCKADDR_STORAGE +dnl ------------------------------------------------- +dnl Check for struct sockaddr_storage. Most IPv6-enabled +dnl hosts have it, but AIX 4.3 is one known exception. + +AC_DEFUN([TYPE_SOCKADDR_STORAGE], +[ + AC_CHECK_TYPE([struct sockaddr_storage], + AC_DEFINE(HAVE_STRUCT_SOCKADDR_STORAGE, 1, + [if struct sockaddr_storage is defined]), , + [ + #undef inline + #ifdef _WIN32 + #ifndef WIN32_LEAN_AND_MEAN + #define WIN32_LEAN_AND_MEAN + #endif + #include + #else + #ifdef HAVE_SYS_TYPES_H + #include + #endif + #include + #ifdef HAVE_NETINET_IN_H + #include + #endif + #ifdef HAVE_ARPA_INET_H + #include + #endif + #endif + ]) +]) + +dnl CURL_CHECK_FUNC_RECV +dnl ------------------------------------------------- +dnl Test if the socket recv() function is available, + +AC_DEFUN([CURL_CHECK_FUNC_RECV], [ + AC_REQUIRE([CURL_CHECK_NATIVE_WINDOWS]) + AC_REQUIRE([CURL_INCLUDES_BSDSOCKET]) + AC_CHECK_HEADERS(sys/types.h) + + AC_MSG_CHECKING([for recv]) + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([[ + #undef inline + #ifdef _WIN32 + #ifndef WIN32_LEAN_AND_MEAN + #define WIN32_LEAN_AND_MEAN + #endif + #include + #else + $curl_includes_bsdsocket + #ifdef HAVE_SYS_TYPES_H + #include + #endif + #include + #endif + ]],[[ + recv(0, 0, 0, 0); + ]]) + ],[ + AC_MSG_RESULT([yes]) + curl_cv_recv="yes" + ],[ + AC_MSG_RESULT([no]) + curl_cv_recv="no" + ]) + + if test "$curl_cv_recv" = "yes"; then + AC_DEFINE_UNQUOTED(HAVE_RECV, 1, + [Define to 1 if you have the recv function.]) + curl_cv_func_recv="yes" + else + AC_MSG_ERROR([Unable to link function recv]) + fi +]) + + +dnl CURL_CHECK_FUNC_SEND +dnl ------------------------------------------------- +dnl Test if the socket send() function is available, + +AC_DEFUN([CURL_CHECK_FUNC_SEND], [ + AC_REQUIRE([CURL_CHECK_NATIVE_WINDOWS]) + AC_REQUIRE([CURL_INCLUDES_BSDSOCKET]) + AC_CHECK_HEADERS(sys/types.h) + + AC_MSG_CHECKING([for send]) + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([[ + #undef inline + #ifdef _WIN32 + #ifndef WIN32_LEAN_AND_MEAN + #define WIN32_LEAN_AND_MEAN + #endif + #include + #else + $curl_includes_bsdsocket + #ifdef HAVE_SYS_TYPES_H + #include + #endif + #include + #endif + ]],[[ + char s[] = ""; + send(0, (void *)s, 0, 0); + ]]) + ],[ + AC_MSG_RESULT([yes]) + curl_cv_send="yes" + ],[ + AC_MSG_RESULT([no]) + curl_cv_send="no" + ]) + + if test "$curl_cv_send" = "yes"; then + AC_DEFINE_UNQUOTED(HAVE_SEND, 1, + [Define to 1 if you have the send function.]) + curl_cv_func_send="yes" + else + AC_MSG_ERROR([Unable to link function send]) + fi +]) + + +dnl CURL_CHECK_STRUCT_TIMEVAL +dnl ------------------------------------------------- +dnl Check for timeval struct + +AC_DEFUN([CURL_CHECK_STRUCT_TIMEVAL], [ + AC_REQUIRE([CURL_CHECK_NATIVE_WINDOWS]) + AC_CHECK_HEADERS(sys/types.h) + AC_CACHE_CHECK([for struct timeval], [curl_cv_struct_timeval], [ + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + #undef inline + #ifdef _WIN32 + #ifndef WIN32_LEAN_AND_MEAN + #define WIN32_LEAN_AND_MEAN + #endif + #include + #else + #include + #include + #endif + #ifdef HAVE_SYS_TYPES_H + #include + #endif + #include + ]],[[ + struct timeval ts; + ts.tv_sec = 0; + ts.tv_usec = 0; + (void)ts; + ]]) + ],[ + curl_cv_struct_timeval="yes" + ],[ + curl_cv_struct_timeval="no" + ]) + ]) + case "$curl_cv_struct_timeval" in + yes) + AC_DEFINE_UNQUOTED(HAVE_STRUCT_TIMEVAL, 1, + [Define to 1 if you have the timeval struct.]) + ;; + esac +]) + + +dnl CURL_CHECK_FUNC_CLOCK_GETTIME_MONOTONIC +dnl ------------------------------------------------- +dnl Check if monotonic clock_gettime is available. + +AC_DEFUN([CURL_CHECK_FUNC_CLOCK_GETTIME_MONOTONIC], [ + AC_CHECK_HEADERS(sys/types.h) + AC_MSG_CHECKING([for monotonic clock_gettime]) + + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + #ifdef HAVE_SYS_TYPES_H + #include + #endif + #ifndef _WIN32 + #include + #endif + #include + ]],[[ + struct timespec ts; + (void)clock_gettime(CLOCK_MONOTONIC, &ts); + (void)ts; + ]]) + ],[ + AC_MSG_RESULT([yes]) + curl_func_clock_gettime="yes" + ],[ + AC_MSG_RESULT([no]) + curl_func_clock_gettime="no" + ]) + + dnl Definition of HAVE_CLOCK_GETTIME_MONOTONIC is intentionally postponed + dnl until library linking and runtime checks for clock_gettime succeed. +]) + +dnl CURL_CHECK_FUNC_CLOCK_GETTIME_MONOTONIC_RAW +dnl ------------------------------------------------- +dnl Check if monotonic clock_gettime is available. + +AC_DEFUN([CURL_CHECK_FUNC_CLOCK_GETTIME_MONOTONIC_RAW], [ + AC_CHECK_HEADERS(sys/types.h) + AC_MSG_CHECKING([for raw monotonic clock_gettime]) + + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + #ifdef HAVE_SYS_TYPES_H + #include + #endif + #ifndef _WIN32 + #include + #endif + #include + ]],[[ + struct timespec ts; + (void)clock_gettime(CLOCK_MONOTONIC_RAW, &ts); + (void)ts; + ]]) + ],[ + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_CLOCK_GETTIME_MONOTONIC_RAW, 1, + [Define to 1 if you have the clock_gettime function and raw monotonic timer.]) + ],[ + AC_MSG_RESULT([no]) + ]) +]) + + +dnl CURL_CHECK_LIBS_CLOCK_GETTIME_MONOTONIC +dnl ------------------------------------------------- +dnl If monotonic clock_gettime is available then, +dnl check and prepended to LIBS any needed libraries. + +AC_DEFUN([CURL_CHECK_LIBS_CLOCK_GETTIME_MONOTONIC], [ + AC_REQUIRE([CURL_CHECK_FUNC_CLOCK_GETTIME_MONOTONIC]) + + if test "$curl_func_clock_gettime" = "yes"; then + + AC_MSG_CHECKING([for clock_gettime in libraries]) + + curl_cv_save_LIBS="$LIBS" + curl_cv_gclk_LIBS="unknown" + + for x_xlibs in '' '-lrt' '-lposix4' ; do + if test "$curl_cv_gclk_LIBS" = "unknown"; then + if test -z "$x_xlibs"; then + LIBS="$curl_cv_save_LIBS" + else + LIBS="$x_xlibs $curl_cv_save_LIBS" + fi + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([[ + #ifdef HAVE_SYS_TYPES_H + #include + #endif + #ifndef _WIN32 + #include + #endif + #include + ]],[[ + struct timespec ts; + (void)clock_gettime(CLOCK_MONOTONIC, &ts); + (void)ts; + ]]) + ],[ + curl_cv_gclk_LIBS="$x_xlibs" + ]) + fi + done + + LIBS="$curl_cv_save_LIBS" + + case X-"$curl_cv_gclk_LIBS" in + X-unknown) + AC_MSG_RESULT([cannot find clock_gettime]) + AC_MSG_WARN([HAVE_CLOCK_GETTIME_MONOTONIC is not defined]) + curl_func_clock_gettime="no" + ;; + X-) + AC_MSG_RESULT([no additional lib required]) + curl_func_clock_gettime="yes" + ;; + *) + if test "$dontwant_rt" = "yes"; then + AC_MSG_WARN([needs -lrt but asked not to use it, HAVE_CLOCK_GETTIME_MONOTONIC is not defined]) + curl_func_clock_gettime="no" + else + if test -z "$curl_cv_save_LIBS"; then + LIBS="$curl_cv_gclk_LIBS" + else + LIBS="$curl_cv_gclk_LIBS $curl_cv_save_LIBS" + fi + AC_MSG_RESULT([$curl_cv_gclk_LIBS]) + curl_func_clock_gettime="yes" + fi + ;; + esac + + dnl only do runtime verification when not cross-compiling + if test "$cross_compiling" != "yes" && + test "$curl_func_clock_gettime" = "yes"; then + AC_MSG_CHECKING([if monotonic clock_gettime works]) + CURL_RUN_IFELSE([ + AC_LANG_PROGRAM([[ + #include + #ifdef HAVE_SYS_TYPES_H + #include + #endif + #ifndef _WIN32 + #include + #endif + #include + ]],[[ + struct timespec ts; + if(0 == clock_gettime(CLOCK_MONOTONIC, &ts)) + return 0; + (void)ts; + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + ],[ + AC_MSG_RESULT([no]) + AC_MSG_WARN([HAVE_CLOCK_GETTIME_MONOTONIC is not defined]) + curl_func_clock_gettime="no" + LIBS="$curl_cv_save_LIBS" + ]) + fi + + case "$curl_func_clock_gettime" in + yes) + AC_DEFINE_UNQUOTED(HAVE_CLOCK_GETTIME_MONOTONIC, 1, + [Define to 1 if you have the clock_gettime function and monotonic timer.]) + ;; + esac + fi +]) + + +dnl CURL_CHECK_LIBS_CONNECT +dnl ------------------------------------------------- +dnl Verify if network connect function is already available +dnl using current libraries or if another one is required. + +AC_DEFUN([CURL_CHECK_LIBS_CONNECT], [ + AC_REQUIRE([CURL_INCLUDES_WINSOCK2]) + AC_REQUIRE([CURL_INCLUDES_BSDSOCKET]) + AC_MSG_CHECKING([for connect in libraries]) + tst_connect_save_LIBS="$LIBS" + tst_connect_need_LIBS="unknown" + for tst_lib in '' '-lsocket' ; do + if test "$tst_connect_need_LIBS" = "unknown"; then + LIBS="$tst_lib $tst_connect_save_LIBS" + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_winsock2 + $curl_includes_bsdsocket + #if !defined(_WIN32) && !defined(HAVE_PROTO_BSDSOCKET_H) + int connect(int, void*, int); + #endif + ]],[[ + if(0 != connect(0, 0, 0)) + return 1; + ]]) + ],[ + tst_connect_need_LIBS="$tst_lib" + ]) + fi + done + LIBS="$tst_connect_save_LIBS" + + case X-"$tst_connect_need_LIBS" in + X-unknown) + AC_MSG_RESULT([cannot find connect]) + AC_MSG_ERROR([cannot find connect function in libraries.]) + ;; + X-) + AC_MSG_RESULT([yes]) + ;; + *) + AC_MSG_RESULT([$tst_connect_need_LIBS]) + LIBS="$tst_connect_need_LIBS $tst_connect_save_LIBS" + ;; + esac +]) + + +dnl CURL_CHECK_FUNC_SELECT +dnl ------------------------------------------------- +dnl Test if the socket select() function is available. + +AC_DEFUN([CURL_CHECK_FUNC_SELECT], [ + AC_REQUIRE([CURL_CHECK_STRUCT_TIMEVAL]) + AC_REQUIRE([CURL_INCLUDES_BSDSOCKET]) + AC_CHECK_HEADERS(sys/select.h) + + AC_MSG_CHECKING([for select]) + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([[ + #undef inline + #ifdef _WIN32 + #ifndef WIN32_LEAN_AND_MEAN + #define WIN32_LEAN_AND_MEAN + #endif + #include + #else + #include + #include + #endif + #ifdef HAVE_SYS_TYPES_H + #include + #endif + #include + #ifndef _WIN32 + #ifdef HAVE_SYS_SELECT_H + #include + #elif defined(HAVE_UNISTD_H) + #include + #endif + $curl_includes_bsdsocket + #endif + ]],[[ + select(0, 0, 0, 0, 0); + ]]) + ],[ + AC_MSG_RESULT([yes]) + curl_cv_select="yes" + ],[ + AC_MSG_RESULT([no]) + curl_cv_select="no" + ]) + + if test "$curl_cv_select" = "yes"; then + AC_DEFINE_UNQUOTED(HAVE_SELECT, 1, + [Define to 1 if you have the select function.]) + curl_cv_func_select="yes" + fi +]) + + +dnl CURL_VERIFY_RUNTIMELIBS +dnl ------------------------------------------------- +dnl Verify that the shared libs found so far can be used when running +dnl programs, since otherwise the situation creates odd configure errors +dnl that are misleading people. +dnl +dnl Make sure this test is run BEFORE the first test in the script that +dnl runs anything, which at the time of this writing is the AC_CHECK_SIZEOF +dnl macro. It must also run AFTER all lib-checking macros are complete. + +AC_DEFUN([CURL_VERIFY_RUNTIMELIBS], [ + + dnl this test is of course not sensible if we are cross-compiling! + if test "$cross_compiling" != "yes"; then + + dnl run a program to verify that the libs checked for previous to this + dnl point also is available runtime! + AC_MSG_CHECKING([runtime libs availability]) + CURL_RUN_IFELSE([ + int main(void) + { + return 0; + } + ], + AC_MSG_RESULT([fine]), + AC_MSG_RESULT([failed]) + AC_MSG_ERROR([one or more libs available at link-time are not available runtime. Libs used at link-time: $LIBS]) + ) + + dnl if this test fails, configure has already stopped + fi +]) + + +dnl CURL_CHECK_CA_BUNDLE +dnl ------------------------------------------------- +dnl Check if a default ca-bundle should be used +dnl +dnl regarding the paths this scans: +dnl /etc/ssl/certs/ca-certificates.crt Debian systems +dnl /etc/pki/tls/certs/ca-bundle.crt Redhat and Mandriva +dnl /usr/share/ssl/certs/ca-bundle.crt old(er) Redhat +dnl /usr/local/share/certs/ca-root-nss.crt MidnightBSD +dnl /etc/ssl/cert.pem OpenBSD, MidnightBSD (symlink) +dnl /etc/ssl/certs (CA path) SUSE, FreeBSD + +AC_DEFUN([CURL_CHECK_CA_BUNDLE], [ + + AC_MSG_CHECKING([default CA cert bundle/path]) + + AC_ARG_WITH(ca-bundle, +AS_HELP_STRING([--with-ca-bundle=FILE], + [Absolute path to a file containing CA certificates (example: /etc/ca-bundle.crt)]) +AS_HELP_STRING([--without-ca-bundle], [Do not use a default CA bundle]), + [ + want_ca="$withval" + if test "x$want_ca" = "xyes"; then + AC_MSG_ERROR([--with-ca-bundle=FILE requires a path to the CA bundle]) + fi + ], + [ want_ca="unset" ]) + AC_ARG_WITH(ca-path, +AS_HELP_STRING([--with-ca-path=DIRECTORY], + [Absolute path to a directory containing CA certificates stored individually, with \ +their filenames in a hash format. This option can be used with the OpenSSL, \ +GnuTLS, mbedTLS and wolfSSL backends. Refer to OpenSSL c_rehash for details. \ +(example: /etc/certificates)]) +AS_HELP_STRING([--without-ca-path], [Do not use a default CA path]), + [ + want_capath="$withval" + if test "x$want_capath" = "xyes"; then + AC_MSG_ERROR([--with-ca-path=DIRECTORY requires a path to the CA path directory]) + fi + ], + [ want_capath="unset"]) + + ca_warning=" (warning: certs not found)" + capath_warning=" (warning: certs not found)" + check_capath="" + + if test "$APPLE_SECTRUST_ENABLED" = "1"; then + ca_native="Apple SecTrust" + elif test "$ca_native_opt" = "1"; then + ca_native="yes" + else + ca_native="no" + fi + + if test "x$want_ca" != "xno" && test "x$want_ca" != "xunset" && + test "x$want_capath" != "xno" && test "x$want_capath" != "xunset"; then + dnl both given + ca="$want_ca" + capath="$want_capath" + elif test "x$want_ca" != "xno" && test "x$want_ca" != "xunset"; then + dnl --with-ca-bundle given + ca="$want_ca" + capath="no" + elif test "x$want_capath" != "xno" && test "x$want_capath" != "xunset"; then + dnl --with-ca-path given + capath="$want_capath" + ca="no" + elif test "$ca_native" != "no"; then + dnl native CA configured, do not look further + ca="no" + capath="no" + else + dnl First try auto-detecting a CA bundle, then a CA path. + dnl Both auto-detections can be skipped by --without-ca-* + ca="no" + capath="no" + if test "$cross_compiling" != "yes" && + test "$curl_cv_native_windows" != "yes"; then + dnl NOT cross-compiling and... + dnl neither of the --with-ca-* options are provided + if test "x$want_ca" = "xunset"; then + dnl the path we previously would have installed the curl CA bundle + dnl to, and thus we now check for an already existing cert in that + dnl place in case we find no other + if test "x$prefix" != "xNONE"; then + cac="${prefix}/share/curl/curl-ca-bundle.crt" + else + cac="$ac_default_prefix/share/curl/curl-ca-bundle.crt" + fi + + for a in /etc/ssl/certs/ca-certificates.crt \ + /etc/pki/tls/certs/ca-bundle.crt \ + /usr/share/ssl/certs/ca-bundle.crt \ + /usr/local/share/certs/ca-root-nss.crt \ + /etc/ssl/cert.pem \ + "$cac"; do + if test -f "$a"; then + ca="$a" + break + fi + done + fi + AC_MSG_NOTICE([want $want_capath CA $ca]) + if test "x$want_capath" = "xunset"; then + check_capath="/etc/ssl/certs" + fi + else + dnl no option given and cross-compiling + AC_MSG_WARN([skipped the ca-cert path detection when cross-compiling]) + fi + fi + + if test "x$ca" = "xno" || test -f "$ca"; then + ca_warning="" + fi + + if test "x$capath" != "xno"; then + check_capath="$capath" + fi + + if test -n "$check_capath"; then + for a in "$check_capath"; do + if test -d "$a" && ls "$a"/[[0-9a-f][0-9a-f][0-9a-f][0-9a-f][0-9a-f][0-9a-f][0-9a-f][0-9a-f]].0 >/dev/null 2>/dev/null; then + if test "x$capath" = "xno"; then + capath="$a" + fi + capath_warning="" + break + fi + done + fi + + if test "x$capath" = "xno"; then + capath_warning="" + fi + + if test "x$ca" != "xno"; then + CURL_CA_BUNDLE="$ca" + AC_DEFINE_UNQUOTED(CURL_CA_BUNDLE, "$ca", [Location of default CA bundle]) + AC_SUBST(CURL_CA_BUNDLE) + AC_MSG_RESULT([$ca]) + fi + if test "x$capath" != "xno"; then + CURL_CA_PATH="\"$capath\"" + AC_DEFINE_UNQUOTED(CURL_CA_PATH, "$capath", [Location of default CA path]) + AC_MSG_RESULT([$capath (capath)]) + fi + if test "x$ca" = "xno" && test "x$capath" = "xno"; then + AC_MSG_RESULT([no]) + fi + + AC_MSG_CHECKING([whether to use OpenSSL's built-in CA store]) + AC_ARG_WITH(ca-fallback, +AS_HELP_STRING([--with-ca-fallback], [Use OpenSSL's built-in CA store]) +AS_HELP_STRING([--without-ca-fallback], [Do not use OpenSSL's built-in CA store]), + [ + if test "x$with_ca_fallback" != "xyes" && test "x$with_ca_fallback" != "xno"; then + AC_MSG_ERROR([--with-ca-fallback only allows yes or no as parameter]) + fi + ], + [ with_ca_fallback="no"]) + AC_MSG_RESULT([$with_ca_fallback]) + if test "x$with_ca_fallback" = "xyes"; then + if test "$OPENSSL_ENABLED" != "1"; then + AC_MSG_ERROR([--with-ca-fallback only works with OpenSSL]) + fi + AC_DEFINE_UNQUOTED(CURL_CA_FALLBACK, 1, [define "1" to use OpenSSL's built-in CA store]) + fi +]) + + +dnl CURL_CHECK_CA_EMBED +dnl ------------------------------------------------- +dnl Check if a ca-bundle should be embedded + +AC_DEFUN([CURL_CHECK_CA_EMBED], [ + + AC_MSG_CHECKING([CA cert bundle path to embed in the curl tool]) + + AC_ARG_WITH(ca-embed, +AS_HELP_STRING([--with-ca-embed=FILE], + [Absolute path to a file containing CA certificates to embed in the curl tool (example: /etc/ca-bundle.crt)]) +AS_HELP_STRING([--without-ca-embed], [Do not embed a default CA bundle in the curl tool]), + [ + want_ca_embed="$withval" + if test "x$want_ca_embed" = "xyes"; then + AC_MSG_ERROR([--with-ca-embed=FILE requires a path to the CA bundle]) + fi + ], + [ want_ca_embed="unset" ]) + + CURL_CA_EMBED='' + if test "x$want_ca_embed" != "xno" && test "x$want_ca_embed" != "xunset" && test -f "$want_ca_embed"; then + if test -n "$PERL"; then + CURL_CA_EMBED="$want_ca_embed" + AC_SUBST(CURL_CA_EMBED) + AC_MSG_RESULT([$want_ca_embed]) + else + AC_MSG_RESULT([no]) + AC_MSG_WARN([perl was not found. Cannot do CA embed.]) + fi + else + AC_MSG_RESULT([no]) + fi +]) + +dnl CURL_CHECK_WIN32_CRYPTO +dnl ------------------------------------------------- +dnl Check if curl's Win32 crypto lib can be used + +AC_DEFUN([CURL_CHECK_WIN32_CRYPTO], [ + AC_REQUIRE([CURL_CHECK_NATIVE_WINDOWS]) + AC_MSG_CHECKING([whether build target supports Win32 crypto API]) + curl_win32_crypto_api="no" + if test "$curl_cv_native_windows" = "yes" && test "$curl_cv_winuwp" != "yes"; then + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + #undef inline + #ifndef WIN32_LEAN_AND_MEAN + #define WIN32_LEAN_AND_MEAN + #endif + #include + #include + ]],[[ + HCRYPTPROV hCryptProv; + if(CryptAcquireContext(&hCryptProv, NULL, NULL, PROV_RSA_FULL, + CRYPT_VERIFYCONTEXT | CRYPT_SILENT)) { + CryptReleaseContext(hCryptProv, 0); + } + ]]) + ],[ + curl_win32_crypto_api="yes" + ]) + fi + case "$curl_win32_crypto_api" in + yes) + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(USE_WIN32_CRYPTO, 1, + [Define to 1 if you are building a Windows target with crypto API support.]) + USE_WIN32_CRYPTO=1 + ;; + *) + AC_MSG_RESULT([no]) + ;; + esac +]) + +dnl CURL_EXPORT_PCDIR ($pcdir, [$additive]) +dnl ------------------------ +dnl if $pcdir is not empty, set PKG_CONFIG_LIBDIR to $pcdir and export. +dnl if $additive is set, extend PKG_CONFIG_PATH instead, by prepending $pcdir +dnl to it, to ensure that system locations are still checked. This is +dnl necessary for modules that depend on modules residing there +dnl (e.g. gnutls.pc). +dnl +dnl we need this macro to limit/expand search locations to/with a custom +dnl configured one. +dnl + +AC_DEFUN([CURL_EXPORT_PCDIR], [ + if test -n "$1"; then + if test -n "$2"; then + dnl honor system locations + PKG_CONFIG_PATH="$1${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + dnl ignore and override system locations + PKG_CONFIG_LIBDIR="$1" + export PKG_CONFIG_LIBDIR + fi + fi +]) + +dnl CURL_TRACE_PCDIR ($module, [$pcdir], [$additive]) +dnl ------------------------ +dnl show pkg-config module lookup details, along with a detailed errors +dnl message in case of failure. Supports both pkg-config and pkgconf. +dnl + +AC_DEFUN([CURL_TRACE_PCDIR], [ + dnl Example pkgconf line: + dnl libpkgconf/pkg.c:746 [pkgconf_pkg_t *pkgconf_pkg_try_specific_path(pkgconf_client_t *, [...]*)]: + dnl trying path: /usr/local/lib/pkgconfig for libngtcp2_crypto_gnutls + dnl Rest of strings are for catching classic pkg-config lines. + trc=`CURL_EXPORT_PCDIR([$2], [$3]) + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug $1 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=`CURL_EXPORT_PCDIR([$2], [$3]) + $PKGCONFIG --exists --print-errors $1 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + AC_MSG_NOTICE([pkg-config --exists $1 trace: +---- begin +${trc} +---- end]) +]) + +dnl CURL_CHECK_PKGCONFIG ($module, [$pcdir], [$additive]) +dnl ------------------------ +dnl search for the pkg-config tool. Set the PKGCONFIG variable to hold the +dnl path to it, or 'no' if not found/present. +dnl +dnl If pkg-config is present, check that it has info about the $module or +dnl return "no" anyway! +dnl +dnl Optionally PKG_CONFIG_LIBDIR may be given as $pcdir. +dnl + +AC_DEFUN([CURL_CHECK_PKGCONFIG], [ + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + AC_PATH_TOOL([PKGCONFIG], [pkg-config], [no], + [$PATH:/usr/bin:/usr/local/bin]) + fi + + if test "$PKGCONFIG" != "no"; then + AC_MSG_CHECKING([for $1 options with pkg-config]) + dnl ask pkg-config about $1 + itexists=`CURL_EXPORT_PCDIR([$2], [$3]) + $PKGCONFIG --exists $1 >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + dnl pkg-config does not have info about the given module! set the + dnl variable to 'no' + AC_MSG_RESULT([no]) + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + CURL_TRACE_PCDIR([$1], [$2], [$3]) + fi + PKGCONFIG="no" + else + AC_MSG_RESULT([found]) + if test -n "$CURL_TRACE_PKG_CONFIG"; then + CURL_TRACE_PCDIR([$1], [$2], [$3]) + fi + fi + fi +]) + + +dnl CURL_PREPARE_CONFIGUREHELP_PM +dnl ------------------------------------------------- +dnl Prepare test harness configurehelp.pm module, defining and +dnl initializing some perl variables with values which are known +dnl when the configure script runs. For portability reasons, test +dnl harness needs information on how to run the C preprocessor. + +AC_DEFUN([CURL_PREPARE_CONFIGUREHELP_PM], [ + AC_REQUIRE([AC_PROG_CPP]) + tmp_cpp=`eval echo "$ac_cpp" 2>/dev/null` + if test -z "$tmp_cpp"; then + tmp_cpp='cpp' + fi + AC_SUBST(CURL_CPP, $tmp_cpp) +]) + + +dnl CURL_PREPARE_BUILDINFO +dnl ------------------------------------------------- +dnl Save build info for test runner to pick up and log + +AC_DEFUN([CURL_PREPARE_BUILDINFO], [ + curl_pflags="" + if test "$curl_cv_apple" = "yes"; then + curl_pflags="${curl_pflags} APPLE" + fi + case $host in + *-*-*bsd*|*-*-aix*|*-*-hpux*|*-*-interix*|*-*-irix*|*-*-linux*|*-*-solaris*|*-*-sunos*|*-apple-*|*-*-cygwin*|*-*-msys*) + curl_pflags="${curl_pflags} UNIX";; + esac + case $host in + *-*-*bsd*) + curl_pflags="${curl_pflags} BSD";; + esac + if test "$curl_cv_android" = "yes"; then + curl_pflags="${curl_pflags} ANDROID" + ANDROID_PLATFORM_LEVEL=`echo "$host_os" | $SED -ne 's/.*android\(@<:@0-9@:>@*\).*/\1/p'` + if test -n "${ANDROID_PLATFORM_LEVEL}"; then + curl_pflags="${curl_pflags}-${ANDROID_PLATFORM_LEVEL}" + fi + fi + if test "$curl_cv_native_windows" = "yes"; then + curl_pflags="${curl_pflags} WIN32" + fi + if test "$curl_cv_winuwp" = "yes"; then + curl_pflags="${curl_pflags} UWP" + fi + case $host_os in + cygwin*|msys*) curl_pflags="${curl_pflags} CYGWIN";; + esac + case $host_os in + msdos*) curl_pflags="${curl_pflags} DOS";; + amiga*) curl_pflags="${curl_pflags} AMIGA";; + esac + if test "$compiler_id" = "GNU_C"; then + curl_pflags="${curl_pflags} GCC" + fi + if test "$compiler_id" = "APPLECLANG"; then + curl_pflags="${curl_pflags} APPLE-CLANG" + elif test "$compiler_id" = "CLANG"; then + curl_pflags="${curl_pflags} LLVM-CLANG" + fi + case $host_os in + mingw*) curl_pflags="${curl_pflags} MINGW";; + esac + if test "$cross_compiling" = "yes"; then + curl_pflags="${curl_pflags} CROSS" + fi + squeeze curl_pflags + curl_buildinfo=" +buildinfo.configure.tool: configure +buildinfo.configure.args: $ac_configure_args +buildinfo.host: $build +buildinfo.host.cpu: $build_cpu +buildinfo.host.os: $build_os +buildinfo.target: $host +buildinfo.target.cpu: $host_cpu +buildinfo.target.os: $host_os +buildinfo.target.flags: $curl_pflags +buildinfo.compiler: $compiler_id +buildinfo.compiler.version: $compiler_ver +buildinfo.sysroot: $lt_sysroot" +]) + + +dnl CURL_CPP_P +dnl +dnl Check if $cpp -P should be used for extract define values due to gcc 5 +dnl splitting up strings and defines between line outputs. gcc by default +dnl (without -P) shows TEST EINVAL TEST as +dnl +dnl # 13 "conftest.c" +dnl TEST +dnl # 13 "conftest.c" 3 4 +dnl 22 +dnl # 13 "conftest.c" +dnl TEST + +AC_DEFUN([CURL_CPP_P], [ + AC_MSG_CHECKING([if cpp -P is needed]) + AC_EGREP_CPP([TEST.*TEST], [ + #include +TEST EINVAL TEST + ], [cpp=no], [cpp=yes]) + AC_MSG_RESULT([$cpp]) + + dnl we need cpp -P so check if it works then + if test "$cpp" = "yes"; then + AC_MSG_CHECKING([if cpp -P works]) + OLDCPPFLAGS=$CPPFLAGS + CPPFLAGS="$CPPFLAGS -P" + AC_EGREP_CPP([TEST.*TEST], [ + #include +TEST EINVAL TEST + ], [cpp_p=yes], [cpp_p=no]) + AC_MSG_RESULT([$cpp_p]) + + if test "$cpp_p" = "no"; then + AC_MSG_WARN([failed to figure out cpp -P alternative]) + dnl without -P + CPPPFLAG="" + else + dnl with -P + CPPPFLAG="-P" + fi + dnl restore CPPFLAGS + CPPFLAGS=$OLDCPPFLAGS + else + dnl without -P + CPPPFLAG="" + fi +]) + + +dnl CURL_DARWIN_CFLAGS +dnl +dnl Set -Werror=partial-availability to detect possible breaking code +dnl with low deployment targets. +dnl + +AC_DEFUN([CURL_DARWIN_CFLAGS], [ + old_CFLAGS=$CFLAGS + CFLAGS="$CFLAGS -Werror=partial-availability" + AC_MSG_CHECKING([whether $CC accepts -Werror=partial-availability]) + AC_COMPILE_IFELSE([AC_LANG_PROGRAM()], + [AC_MSG_RESULT([yes])], + [AC_MSG_RESULT([no]) + CFLAGS=$old_CFLAGS]) +]) + + +dnl CURL_SUPPORTS_BUILTIN_AVAILABLE +dnl +dnl Check to see if the compiler supports __builtin_available. This built-in +dnl compiler function first appeared in Apple LLVM 9.0.0. It is so new that, at +dnl the time this macro was written, the function was not yet documented. Its +dnl purpose is to return true if the code is running under a certain OS version +dnl or later. + +AC_DEFUN([CURL_SUPPORTS_BUILTIN_AVAILABLE], [ + AC_MSG_CHECKING([to see if the compiler supports __builtin_available()]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + ]],[[ + if(__builtin_available(macOS 10.12, iOS 5.0, *)) {} + ]]) + ],[ + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_BUILTIN_AVAILABLE, 1, + [Define to 1 if you have the __builtin_available function.]) + ],[ + AC_MSG_RESULT([no]) + ]) +]) diff --git a/3rdparty/curl-8.21.0/aclocal.m4 b/3rdparty/curl-8.21.0/aclocal.m4 new file mode 100644 index 0000000000..f1732513d5 --- /dev/null +++ b/3rdparty/curl-8.21.0/aclocal.m4 @@ -0,0 +1,1249 @@ +# generated automatically by aclocal 1.16.5 -*- Autoconf -*- + +# Copyright (C) 1996-2021 Free Software Foundation, Inc. + +# This file is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY, to the extent permitted by law; without +# even the implied warranty of MERCHANTABILITY or FITNESS FOR A +# PARTICULAR PURPOSE. + +m4_ifndef([AC_CONFIG_MACRO_DIRS], [m4_defun([_AM_CONFIG_MACRO_DIRS], [])m4_defun([AC_CONFIG_MACRO_DIRS], [_AM_CONFIG_MACRO_DIRS($@)])]) +m4_ifndef([AC_AUTOCONF_VERSION], + [m4_copy([m4_PACKAGE_VERSION], [AC_AUTOCONF_VERSION])])dnl +m4_if(m4_defn([AC_AUTOCONF_VERSION]), [2.71],, +[m4_warning([this file was generated for autoconf 2.71. +You have another version of autoconf. It may work, but is not guaranteed to. +If you have problems, you may need to regenerate the build system entirely. +To do so, use the procedure documented by the package, typically 'autoreconf'.])]) + +# Copyright (C) 2002-2021 Free Software Foundation, Inc. +# +# This file is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# AM_AUTOMAKE_VERSION(VERSION) +# ---------------------------- +# Automake X.Y traces this macro to ensure aclocal.m4 has been +# generated from the m4 files accompanying Automake X.Y. +# (This private macro should not be called outside this file.) +AC_DEFUN([AM_AUTOMAKE_VERSION], +[am__api_version='1.16' +dnl Some users find AM_AUTOMAKE_VERSION and mistake it for a way to +dnl require some minimum version. Point them to the right macro. +m4_if([$1], [1.16.5], [], + [AC_FATAL([Do not call $0, use AM_INIT_AUTOMAKE([$1]).])])dnl +]) + +# _AM_AUTOCONF_VERSION(VERSION) +# ----------------------------- +# aclocal traces this macro to find the Autoconf version. +# This is a private macro too. Using m4_define simplifies +# the logic in aclocal, which can simply ignore this definition. +m4_define([_AM_AUTOCONF_VERSION], []) + +# AM_SET_CURRENT_AUTOMAKE_VERSION +# ------------------------------- +# Call AM_AUTOMAKE_VERSION and AM_AUTOMAKE_VERSION so they can be traced. +# This function is AC_REQUIREd by AM_INIT_AUTOMAKE. +AC_DEFUN([AM_SET_CURRENT_AUTOMAKE_VERSION], +[AM_AUTOMAKE_VERSION([1.16.5])dnl +m4_ifndef([AC_AUTOCONF_VERSION], + [m4_copy([m4_PACKAGE_VERSION], [AC_AUTOCONF_VERSION])])dnl +_AM_AUTOCONF_VERSION(m4_defn([AC_AUTOCONF_VERSION]))]) + +# AM_AUX_DIR_EXPAND -*- Autoconf -*- + +# Copyright (C) 2001-2021 Free Software Foundation, Inc. +# +# This file is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# For projects using AC_CONFIG_AUX_DIR([foo]), Autoconf sets +# $ac_aux_dir to '$srcdir/foo'. In other projects, it is set to +# '$srcdir', '$srcdir/..', or '$srcdir/../..'. +# +# Of course, Automake must honor this variable whenever it calls a +# tool from the auxiliary directory. The problem is that $srcdir (and +# therefore $ac_aux_dir as well) can be either absolute or relative, +# depending on how configure is run. This is pretty annoying, since +# it makes $ac_aux_dir quite unusable in subdirectories: in the top +# source directory, any form will work fine, but in subdirectories a +# relative path needs to be adjusted first. +# +# $ac_aux_dir/missing +# fails when called from a subdirectory if $ac_aux_dir is relative +# $top_srcdir/$ac_aux_dir/missing +# fails if $ac_aux_dir is absolute, +# fails when called from a subdirectory in a VPATH build with +# a relative $ac_aux_dir +# +# The reason of the latter failure is that $top_srcdir and $ac_aux_dir +# are both prefixed by $srcdir. In an in-source build this is usually +# harmless because $srcdir is '.', but things will broke when you +# start a VPATH build or use an absolute $srcdir. +# +# So we could use something similar to $top_srcdir/$ac_aux_dir/missing, +# iff we strip the leading $srcdir from $ac_aux_dir. That would be: +# am_aux_dir='\$(top_srcdir)/'`expr "$ac_aux_dir" : "$srcdir//*\(.*\)"` +# and then we would define $MISSING as +# MISSING="\${SHELL} $am_aux_dir/missing" +# This will work as long as MISSING is not called from configure, because +# unfortunately $(top_srcdir) has no meaning in configure. +# However there are other variables, like CC, which are often used in +# configure, and could therefore not use this "fixed" $ac_aux_dir. +# +# Another solution, used here, is to always expand $ac_aux_dir to an +# absolute PATH. The drawback is that using absolute paths prevent a +# configured tree to be moved without reconfiguration. + +AC_DEFUN([AM_AUX_DIR_EXPAND], +[AC_REQUIRE([AC_CONFIG_AUX_DIR_DEFAULT])dnl +# Expand $ac_aux_dir to an absolute path. +am_aux_dir=`cd "$ac_aux_dir" && pwd` +]) + +# AM_COND_IF -*- Autoconf -*- + +# Copyright (C) 2008-2021 Free Software Foundation, Inc. +# +# This file is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# _AM_COND_IF +# _AM_COND_ELSE +# _AM_COND_ENDIF +# -------------- +# These macros are only used for tracing. +m4_define([_AM_COND_IF]) +m4_define([_AM_COND_ELSE]) +m4_define([_AM_COND_ENDIF]) + +# AM_COND_IF(COND, [IF-TRUE], [IF-FALSE]) +# --------------------------------------- +# If the shell condition COND is true, execute IF-TRUE, otherwise execute +# IF-FALSE. Allow automake to learn about conditional instantiating macros +# (the AC_CONFIG_FOOS). +AC_DEFUN([AM_COND_IF], +[m4_ifndef([_AM_COND_VALUE_$1], + [m4_fatal([$0: no such condition "$1"])])dnl +_AM_COND_IF([$1])dnl +if test -z "$$1_TRUE"; then : + m4_n([$2])[]dnl +m4_ifval([$3], +[_AM_COND_ELSE([$1])dnl +else + $3 +])dnl +_AM_COND_ENDIF([$1])dnl +fi[]dnl +]) + +# AM_CONDITIONAL -*- Autoconf -*- + +# Copyright (C) 1997-2021 Free Software Foundation, Inc. +# +# This file is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# AM_CONDITIONAL(NAME, SHELL-CONDITION) +# ------------------------------------- +# Define a conditional. +AC_DEFUN([AM_CONDITIONAL], +[AC_PREREQ([2.52])dnl + m4_if([$1], [TRUE], [AC_FATAL([$0: invalid condition: $1])], + [$1], [FALSE], [AC_FATAL([$0: invalid condition: $1])])dnl +AC_SUBST([$1_TRUE])dnl +AC_SUBST([$1_FALSE])dnl +_AM_SUBST_NOTMAKE([$1_TRUE])dnl +_AM_SUBST_NOTMAKE([$1_FALSE])dnl +m4_define([_AM_COND_VALUE_$1], [$2])dnl +if $2; then + $1_TRUE= + $1_FALSE='#' +else + $1_TRUE='#' + $1_FALSE= +fi +AC_CONFIG_COMMANDS_PRE( +[if test -z "${$1_TRUE}" && test -z "${$1_FALSE}"; then + AC_MSG_ERROR([[conditional "$1" was never defined. +Usually this means the macro was only invoked conditionally.]]) +fi])]) + +# Copyright (C) 1999-2021 Free Software Foundation, Inc. +# +# This file is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + + +# There are a few dirty hacks below to avoid letting 'AC_PROG_CC' be +# written in clear, in which case automake, when reading aclocal.m4, +# will think it sees a *use*, and therefore will trigger all it's +# C support machinery. Also note that it means that autoscan, seeing +# CC etc. in the Makefile, will ask for an AC_PROG_CC use... + + +# _AM_DEPENDENCIES(NAME) +# ---------------------- +# See how the compiler implements dependency checking. +# NAME is "CC", "CXX", "OBJC", "OBJCXX", "UPC", or "GJC". +# We try a few techniques and use that to set a single cache variable. +# +# We don't AC_REQUIRE the corresponding AC_PROG_CC since the latter was +# modified to invoke _AM_DEPENDENCIES(CC); we would have a circular +# dependency, and given that the user is not expected to run this macro, +# just rely on AC_PROG_CC. +AC_DEFUN([_AM_DEPENDENCIES], +[AC_REQUIRE([AM_SET_DEPDIR])dnl +AC_REQUIRE([AM_OUTPUT_DEPENDENCY_COMMANDS])dnl +AC_REQUIRE([AM_MAKE_INCLUDE])dnl +AC_REQUIRE([AM_DEP_TRACK])dnl + +m4_if([$1], [CC], [depcc="$CC" am_compiler_list=], + [$1], [CXX], [depcc="$CXX" am_compiler_list=], + [$1], [OBJC], [depcc="$OBJC" am_compiler_list='gcc3 gcc'], + [$1], [OBJCXX], [depcc="$OBJCXX" am_compiler_list='gcc3 gcc'], + [$1], [UPC], [depcc="$UPC" am_compiler_list=], + [$1], [GCJ], [depcc="$GCJ" am_compiler_list='gcc3 gcc'], + [depcc="$$1" am_compiler_list=]) + +AC_CACHE_CHECK([dependency style of $depcc], + [am_cv_$1_dependencies_compiler_type], +[if test -z "$AMDEP_TRUE" && test -f "$am_depcomp"; then + # We make a subdir and do the tests there. Otherwise we can end up + # making bogus files that we don't know about and never remove. For + # instance it was reported that on HP-UX the gcc test will end up + # making a dummy file named 'D' -- because '-MD' means "put the output + # in D". + rm -rf conftest.dir + mkdir conftest.dir + # Copy depcomp to subdir because otherwise we won't find it if we're + # using a relative directory. + cp "$am_depcomp" conftest.dir + cd conftest.dir + # We will build objects and dependencies in a subdirectory because + # it helps to detect inapplicable dependency modes. For instance + # both Tru64's cc and ICC support -MD to output dependencies as a + # side effect of compilation, but ICC will put the dependencies in + # the current directory while Tru64 will put them in the object + # directory. + mkdir sub + + am_cv_$1_dependencies_compiler_type=none + if test "$am_compiler_list" = ""; then + am_compiler_list=`sed -n ['s/^#*\([a-zA-Z0-9]*\))$/\1/p'] < ./depcomp` + fi + am__universal=false + m4_case([$1], [CC], + [case " $depcc " in #( + *\ -arch\ *\ -arch\ *) am__universal=true ;; + esac], + [CXX], + [case " $depcc " in #( + *\ -arch\ *\ -arch\ *) am__universal=true ;; + esac]) + + for depmode in $am_compiler_list; do + # Setup a source with many dependencies, because some compilers + # like to wrap large dependency lists on column 80 (with \), and + # we should not choose a depcomp mode which is confused by this. + # + # We need to recreate these files for each test, as the compiler may + # overwrite some of them when testing with obscure command lines. + # This happens at least with the AIX C compiler. + : > sub/conftest.c + for i in 1 2 3 4 5 6; do + echo '#include "conftst'$i'.h"' >> sub/conftest.c + # Using ": > sub/conftst$i.h" creates only sub/conftst1.h with + # Solaris 10 /bin/sh. + echo '/* dummy */' > sub/conftst$i.h + done + echo "${am__include} ${am__quote}sub/conftest.Po${am__quote}" > confmf + + # We check with '-c' and '-o' for the sake of the "dashmstdout" + # mode. It turns out that the SunPro C++ compiler does not properly + # handle '-M -o', and we need to detect this. Also, some Intel + # versions had trouble with output in subdirs. + am__obj=sub/conftest.${OBJEXT-o} + am__minus_obj="-o $am__obj" + case $depmode in + gcc) + # This depmode causes a compiler race in universal mode. + test "$am__universal" = false || continue + ;; + nosideeffect) + # After this tag, mechanisms are not by side-effect, so they'll + # only be used when explicitly requested. + if test "x$enable_dependency_tracking" = xyes; then + continue + else + break + fi + ;; + msvc7 | msvc7msys | msvisualcpp | msvcmsys) + # This compiler won't grok '-c -o', but also, the minuso test has + # not run yet. These depmodes are late enough in the game, and + # so weak that their functioning should not be impacted. + am__obj=conftest.${OBJEXT-o} + am__minus_obj= + ;; + none) break ;; + esac + if depmode=$depmode \ + source=sub/conftest.c object=$am__obj \ + depfile=sub/conftest.Po tmpdepfile=sub/conftest.TPo \ + $SHELL ./depcomp $depcc -c $am__minus_obj sub/conftest.c \ + >/dev/null 2>conftest.err && + grep sub/conftst1.h sub/conftest.Po > /dev/null 2>&1 && + grep sub/conftst6.h sub/conftest.Po > /dev/null 2>&1 && + grep $am__obj sub/conftest.Po > /dev/null 2>&1 && + ${MAKE-make} -s -f confmf > /dev/null 2>&1; then + # icc doesn't choke on unknown options, it will just issue warnings + # or remarks (even with -Werror). So we grep stderr for any message + # that says an option was ignored or not supported. + # When given -MP, icc 7.0 and 7.1 complain thusly: + # icc: Command line warning: ignoring option '-M'; no argument required + # The diagnosis changed in icc 8.0: + # icc: Command line remark: option '-MP' not supported + if (grep 'ignoring option' conftest.err || + grep 'not supported' conftest.err) >/dev/null 2>&1; then :; else + am_cv_$1_dependencies_compiler_type=$depmode + break + fi + fi + done + + cd .. + rm -rf conftest.dir +else + am_cv_$1_dependencies_compiler_type=none +fi +]) +AC_SUBST([$1DEPMODE], [depmode=$am_cv_$1_dependencies_compiler_type]) +AM_CONDITIONAL([am__fastdep$1], [ + test "x$enable_dependency_tracking" != xno \ + && test "$am_cv_$1_dependencies_compiler_type" = gcc3]) +]) + + +# AM_SET_DEPDIR +# ------------- +# Choose a directory name for dependency files. +# This macro is AC_REQUIREd in _AM_DEPENDENCIES. +AC_DEFUN([AM_SET_DEPDIR], +[AC_REQUIRE([AM_SET_LEADING_DOT])dnl +AC_SUBST([DEPDIR], ["${am__leading_dot}deps"])dnl +]) + + +# AM_DEP_TRACK +# ------------ +AC_DEFUN([AM_DEP_TRACK], +[AC_ARG_ENABLE([dependency-tracking], [dnl +AS_HELP_STRING( + [--enable-dependency-tracking], + [do not reject slow dependency extractors]) +AS_HELP_STRING( + [--disable-dependency-tracking], + [speeds up one-time build])]) +if test "x$enable_dependency_tracking" != xno; then + am_depcomp="$ac_aux_dir/depcomp" + AMDEPBACKSLASH='\' + am__nodep='_no' +fi +AM_CONDITIONAL([AMDEP], [test "x$enable_dependency_tracking" != xno]) +AC_SUBST([AMDEPBACKSLASH])dnl +_AM_SUBST_NOTMAKE([AMDEPBACKSLASH])dnl +AC_SUBST([am__nodep])dnl +_AM_SUBST_NOTMAKE([am__nodep])dnl +]) + +# Generate code to set up dependency tracking. -*- Autoconf -*- + +# Copyright (C) 1999-2021 Free Software Foundation, Inc. +# +# This file is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# _AM_OUTPUT_DEPENDENCY_COMMANDS +# ------------------------------ +AC_DEFUN([_AM_OUTPUT_DEPENDENCY_COMMANDS], +[{ + # Older Autoconf quotes --file arguments for eval, but not when files + # are listed without --file. Let's play safe and only enable the eval + # if we detect the quoting. + # TODO: see whether this extra hack can be removed once we start + # requiring Autoconf 2.70 or later. + AS_CASE([$CONFIG_FILES], + [*\'*], [eval set x "$CONFIG_FILES"], + [*], [set x $CONFIG_FILES]) + shift + # Used to flag and report bootstrapping failures. + am_rc=0 + for am_mf + do + # Strip MF so we end up with the name of the file. + am_mf=`AS_ECHO(["$am_mf"]) | sed -e 's/:.*$//'` + # Check whether this is an Automake generated Makefile which includes + # dependency-tracking related rules and includes. + # Grep'ing the whole file directly is not great: AIX grep has a line + # limit of 2048, but all sed's we know have understand at least 4000. + sed -n 's,^am--depfiles:.*,X,p' "$am_mf" | grep X >/dev/null 2>&1 \ + || continue + am_dirpart=`AS_DIRNAME(["$am_mf"])` + am_filepart=`AS_BASENAME(["$am_mf"])` + AM_RUN_LOG([cd "$am_dirpart" \ + && sed -e '/# am--include-marker/d' "$am_filepart" \ + | $MAKE -f - am--depfiles]) || am_rc=$? + done + if test $am_rc -ne 0; then + AC_MSG_FAILURE([Something went wrong bootstrapping makefile fragments + for automatic dependency tracking. If GNU make was not used, consider + re-running the configure script with MAKE="gmake" (or whatever is + necessary). You can also try re-running configure with the + '--disable-dependency-tracking' option to at least be able to build + the package (albeit without support for automatic dependency tracking).]) + fi + AS_UNSET([am_dirpart]) + AS_UNSET([am_filepart]) + AS_UNSET([am_mf]) + AS_UNSET([am_rc]) + rm -f conftest-deps.mk +} +])# _AM_OUTPUT_DEPENDENCY_COMMANDS + + +# AM_OUTPUT_DEPENDENCY_COMMANDS +# ----------------------------- +# This macro should only be invoked once -- use via AC_REQUIRE. +# +# This code is only required when automatic dependency tracking is enabled. +# This creates each '.Po' and '.Plo' makefile fragment that we'll need in +# order to bootstrap the dependency handling code. +AC_DEFUN([AM_OUTPUT_DEPENDENCY_COMMANDS], +[AC_CONFIG_COMMANDS([depfiles], + [test x"$AMDEP_TRUE" != x"" || _AM_OUTPUT_DEPENDENCY_COMMANDS], + [AMDEP_TRUE="$AMDEP_TRUE" MAKE="${MAKE-make}"])]) + +# Do all the work for Automake. -*- Autoconf -*- + +# Copyright (C) 1996-2021 Free Software Foundation, Inc. +# +# This file is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# This macro actually does too much. Some checks are only needed if +# your package does certain things. But this isn't really a big deal. + +dnl Redefine AC_PROG_CC to automatically invoke _AM_PROG_CC_C_O. +m4_define([AC_PROG_CC], +m4_defn([AC_PROG_CC]) +[_AM_PROG_CC_C_O +]) + +# AM_INIT_AUTOMAKE(PACKAGE, VERSION, [NO-DEFINE]) +# AM_INIT_AUTOMAKE([OPTIONS]) +# ----------------------------------------------- +# The call with PACKAGE and VERSION arguments is the old style +# call (pre autoconf-2.50), which is being phased out. PACKAGE +# and VERSION should now be passed to AC_INIT and removed from +# the call to AM_INIT_AUTOMAKE. +# We support both call styles for the transition. After +# the next Automake release, Autoconf can make the AC_INIT +# arguments mandatory, and then we can depend on a new Autoconf +# release and drop the old call support. +AC_DEFUN([AM_INIT_AUTOMAKE], +[AC_PREREQ([2.65])dnl +m4_ifdef([_$0_ALREADY_INIT], + [m4_fatal([$0 expanded multiple times +]m4_defn([_$0_ALREADY_INIT]))], + [m4_define([_$0_ALREADY_INIT], m4_expansion_stack)])dnl +dnl Autoconf wants to disallow AM_ names. We explicitly allow +dnl the ones we care about. +m4_pattern_allow([^AM_[A-Z]+FLAGS$])dnl +AC_REQUIRE([AM_SET_CURRENT_AUTOMAKE_VERSION])dnl +AC_REQUIRE([AC_PROG_INSTALL])dnl +if test "`cd $srcdir && pwd`" != "`pwd`"; then + # Use -I$(srcdir) only when $(srcdir) != ., so that make's output + # is not polluted with repeated "-I." + AC_SUBST([am__isrc], [' -I$(srcdir)'])_AM_SUBST_NOTMAKE([am__isrc])dnl + # test to see if srcdir already configured + if test -f $srcdir/config.status; then + AC_MSG_ERROR([source directory already configured; run "make distclean" there first]) + fi +fi + +# test whether we have cygpath +if test -z "$CYGPATH_W"; then + if (cygpath --version) >/dev/null 2>/dev/null; then + CYGPATH_W='cygpath -w' + else + CYGPATH_W=echo + fi +fi +AC_SUBST([CYGPATH_W]) + +# Define the identity of the package. +dnl Distinguish between old-style and new-style calls. +m4_ifval([$2], +[AC_DIAGNOSE([obsolete], + [$0: two- and three-arguments forms are deprecated.]) +m4_ifval([$3], [_AM_SET_OPTION([no-define])])dnl + AC_SUBST([PACKAGE], [$1])dnl + AC_SUBST([VERSION], [$2])], +[_AM_SET_OPTIONS([$1])dnl +dnl Diagnose old-style AC_INIT with new-style AM_AUTOMAKE_INIT. +m4_if( + m4_ifset([AC_PACKAGE_NAME], [ok]):m4_ifset([AC_PACKAGE_VERSION], [ok]), + [ok:ok],, + [m4_fatal([AC_INIT should be called with package and version arguments])])dnl + AC_SUBST([PACKAGE], ['AC_PACKAGE_TARNAME'])dnl + AC_SUBST([VERSION], ['AC_PACKAGE_VERSION'])])dnl + +_AM_IF_OPTION([no-define],, +[AC_DEFINE_UNQUOTED([PACKAGE], ["$PACKAGE"], [Name of package]) + AC_DEFINE_UNQUOTED([VERSION], ["$VERSION"], [Version number of package])])dnl + +# Some tools Automake needs. +AC_REQUIRE([AM_SANITY_CHECK])dnl +AC_REQUIRE([AC_ARG_PROGRAM])dnl +AM_MISSING_PROG([ACLOCAL], [aclocal-${am__api_version}]) +AM_MISSING_PROG([AUTOCONF], [autoconf]) +AM_MISSING_PROG([AUTOMAKE], [automake-${am__api_version}]) +AM_MISSING_PROG([AUTOHEADER], [autoheader]) +AM_MISSING_PROG([MAKEINFO], [makeinfo]) +AC_REQUIRE([AM_PROG_INSTALL_SH])dnl +AC_REQUIRE([AM_PROG_INSTALL_STRIP])dnl +AC_REQUIRE([AC_PROG_MKDIR_P])dnl +# For better backward compatibility. To be removed once Automake 1.9.x +# dies out for good. For more background, see: +# +# +AC_SUBST([mkdir_p], ['$(MKDIR_P)']) +# We need awk for the "check" target (and possibly the TAP driver). The +# system "awk" is bad on some platforms. +AC_REQUIRE([AC_PROG_AWK])dnl +AC_REQUIRE([AC_PROG_MAKE_SET])dnl +AC_REQUIRE([AM_SET_LEADING_DOT])dnl +_AM_IF_OPTION([tar-ustar], [_AM_PROG_TAR([ustar])], + [_AM_IF_OPTION([tar-pax], [_AM_PROG_TAR([pax])], + [_AM_PROG_TAR([v7])])]) +_AM_IF_OPTION([no-dependencies],, +[AC_PROVIDE_IFELSE([AC_PROG_CC], + [_AM_DEPENDENCIES([CC])], + [m4_define([AC_PROG_CC], + m4_defn([AC_PROG_CC])[_AM_DEPENDENCIES([CC])])])dnl +AC_PROVIDE_IFELSE([AC_PROG_CXX], + [_AM_DEPENDENCIES([CXX])], + [m4_define([AC_PROG_CXX], + m4_defn([AC_PROG_CXX])[_AM_DEPENDENCIES([CXX])])])dnl +AC_PROVIDE_IFELSE([AC_PROG_OBJC], + [_AM_DEPENDENCIES([OBJC])], + [m4_define([AC_PROG_OBJC], + m4_defn([AC_PROG_OBJC])[_AM_DEPENDENCIES([OBJC])])])dnl +AC_PROVIDE_IFELSE([AC_PROG_OBJCXX], + [_AM_DEPENDENCIES([OBJCXX])], + [m4_define([AC_PROG_OBJCXX], + m4_defn([AC_PROG_OBJCXX])[_AM_DEPENDENCIES([OBJCXX])])])dnl +]) +# Variables for tags utilities; see am/tags.am +if test -z "$CTAGS"; then + CTAGS=ctags +fi +AC_SUBST([CTAGS]) +if test -z "$ETAGS"; then + ETAGS=etags +fi +AC_SUBST([ETAGS]) +if test -z "$CSCOPE"; then + CSCOPE=cscope +fi +AC_SUBST([CSCOPE]) + +AC_REQUIRE([AM_SILENT_RULES])dnl +dnl The testsuite driver may need to know about EXEEXT, so add the +dnl 'am__EXEEXT' conditional if _AM_COMPILER_EXEEXT was seen. This +dnl macro is hooked onto _AC_COMPILER_EXEEXT early, see below. +AC_CONFIG_COMMANDS_PRE(dnl +[m4_provide_if([_AM_COMPILER_EXEEXT], + [AM_CONDITIONAL([am__EXEEXT], [test -n "$EXEEXT"])])])dnl + +# POSIX will say in a future version that running "rm -f" with no argument +# is OK; and we want to be able to make that assumption in our Makefile +# recipes. So use an aggressive probe to check that the usage we want is +# actually supported "in the wild" to an acceptable degree. +# See automake bug#10828. +# To make any issue more visible, cause the running configure to be aborted +# by default if the 'rm' program in use doesn't match our expectations; the +# user can still override this though. +if rm -f && rm -fr && rm -rf; then : OK; else + cat >&2 <<'END' +Oops! + +Your 'rm' program seems unable to run without file operands specified +on the command line, even when the '-f' option is present. This is contrary +to the behaviour of most rm programs out there, and not conforming with +the upcoming POSIX standard: + +Please tell bug-automake@gnu.org about your system, including the value +of your $PATH and any error possibly output before this message. This +can help us improve future automake versions. + +END + if test x"$ACCEPT_INFERIOR_RM_PROGRAM" = x"yes"; then + echo 'Configuration will proceed anyway, since you have set the' >&2 + echo 'ACCEPT_INFERIOR_RM_PROGRAM variable to "yes"' >&2 + echo >&2 + else + cat >&2 <<'END' +Aborting the configuration process, to ensure you take notice of the issue. + +You can download and install GNU coreutils to get an 'rm' implementation +that behaves properly: . + +If you want to complete the configuration process using your problematic +'rm' anyway, export the environment variable ACCEPT_INFERIOR_RM_PROGRAM +to "yes", and re-run configure. + +END + AC_MSG_ERROR([Your 'rm' program is bad, sorry.]) + fi +fi +dnl The trailing newline in this macro's definition is deliberate, for +dnl backward compatibility and to allow trailing 'dnl'-style comments +dnl after the AM_INIT_AUTOMAKE invocation. See automake bug#16841. +]) + +dnl Hook into '_AC_COMPILER_EXEEXT' early to learn its expansion. Do not +dnl add the conditional right here, as _AC_COMPILER_EXEEXT may be further +dnl mangled by Autoconf and run in a shell conditional statement. +m4_define([_AC_COMPILER_EXEEXT], +m4_defn([_AC_COMPILER_EXEEXT])[m4_provide([_AM_COMPILER_EXEEXT])]) + +# When config.status generates a header, we must update the stamp-h file. +# This file resides in the same directory as the config header +# that is generated. The stamp files are numbered to have different names. + +# Autoconf calls _AC_AM_CONFIG_HEADER_HOOK (when defined) in the +# loop where config.status creates the headers, so we can generate +# our stamp files there. +AC_DEFUN([_AC_AM_CONFIG_HEADER_HOOK], +[# Compute $1's index in $config_headers. +_am_arg=$1 +_am_stamp_count=1 +for _am_header in $config_headers :; do + case $_am_header in + $_am_arg | $_am_arg:* ) + break ;; + * ) + _am_stamp_count=`expr $_am_stamp_count + 1` ;; + esac +done +echo "timestamp for $_am_arg" >`AS_DIRNAME(["$_am_arg"])`/stamp-h[]$_am_stamp_count]) + +# Copyright (C) 2001-2021 Free Software Foundation, Inc. +# +# This file is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# AM_PROG_INSTALL_SH +# ------------------ +# Define $install_sh. +AC_DEFUN([AM_PROG_INSTALL_SH], +[AC_REQUIRE([AM_AUX_DIR_EXPAND])dnl +if test x"${install_sh+set}" != xset; then + case $am_aux_dir in + *\ * | *\ *) + install_sh="\${SHELL} '$am_aux_dir/install-sh'" ;; + *) + install_sh="\${SHELL} $am_aux_dir/install-sh" + esac +fi +AC_SUBST([install_sh])]) + +# Copyright (C) 2003-2021 Free Software Foundation, Inc. +# +# This file is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# Check whether the underlying file-system supports filenames +# with a leading dot. For instance MS-DOS doesn't. +AC_DEFUN([AM_SET_LEADING_DOT], +[rm -rf .tst 2>/dev/null +mkdir .tst 2>/dev/null +if test -d .tst; then + am__leading_dot=. +else + am__leading_dot=_ +fi +rmdir .tst 2>/dev/null +AC_SUBST([am__leading_dot])]) + +# Add --enable-maintainer-mode option to configure. -*- Autoconf -*- +# From Jim Meyering + +# Copyright (C) 1996-2021 Free Software Foundation, Inc. +# +# This file is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# AM_MAINTAINER_MODE([DEFAULT-MODE]) +# ---------------------------------- +# Control maintainer-specific portions of Makefiles. +# Default is to disable them, unless 'enable' is passed literally. +# For symmetry, 'disable' may be passed as well. Anyway, the user +# can override the default with the --enable/--disable switch. +AC_DEFUN([AM_MAINTAINER_MODE], +[m4_case(m4_default([$1], [disable]), + [enable], [m4_define([am_maintainer_other], [disable])], + [disable], [m4_define([am_maintainer_other], [enable])], + [m4_define([am_maintainer_other], [enable]) + m4_warn([syntax], [unexpected argument to AM@&t@_MAINTAINER_MODE: $1])]) +AC_MSG_CHECKING([whether to enable maintainer-specific portions of Makefiles]) + dnl maintainer-mode's default is 'disable' unless 'enable' is passed + AC_ARG_ENABLE([maintainer-mode], + [AS_HELP_STRING([--]am_maintainer_other[-maintainer-mode], + am_maintainer_other[ make rules and dependencies not useful + (and sometimes confusing) to the casual installer])], + [USE_MAINTAINER_MODE=$enableval], + [USE_MAINTAINER_MODE=]m4_if(am_maintainer_other, [enable], [no], [yes])) + AC_MSG_RESULT([$USE_MAINTAINER_MODE]) + AM_CONDITIONAL([MAINTAINER_MODE], [test $USE_MAINTAINER_MODE = yes]) + MAINT=$MAINTAINER_MODE_TRUE + AC_SUBST([MAINT])dnl +] +) + +# Check to see how 'make' treats includes. -*- Autoconf -*- + +# Copyright (C) 2001-2021 Free Software Foundation, Inc. +# +# This file is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# AM_MAKE_INCLUDE() +# ----------------- +# Check whether make has an 'include' directive that can support all +# the idioms we need for our automatic dependency tracking code. +AC_DEFUN([AM_MAKE_INCLUDE], +[AC_MSG_CHECKING([whether ${MAKE-make} supports the include directive]) +cat > confinc.mk << 'END' +am__doit: + @echo this is the am__doit target >confinc.out +.PHONY: am__doit +END +am__include="#" +am__quote= +# BSD make does it like this. +echo '.include "confinc.mk" # ignored' > confmf.BSD +# Other make implementations (GNU, Solaris 10, AIX) do it like this. +echo 'include confinc.mk # ignored' > confmf.GNU +_am_result=no +for s in GNU BSD; do + AM_RUN_LOG([${MAKE-make} -f confmf.$s && cat confinc.out]) + AS_CASE([$?:`cat confinc.out 2>/dev/null`], + ['0:this is the am__doit target'], + [AS_CASE([$s], + [BSD], [am__include='.include' am__quote='"'], + [am__include='include' am__quote=''])]) + if test "$am__include" != "#"; then + _am_result="yes ($s style)" + break + fi +done +rm -f confinc.* confmf.* +AC_MSG_RESULT([${_am_result}]) +AC_SUBST([am__include])]) +AC_SUBST([am__quote])]) + +# Fake the existence of programs that GNU maintainers use. -*- Autoconf -*- + +# Copyright (C) 1997-2021 Free Software Foundation, Inc. +# +# This file is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# AM_MISSING_PROG(NAME, PROGRAM) +# ------------------------------ +AC_DEFUN([AM_MISSING_PROG], +[AC_REQUIRE([AM_MISSING_HAS_RUN]) +$1=${$1-"${am_missing_run}$2"} +AC_SUBST($1)]) + +# AM_MISSING_HAS_RUN +# ------------------ +# Define MISSING if not defined so far and test if it is modern enough. +# If it is, set am_missing_run to use it, otherwise, to nothing. +AC_DEFUN([AM_MISSING_HAS_RUN], +[AC_REQUIRE([AM_AUX_DIR_EXPAND])dnl +AC_REQUIRE_AUX_FILE([missing])dnl +if test x"${MISSING+set}" != xset; then + MISSING="\${SHELL} '$am_aux_dir/missing'" +fi +# Use eval to expand $SHELL +if eval "$MISSING --is-lightweight"; then + am_missing_run="$MISSING " +else + am_missing_run= + AC_MSG_WARN(['missing' script is too old or missing]) +fi +]) + +# Helper functions for option handling. -*- Autoconf -*- + +# Copyright (C) 2001-2021 Free Software Foundation, Inc. +# +# This file is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# _AM_MANGLE_OPTION(NAME) +# ----------------------- +AC_DEFUN([_AM_MANGLE_OPTION], +[[_AM_OPTION_]m4_bpatsubst($1, [[^a-zA-Z0-9_]], [_])]) + +# _AM_SET_OPTION(NAME) +# -------------------- +# Set option NAME. Presently that only means defining a flag for this option. +AC_DEFUN([_AM_SET_OPTION], +[m4_define(_AM_MANGLE_OPTION([$1]), [1])]) + +# _AM_SET_OPTIONS(OPTIONS) +# ------------------------ +# OPTIONS is a space-separated list of Automake options. +AC_DEFUN([_AM_SET_OPTIONS], +[m4_foreach_w([_AM_Option], [$1], [_AM_SET_OPTION(_AM_Option)])]) + +# _AM_IF_OPTION(OPTION, IF-SET, [IF-NOT-SET]) +# ------------------------------------------- +# Execute IF-SET if OPTION is set, IF-NOT-SET otherwise. +AC_DEFUN([_AM_IF_OPTION], +[m4_ifset(_AM_MANGLE_OPTION([$1]), [$2], [$3])]) + +# Copyright (C) 1999-2021 Free Software Foundation, Inc. +# +# This file is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# _AM_PROG_CC_C_O +# --------------- +# Like AC_PROG_CC_C_O, but changed for automake. We rewrite AC_PROG_CC +# to automatically call this. +AC_DEFUN([_AM_PROG_CC_C_O], +[AC_REQUIRE([AM_AUX_DIR_EXPAND])dnl +AC_REQUIRE_AUX_FILE([compile])dnl +AC_LANG_PUSH([C])dnl +AC_CACHE_CHECK( + [whether $CC understands -c and -o together], + [am_cv_prog_cc_c_o], + [AC_LANG_CONFTEST([AC_LANG_PROGRAM([])]) + # Make sure it works both with $CC and with simple cc. + # Following AC_PROG_CC_C_O, we do the test twice because some + # compilers refuse to overwrite an existing .o file with -o, + # though they will create one. + am_cv_prog_cc_c_o=yes + for am_i in 1 2; do + if AM_RUN_LOG([$CC -c conftest.$ac_ext -o conftest2.$ac_objext]) \ + && test -f conftest2.$ac_objext; then + : OK + else + am_cv_prog_cc_c_o=no + break + fi + done + rm -f core conftest* + unset am_i]) +if test "$am_cv_prog_cc_c_o" != yes; then + # Losing compiler, so override with the script. + # FIXME: It is wrong to rewrite CC. + # But if we don't then we get into trouble of one sort or another. + # A longer-term fix would be to have automake use am__CC in this case, + # and then we could set am__CC="\$(top_srcdir)/compile \$(CC)" + CC="$am_aux_dir/compile $CC" +fi +AC_LANG_POP([C])]) + +# For backward compatibility. +AC_DEFUN_ONCE([AM_PROG_CC_C_O], [AC_REQUIRE([AC_PROG_CC])]) + +# Copyright (C) 2001-2021 Free Software Foundation, Inc. +# +# This file is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# AM_RUN_LOG(COMMAND) +# ------------------- +# Run COMMAND, save the exit status in ac_status, and log it. +# (This has been adapted from Autoconf's _AC_RUN_LOG macro.) +AC_DEFUN([AM_RUN_LOG], +[{ echo "$as_me:$LINENO: $1" >&AS_MESSAGE_LOG_FD + ($1) >&AS_MESSAGE_LOG_FD 2>&AS_MESSAGE_LOG_FD + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&AS_MESSAGE_LOG_FD + (exit $ac_status); }]) + +# Check to make sure that the build environment is sane. -*- Autoconf -*- + +# Copyright (C) 1996-2021 Free Software Foundation, Inc. +# +# This file is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# AM_SANITY_CHECK +# --------------- +AC_DEFUN([AM_SANITY_CHECK], +[AC_MSG_CHECKING([whether build environment is sane]) +# Reject unsafe characters in $srcdir or the absolute working directory +# name. Accept space and tab only in the latter. +am_lf=' +' +case `pwd` in + *[[\\\"\#\$\&\'\`$am_lf]]*) + AC_MSG_ERROR([unsafe absolute working directory name]);; +esac +case $srcdir in + *[[\\\"\#\$\&\'\`$am_lf\ \ ]]*) + AC_MSG_ERROR([unsafe srcdir value: '$srcdir']);; +esac + +# Do 'set' in a subshell so we don't clobber the current shell's +# arguments. Must try -L first in case configure is actually a +# symlink; some systems play weird games with the mod time of symlinks +# (eg FreeBSD returns the mod time of the symlink's containing +# directory). +if ( + am_has_slept=no + for am_try in 1 2; do + echo "timestamp, slept: $am_has_slept" > conftest.file + set X `ls -Lt "$srcdir/configure" conftest.file 2> /dev/null` + if test "$[*]" = "X"; then + # -L didn't work. + set X `ls -t "$srcdir/configure" conftest.file` + fi + if test "$[*]" != "X $srcdir/configure conftest.file" \ + && test "$[*]" != "X conftest.file $srcdir/configure"; then + + # If neither matched, then we have a broken ls. This can happen + # if, for instance, CONFIG_SHELL is bash and it inherits a + # broken ls alias from the environment. This has actually + # happened. Such a system could not be considered "sane". + AC_MSG_ERROR([ls -t appears to fail. Make sure there is not a broken + alias in your environment]) + fi + if test "$[2]" = conftest.file || test $am_try -eq 2; then + break + fi + # Just in case. + sleep 1 + am_has_slept=yes + done + test "$[2]" = conftest.file + ) +then + # Ok. + : +else + AC_MSG_ERROR([newly created file is older than distributed files! +Check your system clock]) +fi +AC_MSG_RESULT([yes]) +# If we didn't sleep, we still need to ensure time stamps of config.status and +# generated files are strictly newer. +am_sleep_pid= +if grep 'slept: no' conftest.file >/dev/null 2>&1; then + ( sleep 1 ) & + am_sleep_pid=$! +fi +AC_CONFIG_COMMANDS_PRE( + [AC_MSG_CHECKING([that generated files are newer than configure]) + if test -n "$am_sleep_pid"; then + # Hide warnings about reused PIDs. + wait $am_sleep_pid 2>/dev/null + fi + AC_MSG_RESULT([done])]) +rm -f conftest.file +]) + +# Copyright (C) 2009-2021 Free Software Foundation, Inc. +# +# This file is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# AM_SILENT_RULES([DEFAULT]) +# -------------------------- +# Enable less verbose build rules; with the default set to DEFAULT +# ("yes" being less verbose, "no" or empty being verbose). +AC_DEFUN([AM_SILENT_RULES], +[AC_ARG_ENABLE([silent-rules], [dnl +AS_HELP_STRING( + [--enable-silent-rules], + [less verbose build output (undo: "make V=1")]) +AS_HELP_STRING( + [--disable-silent-rules], + [verbose build output (undo: "make V=0")])dnl +]) +case $enable_silent_rules in @%:@ ((( + yes) AM_DEFAULT_VERBOSITY=0;; + no) AM_DEFAULT_VERBOSITY=1;; + *) AM_DEFAULT_VERBOSITY=m4_if([$1], [yes], [0], [1]);; +esac +dnl +dnl A few 'make' implementations (e.g., NonStop OS and NextStep) +dnl do not support nested variable expansions. +dnl See automake bug#9928 and bug#10237. +am_make=${MAKE-make} +AC_CACHE_CHECK([whether $am_make supports nested variables], + [am_cv_make_support_nested_variables], + [if AS_ECHO([['TRUE=$(BAR$(V)) +BAR0=false +BAR1=true +V=1 +am__doit: + @$(TRUE) +.PHONY: am__doit']]) | $am_make -f - >/dev/null 2>&1; then + am_cv_make_support_nested_variables=yes +else + am_cv_make_support_nested_variables=no +fi]) +if test $am_cv_make_support_nested_variables = yes; then + dnl Using '$V' instead of '$(V)' breaks IRIX make. + AM_V='$(V)' + AM_DEFAULT_V='$(AM_DEFAULT_VERBOSITY)' +else + AM_V=$AM_DEFAULT_VERBOSITY + AM_DEFAULT_V=$AM_DEFAULT_VERBOSITY +fi +AC_SUBST([AM_V])dnl +AM_SUBST_NOTMAKE([AM_V])dnl +AC_SUBST([AM_DEFAULT_V])dnl +AM_SUBST_NOTMAKE([AM_DEFAULT_V])dnl +AC_SUBST([AM_DEFAULT_VERBOSITY])dnl +AM_BACKSLASH='\' +AC_SUBST([AM_BACKSLASH])dnl +_AM_SUBST_NOTMAKE([AM_BACKSLASH])dnl +]) + +# Copyright (C) 2001-2021 Free Software Foundation, Inc. +# +# This file is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# AM_PROG_INSTALL_STRIP +# --------------------- +# One issue with vendor 'install' (even GNU) is that you can't +# specify the program used to strip binaries. This is especially +# annoying in cross-compiling environments, where the build's strip +# is unlikely to handle the host's binaries. +# Fortunately install-sh will honor a STRIPPROG variable, so we +# always use install-sh in "make install-strip", and initialize +# STRIPPROG with the value of the STRIP variable (set by the user). +AC_DEFUN([AM_PROG_INSTALL_STRIP], +[AC_REQUIRE([AM_PROG_INSTALL_SH])dnl +# Installed binaries are usually stripped using 'strip' when the user +# run "make install-strip". However 'strip' might not be the right +# tool to use in cross-compilation environments, therefore Automake +# will honor the 'STRIP' environment variable to overrule this program. +dnl Don't test for $cross_compiling = yes, because it might be 'maybe'. +if test "$cross_compiling" != no; then + AC_CHECK_TOOL([STRIP], [strip], :) +fi +INSTALL_STRIP_PROGRAM="\$(install_sh) -c -s" +AC_SUBST([INSTALL_STRIP_PROGRAM])]) + +# Copyright (C) 2006-2021 Free Software Foundation, Inc. +# +# This file is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# _AM_SUBST_NOTMAKE(VARIABLE) +# --------------------------- +# Prevent Automake from outputting VARIABLE = @VARIABLE@ in Makefile.in. +# This macro is traced by Automake. +AC_DEFUN([_AM_SUBST_NOTMAKE]) + +# AM_SUBST_NOTMAKE(VARIABLE) +# -------------------------- +# Public sister of _AM_SUBST_NOTMAKE. +AC_DEFUN([AM_SUBST_NOTMAKE], [_AM_SUBST_NOTMAKE($@)]) + +# Check how to create a tarball. -*- Autoconf -*- + +# Copyright (C) 2004-2021 Free Software Foundation, Inc. +# +# This file is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# _AM_PROG_TAR(FORMAT) +# -------------------- +# Check how to create a tarball in format FORMAT. +# FORMAT should be one of 'v7', 'ustar', or 'pax'. +# +# Substitute a variable $(am__tar) that is a command +# writing to stdout a FORMAT-tarball containing the directory +# $tardir. +# tardir=directory && $(am__tar) > result.tar +# +# Substitute a variable $(am__untar) that extract such +# a tarball read from stdin. +# $(am__untar) < result.tar +# +AC_DEFUN([_AM_PROG_TAR], +[# Always define AMTAR for backward compatibility. Yes, it's still used +# in the wild :-( We should find a proper way to deprecate it ... +AC_SUBST([AMTAR], ['$${TAR-tar}']) + +# We'll loop over all known methods to create a tar archive until one works. +_am_tools='gnutar m4_if([$1], [ustar], [plaintar]) pax cpio none' + +m4_if([$1], [v7], + [am__tar='$${TAR-tar} chof - "$$tardir"' am__untar='$${TAR-tar} xf -'], + + [m4_case([$1], + [ustar], + [# The POSIX 1988 'ustar' format is defined with fixed-size fields. + # There is notably a 21 bits limit for the UID and the GID. In fact, + # the 'pax' utility can hang on bigger UID/GID (see automake bug#8343 + # and bug#13588). + am_max_uid=2097151 # 2^21 - 1 + am_max_gid=$am_max_uid + # The $UID and $GID variables are not portable, so we need to resort + # to the POSIX-mandated id(1) utility. Errors in the 'id' calls + # below are definitely unexpected, so allow the users to see them + # (that is, avoid stderr redirection). + am_uid=`id -u || echo unknown` + am_gid=`id -g || echo unknown` + AC_MSG_CHECKING([whether UID '$am_uid' is supported by ustar format]) + if test $am_uid -le $am_max_uid; then + AC_MSG_RESULT([yes]) + else + AC_MSG_RESULT([no]) + _am_tools=none + fi + AC_MSG_CHECKING([whether GID '$am_gid' is supported by ustar format]) + if test $am_gid -le $am_max_gid; then + AC_MSG_RESULT([yes]) + else + AC_MSG_RESULT([no]) + _am_tools=none + fi], + + [pax], + [], + + [m4_fatal([Unknown tar format])]) + + AC_MSG_CHECKING([how to create a $1 tar archive]) + + # Go ahead even if we have the value already cached. We do so because we + # need to set the values for the 'am__tar' and 'am__untar' variables. + _am_tools=${am_cv_prog_tar_$1-$_am_tools} + + for _am_tool in $_am_tools; do + case $_am_tool in + gnutar) + for _am_tar in tar gnutar gtar; do + AM_RUN_LOG([$_am_tar --version]) && break + done + am__tar="$_am_tar --format=m4_if([$1], [pax], [posix], [$1]) -chf - "'"$$tardir"' + am__tar_="$_am_tar --format=m4_if([$1], [pax], [posix], [$1]) -chf - "'"$tardir"' + am__untar="$_am_tar -xf -" + ;; + plaintar) + # Must skip GNU tar: if it does not support --format= it doesn't create + # ustar tarball either. + (tar --version) >/dev/null 2>&1 && continue + am__tar='tar chf - "$$tardir"' + am__tar_='tar chf - "$tardir"' + am__untar='tar xf -' + ;; + pax) + am__tar='pax -L -x $1 -w "$$tardir"' + am__tar_='pax -L -x $1 -w "$tardir"' + am__untar='pax -r' + ;; + cpio) + am__tar='find "$$tardir" -print | cpio -o -H $1 -L' + am__tar_='find "$tardir" -print | cpio -o -H $1 -L' + am__untar='cpio -i -H $1 -d' + ;; + none) + am__tar=false + am__tar_=false + am__untar=false + ;; + esac + + # If the value was cached, stop now. We just wanted to have am__tar + # and am__untar set. + test -n "${am_cv_prog_tar_$1}" && break + + # tar/untar a dummy directory, and stop if the command works. + rm -rf conftest.dir + mkdir conftest.dir + echo GrepMe > conftest.dir/file + AM_RUN_LOG([tardir=conftest.dir && eval $am__tar_ >conftest.tar]) + rm -rf conftest.dir + if test -s conftest.tar; then + AM_RUN_LOG([$am__untar /dev/null 2>&1 && break + fi + done + rm -rf conftest.dir + + AC_CACHE_VAL([am_cv_prog_tar_$1], [am_cv_prog_tar_$1=$_am_tool]) + AC_MSG_RESULT([$am_cv_prog_tar_$1])]) + +AC_SUBST([am__tar]) +AC_SUBST([am__untar]) +]) # _AM_PROG_TAR + +m4_include([m4/curl-amissl.m4]) +m4_include([m4/curl-apple-sectrust.m4]) +m4_include([m4/curl-compilers.m4]) +m4_include([m4/curl-confopts.m4]) +m4_include([m4/curl-functions.m4]) +m4_include([m4/curl-gnutls.m4]) +m4_include([m4/curl-mbedtls.m4]) +m4_include([m4/curl-openssl.m4]) +m4_include([m4/curl-override.m4]) +m4_include([m4/curl-reentrant.m4]) +m4_include([m4/curl-rustls.m4]) +m4_include([m4/curl-schannel.m4]) +m4_include([m4/curl-sysconfig.m4]) +m4_include([m4/curl-wolfssl.m4]) +m4_include([m4/libtool.m4]) +m4_include([m4/ltoptions.m4]) +m4_include([m4/ltsugar.m4]) +m4_include([m4/ltversion.m4]) +m4_include([m4/lt~obsolete.m4]) +m4_include([m4/xc-am-iface.m4]) +m4_include([m4/xc-cc-check.m4]) +m4_include([m4/xc-lt-iface.m4]) +m4_include([m4/xc-val-flgs.m4]) +m4_include([m4/zz40-xc-ovr.m4]) +m4_include([m4/zz50-xc-ovr.m4]) +m4_include([acinclude.m4]) diff --git a/3rdparty/curl-8.21.0/compile b/3rdparty/curl-8.21.0/compile new file mode 100755 index 0000000000..df363c8fbf --- /dev/null +++ b/3rdparty/curl-8.21.0/compile @@ -0,0 +1,348 @@ +#! /bin/sh +# Wrapper for compilers which do not understand '-c -o'. + +scriptversion=2018-03-07.03; # UTC + +# Copyright (C) 1999-2021 Free Software Foundation, Inc. +# Written by Tom Tromey . +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2, or (at your option) +# any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . + +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program that contains a +# configuration script generated by Autoconf, you may include it under +# the same distribution terms that you use for the rest of that program. + +# This file is maintained in Automake, please report +# bugs to or send patches to +# . + +nl=' +' + +# We need space, tab and new line, in precisely that order. Quoting is +# there to prevent tools from complaining about whitespace usage. +IFS=" "" $nl" + +file_conv= + +# func_file_conv build_file lazy +# Convert a $build file to $host form and store it in $file +# Currently only supports Windows hosts. If the determined conversion +# type is listed in (the comma separated) LAZY, no conversion will +# take place. +func_file_conv () +{ + file=$1 + case $file in + / | /[!/]*) # absolute file, and not a UNC file + if test -z "$file_conv"; then + # lazily determine how to convert abs files + case `uname -s` in + MINGW*) + file_conv=mingw + ;; + CYGWIN* | MSYS*) + file_conv=cygwin + ;; + *) + file_conv=wine + ;; + esac + fi + case $file_conv/,$2, in + *,$file_conv,*) + ;; + mingw/*) + file=`cmd //C echo "$file " | sed -e 's/"\(.*\) " *$/\1/'` + ;; + cygwin/* | msys/*) + file=`cygpath -m "$file" || echo "$file"` + ;; + wine/*) + file=`winepath -w "$file" || echo "$file"` + ;; + esac + ;; + esac +} + +# func_cl_dashL linkdir +# Make cl look for libraries in LINKDIR +func_cl_dashL () +{ + func_file_conv "$1" + if test -z "$lib_path"; then + lib_path=$file + else + lib_path="$lib_path;$file" + fi + linker_opts="$linker_opts -LIBPATH:$file" +} + +# func_cl_dashl library +# Do a library search-path lookup for cl +func_cl_dashl () +{ + lib=$1 + found=no + save_IFS=$IFS + IFS=';' + for dir in $lib_path $LIB + do + IFS=$save_IFS + if $shared && test -f "$dir/$lib.dll.lib"; then + found=yes + lib=$dir/$lib.dll.lib + break + fi + if test -f "$dir/$lib.lib"; then + found=yes + lib=$dir/$lib.lib + break + fi + if test -f "$dir/lib$lib.a"; then + found=yes + lib=$dir/lib$lib.a + break + fi + done + IFS=$save_IFS + + if test "$found" != yes; then + lib=$lib.lib + fi +} + +# func_cl_wrapper cl arg... +# Adjust compile command to suit cl +func_cl_wrapper () +{ + # Assume a capable shell + lib_path= + shared=: + linker_opts= + for arg + do + if test -n "$eat"; then + eat= + else + case $1 in + -o) + # configure might choose to run compile as 'compile cc -o foo foo.c'. + eat=1 + case $2 in + *.o | *.[oO][bB][jJ]) + func_file_conv "$2" + set x "$@" -Fo"$file" + shift + ;; + *) + func_file_conv "$2" + set x "$@" -Fe"$file" + shift + ;; + esac + ;; + -I) + eat=1 + func_file_conv "$2" mingw + set x "$@" -I"$file" + shift + ;; + -I*) + func_file_conv "${1#-I}" mingw + set x "$@" -I"$file" + shift + ;; + -l) + eat=1 + func_cl_dashl "$2" + set x "$@" "$lib" + shift + ;; + -l*) + func_cl_dashl "${1#-l}" + set x "$@" "$lib" + shift + ;; + -L) + eat=1 + func_cl_dashL "$2" + ;; + -L*) + func_cl_dashL "${1#-L}" + ;; + -static) + shared=false + ;; + -Wl,*) + arg=${1#-Wl,} + save_ifs="$IFS"; IFS=',' + for flag in $arg; do + IFS="$save_ifs" + linker_opts="$linker_opts $flag" + done + IFS="$save_ifs" + ;; + -Xlinker) + eat=1 + linker_opts="$linker_opts $2" + ;; + -*) + set x "$@" "$1" + shift + ;; + *.cc | *.CC | *.cxx | *.CXX | *.[cC]++) + func_file_conv "$1" + set x "$@" -Tp"$file" + shift + ;; + *.c | *.cpp | *.CPP | *.lib | *.LIB | *.Lib | *.OBJ | *.obj | *.[oO]) + func_file_conv "$1" mingw + set x "$@" "$file" + shift + ;; + *) + set x "$@" "$1" + shift + ;; + esac + fi + shift + done + if test -n "$linker_opts"; then + linker_opts="-link$linker_opts" + fi + exec "$@" $linker_opts + exit 1 +} + +eat= + +case $1 in + '') + echo "$0: No command. Try '$0 --help' for more information." 1>&2 + exit 1; + ;; + -h | --h*) + cat <<\EOF +Usage: compile [--help] [--version] PROGRAM [ARGS] + +Wrapper for compilers which do not understand '-c -o'. +Remove '-o dest.o' from ARGS, run PROGRAM with the remaining +arguments, and rename the output as expected. + +If you are trying to build a whole package this is not the +right script to run: please start by reading the file 'INSTALL'. + +Report bugs to . +EOF + exit $? + ;; + -v | --v*) + echo "compile $scriptversion" + exit $? + ;; + cl | *[/\\]cl | cl.exe | *[/\\]cl.exe | \ + icl | *[/\\]icl | icl.exe | *[/\\]icl.exe ) + func_cl_wrapper "$@" # Doesn't return... + ;; +esac + +ofile= +cfile= + +for arg +do + if test -n "$eat"; then + eat= + else + case $1 in + -o) + # configure might choose to run compile as 'compile cc -o foo foo.c'. + # So we strip '-o arg' only if arg is an object. + eat=1 + case $2 in + *.o | *.obj) + ofile=$2 + ;; + *) + set x "$@" -o "$2" + shift + ;; + esac + ;; + *.c) + cfile=$1 + set x "$@" "$1" + shift + ;; + *) + set x "$@" "$1" + shift + ;; + esac + fi + shift +done + +if test -z "$ofile" || test -z "$cfile"; then + # If no '-o' option was seen then we might have been invoked from a + # pattern rule where we don't need one. That is ok -- this is a + # normal compilation that the losing compiler can handle. If no + # '.c' file was seen then we are probably linking. That is also + # ok. + exec "$@" +fi + +# Name of file we expect compiler to create. +cofile=`echo "$cfile" | sed 's|^.*[\\/]||; s|^[a-zA-Z]:||; s/\.c$/.o/'` + +# Create the lock directory. +# Note: use '[/\\:.-]' here to ensure that we don't use the same name +# that we are using for the .o file. Also, base the name on the expected +# object file name, since that is what matters with a parallel build. +lockdir=`echo "$cofile" | sed -e 's|[/\\:.-]|_|g'`.d +while true; do + if mkdir "$lockdir" >/dev/null 2>&1; then + break + fi + sleep 1 +done +# FIXME: race condition here if user kills between mkdir and trap. +trap "rmdir '$lockdir'; exit 1" 1 2 15 + +# Run the compile. +"$@" +ret=$? + +if test -f "$cofile"; then + test "$cofile" = "$ofile" || mv "$cofile" "$ofile" +elif test -f "${cofile}bj"; then + test "${cofile}bj" = "$ofile" || mv "${cofile}bj" "$ofile" +fi + +rmdir "$lockdir" +exit $ret + +# Local Variables: +# mode: shell-script +# sh-indentation: 2 +# eval: (add-hook 'before-save-hook 'time-stamp) +# time-stamp-start: "scriptversion=" +# time-stamp-format: "%:y-%02m-%02d.%02H" +# time-stamp-time-zone: "UTC0" +# time-stamp-end: "; # UTC" +# End: diff --git a/3rdparty/curl-8.21.0/config.guess b/3rdparty/curl-8.21.0/config.guess new file mode 100755 index 0000000000..7f76b6228f --- /dev/null +++ b/3rdparty/curl-8.21.0/config.guess @@ -0,0 +1,1754 @@ +#! /bin/sh +# Attempt to guess a canonical system name. +# Copyright 1992-2022 Free Software Foundation, Inc. + +# shellcheck disable=SC2006,SC2268 # see below for rationale + +timestamp='2022-01-09' + +# This file is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, see . +# +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program that contains a +# configuration script generated by Autoconf, you may include it under +# the same distribution terms that you use for the rest of that +# program. This Exception is an additional permission under section 7 +# of the GNU General Public License, version 3 ("GPLv3"). +# +# Originally written by Per Bothner; maintained since 2000 by Ben Elliston. +# +# You can get the latest version of this script from: +# https://git.savannah.gnu.org/cgit/config.git/plain/config.guess +# +# Please send patches to . + + +# The "shellcheck disable" line above the timestamp inhibits complaints +# about features and limitations of the classic Bourne shell that were +# superseded or lifted in POSIX. However, this script identifies a wide +# variety of pre-POSIX systems that do not have POSIX shells at all, and +# even some reasonably current systems (Solaris 10 as case-in-point) still +# have a pre-POSIX /bin/sh. + + +me=`echo "$0" | sed -e 's,.*/,,'` + +usage="\ +Usage: $0 [OPTION] + +Output the configuration name of the system \`$me' is run on. + +Options: + -h, --help print this help, then exit + -t, --time-stamp print date of last modification, then exit + -v, --version print version number, then exit + +Report bugs and patches to ." + +version="\ +GNU config.guess ($timestamp) + +Originally written by Per Bothner. +Copyright 1992-2022 Free Software Foundation, Inc. + +This is free software; see the source for copying conditions. There is NO +warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." + +help=" +Try \`$me --help' for more information." + +# Parse command line +while test $# -gt 0 ; do + case $1 in + --time-stamp | --time* | -t ) + echo "$timestamp" ; exit ;; + --version | -v ) + echo "$version" ; exit ;; + --help | --h* | -h ) + echo "$usage"; exit ;; + -- ) # Stop option processing + shift; break ;; + - ) # Use stdin as input. + break ;; + -* ) + echo "$me: invalid option $1$help" >&2 + exit 1 ;; + * ) + break ;; + esac +done + +if test $# != 0; then + echo "$me: too many arguments$help" >&2 + exit 1 +fi + +# Just in case it came from the environment. +GUESS= + +# CC_FOR_BUILD -- compiler used by this script. Note that the use of a +# compiler to aid in system detection is discouraged as it requires +# temporary files to be created and, as you can see below, it is a +# headache to deal with in a portable fashion. + +# Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still +# use `HOST_CC' if defined, but it is deprecated. + +# Portable tmp directory creation inspired by the Autoconf team. + +tmp= +# shellcheck disable=SC2172 +trap 'test -z "$tmp" || rm -fr "$tmp"' 0 1 2 13 15 + +set_cc_for_build() { + # prevent multiple calls if $tmp is already set + test "$tmp" && return 0 + : "${TMPDIR=/tmp}" + # shellcheck disable=SC2039,SC3028 + { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } || + { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir "$tmp" 2>/dev/null) ; } || + { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir "$tmp" 2>/dev/null) && echo "Warning: creating insecure temp directory" >&2 ; } || + { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } + dummy=$tmp/dummy + case ${CC_FOR_BUILD-},${HOST_CC-},${CC-} in + ,,) echo "int x;" > "$dummy.c" + for driver in cc gcc c89 c99 ; do + if ($driver -c -o "$dummy.o" "$dummy.c") >/dev/null 2>&1 ; then + CC_FOR_BUILD=$driver + break + fi + done + if test x"$CC_FOR_BUILD" = x ; then + CC_FOR_BUILD=no_compiler_found + fi + ;; + ,,*) CC_FOR_BUILD=$CC ;; + ,*,*) CC_FOR_BUILD=$HOST_CC ;; + esac +} + +# This is needed to find uname on a Pyramid OSx when run in the BSD universe. +# (ghazi@noc.rutgers.edu 1994-08-24) +if test -f /.attbin/uname ; then + PATH=$PATH:/.attbin ; export PATH +fi + +UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown +UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown +UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown +UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown + +case $UNAME_SYSTEM in +Linux|GNU|GNU/*) + LIBC=unknown + + set_cc_for_build + cat <<-EOF > "$dummy.c" + #include + #if defined(__UCLIBC__) + LIBC=uclibc + #elif defined(__dietlibc__) + LIBC=dietlibc + #elif defined(__GLIBC__) + LIBC=gnu + #else + #include + /* First heuristic to detect musl libc. */ + #ifdef __DEFINED_va_list + LIBC=musl + #endif + #endif + EOF + cc_set_libc=`$CC_FOR_BUILD -E "$dummy.c" 2>/dev/null | grep '^LIBC' | sed 's, ,,g'` + eval "$cc_set_libc" + + # Second heuristic to detect musl libc. + if [ "$LIBC" = unknown ] && + command -v ldd >/dev/null && + ldd --version 2>&1 | grep -q ^musl; then + LIBC=musl + fi + + # If the system lacks a compiler, then just pick glibc. + # We could probably try harder. + if [ "$LIBC" = unknown ]; then + LIBC=gnu + fi + ;; +esac + +# Note: order is significant - the case branches are not exclusive. + +case $UNAME_MACHINE:$UNAME_SYSTEM:$UNAME_RELEASE:$UNAME_VERSION in + *:NetBSD:*:*) + # NetBSD (nbsd) targets should (where applicable) match one or + # more of the tuples: *-*-netbsdelf*, *-*-netbsdaout*, + # *-*-netbsdecoff* and *-*-netbsd*. For targets that recently + # switched to ELF, *-*-netbsd* would select the old + # object file format. This provides both forward + # compatibility and a consistent mechanism for selecting the + # object file format. + # + # Note: NetBSD doesn't particularly care about the vendor + # portion of the name. We always set it to "unknown". + UNAME_MACHINE_ARCH=`(uname -p 2>/dev/null || \ + /sbin/sysctl -n hw.machine_arch 2>/dev/null || \ + /usr/sbin/sysctl -n hw.machine_arch 2>/dev/null || \ + echo unknown)` + case $UNAME_MACHINE_ARCH in + aarch64eb) machine=aarch64_be-unknown ;; + armeb) machine=armeb-unknown ;; + arm*) machine=arm-unknown ;; + sh3el) machine=shl-unknown ;; + sh3eb) machine=sh-unknown ;; + sh5el) machine=sh5le-unknown ;; + earmv*) + arch=`echo "$UNAME_MACHINE_ARCH" | sed -e 's,^e\(armv[0-9]\).*$,\1,'` + endian=`echo "$UNAME_MACHINE_ARCH" | sed -ne 's,^.*\(eb\)$,\1,p'` + machine=${arch}${endian}-unknown + ;; + *) machine=$UNAME_MACHINE_ARCH-unknown ;; + esac + # The Operating System including object format, if it has switched + # to ELF recently (or will in the future) and ABI. + case $UNAME_MACHINE_ARCH in + earm*) + os=netbsdelf + ;; + arm*|i386|m68k|ns32k|sh3*|sparc|vax) + set_cc_for_build + if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \ + | grep -q __ELF__ + then + # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout). + # Return netbsd for either. FIX? + os=netbsd + else + os=netbsdelf + fi + ;; + *) + os=netbsd + ;; + esac + # Determine ABI tags. + case $UNAME_MACHINE_ARCH in + earm*) + expr='s/^earmv[0-9]/-eabi/;s/eb$//' + abi=`echo "$UNAME_MACHINE_ARCH" | sed -e "$expr"` + ;; + esac + # The OS release + # Debian GNU/NetBSD machines have a different userland, and + # thus, need a distinct triplet. However, they do not need + # kernel version information, so it can be replaced with a + # suitable tag, in the style of linux-gnu. + case $UNAME_VERSION in + Debian*) + release='-gnu' + ;; + *) + release=`echo "$UNAME_RELEASE" | sed -e 's/[-_].*//' | cut -d. -f1,2` + ;; + esac + # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM: + # contains redundant information, the shorter form: + # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used. + GUESS=$machine-${os}${release}${abi-} + ;; + *:Bitrig:*:*) + UNAME_MACHINE_ARCH=`arch | sed 's/Bitrig.//'` + GUESS=$UNAME_MACHINE_ARCH-unknown-bitrig$UNAME_RELEASE + ;; + *:OpenBSD:*:*) + UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'` + GUESS=$UNAME_MACHINE_ARCH-unknown-openbsd$UNAME_RELEASE + ;; + *:SecBSD:*:*) + UNAME_MACHINE_ARCH=`arch | sed 's/SecBSD.//'` + GUESS=$UNAME_MACHINE_ARCH-unknown-secbsd$UNAME_RELEASE + ;; + *:LibertyBSD:*:*) + UNAME_MACHINE_ARCH=`arch | sed 's/^.*BSD\.//'` + GUESS=$UNAME_MACHINE_ARCH-unknown-libertybsd$UNAME_RELEASE + ;; + *:MidnightBSD:*:*) + GUESS=$UNAME_MACHINE-unknown-midnightbsd$UNAME_RELEASE + ;; + *:ekkoBSD:*:*) + GUESS=$UNAME_MACHINE-unknown-ekkobsd$UNAME_RELEASE + ;; + *:SolidBSD:*:*) + GUESS=$UNAME_MACHINE-unknown-solidbsd$UNAME_RELEASE + ;; + *:OS108:*:*) + GUESS=$UNAME_MACHINE-unknown-os108_$UNAME_RELEASE + ;; + macppc:MirBSD:*:*) + GUESS=powerpc-unknown-mirbsd$UNAME_RELEASE + ;; + *:MirBSD:*:*) + GUESS=$UNAME_MACHINE-unknown-mirbsd$UNAME_RELEASE + ;; + *:Sortix:*:*) + GUESS=$UNAME_MACHINE-unknown-sortix + ;; + *:Twizzler:*:*) + GUESS=$UNAME_MACHINE-unknown-twizzler + ;; + *:Redox:*:*) + GUESS=$UNAME_MACHINE-unknown-redox + ;; + mips:OSF1:*.*) + GUESS=mips-dec-osf1 + ;; + alpha:OSF1:*:*) + # Reset EXIT trap before exiting to avoid spurious non-zero exit code. + trap '' 0 + case $UNAME_RELEASE in + *4.0) + UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'` + ;; + *5.*) + UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $4}'` + ;; + esac + # According to Compaq, /usr/sbin/psrinfo has been available on + # OSF/1 and Tru64 systems produced since 1995. I hope that + # covers most systems running today. This code pipes the CPU + # types through head -n 1, so we only detect the type of CPU 0. + ALPHA_CPU_TYPE=`/usr/sbin/psrinfo -v | sed -n -e 's/^ The alpha \(.*\) processor.*$/\1/p' | head -n 1` + case $ALPHA_CPU_TYPE in + "EV4 (21064)") + UNAME_MACHINE=alpha ;; + "EV4.5 (21064)") + UNAME_MACHINE=alpha ;; + "LCA4 (21066/21068)") + UNAME_MACHINE=alpha ;; + "EV5 (21164)") + UNAME_MACHINE=alphaev5 ;; + "EV5.6 (21164A)") + UNAME_MACHINE=alphaev56 ;; + "EV5.6 (21164PC)") + UNAME_MACHINE=alphapca56 ;; + "EV5.7 (21164PC)") + UNAME_MACHINE=alphapca57 ;; + "EV6 (21264)") + UNAME_MACHINE=alphaev6 ;; + "EV6.7 (21264A)") + UNAME_MACHINE=alphaev67 ;; + "EV6.8CB (21264C)") + UNAME_MACHINE=alphaev68 ;; + "EV6.8AL (21264B)") + UNAME_MACHINE=alphaev68 ;; + "EV6.8CX (21264D)") + UNAME_MACHINE=alphaev68 ;; + "EV6.9A (21264/EV69A)") + UNAME_MACHINE=alphaev69 ;; + "EV7 (21364)") + UNAME_MACHINE=alphaev7 ;; + "EV7.9 (21364A)") + UNAME_MACHINE=alphaev79 ;; + esac + # A Pn.n version is a patched version. + # A Vn.n version is a released version. + # A Tn.n version is a released field test version. + # A Xn.n version is an unreleased experimental baselevel. + # 1.2 uses "1.2" for uname -r. + OSF_REL=`echo "$UNAME_RELEASE" | sed -e 's/^[PVTX]//' | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz` + GUESS=$UNAME_MACHINE-dec-osf$OSF_REL + ;; + Amiga*:UNIX_System_V:4.0:*) + GUESS=m68k-unknown-sysv4 + ;; + *:[Aa]miga[Oo][Ss]:*:*) + GUESS=$UNAME_MACHINE-unknown-amigaos + ;; + *:[Mm]orph[Oo][Ss]:*:*) + GUESS=$UNAME_MACHINE-unknown-morphos + ;; + *:OS/390:*:*) + GUESS=i370-ibm-openedition + ;; + *:z/VM:*:*) + GUESS=s390-ibm-zvmoe + ;; + *:OS400:*:*) + GUESS=powerpc-ibm-os400 + ;; + arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) + GUESS=arm-acorn-riscix$UNAME_RELEASE + ;; + arm*:riscos:*:*|arm*:RISCOS:*:*) + GUESS=arm-unknown-riscos + ;; + SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*) + GUESS=hppa1.1-hitachi-hiuxmpp + ;; + Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*) + # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE. + case `(/bin/universe) 2>/dev/null` in + att) GUESS=pyramid-pyramid-sysv3 ;; + *) GUESS=pyramid-pyramid-bsd ;; + esac + ;; + NILE*:*:*:dcosx) + GUESS=pyramid-pyramid-svr4 + ;; + DRS?6000:unix:4.0:6*) + GUESS=sparc-icl-nx6 + ;; + DRS?6000:UNIX_SV:4.2*:7* | DRS?6000:isis:4.2*:7*) + case `/usr/bin/uname -p` in + sparc) GUESS=sparc-icl-nx7 ;; + esac + ;; + s390x:SunOS:*:*) + SUN_REL=`echo "$UNAME_RELEASE" | sed -e 's/[^.]*//'` + GUESS=$UNAME_MACHINE-ibm-solaris2$SUN_REL + ;; + sun4H:SunOS:5.*:*) + SUN_REL=`echo "$UNAME_RELEASE" | sed -e 's/[^.]*//'` + GUESS=sparc-hal-solaris2$SUN_REL + ;; + sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*) + SUN_REL=`echo "$UNAME_RELEASE" | sed -e 's/[^.]*//'` + GUESS=sparc-sun-solaris2$SUN_REL + ;; + i86pc:AuroraUX:5.*:* | i86xen:AuroraUX:5.*:*) + GUESS=i386-pc-auroraux$UNAME_RELEASE + ;; + i86pc:SunOS:5.*:* | i86xen:SunOS:5.*:*) + set_cc_for_build + SUN_ARCH=i386 + # If there is a compiler, see if it is configured for 64-bit objects. + # Note that the Sun cc does not turn __LP64__ into 1 like gcc does. + # This test works for both compilers. + if test "$CC_FOR_BUILD" != no_compiler_found; then + if (echo '#ifdef __amd64'; echo IS_64BIT_ARCH; echo '#endif') | \ + (CCOPTS="" $CC_FOR_BUILD -m64 -E - 2>/dev/null) | \ + grep IS_64BIT_ARCH >/dev/null + then + SUN_ARCH=x86_64 + fi + fi + SUN_REL=`echo "$UNAME_RELEASE" | sed -e 's/[^.]*//'` + GUESS=$SUN_ARCH-pc-solaris2$SUN_REL + ;; + sun4*:SunOS:6*:*) + # According to config.sub, this is the proper way to canonicalize + # SunOS6. Hard to guess exactly what SunOS6 will be like, but + # it's likely to be more like Solaris than SunOS4. + SUN_REL=`echo "$UNAME_RELEASE" | sed -e 's/[^.]*//'` + GUESS=sparc-sun-solaris3$SUN_REL + ;; + sun4*:SunOS:*:*) + case `/usr/bin/arch -k` in + Series*|S4*) + UNAME_RELEASE=`uname -v` + ;; + esac + # Japanese Language versions have a version number like `4.1.3-JL'. + SUN_REL=`echo "$UNAME_RELEASE" | sed -e 's/-/_/'` + GUESS=sparc-sun-sunos$SUN_REL + ;; + sun3*:SunOS:*:*) + GUESS=m68k-sun-sunos$UNAME_RELEASE + ;; + sun*:*:4.2BSD:*) + UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null` + test "x$UNAME_RELEASE" = x && UNAME_RELEASE=3 + case `/bin/arch` in + sun3) + GUESS=m68k-sun-sunos$UNAME_RELEASE + ;; + sun4) + GUESS=sparc-sun-sunos$UNAME_RELEASE + ;; + esac + ;; + aushp:SunOS:*:*) + GUESS=sparc-auspex-sunos$UNAME_RELEASE + ;; + # The situation for MiNT is a little confusing. The machine name + # can be virtually everything (everything which is not + # "atarist" or "atariste" at least should have a processor + # > m68000). The system name ranges from "MiNT" over "FreeMiNT" + # to the lowercase version "mint" (or "freemint"). Finally + # the system name "TOS" denotes a system which is actually not + # MiNT. But MiNT is downward compatible to TOS, so this should + # be no problem. + atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*) + GUESS=m68k-atari-mint$UNAME_RELEASE + ;; + atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*) + GUESS=m68k-atari-mint$UNAME_RELEASE + ;; + *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*) + GUESS=m68k-atari-mint$UNAME_RELEASE + ;; + milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*) + GUESS=m68k-milan-mint$UNAME_RELEASE + ;; + hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*) + GUESS=m68k-hades-mint$UNAME_RELEASE + ;; + *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*) + GUESS=m68k-unknown-mint$UNAME_RELEASE + ;; + m68k:machten:*:*) + GUESS=m68k-apple-machten$UNAME_RELEASE + ;; + powerpc:machten:*:*) + GUESS=powerpc-apple-machten$UNAME_RELEASE + ;; + RISC*:Mach:*:*) + GUESS=mips-dec-mach_bsd4.3 + ;; + RISC*:ULTRIX:*:*) + GUESS=mips-dec-ultrix$UNAME_RELEASE + ;; + VAX*:ULTRIX*:*:*) + GUESS=vax-dec-ultrix$UNAME_RELEASE + ;; + 2020:CLIX:*:* | 2430:CLIX:*:*) + GUESS=clipper-intergraph-clix$UNAME_RELEASE + ;; + mips:*:*:UMIPS | mips:*:*:RISCos) + set_cc_for_build + sed 's/^ //' << EOF > "$dummy.c" +#ifdef __cplusplus +#include /* for printf() prototype */ + int main (int argc, char *argv[]) { +#else + int main (argc, argv) int argc; char *argv[]; { +#endif + #if defined (host_mips) && defined (MIPSEB) + #if defined (SYSTYPE_SYSV) + printf ("mips-mips-riscos%ssysv\\n", argv[1]); exit (0); + #endif + #if defined (SYSTYPE_SVR4) + printf ("mips-mips-riscos%ssvr4\\n", argv[1]); exit (0); + #endif + #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD) + printf ("mips-mips-riscos%sbsd\\n", argv[1]); exit (0); + #endif + #endif + exit (-1); + } +EOF + $CC_FOR_BUILD -o "$dummy" "$dummy.c" && + dummyarg=`echo "$UNAME_RELEASE" | sed -n 's/\([0-9]*\).*/\1/p'` && + SYSTEM_NAME=`"$dummy" "$dummyarg"` && + { echo "$SYSTEM_NAME"; exit; } + GUESS=mips-mips-riscos$UNAME_RELEASE + ;; + Motorola:PowerMAX_OS:*:*) + GUESS=powerpc-motorola-powermax + ;; + Motorola:*:4.3:PL8-*) + GUESS=powerpc-harris-powermax + ;; + Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*) + GUESS=powerpc-harris-powermax + ;; + Night_Hawk:Power_UNIX:*:*) + GUESS=powerpc-harris-powerunix + ;; + m88k:CX/UX:7*:*) + GUESS=m88k-harris-cxux7 + ;; + m88k:*:4*:R4*) + GUESS=m88k-motorola-sysv4 + ;; + m88k:*:3*:R3*) + GUESS=m88k-motorola-sysv3 + ;; + AViiON:dgux:*:*) + # DG/UX returns AViiON for all architectures + UNAME_PROCESSOR=`/usr/bin/uname -p` + if test "$UNAME_PROCESSOR" = mc88100 || test "$UNAME_PROCESSOR" = mc88110 + then + if test "$TARGET_BINARY_INTERFACE"x = m88kdguxelfx || \ + test "$TARGET_BINARY_INTERFACE"x = x + then + GUESS=m88k-dg-dgux$UNAME_RELEASE + else + GUESS=m88k-dg-dguxbcs$UNAME_RELEASE + fi + else + GUESS=i586-dg-dgux$UNAME_RELEASE + fi + ;; + M88*:DolphinOS:*:*) # DolphinOS (SVR3) + GUESS=m88k-dolphin-sysv3 + ;; + M88*:*:R3*:*) + # Delta 88k system running SVR3 + GUESS=m88k-motorola-sysv3 + ;; + XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3) + GUESS=m88k-tektronix-sysv3 + ;; + Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD) + GUESS=m68k-tektronix-bsd + ;; + *:IRIX*:*:*) + IRIX_REL=`echo "$UNAME_RELEASE" | sed -e 's/-/_/g'` + GUESS=mips-sgi-irix$IRIX_REL + ;; + ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. + GUESS=romp-ibm-aix # uname -m gives an 8 hex-code CPU id + ;; # Note that: echo "'`uname -s`'" gives 'AIX ' + i*86:AIX:*:*) + GUESS=i386-ibm-aix + ;; + ia64:AIX:*:*) + if test -x /usr/bin/oslevel ; then + IBM_REV=`/usr/bin/oslevel` + else + IBM_REV=$UNAME_VERSION.$UNAME_RELEASE + fi + GUESS=$UNAME_MACHINE-ibm-aix$IBM_REV + ;; + *:AIX:2:3) + if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then + set_cc_for_build + sed 's/^ //' << EOF > "$dummy.c" + #include + + main() + { + if (!__power_pc()) + exit(1); + puts("powerpc-ibm-aix3.2.5"); + exit(0); + } +EOF + if $CC_FOR_BUILD -o "$dummy" "$dummy.c" && SYSTEM_NAME=`"$dummy"` + then + GUESS=$SYSTEM_NAME + else + GUESS=rs6000-ibm-aix3.2.5 + fi + elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then + GUESS=rs6000-ibm-aix3.2.4 + else + GUESS=rs6000-ibm-aix3.2 + fi + ;; + *:AIX:*:[4567]) + IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'` + if /usr/sbin/lsattr -El "$IBM_CPU_ID" | grep ' POWER' >/dev/null 2>&1; then + IBM_ARCH=rs6000 + else + IBM_ARCH=powerpc + fi + if test -x /usr/bin/lslpp ; then + IBM_REV=`/usr/bin/lslpp -Lqc bos.rte.libc | \ + awk -F: '{ print $3 }' | sed s/[0-9]*$/0/` + else + IBM_REV=$UNAME_VERSION.$UNAME_RELEASE + fi + GUESS=$IBM_ARCH-ibm-aix$IBM_REV + ;; + *:AIX:*:*) + GUESS=rs6000-ibm-aix + ;; + ibmrt:4.4BSD:*|romp-ibm:4.4BSD:*) + GUESS=romp-ibm-bsd4.4 + ;; + ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and + GUESS=romp-ibm-bsd$UNAME_RELEASE # 4.3 with uname added to + ;; # report: romp-ibm BSD 4.3 + *:BOSX:*:*) + GUESS=rs6000-bull-bosx + ;; + DPX/2?00:B.O.S.:*:*) + GUESS=m68k-bull-sysv3 + ;; + 9000/[34]??:4.3bsd:1.*:*) + GUESS=m68k-hp-bsd + ;; + hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) + GUESS=m68k-hp-bsd4.4 + ;; + 9000/[34678]??:HP-UX:*:*) + HPUX_REV=`echo "$UNAME_RELEASE" | sed -e 's/[^.]*.[0B]*//'` + case $UNAME_MACHINE in + 9000/31?) HP_ARCH=m68000 ;; + 9000/[34]??) HP_ARCH=m68k ;; + 9000/[678][0-9][0-9]) + if test -x /usr/bin/getconf; then + sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null` + sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null` + case $sc_cpu_version in + 523) HP_ARCH=hppa1.0 ;; # CPU_PA_RISC1_0 + 528) HP_ARCH=hppa1.1 ;; # CPU_PA_RISC1_1 + 532) # CPU_PA_RISC2_0 + case $sc_kernel_bits in + 32) HP_ARCH=hppa2.0n ;; + 64) HP_ARCH=hppa2.0w ;; + '') HP_ARCH=hppa2.0 ;; # HP-UX 10.20 + esac ;; + esac + fi + if test "$HP_ARCH" = ""; then + set_cc_for_build + sed 's/^ //' << EOF > "$dummy.c" + + #define _HPUX_SOURCE + #include + #include + + int main () + { + #if defined(_SC_KERNEL_BITS) + long bits = sysconf(_SC_KERNEL_BITS); + #endif + long cpu = sysconf (_SC_CPU_VERSION); + + switch (cpu) + { + case CPU_PA_RISC1_0: puts ("hppa1.0"); break; + case CPU_PA_RISC1_1: puts ("hppa1.1"); break; + case CPU_PA_RISC2_0: + #if defined(_SC_KERNEL_BITS) + switch (bits) + { + case 64: puts ("hppa2.0w"); break; + case 32: puts ("hppa2.0n"); break; + default: puts ("hppa2.0"); break; + } break; + #else /* !defined(_SC_KERNEL_BITS) */ + puts ("hppa2.0"); break; + #endif + default: puts ("hppa1.0"); break; + } + exit (0); + } +EOF + (CCOPTS="" $CC_FOR_BUILD -o "$dummy" "$dummy.c" 2>/dev/null) && HP_ARCH=`"$dummy"` + test -z "$HP_ARCH" && HP_ARCH=hppa + fi ;; + esac + if test "$HP_ARCH" = hppa2.0w + then + set_cc_for_build + + # hppa2.0w-hp-hpux* has a 64-bit kernel and a compiler generating + # 32-bit code. hppa64-hp-hpux* has the same kernel and a compiler + # generating 64-bit code. GNU and HP use different nomenclature: + # + # $ CC_FOR_BUILD=cc ./config.guess + # => hppa2.0w-hp-hpux11.23 + # $ CC_FOR_BUILD="cc +DA2.0w" ./config.guess + # => hppa64-hp-hpux11.23 + + if echo __LP64__ | (CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | + grep -q __LP64__ + then + HP_ARCH=hppa2.0w + else + HP_ARCH=hppa64 + fi + fi + GUESS=$HP_ARCH-hp-hpux$HPUX_REV + ;; + ia64:HP-UX:*:*) + HPUX_REV=`echo "$UNAME_RELEASE" | sed -e 's/[^.]*.[0B]*//'` + GUESS=ia64-hp-hpux$HPUX_REV + ;; + 3050*:HI-UX:*:*) + set_cc_for_build + sed 's/^ //' << EOF > "$dummy.c" + #include + int + main () + { + long cpu = sysconf (_SC_CPU_VERSION); + /* The order matters, because CPU_IS_HP_MC68K erroneously returns + true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct + results, however. */ + if (CPU_IS_PA_RISC (cpu)) + { + switch (cpu) + { + case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break; + case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break; + case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break; + default: puts ("hppa-hitachi-hiuxwe2"); break; + } + } + else if (CPU_IS_HP_MC68K (cpu)) + puts ("m68k-hitachi-hiuxwe2"); + else puts ("unknown-hitachi-hiuxwe2"); + exit (0); + } +EOF + $CC_FOR_BUILD -o "$dummy" "$dummy.c" && SYSTEM_NAME=`"$dummy"` && + { echo "$SYSTEM_NAME"; exit; } + GUESS=unknown-hitachi-hiuxwe2 + ;; + 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:*) + GUESS=hppa1.1-hp-bsd + ;; + 9000/8??:4.3bsd:*:*) + GUESS=hppa1.0-hp-bsd + ;; + *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*) + GUESS=hppa1.0-hp-mpeix + ;; + hp7??:OSF1:*:* | hp8?[79]:OSF1:*:*) + GUESS=hppa1.1-hp-osf + ;; + hp8??:OSF1:*:*) + GUESS=hppa1.0-hp-osf + ;; + i*86:OSF1:*:*) + if test -x /usr/sbin/sysversion ; then + GUESS=$UNAME_MACHINE-unknown-osf1mk + else + GUESS=$UNAME_MACHINE-unknown-osf1 + fi + ;; + parisc*:Lites*:*:*) + GUESS=hppa1.1-hp-lites + ;; + C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*) + GUESS=c1-convex-bsd + ;; + C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*) + if getsysinfo -f scalar_acc + then echo c32-convex-bsd + else echo c2-convex-bsd + fi + exit ;; + C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*) + GUESS=c34-convex-bsd + ;; + C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*) + GUESS=c38-convex-bsd + ;; + C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*) + GUESS=c4-convex-bsd + ;; + CRAY*Y-MP:*:*:*) + CRAY_REL=`echo "$UNAME_RELEASE" | sed -e 's/\.[^.]*$/.X/'` + GUESS=ymp-cray-unicos$CRAY_REL + ;; + CRAY*[A-Z]90:*:*:*) + echo "$UNAME_MACHINE"-cray-unicos"$UNAME_RELEASE" \ + | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \ + -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \ + -e 's/\.[^.]*$/.X/' + exit ;; + CRAY*TS:*:*:*) + CRAY_REL=`echo "$UNAME_RELEASE" | sed -e 's/\.[^.]*$/.X/'` + GUESS=t90-cray-unicos$CRAY_REL + ;; + CRAY*T3E:*:*:*) + CRAY_REL=`echo "$UNAME_RELEASE" | sed -e 's/\.[^.]*$/.X/'` + GUESS=alphaev5-cray-unicosmk$CRAY_REL + ;; + CRAY*SV1:*:*:*) + CRAY_REL=`echo "$UNAME_RELEASE" | sed -e 's/\.[^.]*$/.X/'` + GUESS=sv1-cray-unicos$CRAY_REL + ;; + *:UNICOS/mp:*:*) + CRAY_REL=`echo "$UNAME_RELEASE" | sed -e 's/\.[^.]*$/.X/'` + GUESS=craynv-cray-unicosmp$CRAY_REL + ;; + F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*) + FUJITSU_PROC=`uname -m | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz` + FUJITSU_SYS=`uname -p | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz | sed -e 's/\///'` + FUJITSU_REL=`echo "$UNAME_RELEASE" | sed -e 's/ /_/'` + GUESS=${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL} + ;; + 5000:UNIX_System_V:4.*:*) + FUJITSU_SYS=`uname -p | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz | sed -e 's/\///'` + FUJITSU_REL=`echo "$UNAME_RELEASE" | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz | sed -e 's/ /_/'` + GUESS=sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL} + ;; + i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*) + GUESS=$UNAME_MACHINE-pc-bsdi$UNAME_RELEASE + ;; + sparc*:BSD/OS:*:*) + GUESS=sparc-unknown-bsdi$UNAME_RELEASE + ;; + *:BSD/OS:*:*) + GUESS=$UNAME_MACHINE-unknown-bsdi$UNAME_RELEASE + ;; + arm:FreeBSD:*:*) + UNAME_PROCESSOR=`uname -p` + set_cc_for_build + if echo __ARM_PCS_VFP | $CC_FOR_BUILD -E - 2>/dev/null \ + | grep -q __ARM_PCS_VFP + then + FREEBSD_REL=`echo "$UNAME_RELEASE" | sed -e 's/[-(].*//'` + GUESS=$UNAME_PROCESSOR-unknown-freebsd$FREEBSD_REL-gnueabi + else + FREEBSD_REL=`echo "$UNAME_RELEASE" | sed -e 's/[-(].*//'` + GUESS=$UNAME_PROCESSOR-unknown-freebsd$FREEBSD_REL-gnueabihf + fi + ;; + *:FreeBSD:*:*) + UNAME_PROCESSOR=`/usr/bin/uname -p` + case $UNAME_PROCESSOR in + amd64) + UNAME_PROCESSOR=x86_64 ;; + i386) + UNAME_PROCESSOR=i586 ;; + esac + FREEBSD_REL=`echo "$UNAME_RELEASE" | sed -e 's/[-(].*//'` + GUESS=$UNAME_PROCESSOR-unknown-freebsd$FREEBSD_REL + ;; + i*:CYGWIN*:*) + GUESS=$UNAME_MACHINE-pc-cygwin + ;; + *:MINGW64*:*) + GUESS=$UNAME_MACHINE-pc-mingw64 + ;; + *:MINGW*:*) + GUESS=$UNAME_MACHINE-pc-mingw32 + ;; + *:MSYS*:*) + GUESS=$UNAME_MACHINE-pc-msys + ;; + i*:PW*:*) + GUESS=$UNAME_MACHINE-pc-pw32 + ;; + *:SerenityOS:*:*) + GUESS=$UNAME_MACHINE-pc-serenity + ;; + *:Interix*:*) + case $UNAME_MACHINE in + x86) + GUESS=i586-pc-interix$UNAME_RELEASE + ;; + authenticamd | genuineintel | EM64T) + GUESS=x86_64-unknown-interix$UNAME_RELEASE + ;; + IA64) + GUESS=ia64-unknown-interix$UNAME_RELEASE + ;; + esac ;; + i*:UWIN*:*) + GUESS=$UNAME_MACHINE-pc-uwin + ;; + amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*) + GUESS=x86_64-pc-cygwin + ;; + prep*:SunOS:5.*:*) + SUN_REL=`echo "$UNAME_RELEASE" | sed -e 's/[^.]*//'` + GUESS=powerpcle-unknown-solaris2$SUN_REL + ;; + *:GNU:*:*) + # the GNU system + GNU_ARCH=`echo "$UNAME_MACHINE" | sed -e 's,[-/].*$,,'` + GNU_REL=`echo "$UNAME_RELEASE" | sed -e 's,/.*$,,'` + GUESS=$GNU_ARCH-unknown-$LIBC$GNU_REL + ;; + *:GNU/*:*:*) + # other systems with GNU libc and userland + GNU_SYS=`echo "$UNAME_SYSTEM" | sed 's,^[^/]*/,,' | tr "[:upper:]" "[:lower:]"` + GNU_REL=`echo "$UNAME_RELEASE" | sed -e 's/[-(].*//'` + GUESS=$UNAME_MACHINE-unknown-$GNU_SYS$GNU_REL-$LIBC + ;; + *:Minix:*:*) + GUESS=$UNAME_MACHINE-unknown-minix + ;; + aarch64:Linux:*:*) + GUESS=$UNAME_MACHINE-unknown-linux-$LIBC + ;; + aarch64_be:Linux:*:*) + UNAME_MACHINE=aarch64_be + GUESS=$UNAME_MACHINE-unknown-linux-$LIBC + ;; + alpha:Linux:*:*) + case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' /proc/cpuinfo 2>/dev/null` in + EV5) UNAME_MACHINE=alphaev5 ;; + EV56) UNAME_MACHINE=alphaev56 ;; + PCA56) UNAME_MACHINE=alphapca56 ;; + PCA57) UNAME_MACHINE=alphapca56 ;; + EV6) UNAME_MACHINE=alphaev6 ;; + EV67) UNAME_MACHINE=alphaev67 ;; + EV68*) UNAME_MACHINE=alphaev68 ;; + esac + objdump --private-headers /bin/sh | grep -q ld.so.1 + if test "$?" = 0 ; then LIBC=gnulibc1 ; fi + GUESS=$UNAME_MACHINE-unknown-linux-$LIBC + ;; + arc:Linux:*:* | arceb:Linux:*:* | arc32:Linux:*:* | arc64:Linux:*:*) + GUESS=$UNAME_MACHINE-unknown-linux-$LIBC + ;; + arm*:Linux:*:*) + set_cc_for_build + if echo __ARM_EABI__ | $CC_FOR_BUILD -E - 2>/dev/null \ + | grep -q __ARM_EABI__ + then + GUESS=$UNAME_MACHINE-unknown-linux-$LIBC + else + if echo __ARM_PCS_VFP | $CC_FOR_BUILD -E - 2>/dev/null \ + | grep -q __ARM_PCS_VFP + then + GUESS=$UNAME_MACHINE-unknown-linux-${LIBC}eabi + else + GUESS=$UNAME_MACHINE-unknown-linux-${LIBC}eabihf + fi + fi + ;; + avr32*:Linux:*:*) + GUESS=$UNAME_MACHINE-unknown-linux-$LIBC + ;; + cris:Linux:*:*) + GUESS=$UNAME_MACHINE-axis-linux-$LIBC + ;; + crisv32:Linux:*:*) + GUESS=$UNAME_MACHINE-axis-linux-$LIBC + ;; + e2k:Linux:*:*) + GUESS=$UNAME_MACHINE-unknown-linux-$LIBC + ;; + frv:Linux:*:*) + GUESS=$UNAME_MACHINE-unknown-linux-$LIBC + ;; + hexagon:Linux:*:*) + GUESS=$UNAME_MACHINE-unknown-linux-$LIBC + ;; + i*86:Linux:*:*) + GUESS=$UNAME_MACHINE-pc-linux-$LIBC + ;; + ia64:Linux:*:*) + GUESS=$UNAME_MACHINE-unknown-linux-$LIBC + ;; + k1om:Linux:*:*) + GUESS=$UNAME_MACHINE-unknown-linux-$LIBC + ;; + loongarch32:Linux:*:* | loongarch64:Linux:*:* | loongarchx32:Linux:*:*) + GUESS=$UNAME_MACHINE-unknown-linux-$LIBC + ;; + m32r*:Linux:*:*) + GUESS=$UNAME_MACHINE-unknown-linux-$LIBC + ;; + m68*:Linux:*:*) + GUESS=$UNAME_MACHINE-unknown-linux-$LIBC + ;; + mips:Linux:*:* | mips64:Linux:*:*) + set_cc_for_build + IS_GLIBC=0 + test x"${LIBC}" = xgnu && IS_GLIBC=1 + sed 's/^ //' << EOF > "$dummy.c" + #undef CPU + #undef mips + #undef mipsel + #undef mips64 + #undef mips64el + #if ${IS_GLIBC} && defined(_ABI64) + LIBCABI=gnuabi64 + #else + #if ${IS_GLIBC} && defined(_ABIN32) + LIBCABI=gnuabin32 + #else + LIBCABI=${LIBC} + #endif + #endif + + #if ${IS_GLIBC} && defined(__mips64) && defined(__mips_isa_rev) && __mips_isa_rev>=6 + CPU=mipsisa64r6 + #else + #if ${IS_GLIBC} && !defined(__mips64) && defined(__mips_isa_rev) && __mips_isa_rev>=6 + CPU=mipsisa32r6 + #else + #if defined(__mips64) + CPU=mips64 + #else + CPU=mips + #endif + #endif + #endif + + #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) + MIPS_ENDIAN=el + #else + #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) + MIPS_ENDIAN= + #else + MIPS_ENDIAN= + #endif + #endif +EOF + cc_set_vars=`$CC_FOR_BUILD -E "$dummy.c" 2>/dev/null | grep '^CPU\|^MIPS_ENDIAN\|^LIBCABI'` + eval "$cc_set_vars" + test "x$CPU" != x && { echo "$CPU${MIPS_ENDIAN}-unknown-linux-$LIBCABI"; exit; } + ;; + mips64el:Linux:*:*) + GUESS=$UNAME_MACHINE-unknown-linux-$LIBC + ;; + openrisc*:Linux:*:*) + GUESS=or1k-unknown-linux-$LIBC + ;; + or32:Linux:*:* | or1k*:Linux:*:*) + GUESS=$UNAME_MACHINE-unknown-linux-$LIBC + ;; + padre:Linux:*:*) + GUESS=sparc-unknown-linux-$LIBC + ;; + parisc64:Linux:*:* | hppa64:Linux:*:*) + GUESS=hppa64-unknown-linux-$LIBC + ;; + parisc:Linux:*:* | hppa:Linux:*:*) + # Look for CPU level + case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in + PA7*) GUESS=hppa1.1-unknown-linux-$LIBC ;; + PA8*) GUESS=hppa2.0-unknown-linux-$LIBC ;; + *) GUESS=hppa-unknown-linux-$LIBC ;; + esac + ;; + ppc64:Linux:*:*) + GUESS=powerpc64-unknown-linux-$LIBC + ;; + ppc:Linux:*:*) + GUESS=powerpc-unknown-linux-$LIBC + ;; + ppc64le:Linux:*:*) + GUESS=powerpc64le-unknown-linux-$LIBC + ;; + ppcle:Linux:*:*) + GUESS=powerpcle-unknown-linux-$LIBC + ;; + riscv32:Linux:*:* | riscv32be:Linux:*:* | riscv64:Linux:*:* | riscv64be:Linux:*:*) + GUESS=$UNAME_MACHINE-unknown-linux-$LIBC + ;; + s390:Linux:*:* | s390x:Linux:*:*) + GUESS=$UNAME_MACHINE-ibm-linux-$LIBC + ;; + sh64*:Linux:*:*) + GUESS=$UNAME_MACHINE-unknown-linux-$LIBC + ;; + sh*:Linux:*:*) + GUESS=$UNAME_MACHINE-unknown-linux-$LIBC + ;; + sparc:Linux:*:* | sparc64:Linux:*:*) + GUESS=$UNAME_MACHINE-unknown-linux-$LIBC + ;; + tile*:Linux:*:*) + GUESS=$UNAME_MACHINE-unknown-linux-$LIBC + ;; + vax:Linux:*:*) + GUESS=$UNAME_MACHINE-dec-linux-$LIBC + ;; + x86_64:Linux:*:*) + set_cc_for_build + LIBCABI=$LIBC + if test "$CC_FOR_BUILD" != no_compiler_found; then + if (echo '#ifdef __ILP32__'; echo IS_X32; echo '#endif') | \ + (CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | \ + grep IS_X32 >/dev/null + then + LIBCABI=${LIBC}x32 + fi + fi + GUESS=$UNAME_MACHINE-pc-linux-$LIBCABI + ;; + xtensa*:Linux:*:*) + GUESS=$UNAME_MACHINE-unknown-linux-$LIBC + ;; + i*86:DYNIX/ptx:4*:*) + # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. + # earlier versions are messed up and put the nodename in both + # sysname and nodename. + GUESS=i386-sequent-sysv4 + ;; + i*86:UNIX_SV:4.2MP:2.*) + # Unixware is an offshoot of SVR4, but it has its own version + # number series starting with 2... + # I am not positive that other SVR4 systems won't match this, + # I just have to hope. -- rms. + # Use sysv4.2uw... so that sysv4* matches it. + GUESS=$UNAME_MACHINE-pc-sysv4.2uw$UNAME_VERSION + ;; + i*86:OS/2:*:*) + # If we were able to find `uname', then EMX Unix compatibility + # is probably installed. + GUESS=$UNAME_MACHINE-pc-os2-emx + ;; + i*86:XTS-300:*:STOP) + GUESS=$UNAME_MACHINE-unknown-stop + ;; + i*86:atheos:*:*) + GUESS=$UNAME_MACHINE-unknown-atheos + ;; + i*86:syllable:*:*) + GUESS=$UNAME_MACHINE-pc-syllable + ;; + i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.[02]*:*) + GUESS=i386-unknown-lynxos$UNAME_RELEASE + ;; + i*86:*DOS:*:*) + GUESS=$UNAME_MACHINE-pc-msdosdjgpp + ;; + i*86:*:4.*:*) + UNAME_REL=`echo "$UNAME_RELEASE" | sed 's/\/MP$//'` + if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then + GUESS=$UNAME_MACHINE-univel-sysv$UNAME_REL + else + GUESS=$UNAME_MACHINE-pc-sysv$UNAME_REL + fi + ;; + i*86:*:5:[678]*) + # UnixWare 7.x, OpenUNIX and OpenServer 6. + case `/bin/uname -X | grep "^Machine"` in + *486*) UNAME_MACHINE=i486 ;; + *Pentium) UNAME_MACHINE=i586 ;; + *Pent*|*Celeron) UNAME_MACHINE=i686 ;; + esac + GUESS=$UNAME_MACHINE-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION} + ;; + i*86:*:3.2:*) + if test -f /usr/options/cb.name; then + UNAME_REL=`sed -n 's/.*Version //p' /dev/null >/dev/null ; then + UNAME_REL=`(/bin/uname -X|grep Release|sed -e 's/.*= //')` + (/bin/uname -X|grep i80486 >/dev/null) && UNAME_MACHINE=i486 + (/bin/uname -X|grep '^Machine.*Pentium' >/dev/null) \ + && UNAME_MACHINE=i586 + (/bin/uname -X|grep '^Machine.*Pent *II' >/dev/null) \ + && UNAME_MACHINE=i686 + (/bin/uname -X|grep '^Machine.*Pentium Pro' >/dev/null) \ + && UNAME_MACHINE=i686 + GUESS=$UNAME_MACHINE-pc-sco$UNAME_REL + else + GUESS=$UNAME_MACHINE-pc-sysv32 + fi + ;; + pc:*:*:*) + # Left here for compatibility: + # uname -m prints for DJGPP always 'pc', but it prints nothing about + # the processor, so we play safe by assuming i586. + # Note: whatever this is, it MUST be the same as what config.sub + # prints for the "djgpp" host, or else GDB configure will decide that + # this is a cross-build. + GUESS=i586-pc-msdosdjgpp + ;; + Intel:Mach:3*:*) + GUESS=i386-pc-mach3 + ;; + paragon:*:*:*) + GUESS=i860-intel-osf1 + ;; + i860:*:4.*:*) # i860-SVR4 + if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then + GUESS=i860-stardent-sysv$UNAME_RELEASE # Stardent Vistra i860-SVR4 + else # Add other i860-SVR4 vendors below as they are discovered. + GUESS=i860-unknown-sysv$UNAME_RELEASE # Unknown i860-SVR4 + fi + ;; + mini*:CTIX:SYS*5:*) + # "miniframe" + GUESS=m68010-convergent-sysv + ;; + mc68k:UNIX:SYSTEM5:3.51m) + GUESS=m68k-convergent-sysv + ;; + M680?0:D-NIX:5.3:*) + GUESS=m68k-diab-dnix + ;; + M68*:*:R3V[5678]*:*) + test -r /sysV68 && { echo 'm68k-motorola-sysv'; exit; } ;; + 3[345]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0 | S7501*:*:4.0:3.0) + OS_REL='' + test -r /etc/.relid \ + && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` + /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ + && { echo i486-ncr-sysv4.3"$OS_REL"; exit; } + /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ + && { echo i586-ncr-sysv4.3"$OS_REL"; exit; } ;; + 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) + /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ + && { echo i486-ncr-sysv4; exit; } ;; + NCR*:*:4.2:* | MPRAS*:*:4.2:*) + OS_REL='.3' + test -r /etc/.relid \ + && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` + /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ + && { echo i486-ncr-sysv4.3"$OS_REL"; exit; } + /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ + && { echo i586-ncr-sysv4.3"$OS_REL"; exit; } + /bin/uname -p 2>/dev/null | /bin/grep pteron >/dev/null \ + && { echo i586-ncr-sysv4.3"$OS_REL"; exit; } ;; + m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*) + GUESS=m68k-unknown-lynxos$UNAME_RELEASE + ;; + mc68030:UNIX_System_V:4.*:*) + GUESS=m68k-atari-sysv4 + ;; + TSUNAMI:LynxOS:2.*:*) + GUESS=sparc-unknown-lynxos$UNAME_RELEASE + ;; + rs6000:LynxOS:2.*:*) + GUESS=rs6000-unknown-lynxos$UNAME_RELEASE + ;; + PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.[02]*:*) + GUESS=powerpc-unknown-lynxos$UNAME_RELEASE + ;; + SM[BE]S:UNIX_SV:*:*) + GUESS=mips-dde-sysv$UNAME_RELEASE + ;; + RM*:ReliantUNIX-*:*:*) + GUESS=mips-sni-sysv4 + ;; + RM*:SINIX-*:*:*) + GUESS=mips-sni-sysv4 + ;; + *:SINIX-*:*:*) + if uname -p 2>/dev/null >/dev/null ; then + UNAME_MACHINE=`(uname -p) 2>/dev/null` + GUESS=$UNAME_MACHINE-sni-sysv4 + else + GUESS=ns32k-sni-sysv + fi + ;; + PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort + # says + GUESS=i586-unisys-sysv4 + ;; + *:UNIX_System_V:4*:FTX*) + # From Gerald Hewes . + # How about differentiating between stratus architectures? -djm + GUESS=hppa1.1-stratus-sysv4 + ;; + *:*:*:FTX*) + # From seanf@swdc.stratus.com. + GUESS=i860-stratus-sysv4 + ;; + i*86:VOS:*:*) + # From Paul.Green@stratus.com. + GUESS=$UNAME_MACHINE-stratus-vos + ;; + *:VOS:*:*) + # From Paul.Green@stratus.com. + GUESS=hppa1.1-stratus-vos + ;; + mc68*:A/UX:*:*) + GUESS=m68k-apple-aux$UNAME_RELEASE + ;; + news*:NEWS-OS:6*:*) + GUESS=mips-sony-newsos6 + ;; + R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*) + if test -d /usr/nec; then + GUESS=mips-nec-sysv$UNAME_RELEASE + else + GUESS=mips-unknown-sysv$UNAME_RELEASE + fi + ;; + BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only. + GUESS=powerpc-be-beos + ;; + BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only. + GUESS=powerpc-apple-beos + ;; + BePC:BeOS:*:*) # BeOS running on Intel PC compatible. + GUESS=i586-pc-beos + ;; + BePC:Haiku:*:*) # Haiku running on Intel PC compatible. + GUESS=i586-pc-haiku + ;; + x86_64:Haiku:*:*) + GUESS=x86_64-unknown-haiku + ;; + SX-4:SUPER-UX:*:*) + GUESS=sx4-nec-superux$UNAME_RELEASE + ;; + SX-5:SUPER-UX:*:*) + GUESS=sx5-nec-superux$UNAME_RELEASE + ;; + SX-6:SUPER-UX:*:*) + GUESS=sx6-nec-superux$UNAME_RELEASE + ;; + SX-7:SUPER-UX:*:*) + GUESS=sx7-nec-superux$UNAME_RELEASE + ;; + SX-8:SUPER-UX:*:*) + GUESS=sx8-nec-superux$UNAME_RELEASE + ;; + SX-8R:SUPER-UX:*:*) + GUESS=sx8r-nec-superux$UNAME_RELEASE + ;; + SX-ACE:SUPER-UX:*:*) + GUESS=sxace-nec-superux$UNAME_RELEASE + ;; + Power*:Rhapsody:*:*) + GUESS=powerpc-apple-rhapsody$UNAME_RELEASE + ;; + *:Rhapsody:*:*) + GUESS=$UNAME_MACHINE-apple-rhapsody$UNAME_RELEASE + ;; + arm64:Darwin:*:*) + GUESS=aarch64-apple-darwin$UNAME_RELEASE + ;; + *:Darwin:*:*) + UNAME_PROCESSOR=`uname -p` + case $UNAME_PROCESSOR in + unknown) UNAME_PROCESSOR=powerpc ;; + esac + if command -v xcode-select > /dev/null 2> /dev/null && \ + ! xcode-select --print-path > /dev/null 2> /dev/null ; then + # Avoid executing cc if there is no toolchain installed as + # cc will be a stub that puts up a graphical alert + # prompting the user to install developer tools. + CC_FOR_BUILD=no_compiler_found + else + set_cc_for_build + fi + if test "$CC_FOR_BUILD" != no_compiler_found; then + if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \ + (CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | \ + grep IS_64BIT_ARCH >/dev/null + then + case $UNAME_PROCESSOR in + i386) UNAME_PROCESSOR=x86_64 ;; + powerpc) UNAME_PROCESSOR=powerpc64 ;; + esac + fi + # On 10.4-10.6 one might compile for PowerPC via gcc -arch ppc + if (echo '#ifdef __POWERPC__'; echo IS_PPC; echo '#endif') | \ + (CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | \ + grep IS_PPC >/dev/null + then + UNAME_PROCESSOR=powerpc + fi + elif test "$UNAME_PROCESSOR" = i386 ; then + # uname -m returns i386 or x86_64 + UNAME_PROCESSOR=$UNAME_MACHINE + fi + GUESS=$UNAME_PROCESSOR-apple-darwin$UNAME_RELEASE + ;; + *:procnto*:*:* | *:QNX:[0123456789]*:*) + UNAME_PROCESSOR=`uname -p` + if test "$UNAME_PROCESSOR" = x86; then + UNAME_PROCESSOR=i386 + UNAME_MACHINE=pc + fi + GUESS=$UNAME_PROCESSOR-$UNAME_MACHINE-nto-qnx$UNAME_RELEASE + ;; + *:QNX:*:4*) + GUESS=i386-pc-qnx + ;; + NEO-*:NONSTOP_KERNEL:*:*) + GUESS=neo-tandem-nsk$UNAME_RELEASE + ;; + NSE-*:NONSTOP_KERNEL:*:*) + GUESS=nse-tandem-nsk$UNAME_RELEASE + ;; + NSR-*:NONSTOP_KERNEL:*:*) + GUESS=nsr-tandem-nsk$UNAME_RELEASE + ;; + NSV-*:NONSTOP_KERNEL:*:*) + GUESS=nsv-tandem-nsk$UNAME_RELEASE + ;; + NSX-*:NONSTOP_KERNEL:*:*) + GUESS=nsx-tandem-nsk$UNAME_RELEASE + ;; + *:NonStop-UX:*:*) + GUESS=mips-compaq-nonstopux + ;; + BS2000:POSIX*:*:*) + GUESS=bs2000-siemens-sysv + ;; + DS/*:UNIX_System_V:*:*) + GUESS=$UNAME_MACHINE-$UNAME_SYSTEM-$UNAME_RELEASE + ;; + *:Plan9:*:*) + # "uname -m" is not consistent, so use $cputype instead. 386 + # is converted to i386 for consistency with other x86 + # operating systems. + if test "${cputype-}" = 386; then + UNAME_MACHINE=i386 + elif test "x${cputype-}" != x; then + UNAME_MACHINE=$cputype + fi + GUESS=$UNAME_MACHINE-unknown-plan9 + ;; + *:TOPS-10:*:*) + GUESS=pdp10-unknown-tops10 + ;; + *:TENEX:*:*) + GUESS=pdp10-unknown-tenex + ;; + KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*) + GUESS=pdp10-dec-tops20 + ;; + XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*) + GUESS=pdp10-xkl-tops20 + ;; + *:TOPS-20:*:*) + GUESS=pdp10-unknown-tops20 + ;; + *:ITS:*:*) + GUESS=pdp10-unknown-its + ;; + SEI:*:*:SEIUX) + GUESS=mips-sei-seiux$UNAME_RELEASE + ;; + *:DragonFly:*:*) + DRAGONFLY_REL=`echo "$UNAME_RELEASE" | sed -e 's/[-(].*//'` + GUESS=$UNAME_MACHINE-unknown-dragonfly$DRAGONFLY_REL + ;; + *:*VMS:*:*) + UNAME_MACHINE=`(uname -p) 2>/dev/null` + case $UNAME_MACHINE in + A*) GUESS=alpha-dec-vms ;; + I*) GUESS=ia64-dec-vms ;; + V*) GUESS=vax-dec-vms ;; + esac ;; + *:XENIX:*:SysV) + GUESS=i386-pc-xenix + ;; + i*86:skyos:*:*) + SKYOS_REL=`echo "$UNAME_RELEASE" | sed -e 's/ .*$//'` + GUESS=$UNAME_MACHINE-pc-skyos$SKYOS_REL + ;; + i*86:rdos:*:*) + GUESS=$UNAME_MACHINE-pc-rdos + ;; + i*86:Fiwix:*:*) + GUESS=$UNAME_MACHINE-pc-fiwix + ;; + *:AROS:*:*) + GUESS=$UNAME_MACHINE-unknown-aros + ;; + x86_64:VMkernel:*:*) + GUESS=$UNAME_MACHINE-unknown-esx + ;; + amd64:Isilon\ OneFS:*:*) + GUESS=x86_64-unknown-onefs + ;; + *:Unleashed:*:*) + GUESS=$UNAME_MACHINE-unknown-unleashed$UNAME_RELEASE + ;; +esac + +# Do we have a guess based on uname results? +if test "x$GUESS" != x; then + echo "$GUESS" + exit +fi + +# No uname command or uname output not recognized. +set_cc_for_build +cat > "$dummy.c" < +#include +#endif +#if defined(ultrix) || defined(_ultrix) || defined(__ultrix) || defined(__ultrix__) +#if defined (vax) || defined (__vax) || defined (__vax__) || defined(mips) || defined(__mips) || defined(__mips__) || defined(MIPS) || defined(__MIPS__) +#include +#if defined(_SIZE_T_) || defined(SIGLOST) +#include +#endif +#endif +#endif +main () +{ +#if defined (sony) +#if defined (MIPSEB) + /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed, + I don't know.... */ + printf ("mips-sony-bsd\n"); exit (0); +#else +#include + printf ("m68k-sony-newsos%s\n", +#ifdef NEWSOS4 + "4" +#else + "" +#endif + ); exit (0); +#endif +#endif + +#if defined (NeXT) +#if !defined (__ARCHITECTURE__) +#define __ARCHITECTURE__ "m68k" +#endif + int version; + version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`; + if (version < 4) + printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version); + else + printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version); + exit (0); +#endif + +#if defined (MULTIMAX) || defined (n16) +#if defined (UMAXV) + printf ("ns32k-encore-sysv\n"); exit (0); +#else +#if defined (CMU) + printf ("ns32k-encore-mach\n"); exit (0); +#else + printf ("ns32k-encore-bsd\n"); exit (0); +#endif +#endif +#endif + +#if defined (__386BSD__) + printf ("i386-pc-bsd\n"); exit (0); +#endif + +#if defined (sequent) +#if defined (i386) + printf ("i386-sequent-dynix\n"); exit (0); +#endif +#if defined (ns32000) + printf ("ns32k-sequent-dynix\n"); exit (0); +#endif +#endif + +#if defined (_SEQUENT_) + struct utsname un; + + uname(&un); + if (strncmp(un.version, "V2", 2) == 0) { + printf ("i386-sequent-ptx2\n"); exit (0); + } + if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */ + printf ("i386-sequent-ptx1\n"); exit (0); + } + printf ("i386-sequent-ptx\n"); exit (0); +#endif + +#if defined (vax) +#if !defined (ultrix) +#include +#if defined (BSD) +#if BSD == 43 + printf ("vax-dec-bsd4.3\n"); exit (0); +#else +#if BSD == 199006 + printf ("vax-dec-bsd4.3reno\n"); exit (0); +#else + printf ("vax-dec-bsd\n"); exit (0); +#endif +#endif +#else + printf ("vax-dec-bsd\n"); exit (0); +#endif +#else +#if defined(_SIZE_T_) || defined(SIGLOST) + struct utsname un; + uname (&un); + printf ("vax-dec-ultrix%s\n", un.release); exit (0); +#else + printf ("vax-dec-ultrix\n"); exit (0); +#endif +#endif +#endif +#if defined(ultrix) || defined(_ultrix) || defined(__ultrix) || defined(__ultrix__) +#if defined(mips) || defined(__mips) || defined(__mips__) || defined(MIPS) || defined(__MIPS__) +#if defined(_SIZE_T_) || defined(SIGLOST) + struct utsname *un; + uname (&un); + printf ("mips-dec-ultrix%s\n", un.release); exit (0); +#else + printf ("mips-dec-ultrix\n"); exit (0); +#endif +#endif +#endif + +#if defined (alliant) && defined (i860) + printf ("i860-alliant-bsd\n"); exit (0); +#endif + + exit (1); +} +EOF + +$CC_FOR_BUILD -o "$dummy" "$dummy.c" 2>/dev/null && SYSTEM_NAME=`"$dummy"` && + { echo "$SYSTEM_NAME"; exit; } + +# Apollos put the system type in the environment. +test -d /usr/apollo && { echo "$ISP-apollo-$SYSTYPE"; exit; } + +echo "$0: unable to guess system type" >&2 + +case $UNAME_MACHINE:$UNAME_SYSTEM in + mips:Linux | mips64:Linux) + # If we got here on MIPS GNU/Linux, output extra information. + cat >&2 <&2 <&2 </dev/null || echo unknown` +uname -r = `(uname -r) 2>/dev/null || echo unknown` +uname -s = `(uname -s) 2>/dev/null || echo unknown` +uname -v = `(uname -v) 2>/dev/null || echo unknown` + +/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null` +/bin/uname -X = `(/bin/uname -X) 2>/dev/null` + +hostinfo = `(hostinfo) 2>/dev/null` +/bin/universe = `(/bin/universe) 2>/dev/null` +/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null` +/bin/arch = `(/bin/arch) 2>/dev/null` +/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null` +/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null` + +UNAME_MACHINE = "$UNAME_MACHINE" +UNAME_RELEASE = "$UNAME_RELEASE" +UNAME_SYSTEM = "$UNAME_SYSTEM" +UNAME_VERSION = "$UNAME_VERSION" +EOF +fi + +exit 1 + +# Local variables: +# eval: (add-hook 'before-save-hook 'time-stamp) +# time-stamp-start: "timestamp='" +# time-stamp-format: "%:y-%02m-%02d" +# time-stamp-end: "'" +# End: diff --git a/3rdparty/curl-8.21.0/config.sub b/3rdparty/curl-8.21.0/config.sub new file mode 100755 index 0000000000..dba16e84c7 --- /dev/null +++ b/3rdparty/curl-8.21.0/config.sub @@ -0,0 +1,1890 @@ +#! /bin/sh +# Configuration validation subroutine script. +# Copyright 1992-2022 Free Software Foundation, Inc. + +# shellcheck disable=SC2006,SC2268 # see below for rationale + +timestamp='2022-01-03' + +# This file is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, see . +# +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program that contains a +# configuration script generated by Autoconf, you may include it under +# the same distribution terms that you use for the rest of that +# program. This Exception is an additional permission under section 7 +# of the GNU General Public License, version 3 ("GPLv3"). + + +# Please send patches to . +# +# Configuration subroutine to validate and canonicalize a configuration type. +# Supply the specified configuration type as an argument. +# If it is invalid, we print an error message on stderr and exit with code 1. +# Otherwise, we print the canonical config type on stdout and succeed. + +# You can get the latest version of this script from: +# https://git.savannah.gnu.org/cgit/config.git/plain/config.sub + +# This file is supposed to be the same for all GNU packages +# and recognize all the CPU types, system types and aliases +# that are meaningful with *any* GNU software. +# Each package is responsible for reporting which valid configurations +# it does not support. The user should be able to distinguish +# a failure to support a valid configuration from a meaningless +# configuration. + +# The goal of this file is to map all the various variations of a given +# machine specification into a single specification in the form: +# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM +# or in some cases, the newer four-part form: +# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM +# It is wrong to echo any other type of specification. + +# The "shellcheck disable" line above the timestamp inhibits complaints +# about features and limitations of the classic Bourne shell that were +# superseded or lifted in POSIX. However, this script identifies a wide +# variety of pre-POSIX systems that do not have POSIX shells at all, and +# even some reasonably current systems (Solaris 10 as case-in-point) still +# have a pre-POSIX /bin/sh. + +me=`echo "$0" | sed -e 's,.*/,,'` + +usage="\ +Usage: $0 [OPTION] CPU-MFR-OPSYS or ALIAS + +Canonicalize a configuration name. + +Options: + -h, --help print this help, then exit + -t, --time-stamp print date of last modification, then exit + -v, --version print version number, then exit + +Report bugs and patches to ." + +version="\ +GNU config.sub ($timestamp) + +Copyright 1992-2022 Free Software Foundation, Inc. + +This is free software; see the source for copying conditions. There is NO +warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." + +help=" +Try \`$me --help' for more information." + +# Parse command line +while test $# -gt 0 ; do + case $1 in + --time-stamp | --time* | -t ) + echo "$timestamp" ; exit ;; + --version | -v ) + echo "$version" ; exit ;; + --help | --h* | -h ) + echo "$usage"; exit ;; + -- ) # Stop option processing + shift; break ;; + - ) # Use stdin as input. + break ;; + -* ) + echo "$me: invalid option $1$help" >&2 + exit 1 ;; + + *local*) + # First pass through any local machine types. + echo "$1" + exit ;; + + * ) + break ;; + esac +done + +case $# in + 0) echo "$me: missing argument$help" >&2 + exit 1;; + 1) ;; + *) echo "$me: too many arguments$help" >&2 + exit 1;; +esac + +# Split fields of configuration type +# shellcheck disable=SC2162 +saved_IFS=$IFS +IFS="-" read field1 field2 field3 field4 <&2 + exit 1 + ;; + *-*-*-*) + basic_machine=$field1-$field2 + basic_os=$field3-$field4 + ;; + *-*-*) + # Ambiguous whether COMPANY is present, or skipped and KERNEL-OS is two + # parts + maybe_os=$field2-$field3 + case $maybe_os in + nto-qnx* | linux-* | uclinux-uclibc* \ + | uclinux-gnu* | kfreebsd*-gnu* | knetbsd*-gnu* | netbsd*-gnu* \ + | netbsd*-eabi* | kopensolaris*-gnu* | cloudabi*-eabi* \ + | storm-chaos* | os2-emx* | rtmk-nova*) + basic_machine=$field1 + basic_os=$maybe_os + ;; + android-linux) + basic_machine=$field1-unknown + basic_os=linux-android + ;; + *) + basic_machine=$field1-$field2 + basic_os=$field3 + ;; + esac + ;; + *-*) + # A lone config we happen to match not fitting any pattern + case $field1-$field2 in + decstation-3100) + basic_machine=mips-dec + basic_os= + ;; + *-*) + # Second component is usually, but not always the OS + case $field2 in + # Prevent following clause from handling this valid os + sun*os*) + basic_machine=$field1 + basic_os=$field2 + ;; + zephyr*) + basic_machine=$field1-unknown + basic_os=$field2 + ;; + # Manufacturers + dec* | mips* | sequent* | encore* | pc533* | sgi* | sony* \ + | att* | 7300* | 3300* | delta* | motorola* | sun[234]* \ + | unicom* | ibm* | next | hp | isi* | apollo | altos* \ + | convergent* | ncr* | news | 32* | 3600* | 3100* \ + | hitachi* | c[123]* | convex* | sun | crds | omron* | dg \ + | ultra | tti* | harris | dolphin | highlevel | gould \ + | cbm | ns | masscomp | apple | axis | knuth | cray \ + | microblaze* | sim | cisco \ + | oki | wec | wrs | winbond) + basic_machine=$field1-$field2 + basic_os= + ;; + *) + basic_machine=$field1 + basic_os=$field2 + ;; + esac + ;; + esac + ;; + *) + # Convert single-component short-hands not valid as part of + # multi-component configurations. + case $field1 in + 386bsd) + basic_machine=i386-pc + basic_os=bsd + ;; + a29khif) + basic_machine=a29k-amd + basic_os=udi + ;; + adobe68k) + basic_machine=m68010-adobe + basic_os=scout + ;; + alliant) + basic_machine=fx80-alliant + basic_os= + ;; + altos | altos3068) + basic_machine=m68k-altos + basic_os= + ;; + am29k) + basic_machine=a29k-none + basic_os=bsd + ;; + amdahl) + basic_machine=580-amdahl + basic_os=sysv + ;; + amiga) + basic_machine=m68k-unknown + basic_os= + ;; + amigaos | amigados) + basic_machine=m68k-unknown + basic_os=amigaos + ;; + amigaunix | amix) + basic_machine=m68k-unknown + basic_os=sysv4 + ;; + apollo68) + basic_machine=m68k-apollo + basic_os=sysv + ;; + apollo68bsd) + basic_machine=m68k-apollo + basic_os=bsd + ;; + aros) + basic_machine=i386-pc + basic_os=aros + ;; + aux) + basic_machine=m68k-apple + basic_os=aux + ;; + balance) + basic_machine=ns32k-sequent + basic_os=dynix + ;; + blackfin) + basic_machine=bfin-unknown + basic_os=linux + ;; + cegcc) + basic_machine=arm-unknown + basic_os=cegcc + ;; + convex-c1) + basic_machine=c1-convex + basic_os=bsd + ;; + convex-c2) + basic_machine=c2-convex + basic_os=bsd + ;; + convex-c32) + basic_machine=c32-convex + basic_os=bsd + ;; + convex-c34) + basic_machine=c34-convex + basic_os=bsd + ;; + convex-c38) + basic_machine=c38-convex + basic_os=bsd + ;; + cray) + basic_machine=j90-cray + basic_os=unicos + ;; + crds | unos) + basic_machine=m68k-crds + basic_os= + ;; + da30) + basic_machine=m68k-da30 + basic_os= + ;; + decstation | pmax | pmin | dec3100 | decstatn) + basic_machine=mips-dec + basic_os= + ;; + delta88) + basic_machine=m88k-motorola + basic_os=sysv3 + ;; + dicos) + basic_machine=i686-pc + basic_os=dicos + ;; + djgpp) + basic_machine=i586-pc + basic_os=msdosdjgpp + ;; + ebmon29k) + basic_machine=a29k-amd + basic_os=ebmon + ;; + es1800 | OSE68k | ose68k | ose | OSE) + basic_machine=m68k-ericsson + basic_os=ose + ;; + gmicro) + basic_machine=tron-gmicro + basic_os=sysv + ;; + go32) + basic_machine=i386-pc + basic_os=go32 + ;; + h8300hms) + basic_machine=h8300-hitachi + basic_os=hms + ;; + h8300xray) + basic_machine=h8300-hitachi + basic_os=xray + ;; + h8500hms) + basic_machine=h8500-hitachi + basic_os=hms + ;; + harris) + basic_machine=m88k-harris + basic_os=sysv3 + ;; + hp300 | hp300hpux) + basic_machine=m68k-hp + basic_os=hpux + ;; + hp300bsd) + basic_machine=m68k-hp + basic_os=bsd + ;; + hppaosf) + basic_machine=hppa1.1-hp + basic_os=osf + ;; + hppro) + basic_machine=hppa1.1-hp + basic_os=proelf + ;; + i386mach) + basic_machine=i386-mach + basic_os=mach + ;; + isi68 | isi) + basic_machine=m68k-isi + basic_os=sysv + ;; + m68knommu) + basic_machine=m68k-unknown + basic_os=linux + ;; + magnum | m3230) + basic_machine=mips-mips + basic_os=sysv + ;; + merlin) + basic_machine=ns32k-utek + basic_os=sysv + ;; + mingw64) + basic_machine=x86_64-pc + basic_os=mingw64 + ;; + mingw32) + basic_machine=i686-pc + basic_os=mingw32 + ;; + mingw32ce) + basic_machine=arm-unknown + basic_os=mingw32ce + ;; + monitor) + basic_machine=m68k-rom68k + basic_os=coff + ;; + morphos) + basic_machine=powerpc-unknown + basic_os=morphos + ;; + moxiebox) + basic_machine=moxie-unknown + basic_os=moxiebox + ;; + msdos) + basic_machine=i386-pc + basic_os=msdos + ;; + msys) + basic_machine=i686-pc + basic_os=msys + ;; + mvs) + basic_machine=i370-ibm + basic_os=mvs + ;; + nacl) + basic_machine=le32-unknown + basic_os=nacl + ;; + ncr3000) + basic_machine=i486-ncr + basic_os=sysv4 + ;; + netbsd386) + basic_machine=i386-pc + basic_os=netbsd + ;; + netwinder) + basic_machine=armv4l-rebel + basic_os=linux + ;; + news | news700 | news800 | news900) + basic_machine=m68k-sony + basic_os=newsos + ;; + news1000) + basic_machine=m68030-sony + basic_os=newsos + ;; + necv70) + basic_machine=v70-nec + basic_os=sysv + ;; + nh3000) + basic_machine=m68k-harris + basic_os=cxux + ;; + nh[45]000) + basic_machine=m88k-harris + basic_os=cxux + ;; + nindy960) + basic_machine=i960-intel + basic_os=nindy + ;; + mon960) + basic_machine=i960-intel + basic_os=mon960 + ;; + nonstopux) + basic_machine=mips-compaq + basic_os=nonstopux + ;; + os400) + basic_machine=powerpc-ibm + basic_os=os400 + ;; + OSE68000 | ose68000) + basic_machine=m68000-ericsson + basic_os=ose + ;; + os68k) + basic_machine=m68k-none + basic_os=os68k + ;; + paragon) + basic_machine=i860-intel + basic_os=osf + ;; + parisc) + basic_machine=hppa-unknown + basic_os=linux + ;; + psp) + basic_machine=mipsallegrexel-sony + basic_os=psp + ;; + pw32) + basic_machine=i586-unknown + basic_os=pw32 + ;; + rdos | rdos64) + basic_machine=x86_64-pc + basic_os=rdos + ;; + rdos32) + basic_machine=i386-pc + basic_os=rdos + ;; + rom68k) + basic_machine=m68k-rom68k + basic_os=coff + ;; + sa29200) + basic_machine=a29k-amd + basic_os=udi + ;; + sei) + basic_machine=mips-sei + basic_os=seiux + ;; + sequent) + basic_machine=i386-sequent + basic_os= + ;; + sps7) + basic_machine=m68k-bull + basic_os=sysv2 + ;; + st2000) + basic_machine=m68k-tandem + basic_os= + ;; + stratus) + basic_machine=i860-stratus + basic_os=sysv4 + ;; + sun2) + basic_machine=m68000-sun + basic_os= + ;; + sun2os3) + basic_machine=m68000-sun + basic_os=sunos3 + ;; + sun2os4) + basic_machine=m68000-sun + basic_os=sunos4 + ;; + sun3) + basic_machine=m68k-sun + basic_os= + ;; + sun3os3) + basic_machine=m68k-sun + basic_os=sunos3 + ;; + sun3os4) + basic_machine=m68k-sun + basic_os=sunos4 + ;; + sun4) + basic_machine=sparc-sun + basic_os= + ;; + sun4os3) + basic_machine=sparc-sun + basic_os=sunos3 + ;; + sun4os4) + basic_machine=sparc-sun + basic_os=sunos4 + ;; + sun4sol2) + basic_machine=sparc-sun + basic_os=solaris2 + ;; + sun386 | sun386i | roadrunner) + basic_machine=i386-sun + basic_os= + ;; + sv1) + basic_machine=sv1-cray + basic_os=unicos + ;; + symmetry) + basic_machine=i386-sequent + basic_os=dynix + ;; + t3e) + basic_machine=alphaev5-cray + basic_os=unicos + ;; + t90) + basic_machine=t90-cray + basic_os=unicos + ;; + toad1) + basic_machine=pdp10-xkl + basic_os=tops20 + ;; + tpf) + basic_machine=s390x-ibm + basic_os=tpf + ;; + udi29k) + basic_machine=a29k-amd + basic_os=udi + ;; + ultra3) + basic_machine=a29k-nyu + basic_os=sym1 + ;; + v810 | necv810) + basic_machine=v810-nec + basic_os=none + ;; + vaxv) + basic_machine=vax-dec + basic_os=sysv + ;; + vms) + basic_machine=vax-dec + basic_os=vms + ;; + vsta) + basic_machine=i386-pc + basic_os=vsta + ;; + vxworks960) + basic_machine=i960-wrs + basic_os=vxworks + ;; + vxworks68) + basic_machine=m68k-wrs + basic_os=vxworks + ;; + vxworks29k) + basic_machine=a29k-wrs + basic_os=vxworks + ;; + xbox) + basic_machine=i686-pc + basic_os=mingw32 + ;; + ymp) + basic_machine=ymp-cray + basic_os=unicos + ;; + *) + basic_machine=$1 + basic_os= + ;; + esac + ;; +esac + +# Decode 1-component or ad-hoc basic machines +case $basic_machine in + # Here we handle the default manufacturer of certain CPU types. It is in + # some cases the only manufacturer, in others, it is the most popular. + w89k) + cpu=hppa1.1 + vendor=winbond + ;; + op50n) + cpu=hppa1.1 + vendor=oki + ;; + op60c) + cpu=hppa1.1 + vendor=oki + ;; + ibm*) + cpu=i370 + vendor=ibm + ;; + orion105) + cpu=clipper + vendor=highlevel + ;; + mac | mpw | mac-mpw) + cpu=m68k + vendor=apple + ;; + pmac | pmac-mpw) + cpu=powerpc + vendor=apple + ;; + + # Recognize the various machine names and aliases which stand + # for a CPU type and a company and sometimes even an OS. + 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) + cpu=m68000 + vendor=att + ;; + 3b*) + cpu=we32k + vendor=att + ;; + bluegene*) + cpu=powerpc + vendor=ibm + basic_os=cnk + ;; + decsystem10* | dec10*) + cpu=pdp10 + vendor=dec + basic_os=tops10 + ;; + decsystem20* | dec20*) + cpu=pdp10 + vendor=dec + basic_os=tops20 + ;; + delta | 3300 | motorola-3300 | motorola-delta \ + | 3300-motorola | delta-motorola) + cpu=m68k + vendor=motorola + ;; + dpx2*) + cpu=m68k + vendor=bull + basic_os=sysv3 + ;; + encore | umax | mmax) + cpu=ns32k + vendor=encore + ;; + elxsi) + cpu=elxsi + vendor=elxsi + basic_os=${basic_os:-bsd} + ;; + fx2800) + cpu=i860 + vendor=alliant + ;; + genix) + cpu=ns32k + vendor=ns + ;; + h3050r* | hiux*) + cpu=hppa1.1 + vendor=hitachi + basic_os=hiuxwe2 + ;; + hp3k9[0-9][0-9] | hp9[0-9][0-9]) + cpu=hppa1.0 + vendor=hp + ;; + hp9k2[0-9][0-9] | hp9k31[0-9]) + cpu=m68000 + vendor=hp + ;; + hp9k3[2-9][0-9]) + cpu=m68k + vendor=hp + ;; + hp9k6[0-9][0-9] | hp6[0-9][0-9]) + cpu=hppa1.0 + vendor=hp + ;; + hp9k7[0-79][0-9] | hp7[0-79][0-9]) + cpu=hppa1.1 + vendor=hp + ;; + hp9k78[0-9] | hp78[0-9]) + # FIXME: really hppa2.0-hp + cpu=hppa1.1 + vendor=hp + ;; + hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893) + # FIXME: really hppa2.0-hp + cpu=hppa1.1 + vendor=hp + ;; + hp9k8[0-9][13679] | hp8[0-9][13679]) + cpu=hppa1.1 + vendor=hp + ;; + hp9k8[0-9][0-9] | hp8[0-9][0-9]) + cpu=hppa1.0 + vendor=hp + ;; + i*86v32) + cpu=`echo "$1" | sed -e 's/86.*/86/'` + vendor=pc + basic_os=sysv32 + ;; + i*86v4*) + cpu=`echo "$1" | sed -e 's/86.*/86/'` + vendor=pc + basic_os=sysv4 + ;; + i*86v) + cpu=`echo "$1" | sed -e 's/86.*/86/'` + vendor=pc + basic_os=sysv + ;; + i*86sol2) + cpu=`echo "$1" | sed -e 's/86.*/86/'` + vendor=pc + basic_os=solaris2 + ;; + j90 | j90-cray) + cpu=j90 + vendor=cray + basic_os=${basic_os:-unicos} + ;; + iris | iris4d) + cpu=mips + vendor=sgi + case $basic_os in + irix*) + ;; + *) + basic_os=irix4 + ;; + esac + ;; + miniframe) + cpu=m68000 + vendor=convergent + ;; + *mint | mint[0-9]* | *MiNT | *MiNT[0-9]*) + cpu=m68k + vendor=atari + basic_os=mint + ;; + news-3600 | risc-news) + cpu=mips + vendor=sony + basic_os=newsos + ;; + next | m*-next) + cpu=m68k + vendor=next + case $basic_os in + openstep*) + ;; + nextstep*) + ;; + ns2*) + basic_os=nextstep2 + ;; + *) + basic_os=nextstep3 + ;; + esac + ;; + np1) + cpu=np1 + vendor=gould + ;; + op50n-* | op60c-*) + cpu=hppa1.1 + vendor=oki + basic_os=proelf + ;; + pa-hitachi) + cpu=hppa1.1 + vendor=hitachi + basic_os=hiuxwe2 + ;; + pbd) + cpu=sparc + vendor=tti + ;; + pbb) + cpu=m68k + vendor=tti + ;; + pc532) + cpu=ns32k + vendor=pc532 + ;; + pn) + cpu=pn + vendor=gould + ;; + power) + cpu=power + vendor=ibm + ;; + ps2) + cpu=i386 + vendor=ibm + ;; + rm[46]00) + cpu=mips + vendor=siemens + ;; + rtpc | rtpc-*) + cpu=romp + vendor=ibm + ;; + sde) + cpu=mipsisa32 + vendor=sde + basic_os=${basic_os:-elf} + ;; + simso-wrs) + cpu=sparclite + vendor=wrs + basic_os=vxworks + ;; + tower | tower-32) + cpu=m68k + vendor=ncr + ;; + vpp*|vx|vx-*) + cpu=f301 + vendor=fujitsu + ;; + w65) + cpu=w65 + vendor=wdc + ;; + w89k-*) + cpu=hppa1.1 + vendor=winbond + basic_os=proelf + ;; + none) + cpu=none + vendor=none + ;; + leon|leon[3-9]) + cpu=sparc + vendor=$basic_machine + ;; + leon-*|leon[3-9]-*) + cpu=sparc + vendor=`echo "$basic_machine" | sed 's/-.*//'` + ;; + + *-*) + # shellcheck disable=SC2162 + saved_IFS=$IFS + IFS="-" read cpu vendor <&2 + exit 1 + ;; + esac + ;; +esac + +# Here we canonicalize certain aliases for manufacturers. +case $vendor in + digital*) + vendor=dec + ;; + commodore*) + vendor=cbm + ;; + *) + ;; +esac + +# Decode manufacturer-specific aliases for certain operating systems. + +if test x$basic_os != x +then + +# First recognize some ad-hoc cases, or perhaps split kernel-os, or else just +# set os. +case $basic_os in + gnu/linux*) + kernel=linux + os=`echo "$basic_os" | sed -e 's|gnu/linux|gnu|'` + ;; + os2-emx) + kernel=os2 + os=`echo "$basic_os" | sed -e 's|os2-emx|emx|'` + ;; + nto-qnx*) + kernel=nto + os=`echo "$basic_os" | sed -e 's|nto-qnx|qnx|'` + ;; + *-*) + # shellcheck disable=SC2162 + saved_IFS=$IFS + IFS="-" read kernel os <&2 + exit 1 + ;; +esac + +# As a final step for OS-related things, validate the OS-kernel combination +# (given a valid OS), if there is a kernel. +case $kernel-$os in + linux-gnu* | linux-dietlibc* | linux-android* | linux-newlib* \ + | linux-musl* | linux-relibc* | linux-uclibc* ) + ;; + uclinux-uclibc* ) + ;; + -dietlibc* | -newlib* | -musl* | -relibc* | -uclibc* ) + # These are just libc implementations, not actual OSes, and thus + # require a kernel. + echo "Invalid configuration \`$1': libc \`$os' needs explicit kernel." 1>&2 + exit 1 + ;; + kfreebsd*-gnu* | kopensolaris*-gnu*) + ;; + vxworks-simlinux | vxworks-simwindows | vxworks-spe) + ;; + nto-qnx*) + ;; + os2-emx) + ;; + *-eabi* | *-gnueabi*) + ;; + -*) + # Blank kernel with real OS is always fine. + ;; + *-*) + echo "Invalid configuration \`$1': Kernel \`$kernel' not known to work with OS \`$os'." 1>&2 + exit 1 + ;; +esac + +# Here we handle the case where we know the os, and the CPU type, but not the +# manufacturer. We pick the logical manufacturer. +case $vendor in + unknown) + case $cpu-$os in + *-riscix*) + vendor=acorn + ;; + *-sunos*) + vendor=sun + ;; + *-cnk* | *-aix*) + vendor=ibm + ;; + *-beos*) + vendor=be + ;; + *-hpux*) + vendor=hp + ;; + *-mpeix*) + vendor=hp + ;; + *-hiux*) + vendor=hitachi + ;; + *-unos*) + vendor=crds + ;; + *-dgux*) + vendor=dg + ;; + *-luna*) + vendor=omron + ;; + *-genix*) + vendor=ns + ;; + *-clix*) + vendor=intergraph + ;; + *-mvs* | *-opened*) + vendor=ibm + ;; + *-os400*) + vendor=ibm + ;; + s390-* | s390x-*) + vendor=ibm + ;; + *-ptx*) + vendor=sequent + ;; + *-tpf*) + vendor=ibm + ;; + *-vxsim* | *-vxworks* | *-windiss*) + vendor=wrs + ;; + *-aux*) + vendor=apple + ;; + *-hms*) + vendor=hitachi + ;; + *-mpw* | *-macos*) + vendor=apple + ;; + *-*mint | *-mint[0-9]* | *-*MiNT | *-MiNT[0-9]*) + vendor=atari + ;; + *-vos*) + vendor=stratus + ;; + esac + ;; +esac + +echo "$cpu-$vendor-${kernel:+$kernel-}$os" +exit + +# Local variables: +# eval: (add-hook 'before-save-hook 'time-stamp) +# time-stamp-start: "timestamp='" +# time-stamp-format: "%:y-%02m-%02d" +# time-stamp-end: "'" +# End: diff --git a/3rdparty/curl-8.21.0/configure b/3rdparty/curl-8.21.0/configure new file mode 100755 index 0000000000..368831bb46 --- /dev/null +++ b/3rdparty/curl-8.21.0/configure @@ -0,0 +1,52925 @@ +#! /bin/sh +# Guess values for system-dependent variables and create Makefiles. +# Generated by GNU Autoconf 2.71 for curl -. +# +# Report bugs to . +# +# +# Copyright (C) 1992-1996, 1998-2017, 2020-2021 Free Software Foundation, +# Inc. +# +# +# This configure script is free software; the Free Software Foundation +# gives unlimited permission to copy, distribute and modify it. +# +# Copyright (C) Daniel Stenberg, +# This configure script may be copied, distributed and modified under the +# terms of the curl license; see COPYING for more details + +## -------------------------------- ## +## XC_CONFIGURE_PREAMBLE ver: 1.0 ## +## -------------------------------- ## + +xc_configure_preamble_ver_major='1' +xc_configure_preamble_ver_minor='0' + + +xc_space=' ' +xc_tab=' ' +xc_newline=' +' +IFS="$xc_space$xc_tab$xc_newline" + + +LANG='C' +LC_ALL='C' +LANGUAGE='C' +export LANG +export LC_ALL +export LANGUAGE + + +xc_msg_warn='configure: WARNING:' +xc_msg_abrt='Can not continue.' +xc_msg_err='configure: error:' + + + + +xc_tst_str='unknown' +(`echo "$xc_tst_str" >/dev/null 2>&1`) && xc_tst_str='success' +case "x$xc_tst_str" in # (( + xsuccess) + : + ;; + *) + echo "$xc_msg_err 'echo' command not found. $xc_msg_abrt" >&2 + exit 1 + ;; +esac + + + + +xc_tst_str='unknown' +(`test -n "$xc_tst_str" >/dev/null 2>&1`) && xc_tst_str='success' +case "x$xc_tst_str" in # (( + xsuccess) + : + ;; + *) + echo "$xc_msg_err 'test' command not found. $xc_msg_abrt" >&2 + exit 1 + ;; +esac + + + + +xc_tst_str='unknown' +(`test -n "$PATH" >/dev/null 2>&1`) && xc_tst_str='success' +case "x$xc_tst_str" in # (( + xsuccess) + : + ;; + *) + echo "$xc_msg_err 'PATH' variable not set. $xc_msg_abrt" >&2 + exit 1 + ;; +esac + + + + +xc_tst_str='unknown' +xc_tst_str=`expr "$xc_tst_str" : '.*' 2>/dev/null` +case "x$xc_tst_str" in # (( + x7) + : + ;; + *) + echo "$xc_msg_err 'expr' command not found. $xc_msg_abrt" >&2 + exit 1 + ;; +esac + + + + +xc_tst_str='unknown' +xc_tst_str=`echo "$xc_tst_str" 2>/dev/null \ + | sed -e 's:unknown:success:' 2>/dev/null` +case "x$xc_tst_str" in # (( + xsuccess) + : + ;; + *) + echo "$xc_msg_err 'sed' utility not found in 'PATH'. $xc_msg_abrt" >&2 + exit 1 + ;; +esac + + + + +xc_tst_str='unknown' +(`echo "$xc_tst_str" 2>/dev/null \ + | grep 'unknown' >/dev/null 2>&1`) && xc_tst_str='success' +case "x$xc_tst_str" in # (( + xsuccess) + : + ;; + *) + echo "$xc_msg_err 'grep' utility not found in 'PATH'. $xc_msg_abrt" >&2 + exit 1 + ;; +esac + + + + +xc_tst_str="${xc_tab}98s7u6c5c4e3s2s10" +xc_tst_str=`echo "$xc_tst_str" 2>/dev/null \ + | tr -d "0123456789$xc_tab" 2>/dev/null` +case "x$xc_tst_str" in # (( + xsuccess) + : + ;; + *) + echo "$xc_msg_err 'tr' utility not found in 'PATH'. $xc_msg_abrt" >&2 + exit 1 + ;; +esac + + + + +xc_tst_str='unknown unknown unknown unknown' +xc_tst_str=`echo "$xc_tst_str" 2>/dev/null \ + | wc -w 2>/dev/null | tr -d "$xc_space$xc_tab" 2>/dev/null` +case "x$xc_tst_str" in # (( + x4) + : + ;; + *) + echo "$xc_msg_err 'wc' utility not found in 'PATH'. $xc_msg_abrt" >&2 + exit 1 + ;; +esac + + + + +xc_tst_str='unknown' +xc_tst_str=`cat <<_EOT 2>/dev/null \ + | wc -l 2>/dev/null | tr -d "$xc_space$xc_tab" 2>/dev/null +unknown +unknown +unknown +_EOT` +case "x$xc_tst_str" in # (( + x3) + : + ;; + *) + echo "$xc_msg_err 'cat' utility not found in 'PATH'. $xc_msg_abrt" >&2 + exit 1 + ;; +esac + + + + +xc_tst_dirs_col='x' +xc_tst_prev_IFS=$IFS; IFS=':' +for xc_tst_dir in $PATH; do + IFS=$xc_tst_prev_IFS + xc_tst_dirs_col="x$xc_tst_dirs_col" +done +IFS=$xc_tst_prev_IFS +xc_tst_dirs_col=`expr "$xc_tst_dirs_col" : '.*'` + +xc_tst_dirs_sem='x' +xc_tst_prev_IFS=$IFS; IFS=';' +for xc_tst_dir in $PATH; do + IFS=$xc_tst_prev_IFS + xc_tst_dirs_sem="x$xc_tst_dirs_sem" +done +IFS=$xc_tst_prev_IFS +xc_tst_dirs_sem=`expr "$xc_tst_dirs_sem" : '.*'` + +if test "$xc_tst_dirs_sem" -eq "$xc_tst_dirs_col"; then + if test -z "$PATH_SEPARATOR"; then + echo "$xc_msg_warn path separator not determined, guessing colon" >&2 + PATH_SEPARATOR=':' + fi +else + if test "$xc_tst_dirs_sem" -gt "$xc_tst_dirs_col"; then + xc_tst_auto_separator=';' + else + xc_tst_auto_separator=':' + fi + if test -z "$PATH_SEPARATOR"; then + PATH_SEPARATOR=$xc_tst_auto_separator + elif test "x$PATH_SEPARATOR" != "x$xc_tst_auto_separator"; then + echo "$xc_msg_warn 'PATH_SEPARATOR' does not match auto-detected one." >&2 + fi +fi +xc_PATH_SEPARATOR=$PATH_SEPARATOR + + + + + + + + + + + + + + + +xc_configure_preamble_result='yes' + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +## -------------------- ## +## M4sh Initialization. ## +## -------------------- ## + +# Be more Bourne compatible +DUALCASE=1; export DUALCASE # for MKS sh +as_nop=: +if test ${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1 +then : + emulate sh + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which + # is contrary to our usage. Disable this feature. + alias -g '${1+"$@"}'='"$@"' + setopt NO_GLOB_SUBST +else $as_nop + case `(set -o) 2>/dev/null` in #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi + + + +# Reset variables that may have inherited troublesome values from +# the environment. + +# IFS needs to be set, to space, tab, and newline, in precisely that order. +# (If _AS_PATH_WALK were called with IFS unset, it would have the +# side effect of setting IFS to empty, thus disabling word splitting.) +# Quoting is to prevent editors from complaining about space-tab. +as_nl=' +' +export as_nl +IFS=" "" $as_nl" + +PS1='$ ' +PS2='> ' +PS4='+ ' + +# Ensure predictable behavior from utilities with locale-dependent output. +LC_ALL=C +export LC_ALL +LANGUAGE=C +export LANGUAGE + +# We cannot yet rely on "unset" to work, but we need these variables +# to be unset--not just set to an empty or harmless value--now, to +# avoid bugs in old shells (e.g. pre-3.0 UWIN ksh). This construct +# also avoids known problems related to "unset" and subshell syntax +# in other old shells (e.g. bash 2.01 and pdksh 5.2.14). +for as_var in BASH_ENV ENV MAIL MAILPATH CDPATH +do eval test \${$as_var+y} \ + && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : +done + +# Ensure that fds 0, 1, and 2 are open. +if (exec 3>&0) 2>/dev/null; then :; else exec 0&1) 2>/dev/null; then :; else exec 1>/dev/null; fi +if (exec 3>&2) ; then :; else exec 2>/dev/null; fi + + + + + + +# Find who we are. Look in the path if we contain no directory separator. +as_myself= +case $0 in #(( + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + test -r "$as_dir$0" && as_myself=$as_dir$0 && break + done +IFS=$as_save_IFS + + ;; +esac +# We did not find ourselves, most probably we were run as `sh COMMAND' +# in which case we are not to be found in the path. +if test "x$as_myself" = x; then + as_myself=$0 +fi +if test ! -f "$as_myself"; then + printf "%s\n" "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 + exit 1 +fi + + +# Use a proper internal environment variable to ensure we don't fall + # into an infinite loop, continuously re-executing ourselves. + if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then + _as_can_reexec=no; export _as_can_reexec; + # We cannot yet assume a decent shell, so we have to provide a +# neutralization value for shells without unset; and this also +# works around shells that cannot unset nonexistent variables. +# Preserve -v and -x to the replacement shell. +BASH_ENV=/dev/null +ENV=/dev/null +(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV +case $- in # (((( + *v*x* | *x*v* ) as_opts=-vx ;; + *v* ) as_opts=-v ;; + *x* ) as_opts=-x ;; + * ) as_opts= ;; +esac +exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} +# Admittedly, this is quite paranoid, since all the known shells bail +# out after a failed `exec'. +printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2 +exit 255 + fi + # We don't want this to propagate to other subprocesses. + { _as_can_reexec=; unset _as_can_reexec;} +if test "x$CONFIG_SHELL" = x; then + as_bourne_compatible="as_nop=: +if test \${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1 +then : + emulate sh + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which + # is contrary to our usage. Disable this feature. + alias -g '\${1+\"\$@\"}'='\"\$@\"' + setopt NO_GLOB_SUBST +else \$as_nop + case \`(set -o) 2>/dev/null\` in #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi +" + as_required="as_fn_return () { (exit \$1); } +as_fn_success () { as_fn_return 0; } +as_fn_failure () { as_fn_return 1; } +as_fn_ret_success () { return 0; } +as_fn_ret_failure () { return 1; } + +exitcode=0 +as_fn_success || { exitcode=1; echo as_fn_success failed.; } +as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } +as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } +as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } +if ( set x; as_fn_ret_success y && test x = \"\$1\" ) +then : + +else \$as_nop + exitcode=1; echo positional parameters were not saved. +fi +test x\$exitcode = x0 || exit 1 +blah=\$(echo \$(echo blah)) +test x\"\$blah\" = xblah || exit 1 +test -x / || exit 1" + as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO + as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO + eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && + test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1 +test \$(( 1 + 1 )) = 2 || exit 1 + + test -n \"\${ZSH_VERSION+set}\${BASH_VERSION+set}\" || ( + ECHO='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' + ECHO=\$ECHO\$ECHO\$ECHO\$ECHO\$ECHO + ECHO=\$ECHO\$ECHO\$ECHO\$ECHO\$ECHO\$ECHO + PATH=/empty FPATH=/empty; export PATH FPATH + test \"X\`printf %s \$ECHO\`\" = \"X\$ECHO\" \\ + || test \"X\`print -r -- \$ECHO\`\" = \"X\$ECHO\" ) || exit 1" + if (eval "$as_required") 2>/dev/null +then : + as_have_required=yes +else $as_nop + as_have_required=no +fi + if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null +then : + +else $as_nop + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_found=false +for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + as_found=: + case $as_dir in #( + /*) + for as_base in sh bash ksh sh5; do + # Try only shells that exist, to save several forks. + as_shell=$as_dir$as_base + if { test -f "$as_shell" || test -f "$as_shell.exe"; } && + as_run=a "$as_shell" -c "$as_bourne_compatible""$as_required" 2>/dev/null +then : + CONFIG_SHELL=$as_shell as_have_required=yes + if as_run=a "$as_shell" -c "$as_bourne_compatible""$as_suggested" 2>/dev/null +then : + break 2 +fi +fi + done;; + esac + as_found=false +done +IFS=$as_save_IFS +if $as_found +then : + +else $as_nop + if { test -f "$SHELL" || test -f "$SHELL.exe"; } && + as_run=a "$SHELL" -c "$as_bourne_compatible""$as_required" 2>/dev/null +then : + CONFIG_SHELL=$SHELL as_have_required=yes +fi +fi + + + if test "x$CONFIG_SHELL" != x +then : + export CONFIG_SHELL + # We cannot yet assume a decent shell, so we have to provide a +# neutralization value for shells without unset; and this also +# works around shells that cannot unset nonexistent variables. +# Preserve -v and -x to the replacement shell. +BASH_ENV=/dev/null +ENV=/dev/null +(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV +case $- in # (((( + *v*x* | *x*v* ) as_opts=-vx ;; + *v* ) as_opts=-v ;; + *x* ) as_opts=-x ;; + * ) as_opts= ;; +esac +exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} +# Admittedly, this is quite paranoid, since all the known shells bail +# out after a failed `exec'. +printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2 +exit 255 +fi + + if test x$as_have_required = xno +then : + printf "%s\n" "$0: This script requires a shell more modern than all" + printf "%s\n" "$0: the shells that I found on your system." + if test ${ZSH_VERSION+y} ; then + printf "%s\n" "$0: In particular, zsh $ZSH_VERSION has bugs and should" + printf "%s\n" "$0: be upgraded to zsh 4.3.4 or later." + else + printf "%s\n" "$0: Please tell bug-autoconf@gnu.org and a suitable curl +$0: mailing list: https://curl.se/mail/ about your system, +$0: including any error possibly output before this +$0: message. Then install a modern shell, or manually run +$0: the script under such a shell if you do have one." + fi + exit 1 +fi +fi +fi +SHELL=${CONFIG_SHELL-/bin/sh} +export SHELL +# Unset more variables known to interfere with behavior of common tools. +CLICOLOR_FORCE= GREP_OPTIONS= +unset CLICOLOR_FORCE GREP_OPTIONS + +## --------------------- ## +## M4sh Shell Functions. ## +## --------------------- ## +# as_fn_unset VAR +# --------------- +# Portably unset VAR. +as_fn_unset () +{ + { eval $1=; unset $1;} +} +as_unset=as_fn_unset + + +# as_fn_set_status STATUS +# ----------------------- +# Set $? to STATUS, without forking. +as_fn_set_status () +{ + return $1 +} # as_fn_set_status + +# as_fn_exit STATUS +# ----------------- +# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. +as_fn_exit () +{ + set +e + as_fn_set_status $1 + exit $1 +} # as_fn_exit +# as_fn_nop +# --------- +# Do nothing but, unlike ":", preserve the value of $?. +as_fn_nop () +{ + return $? +} +as_nop=as_fn_nop + +# as_fn_mkdir_p +# ------------- +# Create "$as_dir" as a directory, including parents if necessary. +as_fn_mkdir_p () +{ + + case $as_dir in #( + -*) as_dir=./$as_dir;; + esac + test -d "$as_dir" || eval $as_mkdir_p || { + as_dirs= + while :; do + case $as_dir in #( + *\'*) as_qdir=`printf "%s\n" "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( + *) as_qdir=$as_dir;; + esac + as_dirs="'$as_qdir' $as_dirs" + as_dir=`$as_dirname -- "$as_dir" || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || +printf "%s\n" X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + test -d "$as_dir" && break + done + test -z "$as_dirs" || eval "mkdir $as_dirs" + } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" + + +} # as_fn_mkdir_p + +# as_fn_executable_p FILE +# ----------------------- +# Test if FILE is an executable regular file. +as_fn_executable_p () +{ + test -f "$1" && test -x "$1" +} # as_fn_executable_p +# as_fn_append VAR VALUE +# ---------------------- +# Append the text in VALUE to the end of the definition contained in VAR. Take +# advantage of any shell optimizations that allow amortized linear growth over +# repeated appends, instead of the typical quadratic growth present in naive +# implementations. +if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null +then : + eval 'as_fn_append () + { + eval $1+=\$2 + }' +else $as_nop + as_fn_append () + { + eval $1=\$$1\$2 + } +fi # as_fn_append + +# as_fn_arith ARG... +# ------------------ +# Perform arithmetic evaluation on the ARGs, and store the result in the +# global $as_val. Take advantage of shells that can avoid forks. The arguments +# must be portable across $(()) and expr. +if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null +then : + eval 'as_fn_arith () + { + as_val=$(( $* )) + }' +else $as_nop + as_fn_arith () + { + as_val=`expr "$@" || test $? -eq 1` + } +fi # as_fn_arith + +# as_fn_nop +# --------- +# Do nothing but, unlike ":", preserve the value of $?. +as_fn_nop () +{ + return $? +} +as_nop=as_fn_nop + +# as_fn_error STATUS ERROR [LINENO LOG_FD] +# ---------------------------------------- +# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are +# provided, also output the error to LOG_FD, referencing LINENO. Then exit the +# script with STATUS, using 1 if that was 0. +as_fn_error () +{ + as_status=$1; test $as_status -eq 0 && as_status=1 + if test "$4"; then + as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 + fi + printf "%s\n" "$as_me: error: $2" >&2 + as_fn_exit $as_status +} # as_fn_error + +if expr a : '\(a\)' >/dev/null 2>&1 && + test "X`expr 00001 : '.*\(...\)'`" = X001; then + as_expr=expr +else + as_expr=false +fi + +if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then + as_basename=basename +else + as_basename=false +fi + +if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then + as_dirname=dirname +else + as_dirname=false +fi + +as_me=`$as_basename -- "$0" || +$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)' \| . 2>/dev/null || +printf "%s\n" X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ + s//\1/ + q + } + /^X\/\(\/\/\)$/{ + s//\1/ + q + } + /^X\/\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + +# Avoid depending upon Character Ranges. +as_cr_letters='abcdefghijklmnopqrstuvwxyz' +as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' +as_cr_Letters=$as_cr_letters$as_cr_LETTERS +as_cr_digits='0123456789' +as_cr_alnum=$as_cr_Letters$as_cr_digits + + + as_lineno_1=$LINENO as_lineno_1a=$LINENO + as_lineno_2=$LINENO as_lineno_2a=$LINENO + eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && + test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { + # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) + sed -n ' + p + /[$]LINENO/= + ' <$as_myself | + sed ' + s/[$]LINENO.*/&-/ + t lineno + b + :lineno + N + :loop + s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ + t loop + s/-\n.*// + ' >$as_me.lineno && + chmod +x "$as_me.lineno" || + { printf "%s\n" "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } + + # If we had to re-execute with $CONFIG_SHELL, we're ensured to have + # already done that, so ensure we don't try to do so again and fall + # in an infinite loop. This has already happened in practice. + _as_can_reexec=no; export _as_can_reexec + # Don't try to exec as it changes $[0], causing all sort of problems + # (the dirname of $[0] is not the place where we might find the + # original and so on. Autoconf is especially sensitive to this). + . "./$as_me.lineno" + # Exit status is that of the last command. + exit +} + + +# Determine whether it's possible to make 'echo' print without a newline. +# These variables are no longer used directly by Autoconf, but are AC_SUBSTed +# for compatibility with existing Makefiles. +ECHO_C= ECHO_N= ECHO_T= +case `echo -n x` in #((((( +-n*) + case `echo 'xy\c'` in + *c*) ECHO_T=' ';; # ECHO_T is single tab character. + xy) ECHO_C='\c';; + *) echo `echo ksh88 bug on AIX 6.1` > /dev/null + ECHO_T=' ';; + esac;; +*) + ECHO_N='-n';; +esac + +# For backward compatibility with old third-party macros, we provide +# the shell variables $as_echo and $as_echo_n. New code should use +# AS_ECHO(["message"]) and AS_ECHO_N(["message"]), respectively. +as_echo='printf %s\n' +as_echo_n='printf %s' + + +rm -f conf$$ conf$$.exe conf$$.file +if test -d conf$$.dir; then + rm -f conf$$.dir/conf$$.file +else + rm -f conf$$.dir + mkdir conf$$.dir 2>/dev/null +fi +if (echo >conf$$.file) 2>/dev/null; then + if ln -s conf$$.file conf$$ 2>/dev/null; then + as_ln_s='ln -s' + # ... but there are two gotchas: + # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. + # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. + # In both cases, we have to default to `cp -pR'. + ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || + as_ln_s='cp -pR' + elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln + else + as_ln_s='cp -pR' + fi +else + as_ln_s='cp -pR' +fi +rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file +rmdir conf$$.dir 2>/dev/null + +if mkdir -p . 2>/dev/null; then + as_mkdir_p='mkdir -p "$as_dir"' +else + test -d ./-p && rmdir ./-p + as_mkdir_p=false +fi + +as_test_x='test -x' +as_executable_p=as_fn_executable_p + +# Sed expression to map a string onto a valid CPP name. +as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" + +# Sed expression to map a string onto a valid variable name. +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" + +SHELL=${CONFIG_SHELL-/bin/sh} + + +test -n "$DJDIR" || exec 7<&0 &1 + +# Name of the host. +# hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, +# so uname gets run too. +ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` + +# +# Initializations. +# +ac_default_prefix=/usr/local +ac_clean_files= +ac_config_libobj_dir=. +LIBOBJS= +cross_compiling=no +subdirs= +MFLAGS= +MAKEFLAGS= + +# Identity of this package. +PACKAGE_NAME='curl' +PACKAGE_TARNAME='curl' +PACKAGE_VERSION='-' +PACKAGE_STRING='curl -' +PACKAGE_BUGREPORT='a suitable curl mailing list: https://curl.se/mail/' +PACKAGE_URL='' + +ac_unique_file="lib/urldata.h" +# Factoring default headers for most tests. +ac_includes_default="\ +#include +#ifdef HAVE_STDIO_H +# include +#endif +#ifdef HAVE_STDLIB_H +# include +#endif +#ifdef HAVE_STRING_H +# include +#endif +#ifdef HAVE_INTTYPES_H +# include +#endif +#ifdef HAVE_STDINT_H +# include +#endif +#ifdef HAVE_STRINGS_H +# include +#endif +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifdef HAVE_SYS_STAT_H +# include +#endif +#ifdef HAVE_UNISTD_H +# include +#endif" + +ac_header_c_list= +ac_subst_vars='am__EXEEXT_FALSE +am__EXEEXT_TRUE +LTLIBOBJS +LIBOBJS +CURL_CPP +SSL_BACKENDS +SUPPORT_PROTOCOLS +SUPPORT_FEATURES +LIBCURL_PC_LIBS +LIBCURL_PC_REQUIRES +LIBCURL_PC_REQUIRES_PRIVATE +ENABLE_STATIC +ENABLE_SHARED +CROSSCOMPILING_FALSE +CROSSCOMPILING_TRUE +BLANK_AT_MAKETIME +CURL_NETWORK_AND_TIME_LIBS +LIBCURL_PC_LIBS_PRIVATE +LIBCURL_PC_LDFLAGS_PRIVATE +CFLAG_CURL_SYMBOL_HIDING +DOING_CURL_SYMBOL_HIDING_FALSE +DOING_CURL_SYMBOL_HIDING_TRUE +USE_MANUAL_FALSE +USE_MANUAL_TRUE +BUILD_DOCS_FALSE +BUILD_DOCS_TRUE +USE_FISH_COMPLETION_FALSE +USE_FISH_COMPLETION_TRUE +FISH_FUNCTIONS_DIR +USE_ZSH_COMPLETION_FALSE +USE_ZSH_COMPLETION_TRUE +ZSH_FUNCTIONS_DIR +USE_UNICODE_FALSE +USE_UNICODE_TRUE +CURL_LT_SHLIB_USE_VERSIONED_SYMBOLS_FALSE +CURL_LT_SHLIB_USE_VERSIONED_SYMBOLS_TRUE +CURL_LIBCURL_VERSIONED_SYMBOLS_SONAME +CURL_LIBCURL_VERSIONED_SYMBOLS_PREFIX +USE_GSASL_FALSE +USE_GSASL_TRUE +USE_LIBPSL_FALSE +USE_LIBPSL_TRUE +CURL_CA_EMBED_SET_FALSE +CURL_CA_EMBED_SET_TRUE +CURL_CA_EMBED +CURL_CA_BUNDLE +BUILD_STUB_GSS_FALSE +BUILD_STUB_GSS_TRUE +ZLIB_LIBS +HAVE_LIBZ_FALSE +HAVE_LIBZ_TRUE +HAVE_LIBZ +PKGCONFIG +USE_UNITY_FALSE +USE_UNITY_TRUE +HAVE_WINDRES_FALSE +HAVE_WINDRES_TRUE +CLANG_FALSE +CLANG_TRUE +BUILD_UNITTESTS_FALSE +BUILD_UNITTESTS_TRUE +CURL_WERROR_FALSE +CURL_WERROR_TRUE +CURL_CFLAG_EXTRAS +DOING_NATIVE_WINDOWS_FALSE +DOING_NATIVE_WINDOWS_TRUE +LCOV +GCOV +LIBCURL_PC_CFLAGS +LIBCURL_PC_CFLAGS_PRIVATE +USE_CPPFLAG_CURL_STATICLIB_FALSE +USE_CPPFLAG_CURL_STATICLIB_TRUE +CURL_LT_SHLIB_USE_MIMPURE_TEXT_FALSE +CURL_LT_SHLIB_USE_MIMPURE_TEXT_TRUE +CURL_LT_SHLIB_USE_NO_UNDEFINED_FALSE +CURL_LT_SHLIB_USE_NO_UNDEFINED_TRUE +CURL_LT_SHLIB_USE_VERSION_INFO_FALSE +CURL_LT_SHLIB_USE_VERSION_INFO_TRUE +NOT_CURL_CI_FALSE +NOT_CURL_CI_TRUE +RC +LT_SYS_LIBRARY_PATH +OTOOL64 +OTOOL +LIPO +NMEDIT +DSYMUTIL +MANIFEST_TOOL +RANLIB +ac_ct_AR +FILECMD +LN_S +NM +ac_ct_DUMPBIN +DUMPBIN +LD +FGREP +LIBTOOL +OBJDUMP +DLLTOOL +AS +AR_FLAGS +host_os +host_vendor +host_cpu +host +build_os +build_vendor +build_cpu +build +HTTPD_NGHTTPX +SFTPD +SSHD +DANTED +HTTPD +APXS +VSFTPD +H2O +CADDY +TEST_NGHTTPX +PERL_FALSE +PERL_TRUE +PERL +VERSIONNUM +CURLVERSION +CSCOPE +ETAGS +CTAGS +am__fastdepCC_FALSE +am__fastdepCC_TRUE +CCDEPMODE +am__nodep +AMDEPBACKSLASH +AMDEP_FALSE +AMDEP_TRUE +am__include +DEPDIR +am__untar +am__tar +AMTAR +am__leading_dot +SET_MAKE +AWK +mkdir_p +MKDIR_P +INSTALL_STRIP_PROGRAM +STRIP +install_sh +MAKEINFO +AUTOHEADER +AUTOMAKE +AUTOCONF +ACLOCAL +VERSION +PACKAGE +CYGPATH_W +am__isrc +CPP +OBJEXT +EXEEXT +ac_ct_CC +CPPFLAGS +LDFLAGS +CFLAGS +CC +INSTALL_DATA +INSTALL_SCRIPT +INSTALL_PROGRAM +CLANG_TIDY +libext +AR +EGREP +GREP +SED +CONFIGURE_OPTIONS +DEBUGBUILD_FALSE +DEBUGBUILD_TRUE +AM_BACKSLASH +AM_DEFAULT_VERBOSITY +AM_DEFAULT_V +AM_V +MAINT +MAINTAINER_MODE_FALSE +MAINTAINER_MODE_TRUE +target_alias +host_alias +build_alias +LIBS +ECHO_T +ECHO_N +ECHO_C +DEFS +mandir +localedir +libdir +psdir +pdfdir +dvidir +htmldir +infodir +docdir +oldincludedir +includedir +runstatedir +localstatedir +sharedstatedir +sysconfdir +datadir +datarootdir +libexecdir +sbindir +bindir +program_transform_name +prefix +exec_prefix +PACKAGE_URL +PACKAGE_BUGREPORT +PACKAGE_STRING +PACKAGE_VERSION +PACKAGE_TARNAME +PACKAGE_NAME +SHELL +PATH_SEPARATOR +am__quote' +ac_subst_files='' +ac_user_opts=' +enable_option_checking +enable_maintainer_mode +enable_silent_rules +enable_debug +enable_optimize +enable_warnings +enable_werror +enable_symbol_hiding +enable_ares +enable_rt +enable_httpsrr +enable_ech +enable_ssls_export +enable_proxy_http3 +enable_dependency_tracking +with_schannel +with_amissl +with_ssl +with_openssl +with_gnutls +with_mbedtls +with_wolfssl +with_rustls +with_apple_sectrust +with_test_nghttpx +with_test_caddy +with_test_h2o +with_test_vsftpd +with_test_httpd +with_test_danted +with_test_sshd +with_darwinssl +enable_largefile +enable_shared +enable_static +with_pic +enable_fast_install +with_aix_soname +with_gnu_ld +with_sysroot +enable_libtool_lock +enable_code_coverage +enable_unity +enable_http +enable_ftp +enable_file +enable_ipfs +enable_ldap +enable_ldaps +enable_rtsp +enable_proxy +enable_dict +enable_telnet +enable_tftp +enable_pop3 +enable_imap +enable_smb +enable_smtp +enable_gopher +enable_mqtt +enable_init_mem_debug +enable_manual +enable_docs +enable_libcurl_option +enable_libgcc +with_backtrace +with_zlib +with_brotli +with_zstd +enable_ipv6 +with_gssapi_includes +with_gssapi_libs +with_gssapi +with_default_ssl_backend +enable_openssl_auto_load_config +enable_ca_native +with_ca_bundle +with_ca_path +with_ca_fallback +with_ca_embed +enable_ca_search +enable_ca_search_safe +with_libpsl +with_libgsasl +with_libmetalink +with_libssh2 +with_libssh +with_ldap_lib +with_lber_lib +with_ldap +enable_versioned_symbols +enable_windows_unicode +with_winidn +with_apple_idn +with_libidn2 +with_nghttp2 +with_ngtcp2 +with_nghttp3 +with_quiche +with_libuv +with_zsh_functions_dir +with_fish_functions_dir +enable_threaded_resolver +enable_typecheck +enable_verbose +enable_sspi +enable_basic_auth +enable_bearer_auth +enable_digest_auth +enable_kerberos_auth +enable_negotiate_auth +enable_aws +enable_ntlm +enable_tls_srp +enable_unix_sockets +enable_cookies +enable_socketpair +enable_http_auth +enable_doh +enable_mime +enable_bindlocal +enable_form_api +enable_dateparse +enable_netrc +enable_progress_meter +enable_sha512_256 +enable_dnsshuffle +enable_get_easy_options +enable_alt_svc +enable_headers_api +enable_hsts +enable_websockets +' + ac_precious_vars='build_alias +host_alias +target_alias +CC +CFLAGS +LDFLAGS +LIBS +CPPFLAGS +CPP +LT_SYS_LIBRARY_PATH' + + +# Initialize some variables set by options. +ac_init_help= +ac_init_version=false +ac_unrecognized_opts= +ac_unrecognized_sep= +# The variables have the same names as the options, with +# dashes changed to underlines. +cache_file=/dev/null +exec_prefix=NONE +no_create= +no_recursion= +prefix=NONE +program_prefix=NONE +program_suffix=NONE +program_transform_name=s,x,x, +silent= +site= +srcdir= +verbose= +x_includes=NONE +x_libraries=NONE + +# Installation directory options. +# These are left unexpanded so users can "make install exec_prefix=/foo" +# and all the variables that are supposed to be based on exec_prefix +# by default will actually change. +# Use braces instead of parens because sh, perl, etc. also accept them. +# (The list follows the same order as the GNU Coding Standards.) +bindir='${exec_prefix}/bin' +sbindir='${exec_prefix}/sbin' +libexecdir='${exec_prefix}/libexec' +datarootdir='${prefix}/share' +datadir='${datarootdir}' +sysconfdir='${prefix}/etc' +sharedstatedir='${prefix}/com' +localstatedir='${prefix}/var' +runstatedir='${localstatedir}/run' +includedir='${prefix}/include' +oldincludedir='/usr/include' +docdir='${datarootdir}/doc/${PACKAGE_TARNAME}' +infodir='${datarootdir}/info' +htmldir='${docdir}' +dvidir='${docdir}' +pdfdir='${docdir}' +psdir='${docdir}' +libdir='${exec_prefix}/lib' +localedir='${datarootdir}/locale' +mandir='${datarootdir}/man' + +ac_prev= +ac_dashdash= +for ac_option +do + # If the previous option needs an argument, assign it. + if test -n "$ac_prev"; then + eval $ac_prev=\$ac_option + ac_prev= + continue + fi + + case $ac_option in + *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; + *=) ac_optarg= ;; + *) ac_optarg=yes ;; + esac + + case $ac_dashdash$ac_option in + --) + ac_dashdash=yes ;; + + -bindir | --bindir | --bindi | --bind | --bin | --bi) + ac_prev=bindir ;; + -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) + bindir=$ac_optarg ;; + + -build | --build | --buil | --bui | --bu) + ac_prev=build_alias ;; + -build=* | --build=* | --buil=* | --bui=* | --bu=*) + build_alias=$ac_optarg ;; + + -cache-file | --cache-file | --cache-fil | --cache-fi \ + | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) + ac_prev=cache_file ;; + -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ + | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) + cache_file=$ac_optarg ;; + + --config-cache | -C) + cache_file=config.cache ;; + + -datadir | --datadir | --datadi | --datad) + ac_prev=datadir ;; + -datadir=* | --datadir=* | --datadi=* | --datad=*) + datadir=$ac_optarg ;; + + -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ + | --dataroo | --dataro | --datar) + ac_prev=datarootdir ;; + -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ + | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) + datarootdir=$ac_optarg ;; + + -disable-* | --disable-*) + ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid feature name: \`$ac_useropt'" + ac_useropt_orig=$ac_useropt + ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"enable_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval enable_$ac_useropt=no ;; + + -docdir | --docdir | --docdi | --doc | --do) + ac_prev=docdir ;; + -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) + docdir=$ac_optarg ;; + + -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) + ac_prev=dvidir ;; + -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) + dvidir=$ac_optarg ;; + + -enable-* | --enable-*) + ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid feature name: \`$ac_useropt'" + ac_useropt_orig=$ac_useropt + ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"enable_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval enable_$ac_useropt=\$ac_optarg ;; + + -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ + | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ + | --exec | --exe | --ex) + ac_prev=exec_prefix ;; + -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ + | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ + | --exec=* | --exe=* | --ex=*) + exec_prefix=$ac_optarg ;; + + -gas | --gas | --ga | --g) + # Obsolete; use --with-gas. + with_gas=yes ;; + + -help | --help | --hel | --he | -h) + ac_init_help=long ;; + -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) + ac_init_help=recursive ;; + -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) + ac_init_help=short ;; + + -host | --host | --hos | --ho) + ac_prev=host_alias ;; + -host=* | --host=* | --hos=* | --ho=*) + host_alias=$ac_optarg ;; + + -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) + ac_prev=htmldir ;; + -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ + | --ht=*) + htmldir=$ac_optarg ;; + + -includedir | --includedir | --includedi | --included | --include \ + | --includ | --inclu | --incl | --inc) + ac_prev=includedir ;; + -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ + | --includ=* | --inclu=* | --incl=* | --inc=*) + includedir=$ac_optarg ;; + + -infodir | --infodir | --infodi | --infod | --info | --inf) + ac_prev=infodir ;; + -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) + infodir=$ac_optarg ;; + + -libdir | --libdir | --libdi | --libd) + ac_prev=libdir ;; + -libdir=* | --libdir=* | --libdi=* | --libd=*) + libdir=$ac_optarg ;; + + -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ + | --libexe | --libex | --libe) + ac_prev=libexecdir ;; + -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ + | --libexe=* | --libex=* | --libe=*) + libexecdir=$ac_optarg ;; + + -localedir | --localedir | --localedi | --localed | --locale) + ac_prev=localedir ;; + -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) + localedir=$ac_optarg ;; + + -localstatedir | --localstatedir | --localstatedi | --localstated \ + | --localstate | --localstat | --localsta | --localst | --locals) + ac_prev=localstatedir ;; + -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ + | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) + localstatedir=$ac_optarg ;; + + -mandir | --mandir | --mandi | --mand | --man | --ma | --m) + ac_prev=mandir ;; + -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) + mandir=$ac_optarg ;; + + -nfp | --nfp | --nf) + # Obsolete; use --without-fp. + with_fp=no ;; + + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c | -n) + no_create=yes ;; + + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) + no_recursion=yes ;; + + -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ + | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ + | --oldin | --oldi | --old | --ol | --o) + ac_prev=oldincludedir ;; + -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ + | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ + | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) + oldincludedir=$ac_optarg ;; + + -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) + ac_prev=prefix ;; + -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) + prefix=$ac_optarg ;; + + -program-prefix | --program-prefix | --program-prefi | --program-pref \ + | --program-pre | --program-pr | --program-p) + ac_prev=program_prefix ;; + -program-prefix=* | --program-prefix=* | --program-prefi=* \ + | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) + program_prefix=$ac_optarg ;; + + -program-suffix | --program-suffix | --program-suffi | --program-suff \ + | --program-suf | --program-su | --program-s) + ac_prev=program_suffix ;; + -program-suffix=* | --program-suffix=* | --program-suffi=* \ + | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) + program_suffix=$ac_optarg ;; + + -program-transform-name | --program-transform-name \ + | --program-transform-nam | --program-transform-na \ + | --program-transform-n | --program-transform- \ + | --program-transform | --program-transfor \ + | --program-transfo | --program-transf \ + | --program-trans | --program-tran \ + | --progr-tra | --program-tr | --program-t) + ac_prev=program_transform_name ;; + -program-transform-name=* | --program-transform-name=* \ + | --program-transform-nam=* | --program-transform-na=* \ + | --program-transform-n=* | --program-transform-=* \ + | --program-transform=* | --program-transfor=* \ + | --program-transfo=* | --program-transf=* \ + | --program-trans=* | --program-tran=* \ + | --progr-tra=* | --program-tr=* | --program-t=*) + program_transform_name=$ac_optarg ;; + + -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) + ac_prev=pdfdir ;; + -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) + pdfdir=$ac_optarg ;; + + -psdir | --psdir | --psdi | --psd | --ps) + ac_prev=psdir ;; + -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) + psdir=$ac_optarg ;; + + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + silent=yes ;; + + -runstatedir | --runstatedir | --runstatedi | --runstated \ + | --runstate | --runstat | --runsta | --runst | --runs \ + | --run | --ru | --r) + ac_prev=runstatedir ;; + -runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \ + | --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \ + | --run=* | --ru=* | --r=*) + runstatedir=$ac_optarg ;; + + -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) + ac_prev=sbindir ;; + -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ + | --sbi=* | --sb=*) + sbindir=$ac_optarg ;; + + -sharedstatedir | --sharedstatedir | --sharedstatedi \ + | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ + | --sharedst | --shareds | --shared | --share | --shar \ + | --sha | --sh) + ac_prev=sharedstatedir ;; + -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ + | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ + | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ + | --sha=* | --sh=*) + sharedstatedir=$ac_optarg ;; + + -site | --site | --sit) + ac_prev=site ;; + -site=* | --site=* | --sit=*) + site=$ac_optarg ;; + + -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) + ac_prev=srcdir ;; + -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) + srcdir=$ac_optarg ;; + + -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ + | --syscon | --sysco | --sysc | --sys | --sy) + ac_prev=sysconfdir ;; + -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ + | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) + sysconfdir=$ac_optarg ;; + + -target | --target | --targe | --targ | --tar | --ta | --t) + ac_prev=target_alias ;; + -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) + target_alias=$ac_optarg ;; + + -v | -verbose | --verbose | --verbos | --verbo | --verb) + verbose=yes ;; + + -version | --version | --versio | --versi | --vers | -V) + ac_init_version=: ;; + + -with-* | --with-*) + ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid package name: \`$ac_useropt'" + ac_useropt_orig=$ac_useropt + ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"with_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval with_$ac_useropt=\$ac_optarg ;; + + -without-* | --without-*) + ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid package name: \`$ac_useropt'" + ac_useropt_orig=$ac_useropt + ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"with_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval with_$ac_useropt=no ;; + + --x) + # Obsolete; use --with-x. + with_x=yes ;; + + -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ + | --x-incl | --x-inc | --x-in | --x-i) + ac_prev=x_includes ;; + -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ + | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) + x_includes=$ac_optarg ;; + + -x-libraries | --x-libraries | --x-librarie | --x-librari \ + | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) + ac_prev=x_libraries ;; + -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ + | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) + x_libraries=$ac_optarg ;; + + -*) as_fn_error $? "unrecognized option: \`$ac_option' +Try \`$0 --help' for more information" + ;; + + *=*) + ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` + # Reject names that are not valid shell variable names. + case $ac_envvar in #( + '' | [0-9]* | *[!_$as_cr_alnum]* ) + as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; + esac + eval $ac_envvar=\$ac_optarg + export $ac_envvar ;; + + *) + # FIXME: should be removed in autoconf 3.0. + printf "%s\n" "$as_me: WARNING: you should use --build, --host, --target" >&2 + expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && + printf "%s\n" "$as_me: WARNING: invalid host type: $ac_option" >&2 + : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" + ;; + + esac +done + +if test -n "$ac_prev"; then + ac_option=--`echo $ac_prev | sed 's/_/-/g'` + as_fn_error $? "missing argument to $ac_option" +fi + +if test -n "$ac_unrecognized_opts"; then + case $enable_option_checking in + no) ;; + fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; + *) printf "%s\n" "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; + esac +fi + +# Check all directory arguments for consistency. +for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ + datadir sysconfdir sharedstatedir localstatedir includedir \ + oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ + libdir localedir mandir runstatedir +do + eval ac_val=\$$ac_var + # Remove trailing slashes. + case $ac_val in + */ ) + ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` + eval $ac_var=\$ac_val;; + esac + # Be sure to have absolute directory names. + case $ac_val in + [\\/$]* | ?:[\\/]* ) continue;; + NONE | '' ) case $ac_var in *prefix ) continue;; esac;; + esac + as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" +done + +# There might be people who depend on the old broken behavior: `$host' +# used to hold the argument of --host etc. +# FIXME: To remove some day. +build=$build_alias +host=$host_alias +target=$target_alias + +# FIXME: To remove some day. +if test "x$host_alias" != x; then + if test "x$build_alias" = x; then + cross_compiling=maybe + elif test "x$build_alias" != "x$host_alias"; then + cross_compiling=yes + fi +fi + +ac_tool_prefix= +test -n "$host_alias" && ac_tool_prefix=$host_alias- + +test "$silent" = yes && exec 6>/dev/null + + +ac_pwd=`pwd` && test -n "$ac_pwd" && +ac_ls_di=`ls -di .` && +ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || + as_fn_error $? "working directory cannot be determined" +test "X$ac_ls_di" = "X$ac_pwd_ls_di" || + as_fn_error $? "pwd does not report name of working directory" + + +# Find the source files, if location was not specified. +if test -z "$srcdir"; then + ac_srcdir_defaulted=yes + # Try the directory containing this script, then the parent directory. + ac_confdir=`$as_dirname -- "$as_myself" || +$as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_myself" : 'X\(//\)[^/]' \| \ + X"$as_myself" : 'X\(//\)$' \| \ + X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || +printf "%s\n" X"$as_myself" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + srcdir=$ac_confdir + if test ! -r "$srcdir/$ac_unique_file"; then + srcdir=.. + fi +else + ac_srcdir_defaulted=no +fi +if test ! -r "$srcdir/$ac_unique_file"; then + test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." + as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" +fi +ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" +ac_abs_confdir=`( + cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" + pwd)` +# When building in place, set srcdir=. +if test "$ac_abs_confdir" = "$ac_pwd"; then + srcdir=. +fi +# Remove unnecessary trailing slashes from srcdir. +# Double slashes in file names in object file debugging info +# mess up M-x gdb in Emacs. +case $srcdir in +*/) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; +esac +for ac_var in $ac_precious_vars; do + eval ac_env_${ac_var}_set=\${${ac_var}+set} + eval ac_env_${ac_var}_value=\$${ac_var} + eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} + eval ac_cv_env_${ac_var}_value=\$${ac_var} +done + +# +# Report the --help message. +# +if test "$ac_init_help" = "long"; then + # Omit some internal or obsolete options to make the list less imposing. + # This message is too long to be a string in the A/UX 3.1 sh. + cat <<_ACEOF +\`configure' configures curl - to adapt to many kinds of systems. + +Usage: $0 [OPTION]... [VAR=VALUE]... + +To assign environment variables (e.g., CC, CFLAGS...), specify them as +VAR=VALUE. See below for descriptions of some of the useful variables. + +Defaults for the options are specified in brackets. + +Configuration: + -h, --help display this help and exit + --help=short display options specific to this package + --help=recursive display the short help of all the included packages + -V, --version display version information and exit + -q, --quiet, --silent do not print \`checking ...' messages + --cache-file=FILE cache test results in FILE [disabled] + -C, --config-cache alias for \`--cache-file=config.cache' + -n, --no-create do not create output files + --srcdir=DIR find the sources in DIR [configure dir or \`..'] + +Installation directories: + --prefix=PREFIX install architecture-independent files in PREFIX + [$ac_default_prefix] + --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX + [PREFIX] + +By default, \`make install' will install all the files in +\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify +an installation prefix other than \`$ac_default_prefix' using \`--prefix', +for instance \`--prefix=\$HOME'. + +For better control, use the options below. + +Fine tuning of the installation directories: + --bindir=DIR user executables [EPREFIX/bin] + --sbindir=DIR system admin executables [EPREFIX/sbin] + --libexecdir=DIR program executables [EPREFIX/libexec] + --sysconfdir=DIR read-only single-machine data [PREFIX/etc] + --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] + --localstatedir=DIR modifiable single-machine data [PREFIX/var] + --runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run] + --libdir=DIR object code libraries [EPREFIX/lib] + --includedir=DIR C header files [PREFIX/include] + --oldincludedir=DIR C header files for non-gcc [/usr/include] + --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] + --datadir=DIR read-only architecture-independent data [DATAROOTDIR] + --infodir=DIR info documentation [DATAROOTDIR/info] + --localedir=DIR locale-dependent data [DATAROOTDIR/locale] + --mandir=DIR man documentation [DATAROOTDIR/man] + --docdir=DIR documentation root [DATAROOTDIR/doc/curl] + --htmldir=DIR html documentation [DOCDIR] + --dvidir=DIR dvi documentation [DOCDIR] + --pdfdir=DIR pdf documentation [DOCDIR] + --psdir=DIR ps documentation [DOCDIR] +_ACEOF + + cat <<\_ACEOF + +Program names: + --program-prefix=PREFIX prepend PREFIX to installed program names + --program-suffix=SUFFIX append SUFFIX to installed program names + --program-transform-name=PROGRAM run sed PROGRAM on installed program names + +System types: + --build=BUILD configure for building on BUILD [guessed] + --host=HOST cross-compile to build programs to run on HOST [BUILD] +_ACEOF +fi + +if test -n "$ac_init_help"; then + case $ac_init_help in + short | recursive ) echo "Configuration of curl -:";; + esac + cat <<\_ACEOF + +Optional Features: + --disable-option-checking ignore unrecognized --enable/--with options + --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) + --enable-FEATURE[=ARG] include FEATURE [ARG=yes] + --enable-maintainer-mode + enable make rules and dependencies not useful (and + sometimes confusing) to the casual installer + --enable-silent-rules less verbose build output (undo: "make V=1") + --disable-silent-rules verbose build output (undo: "make V=0") + --enable-debug Enable debug build options + --disable-debug Disable debug build options + --enable-optimize Enable compiler optimizations + --disable-optimize Disable compiler optimizations + --enable-warnings Enable strict compiler warnings + --disable-warnings Disable strict compiler warnings + --enable-werror Enable compiler warnings as errors + --disable-werror Disable compiler warnings as errors + --enable-symbol-hiding Enable hiding of library internal symbols + --disable-symbol-hiding Disable hiding of library internal symbols + --enable-ares[=PATH] Enable c-ares for DNS lookups + --disable-ares Disable c-ares for DNS lookups + --disable-rt disable dependency on -lrt + --enable-httpsrr Enable HTTPSRR support (experimental) + --disable-httpsrr Disable HTTPSRR support (experimental) + --enable-ech Enable ECH support (experimental) + --disable-ech Disable ECH support (experimental) + --enable-ssls-export Enable SSL session export support (experimental) + --disable-ssls-export Disable SSL session export support (experimental) + --enable-proxy-http3 Enable HTTP/3 proxy support (experimental) + --disable-proxy-http3 Disable HTTP/3 proxy support (experimental) + --enable-dependency-tracking + do not reject slow dependency extractors + --disable-dependency-tracking + speeds up one-time build + --disable-largefile omit support for large files + --enable-shared[=PKGS] build shared libraries [default=yes] + --enable-static[=PKGS] build static libraries [default=yes] + --enable-fast-install[=PKGS] + optimize for fast installation [default=yes] + --disable-libtool-lock avoid locking (might break parallel builds) + --enable-code-coverage Provide code coverage + --enable-unity Enable unity mode + --disable-unity Disable unity (default) + --enable-http Enable HTTP support + --disable-http Disable HTTP support + --enable-ftp Enable FTP support + --disable-ftp Disable FTP support + --enable-file Enable FILE support + --disable-file Disable FILE support + --enable-ipfs Enable IPFS support + --disable-ipfs Disable IPFS support + --enable-ldap Enable LDAP support + --disable-ldap Disable LDAP support + --enable-ldaps Enable LDAPS support + --disable-ldaps Disable LDAPS support + --enable-rtsp Enable RTSP support + --disable-rtsp Disable RTSP support + --enable-proxy Enable proxy support + --disable-proxy Disable proxy support + --enable-dict Enable DICT support + --disable-dict Disable DICT support + --enable-telnet Enable TELNET support + --disable-telnet Disable TELNET support + --enable-tftp Enable TFTP support + --disable-tftp Disable TFTP support + --enable-pop3 Enable POP3 support + --disable-pop3 Disable POP3 support + --enable-imap Enable IMAP support + --disable-imap Disable IMAP support + --enable-smb Enable SMB support + --disable-smb Disable SMB support + --enable-smtp Enable SMTP support + --disable-smtp Disable SMTP support + --enable-gopher Enable Gopher support + --disable-gopher Disable Gopher support + --enable-mqtt Enable MQTT support + --disable-mqtt Disable MQTT support + --enable-init-mem-debug curl_global_init_mem debug + --disable-init-mem-debug + + --enable-manual Enable built-in manual + --disable-manual Disable built-in manual + --enable-docs Enable documentation + --disable-docs Disable documentation + --enable-libcurl-option Enable --libcurl C code generation support + --disable-libcurl-option + Disable --libcurl C code generation support + --enable-libgcc use libgcc when linking + --enable-ipv6 Enable IPv6 (with IPv4) support + --disable-ipv6 Disable IPv6 support + --enable-openssl-auto-load-config + Enable automatic loading of OpenSSL configuration + --disable-openssl-auto-load-config + Disable automatic loading of OpenSSL configuration + --enable-ca-native Enable native CA store + --disable-ca-native Disable native CA store (default) + --enable-ca-search Enable unsafe CA bundle search in PATH on Windows + --disable-ca-search Disable unsafe CA bundle search in PATH on Windows + --enable-ca-search-safe Enable safe CA bundle search + --disable-ca-search-safe + Disable safe CA bundle search (default) + --enable-versioned-symbols + Enable versioned symbols in shared library + --disable-versioned-symbols + Disable versioned symbols in shared library + --enable-windows-unicode + Enable Windows Unicode + --disable-windows-unicode + Disable Windows Unicode (default) + --enable-threaded-resolver + Enable threaded resolver + --disable-threaded-resolver + Disable threaded resolver + --enable-typecheck Enable type checking (default) + --disable-typecheck Disable type checking + --enable-verbose Enable verbose strings + --disable-verbose Disable verbose strings + --enable-sspi Enable SSPI + --disable-sspi Disable SSPI + --enable-basic-auth Enable basic authentication (default) + --disable-basic-auth Disable basic authentication + --enable-bearer-auth Enable bearer authentication (default) + --disable-bearer-auth Disable bearer authentication + --enable-digest-auth Enable digest authentication (default) + --disable-digest-auth Disable digest authentication + --enable-kerberos-auth Enable kerberos authentication (default) + --disable-kerberos-auth Disable kerberos authentication + --enable-negotiate-auth Enable negotiate authentication (default) + --disable-negotiate-auth + Disable negotiate authentication + --enable-aws Enable AWS sig support (default) + --disable-aws Disable AWS sig support + --enable-ntlm Enable NTLM support + --disable-ntlm Disable NTLM support + --enable-tls-srp Enable TLS-SRP authentication + --disable-tls-srp Disable TLS-SRP authentication + --enable-unix-sockets Enable Unix domain sockets + --disable-unix-sockets Disable Unix domain sockets + --enable-cookies Enable cookies support + --disable-cookies Disable cookies support + --enable-socketpair Enable socketpair support + --disable-socketpair Disable socketpair support + --enable-http-auth Enable HTTP authentication support + --disable-http-auth Disable HTTP authentication support + --enable-doh Enable DoH support + --disable-doh Disable DoH support + --enable-mime Enable mime API support + --disable-mime Disable mime API support + --enable-bindlocal Enable local binding support + --disable-bindlocal Disable local binding support + --enable-form-api Enable form API support + --disable-form-api Disable form API support + --enable-dateparse Enable date parsing + --disable-dateparse Disable date parsing + --enable-netrc Enable netrc parsing + --disable-netrc Disable netrc parsing + --enable-progress-meter Enable progress-meter + --disable-progress-meter + Disable progress-meter + --enable-sha512-256 Enable SHA-512/256 hash algorithm (default) + --disable-sha512-256 Disable SHA-512/256 hash algorithm + --enable-dnsshuffle Enable DNS shuffling + --disable-dnsshuffle Disable DNS shuffling + --enable-get-easy-options + Enable curl_easy_options + --disable-get-easy-options + Disable curl_easy_options + --enable-alt-svc Enable alt-svc support + --disable-alt-svc Disable alt-svc support + --enable-headers-api Enable headers-api support + --disable-headers-api Disable headers-api support + --enable-hsts Enable HSTS support + --disable-hsts Disable HSTS support + --enable-websockets Enable WebSockets support + --disable-websockets Disable WebSockets support + +Optional Packages: + --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] + --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) + --with-schannel enable Windows native SSL/TLS + --with-amissl enable Amiga native SSL/TLS (AmiSSL) + --with-ssl=PATH old version of --with-openssl + --without-ssl build without any TLS library + --with-openssl=PATH Where to look for OpenSSL, PATH points to the SSL + installation (default: /usr/local/ssl); when + possible, set the PKG_CONFIG_PATH environment + variable instead of using this option + --with-gnutls=PATH where to look for GnuTLS, PATH points to the + installation root + --with-mbedtls=PATH where to look for mbedTLS, PATH points to the + installation root + --with-wolfssl=PATH where to look for wolfSSL, PATH points to the + installation root (default: system lib default) + --with-rustls=PATH where to look for Rustls, PATH points to the + installation root + --with-apple-sectrust enable Apple OS native certificate verification + --with-test-nghttpx=PATH + where to find nghttpx for testing + --with-test-caddy=PATH where to find caddy for testing + --with-test-h2o=PATH where to find h2o for testing + --with-test-vsftpd=PATH where to find vsftpd for testing + --with-test-httpd=PATH where to find httpd/apache2 for testing + --with-test-danted=PATH where to find danted socks daemon for testing + --with-test-sshd=PATH where to find sshd for testing + + --with-pic[=PKGS] try to use only PIC/non-PIC objects [default=use + both] + --with-aix-soname=aix|svr4|both + shared library versioning (aka "SONAME") variant to + provide on AIX, [default=aix]. + --with-gnu-ld assume the C compiler uses GNU ld [default=no] + --with-sysroot[=DIR] Search for dependent libraries within DIR (or the + compiler's sysroot if not specified). + --enable-backtrace use libbacktrace when linking + --with-zlib=PATH search for zlib in PATH + --without-zlib disable use of zlib + --with-brotli=PATH Where to look for brotli, PATH points to the BROTLI + installation; when possible, set the PKG_CONFIG_PATH + environment variable instead of using this option + --without-brotli disable BROTLI + --with-zstd=PATH Where to look for libzstd, PATH points to the + libzstd installation; when possible, set the + PKG_CONFIG_PATH environment variable instead of + using this option + --without-zstd disable libzstd + --with-gssapi-includes=DIR + Specify location of GSS-API headers + --with-gssapi-libs=DIR Specify location of GSS-API libs + --with-gssapi=DIR Where to look for GSS-API + --with-default-ssl-backend=NAME + Use NAME as default SSL backend + --without-default-ssl-backend + Use implicit default SSL backend + --with-ca-bundle=FILE Absolute path to a file containing CA certificates + (example: /etc/ca-bundle.crt) + --without-ca-bundle Do not use a default CA bundle + --with-ca-path=DIRECTORY + Absolute path to a directory containing CA + certificates stored individually, with their + filenames in a hash format. This option can be used + with the OpenSSL, GnuTLS, mbedTLS and wolfSSL + backends. Refer to OpenSSL c_rehash for details. + (example: /etc/certificates) + --without-ca-path Do not use a default CA path + --with-ca-fallback Use OpenSSL's built-in CA store + --without-ca-fallback Do not use OpenSSL's built-in CA store + --with-ca-embed=FILE Absolute path to a file containing CA certificates + to embed in the curl tool (example: + /etc/ca-bundle.crt) + --without-ca-embed Do not embed a default CA bundle in the curl tool + --with-libpsl=PATH Where to look for libpsl, PATH points to the LIBPSL + installation; when possible, set the PKG_CONFIG_PATH + environment variable instead of using this option + --without-libpsl disable LIBPSL + --with-libgsasl=PATH Where to look for libgsasl, PATH points to the + libgsasl installation; when possible, set the + PKG_CONFIG_PATH environment variable instead of + using this option + --without-libgsasl disable libgsasl support for SCRAM + --with-libssh2=PATH Where to look for libssh2, PATH points to the + libssh2 installation; when possible, set the + PKG_CONFIG_PATH environment variable instead of + using this option + --with-libssh2 enable libssh2 + --with-libssh=PATH Where to look for libssh, PATH points to the libssh + installation; when possible, set the PKG_CONFIG_PATH + environment variable instead of using this option + --with-libssh enable libssh + --with-ldap-lib=libname Specify name of ldap lib file + --with-lber-lib=libname Specify name of lber lib file + --with-ldap=PATH Where to look for LDAP, PATH points to the LDAP + installation; when possible, set the PKG_CONFIG_PATH + environment variable instead of using this option + --without-ldap disable LDAP + --with-winidn enable Windows native IDN + --without-winidn disable Windows native IDN + --with-apple-idn Enable AppleIDN + --without-apple-idn Disable AppleIDN + --with-libidn2=PATH Enable libidn2 usage + --without-libidn2 Disable libidn2 usage + --with-nghttp2=PATH Enable nghttp2 usage + --without-nghttp2 Disable nghttp2 usage + --with-ngtcp2=PATH Enable ngtcp2 usage + --without-ngtcp2 Disable ngtcp2 usage + --with-nghttp3=PATH Enable nghttp3 usage + --without-nghttp3 Disable nghttp3 usage + --with-quiche=PATH Enable quiche usage (experimental) + --without-quiche Disable quiche usage (experimental) + --with-libuv=PATH Enable libuv + --without-libuv Disable libuv + --with-zsh-functions-dir=PATH + Install zsh completions to PATH + --without-zsh-functions-dir + Do not install zsh completions + --with-fish-functions-dir=PATH + Install fish completions to PATH + --without-fish-functions-dir + Do not install fish completions + +Some influential environment variables: + CC C compiler command + CFLAGS C compiler flags + LDFLAGS linker flags, e.g. -L if you have libraries in a + nonstandard directory + LIBS libraries to pass to the linker, e.g. -l + CPPFLAGS (Objective) C/C++ preprocessor flags, e.g. -I if + you have headers in a nonstandard directory + CPP C preprocessor + LT_SYS_LIBRARY_PATH + User-defined run-time library search path. + +Use these variables to override the choices made by `configure' or to help +it to find libraries and programs with nonstandard names/locations. + +Report bugs to . +_ACEOF +ac_status=$? +fi + +if test "$ac_init_help" = "recursive"; then + # If there are subdirs, report their specific --help. + for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue + test -d "$ac_dir" || + { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || + continue + ac_builddir=. + +case "$ac_dir" in +.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; +*) + ac_dir_suffix=/`printf "%s\n" "$ac_dir" | sed 's|^\.[\\/]||'` + # A ".." for each directory in $ac_dir_suffix. + ac_top_builddir_sub=`printf "%s\n" "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` + case $ac_top_builddir_sub in + "") ac_top_builddir_sub=. ac_top_build_prefix= ;; + *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; + esac ;; +esac +ac_abs_top_builddir=$ac_pwd +ac_abs_builddir=$ac_pwd$ac_dir_suffix +# for backward compatibility: +ac_top_builddir=$ac_top_build_prefix + +case $srcdir in + .) # We are building in place. + ac_srcdir=. + ac_top_srcdir=$ac_top_builddir_sub + ac_abs_top_srcdir=$ac_pwd ;; + [\\/]* | ?:[\\/]* ) # Absolute name. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir + ac_abs_top_srcdir=$srcdir ;; + *) # Relative name. + ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_build_prefix$srcdir + ac_abs_top_srcdir=$ac_pwd/$srcdir ;; +esac +ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix + + cd "$ac_dir" || { ac_status=$?; continue; } + # Check for configure.gnu first; this name is used for a wrapper for + # Metaconfig's "Configure" on case-insensitive file systems. + if test -f "$ac_srcdir/configure.gnu"; then + echo && + $SHELL "$ac_srcdir/configure.gnu" --help=recursive + elif test -f "$ac_srcdir/configure"; then + echo && + $SHELL "$ac_srcdir/configure" --help=recursive + else + printf "%s\n" "$as_me: WARNING: no configuration information is in $ac_dir" >&2 + fi || ac_status=$? + cd "$ac_pwd" || { ac_status=$?; break; } + done +fi + +test -n "$ac_init_help" && exit $ac_status +if $ac_init_version; then + cat <<\_ACEOF +curl configure - +generated by GNU Autoconf 2.71 + +Copyright (C) 2021 Free Software Foundation, Inc. +This configure script is free software; the Free Software Foundation +gives unlimited permission to copy, distribute and modify it. + +Copyright (C) Daniel Stenberg, +This configure script may be copied, distributed and modified under the +terms of the curl license; see COPYING for more details +_ACEOF + exit +fi + +## ------------------------ ## +## Autoconf initialization. ## +## ------------------------ ## + +# ac_fn_c_try_compile LINENO +# -------------------------- +# Try to compile conftest.$ac_ext, and return whether this succeeded. +ac_fn_c_try_compile () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + rm -f conftest.$ac_objext conftest.beam + if { { ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +printf "%s\n" "$ac_try_echo"; } >&5 + (eval "$ac_compile") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + grep -v '^ *+' conftest.err >conftest.er1 + cat conftest.er1 >&5 + mv -f conftest.er1 conftest.err + fi + printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext +then : + ac_retval=0 +else $as_nop + printf "%s\n" "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=1 +fi + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_c_try_compile + +# ac_fn_c_try_cpp LINENO +# ---------------------- +# Try to preprocess conftest.$ac_ext, and return whether this succeeded. +ac_fn_c_try_cpp () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + if { { ac_try="$ac_cpp conftest.$ac_ext" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +printf "%s\n" "$ac_try_echo"; } >&5 + (eval "$ac_cpp conftest.$ac_ext") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + grep -v '^ *+' conftest.err >conftest.er1 + cat conftest.er1 >&5 + mv -f conftest.er1 conftest.err + fi + printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } > conftest.i && { + test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || + test ! -s conftest.err + } +then : + ac_retval=0 +else $as_nop + printf "%s\n" "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=1 +fi + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_c_try_cpp + +# ac_fn_c_check_header_compile LINENO HEADER VAR INCLUDES +# ------------------------------------------------------- +# Tests whether HEADER exists and can be compiled using the include files in +# INCLUDES, setting the cache variable VAR accordingly. +ac_fn_c_check_header_compile () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +printf %s "checking for $2... " >&6; } +if eval test \${$3+y} +then : + printf %s "(cached) " >&6 +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +#include <$2> +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + eval "$3=yes" +else $as_nop + eval "$3=no" +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext +fi +eval ac_res=\$$3 + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +printf "%s\n" "$ac_res" >&6; } + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_c_check_header_compile + +# ac_fn_c_try_link LINENO +# ----------------------- +# Try to link conftest.$ac_ext, and return whether this succeeded. +ac_fn_c_try_link () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + rm -f conftest.$ac_objext conftest.beam conftest$ac_exeext + if { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +printf "%s\n" "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + grep -v '^ *+' conftest.err >conftest.er1 + cat conftest.er1 >&5 + mv -f conftest.er1 conftest.err + fi + printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest$ac_exeext && { + test "$cross_compiling" = yes || + test -x conftest$ac_exeext + } +then : + ac_retval=0 +else $as_nop + printf "%s\n" "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=1 +fi + # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information + # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would + # interfere with the next link command; also delete a directory that is + # left behind by Apple's compiler. We do this before executing the actions. + rm -rf conftest.dSYM conftest_ipa8_conftest.oo + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_c_try_link + +# ac_fn_c_check_func LINENO FUNC VAR +# ---------------------------------- +# Tests whether FUNC exists, setting the cache variable VAR accordingly +ac_fn_c_check_func () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +printf %s "checking for $2... " >&6; } +if eval test \${$3+y} +then : + printf %s "(cached) " >&6 +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +#define $2 innocuous_$2 +#ifdef __STDC__ +# include +#else +# include +#endif +#undef $2 +#ifdef __cplusplus +extern "C" +#endif +char $2 (); +#if defined __stub_$2 || defined __stub___$2 +#error force compilation error +#endif + +int main(void) +{ +return $2 (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + eval "$3=yes" +else $as_nop + eval "$3=no" +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +fi +eval ac_res=\$$3 + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +printf "%s\n" "$ac_res" >&6; } + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_c_check_func + +# ac_fn_c_try_run LINENO +# ---------------------- +# Try to run conftest.$ac_ext, and return whether this succeeded. Assumes that +# executables *can* be run. +ac_fn_c_try_run () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + if { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +printf "%s\n" "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>&5 + ac_status=$? + printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && { ac_try='./conftest$ac_exeext' + { { case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +printf "%s\n" "$ac_try_echo"; } >&5 + (eval "$ac_try") 2>&5 + ac_status=$? + printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; } +then : + ac_retval=0 +else $as_nop + printf "%s\n" "$as_me: program exited with status $ac_status" >&5 + printf "%s\n" "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=$ac_status +fi + rm -rf conftest.dSYM conftest_ipa8_conftest.oo + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_c_try_run + +# ac_fn_c_check_type LINENO TYPE VAR INCLUDES +# ------------------------------------------- +# Tests whether TYPE exists after having included INCLUDES, setting cache +# variable VAR accordingly. +ac_fn_c_check_type () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +printf %s "checking for $2... " >&6; } +if eval test \${$3+y} +then : + printf %s "(cached) " >&6 +else $as_nop + eval "$3=no" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +int main(void) +{ +if (sizeof ($2)) + return 0; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +int main(void) +{ +if (sizeof (($2))) + return 0; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + +else $as_nop + eval "$3=yes" +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext +fi +eval ac_res=\$$3 + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +printf "%s\n" "$ac_res" >&6; } + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_c_check_type + +# ac_fn_check_decl LINENO SYMBOL VAR INCLUDES EXTRA-OPTIONS FLAG-VAR +# ------------------------------------------------------------------ +# Tests whether SYMBOL is declared in INCLUDES, setting cache variable VAR +# accordingly. Pass EXTRA-OPTIONS to the compiler, using FLAG-VAR. +ac_fn_check_decl () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + as_decl_name=`echo $2|sed 's/ *(.*//'` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether $as_decl_name is declared" >&5 +printf %s "checking whether $as_decl_name is declared... " >&6; } +if eval test \${$3+y} +then : + printf %s "(cached) " >&6 +else $as_nop + as_decl_use=`echo $2|sed -e 's/(/((/' -e 's/)/) 0&/' -e 's/,/) 0& (/g'` + eval ac_save_FLAGS=\$$6 + as_fn_append $6 " $5" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +int main(void) +{ +#ifndef $as_decl_name +#ifdef __cplusplus + (void) $as_decl_use; +#else + (void) $as_decl_name; +#endif +#endif + + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + eval "$3=yes" +else $as_nop + eval "$3=no" +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + eval $6=\$ac_save_FLAGS + +fi +eval ac_res=\$$3 + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +printf "%s\n" "$ac_res" >&6; } + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_check_decl + +# ac_fn_c_check_member LINENO AGGR MEMBER VAR INCLUDES +# ---------------------------------------------------- +# Tries to find if the field MEMBER exists in type AGGR, after including +# INCLUDES, setting cache variable VAR accordingly. +ac_fn_c_check_member () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2.$3" >&5 +printf %s "checking for $2.$3... " >&6; } +if eval test \${$4+y} +then : + printf %s "(cached) " >&6 +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$5 +int main(void) +{ +static $2 ac_aggr; +if (ac_aggr.$3) +return 0; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + eval "$4=yes" +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$5 +int main(void) +{ +static $2 ac_aggr; +if (sizeof ac_aggr.$3) +return 0; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + eval "$4=yes" +else $as_nop + eval "$4=no" +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext +fi +eval ac_res=\$$4 + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +printf "%s\n" "$ac_res" >&6; } + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_c_check_member +ac_configure_args_raw= +for ac_arg +do + case $ac_arg in + *\'*) + ac_arg=`printf "%s\n" "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; + esac + as_fn_append ac_configure_args_raw " '$ac_arg'" +done + +case $ac_configure_args_raw in + *$as_nl*) + ac_safe_unquote= ;; + *) + ac_unsafe_z='|&;<>()$`\\"*?[ '' ' # This string ends in space, tab. + ac_unsafe_a="$ac_unsafe_z#~" + ac_safe_unquote="s/ '\\([^$ac_unsafe_a][^$ac_unsafe_z]*\\)'/ \\1/g" + ac_configure_args_raw=` printf "%s\n" "$ac_configure_args_raw" | sed "$ac_safe_unquote"`;; +esac + +cat >config.log <<_ACEOF +This file contains any messages produced by compilers while +running configure, to aid debugging if configure makes a mistake. + +It was created by curl $as_me -, which was +generated by GNU Autoconf 2.71. Invocation command line was + + $ $0$ac_configure_args_raw + +_ACEOF +exec 5>>config.log +{ +cat <<_ASUNAME +## --------- ## +## Platform. ## +## --------- ## + +hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` +uname -m = `(uname -m) 2>/dev/null || echo unknown` +uname -r = `(uname -r) 2>/dev/null || echo unknown` +uname -s = `(uname -s) 2>/dev/null || echo unknown` +uname -v = `(uname -v) 2>/dev/null || echo unknown` + +/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` +/bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` + +/bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` +/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` +/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` +/usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` +/bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` +/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` +/bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` + +_ASUNAME + +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + printf "%s\n" "PATH: $as_dir" + done +IFS=$as_save_IFS + +} >&5 + +cat >&5 <<_ACEOF + + +## ----------- ## +## Core tests. ## +## ----------- ## + +_ACEOF + + +# Keep a trace of the command line. +# Strip out --no-create and --no-recursion so they do not pile up. +# Strip out --silent because we don't want to record it for future runs. +# Also quote any args containing shell meta-characters. +# Make two passes to allow for proper duplicate-argument suppression. +ac_configure_args= +ac_configure_args0= +ac_configure_args1= +ac_must_keep_next=false +for ac_pass in 1 2 +do + for ac_arg + do + case $ac_arg in + -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + continue ;; + *\'*) + ac_arg=`printf "%s\n" "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; + esac + case $ac_pass in + 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; + 2) + as_fn_append ac_configure_args1 " '$ac_arg'" + if test $ac_must_keep_next = true; then + ac_must_keep_next=false # Got value, back to normal. + else + case $ac_arg in + *=* | --config-cache | -C | -disable-* | --disable-* \ + | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ + | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ + | -with-* | --with-* | -without-* | --without-* | --x) + case "$ac_configure_args0 " in + "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; + esac + ;; + -* ) ac_must_keep_next=true ;; + esac + fi + as_fn_append ac_configure_args " '$ac_arg'" + ;; + esac + done +done +{ ac_configure_args0=; unset ac_configure_args0;} +{ ac_configure_args1=; unset ac_configure_args1;} + +# When interrupted or exit'd, cleanup temporary files, and complete +# config.log. We remove comments because anyway the quotes in there +# would cause problems or look ugly. +# WARNING: Use '\'' to represent an apostrophe within the trap. +# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. +trap 'exit_status=$? + # Sanitize IFS. + IFS=" "" $as_nl" + # Save into config.log some information that might help in debugging. + { + echo + + printf "%s\n" "## ---------------- ## +## Cache variables. ## +## ---------------- ##" + echo + # The following way of writing the cache mishandles newlines in values, +( + for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do + eval ac_val=\$$ac_var + case $ac_val in #( + *${as_nl}*) + case $ac_var in #( + *_cv_*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 +printf "%s\n" "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; + esac + case $ac_var in #( + _ | IFS | as_nl) ;; #( + BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( + *) { eval $ac_var=; unset $ac_var;} ;; + esac ;; + esac + done + (set) 2>&1 | + case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( + *${as_nl}ac_space=\ *) + sed -n \ + "s/'\''/'\''\\\\'\'''\''/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" + ;; #( + *) + sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" + ;; + esac | + sort +) + echo + + printf "%s\n" "## ----------------- ## +## Output variables. ## +## ----------------- ##" + echo + for ac_var in $ac_subst_vars + do + eval ac_val=\$$ac_var + case $ac_val in + *\'\''*) ac_val=`printf "%s\n" "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; + esac + printf "%s\n" "$ac_var='\''$ac_val'\''" + done | sort + echo + + if test -n "$ac_subst_files"; then + printf "%s\n" "## ------------------- ## +## File substitutions. ## +## ------------------- ##" + echo + for ac_var in $ac_subst_files + do + eval ac_val=\$$ac_var + case $ac_val in + *\'\''*) ac_val=`printf "%s\n" "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; + esac + printf "%s\n" "$ac_var='\''$ac_val'\''" + done | sort + echo + fi + + if test -s confdefs.h; then + printf "%s\n" "## ----------- ## +## confdefs.h. ## +## ----------- ##" + echo + cat confdefs.h + echo + fi + test "$ac_signal" != 0 && + printf "%s\n" "$as_me: caught signal $ac_signal" + printf "%s\n" "$as_me: exit $exit_status" + } >&5 + rm -f core *.core core.conftest.* && + rm -f -r conftest* confdefs* conf$$* $ac_clean_files && + exit $exit_status +' 0 +for ac_signal in 1 2 13 15; do + trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal +done +ac_signal=0 + +# confdefs.h avoids OS command line length limits that DEFS can exceed. +rm -f -r conftest* confdefs.h + +printf "%s\n" "/* confdefs.h */" > confdefs.h + +# Predefined preprocessor variables. + +printf "%s\n" "#define PACKAGE_NAME \"$PACKAGE_NAME\"" >>confdefs.h + +printf "%s\n" "#define PACKAGE_TARNAME \"$PACKAGE_TARNAME\"" >>confdefs.h + +printf "%s\n" "#define PACKAGE_VERSION \"$PACKAGE_VERSION\"" >>confdefs.h + +printf "%s\n" "#define PACKAGE_STRING \"$PACKAGE_STRING\"" >>confdefs.h + +printf "%s\n" "#define PACKAGE_BUGREPORT \"$PACKAGE_BUGREPORT\"" >>confdefs.h + +printf "%s\n" "#define PACKAGE_URL \"$PACKAGE_URL\"" >>confdefs.h + + +# Let the site file select an alternate cache file if it wants to. +# Prefer an explicitly selected file to automatically selected ones. +if test -n "$CONFIG_SITE"; then + ac_site_files="$CONFIG_SITE" +elif test "x$prefix" != xNONE; then + ac_site_files="$prefix/share/config.site $prefix/etc/config.site" +else + ac_site_files="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" +fi + +for ac_site_file in $ac_site_files +do + case $ac_site_file in #( + */*) : + ;; #( + *) : + ac_site_file=./$ac_site_file ;; +esac + if test -f "$ac_site_file" && test -r "$ac_site_file"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 +printf "%s\n" "$as_me: loading site script $ac_site_file" >&6;} + sed 's/^/| /' "$ac_site_file" >&5 + . "$ac_site_file" \ + || { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "failed to load site script $ac_site_file +See \`config.log' for more details" "$LINENO" 5; } + fi +done + +if test -r "$cache_file"; then + # Some versions of bash will fail to source /dev/null (special files + # actually), so we avoid doing that. DJGPP emulates it as a regular file. + if test /dev/null != "$cache_file" && test -f "$cache_file"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 +printf "%s\n" "$as_me: loading cache $cache_file" >&6;} + case $cache_file in + [\\/]* | ?:[\\/]* ) . "$cache_file";; + *) . "./$cache_file";; + esac + fi +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 +printf "%s\n" "$as_me: creating cache $cache_file" >&6;} + >$cache_file +fi + +# Test code for whether the C compiler supports C89 (global declarations) +ac_c_conftest_c89_globals=' +/* Does the compiler advertise C89 conformance? + Do not test the value of __STDC__, because some compilers set it to 0 + while being otherwise adequately conformant. */ +#if !defined __STDC__ +# error "Compiler does not advertise C89 conformance" +#endif + +#include +#include +struct stat; +/* Most of the following tests are stolen from RCS 5.7 src/conf.sh. */ +struct buf { int x; }; +struct buf * (*rcsopen) (struct buf *, struct stat *, int); +static char *e (p, i) + char **p; + int i; +{ + return p[i]; +} +static char *f (char * (*g) (char **, int), char **p, ...) +{ + char *s; + va_list v; + va_start (v,p); + s = g (p, va_arg (v,int)); + va_end (v); + return s; +} + +/* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has + function prototypes and stuff, but not \xHH hex character constants. + These do not provoke an error unfortunately, instead are silently treated + as an "x". The following induces an error, until -std is added to get + proper ANSI mode. Curiously \x00 != x always comes out true, for an + array size at least. It is necessary to write \x00 == 0 to get something + that is true only with -std. */ +int osf4_cc_array ['\''\x00'\'' == 0 ? 1 : -1]; + +/* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters + inside strings and character constants. */ +#define FOO(x) '\''x'\'' +int xlc6_cc_array[FOO(a) == '\''x'\'' ? 1 : -1]; + +int test (int i, double x); +struct s1 {int (*f) (int a);}; +struct s2 {int (*f) (double a);}; +int pairnames (int, char **, int *(*)(struct buf *, struct stat *, int), + int, int);' + +# Test code for whether the C compiler supports C89 (body of main). +ac_c_conftest_c89_main=' +ok |= (argc == 0 || f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]); +' + +# Test code for whether the C compiler supports C99 (global declarations) +ac_c_conftest_c99_globals=' +// Does the compiler advertise C99 conformance? +#if !defined __STDC_VERSION__ || __STDC_VERSION__ < 199901L +# error "Compiler does not advertise C99 conformance" +#endif + +#include +extern int puts (const char *); +extern int printf (const char *, ...); +extern int dprintf (int, const char *, ...); +extern void *malloc (size_t); + +// Check varargs macros. These examples are taken from C99 6.10.3.5. +// dprintf is used instead of fprintf to avoid needing to declare +// FILE and stderr. +#define debug(...) dprintf (2, __VA_ARGS__) +#define showlist(...) puts (#__VA_ARGS__) +#define report(test,...) ((test) ? puts (#test) : printf (__VA_ARGS__)) +static void +test_varargs_macros (void) +{ + int x = 1234; + int y = 5678; + debug ("Flag"); + debug ("X = %d\n", x); + showlist (The first, second, and third items.); + report (x>y, "x is %d but y is %d", x, y); +} + +// Check long long types. +#define BIG64 18446744073709551615ull +#define BIG32 4294967295ul +#define BIG_OK (BIG64 / BIG32 == 4294967297ull && BIG64 % BIG32 == 0) +#if !BIG_OK + #error "your preprocessor is broken" +#endif +#if BIG_OK +#else + #error "your preprocessor is broken" +#endif +static long long int bignum = -9223372036854775807LL; +static unsigned long long int ubignum = BIG64; + +struct incomplete_array +{ + int datasize; + double data[]; +}; + +struct named_init { + int number; + const wchar_t *name; + double average; +}; + +typedef const char *ccp; + +static inline int +test_restrict (ccp restrict text) +{ + // See if C++-style comments work. + // Iterate through items via the restricted pointer. + // Also check for declarations in for loops. + for (unsigned int i = 0; *(text+i) != '\''\0'\''; ++i) + continue; + return 0; +} + +// Check varargs and va_copy. +static bool +test_varargs (const char *format, ...) +{ + va_list args; + va_start (args, format); + va_list args_copy; + va_copy (args_copy, args); + + const char *str = ""; + int number = 0; + float fnumber = 0; + + while (*format) + { + switch (*format++) + { + case '\''s'\'': // string + str = va_arg (args_copy, const char *); + break; + case '\''d'\'': // int + number = va_arg (args_copy, int); + break; + case '\''f'\'': // float + fnumber = va_arg (args_copy, double); + break; + default: + break; + } + } + va_end (args_copy); + va_end (args); + + return *str && number && fnumber; +} +' + +# Test code for whether the C compiler supports C99 (body of main). +ac_c_conftest_c99_main=' + // Check bool. + _Bool success = false; + success |= (argc != 0); + + // Check restrict. + if (test_restrict ("String literal") == 0) + success = true; + char *restrict newvar = "Another string"; + + // Check varargs. + success &= test_varargs ("s, d'\'' f .", "string", 65, 34.234); + test_varargs_macros (); + + // Check flexible array members. + struct incomplete_array *ia = + malloc (sizeof (struct incomplete_array) + (sizeof (double) * 10)); + ia->datasize = 10; + for (int i = 0; i < ia->datasize; ++i) + ia->data[i] = i * 1.234; + + // Check named initializers. + struct named_init ni = { + .number = 34, + .name = L"Test wide string", + .average = 543.34343, + }; + + ni.number = 58; + + int dynamic_array[ni.number]; + dynamic_array[0] = argv[0][0]; + dynamic_array[ni.number - 1] = 543; + + // work around unused variable warnings + ok |= (!success || bignum == 0LL || ubignum == 0uLL || newvar[0] == '\''x'\'' + || dynamic_array[ni.number - 1] != 543); +' + +# Test code for whether the C compiler supports C11 (global declarations) +ac_c_conftest_c11_globals=' +// Does the compiler advertise C11 conformance? +#if !defined __STDC_VERSION__ || __STDC_VERSION__ < 201112L +# error "Compiler does not advertise C11 conformance" +#endif + +// Check _Alignas. +char _Alignas (double) aligned_as_double; +char _Alignas (0) no_special_alignment; +extern char aligned_as_int; +char _Alignas (0) _Alignas (int) aligned_as_int; + +// Check _Alignof. +enum +{ + int_alignment = _Alignof (int), + int_array_alignment = _Alignof (int[100]), + char_alignment = _Alignof (char) +}; +_Static_assert (0 < -_Alignof (int), "_Alignof is signed"); + +// Check _Noreturn. +int _Noreturn does_not_return (void) { for (;;) continue; } + +// Check _Static_assert. +struct test_static_assert +{ + int x; + _Static_assert (sizeof (int) <= sizeof (long int), + "_Static_assert does not work in struct"); + long int y; +}; + +// Check UTF-8 literals. +#define u8 syntax error! +char const utf8_literal[] = u8"happens to be ASCII" "another string"; + +// Check duplicate typedefs. +typedef long *long_ptr; +typedef long int *long_ptr; +typedef long_ptr long_ptr; + +// Anonymous structures and unions -- taken from C11 6.7.2.1 Example 1. +struct anonymous +{ + union { + struct { int i; int j; }; + struct { int k; long int l; } w; + }; + int m; +} v1; +' + +# Test code for whether the C compiler supports C11 (body of main). +ac_c_conftest_c11_main=' + _Static_assert ((offsetof (struct anonymous, i) + == offsetof (struct anonymous, w.k)), + "Anonymous union alignment botch"); + v1.i = 2; + v1.w.k = 5; + ok |= v1.i != 5; +' + +# Test code for whether the C compiler supports C11 (complete). +ac_c_conftest_c11_program="${ac_c_conftest_c89_globals} +${ac_c_conftest_c99_globals} +${ac_c_conftest_c11_globals} + +int +main (int argc, char **argv) +{ + int ok = 0; + ${ac_c_conftest_c89_main} + ${ac_c_conftest_c99_main} + ${ac_c_conftest_c11_main} + return ok; +} +" + +# Test code for whether the C compiler supports C99 (complete). +ac_c_conftest_c99_program="${ac_c_conftest_c89_globals} +${ac_c_conftest_c99_globals} + +int +main (int argc, char **argv) +{ + int ok = 0; + ${ac_c_conftest_c89_main} + ${ac_c_conftest_c99_main} + return ok; +} +" + +# Test code for whether the C compiler supports C89 (complete). +ac_c_conftest_c89_program="${ac_c_conftest_c89_globals} + +int +main (int argc, char **argv) +{ + int ok = 0; + ${ac_c_conftest_c89_main} + return ok; +} +" + +as_fn_append ac_header_c_list " stdio.h stdio_h HAVE_STDIO_H" +as_fn_append ac_header_c_list " stdlib.h stdlib_h HAVE_STDLIB_H" +as_fn_append ac_header_c_list " string.h string_h HAVE_STRING_H" +as_fn_append ac_header_c_list " inttypes.h inttypes_h HAVE_INTTYPES_H" +as_fn_append ac_header_c_list " stdint.h stdint_h HAVE_STDINT_H" +as_fn_append ac_header_c_list " strings.h strings_h HAVE_STRINGS_H" +as_fn_append ac_header_c_list " sys/stat.h sys_stat_h HAVE_SYS_STAT_H" +as_fn_append ac_header_c_list " sys/types.h sys_types_h HAVE_SYS_TYPES_H" +as_fn_append ac_header_c_list " unistd.h unistd_h HAVE_UNISTD_H" + +# Auxiliary files required by this configure script. +ac_aux_files="ltmain.sh config.guess config.sub missing compile install-sh" + +# Locations in which to look for auxiliary files. +ac_aux_dir_candidates="${srcdir}${PATH_SEPARATOR}${srcdir}/..${PATH_SEPARATOR}${srcdir}/../.." + +# Search for a directory containing all of the required auxiliary files, +# $ac_aux_files, from the $PATH-style list $ac_aux_dir_candidates. +# If we don't find one directory that contains all the files we need, +# we report the set of missing files from the *first* directory in +# $ac_aux_dir_candidates and give up. +ac_missing_aux_files="" +ac_first_candidate=: +printf "%s\n" "$as_me:${as_lineno-$LINENO}: looking for aux files: $ac_aux_files" >&5 +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_found=false +for as_dir in $ac_aux_dir_candidates +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + as_found=: + + printf "%s\n" "$as_me:${as_lineno-$LINENO}: trying $as_dir" >&5 + ac_aux_dir_found=yes + ac_install_sh= + for ac_aux in $ac_aux_files + do + # As a special case, if "install-sh" is required, that requirement + # can be satisfied by any of "install-sh", "install.sh", or "shtool", + # and $ac_install_sh is set appropriately for whichever one is found. + if test x"$ac_aux" = x"install-sh" + then + if test -f "${as_dir}install-sh"; then + printf "%s\n" "$as_me:${as_lineno-$LINENO}: ${as_dir}install-sh found" >&5 + ac_install_sh="${as_dir}install-sh -c" + elif test -f "${as_dir}install.sh"; then + printf "%s\n" "$as_me:${as_lineno-$LINENO}: ${as_dir}install.sh found" >&5 + ac_install_sh="${as_dir}install.sh -c" + elif test -f "${as_dir}shtool"; then + printf "%s\n" "$as_me:${as_lineno-$LINENO}: ${as_dir}shtool found" >&5 + ac_install_sh="${as_dir}shtool install -c" + else + ac_aux_dir_found=no + if $ac_first_candidate; then + ac_missing_aux_files="${ac_missing_aux_files} install-sh" + else + break + fi + fi + else + if test -f "${as_dir}${ac_aux}"; then + printf "%s\n" "$as_me:${as_lineno-$LINENO}: ${as_dir}${ac_aux} found" >&5 + else + ac_aux_dir_found=no + if $ac_first_candidate; then + ac_missing_aux_files="${ac_missing_aux_files} ${ac_aux}" + else + break + fi + fi + fi + done + if test "$ac_aux_dir_found" = yes; then + ac_aux_dir="$as_dir" + break + fi + ac_first_candidate=false + + as_found=false +done +IFS=$as_save_IFS +if $as_found +then : + +else $as_nop + as_fn_error $? "cannot find required auxiliary files:$ac_missing_aux_files" "$LINENO" 5 +fi + + +# These three variables are undocumented and unsupported, +# and are intended to be withdrawn in a future Autoconf release. +# They can cause serious problems if a builder's source tree is in a directory +# whose full name contains unusual characters. +if test -f "${ac_aux_dir}config.guess"; then + ac_config_guess="$SHELL ${ac_aux_dir}config.guess" +fi +if test -f "${ac_aux_dir}config.sub"; then + ac_config_sub="$SHELL ${ac_aux_dir}config.sub" +fi +if test -f "$ac_aux_dir/configure"; then + ac_configure="$SHELL ${ac_aux_dir}configure" +fi + +# Check that the precious variables saved in the cache have kept the same +# value. +ac_cache_corrupted=false +for ac_var in $ac_precious_vars; do + eval ac_old_set=\$ac_cv_env_${ac_var}_set + eval ac_new_set=\$ac_env_${ac_var}_set + eval ac_old_val=\$ac_cv_env_${ac_var}_value + eval ac_new_val=\$ac_env_${ac_var}_value + case $ac_old_set,$ac_new_set in + set,) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 +printf "%s\n" "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} + ac_cache_corrupted=: ;; + ,set) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 +printf "%s\n" "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} + ac_cache_corrupted=: ;; + ,);; + *) + if test "x$ac_old_val" != "x$ac_new_val"; then + # differences in whitespace do not lead to failure. + ac_old_val_w=`echo x $ac_old_val` + ac_new_val_w=`echo x $ac_new_val` + if test "$ac_old_val_w" != "$ac_new_val_w"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 +printf "%s\n" "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} + ac_cache_corrupted=: + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 +printf "%s\n" "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} + eval $ac_var=\$ac_old_val + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 +printf "%s\n" "$as_me: former value: \`$ac_old_val'" >&2;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 +printf "%s\n" "$as_me: current value: \`$ac_new_val'" >&2;} + fi;; + esac + # Pass precious variables to config.status. + if test "$ac_new_set" = set; then + case $ac_new_val in + *\'*) ac_arg=$ac_var=`printf "%s\n" "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; + *) ac_arg=$ac_var=$ac_new_val ;; + esac + case " $ac_configure_args " in + *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. + *) as_fn_append ac_configure_args " '$ac_arg'" ;; + esac + fi +done +if $ac_cache_corrupted; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 +printf "%s\n" "$as_me: error: changes in the environment can compromise the build" >&2;} + as_fn_error $? "run \`${MAKE-make} distclean' and/or \`rm $cache_file' + and start over" "$LINENO" 5 +fi +## -------------------- ## +## Main body of script. ## +## -------------------- ## + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + + + + + +# using curl-override.m4 + + + + + +ac_config_headers="$ac_config_headers lib/curl_config.h" + + + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable maintainer-specific portions of Makefiles" >&5 +printf %s "checking whether to enable maintainer-specific portions of Makefiles... " >&6; } + # Check whether --enable-maintainer-mode was given. +if test ${enable_maintainer_mode+y} +then : + enableval=$enable_maintainer_mode; USE_MAINTAINER_MODE=$enableval +else $as_nop + USE_MAINTAINER_MODE=no +fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $USE_MAINTAINER_MODE" >&5 +printf "%s\n" "$USE_MAINTAINER_MODE" >&6; } + if test $USE_MAINTAINER_MODE = yes; then + MAINTAINER_MODE_TRUE= + MAINTAINER_MODE_FALSE='#' +else + MAINTAINER_MODE_TRUE='#' + MAINTAINER_MODE_FALSE= +fi + + MAINT=$MAINTAINER_MODE_TRUE + + +# Check whether --enable-silent-rules was given. +if test ${enable_silent_rules+y} +then : + enableval=$enable_silent_rules; +fi + +case $enable_silent_rules in # ((( + yes) AM_DEFAULT_VERBOSITY=0;; + no) AM_DEFAULT_VERBOSITY=1;; + *) AM_DEFAULT_VERBOSITY=0;; +esac +am_make=${MAKE-make} +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether $am_make supports nested variables" >&5 +printf %s "checking whether $am_make supports nested variables... " >&6; } +if test ${am_cv_make_support_nested_variables+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if printf "%s\n" 'TRUE=$(BAR$(V)) +BAR0=false +BAR1=true +V=1 +am__doit: + @$(TRUE) +.PHONY: am__doit' | $am_make -f - >/dev/null 2>&1; then + am_cv_make_support_nested_variables=yes +else + am_cv_make_support_nested_variables=no +fi +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $am_cv_make_support_nested_variables" >&5 +printf "%s\n" "$am_cv_make_support_nested_variables" >&6; } +if test $am_cv_make_support_nested_variables = yes; then + AM_V='$(V)' + AM_DEFAULT_V='$(AM_DEFAULT_VERBOSITY)' +else + AM_V=$AM_DEFAULT_VERBOSITY + AM_DEFAULT_V=$AM_DEFAULT_VERBOSITY +fi +AM_BACKSLASH='\' + + + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable debug build options" >&5 +printf %s "checking whether to enable debug build options... " >&6; } + OPT_DEBUG_BUILD="default" + # Check whether --enable-debug was given. +if test ${enable_debug+y} +then : + enableval=$enable_debug; OPT_DEBUG_BUILD=$enableval +fi + + case "$OPT_DEBUG_BUILD" in + no) + want_debug="no" + ;; + default) + want_debug="no" + ;; + *) + want_debug="yes" + ;; + esac + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $want_debug" >&5 +printf "%s\n" "$want_debug" >&6; } + + if test "$want_debug" = "yes"; then + DEBUGBUILD_TRUE= + DEBUGBUILD_FALSE='#' +else + DEBUGBUILD_TRUE='#' + DEBUGBUILD_FALSE= +fi + + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable compiler optimizer" >&5 +printf %s "checking whether to enable compiler optimizer... " >&6; } + OPT_COMPILER_OPTIMIZE="default" + # Check whether --enable-optimize was given. +if test ${enable_optimize+y} +then : + enableval=$enable_optimize; OPT_COMPILER_OPTIMIZE=$enableval +fi + + case "$OPT_COMPILER_OPTIMIZE" in + no) + want_optimize="no" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + ;; + default) + if test "$want_debug" = "yes"; then + want_optimize="assume_no" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: (assumed) no" >&5 +printf "%s\n" "(assumed) no" >&6; } + else + want_optimize="assume_yes" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: (assumed) yes" >&5 +printf "%s\n" "(assumed) yes" >&6; } + fi + ;; + *) + want_optimize="yes" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac + + + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable strict compiler warnings" >&5 +printf %s "checking whether to enable strict compiler warnings... " >&6; } + OPT_COMPILER_WARNINGS="default" + # Check whether --enable-warnings was given. +if test ${enable_warnings+y} +then : + enableval=$enable_warnings; OPT_COMPILER_WARNINGS=$enableval +fi + + case "$OPT_COMPILER_WARNINGS" in + no) + want_warnings="no" + ;; + default) + want_warnings="$want_debug" + ;; + *) + want_warnings="yes" + ;; + esac + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $want_warnings" >&5 +printf "%s\n" "$want_warnings" >&6; } + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable compiler warnings as errors" >&5 +printf %s "checking whether to enable compiler warnings as errors... " >&6; } + OPT_COMPILER_WERROR="default" + # Check whether --enable-werror was given. +if test ${enable_werror+y} +then : + enableval=$enable_werror; OPT_COMPILER_WERROR=$enableval +fi + + case "$OPT_COMPILER_WERROR" in + no) + want_werror="no" + ;; + default) + want_werror="no" + ;; + *) + want_werror="yes" + ;; + esac + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $want_werror" >&5 +printf "%s\n" "$want_werror" >&6; } + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable hiding of library internal symbols" >&5 +printf %s "checking whether to enable hiding of library internal symbols... " >&6; } + OPT_SYMBOL_HIDING="default" + # Check whether --enable-symbol-hiding was given. +if test ${enable_symbol_hiding+y} +then : + enableval=$enable_symbol_hiding; OPT_SYMBOL_HIDING=$enableval +fi + + case "$OPT_SYMBOL_HIDING" in + no) + want_symbol_hiding="no" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + ;; + default) + want_symbol_hiding="yes" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + *) + want_symbol_hiding="yes" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable c-ares for DNS lookups" >&5 +printf %s "checking whether to enable c-ares for DNS lookups... " >&6; } + OPT_ARES="default" + # Check whether --enable-ares was given. +if test ${enable_ares+y} +then : + enableval=$enable_ares; OPT_ARES=$enableval +fi + + case "$OPT_ARES" in + no) + want_ares="no" + ;; + default) + want_ares="no" + ;; + *) + want_ares="yes" + if test -n "$enableval" && test "x$enableval" != "xyes"; then + want_ares_path="$enableval" + fi + ;; + esac + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $want_ares" >&5 +printf "%s\n" "$want_ares" >&6; } + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to disable dependency on -lrt" >&5 +printf %s "checking whether to disable dependency on -lrt... " >&6; } + OPT_RT="default" + # Check whether --enable-rt was given. +if test ${enable_rt+y} +then : + enableval=$enable_rt; OPT_RT=$enableval +fi + + case "$OPT_RT" in + no) + dontwant_rt="yes" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + default) + dontwant_rt="no" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: (assumed no)" >&5 +printf "%s\n" "(assumed no)" >&6; } + ;; + *) + dontwant_rt="no" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + ;; + esac + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable HTTPSRR support" >&5 +printf %s "checking whether to enable HTTPSRR support... " >&6; } + OPT_HTTPSRR="default" + # Check whether --enable-httpsrr was given. +if test ${enable_httpsrr+y} +then : + enableval=$enable_httpsrr; OPT_HTTPSRR=$enableval +fi + + case "$OPT_HTTPSRR" in + no) + want_httpsrr="no" + curl_httpsrr_msg="no (--enable-httpsrr)" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + ;; + default) + want_httpsrr="no" + curl_httpsrr_msg="no (--enable-httpsrr)" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + ;; + *) + want_httpsrr="yes" + curl_httpsrr_msg="enabled" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable ECH support" >&5 +printf %s "checking whether to enable ECH support... " >&6; } + OPT_ECH="default" + # Check whether --enable-ech was given. +if test ${enable_ech+y} +then : + enableval=$enable_ech; OPT_ECH=$enableval +fi + + case "$OPT_ECH" in + no) + want_ech="no" + curl_ech_msg="no (--enable-ech)" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + ;; + default) + want_ech="no" + curl_ech_msg="no (--enable-ech)" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + ;; + *) + want_ech="yes" + curl_ech_msg="enabled (--disable-ech)" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable SSL session export support" >&5 +printf %s "checking whether to enable SSL session export support... " >&6; } + OPT_SSLS_EXPORT="default" + # Check whether --enable-ssls-export was given. +if test ${enable_ssls_export+y} +then : + enableval=$enable_ssls_export; OPT_SSLS_EXPORT=$enableval +fi + + case "$OPT_SSLS_EXPORT" in + no) + want_ssls_export="no" + curl_ssls_export_msg="no (--enable-ssls-export)" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + ;; + default) + want_ssls_export="no" + curl_ssls_export_msg="no (--enable-ssls-export)" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + ;; + *) + want_ssls_export="yes" + curl_ssls_export_msg="enabled (--disable-ssls-export)" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable HTTP/3 proxy support" >&5 +printf %s "checking whether to enable HTTP/3 proxy support... " >&6; } +OPT_PROXY_HTTP3="default" +# Check whether --enable-proxy-http3 was given. +if test ${enable_proxy_http3+y} +then : + enableval=$enable_proxy_http3; OPT_PROXY_HTTP3=$enableval +fi + +case "$OPT_PROXY_HTTP3" in + no) + want_proxy_http3="no" + curl_proxy_http3_msg="no (--enable-proxy-http3)" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + ;; + default) + want_proxy_http3="no" + curl_proxy_http3_msg="no (--enable-proxy-http3)" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + ;; + *) + want_proxy_http3="yes" + curl_proxy_http3_msg="enabled (--disable-proxy-http3)" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; +esac +USE_PROXY_HTTP3=0 + + + + + + + + + + + + + + + + + + + + + + + + + + + + +if test -z "$xc_configure_preamble_result"; then + as_fn_error $? "xc_configure_preamble_result not set (internal problem)" "$LINENO" 5 +fi + + +if test -z "$xc_PATH_SEPARATOR"; then + as_fn_error $? "xc_PATH_SEPARATOR not set (internal problem)" "$LINENO" 5 +fi +if test -z "$PATH_SEPARATOR"; then + as_fn_error $? "PATH_SEPARATOR not set (internal or config.site problem)" "$LINENO" 5 +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for path separator" >&5 +printf %s "checking for path separator... " >&6; } +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PATH_SEPARATOR" >&5 +printf "%s\n" "$PATH_SEPARATOR" >&6; } +if test "x$PATH_SEPARATOR" != "x$xc_PATH_SEPARATOR"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for initial path separator" >&5 +printf %s "checking for initial path separator... " >&6; } + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $xc_PATH_SEPARATOR" >&5 +printf "%s\n" "$xc_PATH_SEPARATOR" >&6; } + as_fn_error $? "path separator mismatch (internal or config.site problem)" "$LINENO" 5 +fi + + + + + +CONFIGURE_OPTIONS="\"$ac_configure_args\"" + + +if test -z "$SED"; then + # Extract the first word of "sed", so it can be a program name with args. +set dummy sed; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_SED+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $SED in + [\\/]* | ?:[\\/]*) + ac_cv_path_SED="$SED" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_SED="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + test -z "$ac_cv_path_SED" && ac_cv_path_SED="not_found" + ;; +esac +fi +SED=$ac_cv_path_SED +if test -n "$SED"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $SED" >&5 +printf "%s\n" "$SED" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + + if test -z "$SED" || test "$SED" = "not_found"; then + as_fn_error $? "sed not found in PATH. Cannot continue without sed." "$LINENO" 5 + fi +fi + + +if test -z "$GREP"; then + # Extract the first word of "grep", so it can be a program name with args. +set dummy grep; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_GREP+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $GREP in + [\\/]* | ?:[\\/]*) + ac_cv_path_GREP="$GREP" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_GREP="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + test -z "$ac_cv_path_GREP" && ac_cv_path_GREP="not_found" + ;; +esac +fi +GREP=$ac_cv_path_GREP +if test -n "$GREP"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $GREP" >&5 +printf "%s\n" "$GREP" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + + if test -z "$GREP" || test "$GREP" = "not_found"; then + as_fn_error $? "grep not found in PATH. Cannot continue without grep." "$LINENO" 5 + fi +fi + + +if test -z "$EGREP"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking that grep -E works" >&5 +printf %s "checking that grep -E works... " >&6; } + if echo a | ($GREP -E '(a|b)') >/dev/null 2>&1; then + EGREP="$GREP -E" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + # Extract the first word of "egrep", so it can be a program name with args. +set dummy egrep; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_EGREP+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $EGREP in + [\\/]* | ?:[\\/]*) + ac_cv_path_EGREP="$EGREP" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_EGREP="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + test -z "$ac_cv_path_EGREP" && ac_cv_path_EGREP="not_found" + ;; +esac +fi +EGREP=$ac_cv_path_EGREP +if test -n "$EGREP"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $EGREP" >&5 +printf "%s\n" "$EGREP" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + + fi +fi +if test -z "$EGREP" || test "$EGREP" = "not_found"; then + as_fn_error $? "grep -E is not working and egrep is not found in PATH. Cannot continue." "$LINENO" 5 +fi + + +if test -z "$AR"; then + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}ar", so it can be a program name with args. +set dummy ${ac_tool_prefix}ar; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_AR+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $AR in + [\\/]* | ?:[\\/]*) + ac_cv_path_AR="$AR" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_AR="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +AR=$ac_cv_path_AR +if test -n "$AR"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $AR" >&5 +printf "%s\n" "$AR" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_AR"; then + ac_pt_AR=$AR + # Extract the first word of "ar", so it can be a program name with args. +set dummy ar; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_AR+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_AR in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_AR="$ac_pt_AR" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_AR="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_AR=$ac_cv_path_ac_pt_AR +if test -n "$ac_pt_AR"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_AR" >&5 +printf "%s\n" "$ac_pt_AR" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_AR" = x; then + AR="not_found" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + AR=$ac_pt_AR + fi +else + AR="$ac_cv_path_AR" +fi + + if test -z "$AR" || test "$AR" = "not_found"; then + as_fn_error $? "ar not found in PATH. Cannot continue without ar." "$LINENO" 5 + fi +fi + + + + +if test -z "$CLANG_TIDY"; then + CLANG_TIDY=clang-tidy +fi + + +CURLVERSION=`$SED -ne 's/^#define LIBCURL_VERSION "\(.*\)".*/\1/p' ${srcdir}/include/curl/curlver.h` + + xc_prog_cc_prev_IFS=$IFS + xc_prog_cc_prev_LIBS=$LIBS + xc_prog_cc_prev_CFLAGS=$CFLAGS + xc_prog_cc_prev_LDFLAGS=$LDFLAGS + xc_prog_cc_prev_CPPFLAGS=$CPPFLAGS + + + + + xc_bad_var_libs=no + for xc_word in $LIBS; do + case "$xc_word" in + -l* | --library=*) + : + ;; + *) + xc_bad_var_libs=yes + ;; + esac + done + if test "$xc_bad_var_libs" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: using LIBS: $LIBS" >&5 +printf "%s\n" "$as_me: using LIBS: $LIBS" >&6;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: LIBS note: LIBS should only be used to specify libraries (-lname)." >&5 +printf "%s\n" "$as_me: LIBS note: LIBS should only be used to specify libraries (-lname)." >&6;} + fi + + + xc_bad_var_ldflags=no + for xc_word in $LDFLAGS; do + case "$xc_word" in + -D*) + xc_bad_var_ldflags=yes + ;; + -U*) + xc_bad_var_ldflags=yes + ;; + -I*) + xc_bad_var_ldflags=yes + ;; + -l* | --library=*) + xc_bad_var_ldflags=yes + ;; + esac + done + if test "$xc_bad_var_ldflags" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: using LDFLAGS: $LDFLAGS" >&5 +printf "%s\n" "$as_me: using LDFLAGS: $LDFLAGS" >&6;} + xc_bad_var_msg="LDFLAGS note: LDFLAGS should only be used to specify linker flags, not" + for xc_word in $LDFLAGS; do + case "$xc_word" in + -D*) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $xc_bad_var_msg macro definitions. Use CPPFLAGS for: $xc_word" >&5 +printf "%s\n" "$as_me: $xc_bad_var_msg macro definitions. Use CPPFLAGS for: $xc_word" >&6;} + ;; + -U*) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $xc_bad_var_msg macro suppressions. Use CPPFLAGS for: $xc_word" >&5 +printf "%s\n" "$as_me: $xc_bad_var_msg macro suppressions. Use CPPFLAGS for: $xc_word" >&6;} + ;; + -I*) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $xc_bad_var_msg include directories. Use CPPFLAGS for: $xc_word" >&5 +printf "%s\n" "$as_me: $xc_bad_var_msg include directories. Use CPPFLAGS for: $xc_word" >&6;} + ;; + -l* | --library=*) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $xc_bad_var_msg libraries. Use LIBS for: $xc_word" >&5 +printf "%s\n" "$as_me: $xc_bad_var_msg libraries. Use LIBS for: $xc_word" >&6;} + ;; + esac + done + fi + + + xc_bad_var_cppflags=no + for xc_word in $CPPFLAGS; do + case "$xc_word" in + -rpath*) + xc_bad_var_cppflags=yes + ;; + -L* | --library-path=*) + xc_bad_var_cppflags=yes + ;; + -l* | --library=*) + xc_bad_var_cppflags=yes + ;; + esac + done + if test "$xc_bad_var_cppflags" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: using CPPFLAGS: $CPPFLAGS" >&5 +printf "%s\n" "$as_me: using CPPFLAGS: $CPPFLAGS" >&6;} + xc_bad_var_msg="CPPFLAGS note: CPPFLAGS should only be used to specify C preprocessor flags, not" + for xc_word in $CPPFLAGS; do + case "$xc_word" in + -rpath*) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $xc_bad_var_msg library runtime directories. Use LDFLAGS for: $xc_word" >&5 +printf "%s\n" "$as_me: $xc_bad_var_msg library runtime directories. Use LDFLAGS for: $xc_word" >&6;} + ;; + -L* | --library-path=*) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $xc_bad_var_msg library directories. Use LDFLAGS for: $xc_word" >&5 +printf "%s\n" "$as_me: $xc_bad_var_msg library directories. Use LDFLAGS for: $xc_word" >&6;} + ;; + -l* | --library=*) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $xc_bad_var_msg libraries. Use LIBS for: $xc_word" >&5 +printf "%s\n" "$as_me: $xc_bad_var_msg libraries. Use LIBS for: $xc_word" >&6;} + ;; + esac + done + fi + + + xc_bad_var_cflags=no + for xc_word in $CFLAGS; do + case "$xc_word" in + -D*) + xc_bad_var_cflags=yes + ;; + -U*) + xc_bad_var_cflags=yes + ;; + -I*) + xc_bad_var_cflags=yes + ;; + -rpath*) + xc_bad_var_cflags=yes + ;; + -L* | --library-path=*) + xc_bad_var_cflags=yes + ;; + -l* | --library=*) + xc_bad_var_cflags=yes + ;; + esac + done + if test "$xc_bad_var_cflags" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: using CFLAGS: $CFLAGS" >&5 +printf "%s\n" "$as_me: using CFLAGS: $CFLAGS" >&6;} + xc_bad_var_msg="CFLAGS note: CFLAGS should only be used to specify C compiler flags, not" + for xc_word in $CFLAGS; do + case "$xc_word" in + -D*) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $xc_bad_var_msg macro definitions. Use CPPFLAGS for: $xc_word" >&5 +printf "%s\n" "$as_me: $xc_bad_var_msg macro definitions. Use CPPFLAGS for: $xc_word" >&6;} + ;; + -U*) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $xc_bad_var_msg macro suppressions. Use CPPFLAGS for: $xc_word" >&5 +printf "%s\n" "$as_me: $xc_bad_var_msg macro suppressions. Use CPPFLAGS for: $xc_word" >&6;} + ;; + -I*) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $xc_bad_var_msg include directories. Use CPPFLAGS for: $xc_word" >&5 +printf "%s\n" "$as_me: $xc_bad_var_msg include directories. Use CPPFLAGS for: $xc_word" >&6;} + ;; + -rpath*) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $xc_bad_var_msg library runtime directories. Use LDFLAGS for: $xc_word" >&5 +printf "%s\n" "$as_me: $xc_bad_var_msg library runtime directories. Use LDFLAGS for: $xc_word" >&6;} + ;; + -L* | --library-path=*) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $xc_bad_var_msg library directories. Use LDFLAGS for: $xc_word" >&5 +printf "%s\n" "$as_me: $xc_bad_var_msg library directories. Use LDFLAGS for: $xc_word" >&6;} + ;; + -l* | --library=*) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $xc_bad_var_msg libraries. Use LIBS for: $xc_word" >&5 +printf "%s\n" "$as_me: $xc_bad_var_msg libraries. Use LIBS for: $xc_word" >&6;} + ;; + esac + done + fi + + if test "$xc_bad_var_libs" = "yes" || + test "$xc_bad_var_cflags" = "yes" || + test "$xc_bad_var_ldflags" = "yes" || + test "$xc_bad_var_cppflags" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: Continuing even with errors mentioned immediately above this line." >&5 +printf "%s\n" "$as_me: WARNING: Continuing even with errors mentioned immediately above this line." >&2;} + fi + + + + # Find a good install program. We prefer a C program (faster), +# so one script is as good as another. But avoid the broken or +# incompatible versions: +# SysV /etc/install, /usr/sbin/install +# SunOS /usr/etc/install +# IRIX /sbin/install +# AIX /bin/install +# AmigaOS /C/install, which installs bootblocks on floppy discs +# AIX 4 /usr/bin/installbsd, which doesn't work without a -g flag +# AFS /usr/afsws/bin/install, which mishandles nonexistent args +# SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" +# OS/2's system install, which has a completely different semantic +# ./install, which can be erroneously created by make from ./install.sh. +# Reject install programs that cannot install multiple files. +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for a BSD-compatible install" >&5 +printf %s "checking for a BSD-compatible install... " >&6; } +if test -z "$INSTALL"; then +if test ${ac_cv_path_install+y} +then : + printf %s "(cached) " >&6 +else $as_nop + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + # Account for fact that we put trailing slashes in our PATH walk. +case $as_dir in #(( + ./ | /[cC]/* | \ + /etc/* | /usr/sbin/* | /usr/etc/* | /sbin/* | /usr/afsws/bin/* | \ + ?:[\\/]os2[\\/]install[\\/]* | ?:[\\/]OS2[\\/]INSTALL[\\/]* | \ + /usr/ucb/* ) ;; + *) + # OSF1 and SCO ODT 3.0 have their own names for install. + # Don't use installbsd from OSF since it installs stuff as root + # by default. + for ac_prog in ginstall scoinst install; do + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_prog$ac_exec_ext"; then + if test $ac_prog = install && + grep dspmsg "$as_dir$ac_prog$ac_exec_ext" >/dev/null 2>&1; then + # AIX install. It has an incompatible calling convention. + : + elif test $ac_prog = install && + grep pwplus "$as_dir$ac_prog$ac_exec_ext" >/dev/null 2>&1; then + # program-specific install script used by HP pwplus--don't use. + : + else + rm -rf conftest.one conftest.two conftest.dir + echo one > conftest.one + echo two > conftest.two + mkdir conftest.dir + if "$as_dir$ac_prog$ac_exec_ext" -c conftest.one conftest.two "`pwd`/conftest.dir/" && + test -s conftest.one && test -s conftest.two && + test -s conftest.dir/conftest.one && + test -s conftest.dir/conftest.two + then + ac_cv_path_install="$as_dir$ac_prog$ac_exec_ext -c" + break 3 + fi + fi + fi + done + done + ;; +esac + + done +IFS=$as_save_IFS + +rm -rf conftest.one conftest.two conftest.dir + +fi + if test ${ac_cv_path_install+y}; then + INSTALL=$ac_cv_path_install + else + # As a last resort, use the slow shell script. Don't cache a + # value for INSTALL within a source directory, because that will + # break other packages using the cache if that directory is + # removed, or if the value is a relative name. + INSTALL=$ac_install_sh + fi +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $INSTALL" >&5 +printf "%s\n" "$INSTALL" >&6; } + +# Use test -z because SunOS4 sh mishandles braces in ${var-val}. +# It thinks the first close brace ends the variable substitution. +test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}' + +test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL}' + +test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' + + + + + + + + + + + +# Expand $ac_aux_dir to an absolute path. +am_aux_dir=`cd "$ac_aux_dir" && pwd` + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu +if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args. +set dummy ${ac_tool_prefix}gcc; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_CC+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="${ac_tool_prefix}gcc" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +printf "%s\n" "$CC" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_CC"; then + ac_ct_CC=$CC + # Extract the first word of "gcc", so it can be a program name with args. +set dummy gcc; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_ac_ct_CC+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="gcc" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_CC=$ac_cv_prog_ac_ct_CC +if test -n "$ac_ct_CC"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 +printf "%s\n" "$ac_ct_CC" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_ct_CC" = x; then + CC="" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + CC=$ac_ct_CC + fi +else + CC="$ac_cv_prog_CC" +fi + +if test -z "$CC"; then + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. +set dummy ${ac_tool_prefix}cc; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_CC+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="${ac_tool_prefix}cc" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +printf "%s\n" "$CC" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + + fi +fi +if test -z "$CC"; then + # Extract the first word of "cc", so it can be a program name with args. +set dummy cc; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_CC+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else + ac_prog_rejected=no +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + if test "$as_dir$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then + ac_prog_rejected=yes + continue + fi + ac_cv_prog_CC="cc" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +if test $ac_prog_rejected = yes; then + # We found a bogon in the path, so make sure we never use it. + set dummy $ac_cv_prog_CC + shift + if test $# != 0; then + # We chose a different compiler from the bogus one. + # However, it has the same basename, so the bogon will be chosen + # first if we set CC to just the basename; use the full file name. + shift + ac_cv_prog_CC="$as_dir$ac_word${1+' '}$@" + fi +fi +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +printf "%s\n" "$CC" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$CC"; then + if test -n "$ac_tool_prefix"; then + for ac_prog in cl.exe + do + # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. +set dummy $ac_tool_prefix$ac_prog; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_CC+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="$ac_tool_prefix$ac_prog" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +printf "%s\n" "$CC" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + + test -n "$CC" && break + done +fi +if test -z "$CC"; then + ac_ct_CC=$CC + for ac_prog in cl.exe +do + # Extract the first word of "$ac_prog", so it can be a program name with args. +set dummy $ac_prog; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_ac_ct_CC+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="$ac_prog" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_CC=$ac_cv_prog_ac_ct_CC +if test -n "$ac_ct_CC"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 +printf "%s\n" "$ac_ct_CC" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + + test -n "$ac_ct_CC" && break +done + + if test "x$ac_ct_CC" = x; then + CC="" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + CC=$ac_ct_CC + fi +fi + +fi +if test -z "$CC"; then + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}clang", so it can be a program name with args. +set dummy ${ac_tool_prefix}clang; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_CC+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="${ac_tool_prefix}clang" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +printf "%s\n" "$CC" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_CC"; then + ac_ct_CC=$CC + # Extract the first word of "clang", so it can be a program name with args. +set dummy clang; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_ac_ct_CC+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="clang" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_CC=$ac_cv_prog_ac_ct_CC +if test -n "$ac_ct_CC"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 +printf "%s\n" "$ac_ct_CC" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_ct_CC" = x; then + CC="" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + CC=$ac_ct_CC + fi +else + CC="$ac_cv_prog_CC" +fi + +fi + + +test -z "$CC" && { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "no acceptable C compiler found in \$PATH +See \`config.log' for more details" "$LINENO" 5; } + +# Provide some information about the compiler. +printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5 +set X $ac_compile +ac_compiler=$2 +for ac_option in --version -v -V -qversion -version; do + { { ac_try="$ac_compiler $ac_option >&5" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +printf "%s\n" "$ac_try_echo"; } >&5 + (eval "$ac_compiler $ac_option >&5") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + sed '10a\ +... rest of stderr output deleted ... + 10q' conftest.err >conftest.er1 + cat conftest.er1 >&5 + fi + rm -f conftest.er1 conftest.err + printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } +done + +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int main(void) +{ + + return 0; +} +_ACEOF +ac_clean_files_save=$ac_clean_files +ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out" +# Try to create an executable without -o first, disregard a.out. +# It will help us diagnose broken compilers, and finding out an intuition +# of exeext. +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the C compiler works" >&5 +printf %s "checking whether the C compiler works... " >&6; } +ac_link_default=`printf "%s\n" "$ac_link" | sed 's/ -o *conftest[^ ]*//'` + +# The possible output files: +ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*" + +ac_rmfiles= +for ac_file in $ac_files +do + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; + * ) ac_rmfiles="$ac_rmfiles $ac_file";; + esac +done +rm -f $ac_rmfiles + +if { { ac_try="$ac_link_default" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +printf "%s\n" "$ac_try_echo"; } >&5 + (eval "$ac_link_default") 2>&5 + ac_status=$? + printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } +then : + # Autoconf-2.13 could set the ac_cv_exeext variable to `no'. +# So ignore a value of `no', otherwise this would lead to `EXEEXT = no' +# in a Makefile. We should not override ac_cv_exeext if it was cached, +# so that the user can short-circuit this test for compilers unknown to +# Autoconf. +for ac_file in $ac_files '' +do + test -f "$ac_file" || continue + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) + ;; + [ab].out ) + # We found the default executable, but exeext='' is most + # certainly right. + break;; + *.* ) + if test ${ac_cv_exeext+y} && test "$ac_cv_exeext" != no; + then :; else + ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` + fi + # We set ac_cv_exeext here because the later test for it is not + # safe: cross compilers may not add the suffix if given an `-o' + # argument, so we may need to know it at that point already. + # Even if this section looks crufty: it has the advantage of + # actually working. + break;; + * ) + break;; + esac +done +test "$ac_cv_exeext" = no && ac_cv_exeext= + +else $as_nop + ac_file='' +fi +if test -z "$ac_file" +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +printf "%s\n" "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error 77 "C compiler cannot create executables +See \`config.log' for more details" "$LINENO" 5; } +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5 +printf %s "checking for C compiler default output file name... " >&6; } +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5 +printf "%s\n" "$ac_file" >&6; } +ac_exeext=$ac_cv_exeext + +rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out +ac_clean_files=$ac_clean_files_save +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5 +printf %s "checking for suffix of executables... " >&6; } +if { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +printf "%s\n" "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>&5 + ac_status=$? + printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } +then : + # If both `conftest.exe' and `conftest' are `present' (well, observable) +# catch `conftest.exe'. For instance with Cygwin, `ls conftest' will +# work properly (i.e., refer to `conftest.exe'), while it won't with +# `rm'. +for ac_file in conftest.exe conftest conftest.*; do + test -f "$ac_file" || continue + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; + *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` + break;; + * ) break;; + esac +done +else $as_nop + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot compute suffix of executables: cannot compile and link +See \`config.log' for more details" "$LINENO" 5; } +fi +rm -f conftest conftest$ac_cv_exeext +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 +printf "%s\n" "$ac_cv_exeext" >&6; } + +rm -f conftest.$ac_ext +EXEEXT=$ac_cv_exeext +ac_exeext=$EXEEXT +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +int main(void) +{ +FILE *f = fopen ("conftest.out", "w"); + return ferror (f) || fclose (f) != 0; + + return 0; +} +_ACEOF +ac_clean_files="$ac_clean_files conftest.out" +# Check that the compiler produces executables we can run. If not, either +# the compiler is broken, or we cross compile. +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5 +printf %s "checking whether we are cross compiling... " >&6; } +if test "$cross_compiling" != yes; then + { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +printf "%s\n" "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>&5 + ac_status=$? + printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } + if { ac_try='./conftest$ac_cv_exeext' + { { case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +printf "%s\n" "$ac_try_echo"; } >&5 + (eval "$ac_try") 2>&5 + ac_status=$? + printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; }; then + cross_compiling=no + else + if test "$cross_compiling" = maybe; then + cross_compiling=yes + else + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error 77 "cannot run C compiled programs. +If you meant to cross compile, use \`--host'. +See \`config.log' for more details" "$LINENO" 5; } + fi + fi +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5 +printf "%s\n" "$cross_compiling" >&6; } + +rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out +ac_clean_files=$ac_clean_files_save +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 +printf %s "checking for suffix of object files... " >&6; } +if test ${ac_cv_objext+y} +then : + printf %s "(cached) " >&6 +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int main(void) +{ + + return 0; +} +_ACEOF +rm -f conftest.o conftest.obj +if { { ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +printf "%s\n" "$ac_try_echo"; } >&5 + (eval "$ac_compile") 2>&5 + ac_status=$? + printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } +then : + for ac_file in conftest.o conftest.obj conftest.*; do + test -f "$ac_file" || continue; + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;; + *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` + break;; + esac +done +else $as_nop + printf "%s\n" "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot compute suffix of object files: cannot compile +See \`config.log' for more details" "$LINENO" 5; } +fi +rm -f conftest.$ac_cv_objext conftest.$ac_ext +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 +printf "%s\n" "$ac_cv_objext" >&6; } +OBJEXT=$ac_cv_objext +ac_objext=$OBJEXT +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the compiler supports GNU C" >&5 +printf %s "checking whether the compiler supports GNU C... " >&6; } +if test ${ac_cv_c_compiler_gnu+y} +then : + printf %s "(cached) " >&6 +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int main(void) +{ +#ifndef __GNUC__ + choke me +#endif + + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + ac_compiler_gnu=yes +else $as_nop + ac_compiler_gnu=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext +ac_cv_c_compiler_gnu=$ac_compiler_gnu + +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5 +printf "%s\n" "$ac_cv_c_compiler_gnu" >&6; } +ac_compiler_gnu=$ac_cv_c_compiler_gnu + +if test $ac_compiler_gnu = yes; then + GCC=yes +else + GCC= +fi +ac_test_CFLAGS=${CFLAGS+y} +ac_save_CFLAGS=$CFLAGS +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 +printf %s "checking whether $CC accepts -g... " >&6; } +if test ${ac_cv_prog_cc_g+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_save_c_werror_flag=$ac_c_werror_flag + ac_c_werror_flag=yes + ac_cv_prog_cc_g=no + CFLAGS="-g" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int main(void) +{ + + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + ac_cv_prog_cc_g=yes +else $as_nop + CFLAGS="" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int main(void) +{ + + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + +else $as_nop + ac_c_werror_flag=$ac_save_c_werror_flag + CFLAGS="-g" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int main(void) +{ + + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + ac_cv_prog_cc_g=yes +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + ac_c_werror_flag=$ac_save_c_werror_flag +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5 +printf "%s\n" "$ac_cv_prog_cc_g" >&6; } +if test $ac_test_CFLAGS; then + CFLAGS=$ac_save_CFLAGS +elif test $ac_cv_prog_cc_g = yes; then + if test "$GCC" = yes; then + CFLAGS="-g -O2" + else + CFLAGS="-g" + fi +else + if test "$GCC" = yes; then + CFLAGS="-O2" + else + CFLAGS= + fi +fi +ac_prog_cc_stdc=no +if test x$ac_prog_cc_stdc = xno +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C11 features" >&5 +printf %s "checking for $CC option to enable C11 features... " >&6; } +if test ${ac_cv_prog_cc_c11+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_cv_prog_cc_c11=no +ac_save_CC=$CC +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$ac_c_conftest_c11_program +_ACEOF +for ac_arg in '' -std=gnu11 +do + CC="$ac_save_CC $ac_arg" + if ac_fn_c_try_compile "$LINENO" +then : + ac_cv_prog_cc_c11=$ac_arg +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam + test "x$ac_cv_prog_cc_c11" != "xno" && break +done +rm -f conftest.$ac_ext +CC=$ac_save_CC +fi + +if test "x$ac_cv_prog_cc_c11" = xno +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 +printf "%s\n" "unsupported" >&6; } +else $as_nop + if test "x$ac_cv_prog_cc_c11" = x +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 +printf "%s\n" "none needed" >&6; } +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c11" >&5 +printf "%s\n" "$ac_cv_prog_cc_c11" >&6; } + CC="$CC $ac_cv_prog_cc_c11" +fi + ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c11 + ac_prog_cc_stdc=c11 +fi +fi +if test x$ac_prog_cc_stdc = xno +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C99 features" >&5 +printf %s "checking for $CC option to enable C99 features... " >&6; } +if test ${ac_cv_prog_cc_c99+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_cv_prog_cc_c99=no +ac_save_CC=$CC +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$ac_c_conftest_c99_program +_ACEOF +for ac_arg in '' -std=gnu99 -std=c99 -c99 -qlanglvl=extc1x -qlanglvl=extc99 -AC99 -D_STDC_C99= +do + CC="$ac_save_CC $ac_arg" + if ac_fn_c_try_compile "$LINENO" +then : + ac_cv_prog_cc_c99=$ac_arg +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam + test "x$ac_cv_prog_cc_c99" != "xno" && break +done +rm -f conftest.$ac_ext +CC=$ac_save_CC +fi + +if test "x$ac_cv_prog_cc_c99" = xno +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 +printf "%s\n" "unsupported" >&6; } +else $as_nop + if test "x$ac_cv_prog_cc_c99" = x +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 +printf "%s\n" "none needed" >&6; } +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c99" >&5 +printf "%s\n" "$ac_cv_prog_cc_c99" >&6; } + CC="$CC $ac_cv_prog_cc_c99" +fi + ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c99 + ac_prog_cc_stdc=c99 +fi +fi +if test x$ac_prog_cc_stdc = xno +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C89 features" >&5 +printf %s "checking for $CC option to enable C89 features... " >&6; } +if test ${ac_cv_prog_cc_c89+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_cv_prog_cc_c89=no +ac_save_CC=$CC +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$ac_c_conftest_c89_program +_ACEOF +for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" +do + CC="$ac_save_CC $ac_arg" + if ac_fn_c_try_compile "$LINENO" +then : + ac_cv_prog_cc_c89=$ac_arg +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam + test "x$ac_cv_prog_cc_c89" != "xno" && break +done +rm -f conftest.$ac_ext +CC=$ac_save_CC +fi + +if test "x$ac_cv_prog_cc_c89" = xno +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 +printf "%s\n" "unsupported" >&6; } +else $as_nop + if test "x$ac_cv_prog_cc_c89" = x +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 +printf "%s\n" "none needed" >&6; } +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 +printf "%s\n" "$ac_cv_prog_cc_c89" >&6; } + CC="$CC $ac_cv_prog_cc_c89" +fi + ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c89 + ac_prog_cc_stdc=c89 +fi +fi + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + + ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether $CC understands -c and -o together" >&5 +printf %s "checking whether $CC understands -c and -o together... " >&6; } +if test ${am_cv_prog_cc_c_o+y} +then : + printf %s "(cached) " >&6 +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int main(void) +{ + + return 0; +} +_ACEOF + # Make sure it works both with $CC and with simple cc. + # Following AC_PROG_CC_C_O, we do the test twice because some + # compilers refuse to overwrite an existing .o file with -o, + # though they will create one. + am_cv_prog_cc_c_o=yes + for am_i in 1 2; do + if { echo "$as_me:$LINENO: $CC -c conftest.$ac_ext -o conftest2.$ac_objext" >&5 + ($CC -c conftest.$ac_ext -o conftest2.$ac_objext) >&5 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } \ + && test -f conftest2.$ac_objext; then + : OK + else + am_cv_prog_cc_c_o=no + break + fi + done + rm -f core conftest* + unset am_i +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $am_cv_prog_cc_c_o" >&5 +printf "%s\n" "$am_cv_prog_cc_c_o" >&6; } +if test "$am_cv_prog_cc_c_o" != yes; then + # Losing compiler, so override with the script. + # FIXME: It is wrong to rewrite CC. + # But if we don't then we get into trouble of one sort or another. + # A longer-term fix would be to have automake use am__CC in this case, + # and then we could set am__CC="\$(top_srcdir)/compile \$(CC)" + CC="$am_aux_dir/compile $CC" +fi +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5 +printf %s "checking how to run the C preprocessor... " >&6; } +# On Suns, sometimes $CPP names a directory. +if test -n "$CPP" && test -d "$CPP"; then + CPP= +fi +if test -z "$CPP"; then + if test ${ac_cv_prog_CPP+y} +then : + printf %s "(cached) " >&6 +else $as_nop + # Double quotes because $CC needs to be expanded + for CPP in "$CC -E" "$CC -E -traditional-cpp" cpp /lib/cpp + do + ac_preproc_ok=false +for ac_c_preproc_warn_flag in '' yes +do + # Use a header file that comes with gcc, so configuring glibc + # with a fresh cross-compiler works. + # On the NeXT, cc -E runs the code through the compiler's parser, + # not just through cpp. "Syntax error" is here to catch this case. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include + Syntax error +_ACEOF +if ac_fn_c_try_cpp "$LINENO" +then : + +else $as_nop + # Broken: fails on valid input. +continue +fi +rm -f conftest.err conftest.i conftest.$ac_ext + + # OK, works on sane cases. Now check whether nonexistent headers + # can be detected and how. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +_ACEOF +if ac_fn_c_try_cpp "$LINENO" +then : + # Broken: success on invalid input. +continue +else $as_nop + # Passes both tests. +ac_preproc_ok=: +break +fi +rm -f conftest.err conftest.i conftest.$ac_ext + +done +# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. +rm -f conftest.i conftest.err conftest.$ac_ext +if $ac_preproc_ok +then : + break +fi + + done + ac_cv_prog_CPP=$CPP + +fi + CPP=$ac_cv_prog_CPP +else + ac_cv_prog_CPP=$CPP +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5 +printf "%s\n" "$CPP" >&6; } +ac_preproc_ok=false +for ac_c_preproc_warn_flag in '' yes +do + # Use a header file that comes with gcc, so configuring glibc + # with a fresh cross-compiler works. + # On the NeXT, cc -E runs the code through the compiler's parser, + # not just through cpp. "Syntax error" is here to catch this case. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include + Syntax error +_ACEOF +if ac_fn_c_try_cpp "$LINENO" +then : + +else $as_nop + # Broken: fails on valid input. +continue +fi +rm -f conftest.err conftest.i conftest.$ac_ext + + # OK, works on sane cases. Now check whether nonexistent headers + # can be detected and how. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +_ACEOF +if ac_fn_c_try_cpp "$LINENO" +then : + # Broken: success on invalid input. +continue +else $as_nop + # Passes both tests. +ac_preproc_ok=: +break +fi +rm -f conftest.err conftest.i conftest.$ac_ext + +done +# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. +rm -f conftest.i conftest.err conftest.$ac_ext +if $ac_preproc_ok +then : + +else $as_nop + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "C preprocessor \"$CPP\" fails sanity check +See \`config.log' for more details" "$LINENO" 5; } +fi + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + + IFS=$xc_prog_cc_prev_IFS + LIBS=$xc_prog_cc_prev_LIBS + CFLAGS=$xc_prog_cc_prev_CFLAGS + LDFLAGS=$xc_prog_cc_prev_LDFLAGS + CPPFLAGS=$xc_prog_cc_prev_CPPFLAGS + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +ac_header= ac_cache= +for ac_item in $ac_header_c_list +do + if test $ac_cache; then + ac_fn_c_check_header_compile "$LINENO" $ac_header ac_cv_header_$ac_cache "$ac_includes_default" + if eval test \"x\$ac_cv_header_$ac_cache\" = xyes; then + printf "%s\n" "#define $ac_item 1" >> confdefs.h + fi + ac_header= ac_cache= + elif test $ac_header; then + ac_cache=$ac_item + else + ac_header=$ac_item + fi +done + + + + + + + + +if test $ac_cv_header_stdlib_h = yes && test $ac_cv_header_string_h = yes +then : + +printf "%s\n" "#define STDC_HEADERS 1" >>confdefs.h + +fi + + for ac_header in stdatomic.h +do : + ac_fn_c_check_header_compile "$LINENO" "stdatomic.h" "ac_cv_header_stdatomic_h" "$ac_includes_default" +if test "x$ac_cv_header_stdatomic_h" = xyes +then : + printf "%s\n" "#define HAVE_STDATOMIC_H 1" >>confdefs.h + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if _Atomic is available" >&5 +printf %s "checking if _Atomic is available... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_unistd + +int main(void) +{ + + _Atomic int i = 0; + i = 4; // Force an atomic-write operation. + (void)i; + + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_ATOMIC 1" >>confdefs.h + + tst_atomic="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_atomic="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + +fi + +done + + +am__api_version='1.16' + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether build environment is sane" >&5 +printf %s "checking whether build environment is sane... " >&6; } +# Reject unsafe characters in $srcdir or the absolute working directory +# name. Accept space and tab only in the latter. +am_lf=' +' +case `pwd` in + *[\\\"\#\$\&\'\`$am_lf]*) + as_fn_error $? "unsafe absolute working directory name" "$LINENO" 5;; +esac +case $srcdir in + *[\\\"\#\$\&\'\`$am_lf\ \ ]*) + as_fn_error $? "unsafe srcdir value: '$srcdir'" "$LINENO" 5;; +esac + +# Do 'set' in a subshell so we don't clobber the current shell's +# arguments. Must try -L first in case configure is actually a +# symlink; some systems play weird games with the mod time of symlinks +# (eg FreeBSD returns the mod time of the symlink's containing +# directory). +if ( + am_has_slept=no + for am_try in 1 2; do + echo "timestamp, slept: $am_has_slept" > conftest.file + set X `ls -Lt "$srcdir/configure" conftest.file 2> /dev/null` + if test "$*" = "X"; then + # -L didn't work. + set X `ls -t "$srcdir/configure" conftest.file` + fi + if test "$*" != "X $srcdir/configure conftest.file" \ + && test "$*" != "X conftest.file $srcdir/configure"; then + + # If neither matched, then we have a broken ls. This can happen + # if, for instance, CONFIG_SHELL is bash and it inherits a + # broken ls alias from the environment. This has actually + # happened. Such a system could not be considered "sane". + as_fn_error $? "ls -t appears to fail. Make sure there is not a broken + alias in your environment" "$LINENO" 5 + fi + if test "$2" = conftest.file || test $am_try -eq 2; then + break + fi + # Just in case. + sleep 1 + am_has_slept=yes + done + test "$2" = conftest.file + ) +then + # Ok. + : +else + as_fn_error $? "newly created file is older than distributed files! +Check your system clock" "$LINENO" 5 +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } +# If we didn't sleep, we still need to ensure time stamps of config.status and +# generated files are strictly newer. +am_sleep_pid= +if grep 'slept: no' conftest.file >/dev/null 2>&1; then + ( sleep 1 ) & + am_sleep_pid=$! +fi + +rm -f conftest.file + +test "$program_prefix" != NONE && + program_transform_name="s&^&$program_prefix&;$program_transform_name" +# Use a double $ so make ignores it. +test "$program_suffix" != NONE && + program_transform_name="s&\$&$program_suffix&;$program_transform_name" +# Double any \ or $. +# By default was `s,x,x', remove it if useless. +ac_script='s/[\\$]/&&/g;s/;s,x,x,$//' +program_transform_name=`printf "%s\n" "$program_transform_name" | sed "$ac_script"` + + + if test x"${MISSING+set}" != xset; then + MISSING="\${SHELL} '$am_aux_dir/missing'" +fi +# Use eval to expand $SHELL +if eval "$MISSING --is-lightweight"; then + am_missing_run="$MISSING " +else + am_missing_run= + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: 'missing' script is too old or missing" >&5 +printf "%s\n" "$as_me: WARNING: 'missing' script is too old or missing" >&2;} +fi + +if test x"${install_sh+set}" != xset; then + case $am_aux_dir in + *\ * | *\ *) + install_sh="\${SHELL} '$am_aux_dir/install-sh'" ;; + *) + install_sh="\${SHELL} $am_aux_dir/install-sh" + esac +fi + +# Installed binaries are usually stripped using 'strip' when the user +# run "make install-strip". However 'strip' might not be the right +# tool to use in cross-compilation environments, therefore Automake +# will honor the 'STRIP' environment variable to overrule this program. +if test "$cross_compiling" != no; then + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}strip", so it can be a program name with args. +set dummy ${ac_tool_prefix}strip; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_STRIP+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$STRIP"; then + ac_cv_prog_STRIP="$STRIP" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_STRIP="${ac_tool_prefix}strip" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +STRIP=$ac_cv_prog_STRIP +if test -n "$STRIP"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $STRIP" >&5 +printf "%s\n" "$STRIP" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_STRIP"; then + ac_ct_STRIP=$STRIP + # Extract the first word of "strip", so it can be a program name with args. +set dummy strip; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_ac_ct_STRIP+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$ac_ct_STRIP"; then + ac_cv_prog_ac_ct_STRIP="$ac_ct_STRIP" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_STRIP="strip" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_STRIP=$ac_cv_prog_ac_ct_STRIP +if test -n "$ac_ct_STRIP"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_STRIP" >&5 +printf "%s\n" "$ac_ct_STRIP" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_ct_STRIP" = x; then + STRIP=":" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + STRIP=$ac_ct_STRIP + fi +else + STRIP="$ac_cv_prog_STRIP" +fi + +fi +INSTALL_STRIP_PROGRAM="\$(install_sh) -c -s" + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for a race-free mkdir -p" >&5 +printf %s "checking for a race-free mkdir -p... " >&6; } +if test -z "$MKDIR_P"; then + if test ${ac_cv_path_mkdir+y} +then : + printf %s "(cached) " >&6 +else $as_nop + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH$PATH_SEPARATOR/opt/sfw/bin +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_prog in mkdir gmkdir; do + for ac_exec_ext in '' $ac_executable_extensions; do + as_fn_executable_p "$as_dir$ac_prog$ac_exec_ext" || continue + case `"$as_dir$ac_prog$ac_exec_ext" --version 2>&1` in #( + 'mkdir ('*'coreutils) '* | \ + 'BusyBox '* | \ + 'mkdir (fileutils) '4.1*) + ac_cv_path_mkdir=$as_dir$ac_prog$ac_exec_ext + break 3;; + esac + done + done + done +IFS=$as_save_IFS + +fi + + test -d ./--version && rmdir ./--version + if test ${ac_cv_path_mkdir+y}; then + MKDIR_P="$ac_cv_path_mkdir -p" + else + # As a last resort, use the slow shell script. Don't cache a + # value for MKDIR_P within a source directory, because that will + # break other packages using the cache if that directory is + # removed, or if the value is a relative name. + MKDIR_P="$ac_install_sh -d" + fi +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $MKDIR_P" >&5 +printf "%s\n" "$MKDIR_P" >&6; } + +for ac_prog in gawk mawk nawk awk +do + # Extract the first word of "$ac_prog", so it can be a program name with args. +set dummy $ac_prog; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_AWK+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$AWK"; then + ac_cv_prog_AWK="$AWK" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_AWK="$ac_prog" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +AWK=$ac_cv_prog_AWK +if test -n "$AWK"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $AWK" >&5 +printf "%s\n" "$AWK" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + + test -n "$AWK" && break +done + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether ${MAKE-make} sets \$(MAKE)" >&5 +printf %s "checking whether ${MAKE-make} sets \$(MAKE)... " >&6; } +set x ${MAKE-make} +ac_make=`printf "%s\n" "$2" | sed 's/+/p/g; s/[^a-zA-Z0-9_]/_/g'` +if eval test \${ac_cv_prog_make_${ac_make}_set+y} +then : + printf %s "(cached) " >&6 +else $as_nop + cat >conftest.make <<\_ACEOF +SHELL = /bin/sh +all: + @echo '@@@%%%=$(MAKE)=@@@%%%' +_ACEOF +# GNU make sometimes prints "make[1]: Entering ...", which would confuse us. +case `${MAKE-make} -f conftest.make 2>/dev/null` in + *@@@%%%=?*=@@@%%%*) + eval ac_cv_prog_make_${ac_make}_set=yes;; + *) + eval ac_cv_prog_make_${ac_make}_set=no;; +esac +rm -f conftest.make +fi +if eval test \$ac_cv_prog_make_${ac_make}_set = yes; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + SET_MAKE= +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + SET_MAKE="MAKE=${MAKE-make}" +fi + +rm -rf .tst 2>/dev/null +mkdir .tst 2>/dev/null +if test -d .tst; then + am__leading_dot=. +else + am__leading_dot=_ +fi +rmdir .tst 2>/dev/null + +DEPDIR="${am__leading_dot}deps" + +ac_config_commands="$ac_config_commands depfiles" + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether ${MAKE-make} supports the include directive" >&5 +printf %s "checking whether ${MAKE-make} supports the include directive... " >&6; } +cat > confinc.mk << 'END' +am__doit: + @echo this is the am__doit target >confinc.out +.PHONY: am__doit +END +am__include="#" +am__quote= +# BSD make does it like this. +echo '.include "confinc.mk" # ignored' > confmf.BSD +# Other make implementations (GNU, Solaris 10, AIX) do it like this. +echo 'include confinc.mk # ignored' > confmf.GNU +_am_result=no +for s in GNU BSD; do + { echo "$as_me:$LINENO: ${MAKE-make} -f confmf.$s && cat confinc.out" >&5 + (${MAKE-make} -f confmf.$s && cat confinc.out) >&5 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } + case $?:`cat confinc.out 2>/dev/null` in #( + '0:this is the am__doit target') : + case $s in #( + BSD) : + am__include='.include' am__quote='"' ;; #( + *) : + am__include='include' am__quote='' ;; +esac ;; #( + *) : + ;; +esac + if test "$am__include" != "#"; then + _am_result="yes ($s style)" + break + fi +done +rm -f confinc.* confmf.* +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: ${_am_result}" >&5 +printf "%s\n" "${_am_result}" >&6; } + +# Check whether --enable-dependency-tracking was given. +if test ${enable_dependency_tracking+y} +then : + enableval=$enable_dependency_tracking; +fi + +if test "x$enable_dependency_tracking" != xno; then + am_depcomp="$ac_aux_dir/depcomp" + AMDEPBACKSLASH='\' + am__nodep='_no' +fi + if test "x$enable_dependency_tracking" != xno; then + AMDEP_TRUE= + AMDEP_FALSE='#' +else + AMDEP_TRUE='#' + AMDEP_FALSE= +fi + + + + + + + + + +if test "`cd $srcdir && pwd`" != "`pwd`"; then + # Use -I$(srcdir) only when $(srcdir) != ., so that make's output + # is not polluted with repeated "-I." + am__isrc=' -I$(srcdir)' + # test to see if srcdir already configured + if test -f $srcdir/config.status; then + as_fn_error $? "source directory already configured; run \"make distclean\" there first" "$LINENO" 5 + fi +fi + +# test whether we have cygpath +if test -z "$CYGPATH_W"; then + if (cygpath --version) >/dev/null 2>/dev/null; then + CYGPATH_W='cygpath -w' + else + CYGPATH_W=echo + fi +fi + + +# Define the identity of the package. + PACKAGE='curl' + VERSION='-' + + +printf "%s\n" "#define PACKAGE \"$PACKAGE\"" >>confdefs.h + + +printf "%s\n" "#define VERSION \"$VERSION\"" >>confdefs.h + +# Some tools Automake needs. + +ACLOCAL=${ACLOCAL-"${am_missing_run}aclocal-${am__api_version}"} + + +AUTOCONF=${AUTOCONF-"${am_missing_run}autoconf"} + + +AUTOMAKE=${AUTOMAKE-"${am_missing_run}automake-${am__api_version}"} + + +AUTOHEADER=${AUTOHEADER-"${am_missing_run}autoheader"} + + +MAKEINFO=${MAKEINFO-"${am_missing_run}makeinfo"} + +# For better backward compatibility. To be removed once Automake 1.9.x +# dies out for good. For more background, see: +# +# +mkdir_p='$(MKDIR_P)' + +# We need awk for the "check" target (and possibly the TAP driver). The +# system "awk" is bad on some platforms. +# Always define AMTAR for backward compatibility. Yes, it's still used +# in the wild :-( We should find a proper way to deprecate it ... +AMTAR='$${TAR-tar}' + + +# We'll loop over all known methods to create a tar archive until one works. +_am_tools='gnutar pax cpio none' + +am__tar='$${TAR-tar} chof - "$$tardir"' am__untar='$${TAR-tar} xf -' + + + + + +depcc="$CC" am_compiler_list= + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking dependency style of $depcc" >&5 +printf %s "checking dependency style of $depcc... " >&6; } +if test ${am_cv_CC_dependencies_compiler_type+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -z "$AMDEP_TRUE" && test -f "$am_depcomp"; then + # We make a subdir and do the tests there. Otherwise we can end up + # making bogus files that we don't know about and never remove. For + # instance it was reported that on HP-UX the gcc test will end up + # making a dummy file named 'D' -- because '-MD' means "put the output + # in D". + rm -rf conftest.dir + mkdir conftest.dir + # Copy depcomp to subdir because otherwise we won't find it if we're + # using a relative directory. + cp "$am_depcomp" conftest.dir + cd conftest.dir + # We will build objects and dependencies in a subdirectory because + # it helps to detect inapplicable dependency modes. For instance + # both Tru64's cc and ICC support -MD to output dependencies as a + # side effect of compilation, but ICC will put the dependencies in + # the current directory while Tru64 will put them in the object + # directory. + mkdir sub + + am_cv_CC_dependencies_compiler_type=none + if test "$am_compiler_list" = ""; then + am_compiler_list=`sed -n 's/^#*\([a-zA-Z0-9]*\))$/\1/p' < ./depcomp` + fi + am__universal=false + case " $depcc " in #( + *\ -arch\ *\ -arch\ *) am__universal=true ;; + esac + + for depmode in $am_compiler_list; do + # Setup a source with many dependencies, because some compilers + # like to wrap large dependency lists on column 80 (with \), and + # we should not choose a depcomp mode which is confused by this. + # + # We need to recreate these files for each test, as the compiler may + # overwrite some of them when testing with obscure command lines. + # This happens at least with the AIX C compiler. + : > sub/conftest.c + for i in 1 2 3 4 5 6; do + echo '#include "conftst'$i'.h"' >> sub/conftest.c + # Using ": > sub/conftst$i.h" creates only sub/conftst1.h with + # Solaris 10 /bin/sh. + echo '/* dummy */' > sub/conftst$i.h + done + echo "${am__include} ${am__quote}sub/conftest.Po${am__quote}" > confmf + + # We check with '-c' and '-o' for the sake of the "dashmstdout" + # mode. It turns out that the SunPro C++ compiler does not properly + # handle '-M -o', and we need to detect this. Also, some Intel + # versions had trouble with output in subdirs. + am__obj=sub/conftest.${OBJEXT-o} + am__minus_obj="-o $am__obj" + case $depmode in + gcc) + # This depmode causes a compiler race in universal mode. + test "$am__universal" = false || continue + ;; + nosideeffect) + # After this tag, mechanisms are not by side-effect, so they'll + # only be used when explicitly requested. + if test "x$enable_dependency_tracking" = xyes; then + continue + else + break + fi + ;; + msvc7 | msvc7msys | msvisualcpp | msvcmsys) + # This compiler won't grok '-c -o', but also, the minuso test has + # not run yet. These depmodes are late enough in the game, and + # so weak that their functioning should not be impacted. + am__obj=conftest.${OBJEXT-o} + am__minus_obj= + ;; + none) break ;; + esac + if depmode=$depmode \ + source=sub/conftest.c object=$am__obj \ + depfile=sub/conftest.Po tmpdepfile=sub/conftest.TPo \ + $SHELL ./depcomp $depcc -c $am__minus_obj sub/conftest.c \ + >/dev/null 2>conftest.err && + grep sub/conftst1.h sub/conftest.Po > /dev/null 2>&1 && + grep sub/conftst6.h sub/conftest.Po > /dev/null 2>&1 && + grep $am__obj sub/conftest.Po > /dev/null 2>&1 && + ${MAKE-make} -s -f confmf > /dev/null 2>&1; then + # icc doesn't choke on unknown options, it will just issue warnings + # or remarks (even with -Werror). So we grep stderr for any message + # that says an option was ignored or not supported. + # When given -MP, icc 7.0 and 7.1 complain thusly: + # icc: Command line warning: ignoring option '-M'; no argument required + # The diagnosis changed in icc 8.0: + # icc: Command line remark: option '-MP' not supported + if (grep 'ignoring option' conftest.err || + grep 'not supported' conftest.err) >/dev/null 2>&1; then :; else + am_cv_CC_dependencies_compiler_type=$depmode + break + fi + fi + done + + cd .. + rm -rf conftest.dir +else + am_cv_CC_dependencies_compiler_type=none +fi + +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $am_cv_CC_dependencies_compiler_type" >&5 +printf "%s\n" "$am_cv_CC_dependencies_compiler_type" >&6; } +CCDEPMODE=depmode=$am_cv_CC_dependencies_compiler_type + + if + test "x$enable_dependency_tracking" != xno \ + && test "$am_cv_CC_dependencies_compiler_type" = gcc3; then + am__fastdepCC_TRUE= + am__fastdepCC_FALSE='#' +else + am__fastdepCC_TRUE='#' + am__fastdepCC_FALSE= +fi + + +# Variables for tags utilities; see am/tags.am +if test -z "$CTAGS"; then + CTAGS=ctags +fi + +if test -z "$ETAGS"; then + ETAGS=etags +fi + +if test -z "$CSCOPE"; then + CSCOPE=cscope +fi + + + +# POSIX will say in a future version that running "rm -f" with no argument +# is OK; and we want to be able to make that assumption in our Makefile +# recipes. So use an aggressive probe to check that the usage we want is +# actually supported "in the wild" to an acceptable degree. +# See automake bug#10828. +# To make any issue more visible, cause the running configure to be aborted +# by default if the 'rm' program in use doesn't match our expectations; the +# user can still override this though. +if rm -f && rm -fr && rm -rf; then : OK; else + cat >&2 <<'END' +Oops! + +Your 'rm' program seems unable to run without file operands specified +on the command line, even when the '-f' option is present. This is contrary +to the behaviour of most rm programs out there, and not conforming with +the upcoming POSIX standard: + +Please tell bug-automake@gnu.org about your system, including the value +of your $PATH and any error possibly output before this message. This +can help us improve future automake versions. + +END + if test x"$ACCEPT_INFERIOR_RM_PROGRAM" = x"yes"; then + echo 'Configuration will proceed anyway, since you have set the' >&2 + echo 'ACCEPT_INFERIOR_RM_PROGRAM variable to "yes"' >&2 + echo >&2 + else + cat >&2 <<'END' +Aborting the configuration process, to ensure you take notice of the issue. + +You can download and install GNU coreutils to get an 'rm' implementation +that behaves properly: . + +If you want to complete the configuration process using your problematic +'rm' anyway, export the environment variable ACCEPT_INFERIOR_RM_PROGRAM +to "yes", and re-run configure. + +END + as_fn_error $? "Your 'rm' program is bad, sorry." "$LINENO" 5 + fi +fi + + + + + + + + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking curl version" >&5 +printf %s "checking curl version... " >&6; } +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CURLVERSION" >&5 +printf "%s\n" "$CURLVERSION" >&6; } + + + +VERSIONNUM=`$SED -ne 's/^#define LIBCURL_VERSION_NUM 0x\([0-9A-Fa-f]*\).*/\1/p' ${srcdir}/include/curl/curlver.h` + + + curl_ssl_msg="no (--with-{openssl,gnutls,mbedtls,wolfssl,schannel,amissl,rustls} )" + curl_ssh_msg="no (--with-{libssh,libssh2})" + curl_zlib_msg="no (--with-zlib)" + curl_brotli_msg="no (--with-brotli)" + curl_zstd_msg="no (--with-zstd)" + curl_gss_msg="no (--with-gssapi)" + curl_gsasl_msg="no (--with-gsasl)" + curl_tls_srp_msg="no (--enable-tls-srp)" + curl_res_msg="blocking (--enable-ares / --enable-threaded-resolver)" + curl_ipv6_msg="no (--enable-ipv6)" +curl_unix_sockets_msg="no (--enable-unix-sockets)" + curl_idn_msg="no (--with-{libidn2,winidn})" + curl_docs_msg="enabled (--disable-docs)" + curl_manual_msg="no (--enable-manual)" + curl_libcurl_msg="enabled (--disable-libcurl-option)" + curl_typecheck_msg="enabled (--disable-typecheck)" + curl_verbose_msg="enabled (--disable-verbose)" + curl_sspi_msg="no (--enable-sspi)" + curl_ldap_msg="no (--enable-ldap / --with-ldap-lib / --with-lber-lib)" + curl_ldaps_msg="no (--enable-ldaps)" + curl_ipfs_msg="no (--enable-ipfs)" + curl_rtsp_msg="no (--enable-rtsp)" + curl_psl_msg="no (--with-libpsl)" + curl_altsvc_msg="enabled (--disable-alt-svc)" + curl_headers_msg="enabled (--disable-headers-api)" + curl_hsts_msg="enabled (--disable-hsts)" + ssl_backends= + curl_h1_msg="enabled (internal)" + curl_h2_msg="no (--with-nghttp2)" + curl_h3_msg="no (--with-ngtcp2 --with-nghttp3, --with-quiche)" + +enable_altsvc="yes" +hsts="yes" + +INITIAL_LDFLAGS=$LDFLAGS +INITIAL_LIBS=$LIBS + +compilersh="run-compiler" +CURL_SAVED_CC="$CC" +export CURL_SAVED_CC +CURL_SAVED_LD_LIBRARY_PATH="$LD_LIBRARY_PATH" +export CURL_SAVED_LD_LIBRARY_PATH +cat <<\EOF > "$compilersh" +CC="$CURL_SAVED_CC" +export CC +LD_LIBRARY_PATH="$CURL_SAVED_LD_LIBRARY_PATH" +export LD_LIBRARY_PATH +exec $CC "$@" +EOF + +OPT_SCHANNEL=no + +# Check whether --with-schannel was given. +if test ${with_schannel+y} +then : + withval=$with_schannel; OPT_SCHANNEL=$withval + TLSCHOICE="Schannel" +fi + + +OPT_AMISSL=no + +# Check whether --with-amissl was given. +if test ${with_amissl+y} +then : + withval=$with_amissl; + OPT_AMISSL=$withval + TLSCHOICE="${TLSCHOICE:+$TLSCHOICE, }AmiSSL" + +fi + + +OPT_OPENSSL=no +ca="no" + +# Check whether --with-ssl was given. +if test ${with_ssl+y} +then : + withval=$with_ssl; + OPT_SSL=$withval + OPT_OPENSSL=$withval + if test "x$withval" != "xno"; then + TLSCHOICE="${TLSCHOICE:+$TLSCHOICE, }OpenSSL" + else + SSL_DISABLED="D" + fi + +fi + + + +# Check whether --with-openssl was given. +if test ${with_openssl+y} +then : + withval=$with_openssl; + OPT_OPENSSL=$withval + if test "x$withval" != "xno"; then + TLSCHOICE="${TLSCHOICE:+$TLSCHOICE, }OpenSSL" + fi + +fi + + +OPT_GNUTLS=no + +# Check whether --with-gnutls was given. +if test ${with_gnutls+y} +then : + withval=$with_gnutls; + OPT_GNUTLS=$withval + if test "x$withval" != "xno"; then + TLSCHOICE="${TLSCHOICE:+$TLSCHOICE, }GnuTLS" + fi + +fi + + +OPT_MBEDTLS=no + +# Check whether --with-mbedtls was given. +if test ${with_mbedtls+y} +then : + withval=$with_mbedtls; + OPT_MBEDTLS=$withval + if test "x$withval" != "xno"; then + TLSCHOICE="${TLSCHOICE:+$TLSCHOICE, }mbedTLS" + fi + +fi + + +OPT_WOLFSSL=no + +# Check whether --with-wolfssl was given. +if test ${with_wolfssl+y} +then : + withval=$with_wolfssl; + OPT_WOLFSSL=$withval + if test "x$withval" != "xno"; then + TLSCHOICE="${TLSCHOICE:+$TLSCHOICE, }wolfSSL" + fi + +fi + + +OPT_RUSTLS=no + +# Check whether --with-rustls was given. +if test ${with_rustls+y} +then : + withval=$with_rustls; + OPT_RUSTLS=$withval + if test "x$withval" != "xno"; then + TLSCHOICE="${TLSCHOICE:+$TLSCHOICE, }Rustls" + experimental="$experimental Rustls" + fi + +fi + + +OPT_APPLE_SECTRUST=no + +# Check whether --with-apple-sectrust was given. +if test ${with_apple_sectrust+y} +then : + withval=$with_apple_sectrust; + OPT_APPLE_SECTRUST=$withval + +fi + + +# Extract the first word of "perl", so it can be a program name with args. +set dummy perl; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PERL+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PERL in + [\\/]* | ?:[\\/]*) + ac_cv_path_PERL="$PERL" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/local/bin/perl:/usr/bin/:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PERL="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PERL=$ac_cv_path_PERL +if test -n "$PERL"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PERL" >&5 +printf "%s\n" "$PERL" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + + + if test -n "$PERL"; then + PERL_TRUE= + PERL_FALSE='#' +else + PERL_TRUE='#' + PERL_FALSE= +fi + + +TEST_NGHTTPX=nghttpx + +# Check whether --with-test-nghttpx was given. +if test ${with_test_nghttpx+y} +then : + withval=$with_test_nghttpx; TEST_NGHTTPX=$withval + if test "x$TEST_NGHTTPX" = "xno"; then + TEST_NGHTTPX="" + fi + +fi + + + +if test -x /usr/bin/caddy; then + CADDY=/usr/bin/caddy +elif test -x /usr/local/bin/caddy; then + CADDY=/usr/local/bin/caddy +elif test -x "`brew --prefix 2>/dev/null`/bin/caddy"; then + CADDY=`brew --prefix`/bin/caddy +fi + +# Check whether --with-test-caddy was given. +if test ${with_test_caddy+y} +then : + withval=$with_test_caddy; CADDY=$withval + if test "x$CADDY" = "xno"; then + CADDY="" + fi + +fi + + + +if test -x /usr/local/bin/h2o; then + H2O=/usr/local/bin/h2o +elif test -x /usr/bin/h2o; then + H2O=/usr/bin/h2o +elif test -x "`brew --prefix 2>/dev/null`/bin/h2o"; then + H2O=`brew --prefix`/bin/h2o +fi + +# Check whether --with-test-h2o was given. +if test ${with_test_h2o+y} +then : + withval=$with_test_h2o; H2O=$withval + if test "x$H2O" = "xno"; then + H2O="" + fi + +fi + + + +if test -x /usr/sbin/vsftpd; then + VSFTPD=/usr/sbin/vsftpd +elif test -x /usr/local/sbin/vsftpd; then + VSFTPD=/usr/local/sbin/vsftpd +elif test -x "`brew --prefix 2>/dev/null`/sbin/vsftpd"; then + VSFTPD=`brew --prefix`/sbin/vsftpd +fi + +# Check whether --with-test-vsftpd was given. +if test ${with_test_vsftpd+y} +then : + withval=$with_test_vsftpd; VSFTPD=$withval + if test "x$VSFTPD" = "xno"; then + VSFTPD="" + fi + +fi + + + +HTTPD_ENABLED="maybe" + +# Check whether --with-test-httpd was given. +if test ${with_test_httpd+y} +then : + withval=$with_test_httpd; request_httpd=$withval +else $as_nop + request_httpd=check +fi + +if test "x$request_httpd" = "xcheck" || test "x$request_httpd" = "xyes"; then + if test -x "/usr/sbin/apache2"; then + HTTPD="/usr/sbin/apache2" + # Extract the first word of "apxs", so it can be a program name with args. +set dummy apxs; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_APXS+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $APXS in + [\\/]* | ?:[\\/]*) + ac_cv_path_APXS="$APXS" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_APXS="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +APXS=$ac_cv_path_APXS +if test -n "$APXS"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $APXS" >&5 +printf "%s\n" "$APXS" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + + if test -z "$APXS"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: apache2-dev not installed, httpd tests disabled" >&5 +printf "%s\n" "$as_me: apache2-dev not installed, httpd tests disabled" >&6;} + HTTPD_ENABLED="no" + fi + else + # Extract the first word of "httpd", so it can be a program name with args. +set dummy httpd; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_HTTPD+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $HTTPD in + [\\/]* | ?:[\\/]*) + ac_cv_path_HTTPD="$HTTPD" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_HTTPD="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +HTTPD=$ac_cv_path_HTTPD +if test -n "$HTTPD"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $HTTPD" >&5 +printf "%s\n" "$HTTPD" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + + if test -z "$HTTPD"; then + # Extract the first word of "apache2", so it can be a program name with args. +set dummy apache2; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_HTTPD+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $HTTPD in + [\\/]* | ?:[\\/]*) + ac_cv_path_HTTPD="$HTTPD" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_HTTPD="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +HTTPD=$ac_cv_path_HTTPD +if test -n "$HTTPD"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $HTTPD" >&5 +printf "%s\n" "$HTTPD" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + + fi + # Extract the first word of "apxs", so it can be a program name with args. +set dummy apxs; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_APXS+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $APXS in + [\\/]* | ?:[\\/]*) + ac_cv_path_APXS="$APXS" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_APXS="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +APXS=$ac_cv_path_APXS +if test -n "$APXS"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $APXS" >&5 +printf "%s\n" "$APXS" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + + if test -z "$HTTPD"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: httpd/apache2 not in PATH, http tests disabled" >&5 +printf "%s\n" "$as_me: httpd/apache2 not in PATH, http tests disabled" >&6;} + HTTPD_ENABLED="no" + fi + if test -z "$APXS"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: apxs not in PATH, http tests disabled" >&5 +printf "%s\n" "$as_me: apxs not in PATH, http tests disabled" >&6;} + HTTPD_ENABLED="no" + fi + fi +elif test "x$request_httpd" != "xno"; then + HTTPD="${request_httpd}/bin/httpd" + APXS="${request_httpd}/bin/apxs" + if test ! -x "${HTTPD}"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: httpd not found as ${HTTPD}, http tests disabled" >&5 +printf "%s\n" "$as_me: httpd not found as ${HTTPD}, http tests disabled" >&6;} + HTTPD_ENABLED="no" + elif test ! -x "${APXS}"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: apxs not found as ${APXS}, http tests disabled" >&5 +printf "%s\n" "$as_me: apxs not found as ${APXS}, http tests disabled" >&6;} + HTTPD_ENABLED="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: using HTTPD=$HTTPD for tests" >&5 +printf "%s\n" "$as_me: using HTTPD=$HTTPD for tests" >&6;} + fi +fi +if test "$HTTPD_ENABLED" = "no"; then + HTTPD="" + APXS="" +fi + + + +DANTED_ENABLED="maybe" + +# Check whether --with-test-danted was given. +if test ${with_test_danted+y} +then : + withval=$with_test_danted; request_danted=$withval +else $as_nop + request_danted=check +fi + +if test "x$request_danted" = "xcheck" || test "x$request_danted" = "xyes"; then + if test -x "/usr/sbin/danted"; then + DANTED="/usr/sbin/danted" + else + # Extract the first word of "danted", so it can be a program name with args. +set dummy danted; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_DANTED+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $DANTED in + [\\/]* | ?:[\\/]*) + ac_cv_path_DANTED="$DANTED" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_DANTED="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +DANTED=$ac_cv_path_DANTED +if test -n "$DANTED"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $DANTED" >&5 +printf "%s\n" "$DANTED" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + + if test -z "$DANTED"; then + # Extract the first word of "danted", so it can be a program name with args. +set dummy danted; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_DANTED+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $DANTED in + [\\/]* | ?:[\\/]*) + ac_cv_path_DANTED="$DANTED" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_DANTED="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +DANTED=$ac_cv_path_DANTED +if test -n "$DANTED"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $DANTED" >&5 +printf "%s\n" "$DANTED" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + + fi + fi +elif test "x$request_danted" != "xno"; then + DANTED="${request_danted}" + if test ! -x "${DANTED}"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: danted not found as ${DANTED}, danted tests disabled" >&5 +printf "%s\n" "$as_me: danted not found as ${DANTED}, danted tests disabled" >&6;} + DANTED_ENABLED="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: using DANTED=$DANTED for tests" >&5 +printf "%s\n" "$as_me: using DANTED=$DANTED for tests" >&6;} + fi +fi +if test "$DANTED_ENABLED" = "no"; then + DANTED="" +fi + + +SSHD_ENABLED="maybe" + +# Check whether --with-test-sshd was given. +if test ${with_test_sshd+y} +then : + withval=$with_test_sshd; request_sshd=$withval +else $as_nop + request_sshd=check +fi + +if test "x$request_sshd" = "xcheck" || test "x$request_sshd" = "xyes"; then + if test -x "/usr/sbin/sshd"; then + SSHD="/usr/sbin/sshd" + else + # Extract the first word of "sshd", so it can be a program name with args. +set dummy sshd; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_SSHD+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $SSHD in + [\\/]* | ?:[\\/]*) + ac_cv_path_SSHD="$SSHD" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_SSHD="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +SSHD=$ac_cv_path_SSHD +if test -n "$SSHD"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $SSHD" >&5 +printf "%s\n" "$SSHD" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + + if test -z "$SSHD"; then + # Extract the first word of "sshd", so it can be a program name with args. +set dummy sshd; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_SSHD+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $SSHD in + [\\/]* | ?:[\\/]*) + ac_cv_path_SSHD="$SSHD" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_SSHD="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +SSHD=$ac_cv_path_SSHD +if test -n "$SSHD"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $SSHD" >&5 +printf "%s\n" "$SSHD" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + + fi + fi +elif test "x$request_sshd" != "xno"; then + SSHD="${request_sshd}" + if test ! -x "${SSHD}"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: sshd not found as ${SSHD}, sshd tests disabled" >&5 +printf "%s\n" "$as_me: sshd not found as ${SSHD}, sshd tests disabled" >&6;} + SSHD_ENABLED="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: using SSHD=$SSHD for tests" >&5 +printf "%s\n" "$as_me: using SSHD=$SSHD for tests" >&6;} + fi +fi +if test "$SSHD_ENABLED" = "no"; then + SSHD="" + SFTPD="" +else + if test -x "/usr/libexec/sftp-server"; then + SFTPD="/usr/libexec/sftp-server" + elif test -x "/usr/lib/openssh/sftp-server"; then + SFTPD="/usr/lib/openssh/sftp-server" + else + # Extract the first word of "sftp-server", so it can be a program name with args. +set dummy sftp-server; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_SFTPD+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $SFTPD in + [\\/]* | ?:[\\/]*) + ac_cv_path_SFTPD="$SFTPD" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_SFTPD="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +SFTPD=$ac_cv_path_SFTPD +if test -n "$SFTPD"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $SFTPD" >&5 +printf "%s\n" "$SFTPD" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + + if test -z "$SFTPD"; then + # Extract the first word of "sftp-server", so it can be a program name with args. +set dummy sftp-server; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_SFTPD+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $SFTPD in + [\\/]* | ?:[\\/]*) + ac_cv_path_SFTPD="$SFTPD" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_SFTPD="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +SFTPD=$ac_cv_path_SFTPD +if test -n "$SFTPD"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $SFTPD" >&5 +printf "%s\n" "$SFTPD" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + + fi + fi +fi + + + +if test -n "$TEST_NGHTTPX" && test "x$TEST_NGHTTPX" != "xnghttpx"; then + HTTPD_NGHTTPX="$TEST_NGHTTPX" +else + # Extract the first word of "nghttpx", so it can be a program name with args. +set dummy nghttpx; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_HTTPD_NGHTTPX+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $HTTPD_NGHTTPX in + [\\/]* | ?:[\\/]*) + ac_cv_path_HTTPD_NGHTTPX="$HTTPD_NGHTTPX" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_HTTPD_NGHTTPX="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +HTTPD_NGHTTPX=$ac_cv_path_HTTPD_NGHTTPX +if test -n "$HTTPD_NGHTTPX"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $HTTPD_NGHTTPX" >&5 +printf "%s\n" "$HTTPD_NGHTTPX" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi + + +if test -n "$TEST_CADDY"; then + CADDY="$TEST_CADDY" +else + # Extract the first word of "caddy", so it can be a program name with args. +set dummy caddy; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_CADDY+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $CADDY in + [\\/]* | ?:[\\/]*) + ac_cv_path_CADDY="$CADDY" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_CADDY="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +CADDY=$ac_cv_path_CADDY +if test -n "$CADDY"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CADDY" >&5 +printf "%s\n" "$CADDY" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi + + +if test -z "$TLSCHOICE"; then + if test "x$OPT_SSL" != "xno"; then + as_fn_error $? "select TLS backend(s) or disable TLS with --without-ssl. + +Select from these: + + --with-amissl + --with-gnutls + --with-mbedtls + --with-openssl (also works for AWS-LC, BoringSSL and LibreSSL) + --with-rustls + --with-schannel + --with-wolfssl +" "$LINENO" 5 + fi +fi + + +# Check whether --with-darwinssl was given. +if test ${with_darwinssl+y} +then : + withval=$with_darwinssl; as_fn_error $? "--with-darwin-ssl and --without-darwin-ssl no longer work!" "$LINENO" 5 +fi + + + + + + # Make sure we can run config.sub. +$SHELL "${ac_aux_dir}config.sub" sun4 >/dev/null 2>&1 || + as_fn_error $? "cannot run $SHELL ${ac_aux_dir}config.sub" "$LINENO" 5 + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking build system type" >&5 +printf %s "checking build system type... " >&6; } +if test ${ac_cv_build+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_build_alias=$build_alias +test "x$ac_build_alias" = x && + ac_build_alias=`$SHELL "${ac_aux_dir}config.guess"` +test "x$ac_build_alias" = x && + as_fn_error $? "cannot guess build type; you must specify one" "$LINENO" 5 +ac_cv_build=`$SHELL "${ac_aux_dir}config.sub" $ac_build_alias` || + as_fn_error $? "$SHELL ${ac_aux_dir}config.sub $ac_build_alias failed" "$LINENO" 5 + +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_build" >&5 +printf "%s\n" "$ac_cv_build" >&6; } +case $ac_cv_build in +*-*-*) ;; +*) as_fn_error $? "invalid value of canonical build" "$LINENO" 5;; +esac +build=$ac_cv_build +ac_save_IFS=$IFS; IFS='-' +set x $ac_cv_build +shift +build_cpu=$1 +build_vendor=$2 +shift; shift +# Remember, the first character of IFS is used to create $*, +# except with old shells: +build_os=$* +IFS=$ac_save_IFS +case $build_os in *\ *) build_os=`echo "$build_os" | sed 's/ /-/g'`;; esac + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking host system type" >&5 +printf %s "checking host system type... " >&6; } +if test ${ac_cv_host+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test "x$host_alias" = x; then + ac_cv_host=$ac_cv_build +else + ac_cv_host=`$SHELL "${ac_aux_dir}config.sub" $host_alias` || + as_fn_error $? "$SHELL ${ac_aux_dir}config.sub $host_alias failed" "$LINENO" 5 +fi + +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_host" >&5 +printf "%s\n" "$ac_cv_host" >&6; } +case $ac_cv_host in +*-*-*) ;; +*) as_fn_error $? "invalid value of canonical host" "$LINENO" 5;; +esac +host=$ac_cv_host +ac_save_IFS=$IFS; IFS='-' +set x $ac_cv_host +shift +host_cpu=$1 +host_vendor=$2 +shift; shift +# Remember, the first character of IFS is used to create $*, +# except with old shells: +host_os=$* +IFS=$ac_save_IFS +case $host_os in *\ *) host_os=`echo "$host_os" | sed 's/ /-/g'`;; esac + + + +printf "%s\n" "#define CURL_OS \"${host}\"" >>confdefs.h + + +AR_FLAGS=cr + + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5 +printf %s "checking for grep that handles long lines and -e... " >&6; } +if test ${ac_cv_path_GREP+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -z "$GREP"; then + ac_path_GREP_found=false + # Loop through the user's path and test for each of PROGNAME-LIST + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_prog in grep ggrep + do + for ac_exec_ext in '' $ac_executable_extensions; do + ac_path_GREP="$as_dir$ac_prog$ac_exec_ext" + as_fn_executable_p "$ac_path_GREP" || continue +# Check for GNU ac_path_GREP and select it if it is found. + # Check for GNU $ac_path_GREP +case `"$ac_path_GREP" --version 2>&1` in +*GNU*) + ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_found=:;; +*) + ac_count=0 + printf %s 0123456789 >"conftest.in" + while : + do + cat "conftest.in" "conftest.in" >"conftest.tmp" + mv "conftest.tmp" "conftest.in" + cp "conftest.in" "conftest.nl" + printf "%s\n" 'GREP' >> "conftest.nl" + "$ac_path_GREP" -e 'GREP$' -e '-(cannot match)-' < "conftest.nl" >"conftest.out" 2>/dev/null || break + diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break + as_fn_arith $ac_count + 1 && ac_count=$as_val + if test $ac_count -gt ${ac_path_GREP_max-0}; then + # Best one so far, save it but keep looking for a better one + ac_cv_path_GREP="$ac_path_GREP" + ac_path_GREP_max=$ac_count + fi + # 10*(2^10) chars as input seems more than enough + test $ac_count -gt 10 && break + done + rm -f conftest.in conftest.tmp conftest.nl conftest.out;; +esac + + $ac_path_GREP_found && break 3 + done + done + done +IFS=$as_save_IFS + if test -z "$ac_cv_path_GREP"; then + as_fn_error $? "no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 + fi +else + ac_cv_path_GREP=$GREP +fi + +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_GREP" >&5 +printf "%s\n" "$ac_cv_path_GREP" >&6; } + GREP="$ac_cv_path_GREP" + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for egrep" >&5 +printf %s "checking for egrep... " >&6; } +if test ${ac_cv_path_EGREP+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if echo a | $GREP -E '(a|b)' >/dev/null 2>&1 + then ac_cv_path_EGREP="$GREP -E" + else + if test -z "$EGREP"; then + ac_path_EGREP_found=false + # Loop through the user's path and test for each of PROGNAME-LIST + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_prog in egrep + do + for ac_exec_ext in '' $ac_executable_extensions; do + ac_path_EGREP="$as_dir$ac_prog$ac_exec_ext" + as_fn_executable_p "$ac_path_EGREP" || continue +# Check for GNU ac_path_EGREP and select it if it is found. + # Check for GNU $ac_path_EGREP +case `"$ac_path_EGREP" --version 2>&1` in +*GNU*) + ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_found=:;; +*) + ac_count=0 + printf %s 0123456789 >"conftest.in" + while : + do + cat "conftest.in" "conftest.in" >"conftest.tmp" + mv "conftest.tmp" "conftest.in" + cp "conftest.in" "conftest.nl" + printf "%s\n" 'EGREP' >> "conftest.nl" + "$ac_path_EGREP" 'EGREP$' < "conftest.nl" >"conftest.out" 2>/dev/null || break + diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break + as_fn_arith $ac_count + 1 && ac_count=$as_val + if test $ac_count -gt ${ac_path_EGREP_max-0}; then + # Best one so far, save it but keep looking for a better one + ac_cv_path_EGREP="$ac_path_EGREP" + ac_path_EGREP_max=$ac_count + fi + # 10*(2^10) chars as input seems more than enough + test $ac_count -gt 10 && break + done + rm -f conftest.in conftest.tmp conftest.nl conftest.out;; +esac + + $ac_path_EGREP_found && break 3 + done + done + done +IFS=$as_save_IFS + if test -z "$ac_cv_path_EGREP"; then + as_fn_error $? "no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 + fi +else + ac_cv_path_EGREP=$EGREP +fi + + fi +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_EGREP" >&5 +printf "%s\n" "$ac_cv_path_EGREP" >&6; } + EGREP="$ac_cv_path_EGREP" + + + + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if OS is AIX (to define _ALL_SOURCE)" >&5 +printf %s "checking if OS is AIX (to define _ALL_SOURCE)... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +#ifdef _AIX + yes_this_is_aix +#endif + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "yes_this_is_aix" >/dev/null 2>&1 +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + printf "%s\n" "#define _ALL_SOURCE 1" >>confdefs.h + + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +fi +rm -rf conftest* + + + + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if _THREAD_SAFE is already defined" >&5 +printf %s "checking if _THREAD_SAFE is already defined... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + +int main(void) +{ + + #ifdef _THREAD_SAFE + int dummy = 1; + (void)dummy; + #else + #error force compilation error + #endif + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tmp_thread_safe_initially_defined="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tmp_thread_safe_initially_defined="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + + if test "$tmp_thread_safe_initially_defined" = "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if _THREAD_SAFE is actually needed" >&5 +printf %s "checking if _THREAD_SAFE is actually needed... " >&6; } + + case $host_os in + aix[123].* | aix4.[012].*) + tmp_need_thread_safe="no" + ;; + aix*) + tmp_need_thread_safe="yes" + ;; + *) + tmp_need_thread_safe="no" + ;; + esac + + if test "$tmp_need_thread_safe" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if _THREAD_SAFE is onwards defined" >&5 +printf %s "checking if _THREAD_SAFE is onwards defined... " >&6; } + if test "$tmp_thread_safe_initially_defined" = "yes" || + test "$tmp_need_thread_safe" = "yes"; then + + +printf "%s\n" "#define NEED_THREAD_SAFE 1" >>confdefs.h + +cat >>confdefs.h <<_EOF +#ifndef _THREAD_SAFE +# define _THREAD_SAFE +#endif +_EOF + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + fi + + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if _REENTRANT is already defined" >&5 +printf %s "checking if _REENTRANT is already defined... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + +int main(void) +{ + + #ifdef _REENTRANT + int dummy = 1; + (void)dummy; + #else + #error force compilation error + #endif + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tmp_reentrant_initially_defined="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tmp_reentrant_initially_defined="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + + if test "$tmp_reentrant_initially_defined" = "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if _REENTRANT is actually needed" >&5 +printf %s "checking if _REENTRANT is actually needed... " >&6; } + + case $host_os in + solaris*) + tmp_need_reentrant="yes" + ;; + *) + tmp_need_reentrant="no" + ;; + esac + + if test "$tmp_need_reentrant" = "no"; then + + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #include + +int main(void) +{ + + if(0 != errno) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + tmp_errno="yes" + +else $as_nop + + tmp_errno="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + if test "$tmp_errno" = "yes"; then + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #include + +int main(void) +{ + + #ifdef errno + int dummy = 1; + (void)dummy; + #else + #error force compilation error + #endif + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + tmp_errno="errno_macro_defined" + +else $as_nop + + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #define _REENTRANT + #include + +int main(void) +{ + + #ifdef errno + int dummy = 1; + (void)dummy; + #else + #error force compilation error + #endif + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + tmp_errno="errno_macro_needs_reentrant" + tmp_need_reentrant="yes" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + fi + if test "$tmp_need_reentrant" = "no"; then + + if test "$tmp_need_reentrant" = "no"; then + + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#define gmtime_r innocuous_gmtime_r +#ifdef __STDC__ +# include +#else +# include +#endif +#undef gmtime_r +#ifdef __cplusplus +extern "C" +#endif +char gmtime_r (); +#if defined __stub_gmtime_r || defined __stub___gmtime_r +#error force compilation error +#endif + +int main(void) +{ +return gmtime_r (); + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + tmp_gmtime_r="yes" + +else $as_nop + + tmp_gmtime_r="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + if test "$tmp_gmtime_r" = "yes"; then + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #include + #include + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "gmtime_r" >/dev/null 2>&1 +then : + + tmp_gmtime_r="proto_declared" + +else $as_nop + + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #define _REENTRANT + #include + #include + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "gmtime_r" >/dev/null 2>&1 +then : + + tmp_gmtime_r="proto_needs_reentrant" + tmp_need_reentrant="yes" + +fi +rm -rf conftest* + + +fi +rm -rf conftest* + + fi + + fi + if test "$tmp_need_reentrant" = "no"; then + + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#define localtime_r innocuous_localtime_r +#ifdef __STDC__ +# include +#else +# include +#endif +#undef localtime_r +#ifdef __cplusplus +extern "C" +#endif +char localtime_r (); +#if defined __stub_localtime_r || defined __stub___localtime_r +#error force compilation error +#endif + +int main(void) +{ +return localtime_r (); + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + tmp_localtime_r="yes" + +else $as_nop + + tmp_localtime_r="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + if test "$tmp_localtime_r" = "yes"; then + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #include + #include + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "localtime_r" >/dev/null 2>&1 +then : + + tmp_localtime_r="proto_declared" + +else $as_nop + + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #define _REENTRANT + #include + #include + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "localtime_r" >/dev/null 2>&1 +then : + + tmp_localtime_r="proto_needs_reentrant" + tmp_need_reentrant="yes" + +fi +rm -rf conftest* + + +fi +rm -rf conftest* + + fi + + fi + if test "$tmp_need_reentrant" = "no"; then + + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#define strerror_r innocuous_strerror_r +#ifdef __STDC__ +# include +#else +# include +#endif +#undef strerror_r +#ifdef __cplusplus +extern "C" +#endif +char strerror_r (); +#if defined __stub_strerror_r || defined __stub___strerror_r +#error force compilation error +#endif + +int main(void) +{ +return strerror_r (); + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + tmp_strerror_r="yes" + +else $as_nop + + tmp_strerror_r="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + if test "$tmp_strerror_r" = "yes"; then + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #include + #include + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "strerror_r" >/dev/null 2>&1 +then : + + tmp_strerror_r="proto_declared" + +else $as_nop + + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #define _REENTRANT + #include + #include + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "strerror_r" >/dev/null 2>&1 +then : + + tmp_strerror_r="proto_needs_reentrant" + tmp_need_reentrant="yes" + +fi +rm -rf conftest* + + +fi +rm -rf conftest* + + fi + + fi + if test "$tmp_need_reentrant" = "no"; then + + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#define gethostbyname_r innocuous_gethostbyname_r +#ifdef __STDC__ +# include +#else +# include +#endif +#undef gethostbyname_r +#ifdef __cplusplus +extern "C" +#endif +char gethostbyname_r (); +#if defined __stub_gethostbyname_r || defined __stub___gethostbyname_r +#error force compilation error +#endif + +int main(void) +{ +return gethostbyname_r (); + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + tmp_gethostbyname_r="yes" + +else $as_nop + + tmp_gethostbyname_r="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + if test "$tmp_gethostbyname_r" = "yes"; then + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #include + #include + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "gethostbyname_r" >/dev/null 2>&1 +then : + + tmp_gethostbyname_r="proto_declared" + +else $as_nop + + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #define _REENTRANT + #include + #include + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "gethostbyname_r" >/dev/null 2>&1 +then : + + tmp_gethostbyname_r="proto_needs_reentrant" + tmp_need_reentrant="yes" + +fi +rm -rf conftest* + + +fi +rm -rf conftest* + + fi + + fi + if test "$tmp_need_reentrant" = "no"; then + + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#define getprotobyname_r innocuous_getprotobyname_r +#ifdef __STDC__ +# include +#else +# include +#endif +#undef getprotobyname_r +#ifdef __cplusplus +extern "C" +#endif +char getprotobyname_r (); +#if defined __stub_getprotobyname_r || defined __stub___getprotobyname_r +#error force compilation error +#endif + +int main(void) +{ +return getprotobyname_r (); + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + tmp_getprotobyname_r="yes" + +else $as_nop + + tmp_getprotobyname_r="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + if test "$tmp_getprotobyname_r" = "yes"; then + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #include + #include + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "getprotobyname_r" >/dev/null 2>&1 +then : + + tmp_getprotobyname_r="proto_declared" + +else $as_nop + + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #define _REENTRANT + #include + #include + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "getprotobyname_r" >/dev/null 2>&1 +then : + + tmp_getprotobyname_r="proto_needs_reentrant" + tmp_need_reentrant="yes" + +fi +rm -rf conftest* + + +fi +rm -rf conftest* + + fi + + fi + + fi + if test "$tmp_need_reentrant" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if _REENTRANT is onwards defined" >&5 +printf %s "checking if _REENTRANT is onwards defined... " >&6; } + if test "$tmp_reentrant_initially_defined" = "yes" || + test "$tmp_need_reentrant" = "yes"; then + + +printf "%s\n" "#define NEED_REENTRANT 1" >>confdefs.h + +cat >>confdefs.h <<_EOF +#ifndef _REENTRANT +# define _REENTRANT +#endif +_EOF + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + fi + + +# Check whether --enable-largefile was given. +if test ${enable_largefile+y} +then : + enableval=$enable_largefile; +fi + +if test "$enable_largefile" != no; then + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for special C compiler options needed for large files" >&5 +printf %s "checking for special C compiler options needed for large files... " >&6; } +if test ${ac_cv_sys_largefile_CC+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_cv_sys_largefile_CC=no + if test "$GCC" != yes; then + ac_save_CC=$CC + while :; do + # IRIX 6.2 and later do not support large files by default, + # so use the C compiler's -n32 option if that helps. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include + /* Check that off_t can represent 2**63 - 1 correctly. + We can't simply define LARGE_OFF_T to be 9223372036854775807, + since some C++ compilers masquerading as C compilers + incorrectly reject 9223372036854775807. */ +#define LARGE_OFF_T (((off_t) 1 << 31 << 31) - 1 + ((off_t) 1 << 31 << 31)) + int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721 + && LARGE_OFF_T % 2147483647 == 1) + ? 1 : -1]; +int main(void) +{ + + return 0; +} +_ACEOF + if ac_fn_c_try_compile "$LINENO" +then : + break +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam + CC="$CC -n32" + if ac_fn_c_try_compile "$LINENO" +then : + ac_cv_sys_largefile_CC=' -n32'; break +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam + break + done + CC=$ac_save_CC + rm -f conftest.$ac_ext + fi +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sys_largefile_CC" >&5 +printf "%s\n" "$ac_cv_sys_largefile_CC" >&6; } + if test "$ac_cv_sys_largefile_CC" != no; then + CC=$CC$ac_cv_sys_largefile_CC + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for _FILE_OFFSET_BITS value needed for large files" >&5 +printf %s "checking for _FILE_OFFSET_BITS value needed for large files... " >&6; } +if test ${ac_cv_sys_file_offset_bits+y} +then : + printf %s "(cached) " >&6 +else $as_nop + while :; do + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include + /* Check that off_t can represent 2**63 - 1 correctly. + We can't simply define LARGE_OFF_T to be 9223372036854775807, + since some C++ compilers masquerading as C compilers + incorrectly reject 9223372036854775807. */ +#define LARGE_OFF_T (((off_t) 1 << 31 << 31) - 1 + ((off_t) 1 << 31 << 31)) + int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721 + && LARGE_OFF_T % 2147483647 == 1) + ? 1 : -1]; +int main(void) +{ + + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + ac_cv_sys_file_offset_bits=no; break +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#define _FILE_OFFSET_BITS 64 +#include + /* Check that off_t can represent 2**63 - 1 correctly. + We can't simply define LARGE_OFF_T to be 9223372036854775807, + since some C++ compilers masquerading as C compilers + incorrectly reject 9223372036854775807. */ +#define LARGE_OFF_T (((off_t) 1 << 31 << 31) - 1 + ((off_t) 1 << 31 << 31)) + int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721 + && LARGE_OFF_T % 2147483647 == 1) + ? 1 : -1]; +int main(void) +{ + + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + ac_cv_sys_file_offset_bits=64; break +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + ac_cv_sys_file_offset_bits=unknown + break +done +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sys_file_offset_bits" >&5 +printf "%s\n" "$ac_cv_sys_file_offset_bits" >&6; } +case $ac_cv_sys_file_offset_bits in #( + no | unknown) ;; + *) +printf "%s\n" "#define _FILE_OFFSET_BITS $ac_cv_sys_file_offset_bits" >>confdefs.h +;; +esac +rm -rf conftest* + if test $ac_cv_sys_file_offset_bits = unknown; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for _LARGE_FILES value needed for large files" >&5 +printf %s "checking for _LARGE_FILES value needed for large files... " >&6; } +if test ${ac_cv_sys_large_files+y} +then : + printf %s "(cached) " >&6 +else $as_nop + while :; do + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include + /* Check that off_t can represent 2**63 - 1 correctly. + We can't simply define LARGE_OFF_T to be 9223372036854775807, + since some C++ compilers masquerading as C compilers + incorrectly reject 9223372036854775807. */ +#define LARGE_OFF_T (((off_t) 1 << 31 << 31) - 1 + ((off_t) 1 << 31 << 31)) + int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721 + && LARGE_OFF_T % 2147483647 == 1) + ? 1 : -1]; +int main(void) +{ + + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + ac_cv_sys_large_files=no; break +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#define _LARGE_FILES 1 +#include + /* Check that off_t can represent 2**63 - 1 correctly. + We can't simply define LARGE_OFF_T to be 9223372036854775807, + since some C++ compilers masquerading as C compilers + incorrectly reject 9223372036854775807. */ +#define LARGE_OFF_T (((off_t) 1 << 31 << 31) - 1 + ((off_t) 1 << 31 << 31)) + int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721 + && LARGE_OFF_T % 2147483647 == 1) + ? 1 : -1]; +int main(void) +{ + + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + ac_cv_sys_large_files=1; break +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + ac_cv_sys_large_files=unknown + break +done +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sys_large_files" >&5 +printf "%s\n" "$ac_cv_sys_large_files" >&6; } +case $ac_cv_sys_large_files in #( + no | unknown) ;; + *) +printf "%s\n" "#define _LARGE_FILES $ac_cv_sys_large_files" >>confdefs.h +;; +esac +rm -rf conftest* + fi +fi + + +case `pwd` in + *\ * | *\ *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: Libtool does not cope well with whitespace in \`pwd\`" >&5 +printf "%s\n" "$as_me: WARNING: Libtool does not cope well with whitespace in \`pwd\`" >&2;} ;; +esac + + + +macro_version='2.4.7' +macro_revision='2.4.7' + + + + + + + + + + + + + + +ltmain=$ac_aux_dir/ltmain.sh + +# Backslashify metacharacters that are still active within +# double-quoted strings. +sed_quote_subst='s/\(["`$\\]\)/\\\1/g' + +# Same as above, but do not quote variable references. +double_quote_subst='s/\(["`\\]\)/\\\1/g' + +# Sed substitution to delay expansion of an escaped shell variable in a +# double_quote_subst'ed string. +delay_variable_subst='s/\\\\\\\\\\\$/\\\\\\$/g' + +# Sed substitution to delay expansion of an escaped single quote. +delay_single_quote_subst='s/'\''/'\'\\\\\\\'\''/g' + +# Sed substitution to avoid accidental globbing in evaled expressions +no_glob_subst='s/\*/\\\*/g' + +ECHO='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' +ECHO=$ECHO$ECHO$ECHO$ECHO$ECHO +ECHO=$ECHO$ECHO$ECHO$ECHO$ECHO$ECHO + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to print strings" >&5 +printf %s "checking how to print strings... " >&6; } +# Test print first, because it will be a builtin if present. +if test "X`( print -r -- -n ) 2>/dev/null`" = X-n && \ + test "X`print -r -- $ECHO 2>/dev/null`" = "X$ECHO"; then + ECHO='print -r --' +elif test "X`printf %s $ECHO 2>/dev/null`" = "X$ECHO"; then + ECHO='printf %s\n' +else + # Use this function as a fallback that always works. + func_fallback_echo () + { + eval 'cat <<_LTECHO_EOF +$1 +_LTECHO_EOF' + } + ECHO='func_fallback_echo' +fi + +# func_echo_all arg... +# Invoke $ECHO with all args, space-separated. +func_echo_all () +{ + $ECHO "" +} + +case $ECHO in + printf*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: printf" >&5 +printf "%s\n" "printf" >&6; } ;; + print*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: print -r" >&5 +printf "%s\n" "print -r" >&6; } ;; + *) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: cat" >&5 +printf "%s\n" "cat" >&6; } ;; +esac + + + + + + + + + + + + + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for a sed that does not truncate output" >&5 +printf %s "checking for a sed that does not truncate output... " >&6; } +if test ${ac_cv_path_SED+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_script=s/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa/bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb/ + for ac_i in 1 2 3 4 5 6 7; do + ac_script="$ac_script$as_nl$ac_script" + done + echo "$ac_script" 2>/dev/null | sed 99q >conftest.sed + { ac_script=; unset ac_script;} + if test -z "$SED"; then + ac_path_SED_found=false + # Loop through the user's path and test for each of PROGNAME-LIST + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_prog in sed gsed + do + for ac_exec_ext in '' $ac_executable_extensions; do + ac_path_SED="$as_dir$ac_prog$ac_exec_ext" + as_fn_executable_p "$ac_path_SED" || continue +# Check for GNU ac_path_SED and select it if it is found. + # Check for GNU $ac_path_SED +case `"$ac_path_SED" --version 2>&1` in +*GNU*) + ac_cv_path_SED="$ac_path_SED" ac_path_SED_found=:;; +*) + ac_count=0 + printf %s 0123456789 >"conftest.in" + while : + do + cat "conftest.in" "conftest.in" >"conftest.tmp" + mv "conftest.tmp" "conftest.in" + cp "conftest.in" "conftest.nl" + printf "%s\n" '' >> "conftest.nl" + "$ac_path_SED" -f conftest.sed < "conftest.nl" >"conftest.out" 2>/dev/null || break + diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break + as_fn_arith $ac_count + 1 && ac_count=$as_val + if test $ac_count -gt ${ac_path_SED_max-0}; then + # Best one so far, save it but keep looking for a better one + ac_cv_path_SED="$ac_path_SED" + ac_path_SED_max=$ac_count + fi + # 10*(2^10) chars as input seems more than enough + test $ac_count -gt 10 && break + done + rm -f conftest.in conftest.tmp conftest.nl conftest.out;; +esac + + $ac_path_SED_found && break 3 + done + done + done +IFS=$as_save_IFS + if test -z "$ac_cv_path_SED"; then + as_fn_error $? "no acceptable sed could be found in \$PATH" "$LINENO" 5 + fi +else + ac_cv_path_SED=$SED +fi + +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_SED" >&5 +printf "%s\n" "$ac_cv_path_SED" >&6; } + SED="$ac_cv_path_SED" + rm -f conftest.sed + +test -z "$SED" && SED=sed +Xsed="$SED -e 1s/^X//" + + + + + + + + + + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for fgrep" >&5 +printf %s "checking for fgrep... " >&6; } +if test ${ac_cv_path_FGREP+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if echo 'ab*c' | $GREP -F 'ab*c' >/dev/null 2>&1 + then ac_cv_path_FGREP="$GREP -F" + else + if test -z "$FGREP"; then + ac_path_FGREP_found=false + # Loop through the user's path and test for each of PROGNAME-LIST + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_prog in fgrep + do + for ac_exec_ext in '' $ac_executable_extensions; do + ac_path_FGREP="$as_dir$ac_prog$ac_exec_ext" + as_fn_executable_p "$ac_path_FGREP" || continue +# Check for GNU ac_path_FGREP and select it if it is found. + # Check for GNU $ac_path_FGREP +case `"$ac_path_FGREP" --version 2>&1` in +*GNU*) + ac_cv_path_FGREP="$ac_path_FGREP" ac_path_FGREP_found=:;; +*) + ac_count=0 + printf %s 0123456789 >"conftest.in" + while : + do + cat "conftest.in" "conftest.in" >"conftest.tmp" + mv "conftest.tmp" "conftest.in" + cp "conftest.in" "conftest.nl" + printf "%s\n" 'FGREP' >> "conftest.nl" + "$ac_path_FGREP" FGREP < "conftest.nl" >"conftest.out" 2>/dev/null || break + diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break + as_fn_arith $ac_count + 1 && ac_count=$as_val + if test $ac_count -gt ${ac_path_FGREP_max-0}; then + # Best one so far, save it but keep looking for a better one + ac_cv_path_FGREP="$ac_path_FGREP" + ac_path_FGREP_max=$ac_count + fi + # 10*(2^10) chars as input seems more than enough + test $ac_count -gt 10 && break + done + rm -f conftest.in conftest.tmp conftest.nl conftest.out;; +esac + + $ac_path_FGREP_found && break 3 + done + done + done +IFS=$as_save_IFS + if test -z "$ac_cv_path_FGREP"; then + as_fn_error $? "no acceptable fgrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 + fi +else + ac_cv_path_FGREP=$FGREP +fi + + fi +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_FGREP" >&5 +printf "%s\n" "$ac_cv_path_FGREP" >&6; } + FGREP="$ac_cv_path_FGREP" + + +test -z "$GREP" && GREP=grep + + + + + + + + + + + + + + + + + + + +# Check whether --with-gnu-ld was given. +if test ${with_gnu_ld+y} +then : + withval=$with_gnu_ld; test no = "$withval" || with_gnu_ld=yes +else $as_nop + with_gnu_ld=no +fi + +ac_prog=ld +if test yes = "$GCC"; then + # Check if gcc -print-prog-name=ld gives a path. + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for ld used by $CC" >&5 +printf %s "checking for ld used by $CC... " >&6; } + case $host in + *-*-mingw*) + # gcc leaves a trailing carriage return, which upsets mingw + ac_prog=`($CC -print-prog-name=ld) 2>&5 | tr -d '\015'` ;; + *) + ac_prog=`($CC -print-prog-name=ld) 2>&5` ;; + esac + case $ac_prog in + # Accept absolute paths. + [\\/]* | ?:[\\/]*) + re_direlt='/[^/][^/]*/\.\./' + # Canonicalize the pathname of ld + ac_prog=`$ECHO "$ac_prog"| $SED 's%\\\\%/%g'` + while $ECHO "$ac_prog" | $GREP "$re_direlt" > /dev/null 2>&1; do + ac_prog=`$ECHO $ac_prog| $SED "s%$re_direlt%/%"` + done + test -z "$LD" && LD=$ac_prog + ;; + "") + # If it fails, then pretend we aren't using GCC. + ac_prog=ld + ;; + *) + # If it is relative, then search for the first ld in PATH. + with_gnu_ld=unknown + ;; + esac +elif test yes = "$with_gnu_ld"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for GNU ld" >&5 +printf %s "checking for GNU ld... " >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for non-GNU ld" >&5 +printf %s "checking for non-GNU ld... " >&6; } +fi +if test ${lt_cv_path_LD+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -z "$LD"; then + lt_save_ifs=$IFS; IFS=$PATH_SEPARATOR + for ac_dir in $PATH; do + IFS=$lt_save_ifs + test -z "$ac_dir" && ac_dir=. + if test -f "$ac_dir/$ac_prog" || test -f "$ac_dir/$ac_prog$ac_exeext"; then + lt_cv_path_LD=$ac_dir/$ac_prog + # Check to see if the program is GNU ld. I'd rather use --version, + # but apparently some variants of GNU ld only accept -v. + # Break only if it was the GNU/non-GNU ld that we prefer. + case `"$lt_cv_path_LD" -v 2>&1 &5 +printf "%s\n" "$LD" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi +test -z "$LD" && as_fn_error $? "no acceptable ld found in \$PATH" "$LINENO" 5 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if the linker ($LD) is GNU ld" >&5 +printf %s "checking if the linker ($LD) is GNU ld... " >&6; } +if test ${lt_cv_prog_gnu_ld+y} +then : + printf %s "(cached) " >&6 +else $as_nop + # I'd rather use --version here, but apparently some GNU lds only accept -v. +case `$LD -v 2>&1 &5 +printf "%s\n" "$lt_cv_prog_gnu_ld" >&6; } +with_gnu_ld=$lt_cv_prog_gnu_ld + + + + + + + + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for BSD- or MS-compatible name lister (nm)" >&5 +printf %s "checking for BSD- or MS-compatible name lister (nm)... " >&6; } +if test ${lt_cv_path_NM+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$NM"; then + # Let the user override the test. + lt_cv_path_NM=$NM +else + lt_nm_to_check=${ac_tool_prefix}nm + if test -n "$ac_tool_prefix" && test "$build" = "$host"; then + lt_nm_to_check="$lt_nm_to_check nm" + fi + for lt_tmp_nm in $lt_nm_to_check; do + lt_save_ifs=$IFS; IFS=$PATH_SEPARATOR + for ac_dir in $PATH /usr/ccs/bin/elf /usr/ccs/bin /usr/ucb /bin; do + IFS=$lt_save_ifs + test -z "$ac_dir" && ac_dir=. + tmp_nm=$ac_dir/$lt_tmp_nm + if test -f "$tmp_nm" || test -f "$tmp_nm$ac_exeext"; then + # Check to see if the nm accepts a BSD-compat flag. + # Adding the 'sed 1q' prevents false positives on HP-UX, which says: + # nm: unknown option "B" ignored + # Tru64's nm complains that /dev/null is an invalid object file + # MSYS converts /dev/null to NUL, MinGW nm treats NUL as empty + case $build_os in + mingw*) lt_bad_file=conftest.nm/nofile ;; + *) lt_bad_file=/dev/null ;; + esac + case `"$tmp_nm" -B $lt_bad_file 2>&1 | $SED '1q'` in + *$lt_bad_file* | *'Invalid file or object type'*) + lt_cv_path_NM="$tmp_nm -B" + break 2 + ;; + *) + case `"$tmp_nm" -p /dev/null 2>&1 | $SED '1q'` in + */dev/null*) + lt_cv_path_NM="$tmp_nm -p" + break 2 + ;; + *) + lt_cv_path_NM=${lt_cv_path_NM="$tmp_nm"} # keep the first match, but + continue # so that we can try to find one that supports BSD flags + ;; + esac + ;; + esac + fi + done + IFS=$lt_save_ifs + done + : ${lt_cv_path_NM=no} +fi +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_path_NM" >&5 +printf "%s\n" "$lt_cv_path_NM" >&6; } +if test no != "$lt_cv_path_NM"; then + NM=$lt_cv_path_NM +else + # Didn't find any BSD compatible name lister, look for dumpbin. + if test -n "$DUMPBIN"; then : + # Let the user override the test. + else + if test -n "$ac_tool_prefix"; then + for ac_prog in dumpbin "link -dump" + do + # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. +set dummy $ac_tool_prefix$ac_prog; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_DUMPBIN+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$DUMPBIN"; then + ac_cv_prog_DUMPBIN="$DUMPBIN" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_DUMPBIN="$ac_tool_prefix$ac_prog" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +DUMPBIN=$ac_cv_prog_DUMPBIN +if test -n "$DUMPBIN"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $DUMPBIN" >&5 +printf "%s\n" "$DUMPBIN" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + + test -n "$DUMPBIN" && break + done +fi +if test -z "$DUMPBIN"; then + ac_ct_DUMPBIN=$DUMPBIN + for ac_prog in dumpbin "link -dump" +do + # Extract the first word of "$ac_prog", so it can be a program name with args. +set dummy $ac_prog; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_ac_ct_DUMPBIN+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$ac_ct_DUMPBIN"; then + ac_cv_prog_ac_ct_DUMPBIN="$ac_ct_DUMPBIN" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_DUMPBIN="$ac_prog" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_DUMPBIN=$ac_cv_prog_ac_ct_DUMPBIN +if test -n "$ac_ct_DUMPBIN"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_DUMPBIN" >&5 +printf "%s\n" "$ac_ct_DUMPBIN" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + + test -n "$ac_ct_DUMPBIN" && break +done + + if test "x$ac_ct_DUMPBIN" = x; then + DUMPBIN=":" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + DUMPBIN=$ac_ct_DUMPBIN + fi +fi + + case `$DUMPBIN -symbols -headers /dev/null 2>&1 | $SED '1q'` in + *COFF*) + DUMPBIN="$DUMPBIN -symbols -headers" + ;; + *) + DUMPBIN=: + ;; + esac + fi + + if test : != "$DUMPBIN"; then + NM=$DUMPBIN + fi +fi +test -z "$NM" && NM=nm + + + + + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking the name lister ($NM) interface" >&5 +printf %s "checking the name lister ($NM) interface... " >&6; } +if test ${lt_cv_nm_interface+y} +then : + printf %s "(cached) " >&6 +else $as_nop + lt_cv_nm_interface="BSD nm" + echo "int some_variable = 0;" > conftest.$ac_ext + (eval echo "\"\$as_me:$LINENO: $ac_compile\"" >&5) + (eval "$ac_compile" 2>conftest.err) + cat conftest.err >&5 + (eval echo "\"\$as_me:$LINENO: $NM \\\"conftest.$ac_objext\\\"\"" >&5) + (eval "$NM \"conftest.$ac_objext\"" 2>conftest.err > conftest.out) + cat conftest.err >&5 + (eval echo "\"\$as_me:$LINENO: output\"" >&5) + cat conftest.out >&5 + if $GREP 'External.*some_variable' conftest.out > /dev/null; then + lt_cv_nm_interface="MS dumpbin" + fi + rm -f conftest* +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_nm_interface" >&5 +printf "%s\n" "$lt_cv_nm_interface" >&6; } + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether ln -s works" >&5 +printf %s "checking whether ln -s works... " >&6; } +LN_S=$as_ln_s +if test "$LN_S" = "ln -s"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no, using $LN_S" >&5 +printf "%s\n" "no, using $LN_S" >&6; } +fi + +# find the maximum length of command line arguments +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking the maximum length of command line arguments" >&5 +printf %s "checking the maximum length of command line arguments... " >&6; } +if test ${lt_cv_sys_max_cmd_len+y} +then : + printf %s "(cached) " >&6 +else $as_nop + i=0 + teststring=ABCD + + case $build_os in + msdosdjgpp*) + # On DJGPP, this test can blow up pretty badly due to problems in libc + # (any single argument exceeding 2000 bytes causes a buffer overrun + # during glob expansion). Even if it were fixed, the result of this + # check would be larger than it should be. + lt_cv_sys_max_cmd_len=12288; # 12K is about right + ;; + + gnu*) + # Under GNU Hurd, this test is not required because there is + # no limit to the length of command line arguments. + # Libtool will interpret -1 as no limit whatsoever + lt_cv_sys_max_cmd_len=-1; + ;; + + cygwin* | mingw* | cegcc*) + # On Win9x/ME, this test blows up -- it succeeds, but takes + # about 5 minutes as the teststring grows exponentially. + # Worse, since 9x/ME are not pre-emptively multitasking, + # you end up with a "frozen" computer, even though with patience + # the test eventually succeeds (with a max line length of 256k). + # Instead, let's just punt: use the minimum linelength reported by + # all of the supported platforms: 8192 (on NT/2K/XP). + lt_cv_sys_max_cmd_len=8192; + ;; + + mint*) + # On MiNT this can take a long time and run out of memory. + lt_cv_sys_max_cmd_len=8192; + ;; + + amigaos*) + # On AmigaOS with pdksh, this test takes hours, literally. + # So we just punt and use a minimum line length of 8192. + lt_cv_sys_max_cmd_len=8192; + ;; + + bitrig* | darwin* | dragonfly* | freebsd* | midnightbsd* | netbsd* | openbsd*) + # This has been around since 386BSD, at least. Likely further. + if test -x /sbin/sysctl; then + lt_cv_sys_max_cmd_len=`/sbin/sysctl -n kern.argmax` + elif test -x /usr/sbin/sysctl; then + lt_cv_sys_max_cmd_len=`/usr/sbin/sysctl -n kern.argmax` + else + lt_cv_sys_max_cmd_len=65536 # usable default for all BSDs + fi + # And add a safety zone + lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \/ 4` + lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \* 3` + ;; + + interix*) + # We know the value 262144 and hardcode it with a safety zone (like BSD) + lt_cv_sys_max_cmd_len=196608 + ;; + + os2*) + # The test takes a long time on OS/2. + lt_cv_sys_max_cmd_len=8192 + ;; + + osf*) + # Dr. Hans Ekkehard Plesser reports seeing a kernel panic running configure + # due to this test when exec_disable_arg_limit is 1 on Tru64. It is not + # nice to cause kernel panics so lets avoid the loop below. + # First set a reasonable default. + lt_cv_sys_max_cmd_len=16384 + # + if test -x /sbin/sysconfig; then + case `/sbin/sysconfig -q proc exec_disable_arg_limit` in + *1*) lt_cv_sys_max_cmd_len=-1 ;; + esac + fi + ;; + sco3.2v5*) + lt_cv_sys_max_cmd_len=102400 + ;; + sysv5* | sco5v6* | sysv4.2uw2*) + kargmax=`grep ARG_MAX /etc/conf/cf.d/stune 2>/dev/null` + if test -n "$kargmax"; then + lt_cv_sys_max_cmd_len=`echo $kargmax | $SED 's/.*[ ]//'` + else + lt_cv_sys_max_cmd_len=32768 + fi + ;; + *) + lt_cv_sys_max_cmd_len=`(getconf ARG_MAX) 2> /dev/null` + if test -n "$lt_cv_sys_max_cmd_len" && \ + test undefined != "$lt_cv_sys_max_cmd_len"; then + lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \/ 4` + lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \* 3` + else + # Make teststring a little bigger before we do anything with it. + # a 1K string should be a reasonable start. + for i in 1 2 3 4 5 6 7 8; do + teststring=$teststring$teststring + done + SHELL=${SHELL-${CONFIG_SHELL-/bin/sh}} + # If test is not a shell built-in, we'll probably end up computing a + # maximum length that is only half of the actual maximum length, but + # we can't tell. + while { test X`env echo "$teststring$teststring" 2>/dev/null` \ + = "X$teststring$teststring"; } >/dev/null 2>&1 && + test 17 != "$i" # 1/2 MB should be enough + do + i=`expr $i + 1` + teststring=$teststring$teststring + done + # Only check the string length outside the loop. + lt_cv_sys_max_cmd_len=`expr "X$teststring" : ".*" 2>&1` + teststring= + # Add a significant safety factor because C++ compilers can tack on + # massive amounts of additional arguments before passing them to the + # linker. It appears as though 1/2 is a usable value. + lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \/ 2` + fi + ;; + esac + +fi + +if test -n "$lt_cv_sys_max_cmd_len"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_sys_max_cmd_len" >&5 +printf "%s\n" "$lt_cv_sys_max_cmd_len" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none" >&5 +printf "%s\n" "none" >&6; } +fi +max_cmd_len=$lt_cv_sys_max_cmd_len + + + + + + +: ${CP="cp -f"} +: ${MV="mv -f"} +: ${RM="rm -f"} + +if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then + lt_unset=unset +else + lt_unset=false +fi + + + + + +# test EBCDIC or ASCII +case `echo X|tr X '\101'` in + A) # ASCII based system + # \n is not interpreted correctly by Solaris 8 /usr/ucb/tr + lt_SP2NL='tr \040 \012' + lt_NL2SP='tr \015\012 \040\040' + ;; + *) # EBCDIC based system + lt_SP2NL='tr \100 \n' + lt_NL2SP='tr \r\n \100\100' + ;; +esac + + + + + + + + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to convert $build file names to $host format" >&5 +printf %s "checking how to convert $build file names to $host format... " >&6; } +if test ${lt_cv_to_host_file_cmd+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $host in + *-*-mingw* ) + case $build in + *-*-mingw* ) # actually msys + lt_cv_to_host_file_cmd=func_convert_file_msys_to_w32 + ;; + *-*-cygwin* ) + lt_cv_to_host_file_cmd=func_convert_file_cygwin_to_w32 + ;; + * ) # otherwise, assume *nix + lt_cv_to_host_file_cmd=func_convert_file_nix_to_w32 + ;; + esac + ;; + *-*-cygwin* ) + case $build in + *-*-mingw* ) # actually msys + lt_cv_to_host_file_cmd=func_convert_file_msys_to_cygwin + ;; + *-*-cygwin* ) + lt_cv_to_host_file_cmd=func_convert_file_noop + ;; + * ) # otherwise, assume *nix + lt_cv_to_host_file_cmd=func_convert_file_nix_to_cygwin + ;; + esac + ;; + * ) # unhandled hosts (and "normal" native builds) + lt_cv_to_host_file_cmd=func_convert_file_noop + ;; +esac + +fi + +to_host_file_cmd=$lt_cv_to_host_file_cmd +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_to_host_file_cmd" >&5 +printf "%s\n" "$lt_cv_to_host_file_cmd" >&6; } + + + + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to convert $build file names to toolchain format" >&5 +printf %s "checking how to convert $build file names to toolchain format... " >&6; } +if test ${lt_cv_to_tool_file_cmd+y} +then : + printf %s "(cached) " >&6 +else $as_nop + #assume ordinary cross tools, or native build. +lt_cv_to_tool_file_cmd=func_convert_file_noop +case $host in + *-*-mingw* ) + case $build in + *-*-mingw* ) # actually msys + lt_cv_to_tool_file_cmd=func_convert_file_msys_to_w32 + ;; + esac + ;; +esac + +fi + +to_tool_file_cmd=$lt_cv_to_tool_file_cmd +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_to_tool_file_cmd" >&5 +printf "%s\n" "$lt_cv_to_tool_file_cmd" >&6; } + + + + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $LD option to reload object files" >&5 +printf %s "checking for $LD option to reload object files... " >&6; } +if test ${lt_cv_ld_reload_flag+y} +then : + printf %s "(cached) " >&6 +else $as_nop + lt_cv_ld_reload_flag='-r' +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_ld_reload_flag" >&5 +printf "%s\n" "$lt_cv_ld_reload_flag" >&6; } +reload_flag=$lt_cv_ld_reload_flag +case $reload_flag in +"" | " "*) ;; +*) reload_flag=" $reload_flag" ;; +esac +reload_cmds='$LD$reload_flag -o $output$reload_objs' +case $host_os in + cygwin* | mingw* | pw32* | cegcc*) + if test yes != "$GCC"; then + reload_cmds=false + fi + ;; + darwin*) + if test yes = "$GCC"; then + reload_cmds='$LTCC $LTCFLAGS -nostdlib $wl-r -o $output$reload_objs' + else + reload_cmds='$LD$reload_flag -o $output$reload_objs' + fi + ;; +esac + + + + + + + + + +if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}file", so it can be a program name with args. +set dummy ${ac_tool_prefix}file; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_FILECMD+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$FILECMD"; then + ac_cv_prog_FILECMD="$FILECMD" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_FILECMD="${ac_tool_prefix}file" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +FILECMD=$ac_cv_prog_FILECMD +if test -n "$FILECMD"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $FILECMD" >&5 +printf "%s\n" "$FILECMD" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_FILECMD"; then + ac_ct_FILECMD=$FILECMD + # Extract the first word of "file", so it can be a program name with args. +set dummy file; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_ac_ct_FILECMD+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$ac_ct_FILECMD"; then + ac_cv_prog_ac_ct_FILECMD="$ac_ct_FILECMD" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_FILECMD="file" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_FILECMD=$ac_cv_prog_ac_ct_FILECMD +if test -n "$ac_ct_FILECMD"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_FILECMD" >&5 +printf "%s\n" "$ac_ct_FILECMD" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_ct_FILECMD" = x; then + FILECMD=":" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + FILECMD=$ac_ct_FILECMD + fi +else + FILECMD="$ac_cv_prog_FILECMD" +fi + + + + + + + +if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}objdump", so it can be a program name with args. +set dummy ${ac_tool_prefix}objdump; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_OBJDUMP+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$OBJDUMP"; then + ac_cv_prog_OBJDUMP="$OBJDUMP" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_OBJDUMP="${ac_tool_prefix}objdump" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +OBJDUMP=$ac_cv_prog_OBJDUMP +if test -n "$OBJDUMP"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $OBJDUMP" >&5 +printf "%s\n" "$OBJDUMP" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_OBJDUMP"; then + ac_ct_OBJDUMP=$OBJDUMP + # Extract the first word of "objdump", so it can be a program name with args. +set dummy objdump; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_ac_ct_OBJDUMP+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$ac_ct_OBJDUMP"; then + ac_cv_prog_ac_ct_OBJDUMP="$ac_ct_OBJDUMP" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_OBJDUMP="objdump" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_OBJDUMP=$ac_cv_prog_ac_ct_OBJDUMP +if test -n "$ac_ct_OBJDUMP"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_OBJDUMP" >&5 +printf "%s\n" "$ac_ct_OBJDUMP" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_ct_OBJDUMP" = x; then + OBJDUMP="false" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + OBJDUMP=$ac_ct_OBJDUMP + fi +else + OBJDUMP="$ac_cv_prog_OBJDUMP" +fi + +test -z "$OBJDUMP" && OBJDUMP=objdump + + + + + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to recognize dependent libraries" >&5 +printf %s "checking how to recognize dependent libraries... " >&6; } +if test ${lt_cv_deplibs_check_method+y} +then : + printf %s "(cached) " >&6 +else $as_nop + lt_cv_file_magic_cmd='$MAGIC_CMD' +lt_cv_file_magic_test_file= +lt_cv_deplibs_check_method='unknown' +# Need to set the preceding variable on all platforms that support +# interlibrary dependencies. +# 'none' -- dependencies not supported. +# 'unknown' -- same as none, but documents that we really don't know. +# 'pass_all' -- all dependencies passed with no checks. +# 'test_compile' -- check by making test program. +# 'file_magic [[regex]]' -- check by looking for files in library path +# that responds to the $file_magic_cmd with a given extended regex. +# If you have 'file' or equivalent on your system and you're not sure +# whether 'pass_all' will *always* work, you probably want this one. + +case $host_os in +aix[4-9]*) + lt_cv_deplibs_check_method=pass_all + ;; + +beos*) + lt_cv_deplibs_check_method=pass_all + ;; + +bsdi[45]*) + lt_cv_deplibs_check_method='file_magic ELF [0-9][0-9]*-bit [ML]SB (shared object|dynamic lib)' + lt_cv_file_magic_cmd='$FILECMD -L' + lt_cv_file_magic_test_file=/shlib/libc.so + ;; + +cygwin*) + # func_win32_libid is a shell function defined in ltmain.sh + lt_cv_deplibs_check_method='file_magic ^x86 archive import|^x86 DLL' + lt_cv_file_magic_cmd='func_win32_libid' + ;; + +mingw* | pw32*) + # Base MSYS/MinGW do not provide the 'file' command needed by + # func_win32_libid shell function, so use a weaker test based on 'objdump', + # unless we find 'file', for example because we are cross-compiling. + if ( file / ) >/dev/null 2>&1; then + lt_cv_deplibs_check_method='file_magic ^x86 archive import|^x86 DLL' + lt_cv_file_magic_cmd='func_win32_libid' + else + # Keep this pattern in sync with the one in func_win32_libid. + lt_cv_deplibs_check_method='file_magic file format (pei*-i386(.*architecture: i386)?|pe-arm-wince|pe-x86-64)' + lt_cv_file_magic_cmd='$OBJDUMP -f' + fi + ;; + +cegcc*) + # use the weaker test based on 'objdump'. See mingw*. + lt_cv_deplibs_check_method='file_magic file format pe-arm-.*little(.*architecture: arm)?' + lt_cv_file_magic_cmd='$OBJDUMP -f' + ;; + +darwin* | rhapsody*) + lt_cv_deplibs_check_method=pass_all + ;; + +freebsd* | dragonfly* | midnightbsd*) + if echo __ELF__ | $CC -E - | $GREP __ELF__ > /dev/null; then + case $host_cpu in + i*86 ) + # Not sure whether the presence of OpenBSD here was a mistake. + # Let's accept both of them until this is cleared up. + lt_cv_deplibs_check_method='file_magic (FreeBSD|OpenBSD|DragonFly)/i[3-9]86 (compact )?demand paged shared library' + lt_cv_file_magic_cmd=$FILECMD + lt_cv_file_magic_test_file=`echo /usr/lib/libc.so.*` + ;; + esac + else + lt_cv_deplibs_check_method=pass_all + fi + ;; + +haiku*) + lt_cv_deplibs_check_method=pass_all + ;; + +hpux10.20* | hpux11*) + lt_cv_file_magic_cmd=$FILECMD + case $host_cpu in + ia64*) + lt_cv_deplibs_check_method='file_magic (s[0-9][0-9][0-9]|ELF-[0-9][0-9]) shared object file - IA64' + lt_cv_file_magic_test_file=/usr/lib/hpux32/libc.so + ;; + hppa*64*) + lt_cv_deplibs_check_method='file_magic (s[0-9][0-9][0-9]|ELF[ -][0-9][0-9])(-bit)?( [LM]SB)? shared object( file)?[, -]* PA-RISC [0-9]\.[0-9]' + lt_cv_file_magic_test_file=/usr/lib/pa20_64/libc.sl + ;; + *) + lt_cv_deplibs_check_method='file_magic (s[0-9][0-9][0-9]|PA-RISC[0-9]\.[0-9]) shared library' + lt_cv_file_magic_test_file=/usr/lib/libc.sl + ;; + esac + ;; + +interix[3-9]*) + # PIC code is broken on Interix 3.x, that's why |\.a not |_pic\.a here + lt_cv_deplibs_check_method='match_pattern /lib[^/]+(\.so|\.a)$' + ;; + +irix5* | irix6* | nonstopux*) + case $LD in + *-32|*"-32 ") libmagic=32-bit;; + *-n32|*"-n32 ") libmagic=N32;; + *-64|*"-64 ") libmagic=64-bit;; + *) libmagic=never-match;; + esac + lt_cv_deplibs_check_method=pass_all + ;; + +# This must be glibc/ELF. +linux* | k*bsd*-gnu | kopensolaris*-gnu | gnu*) + lt_cv_deplibs_check_method=pass_all + ;; + +netbsd* | netbsdelf*-gnu) + if echo __ELF__ | $CC -E - | $GREP __ELF__ > /dev/null; then + lt_cv_deplibs_check_method='match_pattern /lib[^/]+(\.so\.[0-9]+\.[0-9]+|_pic\.a)$' + else + lt_cv_deplibs_check_method='match_pattern /lib[^/]+(\.so|_pic\.a)$' + fi + ;; + +newos6*) + lt_cv_deplibs_check_method='file_magic ELF [0-9][0-9]*-bit [ML]SB (executable|dynamic lib)' + lt_cv_file_magic_cmd=$FILECMD + lt_cv_file_magic_test_file=/usr/lib/libnls.so + ;; + +*nto* | *qnx*) + lt_cv_deplibs_check_method=pass_all + ;; + +openbsd* | bitrig*) + if test -z "`echo __ELF__ | $CC -E - | $GREP __ELF__`"; then + lt_cv_deplibs_check_method='match_pattern /lib[^/]+(\.so\.[0-9]+\.[0-9]+|\.so|_pic\.a)$' + else + lt_cv_deplibs_check_method='match_pattern /lib[^/]+(\.so\.[0-9]+\.[0-9]+|_pic\.a)$' + fi + ;; + +osf3* | osf4* | osf5*) + lt_cv_deplibs_check_method=pass_all + ;; + +rdos*) + lt_cv_deplibs_check_method=pass_all + ;; + +solaris*) + lt_cv_deplibs_check_method=pass_all + ;; + +sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX* | sysv4*uw2*) + lt_cv_deplibs_check_method=pass_all + ;; + +sysv4 | sysv4.3*) + case $host_vendor in + motorola) + lt_cv_deplibs_check_method='file_magic ELF [0-9][0-9]*-bit [ML]SB (shared object|dynamic lib) M[0-9][0-9]* Version [0-9]' + lt_cv_file_magic_test_file=`echo /usr/lib/libc.so*` + ;; + ncr) + lt_cv_deplibs_check_method=pass_all + ;; + sequent) + lt_cv_file_magic_cmd='/bin/file' + lt_cv_deplibs_check_method='file_magic ELF [0-9][0-9]*-bit [LM]SB (shared object|dynamic lib )' + ;; + sni) + lt_cv_file_magic_cmd='/bin/file' + lt_cv_deplibs_check_method="file_magic ELF [0-9][0-9]*-bit [LM]SB dynamic lib" + lt_cv_file_magic_test_file=/lib/libc.so + ;; + siemens) + lt_cv_deplibs_check_method=pass_all + ;; + pc) + lt_cv_deplibs_check_method=pass_all + ;; + esac + ;; + +tpf*) + lt_cv_deplibs_check_method=pass_all + ;; +os2*) + lt_cv_deplibs_check_method=pass_all + ;; +esac + +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_deplibs_check_method" >&5 +printf "%s\n" "$lt_cv_deplibs_check_method" >&6; } + +file_magic_glob= +want_nocaseglob=no +if test "$build" = "$host"; then + case $host_os in + mingw* | pw32*) + if ( shopt | grep nocaseglob ) >/dev/null 2>&1; then + want_nocaseglob=yes + else + file_magic_glob=`echo aAbBcCdDeEfFgGhHiIjJkKlLmMnNoOpPqQrRsStTuUvVwWxXyYzZ | $SED -e "s/\(..\)/s\/[\1]\/[\1]\/g;/g"` + fi + ;; + esac +fi + +file_magic_cmd=$lt_cv_file_magic_cmd +deplibs_check_method=$lt_cv_deplibs_check_method +test -z "$deplibs_check_method" && deplibs_check_method=unknown + + + + + + + + + + + + + + + + + + + + + + +if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}dlltool", so it can be a program name with args. +set dummy ${ac_tool_prefix}dlltool; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_DLLTOOL+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$DLLTOOL"; then + ac_cv_prog_DLLTOOL="$DLLTOOL" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_DLLTOOL="${ac_tool_prefix}dlltool" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +DLLTOOL=$ac_cv_prog_DLLTOOL +if test -n "$DLLTOOL"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $DLLTOOL" >&5 +printf "%s\n" "$DLLTOOL" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_DLLTOOL"; then + ac_ct_DLLTOOL=$DLLTOOL + # Extract the first word of "dlltool", so it can be a program name with args. +set dummy dlltool; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_ac_ct_DLLTOOL+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$ac_ct_DLLTOOL"; then + ac_cv_prog_ac_ct_DLLTOOL="$ac_ct_DLLTOOL" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_DLLTOOL="dlltool" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_DLLTOOL=$ac_cv_prog_ac_ct_DLLTOOL +if test -n "$ac_ct_DLLTOOL"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_DLLTOOL" >&5 +printf "%s\n" "$ac_ct_DLLTOOL" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_ct_DLLTOOL" = x; then + DLLTOOL="false" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + DLLTOOL=$ac_ct_DLLTOOL + fi +else + DLLTOOL="$ac_cv_prog_DLLTOOL" +fi + +test -z "$DLLTOOL" && DLLTOOL=dlltool + + + + + + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to associate runtime and link libraries" >&5 +printf %s "checking how to associate runtime and link libraries... " >&6; } +if test ${lt_cv_sharedlib_from_linklib_cmd+y} +then : + printf %s "(cached) " >&6 +else $as_nop + lt_cv_sharedlib_from_linklib_cmd='unknown' + +case $host_os in +cygwin* | mingw* | pw32* | cegcc*) + # two different shell functions defined in ltmain.sh; + # decide which one to use based on capabilities of $DLLTOOL + case `$DLLTOOL --help 2>&1` in + *--identify-strict*) + lt_cv_sharedlib_from_linklib_cmd=func_cygming_dll_for_implib + ;; + *) + lt_cv_sharedlib_from_linklib_cmd=func_cygming_dll_for_implib_fallback + ;; + esac + ;; +*) + # fallback: assume linklib IS sharedlib + lt_cv_sharedlib_from_linklib_cmd=$ECHO + ;; +esac + +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_sharedlib_from_linklib_cmd" >&5 +printf "%s\n" "$lt_cv_sharedlib_from_linklib_cmd" >&6; } +sharedlib_from_linklib_cmd=$lt_cv_sharedlib_from_linklib_cmd +test -z "$sharedlib_from_linklib_cmd" && sharedlib_from_linklib_cmd=$ECHO + + + + + + + +if test -n "$ac_tool_prefix"; then + for ac_prog in ar + do + # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. +set dummy $ac_tool_prefix$ac_prog; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_AR+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$AR"; then + ac_cv_prog_AR="$AR" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_AR="$ac_tool_prefix$ac_prog" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +AR=$ac_cv_prog_AR +if test -n "$AR"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $AR" >&5 +printf "%s\n" "$AR" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + + test -n "$AR" && break + done +fi +if test -z "$AR"; then + ac_ct_AR=$AR + for ac_prog in ar +do + # Extract the first word of "$ac_prog", so it can be a program name with args. +set dummy $ac_prog; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_ac_ct_AR+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$ac_ct_AR"; then + ac_cv_prog_ac_ct_AR="$ac_ct_AR" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_AR="$ac_prog" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_AR=$ac_cv_prog_ac_ct_AR +if test -n "$ac_ct_AR"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_AR" >&5 +printf "%s\n" "$ac_ct_AR" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + + test -n "$ac_ct_AR" && break +done + + if test "x$ac_ct_AR" = x; then + AR="false" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + AR=$ac_ct_AR + fi +fi + +: ${AR=ar} + + + + + + +# Use ARFLAGS variable as AR's operation code to sync the variable naming with +# Automake. If both AR_FLAGS and ARFLAGS are specified, AR_FLAGS should have +# higher priority because thats what people were doing historically (setting +# ARFLAGS for automake and AR_FLAGS for libtool). FIXME: Make the AR_FLAGS +# variable obsoleted/removed. + +test ${AR_FLAGS+y} || AR_FLAGS=${ARFLAGS-cr} +lt_ar_flags=$AR_FLAGS + + + + + + +# Make AR_FLAGS overridable by 'make ARFLAGS='. Don't try to run-time override +# by AR_FLAGS because that was never working and AR_FLAGS is about to die. + + + + + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for archiver @FILE support" >&5 +printf %s "checking for archiver @FILE support... " >&6; } +if test ${lt_cv_ar_at_file+y} +then : + printf %s "(cached) " >&6 +else $as_nop + lt_cv_ar_at_file=no + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int main(void) +{ + + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + echo conftest.$ac_objext > conftest.lst + lt_ar_try='$AR $AR_FLAGS libconftest.a @conftest.lst >&5' + { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$lt_ar_try\""; } >&5 + (eval $lt_ar_try) 2>&5 + ac_status=$? + printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } + if test 0 -eq "$ac_status"; then + # Ensure the archiver fails upon bogus file names. + rm -f conftest.$ac_objext libconftest.a + { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$lt_ar_try\""; } >&5 + (eval $lt_ar_try) 2>&5 + ac_status=$? + printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } + if test 0 -ne "$ac_status"; then + lt_cv_ar_at_file=@ + fi + fi + rm -f conftest.* libconftest.a + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_ar_at_file" >&5 +printf "%s\n" "$lt_cv_ar_at_file" >&6; } + +if test no = "$lt_cv_ar_at_file"; then + archiver_list_spec= +else + archiver_list_spec=$lt_cv_ar_at_file +fi + + + + + + + +if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}strip", so it can be a program name with args. +set dummy ${ac_tool_prefix}strip; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_STRIP+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$STRIP"; then + ac_cv_prog_STRIP="$STRIP" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_STRIP="${ac_tool_prefix}strip" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +STRIP=$ac_cv_prog_STRIP +if test -n "$STRIP"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $STRIP" >&5 +printf "%s\n" "$STRIP" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_STRIP"; then + ac_ct_STRIP=$STRIP + # Extract the first word of "strip", so it can be a program name with args. +set dummy strip; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_ac_ct_STRIP+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$ac_ct_STRIP"; then + ac_cv_prog_ac_ct_STRIP="$ac_ct_STRIP" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_STRIP="strip" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_STRIP=$ac_cv_prog_ac_ct_STRIP +if test -n "$ac_ct_STRIP"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_STRIP" >&5 +printf "%s\n" "$ac_ct_STRIP" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_ct_STRIP" = x; then + STRIP=":" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + STRIP=$ac_ct_STRIP + fi +else + STRIP="$ac_cv_prog_STRIP" +fi + +test -z "$STRIP" && STRIP=: + + + + + + +if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}ranlib", so it can be a program name with args. +set dummy ${ac_tool_prefix}ranlib; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_RANLIB+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$RANLIB"; then + ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_RANLIB="${ac_tool_prefix}ranlib" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +RANLIB=$ac_cv_prog_RANLIB +if test -n "$RANLIB"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $RANLIB" >&5 +printf "%s\n" "$RANLIB" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_RANLIB"; then + ac_ct_RANLIB=$RANLIB + # Extract the first word of "ranlib", so it can be a program name with args. +set dummy ranlib; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_ac_ct_RANLIB+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$ac_ct_RANLIB"; then + ac_cv_prog_ac_ct_RANLIB="$ac_ct_RANLIB" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_RANLIB="ranlib" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_RANLIB=$ac_cv_prog_ac_ct_RANLIB +if test -n "$ac_ct_RANLIB"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_RANLIB" >&5 +printf "%s\n" "$ac_ct_RANLIB" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_ct_RANLIB" = x; then + RANLIB=":" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + RANLIB=$ac_ct_RANLIB + fi +else + RANLIB="$ac_cv_prog_RANLIB" +fi + +test -z "$RANLIB" && RANLIB=: + + + + + + +# Determine commands to create old-style static archives. +old_archive_cmds='$AR $AR_FLAGS $oldlib$oldobjs' +old_postinstall_cmds='chmod 644 $oldlib' +old_postuninstall_cmds= + +if test -n "$RANLIB"; then + case $host_os in + bitrig* | openbsd*) + old_postinstall_cmds="$old_postinstall_cmds~\$RANLIB -t \$tool_oldlib" + ;; + *) + old_postinstall_cmds="$old_postinstall_cmds~\$RANLIB \$tool_oldlib" + ;; + esac + old_archive_cmds="$old_archive_cmds~\$RANLIB \$tool_oldlib" +fi + +case $host_os in + darwin*) + lock_old_archive_extraction=yes ;; + *) + lock_old_archive_extraction=no ;; +esac + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +# If no C compiler was specified, use CC. +LTCC=${LTCC-"$CC"} + +# If no C compiler flags were specified, use CFLAGS. +LTCFLAGS=${LTCFLAGS-"$CFLAGS"} + +# Allow CC to be a program name with arguments. +compiler=$CC + + +# Check for command to grab the raw symbol name followed by C symbol from nm. +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking command to parse $NM output from $compiler object" >&5 +printf %s "checking command to parse $NM output from $compiler object... " >&6; } +if test ${lt_cv_sys_global_symbol_pipe+y} +then : + printf %s "(cached) " >&6 +else $as_nop + +# These are sane defaults that work on at least a few old systems. +# [They come from Ultrix. What could be older than Ultrix?!! ;)] + +# Character class describing NM global symbol codes. +symcode='[BCDEGRST]' + +# Regexp to match symbols that can be accessed directly from C. +sympat='\([_A-Za-z][_A-Za-z0-9]*\)' + +# Define system-specific variables. +case $host_os in +aix*) + symcode='[BCDT]' + ;; +cygwin* | mingw* | pw32* | cegcc*) + symcode='[ABCDGISTW]' + ;; +hpux*) + if test ia64 = "$host_cpu"; then + symcode='[ABCDEGRST]' + fi + ;; +irix* | nonstopux*) + symcode='[BCDEGRST]' + ;; +osf*) + symcode='[BCDEGQRST]' + ;; +solaris*) + symcode='[BDRT]' + ;; +sco3.2v5*) + symcode='[DT]' + ;; +sysv4.2uw2*) + symcode='[DT]' + ;; +sysv5* | sco5v6* | unixware* | OpenUNIX*) + symcode='[ABDT]' + ;; +sysv4) + symcode='[DFNSTU]' + ;; +esac + +# If we're using GNU nm, then use its standard symbol codes. +case `$NM -V 2>&1` in +*GNU* | *'with BFD'*) + symcode='[ABCDGIRSTW]' ;; +esac + +if test "$lt_cv_nm_interface" = "MS dumpbin"; then + # Gets list of data symbols to import. + lt_cv_sys_global_symbol_to_import="$SED -n -e 's/^I .* \(.*\)$/\1/p'" + # Adjust the below global symbol transforms to fixup imported variables. + lt_cdecl_hook=" -e 's/^I .* \(.*\)$/extern __declspec(dllimport) char \1;/p'" + lt_c_name_hook=" -e 's/^I .* \(.*\)$/ {\"\1\", (void *) 0},/p'" + lt_c_name_lib_hook="\ + -e 's/^I .* \(lib.*\)$/ {\"\1\", (void *) 0},/p'\ + -e 's/^I .* \(.*\)$/ {\"lib\1\", (void *) 0},/p'" +else + # Disable hooks by default. + lt_cv_sys_global_symbol_to_import= + lt_cdecl_hook= + lt_c_name_hook= + lt_c_name_lib_hook= +fi + +# Transform an extracted symbol line into a proper C declaration. +# Some systems (esp. on ia64) link data and code symbols differently, +# so use this general approach. +lt_cv_sys_global_symbol_to_cdecl="$SED -n"\ +$lt_cdecl_hook\ +" -e 's/^T .* \(.*\)$/extern int \1();/p'"\ +" -e 's/^$symcode$symcode* .* \(.*\)$/extern char \1;/p'" + +# Transform an extracted symbol line into symbol name and symbol address +lt_cv_sys_global_symbol_to_c_name_address="$SED -n"\ +$lt_c_name_hook\ +" -e 's/^: \(.*\) .*$/ {\"\1\", (void *) 0},/p'"\ +" -e 's/^$symcode$symcode* .* \(.*\)$/ {\"\1\", (void *) \&\1},/p'" + +# Transform an extracted symbol line into symbol name with lib prefix and +# symbol address. +lt_cv_sys_global_symbol_to_c_name_address_lib_prefix="$SED -n"\ +$lt_c_name_lib_hook\ +" -e 's/^: \(.*\) .*$/ {\"\1\", (void *) 0},/p'"\ +" -e 's/^$symcode$symcode* .* \(lib.*\)$/ {\"\1\", (void *) \&\1},/p'"\ +" -e 's/^$symcode$symcode* .* \(.*\)$/ {\"lib\1\", (void *) \&\1},/p'" + +# Handle CRLF in mingw tool chain +opt_cr= +case $build_os in +mingw*) + opt_cr=`$ECHO 'x\{0,1\}' | tr x '\015'` # option cr in regexp + ;; +esac + +# Try without a prefix underscore, then with it. +for ac_symprfx in "" "_"; do + + # Transform symcode, sympat, and symprfx into a raw symbol and a C symbol. + symxfrm="\\1 $ac_symprfx\\2 \\2" + + # Write the raw and C identifiers. + if test "$lt_cv_nm_interface" = "MS dumpbin"; then + # Fake it for dumpbin and say T for any non-static function, + # D for any global variable and I for any imported variable. + # Also find C++ and __fastcall symbols from MSVC++ or ICC, + # which start with @ or ?. + lt_cv_sys_global_symbol_pipe="$AWK '"\ +" {last_section=section; section=\$ 3};"\ +" /^COFF SYMBOL TABLE/{for(i in hide) delete hide[i]};"\ +" /Section length .*#relocs.*(pick any)/{hide[last_section]=1};"\ +" /^ *Symbol name *: /{split(\$ 0,sn,\":\"); si=substr(sn[2],2)};"\ +" /^ *Type *: code/{print \"T\",si,substr(si,length(prfx))};"\ +" /^ *Type *: data/{print \"I\",si,substr(si,length(prfx))};"\ +" \$ 0!~/External *\|/{next};"\ +" / 0+ UNDEF /{next}; / UNDEF \([^|]\)*()/{next};"\ +" {if(hide[section]) next};"\ +" {f=\"D\"}; \$ 0~/\(\).*\|/{f=\"T\"};"\ +" {split(\$ 0,a,/\||\r/); split(a[2],s)};"\ +" s[1]~/^[@?]/{print f,s[1],s[1]; next};"\ +" s[1]~prfx {split(s[1],t,\"@\"); print f,t[1],substr(t[1],length(prfx))}"\ +" ' prfx=^$ac_symprfx" + else + lt_cv_sys_global_symbol_pipe="$SED -n -e 's/^.*[ ]\($symcode$symcode*\)[ ][ ]*$ac_symprfx$sympat$opt_cr$/$symxfrm/p'" + fi + lt_cv_sys_global_symbol_pipe="$lt_cv_sys_global_symbol_pipe | $SED '/ __gnu_lto/d'" + + # Check to see that the pipe works correctly. + pipe_works=no + + rm -f conftest* + cat > conftest.$ac_ext <<_LT_EOF +#ifdef __cplusplus +extern "C" { +#endif +char nm_test_var; +void nm_test_func(void); +void nm_test_func(void){} +#ifdef __cplusplus +} +#endif +int main(){nm_test_var='a';nm_test_func();return(0);} +_LT_EOF + + if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_compile\""; } >&5 + (eval $ac_compile) 2>&5 + ac_status=$? + printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; then + # Now try to grab the symbols. + nlist=conftest.nm + $ECHO "$as_me:$LINENO: $NM conftest.$ac_objext | $lt_cv_sys_global_symbol_pipe > $nlist" >&5 + if eval "$NM" conftest.$ac_objext \| "$lt_cv_sys_global_symbol_pipe" \> $nlist 2>&5 && test -s "$nlist"; then + # Try sorting and uniquifying the output. + if sort "$nlist" | uniq > "$nlist"T; then + mv -f "$nlist"T "$nlist" + else + rm -f "$nlist"T + fi + + # Make sure that we snagged all the symbols we need. + if $GREP ' nm_test_var$' "$nlist" >/dev/null; then + if $GREP ' nm_test_func$' "$nlist" >/dev/null; then + cat <<_LT_EOF > conftest.$ac_ext +/* Keep this code in sync between libtool.m4, ltmain, lt_system.h, and tests. */ +#if defined _WIN32 || defined __CYGWIN__ || defined _WIN32_WCE +/* DATA imports from DLLs on WIN32 can't be const, because runtime + relocations are performed -- see ld's documentation on pseudo-relocs. */ +# define LT_DLSYM_CONST +#elif defined __osf__ +/* This system does not cope well with relocations in const data. */ +# define LT_DLSYM_CONST +#else +# define LT_DLSYM_CONST const +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +_LT_EOF + # Now generate the symbol file. + eval "$lt_cv_sys_global_symbol_to_cdecl"' < "$nlist" | $GREP -v main >> conftest.$ac_ext' + + cat <<_LT_EOF >> conftest.$ac_ext + +/* The mapping between symbol names and symbols. */ +LT_DLSYM_CONST struct { + const char *name; + void *address; +} +lt__PROGRAM__LTX_preloaded_symbols[] = +{ + { "@PROGRAM@", (void *) 0 }, +_LT_EOF + $SED "s/^$symcode$symcode* .* \(.*\)$/ {\"\1\", (void *) \&\1},/" < "$nlist" | $GREP -v main >> conftest.$ac_ext + cat <<\_LT_EOF >> conftest.$ac_ext + {0, (void *) 0} +}; + +/* This works around a problem in FreeBSD linker */ +#ifdef FREEBSD_WORKAROUND +static const void *lt_preloaded_setup() { + return lt__PROGRAM__LTX_preloaded_symbols; +} +#endif + +#ifdef __cplusplus +} +#endif +_LT_EOF + # Now try linking the two files. + mv conftest.$ac_objext conftstm.$ac_objext + lt_globsym_save_LIBS=$LIBS + lt_globsym_save_CFLAGS=$CFLAGS + LIBS=conftstm.$ac_objext + CFLAGS="$CFLAGS$lt_prog_compiler_no_builtin_flag" + if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_link\""; } >&5 + (eval $ac_link) 2>&5 + ac_status=$? + printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && test -s conftest$ac_exeext; then + pipe_works=yes + fi + LIBS=$lt_globsym_save_LIBS + CFLAGS=$lt_globsym_save_CFLAGS + else + echo "cannot find nm_test_func in $nlist" >&5 + fi + else + echo "cannot find nm_test_var in $nlist" >&5 + fi + else + echo "cannot run $lt_cv_sys_global_symbol_pipe" >&5 + fi + else + echo "$progname: failed program was:" >&5 + cat conftest.$ac_ext >&5 + fi + rm -rf conftest* conftst* + + # Do not use the global_symbol_pipe unless it works. + if test yes = "$pipe_works"; then + break + else + lt_cv_sys_global_symbol_pipe= + fi +done + +fi + +if test -z "$lt_cv_sys_global_symbol_pipe"; then + lt_cv_sys_global_symbol_to_cdecl= +fi +if test -z "$lt_cv_sys_global_symbol_pipe$lt_cv_sys_global_symbol_to_cdecl"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: failed" >&5 +printf "%s\n" "failed" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: ok" >&5 +printf "%s\n" "ok" >&6; } +fi + +# Response file support. +if test "$lt_cv_nm_interface" = "MS dumpbin"; then + nm_file_list_spec='@' +elif $NM --help 2>/dev/null | grep '[@]FILE' >/dev/null; then + nm_file_list_spec='@' +fi + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for sysroot" >&5 +printf %s "checking for sysroot... " >&6; } + +# Check whether --with-sysroot was given. +if test ${with_sysroot+y} +then : + withval=$with_sysroot; +else $as_nop + with_sysroot=no +fi + + +lt_sysroot= +case $with_sysroot in #( + yes) + if test yes = "$GCC"; then + lt_sysroot=`$CC --print-sysroot 2>/dev/null` + fi + ;; #( + /*) + lt_sysroot=`echo "$with_sysroot" | $SED -e "$sed_quote_subst"` + ;; #( + no|'') + ;; #( + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $with_sysroot" >&5 +printf "%s\n" "$with_sysroot" >&6; } + as_fn_error $? "The sysroot must be an absolute path." "$LINENO" 5 + ;; +esac + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: ${lt_sysroot:-no}" >&5 +printf "%s\n" "${lt_sysroot:-no}" >&6; } + + + + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for a working dd" >&5 +printf %s "checking for a working dd... " >&6; } +if test ${ac_cv_path_lt_DD+y} +then : + printf %s "(cached) " >&6 +else $as_nop + printf 0123456789abcdef0123456789abcdef >conftest.i +cat conftest.i conftest.i >conftest2.i +: ${lt_DD:=$DD} +if test -z "$lt_DD"; then + ac_path_lt_DD_found=false + # Loop through the user's path and test for each of PROGNAME-LIST + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_prog in dd + do + for ac_exec_ext in '' $ac_executable_extensions; do + ac_path_lt_DD="$as_dir$ac_prog$ac_exec_ext" + as_fn_executable_p "$ac_path_lt_DD" || continue +if "$ac_path_lt_DD" bs=32 count=1 conftest.out 2>/dev/null; then + cmp -s conftest.i conftest.out \ + && ac_cv_path_lt_DD="$ac_path_lt_DD" ac_path_lt_DD_found=: +fi + $ac_path_lt_DD_found && break 3 + done + done + done +IFS=$as_save_IFS + if test -z "$ac_cv_path_lt_DD"; then + : + fi +else + ac_cv_path_lt_DD=$lt_DD +fi + +rm -f conftest.i conftest2.i conftest.out +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_lt_DD" >&5 +printf "%s\n" "$ac_cv_path_lt_DD" >&6; } + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to truncate binary pipes" >&5 +printf %s "checking how to truncate binary pipes... " >&6; } +if test ${lt_cv_truncate_bin+y} +then : + printf %s "(cached) " >&6 +else $as_nop + printf 0123456789abcdef0123456789abcdef >conftest.i +cat conftest.i conftest.i >conftest2.i +lt_cv_truncate_bin= +if "$ac_cv_path_lt_DD" bs=32 count=1 conftest.out 2>/dev/null; then + cmp -s conftest.i conftest.out \ + && lt_cv_truncate_bin="$ac_cv_path_lt_DD bs=4096 count=1" +fi +rm -f conftest.i conftest2.i conftest.out +test -z "$lt_cv_truncate_bin" && lt_cv_truncate_bin="$SED -e 4q" +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_truncate_bin" >&5 +printf "%s\n" "$lt_cv_truncate_bin" >&6; } + + + + + + + +# Calculate cc_basename. Skip known compiler wrappers and cross-prefix. +func_cc_basename () +{ + for cc_temp in $*""; do + case $cc_temp in + compile | *[\\/]compile | ccache | *[\\/]ccache ) ;; + distcc | *[\\/]distcc | purify | *[\\/]purify ) ;; + \-*) ;; + *) break;; + esac + done + func_cc_basename_result=`$ECHO "$cc_temp" | $SED "s%.*/%%; s%^$host_alias-%%"` +} + +# Check whether --enable-libtool-lock was given. +if test ${enable_libtool_lock+y} +then : + enableval=$enable_libtool_lock; +fi + +test no = "$enable_libtool_lock" || enable_libtool_lock=yes + +# Some flags need to be propagated to the compiler or linker for good +# libtool support. +case $host in +ia64-*-hpux*) + # Find out what ABI is being produced by ac_compile, and set mode + # options accordingly. + echo 'int i;' > conftest.$ac_ext + if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_compile\""; } >&5 + (eval $ac_compile) 2>&5 + ac_status=$? + printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; then + case `$FILECMD conftest.$ac_objext` in + *ELF-32*) + HPUX_IA64_MODE=32 + ;; + *ELF-64*) + HPUX_IA64_MODE=64 + ;; + esac + fi + rm -rf conftest* + ;; +*-*-irix6*) + # Find out what ABI is being produced by ac_compile, and set linker + # options accordingly. + echo '#line '$LINENO' "configure"' > conftest.$ac_ext + if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_compile\""; } >&5 + (eval $ac_compile) 2>&5 + ac_status=$? + printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; then + if test yes = "$lt_cv_prog_gnu_ld"; then + case `$FILECMD conftest.$ac_objext` in + *32-bit*) + LD="${LD-ld} -melf32bsmip" + ;; + *N32*) + LD="${LD-ld} -melf32bmipn32" + ;; + *64-bit*) + LD="${LD-ld} -melf64bmip" + ;; + esac + else + case `$FILECMD conftest.$ac_objext` in + *32-bit*) + LD="${LD-ld} -32" + ;; + *N32*) + LD="${LD-ld} -n32" + ;; + *64-bit*) + LD="${LD-ld} -64" + ;; + esac + fi + fi + rm -rf conftest* + ;; + +mips64*-*linux*) + # Find out what ABI is being produced by ac_compile, and set linker + # options accordingly. + echo '#line '$LINENO' "configure"' > conftest.$ac_ext + if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_compile\""; } >&5 + (eval $ac_compile) 2>&5 + ac_status=$? + printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; then + emul=elf + case `$FILECMD conftest.$ac_objext` in + *32-bit*) + emul="${emul}32" + ;; + *64-bit*) + emul="${emul}64" + ;; + esac + case `$FILECMD conftest.$ac_objext` in + *MSB*) + emul="${emul}btsmip" + ;; + *LSB*) + emul="${emul}ltsmip" + ;; + esac + case `$FILECMD conftest.$ac_objext` in + *N32*) + emul="${emul}n32" + ;; + esac + LD="${LD-ld} -m $emul" + fi + rm -rf conftest* + ;; + +x86_64-*kfreebsd*-gnu|x86_64-*linux*|powerpc*-*linux*| \ +s390*-*linux*|s390*-*tpf*|sparc*-*linux*) + # Find out what ABI is being produced by ac_compile, and set linker + # options accordingly. Note that the listed cases only cover the + # situations where additional linker options are needed (such as when + # doing 32-bit compilation for a host where ld defaults to 64-bit, or + # vice versa); the common cases where no linker options are needed do + # not appear in the list. + echo 'int i;' > conftest.$ac_ext + if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_compile\""; } >&5 + (eval $ac_compile) 2>&5 + ac_status=$? + printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; then + case `$FILECMD conftest.o` in + *32-bit*) + case $host in + x86_64-*kfreebsd*-gnu) + LD="${LD-ld} -m elf_i386_fbsd" + ;; + x86_64-*linux*) + case `$FILECMD conftest.o` in + *x86-64*) + LD="${LD-ld} -m elf32_x86_64" + ;; + *) + LD="${LD-ld} -m elf_i386" + ;; + esac + ;; + powerpc64le-*linux*) + LD="${LD-ld} -m elf32lppclinux" + ;; + powerpc64-*linux*) + LD="${LD-ld} -m elf32ppclinux" + ;; + s390x-*linux*) + LD="${LD-ld} -m elf_s390" + ;; + sparc64-*linux*) + LD="${LD-ld} -m elf32_sparc" + ;; + esac + ;; + *64-bit*) + case $host in + x86_64-*kfreebsd*-gnu) + LD="${LD-ld} -m elf_x86_64_fbsd" + ;; + x86_64-*linux*) + LD="${LD-ld} -m elf_x86_64" + ;; + powerpcle-*linux*) + LD="${LD-ld} -m elf64lppc" + ;; + powerpc-*linux*) + LD="${LD-ld} -m elf64ppc" + ;; + s390*-*linux*|s390*-*tpf*) + LD="${LD-ld} -m elf64_s390" + ;; + sparc*-*linux*) + LD="${LD-ld} -m elf64_sparc" + ;; + esac + ;; + esac + fi + rm -rf conftest* + ;; + +*-*-sco3.2v5*) + # On SCO OpenServer 5, we need -belf to get full-featured binaries. + SAVE_CFLAGS=$CFLAGS + CFLAGS="$CFLAGS -belf" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the C compiler needs -belf" >&5 +printf %s "checking whether the C compiler needs -belf... " >&6; } +if test ${lt_cv_cc_needs_belf+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int main(void) +{ + + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + lt_cv_cc_needs_belf=yes +else $as_nop + lt_cv_cc_needs_belf=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_cc_needs_belf" >&5 +printf "%s\n" "$lt_cv_cc_needs_belf" >&6; } + if test yes != "$lt_cv_cc_needs_belf"; then + # this is probably gcc 2.8.0, egcs 1.0 or newer; no need for -belf + CFLAGS=$SAVE_CFLAGS + fi + ;; +*-*solaris*) + # Find out what ABI is being produced by ac_compile, and set linker + # options accordingly. + echo 'int i;' > conftest.$ac_ext + if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_compile\""; } >&5 + (eval $ac_compile) 2>&5 + ac_status=$? + printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; then + case `$FILECMD conftest.o` in + *64-bit*) + case $lt_cv_prog_gnu_ld in + yes*) + case $host in + i?86-*-solaris*|x86_64-*-solaris*) + LD="${LD-ld} -m elf_x86_64" + ;; + sparc*-*-solaris*) + LD="${LD-ld} -m elf64_sparc" + ;; + esac + # GNU ld 2.21 introduced _sol2 emulations. Use them if available. + if ${LD-ld} -V | grep _sol2 >/dev/null 2>&1; then + LD=${LD-ld}_sol2 + fi + ;; + *) + if ${LD-ld} -64 -r -o conftest2.o conftest.o >/dev/null 2>&1; then + LD="${LD-ld} -64" + fi + ;; + esac + ;; + esac + fi + rm -rf conftest* + ;; +esac + +need_locks=$enable_libtool_lock + +if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}mt", so it can be a program name with args. +set dummy ${ac_tool_prefix}mt; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_MANIFEST_TOOL+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$MANIFEST_TOOL"; then + ac_cv_prog_MANIFEST_TOOL="$MANIFEST_TOOL" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_MANIFEST_TOOL="${ac_tool_prefix}mt" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +MANIFEST_TOOL=$ac_cv_prog_MANIFEST_TOOL +if test -n "$MANIFEST_TOOL"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $MANIFEST_TOOL" >&5 +printf "%s\n" "$MANIFEST_TOOL" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_MANIFEST_TOOL"; then + ac_ct_MANIFEST_TOOL=$MANIFEST_TOOL + # Extract the first word of "mt", so it can be a program name with args. +set dummy mt; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_ac_ct_MANIFEST_TOOL+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$ac_ct_MANIFEST_TOOL"; then + ac_cv_prog_ac_ct_MANIFEST_TOOL="$ac_ct_MANIFEST_TOOL" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_MANIFEST_TOOL="mt" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_MANIFEST_TOOL=$ac_cv_prog_ac_ct_MANIFEST_TOOL +if test -n "$ac_ct_MANIFEST_TOOL"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_MANIFEST_TOOL" >&5 +printf "%s\n" "$ac_ct_MANIFEST_TOOL" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_ct_MANIFEST_TOOL" = x; then + MANIFEST_TOOL=":" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + MANIFEST_TOOL=$ac_ct_MANIFEST_TOOL + fi +else + MANIFEST_TOOL="$ac_cv_prog_MANIFEST_TOOL" +fi + +test -z "$MANIFEST_TOOL" && MANIFEST_TOOL=mt +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if $MANIFEST_TOOL is a manifest tool" >&5 +printf %s "checking if $MANIFEST_TOOL is a manifest tool... " >&6; } +if test ${lt_cv_path_mainfest_tool+y} +then : + printf %s "(cached) " >&6 +else $as_nop + lt_cv_path_mainfest_tool=no + echo "$as_me:$LINENO: $MANIFEST_TOOL '-?'" >&5 + $MANIFEST_TOOL '-?' 2>conftest.err > conftest.out + cat conftest.err >&5 + if $GREP 'Manifest Tool' conftest.out > /dev/null; then + lt_cv_path_mainfest_tool=yes + fi + rm -f conftest* +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_path_mainfest_tool" >&5 +printf "%s\n" "$lt_cv_path_mainfest_tool" >&6; } +if test yes != "$lt_cv_path_mainfest_tool"; then + MANIFEST_TOOL=: +fi + + + + + + + case $host_os in + rhapsody* | darwin*) + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}dsymutil", so it can be a program name with args. +set dummy ${ac_tool_prefix}dsymutil; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_DSYMUTIL+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$DSYMUTIL"; then + ac_cv_prog_DSYMUTIL="$DSYMUTIL" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_DSYMUTIL="${ac_tool_prefix}dsymutil" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +DSYMUTIL=$ac_cv_prog_DSYMUTIL +if test -n "$DSYMUTIL"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $DSYMUTIL" >&5 +printf "%s\n" "$DSYMUTIL" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_DSYMUTIL"; then + ac_ct_DSYMUTIL=$DSYMUTIL + # Extract the first word of "dsymutil", so it can be a program name with args. +set dummy dsymutil; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_ac_ct_DSYMUTIL+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$ac_ct_DSYMUTIL"; then + ac_cv_prog_ac_ct_DSYMUTIL="$ac_ct_DSYMUTIL" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_DSYMUTIL="dsymutil" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_DSYMUTIL=$ac_cv_prog_ac_ct_DSYMUTIL +if test -n "$ac_ct_DSYMUTIL"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_DSYMUTIL" >&5 +printf "%s\n" "$ac_ct_DSYMUTIL" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_ct_DSYMUTIL" = x; then + DSYMUTIL=":" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + DSYMUTIL=$ac_ct_DSYMUTIL + fi +else + DSYMUTIL="$ac_cv_prog_DSYMUTIL" +fi + + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}nmedit", so it can be a program name with args. +set dummy ${ac_tool_prefix}nmedit; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_NMEDIT+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$NMEDIT"; then + ac_cv_prog_NMEDIT="$NMEDIT" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_NMEDIT="${ac_tool_prefix}nmedit" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +NMEDIT=$ac_cv_prog_NMEDIT +if test -n "$NMEDIT"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $NMEDIT" >&5 +printf "%s\n" "$NMEDIT" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_NMEDIT"; then + ac_ct_NMEDIT=$NMEDIT + # Extract the first word of "nmedit", so it can be a program name with args. +set dummy nmedit; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_ac_ct_NMEDIT+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$ac_ct_NMEDIT"; then + ac_cv_prog_ac_ct_NMEDIT="$ac_ct_NMEDIT" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_NMEDIT="nmedit" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_NMEDIT=$ac_cv_prog_ac_ct_NMEDIT +if test -n "$ac_ct_NMEDIT"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_NMEDIT" >&5 +printf "%s\n" "$ac_ct_NMEDIT" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_ct_NMEDIT" = x; then + NMEDIT=":" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + NMEDIT=$ac_ct_NMEDIT + fi +else + NMEDIT="$ac_cv_prog_NMEDIT" +fi + + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}lipo", so it can be a program name with args. +set dummy ${ac_tool_prefix}lipo; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_LIPO+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$LIPO"; then + ac_cv_prog_LIPO="$LIPO" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_LIPO="${ac_tool_prefix}lipo" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +LIPO=$ac_cv_prog_LIPO +if test -n "$LIPO"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $LIPO" >&5 +printf "%s\n" "$LIPO" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_LIPO"; then + ac_ct_LIPO=$LIPO + # Extract the first word of "lipo", so it can be a program name with args. +set dummy lipo; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_ac_ct_LIPO+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$ac_ct_LIPO"; then + ac_cv_prog_ac_ct_LIPO="$ac_ct_LIPO" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_LIPO="lipo" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_LIPO=$ac_cv_prog_ac_ct_LIPO +if test -n "$ac_ct_LIPO"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_LIPO" >&5 +printf "%s\n" "$ac_ct_LIPO" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_ct_LIPO" = x; then + LIPO=":" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + LIPO=$ac_ct_LIPO + fi +else + LIPO="$ac_cv_prog_LIPO" +fi + + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}otool", so it can be a program name with args. +set dummy ${ac_tool_prefix}otool; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_OTOOL+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$OTOOL"; then + ac_cv_prog_OTOOL="$OTOOL" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_OTOOL="${ac_tool_prefix}otool" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +OTOOL=$ac_cv_prog_OTOOL +if test -n "$OTOOL"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $OTOOL" >&5 +printf "%s\n" "$OTOOL" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_OTOOL"; then + ac_ct_OTOOL=$OTOOL + # Extract the first word of "otool", so it can be a program name with args. +set dummy otool; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_ac_ct_OTOOL+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$ac_ct_OTOOL"; then + ac_cv_prog_ac_ct_OTOOL="$ac_ct_OTOOL" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_OTOOL="otool" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_OTOOL=$ac_cv_prog_ac_ct_OTOOL +if test -n "$ac_ct_OTOOL"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_OTOOL" >&5 +printf "%s\n" "$ac_ct_OTOOL" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_ct_OTOOL" = x; then + OTOOL=":" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + OTOOL=$ac_ct_OTOOL + fi +else + OTOOL="$ac_cv_prog_OTOOL" +fi + + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}otool64", so it can be a program name with args. +set dummy ${ac_tool_prefix}otool64; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_OTOOL64+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$OTOOL64"; then + ac_cv_prog_OTOOL64="$OTOOL64" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_OTOOL64="${ac_tool_prefix}otool64" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +OTOOL64=$ac_cv_prog_OTOOL64 +if test -n "$OTOOL64"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $OTOOL64" >&5 +printf "%s\n" "$OTOOL64" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_OTOOL64"; then + ac_ct_OTOOL64=$OTOOL64 + # Extract the first word of "otool64", so it can be a program name with args. +set dummy otool64; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_ac_ct_OTOOL64+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$ac_ct_OTOOL64"; then + ac_cv_prog_ac_ct_OTOOL64="$ac_ct_OTOOL64" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_OTOOL64="otool64" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_OTOOL64=$ac_cv_prog_ac_ct_OTOOL64 +if test -n "$ac_ct_OTOOL64"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_OTOOL64" >&5 +printf "%s\n" "$ac_ct_OTOOL64" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_ct_OTOOL64" = x; then + OTOOL64=":" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + OTOOL64=$ac_ct_OTOOL64 + fi +else + OTOOL64="$ac_cv_prog_OTOOL64" +fi + + + + + + + + + + + + + + + + + + + + + + + + + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for -single_module linker flag" >&5 +printf %s "checking for -single_module linker flag... " >&6; } +if test ${lt_cv_apple_cc_single_mod+y} +then : + printf %s "(cached) " >&6 +else $as_nop + lt_cv_apple_cc_single_mod=no + if test -z "$LT_MULTI_MODULE"; then + # By default we will add the -single_module flag. You can override + # by either setting the environment variable LT_MULTI_MODULE + # non-empty at configure time, or by adding -multi_module to the + # link flags. + rm -rf libconftest.dylib* + echo "int foo(void){return 1;}" > conftest.c + echo "$LTCC $LTCFLAGS $LDFLAGS -o libconftest.dylib \ +-dynamiclib -Wl,-single_module conftest.c" >&5 + $LTCC $LTCFLAGS $LDFLAGS -o libconftest.dylib \ + -dynamiclib -Wl,-single_module conftest.c 2>conftest.err + _lt_result=$? + # If there is a non-empty error log, and "single_module" + # appears in it, assume the flag caused a linker warning + if test -s conftest.err && $GREP single_module conftest.err; then + cat conftest.err >&5 + # Otherwise, if the output was created with a 0 exit code from + # the compiler, it worked. + elif test -f libconftest.dylib && test 0 = "$_lt_result"; then + lt_cv_apple_cc_single_mod=yes + else + cat conftest.err >&5 + fi + rm -rf libconftest.dylib* + rm -f conftest.* + fi +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_apple_cc_single_mod" >&5 +printf "%s\n" "$lt_cv_apple_cc_single_mod" >&6; } + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for -exported_symbols_list linker flag" >&5 +printf %s "checking for -exported_symbols_list linker flag... " >&6; } +if test ${lt_cv_ld_exported_symbols_list+y} +then : + printf %s "(cached) " >&6 +else $as_nop + lt_cv_ld_exported_symbols_list=no + save_LDFLAGS=$LDFLAGS + echo "_main" > conftest.sym + LDFLAGS="$LDFLAGS -Wl,-exported_symbols_list,conftest.sym" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int main(void) +{ + + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + lt_cv_ld_exported_symbols_list=yes +else $as_nop + lt_cv_ld_exported_symbols_list=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + LDFLAGS=$save_LDFLAGS + +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_ld_exported_symbols_list" >&5 +printf "%s\n" "$lt_cv_ld_exported_symbols_list" >&6; } + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for -force_load linker flag" >&5 +printf %s "checking for -force_load linker flag... " >&6; } +if test ${lt_cv_ld_force_load+y} +then : + printf %s "(cached) " >&6 +else $as_nop + lt_cv_ld_force_load=no + cat > conftest.c << _LT_EOF +int forced_loaded() { return 2;} +_LT_EOF + echo "$LTCC $LTCFLAGS -c -o conftest.o conftest.c" >&5 + $LTCC $LTCFLAGS -c -o conftest.o conftest.c 2>&5 + echo "$AR $AR_FLAGS libconftest.a conftest.o" >&5 + $AR $AR_FLAGS libconftest.a conftest.o 2>&5 + echo "$RANLIB libconftest.a" >&5 + $RANLIB libconftest.a 2>&5 + cat > conftest.c << _LT_EOF +int main() { return 0;} +_LT_EOF + echo "$LTCC $LTCFLAGS $LDFLAGS -o conftest conftest.c -Wl,-force_load,./libconftest.a" >&5 + $LTCC $LTCFLAGS $LDFLAGS -o conftest conftest.c -Wl,-force_load,./libconftest.a 2>conftest.err + _lt_result=$? + if test -s conftest.err && $GREP force_load conftest.err; then + cat conftest.err >&5 + elif test -f conftest && test 0 = "$_lt_result" && $GREP forced_load conftest >/dev/null 2>&1; then + lt_cv_ld_force_load=yes + else + cat conftest.err >&5 + fi + rm -f conftest.err libconftest.a conftest conftest.c + rm -rf conftest.dSYM + +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_ld_force_load" >&5 +printf "%s\n" "$lt_cv_ld_force_load" >&6; } + case $host_os in + rhapsody* | darwin1.[012]) + _lt_dar_allow_undefined='$wl-undefined ${wl}suppress' ;; + darwin1.*) + _lt_dar_allow_undefined='$wl-flat_namespace $wl-undefined ${wl}suppress' ;; + darwin*) + case $MACOSX_DEPLOYMENT_TARGET,$host in + 10.[012],*|,*powerpc*-darwin[5-8]*) + _lt_dar_allow_undefined='$wl-flat_namespace $wl-undefined ${wl}suppress' ;; + *) + _lt_dar_allow_undefined='$wl-undefined ${wl}dynamic_lookup' ;; + esac + ;; + esac + if test yes = "$lt_cv_apple_cc_single_mod"; then + _lt_dar_single_mod='$single_module' + fi + if test yes = "$lt_cv_ld_exported_symbols_list"; then + _lt_dar_export_syms=' $wl-exported_symbols_list,$output_objdir/$libname-symbols.expsym' + else + _lt_dar_export_syms='~$NMEDIT -s $output_objdir/$libname-symbols.expsym $lib' + fi + if test : != "$DSYMUTIL" && test no = "$lt_cv_ld_force_load"; then + _lt_dsymutil='~$DSYMUTIL $lib || :' + else + _lt_dsymutil= + fi + ;; + esac + +# func_munge_path_list VARIABLE PATH +# ----------------------------------- +# VARIABLE is name of variable containing _space_ separated list of +# directories to be munged by the contents of PATH, which is string +# having a format: +# "DIR[:DIR]:" +# string "DIR[ DIR]" will be prepended to VARIABLE +# ":DIR[:DIR]" +# string "DIR[ DIR]" will be appended to VARIABLE +# "DIRP[:DIRP]::[DIRA:]DIRA" +# string "DIRP[ DIRP]" will be prepended to VARIABLE and string +# "DIRA[ DIRA]" will be appended to VARIABLE +# "DIR[:DIR]" +# VARIABLE will be replaced by "DIR[ DIR]" +func_munge_path_list () +{ + case x$2 in + x) + ;; + *:) + eval $1=\"`$ECHO $2 | $SED 's/:/ /g'` \$$1\" + ;; + x:*) + eval $1=\"\$$1 `$ECHO $2 | $SED 's/:/ /g'`\" + ;; + *::*) + eval $1=\"\$$1\ `$ECHO $2 | $SED -e 's/.*:://' -e 's/:/ /g'`\" + eval $1=\"`$ECHO $2 | $SED -e 's/::.*//' -e 's/:/ /g'`\ \$$1\" + ;; + *) + eval $1=\"`$ECHO $2 | $SED 's/:/ /g'`\" + ;; + esac +} + +ac_fn_c_check_header_compile "$LINENO" "dlfcn.h" "ac_cv_header_dlfcn_h" "$ac_includes_default +" +if test "x$ac_cv_header_dlfcn_h" = xyes +then : + printf "%s\n" "#define HAVE_DLFCN_H 1" >>confdefs.h + +fi + + + + + + + + + + + + + + + +xc_lt_want_enable_shared='yes' +xc_lt_want_enable_static='yes' + +case "x$enable_shared" in # ( + xno) + xc_lt_want_enable_shared='no' + ;; +esac +case "x$enable_static" in # ( + xno) + xc_lt_want_enable_static='no' + ;; +esac +if test "$xc_lt_want_enable_shared" = "no" && + test "$xc_lt_want_enable_static" = "no"; then + as_fn_error $? "can not disable shared and static libraries simultaneously" "$LINENO" 5 +fi + + +if test "$xc_lt_want_enable_shared" = "yes" && + test "$xc_lt_want_enable_static" = "yes"; then + case $host_os in # ( + os2* | aix*) + xc_lt_want_enable_static='no' + ;; + esac +fi + + +enable_shared=$xc_lt_want_enable_shared +enable_static=$xc_lt_want_enable_static + + +xc_lt_want_with_pic='default' + + +case "x$with_pic" in # (( + xno) + xc_lt_want_with_pic='no' + ;; + xyes) + xc_lt_want_with_pic='yes' + ;; +esac + + +if test "$xc_lt_want_with_pic" = "default"; then + case $host_cpu in # ( + x86_64 | amd64 | ia64) + case $host_os in # ( + linux* | freebsd* | midnightbsd*) + xc_lt_want_with_pic='yes' + ;; + esac + ;; + esac +fi + +# +# Make libtool aware of current PIC preference taking in account that, +# depending on host characteristics, libtool may modify PIC default +# behavior to fit host system idiosyncrasies later in this script. +# + +with_pic=$xc_lt_want_with_pic + + + + + + + + + +# Set options +enable_win32_dll=yes + +case $host in +*-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-cegcc*) + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}as", so it can be a program name with args. +set dummy ${ac_tool_prefix}as; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_AS+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$AS"; then + ac_cv_prog_AS="$AS" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_AS="${ac_tool_prefix}as" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +AS=$ac_cv_prog_AS +if test -n "$AS"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $AS" >&5 +printf "%s\n" "$AS" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_AS"; then + ac_ct_AS=$AS + # Extract the first word of "as", so it can be a program name with args. +set dummy as; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_ac_ct_AS+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$ac_ct_AS"; then + ac_cv_prog_ac_ct_AS="$ac_ct_AS" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_AS="as" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_AS=$ac_cv_prog_ac_ct_AS +if test -n "$ac_ct_AS"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_AS" >&5 +printf "%s\n" "$ac_ct_AS" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_ct_AS" = x; then + AS="false" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + AS=$ac_ct_AS + fi +else + AS="$ac_cv_prog_AS" +fi + + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}dlltool", so it can be a program name with args. +set dummy ${ac_tool_prefix}dlltool; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_DLLTOOL+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$DLLTOOL"; then + ac_cv_prog_DLLTOOL="$DLLTOOL" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_DLLTOOL="${ac_tool_prefix}dlltool" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +DLLTOOL=$ac_cv_prog_DLLTOOL +if test -n "$DLLTOOL"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $DLLTOOL" >&5 +printf "%s\n" "$DLLTOOL" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_DLLTOOL"; then + ac_ct_DLLTOOL=$DLLTOOL + # Extract the first word of "dlltool", so it can be a program name with args. +set dummy dlltool; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_ac_ct_DLLTOOL+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$ac_ct_DLLTOOL"; then + ac_cv_prog_ac_ct_DLLTOOL="$ac_ct_DLLTOOL" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_DLLTOOL="dlltool" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_DLLTOOL=$ac_cv_prog_ac_ct_DLLTOOL +if test -n "$ac_ct_DLLTOOL"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_DLLTOOL" >&5 +printf "%s\n" "$ac_ct_DLLTOOL" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_ct_DLLTOOL" = x; then + DLLTOOL="false" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + DLLTOOL=$ac_ct_DLLTOOL + fi +else + DLLTOOL="$ac_cv_prog_DLLTOOL" +fi + + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}objdump", so it can be a program name with args. +set dummy ${ac_tool_prefix}objdump; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_OBJDUMP+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$OBJDUMP"; then + ac_cv_prog_OBJDUMP="$OBJDUMP" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_OBJDUMP="${ac_tool_prefix}objdump" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +OBJDUMP=$ac_cv_prog_OBJDUMP +if test -n "$OBJDUMP"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $OBJDUMP" >&5 +printf "%s\n" "$OBJDUMP" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_OBJDUMP"; then + ac_ct_OBJDUMP=$OBJDUMP + # Extract the first word of "objdump", so it can be a program name with args. +set dummy objdump; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_ac_ct_OBJDUMP+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$ac_ct_OBJDUMP"; then + ac_cv_prog_ac_ct_OBJDUMP="$ac_ct_OBJDUMP" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_OBJDUMP="objdump" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_OBJDUMP=$ac_cv_prog_ac_ct_OBJDUMP +if test -n "$ac_ct_OBJDUMP"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_OBJDUMP" >&5 +printf "%s\n" "$ac_ct_OBJDUMP" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_ct_OBJDUMP" = x; then + OBJDUMP="false" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + OBJDUMP=$ac_ct_OBJDUMP + fi +else + OBJDUMP="$ac_cv_prog_OBJDUMP" +fi + + ;; +esac + +test -z "$AS" && AS=as + + + + + +test -z "$DLLTOOL" && DLLTOOL=dlltool + + + + + +test -z "$OBJDUMP" && OBJDUMP=objdump + + + + + + + + enable_dlopen=no + + + + # Check whether --enable-shared was given. +if test ${enable_shared+y} +then : + enableval=$enable_shared; p=${PACKAGE-default} + case $enableval in + yes) enable_shared=yes ;; + no) enable_shared=no ;; + *) + enable_shared=no + # Look at the argument we got. We use all the common list separators. + lt_save_ifs=$IFS; IFS=$IFS$PATH_SEPARATOR, + for pkg in $enableval; do + IFS=$lt_save_ifs + if test "X$pkg" = "X$p"; then + enable_shared=yes + fi + done + IFS=$lt_save_ifs + ;; + esac +else $as_nop + enable_shared=yes +fi + + + + + + + + + + # Check whether --enable-static was given. +if test ${enable_static+y} +then : + enableval=$enable_static; p=${PACKAGE-default} + case $enableval in + yes) enable_static=yes ;; + no) enable_static=no ;; + *) + enable_static=no + # Look at the argument we got. We use all the common list separators. + lt_save_ifs=$IFS; IFS=$IFS$PATH_SEPARATOR, + for pkg in $enableval; do + IFS=$lt_save_ifs + if test "X$pkg" = "X$p"; then + enable_static=yes + fi + done + IFS=$lt_save_ifs + ;; + esac +else $as_nop + enable_static=yes +fi + + + + + + + + + + +# Check whether --with-pic was given. +if test ${with_pic+y} +then : + withval=$with_pic; lt_p=${PACKAGE-default} + case $withval in + yes|no) pic_mode=$withval ;; + *) + pic_mode=default + # Look at the argument we got. We use all the common list separators. + lt_save_ifs=$IFS; IFS=$IFS$PATH_SEPARATOR, + for lt_pkg in $withval; do + IFS=$lt_save_ifs + if test "X$lt_pkg" = "X$lt_p"; then + pic_mode=yes + fi + done + IFS=$lt_save_ifs + ;; + esac +else $as_nop + pic_mode=default +fi + + + + + + + + + # Check whether --enable-fast-install was given. +if test ${enable_fast_install+y} +then : + enableval=$enable_fast_install; p=${PACKAGE-default} + case $enableval in + yes) enable_fast_install=yes ;; + no) enable_fast_install=no ;; + *) + enable_fast_install=no + # Look at the argument we got. We use all the common list separators. + lt_save_ifs=$IFS; IFS=$IFS$PATH_SEPARATOR, + for pkg in $enableval; do + IFS=$lt_save_ifs + if test "X$pkg" = "X$p"; then + enable_fast_install=yes + fi + done + IFS=$lt_save_ifs + ;; + esac +else $as_nop + enable_fast_install=yes +fi + + + + + + + + + shared_archive_member_spec= +case $host,$enable_shared in +power*-*-aix[5-9]*,yes) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking which variant of shared library versioning to provide" >&5 +printf %s "checking which variant of shared library versioning to provide... " >&6; } + +# Check whether --with-aix-soname was given. +if test ${with_aix_soname+y} +then : + withval=$with_aix_soname; case $withval in + aix|svr4|both) + ;; + *) + as_fn_error $? "Unknown argument to --with-aix-soname" "$LINENO" 5 + ;; + esac + lt_cv_with_aix_soname=$with_aix_soname +else $as_nop + if test ${lt_cv_with_aix_soname+y} +then : + printf %s "(cached) " >&6 +else $as_nop + lt_cv_with_aix_soname=aix +fi + + with_aix_soname=$lt_cv_with_aix_soname +fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $with_aix_soname" >&5 +printf "%s\n" "$with_aix_soname" >&6; } + if test aix != "$with_aix_soname"; then + # For the AIX way of multilib, we name the shared archive member + # based on the bitwidth used, traditionally 'shr.o' or 'shr_64.o', + # and 'shr.imp' or 'shr_64.imp', respectively, for the Import File. + # Even when GNU compilers ignore OBJECT_MODE but need '-maix64' flag, + # the AIX toolchain works better with OBJECT_MODE set (default 32). + if test 64 = "${OBJECT_MODE-32}"; then + shared_archive_member_spec=shr_64 + else + shared_archive_member_spec=shr + fi + fi + ;; +*) + with_aix_soname=aix + ;; +esac + + + + + + + + + + +# This can be used to rebuild libtool when needed +LIBTOOL_DEPS=$ltmain + +# Always use our own libtool. +LIBTOOL='$(SHELL) $(top_builddir)/libtool' + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +test -z "$LN_S" && LN_S="ln -s" + + + + + + + + + + + + + + +if test -n "${ZSH_VERSION+set}"; then + setopt NO_GLOB_SUBST +fi + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for objdir" >&5 +printf %s "checking for objdir... " >&6; } +if test ${lt_cv_objdir+y} +then : + printf %s "(cached) " >&6 +else $as_nop + rm -f .libs 2>/dev/null +mkdir .libs 2>/dev/null +if test -d .libs; then + lt_cv_objdir=.libs +else + # MS-DOS does not allow filenames that begin with a dot. + lt_cv_objdir=_libs +fi +rmdir .libs 2>/dev/null +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_objdir" >&5 +printf "%s\n" "$lt_cv_objdir" >&6; } +objdir=$lt_cv_objdir + + + + + +printf "%s\n" "#define LT_OBJDIR \"$lt_cv_objdir/\"" >>confdefs.h + + + + +case $host_os in +aix3*) + # AIX sometimes has problems with the GCC collect2 program. For some + # reason, if we set the COLLECT_NAMES environment variable, the problems + # vanish in a puff of smoke. + if test set != "${COLLECT_NAMES+set}"; then + COLLECT_NAMES= + export COLLECT_NAMES + fi + ;; +esac + +# Global variables: +ofile=libtool +can_build_shared=yes + +# All known linkers require a '.a' archive for static linking (except MSVC and +# ICC, which need '.lib'). +libext=a + +with_gnu_ld=$lt_cv_prog_gnu_ld + +old_CC=$CC +old_CFLAGS=$CFLAGS + +# Set sane defaults for various variables +test -z "$CC" && CC=cc +test -z "$LTCC" && LTCC=$CC +test -z "$LTCFLAGS" && LTCFLAGS=$CFLAGS +test -z "$LD" && LD=ld +test -z "$ac_objext" && ac_objext=o + +func_cc_basename $compiler +cc_basename=$func_cc_basename_result + + +# Only perform the check for file, if the check method requires it +test -z "$MAGIC_CMD" && MAGIC_CMD=file +case $deplibs_check_method in +file_magic*) + if test "$file_magic_cmd" = '$MAGIC_CMD'; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for ${ac_tool_prefix}file" >&5 +printf %s "checking for ${ac_tool_prefix}file... " >&6; } +if test ${lt_cv_path_MAGIC_CMD+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $MAGIC_CMD in +[\\/*] | ?:[\\/]*) + lt_cv_path_MAGIC_CMD=$MAGIC_CMD # Let the user override the test with a path. + ;; +*) + lt_save_MAGIC_CMD=$MAGIC_CMD + lt_save_ifs=$IFS; IFS=$PATH_SEPARATOR + ac_dummy="/usr/bin$PATH_SEPARATOR$PATH" + for ac_dir in $ac_dummy; do + IFS=$lt_save_ifs + test -z "$ac_dir" && ac_dir=. + if test -f "$ac_dir/${ac_tool_prefix}file"; then + lt_cv_path_MAGIC_CMD=$ac_dir/"${ac_tool_prefix}file" + if test -n "$file_magic_test_file"; then + case $deplibs_check_method in + "file_magic "*) + file_magic_regex=`expr "$deplibs_check_method" : "file_magic \(.*\)"` + MAGIC_CMD=$lt_cv_path_MAGIC_CMD + if eval $file_magic_cmd \$file_magic_test_file 2> /dev/null | + $EGREP "$file_magic_regex" > /dev/null; then + : + else + cat <<_LT_EOF 1>&2 + +*** Warning: the command libtool uses to detect shared libraries, +*** $file_magic_cmd, produces output that libtool cannot recognize. +*** The result is that libtool may fail to recognize shared libraries +*** as such. This will affect the creation of libtool libraries that +*** depend on shared libraries, but programs linked with such libtool +*** libraries will work regardless of this problem. Nevertheless, you +*** may want to report the problem to your system manager and/or to +*** bug-libtool@gnu.org + +_LT_EOF + fi ;; + esac + fi + break + fi + done + IFS=$lt_save_ifs + MAGIC_CMD=$lt_save_MAGIC_CMD + ;; +esac +fi + +MAGIC_CMD=$lt_cv_path_MAGIC_CMD +if test -n "$MAGIC_CMD"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $MAGIC_CMD" >&5 +printf "%s\n" "$MAGIC_CMD" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + + + + +if test -z "$lt_cv_path_MAGIC_CMD"; then + if test -n "$ac_tool_prefix"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for file" >&5 +printf %s "checking for file... " >&6; } +if test ${lt_cv_path_MAGIC_CMD+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $MAGIC_CMD in +[\\/*] | ?:[\\/]*) + lt_cv_path_MAGIC_CMD=$MAGIC_CMD # Let the user override the test with a path. + ;; +*) + lt_save_MAGIC_CMD=$MAGIC_CMD + lt_save_ifs=$IFS; IFS=$PATH_SEPARATOR + ac_dummy="/usr/bin$PATH_SEPARATOR$PATH" + for ac_dir in $ac_dummy; do + IFS=$lt_save_ifs + test -z "$ac_dir" && ac_dir=. + if test -f "$ac_dir/file"; then + lt_cv_path_MAGIC_CMD=$ac_dir/"file" + if test -n "$file_magic_test_file"; then + case $deplibs_check_method in + "file_magic "*) + file_magic_regex=`expr "$deplibs_check_method" : "file_magic \(.*\)"` + MAGIC_CMD=$lt_cv_path_MAGIC_CMD + if eval $file_magic_cmd \$file_magic_test_file 2> /dev/null | + $EGREP "$file_magic_regex" > /dev/null; then + : + else + cat <<_LT_EOF 1>&2 + +*** Warning: the command libtool uses to detect shared libraries, +*** $file_magic_cmd, produces output that libtool cannot recognize. +*** The result is that libtool may fail to recognize shared libraries +*** as such. This will affect the creation of libtool libraries that +*** depend on shared libraries, but programs linked with such libtool +*** libraries will work regardless of this problem. Nevertheless, you +*** may want to report the problem to your system manager and/or to +*** bug-libtool@gnu.org + +_LT_EOF + fi ;; + esac + fi + break + fi + done + IFS=$lt_save_ifs + MAGIC_CMD=$lt_save_MAGIC_CMD + ;; +esac +fi + +MAGIC_CMD=$lt_cv_path_MAGIC_CMD +if test -n "$MAGIC_CMD"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $MAGIC_CMD" >&5 +printf "%s\n" "$MAGIC_CMD" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + + else + MAGIC_CMD=: + fi +fi + + fi + ;; +esac + +# Use C for the default configuration in the libtool script + +lt_save_CC=$CC +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + +# Source file extension for C test sources. +ac_ext=c + +# Object file extension for compiled C test sources. +objext=o +objext=$objext + +# Code to be used in simple compile tests +lt_simple_compile_test_code="int some_variable = 0;" + +# Code to be used in simple link tests +lt_simple_link_test_code='int main(){return(0);}' + + + + + + + +# If no C compiler was specified, use CC. +LTCC=${LTCC-"$CC"} + +# If no C compiler flags were specified, use CFLAGS. +LTCFLAGS=${LTCFLAGS-"$CFLAGS"} + +# Allow CC to be a program name with arguments. +compiler=$CC + +# Save the default compiler, since it gets overwritten when the other +# tags are being tested, and _LT_TAGVAR(compiler, []) is a NOP. +compiler_DEFAULT=$CC + +# save warnings/boilerplate of simple test code +ac_outfile=conftest.$ac_objext +echo "$lt_simple_compile_test_code" >conftest.$ac_ext +eval "$ac_compile" 2>&1 >/dev/null | $SED '/^$/d; /^ *+/d' >conftest.err +_lt_compiler_boilerplate=`cat conftest.err` +$RM conftest* + +ac_outfile=conftest.$ac_objext +echo "$lt_simple_link_test_code" >conftest.$ac_ext +eval "$ac_link" 2>&1 >/dev/null | $SED '/^$/d; /^ *+/d' >conftest.err +_lt_linker_boilerplate=`cat conftest.err` +$RM -r conftest* + + +## CAVEAT EMPTOR: +## There is no encapsulation within the following macros, do not change +## the running order or otherwise move them around unless you know exactly +## what you are doing... +if test -n "$compiler"; then + +lt_prog_compiler_no_builtin_flag= + +if test yes = "$GCC"; then + case $cc_basename in + nvcc*) + lt_prog_compiler_no_builtin_flag=' -Xcompiler -fno-builtin' ;; + *) + lt_prog_compiler_no_builtin_flag=' -fno-builtin' ;; + esac + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if $compiler supports -fno-rtti -fno-exceptions" >&5 +printf %s "checking if $compiler supports -fno-rtti -fno-exceptions... " >&6; } +if test ${lt_cv_prog_compiler_rtti_exceptions+y} +then : + printf %s "(cached) " >&6 +else $as_nop + lt_cv_prog_compiler_rtti_exceptions=no + ac_outfile=conftest.$ac_objext + echo "$lt_simple_compile_test_code" > conftest.$ac_ext + lt_compiler_flag="-fno-rtti -fno-exceptions" ## exclude from sc_useless_quotes_in_assignment + # Insert the option either (1) after the last *FLAGS variable, or + # (2) before a word containing "conftest.", or (3) at the end. + # Note that $ac_compile itself does not contain backslashes and begins + # with a dollar sign (not a hyphen), so the echo should work correctly. + # The option is referenced via a variable to avoid confusing sed. + lt_compile=`echo "$ac_compile" | $SED \ + -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ + -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ + -e 's:$: $lt_compiler_flag:'` + (eval echo "\"\$as_me:$LINENO: $lt_compile\"" >&5) + (eval "$lt_compile" 2>conftest.err) + ac_status=$? + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + if (exit $ac_status) && test -s "$ac_outfile"; then + # The compiler can only warn and ignore the option if not recognized + # So say no if there are warnings other than the usual output. + $ECHO "$_lt_compiler_boilerplate" | $SED '/^$/d' >conftest.exp + $SED '/^$/d; /^ *+/d' conftest.err >conftest.er2 + if test ! -s conftest.er2 || diff conftest.exp conftest.er2 >/dev/null; then + lt_cv_prog_compiler_rtti_exceptions=yes + fi + fi + $RM conftest* + +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_rtti_exceptions" >&5 +printf "%s\n" "$lt_cv_prog_compiler_rtti_exceptions" >&6; } + +if test yes = "$lt_cv_prog_compiler_rtti_exceptions"; then + lt_prog_compiler_no_builtin_flag="$lt_prog_compiler_no_builtin_flag -fno-rtti -fno-exceptions" +else + : +fi + +fi + + + + + + + lt_prog_compiler_wl= +lt_prog_compiler_pic= +lt_prog_compiler_static= + + + if test yes = "$GCC"; then + lt_prog_compiler_wl='-Wl,' + lt_prog_compiler_static='-static' + + case $host_os in + aix*) + # All AIX code is PIC. + if test ia64 = "$host_cpu"; then + # AIX 5 now supports IA64 processor + lt_prog_compiler_static='-Bstatic' + fi + lt_prog_compiler_pic='-fPIC' + ;; + + amigaos*) + case $host_cpu in + powerpc) + # see comment about AmigaOS4 .so support + lt_prog_compiler_pic='-fPIC' + ;; + m68k) + # FIXME: we need at least 68020 code to build shared libraries, but + # adding the '-m68020' flag to GCC prevents building anything better, + # like '-m68040'. + lt_prog_compiler_pic='-m68020 -resident32 -malways-restore-a4' + ;; + esac + ;; + + beos* | irix5* | irix6* | nonstopux* | osf3* | osf4* | osf5*) + # PIC is the default for these OSes. + ;; + + mingw* | cygwin* | pw32* | os2* | cegcc*) + # This hack is so that the source file can tell whether it is being + # built for inclusion in a dll (and should export symbols for example). + # Although the cygwin gcc ignores -fPIC, still need this for old-style + # (--disable-auto-import) libraries + lt_prog_compiler_pic='-DDLL_EXPORT' + case $host_os in + os2*) + lt_prog_compiler_static='$wl-static' + ;; + esac + ;; + + darwin* | rhapsody*) + # PIC is the default on this platform + # Common symbols not allowed in MH_DYLIB files + lt_prog_compiler_pic='-fno-common' + ;; + + haiku*) + # PIC is the default for Haiku. + # The "-static" flag exists, but is broken. + lt_prog_compiler_static= + ;; + + hpux*) + # PIC is the default for 64-bit PA HP-UX, but not for 32-bit + # PA HP-UX. On IA64 HP-UX, PIC is the default but the pic flag + # sets the default TLS model and affects inlining. + case $host_cpu in + hppa*64*) + # +Z the default + ;; + *) + lt_prog_compiler_pic='-fPIC' + ;; + esac + ;; + + interix[3-9]*) + # Interix 3.x gcc -fpic/-fPIC options generate broken code. + # Instead, we relocate shared libraries at runtime. + ;; + + msdosdjgpp*) + # Just because we use GCC doesn't mean we suddenly get shared libraries + # on systems that don't support them. + lt_prog_compiler_can_build_shared=no + enable_shared=no + ;; + + *nto* | *qnx*) + # QNX uses GNU C++, but need to define -shared option too, otherwise + # it will coredump. + lt_prog_compiler_pic='-fPIC -shared' + ;; + + sysv4*MP*) + if test -d /usr/nec; then + lt_prog_compiler_pic=-Kconform_pic + fi + ;; + + *) + lt_prog_compiler_pic='-fPIC' + ;; + esac + + case $cc_basename in + nvcc*) # Cuda Compiler Driver 2.2 + lt_prog_compiler_wl='-Xlinker ' + if test -n "$lt_prog_compiler_pic"; then + lt_prog_compiler_pic="-Xcompiler $lt_prog_compiler_pic" + fi + ;; + esac + else + # PORTME Check for flag to pass linker flags through the system compiler. + case $host_os in + aix*) + lt_prog_compiler_wl='-Wl,' + if test ia64 = "$host_cpu"; then + # AIX 5 now supports IA64 processor + lt_prog_compiler_static='-Bstatic' + else + lt_prog_compiler_static='-bnso -bI:/lib/syscalls.exp' + fi + ;; + + darwin* | rhapsody*) + # PIC is the default on this platform + # Common symbols not allowed in MH_DYLIB files + lt_prog_compiler_pic='-fno-common' + case $cc_basename in + nagfor*) + # NAG Fortran compiler + lt_prog_compiler_wl='-Wl,-Wl,,' + lt_prog_compiler_pic='-PIC' + lt_prog_compiler_static='-Bstatic' + ;; + esac + ;; + + mingw* | cygwin* | pw32* | os2* | cegcc*) + # This hack is so that the source file can tell whether it is being + # built for inclusion in a dll (and should export symbols for example). + lt_prog_compiler_pic='-DDLL_EXPORT' + case $host_os in + os2*) + lt_prog_compiler_static='$wl-static' + ;; + esac + ;; + + hpux9* | hpux10* | hpux11*) + lt_prog_compiler_wl='-Wl,' + # PIC is the default for IA64 HP-UX and 64-bit HP-UX, but + # not for PA HP-UX. + case $host_cpu in + hppa*64*|ia64*) + # +Z the default + ;; + *) + lt_prog_compiler_pic='+Z' + ;; + esac + # Is there a better lt_prog_compiler_static that works with the bundled CC? + lt_prog_compiler_static='$wl-a ${wl}archive' + ;; + + irix5* | irix6* | nonstopux*) + lt_prog_compiler_wl='-Wl,' + # PIC (with -KPIC) is the default. + lt_prog_compiler_static='-non_shared' + ;; + + linux* | k*bsd*-gnu | kopensolaris*-gnu | gnu*) + case $cc_basename in + # old Intel for x86_64, which still supported -KPIC. + ecc*) + lt_prog_compiler_wl='-Wl,' + lt_prog_compiler_pic='-KPIC' + lt_prog_compiler_static='-static' + ;; + # flang / f18. f95 an alias for gfortran or flang on Debian + flang* | f18* | f95*) + lt_prog_compiler_wl='-Wl,' + lt_prog_compiler_pic='-fPIC' + lt_prog_compiler_static='-static' + ;; + # icc used to be incompatible with GCC. + # ICC 10 doesn't accept -KPIC any more. + icc* | ifort*) + lt_prog_compiler_wl='-Wl,' + lt_prog_compiler_pic='-fPIC' + lt_prog_compiler_static='-static' + ;; + # Lahey Fortran 8.1. + lf95*) + lt_prog_compiler_wl='-Wl,' + lt_prog_compiler_pic='--shared' + lt_prog_compiler_static='--static' + ;; + nagfor*) + # NAG Fortran compiler + lt_prog_compiler_wl='-Wl,-Wl,,' + lt_prog_compiler_pic='-PIC' + lt_prog_compiler_static='-Bstatic' + ;; + tcc*) + # Fabrice Bellard et al's Tiny C Compiler + lt_prog_compiler_wl='-Wl,' + lt_prog_compiler_pic='-fPIC' + lt_prog_compiler_static='-static' + ;; + pgcc* | pgf77* | pgf90* | pgf95* | pgfortran*) + # Portland Group compilers (*not* the Pentium gcc compiler, + # which looks to be a dead project) + lt_prog_compiler_wl='-Wl,' + lt_prog_compiler_pic='-fpic' + lt_prog_compiler_static='-Bstatic' + ;; + ccc*) + lt_prog_compiler_wl='-Wl,' + # All Alpha code is PIC. + lt_prog_compiler_static='-non_shared' + ;; + xl* | bgxl* | bgf* | mpixl*) + # IBM XL C 8.0/Fortran 10.1, 11.1 on PPC and BlueGene + lt_prog_compiler_wl='-Wl,' + lt_prog_compiler_pic='-qpic' + lt_prog_compiler_static='-qstaticlink' + ;; + *) + case `$CC -V 2>&1 | $SED 5q` in + *Sun\ Ceres\ Fortran* | *Sun*Fortran*\ [1-7].* | *Sun*Fortran*\ 8.[0-3]*) + # Sun Fortran 8.3 passes all unrecognized flags to the linker + lt_prog_compiler_pic='-KPIC' + lt_prog_compiler_static='-Bstatic' + lt_prog_compiler_wl='' + ;; + *Sun\ F* | *Sun*Fortran*) + lt_prog_compiler_pic='-KPIC' + lt_prog_compiler_static='-Bstatic' + lt_prog_compiler_wl='-Qoption ld ' + ;; + *Sun\ C*) + # Sun C 5.9 + lt_prog_compiler_pic='-KPIC' + lt_prog_compiler_static='-Bstatic' + lt_prog_compiler_wl='-Wl,' + ;; + *Intel*\ [CF]*Compiler*) + lt_prog_compiler_wl='-Wl,' + lt_prog_compiler_pic='-fPIC' + lt_prog_compiler_static='-static' + ;; + *Portland\ Group*) + lt_prog_compiler_wl='-Wl,' + lt_prog_compiler_pic='-fpic' + lt_prog_compiler_static='-Bstatic' + ;; + esac + ;; + esac + ;; + + newsos6) + lt_prog_compiler_pic='-KPIC' + lt_prog_compiler_static='-Bstatic' + ;; + + *nto* | *qnx*) + # QNX uses GNU C++, but need to define -shared option too, otherwise + # it will coredump. + lt_prog_compiler_pic='-fPIC -shared' + ;; + + osf3* | osf4* | osf5*) + lt_prog_compiler_wl='-Wl,' + # All OSF/1 code is PIC. + lt_prog_compiler_static='-non_shared' + ;; + + rdos*) + lt_prog_compiler_static='-non_shared' + ;; + + solaris*) + lt_prog_compiler_pic='-KPIC' + lt_prog_compiler_static='-Bstatic' + case $cc_basename in + f77* | f90* | f95* | sunf77* | sunf90* | sunf95*) + lt_prog_compiler_wl='-Qoption ld ';; + *) + lt_prog_compiler_wl='-Wl,';; + esac + ;; + + sunos4*) + lt_prog_compiler_wl='-Qoption ld ' + lt_prog_compiler_pic='-PIC' + lt_prog_compiler_static='-Bstatic' + ;; + + sysv4 | sysv4.2uw2* | sysv4.3*) + lt_prog_compiler_wl='-Wl,' + lt_prog_compiler_pic='-KPIC' + lt_prog_compiler_static='-Bstatic' + ;; + + sysv4*MP*) + if test -d /usr/nec; then + lt_prog_compiler_pic='-Kconform_pic' + lt_prog_compiler_static='-Bstatic' + fi + ;; + + sysv5* | unixware* | sco3.2v5* | sco5v6* | OpenUNIX*) + lt_prog_compiler_wl='-Wl,' + lt_prog_compiler_pic='-KPIC' + lt_prog_compiler_static='-Bstatic' + ;; + + unicos*) + lt_prog_compiler_wl='-Wl,' + lt_prog_compiler_can_build_shared=no + ;; + + uts4*) + lt_prog_compiler_pic='-pic' + lt_prog_compiler_static='-Bstatic' + ;; + + *) + lt_prog_compiler_can_build_shared=no + ;; + esac + fi + +case $host_os in + # For platforms that do not support PIC, -DPIC is meaningless: + *djgpp*) + lt_prog_compiler_pic= + ;; + *) + lt_prog_compiler_pic="$lt_prog_compiler_pic -DPIC" + ;; +esac + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $compiler option to produce PIC" >&5 +printf %s "checking for $compiler option to produce PIC... " >&6; } +if test ${lt_cv_prog_compiler_pic+y} +then : + printf %s "(cached) " >&6 +else $as_nop + lt_cv_prog_compiler_pic=$lt_prog_compiler_pic +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_pic" >&5 +printf "%s\n" "$lt_cv_prog_compiler_pic" >&6; } +lt_prog_compiler_pic=$lt_cv_prog_compiler_pic + +# +# Check to make sure the PIC flag actually works. +# +if test -n "$lt_prog_compiler_pic"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if $compiler PIC flag $lt_prog_compiler_pic works" >&5 +printf %s "checking if $compiler PIC flag $lt_prog_compiler_pic works... " >&6; } +if test ${lt_cv_prog_compiler_pic_works+y} +then : + printf %s "(cached) " >&6 +else $as_nop + lt_cv_prog_compiler_pic_works=no + ac_outfile=conftest.$ac_objext + echo "$lt_simple_compile_test_code" > conftest.$ac_ext + lt_compiler_flag="$lt_prog_compiler_pic -DPIC" ## exclude from sc_useless_quotes_in_assignment + # Insert the option either (1) after the last *FLAGS variable, or + # (2) before a word containing "conftest.", or (3) at the end. + # Note that $ac_compile itself does not contain backslashes and begins + # with a dollar sign (not a hyphen), so the echo should work correctly. + # The option is referenced via a variable to avoid confusing sed. + lt_compile=`echo "$ac_compile" | $SED \ + -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ + -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ + -e 's:$: $lt_compiler_flag:'` + (eval echo "\"\$as_me:$LINENO: $lt_compile\"" >&5) + (eval "$lt_compile" 2>conftest.err) + ac_status=$? + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + if (exit $ac_status) && test -s "$ac_outfile"; then + # The compiler can only warn and ignore the option if not recognized + # So say no if there are warnings other than the usual output. + $ECHO "$_lt_compiler_boilerplate" | $SED '/^$/d' >conftest.exp + $SED '/^$/d; /^ *+/d' conftest.err >conftest.er2 + if test ! -s conftest.er2 || diff conftest.exp conftest.er2 >/dev/null; then + lt_cv_prog_compiler_pic_works=yes + fi + fi + $RM conftest* + +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_pic_works" >&5 +printf "%s\n" "$lt_cv_prog_compiler_pic_works" >&6; } + +if test yes = "$lt_cv_prog_compiler_pic_works"; then + case $lt_prog_compiler_pic in + "" | " "*) ;; + *) lt_prog_compiler_pic=" $lt_prog_compiler_pic" ;; + esac +else + lt_prog_compiler_pic= + lt_prog_compiler_can_build_shared=no +fi + +fi + + + + + + + + + + + +# +# Check to make sure the static flag actually works. +# +wl=$lt_prog_compiler_wl eval lt_tmp_static_flag=\"$lt_prog_compiler_static\" +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if $compiler static flag $lt_tmp_static_flag works" >&5 +printf %s "checking if $compiler static flag $lt_tmp_static_flag works... " >&6; } +if test ${lt_cv_prog_compiler_static_works+y} +then : + printf %s "(cached) " >&6 +else $as_nop + lt_cv_prog_compiler_static_works=no + save_LDFLAGS=$LDFLAGS + LDFLAGS="$LDFLAGS $lt_tmp_static_flag" + echo "$lt_simple_link_test_code" > conftest.$ac_ext + if (eval $ac_link 2>conftest.err) && test -s conftest$ac_exeext; then + # The linker can only warn and ignore the option if not recognized + # So say no if there are warnings + if test -s conftest.err; then + # Append any errors to the config.log. + cat conftest.err 1>&5 + $ECHO "$_lt_linker_boilerplate" | $SED '/^$/d' > conftest.exp + $SED '/^$/d; /^ *+/d' conftest.err >conftest.er2 + if diff conftest.exp conftest.er2 >/dev/null; then + lt_cv_prog_compiler_static_works=yes + fi + else + lt_cv_prog_compiler_static_works=yes + fi + fi + $RM -r conftest* + LDFLAGS=$save_LDFLAGS + +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_static_works" >&5 +printf "%s\n" "$lt_cv_prog_compiler_static_works" >&6; } + +if test yes = "$lt_cv_prog_compiler_static_works"; then + : +else + lt_prog_compiler_static= +fi + + + + + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if $compiler supports -c -o file.$ac_objext" >&5 +printf %s "checking if $compiler supports -c -o file.$ac_objext... " >&6; } +if test ${lt_cv_prog_compiler_c_o+y} +then : + printf %s "(cached) " >&6 +else $as_nop + lt_cv_prog_compiler_c_o=no + $RM -r conftest 2>/dev/null + mkdir conftest + cd conftest + mkdir out + echo "$lt_simple_compile_test_code" > conftest.$ac_ext + + lt_compiler_flag="-o out/conftest2.$ac_objext" + # Insert the option either (1) after the last *FLAGS variable, or + # (2) before a word containing "conftest.", or (3) at the end. + # Note that $ac_compile itself does not contain backslashes and begins + # with a dollar sign (not a hyphen), so the echo should work correctly. + lt_compile=`echo "$ac_compile" | $SED \ + -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ + -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ + -e 's:$: $lt_compiler_flag:'` + (eval echo "\"\$as_me:$LINENO: $lt_compile\"" >&5) + (eval "$lt_compile" 2>out/conftest.err) + ac_status=$? + cat out/conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + if (exit $ac_status) && test -s out/conftest2.$ac_objext + then + # The compiler can only warn and ignore the option if not recognized + # So say no if there are warnings + $ECHO "$_lt_compiler_boilerplate" | $SED '/^$/d' > out/conftest.exp + $SED '/^$/d; /^ *+/d' out/conftest.err >out/conftest.er2 + if test ! -s out/conftest.er2 || diff out/conftest.exp out/conftest.er2 >/dev/null; then + lt_cv_prog_compiler_c_o=yes + fi + fi + chmod u+w . 2>&5 + $RM conftest* + # SGI C++ compiler will create directory out/ii_files/ for + # template instantiation + test -d out/ii_files && $RM out/ii_files/* && rmdir out/ii_files + $RM out/* && rmdir out + cd .. + $RM -r conftest + $RM conftest* + +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_c_o" >&5 +printf "%s\n" "$lt_cv_prog_compiler_c_o" >&6; } + + + + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if $compiler supports -c -o file.$ac_objext" >&5 +printf %s "checking if $compiler supports -c -o file.$ac_objext... " >&6; } +if test ${lt_cv_prog_compiler_c_o+y} +then : + printf %s "(cached) " >&6 +else $as_nop + lt_cv_prog_compiler_c_o=no + $RM -r conftest 2>/dev/null + mkdir conftest + cd conftest + mkdir out + echo "$lt_simple_compile_test_code" > conftest.$ac_ext + + lt_compiler_flag="-o out/conftest2.$ac_objext" + # Insert the option either (1) after the last *FLAGS variable, or + # (2) before a word containing "conftest.", or (3) at the end. + # Note that $ac_compile itself does not contain backslashes and begins + # with a dollar sign (not a hyphen), so the echo should work correctly. + lt_compile=`echo "$ac_compile" | $SED \ + -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ + -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ + -e 's:$: $lt_compiler_flag:'` + (eval echo "\"\$as_me:$LINENO: $lt_compile\"" >&5) + (eval "$lt_compile" 2>out/conftest.err) + ac_status=$? + cat out/conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + if (exit $ac_status) && test -s out/conftest2.$ac_objext + then + # The compiler can only warn and ignore the option if not recognized + # So say no if there are warnings + $ECHO "$_lt_compiler_boilerplate" | $SED '/^$/d' > out/conftest.exp + $SED '/^$/d; /^ *+/d' out/conftest.err >out/conftest.er2 + if test ! -s out/conftest.er2 || diff out/conftest.exp out/conftest.er2 >/dev/null; then + lt_cv_prog_compiler_c_o=yes + fi + fi + chmod u+w . 2>&5 + $RM conftest* + # SGI C++ compiler will create directory out/ii_files/ for + # template instantiation + test -d out/ii_files && $RM out/ii_files/* && rmdir out/ii_files + $RM out/* && rmdir out + cd .. + $RM -r conftest + $RM conftest* + +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_c_o" >&5 +printf "%s\n" "$lt_cv_prog_compiler_c_o" >&6; } + + + + +hard_links=nottested +if test no = "$lt_cv_prog_compiler_c_o" && test no != "$need_locks"; then + # do not overwrite the value of need_locks provided by the user + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if we can lock with hard links" >&5 +printf %s "checking if we can lock with hard links... " >&6; } + hard_links=yes + $RM conftest* + ln conftest.a conftest.b 2>/dev/null && hard_links=no + touch conftest.a + ln conftest.a conftest.b 2>&5 || hard_links=no + ln conftest.a conftest.b 2>/dev/null && hard_links=no + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $hard_links" >&5 +printf "%s\n" "$hard_links" >&6; } + if test no = "$hard_links"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: '$CC' does not support '-c -o', so 'make -j' may be unsafe" >&5 +printf "%s\n" "$as_me: WARNING: '$CC' does not support '-c -o', so 'make -j' may be unsafe" >&2;} + need_locks=warn + fi +else + need_locks=no +fi + + + + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the $compiler linker ($LD) supports shared libraries" >&5 +printf %s "checking whether the $compiler linker ($LD) supports shared libraries... " >&6; } + + runpath_var= + allow_undefined_flag= + always_export_symbols=no + archive_cmds= + archive_expsym_cmds= + compiler_needs_object=no + enable_shared_with_static_runtimes=no + export_dynamic_flag_spec= + export_symbols_cmds='$NM $libobjs $convenience | $global_symbol_pipe | $SED '\''s/.* //'\'' | sort | uniq > $export_symbols' + hardcode_automatic=no + hardcode_direct=no + hardcode_direct_absolute=no + hardcode_libdir_flag_spec= + hardcode_libdir_separator= + hardcode_minus_L=no + hardcode_shlibpath_var=unsupported + inherit_rpath=no + link_all_deplibs=unknown + module_cmds= + module_expsym_cmds= + old_archive_from_new_cmds= + old_archive_from_expsyms_cmds= + thread_safe_flag_spec= + whole_archive_flag_spec= + # include_expsyms should be a list of space-separated symbols to be *always* + # included in the symbol list + include_expsyms= + # exclude_expsyms can be an extended regexp of symbols to exclude + # it will be wrapped by ' (' and ')$', so one must not match beginning or + # end of line. Example: 'a|bc|.*d.*' will exclude the symbols 'a' and 'bc', + # as well as any symbol that contains 'd'. + exclude_expsyms='_GLOBAL_OFFSET_TABLE_|_GLOBAL__F[ID]_.*' + # Although _GLOBAL_OFFSET_TABLE_ is a valid symbol C name, most a.out + # platforms (ab)use it in PIC code, but their linkers get confused if + # the symbol is explicitly referenced. Since portable code cannot + # rely on this symbol name, it's probably fine to never include it in + # preloaded symbol tables. + # Exclude shared library initialization/finalization symbols. + extract_expsyms_cmds= + + case $host_os in + cygwin* | mingw* | pw32* | cegcc*) + # FIXME: the MSVC++ and ICC port hasn't been tested in a loooong time + # When not using gcc, we currently assume that we are using + # Microsoft Visual C++ or Intel C++ Compiler. + if test yes != "$GCC"; then + with_gnu_ld=no + fi + ;; + interix*) + # we just hope/assume this is gcc and not c89 (= MSVC++ or ICC) + with_gnu_ld=yes + ;; + openbsd* | bitrig*) + with_gnu_ld=no + ;; + linux* | k*bsd*-gnu | gnu*) + link_all_deplibs=no + ;; + esac + + ld_shlibs=yes + + # On some targets, GNU ld is compatible enough with the native linker + # that we're better off using the native interface for both. + lt_use_gnu_ld_interface=no + if test yes = "$with_gnu_ld"; then + case $host_os in + aix*) + # The AIX port of GNU ld has always aspired to compatibility + # with the native linker. However, as the warning in the GNU ld + # block says, versions before 2.19.5* couldn't really create working + # shared libraries, regardless of the interface used. + case `$LD -v 2>&1` in + *\ \(GNU\ Binutils\)\ 2.19.5*) ;; + *\ \(GNU\ Binutils\)\ 2.[2-9]*) ;; + *\ \(GNU\ Binutils\)\ [3-9]*) ;; + *) + lt_use_gnu_ld_interface=yes + ;; + esac + ;; + *) + lt_use_gnu_ld_interface=yes + ;; + esac + fi + + if test yes = "$lt_use_gnu_ld_interface"; then + # If archive_cmds runs LD, not CC, wlarc should be empty + wlarc='$wl' + + # Set some defaults for GNU ld with shared library support. These + # are reset later if shared libraries are not supported. Putting them + # here allows them to be overridden if necessary. + runpath_var=LD_RUN_PATH + hardcode_libdir_flag_spec='$wl-rpath $wl$libdir' + export_dynamic_flag_spec='$wl--export-dynamic' + # ancient GNU ld didn't support --whole-archive et. al. + if $LD --help 2>&1 | $GREP 'no-whole-archive' > /dev/null; then + whole_archive_flag_spec=$wlarc'--whole-archive$convenience '$wlarc'--no-whole-archive' + else + whole_archive_flag_spec= + fi + supports_anon_versioning=no + case `$LD -v | $SED -e 's/([^)]\+)\s\+//' 2>&1` in + *GNU\ gold*) supports_anon_versioning=yes ;; + *\ [01].* | *\ 2.[0-9].* | *\ 2.10.*) ;; # catch versions < 2.11 + *\ 2.11.93.0.2\ *) supports_anon_versioning=yes ;; # RH7.3 ... + *\ 2.11.92.0.12\ *) supports_anon_versioning=yes ;; # Mandrake 8.2 ... + *\ 2.11.*) ;; # other 2.11 versions + *) supports_anon_versioning=yes ;; + esac + + # See if GNU ld supports shared libraries. + case $host_os in + aix[3-9]*) + # On AIX/PPC, the GNU linker is very broken + if test ia64 != "$host_cpu"; then + ld_shlibs=no + cat <<_LT_EOF 1>&2 + +*** Warning: the GNU linker, at least up to release 2.19, is reported +*** to be unable to reliably create shared libraries on AIX. +*** Therefore, libtool is disabling shared libraries support. If you +*** really care for shared libraries, you may want to install binutils +*** 2.20 or above, or modify your PATH so that a non-GNU linker is found. +*** You will then need to restart the configuration process. + +_LT_EOF + fi + ;; + + amigaos*) + case $host_cpu in + powerpc) + # see comment about AmigaOS4 .so support + archive_cmds='$CC -shared $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' + archive_expsym_cmds='' + ;; + m68k) + archive_cmds='$RM $output_objdir/a2ixlibrary.data~$ECHO "#define NAME $libname" > $output_objdir/a2ixlibrary.data~$ECHO "#define LIBRARY_ID 1" >> $output_objdir/a2ixlibrary.data~$ECHO "#define VERSION $major" >> $output_objdir/a2ixlibrary.data~$ECHO "#define REVISION $revision" >> $output_objdir/a2ixlibrary.data~$AR $AR_FLAGS $lib $libobjs~$RANLIB $lib~(cd $output_objdir && a2ixlibrary -32)' + hardcode_libdir_flag_spec='-L$libdir' + hardcode_minus_L=yes + ;; + esac + ;; + + beos*) + if $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then + allow_undefined_flag=unsupported + # Joseph Beckenbach says some releases of gcc + # support --undefined. This deserves some investigation. FIXME + archive_cmds='$CC -nostart $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' + else + ld_shlibs=no + fi + ;; + + cygwin* | mingw* | pw32* | cegcc*) + # _LT_TAGVAR(hardcode_libdir_flag_spec, ) is actually meaningless, + # as there is no search path for DLLs. + hardcode_libdir_flag_spec='-L$libdir' + export_dynamic_flag_spec='$wl--export-all-symbols' + allow_undefined_flag=unsupported + always_export_symbols=no + enable_shared_with_static_runtimes=yes + export_symbols_cmds='$NM $libobjs $convenience | $global_symbol_pipe | $SED -e '\''/^[BCDGRS][ ]/s/.*[ ]\([^ ]*\)/\1 DATA/;s/^.*[ ]__nm__\([^ ]*\)[ ][^ ]*/\1 DATA/;/^I[ ]/d;/^[AITW][ ]/s/.* //'\'' | sort | uniq > $export_symbols' + exclude_expsyms='[_]+GLOBAL_OFFSET_TABLE_|[_]+GLOBAL__[FID]_.*|[_]+head_[A-Za-z0-9_]+_dll|[A-Za-z0-9_]+_dll_iname' + + if $LD --help 2>&1 | $GREP 'auto-import' > /dev/null; then + archive_cmds='$CC -shared $libobjs $deplibs $compiler_flags -o $output_objdir/$soname $wl--enable-auto-image-base -Xlinker --out-implib -Xlinker $lib' + # If the export-symbols file already is a .def file, use it as + # is; otherwise, prepend EXPORTS... + archive_expsym_cmds='if test DEF = "`$SED -n -e '\''s/^[ ]*//'\'' -e '\''/^\(;.*\)*$/d'\'' -e '\''s/^\(EXPORTS\|LIBRARY\)\([ ].*\)*$/DEF/p'\'' -e q $export_symbols`" ; then + cp $export_symbols $output_objdir/$soname.def; + else + echo EXPORTS > $output_objdir/$soname.def; + cat $export_symbols >> $output_objdir/$soname.def; + fi~ + $CC -shared $output_objdir/$soname.def $libobjs $deplibs $compiler_flags -o $output_objdir/$soname $wl--enable-auto-image-base -Xlinker --out-implib -Xlinker $lib' + else + ld_shlibs=no + fi + ;; + + haiku*) + archive_cmds='$CC -shared $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' + link_all_deplibs=yes + ;; + + os2*) + hardcode_libdir_flag_spec='-L$libdir' + hardcode_minus_L=yes + allow_undefined_flag=unsupported + shrext_cmds=.dll + archive_cmds='$ECHO "LIBRARY ${soname%$shared_ext} INITINSTANCE TERMINSTANCE" > $output_objdir/$libname.def~ + $ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~ + $ECHO "DATA MULTIPLE NONSHARED" >> $output_objdir/$libname.def~ + $ECHO EXPORTS >> $output_objdir/$libname.def~ + emxexp $libobjs | $SED /"_DLL_InitTerm"/d >> $output_objdir/$libname.def~ + $CC -Zdll -Zcrtdll -o $output_objdir/$soname $libobjs $deplibs $compiler_flags $output_objdir/$libname.def~ + emximp -o $lib $output_objdir/$libname.def' + archive_expsym_cmds='$ECHO "LIBRARY ${soname%$shared_ext} INITINSTANCE TERMINSTANCE" > $output_objdir/$libname.def~ + $ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~ + $ECHO "DATA MULTIPLE NONSHARED" >> $output_objdir/$libname.def~ + $ECHO EXPORTS >> $output_objdir/$libname.def~ + prefix_cmds="$SED"~ + if test EXPORTS = "`$SED 1q $export_symbols`"; then + prefix_cmds="$prefix_cmds -e 1d"; + fi~ + prefix_cmds="$prefix_cmds -e \"s/^\(.*\)$/_\1/g\""~ + cat $export_symbols | $prefix_cmds >> $output_objdir/$libname.def~ + $CC -Zdll -Zcrtdll -o $output_objdir/$soname $libobjs $deplibs $compiler_flags $output_objdir/$libname.def~ + emximp -o $lib $output_objdir/$libname.def' + old_archive_From_new_cmds='emximp -o $output_objdir/${libname}_dll.a $output_objdir/$libname.def' + enable_shared_with_static_runtimes=yes + file_list_spec='@' + ;; + + interix[3-9]*) + hardcode_direct=no + hardcode_shlibpath_var=no + hardcode_libdir_flag_spec='$wl-rpath,$libdir' + export_dynamic_flag_spec='$wl-E' + # Hack: On Interix 3.x, we cannot compile PIC because of a broken gcc. + # Instead, shared libraries are loaded at an image base (0x10000000 by + # default) and relocated if they conflict, which is a slow very memory + # consuming and fragmenting process. To avoid this, we pick a random, + # 256 KiB-aligned image base between 0x50000000 and 0x6FFC0000 at link + # time. Moving up from 0x10000000 also allows more sbrk(2) space. + archive_cmds='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-h,$soname $wl--image-base,`expr ${RANDOM-$$} % 4096 / 2 \* 262144 + 1342177280` -o $lib' + archive_expsym_cmds='$SED "s|^|_|" $export_symbols >$output_objdir/$soname.expsym~$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-h,$soname $wl--retain-symbols-file,$output_objdir/$soname.expsym $wl--image-base,`expr ${RANDOM-$$} % 4096 / 2 \* 262144 + 1342177280` -o $lib' + ;; + + gnu* | linux* | tpf* | k*bsd*-gnu | kopensolaris*-gnu) + tmp_diet=no + if test linux-dietlibc = "$host_os"; then + case $cc_basename in + diet\ *) tmp_diet=yes;; # linux-dietlibc with static linking (!diet-dyn) + esac + fi + if $LD --help 2>&1 | $EGREP ': supported targets:.* elf' > /dev/null \ + && test no = "$tmp_diet" + then + tmp_addflag=' $pic_flag' + tmp_sharedflag='-shared' + case $cc_basename,$host_cpu in + pgcc*) # Portland Group C compiler + whole_archive_flag_spec='$wl--whole-archive`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` $wl--no-whole-archive' + tmp_addflag=' $pic_flag' + ;; + pgf77* | pgf90* | pgf95* | pgfortran*) + # Portland Group f77 and f90 compilers + whole_archive_flag_spec='$wl--whole-archive`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` $wl--no-whole-archive' + tmp_addflag=' $pic_flag -Mnomain' ;; + ecc*,ia64* | icc*,ia64*) # Intel C compiler on ia64 + tmp_addflag=' -i_dynamic' ;; + efc*,ia64* | ifort*,ia64*) # Intel Fortran compiler on ia64 + tmp_addflag=' -i_dynamic -nofor_main' ;; + ifc* | ifort*) # Intel Fortran compiler + tmp_addflag=' -nofor_main' ;; + lf95*) # Lahey Fortran 8.1 + whole_archive_flag_spec= + tmp_sharedflag='--shared' ;; + nagfor*) # NAGFOR 5.3 + tmp_sharedflag='-Wl,-shared' ;; + xl[cC]* | bgxl[cC]* | mpixl[cC]*) # IBM XL C 8.0 on PPC (deal with xlf below) + tmp_sharedflag='-qmkshrobj' + tmp_addflag= ;; + nvcc*) # Cuda Compiler Driver 2.2 + whole_archive_flag_spec='$wl--whole-archive`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` $wl--no-whole-archive' + compiler_needs_object=yes + ;; + esac + case `$CC -V 2>&1 | $SED 5q` in + *Sun\ C*) # Sun C 5.9 + whole_archive_flag_spec='$wl--whole-archive`new_convenience=; for conv in $convenience\"\"; do test -z \"$conv\" || new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` $wl--no-whole-archive' + compiler_needs_object=yes + tmp_sharedflag='-G' ;; + *Sun\ F*) # Sun Fortran 8.3 + tmp_sharedflag='-G' ;; + esac + archive_cmds='$CC '"$tmp_sharedflag""$tmp_addflag"' $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' + + if test yes = "$supports_anon_versioning"; then + archive_expsym_cmds='echo "{ global:" > $output_objdir/$libname.ver~ + cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $output_objdir/$libname.ver~ + echo "local: *; };" >> $output_objdir/$libname.ver~ + $CC '"$tmp_sharedflag""$tmp_addflag"' $libobjs $deplibs $compiler_flags $wl-soname $wl$soname $wl-version-script $wl$output_objdir/$libname.ver -o $lib' + fi + + case $cc_basename in + tcc*) + hardcode_libdir_flag_spec='$wl-rpath $wl$libdir' + export_dynamic_flag_spec='-rdynamic' + ;; + xlf* | bgf* | bgxlf* | mpixlf*) + # IBM XL Fortran 10.1 on PPC cannot create shared libs itself + whole_archive_flag_spec='--whole-archive$convenience --no-whole-archive' + hardcode_libdir_flag_spec='$wl-rpath $wl$libdir' + archive_cmds='$LD -shared $libobjs $deplibs $linker_flags -soname $soname -o $lib' + if test yes = "$supports_anon_versioning"; then + archive_expsym_cmds='echo "{ global:" > $output_objdir/$libname.ver~ + cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $output_objdir/$libname.ver~ + echo "local: *; };" >> $output_objdir/$libname.ver~ + $LD -shared $libobjs $deplibs $linker_flags -soname $soname -version-script $output_objdir/$libname.ver -o $lib' + fi + ;; + esac + else + ld_shlibs=no + fi + ;; + + netbsd* | netbsdelf*-gnu) + if echo __ELF__ | $CC -E - | $GREP __ELF__ >/dev/null; then + archive_cmds='$LD -Bshareable $libobjs $deplibs $linker_flags -o $lib' + wlarc= + else + archive_cmds='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' + archive_expsym_cmds='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname $wl-retain-symbols-file $wl$export_symbols -o $lib' + fi + ;; + + solaris*) + if $LD -v 2>&1 | $GREP 'BFD 2\.8' > /dev/null; then + ld_shlibs=no + cat <<_LT_EOF 1>&2 + +*** Warning: The releases 2.8.* of the GNU linker cannot reliably +*** create shared libraries on Solaris systems. Therefore, libtool +*** is disabling shared libraries support. We urge you to upgrade GNU +*** binutils to release 2.9.1 or newer. Another option is to modify +*** your PATH or compiler configuration so that the native linker is +*** used, and then restart. + +_LT_EOF + elif $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then + archive_cmds='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' + archive_expsym_cmds='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname $wl-retain-symbols-file $wl$export_symbols -o $lib' + else + ld_shlibs=no + fi + ;; + + sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX*) + case `$LD -v 2>&1` in + *\ [01].* | *\ 2.[0-9].* | *\ 2.1[0-5].*) + ld_shlibs=no + cat <<_LT_EOF 1>&2 + +*** Warning: Releases of the GNU linker prior to 2.16.91.0.3 cannot +*** reliably create shared libraries on SCO systems. Therefore, libtool +*** is disabling shared libraries support. We urge you to upgrade GNU +*** binutils to release 2.16.91.0.3 or newer. Another option is to modify +*** your PATH or compiler configuration so that the native linker is +*** used, and then restart. + +_LT_EOF + ;; + *) + # For security reasons, it is highly recommended that you always + # use absolute paths for naming shared libraries, and exclude the + # DT_RUNPATH tag from executables and libraries. But doing so + # requires that you compile everything twice, which is a pain. + if $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then + hardcode_libdir_flag_spec='$wl-rpath $wl$libdir' + archive_cmds='$CC -shared $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' + archive_expsym_cmds='$CC -shared $libobjs $deplibs $compiler_flags $wl-soname $wl$soname $wl-retain-symbols-file $wl$export_symbols -o $lib' + else + ld_shlibs=no + fi + ;; + esac + ;; + + sunos4*) + archive_cmds='$LD -assert pure-text -Bshareable -o $lib $libobjs $deplibs $linker_flags' + wlarc= + hardcode_direct=yes + hardcode_shlibpath_var=no + ;; + + *) + if $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then + archive_cmds='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' + archive_expsym_cmds='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname $wl-retain-symbols-file $wl$export_symbols -o $lib' + else + ld_shlibs=no + fi + ;; + esac + + if test no = "$ld_shlibs"; then + runpath_var= + hardcode_libdir_flag_spec= + export_dynamic_flag_spec= + whole_archive_flag_spec= + fi + else + # PORTME fill in a description of your system's linker (not GNU ld) + case $host_os in + aix3*) + allow_undefined_flag=unsupported + always_export_symbols=yes + archive_expsym_cmds='$LD -o $output_objdir/$soname $libobjs $deplibs $linker_flags -bE:$export_symbols -T512 -H512 -bM:SRE~$AR $AR_FLAGS $lib $output_objdir/$soname' + # Note: this linker hardcodes the directories in LIBPATH if there + # are no directories specified by -L. + hardcode_minus_L=yes + if test yes = "$GCC" && test -z "$lt_prog_compiler_static"; then + # Neither direct hardcoding nor static linking is supported with a + # broken collect2. + hardcode_direct=unsupported + fi + ;; + + aix[4-9]*) + if test ia64 = "$host_cpu"; then + # On IA64, the linker does run time linking by default, so we don't + # have to do anything special. + aix_use_runtimelinking=no + exp_sym_flag='-Bexport' + no_entry_flag= + else + # If we're using GNU nm, then we don't want the "-C" option. + # -C means demangle to GNU nm, but means don't demangle to AIX nm. + # Without the "-l" option, or with the "-B" option, AIX nm treats + # weak defined symbols like other global defined symbols, whereas + # GNU nm marks them as "W". + # While the 'weak' keyword is ignored in the Export File, we need + # it in the Import File for the 'aix-soname' feature, so we have + # to replace the "-B" option with "-P" for AIX nm. + if $NM -V 2>&1 | $GREP 'GNU' > /dev/null; then + export_symbols_cmds='$NM -Bpg $libobjs $convenience | awk '\''{ if (((\$ 2 == "T") || (\$ 2 == "D") || (\$ 2 == "B") || (\$ 2 == "W")) && (substr(\$ 3,1,1) != ".")) { if (\$ 2 == "W") { print \$ 3 " weak" } else { print \$ 3 } } }'\'' | sort -u > $export_symbols' + else + export_symbols_cmds='`func_echo_all $NM | $SED -e '\''s/B\([^B]*\)$/P\1/'\''` -PCpgl $libobjs $convenience | awk '\''{ if (((\$ 2 == "T") || (\$ 2 == "D") || (\$ 2 == "B") || (\$ 2 == "L") || (\$ 2 == "W") || (\$ 2 == "V") || (\$ 2 == "Z")) && (substr(\$ 1,1,1) != ".")) { if ((\$ 2 == "W") || (\$ 2 == "V") || (\$ 2 == "Z")) { print \$ 1 " weak" } else { print \$ 1 } } }'\'' | sort -u > $export_symbols' + fi + aix_use_runtimelinking=no + + # Test if we are trying to use run time linking or normal + # AIX style linking. If -brtl is somewhere in LDFLAGS, we + # have runtime linking enabled, and use it for executables. + # For shared libraries, we enable/disable runtime linking + # depending on the kind of the shared library created - + # when "with_aix_soname,aix_use_runtimelinking" is: + # "aix,no" lib.a(lib.so.V) shared, rtl:no, for executables + # "aix,yes" lib.so shared, rtl:yes, for executables + # lib.a static archive + # "both,no" lib.so.V(shr.o) shared, rtl:yes + # lib.a(lib.so.V) shared, rtl:no, for executables + # "both,yes" lib.so.V(shr.o) shared, rtl:yes, for executables + # lib.a(lib.so.V) shared, rtl:no + # "svr4,*" lib.so.V(shr.o) shared, rtl:yes, for executables + # lib.a static archive + case $host_os in aix4.[23]|aix4.[23].*|aix[5-9]*) + for ld_flag in $LDFLAGS; do + if (test x-brtl = "x$ld_flag" || test x-Wl,-brtl = "x$ld_flag"); then + aix_use_runtimelinking=yes + break + fi + done + if test svr4,no = "$with_aix_soname,$aix_use_runtimelinking"; then + # With aix-soname=svr4, we create the lib.so.V shared archives only, + # so we don't have lib.a shared libs to link our executables. + # We have to force runtime linking in this case. + aix_use_runtimelinking=yes + LDFLAGS="$LDFLAGS -Wl,-brtl" + fi + ;; + esac + + exp_sym_flag='-bexport' + no_entry_flag='-bnoentry' + fi + + # When large executables or shared objects are built, AIX ld can + # have problems creating the table of contents. If linking a library + # or program results in "error TOC overflow" add -mminimal-toc to + # CXXFLAGS/CFLAGS for g++/gcc. In the cases where that is not + # enough to fix the problem, add -Wl,-bbigtoc to LDFLAGS. + + archive_cmds='' + hardcode_direct=yes + hardcode_direct_absolute=yes + hardcode_libdir_separator=':' + link_all_deplibs=yes + file_list_spec='$wl-f,' + case $with_aix_soname,$aix_use_runtimelinking in + aix,*) ;; # traditional, no import file + svr4,* | *,yes) # use import file + # The Import File defines what to hardcode. + hardcode_direct=no + hardcode_direct_absolute=no + ;; + esac + + if test yes = "$GCC"; then + case $host_os in aix4.[012]|aix4.[012].*) + # We only want to do this on AIX 4.2 and lower, the check + # below for broken collect2 doesn't work under 4.3+ + collect2name=`$CC -print-prog-name=collect2` + if test -f "$collect2name" && + strings "$collect2name" | $GREP resolve_lib_name >/dev/null + then + # We have reworked collect2 + : + else + # We have old collect2 + hardcode_direct=unsupported + # It fails to find uninstalled libraries when the uninstalled + # path is not listed in the libpath. Setting hardcode_minus_L + # to unsupported forces relinking + hardcode_minus_L=yes + hardcode_libdir_flag_spec='-L$libdir' + hardcode_libdir_separator= + fi + ;; + esac + shared_flag='-shared' + if test yes = "$aix_use_runtimelinking"; then + shared_flag="$shared_flag "'$wl-G' + fi + # Need to ensure runtime linking is disabled for the traditional + # shared library, or the linker may eventually find shared libraries + # /with/ Import File - we do not want to mix them. + shared_flag_aix='-shared' + shared_flag_svr4='-shared $wl-G' + else + # not using gcc + if test ia64 = "$host_cpu"; then + # VisualAge C++, Version 5.5 for AIX 5L for IA-64, Beta 3 Release + # chokes on -Wl,-G. The following line is correct: + shared_flag='-G' + else + if test yes = "$aix_use_runtimelinking"; then + shared_flag='$wl-G' + else + shared_flag='$wl-bM:SRE' + fi + shared_flag_aix='$wl-bM:SRE' + shared_flag_svr4='$wl-G' + fi + fi + + export_dynamic_flag_spec='$wl-bexpall' + # It seems that -bexpall does not export symbols beginning with + # underscore (_), so it is better to generate a list of symbols to export. + always_export_symbols=yes + if test aix,yes = "$with_aix_soname,$aix_use_runtimelinking"; then + # Warning - without using the other runtime loading flags (-brtl), + # -berok will link without error, but may produce a broken library. + allow_undefined_flag='-berok' + # Determine the default libpath from the value encoded in an + # empty executable. + if test set = "${lt_cv_aix_libpath+set}"; then + aix_libpath=$lt_cv_aix_libpath +else + if test ${lt_cv_aix_libpath_+y} +then : + printf %s "(cached) " >&6 +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int main(void) +{ + + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + lt_aix_libpath_sed=' + /Import File Strings/,/^$/ { + /^0/ { + s/^0 *\([^ ]*\) *$/\1/ + p + } + }' + lt_cv_aix_libpath_=`dump -H conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"` + # Check for a 64-bit object if we didn't find anything. + if test -z "$lt_cv_aix_libpath_"; then + lt_cv_aix_libpath_=`dump -HX64 conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"` + fi +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + if test -z "$lt_cv_aix_libpath_"; then + lt_cv_aix_libpath_=/usr/lib:/lib + fi + +fi + + aix_libpath=$lt_cv_aix_libpath_ +fi + + hardcode_libdir_flag_spec='$wl-blibpath:$libdir:'"$aix_libpath" + archive_expsym_cmds='$CC -o $output_objdir/$soname $libobjs $deplibs $wl'$no_entry_flag' $compiler_flags `if test -n "$allow_undefined_flag"; then func_echo_all "$wl$allow_undefined_flag"; else :; fi` $wl'$exp_sym_flag:\$export_symbols' '$shared_flag + else + if test ia64 = "$host_cpu"; then + hardcode_libdir_flag_spec='$wl-R $libdir:/usr/lib:/lib' + allow_undefined_flag="-z nodefs" + archive_expsym_cmds="\$CC $shared_flag"' -o $output_objdir/$soname $libobjs $deplibs '"\$wl$no_entry_flag"' $compiler_flags $wl$allow_undefined_flag '"\$wl$exp_sym_flag:\$export_symbols" + else + # Determine the default libpath from the value encoded in an + # empty executable. + if test set = "${lt_cv_aix_libpath+set}"; then + aix_libpath=$lt_cv_aix_libpath +else + if test ${lt_cv_aix_libpath_+y} +then : + printf %s "(cached) " >&6 +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int main(void) +{ + + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + lt_aix_libpath_sed=' + /Import File Strings/,/^$/ { + /^0/ { + s/^0 *\([^ ]*\) *$/\1/ + p + } + }' + lt_cv_aix_libpath_=`dump -H conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"` + # Check for a 64-bit object if we didn't find anything. + if test -z "$lt_cv_aix_libpath_"; then + lt_cv_aix_libpath_=`dump -HX64 conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"` + fi +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + if test -z "$lt_cv_aix_libpath_"; then + lt_cv_aix_libpath_=/usr/lib:/lib + fi + +fi + + aix_libpath=$lt_cv_aix_libpath_ +fi + + hardcode_libdir_flag_spec='$wl-blibpath:$libdir:'"$aix_libpath" + # Warning - without using the other run time loading flags, + # -berok will link without error, but may produce a broken library. + no_undefined_flag=' $wl-bernotok' + allow_undefined_flag=' $wl-berok' + if test yes = "$with_gnu_ld"; then + # We only use this code for GNU lds that support --whole-archive. + whole_archive_flag_spec='$wl--whole-archive$convenience $wl--no-whole-archive' + else + # Exported symbols can be pulled into shared objects from archives + whole_archive_flag_spec='$convenience' + fi + archive_cmds_need_lc=yes + archive_expsym_cmds='$RM -r $output_objdir/$realname.d~$MKDIR $output_objdir/$realname.d' + # -brtl affects multiple linker settings, -berok does not and is overridden later + compiler_flags_filtered='`func_echo_all "$compiler_flags " | $SED -e "s%-brtl\\([, ]\\)%-berok\\1%g"`' + if test svr4 != "$with_aix_soname"; then + # This is similar to how AIX traditionally builds its shared libraries. + archive_expsym_cmds="$archive_expsym_cmds"'~$CC '$shared_flag_aix' -o $output_objdir/$realname.d/$soname $libobjs $deplibs $wl-bnoentry '$compiler_flags_filtered'$wl-bE:$export_symbols$allow_undefined_flag~$AR $AR_FLAGS $output_objdir/$libname$release.a $output_objdir/$realname.d/$soname' + fi + if test aix != "$with_aix_soname"; then + archive_expsym_cmds="$archive_expsym_cmds"'~$CC '$shared_flag_svr4' -o $output_objdir/$realname.d/$shared_archive_member_spec.o $libobjs $deplibs $wl-bnoentry '$compiler_flags_filtered'$wl-bE:$export_symbols$allow_undefined_flag~$STRIP -e $output_objdir/$realname.d/$shared_archive_member_spec.o~( func_echo_all "#! $soname($shared_archive_member_spec.o)"; if test shr_64 = "$shared_archive_member_spec"; then func_echo_all "# 64"; else func_echo_all "# 32"; fi; cat $export_symbols ) > $output_objdir/$realname.d/$shared_archive_member_spec.imp~$AR $AR_FLAGS $output_objdir/$soname $output_objdir/$realname.d/$shared_archive_member_spec.o $output_objdir/$realname.d/$shared_archive_member_spec.imp' + else + # used by -dlpreopen to get the symbols + archive_expsym_cmds="$archive_expsym_cmds"'~$MV $output_objdir/$realname.d/$soname $output_objdir' + fi + archive_expsym_cmds="$archive_expsym_cmds"'~$RM -r $output_objdir/$realname.d' + fi + fi + ;; + + amigaos*) + case $host_cpu in + powerpc) + # see comment about AmigaOS4 .so support + archive_cmds='$CC -shared $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' + archive_expsym_cmds='' + ;; + m68k) + archive_cmds='$RM $output_objdir/a2ixlibrary.data~$ECHO "#define NAME $libname" > $output_objdir/a2ixlibrary.data~$ECHO "#define LIBRARY_ID 1" >> $output_objdir/a2ixlibrary.data~$ECHO "#define VERSION $major" >> $output_objdir/a2ixlibrary.data~$ECHO "#define REVISION $revision" >> $output_objdir/a2ixlibrary.data~$AR $AR_FLAGS $lib $libobjs~$RANLIB $lib~(cd $output_objdir && a2ixlibrary -32)' + hardcode_libdir_flag_spec='-L$libdir' + hardcode_minus_L=yes + ;; + esac + ;; + + bsdi[45]*) + export_dynamic_flag_spec=-rdynamic + ;; + + cygwin* | mingw* | pw32* | cegcc*) + # When not using gcc, we currently assume that we are using + # Microsoft Visual C++ or Intel C++ Compiler. + # hardcode_libdir_flag_spec is actually meaningless, as there is + # no search path for DLLs. + case $cc_basename in + cl* | icl*) + # Native MSVC or ICC + hardcode_libdir_flag_spec=' ' + allow_undefined_flag=unsupported + always_export_symbols=yes + file_list_spec='@' + # Tell ltmain to make .lib files, not .a files. + libext=lib + # Tell ltmain to make .dll files, not .so files. + shrext_cmds=.dll + # FIXME: Setting linknames here is a bad hack. + archive_cmds='$CC -o $output_objdir/$soname $libobjs $compiler_flags $deplibs -Wl,-DLL,-IMPLIB:"$tool_output_objdir$libname.dll.lib"~linknames=' + archive_expsym_cmds='if test DEF = "`$SED -n -e '\''s/^[ ]*//'\'' -e '\''/^\(;.*\)*$/d'\'' -e '\''s/^\(EXPORTS\|LIBRARY\)\([ ].*\)*$/DEF/p'\'' -e q $export_symbols`" ; then + cp "$export_symbols" "$output_objdir/$soname.def"; + echo "$tool_output_objdir$soname.def" > "$output_objdir/$soname.exp"; + else + $SED -e '\''s/^/-link -EXPORT:/'\'' < $export_symbols > $output_objdir/$soname.exp; + fi~ + $CC -o $tool_output_objdir$soname $libobjs $compiler_flags $deplibs "@$tool_output_objdir$soname.exp" -Wl,-DLL,-IMPLIB:"$tool_output_objdir$libname.dll.lib"~ + linknames=' + # The linker will not automatically build a static lib if we build a DLL. + # _LT_TAGVAR(old_archive_from_new_cmds, )='true' + enable_shared_with_static_runtimes=yes + exclude_expsyms='_NULL_IMPORT_DESCRIPTOR|_IMPORT_DESCRIPTOR_.*' + export_symbols_cmds='$NM $libobjs $convenience | $global_symbol_pipe | $SED -e '\''/^[BCDGRS][ ]/s/.*[ ]\([^ ]*\)/\1,DATA/'\'' | $SED -e '\''/^[AITW][ ]/s/.*[ ]//'\'' | sort | uniq > $export_symbols' + # Don't use ranlib + old_postinstall_cmds='chmod 644 $oldlib' + postlink_cmds='lt_outputfile="@OUTPUT@"~ + lt_tool_outputfile="@TOOL_OUTPUT@"~ + case $lt_outputfile in + *.exe|*.EXE) ;; + *) + lt_outputfile=$lt_outputfile.exe + lt_tool_outputfile=$lt_tool_outputfile.exe + ;; + esac~ + if test : != "$MANIFEST_TOOL" && test -f "$lt_outputfile.manifest"; then + $MANIFEST_TOOL -manifest "$lt_tool_outputfile.manifest" -outputresource:"$lt_tool_outputfile" || exit 1; + $RM "$lt_outputfile.manifest"; + fi' + ;; + *) + # Assume MSVC and ICC wrapper + hardcode_libdir_flag_spec=' ' + allow_undefined_flag=unsupported + # Tell ltmain to make .lib files, not .a files. + libext=lib + # Tell ltmain to make .dll files, not .so files. + shrext_cmds=.dll + # FIXME: Setting linknames here is a bad hack. + archive_cmds='$CC -o $lib $libobjs $compiler_flags `func_echo_all "$deplibs" | $SED '\''s/ -lc$//'\''` -link -dll~linknames=' + # The linker will automatically build a .lib file if we build a DLL. + old_archive_from_new_cmds='true' + # FIXME: Should let the user specify the lib program. + old_archive_cmds='lib -OUT:$oldlib$oldobjs$old_deplibs' + enable_shared_with_static_runtimes=yes + ;; + esac + ;; + + darwin* | rhapsody*) + + + archive_cmds_need_lc=no + hardcode_direct=no + hardcode_automatic=yes + hardcode_shlibpath_var=unsupported + if test yes = "$lt_cv_ld_force_load"; then + whole_archive_flag_spec='`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience $wl-force_load,$conv\"; done; func_echo_all \"$new_convenience\"`' + + else + whole_archive_flag_spec='' + fi + link_all_deplibs=yes + allow_undefined_flag=$_lt_dar_allow_undefined + case $cc_basename in + ifort*|nagfor*) _lt_dar_can_shared=yes ;; + *) _lt_dar_can_shared=$GCC ;; + esac + if test yes = "$_lt_dar_can_shared"; then + output_verbose_link_cmd=func_echo_all + archive_cmds="\$CC -dynamiclib \$allow_undefined_flag -o \$lib \$libobjs \$deplibs \$compiler_flags -install_name \$rpath/\$soname \$verstring $_lt_dar_single_mod$_lt_dsymutil" + module_cmds="\$CC \$allow_undefined_flag -o \$lib -bundle \$libobjs \$deplibs \$compiler_flags$_lt_dsymutil" + archive_expsym_cmds="$SED 's|^|_|' < \$export_symbols > \$output_objdir/\$libname-symbols.expsym~\$CC -dynamiclib \$allow_undefined_flag -o \$lib \$libobjs \$deplibs \$compiler_flags -install_name \$rpath/\$soname \$verstring $_lt_dar_single_mod$_lt_dar_export_syms$_lt_dsymutil" + module_expsym_cmds="$SED -e 's|^|_|' < \$export_symbols > \$output_objdir/\$libname-symbols.expsym~\$CC \$allow_undefined_flag -o \$lib -bundle \$libobjs \$deplibs \$compiler_flags$_lt_dar_export_syms$_lt_dsymutil" + + else + ld_shlibs=no + fi + + ;; + + dgux*) + archive_cmds='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' + hardcode_libdir_flag_spec='-L$libdir' + hardcode_shlibpath_var=no + ;; + + # FreeBSD 2.2.[012] allows us to include c++rt0.o to get C++ constructor + # support. Future versions do this automatically, but an explicit c++rt0.o + # does not break anything, and helps significantly (at the cost of a little + # extra space). + freebsd2.2*) + archive_cmds='$LD -Bshareable -o $lib $libobjs $deplibs $linker_flags /usr/lib/c++rt0.o' + hardcode_libdir_flag_spec='-R$libdir' + hardcode_direct=yes + hardcode_shlibpath_var=no + ;; + + # Unfortunately, older versions of FreeBSD 2 do not have this feature. + freebsd2.*) + archive_cmds='$LD -Bshareable -o $lib $libobjs $deplibs $linker_flags' + hardcode_direct=yes + hardcode_minus_L=yes + hardcode_shlibpath_var=no + ;; + + # FreeBSD 3 and greater uses gcc -shared to do shared libraries. + freebsd* | dragonfly* | midnightbsd*) + archive_cmds='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags' + hardcode_libdir_flag_spec='-R$libdir' + hardcode_direct=yes + hardcode_shlibpath_var=no + ;; + + hpux9*) + if test yes = "$GCC"; then + archive_cmds='$RM $output_objdir/$soname~$CC -shared $pic_flag $wl+b $wl$install_libdir -o $output_objdir/$soname $libobjs $deplibs $compiler_flags~test "x$output_objdir/$soname" = "x$lib" || mv $output_objdir/$soname $lib' + else + archive_cmds='$RM $output_objdir/$soname~$LD -b +b $install_libdir -o $output_objdir/$soname $libobjs $deplibs $linker_flags~test "x$output_objdir/$soname" = "x$lib" || mv $output_objdir/$soname $lib' + fi + hardcode_libdir_flag_spec='$wl+b $wl$libdir' + hardcode_libdir_separator=: + hardcode_direct=yes + + # hardcode_minus_L: Not really in the search PATH, + # but as the default location of the library. + hardcode_minus_L=yes + export_dynamic_flag_spec='$wl-E' + ;; + + hpux10*) + if test yes,no = "$GCC,$with_gnu_ld"; then + archive_cmds='$CC -shared $pic_flag $wl+h $wl$soname $wl+b $wl$install_libdir -o $lib $libobjs $deplibs $compiler_flags' + else + archive_cmds='$LD -b +h $soname +b $install_libdir -o $lib $libobjs $deplibs $linker_flags' + fi + if test no = "$with_gnu_ld"; then + hardcode_libdir_flag_spec='$wl+b $wl$libdir' + hardcode_libdir_separator=: + hardcode_direct=yes + hardcode_direct_absolute=yes + export_dynamic_flag_spec='$wl-E' + # hardcode_minus_L: Not really in the search PATH, + # but as the default location of the library. + hardcode_minus_L=yes + fi + ;; + + hpux11*) + if test yes,no = "$GCC,$with_gnu_ld"; then + case $host_cpu in + hppa*64*) + archive_cmds='$CC -shared $wl+h $wl$soname -o $lib $libobjs $deplibs $compiler_flags' + ;; + ia64*) + archive_cmds='$CC -shared $pic_flag $wl+h $wl$soname $wl+nodefaultrpath -o $lib $libobjs $deplibs $compiler_flags' + ;; + *) + archive_cmds='$CC -shared $pic_flag $wl+h $wl$soname $wl+b $wl$install_libdir -o $lib $libobjs $deplibs $compiler_flags' + ;; + esac + else + case $host_cpu in + hppa*64*) + archive_cmds='$CC -b $wl+h $wl$soname -o $lib $libobjs $deplibs $compiler_flags' + ;; + ia64*) + archive_cmds='$CC -b $wl+h $wl$soname $wl+nodefaultrpath -o $lib $libobjs $deplibs $compiler_flags' + ;; + *) + + # Older versions of the 11.00 compiler do not understand -b yet + # (HP92453-01 A.11.01.20 doesn't, HP92453-01 B.11.X.35175-35176.GP does) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if $CC understands -b" >&5 +printf %s "checking if $CC understands -b... " >&6; } +if test ${lt_cv_prog_compiler__b+y} +then : + printf %s "(cached) " >&6 +else $as_nop + lt_cv_prog_compiler__b=no + save_LDFLAGS=$LDFLAGS + LDFLAGS="$LDFLAGS -b" + echo "$lt_simple_link_test_code" > conftest.$ac_ext + if (eval $ac_link 2>conftest.err) && test -s conftest$ac_exeext; then + # The linker can only warn and ignore the option if not recognized + # So say no if there are warnings + if test -s conftest.err; then + # Append any errors to the config.log. + cat conftest.err 1>&5 + $ECHO "$_lt_linker_boilerplate" | $SED '/^$/d' > conftest.exp + $SED '/^$/d; /^ *+/d' conftest.err >conftest.er2 + if diff conftest.exp conftest.er2 >/dev/null; then + lt_cv_prog_compiler__b=yes + fi + else + lt_cv_prog_compiler__b=yes + fi + fi + $RM -r conftest* + LDFLAGS=$save_LDFLAGS + +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler__b" >&5 +printf "%s\n" "$lt_cv_prog_compiler__b" >&6; } + +if test yes = "$lt_cv_prog_compiler__b"; then + archive_cmds='$CC -b $wl+h $wl$soname $wl+b $wl$install_libdir -o $lib $libobjs $deplibs $compiler_flags' +else + archive_cmds='$LD -b +h $soname +b $install_libdir -o $lib $libobjs $deplibs $linker_flags' +fi + + ;; + esac + fi + if test no = "$with_gnu_ld"; then + hardcode_libdir_flag_spec='$wl+b $wl$libdir' + hardcode_libdir_separator=: + + case $host_cpu in + hppa*64*|ia64*) + hardcode_direct=no + hardcode_shlibpath_var=no + ;; + *) + hardcode_direct=yes + hardcode_direct_absolute=yes + export_dynamic_flag_spec='$wl-E' + + # hardcode_minus_L: Not really in the search PATH, + # but as the default location of the library. + hardcode_minus_L=yes + ;; + esac + fi + ;; + + irix5* | irix6* | nonstopux*) + if test yes = "$GCC"; then + archive_cmds='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` $wl-update_registry $wl$output_objdir/so_locations -o $lib' + # Try to use the -exported_symbol ld option, if it does not + # work, assume that -exports_file does not work either and + # implicitly export all symbols. + # This should be the same for all languages, so no per-tag cache variable. + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the $host_os linker accepts -exported_symbol" >&5 +printf %s "checking whether the $host_os linker accepts -exported_symbol... " >&6; } +if test ${lt_cv_irix_exported_symbol+y} +then : + printf %s "(cached) " >&6 +else $as_nop + save_LDFLAGS=$LDFLAGS + LDFLAGS="$LDFLAGS -shared $wl-exported_symbol ${wl}foo $wl-update_registry $wl/dev/null" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +int foo (void) { return 0; } +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + lt_cv_irix_exported_symbol=yes +else $as_nop + lt_cv_irix_exported_symbol=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + LDFLAGS=$save_LDFLAGS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_irix_exported_symbol" >&5 +printf "%s\n" "$lt_cv_irix_exported_symbol" >&6; } + if test yes = "$lt_cv_irix_exported_symbol"; then + archive_expsym_cmds='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` $wl-update_registry $wl$output_objdir/so_locations $wl-exports_file $wl$export_symbols -o $lib' + fi + link_all_deplibs=no + else + archive_cmds='$CC -shared $libobjs $deplibs $compiler_flags -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry $output_objdir/so_locations -o $lib' + archive_expsym_cmds='$CC -shared $libobjs $deplibs $compiler_flags -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry $output_objdir/so_locations -exports_file $export_symbols -o $lib' + fi + archive_cmds_need_lc='no' + hardcode_libdir_flag_spec='$wl-rpath $wl$libdir' + hardcode_libdir_separator=: + inherit_rpath=yes + link_all_deplibs=yes + ;; + + linux*) + case $cc_basename in + tcc*) + # Fabrice Bellard et al's Tiny C Compiler + ld_shlibs=yes + archive_cmds='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags' + hardcode_libdir_flag_spec='$wl-rpath $wl$libdir' + ;; + esac + ;; + + netbsd* | netbsdelf*-gnu) + if echo __ELF__ | $CC -E - | $GREP __ELF__ >/dev/null; then + archive_cmds='$LD -Bshareable -o $lib $libobjs $deplibs $linker_flags' # a.out + else + archive_cmds='$LD -shared -o $lib $libobjs $deplibs $linker_flags' # ELF + fi + hardcode_libdir_flag_spec='-R$libdir' + hardcode_direct=yes + hardcode_shlibpath_var=no + ;; + + newsos6) + archive_cmds='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' + hardcode_direct=yes + hardcode_libdir_flag_spec='$wl-rpath $wl$libdir' + hardcode_libdir_separator=: + hardcode_shlibpath_var=no + ;; + + *nto* | *qnx*) + ;; + + openbsd* | bitrig*) + if test -f /usr/libexec/ld.so; then + hardcode_direct=yes + hardcode_shlibpath_var=no + hardcode_direct_absolute=yes + if test -z "`echo __ELF__ | $CC -E - | $GREP __ELF__`"; then + archive_cmds='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags' + archive_expsym_cmds='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags $wl-retain-symbols-file,$export_symbols' + hardcode_libdir_flag_spec='$wl-rpath,$libdir' + export_dynamic_flag_spec='$wl-E' + else + archive_cmds='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags' + hardcode_libdir_flag_spec='$wl-rpath,$libdir' + fi + else + ld_shlibs=no + fi + ;; + + os2*) + hardcode_libdir_flag_spec='-L$libdir' + hardcode_minus_L=yes + allow_undefined_flag=unsupported + shrext_cmds=.dll + archive_cmds='$ECHO "LIBRARY ${soname%$shared_ext} INITINSTANCE TERMINSTANCE" > $output_objdir/$libname.def~ + $ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~ + $ECHO "DATA MULTIPLE NONSHARED" >> $output_objdir/$libname.def~ + $ECHO EXPORTS >> $output_objdir/$libname.def~ + emxexp $libobjs | $SED /"_DLL_InitTerm"/d >> $output_objdir/$libname.def~ + $CC -Zdll -Zcrtdll -o $output_objdir/$soname $libobjs $deplibs $compiler_flags $output_objdir/$libname.def~ + emximp -o $lib $output_objdir/$libname.def' + archive_expsym_cmds='$ECHO "LIBRARY ${soname%$shared_ext} INITINSTANCE TERMINSTANCE" > $output_objdir/$libname.def~ + $ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~ + $ECHO "DATA MULTIPLE NONSHARED" >> $output_objdir/$libname.def~ + $ECHO EXPORTS >> $output_objdir/$libname.def~ + prefix_cmds="$SED"~ + if test EXPORTS = "`$SED 1q $export_symbols`"; then + prefix_cmds="$prefix_cmds -e 1d"; + fi~ + prefix_cmds="$prefix_cmds -e \"s/^\(.*\)$/_\1/g\""~ + cat $export_symbols | $prefix_cmds >> $output_objdir/$libname.def~ + $CC -Zdll -Zcrtdll -o $output_objdir/$soname $libobjs $deplibs $compiler_flags $output_objdir/$libname.def~ + emximp -o $lib $output_objdir/$libname.def' + old_archive_From_new_cmds='emximp -o $output_objdir/${libname}_dll.a $output_objdir/$libname.def' + enable_shared_with_static_runtimes=yes + file_list_spec='@' + ;; + + osf3*) + if test yes = "$GCC"; then + allow_undefined_flag=' $wl-expect_unresolved $wl\*' + archive_cmds='$CC -shared$allow_undefined_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` $wl-update_registry $wl$output_objdir/so_locations -o $lib' + else + allow_undefined_flag=' -expect_unresolved \*' + archive_cmds='$CC -shared$allow_undefined_flag $libobjs $deplibs $compiler_flags -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry $output_objdir/so_locations -o $lib' + fi + archive_cmds_need_lc='no' + hardcode_libdir_flag_spec='$wl-rpath $wl$libdir' + hardcode_libdir_separator=: + ;; + + osf4* | osf5*) # as osf3* with the addition of -msym flag + if test yes = "$GCC"; then + allow_undefined_flag=' $wl-expect_unresolved $wl\*' + archive_cmds='$CC -shared$allow_undefined_flag $pic_flag $libobjs $deplibs $compiler_flags $wl-msym $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` $wl-update_registry $wl$output_objdir/so_locations -o $lib' + hardcode_libdir_flag_spec='$wl-rpath $wl$libdir' + else + allow_undefined_flag=' -expect_unresolved \*' + archive_cmds='$CC -shared$allow_undefined_flag $libobjs $deplibs $compiler_flags -msym -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry $output_objdir/so_locations -o $lib' + archive_expsym_cmds='for i in `cat $export_symbols`; do printf "%s %s\\n" -exported_symbol "\$i" >> $lib.exp; done; printf "%s\\n" "-hidden">> $lib.exp~ + $CC -shared$allow_undefined_flag $wl-input $wl$lib.exp $compiler_flags $libobjs $deplibs -soname $soname `test -n "$verstring" && $ECHO "-set_version $verstring"` -update_registry $output_objdir/so_locations -o $lib~$RM $lib.exp' + + # Both c and cxx compiler support -rpath directly + hardcode_libdir_flag_spec='-rpath $libdir' + fi + archive_cmds_need_lc='no' + hardcode_libdir_separator=: + ;; + + solaris*) + no_undefined_flag=' -z defs' + if test yes = "$GCC"; then + wlarc='$wl' + archive_cmds='$CC -shared $pic_flag $wl-z ${wl}text $wl-h $wl$soname -o $lib $libobjs $deplibs $compiler_flags' + archive_expsym_cmds='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~ + $CC -shared $pic_flag $wl-z ${wl}text $wl-M $wl$lib.exp $wl-h $wl$soname -o $lib $libobjs $deplibs $compiler_flags~$RM $lib.exp' + else + case `$CC -V 2>&1` in + *"Compilers 5.0"*) + wlarc='' + archive_cmds='$LD -G$allow_undefined_flag -h $soname -o $lib $libobjs $deplibs $linker_flags' + archive_expsym_cmds='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~ + $LD -G$allow_undefined_flag -M $lib.exp -h $soname -o $lib $libobjs $deplibs $linker_flags~$RM $lib.exp' + ;; + *) + wlarc='$wl' + archive_cmds='$CC -G$allow_undefined_flag -h $soname -o $lib $libobjs $deplibs $compiler_flags' + archive_expsym_cmds='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~ + $CC -G$allow_undefined_flag -M $lib.exp -h $soname -o $lib $libobjs $deplibs $compiler_flags~$RM $lib.exp' + ;; + esac + fi + hardcode_libdir_flag_spec='-R$libdir' + hardcode_shlibpath_var=no + case $host_os in + solaris2.[0-5] | solaris2.[0-5].*) ;; + *) + # The compiler driver will combine and reorder linker options, + # but understands '-z linker_flag'. GCC discards it without '$wl', + # but is careful enough not to reorder. + # Supported since Solaris 2.6 (maybe 2.5.1?) + if test yes = "$GCC"; then + whole_archive_flag_spec='$wl-z ${wl}allextract$convenience $wl-z ${wl}defaultextract' + else + whole_archive_flag_spec='-z allextract$convenience -z defaultextract' + fi + ;; + esac + link_all_deplibs=yes + ;; + + sunos4*) + if test sequent = "$host_vendor"; then + # Use $CC to link under sequent, because it throws in some extra .o + # files that make .init and .fini sections work. + archive_cmds='$CC -G $wl-h $soname -o $lib $libobjs $deplibs $compiler_flags' + else + archive_cmds='$LD -assert pure-text -Bstatic -o $lib $libobjs $deplibs $linker_flags' + fi + hardcode_libdir_flag_spec='-L$libdir' + hardcode_direct=yes + hardcode_minus_L=yes + hardcode_shlibpath_var=no + ;; + + sysv4) + case $host_vendor in + sni) + archive_cmds='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' + hardcode_direct=yes # is this really true??? + ;; + siemens) + ## LD is ld it makes a PLAMLIB + ## CC just makes a GrossModule. + archive_cmds='$LD -G -o $lib $libobjs $deplibs $linker_flags' + reload_cmds='$CC -r -o $output$reload_objs' + hardcode_direct=no + ;; + motorola) + archive_cmds='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' + hardcode_direct=no #Motorola manual says yes, but my tests say they lie + ;; + esac + runpath_var='LD_RUN_PATH' + hardcode_shlibpath_var=no + ;; + + sysv4.3*) + archive_cmds='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' + hardcode_shlibpath_var=no + export_dynamic_flag_spec='-Bexport' + ;; + + sysv4*MP*) + if test -d /usr/nec; then + archive_cmds='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' + hardcode_shlibpath_var=no + runpath_var=LD_RUN_PATH + hardcode_runpath_var=yes + ld_shlibs=yes + fi + ;; + + sysv4*uw2* | sysv5OpenUNIX* | sysv5UnixWare7.[01].[10]* | unixware7* | sco3.2v5.0.[024]*) + no_undefined_flag='$wl-z,text' + archive_cmds_need_lc=no + hardcode_shlibpath_var=no + runpath_var='LD_RUN_PATH' + + if test yes = "$GCC"; then + archive_cmds='$CC -shared $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' + archive_expsym_cmds='$CC -shared $wl-Bexport:$export_symbols $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' + else + archive_cmds='$CC -G $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' + archive_expsym_cmds='$CC -G $wl-Bexport:$export_symbols $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' + fi + ;; + + sysv5* | sco3.2v5* | sco5v6*) + # Note: We CANNOT use -z defs as we might desire, because we do not + # link with -lc, and that would cause any symbols used from libc to + # always be unresolved, which means just about no library would + # ever link correctly. If we're not using GNU ld we use -z text + # though, which does catch some bad symbols but isn't as heavy-handed + # as -z defs. + no_undefined_flag='$wl-z,text' + allow_undefined_flag='$wl-z,nodefs' + archive_cmds_need_lc=no + hardcode_shlibpath_var=no + hardcode_libdir_flag_spec='$wl-R,$libdir' + hardcode_libdir_separator=':' + link_all_deplibs=yes + export_dynamic_flag_spec='$wl-Bexport' + runpath_var='LD_RUN_PATH' + + if test yes = "$GCC"; then + archive_cmds='$CC -shared $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' + archive_expsym_cmds='$CC -shared $wl-Bexport:$export_symbols $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' + else + archive_cmds='$CC -G $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' + archive_expsym_cmds='$CC -G $wl-Bexport:$export_symbols $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' + fi + ;; + + uts4*) + archive_cmds='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' + hardcode_libdir_flag_spec='-L$libdir' + hardcode_shlibpath_var=no + ;; + + *) + ld_shlibs=no + ;; + esac + + if test sni = "$host_vendor"; then + case $host in + sysv4 | sysv4.2uw2* | sysv4.3* | sysv5*) + export_dynamic_flag_spec='$wl-Blargedynsym' + ;; + esac + fi + fi + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ld_shlibs" >&5 +printf "%s\n" "$ld_shlibs" >&6; } +test no = "$ld_shlibs" && can_build_shared=no + +with_gnu_ld=$with_gnu_ld + + + + + + + + + + + + + + + +# +# Do we need to explicitly link libc? +# +case "x$archive_cmds_need_lc" in +x|xyes) + # Assume -lc should be added + archive_cmds_need_lc=yes + + if test yes,yes = "$GCC,$enable_shared"; then + case $archive_cmds in + *'~'*) + # FIXME: we may have to deal with multi-command sequences. + ;; + '$CC '*) + # Test whether the compiler implicitly links with -lc since on some + # systems, -lgcc has to come before -lc. If gcc already passes -lc + # to ld, don't add -lc before -lgcc. + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether -lc should be explicitly linked in" >&5 +printf %s "checking whether -lc should be explicitly linked in... " >&6; } +if test ${lt_cv_archive_cmds_need_lc+y} +then : + printf %s "(cached) " >&6 +else $as_nop + $RM conftest* + echo "$lt_simple_compile_test_code" > conftest.$ac_ext + + if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_compile\""; } >&5 + (eval $ac_compile) 2>&5 + ac_status=$? + printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } 2>conftest.err; then + soname=conftest + lib=conftest + libobjs=conftest.$ac_objext + deplibs= + wl=$lt_prog_compiler_wl + pic_flag=$lt_prog_compiler_pic + compiler_flags=-v + linker_flags=-v + verstring= + output_objdir=. + libname=conftest + lt_save_allow_undefined_flag=$allow_undefined_flag + allow_undefined_flag= + if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$archive_cmds 2\>\&1 \| $GREP \" -lc \" \>/dev/null 2\>\&1\""; } >&5 + (eval $archive_cmds 2\>\&1 \| $GREP \" -lc \" \>/dev/null 2\>\&1) 2>&5 + ac_status=$? + printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } + then + lt_cv_archive_cmds_need_lc=no + else + lt_cv_archive_cmds_need_lc=yes + fi + allow_undefined_flag=$lt_save_allow_undefined_flag + else + cat conftest.err 1>&5 + fi + $RM conftest* + +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_archive_cmds_need_lc" >&5 +printf "%s\n" "$lt_cv_archive_cmds_need_lc" >&6; } + archive_cmds_need_lc=$lt_cv_archive_cmds_need_lc + ;; + esac + fi + ;; +esac + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking dynamic linker characteristics" >&5 +printf %s "checking dynamic linker characteristics... " >&6; } + +if test yes = "$GCC"; then + case $host_os in + darwin*) lt_awk_arg='/^libraries:/,/LR/' ;; + *) lt_awk_arg='/^libraries:/' ;; + esac + case $host_os in + mingw* | cegcc*) lt_sed_strip_eq='s|=\([A-Za-z]:\)|\1|g' ;; + *) lt_sed_strip_eq='s|=/|/|g' ;; + esac + lt_search_path_spec=`$CC -print-search-dirs | awk $lt_awk_arg | $SED -e "s/^libraries://" -e $lt_sed_strip_eq` + case $lt_search_path_spec in + *\;*) + # if the path contains ";" then we assume it to be the separator + # otherwise default to the standard path separator (i.e. ":") - it is + # assumed that no part of a normal pathname contains ";" but that should + # okay in the real world where ";" in dirpaths is itself problematic. + lt_search_path_spec=`$ECHO "$lt_search_path_spec" | $SED 's/;/ /g'` + ;; + *) + lt_search_path_spec=`$ECHO "$lt_search_path_spec" | $SED "s/$PATH_SEPARATOR/ /g"` + ;; + esac + # Ok, now we have the path, separated by spaces, we can step through it + # and add multilib dir if necessary... + lt_tmp_lt_search_path_spec= + lt_multi_os_dir=/`$CC $CPPFLAGS $CFLAGS $LDFLAGS -print-multi-os-directory 2>/dev/null` + # ...but if some path component already ends with the multilib dir we assume + # that all is fine and trust -print-search-dirs as is (GCC 4.2? or newer). + case "$lt_multi_os_dir; $lt_search_path_spec " in + "/; "* | "/.; "* | "/./; "* | *"$lt_multi_os_dir "* | *"$lt_multi_os_dir/ "*) + lt_multi_os_dir= + ;; + esac + for lt_sys_path in $lt_search_path_spec; do + if test -d "$lt_sys_path$lt_multi_os_dir"; then + lt_tmp_lt_search_path_spec="$lt_tmp_lt_search_path_spec $lt_sys_path$lt_multi_os_dir" + elif test -n "$lt_multi_os_dir"; then + test -d "$lt_sys_path" && \ + lt_tmp_lt_search_path_spec="$lt_tmp_lt_search_path_spec $lt_sys_path" + fi + done + lt_search_path_spec=`$ECHO "$lt_tmp_lt_search_path_spec" | awk ' +BEGIN {RS = " "; FS = "/|\n";} { + lt_foo = ""; + lt_count = 0; + for (lt_i = NF; lt_i > 0; lt_i--) { + if ($lt_i != "" && $lt_i != ".") { + if ($lt_i == "..") { + lt_count++; + } else { + if (lt_count == 0) { + lt_foo = "/" $lt_i lt_foo; + } else { + lt_count--; + } + } + } + } + if (lt_foo != "") { lt_freq[lt_foo]++; } + if (lt_freq[lt_foo] == 1) { print lt_foo; } +}'` + # AWK program above erroneously prepends '/' to C:/dos/paths + # for these hosts. + case $host_os in + mingw* | cegcc*) lt_search_path_spec=`$ECHO "$lt_search_path_spec" |\ + $SED 's|/\([A-Za-z]:\)|\1|g'` ;; + esac + sys_lib_search_path_spec=`$ECHO "$lt_search_path_spec" | $lt_NL2SP` +else + sys_lib_search_path_spec="/lib /usr/lib /usr/local/lib" +fi +library_names_spec= +libname_spec='lib$name' +soname_spec= +shrext_cmds=.so +postinstall_cmds= +postuninstall_cmds= +finish_cmds= +finish_eval= +shlibpath_var= +shlibpath_overrides_runpath=unknown +version_type=none +dynamic_linker="$host_os ld.so" +sys_lib_dlsearch_path_spec="/lib /usr/lib" +need_lib_prefix=unknown +hardcode_into_libs=no + +# when you set need_version to no, make sure it does not cause -set_version +# flags to be left without arguments +need_version=unknown + + + +case $host_os in +aix3*) + version_type=linux # correct to gnu/linux during the next big refactor + library_names_spec='$libname$release$shared_ext$versuffix $libname.a' + shlibpath_var=LIBPATH + + # AIX 3 has no versioning support, so we append a major version to the name. + soname_spec='$libname$release$shared_ext$major' + ;; + +aix[4-9]*) + version_type=linux # correct to gnu/linux during the next big refactor + need_lib_prefix=no + need_version=no + hardcode_into_libs=yes + if test ia64 = "$host_cpu"; then + # AIX 5 supports IA64 + library_names_spec='$libname$release$shared_ext$major $libname$release$shared_ext$versuffix $libname$shared_ext' + shlibpath_var=LD_LIBRARY_PATH + else + # With GCC up to 2.95.x, collect2 would create an import file + # for dependence libraries. The import file would start with + # the line '#! .'. This would cause the generated library to + # depend on '.', always an invalid library. This was fixed in + # development snapshots of GCC prior to 3.0. + case $host_os in + aix4 | aix4.[01] | aix4.[01].*) + if { echo '#if __GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 97)' + echo ' yes ' + echo '#endif'; } | $CC -E - | $GREP yes > /dev/null; then + : + else + can_build_shared=no + fi + ;; + esac + # Using Import Files as archive members, it is possible to support + # filename-based versioning of shared library archives on AIX. While + # this would work for both with and without runtime linking, it will + # prevent static linking of such archives. So we do filename-based + # shared library versioning with .so extension only, which is used + # when both runtime linking and shared linking is enabled. + # Unfortunately, runtime linking may impact performance, so we do + # not want this to be the default eventually. Also, we use the + # versioned .so libs for executables only if there is the -brtl + # linker flag in LDFLAGS as well, or --with-aix-soname=svr4 only. + # To allow for filename-based versioning support, we need to create + # libNAME.so.V as an archive file, containing: + # *) an Import File, referring to the versioned filename of the + # archive as well as the shared archive member, telling the + # bitwidth (32 or 64) of that shared object, and providing the + # list of exported symbols of that shared object, eventually + # decorated with the 'weak' keyword + # *) the shared object with the F_LOADONLY flag set, to really avoid + # it being seen by the linker. + # At run time we better use the real file rather than another symlink, + # but for link time we create the symlink libNAME.so -> libNAME.so.V + + case $with_aix_soname,$aix_use_runtimelinking in + # AIX (on Power*) has no versioning support, so currently we cannot hardcode correct + # soname into executable. Probably we can add versioning support to + # collect2, so additional links can be useful in future. + aix,yes) # traditional libtool + dynamic_linker='AIX unversionable lib.so' + # If using run time linking (on AIX 4.2 or later) use lib.so + # instead of lib.a to let people know that these are not + # typical AIX shared libraries. + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + ;; + aix,no) # traditional AIX only + dynamic_linker='AIX lib.a(lib.so.V)' + # We preserve .a as extension for shared libraries through AIX4.2 + # and later when we are not doing run time linking. + library_names_spec='$libname$release.a $libname.a' + soname_spec='$libname$release$shared_ext$major' + ;; + svr4,*) # full svr4 only + dynamic_linker="AIX lib.so.V($shared_archive_member_spec.o)" + library_names_spec='$libname$release$shared_ext$major $libname$shared_ext' + # We do not specify a path in Import Files, so LIBPATH fires. + shlibpath_overrides_runpath=yes + ;; + *,yes) # both, prefer svr4 + dynamic_linker="AIX lib.so.V($shared_archive_member_spec.o), lib.a(lib.so.V)" + library_names_spec='$libname$release$shared_ext$major $libname$shared_ext' + # unpreferred sharedlib libNAME.a needs extra handling + postinstall_cmds='test -n "$linkname" || linkname="$realname"~func_stripname "" ".so" "$linkname"~$install_shared_prog "$dir/$func_stripname_result.$libext" "$destdir/$func_stripname_result.$libext"~test -z "$tstripme" || test -z "$striplib" || $striplib "$destdir/$func_stripname_result.$libext"' + postuninstall_cmds='for n in $library_names $old_library; do :; done~func_stripname "" ".so" "$n"~test "$func_stripname_result" = "$n" || func_append rmfiles " $odir/$func_stripname_result.$libext"' + # We do not specify a path in Import Files, so LIBPATH fires. + shlibpath_overrides_runpath=yes + ;; + *,no) # both, prefer aix + dynamic_linker="AIX lib.a(lib.so.V), lib.so.V($shared_archive_member_spec.o)" + library_names_spec='$libname$release.a $libname.a' + soname_spec='$libname$release$shared_ext$major' + # unpreferred sharedlib libNAME.so.V and symlink libNAME.so need extra handling + postinstall_cmds='test -z "$dlname" || $install_shared_prog $dir/$dlname $destdir/$dlname~test -z "$tstripme" || test -z "$striplib" || $striplib $destdir/$dlname~test -n "$linkname" || linkname=$realname~func_stripname "" ".a" "$linkname"~(cd "$destdir" && $LN_S -f $dlname $func_stripname_result.so)' + postuninstall_cmds='test -z "$dlname" || func_append rmfiles " $odir/$dlname"~for n in $old_library $library_names; do :; done~func_stripname "" ".a" "$n"~func_append rmfiles " $odir/$func_stripname_result.so"' + ;; + esac + shlibpath_var=LIBPATH + fi + ;; + +amigaos*) + case $host_cpu in + powerpc) + # Since July 2007 AmigaOS4 officially supports .so libraries. + # When compiling the executable, add -use-dynld -Lsobjs: to the compileline. + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + ;; + m68k) + library_names_spec='$libname.ixlibrary $libname.a' + # Create ${libname}_ixlibrary.a entries in /sys/libs. + finish_eval='for lib in `ls $libdir/*.ixlibrary 2>/dev/null`; do libname=`func_echo_all "$lib" | $SED '\''s%^.*/\([^/]*\)\.ixlibrary$%\1%'\''`; $RM /sys/libs/${libname}_ixlibrary.a; $show "cd /sys/libs && $LN_S $lib ${libname}_ixlibrary.a"; cd /sys/libs && $LN_S $lib ${libname}_ixlibrary.a || exit 1; done' + ;; + esac + ;; + +beos*) + library_names_spec='$libname$shared_ext' + dynamic_linker="$host_os ld.so" + shlibpath_var=LIBRARY_PATH + ;; + +bsdi[45]*) + version_type=linux # correct to gnu/linux during the next big refactor + need_version=no + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + soname_spec='$libname$release$shared_ext$major' + finish_cmds='PATH="\$PATH:/sbin" ldconfig $libdir' + shlibpath_var=LD_LIBRARY_PATH + sys_lib_search_path_spec="/shlib /usr/lib /usr/X11/lib /usr/contrib/lib /lib /usr/local/lib" + sys_lib_dlsearch_path_spec="/shlib /usr/lib /usr/local/lib" + # the default ld.so.conf also contains /usr/contrib/lib and + # /usr/X11R6/lib (/usr/X11 is a link to /usr/X11R6), but let us allow + # libtool to hard-code these into programs + ;; + +cygwin* | mingw* | pw32* | cegcc*) + version_type=windows + shrext_cmds=.dll + need_version=no + need_lib_prefix=no + + case $GCC,$cc_basename in + yes,*) + # gcc + library_names_spec='$libname.dll.a' + # DLL is installed to $(libdir)/../bin by postinstall_cmds + postinstall_cmds='base_file=`basename \$file`~ + dlpath=`$SHELL 2>&1 -c '\''. $dir/'\''\$base_file'\''i; echo \$dlname'\''`~ + dldir=$destdir/`dirname \$dlpath`~ + test -d \$dldir || mkdir -p \$dldir~ + $install_prog $dir/$dlname \$dldir/$dlname~ + chmod a+x \$dldir/$dlname~ + if test -n '\''$stripme'\'' && test -n '\''$striplib'\''; then + eval '\''$striplib \$dldir/$dlname'\'' || exit \$?; + fi' + postuninstall_cmds='dldll=`$SHELL 2>&1 -c '\''. $file; echo \$dlname'\''`~ + dlpath=$dir/\$dldll~ + $RM \$dlpath' + shlibpath_overrides_runpath=yes + + case $host_os in + cygwin*) + # Cygwin DLLs use 'cyg' prefix rather than 'lib' + soname_spec='`echo $libname | $SED -e 's/^lib/cyg/'``echo $release | $SED -e 's/[.]/-/g'`$versuffix$shared_ext' + + sys_lib_search_path_spec="$sys_lib_search_path_spec /usr/lib/w32api" + ;; + mingw* | cegcc*) + # MinGW DLLs use traditional 'lib' prefix + soname_spec='$libname`echo $release | $SED -e 's/[.]/-/g'`$versuffix$shared_ext' + ;; + pw32*) + # pw32 DLLs use 'pw' prefix rather than 'lib' + library_names_spec='`echo $libname | $SED -e 's/^lib/pw/'``echo $release | $SED -e 's/[.]/-/g'`$versuffix$shared_ext' + ;; + esac + dynamic_linker='Win32 ld.exe' + ;; + + *,cl* | *,icl*) + # Native MSVC or ICC + libname_spec='$name' + soname_spec='$libname`echo $release | $SED -e 's/[.]/-/g'`$versuffix$shared_ext' + library_names_spec='$libname.dll.lib' + + case $build_os in + mingw*) + sys_lib_search_path_spec= + lt_save_ifs=$IFS + IFS=';' + for lt_path in $LIB + do + IFS=$lt_save_ifs + # Let DOS variable expansion print the short 8.3 style file name. + lt_path=`cd "$lt_path" 2>/dev/null && cmd //C "for %i in (".") do @echo %~si"` + sys_lib_search_path_spec="$sys_lib_search_path_spec $lt_path" + done + IFS=$lt_save_ifs + # Convert to MSYS style. + sys_lib_search_path_spec=`$ECHO "$sys_lib_search_path_spec" | $SED -e 's|\\\\|/|g' -e 's| \\([a-zA-Z]\\):| /\\1|g' -e 's|^ ||'` + ;; + cygwin*) + # Convert to unix form, then to dos form, then back to unix form + # but this time dos style (no spaces!) so that the unix form looks + # like /cygdrive/c/PROGRA~1:/cygdr... + sys_lib_search_path_spec=`cygpath --path --unix "$LIB"` + sys_lib_search_path_spec=`cygpath --path --dos "$sys_lib_search_path_spec" 2>/dev/null` + sys_lib_search_path_spec=`cygpath --path --unix "$sys_lib_search_path_spec" | $SED -e "s/$PATH_SEPARATOR/ /g"` + ;; + *) + sys_lib_search_path_spec=$LIB + if $ECHO "$sys_lib_search_path_spec" | $GREP ';[c-zC-Z]:/' >/dev/null; then + # It is most probably a Windows format PATH. + sys_lib_search_path_spec=`$ECHO "$sys_lib_search_path_spec" | $SED -e 's/;/ /g'` + else + sys_lib_search_path_spec=`$ECHO "$sys_lib_search_path_spec" | $SED -e "s/$PATH_SEPARATOR/ /g"` + fi + # FIXME: find the short name or the path components, as spaces are + # common. (e.g. "Program Files" -> "PROGRA~1") + ;; + esac + + # DLL is installed to $(libdir)/../bin by postinstall_cmds + postinstall_cmds='base_file=`basename \$file`~ + dlpath=`$SHELL 2>&1 -c '\''. $dir/'\''\$base_file'\''i; echo \$dlname'\''`~ + dldir=$destdir/`dirname \$dlpath`~ + test -d \$dldir || mkdir -p \$dldir~ + $install_prog $dir/$dlname \$dldir/$dlname' + postuninstall_cmds='dldll=`$SHELL 2>&1 -c '\''. $file; echo \$dlname'\''`~ + dlpath=$dir/\$dldll~ + $RM \$dlpath' + shlibpath_overrides_runpath=yes + dynamic_linker='Win32 link.exe' + ;; + + *) + # Assume MSVC and ICC wrapper + library_names_spec='$libname`echo $release | $SED -e 's/[.]/-/g'`$versuffix$shared_ext $libname.lib' + dynamic_linker='Win32 ld.exe' + ;; + esac + # FIXME: first we should search . and the directory the executable is in + shlibpath_var=PATH + ;; + +darwin* | rhapsody*) + dynamic_linker="$host_os dyld" + version_type=darwin + need_lib_prefix=no + need_version=no + library_names_spec='$libname$release$major$shared_ext $libname$shared_ext' + soname_spec='$libname$release$major$shared_ext' + shlibpath_overrides_runpath=yes + shlibpath_var=DYLD_LIBRARY_PATH + shrext_cmds='`test .$module = .yes && echo .so || echo .dylib`' + + sys_lib_search_path_spec="$sys_lib_search_path_spec /usr/local/lib" + sys_lib_dlsearch_path_spec='/usr/local/lib /lib /usr/lib' + ;; + +dgux*) + version_type=linux # correct to gnu/linux during the next big refactor + need_lib_prefix=no + need_version=no + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + soname_spec='$libname$release$shared_ext$major' + shlibpath_var=LD_LIBRARY_PATH + ;; + +freebsd* | dragonfly* | midnightbsd*) + # DragonFly does not have aout. When/if they implement a new + # versioning mechanism, adjust this. + if test -x /usr/bin/objformat; then + objformat=`/usr/bin/objformat` + else + case $host_os in + freebsd[23].*) objformat=aout ;; + *) objformat=elf ;; + esac + fi + version_type=freebsd-$objformat + case $version_type in + freebsd-elf*) + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + soname_spec='$libname$release$shared_ext$major' + need_version=no + need_lib_prefix=no + ;; + freebsd-*) + library_names_spec='$libname$release$shared_ext$versuffix $libname$shared_ext$versuffix' + need_version=yes + ;; + esac + shlibpath_var=LD_LIBRARY_PATH + case $host_os in + freebsd2.*) + shlibpath_overrides_runpath=yes + ;; + freebsd3.[01]* | freebsdelf3.[01]*) + shlibpath_overrides_runpath=yes + hardcode_into_libs=yes + ;; + freebsd3.[2-9]* | freebsdelf3.[2-9]* | \ + freebsd4.[0-5] | freebsdelf4.[0-5] | freebsd4.1.1 | freebsdelf4.1.1) + shlibpath_overrides_runpath=no + hardcode_into_libs=yes + ;; + *) # from 4.6 on, and DragonFly + shlibpath_overrides_runpath=yes + hardcode_into_libs=yes + ;; + esac + ;; + +haiku*) + version_type=linux # correct to gnu/linux during the next big refactor + need_lib_prefix=no + need_version=no + dynamic_linker="$host_os runtime_loader" + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + soname_spec='$libname$release$shared_ext$major' + shlibpath_var=LIBRARY_PATH + shlibpath_overrides_runpath=no + sys_lib_dlsearch_path_spec='/boot/home/config/lib /boot/common/lib /boot/system/lib' + hardcode_into_libs=yes + ;; + +hpux9* | hpux10* | hpux11*) + # Give a soname corresponding to the major version so that dld.sl refuses to + # link against other versions. + version_type=sunos + need_lib_prefix=no + need_version=no + case $host_cpu in + ia64*) + shrext_cmds='.so' + hardcode_into_libs=yes + dynamic_linker="$host_os dld.so" + shlibpath_var=LD_LIBRARY_PATH + shlibpath_overrides_runpath=yes # Unless +noenvvar is specified. + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + soname_spec='$libname$release$shared_ext$major' + if test 32 = "$HPUX_IA64_MODE"; then + sys_lib_search_path_spec="/usr/lib/hpux32 /usr/local/lib/hpux32 /usr/local/lib" + sys_lib_dlsearch_path_spec=/usr/lib/hpux32 + else + sys_lib_search_path_spec="/usr/lib/hpux64 /usr/local/lib/hpux64" + sys_lib_dlsearch_path_spec=/usr/lib/hpux64 + fi + ;; + hppa*64*) + shrext_cmds='.sl' + hardcode_into_libs=yes + dynamic_linker="$host_os dld.sl" + shlibpath_var=LD_LIBRARY_PATH # How should we handle SHLIB_PATH + shlibpath_overrides_runpath=yes # Unless +noenvvar is specified. + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + soname_spec='$libname$release$shared_ext$major' + sys_lib_search_path_spec="/usr/lib/pa20_64 /usr/ccs/lib/pa20_64" + sys_lib_dlsearch_path_spec=$sys_lib_search_path_spec + ;; + *) + shrext_cmds='.sl' + dynamic_linker="$host_os dld.sl" + shlibpath_var=SHLIB_PATH + shlibpath_overrides_runpath=no # +s is required to enable SHLIB_PATH + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + soname_spec='$libname$release$shared_ext$major' + ;; + esac + # HP-UX runs *really* slowly unless shared libraries are mode 555, ... + postinstall_cmds='chmod 555 $lib' + # or fails outright, so override atomically: + install_override_mode=555 + ;; + +interix[3-9]*) + version_type=linux # correct to gnu/linux during the next big refactor + need_lib_prefix=no + need_version=no + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + soname_spec='$libname$release$shared_ext$major' + dynamic_linker='Interix 3.x ld.so.1 (PE, like ELF)' + shlibpath_var=LD_LIBRARY_PATH + shlibpath_overrides_runpath=no + hardcode_into_libs=yes + ;; + +irix5* | irix6* | nonstopux*) + case $host_os in + nonstopux*) version_type=nonstopux ;; + *) + if test yes = "$lt_cv_prog_gnu_ld"; then + version_type=linux # correct to gnu/linux during the next big refactor + else + version_type=irix + fi ;; + esac + need_lib_prefix=no + need_version=no + soname_spec='$libname$release$shared_ext$major' + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$release$shared_ext $libname$shared_ext' + case $host_os in + irix5* | nonstopux*) + libsuff= shlibsuff= + ;; + *) + case $LD in # libtool.m4 will add one of these switches to LD + *-32|*"-32 "|*-melf32bsmip|*"-melf32bsmip ") + libsuff= shlibsuff= libmagic=32-bit;; + *-n32|*"-n32 "|*-melf32bmipn32|*"-melf32bmipn32 ") + libsuff=32 shlibsuff=N32 libmagic=N32;; + *-64|*"-64 "|*-melf64bmip|*"-melf64bmip ") + libsuff=64 shlibsuff=64 libmagic=64-bit;; + *) libsuff= shlibsuff= libmagic=never-match;; + esac + ;; + esac + shlibpath_var=LD_LIBRARY${shlibsuff}_PATH + shlibpath_overrides_runpath=no + sys_lib_search_path_spec="/usr/lib$libsuff /lib$libsuff /usr/local/lib$libsuff" + sys_lib_dlsearch_path_spec="/usr/lib$libsuff /lib$libsuff" + hardcode_into_libs=yes + ;; + +# No shared lib support for Linux oldld, aout, or coff. +linux*oldld* | linux*aout* | linux*coff*) + dynamic_linker=no + ;; + +linux*android*) + version_type=none # Android doesn't support versioned libraries. + need_lib_prefix=no + need_version=no + library_names_spec='$libname$release$shared_ext' + soname_spec='$libname$release$shared_ext' + finish_cmds= + shlibpath_var=LD_LIBRARY_PATH + shlibpath_overrides_runpath=yes + + # This implies no fast_install, which is unacceptable. + # Some rework will be needed to allow for fast_install + # before this can be enabled. + hardcode_into_libs=yes + + dynamic_linker='Android linker' + # Don't embed -rpath directories since the linker doesn't support them. + hardcode_libdir_flag_spec='-L$libdir' + ;; + +# This must be glibc/ELF. +linux* | k*bsd*-gnu | kopensolaris*-gnu | gnu*) + version_type=linux # correct to gnu/linux during the next big refactor + need_lib_prefix=no + need_version=no + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + soname_spec='$libname$release$shared_ext$major' + finish_cmds='PATH="\$PATH:/sbin" ldconfig -n $libdir' + shlibpath_var=LD_LIBRARY_PATH + shlibpath_overrides_runpath=no + + # Some binutils ld are patched to set DT_RUNPATH + if test ${lt_cv_shlibpath_overrides_runpath+y} +then : + printf %s "(cached) " >&6 +else $as_nop + lt_cv_shlibpath_overrides_runpath=no + save_LDFLAGS=$LDFLAGS + save_libdir=$libdir + eval "libdir=/foo; wl=\"$lt_prog_compiler_wl\"; \ + LDFLAGS=\"\$LDFLAGS $hardcode_libdir_flag_spec\"" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int main(void) +{ + + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + if ($OBJDUMP -p conftest$ac_exeext) 2>/dev/null | grep "RUNPATH.*$libdir" >/dev/null +then : + lt_cv_shlibpath_overrides_runpath=yes +fi +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + LDFLAGS=$save_LDFLAGS + libdir=$save_libdir + +fi + + shlibpath_overrides_runpath=$lt_cv_shlibpath_overrides_runpath + + # This implies no fast_install, which is unacceptable. + # Some rework will be needed to allow for fast_install + # before this can be enabled. + hardcode_into_libs=yes + + # Ideally, we could use ldconfig to report *all* directores which are + # searched for libraries, however this is still not possible. Aside from not + # being certain /sbin/ldconfig is available, command + # 'ldconfig -N -X -v | grep ^/' on 64bit Fedora does not report /usr/lib64, + # even though it is searched at run-time. Try to do the best guess by + # appending ld.so.conf contents (and includes) to the search path. + if test -f /etc/ld.so.conf; then + lt_ld_extra=`awk '/^include / { system(sprintf("cd /etc; cat %s 2>/dev/null", \$2)); skip = 1; } { if (!skip) print \$0; skip = 0; }' < /etc/ld.so.conf | $SED -e 's/#.*//;/^[ ]*hwcap[ ]/d;s/[:, ]/ /g;s/=[^=]*$//;s/=[^= ]* / /g;s/"//g;/^$/d' | tr '\n' ' '` + sys_lib_dlsearch_path_spec="/lib /usr/lib $lt_ld_extra" + fi + + # We used to test for /lib/ld.so.1 and disable shared libraries on + # powerpc, because MkLinux only supported shared libraries with the + # GNU dynamic linker. Since this was broken with cross compilers, + # most powerpc-linux boxes support dynamic linking these days and + # people can always --disable-shared, the test was removed, and we + # assume the GNU/Linux dynamic linker is in use. + dynamic_linker='GNU/Linux ld.so' + ;; + +netbsdelf*-gnu) + version_type=linux + need_lib_prefix=no + need_version=no + library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major ${libname}${shared_ext}' + soname_spec='${libname}${release}${shared_ext}$major' + shlibpath_var=LD_LIBRARY_PATH + shlibpath_overrides_runpath=no + hardcode_into_libs=yes + dynamic_linker='NetBSD ld.elf_so' + ;; + +netbsd*) + version_type=sunos + need_lib_prefix=no + need_version=no + if echo __ELF__ | $CC -E - | $GREP __ELF__ >/dev/null; then + library_names_spec='$libname$release$shared_ext$versuffix $libname$shared_ext$versuffix' + finish_cmds='PATH="\$PATH:/sbin" ldconfig -m $libdir' + dynamic_linker='NetBSD (a.out) ld.so' + else + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + soname_spec='$libname$release$shared_ext$major' + dynamic_linker='NetBSD ld.elf_so' + fi + shlibpath_var=LD_LIBRARY_PATH + shlibpath_overrides_runpath=yes + hardcode_into_libs=yes + ;; + +newsos6) + version_type=linux # correct to gnu/linux during the next big refactor + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + shlibpath_var=LD_LIBRARY_PATH + shlibpath_overrides_runpath=yes + ;; + +*nto* | *qnx*) + version_type=qnx + need_lib_prefix=no + need_version=no + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + soname_spec='$libname$release$shared_ext$major' + shlibpath_var=LD_LIBRARY_PATH + shlibpath_overrides_runpath=no + hardcode_into_libs=yes + dynamic_linker='ldqnx.so' + ;; + +openbsd* | bitrig*) + version_type=sunos + sys_lib_dlsearch_path_spec=/usr/lib + need_lib_prefix=no + if test -z "`echo __ELF__ | $CC -E - | $GREP __ELF__`"; then + need_version=no + else + need_version=yes + fi + library_names_spec='$libname$release$shared_ext$versuffix $libname$shared_ext$versuffix' + finish_cmds='PATH="\$PATH:/sbin" ldconfig -m $libdir' + shlibpath_var=LD_LIBRARY_PATH + shlibpath_overrides_runpath=yes + ;; + +os2*) + libname_spec='$name' + version_type=windows + shrext_cmds=.dll + need_version=no + need_lib_prefix=no + # OS/2 can only load a DLL with a base name of 8 characters or less. + soname_spec='`test -n "$os2dllname" && libname="$os2dllname"; + v=$($ECHO $release$versuffix | tr -d .-); + n=$($ECHO $libname | cut -b -$((8 - ${#v})) | tr . _); + $ECHO $n$v`$shared_ext' + library_names_spec='${libname}_dll.$libext' + dynamic_linker='OS/2 ld.exe' + shlibpath_var=BEGINLIBPATH + sys_lib_search_path_spec="/lib /usr/lib /usr/local/lib" + sys_lib_dlsearch_path_spec=$sys_lib_search_path_spec + postinstall_cmds='base_file=`basename \$file`~ + dlpath=`$SHELL 2>&1 -c '\''. $dir/'\''\$base_file'\''i; $ECHO \$dlname'\''`~ + dldir=$destdir/`dirname \$dlpath`~ + test -d \$dldir || mkdir -p \$dldir~ + $install_prog $dir/$dlname \$dldir/$dlname~ + chmod a+x \$dldir/$dlname~ + if test -n '\''$stripme'\'' && test -n '\''$striplib'\''; then + eval '\''$striplib \$dldir/$dlname'\'' || exit \$?; + fi' + postuninstall_cmds='dldll=`$SHELL 2>&1 -c '\''. $file; $ECHO \$dlname'\''`~ + dlpath=$dir/\$dldll~ + $RM \$dlpath' + ;; + +osf3* | osf4* | osf5*) + version_type=osf + need_lib_prefix=no + need_version=no + soname_spec='$libname$release$shared_ext$major' + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + shlibpath_var=LD_LIBRARY_PATH + sys_lib_search_path_spec="/usr/shlib /usr/ccs/lib /usr/lib/cmplrs/cc /usr/lib /usr/local/lib /var/shlib" + sys_lib_dlsearch_path_spec=$sys_lib_search_path_spec + ;; + +rdos*) + dynamic_linker=no + ;; + +solaris*) + version_type=linux # correct to gnu/linux during the next big refactor + need_lib_prefix=no + need_version=no + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + soname_spec='$libname$release$shared_ext$major' + shlibpath_var=LD_LIBRARY_PATH + shlibpath_overrides_runpath=yes + hardcode_into_libs=yes + # ldd complains unless libraries are executable + postinstall_cmds='chmod +x $lib' + ;; + +sunos4*) + version_type=sunos + library_names_spec='$libname$release$shared_ext$versuffix $libname$shared_ext$versuffix' + finish_cmds='PATH="\$PATH:/usr/etc" ldconfig $libdir' + shlibpath_var=LD_LIBRARY_PATH + shlibpath_overrides_runpath=yes + if test yes = "$with_gnu_ld"; then + need_lib_prefix=no + fi + need_version=yes + ;; + +sysv4 | sysv4.3*) + version_type=linux # correct to gnu/linux during the next big refactor + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + soname_spec='$libname$release$shared_ext$major' + shlibpath_var=LD_LIBRARY_PATH + case $host_vendor in + sni) + shlibpath_overrides_runpath=no + need_lib_prefix=no + runpath_var=LD_RUN_PATH + ;; + siemens) + need_lib_prefix=no + ;; + motorola) + need_lib_prefix=no + need_version=no + shlibpath_overrides_runpath=no + sys_lib_search_path_spec='/lib /usr/lib /usr/ccs/lib' + ;; + esac + ;; + +sysv4*MP*) + if test -d /usr/nec; then + version_type=linux # correct to gnu/linux during the next big refactor + library_names_spec='$libname$shared_ext.$versuffix $libname$shared_ext.$major $libname$shared_ext' + soname_spec='$libname$shared_ext.$major' + shlibpath_var=LD_LIBRARY_PATH + fi + ;; + +sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX* | sysv4*uw2*) + version_type=sco + need_lib_prefix=no + need_version=no + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext $libname$shared_ext' + soname_spec='$libname$release$shared_ext$major' + shlibpath_var=LD_LIBRARY_PATH + shlibpath_overrides_runpath=yes + hardcode_into_libs=yes + if test yes = "$with_gnu_ld"; then + sys_lib_search_path_spec='/usr/local/lib /usr/gnu/lib /usr/ccs/lib /usr/lib /lib' + else + sys_lib_search_path_spec='/usr/ccs/lib /usr/lib' + case $host_os in + sco3.2v5*) + sys_lib_search_path_spec="$sys_lib_search_path_spec /lib" + ;; + esac + fi + sys_lib_dlsearch_path_spec='/usr/lib' + ;; + +tpf*) + # TPF is a cross-target only. Preferred cross-host = GNU/Linux. + version_type=linux # correct to gnu/linux during the next big refactor + need_lib_prefix=no + need_version=no + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + shlibpath_var=LD_LIBRARY_PATH + shlibpath_overrides_runpath=no + hardcode_into_libs=yes + ;; + +uts4*) + version_type=linux # correct to gnu/linux during the next big refactor + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + soname_spec='$libname$release$shared_ext$major' + shlibpath_var=LD_LIBRARY_PATH + ;; + +*) + dynamic_linker=no + ;; +esac +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $dynamic_linker" >&5 +printf "%s\n" "$dynamic_linker" >&6; } +test no = "$dynamic_linker" && can_build_shared=no + +variables_saved_for_relink="PATH $shlibpath_var $runpath_var" +if test yes = "$GCC"; then + variables_saved_for_relink="$variables_saved_for_relink GCC_EXEC_PREFIX COMPILER_PATH LIBRARY_PATH" +fi + +if test set = "${lt_cv_sys_lib_search_path_spec+set}"; then + sys_lib_search_path_spec=$lt_cv_sys_lib_search_path_spec +fi + +if test set = "${lt_cv_sys_lib_dlsearch_path_spec+set}"; then + sys_lib_dlsearch_path_spec=$lt_cv_sys_lib_dlsearch_path_spec +fi + +# remember unaugmented sys_lib_dlsearch_path content for libtool script decls... +configure_time_dlsearch_path=$sys_lib_dlsearch_path_spec + +# ... but it needs LT_SYS_LIBRARY_PATH munging for other configure-time code +func_munge_path_list sys_lib_dlsearch_path_spec "$LT_SYS_LIBRARY_PATH" + +# to be used as default LT_SYS_LIBRARY_PATH value in generated libtool +configure_time_lt_sys_library_path=$LT_SYS_LIBRARY_PATH + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to hardcode library paths into programs" >&5 +printf %s "checking how to hardcode library paths into programs... " >&6; } +hardcode_action= +if test -n "$hardcode_libdir_flag_spec" || + test -n "$runpath_var" || + test yes = "$hardcode_automatic"; then + + # We can hardcode non-existent directories. + if test no != "$hardcode_direct" && + # If the only mechanism to avoid hardcoding is shlibpath_var, we + # have to relink, otherwise we might link with an installed library + # when we should be linking with a yet-to-be-installed one + ## test no != "$_LT_TAGVAR(hardcode_shlibpath_var, )" && + test no != "$hardcode_minus_L"; then + # Linking always hardcodes the temporary library directory. + hardcode_action=relink + else + # We can link without hardcoding, and we can hardcode nonexisting dirs. + hardcode_action=immediate + fi +else + # We cannot hardcode anything, or else we can only hardcode existing + # directories. + hardcode_action=unsupported +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $hardcode_action" >&5 +printf "%s\n" "$hardcode_action" >&6; } + +if test relink = "$hardcode_action" || + test yes = "$inherit_rpath"; then + # Fast installation is not supported + enable_fast_install=no +elif test yes = "$shlibpath_overrides_runpath" || + test no = "$enable_shared"; then + # Fast installation is not necessary + enable_fast_install=needless +fi + + + + + + + if test yes != "$enable_dlopen"; then + enable_dlopen=unknown + enable_dlopen_self=unknown + enable_dlopen_self_static=unknown +else + lt_cv_dlopen=no + lt_cv_dlopen_libs= + + case $host_os in + beos*) + lt_cv_dlopen=load_add_on + lt_cv_dlopen_libs= + lt_cv_dlopen_self=yes + ;; + + mingw* | pw32* | cegcc*) + lt_cv_dlopen=LoadLibrary + lt_cv_dlopen_libs= + ;; + + cygwin*) + lt_cv_dlopen=dlopen + lt_cv_dlopen_libs= + ;; + + darwin*) + # if libdl is installed we need to link against it + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5 +printf %s "checking for dlopen in -ldl... " >&6; } +if test ${ac_cv_lib_dl_dlopen+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-ldl $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char dlopen (); +int main(void) +{ +return dlopen (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_dl_dlopen=yes +else $as_nop + ac_cv_lib_dl_dlopen=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlopen" >&5 +printf "%s\n" "$ac_cv_lib_dl_dlopen" >&6; } +if test "x$ac_cv_lib_dl_dlopen" = xyes +then : + lt_cv_dlopen=dlopen lt_cv_dlopen_libs=-ldl +else $as_nop + + lt_cv_dlopen=dyld + lt_cv_dlopen_libs= + lt_cv_dlopen_self=yes + +fi + + ;; + + tpf*) + # Don't try to run any link tests for TPF. We know it's impossible + # because TPF is a cross-compiler, and we know how we open DSOs. + lt_cv_dlopen=dlopen + lt_cv_dlopen_libs= + lt_cv_dlopen_self=no + ;; + + *) + ac_fn_c_check_func "$LINENO" "shl_load" "ac_cv_func_shl_load" +if test "x$ac_cv_func_shl_load" = xyes +then : + lt_cv_dlopen=shl_load +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for shl_load in -ldld" >&5 +printf %s "checking for shl_load in -ldld... " >&6; } +if test ${ac_cv_lib_dld_shl_load+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-ldld $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char shl_load (); +int main(void) +{ +return shl_load (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_dld_shl_load=yes +else $as_nop + ac_cv_lib_dld_shl_load=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dld_shl_load" >&5 +printf "%s\n" "$ac_cv_lib_dld_shl_load" >&6; } +if test "x$ac_cv_lib_dld_shl_load" = xyes +then : + lt_cv_dlopen=shl_load lt_cv_dlopen_libs=-ldld +else $as_nop + ac_fn_c_check_func "$LINENO" "dlopen" "ac_cv_func_dlopen" +if test "x$ac_cv_func_dlopen" = xyes +then : + lt_cv_dlopen=dlopen +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5 +printf %s "checking for dlopen in -ldl... " >&6; } +if test ${ac_cv_lib_dl_dlopen+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-ldl $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char dlopen (); +int main(void) +{ +return dlopen (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_dl_dlopen=yes +else $as_nop + ac_cv_lib_dl_dlopen=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlopen" >&5 +printf "%s\n" "$ac_cv_lib_dl_dlopen" >&6; } +if test "x$ac_cv_lib_dl_dlopen" = xyes +then : + lt_cv_dlopen=dlopen lt_cv_dlopen_libs=-ldl +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for dlopen in -lsvld" >&5 +printf %s "checking for dlopen in -lsvld... " >&6; } +if test ${ac_cv_lib_svld_dlopen+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lsvld $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char dlopen (); +int main(void) +{ +return dlopen (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_svld_dlopen=yes +else $as_nop + ac_cv_lib_svld_dlopen=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_svld_dlopen" >&5 +printf "%s\n" "$ac_cv_lib_svld_dlopen" >&6; } +if test "x$ac_cv_lib_svld_dlopen" = xyes +then : + lt_cv_dlopen=dlopen lt_cv_dlopen_libs=-lsvld +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for dld_link in -ldld" >&5 +printf %s "checking for dld_link in -ldld... " >&6; } +if test ${ac_cv_lib_dld_dld_link+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-ldld $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char dld_link (); +int main(void) +{ +return dld_link (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_dld_dld_link=yes +else $as_nop + ac_cv_lib_dld_dld_link=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dld_dld_link" >&5 +printf "%s\n" "$ac_cv_lib_dld_dld_link" >&6; } +if test "x$ac_cv_lib_dld_dld_link" = xyes +then : + lt_cv_dlopen=dld_link lt_cv_dlopen_libs=-ldld +fi + + +fi + + +fi + + +fi + + +fi + + +fi + + ;; + esac + + if test no = "$lt_cv_dlopen"; then + enable_dlopen=no + else + enable_dlopen=yes + fi + + case $lt_cv_dlopen in + dlopen) + save_CPPFLAGS=$CPPFLAGS + test yes = "$ac_cv_header_dlfcn_h" && CPPFLAGS="$CPPFLAGS -DHAVE_DLFCN_H" + + save_LDFLAGS=$LDFLAGS + wl=$lt_prog_compiler_wl eval LDFLAGS=\"\$LDFLAGS $export_dynamic_flag_spec\" + + save_LIBS=$LIBS + LIBS="$lt_cv_dlopen_libs $LIBS" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether a program can dlopen itself" >&5 +printf %s "checking whether a program can dlopen itself... " >&6; } +if test ${lt_cv_dlopen_self+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test yes = "$cross_compiling"; then : + lt_cv_dlopen_self=cross +else + lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2 + lt_status=$lt_dlunknown + cat > conftest.$ac_ext <<_LT_EOF +#line $LINENO "configure" +#include "confdefs.h" + +#if HAVE_DLFCN_H +#include +#endif + +#include + +#ifdef RTLD_GLOBAL +# define LT_DLGLOBAL RTLD_GLOBAL +#else +# ifdef DL_GLOBAL +# define LT_DLGLOBAL DL_GLOBAL +# else +# define LT_DLGLOBAL 0 +# endif +#endif + +/* We may have to define LT_DLLAZY_OR_NOW in the command line if we + find out it does not work in some platform. */ +#ifndef LT_DLLAZY_OR_NOW +# ifdef RTLD_LAZY +# define LT_DLLAZY_OR_NOW RTLD_LAZY +# else +# ifdef DL_LAZY +# define LT_DLLAZY_OR_NOW DL_LAZY +# else +# ifdef RTLD_NOW +# define LT_DLLAZY_OR_NOW RTLD_NOW +# else +# ifdef DL_NOW +# define LT_DLLAZY_OR_NOW DL_NOW +# else +# define LT_DLLAZY_OR_NOW 0 +# endif +# endif +# endif +# endif +#endif + +/* When -fvisibility=hidden is used, assume the code has been annotated + correspondingly for the symbols needed. */ +#if defined __GNUC__ && (((__GNUC__ == 3) && (__GNUC_MINOR__ >= 3)) || (__GNUC__ > 3)) +int fnord () __attribute__((visibility("default"))); +#endif + +int fnord () { return 42; } +int main () +{ + void *self = dlopen (0, LT_DLGLOBAL|LT_DLLAZY_OR_NOW); + int status = $lt_dlunknown; + + if (self) + { + if (dlsym (self,"fnord")) status = $lt_dlno_uscore; + else + { + if (dlsym( self,"_fnord")) status = $lt_dlneed_uscore; + else puts (dlerror ()); + } + /* dlclose (self); */ + } + else + puts (dlerror ()); + + return status; +} +_LT_EOF + if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_link\""; } >&5 + (eval $ac_link) 2>&5 + ac_status=$? + printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && test -s "conftest$ac_exeext" 2>/dev/null; then + (./conftest; exit; ) >&5 2>/dev/null + lt_status=$? + case x$lt_status in + x$lt_dlno_uscore) lt_cv_dlopen_self=yes ;; + x$lt_dlneed_uscore) lt_cv_dlopen_self=yes ;; + x$lt_dlunknown|x*) lt_cv_dlopen_self=no ;; + esac + else : + # compilation failed + lt_cv_dlopen_self=no + fi +fi +rm -fr conftest* + + +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_dlopen_self" >&5 +printf "%s\n" "$lt_cv_dlopen_self" >&6; } + + if test yes = "$lt_cv_dlopen_self"; then + wl=$lt_prog_compiler_wl eval LDFLAGS=\"\$LDFLAGS $lt_prog_compiler_static\" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether a statically linked program can dlopen itself" >&5 +printf %s "checking whether a statically linked program can dlopen itself... " >&6; } +if test ${lt_cv_dlopen_self_static+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test yes = "$cross_compiling"; then : + lt_cv_dlopen_self_static=cross +else + lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2 + lt_status=$lt_dlunknown + cat > conftest.$ac_ext <<_LT_EOF +#line $LINENO "configure" +#include "confdefs.h" + +#if HAVE_DLFCN_H +#include +#endif + +#include + +#ifdef RTLD_GLOBAL +# define LT_DLGLOBAL RTLD_GLOBAL +#else +# ifdef DL_GLOBAL +# define LT_DLGLOBAL DL_GLOBAL +# else +# define LT_DLGLOBAL 0 +# endif +#endif + +/* We may have to define LT_DLLAZY_OR_NOW in the command line if we + find out it does not work in some platform. */ +#ifndef LT_DLLAZY_OR_NOW +# ifdef RTLD_LAZY +# define LT_DLLAZY_OR_NOW RTLD_LAZY +# else +# ifdef DL_LAZY +# define LT_DLLAZY_OR_NOW DL_LAZY +# else +# ifdef RTLD_NOW +# define LT_DLLAZY_OR_NOW RTLD_NOW +# else +# ifdef DL_NOW +# define LT_DLLAZY_OR_NOW DL_NOW +# else +# define LT_DLLAZY_OR_NOW 0 +# endif +# endif +# endif +# endif +#endif + +/* When -fvisibility=hidden is used, assume the code has been annotated + correspondingly for the symbols needed. */ +#if defined __GNUC__ && (((__GNUC__ == 3) && (__GNUC_MINOR__ >= 3)) || (__GNUC__ > 3)) +int fnord () __attribute__((visibility("default"))); +#endif + +int fnord () { return 42; } +int main () +{ + void *self = dlopen (0, LT_DLGLOBAL|LT_DLLAZY_OR_NOW); + int status = $lt_dlunknown; + + if (self) + { + if (dlsym (self,"fnord")) status = $lt_dlno_uscore; + else + { + if (dlsym( self,"_fnord")) status = $lt_dlneed_uscore; + else puts (dlerror ()); + } + /* dlclose (self); */ + } + else + puts (dlerror ()); + + return status; +} +_LT_EOF + if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_link\""; } >&5 + (eval $ac_link) 2>&5 + ac_status=$? + printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && test -s "conftest$ac_exeext" 2>/dev/null; then + (./conftest; exit; ) >&5 2>/dev/null + lt_status=$? + case x$lt_status in + x$lt_dlno_uscore) lt_cv_dlopen_self_static=yes ;; + x$lt_dlneed_uscore) lt_cv_dlopen_self_static=yes ;; + x$lt_dlunknown|x*) lt_cv_dlopen_self_static=no ;; + esac + else : + # compilation failed + lt_cv_dlopen_self_static=no + fi +fi +rm -fr conftest* + + +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_dlopen_self_static" >&5 +printf "%s\n" "$lt_cv_dlopen_self_static" >&6; } + fi + + CPPFLAGS=$save_CPPFLAGS + LDFLAGS=$save_LDFLAGS + LIBS=$save_LIBS + ;; + esac + + case $lt_cv_dlopen_self in + yes|no) enable_dlopen_self=$lt_cv_dlopen_self ;; + *) enable_dlopen_self=unknown ;; + esac + + case $lt_cv_dlopen_self_static in + yes|no) enable_dlopen_self_static=$lt_cv_dlopen_self_static ;; + *) enable_dlopen_self_static=unknown ;; + esac +fi + + + + + + + + + + + + + + + + + +striplib= +old_striplib= +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether stripping libraries is possible" >&5 +printf %s "checking whether stripping libraries is possible... " >&6; } +if test -z "$STRIP"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +else + if $STRIP -V 2>&1 | $GREP "GNU strip" >/dev/null; then + old_striplib="$STRIP --strip-debug" + striplib="$STRIP --strip-unneeded" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + else + case $host_os in + darwin*) + # FIXME - insert some real tests, host_os isn't really good enough + striplib="$STRIP -x" + old_striplib="$STRIP -S" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + freebsd*) + if $STRIP -V 2>&1 | $GREP "elftoolchain" >/dev/null; then + old_striplib="$STRIP --strip-debug" + striplib="$STRIP --strip-unneeded" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + fi + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + ;; + esac + fi +fi + + + + + + + + + + + + + # Report what library types will actually be built + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if libtool supports shared libraries" >&5 +printf %s "checking if libtool supports shared libraries... " >&6; } + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $can_build_shared" >&5 +printf "%s\n" "$can_build_shared" >&6; } + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to build shared libraries" >&5 +printf %s "checking whether to build shared libraries... " >&6; } + test no = "$can_build_shared" && enable_shared=no + + # On AIX, shared libraries and static libraries use the same namespace, and + # are all built from PIC. + case $host_os in + aix3*) + test yes = "$enable_shared" && enable_static=no + if test -n "$RANLIB"; then + archive_cmds="$archive_cmds~\$RANLIB \$lib" + postinstall_cmds='$RANLIB $lib' + fi + ;; + + aix[4-9]*) + if test ia64 != "$host_cpu"; then + case $enable_shared,$with_aix_soname,$aix_use_runtimelinking in + yes,aix,yes) ;; # shared object as lib.so file only + yes,svr4,*) ;; # shared object as lib.so archive member only + yes,*) enable_static=no ;; # shared object in lib.a archive as well + esac + fi + ;; + esac + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $enable_shared" >&5 +printf "%s\n" "$enable_shared" >&6; } + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to build static libraries" >&5 +printf %s "checking whether to build static libraries... " >&6; } + # Make sure either enable_shared or enable_static is yes. + test yes = "$enable_shared" || enable_static=yes + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $enable_static" >&5 +printf "%s\n" "$enable_static" >&6; } + + + + +fi +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + +CC=$lt_save_CC + + + + + + + + + + + + + + + + ac_config_commands="$ac_config_commands libtool" + + + + +# Only expand once: + + + + + + + + +# +# Verify if finally libtool shared libraries are built +# +case "x$enable_shared" in # (( + xyes | xno) + xc_lt_build_shared=$enable_shared + ;; + *) + as_fn_error $? "unexpected libtool enable_shared value: $enable_shared" "$LINENO" 5 + ;; +esac + +# +# Verify if finally libtool static libraries are built +# +case "x$enable_static" in # (( + xyes | xno) + xc_lt_build_static=$enable_static + ;; + *) + as_fn_error $? "unexpected libtool enable_static value: $enable_static" "$LINENO" 5 + ;; +esac + + + + +# +# Verify if libtool shared libraries should be linked using flag -version-info +# + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to build shared libraries with -version-info" >&5 +printf %s "checking whether to build shared libraries with -version-info... " >&6; } +xc_lt_shlib_use_version_info='yes' +if test "$version_type" = "none"; then + xc_lt_shlib_use_version_info='no' +fi +case $host_os in # ( + amigaos*) + xc_lt_shlib_use_version_info='yes' + ;; +esac +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $xc_lt_shlib_use_version_info" >&5 +printf "%s\n" "$xc_lt_shlib_use_version_info" >&6; } + + + + +# +# Verify if libtool shared libraries should be linked using flag -no-undefined +# + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to build shared libraries with -no-undefined" >&5 +printf %s "checking whether to build shared libraries with -no-undefined... " >&6; } +xc_lt_shlib_use_no_undefined='no' +if test "x$allow_undefined" = "xno"; then + xc_lt_shlib_use_no_undefined='yes' +elif test "x$allow_undefined_flag" = "xunsupported"; then + xc_lt_shlib_use_no_undefined='yes' +fi +case $host_os in # ( + cygwin* | mingw* | os2* | aix*) + xc_lt_shlib_use_no_undefined='yes' + ;; +esac +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $xc_lt_shlib_use_no_undefined" >&5 +printf "%s\n" "$xc_lt_shlib_use_no_undefined" >&6; } + + + + +# +# Verify if libtool shared libraries should be linked using flag -mimpure-text +# + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to build shared libraries with -mimpure-text" >&5 +printf %s "checking whether to build shared libraries with -mimpure-text... " >&6; } +xc_lt_shlib_use_mimpure_text='no' +case $host_os in # ( + solaris2*) + if test "x$GCC" = "xyes"; then + xc_lt_shlib_use_mimpure_text='yes' + fi + ;; +esac +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $xc_lt_shlib_use_mimpure_text" >&5 +printf "%s\n" "$xc_lt_shlib_use_mimpure_text" >&6; } + + + + +# +# Find out whether libtool libraries would be built with PIC +# + +case "x$pic_mode" in # (((( + xdefault) + xc_lt_build_shared_with_pic='yes' + xc_lt_build_static_with_pic='no' + ;; + xyes) + xc_lt_build_shared_with_pic='yes' + xc_lt_build_static_with_pic='yes' + ;; + xno) + xc_lt_build_shared_with_pic='no' + xc_lt_build_static_with_pic='no' + ;; + *) + xc_lt_build_shared_with_pic='unknown' + xc_lt_build_static_with_pic='unknown' + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: unexpected libtool pic_mode value: $pic_mode" >&5 +printf "%s\n" "$as_me: WARNING: unexpected libtool pic_mode value: $pic_mode" >&2;} + ;; +esac +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to build shared libraries with PIC" >&5 +printf %s "checking whether to build shared libraries with PIC... " >&6; } +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $xc_lt_build_shared_with_pic" >&5 +printf "%s\n" "$xc_lt_build_shared_with_pic" >&6; } +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to build static libraries with PIC" >&5 +printf %s "checking whether to build static libraries with PIC... " >&6; } +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $xc_lt_build_static_with_pic" >&5 +printf "%s\n" "$xc_lt_build_static_with_pic" >&6; } + + + + + +# +# Verify if libtool shared libraries are built while static not built +# +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to build shared libraries only" >&5 +printf %s "checking whether to build shared libraries only... " >&6; } +if test "$xc_lt_build_shared" = "yes" && + test "$xc_lt_build_static" = "no"; then + xc_lt_build_shared_only='yes' +else + xc_lt_build_shared_only='no' +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $xc_lt_build_shared_only" >&5 +printf "%s\n" "$xc_lt_build_shared_only" >&6; } + +# +# Verify if libtool static libraries are built while shared not built +# +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to build static libraries only" >&5 +printf %s "checking whether to build static libraries only... " >&6; } +if test "$xc_lt_build_static" = "yes" && + test "$xc_lt_build_shared" = "no"; then + xc_lt_build_static_only='yes' +else + xc_lt_build_static_only='no' +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $xc_lt_build_static_only" >&5 +printf "%s\n" "$xc_lt_build_static_only" >&6; } + + + + + + + + + + + + + + +if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}windres", so it can be a program name with args. +set dummy ${ac_tool_prefix}windres; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_RC+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$RC"; then + ac_cv_prog_RC="$RC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_RC="${ac_tool_prefix}windres" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +RC=$ac_cv_prog_RC +if test -n "$RC"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $RC" >&5 +printf "%s\n" "$RC" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_RC"; then + ac_ct_RC=$RC + # Extract the first word of "windres", so it can be a program name with args. +set dummy windres; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_ac_ct_RC+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$ac_ct_RC"; then + ac_cv_prog_ac_ct_RC="$ac_ct_RC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_RC="windres" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_RC=$ac_cv_prog_ac_ct_RC +if test -n "$ac_ct_RC"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_RC" >&5 +printf "%s\n" "$ac_ct_RC" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_ct_RC" = x; then + RC="" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + RC=$ac_ct_RC + fi +else + RC="$ac_cv_prog_RC" +fi + + + + +# Source file extension for RC test sources. +ac_ext=rc + +# Object file extension for compiled RC test sources. +objext=o +objext_RC=$objext + +# Code to be used in simple compile tests +lt_simple_compile_test_code='sample MENU { MENUITEM "&Soup", 100, CHECKED }' + +# Code to be used in simple link tests +lt_simple_link_test_code=$lt_simple_compile_test_code + +# ltmain only uses $CC for tagged configurations so make sure $CC is set. + + + + + + +# If no C compiler was specified, use CC. +LTCC=${LTCC-"$CC"} + +# If no C compiler flags were specified, use CFLAGS. +LTCFLAGS=${LTCFLAGS-"$CFLAGS"} + +# Allow CC to be a program name with arguments. +compiler=$CC + + +# save warnings/boilerplate of simple test code +ac_outfile=conftest.$ac_objext +echo "$lt_simple_compile_test_code" >conftest.$ac_ext +eval "$ac_compile" 2>&1 >/dev/null | $SED '/^$/d; /^ *+/d' >conftest.err +_lt_compiler_boilerplate=`cat conftest.err` +$RM conftest* + +ac_outfile=conftest.$ac_objext +echo "$lt_simple_link_test_code" >conftest.$ac_ext +eval "$ac_link" 2>&1 >/dev/null | $SED '/^$/d; /^ *+/d' >conftest.err +_lt_linker_boilerplate=`cat conftest.err` +$RM -r conftest* + + +# Allow CC to be a program name with arguments. +lt_save_CC=$CC +lt_save_CFLAGS=$CFLAGS +lt_save_GCC=$GCC +GCC= +CC=${RC-"windres"} +CFLAGS= +compiler=$CC +compiler_RC=$CC +func_cc_basename $compiler +cc_basename=$func_cc_basename_result + +lt_cv_prog_compiler_c_o_RC=yes + +if test -n "$compiler"; then + : + + + +fi + +GCC=$lt_save_GCC +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + +CC=$lt_save_CC +CFLAGS=$lt_save_CFLAGS + + + if test -z "$CURL_CI"; then + NOT_CURL_CI_TRUE= + NOT_CURL_CI_FALSE='#' +else + NOT_CURL_CI_TRUE='#' + NOT_CURL_CI_FALSE= +fi + + + + if test "$xc_lt_shlib_use_version_info" = "yes"; then + CURL_LT_SHLIB_USE_VERSION_INFO_TRUE= + CURL_LT_SHLIB_USE_VERSION_INFO_FALSE='#' +else + CURL_LT_SHLIB_USE_VERSION_INFO_TRUE='#' + CURL_LT_SHLIB_USE_VERSION_INFO_FALSE= +fi + + if test "$xc_lt_shlib_use_no_undefined" = "yes"; then + CURL_LT_SHLIB_USE_NO_UNDEFINED_TRUE= + CURL_LT_SHLIB_USE_NO_UNDEFINED_FALSE='#' +else + CURL_LT_SHLIB_USE_NO_UNDEFINED_TRUE='#' + CURL_LT_SHLIB_USE_NO_UNDEFINED_FALSE= +fi + + if test "$xc_lt_shlib_use_mimpure_text" = "yes"; then + CURL_LT_SHLIB_USE_MIMPURE_TEXT_TRUE= + CURL_LT_SHLIB_USE_MIMPURE_TEXT_FALSE='#' +else + CURL_LT_SHLIB_USE_MIMPURE_TEXT_TRUE='#' + CURL_LT_SHLIB_USE_MIMPURE_TEXT_FALSE= +fi + + + + + if test "$xc_lt_build_static_only" = "yes"; then + USE_CPPFLAG_CURL_STATICLIB_TRUE= + USE_CPPFLAG_CURL_STATICLIB_FALSE='#' +else + USE_CPPFLAG_CURL_STATICLIB_TRUE='#' + USE_CPPFLAG_CURL_STATICLIB_FALSE= +fi + + + +LIBCURL_PC_CFLAGS_PRIVATE='-DCURL_STATICLIB' + + +LIBCURL_PC_CFLAGS= +if test "$xc_lt_build_static_only" = "yes"; then + LIBCURL_PC_CFLAGS="${LIBCURL_PC_CFLAGS_PRIVATE}" +fi + + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if cpp -P is needed" >&5 +printf %s "checking if cpp -P is needed... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #include +TEST EINVAL TEST + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "TEST.*TEST" >/dev/null 2>&1 +then : + cpp=no +else $as_nop + cpp=yes +fi +rm -rf conftest* + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $cpp" >&5 +printf "%s\n" "$cpp" >&6; } + + if test "$cpp" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if cpp -P works" >&5 +printf %s "checking if cpp -P works... " >&6; } + OLDCPPFLAGS=$CPPFLAGS + CPPFLAGS="$CPPFLAGS -P" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #include +TEST EINVAL TEST + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "TEST.*TEST" >/dev/null 2>&1 +then : + cpp_p=yes +else $as_nop + cpp_p=no +fi +rm -rf conftest* + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $cpp_p" >&5 +printf "%s\n" "$cpp_p" >&6; } + + if test "$cpp_p" = "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: failed to figure out cpp -P alternative" >&5 +printf "%s\n" "$as_me: WARNING: failed to figure out cpp -P alternative" >&2;} + CPPPFLAG="" + else + CPPPFLAG="-P" + fi + CPPFLAGS=$OLDCPPFLAGS + else + CPPPFLAG="" + fi + + + + compiler_id="unknown" + compiler_ver="" + compiler_num="0" + + flags_dbg_yes="unknown" + flags_opt_all="unknown" + flags_opt_yes="unknown" + flags_opt_off="unknown" + + flags_prefer_cppflags="no" + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler is DEC/Compaq/HP C" >&5 +printf %s "checking if compiler is DEC/Compaq/HP C... " >&6; } + + + OLDCPPFLAGS=$CPPFLAGS + CPPFLAGS="$CPPFLAGS $CPPPFLAG" + + + if test -z "$SED"; then + as_fn_error $? "SED not set. Cannot continue without SED being set." "$LINENO" 5 + fi + if test -z "$GREP"; then + as_fn_error $? "GREP not set. Cannot continue without GREP being set." "$LINENO" 5 + fi + + tmp_exp="" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #ifdef __DECC + CURL_DEF_TOKEN __DECC + #endif + + +_ACEOF +if ac_fn_c_try_cpp "$LINENO" +then : + + tmp_exp=`eval "$ac_cpp conftest.$ac_ext" 2>/dev/null | \ + "$GREP" CURL_DEF_TOKEN 2>/dev/null | \ + "$SED" 's/.*CURL_DEF_TOKEN[ ][ ]*//' 2>/dev/null | \ + "$SED" 's/["][ ]*["]//g' 2>/dev/null` + if test -z "$tmp_exp" || test "$tmp_exp" = "__DECC"; then + tmp_exp="" + fi + +fi +rm -f conftest.err conftest.i conftest.$ac_ext + if test -z "$tmp_exp"; then + curl_cv_have_def___DECC=no + + else + curl_cv_have_def___DECC=yes + curl_cv_def___DECC=$tmp_exp + + fi + + + CPPFLAGS=$OLDCPPFLAGS + + + + OLDCPPFLAGS=$CPPFLAGS + CPPFLAGS="$CPPFLAGS $CPPPFLAG" + + + if test -z "$SED"; then + as_fn_error $? "SED not set. Cannot continue without SED being set." "$LINENO" 5 + fi + if test -z "$GREP"; then + as_fn_error $? "GREP not set. Cannot continue without GREP being set." "$LINENO" 5 + fi + + tmp_exp="" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #ifdef __DECC_VER + CURL_DEF_TOKEN __DECC_VER + #endif + + +_ACEOF +if ac_fn_c_try_cpp "$LINENO" +then : + + tmp_exp=`eval "$ac_cpp conftest.$ac_ext" 2>/dev/null | \ + "$GREP" CURL_DEF_TOKEN 2>/dev/null | \ + "$SED" 's/.*CURL_DEF_TOKEN[ ][ ]*//' 2>/dev/null | \ + "$SED" 's/["][ ]*["]//g' 2>/dev/null` + if test -z "$tmp_exp" || test "$tmp_exp" = "__DECC_VER"; then + tmp_exp="" + fi + +fi +rm -f conftest.err conftest.i conftest.$ac_ext + if test -z "$tmp_exp"; then + curl_cv_have_def___DECC_VER=no + + else + curl_cv_have_def___DECC_VER=yes + curl_cv_def___DECC_VER=$tmp_exp + + fi + + + CPPFLAGS=$OLDCPPFLAGS + + if test "$curl_cv_have_def___DECC" = "yes" && + test "$curl_cv_have_def___DECC_VER" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + compiler_id="DEC_C" + flags_dbg_yes="-g2" + flags_opt_all="-O -O0 -O1 -O2 -O3 -O4" + flags_opt_yes="-O1" + flags_opt_off="-O0" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + fi + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler is HP-UX C" >&5 +printf %s "checking if compiler is HP-UX C... " >&6; } + + + OLDCPPFLAGS=$CPPFLAGS + CPPFLAGS="$CPPFLAGS $CPPPFLAG" + + + if test -z "$SED"; then + as_fn_error $? "SED not set. Cannot continue without SED being set." "$LINENO" 5 + fi + if test -z "$GREP"; then + as_fn_error $? "GREP not set. Cannot continue without GREP being set." "$LINENO" 5 + fi + + tmp_exp="" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #ifdef __HP_cc + CURL_DEF_TOKEN __HP_cc + #endif + + +_ACEOF +if ac_fn_c_try_cpp "$LINENO" +then : + + tmp_exp=`eval "$ac_cpp conftest.$ac_ext" 2>/dev/null | \ + "$GREP" CURL_DEF_TOKEN 2>/dev/null | \ + "$SED" 's/.*CURL_DEF_TOKEN[ ][ ]*//' 2>/dev/null | \ + "$SED" 's/["][ ]*["]//g' 2>/dev/null` + if test -z "$tmp_exp" || test "$tmp_exp" = "__HP_cc"; then + tmp_exp="" + fi + +fi +rm -f conftest.err conftest.i conftest.$ac_ext + if test -z "$tmp_exp"; then + curl_cv_have_def___HP_cc=no + + else + curl_cv_have_def___HP_cc=yes + curl_cv_def___HP_cc=$tmp_exp + + fi + + + CPPFLAGS=$OLDCPPFLAGS + + if test "$curl_cv_have_def___HP_cc" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + compiler_id="HP_UX_C" + flags_dbg_yes="-g" + flags_opt_all="-O +O0 +O1 +O2 +O3 +O4" + flags_opt_yes="+O2" + flags_opt_off="+O0" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + fi + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler is IBM C" >&5 +printf %s "checking if compiler is IBM C... " >&6; } + + + OLDCPPFLAGS=$CPPFLAGS + CPPFLAGS="$CPPFLAGS $CPPPFLAG" + + + if test -z "$SED"; then + as_fn_error $? "SED not set. Cannot continue without SED being set." "$LINENO" 5 + fi + if test -z "$GREP"; then + as_fn_error $? "GREP not set. Cannot continue without GREP being set." "$LINENO" 5 + fi + + tmp_exp="" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #ifdef __IBMC__ + CURL_DEF_TOKEN __IBMC__ + #endif + + +_ACEOF +if ac_fn_c_try_cpp "$LINENO" +then : + + tmp_exp=`eval "$ac_cpp conftest.$ac_ext" 2>/dev/null | \ + "$GREP" CURL_DEF_TOKEN 2>/dev/null | \ + "$SED" 's/.*CURL_DEF_TOKEN[ ][ ]*//' 2>/dev/null | \ + "$SED" 's/["][ ]*["]//g' 2>/dev/null` + if test -z "$tmp_exp" || test "$tmp_exp" = "__IBMC__"; then + tmp_exp="" + fi + +fi +rm -f conftest.err conftest.i conftest.$ac_ext + if test -z "$tmp_exp"; then + curl_cv_have_def___IBMC__=no + + else + curl_cv_have_def___IBMC__=yes + curl_cv_def___IBMC__=$tmp_exp + + fi + + + CPPFLAGS=$OLDCPPFLAGS + + if test "$curl_cv_have_def___IBMC__" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + compiler_id="IBM_C" + flags_dbg_yes="-g" + flags_opt_all="-O -O0 -O1 -O2 -O3 -O4 -O5" + flags_opt_all="$flags_opt_all -qnooptimize" + flags_opt_all="$flags_opt_all -qoptimize=0" + flags_opt_all="$flags_opt_all -qoptimize=1" + flags_opt_all="$flags_opt_all -qoptimize=2" + flags_opt_all="$flags_opt_all -qoptimize=3" + flags_opt_all="$flags_opt_all -qoptimize=4" + flags_opt_all="$flags_opt_all -qoptimize=5" + flags_opt_yes="-O2" + flags_opt_off="-qnooptimize" + flags_prefer_cppflags="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + fi + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler is Intel C" >&5 +printf %s "checking if compiler is Intel C... " >&6; } + + + OLDCPPFLAGS=$CPPFLAGS + CPPFLAGS="$CPPFLAGS $CPPPFLAG" + + + if test -z "$SED"; then + as_fn_error $? "SED not set. Cannot continue without SED being set." "$LINENO" 5 + fi + if test -z "$GREP"; then + as_fn_error $? "GREP not set. Cannot continue without GREP being set." "$LINENO" 5 + fi + + tmp_exp="" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #ifdef __INTEL_COMPILER + CURL_DEF_TOKEN __INTEL_COMPILER + #endif + + +_ACEOF +if ac_fn_c_try_cpp "$LINENO" +then : + + tmp_exp=`eval "$ac_cpp conftest.$ac_ext" 2>/dev/null | \ + "$GREP" CURL_DEF_TOKEN 2>/dev/null | \ + "$SED" 's/.*CURL_DEF_TOKEN[ ][ ]*//' 2>/dev/null | \ + "$SED" 's/["][ ]*["]//g' 2>/dev/null` + if test -z "$tmp_exp" || test "$tmp_exp" = "__INTEL_COMPILER"; then + tmp_exp="" + fi + +fi +rm -f conftest.err conftest.i conftest.$ac_ext + if test -z "$tmp_exp"; then + curl_cv_have_def___INTEL_COMPILER=no + + else + curl_cv_have_def___INTEL_COMPILER=yes + curl_cv_def___INTEL_COMPILER=$tmp_exp + + fi + + + CPPFLAGS=$OLDCPPFLAGS + + if test "$curl_cv_have_def___INTEL_COMPILER" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking compiler version" >&5 +printf %s "checking compiler version... " >&6; } + compiler_num="$curl_cv_def___INTEL_COMPILER" + compiler_ver=`echo "$compiler_num" | cut -c -2 | $SED 's/^0//'`.`echo "$compiler_num" | cut -c 3-4 | $SED 's/^0//'` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Intel C '$compiler_num'" >&5 +printf "%s\n" "Intel C '$compiler_num'" >&6; } + + + OLDCPPFLAGS=$CPPFLAGS + CPPFLAGS="$CPPFLAGS $CPPPFLAG" + + + if test -z "$SED"; then + as_fn_error $? "SED not set. Cannot continue without SED being set." "$LINENO" 5 + fi + if test -z "$GREP"; then + as_fn_error $? "GREP not set. Cannot continue without GREP being set." "$LINENO" 5 + fi + + tmp_exp="" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #ifdef __unix__ + CURL_DEF_TOKEN __unix__ + #endif + + +_ACEOF +if ac_fn_c_try_cpp "$LINENO" +then : + + tmp_exp=`eval "$ac_cpp conftest.$ac_ext" 2>/dev/null | \ + "$GREP" CURL_DEF_TOKEN 2>/dev/null | \ + "$SED" 's/.*CURL_DEF_TOKEN[ ][ ]*//' 2>/dev/null | \ + "$SED" 's/["][ ]*["]//g' 2>/dev/null` + if test -z "$tmp_exp" || test "$tmp_exp" = ""; then + tmp_exp="" + fi + +fi +rm -f conftest.err conftest.i conftest.$ac_ext + if test -z "$tmp_exp"; then + curl_cv_have_def___unix__=no + + else + curl_cv_have_def___unix__=yes + curl_cv_def___unix__=$tmp_exp + + fi + + + CPPFLAGS=$OLDCPPFLAGS + + if test "$curl_cv_have_def___unix__" = "yes"; then + compiler_id="INTEL_UNIX_C" + flags_dbg_yes="-g" + flags_opt_all="-O -O0 -O1 -O2 -O3 -Os" + flags_opt_yes="-O2" + flags_opt_off="-O0" + else + compiler_id="INTEL_WINDOWS_C" + flags_dbg_yes="/Zi /Oy-" + flags_opt_all="/O /O0 /O1 /O2 /O3 /Od /Og /Og- /Oi /Oi-" + flags_opt_yes="/O2" + flags_opt_off="/Od" + fi + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + fi + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler is clang" >&5 +printf %s "checking if compiler is clang... " >&6; } + + + OLDCPPFLAGS=$CPPFLAGS + CPPFLAGS="$CPPFLAGS $CPPPFLAG" + + + if test -z "$SED"; then + as_fn_error $? "SED not set. Cannot continue without SED being set." "$LINENO" 5 + fi + if test -z "$GREP"; then + as_fn_error $? "GREP not set. Cannot continue without GREP being set." "$LINENO" 5 + fi + + tmp_exp="" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #ifdef __clang__ + CURL_DEF_TOKEN __clang__ + #endif + + +_ACEOF +if ac_fn_c_try_cpp "$LINENO" +then : + + tmp_exp=`eval "$ac_cpp conftest.$ac_ext" 2>/dev/null | \ + "$GREP" CURL_DEF_TOKEN 2>/dev/null | \ + "$SED" 's/.*CURL_DEF_TOKEN[ ][ ]*//' 2>/dev/null | \ + "$SED" 's/["][ ]*["]//g' 2>/dev/null` + if test -z "$tmp_exp" || test "$tmp_exp" = "__clang__"; then + tmp_exp="" + fi + +fi +rm -f conftest.err conftest.i conftest.$ac_ext + if test -z "$tmp_exp"; then + curl_cv_have_def___clang__=no + + else + curl_cv_have_def___clang__=yes + curl_cv_def___clang__=$tmp_exp + + fi + + + CPPFLAGS=$OLDCPPFLAGS + + if test "$curl_cv_have_def___clang__" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler is xlclang" >&5 +printf %s "checking if compiler is xlclang... " >&6; } + + + OLDCPPFLAGS=$CPPFLAGS + CPPFLAGS="$CPPFLAGS $CPPPFLAG" + + + if test -z "$SED"; then + as_fn_error $? "SED not set. Cannot continue without SED being set." "$LINENO" 5 + fi + if test -z "$GREP"; then + as_fn_error $? "GREP not set. Cannot continue without GREP being set." "$LINENO" 5 + fi + + tmp_exp="" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #ifdef __ibmxl__ + CURL_DEF_TOKEN __ibmxl__ + #endif + + +_ACEOF +if ac_fn_c_try_cpp "$LINENO" +then : + + tmp_exp=`eval "$ac_cpp conftest.$ac_ext" 2>/dev/null | \ + "$GREP" CURL_DEF_TOKEN 2>/dev/null | \ + "$SED" 's/.*CURL_DEF_TOKEN[ ][ ]*//' 2>/dev/null | \ + "$SED" 's/["][ ]*["]//g' 2>/dev/null` + if test -z "$tmp_exp" || test "$tmp_exp" = "__ibmxl__"; then + tmp_exp="" + fi + +fi +rm -f conftest.err conftest.i conftest.$ac_ext + if test -z "$tmp_exp"; then + curl_cv_have_def___ibmxl__=no + + else + curl_cv_have_def___ibmxl__=yes + curl_cv_def___ibmxl__=$tmp_exp + + fi + + + CPPFLAGS=$OLDCPPFLAGS + + if test "$curl_cv_have_def___ibmxl__" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + compiler_id="XLCLANG" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + compiler_id="CLANG" + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler is Apple clang" >&5 +printf %s "checking if compiler is Apple clang... " >&6; } + fullclangver=`$CC -v 2>&1 | grep version` + if echo $fullclangver | grep 'Apple' >/dev/null; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + appleclang=1 + compiler_id="APPLECLANG" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + appleclang=0 + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking compiler version" >&5 +printf %s "checking compiler version... " >&6; } + clangver=`echo $fullclangver | grep "based on LLVM " | "$SED" 's/.*(based on LLVM \([0-9]*\.[0-9]*\).*)/\1/'` + if test -z "$clangver"; then + clangver=`echo $fullclangver | "$SED" 's/.*version \([0-9]*\.[0-9]*\).*/\1/'` + oldapple=0 + else + oldapple=1 + fi + clangvhi=`echo $clangver | cut -d . -f1` + clangvlo=`echo $clangver | cut -d . -f2` + compiler_ver="$clangver" + compiler_num=`(expr $clangvhi "*" 100 + $clangvlo) 2>/dev/null` + if test "$appleclang" = "1" && test "$oldapple" = "0"; then + if test "$compiler_num" -ge '2604'; then compiler_num='2101' + elif test "$compiler_num" -ge '1700'; then compiler_num='1901' + elif test "$compiler_num" -ge '1600'; then compiler_num='1700' + elif test "$compiler_num" -ge '1500'; then compiler_num='1600' + elif test "$compiler_num" -ge '1400'; then compiler_num='1400' + elif test "$compiler_num" -ge '1301'; then compiler_num='1300' + elif test "$compiler_num" -ge '1300'; then compiler_num='1200' + elif test "$compiler_num" -ge '1200'; then compiler_num='1000' + elif test "$compiler_num" -ge '1100'; then compiler_num='800' + elif test "$compiler_num" -ge '1000'; then compiler_num='600' + elif test "$compiler_num" -ge '901'; then compiler_num='500' + elif test "$compiler_num" -ge '900'; then compiler_num='400' + elif test "$compiler_num" -ge '801'; then compiler_num='309' + elif test "$compiler_num" -ge '703'; then compiler_num='308' + else compiler_num='307' + fi + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: clang '$compiler_num' (raw: '$fullclangver' / '$clangver')" >&5 +printf "%s\n" "clang '$compiler_num' (raw: '$fullclangver' / '$clangver')" >&6; } + flags_dbg_yes="-g" + flags_opt_all="-O -O0 -O1 -O2 -Os -O3 -O4" + flags_opt_yes="-O2" + flags_opt_off="-O0" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + fi + + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler is GNU C" >&5 +printf %s "checking if compiler is GNU C... " >&6; } + + + OLDCPPFLAGS=$CPPFLAGS + CPPFLAGS="$CPPFLAGS $CPPPFLAG" + + + if test -z "$SED"; then + as_fn_error $? "SED not set. Cannot continue without SED being set." "$LINENO" 5 + fi + if test -z "$GREP"; then + as_fn_error $? "GREP not set. Cannot continue without GREP being set." "$LINENO" 5 + fi + + tmp_exp="" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #ifdef __GNUC__ + CURL_DEF_TOKEN __GNUC__ + #endif + + +_ACEOF +if ac_fn_c_try_cpp "$LINENO" +then : + + tmp_exp=`eval "$ac_cpp conftest.$ac_ext" 2>/dev/null | \ + "$GREP" CURL_DEF_TOKEN 2>/dev/null | \ + "$SED" 's/.*CURL_DEF_TOKEN[ ][ ]*//' 2>/dev/null | \ + "$SED" 's/["][ ]*["]//g' 2>/dev/null` + if test -z "$tmp_exp" || test "$tmp_exp" = "__GNUC__"; then + tmp_exp="" + fi + +fi +rm -f conftest.err conftest.i conftest.$ac_ext + if test -z "$tmp_exp"; then + curl_cv_have_def___GNUC__=no + + else + curl_cv_have_def___GNUC__=yes + curl_cv_def___GNUC__=$tmp_exp + + fi + + + CPPFLAGS=$OLDCPPFLAGS + + if test "$curl_cv_have_def___GNUC__" = "yes" && + test "$compiler_id" = "unknown"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + compiler_id="GNU_C" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking compiler version" >&5 +printf %s "checking compiler version... " >&6; } + gccver=`$CC -dumpversion | "$SED" 's/-.\{1,\}$//'` + gccvhi=`echo $gccver | cut -d . -f1` + if echo $gccver | grep -F '.' >/dev/null; then + gccvlo=`echo $gccver | cut -d . -f2` + else + gccvlo="0" + fi + compiler_ver="$gccver" + compiler_num=`(expr $gccvhi "*" 100 + $gccvlo) 2>/dev/null` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: gcc '$compiler_num' (raw: '$gccver')" >&5 +printf "%s\n" "gcc '$compiler_num' (raw: '$gccver')" >&6; } + flags_dbg_yes="-g" + flags_opt_all="-O -O0 -O1 -O2 -O3 -Os -Og -Ofast" + flags_opt_yes="-O2" + flags_opt_off="-O0" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + fi + + case $host in + mips-sgi-irix*) + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler is SGI MIPSpro C" >&5 +printf %s "checking if compiler is SGI MIPSpro C... " >&6; } + + + OLDCPPFLAGS=$CPPFLAGS + CPPFLAGS="$CPPFLAGS $CPPPFLAG" + + + if test -z "$SED"; then + as_fn_error $? "SED not set. Cannot continue without SED being set." "$LINENO" 5 + fi + if test -z "$GREP"; then + as_fn_error $? "GREP not set. Cannot continue without GREP being set." "$LINENO" 5 + fi + + tmp_exp="" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #ifdef __GNUC__ + CURL_DEF_TOKEN __GNUC__ + #endif + + +_ACEOF +if ac_fn_c_try_cpp "$LINENO" +then : + + tmp_exp=`eval "$ac_cpp conftest.$ac_ext" 2>/dev/null | \ + "$GREP" CURL_DEF_TOKEN 2>/dev/null | \ + "$SED" 's/.*CURL_DEF_TOKEN[ ][ ]*//' 2>/dev/null | \ + "$SED" 's/["][ ]*["]//g' 2>/dev/null` + if test -z "$tmp_exp" || test "$tmp_exp" = "__GNUC__"; then + tmp_exp="" + fi + +fi +rm -f conftest.err conftest.i conftest.$ac_ext + if test -z "$tmp_exp"; then + curl_cv_have_def___GNUC__=no + + else + curl_cv_have_def___GNUC__=yes + curl_cv_def___GNUC__=$tmp_exp + + fi + + + CPPFLAGS=$OLDCPPFLAGS + + + + OLDCPPFLAGS=$CPPFLAGS + CPPFLAGS="$CPPFLAGS $CPPPFLAG" + + + if test -z "$SED"; then + as_fn_error $? "SED not set. Cannot continue without SED being set." "$LINENO" 5 + fi + if test -z "$GREP"; then + as_fn_error $? "GREP not set. Cannot continue without GREP being set." "$LINENO" 5 + fi + + tmp_exp="" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #ifdef _COMPILER_VERSION + CURL_DEF_TOKEN _COMPILER_VERSION + #endif + + +_ACEOF +if ac_fn_c_try_cpp "$LINENO" +then : + + tmp_exp=`eval "$ac_cpp conftest.$ac_ext" 2>/dev/null | \ + "$GREP" CURL_DEF_TOKEN 2>/dev/null | \ + "$SED" 's/.*CURL_DEF_TOKEN[ ][ ]*//' 2>/dev/null | \ + "$SED" 's/["][ ]*["]//g' 2>/dev/null` + if test -z "$tmp_exp" || test "$tmp_exp" = "_COMPILER_VERSION"; then + tmp_exp="" + fi + +fi +rm -f conftest.err conftest.i conftest.$ac_ext + if test -z "$tmp_exp"; then + curl_cv_have_def__COMPILER_VERSION=no + + else + curl_cv_have_def__COMPILER_VERSION=yes + curl_cv_def__COMPILER_VERSION=$tmp_exp + + fi + + + CPPFLAGS=$OLDCPPFLAGS + + + + OLDCPPFLAGS=$CPPFLAGS + CPPFLAGS="$CPPFLAGS $CPPPFLAG" + + + if test -z "$SED"; then + as_fn_error $? "SED not set. Cannot continue without SED being set." "$LINENO" 5 + fi + if test -z "$GREP"; then + as_fn_error $? "GREP not set. Cannot continue without GREP being set." "$LINENO" 5 + fi + + tmp_exp="" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #ifdef _SGI_COMPILER_VERSION + CURL_DEF_TOKEN _SGI_COMPILER_VERSION + #endif + + +_ACEOF +if ac_fn_c_try_cpp "$LINENO" +then : + + tmp_exp=`eval "$ac_cpp conftest.$ac_ext" 2>/dev/null | \ + "$GREP" CURL_DEF_TOKEN 2>/dev/null | \ + "$SED" 's/.*CURL_DEF_TOKEN[ ][ ]*//' 2>/dev/null | \ + "$SED" 's/["][ ]*["]//g' 2>/dev/null` + if test -z "$tmp_exp" || test "$tmp_exp" = "_SGI_COMPILER_VERSION"; then + tmp_exp="" + fi + +fi +rm -f conftest.err conftest.i conftest.$ac_ext + if test -z "$tmp_exp"; then + curl_cv_have_def__SGI_COMPILER_VERSION=no + + else + curl_cv_have_def__SGI_COMPILER_VERSION=yes + curl_cv_def__SGI_COMPILER_VERSION=$tmp_exp + + fi + + + CPPFLAGS=$OLDCPPFLAGS + + if test "$curl_cv_have_def___GNUC__" = "no" && + (test "$curl_cv_have_def__SGI_COMPILER_VERSION" = "yes" || + test "$curl_cv_have_def__COMPILER_VERSION" = "yes"); then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + compiler_id="SGI_MIPSPRO_C" + flags_dbg_yes="-g" + flags_opt_all="-O -O0 -O1 -O2 -O3 -Ofast" + flags_opt_yes="-O2" + flags_opt_off="-O0" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + fi + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler is SGI MIPS C" >&5 +printf %s "checking if compiler is SGI MIPS C... " >&6; } + + + OLDCPPFLAGS=$CPPFLAGS + CPPFLAGS="$CPPFLAGS $CPPPFLAG" + + + if test -z "$SED"; then + as_fn_error $? "SED not set. Cannot continue without SED being set." "$LINENO" 5 + fi + if test -z "$GREP"; then + as_fn_error $? "GREP not set. Cannot continue without GREP being set." "$LINENO" 5 + fi + + tmp_exp="" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #ifdef __GNUC__ + CURL_DEF_TOKEN __GNUC__ + #endif + + +_ACEOF +if ac_fn_c_try_cpp "$LINENO" +then : + + tmp_exp=`eval "$ac_cpp conftest.$ac_ext" 2>/dev/null | \ + "$GREP" CURL_DEF_TOKEN 2>/dev/null | \ + "$SED" 's/.*CURL_DEF_TOKEN[ ][ ]*//' 2>/dev/null | \ + "$SED" 's/["][ ]*["]//g' 2>/dev/null` + if test -z "$tmp_exp" || test "$tmp_exp" = "__GNUC__"; then + tmp_exp="" + fi + +fi +rm -f conftest.err conftest.i conftest.$ac_ext + if test -z "$tmp_exp"; then + curl_cv_have_def___GNUC__=no + + else + curl_cv_have_def___GNUC__=yes + curl_cv_def___GNUC__=$tmp_exp + + fi + + + CPPFLAGS=$OLDCPPFLAGS + + + + OLDCPPFLAGS=$CPPFLAGS + CPPFLAGS="$CPPFLAGS $CPPPFLAG" + + + if test -z "$SED"; then + as_fn_error $? "SED not set. Cannot continue without SED being set." "$LINENO" 5 + fi + if test -z "$GREP"; then + as_fn_error $? "GREP not set. Cannot continue without GREP being set." "$LINENO" 5 + fi + + tmp_exp="" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #ifdef __sgi + CURL_DEF_TOKEN __sgi + #endif + + +_ACEOF +if ac_fn_c_try_cpp "$LINENO" +then : + + tmp_exp=`eval "$ac_cpp conftest.$ac_ext" 2>/dev/null | \ + "$GREP" CURL_DEF_TOKEN 2>/dev/null | \ + "$SED" 's/.*CURL_DEF_TOKEN[ ][ ]*//' 2>/dev/null | \ + "$SED" 's/["][ ]*["]//g' 2>/dev/null` + if test -z "$tmp_exp" || test "$tmp_exp" = "__sgi"; then + tmp_exp="" + fi + +fi +rm -f conftest.err conftest.i conftest.$ac_ext + if test -z "$tmp_exp"; then + curl_cv_have_def___sgi=no + + else + curl_cv_have_def___sgi=yes + curl_cv_def___sgi=$tmp_exp + + fi + + + CPPFLAGS=$OLDCPPFLAGS + + if test "$curl_cv_have_def___GNUC__" = "no" && + test "$curl_cv_have_def___sgi" = "yes" && + test "$compiler_id" = "unknown"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + compiler_id="SGI_MIPS_C" + flags_dbg_yes="-g" + flags_opt_all="-O -O0 -O1 -O2 -O3 -Ofast" + flags_opt_yes="-O2" + flags_opt_off="-O0" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + fi + + ;; + esac + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler is SunPro C" >&5 +printf %s "checking if compiler is SunPro C... " >&6; } + + + OLDCPPFLAGS=$CPPFLAGS + CPPFLAGS="$CPPFLAGS $CPPPFLAG" + + + if test -z "$SED"; then + as_fn_error $? "SED not set. Cannot continue without SED being set." "$LINENO" 5 + fi + if test -z "$GREP"; then + as_fn_error $? "GREP not set. Cannot continue without GREP being set." "$LINENO" 5 + fi + + tmp_exp="" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #ifdef __SUNPRO_C + CURL_DEF_TOKEN __SUNPRO_C + #endif + + +_ACEOF +if ac_fn_c_try_cpp "$LINENO" +then : + + tmp_exp=`eval "$ac_cpp conftest.$ac_ext" 2>/dev/null | \ + "$GREP" CURL_DEF_TOKEN 2>/dev/null | \ + "$SED" 's/.*CURL_DEF_TOKEN[ ][ ]*//' 2>/dev/null | \ + "$SED" 's/["][ ]*["]//g' 2>/dev/null` + if test -z "$tmp_exp" || test "$tmp_exp" = "__SUNPRO_C"; then + tmp_exp="" + fi + +fi +rm -f conftest.err conftest.i conftest.$ac_ext + if test -z "$tmp_exp"; then + curl_cv_have_def___SUNPRO_C=no + + else + curl_cv_have_def___SUNPRO_C=yes + curl_cv_def___SUNPRO_C=$tmp_exp + + fi + + + CPPFLAGS=$OLDCPPFLAGS + + if test "$curl_cv_have_def___SUNPRO_C" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + compiler_id="SUNPRO_C" + flags_dbg_yes="-g" + flags_opt_all="-O -xO -xO1 -xO2 -xO3 -xO4 -xO5" + flags_opt_yes="-xO2" + flags_opt_off="" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + fi + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler is Tiny C" >&5 +printf %s "checking if compiler is Tiny C... " >&6; } + + + OLDCPPFLAGS=$CPPFLAGS + CPPFLAGS="$CPPFLAGS $CPPPFLAG" + + + if test -z "$SED"; then + as_fn_error $? "SED not set. Cannot continue without SED being set." "$LINENO" 5 + fi + if test -z "$GREP"; then + as_fn_error $? "GREP not set. Cannot continue without GREP being set." "$LINENO" 5 + fi + + tmp_exp="" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #ifdef __TINYC__ + CURL_DEF_TOKEN __TINYC__ + #endif + + +_ACEOF +if ac_fn_c_try_cpp "$LINENO" +then : + + tmp_exp=`eval "$ac_cpp conftest.$ac_ext" 2>/dev/null | \ + "$GREP" CURL_DEF_TOKEN 2>/dev/null | \ + "$SED" 's/.*CURL_DEF_TOKEN[ ][ ]*//' 2>/dev/null | \ + "$SED" 's/["][ ]*["]//g' 2>/dev/null` + if test -z "$tmp_exp" || test "$tmp_exp" = "__TINYC__"; then + tmp_exp="" + fi + +fi +rm -f conftest.err conftest.i conftest.$ac_ext + if test -z "$tmp_exp"; then + curl_cv_have_def___TINYC__=no + + else + curl_cv_have_def___TINYC__=yes + curl_cv_def___TINYC__=$tmp_exp + + fi + + + CPPFLAGS=$OLDCPPFLAGS + + if test "$curl_cv_have_def___TINYC__" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + compiler_id="TINY_C" + flags_dbg_yes="-g" + flags_opt_all="" + flags_opt_yes="" + flags_opt_off="" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + fi + + + if test "$compiler_id" = "unknown"; then + cat <<_EOF 1>&2 +*** +*** Warning: This configure script does not have information about the +*** compiler you are using, relative to the flags required to enable or +*** disable generation of debug info, optimization options or warnings. +*** +*** Whatever settings are present in CFLAGS are used for this run. +*** +*** If you wish to help the curl project to better support your compiler +*** you can report this and the required info on the libcurl development +*** mailing list: https://lists.haxx.se/listinfo/curl-library/ +*** +_EOF + fi + + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for code coverage support" >&5 +printf %s "checking for code coverage support... " >&6; } + coverage="no" + curl_coverage_msg="disabled" + + # Check whether --enable-code-coverage was given. +if test ${enable_code_coverage+y} +then : + enableval=$enable_code_coverage; coverage="$enableval" +fi + + + if test "$compiler_id" != "GNU_C" && test "$compiler_id" != "CLANG" && test "$compiler_id" != "APPLECLANG" +then : + coverage="no" +fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $coverage" >&5 +printf "%s\n" "$coverage" >&6; } + + if test "x$coverage" = "xyes"; then + curl_coverage_msg="enabled" + + CPPFLAGS="$CPPFLAGS -DNDEBUG" + CFLAGS="$CFLAGS -O0 -g" + + if test "$compiler_id" = "GNU_C"; then + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}gcov", so it can be a program name with args. +set dummy ${ac_tool_prefix}gcov; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_GCOV+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$GCOV"; then + ac_cv_prog_GCOV="$GCOV" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_GCOV="${ac_tool_prefix}gcov" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +GCOV=$ac_cv_prog_GCOV +if test -n "$GCOV"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $GCOV" >&5 +printf "%s\n" "$GCOV" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_GCOV"; then + ac_ct_GCOV=$GCOV + # Extract the first word of "gcov", so it can be a program name with args. +set dummy gcov; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_ac_ct_GCOV+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$ac_ct_GCOV"; then + ac_cv_prog_ac_ct_GCOV="$ac_ct_GCOV" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_GCOV="gcov" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_GCOV=$ac_cv_prog_ac_ct_GCOV +if test -n "$ac_ct_GCOV"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_GCOV" >&5 +printf "%s\n" "$ac_ct_GCOV" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_ct_GCOV" = x; then + GCOV="gcov" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + GCOV=$ac_ct_GCOV + fi +else + GCOV="$ac_cv_prog_GCOV" +fi + + if test -z "$GCOV"; then + as_fn_error $? "needs gcov for code coverage" "$LINENO" 5 + fi + # Extract the first word of "lcov", so it can be a program name with args. +set dummy lcov; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_prog_LCOV+y} +then : + printf %s "(cached) " >&6 +else $as_nop + if test -n "$LCOV"; then + ac_cv_prog_LCOV="$LCOV" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_prog_LCOV="lcov" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +LCOV=$ac_cv_prog_LCOV +if test -n "$LCOV"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $LCOV" >&5 +printf "%s\n" "$LCOV" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + + if test -z "$LCOV"; then + as_fn_error $? "needs lcov for code coverage" "$LINENO" 5 + fi + CFLAGS="$CFLAGS -ftest-coverage -fprofile-arcs" + LIBS="$LIBS -lgcov" + else + CFLAGS="$CFLAGS -fprofile-instr-generate -fcoverage-mapping" + LDFLAGS="$LDFLAGS -fprofile-instr-generate -fcoverage-mapping" + fi + fi + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether build target is a native Windows one" >&5 +printf %s "checking whether build target is a native Windows one... " >&6; } +if test ${curl_cv_native_windows+y} +then : + printf %s "(cached) " >&6 +else $as_nop + + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + +int main(void) +{ + + #ifdef _WIN32 + int dummy = 1; + (void)dummy; + #else + #error Not a native Windows build target. + #endif + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + curl_cv_native_windows="yes" + +else $as_nop + + curl_cv_native_windows="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $curl_cv_native_windows" >&5 +printf "%s\n" "$curl_cv_native_windows" >&6; } + if test "$curl_cv_native_windows" = "yes"; then + DOING_NATIVE_WINDOWS_TRUE= + DOING_NATIVE_WINDOWS_FALSE='#' +else + DOING_NATIVE_WINDOWS_TRUE='#' + DOING_NATIVE_WINDOWS_FALSE= +fi + + + +curl_cv_winuwp='no' +if test "$curl_cv_native_windows" = "yes"; then + case "$CPPFLAGS" in + *-DWINSTORECOMPAT*) curl_cv_winuwp='yes';; + esac + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if building for Windows Vista or newer" >&5 +printf %s "checking if building for Windows Vista or newer... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #include + +int main(void) +{ + + #if (_WIN32_WINNT < 0x600) + #error + #endif + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + as_fn_error $? "Building for Windows Vista or newer is required." "$LINENO" 5 + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + +squeeze() { + _sqz_result="" + eval _sqz_input=\$$1 + for _sqz_token in $_sqz_input; do + if test -z "$_sqz_result"; then + _sqz_result="$_sqz_token" + else + _sqz_result="$_sqz_result $_sqz_token" + fi + done + eval $1=\$_sqz_result + return 0 +} + + + + + + if test "$compiler_id" != "unknown"; then + + tmp_save_CPPFLAGS="$CPPFLAGS" + tmp_save_CFLAGS="$CFLAGS" + tmp_CPPFLAGS="" + tmp_CFLAGS="" + + case "$compiler_id" in + + CLANG|APPLECLANG) + + tmp_CFLAGS="$tmp_CFLAGS -Qunused-arguments" + tmp_CFLAGS="$tmp_CFLAGS -Werror-implicit-function-declaration" + ;; + + DEC_C) + + tmp_CFLAGS="$tmp_CFLAGS -std1" + tmp_CFLAGS="$tmp_CFLAGS -noansi_alias" + tmp_CFLAGS="$tmp_CFLAGS -warnprotos" + tmp_CFLAGS="$tmp_CFLAGS -msg_fatal toofewargs,toomanyargs" + ;; + + GNU_C) + + if test "$compiler_num" -ge "295"; then + tmp_CFLAGS="$tmp_CFLAGS -Werror-implicit-function-declaration" + fi + ;; + + HP_UX_C) + + tmp_CFLAGS="$tmp_CFLAGS -z" + tmp_CFLAGS="$tmp_CFLAGS +W 4227,4255" + ;; + + IBM_C) + + tmp_CPPFLAGS="$tmp_CPPFLAGS -qthreaded" + tmp_CPPFLAGS="$tmp_CPPFLAGS -qnoansialias" + tmp_CPPFLAGS="$tmp_CPPFLAGS -qhalt=e" + ;; + + INTEL_UNIX_C) + + tmp_CFLAGS="$tmp_CFLAGS -std=gnu89" + tmp_CPPFLAGS="$tmp_CPPFLAGS -diag-error 140,147,165,266" + tmp_CPPFLAGS="$tmp_CPPFLAGS -diag-disable 279,981,1025,1469,2259" + ;; + + INTEL_WINDOWS_C) + + tmp_CFLAGS="$tmp_CFLAGS" + ;; + + SGI_MIPS_C) + + tmp_CFLAGS="$tmp_CFLAGS" + ;; + + SGI_MIPSPRO_C) + + tmp_CFLAGS="$tmp_CFLAGS" + ;; + + SUNPRO_C) + + tmp_CFLAGS="$tmp_CFLAGS" + ;; + + TINY_C) + + tmp_CFLAGS="$tmp_CFLAGS" + ;; + + esac + + squeeze tmp_CPPFLAGS + squeeze tmp_CFLAGS + + if test -n "$tmp_CFLAGS" || test -n "$tmp_CPPFLAGS"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler accepts some basic options" >&5 +printf %s "checking if compiler accepts some basic options... " >&6; } + CPPFLAGS="$tmp_save_CPPFLAGS $tmp_CPPFLAGS" + CFLAGS="$tmp_save_CFLAGS $tmp_CFLAGS" + squeeze CPPFLAGS + squeeze CFLAGS + + tmp_compiler_works="unknown" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + +int main(void) +{ + + int i = 1; + return i; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + tmp_compiler_works="yes" + +else $as_nop + + tmp_compiler_works="no" + echo " " >&6 + sed 's/^/cc-fail: /' conftest.err >&6 + echo " " >&6 + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + if test "$tmp_compiler_works" = "yes"; then + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + +int main(void) +{ + + int i = 1; + return i; + + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + tmp_compiler_works="yes" + +else $as_nop + + tmp_compiler_works="no" + echo " " >&6 + sed 's/^/link-fail: /' conftest.err >&6 + echo " " >&6 + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + fi + if test "$cross_compiling" != "yes" && + test "$tmp_compiler_works" = "yes"; then + + if test "$curl_cv_apple" = "yes"; then + if test "$cross_compiling" = yes +then : + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #ifdef __STDC__ + # include + #endif + +int main(void) +{ + + int i = 0; + return i; + + return 0; +} + +_ACEOF +if ac_fn_c_try_run "$LINENO" +then : + tmp_compiler_works="yes" + +else $as_nop + tmp_compiler_works="no" + echo " " >&6 + echo "run-fail: test program exited with status $ac_status" >&6 + echo " " >&6 + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + else + oldcc=$CC + old=$LD_LIBRARY_PATH + CC="sh ./run-compiler" + LD_LIBRARY_PATH=$CURL_LIBRARY_PATH:$old + export LD_LIBRARY_PATH + if test "$cross_compiling" = yes +then : + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #ifdef __STDC__ + # include + #endif + +int main(void) +{ + + int i = 0; + return i; + + return 0; +} + +_ACEOF +if ac_fn_c_try_run "$LINENO" +then : + tmp_compiler_works="yes" + +else $as_nop + tmp_compiler_works="no" + echo " " >&6 + echo "run-fail: test program exited with status $ac_status" >&6 + echo " " >&6 + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + # restore + LD_LIBRARY_PATH=$old + CC=$oldcc + fi + + fi + if test "$tmp_compiler_works" = "yes"; then + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: compiler options added: $tmp_CFLAGS $tmp_CPPFLAGS" >&5 +printf "%s\n" "$as_me: compiler options added: $tmp_CFLAGS $tmp_CPPFLAGS" >&6;} + + else + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: compiler options rejected: $tmp_CFLAGS $tmp_CPPFLAGS" >&5 +printf "%s\n" "$as_me: WARNING: compiler options rejected: $tmp_CFLAGS $tmp_CPPFLAGS" >&2;} + CPPFLAGS="$tmp_save_CPPFLAGS" + CFLAGS="$tmp_save_CFLAGS" + + fi + + fi + fi + + + + + + + if test "$compiler_id" != "unknown"; then + + tmp_save_CFLAGS="$CFLAGS" + tmp_save_CPPFLAGS="$CPPFLAGS" + + tmp_options="" + tmp_CFLAGS="$CFLAGS" + tmp_CPPFLAGS="$CPPFLAGS" + + if test "$want_debug" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler accepts debug enabling options" >&5 +printf %s "checking if compiler accepts debug enabling options... " >&6; } + tmp_options="$flags_dbg_yes" + fi + + if test "$flags_prefer_cppflags" = "yes"; then + CPPFLAGS="$tmp_CPPFLAGS $tmp_options" + CFLAGS="$tmp_CFLAGS" + else + CPPFLAGS="$tmp_CPPFLAGS" + CFLAGS="$tmp_CFLAGS $tmp_options" + fi + squeeze CPPFLAGS + squeeze CFLAGS + fi + + + + + + + if test "$compiler_id" != "unknown"; then + + tmp_save_CFLAGS="$CFLAGS" + tmp_save_CPPFLAGS="$CPPFLAGS" + + tmp_options="" + tmp_CFLAGS="$CFLAGS" + tmp_CPPFLAGS="$CPPFLAGS" + honor_optimize_option="yes" + + + if test "$want_optimize" = "assume_no" || + test "$want_optimize" = "assume_yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler optimizer assumed setting might be used" >&5 +printf %s "checking if compiler optimizer assumed setting might be used... " >&6; } + + + ac_var_match_word="no" + for word1 in $tmp_CFLAGS; do + for word2 in $flags_opt_all; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "yes"; then + + honor_optimize_option="no" + + + fi + + + + ac_var_match_word="no" + for word1 in $tmp_CPPFLAGS; do + for word2 in $flags_opt_all; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "yes"; then + + honor_optimize_option="no" + + + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $honor_optimize_option" >&5 +printf "%s\n" "$honor_optimize_option" >&6; } + if test "$honor_optimize_option" = "yes"; then + if test "$want_optimize" = "assume_yes"; then + want_optimize="yes" + fi + if test "$want_optimize" = "assume_no"; then + want_optimize="no" + fi + fi + fi + + if test "$honor_optimize_option" = "yes"; then + + + ac_var_stripped="" + for word1 in $tmp_CFLAGS; do + ac_var_strip_word="no" + for word2 in $flags_opt_all; do + if test "$word1" = "$word2"; then + ac_var_strip_word="yes" + fi + done + if test "$ac_var_strip_word" = "no"; then + ac_var_stripped="$ac_var_stripped $word1" + fi + done + tmp_CFLAGS="$ac_var_stripped" + squeeze tmp_CFLAGS + + + + ac_var_stripped="" + for word1 in $tmp_CPPFLAGS; do + ac_var_strip_word="no" + for word2 in $flags_opt_all; do + if test "$word1" = "$word2"; then + ac_var_strip_word="yes" + fi + done + if test "$ac_var_strip_word" = "no"; then + ac_var_stripped="$ac_var_stripped $word1" + fi + done + tmp_CPPFLAGS="$ac_var_stripped" + squeeze tmp_CPPFLAGS + + if test "$want_optimize" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler accepts optimizer enabling options" >&5 +printf %s "checking if compiler accepts optimizer enabling options... " >&6; } + tmp_options="$flags_opt_yes" + fi + if test "$want_optimize" = "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler accepts optimizer disabling options" >&5 +printf %s "checking if compiler accepts optimizer disabling options... " >&6; } + tmp_options="$flags_opt_off" + fi + if test "$flags_prefer_cppflags" = "yes"; then + CPPFLAGS="$tmp_CPPFLAGS $tmp_options" + CFLAGS="$tmp_CFLAGS" + else + CPPFLAGS="$tmp_CPPFLAGS" + CFLAGS="$tmp_CFLAGS $tmp_options" + fi + squeeze CPPFLAGS + squeeze CFLAGS + + tmp_compiler_works="unknown" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + +int main(void) +{ + + int i = 1; + return i; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + tmp_compiler_works="yes" + +else $as_nop + + tmp_compiler_works="no" + echo " " >&6 + sed 's/^/cc-fail: /' conftest.err >&6 + echo " " >&6 + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + if test "$tmp_compiler_works" = "yes"; then + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + +int main(void) +{ + + int i = 1; + return i; + + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + tmp_compiler_works="yes" + +else $as_nop + + tmp_compiler_works="no" + echo " " >&6 + sed 's/^/link-fail: /' conftest.err >&6 + echo " " >&6 + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + fi + if test "$cross_compiling" != "yes" && + test "$tmp_compiler_works" = "yes"; then + + if test "$curl_cv_apple" = "yes"; then + if test "$cross_compiling" = yes +then : + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #ifdef __STDC__ + # include + #endif + +int main(void) +{ + + int i = 0; + return i; + + return 0; +} + +_ACEOF +if ac_fn_c_try_run "$LINENO" +then : + tmp_compiler_works="yes" + +else $as_nop + tmp_compiler_works="no" + echo " " >&6 + echo "run-fail: test program exited with status $ac_status" >&6 + echo " " >&6 + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + else + oldcc=$CC + old=$LD_LIBRARY_PATH + CC="sh ./run-compiler" + LD_LIBRARY_PATH=$CURL_LIBRARY_PATH:$old + export LD_LIBRARY_PATH + if test "$cross_compiling" = yes +then : + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #ifdef __STDC__ + # include + #endif + +int main(void) +{ + + int i = 0; + return i; + + return 0; +} + +_ACEOF +if ac_fn_c_try_run "$LINENO" +then : + tmp_compiler_works="yes" + +else $as_nop + tmp_compiler_works="no" + echo " " >&6 + echo "run-fail: test program exited with status $ac_status" >&6 + echo " " >&6 + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + # restore + LD_LIBRARY_PATH=$old + CC=$oldcc + fi + + fi + if test "$tmp_compiler_works" = "yes"; then + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: compiler options added: $tmp_options" >&5 +printf "%s\n" "$as_me: compiler options added: $tmp_options" >&6;} + + else + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: compiler options rejected: $tmp_options" >&5 +printf "%s\n" "$as_me: WARNING: compiler options rejected: $tmp_options" >&2;} + CPPFLAGS="$tmp_save_CPPFLAGS" + CFLAGS="$tmp_save_CFLAGS" + + fi + + fi + fi + + + + + + + if test "$compiler_id" != "unknown"; then + + tmp_save_CPPFLAGS="$CPPFLAGS" + tmp_save_CFLAGS="$CFLAGS" + tmp_CPPFLAGS="" + tmp_CFLAGS="" + + case "$compiler_id" in + + CLANG|APPLECLANG) + + if test "$want_warnings" = "yes"; then + if test "$compiler_num" -ge "302"; then + + + ac_var_added_warnings="" + for warning in pedantic; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + else + tmp_CFLAGS="$tmp_CFLAGS -pedantic" + fi + + + ac_var_added_warnings="" + for warning in all extra; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in pointer-arith write-strings; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in shadow; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in nested-externs; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in missing-declarations; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in missing-prototypes; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + tmp_CFLAGS="$tmp_CFLAGS -Wno-long-long" + + + ac_var_added_warnings="" + for warning in float-equal; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in sign-compare; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + tmp_CFLAGS="$tmp_CFLAGS -Wno-multichar" + + + ac_var_added_warnings="" + for warning in undef; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in endif-labels strict-prototypes; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in declaration-after-statement; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in cast-align; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + tmp_CFLAGS="$tmp_CFLAGS -Wno-system-headers" + + + ac_var_added_warnings="" + for warning in shorten-64-to-32; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + if test "$compiler_num" -ge "101"; then + + + ac_var_added_warnings="" + for warning in unused; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + fi + + if test "$compiler_num" -ge "207"; then + + + ac_var_added_warnings="" + for warning in address; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in attributes; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in bad-function-cast; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in cast-qual; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in conversion; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in div-by-zero format-security; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in empty-body; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + tmp_CFLAGS="$tmp_CFLAGS -Wformat=2" + + + ac_var_added_warnings="" + for warning in missing-field-initializers; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in missing-noreturn; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + tmp_CFLAGS="$tmp_CFLAGS -Wno-switch-default" + tmp_CFLAGS="$tmp_CFLAGS -Wno-switch-enum" # Not used because this basically disallows default case + + + ac_var_added_warnings="" + for warning in old-style-definition; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in redundant-decls; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in type-limits; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + # CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [unused-macros]) # Not practical + # tmp_CFLAGS="$tmp_CFLAGS -Wno-error=unused-macros" + + + ac_var_added_warnings="" + for warning in unreachable-code unused-parameter; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + fi + + if test "$compiler_num" -ge "208"; then + + + ac_var_added_warnings="" + for warning in ignored-qualifiers; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in vla; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + fi + + if test "$compiler_num" -ge "209"; then + tmp_CFLAGS="$tmp_CFLAGS -Wno-sign-conversion" + tmp_CFLAGS="$tmp_CFLAGS -Wno-padded" # Not used because we cannot change public structs + tmp_CFLAGS="$tmp_CFLAGS -Wno-used-but-marked-unused" # for typecheck-gcc.h with clang 14+, dependency headers + + + ac_var_added_warnings="" + for warning in shift-sign-overflow; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + fi + + if test "$compiler_num" -ge "300"; then + + + ac_var_added_warnings="" + for warning in conditional-uninitialized; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in language-extension-token; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + fi + + if test "$compiler_num" -ge "301"; then + + + ac_var_added_warnings="" + for warning in format-non-iso; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + tmp_CFLAGS="$tmp_CFLAGS -Wno-covered-switch-default" # Annoying to fix or silence + tmp_CFLAGS="$tmp_CFLAGS -Wno-disabled-macro-expansion" # for std headers, and curl/curl.h (rare combos) + fi + + if test "$compiler_num" -ge "302"; then + + + ac_var_added_warnings="" + for warning in enum-conversion; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in sometimes-uninitialized; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + case $host_os in + cygwin* | mingw*) + ;; + *) + + + ac_var_added_warnings="" + for warning in missing-variable-declarations; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + ;; + esac + fi + + if test "$compiler_num" -ge "303"; then + tmp_CFLAGS="$tmp_CFLAGS -Wno-documentation-unknown-command" + fi + + if test "$compiler_num" -ge "304"; then + + + ac_var_added_warnings="" + for warning in header-guard; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in unused-const-variable; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + fi + + if test "$compiler_num" -ge "305"; then + + + ac_var_added_warnings="" + for warning in pragmas; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + # CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [unreachable-code-break]) # Not used: Silent in "unity" builds + fi + + if test "$compiler_num" -ge "306"; then + + + ac_var_added_warnings="" + for warning in double-promotion; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + fi + + if test "$compiler_num" -ge "309"; then + + + ac_var_added_warnings="" + for warning in comma; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + if test "$compiler_num" -lt "400"; then + tmp_CFLAGS="$tmp_CFLAGS -Wno-varargs" + fi + fi + + if test "$compiler_num" -ge "700"; then + + + ac_var_added_warnings="" + for warning in assign-enum; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in extra-semi-stmt; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + fi + + if test "$compiler_num" -ge "1000"; then + tmp_CFLAGS="$tmp_CFLAGS -Wimplicit-fallthrough" # we have silencing markup for clang 10.0 and above only + + + ac_var_added_warnings="" + for warning in xor-used-as-pow; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + fi + + if test "$compiler_num" -ge "1300"; then + + + ac_var_added_warnings="" + for warning in cast-function-type; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in reserved-identifier; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + # Keep it before -Wno-reserved-macro-identifier + tmp_CFLAGS="$tmp_CFLAGS -Wno-reserved-macro-identifier" # Sometimes such external macros need to be set + fi + + if test "$compiler_num" -ge "1600"; then + tmp_CFLAGS="$tmp_CFLAGS -Wno-unsafe-buffer-usage" + fi + + if test "$compiler_num" -ge "1700"; then + + + ac_var_added_warnings="" + for warning in cast-function-type-strict; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + # with Apple clang it requires 16.0 or above + fi + + if test "$compiler_num" -ge "1901"; then + + + ac_var_added_warnings="" + for warning in format-signedness; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + fi + + if test "$compiler_num" -ge "2001"; then + + + ac_var_added_warnings="" + for warning in array-compare; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + fi + + if test "$compiler_num" -ge "2101"; then + + + ac_var_added_warnings="" + for warning in c++-hidden-decl; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in implicit-int-enum-cast; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in jump-misses-init; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + tmp_CFLAGS="$tmp_CFLAGS -Wno-implicit-void-ptr-cast" + + + ac_var_added_warnings="" + for warning in tentative-definition-compat; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + if test "$curl_cv_native_windows" = "yes"; then + tmp_CFLAGS="$tmp_CFLAGS -Wno-c++-keyword" # `wchar_t` triggers it on Windows + else + + + ac_var_added_warnings="" + for warning in c++-keyword; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + fi + fi + + case "$CFLAGS" in + *-std=c89*|*-std=c90*|*-std=gnu89*|*-std=gnu90*) + if test "$compiler_num" -ge "300"; then + tmp_CFLAGS="$tmp_CFLAGS -Wno-c99-extensions" # Avoid: warning: '_Bool' is a C99 extension + fi + if test "$compiler_num" -ge "309"; then + tmp_CFLAGS="$tmp_CFLAGS -Wno-comma" # Silly + fi + ;; + esac + fi + ;; + + DEC_C) + + if test "$want_warnings" = "yes"; then + tmp_CFLAGS="$tmp_CFLAGS -msg_enable level3" + fi + ;; + + GNU_C) + + if test "$want_warnings" = "yes" && test "$compiler_num" -ge "406"; then + + if test "$cross_compiling" != "yes" || + test "$compiler_num" -ge "300"; then + if test "$compiler_num" -ge "408"; then + + + ac_var_added_warnings="" + for warning in pedantic; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + else + tmp_CFLAGS="$tmp_CFLAGS -pedantic" + fi + fi + + + + ac_var_added_warnings="" + for warning in all; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + tmp_CFLAGS="$tmp_CFLAGS -W" + + if test "$compiler_num" -ge "104"; then + + + ac_var_added_warnings="" + for warning in pointer-arith write-strings; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + if test "$cross_compiling" != "yes" || + test "$compiler_num" -ge "300"; then + + + ac_var_added_warnings="" + for warning in unused shadow; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + fi + fi + + if test "$compiler_num" -ge "207"; then + + + ac_var_added_warnings="" + for warning in nested-externs; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + if test "$cross_compiling" != "yes" || + test "$compiler_num" -ge "300"; then + + + ac_var_added_warnings="" + for warning in missing-declarations; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in missing-prototypes; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + fi + fi + + if test "$compiler_num" -ge "295"; then + tmp_CFLAGS="$tmp_CFLAGS -Wno-long-long" + + + ac_var_added_warnings="" + for warning in bad-function-cast; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + fi + + if test "$compiler_num" -ge "296"; then + + + ac_var_added_warnings="" + for warning in float-equal; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + tmp_CFLAGS="$tmp_CFLAGS -Wno-multichar" + + + ac_var_added_warnings="" + for warning in sign-compare; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in undef; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + fi + + if test "$compiler_num" -ge "300"; then + tmp_CFLAGS="$tmp_CFLAGS" + fi + + if test "$compiler_num" -ge "303"; then + + + ac_var_added_warnings="" + for warning in endif-labels strict-prototypes; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + fi + + if test "$compiler_num" -ge "304"; then + + + ac_var_added_warnings="" + for warning in declaration-after-statement; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in old-style-definition; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + fi + + if test "$compiler_num" -ge "400"; then + + + ac_var_added_warnings="" + for warning in cast-qual; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + tmp_CFLAGS="$tmp_CFLAGS -Wstrict-aliasing=3" + fi + + if test "$compiler_num" -ge "401"; then + + + ac_var_added_warnings="" + for warning in attributes; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in div-by-zero format-security; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in missing-field-initializers; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + case $host in + *-*-msys*) + ;; + *) + + + ac_var_added_warnings="" + for warning in missing-noreturn; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + # Seen to clash with libtool-generated stub code + ;; + esac + + + ac_var_added_warnings="" + for warning in unreachable-code unused-parameter; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + tmp_CFLAGS="$tmp_CFLAGS -Wno-padded" # Not used because we cannot change public structs + tmp_CFLAGS="$tmp_CFLAGS -Wno-switch-default" + tmp_CFLAGS="$tmp_CFLAGS -Wno-switch-enum" # Not used because this basically disallows default case + + + ac_var_added_warnings="" + for warning in pragmas; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in redundant-decls; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + # CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [unused-macros]) # Not practical + # tmp_CFLAGS="$tmp_CFLAGS -Wno-error=unused-macros" + fi + + if test "$compiler_num" -ge "402"; then + + + ac_var_added_warnings="" + for warning in cast-align; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + fi + + if test "$compiler_num" -ge "403"; then + + + ac_var_added_warnings="" + for warning in address; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in type-limits old-style-declaration; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in missing-parameter-type empty-body; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in clobbered ignored-qualifiers; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in conversion; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + tmp_CFLAGS="$tmp_CFLAGS -Wno-sign-conversion" + + + ac_var_added_warnings="" + for warning in vla; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + tmp_CFLAGS="$tmp_CFLAGS -ftree-vrp" + fi + + if test "$compiler_num" -ge "404"; then + + + ac_var_added_warnings="" + for warning in logical-op; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + fi + + if test "$compiler_num" -ge "405"; then + + + ac_var_added_warnings="" + for warning in jump-misses-init; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + if test "$curl_cv_native_windows" = "yes"; then + tmp_CFLAGS="$tmp_CFLAGS -Wno-pedantic-ms-format" + fi + case $host_os in + cygwin*) + tmp_CFLAGS="$tmp_CFLAGS -Wno-suggest-attribute=noreturn" + ;; + esac + fi + + if test "$compiler_num" -ge "406"; then + + + ac_var_added_warnings="" + for warning in double-promotion; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in trampolines; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + fi + + if test "$compiler_num" -ge "408"; then + tmp_CFLAGS="$tmp_CFLAGS -Wformat=2" + fi + + if test "$compiler_num" -ge "500"; then + tmp_CFLAGS="$tmp_CFLAGS -Warray-bounds=2" + + + ac_var_added_warnings="" + for warning in format-signedness; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + fi + + if test "$compiler_num" -ge "600"; then + + + ac_var_added_warnings="" + for warning in shift-negative-value; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + tmp_CFLAGS="$tmp_CFLAGS -Wshift-overflow=2" + + + ac_var_added_warnings="" + for warning in null-dereference; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + tmp_CFLAGS="$tmp_CFLAGS -fdelete-null-pointer-checks" + + + ac_var_added_warnings="" + for warning in duplicated-cond; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in unused-const-variable; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + fi + + if test "$compiler_num" -ge "700"; then + + + ac_var_added_warnings="" + for warning in duplicated-branches; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in restrict; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in alloc-zero; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + tmp_CFLAGS="$tmp_CFLAGS -Wformat-truncation=2" + tmp_CFLAGS="$tmp_CFLAGS -Wimplicit-fallthrough" + fi + + if test "$compiler_num" -ge "1000"; then + + + ac_var_added_warnings="" + for warning in arith-conversion; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in enum-conversion; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + fi + + if test "$compiler_num" -ge "1200"; then + + + ac_var_added_warnings="" + for warning in array-compare; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + fi + + if test "$compiler_num" -ge "1300"; then + + + ac_var_added_warnings="" + for warning in enum-int-mismatch; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in xor-used-as-pow; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + fi + + if test "$compiler_num" -ge "1500"; then + + + ac_var_added_warnings="" + for warning in leading-whitespace=spaces; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in trailing-whitespace=any; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in unterminated-string-initialization; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + fi + fi + + if test "$compiler_num" -ge "300"; then + tmp_CFLAGS="$tmp_CFLAGS -Wno-system-headers" + else + if test "$cross_compiling" = "yes"; then + if test "$compiler_num" -ge "104"; then + tmp_CFLAGS="$tmp_CFLAGS -Wno-unused -Wno-shadow" + fi + if test "$compiler_num" -ge "207"; then + tmp_CFLAGS="$tmp_CFLAGS -Wno-missing-declarations" + tmp_CFLAGS="$tmp_CFLAGS -Wno-missing-prototypes" + fi + fi + fi + if test "$compiler_num" -ge "400" && test "$compiler_num" -lt "407"; then + tmp_CFLAGS="$tmp_CFLAGS -Wno-missing-field-initializers" + fi + if test "$compiler_num" -ge "403" && test "$compiler_num" -lt "408"; then + tmp_CFLAGS="$tmp_CFLAGS -Wno-type-limits" + fi + if test "$compiler_num" -ge "501" && test "$compiler_num" -lt "505"; then + tmp_CFLAGS="$tmp_CFLAGS -Wno-conversion" + fi + ;; + + HP_UX_C) + + if test "$want_warnings" = "yes"; then + tmp_CFLAGS="$tmp_CFLAGS +w1" + fi + ;; + + IBM_C) + + tmp_CFLAGS="$tmp_CFLAGS" + ;; + + INTEL_UNIX_C) + + if test "$want_warnings" = "yes"; then + if test "$compiler_num" -gt "600"; then + tmp_CPPFLAGS="$tmp_CPPFLAGS -Wall -w2" + tmp_CPPFLAGS="$tmp_CPPFLAGS -Wcheck" + tmp_CPPFLAGS="$tmp_CPPFLAGS -Wcomment" + tmp_CPPFLAGS="$tmp_CPPFLAGS -Wdeprecated" + tmp_CPPFLAGS="$tmp_CPPFLAGS -Wmissing-prototypes" + tmp_CPPFLAGS="$tmp_CPPFLAGS -Wp64" + tmp_CPPFLAGS="$tmp_CPPFLAGS -Wpointer-arith" + tmp_CPPFLAGS="$tmp_CPPFLAGS -Wreturn-type" + tmp_CPPFLAGS="$tmp_CPPFLAGS -Wshadow" + tmp_CPPFLAGS="$tmp_CPPFLAGS -Wuninitialized" + tmp_CPPFLAGS="$tmp_CPPFLAGS -Wunused-function" + fi + fi + tmp_CFLAGS="$tmp_CFLAGS -fno-omit-frame-pointer" + tmp_CFLAGS="$tmp_CFLAGS -fno-strict-aliasing" + tmp_CFLAGS="$tmp_CFLAGS -fp-model precise" + ;; + + INTEL_WINDOWS_C) + + tmp_CFLAGS="$tmp_CFLAGS" + ;; + + SGI_MIPS_C) + + if test "$want_warnings" = "yes"; then + tmp_CFLAGS="$tmp_CFLAGS -fullwarn" + fi + ;; + + SGI_MIPSPRO_C) + + if test "$want_warnings" = "yes"; then + tmp_CFLAGS="$tmp_CFLAGS -fullwarn" + tmp_CFLAGS="$tmp_CFLAGS -woff 1209" + fi + ;; + + SUNPRO_C) + + if test "$want_warnings" = "yes"; then + tmp_CFLAGS="$tmp_CFLAGS -v" + fi + ;; + + TINY_C) + + if test "$want_warnings" = "yes"; then + + + ac_var_added_warnings="" + for warning in all; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in write-strings; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + + + ac_var_added_warnings="" + for warning in unsupported; do + + ac_var_match_word="no" + for word1 in $CFLAGS; do + for word2 in -Wno-$warning -W$warning; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done + + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + tmp_CFLAGS="$tmp_CFLAGS $ac_var_added_warnings" + squeeze tmp_CFLAGS + + fi + ;; + + esac + + squeeze tmp_CPPFLAGS + squeeze tmp_CFLAGS + + if test -n "$tmp_CFLAGS" || test -n "$tmp_CPPFLAGS"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler accepts strict warning options" >&5 +printf %s "checking if compiler accepts strict warning options... " >&6; } + CPPFLAGS="$tmp_save_CPPFLAGS $tmp_CPPFLAGS" + CFLAGS="$tmp_save_CFLAGS $tmp_CFLAGS" + squeeze CPPFLAGS + squeeze CFLAGS + + tmp_compiler_works="unknown" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + +int main(void) +{ + + int i = 1; + return i; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + tmp_compiler_works="yes" + +else $as_nop + + tmp_compiler_works="no" + echo " " >&6 + sed 's/^/cc-fail: /' conftest.err >&6 + echo " " >&6 + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + if test "$tmp_compiler_works" = "yes"; then + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + +int main(void) +{ + + int i = 1; + return i; + + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + tmp_compiler_works="yes" + +else $as_nop + + tmp_compiler_works="no" + echo " " >&6 + sed 's/^/link-fail: /' conftest.err >&6 + echo " " >&6 + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + fi + if test "$cross_compiling" != "yes" && + test "$tmp_compiler_works" = "yes"; then + + if test "$curl_cv_apple" = "yes"; then + if test "$cross_compiling" = yes +then : + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #ifdef __STDC__ + # include + #endif + +int main(void) +{ + + int i = 0; + return i; + + return 0; +} + +_ACEOF +if ac_fn_c_try_run "$LINENO" +then : + tmp_compiler_works="yes" + +else $as_nop + tmp_compiler_works="no" + echo " " >&6 + echo "run-fail: test program exited with status $ac_status" >&6 + echo " " >&6 + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + else + oldcc=$CC + old=$LD_LIBRARY_PATH + CC="sh ./run-compiler" + LD_LIBRARY_PATH=$CURL_LIBRARY_PATH:$old + export LD_LIBRARY_PATH + if test "$cross_compiling" = yes +then : + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #ifdef __STDC__ + # include + #endif + +int main(void) +{ + + int i = 0; + return i; + + return 0; +} + +_ACEOF +if ac_fn_c_try_run "$LINENO" +then : + tmp_compiler_works="yes" + +else $as_nop + tmp_compiler_works="no" + echo " " >&6 + echo "run-fail: test program exited with status $ac_status" >&6 + echo " " >&6 + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + # restore + LD_LIBRARY_PATH=$old + CC=$oldcc + fi + + fi + if test "$tmp_compiler_works" = "yes"; then + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: compiler options added: $tmp_CFLAGS $tmp_CPPFLAGS" >&5 +printf "%s\n" "$as_me: compiler options added: $tmp_CFLAGS $tmp_CPPFLAGS" >&6;} + + else + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: compiler options rejected: $tmp_CFLAGS $tmp_CPPFLAGS" >&5 +printf "%s\n" "$as_me: WARNING: compiler options rejected: $tmp_CFLAGS $tmp_CPPFLAGS" >&2;} + CPPFLAGS="$tmp_save_CPPFLAGS" + CFLAGS="$tmp_save_CFLAGS" + + fi + + fi + fi + + +if test "$compiler_id" = "INTEL_UNIX_C"; then + if test "$compiler_num" -ge "1000"; then + CFLAGS="$CFLAGS -shared-intel" + elif test "$compiler_num" -ge "900"; then + CFLAGS="$CFLAGS -i-dynamic" + fi +fi + +case $host in + *msdosdjgpp) + if test "$compiler_num" -ge "1000"; then + CFLAGS="$CFLAGS -Wno-arith-conversion" + fi + ;; +esac + +CURL_CFLAG_EXTRAS="" +if test "$want_werror" = "yes"; then + CURL_CFLAG_EXTRAS="-Werror" + if test "$compiler_id" = "GNU_C"; then + if test "$compiler_num" -ge "500"; then + CURL_CFLAG_EXTRAS="$CURL_CFLAG_EXTRAS -pedantic-errors" + fi + elif test "$compiler_id" = "CLANG" || test "$compiler_id" = "APPLECLANG"; then + CURL_CFLAG_EXTRAS="$CURL_CFLAG_EXTRAS -pedantic-errors" + fi +fi + + if test "$want_werror" = "yes"; then + CURL_WERROR_TRUE= + CURL_WERROR_FALSE='#' +else + CURL_WERROR_TRUE='#' + CURL_WERROR_FALSE= +fi + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler halts on compilation errors" >&5 +printf %s "checking if compiler halts on compilation errors... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + +int main(void) +{ + + #error force compilation error + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + as_fn_error $? "compiler does not halt on compilation errors." "$LINENO" 5 + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler halts on negative sized arrays" >&5 +printf %s "checking if compiler halts on negative sized arrays... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + typedef char bad_t[sizeof(char) == sizeof(int) ? -1 : -1]; + +int main(void) +{ + + bad_t dummy; + (void)dummy; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + as_fn_error $? "compiler does not halt on negative sized arrays." "$LINENO" 5 + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler halts on function prototype mismatch" >&5 +printf %s "checking if compiler halts on function prototype mismatch... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #include + int rand(int n); + int rand(int n) + { + if(n) + return ++n; + else + return n; + } + +int main(void) +{ + + int i[2] ={ 0, 0 }; + int j = rand(i[0]); + if(j) + return j; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + as_fn_error $? "compiler does not halt on function prototype mismatch." "$LINENO" 5 + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler supports hiding library internal symbols" >&5 +printf %s "checking if compiler supports hiding library internal symbols... " >&6; } + supports_symbol_hiding="no" + symbol_hiding_CFLAGS="" + symbol_hiding_EXTERN="" + tmp_CFLAGS="" + tmp_EXTERN="" + case "$compiler_id" in + CLANG|APPLECLANG) + tmp_EXTERN="__attribute__((__visibility__(\"default\")))" + tmp_CFLAGS="-fvisibility=hidden" + supports_symbol_hiding="yes" + ;; + GNU_C) + if test "$compiler_num" -ge "304"; then + if $CC --help --verbose 2>/dev/null | grep fvisibility= >/dev/null; then + tmp_EXTERN="__attribute__((__visibility__(\"default\")))" + tmp_CFLAGS="-fvisibility=hidden" + supports_symbol_hiding="yes" + fi + fi + ;; + INTEL_UNIX_C) + if test "$compiler_num" -ge "900"; then + if $CC --help --verbose 2>&1 | grep fvisibility= > /dev/null; then + tmp_save_CFLAGS="$CFLAGS" + CFLAGS="$CFLAGS -fvisibility=hidden" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #include + +int main(void) +{ + + printf("icc fvisibility bug test"); + + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + tmp_EXTERN="__attribute__((__visibility__(\"default\")))" + tmp_CFLAGS="-fvisibility=hidden" + supports_symbol_hiding="yes" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + CFLAGS="$tmp_save_CFLAGS" + fi + fi + ;; + SUNPRO_C) + if $CC 2>&1 | grep flags >/dev/null && $CC -flags | grep xldscope= >/dev/null; then + tmp_EXTERN="__global" + tmp_CFLAGS="-xldscope=hidden" + supports_symbol_hiding="yes" + fi + ;; + esac + if test "$supports_symbol_hiding" = "yes"; then + tmp_save_CFLAGS="$CFLAGS" + CFLAGS="$tmp_save_CFLAGS $tmp_CFLAGS" + squeeze CFLAGS + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $tmp_EXTERN const char *dummy(const char *buff); + const char *dummy(const char *buff) + { + if(buff) + return ++buff; + else + return buff; + } + +int main(void) +{ + + const char *b = "example"; + const char *r = dummy(&b[0]); + if(r) + return (int)*r; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + supports_symbol_hiding="yes" + if test -f conftest.err; then + grep 'visibility' conftest.err >/dev/null + if test "$?" -eq "0"; then + supports_symbol_hiding="no" + fi + fi + +else $as_nop + + supports_symbol_hiding="no" + echo " " >&6 + sed 's/^/cc-src: /' conftest.$ac_ext >&6 + sed 's/^/cc-err: /' conftest.err >&6 + echo " " >&6 + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + CFLAGS="$tmp_save_CFLAGS" + fi + if test "$supports_symbol_hiding" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + symbol_hiding_CFLAGS="$tmp_CFLAGS" + symbol_hiding_EXTERN="$tmp_EXTERN" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + fi + + +supports_unittests=yes +if test "$cross_compiling" != "no" && + test "$enable_shared" != "no"; then + supports_unittests=no +fi + +case $host in + mips-sgi-irix6.5) + if test "$compiler_id" = "GNU_C"; then + supports_unittests=no + fi + ;; +esac + +case $host_os in + aix*) + supports_unittests=no + ;; +esac + + if test "$supports_unittests" = "yes"; then + BUILD_UNITTESTS_TRUE= + BUILD_UNITTESTS_FALSE='#' +else + BUILD_UNITTESTS_TRUE='#' + BUILD_UNITTESTS_FALSE= +fi + + +case $host_os in + *linux*|cygwin*|msys*|gnu*) + CPPFLAGS="$CPPFLAGS -D_GNU_SOURCE" + ;; +esac + + if test "$compiler_id" = "APPLECLANG" || test "$compiler_id" = "CLANG"; then + CLANG_TRUE= + CLANG_FALSE='#' +else + CLANG_TRUE='#' + CLANG_FALSE= +fi + + + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether build target supports Win32 crypto API" >&5 +printf %s "checking whether build target supports Win32 crypto API... " >&6; } + curl_win32_crypto_api="no" + if test "$curl_cv_native_windows" = "yes" && test "$curl_cv_winuwp" != "yes"; then + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #undef inline + #ifndef WIN32_LEAN_AND_MEAN + #define WIN32_LEAN_AND_MEAN + #endif + #include + #include + +int main(void) +{ + + HCRYPTPROV hCryptProv; + if(CryptAcquireContext(&hCryptProv, NULL, NULL, PROV_RSA_FULL, + CRYPT_VERIFYCONTEXT | CRYPT_SILENT)) { + CryptReleaseContext(hCryptProv, 0); + } + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + curl_win32_crypto_api="yes" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + case "$curl_win32_crypto_api" in + yes) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define USE_WIN32_CRYPTO 1" >>confdefs.h + + USE_WIN32_CRYPTO=1 + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + ;; + esac + + +curl_cv_android='no' +curl_cv_apple='no' +case $host in + *-*-android*) curl_cv_android='yes';; + *-apple-*) curl_cv_apple='yes';; +esac + +if test "$curl_cv_apple" = "yes"; then + + old_CFLAGS=$CFLAGS + CFLAGS="$CFLAGS -Werror=partial-availability" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -Werror=partial-availability" >&5 +printf %s "checking whether $CC accepts -Werror=partial-availability... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int main(void) +{ + + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + CFLAGS=$old_CFLAGS +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking to see if the compiler supports __builtin_available()" >&5 +printf %s "checking to see if the compiler supports __builtin_available()... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + +int main(void) +{ + + if(__builtin_available(macOS 10.12, iOS 5.0, *)) {} + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_BUILTIN_AVAILABLE 1" >>confdefs.h + + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + +fi + + if test "$curl_cv_native_windows" = "yes" && test -n "${RC}"; then + HAVE_WINDRES_TRUE= + HAVE_WINDRES_FALSE='#' +else + HAVE_WINDRES_TRUE='#' + HAVE_WINDRES_FALSE= +fi + + +if test "$curl_cv_native_windows" = "yes"; then + if test -z "$HAVE_WINDRES_TRUE"; then : + else + as_fn_error $? "windres not found in PATH. Windows builds require windres. Cannot continue." "$LINENO" 5 +fi +fi + + +want_unity='no' +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to build libcurl and curl in \"unity\" mode" >&5 +printf %s "checking whether to build libcurl and curl in \"unity\" mode... " >&6; } +# Check whether --enable-unity was given. +if test ${enable_unity+y} +then : + enableval=$enable_unity; case "$enableval" in + yes) + want_unity='yes' + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +fi + +if test -z "$PERL" && test "$want_unity" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: perl was not found. Cannot enable unity." >&5 +printf "%s\n" "$as_me: WARNING: perl was not found. Cannot enable unity." >&2;} + want_unity='no' +fi + if test "$want_unity" = "yes"; then + USE_UNITY_TRUE= + USE_UNITY_FALSE='#' +else + USE_UNITY_TRUE='#' + USE_UNITY_FALSE= +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support http" >&5 +printf %s "checking whether to support http... " >&6; } +# Check whether --enable-http was given. +if test ${enable_http+y} +then : + enableval=$enable_http; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_HTTP 1" >>confdefs.h + + disable_http="yes" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: disable HTTP disables FTP over proxy, IPFS and RTSP" >&5 +printf "%s\n" "$as_me: WARNING: disable HTTP disables FTP over proxy, IPFS and RTSP" >&2;} + CURL_DISABLE_HTTP=1 + +printf "%s\n" "#define CURL_DISABLE_IPFS 1" >>confdefs.h + + CURL_DISABLE_IPFS=1 + +printf "%s\n" "#define CURL_DISABLE_RTSP 1" >>confdefs.h + + CURL_DISABLE_RTSP=1 + +printf "%s\n" "#define CURL_DISABLE_ALTSVC 1" >>confdefs.h + + +printf "%s\n" "#define CURL_DISABLE_HSTS 1" >>confdefs.h + + curl_h1_msg="no (--enable-http)" + curl_altsvc_msg="no"; + curl_hsts_msg="no (--enable-hsts)"; + enable_altsvc="no" + hsts="no" + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support ftp" >&5 +printf %s "checking whether to support ftp... " >&6; } +# Check whether --enable-ftp was given. +if test ${enable_ftp+y} +then : + enableval=$enable_ftp; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_FTP 1" >>confdefs.h + + CURL_DISABLE_FTP=1 + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support file" >&5 +printf %s "checking whether to support file... " >&6; } +# Check whether --enable-file was given. +if test ${enable_file+y} +then : + enableval=$enable_file; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_FILE 1" >>confdefs.h + + CURL_DISABLE_FILE=1 + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support IPFS" >&5 +printf %s "checking whether to support IPFS... " >&6; } +# Check whether --enable-ipfs was given. +if test ${enable_ipfs+y} +then : + enableval=$enable_ipfs; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_IPFS 1" >>confdefs.h + + CURL_DISABLE_IPFS=1 + ;; + *) + if test "$CURL_DISABLE_HTTP" = "1"; then + as_fn_error $? "HTTP support needs to be enabled in order to enable IPFS support!" "$LINENO" 5 + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + curl_ipfs_msg="enabled" + fi + ;; + esac +else $as_nop + if test "$CURL_DISABLE_HTTP" != "1"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + curl_ipfs_msg="enabled" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + fi + +fi + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support ldap" >&5 +printf %s "checking whether to support ldap... " >&6; } +# Check whether --enable-ldap was given. +if test ${enable_ldap+y} +then : + enableval=$enable_ldap; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_LDAP 1" >>confdefs.h + + CURL_DISABLE_LDAP=1 + ;; + yes) + ldap_askedfor="yes" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support ldaps" >&5 +printf %s "checking whether to support ldaps... " >&6; } +# Check whether --enable-ldaps was given. +if test ${enable_ldaps+y} +then : + enableval=$enable_ldaps; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_LDAPS 1" >>confdefs.h + + CURL_DISABLE_LDAPS=1 + ;; + *) + if test "$CURL_DISABLE_LDAP" = "1"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: LDAP needs to be enabled to support LDAPS" >&5 +printf "%s\n" "LDAP needs to be enabled to support LDAPS" >&6; } + +printf "%s\n" "#define CURL_DISABLE_LDAPS 1" >>confdefs.h + + CURL_DISABLE_LDAPS=1 + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_LDAP_SSL 1" >>confdefs.h + + HAVE_LDAP_SSL=1 + fi + ;; + esac +else $as_nop + + if test "$CURL_DISABLE_LDAP" = "1"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_LDAPS 1" >>confdefs.h + + CURL_DISABLE_LDAPS=1 + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_LDAP_SSL 1" >>confdefs.h + + HAVE_LDAP_SSL=1 + fi + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support rtsp" >&5 +printf %s "checking whether to support rtsp... " >&6; } +# Check whether --enable-rtsp was given. +if test ${enable_rtsp+y} +then : + enableval=$enable_rtsp; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_RTSP 1" >>confdefs.h + + CURL_DISABLE_RTSP=1 + ;; + *) + if test "$CURL_DISABLE_HTTP" = "1"; then + as_fn_error $? "HTTP support needs to be enabled in order to enable RTSP support!" "$LINENO" 5 + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + curl_rtsp_msg="enabled" + fi + ;; + esac +else $as_nop + if test "$CURL_DISABLE_HTTP" != "1"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + curl_rtsp_msg="enabled" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + fi + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support proxies" >&5 +printf %s "checking whether to support proxies... " >&6; } +# Check whether --enable-proxy was given. +if test ${enable_proxy+y} +then : + enableval=$enable_proxy; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_PROXY 1" >>confdefs.h + + CURL_DISABLE_PROXY=1 + https_proxy="no" + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support dict" >&5 +printf %s "checking whether to support dict... " >&6; } +# Check whether --enable-dict was given. +if test ${enable_dict+y} +then : + enableval=$enable_dict; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_DICT 1" >>confdefs.h + + CURL_DISABLE_DICT=1 + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support telnet" >&5 +printf %s "checking whether to support telnet... " >&6; } +# Check whether --enable-telnet was given. +if test ${enable_telnet+y} +then : + enableval=$enable_telnet; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_TELNET 1" >>confdefs.h + + CURL_DISABLE_TELNET=1 + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + + +if test "$curl_cv_winuwp" = "yes"; then + +printf "%s\n" "#define CURL_DISABLE_TELNET 1" >>confdefs.h + + CURL_DISABLE_TELNET=1 +fi + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support tftp" >&5 +printf %s "checking whether to support tftp... " >&6; } +# Check whether --enable-tftp was given. +if test ${enable_tftp+y} +then : + enableval=$enable_tftp; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_TFTP 1" >>confdefs.h + + CURL_DISABLE_TFTP=1 + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support pop3" >&5 +printf %s "checking whether to support pop3... " >&6; } +# Check whether --enable-pop3 was given. +if test ${enable_pop3+y} +then : + enableval=$enable_pop3; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_POP3 1" >>confdefs.h + + CURL_DISABLE_POP3=1 + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support imap" >&5 +printf %s "checking whether to support imap... " >&6; } +# Check whether --enable-imap was given. +if test ${enable_imap+y} +then : + enableval=$enable_imap; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_IMAP 1" >>confdefs.h + + CURL_DISABLE_IMAP=1 + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support smb" >&5 +printf %s "checking whether to support smb... " >&6; } +# Check whether --enable-smb was given. +if test ${enable_smb+y} +then : + enableval=$enable_smb; case "$enableval" in + yes) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define CURL_ENABLE_SMB 1" >>confdefs.h + + CURL_ENABLE_SMB=1 + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support smtp" >&5 +printf %s "checking whether to support smtp... " >&6; } +# Check whether --enable-smtp was given. +if test ${enable_smtp+y} +then : + enableval=$enable_smtp; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_SMTP 1" >>confdefs.h + + CURL_DISABLE_SMTP=1 + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support gopher" >&5 +printf %s "checking whether to support gopher... " >&6; } +# Check whether --enable-gopher was given. +if test ${enable_gopher+y} +then : + enableval=$enable_gopher; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_GOPHER 1" >>confdefs.h + + CURL_DISABLE_GOPHER=1 + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support mqtt" >&5 +printf %s "checking whether to support mqtt... " >&6; } +# Check whether --enable-mqtt was given. +if test ${enable_mqtt+y} +then : + enableval=$enable_mqtt; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_MQTT 1" >>confdefs.h + + CURL_DISABLE_MQTT=1 + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking enable curl_global_init_mem debug build" >&5 +printf %s "checking enable curl_global_init_mem debug build... " >&6; } +# Check whether --enable-init-mem-debug was given. +if test ${enable_init_mem_debug+y} +then : + enableval=$enable_init_mem_debug; case "$enableval" in + yes) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define CURL_DEBUG_GLOBAL_MEM 1" >>confdefs.h + + SUPPORT_FEATURES="$SUPPORT_FEATURES global-mem-debug" + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +fi + + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to provide built-in manual" >&5 +printf %s "checking whether to provide built-in manual... " >&6; } +# Check whether --enable-manual was given. +if test ${enable_manual+y} +then : + enableval=$enable_manual; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + USE_MANUAL="1" + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + USE_MANUAL="1" + +fi + + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to build documentation" >&5 +printf %s "checking whether to build documentation... " >&6; } +# Check whether --enable-docs was given. +if test ${enable_docs+y} +then : + enableval=$enable_docs; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + BUILD_DOCS=0 + USE_MANUAL=0 + curl_docs_msg="no" + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + BUILD_DOCS=1 + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + BUILD_DOCS=1 + +fi + +if test -z "$PERL" && test "$BUILD_DOCS" != "0"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: perl was not found. Cannot build documentation." >&5 +printf "%s\n" "$as_me: WARNING: perl was not found. Cannot build documentation." >&2;} + BUILD_DOCS=0 +fi + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable generation of C code" >&5 +printf %s "checking whether to enable generation of C code... " >&6; } +# Check whether --enable-libcurl_option was given. +if test ${enable_libcurl_option+y} +then : + enableval=$enable_libcurl_option; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_LIBCURL_OPTION 1" >>confdefs.h + + curl_libcurl_msg="no" + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to use libgcc" >&5 +printf %s "checking whether to use libgcc... " >&6; } +# Check whether --enable-libgcc was given. +if test ${enable_libgcc+y} +then : + enableval=$enable_libgcc; case "$enableval" in + yes) + LIBS="-lgcc $LIBS" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to use libbacktrace" >&5 +printf %s "checking whether to use libbacktrace... " >&6; } + +# Check whether --with-backtrace was given. +if test ${with_backtrace+y} +then : + withval=$with_backtrace; case "$enableval" in + yes) + LIBS="-lbacktrace $LIBS" + +printf "%s\n" "#define USE_BACKTRACE 1" >>confdefs.h + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +fi + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if X/Open network library is required" >&5 +printf %s "checking if X/Open network library is required... " >&6; } + tst_lib_xnet_required="no" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + int main(void) + { + #if defined(__hpux) && defined(_XOPEN_SOURCE) && (_XOPEN_SOURCE >= 600) + #elif defined(__hpux) && defined(_XOPEN_SOURCE_EXTENDED) + #else + #error force compilation error + #endif + return 0; + } + + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + tst_lib_xnet_required="yes" + LIBS="-lxnet $LIBS" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tst_lib_xnet_required" >&5 +printf "%s\n" "$tst_lib_xnet_required" >&6; } + + +ac_fn_c_check_func "$LINENO" "gethostbyname" "ac_cv_func_gethostbyname" +if test "x$ac_cv_func_gethostbyname" = xyes +then : + + HAVE_GETHOSTBYNAME="1" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gethostbyname in -lnsl" >&5 +printf %s "checking for gethostbyname in -lnsl... " >&6; } +if test ${ac_cv_lib_nsl_gethostbyname+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lnsl $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char gethostbyname (); +int main(void) +{ +return gethostbyname (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_nsl_gethostbyname=yes +else $as_nop + ac_cv_lib_nsl_gethostbyname=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_nsl_gethostbyname" >&5 +printf "%s\n" "$ac_cv_lib_nsl_gethostbyname" >&6; } +if test "x$ac_cv_lib_nsl_gethostbyname" = xyes +then : + + HAVE_GETHOSTBYNAME="1" + LIBS="-lnsl $LIBS" + + +fi + + + +fi + + +if test "$HAVE_GETHOSTBYNAME" != "1"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gethostbyname in -lsocket" >&5 +printf %s "checking for gethostbyname in -lsocket... " >&6; } +if test ${ac_cv_lib_socket_gethostbyname+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lsocket $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char gethostbyname (); +int main(void) +{ +return gethostbyname (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_socket_gethostbyname=yes +else $as_nop + ac_cv_lib_socket_gethostbyname=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_socket_gethostbyname" >&5 +printf "%s\n" "$ac_cv_lib_socket_gethostbyname" >&6; } +if test "x$ac_cv_lib_socket_gethostbyname" = xyes +then : + + HAVE_GETHOSTBYNAME="1" + LIBS="-lsocket $LIBS" + + +fi + +fi + +if test "$HAVE_GETHOSTBYNAME" != "1"; then + clean_CPPFLAGS=$CPPFLAGS + clean_LDFLAGS=$LDFLAGS + CPPFLAGS="-I${WATT_ROOT}/inc" + LDFLAGS="-L${WATT_ROOT}/lib" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gethostbyname in -lwatt" >&5 +printf %s "checking for gethostbyname in -lwatt... " >&6; } +if test ${ac_cv_lib_watt_gethostbyname+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lwatt $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char gethostbyname (); +int main(void) +{ +return gethostbyname (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_watt_gethostbyname=yes +else $as_nop + ac_cv_lib_watt_gethostbyname=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_watt_gethostbyname" >&5 +printf "%s\n" "$ac_cv_lib_watt_gethostbyname" >&6; } +if test "x$ac_cv_lib_watt_gethostbyname" = xyes +then : + + HAVE_GETHOSTBYNAME="1" + LIBS="-lwatt $LIBS" + +printf "%s\n" "#define USE_WATT32 1" >>confdefs.h + + +else $as_nop + + CPPFLAGS=$clean_CPPFLAGS + LDFLAGS=$clean_LDFLAGS + + +fi + +fi + +if test "$HAVE_GETHOSTBYNAME" != "1"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gethostbyname with both nsl and socket libs" >&5 +printf %s "checking for gethostbyname with both nsl and socket libs... " >&6; } + my_ac_save_LIBS=$LIBS + LIBS="-lnsl -lsocket $LIBS" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + +int main(void) +{ + + gethostbyname(); + + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + HAVE_GETHOSTBYNAME="1" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + LIBS=$my_ac_save_LIBS + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +fi + +if test "$HAVE_GETHOSTBYNAME" != "1" || test "$curl_cv_winuwp" = "yes"; then + if test "$curl_cv_native_windows" = "yes"; then + winsock_LIB="-lws2_32" + if test "$curl_cv_winuwp" != "yes"; then + winsock_LIB="$winsock_LIB -liphlpapi" + fi + my_ac_save_LIBS=$LIBS + LIBS="$winsock_LIB $LIBS" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gethostbyname in $winsock_LIB" >&5 +printf %s "checking for gethostbyname in $winsock_LIB... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #ifdef _WIN32 + #ifndef WIN32_LEAN_AND_MEAN + #define WIN32_LEAN_AND_MEAN + #endif + #include + #endif + +int main(void) +{ + + gethostbyname("localhost"); + + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + HAVE_GETHOSTBYNAME="1" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + winsock_LIB="" + LIBS=$my_ac_save_LIBS + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + fi +fi + +if test "$HAVE_GETHOSTBYNAME" != "1"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gethostbyname for Minix 3" >&5 +printf %s "checking for gethostbyname for Minix 3... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + /* Older Minix versions may need here instead */ + #include + +int main(void) +{ + + gethostbyname("localhost"); + + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + HAVE_GETHOSTBYNAME="1" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +fi + +if test "$HAVE_GETHOSTBYNAME" != "1"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gethostbyname for eCos" >&5 +printf %s "checking for gethostbyname for eCos... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #include + #include + +int main(void) +{ + + gethostbyname("localhost"); + + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + HAVE_GETHOSTBYNAME="1" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +fi + +if test "$HAVE_GETHOSTBYNAME" != "1" || test "${with_amissl+set}" = "set"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gethostbyname for AmigaOS bsdsocket.library" >&5 +printf %s "checking for gethostbyname for AmigaOS bsdsocket.library... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #define __USE_INLINE__ + #include + #ifdef __amigaos4__ + struct SocketIFace *ISocket = NULL; + #else + struct Library *SocketBase = NULL; + #endif + +int main(void) +{ + + unsigned char host[] = "localhost"; + gethostbyname(host); + + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + HAVE_GETHOSTBYNAME="1" + HAVE_PROTO_BSDSOCKET_H="1" + +printf "%s\n" "#define HAVE_PROTO_BSDSOCKET_H 1" >>confdefs.h + + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +fi + +if test "$HAVE_GETHOSTBYNAME" != "1"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gethostbyname in -lnetwork" >&5 +printf %s "checking for gethostbyname in -lnetwork... " >&6; } +if test ${ac_cv_lib_network_gethostbyname+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lnetwork $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char gethostbyname (); +int main(void) +{ +return gethostbyname (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_network_gethostbyname=yes +else $as_nop + ac_cv_lib_network_gethostbyname=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_network_gethostbyname" >&5 +printf "%s\n" "$ac_cv_lib_network_gethostbyname" >&6; } +if test "x$ac_cv_lib_network_gethostbyname" = xyes +then : + + HAVE_GETHOSTBYNAME="1" + LIBS="-lnetwork $LIBS" + + +fi + +fi + + +curl_includes_winsock2="\ +/* includes start */ +#ifdef _WIN32 +# ifndef WIN32_LEAN_AND_MEAN +# define WIN32_LEAN_AND_MEAN +# endif +# include +#endif +/* includes end */" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether build target is a native Windows one" >&5 +printf %s "checking whether build target is a native Windows one... " >&6; } +if test ${curl_cv_native_windows+y} +then : + printf %s "(cached) " >&6 +else $as_nop + + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + +int main(void) +{ + + #ifdef _WIN32 + int dummy = 1; + (void)dummy; + #else + #error Not a native Windows build target. + #endif + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + curl_cv_native_windows="yes" + +else $as_nop + + curl_cv_native_windows="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $curl_cv_native_windows" >&5 +printf "%s\n" "$curl_cv_native_windows" >&6; } + if test "$curl_cv_native_windows" = "yes"; then + DOING_NATIVE_WINDOWS_TRUE= + DOING_NATIVE_WINDOWS_FALSE='#' +else + DOING_NATIVE_WINDOWS_TRUE='#' + DOING_NATIVE_WINDOWS_FALSE= +fi + + + + +curl_includes_bsdsocket="\ +/* includes start */ +#ifdef HAVE_PROTO_BSDSOCKET_H +# define __NO_NET_API +# define __USE_INLINE__ +# include +# ifdef HAVE_SYS_IOCTL_H +# include +# endif +# ifdef __amigaos4__ +struct SocketIFace *ISocket = NULL; +# else +struct Library *SocketBase = NULL; +# endif +# define select(a, b, c, d, e) WaitSelect(a, b, c, d, e, 0) +#endif +/* includes end */" + ac_fn_c_check_header_compile "$LINENO" "proto/bsdsocket.h" "ac_cv_header_proto_bsdsocket_h" "$curl_includes_bsdsocket +" +if test "x$ac_cv_header_proto_bsdsocket_h" = xyes +then : + printf "%s\n" "#define HAVE_PROTO_BSDSOCKET_H 1" >>confdefs.h + +fi + + + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for connect in libraries" >&5 +printf %s "checking for connect in libraries... " >&6; } + tst_connect_save_LIBS="$LIBS" + tst_connect_need_LIBS="unknown" + for tst_lib in '' '-lsocket' ; do + if test "$tst_connect_need_LIBS" = "unknown"; then + LIBS="$tst_lib $tst_connect_save_LIBS" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_winsock2 + $curl_includes_bsdsocket + #if !defined(_WIN32) && !defined(HAVE_PROTO_BSDSOCKET_H) + int connect(int, void*, int); + #endif + +int main(void) +{ + + if(0 != connect(0, 0, 0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + tst_connect_need_LIBS="$tst_lib" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + fi + done + LIBS="$tst_connect_save_LIBS" + + case X-"$tst_connect_need_LIBS" in + X-unknown) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: cannot find connect" >&5 +printf "%s\n" "cannot find connect" >&6; } + as_fn_error $? "cannot find connect function in libraries." "$LINENO" 5 + ;; + X-) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tst_connect_need_LIBS" >&5 +printf "%s\n" "$tst_connect_need_LIBS" >&6; } + LIBS="$tst_connect_need_LIBS $tst_connect_save_LIBS" + ;; + esac + + + + ac_fn_c_check_header_compile "$LINENO" "sys/types.h" "ac_cv_header_sys_types_h" "$ac_includes_default" +if test "x$ac_cv_header_sys_types_h" = xyes +then : + printf "%s\n" "#define HAVE_SYS_TYPES_H 1" >>confdefs.h + +fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for monotonic clock_gettime" >&5 +printf %s "checking for monotonic clock_gettime... " >&6; } + + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #ifdef HAVE_SYS_TYPES_H + #include + #endif + #ifndef _WIN32 + #include + #endif + #include + +int main(void) +{ + + struct timespec ts; + (void)clock_gettime(CLOCK_MONOTONIC, &ts); + (void)ts; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + curl_func_clock_gettime="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_func_clock_gettime="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + + + + + + if test "$curl_func_clock_gettime" = "yes"; then + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for clock_gettime in libraries" >&5 +printf %s "checking for clock_gettime in libraries... " >&6; } + + curl_cv_save_LIBS="$LIBS" + curl_cv_gclk_LIBS="unknown" + + for x_xlibs in '' '-lrt' '-lposix4' ; do + if test "$curl_cv_gclk_LIBS" = "unknown"; then + if test -z "$x_xlibs"; then + LIBS="$curl_cv_save_LIBS" + else + LIBS="$x_xlibs $curl_cv_save_LIBS" + fi + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #ifdef HAVE_SYS_TYPES_H + #include + #endif + #ifndef _WIN32 + #include + #endif + #include + +int main(void) +{ + + struct timespec ts; + (void)clock_gettime(CLOCK_MONOTONIC, &ts); + (void)ts; + + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + curl_cv_gclk_LIBS="$x_xlibs" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + fi + done + + LIBS="$curl_cv_save_LIBS" + + case X-"$curl_cv_gclk_LIBS" in + X-unknown) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: cannot find clock_gettime" >&5 +printf "%s\n" "cannot find clock_gettime" >&6; } + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: HAVE_CLOCK_GETTIME_MONOTONIC is not defined" >&5 +printf "%s\n" "$as_me: WARNING: HAVE_CLOCK_GETTIME_MONOTONIC is not defined" >&2;} + curl_func_clock_gettime="no" + ;; + X-) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no additional lib required" >&5 +printf "%s\n" "no additional lib required" >&6; } + curl_func_clock_gettime="yes" + ;; + *) + if test "$dontwant_rt" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: needs -lrt but asked not to use it, HAVE_CLOCK_GETTIME_MONOTONIC is not defined" >&5 +printf "%s\n" "$as_me: WARNING: needs -lrt but asked not to use it, HAVE_CLOCK_GETTIME_MONOTONIC is not defined" >&2;} + curl_func_clock_gettime="no" + else + if test -z "$curl_cv_save_LIBS"; then + LIBS="$curl_cv_gclk_LIBS" + else + LIBS="$curl_cv_gclk_LIBS $curl_cv_save_LIBS" + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $curl_cv_gclk_LIBS" >&5 +printf "%s\n" "$curl_cv_gclk_LIBS" >&6; } + curl_func_clock_gettime="yes" + fi + ;; + esac + + if test "$cross_compiling" != "yes" && + test "$curl_func_clock_gettime" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if monotonic clock_gettime works" >&5 +printf %s "checking if monotonic clock_gettime works... " >&6; } + + if test "$curl_cv_apple" = "yes"; then + if test "$cross_compiling" = yes +then : + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #include + #ifdef HAVE_SYS_TYPES_H + #include + #endif + #ifndef _WIN32 + #include + #endif + #include + +int main(void) +{ + + struct timespec ts; + if(0 == clock_gettime(CLOCK_MONOTONIC, &ts)) + return 0; + (void)ts; + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_run "$LINENO" +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: HAVE_CLOCK_GETTIME_MONOTONIC is not defined" >&5 +printf "%s\n" "$as_me: WARNING: HAVE_CLOCK_GETTIME_MONOTONIC is not defined" >&2;} + curl_func_clock_gettime="no" + LIBS="$curl_cv_save_LIBS" + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + else + oldcc=$CC + old=$LD_LIBRARY_PATH + CC="sh ./run-compiler" + LD_LIBRARY_PATH=$CURL_LIBRARY_PATH:$old + export LD_LIBRARY_PATH + if test "$cross_compiling" = yes +then : + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #include + #ifdef HAVE_SYS_TYPES_H + #include + #endif + #ifndef _WIN32 + #include + #endif + #include + +int main(void) +{ + + struct timespec ts; + if(0 == clock_gettime(CLOCK_MONOTONIC, &ts)) + return 0; + (void)ts; + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_run "$LINENO" +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: HAVE_CLOCK_GETTIME_MONOTONIC is not defined" >&5 +printf "%s\n" "$as_me: WARNING: HAVE_CLOCK_GETTIME_MONOTONIC is not defined" >&2;} + curl_func_clock_gettime="no" + LIBS="$curl_cv_save_LIBS" + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + # restore + LD_LIBRARY_PATH=$old + CC=$oldcc + fi + + fi + + case "$curl_func_clock_gettime" in + yes) + +printf "%s\n" "#define HAVE_CLOCK_GETTIME_MONOTONIC 1" >>confdefs.h + + ;; + esac + fi + + + + ac_fn_c_check_header_compile "$LINENO" "sys/types.h" "ac_cv_header_sys_types_h" "$ac_includes_default" +if test "x$ac_cv_header_sys_types_h" = xyes +then : + printf "%s\n" "#define HAVE_SYS_TYPES_H 1" >>confdefs.h + +fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for raw monotonic clock_gettime" >&5 +printf %s "checking for raw monotonic clock_gettime... " >&6; } + + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #ifdef HAVE_SYS_TYPES_H + #include + #endif + #ifndef _WIN32 + #include + #endif + #include + +int main(void) +{ + + struct timespec ts; + (void)clock_gettime(CLOCK_MONOTONIC_RAW, &ts); + (void)ts; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_CLOCK_GETTIME_MONOTONIC_RAW 1" >>confdefs.h + + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + + +CURL_NETWORK_AND_TIME_LIBS=$LIBS + + + +clean_CPPFLAGS=$CPPFLAGS +clean_LDFLAGS=$LDFLAGS +clean_LIBS=$LIBS +ZLIB_LIBS="" + +# Check whether --with-zlib was given. +if test ${with_zlib+y} +then : + withval=$with_zlib; OPT_ZLIB="$withval" +fi + + +if test "x$OPT_ZLIB" = "xno"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: zlib disabled" >&5 +printf "%s\n" "$as_me: WARNING: zlib disabled" >&2;} +else + if test "x$OPT_ZLIB" = "xyes"; then + OPT_ZLIB="" + fi + + if test -z "$OPT_ZLIB"; then + + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. +set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKGCONFIG="$PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PKGCONFIG=$ac_cv_path_PKGCONFIG +if test -n "$PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PKGCONFIG" >&5 +printf "%s\n" "$PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_PKGCONFIG"; then + ac_pt_PKGCONFIG=$PKGCONFIG + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_PKGCONFIG="$ac_pt_PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_PKGCONFIG=$ac_cv_path_ac_pt_PKGCONFIG +if test -n "$ac_pt_PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKGCONFIG" >&5 +printf "%s\n" "$ac_pt_PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_PKGCONFIG" = x; then + PKGCONFIG="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + PKGCONFIG=$ac_pt_PKGCONFIG + fi +else + PKGCONFIG="$ac_cv_path_PKGCONFIG" +fi + + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for zlib options with pkg-config" >&5 +printf %s "checking for zlib options with pkg-config... " >&6; } + itexists=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists zlib >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + + trc=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug zlib 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors zlib 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists zlib trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists zlib trace: +---- begin +${trc} +---- end" >&6;} + + fi + PKGCONFIG="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found" >&5 +printf "%s\n" "found" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG"; then + + trc=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug zlib 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors zlib 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists zlib trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists zlib trace: +---- begin +${trc} +---- end" >&6;} + + fi + fi + fi + + + if test "$PKGCONFIG" != "no"; then + ZLIB_LIBS="`$PKGCONFIG --libs-only-l zlib`" + if test -n "$ZLIB_LIBS"; then + LDFLAGS="$LDFLAGS `$PKGCONFIG --libs-only-L zlib`" + else + ZLIB_LIBS="`$PKGCONFIG --libs zlib`" + fi + LIBS="$ZLIB_LIBS $LIBS" + CPPFLAGS="$CPPFLAGS `$PKGCONFIG --cflags zlib`" + OPT_ZLIB="" + HAVE_LIBZ="1" + fi + + if test -z "$HAVE_LIBZ"; then + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for inflateEnd in -lz" >&5 +printf %s "checking for inflateEnd in -lz... " >&6; } +if test ${ac_cv_lib_z_inflateEnd+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lz $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char inflateEnd (); +int main(void) +{ +return inflateEnd (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_z_inflateEnd=yes +else $as_nop + ac_cv_lib_z_inflateEnd=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_z_inflateEnd" >&5 +printf "%s\n" "$ac_cv_lib_z_inflateEnd" >&6; } +if test "x$ac_cv_lib_z_inflateEnd" = xyes +then : + + HAVE_LIBZ="1" + ZLIB_LIBS="-lz" + LIBS="$ZLIB_LIBS $LIBS" + +else $as_nop + + OPT_ZLIB="/usr/local" + + +fi + + fi + fi + + if test -n "$OPT_ZLIB"; then + CPPFLAGS="$CPPFLAGS -I$OPT_ZLIB/include" + LDFLAGS="$LDFLAGS -L$OPT_ZLIB/lib$libsuff" + fi + + ac_fn_c_check_header_compile "$LINENO" "zlib.h" "ac_cv_header_zlib_h" "$ac_includes_default" +if test "x$ac_cv_header_zlib_h" = xyes +then : + + HAVE_ZLIB_H="1" + if test "$HAVE_LIBZ" != "1"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gzread in -lz" >&5 +printf %s "checking for gzread in -lz... " >&6; } +if test ${ac_cv_lib_z_gzread+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lz $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char gzread (); +int main(void) +{ +return gzread (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_z_gzread=yes +else $as_nop + ac_cv_lib_z_gzread=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_z_gzread" >&5 +printf "%s\n" "$ac_cv_lib_z_gzread" >&6; } +if test "x$ac_cv_lib_z_gzread" = xyes +then : + + HAVE_LIBZ="1" + ZLIB_LIBS="-lz" + LIBS="$ZLIB_LIBS $LIBS" + +else $as_nop + + CPPFLAGS=$clean_CPPFLAGS + LDFLAGS=$clean_LDFLAGS + + +fi + + fi + +else $as_nop + + CPPFLAGS=$clean_CPPFLAGS + LDFLAGS=$clean_LDFLAGS + +fi + + + if test "$HAVE_LIBZ" = "1" && test "$HAVE_ZLIB_H" != "1"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: configure found only the libz lib, not the header file!" >&5 +printf "%s\n" "$as_me: WARNING: configure found only the libz lib, not the header file!" >&2;} + HAVE_LIBZ="" + CPPFLAGS=$clean_CPPFLAGS + LDFLAGS=$clean_LDFLAGS + LIBS=$clean_LIBS + ZLIB_LIBS="" + elif test "$HAVE_LIBZ" != "1" && test "$HAVE_ZLIB_H" = "1"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: configure found only the libz header file, not the lib!" >&5 +printf "%s\n" "$as_me: WARNING: configure found only the libz header file, not the lib!" >&2;} + CPPFLAGS=$clean_CPPFLAGS + LDFLAGS=$clean_LDFLAGS + LIBS=$clean_LIBS + ZLIB_LIBS="" + elif test "$HAVE_LIBZ" = "1" && test "$HAVE_ZLIB_H" = "1"; then + + +printf "%s\n" "#define HAVE_LIBZ 1" >>confdefs.h + + LIBS="$ZLIB_LIBS $clean_LIBS" + + AMFIXLIB="1" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: found both libz and libz.h header" >&5 +printf "%s\n" "$as_me: found both libz and libz.h header" >&6;} + if test "$curl_cv_android" = "no"; then + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE zlib" + fi + curl_zlib_msg="enabled" + fi +fi + + if test "$AMFIXLIB" = "1"; then + HAVE_LIBZ_TRUE= + HAVE_LIBZ_FALSE='#' +else + HAVE_LIBZ_TRUE='#' + HAVE_LIBZ_FALSE= +fi + + + + + +OPT_BROTLI=off + +# Check whether --with-brotli was given. +if test ${with_brotli+y} +then : + withval=$with_brotli; OPT_BROTLI=$withval +fi + + +if test "x$OPT_BROTLI" != "xno"; then + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + case "$OPT_BROTLI" in + yes) + + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. +set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKGCONFIG="$PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PKGCONFIG=$ac_cv_path_PKGCONFIG +if test -n "$PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PKGCONFIG" >&5 +printf "%s\n" "$PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_PKGCONFIG"; then + ac_pt_PKGCONFIG=$PKGCONFIG + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_PKGCONFIG="$ac_pt_PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_PKGCONFIG=$ac_cv_path_ac_pt_PKGCONFIG +if test -n "$ac_pt_PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKGCONFIG" >&5 +printf "%s\n" "$ac_pt_PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_PKGCONFIG" = x; then + PKGCONFIG="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + PKGCONFIG=$ac_pt_PKGCONFIG + fi +else + PKGCONFIG="$ac_cv_path_PKGCONFIG" +fi + + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for libbrotlidec options with pkg-config" >&5 +printf %s "checking for libbrotlidec options with pkg-config... " >&6; } + itexists=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists libbrotlidec >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + + trc=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libbrotlidec 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libbrotlidec 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libbrotlidec trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libbrotlidec trace: +---- begin +${trc} +---- end" >&6;} + + fi + PKGCONFIG="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found" >&5 +printf "%s\n" "found" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG"; then + + trc=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libbrotlidec 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libbrotlidec 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libbrotlidec trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libbrotlidec trace: +---- begin +${trc} +---- end" >&6;} + + fi + fi + fi + + + if test "$PKGCONFIG" != "no"; then + LIB_BROTLI=`$PKGCONFIG --libs-only-l libbrotlidec` + LD_BROTLI=`$PKGCONFIG --libs-only-L libbrotlidec` + CPP_BROTLI=`$PKGCONFIG --cflags-only-I libbrotlidec` + version=`$PKGCONFIG --modversion libbrotlidec` + fi + + + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. +set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKGCONFIG="$PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PKGCONFIG=$ac_cv_path_PKGCONFIG +if test -n "$PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PKGCONFIG" >&5 +printf "%s\n" "$PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_PKGCONFIG"; then + ac_pt_PKGCONFIG=$PKGCONFIG + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_PKGCONFIG="$ac_pt_PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_PKGCONFIG=$ac_cv_path_ac_pt_PKGCONFIG +if test -n "$ac_pt_PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKGCONFIG" >&5 +printf "%s\n" "$ac_pt_PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_PKGCONFIG" = x; then + PKGCONFIG="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + PKGCONFIG=$ac_pt_PKGCONFIG + fi +else + PKGCONFIG="$ac_cv_path_PKGCONFIG" +fi + + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for libbrotlicommon options with pkg-config" >&5 +printf %s "checking for libbrotlicommon options with pkg-config... " >&6; } + itexists=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists libbrotlicommon >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + + trc=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libbrotlicommon 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libbrotlicommon 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libbrotlicommon trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libbrotlicommon trace: +---- begin +${trc} +---- end" >&6;} + + fi + PKGCONFIG="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found" >&5 +printf "%s\n" "found" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG"; then + + trc=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libbrotlicommon 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libbrotlicommon 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libbrotlicommon trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libbrotlicommon trace: +---- begin +${trc} +---- end" >&6;} + + fi + fi + fi + + + if test "$PKGCONFIG" != "no"; then + LIB_BROTLI="$LIB_BROTLI `$PKGCONFIG --libs-only-l libbrotlicommon`" + LD_BROTLI="$LD_BROTLI `$PKGCONFIG --libs-only-L libbrotlicommon`" + CPP_BROTLI="$CPP_BROTLI `$PKGCONFIG --cflags-only-I libbrotlicommon`" + fi + + DIR_BROTLI=`echo $LD_BROTLI | $SED -e 's/^-L//'` + ;; + off) + ;; + *) + PREFIX_BROTLI=$OPT_BROTLI + ;; + esac + + if test -n "$PREFIX_BROTLI"; then + LIB_BROTLI="-lbrotlidec -lbrotlicommon" + LD_BROTLI=-L${PREFIX_BROTLI}/lib$libsuff + CPP_BROTLI=-I${PREFIX_BROTLI}/include + DIR_BROTLI=${PREFIX_BROTLI}/lib$libsuff + fi + + LDFLAGS="$LDFLAGS $LD_BROTLI" + LDFLAGSPC="$LDFLAGSPC $LD_BROTLI" + CPPFLAGS="$CPPFLAGS $CPP_BROTLI" + LIBS="$LIB_BROTLI $LIBS" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for BrotliDecoderDecompress in -lbrotlidec" >&5 +printf %s "checking for BrotliDecoderDecompress in -lbrotlidec... " >&6; } +if test ${ac_cv_lib_brotlidec_BrotliDecoderDecompress+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lbrotlidec $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char BrotliDecoderDecompress (); +int main(void) +{ +return BrotliDecoderDecompress (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_brotlidec_BrotliDecoderDecompress=yes +else $as_nop + ac_cv_lib_brotlidec_BrotliDecoderDecompress=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_brotlidec_BrotliDecoderDecompress" >&5 +printf "%s\n" "$ac_cv_lib_brotlidec_BrotliDecoderDecompress" >&6; } +if test "x$ac_cv_lib_brotlidec_BrotliDecoderDecompress" = xyes +then : + printf "%s\n" "#define HAVE_LIBBROTLIDEC 1" >>confdefs.h + + LIBS="-lbrotlidec $LIBS" + +fi + + + for ac_header in brotli/decode.h +do : + ac_fn_c_check_header_compile "$LINENO" "brotli/decode.h" "ac_cv_header_brotli_decode_h" "$ac_includes_default" +if test "x$ac_cv_header_brotli_decode_h" = xyes +then : + printf "%s\n" "#define HAVE_BROTLI_DECODE_H 1" >>confdefs.h + curl_brotli_msg="enabled (libbrotlidec)" + HAVE_BROTLI=1 + +printf "%s\n" "#define HAVE_BROTLI 1" >>confdefs.h + + +fi + +done + + if test "x$OPT_BROTLI" != "xoff" && + test "$HAVE_BROTLI" != "1"; then + as_fn_error $? "BROTLI libs and/or directories were not found where specified!" "$LINENO" 5 + fi + + if test "$HAVE_BROTLI" = "1"; then + if test -n "$DIR_BROTLI"; then + + if test "$cross_compiling" != "yes"; then + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$DIR_BROTLI" + export CURL_LIBRARY_PATH + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: Added $DIR_BROTLI to CURL_LIBRARY_PATH" >&5 +printf "%s\n" "$as_me: Added $DIR_BROTLI to CURL_LIBRARY_PATH" >&6;} + fi + fi + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libbrotlidec libbrotlicommon" + else + LDFLAGS=$CLEANLDFLAGS + LDFLAGSPC=$CLEANLDFLAGSPC + CPPFLAGS=$CLEANCPPFLAGS + LIBS=$CLEANLIBS + fi +fi + + +OPT_ZSTD=off + +# Check whether --with-zstd was given. +if test ${with_zstd+y} +then : + withval=$with_zstd; OPT_ZSTD=$withval +fi + + +if test "x$OPT_ZSTD" != "xno"; then + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + case "$OPT_ZSTD" in + yes) + + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. +set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKGCONFIG="$PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PKGCONFIG=$ac_cv_path_PKGCONFIG +if test -n "$PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PKGCONFIG" >&5 +printf "%s\n" "$PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_PKGCONFIG"; then + ac_pt_PKGCONFIG=$PKGCONFIG + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_PKGCONFIG="$ac_pt_PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_PKGCONFIG=$ac_cv_path_ac_pt_PKGCONFIG +if test -n "$ac_pt_PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKGCONFIG" >&5 +printf "%s\n" "$ac_pt_PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_PKGCONFIG" = x; then + PKGCONFIG="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + PKGCONFIG=$ac_pt_PKGCONFIG + fi +else + PKGCONFIG="$ac_cv_path_PKGCONFIG" +fi + + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for libzstd options with pkg-config" >&5 +printf %s "checking for libzstd options with pkg-config... " >&6; } + itexists=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists libzstd >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + + trc=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libzstd 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libzstd 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libzstd trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libzstd trace: +---- begin +${trc} +---- end" >&6;} + + fi + PKGCONFIG="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found" >&5 +printf "%s\n" "found" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG"; then + + trc=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libzstd 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libzstd 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libzstd trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libzstd trace: +---- begin +${trc} +---- end" >&6;} + + fi + fi + fi + + + if test "$PKGCONFIG" != "no"; then + LIB_ZSTD=`$PKGCONFIG --libs-only-l libzstd` + LD_ZSTD=`$PKGCONFIG --libs-only-L libzstd` + CPP_ZSTD=`$PKGCONFIG --cflags-only-I libzstd` + version=`$PKGCONFIG --modversion libzstd` + DIR_ZSTD=`echo $LD_ZSTD | $SED -e 's/-L//'` + fi + + ;; + off) + ;; + *) + PREFIX_ZSTD=$OPT_ZSTD + ;; + esac + + if test -n "$PREFIX_ZSTD"; then + LIB_ZSTD="-lzstd" + LD_ZSTD=-L${PREFIX_ZSTD}/lib$libsuff + CPP_ZSTD=-I${PREFIX_ZSTD}/include + DIR_ZSTD=${PREFIX_ZSTD}/lib$libsuff + fi + + LDFLAGS="$LDFLAGS $LD_ZSTD" + LDFLAGSPC="$LDFLAGSPC $LD_ZSTD" + CPPFLAGS="$CPPFLAGS $CPP_ZSTD" + LIBS="$LIB_ZSTD $LIBS" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for ZSTD_createDStream in -lzstd" >&5 +printf %s "checking for ZSTD_createDStream in -lzstd... " >&6; } +if test ${ac_cv_lib_zstd_ZSTD_createDStream+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lzstd $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char ZSTD_createDStream (); +int main(void) +{ +return ZSTD_createDStream (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_zstd_ZSTD_createDStream=yes +else $as_nop + ac_cv_lib_zstd_ZSTD_createDStream=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_zstd_ZSTD_createDStream" >&5 +printf "%s\n" "$ac_cv_lib_zstd_ZSTD_createDStream" >&6; } +if test "x$ac_cv_lib_zstd_ZSTD_createDStream" = xyes +then : + printf "%s\n" "#define HAVE_LIBZSTD 1" >>confdefs.h + + LIBS="-lzstd $LIBS" + +fi + + + for ac_header in zstd.h +do : + ac_fn_c_check_header_compile "$LINENO" "zstd.h" "ac_cv_header_zstd_h" "$ac_includes_default" +if test "x$ac_cv_header_zstd_h" = xyes +then : + printf "%s\n" "#define HAVE_ZSTD_H 1" >>confdefs.h + curl_zstd_msg="enabled (libzstd)" + HAVE_ZSTD=1 + +printf "%s\n" "#define HAVE_ZSTD 1" >>confdefs.h + + +fi + +done + + if test "x$OPT_ZSTD" != "xoff" && + test "$HAVE_ZSTD" != "1"; then + as_fn_error $? "libzstd was not found where specified!" "$LINENO" 5 + fi + + if test "$HAVE_ZSTD" = "1"; then + if test -n "$DIR_ZSTD"; then + + if test "$cross_compiling" != "yes"; then + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$DIR_ZSTD" + export CURL_LIBRARY_PATH + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: Added $DIR_ZSTD to CURL_LIBRARY_PATH" >&5 +printf "%s\n" "$as_me: Added $DIR_ZSTD to CURL_LIBRARY_PATH" >&6;} + fi + fi + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libzstd" + else + LDFLAGS=$CLEANLDFLAGS + LDFLAGSPC=$CLEANLDFLAGSPC + CPPFLAGS=$CLEANCPPFLAGS + LIBS=$CLEANLIBS + fi +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable IPv6" >&5 +printf %s "checking whether to enable IPv6... " >&6; } +# Check whether --enable-ipv6 was given. +if test ${enable_ipv6+y} +then : + enableval=$enable_ipv6; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + ipv6=no + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ipv6=yes + ;; + esac +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + /* are AF_INET6 and sockaddr_in6 available? */ + #include + #ifdef _WIN32 + #include + #include + #else + #include + #include + #ifdef __TANDEM + #include + #endif + #endif + int main(void) + { + int s = (int)sizeof(struct sockaddr_in6); + (void)s; + return socket(AF_INET6, SOCK_STREAM, 0) > 0; + } + + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ipv6=yes +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + ipv6=no + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + +fi + + +if test "$ipv6" = "yes"; then + curl_ipv6_msg="enabled" + +printf "%s\n" "#define USE_IPV6 1" >>confdefs.h + + IPV6_ENABLED=1 + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if struct sockaddr_in6 has sin6_scope_id member" >&5 +printf %s "checking if struct sockaddr_in6 has sin6_scope_id member... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #include + #ifdef _WIN32 + #include + #include + #else + #include + #ifdef __TANDEM + #include + #endif + #endif + +int main(void) +{ + + struct sockaddr_in6 s; + s.sin6_scope_id = 0; + (void)s; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_SOCKADDR_IN6_SIN6_SCOPE_ID 1" >>confdefs.h + + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if argv can be written to" >&5 +printf %s "checking if argv can be written to... " >&6; } + + if test "$curl_cv_apple" = "yes"; then + if test "$cross_compiling" = yes +then : + curl_cv_writable_argv=cross + +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int main(int argc, char **argv) +{ +#ifdef _WIN32 + /* on Windows, writing to the argv does not hide the argument in + process lists so it can be skipped */ + (void)argc; + (void)argv; + return 1; +#else + (void)argc; + argv[0][0] = ' '; + return (argv[0][0] == ' ') ? 0 : 1; +#endif +} + +_ACEOF +if ac_fn_c_try_run "$LINENO" +then : + curl_cv_writable_argv=yes + +else $as_nop + curl_cv_writable_argv=no + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + else + oldcc=$CC + old=$LD_LIBRARY_PATH + CC="sh ./run-compiler" + LD_LIBRARY_PATH=$CURL_LIBRARY_PATH:$old + export LD_LIBRARY_PATH + if test "$cross_compiling" = yes +then : + curl_cv_writable_argv=cross + +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int main(int argc, char **argv) +{ +#ifdef _WIN32 + /* on Windows, writing to the argv does not hide the argument in + process lists so it can be skipped */ + (void)argc; + (void)argv; + return 1; +#else + (void)argc; + argv[0][0] = ' '; + return (argv[0][0] == ' ') ? 0 : 1; +#endif +} + +_ACEOF +if ac_fn_c_try_run "$LINENO" +then : + curl_cv_writable_argv=yes + +else $as_nop + curl_cv_writable_argv=no + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + # restore + LD_LIBRARY_PATH=$old + CC=$oldcc + fi + +if test "$curl_cv_writable_argv" = "cross" && test "$curl_cv_apple" = "yes"; then + curl_cv_writable_argv=yes +fi +case $curl_cv_writable_argv in + yes) + +printf "%s\n" "#define HAVE_WRITABLE_ARGV 1" >>confdefs.h + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: the previous check could not be made default was used" >&5 +printf "%s\n" "$as_me: WARNING: the previous check could not be made default was used" >&2;} + ;; +esac + + + +GSSAPI_ROOT="/usr" + +# Check whether --with-gssapi-includes was given. +if test ${with_gssapi_includes+y} +then : + withval=$with_gssapi_includes; + GSSAPI_INCS="-I$withval" + want_gss="yes" + + +fi + + + +# Check whether --with-gssapi-libs was given. +if test ${with_gssapi_libs+y} +then : + withval=$with_gssapi_libs; + GSSAPI_LIB_DIR="-L$withval" + want_gss="yes" + + +fi + + + +# Check whether --with-gssapi was given. +if test ${with_gssapi+y} +then : + withval=$with_gssapi; + GSSAPI_ROOT="$withval" + if test "$GSSAPI_ROOT" != "no"; then + want_gss="yes" + if test "$GSSAPI_ROOT" = "yes"; then + GSSAPI_ROOT="/usr" + fi + fi + + +fi + + +: ${KRB5CONFIG:="$GSSAPI_ROOT/bin/krb5-config"} + +save_CPPFLAGS="$CPPFLAGS" +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if GSS-API support is requested" >&5 +printf %s "checking if GSS-API support is requested... " >&6; } +if test "$want_gss" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + + if test "$GSSAPI_ROOT" != "/usr"; then + + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. +set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKGCONFIG="$PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PKGCONFIG=$ac_cv_path_PKGCONFIG +if test -n "$PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PKGCONFIG" >&5 +printf "%s\n" "$PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_PKGCONFIG"; then + ac_pt_PKGCONFIG=$PKGCONFIG + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_PKGCONFIG="$ac_pt_PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_PKGCONFIG=$ac_cv_path_ac_pt_PKGCONFIG +if test -n "$ac_pt_PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKGCONFIG" >&5 +printf "%s\n" "$ac_pt_PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_PKGCONFIG" = x; then + PKGCONFIG="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + PKGCONFIG=$ac_pt_PKGCONFIG + fi +else + PKGCONFIG="$ac_cv_path_PKGCONFIG" +fi + + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for mit-krb5-gssapi options with pkg-config" >&5 +printf %s "checking for mit-krb5-gssapi options with pkg-config... " >&6; } + itexists=` + if test -n "$GSSAPI_ROOT/lib/pkgconfig"; then + if test -n ""; then + PKG_CONFIG_PATH="$GSSAPI_ROOT/lib/pkgconfig${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$GSSAPI_ROOT/lib/pkgconfig" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists mit-krb5-gssapi >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + + trc=` + if test -n "$GSSAPI_ROOT/lib/pkgconfig"; then + if test -n ""; then + PKG_CONFIG_PATH="$GSSAPI_ROOT/lib/pkgconfig${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$GSSAPI_ROOT/lib/pkgconfig" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug mit-krb5-gssapi 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$GSSAPI_ROOT/lib/pkgconfig"; then + if test -n ""; then + PKG_CONFIG_PATH="$GSSAPI_ROOT/lib/pkgconfig${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$GSSAPI_ROOT/lib/pkgconfig" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors mit-krb5-gssapi 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists mit-krb5-gssapi trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists mit-krb5-gssapi trace: +---- begin +${trc} +---- end" >&6;} + + fi + PKGCONFIG="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found" >&5 +printf "%s\n" "found" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG"; then + + trc=` + if test -n "$GSSAPI_ROOT/lib/pkgconfig"; then + if test -n ""; then + PKG_CONFIG_PATH="$GSSAPI_ROOT/lib/pkgconfig${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$GSSAPI_ROOT/lib/pkgconfig" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug mit-krb5-gssapi 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$GSSAPI_ROOT/lib/pkgconfig"; then + if test -n ""; then + PKG_CONFIG_PATH="$GSSAPI_ROOT/lib/pkgconfig${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$GSSAPI_ROOT/lib/pkgconfig" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors mit-krb5-gssapi 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists mit-krb5-gssapi trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists mit-krb5-gssapi trace: +---- begin +${trc} +---- end" >&6;} + + fi + fi + fi + + else + + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. +set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKGCONFIG="$PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PKGCONFIG=$ac_cv_path_PKGCONFIG +if test -n "$PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PKGCONFIG" >&5 +printf "%s\n" "$PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_PKGCONFIG"; then + ac_pt_PKGCONFIG=$PKGCONFIG + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_PKGCONFIG="$ac_pt_PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_PKGCONFIG=$ac_cv_path_ac_pt_PKGCONFIG +if test -n "$ac_pt_PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKGCONFIG" >&5 +printf "%s\n" "$ac_pt_PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_PKGCONFIG" = x; then + PKGCONFIG="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + PKGCONFIG=$ac_pt_PKGCONFIG + fi +else + PKGCONFIG="$ac_cv_path_PKGCONFIG" +fi + + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for mit-krb5-gssapi options with pkg-config" >&5 +printf %s "checking for mit-krb5-gssapi options with pkg-config... " >&6; } + itexists=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists mit-krb5-gssapi >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + + trc=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug mit-krb5-gssapi 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors mit-krb5-gssapi 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists mit-krb5-gssapi trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists mit-krb5-gssapi trace: +---- begin +${trc} +---- end" >&6;} + + fi + PKGCONFIG="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found" >&5 +printf "%s\n" "found" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG"; then + + trc=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug mit-krb5-gssapi 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors mit-krb5-gssapi 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists mit-krb5-gssapi trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists mit-krb5-gssapi trace: +---- begin +${trc} +---- end" >&6;} + + fi + fi + fi + + fi + if test -z "$GSSAPI_INCS"; then + if test -n "$host_alias" && test -f "$GSSAPI_ROOT/bin/$host_alias-krb5-config"; then + GSSAPI_INCS=`$GSSAPI_ROOT/bin/$host_alias-krb5-config --cflags gssapi` + elif test "$PKGCONFIG" != "no"; then + GSSAPI_INCS=`$PKGCONFIG --cflags mit-krb5-gssapi` + elif test -f "$KRB5CONFIG"; then + GSSAPI_INCS=`$KRB5CONFIG --cflags gssapi` + elif test "$GSSAPI_ROOT" != "yes"; then + GSSAPI_INCS="-I$GSSAPI_ROOT/include" + fi + fi + + CPPFLAGS="$CPPFLAGS $GSSAPI_INCS" + + ac_fn_c_check_header_compile "$LINENO" "gss.h" "ac_cv_header_gss_h" "$ac_includes_default" +if test "x$ac_cv_header_gss_h" = xyes +then : + + +printf "%s\n" "#define HAVE_GSSGNU 1" >>confdefs.h + + gnu_gss=yes + +else $as_nop + + for ac_header in gssapi/gssapi.h gssapi/gssapi_generic.h gssapi/gssapi_krb5.h +do : + as_ac_Header=`printf "%s\n" "ac_cv_header_$ac_header" | $as_tr_sh` +ac_fn_c_check_header_compile "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" +if eval test \"x\$"$as_ac_Header"\" = x"yes" +then : + cat >>confdefs.h <<_ACEOF +#define `printf "%s\n" "HAVE_$ac_header" | $as_tr_cpp` 1 +_ACEOF + +else $as_nop + not_mit=1 +fi + +done + if test "$not_mit" = "1"; then + as_fn_error $? "MIT or GNU GSS library required, but not found" "$LINENO" 5 + fi + + +fi + +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi +if test "$want_gss" = "yes"; then + +printf "%s\n" "#define HAVE_GSSAPI 1" >>confdefs.h + + HAVE_GSSAPI=1 + curl_gss_msg="enabled (MIT Kerberos)" + link_pkgconfig='' + + if test -n "$gnu_gss"; then + curl_gss_msg="enabled (GNU GSS)" + LDFLAGS="$LDFLAGS $GSSAPI_LIB_DIR" + LDFLAGSPC="$LDFLAGSPC $GSSAPI_LIB_DIR" + LIBS="-lgss $LIBS" + link_pkgconfig=1 + elif test -z "$GSSAPI_LIB_DIR"; then + if test "$curl_cv_apple" = "yes"; then + LIBS="-lgssapi_krb5 -lresolv $LIBS" + else + if test "$GSSAPI_ROOT" != "/usr"; then + + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. +set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKGCONFIG="$PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PKGCONFIG=$ac_cv_path_PKGCONFIG +if test -n "$PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PKGCONFIG" >&5 +printf "%s\n" "$PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_PKGCONFIG"; then + ac_pt_PKGCONFIG=$PKGCONFIG + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_PKGCONFIG="$ac_pt_PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_PKGCONFIG=$ac_cv_path_ac_pt_PKGCONFIG +if test -n "$ac_pt_PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKGCONFIG" >&5 +printf "%s\n" "$ac_pt_PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_PKGCONFIG" = x; then + PKGCONFIG="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + PKGCONFIG=$ac_pt_PKGCONFIG + fi +else + PKGCONFIG="$ac_cv_path_PKGCONFIG" +fi + + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for mit-krb5-gssapi options with pkg-config" >&5 +printf %s "checking for mit-krb5-gssapi options with pkg-config... " >&6; } + itexists=` + if test -n "$GSSAPI_ROOT/lib/pkgconfig"; then + if test -n ""; then + PKG_CONFIG_PATH="$GSSAPI_ROOT/lib/pkgconfig${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$GSSAPI_ROOT/lib/pkgconfig" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists mit-krb5-gssapi >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + + trc=` + if test -n "$GSSAPI_ROOT/lib/pkgconfig"; then + if test -n ""; then + PKG_CONFIG_PATH="$GSSAPI_ROOT/lib/pkgconfig${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$GSSAPI_ROOT/lib/pkgconfig" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug mit-krb5-gssapi 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$GSSAPI_ROOT/lib/pkgconfig"; then + if test -n ""; then + PKG_CONFIG_PATH="$GSSAPI_ROOT/lib/pkgconfig${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$GSSAPI_ROOT/lib/pkgconfig" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors mit-krb5-gssapi 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists mit-krb5-gssapi trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists mit-krb5-gssapi trace: +---- begin +${trc} +---- end" >&6;} + + fi + PKGCONFIG="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found" >&5 +printf "%s\n" "found" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG"; then + + trc=` + if test -n "$GSSAPI_ROOT/lib/pkgconfig"; then + if test -n ""; then + PKG_CONFIG_PATH="$GSSAPI_ROOT/lib/pkgconfig${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$GSSAPI_ROOT/lib/pkgconfig" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug mit-krb5-gssapi 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$GSSAPI_ROOT/lib/pkgconfig"; then + if test -n ""; then + PKG_CONFIG_PATH="$GSSAPI_ROOT/lib/pkgconfig${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$GSSAPI_ROOT/lib/pkgconfig" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors mit-krb5-gssapi 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists mit-krb5-gssapi trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists mit-krb5-gssapi trace: +---- begin +${trc} +---- end" >&6;} + + fi + fi + fi + + else + + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. +set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKGCONFIG="$PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PKGCONFIG=$ac_cv_path_PKGCONFIG +if test -n "$PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PKGCONFIG" >&5 +printf "%s\n" "$PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_PKGCONFIG"; then + ac_pt_PKGCONFIG=$PKGCONFIG + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_PKGCONFIG="$ac_pt_PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_PKGCONFIG=$ac_cv_path_ac_pt_PKGCONFIG +if test -n "$ac_pt_PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKGCONFIG" >&5 +printf "%s\n" "$ac_pt_PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_PKGCONFIG" = x; then + PKGCONFIG="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + PKGCONFIG=$ac_pt_PKGCONFIG + fi +else + PKGCONFIG="$ac_cv_path_PKGCONFIG" +fi + + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for mit-krb5-gssapi options with pkg-config" >&5 +printf %s "checking for mit-krb5-gssapi options with pkg-config... " >&6; } + itexists=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists mit-krb5-gssapi >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + + trc=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug mit-krb5-gssapi 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors mit-krb5-gssapi 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists mit-krb5-gssapi trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists mit-krb5-gssapi trace: +---- begin +${trc} +---- end" >&6;} + + fi + PKGCONFIG="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found" >&5 +printf "%s\n" "found" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG"; then + + trc=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug mit-krb5-gssapi 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors mit-krb5-gssapi 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists mit-krb5-gssapi trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists mit-krb5-gssapi trace: +---- begin +${trc} +---- end" >&6;} + + fi + fi + fi + + fi + if test -n "$host_alias" && test -f "$GSSAPI_ROOT/bin/$host_alias-krb5-config"; then + gss_libs=`$GSSAPI_ROOT/bin/$host_alias-krb5-config --libs gssapi` + LIBS="$gss_libs $LIBS" + elif test "$PKGCONFIG" != "no"; then + gss_libs=`$PKGCONFIG --libs mit-krb5-gssapi` + LIBS="$gss_libs $LIBS" + link_pkgconfig=1 + elif test -f "$KRB5CONFIG"; then + gss_libs=`$KRB5CONFIG --libs gssapi` + LIBS="$gss_libs $LIBS" + link_pkgconfig=1 + else + case $host in + *-hp-hpux*) + gss_libname="gss" + ;; + *) + gss_libname="gssapi" + ;; + esac + + if test "$GSSAPI_ROOT" != "yes"; then + LDFLAGS="$LDFLAGS -L$GSSAPI_ROOT/lib$libsuff" + LDFLAGSPC="$LDFLAGSPC -L$GSSAPI_ROOT/lib$libsuff" + LIBS="-l$gss_libname $LIBS" + else + LIBS="-l$gss_libname $LIBS" + fi + fi + fi + gss_version="" + if test -n "$host_alias" && test -f "$GSSAPI_ROOT/bin/$host_alias-krb5-config"; then + gss_version=`$GSSAPI_ROOT/bin/$host_alias-krb5-config --version | $SED 's/Kerberos 5 release //'` + elif test "$PKGCONFIG" != "no"; then + gss_version=`$PKGCONFIG --modversion mit-krb5-gssapi` + elif test -f "$KRB5CONFIG"; then + gss_version=`$KRB5CONFIG --version | $SED 's/Kerberos 5 release //'` + fi + if test -n "$gss_version"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: GSS-API MIT Kerberos version detected: $gss_version" >&5 +printf "%s\n" "$as_me: GSS-API MIT Kerberos version detected: $gss_version" >&6;} + +printf "%s\n" "#define CURL_KRB5_VERSION \"$gss_version\"" >>confdefs.h + + fi + else + LDFLAGS="$LDFLAGS $GSSAPI_LIB_DIR" + LDFLAGSPC="$LDFLAGSPC $GSSAPI_LIB_DIR" + case $host in + *-hp-hpux*) + LIBS="-lgss $LIBS" + ;; + *) + LIBS="-lgssapi $LIBS" + ;; + esac + fi + if test -n "$link_pkgconfig"; then + if test -n "$gnu_gss"; then + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE gss" + else + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE mit-krb5-gssapi" + fi + fi +else + CPPFLAGS="$save_CPPFLAGS" +fi + +if test "$want_gss" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if we can link against GSS-API library" >&5 +printf %s "checking if we can link against GSS-API library... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#define gss_init_sec_context innocuous_gss_init_sec_context +#ifdef __STDC__ +# include +#else +# include +#endif +#undef gss_init_sec_context +#ifdef __cplusplus +extern "C" +#endif +char gss_init_sec_context (); +#if defined __stub_gss_init_sec_context || defined __stub___gss_init_sec_context +#error force compilation error +#endif + +int main(void) +{ +return gss_init_sec_context (); + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + as_fn_error $? "--with-gssapi was specified, but a GSS-API library was not found." "$LINENO" 5 + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +fi + +build_libstubgss=no +if test "$want_gss" = "yes"; then + build_libstubgss=yes +fi + + if test "$build_libstubgss" = "yes"; then + BUILD_STUB_GSS_TRUE= + BUILD_STUB_GSS_FALSE='#' +else + BUILD_STUB_GSS_TRUE='#' + BUILD_STUB_GSS_FALSE= +fi + + + +DEFAULT_SSL_BACKEND=no +VALID_DEFAULT_SSL_BACKEND= + +# Check whether --with-default-ssl-backend was given. +if test ${with_default_ssl_backend+y} +then : + withval=$with_default_ssl_backend; DEFAULT_SSL_BACKEND=$withval +fi + +case "$DEFAULT_SSL_BACKEND" in + no) + ;; + default|yes) + as_fn_error $? "The name of the default SSL backend is required." "$LINENO" 5 + ;; + *) + VALID_DEFAULT_SSL_BACKEND=no + ;; +esac + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable Windows native SSL/TLS" >&5 +printf %s "checking whether to enable Windows native SSL/TLS... " >&6; } +if test "x$OPT_SCHANNEL" != "xno"; then + ssl_msg= + if test "$curl_cv_native_windows" = "yes"; then + if test "$curl_cv_winuwp" = "yes"; then + as_fn_error $? "UWP does not support Schannel." "$LINENO" 5 + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define USE_SCHANNEL 1" >>confdefs.h + + ssl_msg="Schannel" + test "schannel" != "$DEFAULT_SSL_BACKEND" || VALID_DEFAULT_SSL_BACKEND=yes + SCHANNEL_ENABLED=1 + +printf "%s\n" "#define USE_WINDOWS_SSPI 1" >>confdefs.h + + USE_WINDOWS_SSPI=1 + curl_sspi_msg="enabled" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + fi + test -z "$ssl_msg" || ssl_backends="${ssl_backends:+$ssl_backends, }$ssl_msg" +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable Amiga native SSL/TLS (AmiSSL v5)" >&5 +printf %s "checking whether to enable Amiga native SSL/TLS (AmiSSL v5)... " >&6; } +if test "$HAVE_PROTO_BSDSOCKET_H" = "1"; then + if test "x$OPT_AMISSL" != "xno"; then + ssl_msg= + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #include + #include + +int main(void) +{ + + #if defined(AMISSL_CURRENT_VERSION) && defined(AMISSL_V3xx) && \ + (OPENSSL_VERSION_NUMBER >= 0x30000000L) && defined(PROTO_AMISSL_H) + return 0; + #else + #error not AmiSSL v5 / OpenSSL 3 + #endif + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ssl_msg="AmiSSL" + test "amissl" != "$DEFAULT_SSL_BACKEND" || VALID_DEFAULT_SSL_BACKEND=yes + AMISSL_ENABLED=1 + OPENSSL_ENABLED=1 + check_for_ca_bundle=1 + with_ca_fallback=yes + LIBS="-lamisslstubs -lamisslauto $LIBS" + CURL_NETWORK_AND_TIME_LIBS="-lamisslstubs -lamisslauto $CURL_NETWORK_AND_TIME_LIBS" + +printf "%s\n" "#define USE_AMISSL 1" >>confdefs.h + + +printf "%s\n" "#define USE_OPENSSL 1" >>confdefs.h + + ac_fn_c_check_header_compile "$LINENO" "openssl/rsa.h" "ac_cv_header_openssl_rsa_h" "$ac_includes_default" +if test "x$ac_cv_header_openssl_rsa_h" = xyes +then : + printf "%s\n" "#define HAVE_OPENSSL_RSA_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "openssl/crypto.h" "ac_cv_header_openssl_crypto_h" "$ac_includes_default" +if test "x$ac_cv_header_openssl_crypto_h" = xyes +then : + printf "%s\n" "#define HAVE_OPENSSL_CRYPTO_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "openssl/pem.h" "ac_cv_header_openssl_pem_h" "$ac_includes_default" +if test "x$ac_cv_header_openssl_pem_h" = xyes +then : + printf "%s\n" "#define HAVE_OPENSSL_PEM_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "openssl/ssl.h" "ac_cv_header_openssl_ssl_h" "$ac_includes_default" +if test "x$ac_cv_header_openssl_ssl_h" = xyes +then : + printf "%s\n" "#define HAVE_OPENSSL_SSL_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "openssl/err.h" "ac_cv_header_openssl_err_h" "$ac_includes_default" +if test "x$ac_cv_header_openssl_err_h" = xyes +then : + printf "%s\n" "#define HAVE_OPENSSL_ERR_H 1" >>confdefs.h + +fi + + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + test -z "$ssl_msg" || ssl_backends="${ssl_backends:+$ssl_backends, }$ssl_msg" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + fi +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +if test "x$OPT_OPENSSL" != "xno"; then + ssl_msg= + + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + case $host in + *-*-msys* | *-*-mingw*) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gdi32" >&5 +printf %s "checking for gdi32... " >&6; } + my_ac_save_LIBS=$LIBS + LIBS="-lgdi32 $LIBS" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #ifndef WIN32_LEAN_AND_MEAN + #define WIN32_LEAN_AND_MEAN + #endif + #include + #include + +int main(void) +{ + + GdiFlush(); + + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } +else $as_nop + LIBS=$my_ac_save_LIBS + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + ;; + esac + + case "$OPT_OPENSSL" in + yes) + PKGTEST="yes" + PREFIX_OPENSSL= + ;; + *) + PKGTEST="no" + PREFIX_OPENSSL=$OPT_OPENSSL + + OPENSSL_PCDIR="$OPT_OPENSSL/lib/pkgconfig" + if test -f "$OPENSSL_PCDIR/openssl.pc"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: PKG_CONFIG_LIBDIR is set to \"$OPENSSL_PCDIR\"" >&5 +printf "%s\n" "$as_me: PKG_CONFIG_LIBDIR is set to \"$OPENSSL_PCDIR\"" >&6;} + PKGTEST="yes" + fi + + if test "$PKGTEST" != "yes"; then + OPENSSL_PCDIR="$OPT_OPENSSL/lib64/pkgconfig" + if test -f "$OPENSSL_PCDIR/openssl.pc"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: PKG_CONFIG_LIBDIR is set to \"$OPENSSL_PCDIR\"" >&5 +printf "%s\n" "$as_me: PKG_CONFIG_LIBDIR is set to \"$OPENSSL_PCDIR\"" >&6;} + PKGTEST="yes" + fi + fi + + if test "$PKGTEST" != "yes"; then + if test ! -f "$PREFIX_OPENSSL/include/openssl/ssl.h"; then + as_fn_error $? "$PREFIX_OPENSSL is a bad --with-openssl prefix!" "$LINENO" 5 + fi + fi + + LIB_OPENSSL="$PREFIX_OPENSSL/lib$libsuff" + if test "$PREFIX_OPENSSL" != "/usr"; then + SSL_LDFLAGS="-L$LIB_OPENSSL" + SSL_CPPFLAGS="-I$PREFIX_OPENSSL/include" + fi + ;; + esac + + if test "$PKGTEST" = "yes"; then + + + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. +set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKGCONFIG="$PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PKGCONFIG=$ac_cv_path_PKGCONFIG +if test -n "$PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PKGCONFIG" >&5 +printf "%s\n" "$PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_PKGCONFIG"; then + ac_pt_PKGCONFIG=$PKGCONFIG + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_PKGCONFIG="$ac_pt_PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_PKGCONFIG=$ac_cv_path_ac_pt_PKGCONFIG +if test -n "$ac_pt_PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKGCONFIG" >&5 +printf "%s\n" "$ac_pt_PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_PKGCONFIG" = x; then + PKGCONFIG="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + PKGCONFIG=$ac_pt_PKGCONFIG + fi +else + PKGCONFIG="$ac_cv_path_PKGCONFIG" +fi + + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for openssl options with pkg-config" >&5 +printf %s "checking for openssl options with pkg-config... " >&6; } + itexists=` + if test -n "$OPENSSL_PCDIR"; then + if test -n ""; then + PKG_CONFIG_PATH="$OPENSSL_PCDIR${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$OPENSSL_PCDIR" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists openssl >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + + trc=` + if test -n "$OPENSSL_PCDIR"; then + if test -n ""; then + PKG_CONFIG_PATH="$OPENSSL_PCDIR${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$OPENSSL_PCDIR" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug openssl 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$OPENSSL_PCDIR"; then + if test -n ""; then + PKG_CONFIG_PATH="$OPENSSL_PCDIR${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$OPENSSL_PCDIR" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors openssl 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists openssl trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists openssl trace: +---- begin +${trc} +---- end" >&6;} + + fi + PKGCONFIG="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found" >&5 +printf "%s\n" "found" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG"; then + + trc=` + if test -n "$OPENSSL_PCDIR"; then + if test -n ""; then + PKG_CONFIG_PATH="$OPENSSL_PCDIR${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$OPENSSL_PCDIR" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug openssl 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$OPENSSL_PCDIR"; then + if test -n ""; then + PKG_CONFIG_PATH="$OPENSSL_PCDIR${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$OPENSSL_PCDIR" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors openssl 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists openssl trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists openssl trace: +---- begin +${trc} +---- end" >&6;} + + fi + fi + fi + + + if test "$PKGCONFIG" != "no"; then + SSL_LIBS=` + if test -n "$OPENSSL_PCDIR"; then + if test -n ""; then + PKG_CONFIG_PATH="$OPENSSL_PCDIR${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$OPENSSL_PCDIR" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --libs-only-l --libs-only-other openssl 2>/dev/null` + + SSL_LDFLAGS=` + if test -n "$OPENSSL_PCDIR"; then + if test -n ""; then + PKG_CONFIG_PATH="$OPENSSL_PCDIR${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$OPENSSL_PCDIR" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --libs-only-L openssl 2>/dev/null` + + SSL_CPPFLAGS=` + if test -n "$OPENSSL_PCDIR"; then + if test -n ""; then + PKG_CONFIG_PATH="$OPENSSL_PCDIR${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$OPENSSL_PCDIR" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --cflags-only-I openssl 2>/dev/null` + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config: SSL_LIBS: \"$SSL_LIBS\"" >&5 +printf "%s\n" "$as_me: pkg-config: SSL_LIBS: \"$SSL_LIBS\"" >&6;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config: SSL_LDFLAGS: \"$SSL_LDFLAGS\"" >&5 +printf "%s\n" "$as_me: pkg-config: SSL_LDFLAGS: \"$SSL_LDFLAGS\"" >&6;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config: SSL_CPPFLAGS: \"$SSL_CPPFLAGS\"" >&5 +printf "%s\n" "$as_me: pkg-config: SSL_CPPFLAGS: \"$SSL_CPPFLAGS\"" >&6;} + + LIB_OPENSSL=`echo $SSL_LDFLAGS | sed -e 's/^-L//'` + + LIBS="$SSL_LIBS $LIBS" + fi + fi + + CPPFLAGS="$CPPFLAGS $SSL_CPPFLAGS" + LDFLAGS="$LDFLAGS $SSL_LDFLAGS" + LDFLAGSPC="$LDFLAGSPC $SSL_LDFLAGS" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for HMAC_Update in -lcrypto" >&5 +printf %s "checking for HMAC_Update in -lcrypto... " >&6; } +if test ${ac_cv_lib_crypto_HMAC_Update+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lcrypto $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char HMAC_Update (); +int main(void) +{ +return HMAC_Update (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_crypto_HMAC_Update=yes +else $as_nop + ac_cv_lib_crypto_HMAC_Update=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_crypto_HMAC_Update" >&5 +printf "%s\n" "$ac_cv_lib_crypto_HMAC_Update" >&6; } +if test "x$ac_cv_lib_crypto_HMAC_Update" = xyes +then : + + HAVECRYPTO="yes" + LIBS="-lcrypto $LIBS" + +else $as_nop + + if test -n "$LIB_OPENSSL"; then + LDFLAGS="$CLEANLDFLAGS -L$LIB_OPENSSL" + LDFLAGSPC="$CLEANLDFLAGSPC -L$LIB_OPENSSL" + fi + if test "$PKGCONFIG" = "no" && test -n "$PREFIX_OPENSSL"; then + CPPFLAGS="$CLEANCPPFLAGS -I$PREFIX_OPENSSL/include" + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for HMAC_Init_ex in -lcrypto" >&5 +printf %s "checking for HMAC_Init_ex in -lcrypto... " >&6; } +if test ${ac_cv_lib_crypto_HMAC_Init_ex+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lcrypto $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char HMAC_Init_ex (); +int main(void) +{ +return HMAC_Init_ex (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_crypto_HMAC_Init_ex=yes +else $as_nop + ac_cv_lib_crypto_HMAC_Init_ex=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_crypto_HMAC_Init_ex" >&5 +printf "%s\n" "$ac_cv_lib_crypto_HMAC_Init_ex" >&6; } +if test "x$ac_cv_lib_crypto_HMAC_Init_ex" = xyes +then : + + HAVECRYPTO="yes" + LIBS="-lcrypto $LIBS" +else $as_nop + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking OpenSSL linking with -ldl" >&5 +printf %s "checking OpenSSL linking with -ldl... " >&6; } + LIBS="-lcrypto $CLEANLIBS -ldl" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #include + +int main(void) +{ + + ERR_clear_error(); + + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + HAVECRYPTO="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking OpenSSL linking with -ldl and -lpthread" >&5 +printf %s "checking OpenSSL linking with -ldl and -lpthread... " >&6; } + LIBS="-lcrypto $CLEANLIBS -ldl -lpthread" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #include + +int main(void) +{ + + ERR_clear_error(); + + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + HAVECRYPTO="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + LDFLAGS="$CLEANLDFLAGS" + LDFLAGSPC="$CLEANLDFLAGSPC" + CPPFLAGS="$CLEANCPPFLAGS" + LIBS="$CLEANLIBS" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + +fi + + +fi + + + if test "$HAVECRYPTO" = "yes"; then + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for SSL_connect in -lssl" >&5 +printf %s "checking for SSL_connect in -lssl... " >&6; } +if test ${ac_cv_lib_ssl_SSL_connect+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lssl $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char SSL_connect (); +int main(void) +{ +return SSL_connect (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_ssl_SSL_connect=yes +else $as_nop + ac_cv_lib_ssl_SSL_connect=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_ssl_SSL_connect" >&5 +printf "%s\n" "$ac_cv_lib_ssl_SSL_connect" >&6; } +if test "x$ac_cv_lib_ssl_SSL_connect" = xyes +then : + printf "%s\n" "#define HAVE_LIBSSL 1" >>confdefs.h + + LIBS="-lssl $LIBS" + +fi + + + if test "$ac_cv_lib_ssl_SSL_connect" = "yes"; then + for ac_header in openssl/rsa.h openssl/crypto.h openssl/pem.h openssl/ssl.h openssl/err.h +do : + as_ac_Header=`printf "%s\n" "ac_cv_header_$ac_header" | $as_tr_sh` +ac_fn_c_check_header_compile "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" +if eval test \"x\$"$as_ac_Header"\" = x"yes" +then : + cat >>confdefs.h <<_ACEOF +#define `printf "%s\n" "HAVE_$ac_header" | $as_tr_cpp` 1 +_ACEOF + ssl_msg="OpenSSL" + test "openssl" != "$DEFAULT_SSL_BACKEND" || VALID_DEFAULT_SSL_BACKEND=yes + OPENSSL_ENABLED=1 + +printf "%s\n" "#define USE_OPENSSL 1" >>confdefs.h + +fi + +done + fi + + if test "$OPENSSL_ENABLED" != "1"; then + LIBS="$CLEANLIBS" + as_fn_error $? "OpenSSL libs and/or directories were not found where specified!" "$LINENO" 5 + fi + fi + + if test "$OPENSSL_ENABLED" = "1"; then + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for AWS-LC" >&5 +printf %s "checking for AWS-LC... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #include + +int main(void) +{ + + #ifndef OPENSSL_IS_AWSLC + #error not AWS-LC + #endif + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ssl_msg="AWS-LC" + OPENSSL_IS_AWSLC=1 + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for BoringSSL" >&5 +printf %s "checking for BoringSSL... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #include + +int main(void) +{ + + #ifndef OPENSSL_IS_BORINGSSL + #error not BoringSSL + #endif + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ssl_msg="BoringSSL" + OPENSSL_IS_BORINGSSL=1 + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for LibreSSL" >&5 +printf %s "checking for LibreSSL... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #include + +int main(void) +{ + + int dummy = LIBRESSL_VERSION_NUMBER; + (void)dummy; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ssl_msg="LibreSSL" + HAVE_LIBRESSL=1 + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + + if test "$ssl_msg" = 'OpenSSL'; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for OpenSSL >= v3" >&5 +printf %s "checking for OpenSSL >= v3... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #include + +int main(void) +{ + + #if (OPENSSL_VERSION_NUMBER >= 0x30000000L) + return 0; + #else + #error older than 3 + #endif + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + +else $as_nop + + as_fn_error $? "OpenSSL 3.0.0 or upper required." "$LINENO" 5 + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + fi + + + for ac_func in SSL_set_quic_use_legacy_codepoint +do : + ac_fn_c_check_func "$LINENO" "SSL_set_quic_use_legacy_codepoint" "ac_cv_func_SSL_set_quic_use_legacy_codepoint" +if test "x$ac_cv_func_SSL_set_quic_use_legacy_codepoint" = xyes +then : + printf "%s\n" "#define HAVE_SSL_SET_QUIC_USE_LEGACY_CODEPOINT 1" >>confdefs.h + QUIC_ENABLED=yes +fi + +done + if test "$QUIC_ENABLED" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: OpenSSL fork speaks QUIC API" >&5 +printf "%s\n" "$as_me: OpenSSL fork speaks QUIC API" >&6;} + else + + for ac_func in SSL_set_quic_tls_cbs +do : + ac_fn_c_check_func "$LINENO" "SSL_set_quic_tls_cbs" "ac_cv_func_SSL_set_quic_tls_cbs" +if test "x$ac_cv_func_SSL_set_quic_tls_cbs" = xyes +then : + printf "%s\n" "#define HAVE_SSL_SET_QUIC_TLS_CBS 1" >>confdefs.h + QUIC_ENABLED=yes +fi + +done + if test "$QUIC_ENABLED" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: OpenSSL with QUIC APIv2" >&5 +printf "%s\n" "$as_me: OpenSSL with QUIC APIv2" >&6;} + OPENSSL_QUIC_API2=1 + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: OpenSSL version does not speak any known QUIC API" >&5 +printf "%s\n" "$as_me: OpenSSL version does not speak any known QUIC API" >&6;} + fi + fi + + if test "$OPENSSL_ENABLED" = "1"; then + if test -n "$LIB_OPENSSL"; then + if test "$cross_compiling" != "yes"; then + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$LIB_OPENSSL" + export CURL_LIBRARY_PATH + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: Added $LIB_OPENSSL to CURL_LIBRARY_PATH" >&5 +printf "%s\n" "$as_me: Added $LIB_OPENSSL to CURL_LIBRARY_PATH" >&6;} + fi + fi + check_for_ca_bundle=1 + if test "$OPENSSL_IS_BORINGSSL" != "1"; then LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE openssl" + fi + fi + + if test "$OPENSSL_ENABLED" != "1"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: OPT_OPENSSL: $OPT_OPENSSL" >&5 +printf "%s\n" "$as_me: OPT_OPENSSL: $OPT_OPENSSL" >&6;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: OPENSSL_ENABLED: $OPENSSL_ENABLED" >&5 +printf "%s\n" "$as_me: OPENSSL_ENABLED: $OPENSSL_ENABLED" >&6;} + as_fn_error $? "--with-openssl was given but OpenSSL could not be detected" "$LINENO" 5 + fi + + test -z "$ssl_msg" || ssl_backends="${ssl_backends:+$ssl_backends, }$ssl_msg" +fi +if test "$OPENSSL_ENABLED" = "1"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for DES support in OpenSSL" >&5 +printf %s "checking for DES support in OpenSSL... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #ifndef OPENSSL_SUPPRESS_DEPRECATED + #define OPENSSL_SUPPRESS_DEPRECATED + #endif + #include + +int main(void) +{ + + DES_ecb_encrypt(0, 0, 0, DES_ENCRYPT); + + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_DES_ECB_ENCRYPT 1" >>confdefs.h + + HAVE_DES_ECB_ENCRYPT=1 + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for SRP support in OpenSSL" >&5 +printf %s "checking for SRP support in OpenSSL... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #ifndef OPENSSL_SUPPRESS_DEPRECATED + #define OPENSSL_SUPPRESS_DEPRECATED + #endif + #include + +int main(void) +{ + + SSL_CTX_set_srp_username(NULL, NULL); + SSL_CTX_set_srp_password(NULL, NULL); + + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_OPENSSL_SRP 1" >>confdefs.h + + HAVE_OPENSSL_SRP=1 + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + # Check whether --enable-openssl-auto-load-config was given. +if test ${enable_openssl_auto_load_config+y} +then : + enableval=$enable_openssl_auto_load_config; if test "x$enableval" = "xno"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: automatic loading of OpenSSL configuration disabled" >&5 +printf "%s\n" "$as_me: automatic loading of OpenSSL configuration disabled" >&6;} + +printf "%s\n" "#define CURL_DISABLE_OPENSSL_AUTO_LOAD_CONFIG 1" >>confdefs.h + + fi + +fi + +fi + + +if test "x$OPT_GNUTLS" != "xno"; then + ssl_msg= + + addld="" + addlib="" + gtlslib="" + version="" + addcflags="" + + if test "x$OPT_GNUTLS" = "xyes"; then + + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. +set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKGCONFIG="$PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PKGCONFIG=$ac_cv_path_PKGCONFIG +if test -n "$PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PKGCONFIG" >&5 +printf "%s\n" "$PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_PKGCONFIG"; then + ac_pt_PKGCONFIG=$PKGCONFIG + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_PKGCONFIG="$ac_pt_PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_PKGCONFIG=$ac_cv_path_ac_pt_PKGCONFIG +if test -n "$ac_pt_PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKGCONFIG" >&5 +printf "%s\n" "$ac_pt_PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_PKGCONFIG" = x; then + PKGCONFIG="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + PKGCONFIG=$ac_pt_PKGCONFIG + fi +else + PKGCONFIG="$ac_cv_path_PKGCONFIG" +fi + + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gnutls options with pkg-config" >&5 +printf %s "checking for gnutls options with pkg-config... " >&6; } + itexists=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists gnutls >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + + trc=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug gnutls 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors gnutls 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists gnutls trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists gnutls trace: +---- begin +${trc} +---- end" >&6;} + + fi + PKGCONFIG="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found" >&5 +printf "%s\n" "found" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG"; then + + trc=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug gnutls 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors gnutls 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists gnutls trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists gnutls trace: +---- begin +${trc} +---- end" >&6;} + + fi + fi + fi + + + if test "$PKGCONFIG" != "no"; then + addlib=`$PKGCONFIG --libs-only-l gnutls` + addld=`$PKGCONFIG --libs-only-L gnutls` + addcflags=`$PKGCONFIG --cflags-only-I gnutls` + version=`$PKGCONFIG --modversion gnutls` + gtlslib=`echo $addld | $SED -e 's/^-L//'` + else + check=`libgnutls-config --version 2>/dev/null` + if test -n "$check"; then + addlib=`libgnutls-config --libs` + addcflags=`libgnutls-config --cflags` + version=`libgnutls-config --version` + gtlslib=`libgnutls-config --prefix`/lib$libsuff + fi + fi + else + cfg=$OPT_GNUTLS/bin/libgnutls-config + check=`$cfg --version 2>/dev/null` + if test -n "$check"; then + addlib=`$cfg --libs` + addcflags=`$cfg --cflags` + version=`$cfg --version` + gtlslib=`$cfg --prefix`/lib$libsuff + else + addlib=-lgnutls + addld=-L$OPT_GNUTLS/lib$libsuff + addcflags=-I$OPT_GNUTLS/include + version="" + gtlslib=$OPT_GNUTLS/lib$libsuff + fi + fi + + if test -z "$version"; then + version="unknown" + fi + + if test -n "$addlib"; then + + CLEANLIBS="$LIBS" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + + LIBS="$addlib $LIBS" + LDFLAGS="$LDFLAGS $addld" + LDFLAGSPC="$LDFLAGSPC $addld" + if test "$addcflags" != "-I/usr/include"; then + CPPFLAGS="$CPPFLAGS $addcflags" + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gnutls_x509_crt_get_dn2 in -lgnutls" >&5 +printf %s "checking for gnutls_x509_crt_get_dn2 in -lgnutls... " >&6; } +if test ${ac_cv_lib_gnutls_gnutls_x509_crt_get_dn2+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lgnutls $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char gnutls_x509_crt_get_dn2 (); +int main(void) +{ +return gnutls_x509_crt_get_dn2 (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_gnutls_gnutls_x509_crt_get_dn2=yes +else $as_nop + ac_cv_lib_gnutls_gnutls_x509_crt_get_dn2=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_gnutls_gnutls_x509_crt_get_dn2" >&5 +printf "%s\n" "$ac_cv_lib_gnutls_gnutls_x509_crt_get_dn2" >&6; } +if test "x$ac_cv_lib_gnutls_gnutls_x509_crt_get_dn2" = xyes +then : + + +printf "%s\n" "#define USE_GNUTLS 1" >>confdefs.h + + GNUTLS_ENABLED=1 + USE_GNUTLS="yes" + ssl_msg="GnuTLS" + QUIC_ENABLED=yes + test "gnutls" != "$DEFAULT_SSL_BACKEND" || VALID_DEFAULT_SSL_BACKEND=yes + +else $as_nop + + LIBS="$CLEANLIBS" + CPPFLAGS="$CLEANCPPFLAGS" + LDFLAGS="$CLEANLDFLAGS" + LDFLAGSPC="$CLEANLDFLAGSPC" + +fi + + + if test "$USE_GNUTLS" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: detected GnuTLS version $version" >&5 +printf "%s\n" "$as_me: detected GnuTLS version $version" >&6;} + check_for_ca_bundle=1 + if test -n "$gtlslib"; then + if test "$cross_compiling" != "yes"; then + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$gtlslib" + export CURL_LIBRARY_PATH + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: Added $gtlslib to CURL_LIBRARY_PATH" >&5 +printf "%s\n" "$as_me: Added $gtlslib to CURL_LIBRARY_PATH" >&6;} + fi + fi + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE gnutls" + fi + fi + + test -z "$ssl_msg" || ssl_backends="${ssl_backends:+$ssl_backends, }$ssl_msg" +fi +if test "$GNUTLS_ENABLED" = "1"; then + USE_GNUTLS_NETTLE= + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for nettle_md5_init in -lgnutls" >&5 +printf %s "checking for nettle_md5_init in -lgnutls... " >&6; } +if test ${ac_cv_lib_gnutls_nettle_md5_init+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lgnutls $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char nettle_md5_init (); +int main(void) +{ +return nettle_md5_init (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_gnutls_nettle_md5_init=yes +else $as_nop + ac_cv_lib_gnutls_nettle_md5_init=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_gnutls_nettle_md5_init" >&5 +printf "%s\n" "$ac_cv_lib_gnutls_nettle_md5_init" >&6; } +if test "x$ac_cv_lib_gnutls_nettle_md5_init" = xyes +then : + USE_GNUTLS_NETTLE=1 +fi + + + if test -z "$USE_GNUTLS_NETTLE"; then + + + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. +set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKGCONFIG="$PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PKGCONFIG=$ac_cv_path_PKGCONFIG +if test -n "$PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PKGCONFIG" >&5 +printf "%s\n" "$PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_PKGCONFIG"; then + ac_pt_PKGCONFIG=$PKGCONFIG + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_PKGCONFIG="$ac_pt_PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_PKGCONFIG=$ac_cv_path_ac_pt_PKGCONFIG +if test -n "$ac_pt_PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKGCONFIG" >&5 +printf "%s\n" "$ac_pt_PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_PKGCONFIG" = x; then + PKGCONFIG="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + PKGCONFIG=$ac_pt_PKGCONFIG + fi +else + PKGCONFIG="$ac_cv_path_PKGCONFIG" +fi + + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for nettle options with pkg-config" >&5 +printf %s "checking for nettle options with pkg-config... " >&6; } + itexists=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists nettle >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + + trc=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug nettle 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors nettle 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists nettle trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists nettle trace: +---- begin +${trc} +---- end" >&6;} + + fi + PKGCONFIG="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found" >&5 +printf "%s\n" "found" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG"; then + + trc=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug nettle 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors nettle 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists nettle trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists nettle trace: +---- begin +${trc} +---- end" >&6;} + + fi + fi + fi + + + if test "$PKGCONFIG" != "no"; then + addlib=`$PKGCONFIG --libs-only-l nettle` + addld=`$PKGCONFIG --libs-only-L nettle` + addcflags=`$PKGCONFIG --cflags-only-I nettle` + version=`$PKGCONFIG --modversion nettle` + gtlslib=`echo $addld | $SED -e 's/^-L//'` + + if test -n "$addlib"; then + + CLEANLIBS="$LIBS" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + + LIBS="$addlib $LIBS" + LDFLAGS="$LDFLAGS $addld" + LDFLAGSPC="$LDFLAGSPC $addld" + if test "$addcflags" != "-I/usr/include"; then + CPPFLAGS="$CPPFLAGS $addcflags" + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for nettle_md5_init in -lnettle" >&5 +printf %s "checking for nettle_md5_init in -lnettle... " >&6; } +if test ${ac_cv_lib_nettle_nettle_md5_init+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lnettle $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char nettle_md5_init (); +int main(void) +{ +return nettle_md5_init (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_nettle_nettle_md5_init=yes +else $as_nop + ac_cv_lib_nettle_nettle_md5_init=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_nettle_nettle_md5_init" >&5 +printf "%s\n" "$ac_cv_lib_nettle_nettle_md5_init" >&6; } +if test "x$ac_cv_lib_nettle_nettle_md5_init" = xyes +then : + + USE_GNUTLS_NETTLE=1 + +else $as_nop + + LIBS="$CLEANLIBS" + CPPFLAGS="$CLEANCPPFLAGS" + LDFLAGS="$CLEANLDFLAGS" + LDFLAGSPC="$CLEANLDFLAGSPC" + +fi + + + if test "$USE_GNUTLS_NETTLE" = "1"; then + if test -z "$version"; then + version="unknown" + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: detected nettle version $version" >&5 +printf "%s\n" "$as_me: detected nettle version $version" >&6;} + fi + fi + fi + if test -z "$USE_GNUTLS_NETTLE"; then + as_fn_error $? "GnuTLS found, but nettle was not found" "$LINENO" 5 + fi + else + LIBS="-lnettle $LIBS" + fi + + if test "$USE_GNUTLS_NETTLE" = "1"; then + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE nettle" + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gnutls_srp_verifier in -lgnutls" >&5 +printf %s "checking for gnutls_srp_verifier in -lgnutls... " >&6; } +if test ${ac_cv_lib_gnutls_gnutls_srp_verifier+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lgnutls $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char gnutls_srp_verifier (); +int main(void) +{ +return gnutls_srp_verifier (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_gnutls_gnutls_srp_verifier=yes +else $as_nop + ac_cv_lib_gnutls_gnutls_srp_verifier=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_gnutls_gnutls_srp_verifier" >&5 +printf "%s\n" "$ac_cv_lib_gnutls_gnutls_srp_verifier" >&6; } +if test "x$ac_cv_lib_gnutls_gnutls_srp_verifier" = xyes +then : + + +printf "%s\n" "#define HAVE_GNUTLS_SRP 1" >>confdefs.h + + HAVE_GNUTLS_SRP=1 + +fi + +fi + + + +if test "x$OPT_MBEDTLS" != "xno"; then + _cppflags=$CPPFLAGS + _ldflags=$LDFLAGS + _ldflagspc=$LDFLAGSPC + ssl_msg= + + if test "x$OPT_MBEDTLS" = "xyes"; then + OPT_MBEDTLS="" + fi + + if test -z "$OPT_MBEDTLS"; then + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for mbedtls_ssl_init in -lmbedtls" >&5 +printf %s "checking for mbedtls_ssl_init in -lmbedtls... " >&6; } +if test ${ac_cv_lib_mbedtls_mbedtls_ssl_init+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lmbedtls -lmbedx509 -lmbedcrypto $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char mbedtls_ssl_init (); +int main(void) +{ +return mbedtls_ssl_init (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_mbedtls_mbedtls_ssl_init=yes +else $as_nop + ac_cv_lib_mbedtls_mbedtls_ssl_init=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_mbedtls_mbedtls_ssl_init" >&5 +printf "%s\n" "$ac_cv_lib_mbedtls_mbedtls_ssl_init" >&6; } +if test "x$ac_cv_lib_mbedtls_mbedtls_ssl_init" = xyes +then : + + +printf "%s\n" "#define USE_MBEDTLS 1" >>confdefs.h + + MBEDTLS_ENABLED=1 + USE_MBEDTLS="yes" + ssl_msg="mbedTLS" + test "mbedtls" != "$DEFAULT_SSL_BACKEND" || VALID_DEFAULT_SSL_BACKEND=yes + +fi + + fi + + addld="" + addlib="" + addcflags="" + mbedtlslib="" + + if test "$USE_MBEDTLS" != "yes" && test -n "$OPT_MBEDTLS"; then + addld=-L$OPT_MBEDTLS/lib$libsuff + addcflags=-I$OPT_MBEDTLS/include + mbedtlslib=$OPT_MBEDTLS/lib$libsuff + + LDFLAGS="$LDFLAGS $addld" + LDFLAGSPC="$LDFLAGSPC $addld" + if test "$addcflags" != "-I/usr/include"; then + CPPFLAGS="$CPPFLAGS $addcflags" + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for mbedtls_ssl_init in -lmbedtls" >&5 +printf %s "checking for mbedtls_ssl_init in -lmbedtls... " >&6; } +if test ${ac_cv_lib_mbedtls_mbedtls_ssl_init+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lmbedtls -lmbedx509 -lmbedcrypto $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char mbedtls_ssl_init (); +int main(void) +{ +return mbedtls_ssl_init (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_mbedtls_mbedtls_ssl_init=yes +else $as_nop + ac_cv_lib_mbedtls_mbedtls_ssl_init=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_mbedtls_mbedtls_ssl_init" >&5 +printf "%s\n" "$ac_cv_lib_mbedtls_mbedtls_ssl_init" >&6; } +if test "x$ac_cv_lib_mbedtls_mbedtls_ssl_init" = xyes +then : + + +printf "%s\n" "#define USE_MBEDTLS 1" >>confdefs.h + + MBEDTLS_ENABLED=1 + USE_MBEDTLS="yes" + ssl_msg="mbedTLS" + test "mbedtls" != "$DEFAULT_SSL_BACKEND" || VALID_DEFAULT_SSL_BACKEND=yes + +else $as_nop + + CPPFLAGS=$_cppflags + LDFLAGS=$_ldflags + LDFLAGSPC=$_ldflagspc + +fi + + fi + + if test "$USE_MBEDTLS" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: detected mbedTLS" >&5 +printf "%s\n" "$as_me: detected mbedTLS" >&6;} + check_for_ca_bundle=1 + + LIBS="-lmbedtls -lmbedx509 -lmbedcrypto $LIBS" + + if test -n "$mbedtlslib"; then + if test "$cross_compiling" != "yes"; then + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$mbedtlslib" + export CURL_LIBRARY_PATH + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: Added $mbedtlslib to CURL_LIBRARY_PATH" >&5 +printf "%s\n" "$as_me: Added $mbedtlslib to CURL_LIBRARY_PATH" >&6;} + fi + fi + if false; then + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE mbedtls mbedx509 mbedcrypto" + fi + + ac_fn_c_check_func "$LINENO" "mbedtls_des_crypt_ecb" "ac_cv_func_mbedtls_des_crypt_ecb" +if test "x$ac_cv_func_mbedtls_des_crypt_ecb" = xyes +then : + printf "%s\n" "#define HAVE_MBEDTLS_DES_CRYPT_ECB 1" >>confdefs.h + +fi + + if test "$ac_cv_func_mbedtls_des_crypt_ecb" = 'yes'; then + HAVE_MBEDTLS_DES_CRYPT_ECB=1 + fi + fi + + test -z "$ssl_msg" || ssl_backends="${ssl_backends:+$ssl_backends, }$ssl_msg" +fi + + +case "$OPT_WOLFSSL" in + yes|no) + wolfpkg="" + ;; + *) + wolfpkg="$OPT_WOLFSSL/lib/pkgconfig" + ;; +esac + +if test "$OPT_WOLFSSL" != "no"; then + _cppflags=$CPPFLAGS + _ldflags=$LDFLAGS + _ldflagspc=$LDFLAGSPC + + ssl_msg= + + if test "$OPT_WOLFSSL" = "yes"; then + OPT_WOLFSSL="" + fi + + + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. +set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKGCONFIG="$PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PKGCONFIG=$ac_cv_path_PKGCONFIG +if test -n "$PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PKGCONFIG" >&5 +printf "%s\n" "$PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_PKGCONFIG"; then + ac_pt_PKGCONFIG=$PKGCONFIG + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_PKGCONFIG="$ac_pt_PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_PKGCONFIG=$ac_cv_path_ac_pt_PKGCONFIG +if test -n "$ac_pt_PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKGCONFIG" >&5 +printf "%s\n" "$ac_pt_PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_PKGCONFIG" = x; then + PKGCONFIG="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + PKGCONFIG=$ac_pt_PKGCONFIG + fi +else + PKGCONFIG="$ac_cv_path_PKGCONFIG" +fi + + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for wolfssl options with pkg-config" >&5 +printf %s "checking for wolfssl options with pkg-config... " >&6; } + itexists=` + if test -n "$wolfpkg"; then + if test -n ""; then + PKG_CONFIG_PATH="$wolfpkg${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$wolfpkg" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists wolfssl >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + + trc=` + if test -n "$wolfpkg"; then + if test -n ""; then + PKG_CONFIG_PATH="$wolfpkg${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$wolfpkg" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug wolfssl 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$wolfpkg"; then + if test -n ""; then + PKG_CONFIG_PATH="$wolfpkg${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$wolfpkg" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors wolfssl 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists wolfssl trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists wolfssl trace: +---- begin +${trc} +---- end" >&6;} + + fi + PKGCONFIG="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found" >&5 +printf "%s\n" "found" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG"; then + + trc=` + if test -n "$wolfpkg"; then + if test -n ""; then + PKG_CONFIG_PATH="$wolfpkg${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$wolfpkg" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug wolfssl 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$wolfpkg"; then + if test -n ""; then + PKG_CONFIG_PATH="$wolfpkg${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$wolfpkg" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors wolfssl 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists wolfssl trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists wolfssl trace: +---- begin +${trc} +---- end" >&6;} + + fi + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: Check directory $wolfpkg" >&5 +printf "%s\n" "$as_me: Check directory $wolfpkg" >&6;} + + addld="" + addlib="" + addcflags="" + if test "$PKGCONFIG" != "no"; then + addlib=` + if test -n "$wolfpkg"; then + if test -n ""; then + PKG_CONFIG_PATH="$wolfpkg${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$wolfpkg" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --libs-only-l wolfssl` + addld=` + if test -n "$wolfpkg"; then + if test -n ""; then + PKG_CONFIG_PATH="$wolfpkg${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$wolfpkg" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --libs-only-L wolfssl` + addcflags=` + if test -n "$wolfpkg"; then + if test -n ""; then + PKG_CONFIG_PATH="$wolfpkg${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$wolfpkg" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --cflags-only-I wolfssl` + version=` + if test -n "$wolfpkg"; then + if test -n ""; then + PKG_CONFIG_PATH="$wolfpkg${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$wolfpkg" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --modversion wolfssl` + wolfssllibpath=`echo $addld | $SED -e 's/^-L//'` + else + addlib=-lwolfssl + if test -n "$OPT_WOLFSSL"; then + addld=-L$OPT_WOLFSSL/lib$libsuff + addcflags=-I$OPT_WOLFSSL/include + wolfssllibpath=$OPT_WOLFSSL/lib$libsuff + fi + fi + + if test "$curl_cv_apple" = "yes"; then + addlib="$addlib -framework Security -framework CoreFoundation" + else + addlib="$addlib -lm" + fi + + if test "$USE_WOLFSSL" != "yes"; then + CPPFLAGS="$CPPFLAGS -DWOLFSSL_OPTIONS_IGNORE_SYS" + + LDFLAGS="$LDFLAGS $addld" + LDFLAGSPC="$LDFLAGSPC $addld" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: Add $addld to LDFLAGS" >&5 +printf "%s\n" "$as_me: Add $addld to LDFLAGS" >&6;} + if test "$addcflags" != "-I/usr/include"; then + CPPFLAGS="$CPPFLAGS $addcflags" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: Add $addcflags to CPPFLAGS" >&5 +printf "%s\n" "$as_me: Add $addcflags to CPPFLAGS" >&6;} + fi + + my_ac_save_LIBS="$LIBS" + LIBS="$addlib $LIBS" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: Add $addlib to LIBS" >&5 +printf "%s\n" "$as_me: Add $addlib to LIBS" >&6;} + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for wolfSSL_Init in -lwolfssl" >&5 +printf %s "checking for wolfSSL_Init in -lwolfssl... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #include + #include + +int main(void) +{ + + return wolfSSL_Init(); + + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define USE_WOLFSSL 1" >>confdefs.h + + WOLFSSL_ENABLED=1 + USE_WOLFSSL="yes" + ssl_msg="wolfSSL" + test "wolfssl" != "$DEFAULT_SSL_BACKEND" || VALID_DEFAULT_SSL_BACKEND=yes + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + CPPFLAGS=$_cppflags + LDFLAGS=$_ldflags + LDFLAGSPC=$_ldflagspc + wolfssllibpath="" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + LIBS="$my_ac_save_LIBS" + fi + + if test "$USE_WOLFSSL" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: detected wolfSSL" >&5 +printf "%s\n" "$as_me: detected wolfSSL" >&6;} + check_for_ca_bundle=1 + + LIBS="$addlib $LIBS" + + + for ac_func in wolfSSL_set_quic_use_legacy_codepoint +do : + ac_fn_c_check_func "$LINENO" "wolfSSL_set_quic_use_legacy_codepoint" "ac_cv_func_wolfSSL_set_quic_use_legacy_codepoint" +if test "x$ac_cv_func_wolfSSL_set_quic_use_legacy_codepoint" = xyes +then : + printf "%s\n" "#define HAVE_WOLFSSL_SET_QUIC_USE_LEGACY_CODEPOINT 1" >>confdefs.h + QUIC_ENABLED=yes +fi + +done + + ac_fn_c_check_func "$LINENO" "wolfSSL_get_peer_certificate" "ac_cv_func_wolfSSL_get_peer_certificate" +if test "x$ac_cv_func_wolfSSL_get_peer_certificate" = xyes +then : + printf "%s\n" "#define HAVE_WOLFSSL_GET_PEER_CERTIFICATE 1" >>confdefs.h + +fi +ac_fn_c_check_func "$LINENO" "wolfSSL_UseALPN" "ac_cv_func_wolfSSL_UseALPN" +if test "x$ac_cv_func_wolfSSL_UseALPN" = xyes +then : + printf "%s\n" "#define HAVE_WOLFSSL_USEALPN 1" >>confdefs.h + +fi +ac_fn_c_check_func "$LINENO" "wolfSSL_BIO_new" "ac_cv_func_wolfSSL_BIO_new" +if test "x$ac_cv_func_wolfSSL_BIO_new" = xyes +then : + printf "%s\n" "#define HAVE_WOLFSSL_BIO_NEW 1" >>confdefs.h + +fi +ac_fn_c_check_func "$LINENO" "wolfSSL_BIO_set_shutdown" "ac_cv_func_wolfSSL_BIO_set_shutdown" +if test "x$ac_cv_func_wolfSSL_BIO_set_shutdown" = xyes +then : + printf "%s\n" "#define HAVE_WOLFSSL_BIO_SET_SHUTDOWN 1" >>confdefs.h + +fi +ac_fn_c_check_func "$LINENO" "wc_Des_EcbEncrypt" "ac_cv_func_wc_Des_EcbEncrypt" +if test "x$ac_cv_func_wc_Des_EcbEncrypt" = xyes +then : + printf "%s\n" "#define HAVE_WC_DES_ECBENCRYPT 1" >>confdefs.h + +fi + + + if test "$ac_cv_func_wc_Des_EcbEncrypt" = "yes"; then + HAVE_WC_DES_ECBENCRYPT=1 + fi + + if test "$ac_cv_func_wolfSSL_BIO_new" = "yes"; then + HAVE_WOLFSSL_BIO_NEW=1 + fi + + if test -n "$wolfssllibpath"; then + if test "$cross_compiling" != "yes"; then + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$wolfssllibpath" + export CURL_LIBRARY_PATH + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: Added $wolfssllibpath to CURL_LIBRARY_PATH" >&5 +printf "%s\n" "$as_me: Added $wolfssllibpath to CURL_LIBRARY_PATH" >&6;} + fi + fi + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE wolfssl" + else + as_fn_error $? "--with-wolfssl but wolfSSL was not found or does not work" "$LINENO" 5 + fi + + test -z "$ssl_msg" || ssl_backends="${ssl_backends:+$ssl_backends, }$ssl_msg" +fi + + +if test "x$OPT_RUSTLS" != "xno"; then + ssl_msg= + + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + + + + case "$OPT_RUSTLS" in + yes) + PKGTEST="yes" + PREFIX_RUSTLS= + ;; + *) + PKGTEST="no" + PREFIX_RUSTLS=$OPT_RUSTLS + + + RUSTLS_PCDIR="$PREFIX_RUSTLS/lib/pkgconfig" + if test -f "$RUSTLS_PCDIR/rustls.pc"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: PKG_CONFIG_LIBDIR is set to \"$RUSTLS_PCDIR\"" >&5 +printf "%s\n" "$as_me: PKG_CONFIG_LIBDIR is set to \"$RUSTLS_PCDIR\"" >&6;} + PKGTEST="yes" + fi + + if test "$PKGTEST" != "yes"; then + RUSTLS_PCDIR="$PREFIX_RUSTLS/lib64/pkgconfig" + if test -f "$RUSTLS_PCDIR/rustls.pc"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: PKG_CONFIG_LIBDIR is set to \"$RUSTLS_PCDIR\"" >&5 +printf "%s\n" "$as_me: PKG_CONFIG_LIBDIR is set to \"$RUSTLS_PCDIR\"" >&6;} + PKGTEST="yes" + fi + fi + + if test "$PKGTEST" != "yes"; then + + addld=-L$PREFIX_RUSTLS/lib$libsuff + addcflags=-I$PREFIX_RUSTLS/include + + LDFLAGS="$LDFLAGS $addld" + LDFLAGSPC="$LDFLAGSPC $addld" + if test "$addcflags" != "-I/usr/include"; then + CPPFLAGS="$CPPFLAGS $addcflags" + fi + + if test "$curl_cv_apple" = "yes"; then + RUSTLS_LDFLAGS="-framework Security -framework Foundation" + else + RUSTLS_LDFLAGS="-lpthread -ldl -lm" + fi + + LIB_RUSTLS="$PREFIX_RUSTLS/lib$libsuff" + if test "$PREFIX_RUSTLS" != "/usr"; then + SSL_LDFLAGS="-L$LIB_RUSTLS $RUSTLS_LDFLAGS" + SSL_CPPFLAGS="-I$PREFIX_RUSTLS/include" + fi + + +printf "%s\n" "#define USE_RUSTLS 1" >>confdefs.h + + USE_RUSTLS="yes" + fi + ;; + esac + + link_pkgconfig='' + + if test "$PKGTEST" = "yes"; then + + + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. +set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKGCONFIG="$PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PKGCONFIG=$ac_cv_path_PKGCONFIG +if test -n "$PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PKGCONFIG" >&5 +printf "%s\n" "$PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_PKGCONFIG"; then + ac_pt_PKGCONFIG=$PKGCONFIG + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_PKGCONFIG="$ac_pt_PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_PKGCONFIG=$ac_cv_path_ac_pt_PKGCONFIG +if test -n "$ac_pt_PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKGCONFIG" >&5 +printf "%s\n" "$ac_pt_PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_PKGCONFIG" = x; then + PKGCONFIG="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + PKGCONFIG=$ac_pt_PKGCONFIG + fi +else + PKGCONFIG="$ac_cv_path_PKGCONFIG" +fi + + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for rustls options with pkg-config" >&5 +printf %s "checking for rustls options with pkg-config... " >&6; } + itexists=` + if test -n "$RUSTLS_PCDIR"; then + if test -n ""; then + PKG_CONFIG_PATH="$RUSTLS_PCDIR${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$RUSTLS_PCDIR" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists rustls >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + + trc=` + if test -n "$RUSTLS_PCDIR"; then + if test -n ""; then + PKG_CONFIG_PATH="$RUSTLS_PCDIR${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$RUSTLS_PCDIR" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug rustls 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$RUSTLS_PCDIR"; then + if test -n ""; then + PKG_CONFIG_PATH="$RUSTLS_PCDIR${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$RUSTLS_PCDIR" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors rustls 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists rustls trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists rustls trace: +---- begin +${trc} +---- end" >&6;} + + fi + PKGCONFIG="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found" >&5 +printf "%s\n" "found" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG"; then + + trc=` + if test -n "$RUSTLS_PCDIR"; then + if test -n ""; then + PKG_CONFIG_PATH="$RUSTLS_PCDIR${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$RUSTLS_PCDIR" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug rustls 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$RUSTLS_PCDIR"; then + if test -n ""; then + PKG_CONFIG_PATH="$RUSTLS_PCDIR${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$RUSTLS_PCDIR" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors rustls 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists rustls trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists rustls trace: +---- begin +${trc} +---- end" >&6;} + + fi + fi + fi + + + if test "$PKGCONFIG" != "no"; then + SSL_LIBS=` + if test -n "$RUSTLS_PCDIR"; then + if test -n ""; then + PKG_CONFIG_PATH="$RUSTLS_PCDIR${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$RUSTLS_PCDIR" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --libs-only-l --libs-only-other rustls 2>/dev/null` + + SSL_LDFLAGS=` + if test -n "$RUSTLS_PCDIR"; then + if test -n ""; then + PKG_CONFIG_PATH="$RUSTLS_PCDIR${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$RUSTLS_PCDIR" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --libs-only-L rustls 2>/dev/null` + + SSL_CPPFLAGS=` + if test -n "$RUSTLS_PCDIR"; then + if test -n ""; then + PKG_CONFIG_PATH="$RUSTLS_PCDIR${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$RUSTLS_PCDIR" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --cflags-only-I rustls 2>/dev/null` + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config: SSL_LIBS: \"$SSL_LIBS\"" >&5 +printf "%s\n" "$as_me: pkg-config: SSL_LIBS: \"$SSL_LIBS\"" >&6;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config: SSL_LDFLAGS: \"$SSL_LDFLAGS\"" >&5 +printf "%s\n" "$as_me: pkg-config: SSL_LDFLAGS: \"$SSL_LDFLAGS\"" >&6;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config: SSL_CPPFLAGS: \"$SSL_CPPFLAGS\"" >&5 +printf "%s\n" "$as_me: pkg-config: SSL_CPPFLAGS: \"$SSL_CPPFLAGS\"" >&6;} + + LIB_RUSTLS=`echo $SSL_LDFLAGS | sed -e 's/^-L//'` + + LIBS="$SSL_LIBS $LIBS" + link_pkgconfig=1 + ssl_msg="Rustls" + +printf "%s\n" "#define USE_RUSTLS 1" >>confdefs.h + + USE_RUSTLS="yes" + RUSTLS_ENABLED=1 + test "rustls" != "$DEFAULT_SSL_BACKEND" || VALID_DEFAULT_SSL_BACKEND=yes + else + as_fn_error $? "pkg-config: Could not find Rustls" "$LINENO" 5 + fi + + else + LIBS="-lrustls -lpthread -ldl -lm $LIBS" + fi + + CPPFLAGS="$CLEANCPPFLAGS $SSL_CPPFLAGS" + LDFLAGS="$CLEANLDFLAGS $SSL_LDFLAGS" + LDFLAGSPC="$CLEANLDFLAGSPC $SSL_LDFLAGS" + + if test "$USE_RUSTLS" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: detected Rustls" >&5 +printf "%s\n" "$as_me: detected Rustls" >&6;} + check_for_ca_bundle=1 + + if test -n "$LIB_RUSTLS"; then + if test "$cross_compiling" != "yes"; then + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$LIB_RUSTLS" + export CURL_LIBRARY_PATH + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: Added $LIB_RUSTLS to CURL_LIBRARY_PATH" >&5 +printf "%s\n" "$as_me: Added $LIB_RUSTLS to CURL_LIBRARY_PATH" >&6;} + fi + fi + if test -n "$link_pkgconfig"; then + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE rustls" + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for rustls_supported_hpke in -lrustls" >&5 +printf %s "checking for rustls_supported_hpke in -lrustls... " >&6; } +if test ${ac_cv_lib_rustls_rustls_supported_hpke+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lrustls $RUSTLS_LDFLAGS $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char rustls_supported_hpke (); +int main(void) +{ +return rustls_supported_hpke (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_rustls_rustls_supported_hpke=yes +else $as_nop + ac_cv_lib_rustls_rustls_supported_hpke=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_rustls_rustls_supported_hpke" >&5 +printf "%s\n" "$ac_cv_lib_rustls_rustls_supported_hpke" >&6; } +if test "x$ac_cv_lib_rustls_rustls_supported_hpke" = xyes +then : + + +printf "%s\n" "#define USE_RUSTLS 1" >>confdefs.h + + RUSTLS_ENABLED=1 + USE_RUSTLS="yes" + ssl_msg="Rustls" + test "rustls" != "$DEFAULT_SSL_BACKEND" || VALID_DEFAULT_SSL_BACKEND=yes + +else $as_nop + as_fn_error $? "--with-rustls was specified but could not find compatible Rustls." "$LINENO" 5 +fi + + fi + + test -z "$ssl_msg" || ssl_backends="${ssl_backends:+$ssl_backends, }$ssl_msg" + + if test "$RUSTLS_ENABLED" != "1"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: OPT_RUSTLS: $OPT_RUSTLS" >&5 +printf "%s\n" "$as_me: OPT_RUSTLS: $OPT_RUSTLS" >&6;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: RUSTLS_ENABLED: $RUSTLS_ENABLED" >&5 +printf "%s\n" "$as_me: RUSTLS_ENABLED: $RUSTLS_ENABLED" >&6;} + as_fn_error $? "--with-rustls was given but Rustls could not be detected" "$LINENO" 5 + fi +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable Apple OS native certificate validation" >&5 +printf %s "checking whether to enable Apple OS native certificate validation... " >&6; } +if test "x$OPT_APPLE_SECTRUST" = "xyes"; then + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #include + #include + +int main(void) +{ + + #if TARGET_OS_MAC + return 0; + #else + #error Not macOS + #endif + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + build_for_apple="yes" + +else $as_nop + + build_for_apple="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + if test "$build_for_apple" = "no"; then + as_fn_error $? "Apple SecTrust can only be enabled for Apple OS targets" "$LINENO" 5 + fi + if test "$OPENSSL_ENABLED" = "1" || test "$GNUTLS_ENABLED" = "1"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define USE_APPLE_SECTRUST 1" >>confdefs.h + + APPLE_SECTRUST_ENABLED=1 + APPLE_SECTRUST_LDFLAGS='-framework CoreFoundation -framework CoreServices -framework Security' + LDFLAGS="$LDFLAGS $APPLE_SECTRUST_LDFLAGS" + LDFLAGSPC="$LDFLAGSPC $APPLE_SECTRUST_LDFLAGS" + else + as_fn_error $? "Apple SecTrust is only supported for OpenSSL/GnuTLS builds" "$LINENO" 5 + fi +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + + +if test "$USE_WIN32_CRYPTO" = "1" || test "$SCHANNEL_ENABLED" = "1"; then + LIBS="-ladvapi32 -lcrypt32 $LIBS" +fi + +if test "$curl_cv_native_windows" = "yes"; then + LIBS="-lbcrypt $LIBS" +fi + +case "x$SSL_DISABLED$OPENSSL_ENABLED$GNUTLS_ENABLED$MBEDTLS_ENABLED$WOLFSSL_ENABLED$SCHANNEL_ENABLED$RUSTLS_ENABLED" in + x) + as_fn_error $? "TLS not detected, you will not be able to use HTTPS, FTPS, NTLM and more. +Use --with-openssl, --with-gnutls, --with-wolfssl, --with-mbedtls, --with-schannel, --with-amissl or --with-rustls to address this." "$LINENO" 5 + ;; + x1) + SSL_ENABLED="1" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: built with one SSL backend" >&5 +printf "%s\n" "$as_me: built with one SSL backend" >&6;} + ;; + xD) + ;; + xD*) + as_fn_error $? "--without-ssl has been set together with an explicit option to use an SSL library +(e.g. --with-openssl, --with-gnutls, --with-wolfssl, --with-mbedtls, --with-schannel, --with-amissl, --with-rustls). +Since these are conflicting parameters, verify which is the desired one and drop the other." "$LINENO" 5 + ;; + *) + SSL_ENABLED="1" + CURL_WITH_MULTI_SSL="1" + +printf "%s\n" "#define CURL_WITH_MULTI_SSL 1" >>confdefs.h + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: built with multiple SSL backends" >&5 +printf "%s\n" "$as_me: built with multiple SSL backends" >&6;} + ;; +esac + +if test -n "$ssl_backends"; then + curl_ssl_msg="enabled ($ssl_backends)" +fi + +if test "$VALID_DEFAULT_SSL_BACKEND" = "no"; then + if test -n "$SSL_ENABLED"; then + as_fn_error $? "Default SSL backend $DEFAULT_SSL_BACKEND not enabled!" "$LINENO" 5 + else + as_fn_error $? "Default SSL backend requires SSL!" "$LINENO" 5 + fi +elif test "$VALID_DEFAULT_SSL_BACKEND" = "yes"; then + +printf "%s\n" "#define CURL_DEFAULT_SSL_BACKEND \"$DEFAULT_SSL_BACKEND\"" >>confdefs.h + +fi + + +ca_native_opt=0 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to use native CA store" >&5 +printf %s "checking whether to use native CA store... " >&6; } +# Check whether --enable-ca-native was given. +if test ${enable_ca_native+y} +then : + enableval=$enable_ca_native; case "$enableval" in + yes) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define CURL_CA_NATIVE 1" >>confdefs.h + + ca_native_opt=1 + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +fi + + + +if test -n "$check_for_ca_bundle"; then + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking default CA cert bundle/path" >&5 +printf %s "checking default CA cert bundle/path... " >&6; } + + +# Check whether --with-ca-bundle was given. +if test ${with_ca_bundle+y} +then : + withval=$with_ca_bundle; + want_ca="$withval" + if test "x$want_ca" = "xyes"; then + as_fn_error $? "--with-ca-bundle=FILE requires a path to the CA bundle" "$LINENO" 5 + fi + +else $as_nop + want_ca="unset" +fi + + +# Check whether --with-ca-path was given. +if test ${with_ca_path+y} +then : + withval=$with_ca_path; + want_capath="$withval" + if test "x$want_capath" = "xyes"; then + as_fn_error $? "--with-ca-path=DIRECTORY requires a path to the CA path directory" "$LINENO" 5 + fi + +else $as_nop + want_capath="unset" +fi + + + ca_warning=" (warning: certs not found)" + capath_warning=" (warning: certs not found)" + check_capath="" + + if test "$APPLE_SECTRUST_ENABLED" = "1"; then + ca_native="Apple SecTrust" + elif test "$ca_native_opt" = "1"; then + ca_native="yes" + else + ca_native="no" + fi + + if test "x$want_ca" != "xno" && test "x$want_ca" != "xunset" && + test "x$want_capath" != "xno" && test "x$want_capath" != "xunset"; then + ca="$want_ca" + capath="$want_capath" + elif test "x$want_ca" != "xno" && test "x$want_ca" != "xunset"; then + ca="$want_ca" + capath="no" + elif test "x$want_capath" != "xno" && test "x$want_capath" != "xunset"; then + capath="$want_capath" + ca="no" + elif test "$ca_native" != "no"; then + ca="no" + capath="no" + else + ca="no" + capath="no" + if test "$cross_compiling" != "yes" && + test "$curl_cv_native_windows" != "yes"; then + if test "x$want_ca" = "xunset"; then + if test "x$prefix" != "xNONE"; then + cac="${prefix}/share/curl/curl-ca-bundle.crt" + else + cac="$ac_default_prefix/share/curl/curl-ca-bundle.crt" + fi + + for a in /etc/ssl/certs/ca-certificates.crt \ + /etc/pki/tls/certs/ca-bundle.crt \ + /usr/share/ssl/certs/ca-bundle.crt \ + /usr/local/share/certs/ca-root-nss.crt \ + /etc/ssl/cert.pem \ + "$cac"; do + if test -f "$a"; then + ca="$a" + break + fi + done + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: want $want_capath CA $ca" >&5 +printf "%s\n" "$as_me: want $want_capath CA $ca" >&6;} + if test "x$want_capath" = "xunset"; then + check_capath="/etc/ssl/certs" + fi + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: skipped the ca-cert path detection when cross-compiling" >&5 +printf "%s\n" "$as_me: WARNING: skipped the ca-cert path detection when cross-compiling" >&2;} + fi + fi + + if test "x$ca" = "xno" || test -f "$ca"; then + ca_warning="" + fi + + if test "x$capath" != "xno"; then + check_capath="$capath" + fi + + if test -n "$check_capath"; then + for a in "$check_capath"; do + if test -d "$a" && ls "$a"/[0-9a-f][0-9a-f][0-9a-f][0-9a-f][0-9a-f][0-9a-f][0-9a-f][0-9a-f].0 >/dev/null 2>/dev/null; then + if test "x$capath" = "xno"; then + capath="$a" + fi + capath_warning="" + break + fi + done + fi + + if test "x$capath" = "xno"; then + capath_warning="" + fi + + if test "x$ca" != "xno"; then + CURL_CA_BUNDLE="$ca" + +printf "%s\n" "#define CURL_CA_BUNDLE \"$ca\"" >>confdefs.h + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ca" >&5 +printf "%s\n" "$ca" >&6; } + fi + if test "x$capath" != "xno"; then + CURL_CA_PATH="\"$capath\"" + +printf "%s\n" "#define CURL_CA_PATH \"$capath\"" >>confdefs.h + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $capath (capath)" >&5 +printf "%s\n" "$capath (capath)" >&6; } + fi + if test "x$ca" = "xno" && test "x$capath" = "xno"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to use OpenSSL's built-in CA store" >&5 +printf %s "checking whether to use OpenSSL's built-in CA store... " >&6; } + +# Check whether --with-ca-fallback was given. +if test ${with_ca_fallback+y} +then : + withval=$with_ca_fallback; + if test "x$with_ca_fallback" != "xyes" && test "x$with_ca_fallback" != "xno"; then + as_fn_error $? "--with-ca-fallback only allows yes or no as parameter" "$LINENO" 5 + fi + +else $as_nop + with_ca_fallback="no" +fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $with_ca_fallback" >&5 +printf "%s\n" "$with_ca_fallback" >&6; } + if test "x$with_ca_fallback" = "xyes"; then + if test "$OPENSSL_ENABLED" != "1"; then + as_fn_error $? "--with-ca-fallback only works with OpenSSL" "$LINENO" 5 + fi + +printf "%s\n" "#define CURL_CA_FALLBACK 1" >>confdefs.h + + fi + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking CA cert bundle path to embed in the curl tool" >&5 +printf %s "checking CA cert bundle path to embed in the curl tool... " >&6; } + + +# Check whether --with-ca-embed was given. +if test ${with_ca_embed+y} +then : + withval=$with_ca_embed; + want_ca_embed="$withval" + if test "x$want_ca_embed" = "xyes"; then + as_fn_error $? "--with-ca-embed=FILE requires a path to the CA bundle" "$LINENO" 5 + fi + +else $as_nop + want_ca_embed="unset" +fi + + + CURL_CA_EMBED='' + if test "x$want_ca_embed" != "xno" && test "x$want_ca_embed" != "xunset" && test -f "$want_ca_embed"; then + if test -n "$PERL"; then + CURL_CA_EMBED="$want_ca_embed" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $want_ca_embed" >&5 +printf "%s\n" "$want_ca_embed" >&6; } + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: perl was not found. Cannot do CA embed." >&5 +printf "%s\n" "$as_me: WARNING: perl was not found. Cannot do CA embed." >&2;} + fi + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + fi + +fi + + if test -n "$CURL_CA_EMBED"; then + CURL_CA_EMBED_SET_TRUE= + CURL_CA_EMBED_SET_FALSE='#' +else + CURL_CA_EMBED_SET_TRUE='#' + CURL_CA_EMBED_SET_FALSE= +fi + + + +if test "$curl_cv_native_windows" = "yes"; then + ca_search=1 + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable unsafe CA bundle search in PATH on Windows" >&5 +printf %s "checking whether to enable unsafe CA bundle search in PATH on Windows... " >&6; } + # Check whether --enable-ca-search was given. +if test ${enable_ca_search+y} +then : + enableval=$enable_ca_search; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + ca_search=0 + ;; + yes) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + *) + if test "$ca_native_opt" = "1"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + ca_search=0 + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + fi + ;; + esac +else $as_nop + if test "$ca_native_opt" = "1"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + ca_search=0 + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + fi + +fi + + if test "$ca_search" = "0"; then + +printf "%s\n" "#define CURL_DISABLE_CA_SEARCH 1" >>confdefs.h + + fi +fi + + +if test "$curl_cv_native_windows" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable safe CA bundle search (within the curl tool directory) on Windows" >&5 +printf %s "checking whether to enable safe CA bundle search (within the curl tool directory) on Windows... " >&6; } + # Check whether --enable-ca-search-safe was given. +if test ${enable_ca_search_safe+y} +then : + enableval=$enable_ca_search_safe; case "$enableval" in + yes) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define CURL_CA_SEARCH_SAFE 1" >>confdefs.h + + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +fi + +fi + + +OPT_LIBPSL=off + +# Check whether --with-libpsl was given. +if test ${with_libpsl+y} +then : + withval=$with_libpsl; OPT_LIBPSL=$withval +fi + + +if test "x$OPT_LIBPSL" != "xno"; then + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + case "$OPT_LIBPSL" in + yes|off) + + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. +set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKGCONFIG="$PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PKGCONFIG=$ac_cv_path_PKGCONFIG +if test -n "$PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PKGCONFIG" >&5 +printf "%s\n" "$PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_PKGCONFIG"; then + ac_pt_PKGCONFIG=$PKGCONFIG + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_PKGCONFIG="$ac_pt_PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_PKGCONFIG=$ac_cv_path_ac_pt_PKGCONFIG +if test -n "$ac_pt_PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKGCONFIG" >&5 +printf "%s\n" "$ac_pt_PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_PKGCONFIG" = x; then + PKGCONFIG="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + PKGCONFIG=$ac_pt_PKGCONFIG + fi +else + PKGCONFIG="$ac_cv_path_PKGCONFIG" +fi + + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for libpsl options with pkg-config" >&5 +printf %s "checking for libpsl options with pkg-config... " >&6; } + itexists=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists libpsl >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + + trc=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libpsl 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libpsl 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libpsl trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libpsl trace: +---- begin +${trc} +---- end" >&6;} + + fi + PKGCONFIG="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found" >&5 +printf "%s\n" "found" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG"; then + + trc=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libpsl 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libpsl 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libpsl trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libpsl trace: +---- begin +${trc} +---- end" >&6;} + + fi + fi + fi + + + if test "$PKGCONFIG" != "no"; then + LIB_PSL=`$PKGCONFIG --libs-only-l libpsl` + LD_PSL=`$PKGCONFIG --libs-only-L libpsl` + CPP_PSL=`$PKGCONFIG --cflags-only-I libpsl` + else + LIB_PSL="-lpsl" + fi + + ;; + *) + LIB_PSL="-lpsl" + PREFIX_PSL=$OPT_LIBPSL + ;; + esac + + if test -n "$PREFIX_PSL"; then + LD_PSL=-L${PREFIX_PSL}/lib$libsuff + CPP_PSL=-I${PREFIX_PSL}/include + fi + + LDFLAGS="$LDFLAGS $LD_PSL" + LDFLAGSPC="$LDFLAGSPC $LD_PSL" + CPPFLAGS="$CPPFLAGS $CPP_PSL" + LIBS="$LIB_PSL $LIBS" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for psl_builtin in -lpsl" >&5 +printf %s "checking for psl_builtin in -lpsl... " >&6; } +if test ${ac_cv_lib_psl_psl_builtin+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lpsl $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char psl_builtin (); +int main(void) +{ +return psl_builtin (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_psl_psl_builtin=yes +else $as_nop + ac_cv_lib_psl_psl_builtin=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_psl_psl_builtin" >&5 +printf "%s\n" "$ac_cv_lib_psl_psl_builtin" >&6; } +if test "x$ac_cv_lib_psl_psl_builtin" = xyes +then : + + for ac_header in libpsl.h +do : + ac_fn_c_check_header_compile "$LINENO" "libpsl.h" "ac_cv_header_libpsl_h" "$ac_includes_default" +if test "x$ac_cv_header_libpsl_h" = xyes +then : + printf "%s\n" "#define HAVE_LIBPSL_H 1" >>confdefs.h + curl_psl_msg="enabled" + +printf "%s\n" "#define USE_LIBPSL 1" >>confdefs.h + + USE_LIBPSL=1 + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libpsl" + +fi + +done + +else $as_nop + LDFLAGS=$CLEANLDFLAGS + LDFLAGSPC=$CLEANLDFLAGSPC + CPPFLAGS=$CLEANCPPFLAGS + LIBS=$CLEANLIBS + +fi + + + if test "$USE_LIBPSL" != "1"; then + as_fn_error $? "libpsl libs and/or directories were not found where specified!" "$LINENO" 5 + fi +fi + if test "$curl_psl_msg" = "enabled"; then + USE_LIBPSL_TRUE= + USE_LIBPSL_FALSE='#' +else + USE_LIBPSL_TRUE='#' + USE_LIBPSL_FALSE= +fi + + + +OPT_LIBGSASL=no + +# Check whether --with-libgsasl was given. +if test ${with_libgsasl+y} +then : + withval=$with_libgsasl; OPT_LIBGSASL=$withval +fi + + +if test "x$OPT_LIBGSASL" != "xno"; then + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + case "$OPT_LIBGSASL" in + yes) + + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. +set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKGCONFIG="$PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PKGCONFIG=$ac_cv_path_PKGCONFIG +if test -n "$PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PKGCONFIG" >&5 +printf "%s\n" "$PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_PKGCONFIG"; then + ac_pt_PKGCONFIG=$PKGCONFIG + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_PKGCONFIG="$ac_pt_PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_PKGCONFIG=$ac_cv_path_ac_pt_PKGCONFIG +if test -n "$ac_pt_PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKGCONFIG" >&5 +printf "%s\n" "$ac_pt_PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_PKGCONFIG" = x; then + PKGCONFIG="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + PKGCONFIG=$ac_pt_PKGCONFIG + fi +else + PKGCONFIG="$ac_cv_path_PKGCONFIG" +fi + + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for libgsasl options with pkg-config" >&5 +printf %s "checking for libgsasl options with pkg-config... " >&6; } + itexists=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists libgsasl >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + + trc=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libgsasl 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libgsasl 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libgsasl trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libgsasl trace: +---- begin +${trc} +---- end" >&6;} + + fi + PKGCONFIG="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found" >&5 +printf "%s\n" "found" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG"; then + + trc=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libgsasl 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libgsasl 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libgsasl trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libgsasl trace: +---- begin +${trc} +---- end" >&6;} + + fi + fi + fi + + + if test "$PKGCONFIG" != "no"; then + LIB_GSASL=`$PKGCONFIG --libs-only-l libgsasl` + LD_GSASL=`$PKGCONFIG --libs-only-L libgsasl` + CPP_GSASL=`$PKGCONFIG --cflags-only-I libgsasl` + else + LIB_GSASL="-lgsasl" + fi + ;; + *) + PREFIX_GSASL=$OPT_LIBGSASL + ;; + esac + + if test -n "$PREFIX_GSASL"; then + LIB_GSASL="-lgsasl" + LD_GSASL=-L${PREFIX_GSASL}/lib$libsuff + CPP_GSASL=-I${PREFIX_GSASL}/include + fi + + LDFLAGS="$LDFLAGS $LD_GSASL" + LDFLAGSPC="$LDFLAGSPC $LD_GSASL" + CPPFLAGS="$CPPFLAGS $CPP_GSASL" + LIBS="$LIB_GSASL $LIBS" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gsasl_init in -lgsasl" >&5 +printf %s "checking for gsasl_init in -lgsasl... " >&6; } +if test ${ac_cv_lib_gsasl_gsasl_init+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lgsasl $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char gsasl_init (); +int main(void) +{ +return gsasl_init (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_gsasl_gsasl_init=yes +else $as_nop + ac_cv_lib_gsasl_gsasl_init=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_gsasl_gsasl_init" >&5 +printf "%s\n" "$ac_cv_lib_gsasl_gsasl_init" >&6; } +if test "x$ac_cv_lib_gsasl_gsasl_init" = xyes +then : + + for ac_header in gsasl.h +do : + ac_fn_c_check_header_compile "$LINENO" "gsasl.h" "ac_cv_header_gsasl_h" "$ac_includes_default" +if test "x$ac_cv_header_gsasl_h" = xyes +then : + printf "%s\n" "#define HAVE_GSASL_H 1" >>confdefs.h + curl_gsasl_msg="enabled" + +printf "%s\n" "#define USE_GSASL 1" >>confdefs.h + + USE_LIBGSASL=1 + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libgsasl" + +fi + +done + +else $as_nop + LDFLAGS=$CLEANLDFLAGS + LDFLAGSPC=$CLEANLDFLAGSPC + CPPFLAGS=$CLEANCPPFLAGS + LIBS=$CLEANLIBS + curl_gsasl_msg="no (libgsasl not found)" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: libgsasl was not found" >&5 +printf "%s\n" "$as_me: WARNING: libgsasl was not found" >&2;} + +fi + +fi + if test "$curl_gsasl_msg" = "enabled"; then + USE_GSASL_TRUE= + USE_GSASL_FALSE='#' +else + USE_GSASL_TRUE='#' + USE_GSASL_FALSE= +fi + + + +# Check whether --with-libmetalink was given. +if test ${with_libmetalink+y} +then : + withval=$with_libmetalink; as_fn_error $? "--with-libmetalink and --without-libmetalink no longer work!" "$LINENO" 5 +fi + + + +OPT_LIBSSH2=off + +# Check whether --with-libssh2 was given. +if test ${with_libssh2+y} +then : + withval=$with_libssh2; OPT_LIBSSH2=$withval +else $as_nop + OPT_LIBSSH2=no +fi + + +OPT_LIBSSH=off + +# Check whether --with-libssh was given. +if test ${with_libssh+y} +then : + withval=$with_libssh; OPT_LIBSSH=$withval +else $as_nop + OPT_LIBSSH=no +fi + + +if test "x$OPT_LIBSSH2" != "xno"; then + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + case "$OPT_LIBSSH2" in + yes) + + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. +set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKGCONFIG="$PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PKGCONFIG=$ac_cv_path_PKGCONFIG +if test -n "$PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PKGCONFIG" >&5 +printf "%s\n" "$PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_PKGCONFIG"; then + ac_pt_PKGCONFIG=$PKGCONFIG + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_PKGCONFIG="$ac_pt_PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_PKGCONFIG=$ac_cv_path_ac_pt_PKGCONFIG +if test -n "$ac_pt_PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKGCONFIG" >&5 +printf "%s\n" "$ac_pt_PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_PKGCONFIG" = x; then + PKGCONFIG="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + PKGCONFIG=$ac_pt_PKGCONFIG + fi +else + PKGCONFIG="$ac_cv_path_PKGCONFIG" +fi + + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for libssh2 options with pkg-config" >&5 +printf %s "checking for libssh2 options with pkg-config... " >&6; } + itexists=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists libssh2 >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + + trc=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libssh2 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libssh2 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libssh2 trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libssh2 trace: +---- begin +${trc} +---- end" >&6;} + + fi + PKGCONFIG="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found" >&5 +printf "%s\n" "found" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG"; then + + trc=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libssh2 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libssh2 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libssh2 trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libssh2 trace: +---- begin +${trc} +---- end" >&6;} + + fi + fi + fi + + + if test "$PKGCONFIG" != "no"; then + LIB_SSH2=`$PKGCONFIG --libs-only-l libssh2` + LD_SSH2=`$PKGCONFIG --libs-only-L libssh2` + CPP_SSH2=`$PKGCONFIG --cflags-only-I libssh2` + version=`$PKGCONFIG --modversion libssh2` + DIR_SSH2=`echo $LD_SSH2 | $SED -e 's/^-L//'` + fi + + ;; + off) + ;; + *) + PREFIX_SSH2=$OPT_LIBSSH2 + ;; + esac + + if test -n "$PREFIX_SSH2"; then + LIB_SSH2="-lssh2" + LD_SSH2=-L${PREFIX_SSH2}/lib$libsuff + CPP_SSH2=-I${PREFIX_SSH2}/include + DIR_SSH2=${PREFIX_SSH2}/lib$libsuff + fi + + LDFLAGS="$LDFLAGS $LD_SSH2" + LDFLAGSPC="$LDFLAGSPC $LD_SSH2" + CPPFLAGS="$CPPFLAGS $CPP_SSH2" + LIBS="$LIB_SSH2 $LIBS" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for libssh2_agent_get_identity_path in -lssh2" >&5 +printf %s "checking for libssh2_agent_get_identity_path in -lssh2... " >&6; } +if test ${ac_cv_lib_ssh2_libssh2_agent_get_identity_path+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lssh2 $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char libssh2_agent_get_identity_path (); +int main(void) +{ +return libssh2_agent_get_identity_path (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_ssh2_libssh2_agent_get_identity_path=yes +else $as_nop + ac_cv_lib_ssh2_libssh2_agent_get_identity_path=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_ssh2_libssh2_agent_get_identity_path" >&5 +printf "%s\n" "$ac_cv_lib_ssh2_libssh2_agent_get_identity_path" >&6; } +if test "x$ac_cv_lib_ssh2_libssh2_agent_get_identity_path" = xyes +then : + printf "%s\n" "#define HAVE_LIBSSH2 1" >>confdefs.h + + LIBS="-lssh2 $LIBS" + +fi + + + ac_fn_c_check_header_compile "$LINENO" "libssh2.h" "ac_cv_header_libssh2_h" "$ac_includes_default" +if test "x$ac_cv_header_libssh2_h" = xyes +then : + curl_ssh_msg="enabled (libssh2)" + +printf "%s\n" "#define USE_LIBSSH2 1" >>confdefs.h + + USE_LIBSSH2=1 + +fi + + + if test "x$OPT_LIBSSH2" != "xoff" && + test "$USE_LIBSSH2" != "1"; then + as_fn_error $? "libssh2 libs and/or directories were not found where specified!" "$LINENO" 5 + fi + + if test "$USE_LIBSSH2" = "1"; then + if test -n "$DIR_SSH2"; then + + if test "$cross_compiling" != "yes"; then + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$DIR_SSH2" + export CURL_LIBRARY_PATH + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: Added $DIR_SSH2 to CURL_LIBRARY_PATH" >&5 +printf "%s\n" "$as_me: Added $DIR_SSH2 to CURL_LIBRARY_PATH" >&6;} + fi + fi + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libssh2" + else + LDFLAGS=$CLEANLDFLAGS + LDFLAGSPC=$CLEANLDFLAGSPC + CPPFLAGS=$CLEANCPPFLAGS + LIBS=$CLEANLIBS + fi +elif test "x$OPT_LIBSSH" != "xno"; then + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + case "$OPT_LIBSSH" in + yes) + + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. +set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKGCONFIG="$PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PKGCONFIG=$ac_cv_path_PKGCONFIG +if test -n "$PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PKGCONFIG" >&5 +printf "%s\n" "$PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_PKGCONFIG"; then + ac_pt_PKGCONFIG=$PKGCONFIG + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_PKGCONFIG="$ac_pt_PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_PKGCONFIG=$ac_cv_path_ac_pt_PKGCONFIG +if test -n "$ac_pt_PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKGCONFIG" >&5 +printf "%s\n" "$ac_pt_PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_PKGCONFIG" = x; then + PKGCONFIG="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + PKGCONFIG=$ac_pt_PKGCONFIG + fi +else + PKGCONFIG="$ac_cv_path_PKGCONFIG" +fi + + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for libssh options with pkg-config" >&5 +printf %s "checking for libssh options with pkg-config... " >&6; } + itexists=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists libssh >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + + trc=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libssh 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libssh 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libssh trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libssh trace: +---- begin +${trc} +---- end" >&6;} + + fi + PKGCONFIG="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found" >&5 +printf "%s\n" "found" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG"; then + + trc=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libssh 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libssh 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libssh trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libssh trace: +---- begin +${trc} +---- end" >&6;} + + fi + fi + fi + + + if test "$PKGCONFIG" != "no"; then + LIB_SSH=`$PKGCONFIG --libs-only-l libssh` + LD_SSH=`$PKGCONFIG --libs-only-L libssh` + CPP_SSH=`$PKGCONFIG --cflags-only-I libssh` + version=`$PKGCONFIG --modversion libssh` + DIR_SSH=`echo $LD_SSH | $SED -e 's/^-L//'` + fi + + ;; + off) + ;; + *) + PREFIX_SSH=$OPT_LIBSSH + ;; + esac + + if test -n "$PREFIX_SSH"; then + LIB_SSH="-lssh" + LD_SSH=-L${PREFIX_SSH}/lib$libsuff + CPP_SSH=-I${PREFIX_SSH}/include + DIR_SSH=${PREFIX_SSH}/lib$libsuff + fi + + LDFLAGS="$LDFLAGS $LD_SSH" + LDFLAGSPC="$LDFLAGSPC $LD_SSH" + CPPFLAGS="$CPPFLAGS $CPP_SSH" + LIBS="$LIB_SSH $LIBS" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for ssh_new in -lssh" >&5 +printf %s "checking for ssh_new in -lssh... " >&6; } +if test ${ac_cv_lib_ssh_ssh_new+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lssh $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char ssh_new (); +int main(void) +{ +return ssh_new (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_ssh_ssh_new=yes +else $as_nop + ac_cv_lib_ssh_ssh_new=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_ssh_ssh_new" >&5 +printf "%s\n" "$ac_cv_lib_ssh_ssh_new" >&6; } +if test "x$ac_cv_lib_ssh_ssh_new" = xyes +then : + printf "%s\n" "#define HAVE_LIBSSH 1" >>confdefs.h + + LIBS="-lssh $LIBS" + +fi + + + ac_fn_c_check_header_compile "$LINENO" "libssh/libssh.h" "ac_cv_header_libssh_libssh_h" "$ac_includes_default" +if test "x$ac_cv_header_libssh_libssh_h" = xyes +then : + curl_ssh_msg="enabled (libssh)" + +printf "%s\n" "#define USE_LIBSSH 1" >>confdefs.h + + USE_LIBSSH=1 + +fi + + + if test "x$OPT_LIBSSH" != "xoff" && + test "$USE_LIBSSH" != "1"; then + as_fn_error $? "libssh libs and/or directories were not found where specified!" "$LINENO" 5 + fi + + if test "$USE_LIBSSH" = "1"; then + if test "$curl_cv_native_windows" = "yes"; then + LIBS="-liphlpapi $LIBS" + fi + if test -n "$DIR_SSH"; then + + if test "$cross_compiling" != "yes"; then + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$DIR_SSH" + export CURL_LIBRARY_PATH + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: Added $DIR_SSH to CURL_LIBRARY_PATH" >&5 +printf "%s\n" "$as_me: Added $DIR_SSH to CURL_LIBRARY_PATH" >&6;} + fi + fi + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libssh" + else + LDFLAGS=$CLEANLDFLAGS + LDFLAGSPC=$CLEANLDFLAGSPC + CPPFLAGS=$CLEANCPPFLAGS + LIBS=$CLEANLIBS + fi +fi + + +LDAPLIBNAME="" + +# Check whether --with-ldap-lib was given. +if test ${with_ldap_lib+y} +then : + withval=$with_ldap_lib; LDAPLIBNAME="$withval" +fi + + +LBERLIBNAME="" + +# Check whether --with-lber-lib was given. +if test ${with_lber_lib+y} +then : + withval=$with_lber_lib; LBERLIBNAME="$withval" +fi + + +clean_LDAP_CPPFLAGS=$CPPFLAGS +clean_LDAP_LDFLAGS=$LDFLAGS +clean_LDAP_LIBS=$LIBS +OPT_LDAP=off + +# Check whether --with-ldap was given. +if test ${with_ldap+y} +then : + withval=$with_ldap; OPT_LDAP=$withval +fi + + +case "$OPT_LDAP" in + no) + want_ldap="no" + ;; + yes) + want_ldap="yes" + ;; + off) + want_ldap="default" + ;; + *) + want_ldap="yes" + if test -d "$OPT_LDAP/lib$libsuff"; then + LDFLAGS="$LDFLAGS -L$OPT_LDAP/lib$libsuff" + DIR_LDAP="$OPT_LDAP/lib$libsuff" + elif test -d "$OPT_LDAP/lib"; then + LDFLAGS="$LDFLAGS -L$OPT_LDAP/lib" + DIR_LDAP="$OPT_LDAP/lib" + fi + if test -d "$OPT_LDAP/include"; then + CPPFLAGS="$CPPFLAGS -I$OPT_LDAP/include" + fi + ldap_askedfor="yes" + ;; +esac + +if test "$CURL_DISABLE_LDAP" != "1" && test "$want_ldap" != "no"; then + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for lber.h" >&5 +printf %s "checking for lber.h... " >&6; } +if test ${curl_cv_header_lber_h+y} +then : + printf %s "(cached) " >&6 +else $as_nop + + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #undef inline + #ifdef _WIN32 + #ifndef WIN32_LEAN_AND_MEAN + #define WIN32_LEAN_AND_MEAN + #endif + #include + #else + #ifdef HAVE_SYS_TYPES_H + #include + #endif + #endif + #ifndef NULL + #define NULL (void *)0 + #endif + #include + +int main(void) +{ + + BerValue *bvp = NULL; + BerElement *bep = ber_init(bvp); + ber_free(bep, 1); + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + curl_cv_header_lber_h="yes" + +else $as_nop + + curl_cv_header_lber_h="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $curl_cv_header_lber_h" >&5 +printf "%s\n" "$curl_cv_header_lber_h" >&6; } + if test "$curl_cv_header_lber_h" = "yes"; then + +printf "%s\n" "#define HAVE_LBER_H 1" >>confdefs.h + + + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #undef inline + #ifdef _WIN32 + #ifndef WIN32_LEAN_AND_MEAN + #define WIN32_LEAN_AND_MEAN + #endif + #include + #else + #ifdef HAVE_SYS_TYPES_H + #include + #endif + #endif + #ifndef NULL + #define NULL (void *)0 + #endif + #ifndef LDAP_DEPRECATED + #define LDAP_DEPRECATED 1 + #endif + #include + +int main(void) +{ + + BerValue *bvp = NULL; + BerElement *bep = ber_init(bvp); + ber_free(bep, 1); + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + curl_cv_need_header_lber_h="no" + +else $as_nop + + curl_cv_need_header_lber_h="yes" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + + case "$curl_cv_need_header_lber_h" in + yes) + +printf "%s\n" "#define NEED_LBER_H 1" >>confdefs.h + + ;; + esac + fi + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for ldap.h" >&5 +printf %s "checking for ldap.h... " >&6; } +if test ${curl_cv_header_ldap_h+y} +then : + printf %s "(cached) " >&6 +else $as_nop + + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #undef inline + #ifdef _WIN32 + #ifndef WIN32_LEAN_AND_MEAN + #define WIN32_LEAN_AND_MEAN + #endif + #include + #else + #ifdef HAVE_SYS_TYPES_H + #include + #endif + #endif + #ifndef LDAP_DEPRECATED + #define LDAP_DEPRECATED 1 + #endif + #ifdef NEED_LBER_H + #include + #endif + #include + +int main(void) +{ + + LDAP *ldp = ldap_init("0.0.0.0", LDAP_PORT); + int res = ldap_unbind(ldp); + (void)res; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + curl_cv_header_ldap_h="yes" + +else $as_nop + + curl_cv_header_ldap_h="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $curl_cv_header_ldap_h" >&5 +printf "%s\n" "$curl_cv_header_ldap_h" >&6; } + case "$curl_cv_header_ldap_h" in + yes) + +printf "%s\n" "#define HAVE_LDAP_H 1" >>confdefs.h + + ;; + esac + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for ldap_ssl.h" >&5 +printf %s "checking for ldap_ssl.h... " >&6; } +if test ${curl_cv_header_ldap_ssl_h+y} +then : + printf %s "(cached) " >&6 +else $as_nop + + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #undef inline + #ifdef _WIN32 + #ifndef WIN32_LEAN_AND_MEAN + #define WIN32_LEAN_AND_MEAN + #endif + #include + #else + #ifdef HAVE_SYS_TYPES_H + #include + #endif + #endif + #ifndef LDAP_DEPRECATED + #define LDAP_DEPRECATED 1 + #endif + #ifdef NEED_LBER_H + #include + #endif + #ifdef HAVE_LDAP_H + #include + #endif + #include + +int main(void) +{ + + LDAP *ldp = ldapssl_init("0.0.0.0", LDAPS_PORT, 1); + (void)ldp; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + curl_cv_header_ldap_ssl_h="yes" + +else $as_nop + + curl_cv_header_ldap_ssl_h="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $curl_cv_header_ldap_ssl_h" >&5 +printf "%s\n" "$curl_cv_header_ldap_ssl_h" >&6; } + case "$curl_cv_header_ldap_ssl_h" in + yes) + +printf "%s\n" "#define HAVE_LDAP_SSL_H 1" >>confdefs.h + + ;; + esac + + + if test -z "$LDAPLIBNAME"; then + if test "$curl_cv_native_windows" = "yes" && test "$curl_cv_winuwp" != "yes"; then + LDAPLIBNAME="wldap32" + LBERLIBNAME="no" + fi + fi + + if test "$LDAPLIBNAME"; then + if test "$LBERLIBNAME" && test "$LBERLIBNAME" != "no"; then + as_ac_Lib=`printf "%s\n" "ac_cv_lib_"$LDAPLIBNAME"""_ldap_init" | $as_tr_sh` +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for ldap_init in -l\"$LDAPLIBNAME\"" >&5 +printf %s "checking for ldap_init in -l\"$LDAPLIBNAME\"... " >&6; } +if eval test \${$as_ac_Lib+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-l"$LDAPLIBNAME" $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char ldap_init (); +int main(void) +{ +return ldap_init (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + eval "$as_ac_Lib=yes" +else $as_nop + eval "$as_ac_Lib=no" +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +eval ac_res=\$$as_ac_Lib + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +printf "%s\n" "$ac_res" >&6; } +if eval test \"x\$"$as_ac_Lib"\" = x"yes" +then : + ldap_lib_ok=yes +else $as_nop + ldap_lib_ok=no +fi + + if test "$ldap_lib_ok" = "no"; then + as_ac_Lib=`printf "%s\n" "ac_cv_lib_"$LDAPLIBNAME"""_ldap_unbind" | $as_tr_sh` +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for ldap_unbind in -l\"$LDAPLIBNAME\"" >&5 +printf %s "checking for ldap_unbind in -l\"$LDAPLIBNAME\"... " >&6; } +if eval test \${$as_ac_Lib+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-l"$LDAPLIBNAME" -l$LBERLIBNAME $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char ldap_unbind (); +int main(void) +{ +return ldap_unbind (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + eval "$as_ac_Lib=yes" +else $as_nop + eval "$as_ac_Lib=no" +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +eval ac_res=\$$as_ac_Lib + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +printf "%s\n" "$ac_res" >&6; } +if eval test \"x\$"$as_ac_Lib"\" = x"yes" +then : + ldap_lib_ok=yes +else $as_nop + ldap_lib_ok=no +fi + + if test "$ldap_lib_ok" = "yes"; then + LIBS="-l$LDAPLIBNAME -l$LBERLIBNAME $LIBS" + fi + else + LIBS="-l$LDAPLIBNAME $LIBS" + fi + else + as_ac_Lib=`printf "%s\n" "ac_cv_lib_"$LDAPLIBNAME"""_ldap_init" | $as_tr_sh` +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for ldap_init in -l\"$LDAPLIBNAME\"" >&5 +printf %s "checking for ldap_init in -l\"$LDAPLIBNAME\"... " >&6; } +if eval test \${$as_ac_Lib+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-l"$LDAPLIBNAME" $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char ldap_init (); +int main(void) +{ +return ldap_init (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + eval "$as_ac_Lib=yes" +else $as_nop + eval "$as_ac_Lib=no" +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +eval ac_res=\$$as_ac_Lib + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +printf "%s\n" "$ac_res" >&6; } +if eval test \"x\$"$as_ac_Lib"\" = x"yes" +then : + ldap_lib_ok=yes; LIBS="-l$LDAPLIBNAME $LIBS" +else $as_nop + ldap_lib_ok=no +fi + + fi + + if test "$ldap_lib_ok" = "no"; then + if test -n "$ldap_askedfor"; then + as_fn_error $? "could not detect the LDAP libraries" "$LINENO" 5 + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: \"$LDAPLIBNAME\" is not an LDAP library: LDAP disabled" >&5 +printf "%s\n" "$as_me: WARNING: \"$LDAPLIBNAME\" is not an LDAP library: LDAP disabled" >&2;} + +printf "%s\n" "#define CURL_DISABLE_LDAP 1" >>confdefs.h + + CURL_DISABLE_LDAP=1 + +printf "%s\n" "#define CURL_DISABLE_LDAPS 1" >>confdefs.h + + CURL_DISABLE_LDAPS=1 + CPPFLAGS=$clean_LDAP_CPPFLAGS + LDFLAGS=$clean_LDAP_LDFLAGS + LIBS=$clean_LDAP_LIBS + fi + else + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for LDAP libraries" >&5 +printf %s "checking for LDAP libraries... " >&6; } + + u_libs="" + + + + curl_cv_save_LIBS="$LIBS" + curl_cv_ldap_LIBS="unknown" + + for x_nlibs in '' "$u_libs" \ + '-lldap' \ + '-lldap -llber' \ + '-llber -lldap' \ + '-lldapssl -lldapx -lldapsdk' \ + '-lldapsdk -lldapx -lldapssl' \ + '-lldap -llber -lssl -lcrypto'; do + + if test "$curl_cv_ldap_LIBS" = "unknown"; then + if test -z "$x_nlibs"; then + LIBS="$curl_cv_save_LIBS" + else + LIBS="$x_nlibs $curl_cv_save_LIBS" + fi + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #undef inline + #ifdef _WIN32 + #ifndef WIN32_LEAN_AND_MEAN + #define WIN32_LEAN_AND_MEAN + #endif + #include + #else + #ifdef HAVE_SYS_TYPES_H + #include + #endif + #endif + #ifndef NULL + #define NULL (void *)0 + #endif + #ifndef LDAP_DEPRECATED + #define LDAP_DEPRECATED 1 + #endif + #ifdef NEED_LBER_H + #include + #endif + #ifdef HAVE_LDAP_H + #include + #endif + +int main(void) +{ + + BerValue *bvp = NULL; + BerElement *bep = ber_init(bvp); + LDAP *ldp = ldap_init("0.0.0.0", LDAP_PORT); + int res = ldap_unbind(ldp); + ber_free(bep, 1); + (void)res; + + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + curl_cv_ldap_LIBS="$x_nlibs" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + fi + done + + LIBS="$curl_cv_save_LIBS" + + case X-"$curl_cv_ldap_LIBS" in + X-unknown) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: cannot find LDAP libraries" >&5 +printf "%s\n" "cannot find LDAP libraries" >&6; } + ;; + X-) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no additional lib required" >&5 +printf "%s\n" "no additional lib required" >&6; } + ;; + *) + if test -z "$curl_cv_save_LIBS"; then + LIBS="$curl_cv_ldap_LIBS" + else + LIBS="$curl_cv_ldap_LIBS $curl_cv_save_LIBS" + fi + if false; then + LIBCURL_PC_REQUIRES_PRIVATE="ldap $LIBCURL_PC_REQUIRES_PRIVATE" + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $curl_cv_ldap_LIBS" >&5 +printf "%s\n" "$curl_cv_ldap_LIBS" >&6; } + ;; + esac + + case X-"$curl_cv_ldap_LIBS" in + X-unknown) + if test -n "$ldap_askedfor"; then + as_fn_error $? "could not detect the LDAP libraries" "$LINENO" 5 + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: Cannot find libraries for LDAP support: LDAP disabled" >&5 +printf "%s\n" "$as_me: WARNING: Cannot find libraries for LDAP support: LDAP disabled" >&2;} + +printf "%s\n" "#define CURL_DISABLE_LDAP 1" >>confdefs.h + + CURL_DISABLE_LDAP=1 + +printf "%s\n" "#define CURL_DISABLE_LDAPS 1" >>confdefs.h + + CURL_DISABLE_LDAPS=1 + CPPFLAGS=$clean_LDAP_CPPFLAGS + LDFLAGS=$clean_LDAP_LDFLAGS + LIBS=$clean_LDAP_LIBS + ;; + esac + fi +fi + +if test "$CURL_DISABLE_LDAP" != "1"; then + if test -n "$DIR_LDAP"; then + + if test "$cross_compiling" != "yes"; then + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$DIR_LDAP" + export CURL_LIBRARY_PATH + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: Added $DIR_LDAP to CURL_LIBRARY_PATH" >&5 +printf "%s\n" "$as_me: Added $DIR_LDAP to CURL_LIBRARY_PATH" >&6;} + fi + fi + + if test "$LBERLIBNAME"; then + if test "$LBERLIBNAME" != "no" && test "$ldap_lib_ok" != "yes"; then + as_ac_Lib=`printf "%s\n" "ac_cv_lib_"$LBERLIBNAME"""_ber_free" | $as_tr_sh` +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for ber_free in -l\"$LBERLIBNAME\"" >&5 +printf %s "checking for ber_free in -l\"$LBERLIBNAME\"... " >&6; } +if eval test \${$as_ac_Lib+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-l"$LBERLIBNAME" $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char ber_free (); +int main(void) +{ +return ber_free (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + eval "$as_ac_Lib=yes" +else $as_nop + eval "$as_ac_Lib=no" +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +eval ac_res=\$$as_ac_Lib + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +printf "%s\n" "$ac_res" >&6; } +if eval test \"x\$"$as_ac_Lib"\" = x"yes" +then : + cat >>confdefs.h <<_ACEOF +#define `printf "%s\n" "HAVE_LIB"$LBERLIBNAME"" | $as_tr_cpp` 1 +_ACEOF + + LIBS="-l"$LBERLIBNAME" $LIBS" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: \"$LBERLIBNAME\" is not an LBER library: LDAP disabled" >&5 +printf "%s\n" "$as_me: WARNING: \"$LBERLIBNAME\" is not an LBER library: LDAP disabled" >&2;} + +printf "%s\n" "#define CURL_DISABLE_LDAP 1" >>confdefs.h + + CURL_DISABLE_LDAP=1 + +printf "%s\n" "#define CURL_DISABLE_LDAPS 1" >>confdefs.h + + CURL_DISABLE_LDAPS=1 + CPPFLAGS=$clean_LDAP_CPPFLAGS + LDFLAGS=$clean_LDAP_LDFLAGS + LIBS=$clean_LDAP_LIBS + + +fi + + fi + fi +fi + +if test "$CURL_DISABLE_LDAP" != "1"; then + ac_fn_c_check_func "$LINENO" "ldap_url_parse" "ac_cv_func_ldap_url_parse" +if test "x$ac_cv_func_ldap_url_parse" = xyes +then : + printf "%s\n" "#define HAVE_LDAP_URL_PARSE 1" >>confdefs.h + +fi +ac_fn_c_check_func "$LINENO" "ldap_init_fd" "ac_cv_func_ldap_init_fd" +if test "x$ac_cv_func_ldap_init_fd" = xyes +then : + printf "%s\n" "#define HAVE_LDAP_INIT_FD 1" >>confdefs.h + +fi + + + if test "$LDAPLIBNAME" = "wldap32"; then + curl_ldap_msg="enabled (winldap)" + +printf "%s\n" "#define USE_WIN32_LDAP 1" >>confdefs.h + + else + if test "$ac_cv_func_ldap_init_fd" = "yes"; then + curl_ldap_msg="enabled (OpenLDAP)" + +printf "%s\n" "#define USE_OPENLDAP 1" >>confdefs.h + + USE_OPENLDAP=1 + else + curl_ldap_msg="enabled (ancient OpenLDAP)" + fi + fi +fi + +if test "$CURL_DISABLE_LDAPS" != "1"; then + curl_ldaps_msg="enabled" +fi + + +versioned_symbols_flavor= +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether versioned symbols are wanted" >&5 +printf %s "checking whether versioned symbols are wanted... " >&6; } +# Check whether --enable-versioned-symbols was given. +if test ${enable_versioned_symbols+y} +then : + enableval=$enable_versioned_symbols; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if libraries can be versioned" >&5 +printf %s "checking if libraries can be versioned... " >&6; } + GLD=`$LD --help < /dev/null 2>/dev/null | grep version-script` + if test -z "$GLD"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: You need an ld version supporting the --version-script option" >&5 +printf "%s\n" "$as_me: WARNING: You need an ld version supporting the --version-script option" >&2;} + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + if test "x$enableval" != "xyes"; then + versioned_symbols_flavor="$enableval" + elif test "$CURL_WITH_MULTI_SSL" = "1"; then + versioned_symbols_flavor="MULTISSL_" + elif test "$OPENSSL_ENABLED" = "1"; then + versioned_symbols_flavor="OPENSSL_" + elif test "$MBEDTLS_ENABLED" = "1"; then + versioned_symbols_flavor="MBEDTLS_" + elif test "$WOLFSSL_ENABLED" = "1"; then + versioned_symbols_flavor="WOLFSSL_" + elif test "$GNUTLS_ENABLED" = "1"; then + versioned_symbols_flavor="GNUTLS_" + elif test "$RUSTLS_ENABLED" = "1"; then + versioned_symbols_flavor="RUSTLS_" + else + versioned_symbols_flavor="" + fi + versioned_symbols="yes" + fi + ;; + + esac + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + + +fi + + +CURL_LIBCURL_VERSIONED_SYMBOLS_PREFIX="$versioned_symbols_flavor" + +CURL_LIBCURL_VERSIONED_SYMBOLS_SONAME="4" + if test "$versioned_symbols" = "yes"; then + CURL_LT_SHLIB_USE_VERSIONED_SYMBOLS_TRUE= + CURL_LT_SHLIB_USE_VERSIONED_SYMBOLS_FALSE='#' +else + CURL_LT_SHLIB_USE_VERSIONED_SYMBOLS_TRUE='#' + CURL_LT_SHLIB_USE_VERSIONED_SYMBOLS_FALSE= +fi + + + +want_winuni="no" +if test "$curl_cv_native_windows" = "yes"; then + if test "$curl_cv_winuwp" = "yes"; then + want_winuni="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable Windows Unicode (Windows native builds only)" >&5 +printf %s "checking whether to enable Windows Unicode (Windows native builds only)... " >&6; } + # Check whether --enable-windows-unicode was given. +if test ${enable_windows_unicode+y} +then : + enableval=$enable_windows_unicode; case "$enableval" in + yes) + want_winuni="yes" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +fi + + fi + + if test "$want_winuni" = "yes"; then + CPPFLAGS="${CPPFLAGS} -DUNICODE -D_UNICODE" + fi +fi + + if test "$want_winuni" = "yes"; then + USE_UNICODE_TRUE= + USE_UNICODE_FALSE='#' +else + USE_UNICODE_TRUE='#' + USE_UNICODE_FALSE= +fi + + + +tst_links_winidn='no' +if test "$curl_cv_native_windows" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable Windows native IDN (Windows native builds only)" >&5 +printf %s "checking whether to enable Windows native IDN (Windows native builds only)... " >&6; } + OPT_WINIDN="default" + +# Check whether --with-winidn was given. +if test ${with_winidn+y} +then : + withval=$with_winidn; OPT_WINIDN=$withval +fi + + case "$OPT_WINIDN" in + no|default) + want_winidn="no" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + ;; + *) + want_winidn="yes" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac + + if test "$want_winidn" = "yes"; then + LIBS="-lnormaliz $LIBS" + +printf "%s\n" "#define USE_WIN32_IDN 1" >>confdefs.h + + IDN_ENABLED=1 + curl_idn_msg="enabled (Windows-native)" + fi +fi + + +tst_links_appleidn='no' +if test "$curl_cv_apple" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to build with Apple IDN" >&5 +printf %s "checking whether to build with Apple IDN... " >&6; } + OPT_IDN="default" + +# Check whether --with-apple-idn was given. +if test ${with_apple_idn+y} +then : + withval=$with_apple_idn; OPT_IDN=$withval +fi + + case "$OPT_IDN" in + yes) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes, check" >&5 +printf "%s\n" "yes, check" >&6; } + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for uidna_openUTS46 in -licucore" >&5 +printf %s "checking for uidna_openUTS46 in -licucore... " >&6; } +if test ${ac_cv_lib_icucore_uidna_openUTS46+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-licucore $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char uidna_openUTS46 (); +int main(void) +{ +return uidna_openUTS46 (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_icucore_uidna_openUTS46=yes +else $as_nop + ac_cv_lib_icucore_uidna_openUTS46=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_icucore_uidna_openUTS46" >&5 +printf "%s\n" "$ac_cv_lib_icucore_uidna_openUTS46" >&6; } +if test "x$ac_cv_lib_icucore_uidna_openUTS46" = xyes +then : + + for ac_header in unicode/uidna.h +do : + ac_fn_c_check_header_compile "$LINENO" "unicode/uidna.h" "ac_cv_header_unicode_uidna_h" "$ac_includes_default" +if test "x$ac_cv_header_unicode_uidna_h" = xyes +then : + printf "%s\n" "#define HAVE_UNICODE_UIDNA_H 1" >>confdefs.h + curl_idn_msg="enabled (AppleIDN)" + +printf "%s\n" "#define USE_APPLE_IDN 1" >>confdefs.h + + USE_APPLE_IDN=1 + IDN_ENABLED=1 + LIBS="-licucore -liconv $LIBS" + tst_links_appleidn='yes' + +fi + +done + +fi + + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + ;; + esac +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to build with libidn2" >&5 +printf %s "checking whether to build with libidn2... " >&6; } +OPT_IDN="default" + +# Check whether --with-libidn2 was given. +if test ${with_libidn2+y} +then : + withval=$with_libidn2; OPT_IDN=$withval +fi + +if test "$tst_links_winidn" = "yes"; then + want_idn="no" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no (using WinIDN instead)" >&5 +printf "%s\n" "no (using WinIDN instead)" >&6; } +elif test "$tst_links_appleidn" = "yes"; then + want_idn="no" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no (using AppleIDN instead)" >&5 +printf "%s\n" "no (using AppleIDN instead)" >&6; } +else + case "$OPT_IDN" in + no) + want_idn="no" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + ;; + default) + want_idn="yes" + want_idn_path="default" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: (assumed) yes" >&5 +printf "%s\n" "(assumed) yes" >&6; } + ;; + yes) + want_idn="yes" + want_idn_path="default" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + *) + want_idn="yes" + want_idn_path="$withval" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes ($withval)" >&5 +printf "%s\n" "yes ($withval)" >&6; } + ;; + esac +fi + +if test "$want_idn" = "yes"; then + clean_CPPFLAGS="$CPPFLAGS" + clean_LDFLAGS="$LDFLAGS" + clean_LDFLAGSPC="$LDFLAGSPC" + clean_LIBS="$LIBS" + PKGCONFIG="no" + + if test "$want_idn_path" != "default"; then + IDN_PCDIR="$want_idn_path/lib$libsuff/pkgconfig" + + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. +set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKGCONFIG="$PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PKGCONFIG=$ac_cv_path_PKGCONFIG +if test -n "$PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PKGCONFIG" >&5 +printf "%s\n" "$PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_PKGCONFIG"; then + ac_pt_PKGCONFIG=$PKGCONFIG + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_PKGCONFIG="$ac_pt_PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_PKGCONFIG=$ac_cv_path_ac_pt_PKGCONFIG +if test -n "$ac_pt_PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKGCONFIG" >&5 +printf "%s\n" "$ac_pt_PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_PKGCONFIG" = x; then + PKGCONFIG="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + PKGCONFIG=$ac_pt_PKGCONFIG + fi +else + PKGCONFIG="$ac_cv_path_PKGCONFIG" +fi + + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for libidn2 options with pkg-config" >&5 +printf %s "checking for libidn2 options with pkg-config... " >&6; } + itexists=` + if test -n "$IDN_PCDIR"; then + if test -n ""; then + PKG_CONFIG_PATH="$IDN_PCDIR${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$IDN_PCDIR" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists libidn2 >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + + trc=` + if test -n "$IDN_PCDIR"; then + if test -n ""; then + PKG_CONFIG_PATH="$IDN_PCDIR${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$IDN_PCDIR" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libidn2 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$IDN_PCDIR"; then + if test -n ""; then + PKG_CONFIG_PATH="$IDN_PCDIR${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$IDN_PCDIR" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libidn2 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libidn2 trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libidn2 trace: +---- begin +${trc} +---- end" >&6;} + + fi + PKGCONFIG="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found" >&5 +printf "%s\n" "found" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG"; then + + trc=` + if test -n "$IDN_PCDIR"; then + if test -n ""; then + PKG_CONFIG_PATH="$IDN_PCDIR${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$IDN_PCDIR" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libidn2 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$IDN_PCDIR"; then + if test -n ""; then + PKG_CONFIG_PATH="$IDN_PCDIR${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$IDN_PCDIR" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libidn2 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libidn2 trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libidn2 trace: +---- begin +${trc} +---- end" >&6;} + + fi + fi + fi + + if test "$PKGCONFIG" != "no"; then + IDN_LIBS=` + if test -n "$IDN_PCDIR"; then + if test -n ""; then + PKG_CONFIG_PATH="$IDN_PCDIR${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$IDN_PCDIR" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --libs-only-l libidn2 2>/dev/null` + IDN_LDFLAGS=` + if test -n "$IDN_PCDIR"; then + if test -n ""; then + PKG_CONFIG_PATH="$IDN_PCDIR${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$IDN_PCDIR" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --libs-only-L libidn2 2>/dev/null` + IDN_CPPFLAGS=` + if test -n "$IDN_PCDIR"; then + if test -n ""; then + PKG_CONFIG_PATH="$IDN_PCDIR${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$IDN_PCDIR" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --cflags-only-I libidn2 2>/dev/null` + IDN_DIR=`echo $IDN_LDFLAGS | $SED -e 's/^-L//'` + else + IDN_LIBS="-lidn2" + IDN_LDFLAGS="-L$want_idn_path/lib$libsuff" + IDN_CPPFLAGS="-I$want_idn_path/include" + IDN_DIR="$want_idn_path/lib$libsuff" + fi + else + + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. +set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKGCONFIG="$PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PKGCONFIG=$ac_cv_path_PKGCONFIG +if test -n "$PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PKGCONFIG" >&5 +printf "%s\n" "$PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_PKGCONFIG"; then + ac_pt_PKGCONFIG=$PKGCONFIG + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_PKGCONFIG="$ac_pt_PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_PKGCONFIG=$ac_cv_path_ac_pt_PKGCONFIG +if test -n "$ac_pt_PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKGCONFIG" >&5 +printf "%s\n" "$ac_pt_PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_PKGCONFIG" = x; then + PKGCONFIG="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + PKGCONFIG=$ac_pt_PKGCONFIG + fi +else + PKGCONFIG="$ac_cv_path_PKGCONFIG" +fi + + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for libidn2 options with pkg-config" >&5 +printf %s "checking for libidn2 options with pkg-config... " >&6; } + itexists=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists libidn2 >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + + trc=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libidn2 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libidn2 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libidn2 trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libidn2 trace: +---- begin +${trc} +---- end" >&6;} + + fi + PKGCONFIG="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found" >&5 +printf "%s\n" "found" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG"; then + + trc=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libidn2 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libidn2 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libidn2 trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libidn2 trace: +---- begin +${trc} +---- end" >&6;} + + fi + fi + fi + + if test "$PKGCONFIG" != "no"; then + IDN_LIBS=`$PKGCONFIG --libs-only-l libidn2 2>/dev/null` + IDN_LDFLAGS=`$PKGCONFIG --libs-only-L libidn2 2>/dev/null` + IDN_CPPFLAGS=`$PKGCONFIG --cflags-only-I libidn2 2>/dev/null` + IDN_DIR=`echo $IDN_LDFLAGS | $SED -e 's/^-L//'` + else + IDN_LIBS="-lidn2" + fi + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config: IDN_LIBS: \"$IDN_LIBS\"" >&5 +printf "%s\n" "$as_me: pkg-config: IDN_LIBS: \"$IDN_LIBS\"" >&6;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config: IDN_LDFLAGS: \"$IDN_LDFLAGS\"" >&5 +printf "%s\n" "$as_me: pkg-config: IDN_LDFLAGS: \"$IDN_LDFLAGS\"" >&6;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config: IDN_CPPFLAGS: \"$IDN_CPPFLAGS\"" >&5 +printf "%s\n" "$as_me: pkg-config: IDN_CPPFLAGS: \"$IDN_CPPFLAGS\"" >&6;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config: IDN_DIR: \"$IDN_DIR\"" >&5 +printf "%s\n" "$as_me: pkg-config: IDN_DIR: \"$IDN_DIR\"" >&6;} + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: IDN_LIBS: \"$IDN_LIBS\"" >&5 +printf "%s\n" "$as_me: IDN_LIBS: \"$IDN_LIBS\"" >&6;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: IDN_LDFLAGS: \"$IDN_LDFLAGS\"" >&5 +printf "%s\n" "$as_me: IDN_LDFLAGS: \"$IDN_LDFLAGS\"" >&6;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: IDN_CPPFLAGS: \"$IDN_CPPFLAGS\"" >&5 +printf "%s\n" "$as_me: IDN_CPPFLAGS: \"$IDN_CPPFLAGS\"" >&6;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: IDN_DIR: \"$IDN_DIR\"" >&5 +printf "%s\n" "$as_me: IDN_DIR: \"$IDN_DIR\"" >&6;} + fi + + CPPFLAGS="$CPPFLAGS $IDN_CPPFLAGS" + LDFLAGS="$LDFLAGS $IDN_LDFLAGS" + LDFLAGSPC="$LDFLAGSPC $IDN_LDFLAGS" + LIBS="$IDN_LIBS $LIBS" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if idn2_lookup_ul can be linked" >&5 +printf %s "checking if idn2_lookup_ul can be linked... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#define idn2_lookup_ul innocuous_idn2_lookup_ul +#ifdef __STDC__ +# include +#else +# include +#endif +#undef idn2_lookup_ul +#ifdef __cplusplus +extern "C" +#endif +char idn2_lookup_ul (); +#if defined __stub_idn2_lookup_ul || defined __stub___idn2_lookup_ul +#error force compilation error +#endif + +int main(void) +{ +return idn2_lookup_ul (); + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_links_libidn="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_links_libidn="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + ac_fn_c_check_header_compile "$LINENO" "idn2.h" "ac_cv_header_idn2_h" "$ac_includes_default" +if test "x$ac_cv_header_idn2_h" = xyes +then : + printf "%s\n" "#define HAVE_IDN2_H 1" >>confdefs.h + +fi + + + if test "$tst_links_libidn" = "yes"; then + +printf "%s\n" "#define HAVE_LIBIDN2 1" >>confdefs.h + + + IDN_ENABLED=1 + curl_idn_msg="enabled (libidn2)" + if test -n "$IDN_DIR" && test "$cross_compiling" != "yes"; then + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$IDN_DIR" + export CURL_LIBRARY_PATH + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: Added $IDN_DIR to CURL_LIBRARY_PATH" >&5 +printf "%s\n" "$as_me: Added $IDN_DIR to CURL_LIBRARY_PATH" >&6;} + fi + LIBCURL_PC_REQUIRES_PRIVATE="libidn2 $LIBCURL_PC_REQUIRES_PRIVATE" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: Cannot find libidn2" >&5 +printf "%s\n" "$as_me: WARNING: Cannot find libidn2" >&2;} + CPPFLAGS="$clean_CPPFLAGS" + LDFLAGS="$clean_LDFLAGS" + LDFLAGSPC="$clean_LDFLAGSPC" + LIBS="$clean_LIBS" + want_idn="no" + fi +fi + + +OPT_H2="yes" + +if test "$disable_http" = "yes"; then + OPT_H2="no" +fi + + +# Check whether --with-nghttp2 was given. +if test ${with_nghttp2+y} +then : + withval=$with_nghttp2; OPT_H2=$withval +fi + +case "$OPT_H2" in + no) + want_nghttp2="no" + ;; + yes) + want_nghttp2="default" + want_nghttp2_path="" + want_nghttp2_pkg_config_path="" + ;; + *) + want_nghttp2="yes" + want_nghttp2_path="$withval" + want_nghttp2_pkg_config_path="$OPT_H2/lib/pkgconfig" + ;; +esac + +if test "$want_nghttp2" != "no"; then + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. +set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKGCONFIG="$PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PKGCONFIG=$ac_cv_path_PKGCONFIG +if test -n "$PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PKGCONFIG" >&5 +printf "%s\n" "$PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_PKGCONFIG"; then + ac_pt_PKGCONFIG=$PKGCONFIG + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_PKGCONFIG="$ac_pt_PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_PKGCONFIG=$ac_cv_path_ac_pt_PKGCONFIG +if test -n "$ac_pt_PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKGCONFIG" >&5 +printf "%s\n" "$ac_pt_PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_PKGCONFIG" = x; then + PKGCONFIG="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + PKGCONFIG=$ac_pt_PKGCONFIG + fi +else + PKGCONFIG="$ac_cv_path_PKGCONFIG" +fi + + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for libnghttp2 options with pkg-config" >&5 +printf %s "checking for libnghttp2 options with pkg-config... " >&6; } + itexists=` + if test -n "$want_nghttp2_pkg_config_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_nghttp2_pkg_config_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_nghttp2_pkg_config_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists libnghttp2 >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + + trc=` + if test -n "$want_nghttp2_pkg_config_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_nghttp2_pkg_config_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_nghttp2_pkg_config_path" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libnghttp2 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$want_nghttp2_pkg_config_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_nghttp2_pkg_config_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_nghttp2_pkg_config_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libnghttp2 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libnghttp2 trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libnghttp2 trace: +---- begin +${trc} +---- end" >&6;} + + fi + PKGCONFIG="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found" >&5 +printf "%s\n" "found" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG"; then + + trc=` + if test -n "$want_nghttp2_pkg_config_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_nghttp2_pkg_config_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_nghttp2_pkg_config_path" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libnghttp2 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$want_nghttp2_pkg_config_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_nghttp2_pkg_config_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_nghttp2_pkg_config_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libnghttp2 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libnghttp2 trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libnghttp2 trace: +---- begin +${trc} +---- end" >&6;} + + fi + fi + fi + + + if test "$PKGCONFIG" != "no"; then + LIB_H2=` + if test -n "$want_nghttp2_pkg_config_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_nghttp2_pkg_config_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_nghttp2_pkg_config_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --libs-only-l libnghttp2` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: -l is $LIB_H2" >&5 +printf "%s\n" "$as_me: -l is $LIB_H2" >&6;} + + CPP_H2=` + if test -n "$want_nghttp2_pkg_config_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_nghttp2_pkg_config_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_nghttp2_pkg_config_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --cflags-only-I libnghttp2` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: -I is $CPP_H2" >&5 +printf "%s\n" "$as_me: -I is $CPP_H2" >&6;} + + LD_H2=` + if test -n "$want_nghttp2_pkg_config_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_nghttp2_pkg_config_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_nghttp2_pkg_config_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --libs-only-L libnghttp2` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: -L is $LD_H2" >&5 +printf "%s\n" "$as_me: -L is $LD_H2" >&6;} + + DIR_H2=`echo $LD_H2 | $SED -e 's/^-L//'` + elif test -n "$want_nghttp2_path"; then + LIB_H2="-lnghttp2" + LD_H2=-L${want_nghttp2_path}/lib$libsuff + CPP_H2=-I${want_nghttp2_path}/include + DIR_H2=${want_nghttp2_path}/lib$libsuff + elif test "$want_nghttp2" != "default"; then + as_fn_error $? "--with-nghttp2 was specified but could not find libnghttp2 pkg-config file." "$LINENO" 5 + else + LIB_H2="-lnghttp2" + fi + + LDFLAGS="$LDFLAGS $LD_H2" + LDFLAGSPC="$LDFLAGSPC $LD_H2" + CPPFLAGS="$CPPFLAGS $CPP_H2" + LIBS="$LIB_H2 $LIBS" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for nghttp2_session_get_stream_local_window_size in -lnghttp2" >&5 +printf %s "checking for nghttp2_session_get_stream_local_window_size in -lnghttp2... " >&6; } +if test ${ac_cv_lib_nghttp2_nghttp2_session_get_stream_local_window_size+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lnghttp2 $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char nghttp2_session_get_stream_local_window_size (); +int main(void) +{ +return nghttp2_session_get_stream_local_window_size (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_nghttp2_nghttp2_session_get_stream_local_window_size=yes +else $as_nop + ac_cv_lib_nghttp2_nghttp2_session_get_stream_local_window_size=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_nghttp2_nghttp2_session_get_stream_local_window_size" >&5 +printf "%s\n" "$ac_cv_lib_nghttp2_nghttp2_session_get_stream_local_window_size" >&6; } +if test "x$ac_cv_lib_nghttp2_nghttp2_session_get_stream_local_window_size" = xyes +then : + + for ac_header in nghttp2/nghttp2.h +do : + ac_fn_c_check_header_compile "$LINENO" "nghttp2/nghttp2.h" "ac_cv_header_nghttp2_nghttp2_h" "$ac_includes_default" +if test "x$ac_cv_header_nghttp2_nghttp2_h" = xyes +then : + printf "%s\n" "#define HAVE_NGHTTP2_NGHTTP2_H 1" >>confdefs.h + curl_h2_msg="enabled (nghttp2)" + +printf "%s\n" "#define USE_NGHTTP2 1" >>confdefs.h + + USE_NGHTTP2=1 + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libnghttp2" + +fi + +done + + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$DIR_H2" + export CURL_LIBRARY_PATH + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: Added $DIR_H2 to CURL_LIBRARY_PATH" >&5 +printf "%s\n" "$as_me: Added $DIR_H2 to CURL_LIBRARY_PATH" >&6;} + +else $as_nop + LDFLAGS=$CLEANLDFLAGS + LDFLAGSPC=$CLEANLDFLAGSPC + CPPFLAGS=$CLEANCPPFLAGS + LIBS=$CLEANLIBS + +fi + +fi + + +OPT_TCP2="no" + +if test "$disable_http" = "yes"; then + OPT_TCP2="no" +fi + + +# Check whether --with-ngtcp2 was given. +if test ${with_ngtcp2+y} +then : + withval=$with_ngtcp2; OPT_TCP2=$withval +fi + +case "$OPT_TCP2" in + no) + want_tcp2="no" + ;; + yes) + want_tcp2="default" + want_tcp2_path="" + ;; + *) + want_tcp2="yes" + want_tcp2_path="$OPT_TCP2/lib/pkgconfig" + ;; +esac + +curl_tcp2_msg="no (--with-ngtcp2)" +if test "$want_tcp2" != "no"; then + + if test "$QUIC_ENABLED" != "yes"; then + as_fn_error $? "the detected TLS library does not support QUIC, making --with-ngtcp2 a no-no" "$LINENO" 5 + fi + + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. +set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKGCONFIG="$PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PKGCONFIG=$ac_cv_path_PKGCONFIG +if test -n "$PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PKGCONFIG" >&5 +printf "%s\n" "$PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_PKGCONFIG"; then + ac_pt_PKGCONFIG=$PKGCONFIG + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_PKGCONFIG="$ac_pt_PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_PKGCONFIG=$ac_cv_path_ac_pt_PKGCONFIG +if test -n "$ac_pt_PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKGCONFIG" >&5 +printf "%s\n" "$ac_pt_PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_PKGCONFIG" = x; then + PKGCONFIG="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + PKGCONFIG=$ac_pt_PKGCONFIG + fi +else + PKGCONFIG="$ac_cv_path_PKGCONFIG" +fi + + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for libngtcp2 options with pkg-config" >&5 +printf %s "checking for libngtcp2 options with pkg-config... " >&6; } + itexists=` + if test -n "$want_tcp2_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists libngtcp2 >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + + trc=` + if test -n "$want_tcp2_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libngtcp2 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$want_tcp2_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libngtcp2 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libngtcp2 trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libngtcp2 trace: +---- begin +${trc} +---- end" >&6;} + + fi + PKGCONFIG="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found" >&5 +printf "%s\n" "found" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG"; then + + trc=` + if test -n "$want_tcp2_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libngtcp2 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$want_tcp2_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libngtcp2 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libngtcp2 trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libngtcp2 trace: +---- begin +${trc} +---- end" >&6;} + + fi + fi + fi + + + if test "$PKGCONFIG" != "no"; then + LIB_TCP2=` + if test -n "$want_tcp2_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --libs-only-l libngtcp2` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: -l is $LIB_TCP2" >&5 +printf "%s\n" "$as_me: -l is $LIB_TCP2" >&6;} + + CPP_TCP2=` + if test -n "$want_tcp2_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --cflags-only-I libngtcp2` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: -I is $CPP_TCP2" >&5 +printf "%s\n" "$as_me: -I is $CPP_TCP2" >&6;} + + LD_TCP2=` + if test -n "$want_tcp2_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --libs-only-L libngtcp2` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: -L is $LD_TCP2" >&5 +printf "%s\n" "$as_me: -L is $LD_TCP2" >&6;} + + LDFLAGS="$LDFLAGS $LD_TCP2" + LDFLAGSPC="$LDFLAGSPC $LD_TCP2" + CPPFLAGS="$CPPFLAGS $CPP_TCP2" + LIBS="$LIB_TCP2 $LIBS" + + if test "$cross_compiling" != "yes"; then + DIR_TCP2=`echo $LD_TCP2 | $SED -e 's/^-L//'` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for ngtcp2_conn_client_new_versioned in -lngtcp2" >&5 +printf %s "checking for ngtcp2_conn_client_new_versioned in -lngtcp2... " >&6; } +if test ${ac_cv_lib_ngtcp2_ngtcp2_conn_client_new_versioned+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lngtcp2 $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char ngtcp2_conn_client_new_versioned (); +int main(void) +{ +return ngtcp2_conn_client_new_versioned (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_ngtcp2_ngtcp2_conn_client_new_versioned=yes +else $as_nop + ac_cv_lib_ngtcp2_ngtcp2_conn_client_new_versioned=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_ngtcp2_ngtcp2_conn_client_new_versioned" >&5 +printf "%s\n" "$ac_cv_lib_ngtcp2_ngtcp2_conn_client_new_versioned" >&6; } +if test "x$ac_cv_lib_ngtcp2_ngtcp2_conn_client_new_versioned" = xyes +then : + + for ac_header in ngtcp2/ngtcp2.h +do : + ac_fn_c_check_header_compile "$LINENO" "ngtcp2/ngtcp2.h" "ac_cv_header_ngtcp2_ngtcp2_h" "$ac_includes_default" +if test "x$ac_cv_header_ngtcp2_ngtcp2_h" = xyes +then : + printf "%s\n" "#define HAVE_NGTCP2_NGTCP2_H 1" >>confdefs.h + +printf "%s\n" "#define USE_NGTCP2 1" >>confdefs.h + + USE_NGTCP2=1 + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$DIR_TCP2" + export CURL_LIBRARY_PATH + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: Added $DIR_TCP2 to CURL_LIBRARY_PATH" >&5 +printf "%s\n" "$as_me: Added $DIR_TCP2 to CURL_LIBRARY_PATH" >&6;} + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libngtcp2" + +fi + +done + +else $as_nop + LDFLAGS=$CLEANLDFLAGS + LDFLAGSPC=$CLEANLDFLAGSPC + CPPFLAGS=$CLEANCPPFLAGS + LIBS=$CLEANLIBS + +fi + + + else + if test "$want_tcp2" != "default"; then + as_fn_error $? "--with-ngtcp2 was specified but could not find ngtcp2 pkg-config file." "$LINENO" 5 + fi + fi +fi + +if test "$USE_NGTCP2" = "1" && test "$OPENSSL_ENABLED" = "1" && test "$HAVE_LIBRESSL" = "1"; then + + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. +set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKGCONFIG="$PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PKGCONFIG=$ac_cv_path_PKGCONFIG +if test -n "$PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PKGCONFIG" >&5 +printf "%s\n" "$PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_PKGCONFIG"; then + ac_pt_PKGCONFIG=$PKGCONFIG + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_PKGCONFIG="$ac_pt_PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_PKGCONFIG=$ac_cv_path_ac_pt_PKGCONFIG +if test -n "$ac_pt_PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKGCONFIG" >&5 +printf "%s\n" "$ac_pt_PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_PKGCONFIG" = x; then + PKGCONFIG="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + PKGCONFIG=$ac_pt_PKGCONFIG + fi +else + PKGCONFIG="$ac_cv_path_PKGCONFIG" +fi + + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for libngtcp2_crypto_libressl options with pkg-config" >&5 +printf %s "checking for libngtcp2_crypto_libressl options with pkg-config... " >&6; } + itexists=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists libngtcp2_crypto_libressl >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + + trc=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libngtcp2_crypto_libressl 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libngtcp2_crypto_libressl 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libngtcp2_crypto_libressl trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libngtcp2_crypto_libressl trace: +---- begin +${trc} +---- end" >&6;} + + fi + PKGCONFIG="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found" >&5 +printf "%s\n" "found" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG"; then + + trc=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libngtcp2_crypto_libressl 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libngtcp2_crypto_libressl 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libngtcp2_crypto_libressl trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libngtcp2_crypto_libressl trace: +---- begin +${trc} +---- end" >&6;} + + fi + fi + fi + + + if test "$PKGCONFIG" != "no"; then + LIB_NGTCP2_CRYPTO_LIBRESSL=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --libs-only-l libngtcp2_crypto_libressl` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: -l is $LIB_NGTCP2_CRYPTO_LIBRESSL" >&5 +printf "%s\n" "$as_me: -l is $LIB_NGTCP2_CRYPTO_LIBRESSL" >&6;} + + CPP_NGTCP2_CRYPTO_LIBRESSL=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --cflags-only-I libngtcp2_crypto_libressl` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: -I is $CPP_NGTCP2_CRYPTO_LIBRESSL" >&5 +printf "%s\n" "$as_me: -I is $CPP_NGTCP2_CRYPTO_LIBRESSL" >&6;} + + LD_NGTCP2_CRYPTO_LIBRESSL=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --libs-only-L libngtcp2_crypto_libressl` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: -L is $LD_NGTCP2_CRYPTO_LIBRESSL" >&5 +printf "%s\n" "$as_me: -L is $LD_NGTCP2_CRYPTO_LIBRESSL" >&6;} + + LDFLAGS="$LDFLAGS $LD_NGTCP2_CRYPTO_LIBRESSL" + LDFLAGSPC="$LDFLAGSPC $LD_NGTCP2_CRYPTO_LIBRESSL" + CPPFLAGS="$CPPFLAGS $CPP_NGTCP2_CRYPTO_LIBRESSL" + LIBS="$LIB_NGTCP2_CRYPTO_LIBRESSL $LIBS" + + if test "$cross_compiling" != "yes"; then + DIR_NGTCP2_CRYPTO_LIBRESSL=`echo $LD_NGTCP2_CRYPTO_LIBRESSL | $SED -e 's/^-L//'` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for ngtcp2_crypto_recv_client_initial_cb in -lngtcp2_crypto_libressl" >&5 +printf %s "checking for ngtcp2_crypto_recv_client_initial_cb in -lngtcp2_crypto_libressl... " >&6; } +if test ${ac_cv_lib_ngtcp2_crypto_libressl_ngtcp2_crypto_recv_client_initial_cb+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lngtcp2_crypto_libressl $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char ngtcp2_crypto_recv_client_initial_cb (); +int main(void) +{ +return ngtcp2_crypto_recv_client_initial_cb (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_ngtcp2_crypto_libressl_ngtcp2_crypto_recv_client_initial_cb=yes +else $as_nop + ac_cv_lib_ngtcp2_crypto_libressl_ngtcp2_crypto_recv_client_initial_cb=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_ngtcp2_crypto_libressl_ngtcp2_crypto_recv_client_initial_cb" >&5 +printf "%s\n" "$ac_cv_lib_ngtcp2_crypto_libressl_ngtcp2_crypto_recv_client_initial_cb" >&6; } +if test "x$ac_cv_lib_ngtcp2_crypto_libressl_ngtcp2_crypto_recv_client_initial_cb" = xyes +then : + + for ac_header in ngtcp2/ngtcp2_crypto.h +do : + ac_fn_c_check_header_compile "$LINENO" "ngtcp2/ngtcp2_crypto.h" "ac_cv_header_ngtcp2_ngtcp2_crypto_h" "$ac_includes_default" +if test "x$ac_cv_header_ngtcp2_ngtcp2_crypto_h" = xyes +then : + printf "%s\n" "#define HAVE_NGTCP2_NGTCP2_CRYPTO_H 1" >>confdefs.h + USE_NGTCP2=1 + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$DIR_NGTCP2_CRYPTO_LIBRESSL" + export CURL_LIBRARY_PATH + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: Added $DIR_NGTCP2_CRYPTO_LIBRESSL to CURL_LIBRARY_PATH" >&5 +printf "%s\n" "$as_me: Added $DIR_NGTCP2_CRYPTO_LIBRESSL to CURL_LIBRARY_PATH" >&6;} + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libngtcp2_crypto_libressl" + +fi + +done + +else $as_nop + LDFLAGS=$CLEANLDFLAGS + LDFLAGSPC=$CLEANLDFLAGSPC + CPPFLAGS=$CLEANCPPFLAGS + LIBS=$CLEANLIBS + +fi + + + else + if test "$want_tcp2" != "default"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: --with-ngtcp2 was specified but could not find ngtcp2_crypto_libressl pkg-config file." >&5 +printf "%s\n" "$as_me: WARNING: --with-ngtcp2 was specified but could not find ngtcp2_crypto_libressl pkg-config file." >&2;} + fi + HAVE_LIBRESSL=0 + fi +fi + +if test "$USE_NGTCP2" = "1" && test "$OPENSSL_ENABLED" = "1" && test "$HAVE_LIBRESSL" != "1" && + test "$OPENSSL_IS_AWSLC" != "1" && test "$OPENSSL_IS_BORINGSSL" != "1" && test "$OPENSSL_QUIC_API2" != "1"; then + + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. +set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKGCONFIG="$PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PKGCONFIG=$ac_cv_path_PKGCONFIG +if test -n "$PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PKGCONFIG" >&5 +printf "%s\n" "$PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_PKGCONFIG"; then + ac_pt_PKGCONFIG=$PKGCONFIG + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_PKGCONFIG="$ac_pt_PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_PKGCONFIG=$ac_cv_path_ac_pt_PKGCONFIG +if test -n "$ac_pt_PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKGCONFIG" >&5 +printf "%s\n" "$ac_pt_PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_PKGCONFIG" = x; then + PKGCONFIG="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + PKGCONFIG=$ac_pt_PKGCONFIG + fi +else + PKGCONFIG="$ac_cv_path_PKGCONFIG" +fi + + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for libngtcp2_crypto_quictls options with pkg-config" >&5 +printf %s "checking for libngtcp2_crypto_quictls options with pkg-config... " >&6; } + itexists=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists libngtcp2_crypto_quictls >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + + trc=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libngtcp2_crypto_quictls 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libngtcp2_crypto_quictls 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libngtcp2_crypto_quictls trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libngtcp2_crypto_quictls trace: +---- begin +${trc} +---- end" >&6;} + + fi + PKGCONFIG="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found" >&5 +printf "%s\n" "found" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG"; then + + trc=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libngtcp2_crypto_quictls 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libngtcp2_crypto_quictls 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libngtcp2_crypto_quictls trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libngtcp2_crypto_quictls trace: +---- begin +${trc} +---- end" >&6;} + + fi + fi + fi + + + if test "$PKGCONFIG" != "no"; then + LIB_NGTCP2_CRYPTO_QUICTLS=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --libs-only-l libngtcp2_crypto_quictls` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: -l is $LIB_NGTCP2_CRYPTO_QUICTLS" >&5 +printf "%s\n" "$as_me: -l is $LIB_NGTCP2_CRYPTO_QUICTLS" >&6;} + + CPP_NGTCP2_CRYPTO_QUICTLS=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --cflags-only-I libngtcp2_crypto_quictls` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: -I is $CPP_NGTCP2_CRYPTO_QUICTLS" >&5 +printf "%s\n" "$as_me: -I is $CPP_NGTCP2_CRYPTO_QUICTLS" >&6;} + + LD_NGTCP2_CRYPTO_QUICTLS=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --libs-only-L libngtcp2_crypto_quictls` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: -L is $LD_NGTCP2_CRYPTO_QUICTLS" >&5 +printf "%s\n" "$as_me: -L is $LD_NGTCP2_CRYPTO_QUICTLS" >&6;} + + LDFLAGS="$LDFLAGS $LD_NGTCP2_CRYPTO_QUICTLS" + LDFLAGSPC="$LDFLAGSPC $LD_NGTCP2_CRYPTO_QUICTLS" + CPPFLAGS="$CPPFLAGS $CPP_NGTCP2_CRYPTO_QUICTLS" + LIBS="$LIB_NGTCP2_CRYPTO_QUICTLS $LIBS" + + if test "$cross_compiling" != "yes"; then + DIR_NGTCP2_CRYPTO_QUICTLS=`echo $LD_NGTCP2_CRYPTO_QUICTLS | $SED -e 's/^-L//'` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for ngtcp2_crypto_recv_client_initial_cb in -lngtcp2_crypto_quictls" >&5 +printf %s "checking for ngtcp2_crypto_recv_client_initial_cb in -lngtcp2_crypto_quictls... " >&6; } +if test ${ac_cv_lib_ngtcp2_crypto_quictls_ngtcp2_crypto_recv_client_initial_cb+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lngtcp2_crypto_quictls $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char ngtcp2_crypto_recv_client_initial_cb (); +int main(void) +{ +return ngtcp2_crypto_recv_client_initial_cb (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_ngtcp2_crypto_quictls_ngtcp2_crypto_recv_client_initial_cb=yes +else $as_nop + ac_cv_lib_ngtcp2_crypto_quictls_ngtcp2_crypto_recv_client_initial_cb=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_ngtcp2_crypto_quictls_ngtcp2_crypto_recv_client_initial_cb" >&5 +printf "%s\n" "$ac_cv_lib_ngtcp2_crypto_quictls_ngtcp2_crypto_recv_client_initial_cb" >&6; } +if test "x$ac_cv_lib_ngtcp2_crypto_quictls_ngtcp2_crypto_recv_client_initial_cb" = xyes +then : + + for ac_header in ngtcp2/ngtcp2_crypto.h +do : + ac_fn_c_check_header_compile "$LINENO" "ngtcp2/ngtcp2_crypto.h" "ac_cv_header_ngtcp2_ngtcp2_crypto_h" "$ac_includes_default" +if test "x$ac_cv_header_ngtcp2_ngtcp2_crypto_h" = xyes +then : + printf "%s\n" "#define HAVE_NGTCP2_NGTCP2_CRYPTO_H 1" >>confdefs.h + USE_NGTCP2=1 + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$DIR_NGTCP2_CRYPTO_QUICTLS" + export CURL_LIBRARY_PATH + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: Added $DIR_NGTCP2_CRYPTO_QUICTLS to CURL_LIBRARY_PATH" >&5 +printf "%s\n" "$as_me: Added $DIR_NGTCP2_CRYPTO_QUICTLS to CURL_LIBRARY_PATH" >&6;} + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libngtcp2_crypto_quictls" + +fi + +done + +else $as_nop + LDFLAGS=$CLEANLDFLAGS + LDFLAGSPC=$CLEANLDFLAGSPC + CPPFLAGS=$CLEANCPPFLAGS + LIBS=$CLEANLIBS + +fi + + + else + if test "$want_tcp2" != "default"; then + as_fn_error $? "--with-ngtcp2 was specified but could not find ngtcp2_crypto_quictls pkg-config file." "$LINENO" 5 + fi + fi +fi + +if test "$USE_NGTCP2" = "1" && test "$OPENSSL_ENABLED" = "1" && + test "$OPENSSL_IS_AWSLC" != "1" && test "$OPENSSL_IS_BORINGSSL" != "1" && test "$OPENSSL_QUIC_API2" = "1"; then + + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. +set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKGCONFIG="$PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PKGCONFIG=$ac_cv_path_PKGCONFIG +if test -n "$PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PKGCONFIG" >&5 +printf "%s\n" "$PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_PKGCONFIG"; then + ac_pt_PKGCONFIG=$PKGCONFIG + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_PKGCONFIG="$ac_pt_PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_PKGCONFIG=$ac_cv_path_ac_pt_PKGCONFIG +if test -n "$ac_pt_PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKGCONFIG" >&5 +printf "%s\n" "$ac_pt_PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_PKGCONFIG" = x; then + PKGCONFIG="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + PKGCONFIG=$ac_pt_PKGCONFIG + fi +else + PKGCONFIG="$ac_cv_path_PKGCONFIG" +fi + + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for libngtcp2_crypto_ossl options with pkg-config" >&5 +printf %s "checking for libngtcp2_crypto_ossl options with pkg-config... " >&6; } + itexists=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists libngtcp2_crypto_ossl >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + + trc=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libngtcp2_crypto_ossl 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libngtcp2_crypto_ossl 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libngtcp2_crypto_ossl trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libngtcp2_crypto_ossl trace: +---- begin +${trc} +---- end" >&6;} + + fi + PKGCONFIG="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found" >&5 +printf "%s\n" "found" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG"; then + + trc=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libngtcp2_crypto_ossl 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libngtcp2_crypto_ossl 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libngtcp2_crypto_ossl trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libngtcp2_crypto_ossl trace: +---- begin +${trc} +---- end" >&6;} + + fi + fi + fi + + + if test "$PKGCONFIG" != "no"; then + LIB_NGTCP2_CRYPTO_OSSL=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --libs-only-l libngtcp2_crypto_ossl` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: -l is $LIB_NGTCP2_CRYPTO_OSSL" >&5 +printf "%s\n" "$as_me: -l is $LIB_NGTCP2_CRYPTO_OSSL" >&6;} + + CPP_NGTCP2_CRYPTO_OSSL=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --cflags-only-I libngtcp2_crypto_ossl` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: -I is $CPP_NGTCP2_CRYPTO_OSSL" >&5 +printf "%s\n" "$as_me: -I is $CPP_NGTCP2_CRYPTO_OSSL" >&6;} + + LD_NGTCP2_CRYPTO_OSSL=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --libs-only-L libngtcp2_crypto_ossl` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: -L is $LD_NGTCP2_CRYPTO_OSSL" >&5 +printf "%s\n" "$as_me: -L is $LD_NGTCP2_CRYPTO_OSSL" >&6;} + + LDFLAGS="$LDFLAGS $LD_NGTCP2_CRYPTO_OSSL" + LDFLAGSPC="$LDFLAGSPC $LD_NGTCP2_CRYPTO_OSSL" + CPPFLAGS="$CPPFLAGS $CPP_NGTCP2_CRYPTO_OSSL" + LIBS="$LIB_NGTCP2_CRYPTO_OSSL $LIBS" + + if test "$cross_compiling" != "yes"; then + DIR_NGTCP2_CRYPTO_OSSL=`echo $LD_NGTCP2_CRYPTO_OSSL | $SED -e 's/^-L//'` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for ngtcp2_crypto_recv_client_initial_cb in -lngtcp2_crypto_ossl" >&5 +printf %s "checking for ngtcp2_crypto_recv_client_initial_cb in -lngtcp2_crypto_ossl... " >&6; } +if test ${ac_cv_lib_ngtcp2_crypto_ossl_ngtcp2_crypto_recv_client_initial_cb+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lngtcp2_crypto_ossl $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char ngtcp2_crypto_recv_client_initial_cb (); +int main(void) +{ +return ngtcp2_crypto_recv_client_initial_cb (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_ngtcp2_crypto_ossl_ngtcp2_crypto_recv_client_initial_cb=yes +else $as_nop + ac_cv_lib_ngtcp2_crypto_ossl_ngtcp2_crypto_recv_client_initial_cb=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_ngtcp2_crypto_ossl_ngtcp2_crypto_recv_client_initial_cb" >&5 +printf "%s\n" "$ac_cv_lib_ngtcp2_crypto_ossl_ngtcp2_crypto_recv_client_initial_cb" >&6; } +if test "x$ac_cv_lib_ngtcp2_crypto_ossl_ngtcp2_crypto_recv_client_initial_cb" = xyes +then : + + for ac_header in ngtcp2/ngtcp2_crypto.h +do : + ac_fn_c_check_header_compile "$LINENO" "ngtcp2/ngtcp2_crypto.h" "ac_cv_header_ngtcp2_ngtcp2_crypto_h" "$ac_includes_default" +if test "x$ac_cv_header_ngtcp2_ngtcp2_crypto_h" = xyes +then : + printf "%s\n" "#define HAVE_NGTCP2_NGTCP2_CRYPTO_H 1" >>confdefs.h + USE_NGTCP2=1 + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$DIR_NGTCP2_CRYPTO_OSSL" + export CURL_LIBRARY_PATH + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: Added $DIR_NGTCP2_CRYPTO_OSSL to CURL_LIBRARY_PATH" >&5 +printf "%s\n" "$as_me: Added $DIR_NGTCP2_CRYPTO_OSSL to CURL_LIBRARY_PATH" >&6;} + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libngtcp2_crypto_ossl" + +printf "%s\n" "#define OPENSSL_QUIC_API2 1" >>confdefs.h + + +fi + +done + +else $as_nop + LDFLAGS=$CLEANLDFLAGS + LDFLAGSPC=$CLEANLDFLAGSPC + CPPFLAGS=$CLEANCPPFLAGS + LIBS=$CLEANLIBS + +fi + + + else + if test "$want_tcp2" != "default"; then + as_fn_error $? "--with-ngtcp2 was specified but could not find ngtcp2_crypto_ossl pkg-config file." "$LINENO" 5 + fi + fi +fi + +if test "$USE_NGTCP2" = "1" && test "$OPENSSL_ENABLED" = "1" && + (test "$OPENSSL_IS_AWSLC" = "1" || test "$OPENSSL_IS_BORINGSSL" = "1"); then + + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. +set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKGCONFIG="$PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PKGCONFIG=$ac_cv_path_PKGCONFIG +if test -n "$PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PKGCONFIG" >&5 +printf "%s\n" "$PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_PKGCONFIG"; then + ac_pt_PKGCONFIG=$PKGCONFIG + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_PKGCONFIG="$ac_pt_PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_PKGCONFIG=$ac_cv_path_ac_pt_PKGCONFIG +if test -n "$ac_pt_PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKGCONFIG" >&5 +printf "%s\n" "$ac_pt_PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_PKGCONFIG" = x; then + PKGCONFIG="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + PKGCONFIG=$ac_pt_PKGCONFIG + fi +else + PKGCONFIG="$ac_cv_path_PKGCONFIG" +fi + + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for libngtcp2_crypto_boringssl options with pkg-config" >&5 +printf %s "checking for libngtcp2_crypto_boringssl options with pkg-config... " >&6; } + itexists=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists libngtcp2_crypto_boringssl >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + + trc=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libngtcp2_crypto_boringssl 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libngtcp2_crypto_boringssl 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libngtcp2_crypto_boringssl trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libngtcp2_crypto_boringssl trace: +---- begin +${trc} +---- end" >&6;} + + fi + PKGCONFIG="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found" >&5 +printf "%s\n" "found" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG"; then + + trc=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libngtcp2_crypto_boringssl 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libngtcp2_crypto_boringssl 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libngtcp2_crypto_boringssl trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libngtcp2_crypto_boringssl trace: +---- begin +${trc} +---- end" >&6;} + + fi + fi + fi + + + if test "$PKGCONFIG" != "no"; then + LIB_NGTCP2_CRYPTO_BORINGSSL=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --libs-only-l libngtcp2_crypto_boringssl` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: -l is $LIB_NGTCP2_CRYPTO_BORINGSSL" >&5 +printf "%s\n" "$as_me: -l is $LIB_NGTCP2_CRYPTO_BORINGSSL" >&6;} + + CPP_NGTCP2_CRYPTO_BORINGSSL=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --cflags-only-I libngtcp2_crypto_boringssl` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: -I is $CPP_NGTCP2_CRYPTO_BORINGSSL" >&5 +printf "%s\n" "$as_me: -I is $CPP_NGTCP2_CRYPTO_BORINGSSL" >&6;} + + LD_NGTCP2_CRYPTO_BORINGSSL=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --libs-only-L libngtcp2_crypto_boringssl` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: -L is $LD_NGTCP2_CRYPTO_BORINGSSL" >&5 +printf "%s\n" "$as_me: -L is $LD_NGTCP2_CRYPTO_BORINGSSL" >&6;} + + LDFLAGS="$LDFLAGS $LD_NGTCP2_CRYPTO_BORINGSSL" + LDFLAGSPC="$LDFLAGSPC $LD_NGTCP2_CRYPTO_BORINGSSL" + CPPFLAGS="$CPPFLAGS $CPP_NGTCP2_CRYPTO_BORINGSSL" + LIBS="$LIB_NGTCP2_CRYPTO_BORINGSSL $LIBS" + + if test "$cross_compiling" != "yes"; then + DIR_NGTCP2_CRYPTO_BORINGSSL=`echo $LD_NGTCP2_CRYPTO_BORINGSSL | $SED -e 's/^-L//'` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for ngtcp2_crypto_recv_client_initial_cb in -lngtcp2_crypto_boringssl" >&5 +printf %s "checking for ngtcp2_crypto_recv_client_initial_cb in -lngtcp2_crypto_boringssl... " >&6; } +if test ${ac_cv_lib_ngtcp2_crypto_boringssl_ngtcp2_crypto_recv_client_initial_cb+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lngtcp2_crypto_boringssl $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char ngtcp2_crypto_recv_client_initial_cb (); +int main(void) +{ +return ngtcp2_crypto_recv_client_initial_cb (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_ngtcp2_crypto_boringssl_ngtcp2_crypto_recv_client_initial_cb=yes +else $as_nop + ac_cv_lib_ngtcp2_crypto_boringssl_ngtcp2_crypto_recv_client_initial_cb=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_ngtcp2_crypto_boringssl_ngtcp2_crypto_recv_client_initial_cb" >&5 +printf "%s\n" "$ac_cv_lib_ngtcp2_crypto_boringssl_ngtcp2_crypto_recv_client_initial_cb" >&6; } +if test "x$ac_cv_lib_ngtcp2_crypto_boringssl_ngtcp2_crypto_recv_client_initial_cb" = xyes +then : + + for ac_header in ngtcp2/ngtcp2_crypto.h +do : + ac_fn_c_check_header_compile "$LINENO" "ngtcp2/ngtcp2_crypto.h" "ac_cv_header_ngtcp2_ngtcp2_crypto_h" "$ac_includes_default" +if test "x$ac_cv_header_ngtcp2_ngtcp2_crypto_h" = xyes +then : + printf "%s\n" "#define HAVE_NGTCP2_NGTCP2_CRYPTO_H 1" >>confdefs.h + USE_NGTCP2=1 + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$DIR_NGTCP2_CRYPTO_BORINGSSL" + export CURL_LIBRARY_PATH + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: Added $DIR_NGTCP2_CRYPTO_BORINGSSL to CURL_LIBRARY_PATH" >&5 +printf "%s\n" "$as_me: Added $DIR_NGTCP2_CRYPTO_BORINGSSL to CURL_LIBRARY_PATH" >&6;} + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libngtcp2_crypto_boringssl" + +fi + +done + +else $as_nop + LDFLAGS=$CLEANLDFLAGS + LDFLAGSPC=$CLEANLDFLAGSPC + CPPFLAGS=$CLEANCPPFLAGS + LIBS=$CLEANLIBS + +fi + + + else + if test "$want_tcp2" != "default"; then + as_fn_error $? "--with-ngtcp2 was specified but could not find ngtcp2_crypto_boringssl pkg-config file." "$LINENO" 5 + fi + fi +fi + +if test "$USE_NGTCP2" = "1" && test "$GNUTLS_ENABLED" = "1"; then + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. +set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKGCONFIG="$PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PKGCONFIG=$ac_cv_path_PKGCONFIG +if test -n "$PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PKGCONFIG" >&5 +printf "%s\n" "$PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_PKGCONFIG"; then + ac_pt_PKGCONFIG=$PKGCONFIG + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_PKGCONFIG="$ac_pt_PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_PKGCONFIG=$ac_cv_path_ac_pt_PKGCONFIG +if test -n "$ac_pt_PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKGCONFIG" >&5 +printf "%s\n" "$ac_pt_PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_PKGCONFIG" = x; then + PKGCONFIG="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + PKGCONFIG=$ac_pt_PKGCONFIG + fi +else + PKGCONFIG="$ac_cv_path_PKGCONFIG" +fi + + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for libngtcp2_crypto_gnutls options with pkg-config" >&5 +printf %s "checking for libngtcp2_crypto_gnutls options with pkg-config... " >&6; } + itexists=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists libngtcp2_crypto_gnutls >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + + trc=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libngtcp2_crypto_gnutls 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libngtcp2_crypto_gnutls 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libngtcp2_crypto_gnutls trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libngtcp2_crypto_gnutls trace: +---- begin +${trc} +---- end" >&6;} + + fi + PKGCONFIG="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found" >&5 +printf "%s\n" "found" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG"; then + + trc=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libngtcp2_crypto_gnutls 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libngtcp2_crypto_gnutls 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libngtcp2_crypto_gnutls trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libngtcp2_crypto_gnutls trace: +---- begin +${trc} +---- end" >&6;} + + fi + fi + fi + + + if test "$PKGCONFIG" != "no"; then + LIB_NGTCP2_CRYPTO_GNUTLS=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --libs-only-l libngtcp2_crypto_gnutls` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: -l is $LIB_NGTCP2_CRYPTO_GNUTLS" >&5 +printf "%s\n" "$as_me: -l is $LIB_NGTCP2_CRYPTO_GNUTLS" >&6;} + + CPP_NGTCP2_CRYPTO_GNUTLS=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --cflags-only-I libngtcp2_crypto_gnutls` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: -I is $CPP_NGTCP2_CRYPTO_GNUTLS" >&5 +printf "%s\n" "$as_me: -I is $CPP_NGTCP2_CRYPTO_GNUTLS" >&6;} + + LD_NGTCP2_CRYPTO_GNUTLS=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --libs-only-L libngtcp2_crypto_gnutls` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: -L is $LD_NGTCP2_CRYPTO_GNUTLS" >&5 +printf "%s\n" "$as_me: -L is $LD_NGTCP2_CRYPTO_GNUTLS" >&6;} + + LDFLAGS="$LDFLAGS $LD_NGTCP2_CRYPTO_GNUTLS" + LDFLAGSPC="$LDFLAGSPC $LD_NGTCP2_CRYPTO_GNUTLS" + CPPFLAGS="$CPPFLAGS $CPP_NGTCP2_CRYPTO_GNUTLS" + LIBS="$LIB_NGTCP2_CRYPTO_GNUTLS $LIBS" + + if test "$cross_compiling" != "yes"; then + DIR_NGTCP2_CRYPTO_GNUTLS=`echo $LD_NGTCP2_CRYPTO_GNUTLS | $SED -e 's/^-L//'` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for ngtcp2_crypto_recv_client_initial_cb in -lngtcp2_crypto_gnutls" >&5 +printf %s "checking for ngtcp2_crypto_recv_client_initial_cb in -lngtcp2_crypto_gnutls... " >&6; } +if test ${ac_cv_lib_ngtcp2_crypto_gnutls_ngtcp2_crypto_recv_client_initial_cb+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lngtcp2_crypto_gnutls $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char ngtcp2_crypto_recv_client_initial_cb (); +int main(void) +{ +return ngtcp2_crypto_recv_client_initial_cb (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_ngtcp2_crypto_gnutls_ngtcp2_crypto_recv_client_initial_cb=yes +else $as_nop + ac_cv_lib_ngtcp2_crypto_gnutls_ngtcp2_crypto_recv_client_initial_cb=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_ngtcp2_crypto_gnutls_ngtcp2_crypto_recv_client_initial_cb" >&5 +printf "%s\n" "$ac_cv_lib_ngtcp2_crypto_gnutls_ngtcp2_crypto_recv_client_initial_cb" >&6; } +if test "x$ac_cv_lib_ngtcp2_crypto_gnutls_ngtcp2_crypto_recv_client_initial_cb" = xyes +then : + + for ac_header in ngtcp2/ngtcp2_crypto.h +do : + ac_fn_c_check_header_compile "$LINENO" "ngtcp2/ngtcp2_crypto.h" "ac_cv_header_ngtcp2_ngtcp2_crypto_h" "$ac_includes_default" +if test "x$ac_cv_header_ngtcp2_ngtcp2_crypto_h" = xyes +then : + printf "%s\n" "#define HAVE_NGTCP2_NGTCP2_CRYPTO_H 1" >>confdefs.h + USE_NGTCP2=1 + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$DIR_NGTCP2_CRYPTO_GNUTLS" + export CURL_LIBRARY_PATH + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: Added $DIR_NGTCP2_CRYPTO_GNUTLS to CURL_LIBRARY_PATH" >&5 +printf "%s\n" "$as_me: Added $DIR_NGTCP2_CRYPTO_GNUTLS to CURL_LIBRARY_PATH" >&6;} + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libngtcp2_crypto_gnutls" + +fi + +done + +else $as_nop + LDFLAGS=$CLEANLDFLAGS + LDFLAGSPC=$CLEANLDFLAGSPC + CPPFLAGS=$CLEANCPPFLAGS + LIBS=$CLEANLIBS + +fi + + + else + if test "$want_tcp2" != "default"; then + as_fn_error $? "--with-ngtcp2 was specified but could not find ngtcp2_crypto_gnutls pkg-config file." "$LINENO" 5 + fi + fi +fi + +if test "$USE_NGTCP2" = "1" && test "$WOLFSSL_ENABLED" = "1"; then + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. +set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKGCONFIG="$PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PKGCONFIG=$ac_cv_path_PKGCONFIG +if test -n "$PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PKGCONFIG" >&5 +printf "%s\n" "$PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_PKGCONFIG"; then + ac_pt_PKGCONFIG=$PKGCONFIG + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_PKGCONFIG="$ac_pt_PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_PKGCONFIG=$ac_cv_path_ac_pt_PKGCONFIG +if test -n "$ac_pt_PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKGCONFIG" >&5 +printf "%s\n" "$ac_pt_PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_PKGCONFIG" = x; then + PKGCONFIG="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + PKGCONFIG=$ac_pt_PKGCONFIG + fi +else + PKGCONFIG="$ac_cv_path_PKGCONFIG" +fi + + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for libngtcp2_crypto_wolfssl options with pkg-config" >&5 +printf %s "checking for libngtcp2_crypto_wolfssl options with pkg-config... " >&6; } + itexists=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists libngtcp2_crypto_wolfssl >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + + trc=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libngtcp2_crypto_wolfssl 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libngtcp2_crypto_wolfssl 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libngtcp2_crypto_wolfssl trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libngtcp2_crypto_wolfssl trace: +---- begin +${trc} +---- end" >&6;} + + fi + PKGCONFIG="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found" >&5 +printf "%s\n" "found" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG"; then + + trc=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libngtcp2_crypto_wolfssl 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libngtcp2_crypto_wolfssl 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libngtcp2_crypto_wolfssl trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libngtcp2_crypto_wolfssl trace: +---- begin +${trc} +---- end" >&6;} + + fi + fi + fi + + + if test "$PKGCONFIG" != "no"; then + LIB_NGTCP2_CRYPTO_WOLFSSL=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --libs-only-l libngtcp2_crypto_wolfssl` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: -l is $LIB_NGTCP2_CRYPTO_WOLFSSL" >&5 +printf "%s\n" "$as_me: -l is $LIB_NGTCP2_CRYPTO_WOLFSSL" >&6;} + + CPP_NGTCP2_CRYPTO_WOLFSSL=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --cflags-only-I libngtcp2_crypto_wolfssl` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: -I is $CPP_NGTCP2_CRYPTO_WOLFSSL" >&5 +printf "%s\n" "$as_me: -I is $CPP_NGTCP2_CRYPTO_WOLFSSL" >&6;} + + LD_NGTCP2_CRYPTO_WOLFSSL=` + if test -n "$want_tcp2_path"; then + if test -n "1"; then + PKG_CONFIG_PATH="$want_tcp2_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_tcp2_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --libs-only-L libngtcp2_crypto_wolfssl` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: -L is $LD_NGTCP2_CRYPTO_WOLFSSL" >&5 +printf "%s\n" "$as_me: -L is $LD_NGTCP2_CRYPTO_WOLFSSL" >&6;} + + LDFLAGS="$LDFLAGS $LD_NGTCP2_CRYPTO_WOLFSSL" + LDFLAGSPC="$LDFLAGSPC $LD_NGTCP2_CRYPTO_WOLFSSL" + CPPFLAGS="$CPPFLAGS $CPP_NGTCP2_CRYPTO_WOLFSSL" + LIBS="$LIB_NGTCP2_CRYPTO_WOLFSSL $LIBS" + + if test "$cross_compiling" != "yes"; then + DIR_NGTCP2_CRYPTO_WOLFSSL=`echo $LD_NGTCP2_CRYPTO_WOLFSSL | $SED -e 's/^-L//'` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for ngtcp2_crypto_recv_client_initial_cb in -lngtcp2_crypto_wolfssl" >&5 +printf %s "checking for ngtcp2_crypto_recv_client_initial_cb in -lngtcp2_crypto_wolfssl... " >&6; } +if test ${ac_cv_lib_ngtcp2_crypto_wolfssl_ngtcp2_crypto_recv_client_initial_cb+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lngtcp2_crypto_wolfssl $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char ngtcp2_crypto_recv_client_initial_cb (); +int main(void) +{ +return ngtcp2_crypto_recv_client_initial_cb (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_ngtcp2_crypto_wolfssl_ngtcp2_crypto_recv_client_initial_cb=yes +else $as_nop + ac_cv_lib_ngtcp2_crypto_wolfssl_ngtcp2_crypto_recv_client_initial_cb=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_ngtcp2_crypto_wolfssl_ngtcp2_crypto_recv_client_initial_cb" >&5 +printf "%s\n" "$ac_cv_lib_ngtcp2_crypto_wolfssl_ngtcp2_crypto_recv_client_initial_cb" >&6; } +if test "x$ac_cv_lib_ngtcp2_crypto_wolfssl_ngtcp2_crypto_recv_client_initial_cb" = xyes +then : + + for ac_header in ngtcp2/ngtcp2_crypto.h +do : + ac_fn_c_check_header_compile "$LINENO" "ngtcp2/ngtcp2_crypto.h" "ac_cv_header_ngtcp2_ngtcp2_crypto_h" "$ac_includes_default" +if test "x$ac_cv_header_ngtcp2_ngtcp2_crypto_h" = xyes +then : + printf "%s\n" "#define HAVE_NGTCP2_NGTCP2_CRYPTO_H 1" >>confdefs.h + USE_NGTCP2=1 + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$DIR_NGTCP2_CRYPTO_WOLFSSL" + export CURL_LIBRARY_PATH + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: Added $DIR_NGTCP2_CRYPTO_WOLFSSL to CURL_LIBRARY_PATH" >&5 +printf "%s\n" "$as_me: Added $DIR_NGTCP2_CRYPTO_WOLFSSL to CURL_LIBRARY_PATH" >&6;} + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libngtcp2_crypto_wolfssl" + +fi + +done + +else $as_nop + LDFLAGS=$CLEANLDFLAGS + LDFLAGSPC=$CLEANLDFLAGSPC + CPPFLAGS=$CLEANCPPFLAGS + LIBS=$CLEANLIBS + +fi + + + else + if test "$want_tcp2" != "default"; then + as_fn_error $? "--with-ngtcp2 was specified but could not find ngtcp2_crypto_wolfssl pkg-config file." "$LINENO" 5 + fi + fi +fi + + +OPT_NGHTTP3="yes" + +if test "$USE_NGTCP2" != "1"; then + OPT_NGHTTP3="no" + want_nghttp3="no" +fi + + +# Check whether --with-nghttp3 was given. +if test ${with_nghttp3+y} +then : + withval=$with_nghttp3; OPT_NGHTTP3=$withval +fi + +case "$OPT_NGHTTP3" in + no) + want_nghttp3="no" + ;; + yes) + want_nghttp3="default" + want_nghttp3_path="" + ;; + *) + want_nghttp3="yes" + want_nghttp3_path="$OPT_NGHTTP3/lib/pkgconfig" + ;; +esac + +curl_http3_msg="no (--with-nghttp3)" +if test "$want_nghttp3" != "no"; then + + if test "x$USE_NGTCP2" != "x1"; then + as_fn_error $? "nghttp3 enabled without a QUIC library; enable ngtcp2" "$LINENO" 5 + fi + + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. +set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKGCONFIG="$PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PKGCONFIG=$ac_cv_path_PKGCONFIG +if test -n "$PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PKGCONFIG" >&5 +printf "%s\n" "$PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_PKGCONFIG"; then + ac_pt_PKGCONFIG=$PKGCONFIG + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_PKGCONFIG="$ac_pt_PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_PKGCONFIG=$ac_cv_path_ac_pt_PKGCONFIG +if test -n "$ac_pt_PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKGCONFIG" >&5 +printf "%s\n" "$ac_pt_PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_PKGCONFIG" = x; then + PKGCONFIG="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + PKGCONFIG=$ac_pt_PKGCONFIG + fi +else + PKGCONFIG="$ac_cv_path_PKGCONFIG" +fi + + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for libnghttp3 options with pkg-config" >&5 +printf %s "checking for libnghttp3 options with pkg-config... " >&6; } + itexists=` + if test -n "$want_nghttp3_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_nghttp3_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_nghttp3_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists libnghttp3 >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + + trc=` + if test -n "$want_nghttp3_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_nghttp3_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_nghttp3_path" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libnghttp3 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$want_nghttp3_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_nghttp3_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_nghttp3_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libnghttp3 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libnghttp3 trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libnghttp3 trace: +---- begin +${trc} +---- end" >&6;} + + fi + PKGCONFIG="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found" >&5 +printf "%s\n" "found" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG"; then + + trc=` + if test -n "$want_nghttp3_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_nghttp3_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_nghttp3_path" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libnghttp3 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$want_nghttp3_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_nghttp3_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_nghttp3_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libnghttp3 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libnghttp3 trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libnghttp3 trace: +---- begin +${trc} +---- end" >&6;} + + fi + fi + fi + + + if test "$PKGCONFIG" != "no"; then + LIB_NGHTTP3=` + if test -n "$want_nghttp3_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_nghttp3_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_nghttp3_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --libs-only-l libnghttp3` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: -l is $LIB_NGHTTP3" >&5 +printf "%s\n" "$as_me: -l is $LIB_NGHTTP3" >&6;} + + CPP_NGHTTP3=` + if test -n "$want_nghttp3_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_nghttp3_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_nghttp3_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --cflags-only-I libnghttp3` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: -I is $CPP_NGHTTP3" >&5 +printf "%s\n" "$as_me: -I is $CPP_NGHTTP3" >&6;} + + LD_NGHTTP3=` + if test -n "$want_nghttp3_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_nghttp3_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_nghttp3_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --libs-only-L libnghttp3` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: -L is $LD_NGHTTP3" >&5 +printf "%s\n" "$as_me: -L is $LD_NGHTTP3" >&6;} + + LDFLAGS="$LDFLAGS $LD_NGHTTP3" + LDFLAGSPC="$LDFLAGSPC $LD_NGHTTP3" + CPPFLAGS="$CPPFLAGS $CPP_NGHTTP3" + LIBS="$LIB_NGHTTP3 $LIBS" + + if test "$cross_compiling" != "yes"; then + DIR_NGHTTP3=`echo $LD_NGHTTP3 | $SED -e 's/^-L//'` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for nghttp3_conn_client_new_versioned in -lnghttp3" >&5 +printf %s "checking for nghttp3_conn_client_new_versioned in -lnghttp3... " >&6; } +if test ${ac_cv_lib_nghttp3_nghttp3_conn_client_new_versioned+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lnghttp3 $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char nghttp3_conn_client_new_versioned (); +int main(void) +{ +return nghttp3_conn_client_new_versioned (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_nghttp3_nghttp3_conn_client_new_versioned=yes +else $as_nop + ac_cv_lib_nghttp3_nghttp3_conn_client_new_versioned=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_nghttp3_nghttp3_conn_client_new_versioned" >&5 +printf "%s\n" "$ac_cv_lib_nghttp3_nghttp3_conn_client_new_versioned" >&6; } +if test "x$ac_cv_lib_nghttp3_nghttp3_conn_client_new_versioned" = xyes +then : + + for ac_header in nghttp3/nghttp3.h +do : + ac_fn_c_check_header_compile "$LINENO" "nghttp3/nghttp3.h" "ac_cv_header_nghttp3_nghttp3_h" "$ac_includes_default" +if test "x$ac_cv_header_nghttp3_nghttp3_h" = xyes +then : + printf "%s\n" "#define HAVE_NGHTTP3_NGHTTP3_H 1" >>confdefs.h + +printf "%s\n" "#define USE_NGHTTP3 1" >>confdefs.h + + USE_NGHTTP3=1 + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$DIR_NGHTTP3" + export CURL_LIBRARY_PATH + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: Added $DIR_NGHTTP3 to CURL_LIBRARY_PATH" >&5 +printf "%s\n" "$as_me: Added $DIR_NGHTTP3 to CURL_LIBRARY_PATH" >&6;} + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libnghttp3" + +fi + +done + +else $as_nop + LDFLAGS=$CLEANLDFLAGS + LDFLAGSPC=$CLEANLDFLAGSPC + CPPFLAGS=$CLEANCPPFLAGS + LIBS=$CLEANLIBS + +fi + + else + if test "$want_nghttp3" != "default"; then + as_fn_error $? "--with-nghttp3 was specified but could not find nghttp3 pkg-config file." "$LINENO" 5 + fi + fi +fi + + +if test "$USE_NGTCP2" = "1" && test "$USE_NGHTTP3" = "1"; then + USE_NGTCP2_H3=1 + curl_h3_msg="enabled (ngtcp2 + nghttp3)" +fi + + +OPT_QUICHE="no" + +if test "$disable_http" = "yes" || test "$USE_NGTCP" = "1"; then + OPT_QUICHE="no" +fi + + +# Check whether --with-quiche was given. +if test ${with_quiche+y} +then : + withval=$with_quiche; OPT_QUICHE=$withval +fi + +case "$OPT_QUICHE" in + no) + want_quiche="no" + ;; + yes) + want_quiche="default" + want_quiche_path="" + ;; + *) + want_quiche="yes" + want_quiche_path="$withval" + ;; +esac + +if test "$want_quiche" != "no"; then + + if test "$QUIC_ENABLED" != "yes"; then + as_fn_error $? "the detected TLS library does not support QUIC, making --with-quiche a no-no" "$LINENO" 5 + fi + + if test "$NGHTTP3_ENABLED" = "1"; then + as_fn_error $? "--with-quiche and --with-ngtcp2 are mutually exclusive" "$LINENO" 5 + fi + + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. +set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKGCONFIG="$PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PKGCONFIG=$ac_cv_path_PKGCONFIG +if test -n "$PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PKGCONFIG" >&5 +printf "%s\n" "$PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_PKGCONFIG"; then + ac_pt_PKGCONFIG=$PKGCONFIG + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_PKGCONFIG="$ac_pt_PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_PKGCONFIG=$ac_cv_path_ac_pt_PKGCONFIG +if test -n "$ac_pt_PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKGCONFIG" >&5 +printf "%s\n" "$ac_pt_PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_PKGCONFIG" = x; then + PKGCONFIG="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + PKGCONFIG=$ac_pt_PKGCONFIG + fi +else + PKGCONFIG="$ac_cv_path_PKGCONFIG" +fi + + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for quiche options with pkg-config" >&5 +printf %s "checking for quiche options with pkg-config... " >&6; } + itexists=` + if test -n "$want_quiche_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_quiche_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_quiche_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists quiche >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + + trc=` + if test -n "$want_quiche_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_quiche_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_quiche_path" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug quiche 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$want_quiche_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_quiche_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_quiche_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors quiche 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists quiche trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists quiche trace: +---- begin +${trc} +---- end" >&6;} + + fi + PKGCONFIG="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found" >&5 +printf "%s\n" "found" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG"; then + + trc=` + if test -n "$want_quiche_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_quiche_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_quiche_path" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug quiche 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$want_quiche_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_quiche_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_quiche_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors quiche 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists quiche trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists quiche trace: +---- begin +${trc} +---- end" >&6;} + + fi + fi + fi + + + if test "$PKGCONFIG" != "no"; then + LIB_QUICHE=` + if test -n "$want_quiche_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_quiche_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_quiche_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --libs-only-l quiche` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: -l is $LIB_QUICHE" >&5 +printf "%s\n" "$as_me: -l is $LIB_QUICHE" >&6;} + + CPP_QUICHE=` + if test -n "$want_quiche_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_quiche_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_quiche_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --cflags-only-I quiche` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: -I is $CPP_QUICHE" >&5 +printf "%s\n" "$as_me: -I is $CPP_QUICHE" >&6;} + + LD_QUICHE=` + if test -n "$want_quiche_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_quiche_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_quiche_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --libs-only-L quiche` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: -L is $LD_QUICHE" >&5 +printf "%s\n" "$as_me: -L is $LD_QUICHE" >&6;} + + LDFLAGS="$LDFLAGS $LD_QUICHE" + LDFLAGSPC="$LDFLAGSPC $LD_QUICHE" + CPPFLAGS="$CPPFLAGS $CPP_QUICHE" + LIBS="$LIB_QUICHE $LIBS" + + if test "$cross_compiling" != "yes"; then + DIR_QUICHE=`echo $LD_QUICHE | $SED -e 's/^-L//'` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for quiche_conn_send_ack_eliciting in -lquiche" >&5 +printf %s "checking for quiche_conn_send_ack_eliciting in -lquiche... " >&6; } +if test ${ac_cv_lib_quiche_quiche_conn_send_ack_eliciting+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lquiche $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char quiche_conn_send_ack_eliciting (); +int main(void) +{ +return quiche_conn_send_ack_eliciting (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_quiche_quiche_conn_send_ack_eliciting=yes +else $as_nop + ac_cv_lib_quiche_quiche_conn_send_ack_eliciting=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_quiche_quiche_conn_send_ack_eliciting" >&5 +printf "%s\n" "$ac_cv_lib_quiche_quiche_conn_send_ack_eliciting" >&6; } +if test "x$ac_cv_lib_quiche_quiche_conn_send_ack_eliciting" = xyes +then : + + for ac_header in quiche.h +do : + ac_fn_c_check_header_compile "$LINENO" "quiche.h" "ac_cv_header_quiche_h" " + $ac_includes_default + #include + + +" +if test "x$ac_cv_header_quiche_h" = xyes +then : + printf "%s\n" "#define HAVE_QUICHE_H 1" >>confdefs.h + experimental="$experimental Quiche" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: HTTP3 support is experimental" >&5 +printf "%s\n" "$as_me: HTTP3 support is experimental" >&6;} + curl_h3_msg="enabled (quiche)" + +printf "%s\n" "#define USE_QUICHE 1" >>confdefs.h + + USE_QUICHE=1 + ac_fn_c_check_func "$LINENO" "quiche_conn_set_qlog_fd" "ac_cv_func_quiche_conn_set_qlog_fd" +if test "x$ac_cv_func_quiche_conn_set_qlog_fd" = xyes +then : + printf "%s\n" "#define HAVE_QUICHE_CONN_SET_QLOG_FD 1" >>confdefs.h + +fi + + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$DIR_QUICHE" + export CURL_LIBRARY_PATH + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: Added $DIR_QUICHE to CURL_LIBRARY_PATH" >&5 +printf "%s\n" "$as_me: Added $DIR_QUICHE to CURL_LIBRARY_PATH" >&6;} + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE quiche" +fi + +done + +else $as_nop + as_fn_error $? "could not use quiche" "$LINENO" 5 + +fi + + else + if test "$want_quiche" != "default"; then + as_fn_error $? "--with-quiche was specified but could not find quiche pkg-config file." "$LINENO" 5 + fi + fi +fi + + +OPT_LIBUV=no + +# Check whether --with-libuv was given. +if test ${with_libuv+y} +then : + withval=$with_libuv; OPT_LIBUV=$withval +fi + +case "$OPT_LIBUV" in + no) + want_libuv="no" + ;; + yes) + want_libuv="default" + want_libuv_path="" + ;; + *) + want_libuv="yes" + want_libuv_path="$withval" + ;; +esac + +if test "$want_libuv" != "no"; then + if test "$want_debug" != "yes"; then + as_fn_error $? "Using libuv without debug support enabled is useless" "$LINENO" 5 + fi + + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. +set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKGCONFIG="$PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PKGCONFIG=$ac_cv_path_PKGCONFIG +if test -n "$PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PKGCONFIG" >&5 +printf "%s\n" "$PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_PKGCONFIG"; then + ac_pt_PKGCONFIG=$PKGCONFIG + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_PKGCONFIG="$ac_pt_PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_PKGCONFIG=$ac_cv_path_ac_pt_PKGCONFIG +if test -n "$ac_pt_PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKGCONFIG" >&5 +printf "%s\n" "$ac_pt_PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_PKGCONFIG" = x; then + PKGCONFIG="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + PKGCONFIG=$ac_pt_PKGCONFIG + fi +else + PKGCONFIG="$ac_cv_path_PKGCONFIG" +fi + + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for libuv options with pkg-config" >&5 +printf %s "checking for libuv options with pkg-config... " >&6; } + itexists=` + if test -n "$want_libuv_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_libuv_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_libuv_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists libuv >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + + trc=` + if test -n "$want_libuv_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_libuv_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_libuv_path" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libuv 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$want_libuv_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_libuv_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_libuv_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libuv 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libuv trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libuv trace: +---- begin +${trc} +---- end" >&6;} + + fi + PKGCONFIG="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found" >&5 +printf "%s\n" "found" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG"; then + + trc=` + if test -n "$want_libuv_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_libuv_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_libuv_path" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libuv 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$want_libuv_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_libuv_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_libuv_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libuv 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libuv trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libuv trace: +---- begin +${trc} +---- end" >&6;} + + fi + fi + fi + + + if test "$PKGCONFIG" != "no"; then + LIB_LIBUV=` + if test -n "$want_libuv_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_libuv_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_libuv_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --libs-only-l libuv` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: -l is $LIB_LIBUV" >&5 +printf "%s\n" "$as_me: -l is $LIB_LIBUV" >&6;} + + CPP_LIBUV=` + if test -n "$want_libuv_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_libuv_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_libuv_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --cflags-only-I libuv` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: -I is $CPP_LIBUV" >&5 +printf "%s\n" "$as_me: -I is $CPP_LIBUV" >&6;} + + LD_LIBUV=` + if test -n "$want_libuv_path"; then + if test -n ""; then + PKG_CONFIG_PATH="$want_libuv_path${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$want_libuv_path" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --libs-only-L libuv` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: -L is $LD_LIBUV" >&5 +printf "%s\n" "$as_me: -L is $LD_LIBUV" >&6;} + + LDFLAGS="$LDFLAGS $LD_LIBUV" + LDFLAGSPC="$LDFLAGSPC $LD_LIBUV" + CPPFLAGS="$CPPFLAGS $CPP_LIBUV" + LIBS="$LIB_LIBUV $LIBS" + + if test "$cross_compiling" != "yes"; then + DIR_LIBUV=`echo $LD_LIBUV | $SED -e 's/^-L//'` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for uv_default_loop in -luv" >&5 +printf %s "checking for uv_default_loop in -luv... " >&6; } +if test ${ac_cv_lib_uv_uv_default_loop+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-luv $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char uv_default_loop (); +int main(void) +{ +return uv_default_loop (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_uv_uv_default_loop=yes +else $as_nop + ac_cv_lib_uv_uv_default_loop=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_uv_uv_default_loop" >&5 +printf "%s\n" "$ac_cv_lib_uv_uv_default_loop" >&6; } +if test "x$ac_cv_lib_uv_uv_default_loop" = xyes +then : + + for ac_header in uv.h +do : + ac_fn_c_check_header_compile "$LINENO" "uv.h" "ac_cv_header_uv_h" "$ac_includes_default" +if test "x$ac_cv_header_uv_h" = xyes +then : + printf "%s\n" "#define HAVE_UV_H 1" >>confdefs.h + +printf "%s\n" "#define USE_LIBUV 1" >>confdefs.h + + USE_LIBUV=1 + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$DIR_LIBUV" + export CURL_LIBRARY_PATH + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: Added $DIR_LIBUV to CURL_LIBRARY_PATH" >&5 +printf "%s\n" "$as_me: Added $DIR_LIBUV to CURL_LIBRARY_PATH" >&6;} + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libuv" + +fi + +done + +else $as_nop + LDFLAGS=$CLEANLDFLAGS + LDFLAGSPC=$CLEANLDFLAGSPC + CPPFLAGS=$CLEANCPPFLAGS + LIBS=$CLEANLIBS + +fi + + else + if test "$want_libuv" != "default"; then + as_fn_error $? "--with-libuv was specified but could not find libuv pkg-config file." "$LINENO" 5 + fi + fi + +fi + + +OPT_ZSH_FPATH=default + +# Check whether --with-zsh-functions-dir was given. +if test ${with_zsh_functions_dir+y} +then : + withval=$with_zsh_functions_dir; OPT_ZSH_FPATH=$withval +fi + +case "$OPT_ZSH_FPATH" in + default|no) + ;; + yes) + ZSH_FUNCTIONS_DIR="$datarootdir/zsh/site-functions" + + ;; + *) + ZSH_FUNCTIONS_DIR="$withval" + + ;; +esac +if test -z "$PERL" && test -n "$ZSH_FUNCTIONS_DIR"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: perl was not found. Cannot install zsh completions." >&5 +printf "%s\n" "$as_me: WARNING: perl was not found. Cannot install zsh completions." >&2;} + ZSH_FUNCTIONS_DIR='' +fi + if test -n "$ZSH_FUNCTIONS_DIR"; then + USE_ZSH_COMPLETION_TRUE= + USE_ZSH_COMPLETION_FALSE='#' +else + USE_ZSH_COMPLETION_TRUE='#' + USE_ZSH_COMPLETION_FALSE= +fi + + + +OPT_FISH_FPATH=default + +# Check whether --with-fish-functions-dir was given. +if test ${with_fish_functions_dir+y} +then : + withval=$with_fish_functions_dir; OPT_FISH_FPATH=$withval +fi + +case "$OPT_FISH_FPATH" in + default|no) + ;; + yes) + + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. +set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKGCONFIG="$PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PKGCONFIG=$ac_cv_path_PKGCONFIG +if test -n "$PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PKGCONFIG" >&5 +printf "%s\n" "$PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_PKGCONFIG"; then + ac_pt_PKGCONFIG=$PKGCONFIG + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_PKGCONFIG="$ac_pt_PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_PKGCONFIG=$ac_cv_path_ac_pt_PKGCONFIG +if test -n "$ac_pt_PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKGCONFIG" >&5 +printf "%s\n" "$ac_pt_PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_PKGCONFIG" = x; then + PKGCONFIG="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + PKGCONFIG=$ac_pt_PKGCONFIG + fi +else + PKGCONFIG="$ac_cv_path_PKGCONFIG" +fi + + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for fish options with pkg-config" >&5 +printf %s "checking for fish options with pkg-config... " >&6; } + itexists=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists fish >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + + trc=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug fish 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors fish 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists fish trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists fish trace: +---- begin +${trc} +---- end" >&6;} + + fi + PKGCONFIG="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found" >&5 +printf "%s\n" "found" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG"; then + + trc=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug fish 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors fish 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists fish trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists fish trace: +---- begin +${trc} +---- end" >&6;} + + fi + fi + fi + + if test "$PKGCONFIG" != "no"; then + FISH_FUNCTIONS_DIR=`$PKGCONFIG --variable completionsdir fish` + else + FISH_FUNCTIONS_DIR="$datarootdir/fish/vendor_completions.d" + fi + + ;; + *) + FISH_FUNCTIONS_DIR="$withval" + + ;; +esac +if test -z "$PERL" && test -n "$FISH_FUNCTIONS_DIR"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: perl was not found. Cannot install fish completions." >&5 +printf "%s\n" "$as_me: WARNING: perl was not found. Cannot install fish completions." >&2;} + FISH_FUNCTIONS_DIR='' +fi + if test -n "$FISH_FUNCTIONS_DIR"; then + USE_FISH_COMPLETION_TRUE= + USE_FISH_COMPLETION_FALSE='#' +else + USE_FISH_COMPLETION_TRUE='#' + USE_FISH_COMPLETION_FALSE= +fi + + +ac_fn_c_check_header_compile "$LINENO" "sys/types.h" "ac_cv_header_sys_types_h" "/* default includes */ + +#include +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#if !defined(_WIN32) || defined(__MINGW32__) +#include +#endif +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif +#ifndef _WIN32 +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include /* is this really required to detect other headers? */ +#endif +#ifdef HAVE_SYS_UN_H +#include /* is this really required to detect other headers? */ +#endif + + +" +if test "x$ac_cv_header_sys_types_h" = xyes +then : + printf "%s\n" "#define HAVE_SYS_TYPES_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "sys/select.h" "ac_cv_header_sys_select_h" "/* default includes */ + +#include +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#if !defined(_WIN32) || defined(__MINGW32__) +#include +#endif +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif +#ifndef _WIN32 +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include /* is this really required to detect other headers? */ +#endif +#ifdef HAVE_SYS_UN_H +#include /* is this really required to detect other headers? */ +#endif + + +" +if test "x$ac_cv_header_sys_select_h" = xyes +then : + printf "%s\n" "#define HAVE_SYS_SELECT_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "sys/ioctl.h" "ac_cv_header_sys_ioctl_h" "/* default includes */ + +#include +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#if !defined(_WIN32) || defined(__MINGW32__) +#include +#endif +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif +#ifndef _WIN32 +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include /* is this really required to detect other headers? */ +#endif +#ifdef HAVE_SYS_UN_H +#include /* is this really required to detect other headers? */ +#endif + + +" +if test "x$ac_cv_header_sys_ioctl_h" = xyes +then : + printf "%s\n" "#define HAVE_SYS_IOCTL_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "unistd.h" "ac_cv_header_unistd_h" "/* default includes */ + +#include +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#if !defined(_WIN32) || defined(__MINGW32__) +#include +#endif +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif +#ifndef _WIN32 +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include /* is this really required to detect other headers? */ +#endif +#ifdef HAVE_SYS_UN_H +#include /* is this really required to detect other headers? */ +#endif + + +" +if test "x$ac_cv_header_unistd_h" = xyes +then : + printf "%s\n" "#define HAVE_UNISTD_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "arpa/inet.h" "ac_cv_header_arpa_inet_h" "/* default includes */ + +#include +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#if !defined(_WIN32) || defined(__MINGW32__) +#include +#endif +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif +#ifndef _WIN32 +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include /* is this really required to detect other headers? */ +#endif +#ifdef HAVE_SYS_UN_H +#include /* is this really required to detect other headers? */ +#endif + + +" +if test "x$ac_cv_header_arpa_inet_h" = xyes +then : + printf "%s\n" "#define HAVE_ARPA_INET_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "net/if.h" "ac_cv_header_net_if_h" "/* default includes */ + +#include +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#if !defined(_WIN32) || defined(__MINGW32__) +#include +#endif +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif +#ifndef _WIN32 +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include /* is this really required to detect other headers? */ +#endif +#ifdef HAVE_SYS_UN_H +#include /* is this really required to detect other headers? */ +#endif + + +" +if test "x$ac_cv_header_net_if_h" = xyes +then : + printf "%s\n" "#define HAVE_NET_IF_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "netinet/in.h" "ac_cv_header_netinet_in_h" "/* default includes */ + +#include +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#if !defined(_WIN32) || defined(__MINGW32__) +#include +#endif +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif +#ifndef _WIN32 +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include /* is this really required to detect other headers? */ +#endif +#ifdef HAVE_SYS_UN_H +#include /* is this really required to detect other headers? */ +#endif + + +" +if test "x$ac_cv_header_netinet_in_h" = xyes +then : + printf "%s\n" "#define HAVE_NETINET_IN_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "netinet/in6.h" "ac_cv_header_netinet_in6_h" "/* default includes */ + +#include +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#if !defined(_WIN32) || defined(__MINGW32__) +#include +#endif +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif +#ifndef _WIN32 +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include /* is this really required to detect other headers? */ +#endif +#ifdef HAVE_SYS_UN_H +#include /* is this really required to detect other headers? */ +#endif + + +" +if test "x$ac_cv_header_netinet_in6_h" = xyes +then : + printf "%s\n" "#define HAVE_NETINET_IN6_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "sys/un.h" "ac_cv_header_sys_un_h" "/* default includes */ + +#include +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#if !defined(_WIN32) || defined(__MINGW32__) +#include +#endif +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif +#ifndef _WIN32 +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include /* is this really required to detect other headers? */ +#endif +#ifdef HAVE_SYS_UN_H +#include /* is this really required to detect other headers? */ +#endif + + +" +if test "x$ac_cv_header_sys_un_h" = xyes +then : + printf "%s\n" "#define HAVE_SYS_UN_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "linux/tcp.h" "ac_cv_header_linux_tcp_h" "/* default includes */ + +#include +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#if !defined(_WIN32) || defined(__MINGW32__) +#include +#endif +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif +#ifndef _WIN32 +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include /* is this really required to detect other headers? */ +#endif +#ifdef HAVE_SYS_UN_H +#include /* is this really required to detect other headers? */ +#endif + + +" +if test "x$ac_cv_header_linux_tcp_h" = xyes +then : + printf "%s\n" "#define HAVE_LINUX_TCP_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "netinet/tcp.h" "ac_cv_header_netinet_tcp_h" "/* default includes */ + +#include +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#if !defined(_WIN32) || defined(__MINGW32__) +#include +#endif +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif +#ifndef _WIN32 +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include /* is this really required to detect other headers? */ +#endif +#ifdef HAVE_SYS_UN_H +#include /* is this really required to detect other headers? */ +#endif + + +" +if test "x$ac_cv_header_netinet_tcp_h" = xyes +then : + printf "%s\n" "#define HAVE_NETINET_TCP_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "netinet/udp.h" "ac_cv_header_netinet_udp_h" "/* default includes */ + +#include +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#if !defined(_WIN32) || defined(__MINGW32__) +#include +#endif +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif +#ifndef _WIN32 +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include /* is this really required to detect other headers? */ +#endif +#ifdef HAVE_SYS_UN_H +#include /* is this really required to detect other headers? */ +#endif + + +" +if test "x$ac_cv_header_netinet_udp_h" = xyes +then : + printf "%s\n" "#define HAVE_NETINET_UDP_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "netdb.h" "ac_cv_header_netdb_h" "/* default includes */ + +#include +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#if !defined(_WIN32) || defined(__MINGW32__) +#include +#endif +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif +#ifndef _WIN32 +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include /* is this really required to detect other headers? */ +#endif +#ifdef HAVE_SYS_UN_H +#include /* is this really required to detect other headers? */ +#endif + + +" +if test "x$ac_cv_header_netdb_h" = xyes +then : + printf "%s\n" "#define HAVE_NETDB_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "sys/sockio.h" "ac_cv_header_sys_sockio_h" "/* default includes */ + +#include +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#if !defined(_WIN32) || defined(__MINGW32__) +#include +#endif +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif +#ifndef _WIN32 +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include /* is this really required to detect other headers? */ +#endif +#ifdef HAVE_SYS_UN_H +#include /* is this really required to detect other headers? */ +#endif + + +" +if test "x$ac_cv_header_sys_sockio_h" = xyes +then : + printf "%s\n" "#define HAVE_SYS_SOCKIO_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "sys/param.h" "ac_cv_header_sys_param_h" "/* default includes */ + +#include +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#if !defined(_WIN32) || defined(__MINGW32__) +#include +#endif +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif +#ifndef _WIN32 +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include /* is this really required to detect other headers? */ +#endif +#ifdef HAVE_SYS_UN_H +#include /* is this really required to detect other headers? */ +#endif + + +" +if test "x$ac_cv_header_sys_param_h" = xyes +then : + printf "%s\n" "#define HAVE_SYS_PARAM_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "termios.h" "ac_cv_header_termios_h" "/* default includes */ + +#include +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#if !defined(_WIN32) || defined(__MINGW32__) +#include +#endif +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif +#ifndef _WIN32 +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include /* is this really required to detect other headers? */ +#endif +#ifdef HAVE_SYS_UN_H +#include /* is this really required to detect other headers? */ +#endif + + +" +if test "x$ac_cv_header_termios_h" = xyes +then : + printf "%s\n" "#define HAVE_TERMIOS_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "termio.h" "ac_cv_header_termio_h" "/* default includes */ + +#include +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#if !defined(_WIN32) || defined(__MINGW32__) +#include +#endif +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif +#ifndef _WIN32 +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include /* is this really required to detect other headers? */ +#endif +#ifdef HAVE_SYS_UN_H +#include /* is this really required to detect other headers? */ +#endif + + +" +if test "x$ac_cv_header_termio_h" = xyes +then : + printf "%s\n" "#define HAVE_TERMIO_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "fcntl.h" "ac_cv_header_fcntl_h" "/* default includes */ + +#include +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#if !defined(_WIN32) || defined(__MINGW32__) +#include +#endif +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif +#ifndef _WIN32 +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include /* is this really required to detect other headers? */ +#endif +#ifdef HAVE_SYS_UN_H +#include /* is this really required to detect other headers? */ +#endif + + +" +if test "x$ac_cv_header_fcntl_h" = xyes +then : + printf "%s\n" "#define HAVE_FCNTL_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "io.h" "ac_cv_header_io_h" "/* default includes */ + +#include +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#if !defined(_WIN32) || defined(__MINGW32__) +#include +#endif +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif +#ifndef _WIN32 +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include /* is this really required to detect other headers? */ +#endif +#ifdef HAVE_SYS_UN_H +#include /* is this really required to detect other headers? */ +#endif + + +" +if test "x$ac_cv_header_io_h" = xyes +then : + printf "%s\n" "#define HAVE_IO_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "pwd.h" "ac_cv_header_pwd_h" "/* default includes */ + +#include +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#if !defined(_WIN32) || defined(__MINGW32__) +#include +#endif +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif +#ifndef _WIN32 +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include /* is this really required to detect other headers? */ +#endif +#ifdef HAVE_SYS_UN_H +#include /* is this really required to detect other headers? */ +#endif + + +" +if test "x$ac_cv_header_pwd_h" = xyes +then : + printf "%s\n" "#define HAVE_PWD_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "utime.h" "ac_cv_header_utime_h" "/* default includes */ + +#include +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#if !defined(_WIN32) || defined(__MINGW32__) +#include +#endif +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif +#ifndef _WIN32 +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include /* is this really required to detect other headers? */ +#endif +#ifdef HAVE_SYS_UN_H +#include /* is this really required to detect other headers? */ +#endif + + +" +if test "x$ac_cv_header_utime_h" = xyes +then : + printf "%s\n" "#define HAVE_UTIME_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "sys/utime.h" "ac_cv_header_sys_utime_h" "/* default includes */ + +#include +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#if !defined(_WIN32) || defined(__MINGW32__) +#include +#endif +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif +#ifndef _WIN32 +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include /* is this really required to detect other headers? */ +#endif +#ifdef HAVE_SYS_UN_H +#include /* is this really required to detect other headers? */ +#endif + + +" +if test "x$ac_cv_header_sys_utime_h" = xyes +then : + printf "%s\n" "#define HAVE_SYS_UTIME_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "sys/poll.h" "ac_cv_header_sys_poll_h" "/* default includes */ + +#include +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#if !defined(_WIN32) || defined(__MINGW32__) +#include +#endif +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif +#ifndef _WIN32 +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include /* is this really required to detect other headers? */ +#endif +#ifdef HAVE_SYS_UN_H +#include /* is this really required to detect other headers? */ +#endif + + +" +if test "x$ac_cv_header_sys_poll_h" = xyes +then : + printf "%s\n" "#define HAVE_SYS_POLL_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "poll.h" "ac_cv_header_poll_h" "/* default includes */ + +#include +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#if !defined(_WIN32) || defined(__MINGW32__) +#include +#endif +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif +#ifndef _WIN32 +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include /* is this really required to detect other headers? */ +#endif +#ifdef HAVE_SYS_UN_H +#include /* is this really required to detect other headers? */ +#endif + + +" +if test "x$ac_cv_header_poll_h" = xyes +then : + printf "%s\n" "#define HAVE_POLL_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "sys/resource.h" "ac_cv_header_sys_resource_h" "/* default includes */ + +#include +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#if !defined(_WIN32) || defined(__MINGW32__) +#include +#endif +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif +#ifndef _WIN32 +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include /* is this really required to detect other headers? */ +#endif +#ifdef HAVE_SYS_UN_H +#include /* is this really required to detect other headers? */ +#endif + + +" +if test "x$ac_cv_header_sys_resource_h" = xyes +then : + printf "%s\n" "#define HAVE_SYS_RESOURCE_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "libgen.h" "ac_cv_header_libgen_h" "/* default includes */ + +#include +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#if !defined(_WIN32) || defined(__MINGW32__) +#include +#endif +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif +#ifndef _WIN32 +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include /* is this really required to detect other headers? */ +#endif +#ifdef HAVE_SYS_UN_H +#include /* is this really required to detect other headers? */ +#endif + + +" +if test "x$ac_cv_header_libgen_h" = xyes +then : + printf "%s\n" "#define HAVE_LIBGEN_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "locale.h" "ac_cv_header_locale_h" "/* default includes */ + +#include +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#if !defined(_WIN32) || defined(__MINGW32__) +#include +#endif +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif +#ifndef _WIN32 +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include /* is this really required to detect other headers? */ +#endif +#ifdef HAVE_SYS_UN_H +#include /* is this really required to detect other headers? */ +#endif + + +" +if test "x$ac_cv_header_locale_h" = xyes +then : + printf "%s\n" "#define HAVE_LOCALE_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "stdbool.h" "ac_cv_header_stdbool_h" "/* default includes */ + +#include +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#if !defined(_WIN32) || defined(__MINGW32__) +#include +#endif +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif +#ifndef _WIN32 +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include /* is this really required to detect other headers? */ +#endif +#ifdef HAVE_SYS_UN_H +#include /* is this really required to detect other headers? */ +#endif + + +" +if test "x$ac_cv_header_stdbool_h" = xyes +then : + printf "%s\n" "#define HAVE_STDBOOL_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "sys/filio.h" "ac_cv_header_sys_filio_h" "/* default includes */ + +#include +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#if !defined(_WIN32) || defined(__MINGW32__) +#include +#endif +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif +#ifndef _WIN32 +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include /* is this really required to detect other headers? */ +#endif +#ifdef HAVE_SYS_UN_H +#include /* is this really required to detect other headers? */ +#endif + + +" +if test "x$ac_cv_header_sys_filio_h" = xyes +then : + printf "%s\n" "#define HAVE_SYS_FILIO_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "sys/eventfd.h" "ac_cv_header_sys_eventfd_h" "/* default includes */ + +#include +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#if !defined(_WIN32) || defined(__MINGW32__) +#include +#endif +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif +#ifndef _WIN32 +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include /* is this really required to detect other headers? */ +#endif +#ifdef HAVE_SYS_UN_H +#include /* is this really required to detect other headers? */ +#endif + + +" +if test "x$ac_cv_header_sys_eventfd_h" = xyes +then : + printf "%s\n" "#define HAVE_SYS_EVENTFD_H 1" >>confdefs.h + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for an ANSI C-conforming const" >&5 +printf %s "checking for an ANSI C-conforming const... " >&6; } +if test ${ac_cv_c_const+y} +then : + printf %s "(cached) " >&6 +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int main(void) +{ + +#ifndef __cplusplus + /* Ultrix mips cc rejects this sort of thing. */ + typedef int charset[2]; + const charset cs = { 0, 0 }; + /* SunOS 4.1.1 cc rejects this. */ + char const *const *pcpcc; + char **ppc; + /* NEC SVR4.0.2 mips cc rejects this. */ + struct point {int x, y;}; + static struct point const zero = {0,0}; + /* IBM XL C 1.02.0.0 rejects this. + It does not let you subtract one const X* pointer from another in + an arm of an if-expression whose if-part is not a constant + expression */ + const char *g = "string"; + pcpcc = &g + (g ? g-g : 0); + /* HPUX 7.0 cc rejects these. */ + ++pcpcc; + ppc = (char**) pcpcc; + pcpcc = (char const *const *) ppc; + { /* SCO 3.2v4 cc rejects this sort of thing. */ + char tx; + char *t = &tx; + char const *s = 0 ? (char *) 0 : (char const *) 0; + + *t++ = 0; + if (s) return 0; + } + { /* Someone thinks the Sun supposedly-ANSI compiler will reject this. */ + int x[] = {25, 17}; + const int *foo = &x[0]; + ++foo; + } + { /* Sun SC1.0 ANSI compiler rejects this -- but not the above. */ + typedef const int *iptr; + iptr p = 0; + ++p; + } + { /* IBM XL C 1.02.0.0 rejects this sort of thing, saying + "k.c", line 2.27: 1506-025 (S) Operand must be a modifiable lvalue. */ + struct s { int j; const int *ap[3]; } bx; + struct s *b = &bx; b->j = 5; + } + { /* ULTRIX-32 V3.1 (Rev 9) vcc rejects this */ + const int foo = 10; + if (!foo) return 0; + } + return !cs[0] && !zero.x; +#endif + + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + ac_cv_c_const=yes +else $as_nop + ac_cv_c_const=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_const" >&5 +printf "%s\n" "$ac_cv_c_const" >&6; } +if test $ac_cv_c_const = no; then + +printf "%s\n" "#define const /**/" >>confdefs.h + +fi + +ac_fn_c_check_type "$LINENO" "size_t" "ac_cv_type_size_t" "$ac_includes_default" +if test "x$ac_cv_type_size_t" = xyes +then : + +else $as_nop + +printf "%s\n" "#define size_t unsigned int" >>confdefs.h + +fi + + + + + ac_fn_c_check_header_compile "$LINENO" "sys/types.h" "ac_cv_header_sys_types_h" "$ac_includes_default" +if test "x$ac_cv_header_sys_types_h" = xyes +then : + printf "%s\n" "#define HAVE_SYS_TYPES_H 1" >>confdefs.h + +fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for struct timeval" >&5 +printf %s "checking for struct timeval... " >&6; } +if test ${curl_cv_struct_timeval+y} +then : + printf %s "(cached) " >&6 +else $as_nop + + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #undef inline + #ifdef _WIN32 + #ifndef WIN32_LEAN_AND_MEAN + #define WIN32_LEAN_AND_MEAN + #endif + #include + #else + #include + #include + #endif + #ifdef HAVE_SYS_TYPES_H + #include + #endif + #include + +int main(void) +{ + + struct timeval ts; + ts.tv_sec = 0; + ts.tv_usec = 0; + (void)ts; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + curl_cv_struct_timeval="yes" + +else $as_nop + + curl_cv_struct_timeval="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $curl_cv_struct_timeval" >&5 +printf "%s\n" "$curl_cv_struct_timeval" >&6; } + case "$curl_cv_struct_timeval" in + yes) + +printf "%s\n" "#define HAVE_STRUCT_TIMEVAL 1" >>confdefs.h + + ;; + esac + + + + if test "$cross_compiling" != "yes"; then + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking runtime libs availability" >&5 +printf %s "checking runtime libs availability... " >&6; } + + if test "$curl_cv_apple" = "yes"; then + if test "$cross_compiling" = yes +then : + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + int main(void) + { + return 0; + } + +_ACEOF +if ac_fn_c_try_run "$LINENO" +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: fine" >&5 +printf "%s\n" "fine" >&6; } +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: failed" >&5 +printf "%s\n" "failed" >&6; } + as_fn_error $? "one or more libs available at link-time are not available runtime. Libs used at link-time: $LIBS" "$LINENO" 5 + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + else + oldcc=$CC + old=$LD_LIBRARY_PATH + CC="sh ./run-compiler" + LD_LIBRARY_PATH=$CURL_LIBRARY_PATH:$old + export LD_LIBRARY_PATH + if test "$cross_compiling" = yes +then : + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + int main(void) + { + return 0; + } + +_ACEOF +if ac_fn_c_try_run "$LINENO" +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: fine" >&5 +printf "%s\n" "fine" >&6; } +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: failed" >&5 +printf "%s\n" "failed" >&6; } + as_fn_error $? "one or more libs available at link-time are not available runtime. Libs used at link-time: $LIBS" "$LINENO" 5 + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + # restore + LD_LIBRARY_PATH=$old + CC=$oldcc + fi + + + fi + + + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking size of size_t" >&5 +printf %s "checking size of size_t... " >&6; } + r=0 + for typesize in 8 4 2 16 1; do + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #include + + +int main(void) +{ + + switch(0) { + case 0: + case (sizeof(size_t) == $typesize):; + } + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + r=$typesize + +else $as_nop + + r=0 + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + if test "$r" -gt 0; then + break; + fi + done + if test "$r" -eq 0; then + as_fn_error $? "Failed to find size of size_t" "$LINENO" 5 + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $r" >&5 +printf "%s\n" "$r" >&6; } + tname=`echo "ac_cv_sizeof_size_t" | tr A-Z a-z | tr " " "_"` + eval "$tname=$r" + + +printf "%s\n" "#define SIZEOF_SIZE_T $r" >>confdefs.h + + + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking size of long" >&5 +printf %s "checking size of long... " >&6; } + r=0 + for typesize in 8 4 2 16 1; do + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #include + + +int main(void) +{ + + switch(0) { + case 0: + case (sizeof(long) == $typesize):; + } + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + r=$typesize + +else $as_nop + + r=0 + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + if test "$r" -gt 0; then + break; + fi + done + if test "$r" -eq 0; then + as_fn_error $? "Failed to find size of long" "$LINENO" 5 + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $r" >&5 +printf "%s\n" "$r" >&6; } + tname=`echo "ac_cv_sizeof_long" | tr A-Z a-z | tr " " "_"` + eval "$tname=$r" + + +printf "%s\n" "#define SIZEOF_LONG $r" >>confdefs.h + + + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking size of int" >&5 +printf %s "checking size of int... " >&6; } + r=0 + for typesize in 8 4 2 16 1; do + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #include + + +int main(void) +{ + + switch(0) { + case 0: + case (sizeof(int) == $typesize):; + } + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + r=$typesize + +else $as_nop + + r=0 + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + if test "$r" -gt 0; then + break; + fi + done + if test "$r" -eq 0; then + as_fn_error $? "Failed to find size of int" "$LINENO" 5 + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $r" >&5 +printf "%s\n" "$r" >&6; } + tname=`echo "ac_cv_sizeof_int" | tr A-Z a-z | tr " " "_"` + eval "$tname=$r" + + +printf "%s\n" "#define SIZEOF_INT $r" >>confdefs.h + + + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking size of time_t" >&5 +printf %s "checking size of time_t... " >&6; } + r=0 + for typesize in 8 4 2 16 1; do + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #include + + +int main(void) +{ + + switch(0) { + case 0: + case (sizeof(time_t) == $typesize):; + } + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + r=$typesize + +else $as_nop + + r=0 + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + if test "$r" -gt 0; then + break; + fi + done + if test "$r" -eq 0; then + as_fn_error $? "Failed to find size of time_t" "$LINENO" 5 + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $r" >&5 +printf "%s\n" "$r" >&6; } + tname=`echo "ac_cv_sizeof_time_t" | tr A-Z a-z | tr " " "_"` + eval "$tname=$r" + + +printf "%s\n" "#define SIZEOF_TIME_T $r" >>confdefs.h + + + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking size of off_t" >&5 +printf %s "checking size of off_t... " >&6; } + r=0 + for typesize in 8 4 2 16 1; do + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #include + + +int main(void) +{ + + switch(0) { + case 0: + case (sizeof(off_t) == $typesize):; + } + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + r=$typesize + +else $as_nop + + r=0 + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + if test "$r" -gt 0; then + break; + fi + done + if test "$r" -eq 0; then + as_fn_error $? "Failed to find size of off_t" "$LINENO" 5 + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $r" >&5 +printf "%s\n" "$r" >&6; } + tname=`echo "ac_cv_sizeof_off_t" | tr A-Z a-z | tr " " "_"` + eval "$tname=$r" + + +printf "%s\n" "#define SIZEOF_OFF_T $r" >>confdefs.h + + + +o=$CPPFLAGS +CPPFLAGS="-I$srcdir/include $CPPFLAGS" + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking size of curl_off_t" >&5 +printf %s "checking size of curl_off_t... " >&6; } + r=0 + for typesize in 8 4 2 16 1; do + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #include + +#include + + +int main(void) +{ + + switch(0) { + case 0: + case (sizeof(curl_off_t) == $typesize):; + } + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + r=$typesize + +else $as_nop + + r=0 + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + if test "$r" -gt 0; then + break; + fi + done + if test "$r" -eq 0; then + as_fn_error $? "Failed to find size of curl_off_t" "$LINENO" 5 + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $r" >&5 +printf "%s\n" "$r" >&6; } + tname=`echo "ac_cv_sizeof_curl_off_t" | tr A-Z a-z | tr " " "_"` + eval "$tname=$r" + + +printf "%s\n" "#define SIZEOF_CURL_OFF_T $r" >>confdefs.h + + + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking size of curl_socket_t" >&5 +printf %s "checking size of curl_socket_t... " >&6; } + r=0 + for typesize in 8 4 2 16 1; do + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #include + +#include + + +int main(void) +{ + + switch(0) { + case 0: + case (sizeof(curl_socket_t) == $typesize):; + } + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + r=$typesize + +else $as_nop + + r=0 + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + if test "$r" -gt 0; then + break; + fi + done + if test "$r" -eq 0; then + as_fn_error $? "Failed to find size of curl_socket_t" "$LINENO" 5 + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $r" >&5 +printf "%s\n" "$r" >&6; } + tname=`echo "ac_cv_sizeof_curl_socket_t" | tr A-Z a-z | tr " " "_"` + eval "$tname=$r" + + +printf "%s\n" "#define SIZEOF_CURL_SOCKET_T $r" >>confdefs.h + + +CPPFLAGS=$o + +if test "$ac_cv_sizeof_curl_off_t" -lt 8; then + as_fn_error $? "64-bit curl_off_t is required" "$LINENO" 5 +fi + +ac_fn_c_check_type "$LINENO" "ssize_t" "ac_cv_type_ssize_t" "$ac_includes_default" +if test "x$ac_cv_type_ssize_t" = xyes +then : + +else $as_nop + +printf "%s\n" "#define ssize_t int" >>confdefs.h + +fi + + +ac_fn_c_check_type "$LINENO" "bool" "ac_cv_type_bool" " +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#ifdef HAVE_STDBOOL_H +#include +#endif + +" +if test "x$ac_cv_type_bool" = xyes +then : + + +printf "%s\n" "#define HAVE_BOOL_T 1" >>confdefs.h + + +fi + + +if test "$curl_cv_native_windows" != "yes"; then + ac_fn_c_check_type "$LINENO" "sa_family_t" "ac_cv_type_sa_family_t" " + #include + +" +if test "x$ac_cv_type_sa_family_t" = xyes +then : + +printf "%s\n" "#define HAVE_SA_FAMILY_T 1" >>confdefs.h + +fi + +fi + +ac_fn_c_check_type "$LINENO" "suseconds_t" "ac_cv_type_suseconds_t" " +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#ifndef _WIN32 +#include +#endif + +" +if test "x$ac_cv_type_suseconds_t" = xyes +then : + + +printf "%s\n" "#define HAVE_SUSECONDS_T 1" >>confdefs.h + + +fi + + +case $host_os in + amigaos*|msdos*) + +printf "%s\n" "#define HAVE_TIME_T_UNSIGNED 1" >>confdefs.h + + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if time_t is unsigned" >&5 +printf %s "checking if time_t is unsigned... " >&6; } + + if test "$curl_cv_apple" = "yes"; then + if test "$cross_compiling" = yes +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #include + int main(void) { + time_t t = -1; + return t < 0; + } + +_ACEOF +if ac_fn_c_try_run "$LINENO" +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_TIME_T_UNSIGNED 1" >>confdefs.h + + +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + else + oldcc=$CC + old=$LD_LIBRARY_PATH + CC="sh ./run-compiler" + LD_LIBRARY_PATH=$CURL_LIBRARY_PATH:$old + export LD_LIBRARY_PATH + if test "$cross_compiling" = yes +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #include + int main(void) { + time_t t = -1; + return t < 0; + } + +_ACEOF +if ac_fn_c_try_run "$LINENO" +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_TIME_T_UNSIGNED 1" >>confdefs.h + + +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + # restore + LD_LIBRARY_PATH=$old + CC=$oldcc + fi + + ;; +esac + + + ac_fn_c_check_type "$LINENO" "struct sockaddr_storage" "ac_cv_type_struct_sockaddr_storage" " + #undef inline + #ifdef _WIN32 + #ifndef WIN32_LEAN_AND_MEAN + #define WIN32_LEAN_AND_MEAN + #endif + #include + #else + #ifdef HAVE_SYS_TYPES_H + #include + #endif + #include + #ifdef HAVE_NETINET_IN_H + #include + #endif + #ifdef HAVE_ARPA_INET_H + #include + #endif + #endif + +" +if test "x$ac_cv_type_struct_sockaddr_storage" = xyes +then : + +printf "%s\n" "#define HAVE_STRUCT_SOCKADDR_STORAGE 1" >>confdefs.h + +fi + + + + + + + ac_fn_c_check_header_compile "$LINENO" "sys/select.h" "ac_cv_header_sys_select_h" "$ac_includes_default" +if test "x$ac_cv_header_sys_select_h" = xyes +then : + printf "%s\n" "#define HAVE_SYS_SELECT_H 1" >>confdefs.h + +fi + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for select" >&5 +printf %s "checking for select... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #undef inline + #ifdef _WIN32 + #ifndef WIN32_LEAN_AND_MEAN + #define WIN32_LEAN_AND_MEAN + #endif + #include + #else + #include + #include + #endif + #ifdef HAVE_SYS_TYPES_H + #include + #endif + #include + #ifndef _WIN32 + #ifdef HAVE_SYS_SELECT_H + #include + #elif defined(HAVE_UNISTD_H) + #include + #endif + $curl_includes_bsdsocket + #endif + +int main(void) +{ + + select(0, 0, 0, 0, 0); + + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + curl_cv_select="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_select="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$curl_cv_select" = "yes"; then + +printf "%s\n" "#define HAVE_SELECT 1" >>confdefs.h + + curl_cv_func_select="yes" + fi + + + + + + ac_fn_c_check_header_compile "$LINENO" "sys/types.h" "ac_cv_header_sys_types_h" "$ac_includes_default" +if test "x$ac_cv_header_sys_types_h" = xyes +then : + printf "%s\n" "#define HAVE_SYS_TYPES_H 1" >>confdefs.h + +fi + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for recv" >&5 +printf %s "checking for recv... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #undef inline + #ifdef _WIN32 + #ifndef WIN32_LEAN_AND_MEAN + #define WIN32_LEAN_AND_MEAN + #endif + #include + #else + $curl_includes_bsdsocket + #ifdef HAVE_SYS_TYPES_H + #include + #endif + #include + #endif + +int main(void) +{ + + recv(0, 0, 0, 0); + + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + curl_cv_recv="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_recv="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$curl_cv_recv" = "yes"; then + +printf "%s\n" "#define HAVE_RECV 1" >>confdefs.h + + curl_cv_func_recv="yes" + else + as_fn_error $? "Unable to link function recv" "$LINENO" 5 + fi + + + + + ac_fn_c_check_header_compile "$LINENO" "sys/types.h" "ac_cv_header_sys_types_h" "$ac_includes_default" +if test "x$ac_cv_header_sys_types_h" = xyes +then : + printf "%s\n" "#define HAVE_SYS_TYPES_H 1" >>confdefs.h + +fi + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for send" >&5 +printf %s "checking for send... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #undef inline + #ifdef _WIN32 + #ifndef WIN32_LEAN_AND_MEAN + #define WIN32_LEAN_AND_MEAN + #endif + #include + #else + $curl_includes_bsdsocket + #ifdef HAVE_SYS_TYPES_H + #include + #endif + #include + #endif + +int main(void) +{ + + char s[] = ""; + send(0, (void *)s, 0, 0); + + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + curl_cv_send="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_send="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$curl_cv_send" = "yes"; then + +printf "%s\n" "#define HAVE_SEND 1" >>confdefs.h + + curl_cv_func_send="yes" + else + as_fn_error $? "Unable to link function send" "$LINENO" 5 + fi + + + +curl_includes_unistd="\ +/* includes start */ +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifdef HAVE_UNISTD_H +# include +#endif +/* includes end */" + ac_fn_c_check_header_compile "$LINENO" "sys/types.h" "ac_cv_header_sys_types_h" "$curl_includes_unistd +" +if test "x$ac_cv_header_sys_types_h" = xyes +then : + printf "%s\n" "#define HAVE_SYS_TYPES_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "unistd.h" "ac_cv_header_unistd_h" "$curl_includes_unistd +" +if test "x$ac_cv_header_unistd_h" = xyes +then : + printf "%s\n" "#define HAVE_UNISTD_H 1" >>confdefs.h + +fi + + + + + + tst_links_alarm="unknown" + tst_proto_alarm="unknown" + tst_compi_alarm="unknown" + tst_allow_alarm="unknown" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if alarm can be linked" >&5 +printf %s "checking if alarm can be linked... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#define alarm innocuous_alarm +#ifdef __STDC__ +# include +#else +# include +#endif +#undef alarm +#ifdef __cplusplus +extern "C" +#endif +char alarm (); +#if defined __stub_alarm || defined __stub___alarm +#error force compilation error +#endif + +int main(void) +{ +return alarm (); + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_links_alarm="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_links_alarm="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$tst_links_alarm" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if alarm is prototyped" >&5 +printf %s "checking if alarm is prototyped... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + $curl_includes_unistd + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "alarm" >/dev/null 2>&1 +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_proto_alarm="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_proto_alarm="no" + +fi +rm -rf conftest* + + fi + + if test "$tst_proto_alarm" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if alarm is compilable" >&5 +printf %s "checking if alarm is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_unistd + +int main(void) +{ + + if(alarm(0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_alarm="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_alarm="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$tst_compi_alarm" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if alarm usage allowed" >&5 +printf %s "checking if alarm usage allowed... " >&6; } + if test "x$curl_disallow_alarm" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_alarm="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_alarm="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if alarm might be used" >&5 +printf %s "checking if alarm might be used... " >&6; } + if test "$tst_links_alarm" = "yes" && + test "$tst_proto_alarm" = "yes" && + test "$tst_compi_alarm" = "yes" && + test "$tst_allow_alarm" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_ALARM 1" >>confdefs.h + + curl_cv_func_alarm="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_alarm="no" + fi + + +curl_includes_string="\ +/* includes start */ +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#include +#ifdef HAVE_STRINGS_H +# include +#endif +/* includes end */" + ac_fn_c_check_header_compile "$LINENO" "sys/types.h" "ac_cv_header_sys_types_h" "$curl_includes_string +" +if test "x$ac_cv_header_sys_types_h" = xyes +then : + printf "%s\n" "#define HAVE_SYS_TYPES_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "strings.h" "ac_cv_header_strings_h" "$curl_includes_string +" +if test "x$ac_cv_header_strings_h" = xyes +then : + printf "%s\n" "#define HAVE_STRINGS_H 1" >>confdefs.h + +fi + + + +curl_includes_libgen="\ +/* includes start */ +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifdef HAVE_LIBGEN_H +# include +#endif +/* includes end */" + ac_fn_c_check_header_compile "$LINENO" "sys/types.h" "ac_cv_header_sys_types_h" "$curl_includes_libgen +" +if test "x$ac_cv_header_sys_types_h" = xyes +then : + printf "%s\n" "#define HAVE_SYS_TYPES_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "libgen.h" "ac_cv_header_libgen_h" "$curl_includes_libgen +" +if test "x$ac_cv_header_libgen_h" = xyes +then : + printf "%s\n" "#define HAVE_LIBGEN_H 1" >>confdefs.h + +fi + + + + + + + + tst_links_basename="unknown" + tst_proto_basename="unknown" + tst_compi_basename="unknown" + tst_allow_basename="unknown" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if basename can be linked" >&5 +printf %s "checking if basename can be linked... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#define basename innocuous_basename +#ifdef __STDC__ +# include +#else +# include +#endif +#undef basename +#ifdef __cplusplus +extern "C" +#endif +char basename (); +#if defined __stub_basename || defined __stub___basename +#error force compilation error +#endif + +int main(void) +{ +return basename (); + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_links_basename="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_links_basename="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$tst_links_basename" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if basename is prototyped" >&5 +printf %s "checking if basename is prototyped... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + $curl_includes_string + $curl_includes_libgen + $curl_includes_unistd + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "basename" >/dev/null 2>&1 +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_proto_basename="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_proto_basename="no" + +fi +rm -rf conftest* + + fi + + if test "$tst_proto_basename" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if basename is compilable" >&5 +printf %s "checking if basename is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_string + $curl_includes_libgen + $curl_includes_unistd + +int main(void) +{ + + if(basename(0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_basename="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_basename="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$tst_compi_basename" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if basename usage allowed" >&5 +printf %s "checking if basename usage allowed... " >&6; } + if test "x$curl_disallow_basename" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_basename="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_basename="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if basename might be used" >&5 +printf %s "checking if basename might be used... " >&6; } + if test "$tst_links_basename" = "yes" && + test "$tst_proto_basename" = "yes" && + test "$tst_compi_basename" = "yes" && + test "$tst_allow_basename" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_BASENAME 1" >>confdefs.h + + curl_cv_func_basename="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_basename="no" + fi + + + + + tst_links_closesocket="unknown" + tst_proto_closesocket="unknown" + tst_compi_closesocket="unknown" + tst_allow_closesocket="unknown" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if closesocket can be linked" >&5 +printf %s "checking if closesocket can be linked... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_winsock2 + +int main(void) +{ + + if(closesocket(0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_links_closesocket="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_links_closesocket="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$tst_links_closesocket" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if closesocket is prototyped" >&5 +printf %s "checking if closesocket is prototyped... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + $curl_includes_winsock2 + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "closesocket" >/dev/null 2>&1 +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_proto_closesocket="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_proto_closesocket="no" + +fi +rm -rf conftest* + + fi + + if test "$tst_proto_closesocket" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if closesocket is compilable" >&5 +printf %s "checking if closesocket is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_winsock2 + +int main(void) +{ + + if(closesocket(0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_closesocket="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_closesocket="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$tst_compi_closesocket" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if closesocket usage allowed" >&5 +printf %s "checking if closesocket usage allowed... " >&6; } + if test "x$curl_disallow_closesocket" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_closesocket="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_closesocket="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if closesocket might be used" >&5 +printf %s "checking if closesocket might be used... " >&6; } + if test "$tst_links_closesocket" = "yes" && + test "$tst_proto_closesocket" = "yes" && + test "$tst_compi_closesocket" = "yes" && + test "$tst_allow_closesocket" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_CLOSESOCKET 1" >>confdefs.h + + curl_cv_func_closesocket="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_closesocket="no" + fi + + +curl_includes_sys_socket="\ +/* includes start */ +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifndef _WIN32 +# include +#endif +/* includes end */" + ac_fn_c_check_header_compile "$LINENO" "sys/types.h" "ac_cv_header_sys_types_h" "$curl_includes_sys_socket +" +if test "x$ac_cv_header_sys_types_h" = xyes +then : + printf "%s\n" "#define HAVE_SYS_TYPES_H 1" >>confdefs.h + +fi + + + + + + + tst_links_closesocket_camel="unknown" + tst_compi_closesocket_camel="unknown" + tst_allow_closesocket_camel="unknown" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if CloseSocket can be linked" >&5 +printf %s "checking if CloseSocket can be linked... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_bsdsocket + $curl_includes_sys_socket + +int main(void) +{ + + if(CloseSocket(0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_links_closesocket_camel="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_links_closesocket_camel="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$tst_links_closesocket_camel" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if CloseSocket is compilable" >&5 +printf %s "checking if CloseSocket is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_bsdsocket + $curl_includes_sys_socket + +int main(void) +{ + + if(CloseSocket(0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_closesocket_camel="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_closesocket_camel="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$tst_compi_closesocket_camel" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if CloseSocket usage allowed" >&5 +printf %s "checking if CloseSocket usage allowed... " >&6; } + if test "x$curl_disallow_closesocket_camel" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_closesocket_camel="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_closesocket_camel="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if CloseSocket might be used" >&5 +printf %s "checking if CloseSocket might be used... " >&6; } + if test "$tst_links_closesocket_camel" = "yes" && + test "$tst_compi_closesocket_camel" = "yes" && + test "$tst_allow_closesocket_camel" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_CLOSESOCKET_CAMEL 1" >>confdefs.h + + curl_cv_func_closesocket_camel="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_closesocket_camel="no" + fi + + +curl_includes_fcntl="\ +/* includes start */ +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifdef HAVE_UNISTD_H +# include +#endif +#ifdef HAVE_FCNTL_H +# include +#endif +/* includes end */" + ac_fn_c_check_header_compile "$LINENO" "sys/types.h" "ac_cv_header_sys_types_h" "$curl_includes_fcntl +" +if test "x$ac_cv_header_sys_types_h" = xyes +then : + printf "%s\n" "#define HAVE_SYS_TYPES_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "unistd.h" "ac_cv_header_unistd_h" "$curl_includes_fcntl +" +if test "x$ac_cv_header_unistd_h" = xyes +then : + printf "%s\n" "#define HAVE_UNISTD_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "fcntl.h" "ac_cv_header_fcntl_h" "$curl_includes_fcntl +" +if test "x$ac_cv_header_fcntl_h" = xyes +then : + printf "%s\n" "#define HAVE_FCNTL_H 1" >>confdefs.h + +fi + + + + + + tst_links_fcntl="unknown" + tst_proto_fcntl="unknown" + tst_compi_fcntl="unknown" + tst_allow_fcntl="unknown" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if fcntl can be linked" >&5 +printf %s "checking if fcntl can be linked... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#define fcntl innocuous_fcntl +#ifdef __STDC__ +# include +#else +# include +#endif +#undef fcntl +#ifdef __cplusplus +extern "C" +#endif +char fcntl (); +#if defined __stub_fcntl || defined __stub___fcntl +#error force compilation error +#endif + +int main(void) +{ +return fcntl (); + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_links_fcntl="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_links_fcntl="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$tst_links_fcntl" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if fcntl is prototyped" >&5 +printf %s "checking if fcntl is prototyped... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + $curl_includes_fcntl + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "fcntl" >/dev/null 2>&1 +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_proto_fcntl="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_proto_fcntl="no" + +fi +rm -rf conftest* + + fi + + if test "$tst_proto_fcntl" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if fcntl is compilable" >&5 +printf %s "checking if fcntl is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_fcntl + +int main(void) +{ + + if(fcntl(0, 0, 0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_fcntl="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_fcntl="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$tst_compi_fcntl" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if fcntl usage allowed" >&5 +printf %s "checking if fcntl usage allowed... " >&6; } + if test "x$curl_disallow_fcntl" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_fcntl="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_fcntl="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if fcntl might be used" >&5 +printf %s "checking if fcntl might be used... " >&6; } + if test "$tst_links_fcntl" = "yes" && + test "$tst_proto_fcntl" = "yes" && + test "$tst_compi_fcntl" = "yes" && + test "$tst_allow_fcntl" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_FCNTL 1" >>confdefs.h + + curl_cv_func_fcntl="yes" + + + tst_compi_fcntl_o_nonblock="unknown" + tst_allow_fcntl_o_nonblock="unknown" + + case $host_os in + sunos4* | aix3*) + curl_disallow_fcntl_o_nonblock="yes" + ;; + esac + + if test "$curl_cv_func_fcntl" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if fcntl O_NONBLOCK is compilable" >&5 +printf %s "checking if fcntl O_NONBLOCK is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_fcntl + +int main(void) +{ + + int flags = 0; + if(fcntl(0, F_SETFL, flags | O_NONBLOCK)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_fcntl_o_nonblock="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_fcntl_o_nonblock="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$tst_compi_fcntl_o_nonblock" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if fcntl O_NONBLOCK usage allowed" >&5 +printf %s "checking if fcntl O_NONBLOCK usage allowed... " >&6; } + if test "x$curl_disallow_fcntl_o_nonblock" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_fcntl_o_nonblock="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_fcntl_o_nonblock="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if fcntl O_NONBLOCK might be used" >&5 +printf %s "checking if fcntl O_NONBLOCK might be used... " >&6; } + if test "$tst_compi_fcntl_o_nonblock" = "yes" && + test "$tst_allow_fcntl_o_nonblock" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_FCNTL_O_NONBLOCK 1" >>confdefs.h + + curl_cv_func_fcntl_o_nonblock="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_fcntl_o_nonblock="no" + fi + + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_fcntl="no" + fi + + +curl_includes_ws2tcpip="\ +/* includes start */ +#ifdef _WIN32 +# ifndef WIN32_LEAN_AND_MEAN +# define WIN32_LEAN_AND_MEAN +# endif +# include +# include +#endif +/* includes end */" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether build target is a native Windows one" >&5 +printf %s "checking whether build target is a native Windows one... " >&6; } +if test ${curl_cv_native_windows+y} +then : + printf %s "(cached) " >&6 +else $as_nop + + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + +int main(void) +{ + + #ifdef _WIN32 + int dummy = 1; + (void)dummy; + #else + #error Not a native Windows build target. + #endif + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + curl_cv_native_windows="yes" + +else $as_nop + + curl_cv_native_windows="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $curl_cv_native_windows" >&5 +printf "%s\n" "$curl_cv_native_windows" >&6; } + if test "$curl_cv_native_windows" = "yes"; then + DOING_NATIVE_WINDOWS_TRUE= + DOING_NATIVE_WINDOWS_FALSE='#' +else + DOING_NATIVE_WINDOWS_TRUE='#' + DOING_NATIVE_WINDOWS_FALSE= +fi + + + + +curl_includes_netdb="\ +/* includes start */ +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifdef HAVE_NETDB_H +# include +#endif +/* includes end */" + ac_fn_c_check_header_compile "$LINENO" "sys/types.h" "ac_cv_header_sys_types_h" "$curl_includes_netdb +" +if test "x$ac_cv_header_sys_types_h" = xyes +then : + printf "%s\n" "#define HAVE_SYS_TYPES_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "netdb.h" "ac_cv_header_netdb_h" "$curl_includes_netdb +" +if test "x$ac_cv_header_netdb_h" = xyes +then : + printf "%s\n" "#define HAVE_NETDB_H 1" >>confdefs.h + +fi + + + + + + + + tst_links_freeaddrinfo="unknown" + tst_proto_freeaddrinfo="unknown" + tst_compi_freeaddrinfo="unknown" + tst_allow_freeaddrinfo="unknown" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if freeaddrinfo can be linked" >&5 +printf %s "checking if freeaddrinfo can be linked... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_ws2tcpip + $curl_includes_sys_socket + $curl_includes_netdb + +int main(void) +{ + + freeaddrinfo(0); + + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_links_freeaddrinfo="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_links_freeaddrinfo="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$tst_links_freeaddrinfo" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if freeaddrinfo is prototyped" >&5 +printf %s "checking if freeaddrinfo is prototyped... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + $curl_includes_ws2tcpip + $curl_includes_sys_socket + $curl_includes_netdb + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "freeaddrinfo" >/dev/null 2>&1 +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_proto_freeaddrinfo="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_proto_freeaddrinfo="no" + +fi +rm -rf conftest* + + fi + + if test "$tst_proto_freeaddrinfo" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if freeaddrinfo is compilable" >&5 +printf %s "checking if freeaddrinfo is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_ws2tcpip + $curl_includes_sys_socket + $curl_includes_netdb + +int main(void) +{ + + freeaddrinfo(0); + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_freeaddrinfo="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_freeaddrinfo="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$tst_compi_freeaddrinfo" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if freeaddrinfo usage allowed" >&5 +printf %s "checking if freeaddrinfo usage allowed... " >&6; } + if test "x$curl_disallow_freeaddrinfo" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_freeaddrinfo="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_freeaddrinfo="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if freeaddrinfo might be used" >&5 +printf %s "checking if freeaddrinfo might be used... " >&6; } + if test "$tst_links_freeaddrinfo" = "yes" && + test "$tst_proto_freeaddrinfo" = "yes" && + test "$tst_compi_freeaddrinfo" = "yes" && + test "$tst_allow_freeaddrinfo" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_FREEADDRINFO 1" >>confdefs.h + + curl_cv_func_freeaddrinfo="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_freeaddrinfo="no" + fi + + +curl_includes_sys_xattr="\ +/* includes start */ +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifdef HAVE_SYS_XATTR_H +# include +#endif +/* includes end */" + ac_fn_c_check_header_compile "$LINENO" "sys/types.h" "ac_cv_header_sys_types_h" "$curl_includes_sys_xattr +" +if test "x$ac_cv_header_sys_types_h" = xyes +then : + printf "%s\n" "#define HAVE_SYS_TYPES_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "sys/xattr.h" "ac_cv_header_sys_xattr_h" "$curl_includes_sys_xattr +" +if test "x$ac_cv_header_sys_xattr_h" = xyes +then : + printf "%s\n" "#define HAVE_SYS_XATTR_H 1" >>confdefs.h + +fi + + + + + + tst_links_fsetxattr="unknown" + tst_proto_fsetxattr="unknown" + tst_compi_fsetxattr="unknown" + tst_allow_fsetxattr="unknown" + tst_nargs_fsetxattr="unknown" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if fsetxattr can be linked" >&5 +printf %s "checking if fsetxattr can be linked... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#define fsetxattr innocuous_fsetxattr +#ifdef __STDC__ +# include +#else +# include +#endif +#undef fsetxattr +#ifdef __cplusplus +extern "C" +#endif +char fsetxattr (); +#if defined __stub_fsetxattr || defined __stub___fsetxattr +#error force compilation error +#endif + +int main(void) +{ +return fsetxattr (); + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_links_fsetxattr="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_links_fsetxattr="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$tst_links_fsetxattr" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if fsetxattr is prototyped" >&5 +printf %s "checking if fsetxattr is prototyped... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + $curl_includes_sys_xattr + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "fsetxattr" >/dev/null 2>&1 +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_proto_fsetxattr="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_proto_fsetxattr="no" + +fi +rm -rf conftest* + + fi + + if test "$tst_proto_fsetxattr" = "yes"; then + if test "$tst_nargs_fsetxattr" = "unknown"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if fsetxattr takes 5 args." >&5 +printf %s "checking if fsetxattr takes 5 args.... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_sys_xattr + +int main(void) +{ + + if(fsetxattr(0, "", 0, 0, 0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_fsetxattr="yes" + tst_nargs_fsetxattr="5" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_fsetxattr="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + if test "$tst_nargs_fsetxattr" = "unknown"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if fsetxattr takes 6 args." >&5 +printf %s "checking if fsetxattr takes 6 args.... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_sys_xattr + +int main(void) +{ + + if(fsetxattr(0, 0, 0, 0, 0, 0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_fsetxattr="yes" + tst_nargs_fsetxattr="6" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_fsetxattr="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if fsetxattr is compilable" >&5 +printf %s "checking if fsetxattr is compilable... " >&6; } + if test "$tst_compi_fsetxattr" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + fi + fi + + if test "$tst_compi_fsetxattr" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if fsetxattr usage allowed" >&5 +printf %s "checking if fsetxattr usage allowed... " >&6; } + if test "x$curl_disallow_fsetxattr" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_fsetxattr="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_fsetxattr="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if fsetxattr might be used" >&5 +printf %s "checking if fsetxattr might be used... " >&6; } + if test "$tst_links_fsetxattr" = "yes" && + test "$tst_proto_fsetxattr" = "yes" && + test "$tst_compi_fsetxattr" = "yes" && + test "$tst_allow_fsetxattr" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_FSETXATTR 1" >>confdefs.h + + + if test "$tst_nargs_fsetxattr" -eq "5"; then + +printf "%s\n" "#define HAVE_FSETXATTR_5 1" >>confdefs.h + + elif test "$tst_nargs_fsetxattr" -eq "6"; then + +printf "%s\n" "#define HAVE_FSETXATTR_6 1" >>confdefs.h + + fi + + curl_cv_func_fsetxattr="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_fsetxattr="no" + fi + + +curl_includes_stdlib="\ +/* includes start */ +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#include +/* includes end */" + ac_fn_c_check_header_compile "$LINENO" "sys/types.h" "ac_cv_header_sys_types_h" "$curl_includes_stdlib +" +if test "x$ac_cv_header_sys_types_h" = xyes +then : + printf "%s\n" "#define HAVE_SYS_TYPES_H 1" >>confdefs.h + +fi + + + + + + + + + + + tst_links_getaddrinfo="unknown" + tst_proto_getaddrinfo="unknown" + tst_compi_getaddrinfo="unknown" + tst_works_getaddrinfo="unknown" + tst_allow_getaddrinfo="unknown" + tst_tsafe_getaddrinfo="unknown" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if getaddrinfo can be linked" >&5 +printf %s "checking if getaddrinfo can be linked... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_ws2tcpip + $curl_includes_sys_socket + $curl_includes_netdb + +int main(void) +{ + + struct addrinfo *ai = 0; + if(getaddrinfo(0, 0, 0, &ai)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_links_getaddrinfo="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_links_getaddrinfo="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$tst_links_getaddrinfo" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if getaddrinfo is prototyped" >&5 +printf %s "checking if getaddrinfo is prototyped... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + $curl_includes_ws2tcpip + $curl_includes_sys_socket + $curl_includes_netdb + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "getaddrinfo" >/dev/null 2>&1 +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_proto_getaddrinfo="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_proto_getaddrinfo="no" + +fi +rm -rf conftest* + + fi + + if test "$tst_proto_getaddrinfo" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if getaddrinfo is compilable" >&5 +printf %s "checking if getaddrinfo is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_ws2tcpip + $curl_includes_sys_socket + $curl_includes_netdb + +int main(void) +{ + + struct addrinfo *ai = 0; + if(getaddrinfo(0, 0, 0, &ai)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_getaddrinfo="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_getaddrinfo="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$cross_compiling" != "yes" && + test "$tst_compi_getaddrinfo" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if getaddrinfo seems to work" >&5 +printf %s "checking if getaddrinfo seems to work... " >&6; } + + if test "$curl_cv_apple" = "yes"; then + if test "$cross_compiling" = yes +then : + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_ws2tcpip + $curl_includes_stdlib + $curl_includes_string + $curl_includes_sys_socket + $curl_includes_netdb + +int main(void) +{ + + struct addrinfo hints; + struct addrinfo *ai = 0; + int error; + int exitcode; + + #ifdef _WIN32 + WSADATA wsa; + if(WSAStartup(MAKEWORD(2, 2), &wsa)) + return 2; + #endif + + memset(&hints, 0, sizeof(hints)); + hints.ai_flags = AI_NUMERICHOST; + hints.ai_family = AF_UNSPEC; + hints.ai_socktype = SOCK_STREAM; + error = getaddrinfo("127.0.0.1", 0, &hints, &ai); + if(error || !ai) + exitcode = 1; /* fail */ + else { + freeaddrinfo(ai); + exitcode = 0; + } + #ifdef _WIN32 + WSACleanup(); + #endif + return exitcode; + + return 0; +} + +_ACEOF +if ac_fn_c_try_run "$LINENO" +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_works_getaddrinfo="yes" + +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_works_getaddrinfo="no" + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + else + oldcc=$CC + old=$LD_LIBRARY_PATH + CC="sh ./run-compiler" + LD_LIBRARY_PATH=$CURL_LIBRARY_PATH:$old + export LD_LIBRARY_PATH + if test "$cross_compiling" = yes +then : + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_ws2tcpip + $curl_includes_stdlib + $curl_includes_string + $curl_includes_sys_socket + $curl_includes_netdb + +int main(void) +{ + + struct addrinfo hints; + struct addrinfo *ai = 0; + int error; + int exitcode; + + #ifdef _WIN32 + WSADATA wsa; + if(WSAStartup(MAKEWORD(2, 2), &wsa)) + return 2; + #endif + + memset(&hints, 0, sizeof(hints)); + hints.ai_flags = AI_NUMERICHOST; + hints.ai_family = AF_UNSPEC; + hints.ai_socktype = SOCK_STREAM; + error = getaddrinfo("127.0.0.1", 0, &hints, &ai); + if(error || !ai) + exitcode = 1; /* fail */ + else { + freeaddrinfo(ai); + exitcode = 0; + } + #ifdef _WIN32 + WSACleanup(); + #endif + return exitcode; + + return 0; +} + +_ACEOF +if ac_fn_c_try_run "$LINENO" +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_works_getaddrinfo="yes" + +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_works_getaddrinfo="no" + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + # restore + LD_LIBRARY_PATH=$old + CC=$oldcc + fi + + fi + + if test "$tst_compi_getaddrinfo" = "yes" && + test "$tst_works_getaddrinfo" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if getaddrinfo usage allowed" >&5 +printf %s "checking if getaddrinfo usage allowed... " >&6; } + if test "x$curl_disallow_getaddrinfo" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_getaddrinfo="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_getaddrinfo="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if getaddrinfo might be used" >&5 +printf %s "checking if getaddrinfo might be used... " >&6; } + if test "$tst_proto_getaddrinfo" = "yes" && + test "$tst_compi_getaddrinfo" = "yes" && + test "$tst_allow_getaddrinfo" = "yes" && + test "$tst_works_getaddrinfo" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_GETADDRINFO 1" >>confdefs.h + + curl_cv_func_getaddrinfo="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_getaddrinfo="no" + curl_cv_func_getaddrinfo_threadsafe="no" + fi + + if test "$curl_cv_func_getaddrinfo" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if getaddrinfo is thread-safe" >&5 +printf %s "checking if getaddrinfo is thread-safe... " >&6; } + if test "$curl_cv_apple" = "yes"; then + tst_tsafe_getaddrinfo="yes" + fi + case $host_os in + aix[1234].* | aix5.[01].*) + tst_tsafe_getaddrinfo="no" + ;; + aix*) + tst_tsafe_getaddrinfo="yes" + ;; + darwin[12345].*) + tst_tsafe_getaddrinfo="no" + ;; + freebsd[1234].* | freebsd5.[1234]*) + tst_tsafe_getaddrinfo="no" + ;; + freebsd*) + tst_tsafe_getaddrinfo="yes" + ;; + hpux[123456789].* | hpux10.* | hpux11.0* | hpux11.10*) + tst_tsafe_getaddrinfo="no" + ;; + hpux*) + tst_tsafe_getaddrinfo="yes" + ;; + midnightbsd*) + tst_tsafe_getaddrinfo="yes" + ;; + netbsd[123].*) + tst_tsafe_getaddrinfo="no" + ;; + netbsd*) + tst_tsafe_getaddrinfo="yes" + ;; + *bsd*) + tst_tsafe_getaddrinfo="no" + ;; + solaris2*) + tst_tsafe_getaddrinfo="yes" + ;; + esac + if test "$tst_tsafe_getaddrinfo" = "unknown" && + test "$curl_cv_native_windows" = "yes"; then + tst_tsafe_getaddrinfo="yes" + fi + if test "$tst_tsafe_getaddrinfo" = "unknown"; then + tst_tsafe_getaddrinfo="yes" + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tst_tsafe_getaddrinfo" >&5 +printf "%s\n" "$tst_tsafe_getaddrinfo" >&6; } + if test "$tst_tsafe_getaddrinfo" = "yes"; then + +printf "%s\n" "#define HAVE_GETADDRINFO_THREADSAFE 1" >>confdefs.h + + curl_cv_func_getaddrinfo_threadsafe="yes" + else + curl_cv_func_getaddrinfo_threadsafe="no" + fi + fi + + + + + tst_links_gethostbyname_r="unknown" + tst_proto_gethostbyname_r="unknown" + tst_compi_gethostbyname_r="unknown" + tst_allow_gethostbyname_r="unknown" + tst_nargs_gethostbyname_r="unknown" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if gethostbyname_r can be linked" >&5 +printf %s "checking if gethostbyname_r can be linked... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#define gethostbyname_r innocuous_gethostbyname_r +#ifdef __STDC__ +# include +#else +# include +#endif +#undef gethostbyname_r +#ifdef __cplusplus +extern "C" +#endif +char gethostbyname_r (); +#if defined __stub_gethostbyname_r || defined __stub___gethostbyname_r +#error force compilation error +#endif + +int main(void) +{ +return gethostbyname_r (); + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_links_gethostbyname_r="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_links_gethostbyname_r="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$tst_links_gethostbyname_r" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if gethostbyname_r is prototyped" >&5 +printf %s "checking if gethostbyname_r is prototyped... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + $curl_includes_netdb + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "gethostbyname_r" >/dev/null 2>&1 +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_proto_gethostbyname_r="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_proto_gethostbyname_r="no" + +fi +rm -rf conftest* + + fi + + if test "$tst_proto_gethostbyname_r" = "yes"; then + if test "$tst_nargs_gethostbyname_r" = "unknown"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if gethostbyname_r takes 3 args." >&5 +printf %s "checking if gethostbyname_r takes 3 args.... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_netdb + $curl_includes_bsdsocket + +int main(void) +{ + + if(gethostbyname_r(0, 0, 0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_gethostbyname_r="yes" + tst_nargs_gethostbyname_r="3" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_gethostbyname_r="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + if test "$tst_nargs_gethostbyname_r" = "unknown"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if gethostbyname_r takes 5 args." >&5 +printf %s "checking if gethostbyname_r takes 5 args.... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_netdb + $curl_includes_bsdsocket + +int main(void) +{ + + if(gethostbyname_r(0, 0, 0, 0, 0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_gethostbyname_r="yes" + tst_nargs_gethostbyname_r="5" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_gethostbyname_r="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + if test "$tst_nargs_gethostbyname_r" = "unknown"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if gethostbyname_r takes 6 args." >&5 +printf %s "checking if gethostbyname_r takes 6 args.... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_netdb + $curl_includes_bsdsocket + +int main(void) +{ + + if(gethostbyname_r(0, 0, 0, 0, 0, 0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_gethostbyname_r="yes" + tst_nargs_gethostbyname_r="6" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_gethostbyname_r="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if gethostbyname_r is compilable" >&5 +printf %s "checking if gethostbyname_r is compilable... " >&6; } + if test "$tst_compi_gethostbyname_r" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + fi + fi + + if test "$tst_compi_gethostbyname_r" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if gethostbyname_r usage allowed" >&5 +printf %s "checking if gethostbyname_r usage allowed... " >&6; } + if test "x$curl_disallow_gethostbyname_r" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_gethostbyname_r="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_gethostbyname_r="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if gethostbyname_r might be used" >&5 +printf %s "checking if gethostbyname_r might be used... " >&6; } + if test "$tst_links_gethostbyname_r" = "yes" && + test "$tst_proto_gethostbyname_r" = "yes" && + test "$tst_compi_gethostbyname_r" = "yes" && + test "$tst_allow_gethostbyname_r" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_GETHOSTBYNAME_R 1" >>confdefs.h + + + if test "$tst_nargs_gethostbyname_r" -eq "3"; then + +printf "%s\n" "#define HAVE_GETHOSTBYNAME_R_3 1" >>confdefs.h + + elif test "$tst_nargs_gethostbyname_r" -eq "5"; then + +printf "%s\n" "#define HAVE_GETHOSTBYNAME_R_5 1" >>confdefs.h + + elif test "$tst_nargs_gethostbyname_r" -eq "6"; then + +printf "%s\n" "#define HAVE_GETHOSTBYNAME_R_6 1" >>confdefs.h + + fi + + curl_cv_func_gethostbyname_r="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_gethostbyname_r="no" + fi + + +curl_preprocess_callconv="\ +/* preprocess start */ +#ifdef _WIN32 +# define FUNCALLCONV __stdcall +#else +# define FUNCALLCONV +#endif +/* preprocess end */" + + + + + + + + tst_links_gethostname="unknown" + tst_proto_gethostname="unknown" + tst_compi_gethostname="unknown" + tst_allow_gethostname="unknown" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if gethostname can be linked" >&5 +printf %s "checking if gethostname can be linked... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_winsock2 + $curl_includes_unistd + $curl_includes_bsdsocket + +int main(void) +{ + + char s[1]; + if(gethostname((void *)s, 0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_links_gethostname="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_links_gethostname="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$tst_links_gethostname" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if gethostname is prototyped" >&5 +printf %s "checking if gethostname is prototyped... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + $curl_includes_winsock2 + $curl_includes_unistd + $curl_includes_bsdsocket + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "gethostname" >/dev/null 2>&1 +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_proto_gethostname="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_proto_gethostname="no" + +fi +rm -rf conftest* + + fi + + if test "$tst_proto_gethostname" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if gethostname is compilable" >&5 +printf %s "checking if gethostname is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_winsock2 + $curl_includes_unistd + $curl_includes_bsdsocket + +int main(void) +{ + + char s[1]; + if(gethostname((void *)s, 0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_gethostname="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_gethostname="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$tst_compi_gethostname" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gethostname arg 2 data type" >&5 +printf %s "checking for gethostname arg 2 data type... " >&6; } + tst_gethostname_type_arg2="unknown" + for tst_arg1 in 'char *' 'unsigned char *' 'void *'; do + for tst_arg2 in 'int' 'unsigned int' 'size_t'; do + if test "$tst_gethostname_type_arg2" = "unknown"; then + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_winsock2 + $curl_includes_unistd + $curl_includes_bsdsocket + $curl_preprocess_callconv + #if defined(_WIN32) && defined(WINSOCK_API_LINKAGE) + WINSOCK_API_LINKAGE + #else + extern + #endif + int FUNCALLCONV gethostname($tst_arg1, $tst_arg2); + +int main(void) +{ + + char s[1]; + if(gethostname(($tst_arg1)s, 0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + tst_gethostname_type_arg2="$tst_arg2" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + done + done + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tst_gethostname_type_arg2" >&5 +printf "%s\n" "$tst_gethostname_type_arg2" >&6; } + if test "$tst_gethostname_type_arg2" != "unknown"; then + +printf "%s\n" "#define GETHOSTNAME_TYPE_ARG2 $tst_gethostname_type_arg2" >>confdefs.h + + fi + fi + + if test "$tst_compi_gethostname" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if gethostname usage allowed" >&5 +printf %s "checking if gethostname usage allowed... " >&6; } + if test "x$curl_disallow_gethostname" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_gethostname="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_gethostname="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if gethostname might be used" >&5 +printf %s "checking if gethostname might be used... " >&6; } + if test "$tst_links_gethostname" = "yes" && + test "$tst_proto_gethostname" = "yes" && + test "$tst_compi_gethostname" = "yes" && + test "$tst_allow_gethostname" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_GETHOSTNAME 1" >>confdefs.h + + curl_cv_func_gethostname="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_gethostname="no" + fi + + +curl_includes_ifaddrs="\ +/* includes start */ +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifndef _WIN32 +# include +#endif +#ifdef HAVE_NETINET_IN_H +# include +#endif +#ifdef HAVE_IFADDRS_H +# include +#endif +/* includes end */" + ac_fn_c_check_header_compile "$LINENO" "sys/types.h" "ac_cv_header_sys_types_h" "$curl_includes_ifaddrs +" +if test "x$ac_cv_header_sys_types_h" = xyes +then : + printf "%s\n" "#define HAVE_SYS_TYPES_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "netinet/in.h" "ac_cv_header_netinet_in_h" "$curl_includes_ifaddrs +" +if test "x$ac_cv_header_netinet_in_h" = xyes +then : + printf "%s\n" "#define HAVE_NETINET_IN_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "ifaddrs.h" "ac_cv_header_ifaddrs_h" "$curl_includes_ifaddrs +" +if test "x$ac_cv_header_ifaddrs_h" = xyes +then : + printf "%s\n" "#define HAVE_IFADDRS_H 1" >>confdefs.h + +fi + + + + + + + tst_links_getifaddrs="unknown" + tst_proto_getifaddrs="unknown" + tst_compi_getifaddrs="unknown" + tst_works_getifaddrs="unknown" + tst_allow_getifaddrs="unknown" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if getifaddrs can be linked" >&5 +printf %s "checking if getifaddrs can be linked... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#define getifaddrs innocuous_getifaddrs +#ifdef __STDC__ +# include +#else +# include +#endif +#undef getifaddrs +#ifdef __cplusplus +extern "C" +#endif +char getifaddrs (); +#if defined __stub_getifaddrs || defined __stub___getifaddrs +#error force compilation error +#endif + +int main(void) +{ +return getifaddrs (); + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_links_getifaddrs="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_links_getifaddrs="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$tst_links_getifaddrs" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if getifaddrs is prototyped" >&5 +printf %s "checking if getifaddrs is prototyped... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + $curl_includes_ifaddrs + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "getifaddrs" >/dev/null 2>&1 +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_proto_getifaddrs="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_proto_getifaddrs="no" + +fi +rm -rf conftest* + + fi + + if test "$tst_proto_getifaddrs" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if getifaddrs is compilable" >&5 +printf %s "checking if getifaddrs is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_ifaddrs + +int main(void) +{ + + if(getifaddrs(0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_getifaddrs="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_getifaddrs="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$cross_compiling" != "yes" && + test "$tst_compi_getifaddrs" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if getifaddrs seems to work" >&5 +printf %s "checking if getifaddrs seems to work... " >&6; } + + if test "$curl_cv_apple" = "yes"; then + if test "$cross_compiling" = yes +then : + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_stdlib + $curl_includes_ifaddrs + +int main(void) +{ + + struct ifaddrs *ifa = 0; + int error; + + error = getifaddrs(&ifa); + if(error || !ifa) + return 1; /* fail */ + else { + freeifaddrs(ifa); + return 0; + } + + return 0; +} + +_ACEOF +if ac_fn_c_try_run "$LINENO" +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_works_getifaddrs="yes" + +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_works_getifaddrs="no" + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + else + oldcc=$CC + old=$LD_LIBRARY_PATH + CC="sh ./run-compiler" + LD_LIBRARY_PATH=$CURL_LIBRARY_PATH:$old + export LD_LIBRARY_PATH + if test "$cross_compiling" = yes +then : + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_stdlib + $curl_includes_ifaddrs + +int main(void) +{ + + struct ifaddrs *ifa = 0; + int error; + + error = getifaddrs(&ifa); + if(error || !ifa) + return 1; /* fail */ + else { + freeifaddrs(ifa); + return 0; + } + + return 0; +} + +_ACEOF +if ac_fn_c_try_run "$LINENO" +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_works_getifaddrs="yes" + +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_works_getifaddrs="no" + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + # restore + LD_LIBRARY_PATH=$old + CC=$oldcc + fi + + fi + + if test "$tst_compi_getifaddrs" = "yes" && + test "$tst_works_getifaddrs" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if getifaddrs usage allowed" >&5 +printf %s "checking if getifaddrs usage allowed... " >&6; } + if test "x$curl_disallow_getifaddrs" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_getifaddrs="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_getifaddrs="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if getifaddrs might be used" >&5 +printf %s "checking if getifaddrs might be used... " >&6; } + if test "$tst_links_getifaddrs" = "yes" && + test "$tst_proto_getifaddrs" = "yes" && + test "$tst_compi_getifaddrs" = "yes" && + test "$tst_allow_getifaddrs" = "yes" && + test "$tst_works_getifaddrs" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_GETIFADDRS 1" >>confdefs.h + + curl_cv_func_getifaddrs="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_getifaddrs="no" + fi + + + + + + + + tst_links_getpeername="unknown" + tst_proto_getpeername="unknown" + tst_compi_getpeername="unknown" + tst_allow_getpeername="unknown" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if getpeername can be linked" >&5 +printf %s "checking if getpeername can be linked... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_winsock2 + $curl_includes_bsdsocket + $curl_includes_sys_socket + +int main(void) +{ + + if(getpeername(0, (void *)0, (void *)0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_links_getpeername="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_links_getpeername="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$tst_links_getpeername" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if getpeername is prototyped" >&5 +printf %s "checking if getpeername is prototyped... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + $curl_includes_winsock2 + $curl_includes_bsdsocket + $curl_includes_sys_socket + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "getpeername" >/dev/null 2>&1 +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_proto_getpeername="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_proto_getpeername="no" + +fi +rm -rf conftest* + + fi + + if test "$tst_proto_getpeername" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if getpeername is compilable" >&5 +printf %s "checking if getpeername is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_winsock2 + $curl_includes_bsdsocket + $curl_includes_sys_socket + +int main(void) +{ + + if(getpeername(0, (void *)0, (void *)0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_getpeername="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_getpeername="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$tst_compi_getpeername" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if getpeername usage allowed" >&5 +printf %s "checking if getpeername usage allowed... " >&6; } + if test "x$curl_disallow_getpeername" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_getpeername="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_getpeername="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if getpeername might be used" >&5 +printf %s "checking if getpeername might be used... " >&6; } + if test "$tst_links_getpeername" = "yes" && + test "$tst_proto_getpeername" = "yes" && + test "$tst_compi_getpeername" = "yes" && + test "$tst_allow_getpeername" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_GETPEERNAME 1" >>confdefs.h + + curl_cv_func_getpeername="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_getpeername="no" + fi + + + + + + + + tst_links_getsockname="unknown" + tst_proto_getsockname="unknown" + tst_compi_getsockname="unknown" + tst_allow_getsockname="unknown" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if getsockname can be linked" >&5 +printf %s "checking if getsockname can be linked... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_winsock2 + $curl_includes_bsdsocket + $curl_includes_sys_socket + +int main(void) +{ + + if(getsockname(0, (void *)0, (void *)0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_links_getsockname="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_links_getsockname="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$tst_links_getsockname" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if getsockname is prototyped" >&5 +printf %s "checking if getsockname is prototyped... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + $curl_includes_winsock2 + $curl_includes_bsdsocket + $curl_includes_sys_socket + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "getsockname" >/dev/null 2>&1 +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_proto_getsockname="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_proto_getsockname="no" + +fi +rm -rf conftest* + + fi + + if test "$tst_proto_getsockname" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if getsockname is compilable" >&5 +printf %s "checking if getsockname is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_winsock2 + $curl_includes_bsdsocket + $curl_includes_sys_socket + +int main(void) +{ + + if(getsockname(0, (void *)0, (void *)0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_getsockname="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_getsockname="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$tst_compi_getsockname" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if getsockname usage allowed" >&5 +printf %s "checking if getsockname usage allowed... " >&6; } + if test "x$curl_disallow_getsockname" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_getsockname="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_getsockname="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if getsockname might be used" >&5 +printf %s "checking if getsockname might be used... " >&6; } + if test "$tst_links_getsockname" = "yes" && + test "$tst_proto_getsockname" = "yes" && + test "$tst_compi_getsockname" = "yes" && + test "$tst_allow_getsockname" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_GETSOCKNAME 1" >>confdefs.h + + curl_cv_func_getsockname="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_getsockname="no" + fi + + +curl_includes_time="\ +/* includes start */ +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#if !defined(_WIN32) || defined(__MINGW32__) +# include +#endif +#include +/* includes end */" + ac_fn_c_check_header_compile "$LINENO" "sys/types.h" "ac_cv_header_sys_types_h" "$curl_includes_time +" +if test "x$ac_cv_header_sys_types_h" = xyes +then : + printf "%s\n" "#define HAVE_SYS_TYPES_H 1" >>confdefs.h + +fi + + + + + + + tst_links_gmtime_r="unknown" + tst_proto_gmtime_r="unknown" + tst_compi_gmtime_r="unknown" + tst_works_gmtime_r="unknown" + tst_allow_gmtime_r="unknown" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if gmtime_r can be linked" >&5 +printf %s "checking if gmtime_r can be linked... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#define gmtime_r innocuous_gmtime_r +#ifdef __STDC__ +# include +#else +# include +#endif +#undef gmtime_r +#ifdef __cplusplus +extern "C" +#endif +char gmtime_r (); +#if defined __stub_gmtime_r || defined __stub___gmtime_r +#error force compilation error +#endif + +int main(void) +{ +return gmtime_r (); + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_links_gmtime_r="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_links_gmtime_r="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$tst_links_gmtime_r" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if gmtime_r is prototyped" >&5 +printf %s "checking if gmtime_r is prototyped... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + $curl_includes_time + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "gmtime_r" >/dev/null 2>&1 +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_proto_gmtime_r="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_proto_gmtime_r="no" + +fi +rm -rf conftest* + + fi + + if test "$tst_proto_gmtime_r" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if gmtime_r is compilable" >&5 +printf %s "checking if gmtime_r is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_time + +int main(void) +{ + + time_t tm = 1170352587; + struct tm result; + if(gmtime_r(&tm, &result) == 0) + return 1; + (void)result; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_gmtime_r="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_gmtime_r="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$cross_compiling" != "yes" && + test "$tst_compi_gmtime_r" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if gmtime_r seems to work" >&5 +printf %s "checking if gmtime_r seems to work... " >&6; } + + if test "$curl_cv_apple" = "yes"; then + if test "$cross_compiling" = yes +then : + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_stdlib + $curl_includes_time + +int main(void) +{ + + time_t local = 1170352587; + struct tm *gmt = 0; + struct tm result; + gmt = gmtime_r(&local, &result); + (void)result; + if(gmt) + return 0; + else + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_run "$LINENO" +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_works_gmtime_r="yes" + +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_works_gmtime_r="no" + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + else + oldcc=$CC + old=$LD_LIBRARY_PATH + CC="sh ./run-compiler" + LD_LIBRARY_PATH=$CURL_LIBRARY_PATH:$old + export LD_LIBRARY_PATH + if test "$cross_compiling" = yes +then : + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_stdlib + $curl_includes_time + +int main(void) +{ + + time_t local = 1170352587; + struct tm *gmt = 0; + struct tm result; + gmt = gmtime_r(&local, &result); + (void)result; + if(gmt) + return 0; + else + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_run "$LINENO" +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_works_gmtime_r="yes" + +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_works_gmtime_r="no" + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + # restore + LD_LIBRARY_PATH=$old + CC=$oldcc + fi + + fi + + if test "$tst_compi_gmtime_r" = "yes" && + test "$tst_works_gmtime_r" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if gmtime_r usage allowed" >&5 +printf %s "checking if gmtime_r usage allowed... " >&6; } + if test "x$curl_disallow_gmtime_r" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_gmtime_r="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_gmtime_r="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if gmtime_r might be used" >&5 +printf %s "checking if gmtime_r might be used... " >&6; } + if test "$tst_links_gmtime_r" = "yes" && + test "$tst_proto_gmtime_r" = "yes" && + test "$tst_compi_gmtime_r" = "yes" && + test "$tst_allow_gmtime_r" = "yes" && + test "$tst_works_gmtime_r" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_GMTIME_R 1" >>confdefs.h + + curl_cv_func_gmtime_r="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_gmtime_r="no" + fi + + +curl_includes_stropts="\ +/* includes start */ +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifdef HAVE_UNISTD_H +# include +#endif +#ifndef _WIN32 +# include +#endif +#ifdef HAVE_SYS_IOCTL_H +# include +#endif +#ifdef HAVE_STROPTS_H +# include +#endif +/* includes end */" + ac_fn_c_check_header_compile "$LINENO" "sys/types.h" "ac_cv_header_sys_types_h" "$curl_includes_stropts +" +if test "x$ac_cv_header_sys_types_h" = xyes +then : + printf "%s\n" "#define HAVE_SYS_TYPES_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "unistd.h" "ac_cv_header_unistd_h" "$curl_includes_stropts +" +if test "x$ac_cv_header_unistd_h" = xyes +then : + printf "%s\n" "#define HAVE_UNISTD_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "sys/ioctl.h" "ac_cv_header_sys_ioctl_h" "$curl_includes_stropts +" +if test "x$ac_cv_header_sys_ioctl_h" = xyes +then : + printf "%s\n" "#define HAVE_SYS_IOCTL_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "stropts.h" "ac_cv_header_stropts_h" "$curl_includes_stropts +" +if test "x$ac_cv_header_stropts_h" = xyes +then : + printf "%s\n" "#define HAVE_STROPTS_H 1" >>confdefs.h + +fi + + + + + + tst_links_ioctl="unknown" + tst_proto_ioctl="unknown" + tst_compi_ioctl="unknown" + tst_allow_ioctl="unknown" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if ioctl can be linked" >&5 +printf %s "checking if ioctl can be linked... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#define ioctl innocuous_ioctl +#ifdef __STDC__ +# include +#else +# include +#endif +#undef ioctl +#ifdef __cplusplus +extern "C" +#endif +char ioctl (); +#if defined __stub_ioctl || defined __stub___ioctl +#error force compilation error +#endif + +int main(void) +{ +return ioctl (); + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_links_ioctl="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_links_ioctl="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$tst_links_ioctl" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if ioctl is prototyped" >&5 +printf %s "checking if ioctl is prototyped... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + $curl_includes_stropts + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "ioctl" >/dev/null 2>&1 +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_proto_ioctl="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_proto_ioctl="no" + +fi +rm -rf conftest* + + fi + + if test "$tst_proto_ioctl" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if ioctl is compilable" >&5 +printf %s "checking if ioctl is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_stropts + +int main(void) +{ + + if(ioctl(0, 0, 0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_ioctl="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_ioctl="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$tst_compi_ioctl" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if ioctl usage allowed" >&5 +printf %s "checking if ioctl usage allowed... " >&6; } + if test "x$curl_disallow_ioctl" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_ioctl="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_ioctl="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if ioctl might be used" >&5 +printf %s "checking if ioctl might be used... " >&6; } + if test "$tst_links_ioctl" = "yes" && + test "$tst_proto_ioctl" = "yes" && + test "$tst_compi_ioctl" = "yes" && + test "$tst_allow_ioctl" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + curl_cv_func_ioctl="yes" + + + tst_compi_ioctl_fionbio="unknown" + tst_allow_ioctl_fionbio="unknown" + + if test "$curl_cv_func_ioctl" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if ioctl FIONBIO is compilable" >&5 +printf %s "checking if ioctl FIONBIO is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_stropts + +int main(void) +{ + + int flags = 0; + if(ioctl(0, FIONBIO, &flags)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_ioctl_fionbio="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_ioctl_fionbio="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$tst_compi_ioctl_fionbio" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if ioctl FIONBIO usage allowed" >&5 +printf %s "checking if ioctl FIONBIO usage allowed... " >&6; } + if test "x$curl_disallow_ioctl_fionbio" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_ioctl_fionbio="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_ioctl_fionbio="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if ioctl FIONBIO might be used" >&5 +printf %s "checking if ioctl FIONBIO might be used... " >&6; } + if test "$tst_compi_ioctl_fionbio" = "yes" && + test "$tst_allow_ioctl_fionbio" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_IOCTL_FIONBIO 1" >>confdefs.h + + curl_cv_func_ioctl_fionbio="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_ioctl_fionbio="no" + fi + + + + tst_compi_ioctl_siocgifaddr="unknown" + tst_allow_ioctl_siocgifaddr="unknown" + + if test "$curl_cv_func_ioctl" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if ioctl SIOCGIFADDR is compilable" >&5 +printf %s "checking if ioctl SIOCGIFADDR is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_stropts + #include + +int main(void) +{ + + struct ifreq ifr; + if(ioctl(0, SIOCGIFADDR, &ifr)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_ioctl_siocgifaddr="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_ioctl_siocgifaddr="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$tst_compi_ioctl_siocgifaddr" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if ioctl SIOCGIFADDR usage allowed" >&5 +printf %s "checking if ioctl SIOCGIFADDR usage allowed... " >&6; } + if test "x$curl_disallow_ioctl_siocgifaddr" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_ioctl_siocgifaddr="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_ioctl_siocgifaddr="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if ioctl SIOCGIFADDR might be used" >&5 +printf %s "checking if ioctl SIOCGIFADDR might be used... " >&6; } + if test "$tst_compi_ioctl_siocgifaddr" = "yes" && + test "$tst_allow_ioctl_siocgifaddr" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_IOCTL_SIOCGIFADDR 1" >>confdefs.h + + curl_cv_func_ioctl_siocgifaddr="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_ioctl_siocgifaddr="no" + fi + + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_ioctl="no" + fi + + + + + tst_links_ioctlsocket="unknown" + tst_proto_ioctlsocket="unknown" + tst_compi_ioctlsocket="unknown" + tst_allow_ioctlsocket="unknown" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if ioctlsocket can be linked" >&5 +printf %s "checking if ioctlsocket can be linked... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_winsock2 + +int main(void) +{ + + if(ioctlsocket(0, 0, 0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_links_ioctlsocket="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_links_ioctlsocket="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$tst_links_ioctlsocket" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if ioctlsocket is prototyped" >&5 +printf %s "checking if ioctlsocket is prototyped... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + $curl_includes_winsock2 + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "ioctlsocket" >/dev/null 2>&1 +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_proto_ioctlsocket="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_proto_ioctlsocket="no" + +fi +rm -rf conftest* + + fi + + if test "$tst_proto_ioctlsocket" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if ioctlsocket is compilable" >&5 +printf %s "checking if ioctlsocket is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_winsock2 + +int main(void) +{ + + if(ioctlsocket(0, 0, 0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_ioctlsocket="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_ioctlsocket="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$tst_compi_ioctlsocket" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if ioctlsocket usage allowed" >&5 +printf %s "checking if ioctlsocket usage allowed... " >&6; } + if test "x$curl_disallow_ioctlsocket" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_ioctlsocket="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_ioctlsocket="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if ioctlsocket might be used" >&5 +printf %s "checking if ioctlsocket might be used... " >&6; } + if test "$tst_links_ioctlsocket" = "yes" && + test "$tst_proto_ioctlsocket" = "yes" && + test "$tst_compi_ioctlsocket" = "yes" && + test "$tst_allow_ioctlsocket" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_IOCTLSOCKET 1" >>confdefs.h + + curl_cv_func_ioctlsocket="yes" + + + tst_compi_ioctlsocket_fionbio="unknown" + tst_allow_ioctlsocket_fionbio="unknown" + + if test "$curl_cv_func_ioctlsocket" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if ioctlsocket FIONBIO is compilable" >&5 +printf %s "checking if ioctlsocket FIONBIO is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_winsock2 + +int main(void) +{ + + unsigned long flags = 0; + if(ioctlsocket(0, FIONBIO, &flags)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_ioctlsocket_fionbio="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_ioctlsocket_fionbio="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$tst_compi_ioctlsocket_fionbio" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if ioctlsocket FIONBIO usage allowed" >&5 +printf %s "checking if ioctlsocket FIONBIO usage allowed... " >&6; } + if test "x$curl_disallow_ioctlsocket_fionbio" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_ioctlsocket_fionbio="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_ioctlsocket_fionbio="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if ioctlsocket FIONBIO might be used" >&5 +printf %s "checking if ioctlsocket FIONBIO might be used... " >&6; } + if test "$tst_compi_ioctlsocket_fionbio" = "yes" && + test "$tst_allow_ioctlsocket_fionbio" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_IOCTLSOCKET_FIONBIO 1" >>confdefs.h + + curl_cv_func_ioctlsocket_fionbio="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_ioctlsocket_fionbio="no" + fi + + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_ioctlsocket="no" + fi + + + + + tst_links_ioctlsocket_camel="unknown" + tst_compi_ioctlsocket_camel="unknown" + tst_allow_ioctlsocket_camel="unknown" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if IoctlSocket can be linked" >&5 +printf %s "checking if IoctlSocket can be linked... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_bsdsocket + +int main(void) +{ + + if(IoctlSocket(0, 0, 0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_links_ioctlsocket_camel="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_links_ioctlsocket_camel="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$tst_links_ioctlsocket_camel" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if IoctlSocket is compilable" >&5 +printf %s "checking if IoctlSocket is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_bsdsocket + +int main(void) +{ + + if(IoctlSocket(0, 0, 0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_ioctlsocket_camel="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_ioctlsocket_camel="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$tst_compi_ioctlsocket_camel" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if IoctlSocket usage allowed" >&5 +printf %s "checking if IoctlSocket usage allowed... " >&6; } + if test "x$curl_disallow_ioctlsocket_camel" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_ioctlsocket_camel="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_ioctlsocket_camel="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if IoctlSocket might be used" >&5 +printf %s "checking if IoctlSocket might be used... " >&6; } + if test "$tst_links_ioctlsocket_camel" = "yes" && + test "$tst_compi_ioctlsocket_camel" = "yes" && + test "$tst_allow_ioctlsocket_camel" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_IOCTLSOCKET_CAMEL 1" >>confdefs.h + + curl_cv_func_ioctlsocket_camel="yes" + + + + tst_compi_ioctlsocket_camel_fionbio="unknown" + tst_allow_ioctlsocket_camel_fionbio="unknown" + + if test "$curl_cv_func_ioctlsocket_camel" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if IoctlSocket FIONBIO is compilable" >&5 +printf %s "checking if IoctlSocket FIONBIO is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_bsdsocket + +int main(void) +{ + + long flags = 0; + if(IoctlSocket(0, FIONBIO, &flags)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_ioctlsocket_camel_fionbio="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_ioctlsocket_camel_fionbio="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$tst_compi_ioctlsocket_camel_fionbio" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if IoctlSocket FIONBIO usage allowed" >&5 +printf %s "checking if IoctlSocket FIONBIO usage allowed... " >&6; } + if test "x$curl_disallow_ioctlsocket_camel_fionbio" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_ioctlsocket_camel_fionbio="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_ioctlsocket_camel_fionbio="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if IoctlSocket FIONBIO might be used" >&5 +printf %s "checking if IoctlSocket FIONBIO might be used... " >&6; } + if test "$tst_compi_ioctlsocket_camel_fionbio" = "yes" && + test "$tst_allow_ioctlsocket_camel_fionbio" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_IOCTLSOCKET_CAMEL_FIONBIO 1" >>confdefs.h + + curl_cv_func_ioctlsocket_camel_fionbio="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_ioctlsocket_camel_fionbio="no" + fi + + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_ioctlsocket_camel="no" + fi + + + + + + tst_links_localtime_r="unknown" + tst_proto_localtime_r="unknown" + tst_compi_localtime_r="unknown" + tst_works_localtime_r="unknown" + tst_allow_localtime_r="unknown" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if localtime_r can be linked" >&5 +printf %s "checking if localtime_r can be linked... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#define localtime_r innocuous_localtime_r +#ifdef __STDC__ +# include +#else +# include +#endif +#undef localtime_r +#ifdef __cplusplus +extern "C" +#endif +char localtime_r (); +#if defined __stub_localtime_r || defined __stub___localtime_r +#error force compilation error +#endif + +int main(void) +{ +return localtime_r (); + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_links_localtime_r="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_links_localtime_r="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$tst_links_localtime_r" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if localtime_r is prototyped" >&5 +printf %s "checking if localtime_r is prototyped... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + $curl_includes_time + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "localtime_r" >/dev/null 2>&1 +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_proto_localtime_r="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_proto_localtime_r="no" + +fi +rm -rf conftest* + + fi + + if test "$tst_proto_localtime_r" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if localtime_r is compilable" >&5 +printf %s "checking if localtime_r is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_time + +int main(void) +{ + + time_t clock = 1170352587; + struct tm result; + if(localtime_r(&clock, &result)) + return 1; + (void)result; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_localtime_r="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_localtime_r="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$cross_compiling" != "yes" && + test "$tst_compi_localtime_r" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if localtime_r seems to work" >&5 +printf %s "checking if localtime_r seems to work... " >&6; } + + if test "$curl_cv_apple" = "yes"; then + if test "$cross_compiling" = yes +then : + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_stdlib + $curl_includes_time + +int main(void) +{ + + time_t clock = 1170352587; + struct tm *tmp = 0; + struct tm result; + tmp = localtime_r(&clock, &result); + (void)result; + if(tmp) + return 0; + else + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_run "$LINENO" +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_works_localtime_r="yes" + +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_works_localtime_r="no" + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + else + oldcc=$CC + old=$LD_LIBRARY_PATH + CC="sh ./run-compiler" + LD_LIBRARY_PATH=$CURL_LIBRARY_PATH:$old + export LD_LIBRARY_PATH + if test "$cross_compiling" = yes +then : + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_stdlib + $curl_includes_time + +int main(void) +{ + + time_t clock = 1170352587; + struct tm *tmp = 0; + struct tm result; + tmp = localtime_r(&clock, &result); + (void)result; + if(tmp) + return 0; + else + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_run "$LINENO" +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_works_localtime_r="yes" + +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_works_localtime_r="no" + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + # restore + LD_LIBRARY_PATH=$old + CC=$oldcc + fi + + fi + + if test "$tst_compi_localtime_r" = "yes" && + test "$tst_works_localtime_r" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if localtime_r usage allowed" >&5 +printf %s "checking if localtime_r usage allowed... " >&6; } + if test "x$curl_disallow_localtime_r" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_localtime_r="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_localtime_r="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if localtime_r might be used" >&5 +printf %s "checking if localtime_r might be used... " >&6; } + if test "$tst_links_localtime_r" = "yes" && + test "$tst_proto_localtime_r" = "yes" && + test "$tst_compi_localtime_r" = "yes" && + test "$tst_allow_localtime_r" = "yes" && + test "$tst_works_localtime_r" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_LOCALTIME_R 1" >>confdefs.h + + curl_cv_func_localtime_r="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_localtime_r="no" + fi + + + + + tst_links_memrchr="unknown" + tst_macro_memrchr="unknown" + tst_proto_memrchr="unknown" + tst_compi_memrchr="unknown" + tst_allow_memrchr="unknown" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if memrchr can be linked" >&5 +printf %s "checking if memrchr can be linked... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#define memrchr innocuous_memrchr +#ifdef __STDC__ +# include +#else +# include +#endif +#undef memrchr +#ifdef __cplusplus +extern "C" +#endif +char memrchr (); +#if defined __stub_memrchr || defined __stub___memrchr +#error force compilation error +#endif + +int main(void) +{ +return memrchr (); + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_links_memrchr="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_links_memrchr="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$tst_links_memrchr" = "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if memrchr seems a macro" >&5 +printf %s "checking if memrchr seems a macro... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_string + +int main(void) +{ + + if(memrchr("", 0, 0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_macro_memrchr="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_macro_memrchr="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + fi + + if test "$tst_links_memrchr" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if memrchr is prototyped" >&5 +printf %s "checking if memrchr is prototyped... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + $curl_includes_string + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "memrchr" >/dev/null 2>&1 +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_proto_memrchr="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_proto_memrchr="no" + +fi +rm -rf conftest* + + fi + + if test "$tst_proto_memrchr" = "yes" || + test "$tst_macro_memrchr" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if memrchr is compilable" >&5 +printf %s "checking if memrchr is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_string + +int main(void) +{ + + if(memrchr("", 0, 0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_memrchr="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_memrchr="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$tst_compi_memrchr" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if memrchr usage allowed" >&5 +printf %s "checking if memrchr usage allowed... " >&6; } + if test "x$curl_disallow_memrchr" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_memrchr="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_memrchr="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if memrchr might be used" >&5 +printf %s "checking if memrchr might be used... " >&6; } + if (test "$tst_proto_memrchr" = "yes" || + test "$tst_macro_memrchr" = "yes") && + test "$tst_compi_memrchr" = "yes" && + test "$tst_allow_memrchr" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_MEMRCHR 1" >>confdefs.h + + curl_cv_func_memrchr="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_memrchr="no" + fi + + +curl_includes_signal="\ +/* includes start */ +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#include +/* includes end */" + ac_fn_c_check_header_compile "$LINENO" "sys/types.h" "ac_cv_header_sys_types_h" "$curl_includes_signal +" +if test "x$ac_cv_header_sys_types_h" = xyes +then : + printf "%s\n" "#define HAVE_SYS_TYPES_H 1" >>confdefs.h + +fi + + + + + + tst_links_sigaction="unknown" + tst_proto_sigaction="unknown" + tst_compi_sigaction="unknown" + tst_allow_sigaction="unknown" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if sigaction can be linked" >&5 +printf %s "checking if sigaction can be linked... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#define sigaction innocuous_sigaction +#ifdef __STDC__ +# include +#else +# include +#endif +#undef sigaction +#ifdef __cplusplus +extern "C" +#endif +char sigaction (); +#if defined __stub_sigaction || defined __stub___sigaction +#error force compilation error +#endif + +int main(void) +{ +return sigaction (); + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_links_sigaction="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_links_sigaction="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$tst_links_sigaction" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if sigaction is prototyped" >&5 +printf %s "checking if sigaction is prototyped... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + $curl_includes_signal + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "sigaction" >/dev/null 2>&1 +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_proto_sigaction="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_proto_sigaction="no" + +fi +rm -rf conftest* + + fi + + if test "$tst_proto_sigaction" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if sigaction is compilable" >&5 +printf %s "checking if sigaction is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_signal + +int main(void) +{ + + if(sigaction(0, 0, 0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_sigaction="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_sigaction="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$tst_compi_sigaction" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if sigaction usage allowed" >&5 +printf %s "checking if sigaction usage allowed... " >&6; } + if test "x$curl_disallow_sigaction" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_sigaction="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_sigaction="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if sigaction might be used" >&5 +printf %s "checking if sigaction might be used... " >&6; } + if test "$tst_links_sigaction" = "yes" && + test "$tst_proto_sigaction" = "yes" && + test "$tst_compi_sigaction" = "yes" && + test "$tst_allow_sigaction" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_SIGACTION 1" >>confdefs.h + + curl_cv_func_sigaction="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_sigaction="no" + fi + + + + + tst_links_siginterrupt="unknown" + tst_proto_siginterrupt="unknown" + tst_compi_siginterrupt="unknown" + tst_allow_siginterrupt="unknown" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if siginterrupt can be linked" >&5 +printf %s "checking if siginterrupt can be linked... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#define siginterrupt innocuous_siginterrupt +#ifdef __STDC__ +# include +#else +# include +#endif +#undef siginterrupt +#ifdef __cplusplus +extern "C" +#endif +char siginterrupt (); +#if defined __stub_siginterrupt || defined __stub___siginterrupt +#error force compilation error +#endif + +int main(void) +{ +return siginterrupt (); + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_links_siginterrupt="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_links_siginterrupt="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$tst_links_siginterrupt" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if siginterrupt is prototyped" >&5 +printf %s "checking if siginterrupt is prototyped... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + $curl_includes_signal + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "siginterrupt" >/dev/null 2>&1 +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_proto_siginterrupt="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_proto_siginterrupt="no" + +fi +rm -rf conftest* + + fi + + if test "$tst_proto_siginterrupt" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if siginterrupt is compilable" >&5 +printf %s "checking if siginterrupt is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_signal + +int main(void) +{ + + if(siginterrupt(0, 0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_siginterrupt="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_siginterrupt="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$tst_compi_siginterrupt" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if siginterrupt usage allowed" >&5 +printf %s "checking if siginterrupt usage allowed... " >&6; } + if test "x$curl_disallow_siginterrupt" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_siginterrupt="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_siginterrupt="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if siginterrupt might be used" >&5 +printf %s "checking if siginterrupt might be used... " >&6; } + if test "$tst_links_siginterrupt" = "yes" && + test "$tst_proto_siginterrupt" = "yes" && + test "$tst_compi_siginterrupt" = "yes" && + test "$tst_allow_siginterrupt" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_SIGINTERRUPT 1" >>confdefs.h + + curl_cv_func_siginterrupt="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_siginterrupt="no" + fi + + + + + tst_links_signal="unknown" + tst_proto_signal="unknown" + tst_compi_signal="unknown" + tst_allow_signal="unknown" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if signal can be linked" >&5 +printf %s "checking if signal can be linked... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#define signal innocuous_signal +#ifdef __STDC__ +# include +#else +# include +#endif +#undef signal +#ifdef __cplusplus +extern "C" +#endif +char signal (); +#if defined __stub_signal || defined __stub___signal +#error force compilation error +#endif + +int main(void) +{ +return signal (); + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_links_signal="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_links_signal="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$tst_links_signal" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if signal is prototyped" >&5 +printf %s "checking if signal is prototyped... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + $curl_includes_signal + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "signal" >/dev/null 2>&1 +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_proto_signal="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_proto_signal="no" + +fi +rm -rf conftest* + + fi + + if test "$tst_proto_signal" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if signal is compilable" >&5 +printf %s "checking if signal is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_signal + +int main(void) +{ + + if(signal(0, 0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_signal="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_signal="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$tst_compi_signal" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if signal usage allowed" >&5 +printf %s "checking if signal usage allowed... " >&6; } + if test "x$curl_disallow_signal" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_signal="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_signal="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if signal might be used" >&5 +printf %s "checking if signal might be used... " >&6; } + if test "$tst_links_signal" = "yes" && + test "$tst_proto_signal" = "yes" && + test "$tst_compi_signal" = "yes" && + test "$tst_allow_signal" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_SIGNAL 1" >>confdefs.h + + curl_cv_func_signal="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_signal="no" + fi + + +curl_includes_setjmp="\ +/* includes start */ +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#include +/* includes end */" + ac_fn_c_check_header_compile "$LINENO" "sys/types.h" "ac_cv_header_sys_types_h" "$curl_includes_setjmp +" +if test "x$ac_cv_header_sys_types_h" = xyes +then : + printf "%s\n" "#define HAVE_SYS_TYPES_H 1" >>confdefs.h + +fi + + + + + + tst_links_sigsetjmp="unknown" + tst_macro_sigsetjmp="unknown" + tst_proto_sigsetjmp="unknown" + tst_compi_sigsetjmp="unknown" + tst_allow_sigsetjmp="unknown" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if sigsetjmp can be linked" >&5 +printf %s "checking if sigsetjmp can be linked... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#define sigsetjmp innocuous_sigsetjmp +#ifdef __STDC__ +# include +#else +# include +#endif +#undef sigsetjmp +#ifdef __cplusplus +extern "C" +#endif +char sigsetjmp (); +#if defined __stub_sigsetjmp || defined __stub___sigsetjmp +#error force compilation error +#endif + +int main(void) +{ +return sigsetjmp (); + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_links_sigsetjmp="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_links_sigsetjmp="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$tst_links_sigsetjmp" = "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if sigsetjmp seems a macro" >&5 +printf %s "checking if sigsetjmp seems a macro... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_setjmp + +int main(void) +{ + + sigjmp_buf env; + if(sigsetjmp(env, 0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_macro_sigsetjmp="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_macro_sigsetjmp="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + fi + + if test "$tst_links_sigsetjmp" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if sigsetjmp is prototyped" >&5 +printf %s "checking if sigsetjmp is prototyped... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + $curl_includes_setjmp + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "sigsetjmp" >/dev/null 2>&1 +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_proto_sigsetjmp="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_proto_sigsetjmp="no" + +fi +rm -rf conftest* + + fi + + if test "$tst_proto_sigsetjmp" = "yes" || + test "$tst_macro_sigsetjmp" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if sigsetjmp is compilable" >&5 +printf %s "checking if sigsetjmp is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_setjmp + +int main(void) +{ + + sigjmp_buf env; + if(sigsetjmp(env, 0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_sigsetjmp="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_sigsetjmp="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$tst_compi_sigsetjmp" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if sigsetjmp usage allowed" >&5 +printf %s "checking if sigsetjmp usage allowed... " >&6; } + if test "x$curl_disallow_sigsetjmp" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_sigsetjmp="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_sigsetjmp="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if sigsetjmp might be used" >&5 +printf %s "checking if sigsetjmp might be used... " >&6; } + if (test "$tst_proto_sigsetjmp" = "yes" || + test "$tst_macro_sigsetjmp" = "yes") && + test "$tst_compi_sigsetjmp" = "yes" && + test "$tst_allow_sigsetjmp" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_SIGSETJMP 1" >>confdefs.h + + curl_cv_func_sigsetjmp="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_sigsetjmp="no" + fi + + + + + + tst_links_socket="unknown" + tst_proto_socket="unknown" + tst_compi_socket="unknown" + tst_allow_socket="unknown" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if socket can be linked" >&5 +printf %s "checking if socket can be linked... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_winsock2 + $curl_includes_bsdsocket + $curl_includes_sys_socket + +int main(void) +{ + + if(socket(0, 0, 0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_links_socket="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_links_socket="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$tst_links_socket" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if socket is prototyped" >&5 +printf %s "checking if socket is prototyped... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + $curl_includes_winsock2 + $curl_includes_bsdsocket + $curl_includes_sys_socket + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "socket" >/dev/null 2>&1 +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_proto_socket="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_proto_socket="no" + +fi +rm -rf conftest* + + fi + + if test "$tst_proto_socket" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if socket is compilable" >&5 +printf %s "checking if socket is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_winsock2 + $curl_includes_bsdsocket + $curl_includes_sys_socket + +int main(void) +{ + + if(socket(0, 0, 0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_socket="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_socket="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$tst_compi_socket" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if socket usage allowed" >&5 +printf %s "checking if socket usage allowed... " >&6; } + if test "x$curl_disallow_socket" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_socket="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_socket="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if socket might be used" >&5 +printf %s "checking if socket might be used... " >&6; } + if test "$tst_links_socket" = "yes" && + test "$tst_proto_socket" = "yes" && + test "$tst_compi_socket" = "yes" && + test "$tst_allow_socket" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_SOCKET 1" >>confdefs.h + + curl_cv_func_socket="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_socket="no" + fi + + + + + tst_links_socketpair="unknown" + tst_proto_socketpair="unknown" + tst_compi_socketpair="unknown" + tst_allow_socketpair="unknown" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if socketpair can be linked" >&5 +printf %s "checking if socketpair can be linked... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#define socketpair innocuous_socketpair +#ifdef __STDC__ +# include +#else +# include +#endif +#undef socketpair +#ifdef __cplusplus +extern "C" +#endif +char socketpair (); +#if defined __stub_socketpair || defined __stub___socketpair +#error force compilation error +#endif + +int main(void) +{ +return socketpair (); + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_links_socketpair="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_links_socketpair="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$tst_links_socketpair" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if socketpair is prototyped" >&5 +printf %s "checking if socketpair is prototyped... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + $curl_includes_sys_socket + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "socketpair" >/dev/null 2>&1 +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_proto_socketpair="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_proto_socketpair="no" + +fi +rm -rf conftest* + + fi + + if test "$tst_proto_socketpair" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if socketpair is compilable" >&5 +printf %s "checking if socketpair is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_sys_socket + +int main(void) +{ + + int sv[2]; + if(socketpair(0, 0, 0, sv)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_socketpair="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_socketpair="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$tst_compi_socketpair" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if socketpair usage allowed" >&5 +printf %s "checking if socketpair usage allowed... " >&6; } + if test "x$curl_disallow_socketpair" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_socketpair="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_socketpair="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if socketpair might be used" >&5 +printf %s "checking if socketpair might be used... " >&6; } + if test "$tst_links_socketpair" = "yes" && + test "$tst_proto_socketpair" = "yes" && + test "$tst_compi_socketpair" = "yes" && + test "$tst_allow_socketpair" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_SOCKETPAIR 1" >>confdefs.h + + curl_cv_func_socketpair="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_socketpair="no" + fi + + + + + + tst_links_strerror_r="unknown" + tst_proto_strerror_r="unknown" + tst_compi_strerror_r="unknown" + tst_glibc_strerror_r="unknown" + tst_posix_strerror_r="unknown" + tst_allow_strerror_r="unknown" + tst_works_glibc_strerror_r="unknown" + tst_works_posix_strerror_r="unknown" + tst_glibc_strerror_r_type_arg3="unknown" + tst_posix_strerror_r_type_arg3="unknown" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if strerror_r can be linked" >&5 +printf %s "checking if strerror_r can be linked... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#define strerror_r innocuous_strerror_r +#ifdef __STDC__ +# include +#else +# include +#endif +#undef strerror_r +#ifdef __cplusplus +extern "C" +#endif +char strerror_r (); +#if defined __stub_strerror_r || defined __stub___strerror_r +#error force compilation error +#endif + +int main(void) +{ +return strerror_r (); + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_links_strerror_r="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_links_strerror_r="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$tst_links_strerror_r" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if strerror_r is prototyped" >&5 +printf %s "checking if strerror_r is prototyped... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + $curl_includes_string + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "strerror_r" >/dev/null 2>&1 +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_proto_strerror_r="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_proto_strerror_r="no" + +fi +rm -rf conftest* + + fi + + if test "$tst_proto_strerror_r" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if strerror_r is compilable" >&5 +printf %s "checking if strerror_r is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_string + +int main(void) +{ + + char s[1]; + if(strerror_r(0, s, 0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_strerror_r="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_strerror_r="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$tst_compi_strerror_r" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if strerror_r is glibc like" >&5 +printf %s "checking if strerror_r is glibc like... " >&6; } + tst_glibc_strerror_r_type_arg3="unknown" + for arg3 in 'size_t' 'int' 'unsigned int'; do + if test "$tst_glibc_strerror_r_type_arg3" = "unknown"; then + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_string + char *strerror_r(int errnum, char *workbuf, $arg3 bufsize); + +int main(void) +{ + + char s[1]; + if(strerror_r(0, s, 0)) + return 1; + (void)s; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + tst_glibc_strerror_r_type_arg3="$arg3" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + done + case "$tst_glibc_strerror_r_type_arg3" in + unknown) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_glibc_strerror_r="no" + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_glibc_strerror_r="yes" + ;; + esac + fi + + if test "$cross_compiling" != "yes" && + test "$tst_glibc_strerror_r" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if strerror_r seems to work" >&5 +printf %s "checking if strerror_r seems to work... " >&6; } + + if test "$curl_cv_apple" = "yes"; then + if test "$cross_compiling" = yes +then : + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_stdlib + $curl_includes_string + #include + +int main(void) +{ + + char buffer[1024]; + char *string = 0; + buffer[0] = '\0'; + string = strerror_r(EACCES, buffer, sizeof(buffer)); + if(!string) + return 1; /* fail */ + if(!string[0]) + return 1; /* fail */ + else + return 0; + + return 0; +} + +_ACEOF +if ac_fn_c_try_run "$LINENO" +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_works_glibc_strerror_r="yes" + +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_works_glibc_strerror_r="no" + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + else + oldcc=$CC + old=$LD_LIBRARY_PATH + CC="sh ./run-compiler" + LD_LIBRARY_PATH=$CURL_LIBRARY_PATH:$old + export LD_LIBRARY_PATH + if test "$cross_compiling" = yes +then : + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_stdlib + $curl_includes_string + #include + +int main(void) +{ + + char buffer[1024]; + char *string = 0; + buffer[0] = '\0'; + string = strerror_r(EACCES, buffer, sizeof(buffer)); + if(!string) + return 1; /* fail */ + if(!string[0]) + return 1; /* fail */ + else + return 0; + + return 0; +} + +_ACEOF +if ac_fn_c_try_run "$LINENO" +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_works_glibc_strerror_r="yes" + +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_works_glibc_strerror_r="no" + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + # restore + LD_LIBRARY_PATH=$old + CC=$oldcc + fi + + fi + + if test "$tst_compi_strerror_r" = "yes" && + test "$tst_works_glibc_strerror_r" != "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if strerror_r is POSIX like" >&5 +printf %s "checking if strerror_r is POSIX like... " >&6; } + tst_posix_strerror_r_type_arg3="unknown" + for arg3 in 'size_t' 'int' 'unsigned int'; do + if test "$tst_posix_strerror_r_type_arg3" = "unknown"; then + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_string + int strerror_r(int errnum, char *resultbuf, $arg3 bufsize); + +int main(void) +{ + + char s[1]; + if(strerror_r(0, s, 0)) + return 1; + (void)s; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + tst_posix_strerror_r_type_arg3="$arg3" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + done + case "$tst_posix_strerror_r_type_arg3" in + unknown) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_posix_strerror_r="no" + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_posix_strerror_r="yes" + ;; + esac + fi + + if test "$cross_compiling" != "yes" && + test "$tst_posix_strerror_r" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if strerror_r seems to work" >&5 +printf %s "checking if strerror_r seems to work... " >&6; } + + if test "$curl_cv_apple" = "yes"; then + if test "$cross_compiling" = yes +then : + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_stdlib + $curl_includes_string + #include + +int main(void) +{ + + char buffer[1024]; + int error = 1; + buffer[0] = '\0'; + error = strerror_r(EACCES, buffer, sizeof(buffer)); + if(error) + return 1; /* fail */ + if(buffer[0] == '\0') + return 1; /* fail */ + else + return 0; + + return 0; +} + +_ACEOF +if ac_fn_c_try_run "$LINENO" +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_works_posix_strerror_r="yes" + +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_works_posix_strerror_r="no" + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + else + oldcc=$CC + old=$LD_LIBRARY_PATH + CC="sh ./run-compiler" + LD_LIBRARY_PATH=$CURL_LIBRARY_PATH:$old + export LD_LIBRARY_PATH + if test "$cross_compiling" = yes +then : + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_stdlib + $curl_includes_string + #include + +int main(void) +{ + + char buffer[1024]; + int error = 1; + buffer[0] = '\0'; + error = strerror_r(EACCES, buffer, sizeof(buffer)); + if(error) + return 1; /* fail */ + if(buffer[0] == '\0') + return 1; /* fail */ + else + return 0; + + return 0; +} + +_ACEOF +if ac_fn_c_try_run "$LINENO" +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_works_posix_strerror_r="yes" + +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_works_posix_strerror_r="no" + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + # restore + LD_LIBRARY_PATH=$old + CC=$oldcc + fi + + fi + + if test "$tst_works_glibc_strerror_r" = "yes"; then + tst_posix_strerror_r="no" + fi + if test "$tst_works_posix_strerror_r" = "yes"; then + tst_glibc_strerror_r="no" + fi + if test "$tst_glibc_strerror_r" = "yes" && + test "$tst_works_glibc_strerror_r" != "no" && + test "$tst_posix_strerror_r" != "yes"; then + tst_allow_strerror_r="check" + fi + if test "$tst_posix_strerror_r" = "yes" && + test "$tst_works_posix_strerror_r" != "no" && + test "$tst_glibc_strerror_r" != "yes"; then + tst_allow_strerror_r="check" + fi + if test "$tst_allow_strerror_r" = "check"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if strerror_r usage allowed" >&5 +printf %s "checking if strerror_r usage allowed... " >&6; } + if test "x$curl_disallow_strerror_r" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_strerror_r="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_strerror_r="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if strerror_r might be used" >&5 +printf %s "checking if strerror_r might be used... " >&6; } + if test "$tst_links_strerror_r" = "yes" && + test "$tst_proto_strerror_r" = "yes" && + test "$tst_compi_strerror_r" = "yes" && + test "$tst_allow_strerror_r" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + if test "$tst_glibc_strerror_r" = "yes"; then + +printf "%s\n" "#define HAVE_STRERROR_R 1" >>confdefs.h + + +printf "%s\n" "#define HAVE_GLIBC_STRERROR_R 1" >>confdefs.h + + fi + if test "$tst_posix_strerror_r" = "yes"; then + +printf "%s\n" "#define HAVE_STRERROR_R 1" >>confdefs.h + + +printf "%s\n" "#define HAVE_POSIX_STRERROR_R 1" >>confdefs.h + + fi + curl_cv_func_strerror_r="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_strerror_r="no" + fi + + if test "$tst_compi_strerror_r" = "yes" && + test "$tst_allow_strerror_r" = "unknown"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: cannot determine strerror_r() style: edit lib/curl_config.h manually." >&5 +printf "%s\n" "$as_me: WARNING: cannot determine strerror_r() style: edit lib/curl_config.h manually." >&2;} + fi + + +case $host in + *msdosdjgpp) + ac_cv_func_pipe=no + skipcheck_pipe=yes + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: skip check for pipe on msdosdjgpp" >&5 +printf "%s\n" "$as_me: skip check for pipe on msdosdjgpp" >&6;} + ;; +esac + +ac_fn_c_check_func "$LINENO" "accept4" "ac_cv_func_accept4" +if test "x$ac_cv_func_accept4" = xyes +then : + printf "%s\n" "#define HAVE_ACCEPT4 1" >>confdefs.h + +fi +ac_fn_c_check_func "$LINENO" "eventfd" "ac_cv_func_eventfd" +if test "x$ac_cv_func_eventfd" = xyes +then : + printf "%s\n" "#define HAVE_EVENTFD 1" >>confdefs.h + +fi +ac_fn_c_check_func "$LINENO" "fnmatch" "ac_cv_func_fnmatch" +if test "x$ac_cv_func_fnmatch" = xyes +then : + printf "%s\n" "#define HAVE_FNMATCH 1" >>confdefs.h + +fi +ac_fn_c_check_func "$LINENO" "geteuid" "ac_cv_func_geteuid" +if test "x$ac_cv_func_geteuid" = xyes +then : + printf "%s\n" "#define HAVE_GETEUID 1" >>confdefs.h + +fi +ac_fn_c_check_func "$LINENO" "getpass_r" "ac_cv_func_getpass_r" +if test "x$ac_cv_func_getpass_r" = xyes +then : + printf "%s\n" "#define HAVE_GETPASS_R 1" >>confdefs.h + +fi +ac_fn_c_check_func "$LINENO" "getppid" "ac_cv_func_getppid" +if test "x$ac_cv_func_getppid" = xyes +then : + printf "%s\n" "#define HAVE_GETPPID 1" >>confdefs.h + +fi +ac_fn_c_check_func "$LINENO" "getpwuid" "ac_cv_func_getpwuid" +if test "x$ac_cv_func_getpwuid" = xyes +then : + printf "%s\n" "#define HAVE_GETPWUID 1" >>confdefs.h + +fi +ac_fn_c_check_func "$LINENO" "getpwuid_r" "ac_cv_func_getpwuid_r" +if test "x$ac_cv_func_getpwuid_r" = xyes +then : + printf "%s\n" "#define HAVE_GETPWUID_R 1" >>confdefs.h + +fi +ac_fn_c_check_func "$LINENO" "getrlimit" "ac_cv_func_getrlimit" +if test "x$ac_cv_func_getrlimit" = xyes +then : + printf "%s\n" "#define HAVE_GETRLIMIT 1" >>confdefs.h + +fi +ac_fn_c_check_func "$LINENO" "gettimeofday" "ac_cv_func_gettimeofday" +if test "x$ac_cv_func_gettimeofday" = xyes +then : + printf "%s\n" "#define HAVE_GETTIMEOFDAY 1" >>confdefs.h + +fi +ac_fn_c_check_func "$LINENO" "mach_absolute_time" "ac_cv_func_mach_absolute_time" +if test "x$ac_cv_func_mach_absolute_time" = xyes +then : + printf "%s\n" "#define HAVE_MACH_ABSOLUTE_TIME 1" >>confdefs.h + +fi +ac_fn_c_check_func "$LINENO" "pipe" "ac_cv_func_pipe" +if test "x$ac_cv_func_pipe" = xyes +then : + printf "%s\n" "#define HAVE_PIPE 1" >>confdefs.h + +fi +ac_fn_c_check_func "$LINENO" "poll" "ac_cv_func_poll" +if test "x$ac_cv_func_poll" = xyes +then : + printf "%s\n" "#define HAVE_POLL 1" >>confdefs.h + +fi +ac_fn_c_check_func "$LINENO" "sendmmsg" "ac_cv_func_sendmmsg" +if test "x$ac_cv_func_sendmmsg" = xyes +then : + printf "%s\n" "#define HAVE_SENDMMSG 1" >>confdefs.h + +fi +ac_fn_c_check_func "$LINENO" "sendmsg" "ac_cv_func_sendmsg" +if test "x$ac_cv_func_sendmsg" = xyes +then : + printf "%s\n" "#define HAVE_SENDMSG 1" >>confdefs.h + +fi +ac_fn_c_check_func "$LINENO" "setlocale" "ac_cv_func_setlocale" +if test "x$ac_cv_func_setlocale" = xyes +then : + printf "%s\n" "#define HAVE_SETLOCALE 1" >>confdefs.h + +fi +ac_fn_c_check_func "$LINENO" "setrlimit" "ac_cv_func_setrlimit" +if test "x$ac_cv_func_setrlimit" = xyes +then : + printf "%s\n" "#define HAVE_SETRLIMIT 1" >>confdefs.h + +fi +ac_fn_c_check_func "$LINENO" "utime" "ac_cv_func_utime" +if test "x$ac_cv_func_utime" = xyes +then : + printf "%s\n" "#define HAVE_UTIME 1" >>confdefs.h + +fi +ac_fn_c_check_func "$LINENO" "utimes" "ac_cv_func_utimes" +if test "x$ac_cv_func_utimes" = xyes +then : + printf "%s\n" "#define HAVE_UTIMES 1" >>confdefs.h + +fi + + +if test "$curl_cv_apple" != "yes"; then + ac_fn_c_check_func "$LINENO" "pipe2" "ac_cv_func_pipe2" +if test "x$ac_cv_func_pipe2" = xyes +then : + printf "%s\n" "#define HAVE_PIPE2 1" >>confdefs.h + +fi + +fi + +if test "$curl_cv_native_windows" != "yes"; then + ac_fn_c_check_func "$LINENO" "if_nametoindex" "ac_cv_func_if_nametoindex" +if test "x$ac_cv_func_if_nametoindex" = xyes +then : + printf "%s\n" "#define HAVE_IF_NAMETOINDEX 1" >>confdefs.h + +fi +ac_fn_c_check_func "$LINENO" "realpath" "ac_cv_func_realpath" +if test "x$ac_cv_func_realpath" = xyes +then : + printf "%s\n" "#define HAVE_REALPATH 1" >>confdefs.h + +fi +ac_fn_c_check_func "$LINENO" "sched_yield" "ac_cv_func_sched_yield" +if test "x$ac_cv_func_sched_yield" = xyes +then : + printf "%s\n" "#define HAVE_SCHED_YIELD 1" >>confdefs.h + +fi + + +curl_includes_arpa_inet="\ +/* includes start */ +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifdef HAVE_NETINET_IN_H +# include +#endif +#ifdef HAVE_ARPA_INET_H +# include +#endif +#ifdef _WIN32 +#include +#include +#else +#include +#endif +/* includes end */" + ac_fn_c_check_header_compile "$LINENO" "sys/types.h" "ac_cv_header_sys_types_h" "$curl_includes_arpa_inet +" +if test "x$ac_cv_header_sys_types_h" = xyes +then : + printf "%s\n" "#define HAVE_SYS_TYPES_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "netinet/in.h" "ac_cv_header_netinet_in_h" "$curl_includes_arpa_inet +" +if test "x$ac_cv_header_netinet_in_h" = xyes +then : + printf "%s\n" "#define HAVE_NETINET_IN_H 1" >>confdefs.h + +fi +ac_fn_c_check_header_compile "$LINENO" "arpa/inet.h" "ac_cv_header_arpa_inet_h" "$curl_includes_arpa_inet +" +if test "x$ac_cv_header_arpa_inet_h" = xyes +then : + printf "%s\n" "#define HAVE_ARPA_INET_H 1" >>confdefs.h + +fi + + + + + + + + tst_links_inet_ntop="unknown" + tst_proto_inet_ntop="unknown" + tst_compi_inet_ntop="unknown" + tst_works_inet_ntop="unknown" + tst_allow_inet_ntop="unknown" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if inet_ntop can be linked" >&5 +printf %s "checking if inet_ntop can be linked... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#define inet_ntop innocuous_inet_ntop +#ifdef __STDC__ +# include +#else +# include +#endif +#undef inet_ntop +#ifdef __cplusplus +extern "C" +#endif +char inet_ntop (); +#if defined __stub_inet_ntop || defined __stub___inet_ntop +#error force compilation error +#endif + +int main(void) +{ +return inet_ntop (); + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_links_inet_ntop="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_links_inet_ntop="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$tst_links_inet_ntop" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if inet_ntop is prototyped" >&5 +printf %s "checking if inet_ntop is prototyped... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + $curl_includes_arpa_inet + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "inet_ntop" >/dev/null 2>&1 +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_proto_inet_ntop="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_proto_inet_ntop="no" + +fi +rm -rf conftest* + + fi + + if test "$tst_proto_inet_ntop" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if inet_ntop is compilable" >&5 +printf %s "checking if inet_ntop is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_arpa_inet + +int main(void) +{ + + char ipv4res[sizeof("255.255.255.255")]; + unsigned char ipv4a[5] = ""; + if(inet_ntop(0, ipv4a, ipv4res, 0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_inet_ntop="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_inet_ntop="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$cross_compiling" != "yes" && + test "$tst_compi_inet_ntop" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if inet_ntop seems to work" >&5 +printf %s "checking if inet_ntop seems to work... " >&6; } + + if test "$curl_cv_apple" = "yes"; then + if test "$cross_compiling" = yes +then : + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_stdlib + $curl_includes_arpa_inet + $curl_includes_string + +int main(void) +{ + + char ipv6res[sizeof("ffff:ffff:ffff:ffff:ffff:ffff:255.255.255.255")]; + char ipv4res[sizeof("255.255.255.255")]; + unsigned char ipv6a[26]; + unsigned char ipv4a[5]; + const char *ipv6ptr = 0; + const char *ipv4ptr = 0; + /* - */ + ipv4res[0] = '\0'; + ipv4a[0] = 0xc0; + ipv4a[1] = 0xa8; + ipv4a[2] = 0x64; + ipv4a[3] = 0x01; + ipv4a[4] = 0x01; + /* - */ + ipv4ptr = inet_ntop(AF_INET, ipv4a, ipv4res, sizeof(ipv4res)); + if(!ipv4ptr) + return 1; /* fail */ + if(ipv4ptr != ipv4res) + return 1; /* fail */ + if(!ipv4ptr[0]) + return 1; /* fail */ + if(memcmp(ipv4res, "192.168.100.1", 13)) + return 1; /* fail */ + /* - */ + ipv6res[0] = '\0'; + memset(ipv6a, 0, sizeof(ipv6a)); + ipv6a[0] = 0xfe; + ipv6a[1] = 0x80; + ipv6a[8] = 0x02; + ipv6a[9] = 0x14; + ipv6a[10] = 0x4f; + ipv6a[11] = 0xff; + ipv6a[12] = 0xfe; + ipv6a[13] = 0x0b; + ipv6a[14] = 0x76; + ipv6a[15] = 0xc8; + ipv6a[25] = 0x01; + /* - */ + ipv6ptr = inet_ntop(AF_INET6, ipv6a, ipv6res, sizeof(ipv6res)); + if(!ipv6ptr) + return 1; /* fail */ + if(ipv6ptr != ipv6res) + return 1; /* fail */ + if(!ipv6ptr[0]) + return 1; /* fail */ + if(memcmp(ipv6res, "fe80::214:4fff:fe0b:76c8", 24)) + return 1; /* fail */ + /* - */ + return 0; + + return 0; +} + +_ACEOF +if ac_fn_c_try_run "$LINENO" +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_works_inet_ntop="yes" + +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_works_inet_ntop="no" + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + else + oldcc=$CC + old=$LD_LIBRARY_PATH + CC="sh ./run-compiler" + LD_LIBRARY_PATH=$CURL_LIBRARY_PATH:$old + export LD_LIBRARY_PATH + if test "$cross_compiling" = yes +then : + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_stdlib + $curl_includes_arpa_inet + $curl_includes_string + +int main(void) +{ + + char ipv6res[sizeof("ffff:ffff:ffff:ffff:ffff:ffff:255.255.255.255")]; + char ipv4res[sizeof("255.255.255.255")]; + unsigned char ipv6a[26]; + unsigned char ipv4a[5]; + const char *ipv6ptr = 0; + const char *ipv4ptr = 0; + /* - */ + ipv4res[0] = '\0'; + ipv4a[0] = 0xc0; + ipv4a[1] = 0xa8; + ipv4a[2] = 0x64; + ipv4a[3] = 0x01; + ipv4a[4] = 0x01; + /* - */ + ipv4ptr = inet_ntop(AF_INET, ipv4a, ipv4res, sizeof(ipv4res)); + if(!ipv4ptr) + return 1; /* fail */ + if(ipv4ptr != ipv4res) + return 1; /* fail */ + if(!ipv4ptr[0]) + return 1; /* fail */ + if(memcmp(ipv4res, "192.168.100.1", 13)) + return 1; /* fail */ + /* - */ + ipv6res[0] = '\0'; + memset(ipv6a, 0, sizeof(ipv6a)); + ipv6a[0] = 0xfe; + ipv6a[1] = 0x80; + ipv6a[8] = 0x02; + ipv6a[9] = 0x14; + ipv6a[10] = 0x4f; + ipv6a[11] = 0xff; + ipv6a[12] = 0xfe; + ipv6a[13] = 0x0b; + ipv6a[14] = 0x76; + ipv6a[15] = 0xc8; + ipv6a[25] = 0x01; + /* - */ + ipv6ptr = inet_ntop(AF_INET6, ipv6a, ipv6res, sizeof(ipv6res)); + if(!ipv6ptr) + return 1; /* fail */ + if(ipv6ptr != ipv6res) + return 1; /* fail */ + if(!ipv6ptr[0]) + return 1; /* fail */ + if(memcmp(ipv6res, "fe80::214:4fff:fe0b:76c8", 24)) + return 1; /* fail */ + /* - */ + return 0; + + return 0; +} + +_ACEOF +if ac_fn_c_try_run "$LINENO" +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_works_inet_ntop="yes" + +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_works_inet_ntop="no" + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + # restore + LD_LIBRARY_PATH=$old + CC=$oldcc + fi + + fi + + if test "$tst_compi_inet_ntop" = "yes" && + test "$tst_works_inet_ntop" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if inet_ntop usage allowed" >&5 +printf %s "checking if inet_ntop usage allowed... " >&6; } + if test "x$curl_disallow_inet_ntop" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_inet_ntop="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_inet_ntop="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if inet_ntop might be used" >&5 +printf %s "checking if inet_ntop might be used... " >&6; } + if test "$tst_links_inet_ntop" = "yes" && + test "$tst_proto_inet_ntop" = "yes" && + test "$tst_compi_inet_ntop" = "yes" && + test "$tst_allow_inet_ntop" = "yes" && + test "$tst_works_inet_ntop" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_INET_NTOP 1" >>confdefs.h + + curl_cv_func_inet_ntop="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_inet_ntop="no" + fi + + + + + + + tst_links_inet_pton="unknown" + tst_proto_inet_pton="unknown" + tst_compi_inet_pton="unknown" + tst_works_inet_pton="unknown" + tst_allow_inet_pton="unknown" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if inet_pton can be linked" >&5 +printf %s "checking if inet_pton can be linked... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#define inet_pton innocuous_inet_pton +#ifdef __STDC__ +# include +#else +# include +#endif +#undef inet_pton +#ifdef __cplusplus +extern "C" +#endif +char inet_pton (); +#if defined __stub_inet_pton || defined __stub___inet_pton +#error force compilation error +#endif + +int main(void) +{ +return inet_pton (); + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_links_inet_pton="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_links_inet_pton="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$tst_links_inet_pton" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if inet_pton is prototyped" >&5 +printf %s "checking if inet_pton is prototyped... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + $curl_includes_arpa_inet + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "inet_pton" >/dev/null 2>&1 +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_proto_inet_pton="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_proto_inet_pton="no" + +fi +rm -rf conftest* + + fi + + if test "$tst_proto_inet_pton" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if inet_pton is compilable" >&5 +printf %s "checking if inet_pton is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_arpa_inet + +int main(void) +{ + + unsigned char ipv4a[4 + 1] = ""; + const char *ipv4src = "192.168.100.1"; + if(inet_pton(0, ipv4src, ipv4a)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_inet_pton="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_inet_pton="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$cross_compiling" != "yes" && + test "$tst_compi_inet_pton" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if inet_pton seems to work" >&5 +printf %s "checking if inet_pton seems to work... " >&6; } + + if test "$curl_cv_apple" = "yes"; then + if test "$cross_compiling" = yes +then : + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_stdlib + $curl_includes_arpa_inet + $curl_includes_string + +int main(void) +{ + + unsigned char ipv6a[16 + 1]; + unsigned char ipv4a[4 + 1]; + const char *ipv6src = "fe80::214:4fff:fe0b:76c8"; + const char *ipv4src = "192.168.100.1"; + /* - */ + memset(ipv4a, 1, sizeof(ipv4a)); + if(inet_pton(AF_INET, ipv4src, ipv4a) != 1) + return 1; /* fail */ + /* - */ + if((ipv4a[0] != 0xc0) || + (ipv4a[1] != 0xa8) || + (ipv4a[2] != 0x64) || + (ipv4a[3] != 0x01) || + (ipv4a[4] != 0x01)) + return 1; /* fail */ + /* - */ + memset(ipv6a, 1, sizeof(ipv6a)); + if(inet_pton(AF_INET6, ipv6src, ipv6a) != 1) + return 1; /* fail */ + /* - */ + if((ipv6a[0] != 0xfe) || + (ipv6a[1] != 0x80) || + (ipv6a[8] != 0x02) || + (ipv6a[9] != 0x14) || + (ipv6a[10] != 0x4f) || + (ipv6a[11] != 0xff) || + (ipv6a[12] != 0xfe) || + (ipv6a[13] != 0x0b) || + (ipv6a[14] != 0x76) || + (ipv6a[15] != 0xc8) || + (ipv6a[16] != 0x01)) + return 1; /* fail */ + /* - */ + if((ipv6a[2] != 0x0) || + (ipv6a[3] != 0x0) || + (ipv6a[4] != 0x0) || + (ipv6a[5] != 0x0) || + (ipv6a[6] != 0x0) || + (ipv6a[7] != 0x0)) + return 1; /* fail */ + /* - */ + return 0; + + return 0; +} + +_ACEOF +if ac_fn_c_try_run "$LINENO" +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_works_inet_pton="yes" + +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_works_inet_pton="no" + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + else + oldcc=$CC + old=$LD_LIBRARY_PATH + CC="sh ./run-compiler" + LD_LIBRARY_PATH=$CURL_LIBRARY_PATH:$old + export LD_LIBRARY_PATH + if test "$cross_compiling" = yes +then : + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_stdlib + $curl_includes_arpa_inet + $curl_includes_string + +int main(void) +{ + + unsigned char ipv6a[16 + 1]; + unsigned char ipv4a[4 + 1]; + const char *ipv6src = "fe80::214:4fff:fe0b:76c8"; + const char *ipv4src = "192.168.100.1"; + /* - */ + memset(ipv4a, 1, sizeof(ipv4a)); + if(inet_pton(AF_INET, ipv4src, ipv4a) != 1) + return 1; /* fail */ + /* - */ + if((ipv4a[0] != 0xc0) || + (ipv4a[1] != 0xa8) || + (ipv4a[2] != 0x64) || + (ipv4a[3] != 0x01) || + (ipv4a[4] != 0x01)) + return 1; /* fail */ + /* - */ + memset(ipv6a, 1, sizeof(ipv6a)); + if(inet_pton(AF_INET6, ipv6src, ipv6a) != 1) + return 1; /* fail */ + /* - */ + if((ipv6a[0] != 0xfe) || + (ipv6a[1] != 0x80) || + (ipv6a[8] != 0x02) || + (ipv6a[9] != 0x14) || + (ipv6a[10] != 0x4f) || + (ipv6a[11] != 0xff) || + (ipv6a[12] != 0xfe) || + (ipv6a[13] != 0x0b) || + (ipv6a[14] != 0x76) || + (ipv6a[15] != 0xc8) || + (ipv6a[16] != 0x01)) + return 1; /* fail */ + /* - */ + if((ipv6a[2] != 0x0) || + (ipv6a[3] != 0x0) || + (ipv6a[4] != 0x0) || + (ipv6a[5] != 0x0) || + (ipv6a[6] != 0x0) || + (ipv6a[7] != 0x0)) + return 1; /* fail */ + /* - */ + return 0; + + return 0; +} + +_ACEOF +if ac_fn_c_try_run "$LINENO" +then : + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_works_inet_pton="yes" + +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_works_inet_pton="no" + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + # restore + LD_LIBRARY_PATH=$old + CC=$oldcc + fi + + fi + + if test "$tst_compi_inet_pton" = "yes" && + test "$tst_works_inet_pton" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if inet_pton usage allowed" >&5 +printf %s "checking if inet_pton usage allowed... " >&6; } + if test "x$curl_disallow_inet_pton" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_inet_pton="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_inet_pton="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if inet_pton might be used" >&5 +printf %s "checking if inet_pton might be used... " >&6; } + if test "$tst_links_inet_pton" = "yes" && + test "$tst_proto_inet_pton" = "yes" && + test "$tst_compi_inet_pton" = "yes" && + test "$tst_allow_inet_pton" = "yes" && + test "$tst_works_inet_pton" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_INET_PTON 1" >>confdefs.h + + curl_cv_func_inet_pton="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_inet_pton="no" + fi + + + + + tst_links_strcasecmp="unknown" + tst_proto_strcasecmp="unknown" + tst_compi_strcasecmp="unknown" + tst_allow_strcasecmp="unknown" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if strcasecmp can be linked" >&5 +printf %s "checking if strcasecmp can be linked... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#define strcasecmp innocuous_strcasecmp +#ifdef __STDC__ +# include +#else +# include +#endif +#undef strcasecmp +#ifdef __cplusplus +extern "C" +#endif +char strcasecmp (); +#if defined __stub_strcasecmp || defined __stub___strcasecmp +#error force compilation error +#endif + +int main(void) +{ +return strcasecmp (); + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_links_strcasecmp="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_links_strcasecmp="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$tst_links_strcasecmp" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if strcasecmp is prototyped" >&5 +printf %s "checking if strcasecmp is prototyped... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + $curl_includes_string + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "strcasecmp" >/dev/null 2>&1 +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_proto_strcasecmp="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_proto_strcasecmp="no" + +fi +rm -rf conftest* + + fi + + if test "$tst_proto_strcasecmp" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if strcasecmp is compilable" >&5 +printf %s "checking if strcasecmp is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_string + +int main(void) +{ + + if(strcasecmp("", "")) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_strcasecmp="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_strcasecmp="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$tst_compi_strcasecmp" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if strcasecmp usage allowed" >&5 +printf %s "checking if strcasecmp usage allowed... " >&6; } + if test "x$curl_disallow_strcasecmp" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_strcasecmp="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_strcasecmp="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if strcasecmp might be used" >&5 +printf %s "checking if strcasecmp might be used... " >&6; } + if test "$tst_links_strcasecmp" = "yes" && + test "$tst_proto_strcasecmp" = "yes" && + test "$tst_compi_strcasecmp" = "yes" && + test "$tst_allow_strcasecmp" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_STRCASECMP 1" >>confdefs.h + + curl_cv_func_strcasecmp="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_strcasecmp="no" + fi + + + + + tst_links_strcmpi="unknown" + tst_proto_strcmpi="unknown" + tst_compi_strcmpi="unknown" + tst_allow_strcmpi="unknown" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if strcmpi can be linked" >&5 +printf %s "checking if strcmpi can be linked... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#define strcmpi innocuous_strcmpi +#ifdef __STDC__ +# include +#else +# include +#endif +#undef strcmpi +#ifdef __cplusplus +extern "C" +#endif +char strcmpi (); +#if defined __stub_strcmpi || defined __stub___strcmpi +#error force compilation error +#endif + +int main(void) +{ +return strcmpi (); + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_links_strcmpi="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_links_strcmpi="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$tst_links_strcmpi" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if strcmpi is prototyped" >&5 +printf %s "checking if strcmpi is prototyped... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + $curl_includes_string + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "strcmpi" >/dev/null 2>&1 +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_proto_strcmpi="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_proto_strcmpi="no" + +fi +rm -rf conftest* + + fi + + if test "$tst_proto_strcmpi" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if strcmpi is compilable" >&5 +printf %s "checking if strcmpi is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_string + +int main(void) +{ + + if(strcmpi(0, 0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_strcmpi="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_strcmpi="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$tst_compi_strcmpi" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if strcmpi usage allowed" >&5 +printf %s "checking if strcmpi usage allowed... " >&6; } + if test "x$curl_disallow_strcmpi" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_strcmpi="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_strcmpi="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if strcmpi might be used" >&5 +printf %s "checking if strcmpi might be used... " >&6; } + if test "$tst_links_strcmpi" = "yes" && + test "$tst_proto_strcmpi" = "yes" && + test "$tst_compi_strcmpi" = "yes" && + test "$tst_allow_strcmpi" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_STRCMPI 1" >>confdefs.h + + curl_cv_func_strcmpi="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_strcmpi="no" + fi + + + + + tst_links_stricmp="unknown" + tst_proto_stricmp="unknown" + tst_compi_stricmp="unknown" + tst_allow_stricmp="unknown" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if stricmp can be linked" >&5 +printf %s "checking if stricmp can be linked... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#define stricmp innocuous_stricmp +#ifdef __STDC__ +# include +#else +# include +#endif +#undef stricmp +#ifdef __cplusplus +extern "C" +#endif +char stricmp (); +#if defined __stub_stricmp || defined __stub___stricmp +#error force compilation error +#endif + +int main(void) +{ +return stricmp (); + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_links_stricmp="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_links_stricmp="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$tst_links_stricmp" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if stricmp is prototyped" >&5 +printf %s "checking if stricmp is prototyped... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + $curl_includes_string + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "stricmp" >/dev/null 2>&1 +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_proto_stricmp="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_proto_stricmp="no" + +fi +rm -rf conftest* + + fi + + if test "$tst_proto_stricmp" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if stricmp is compilable" >&5 +printf %s "checking if stricmp is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_string + +int main(void) +{ + + if(stricmp(0, 0)) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_stricmp="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_stricmp="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$tst_compi_stricmp" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if stricmp usage allowed" >&5 +printf %s "checking if stricmp usage allowed... " >&6; } + if test "x$curl_disallow_stricmp" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_stricmp="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_stricmp="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if stricmp might be used" >&5 +printf %s "checking if stricmp might be used... " >&6; } + if test "$tst_links_stricmp" = "yes" && + test "$tst_proto_stricmp" = "yes" && + test "$tst_compi_stricmp" = "yes" && + test "$tst_allow_stricmp" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_STRICMP 1" >>confdefs.h + + curl_cv_func_stricmp="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_stricmp="no" + fi + + + + + + tst_links_memset_s="unknown" + tst_proto_memset_s="unknown" + tst_compi_memset_s="unknown" + tst_allow_memset_s="unknown" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if memset_s can be linked" >&5 +printf %s "checking if memset_s can be linked... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#define memset_s innocuous_memset_s +#ifdef __STDC__ +# include +#else +# include +#endif +#undef memset_s +#ifdef __cplusplus +extern "C" +#endif +char memset_s (); +#if defined __stub_memset_s || defined __stub___memset_s +#error force compilation error +#endif + +int main(void) +{ +return memset_s (); + return 0; +} + +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_links_memset_s="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_links_memset_s="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + + if test "$tst_links_memset_s" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if memset_s is prototyped" >&5 +printf %s "checking if memset_s is prototyped... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + $curl_includes_string + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "memset_s" >/dev/null 2>&1 +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_proto_memset_s="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_proto_memset_s="no" + +fi +rm -rf conftest* + + fi + + if test "$tst_proto_memset_s" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if memset_s is compilable" >&5 +printf %s "checking if memset_s is compilable... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + $curl_includes_string + +int main(void) +{ + + char buf[2]; + if(memset_s(buf, sizeof(buf), 0, sizeof(buf))) + return 1; + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_compi_memset_s="yes" + +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_compi_memset_s="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + fi + + if test "$tst_compi_memset_s" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if memset_s usage allowed" >&5 +printf %s "checking if memset_s usage allowed... " >&6; } + if test "x$curl_disallow_memset_s" != "xyes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tst_allow_memset_s="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + tst_allow_memset_s="no" + fi + fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if memset_s might be used" >&5 +printf %s "checking if memset_s might be used... " >&6; } + if test "$tst_links_memset_s" = "yes" && + test "$tst_proto_memset_s" = "yes" && + test "$tst_compi_memset_s" = "yes" && + test "$tst_allow_memset_s" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define HAVE_MEMSET_S 1" >>confdefs.h + + curl_cv_func_memset_s="yes" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_cv_func_memset_s="no" + fi + + if test "$curl_cv_func_memset_s" = "no"; then + ac_fn_c_check_func "$LINENO" "memset_explicit" "ac_cv_func_memset_explicit" +if test "x$ac_cv_func_memset_explicit" = xyes +then : + printf "%s\n" "#define HAVE_MEMSET_EXPLICIT 1" >>confdefs.h + +fi + + fi +fi + +if test -z "$ssl_backends"; then + ac_fn_c_check_func "$LINENO" "arc4random" "ac_cv_func_arc4random" +if test "x$ac_cv_func_arc4random" = xyes +then : + printf "%s\n" "#define HAVE_ARC4RANDOM 1" >>confdefs.h + +fi + +fi + +if test "$curl_cv_native_windows" != "yes"; then + ac_fn_c_check_func "$LINENO" "fseeko" "ac_cv_func_fseeko" +if test "x$ac_cv_func_fseeko" = xyes +then : + printf "%s\n" "#define HAVE_FSEEKO 1" >>confdefs.h + +fi + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC options needed to detect all undeclared functions" >&5 +printf %s "checking for $CC options needed to detect all undeclared functions... " >&6; } +if test ${ac_cv_c_undeclared_builtin_options+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_save_CFLAGS=$CFLAGS + ac_cv_c_undeclared_builtin_options='cannot detect' + for ac_arg in '' -fno-builtin; do + CFLAGS="$ac_save_CFLAGS $ac_arg" + # This test program should *not* compile successfully. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int main(void) +{ +(void) strchr; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + +else $as_nop + # This test program should compile successfully. + # No library function is consistently available on + # freestanding implementations, so test against a dummy + # declaration. Include always-available headers on the + # off chance that they somehow elicit warnings. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +#include +#include +#include +extern void ac_decl (int, char *); + +int main(void) +{ +(void) ac_decl (0, (char *) 0); + (void) ac_decl; + + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + if test x"$ac_arg" = x +then : + ac_cv_c_undeclared_builtin_options='none needed' +else $as_nop + ac_cv_c_undeclared_builtin_options=$ac_arg +fi + break +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + done + CFLAGS=$ac_save_CFLAGS + +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_undeclared_builtin_options" >&5 +printf "%s\n" "$ac_cv_c_undeclared_builtin_options" >&6; } + case $ac_cv_c_undeclared_builtin_options in #( + 'cannot detect') : + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot make $CC report undeclared builtins +See \`config.log' for more details" "$LINENO" 5; } ;; #( + 'none needed') : + ac_c_undeclared_builtin_options='' ;; #( + *) : + ac_c_undeclared_builtin_options=$ac_cv_c_undeclared_builtin_options ;; +esac + +ac_fn_check_decl "$LINENO" "fseeko" "ac_cv_have_decl_fseeko" "#include +" "$ac_c_undeclared_builtin_options" "CFLAGS" +if test "x$ac_cv_have_decl_fseeko" = xyes +then : + +printf "%s\n" "#define HAVE_DECL_FSEEKO 1" >>confdefs.h + +fi +fi + + + + + + + tst_method="unknown" + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to set a socket into non-blocking mode" >&5 +printf %s "checking how to set a socket into non-blocking mode... " >&6; } + if test "$curl_cv_func_fcntl_o_nonblock" = "yes"; then + tst_method="fcntl O_NONBLOCK" + elif test "$curl_cv_func_ioctl_fionbio" = "yes"; then + tst_method="ioctl FIONBIO" + elif test "$curl_cv_func_ioctlsocket_fionbio" = "yes"; then + tst_method="ioctlsocket FIONBIO" + elif test "$curl_cv_func_ioctlsocket_camel_fionbio" = "yes"; then + tst_method="IoctlSocket FIONBIO" + elif test "$curl_cv_func_setsockopt_so_nonblock" = "yes"; then + tst_method="setsockopt SO_NONBLOCK" + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tst_method" >&5 +printf "%s\n" "$tst_method" >&6; } + if test "$tst_method" = "unknown"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: cannot determine non-blocking socket method." >&5 +printf "%s\n" "$as_me: WARNING: cannot determine non-blocking socket method." >&2;} + fi + + + if test "$BUILD_DOCS" = "1"; then + BUILD_DOCS_TRUE= + BUILD_DOCS_FALSE='#' +else + BUILD_DOCS_TRUE='#' + BUILD_DOCS_FALSE= +fi + + + +if test "$USE_MANUAL" = "1"; then + curl_manual_msg="enabled" +fi + + if test "$USE_MANUAL" = "1"; then + USE_MANUAL_TRUE= + USE_MANUAL_FALSE='#' +else + USE_MANUAL_TRUE='#' + USE_MANUAL_FALSE= +fi + + + + + if test "$want_ares" = "yes"; then + clean_CPPFLAGS="$CPPFLAGS" + clean_LDFLAGS="$LDFLAGS" + clean_LDFLAGSPC="$LDFLAGSPC" + clean_LIBS="$LIBS" + configure_runpath=`pwd` + if test -n "$want_ares_path"; then + ARES_PCDIR="$want_ares_path/lib/pkgconfig" + + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. +set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKGCONFIG="$PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PKGCONFIG=$ac_cv_path_PKGCONFIG +if test -n "$PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PKGCONFIG" >&5 +printf "%s\n" "$PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_PKGCONFIG"; then + ac_pt_PKGCONFIG=$PKGCONFIG + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_PKGCONFIG="$ac_pt_PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_PKGCONFIG=$ac_cv_path_ac_pt_PKGCONFIG +if test -n "$ac_pt_PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKGCONFIG" >&5 +printf "%s\n" "$ac_pt_PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_PKGCONFIG" = x; then + PKGCONFIG="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + PKGCONFIG=$ac_pt_PKGCONFIG + fi +else + PKGCONFIG="$ac_cv_path_PKGCONFIG" +fi + + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for libcares options with pkg-config" >&5 +printf %s "checking for libcares options with pkg-config... " >&6; } + itexists=` + if test -n "$ARES_PCDIR"; then + if test -n ""; then + PKG_CONFIG_PATH="$ARES_PCDIR${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$ARES_PCDIR" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists libcares >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + + trc=` + if test -n "$ARES_PCDIR"; then + if test -n ""; then + PKG_CONFIG_PATH="$ARES_PCDIR${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$ARES_PCDIR" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libcares 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$ARES_PCDIR"; then + if test -n ""; then + PKG_CONFIG_PATH="$ARES_PCDIR${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$ARES_PCDIR" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libcares 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libcares trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libcares trace: +---- begin +${trc} +---- end" >&6;} + + fi + PKGCONFIG="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found" >&5 +printf "%s\n" "found" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG"; then + + trc=` + if test -n "$ARES_PCDIR"; then + if test -n ""; then + PKG_CONFIG_PATH="$ARES_PCDIR${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$ARES_PCDIR" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libcares 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n "$ARES_PCDIR"; then + if test -n ""; then + PKG_CONFIG_PATH="$ARES_PCDIR${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$ARES_PCDIR" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libcares 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libcares trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libcares trace: +---- begin +${trc} +---- end" >&6;} + + fi + fi + fi + + if test "$PKGCONFIG" != "no"; then + ares_LIBS=` + if test -n "$ARES_PCDIR"; then + if test -n ""; then + PKG_CONFIG_PATH="$ARES_PCDIR${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$ARES_PCDIR" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --libs-only-l libcares` + ares_LDFLAGS=` + if test -n "$ARES_PCDIR"; then + if test -n ""; then + PKG_CONFIG_PATH="$ARES_PCDIR${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$ARES_PCDIR" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --libs-only-L libcares` + ares_CPPFLAGS=` + if test -n "$ARES_PCDIR"; then + if test -n ""; then + PKG_CONFIG_PATH="$ARES_PCDIR${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="$ARES_PCDIR" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --cflags-only-I libcares` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config: ares LIBS: \"$ares_LIBS\"" >&5 +printf "%s\n" "$as_me: pkg-config: ares LIBS: \"$ares_LIBS\"" >&6;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config: ares LDFLAGS: \"$ares_LDFLAGS\"" >&5 +printf "%s\n" "$as_me: pkg-config: ares LDFLAGS: \"$ares_LDFLAGS\"" >&6;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config: ares CPPFLAGS: \"$ares_CPPFLAGS\"" >&5 +printf "%s\n" "$as_me: pkg-config: ares CPPFLAGS: \"$ares_CPPFLAGS\"" >&6;} + else + ares_CPPFLAGS="-I$want_ares_path/include" + ares_LDFLAGS="-L$want_ares_path/lib" + ares_LIBS="-lcares" + fi + else + + if test -n "$PKG_CONFIG"; then + PKGCONFIG="$PKG_CONFIG" + else + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. +set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKGCONFIG="$PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PKGCONFIG=$ac_cv_path_PKGCONFIG +if test -n "$PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PKGCONFIG" >&5 +printf "%s\n" "$PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + +fi +if test -z "$ac_cv_path_PKGCONFIG"; then + ac_pt_PKGCONFIG=$PKGCONFIG + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_ac_pt_PKGCONFIG+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $ac_pt_PKGCONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_ac_pt_PKGCONFIG="$ac_pt_PKGCONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_dummy="$PATH:/usr/bin:/usr/local/bin" +for as_dir in $as_dummy +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_ac_pt_PKGCONFIG="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +ac_pt_PKGCONFIG=$ac_cv_path_ac_pt_PKGCONFIG +if test -n "$ac_pt_PKGCONFIG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKGCONFIG" >&5 +printf "%s\n" "$ac_pt_PKGCONFIG" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + if test "x$ac_pt_PKGCONFIG" = x; then + PKGCONFIG="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + PKGCONFIG=$ac_pt_PKGCONFIG + fi +else + PKGCONFIG="$ac_cv_path_PKGCONFIG" +fi + + fi + + if test "$PKGCONFIG" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for libcares options with pkg-config" >&5 +printf %s "checking for libcares options with pkg-config... " >&6; } + itexists=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists libcares >/dev/null 2>&1 && echo 1` + + if test -z "$itexists"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG$CURL_CI"; then + + trc=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libcares 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libcares 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libcares trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libcares trace: +---- begin +${trc} +---- end" >&6;} + + fi + PKGCONFIG="no" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found" >&5 +printf "%s\n" "found" >&6; } + if test -n "$CURL_TRACE_PKG_CONFIG"; then + + trc=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + if test -n "$PKG_CONFIG_LIBDIR"; then + echo "PKG_CONFIG_LIBDIR: '$PKG_CONFIG_LIBDIR'" + fi + if test -n "$PKG_CONFIG_PATH"; then + echo "PKG_CONFIG_PATH: '$PKG_CONFIG_PATH'" + fi + $PKGCONFIG --exists --debug libcares 2>&1 | \ + $EGREP '(trying path:|Adding directory|Looking for|Scanning directory|Cannot open directory)' | \ + $SED 's/^.*trying path:/trying path:/'` + msg=` + if test -n ""; then + if test -n ""; then + PKG_CONFIG_PATH="${PKG_CONFIG_PATH:+:$PKG_CONFIG_PATH}" + export PKG_CONFIG_PATH + else + PKG_CONFIG_LIBDIR="" + export PKG_CONFIG_LIBDIR + fi + fi + + $PKGCONFIG --exists --print-errors libcares 2>&1` + if test -n "$msg"; then + trc=`echo "$trc"; echo '==== error:'; echo "$msg"` + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config --exists libcares trace: +---- begin +${trc} +---- end" >&5 +printf "%s\n" "$as_me: pkg-config --exists libcares trace: +---- begin +${trc} +---- end" >&6;} + + fi + fi + fi + + if test "$PKGCONFIG" != "no"; then + ares_LIBS=`$PKGCONFIG --libs-only-l libcares` + ares_LDFLAGS=`$PKGCONFIG --libs-only-L libcares` + ares_CPPFLAGS=`$PKGCONFIG --cflags-only-I libcares` + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config: ares_LIBS: \"$ares_LIBS\"" >&5 +printf "%s\n" "$as_me: pkg-config: ares_LIBS: \"$ares_LIBS\"" >&6;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config: ares_LDFLAGS: \"$ares_LDFLAGS\"" >&5 +printf "%s\n" "$as_me: pkg-config: ares_LDFLAGS: \"$ares_LDFLAGS\"" >&6;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: pkg-config: ares_CPPFLAGS: \"$ares_CPPFLAGS\"" >&5 +printf "%s\n" "$as_me: pkg-config: ares_CPPFLAGS: \"$ares_CPPFLAGS\"" >&6;} + else + ares_CPPFLAGS="" + ares_LDFLAGS="" + ares_LIBS="-lcares" + fi + fi + + CPPFLAGS="$clean_CPPFLAGS $ares_CPPFLAGS" + LDFLAGS="$clean_LDFLAGS $ares_LDFLAGS" + LDFLAGSPC="$clean_LDFLAGSPC $ares_LDFLAGS" + LIBS="$ares_LIBS $clean_LIBS" + + ac_fn_c_check_func "$LINENO" "ares_getaddrinfo" "ac_cv_func_ares_getaddrinfo" +if test "x$ac_cv_func_ares_getaddrinfo" = xyes +then : + + +else $as_nop + + as_fn_error $? "c-ares library is defective or too old" "$LINENO" 5 + CPPFLAGS="$clean_CPPFLAGS" + LDFLAGS="$clean_LDFLAGS" + LDFLAGSPC="$clean_LDFLAGSPC" + LIBS="$clean_LIBS" + want_ares="no" + +fi + + + if test "$want_ares" = "yes"; then + +printf "%s\n" "#define USE_ARES 1" >>confdefs.h + + USE_ARES=1 + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libcares" + curl_res_msg="c-ares" + fi + fi + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable the threaded resolver" >&5 +printf %s "checking whether to enable the threaded resolver... " >&6; } + OPT_THRES="default" + # Check whether --enable-threaded_resolver was given. +if test ${enable_threaded_resolver+y} +then : + enableval=$enable_threaded_resolver; OPT_THRES=$enableval +fi + + case "$OPT_THRES" in + no) + want_threaded_resolver="no" + ;; + yes) + want_threaded_resolver="yes" + ;; + *) + case $host_os in + msdos* | amiga*) + want_threaded_resolver="no" + ;; + *) + if test "$want_ares" = "yes"; then + want_threaded_resolver="no" + else + want_threaded_resolver="yes" + fi + ;; + esac + ;; + esac + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $want_threaded_resolver" >&5 +printf "%s\n" "$want_threaded_resolver" >&6; } + + +if test "$ipv6" = "yes" && test "$curl_cv_apple" = "yes"; then + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to link macOS CoreFoundation, CoreServices, and SystemConfiguration frameworks" >&5 +printf %s "checking whether to link macOS CoreFoundation, CoreServices, and SystemConfiguration frameworks... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #include + #include + +int main(void) +{ + + #if TARGET_OS_MAC && !(defined(TARGET_OS_IPHONE) && TARGET_OS_IPHONE) + return 0; + #else + #error Not macOS + #endif + + return 0; +} + +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + + build_for_macos="yes" + +else $as_nop + + build_for_macos="no" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext + if test "$build_for_macos" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + SYSCONFIG_LDFLAGS='-framework CoreFoundation -framework CoreServices -framework SystemConfiguration' + LDFLAGS="$LDFLAGS $SYSCONFIG_LDFLAGS" + LDFLAGSPC="$LDFLAGSPC $SYSCONFIG_LDFLAGS" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + fi + +fi + +if test "$curl_cv_native_windows" != "yes"; then + ac_fn_c_check_header_compile "$LINENO" "pthread.h" "ac_cv_header_pthread_h" "$ac_includes_default" +if test "x$ac_cv_header_pthread_h" = xyes +then : + + save_CFLAGS="$CFLAGS" + save_LIBS="$LIBS" + + LIBS= + ac_fn_c_check_func "$LINENO" "pthread_create" "ac_cv_func_pthread_create" +if test "x$ac_cv_func_pthread_create" = xyes +then : + HAVE_THREADS_POSIX=1 +fi + + LIBS="$save_LIBS" + + case $host in + *-hp-hpux*) + CFLAGS="$CFLAGS -mt" + ;; + *) + ;; + esac + + if test "$HAVE_THREADS_POSIX" != "1"; then + PTHREAD=" -pthread" + + case $host in + *-ibm-aix*) + COMPILER_VERSION=`"$CC" -qversion 2>/dev/null` + if test -z "$COMPILER_VERSION"; then + CFLAGS="$CFLAGS -pthread" + else + CFLAGS="$CFLAGS -qthreaded" + fi + ;; + powerpc-*amigaos*) + PTHREAD=" -lpthread" + ;; + *) + CFLAGS="$CFLAGS -pthread" + ;; + esac + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for pthread_create in -lpthread" >&5 +printf %s "checking for pthread_create in -lpthread... " >&6; } +if test ${ac_cv_lib_pthread_pthread_create+y} +then : + printf %s "(cached) " >&6 +else $as_nop + ac_check_lib_save_LIBS=$LIBS +LIBS="-lpthread $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +#ifdef __cplusplus +extern "C" +#endif +char pthread_create (); +int main(void) +{ +return pthread_create (); + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + ac_cv_lib_pthread_pthread_create=yes +else $as_nop + ac_cv_lib_pthread_pthread_create=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_pthread_pthread_create" >&5 +printf "%s\n" "$ac_cv_lib_pthread_pthread_create" >&6; } +if test "x$ac_cv_lib_pthread_pthread_create" = xyes +then : + HAVE_THREADS_POSIX=1 +else $as_nop + CFLAGS="$save_CFLAGS" +fi + + fi + +fi + + if test "$HAVE_THREADS_POSIX" = "1"; then + +printf "%s\n" "#define HAVE_THREADS_POSIX 1" >>confdefs.h + + fi +fi + +if test "$want_threaded_resolver" = "yes"; then + if test "$curl_cv_native_windows" = "yes"; then + USE_RESOLV_THREADED=1 + +printf "%s\n" "#define USE_RESOLV_THREADED 1" >>confdefs.h + + curl_res_msg="Win32 threaded" + elif test "$HAVE_THREADS_POSIX" = "1"; then + USE_RESOLV_THREADED=1 + +printf "%s\n" "#define USE_RESOLV_THREADED 1" >>confdefs.h + + curl_res_msg="POSIX threaded" + else + as_fn_error $? "Threaded resolver enabled but no thread library found" "$LINENO" 5 + fi +elif test "$USE_ARES" = "1"; then + USE_RESOLV_ARES=1 + +printf "%s\n" "#define USE_RESOLV_ARES 1" >>confdefs.h + + curl_res_msg="c-ares" +fi + +ac_fn_c_check_header_compile "$LINENO" "dirent.h" "ac_cv_header_dirent_h" "$ac_includes_default" +if test "x$ac_cv_header_dirent_h" = xyes +then : + +printf "%s\n" "#define HAVE_DIRENT_H 1" >>confdefs.h + + ac_fn_c_check_func "$LINENO" "opendir" "ac_cv_func_opendir" +if test "x$ac_cv_func_opendir" = xyes +then : + +printf "%s\n" "#define HAVE_OPENDIR 1" >>confdefs.h + +fi + + + +fi + + + + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking convert -I options to -isystem" >&5 +printf %s "checking convert -I options to -isystem... " >&6; } + if test "$compiler_id" = "GNU_C" || + test "$compiler_id" = "CLANG" || + test "$compiler_id" = "APPLECLANG"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + tmp_has_include="no" + tmp_chg_FLAGS="$CFLAGS" + for word1 in $tmp_chg_FLAGS; do + case "$word1" in + -I*) + tmp_has_include="yes" + ;; + esac + done + if test "$tmp_has_include" = "yes"; then + tmp_chg_FLAGS=`echo "$tmp_chg_FLAGS" | "$SED" 's/^-I/ -isystem /g'` + tmp_chg_FLAGS=`echo "$tmp_chg_FLAGS" | "$SED" 's/ -I/ -isystem /g'` + CFLAGS="$tmp_chg_FLAGS" + squeeze CFLAGS + fi + tmp_has_include="no" + tmp_chg_FLAGS="$CPPFLAGS" + for word1 in $tmp_chg_FLAGS; do + case "$word1" in + -I*) + tmp_has_include="yes" + ;; + esac + done + if test "$tmp_has_include" = "yes"; then + tmp_chg_FLAGS=`echo "$tmp_chg_FLAGS" | "$SED" 's/^-I/ -isystem /g'` + tmp_chg_FLAGS=`echo "$tmp_chg_FLAGS" | "$SED" 's/ -I/ -isystem /g'` + CPPFLAGS="$tmp_chg_FLAGS" + squeeze CPPFLAGS + fi + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable curl_easy_setopt()/curl_easy_getinfo() type checking" >&5 +printf %s "checking whether to enable curl_easy_setopt()/curl_easy_getinfo() type checking... " >&6; } +# Check whether --enable-typecheck was given. +if test ${enable_typecheck+y} +then : + enableval=$enable_typecheck; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + CPPFLAGS="$CPPFLAGS -DCURL_DISABLE_TYPECHECK" + curl_typecheck_msg="no" + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable verbose strings" >&5 +printf %s "checking whether to enable verbose strings... " >&6; } +# Check whether --enable-verbose was given. +if test ${enable_verbose+y} +then : + enableval=$enable_verbose; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_VERBOSE_STRINGS 1" >>confdefs.h + + curl_verbose_msg="no" + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + + +if test "$curl_cv_winuwp" != "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable SSPI support (Windows native builds only)" >&5 +printf %s "checking whether to enable SSPI support (Windows native builds only)... " >&6; } + # Check whether --enable-sspi was given. +if test ${enable_sspi+y} +then : + enableval=$enable_sspi; case "$enableval" in + yes) + if test "$curl_cv_native_windows" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define USE_WINDOWS_SSPI 1" >>confdefs.h + + USE_WINDOWS_SSPI=1 + curl_sspi_msg="enabled" + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: --enable-sspi Ignored. Only supported on native Windows builds." >&5 +printf "%s\n" "$as_me: WARNING: --enable-sspi Ignored. Only supported on native Windows builds." >&2;} + fi + ;; + *) + if test "$SCHANNEL_ENABLED" = "1"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + fi + ;; + esac +else $as_nop + if test "$SCHANNEL_ENABLED" = "1"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + fi + +fi + + + if test "$USE_WINDOWS_SSPI" = "1"; then + LIBS="-lsecur32 $LIBS" + fi +fi + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable basic authentication method" >&5 +printf %s "checking whether to enable basic authentication method... " >&6; } +# Check whether --enable-basic-auth was given. +if test ${enable_basic_auth+y} +then : + enableval=$enable_basic_auth; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_BASIC_AUTH 1" >>confdefs.h + + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable bearer authentication method" >&5 +printf %s "checking whether to enable bearer authentication method... " >&6; } +# Check whether --enable-bearer-auth was given. +if test ${enable_bearer_auth+y} +then : + enableval=$enable_bearer_auth; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_BEARER_AUTH 1" >>confdefs.h + + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable digest authentication method" >&5 +printf %s "checking whether to enable digest authentication method... " >&6; } +# Check whether --enable-digest-auth was given. +if test ${enable_digest_auth+y} +then : + enableval=$enable_digest_auth; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_DIGEST_AUTH 1" >>confdefs.h + + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable kerberos authentication method" >&5 +printf %s "checking whether to enable kerberos authentication method... " >&6; } +# Check whether --enable-kerberos-auth was given. +if test ${enable_kerberos_auth+y} +then : + enableval=$enable_kerberos_auth; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_KERBEROS_AUTH 1" >>confdefs.h + + CURL_DISABLE_KERBEROS_AUTH=1 + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable negotiate authentication method" >&5 +printf %s "checking whether to enable negotiate authentication method... " >&6; } +# Check whether --enable-negotiate-auth was given. +if test ${enable_negotiate_auth+y} +then : + enableval=$enable_negotiate_auth; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_NEGOTIATE_AUTH 1" >>confdefs.h + + CURL_DISABLE_NEGOTIATE_AUTH=1 + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable aws sig methods" >&5 +printf %s "checking whether to enable aws sig methods... " >&6; } +# Check whether --enable-aws was given. +if test ${enable_aws+y} +then : + enableval=$enable_aws; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_AWS 1" >>confdefs.h + + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support NTLM" >&5 +printf %s "checking whether to support NTLM... " >&6; } +# Check whether --enable-ntlm was given. +if test ${enable_ntlm+y} +then : + enableval=$enable_ntlm; case "$enableval" in + yes) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define CURL_ENABLE_NTLM 1" >>confdefs.h + + CURL_ENABLE_NTLM=1 + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable TLS-SRP authentication" >&5 +printf %s "checking whether to enable TLS-SRP authentication... " >&6; } +# Check whether --enable-tls-srp was given. +if test ${enable_tls_srp+y} +then : + enableval=$enable_tls_srp; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + want_tls_srp=no + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + want_tls_srp=yes + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + want_tls_srp=yes + +fi + + +if test "$want_tls_srp" = "yes" && (test "$HAVE_GNUTLS_SRP" = "1" || test "$HAVE_OPENSSL_SRP" = "1"); then + +printf "%s\n" "#define USE_TLS_SRP 1" >>confdefs.h + + USE_TLS_SRP=1 + curl_tls_srp_msg="enabled" +fi + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable Unix domain sockets" >&5 +printf %s "checking whether to enable Unix domain sockets... " >&6; } +# Check whether --enable-unix-sockets was given. +if test ${enable_unix_sockets+y} +then : + enableval=$enable_unix_sockets; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + want_unix_sockets=no + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + want_unix_sockets=yes + ;; + esac +else $as_nop + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: auto" >&5 +printf "%s\n" "auto" >&6; } + want_unix_sockets=auto + + +fi + +if test "$want_unix_sockets" != "no"; then + if test "$curl_cv_native_windows" = "yes"; then + USE_UNIX_SOCKETS=1 + +printf "%s\n" "#define USE_UNIX_SOCKETS 1" >>confdefs.h + + curl_unix_sockets_msg="enabled" + else + ac_fn_c_check_member "$LINENO" "struct sockaddr_un" "sun_path" "ac_cv_member_struct_sockaddr_un_sun_path" " + #include + +" +if test "x$ac_cv_member_struct_sockaddr_un_sun_path" = xyes +then : + + +printf "%s\n" "#define USE_UNIX_SOCKETS 1" >>confdefs.h + + USE_UNIX_SOCKETS=1 + curl_unix_sockets_msg="enabled" + +else $as_nop + + if test "$want_unix_sockets" = "yes"; then + as_fn_error $? "--enable-unix-sockets is not available on this platform!" "$LINENO" 5 + fi + +fi + + fi +fi + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support cookies" >&5 +printf %s "checking whether to support cookies... " >&6; } +# Check whether --enable-cookies was given. +if test ${enable_cookies+y} +then : + enableval=$enable_cookies; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_COOKIES 1" >>confdefs.h + + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support socketpair" >&5 +printf %s "checking whether to support socketpair... " >&6; } +# Check whether --enable-socketpair was given. +if test ${enable_socketpair+y} +then : + enableval=$enable_socketpair; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_SOCKETPAIR 1" >>confdefs.h + + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support HTTP authentication" >&5 +printf %s "checking whether to support HTTP authentication... " >&6; } +# Check whether --enable-http-auth was given. +if test ${enable_http_auth+y} +then : + enableval=$enable_http_auth; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_HTTP_AUTH 1" >>confdefs.h + + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support DoH" >&5 +printf %s "checking whether to support DoH... " >&6; } +# Check whether --enable-doh was given. +if test ${enable_doh+y} +then : + enableval=$enable_doh; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_DOH 1" >>confdefs.h + + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support the MIME API" >&5 +printf %s "checking whether to support the MIME API... " >&6; } +# Check whether --enable-mime was given. +if test ${enable_mime+y} +then : + enableval=$enable_mime; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_MIME 1" >>confdefs.h + + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support binding connections locally" >&5 +printf %s "checking whether to support binding connections locally... " >&6; } +# Check whether --enable-bindlocal was given. +if test ${enable_bindlocal+y} +then : + enableval=$enable_bindlocal; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_BINDLOCAL 1" >>confdefs.h + + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support the form API" >&5 +printf %s "checking whether to support the form API... " >&6; } +# Check whether --enable-form-api was given. +if test ${enable_form_api+y} +then : + enableval=$enable_form_api; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_FORM_API 1" >>confdefs.h + + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + test "x$enable_mime" = "xno" && + as_fn_error $? "MIME support needs to be enabled in order to enable form API support" "$LINENO" 5 + ;; + esac +else $as_nop + + if test "x$enable_mime" = "xno"; then + enable_form_api=no + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_FORM_API 1" >>confdefs.h + + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + fi + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support date parsing" >&5 +printf %s "checking whether to support date parsing... " >&6; } +# Check whether --enable-dateparse was given. +if test ${enable_dateparse+y} +then : + enableval=$enable_dateparse; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_PARSEDATE 1" >>confdefs.h + + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support netrc parsing" >&5 +printf %s "checking whether to support netrc parsing... " >&6; } +# Check whether --enable-netrc was given. +if test ${enable_netrc+y} +then : + enableval=$enable_netrc; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_NETRC 1" >>confdefs.h + + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support progress-meter" >&5 +printf %s "checking whether to support progress-meter... " >&6; } +# Check whether --enable-progress-meter was given. +if test ${enable_progress_meter+y} +then : + enableval=$enable_progress_meter; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_PROGRESS_METER 1" >>confdefs.h + + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support the SHA-512/256 hash algorithm" >&5 +printf %s "checking whether to support the SHA-512/256 hash algorithm... " >&6; } +# Check whether --enable-sha512-256 was given. +if test ${enable_sha512_256+y} +then : + enableval=$enable_sha512_256; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_SHA512_256 1" >>confdefs.h + + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support DNS shuffling" >&5 +printf %s "checking whether to support DNS shuffling... " >&6; } +# Check whether --enable-dnsshuffle was given. +if test ${enable_dnsshuffle+y} +then : + enableval=$enable_dnsshuffle; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_SHUFFLE_DNS 1" >>confdefs.h + + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support curl_easy_option*" >&5 +printf %s "checking whether to support curl_easy_option*... " >&6; } +# Check whether --enable-get-easy-options was given. +if test ${enable_get_easy_options+y} +then : + enableval=$enable_get_easy_options; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_GETOPTIONS 1" >>confdefs.h + + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support alt-svc" >&5 +printf %s "checking whether to support alt-svc... " >&6; } +# Check whether --enable-alt-svc was given. +if test ${enable_alt_svc+y} +then : + enableval=$enable_alt_svc; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_ALTSVC 1" >>confdefs.h + + curl_altsvc_msg="no"; + enable_altsvc="no" + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support headers-api" >&5 +printf %s "checking whether to support headers-api... " >&6; } +# Check whether --enable-headers-api was given. +if test ${enable_headers_api+y} +then : + enableval=$enable_headers_api; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + curl_headers_msg="no (--enable-headers-api)" + +printf "%s\n" "#define CURL_DISABLE_HEADERS_API 1" >>confdefs.h + + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + + +if test -n "$SSL_ENABLED"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support HSTS" >&5 +printf %s "checking whether to support HSTS... " >&6; } + # Check whether --enable-hsts was given. +if test ${enable_hsts+y} +then : + enableval=$enable_hsts; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + hsts="no" + ;; + *) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $hsts" >&5 +printf "%s\n" "$hsts" >&6; } + +fi + +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: disables HSTS due to lack of SSL" >&5 +printf "%s\n" "$as_me: disables HSTS due to lack of SSL" >&6;} + hsts="no" +fi + +if test "$hsts" != "yes"; then + curl_hsts_msg="no (--enable-hsts)"; + +printf "%s\n" "#define CURL_DISABLE_HSTS 1" >>confdefs.h + +fi + +if test "$want_ech" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether ECH support is available" >&5 +printf %s "checking whether ECH support is available... " >&6; } + + ECH_ENABLED=0 + ECH_ENABLED_OPENSSL=0 + ECH_ENABLED_WOLFSSL=0 + ECH_ENABLED_RUSTLS=0 + ECH_SUPPORT='' + + if test "$OPENSSL_ENABLED" = "1"; then + + for ac_func in SSL_set1_ech_config_list +do : + ac_fn_c_check_func "$LINENO" "SSL_set1_ech_config_list" "ac_cv_func_SSL_set1_ech_config_list" +if test "x$ac_cv_func_SSL_set1_ech_config_list" = xyes +then : + printf "%s\n" "#define HAVE_SSL_SET1_ECH_CONFIG_LIST 1" >>confdefs.h + ECH_SUPPORT="$ECH_SUPPORT OpenSSL" + ECH_ENABLED_OPENSSL=1 +fi + +done + fi + if test "$WOLFSSL_ENABLED" = "1"; then + + for ac_func in wolfSSL_CTX_GenerateEchConfig +do : + ac_fn_c_check_func "$LINENO" "wolfSSL_CTX_GenerateEchConfig" "ac_cv_func_wolfSSL_CTX_GenerateEchConfig" +if test "x$ac_cv_func_wolfSSL_CTX_GenerateEchConfig" = xyes +then : + printf "%s\n" "#define HAVE_WOLFSSL_CTX_GENERATEECHCONFIG 1" >>confdefs.h + ECH_SUPPORT="$ECH_SUPPORT wolfSSL" + ECH_ENABLED_WOLFSSL=1 +fi + +done + fi + if test "$RUSTLS_ENABLED" = "1"; then + ECH_SUPPORT="$ECH_SUPPORT rustls-ffi" + ECH_ENABLED_RUSTLS=1 + fi + + if test "$ECH_ENABLED_OPENSSL" = "1" || + test "$ECH_ENABLED_WOLFSSL" = "1" || + test "$ECH_ENABLED_RUSTLS" = "1"; then + +printf "%s\n" "#define USE_ECH 1" >>confdefs.h + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: ECH support available via:$ECH_SUPPORT" >&5 +printf "%s\n" "ECH support available via:$ECH_SUPPORT" >&6; } + experimental="$experimental ECH" + ECH_ENABLED=1 + want_httpsrr="yes" + else + as_fn_error $? "--enable-ech ignored: No ECH support found" "$LINENO" 5 + fi +fi + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable HTTPS-RR support" >&5 +printf %s "checking whether to enable HTTPS-RR support... " >&6; } +if test "$want_httpsrr" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +printf "%s\n" "#define USE_HTTPSRR 1" >>confdefs.h + + experimental="$experimental HTTPSRR" + curl_httpsrr_msg="enabled (--disable-httpsrr)" +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + if test "$want_threaded_resolver" = "yes"; then + if test "$USE_ARES" = "1"; then + as_fn_error $? "without HTTPS-RR support, asking for both threaded resolver and c-ares support is ambivalent. Please drop one of them." "$LINENO" 5 + fi + fi +fi + +if test "$OPENSSL_ENABLED" = "1"; then + ac_fn_c_check_func "$LINENO" "SSL_set0_wbio" "ac_cv_func_SSL_set0_wbio" +if test "x$ac_cv_func_SSL_set0_wbio" = xyes +then : + printf "%s\n" "#define HAVE_SSL_SET0_WBIO 1" >>confdefs.h + +fi + +fi + +if test "$CURL_DISABLE_HTTP" != "1"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to support WebSockets" >&5 +printf %s "checking whether to support WebSockets... " >&6; } + # Check whether --enable-websockets was given. +if test ${enable_websockets+y} +then : + enableval=$enable_websockets; case "$enableval" in + no) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + +printf "%s\n" "#define CURL_DISABLE_WEBSOCKETS 1" >>confdefs.h + + CURL_DISABLE_WEBSOCKETS=1 + ;; + *) + if test "$ac_cv_sizeof_curl_off_t" -gt 4; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: WebSockets disabled due to lack of >32-bit curl_off_t" >&5 +printf "%s\n" "$as_me: WARNING: WebSockets disabled due to lack of >32-bit curl_off_t" >&2;} + +printf "%s\n" "#define CURL_DISABLE_WEBSOCKETS 1" >>confdefs.h + + CURL_DISABLE_WEBSOCKETS=1 + fi + ;; + esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + +fi + +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: WebSockets disabled because HTTP is disabled" >&5 +printf "%s\n" "$as_me: WARNING: WebSockets disabled because HTTP is disabled" >&2;} + +printf "%s\n" "#define CURL_DISABLE_WEBSOCKETS 1" >>confdefs.h + + CURL_DISABLE_WEBSOCKETS=1 +fi + +if test "$want_ssls_export" != "no"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether SSL session export support is available" >&5 +printf %s "checking whether SSL session export support is available... " >&6; } + + SSLS_EXPORT_ENABLED=0 + SSLS_EXPORT_SUPPORT='' + + if test "$SSL_ENABLED" != "1"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: --enable-ssls-export ignored: No SSL support" >&5 +printf "%s\n" "$as_me: WARNING: --enable-ssls-export ignored: No SSL support" >&2;} + else + SSLS_EXPORT_ENABLED=1 + +printf "%s\n" "#define USE_SSLS_EXPORT 1" >>confdefs.h + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: \"SSL session im-/export enabled\"" >&5 +printf "%s\n" "\"SSL session im-/export enabled\"" >&6; } + experimental="$experimental SSLS-EXPORT" + fi +fi + +if test "$want_proxy_http3" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether HTTP/3 proxy support is available" >&5 +printf %s "checking whether HTTP/3 proxy support is available... " >&6; } + + if test "$CURL_DISABLE_PROXY" = "1"; then + as_fn_error $? "--enable-proxy-http3 requires proxy support" "$LINENO" 5 + elif test "$CURL_DISABLE_HTTP" = "1"; then + as_fn_error $? "--enable-proxy-http3 requires HTTP support" "$LINENO" 5 + elif test "$USE_NGTCP2_H3" != "1"; then + as_fn_error $? "--enable-proxy-http3 requires ngtcp2 + nghttp3" "$LINENO" 5 + elif test "x$OPENSSL_ENABLED" != "x1"; then + as_fn_error $? "--enable-proxy-http3 currently requires OpenSSL" "$LINENO" 5 + else + +printf "%s\n" "#define USE_PROXY_HTTP3 1" >>confdefs.h + + USE_PROXY_HTTP3=1 + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + experimental="$experimental proxy-HTTP3" + fi +fi + + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether hiding of library internal symbols does actually happen" >&5 +printf %s "checking whether hiding of library internal symbols does actually happen... " >&6; } + CFLAG_CURL_SYMBOL_HIDING="" + doing_symbol_hiding="no" + if test "$want_symbol_hiding" = "yes" && + test "$supports_symbol_hiding" = "yes"; then + doing_symbol_hiding="yes" + CFLAG_CURL_SYMBOL_HIDING="$symbol_hiding_CFLAGS" + +printf "%s\n" "#define CURL_EXTERN_SYMBOL $symbol_hiding_EXTERN" >>confdefs.h + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + fi + if test "$doing_symbol_hiding" = "yes"; then + DOING_CURL_SYMBOL_HIDING_TRUE= + DOING_CURL_SYMBOL_HIDING_FALSE='#' +else + DOING_CURL_SYMBOL_HIDING_TRUE='#' + DOING_CURL_SYMBOL_HIDING_FALSE= +fi + + + + +LIBCURL_PC_LDFLAGS_PRIVATE='' +set -- $INITIAL_LDFLAGS +while test -n "$1"; do + case "$1" in + -L* | --library-path=* | -F*) + LIBCURL_PC_LDFLAGS_PRIVATE="$LIBCURL_PC_LDFLAGS_PRIVATE $1" + ;; + -framework) + if test -n "$2"; then + LIBCURL_PC_LDFLAGS_PRIVATE="$LIBCURL_PC_LDFLAGS_PRIVATE $1 $2" + shift + fi + ;; + esac + shift +done +LIBCURL_PC_LDFLAGS_PRIVATE="$LIBCURL_PC_LDFLAGS_PRIVATE $LDFLAGSPC" +LIBCURL_PC_LIBS_PRIVATE="$LIBS$PTHREAD" + + + + + +BLANK_AT_MAKETIME= + + + if test "$cross_compiling" = "yes"; then + CROSSCOMPILING_TRUE= + CROSSCOMPILING_FALSE='#' +else + CROSSCOMPILING_TRUE='#' + CROSSCOMPILING_FALSE= +fi + + +ENABLE_SHARED="$enable_shared" + + +ENABLE_STATIC="$enable_static" + + +squeeze LIBCURL_PC_REQUIRES_PRIVATE +LIBCURL_PC_REQUIRES_PRIVATE=`echo $LIBCURL_PC_REQUIRES_PRIVATE | tr ' ' ','` + + + +if test "$enable_shared" = "no"; then + LIBCURL_PC_REQUIRES=$LIBCURL_PC_REQUIRES_PRIVATE + LIBCURL_PC_LIBS=$LIBCURL_PC_LIBS_PRIVATE +else + LIBCURL_PC_REQUIRES= + LIBCURL_PC_LIBS= +fi + + + +rm $compilersh + + +if test "$OPENSSL_ENABLED" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES SSL" +elif test -n "$SSL_ENABLED"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES SSL" +fi +if test "$IPV6_ENABLED" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES IPv6" +fi +if test "$USE_UNIX_SOCKETS" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES UnixSockets" +fi +if test "$HAVE_LIBZ" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES libz" +fi +if test "$HAVE_BROTLI" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES brotli" +fi +if test "$HAVE_ZSTD" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES zstd" +fi +if test "$USE_RESOLV_ARES" = "1" || test "$USE_RESOLV_THREADED" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES AsynchDNS" +fi +if test "$USE_ARES" = "1" && test "$want_threaded_resolver" = "yes" && test "$want_httpsrr" != "no"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES asyn-rr" +fi +if test "$IDN_ENABLED" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES IDN" +fi +if test "$USE_WINDOWS_SSPI" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES SSPI" +fi + +if test "$HAVE_GSSAPI" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES GSS-API" +fi + +if test "$curl_psl_msg" = "enabled"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES PSL" +fi + +if test "$USE_PROXY_HTTP3" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES proxy-HTTP3" +fi + +if test "$curl_gsasl_msg" = "enabled"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES gsasl" +fi + +if test "$enable_altsvc" = "yes"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES alt-svc" +fi +if test "$hsts" = "yes"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES HSTS" +fi + +if test "$CURL_DISABLE_NEGOTIATE_AUTH" != "1" && (test "$HAVE_GSSAPI" = "1" || test "$USE_WINDOWS_SSPI" = "1"); then + SUPPORT_FEATURES="$SUPPORT_FEATURES SPNEGO" +fi + +if test "$CURL_DISABLE_KERBEROS_AUTH" != "1" && (test "$HAVE_GSSAPI" = "1" || test "$USE_WINDOWS_SSPI" = "1"); then + SUPPORT_FEATURES="$SUPPORT_FEATURES Kerberos" +fi + +use_curl_ntlm_core=no + +if test "$CURL_ENABLE_NTLM" = "1"; then + if test "$HAVE_DES_ECB_ENCRYPT" = "1" || + test "$GNUTLS_ENABLED" = "1" || + test "$USE_WIN32_CRYPTO" = "1" || + test "$HAVE_WC_DES_ECBENCRYPT" = "1" || + test "$HAVE_MBEDTLS_DES_CRYPT_ECB" = "1"; then + use_curl_ntlm_core=yes + fi + + if test "$use_curl_ntlm_core" = "yes" || + test "$USE_WINDOWS_SSPI" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES NTLM" + fi +fi + +if test "$USE_TLS_SRP" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES TLS-SRP" +fi + +if test "$USE_NGHTTP2" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES HTTP2" +fi + +if test "$USE_NGTCP2_H3" = "1" || + test "$USE_QUICHE" = "1" || + test "$USE_OPENSSL_H3" = "1"; then + if test "$CURL_WITH_MULTI_SSL" = "1"; then + as_fn_error $? "MultiSSL cannot be enabled with HTTP/3 and vice versa" "$LINENO" 5 + fi + SUPPORT_FEATURES="$SUPPORT_FEATURES HTTP3" +fi + +if test "$CURL_WITH_MULTI_SSL" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES MultiSSL" +fi + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if this build supports HTTPS-proxy" >&5 +printf %s "checking if this build supports HTTPS-proxy... " >&6; } +if test "$CURL_DISABLE_HTTP" != "1"; then + if test "$https_proxy" != "no"; then + if test "$OPENSSL_ENABLED" = "1" || + test "$GNUTLS_ENABLED" = "1" || + test "$RUSTLS_ENABLED" = "1" || + test "$SCHANNEL_ENABLED" = "1" || + test "$GNUTLS_ENABLED" = "1" || + test "$MBEDTLS_ENABLED" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES HTTPS-proxy" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + elif test "$WOLFSSL_ENABLED" = "1" && test "$HAVE_WOLFSSL_BIO_NEW" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES HTTPS-proxy" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + fi + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } + fi +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + +if test "$OPENSSL_ENABLED" = "1" || test -n "$SSL_ENABLED"; then + if test "$ECH_ENABLED" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES ECH" + fi +fi + +if test -n "$SSL_ENABLED"; then + if test "$APPLE_SECTRUST_ENABLED" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES AppleSecTrust" + elif test "$ca_native_opt" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES NativeCA" + fi +fi + +if test "$want_httpsrr" != "no"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES HTTPSRR" +fi + +if test "$SSLS_EXPORT_ENABLED" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES SSLS-EXPORT" +fi + +if test "$ac_cv_sizeof_curl_off_t" -gt 4; then + if test "$ac_cv_sizeof_off_t" -gt 4 || + test "$curl_cv_native_windows" = "yes"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES Largefile" + fi +fi + +if test "$tst_atomic" = "yes"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES threadsafe" +elif test "$HAVE_THREADS_POSIX" = "1" && test "$ac_cv_header_pthread_h" = "yes"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES threadsafe" +elif test "$curl_cv_native_windows" = "yes"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES threadsafe" +fi + +if test "$want_winuni" = "yes"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES Unicode" +fi +if test "$want_debug" = "yes"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES Debug" +fi +if test -n "$CURL_CA_EMBED"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES CAcert" + CURL_CA_EMBED_msg="$CURL_CA_EMBED" +else + CURL_CA_EMBED_msg='no' +fi + +if sort -f /dev/null 2>&1; then + SUPPORT_FEATURES=`echo $SUPPORT_FEATURES | tr ' ' '\012' | sort -f | tr '\012' ' '` +else + SUPPORT_FEATURES=`echo $SUPPORT_FEATURES | tr ' ' '\012' | sort | tr '\012' ' '` +fi + + +if test "$CURL_DISABLE_HTTP" != "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS HTTP" + if test "$SSL_ENABLED" = "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS HTTPS" + fi +fi +if test "$CURL_DISABLE_FTP" != "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS FTP" + if test "$SSL_ENABLED" = "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS FTPS" + fi +fi +if test "$CURL_DISABLE_FILE" != "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS FILE" +fi +if test "$CURL_DISABLE_TELNET" != "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS TELNET" +fi +if test "$CURL_DISABLE_LDAP" != "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS LDAP" + if test "$CURL_DISABLE_LDAPS" != "1"; then + if (test "$USE_OPENLDAP" = "1" && test "$SSL_ENABLED" = "1") || + (test "$USE_OPENLDAP" != "1" && test "$HAVE_LDAP_SSL" = "1"); then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS LDAPS" + fi + fi +fi +if test "$CURL_DISABLE_DICT" != "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS DICT" +fi +if test "$CURL_DISABLE_TFTP" != "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS TFTP" +fi +if test "$CURL_DISABLE_GOPHER" != "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS GOPHER" + if test "$SSL_ENABLED" = "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS GOPHERS" + fi +fi +if test "$CURL_DISABLE_MQTT" != "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS MQTT" + if test "$SSL_ENABLED" = "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS MQTTS" + fi +fi +if test "$CURL_DISABLE_POP3" != "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS POP3" + if test "$SSL_ENABLED" = "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS POP3S" + fi +fi +if test "$CURL_DISABLE_IMAP" != "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS IMAP" + if test "$SSL_ENABLED" = "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS IMAPS" + fi +fi +if test "$CURL_ENABLE_SMB" = "1" && test "$use_curl_ntlm_core" = "yes"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS SMB" + if test "$SSL_ENABLED" = "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS SMBS" + fi +fi +if test "$CURL_DISABLE_SMTP" != "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS SMTP" + if test "$SSL_ENABLED" = "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS SMTPS" + fi +fi +if test "$USE_LIBSSH2" = "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS SCP" + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS SFTP" +fi +if test "$USE_LIBSSH" = "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS SCP" + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS SFTP" +fi +if test "$CURL_DISABLE_IPFS" != "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS IPFS IPNS" +fi +if test "$CURL_DISABLE_RTSP" != "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS RTSP" +fi +if test "$CURL_DISABLE_WEBSOCKETS" != "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS WS" + if test "$SSL_ENABLED" = "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS WSS" + fi +fi + +SUPPORT_PROTOCOLS=`echo $SUPPORT_PROTOCOLS | tr ' ' '\012' | sort | tr '\012' ' '` + + + + +squeeze CFLAGS +squeeze CPPFLAGS +squeeze DEFS +squeeze LDFLAGS +squeeze LIBS + +squeeze LIBCURL_PC_LDFLAGS_PRIVATE +squeeze LIBCURL_PC_LIBS_PRIVATE +squeeze CURL_NETWORK_AND_TIME_LIBS + +squeeze SUPPORT_FEATURES +squeeze SUPPORT_PROTOCOLS + + + + + xc_bad_var_libs=no + for xc_word in $LIBS; do + case "$xc_word" in + -l* | --library=*) + : + ;; + *) + xc_bad_var_libs=yes + ;; + esac + done + if test "$xc_bad_var_libs" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: using LIBS: $LIBS" >&5 +printf "%s\n" "$as_me: using LIBS: $LIBS" >&6;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: LIBS note: LIBS should only be used to specify libraries (-lname)." >&5 +printf "%s\n" "$as_me: LIBS note: LIBS should only be used to specify libraries (-lname)." >&6;} + fi + + + xc_bad_var_ldflags=no + for xc_word in $LDFLAGS; do + case "$xc_word" in + -D*) + xc_bad_var_ldflags=yes + ;; + -U*) + xc_bad_var_ldflags=yes + ;; + -I*) + xc_bad_var_ldflags=yes + ;; + -l* | --library=*) + xc_bad_var_ldflags=yes + ;; + esac + done + if test "$xc_bad_var_ldflags" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: using LDFLAGS: $LDFLAGS" >&5 +printf "%s\n" "$as_me: using LDFLAGS: $LDFLAGS" >&6;} + xc_bad_var_msg="LDFLAGS note: LDFLAGS should only be used to specify linker flags, not" + for xc_word in $LDFLAGS; do + case "$xc_word" in + -D*) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $xc_bad_var_msg macro definitions. Use CPPFLAGS for: $xc_word" >&5 +printf "%s\n" "$as_me: $xc_bad_var_msg macro definitions. Use CPPFLAGS for: $xc_word" >&6;} + ;; + -U*) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $xc_bad_var_msg macro suppressions. Use CPPFLAGS for: $xc_word" >&5 +printf "%s\n" "$as_me: $xc_bad_var_msg macro suppressions. Use CPPFLAGS for: $xc_word" >&6;} + ;; + -I*) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $xc_bad_var_msg include directories. Use CPPFLAGS for: $xc_word" >&5 +printf "%s\n" "$as_me: $xc_bad_var_msg include directories. Use CPPFLAGS for: $xc_word" >&6;} + ;; + -l* | --library=*) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $xc_bad_var_msg libraries. Use LIBS for: $xc_word" >&5 +printf "%s\n" "$as_me: $xc_bad_var_msg libraries. Use LIBS for: $xc_word" >&6;} + ;; + esac + done + fi + + + xc_bad_var_cppflags=no + for xc_word in $CPPFLAGS; do + case "$xc_word" in + -rpath*) + xc_bad_var_cppflags=yes + ;; + -L* | --library-path=*) + xc_bad_var_cppflags=yes + ;; + -l* | --library=*) + xc_bad_var_cppflags=yes + ;; + esac + done + if test "$xc_bad_var_cppflags" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: using CPPFLAGS: $CPPFLAGS" >&5 +printf "%s\n" "$as_me: using CPPFLAGS: $CPPFLAGS" >&6;} + xc_bad_var_msg="CPPFLAGS note: CPPFLAGS should only be used to specify C preprocessor flags, not" + for xc_word in $CPPFLAGS; do + case "$xc_word" in + -rpath*) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $xc_bad_var_msg library runtime directories. Use LDFLAGS for: $xc_word" >&5 +printf "%s\n" "$as_me: $xc_bad_var_msg library runtime directories. Use LDFLAGS for: $xc_word" >&6;} + ;; + -L* | --library-path=*) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $xc_bad_var_msg library directories. Use LDFLAGS for: $xc_word" >&5 +printf "%s\n" "$as_me: $xc_bad_var_msg library directories. Use LDFLAGS for: $xc_word" >&6;} + ;; + -l* | --library=*) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $xc_bad_var_msg libraries. Use LIBS for: $xc_word" >&5 +printf "%s\n" "$as_me: $xc_bad_var_msg libraries. Use LIBS for: $xc_word" >&6;} + ;; + esac + done + fi + + + xc_bad_var_cflags=no + for xc_word in $CFLAGS; do + case "$xc_word" in + -D*) + xc_bad_var_cflags=yes + ;; + -U*) + xc_bad_var_cflags=yes + ;; + -I*) + xc_bad_var_cflags=yes + ;; + -rpath*) + xc_bad_var_cflags=yes + ;; + -L* | --library-path=*) + xc_bad_var_cflags=yes + ;; + -l* | --library=*) + xc_bad_var_cflags=yes + ;; + esac + done + if test "$xc_bad_var_cflags" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: using CFLAGS: $CFLAGS" >&5 +printf "%s\n" "$as_me: using CFLAGS: $CFLAGS" >&6;} + xc_bad_var_msg="CFLAGS note: CFLAGS should only be used to specify C compiler flags, not" + for xc_word in $CFLAGS; do + case "$xc_word" in + -D*) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $xc_bad_var_msg macro definitions. Use CPPFLAGS for: $xc_word" >&5 +printf "%s\n" "$as_me: $xc_bad_var_msg macro definitions. Use CPPFLAGS for: $xc_word" >&6;} + ;; + -U*) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $xc_bad_var_msg macro suppressions. Use CPPFLAGS for: $xc_word" >&5 +printf "%s\n" "$as_me: $xc_bad_var_msg macro suppressions. Use CPPFLAGS for: $xc_word" >&6;} + ;; + -I*) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $xc_bad_var_msg include directories. Use CPPFLAGS for: $xc_word" >&5 +printf "%s\n" "$as_me: $xc_bad_var_msg include directories. Use CPPFLAGS for: $xc_word" >&6;} + ;; + -rpath*) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $xc_bad_var_msg library runtime directories. Use LDFLAGS for: $xc_word" >&5 +printf "%s\n" "$as_me: $xc_bad_var_msg library runtime directories. Use LDFLAGS for: $xc_word" >&6;} + ;; + -L* | --library-path=*) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $xc_bad_var_msg library directories. Use LDFLAGS for: $xc_word" >&5 +printf "%s\n" "$as_me: $xc_bad_var_msg library directories. Use LDFLAGS for: $xc_word" >&6;} + ;; + -l* | --library=*) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $xc_bad_var_msg libraries. Use LIBS for: $xc_word" >&5 +printf "%s\n" "$as_me: $xc_bad_var_msg libraries. Use LIBS for: $xc_word" >&6;} + ;; + esac + done + fi + + if test "$xc_bad_var_libs" = "yes" || + test "$xc_bad_var_cflags" = "yes" || + test "$xc_bad_var_ldflags" = "yes" || + test "$xc_bad_var_cppflags" = "yes"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: Continuing even with errors mentioned immediately above this line." >&5 +printf "%s\n" "$as_me: WARNING: Continuing even with errors mentioned immediately above this line." >&2;} + fi + + +SSL_BACKENDS=${ssl_backends} + + + + + tmp_cpp=`eval echo "$ac_cpp" 2>/dev/null` + if test -z "$tmp_cpp"; then + tmp_cpp='cpp' + fi + CURL_CPP=$tmp_cpp + + + +ac_config_files="$ac_config_files Makefile docs/Makefile docs/examples/Makefile docs/libcurl/Makefile docs/libcurl/opts/Makefile docs/cmdline-opts/Makefile include/Makefile include/curl/Makefile src/Makefile lib/Makefile scripts/Makefile lib/libcurl.vers tests/Makefile tests/config tests/configurehelp.pm tests/certs/Makefile tests/data/Makefile tests/server/Makefile tests/libtest/Makefile tests/unit/Makefile tests/tunit/Makefile tests/http/config.ini tests/http/Makefile projects/Makefile projects/vms/Makefile libcurl.pc" + +ac_config_files="$ac_config_files curl-config" + +cat >confcache <<\_ACEOF +# This file is a shell script that caches the results of configure +# tests run on this system so they can be shared between configure +# scripts and configure runs, see configure's option --config-cache. +# It is not useful on other systems. If it contains results you don't +# want to keep, you may remove or edit it. +# +# config.status only pays attention to the cache file if you give it +# the --recheck option to rerun configure. +# +# `ac_cv_env_foo' variables (set or unset) will be overridden when +# loading this file, other *unset* `ac_cv_foo' will be assigned the +# following values. + +_ACEOF + +# The following way of writing the cache mishandles newlines in values, +# but we know of no workaround that is simple, portable, and efficient. +# So, we kill variables containing newlines. +# Ultrix sh set writes to stderr and can't be redirected directly, +# and sets the high bit in the cache file unless we assign to the vars. +( + for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do + eval ac_val=\$$ac_var + case $ac_val in #( + *${as_nl}*) + case $ac_var in #( + *_cv_*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 +printf "%s\n" "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; + esac + case $ac_var in #( + _ | IFS | as_nl) ;; #( + BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( + *) { eval $ac_var=; unset $ac_var;} ;; + esac ;; + esac + done + + (set) 2>&1 | + case $as_nl`(ac_space=' '; set) 2>&1` in #( + *${as_nl}ac_space=\ *) + # `set' does not quote correctly, so add quotes: double-quote + # substitution turns \\\\ into \\, and sed turns \\ into \. + sed -n \ + "s/'/'\\\\''/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" + ;; #( + *) + # `set' quotes correctly as required by POSIX, so do not add quotes. + sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" + ;; + esac | + sort +) | + sed ' + /^ac_cv_env_/b end + t clear + :clear + s/^\([^=]*\)=\(.*[{}].*\)$/test ${\1+y} || &/ + t end + s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ + :end' >>confcache +if diff "$cache_file" confcache >/dev/null 2>&1; then :; else + if test -w "$cache_file"; then + if test "x$cache_file" != "x/dev/null"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 +printf "%s\n" "$as_me: updating cache $cache_file" >&6;} + if test ! -f "$cache_file" || test -h "$cache_file"; then + cat confcache >"$cache_file" + else + case $cache_file in #( + */* | ?:*) + mv -f confcache "$cache_file"$$ && + mv -f "$cache_file"$$ "$cache_file" ;; #( + *) + mv -f confcache "$cache_file" ;; + esac + fi + fi + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 +printf "%s\n" "$as_me: not updating unwritable cache $cache_file" >&6;} + fi +fi +rm -f confcache + +test "x$prefix" = xNONE && prefix=$ac_default_prefix +# Let make expand exec_prefix. +test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' + +DEFS=-DHAVE_CONFIG_H + +ac_libobjs= +ac_ltlibobjs= +U= +for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue + # 1. Remove the extension, and $U if already installed. + ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' + ac_i=`printf "%s\n" "$ac_i" | sed "$ac_script"` + # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR + # will be set to the directory where LIBOBJS objects are built. + as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" + as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' +done +LIBOBJS=$ac_libobjs + +LTLIBOBJS=$ac_ltlibobjs + + +if test -z "${MAINTAINER_MODE_TRUE}" && test -z "${MAINTAINER_MODE_FALSE}"; then + as_fn_error $? "conditional \"MAINTAINER_MODE\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi +if test -z "${DEBUGBUILD_TRUE}" && test -z "${DEBUGBUILD_FALSE}"; then + as_fn_error $? "conditional \"DEBUGBUILD\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking that generated files are newer than configure" >&5 +printf %s "checking that generated files are newer than configure... " >&6; } + if test -n "$am_sleep_pid"; then + # Hide warnings about reused PIDs. + wait $am_sleep_pid 2>/dev/null + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: done" >&5 +printf "%s\n" "done" >&6; } +if test -z "${AMDEP_TRUE}" && test -z "${AMDEP_FALSE}"; then + as_fn_error $? "conditional \"AMDEP\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi +if test -z "${am__fastdepCC_TRUE}" && test -z "${am__fastdepCC_FALSE}"; then + as_fn_error $? "conditional \"am__fastdepCC\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi + if test -n "$EXEEXT"; then + am__EXEEXT_TRUE= + am__EXEEXT_FALSE='#' +else + am__EXEEXT_TRUE='#' + am__EXEEXT_FALSE= +fi + +if test -z "${PERL_TRUE}" && test -z "${PERL_FALSE}"; then + as_fn_error $? "conditional \"PERL\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi +if test -z "${NOT_CURL_CI_TRUE}" && test -z "${NOT_CURL_CI_FALSE}"; then + as_fn_error $? "conditional \"NOT_CURL_CI\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi +if test -z "${CURL_LT_SHLIB_USE_VERSION_INFO_TRUE}" && test -z "${CURL_LT_SHLIB_USE_VERSION_INFO_FALSE}"; then + as_fn_error $? "conditional \"CURL_LT_SHLIB_USE_VERSION_INFO\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi +if test -z "${CURL_LT_SHLIB_USE_NO_UNDEFINED_TRUE}" && test -z "${CURL_LT_SHLIB_USE_NO_UNDEFINED_FALSE}"; then + as_fn_error $? "conditional \"CURL_LT_SHLIB_USE_NO_UNDEFINED\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi +if test -z "${CURL_LT_SHLIB_USE_MIMPURE_TEXT_TRUE}" && test -z "${CURL_LT_SHLIB_USE_MIMPURE_TEXT_FALSE}"; then + as_fn_error $? "conditional \"CURL_LT_SHLIB_USE_MIMPURE_TEXT\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi +if test -z "${USE_CPPFLAG_CURL_STATICLIB_TRUE}" && test -z "${USE_CPPFLAG_CURL_STATICLIB_FALSE}"; then + as_fn_error $? "conditional \"USE_CPPFLAG_CURL_STATICLIB\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi +if test -z "${DOING_NATIVE_WINDOWS_TRUE}" && test -z "${DOING_NATIVE_WINDOWS_FALSE}"; then + as_fn_error $? "conditional \"DOING_NATIVE_WINDOWS\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi +if test -z "${CURL_WERROR_TRUE}" && test -z "${CURL_WERROR_FALSE}"; then + as_fn_error $? "conditional \"CURL_WERROR\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi +if test -z "${BUILD_UNITTESTS_TRUE}" && test -z "${BUILD_UNITTESTS_FALSE}"; then + as_fn_error $? "conditional \"BUILD_UNITTESTS\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi +if test -z "${CLANG_TRUE}" && test -z "${CLANG_FALSE}"; then + as_fn_error $? "conditional \"CLANG\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi +if test -z "${HAVE_WINDRES_TRUE}" && test -z "${HAVE_WINDRES_FALSE}"; then + as_fn_error $? "conditional \"HAVE_WINDRES\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi +if test -z "${USE_UNITY_TRUE}" && test -z "${USE_UNITY_FALSE}"; then + as_fn_error $? "conditional \"USE_UNITY\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi +if test -z "${DOING_NATIVE_WINDOWS_TRUE}" && test -z "${DOING_NATIVE_WINDOWS_FALSE}"; then + as_fn_error $? "conditional \"DOING_NATIVE_WINDOWS\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi +if test -z "${HAVE_LIBZ_TRUE}" && test -z "${HAVE_LIBZ_FALSE}"; then + as_fn_error $? "conditional \"HAVE_LIBZ\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi +if test -z "${BUILD_STUB_GSS_TRUE}" && test -z "${BUILD_STUB_GSS_FALSE}"; then + as_fn_error $? "conditional \"BUILD_STUB_GSS\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi +if test -z "${CURL_CA_EMBED_SET_TRUE}" && test -z "${CURL_CA_EMBED_SET_FALSE}"; then + as_fn_error $? "conditional \"CURL_CA_EMBED_SET\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi +if test -z "${USE_LIBPSL_TRUE}" && test -z "${USE_LIBPSL_FALSE}"; then + as_fn_error $? "conditional \"USE_LIBPSL\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi +if test -z "${USE_GSASL_TRUE}" && test -z "${USE_GSASL_FALSE}"; then + as_fn_error $? "conditional \"USE_GSASL\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi +if test -z "${CURL_LT_SHLIB_USE_VERSIONED_SYMBOLS_TRUE}" && test -z "${CURL_LT_SHLIB_USE_VERSIONED_SYMBOLS_FALSE}"; then + as_fn_error $? "conditional \"CURL_LT_SHLIB_USE_VERSIONED_SYMBOLS\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi +if test -z "${USE_UNICODE_TRUE}" && test -z "${USE_UNICODE_FALSE}"; then + as_fn_error $? "conditional \"USE_UNICODE\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi +if test -z "${USE_ZSH_COMPLETION_TRUE}" && test -z "${USE_ZSH_COMPLETION_FALSE}"; then + as_fn_error $? "conditional \"USE_ZSH_COMPLETION\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi +if test -z "${USE_FISH_COMPLETION_TRUE}" && test -z "${USE_FISH_COMPLETION_FALSE}"; then + as_fn_error $? "conditional \"USE_FISH_COMPLETION\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi +if test -z "${DOING_NATIVE_WINDOWS_TRUE}" && test -z "${DOING_NATIVE_WINDOWS_FALSE}"; then + as_fn_error $? "conditional \"DOING_NATIVE_WINDOWS\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi +if test -z "${BUILD_DOCS_TRUE}" && test -z "${BUILD_DOCS_FALSE}"; then + as_fn_error $? "conditional \"BUILD_DOCS\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi +if test -z "${USE_MANUAL_TRUE}" && test -z "${USE_MANUAL_FALSE}"; then + as_fn_error $? "conditional \"USE_MANUAL\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi +if test -z "${DOING_CURL_SYMBOL_HIDING_TRUE}" && test -z "${DOING_CURL_SYMBOL_HIDING_FALSE}"; then + as_fn_error $? "conditional \"DOING_CURL_SYMBOL_HIDING\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi +if test -z "${CROSSCOMPILING_TRUE}" && test -z "${CROSSCOMPILING_FALSE}"; then + as_fn_error $? "conditional \"CROSSCOMPILING\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi + +: "${CONFIG_STATUS=./config.status}" +ac_write_fail=0 +ac_clean_files_save=$ac_clean_files +ac_clean_files="$ac_clean_files $CONFIG_STATUS" +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 +printf "%s\n" "$as_me: creating $CONFIG_STATUS" >&6;} +as_write_fail=0 +cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 +#! $SHELL +# Generated by $as_me. +# Run this file to recreate the current configuration. +# Compiler output produced by configure, useful for debugging +# configure, is in config.log if it exists. + +debug=false +ac_cs_recheck=false +ac_cs_silent=false + +SHELL=\${CONFIG_SHELL-$SHELL} +export SHELL +_ASEOF +cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 +## -------------------- ## +## M4sh Initialization. ## +## -------------------- ## + +# Be more Bourne compatible +DUALCASE=1; export DUALCASE # for MKS sh +as_nop=: +if test ${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1 +then : + emulate sh + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which + # is contrary to our usage. Disable this feature. + alias -g '${1+"$@"}'='"$@"' + setopt NO_GLOB_SUBST +else $as_nop + case `(set -o) 2>/dev/null` in #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi + + + +# Reset variables that may have inherited troublesome values from +# the environment. + +# IFS needs to be set, to space, tab, and newline, in precisely that order. +# (If _AS_PATH_WALK were called with IFS unset, it would have the +# side effect of setting IFS to empty, thus disabling word splitting.) +# Quoting is to prevent editors from complaining about space-tab. +as_nl=' +' +export as_nl +IFS=" "" $as_nl" + +PS1='$ ' +PS2='> ' +PS4='+ ' + +# Ensure predictable behavior from utilities with locale-dependent output. +LC_ALL=C +export LC_ALL +LANGUAGE=C +export LANGUAGE + +# We cannot yet rely on "unset" to work, but we need these variables +# to be unset--not just set to an empty or harmless value--now, to +# avoid bugs in old shells (e.g. pre-3.0 UWIN ksh). This construct +# also avoids known problems related to "unset" and subshell syntax +# in other old shells (e.g. bash 2.01 and pdksh 5.2.14). +for as_var in BASH_ENV ENV MAIL MAILPATH CDPATH +do eval test \${$as_var+y} \ + && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : +done + +# Ensure that fds 0, 1, and 2 are open. +if (exec 3>&0) 2>/dev/null; then :; else exec 0&1) 2>/dev/null; then :; else exec 1>/dev/null; fi +if (exec 3>&2) ; then :; else exec 2>/dev/null; fi + + + +# Find who we are. Look in the path if we contain no directory separator. +as_myself= +case $0 in #(( + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + test -r "$as_dir$0" && as_myself=$as_dir$0 && break + done +IFS=$as_save_IFS + + ;; +esac +# We did not find ourselves, most probably we were run as `sh COMMAND' +# in which case we are not to be found in the path. +if test "x$as_myself" = x; then + as_myself=$0 +fi +if test ! -f "$as_myself"; then + printf "%s\n" "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 + exit 1 +fi + + + +# as_fn_error STATUS ERROR [LINENO LOG_FD] +# ---------------------------------------- +# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are +# provided, also output the error to LOG_FD, referencing LINENO. Then exit the +# script with STATUS, using 1 if that was 0. +as_fn_error () +{ + as_status=$1; test $as_status -eq 0 && as_status=1 + if test "$4"; then + as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 + fi + printf "%s\n" "$as_me: error: $2" >&2 + as_fn_exit $as_status +} # as_fn_error + + + +# as_fn_set_status STATUS +# ----------------------- +# Set $? to STATUS, without forking. +as_fn_set_status () +{ + return $1 +} # as_fn_set_status + +# as_fn_exit STATUS +# ----------------- +# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. +as_fn_exit () +{ + set +e + as_fn_set_status $1 + exit $1 +} # as_fn_exit + +# as_fn_unset VAR +# --------------- +# Portably unset VAR. +as_fn_unset () +{ + { eval $1=; unset $1;} +} +as_unset=as_fn_unset + +# as_fn_append VAR VALUE +# ---------------------- +# Append the text in VALUE to the end of the definition contained in VAR. Take +# advantage of any shell optimizations that allow amortized linear growth over +# repeated appends, instead of the typical quadratic growth present in naive +# implementations. +if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null +then : + eval 'as_fn_append () + { + eval $1+=\$2 + }' +else $as_nop + as_fn_append () + { + eval $1=\$$1\$2 + } +fi # as_fn_append + +# as_fn_arith ARG... +# ------------------ +# Perform arithmetic evaluation on the ARGs, and store the result in the +# global $as_val. Take advantage of shells that can avoid forks. The arguments +# must be portable across $(()) and expr. +if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null +then : + eval 'as_fn_arith () + { + as_val=$(( $* )) + }' +else $as_nop + as_fn_arith () + { + as_val=`expr "$@" || test $? -eq 1` + } +fi # as_fn_arith + + +if expr a : '\(a\)' >/dev/null 2>&1 && + test "X`expr 00001 : '.*\(...\)'`" = X001; then + as_expr=expr +else + as_expr=false +fi + +if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then + as_basename=basename +else + as_basename=false +fi + +if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then + as_dirname=dirname +else + as_dirname=false +fi + +as_me=`$as_basename -- "$0" || +$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)' \| . 2>/dev/null || +printf "%s\n" X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ + s//\1/ + q + } + /^X\/\(\/\/\)$/{ + s//\1/ + q + } + /^X\/\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + +# Avoid depending upon Character Ranges. +as_cr_letters='abcdefghijklmnopqrstuvwxyz' +as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' +as_cr_Letters=$as_cr_letters$as_cr_LETTERS +as_cr_digits='0123456789' +as_cr_alnum=$as_cr_Letters$as_cr_digits + + +# Determine whether it's possible to make 'echo' print without a newline. +# These variables are no longer used directly by Autoconf, but are AC_SUBSTed +# for compatibility with existing Makefiles. +ECHO_C= ECHO_N= ECHO_T= +case `echo -n x` in #((((( +-n*) + case `echo 'xy\c'` in + *c*) ECHO_T=' ';; # ECHO_T is single tab character. + xy) ECHO_C='\c';; + *) echo `echo ksh88 bug on AIX 6.1` > /dev/null + ECHO_T=' ';; + esac;; +*) + ECHO_N='-n';; +esac + +# For backward compatibility with old third-party macros, we provide +# the shell variables $as_echo and $as_echo_n. New code should use +# AS_ECHO(["message"]) and AS_ECHO_N(["message"]), respectively. +as_echo='printf %s\n' +as_echo_n='printf %s' + +rm -f conf$$ conf$$.exe conf$$.file +if test -d conf$$.dir; then + rm -f conf$$.dir/conf$$.file +else + rm -f conf$$.dir + mkdir conf$$.dir 2>/dev/null +fi +if (echo >conf$$.file) 2>/dev/null; then + if ln -s conf$$.file conf$$ 2>/dev/null; then + as_ln_s='ln -s' + # ... but there are two gotchas: + # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. + # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. + # In both cases, we have to default to `cp -pR'. + ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || + as_ln_s='cp -pR' + elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln + else + as_ln_s='cp -pR' + fi +else + as_ln_s='cp -pR' +fi +rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file +rmdir conf$$.dir 2>/dev/null + + +# as_fn_mkdir_p +# ------------- +# Create "$as_dir" as a directory, including parents if necessary. +as_fn_mkdir_p () +{ + + case $as_dir in #( + -*) as_dir=./$as_dir;; + esac + test -d "$as_dir" || eval $as_mkdir_p || { + as_dirs= + while :; do + case $as_dir in #( + *\'*) as_qdir=`printf "%s\n" "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( + *) as_qdir=$as_dir;; + esac + as_dirs="'$as_qdir' $as_dirs" + as_dir=`$as_dirname -- "$as_dir" || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || +printf "%s\n" X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + test -d "$as_dir" && break + done + test -z "$as_dirs" || eval "mkdir $as_dirs" + } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" + + +} # as_fn_mkdir_p +if mkdir -p . 2>/dev/null; then + as_mkdir_p='mkdir -p "$as_dir"' +else + test -d ./-p && rmdir ./-p + as_mkdir_p=false +fi + + +# as_fn_executable_p FILE +# ----------------------- +# Test if FILE is an executable regular file. +as_fn_executable_p () +{ + test -f "$1" && test -x "$1" +} # as_fn_executable_p +as_test_x='test -x' +as_executable_p=as_fn_executable_p + +# Sed expression to map a string onto a valid CPP name. +as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" + +# Sed expression to map a string onto a valid variable name. +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" + + +exec 6>&1 +## ----------------------------------- ## +## Main body of $CONFIG_STATUS script. ## +## ----------------------------------- ## +_ASEOF +test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +# Save the log message, to keep $0 and so on meaningful, and to +# report actual input values of CONFIG_FILES etc. instead of their +# values after options handling. +ac_log=" +This file was extended by curl $as_me -, which was +generated by GNU Autoconf 2.71. Invocation command line was + + CONFIG_FILES = $CONFIG_FILES + CONFIG_HEADERS = $CONFIG_HEADERS + CONFIG_LINKS = $CONFIG_LINKS + CONFIG_COMMANDS = $CONFIG_COMMANDS + $ $0 $@ + +on `(hostname || uname -n) 2>/dev/null | sed 1q` +" + +_ACEOF + +case $ac_config_files in *" +"*) set x $ac_config_files; shift; ac_config_files=$*;; +esac + +case $ac_config_headers in *" +"*) set x $ac_config_headers; shift; ac_config_headers=$*;; +esac + + +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +# Files that config.status was made for. +config_files="$ac_config_files" +config_headers="$ac_config_headers" +config_commands="$ac_config_commands" + +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +ac_cs_usage="\ +\`$as_me' instantiates files and other configuration actions +from templates according to the current configuration. Unless the files +and actions are specified as TAGs, all are instantiated by default. + +Usage: $0 [OPTION]... [TAG]... + + -h, --help print this help, then exit + -V, --version print version number and configuration settings, then exit + --config print configuration, then exit + -q, --quiet, --silent + do not print progress messages + -d, --debug don't remove temporary files + --recheck update $as_me by reconfiguring in the same conditions + --file=FILE[:TEMPLATE] + instantiate the configuration file FILE + --header=FILE[:TEMPLATE] + instantiate the configuration header FILE + +Configuration files: +$config_files + +Configuration headers: +$config_headers + +Configuration commands: +$config_commands + +Report bugs to ." + +_ACEOF +ac_cs_config=`printf "%s\n" "$ac_configure_args" | sed "$ac_safe_unquote"` +ac_cs_config_escaped=`printf "%s\n" "$ac_cs_config" | sed "s/^ //; s/'/'\\\\\\\\''/g"` +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +ac_cs_config='$ac_cs_config_escaped' +ac_cs_version="\\ +curl config.status - +configured by $0, generated by GNU Autoconf 2.71, + with options \\"\$ac_cs_config\\" + +Copyright (C) 2021 Free Software Foundation, Inc. +This config.status script is free software; the Free Software Foundation +gives unlimited permission to copy, distribute and modify it." + +ac_pwd='$ac_pwd' +srcdir='$srcdir' +INSTALL='$INSTALL' +MKDIR_P='$MKDIR_P' +AWK='$AWK' +test -n "\$AWK" || AWK=awk +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +# The default lists apply if the user does not specify any file. +ac_need_defaults=: +while test $# != 0 +do + case $1 in + --*=?*) + ac_option=`expr "X$1" : 'X\([^=]*\)='` + ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` + ac_shift=: + ;; + --*=) + ac_option=`expr "X$1" : 'X\([^=]*\)='` + ac_optarg= + ac_shift=: + ;; + *) + ac_option=$1 + ac_optarg=$2 + ac_shift=shift + ;; + esac + + case $ac_option in + # Handling of the options. + -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) + ac_cs_recheck=: ;; + --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) + printf "%s\n" "$ac_cs_version"; exit ;; + --config | --confi | --conf | --con | --co | --c ) + printf "%s\n" "$ac_cs_config"; exit ;; + --debug | --debu | --deb | --de | --d | -d ) + debug=: ;; + --file | --fil | --fi | --f ) + $ac_shift + case $ac_optarg in + *\'*) ac_optarg=`printf "%s\n" "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; + '') as_fn_error $? "missing file argument" ;; + esac + as_fn_append CONFIG_FILES " '$ac_optarg'" + ac_need_defaults=false;; + --header | --heade | --head | --hea ) + $ac_shift + case $ac_optarg in + *\'*) ac_optarg=`printf "%s\n" "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; + esac + as_fn_append CONFIG_HEADERS " '$ac_optarg'" + ac_need_defaults=false;; + --he | --h) + # Conflict between --help and --header + as_fn_error $? "ambiguous option: \`$1' +Try \`$0 --help' for more information.";; + --help | --hel | -h ) + printf "%s\n" "$ac_cs_usage"; exit ;; + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil | --si | --s) + ac_cs_silent=: ;; + + # This is an error. + -*) as_fn_error $? "unrecognized option: \`$1' +Try \`$0 --help' for more information." ;; + + *) as_fn_append ac_config_targets " $1" + ac_need_defaults=false ;; + + esac + shift +done + +ac_configure_extra_args= + +if $ac_cs_silent; then + exec 6>/dev/null + ac_configure_extra_args="$ac_configure_extra_args --silent" +fi + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +if \$ac_cs_recheck; then + set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion + shift + \printf "%s\n" "running CONFIG_SHELL=$SHELL \$*" >&6 + CONFIG_SHELL='$SHELL' + export CONFIG_SHELL + exec "\$@" +fi + +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +exec 5>>config.log +{ + echo + sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX +## Running $as_me. ## +_ASBOX + printf "%s\n" "$ac_log" +} >&5 + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +# +# INIT-COMMANDS +# +AMDEP_TRUE="$AMDEP_TRUE" MAKE="${MAKE-make}" + + +# The HP-UX ksh and POSIX shell print the target directory to stdout +# if CDPATH is set. +(unset CDPATH) >/dev/null 2>&1 && unset CDPATH + +sed_quote_subst='$sed_quote_subst' +double_quote_subst='$double_quote_subst' +delay_variable_subst='$delay_variable_subst' +macro_version='`$ECHO "$macro_version" | $SED "$delay_single_quote_subst"`' +macro_revision='`$ECHO "$macro_revision" | $SED "$delay_single_quote_subst"`' +AS='`$ECHO "$AS" | $SED "$delay_single_quote_subst"`' +DLLTOOL='`$ECHO "$DLLTOOL" | $SED "$delay_single_quote_subst"`' +OBJDUMP='`$ECHO "$OBJDUMP" | $SED "$delay_single_quote_subst"`' +enable_shared='`$ECHO "$enable_shared" | $SED "$delay_single_quote_subst"`' +enable_static='`$ECHO "$enable_static" | $SED "$delay_single_quote_subst"`' +pic_mode='`$ECHO "$pic_mode" | $SED "$delay_single_quote_subst"`' +enable_fast_install='`$ECHO "$enable_fast_install" | $SED "$delay_single_quote_subst"`' +shared_archive_member_spec='`$ECHO "$shared_archive_member_spec" | $SED "$delay_single_quote_subst"`' +SHELL='`$ECHO "$SHELL" | $SED "$delay_single_quote_subst"`' +ECHO='`$ECHO "$ECHO" | $SED "$delay_single_quote_subst"`' +PATH_SEPARATOR='`$ECHO "$PATH_SEPARATOR" | $SED "$delay_single_quote_subst"`' +host_alias='`$ECHO "$host_alias" | $SED "$delay_single_quote_subst"`' +host='`$ECHO "$host" | $SED "$delay_single_quote_subst"`' +host_os='`$ECHO "$host_os" | $SED "$delay_single_quote_subst"`' +build_alias='`$ECHO "$build_alias" | $SED "$delay_single_quote_subst"`' +build='`$ECHO "$build" | $SED "$delay_single_quote_subst"`' +build_os='`$ECHO "$build_os" | $SED "$delay_single_quote_subst"`' +SED='`$ECHO "$SED" | $SED "$delay_single_quote_subst"`' +Xsed='`$ECHO "$Xsed" | $SED "$delay_single_quote_subst"`' +GREP='`$ECHO "$GREP" | $SED "$delay_single_quote_subst"`' +EGREP='`$ECHO "$EGREP" | $SED "$delay_single_quote_subst"`' +FGREP='`$ECHO "$FGREP" | $SED "$delay_single_quote_subst"`' +LD='`$ECHO "$LD" | $SED "$delay_single_quote_subst"`' +NM='`$ECHO "$NM" | $SED "$delay_single_quote_subst"`' +LN_S='`$ECHO "$LN_S" | $SED "$delay_single_quote_subst"`' +max_cmd_len='`$ECHO "$max_cmd_len" | $SED "$delay_single_quote_subst"`' +ac_objext='`$ECHO "$ac_objext" | $SED "$delay_single_quote_subst"`' +exeext='`$ECHO "$exeext" | $SED "$delay_single_quote_subst"`' +lt_unset='`$ECHO "$lt_unset" | $SED "$delay_single_quote_subst"`' +lt_SP2NL='`$ECHO "$lt_SP2NL" | $SED "$delay_single_quote_subst"`' +lt_NL2SP='`$ECHO "$lt_NL2SP" | $SED "$delay_single_quote_subst"`' +lt_cv_to_host_file_cmd='`$ECHO "$lt_cv_to_host_file_cmd" | $SED "$delay_single_quote_subst"`' +lt_cv_to_tool_file_cmd='`$ECHO "$lt_cv_to_tool_file_cmd" | $SED "$delay_single_quote_subst"`' +reload_flag='`$ECHO "$reload_flag" | $SED "$delay_single_quote_subst"`' +reload_cmds='`$ECHO "$reload_cmds" | $SED "$delay_single_quote_subst"`' +FILECMD='`$ECHO "$FILECMD" | $SED "$delay_single_quote_subst"`' +deplibs_check_method='`$ECHO "$deplibs_check_method" | $SED "$delay_single_quote_subst"`' +file_magic_cmd='`$ECHO "$file_magic_cmd" | $SED "$delay_single_quote_subst"`' +file_magic_glob='`$ECHO "$file_magic_glob" | $SED "$delay_single_quote_subst"`' +want_nocaseglob='`$ECHO "$want_nocaseglob" | $SED "$delay_single_quote_subst"`' +sharedlib_from_linklib_cmd='`$ECHO "$sharedlib_from_linklib_cmd" | $SED "$delay_single_quote_subst"`' +AR='`$ECHO "$AR" | $SED "$delay_single_quote_subst"`' +lt_ar_flags='`$ECHO "$lt_ar_flags" | $SED "$delay_single_quote_subst"`' +AR_FLAGS='`$ECHO "$AR_FLAGS" | $SED "$delay_single_quote_subst"`' +archiver_list_spec='`$ECHO "$archiver_list_spec" | $SED "$delay_single_quote_subst"`' +STRIP='`$ECHO "$STRIP" | $SED "$delay_single_quote_subst"`' +RANLIB='`$ECHO "$RANLIB" | $SED "$delay_single_quote_subst"`' +old_postinstall_cmds='`$ECHO "$old_postinstall_cmds" | $SED "$delay_single_quote_subst"`' +old_postuninstall_cmds='`$ECHO "$old_postuninstall_cmds" | $SED "$delay_single_quote_subst"`' +old_archive_cmds='`$ECHO "$old_archive_cmds" | $SED "$delay_single_quote_subst"`' +lock_old_archive_extraction='`$ECHO "$lock_old_archive_extraction" | $SED "$delay_single_quote_subst"`' +CC='`$ECHO "$CC" | $SED "$delay_single_quote_subst"`' +CFLAGS='`$ECHO "$CFLAGS" | $SED "$delay_single_quote_subst"`' +compiler='`$ECHO "$compiler" | $SED "$delay_single_quote_subst"`' +GCC='`$ECHO "$GCC" | $SED "$delay_single_quote_subst"`' +lt_cv_sys_global_symbol_pipe='`$ECHO "$lt_cv_sys_global_symbol_pipe" | $SED "$delay_single_quote_subst"`' +lt_cv_sys_global_symbol_to_cdecl='`$ECHO "$lt_cv_sys_global_symbol_to_cdecl" | $SED "$delay_single_quote_subst"`' +lt_cv_sys_global_symbol_to_import='`$ECHO "$lt_cv_sys_global_symbol_to_import" | $SED "$delay_single_quote_subst"`' +lt_cv_sys_global_symbol_to_c_name_address='`$ECHO "$lt_cv_sys_global_symbol_to_c_name_address" | $SED "$delay_single_quote_subst"`' +lt_cv_sys_global_symbol_to_c_name_address_lib_prefix='`$ECHO "$lt_cv_sys_global_symbol_to_c_name_address_lib_prefix" | $SED "$delay_single_quote_subst"`' +lt_cv_nm_interface='`$ECHO "$lt_cv_nm_interface" | $SED "$delay_single_quote_subst"`' +nm_file_list_spec='`$ECHO "$nm_file_list_spec" | $SED "$delay_single_quote_subst"`' +lt_sysroot='`$ECHO "$lt_sysroot" | $SED "$delay_single_quote_subst"`' +lt_cv_truncate_bin='`$ECHO "$lt_cv_truncate_bin" | $SED "$delay_single_quote_subst"`' +objdir='`$ECHO "$objdir" | $SED "$delay_single_quote_subst"`' +MAGIC_CMD='`$ECHO "$MAGIC_CMD" | $SED "$delay_single_quote_subst"`' +lt_prog_compiler_no_builtin_flag='`$ECHO "$lt_prog_compiler_no_builtin_flag" | $SED "$delay_single_quote_subst"`' +lt_prog_compiler_pic='`$ECHO "$lt_prog_compiler_pic" | $SED "$delay_single_quote_subst"`' +lt_prog_compiler_wl='`$ECHO "$lt_prog_compiler_wl" | $SED "$delay_single_quote_subst"`' +lt_prog_compiler_static='`$ECHO "$lt_prog_compiler_static" | $SED "$delay_single_quote_subst"`' +lt_cv_prog_compiler_c_o='`$ECHO "$lt_cv_prog_compiler_c_o" | $SED "$delay_single_quote_subst"`' +need_locks='`$ECHO "$need_locks" | $SED "$delay_single_quote_subst"`' +MANIFEST_TOOL='`$ECHO "$MANIFEST_TOOL" | $SED "$delay_single_quote_subst"`' +DSYMUTIL='`$ECHO "$DSYMUTIL" | $SED "$delay_single_quote_subst"`' +NMEDIT='`$ECHO "$NMEDIT" | $SED "$delay_single_quote_subst"`' +LIPO='`$ECHO "$LIPO" | $SED "$delay_single_quote_subst"`' +OTOOL='`$ECHO "$OTOOL" | $SED "$delay_single_quote_subst"`' +OTOOL64='`$ECHO "$OTOOL64" | $SED "$delay_single_quote_subst"`' +libext='`$ECHO "$libext" | $SED "$delay_single_quote_subst"`' +shrext_cmds='`$ECHO "$shrext_cmds" | $SED "$delay_single_quote_subst"`' +extract_expsyms_cmds='`$ECHO "$extract_expsyms_cmds" | $SED "$delay_single_quote_subst"`' +archive_cmds_need_lc='`$ECHO "$archive_cmds_need_lc" | $SED "$delay_single_quote_subst"`' +enable_shared_with_static_runtimes='`$ECHO "$enable_shared_with_static_runtimes" | $SED "$delay_single_quote_subst"`' +export_dynamic_flag_spec='`$ECHO "$export_dynamic_flag_spec" | $SED "$delay_single_quote_subst"`' +whole_archive_flag_spec='`$ECHO "$whole_archive_flag_spec" | $SED "$delay_single_quote_subst"`' +compiler_needs_object='`$ECHO "$compiler_needs_object" | $SED "$delay_single_quote_subst"`' +old_archive_from_new_cmds='`$ECHO "$old_archive_from_new_cmds" | $SED "$delay_single_quote_subst"`' +old_archive_from_expsyms_cmds='`$ECHO "$old_archive_from_expsyms_cmds" | $SED "$delay_single_quote_subst"`' +archive_cmds='`$ECHO "$archive_cmds" | $SED "$delay_single_quote_subst"`' +archive_expsym_cmds='`$ECHO "$archive_expsym_cmds" | $SED "$delay_single_quote_subst"`' +module_cmds='`$ECHO "$module_cmds" | $SED "$delay_single_quote_subst"`' +module_expsym_cmds='`$ECHO "$module_expsym_cmds" | $SED "$delay_single_quote_subst"`' +with_gnu_ld='`$ECHO "$with_gnu_ld" | $SED "$delay_single_quote_subst"`' +allow_undefined_flag='`$ECHO "$allow_undefined_flag" | $SED "$delay_single_quote_subst"`' +no_undefined_flag='`$ECHO "$no_undefined_flag" | $SED "$delay_single_quote_subst"`' +hardcode_libdir_flag_spec='`$ECHO "$hardcode_libdir_flag_spec" | $SED "$delay_single_quote_subst"`' +hardcode_libdir_separator='`$ECHO "$hardcode_libdir_separator" | $SED "$delay_single_quote_subst"`' +hardcode_direct='`$ECHO "$hardcode_direct" | $SED "$delay_single_quote_subst"`' +hardcode_direct_absolute='`$ECHO "$hardcode_direct_absolute" | $SED "$delay_single_quote_subst"`' +hardcode_minus_L='`$ECHO "$hardcode_minus_L" | $SED "$delay_single_quote_subst"`' +hardcode_shlibpath_var='`$ECHO "$hardcode_shlibpath_var" | $SED "$delay_single_quote_subst"`' +hardcode_automatic='`$ECHO "$hardcode_automatic" | $SED "$delay_single_quote_subst"`' +inherit_rpath='`$ECHO "$inherit_rpath" | $SED "$delay_single_quote_subst"`' +link_all_deplibs='`$ECHO "$link_all_deplibs" | $SED "$delay_single_quote_subst"`' +always_export_symbols='`$ECHO "$always_export_symbols" | $SED "$delay_single_quote_subst"`' +export_symbols_cmds='`$ECHO "$export_symbols_cmds" | $SED "$delay_single_quote_subst"`' +exclude_expsyms='`$ECHO "$exclude_expsyms" | $SED "$delay_single_quote_subst"`' +include_expsyms='`$ECHO "$include_expsyms" | $SED "$delay_single_quote_subst"`' +prelink_cmds='`$ECHO "$prelink_cmds" | $SED "$delay_single_quote_subst"`' +postlink_cmds='`$ECHO "$postlink_cmds" | $SED "$delay_single_quote_subst"`' +file_list_spec='`$ECHO "$file_list_spec" | $SED "$delay_single_quote_subst"`' +variables_saved_for_relink='`$ECHO "$variables_saved_for_relink" | $SED "$delay_single_quote_subst"`' +need_lib_prefix='`$ECHO "$need_lib_prefix" | $SED "$delay_single_quote_subst"`' +need_version='`$ECHO "$need_version" | $SED "$delay_single_quote_subst"`' +version_type='`$ECHO "$version_type" | $SED "$delay_single_quote_subst"`' +runpath_var='`$ECHO "$runpath_var" | $SED "$delay_single_quote_subst"`' +shlibpath_var='`$ECHO "$shlibpath_var" | $SED "$delay_single_quote_subst"`' +shlibpath_overrides_runpath='`$ECHO "$shlibpath_overrides_runpath" | $SED "$delay_single_quote_subst"`' +libname_spec='`$ECHO "$libname_spec" | $SED "$delay_single_quote_subst"`' +library_names_spec='`$ECHO "$library_names_spec" | $SED "$delay_single_quote_subst"`' +soname_spec='`$ECHO "$soname_spec" | $SED "$delay_single_quote_subst"`' +install_override_mode='`$ECHO "$install_override_mode" | $SED "$delay_single_quote_subst"`' +postinstall_cmds='`$ECHO "$postinstall_cmds" | $SED "$delay_single_quote_subst"`' +postuninstall_cmds='`$ECHO "$postuninstall_cmds" | $SED "$delay_single_quote_subst"`' +finish_cmds='`$ECHO "$finish_cmds" | $SED "$delay_single_quote_subst"`' +finish_eval='`$ECHO "$finish_eval" | $SED "$delay_single_quote_subst"`' +hardcode_into_libs='`$ECHO "$hardcode_into_libs" | $SED "$delay_single_quote_subst"`' +sys_lib_search_path_spec='`$ECHO "$sys_lib_search_path_spec" | $SED "$delay_single_quote_subst"`' +configure_time_dlsearch_path='`$ECHO "$configure_time_dlsearch_path" | $SED "$delay_single_quote_subst"`' +configure_time_lt_sys_library_path='`$ECHO "$configure_time_lt_sys_library_path" | $SED "$delay_single_quote_subst"`' +hardcode_action='`$ECHO "$hardcode_action" | $SED "$delay_single_quote_subst"`' +enable_dlopen='`$ECHO "$enable_dlopen" | $SED "$delay_single_quote_subst"`' +enable_dlopen_self='`$ECHO "$enable_dlopen_self" | $SED "$delay_single_quote_subst"`' +enable_dlopen_self_static='`$ECHO "$enable_dlopen_self_static" | $SED "$delay_single_quote_subst"`' +old_striplib='`$ECHO "$old_striplib" | $SED "$delay_single_quote_subst"`' +striplib='`$ECHO "$striplib" | $SED "$delay_single_quote_subst"`' +LD_RC='`$ECHO "$LD_RC" | $SED "$delay_single_quote_subst"`' +reload_flag_RC='`$ECHO "$reload_flag_RC" | $SED "$delay_single_quote_subst"`' +reload_cmds_RC='`$ECHO "$reload_cmds_RC" | $SED "$delay_single_quote_subst"`' +old_archive_cmds_RC='`$ECHO "$old_archive_cmds_RC" | $SED "$delay_single_quote_subst"`' +compiler_RC='`$ECHO "$compiler_RC" | $SED "$delay_single_quote_subst"`' +GCC_RC='`$ECHO "$GCC_RC" | $SED "$delay_single_quote_subst"`' +lt_prog_compiler_no_builtin_flag_RC='`$ECHO "$lt_prog_compiler_no_builtin_flag_RC" | $SED "$delay_single_quote_subst"`' +lt_prog_compiler_pic_RC='`$ECHO "$lt_prog_compiler_pic_RC" | $SED "$delay_single_quote_subst"`' +lt_prog_compiler_wl_RC='`$ECHO "$lt_prog_compiler_wl_RC" | $SED "$delay_single_quote_subst"`' +lt_prog_compiler_static_RC='`$ECHO "$lt_prog_compiler_static_RC" | $SED "$delay_single_quote_subst"`' +lt_cv_prog_compiler_c_o_RC='`$ECHO "$lt_cv_prog_compiler_c_o_RC" | $SED "$delay_single_quote_subst"`' +archive_cmds_need_lc_RC='`$ECHO "$archive_cmds_need_lc_RC" | $SED "$delay_single_quote_subst"`' +enable_shared_with_static_runtimes_RC='`$ECHO "$enable_shared_with_static_runtimes_RC" | $SED "$delay_single_quote_subst"`' +export_dynamic_flag_spec_RC='`$ECHO "$export_dynamic_flag_spec_RC" | $SED "$delay_single_quote_subst"`' +whole_archive_flag_spec_RC='`$ECHO "$whole_archive_flag_spec_RC" | $SED "$delay_single_quote_subst"`' +compiler_needs_object_RC='`$ECHO "$compiler_needs_object_RC" | $SED "$delay_single_quote_subst"`' +old_archive_from_new_cmds_RC='`$ECHO "$old_archive_from_new_cmds_RC" | $SED "$delay_single_quote_subst"`' +old_archive_from_expsyms_cmds_RC='`$ECHO "$old_archive_from_expsyms_cmds_RC" | $SED "$delay_single_quote_subst"`' +archive_cmds_RC='`$ECHO "$archive_cmds_RC" | $SED "$delay_single_quote_subst"`' +archive_expsym_cmds_RC='`$ECHO "$archive_expsym_cmds_RC" | $SED "$delay_single_quote_subst"`' +module_cmds_RC='`$ECHO "$module_cmds_RC" | $SED "$delay_single_quote_subst"`' +module_expsym_cmds_RC='`$ECHO "$module_expsym_cmds_RC" | $SED "$delay_single_quote_subst"`' +with_gnu_ld_RC='`$ECHO "$with_gnu_ld_RC" | $SED "$delay_single_quote_subst"`' +allow_undefined_flag_RC='`$ECHO "$allow_undefined_flag_RC" | $SED "$delay_single_quote_subst"`' +no_undefined_flag_RC='`$ECHO "$no_undefined_flag_RC" | $SED "$delay_single_quote_subst"`' +hardcode_libdir_flag_spec_RC='`$ECHO "$hardcode_libdir_flag_spec_RC" | $SED "$delay_single_quote_subst"`' +hardcode_libdir_separator_RC='`$ECHO "$hardcode_libdir_separator_RC" | $SED "$delay_single_quote_subst"`' +hardcode_direct_RC='`$ECHO "$hardcode_direct_RC" | $SED "$delay_single_quote_subst"`' +hardcode_direct_absolute_RC='`$ECHO "$hardcode_direct_absolute_RC" | $SED "$delay_single_quote_subst"`' +hardcode_minus_L_RC='`$ECHO "$hardcode_minus_L_RC" | $SED "$delay_single_quote_subst"`' +hardcode_shlibpath_var_RC='`$ECHO "$hardcode_shlibpath_var_RC" | $SED "$delay_single_quote_subst"`' +hardcode_automatic_RC='`$ECHO "$hardcode_automatic_RC" | $SED "$delay_single_quote_subst"`' +inherit_rpath_RC='`$ECHO "$inherit_rpath_RC" | $SED "$delay_single_quote_subst"`' +link_all_deplibs_RC='`$ECHO "$link_all_deplibs_RC" | $SED "$delay_single_quote_subst"`' +always_export_symbols_RC='`$ECHO "$always_export_symbols_RC" | $SED "$delay_single_quote_subst"`' +export_symbols_cmds_RC='`$ECHO "$export_symbols_cmds_RC" | $SED "$delay_single_quote_subst"`' +exclude_expsyms_RC='`$ECHO "$exclude_expsyms_RC" | $SED "$delay_single_quote_subst"`' +include_expsyms_RC='`$ECHO "$include_expsyms_RC" | $SED "$delay_single_quote_subst"`' +prelink_cmds_RC='`$ECHO "$prelink_cmds_RC" | $SED "$delay_single_quote_subst"`' +postlink_cmds_RC='`$ECHO "$postlink_cmds_RC" | $SED "$delay_single_quote_subst"`' +file_list_spec_RC='`$ECHO "$file_list_spec_RC" | $SED "$delay_single_quote_subst"`' +hardcode_action_RC='`$ECHO "$hardcode_action_RC" | $SED "$delay_single_quote_subst"`' + +LTCC='$LTCC' +LTCFLAGS='$LTCFLAGS' +compiler='$compiler_DEFAULT' + +# A function that is used when there is no print builtin or printf. +func_fallback_echo () +{ + eval 'cat <<_LTECHO_EOF +\$1 +_LTECHO_EOF' +} + +# Quote evaled strings. +for var in AS \ +DLLTOOL \ +OBJDUMP \ +SHELL \ +ECHO \ +PATH_SEPARATOR \ +SED \ +GREP \ +EGREP \ +FGREP \ +LD \ +NM \ +LN_S \ +lt_SP2NL \ +lt_NL2SP \ +reload_flag \ +FILECMD \ +deplibs_check_method \ +file_magic_cmd \ +file_magic_glob \ +want_nocaseglob \ +sharedlib_from_linklib_cmd \ +AR \ +archiver_list_spec \ +STRIP \ +RANLIB \ +CC \ +CFLAGS \ +compiler \ +lt_cv_sys_global_symbol_pipe \ +lt_cv_sys_global_symbol_to_cdecl \ +lt_cv_sys_global_symbol_to_import \ +lt_cv_sys_global_symbol_to_c_name_address \ +lt_cv_sys_global_symbol_to_c_name_address_lib_prefix \ +lt_cv_nm_interface \ +nm_file_list_spec \ +lt_cv_truncate_bin \ +lt_prog_compiler_no_builtin_flag \ +lt_prog_compiler_pic \ +lt_prog_compiler_wl \ +lt_prog_compiler_static \ +lt_cv_prog_compiler_c_o \ +need_locks \ +MANIFEST_TOOL \ +DSYMUTIL \ +NMEDIT \ +LIPO \ +OTOOL \ +OTOOL64 \ +shrext_cmds \ +export_dynamic_flag_spec \ +whole_archive_flag_spec \ +compiler_needs_object \ +with_gnu_ld \ +allow_undefined_flag \ +no_undefined_flag \ +hardcode_libdir_flag_spec \ +hardcode_libdir_separator \ +exclude_expsyms \ +include_expsyms \ +file_list_spec \ +variables_saved_for_relink \ +libname_spec \ +library_names_spec \ +soname_spec \ +install_override_mode \ +finish_eval \ +old_striplib \ +striplib \ +LD_RC \ +reload_flag_RC \ +compiler_RC \ +lt_prog_compiler_no_builtin_flag_RC \ +lt_prog_compiler_pic_RC \ +lt_prog_compiler_wl_RC \ +lt_prog_compiler_static_RC \ +lt_cv_prog_compiler_c_o_RC \ +export_dynamic_flag_spec_RC \ +whole_archive_flag_spec_RC \ +compiler_needs_object_RC \ +with_gnu_ld_RC \ +allow_undefined_flag_RC \ +no_undefined_flag_RC \ +hardcode_libdir_flag_spec_RC \ +hardcode_libdir_separator_RC \ +exclude_expsyms_RC \ +include_expsyms_RC \ +file_list_spec_RC; do + case \`eval \\\\\$ECHO \\\\""\\\\\$\$var"\\\\"\` in + *[\\\\\\\`\\"\\\$]*) + eval "lt_\$var=\\\\\\"\\\`\\\$ECHO \\"\\\$\$var\\" | \\\$SED \\"\\\$sed_quote_subst\\"\\\`\\\\\\"" ## exclude from sc_prohibit_nested_quotes + ;; + *) + eval "lt_\$var=\\\\\\"\\\$\$var\\\\\\"" + ;; + esac +done + +# Double-quote double-evaled strings. +for var in reload_cmds \ +old_postinstall_cmds \ +old_postuninstall_cmds \ +old_archive_cmds \ +extract_expsyms_cmds \ +old_archive_from_new_cmds \ +old_archive_from_expsyms_cmds \ +archive_cmds \ +archive_expsym_cmds \ +module_cmds \ +module_expsym_cmds \ +export_symbols_cmds \ +prelink_cmds \ +postlink_cmds \ +postinstall_cmds \ +postuninstall_cmds \ +finish_cmds \ +sys_lib_search_path_spec \ +configure_time_dlsearch_path \ +configure_time_lt_sys_library_path \ +reload_cmds_RC \ +old_archive_cmds_RC \ +old_archive_from_new_cmds_RC \ +old_archive_from_expsyms_cmds_RC \ +archive_cmds_RC \ +archive_expsym_cmds_RC \ +module_cmds_RC \ +module_expsym_cmds_RC \ +export_symbols_cmds_RC \ +prelink_cmds_RC \ +postlink_cmds_RC; do + case \`eval \\\\\$ECHO \\\\""\\\\\$\$var"\\\\"\` in + *[\\\\\\\`\\"\\\$]*) + eval "lt_\$var=\\\\\\"\\\`\\\$ECHO \\"\\\$\$var\\" | \\\$SED -e \\"\\\$double_quote_subst\\" -e \\"\\\$sed_quote_subst\\" -e \\"\\\$delay_variable_subst\\"\\\`\\\\\\"" ## exclude from sc_prohibit_nested_quotes + ;; + *) + eval "lt_\$var=\\\\\\"\\\$\$var\\\\\\"" + ;; + esac +done + +ac_aux_dir='$ac_aux_dir' + +# See if we are running on zsh, and set the options that allow our +# commands through without removal of \ escapes INIT. +if test -n "\${ZSH_VERSION+set}"; then + setopt NO_GLOB_SUBST +fi + + + PACKAGE='$PACKAGE' + VERSION='$VERSION' + RM='$RM' + ofile='$ofile' + + + + + + +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 + +# Handling of arguments. +for ac_config_target in $ac_config_targets +do + case $ac_config_target in + "lib/curl_config.h") CONFIG_HEADERS="$CONFIG_HEADERS lib/curl_config.h" ;; + "depfiles") CONFIG_COMMANDS="$CONFIG_COMMANDS depfiles" ;; + "libtool") CONFIG_COMMANDS="$CONFIG_COMMANDS libtool" ;; + "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;; + "docs/Makefile") CONFIG_FILES="$CONFIG_FILES docs/Makefile" ;; + "docs/examples/Makefile") CONFIG_FILES="$CONFIG_FILES docs/examples/Makefile" ;; + "docs/libcurl/Makefile") CONFIG_FILES="$CONFIG_FILES docs/libcurl/Makefile" ;; + "docs/libcurl/opts/Makefile") CONFIG_FILES="$CONFIG_FILES docs/libcurl/opts/Makefile" ;; + "docs/cmdline-opts/Makefile") CONFIG_FILES="$CONFIG_FILES docs/cmdline-opts/Makefile" ;; + "include/Makefile") CONFIG_FILES="$CONFIG_FILES include/Makefile" ;; + "include/curl/Makefile") CONFIG_FILES="$CONFIG_FILES include/curl/Makefile" ;; + "src/Makefile") CONFIG_FILES="$CONFIG_FILES src/Makefile" ;; + "lib/Makefile") CONFIG_FILES="$CONFIG_FILES lib/Makefile" ;; + "scripts/Makefile") CONFIG_FILES="$CONFIG_FILES scripts/Makefile" ;; + "lib/libcurl.vers") CONFIG_FILES="$CONFIG_FILES lib/libcurl.vers" ;; + "tests/Makefile") CONFIG_FILES="$CONFIG_FILES tests/Makefile" ;; + "tests/config") CONFIG_FILES="$CONFIG_FILES tests/config" ;; + "tests/configurehelp.pm") CONFIG_FILES="$CONFIG_FILES tests/configurehelp.pm" ;; + "tests/certs/Makefile") CONFIG_FILES="$CONFIG_FILES tests/certs/Makefile" ;; + "tests/data/Makefile") CONFIG_FILES="$CONFIG_FILES tests/data/Makefile" ;; + "tests/server/Makefile") CONFIG_FILES="$CONFIG_FILES tests/server/Makefile" ;; + "tests/libtest/Makefile") CONFIG_FILES="$CONFIG_FILES tests/libtest/Makefile" ;; + "tests/unit/Makefile") CONFIG_FILES="$CONFIG_FILES tests/unit/Makefile" ;; + "tests/tunit/Makefile") CONFIG_FILES="$CONFIG_FILES tests/tunit/Makefile" ;; + "tests/http/config.ini") CONFIG_FILES="$CONFIG_FILES tests/http/config.ini" ;; + "tests/http/Makefile") CONFIG_FILES="$CONFIG_FILES tests/http/Makefile" ;; + "projects/Makefile") CONFIG_FILES="$CONFIG_FILES projects/Makefile" ;; + "projects/vms/Makefile") CONFIG_FILES="$CONFIG_FILES projects/vms/Makefile" ;; + "libcurl.pc") CONFIG_FILES="$CONFIG_FILES libcurl.pc" ;; + "curl-config") CONFIG_FILES="$CONFIG_FILES curl-config" ;; + + *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; + esac +done + + +# If the user did not use the arguments to specify the items to instantiate, +# then the envvar interface is used. Set only those that are not. +# We use the long form for the default assignment because of an extremely +# bizarre bug on SunOS 4.1.3. +if $ac_need_defaults; then + test ${CONFIG_FILES+y} || CONFIG_FILES=$config_files + test ${CONFIG_HEADERS+y} || CONFIG_HEADERS=$config_headers + test ${CONFIG_COMMANDS+y} || CONFIG_COMMANDS=$config_commands +fi + +# Have a temporary directory for convenience. Make it in the build tree +# simply because there is no reason against having it here, and in addition, +# creating and moving files from /tmp can sometimes cause problems. +# Hook for its removal unless debugging. +# Note that there is a small window in which the directory will not be cleaned: +# after its creation but before its name has been assigned to `$tmp'. +$debug || +{ + tmp= ac_tmp= + trap 'exit_status=$? + : "${ac_tmp:=$tmp}" + { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status +' 0 + trap 'as_fn_exit 1' 1 2 13 15 +} +# Create a (secure) tmp directory for tmp files. + +{ + tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && + test -d "$tmp" +} || +{ + tmp=./conf$$-$RANDOM + (umask 077 && mkdir "$tmp") +} || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 +ac_tmp=$tmp + +# Set up the scripts for CONFIG_FILES section. +# No need to generate them if there are no CONFIG_FILES. +# This happens for instance with `./config.status config.h'. +if test -n "$CONFIG_FILES"; then + + +ac_cr=`echo X | tr X '\015'` +# On cygwin, bash can eat \r inside `` if the user requested igncr. +# But we know of no other shell where ac_cr would be empty at this +# point, so we can use a bashism as a fallback. +if test "x$ac_cr" = x; then + eval ac_cr=\$\'\\r\' +fi +ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` +if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then + ac_cs_awk_cr='\\r' +else + ac_cs_awk_cr=$ac_cr +fi + +echo 'BEGIN {' >"$ac_tmp/subs1.awk" && +_ACEOF + + +{ + echo "cat >conf$$subs.awk <<_ACEOF" && + echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && + echo "_ACEOF" +} >conf$$subs.sh || + as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 +ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` +ac_delim='%!_!# ' +for ac_last_try in false false false false false :; do + . ./conf$$subs.sh || + as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 + + ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` + if test $ac_delim_n = $ac_delim_num; then + break + elif $ac_last_try; then + as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 + else + ac_delim="$ac_delim!$ac_delim _$ac_delim!! " + fi +done +rm -f conf$$subs.sh + +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && +_ACEOF +sed -n ' +h +s/^/S["/; s/!.*/"]=/ +p +g +s/^[^!]*!// +:repl +t repl +s/'"$ac_delim"'$// +t delim +:nl +h +s/\(.\{148\}\)..*/\1/ +t more1 +s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ +p +n +b repl +:more1 +s/["\\]/\\&/g; s/^/"/; s/$/"\\/ +p +g +s/.\{148\}// +t nl +:delim +h +s/\(.\{148\}\)..*/\1/ +t more2 +s/["\\]/\\&/g; s/^/"/; s/$/"/ +p +b +:more2 +s/["\\]/\\&/g; s/^/"/; s/$/"\\/ +p +g +s/.\{148\}// +t delim +' >$CONFIG_STATUS || ac_write_fail=1 +rm -f conf$$subs.awk +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +_ACAWK +cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && + for (key in S) S_is_set[key] = 1 + FS = "" + +} +{ + line = $ 0 + nfields = split(line, field, "@") + substed = 0 + len = length(field[1]) + for (i = 2; i < nfields; i++) { + key = field[i] + keylen = length(key) + if (S_is_set[key]) { + value = S[key] + line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) + len += length(value) + length(field[++i]) + substed = 1 + } else + len += 1 + keylen + } + + print line +} + +_ACAWK +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then + sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" +else + cat +fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ + || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 +_ACEOF + +# VPATH may cause trouble with some makes, so we remove sole $(srcdir), +# ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and +# trailing colons and then remove the whole line if VPATH becomes empty +# (actually we leave an empty line to preserve line numbers). +if test "x$srcdir" = x.; then + ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ +h +s/// +s/^/:/ +s/[ ]*$/:/ +s/:\$(srcdir):/:/g +s/:\${srcdir}:/:/g +s/:@srcdir@:/:/g +s/^:*// +s/:*$// +x +s/\(=[ ]*\).*/\1/ +G +s/\n// +s/^[^=]*=[ ]*$// +}' +fi + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +fi # test -n "$CONFIG_FILES" + +# Set up the scripts for CONFIG_HEADERS section. +# No need to generate them if there are no CONFIG_HEADERS. +# This happens for instance with `./config.status Makefile'. +if test -n "$CONFIG_HEADERS"; then +cat >"$ac_tmp/defines.awk" <<\_ACAWK || +BEGIN { +_ACEOF + +# Transform confdefs.h into an awk script `defines.awk', embedded as +# here-document in config.status, that substitutes the proper values into +# config.h.in to produce config.h. + +# Create a delimiter string that does not exist in confdefs.h, to ease +# handling of long lines. +ac_delim='%!_!# ' +for ac_last_try in false false :; do + ac_tt=`sed -n "/$ac_delim/p" confdefs.h` + if test -z "$ac_tt"; then + break + elif $ac_last_try; then + as_fn_error $? "could not make $CONFIG_HEADERS" "$LINENO" 5 + else + ac_delim="$ac_delim!$ac_delim _$ac_delim!! " + fi +done + +# For the awk script, D is an array of macro values keyed by name, +# likewise P contains macro parameters if any. Preserve backslash +# newline sequences. + +ac_word_re=[_$as_cr_Letters][_$as_cr_alnum]* +sed -n ' +s/.\{148\}/&'"$ac_delim"'/g +t rset +:rset +s/^[ ]*#[ ]*define[ ][ ]*/ / +t def +d +:def +s/\\$// +t bsnl +s/["\\]/\\&/g +s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ +D["\1"]=" \3"/p +s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2"/p +d +:bsnl +s/["\\]/\\&/g +s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ +D["\1"]=" \3\\\\\\n"\\/p +t cont +s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2\\\\\\n"\\/p +t cont +d +:cont +n +s/.\{148\}/&'"$ac_delim"'/g +t clear +:clear +s/\\$// +t bsnlc +s/["\\]/\\&/g; s/^/"/; s/$/"/p +d +:bsnlc +s/["\\]/\\&/g; s/^/"/; s/$/\\\\\\n"\\/p +b cont +' >$CONFIG_STATUS || ac_write_fail=1 + +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 + for (key in D) D_is_set[key] = 1 + FS = "" +} +/^[\t ]*#[\t ]*(define|undef)[\t ]+$ac_word_re([\t (]|\$)/ { + line = \$ 0 + split(line, arg, " ") + if (arg[1] == "#") { + defundef = arg[2] + mac1 = arg[3] + } else { + defundef = substr(arg[1], 2) + mac1 = arg[2] + } + split(mac1, mac2, "(") #) + macro = mac2[1] + prefix = substr(line, 1, index(line, defundef) - 1) + if (D_is_set[macro]) { + # Preserve the white space surrounding the "#". + print prefix "define", macro P[macro] D[macro] + next + } else { + # Replace #undef with comments. This is necessary, for example, + # in the case of _POSIX_SOURCE, which is predefined and required + # on some systems where configure will not decide to define it. + if (defundef == "undef") { + print "/*", prefix defundef, macro, "*/" + next + } + } +} +{ print } +_ACAWK +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 + as_fn_error $? "could not setup config headers machinery" "$LINENO" 5 +fi # test -n "$CONFIG_HEADERS" + + +eval set X " :F $CONFIG_FILES :H $CONFIG_HEADERS :C $CONFIG_COMMANDS" +shift +for ac_tag +do + case $ac_tag in + :[FHLC]) ac_mode=$ac_tag; continue;; + esac + case $ac_mode$ac_tag in + :[FHL]*:*);; + :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; + :[FH]-) ac_tag=-:-;; + :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; + esac + ac_save_IFS=$IFS + IFS=: + set x $ac_tag + IFS=$ac_save_IFS + shift + ac_file=$1 + shift + + case $ac_mode in + :L) ac_source=$1;; + :[FH]) + ac_file_inputs= + for ac_f + do + case $ac_f in + -) ac_f="$ac_tmp/stdin";; + *) # Look for the file first in the build tree, then in the source tree + # (if the path is not absolute). The absolute path cannot be DOS-style, + # because $ac_f cannot contain `:'. + test -f "$ac_f" || + case $ac_f in + [\\/$]*) false;; + *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; + esac || + as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; + esac + case $ac_f in *\'*) ac_f=`printf "%s\n" "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac + as_fn_append ac_file_inputs " '$ac_f'" + done + + # Let's still pretend it is `configure' which instantiates (i.e., don't + # use $as_me), people would be surprised to read: + # /* config.h. Generated by config.status. */ + configure_input='Generated from '` + printf "%s\n" "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' + `' by configure.' + if test x"$ac_file" != x-; then + configure_input="$ac_file. $configure_input" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 +printf "%s\n" "$as_me: creating $ac_file" >&6;} + fi + # Neutralize special characters interpreted by sed in replacement strings. + case $configure_input in #( + *\&* | *\|* | *\\* ) + ac_sed_conf_input=`printf "%s\n" "$configure_input" | + sed 's/[\\\\&|]/\\\\&/g'`;; #( + *) ac_sed_conf_input=$configure_input;; + esac + + case $ac_tag in + *:-:* | *:-) cat >"$ac_tmp/stdin" \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; + esac + ;; + esac + + ac_dir=`$as_dirname -- "$ac_file" || +$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$ac_file" : 'X\(//\)[^/]' \| \ + X"$ac_file" : 'X\(//\)$' \| \ + X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || +printf "%s\n" X"$ac_file" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + as_dir="$ac_dir"; as_fn_mkdir_p + ac_builddir=. + +case "$ac_dir" in +.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; +*) + ac_dir_suffix=/`printf "%s\n" "$ac_dir" | sed 's|^\.[\\/]||'` + # A ".." for each directory in $ac_dir_suffix. + ac_top_builddir_sub=`printf "%s\n" "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` + case $ac_top_builddir_sub in + "") ac_top_builddir_sub=. ac_top_build_prefix= ;; + *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; + esac ;; +esac +ac_abs_top_builddir=$ac_pwd +ac_abs_builddir=$ac_pwd$ac_dir_suffix +# for backward compatibility: +ac_top_builddir=$ac_top_build_prefix + +case $srcdir in + .) # We are building in place. + ac_srcdir=. + ac_top_srcdir=$ac_top_builddir_sub + ac_abs_top_srcdir=$ac_pwd ;; + [\\/]* | ?:[\\/]* ) # Absolute name. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir + ac_abs_top_srcdir=$srcdir ;; + *) # Relative name. + ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_build_prefix$srcdir + ac_abs_top_srcdir=$ac_pwd/$srcdir ;; +esac +ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix + + + case $ac_mode in + :F) + # + # CONFIG_FILE + # + + case $INSTALL in + [\\/$]* | ?:[\\/]* ) ac_INSTALL=$INSTALL ;; + *) ac_INSTALL=$ac_top_build_prefix$INSTALL ;; + esac + ac_MKDIR_P=$MKDIR_P + case $MKDIR_P in + [\\/$]* | ?:[\\/]* ) ;; + */*) ac_MKDIR_P=$ac_top_build_prefix$MKDIR_P ;; + esac +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +# If the template does not know about datarootdir, expand it. +# FIXME: This hack should be removed a few years after 2.60. +ac_datarootdir_hack=; ac_datarootdir_seen= +ac_sed_dataroot=' +/datarootdir/ { + p + q +} +/@datadir@/p +/@docdir@/p +/@infodir@/p +/@localedir@/p +/@mandir@/p' +case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in +*datarootdir*) ac_datarootdir_seen=yes;; +*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 +printf "%s\n" "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 + ac_datarootdir_hack=' + s&@datadir@&$datadir&g + s&@docdir@&$docdir&g + s&@infodir@&$infodir&g + s&@localedir@&$localedir&g + s&@mandir@&$mandir&g + s&\\\${datarootdir}&$datarootdir&g' ;; +esac +_ACEOF + +# Neutralize VPATH when `$srcdir' = `.'. +# Shell code in configure.ac might set extrasub. +# FIXME: do we really want to maintain this feature? +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +ac_sed_extra="$ac_vpsub +$extrasub +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +:t +/@[a-zA-Z_][a-zA-Z_0-9]*@/!b +s|@configure_input@|$ac_sed_conf_input|;t t +s&@top_builddir@&$ac_top_builddir_sub&;t t +s&@top_build_prefix@&$ac_top_build_prefix&;t t +s&@srcdir@&$ac_srcdir&;t t +s&@abs_srcdir@&$ac_abs_srcdir&;t t +s&@top_srcdir@&$ac_top_srcdir&;t t +s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t +s&@builddir@&$ac_builddir&;t t +s&@abs_builddir@&$ac_abs_builddir&;t t +s&@abs_top_builddir@&$ac_abs_top_builddir&;t t +s&@INSTALL@&$ac_INSTALL&;t t +s&@MKDIR_P@&$ac_MKDIR_P&;t t +$ac_datarootdir_hack +" +eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ + >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + +test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && + { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && + { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ + "$ac_tmp/out"`; test -z "$ac_out"; } && + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' +which seems to be undefined. Please make sure it is defined" >&5 +printf "%s\n" "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' +which seems to be undefined. Please make sure it is defined" >&2;} + + rm -f "$ac_tmp/stdin" + case $ac_file in + -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; + *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; + esac \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + ;; + :H) + # + # CONFIG_HEADER + # + if test x"$ac_file" != x-; then + { + printf "%s\n" "/* $configure_input */" >&1 \ + && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" + } >"$ac_tmp/config.h" \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + if diff "$ac_file" "$ac_tmp/config.h" >/dev/null 2>&1; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $ac_file is unchanged" >&5 +printf "%s\n" "$as_me: $ac_file is unchanged" >&6;} + else + rm -f "$ac_file" + mv "$ac_tmp/config.h" "$ac_file" \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + fi + else + printf "%s\n" "/* $configure_input */" >&1 \ + && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" \ + || as_fn_error $? "could not create -" "$LINENO" 5 + fi +# Compute "$ac_file"'s index in $config_headers. +_am_arg="$ac_file" +_am_stamp_count=1 +for _am_header in $config_headers :; do + case $_am_header in + $_am_arg | $_am_arg:* ) + break ;; + * ) + _am_stamp_count=`expr $_am_stamp_count + 1` ;; + esac +done +echo "timestamp for $_am_arg" >`$as_dirname -- "$_am_arg" || +$as_expr X"$_am_arg" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$_am_arg" : 'X\(//\)[^/]' \| \ + X"$_am_arg" : 'X\(//\)$' \| \ + X"$_am_arg" : 'X\(/\)' \| . 2>/dev/null || +printf "%s\n" X"$_am_arg" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'`/stamp-h$_am_stamp_count + ;; + + :C) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: executing $ac_file commands" >&5 +printf "%s\n" "$as_me: executing $ac_file commands" >&6;} + ;; + esac + + + case $ac_file$ac_mode in + "depfiles":C) test x"$AMDEP_TRUE" != x"" || { + # Older Autoconf quotes --file arguments for eval, but not when files + # are listed without --file. Let's play safe and only enable the eval + # if we detect the quoting. + # TODO: see whether this extra hack can be removed once we start + # requiring Autoconf 2.70 or later. + case $CONFIG_FILES in #( + *\'*) : + eval set x "$CONFIG_FILES" ;; #( + *) : + set x $CONFIG_FILES ;; #( + *) : + ;; +esac + shift + # Used to flag and report bootstrapping failures. + am_rc=0 + for am_mf + do + # Strip MF so we end up with the name of the file. + am_mf=`printf "%s\n" "$am_mf" | sed -e 's/:.*$//'` + # Check whether this is an Automake generated Makefile which includes + # dependency-tracking related rules and includes. + # Grep'ing the whole file directly is not great: AIX grep has a line + # limit of 2048, but all sed's we know have understand at least 4000. + sed -n 's,^am--depfiles:.*,X,p' "$am_mf" | grep X >/dev/null 2>&1 \ + || continue + am_dirpart=`$as_dirname -- "$am_mf" || +$as_expr X"$am_mf" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$am_mf" : 'X\(//\)[^/]' \| \ + X"$am_mf" : 'X\(//\)$' \| \ + X"$am_mf" : 'X\(/\)' \| . 2>/dev/null || +printf "%s\n" X"$am_mf" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + am_filepart=`$as_basename -- "$am_mf" || +$as_expr X/"$am_mf" : '.*/\([^/][^/]*\)/*$' \| \ + X"$am_mf" : 'X\(//\)$' \| \ + X"$am_mf" : 'X\(/\)' \| . 2>/dev/null || +printf "%s\n" X/"$am_mf" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ + s//\1/ + q + } + /^X\/\(\/\/\)$/{ + s//\1/ + q + } + /^X\/\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + { echo "$as_me:$LINENO: cd "$am_dirpart" \ + && sed -e '/# am--include-marker/d' "$am_filepart" \ + | $MAKE -f - am--depfiles" >&5 + (cd "$am_dirpart" \ + && sed -e '/# am--include-marker/d' "$am_filepart" \ + | $MAKE -f - am--depfiles) >&5 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } || am_rc=$? + done + if test $am_rc -ne 0; then + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "Something went wrong bootstrapping makefile fragments + for automatic dependency tracking. If GNU make was not used, consider + re-running the configure script with MAKE=\"gmake\" (or whatever is + necessary). You can also try re-running configure with the + '--disable-dependency-tracking' option to at least be able to build + the package (albeit without support for automatic dependency tracking). +See \`config.log' for more details" "$LINENO" 5; } + fi + { am_dirpart=; unset am_dirpart;} + { am_filepart=; unset am_filepart;} + { am_mf=; unset am_mf;} + { am_rc=; unset am_rc;} + rm -f conftest-deps.mk +} + ;; + "libtool":C) + + # See if we are running on zsh, and set the options that allow our + # commands through without removal of \ escapes. + if test -n "${ZSH_VERSION+set}"; then + setopt NO_GLOB_SUBST + fi + + cfgfile=${ofile}T + trap "$RM \"$cfgfile\"; exit 1" 1 2 15 + $RM "$cfgfile" + + cat <<_LT_EOF >> "$cfgfile" +#! $SHELL +# Generated automatically by $as_me ($PACKAGE) $VERSION +# NOTE: Changes made to this file will be lost: look at ltmain.sh. + +# Provide generalized library-building support services. +# Written by Gordon Matzigkeit, 1996 + +# Copyright (C) 2014 Free Software Foundation, Inc. +# This is free software; see the source for copying conditions. There is NO +# warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +# GNU Libtool is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of of the License, or +# (at your option) any later version. +# +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program or library that is built +# using GNU Libtool, you may include this file under the same +# distribution terms that you use for the rest of that program. +# +# GNU Libtool is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . + + +# The names of the tagged configurations supported by this script. +available_tags='RC ' + +# Configured defaults for sys_lib_dlsearch_path munging. +: \${LT_SYS_LIBRARY_PATH="$configure_time_lt_sys_library_path"} + +# ### BEGIN LIBTOOL CONFIG + +# Which release of libtool.m4 was used? +macro_version=$macro_version +macro_revision=$macro_revision + +# Assembler program. +AS=$lt_AS + +# DLL creation program. +DLLTOOL=$lt_DLLTOOL + +# Object dumper program. +OBJDUMP=$lt_OBJDUMP + +# Whether or not to build shared libraries. +build_libtool_libs=$enable_shared + +# Whether or not to build static libraries. +build_old_libs=$enable_static + +# What type of objects to build. +pic_mode=$pic_mode + +# Whether or not to optimize for fast installation. +fast_install=$enable_fast_install + +# Shared archive member basename,for filename based shared library versioning on AIX. +shared_archive_member_spec=$shared_archive_member_spec + +# Shell to use when invoking shell scripts. +SHELL=$lt_SHELL + +# An echo program that protects backslashes. +ECHO=$lt_ECHO + +# The PATH separator for the build system. +PATH_SEPARATOR=$lt_PATH_SEPARATOR + +# The host system. +host_alias=$host_alias +host=$host +host_os=$host_os + +# The build system. +build_alias=$build_alias +build=$build +build_os=$build_os + +# A sed program that does not truncate output. +SED=$lt_SED + +# Sed that helps us avoid accidentally triggering echo(1) options like -n. +Xsed="\$SED -e 1s/^X//" + +# A grep program that handles long lines. +GREP=$lt_GREP + +# An ERE matcher. +EGREP=$lt_EGREP + +# A literal string matcher. +FGREP=$lt_FGREP + +# A BSD- or MS-compatible name lister. +NM=$lt_NM + +# Whether we need soft or hard links. +LN_S=$lt_LN_S + +# What is the maximum length of a command? +max_cmd_len=$max_cmd_len + +# Object file suffix (normally "o"). +objext=$ac_objext + +# Executable file suffix (normally ""). +exeext=$exeext + +# whether the shell understands "unset". +lt_unset=$lt_unset + +# turn spaces into newlines. +SP2NL=$lt_lt_SP2NL + +# turn newlines into spaces. +NL2SP=$lt_lt_NL2SP + +# convert \$build file names to \$host format. +to_host_file_cmd=$lt_cv_to_host_file_cmd + +# convert \$build files to toolchain format. +to_tool_file_cmd=$lt_cv_to_tool_file_cmd + +# A file(cmd) program that detects file types. +FILECMD=$lt_FILECMD + +# Method to check whether dependent libraries are shared objects. +deplibs_check_method=$lt_deplibs_check_method + +# Command to use when deplibs_check_method = "file_magic". +file_magic_cmd=$lt_file_magic_cmd + +# How to find potential files when deplibs_check_method = "file_magic". +file_magic_glob=$lt_file_magic_glob + +# Find potential files using nocaseglob when deplibs_check_method = "file_magic". +want_nocaseglob=$lt_want_nocaseglob + +# Command to associate shared and link libraries. +sharedlib_from_linklib_cmd=$lt_sharedlib_from_linklib_cmd + +# The archiver. +AR=$lt_AR + +# Flags to create an archive (by configure). +lt_ar_flags=$lt_ar_flags + +# Flags to create an archive. +AR_FLAGS=\${ARFLAGS-"\$lt_ar_flags"} + +# How to feed a file listing to the archiver. +archiver_list_spec=$lt_archiver_list_spec + +# A symbol stripping program. +STRIP=$lt_STRIP + +# Commands used to install an old-style archive. +RANLIB=$lt_RANLIB +old_postinstall_cmds=$lt_old_postinstall_cmds +old_postuninstall_cmds=$lt_old_postuninstall_cmds + +# Whether to use a lock for old archive extraction. +lock_old_archive_extraction=$lock_old_archive_extraction + +# A C compiler. +LTCC=$lt_CC + +# LTCC compiler flags. +LTCFLAGS=$lt_CFLAGS + +# Take the output of nm and produce a listing of raw symbols and C names. +global_symbol_pipe=$lt_lt_cv_sys_global_symbol_pipe + +# Transform the output of nm in a proper C declaration. +global_symbol_to_cdecl=$lt_lt_cv_sys_global_symbol_to_cdecl + +# Transform the output of nm into a list of symbols to manually relocate. +global_symbol_to_import=$lt_lt_cv_sys_global_symbol_to_import + +# Transform the output of nm in a C name address pair. +global_symbol_to_c_name_address=$lt_lt_cv_sys_global_symbol_to_c_name_address + +# Transform the output of nm in a C name address pair when lib prefix is needed. +global_symbol_to_c_name_address_lib_prefix=$lt_lt_cv_sys_global_symbol_to_c_name_address_lib_prefix + +# The name lister interface. +nm_interface=$lt_lt_cv_nm_interface + +# Specify filename containing input files for \$NM. +nm_file_list_spec=$lt_nm_file_list_spec + +# The root where to search for dependent libraries,and where our libraries should be installed. +lt_sysroot=$lt_sysroot + +# Command to truncate a binary pipe. +lt_truncate_bin=$lt_lt_cv_truncate_bin + +# The name of the directory that contains temporary libtool files. +objdir=$objdir + +# Used to examine libraries when file_magic_cmd begins with "file". +MAGIC_CMD=$MAGIC_CMD + +# Must we lock files when doing compilation? +need_locks=$lt_need_locks + +# Manifest tool. +MANIFEST_TOOL=$lt_MANIFEST_TOOL + +# Tool to manipulate archived DWARF debug symbol files on Mac OS X. +DSYMUTIL=$lt_DSYMUTIL + +# Tool to change global to local symbols on Mac OS X. +NMEDIT=$lt_NMEDIT + +# Tool to manipulate fat objects and archives on Mac OS X. +LIPO=$lt_LIPO + +# ldd/readelf like tool for Mach-O binaries on Mac OS X. +OTOOL=$lt_OTOOL + +# ldd/readelf like tool for 64 bit Mach-O binaries on Mac OS X 10.4. +OTOOL64=$lt_OTOOL64 + +# Old archive suffix (normally "a"). +libext=$libext + +# Shared library suffix (normally ".so"). +shrext_cmds=$lt_shrext_cmds + +# The commands to extract the exported symbol list from a shared archive. +extract_expsyms_cmds=$lt_extract_expsyms_cmds + +# Variables whose values should be saved in libtool wrapper scripts and +# restored at link time. +variables_saved_for_relink=$lt_variables_saved_for_relink + +# Do we need the "lib" prefix for modules? +need_lib_prefix=$need_lib_prefix + +# Do we need a version for libraries? +need_version=$need_version + +# Library versioning type. +version_type=$version_type + +# Shared library runtime path variable. +runpath_var=$runpath_var + +# Shared library path variable. +shlibpath_var=$shlibpath_var + +# Is shlibpath searched before the hard-coded library search path? +shlibpath_overrides_runpath=$shlibpath_overrides_runpath + +# Format of library name prefix. +libname_spec=$lt_libname_spec + +# List of archive names. First name is the real one, the rest are links. +# The last name is the one that the linker finds with -lNAME +library_names_spec=$lt_library_names_spec + +# The coded name of the library, if different from the real name. +soname_spec=$lt_soname_spec + +# Permission mode override for installation of shared libraries. +install_override_mode=$lt_install_override_mode + +# Command to use after installation of a shared archive. +postinstall_cmds=$lt_postinstall_cmds + +# Command to use after uninstallation of a shared archive. +postuninstall_cmds=$lt_postuninstall_cmds + +# Commands used to finish a libtool library installation in a directory. +finish_cmds=$lt_finish_cmds + +# As "finish_cmds", except a single script fragment to be evaled but +# not shown. +finish_eval=$lt_finish_eval + +# Whether we should hardcode library paths into libraries. +hardcode_into_libs=$hardcode_into_libs + +# Compile-time system search path for libraries. +sys_lib_search_path_spec=$lt_sys_lib_search_path_spec + +# Detected run-time system search path for libraries. +sys_lib_dlsearch_path_spec=$lt_configure_time_dlsearch_path + +# Explicit LT_SYS_LIBRARY_PATH set during ./configure time. +configure_time_lt_sys_library_path=$lt_configure_time_lt_sys_library_path + +# Whether dlopen is supported. +dlopen_support=$enable_dlopen + +# Whether dlopen of programs is supported. +dlopen_self=$enable_dlopen_self + +# Whether dlopen of statically linked programs is supported. +dlopen_self_static=$enable_dlopen_self_static + +# Commands to strip libraries. +old_striplib=$lt_old_striplib +striplib=$lt_striplib + + +# The linker used to build libraries. +LD=$lt_LD + +# How to create reloadable object files. +reload_flag=$lt_reload_flag +reload_cmds=$lt_reload_cmds + +# Commands used to build an old-style archive. +old_archive_cmds=$lt_old_archive_cmds + +# A language specific compiler. +CC=$lt_compiler + +# Is the compiler the GNU compiler? +with_gcc=$GCC + +# Compiler flag to turn off builtin functions. +no_builtin_flag=$lt_lt_prog_compiler_no_builtin_flag + +# Additional compiler flags for building library objects. +pic_flag=$lt_lt_prog_compiler_pic + +# How to pass a linker flag through the compiler. +wl=$lt_lt_prog_compiler_wl + +# Compiler flag to prevent dynamic linking. +link_static_flag=$lt_lt_prog_compiler_static + +# Does compiler simultaneously support -c and -o options? +compiler_c_o=$lt_lt_cv_prog_compiler_c_o + +# Whether or not to add -lc for building shared libraries. +build_libtool_need_lc=$archive_cmds_need_lc + +# Whether or not to disallow shared libs when runtime libs are static. +allow_libtool_libs_with_static_runtimes=$enable_shared_with_static_runtimes + +# Compiler flag to allow reflexive dlopens. +export_dynamic_flag_spec=$lt_export_dynamic_flag_spec + +# Compiler flag to generate shared objects directly from archives. +whole_archive_flag_spec=$lt_whole_archive_flag_spec + +# Whether the compiler copes with passing no objects directly. +compiler_needs_object=$lt_compiler_needs_object + +# Create an old-style archive from a shared archive. +old_archive_from_new_cmds=$lt_old_archive_from_new_cmds + +# Create a temporary old-style archive to link instead of a shared archive. +old_archive_from_expsyms_cmds=$lt_old_archive_from_expsyms_cmds + +# Commands used to build a shared archive. +archive_cmds=$lt_archive_cmds +archive_expsym_cmds=$lt_archive_expsym_cmds + +# Commands used to build a loadable module if different from building +# a shared archive. +module_cmds=$lt_module_cmds +module_expsym_cmds=$lt_module_expsym_cmds + +# Whether we are building with GNU ld or not. +with_gnu_ld=$lt_with_gnu_ld + +# Flag that allows shared libraries with undefined symbols to be built. +allow_undefined_flag=$lt_allow_undefined_flag + +# Flag that enforces no undefined symbols. +no_undefined_flag=$lt_no_undefined_flag + +# Flag to hardcode \$libdir into a binary during linking. +# This must work even if \$libdir does not exist +hardcode_libdir_flag_spec=$lt_hardcode_libdir_flag_spec + +# Whether we need a single "-rpath" flag with a separated argument. +hardcode_libdir_separator=$lt_hardcode_libdir_separator + +# Set to "yes" if using DIR/libNAME\$shared_ext during linking hardcodes +# DIR into the resulting binary. +hardcode_direct=$hardcode_direct + +# Set to "yes" if using DIR/libNAME\$shared_ext during linking hardcodes +# DIR into the resulting binary and the resulting library dependency is +# "absolute",i.e impossible to change by setting \$shlibpath_var if the +# library is relocated. +hardcode_direct_absolute=$hardcode_direct_absolute + +# Set to "yes" if using the -LDIR flag during linking hardcodes DIR +# into the resulting binary. +hardcode_minus_L=$hardcode_minus_L + +# Set to "yes" if using SHLIBPATH_VAR=DIR during linking hardcodes DIR +# into the resulting binary. +hardcode_shlibpath_var=$hardcode_shlibpath_var + +# Set to "yes" if building a shared library automatically hardcodes DIR +# into the library and all subsequent libraries and executables linked +# against it. +hardcode_automatic=$hardcode_automatic + +# Set to yes if linker adds runtime paths of dependent libraries +# to runtime path list. +inherit_rpath=$inherit_rpath + +# Whether libtool must link a program against all its dependency libraries. +link_all_deplibs=$link_all_deplibs + +# Set to "yes" if exported symbols are required. +always_export_symbols=$always_export_symbols + +# The commands to list exported symbols. +export_symbols_cmds=$lt_export_symbols_cmds + +# Symbols that should not be listed in the preloaded symbols. +exclude_expsyms=$lt_exclude_expsyms + +# Symbols that must always be exported. +include_expsyms=$lt_include_expsyms + +# Commands necessary for linking programs (against libraries) with templates. +prelink_cmds=$lt_prelink_cmds + +# Commands necessary for finishing linking programs. +postlink_cmds=$lt_postlink_cmds + +# Specify filename containing input files. +file_list_spec=$lt_file_list_spec + +# How to hardcode a shared library path into an executable. +hardcode_action=$hardcode_action + +# ### END LIBTOOL CONFIG + +_LT_EOF + + cat <<'_LT_EOF' >> "$cfgfile" + +# ### BEGIN FUNCTIONS SHARED WITH CONFIGURE + +# func_munge_path_list VARIABLE PATH +# ----------------------------------- +# VARIABLE is name of variable containing _space_ separated list of +# directories to be munged by the contents of PATH, which is string +# having a format: +# "DIR[:DIR]:" +# string "DIR[ DIR]" will be prepended to VARIABLE +# ":DIR[:DIR]" +# string "DIR[ DIR]" will be appended to VARIABLE +# "DIRP[:DIRP]::[DIRA:]DIRA" +# string "DIRP[ DIRP]" will be prepended to VARIABLE and string +# "DIRA[ DIRA]" will be appended to VARIABLE +# "DIR[:DIR]" +# VARIABLE will be replaced by "DIR[ DIR]" +func_munge_path_list () +{ + case x$2 in + x) + ;; + *:) + eval $1=\"`$ECHO $2 | $SED 's/:/ /g'` \$$1\" + ;; + x:*) + eval $1=\"\$$1 `$ECHO $2 | $SED 's/:/ /g'`\" + ;; + *::*) + eval $1=\"\$$1\ `$ECHO $2 | $SED -e 's/.*:://' -e 's/:/ /g'`\" + eval $1=\"`$ECHO $2 | $SED -e 's/::.*//' -e 's/:/ /g'`\ \$$1\" + ;; + *) + eval $1=\"`$ECHO $2 | $SED 's/:/ /g'`\" + ;; + esac +} + + +# Calculate cc_basename. Skip known compiler wrappers and cross-prefix. +func_cc_basename () +{ + for cc_temp in $*""; do + case $cc_temp in + compile | *[\\/]compile | ccache | *[\\/]ccache ) ;; + distcc | *[\\/]distcc | purify | *[\\/]purify ) ;; + \-*) ;; + *) break;; + esac + done + func_cc_basename_result=`$ECHO "$cc_temp" | $SED "s%.*/%%; s%^$host_alias-%%"` +} + + +# ### END FUNCTIONS SHARED WITH CONFIGURE + +_LT_EOF + + case $host_os in + aix3*) + cat <<\_LT_EOF >> "$cfgfile" +# AIX sometimes has problems with the GCC collect2 program. For some +# reason, if we set the COLLECT_NAMES environment variable, the problems +# vanish in a puff of smoke. +if test set != "${COLLECT_NAMES+set}"; then + COLLECT_NAMES= + export COLLECT_NAMES +fi +_LT_EOF + ;; + esac + + + +ltmain=$ac_aux_dir/ltmain.sh + + + # We use sed instead of cat because bash on DJGPP gets confused if + # if finds mixed CR/LF and LF-only lines. Since sed operates in + # text mode, it properly converts lines to CR/LF. This bash problem + # is reportedly fixed, but why not run on old versions too? + $SED '$q' "$ltmain" >> "$cfgfile" \ + || (rm -f "$cfgfile"; exit 1) + + mv -f "$cfgfile" "$ofile" || + (rm -f "$ofile" && cp "$cfgfile" "$ofile" && rm -f "$cfgfile") + chmod +x "$ofile" + + + cat <<_LT_EOF >> "$ofile" + +# ### BEGIN LIBTOOL TAG CONFIG: RC + +# The linker used to build libraries. +LD=$lt_LD_RC + +# How to create reloadable object files. +reload_flag=$lt_reload_flag_RC +reload_cmds=$lt_reload_cmds_RC + +# Commands used to build an old-style archive. +old_archive_cmds=$lt_old_archive_cmds_RC + +# A language specific compiler. +CC=$lt_compiler_RC + +# Is the compiler the GNU compiler? +with_gcc=$GCC_RC + +# Compiler flag to turn off builtin functions. +no_builtin_flag=$lt_lt_prog_compiler_no_builtin_flag_RC + +# Additional compiler flags for building library objects. +pic_flag=$lt_lt_prog_compiler_pic_RC + +# How to pass a linker flag through the compiler. +wl=$lt_lt_prog_compiler_wl_RC + +# Compiler flag to prevent dynamic linking. +link_static_flag=$lt_lt_prog_compiler_static_RC + +# Does compiler simultaneously support -c and -o options? +compiler_c_o=$lt_lt_cv_prog_compiler_c_o_RC + +# Whether or not to add -lc for building shared libraries. +build_libtool_need_lc=$archive_cmds_need_lc_RC + +# Whether or not to disallow shared libs when runtime libs are static. +allow_libtool_libs_with_static_runtimes=$enable_shared_with_static_runtimes_RC + +# Compiler flag to allow reflexive dlopens. +export_dynamic_flag_spec=$lt_export_dynamic_flag_spec_RC + +# Compiler flag to generate shared objects directly from archives. +whole_archive_flag_spec=$lt_whole_archive_flag_spec_RC + +# Whether the compiler copes with passing no objects directly. +compiler_needs_object=$lt_compiler_needs_object_RC + +# Create an old-style archive from a shared archive. +old_archive_from_new_cmds=$lt_old_archive_from_new_cmds_RC + +# Create a temporary old-style archive to link instead of a shared archive. +old_archive_from_expsyms_cmds=$lt_old_archive_from_expsyms_cmds_RC + +# Commands used to build a shared archive. +archive_cmds=$lt_archive_cmds_RC +archive_expsym_cmds=$lt_archive_expsym_cmds_RC + +# Commands used to build a loadable module if different from building +# a shared archive. +module_cmds=$lt_module_cmds_RC +module_expsym_cmds=$lt_module_expsym_cmds_RC + +# Whether we are building with GNU ld or not. +with_gnu_ld=$lt_with_gnu_ld_RC + +# Flag that allows shared libraries with undefined symbols to be built. +allow_undefined_flag=$lt_allow_undefined_flag_RC + +# Flag that enforces no undefined symbols. +no_undefined_flag=$lt_no_undefined_flag_RC + +# Flag to hardcode \$libdir into a binary during linking. +# This must work even if \$libdir does not exist +hardcode_libdir_flag_spec=$lt_hardcode_libdir_flag_spec_RC + +# Whether we need a single "-rpath" flag with a separated argument. +hardcode_libdir_separator=$lt_hardcode_libdir_separator_RC + +# Set to "yes" if using DIR/libNAME\$shared_ext during linking hardcodes +# DIR into the resulting binary. +hardcode_direct=$hardcode_direct_RC + +# Set to "yes" if using DIR/libNAME\$shared_ext during linking hardcodes +# DIR into the resulting binary and the resulting library dependency is +# "absolute",i.e impossible to change by setting \$shlibpath_var if the +# library is relocated. +hardcode_direct_absolute=$hardcode_direct_absolute_RC + +# Set to "yes" if using the -LDIR flag during linking hardcodes DIR +# into the resulting binary. +hardcode_minus_L=$hardcode_minus_L_RC + +# Set to "yes" if using SHLIBPATH_VAR=DIR during linking hardcodes DIR +# into the resulting binary. +hardcode_shlibpath_var=$hardcode_shlibpath_var_RC + +# Set to "yes" if building a shared library automatically hardcodes DIR +# into the library and all subsequent libraries and executables linked +# against it. +hardcode_automatic=$hardcode_automatic_RC + +# Set to yes if linker adds runtime paths of dependent libraries +# to runtime path list. +inherit_rpath=$inherit_rpath_RC + +# Whether libtool must link a program against all its dependency libraries. +link_all_deplibs=$link_all_deplibs_RC + +# Set to "yes" if exported symbols are required. +always_export_symbols=$always_export_symbols_RC + +# The commands to list exported symbols. +export_symbols_cmds=$lt_export_symbols_cmds_RC + +# Symbols that should not be listed in the preloaded symbols. +exclude_expsyms=$lt_exclude_expsyms_RC + +# Symbols that must always be exported. +include_expsyms=$lt_include_expsyms_RC + +# Commands necessary for linking programs (against libraries) with templates. +prelink_cmds=$lt_prelink_cmds_RC + +# Commands necessary for finishing linking programs. +postlink_cmds=$lt_postlink_cmds_RC + +# Specify filename containing input files. +file_list_spec=$lt_file_list_spec_RC + +# How to hardcode a shared library path into an executable. +hardcode_action=$hardcode_action_RC + +# ### END LIBTOOL TAG CONFIG: RC +_LT_EOF + + ;; + "curl-config":F) chmod +x curl-config ;; + + esac +done # for ac_tag + + +as_fn_exit 0 +_ACEOF +ac_clean_files=$ac_clean_files_save + +test $ac_write_fail = 0 || + as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 + + +# configure is writing to config.log, and then calls config.status. +# config.status does its own redirection, appending to config.log. +# Unfortunately, on DOS this fails, as config.log is still kept open +# by configure, so config.status won't be able to write to it; its +# output is simply discarded. So we exec the FD to /dev/null, +# effectively closing config.log, so it can be properly (re)opened and +# appended to by config.status. When coming back to configure, we +# need to make the FD available again. +if test "$no_create" != yes; then + ac_cs_success=: + ac_config_status_args= + test "$silent" = yes && + ac_config_status_args="$ac_config_status_args --quiet" + exec 5>/dev/null + $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false + exec 5>>config.log + # Use ||, not &&, to avoid exiting from the if with $? = 1, which + # would make configure fail if this is the last instruction. + $ac_cs_success || as_fn_exit 1 +fi +if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 +printf "%s\n" "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} +fi + + +SUPPORT_PROTOCOLS_LOWER=`echo "$SUPPORT_PROTOCOLS" | tr A-Z a-z` + +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: Configured to build curl/libcurl: + + Host setup: ${host} + Install prefix: ${prefix} + Compiler: ${CC} + CFLAGS: ${CFLAGS} + CFLAGS extras: ${CURL_CFLAG_EXTRAS} + CPPFLAGS: ${CPPFLAGS} + LDFLAGS: ${LDFLAGS} + curl-config: ${LIBCURL_PC_LDFLAGS_PRIVATE} + LIBS: ${LIBS} + + curl version: ${CURLVERSION} + SSL: ${curl_ssl_msg} + SSH: ${curl_ssh_msg} + zlib: ${curl_zlib_msg} + brotli: ${curl_brotli_msg} + zstd: ${curl_zstd_msg} + GSS-API: ${curl_gss_msg} + GSASL: ${curl_gsasl_msg} + TLS-SRP: ${curl_tls_srp_msg} + resolver: ${curl_res_msg} + IPv6: ${curl_ipv6_msg} + Unix sockets: ${curl_unix_sockets_msg} + IDN: ${curl_idn_msg} + Build docs: ${curl_docs_msg} + Build libcurl: Shared=${enable_shared}, Static=${enable_static} + Built-in manual: ${curl_manual_msg} + --libcurl option: ${curl_libcurl_msg} + Type checking: ${curl_typecheck_msg} + Verbose errors: ${curl_verbose_msg} + Code coverage: ${curl_coverage_msg} + SSPI: ${curl_sspi_msg} + CA native: ${ca_native} + CA cert bundle: ${ca}${ca_warning} + CA cert path: ${capath}${capath_warning} + CA cert embed: ${CURL_CA_EMBED_msg} + CA fallback: ${with_ca_fallback} + LDAP: ${curl_ldap_msg} + LDAPS: ${curl_ldaps_msg} + IPFS/IPNS: ${curl_ipfs_msg} + RTSP: ${curl_rtsp_msg} + PSL: ${curl_psl_msg} + Alt-svc: ${curl_altsvc_msg} + Headers API: ${curl_headers_msg} + HSTS: ${curl_hsts_msg} + HTTP1: ${curl_h1_msg} + HTTP2: ${curl_h2_msg} + HTTP3: ${curl_h3_msg} + proxy-HTTP3: ${curl_proxy_http3_msg} + ECH: ${curl_ech_msg} + HTTPS RR: ${curl_httpsrr_msg} + SSLS-EXPORT: ${curl_ssls_export_msg} + Protocols: ${SUPPORT_PROTOCOLS_LOWER} + Features: ${SUPPORT_FEATURES} +" >&5 +printf "%s\n" "$as_me: Configured to build curl/libcurl: + + Host setup: ${host} + Install prefix: ${prefix} + Compiler: ${CC} + CFLAGS: ${CFLAGS} + CFLAGS extras: ${CURL_CFLAG_EXTRAS} + CPPFLAGS: ${CPPFLAGS} + LDFLAGS: ${LDFLAGS} + curl-config: ${LIBCURL_PC_LDFLAGS_PRIVATE} + LIBS: ${LIBS} + + curl version: ${CURLVERSION} + SSL: ${curl_ssl_msg} + SSH: ${curl_ssh_msg} + zlib: ${curl_zlib_msg} + brotli: ${curl_brotli_msg} + zstd: ${curl_zstd_msg} + GSS-API: ${curl_gss_msg} + GSASL: ${curl_gsasl_msg} + TLS-SRP: ${curl_tls_srp_msg} + resolver: ${curl_res_msg} + IPv6: ${curl_ipv6_msg} + Unix sockets: ${curl_unix_sockets_msg} + IDN: ${curl_idn_msg} + Build docs: ${curl_docs_msg} + Build libcurl: Shared=${enable_shared}, Static=${enable_static} + Built-in manual: ${curl_manual_msg} + --libcurl option: ${curl_libcurl_msg} + Type checking: ${curl_typecheck_msg} + Verbose errors: ${curl_verbose_msg} + Code coverage: ${curl_coverage_msg} + SSPI: ${curl_sspi_msg} + CA native: ${ca_native} + CA cert bundle: ${ca}${ca_warning} + CA cert path: ${capath}${capath_warning} + CA cert embed: ${CURL_CA_EMBED_msg} + CA fallback: ${with_ca_fallback} + LDAP: ${curl_ldap_msg} + LDAPS: ${curl_ldaps_msg} + IPFS/IPNS: ${curl_ipfs_msg} + RTSP: ${curl_rtsp_msg} + PSL: ${curl_psl_msg} + Alt-svc: ${curl_altsvc_msg} + Headers API: ${curl_headers_msg} + HSTS: ${curl_hsts_msg} + HTTP1: ${curl_h1_msg} + HTTP2: ${curl_h2_msg} + HTTP3: ${curl_h3_msg} + proxy-HTTP3: ${curl_proxy_http3_msg} + ECH: ${curl_ech_msg} + HTTPS RR: ${curl_httpsrr_msg} + SSLS-EXPORT: ${curl_ssls_export_msg} + Protocols: ${SUPPORT_PROTOCOLS_LOWER} + Features: ${SUPPORT_FEATURES} +" >&6;} + +if test -n "$experimental"; then + for a in $experimental; do + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: $a is enabled but marked EXPERIMENTAL. Use with caution!" >&5 +printf "%s\n" "$as_me: WARNING: $a is enabled but marked EXPERIMENTAL. Use with caution!" >&2;} + done +fi + + + curl_pflags="" + if test "$curl_cv_apple" = "yes"; then + curl_pflags="${curl_pflags} APPLE" + fi + case $host in + *-*-*bsd*|*-*-aix*|*-*-hpux*|*-*-interix*|*-*-irix*|*-*-linux*|*-*-solaris*|*-*-sunos*|*-apple-*|*-*-cygwin*|*-*-msys*) + curl_pflags="${curl_pflags} UNIX";; + esac + case $host in + *-*-*bsd*) + curl_pflags="${curl_pflags} BSD";; + esac + if test "$curl_cv_android" = "yes"; then + curl_pflags="${curl_pflags} ANDROID" + ANDROID_PLATFORM_LEVEL=`echo "$host_os" | $SED -ne 's/.*android\([0-9]*\).*/\1/p'` + if test -n "${ANDROID_PLATFORM_LEVEL}"; then + curl_pflags="${curl_pflags}-${ANDROID_PLATFORM_LEVEL}" + fi + fi + if test "$curl_cv_native_windows" = "yes"; then + curl_pflags="${curl_pflags} WIN32" + fi + if test "$curl_cv_winuwp" = "yes"; then + curl_pflags="${curl_pflags} UWP" + fi + case $host_os in + cygwin*|msys*) curl_pflags="${curl_pflags} CYGWIN";; + esac + case $host_os in + msdos*) curl_pflags="${curl_pflags} DOS";; + amiga*) curl_pflags="${curl_pflags} AMIGA";; + esac + if test "$compiler_id" = "GNU_C"; then + curl_pflags="${curl_pflags} GCC" + fi + if test "$compiler_id" = "APPLECLANG"; then + curl_pflags="${curl_pflags} APPLE-CLANG" + elif test "$compiler_id" = "CLANG"; then + curl_pflags="${curl_pflags} LLVM-CLANG" + fi + case $host_os in + mingw*) curl_pflags="${curl_pflags} MINGW";; + esac + if test "$cross_compiling" = "yes"; then + curl_pflags="${curl_pflags} CROSS" + fi + squeeze curl_pflags + curl_buildinfo=" +buildinfo.configure.tool: configure +buildinfo.configure.args: $ac_configure_args +buildinfo.host: $build +buildinfo.host.cpu: $build_cpu +buildinfo.host.os: $build_os +buildinfo.target: $host +buildinfo.target.cpu: $host_cpu +buildinfo.target.os: $host_os +buildinfo.target.flags: $curl_pflags +buildinfo.compiler: $compiler_id +buildinfo.compiler.version: $compiler_ver +buildinfo.sysroot: $lt_sysroot" + +echo "# This is a generated file. Do not edit.${curl_buildinfo}" > ./buildinfo.txt +if test -n "$CURL_BUILDINFO$CURL_CI$CI"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: ${curl_buildinfo}" >&5 +printf "%s\n" "$as_me: ${curl_buildinfo}" >&6;} +fi + diff --git a/3rdparty/curl-8.21.0/configure.ac b/3rdparty/curl-8.21.0/configure.ac new file mode 100644 index 0000000000..a21847ea66 --- /dev/null +++ b/3rdparty/curl-8.21.0/configure.ac @@ -0,0 +1,5572 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +#*************************************************************************** +dnl Process this file with autoconf to produce a configure script. + +AC_PREREQ(2.59) + +dnl We do not know the version number "statically" so we use a dash here +AC_INIT([curl], [-], [a suitable curl mailing list: https://curl.se/mail/]) + +XC_OVR_ZZ50 +CURL_OVERRIDE_AUTOCONF + +dnl configure script copyright +AC_COPYRIGHT([Copyright (C) Daniel Stenberg, +This configure script may be copied, distributed and modified under the +terms of the curl license; see COPYING for more details]) + +AC_CONFIG_SRCDIR([lib/urldata.h]) +AC_CONFIG_HEADERS(lib/curl_config.h) +AH_TOP([/* !checksrc! disable COPYRIGHT all */]) +AC_CONFIG_MACRO_DIR([m4]) +AM_MAINTAINER_MODE +m4_ifdef([AM_SILENT_RULES], [AM_SILENT_RULES([yes])]) + +CURL_CHECK_OPTION_DEBUG +AM_CONDITIONAL(DEBUGBUILD, test "$want_debug" = "yes") +CURL_CHECK_OPTION_OPTIMIZE +CURL_CHECK_OPTION_WARNINGS +CURL_CHECK_OPTION_WERROR +CURL_CHECK_OPTION_SYMBOL_HIDING +CURL_CHECK_OPTION_ARES +CURL_CHECK_OPTION_RT +CURL_CHECK_OPTION_HTTPSRR +CURL_CHECK_OPTION_ECH +CURL_CHECK_OPTION_SSLS_EXPORT +AC_MSG_CHECKING([whether to enable HTTP/3 proxy support]) +OPT_PROXY_HTTP3="default" +AC_ARG_ENABLE(proxy-http3, +AS_HELP_STRING([--enable-proxy-http3],[Enable HTTP/3 proxy support (experimental)]) +AS_HELP_STRING([--disable-proxy-http3],[Disable HTTP/3 proxy support (experimental)]), + OPT_PROXY_HTTP3=$enableval) +case "$OPT_PROXY_HTTP3" in + no) + want_proxy_http3="no" + curl_proxy_http3_msg="no (--enable-proxy-http3)" + AC_MSG_RESULT([no]) + ;; + default) + want_proxy_http3="no" + curl_proxy_http3_msg="no (--enable-proxy-http3)" + AC_MSG_RESULT([no]) + ;; + *) + want_proxy_http3="yes" + curl_proxy_http3_msg="enabled (--disable-proxy-http3)" + AC_MSG_RESULT([yes]) + ;; +esac +USE_PROXY_HTTP3=0 + +XC_CHECK_PATH_SEPARATOR + +dnl +dnl save the configure arguments +dnl +CONFIGURE_OPTIONS="\"$ac_configure_args\"" +AC_SUBST(CONFIGURE_OPTIONS) + +dnl SED is mandatory for configure process and libtool. +dnl Set it now, allowing it to be changed later. +if test -z "$SED"; then + dnl allow it to be overridden + AC_PATH_PROG([SED], [sed], [not_found], + [$PATH:/usr/bin:/usr/local/bin]) + if test -z "$SED" || test "$SED" = "not_found"; then + AC_MSG_ERROR([sed not found in PATH. Cannot continue without sed.]) + fi +fi +AC_SUBST([SED]) + +dnl GREP is mandatory for configure process and libtool. +dnl Set it now, allowing it to be changed later. +if test -z "$GREP"; then + dnl allow it to be overridden + AC_PATH_PROG([GREP], [grep], [not_found], + [$PATH:/usr/bin:/usr/local/bin]) + if test -z "$GREP" || test "$GREP" = "not_found"; then + AC_MSG_ERROR([grep not found in PATH. Cannot continue without grep.]) + fi +fi +AC_SUBST([GREP]) + +dnl 'grep -E' is mandatory for configure process and libtool. +dnl Set it now, allowing it to be changed later. +if test -z "$EGREP"; then + dnl allow it to be overridden + AC_MSG_CHECKING([that grep -E works]) + if echo a | ($GREP -E '(a|b)') >/dev/null 2>&1; then + EGREP="$GREP -E" + AC_MSG_RESULT([yes]) + else + AC_MSG_RESULT([no]) + AC_PATH_PROG([EGREP], [egrep], [not_found], + [$PATH:/usr/bin:/usr/local/bin]) + fi +fi +if test -z "$EGREP" || test "$EGREP" = "not_found"; then + AC_MSG_ERROR([grep -E is not working and egrep is not found in PATH. Cannot continue.]) +fi +AC_SUBST([EGREP]) + +dnl AR is mandatory for configure process and libtool. +dnl This is target dependent, so check it as a tool. +if test -z "$AR"; then + dnl allow it to be overridden + AC_PATH_TOOL([AR], [ar], [not_found], + [$PATH:/usr/bin:/usr/local/bin]) + if test -z "$AR" || test "$AR" = "not_found"; then + AC_MSG_ERROR([ar not found in PATH. Cannot continue without ar.]) + fi +fi +AC_SUBST([AR]) + +AC_SUBST(libext) + +if test -z "$CLANG_TIDY"; then + CLANG_TIDY=clang-tidy +fi +AC_SUBST(CLANG_TIDY) + +dnl figure out the libcurl version +CURLVERSION=`$SED -ne 's/^#define LIBCURL_VERSION "\(.*\)".*/\1/p' ${srcdir}/include/curl/curlver.h` +XC_CHECK_PROG_CC +CURL_ATOMIC + +XC_AUTOMAKE +AC_MSG_CHECKING([curl version]) +AC_MSG_RESULT($CURLVERSION) + +AC_SUBST(CURLVERSION) + +dnl +dnl we extract the numerical version for curl-config only +VERSIONNUM=`$SED -ne 's/^#define LIBCURL_VERSION_NUM 0x\([0-9A-Fa-f]*\).*/\1/p' ${srcdir}/include/curl/curlver.h` +AC_SUBST(VERSIONNUM) + +dnl +dnl initialize all the info variables + curl_ssl_msg="no (--with-{openssl,gnutls,mbedtls,wolfssl,schannel,amissl,rustls} )" + curl_ssh_msg="no (--with-{libssh,libssh2})" + curl_zlib_msg="no (--with-zlib)" + curl_brotli_msg="no (--with-brotli)" + curl_zstd_msg="no (--with-zstd)" + curl_gss_msg="no (--with-gssapi)" + curl_gsasl_msg="no (--with-gsasl)" + curl_tls_srp_msg="no (--enable-tls-srp)" + curl_res_msg="blocking (--enable-ares / --enable-threaded-resolver)" + curl_ipv6_msg="no (--enable-ipv6)" +curl_unix_sockets_msg="no (--enable-unix-sockets)" + curl_idn_msg="no (--with-{libidn2,winidn})" + curl_docs_msg="enabled (--disable-docs)" + curl_manual_msg="no (--enable-manual)" + curl_libcurl_msg="enabled (--disable-libcurl-option)" + curl_typecheck_msg="enabled (--disable-typecheck)" + curl_verbose_msg="enabled (--disable-verbose)" + curl_sspi_msg="no (--enable-sspi)" + curl_ldap_msg="no (--enable-ldap / --with-ldap-lib / --with-lber-lib)" + curl_ldaps_msg="no (--enable-ldaps)" + curl_ipfs_msg="no (--enable-ipfs)" + curl_rtsp_msg="no (--enable-rtsp)" + curl_psl_msg="no (--with-libpsl)" + curl_altsvc_msg="enabled (--disable-alt-svc)" + curl_headers_msg="enabled (--disable-headers-api)" + curl_hsts_msg="enabled (--disable-hsts)" + ssl_backends= + curl_h1_msg="enabled (internal)" + curl_h2_msg="no (--with-nghttp2)" + curl_h3_msg="no (--with-ngtcp2 --with-nghttp3, --with-quiche)" + +enable_altsvc="yes" +hsts="yes" + +dnl +dnl Save some initial values the user might have provided +dnl +INITIAL_LDFLAGS=$LDFLAGS +INITIAL_LIBS=$LIBS + +dnl +dnl Generates a shell script to run the compiler with LD_LIBRARY_PATH set to +dnl the value used right now. This lets CURL_RUN_IFELSE set LD_LIBRARY_PATH to +dnl something different but only have that affect the execution of the results +dnl of the compile, not change the libraries for the compiler itself. +dnl +compilersh="run-compiler" +CURL_SAVED_CC="$CC" +export CURL_SAVED_CC +CURL_SAVED_LD_LIBRARY_PATH="$LD_LIBRARY_PATH" +export CURL_SAVED_LD_LIBRARY_PATH +cat <<\EOF > "$compilersh" +CC="$CURL_SAVED_CC" +export CC +LD_LIBRARY_PATH="$CURL_SAVED_LD_LIBRARY_PATH" +export LD_LIBRARY_PATH +exec $CC "$@" +EOF + +dnl ********************************************************************** +dnl See which TLS backend(s) that are requested. Do all the +dnl TLS AC_ARG_WITH() invokes here and do the checks later +dnl ********************************************************************** +OPT_SCHANNEL=no +AC_ARG_WITH(schannel, +AS_HELP_STRING([--with-schannel],[enable Windows native SSL/TLS]), + OPT_SCHANNEL=$withval + TLSCHOICE="Schannel") + +OPT_AMISSL=no +AC_ARG_WITH(amissl, +AS_HELP_STRING([--with-amissl],[enable Amiga native SSL/TLS (AmiSSL)]),[ + OPT_AMISSL=$withval + TLSCHOICE="${TLSCHOICE:+$TLSCHOICE, }AmiSSL" +]) + +OPT_OPENSSL=no +dnl Default to no CA bundle +ca="no" +AC_ARG_WITH(ssl, +AS_HELP_STRING([--with-ssl=PATH],[old version of --with-openssl]) +AS_HELP_STRING([--without-ssl], [build without any TLS library]),[ + OPT_SSL=$withval + OPT_OPENSSL=$withval + if test "x$withval" != "xno"; then + TLSCHOICE="${TLSCHOICE:+$TLSCHOICE, }OpenSSL" + else + SSL_DISABLED="D" + fi +]) + +AC_ARG_WITH(openssl, +AS_HELP_STRING([--with-openssl=PATH],[Where to look for OpenSSL, PATH points + to the SSL installation (default: /usr/local/ssl); when possible, set + the PKG_CONFIG_PATH environment variable instead of using this option]), +[ + OPT_OPENSSL=$withval + if test "x$withval" != "xno"; then + TLSCHOICE="${TLSCHOICE:+$TLSCHOICE, }OpenSSL" + fi +]) + +OPT_GNUTLS=no +AC_ARG_WITH(gnutls, +AS_HELP_STRING([--with-gnutls=PATH],[where to look for GnuTLS, PATH points to the installation root]),[ + OPT_GNUTLS=$withval + if test "x$withval" != "xno"; then + TLSCHOICE="${TLSCHOICE:+$TLSCHOICE, }GnuTLS" + fi +]) + +OPT_MBEDTLS=no +AC_ARG_WITH(mbedtls, +AS_HELP_STRING([--with-mbedtls=PATH],[where to look for mbedTLS, PATH points to the installation root]),[ + OPT_MBEDTLS=$withval + if test "x$withval" != "xno"; then + TLSCHOICE="${TLSCHOICE:+$TLSCHOICE, }mbedTLS" + fi +]) + +OPT_WOLFSSL=no +AC_ARG_WITH(wolfssl, +AS_HELP_STRING([--with-wolfssl=PATH],[where to look for wolfSSL, PATH points to the installation root (default: system lib default)]),[ + OPT_WOLFSSL=$withval + if test "x$withval" != "xno"; then + TLSCHOICE="${TLSCHOICE:+$TLSCHOICE, }wolfSSL" + fi +]) + +OPT_RUSTLS=no +AC_ARG_WITH(rustls, +AS_HELP_STRING([--with-rustls=PATH],[where to look for Rustls, PATH points to the installation root]),[ + OPT_RUSTLS=$withval + if test "x$withval" != "xno"; then + TLSCHOICE="${TLSCHOICE:+$TLSCHOICE, }Rustls" + experimental="$experimental Rustls" + fi +]) + +OPT_APPLE_SECTRUST=no +AC_ARG_WITH(apple-sectrust, +AS_HELP_STRING([--with-apple-sectrust],[enable Apple OS native certificate verification]),[ + OPT_APPLE_SECTRUST=$withval +]) + +AC_PATH_PROG(PERL, perl,, $PATH:/usr/local/bin/perl:/usr/bin/:/usr/local/bin) +AC_SUBST(PERL) +AM_CONDITIONAL(PERL, test -n "$PERL") + +TEST_NGHTTPX=nghttpx +AC_ARG_WITH(test-nghttpx, +AS_HELP_STRING([--with-test-nghttpx=PATH],[where to find nghttpx for testing]), + TEST_NGHTTPX=$withval + if test "x$TEST_NGHTTPX" = "xno"; then + TEST_NGHTTPX="" + fi +) +AC_SUBST(TEST_NGHTTPX) + +if test -x /usr/bin/caddy; then + CADDY=/usr/bin/caddy +elif test -x /usr/local/bin/caddy; then + CADDY=/usr/local/bin/caddy +elif test -x "`brew --prefix 2>/dev/null`/bin/caddy"; then + CADDY=`brew --prefix`/bin/caddy +fi +AC_ARG_WITH(test-caddy, +AS_HELP_STRING([--with-test-caddy=PATH],[where to find caddy for testing]), + CADDY=$withval + if test "x$CADDY" = "xno"; then + CADDY="" + fi +) +AC_SUBST(CADDY) + +if test -x /usr/local/bin/h2o; then + H2O=/usr/local/bin/h2o +elif test -x /usr/bin/h2o; then + H2O=/usr/bin/h2o +elif test -x "`brew --prefix 2>/dev/null`/bin/h2o"; then + H2O=`brew --prefix`/bin/h2o +fi +AC_ARG_WITH(test-h2o,dnl +AS_HELP_STRING([--with-test-h2o=PATH],[where to find h2o for testing]), + H2O=$withval + if test "x$H2O" = "xno"; then + H2O="" + fi +) +AC_SUBST(H2O) + +if test -x /usr/sbin/vsftpd; then + VSFTPD=/usr/sbin/vsftpd +elif test -x /usr/local/sbin/vsftpd; then + VSFTPD=/usr/local/sbin/vsftpd +elif test -x "`brew --prefix 2>/dev/null`/sbin/vsftpd"; then + VSFTPD=`brew --prefix`/sbin/vsftpd +fi +AC_ARG_WITH(test-vsftpd, +AS_HELP_STRING([--with-test-vsftpd=PATH],[where to find vsftpd for testing]), + VSFTPD=$withval + if test "x$VSFTPD" = "xno"; then + VSFTPD="" + fi +) +AC_SUBST(VSFTPD) + +dnl we would like an httpd as test server +dnl +HTTPD_ENABLED="maybe" +AC_ARG_WITH(test-httpd, [AS_HELP_STRING([--with-test-httpd=PATH], + [where to find httpd/apache2 for testing])], + [request_httpd=$withval], [request_httpd=check]) +if test "x$request_httpd" = "xcheck" || test "x$request_httpd" = "xyes"; then + if test -x "/usr/sbin/apache2"; then + dnl common location on distros (debian/ubuntu) + HTTPD="/usr/sbin/apache2" + AC_PATH_PROG([APXS], [apxs]) + if test -z "$APXS"; then + AC_MSG_NOTICE([apache2-dev not installed, httpd tests disabled]) + HTTPD_ENABLED="no" + fi + else + AC_PATH_PROG([HTTPD], [httpd]) + if test -z "$HTTPD"; then + AC_PATH_PROG([HTTPD], [apache2]) + fi + AC_PATH_PROG([APXS], [apxs]) + if test -z "$HTTPD"; then + AC_MSG_NOTICE([httpd/apache2 not in PATH, http tests disabled]) + HTTPD_ENABLED="no" + fi + if test -z "$APXS"; then + AC_MSG_NOTICE([apxs not in PATH, http tests disabled]) + HTTPD_ENABLED="no" + fi + fi +elif test "x$request_httpd" != "xno"; then + HTTPD="${request_httpd}/bin/httpd" + APXS="${request_httpd}/bin/apxs" + if test ! -x "${HTTPD}"; then + AC_MSG_NOTICE([httpd not found as ${HTTPD}, http tests disabled]) + HTTPD_ENABLED="no" + elif test ! -x "${APXS}"; then + AC_MSG_NOTICE([apxs not found as ${APXS}, http tests disabled]) + HTTPD_ENABLED="no" + else + AC_MSG_NOTICE([using HTTPD=$HTTPD for tests]) + fi +fi +if test "$HTTPD_ENABLED" = "no"; then + HTTPD="" + APXS="" +fi +AC_SUBST(HTTPD) +AC_SUBST(APXS) + +dnl we would like a dante as test socks server +dnl +DANTED_ENABLED="maybe" +AC_ARG_WITH(test-danted, [AS_HELP_STRING([--with-test-danted=PATH], + [where to find danted socks daemon for testing])], + [request_danted=$withval], [request_danted=check]) +if test "x$request_danted" = "xcheck" || test "x$request_danted" = "xyes"; then + if test -x "/usr/sbin/danted"; then + dnl common location on distros (debian/ubuntu) + DANTED="/usr/sbin/danted" + else + AC_PATH_PROG([DANTED], [danted]) + if test -z "$DANTED"; then + AC_PATH_PROG([DANTED], [danted]) + fi + fi +elif test "x$request_danted" != "xno"; then + DANTED="${request_danted}" + if test ! -x "${DANTED}"; then + AC_MSG_NOTICE([danted not found as ${DANTED}, danted tests disabled]) + DANTED_ENABLED="no" + else + AC_MSG_NOTICE([using DANTED=$DANTED for tests]) + fi +fi +if test "$DANTED_ENABLED" = "no"; then + DANTED="" +fi +AC_SUBST(DANTED) + +dnl we would like a sshd as test server +dnl +SSHD_ENABLED="maybe" +AC_ARG_WITH(test-sshd, [AS_HELP_STRING([--with-test-sshd=PATH], + [where to find sshd for testing])], + [request_sshd=$withval], [request_sshd=check]) +if test "x$request_sshd" = "xcheck" || test "x$request_sshd" = "xyes"; then + if test -x "/usr/sbin/sshd"; then + dnl common location on distros (debian/ubuntu) + SSHD="/usr/sbin/sshd" + else + AC_PATH_PROG([SSHD], [sshd]) + if test -z "$SSHD"; then + AC_PATH_PROG([SSHD], [sshd]) + fi + fi +elif test "x$request_sshd" != "xno"; then + SSHD="${request_sshd}" + if test ! -x "${SSHD}"; then + AC_MSG_NOTICE([sshd not found as ${SSHD}, sshd tests disabled]) + SSHD_ENABLED="no" + else + AC_MSG_NOTICE([using SSHD=$SSHD for tests]) + fi +fi +if test "$SSHD_ENABLED" = "no"; then + SSHD="" + SFTPD="" +else + if test -x "/usr/libexec/sftp-server"; then + dnl common location on macOS) + SFTPD="/usr/libexec/sftp-server" + elif test -x "/usr/lib/openssh/sftp-server"; then + dnl common location on debian + SFTPD="/usr/lib/openssh/sftp-server" + else + AC_PATH_PROG([SFTPD], [sftp-server]) + if test -z "$SFTPD"; then + AC_PATH_PROG([SFTPD], [sftp-server]) + fi + fi +fi +AC_SUBST(SSHD) +AC_SUBST(SFTPD) + +dnl the nghttpx we might use in httpd testing +if test -n "$TEST_NGHTTPX" && test "x$TEST_NGHTTPX" != "xnghttpx"; then + HTTPD_NGHTTPX="$TEST_NGHTTPX" +else + AC_PATH_PROG([HTTPD_NGHTTPX], [nghttpx], [], + [$PATH:/usr/bin:/usr/local/bin]) +fi +AC_SUBST(HTTPD_NGHTTPX) + +dnl the Caddy server we might use in testing +if test -n "$TEST_CADDY"; then + CADDY="$TEST_CADDY" +else + AC_PATH_PROG([CADDY], [caddy]) +fi +AC_SUBST(CADDY) + +dnl If no TLS choice has been made, check if it was explicitly disabled or +dnl error out to force the user to decide. +if test -z "$TLSCHOICE"; then + if test "x$OPT_SSL" != "xno"; then + AC_MSG_ERROR([select TLS backend(s) or disable TLS with --without-ssl. + +Select from these: + + --with-amissl + --with-gnutls + --with-mbedtls + --with-openssl (also works for AWS-LC, BoringSSL and LibreSSL) + --with-rustls + --with-schannel + --with-wolfssl +]) + fi +fi + +AC_ARG_WITH(darwinssl,, + AC_MSG_ERROR([--with-darwin-ssl and --without-darwin-ssl no longer work!])) + +dnl +dnl Detect the canonical host and target build environment +dnl + +AC_CANONICAL_HOST +dnl Get system canonical name +AC_DEFINE_UNQUOTED(CURL_OS, "${host}", [cpu-machine-OS]) + +dnl Silence warning: ar: 'u' modifier ignored since 'D' is the default +AC_SUBST(AR_FLAGS, [cr]) + +dnl This defines _ALL_SOURCE for AIX +CURL_CHECK_AIX_ALL_SOURCE + +dnl Our configure and build reentrant settings +CURL_CONFIGURE_THREAD_SAFE +CURL_CONFIGURE_REENTRANT + +dnl check for how to do large files +AC_SYS_LARGEFILE + +XC_LIBTOOL + +LT_LANG([Windows Resource]) + +AM_CONDITIONAL(NOT_CURL_CI, test -z "$CURL_CI") + +dnl +dnl Automake conditionals based on libtool related checks +dnl + +AM_CONDITIONAL([CURL_LT_SHLIB_USE_VERSION_INFO], + [test "$xc_lt_shlib_use_version_info" = "yes"]) +AM_CONDITIONAL([CURL_LT_SHLIB_USE_NO_UNDEFINED], + [test "$xc_lt_shlib_use_no_undefined" = "yes"]) +AM_CONDITIONAL([CURL_LT_SHLIB_USE_MIMPURE_TEXT], + [test "$xc_lt_shlib_use_mimpure_text" = "yes"]) + +dnl +dnl Due to libtool and automake machinery limitations of not allowing +dnl specifying separate CPPFLAGS or CFLAGS when compiling objects for +dnl inclusion of these in shared or static libraries, we are forced to +dnl build using separate configure runs for shared and static libraries +dnl on systems where different CPPFLAGS or CFLAGS are mandatory in order +dnl to compile objects for each kind of library. Notice that relying on +dnl the '-DPIC' CFLAG that libtool provides is not valid given that the +dnl user might for example choose to build static libraries with PIC. +dnl + +dnl +dnl Make our Makefile.am files use the staticlib CPPFLAG only when strictly +dnl targeting a static library and not building its shared counterpart. +dnl + +AM_CONDITIONAL([USE_CPPFLAG_CURL_STATICLIB], + [test "$xc_lt_build_static_only" = "yes"]) + +dnl +dnl Make staticlib CPPFLAG variable and its definition visible in output +dnl files unconditionally, providing an empty definition unless strictly +dnl targeting a static library and not building its shared counterpart. +dnl + +LIBCURL_PC_CFLAGS_PRIVATE='-DCURL_STATICLIB' +AC_SUBST(LIBCURL_PC_CFLAGS_PRIVATE) + +LIBCURL_PC_CFLAGS= +if test "$xc_lt_build_static_only" = "yes"; then + LIBCURL_PC_CFLAGS="${LIBCURL_PC_CFLAGS_PRIVATE}" +fi +AC_SUBST([LIBCURL_PC_CFLAGS]) + +dnl ********************************************************************** +dnl platform/compiler/architecture specific checks/flags +dnl ********************************************************************** + +CURL_CHECK_COMPILER +dnl for --enable-code-coverage +CURL_COVERAGE +CURL_CHECK_NATIVE_WINDOWS + +curl_cv_winuwp='no' +if test "$curl_cv_native_windows" = "yes"; then + case "$CPPFLAGS" in + *-DWINSTORECOMPAT*) curl_cv_winuwp='yes';; + esac + + AC_MSG_CHECKING([if building for Windows Vista or newer]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + #include + ]],[[ + #if (_WIN32_WINNT < 0x600) + #error + #endif + ]]) + ],[ + AC_MSG_RESULT([yes]) + ],[ + AC_MSG_RESULT([no]) + AC_MSG_ERROR([Building for Windows Vista or newer is required.]) + ]) +fi + +CURL_SET_COMPILER_BASIC_OPTS +CURL_SET_COMPILER_DEBUG_OPTS +CURL_SET_COMPILER_OPTIMIZE_OPTS +CURL_SET_COMPILER_WARNING_OPTS + +if test "$compiler_id" = "INTEL_UNIX_C"; then + if test "$compiler_num" -ge "1000"; then + dnl icc 10.X or later + CFLAGS="$CFLAGS -shared-intel" + elif test "$compiler_num" -ge "900"; then + dnl icc 9.X specific + CFLAGS="$CFLAGS -i-dynamic" + fi +fi + +case $host in + *msdosdjgpp) + if test "$compiler_num" -ge "1000"; then + dnl Avoid warnings in DJGPP's built-in FD_SET() macro + CFLAGS="$CFLAGS -Wno-arith-conversion" + fi + ;; +esac + +CURL_CFLAG_EXTRAS="" +if test "$want_werror" = "yes"; then + CURL_CFLAG_EXTRAS="-Werror" + if test "$compiler_id" = "GNU_C"; then + dnl enable -pedantic-errors for GCC 5 and later, + dnl as before that it was the same as -Werror=pedantic + if test "$compiler_num" -ge "500"; then + CURL_CFLAG_EXTRAS="$CURL_CFLAG_EXTRAS -pedantic-errors" + fi + elif test "$compiler_id" = "CLANG" || test "$compiler_id" = "APPLECLANG"; then + CURL_CFLAG_EXTRAS="$CURL_CFLAG_EXTRAS -pedantic-errors" + fi +fi +AC_SUBST(CURL_CFLAG_EXTRAS) +AM_CONDITIONAL(CURL_WERROR, test "$want_werror" = "yes") + +CURL_CHECK_COMPILER_HALT_ON_ERROR +CURL_CHECK_COMPILER_ARRAY_SIZE_NEGATIVE +CURL_CHECK_COMPILER_PROTOTYPE_MISMATCH +CURL_CHECK_COMPILER_SYMBOL_HIDING + +supports_unittests=yes +dnl cross-compilation of unit tests static library/programs fails when +dnl libcurl shared library is built. This might be due to a libtool or +dnl automake issue. In this case we disable unit tests. +if test "$cross_compiling" != "no" && + test "$enable_shared" != "no"; then + supports_unittests=no +fi + +dnl IRIX 6.5.24 gcc 3.3 autobuilds fail unittests library compilation due to +dnl a problem related with OpenSSL headers and library versions not matching. +dnl Disable unit tests while time to further investigate this is found. +case $host in + mips-sgi-irix6.5) + if test "$compiler_id" = "GNU_C"; then + supports_unittests=no + fi + ;; +esac + +dnl All AIX autobuilds fails unit tests linking against unittests library +dnl due to unittests library being built with no symbols or members. Libtool ? +dnl Disable unit tests while time to further investigate this is found. +case $host_os in + aix*) + supports_unittests=no + ;; +esac + +AM_CONDITIONAL(BUILD_UNITTESTS, test "$supports_unittests" = "yes") + +dnl In order to detect support of sendmmsg() and accept4(), we need to escape +dnl the POSIX jail by defining _GNU_SOURCE or does not expose it. +case $host_os in + *linux*|cygwin*|msys*|gnu*) + CPPFLAGS="$CPPFLAGS -D_GNU_SOURCE" + ;; +esac + +AM_CONDITIONAL(CLANG, test "$compiler_id" = "APPLECLANG" || test "$compiler_id" = "CLANG") + +dnl ********************************************************************** +dnl Compilation based checks should not be done before this point. +dnl ********************************************************************** + +CURL_CHECK_WIN32_CRYPTO + +curl_cv_android='no' +curl_cv_apple='no' +case $host in + *-*-android*) curl_cv_android='yes';; + *-apple-*) curl_cv_apple='yes';; +esac + +if test "$curl_cv_apple" = "yes"; then + CURL_DARWIN_CFLAGS + CURL_SUPPORTS_BUILTIN_AVAILABLE +fi + +AM_CONDITIONAL([HAVE_WINDRES], + [test "$curl_cv_native_windows" = "yes" && test -n "${RC}"]) + +if test "$curl_cv_native_windows" = "yes"; then + AM_COND_IF([HAVE_WINDRES],, + [AC_MSG_ERROR([windres not found in PATH. Windows builds require windres. Cannot continue.])]) +fi + +dnl ---------------------------------------- +dnl whether use "unity" mode for lib and src +dnl ---------------------------------------- + +want_unity='no' +AC_MSG_CHECKING([whether to build libcurl and curl in "unity" mode]) +AC_ARG_ENABLE(unity, +AS_HELP_STRING([--enable-unity],[Enable unity mode]) +AS_HELP_STRING([--disable-unity],[Disable unity (default)]), +[ case "$enableval" in + yes) + want_unity='yes' + AC_MSG_RESULT([yes]) + ;; + *) + AC_MSG_RESULT([no]) + ;; + esac ], + AC_MSG_RESULT([no]) +) +if test -z "$PERL" && test "$want_unity" = "yes"; then + AC_MSG_WARN([perl was not found. Cannot enable unity.]) + want_unity='no' +fi +AM_CONDITIONAL([USE_UNITY], [test "$want_unity" = "yes"]) + +dnl ************************************************************ +dnl switch off particular protocols +dnl +AC_MSG_CHECKING([whether to support http]) +AC_ARG_ENABLE(http, +AS_HELP_STRING([--enable-http],[Enable HTTP support]) +AS_HELP_STRING([--disable-http],[Disable HTTP support]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_HTTP, 1, [to disable HTTP]) + disable_http="yes" + AC_MSG_WARN([disable HTTP disables FTP over proxy, IPFS and RTSP]) + CURL_DISABLE_HTTP=1 + AC_DEFINE(CURL_DISABLE_IPFS, 1, [to disable IPFS]) + CURL_DISABLE_IPFS=1 + AC_DEFINE(CURL_DISABLE_RTSP, 1, [to disable RTSP]) + CURL_DISABLE_RTSP=1 + dnl toggle off alt-svc too when HTTP is disabled + AC_DEFINE(CURL_DISABLE_ALTSVC, 1, [disable alt-svc]) + AC_DEFINE(CURL_DISABLE_HSTS, 1, [disable HSTS]) + curl_h1_msg="no (--enable-http)" + curl_altsvc_msg="no"; + curl_hsts_msg="no (--enable-hsts)"; + enable_altsvc="no" + hsts="no" + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) +AC_MSG_CHECKING([whether to support ftp]) +AC_ARG_ENABLE(ftp, +AS_HELP_STRING([--enable-ftp],[Enable FTP support]) +AS_HELP_STRING([--disable-ftp],[Disable FTP support]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_FTP, 1, [to disable FTP]) + CURL_DISABLE_FTP=1 + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) +AC_MSG_CHECKING([whether to support file]) +AC_ARG_ENABLE(file, +AS_HELP_STRING([--enable-file],[Enable FILE support]) +AS_HELP_STRING([--disable-file],[Disable FILE support]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_FILE, 1, [to disable FILE]) + CURL_DISABLE_FILE=1 + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) +AC_MSG_CHECKING([whether to support IPFS]) +AC_ARG_ENABLE(ipfs, +AS_HELP_STRING([--enable-ipfs],[Enable IPFS support]) +AS_HELP_STRING([--disable-ipfs],[Disable IPFS support]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_IPFS, 1, [to disable IPFS]) + CURL_DISABLE_IPFS=1 + ;; + *) + if test "$CURL_DISABLE_HTTP" = "1"; then + AC_MSG_ERROR(HTTP support needs to be enabled in order to enable IPFS support!) + else + AC_MSG_RESULT(yes) + curl_ipfs_msg="enabled" + fi + ;; + esac ], + if test "$CURL_DISABLE_HTTP" != "1"; then + AC_MSG_RESULT(yes) + curl_ipfs_msg="enabled" + else + AC_MSG_RESULT(no) + fi +) +AC_MSG_CHECKING([whether to support ldap]) +AC_ARG_ENABLE(ldap, +AS_HELP_STRING([--enable-ldap],[Enable LDAP support]) +AS_HELP_STRING([--disable-ldap],[Disable LDAP support]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_LDAP, 1, [to disable LDAP]) + CURL_DISABLE_LDAP=1 + ;; + yes) + ldap_askedfor="yes" + AC_MSG_RESULT(yes) + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ],[ + AC_MSG_RESULT(yes) ] +) +AC_MSG_CHECKING([whether to support ldaps]) +AC_ARG_ENABLE(ldaps, +AS_HELP_STRING([--enable-ldaps],[Enable LDAPS support]) +AS_HELP_STRING([--disable-ldaps],[Disable LDAPS support]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_LDAPS, 1, [to disable LDAPS]) + CURL_DISABLE_LDAPS=1 + ;; + *) + if test "$CURL_DISABLE_LDAP" = "1"; then + AC_MSG_RESULT(LDAP needs to be enabled to support LDAPS) + AC_DEFINE(CURL_DISABLE_LDAPS, 1, [to disable LDAPS]) + CURL_DISABLE_LDAPS=1 + else + AC_MSG_RESULT(yes) + AC_DEFINE(HAVE_LDAP_SSL, 1, [Use LDAPS implementation]) + HAVE_LDAP_SSL=1 + fi + ;; + esac ],[ + if test "$CURL_DISABLE_LDAP" = "1"; then + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_LDAPS, 1, [to disable LDAPS]) + CURL_DISABLE_LDAPS=1 + else + AC_MSG_RESULT(yes) + AC_DEFINE(HAVE_LDAP_SSL, 1, [Use LDAPS implementation]) + HAVE_LDAP_SSL=1 + fi ] +) + +AC_MSG_CHECKING([whether to support rtsp]) +AC_ARG_ENABLE(rtsp, +AS_HELP_STRING([--enable-rtsp],[Enable RTSP support]) +AS_HELP_STRING([--disable-rtsp],[Disable RTSP support]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_RTSP, 1, [to disable RTSP]) + CURL_DISABLE_RTSP=1 + ;; + *) + if test "$CURL_DISABLE_HTTP" = "1"; then + AC_MSG_ERROR(HTTP support needs to be enabled in order to enable RTSP support!) + else + AC_MSG_RESULT(yes) + curl_rtsp_msg="enabled" + fi + ;; + esac ], + if test "$CURL_DISABLE_HTTP" != "1"; then + AC_MSG_RESULT(yes) + curl_rtsp_msg="enabled" + else + AC_MSG_RESULT(no) + fi +) + +AC_MSG_CHECKING([whether to support proxies]) +AC_ARG_ENABLE(proxy, +AS_HELP_STRING([--enable-proxy],[Enable proxy support]) +AS_HELP_STRING([--disable-proxy],[Disable proxy support]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_PROXY, 1, [to disable proxies]) + CURL_DISABLE_PROXY=1 + https_proxy="no" + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) + +AC_MSG_CHECKING([whether to support dict]) +AC_ARG_ENABLE(dict, +AS_HELP_STRING([--enable-dict],[Enable DICT support]) +AS_HELP_STRING([--disable-dict],[Disable DICT support]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_DICT, 1, [to disable DICT]) + CURL_DISABLE_DICT=1 + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) + +AC_MSG_CHECKING([whether to support telnet]) +AC_ARG_ENABLE(telnet, +AS_HELP_STRING([--enable-telnet],[Enable TELNET support]) +AS_HELP_STRING([--disable-telnet],[Disable TELNET support]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_TELNET, 1, [to disable TELNET]) + CURL_DISABLE_TELNET=1 + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) + +if test "$curl_cv_winuwp" = "yes"; then + AC_DEFINE(CURL_DISABLE_TELNET, 1, [to disable TELNET]) + CURL_DISABLE_TELNET=1 +fi + +AC_MSG_CHECKING([whether to support tftp]) +AC_ARG_ENABLE(tftp, +AS_HELP_STRING([--enable-tftp],[Enable TFTP support]) +AS_HELP_STRING([--disable-tftp],[Disable TFTP support]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_TFTP, 1, [to disable TFTP]) + CURL_DISABLE_TFTP=1 + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) + +AC_MSG_CHECKING([whether to support pop3]) +AC_ARG_ENABLE(pop3, +AS_HELP_STRING([--enable-pop3],[Enable POP3 support]) +AS_HELP_STRING([--disable-pop3],[Disable POP3 support]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_POP3, 1, [to disable POP3]) + CURL_DISABLE_POP3=1 + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) + +AC_MSG_CHECKING([whether to support imap]) +AC_ARG_ENABLE(imap, +AS_HELP_STRING([--enable-imap],[Enable IMAP support]) +AS_HELP_STRING([--disable-imap],[Disable IMAP support]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_IMAP, 1, [to disable IMAP]) + CURL_DISABLE_IMAP=1 + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) + +AC_MSG_CHECKING([whether to support smb]) +AC_ARG_ENABLE(smb, +AS_HELP_STRING([--enable-smb],[Enable SMB support]) +AS_HELP_STRING([--disable-smb],[Disable SMB support]), +[ case "$enableval" in + yes) + AC_MSG_RESULT(yes) + AC_DEFINE(CURL_ENABLE_SMB, 1, [to enable SMB]) + CURL_ENABLE_SMB=1 + ;; + *) + AC_MSG_RESULT(no) + ;; + esac ], + AC_MSG_RESULT(no) +) + +AC_MSG_CHECKING([whether to support smtp]) +AC_ARG_ENABLE(smtp, +AS_HELP_STRING([--enable-smtp],[Enable SMTP support]) +AS_HELP_STRING([--disable-smtp],[Disable SMTP support]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_SMTP, 1, [to disable SMTP]) + CURL_DISABLE_SMTP=1 + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) + +AC_MSG_CHECKING([whether to support gopher]) +AC_ARG_ENABLE(gopher, +AS_HELP_STRING([--enable-gopher],[Enable Gopher support]) +AS_HELP_STRING([--disable-gopher],[Disable Gopher support]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_GOPHER, 1, [to disable Gopher]) + CURL_DISABLE_GOPHER=1 + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) + +AC_MSG_CHECKING([whether to support mqtt]) +AC_ARG_ENABLE(mqtt, +AS_HELP_STRING([--enable-mqtt],[Enable MQTT support]) +AS_HELP_STRING([--disable-mqtt],[Disable MQTT support]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_MQTT, 1, [to disable MQTT]) + CURL_DISABLE_MQTT=1 + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(no) +) + +AC_MSG_CHECKING([enable curl_global_init_mem debug build]) +AC_ARG_ENABLE(init-mem-debug, +AS_HELP_STRING([--enable-init-mem-debug],[curl_global_init_mem debug]) +AS_HELP_STRING([--disable-init-mem-debug],[]), +[ case "$enableval" in + yes) + AC_MSG_RESULT(yes) + AC_DEFINE(CURL_DEBUG_GLOBAL_MEM, 1, [curl_debug_global_mem debug build]) + SUPPORT_FEATURES="$SUPPORT_FEATURES global-mem-debug" + ;; + *) + AC_MSG_RESULT(no) + ;; + esac ], + AC_MSG_RESULT(no) +) + +dnl ********************************************************************** +dnl Check for built-in manual +dnl ********************************************************************** + +AC_MSG_CHECKING([whether to provide built-in manual]) +AC_ARG_ENABLE(manual, +AS_HELP_STRING([--enable-manual],[Enable built-in manual]) +AS_HELP_STRING([--disable-manual],[Disable built-in manual]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + ;; + *) + AC_MSG_RESULT(yes) + USE_MANUAL="1" + ;; + esac ], + AC_MSG_RESULT(yes) + USE_MANUAL="1" +) +dnl The actual use of the USE_MANUAL variable is done much later in this +dnl script to allow other actions to disable it as well. + +dnl ********************************************************************** +dnl Check whether to build documentation +dnl ********************************************************************** + +AC_MSG_CHECKING([whether to build documentation]) +AC_ARG_ENABLE(docs, +AS_HELP_STRING([--enable-docs],[Enable documentation]) +AS_HELP_STRING([--disable-docs],[Disable documentation]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + BUILD_DOCS=0 + dnl disable manual too because it needs built documentation + USE_MANUAL=0 + curl_docs_msg="no" + ;; + *) + AC_MSG_RESULT(yes) + BUILD_DOCS=1 + ;; + esac ], + AC_MSG_RESULT(yes) + BUILD_DOCS=1 +) +if test -z "$PERL" && test "$BUILD_DOCS" != "0"; then + AC_MSG_WARN([perl was not found. Cannot build documentation.]) + BUILD_DOCS=0 +fi + +dnl ************************************************************ +dnl disable C code generation support +dnl +AC_MSG_CHECKING([whether to enable generation of C code]) +AC_ARG_ENABLE(libcurl_option, +AS_HELP_STRING([--enable-libcurl-option],[Enable --libcurl C code generation support]) +AS_HELP_STRING([--disable-libcurl-option],[Disable --libcurl C code generation support]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_LIBCURL_OPTION, 1, [to disable --libcurl C code generation option]) + curl_libcurl_msg="no" + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) + +dnl ********************************************************************** +dnl Checks for libraries. +dnl ********************************************************************** + +AC_MSG_CHECKING([whether to use libgcc]) +AC_ARG_ENABLE(libgcc, +AS_HELP_STRING([--enable-libgcc],[use libgcc when linking]), +[ case "$enableval" in + yes) + LIBS="-lgcc $LIBS" + AC_MSG_RESULT(yes) + ;; + *) + AC_MSG_RESULT(no) + ;; + esac ], + AC_MSG_RESULT(no) +) + +AC_MSG_CHECKING([whether to use libbacktrace]) +AC_ARG_WITH(backtrace, +AS_HELP_STRING([--enable-backtrace],[use libbacktrace when linking]), +[ case "$enableval" in + yes) + LIBS="-lbacktrace $LIBS" + AC_DEFINE(USE_BACKTRACE, 1, [if libbacktrace is in use]) + AC_MSG_RESULT(yes) + ;; + *) + AC_MSG_RESULT(no) + ;; + esac ], + AC_MSG_RESULT(no) +) + +CURL_CHECK_LIB_XNET + +dnl gethostbyname without lib or in the nsl lib? +AC_CHECK_FUNC(gethostbyname, + [ + HAVE_GETHOSTBYNAME="1" + ], + [ + AC_CHECK_LIB(nsl, gethostbyname, + [ + HAVE_GETHOSTBYNAME="1" + LIBS="-lnsl $LIBS" + ] + ) + ] +) + +if test "$HAVE_GETHOSTBYNAME" != "1"; then + dnl gethostbyname in the socket lib? + AC_CHECK_LIB(socket, gethostbyname, + [ + HAVE_GETHOSTBYNAME="1" + LIBS="-lsocket $LIBS" + ] + ) +fi + +if test "$HAVE_GETHOSTBYNAME" != "1"; then + dnl gethostbyname in the watt lib? + clean_CPPFLAGS=$CPPFLAGS + clean_LDFLAGS=$LDFLAGS + CPPFLAGS="-I${WATT_ROOT}/inc" + LDFLAGS="-L${WATT_ROOT}/lib" + AC_CHECK_LIB(watt, gethostbyname, + [ + HAVE_GETHOSTBYNAME="1" + LIBS="-lwatt $LIBS" + AC_DEFINE(USE_WATT32, 1, [if Watt-32 is in use]) + ], + [ + CPPFLAGS=$clean_CPPFLAGS + LDFLAGS=$clean_LDFLAGS + ] + ) +fi + +dnl At least one system has been identified to require BOTH nsl and socket +dnl libs at the same time to link properly. +if test "$HAVE_GETHOSTBYNAME" != "1"; then + AC_MSG_CHECKING([for gethostbyname with both nsl and socket libs]) + my_ac_save_LIBS=$LIBS + LIBS="-lnsl -lsocket $LIBS" + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([[ + ]],[[ + gethostbyname(); + ]]) + ],[ + AC_MSG_RESULT([yes]) + HAVE_GETHOSTBYNAME="1" + ],[ + AC_MSG_RESULT([no]) + LIBS=$my_ac_save_LIBS + ]) +fi + +dnl In UWP mode gethostbyname gets detected via the core libs, but some +dnl code (in6addr_any) still need ws2_32, so let us detect and add it. +if test "$HAVE_GETHOSTBYNAME" != "1" || test "$curl_cv_winuwp" = "yes"; then + if test "$curl_cv_native_windows" = "yes"; then + dnl This is for Winsock systems + winsock_LIB="-lws2_32" + if test "$curl_cv_winuwp" != "yes"; then + winsock_LIB="$winsock_LIB -liphlpapi" + fi + my_ac_save_LIBS=$LIBS + LIBS="$winsock_LIB $LIBS" + AC_MSG_CHECKING([for gethostbyname in $winsock_LIB]) + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([[ + #ifdef _WIN32 + #ifndef WIN32_LEAN_AND_MEAN + #define WIN32_LEAN_AND_MEAN + #endif + #include + #endif + ]],[[ + gethostbyname("localhost"); + ]]) + ],[ + AC_MSG_RESULT([yes]) + HAVE_GETHOSTBYNAME="1" + ],[ + AC_MSG_RESULT([no]) + winsock_LIB="" + LIBS=$my_ac_save_LIBS + ]) + fi +fi + +if test "$HAVE_GETHOSTBYNAME" != "1"; then + dnl This is for Minix 3.1 + AC_MSG_CHECKING([for gethostbyname for Minix 3]) + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([[ + /* Older Minix versions may need here instead */ + #include + ]],[[ + gethostbyname("localhost"); + ]]) + ],[ + AC_MSG_RESULT([yes]) + HAVE_GETHOSTBYNAME="1" + ],[ + AC_MSG_RESULT([no]) + ]) +fi + +if test "$HAVE_GETHOSTBYNAME" != "1"; then + dnl This is for eCos with a stubbed DNS implementation + AC_MSG_CHECKING([for gethostbyname for eCos]) + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([[ + #include + #include + ]],[[ + gethostbyname("localhost"); + ]]) + ],[ + AC_MSG_RESULT([yes]) + HAVE_GETHOSTBYNAME="1" + ],[ + AC_MSG_RESULT([no]) + ]) +fi + +if test "$HAVE_GETHOSTBYNAME" != "1" || test "${with_amissl+set}" = "set"; then + dnl This is for AmigaOS with bsdsocket.library - needs testing before -lnet + AC_MSG_CHECKING([for gethostbyname for AmigaOS bsdsocket.library]) + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([[ + #define __USE_INLINE__ + #include + #ifdef __amigaos4__ + struct SocketIFace *ISocket = NULL; + #else + struct Library *SocketBase = NULL; + #endif + ]],[[ + unsigned char host[] = "localhost"; + gethostbyname(host); + ]]) + ],[ + AC_MSG_RESULT([yes]) + HAVE_GETHOSTBYNAME="1" + HAVE_PROTO_BSDSOCKET_H="1" + AC_DEFINE(HAVE_PROTO_BSDSOCKET_H, 1, [if Amiga bsdsocket.library is in use]) + ],[ + AC_MSG_RESULT([no]) + ]) +fi + +if test "$HAVE_GETHOSTBYNAME" != "1"; then + dnl gethostbyname in the network lib - for Haiku OS + AC_CHECK_LIB(network, gethostbyname, + [ + HAVE_GETHOSTBYNAME="1" + LIBS="-lnetwork $LIBS" + ] + ) +fi + +CURL_CHECK_LIBS_CONNECT + +dnl ********************************************************************** +dnl In case that function clock_gettime with monotonic timer is available, +dnl check for additional required libraries. +dnl ********************************************************************** +CURL_CHECK_LIBS_CLOCK_GETTIME_MONOTONIC + +dnl Check for even better option +CURL_CHECK_FUNC_CLOCK_GETTIME_MONOTONIC_RAW + +dnl ********************************************************************** +dnl The preceding library checks are all potentially useful for test +dnl servers and libtest cases which require networking and clock_gettime +dnl support. Save the list of required libraries at this point for use +dnl while linking those test servers and programs. +dnl ********************************************************************** +CURL_NETWORK_AND_TIME_LIBS=$LIBS + +dnl ********************************************************************** +dnl Check for the presence of ZLIB libraries and headers +dnl ********************************************************************** + +dnl Check for & handle argument to --with-zlib. + +clean_CPPFLAGS=$CPPFLAGS +clean_LDFLAGS=$LDFLAGS +clean_LIBS=$LIBS +ZLIB_LIBS="" +AC_ARG_WITH(zlib, +AS_HELP_STRING([--with-zlib=PATH],[search for zlib in PATH]) +AS_HELP_STRING([--without-zlib],[disable use of zlib]), + [OPT_ZLIB="$withval"]) + +if test "x$OPT_ZLIB" = "xno"; then + AC_MSG_WARN([zlib disabled]) +else + if test "x$OPT_ZLIB" = "xyes"; then + OPT_ZLIB="" + fi + + if test -z "$OPT_ZLIB"; then + CURL_CHECK_PKGCONFIG(zlib) + + if test "$PKGCONFIG" != "no"; then + ZLIB_LIBS="`$PKGCONFIG --libs-only-l zlib`" + if test -n "$ZLIB_LIBS"; then + LDFLAGS="$LDFLAGS `$PKGCONFIG --libs-only-L zlib`" + else + ZLIB_LIBS="`$PKGCONFIG --libs zlib`" + fi + LIBS="$ZLIB_LIBS $LIBS" + CPPFLAGS="$CPPFLAGS `$PKGCONFIG --cflags zlib`" + OPT_ZLIB="" + HAVE_LIBZ="1" + fi + + if test -z "$HAVE_LIBZ"; then + + dnl Check for the lib without setting any new path, since many + dnl people have it in the default path + + AC_CHECK_LIB(z, inflateEnd, + dnl libz found, set the variable + [ + HAVE_LIBZ="1" + ZLIB_LIBS="-lz" + LIBS="$ZLIB_LIBS $LIBS" + ], + dnl if no lib found, try /usr/local + [ + OPT_ZLIB="/usr/local" + ] + ) + fi + fi + + dnl Add a nonempty path to the compiler flags + if test -n "$OPT_ZLIB"; then + CPPFLAGS="$CPPFLAGS -I$OPT_ZLIB/include" + LDFLAGS="$LDFLAGS -L$OPT_ZLIB/lib$libsuff" + fi + + AC_CHECK_HEADER(zlib.h, + [ + dnl zlib.h was found + HAVE_ZLIB_H="1" + dnl if the lib was not found already, try again with the new paths + if test "$HAVE_LIBZ" != "1"; then + AC_CHECK_LIB(z, gzread, + [ + dnl the lib was found! + HAVE_LIBZ="1" + ZLIB_LIBS="-lz" + LIBS="$ZLIB_LIBS $LIBS" + ], + [ + CPPFLAGS=$clean_CPPFLAGS + LDFLAGS=$clean_LDFLAGS + ] + ) + fi + ], + [ + dnl zlib.h was not found, restore the flags + CPPFLAGS=$clean_CPPFLAGS + LDFLAGS=$clean_LDFLAGS] + ) + + if test "$HAVE_LIBZ" = "1" && test "$HAVE_ZLIB_H" != "1"; then + AC_MSG_WARN([configure found only the libz lib, not the header file!]) + HAVE_LIBZ="" + CPPFLAGS=$clean_CPPFLAGS + LDFLAGS=$clean_LDFLAGS + LIBS=$clean_LIBS + ZLIB_LIBS="" + elif test "$HAVE_LIBZ" != "1" && test "$HAVE_ZLIB_H" = "1"; then + AC_MSG_WARN([configure found only the libz header file, not the lib!]) + CPPFLAGS=$clean_CPPFLAGS + LDFLAGS=$clean_LDFLAGS + LIBS=$clean_LIBS + ZLIB_LIBS="" + elif test "$HAVE_LIBZ" = "1" && test "$HAVE_ZLIB_H" = "1"; then + dnl both header and lib were found! + AC_SUBST(HAVE_LIBZ) + AC_DEFINE(HAVE_LIBZ, 1, [if zlib is available]) + LIBS="$ZLIB_LIBS $clean_LIBS" + + dnl replace 'HAVE_LIBZ' in the automake makefile.ams + AMFIXLIB="1" + AC_MSG_NOTICE([found both libz and libz.h header]) + dnl Android does not provide zlib.pc + if test "$curl_cv_android" = "no"; then + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE zlib" + fi + curl_zlib_msg="enabled" + fi +fi + +dnl set variable for use in automakefile(s) +AM_CONDITIONAL(HAVE_LIBZ, test "$AMFIXLIB" = "1") +AC_SUBST(ZLIB_LIBS) + +dnl ********************************************************************** +dnl Check for the presence of BROTLI decoder libraries and headers +dnl ********************************************************************** + +dnl Brotli project home page: https://github.com/google/brotli + +dnl Default to compiler & linker defaults for BROTLI files & libraries. +OPT_BROTLI=off +AC_ARG_WITH(brotli, +AS_HELP_STRING([--with-brotli=PATH],[Where to look for brotli, PATH points to the BROTLI installation; + when possible, set the PKG_CONFIG_PATH environment variable instead of using this option]) +AS_HELP_STRING([--without-brotli], [disable BROTLI]), + OPT_BROTLI=$withval) + +if test "x$OPT_BROTLI" != "xno"; then + dnl backup the pre-brotli variables + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + case "$OPT_BROTLI" in + yes) + dnl --with-brotli (without path) used + CURL_CHECK_PKGCONFIG(libbrotlidec) + + if test "$PKGCONFIG" != "no"; then + LIB_BROTLI=`$PKGCONFIG --libs-only-l libbrotlidec` + LD_BROTLI=`$PKGCONFIG --libs-only-L libbrotlidec` + CPP_BROTLI=`$PKGCONFIG --cflags-only-I libbrotlidec` + version=`$PKGCONFIG --modversion libbrotlidec` + fi + + CURL_CHECK_PKGCONFIG(libbrotlicommon) + + if test "$PKGCONFIG" != "no"; then + LIB_BROTLI="$LIB_BROTLI `$PKGCONFIG --libs-only-l libbrotlicommon`" + LD_BROTLI="$LD_BROTLI `$PKGCONFIG --libs-only-L libbrotlicommon`" + CPP_BROTLI="$CPP_BROTLI `$PKGCONFIG --cflags-only-I libbrotlicommon`" + fi + + DIR_BROTLI=`echo $LD_BROTLI | $SED -e 's/^-L//'` + ;; + off) + dnl no --with-brotli option given, check default places + ;; + *) + dnl use the given --with-brotli spot + PREFIX_BROTLI=$OPT_BROTLI + ;; + esac + + dnl if given with a prefix, we set -L and -I based on that + if test -n "$PREFIX_BROTLI"; then + LIB_BROTLI="-lbrotlidec -lbrotlicommon" + LD_BROTLI=-L${PREFIX_BROTLI}/lib$libsuff + CPP_BROTLI=-I${PREFIX_BROTLI}/include + DIR_BROTLI=${PREFIX_BROTLI}/lib$libsuff + fi + + LDFLAGS="$LDFLAGS $LD_BROTLI" + LDFLAGSPC="$LDFLAGSPC $LD_BROTLI" + CPPFLAGS="$CPPFLAGS $CPP_BROTLI" + LIBS="$LIB_BROTLI $LIBS" + + AC_CHECK_LIB(brotlidec, BrotliDecoderDecompress) + + AC_CHECK_HEADERS(brotli/decode.h, + curl_brotli_msg="enabled (libbrotlidec)" + HAVE_BROTLI=1 + AC_DEFINE(HAVE_BROTLI, 1, [if BROTLI is in use]) + ) + + if test "x$OPT_BROTLI" != "xoff" && + test "$HAVE_BROTLI" != "1"; then + AC_MSG_ERROR([BROTLI libs and/or directories were not found where specified!]) + fi + + if test "$HAVE_BROTLI" = "1"; then + if test -n "$DIR_BROTLI"; then + dnl when the brotli shared libs were found in a path that the runtime + dnl linker does not search through, we need to add it to CURL_LIBRARY_PATH + dnl to prevent further configure tests to fail due to this + + if test "$cross_compiling" != "yes"; then + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$DIR_BROTLI" + export CURL_LIBRARY_PATH + AC_MSG_NOTICE([Added $DIR_BROTLI to CURL_LIBRARY_PATH]) + fi + fi + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libbrotlidec libbrotlicommon" + else + dnl no brotli, revert back to clean variables + LDFLAGS=$CLEANLDFLAGS + LDFLAGSPC=$CLEANLDFLAGSPC + CPPFLAGS=$CLEANCPPFLAGS + LIBS=$CLEANLIBS + fi +fi + +dnl ********************************************************************** +dnl Check for libzstd +dnl ********************************************************************** + +dnl Default to compiler & linker defaults for libzstd +OPT_ZSTD=off +AC_ARG_WITH(zstd, +AS_HELP_STRING([--with-zstd=PATH],[Where to look for libzstd, PATH points to the libzstd installation; + when possible, set the PKG_CONFIG_PATH environment variable instead of using this option]) +AS_HELP_STRING([--without-zstd], [disable libzstd]), + OPT_ZSTD=$withval) + +if test "x$OPT_ZSTD" != "xno"; then + dnl backup the pre-zstd variables + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + case "$OPT_ZSTD" in + yes) + dnl --with-zstd (without path) used + CURL_CHECK_PKGCONFIG(libzstd) + + if test "$PKGCONFIG" != "no"; then + LIB_ZSTD=`$PKGCONFIG --libs-only-l libzstd` + LD_ZSTD=`$PKGCONFIG --libs-only-L libzstd` + CPP_ZSTD=`$PKGCONFIG --cflags-only-I libzstd` + version=`$PKGCONFIG --modversion libzstd` + DIR_ZSTD=`echo $LD_ZSTD | $SED -e 's/-L//'` + fi + + ;; + off) + dnl no --with-zstd option given, check default places + ;; + *) + dnl use the given --with-zstd spot + PREFIX_ZSTD=$OPT_ZSTD + ;; + esac + + dnl if given with a prefix, we set -L and -I based on that + if test -n "$PREFIX_ZSTD"; then + LIB_ZSTD="-lzstd" + LD_ZSTD=-L${PREFIX_ZSTD}/lib$libsuff + CPP_ZSTD=-I${PREFIX_ZSTD}/include + DIR_ZSTD=${PREFIX_ZSTD}/lib$libsuff + fi + + LDFLAGS="$LDFLAGS $LD_ZSTD" + LDFLAGSPC="$LDFLAGSPC $LD_ZSTD" + CPPFLAGS="$CPPFLAGS $CPP_ZSTD" + LIBS="$LIB_ZSTD $LIBS" + + AC_CHECK_LIB(zstd, ZSTD_createDStream) + + AC_CHECK_HEADERS(zstd.h, + curl_zstd_msg="enabled (libzstd)" + HAVE_ZSTD=1 + AC_DEFINE(HAVE_ZSTD, 1, [if libzstd is in use]) + ) + + if test "x$OPT_ZSTD" != "xoff" && + test "$HAVE_ZSTD" != "1"; then + AC_MSG_ERROR([libzstd was not found where specified!]) + fi + + if test "$HAVE_ZSTD" = "1"; then + if test -n "$DIR_ZSTD"; then + dnl when the zstd shared lib were found in a path that the runtime + dnl linker does not search through, we need to add it to + dnl CURL_LIBRARY_PATH to prevent further configure tests to fail due to + dnl this + + if test "$cross_compiling" != "yes"; then + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$DIR_ZSTD" + export CURL_LIBRARY_PATH + AC_MSG_NOTICE([Added $DIR_ZSTD to CURL_LIBRARY_PATH]) + fi + fi + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libzstd" + else + dnl no zstd, revert back to clean variables + LDFLAGS=$CLEANLDFLAGS + LDFLAGSPC=$CLEANLDFLAGSPC + CPPFLAGS=$CLEANCPPFLAGS + LIBS=$CLEANLIBS + fi +fi + +dnl ********************************************************************** +dnl Checks for IPv6 +dnl ********************************************************************** + +AC_MSG_CHECKING([whether to enable IPv6]) +AC_ARG_ENABLE(ipv6, +AS_HELP_STRING([--enable-ipv6],[Enable IPv6 (with IPv4) support]) +AS_HELP_STRING([--disable-ipv6],[Disable IPv6 support]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + ipv6=no + ;; + *) + AC_MSG_RESULT(yes) + ipv6=yes + ;; + esac ], + + AC_COMPILE_IFELSE([ + AC_LANG_SOURCE([[ + /* are AF_INET6 and sockaddr_in6 available? */ + #include + #ifdef _WIN32 + #include + #include + #else + #include + #include + #ifdef __TANDEM + #include + #endif + #endif + int main(void) + { + int s = (int)sizeof(struct sockaddr_in6); + (void)s; + return socket(AF_INET6, SOCK_STREAM, 0) > 0; + } + ]]) + ], + AC_MSG_RESULT(yes) + ipv6=yes, + AC_MSG_RESULT(no) + ipv6=no + ) +) + +if test "$ipv6" = "yes"; then + curl_ipv6_msg="enabled" + AC_DEFINE(USE_IPV6, 1, [Define if you want to enable IPv6 support]) + IPV6_ENABLED=1 + + AC_MSG_CHECKING([if struct sockaddr_in6 has sin6_scope_id member]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + #include + #ifdef _WIN32 + #include + #include + #else + #include + #ifdef __TANDEM + #include + #endif + #endif + ]], [[ + struct sockaddr_in6 s; + s.sin6_scope_id = 0; + (void)s; + ]]) + ],[ + AC_MSG_RESULT([yes]) + AC_DEFINE(HAVE_SOCKADDR_IN6_SIN6_SCOPE_ID, 1, [Define to 1 if struct sockaddr_in6 has the sin6_scope_id member]) + ],[ + AC_MSG_RESULT([no]) + ]) +fi + +dnl ********************************************************************** +dnl Check if the operating system allows programs to write to their own argv[] +dnl ********************************************************************** + +AC_MSG_CHECKING([if argv can be written to]) +CURL_RUN_IFELSE([[ +int main(int argc, char **argv) +{ +#ifdef _WIN32 + /* on Windows, writing to the argv does not hide the argument in + process lists so it can be skipped */ + (void)argc; + (void)argv; + return 1; +#else + (void)argc; + argv[0][0] = ' '; + return (argv[0][0] == ' ') ? 0 : 1; +#endif +} +]],[ + curl_cv_writable_argv=yes +],[ + curl_cv_writable_argv=no +],[ + curl_cv_writable_argv=cross +]) +if test "$curl_cv_writable_argv" = "cross" && test "$curl_cv_apple" = "yes"; then + curl_cv_writable_argv=yes +fi +case $curl_cv_writable_argv in + yes) + AC_DEFINE(HAVE_WRITABLE_ARGV, 1, [Define this symbol if your OS supports changing the contents of argv]) + AC_MSG_RESULT(yes) + ;; + no) + AC_MSG_RESULT(no) + ;; + *) + AC_MSG_RESULT(no) + AC_MSG_WARN([the previous check could not be made default was used]) + ;; +esac + +dnl ********************************************************************** +dnl Check for GSS-API libraries +dnl ********************************************************************** + +dnl check for GSS-API stuff in the /usr as default + +GSSAPI_ROOT="/usr" +AC_ARG_WITH(gssapi-includes, + AS_HELP_STRING([--with-gssapi-includes=DIR], [Specify location of GSS-API headers]), [ + GSSAPI_INCS="-I$withval" + want_gss="yes" + ] +) + +AC_ARG_WITH(gssapi-libs, + AS_HELP_STRING([--with-gssapi-libs=DIR], [Specify location of GSS-API libs]), [ + GSSAPI_LIB_DIR="-L$withval" + want_gss="yes" + ] +) + +AC_ARG_WITH(gssapi, + AS_HELP_STRING([--with-gssapi=DIR], [Where to look for GSS-API]), [ + GSSAPI_ROOT="$withval" + if test "$GSSAPI_ROOT" != "no"; then + want_gss="yes" + if test "$GSSAPI_ROOT" = "yes"; then + dnl if yes, then use default root + GSSAPI_ROOT="/usr" + fi + fi + ] +) + +: ${KRB5CONFIG:="$GSSAPI_ROOT/bin/krb5-config"} + +save_CPPFLAGS="$CPPFLAGS" +AC_MSG_CHECKING([if GSS-API support is requested]) +if test "$want_gss" = "yes"; then + AC_MSG_RESULT(yes) + + if test "$GSSAPI_ROOT" != "/usr"; then + CURL_CHECK_PKGCONFIG(mit-krb5-gssapi, $GSSAPI_ROOT/lib/pkgconfig) + else + CURL_CHECK_PKGCONFIG(mit-krb5-gssapi) + fi + if test -z "$GSSAPI_INCS"; then + if test -n "$host_alias" && test -f "$GSSAPI_ROOT/bin/$host_alias-krb5-config"; then + GSSAPI_INCS=`$GSSAPI_ROOT/bin/$host_alias-krb5-config --cflags gssapi` + elif test "$PKGCONFIG" != "no"; then + GSSAPI_INCS=`$PKGCONFIG --cflags mit-krb5-gssapi` + elif test -f "$KRB5CONFIG"; then + GSSAPI_INCS=`$KRB5CONFIG --cflags gssapi` + elif test "$GSSAPI_ROOT" != "yes"; then + GSSAPI_INCS="-I$GSSAPI_ROOT/include" + fi + fi + + CPPFLAGS="$CPPFLAGS $GSSAPI_INCS" + + AC_CHECK_HEADER(gss.h, + [ + dnl found in the given dirs + AC_DEFINE(HAVE_GSSGNU, 1, [if you have GNU GSS]) + gnu_gss=yes + ], + [ + dnl not found, check for MIT + AC_CHECK_HEADERS( + [gssapi/gssapi.h gssapi/gssapi_generic.h gssapi/gssapi_krb5.h], + [], + [not_mit=1]) + if test "$not_mit" = "1"; then + dnl MIT not found + AC_MSG_ERROR([MIT or GNU GSS library required, but not found]) + fi + ] + ) +else + AC_MSG_RESULT(no) +fi +if test "$want_gss" = "yes"; then + AC_DEFINE(HAVE_GSSAPI, 1, [if you have GSS-API libraries]) + HAVE_GSSAPI=1 + curl_gss_msg="enabled (MIT Kerberos)" + link_pkgconfig='' + + if test -n "$gnu_gss"; then + curl_gss_msg="enabled (GNU GSS)" + LDFLAGS="$LDFLAGS $GSSAPI_LIB_DIR" + LDFLAGSPC="$LDFLAGSPC $GSSAPI_LIB_DIR" + LIBS="-lgss $LIBS" + link_pkgconfig=1 + elif test -z "$GSSAPI_LIB_DIR"; then + if test "$curl_cv_apple" = "yes"; then + LIBS="-lgssapi_krb5 -lresolv $LIBS" + else + if test "$GSSAPI_ROOT" != "/usr"; then + CURL_CHECK_PKGCONFIG(mit-krb5-gssapi, $GSSAPI_ROOT/lib/pkgconfig) + else + CURL_CHECK_PKGCONFIG(mit-krb5-gssapi) + fi + if test -n "$host_alias" && test -f "$GSSAPI_ROOT/bin/$host_alias-krb5-config"; then + dnl krb5-config does not have --libs-only-L or similar, put everything + dnl into LIBS + gss_libs=`$GSSAPI_ROOT/bin/$host_alias-krb5-config --libs gssapi` + LIBS="$gss_libs $LIBS" + elif test "$PKGCONFIG" != "no"; then + gss_libs=`$PKGCONFIG --libs mit-krb5-gssapi` + LIBS="$gss_libs $LIBS" + link_pkgconfig=1 + elif test -f "$KRB5CONFIG"; then + dnl krb5-config does not have --libs-only-L or similar, put everything + dnl into LIBS + gss_libs=`$KRB5CONFIG --libs gssapi` + LIBS="$gss_libs $LIBS" + link_pkgconfig=1 + else + case $host in + *-hp-hpux*) + gss_libname="gss" + ;; + *) + gss_libname="gssapi" + ;; + esac + + if test "$GSSAPI_ROOT" != "yes"; then + LDFLAGS="$LDFLAGS -L$GSSAPI_ROOT/lib$libsuff" + LDFLAGSPC="$LDFLAGSPC -L$GSSAPI_ROOT/lib$libsuff" + LIBS="-l$gss_libname $LIBS" + else + LIBS="-l$gss_libname $LIBS" + fi + fi + fi + gss_version="" + if test -n "$host_alias" && test -f "$GSSAPI_ROOT/bin/$host_alias-krb5-config"; then + gss_version=`$GSSAPI_ROOT/bin/$host_alias-krb5-config --version | $SED 's/Kerberos 5 release //'` + elif test "$PKGCONFIG" != "no"; then + gss_version=`$PKGCONFIG --modversion mit-krb5-gssapi` + elif test -f "$KRB5CONFIG"; then + gss_version=`$KRB5CONFIG --version | $SED 's/Kerberos 5 release //'` + fi + if test -n "$gss_version"; then + AC_MSG_NOTICE([GSS-API MIT Kerberos version detected: $gss_version]) + AC_DEFINE_UNQUOTED([CURL_KRB5_VERSION], ["$gss_version"], [MIT Kerberos version]) + fi + else + LDFLAGS="$LDFLAGS $GSSAPI_LIB_DIR" + LDFLAGSPC="$LDFLAGSPC $GSSAPI_LIB_DIR" + case $host in + *-hp-hpux*) + LIBS="-lgss $LIBS" + ;; + *) + LIBS="-lgssapi $LIBS" + ;; + esac + fi + if test -n "$link_pkgconfig"; then + if test -n "$gnu_gss"; then + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE gss" + else + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE mit-krb5-gssapi" + fi + fi +else + CPPFLAGS="$save_CPPFLAGS" +fi + +if test "$want_gss" = "yes"; then + AC_MSG_CHECKING([if we can link against GSS-API library]) + AC_LINK_IFELSE([ + AC_LANG_FUNC_LINK_TRY([gss_init_sec_context]) + ],[ + AC_MSG_RESULT([yes]) + ],[ + AC_MSG_RESULT([no]) + AC_MSG_ERROR([--with-gssapi was specified, but a GSS-API library was not found.]) + ]) +fi + +build_libstubgss=no +if test "$want_gss" = "yes"; then + build_libstubgss=yes +fi + +AM_CONDITIONAL(BUILD_STUB_GSS, test "$build_libstubgss" = "yes") + +dnl ------------------------------------------------------------- +dnl parse --with-default-ssl-backend so it can be validated below +dnl ------------------------------------------------------------- + +DEFAULT_SSL_BACKEND=no +VALID_DEFAULT_SSL_BACKEND= +AC_ARG_WITH(default-ssl-backend, +AS_HELP_STRING([--with-default-ssl-backend=NAME],[Use NAME as default SSL backend]) +AS_HELP_STRING([--without-default-ssl-backend],[Use implicit default SSL backend]), + [DEFAULT_SSL_BACKEND=$withval]) +case "$DEFAULT_SSL_BACKEND" in + no) + dnl --without-default-ssl-backend option used + ;; + default|yes) + dnl --with-default-ssl-backend option used without name + AC_MSG_ERROR([The name of the default SSL backend is required.]) + ;; + *) + dnl --with-default-ssl-backend option used with name + dnl needs to be validated below + VALID_DEFAULT_SSL_BACKEND=no + ;; +esac + +CURL_WITH_SCHANNEL +CURL_WITH_AMISSL +CURL_WITH_OPENSSL +CURL_WITH_GNUTLS +CURL_WITH_MBEDTLS +CURL_WITH_WOLFSSL +CURL_WITH_RUSTLS +CURL_WITH_APPLE_SECTRUST + +dnl link required libraries for USE_WIN32_CRYPTO or SCHANNEL_ENABLED +if test "$USE_WIN32_CRYPTO" = "1" || test "$SCHANNEL_ENABLED" = "1"; then + LIBS="-ladvapi32 -lcrypt32 $LIBS" +fi + +if test "$curl_cv_native_windows" = "yes"; then + dnl for BCryptGenRandom() + LIBS="-lbcrypt $LIBS" +fi + +case "x$SSL_DISABLED$OPENSSL_ENABLED$GNUTLS_ENABLED$MBEDTLS_ENABLED$WOLFSSL_ENABLED$SCHANNEL_ENABLED$RUSTLS_ENABLED" in + x) + AC_MSG_ERROR([TLS not detected, you will not be able to use HTTPS, FTPS, NTLM and more. +Use --with-openssl, --with-gnutls, --with-wolfssl, --with-mbedtls, --with-schannel, --with-amissl or --with-rustls to address this.]) + ;; + x1) + dnl one SSL backend is enabled + SSL_ENABLED="1" + AC_MSG_NOTICE([built with one SSL backend]) + ;; + xD) + dnl explicitly built without TLS + ;; + xD*) + AC_MSG_ERROR([--without-ssl has been set together with an explicit option to use an SSL library +(e.g. --with-openssl, --with-gnutls, --with-wolfssl, --with-mbedtls, --with-schannel, --with-amissl, --with-rustls). +Since these are conflicting parameters, verify which is the desired one and drop the other.]) + ;; + *) + dnl more than one SSL backend is enabled + SSL_ENABLED="1" + CURL_WITH_MULTI_SSL="1" + AC_DEFINE(CURL_WITH_MULTI_SSL, 1, [built with multiple SSL backends]) + AC_MSG_NOTICE([built with multiple SSL backends]) + ;; +esac + +if test -n "$ssl_backends"; then + curl_ssl_msg="enabled ($ssl_backends)" +fi + +if test "$VALID_DEFAULT_SSL_BACKEND" = "no"; then + if test -n "$SSL_ENABLED"; then + AC_MSG_ERROR([Default SSL backend $DEFAULT_SSL_BACKEND not enabled!]) + else + AC_MSG_ERROR([Default SSL backend requires SSL!]) + fi +elif test "$VALID_DEFAULT_SSL_BACKEND" = "yes"; then + AC_DEFINE_UNQUOTED([CURL_DEFAULT_SSL_BACKEND], ["$DEFAULT_SSL_BACKEND"], [Default SSL backend]) +fi + +dnl --------------------- +dnl check native CA store +dnl --------------------- + +ca_native_opt=0 +AC_MSG_CHECKING([whether to use native CA store]) +AC_ARG_ENABLE(ca-native, +AS_HELP_STRING([--enable-ca-native],[Enable native CA store]) +AS_HELP_STRING([--disable-ca-native],[Disable native CA store (default)]), +[ case "$enableval" in + yes) + AC_MSG_RESULT([yes]) + AC_DEFINE(CURL_CA_NATIVE, 1, [If native CA store is enabled]) + ca_native_opt=1 + ;; + *) + AC_MSG_RESULT([no]) + ;; + esac ], + AC_MSG_RESULT([no]) +) + +dnl ********************************************************************** +dnl Check for the CA bundle +dnl ********************************************************************** + +if test -n "$check_for_ca_bundle"; then + CURL_CHECK_CA_BUNDLE + CURL_CHECK_CA_EMBED +fi + +AM_CONDITIONAL(CURL_CA_EMBED_SET, test -n "$CURL_CA_EMBED") + +dnl ---------------------- +dnl check unsafe CA search +dnl ---------------------- + +if test "$curl_cv_native_windows" = "yes"; then + ca_search=1 + AC_MSG_CHECKING([whether to enable unsafe CA bundle search in PATH on Windows]) + AC_ARG_ENABLE(ca-search, +AS_HELP_STRING([--enable-ca-search],[Enable unsafe CA bundle search in PATH on Windows]) +AS_HELP_STRING([--disable-ca-search],[Disable unsafe CA bundle search in PATH on Windows]), + [ case "$enableval" in + no) + AC_MSG_RESULT([no]) + ca_search=0 + ;; + yes) + AC_MSG_RESULT([yes]) + ;; + *) + if test "$ca_native_opt" = "1"; then + AC_MSG_RESULT([no]) + ca_search=0 + else + AC_MSG_RESULT([yes]) + fi + ;; + esac ], + if test "$ca_native_opt" = "1"; then + AC_MSG_RESULT([no]) + ca_search=0 + else + AC_MSG_RESULT([yes]) + fi + ) + if test "$ca_search" = "0"; then + AC_DEFINE(CURL_DISABLE_CA_SEARCH, 1, [If unsafe CA bundle search in PATH on Windows is disabled]) + fi +fi + +dnl -------------------- +dnl check safe CA search +dnl -------------------- + +if test "$curl_cv_native_windows" = "yes"; then + AC_MSG_CHECKING([whether to enable safe CA bundle search (within the curl tool directory) on Windows]) + AC_ARG_ENABLE(ca-search-safe, +AS_HELP_STRING([--enable-ca-search-safe],[Enable safe CA bundle search]) +AS_HELP_STRING([--disable-ca-search-safe],[Disable safe CA bundle search (default)]), + [ case "$enableval" in + yes) + AC_MSG_RESULT([yes]) + AC_DEFINE(CURL_CA_SEARCH_SAFE, 1, [If safe CA bundle search is enabled]) + ;; + *) + AC_MSG_RESULT([no]) + ;; + esac ], + AC_MSG_RESULT([no]) + ) +fi + +dnl ********************************************************************** +dnl Check for libpsl +dnl ********************************************************************** + +dnl Default to compiler & linker defaults for LIBPSL files & libraries. +OPT_LIBPSL=off +AC_ARG_WITH(libpsl, +AS_HELP_STRING([--with-libpsl=PATH],[Where to look for libpsl, PATH points to the LIBPSL installation; + when possible, set the PKG_CONFIG_PATH environment variable instead of using this option]) +AS_HELP_STRING([--without-libpsl], [disable LIBPSL]), + OPT_LIBPSL=$withval) + +if test "x$OPT_LIBPSL" != "xno"; then + dnl backup the pre-libpsl variables + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + case "$OPT_LIBPSL" in + yes|off) + dnl --with-libpsl (without path) used + CURL_CHECK_PKGCONFIG(libpsl) + + if test "$PKGCONFIG" != "no"; then + LIB_PSL=`$PKGCONFIG --libs-only-l libpsl` + LD_PSL=`$PKGCONFIG --libs-only-L libpsl` + CPP_PSL=`$PKGCONFIG --cflags-only-I libpsl` + else + dnl no libpsl pkg-config found + LIB_PSL="-lpsl" + fi + + ;; + *) + dnl use the given --with-libpsl spot + LIB_PSL="-lpsl" + PREFIX_PSL=$OPT_LIBPSL + ;; + esac + + dnl if given with a prefix, we set -L and -I based on that + if test -n "$PREFIX_PSL"; then + LD_PSL=-L${PREFIX_PSL}/lib$libsuff + CPP_PSL=-I${PREFIX_PSL}/include + fi + + LDFLAGS="$LDFLAGS $LD_PSL" + LDFLAGSPC="$LDFLAGSPC $LD_PSL" + CPPFLAGS="$CPPFLAGS $CPP_PSL" + LIBS="$LIB_PSL $LIBS" + + AC_CHECK_LIB(psl, psl_builtin, + [ + AC_CHECK_HEADERS(libpsl.h, + curl_psl_msg="enabled" + AC_DEFINE(USE_LIBPSL, 1, [if libpsl is in use]) + USE_LIBPSL=1 + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libpsl" + ) + ], + dnl not found, revert back to clean variables + LDFLAGS=$CLEANLDFLAGS + LDFLAGSPC=$CLEANLDFLAGSPC + CPPFLAGS=$CLEANCPPFLAGS + LIBS=$CLEANLIBS + ) + + if test "$USE_LIBPSL" != "1"; then + AC_MSG_ERROR([libpsl libs and/or directories were not found where specified!]) + fi +fi +AM_CONDITIONAL([USE_LIBPSL], [test "$curl_psl_msg" = "enabled"]) + +dnl ********************************************************************** +dnl Check for libgsasl +dnl ********************************************************************** + +OPT_LIBGSASL=no +AC_ARG_WITH(libgsasl, +AS_HELP_STRING([--with-libgsasl=PATH],[Where to look for libgsasl, PATH points to the libgsasl installation; + when possible, set the PKG_CONFIG_PATH environment variable instead of using this option]) +AS_HELP_STRING([--without-libgsasl], [disable libgsasl support for SCRAM]), + OPT_LIBGSASL=$withval) + +if test "x$OPT_LIBGSASL" != "xno"; then + dnl backup the pre-libgsasl variables + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + case "$OPT_LIBGSASL" in + yes) + dnl --with-libgsasl (without path) used + CURL_CHECK_PKGCONFIG(libgsasl) + + if test "$PKGCONFIG" != "no"; then + LIB_GSASL=`$PKGCONFIG --libs-only-l libgsasl` + LD_GSASL=`$PKGCONFIG --libs-only-L libgsasl` + CPP_GSASL=`$PKGCONFIG --cflags-only-I libgsasl` + else + dnl no libgsasl pkg-config found + LIB_GSASL="-lgsasl" + fi + ;; + *) + dnl use the given --with-libgsasl spot + PREFIX_GSASL=$OPT_LIBGSASL + ;; + esac + + dnl if given with a prefix, we set -L and -I based on that + if test -n "$PREFIX_GSASL"; then + LIB_GSASL="-lgsasl" + LD_GSASL=-L${PREFIX_GSASL}/lib$libsuff + CPP_GSASL=-I${PREFIX_GSASL}/include + fi + + LDFLAGS="$LDFLAGS $LD_GSASL" + LDFLAGSPC="$LDFLAGSPC $LD_GSASL" + CPPFLAGS="$CPPFLAGS $CPP_GSASL" + LIBS="$LIB_GSASL $LIBS" + + AC_CHECK_LIB(gsasl, gsasl_init, + [ + AC_CHECK_HEADERS(gsasl.h, + curl_gsasl_msg="enabled" + AC_DEFINE(USE_GSASL, 1, [GSASL support enabled]) + USE_LIBGSASL=1 + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libgsasl" + ) + ], + dnl not found, revert back to clean variables + LDFLAGS=$CLEANLDFLAGS + LDFLAGSPC=$CLEANLDFLAGSPC + CPPFLAGS=$CLEANCPPFLAGS + LIBS=$CLEANLIBS + curl_gsasl_msg="no (libgsasl not found)" + AC_MSG_WARN([libgsasl was not found]) + ) +fi +AM_CONDITIONAL([USE_GSASL], [test "$curl_gsasl_msg" = "enabled"]) + +AC_ARG_WITH(libmetalink,, + AC_MSG_ERROR([--with-libmetalink and --without-libmetalink no longer work!])) + +dnl ********************************************************************** +dnl Check for the presence of libssh2 libraries and headers +dnl ********************************************************************** + +dnl Default to compiler & linker defaults for libssh2 files & libraries. +OPT_LIBSSH2=off +AC_ARG_WITH(libssh2, +AS_HELP_STRING([--with-libssh2=PATH],[Where to look for libssh2, PATH points to the libssh2 installation; + when possible, set the PKG_CONFIG_PATH environment variable instead of using this option]) +AS_HELP_STRING([--with-libssh2], [enable libssh2]), + OPT_LIBSSH2=$withval, OPT_LIBSSH2=no) + +OPT_LIBSSH=off +AC_ARG_WITH(libssh, +AS_HELP_STRING([--with-libssh=PATH],[Where to look for libssh, PATH points to the libssh installation; + when possible, set the PKG_CONFIG_PATH environment variable instead of using this option]) +AS_HELP_STRING([--with-libssh], [enable libssh]), + OPT_LIBSSH=$withval, OPT_LIBSSH=no) + +if test "x$OPT_LIBSSH2" != "xno"; then + dnl backup the pre-libssh2 variables + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + case "$OPT_LIBSSH2" in + yes) + dnl --with-libssh2 (without path) used + CURL_CHECK_PKGCONFIG(libssh2) + + if test "$PKGCONFIG" != "no"; then + LIB_SSH2=`$PKGCONFIG --libs-only-l libssh2` + LD_SSH2=`$PKGCONFIG --libs-only-L libssh2` + CPP_SSH2=`$PKGCONFIG --cflags-only-I libssh2` + version=`$PKGCONFIG --modversion libssh2` + DIR_SSH2=`echo $LD_SSH2 | $SED -e 's/^-L//'` + fi + + ;; + off) + dnl no --with-libssh2 option given, check default places + ;; + *) + dnl use the given --with-libssh2 spot + PREFIX_SSH2=$OPT_LIBSSH2 + ;; + esac + + dnl if given with a prefix, we set -L and -I based on that + if test -n "$PREFIX_SSH2"; then + LIB_SSH2="-lssh2" + LD_SSH2=-L${PREFIX_SSH2}/lib$libsuff + CPP_SSH2=-I${PREFIX_SSH2}/include + DIR_SSH2=${PREFIX_SSH2}/lib$libsuff + fi + + LDFLAGS="$LDFLAGS $LD_SSH2" + LDFLAGSPC="$LDFLAGSPC $LD_SSH2" + CPPFLAGS="$CPPFLAGS $CPP_SSH2" + LIBS="$LIB_SSH2 $LIBS" + + dnl check for function added in libssh2 v1.9.0 + AC_CHECK_LIB(ssh2, libssh2_agent_get_identity_path) + + AC_CHECK_HEADER(libssh2.h, + curl_ssh_msg="enabled (libssh2)" + AC_DEFINE(USE_LIBSSH2, 1, [if libssh2 is in use]) + USE_LIBSSH2=1 + ) + + if test "x$OPT_LIBSSH2" != "xoff" && + test "$USE_LIBSSH2" != "1"; then + AC_MSG_ERROR([libssh2 libs and/or directories were not found where specified!]) + fi + + if test "$USE_LIBSSH2" = "1"; then + if test -n "$DIR_SSH2"; then + dnl when the libssh2 shared libs were found in a path that the runtime + dnl linker does not search through, we need to add it to CURL_LIBRARY_PATH + dnl to prevent further configure tests to fail due to this + + if test "$cross_compiling" != "yes"; then + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$DIR_SSH2" + export CURL_LIBRARY_PATH + AC_MSG_NOTICE([Added $DIR_SSH2 to CURL_LIBRARY_PATH]) + fi + fi + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libssh2" + else + dnl no libssh2, revert back to clean variables + LDFLAGS=$CLEANLDFLAGS + LDFLAGSPC=$CLEANLDFLAGSPC + CPPFLAGS=$CLEANCPPFLAGS + LIBS=$CLEANLIBS + fi +elif test "x$OPT_LIBSSH" != "xno"; then + dnl backup the pre-libssh variables + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + case "$OPT_LIBSSH" in + yes) + dnl --with-libssh (without path) used + CURL_CHECK_PKGCONFIG(libssh) + + if test "$PKGCONFIG" != "no"; then + LIB_SSH=`$PKGCONFIG --libs-only-l libssh` + LD_SSH=`$PKGCONFIG --libs-only-L libssh` + CPP_SSH=`$PKGCONFIG --cflags-only-I libssh` + version=`$PKGCONFIG --modversion libssh` + DIR_SSH=`echo $LD_SSH | $SED -e 's/^-L//'` + fi + + ;; + off) + dnl no --with-libssh option given, check default places + ;; + *) + dnl use the given --with-libssh spot + PREFIX_SSH=$OPT_LIBSSH + ;; + esac + + dnl if given with a prefix, we set -L and -I based on that + if test -n "$PREFIX_SSH"; then + LIB_SSH="-lssh" + LD_SSH=-L${PREFIX_SSH}/lib$libsuff + CPP_SSH=-I${PREFIX_SSH}/include + DIR_SSH=${PREFIX_SSH}/lib$libsuff + fi + + LDFLAGS="$LDFLAGS $LD_SSH" + LDFLAGSPC="$LDFLAGSPC $LD_SSH" + CPPFLAGS="$CPPFLAGS $CPP_SSH" + LIBS="$LIB_SSH $LIBS" + + AC_CHECK_LIB(ssh, ssh_new) + + AC_CHECK_HEADER(libssh/libssh.h, + curl_ssh_msg="enabled (libssh)" + AC_DEFINE(USE_LIBSSH, 1, [if libssh is in use]) + USE_LIBSSH=1 + ) + + if test "x$OPT_LIBSSH" != "xoff" && + test "$USE_LIBSSH" != "1"; then + AC_MSG_ERROR([libssh libs and/or directories were not found where specified!]) + fi + + if test "$USE_LIBSSH" = "1"; then + if test "$curl_cv_native_windows" = "yes"; then + dnl for if_nametoindex + LIBS="-liphlpapi $LIBS" + fi + if test -n "$DIR_SSH"; then + dnl when the libssh shared libs were found in a path that the runtime + dnl linker does not search through, we need to add it to CURL_LIBRARY_PATH + dnl to prevent further configure tests to fail due to this + + if test "$cross_compiling" != "yes"; then + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$DIR_SSH" + export CURL_LIBRARY_PATH + AC_MSG_NOTICE([Added $DIR_SSH to CURL_LIBRARY_PATH]) + fi + fi + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libssh" + else + dnl no libssh, revert back to clean variables + LDFLAGS=$CLEANLDFLAGS + LDFLAGSPC=$CLEANLDFLAGSPC + CPPFLAGS=$CLEANCPPFLAGS + LIBS=$CLEANLIBS + fi +fi + +dnl ********************************************************************** +dnl Check for LDAP (after the SSL libraries) +dnl ********************************************************************** + +LDAPLIBNAME="" +AC_ARG_WITH(ldap-lib, +AS_HELP_STRING([--with-ldap-lib=libname],[Specify name of ldap lib file]), + [LDAPLIBNAME="$withval"]) + +LBERLIBNAME="" +AC_ARG_WITH(lber-lib, +AS_HELP_STRING([--with-lber-lib=libname],[Specify name of lber lib file]), + [LBERLIBNAME="$withval"]) + +dnl Handle argument to --with-ldap. +clean_LDAP_CPPFLAGS=$CPPFLAGS +clean_LDAP_LDFLAGS=$LDFLAGS +clean_LDAP_LIBS=$LIBS +OPT_LDAP=off +AC_ARG_WITH(ldap, +AS_HELP_STRING([--with-ldap=PATH],[Where to look for LDAP, PATH points to the LDAP installation; + when possible, set the PKG_CONFIG_PATH environment variable instead of using this option]) +AS_HELP_STRING([--without-ldap], [disable LDAP]), + OPT_LDAP=$withval) + +case "$OPT_LDAP" in + no) + dnl --without-ldap option used + want_ldap="no" + ;; + yes) + dnl --with-ldap option used without path + want_ldap="yes" + ;; + off) + dnl no --with-ldap option given, do not change anything + want_ldap="default" + ;; + *) + dnl --with-ldap option used with path + want_ldap="yes" + if test -d "$OPT_LDAP/lib$libsuff"; then + LDFLAGS="$LDFLAGS -L$OPT_LDAP/lib$libsuff" + DIR_LDAP="$OPT_LDAP/lib$libsuff" + elif test -d "$OPT_LDAP/lib"; then + LDFLAGS="$LDFLAGS -L$OPT_LDAP/lib" + DIR_LDAP="$OPT_LDAP/lib" + fi + if test -d "$OPT_LDAP/include"; then + CPPFLAGS="$CPPFLAGS -I$OPT_LDAP/include" + fi + ldap_askedfor="yes" + ;; +esac + +if test "$CURL_DISABLE_LDAP" != "1" && test "$want_ldap" != "no"; then + + CURL_CHECK_HEADER_LBER + CURL_CHECK_HEADER_LDAP + CURL_CHECK_HEADER_LDAP_SSL + + if test -z "$LDAPLIBNAME"; then + if test "$curl_cv_native_windows" = "yes" && test "$curl_cv_winuwp" != "yes"; then + dnl Windows uses a single and unique LDAP library name + LDAPLIBNAME="wldap32" + LBERLIBNAME="no" + fi + fi + + if test "$LDAPLIBNAME"; then + dnl If we have both LDAP and LBER library names, check if we need both + if test "$LBERLIBNAME" && test "$LBERLIBNAME" != "no"; then + dnl Try LDAP first, then with LBER if needed + AC_CHECK_LIB("$LDAPLIBNAME", ldap_init, [ldap_lib_ok=yes], [ldap_lib_ok=no]) + if test "$ldap_lib_ok" = "no"; then + dnl LDAP alone failed, try with LBER using a different function + AC_CHECK_LIB("$LDAPLIBNAME", ldap_unbind, [ldap_lib_ok=yes], [ldap_lib_ok=no], [-l$LBERLIBNAME]) + if test "$ldap_lib_ok" = "yes"; then + dnl We need both libraries + LIBS="-l$LDAPLIBNAME -l$LBERLIBNAME $LIBS" + fi + else + dnl LDAP alone is sufficient + LIBS="-l$LDAPLIBNAME $LIBS" + fi + else + dnl Only check LDAP library + AC_CHECK_LIB("$LDAPLIBNAME", ldap_init, [ldap_lib_ok=yes; LIBS="-l$LDAPLIBNAME $LIBS"], [ldap_lib_ok=no]) + fi + + if test "$ldap_lib_ok" = "no"; then + if test -n "$ldap_askedfor"; then + AC_MSG_ERROR([could not detect the LDAP libraries]) + fi + AC_MSG_WARN(["$LDAPLIBNAME" is not an LDAP library: LDAP disabled]) + AC_DEFINE(CURL_DISABLE_LDAP, 1, [to disable LDAP]) + CURL_DISABLE_LDAP=1 + AC_DEFINE(CURL_DISABLE_LDAPS, 1, [to disable LDAPS]) + CURL_DISABLE_LDAPS=1 + dnl restore original flags + CPPFLAGS=$clean_LDAP_CPPFLAGS + LDFLAGS=$clean_LDAP_LDFLAGS + LIBS=$clean_LDAP_LIBS + fi + else + dnl Try to find the right ldap libraries for this system + CURL_CHECK_LIBS_LDAP + case X-"$curl_cv_ldap_LIBS" in + X-unknown) + if test -n "$ldap_askedfor"; then + AC_MSG_ERROR([could not detect the LDAP libraries]) + fi + AC_MSG_WARN([Cannot find libraries for LDAP support: LDAP disabled]) + AC_DEFINE(CURL_DISABLE_LDAP, 1, [to disable LDAP]) + CURL_DISABLE_LDAP=1 + AC_DEFINE(CURL_DISABLE_LDAPS, 1, [to disable LDAPS]) + CURL_DISABLE_LDAPS=1 + dnl restore original flags + CPPFLAGS=$clean_LDAP_CPPFLAGS + LDFLAGS=$clean_LDAP_LDFLAGS + LIBS=$clean_LDAP_LIBS + ;; + esac + fi +fi + +if test "$CURL_DISABLE_LDAP" != "1"; then + dnl Add to library path if needed + if test -n "$DIR_LDAP"; then + dnl when the ldap shared lib were found in a path that the runtime + dnl linker does not search through, we need to add it to + dnl CURL_LIBRARY_PATH to prevent further configure tests to fail due to + dnl this + + if test "$cross_compiling" != "yes"; then + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$DIR_LDAP" + export CURL_LIBRARY_PATH + AC_MSG_NOTICE([Added $DIR_LDAP to CURL_LIBRARY_PATH]) + fi + fi + + if test "$LBERLIBNAME"; then + dnl If name is "no" then do not define this library at all + dnl (it is only needed if libldap.so's dependencies are broken). + dnl Skip this check if we already determined we need both libraries above + if test "$LBERLIBNAME" != "no" && test "$ldap_lib_ok" != "yes"; then + AC_CHECK_LIB("$LBERLIBNAME", ber_free,, [ + AC_MSG_WARN(["$LBERLIBNAME" is not an LBER library: LDAP disabled]) + AC_DEFINE(CURL_DISABLE_LDAP, 1, [to disable LDAP]) + CURL_DISABLE_LDAP=1 + AC_DEFINE(CURL_DISABLE_LDAPS, 1, [to disable LDAPS]) + CURL_DISABLE_LDAPS=1 + dnl restore original flags + CPPFLAGS=$clean_LDAP_CPPFLAGS + LDFLAGS=$clean_LDAP_LDFLAGS + LIBS=$clean_LDAP_LIBS + ] + ) + fi + fi +fi + +if test "$CURL_DISABLE_LDAP" != "1"; then + AC_CHECK_FUNCS([ldap_url_parse \ + ldap_init_fd]) + + if test "$LDAPLIBNAME" = "wldap32"; then + curl_ldap_msg="enabled (winldap)" + AC_DEFINE(USE_WIN32_LDAP, 1, [Use Windows LDAP implementation]) + else + if test "$ac_cv_func_ldap_init_fd" = "yes"; then + curl_ldap_msg="enabled (OpenLDAP)" + AC_DEFINE(USE_OPENLDAP, 1, [Use OpenLDAP-specific code]) + USE_OPENLDAP=1 + else + curl_ldap_msg="enabled (ancient OpenLDAP)" + fi + fi +fi + +if test "$CURL_DISABLE_LDAPS" != "1"; then + curl_ldaps_msg="enabled" +fi + +dnl ********************************************************************** +dnl Check for linker switch for versioned symbols +dnl ********************************************************************** + +versioned_symbols_flavor= +AC_MSG_CHECKING([whether versioned symbols are wanted]) +AC_ARG_ENABLE(versioned-symbols, +AS_HELP_STRING([--enable-versioned-symbols], [Enable versioned symbols in shared library]) +AS_HELP_STRING([--disable-versioned-symbols], [Disable versioned symbols in shared library]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + ;; + *) + AC_MSG_RESULT(yes) + AC_MSG_CHECKING([if libraries can be versioned]) + GLD=`$LD --help < /dev/null 2>/dev/null | grep version-script` + if test -z "$GLD"; then + AC_MSG_RESULT(no) + AC_MSG_WARN([You need an ld version supporting the --version-script option]) + else + AC_MSG_RESULT(yes) + if test "x$enableval" != "xyes"; then + versioned_symbols_flavor="$enableval" + elif test "$CURL_WITH_MULTI_SSL" = "1"; then + versioned_symbols_flavor="MULTISSL_" + elif test "$OPENSSL_ENABLED" = "1"; then + versioned_symbols_flavor="OPENSSL_" + elif test "$MBEDTLS_ENABLED" = "1"; then + versioned_symbols_flavor="MBEDTLS_" + elif test "$WOLFSSL_ENABLED" = "1"; then + versioned_symbols_flavor="WOLFSSL_" + elif test "$GNUTLS_ENABLED" = "1"; then + versioned_symbols_flavor="GNUTLS_" + elif test "$RUSTLS_ENABLED" = "1"; then + versioned_symbols_flavor="RUSTLS_" + else + versioned_symbols_flavor="" + fi + versioned_symbols="yes" + fi + ;; + + esac +], [ + AC_MSG_RESULT(no) +] +) + +AC_SUBST([CURL_LIBCURL_VERSIONED_SYMBOLS_PREFIX], ["$versioned_symbols_flavor"]) +AC_SUBST([CURL_LIBCURL_VERSIONED_SYMBOLS_SONAME], ["4"]) dnl Keep in sync with VERSIONCHANGE - VERSIONDEL in lib/Makefile.soname +AM_CONDITIONAL([CURL_LT_SHLIB_USE_VERSIONED_SYMBOLS], + [test "$versioned_symbols" = "yes"]) + +dnl ---------------------------- +dnl check Windows Unicode option +dnl ---------------------------- + +want_winuni="no" +if test "$curl_cv_native_windows" = "yes"; then + if test "$curl_cv_winuwp" = "yes"; then + want_winuni="yes" + else + AC_MSG_CHECKING([whether to enable Windows Unicode (Windows native builds only)]) + AC_ARG_ENABLE(windows-unicode, +AS_HELP_STRING([--enable-windows-unicode],[Enable Windows Unicode]) +AS_HELP_STRING([--disable-windows-unicode],[Disable Windows Unicode (default)]), + [ case "$enableval" in + yes) + want_winuni="yes" + AC_MSG_RESULT([yes]) + ;; + *) + AC_MSG_RESULT([no]) + ;; + esac ], + AC_MSG_RESULT([no]) + ) + fi + + if test "$want_winuni" = "yes"; then + CPPFLAGS="${CPPFLAGS} -DUNICODE -D_UNICODE" + fi +fi + +AM_CONDITIONAL([USE_UNICODE], [test "$want_winuni" = "yes"]) + +dnl ------------------------------------------------- +dnl check WinIDN option before other IDN libraries +dnl ------------------------------------------------- + +tst_links_winidn='no' +if test "$curl_cv_native_windows" = "yes"; then + AC_MSG_CHECKING([whether to enable Windows native IDN (Windows native builds only)]) + OPT_WINIDN="default" + AC_ARG_WITH(winidn, +AS_HELP_STRING([--with-winidn],[enable Windows native IDN]) +AS_HELP_STRING([--without-winidn], [disable Windows native IDN]), + OPT_WINIDN=$withval) + case "$OPT_WINIDN" in + no|default) + dnl --without-winidn option used or configure option not specified + want_winidn="no" + AC_MSG_RESULT([no]) + ;; + *) + dnl --with-winidn option + want_winidn="yes" + AC_MSG_RESULT([yes]) + ;; + esac + + if test "$want_winidn" = "yes"; then + LIBS="-lnormaliz $LIBS" + AC_DEFINE(USE_WIN32_IDN, 1, [Define to 1 if you have the `normaliz' (WinIDN) library (-lnormaliz).]) + IDN_ENABLED=1 + curl_idn_msg="enabled (Windows-native)" + fi +fi + +dnl ********************************************************************** +dnl Check for the presence of AppleIDN +dnl ********************************************************************** + +tst_links_appleidn='no' +if test "$curl_cv_apple" = "yes"; then + AC_MSG_CHECKING([whether to build with Apple IDN]) + OPT_IDN="default" + AC_ARG_WITH(apple-idn, +AS_HELP_STRING([--with-apple-idn],[Enable AppleIDN]) +AS_HELP_STRING([--without-apple-idn],[Disable AppleIDN]), + [OPT_IDN=$withval]) + case "$OPT_IDN" in + yes) + dnl --with-apple-idn option used + AC_MSG_RESULT([yes, check]) + AC_CHECK_LIB(icucore, uidna_openUTS46, + [ + AC_CHECK_HEADERS(unicode/uidna.h, + curl_idn_msg="enabled (AppleIDN)" + AC_DEFINE(USE_APPLE_IDN, 1, [if AppleIDN]) + USE_APPLE_IDN=1 + IDN_ENABLED=1 + LIBS="-licucore -liconv $LIBS" + tst_links_appleidn='yes' + ) + ]) + ;; + *) + AC_MSG_RESULT([no]) + ;; + esac +fi + +dnl ********************************************************************** +dnl Check for the presence of libidn2 +dnl ********************************************************************** + +AC_MSG_CHECKING([whether to build with libidn2]) +OPT_IDN="default" +AC_ARG_WITH(libidn2, +AS_HELP_STRING([--with-libidn2=PATH],[Enable libidn2 usage]) +AS_HELP_STRING([--without-libidn2],[Disable libidn2 usage]), + [OPT_IDN=$withval]) +if test "$tst_links_winidn" = "yes"; then + want_idn="no" + AC_MSG_RESULT([no (using WinIDN instead)]) +elif test "$tst_links_appleidn" = "yes"; then + want_idn="no" + AC_MSG_RESULT([no (using AppleIDN instead)]) +else + case "$OPT_IDN" in + no) + dnl --without-libidn2 option used + want_idn="no" + AC_MSG_RESULT([no]) + ;; + default) + dnl configure option not specified + want_idn="yes" + want_idn_path="default" + AC_MSG_RESULT([(assumed) yes]) + ;; + yes) + dnl --with-libidn2 option used without path + want_idn="yes" + want_idn_path="default" + AC_MSG_RESULT([yes]) + ;; + *) + dnl --with-libidn2 option used with path + want_idn="yes" + want_idn_path="$withval" + AC_MSG_RESULT([yes ($withval)]) + ;; + esac +fi + +if test "$want_idn" = "yes"; then + dnl idn library support has been requested + clean_CPPFLAGS="$CPPFLAGS" + clean_LDFLAGS="$LDFLAGS" + clean_LDFLAGSPC="$LDFLAGSPC" + clean_LIBS="$LIBS" + PKGCONFIG="no" + + if test "$want_idn_path" != "default"; then + dnl path has been specified + IDN_PCDIR="$want_idn_path/lib$libsuff/pkgconfig" + CURL_CHECK_PKGCONFIG(libidn2, [$IDN_PCDIR]) + if test "$PKGCONFIG" != "no"; then + IDN_LIBS=`CURL_EXPORT_PCDIR([$IDN_PCDIR]) + $PKGCONFIG --libs-only-l libidn2 2>/dev/null` + IDN_LDFLAGS=`CURL_EXPORT_PCDIR([$IDN_PCDIR]) + $PKGCONFIG --libs-only-L libidn2 2>/dev/null` + IDN_CPPFLAGS=`CURL_EXPORT_PCDIR([$IDN_PCDIR]) + $PKGCONFIG --cflags-only-I libidn2 2>/dev/null` + IDN_DIR=`echo $IDN_LDFLAGS | $SED -e 's/^-L//'` + else + dnl pkg-config not available or provides no info + IDN_LIBS="-lidn2" + IDN_LDFLAGS="-L$want_idn_path/lib$libsuff" + IDN_CPPFLAGS="-I$want_idn_path/include" + IDN_DIR="$want_idn_path/lib$libsuff" + fi + else + dnl path not specified + CURL_CHECK_PKGCONFIG(libidn2) + if test "$PKGCONFIG" != "no"; then + IDN_LIBS=`$PKGCONFIG --libs-only-l libidn2 2>/dev/null` + IDN_LDFLAGS=`$PKGCONFIG --libs-only-L libidn2 2>/dev/null` + IDN_CPPFLAGS=`$PKGCONFIG --cflags-only-I libidn2 2>/dev/null` + IDN_DIR=`echo $IDN_LDFLAGS | $SED -e 's/^-L//'` + else + dnl pkg-config not available or provides no info + IDN_LIBS="-lidn2" + fi + fi + + if test "$PKGCONFIG" != "no"; then + AC_MSG_NOTICE([pkg-config: IDN_LIBS: "$IDN_LIBS"]) + AC_MSG_NOTICE([pkg-config: IDN_LDFLAGS: "$IDN_LDFLAGS"]) + AC_MSG_NOTICE([pkg-config: IDN_CPPFLAGS: "$IDN_CPPFLAGS"]) + AC_MSG_NOTICE([pkg-config: IDN_DIR: "$IDN_DIR"]) + else + AC_MSG_NOTICE([IDN_LIBS: "$IDN_LIBS"]) + AC_MSG_NOTICE([IDN_LDFLAGS: "$IDN_LDFLAGS"]) + AC_MSG_NOTICE([IDN_CPPFLAGS: "$IDN_CPPFLAGS"]) + AC_MSG_NOTICE([IDN_DIR: "$IDN_DIR"]) + fi + + CPPFLAGS="$CPPFLAGS $IDN_CPPFLAGS" + LDFLAGS="$LDFLAGS $IDN_LDFLAGS" + LDFLAGSPC="$LDFLAGSPC $IDN_LDFLAGS" + LIBS="$IDN_LIBS $LIBS" + + AC_MSG_CHECKING([if idn2_lookup_ul can be linked]) + AC_LINK_IFELSE([ + AC_LANG_FUNC_LINK_TRY([idn2_lookup_ul]) + ],[ + AC_MSG_RESULT([yes]) + tst_links_libidn="yes" + ],[ + AC_MSG_RESULT([no]) + tst_links_libidn="no" + ]) + + AC_CHECK_HEADERS(idn2.h) + + if test "$tst_links_libidn" = "yes"; then + AC_DEFINE(HAVE_LIBIDN2, 1, [Define to 1 if you have the `idn2' library (-lidn2).]) + dnl different versions of libidn have different setups of these: + + IDN_ENABLED=1 + curl_idn_msg="enabled (libidn2)" + if test -n "$IDN_DIR" && test "$cross_compiling" != "yes"; then + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$IDN_DIR" + export CURL_LIBRARY_PATH + AC_MSG_NOTICE([Added $IDN_DIR to CURL_LIBRARY_PATH]) + fi + LIBCURL_PC_REQUIRES_PRIVATE="libidn2 $LIBCURL_PC_REQUIRES_PRIVATE" + else + AC_MSG_WARN([Cannot find libidn2]) + CPPFLAGS="$clean_CPPFLAGS" + LDFLAGS="$clean_LDFLAGS" + LDFLAGSPC="$clean_LDFLAGSPC" + LIBS="$clean_LIBS" + want_idn="no" + fi +fi + +dnl ********************************************************************** +dnl Check for nghttp2 +dnl ********************************************************************** + +OPT_H2="yes" + +if test "$disable_http" = "yes"; then + dnl without HTTP nghttp2 is no use + OPT_H2="no" +fi + +AC_ARG_WITH(nghttp2, +AS_HELP_STRING([--with-nghttp2=PATH],[Enable nghttp2 usage]) +AS_HELP_STRING([--without-nghttp2],[Disable nghttp2 usage]), + [OPT_H2=$withval]) +case "$OPT_H2" in + no) + dnl --without-nghttp2 option used + want_nghttp2="no" + ;; + yes) + dnl --with-nghttp2 option used without path + want_nghttp2="default" + want_nghttp2_path="" + want_nghttp2_pkg_config_path="" + ;; + *) + dnl --with-nghttp2 option used with path + want_nghttp2="yes" + want_nghttp2_path="$withval" + want_nghttp2_pkg_config_path="$OPT_H2/lib/pkgconfig" + ;; +esac + +if test "$want_nghttp2" != "no"; then + dnl backup the pre-nghttp2 variables + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + CURL_CHECK_PKGCONFIG(libnghttp2, $want_nghttp2_pkg_config_path) + + if test "$PKGCONFIG" != "no"; then + LIB_H2=`CURL_EXPORT_PCDIR([$want_nghttp2_pkg_config_path]) + $PKGCONFIG --libs-only-l libnghttp2` + AC_MSG_NOTICE([-l is $LIB_H2]) + + CPP_H2=`CURL_EXPORT_PCDIR([$want_nghttp2_pkg_config_path]) + $PKGCONFIG --cflags-only-I libnghttp2` + AC_MSG_NOTICE([-I is $CPP_H2]) + + LD_H2=`CURL_EXPORT_PCDIR([$want_nghttp2_pkg_config_path]) + $PKGCONFIG --libs-only-L libnghttp2` + AC_MSG_NOTICE([-L is $LD_H2]) + + DIR_H2=`echo $LD_H2 | $SED -e 's/^-L//'` + elif test -n "$want_nghttp2_path"; then + LIB_H2="-lnghttp2" + LD_H2=-L${want_nghttp2_path}/lib$libsuff + CPP_H2=-I${want_nghttp2_path}/include + DIR_H2=${want_nghttp2_path}/lib$libsuff + elif test "$want_nghttp2" != "default"; then + dnl no nghttp2 pkg-config found and no custom directory specified, + dnl deal with it + AC_MSG_ERROR([--with-nghttp2 was specified but could not find libnghttp2 pkg-config file.]) + else + LIB_H2="-lnghttp2" + fi + + LDFLAGS="$LDFLAGS $LD_H2" + LDFLAGSPC="$LDFLAGSPC $LD_H2" + CPPFLAGS="$CPPFLAGS $CPP_H2" + LIBS="$LIB_H2 $LIBS" + + dnl use nghttp2_session_get_stream_local_window_size to require nghttp2 + dnl >= 1.15.0 + AC_CHECK_LIB(nghttp2, nghttp2_session_get_stream_local_window_size, + [ + AC_CHECK_HEADERS(nghttp2/nghttp2.h, + curl_h2_msg="enabled (nghttp2)" + AC_DEFINE(USE_NGHTTP2, 1, [if nghttp2 is in use]) + USE_NGHTTP2=1 + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libnghttp2" + ) + + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$DIR_H2" + export CURL_LIBRARY_PATH + AC_MSG_NOTICE([Added $DIR_H2 to CURL_LIBRARY_PATH]) + ], + dnl not found, revert back to clean variables + LDFLAGS=$CLEANLDFLAGS + LDFLAGSPC=$CLEANLDFLAGSPC + CPPFLAGS=$CLEANCPPFLAGS + LIBS=$CLEANLIBS + ) +fi + +dnl ********************************************************************** +dnl Check for ngtcp2 (QUIC) +dnl ********************************************************************** + +OPT_TCP2="no" + +if test "$disable_http" = "yes"; then + dnl without HTTP, ngtcp2 is no use + OPT_TCP2="no" +fi + +AC_ARG_WITH(ngtcp2, +AS_HELP_STRING([--with-ngtcp2=PATH],[Enable ngtcp2 usage]) +AS_HELP_STRING([--without-ngtcp2],[Disable ngtcp2 usage]), + [OPT_TCP2=$withval]) +case "$OPT_TCP2" in + no) + dnl --without-ngtcp2 option used + want_tcp2="no" + ;; + yes) + dnl --with-ngtcp2 option used without path + want_tcp2="default" + want_tcp2_path="" + ;; + *) + dnl --with-ngtcp2 option used with path + want_tcp2="yes" + want_tcp2_path="$OPT_TCP2/lib/pkgconfig" + ;; +esac + +curl_tcp2_msg="no (--with-ngtcp2)" +if test "$want_tcp2" != "no"; then + + if test "$QUIC_ENABLED" != "yes"; then + AC_MSG_ERROR([the detected TLS library does not support QUIC, making --with-ngtcp2 a no-no]) + fi + + dnl backup the pre-ngtcp2 variables + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + CURL_CHECK_PKGCONFIG(libngtcp2, $want_tcp2_path) + + if test "$PKGCONFIG" != "no"; then + LIB_TCP2=`CURL_EXPORT_PCDIR([$want_tcp2_path]) + $PKGCONFIG --libs-only-l libngtcp2` + AC_MSG_NOTICE([-l is $LIB_TCP2]) + + CPP_TCP2=`CURL_EXPORT_PCDIR([$want_tcp2_path]) + $PKGCONFIG --cflags-only-I libngtcp2` + AC_MSG_NOTICE([-I is $CPP_TCP2]) + + LD_TCP2=`CURL_EXPORT_PCDIR([$want_tcp2_path]) + $PKGCONFIG --libs-only-L libngtcp2` + AC_MSG_NOTICE([-L is $LD_TCP2]) + + LDFLAGS="$LDFLAGS $LD_TCP2" + LDFLAGSPC="$LDFLAGSPC $LD_TCP2" + CPPFLAGS="$CPPFLAGS $CPP_TCP2" + LIBS="$LIB_TCP2 $LIBS" + + if test "$cross_compiling" != "yes"; then + DIR_TCP2=`echo $LD_TCP2 | $SED -e 's/^-L//'` + fi + AC_CHECK_LIB(ngtcp2, ngtcp2_conn_client_new_versioned, + [ + AC_CHECK_HEADERS(ngtcp2/ngtcp2.h, + AC_DEFINE(USE_NGTCP2, 1, [if ngtcp2 is in use]) + USE_NGTCP2=1 + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$DIR_TCP2" + export CURL_LIBRARY_PATH + AC_MSG_NOTICE([Added $DIR_TCP2 to CURL_LIBRARY_PATH]) + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libngtcp2" + ) + ], + dnl not found, revert back to clean variables + LDFLAGS=$CLEANLDFLAGS + LDFLAGSPC=$CLEANLDFLAGSPC + CPPFLAGS=$CLEANCPPFLAGS + LIBS=$CLEANLIBS + ) + + else + dnl no ngtcp2 pkg-config found, deal with it + if test "$want_tcp2" != "default"; then + dnl To avoid link errors, we do not allow --with-ngtcp2 without + dnl a pkgconfig file + AC_MSG_ERROR([--with-ngtcp2 was specified but could not find ngtcp2 pkg-config file.]) + fi + fi +fi + +if test "$USE_NGTCP2" = "1" && test "$OPENSSL_ENABLED" = "1" && test "$HAVE_LIBRESSL" = "1"; then + + dnl backup the pre-ngtcp2_crypto_libressl variables + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + CURL_CHECK_PKGCONFIG(libngtcp2_crypto_libressl, $want_tcp2_path, 1) + + if test "$PKGCONFIG" != "no"; then + LIB_NGTCP2_CRYPTO_LIBRESSL=`CURL_EXPORT_PCDIR([$want_tcp2_path], 1) + $PKGCONFIG --libs-only-l libngtcp2_crypto_libressl` + AC_MSG_NOTICE([-l is $LIB_NGTCP2_CRYPTO_LIBRESSL]) + + CPP_NGTCP2_CRYPTO_LIBRESSL=`CURL_EXPORT_PCDIR([$want_tcp2_path], 1) + $PKGCONFIG --cflags-only-I libngtcp2_crypto_libressl` + AC_MSG_NOTICE([-I is $CPP_NGTCP2_CRYPTO_LIBRESSL]) + + LD_NGTCP2_CRYPTO_LIBRESSL=`CURL_EXPORT_PCDIR([$want_tcp2_path], 1) + $PKGCONFIG --libs-only-L libngtcp2_crypto_libressl` + AC_MSG_NOTICE([-L is $LD_NGTCP2_CRYPTO_LIBRESSL]) + + LDFLAGS="$LDFLAGS $LD_NGTCP2_CRYPTO_LIBRESSL" + LDFLAGSPC="$LDFLAGSPC $LD_NGTCP2_CRYPTO_LIBRESSL" + CPPFLAGS="$CPPFLAGS $CPP_NGTCP2_CRYPTO_LIBRESSL" + LIBS="$LIB_NGTCP2_CRYPTO_LIBRESSL $LIBS" + + if test "$cross_compiling" != "yes"; then + DIR_NGTCP2_CRYPTO_LIBRESSL=`echo $LD_NGTCP2_CRYPTO_LIBRESSL | $SED -e 's/^-L//'` + fi + AC_CHECK_LIB(ngtcp2_crypto_libressl, ngtcp2_crypto_recv_client_initial_cb, + [ + AC_CHECK_HEADERS(ngtcp2/ngtcp2_crypto.h, + USE_NGTCP2=1 + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$DIR_NGTCP2_CRYPTO_LIBRESSL" + export CURL_LIBRARY_PATH + AC_MSG_NOTICE([Added $DIR_NGTCP2_CRYPTO_LIBRESSL to CURL_LIBRARY_PATH]) + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libngtcp2_crypto_libressl" + ) + ], + dnl not found, revert back to clean variables + LDFLAGS=$CLEANLDFLAGS + LDFLAGSPC=$CLEANLDFLAGSPC + CPPFLAGS=$CLEANCPPFLAGS + LIBS=$CLEANLIBS + ) + + else + dnl no ngtcp2_crypto_libressl pkg-config found, deal with it + if test "$want_tcp2" != "default"; then + dnl To avoid link errors, we do not allow --with-ngtcp2 without + dnl a pkgconfig file + AC_MSG_WARN([--with-ngtcp2 was specified but could not find ngtcp2_crypto_libressl pkg-config file.]) + dnl Pretend to be quictls to fall back to using ngtcp2_crypto_quictls + fi + HAVE_LIBRESSL=0 + fi +fi + +if test "$USE_NGTCP2" = "1" && test "$OPENSSL_ENABLED" = "1" && test "$HAVE_LIBRESSL" != "1" && + test "$OPENSSL_IS_AWSLC" != "1" && test "$OPENSSL_IS_BORINGSSL" != "1" && test "$OPENSSL_QUIC_API2" != "1"; then + + dnl backup the pre-ngtcp2_crypto_quictls variables + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + CURL_CHECK_PKGCONFIG(libngtcp2_crypto_quictls, $want_tcp2_path, 1) + + if test "$PKGCONFIG" != "no"; then + LIB_NGTCP2_CRYPTO_QUICTLS=`CURL_EXPORT_PCDIR([$want_tcp2_path], 1) + $PKGCONFIG --libs-only-l libngtcp2_crypto_quictls` + AC_MSG_NOTICE([-l is $LIB_NGTCP2_CRYPTO_QUICTLS]) + + CPP_NGTCP2_CRYPTO_QUICTLS=`CURL_EXPORT_PCDIR([$want_tcp2_path], 1) + $PKGCONFIG --cflags-only-I libngtcp2_crypto_quictls` + AC_MSG_NOTICE([-I is $CPP_NGTCP2_CRYPTO_QUICTLS]) + + LD_NGTCP2_CRYPTO_QUICTLS=`CURL_EXPORT_PCDIR([$want_tcp2_path], 1) + $PKGCONFIG --libs-only-L libngtcp2_crypto_quictls` + AC_MSG_NOTICE([-L is $LD_NGTCP2_CRYPTO_QUICTLS]) + + LDFLAGS="$LDFLAGS $LD_NGTCP2_CRYPTO_QUICTLS" + LDFLAGSPC="$LDFLAGSPC $LD_NGTCP2_CRYPTO_QUICTLS" + CPPFLAGS="$CPPFLAGS $CPP_NGTCP2_CRYPTO_QUICTLS" + LIBS="$LIB_NGTCP2_CRYPTO_QUICTLS $LIBS" + + if test "$cross_compiling" != "yes"; then + DIR_NGTCP2_CRYPTO_QUICTLS=`echo $LD_NGTCP2_CRYPTO_QUICTLS | $SED -e 's/^-L//'` + fi + AC_CHECK_LIB(ngtcp2_crypto_quictls, ngtcp2_crypto_recv_client_initial_cb, + [ + AC_CHECK_HEADERS(ngtcp2/ngtcp2_crypto.h, + USE_NGTCP2=1 + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$DIR_NGTCP2_CRYPTO_QUICTLS" + export CURL_LIBRARY_PATH + AC_MSG_NOTICE([Added $DIR_NGTCP2_CRYPTO_QUICTLS to CURL_LIBRARY_PATH]) + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libngtcp2_crypto_quictls" + ) + ], + dnl not found, revert back to clean variables + LDFLAGS=$CLEANLDFLAGS + LDFLAGSPC=$CLEANLDFLAGSPC + CPPFLAGS=$CLEANCPPFLAGS + LIBS=$CLEANLIBS + ) + + else + dnl no ngtcp2_crypto_quictls pkg-config found, deal with it + if test "$want_tcp2" != "default"; then + dnl To avoid link errors, we do not allow --with-ngtcp2 without + dnl a pkgconfig file + AC_MSG_ERROR([--with-ngtcp2 was specified but could not find ngtcp2_crypto_quictls pkg-config file.]) + fi + fi +fi + +if test "$USE_NGTCP2" = "1" && test "$OPENSSL_ENABLED" = "1" && + test "$OPENSSL_IS_AWSLC" != "1" && test "$OPENSSL_IS_BORINGSSL" != "1" && test "$OPENSSL_QUIC_API2" = "1"; then + + dnl backup the pre-ngtcp2_crypto_ossl variables + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + CURL_CHECK_PKGCONFIG(libngtcp2_crypto_ossl, $want_tcp2_path, 1) + + if test "$PKGCONFIG" != "no"; then + LIB_NGTCP2_CRYPTO_OSSL=`CURL_EXPORT_PCDIR([$want_tcp2_path], 1) + $PKGCONFIG --libs-only-l libngtcp2_crypto_ossl` + AC_MSG_NOTICE([-l is $LIB_NGTCP2_CRYPTO_OSSL]) + + CPP_NGTCP2_CRYPTO_OSSL=`CURL_EXPORT_PCDIR([$want_tcp2_path], 1) + $PKGCONFIG --cflags-only-I libngtcp2_crypto_ossl` + AC_MSG_NOTICE([-I is $CPP_NGTCP2_CRYPTO_OSSL]) + + LD_NGTCP2_CRYPTO_OSSL=`CURL_EXPORT_PCDIR([$want_tcp2_path], 1) + $PKGCONFIG --libs-only-L libngtcp2_crypto_ossl` + AC_MSG_NOTICE([-L is $LD_NGTCP2_CRYPTO_OSSL]) + + LDFLAGS="$LDFLAGS $LD_NGTCP2_CRYPTO_OSSL" + LDFLAGSPC="$LDFLAGSPC $LD_NGTCP2_CRYPTO_OSSL" + CPPFLAGS="$CPPFLAGS $CPP_NGTCP2_CRYPTO_OSSL" + LIBS="$LIB_NGTCP2_CRYPTO_OSSL $LIBS" + + if test "$cross_compiling" != "yes"; then + DIR_NGTCP2_CRYPTO_OSSL=`echo $LD_NGTCP2_CRYPTO_OSSL | $SED -e 's/^-L//'` + fi + AC_CHECK_LIB(ngtcp2_crypto_ossl, ngtcp2_crypto_recv_client_initial_cb, + [ + AC_CHECK_HEADERS(ngtcp2/ngtcp2_crypto.h, + USE_NGTCP2=1 + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$DIR_NGTCP2_CRYPTO_OSSL" + export CURL_LIBRARY_PATH + AC_MSG_NOTICE([Added $DIR_NGTCP2_CRYPTO_OSSL to CURL_LIBRARY_PATH]) + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libngtcp2_crypto_ossl" + AC_DEFINE(OPENSSL_QUIC_API2, 1, [openssl with new QUIC API]) + ) + ], + dnl not found, revert back to clean variables + LDFLAGS=$CLEANLDFLAGS + LDFLAGSPC=$CLEANLDFLAGSPC + CPPFLAGS=$CLEANCPPFLAGS + LIBS=$CLEANLIBS + ) + + else + dnl no ngtcp2_crypto_ossl pkg-config found, deal with it + if test "$want_tcp2" != "default"; then + dnl To avoid link errors, we do not allow --with-ngtcp2 without + dnl a pkgconfig file + AC_MSG_ERROR([--with-ngtcp2 was specified but could not find ngtcp2_crypto_ossl pkg-config file.]) + fi + fi +fi + +if test "$USE_NGTCP2" = "1" && test "$OPENSSL_ENABLED" = "1" && + (test "$OPENSSL_IS_AWSLC" = "1" || test "$OPENSSL_IS_BORINGSSL" = "1"); then + + dnl backup the pre-ngtcp2_crypto_boringssl variables + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + CURL_CHECK_PKGCONFIG(libngtcp2_crypto_boringssl, $want_tcp2_path, 1) + + if test "$PKGCONFIG" != "no"; then + LIB_NGTCP2_CRYPTO_BORINGSSL=`CURL_EXPORT_PCDIR([$want_tcp2_path], 1) + $PKGCONFIG --libs-only-l libngtcp2_crypto_boringssl` + AC_MSG_NOTICE([-l is $LIB_NGTCP2_CRYPTO_BORINGSSL]) + + CPP_NGTCP2_CRYPTO_BORINGSSL=`CURL_EXPORT_PCDIR([$want_tcp2_path], 1) + $PKGCONFIG --cflags-only-I libngtcp2_crypto_boringssl` + AC_MSG_NOTICE([-I is $CPP_NGTCP2_CRYPTO_BORINGSSL]) + + LD_NGTCP2_CRYPTO_BORINGSSL=`CURL_EXPORT_PCDIR([$want_tcp2_path], 1) + $PKGCONFIG --libs-only-L libngtcp2_crypto_boringssl` + AC_MSG_NOTICE([-L is $LD_NGTCP2_CRYPTO_BORINGSSL]) + + LDFLAGS="$LDFLAGS $LD_NGTCP2_CRYPTO_BORINGSSL" + LDFLAGSPC="$LDFLAGSPC $LD_NGTCP2_CRYPTO_BORINGSSL" + CPPFLAGS="$CPPFLAGS $CPP_NGTCP2_CRYPTO_BORINGSSL" + LIBS="$LIB_NGTCP2_CRYPTO_BORINGSSL $LIBS" + + if test "$cross_compiling" != "yes"; then + DIR_NGTCP2_CRYPTO_BORINGSSL=`echo $LD_NGTCP2_CRYPTO_BORINGSSL | $SED -e 's/^-L//'` + fi + AC_CHECK_LIB(ngtcp2_crypto_boringssl, ngtcp2_crypto_recv_client_initial_cb, + [ + AC_CHECK_HEADERS(ngtcp2/ngtcp2_crypto.h, + USE_NGTCP2=1 + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$DIR_NGTCP2_CRYPTO_BORINGSSL" + export CURL_LIBRARY_PATH + AC_MSG_NOTICE([Added $DIR_NGTCP2_CRYPTO_BORINGSSL to CURL_LIBRARY_PATH]) + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libngtcp2_crypto_boringssl" + ) + ], + dnl not found, revert back to clean variables + LDFLAGS=$CLEANLDFLAGS + LDFLAGSPC=$CLEANLDFLAGSPC + CPPFLAGS=$CLEANCPPFLAGS + LIBS=$CLEANLIBS + ) + + else + dnl no ngtcp2_crypto_boringssl pkg-config found, deal with it + if test "$want_tcp2" != "default"; then + dnl To avoid link errors, we do not allow --with-ngtcp2 without + dnl a pkgconfig file + AC_MSG_ERROR([--with-ngtcp2 was specified but could not find ngtcp2_crypto_boringssl pkg-config file.]) + fi + fi +fi + +if test "$USE_NGTCP2" = "1" && test "$GNUTLS_ENABLED" = "1"; then + dnl backup the pre-ngtcp2_crypto_gnutls variables + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + CURL_CHECK_PKGCONFIG(libngtcp2_crypto_gnutls, $want_tcp2_path, 1) + + if test "$PKGCONFIG" != "no"; then + LIB_NGTCP2_CRYPTO_GNUTLS=`CURL_EXPORT_PCDIR([$want_tcp2_path], 1) + $PKGCONFIG --libs-only-l libngtcp2_crypto_gnutls` + AC_MSG_NOTICE([-l is $LIB_NGTCP2_CRYPTO_GNUTLS]) + + CPP_NGTCP2_CRYPTO_GNUTLS=`CURL_EXPORT_PCDIR([$want_tcp2_path], 1) + $PKGCONFIG --cflags-only-I libngtcp2_crypto_gnutls` + AC_MSG_NOTICE([-I is $CPP_NGTCP2_CRYPTO_GNUTLS]) + + LD_NGTCP2_CRYPTO_GNUTLS=`CURL_EXPORT_PCDIR([$want_tcp2_path], 1) + $PKGCONFIG --libs-only-L libngtcp2_crypto_gnutls` + AC_MSG_NOTICE([-L is $LD_NGTCP2_CRYPTO_GNUTLS]) + + LDFLAGS="$LDFLAGS $LD_NGTCP2_CRYPTO_GNUTLS" + LDFLAGSPC="$LDFLAGSPC $LD_NGTCP2_CRYPTO_GNUTLS" + CPPFLAGS="$CPPFLAGS $CPP_NGTCP2_CRYPTO_GNUTLS" + LIBS="$LIB_NGTCP2_CRYPTO_GNUTLS $LIBS" + + if test "$cross_compiling" != "yes"; then + DIR_NGTCP2_CRYPTO_GNUTLS=`echo $LD_NGTCP2_CRYPTO_GNUTLS | $SED -e 's/^-L//'` + fi + AC_CHECK_LIB(ngtcp2_crypto_gnutls, ngtcp2_crypto_recv_client_initial_cb, + [ + AC_CHECK_HEADERS(ngtcp2/ngtcp2_crypto.h, + USE_NGTCP2=1 + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$DIR_NGTCP2_CRYPTO_GNUTLS" + export CURL_LIBRARY_PATH + AC_MSG_NOTICE([Added $DIR_NGTCP2_CRYPTO_GNUTLS to CURL_LIBRARY_PATH]) + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libngtcp2_crypto_gnutls" + ) + ], + dnl not found, revert back to clean variables + LDFLAGS=$CLEANLDFLAGS + LDFLAGSPC=$CLEANLDFLAGSPC + CPPFLAGS=$CLEANCPPFLAGS + LIBS=$CLEANLIBS + ) + + else + dnl no ngtcp2_crypto_gnutls pkg-config found, deal with it + if test "$want_tcp2" != "default"; then + dnl To avoid link errors, we do not allow --with-ngtcp2 without + dnl a pkgconfig file + AC_MSG_ERROR([--with-ngtcp2 was specified but could not find ngtcp2_crypto_gnutls pkg-config file.]) + fi + fi +fi + +if test "$USE_NGTCP2" = "1" && test "$WOLFSSL_ENABLED" = "1"; then + dnl backup the pre-ngtcp2_crypto_wolfssl variables + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + CURL_CHECK_PKGCONFIG(libngtcp2_crypto_wolfssl, $want_tcp2_path, 1) + + if test "$PKGCONFIG" != "no"; then + LIB_NGTCP2_CRYPTO_WOLFSSL=`CURL_EXPORT_PCDIR([$want_tcp2_path], 1) + $PKGCONFIG --libs-only-l libngtcp2_crypto_wolfssl` + AC_MSG_NOTICE([-l is $LIB_NGTCP2_CRYPTO_WOLFSSL]) + + CPP_NGTCP2_CRYPTO_WOLFSSL=`CURL_EXPORT_PCDIR([$want_tcp2_path], 1) + $PKGCONFIG --cflags-only-I libngtcp2_crypto_wolfssl` + AC_MSG_NOTICE([-I is $CPP_NGTCP2_CRYPTO_WOLFSSL]) + + LD_NGTCP2_CRYPTO_WOLFSSL=`CURL_EXPORT_PCDIR([$want_tcp2_path], 1) + $PKGCONFIG --libs-only-L libngtcp2_crypto_wolfssl` + AC_MSG_NOTICE([-L is $LD_NGTCP2_CRYPTO_WOLFSSL]) + + LDFLAGS="$LDFLAGS $LD_NGTCP2_CRYPTO_WOLFSSL" + LDFLAGSPC="$LDFLAGSPC $LD_NGTCP2_CRYPTO_WOLFSSL" + CPPFLAGS="$CPPFLAGS $CPP_NGTCP2_CRYPTO_WOLFSSL" + LIBS="$LIB_NGTCP2_CRYPTO_WOLFSSL $LIBS" + + if test "$cross_compiling" != "yes"; then + DIR_NGTCP2_CRYPTO_WOLFSSL=`echo $LD_NGTCP2_CRYPTO_WOLFSSL | $SED -e 's/^-L//'` + fi + AC_CHECK_LIB(ngtcp2_crypto_wolfssl, ngtcp2_crypto_recv_client_initial_cb, + [ + AC_CHECK_HEADERS(ngtcp2/ngtcp2_crypto.h, + USE_NGTCP2=1 + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$DIR_NGTCP2_CRYPTO_WOLFSSL" + export CURL_LIBRARY_PATH + AC_MSG_NOTICE([Added $DIR_NGTCP2_CRYPTO_WOLFSSL to CURL_LIBRARY_PATH]) + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libngtcp2_crypto_wolfssl" + ) + ], + dnl not found, revert back to clean variables + LDFLAGS=$CLEANLDFLAGS + LDFLAGSPC=$CLEANLDFLAGSPC + CPPFLAGS=$CLEANCPPFLAGS + LIBS=$CLEANLIBS + ) + + else + dnl no ngtcp2_crypto_wolfssl pkg-config found, deal with it + if test "$want_tcp2" != "default"; then + dnl To avoid link errors, we do not allow --with-ngtcp2 without + dnl a pkgconfig file + AC_MSG_ERROR([--with-ngtcp2 was specified but could not find ngtcp2_crypto_wolfssl pkg-config file.]) + fi + fi +fi + +dnl ********************************************************************** +dnl Check for nghttp3 (HTTP/3 with ngtcp2) +dnl ********************************************************************** + +OPT_NGHTTP3="yes" + +if test "$USE_NGTCP2" != "1"; then + dnl without ngtcp2, nghttp3 is of no use for us + OPT_NGHTTP3="no" + want_nghttp3="no" +fi + +AC_ARG_WITH(nghttp3, +AS_HELP_STRING([--with-nghttp3=PATH],[Enable nghttp3 usage]) +AS_HELP_STRING([--without-nghttp3],[Disable nghttp3 usage]), + [OPT_NGHTTP3=$withval]) +case "$OPT_NGHTTP3" in + no) + dnl --without-nghttp3 option used + want_nghttp3="no" + ;; + yes) + dnl --with-nghttp3 option used without path + want_nghttp3="default" + want_nghttp3_path="" + ;; + *) + dnl --with-nghttp3 option used with path + want_nghttp3="yes" + want_nghttp3_path="$OPT_NGHTTP3/lib/pkgconfig" + ;; +esac + +curl_http3_msg="no (--with-nghttp3)" +if test "$want_nghttp3" != "no"; then + + if test "x$USE_NGTCP2" != "x1"; then + dnl without ngtcp2, nghttp3 is of no use for us + AC_MSG_ERROR([nghttp3 enabled without a QUIC library; enable ngtcp2]) + fi + + dnl backup the pre-nghttp3 variables + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + CURL_CHECK_PKGCONFIG(libnghttp3, $want_nghttp3_path) + + if test "$PKGCONFIG" != "no"; then + LIB_NGHTTP3=`CURL_EXPORT_PCDIR([$want_nghttp3_path]) + $PKGCONFIG --libs-only-l libnghttp3` + AC_MSG_NOTICE([-l is $LIB_NGHTTP3]) + + CPP_NGHTTP3=`CURL_EXPORT_PCDIR([$want_nghttp3_path]) + $PKGCONFIG --cflags-only-I libnghttp3` + AC_MSG_NOTICE([-I is $CPP_NGHTTP3]) + + LD_NGHTTP3=`CURL_EXPORT_PCDIR([$want_nghttp3_path]) + $PKGCONFIG --libs-only-L libnghttp3` + AC_MSG_NOTICE([-L is $LD_NGHTTP3]) + + LDFLAGS="$LDFLAGS $LD_NGHTTP3" + LDFLAGSPC="$LDFLAGSPC $LD_NGHTTP3" + CPPFLAGS="$CPPFLAGS $CPP_NGHTTP3" + LIBS="$LIB_NGHTTP3 $LIBS" + + if test "$cross_compiling" != "yes"; then + DIR_NGHTTP3=`echo $LD_NGHTTP3 | $SED -e 's/^-L//'` + fi + AC_CHECK_LIB(nghttp3, nghttp3_conn_client_new_versioned, + [ + AC_CHECK_HEADERS(nghttp3/nghttp3.h, + AC_DEFINE(USE_NGHTTP3, 1, [if nghttp3 is in use]) + USE_NGHTTP3=1 + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$DIR_NGHTTP3" + export CURL_LIBRARY_PATH + AC_MSG_NOTICE([Added $DIR_NGHTTP3 to CURL_LIBRARY_PATH]) + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libnghttp3" + ) + ], + dnl not found, revert back to clean variables + LDFLAGS=$CLEANLDFLAGS + LDFLAGSPC=$CLEANLDFLAGSPC + CPPFLAGS=$CLEANCPPFLAGS + LIBS=$CLEANLIBS + ) + else + dnl no nghttp3 pkg-config found, deal with it + if test "$want_nghttp3" != "default"; then + dnl To avoid link errors, we do not allow --with-nghttp3 without + dnl a pkgconfig file + AC_MSG_ERROR([--with-nghttp3 was specified but could not find nghttp3 pkg-config file.]) + fi + fi +fi + +dnl ********************************************************************** +dnl Check for ngtcp2 and nghttp3 (HTTP/3 with ngtcp2 + nghttp3) +dnl ********************************************************************** + +if test "$USE_NGTCP2" = "1" && test "$USE_NGHTTP3" = "1"; then + USE_NGTCP2_H3=1 + curl_h3_msg="enabled (ngtcp2 + nghttp3)" +fi + +dnl ********************************************************************** +dnl Check for quiche (QUIC) +dnl ********************************************************************** + +OPT_QUICHE="no" + +if test "$disable_http" = "yes" || test "$USE_NGTCP" = "1"; then + dnl without HTTP or with ngtcp2, quiche is no use + OPT_QUICHE="no" +fi + +AC_ARG_WITH(quiche, +AS_HELP_STRING([--with-quiche=PATH],[Enable quiche usage (experimental)]) +AS_HELP_STRING([--without-quiche],[Disable quiche usage (experimental)]), + [OPT_QUICHE=$withval]) +case "$OPT_QUICHE" in + no) + dnl --without-quiche option used + want_quiche="no" + ;; + yes) + dnl --with-quiche option used without path + want_quiche="default" + want_quiche_path="" + ;; + *) + dnl --with-quiche option used with path + want_quiche="yes" + want_quiche_path="$withval" + ;; +esac + +if test "$want_quiche" != "no"; then + + if test "$QUIC_ENABLED" != "yes"; then + AC_MSG_ERROR([the detected TLS library does not support QUIC, making --with-quiche a no-no]) + fi + + if test "$NGHTTP3_ENABLED" = "1"; then + AC_MSG_ERROR([--with-quiche and --with-ngtcp2 are mutually exclusive]) + fi + + dnl backup the pre-quiche variables + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + CURL_CHECK_PKGCONFIG(quiche, $want_quiche_path) + + if test "$PKGCONFIG" != "no"; then + LIB_QUICHE=`CURL_EXPORT_PCDIR([$want_quiche_path]) + $PKGCONFIG --libs-only-l quiche` + AC_MSG_NOTICE([-l is $LIB_QUICHE]) + + CPP_QUICHE=`CURL_EXPORT_PCDIR([$want_quiche_path]) + $PKGCONFIG --cflags-only-I quiche` + AC_MSG_NOTICE([-I is $CPP_QUICHE]) + + LD_QUICHE=`CURL_EXPORT_PCDIR([$want_quiche_path]) + $PKGCONFIG --libs-only-L quiche` + AC_MSG_NOTICE([-L is $LD_QUICHE]) + + LDFLAGS="$LDFLAGS $LD_QUICHE" + LDFLAGSPC="$LDFLAGSPC $LD_QUICHE" + CPPFLAGS="$CPPFLAGS $CPP_QUICHE" + LIBS="$LIB_QUICHE $LIBS" + + if test "$cross_compiling" != "yes"; then + DIR_QUICHE=`echo $LD_QUICHE | $SED -e 's/^-L//'` + fi + AC_CHECK_LIB(quiche, quiche_conn_send_ack_eliciting, + [ + AC_CHECK_HEADERS(quiche.h, + experimental="$experimental Quiche" + AC_MSG_NOTICE([HTTP3 support is experimental]) + curl_h3_msg="enabled (quiche)" + AC_DEFINE(USE_QUICHE, 1, [if quiche is in use]) + USE_QUICHE=1 + AC_CHECK_FUNCS([quiche_conn_set_qlog_fd]) + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$DIR_QUICHE" + export CURL_LIBRARY_PATH + AC_MSG_NOTICE([Added $DIR_QUICHE to CURL_LIBRARY_PATH]) + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE quiche", + [], + [ + AC_INCLUDES_DEFAULT + #include + ] + ) + ], + dnl not found, revert back to clean variables + AC_MSG_ERROR([could not use quiche]) + ) + else + dnl no quiche pkg-config found, deal with it + if test "$want_quiche" != "default"; then + dnl To avoid link errors, we do not allow --with-quiche without + dnl a pkgconfig file + AC_MSG_ERROR([--with-quiche was specified but could not find quiche pkg-config file.]) + fi + fi +fi + +dnl ********************************************************************** +dnl libuv is only ever used for debug purposes +dnl ********************************************************************** + +OPT_LIBUV=no +AC_ARG_WITH(libuv, +AS_HELP_STRING([--with-libuv=PATH],[Enable libuv]) +AS_HELP_STRING([--without-libuv],[Disable libuv]), + [OPT_LIBUV=$withval]) +case "$OPT_LIBUV" in + no) + dnl --without-libuv option used + want_libuv="no" + ;; + yes) + dnl --with-libuv option used without path + want_libuv="default" + want_libuv_path="" + ;; + *) + dnl --with-libuv option used with path + want_libuv="yes" + want_libuv_path="$withval" + ;; +esac + +if test "$want_libuv" != "no"; then + if test "$want_debug" != "yes"; then + AC_MSG_ERROR([Using libuv without debug support enabled is useless]) + fi + + dnl backup the pre-libuv variables + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + CURL_CHECK_PKGCONFIG(libuv, $want_libuv_path) + + if test "$PKGCONFIG" != "no"; then + LIB_LIBUV=`CURL_EXPORT_PCDIR([$want_libuv_path]) + $PKGCONFIG --libs-only-l libuv` + AC_MSG_NOTICE([-l is $LIB_LIBUV]) + + CPP_LIBUV=`CURL_EXPORT_PCDIR([$want_libuv_path]) + $PKGCONFIG --cflags-only-I libuv` + AC_MSG_NOTICE([-I is $CPP_LIBUV]) + + LD_LIBUV=`CURL_EXPORT_PCDIR([$want_libuv_path]) + $PKGCONFIG --libs-only-L libuv` + AC_MSG_NOTICE([-L is $LD_LIBUV]) + + LDFLAGS="$LDFLAGS $LD_LIBUV" + LDFLAGSPC="$LDFLAGSPC $LD_LIBUV" + CPPFLAGS="$CPPFLAGS $CPP_LIBUV" + LIBS="$LIB_LIBUV $LIBS" + + if test "$cross_compiling" != "yes"; then + DIR_LIBUV=`echo $LD_LIBUV | $SED -e 's/^-L//'` + fi + AC_CHECK_LIB(uv, uv_default_loop, + [ + AC_CHECK_HEADERS(uv.h, + AC_DEFINE(USE_LIBUV, 1, [if libuv is in use]) + USE_LIBUV=1 + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$DIR_LIBUV" + export CURL_LIBRARY_PATH + AC_MSG_NOTICE([Added $DIR_LIBUV to CURL_LIBRARY_PATH]) + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libuv" + ) + ], + dnl not found, revert back to clean variables + LDFLAGS=$CLEANLDFLAGS + LDFLAGSPC=$CLEANLDFLAGSPC + CPPFLAGS=$CLEANCPPFLAGS + LIBS=$CLEANLIBS + ) + else + dnl no libuv pkg-config found, deal with it + if test "$want_libuv" != "default"; then + dnl To avoid link errors, we do not allow --with-libuv without + dnl a pkgconfig file + AC_MSG_ERROR([--with-libuv was specified but could not find libuv pkg-config file.]) + fi + fi + +fi + +dnl ********************************************************************** +dnl Check for zsh completion path +dnl ********************************************************************** + +OPT_ZSH_FPATH=default +AC_ARG_WITH(zsh-functions-dir, +AS_HELP_STRING([--with-zsh-functions-dir=PATH],[Install zsh completions to PATH]) +AS_HELP_STRING([--without-zsh-functions-dir],[Do not install zsh completions]), + [OPT_ZSH_FPATH=$withval]) +case "$OPT_ZSH_FPATH" in + default|no) + dnl --without-zsh-functions-dir option used + ;; + yes) + dnl --with-zsh-functions-dir option used without path + ZSH_FUNCTIONS_DIR="$datarootdir/zsh/site-functions" + AC_SUBST(ZSH_FUNCTIONS_DIR) + ;; + *) + dnl --with-zsh-functions-dir option used with path + ZSH_FUNCTIONS_DIR="$withval" + AC_SUBST(ZSH_FUNCTIONS_DIR) + ;; +esac +if test -z "$PERL" && test -n "$ZSH_FUNCTIONS_DIR"; then + AC_MSG_WARN([perl was not found. Cannot install zsh completions.]) + ZSH_FUNCTIONS_DIR='' +fi +AM_CONDITIONAL(USE_ZSH_COMPLETION, test -n "$ZSH_FUNCTIONS_DIR") + +dnl ********************************************************************** +dnl Check for fish completion path +dnl ********************************************************************** + +OPT_FISH_FPATH=default +AC_ARG_WITH(fish-functions-dir, +AS_HELP_STRING([--with-fish-functions-dir=PATH],[Install fish completions to PATH]) +AS_HELP_STRING([--without-fish-functions-dir],[Do not install fish completions]), + [OPT_FISH_FPATH=$withval]) +case "$OPT_FISH_FPATH" in + default|no) + dnl --without-fish-functions-dir option used + ;; + yes) + dnl --with-fish-functions-dir option used without path + CURL_CHECK_PKGCONFIG(fish) + if test "$PKGCONFIG" != "no"; then + FISH_FUNCTIONS_DIR=`$PKGCONFIG --variable completionsdir fish` + else + FISH_FUNCTIONS_DIR="$datarootdir/fish/vendor_completions.d" + fi + AC_SUBST(FISH_FUNCTIONS_DIR) + ;; + *) + dnl --with-fish-functions-dir option used with path + FISH_FUNCTIONS_DIR="$withval" + AC_SUBST(FISH_FUNCTIONS_DIR) + ;; +esac +if test -z "$PERL" && test -n "$FISH_FUNCTIONS_DIR"; then + AC_MSG_WARN([perl was not found. Cannot install fish completions.]) + FISH_FUNCTIONS_DIR='' +fi +AM_CONDITIONAL(USE_FISH_COMPLETION, test -n "$FISH_FUNCTIONS_DIR") + +dnl Now check for the most basic headers. Then we can use these +dnl ones as default-headers when checking for the rest! +AC_CHECK_HEADERS( + sys/types.h \ + sys/select.h \ + sys/ioctl.h \ + unistd.h \ + arpa/inet.h \ + net/if.h \ + netinet/in.h \ + netinet/in6.h \ + sys/un.h \ + linux/tcp.h \ + netinet/tcp.h \ + netinet/udp.h \ + netdb.h \ + sys/sockio.h \ + sys/param.h \ + termios.h \ + termio.h \ + fcntl.h \ + io.h \ + pwd.h \ + utime.h \ + sys/utime.h \ + sys/poll.h \ + poll.h \ + sys/resource.h \ + libgen.h \ + locale.h \ + stdbool.h \ + sys/filio.h \ + sys/eventfd.h, +[], +[], +/* default includes */ +[ +#include +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#if !defined(_WIN32) || defined(__MINGW32__) +#include +#endif +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif +#ifndef _WIN32 +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include /* is this really required to detect other headers? */ +#endif +#ifdef HAVE_SYS_UN_H +#include /* is this really required to detect other headers? */ +#endif +] +) + +dnl Checks for typedefs, structures, and compiler characteristics. +AC_C_CONST +AC_TYPE_SIZE_T + +CURL_CHECK_STRUCT_TIMEVAL +CURL_VERIFY_RUNTIMELIBS + +CURL_SIZEOF(size_t) +CURL_SIZEOF(long) +CURL_SIZEOF(int) +CURL_SIZEOF(time_t) +CURL_SIZEOF(off_t) + +o=$CPPFLAGS +CPPFLAGS="-I$srcdir/include $CPPFLAGS" +CURL_SIZEOF(curl_off_t, [ +#include +]) +CURL_SIZEOF(curl_socket_t, [ +#include +]) +CPPFLAGS=$o + +if test "$ac_cv_sizeof_curl_off_t" -lt 8; then + AC_MSG_ERROR([64-bit curl_off_t is required]) +fi + +dnl check for ssize_t +AC_CHECK_TYPE(ssize_t, , + AC_DEFINE(ssize_t, int, [the signed version of size_t])) + +dnl check for bool type +AC_CHECK_TYPE([bool],[ + AC_DEFINE(HAVE_BOOL_T, 1, + [Define to 1 if bool is an available type.]) +], ,[ +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#ifdef HAVE_STDBOOL_H +#include +#endif +]) + +if test "$curl_cv_native_windows" != "yes"; then + dnl check for sa_family_t + AC_CHECK_TYPE(sa_family_t, + AC_DEFINE(HAVE_SA_FAMILY_T, 1, [Define to 1 if symbol `sa_family_t' exists]),, + [ + #include + ]) +fi + +dnl check for suseconds_t +AC_CHECK_TYPE([suseconds_t],[ + AC_DEFINE(HAVE_SUSECONDS_T, 1, + [Define to 1 if suseconds_t is an available type.]) +], ,[ +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#ifndef _WIN32 +#include +#endif +]) + +case $host_os in + amigaos*|msdos*) + AC_DEFINE(HAVE_TIME_T_UNSIGNED, 1, [Define this if time_t is unsigned]) + ;; + *) + AC_MSG_CHECKING([if time_t is unsigned]) + CURL_RUN_IFELSE( + [ + #include + int main(void) { + time_t t = -1; + return t < 0; + } + ],[ + AC_MSG_RESULT([yes]) + AC_DEFINE(HAVE_TIME_T_UNSIGNED, 1, [Define this if time_t is unsigned]) + ],[ + AC_MSG_RESULT([no]) + ],[ + dnl cross-compiling, most systems are signed + AC_MSG_RESULT([no]) + ]) + ;; +esac + +TYPE_SOCKADDR_STORAGE + +CURL_CHECK_FUNC_SELECT + +CURL_CHECK_FUNC_RECV +CURL_CHECK_FUNC_SEND + +CURL_CHECK_FUNC_ALARM +CURL_CHECK_FUNC_BASENAME +CURL_CHECK_FUNC_CLOSESOCKET +CURL_CHECK_FUNC_CLOSESOCKET_CAMEL +CURL_CHECK_FUNC_FCNTL +CURL_CHECK_FUNC_FREEADDRINFO +CURL_CHECK_FUNC_FSETXATTR +CURL_CHECK_FUNC_GETADDRINFO +CURL_CHECK_FUNC_GETHOSTBYNAME_R +CURL_CHECK_FUNC_GETHOSTNAME +CURL_CHECK_FUNC_GETIFADDRS +CURL_CHECK_FUNC_GETPEERNAME +CURL_CHECK_FUNC_GETSOCKNAME +CURL_CHECK_FUNC_GMTIME_R +CURL_CHECK_FUNC_IOCTL +CURL_CHECK_FUNC_IOCTLSOCKET +CURL_CHECK_FUNC_IOCTLSOCKET_CAMEL +CURL_CHECK_FUNC_LOCALTIME_R +CURL_CHECK_FUNC_MEMRCHR +CURL_CHECK_FUNC_SIGACTION +CURL_CHECK_FUNC_SIGINTERRUPT +CURL_CHECK_FUNC_SIGNAL +CURL_CHECK_FUNC_SIGSETJMP +CURL_CHECK_FUNC_SOCKET +CURL_CHECK_FUNC_SOCKETPAIR +CURL_CHECK_FUNC_STRERROR_R + +case $host in + *msdosdjgpp) + ac_cv_func_pipe=no + skipcheck_pipe=yes + AC_MSG_NOTICE([skip check for pipe on msdosdjgpp]) + ;; +esac + +AC_CHECK_FUNCS([\ + accept4 \ + eventfd \ + fnmatch \ + geteuid \ + getpass_r \ + getppid \ + getpwuid \ + getpwuid_r \ + getrlimit \ + gettimeofday \ + mach_absolute_time \ + pipe \ + poll \ + sendmmsg \ + sendmsg \ + setlocale \ + setrlimit \ + utime \ + utimes \ +]) + +if test "$curl_cv_apple" != "yes"; then + dnl Apple platforms do not offer pipe2(), but the iPhone Simulator-specific + dnl /usr/lib/system/libsystem_sim_kernel.dylib exports it. To avoid false + dnl detection, omit this feature check for Apple targets. + AC_CHECK_FUNCS([\ + pipe2 \ + ]) +fi + +if test "$curl_cv_native_windows" != "yes"; then + AC_CHECK_FUNCS([\ + if_nametoindex \ + realpath \ + sched_yield \ + ]) + CURL_CHECK_FUNC_INET_NTOP + CURL_CHECK_FUNC_INET_PTON + CURL_CHECK_FUNC_STRCASECMP + CURL_CHECK_FUNC_STRCMPI + CURL_CHECK_FUNC_STRICMP + + CURL_CHECK_FUNC_MEMSET_S + if test "$curl_cv_func_memset_s" = "no"; then + AC_CHECK_FUNCS([memset_explicit]) + fi +fi + +if test -z "$ssl_backends"; then + AC_CHECK_FUNCS([arc4random]) +fi + +if test "$curl_cv_native_windows" != "yes"; then + AC_CHECK_FUNCS([fseeko]) + + dnl On Android, the only way to know if fseeko can be used is to see if it is + dnl declared or not (for this API level), as the symbol always exists in the + dnl lib. + AC_CHECK_DECL([fseeko], + [AC_DEFINE([HAVE_DECL_FSEEKO], [1], + [Define to 1 if you have the fseeko declaration])], + [], + [[#include ]]) +fi + +CURL_CHECK_NONBLOCKING_SOCKET + +dnl set variable for use in automakefile(s) +AM_CONDITIONAL(BUILD_DOCS, test "$BUILD_DOCS" = "1") + +dnl ************************************************************************* +dnl If the manual variable still is set, then we go with providing a built-in +dnl manual + +if test "$USE_MANUAL" = "1"; then + curl_manual_msg="enabled" +fi + +dnl set variable for use in automakefile(s) +AM_CONDITIONAL(USE_MANUAL, test "$USE_MANUAL" = "1") + +CURL_CHECK_LIB_ARES +CURL_CHECK_OPTION_THREADED_RESOLVER + +if test "$ipv6" = "yes" && test "$curl_cv_apple" = "yes"; then + CURL_DARWIN_SYSTEMCONFIGURATION +fi + +dnl detect pthreads +if test "$curl_cv_native_windows" != "yes"; then + AC_CHECK_HEADER(pthread.h, + [ + save_CFLAGS="$CFLAGS" + dnl When statically linking against BoringSSL, -lpthread is added to LIBS. + dnl Make sure to that this does not pass the check below, we really want + dnl -pthread in CFLAGS as recommended for GCC. This also ensures that + dnl lib1541 and lib1565 tests are built with these options. Otherwise + dnl they fail the build since tests/libtest/Makefile.am clears LIBS. + save_LIBS="$LIBS" + + LIBS= + dnl Check for libc variants without a separate pthread lib like bionic + AC_CHECK_FUNC(pthread_create, [HAVE_THREADS_POSIX=1] ) + LIBS="$save_LIBS" + + case $host in + *-hp-hpux*) + CFLAGS="$CFLAGS -mt" + ;; + *) + ;; + esac + + dnl if it was not found without lib, search for it in pthread lib + if test "$HAVE_THREADS_POSIX" != "1"; then + dnl assign PTHREAD for pkg-config use + PTHREAD=" -pthread" + + case $host in + *-ibm-aix*) + dnl Check if compiler is xlC + COMPILER_VERSION=`"$CC" -qversion 2>/dev/null` + if test -z "$COMPILER_VERSION"; then + CFLAGS="$CFLAGS -pthread" + else + CFLAGS="$CFLAGS -qthreaded" + fi + ;; + powerpc-*amigaos*) + dnl No -pthread option, but link with -lpthread + PTHREAD=" -lpthread" + ;; + *) + CFLAGS="$CFLAGS -pthread" + ;; + esac + AC_CHECK_LIB(pthread, pthread_create, + [HAVE_THREADS_POSIX=1], + [ CFLAGS="$save_CFLAGS"]) + fi + ]) + if test "$HAVE_THREADS_POSIX" = "1"; then + AC_DEFINE(HAVE_THREADS_POSIX, 1, [if POSIX pthreads are supported]) + fi +fi + +dnl threaded resolver check +if test "$want_threaded_resolver" = "yes"; then + if test "$curl_cv_native_windows" = "yes"; then + USE_RESOLV_THREADED=1 + AC_DEFINE(USE_RESOLV_THREADED, 1, [if you want threaded DNS lookup]) + curl_res_msg="Win32 threaded" + elif test "$HAVE_THREADS_POSIX" = "1"; then + USE_RESOLV_THREADED=1 + AC_DEFINE(USE_RESOLV_THREADED, 1, [if you want threaded DNS lookup]) + curl_res_msg="POSIX threaded" + else + AC_MSG_ERROR([Threaded resolver enabled but no thread library found]) + fi +elif test "$USE_ARES" = "1"; then + USE_RESOLV_ARES=1 + AC_DEFINE(USE_RESOLV_ARES, 1, [if you want c-ares for DNS lookup]) + curl_res_msg="c-ares" +fi + +AC_CHECK_HEADER(dirent.h, + [ AC_DEFINE(HAVE_DIRENT_H, 1, [if you have ]) + AC_CHECK_FUNC(opendir, AC_DEFINE(HAVE_OPENDIR, 1, [if you have opendir]) ) + ] +) + +CURL_CONVERT_INCLUDE_TO_ISYSTEM + +dnl ************************************************************ +dnl disable curl_easy_setopt()/curl_easy_getinfo() type checking +dnl +AC_MSG_CHECKING([whether to enable curl_easy_setopt()/curl_easy_getinfo() type checking]) +AC_ARG_ENABLE(typecheck, +AS_HELP_STRING([--enable-typecheck],[Enable type checking (default)]) +AS_HELP_STRING([--disable-typecheck],[Disable type checking]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + dnl Set it via the command-line to make it apply to examples also. + CPPFLAGS="$CPPFLAGS -DCURL_DISABLE_TYPECHECK" + curl_typecheck_msg="no" + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) + +dnl ************************************************************ +dnl disable verbose text strings +dnl +AC_MSG_CHECKING([whether to enable verbose strings]) +AC_ARG_ENABLE(verbose, +AS_HELP_STRING([--enable-verbose],[Enable verbose strings]) +AS_HELP_STRING([--disable-verbose],[Disable verbose strings]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_VERBOSE_STRINGS, 1, [to disable verbose strings]) + curl_verbose_msg="no" + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) + +if test "$curl_cv_winuwp" != "yes"; then + dnl ************************************************************ + dnl enable SSPI support + dnl + AC_MSG_CHECKING([whether to enable SSPI support (Windows native builds only)]) + AC_ARG_ENABLE(sspi, + AS_HELP_STRING([--enable-sspi],[Enable SSPI]) +AS_HELP_STRING([--disable-sspi],[Disable SSPI]), + [ case "$enableval" in + yes) + if test "$curl_cv_native_windows" = "yes"; then + AC_MSG_RESULT(yes) + AC_DEFINE(USE_WINDOWS_SSPI, 1, [to enable SSPI support]) + USE_WINDOWS_SSPI=1 + curl_sspi_msg="enabled" + else + AC_MSG_RESULT(no) + AC_MSG_WARN([--enable-sspi Ignored. Only supported on native Windows builds.]) + fi + ;; + *) + if test "$SCHANNEL_ENABLED" = "1"; then + dnl --with-schannel implies --enable-sspi + AC_MSG_RESULT(yes) + else + AC_MSG_RESULT(no) + fi + ;; + esac ], + if test "$SCHANNEL_ENABLED" = "1"; then + dnl --with-schannel implies --enable-sspi + AC_MSG_RESULT(yes) + else + AC_MSG_RESULT(no) + fi + ) + + if test "$USE_WINDOWS_SSPI" = "1"; then + LIBS="-lsecur32 $LIBS" + fi +fi + +dnl ************************************************************ +dnl disable basic authentication +dnl +AC_MSG_CHECKING([whether to enable basic authentication method]) +AC_ARG_ENABLE(basic-auth, +AS_HELP_STRING([--enable-basic-auth],[Enable basic authentication (default)]) +AS_HELP_STRING([--disable-basic-auth],[Disable basic authentication]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_BASIC_AUTH, 1, [to disable basic authentication]) + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) + +dnl ************************************************************ +dnl disable bearer authentication +dnl +AC_MSG_CHECKING([whether to enable bearer authentication method]) +AC_ARG_ENABLE(bearer-auth, +AS_HELP_STRING([--enable-bearer-auth],[Enable bearer authentication (default)]) +AS_HELP_STRING([--disable-bearer-auth],[Disable bearer authentication]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_BEARER_AUTH, 1, [to disable bearer authentication]) + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) + +dnl ************************************************************ +dnl disable digest authentication +dnl +AC_MSG_CHECKING([whether to enable digest authentication method]) +AC_ARG_ENABLE(digest-auth, +AS_HELP_STRING([--enable-digest-auth],[Enable digest authentication (default)]) +AS_HELP_STRING([--disable-digest-auth],[Disable digest authentication]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_DIGEST_AUTH, 1, [to disable digest authentication]) + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) + +dnl ************************************************************ +dnl disable kerberos authentication +dnl +AC_MSG_CHECKING([whether to enable kerberos authentication method]) +AC_ARG_ENABLE(kerberos-auth, +AS_HELP_STRING([--enable-kerberos-auth],[Enable kerberos authentication (default)]) +AS_HELP_STRING([--disable-kerberos-auth],[Disable kerberos authentication]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_KERBEROS_AUTH, 1, [to disable kerberos authentication]) + CURL_DISABLE_KERBEROS_AUTH=1 + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) + +dnl ************************************************************ +dnl disable negotiate authentication +dnl +AC_MSG_CHECKING([whether to enable negotiate authentication method]) +AC_ARG_ENABLE(negotiate-auth, +AS_HELP_STRING([--enable-negotiate-auth],[Enable negotiate authentication (default)]) +AS_HELP_STRING([--disable-negotiate-auth],[Disable negotiate authentication]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_NEGOTIATE_AUTH, 1, [to disable negotiate authentication]) + CURL_DISABLE_NEGOTIATE_AUTH=1 + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) + +dnl ************************************************************ +dnl disable aws +dnl +AC_MSG_CHECKING([whether to enable aws sig methods]) +AC_ARG_ENABLE(aws, +AS_HELP_STRING([--enable-aws],[Enable AWS sig support (default)]) +AS_HELP_STRING([--disable-aws],[Disable AWS sig support]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_AWS, 1, [to disable AWS sig support]) + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) + +dnl ************************************************************ +dnl disable NTLM support +dnl +AC_MSG_CHECKING([whether to support NTLM]) +AC_ARG_ENABLE(ntlm, +AS_HELP_STRING([--enable-ntlm],[Enable NTLM support]) +AS_HELP_STRING([--disable-ntlm],[Disable NTLM support]), +[ case "$enableval" in + yes) + AC_MSG_RESULT(yes) + AC_DEFINE(CURL_ENABLE_NTLM, 1, [enable NTLM support]) + CURL_ENABLE_NTLM=1 + ;; + *) + AC_MSG_RESULT(no) + ;; + esac ], + AC_MSG_RESULT(no) +) + +dnl ************************************************************ +dnl disable TLS-SRP authentication +dnl +AC_MSG_CHECKING([whether to enable TLS-SRP authentication]) +AC_ARG_ENABLE(tls-srp, +AS_HELP_STRING([--enable-tls-srp],[Enable TLS-SRP authentication]) +AS_HELP_STRING([--disable-tls-srp],[Disable TLS-SRP authentication]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + want_tls_srp=no + ;; + *) + AC_MSG_RESULT(yes) + want_tls_srp=yes + ;; + esac ], + AC_MSG_RESULT(yes) + want_tls_srp=yes +) + +if test "$want_tls_srp" = "yes" && (test "$HAVE_GNUTLS_SRP" = "1" || test "$HAVE_OPENSSL_SRP" = "1"); then + AC_DEFINE(USE_TLS_SRP, 1, [Use TLS-SRP authentication]) + USE_TLS_SRP=1 + curl_tls_srp_msg="enabled" +fi + +dnl ************************************************************ +dnl disable Unix domain sockets support +dnl +AC_MSG_CHECKING([whether to enable Unix domain sockets]) +AC_ARG_ENABLE(unix-sockets, +AS_HELP_STRING([--enable-unix-sockets],[Enable Unix domain sockets]) +AS_HELP_STRING([--disable-unix-sockets],[Disable Unix domain sockets]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + want_unix_sockets=no + ;; + *) + AC_MSG_RESULT(yes) + want_unix_sockets=yes + ;; + esac ], [ + AC_MSG_RESULT(auto) + want_unix_sockets=auto + ] +) +if test "$want_unix_sockets" != "no"; then + if test "$curl_cv_native_windows" = "yes"; then + USE_UNIX_SOCKETS=1 + AC_DEFINE(USE_UNIX_SOCKETS, 1, [Use Unix domain sockets]) + curl_unix_sockets_msg="enabled" + else + AC_CHECK_MEMBER([struct sockaddr_un.sun_path], [ + AC_DEFINE(USE_UNIX_SOCKETS, 1, [Use Unix domain sockets]) + USE_UNIX_SOCKETS=1 + curl_unix_sockets_msg="enabled" + ], [ + if test "$want_unix_sockets" = "yes"; then + AC_MSG_ERROR([--enable-unix-sockets is not available on this platform!]) + fi + ], [ + #include + ]) + fi +fi + +dnl ************************************************************ +dnl disable cookies support +dnl +AC_MSG_CHECKING([whether to support cookies]) +AC_ARG_ENABLE(cookies, +AS_HELP_STRING([--enable-cookies],[Enable cookies support]) +AS_HELP_STRING([--disable-cookies],[Disable cookies support]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_COOKIES, 1, [to disable cookies support]) + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) + +dnl ************************************************************ +dnl disable socketpair +dnl +AC_MSG_CHECKING([whether to support socketpair]) +AC_ARG_ENABLE(socketpair, +AS_HELP_STRING([--enable-socketpair],[Enable socketpair support]) +AS_HELP_STRING([--disable-socketpair],[Disable socketpair support]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_SOCKETPAIR, 1, [to disable socketpair support]) + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) + +dnl ************************************************************ +dnl disable HTTP authentication support +dnl +AC_MSG_CHECKING([whether to support HTTP authentication]) +AC_ARG_ENABLE(http-auth, +AS_HELP_STRING([--enable-http-auth],[Enable HTTP authentication support]) +AS_HELP_STRING([--disable-http-auth],[Disable HTTP authentication support]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_HTTP_AUTH, 1, [disable HTTP authentication]) + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) + +dnl ************************************************************ +dnl disable DoH support +dnl +AC_MSG_CHECKING([whether to support DoH]) +AC_ARG_ENABLE(doh, +AS_HELP_STRING([--enable-doh],[Enable DoH support]) +AS_HELP_STRING([--disable-doh],[Disable DoH support]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_DOH, 1, [disable DoH]) + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) + +dnl ************************************************************ +dnl disable mime API support +dnl +AC_MSG_CHECKING([whether to support the MIME API]) +AC_ARG_ENABLE(mime, +AS_HELP_STRING([--enable-mime],[Enable mime API support]) +AS_HELP_STRING([--disable-mime],[Disable mime API support]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_MIME, 1, [disable mime API]) + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) + +dnl ************************************************************ +dnl disable bindlocal +dnl +AC_MSG_CHECKING([whether to support binding connections locally]) +AC_ARG_ENABLE(bindlocal, +AS_HELP_STRING([--enable-bindlocal],[Enable local binding support]) +AS_HELP_STRING([--disable-bindlocal],[Disable local binding support]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_BINDLOCAL, 1, [disable local binding support]) + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) + +dnl ************************************************************ +dnl disable form API support +dnl +AC_MSG_CHECKING([whether to support the form API]) +AC_ARG_ENABLE(form-api, +AS_HELP_STRING([--enable-form-api],[Enable form API support]) +AS_HELP_STRING([--disable-form-api],[Disable form API support]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_FORM_API, 1, [disable form API]) + ;; + *) + AC_MSG_RESULT(yes) + test "x$enable_mime" = "xno" && + AC_MSG_ERROR(MIME support needs to be enabled in order to enable form API support) + ;; + esac ], +[ + if test "x$enable_mime" = "xno"; then + enable_form_api=no + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_FORM_API, 1, [disable form API]) + else + AC_MSG_RESULT(yes) + fi ] +) + +dnl ************************************************************ +dnl disable date parsing +dnl +AC_MSG_CHECKING([whether to support date parsing]) +AC_ARG_ENABLE(dateparse, +AS_HELP_STRING([--enable-dateparse],[Enable date parsing]) +AS_HELP_STRING([--disable-dateparse],[Disable date parsing]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_PARSEDATE, 1, [disable date parsing]) + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) + +dnl ************************************************************ +dnl disable netrc +dnl +AC_MSG_CHECKING([whether to support netrc parsing]) +AC_ARG_ENABLE(netrc, +AS_HELP_STRING([--enable-netrc],[Enable netrc parsing]) +AS_HELP_STRING([--disable-netrc],[Disable netrc parsing]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_NETRC, 1, [disable netrc parsing]) + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) + +dnl ************************************************************ +dnl disable progress-meter +dnl +AC_MSG_CHECKING([whether to support progress-meter]) +AC_ARG_ENABLE(progress-meter, +AS_HELP_STRING([--enable-progress-meter],[Enable progress-meter]) +AS_HELP_STRING([--disable-progress-meter],[Disable progress-meter]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_PROGRESS_METER, 1, [disable progress-meter]) + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) + +dnl ************************************************************ +dnl disable SHA-512/256 hash algorithm +dnl +AC_MSG_CHECKING([whether to support the SHA-512/256 hash algorithm]) +AC_ARG_ENABLE(sha512-256, +AS_HELP_STRING([--enable-sha512-256],[Enable SHA-512/256 hash algorithm (default)]) +AS_HELP_STRING([--disable-sha512-256],[Disable SHA-512/256 hash algorithm]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_SHA512_256, 1, [disable SHA-512/256 hash algorithm]) + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) + +dnl ************************************************************ +dnl disable shuffle DNS support +dnl +AC_MSG_CHECKING([whether to support DNS shuffling]) +AC_ARG_ENABLE(dnsshuffle, +AS_HELP_STRING([--enable-dnsshuffle],[Enable DNS shuffling]) +AS_HELP_STRING([--disable-dnsshuffle],[Disable DNS shuffling]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_SHUFFLE_DNS, 1, [disable DNS shuffling]) + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) + +dnl ************************************************************ +dnl disable the curl_easy_options API +dnl +AC_MSG_CHECKING([whether to support curl_easy_option*]) +AC_ARG_ENABLE(get-easy-options, +AS_HELP_STRING([--enable-get-easy-options],[Enable curl_easy_options]) +AS_HELP_STRING([--disable-get-easy-options],[Disable curl_easy_options]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_GETOPTIONS, 1, [to disable curl_easy_options]) + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) + +dnl ************************************************************ +dnl switch on/off alt-svc +dnl +AC_MSG_CHECKING([whether to support alt-svc]) +AC_ARG_ENABLE(alt-svc, +AS_HELP_STRING([--enable-alt-svc],[Enable alt-svc support]) +AS_HELP_STRING([--disable-alt-svc],[Disable alt-svc support]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_ALTSVC, 1, [disable alt-svc]) + curl_altsvc_msg="no"; + enable_altsvc="no" + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) + +dnl ************************************************************ +dnl switch on/off headers-api +dnl +AC_MSG_CHECKING([whether to support headers-api]) +AC_ARG_ENABLE(headers-api, +AS_HELP_STRING([--enable-headers-api],[Enable headers-api support]) +AS_HELP_STRING([--disable-headers-api],[Disable headers-api support]), +[ case "$enableval" in + no) + AC_MSG_RESULT(no) + curl_headers_msg="no (--enable-headers-api)" + AC_DEFINE(CURL_DISABLE_HEADERS_API, 1, [disable headers-api]) + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT(yes) +) + +dnl only check for HSTS if there is SSL present +if test -n "$SSL_ENABLED"; then + dnl ************************************************************ + dnl switch on/off hsts + dnl + AC_MSG_CHECKING([whether to support HSTS]) + AC_ARG_ENABLE(hsts, +AS_HELP_STRING([--enable-hsts],[Enable HSTS support]) +AS_HELP_STRING([--disable-hsts],[Disable HSTS support]), + [ case "$enableval" in + no) + AC_MSG_RESULT(no) + hsts="no" + ;; + *) + AC_MSG_RESULT(yes) + ;; + esac ], + AC_MSG_RESULT($hsts) + ) +else + AC_MSG_NOTICE([disables HSTS due to lack of SSL]) + hsts="no" +fi + +if test "$hsts" != "yes"; then + curl_hsts_msg="no (--enable-hsts)"; + AC_DEFINE(CURL_DISABLE_HSTS, 1, [disable alt-svc]) +fi + +dnl ************************************************************* +dnl check whether ECH support, if desired, is actually available +dnl +if test "$want_ech" != "no"; then + AC_MSG_CHECKING([whether ECH support is available]) + + dnl assume NOT and look for sufficient condition + ECH_ENABLED=0 + ECH_ENABLED_OPENSSL=0 + ECH_ENABLED_WOLFSSL=0 + ECH_ENABLED_RUSTLS=0 + ECH_SUPPORT='' + + dnl check for OpenSSL equivalent + if test "$OPENSSL_ENABLED" = "1"; then + AC_CHECK_FUNCS(SSL_set1_ech_config_list, + ECH_SUPPORT="$ECH_SUPPORT OpenSSL" + ECH_ENABLED_OPENSSL=1) + fi + if test "$WOLFSSL_ENABLED" = "1"; then + AC_CHECK_FUNCS(wolfSSL_CTX_GenerateEchConfig, + ECH_SUPPORT="$ECH_SUPPORT wolfSSL" + ECH_ENABLED_WOLFSSL=1) + fi + if test "$RUSTLS_ENABLED" = "1"; then + ECH_SUPPORT="$ECH_SUPPORT rustls-ffi" + ECH_ENABLED_RUSTLS=1 + fi + + dnl now deal with whatever we found + if test "$ECH_ENABLED_OPENSSL" = "1" || + test "$ECH_ENABLED_WOLFSSL" = "1" || + test "$ECH_ENABLED_RUSTLS" = "1"; then + AC_DEFINE(USE_ECH, 1, [if ECH support is available]) + AC_MSG_RESULT(ECH support available via:$ECH_SUPPORT) + experimental="$experimental ECH" + ECH_ENABLED=1 + dnl ECH wants HTTPSRR + want_httpsrr="yes" + else + AC_MSG_ERROR([--enable-ech ignored: No ECH support found]) + fi +fi + +AC_MSG_CHECKING([whether to enable HTTPS-RR support]) +dnl ************************************************************* +dnl check whether HTTPSRR support if desired +dnl +if test "$want_httpsrr" != "no"; then + AC_MSG_RESULT([yes]) + AC_DEFINE(USE_HTTPSRR, 1, [enable HTTPS RR support]) + experimental="$experimental HTTPSRR" + curl_httpsrr_msg="enabled (--disable-httpsrr)" +else + AC_MSG_RESULT([no]) + dnl no HTTPSRR wanted + if test "$want_threaded_resolver" = "yes"; then + dnl and using the threaded resolver + if test "$USE_ARES" = "1"; then + AC_MSG_ERROR([without HTTPS-RR support, asking for both threaded resolver and c-ares support is ambivalent. Please drop one of them.]) + fi + fi +fi + +dnl ************************************************************* +dnl check whether OpenSSL (lookalikes) have SSL_set0_wbio +dnl +if test "$OPENSSL_ENABLED" = "1"; then + AC_CHECK_FUNCS([SSL_set0_wbio]) +fi + +dnl ************************************************************* +dnl WebSockets +dnl +if test "$CURL_DISABLE_HTTP" != "1"; then + AC_MSG_CHECKING([whether to support WebSockets]) + AC_ARG_ENABLE(websockets, + AS_HELP_STRING([--enable-websockets],[Enable WebSockets support]) +AS_HELP_STRING([--disable-websockets],[Disable WebSockets support]), + [ case "$enableval" in + no) + AC_MSG_RESULT(no) + AC_DEFINE(CURL_DISABLE_WEBSOCKETS, [1], [disable WebSockets]) + CURL_DISABLE_WEBSOCKETS=1 + ;; + *) + if test "$ac_cv_sizeof_curl_off_t" -gt 4; then + AC_MSG_RESULT(yes) + else + dnl WebSockets requires >32-bit curl_off_t + AC_MSG_RESULT(no) + AC_MSG_WARN([WebSockets disabled due to lack of >32-bit curl_off_t]) + AC_DEFINE(CURL_DISABLE_WEBSOCKETS, [1], [disable WebSockets]) + CURL_DISABLE_WEBSOCKETS=1 + fi + ;; + esac ], + AC_MSG_RESULT(yes) + ) +else + AC_MSG_WARN([WebSockets disabled because HTTP is disabled]) + AC_DEFINE(CURL_DISABLE_WEBSOCKETS, [1], [disable WebSockets]) + CURL_DISABLE_WEBSOCKETS=1 +fi + +dnl ************************************************************* +dnl check whether experimental SSL Session Im-/Export is enabled +dnl +if test "$want_ssls_export" != "no"; then + AC_MSG_CHECKING([whether SSL session export support is available]) + + dnl assume NOT and look for sufficient condition + SSLS_EXPORT_ENABLED=0 + SSLS_EXPORT_SUPPORT='' + + if test "$SSL_ENABLED" != "1"; then + AC_MSG_WARN([--enable-ssls-export ignored: No SSL support]) + else + SSLS_EXPORT_ENABLED=1 + AC_DEFINE(USE_SSLS_EXPORT, 1, [if SSL session export support is available]) + AC_MSG_RESULT("SSL session im-/export enabled") + experimental="$experimental SSLS-EXPORT" + fi +fi + +dnl ************************************************************* +dnl check whether experimental HTTP/3 proxy support is enabled +dnl +if test "$want_proxy_http3" = "yes"; then + AC_MSG_CHECKING([whether HTTP/3 proxy support is available]) + + if test "$CURL_DISABLE_PROXY" = "1"; then + AC_MSG_ERROR([--enable-proxy-http3 requires proxy support]) + elif test "$CURL_DISABLE_HTTP" = "1"; then + AC_MSG_ERROR([--enable-proxy-http3 requires HTTP support]) + elif test "$USE_NGTCP2_H3" != "1"; then + AC_MSG_ERROR([--enable-proxy-http3 requires ngtcp2 + nghttp3]) + elif test "x$OPENSSL_ENABLED" != "x1"; then + AC_MSG_ERROR([--enable-proxy-http3 currently requires OpenSSL]) + else + AC_DEFINE(USE_PROXY_HTTP3, 1, [if HTTP/3 proxy support is available]) + USE_PROXY_HTTP3=1 + AC_MSG_RESULT([yes]) + experimental="$experimental proxy-HTTP3" + fi +fi + +dnl ************************************************************ +dnl hiding of library internal symbols +dnl +CURL_CONFIGURE_SYMBOL_HIDING + +dnl +dnl All the library dependencies put into $LIB apply to libcurl only. +dnl +LIBCURL_PC_LDFLAGS_PRIVATE='' +dnl Do not quote $INITIAL_LDFLAGS +set -- $INITIAL_LDFLAGS +while test -n "$1"; do + case "$1" in + -L* | --library-path=* | -F*) + LIBCURL_PC_LDFLAGS_PRIVATE="$LIBCURL_PC_LDFLAGS_PRIVATE $1" + ;; + -framework) + if test -n "$2"; then + LIBCURL_PC_LDFLAGS_PRIVATE="$LIBCURL_PC_LDFLAGS_PRIVATE $1 $2" + shift + fi + ;; + esac + shift +done +LIBCURL_PC_LDFLAGS_PRIVATE="$LIBCURL_PC_LDFLAGS_PRIVATE $LDFLAGSPC" +LIBCURL_PC_LIBS_PRIVATE="$LIBS$PTHREAD" + +AC_SUBST(LIBCURL_PC_LDFLAGS_PRIVATE) +AC_SUBST(LIBCURL_PC_LIBS_PRIVATE) +AC_SUBST(CURL_NETWORK_AND_TIME_LIBS) + +dnl BLANK_AT_MAKETIME may be used in our Makefile.am files to blank +dnl LIBS variable used in generated makefile at makefile processing +dnl time. Doing this functionally prevents LIBS from being used for +dnl all link targets in given makefile. +BLANK_AT_MAKETIME= +AC_SUBST(BLANK_AT_MAKETIME) + +AM_CONDITIONAL(CROSSCOMPILING, test "$cross_compiling" = "yes") + +dnl yes or no +ENABLE_SHARED="$enable_shared" +AC_SUBST(ENABLE_SHARED) + +dnl to let curl-config output the static libraries correctly +ENABLE_STATIC="$enable_static" +AC_SUBST(ENABLE_STATIC) + +squeeze LIBCURL_PC_REQUIRES_PRIVATE +LIBCURL_PC_REQUIRES_PRIVATE=`echo $LIBCURL_PC_REQUIRES_PRIVATE | tr ' ' ','` + +AC_SUBST(LIBCURL_PC_REQUIRES_PRIVATE) + +dnl Merge pkg-config private fields into public ones when static-only +if test "$enable_shared" = "no"; then + LIBCURL_PC_REQUIRES=$LIBCURL_PC_REQUIRES_PRIVATE + LIBCURL_PC_LIBS=$LIBCURL_PC_LIBS_PRIVATE +else + LIBCURL_PC_REQUIRES= + LIBCURL_PC_LIBS= +fi +AC_SUBST(LIBCURL_PC_REQUIRES) +AC_SUBST(LIBCURL_PC_LIBS) + +rm $compilersh + +dnl +dnl For keeping supported features and protocols also in pkg-config file +dnl since it is more cross-compile friendly than curl-config +dnl + +if test "$OPENSSL_ENABLED" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES SSL" +elif test -n "$SSL_ENABLED"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES SSL" +fi +if test "$IPV6_ENABLED" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES IPv6" +fi +if test "$USE_UNIX_SOCKETS" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES UnixSockets" +fi +if test "$HAVE_LIBZ" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES libz" +fi +if test "$HAVE_BROTLI" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES brotli" +fi +if test "$HAVE_ZSTD" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES zstd" +fi +if test "$USE_RESOLV_ARES" = "1" || test "$USE_RESOLV_THREADED" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES AsynchDNS" +fi +if test "$USE_ARES" = "1" && test "$want_threaded_resolver" = "yes" && test "$want_httpsrr" != "no"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES asyn-rr" +fi +if test "$IDN_ENABLED" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES IDN" +fi +if test "$USE_WINDOWS_SSPI" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES SSPI" +fi + +if test "$HAVE_GSSAPI" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES GSS-API" +fi + +if test "$curl_psl_msg" = "enabled"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES PSL" +fi + +if test "$USE_PROXY_HTTP3" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES proxy-HTTP3" +fi + +if test "$curl_gsasl_msg" = "enabled"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES gsasl" +fi + +if test "$enable_altsvc" = "yes"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES alt-svc" +fi +if test "$hsts" = "yes"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES HSTS" +fi + +if test "$CURL_DISABLE_NEGOTIATE_AUTH" != "1" && (test "$HAVE_GSSAPI" = "1" || test "$USE_WINDOWS_SSPI" = "1"); then + SUPPORT_FEATURES="$SUPPORT_FEATURES SPNEGO" +fi + +if test "$CURL_DISABLE_KERBEROS_AUTH" != "1" && (test "$HAVE_GSSAPI" = "1" || test "$USE_WINDOWS_SSPI" = "1"); then + SUPPORT_FEATURES="$SUPPORT_FEATURES Kerberos" +fi + +use_curl_ntlm_core=no + +if test "$CURL_ENABLE_NTLM" = "1"; then + if test "$HAVE_DES_ECB_ENCRYPT" = "1" || + test "$GNUTLS_ENABLED" = "1" || + test "$USE_WIN32_CRYPTO" = "1" || + test "$HAVE_WC_DES_ECBENCRYPT" = "1" || + test "$HAVE_MBEDTLS_DES_CRYPT_ECB" = "1"; then + use_curl_ntlm_core=yes + fi + + if test "$use_curl_ntlm_core" = "yes" || + test "$USE_WINDOWS_SSPI" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES NTLM" + fi +fi + +if test "$USE_TLS_SRP" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES TLS-SRP" +fi + +if test "$USE_NGHTTP2" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES HTTP2" +fi + +if test "$USE_NGTCP2_H3" = "1" || + test "$USE_QUICHE" = "1" || + test "$USE_OPENSSL_H3" = "1"; then + if test "$CURL_WITH_MULTI_SSL" = "1"; then + AC_MSG_ERROR([MultiSSL cannot be enabled with HTTP/3 and vice versa]) + fi + SUPPORT_FEATURES="$SUPPORT_FEATURES HTTP3" +fi + +if test "$CURL_WITH_MULTI_SSL" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES MultiSSL" +fi + +AC_MSG_CHECKING([if this build supports HTTPS-proxy]) +dnl if not explicitly turned off, HTTPS-proxy comes with some TLS backends +if test "$CURL_DISABLE_HTTP" != "1"; then + if test "$https_proxy" != "no"; then + if test "$OPENSSL_ENABLED" = "1" || + test "$GNUTLS_ENABLED" = "1" || + test "$RUSTLS_ENABLED" = "1" || + test "$SCHANNEL_ENABLED" = "1" || + test "$GNUTLS_ENABLED" = "1" || + test "$MBEDTLS_ENABLED" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES HTTPS-proxy" + AC_MSG_RESULT([yes]) + elif test "$WOLFSSL_ENABLED" = "1" && test "$HAVE_WOLFSSL_BIO_NEW" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES HTTPS-proxy" + AC_MSG_RESULT([yes]) + else + AC_MSG_RESULT([no]) + fi + else + AC_MSG_RESULT([no]) + fi +else + AC_MSG_RESULT([no]) +fi + +if test "$OPENSSL_ENABLED" = "1" || test -n "$SSL_ENABLED"; then + if test "$ECH_ENABLED" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES ECH" + fi +fi + +if test -n "$SSL_ENABLED"; then + if test "$APPLE_SECTRUST_ENABLED" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES AppleSecTrust" + elif test "$ca_native_opt" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES NativeCA" + fi +fi + +if test "$want_httpsrr" != "no"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES HTTPSRR" +fi + +if test "$SSLS_EXPORT_ENABLED" = "1"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES SSLS-EXPORT" +fi + +if test "$ac_cv_sizeof_curl_off_t" -gt 4; then + if test "$ac_cv_sizeof_off_t" -gt 4 || + test "$curl_cv_native_windows" = "yes"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES Largefile" + fi +fi + +if test "$tst_atomic" = "yes"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES threadsafe" +elif test "$HAVE_THREADS_POSIX" = "1" && test "$ac_cv_header_pthread_h" = "yes"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES threadsafe" +elif test "$curl_cv_native_windows" = "yes"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES threadsafe" +fi + +if test "$want_winuni" = "yes"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES Unicode" +fi +if test "$want_debug" = "yes"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES Debug" +fi +if test -n "$CURL_CA_EMBED"; then + SUPPORT_FEATURES="$SUPPORT_FEATURES CAcert" + CURL_CA_EMBED_msg="$CURL_CA_EMBED" +else + CURL_CA_EMBED_msg='no' +fi + +dnl replace spaces with newlines +dnl sort the lines +dnl replace the newlines back to spaces +if sort -f /dev/null 2>&1; then + SUPPORT_FEATURES=`echo $SUPPORT_FEATURES | tr ' ' '\012' | sort -f | tr '\012' ' '` +else + SUPPORT_FEATURES=`echo $SUPPORT_FEATURES | tr ' ' '\012' | sort | tr '\012' ' '` +fi +AC_SUBST(SUPPORT_FEATURES) + +dnl For supported protocols in pkg-config file +if test "$CURL_DISABLE_HTTP" != "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS HTTP" + if test "$SSL_ENABLED" = "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS HTTPS" + fi +fi +if test "$CURL_DISABLE_FTP" != "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS FTP" + if test "$SSL_ENABLED" = "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS FTPS" + fi +fi +if test "$CURL_DISABLE_FILE" != "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS FILE" +fi +if test "$CURL_DISABLE_TELNET" != "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS TELNET" +fi +if test "$CURL_DISABLE_LDAP" != "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS LDAP" + if test "$CURL_DISABLE_LDAPS" != "1"; then + if (test "$USE_OPENLDAP" = "1" && test "$SSL_ENABLED" = "1") || + (test "$USE_OPENLDAP" != "1" && test "$HAVE_LDAP_SSL" = "1"); then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS LDAPS" + fi + fi +fi +if test "$CURL_DISABLE_DICT" != "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS DICT" +fi +if test "$CURL_DISABLE_TFTP" != "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS TFTP" +fi +if test "$CURL_DISABLE_GOPHER" != "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS GOPHER" + if test "$SSL_ENABLED" = "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS GOPHERS" + fi +fi +if test "$CURL_DISABLE_MQTT" != "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS MQTT" + if test "$SSL_ENABLED" = "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS MQTTS" + fi +fi +if test "$CURL_DISABLE_POP3" != "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS POP3" + if test "$SSL_ENABLED" = "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS POP3S" + fi +fi +if test "$CURL_DISABLE_IMAP" != "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS IMAP" + if test "$SSL_ENABLED" = "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS IMAPS" + fi +fi +if test "$CURL_ENABLE_SMB" = "1" && test "$use_curl_ntlm_core" = "yes"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS SMB" + if test "$SSL_ENABLED" = "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS SMBS" + fi +fi +if test "$CURL_DISABLE_SMTP" != "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS SMTP" + if test "$SSL_ENABLED" = "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS SMTPS" + fi +fi +if test "$USE_LIBSSH2" = "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS SCP" + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS SFTP" +fi +if test "$USE_LIBSSH" = "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS SCP" + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS SFTP" +fi +if test "$CURL_DISABLE_IPFS" != "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS IPFS IPNS" +fi +if test "$CURL_DISABLE_RTSP" != "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS RTSP" +fi +if test "$CURL_DISABLE_WEBSOCKETS" != "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS WS" + if test "$SSL_ENABLED" = "1"; then + SUPPORT_PROTOCOLS="$SUPPORT_PROTOCOLS WSS" + fi +fi + +dnl replace spaces with newlines +dnl sort the lines +dnl replace the newlines back to spaces +SUPPORT_PROTOCOLS=`echo $SUPPORT_PROTOCOLS | tr ' ' '\012' | sort | tr '\012' ' '` + +AC_SUBST(SUPPORT_PROTOCOLS) + +dnl squeeze whitespace out of some variables + +squeeze CFLAGS +squeeze CPPFLAGS +squeeze DEFS +squeeze LDFLAGS +squeeze LIBS + +squeeze LIBCURL_PC_LDFLAGS_PRIVATE +squeeze LIBCURL_PC_LIBS_PRIVATE +squeeze CURL_NETWORK_AND_TIME_LIBS + +squeeze SUPPORT_FEATURES +squeeze SUPPORT_PROTOCOLS + +XC_CHECK_BUILD_FLAGS + +SSL_BACKENDS=${ssl_backends} +AC_SUBST(SSL_BACKENDS) + +CURL_PREPARE_CONFIGUREHELP_PM + +AC_CONFIG_FILES([\ + Makefile \ + docs/Makefile \ + docs/examples/Makefile \ + docs/libcurl/Makefile \ + docs/libcurl/opts/Makefile \ + docs/cmdline-opts/Makefile \ + include/Makefile \ + include/curl/Makefile \ + src/Makefile \ + lib/Makefile \ + scripts/Makefile \ + lib/libcurl.vers \ + tests/Makefile \ + tests/config \ + tests/configurehelp.pm \ + tests/certs/Makefile \ + tests/data/Makefile \ + tests/server/Makefile \ + tests/libtest/Makefile \ + tests/unit/Makefile \ + tests/tunit/Makefile \ + tests/http/config.ini \ + tests/http/Makefile \ + projects/Makefile \ + projects/vms/Makefile \ + libcurl.pc +]) +AC_CONFIG_FILES([curl-config], [chmod +x curl-config]) +AC_OUTPUT + +SUPPORT_PROTOCOLS_LOWER=`echo "$SUPPORT_PROTOCOLS" | tr A-Z a-z` + +AC_MSG_NOTICE([Configured to build curl/libcurl: + + Host setup: ${host} + Install prefix: ${prefix} + Compiler: ${CC} + CFLAGS: ${CFLAGS} + CFLAGS extras: ${CURL_CFLAG_EXTRAS} + CPPFLAGS: ${CPPFLAGS} + LDFLAGS: ${LDFLAGS} + curl-config: ${LIBCURL_PC_LDFLAGS_PRIVATE} + LIBS: ${LIBS} + + curl version: ${CURLVERSION} + SSL: ${curl_ssl_msg} + SSH: ${curl_ssh_msg} + zlib: ${curl_zlib_msg} + brotli: ${curl_brotli_msg} + zstd: ${curl_zstd_msg} + GSS-API: ${curl_gss_msg} + GSASL: ${curl_gsasl_msg} + TLS-SRP: ${curl_tls_srp_msg} + resolver: ${curl_res_msg} + IPv6: ${curl_ipv6_msg} + Unix sockets: ${curl_unix_sockets_msg} + IDN: ${curl_idn_msg} + Build docs: ${curl_docs_msg} + Build libcurl: Shared=${enable_shared}, Static=${enable_static} + Built-in manual: ${curl_manual_msg} + --libcurl option: ${curl_libcurl_msg} + Type checking: ${curl_typecheck_msg} + Verbose errors: ${curl_verbose_msg} + Code coverage: ${curl_coverage_msg} + SSPI: ${curl_sspi_msg} + CA native: ${ca_native} + CA cert bundle: ${ca}${ca_warning} + CA cert path: ${capath}${capath_warning} + CA cert embed: ${CURL_CA_EMBED_msg} + CA fallback: ${with_ca_fallback} + LDAP: ${curl_ldap_msg} + LDAPS: ${curl_ldaps_msg} + IPFS/IPNS: ${curl_ipfs_msg} + RTSP: ${curl_rtsp_msg} + PSL: ${curl_psl_msg} + Alt-svc: ${curl_altsvc_msg} + Headers API: ${curl_headers_msg} + HSTS: ${curl_hsts_msg} + HTTP1: ${curl_h1_msg} + HTTP2: ${curl_h2_msg} + HTTP3: ${curl_h3_msg} + proxy-HTTP3: ${curl_proxy_http3_msg} + ECH: ${curl_ech_msg} + HTTPS RR: ${curl_httpsrr_msg} + SSLS-EXPORT: ${curl_ssls_export_msg} + Protocols: ${SUPPORT_PROTOCOLS_LOWER} + Features: ${SUPPORT_FEATURES} +]) + +if test -n "$experimental"; then + for a in $experimental; do + AC_MSG_WARN([$a is enabled but marked EXPERIMENTAL. Use with caution!]) + done +fi + +CURL_PREPARE_BUILDINFO +echo "[@%:@] This is a generated file. Do not edit.${curl_buildinfo}" > ./buildinfo.txt +if test -n "$CURL_BUILDINFO$CURL_CI$CI"; then + AC_MSG_NOTICE([${curl_buildinfo}]) +fi diff --git a/3rdparty/curl-8.21.0/curl-config.in b/3rdparty/curl-8.21.0/curl-config.in new file mode 100644 index 0000000000..a1c8185875 --- /dev/null +++ b/3rdparty/curl-8.21.0/curl-config.in @@ -0,0 +1,189 @@ +#!/bin/sh +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### + +# shellcheck disable=SC2006 + +prefix='@prefix@' +# Used in 'libdir' +# shellcheck disable=SC2034 +exec_prefix="@exec_prefix@" +# shellcheck disable=SC2034 +includedir="@includedir@" + +usage() +{ + cat <&2 + exit 1 + fi + ;; + + --configure) + echo @CONFIGURE_OPTIONS@ + ;; + + *) + echo "unknown option: $1" + usage 1 + ;; + esac + shift +done + +exit 0 diff --git a/3rdparty/curl-8.21.0/depcomp b/3rdparty/curl-8.21.0/depcomp new file mode 100755 index 0000000000..715e34311e --- /dev/null +++ b/3rdparty/curl-8.21.0/depcomp @@ -0,0 +1,791 @@ +#! /bin/sh +# depcomp - compile a program generating dependencies as side-effects + +scriptversion=2018-03-07.03; # UTC + +# Copyright (C) 1999-2021 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2, or (at your option) +# any later version. + +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. + +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . + +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program that contains a +# configuration script generated by Autoconf, you may include it under +# the same distribution terms that you use for the rest of that program. + +# Originally written by Alexandre Oliva . + +case $1 in + '') + echo "$0: No command. Try '$0 --help' for more information." 1>&2 + exit 1; + ;; + -h | --h*) + cat <<\EOF +Usage: depcomp [--help] [--version] PROGRAM [ARGS] + +Run PROGRAMS ARGS to compile a file, generating dependencies +as side-effects. + +Environment variables: + depmode Dependency tracking mode. + source Source file read by 'PROGRAMS ARGS'. + object Object file output by 'PROGRAMS ARGS'. + DEPDIR directory where to store dependencies. + depfile Dependency file to output. + tmpdepfile Temporary file to use when outputting dependencies. + libtool Whether libtool is used (yes/no). + +Report bugs to . +EOF + exit $? + ;; + -v | --v*) + echo "depcomp $scriptversion" + exit $? + ;; +esac + +# Get the directory component of the given path, and save it in the +# global variables '$dir'. Note that this directory component will +# be either empty or ending with a '/' character. This is deliberate. +set_dir_from () +{ + case $1 in + */*) dir=`echo "$1" | sed -e 's|/[^/]*$|/|'`;; + *) dir=;; + esac +} + +# Get the suffix-stripped basename of the given path, and save it the +# global variable '$base'. +set_base_from () +{ + base=`echo "$1" | sed -e 's|^.*/||' -e 's/\.[^.]*$//'` +} + +# If no dependency file was actually created by the compiler invocation, +# we still have to create a dummy depfile, to avoid errors with the +# Makefile "include basename.Plo" scheme. +make_dummy_depfile () +{ + echo "#dummy" > "$depfile" +} + +# Factor out some common post-processing of the generated depfile. +# Requires the auxiliary global variable '$tmpdepfile' to be set. +aix_post_process_depfile () +{ + # If the compiler actually managed to produce a dependency file, + # post-process it. + if test -f "$tmpdepfile"; then + # Each line is of the form 'foo.o: dependency.h'. + # Do two passes, one to just change these to + # $object: dependency.h + # and one to simply output + # dependency.h: + # which is needed to avoid the deleted-header problem. + { sed -e "s,^.*\.[$lower]*:,$object:," < "$tmpdepfile" + sed -e "s,^.*\.[$lower]*:[$tab ]*,," -e 's,$,:,' < "$tmpdepfile" + } > "$depfile" + rm -f "$tmpdepfile" + else + make_dummy_depfile + fi +} + +# A tabulation character. +tab=' ' +# A newline character. +nl=' +' +# Character ranges might be problematic outside the C locale. +# These definitions help. +upper=ABCDEFGHIJKLMNOPQRSTUVWXYZ +lower=abcdefghijklmnopqrstuvwxyz +digits=0123456789 +alpha=${upper}${lower} + +if test -z "$depmode" || test -z "$source" || test -z "$object"; then + echo "depcomp: Variables source, object and depmode must be set" 1>&2 + exit 1 +fi + +# Dependencies for sub/bar.o or sub/bar.obj go into sub/.deps/bar.Po. +depfile=${depfile-`echo "$object" | + sed 's|[^\\/]*$|'${DEPDIR-.deps}'/&|;s|\.\([^.]*\)$|.P\1|;s|Pobj$|Po|'`} +tmpdepfile=${tmpdepfile-`echo "$depfile" | sed 's/\.\([^.]*\)$/.T\1/'`} + +rm -f "$tmpdepfile" + +# Avoid interferences from the environment. +gccflag= dashmflag= + +# Some modes work just like other modes, but use different flags. We +# parameterize here, but still list the modes in the big case below, +# to make depend.m4 easier to write. Note that we *cannot* use a case +# here, because this file can only contain one case statement. +if test "$depmode" = hp; then + # HP compiler uses -M and no extra arg. + gccflag=-M + depmode=gcc +fi + +if test "$depmode" = dashXmstdout; then + # This is just like dashmstdout with a different argument. + dashmflag=-xM + depmode=dashmstdout +fi + +cygpath_u="cygpath -u -f -" +if test "$depmode" = msvcmsys; then + # This is just like msvisualcpp but w/o cygpath translation. + # Just convert the backslash-escaped backslashes to single forward + # slashes to satisfy depend.m4 + cygpath_u='sed s,\\\\,/,g' + depmode=msvisualcpp +fi + +if test "$depmode" = msvc7msys; then + # This is just like msvc7 but w/o cygpath translation. + # Just convert the backslash-escaped backslashes to single forward + # slashes to satisfy depend.m4 + cygpath_u='sed s,\\\\,/,g' + depmode=msvc7 +fi + +if test "$depmode" = xlc; then + # IBM C/C++ Compilers xlc/xlC can output gcc-like dependency information. + gccflag=-qmakedep=gcc,-MF + depmode=gcc +fi + +case "$depmode" in +gcc3) +## gcc 3 implements dependency tracking that does exactly what +## we want. Yay! Note: for some reason libtool 1.4 doesn't like +## it if -MD -MP comes after the -MF stuff. Hmm. +## Unfortunately, FreeBSD c89 acceptance of flags depends upon +## the command line argument order; so add the flags where they +## appear in depend2.am. Note that the slowdown incurred here +## affects only configure: in makefiles, %FASTDEP% shortcuts this. + for arg + do + case $arg in + -c) set fnord "$@" -MT "$object" -MD -MP -MF "$tmpdepfile" "$arg" ;; + *) set fnord "$@" "$arg" ;; + esac + shift # fnord + shift # $arg + done + "$@" + stat=$? + if test $stat -ne 0; then + rm -f "$tmpdepfile" + exit $stat + fi + mv "$tmpdepfile" "$depfile" + ;; + +gcc) +## Note that this doesn't just cater to obsosete pre-3.x GCC compilers. +## but also to in-use compilers like IMB xlc/xlC and the HP C compiler. +## (see the conditional assignment to $gccflag above). +## There are various ways to get dependency output from gcc. Here's +## why we pick this rather obscure method: +## - Don't want to use -MD because we'd like the dependencies to end +## up in a subdir. Having to rename by hand is ugly. +## (We might end up doing this anyway to support other compilers.) +## - The DEPENDENCIES_OUTPUT environment variable makes gcc act like +## -MM, not -M (despite what the docs say). Also, it might not be +## supported by the other compilers which use the 'gcc' depmode. +## - Using -M directly means running the compiler twice (even worse +## than renaming). + if test -z "$gccflag"; then + gccflag=-MD, + fi + "$@" -Wp,"$gccflag$tmpdepfile" + stat=$? + if test $stat -ne 0; then + rm -f "$tmpdepfile" + exit $stat + fi + rm -f "$depfile" + echo "$object : \\" > "$depfile" + # The second -e expression handles DOS-style file names with drive + # letters. + sed -e 's/^[^:]*: / /' \ + -e 's/^['$alpha']:\/[^:]*: / /' < "$tmpdepfile" >> "$depfile" +## This next piece of magic avoids the "deleted header file" problem. +## The problem is that when a header file which appears in a .P file +## is deleted, the dependency causes make to die (because there is +## typically no way to rebuild the header). We avoid this by adding +## dummy dependencies for each header file. Too bad gcc doesn't do +## this for us directly. +## Some versions of gcc put a space before the ':'. On the theory +## that the space means something, we add a space to the output as +## well. hp depmode also adds that space, but also prefixes the VPATH +## to the object. Take care to not repeat it in the output. +## Some versions of the HPUX 10.20 sed can't process this invocation +## correctly. Breaking it into two sed invocations is a workaround. + tr ' ' "$nl" < "$tmpdepfile" \ + | sed -e 's/^\\$//' -e '/^$/d' -e "s|.*$object$||" -e '/:$/d' \ + | sed -e 's/$/ :/' >> "$depfile" + rm -f "$tmpdepfile" + ;; + +hp) + # This case exists only to let depend.m4 do its work. It works by + # looking at the text of this script. This case will never be run, + # since it is checked for above. + exit 1 + ;; + +sgi) + if test "$libtool" = yes; then + "$@" "-Wp,-MDupdate,$tmpdepfile" + else + "$@" -MDupdate "$tmpdepfile" + fi + stat=$? + if test $stat -ne 0; then + rm -f "$tmpdepfile" + exit $stat + fi + rm -f "$depfile" + + if test -f "$tmpdepfile"; then # yes, the sourcefile depend on other files + echo "$object : \\" > "$depfile" + # Clip off the initial element (the dependent). Don't try to be + # clever and replace this with sed code, as IRIX sed won't handle + # lines with more than a fixed number of characters (4096 in + # IRIX 6.2 sed, 8192 in IRIX 6.5). We also remove comment lines; + # the IRIX cc adds comments like '#:fec' to the end of the + # dependency line. + tr ' ' "$nl" < "$tmpdepfile" \ + | sed -e 's/^.*\.o://' -e 's/#.*$//' -e '/^$/ d' \ + | tr "$nl" ' ' >> "$depfile" + echo >> "$depfile" + # The second pass generates a dummy entry for each header file. + tr ' ' "$nl" < "$tmpdepfile" \ + | sed -e 's/^.*\.o://' -e 's/#.*$//' -e '/^$/ d' -e 's/$/:/' \ + >> "$depfile" + else + make_dummy_depfile + fi + rm -f "$tmpdepfile" + ;; + +xlc) + # This case exists only to let depend.m4 do its work. It works by + # looking at the text of this script. This case will never be run, + # since it is checked for above. + exit 1 + ;; + +aix) + # The C for AIX Compiler uses -M and outputs the dependencies + # in a .u file. In older versions, this file always lives in the + # current directory. Also, the AIX compiler puts '$object:' at the + # start of each line; $object doesn't have directory information. + # Version 6 uses the directory in both cases. + set_dir_from "$object" + set_base_from "$object" + if test "$libtool" = yes; then + tmpdepfile1=$dir$base.u + tmpdepfile2=$base.u + tmpdepfile3=$dir.libs/$base.u + "$@" -Wc,-M + else + tmpdepfile1=$dir$base.u + tmpdepfile2=$dir$base.u + tmpdepfile3=$dir$base.u + "$@" -M + fi + stat=$? + if test $stat -ne 0; then + rm -f "$tmpdepfile1" "$tmpdepfile2" "$tmpdepfile3" + exit $stat + fi + + for tmpdepfile in "$tmpdepfile1" "$tmpdepfile2" "$tmpdepfile3" + do + test -f "$tmpdepfile" && break + done + aix_post_process_depfile + ;; + +tcc) + # tcc (Tiny C Compiler) understand '-MD -MF file' since version 0.9.26 + # FIXME: That version still under development at the moment of writing. + # Make that this statement remains true also for stable, released + # versions. + # It will wrap lines (doesn't matter whether long or short) with a + # trailing '\', as in: + # + # foo.o : \ + # foo.c \ + # foo.h \ + # + # It will put a trailing '\' even on the last line, and will use leading + # spaces rather than leading tabs (at least since its commit 0394caf7 + # "Emit spaces for -MD"). + "$@" -MD -MF "$tmpdepfile" + stat=$? + if test $stat -ne 0; then + rm -f "$tmpdepfile" + exit $stat + fi + rm -f "$depfile" + # Each non-empty line is of the form 'foo.o : \' or ' dep.h \'. + # We have to change lines of the first kind to '$object: \'. + sed -e "s|.*:|$object :|" < "$tmpdepfile" > "$depfile" + # And for each line of the second kind, we have to emit a 'dep.h:' + # dummy dependency, to avoid the deleted-header problem. + sed -n -e 's|^ *\(.*\) *\\$|\1:|p' < "$tmpdepfile" >> "$depfile" + rm -f "$tmpdepfile" + ;; + +## The order of this option in the case statement is important, since the +## shell code in configure will try each of these formats in the order +## listed in this file. A plain '-MD' option would be understood by many +## compilers, so we must ensure this comes after the gcc and icc options. +pgcc) + # Portland's C compiler understands '-MD'. + # Will always output deps to 'file.d' where file is the root name of the + # source file under compilation, even if file resides in a subdirectory. + # The object file name does not affect the name of the '.d' file. + # pgcc 10.2 will output + # foo.o: sub/foo.c sub/foo.h + # and will wrap long lines using '\' : + # foo.o: sub/foo.c ... \ + # sub/foo.h ... \ + # ... + set_dir_from "$object" + # Use the source, not the object, to determine the base name, since + # that's sadly what pgcc will do too. + set_base_from "$source" + tmpdepfile=$base.d + + # For projects that build the same source file twice into different object + # files, the pgcc approach of using the *source* file root name can cause + # problems in parallel builds. Use a locking strategy to avoid stomping on + # the same $tmpdepfile. + lockdir=$base.d-lock + trap " + echo '$0: caught signal, cleaning up...' >&2 + rmdir '$lockdir' + exit 1 + " 1 2 13 15 + numtries=100 + i=$numtries + while test $i -gt 0; do + # mkdir is a portable test-and-set. + if mkdir "$lockdir" 2>/dev/null; then + # This process acquired the lock. + "$@" -MD + stat=$? + # Release the lock. + rmdir "$lockdir" + break + else + # If the lock is being held by a different process, wait + # until the winning process is done or we timeout. + while test -d "$lockdir" && test $i -gt 0; do + sleep 1 + i=`expr $i - 1` + done + fi + i=`expr $i - 1` + done + trap - 1 2 13 15 + if test $i -le 0; then + echo "$0: failed to acquire lock after $numtries attempts" >&2 + echo "$0: check lockdir '$lockdir'" >&2 + exit 1 + fi + + if test $stat -ne 0; then + rm -f "$tmpdepfile" + exit $stat + fi + rm -f "$depfile" + # Each line is of the form `foo.o: dependent.h', + # or `foo.o: dep1.h dep2.h \', or ` dep3.h dep4.h \'. + # Do two passes, one to just change these to + # `$object: dependent.h' and one to simply `dependent.h:'. + sed "s,^[^:]*:,$object :," < "$tmpdepfile" > "$depfile" + # Some versions of the HPUX 10.20 sed can't process this invocation + # correctly. Breaking it into two sed invocations is a workaround. + sed 's,^[^:]*: \(.*\)$,\1,;s/^\\$//;/^$/d;/:$/d' < "$tmpdepfile" \ + | sed -e 's/$/ :/' >> "$depfile" + rm -f "$tmpdepfile" + ;; + +hp2) + # The "hp" stanza above does not work with aCC (C++) and HP's ia64 + # compilers, which have integrated preprocessors. The correct option + # to use with these is +Maked; it writes dependencies to a file named + # 'foo.d', which lands next to the object file, wherever that + # happens to be. + # Much of this is similar to the tru64 case; see comments there. + set_dir_from "$object" + set_base_from "$object" + if test "$libtool" = yes; then + tmpdepfile1=$dir$base.d + tmpdepfile2=$dir.libs/$base.d + "$@" -Wc,+Maked + else + tmpdepfile1=$dir$base.d + tmpdepfile2=$dir$base.d + "$@" +Maked + fi + stat=$? + if test $stat -ne 0; then + rm -f "$tmpdepfile1" "$tmpdepfile2" + exit $stat + fi + + for tmpdepfile in "$tmpdepfile1" "$tmpdepfile2" + do + test -f "$tmpdepfile" && break + done + if test -f "$tmpdepfile"; then + sed -e "s,^.*\.[$lower]*:,$object:," "$tmpdepfile" > "$depfile" + # Add 'dependent.h:' lines. + sed -ne '2,${ + s/^ *// + s/ \\*$// + s/$/:/ + p + }' "$tmpdepfile" >> "$depfile" + else + make_dummy_depfile + fi + rm -f "$tmpdepfile" "$tmpdepfile2" + ;; + +tru64) + # The Tru64 compiler uses -MD to generate dependencies as a side + # effect. 'cc -MD -o foo.o ...' puts the dependencies into 'foo.o.d'. + # At least on Alpha/Redhat 6.1, Compaq CCC V6.2-504 seems to put + # dependencies in 'foo.d' instead, so we check for that too. + # Subdirectories are respected. + set_dir_from "$object" + set_base_from "$object" + + if test "$libtool" = yes; then + # Libtool generates 2 separate objects for the 2 libraries. These + # two compilations output dependencies in $dir.libs/$base.o.d and + # in $dir$base.o.d. We have to check for both files, because + # one of the two compilations can be disabled. We should prefer + # $dir$base.o.d over $dir.libs/$base.o.d because the latter is + # automatically cleaned when .libs/ is deleted, while ignoring + # the former would cause a distcleancheck panic. + tmpdepfile1=$dir$base.o.d # libtool 1.5 + tmpdepfile2=$dir.libs/$base.o.d # Likewise. + tmpdepfile3=$dir.libs/$base.d # Compaq CCC V6.2-504 + "$@" -Wc,-MD + else + tmpdepfile1=$dir$base.d + tmpdepfile2=$dir$base.d + tmpdepfile3=$dir$base.d + "$@" -MD + fi + + stat=$? + if test $stat -ne 0; then + rm -f "$tmpdepfile1" "$tmpdepfile2" "$tmpdepfile3" + exit $stat + fi + + for tmpdepfile in "$tmpdepfile1" "$tmpdepfile2" "$tmpdepfile3" + do + test -f "$tmpdepfile" && break + done + # Same post-processing that is required for AIX mode. + aix_post_process_depfile + ;; + +msvc7) + if test "$libtool" = yes; then + showIncludes=-Wc,-showIncludes + else + showIncludes=-showIncludes + fi + "$@" $showIncludes > "$tmpdepfile" + stat=$? + grep -v '^Note: including file: ' "$tmpdepfile" + if test $stat -ne 0; then + rm -f "$tmpdepfile" + exit $stat + fi + rm -f "$depfile" + echo "$object : \\" > "$depfile" + # The first sed program below extracts the file names and escapes + # backslashes for cygpath. The second sed program outputs the file + # name when reading, but also accumulates all include files in the + # hold buffer in order to output them again at the end. This only + # works with sed implementations that can handle large buffers. + sed < "$tmpdepfile" -n ' +/^Note: including file: *\(.*\)/ { + s//\1/ + s/\\/\\\\/g + p +}' | $cygpath_u | sort -u | sed -n ' +s/ /\\ /g +s/\(.*\)/'"$tab"'\1 \\/p +s/.\(.*\) \\/\1:/ +H +$ { + s/.*/'"$tab"'/ + G + p +}' >> "$depfile" + echo >> "$depfile" # make sure the fragment doesn't end with a backslash + rm -f "$tmpdepfile" + ;; + +msvc7msys) + # This case exists only to let depend.m4 do its work. It works by + # looking at the text of this script. This case will never be run, + # since it is checked for above. + exit 1 + ;; + +#nosideeffect) + # This comment above is used by automake to tell side-effect + # dependency tracking mechanisms from slower ones. + +dashmstdout) + # Important note: in order to support this mode, a compiler *must* + # always write the preprocessed file to stdout, regardless of -o. + "$@" || exit $? + + # Remove the call to Libtool. + if test "$libtool" = yes; then + while test "X$1" != 'X--mode=compile'; do + shift + done + shift + fi + + # Remove '-o $object'. + IFS=" " + for arg + do + case $arg in + -o) + shift + ;; + $object) + shift + ;; + *) + set fnord "$@" "$arg" + shift # fnord + shift # $arg + ;; + esac + done + + test -z "$dashmflag" && dashmflag=-M + # Require at least two characters before searching for ':' + # in the target name. This is to cope with DOS-style filenames: + # a dependency such as 'c:/foo/bar' could be seen as target 'c' otherwise. + "$@" $dashmflag | + sed "s|^[$tab ]*[^:$tab ][^:][^:]*:[$tab ]*|$object: |" > "$tmpdepfile" + rm -f "$depfile" + cat < "$tmpdepfile" > "$depfile" + # Some versions of the HPUX 10.20 sed can't process this sed invocation + # correctly. Breaking it into two sed invocations is a workaround. + tr ' ' "$nl" < "$tmpdepfile" \ + | sed -e 's/^\\$//' -e '/^$/d' -e '/:$/d' \ + | sed -e 's/$/ :/' >> "$depfile" + rm -f "$tmpdepfile" + ;; + +dashXmstdout) + # This case only exists to satisfy depend.m4. It is never actually + # run, as this mode is specially recognized in the preamble. + exit 1 + ;; + +makedepend) + "$@" || exit $? + # Remove any Libtool call + if test "$libtool" = yes; then + while test "X$1" != 'X--mode=compile'; do + shift + done + shift + fi + # X makedepend + shift + cleared=no eat=no + for arg + do + case $cleared in + no) + set ""; shift + cleared=yes ;; + esac + if test $eat = yes; then + eat=no + continue + fi + case "$arg" in + -D*|-I*) + set fnord "$@" "$arg"; shift ;; + # Strip any option that makedepend may not understand. Remove + # the object too, otherwise makedepend will parse it as a source file. + -arch) + eat=yes ;; + -*|$object) + ;; + *) + set fnord "$@" "$arg"; shift ;; + esac + done + obj_suffix=`echo "$object" | sed 's/^.*\././'` + touch "$tmpdepfile" + ${MAKEDEPEND-makedepend} -o"$obj_suffix" -f"$tmpdepfile" "$@" + rm -f "$depfile" + # makedepend may prepend the VPATH from the source file name to the object. + # No need to regex-escape $object, excess matching of '.' is harmless. + sed "s|^.*\($object *:\)|\1|" "$tmpdepfile" > "$depfile" + # Some versions of the HPUX 10.20 sed can't process the last invocation + # correctly. Breaking it into two sed invocations is a workaround. + sed '1,2d' "$tmpdepfile" \ + | tr ' ' "$nl" \ + | sed -e 's/^\\$//' -e '/^$/d' -e '/:$/d' \ + | sed -e 's/$/ :/' >> "$depfile" + rm -f "$tmpdepfile" "$tmpdepfile".bak + ;; + +cpp) + # Important note: in order to support this mode, a compiler *must* + # always write the preprocessed file to stdout. + "$@" || exit $? + + # Remove the call to Libtool. + if test "$libtool" = yes; then + while test "X$1" != 'X--mode=compile'; do + shift + done + shift + fi + + # Remove '-o $object'. + IFS=" " + for arg + do + case $arg in + -o) + shift + ;; + $object) + shift + ;; + *) + set fnord "$@" "$arg" + shift # fnord + shift # $arg + ;; + esac + done + + "$@" -E \ + | sed -n -e '/^# [0-9][0-9]* "\([^"]*\)".*/ s:: \1 \\:p' \ + -e '/^#line [0-9][0-9]* "\([^"]*\)".*/ s:: \1 \\:p' \ + | sed '$ s: \\$::' > "$tmpdepfile" + rm -f "$depfile" + echo "$object : \\" > "$depfile" + cat < "$tmpdepfile" >> "$depfile" + sed < "$tmpdepfile" '/^$/d;s/^ //;s/ \\$//;s/$/ :/' >> "$depfile" + rm -f "$tmpdepfile" + ;; + +msvisualcpp) + # Important note: in order to support this mode, a compiler *must* + # always write the preprocessed file to stdout. + "$@" || exit $? + + # Remove the call to Libtool. + if test "$libtool" = yes; then + while test "X$1" != 'X--mode=compile'; do + shift + done + shift + fi + + IFS=" " + for arg + do + case "$arg" in + -o) + shift + ;; + $object) + shift + ;; + "-Gm"|"/Gm"|"-Gi"|"/Gi"|"-ZI"|"/ZI") + set fnord "$@" + shift + shift + ;; + *) + set fnord "$@" "$arg" + shift + shift + ;; + esac + done + "$@" -E 2>/dev/null | + sed -n '/^#line [0-9][0-9]* "\([^"]*\)"/ s::\1:p' | $cygpath_u | sort -u > "$tmpdepfile" + rm -f "$depfile" + echo "$object : \\" > "$depfile" + sed < "$tmpdepfile" -n -e 's% %\\ %g' -e '/^\(.*\)$/ s::'"$tab"'\1 \\:p' >> "$depfile" + echo "$tab" >> "$depfile" + sed < "$tmpdepfile" -n -e 's% %\\ %g' -e '/^\(.*\)$/ s::\1\::p' >> "$depfile" + rm -f "$tmpdepfile" + ;; + +msvcmsys) + # This case exists only to let depend.m4 do its work. It works by + # looking at the text of this script. This case will never be run, + # since it is checked for above. + exit 1 + ;; + +none) + exec "$@" + ;; + +*) + echo "Unknown depmode $depmode" 1>&2 + exit 1 + ;; +esac + +exit 0 + +# Local Variables: +# mode: shell-script +# sh-indentation: 2 +# eval: (add-hook 'before-save-hook 'time-stamp) +# time-stamp-start: "scriptversion=" +# time-stamp-format: "%:y-%02m-%02d.%02H" +# time-stamp-time-zone: "UTC0" +# time-stamp-end: "; # UTC" +# End: diff --git a/3rdparty/curl-8.21.0/include/Makefile.am b/3rdparty/curl-8.21.0/include/Makefile.am new file mode 100644 index 0000000000..d65bfeaa0f --- /dev/null +++ b/3rdparty/curl-8.21.0/include/Makefile.am @@ -0,0 +1,28 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +SUBDIRS = curl + +EXTRA_DIST = README.md + +AUTOMAKE_OPTIONS = foreign no-dependencies diff --git a/3rdparty/curl-8.21.0/include/Makefile.in b/3rdparty/curl-8.21.0/include/Makefile.in new file mode 100644 index 0000000000..66e7e27cb5 --- /dev/null +++ b/3rdparty/curl-8.21.0/include/Makefile.in @@ -0,0 +1,715 @@ +# Makefile.in generated by automake 1.16.5 from Makefile.am. +# @configure_input@ + +# Copyright (C) 1994-2021 Free Software Foundation, Inc. + +# This Makefile.in is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY, to the extent permitted by law; without +# even the implied warranty of MERCHANTABILITY or FITNESS FOR A +# PARTICULAR PURPOSE. + +@SET_MAKE@ +VPATH = @srcdir@ +am__is_gnu_make = { \ + if test -z '$(MAKELEVEL)'; then \ + false; \ + elif test -n '$(MAKE_HOST)'; then \ + true; \ + elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \ + true; \ + else \ + false; \ + fi; \ +} +am__make_running_with_option = \ + case $${target_option-} in \ + ?) ;; \ + *) echo "am__make_running_with_option: internal error: invalid" \ + "target option '$${target_option-}' specified" >&2; \ + exit 1;; \ + esac; \ + has_opt=no; \ + sane_makeflags=$$MAKEFLAGS; \ + if $(am__is_gnu_make); then \ + sane_makeflags=$$MFLAGS; \ + else \ + case $$MAKEFLAGS in \ + *\\[\ \ ]*) \ + bs=\\; \ + sane_makeflags=`printf '%s\n' "$$MAKEFLAGS" \ + | sed "s/$$bs$$bs[$$bs $$bs ]*//g"`;; \ + esac; \ + fi; \ + skip_next=no; \ + strip_trailopt () \ + { \ + flg=`printf '%s\n' "$$flg" | sed "s/$$1.*$$//"`; \ + }; \ + for flg in $$sane_makeflags; do \ + test $$skip_next = yes && { skip_next=no; continue; }; \ + case $$flg in \ + *=*|--*) continue;; \ + -*I) strip_trailopt 'I'; skip_next=yes;; \ + -*I?*) strip_trailopt 'I';; \ + -*O) strip_trailopt 'O'; skip_next=yes;; \ + -*O?*) strip_trailopt 'O';; \ + -*l) strip_trailopt 'l'; skip_next=yes;; \ + -*l?*) strip_trailopt 'l';; \ + -[dEDm]) skip_next=yes;; \ + -[JT]) skip_next=yes;; \ + esac; \ + case $$flg in \ + *$$target_option*) has_opt=yes; break;; \ + esac; \ + done; \ + test $$has_opt = yes +am__make_dryrun = (target_option=n; $(am__make_running_with_option)) +am__make_keepgoing = (target_option=k; $(am__make_running_with_option)) +pkgdatadir = $(datadir)/@PACKAGE@ +pkgincludedir = $(includedir)/@PACKAGE@ +pkglibdir = $(libdir)/@PACKAGE@ +pkglibexecdir = $(libexecdir)/@PACKAGE@ +am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd +install_sh_DATA = $(install_sh) -c -m 644 +install_sh_PROGRAM = $(install_sh) -c +install_sh_SCRIPT = $(install_sh) -c +INSTALL_HEADER = $(INSTALL_DATA) +transform = $(program_transform_name) +NORMAL_INSTALL = : +PRE_INSTALL = : +POST_INSTALL = : +NORMAL_UNINSTALL = : +PRE_UNINSTALL = : +POST_UNINSTALL = : +build_triplet = @build@ +host_triplet = @host@ +subdir = include +ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 +am__aclocal_m4_deps = $(top_srcdir)/m4/curl-amissl.m4 \ + $(top_srcdir)/m4/curl-apple-sectrust.m4 \ + $(top_srcdir)/m4/curl-compilers.m4 \ + $(top_srcdir)/m4/curl-confopts.m4 \ + $(top_srcdir)/m4/curl-functions.m4 \ + $(top_srcdir)/m4/curl-gnutls.m4 \ + $(top_srcdir)/m4/curl-mbedtls.m4 \ + $(top_srcdir)/m4/curl-openssl.m4 \ + $(top_srcdir)/m4/curl-override.m4 \ + $(top_srcdir)/m4/curl-reentrant.m4 \ + $(top_srcdir)/m4/curl-rustls.m4 \ + $(top_srcdir)/m4/curl-schannel.m4 \ + $(top_srcdir)/m4/curl-sysconfig.m4 \ + $(top_srcdir)/m4/curl-wolfssl.m4 $(top_srcdir)/m4/libtool.m4 \ + $(top_srcdir)/m4/ltoptions.m4 $(top_srcdir)/m4/ltsugar.m4 \ + $(top_srcdir)/m4/ltversion.m4 $(top_srcdir)/m4/lt~obsolete.m4 \ + $(top_srcdir)/m4/xc-am-iface.m4 \ + $(top_srcdir)/m4/xc-cc-check.m4 \ + $(top_srcdir)/m4/xc-lt-iface.m4 \ + $(top_srcdir)/m4/xc-val-flgs.m4 \ + $(top_srcdir)/m4/zz40-xc-ovr.m4 \ + $(top_srcdir)/m4/zz50-xc-ovr.m4 $(top_srcdir)/acinclude.m4 \ + $(top_srcdir)/configure.ac +am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ + $(ACLOCAL_M4) +DIST_COMMON = $(srcdir)/Makefile.am $(am__DIST_COMMON) +mkinstalldirs = $(install_sh) -d +CONFIG_HEADER = $(top_builddir)/lib/curl_config.h +CONFIG_CLEAN_FILES = +CONFIG_CLEAN_VPATH_FILES = +AM_V_P = $(am__v_P_@AM_V@) +am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) +am__v_P_0 = false +am__v_P_1 = : +AM_V_GEN = $(am__v_GEN_@AM_V@) +am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@) +am__v_GEN_0 = @echo " GEN " $@; +am__v_GEN_1 = +AM_V_at = $(am__v_at_@AM_V@) +am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) +am__v_at_0 = @ +am__v_at_1 = +depcomp = +am__maybe_remake_depfiles = +SOURCES = +DIST_SOURCES = +RECURSIVE_TARGETS = all-recursive check-recursive cscopelist-recursive \ + ctags-recursive dvi-recursive html-recursive info-recursive \ + install-data-recursive install-dvi-recursive \ + install-exec-recursive install-html-recursive \ + install-info-recursive install-pdf-recursive \ + install-ps-recursive install-recursive installcheck-recursive \ + installdirs-recursive pdf-recursive ps-recursive \ + tags-recursive uninstall-recursive +am__can_run_installinfo = \ + case $$AM_UPDATE_INFO_DIR in \ + n|no|NO) false;; \ + *) (install-info --version) >/dev/null 2>&1;; \ + esac +RECURSIVE_CLEAN_TARGETS = mostlyclean-recursive clean-recursive \ + distclean-recursive maintainer-clean-recursive +am__recursive_targets = \ + $(RECURSIVE_TARGETS) \ + $(RECURSIVE_CLEAN_TARGETS) \ + $(am__extra_recursive_targets) +AM_RECURSIVE_TARGETS = $(am__recursive_targets:-recursive=) TAGS CTAGS \ + distdir distdir-am +am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) $(LISP) +# Read a list of newline-separated strings from the standard input, +# and print each of them once, without duplicates. Input order is +# *not* preserved. +am__uniquify_input = $(AWK) '\ + BEGIN { nonempty = 0; } \ + { items[$$0] = 1; nonempty = 1; } \ + END { if (nonempty) { for (i in items) print i; }; } \ +' +# Make sure the list of sources is unique. This is necessary because, +# e.g., the same source file might be shared among _SOURCES variables +# for different programs/libraries. +am__define_uniq_tagged_files = \ + list='$(am__tagged_files)'; \ + unique=`for i in $$list; do \ + if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ + done | $(am__uniquify_input)` +DIST_SUBDIRS = $(SUBDIRS) +am__DIST_COMMON = $(srcdir)/Makefile.in README.md +DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) +am__relativize = \ + dir0=`pwd`; \ + sed_first='s,^\([^/]*\)/.*$$,\1,'; \ + sed_rest='s,^[^/]*/*,,'; \ + sed_last='s,^.*/\([^/]*\)$$,\1,'; \ + sed_butlast='s,/*[^/]*$$,,'; \ + while test -n "$$dir1"; do \ + first=`echo "$$dir1" | sed -e "$$sed_first"`; \ + if test "$$first" != "."; then \ + if test "$$first" = ".."; then \ + dir2=`echo "$$dir0" | sed -e "$$sed_last"`/"$$dir2"; \ + dir0=`echo "$$dir0" | sed -e "$$sed_butlast"`; \ + else \ + first2=`echo "$$dir2" | sed -e "$$sed_first"`; \ + if test "$$first2" = "$$first"; then \ + dir2=`echo "$$dir2" | sed -e "$$sed_rest"`; \ + else \ + dir2="../$$dir2"; \ + fi; \ + dir0="$$dir0"/"$$first"; \ + fi; \ + fi; \ + dir1=`echo "$$dir1" | sed -e "$$sed_rest"`; \ + done; \ + reldir="$$dir2" +ACLOCAL = @ACLOCAL@ +AMTAR = @AMTAR@ +AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ +APXS = @APXS@ +AR = @AR@ +AR_FLAGS = @AR_FLAGS@ +AS = @AS@ +AUTOCONF = @AUTOCONF@ +AUTOHEADER = @AUTOHEADER@ +AUTOMAKE = @AUTOMAKE@ +AWK = @AWK@ +BLANK_AT_MAKETIME = @BLANK_AT_MAKETIME@ +CADDY = @CADDY@ +CC = @CC@ +CCDEPMODE = @CCDEPMODE@ +CFLAGS = @CFLAGS@ +CFLAG_CURL_SYMBOL_HIDING = @CFLAG_CURL_SYMBOL_HIDING@ +CLANG_TIDY = @CLANG_TIDY@ +CONFIGURE_OPTIONS = @CONFIGURE_OPTIONS@ +CPP = @CPP@ +CPPFLAGS = @CPPFLAGS@ +CSCOPE = @CSCOPE@ +CTAGS = @CTAGS@ +CURLVERSION = @CURLVERSION@ +CURL_CA_BUNDLE = @CURL_CA_BUNDLE@ +CURL_CA_EMBED = @CURL_CA_EMBED@ +CURL_CFLAG_EXTRAS = @CURL_CFLAG_EXTRAS@ +CURL_CPP = @CURL_CPP@ +CURL_LIBCURL_VERSIONED_SYMBOLS_PREFIX = @CURL_LIBCURL_VERSIONED_SYMBOLS_PREFIX@ +CURL_LIBCURL_VERSIONED_SYMBOLS_SONAME = @CURL_LIBCURL_VERSIONED_SYMBOLS_SONAME@ +CURL_NETWORK_AND_TIME_LIBS = @CURL_NETWORK_AND_TIME_LIBS@ +CYGPATH_W = @CYGPATH_W@ +DANTED = @DANTED@ +DEFS = @DEFS@ +DEPDIR = @DEPDIR@ +DLLTOOL = @DLLTOOL@ +DSYMUTIL = @DSYMUTIL@ +DUMPBIN = @DUMPBIN@ +ECHO_C = @ECHO_C@ +ECHO_N = @ECHO_N@ +ECHO_T = @ECHO_T@ +EGREP = @EGREP@ +ENABLE_SHARED = @ENABLE_SHARED@ +ENABLE_STATIC = @ENABLE_STATIC@ +ETAGS = @ETAGS@ +EXEEXT = @EXEEXT@ +FGREP = @FGREP@ +FILECMD = @FILECMD@ +FISH_FUNCTIONS_DIR = @FISH_FUNCTIONS_DIR@ +GCOV = @GCOV@ +GREP = @GREP@ +H2O = @H2O@ +HAVE_LIBZ = @HAVE_LIBZ@ +HTTPD = @HTTPD@ +HTTPD_NGHTTPX = @HTTPD_NGHTTPX@ +INSTALL = @INSTALL@ +INSTALL_DATA = @INSTALL_DATA@ +INSTALL_PROGRAM = @INSTALL_PROGRAM@ +INSTALL_SCRIPT = @INSTALL_SCRIPT@ +INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ +LCOV = @LCOV@ +LD = @LD@ +LDFLAGS = @LDFLAGS@ +LIBCURL_PC_CFLAGS = @LIBCURL_PC_CFLAGS@ +LIBCURL_PC_CFLAGS_PRIVATE = @LIBCURL_PC_CFLAGS_PRIVATE@ +LIBCURL_PC_LDFLAGS_PRIVATE = @LIBCURL_PC_LDFLAGS_PRIVATE@ +LIBCURL_PC_LIBS = @LIBCURL_PC_LIBS@ +LIBCURL_PC_LIBS_PRIVATE = @LIBCURL_PC_LIBS_PRIVATE@ +LIBCURL_PC_REQUIRES = @LIBCURL_PC_REQUIRES@ +LIBCURL_PC_REQUIRES_PRIVATE = @LIBCURL_PC_REQUIRES_PRIVATE@ +LIBOBJS = @LIBOBJS@ +LIBS = @LIBS@ +LIBTOOL = @LIBTOOL@ +LIPO = @LIPO@ +LN_S = @LN_S@ +LTLIBOBJS = @LTLIBOBJS@ +LT_SYS_LIBRARY_PATH = @LT_SYS_LIBRARY_PATH@ +MAINT = @MAINT@ +MAKEINFO = @MAKEINFO@ +MANIFEST_TOOL = @MANIFEST_TOOL@ +MKDIR_P = @MKDIR_P@ +NM = @NM@ +NMEDIT = @NMEDIT@ +OBJDUMP = @OBJDUMP@ +OBJEXT = @OBJEXT@ +OTOOL = @OTOOL@ +OTOOL64 = @OTOOL64@ +PACKAGE = @PACKAGE@ +PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ +PACKAGE_NAME = @PACKAGE_NAME@ +PACKAGE_STRING = @PACKAGE_STRING@ +PACKAGE_TARNAME = @PACKAGE_TARNAME@ +PACKAGE_URL = @PACKAGE_URL@ +PACKAGE_VERSION = @PACKAGE_VERSION@ +PATH_SEPARATOR = @PATH_SEPARATOR@ +PERL = @PERL@ +PKGCONFIG = @PKGCONFIG@ +RANLIB = @RANLIB@ +RC = @RC@ +SED = @SED@ +SET_MAKE = @SET_MAKE@ +SFTPD = @SFTPD@ +SHELL = @SHELL@ +SSHD = @SSHD@ +SSL_BACKENDS = @SSL_BACKENDS@ +STRIP = @STRIP@ +SUPPORT_FEATURES = @SUPPORT_FEATURES@ +SUPPORT_PROTOCOLS = @SUPPORT_PROTOCOLS@ +TEST_NGHTTPX = @TEST_NGHTTPX@ +VERSION = @VERSION@ +VERSIONNUM = @VERSIONNUM@ +VSFTPD = @VSFTPD@ +ZLIB_LIBS = @ZLIB_LIBS@ +ZSH_FUNCTIONS_DIR = @ZSH_FUNCTIONS_DIR@ +abs_builddir = @abs_builddir@ +abs_srcdir = @abs_srcdir@ +abs_top_builddir = @abs_top_builddir@ +abs_top_srcdir = @abs_top_srcdir@ +ac_ct_AR = @ac_ct_AR@ +ac_ct_CC = @ac_ct_CC@ +ac_ct_DUMPBIN = @ac_ct_DUMPBIN@ +am__include = @am__include@ +am__leading_dot = @am__leading_dot@ +am__quote = @am__quote@ +am__tar = @am__tar@ +am__untar = @am__untar@ +bindir = @bindir@ +build = @build@ +build_alias = @build_alias@ +build_cpu = @build_cpu@ +build_os = @build_os@ +build_vendor = @build_vendor@ +builddir = @builddir@ +datadir = @datadir@ +datarootdir = @datarootdir@ +docdir = @docdir@ +dvidir = @dvidir@ +exec_prefix = @exec_prefix@ +host = @host@ +host_alias = @host_alias@ +host_cpu = @host_cpu@ +host_os = @host_os@ +host_vendor = @host_vendor@ +htmldir = @htmldir@ +includedir = @includedir@ +infodir = @infodir@ +install_sh = @install_sh@ +libdir = @libdir@ +libexecdir = @libexecdir@ +libext = @libext@ +localedir = @localedir@ +localstatedir = @localstatedir@ +mandir = @mandir@ +mkdir_p = @mkdir_p@ +oldincludedir = @oldincludedir@ +pdfdir = @pdfdir@ +prefix = @prefix@ +program_transform_name = @program_transform_name@ +psdir = @psdir@ +runstatedir = @runstatedir@ +sbindir = @sbindir@ +sharedstatedir = @sharedstatedir@ +srcdir = @srcdir@ +sysconfdir = @sysconfdir@ +target_alias = @target_alias@ +top_build_prefix = @top_build_prefix@ +top_builddir = @top_builddir@ +top_srcdir = @top_srcdir@ + +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +SUBDIRS = curl +EXTRA_DIST = README.md +AUTOMAKE_OPTIONS = foreign no-dependencies +all: all-recursive + +.SUFFIXES: +$(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps) + @for dep in $?; do \ + case '$(am__configure_deps)' in \ + *$$dep*) \ + ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \ + && { if test -f $@; then exit 0; else break; fi; }; \ + exit 1;; \ + esac; \ + done; \ + echo ' cd $(top_srcdir) && $(AUTOMAKE) --foreign include/Makefile'; \ + $(am__cd) $(top_srcdir) && \ + $(AUTOMAKE) --foreign include/Makefile +Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status + @case '$?' in \ + *config.status*) \ + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ + *) \ + echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__maybe_remake_depfiles)'; \ + cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__maybe_remake_depfiles);; \ + esac; + +$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh + +$(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh +$(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh +$(am__aclocal_m4_deps): + +mostlyclean-libtool: + -rm -f *.lo + +clean-libtool: + -rm -rf .libs _libs + +# This directory's subdirectories are mostly independent; you can cd +# into them and run 'make' without going through this Makefile. +# To change the values of 'make' variables: instead of editing Makefiles, +# (1) if the variable is set in 'config.status', edit 'config.status' +# (which will cause the Makefiles to be regenerated when you run 'make'); +# (2) otherwise, pass the desired values on the 'make' command line. +$(am__recursive_targets): + @fail=; \ + if $(am__make_keepgoing); then \ + failcom='fail=yes'; \ + else \ + failcom='exit 1'; \ + fi; \ + dot_seen=no; \ + target=`echo $@ | sed s/-recursive//`; \ + case "$@" in \ + distclean-* | maintainer-clean-*) list='$(DIST_SUBDIRS)' ;; \ + *) list='$(SUBDIRS)' ;; \ + esac; \ + for subdir in $$list; do \ + echo "Making $$target in $$subdir"; \ + if test "$$subdir" = "."; then \ + dot_seen=yes; \ + local_target="$$target-am"; \ + else \ + local_target="$$target"; \ + fi; \ + ($(am__cd) $$subdir && $(MAKE) $(AM_MAKEFLAGS) $$local_target) \ + || eval $$failcom; \ + done; \ + if test "$$dot_seen" = "no"; then \ + $(MAKE) $(AM_MAKEFLAGS) "$$target-am" || exit 1; \ + fi; test -z "$$fail" + +ID: $(am__tagged_files) + $(am__define_uniq_tagged_files); mkid -fID $$unique +tags: tags-recursive +TAGS: tags + +tags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) + set x; \ + here=`pwd`; \ + if ($(ETAGS) --etags-include --version) >/dev/null 2>&1; then \ + include_option=--etags-include; \ + empty_fix=.; \ + else \ + include_option=--include; \ + empty_fix=; \ + fi; \ + list='$(SUBDIRS)'; for subdir in $$list; do \ + if test "$$subdir" = .; then :; else \ + test ! -f $$subdir/TAGS || \ + set "$$@" "$$include_option=$$here/$$subdir/TAGS"; \ + fi; \ + done; \ + $(am__define_uniq_tagged_files); \ + shift; \ + if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \ + test -n "$$unique" || unique=$$empty_fix; \ + if test $$# -gt 0; then \ + $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ + "$$@" $$unique; \ + else \ + $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ + $$unique; \ + fi; \ + fi +ctags: ctags-recursive + +CTAGS: ctags +ctags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) + $(am__define_uniq_tagged_files); \ + test -z "$(CTAGS_ARGS)$$unique" \ + || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ + $$unique + +GTAGS: + here=`$(am__cd) $(top_builddir) && pwd` \ + && $(am__cd) $(top_srcdir) \ + && gtags -i $(GTAGS_ARGS) "$$here" +cscopelist: cscopelist-recursive + +cscopelist-am: $(am__tagged_files) + list='$(am__tagged_files)'; \ + case "$(srcdir)" in \ + [\\/]* | ?:[\\/]*) sdir="$(srcdir)" ;; \ + *) sdir=$(subdir)/$(srcdir) ;; \ + esac; \ + for i in $$list; do \ + if test -f "$$i"; then \ + echo "$(subdir)/$$i"; \ + else \ + echo "$$sdir/$$i"; \ + fi; \ + done >> $(top_builddir)/cscope.files + +distclean-tags: + -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags +distdir: $(BUILT_SOURCES) + $(MAKE) $(AM_MAKEFLAGS) distdir-am + +distdir-am: $(DISTFILES) + @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ + topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ + list='$(DISTFILES)'; \ + dist_files=`for file in $$list; do echo $$file; done | \ + sed -e "s|^$$srcdirstrip/||;t" \ + -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ + case $$dist_files in \ + */*) $(MKDIR_P) `echo "$$dist_files" | \ + sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ + sort -u` ;; \ + esac; \ + for file in $$dist_files; do \ + if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ + if test -d $$d/$$file; then \ + dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ + if test -d "$(distdir)/$$file"; then \ + find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ + fi; \ + if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ + cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ + find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ + fi; \ + cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ + else \ + test -f "$(distdir)/$$file" \ + || cp -p $$d/$$file "$(distdir)/$$file" \ + || exit 1; \ + fi; \ + done + @list='$(DIST_SUBDIRS)'; for subdir in $$list; do \ + if test "$$subdir" = .; then :; else \ + $(am__make_dryrun) \ + || test -d "$(distdir)/$$subdir" \ + || $(MKDIR_P) "$(distdir)/$$subdir" \ + || exit 1; \ + dir1=$$subdir; dir2="$(distdir)/$$subdir"; \ + $(am__relativize); \ + new_distdir=$$reldir; \ + dir1=$$subdir; dir2="$(top_distdir)"; \ + $(am__relativize); \ + new_top_distdir=$$reldir; \ + echo " (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) top_distdir="$$new_top_distdir" distdir="$$new_distdir" \\"; \ + echo " am__remove_distdir=: am__skip_length_check=: am__skip_mode_fix=: distdir)"; \ + ($(am__cd) $$subdir && \ + $(MAKE) $(AM_MAKEFLAGS) \ + top_distdir="$$new_top_distdir" \ + distdir="$$new_distdir" \ + am__remove_distdir=: \ + am__skip_length_check=: \ + am__skip_mode_fix=: \ + distdir) \ + || exit 1; \ + fi; \ + done +check-am: all-am +check: check-recursive +all-am: Makefile +installdirs: installdirs-recursive +installdirs-am: +install: install-recursive +install-exec: install-exec-recursive +install-data: install-data-recursive +uninstall: uninstall-recursive + +install-am: all-am + @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am + +installcheck: installcheck-recursive +install-strip: + if test -z '$(STRIP)'; then \ + $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ + install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ + install; \ + else \ + $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ + install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ + "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \ + fi +mostlyclean-generic: + +clean-generic: + +distclean-generic: + -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) + -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) + +maintainer-clean-generic: + @echo "This command is intended for maintainers to use" + @echo "it deletes files that may require special tools to rebuild." +clean: clean-recursive + +clean-am: clean-generic clean-libtool mostlyclean-am + +distclean: distclean-recursive + -rm -f Makefile +distclean-am: clean-am distclean-generic distclean-tags + +dvi: dvi-recursive + +dvi-am: + +html: html-recursive + +html-am: + +info: info-recursive + +info-am: + +install-data-am: + +install-dvi: install-dvi-recursive + +install-dvi-am: + +install-exec-am: + +install-html: install-html-recursive + +install-html-am: + +install-info: install-info-recursive + +install-info-am: + +install-man: + +install-pdf: install-pdf-recursive + +install-pdf-am: + +install-ps: install-ps-recursive + +install-ps-am: + +installcheck-am: + +maintainer-clean: maintainer-clean-recursive + -rm -f Makefile +maintainer-clean-am: distclean-am maintainer-clean-generic + +mostlyclean: mostlyclean-recursive + +mostlyclean-am: mostlyclean-generic mostlyclean-libtool + +pdf: pdf-recursive + +pdf-am: + +ps: ps-recursive + +ps-am: + +uninstall-am: + +.MAKE: $(am__recursive_targets) install-am install-strip + +.PHONY: $(am__recursive_targets) CTAGS GTAGS TAGS all all-am check \ + check-am clean clean-generic clean-libtool cscopelist-am ctags \ + ctags-am distclean distclean-generic distclean-libtool \ + distclean-tags distdir dvi dvi-am html html-am info info-am \ + install install-am install-data install-data-am install-dvi \ + install-dvi-am install-exec install-exec-am install-html \ + install-html-am install-info install-info-am install-man \ + install-pdf install-pdf-am install-ps install-ps-am \ + install-strip installcheck installcheck-am installdirs \ + installdirs-am maintainer-clean maintainer-clean-generic \ + mostlyclean mostlyclean-generic mostlyclean-libtool pdf pdf-am \ + ps ps-am tags tags-am uninstall uninstall-am + +.PRECIOUS: Makefile + + +# Tell versions [3.59,3.63) of GNU make to not export all variables. +# Otherwise a system limit (for SysV at least) may be exceeded. +.NOEXPORT: diff --git a/3rdparty/curl-8.21.0/include/README.md b/3rdparty/curl-8.21.0/include/README.md new file mode 100644 index 0000000000..b155d8c13b --- /dev/null +++ b/3rdparty/curl-8.21.0/include/README.md @@ -0,0 +1,20 @@ + + +# include + +Public include files for libcurl, external users. + +They are all placed in the curl subdirectory here for better fit in any kind of +environment. You must include files from here using... + + #include + +... style and point the compiler's include path to the directory holding the +curl subdirectory. It makes it more likely to survive future modifications. + +The public curl include files can be shared freely between different platforms +and different architectures. diff --git a/3rdparty/curl-8.21.0/include/curl/Makefile.am b/3rdparty/curl-8.21.0/include/curl/Makefile.am new file mode 100644 index 0000000000..f2810fd307 --- /dev/null +++ b/3rdparty/curl-8.21.0/include/curl/Makefile.am @@ -0,0 +1,43 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +pkginclude_HEADERS = \ + curl.h curlver.h easy.h mprintf.h stdcheaders.h multi.h \ + typecheck-gcc.h system.h urlapi.h options.h header.h websockets.h + +pkgincludedir = $(includedir)/curl + +CHECKSRC = $(CS_$(V)) +CS_0 = @echo " RUN " $@; +CS_1 = +CS_ = $(CS_0) + +checksrc: + $(CHECKSRC)@PERL@ $(top_srcdir)/scripts/checksrc.pl -D$(top_srcdir)/include/curl $(pkginclude_HEADERS) + +if NOT_CURL_CI +if DEBUGBUILD +# for debug builds, we scan the sources on all regular make invokes +all-local: checksrc +endif +endif diff --git a/3rdparty/curl-8.21.0/include/curl/Makefile.in b/3rdparty/curl-8.21.0/include/curl/Makefile.in new file mode 100644 index 0000000000..cf1aa85e98 --- /dev/null +++ b/3rdparty/curl-8.21.0/include/curl/Makefile.in @@ -0,0 +1,667 @@ +# Makefile.in generated by automake 1.16.5 from Makefile.am. +# @configure_input@ + +# Copyright (C) 1994-2021 Free Software Foundation, Inc. + +# This Makefile.in is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY, to the extent permitted by law; without +# even the implied warranty of MERCHANTABILITY or FITNESS FOR A +# PARTICULAR PURPOSE. + +@SET_MAKE@ + +VPATH = @srcdir@ +am__is_gnu_make = { \ + if test -z '$(MAKELEVEL)'; then \ + false; \ + elif test -n '$(MAKE_HOST)'; then \ + true; \ + elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \ + true; \ + else \ + false; \ + fi; \ +} +am__make_running_with_option = \ + case $${target_option-} in \ + ?) ;; \ + *) echo "am__make_running_with_option: internal error: invalid" \ + "target option '$${target_option-}' specified" >&2; \ + exit 1;; \ + esac; \ + has_opt=no; \ + sane_makeflags=$$MAKEFLAGS; \ + if $(am__is_gnu_make); then \ + sane_makeflags=$$MFLAGS; \ + else \ + case $$MAKEFLAGS in \ + *\\[\ \ ]*) \ + bs=\\; \ + sane_makeflags=`printf '%s\n' "$$MAKEFLAGS" \ + | sed "s/$$bs$$bs[$$bs $$bs ]*//g"`;; \ + esac; \ + fi; \ + skip_next=no; \ + strip_trailopt () \ + { \ + flg=`printf '%s\n' "$$flg" | sed "s/$$1.*$$//"`; \ + }; \ + for flg in $$sane_makeflags; do \ + test $$skip_next = yes && { skip_next=no; continue; }; \ + case $$flg in \ + *=*|--*) continue;; \ + -*I) strip_trailopt 'I'; skip_next=yes;; \ + -*I?*) strip_trailopt 'I';; \ + -*O) strip_trailopt 'O'; skip_next=yes;; \ + -*O?*) strip_trailopt 'O';; \ + -*l) strip_trailopt 'l'; skip_next=yes;; \ + -*l?*) strip_trailopt 'l';; \ + -[dEDm]) skip_next=yes;; \ + -[JT]) skip_next=yes;; \ + esac; \ + case $$flg in \ + *$$target_option*) has_opt=yes; break;; \ + esac; \ + done; \ + test $$has_opt = yes +am__make_dryrun = (target_option=n; $(am__make_running_with_option)) +am__make_keepgoing = (target_option=k; $(am__make_running_with_option)) +pkgdatadir = $(datadir)/@PACKAGE@ +pkglibdir = $(libdir)/@PACKAGE@ +pkglibexecdir = $(libexecdir)/@PACKAGE@ +am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd +install_sh_DATA = $(install_sh) -c -m 644 +install_sh_PROGRAM = $(install_sh) -c +install_sh_SCRIPT = $(install_sh) -c +INSTALL_HEADER = $(INSTALL_DATA) +transform = $(program_transform_name) +NORMAL_INSTALL = : +PRE_INSTALL = : +POST_INSTALL = : +NORMAL_UNINSTALL = : +PRE_UNINSTALL = : +POST_UNINSTALL = : +build_triplet = @build@ +host_triplet = @host@ +subdir = include/curl +ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 +am__aclocal_m4_deps = $(top_srcdir)/m4/curl-amissl.m4 \ + $(top_srcdir)/m4/curl-apple-sectrust.m4 \ + $(top_srcdir)/m4/curl-compilers.m4 \ + $(top_srcdir)/m4/curl-confopts.m4 \ + $(top_srcdir)/m4/curl-functions.m4 \ + $(top_srcdir)/m4/curl-gnutls.m4 \ + $(top_srcdir)/m4/curl-mbedtls.m4 \ + $(top_srcdir)/m4/curl-openssl.m4 \ + $(top_srcdir)/m4/curl-override.m4 \ + $(top_srcdir)/m4/curl-reentrant.m4 \ + $(top_srcdir)/m4/curl-rustls.m4 \ + $(top_srcdir)/m4/curl-schannel.m4 \ + $(top_srcdir)/m4/curl-sysconfig.m4 \ + $(top_srcdir)/m4/curl-wolfssl.m4 $(top_srcdir)/m4/libtool.m4 \ + $(top_srcdir)/m4/ltoptions.m4 $(top_srcdir)/m4/ltsugar.m4 \ + $(top_srcdir)/m4/ltversion.m4 $(top_srcdir)/m4/lt~obsolete.m4 \ + $(top_srcdir)/m4/xc-am-iface.m4 \ + $(top_srcdir)/m4/xc-cc-check.m4 \ + $(top_srcdir)/m4/xc-lt-iface.m4 \ + $(top_srcdir)/m4/xc-val-flgs.m4 \ + $(top_srcdir)/m4/zz40-xc-ovr.m4 \ + $(top_srcdir)/m4/zz50-xc-ovr.m4 $(top_srcdir)/acinclude.m4 \ + $(top_srcdir)/configure.ac +am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ + $(ACLOCAL_M4) +DIST_COMMON = $(srcdir)/Makefile.am $(pkginclude_HEADERS) \ + $(am__DIST_COMMON) +mkinstalldirs = $(install_sh) -d +CONFIG_HEADER = $(top_builddir)/lib/curl_config.h +CONFIG_CLEAN_FILES = +CONFIG_CLEAN_VPATH_FILES = +AM_V_P = $(am__v_P_@AM_V@) +am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) +am__v_P_0 = false +am__v_P_1 = : +AM_V_GEN = $(am__v_GEN_@AM_V@) +am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@) +am__v_GEN_0 = @echo " GEN " $@; +am__v_GEN_1 = +AM_V_at = $(am__v_at_@AM_V@) +am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) +am__v_at_0 = @ +am__v_at_1 = +SOURCES = +DIST_SOURCES = +am__can_run_installinfo = \ + case $$AM_UPDATE_INFO_DIR in \ + n|no|NO) false;; \ + *) (install-info --version) >/dev/null 2>&1;; \ + esac +am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; +am__vpath_adj = case $$p in \ + $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \ + *) f=$$p;; \ + esac; +am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`; +am__install_max = 40 +am__nobase_strip_setup = \ + srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'` +am__nobase_strip = \ + for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||" +am__nobase_list = $(am__nobase_strip_setup); \ + for p in $$list; do echo "$$p $$p"; done | \ + sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \ + $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \ + if (++n[$$2] == $(am__install_max)) \ + { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \ + END { for (dir in files) print dir, files[dir] }' +am__base_list = \ + sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \ + sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g' +am__uninstall_files_from_dir = { \ + test -z "$$files" \ + || { test ! -d "$$dir" && test ! -f "$$dir" && test ! -r "$$dir"; } \ + || { echo " ( cd '$$dir' && rm -f" $$files ")"; \ + $(am__cd) "$$dir" && rm -f $$files; }; \ + } +am__installdirs = "$(DESTDIR)$(pkgincludedir)" +HEADERS = $(pkginclude_HEADERS) +am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) $(LISP) +# Read a list of newline-separated strings from the standard input, +# and print each of them once, without duplicates. Input order is +# *not* preserved. +am__uniquify_input = $(AWK) '\ + BEGIN { nonempty = 0; } \ + { items[$$0] = 1; nonempty = 1; } \ + END { if (nonempty) { for (i in items) print i; }; } \ +' +# Make sure the list of sources is unique. This is necessary because, +# e.g., the same source file might be shared among _SOURCES variables +# for different programs/libraries. +am__define_uniq_tagged_files = \ + list='$(am__tagged_files)'; \ + unique=`for i in $$list; do \ + if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ + done | $(am__uniquify_input)` +am__DIST_COMMON = $(srcdir)/Makefile.in +DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) +pkgincludedir = $(includedir)/curl +ACLOCAL = @ACLOCAL@ +AMTAR = @AMTAR@ +AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ +APXS = @APXS@ +AR = @AR@ +AR_FLAGS = @AR_FLAGS@ +AS = @AS@ +AUTOCONF = @AUTOCONF@ +AUTOHEADER = @AUTOHEADER@ +AUTOMAKE = @AUTOMAKE@ +AWK = @AWK@ +BLANK_AT_MAKETIME = @BLANK_AT_MAKETIME@ +CADDY = @CADDY@ +CC = @CC@ +CCDEPMODE = @CCDEPMODE@ +CFLAGS = @CFLAGS@ +CFLAG_CURL_SYMBOL_HIDING = @CFLAG_CURL_SYMBOL_HIDING@ +CLANG_TIDY = @CLANG_TIDY@ +CONFIGURE_OPTIONS = @CONFIGURE_OPTIONS@ +CPP = @CPP@ +CPPFLAGS = @CPPFLAGS@ +CSCOPE = @CSCOPE@ +CTAGS = @CTAGS@ +CURLVERSION = @CURLVERSION@ +CURL_CA_BUNDLE = @CURL_CA_BUNDLE@ +CURL_CA_EMBED = @CURL_CA_EMBED@ +CURL_CFLAG_EXTRAS = @CURL_CFLAG_EXTRAS@ +CURL_CPP = @CURL_CPP@ +CURL_LIBCURL_VERSIONED_SYMBOLS_PREFIX = @CURL_LIBCURL_VERSIONED_SYMBOLS_PREFIX@ +CURL_LIBCURL_VERSIONED_SYMBOLS_SONAME = @CURL_LIBCURL_VERSIONED_SYMBOLS_SONAME@ +CURL_NETWORK_AND_TIME_LIBS = @CURL_NETWORK_AND_TIME_LIBS@ +CYGPATH_W = @CYGPATH_W@ +DANTED = @DANTED@ +DEFS = @DEFS@ +DEPDIR = @DEPDIR@ +DLLTOOL = @DLLTOOL@ +DSYMUTIL = @DSYMUTIL@ +DUMPBIN = @DUMPBIN@ +ECHO_C = @ECHO_C@ +ECHO_N = @ECHO_N@ +ECHO_T = @ECHO_T@ +EGREP = @EGREP@ +ENABLE_SHARED = @ENABLE_SHARED@ +ENABLE_STATIC = @ENABLE_STATIC@ +ETAGS = @ETAGS@ +EXEEXT = @EXEEXT@ +FGREP = @FGREP@ +FILECMD = @FILECMD@ +FISH_FUNCTIONS_DIR = @FISH_FUNCTIONS_DIR@ +GCOV = @GCOV@ +GREP = @GREP@ +H2O = @H2O@ +HAVE_LIBZ = @HAVE_LIBZ@ +HTTPD = @HTTPD@ +HTTPD_NGHTTPX = @HTTPD_NGHTTPX@ +INSTALL = @INSTALL@ +INSTALL_DATA = @INSTALL_DATA@ +INSTALL_PROGRAM = @INSTALL_PROGRAM@ +INSTALL_SCRIPT = @INSTALL_SCRIPT@ +INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ +LCOV = @LCOV@ +LD = @LD@ +LDFLAGS = @LDFLAGS@ +LIBCURL_PC_CFLAGS = @LIBCURL_PC_CFLAGS@ +LIBCURL_PC_CFLAGS_PRIVATE = @LIBCURL_PC_CFLAGS_PRIVATE@ +LIBCURL_PC_LDFLAGS_PRIVATE = @LIBCURL_PC_LDFLAGS_PRIVATE@ +LIBCURL_PC_LIBS = @LIBCURL_PC_LIBS@ +LIBCURL_PC_LIBS_PRIVATE = @LIBCURL_PC_LIBS_PRIVATE@ +LIBCURL_PC_REQUIRES = @LIBCURL_PC_REQUIRES@ +LIBCURL_PC_REQUIRES_PRIVATE = @LIBCURL_PC_REQUIRES_PRIVATE@ +LIBOBJS = @LIBOBJS@ +LIBS = @LIBS@ +LIBTOOL = @LIBTOOL@ +LIPO = @LIPO@ +LN_S = @LN_S@ +LTLIBOBJS = @LTLIBOBJS@ +LT_SYS_LIBRARY_PATH = @LT_SYS_LIBRARY_PATH@ +MAINT = @MAINT@ +MAKEINFO = @MAKEINFO@ +MANIFEST_TOOL = @MANIFEST_TOOL@ +MKDIR_P = @MKDIR_P@ +NM = @NM@ +NMEDIT = @NMEDIT@ +OBJDUMP = @OBJDUMP@ +OBJEXT = @OBJEXT@ +OTOOL = @OTOOL@ +OTOOL64 = @OTOOL64@ +PACKAGE = @PACKAGE@ +PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ +PACKAGE_NAME = @PACKAGE_NAME@ +PACKAGE_STRING = @PACKAGE_STRING@ +PACKAGE_TARNAME = @PACKAGE_TARNAME@ +PACKAGE_URL = @PACKAGE_URL@ +PACKAGE_VERSION = @PACKAGE_VERSION@ +PATH_SEPARATOR = @PATH_SEPARATOR@ +PERL = @PERL@ +PKGCONFIG = @PKGCONFIG@ +RANLIB = @RANLIB@ +RC = @RC@ +SED = @SED@ +SET_MAKE = @SET_MAKE@ +SFTPD = @SFTPD@ +SHELL = @SHELL@ +SSHD = @SSHD@ +SSL_BACKENDS = @SSL_BACKENDS@ +STRIP = @STRIP@ +SUPPORT_FEATURES = @SUPPORT_FEATURES@ +SUPPORT_PROTOCOLS = @SUPPORT_PROTOCOLS@ +TEST_NGHTTPX = @TEST_NGHTTPX@ +VERSION = @VERSION@ +VERSIONNUM = @VERSIONNUM@ +VSFTPD = @VSFTPD@ +ZLIB_LIBS = @ZLIB_LIBS@ +ZSH_FUNCTIONS_DIR = @ZSH_FUNCTIONS_DIR@ +abs_builddir = @abs_builddir@ +abs_srcdir = @abs_srcdir@ +abs_top_builddir = @abs_top_builddir@ +abs_top_srcdir = @abs_top_srcdir@ +ac_ct_AR = @ac_ct_AR@ +ac_ct_CC = @ac_ct_CC@ +ac_ct_DUMPBIN = @ac_ct_DUMPBIN@ +am__include = @am__include@ +am__leading_dot = @am__leading_dot@ +am__quote = @am__quote@ +am__tar = @am__tar@ +am__untar = @am__untar@ +bindir = @bindir@ +build = @build@ +build_alias = @build_alias@ +build_cpu = @build_cpu@ +build_os = @build_os@ +build_vendor = @build_vendor@ +builddir = @builddir@ +datadir = @datadir@ +datarootdir = @datarootdir@ +docdir = @docdir@ +dvidir = @dvidir@ +exec_prefix = @exec_prefix@ +host = @host@ +host_alias = @host_alias@ +host_cpu = @host_cpu@ +host_os = @host_os@ +host_vendor = @host_vendor@ +htmldir = @htmldir@ +includedir = @includedir@ +infodir = @infodir@ +install_sh = @install_sh@ +libdir = @libdir@ +libexecdir = @libexecdir@ +libext = @libext@ +localedir = @localedir@ +localstatedir = @localstatedir@ +mandir = @mandir@ +mkdir_p = @mkdir_p@ +oldincludedir = @oldincludedir@ +pdfdir = @pdfdir@ +prefix = @prefix@ +program_transform_name = @program_transform_name@ +psdir = @psdir@ +runstatedir = @runstatedir@ +sbindir = @sbindir@ +sharedstatedir = @sharedstatedir@ +srcdir = @srcdir@ +sysconfdir = @sysconfdir@ +target_alias = @target_alias@ +top_build_prefix = @top_build_prefix@ +top_builddir = @top_builddir@ +top_srcdir = @top_srcdir@ + +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +pkginclude_HEADERS = \ + curl.h curlver.h easy.h mprintf.h stdcheaders.h multi.h \ + typecheck-gcc.h system.h urlapi.h options.h header.h websockets.h + +CHECKSRC = $(CS_$(V)) +CS_0 = @echo " RUN " $@; +CS_1 = +CS_ = $(CS_0) +all: all-am + +.SUFFIXES: +$(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps) + @for dep in $?; do \ + case '$(am__configure_deps)' in \ + *$$dep*) \ + ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \ + && { if test -f $@; then exit 0; else break; fi; }; \ + exit 1;; \ + esac; \ + done; \ + echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu include/curl/Makefile'; \ + $(am__cd) $(top_srcdir) && \ + $(AUTOMAKE) --gnu include/curl/Makefile +Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status + @case '$?' in \ + *config.status*) \ + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ + *) \ + echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__maybe_remake_depfiles)'; \ + cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__maybe_remake_depfiles);; \ + esac; + +$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh + +$(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh +$(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh +$(am__aclocal_m4_deps): + +mostlyclean-libtool: + -rm -f *.lo + +clean-libtool: + -rm -rf .libs _libs +install-pkgincludeHEADERS: $(pkginclude_HEADERS) + @$(NORMAL_INSTALL) + @list='$(pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \ + if test -n "$$list"; then \ + echo " $(MKDIR_P) '$(DESTDIR)$(pkgincludedir)'"; \ + $(MKDIR_P) "$(DESTDIR)$(pkgincludedir)" || exit 1; \ + fi; \ + for p in $$list; do \ + if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ + echo "$$d$$p"; \ + done | $(am__base_list) | \ + while read files; do \ + echo " $(INSTALL_HEADER) $$files '$(DESTDIR)$(pkgincludedir)'"; \ + $(INSTALL_HEADER) $$files "$(DESTDIR)$(pkgincludedir)" || exit $$?; \ + done + +uninstall-pkgincludeHEADERS: + @$(NORMAL_UNINSTALL) + @list='$(pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \ + files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ + dir='$(DESTDIR)$(pkgincludedir)'; $(am__uninstall_files_from_dir) + +ID: $(am__tagged_files) + $(am__define_uniq_tagged_files); mkid -fID $$unique +tags: tags-am +TAGS: tags + +tags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) + set x; \ + here=`pwd`; \ + $(am__define_uniq_tagged_files); \ + shift; \ + if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \ + test -n "$$unique" || unique=$$empty_fix; \ + if test $$# -gt 0; then \ + $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ + "$$@" $$unique; \ + else \ + $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ + $$unique; \ + fi; \ + fi +ctags: ctags-am + +CTAGS: ctags +ctags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) + $(am__define_uniq_tagged_files); \ + test -z "$(CTAGS_ARGS)$$unique" \ + || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ + $$unique + +GTAGS: + here=`$(am__cd) $(top_builddir) && pwd` \ + && $(am__cd) $(top_srcdir) \ + && gtags -i $(GTAGS_ARGS) "$$here" +cscopelist: cscopelist-am + +cscopelist-am: $(am__tagged_files) + list='$(am__tagged_files)'; \ + case "$(srcdir)" in \ + [\\/]* | ?:[\\/]*) sdir="$(srcdir)" ;; \ + *) sdir=$(subdir)/$(srcdir) ;; \ + esac; \ + for i in $$list; do \ + if test -f "$$i"; then \ + echo "$(subdir)/$$i"; \ + else \ + echo "$$sdir/$$i"; \ + fi; \ + done >> $(top_builddir)/cscope.files + +distclean-tags: + -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags +distdir: $(BUILT_SOURCES) + $(MAKE) $(AM_MAKEFLAGS) distdir-am + +distdir-am: $(DISTFILES) + @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ + topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ + list='$(DISTFILES)'; \ + dist_files=`for file in $$list; do echo $$file; done | \ + sed -e "s|^$$srcdirstrip/||;t" \ + -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ + case $$dist_files in \ + */*) $(MKDIR_P) `echo "$$dist_files" | \ + sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ + sort -u` ;; \ + esac; \ + for file in $$dist_files; do \ + if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ + if test -d $$d/$$file; then \ + dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ + if test -d "$(distdir)/$$file"; then \ + find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ + fi; \ + if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ + cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ + find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ + fi; \ + cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ + else \ + test -f "$(distdir)/$$file" \ + || cp -p $$d/$$file "$(distdir)/$$file" \ + || exit 1; \ + fi; \ + done +check-am: all-am +check: check-am +@DEBUGBUILD_FALSE@all-local: +@NOT_CURL_CI_FALSE@all-local: +all-am: Makefile $(HEADERS) all-local +installdirs: + for dir in "$(DESTDIR)$(pkgincludedir)"; do \ + test -z "$$dir" || $(MKDIR_P) "$$dir"; \ + done +install: install-am +install-exec: install-exec-am +install-data: install-data-am +uninstall: uninstall-am + +install-am: all-am + @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am + +installcheck: installcheck-am +install-strip: + if test -z '$(STRIP)'; then \ + $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ + install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ + install; \ + else \ + $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ + install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ + "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \ + fi +mostlyclean-generic: + +clean-generic: + +distclean-generic: + -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) + -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) + +maintainer-clean-generic: + @echo "This command is intended for maintainers to use" + @echo "it deletes files that may require special tools to rebuild." +clean: clean-am + +clean-am: clean-generic clean-libtool mostlyclean-am + +distclean: distclean-am + -rm -f Makefile +distclean-am: clean-am distclean-generic distclean-tags + +dvi: dvi-am + +dvi-am: + +html: html-am + +html-am: + +info: info-am + +info-am: + +install-data-am: install-pkgincludeHEADERS + +install-dvi: install-dvi-am + +install-dvi-am: + +install-exec-am: + +install-html: install-html-am + +install-html-am: + +install-info: install-info-am + +install-info-am: + +install-man: + +install-pdf: install-pdf-am + +install-pdf-am: + +install-ps: install-ps-am + +install-ps-am: + +installcheck-am: + +maintainer-clean: maintainer-clean-am + -rm -f Makefile +maintainer-clean-am: distclean-am maintainer-clean-generic + +mostlyclean: mostlyclean-am + +mostlyclean-am: mostlyclean-generic mostlyclean-libtool + +pdf: pdf-am + +pdf-am: + +ps: ps-am + +ps-am: + +uninstall-am: uninstall-pkgincludeHEADERS + +.MAKE: install-am install-strip + +.PHONY: CTAGS GTAGS TAGS all all-am all-local check check-am clean \ + clean-generic clean-libtool cscopelist-am ctags ctags-am \ + distclean distclean-generic distclean-libtool distclean-tags \ + distdir dvi dvi-am html html-am info info-am install \ + install-am install-data install-data-am install-dvi \ + install-dvi-am install-exec install-exec-am install-html \ + install-html-am install-info install-info-am install-man \ + install-pdf install-pdf-am install-pkgincludeHEADERS \ + install-ps install-ps-am install-strip installcheck \ + installcheck-am installdirs maintainer-clean \ + maintainer-clean-generic mostlyclean mostlyclean-generic \ + mostlyclean-libtool pdf pdf-am ps ps-am tags tags-am uninstall \ + uninstall-am uninstall-pkgincludeHEADERS + +.PRECIOUS: Makefile + + +checksrc: + $(CHECKSRC)@PERL@ $(top_srcdir)/scripts/checksrc.pl -D$(top_srcdir)/include/curl $(pkginclude_HEADERS) + +# for debug builds, we scan the sources on all regular make invokes +@DEBUGBUILD_TRUE@@NOT_CURL_CI_TRUE@all-local: checksrc + +# Tell versions [3.59,3.63) of GNU make to not export all variables. +# Otherwise a system limit (for SysV at least) may be exceeded. +.NOEXPORT: diff --git a/3rdparty/curl-8.21.0/include/curl/curl.h b/3rdparty/curl-8.21.0/include/curl/curl.h new file mode 100644 index 0000000000..7e59e43c4d --- /dev/null +++ b/3rdparty/curl-8.21.0/include/curl/curl.h @@ -0,0 +1,3347 @@ +#ifndef CURLINC_CURL_H +#define CURLINC_CURL_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +/* + * If you have libcurl problems, all docs and details are found here: + * https://curl.se/libcurl/ + */ + +#ifdef CURL_NO_OLDIES +#define CURL_STRICTER /* not used since 8.11.0 */ +#endif + +/* Compile-time deprecation macros. */ +#if (defined(__GNUC__) && \ + ((__GNUC__ > 12) || ((__GNUC__ == 12) && (__GNUC_MINOR__ >= 1))) || \ + (defined(__clang__) && __clang_major__ >= 3) || \ + defined(__IAR_SYSTEMS_ICC__)) && \ + !defined(__INTEL_COMPILER) && \ + !defined(CURL_DISABLE_DEPRECATION) && !defined(BUILDING_LIBCURL) +#define CURL_DEPRECATED(version, message) \ + __attribute__((deprecated("since " # version ". " message))) +#ifdef __IAR_SYSTEMS_ICC__ +#define CURL_IGNORE_DEPRECATION(statements) \ + _Pragma("diag_suppress=Pe1444") \ + statements \ + _Pragma("diag_default=Pe1444") +#else +#define CURL_IGNORE_DEPRECATION(statements) \ + _Pragma("GCC diagnostic push") \ + _Pragma("GCC diagnostic ignored \"-Wdeprecated-declarations\"") \ + statements \ + _Pragma("GCC diagnostic pop") +#endif +#else +#define CURL_DEPRECATED(version, message) +#define CURL_IGNORE_DEPRECATION(statements) statements +#endif + +#include "curlver.h" /* libcurl version defines */ +#include "system.h" /* determine things runtime */ + +#include +#include + +#if defined(__FreeBSD__) || defined(__MidnightBSD__) +/* Needed for __FreeBSD_version or __MidnightBSD_version symbol definition */ +#include +#endif + +/* The include stuff here below is mainly for time_t! */ +#include +#include + +#if defined(_WIN32) && !defined(_WIN32_WCE) && !defined(__CYGWIN__) +#if !(defined(_WINSOCKAPI_) || defined(_WINSOCK_H) || \ + defined(__LWIP_OPT_H__) || defined(LWIP_HDR_OPT_H)) +/* The check above prevents the winsock2.h inclusion if winsock.h already was + included, since they cannot co-exist without problems */ +#include +#include +#endif +#endif + +/* HP-UX systems version 9, 10 and 11 lack sys/select.h and so does oldish + libc5-based Linux systems. Only include it on systems that are known to + require it! */ +#if defined(_AIX) || defined(__NOVELL_LIBC__) || defined(__NetBSD__) || \ + defined(__minix) || defined(__INTEGRITY) || \ + defined(ANDROID) || defined(__ANDROID__) || defined(__OpenBSD__) || \ + defined(__CYGWIN__) || defined(AMIGA) || defined(__NuttX__) || \ + (defined(__FreeBSD_version) && (__FreeBSD_version < 800000)) || \ + (defined(__MidnightBSD_version) && (__MidnightBSD_version < 100000)) || \ + defined(__sun__) || defined(__serenity__) || defined(__vxworks__) +#include +#endif + +#ifndef _WIN32 +#include +#include +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +typedef void CURL; +typedef void CURLSH; + +/* + * libcurl external API function linkage decorations. + */ + +#ifdef __has_declspec_attribute +#define CURL_HAS_DECLSPEC_ATTRIBUTE(x) __has_declspec_attribute(x) +#else +#define CURL_HAS_DECLSPEC_ATTRIBUTE(x) 0 +#endif + +#ifdef CURL_STATICLIB +# define CURL_EXTERN +#elif defined(_WIN32) || \ + (CURL_HAS_DECLSPEC_ATTRIBUTE(dllexport) && \ + CURL_HAS_DECLSPEC_ATTRIBUTE(dllimport)) +# ifdef BUILDING_LIBCURL +# define CURL_EXTERN __declspec(dllexport) +# else +# define CURL_EXTERN __declspec(dllimport) +# endif +#elif defined(BUILDING_LIBCURL) && defined(CURL_HIDDEN_SYMBOLS) +# define CURL_EXTERN CURL_EXTERN_SYMBOL +#else +# define CURL_EXTERN +#endif + +#ifndef curl_socket_typedef +/* socket typedef */ +#if defined(_WIN32) && !defined(__LWIP_OPT_H__) && !defined(LWIP_HDR_OPT_H) +typedef SOCKET curl_socket_t; +#define CURL_SOCKET_BAD INVALID_SOCKET +#else +typedef int curl_socket_t; +#define CURL_SOCKET_BAD (-1) +#endif +#define curl_socket_typedef +#endif /* curl_socket_typedef */ + +/* enum for the different supported SSL backends */ +typedef enum { + CURLSSLBACKEND_NONE = 0, + CURLSSLBACKEND_OPENSSL = 1, + CURLSSLBACKEND_GNUTLS = 2, + CURLSSLBACKEND_NSS CURL_DEPRECATED(8.3.0, "") = 3, + CURLSSLBACKEND_OBSOLETE4 = 4, /* Was QSOSSL. */ + CURLSSLBACKEND_GSKIT CURL_DEPRECATED(8.3.0, "") = 5, + CURLSSLBACKEND_POLARSSL CURL_DEPRECATED(7.69.0, "") = 6, + CURLSSLBACKEND_WOLFSSL = 7, + CURLSSLBACKEND_SCHANNEL = 8, + CURLSSLBACKEND_SECURETRANSPORT CURL_DEPRECATED(8.15.0, "") = 9, + CURLSSLBACKEND_AXTLS CURL_DEPRECATED(7.61.0, "") = 10, + CURLSSLBACKEND_MBEDTLS = 11, + CURLSSLBACKEND_MESALINK CURL_DEPRECATED(7.82.0, "") = 12, + CURLSSLBACKEND_BEARSSL CURL_DEPRECATED(8.15.0, "") = 13, + CURLSSLBACKEND_RUSTLS = 14 +} curl_sslbackend; + +/* aliases for library clones and renames */ +#define CURLSSLBACKEND_AWSLC CURLSSLBACKEND_OPENSSL +#define CURLSSLBACKEND_BORINGSSL CURLSSLBACKEND_OPENSSL +#define CURLSSLBACKEND_LIBRESSL CURLSSLBACKEND_OPENSSL + +/* deprecated names: */ +#define CURLSSLBACKEND_CYASSL CURLSSLBACKEND_WOLFSSL +#define CURLSSLBACKEND_DARWINSSL CURLSSLBACKEND_SECURETRANSPORT + +/* bits for the CURLOPT_FOLLOWLOCATION option */ +#define CURLFOLLOW_ALL 1L /* generic follow redirects */ + +/* Do not use the custom method in the follow-up request if the HTTP code + instructs so (301, 302, 303). */ +#define CURLFOLLOW_OBEYCODE 2L + +/* Only use the custom method in the first request, always reset in the next */ +#define CURLFOLLOW_FIRSTONLY 3L + +struct curl_httppost { + struct curl_httppost *next; /* next entry in the list */ + char *name; /* pointer to allocated name */ + long namelength; /* length of name length */ + char *contents; /* pointer to allocated data contents */ + long contentslength; /* length of contents field, see also + CURL_HTTPPOST_LARGE */ + char *buffer; /* pointer to allocated buffer contents */ + long bufferlength; /* length of buffer field */ + char *contenttype; /* Content-Type */ + struct curl_slist *contentheader; /* list of extra headers for this form */ + struct curl_httppost *more; /* if one field name has more than one + file, this link should link to following + files */ + long flags; /* as defined below */ + +/* specified content is a filename */ +#define CURL_HTTPPOST_FILENAME (1 << 0) +/* specified content is a filename */ +#define CURL_HTTPPOST_READFILE (1 << 1) +/* name is only stored pointer do not free in formfree */ +#define CURL_HTTPPOST_PTRNAME (1 << 2) +/* contents is only stored pointer do not free in formfree */ +#define CURL_HTTPPOST_PTRCONTENTS (1 << 3) +/* upload file from buffer */ +#define CURL_HTTPPOST_BUFFER (1 << 4) +/* upload file from pointer contents */ +#define CURL_HTTPPOST_PTRBUFFER (1 << 5) +/* upload file contents by using the regular read callback to get the data and + pass the given pointer as custom pointer */ +#define CURL_HTTPPOST_CALLBACK (1 << 6) +/* use size in 'contentlen', added in 7.46.0 */ +#define CURL_HTTPPOST_LARGE (1 << 7) + + char *showfilename; /* The filename to show. If not set, the + actual filename is used (if this is + a file part) */ + void *userp; /* custom pointer used for + HTTPPOST_CALLBACK posts */ + curl_off_t contentlen; /* alternative length of contents + field. Used if CURL_HTTPPOST_LARGE is + set. Added in 7.46.0 */ +}; + +/* This is a return code for the progress callback that, when returned, + signals libcurl to continue executing the default progress function */ +#define CURL_PROGRESSFUNC_CONTINUE 0x10000001 + +/* This is the CURLOPT_PROGRESSFUNCTION callback prototype. It is now + considered deprecated but was the only choice up until 7.31.0 */ +typedef int (*curl_progress_callback)(void *clientp, + double dltotal, + double dlnow, + double ultotal, + double ulnow); + +/* This is the CURLOPT_XFERINFOFUNCTION callback prototype. It was introduced + in 7.32.0, avoids the use of floating point numbers and provides more + detailed information. */ +typedef int (*curl_xferinfo_callback)(void *clientp, + curl_off_t dltotal, + curl_off_t dlnow, + curl_off_t ultotal, + curl_off_t ulnow); + +#ifndef CURL_MAX_READ_SIZE + /* The maximum receive buffer size configurable via CURLOPT_BUFFERSIZE. */ +#define CURL_MAX_READ_SIZE (10 * 1024 * 1024) +#endif + +#ifndef CURL_MAX_WRITE_SIZE + /* Tests have proven that 20K is a bad buffer size for uploads on Windows, + while 16K for some odd reason performed a lot better. We do the ifndef + check to allow this value to easier be changed at build time for those + who feel adventurous. The practical minimum is about 400 bytes since + libcurl uses a buffer of this size as a scratch area (unrelated to + network send operations). */ +#define CURL_MAX_WRITE_SIZE 16384 +#endif + +#ifndef CURL_MAX_HTTP_HEADER +/* The only reason to have a max limit for this is to avoid the risk of a bad + server feeding libcurl with a never-ending header that causes reallocs + infinitely */ +#define CURL_MAX_HTTP_HEADER (100 * 1024) +#endif + +/* This is a magic return code for the write callback that, when returned, + signals libcurl to pause receiving on the current transfer. */ +#define CURL_WRITEFUNC_PAUSE 0x10000001 + +/* This is a magic return code for the write callback that, when returned, + signals an error from the callback. */ +#define CURL_WRITEFUNC_ERROR 0xFFFFFFFF + +typedef size_t (*curl_write_callback)(char *buffer, + size_t size, + size_t nitems, + void *outstream); + +/* This callback is called when a new resolver request is made */ +typedef int (*curl_resolver_start_callback)(void *resolver_state, + void *reserved, void *userdata); + +/* enumeration of file types */ +typedef enum { + CURLFILETYPE_FILE = 0, + CURLFILETYPE_DIRECTORY, + CURLFILETYPE_SYMLINK, + CURLFILETYPE_DEVICE_BLOCK, + CURLFILETYPE_DEVICE_CHAR, + CURLFILETYPE_NAMEDPIPE, + CURLFILETYPE_SOCKET, + CURLFILETYPE_DOOR, /* is possible only on Sun Solaris now */ + + CURLFILETYPE_UNKNOWN /* should never occur */ +} curlfiletype; + +#define CURLFINFOFLAG_KNOWN_FILENAME (1 << 0) +#define CURLFINFOFLAG_KNOWN_FILETYPE (1 << 1) +#define CURLFINFOFLAG_KNOWN_TIME (1 << 2) +#define CURLFINFOFLAG_KNOWN_PERM (1 << 3) +#define CURLFINFOFLAG_KNOWN_UID (1 << 4) +#define CURLFINFOFLAG_KNOWN_GID (1 << 5) +#define CURLFINFOFLAG_KNOWN_SIZE (1 << 6) +#define CURLFINFOFLAG_KNOWN_HLINKCOUNT (1 << 7) + +/* Information about a single file, used when doing FTP wildcard matching */ +struct curl_fileinfo { + char *filename; + curlfiletype filetype; + time_t time; /* always zero! */ + unsigned int perm; + int uid; + int gid; + curl_off_t size; + long int hardlinks; + + struct { + /* If some of these fields is not NULL, it is a pointer to b_data. */ + char *time; + char *perm; + char *user; + char *group; + char *target; /* pointer to the target filename of a symlink */ + } strings; + + unsigned int flags; + + /* These are libcurl private struct fields. Previously used by libcurl, so + they must never be interfered with. */ + char *b_data; + size_t b_size; + size_t b_used; +}; + +/* return codes for CURLOPT_CHUNK_BGN_FUNCTION */ +#define CURL_CHUNK_BGN_FUNC_OK 0 +#define CURL_CHUNK_BGN_FUNC_FAIL 1 /* tell the lib to end the task */ +#define CURL_CHUNK_BGN_FUNC_SKIP 2 /* skip this chunk over */ + +/* if splitting of data transfer is enabled, this callback is called before + download of an individual chunk started. Note that parameter "remains" works + only for FTP wildcard downloading (for now), otherwise is not used */ +typedef long (*curl_chunk_bgn_callback)(const void *transfer_info, + void *ptr, + int remains); + +/* return codes for CURLOPT_CHUNK_END_FUNCTION */ +#define CURL_CHUNK_END_FUNC_OK 0 +#define CURL_CHUNK_END_FUNC_FAIL 1 /* tell the lib to end the task */ + +/* If splitting of data transfer is enabled this callback is called after + download of an individual chunk finished. + Note! After this callback was set then it have to be called FOR ALL chunks. + Even if downloading of this chunk was skipped in CHUNK_BGN_FUNC. + This is the reason why we do not need "transfer_info" parameter in this + callback and we are not interested in "remains" parameter too. */ +typedef long (*curl_chunk_end_callback)(void *ptr); + +/* return codes for FNMATCHFUNCTION */ +#define CURL_FNMATCHFUNC_MATCH 0 /* string corresponds to the pattern */ +#define CURL_FNMATCHFUNC_NOMATCH 1 /* pattern does not match the string */ +#define CURL_FNMATCHFUNC_FAIL 2 /* an error occurred */ + +/* callback type for wildcard downloading pattern matching. If the + string matches the pattern, return CURL_FNMATCHFUNC_MATCH value, etc. */ +typedef int (*curl_fnmatch_callback)(void *ptr, + const char *pattern, + const char *string); + +/* These are the return codes for the seek callbacks */ +#define CURL_SEEKFUNC_OK 0 +#define CURL_SEEKFUNC_FAIL 1 /* fail the entire transfer */ +#define CURL_SEEKFUNC_CANTSEEK 2 /* tell libcurl seeking cannot be done, so + libcurl might try other means instead */ +typedef int (*curl_seek_callback)(void *instream, + curl_off_t offset, + int origin); /* 'whence' */ + +/* This is a return code for the read callback that, when returned, + signals libcurl to immediately abort the current transfer. */ +#define CURL_READFUNC_ABORT 0x10000000 +/* This is a return code for the read callback that, when returned, + signals libcurl to pause sending data on the current transfer. */ +#define CURL_READFUNC_PAUSE 0x10000001 + +/* Return code for when the trailing headers' callback has terminated + without any errors */ +#define CURL_TRAILERFUNC_OK 0 +/* Return code for when was an error in the trailing header's list and we + want to abort the request */ +#define CURL_TRAILERFUNC_ABORT 1 + +typedef size_t (*curl_read_callback)(char *buffer, + size_t size, + size_t nitems, + void *instream); + +typedef int (*curl_trailer_callback)(struct curl_slist **list, + void *userdata); + +typedef enum { + CURLSOCKTYPE_IPCXN, /* socket created for a specific IP connection */ + CURLSOCKTYPE_ACCEPT, /* socket created by accept() call */ + CURLSOCKTYPE_LAST /* never use */ +} curlsocktype; + +/* The return code from the sockopt_callback can signal information back + to libcurl: */ +#define CURL_SOCKOPT_OK 0 +#define CURL_SOCKOPT_ERROR 1 /* causes libcurl to abort and return + CURLE_ABORTED_BY_CALLBACK */ +#define CURL_SOCKOPT_ALREADY_CONNECTED 2 + +typedef int (*curl_sockopt_callback)(void *clientp, + curl_socket_t curlfd, + curlsocktype purpose); + +struct curl_sockaddr { + int family; + int socktype; + int protocol; + unsigned int addrlen; /* addrlen was a socklen_t type before 7.18.0 but it + turned really ugly and painful on the systems that + lack this type */ + struct sockaddr addr; +}; + +typedef curl_socket_t +(*curl_opensocket_callback)(void *clientp, + curlsocktype purpose, + struct curl_sockaddr *address); + +typedef int +(*curl_closesocket_callback)(void *clientp, curl_socket_t item); + +typedef enum { + CURLIOE_OK, /* I/O operation successful */ + CURLIOE_UNKNOWNCMD, /* command was unknown to callback */ + CURLIOE_FAILRESTART, /* failed to restart the read */ + CURLIOE_LAST /* never use */ +} curlioerr; + +typedef enum { + CURLIOCMD_NOP, /* no operation */ + CURLIOCMD_RESTARTREAD, /* restart the read stream from start */ + CURLIOCMD_LAST /* never use */ +} curliocmd; + +typedef curlioerr (*curl_ioctl_callback)(CURL *handle, + int cmd, + void *clientp); + +#ifndef CURL_DID_MEMORY_FUNC_TYPEDEFS +/* + * The following typedef's are signatures of malloc, free, realloc, strdup and + * calloc respectively. Function pointers of these types can be passed to the + * curl_global_init_mem() function to set user defined memory management + * callback routines. + */ +typedef void *(*curl_malloc_callback)(size_t size); +typedef void (*curl_free_callback)(void *ptr); +typedef void *(*curl_realloc_callback)(void *ptr, size_t size); +typedef char *(*curl_strdup_callback)(const char *str); +typedef void *(*curl_calloc_callback)(size_t nmemb, size_t size); + +#define CURL_DID_MEMORY_FUNC_TYPEDEFS +#endif + +/* the kind of data that is passed to information_callback */ +typedef enum { + CURLINFO_TEXT = 0, + CURLINFO_HEADER_IN, /* 1 */ + CURLINFO_HEADER_OUT, /* 2 */ + CURLINFO_DATA_IN, /* 3 */ + CURLINFO_DATA_OUT, /* 4 */ + CURLINFO_SSL_DATA_IN, /* 5 */ + CURLINFO_SSL_DATA_OUT, /* 6 */ + CURLINFO_END +} curl_infotype; + +typedef int (*curl_debug_callback) + (CURL *handle, /* the handle/transfer this concerns */ + curl_infotype type, /* what kind of data */ + char *data, /* points to the data */ + size_t size, /* size of the data pointed to */ + void *userptr); /* whatever the user please */ + +/* This is the CURLOPT_PREREQFUNCTION callback prototype. */ +typedef int (*curl_prereq_callback)(void *clientp, + char *conn_primary_ip, + char *conn_local_ip, + int conn_primary_port, + int conn_local_port); + +/* Return code for when the pre-request callback has terminated without + any errors */ +#define CURL_PREREQFUNC_OK 0 +/* Return code for when the pre-request callback wants to abort the + request */ +#define CURL_PREREQFUNC_ABORT 1 + +/* All possible error codes from all sorts of curl functions. Future versions + may return other values, stay prepared. + + Always add new return codes last. Never *EVER* remove any. The return + codes must remain the same! + */ + +typedef enum { + CURLE_OK = 0, + CURLE_UNSUPPORTED_PROTOCOL, /* 1 */ + CURLE_FAILED_INIT, /* 2 */ + CURLE_URL_MALFORMAT, /* 3 */ + CURLE_NOT_BUILT_IN, /* 4 - [was obsoleted in August 2007 for + 7.17.0, reused in April 2011 for 7.21.5] */ + CURLE_COULDNT_RESOLVE_PROXY, /* 5 */ + CURLE_COULDNT_RESOLVE_HOST, /* 6 */ + CURLE_COULDNT_CONNECT, /* 7 */ + CURLE_WEIRD_SERVER_REPLY, /* 8 */ + CURLE_REMOTE_ACCESS_DENIED, /* 9 a service was denied by the server + due to lack of access - when login fails + this is not returned. */ + CURLE_FTP_ACCEPT_FAILED, /* 10 - [was obsoleted in April 2006 for + 7.15.4, reused in Dec 2011 for 7.24.0]*/ + CURLE_FTP_WEIRD_PASS_REPLY, /* 11 */ + CURLE_FTP_ACCEPT_TIMEOUT, /* 12 - timeout occurred accepting server + [was obsoleted in August 2007 for 7.17.0, + reused in Dec 2011 for 7.24.0]*/ + CURLE_FTP_WEIRD_PASV_REPLY, /* 13 */ + CURLE_FTP_WEIRD_227_FORMAT, /* 14 */ + CURLE_FTP_CANT_GET_HOST, /* 15 */ + CURLE_HTTP2, /* 16 - A problem in the http2 framing layer. + [was obsoleted in August 2007 for 7.17.0, + reused in July 2014 for 7.38.0] */ + CURLE_FTP_COULDNT_SET_TYPE, /* 17 */ + CURLE_PARTIAL_FILE, /* 18 */ + CURLE_FTP_COULDNT_RETR_FILE, /* 19 */ + CURLE_OBSOLETE20, /* 20 - NOT USED */ + CURLE_QUOTE_ERROR, /* 21 - quote command failure */ + CURLE_HTTP_RETURNED_ERROR, /* 22 */ + CURLE_WRITE_ERROR, /* 23 */ + CURLE_OBSOLETE24, /* 24 - NOT USED */ + CURLE_UPLOAD_FAILED, /* 25 - failed upload "command" */ + CURLE_READ_ERROR, /* 26 - could not open/read from file */ + CURLE_OUT_OF_MEMORY, /* 27 */ + CURLE_OPERATION_TIMEDOUT, /* 28 - the timeout time was reached */ + CURLE_OBSOLETE29, /* 29 - NOT USED */ + CURLE_FTP_PORT_FAILED, /* 30 - FTP PORT operation failed */ + CURLE_FTP_COULDNT_USE_REST, /* 31 - the REST command failed */ + CURLE_OBSOLETE32, /* 32 - NOT USED */ + CURLE_RANGE_ERROR, /* 33 - RANGE "command" did not work */ + CURLE_OBSOLETE34, /* 34 */ + CURLE_SSL_CONNECT_ERROR, /* 35 - wrong when connecting with SSL */ + CURLE_BAD_DOWNLOAD_RESUME, /* 36 - could not resume download */ + CURLE_FILE_COULDNT_READ_FILE, /* 37 */ + CURLE_LDAP_CANNOT_BIND, /* 38 */ + CURLE_LDAP_SEARCH_FAILED, /* 39 */ + CURLE_OBSOLETE40, /* 40 - NOT USED */ + CURLE_OBSOLETE41, /* 41 - NOT USED starting with 7.53.0 */ + CURLE_ABORTED_BY_CALLBACK, /* 42 */ + CURLE_BAD_FUNCTION_ARGUMENT, /* 43 */ + CURLE_OBSOLETE44, /* 44 - NOT USED */ + CURLE_INTERFACE_FAILED, /* 45 - CURLOPT_INTERFACE failed */ + CURLE_OBSOLETE46, /* 46 - NOT USED */ + CURLE_TOO_MANY_REDIRECTS, /* 47 - catch endless re-direct loops */ + CURLE_UNKNOWN_OPTION, /* 48 - User specified an unknown option */ + CURLE_SETOPT_OPTION_SYNTAX, /* 49 - Malformed setopt option */ + CURLE_OBSOLETE50, /* 50 - NOT USED */ + CURLE_OBSOLETE51, /* 51 - NOT USED */ + CURLE_GOT_NOTHING, /* 52 - when this is a specific error */ + CURLE_SSL_ENGINE_NOTFOUND, /* 53 - SSL crypto engine not found */ + CURLE_SSL_ENGINE_SETFAILED, /* 54 - can not set SSL crypto engine as + default */ + CURLE_SEND_ERROR, /* 55 - failed sending network data */ + CURLE_RECV_ERROR, /* 56 - failure in receiving network data */ + CURLE_OBSOLETE57, /* 57 - NOT IN USE */ + CURLE_SSL_CERTPROBLEM, /* 58 - problem with the local certificate */ + CURLE_SSL_CIPHER, /* 59 - could not use specified cipher */ + CURLE_PEER_FAILED_VERIFICATION, /* 60 - peer's certificate or fingerprint + was not verified fine */ + CURLE_BAD_CONTENT_ENCODING, /* 61 - Unrecognized/bad encoding */ + CURLE_OBSOLETE62, /* 62 - NOT IN USE since 7.82.0 */ + CURLE_FILESIZE_EXCEEDED, /* 63 - Maximum file size exceeded */ + CURLE_USE_SSL_FAILED, /* 64 - Requested FTP SSL level failed */ + CURLE_SEND_FAIL_REWIND, /* 65 - Sending the data requires a rewind + that failed */ + CURLE_SSL_ENGINE_INITFAILED, /* 66 - failed to initialize ENGINE */ + CURLE_LOGIN_DENIED, /* 67 - user, password or similar was not + accepted and we failed to login */ + CURLE_TFTP_NOTFOUND, /* 68 - file not found on server */ + CURLE_TFTP_PERM, /* 69 - permission problem on server */ + CURLE_REMOTE_DISK_FULL, /* 70 - out of disk space on server */ + CURLE_TFTP_ILLEGAL, /* 71 - Illegal TFTP operation */ + CURLE_TFTP_UNKNOWNID, /* 72 - Unknown transfer ID */ + CURLE_REMOTE_FILE_EXISTS, /* 73 - File already exists */ + CURLE_TFTP_NOSUCHUSER, /* 74 - No such user */ + CURLE_OBSOLETE75, /* 75 - NOT IN USE since 7.82.0 */ + CURLE_OBSOLETE76, /* 76 - NOT IN USE since 7.82.0 */ + CURLE_SSL_CACERT_BADFILE, /* 77 - could not load CACERT file, missing + or wrong format */ + CURLE_REMOTE_FILE_NOT_FOUND, /* 78 - remote file not found */ + CURLE_SSH, /* 79 - error from the SSH layer, somewhat + generic so the error message is of + interest when this has happened */ + + CURLE_SSL_SHUTDOWN_FAILED, /* 80 - Failed to shut down the SSL + connection */ + CURLE_AGAIN, /* 81 - socket is not ready for send/recv, + wait till it is ready and try again (Added + in 7.18.2) */ + CURLE_SSL_CRL_BADFILE, /* 82 - could not load CRL file, missing or + wrong format (Added in 7.19.0) */ + CURLE_SSL_ISSUER_ERROR, /* 83 - Issuer check failed. (Added in + 7.19.0) */ + CURLE_FTP_PRET_FAILED, /* 84 - a PRET command failed */ + CURLE_RTSP_CSEQ_ERROR, /* 85 - mismatch of RTSP CSeq numbers */ + CURLE_RTSP_SESSION_ERROR, /* 86 - mismatch of RTSP Session Ids */ + CURLE_FTP_BAD_FILE_LIST, /* 87 - unable to parse FTP file list */ + CURLE_CHUNK_FAILED, /* 88 - chunk callback reported error */ + CURLE_NO_CONNECTION_AVAILABLE, /* 89 - No connection available, the + session is queued */ + CURLE_SSL_PINNEDPUBKEYNOTMATCH, /* 90 - specified pinned public key did not + match */ + CURLE_SSL_INVALIDCERTSTATUS, /* 91 - invalid certificate status */ + CURLE_HTTP2_STREAM, /* 92 - stream error in HTTP/2 framing layer + */ + CURLE_RECURSIVE_API_CALL, /* 93 - an api function was called from + inside a callback */ + CURLE_AUTH_ERROR, /* 94 - an authentication function returned an + error */ + CURLE_HTTP3, /* 95 - An HTTP/3 layer problem */ + CURLE_QUIC_CONNECT_ERROR, /* 96 - QUIC connection error */ + CURLE_PROXY, /* 97 - proxy handshake error */ + CURLE_SSL_CLIENTCERT, /* 98 - client-side certificate required */ + CURLE_UNRECOVERABLE_POLL, /* 99 - poll/select returned fatal error */ + CURLE_TOO_LARGE, /* 100 - a value/data met its maximum */ + CURLE_ECH_REQUIRED, /* 101 - ECH tried but failed */ + CURL_LAST /* never use! */ +} CURLcode; + +#ifndef CURL_NO_OLDIES /* define this to test if your app builds with all + the obsolete stuff removed! */ + +/* removed in 7.53.0 */ +#define CURLE_FUNCTION_NOT_FOUND CURLE_OBSOLETE41 + +/* removed in 7.56.0 */ +#define CURLE_HTTP_POST_ERROR CURLE_OBSOLETE34 + +/* Previously obsolete error code reused in 7.38.0 */ +#define CURLE_OBSOLETE16 CURLE_HTTP2 + +/* Previously obsolete error codes reused in 7.24.0 */ +#define CURLE_OBSOLETE10 CURLE_FTP_ACCEPT_FAILED +#define CURLE_OBSOLETE12 CURLE_FTP_ACCEPT_TIMEOUT + +/* compatibility with older names */ +#define CURLOPT_ENCODING CURLOPT_ACCEPT_ENCODING +#define CURLE_FTP_WEIRD_SERVER_REPLY CURLE_WEIRD_SERVER_REPLY + +/* The following were added in 7.62.0 */ +#define CURLE_SSL_CACERT CURLE_PEER_FAILED_VERIFICATION + +/* The following were added in 7.21.5, April 2011 */ +#define CURLE_UNKNOWN_TELNET_OPTION CURLE_UNKNOWN_OPTION + +/* Added for 7.78.0 */ +#define CURLE_TELNET_OPTION_SYNTAX CURLE_SETOPT_OPTION_SYNTAX + +/* The following were added in 7.17.1 */ +/* These are scheduled to disappear by 2009 */ +#define CURLE_SSL_PEER_CERTIFICATE CURLE_PEER_FAILED_VERIFICATION + +/* The following were added in 7.17.0 */ +/* These are scheduled to disappear by 2009 */ +#define CURLE_OBSOLETE CURLE_OBSOLETE50 /* no one should be using this! */ +#define CURLE_BAD_PASSWORD_ENTERED CURLE_OBSOLETE46 +#define CURLE_BAD_CALLING_ORDER CURLE_OBSOLETE44 +#define CURLE_FTP_USER_PASSWORD_INCORRECT CURLE_OBSOLETE10 +#define CURLE_FTP_CANT_RECONNECT CURLE_OBSOLETE16 +#define CURLE_FTP_COULDNT_GET_SIZE CURLE_OBSOLETE32 +#define CURLE_FTP_COULDNT_SET_ASCII CURLE_OBSOLETE29 +#define CURLE_FTP_WEIRD_USER_REPLY CURLE_OBSOLETE12 +#define CURLE_FTP_WRITE_ERROR CURLE_OBSOLETE20 +#define CURLE_LIBRARY_NOT_FOUND CURLE_OBSOLETE40 +#define CURLE_MALFORMAT_USER CURLE_OBSOLETE24 +#define CURLE_SHARE_IN_USE CURLE_OBSOLETE57 +#define CURLE_URL_MALFORMAT_USER CURLE_NOT_BUILT_IN + +#define CURLE_FTP_ACCESS_DENIED CURLE_REMOTE_ACCESS_DENIED +#define CURLE_FTP_COULDNT_SET_BINARY CURLE_FTP_COULDNT_SET_TYPE +#define CURLE_FTP_QUOTE_ERROR CURLE_QUOTE_ERROR +#define CURLE_TFTP_DISKFULL CURLE_REMOTE_DISK_FULL +#define CURLE_TFTP_EXISTS CURLE_REMOTE_FILE_EXISTS +#define CURLE_HTTP_RANGE_ERROR CURLE_RANGE_ERROR +#define CURLE_FTP_SSL_FAILED CURLE_USE_SSL_FAILED + +/* The following were added earlier */ + +#define CURLE_OPERATION_TIMEOUTED CURLE_OPERATION_TIMEDOUT +#define CURLE_HTTP_NOT_FOUND CURLE_HTTP_RETURNED_ERROR +#define CURLE_HTTP_PORT_FAILED CURLE_INTERFACE_FAILED +#define CURLE_FTP_COULDNT_STOR_FILE CURLE_UPLOAD_FAILED +#define CURLE_FTP_PARTIAL_FILE CURLE_PARTIAL_FILE +#define CURLE_FTP_BAD_DOWNLOAD_RESUME CURLE_BAD_DOWNLOAD_RESUME +#define CURLE_LDAP_INVALID_URL CURLE_OBSOLETE62 +#define CURLE_CONV_REQD CURLE_OBSOLETE76 +#define CURLE_CONV_FAILED CURLE_OBSOLETE75 + +/* This was the error code 50 in 7.7.3 and a few earlier versions, this + is no longer used by libcurl but is instead #defined here only to not + make programs break */ +#define CURLE_ALREADY_COMPLETE 99999 + +/* Provide defines for really old option names */ +#define CURLOPT_FILE CURLOPT_WRITEDATA /* name changed in 7.9.7 */ +#define CURLOPT_INFILE CURLOPT_READDATA /* name changed in 7.9.7 */ +#define CURLOPT_WRITEHEADER CURLOPT_HEADERDATA + +/* Since long deprecated options with no code in the lib that does anything + with them. */ +#define CURLOPT_WRITEINFO CURLOPT_OBSOLETE40 +#define CURLOPT_CLOSEPOLICY CURLOPT_OBSOLETE72 +#define CURLOPT_OBSOLETE72 9999 +#define CURLOPT_OBSOLETE40 9999 + +#endif /* !CURL_NO_OLDIES */ + +/* + * Proxy error codes. Returned in CURLINFO_PROXY_ERROR if CURLE_PROXY was + * return for the transfers. + */ +typedef enum { + CURLPX_OK, + CURLPX_BAD_ADDRESS_TYPE, + CURLPX_BAD_VERSION, + CURLPX_CLOSED, + CURLPX_GSSAPI, + CURLPX_GSSAPI_PERMSG, + CURLPX_GSSAPI_PROTECTION, + CURLPX_IDENTD, + CURLPX_IDENTD_DIFFER, + CURLPX_LONG_HOSTNAME, + CURLPX_LONG_PASSWD, + CURLPX_LONG_USER, + CURLPX_NO_AUTH, + CURLPX_RECV_ADDRESS, + CURLPX_RECV_AUTH, + CURLPX_RECV_CONNECT, + CURLPX_RECV_REQACK, + CURLPX_REPLY_ADDRESS_TYPE_NOT_SUPPORTED, + CURLPX_REPLY_COMMAND_NOT_SUPPORTED, + CURLPX_REPLY_CONNECTION_REFUSED, + CURLPX_REPLY_GENERAL_SERVER_FAILURE, + CURLPX_REPLY_HOST_UNREACHABLE, + CURLPX_REPLY_NETWORK_UNREACHABLE, + CURLPX_REPLY_NOT_ALLOWED, + CURLPX_REPLY_TTL_EXPIRED, + CURLPX_REPLY_UNASSIGNED, + CURLPX_REQUEST_FAILED, + CURLPX_RESOLVE_HOST, + CURLPX_SEND_AUTH, + CURLPX_SEND_CONNECT, + CURLPX_SEND_REQUEST, + CURLPX_UNKNOWN_FAIL, + CURLPX_UNKNOWN_MODE, + CURLPX_USER_REJECTED, + CURLPX_LAST /* never use */ +} CURLproxycode; + +/* This prototype applies to all conversion callbacks */ +typedef CURLcode (*curl_conv_callback)(char *buffer, size_t length); + +typedef CURLcode (*curl_ssl_ctx_callback)(CURL *curl, /* easy handle */ + void *ssl_ctx, /* actually an OpenSSL + or wolfSSL SSL_CTX, + or an mbedTLS + mbedtls_ssl_config */ + void *userptr); + +#define CURLPROXY_HTTP 0L /* added in 7.10, new in 7.19.4 default is + to use CONNECT HTTP/1.1 */ +#define CURLPROXY_HTTP_1_0 1L /* force to use CONNECT HTTP/1.0 + added in 7.19.4 */ +#define CURLPROXY_HTTPS 2L /* HTTPS but stick to HTTP/1 + added in 7.52.0 */ +#define CURLPROXY_HTTPS2 3L /* HTTPS and attempt HTTP/2 + added in 8.2.0 */ +#define CURLPROXY_SOCKS4 4L /* support added in 7.15.2, enum existed + already in 7.10 */ +#define CURLPROXY_SOCKS5 5L /* added in 7.10 */ +#define CURLPROXY_SOCKS4A 6L /* added in 7.18.0 */ +#define CURLPROXY_SOCKS5_HOSTNAME 7L /* Use the SOCKS5 protocol but pass along + the hostname rather than the IP + address. added in 7.18.0 */ +#define CURLPROXY_HTTPS3 8L /* HTTPS and attempt HTTP/3 + added in 8.21.0 */ + +typedef enum { + CURLPROXY_LAST = 9 /* never use */ +} curl_proxytype; /* this enum was added in 7.10 */ + +/* + * Bitmasks for CURLOPT_HTTPAUTH and CURLOPT_PROXYAUTH options: + * + * CURLAUTH_NONE - No HTTP authentication + * CURLAUTH_BASIC - HTTP Basic authentication (default) + * CURLAUTH_DIGEST - HTTP Digest authentication + * CURLAUTH_NEGOTIATE - HTTP Negotiate (SPNEGO) authentication + * CURLAUTH_GSSNEGOTIATE - Alias for CURLAUTH_NEGOTIATE (deprecated) + * CURLAUTH_NTLM - HTTP NTLM authentication + * CURLAUTH_DIGEST_IE - HTTP Digest authentication with IE flavor + * CURLAUTH_NTLM_WB - HTTP NTLM authentication delegated to winbind helper + * CURLAUTH_BEARER - HTTP Bearer token authentication + * CURLAUTH_ONLY - Use together with a single other type to force no + * authentication or that single type + * CURLAUTH_ANY - All fine types set + * CURLAUTH_ANYSAFE - All fine types except Basic + */ + +#define CURLAUTH_NONE ((unsigned long)0) +#define CURLAUTH_BASIC (((unsigned long)1) << 0) +#define CURLAUTH_DIGEST (((unsigned long)1) << 1) +#define CURLAUTH_NEGOTIATE (((unsigned long)1) << 2) +/* Deprecated since the advent of CURLAUTH_NEGOTIATE */ +#define CURLAUTH_GSSNEGOTIATE CURLAUTH_NEGOTIATE +/* Used for CURLOPT_SOCKS5_AUTH to stay terminologically correct */ +#define CURLAUTH_GSSAPI CURLAUTH_NEGOTIATE +#define CURLAUTH_NTLM (((unsigned long)1) << 3) +#define CURLAUTH_DIGEST_IE (((unsigned long)1) << 4) +#ifndef CURL_NO_OLDIES + /* functionality removed since 8.8.0 */ +#define CURLAUTH_NTLM_WB (((unsigned long)1) << 5) +#endif +#define CURLAUTH_BEARER (((unsigned long)1) << 6) +#define CURLAUTH_AWS_SIGV4 (((unsigned long)1) << 7) +#define CURLAUTH_ONLY (((unsigned long)1) << 31) +#define CURLAUTH_ANY ((~CURLAUTH_DIGEST_IE) & \ + ((unsigned long)0xffffffff)) +#define CURLAUTH_ANYSAFE ((~(CURLAUTH_BASIC | CURLAUTH_DIGEST_IE)) & \ + ((unsigned long)0xffffffff)) + +/* all types supported by server */ +#define CURLSSH_AUTH_ANY ((unsigned long)0xffffffff) +#define CURLSSH_AUTH_NONE 0L /* none allowed, silly but complete */ +#define CURLSSH_AUTH_PUBLICKEY (1L << 0) /* public/private key files */ +#define CURLSSH_AUTH_PASSWORD (1L << 1) /* password */ +#define CURLSSH_AUTH_HOST (1L << 2) /* host key files */ +#define CURLSSH_AUTH_KEYBOARD (1L << 3) /* keyboard interactive */ +#define CURLSSH_AUTH_AGENT (1L << 4) /* agent (ssh-agent, pageant...) */ +#define CURLSSH_AUTH_GSSAPI (1L << 5) /* gssapi (kerberos, ...) */ +#define CURLSSH_AUTH_DEFAULT CURLSSH_AUTH_ANY + +#define CURLGSSAPI_DELEGATION_NONE 0L /* no delegation (default) */ +#define CURLGSSAPI_DELEGATION_POLICY_FLAG (1L<<0) /* if permitted by policy */ +#define CURLGSSAPI_DELEGATION_FLAG (1L<<1) /* delegate always */ + +#define CURL_ERROR_SIZE 256 + +enum curl_khtype { + CURLKHTYPE_UNKNOWN, + CURLKHTYPE_RSA1, + CURLKHTYPE_RSA, + CURLKHTYPE_DSS, + CURLKHTYPE_ECDSA, + CURLKHTYPE_ED25519 +}; + +struct curl_khkey { + const char *key; /* points to a null-terminated string encoded with base64 + if len is zero, otherwise to the "raw" data */ + size_t len; + enum curl_khtype keytype; +}; + +/* this is the set of return values expected from the curl_sshkeycallback + callback */ +enum curl_khstat { + CURLKHSTAT_FINE_ADD_TO_FILE, + CURLKHSTAT_FINE, + CURLKHSTAT_REJECT, /* reject the connection, return an error */ + CURLKHSTAT_DEFER, /* do not accept it, but we cannot answer right now. + Causes a CURLE_PEER_FAILED_VERIFICATION error but the + connection is left intact etc */ + CURLKHSTAT_FINE_REPLACE, /* accept and replace the wrong key */ + CURLKHSTAT_LAST /* not for use, only a marker for last-in-list */ +}; + +/* this is the set of status codes pass in to the callback */ +enum curl_khmatch { + CURLKHMATCH_OK, /* match */ + CURLKHMATCH_MISMATCH, /* host found, key mismatch! */ + CURLKHMATCH_MISSING, /* no matching host/key found */ + CURLKHMATCH_LAST /* not for use, only a marker for last-in-list */ +}; + +typedef int + (*curl_sshkeycallback)(CURL *easy, /* easy handle */ + const struct curl_khkey *knownkey, /* known */ + const struct curl_khkey *foundkey, /* found */ + enum curl_khmatch, /* libcurl's view on the keys */ + void *clientp); /* custom pointer passed with */ + /* CURLOPT_SSH_KEYDATA */ + +typedef int + (*curl_sshhostkeycallback)(void *clientp,/* custom pointer passed */ + /* with CURLOPT_SSH_HOSTKEYDATA */ + int keytype, /* CURLKHTYPE */ + const char *key, /* hostkey to check */ + size_t keylen); /* length of the key */ + /* return CURLE_OK to accept */ + /* or something else to refuse */ + +/* parameter for the CURLOPT_USE_SSL option */ +#define CURLUSESSL_NONE 0L /* do not attempt to use SSL */ +#define CURLUSESSL_TRY 1L /* try using SSL, proceed anyway otherwise */ +#define CURLUSESSL_CONTROL 2L /* SSL for the control connection or fail */ +#define CURLUSESSL_ALL 3L /* SSL for all communication or fail */ + +typedef enum { + CURLUSESSL_LAST = 4 /* not an option, never use */ +} curl_usessl; + +/* Definition of bits for the CURLOPT_SSL_OPTIONS argument: */ + +/* - ALLOW_BEAST tells libcurl to allow the BEAST SSL vulnerability in the + name of improving interoperability with older servers. Some SSL libraries + have introduced workarounds for this flaw but those workarounds sometimes + make the SSL communication fail. To regain functionality with those broken + servers, a user can this way allow the vulnerability back. */ +#define CURLSSLOPT_ALLOW_BEAST (1L << 0) + +/* - NO_REVOKE tells libcurl to disable certificate revocation checks for those + SSL backends where such behavior is present. */ +#define CURLSSLOPT_NO_REVOKE (1L << 1) + +/* - NO_PARTIALCHAIN tells libcurl to *NOT* accept a partial certificate chain + if possible. The OpenSSL backend has this ability. */ +#define CURLSSLOPT_NO_PARTIALCHAIN (1L << 2) + +/* - REVOKE_BEST_EFFORT tells libcurl to ignore certificate revocation offline + checks and ignore missing revocation list for those SSL backends where such + behavior is present. */ +#define CURLSSLOPT_REVOKE_BEST_EFFORT (1L << 3) + +/* - CURLSSLOPT_NATIVE_CA tells libcurl to use standard certificate store of + operating system. Currently implemented under MS-Windows. */ +#define CURLSSLOPT_NATIVE_CA (1L << 4) + +/* - CURLSSLOPT_AUTO_CLIENT_CERT tells libcurl to automatically locate and use + a client certificate for authentication. (Schannel) */ +#define CURLSSLOPT_AUTO_CLIENT_CERT (1L << 5) + +/* If possible, send data using TLS 1.3 early data */ +#define CURLSSLOPT_EARLYDATA (1L << 6) + +/* The default connection attempt delay in milliseconds for happy eyeballs. + CURLOPT_HAPPY_EYEBALLS_TIMEOUT_MS.3 and happy-eyeballs-timeout-ms.d document + this value, keep them in sync. */ +#define CURL_HET_DEFAULT 200L + +/* The default connection upkeep interval in milliseconds. */ +#define CURL_UPKEEP_INTERVAL_DEFAULT 60000L + +#ifndef CURL_NO_OLDIES /* define this to test if your app builds with all + the obsolete stuff removed! */ + +/* Backwards compatibility with older names */ +/* These are scheduled to disappear by 2009 */ + +#define CURLFTPSSL_NONE CURLUSESSL_NONE +#define CURLFTPSSL_TRY CURLUSESSL_TRY +#define CURLFTPSSL_CONTROL CURLUSESSL_CONTROL +#define CURLFTPSSL_ALL CURLUSESSL_ALL +#define CURLFTPSSL_LAST CURLUSESSL_LAST +#define curl_ftpssl curl_usessl +#endif /* !CURL_NO_OLDIES */ + +/* parameter for the CURLOPT_FTP_SSL_CCC option */ +#define CURLFTPSSL_CCC_NONE 0L /* do not send CCC */ +#define CURLFTPSSL_CCC_PASSIVE 1L /* Let the server initiate the shutdown */ +#define CURLFTPSSL_CCC_ACTIVE 2L /* Initiate the shutdown */ + +typedef enum { + CURLFTPSSL_CCC_LAST = 3 /* not an option, never use */ +} curl_ftpccc; + +/* parameter for the CURLOPT_FTPSSLAUTH option */ +#define CURLFTPAUTH_DEFAULT 0L /* let libcurl decide */ +#define CURLFTPAUTH_SSL 1L /* use "AUTH SSL" */ +#define CURLFTPAUTH_TLS 2L /* use "AUTH TLS" */ + +typedef enum { + CURLFTPAUTH_LAST = 3 /* not an option, never use */ +} curl_ftpauth; + +/* parameter for the CURLOPT_FTP_CREATE_MISSING_DIRS option */ +#define CURLFTP_CREATE_DIR_NONE 0L /* do NOT create missing dirs! */ +#define CURLFTP_CREATE_DIR 1L /* (FTP/SFTP) if CWD fails, try MKD and + then CWD again if MKD succeeded, for + SFTP this does similar magic */ +#define CURLFTP_CREATE_DIR_RETRY 2L /* (FTP only) if CWD fails, try MKD and + then CWD again even if MKD failed! */ + +typedef enum { + CURLFTP_CREATE_DIR_LAST = 3 /* not an option, never use */ +} curl_ftpcreatedir; + +/* parameter for the CURLOPT_FTP_FILEMETHOD option */ +#define CURLFTPMETHOD_DEFAULT 0L /* let libcurl pick */ +#define CURLFTPMETHOD_MULTICWD 1L /* single CWD operation for each path + part */ +#define CURLFTPMETHOD_NOCWD 2L /* no CWD at all */ +#define CURLFTPMETHOD_SINGLECWD 3L /* one CWD to full dir, then work on file */ + +typedef enum { + CURLFTPMETHOD_LAST = 4 /* not an option, never use */ +} curl_ftpmethod; + +/* bitmask defines for CURLOPT_HEADEROPT */ +#define CURLHEADER_UNIFIED 0L +#define CURLHEADER_SEPARATE (1L << 0) + +/* CURLALTSVC_* are bits for the CURLOPT_ALTSVC_CTRL option */ +#define CURLALTSVC_READONLYFILE (1L << 2) +#define CURLALTSVC_H1 (1L << 3) +#define CURLALTSVC_H2 (1L << 4) +#define CURLALTSVC_H3 (1L << 5) + +/* bitmask values for CURLOPT_UPLOAD_FLAGS */ +#define CURLULFLAG_ANSWERED (1L << 0) +#define CURLULFLAG_DELETED (1L << 1) +#define CURLULFLAG_DRAFT (1L << 2) +#define CURLULFLAG_FLAGGED (1L << 3) +#define CURLULFLAG_SEEN (1L << 4) + +struct curl_hstsentry { + char *name; + size_t namelen; + unsigned int includeSubDomains:1; + char expire[18]; /* YYYYMMDD HH:MM:SS [null-terminated] */ +}; + +struct curl_index { + size_t index; /* the provided entry's "index" or count */ + size_t total; /* total number of entries to save */ +}; + +typedef enum { + CURLSTS_OK, + CURLSTS_DONE, + CURLSTS_FAIL +} CURLSTScode; + +typedef CURLSTScode (*curl_hstsread_callback)(CURL *easy, + struct curl_hstsentry *e, + void *userp); +typedef CURLSTScode (*curl_hstswrite_callback)(CURL *easy, + struct curl_hstsentry *e, + struct curl_index *i, + void *userp); + +/* CURLHSTS_* are bits for the CURLOPT_HSTS option */ +#define CURLHSTS_ENABLE (1L << 0) +#define CURLHSTS_READONLYFILE (1L << 1) + +/* The CURLPROTO_ defines below are for the **deprecated** CURLOPT_*PROTOCOLS + options. Do not use. */ +#define CURLPROTO_HTTP (1L << 0) +#define CURLPROTO_HTTPS (1L << 1) +#define CURLPROTO_FTP (1L << 2) +#define CURLPROTO_FTPS (1L << 3) +#define CURLPROTO_SCP (1L << 4) +#define CURLPROTO_SFTP (1L << 5) +#define CURLPROTO_TELNET (1L << 6) +#define CURLPROTO_LDAP (1L << 7) +#define CURLPROTO_LDAPS (1L << 8) +#define CURLPROTO_DICT (1L << 9) +#define CURLPROTO_FILE (1L << 10) +#define CURLPROTO_TFTP (1L << 11) +#define CURLPROTO_IMAP (1L << 12) +#define CURLPROTO_IMAPS (1L << 13) +#define CURLPROTO_POP3 (1L << 14) +#define CURLPROTO_POP3S (1L << 15) +#define CURLPROTO_SMTP (1L << 16) +#define CURLPROTO_SMTPS (1L << 17) +#define CURLPROTO_RTSP (1L << 18) +#define CURLPROTO_RTMP (1L << 19) +#define CURLPROTO_RTMPT (1L << 20) +#define CURLPROTO_RTMPE (1L << 21) +#define CURLPROTO_RTMPTE (1L << 22) +#define CURLPROTO_RTMPS (1L << 23) +#define CURLPROTO_RTMPTS (1L << 24) +#define CURLPROTO_GOPHER (1L << 25) +#define CURLPROTO_SMB (1L << 26) +#define CURLPROTO_SMBS (1L << 27) +#define CURLPROTO_MQTT (1L << 28) +#define CURLPROTO_GOPHERS (1L << 29) +#define CURLPROTO_ALL ((unsigned long)0xffffffff) /* old-style enable + "everything" */ + +/* long may be 32 or 64 bits, but we should never depend on anything else + but 32 */ +#define CURLOPTTYPE_LONG 0 +#define CURLOPTTYPE_OBJECTPOINT 10000 +#define CURLOPTTYPE_FUNCTIONPOINT 20000 +#define CURLOPTTYPE_OFF_T 30000 +#define CURLOPTTYPE_BLOB 40000 + +/* *STRINGPOINT is an alias for OBJECTPOINT to allow tools to extract the + string options from the header file */ + +#define CURLOPT(na, t, nu) na = ((t) + (nu)) +#define CURLOPTDEPRECATED(na, t, nu, v, m) na CURL_DEPRECATED(v, m) \ + = ((t) + (nu)) + +/* CURLOPT aliases that make no runtime difference */ + +/* 'char *' argument to a string with a trailing zero */ +#define CURLOPTTYPE_STRINGPOINT CURLOPTTYPE_OBJECTPOINT + +/* 'struct curl_slist *' argument */ +#define CURLOPTTYPE_SLISTPOINT CURLOPTTYPE_OBJECTPOINT + +/* 'void *' argument passed untouched to callback */ +#define CURLOPTTYPE_CBPOINT CURLOPTTYPE_OBJECTPOINT + +/* 'long' argument with a set of values/bitmask */ +#define CURLOPTTYPE_VALUES CURLOPTTYPE_LONG + +/* + * All CURLOPT_* values. + */ + +typedef enum { + /* This is the FILE * or void * the regular output should be written to. */ + CURLOPT(CURLOPT_WRITEDATA, CURLOPTTYPE_CBPOINT, 1), + + /* The full URL to get/put */ + CURLOPT(CURLOPT_URL, CURLOPTTYPE_STRINGPOINT, 2), + + /* Port number to connect to, if other than default. */ + CURLOPT(CURLOPT_PORT, CURLOPTTYPE_LONG, 3), + + /* Name of proxy to use. */ + CURLOPT(CURLOPT_PROXY, CURLOPTTYPE_STRINGPOINT, 4), + + /* "user:password;options" to use when fetching. */ + CURLOPT(CURLOPT_USERPWD, CURLOPTTYPE_STRINGPOINT, 5), + + /* "user:password" to use with proxy. */ + CURLOPT(CURLOPT_PROXYUSERPWD, CURLOPTTYPE_STRINGPOINT, 6), + + /* Range to get, specified as an ASCII string. */ + CURLOPT(CURLOPT_RANGE, CURLOPTTYPE_STRINGPOINT, 7), + + /* not used */ + + /* Specified file stream to upload from (use as input): */ + CURLOPT(CURLOPT_READDATA, CURLOPTTYPE_CBPOINT, 9), + + /* Buffer to receive error messages in, must be at least CURL_ERROR_SIZE + * bytes big. */ + CURLOPT(CURLOPT_ERRORBUFFER, CURLOPTTYPE_OBJECTPOINT, 10), + + /* Function that is called to store the output (instead of fwrite). The + * parameters use fwrite() syntax, make sure to follow them. */ + CURLOPT(CURLOPT_WRITEFUNCTION, CURLOPTTYPE_FUNCTIONPOINT, 11), + + /* Function that is called to read the input (instead of fread). The + * parameters use fread() syntax, make sure to follow them. */ + CURLOPT(CURLOPT_READFUNCTION, CURLOPTTYPE_FUNCTIONPOINT, 12), + + /* Time-out the read operation after this amount of seconds */ + CURLOPT(CURLOPT_TIMEOUT, CURLOPTTYPE_LONG, 13), + + /* If CURLOPT_READDATA is used, this can be used to inform libcurl about + * how large the file being sent really is. That allows better error + * checking and better verifies that the upload was successful. -1 means + * unknown size. + * + * For large file support, there is also a _LARGE version of the key + * which takes an off_t type, allowing platforms with larger off_t + * sizes to handle larger files. See below for INFILESIZE_LARGE. + */ + CURLOPT(CURLOPT_INFILESIZE, CURLOPTTYPE_LONG, 14), + + /* POST static input fields. */ + CURLOPT(CURLOPT_POSTFIELDS, CURLOPTTYPE_OBJECTPOINT, 15), + + /* Set the referrer page (needed by some CGIs) */ + CURLOPT(CURLOPT_REFERER, CURLOPTTYPE_STRINGPOINT, 16), + + /* Set the FTP PORT string (interface name, named or numerical IP address) + Use i.e '-' to use default address. */ + CURLOPT(CURLOPT_FTPPORT, CURLOPTTYPE_STRINGPOINT, 17), + + /* Set the User-Agent string (examined by some CGIs) */ + CURLOPT(CURLOPT_USERAGENT, CURLOPTTYPE_STRINGPOINT, 18), + + /* If the download receives less than "low speed limit" bytes/second + * during "low speed time" seconds, the operations is aborted. + * You could i.e if you have a pretty high speed connection, abort if + * it is less than 2000 bytes/sec during 20 seconds. + */ + + /* Set the "low speed limit" */ + CURLOPT(CURLOPT_LOW_SPEED_LIMIT, CURLOPTTYPE_LONG, 19), + + /* Set the "low speed time" */ + CURLOPT(CURLOPT_LOW_SPEED_TIME, CURLOPTTYPE_LONG, 20), + + /* Set the continuation offset. + * + * Note there is also a _LARGE version of this key which uses + * off_t types, allowing for large file offsets on platforms which + * use larger-than-32-bit off_t's. Look below for RESUME_FROM_LARGE. + */ + CURLOPT(CURLOPT_RESUME_FROM, CURLOPTTYPE_LONG, 21), + + /* Set cookie in request: */ + CURLOPT(CURLOPT_COOKIE, CURLOPTTYPE_STRINGPOINT, 22), + + /* This points to a linked list of headers, struct curl_slist kind. This + list is also used for RTSP (in spite of its name) */ + CURLOPT(CURLOPT_HTTPHEADER, CURLOPTTYPE_SLISTPOINT, 23), + + /* This points to a linked list of post entries, struct curl_httppost */ + CURLOPTDEPRECATED(CURLOPT_HTTPPOST, CURLOPTTYPE_OBJECTPOINT, 24, + 7.56.0, "Use CURLOPT_MIMEPOST"), + + /* name of the file keeping your private SSL-certificate */ + CURLOPT(CURLOPT_SSLCERT, CURLOPTTYPE_STRINGPOINT, 25), + + /* password for the SSL or SSH private key */ + CURLOPT(CURLOPT_KEYPASSWD, CURLOPTTYPE_STRINGPOINT, 26), + + /* send TYPE parameter? */ + CURLOPT(CURLOPT_CRLF, CURLOPTTYPE_LONG, 27), + + /* send linked-list of QUOTE commands */ + CURLOPT(CURLOPT_QUOTE, CURLOPTTYPE_SLISTPOINT, 28), + + /* send FILE * or void * to store headers to, if you use a callback it + is passed to the callback unmodified */ + CURLOPT(CURLOPT_HEADERDATA, CURLOPTTYPE_CBPOINT, 29), + + /* point to a file to read the initial cookies from, also enables + "cookie awareness" */ + CURLOPT(CURLOPT_COOKIEFILE, CURLOPTTYPE_STRINGPOINT, 31), + + /* What version to specifically try to use. + See CURL_SSLVERSION defines below. */ + CURLOPT(CURLOPT_SSLVERSION, CURLOPTTYPE_VALUES, 32), + + /* What kind of HTTP time condition to use, see defines */ + CURLOPT(CURLOPT_TIMECONDITION, CURLOPTTYPE_VALUES, 33), + + /* Time to use with the above condition. Specified in number of seconds + since 1 Jan 1970 */ + CURLOPT(CURLOPT_TIMEVALUE, CURLOPTTYPE_LONG, 34), + + /* 35 = OBSOLETE */ + + /* Custom request, for customizing the get command like + HTTP: DELETE, TRACE and others + FTP: to use a different list command + */ + CURLOPT(CURLOPT_CUSTOMREQUEST, CURLOPTTYPE_STRINGPOINT, 36), + + /* FILE handle to use instead of stderr */ + CURLOPT(CURLOPT_STDERR, CURLOPTTYPE_OBJECTPOINT, 37), + + /* 38 is not used */ + + /* send linked-list of post-transfer QUOTE commands */ + CURLOPT(CURLOPT_POSTQUOTE, CURLOPTTYPE_SLISTPOINT, 39), + + /* 40 is not used */ + + /* talk a lot */ + CURLOPT(CURLOPT_VERBOSE, CURLOPTTYPE_LONG, 41), + + /* throw the header out too */ + CURLOPT(CURLOPT_HEADER, CURLOPTTYPE_LONG, 42), + + /* shut off the progress meter */ + CURLOPT(CURLOPT_NOPROGRESS, CURLOPTTYPE_LONG, 43), + + /* use HEAD to get http document */ + CURLOPT(CURLOPT_NOBODY, CURLOPTTYPE_LONG, 44), + + /* no output on http error codes >= 400 */ + CURLOPT(CURLOPT_FAILONERROR, CURLOPTTYPE_LONG, 45), + + /* this is an upload */ + CURLOPT(CURLOPT_UPLOAD, CURLOPTTYPE_LONG, 46), + + /* HTTP POST method */ + CURLOPT(CURLOPT_POST, CURLOPTTYPE_LONG, 47), + + /* bare names when listing directories */ + CURLOPT(CURLOPT_DIRLISTONLY, CURLOPTTYPE_LONG, 48), + + /* Append instead of overwrite on upload! */ + CURLOPT(CURLOPT_APPEND, CURLOPTTYPE_LONG, 50), + + /* Specify whether to read the user+password from the .netrc or the URL. + * This must be one of the CURL_NETRC_* enums below. */ + CURLOPT(CURLOPT_NETRC, CURLOPTTYPE_VALUES, 51), + + /* use Location: Luke! */ + CURLOPT(CURLOPT_FOLLOWLOCATION, CURLOPTTYPE_LONG, 52), + + /* transfer data in text/ASCII format */ + CURLOPT(CURLOPT_TRANSFERTEXT, CURLOPTTYPE_LONG, 53), + + /* HTTP PUT */ + CURLOPTDEPRECATED(CURLOPT_PUT, CURLOPTTYPE_LONG, 54, + 7.12.1, "Use CURLOPT_UPLOAD"), + + /* 55 = OBSOLETE */ + + /* DEPRECATED + * Function that is called instead of the internal progress display + * function. This function should be defined as the curl_progress_callback + * prototype defines. */ + CURLOPTDEPRECATED(CURLOPT_PROGRESSFUNCTION, CURLOPTTYPE_FUNCTIONPOINT, 56, + 7.32.0, "Use CURLOPT_XFERINFOFUNCTION"), + + /* Data passed to the CURLOPT_PROGRESSFUNCTION and CURLOPT_XFERINFOFUNCTION + callbacks */ + CURLOPT(CURLOPT_XFERINFODATA, CURLOPTTYPE_CBPOINT, 57), +#define CURLOPT_PROGRESSDATA CURLOPT_XFERINFODATA + + /* We want the referrer field set automatically when following locations */ + CURLOPT(CURLOPT_AUTOREFERER, CURLOPTTYPE_LONG, 58), + + /* Port of the proxy, can be set in the proxy string as well with: + "[host]:[port]" */ + CURLOPT(CURLOPT_PROXYPORT, CURLOPTTYPE_LONG, 59), + + /* size of the POST input data, if strlen() is not good to use */ + CURLOPT(CURLOPT_POSTFIELDSIZE, CURLOPTTYPE_LONG, 60), + + /* tunnel non-http operations through an HTTP proxy */ + CURLOPT(CURLOPT_HTTPPROXYTUNNEL, CURLOPTTYPE_LONG, 61), + + /* Set the interface string to use as outgoing network interface */ + CURLOPT(CURLOPT_INTERFACE, CURLOPTTYPE_STRINGPOINT, 62), + + /* Set the krb4/5 security level, this also enables krb4/5 awareness. This + * is a string, 'clear', 'safe', 'confidential' or 'private'. If the string + * is set but does not match one of these, 'private' is used. */ + CURLOPTDEPRECATED(CURLOPT_KRBLEVEL, CURLOPTTYPE_STRINGPOINT, 63, + 8.17.0, "removed"), + + /* Set if we should verify the peer in SSL handshake, set 1 to verify. */ + CURLOPT(CURLOPT_SSL_VERIFYPEER, CURLOPTTYPE_LONG, 64), + + /* The CApath or CAfile used to validate the peer certificate + this option is used only if SSL_VERIFYPEER is true */ + CURLOPT(CURLOPT_CAINFO, CURLOPTTYPE_STRINGPOINT, 65), + + /* 66 = OBSOLETE */ + /* 67 = OBSOLETE */ + + /* Maximum number of http redirects to follow */ + CURLOPT(CURLOPT_MAXREDIRS, CURLOPTTYPE_LONG, 68), + + /* Pass a long set to 1 to get the date of the requested document (if + possible)! Pass a zero to shut it off. */ + CURLOPT(CURLOPT_FILETIME, CURLOPTTYPE_LONG, 69), + + /* This points to a linked list of telnet options */ + CURLOPT(CURLOPT_TELNETOPTIONS, CURLOPTTYPE_SLISTPOINT, 70), + + /* Max amount of cached alive connections */ + CURLOPT(CURLOPT_MAXCONNECTS, CURLOPTTYPE_LONG, 71), + + /* 72 = OBSOLETE */ + /* 73 = OBSOLETE */ + + /* Set to explicitly use a new connection for the upcoming transfer. + Do not use this unless you are absolutely sure of this, as it makes the + operation slower and is less friendly for the network. */ + CURLOPT(CURLOPT_FRESH_CONNECT, CURLOPTTYPE_LONG, 74), + + /* Set to explicitly forbid the upcoming transfer's connection to be reused + when done. Do not use this unless you are absolutely sure of this, as it + makes the operation slower and is less friendly for the network. */ + CURLOPT(CURLOPT_FORBID_REUSE, CURLOPTTYPE_LONG, 75), + + /* Set to a filename that contains random data for libcurl to use to + seed the random engine when doing SSL connects. */ + CURLOPTDEPRECATED(CURLOPT_RANDOM_FILE, CURLOPTTYPE_STRINGPOINT, 76, + 7.84.0, "Serves no purpose anymore"), + + /* Set to the Entropy Gathering Daemon socket pathname */ + CURLOPTDEPRECATED(CURLOPT_EGDSOCKET, CURLOPTTYPE_STRINGPOINT, 77, + 7.84.0, "Serves no purpose anymore"), + + /* Time-out connect operations after this amount of seconds, if connects are + OK within this time, then fine... This only aborts the connect phase. */ + CURLOPT(CURLOPT_CONNECTTIMEOUT, CURLOPTTYPE_LONG, 78), + + /* Function that is called to store headers (instead of fwrite). The + * parameters use fwrite() syntax, make sure to follow them. */ + CURLOPT(CURLOPT_HEADERFUNCTION, CURLOPTTYPE_FUNCTIONPOINT, 79), + + /* Set this to force the HTTP request to get back to GET. Only really usable + if POST, PUT or a custom request have been used first. + */ + CURLOPT(CURLOPT_HTTPGET, CURLOPTTYPE_LONG, 80), + + /* Set if we should verify the Common name from the peer certificate in SSL + * handshake, set 1 to check existence, 2 to ensure that it matches the + * provided hostname. */ + CURLOPT(CURLOPT_SSL_VERIFYHOST, CURLOPTTYPE_LONG, 81), + + /* Specify which filename to write all known cookies in after completed + operation. Set filename to "-" (dash) to make it go to stdout. */ + CURLOPT(CURLOPT_COOKIEJAR, CURLOPTTYPE_STRINGPOINT, 82), + + /* Specify which TLS 1.2 (1.1, 1.0) ciphers to use */ + CURLOPT(CURLOPT_SSL_CIPHER_LIST, CURLOPTTYPE_STRINGPOINT, 83), + + /* Specify which HTTP version to use! This must be set to one of the + CURL_HTTP_VERSION* enums set below. */ + CURLOPT(CURLOPT_HTTP_VERSION, CURLOPTTYPE_VALUES, 84), + + /* Specifically switch on or off the FTP engine's use of the EPSV command. By + default, that one is always attempted before the more traditional + PASV command. */ + CURLOPT(CURLOPT_FTP_USE_EPSV, CURLOPTTYPE_LONG, 85), + + /* type of the file keeping your SSL-certificate ("DER", "PEM", "ENG") */ + CURLOPT(CURLOPT_SSLCERTTYPE, CURLOPTTYPE_STRINGPOINT, 86), + + /* name of the file keeping your private SSL-key */ + CURLOPT(CURLOPT_SSLKEY, CURLOPTTYPE_STRINGPOINT, 87), + + /* type of the file keeping your private SSL-key ("DER", "PEM", "ENG") */ + CURLOPT(CURLOPT_SSLKEYTYPE, CURLOPTTYPE_STRINGPOINT, 88), + + /* crypto engine for the SSL-sub system */ + CURLOPT(CURLOPT_SSLENGINE, CURLOPTTYPE_STRINGPOINT, 89), + + /* set the crypto engine for the SSL-sub system as default + the param has no meaning... + */ + CURLOPT(CURLOPT_SSLENGINE_DEFAULT, CURLOPTTYPE_LONG, 90), + + /* Non-zero value means to use the global dns cache */ + /* DEPRECATED, do not use! */ + CURLOPTDEPRECATED(CURLOPT_DNS_USE_GLOBAL_CACHE, CURLOPTTYPE_LONG, 91, + 7.11.1, "Use CURLOPT_SHARE"), + + /* DNS cache timeout */ + CURLOPT(CURLOPT_DNS_CACHE_TIMEOUT, CURLOPTTYPE_LONG, 92), + + /* send linked-list of pre-transfer QUOTE commands */ + CURLOPT(CURLOPT_PREQUOTE, CURLOPTTYPE_SLISTPOINT, 93), + + /* set the debug function */ + CURLOPT(CURLOPT_DEBUGFUNCTION, CURLOPTTYPE_FUNCTIONPOINT, 94), + + /* set the data for the debug function */ + CURLOPT(CURLOPT_DEBUGDATA, CURLOPTTYPE_CBPOINT, 95), + + /* mark this as start of a cookie session */ + CURLOPT(CURLOPT_COOKIESESSION, CURLOPTTYPE_LONG, 96), + + /* The CApath directory used to validate the peer certificate + this option is used only if SSL_VERIFYPEER is true */ + CURLOPT(CURLOPT_CAPATH, CURLOPTTYPE_STRINGPOINT, 97), + + /* Instruct libcurl to use a smaller receive buffer */ + CURLOPT(CURLOPT_BUFFERSIZE, CURLOPTTYPE_LONG, 98), + + /* Instruct libcurl to not use any signal/alarm handlers, even when using + timeouts. This option is useful for multi-threaded applications. + See libcurl-the-guide for more background information. */ + CURLOPT(CURLOPT_NOSIGNAL, CURLOPTTYPE_LONG, 99), + + /* Provide a CURLShare for mutexing non-ts data */ + CURLOPT(CURLOPT_SHARE, CURLOPTTYPE_OBJECTPOINT, 100), + + /* indicates type of proxy. accepted values are CURLPROXY_HTTP (default), + CURLPROXY_HTTPS, CURLPROXY_HTTPS2, CURLPROXY_HTTPS3, CURLPROXY_SOCKS4, + CURLPROXY_SOCKS4A and CURLPROXY_SOCKS5. */ + CURLOPT(CURLOPT_PROXYTYPE, CURLOPTTYPE_VALUES, 101), + + /* Set the Accept-Encoding string. Use this to tell a server you would like + the response to be compressed. Before 7.21.6, this was known as + CURLOPT_ENCODING */ + CURLOPT(CURLOPT_ACCEPT_ENCODING, CURLOPTTYPE_STRINGPOINT, 102), + + /* Set pointer to private data */ + CURLOPT(CURLOPT_PRIVATE, CURLOPTTYPE_OBJECTPOINT, 103), + + /* Set aliases for HTTP 200 in the HTTP Response header */ + CURLOPT(CURLOPT_HTTP200ALIASES, CURLOPTTYPE_SLISTPOINT, 104), + + /* Continue to send authentication (user+password) when following locations, + even when hostname changed. This can potentially send off the name + and password to whatever host the server decides. */ + CURLOPT(CURLOPT_UNRESTRICTED_AUTH, CURLOPTTYPE_LONG, 105), + + /* Specifically switch on or off the FTP engine's use of the EPRT command ( + it also disables the LPRT attempt). By default, those ones are always + attempted before the good old traditional PORT command. */ + CURLOPT(CURLOPT_FTP_USE_EPRT, CURLOPTTYPE_LONG, 106), + + /* Set this to a bitmask value to enable the particular authentications + methods you like. Use this in combination with CURLOPT_USERPWD. + Note that setting multiple bits may cause extra network round-trips. */ + CURLOPT(CURLOPT_HTTPAUTH, CURLOPTTYPE_VALUES, 107), + + /* Set the SSL context callback function, currently only for OpenSSL or + wolfSSL ssl_ctx, or mbedTLS mbedtls_ssl_config in the second argument. + The function must match the curl_ssl_ctx_callback prototype. */ + CURLOPT(CURLOPT_SSL_CTX_FUNCTION, CURLOPTTYPE_FUNCTIONPOINT, 108), + + /* Set the userdata for the SSL context callback function's third + argument */ + CURLOPT(CURLOPT_SSL_CTX_DATA, CURLOPTTYPE_CBPOINT, 109), + + /* FTP Option that causes missing dirs to be created on the remote server. + In 7.19.4 we introduced the convenience enums for this option using the + CURLFTP_CREATE_DIR prefix. + */ + CURLOPT(CURLOPT_FTP_CREATE_MISSING_DIRS, CURLOPTTYPE_LONG, 110), + + /* Set this to a bitmask value to enable the particular authentications + methods you like. Use this in combination with CURLOPT_PROXYUSERPWD. + Note that setting multiple bits may cause extra network round-trips. */ + CURLOPT(CURLOPT_PROXYAUTH, CURLOPTTYPE_VALUES, 111), + + /* Option that changes the timeout, in seconds, associated with getting a + response. This is different from transfer timeout time and essentially + places a demand on the server to acknowledge commands in a timely + manner. For FTP, SMTP, IMAP and POP3. */ + CURLOPT(CURLOPT_SERVER_RESPONSE_TIMEOUT, CURLOPTTYPE_LONG, 112), + + /* Set this option to one of the CURL_IPRESOLVE_* defines (see below) to + tell libcurl to use those IP versions only. This only has effect on + systems with support for more than one, i.e IPv4 _and_ IPv6. */ + CURLOPT(CURLOPT_IPRESOLVE, CURLOPTTYPE_VALUES, 113), + + /* Set this option to limit the size of a file that is to be downloaded from + an HTTP or FTP server. + + Note there is also _LARGE version which adds large file support for + platforms which have larger off_t sizes. See MAXFILESIZE_LARGE below. */ + CURLOPT(CURLOPT_MAXFILESIZE, CURLOPTTYPE_LONG, 114), + + /* See the comment for INFILESIZE above, but in short, specifies + * the size of the file being uploaded. -1 means unknown. + */ + CURLOPT(CURLOPT_INFILESIZE_LARGE, CURLOPTTYPE_OFF_T, 115), + + /* Sets the continuation offset. There is also a CURLOPTTYPE_LONG version + * of this; look above for RESUME_FROM. + */ + CURLOPT(CURLOPT_RESUME_FROM_LARGE, CURLOPTTYPE_OFF_T, 116), + + /* Sets the maximum size of data that is to be downloaded from + * an HTTP or FTP server. See MAXFILESIZE above for the LONG version. + */ + CURLOPT(CURLOPT_MAXFILESIZE_LARGE, CURLOPTTYPE_OFF_T, 117), + + /* Set this option to the filename of your .netrc file you want libcurl + to parse (using the CURLOPT_NETRC option). If not set, libcurl does + a poor attempt to find the user's home directory and check for a .netrc + file in there. */ + CURLOPT(CURLOPT_NETRC_FILE, CURLOPTTYPE_STRINGPOINT, 118), + + /* Enable SSL/TLS for FTP, pick one of: + CURLUSESSL_TRY - try using SSL, proceed anyway otherwise + CURLUSESSL_CONTROL - SSL for the control connection or fail + CURLUSESSL_ALL - SSL for all communication or fail + */ + CURLOPT(CURLOPT_USE_SSL, CURLOPTTYPE_VALUES, 119), + + /* The _LARGE version of the standard POSTFIELDSIZE option */ + CURLOPT(CURLOPT_POSTFIELDSIZE_LARGE, CURLOPTTYPE_OFF_T, 120), + + /* Enable/disable the TCP Nagle algorithm */ + CURLOPT(CURLOPT_TCP_NODELAY, CURLOPTTYPE_LONG, 121), + + /* 122 OBSOLETE, used in 7.12.3. Gone in 7.13.0 */ + /* 123 OBSOLETE. Gone in 7.16.0 */ + /* 124 OBSOLETE, used in 7.12.3. Gone in 7.13.0 */ + /* 125 OBSOLETE, used in 7.12.3. Gone in 7.13.0 */ + /* 126 OBSOLETE, used in 7.12.3. Gone in 7.13.0 */ + /* 127 OBSOLETE. Gone in 7.16.0 */ + /* 128 OBSOLETE. Gone in 7.16.0 */ + + /* When FTP over SSL/TLS is selected (with CURLOPT_USE_SSL), this option + can be used to change libcurl's default action which is to first try + "AUTH SSL" and then "AUTH TLS" in this order, and proceed when a OK + response has been received. + + Available parameters are: + CURLFTPAUTH_DEFAULT - let libcurl decide + CURLFTPAUTH_SSL - try "AUTH SSL" first, then TLS + CURLFTPAUTH_TLS - try "AUTH TLS" first, then SSL + */ + CURLOPT(CURLOPT_FTPSSLAUTH, CURLOPTTYPE_VALUES, 129), + + CURLOPTDEPRECATED(CURLOPT_IOCTLFUNCTION, CURLOPTTYPE_FUNCTIONPOINT, 130, + 7.18.0, "Use CURLOPT_SEEKFUNCTION"), + CURLOPTDEPRECATED(CURLOPT_IOCTLDATA, CURLOPTTYPE_CBPOINT, 131, + 7.18.0, "Use CURLOPT_SEEKDATA"), + + /* 132 OBSOLETE. Gone in 7.16.0 */ + /* 133 OBSOLETE. Gone in 7.16.0 */ + + /* null-terminated string for pass on to the FTP server when asked for + "account" info */ + CURLOPT(CURLOPT_FTP_ACCOUNT, CURLOPTTYPE_STRINGPOINT, 134), + + /* feed cookie into cookie engine */ + CURLOPT(CURLOPT_COOKIELIST, CURLOPTTYPE_STRINGPOINT, 135), + + /* ignore Content-Length */ + CURLOPT(CURLOPT_IGNORE_CONTENT_LENGTH, CURLOPTTYPE_LONG, 136), + + /* Set to non-zero to skip the IP address received in a 227 PASV FTP server + response. Typically used for FTP-SSL purposes but is not restricted to + that. libcurl is then instead using the same IP address it used for the + control connection. */ + CURLOPT(CURLOPT_FTP_SKIP_PASV_IP, CURLOPTTYPE_LONG, 137), + + /* Select "file method" to use when doing FTP, see the curl_ftpmethod + above. */ + CURLOPT(CURLOPT_FTP_FILEMETHOD, CURLOPTTYPE_VALUES, 138), + + /* Local port number to bind the socket to */ + CURLOPT(CURLOPT_LOCALPORT, CURLOPTTYPE_LONG, 139), + + /* Number of ports to try, including the first one set with LOCALPORT. + Thus, setting it to 1 makes no additional attempts but the first. + */ + CURLOPT(CURLOPT_LOCALPORTRANGE, CURLOPTTYPE_LONG, 140), + + /* no transfer, set up connection and let application use the socket by + extracting it with CURLINFO_LASTSOCKET */ + CURLOPT(CURLOPT_CONNECT_ONLY, CURLOPTTYPE_LONG, 141), + + /* Function that is called to convert from the + network encoding (instead of using the iconv calls in libcurl) */ + CURLOPTDEPRECATED(CURLOPT_CONV_FROM_NETWORK_FUNCTION, + CURLOPTTYPE_FUNCTIONPOINT, 142, + 7.82.0, "Serves no purpose anymore"), + + /* Function that is called to convert to the + network encoding (instead of using the iconv calls in libcurl) */ + CURLOPTDEPRECATED(CURLOPT_CONV_TO_NETWORK_FUNCTION, + CURLOPTTYPE_FUNCTIONPOINT, 143, + 7.82.0, "Serves no purpose anymore"), + + /* Function that is called to convert from UTF8 + (instead of using the iconv calls in libcurl) + Note that this is used only for SSL certificate processing */ + CURLOPTDEPRECATED(CURLOPT_CONV_FROM_UTF8_FUNCTION, + CURLOPTTYPE_FUNCTIONPOINT, 144, + 7.82.0, "Serves no purpose anymore"), + + /* if the connection proceeds too quickly then need to slow it down */ + /* limit-rate: maximum number of bytes per second to send or receive */ + CURLOPT(CURLOPT_MAX_SEND_SPEED_LARGE, CURLOPTTYPE_OFF_T, 145), + CURLOPT(CURLOPT_MAX_RECV_SPEED_LARGE, CURLOPTTYPE_OFF_T, 146), + + /* Pointer to command string to send if USER/PASS fails. */ + CURLOPT(CURLOPT_FTP_ALTERNATIVE_TO_USER, CURLOPTTYPE_STRINGPOINT, 147), + + /* callback function for setting socket options */ + CURLOPT(CURLOPT_SOCKOPTFUNCTION, CURLOPTTYPE_FUNCTIONPOINT, 148), + CURLOPT(CURLOPT_SOCKOPTDATA, CURLOPTTYPE_CBPOINT, 149), + + /* set to 0 to disable session ID reuse for this transfer, default is + enabled (== 1) */ + CURLOPT(CURLOPT_SSL_SESSIONID_CACHE, CURLOPTTYPE_LONG, 150), + + /* allowed SSH authentication methods */ + CURLOPT(CURLOPT_SSH_AUTH_TYPES, CURLOPTTYPE_VALUES, 151), + + /* Used by scp/sftp to do public/private key authentication */ + CURLOPT(CURLOPT_SSH_PUBLIC_KEYFILE, CURLOPTTYPE_STRINGPOINT, 152), + CURLOPT(CURLOPT_SSH_PRIVATE_KEYFILE, CURLOPTTYPE_STRINGPOINT, 153), + + /* Send CCC (Clear Command Channel) after authentication */ + CURLOPT(CURLOPT_FTP_SSL_CCC, CURLOPTTYPE_LONG, 154), + + /* Same as TIMEOUT and CONNECTTIMEOUT, but with ms resolution */ + CURLOPT(CURLOPT_TIMEOUT_MS, CURLOPTTYPE_LONG, 155), + CURLOPT(CURLOPT_CONNECTTIMEOUT_MS, CURLOPTTYPE_LONG, 156), + + /* set to zero to disable the libcurl's decoding and thus pass the raw body + data to the application even when it is encoded/compressed */ + CURLOPT(CURLOPT_HTTP_TRANSFER_DECODING, CURLOPTTYPE_LONG, 157), + CURLOPT(CURLOPT_HTTP_CONTENT_DECODING, CURLOPTTYPE_LONG, 158), + + /* Permission used when creating new files and directories on the remote + server for protocols that support it, SFTP/SCP/FILE */ + CURLOPT(CURLOPT_NEW_FILE_PERMS, CURLOPTTYPE_LONG, 159), + CURLOPT(CURLOPT_NEW_DIRECTORY_PERMS, CURLOPTTYPE_LONG, 160), + + /* Set the behavior of POST when redirecting. Values must be set to one + of CURL_REDIR* defines below. This used to be called CURLOPT_POST301 */ + CURLOPT(CURLOPT_POSTREDIR, CURLOPTTYPE_VALUES, 161), + + /* used by scp/sftp to verify the host's public key */ + CURLOPT(CURLOPT_SSH_HOST_PUBLIC_KEY_MD5, CURLOPTTYPE_STRINGPOINT, 162), + + /* Callback function for opening socket (instead of socket(2)). Optionally, + callback is able change the address or refuse to connect returning + CURL_SOCKET_BAD. The callback should have type + curl_opensocket_callback */ + CURLOPT(CURLOPT_OPENSOCKETFUNCTION, CURLOPTTYPE_FUNCTIONPOINT, 163), + CURLOPT(CURLOPT_OPENSOCKETDATA, CURLOPTTYPE_CBPOINT, 164), + + /* POST volatile input fields. */ + CURLOPT(CURLOPT_COPYPOSTFIELDS, CURLOPTTYPE_OBJECTPOINT, 165), + + /* set transfer mode (;type=) when doing FTP via an HTTP proxy */ + CURLOPT(CURLOPT_PROXY_TRANSFER_MODE, CURLOPTTYPE_LONG, 166), + + /* Callback function for seeking in the input stream */ + CURLOPT(CURLOPT_SEEKFUNCTION, CURLOPTTYPE_FUNCTIONPOINT, 167), + CURLOPT(CURLOPT_SEEKDATA, CURLOPTTYPE_CBPOINT, 168), + + /* CRL file */ + CURLOPT(CURLOPT_CRLFILE, CURLOPTTYPE_STRINGPOINT, 169), + + /* Issuer certificate */ + CURLOPT(CURLOPT_ISSUERCERT, CURLOPTTYPE_STRINGPOINT, 170), + + /* (IPv6) Address scope */ + CURLOPT(CURLOPT_ADDRESS_SCOPE, CURLOPTTYPE_LONG, 171), + + /* Collect certificate chain info and allow it to get retrievable with + CURLINFO_CERTINFO after the transfer is complete. */ + CURLOPT(CURLOPT_CERTINFO, CURLOPTTYPE_LONG, 172), + + /* "name" and "pwd" to use when fetching. */ + CURLOPT(CURLOPT_USERNAME, CURLOPTTYPE_STRINGPOINT, 173), + CURLOPT(CURLOPT_PASSWORD, CURLOPTTYPE_STRINGPOINT, 174), + + /* "name" and "pwd" to use with Proxy when fetching. */ + CURLOPT(CURLOPT_PROXYUSERNAME, CURLOPTTYPE_STRINGPOINT, 175), + CURLOPT(CURLOPT_PROXYPASSWORD, CURLOPTTYPE_STRINGPOINT, 176), + + /* Comma separated list of hostnames defining no-proxy zones. These should + match both hostnames directly, and hostnames within a domain. For + example, local.com matches local.com and www.local.com, but NOT + notlocal.com or www.notlocal.com. For compatibility with other + implementations of this, .local.com is considered to be the same as + local.com. A single * is the only valid wildcard, and effectively + disables the use of proxy. */ + CURLOPT(CURLOPT_NOPROXY, CURLOPTTYPE_STRINGPOINT, 177), + + /* block size for TFTP transfers */ + CURLOPT(CURLOPT_TFTP_BLKSIZE, CURLOPTTYPE_LONG, 178), + + /* Socks Service */ + /* DEPRECATED, do not use! */ + CURLOPTDEPRECATED(CURLOPT_SOCKS5_GSSAPI_SERVICE, + CURLOPTTYPE_STRINGPOINT, 179, + 7.49.0, "Use CURLOPT_PROXY_SERVICE_NAME"), + + /* Socks Service */ + CURLOPT(CURLOPT_SOCKS5_GSSAPI_NEC, CURLOPTTYPE_LONG, 180), + + /* set the bitmask for the protocols that are allowed to be used for the + transfer, which thus helps the app which takes URLs from users or other + external inputs and want to restrict what protocol(s) to deal + with. Defaults to CURLPROTO_ALL. */ + CURLOPTDEPRECATED(CURLOPT_PROTOCOLS, CURLOPTTYPE_LONG, 181, + 7.85.0, "Use CURLOPT_PROTOCOLS_STR"), + + /* set the bitmask for the protocols that libcurl is allowed to follow to, + as a subset of the CURLOPT_PROTOCOLS ones. That means the protocol needs + to be set in both bitmasks to be allowed to get redirected to. */ + CURLOPTDEPRECATED(CURLOPT_REDIR_PROTOCOLS, CURLOPTTYPE_LONG, 182, + 7.85.0, "Use CURLOPT_REDIR_PROTOCOLS_STR"), + + /* set the SSH knownhost filename to use */ + CURLOPT(CURLOPT_SSH_KNOWNHOSTS, CURLOPTTYPE_STRINGPOINT, 183), + + /* set the SSH host key callback, must point to a curl_sshkeycallback + function */ + CURLOPT(CURLOPT_SSH_KEYFUNCTION, CURLOPTTYPE_FUNCTIONPOINT, 184), + + /* set the SSH host key callback custom pointer */ + CURLOPT(CURLOPT_SSH_KEYDATA, CURLOPTTYPE_CBPOINT, 185), + + /* set the SMTP mail originator */ + CURLOPT(CURLOPT_MAIL_FROM, CURLOPTTYPE_STRINGPOINT, 186), + + /* set the list of SMTP mail receiver(s) */ + CURLOPT(CURLOPT_MAIL_RCPT, CURLOPTTYPE_SLISTPOINT, 187), + + /* FTP: send PRET before PASV */ + CURLOPT(CURLOPT_FTP_USE_PRET, CURLOPTTYPE_LONG, 188), + + /* RTSP request method (OPTIONS, SETUP, PLAY, etc...) */ + CURLOPT(CURLOPT_RTSP_REQUEST, CURLOPTTYPE_VALUES, 189), + + /* The RTSP session identifier */ + CURLOPT(CURLOPT_RTSP_SESSION_ID, CURLOPTTYPE_STRINGPOINT, 190), + + /* The RTSP stream URI */ + CURLOPT(CURLOPT_RTSP_STREAM_URI, CURLOPTTYPE_STRINGPOINT, 191), + + /* The Transport: header to use in RTSP requests */ + CURLOPT(CURLOPT_RTSP_TRANSPORT, CURLOPTTYPE_STRINGPOINT, 192), + + /* Manually initialize the client RTSP CSeq for this handle */ + CURLOPT(CURLOPT_RTSP_CLIENT_CSEQ, CURLOPTTYPE_LONG, 193), + + /* Manually initialize the server RTSP CSeq for this handle */ + CURLOPT(CURLOPT_RTSP_SERVER_CSEQ, CURLOPTTYPE_LONG, 194), + + /* The stream to pass to INTERLEAVEFUNCTION. */ + CURLOPT(CURLOPT_INTERLEAVEDATA, CURLOPTTYPE_CBPOINT, 195), + + /* Let the application define a custom write method for RTP data */ + CURLOPT(CURLOPT_INTERLEAVEFUNCTION, CURLOPTTYPE_FUNCTIONPOINT, 196), + + /* Turn on wildcard matching */ + CURLOPT(CURLOPT_WILDCARDMATCH, CURLOPTTYPE_LONG, 197), + + /* Directory matching callback called before downloading of an + individual file (chunk) started */ + CURLOPT(CURLOPT_CHUNK_BGN_FUNCTION, CURLOPTTYPE_FUNCTIONPOINT, 198), + + /* Directory matching callback called after the file (chunk) + was downloaded, or skipped */ + CURLOPT(CURLOPT_CHUNK_END_FUNCTION, CURLOPTTYPE_FUNCTIONPOINT, 199), + + /* Change match (fnmatch-like) callback for wildcard matching */ + CURLOPT(CURLOPT_FNMATCH_FUNCTION, CURLOPTTYPE_FUNCTIONPOINT, 200), + + /* Let the application define custom chunk data pointer */ + CURLOPT(CURLOPT_CHUNK_DATA, CURLOPTTYPE_CBPOINT, 201), + + /* FNMATCH_FUNCTION user pointer */ + CURLOPT(CURLOPT_FNMATCH_DATA, CURLOPTTYPE_CBPOINT, 202), + + /* send linked-list of name:port:address sets */ + CURLOPT(CURLOPT_RESOLVE, CURLOPTTYPE_SLISTPOINT, 203), + + /* Set a username for authenticated TLS */ + CURLOPT(CURLOPT_TLSAUTH_USERNAME, CURLOPTTYPE_STRINGPOINT, 204), + + /* Set a password for authenticated TLS */ + CURLOPT(CURLOPT_TLSAUTH_PASSWORD, CURLOPTTYPE_STRINGPOINT, 205), + + /* Set authentication type for authenticated TLS */ + CURLOPT(CURLOPT_TLSAUTH_TYPE, CURLOPTTYPE_STRINGPOINT, 206), + + /* Set to 1 to enable the "TE:" header in HTTP requests to ask for + compressed transfer-encoded responses. Set to 0 to disable the use of TE: + in outgoing requests. The current default is 0, but it might change in a + future libcurl release. + + libcurl asks for the compressed methods it knows of, and if that + is not any, it does not ask for transfer-encoding at all even if this + option is set to 1. */ + CURLOPT(CURLOPT_TRANSFER_ENCODING, CURLOPTTYPE_LONG, 207), + + /* Callback function for closing socket (instead of close(2)). The callback + should have type curl_closesocket_callback */ + CURLOPT(CURLOPT_CLOSESOCKETFUNCTION, CURLOPTTYPE_FUNCTIONPOINT, 208), + CURLOPT(CURLOPT_CLOSESOCKETDATA, CURLOPTTYPE_CBPOINT, 209), + + /* allow GSSAPI credential delegation */ + CURLOPT(CURLOPT_GSSAPI_DELEGATION, CURLOPTTYPE_VALUES, 210), + + /* Set the name servers to use for DNS resolution. + * Only supported by the c-ares DNS backend */ + CURLOPT(CURLOPT_DNS_SERVERS, CURLOPTTYPE_STRINGPOINT, 211), + + /* Time-out accept operations (currently for FTP only) after this amount + of milliseconds. */ + CURLOPT(CURLOPT_ACCEPTTIMEOUT_MS, CURLOPTTYPE_LONG, 212), + + /* Set TCP keepalive */ + CURLOPT(CURLOPT_TCP_KEEPALIVE, CURLOPTTYPE_LONG, 213), + + /* non-universal keepalive knobs (Linux, AIX, HP-UX, more) */ + CURLOPT(CURLOPT_TCP_KEEPIDLE, CURLOPTTYPE_LONG, 214), + CURLOPT(CURLOPT_TCP_KEEPINTVL, CURLOPTTYPE_LONG, 215), + + /* Enable/disable specific SSL features with a bitmask, see CURLSSLOPT_* */ + CURLOPT(CURLOPT_SSL_OPTIONS, CURLOPTTYPE_VALUES, 216), + + /* Set the SMTP auth originator */ + CURLOPT(CURLOPT_MAIL_AUTH, CURLOPTTYPE_STRINGPOINT, 217), + + /* Enable/disable SASL initial response */ + CURLOPT(CURLOPT_SASL_IR, CURLOPTTYPE_LONG, 218), + + /* Function that is called instead of the internal progress display + * function. This function should be defined as the curl_xferinfo_callback + * prototype defines. (Deprecates CURLOPT_PROGRESSFUNCTION) */ + CURLOPT(CURLOPT_XFERINFOFUNCTION, CURLOPTTYPE_FUNCTIONPOINT, 219), + + /* The XOAUTH2 bearer token */ + CURLOPT(CURLOPT_XOAUTH2_BEARER, CURLOPTTYPE_STRINGPOINT, 220), + + /* Set the interface string to use as outgoing network + * interface for DNS requests. + * Only supported by the c-ares DNS backend */ + CURLOPT(CURLOPT_DNS_INTERFACE, CURLOPTTYPE_STRINGPOINT, 221), + + /* Set the local IPv4 address to use for outgoing DNS requests. + * Only supported by the c-ares DNS backend */ + CURLOPT(CURLOPT_DNS_LOCAL_IP4, CURLOPTTYPE_STRINGPOINT, 222), + + /* Set the local IPv6 address to use for outgoing DNS requests. + * Only supported by the c-ares DNS backend */ + CURLOPT(CURLOPT_DNS_LOCAL_IP6, CURLOPTTYPE_STRINGPOINT, 223), + + /* Set authentication options directly */ + CURLOPT(CURLOPT_LOGIN_OPTIONS, CURLOPTTYPE_STRINGPOINT, 224), + + /* Enable/disable TLS NPN extension (http2 over SSL might fail without) */ + CURLOPTDEPRECATED(CURLOPT_SSL_ENABLE_NPN, CURLOPTTYPE_LONG, 225, + 7.86.0, "Has no function"), + + /* Enable/disable TLS ALPN extension (http2 over SSL might fail without) */ + CURLOPT(CURLOPT_SSL_ENABLE_ALPN, CURLOPTTYPE_LONG, 226), + + /* Time to wait for a response to an HTTP request containing an + * Expect: 100-continue header before sending the data anyway. */ + CURLOPT(CURLOPT_EXPECT_100_TIMEOUT_MS, CURLOPTTYPE_LONG, 227), + + /* This points to a linked list of headers used for proxy requests only, + struct curl_slist kind */ + CURLOPT(CURLOPT_PROXYHEADER, CURLOPTTYPE_SLISTPOINT, 228), + + /* Pass in a bitmask of "header options" */ + CURLOPT(CURLOPT_HEADEROPT, CURLOPTTYPE_VALUES, 229), + + /* The public key used to validate the peer public key */ + CURLOPT(CURLOPT_PINNEDPUBLICKEY, CURLOPTTYPE_STRINGPOINT, 230), + + /* Path to Unix domain socket */ + CURLOPT(CURLOPT_UNIX_SOCKET_PATH, CURLOPTTYPE_STRINGPOINT, 231), + + /* Set if we should verify the certificate status. */ + CURLOPT(CURLOPT_SSL_VERIFYSTATUS, CURLOPTTYPE_LONG, 232), + + /* Set if we should enable TLS false start. */ + CURLOPTDEPRECATED(CURLOPT_SSL_FALSESTART, CURLOPTTYPE_LONG, 233, + 8.15.0, "Has no function"), + + /* Do not squash dot-dot sequences */ + CURLOPT(CURLOPT_PATH_AS_IS, CURLOPTTYPE_LONG, 234), + + /* Proxy Service Name */ + CURLOPT(CURLOPT_PROXY_SERVICE_NAME, CURLOPTTYPE_STRINGPOINT, 235), + + /* Service Name */ + CURLOPT(CURLOPT_SERVICE_NAME, CURLOPTTYPE_STRINGPOINT, 236), + + /* Wait/do not wait for pipe/mutex to clarify */ + CURLOPT(CURLOPT_PIPEWAIT, CURLOPTTYPE_LONG, 237), + + /* Set the protocol used when curl is given a URL without a protocol */ + CURLOPT(CURLOPT_DEFAULT_PROTOCOL, CURLOPTTYPE_STRINGPOINT, 238), + + /* Set stream weight, 1 - 256 (default is 16) */ + CURLOPT(CURLOPT_STREAM_WEIGHT, CURLOPTTYPE_LONG, 239), + + /* Set stream dependency on another curl handle */ + CURLOPTDEPRECATED(CURLOPT_STREAM_DEPENDS, CURLOPTTYPE_OBJECTPOINT, 240, + 8.21.0, "Has no function"), + + /* Set E-xclusive stream dependency on another curl handle */ + CURLOPTDEPRECATED(CURLOPT_STREAM_DEPENDS_E, CURLOPTTYPE_OBJECTPOINT, 241, + 8.21.0, "Has no function"), + + /* Do not send any tftp option requests to the server */ + CURLOPT(CURLOPT_TFTP_NO_OPTIONS, CURLOPTTYPE_LONG, 242), + + /* Linked-list of host:port:connect-to-host:connect-to-port, + overrides the URL's host:port (only for the network layer) */ + CURLOPT(CURLOPT_CONNECT_TO, CURLOPTTYPE_SLISTPOINT, 243), + + /* Set TCP Fast Open */ + CURLOPT(CURLOPT_TCP_FASTOPEN, CURLOPTTYPE_LONG, 244), + + /* Continue to send data if the server responds early with an + * HTTP status code >= 300 */ + CURLOPT(CURLOPT_KEEP_SENDING_ON_ERROR, CURLOPTTYPE_LONG, 245), + + /* The CApath or CAfile used to validate the proxy certificate + this option is used only if PROXY_SSL_VERIFYPEER is true */ + CURLOPT(CURLOPT_PROXY_CAINFO, CURLOPTTYPE_STRINGPOINT, 246), + + /* The CApath directory used to validate the proxy certificate + this option is used only if PROXY_SSL_VERIFYPEER is true */ + CURLOPT(CURLOPT_PROXY_CAPATH, CURLOPTTYPE_STRINGPOINT, 247), + + /* Set if we should verify the proxy in SSL handshake, + set 1 to verify. */ + CURLOPT(CURLOPT_PROXY_SSL_VERIFYPEER, CURLOPTTYPE_LONG, 248), + + /* Set if we should verify the Common name from the proxy certificate in SSL + * handshake, set 1 to check existence, 2 to ensure that it matches + * the provided hostname. */ + CURLOPT(CURLOPT_PROXY_SSL_VERIFYHOST, CURLOPTTYPE_LONG, 249), + + /* What version to specifically try to use for proxy. + See CURL_SSLVERSION defines below. */ + CURLOPT(CURLOPT_PROXY_SSLVERSION, CURLOPTTYPE_VALUES, 250), + + /* Set a username for authenticated TLS for proxy */ + CURLOPT(CURLOPT_PROXY_TLSAUTH_USERNAME, CURLOPTTYPE_STRINGPOINT, 251), + + /* Set a password for authenticated TLS for proxy */ + CURLOPT(CURLOPT_PROXY_TLSAUTH_PASSWORD, CURLOPTTYPE_STRINGPOINT, 252), + + /* Set authentication type for authenticated TLS for proxy */ + CURLOPT(CURLOPT_PROXY_TLSAUTH_TYPE, CURLOPTTYPE_STRINGPOINT, 253), + + /* name of the file keeping your private SSL-certificate for proxy */ + CURLOPT(CURLOPT_PROXY_SSLCERT, CURLOPTTYPE_STRINGPOINT, 254), + + /* type of the file keeping your SSL-certificate ("DER", "PEM", "ENG") for + proxy */ + CURLOPT(CURLOPT_PROXY_SSLCERTTYPE, CURLOPTTYPE_STRINGPOINT, 255), + + /* name of the file keeping your private SSL-key for proxy */ + CURLOPT(CURLOPT_PROXY_SSLKEY, CURLOPTTYPE_STRINGPOINT, 256), + + /* type of the file keeping your private SSL-key ("DER", "PEM", "ENG") for + proxy */ + CURLOPT(CURLOPT_PROXY_SSLKEYTYPE, CURLOPTTYPE_STRINGPOINT, 257), + + /* password for the SSL private key for proxy */ + CURLOPT(CURLOPT_PROXY_KEYPASSWD, CURLOPTTYPE_STRINGPOINT, 258), + + /* Specify which TLS 1.2 (1.1, 1.0) ciphers to use for proxy */ + CURLOPT(CURLOPT_PROXY_SSL_CIPHER_LIST, CURLOPTTYPE_STRINGPOINT, 259), + + /* CRL file for proxy */ + CURLOPT(CURLOPT_PROXY_CRLFILE, CURLOPTTYPE_STRINGPOINT, 260), + + /* Enable/disable specific SSL features with a bitmask for proxy, see + CURLSSLOPT_* */ + CURLOPT(CURLOPT_PROXY_SSL_OPTIONS, CURLOPTTYPE_LONG, 261), + + /* Name of pre proxy to use. */ + CURLOPT(CURLOPT_PRE_PROXY, CURLOPTTYPE_STRINGPOINT, 262), + + /* The public key in DER form used to validate the proxy public key + this option is used only if PROXY_SSL_VERIFYPEER is true */ + CURLOPT(CURLOPT_PROXY_PINNEDPUBLICKEY, CURLOPTTYPE_STRINGPOINT, 263), + + /* Path to an abstract Unix domain socket */ + CURLOPT(CURLOPT_ABSTRACT_UNIX_SOCKET, CURLOPTTYPE_STRINGPOINT, 264), + + /* Suppress proxy CONNECT response headers from user callbacks */ + CURLOPT(CURLOPT_SUPPRESS_CONNECT_HEADERS, CURLOPTTYPE_LONG, 265), + + /* The request target, instead of extracted from the URL */ + CURLOPT(CURLOPT_REQUEST_TARGET, CURLOPTTYPE_STRINGPOINT, 266), + + /* bitmask of allowed auth methods for connections to SOCKS5 proxies */ + CURLOPT(CURLOPT_SOCKS5_AUTH, CURLOPTTYPE_LONG, 267), + + /* Enable/disable SSH compression */ + CURLOPT(CURLOPT_SSH_COMPRESSION, CURLOPTTYPE_LONG, 268), + + /* Post MIME data. */ + CURLOPT(CURLOPT_MIMEPOST, CURLOPTTYPE_OBJECTPOINT, 269), + + /* Time to use with the CURLOPT_TIMECONDITION. Specified in number of + seconds since 1 Jan 1970. */ + CURLOPT(CURLOPT_TIMEVALUE_LARGE, CURLOPTTYPE_OFF_T, 270), + + /* Head start in milliseconds to give happy eyeballs. */ + CURLOPT(CURLOPT_HAPPY_EYEBALLS_TIMEOUT_MS, CURLOPTTYPE_LONG, 271), + + /* Function that is called before a resolver request is made */ + CURLOPT(CURLOPT_RESOLVER_START_FUNCTION, CURLOPTTYPE_FUNCTIONPOINT, 272), + + /* User data to pass to the resolver start callback. */ + CURLOPT(CURLOPT_RESOLVER_START_DATA, CURLOPTTYPE_CBPOINT, 273), + + /* send HAProxy PROXY protocol header? */ + CURLOPT(CURLOPT_HAPROXYPROTOCOL, CURLOPTTYPE_LONG, 274), + + /* shuffle addresses before use when DNS returns multiple */ + CURLOPT(CURLOPT_DNS_SHUFFLE_ADDRESSES, CURLOPTTYPE_LONG, 275), + + /* Specify which TLS 1.3 ciphers suites to use */ + CURLOPT(CURLOPT_TLS13_CIPHERS, CURLOPTTYPE_STRINGPOINT, 276), + CURLOPT(CURLOPT_PROXY_TLS13_CIPHERS, CURLOPTTYPE_STRINGPOINT, 277), + + /* Disallow specifying username/login in URL. */ + CURLOPT(CURLOPT_DISALLOW_USERNAME_IN_URL, CURLOPTTYPE_LONG, 278), + + /* DNS-over-HTTPS URL */ + CURLOPT(CURLOPT_DOH_URL, CURLOPTTYPE_STRINGPOINT, 279), + + /* Preferred buffer size to use for uploads */ + CURLOPT(CURLOPT_UPLOAD_BUFFERSIZE, CURLOPTTYPE_LONG, 280), + + /* Time in ms between connection upkeep calls for long-lived connections. */ + CURLOPT(CURLOPT_UPKEEP_INTERVAL_MS, CURLOPTTYPE_LONG, 281), + + /* Specify URL using CURL URL API. */ + CURLOPT(CURLOPT_CURLU, CURLOPTTYPE_OBJECTPOINT, 282), + + /* add trailing data after no more data is available */ + CURLOPT(CURLOPT_TRAILERFUNCTION, CURLOPTTYPE_FUNCTIONPOINT, 283), + + /* pointer to be passed to HTTP_TRAILER_FUNCTION */ + CURLOPT(CURLOPT_TRAILERDATA, CURLOPTTYPE_CBPOINT, 284), + + /* set this to 1L to allow HTTP/0.9 responses or 0L to disallow */ + CURLOPT(CURLOPT_HTTP09_ALLOWED, CURLOPTTYPE_LONG, 285), + + /* alt-svc control bitmask */ + CURLOPT(CURLOPT_ALTSVC_CTRL, CURLOPTTYPE_LONG, 286), + + /* alt-svc cache filename to possibly read from/write to */ + CURLOPT(CURLOPT_ALTSVC, CURLOPTTYPE_STRINGPOINT, 287), + + /* maximum age (idle time) of a connection to consider it for reuse + * (in seconds) */ + CURLOPT(CURLOPT_MAXAGE_CONN, CURLOPTTYPE_LONG, 288), + + /* SASL authorization identity */ + CURLOPT(CURLOPT_SASL_AUTHZID, CURLOPTTYPE_STRINGPOINT, 289), + + /* allow RCPT TO command to fail for some recipients */ + CURLOPT(CURLOPT_MAIL_RCPT_ALLOWFAILS, CURLOPTTYPE_LONG, 290), + + /* the private SSL-certificate as a "blob" */ + CURLOPT(CURLOPT_SSLCERT_BLOB, CURLOPTTYPE_BLOB, 291), + CURLOPT(CURLOPT_SSLKEY_BLOB, CURLOPTTYPE_BLOB, 292), + CURLOPT(CURLOPT_PROXY_SSLCERT_BLOB, CURLOPTTYPE_BLOB, 293), + CURLOPT(CURLOPT_PROXY_SSLKEY_BLOB, CURLOPTTYPE_BLOB, 294), + CURLOPT(CURLOPT_ISSUERCERT_BLOB, CURLOPTTYPE_BLOB, 295), + + /* Issuer certificate for proxy */ + CURLOPT(CURLOPT_PROXY_ISSUERCERT, CURLOPTTYPE_STRINGPOINT, 296), + CURLOPT(CURLOPT_PROXY_ISSUERCERT_BLOB, CURLOPTTYPE_BLOB, 297), + + /* the EC curves requested by the TLS client (RFC 8422, 5.1); + * OpenSSL support via 'set_groups'/'set_curves': + * https://docs.openssl.org/master/man3/SSL_CTX_set1_curves/ + */ + CURLOPT(CURLOPT_SSL_EC_CURVES, CURLOPTTYPE_STRINGPOINT, 298), + + /* HSTS bitmask */ + CURLOPT(CURLOPT_HSTS_CTRL, CURLOPTTYPE_LONG, 299), + /* HSTS filename */ + CURLOPT(CURLOPT_HSTS, CURLOPTTYPE_STRINGPOINT, 300), + + /* HSTS read callback */ + CURLOPT(CURLOPT_HSTSREADFUNCTION, CURLOPTTYPE_FUNCTIONPOINT, 301), + CURLOPT(CURLOPT_HSTSREADDATA, CURLOPTTYPE_CBPOINT, 302), + + /* HSTS write callback */ + CURLOPT(CURLOPT_HSTSWRITEFUNCTION, CURLOPTTYPE_FUNCTIONPOINT, 303), + CURLOPT(CURLOPT_HSTSWRITEDATA, CURLOPTTYPE_CBPOINT, 304), + + /* Parameters for V4 signature */ + CURLOPT(CURLOPT_AWS_SIGV4, CURLOPTTYPE_STRINGPOINT, 305), + + /* Same as CURLOPT_SSL_VERIFYPEER but for DoH (DNS-over-HTTPS) servers. */ + CURLOPT(CURLOPT_DOH_SSL_VERIFYPEER, CURLOPTTYPE_LONG, 306), + + /* Same as CURLOPT_SSL_VERIFYHOST but for DoH (DNS-over-HTTPS) servers. */ + CURLOPT(CURLOPT_DOH_SSL_VERIFYHOST, CURLOPTTYPE_LONG, 307), + + /* Same as CURLOPT_SSL_VERIFYSTATUS but for DoH (DNS-over-HTTPS) servers. */ + CURLOPT(CURLOPT_DOH_SSL_VERIFYSTATUS, CURLOPTTYPE_LONG, 308), + + /* The CA certificates as "blob" used to validate the peer certificate + this option is used only if SSL_VERIFYPEER is true */ + CURLOPT(CURLOPT_CAINFO_BLOB, CURLOPTTYPE_BLOB, 309), + + /* The CA certificates as "blob" used to validate the proxy certificate + this option is used only if PROXY_SSL_VERIFYPEER is true */ + CURLOPT(CURLOPT_PROXY_CAINFO_BLOB, CURLOPTTYPE_BLOB, 310), + + /* used by scp/sftp to verify the host's public key */ + CURLOPT(CURLOPT_SSH_HOST_PUBLIC_KEY_SHA256, CURLOPTTYPE_STRINGPOINT, 311), + + /* Function that is called immediately before the initial request + is made on a connection (after any protocol negotiation step). */ + CURLOPT(CURLOPT_PREREQFUNCTION, CURLOPTTYPE_FUNCTIONPOINT, 312), + + /* Data passed to the CURLOPT_PREREQFUNCTION callback */ + CURLOPT(CURLOPT_PREREQDATA, CURLOPTTYPE_CBPOINT, 313), + + /* maximum age (since creation) of a connection to consider it for reuse + * (in seconds) */ + CURLOPT(CURLOPT_MAXLIFETIME_CONN, CURLOPTTYPE_LONG, 314), + + /* Set MIME option flags. */ + CURLOPT(CURLOPT_MIME_OPTIONS, CURLOPTTYPE_LONG, 315), + + /* set the SSH host key callback, must point to a curl_sshkeycallback + function */ + CURLOPT(CURLOPT_SSH_HOSTKEYFUNCTION, CURLOPTTYPE_FUNCTIONPOINT, 316), + + /* set the SSH host key callback custom pointer */ + CURLOPT(CURLOPT_SSH_HOSTKEYDATA, CURLOPTTYPE_CBPOINT, 317), + + /* specify which protocols that are allowed to be used for the transfer, + which thus helps the app which takes URLs from users or other external + inputs and want to restrict what protocol(s) to deal with. Defaults to + all built-in protocols. */ + CURLOPT(CURLOPT_PROTOCOLS_STR, CURLOPTTYPE_STRINGPOINT, 318), + + /* specify which protocols that libcurl is allowed to follow directs to */ + CURLOPT(CURLOPT_REDIR_PROTOCOLS_STR, CURLOPTTYPE_STRINGPOINT, 319), + + /* WebSockets options */ + CURLOPT(CURLOPT_WS_OPTIONS, CURLOPTTYPE_LONG, 320), + + /* CA cache timeout */ + CURLOPT(CURLOPT_CA_CACHE_TIMEOUT, CURLOPTTYPE_LONG, 321), + + /* Can leak things, gonna exit() soon */ + CURLOPT(CURLOPT_QUICK_EXIT, CURLOPTTYPE_LONG, 322), + + /* set a specific client IP for HAProxy PROXY protocol header? */ + CURLOPT(CURLOPT_HAPROXY_CLIENT_IP, CURLOPTTYPE_STRINGPOINT, 323), + + /* millisecond version */ + CURLOPT(CURLOPT_SERVER_RESPONSE_TIMEOUT_MS, CURLOPTTYPE_LONG, 324), + + /* set ECH configuration */ + CURLOPT(CURLOPT_ECH, CURLOPTTYPE_STRINGPOINT, 325), + + /* maximum number of keepalive probes (Linux, *BSD, macOS, etc.) */ + CURLOPT(CURLOPT_TCP_KEEPCNT, CURLOPTTYPE_LONG, 326), + + CURLOPT(CURLOPT_UPLOAD_FLAGS, CURLOPTTYPE_LONG, 327), + + /* set TLS supported signature algorithms */ + CURLOPT(CURLOPT_SSL_SIGNATURE_ALGORITHMS, CURLOPTTYPE_STRINGPOINT, 328), + + CURLOPT_LASTENTRY /* the last unused */ +} CURLoption; + +#ifndef CURL_NO_OLDIES /* define this to test if your app builds with all + the obsolete stuff removed! */ + +/* Backwards compatibility with older names */ +/* These are scheduled to disappear by 2011 */ + +/* This was added in version 7.19.1 */ +#define CURLOPT_POST301 CURLOPT_POSTREDIR + +/* These are scheduled to disappear by 2009 */ + +/* The following were added in 7.17.0 */ +#define CURLOPT_SSLKEYPASSWD CURLOPT_KEYPASSWD +#define CURLOPT_FTPAPPEND CURLOPT_APPEND +#define CURLOPT_FTPLISTONLY CURLOPT_DIRLISTONLY +#define CURLOPT_FTP_SSL CURLOPT_USE_SSL + +/* The following were added earlier */ + +#define CURLOPT_SSLCERTPASSWD CURLOPT_KEYPASSWD +#define CURLOPT_KRB4LEVEL CURLOPT_KRBLEVEL + +#define CURLOPT_FTP_RESPONSE_TIMEOUT CURLOPT_SERVER_RESPONSE_TIMEOUT + +/* Added in 8.2.0 */ +#define CURLOPT_MAIL_RCPT_ALLLOWFAILS CURLOPT_MAIL_RCPT_ALLOWFAILS + +#else +/* This is set if CURL_NO_OLDIES is defined at compile-time */ +#undef CURLOPT_DNS_USE_GLOBAL_CACHE /* soon obsolete */ +#endif + +/* Below here follows defines for the CURLOPT_IPRESOLVE option. If a host + name resolves addresses using more than one IP protocol version, this + option might be handy to force libcurl to use a specific IP version. */ +#define CURL_IPRESOLVE_WHATEVER 0L /* default, uses addresses to all IP + versions that your system allows */ +#define CURL_IPRESOLVE_V4 1L /* uses only IPv4 addresses/connections */ +#define CURL_IPRESOLVE_V6 2L /* uses only IPv6 addresses/connections */ + + /* Convenient "aliases" */ +#define CURLOPT_RTSPHEADER CURLOPT_HTTPHEADER + +/* These constants are for use with the CURLOPT_HTTP_VERSION option. */ +#define CURL_HTTP_VERSION_NONE 0L /* setting this means we do not care, and + that we would like the library to choose + the best possible for us! */ +#define CURL_HTTP_VERSION_1_0 1L /* please use HTTP 1.0 in the request */ +#define CURL_HTTP_VERSION_1_1 2L /* please use HTTP 1.1 in the request */ +#define CURL_HTTP_VERSION_2_0 3L /* please use HTTP 2 in the request */ +#define CURL_HTTP_VERSION_2TLS 4L /* use version 2 for HTTPS, version 1.1 for + HTTP */ +#define CURL_HTTP_VERSION_2_PRIOR_KNOWLEDGE 5L /* please use HTTP 2 without + HTTP/1.1 Upgrade */ +#define CURL_HTTP_VERSION_3 30L /* Use HTTP/3, fallback to HTTP/2 or + HTTP/1 if needed. For HTTPS only. For + HTTP, this option makes libcurl + return error. */ +#define CURL_HTTP_VERSION_3ONLY 31L /* Use HTTP/3 without fallback. For + HTTPS only. For HTTP, this makes + libcurl return error. */ +#define CURL_HTTP_VERSION_LAST 32L /* *ILLEGAL* http version */ + +/* Convenience definition simple because the name of the version is HTTP/2 and + not 2.0. The 2_0 version of the enum name was set while the version was + still planned to be 2.0 and we stick to it for compatibility. */ +#define CURL_HTTP_VERSION_2 CURL_HTTP_VERSION_2_0 + +/* + * Public API enums for RTSP requests + */ + +#define CURL_RTSPREQ_NONE 0L +#define CURL_RTSPREQ_OPTIONS 1L +#define CURL_RTSPREQ_DESCRIBE 2L +#define CURL_RTSPREQ_ANNOUNCE 3L +#define CURL_RTSPREQ_SETUP 4L +#define CURL_RTSPREQ_PLAY 5L +#define CURL_RTSPREQ_PAUSE 6L +#define CURL_RTSPREQ_TEARDOWN 7L +#define CURL_RTSPREQ_GET_PARAMETER 8L +#define CURL_RTSPREQ_SET_PARAMETER 9L +#define CURL_RTSPREQ_RECORD 10L +#define CURL_RTSPREQ_RECEIVE 11L +#define CURL_RTSPREQ_LAST 12L /* not used */ + + /* These enums are for use with the CURLOPT_NETRC option. */ +#define CURL_NETRC_IGNORED 0L /* The .netrc is never read. + This is the default. */ +#define CURL_NETRC_OPTIONAL 1L /* A user:password in the URL is preferred + to one in the .netrc. */ +#define CURL_NETRC_REQUIRED 2L /* A user:password in the URL is ignored. + Unless one is set programmatically, the + .netrc is queried. */ +enum CURL_NETRC_OPTION { + /* we set a single member here, to make sure we still provide the enum, but + the values to use are defined above with L suffixes */ + CURL_NETRC_LAST = 3 +}; + +#define CURL_SSLVERSION_DEFAULT 0L +#define CURL_SSLVERSION_TLSv1 1L /* TLS 1.x */ +#define CURL_SSLVERSION_SSLv2 2L +#define CURL_SSLVERSION_SSLv3 3L +#define CURL_SSLVERSION_TLSv1_0 4L +#define CURL_SSLVERSION_TLSv1_1 5L +#define CURL_SSLVERSION_TLSv1_2 6L +#define CURL_SSLVERSION_TLSv1_3 7L + +#define CURL_SSLVERSION_LAST 8L /* never use, keep last */ + +#define CURL_SSLVERSION_MAX_NONE 0L +#define CURL_SSLVERSION_MAX_DEFAULT (CURL_SSLVERSION_TLSv1 << 16) +#define CURL_SSLVERSION_MAX_TLSv1_0 (CURL_SSLVERSION_TLSv1_0 << 16) +#define CURL_SSLVERSION_MAX_TLSv1_1 (CURL_SSLVERSION_TLSv1_1 << 16) +#define CURL_SSLVERSION_MAX_TLSv1_2 (CURL_SSLVERSION_TLSv1_2 << 16) +#define CURL_SSLVERSION_MAX_TLSv1_3 (CURL_SSLVERSION_TLSv1_3 << 16) + +/* never use, keep last */ +#define CURL_SSLVERSION_MAX_LAST (CURL_SSLVERSION_LAST << 16) + +#define CURL_TLSAUTH_NONE 0L +#define CURL_TLSAUTH_SRP 1L + +enum CURL_TLSAUTH { + /* we set a single member here, to make sure we still provide the enum, + but the values to use are defined above with L suffixes */ + CURL_TLSAUTH_LAST = 2 +}; + +/* symbols to use with CURLOPT_POSTREDIR. + CURL_REDIR_POST_301, CURL_REDIR_POST_302 and CURL_REDIR_POST_303 + can be bitwise ORed so that CURL_REDIR_POST_301 | CURL_REDIR_POST_302 + | CURL_REDIR_POST_303 == CURL_REDIR_POST_ALL */ + +#define CURL_REDIR_GET_ALL 0L +#define CURL_REDIR_POST_301 1L +#define CURL_REDIR_POST_302 2L +#define CURL_REDIR_POST_303 4L +#define CURL_REDIR_POST_ALL \ + (CURL_REDIR_POST_301 | CURL_REDIR_POST_302 | CURL_REDIR_POST_303) + +#define CURL_TIMECOND_NONE 0L +#define CURL_TIMECOND_IFMODSINCE 1L +#define CURL_TIMECOND_IFUNMODSINCE 2L +#define CURL_TIMECOND_LASTMOD 3L + +typedef enum { + /* we set a single member here, to make sure we still provide + the enum typedef, but the values to use are defined above with L + suffixes */ + CURL_TIMECOND_LAST = 4 +} curl_TimeCond; + +/* Special size_t value signaling a null-terminated string. */ +#define CURL_ZERO_TERMINATED ((size_t)-1) + +/* curl_strequal() and curl_strnequal() are subject for removal in a future + release */ +CURL_EXTERN int curl_strequal(const char *s1, const char *s2); +CURL_EXTERN int curl_strnequal(const char *s1, const char *s2, size_t n); + +/* Mime/form handling support. */ +typedef struct curl_mime curl_mime; /* Mime context. */ +typedef struct curl_mimepart curl_mimepart; /* Mime part context. */ + +/* CURLMIMEOPT_ defines are for the CURLOPT_MIME_OPTIONS option. */ +#define CURLMIMEOPT_FORMESCAPE (1L << 0) /* Use backslash-escaping for forms */ + +/* + * NAME curl_mime_init() + * + * DESCRIPTION + * + * Create a mime context and return its handle. The easy parameter is the + * target handle. + */ +CURL_EXTERN curl_mime *curl_mime_init(CURL *easy); + +/* + * NAME curl_mime_free() + * + * DESCRIPTION + * + * release a mime handle and its substructures. + */ +CURL_EXTERN void curl_mime_free(curl_mime *mime); + +/* + * NAME curl_mime_addpart() + * + * DESCRIPTION + * + * Append a new empty part to the given mime context and return a handle to + * the created part. + */ +CURL_EXTERN curl_mimepart *curl_mime_addpart(curl_mime *mime); + +/* + * NAME curl_mime_name() + * + * DESCRIPTION + * + * Set mime/form part name. + */ +CURL_EXTERN CURLcode curl_mime_name(curl_mimepart *part, const char *name); + +/* + * NAME curl_mime_filename() + * + * DESCRIPTION + * + * Set mime part remote filename. + */ +CURL_EXTERN CURLcode curl_mime_filename(curl_mimepart *part, + const char *filename); + +/* + * NAME curl_mime_type() + * + * DESCRIPTION + * + * Set mime part type. + */ +CURL_EXTERN CURLcode curl_mime_type(curl_mimepart *part, const char *mimetype); + +/* + * NAME curl_mime_encoder() + * + * DESCRIPTION + * + * Set mime data transfer encoder. + */ +CURL_EXTERN CURLcode curl_mime_encoder(curl_mimepart *part, + const char *encoding); + +/* + * NAME curl_mime_data() + * + * DESCRIPTION + * + * Set mime part data source from memory data, + */ +CURL_EXTERN CURLcode curl_mime_data(curl_mimepart *part, + const char *data, size_t datasize); + +/* + * NAME curl_mime_filedata() + * + * DESCRIPTION + * + * Set mime part data source from named file. + */ +CURL_EXTERN CURLcode curl_mime_filedata(curl_mimepart *part, + const char *filename); + +/* + * NAME curl_mime_data_cb() + * + * DESCRIPTION + * + * Set mime part data source from callback function. + */ +CURL_EXTERN CURLcode curl_mime_data_cb(curl_mimepart *part, + curl_off_t datasize, + curl_read_callback readfunc, + curl_seek_callback seekfunc, + curl_free_callback freefunc, + void *arg); + +/* + * NAME curl_mime_subparts() + * + * DESCRIPTION + * + * Set mime part data source from subparts. + */ +CURL_EXTERN CURLcode curl_mime_subparts(curl_mimepart *part, + curl_mime *subparts); +/* + * NAME curl_mime_headers() + * + * DESCRIPTION + * + * Set mime part headers. + */ +CURL_EXTERN CURLcode curl_mime_headers(curl_mimepart *part, + struct curl_slist *headers, + int take_ownership); + +typedef enum { + /********* the first one is unused ************/ + CURLFORM_NOTHING CURL_DEPRECATED(7.56.0, ""), + CURLFORM_COPYNAME CURL_DEPRECATED(7.56.0, "Use curl_mime_name()"), + CURLFORM_PTRNAME CURL_DEPRECATED(7.56.0, "Use curl_mime_name()"), + CURLFORM_NAMELENGTH CURL_DEPRECATED(7.56.0, ""), + CURLFORM_COPYCONTENTS CURL_DEPRECATED(7.56.0, "Use curl_mime_data()"), + CURLFORM_PTRCONTENTS CURL_DEPRECATED(7.56.0, "Use curl_mime_data()"), + CURLFORM_CONTENTSLENGTH CURL_DEPRECATED(7.56.0, "Use curl_mime_data()"), + CURLFORM_FILECONTENT CURL_DEPRECATED(7.56.0, "Use curl_mime_data_cb()"), + CURLFORM_ARRAY CURL_DEPRECATED(7.56.0, ""), + CURLFORM_OBSOLETE, + CURLFORM_FILE CURL_DEPRECATED(7.56.0, "Use curl_mime_filedata()"), + + CURLFORM_BUFFER CURL_DEPRECATED(7.56.0, "Use curl_mime_filename()"), + CURLFORM_BUFFERPTR CURL_DEPRECATED(7.56.0, "Use curl_mime_data()"), + CURLFORM_BUFFERLENGTH CURL_DEPRECATED(7.56.0, "Use curl_mime_data()"), + + CURLFORM_CONTENTTYPE CURL_DEPRECATED(7.56.0, "Use curl_mime_type()"), + CURLFORM_CONTENTHEADER CURL_DEPRECATED(7.56.0, "Use curl_mime_headers()"), + CURLFORM_FILENAME CURL_DEPRECATED(7.56.0, "Use curl_mime_filename()"), + CURLFORM_END, + CURLFORM_OBSOLETE2, + + CURLFORM_STREAM CURL_DEPRECATED(7.56.0, "Use curl_mime_data_cb()"), + CURLFORM_CONTENTLEN /* added in 7.46.0, provide a curl_off_t length */ + CURL_DEPRECATED(7.56.0, "Use curl_mime_data()"), + + CURLFORM_LASTENTRY /* the last unused */ +} CURLformoption; + +/* structure to be used as parameter for CURLFORM_ARRAY */ +struct curl_forms { + CURLformoption option; + const char *value; +}; + +/* use this for multipart formpost building */ +/* Returns code for curl_formadd() + * + * Returns: + * CURL_FORMADD_OK on success + * CURL_FORMADD_MEMORY if the FormInfo allocation fails + * CURL_FORMADD_OPTION_TWICE if one option is given twice for one Form + * CURL_FORMADD_NULL if a null pointer was given for a char + * CURL_FORMADD_MEMORY if the allocation of a FormInfo struct failed + * CURL_FORMADD_UNKNOWN_OPTION if an unknown option was used + * CURL_FORMADD_INCOMPLETE if the some FormInfo is not complete (or error) + * CURL_FORMADD_MEMORY if a curl_httppost struct cannot be allocated + * CURL_FORMADD_MEMORY if some allocation for string copying failed. + * CURL_FORMADD_ILLEGAL_ARRAY if an illegal option is used in an array + * + ***************************************************************************/ +typedef enum { + CURL_FORMADD_OK CURL_DEPRECATED(7.56.0, ""), /* 1st, no error */ + + CURL_FORMADD_MEMORY CURL_DEPRECATED(7.56.0, ""), + CURL_FORMADD_OPTION_TWICE CURL_DEPRECATED(7.56.0, ""), + CURL_FORMADD_NULL CURL_DEPRECATED(7.56.0, ""), + CURL_FORMADD_UNKNOWN_OPTION CURL_DEPRECATED(7.56.0, ""), + CURL_FORMADD_INCOMPLETE CURL_DEPRECATED(7.56.0, ""), + CURL_FORMADD_ILLEGAL_ARRAY CURL_DEPRECATED(7.56.0, ""), + /* libcurl was built with form api disabled */ + CURL_FORMADD_DISABLED CURL_DEPRECATED(7.56.0, ""), + + CURL_FORMADD_LAST /* last */ +} CURLFORMcode; + +/* + * NAME curl_formadd() + * + * DESCRIPTION + * + * Pretty advanced function for building multi-part formposts. Each invoke + * adds one part that together construct a full post. Then use + * CURLOPT_HTTPPOST to send it off to libcurl. + */ +CURL_EXTERN CURLFORMcode CURL_DEPRECATED(7.56.0, "Use curl_mime_init()") +curl_formadd(struct curl_httppost **httppost, + struct curl_httppost **last_post, + ...); + +/* + * callback function for curl_formget() + * The void *arg pointer is the one passed as second argument to + * curl_formget(). + * The character buffer passed to it must not be freed. + * Should return the buffer length passed to it as the argument "len" on + * success. + */ +typedef size_t (*curl_formget_callback)(void *arg, const char *buf, + size_t len); + +/* + * NAME curl_formget() + * + * DESCRIPTION + * + * Serialize a curl_httppost struct built with curl_formadd(). + * Accepts a void pointer as second argument which is passed to + * the curl_formget_callback function. + * Returns 0 on success. + */ +CURL_EXTERN int CURL_DEPRECATED(7.56.0, "") +curl_formget(struct curl_httppost *form, void *arg, + curl_formget_callback append); +/* + * NAME curl_formfree() + * + * DESCRIPTION + * + * Free a multipart formpost previously built with curl_formadd(). + */ +CURL_EXTERN void CURL_DEPRECATED(7.56.0, "Use curl_mime_free()") +curl_formfree(struct curl_httppost *form); + +/* + * NAME curl_getenv() + * + * DESCRIPTION + * + * Returns a malloc()'ed string that MUST be curl_free()ed after usage is + * complete. DEPRECATED - see lib/README.curlx + */ +CURL_EXTERN char *curl_getenv(const char *variable); + +/* + * NAME curl_version() + * + * DESCRIPTION + * + * Returns a static ASCII string of the libcurl version. + */ +CURL_EXTERN char *curl_version(void); + +/* + * NAME curl_easy_escape() + * + * DESCRIPTION + * + * Escapes URL strings (converts all letters consider illegal in URLs to their + * %XX versions). This function returns a new allocated string or NULL if an + * error occurred. + */ +CURL_EXTERN char *curl_easy_escape(CURL *curl, + const char *string, + int length); + +/* the previous version: */ +CURL_EXTERN char *curl_escape(const char *string, + int length); + +/* + * NAME curl_easy_unescape() + * + * DESCRIPTION + * + * Unescapes URL encoding in strings (converts all %XX codes to their 8-bit + * versions). This function returns a new allocated string or NULL if an error + * occurred. + * Conversion Note: On non-ASCII platforms the ASCII %XX codes are + * converted into the host encoding. + */ +CURL_EXTERN char *curl_easy_unescape(CURL *curl, + const char *string, + int inlength, + int *outlength); + +/* the previous version */ +CURL_EXTERN char *curl_unescape(const char *string, + int length); + +/* + * NAME curl_free() + * + * DESCRIPTION + * + * Provided for de-allocation in the same translation unit that did the + * allocation. Added in libcurl 7.10 + */ +CURL_EXTERN void curl_free(void *p); + +/* + * NAME curl_global_init() + * + * DESCRIPTION + * + * curl_global_init() should be invoked exactly once for each application that + * uses libcurl and before any call of other libcurl functions. + * + * This function is thread-safe if CURL_VERSION_THREADSAFE is set in the + * curl_version_info_data.features flag (fetch by curl_version_info()). + */ +CURL_EXTERN CURLcode curl_global_init(long flags); + +/* + * NAME curl_global_init_mem() + * + * DESCRIPTION + * + * curl_global_init() or curl_global_init_mem() should be invoked exactly once + * for each application that uses libcurl. This function can be used to + * initialize libcurl and set user defined memory management callback + * functions. Users can implement memory management routines to check for + * memory leaks, check for misuse of the curl library etc. User registered + * callback routines is invoked by this library instead of the system + * memory management routines like malloc, free etc. + */ +CURL_EXTERN CURLcode curl_global_init_mem(long flags, + curl_malloc_callback m, + curl_free_callback f, + curl_realloc_callback r, + curl_strdup_callback s, + curl_calloc_callback c); + +/* + * NAME curl_global_cleanup() + * + * DESCRIPTION + * + * curl_global_cleanup() should be invoked exactly once for each application + * that uses libcurl + */ +CURL_EXTERN void curl_global_cleanup(void); + +/* + * NAME curl_global_trace() + * + * DESCRIPTION + * + * curl_global_trace() can be invoked at application start to + * configure which components in curl should participate in tracing. + * + * This function is thread-safe if CURL_VERSION_THREADSAFE is set in the + * curl_version_info_data.features flag (fetch by curl_version_info()). + */ +CURL_EXTERN CURLcode curl_global_trace(const char *config); + +/* linked-list structure for the CURLOPT_QUOTE option (and other) */ +struct curl_slist { + char *data; + struct curl_slist *next; +}; + +/* + * NAME curl_global_sslset() + * + * DESCRIPTION + * + * When built with multiple SSL backends, curl_global_sslset() allows to + * choose one. This function can only be called once, and it must be called + * *before* curl_global_init(). + * + * The backend can be identified by the id (e.g. CURLSSLBACKEND_OPENSSL). The + * backend can also be specified via the name parameter (passing -1 as id). If + * both id and name are specified, the name is ignored. If neither id nor + * name are specified, the function fails with CURLSSLSET_UNKNOWN_BACKEND + * and set the "avail" pointer to the null-terminated list of available + * backends. + * + * Upon success, the function returns CURLSSLSET_OK. + * + * If the specified SSL backend is not available, the function returns + * CURLSSLSET_UNKNOWN_BACKEND and sets the "avail" pointer to a + * null-terminated list of available SSL backends. + * + * The SSL backend can be set only once. If it has already been set, a + * subsequent attempt to change it results in a CURLSSLSET_TOO_LATE. + */ + +struct curl_ssl_backend { + curl_sslbackend id; + const char *name; +}; +typedef struct curl_ssl_backend curl_ssl_backend; + +typedef enum { + CURLSSLSET_OK = 0, + CURLSSLSET_UNKNOWN_BACKEND, + CURLSSLSET_TOO_LATE, + CURLSSLSET_NO_BACKENDS /* libcurl was built without any SSL support */ +} CURLsslset; + +CURL_EXTERN CURLsslset curl_global_sslset(curl_sslbackend id, const char *name, + const curl_ssl_backend ***avail); + +/* + * NAME curl_slist_append() + * + * DESCRIPTION + * + * Appends a string to a linked list. If no list exists, it is created first. + * Returns the new list, after appending. + */ +CURL_EXTERN struct curl_slist *curl_slist_append(struct curl_slist *list, + const char *data); + +/* + * NAME curl_slist_free_all() + * + * DESCRIPTION + * + * free a previously built curl_slist. + */ +CURL_EXTERN void curl_slist_free_all(struct curl_slist *list); + +/* + * NAME curl_getdate() + * + * DESCRIPTION + * + * Returns the time, in seconds since 1 Jan 1970 of the time string given in + * the first argument. The time argument in the second parameter is unused + * and should be set to NULL. + */ +CURL_EXTERN time_t curl_getdate(const char *p, const time_t *unused); + +/* info about the certificate chain, for SSL backends that support it. Asked + for with CURLOPT_CERTINFO / CURLINFO_CERTINFO */ +struct curl_certinfo { + int num_of_certs; /* number of certificates with information */ + struct curl_slist **certinfo; /* for each index in this array, there is a + linked list with textual information for a + certificate in the format "name:content". + eg "Subject:foo", "Issuer:bar", etc. */ +}; + +/* Information about the SSL library used and the respective internal SSL + handle, which can be used to obtain further information regarding the + connection. Asked for with CURLINFO_TLS_SSL_PTR or CURLINFO_TLS_SESSION. */ +struct curl_tlssessioninfo { + curl_sslbackend backend; + void *internals; +}; + +#define CURLINFO_STRING 0x100000 +#define CURLINFO_LONG 0x200000 +#define CURLINFO_DOUBLE 0x300000 +#define CURLINFO_SLIST 0x400000 +#define CURLINFO_PTR 0x400000 /* same as SLIST */ +#define CURLINFO_SOCKET 0x500000 +#define CURLINFO_OFF_T 0x600000 +#define CURLINFO_MASK 0x0fffff +#define CURLINFO_TYPEMASK 0xf00000 + +typedef enum { + CURLINFO_NONE, /* first, never use this */ + CURLINFO_EFFECTIVE_URL = CURLINFO_STRING + 1, + CURLINFO_RESPONSE_CODE = CURLINFO_LONG + 2, + CURLINFO_TOTAL_TIME = CURLINFO_DOUBLE + 3, + CURLINFO_NAMELOOKUP_TIME = CURLINFO_DOUBLE + 4, + CURLINFO_CONNECT_TIME = CURLINFO_DOUBLE + 5, + CURLINFO_PRETRANSFER_TIME = CURLINFO_DOUBLE + 6, + CURLINFO_SIZE_UPLOAD CURL_DEPRECATED(7.55.0, "Use CURLINFO_SIZE_UPLOAD_T") + = CURLINFO_DOUBLE + 7, + CURLINFO_SIZE_UPLOAD_T = CURLINFO_OFF_T + 7, + CURLINFO_SIZE_DOWNLOAD + CURL_DEPRECATED(7.55.0, "Use CURLINFO_SIZE_DOWNLOAD_T") + = CURLINFO_DOUBLE + 8, + CURLINFO_SIZE_DOWNLOAD_T = CURLINFO_OFF_T + 8, + CURLINFO_SPEED_DOWNLOAD + CURL_DEPRECATED(7.55.0, "Use CURLINFO_SPEED_DOWNLOAD_T") + = CURLINFO_DOUBLE + 9, + CURLINFO_SPEED_DOWNLOAD_T = CURLINFO_OFF_T + 9, + CURLINFO_SPEED_UPLOAD + CURL_DEPRECATED(7.55.0, "Use CURLINFO_SPEED_UPLOAD_T") + = CURLINFO_DOUBLE + 10, + CURLINFO_SPEED_UPLOAD_T = CURLINFO_OFF_T + 10, + CURLINFO_HEADER_SIZE = CURLINFO_LONG + 11, + CURLINFO_REQUEST_SIZE = CURLINFO_LONG + 12, + CURLINFO_SSL_VERIFYRESULT = CURLINFO_LONG + 13, + CURLINFO_FILETIME = CURLINFO_LONG + 14, + CURLINFO_FILETIME_T = CURLINFO_OFF_T + 14, + CURLINFO_CONTENT_LENGTH_DOWNLOAD + CURL_DEPRECATED(7.55.0, + "Use CURLINFO_CONTENT_LENGTH_DOWNLOAD_T") + = CURLINFO_DOUBLE + 15, + CURLINFO_CONTENT_LENGTH_DOWNLOAD_T = CURLINFO_OFF_T + 15, + CURLINFO_CONTENT_LENGTH_UPLOAD + CURL_DEPRECATED(7.55.0, + "Use CURLINFO_CONTENT_LENGTH_UPLOAD_T") + = CURLINFO_DOUBLE + 16, + CURLINFO_CONTENT_LENGTH_UPLOAD_T = CURLINFO_OFF_T + 16, + CURLINFO_STARTTRANSFER_TIME = CURLINFO_DOUBLE + 17, + CURLINFO_CONTENT_TYPE = CURLINFO_STRING + 18, + CURLINFO_REDIRECT_TIME = CURLINFO_DOUBLE + 19, + CURLINFO_REDIRECT_COUNT = CURLINFO_LONG + 20, + CURLINFO_PRIVATE = CURLINFO_STRING + 21, + CURLINFO_HTTP_CONNECTCODE = CURLINFO_LONG + 22, + CURLINFO_HTTPAUTH_AVAIL = CURLINFO_LONG + 23, + CURLINFO_PROXYAUTH_AVAIL = CURLINFO_LONG + 24, + CURLINFO_OS_ERRNO = CURLINFO_LONG + 25, + CURLINFO_NUM_CONNECTS = CURLINFO_LONG + 26, + CURLINFO_SSL_ENGINES = CURLINFO_SLIST + 27, + CURLINFO_COOKIELIST = CURLINFO_SLIST + 28, + CURLINFO_LASTSOCKET CURL_DEPRECATED(7.45.0, "Use CURLINFO_ACTIVESOCKET") + = CURLINFO_LONG + 29, + CURLINFO_FTP_ENTRY_PATH = CURLINFO_STRING + 30, + CURLINFO_REDIRECT_URL = CURLINFO_STRING + 31, + CURLINFO_PRIMARY_IP = CURLINFO_STRING + 32, + CURLINFO_APPCONNECT_TIME = CURLINFO_DOUBLE + 33, + CURLINFO_CERTINFO = CURLINFO_PTR + 34, + CURLINFO_CONDITION_UNMET = CURLINFO_LONG + 35, + CURLINFO_RTSP_SESSION_ID = CURLINFO_STRING + 36, + CURLINFO_RTSP_CLIENT_CSEQ = CURLINFO_LONG + 37, + CURLINFO_RTSP_SERVER_CSEQ = CURLINFO_LONG + 38, + CURLINFO_RTSP_CSEQ_RECV = CURLINFO_LONG + 39, + CURLINFO_PRIMARY_PORT = CURLINFO_LONG + 40, + CURLINFO_LOCAL_IP = CURLINFO_STRING + 41, + CURLINFO_LOCAL_PORT = CURLINFO_LONG + 42, + CURLINFO_TLS_SESSION CURL_DEPRECATED(7.48.0, "Use CURLINFO_TLS_SSL_PTR") + = CURLINFO_PTR + 43, + CURLINFO_ACTIVESOCKET = CURLINFO_SOCKET + 44, + CURLINFO_TLS_SSL_PTR = CURLINFO_PTR + 45, + CURLINFO_HTTP_VERSION = CURLINFO_LONG + 46, + CURLINFO_PROXY_SSL_VERIFYRESULT = CURLINFO_LONG + 47, + CURLINFO_PROTOCOL CURL_DEPRECATED(7.85.0, "Use CURLINFO_SCHEME") + = CURLINFO_LONG + 48, + CURLINFO_SCHEME = CURLINFO_STRING + 49, + CURLINFO_TOTAL_TIME_T = CURLINFO_OFF_T + 50, + CURLINFO_NAMELOOKUP_TIME_T = CURLINFO_OFF_T + 51, + CURLINFO_CONNECT_TIME_T = CURLINFO_OFF_T + 52, + CURLINFO_PRETRANSFER_TIME_T = CURLINFO_OFF_T + 53, + CURLINFO_STARTTRANSFER_TIME_T = CURLINFO_OFF_T + 54, + CURLINFO_REDIRECT_TIME_T = CURLINFO_OFF_T + 55, + CURLINFO_APPCONNECT_TIME_T = CURLINFO_OFF_T + 56, + CURLINFO_RETRY_AFTER = CURLINFO_OFF_T + 57, + CURLINFO_EFFECTIVE_METHOD = CURLINFO_STRING + 58, + CURLINFO_PROXY_ERROR = CURLINFO_LONG + 59, + CURLINFO_REFERER = CURLINFO_STRING + 60, + CURLINFO_CAINFO = CURLINFO_STRING + 61, + CURLINFO_CAPATH = CURLINFO_STRING + 62, + CURLINFO_XFER_ID = CURLINFO_OFF_T + 63, + CURLINFO_CONN_ID = CURLINFO_OFF_T + 64, + CURLINFO_QUEUE_TIME_T = CURLINFO_OFF_T + 65, + CURLINFO_USED_PROXY = CURLINFO_LONG + 66, + CURLINFO_POSTTRANSFER_TIME_T = CURLINFO_OFF_T + 67, + CURLINFO_EARLYDATA_SENT_T = CURLINFO_OFF_T + 68, + CURLINFO_HTTPAUTH_USED = CURLINFO_LONG + 69, + CURLINFO_PROXYAUTH_USED = CURLINFO_LONG + 70, + CURLINFO_SIZE_DELIVERED = CURLINFO_OFF_T + 71, + CURLINFO_LASTONE = 71 +} CURLINFO; + +/* CURLINFO_RESPONSE_CODE is the new name for the option previously known as + CURLINFO_HTTP_CODE */ +#define CURLINFO_HTTP_CODE CURLINFO_RESPONSE_CODE + +typedef enum { + CURLCLOSEPOLICY_NONE, /* first, never use this */ + + CURLCLOSEPOLICY_OLDEST, + CURLCLOSEPOLICY_LEAST_RECENTLY_USED, + CURLCLOSEPOLICY_LEAST_TRAFFIC, + CURLCLOSEPOLICY_SLOWEST, + CURLCLOSEPOLICY_CALLBACK, + + CURLCLOSEPOLICY_LAST /* last, never use this */ +} curl_closepolicy; + +#define CURL_GLOBAL_SSL (1 << 0) /* no purpose since 7.57.0 */ +#define CURL_GLOBAL_WIN32 (1 << 1) +#define CURL_GLOBAL_ALL (CURL_GLOBAL_SSL | CURL_GLOBAL_WIN32) +#define CURL_GLOBAL_NOTHING 0 +#define CURL_GLOBAL_DEFAULT CURL_GLOBAL_ALL +#define CURL_GLOBAL_ACK_EINTR (1 << 2) + +/***************************************************************************** + * Setup defines, protos etc for the sharing stuff. + */ + +/* Different data locks for a single share */ +typedef enum { + CURL_LOCK_DATA_NONE = 0, + /* CURL_LOCK_DATA_SHARE is used internally to say that the locking is made + * to change the internal state of the share itself. + */ + CURL_LOCK_DATA_SHARE, + CURL_LOCK_DATA_COOKIE, + CURL_LOCK_DATA_DNS, + CURL_LOCK_DATA_SSL_SESSION, + CURL_LOCK_DATA_CONNECT, + CURL_LOCK_DATA_PSL, + CURL_LOCK_DATA_HSTS, + CURL_LOCK_DATA_LAST +} curl_lock_data; + +/* Different lock access types */ +typedef enum { + CURL_LOCK_ACCESS_NONE = 0, /* unspecified action */ + CURL_LOCK_ACCESS_SHARED = 1, /* for read perhaps */ + CURL_LOCK_ACCESS_SINGLE = 2, /* for write perhaps */ + CURL_LOCK_ACCESS_LAST /* never use */ +} curl_lock_access; + +typedef void (*curl_lock_function)(CURL *handle, + curl_lock_data data, + curl_lock_access locktype, + void *userptr); +typedef void (*curl_unlock_function)(CURL *handle, + curl_lock_data data, + void *userptr); + +typedef enum { + CURLSHE_OK, /* all is fine */ + CURLSHE_BAD_OPTION, /* 1 */ + CURLSHE_IN_USE, /* 2 */ + CURLSHE_INVALID, /* 3 */ + CURLSHE_NOMEM, /* 4 out of memory */ + CURLSHE_NOT_BUILT_IN, /* 5 feature not present in lib */ + CURLSHE_LAST /* never use */ +} CURLSHcode; + +typedef enum { + CURLSHOPT_NONE, /* do not use */ + CURLSHOPT_SHARE, /* specify a data type to share */ + CURLSHOPT_UNSHARE, /* specify which data type to stop sharing */ + CURLSHOPT_LOCKFUNC, /* pass in a 'curl_lock_function' pointer */ + CURLSHOPT_UNLOCKFUNC, /* pass in a 'curl_unlock_function' pointer */ + CURLSHOPT_USERDATA, /* pass in a user data pointer used in the lock/unlock + callback functions */ + CURLSHOPT_LAST /* never use */ +} CURLSHoption; + +CURL_EXTERN CURLSH *curl_share_init(void); +CURL_EXTERN CURLSHcode curl_share_setopt(CURLSH *sh, CURLSHoption option, ...); +CURL_EXTERN CURLSHcode curl_share_cleanup(CURLSH *sh); + +/**************************************************************************** + * Structures for querying information about the curl library at runtime. + */ + +typedef enum { + CURLVERSION_FIRST, /* 7.10 */ + CURLVERSION_SECOND, /* 7.11.1 */ + CURLVERSION_THIRD, /* 7.12.0 */ + CURLVERSION_FOURTH, /* 7.16.1 */ + CURLVERSION_FIFTH, /* 7.57.0 */ + CURLVERSION_SIXTH, /* 7.66.0 */ + CURLVERSION_SEVENTH, /* 7.70.0 */ + CURLVERSION_EIGHTH, /* 7.72.0 */ + CURLVERSION_NINTH, /* 7.75.0 */ + CURLVERSION_TENTH, /* 7.77.0 */ + CURLVERSION_ELEVENTH, /* 7.87.0 */ + CURLVERSION_TWELFTH, /* 8.8.0 */ + CURLVERSION_LAST /* never actually use this */ +} CURLversion; + +/* The 'CURLVERSION_NOW' is the symbolic name meant to be used by programs + that want to get version information. It is meant to be a built-in + version number for what kind of struct the caller expects. If the struct + ever changes, we redefine the NOW to another enum from above. */ +#define CURLVERSION_NOW CURLVERSION_TWELFTH + +struct curl_version_info_data { + CURLversion age; /* age of the returned struct */ + const char *version; /* LIBCURL_VERSION */ + unsigned int version_num; /* LIBCURL_VERSION_NUM */ + const char *host; /* OS/host/cpu/machine when configured */ + int features; /* bitmask, see defines below */ + const char *ssl_version; /* human readable string */ + long ssl_version_num; /* not used anymore, always 0 */ + const char *libz_version; /* human readable string */ + /* protocols is terminated by an entry with a NULL protoname */ + const char * const *protocols; + + /* The fields below this were added in CURLVERSION_SECOND */ + const char *ares; + int ares_num; + + /* This field was added in CURLVERSION_THIRD */ + const char *libidn; + + /* These field were added in CURLVERSION_FOURTH */ + + /* Same as '_libiconv_version' if built with HAVE_ICONV */ + int iconv_ver_num; + + const char *libssh_version; /* human readable string */ + + /* These fields were added in CURLVERSION_FIFTH */ + unsigned int brotli_ver_num; /* Numeric Brotli version + (MAJOR << 24) | (MINOR << 12) | PATCH */ + const char *brotli_version; /* human readable string. */ + + /* These fields were added in CURLVERSION_SIXTH */ + unsigned int nghttp2_ver_num; /* Numeric nghttp2 version + (MAJOR << 16) | (MINOR << 8) | PATCH */ + const char *nghttp2_version; /* human readable string. */ + const char *quic_version; /* human readable quic (+ HTTP/3) library + + version or NULL */ + + /* These fields were added in CURLVERSION_SEVENTH */ + const char *cainfo; /* the built-in default CURLOPT_CAINFO, might + be NULL */ + const char *capath; /* the built-in default CURLOPT_CAPATH, might + be NULL */ + + /* These fields were added in CURLVERSION_EIGHTH */ + unsigned int zstd_ver_num; /* Numeric Zstd version + (MAJOR << 24) | (MINOR << 12) | PATCH */ + const char *zstd_version; /* human readable string. */ + + /* These fields were added in CURLVERSION_NINTH */ + const char *hyper_version; /* human readable string. */ + + /* These fields were added in CURLVERSION_TENTH */ + const char *gsasl_version; /* human readable string. */ + + /* These fields were added in CURLVERSION_ELEVENTH */ + /* feature_names is terminated by an entry with a NULL feature name */ + const char * const *feature_names; + + /* These fields were added in CURLVERSION_TWELFTH */ + const char *rtmp_version; /* human readable string. */ +}; +typedef struct curl_version_info_data curl_version_info_data; + +#define CURL_VERSION_IPV6 (1<<0) /* IPv6-enabled */ +#define CURL_VERSION_KERBEROS4 (1<<1) /* Kerberos V4 auth is supported + (deprecated) */ +#define CURL_VERSION_SSL (1<<2) /* SSL options are present */ +#define CURL_VERSION_LIBZ (1<<3) /* libz features are present */ +#define CURL_VERSION_NTLM (1<<4) /* NTLM auth is supported */ +#define CURL_VERSION_GSSNEGOTIATE (1<<5) /* Negotiate auth is supported + (deprecated) */ +#define CURL_VERSION_DEBUG (1<<6) /* Built with debug capabilities */ +#define CURL_VERSION_ASYNCHDNS (1<<7) /* Asynchronous DNS resolves */ +#define CURL_VERSION_SPNEGO (1<<8) /* SPNEGO auth is supported */ +#define CURL_VERSION_LARGEFILE (1<<9) /* Supports files larger than 2GB */ +#define CURL_VERSION_IDN (1<<10) /* Internationized Domain Names are + supported */ +#define CURL_VERSION_SSPI (1<<11) /* Built against Windows SSPI */ +#define CURL_VERSION_CONV (1<<12) /* Character conversions supported */ +#define CURL_VERSION_CURLDEBUG (1<<13) /* Debug memory tracking supported + (deprecated) */ +#define CURL_VERSION_TLSAUTH_SRP (1<<14) /* TLS-SRP auth is supported */ +#define CURL_VERSION_NTLM_WB (1<<15) /* NTLM delegation to winbind helper + is supported */ +#define CURL_VERSION_HTTP2 (1<<16) /* HTTP2 support built-in */ +#define CURL_VERSION_GSSAPI (1<<17) /* Built against a GSS-API library */ +#define CURL_VERSION_KERBEROS5 (1<<18) /* Kerberos V5 auth is supported */ +#define CURL_VERSION_UNIX_SOCKETS (1<<19) /* Unix domain sockets support */ +#define CURL_VERSION_PSL (1<<20) /* Mozilla's Public Suffix List, used + for cookie domain verification */ +#define CURL_VERSION_HTTPS_PROXY (1<<21) /* HTTPS-proxy support built-in */ +#define CURL_VERSION_MULTI_SSL (1<<22) /* Multiple SSL backends available */ +#define CURL_VERSION_BROTLI (1<<23) /* Brotli features are present. */ +#define CURL_VERSION_ALTSVC (1<<24) /* Alt-Svc handling built-in */ +#define CURL_VERSION_HTTP3 (1<<25) /* HTTP3 support built-in */ +#define CURL_VERSION_ZSTD (1<<26) /* zstd features are present */ +#define CURL_VERSION_UNICODE (1<<27) /* Unicode support on Windows */ +#define CURL_VERSION_HSTS (1<<28) /* HSTS is supported */ +#define CURL_VERSION_GSASL (1<<29) /* libgsasl is supported */ +#define CURL_VERSION_THREADSAFE (1<<30) /* libcurl API is thread-safe */ + +/* + * NAME curl_version_info() + * + * DESCRIPTION + * + * This function returns a pointer to a static copy of the version info + * struct. See above. + */ +CURL_EXTERN curl_version_info_data *curl_version_info(CURLversion stamp); + +/* + * NAME curl_easy_strerror() + * + * DESCRIPTION + * + * The curl_easy_strerror function may be used to turn a CURLcode value + * into the equivalent human readable error string. This is useful + * for printing meaningful error messages. + */ +CURL_EXTERN const char *curl_easy_strerror(CURLcode error); + +/* + * NAME curl_share_strerror() + * + * DESCRIPTION + * + * The curl_share_strerror function may be used to turn a CURLSHcode value + * into the equivalent human readable error string. This is useful + * for printing meaningful error messages. + */ +CURL_EXTERN const char *curl_share_strerror(CURLSHcode error); + +/* + * NAME curl_easy_pause() + * + * DESCRIPTION + * + * The curl_easy_pause function pauses or unpauses transfers. Select the new + * state by setting the action bitmask, use the convenience defines below. + * + */ +CURL_EXTERN CURLcode curl_easy_pause(CURL *curl, int action); + +#define CURLPAUSE_RECV (1 << 0) +#define CURLPAUSE_RECV_CONT 0 + +#define CURLPAUSE_SEND (1 << 2) +#define CURLPAUSE_SEND_CONT 0 + +#define CURLPAUSE_ALL (CURLPAUSE_RECV | CURLPAUSE_SEND) +#define CURLPAUSE_CONT (CURLPAUSE_RECV_CONT | CURLPAUSE_SEND_CONT) + +/* + * NAME curl_easy_ssls_import() + * + * DESCRIPTION + * + * The curl_easy_ssls_import function adds a previously exported SSL session + * to the SSL session cache of the easy handle (or the underlying share). + */ +CURL_EXTERN CURLcode curl_easy_ssls_import(CURL *curl, + const char *session_key, + const unsigned char *shmac, + size_t shmac_len, + const unsigned char *sdata, + size_t sdata_len); + +/* This is the curl_ssls_export_cb callback prototype. It + * is passed to curl_easy_ssls_export() to extract SSL sessions/tickets. */ +typedef CURLcode curl_ssls_export_cb(CURL *curl, + void *userptr, + const char *session_key, + const unsigned char *shmac, + size_t shmac_len, + const unsigned char *sdata, + size_t sdata_len, + curl_off_t valid_until, + int ietf_tls_id, + const char *alpn, + size_t earlydata_max); + +/* + * NAME curl_easy_ssls_export() + * + * DESCRIPTION + * + * The curl_easy_ssls_export function iterates over all SSL sessions stored + * in the easy handle (or underlying share) and invokes the passed + * callback. + * + */ +CURL_EXTERN CURLcode curl_easy_ssls_export(CURL *curl, + curl_ssls_export_cb *export_fn, + void *userptr); + +#ifdef __cplusplus +} /* end of extern "C" */ +#endif + +/* unfortunately, the easy.h and multi.h include files need options and info + stuff before they can be included! */ +#include "easy.h" /* nothing in curl is fun without the easy stuff */ +#include "multi.h" +#include "urlapi.h" +#include "options.h" +#include "header.h" +#include "websockets.h" +#include "mprintf.h" + +/* the typechecker does not work in C++ (yet) */ +#if ((defined(__GNUC__) && defined(__GNUC_MINOR__) && \ + ((__GNUC__ > 4) || (__GNUC__ == 4 && __GNUC_MINOR__ >= 3))) || \ + (defined(__clang__) && __clang_major__ >= 14)) && \ + !defined(__cplusplus) && !defined(CURL_DISABLE_TYPECHECK) +#include "typecheck-gcc.h" +#else +#if defined(__STDC__) && (__STDC__ >= 1) +/* This preprocessor magic ensures that application authors pass exactly three + arguments to these functions. For compatibility with C++ global namespace + '::' and reusing these symbols as method names, while also avoiding + recursive macros, use a two-stage solution. */ +#define curl_exactly_three_arguments(a, b, c) (a, b, c) +#define curl_easy_setopt(handle, opt, param) \ + curl_easy_setopt curl_exactly_three_arguments(handle, opt, param) +#define curl_easy_getinfo(handle, info, arg) \ + curl_easy_getinfo curl_exactly_three_arguments(handle, info, arg) +#define curl_share_setopt(share, opt, param) \ + curl_share_setopt curl_exactly_three_arguments(share, opt, param) +#define curl_multi_setopt(handle, opt, param) \ + curl_multi_setopt curl_exactly_three_arguments(handle, opt, param) +#endif /* __STDC__ >= 1 */ +#endif /* gcc >= 4.3 && !__cplusplus && !CURL_DISABLE_TYPECHECK */ + +#endif /* CURLINC_CURL_H */ diff --git a/3rdparty/curl-8.21.0/include/curl/curlver.h b/3rdparty/curl-8.21.0/include/curl/curlver.h new file mode 100644 index 0000000000..683098e172 --- /dev/null +++ b/3rdparty/curl-8.21.0/include/curl/curlver.h @@ -0,0 +1,78 @@ +#ifndef CURLINC_CURLVER_H +#define CURLINC_CURLVER_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +/* This header file contains nothing but libcurl version info, generated by + a script at release-time. This was made its own header file in 7.11.2 */ + +/* This is the global package copyright */ +#define LIBCURL_COPYRIGHT "Daniel Stenberg, ." + +/* This is the version number of the libcurl package from which this header + file origins: */ +#define LIBCURL_VERSION "8.21.0" + +/* The numeric version number is also available "in parts" by using these + defines: */ +#define LIBCURL_VERSION_MAJOR 8 +#define LIBCURL_VERSION_MINOR 21 +#define LIBCURL_VERSION_PATCH 0 +/* This is the numeric version of the libcurl version number, meant for easier + parsing and comparisons by programs. The LIBCURL_VERSION_NUM define always + follows this syntax: + + 0xXXYYZZ + + Where XX, YY and ZZ are the main version, release and patch numbers in + hexadecimal (using 8 bits each). All three numbers are always represented + using two digits. Version 1.2 would appear as "0x010200" while 9.11.7 + appears as "0x090b07". + + This 6-digit (24 bits) hexadecimal number does not show pre-release number, + and it is always a greater number in a more recent release. It makes + comparisons with greater than and less than work. + + Note: This define is the full hex number and _does not_ use the + CURL_VERSION_BITS() macro since curl's own configure script greps for it + and needs it to contain the full number. +*/ +#define LIBCURL_VERSION_NUM 0x081500 + +/* + * This is the date and time when the full source package was created. The + * timestamp is not stored in git, as the timestamp is properly set in the + * tarballs by the maketgz script. + * + * The format of the date follows this template: + * + * "2007-11-23" + */ +#define LIBCURL_TIMESTAMP "2026-06-24" + +#define CURL_VERSION_BITS(x, y, z) ((x) << 16 | (y) << 8 | (z)) +#define CURL_AT_LEAST_VERSION(x, y, z) \ + (LIBCURL_VERSION_NUM >= CURL_VERSION_BITS(x, y, z)) + +#endif /* CURLINC_CURLVER_H */ diff --git a/3rdparty/curl-8.21.0/include/curl/easy.h b/3rdparty/curl-8.21.0/include/curl/easy.h new file mode 100644 index 0000000000..197e6e7b92 --- /dev/null +++ b/3rdparty/curl-8.21.0/include/curl/easy.h @@ -0,0 +1,123 @@ +#ifndef CURLINC_EASY_H +#define CURLINC_EASY_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#ifdef __cplusplus +extern "C" { +#endif + +/* Flag bits in the curl_blob struct: */ +#define CURL_BLOB_COPY 1 /* tell libcurl to copy the data */ +#define CURL_BLOB_NOCOPY 0 /* tell libcurl to NOT copy the data */ + +struct curl_blob { + void *data; + size_t len; + unsigned int flags; /* bit 0 is defined, the rest are reserved and should be + left zeroes */ +}; + +CURL_EXTERN CURL *curl_easy_init(void); +CURL_EXTERN CURLcode curl_easy_setopt(CURL *curl, CURLoption option, ...); +CURL_EXTERN CURLcode curl_easy_perform(CURL *curl); +CURL_EXTERN void curl_easy_cleanup(CURL *curl); + +/* + * NAME curl_easy_getinfo() + * + * DESCRIPTION + * + * Request internal information from the curl session with this function. + * The third argument MUST be pointing to the specific type of the used option + * which is documented in each man page of the option. The data pointed to + * is filled in accordingly and can be relied upon only if the function + * returns CURLE_OK. This function is intended to get used *AFTER* a performed + * transfer, all results from this function are undefined until the transfer + * is completed. + */ +CURL_EXTERN CURLcode curl_easy_getinfo(CURL *curl, CURLINFO info, ...); + +/* + * NAME curl_easy_duphandle() + * + * DESCRIPTION + * + * Creates a new curl session handle with the same options set for the handle + * passed in. Duplicating a handle could only be a matter of cloning data and + * options, internal state info and things like persistent connections cannot + * be transferred. It is useful in multi-threaded applications when you can run + * curl_easy_duphandle() for each new thread to avoid a series of identical + * curl_easy_setopt() invokes in every thread. + */ +CURL_EXTERN CURL *curl_easy_duphandle(CURL *curl); + +/* + * NAME curl_easy_reset() + * + * DESCRIPTION + * + * Re-initializes a curl handle to the default values. This puts back the + * handle to the same state as it was in when it was created. + * + * It does keep: live connections, the Session ID cache, the DNS cache and the + * cookies. + */ +CURL_EXTERN void curl_easy_reset(CURL *curl); + +/* + * NAME curl_easy_recv() + * + * DESCRIPTION + * + * Receives data from the connected socket. Use after successful + * curl_easy_perform() with CURLOPT_CONNECT_ONLY option. + */ +CURL_EXTERN CURLcode curl_easy_recv(CURL *curl, void *buffer, size_t buflen, + size_t *n); + +/* + * NAME curl_easy_send() + * + * DESCRIPTION + * + * Sends data over the connected socket. Use after successful + * curl_easy_perform() with CURLOPT_CONNECT_ONLY option. + */ +CURL_EXTERN CURLcode curl_easy_send(CURL *curl, const void *buffer, + size_t buflen, size_t *n); + +/* + * NAME curl_easy_upkeep() + * + * DESCRIPTION + * + * Performs connection upkeep for the given session handle. + */ +CURL_EXTERN CURLcode curl_easy_upkeep(CURL *curl); + +#ifdef __cplusplus +} /* end of extern "C" */ +#endif + +#endif diff --git a/3rdparty/curl-8.21.0/include/curl/header.h b/3rdparty/curl-8.21.0/include/curl/header.h new file mode 100644 index 0000000000..5c3281a531 --- /dev/null +++ b/3rdparty/curl-8.21.0/include/curl/header.h @@ -0,0 +1,74 @@ +#ifndef CURLINC_HEADER_H +#define CURLINC_HEADER_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +#ifdef __cplusplus +extern "C" { +#endif + +struct curl_header { + char *name; /* this might not use the same case */ + char *value; + size_t amount; /* number of headers using this name */ + size_t index; /* ... of this instance, 0 or higher */ + unsigned int origin; /* see bits below */ + void *anchor; /* handle privately used by libcurl */ +}; + +/* 'origin' bits */ +#define CURLH_HEADER (1 << 0) /* plain server header */ +#define CURLH_TRAILER (1 << 1) /* trailers */ +#define CURLH_CONNECT (1 << 2) /* CONNECT headers */ +#define CURLH_1XX (1 << 3) /* 1xx headers */ +#define CURLH_PSEUDO (1 << 4) /* pseudo headers */ + +typedef enum { + CURLHE_OK, + CURLHE_BADINDEX, /* header exists but not with this index */ + CURLHE_MISSING, /* no such header exists */ + CURLHE_NOHEADERS, /* no headers at all exist (yet) */ + CURLHE_NOREQUEST, /* no request with this number was used */ + CURLHE_OUT_OF_MEMORY, /* out of memory while processing */ + CURLHE_BAD_ARGUMENT, /* a function argument was not okay */ + CURLHE_NOT_BUILT_IN /* if API was disabled in the build */ +} CURLHcode; + +CURL_EXTERN CURLHcode curl_easy_header(CURL *curl, + const char *name, + size_t nameindex, + unsigned int origin, + int request, + struct curl_header **hout); + +CURL_EXTERN struct curl_header *curl_easy_nextheader(CURL *curl, + unsigned int origin, + int request, + struct curl_header *prev); + +#ifdef __cplusplus +} /* end of extern "C" */ +#endif + +#endif /* CURLINC_HEADER_H */ diff --git a/3rdparty/curl-8.21.0/include/curl/mprintf.h b/3rdparty/curl-8.21.0/include/curl/mprintf.h new file mode 100644 index 0000000000..9272e74891 --- /dev/null +++ b/3rdparty/curl-8.21.0/include/curl/mprintf.h @@ -0,0 +1,85 @@ +#ifndef CURLINC_MPRINTF_H +#define CURLINC_MPRINTF_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +#include +#include /* needed for FILE */ +#include "curl.h" /* for CURL_EXTERN */ + +#ifdef __cplusplus +extern "C" { +#endif + +#ifndef CURL_TEMP_PRINTF +#if (defined(__GNUC__) || defined(__clang__) || \ + defined(__IAR_SYSTEMS_ICC__)) && \ + defined(__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L) && \ + !defined(CURL_NO_FMT_CHECKS) +#if defined(__MINGW32__) && !defined(__clang__) +#ifdef __MINGW_PRINTF_FORMAT /* mingw-w64 3.0.0+. Needs stdio.h. */ +#define CURL_TEMP_PRINTF(fmt, arg) \ + __attribute__((format(__MINGW_PRINTF_FORMAT, fmt, arg))) +#else +#define CURL_TEMP_PRINTF(fmt, arg) +#endif +#else +#define CURL_TEMP_PRINTF(fmt, arg) \ + __attribute__((format(printf, fmt, arg))) +#endif +#else +#define CURL_TEMP_PRINTF(fmt, arg) +#endif +#endif + +CURL_EXTERN int curl_mprintf(const char *format, ...) + CURL_TEMP_PRINTF(1, 2); +CURL_EXTERN int curl_mfprintf(FILE *fd, const char *format, ...) + CURL_TEMP_PRINTF(2, 3); +CURL_EXTERN int curl_msprintf(char *buffer, const char *format, ...) + CURL_TEMP_PRINTF(2, 3); +CURL_EXTERN int curl_msnprintf(char *buffer, size_t maxlength, + const char *format, ...) + CURL_TEMP_PRINTF(3, 4); +CURL_EXTERN int curl_mvprintf(const char *format, va_list args) + CURL_TEMP_PRINTF(1, 0); +CURL_EXTERN int curl_mvfprintf(FILE *fd, const char *format, va_list args) + CURL_TEMP_PRINTF(2, 0); +CURL_EXTERN int curl_mvsprintf(char *buffer, const char *format, va_list args) + CURL_TEMP_PRINTF(2, 0); +CURL_EXTERN int curl_mvsnprintf(char *buffer, size_t maxlength, + const char *format, va_list args) + CURL_TEMP_PRINTF(3, 0); +CURL_EXTERN char *curl_maprintf(const char *format, ...) + CURL_TEMP_PRINTF(1, 2); +CURL_EXTERN char *curl_mvaprintf(const char *format, va_list args) + CURL_TEMP_PRINTF(1, 0); + +#undef CURL_TEMP_PRINTF + +#ifdef __cplusplus +} /* end of extern "C" */ +#endif + +#endif /* CURLINC_MPRINTF_H */ diff --git a/3rdparty/curl-8.21.0/include/curl/multi.h b/3rdparty/curl-8.21.0/include/curl/multi.h new file mode 100644 index 0000000000..060b73eeec --- /dev/null +++ b/3rdparty/curl-8.21.0/include/curl/multi.h @@ -0,0 +1,560 @@ +#ifndef CURLINC_MULTI_H +#define CURLINC_MULTI_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +/* + This is an "external" header file. Do not give away any internals here! + + GOALS + + o Enable a "pull" interface. The application that uses libcurl decides where + and when to ask libcurl to get/send data. + + o Enable multiple simultaneous transfers in the same thread without making it + complicated for the application. + + o Enable the application to select() on its own file descriptors and curl's + file descriptors simultaneous easily. + +*/ + +/* + * This header file should not really need to include "curl.h" since curl.h + * itself includes this file and we expect user applications to do #include + * without the need for especially including multi.h. + * + * For some reason we added this include here at one point, and rather than to + * break existing (wrongly written) libcurl applications, we leave it as-is + * but with this warning attached. + */ +#include "curl.h" + +#ifdef __cplusplus +extern "C" { +#endif + +typedef void CURLM; + +typedef enum { + CURLM_CALL_MULTI_PERFORM = -1, /* please call curl_multi_perform() or + curl_multi_socket*() soon */ + CURLM_OK, + CURLM_BAD_HANDLE, /* the passed-in handle is not a valid CURLM handle */ + CURLM_BAD_EASY_HANDLE, /* an easy handle was not good/valid */ + CURLM_OUT_OF_MEMORY, /* if you ever get this, you are in deep sh*t */ + CURLM_INTERNAL_ERROR, /* this is a libcurl bug */ + CURLM_BAD_SOCKET, /* the passed in socket argument did not match */ + CURLM_UNKNOWN_OPTION, /* curl_multi_setopt() with unsupported option */ + CURLM_ADDED_ALREADY, /* an easy handle already added to a multi handle was + attempted to get added - again */ + CURLM_RECURSIVE_API_CALL, /* an api function was called from inside a + callback */ + CURLM_WAKEUP_FAILURE, /* wakeup is unavailable or failed */ + CURLM_BAD_FUNCTION_ARGUMENT, /* function called with a bad parameter */ + CURLM_ABORTED_BY_CALLBACK, + CURLM_UNRECOVERABLE_POLL, + CURLM_LAST +} CURLMcode; + +/* You can check for CURLM_CALL_MULTI_SOCKET too in the same style it works + for curl_multi_perform() and CURLM_CALL_MULTI_PERFORM */ +#define CURLM_CALL_MULTI_SOCKET CURLM_CALL_MULTI_PERFORM + +/* bitmask bits for CURLMOPT_PIPELINING */ +#define CURLPIPE_NOTHING 0L +#define CURLPIPE_HTTP1 1L +#define CURLPIPE_MULTIPLEX 2L + +typedef enum { + CURLMSG_NONE, /* first, not used */ + CURLMSG_DONE, /* This easy handle has completed. 'result' contains + the CURLcode of the transfer */ + CURLMSG_LAST /* last, not used */ +} CURLMSG; + +struct CURLMsg { + CURLMSG msg; /* what this message means */ + CURL *easy_handle; /* the handle it concerns */ + union { + void *whatever; /* message-specific data */ + CURLcode result; /* return code for transfer */ + } data; +}; +typedef struct CURLMsg CURLMsg; + +/* Based on poll(2) structure and values. + * We do not use pollfd and POLL* constants explicitly + * to cover platforms without poll(). */ +#define CURL_WAIT_POLLIN 0x0001 +#define CURL_WAIT_POLLPRI 0x0002 +#define CURL_WAIT_POLLOUT 0x0004 + +struct curl_waitfd { + curl_socket_t fd; + short events; + short revents; +}; + +/* + * Name: curl_multi_init() + * + * Desc: initialize multi-style curl usage + * + * Returns: a new CURLM handle to use in all 'curl_multi' functions. + */ +CURL_EXTERN CURLM *curl_multi_init(void); + +/* + * Name: curl_multi_add_handle() + * + * Desc: add a standard curl handle to the multi stack + * + * Returns: CURLMcode type, general multi error code. + */ +CURL_EXTERN CURLMcode curl_multi_add_handle(CURLM *m, + CURL *curl); + +/* + * Name: curl_multi_remove_handle() + * + * Desc: removes a curl handle from the multi stack again + * + * Returns: CURLMcode type, general multi error code. + */ +CURL_EXTERN CURLMcode curl_multi_remove_handle(CURLM *m, + CURL *curl); + +/* + * Name: curl_multi_fdset() + * + * Desc: Ask curl for its fd_set sets. The app can use these to select() or + * poll() on. We want curl_multi_perform() called as soon as one of + * them are ready. + * + * Returns: CURLMcode type, general multi error code. + */ +CURL_EXTERN CURLMcode curl_multi_fdset(CURLM *m, + fd_set *read_fd_set, + fd_set *write_fd_set, + fd_set *exc_fd_set, + int *max_fd); + +/* + * Name: curl_multi_wait() + * + * Desc: Poll on all fds within a CURLM set as well as any + * additional fds passed to the function. + * + * Returns: CURLMcode type, general multi error code. + */ +CURL_EXTERN CURLMcode curl_multi_wait(CURLM *m, + struct curl_waitfd extra_fds[], + unsigned int extra_nfds, + int timeout_ms, + int *ret); + +/* + * Name: curl_multi_poll() + * + * Desc: Poll on all fds within a CURLM set as well as any + * additional fds passed to the function. + * + * Returns: CURLMcode type, general multi error code. + */ +CURL_EXTERN CURLMcode curl_multi_poll(CURLM *m, + struct curl_waitfd extra_fds[], + unsigned int extra_nfds, + int timeout_ms, + int *ret); + +/* + * Name: curl_multi_wakeup() + * + * Desc: wakes up a sleeping curl_multi_poll call. + * + * Returns: CURLMcode type, general multi error code. + */ +CURL_EXTERN CURLMcode curl_multi_wakeup(CURLM *m); + +/* + * Name: curl_multi_perform() + * + * Desc: When the app thinks there is data available for curl it calls this + * function to read/write whatever there is right now. This returns + * as soon as the reads and writes are done. This function does not + * require that there actually is data available for reading or that + * data can be written, it can be called. It returns the number of + * handles that still transfer data in the second argument's + * integer-pointer. + * + * Returns: CURLMcode type, general multi error code. *NOTE* that this only + * returns errors etc regarding the whole multi stack. There might + * still have occurred problems on individual transfers even when + * this returns OK. + */ +CURL_EXTERN CURLMcode curl_multi_perform(CURLM *m, + int *running_handles); + +/* + * Name: curl_multi_cleanup() + * + * Desc: Cleans up and removes a whole multi stack. It does not free or + * touch any individual easy handles in any way. We need to define + * in what state those handles are going to be if this function is + * called in the middle of a transfer. + * + * Returns: CURLMcode type, general multi error code. + */ +CURL_EXTERN CURLMcode curl_multi_cleanup(CURLM *m); + +/* + * Name: curl_multi_info_read() + * + * Desc: Ask the multi handle if there is any messages/informationals from + * the individual transfers. Messages include informationals such as + * error code from the transfer or the fact that a transfer is + * completed. More details on these should be written down as well. + * + * Repeated calls to this function return a new struct each time, + * until a special "end of msgs" struct is returned as a signal that + * there is no more to get at this point. + * + * The data the returned pointer points to does not survive calling + * curl_multi_cleanup(). + * + * The 'CURLMsg' struct is meant to be simple and only contain basic + * information. If more involved information is wanted, we provide + * the particular "transfer handle" in that struct and that + * should/could/would be used in subsequent curl_easy_getinfo() calls + * (or similar). The point being that we must never expose complex + * structs to applications, as then we undoubtably get backwards + * compatibility problems in the future. + * + * Returns: A pointer to a filled-in struct, or NULL if it failed or ran out + * of structs. It also writes the number of messages left in the + * queue (after this read) in the integer the second argument points + * to. + */ +CURL_EXTERN CURLMsg *curl_multi_info_read(CURLM *m, + int *msgs_in_queue); + +/* + * Name: curl_multi_strerror() + * + * Desc: The curl_multi_strerror function may be used to turn a CURLMcode + * value into the equivalent human readable error string. This is + * useful for printing meaningful error messages. + * + * Returns: A pointer to a null-terminated error message. + */ +CURL_EXTERN const char *curl_multi_strerror(CURLMcode error); + +/* + * Name: curl_multi_socket() and + * curl_multi_socket_all() + * + * Desc: An alternative version of curl_multi_perform() that allows the + * application to pass in one of the file descriptors that have been + * detected to have "action" on them and let libcurl perform. + * See man page for details. + */ +#define CURL_POLL_NONE 0 +#define CURL_POLL_IN 1 +#define CURL_POLL_OUT 2 +#define CURL_POLL_INOUT 3 +#define CURL_POLL_REMOVE 4 + +#define CURL_SOCKET_TIMEOUT CURL_SOCKET_BAD + +#define CURL_CSELECT_IN 0x01 +#define CURL_CSELECT_OUT 0x02 +#define CURL_CSELECT_ERR 0x04 + +typedef int (*curl_socket_callback)(CURL *easy, /* easy handle */ + curl_socket_t s, /* socket */ + int what, /* see above */ + void *userp, /* private callback + pointer */ + void *socketp); /* private socket + pointer */ +/* + * Name: curl_multi_timer_callback + * + * Desc: Called by libcurl whenever the library detects a change in the + * maximum number of milliseconds the app is allowed to wait before + * curl_multi_socket() or curl_multi_perform() must be called + * (to allow libcurl's timed events to take place). + * + * Returns: The callback should return zero. + */ +typedef int (*curl_multi_timer_callback)(CURLM *m, /* multi handle */ + long timeout_ms, /* see above */ + void *userp); /* private callback + pointer */ + +CURL_EXTERN CURLMcode CURL_DEPRECATED(7.19.5, "Use curl_multi_socket_action()") +curl_multi_socket(CURLM *m, curl_socket_t s, int *running_handles); + +CURL_EXTERN CURLMcode curl_multi_socket_action(CURLM *m, + curl_socket_t s, + int ev_bitmask, + int *running_handles); + +CURL_EXTERN CURLMcode CURL_DEPRECATED(7.19.5, "Use curl_multi_socket_action()") +curl_multi_socket_all(CURLM *m, int *running_handles); + +#ifndef CURL_ALLOW_OLD_MULTI_SOCKET +/* This macro below was added in 7.16.3 to push users who recompile to use + * the new curl_multi_socket_action() instead of the old curl_multi_socket() + */ +#define curl_multi_socket(x, y, z) curl_multi_socket_action(x, y, 0, z) +#endif + +/* + * Name: curl_multi_timeout() + * + * Desc: Returns the maximum number of milliseconds the app is allowed to + * wait before curl_multi_socket() or curl_multi_perform() must be + * called (to allow libcurl's timed events to take place). + * + * Returns: CURLM error code. + */ +CURL_EXTERN CURLMcode curl_multi_timeout(CURLM *m, + long *timeout_ms); + +typedef enum { + /* This is the socket callback function pointer */ + CURLOPT(CURLMOPT_SOCKETFUNCTION, CURLOPTTYPE_FUNCTIONPOINT, 1), + + /* This is the argument passed to the socket callback */ + CURLOPT(CURLMOPT_SOCKETDATA, CURLOPTTYPE_OBJECTPOINT, 2), + + /* set to 1 to enable pipelining for this multi handle */ + CURLOPT(CURLMOPT_PIPELINING, CURLOPTTYPE_LONG, 3), + + /* This is the timer callback function pointer */ + CURLOPT(CURLMOPT_TIMERFUNCTION, CURLOPTTYPE_FUNCTIONPOINT, 4), + + /* This is the argument passed to the timer callback */ + CURLOPT(CURLMOPT_TIMERDATA, CURLOPTTYPE_OBJECTPOINT, 5), + + /* maximum number of entries in the connection cache */ + CURLOPT(CURLMOPT_MAXCONNECTS, CURLOPTTYPE_LONG, 6), + + /* maximum number of (pipelining) connections to one host */ + CURLOPT(CURLMOPT_MAX_HOST_CONNECTIONS, CURLOPTTYPE_LONG, 7), + + /* maximum number of requests in a pipeline */ + CURLOPT(CURLMOPT_MAX_PIPELINE_LENGTH, CURLOPTTYPE_LONG, 8), + + /* a connection with a content-length longer than this + is not considered for pipelining */ + CURLOPT(CURLMOPT_CONTENT_LENGTH_PENALTY_SIZE, CURLOPTTYPE_OFF_T, 9), + + /* a connection with a chunk length longer than this + is not considered for pipelining */ + CURLOPT(CURLMOPT_CHUNK_LENGTH_PENALTY_SIZE, CURLOPTTYPE_OFF_T, 10), + + /* a list of site names(+port) that are blocked from pipelining */ + CURLOPT(CURLMOPT_PIPELINING_SITE_BL, CURLOPTTYPE_OBJECTPOINT, 11), + + /* a list of server types that are blocked from pipelining */ + CURLOPT(CURLMOPT_PIPELINING_SERVER_BL, CURLOPTTYPE_OBJECTPOINT, 12), + + /* maximum number of open connections in total */ + CURLOPT(CURLMOPT_MAX_TOTAL_CONNECTIONS, CURLOPTTYPE_LONG, 13), + + /* This is the server push callback function pointer */ + CURLOPT(CURLMOPT_PUSHFUNCTION, CURLOPTTYPE_FUNCTIONPOINT, 14), + + /* This is the argument passed to the server push callback */ + CURLOPT(CURLMOPT_PUSHDATA, CURLOPTTYPE_OBJECTPOINT, 15), + + /* maximum number of concurrent streams to support on a connection */ + CURLOPT(CURLMOPT_MAX_CONCURRENT_STREAMS, CURLOPTTYPE_LONG, 16), + + /* network has changed, adjust caches/connection reuse */ + CURLOPT(CURLMOPT_NETWORK_CHANGED, CURLOPTTYPE_LONG, 17), + + /* This is the notify callback function pointer */ + CURLOPT(CURLMOPT_NOTIFYFUNCTION, CURLOPTTYPE_FUNCTIONPOINT, 18), + + /* This is the argument passed to the notify callback */ + CURLOPT(CURLMOPT_NOTIFYDATA, CURLOPTTYPE_OBJECTPOINT, 19), + + /* maximum number of threads used with threaded DNS resolver */ + CURLOPT(CURLMOPT_RESOLVE_THREADS_MAX, CURLOPTTYPE_LONG, 20), + + /* set to 1L for not joining threads when multi is cleaned up */ + CURLOPT(CURLMOPT_QUICK_EXIT, CURLOPTTYPE_LONG, 21), + + CURLMOPT_LASTENTRY /* the last unused */ +} CURLMoption; + +/* Definition of bits for the CURLMOPT_NETWORK_CHANGED argument: */ + +/* - CURLMNWC_CLEAR_ALL tells libcurl to clear "everything" that could be + associated with this network, including both connections and DNS data. */ +#define CURLMNWC_CLEAR_ALL (1L << 0) + +/* - CURLMNWC_CLEAR_CONNS tells libcurl to prevent further reuse of existing + connections. Connections that are idle are closed. Ongoing transfers do + continue with the connection they have. */ +#define CURLMNWC_CLEAR_CONNS (1L << 1) + +/* - CURLMNWC_CLEAR_DNS tells libcurl to clear the DNS cache associated with + this multi handle. Ongoing transfers keep using their already resolved + addresses, but future name resolutions are performed again. */ +#define CURLMNWC_CLEAR_DNS (1L << 2) + +/* + * Name: curl_multi_setopt() + * + * Desc: Sets options for the multi handle. + * + * Returns: CURLM error code. + */ +CURL_EXTERN CURLMcode curl_multi_setopt(CURLM *m, + CURLMoption option, ...); + +/* + * Name: curl_multi_assign() + * + * Desc: This function sets an association in the multi handle between the + * given socket and a private pointer of the application. This is + * (only) useful for curl_multi_socket uses. + * + * Returns: CURLM error code. + */ +CURL_EXTERN CURLMcode curl_multi_assign(CURLM *m, + curl_socket_t sockfd, void *sockp); + +/* + * Name: curl_multi_get_handles() + * + * Desc: Returns an allocated array holding all handles currently added to + * the multi handle. Marks the final entry with a NULL pointer. If + * there is no easy handle added to the multi handle, this function + * returns an array with the first entry as a NULL pointer. + * + * Returns: NULL on failure, otherwise a CURL **array pointer + */ +CURL_EXTERN CURL **curl_multi_get_handles(CURLM *m); + +typedef enum { + CURLMINFO_NONE, /* first, never use this */ + /* The number of easy handles currently managed by the multi handle, + * e.g. have been added but not yet removed. */ + CURLMINFO_XFERS_CURRENT = 1, + /* The number of easy handles running, e.g. not done and not queueing. */ + CURLMINFO_XFERS_RUNNING = 2, + /* The number of easy handles waiting to start, e.g. for a connection + * to become available due to limits on parallelism, max connections + * or other factors. */ + CURLMINFO_XFERS_PENDING = 3, + /* The number of easy handles finished, waiting for their results to + * be read via `curl_multi_info_read()`. */ + CURLMINFO_XFERS_DONE = 4, + /* The total number of easy handles added to the multi handle, ever. */ + CURLMINFO_XFERS_ADDED = 5, + + CURLMINFO_LASTENTRY /* the last unused */ +} CURLMinfo_offt; + +/* + * Name: curl_multi_get_offt() + * + * Desc: Retrieves a numeric value for the `CURLMINFO_*` enums. + * + * Returns: CULRM_OK or error when value could not be obtained. + */ +CURL_EXTERN CURLMcode curl_multi_get_offt(CURLM *m, + CURLMinfo_offt info, + curl_off_t *pvalue); + +/* + * Name: curl_push_callback + * + * Desc: This callback gets called when a new stream is being pushed by the + * server. It approves or denies the new stream. It can also decide + * to completely fail the connection. + * + * Returns: CURL_PUSH_OK, CURL_PUSH_DENY or CURL_PUSH_ERROROUT + */ +#define CURL_PUSH_OK 0 +#define CURL_PUSH_DENY 1 +#define CURL_PUSH_ERROROUT 2 /* added in 7.72.0 */ + +struct curl_pushheaders; /* forward declaration only */ + +CURL_EXTERN char *curl_pushheader_bynum(struct curl_pushheaders *h, + size_t num); +CURL_EXTERN char *curl_pushheader_byname(struct curl_pushheaders *h, + const char *name); + +typedef int (*curl_push_callback)(CURL *parent, + CURL *easy, + size_t num_headers, + struct curl_pushheaders *headers, + void *userp); + +/* + * Name: curl_multi_waitfds() + * + * Desc: Ask curl for fds for polling. The app can use these to poll on. + * We want curl_multi_perform() called as soon as one of them are + * ready. Passing zero size allows to get a number of fds. + * + * Returns: CURLMcode type, general multi error code. + */ +CURL_EXTERN CURLMcode curl_multi_waitfds(CURLM *m, + struct curl_waitfd *ufds, + unsigned int size, + unsigned int *fd_count); + +/* + * Notifications dispatched by a multi handle, when enabled. + */ +#define CURLMNOTIFY_INFO_READ 0 +#define CURLMNOTIFY_EASY_DONE 1 + +/* + * Callback to install via CURLMOPT_NOTIFYFUNCTION. + */ +typedef void (*curl_notify_callback)(CURLM *m, + unsigned int notification, + CURL *easy, + void *user_data); + +CURL_EXTERN CURLMcode curl_multi_notify_disable(CURLM *m, + unsigned int notification); + +CURL_EXTERN CURLMcode curl_multi_notify_enable(CURLM *m, + unsigned int notification); + +#ifdef __cplusplus +} /* end of extern "C" */ +#endif + +#endif diff --git a/3rdparty/curl-8.21.0/include/curl/options.h b/3rdparty/curl-8.21.0/include/curl/options.h new file mode 100644 index 0000000000..835a722e91 --- /dev/null +++ b/3rdparty/curl-8.21.0/include/curl/options.h @@ -0,0 +1,70 @@ +#ifndef CURLINC_OPTIONS_H +#define CURLINC_OPTIONS_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +#ifdef __cplusplus +extern "C" { +#endif + +typedef enum { + CURLOT_LONG, /* long (a range of values) */ + CURLOT_VALUES, /* (a defined set or bitmask) */ + CURLOT_OFF_T, /* curl_off_t (a range of values) */ + CURLOT_OBJECT, /* pointer (void *) */ + CURLOT_STRING, /* (char * to null-terminated buffer) */ + CURLOT_SLIST, /* (struct curl_slist *) */ + CURLOT_CBPTR, /* (void * passed as-is to a callback) */ + CURLOT_BLOB, /* blob (struct curl_blob *) */ + CURLOT_FUNCTION /* function pointer */ +} curl_easytype; + +/* Flag bits */ + +/* "alias" means it is provided for old programs to remain functional, + we prefer another name */ +#define CURLOT_FLAG_ALIAS (1 << 0) + +/* The CURLOPTTYPE_* id ranges can still be used to figure out what type/size + to use for curl_easy_setopt() for the given id */ +struct curl_easyoption { + const char *name; + CURLoption id; + curl_easytype type; + unsigned int flags; +}; + +CURL_EXTERN const struct curl_easyoption * +curl_easy_option_by_name(const char *name); + +CURL_EXTERN const struct curl_easyoption * +curl_easy_option_by_id(CURLoption id); + +CURL_EXTERN const struct curl_easyoption * +curl_easy_option_next(const struct curl_easyoption *prev); + +#ifdef __cplusplus +} /* end of extern "C" */ +#endif +#endif /* CURLINC_OPTIONS_H */ diff --git a/3rdparty/curl-8.21.0/include/curl/stdcheaders.h b/3rdparty/curl-8.21.0/include/curl/stdcheaders.h new file mode 100644 index 0000000000..7451aa3052 --- /dev/null +++ b/3rdparty/curl-8.21.0/include/curl/stdcheaders.h @@ -0,0 +1,35 @@ +#ifndef CURLINC_STDCHEADERS_H +#define CURLINC_STDCHEADERS_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +#include + +size_t fread(void *, size_t, size_t, FILE *); +size_t fwrite(const void *, size_t, size_t, FILE *); + +int strcasecmp(const char *, const char *); +int strncasecmp(const char *, const char *, size_t); + +#endif /* CURLINC_STDCHEADERS_H */ diff --git a/3rdparty/curl-8.21.0/include/curl/system.h b/3rdparty/curl-8.21.0/include/curl/system.h new file mode 100644 index 0000000000..30216ea34c --- /dev/null +++ b/3rdparty/curl-8.21.0/include/curl/system.h @@ -0,0 +1,399 @@ +#ifndef CURLINC_SYSTEM_H +#define CURLINC_SYSTEM_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +/* + * Try to keep one section per platform, compiler and architecture, otherwise, + * if an existing section is reused for a different one and later on the + * original is adjusted, probably the piggybacking one can be adversely + * changed. + * + * In order to differentiate between platforms/compilers/architectures use + * only compiler built-in predefined preprocessor symbols. + * + * curl_off_t + * ---------- + * + * For any given platform/compiler curl_off_t MUST be typedef'ed to a 64-bit + * wide signed integral data type. The width of this data type must remain + * constant and independent of any possible large file support settings. + * + * As a general rule, curl_off_t shall not be mapped to off_t. This rule shall + * only be violated if off_t is the only 64-bit data type available and the + * size of off_t is independent of large file support settings. Keep your + * build on the safe side avoiding an off_t gating. If you have a 64-bit + * off_t then take for sure that another 64-bit data type exists, dig deeper + * to find it. + * + */ + +#ifdef __DJGPP__ +# define CURL_TYPEOF_CURL_OFF_T long long +# define CURL_FORMAT_CURL_OFF_T "lld" +# define CURL_FORMAT_CURL_OFF_TU "llu" +# define CURL_SUFFIX_CURL_OFF_T LL +# define CURL_SUFFIX_CURL_OFF_TU ULL +# define CURL_TYPEOF_CURL_SOCKLEN_T int + +#elif defined(__BORLANDC__) +# define CURL_TYPEOF_CURL_OFF_T __int64 +# define CURL_FORMAT_CURL_OFF_T "I64d" +# define CURL_FORMAT_CURL_OFF_TU "I64u" +# define CURL_SUFFIX_CURL_OFF_T i64 +# define CURL_SUFFIX_CURL_OFF_TU ui64 +# define CURL_TYPEOF_CURL_SOCKLEN_T int + +#elif defined(__POCC__) +# ifdef _MSC_VER +# define CURL_TYPEOF_CURL_OFF_T __int64 +# define CURL_FORMAT_CURL_OFF_T "I64d" +# define CURL_FORMAT_CURL_OFF_TU "I64u" +# define CURL_SUFFIX_CURL_OFF_T i64 +# define CURL_SUFFIX_CURL_OFF_TU ui64 +# else +# define CURL_TYPEOF_CURL_OFF_T long long +# define CURL_FORMAT_CURL_OFF_T "lld" +# define CURL_FORMAT_CURL_OFF_TU "llu" +# define CURL_SUFFIX_CURL_OFF_T LL +# define CURL_SUFFIX_CURL_OFF_TU ULL +# endif +# define CURL_TYPEOF_CURL_SOCKLEN_T int + +#elif defined(__LCC__) +# ifdef __MCST__ /* MCST eLbrus Compiler Collection */ +# define CURL_TYPEOF_CURL_OFF_T long +# define CURL_FORMAT_CURL_OFF_T "ld" +# define CURL_FORMAT_CURL_OFF_TU "lu" +# define CURL_SUFFIX_CURL_OFF_T L +# define CURL_SUFFIX_CURL_OFF_TU UL +# define CURL_TYPEOF_CURL_SOCKLEN_T socklen_t +# define CURL_PULL_SYS_TYPES_H 1 +# define CURL_PULL_SYS_SOCKET_H 1 +# else /* Local (or Little) C Compiler */ +# define CURL_TYPEOF_CURL_OFF_T long +# define CURL_FORMAT_CURL_OFF_T "ld" +# define CURL_FORMAT_CURL_OFF_TU "lu" +# define CURL_SUFFIX_CURL_OFF_T L +# define CURL_SUFFIX_CURL_OFF_TU UL +# define CURL_TYPEOF_CURL_SOCKLEN_T int +# endif + +#elif defined(macintosh) +# include +# if TYPE_LONGLONG +# define CURL_TYPEOF_CURL_OFF_T long long +# define CURL_FORMAT_CURL_OFF_T "lld" +# define CURL_FORMAT_CURL_OFF_TU "llu" +# define CURL_SUFFIX_CURL_OFF_T LL +# define CURL_SUFFIX_CURL_OFF_TU ULL +# else +# define CURL_TYPEOF_CURL_OFF_T long +# define CURL_FORMAT_CURL_OFF_T "ld" +# define CURL_FORMAT_CURL_OFF_TU "lu" +# define CURL_SUFFIX_CURL_OFF_T L +# define CURL_SUFFIX_CURL_OFF_TU UL +# endif +# define CURL_TYPEOF_CURL_SOCKLEN_T unsigned int + +#elif defined(__TANDEM) +# ifndef __LP64 +# define CURL_TYPEOF_CURL_OFF_T long long +# define CURL_FORMAT_CURL_OFF_T "lld" +# define CURL_FORMAT_CURL_OFF_TU "llu" +# define CURL_SUFFIX_CURL_OFF_T LL +# define CURL_SUFFIX_CURL_OFF_TU ULL +# define CURL_TYPEOF_CURL_SOCKLEN_T int +# else +# define CURL_TYPEOF_CURL_OFF_T long +# define CURL_FORMAT_CURL_OFF_T "ld" +# define CURL_FORMAT_CURL_OFF_TU "lu" +# define CURL_SUFFIX_CURL_OFF_T L +# define CURL_SUFFIX_CURL_OFF_TU UL +# define CURL_TYPEOF_CURL_SOCKLEN_T unsigned int +# endif + +#elif defined(UNDER_CE) +# define CURL_TYPEOF_CURL_OFF_T __int64 +# define CURL_FORMAT_CURL_OFF_T "I64d" +# define CURL_FORMAT_CURL_OFF_TU "I64u" +# define CURL_SUFFIX_CURL_OFF_T i64 +# define CURL_SUFFIX_CURL_OFF_TU ui64 +# define CURL_TYPEOF_CURL_SOCKLEN_T int + +#elif defined(__MINGW32__) +# include +# define CURL_TYPEOF_CURL_OFF_T long long +# define CURL_FORMAT_CURL_OFF_T PRId64 +# define CURL_FORMAT_CURL_OFF_TU PRIu64 +# define CURL_SUFFIX_CURL_OFF_T LL +# define CURL_SUFFIX_CURL_OFF_TU ULL +# define CURL_TYPEOF_CURL_SOCKLEN_T int +# define CURL_PULL_SYS_TYPES_H 1 + +#elif defined(__VMS) +# ifdef __VAX +# define CURL_TYPEOF_CURL_OFF_T long +# define CURL_FORMAT_CURL_OFF_T "ld" +# define CURL_FORMAT_CURL_OFF_TU "lu" +# define CURL_SUFFIX_CURL_OFF_T L +# define CURL_SUFFIX_CURL_OFF_TU UL +# else +# define CURL_TYPEOF_CURL_OFF_T long long +# define CURL_FORMAT_CURL_OFF_T "lld" +# define CURL_FORMAT_CURL_OFF_TU "llu" +# define CURL_SUFFIX_CURL_OFF_T LL +# define CURL_SUFFIX_CURL_OFF_TU ULL +# endif +# define CURL_TYPEOF_CURL_SOCKLEN_T unsigned int + +#elif defined(__OS400__) +# define CURL_TYPEOF_CURL_OFF_T long long +# define CURL_FORMAT_CURL_OFF_T "lld" +# define CURL_FORMAT_CURL_OFF_TU "llu" +# define CURL_SUFFIX_CURL_OFF_T LL +# define CURL_SUFFIX_CURL_OFF_TU ULL +# define CURL_TYPEOF_CURL_SOCKLEN_T socklen_t +# define CURL_PULL_SYS_TYPES_H 1 +# define CURL_PULL_SYS_SOCKET_H 1 + +#elif defined(__MVS__) +# ifdef _LONG_LONG +# define CURL_TYPEOF_CURL_OFF_T long long +# define CURL_FORMAT_CURL_OFF_T "lld" +# define CURL_FORMAT_CURL_OFF_TU "llu" +# define CURL_SUFFIX_CURL_OFF_T LL +# define CURL_SUFFIX_CURL_OFF_TU ULL +# else /* _LP64 and default */ +# define CURL_TYPEOF_CURL_OFF_T long +# define CURL_FORMAT_CURL_OFF_T "ld" +# define CURL_FORMAT_CURL_OFF_TU "lu" +# define CURL_SUFFIX_CURL_OFF_T L +# define CURL_SUFFIX_CURL_OFF_TU UL +# endif +# define CURL_TYPEOF_CURL_SOCKLEN_T socklen_t +# define CURL_PULL_SYS_TYPES_H 1 +# define CURL_PULL_SYS_SOCKET_H 1 + +#elif defined(__370__) +# if defined(__IBMC__) || defined(__IBMCPP__) +# ifdef _LONG_LONG +# define CURL_TYPEOF_CURL_OFF_T long long +# define CURL_FORMAT_CURL_OFF_T "lld" +# define CURL_FORMAT_CURL_OFF_TU "llu" +# define CURL_SUFFIX_CURL_OFF_T LL +# define CURL_SUFFIX_CURL_OFF_TU ULL +# else /* _LP64 and default */ +# define CURL_TYPEOF_CURL_OFF_T long +# define CURL_FORMAT_CURL_OFF_T "ld" +# define CURL_FORMAT_CURL_OFF_TU "lu" +# define CURL_SUFFIX_CURL_OFF_T L +# define CURL_SUFFIX_CURL_OFF_TU UL +# endif +# define CURL_TYPEOF_CURL_SOCKLEN_T socklen_t +# define CURL_PULL_SYS_TYPES_H 1 +# define CURL_PULL_SYS_SOCKET_H 1 +# endif + +#elif defined(TPF) +# define CURL_TYPEOF_CURL_OFF_T long +# define CURL_FORMAT_CURL_OFF_T "ld" +# define CURL_FORMAT_CURL_OFF_TU "lu" +# define CURL_SUFFIX_CURL_OFF_T L +# define CURL_SUFFIX_CURL_OFF_TU UL +# define CURL_TYPEOF_CURL_SOCKLEN_T int + +#elif defined(__TINYC__) /* also known as tcc */ +# define CURL_TYPEOF_CURL_OFF_T long long +# define CURL_FORMAT_CURL_OFF_T "lld" +# define CURL_FORMAT_CURL_OFF_TU "llu" +# define CURL_SUFFIX_CURL_OFF_T LL +# define CURL_SUFFIX_CURL_OFF_TU ULL +# define CURL_TYPEOF_CURL_SOCKLEN_T socklen_t +# define CURL_PULL_SYS_TYPES_H 1 +# define CURL_PULL_SYS_SOCKET_H 1 + +#elif defined(__SUNPRO_C) || defined(__SUNPRO_CC) /* Oracle Solaris Studio */ +# if !defined(__LP64) && (defined(__ILP32) || \ + defined(__i386) || \ + defined(__sparcv8) || \ + defined(__sparcv8plus)) +# define CURL_TYPEOF_CURL_OFF_T long long +# define CURL_FORMAT_CURL_OFF_T "lld" +# define CURL_FORMAT_CURL_OFF_TU "llu" +# define CURL_SUFFIX_CURL_OFF_T LL +# define CURL_SUFFIX_CURL_OFF_TU ULL +# elif defined(__LP64) || \ + defined(__amd64) || defined(__sparcv9) +# define CURL_TYPEOF_CURL_OFF_T long +# define CURL_FORMAT_CURL_OFF_T "ld" +# define CURL_FORMAT_CURL_OFF_TU "lu" +# define CURL_SUFFIX_CURL_OFF_T L +# define CURL_SUFFIX_CURL_OFF_TU UL +# endif +# define CURL_TYPEOF_CURL_SOCKLEN_T socklen_t +# define CURL_PULL_SYS_TYPES_H 1 +# define CURL_PULL_SYS_SOCKET_H 1 + +#elif defined(__xlc__) /* IBM xlc compiler */ +# ifndef _LP64 +# define CURL_TYPEOF_CURL_OFF_T long long +# define CURL_FORMAT_CURL_OFF_T "lld" +# define CURL_FORMAT_CURL_OFF_TU "llu" +# define CURL_SUFFIX_CURL_OFF_T LL +# define CURL_SUFFIX_CURL_OFF_TU ULL +# else +# define CURL_TYPEOF_CURL_OFF_T long +# define CURL_FORMAT_CURL_OFF_T "ld" +# define CURL_FORMAT_CURL_OFF_TU "lu" +# define CURL_SUFFIX_CURL_OFF_T L +# define CURL_SUFFIX_CURL_OFF_TU UL +# endif +# define CURL_TYPEOF_CURL_SOCKLEN_T socklen_t +# define CURL_PULL_SYS_TYPES_H 1 +# define CURL_PULL_SYS_SOCKET_H 1 + +#elif defined(__hpux) /* HP aCC compiler */ +# ifndef _LP64 +# define CURL_TYPEOF_CURL_OFF_T long long +# define CURL_FORMAT_CURL_OFF_T "lld" +# define CURL_FORMAT_CURL_OFF_TU "llu" +# define CURL_SUFFIX_CURL_OFF_T LL +# define CURL_SUFFIX_CURL_OFF_TU ULL +# else +# define CURL_TYPEOF_CURL_OFF_T long +# define CURL_FORMAT_CURL_OFF_T "ld" +# define CURL_FORMAT_CURL_OFF_TU "lu" +# define CURL_SUFFIX_CURL_OFF_T L +# define CURL_SUFFIX_CURL_OFF_TU UL +# endif +# define CURL_TYPEOF_CURL_SOCKLEN_T socklen_t +# define CURL_PULL_SYS_TYPES_H 1 +# define CURL_PULL_SYS_SOCKET_H 1 + +/* ===================================== */ +/* KEEP MSVC THE PENULTIMATE ENTRY */ +/* ===================================== */ + +#elif defined(_MSC_VER) +# if _MSC_VER >= 1800 +# include +# define CURL_FORMAT_CURL_OFF_T PRId64 +# define CURL_FORMAT_CURL_OFF_TU PRIu64 +# else +# define CURL_FORMAT_CURL_OFF_T "I64d" +# define CURL_FORMAT_CURL_OFF_TU "I64u" +# endif +# define CURL_TYPEOF_CURL_OFF_T __int64 +# define CURL_SUFFIX_CURL_OFF_T i64 +# define CURL_SUFFIX_CURL_OFF_TU ui64 +# define CURL_TYPEOF_CURL_SOCKLEN_T int + +/* ===================================== */ +/* KEEP GENERIC GCC THE LAST ENTRY */ +/* ===================================== */ + +#elif defined(__GNUC__) && !defined(_SCO_DS) +# if !defined(__LP64__) && \ + (defined(__ILP32__) || defined(__i386__) || defined(__hppa__) || \ + defined(__ppc__) || defined(__powerpc__) || defined(__arm__) || \ + defined(__sparc__) || defined(__mips__) || defined(__sh__) || \ + defined(__XTENSA__) || \ + (defined(__SIZEOF_LONG__) && __SIZEOF_LONG__ == 4) || \ + (defined(__LONG_MAX__) && __LONG_MAX__ == 2147483647L)) +# define CURL_TYPEOF_CURL_OFF_T long long +# define CURL_FORMAT_CURL_OFF_T "lld" +# define CURL_FORMAT_CURL_OFF_TU "llu" +# define CURL_SUFFIX_CURL_OFF_T LL +# define CURL_SUFFIX_CURL_OFF_TU ULL +# if (__GNUC__ >= 4) || \ + ((__GNUC__ == 3) && defined(__GNUC_MINOR__) && (__GNUC_MINOR__ >= 4)) +# define CURL_POPCOUNT64(x) __builtin_popcountll(x) +# define CURL_CTZ64(x) __builtin_ctzll(x) +# endif +# elif defined(__LP64__) || \ + defined(__x86_64__) || defined(__ppc64__) || defined(__sparc64__) || \ + defined(__e2k__) || \ + (defined(__SIZEOF_LONG__) && __SIZEOF_LONG__ == 8) || \ + (defined(__LONG_MAX__) && __LONG_MAX__ == 9223372036854775807L) +# define CURL_TYPEOF_CURL_OFF_T long +# define CURL_FORMAT_CURL_OFF_T "ld" +# define CURL_FORMAT_CURL_OFF_TU "lu" +# define CURL_SUFFIX_CURL_OFF_T L +# define CURL_SUFFIX_CURL_OFF_TU UL +# if (__GNUC__ >= 4) || \ + ((__GNUC__ == 3) && defined(__GNUC_MINOR__) && (__GNUC_MINOR__ >= 4)) +# define CURL_POPCOUNT64(x) __builtin_popcountl(x) +# define CURL_CTZ64(x) __builtin_ctzl(x) +# endif +# endif +# define CURL_TYPEOF_CURL_SOCKLEN_T socklen_t +# define CURL_PULL_SYS_TYPES_H 1 +# define CURL_PULL_SYS_SOCKET_H 1 + +#else +/* generic "safe guess" on old 32-bit style */ +# define CURL_TYPEOF_CURL_OFF_T long long +# define CURL_FORMAT_CURL_OFF_T "lld" +# define CURL_FORMAT_CURL_OFF_TU "llu" +# define CURL_SUFFIX_CURL_OFF_T LL +# define CURL_SUFFIX_CURL_OFF_TU ULL +# define CURL_TYPEOF_CURL_SOCKLEN_T int +#endif + +#ifdef _AIX +/* AIX needs */ +#define CURL_PULL_SYS_POLL_H +#endif + +/* CURL_PULL_SYS_TYPES_H is defined above when inclusion of header file + sys/types.h is required here to properly make type definitions below. */ +#ifdef CURL_PULL_SYS_TYPES_H +# include +#endif + +/* CURL_PULL_SYS_SOCKET_H is defined above when inclusion of header file + sys/socket.h is required here to properly make type definitions below. */ +#ifdef CURL_PULL_SYS_SOCKET_H +# include +#endif + +/* CURL_PULL_SYS_POLL_H is defined above when inclusion of header file + sys/poll.h is required here to properly make type definitions below. */ +#ifdef CURL_PULL_SYS_POLL_H +# include +#endif + +/* Data type definition of curl_socklen_t. */ +#ifdef CURL_TYPEOF_CURL_SOCKLEN_T + typedef CURL_TYPEOF_CURL_SOCKLEN_T curl_socklen_t; +#endif + +/* Data type definition of curl_off_t. */ + +#ifdef CURL_TYPEOF_CURL_OFF_T + typedef CURL_TYPEOF_CURL_OFF_T curl_off_t; +#endif + +#endif /* CURLINC_SYSTEM_H */ diff --git a/3rdparty/curl-8.21.0/include/curl/typecheck-gcc.h b/3rdparty/curl-8.21.0/include/curl/typecheck-gcc.h new file mode 100644 index 0000000000..d600c73cdc --- /dev/null +++ b/3rdparty/curl-8.21.0/include/curl/typecheck-gcc.h @@ -0,0 +1,960 @@ +#ifndef CURLINC_TYPECHECK_GCC_H +#define CURLINC_TYPECHECK_GCC_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +/* wraps curl_easy_setopt() with type checking */ + +/* To add a new kind of warning, add an + * if(curlcheck_sometype_option(_curl_opt)) + * if(!curlcheck_sometype(value)) + * Wcurl_easy_setopt_err_sometype(); + * block and define curlcheck_sometype_option, curlcheck_sometype and + * Wcurl_easy_setopt_err_sometype below + * + * NOTE: We use two nested 'if' statements here instead of the && operator, in + * order to work around gcc bug #32061. It affects only gcc 4.3.x/4.4.x + * when compiling with -Wlogical-op. + * + * To add an option that uses the same type as an existing option, you need + * to extend the appropriate _curl_*_option macro + */ + +#define curl_easy_setopt(handle, option, value) \ + __extension__({ \ + if(__builtin_constant_p(option)) { \ + CURL_IGNORE_DEPRECATION( \ + if(curlcheck_long_option(option)) \ + if(!curlcheck_long(value)) \ + Wcurl_easy_setopt_err_long(); \ + if(curlcheck_off_t_option(option)) \ + if(!curlcheck_off_t(value)) \ + Wcurl_easy_setopt_err_curl_off_t(); \ + if(curlcheck_string_option(option)) \ + if(!curlcheck_string(value)) \ + Wcurl_easy_setopt_err_string(); \ + if((option) == CURLOPT_PRIVATE) { } \ + if(curlcheck_write_cb_option(option)) \ + if(!curlcheck_write_cb(value)) \ + Wcurl_easy_setopt_err_write_callback(); \ + if(curlcheck_curl_option(option)) \ + if(!curlcheck_curl(value)) \ + Wcurl_easy_setopt_err_curl(); \ + if((option) == CURLOPT_RESOLVER_START_FUNCTION) \ + if(!curlcheck_resolver_start_callback(value)) \ + Wcurl_easy_setopt_err_resolver_start_callback(); \ + if((option) == CURLOPT_READFUNCTION) \ + if(!curlcheck_read_cb(value)) \ + Wcurl_easy_setopt_err_read_cb(); \ + if((option) == CURLOPT_IOCTLFUNCTION) \ + if(!curlcheck_ioctl_cb(value)) \ + Wcurl_easy_setopt_err_ioctl_cb(); \ + if((option) == CURLOPT_SOCKOPTFUNCTION) \ + if(!curlcheck_sockopt_cb(value)) \ + Wcurl_easy_setopt_err_sockopt_cb(); \ + if((option) == CURLOPT_OPENSOCKETFUNCTION) \ + if(!curlcheck_opensocket_cb(value)) \ + Wcurl_easy_setopt_err_opensocket_cb(); \ + if((option) == CURLOPT_PROGRESSFUNCTION) \ + if(!curlcheck_progress_cb(value)) \ + Wcurl_easy_setopt_err_progress_cb(); \ + if((option) == CURLOPT_XFERINFOFUNCTION) \ + if(!curlcheck_xferinfo_cb(value)) \ + Wcurl_easy_setopt_err_xferinfo_cb(); \ + if((option) == CURLOPT_DEBUGFUNCTION) \ + if(!curlcheck_debug_cb(value)) \ + Wcurl_easy_setopt_err_debug_cb(); \ + if((option) == CURLOPT_SSL_CTX_FUNCTION) \ + if(!curlcheck_ssl_ctx_cb(value)) \ + Wcurl_easy_setopt_err_ssl_ctx_cb(); \ + if(curlcheck_conv_cb_option(option)) \ + if(!curlcheck_conv_cb(value)) \ + Wcurl_easy_setopt_err_conv_cb(); \ + if((option) == CURLOPT_SEEKFUNCTION) \ + if(!curlcheck_seek_cb(value)) \ + Wcurl_easy_setopt_err_seek_cb(); \ + if((option) == CURLOPT_CHUNK_BGN_FUNCTION) \ + if(!curlcheck_chunk_bgn_cb(value)) \ + Wcurl_easy_setopt_err_chunk_bgn_cb(); \ + if((option) == CURLOPT_CHUNK_END_FUNCTION) \ + if(!curlcheck_chunk_end_cb(value)) \ + Wcurl_easy_setopt_err_chunk_end_cb(); \ + if((option) == CURLOPT_CLOSESOCKETFUNCTION) \ + if(!curlcheck_close_socket_cb(value)) \ + Wcurl_easy_setopt_err_close_socket_cb(); \ + if((option) == CURLOPT_FNMATCH_FUNCTION) \ + if(!curlcheck_fnmatch_cb(value)) \ + Wcurl_easy_setopt_err_fnmatch_cb(); \ + if((option) == CURLOPT_HSTSREADFUNCTION) \ + if(!curlcheck_hstsread_cb(value)) \ + Wcurl_easy_setopt_err_hstsread_cb(); \ + if((option) == CURLOPT_HSTSWRITEFUNCTION) \ + if(!curlcheck_hstswrite_cb(value)) \ + Wcurl_easy_setopt_err_hstswrite_cb(); \ + if((option) == CURLOPT_SSH_HOSTKEYFUNCTION) \ + if(!curlcheck_ssh_hostkey_cb(value)) \ + Wcurl_easy_setopt_err_ssh_hostkey_cb(); \ + if((option) == CURLOPT_SSH_KEYFUNCTION) \ + if(!curlcheck_ssh_key_cb(value)) \ + Wcurl_easy_setopt_err_ssh_key_cb(); \ + if((option) == CURLOPT_INTERLEAVEFUNCTION) \ + if(!curlcheck_interleave_cb(value)) \ + Wcurl_easy_setopt_err_interleave_cb(); \ + if((option) == CURLOPT_PREREQFUNCTION) \ + if(!curlcheck_prereq_cb(value)) \ + Wcurl_easy_setopt_err_prereq_cb(); \ + if((option) == CURLOPT_TRAILERFUNCTION) \ + if(!curlcheck_trailer_cb(value)) \ + Wcurl_easy_setopt_err_trailer_cb(); \ + if(curlcheck_cb_data_option(option)) \ + if(!curlcheck_cb_data(value)) \ + Wcurl_easy_setopt_err_cb_data(); \ + if((option) == CURLOPT_ERRORBUFFER) \ + if(!curlcheck_error_buffer(value)) \ + Wcurl_easy_setopt_err_error_buffer(); \ + if((option) == CURLOPT_CURLU) \ + if(!curlcheck_ptr((value), CURLU)) \ + Wcurl_easy_setopt_err_curlu(); \ + if((option) == CURLOPT_STDERR) \ + if(!curlcheck_FILE(value)) \ + Wcurl_easy_setopt_err_FILE(); \ + if(curlcheck_postfields_option(option)) \ + if(!curlcheck_postfields(value)) \ + Wcurl_easy_setopt_err_postfields(); \ + if((option) == CURLOPT_HTTPPOST) \ + if(!curlcheck_arr((value), struct curl_httppost)) \ + Wcurl_easy_setopt_err_curl_httpost(); \ + if((option) == CURLOPT_MIMEPOST) \ + if(!curlcheck_ptr((value), curl_mime)) \ + Wcurl_easy_setopt_err_curl_mimepost(); \ + if(curlcheck_slist_option(option)) \ + if(!curlcheck_arr((value), struct curl_slist)) \ + Wcurl_easy_setopt_err_curl_slist(); \ + if((option) == CURLOPT_SHARE) \ + if(!curlcheck_ptr((value), CURLSH)) \ + Wcurl_easy_setopt_err_CURLSH(); \ + ) \ + } \ + (curl_easy_setopt)(handle, option, value); \ + }) + +/* wraps curl_easy_getinfo() with type checking */ +#define curl_easy_getinfo(handle, info, arg) \ + __extension__({ \ + if(__builtin_constant_p(info)) { \ + CURL_IGNORE_DEPRECATION( \ + if(curlcheck_string_info(info)) \ + if(!curlcheck_arr((arg), char *)) \ + Wcurl_easy_getinfo_err_string(); \ + if(curlcheck_long_info(info)) \ + if(!curlcheck_arr((arg), long)) \ + Wcurl_easy_getinfo_err_long(); \ + if(curlcheck_double_info(info)) \ + if(!curlcheck_arr((arg), double)) \ + Wcurl_easy_getinfo_err_double(); \ + if(curlcheck_slist_info(info)) \ + if(!curlcheck_arr((arg), struct curl_slist *)) \ + Wcurl_easy_getinfo_err_curl_slist(); \ + if(curlcheck_tlssessioninfo_info(info)) \ + if(!curlcheck_arr((arg), struct curl_tlssessioninfo *)) \ + Wcurl_easy_getinfo_err_curl_tlssessioninfo(); \ + if(curlcheck_certinfo_info(info)) \ + if(!curlcheck_arr((arg), struct curl_certinfo *)) \ + Wcurl_easy_getinfo_err_curl_certinfo(); \ + if(curlcheck_socket_info(info)) \ + if(!curlcheck_arr((arg), curl_socket_t)) \ + Wcurl_easy_getinfo_err_curl_socket(); \ + if(curlcheck_off_t_info(info)) \ + if(!curlcheck_arr((arg), curl_off_t)) \ + Wcurl_easy_getinfo_err_curl_off_t(); \ + ) \ + } \ + (curl_easy_getinfo)(handle, info, arg); \ + }) + +#define curl_multi_setopt(handle, option, value) \ + __extension__({ \ + if(__builtin_constant_p(option)) { \ + if(curlcheck_long_option(option)) \ + if(!curlcheck_long(value)) \ + Wcurl_multi_setopt_err_long(); \ + if(curlcheck_off_t_option(option)) \ + if(!curlcheck_off_t(value)) \ + Wcurl_multi_setopt_err_curl_off_t(); \ + if(curlcheck_multicb_data_option(option)) \ + if(!curlcheck_cb_data(value)) \ + Wcurl_multi_setopt_err_cb_data(); \ + if(curlcheck_charpp_option(option)) \ + if(!curlcheck_ptrptr(value, char)) \ + Wcurl_multi_setopt_err_charpp(); \ + if((option) == CURLMOPT_NOTIFYFUNCTION) \ + if(!curlcheck_multinotify_cb(value)) \ + Wcurl_multi_setopt_err_notifycb(); \ + if((option) == CURLMOPT_PUSHFUNCTION) \ + if(!curlcheck_multipush_cb(value)) \ + Wcurl_multi_setopt_err_pushcb(); \ + if((option) == CURLMOPT_SOCKETFUNCTION) \ + if(!curlcheck_multisocket_cb(value)) \ + Wcurl_multi_setopt_err_socketcb(); \ + if((option) == CURLMOPT_TIMERFUNCTION) \ + if(!curlcheck_multitimer_cb(value)) \ + Wcurl_multi_setopt_err_timercb(); \ + } \ + (curl_multi_setopt)(handle, option, value); \ + }) + +/* evaluates to true if the option takes a data argument to pass to a + callback */ +#define curlcheck_multicb_data_option(option) \ + ((option) == CURLMOPT_NOTIFYDATA || \ + (option) == CURLMOPT_PUSHDATA || \ + (option) == CURLMOPT_SOCKETDATA || \ + (option) == CURLMOPT_TIMERDATA || \ + 0) + +/* evaluates to true if the option takes a char ** argument */ +#define curlcheck_charpp_option(option) \ + ((option) == CURLMOPT_PIPELINING_SERVER_BL || \ + (option) == CURLMOPT_PIPELINING_SITE_BL || \ + 0) + +/* evaluates to true if expr is of type curl_multi_timer_callback */ +#define curlcheck_multitimer_cb(expr) \ + (curlcheck_NULL(expr) || \ + curlcheck_cb_compatible((expr), curl_multi_timer_callback)) + +/* evaluates to true if expr is of type curl_socket_callback */ +#define curlcheck_multisocket_cb(expr) \ + (curlcheck_NULL(expr) || \ + curlcheck_cb_compatible((expr), curl_socket_callback)) + +/* evaluates to true if expr is of type curl_push_callback */ +#define curlcheck_multipush_cb(expr) \ + (curlcheck_NULL(expr) || \ + curlcheck_cb_compatible((expr), curl_push_callback)) + +/* evaluates to true if expr is of type curl_push_callback */ +#define curlcheck_multinotify_cb(expr) \ + (curlcheck_NULL(expr) || \ + curlcheck_cb_compatible((expr), curl_notify_callback)) + +/* + * Make sure that the functions are called with three arguments + */ +#define curl_share_setopt(share, opt, param) \ + (curl_share_setopt)(share, opt, param) + +/* the actual warnings, triggered by calling the Wcurl_easy_setopt_err* + * functions */ + +/* To define a new warning, use _CURL_WARNING(identifier, "message") */ +#define CURLWARNING(id, message) \ + static void __attribute__((__warning__(message))) \ + __attribute__((__unused__)) __attribute__((__noinline__)) \ + id(void) { __asm__(""); } + +CURLWARNING(Wcurl_multi_setopt_err_long, + "curl_multi_setopt expects a long argument") +CURLWARNING(Wcurl_multi_setopt_err_curl_off_t, + "curl_multi_setopt expects a curl_off_t argument") +CURLWARNING(Wcurl_multi_setopt_err_cb_data, + "curl_multi_setopt expects a 'void *' argument") +CURLWARNING(Wcurl_multi_setopt_err_charpp, + "curl_multi_setopt expects a 'char **' argument") +CURLWARNING(Wcurl_multi_setopt_err_pushcb, + "curl_multi_setopt expects a curl_push_callback argument") +CURLWARNING(Wcurl_multi_setopt_err_notifycb, + "curl_multi_setopt expects a curl_notify_callback argument") +CURLWARNING(Wcurl_multi_setopt_err_socketcb, + "curl_multi_setopt expects a curl_socket_callback argument") +CURLWARNING(Wcurl_multi_setopt_err_timercb, + "curl_multi_setopt expects a curl_multi_timer_callback argument") + +CURLWARNING(Wcurl_easy_setopt_err_long, + "curl_easy_setopt expects a long argument") +CURLWARNING(Wcurl_easy_setopt_err_curl_off_t, + "curl_easy_setopt expects a curl_off_t argument") +CURLWARNING(Wcurl_easy_setopt_err_string, + "curl_easy_setopt expects a " + "string ('char *' or char[]) argument") +CURLWARNING(Wcurl_easy_setopt_err_write_callback, + "curl_easy_setopt expects a curl_write_callback argument") +CURLWARNING(Wcurl_easy_setopt_err_resolver_start_callback, + "curl_easy_setopt expects a " + "curl_resolver_start_callback argument") +CURLWARNING(Wcurl_easy_setopt_err_read_cb, + "curl_easy_setopt expects a curl_read_callback argument") +CURLWARNING(Wcurl_easy_setopt_err_ioctl_cb, + "curl_easy_setopt expects a curl_ioctl_callback argument") +CURLWARNING(Wcurl_easy_setopt_err_sockopt_cb, + "curl_easy_setopt expects a curl_sockopt_callback argument") +CURLWARNING(Wcurl_easy_setopt_err_opensocket_cb, + "curl_easy_setopt expects a " + "curl_opensocket_callback argument") +CURLWARNING(Wcurl_easy_setopt_err_progress_cb, + "curl_easy_setopt expects a curl_progress_callback argument") +CURLWARNING(Wcurl_easy_setopt_err_xferinfo_cb, + "curl_easy_setopt expects a curl_xferinfo_callback argument") +CURLWARNING(Wcurl_easy_setopt_err_debug_cb, + "curl_easy_setopt expects a curl_debug_callback argument") +CURLWARNING(Wcurl_easy_setopt_err_ssl_ctx_cb, + "curl_easy_setopt expects a curl_ssl_ctx_callback argument") +CURLWARNING(Wcurl_easy_setopt_err_conv_cb, + "curl_easy_setopt expects a curl_conv_callback argument") +CURLWARNING(Wcurl_easy_setopt_err_seek_cb, + "curl_easy_setopt expects a curl_seek_callback argument") +CURLWARNING(Wcurl_easy_setopt_err_cb_data, + "curl_easy_setopt expects a " + "private data pointer as argument") +CURLWARNING(Wcurl_easy_setopt_err_chunk_bgn_cb, + "curl_easy_setopt expects a curl_chunk_bgn_callback argument") +CURLWARNING(Wcurl_easy_setopt_err_chunk_end_cb, + "curl_easy_setopt expects a curl_chunk_end_callback argument") +CURLWARNING(Wcurl_easy_setopt_err_close_socket_cb, + "curl_easy_setopt expects a curl_closesocket_callback argument") +CURLWARNING(Wcurl_easy_setopt_err_fnmatch_cb, + "curl_easy_setopt expects a curl_fnmatch_callback argument") +CURLWARNING(Wcurl_easy_setopt_err_hstsread_cb, + "curl_easy_setopt expects a curl_hstsread_callback argument") +CURLWARNING(Wcurl_easy_setopt_err_hstswrite_cb, + "curl_easy_setopt expects a curl_hstswrite_callback argument") +CURLWARNING(Wcurl_easy_setopt_err_ssh_key_cb, + "curl_easy_setopt expects a curl_sshkeycallback argument") +CURLWARNING(Wcurl_easy_setopt_err_ssh_hostkey_cb, + "curl_easy_setopt expects a curl_sshhostkeycallback argument") +CURLWARNING(Wcurl_easy_setopt_err_interleave_cb, + "curl_easy_setopt expects a curl_interleave_callback argument") +CURLWARNING(Wcurl_easy_setopt_err_prereq_cb, + "curl_easy_setopt expects a curl_prereq_callback argument") +CURLWARNING(Wcurl_easy_setopt_err_trailer_cb, + "curl_easy_setopt expects a curl_trailerfunc_ok argument") +CURLWARNING(Wcurl_easy_setopt_err_error_buffer, + "curl_easy_setopt expects a " + "char buffer of CURL_ERROR_SIZE as argument") +CURLWARNING(Wcurl_easy_setopt_err_curlu, + "curl_easy_setopt expects a 'CURLU *' argument") +CURLWARNING(Wcurl_easy_setopt_err_curl, + "curl_easy_setopt expects a 'CURL *' argument") +CURLWARNING(Wcurl_easy_setopt_err_FILE, + "curl_easy_setopt expects a 'FILE *' argument") +CURLWARNING(Wcurl_easy_setopt_err_postfields, + "curl_easy_setopt expects a 'void *' or 'char *' argument") +CURLWARNING(Wcurl_easy_setopt_err_curl_httpost, + "curl_easy_setopt expects a 'struct curl_httppost *' " + "argument") +CURLWARNING(Wcurl_easy_setopt_err_curl_mimepost, + "curl_easy_setopt expects a 'curl_mime *' " + "argument") +CURLWARNING(Wcurl_easy_setopt_err_curl_slist, + "curl_easy_setopt expects a 'struct curl_slist *' argument") +CURLWARNING(Wcurl_easy_setopt_err_CURLSH, + "curl_easy_setopt expects a CURLSH* argument") +CURLWARNING(Wcurl_easy_getinfo_err_string, + "curl_easy_getinfo expects a pointer to 'char *'") +CURLWARNING(Wcurl_easy_getinfo_err_long, + "curl_easy_getinfo expects a pointer to long") +CURLWARNING(Wcurl_easy_getinfo_err_double, + "curl_easy_getinfo expects a pointer to double") +CURLWARNING(Wcurl_easy_getinfo_err_curl_slist, + "curl_easy_getinfo expects a pointer to 'struct curl_slist *'") +CURLWARNING(Wcurl_easy_getinfo_err_curl_tlssessioninfo, + "curl_easy_getinfo expects a pointer to " + "'struct curl_tlssessioninfo *'") +CURLWARNING(Wcurl_easy_getinfo_err_curl_certinfo, + "curl_easy_getinfo expects a pointer to " + "'struct curl_certinfo *'") +CURLWARNING(Wcurl_easy_getinfo_err_curl_socket, + "curl_easy_getinfo expects a pointer to curl_socket_t") +CURLWARNING(Wcurl_easy_getinfo_err_curl_off_t, + "curl_easy_getinfo expects a pointer to curl_off_t") + +/* groups of curl_easy_setops options that take the same type of argument */ + +/* evaluates to true if option takes a long argument */ +#define curlcheck_long_option(option) \ + (0 < (option) && (option) < CURLOPTTYPE_OBJECTPOINT) + +#define curlcheck_off_t_option(option) \ + (((option) > CURLOPTTYPE_OFF_T) && ((option) < CURLOPTTYPE_BLOB)) + +/* option takes a CURL * argument */ +#define curlcheck_curl_option(option) \ + ((option) == CURLOPT_STREAM_DEPENDS || \ + (option) == CURLOPT_STREAM_DEPENDS_E || \ + 0) + +/* evaluates to true if option takes a char* argument */ +#define curlcheck_string_option(option) \ + ((option) == CURLOPT_ABSTRACT_UNIX_SOCKET || \ + (option) == CURLOPT_ACCEPT_ENCODING || \ + (option) == CURLOPT_ALTSVC || \ + (option) == CURLOPT_CAINFO || \ + (option) == CURLOPT_CAPATH || \ + (option) == CURLOPT_COOKIE || \ + (option) == CURLOPT_COOKIEFILE || \ + (option) == CURLOPT_COOKIEJAR || \ + (option) == CURLOPT_COOKIELIST || \ + (option) == CURLOPT_CRLFILE || \ + (option) == CURLOPT_CUSTOMREQUEST || \ + (option) == CURLOPT_DEFAULT_PROTOCOL || \ + (option) == CURLOPT_DNS_INTERFACE || \ + (option) == CURLOPT_DNS_LOCAL_IP4 || \ + (option) == CURLOPT_DNS_LOCAL_IP6 || \ + (option) == CURLOPT_DNS_SERVERS || \ + (option) == CURLOPT_DOH_URL || \ + (option) == CURLOPT_ECH || \ + (option) == CURLOPT_EGDSOCKET || \ + (option) == CURLOPT_FTP_ACCOUNT || \ + (option) == CURLOPT_FTP_ALTERNATIVE_TO_USER || \ + (option) == CURLOPT_FTPPORT || \ + (option) == CURLOPT_HAPROXY_CLIENT_IP || \ + (option) == CURLOPT_HSTS || \ + (option) == CURLOPT_INTERFACE || \ + (option) == CURLOPT_ISSUERCERT || \ + (option) == CURLOPT_KEYPASSWD || \ + (option) == CURLOPT_KRBLEVEL || \ + (option) == CURLOPT_LOGIN_OPTIONS || \ + (option) == CURLOPT_MAIL_AUTH || \ + (option) == CURLOPT_MAIL_FROM || \ + (option) == CURLOPT_NETRC_FILE || \ + (option) == CURLOPT_NOPROXY || \ + (option) == CURLOPT_PASSWORD || \ + (option) == CURLOPT_PINNEDPUBLICKEY || \ + (option) == CURLOPT_PRE_PROXY || \ + (option) == CURLOPT_PROTOCOLS_STR || \ + (option) == CURLOPT_PROXY || \ + (option) == CURLOPT_PROXY_CAINFO || \ + (option) == CURLOPT_PROXY_CAPATH || \ + (option) == CURLOPT_PROXY_CRLFILE || \ + (option) == CURLOPT_PROXY_ISSUERCERT || \ + (option) == CURLOPT_PROXY_KEYPASSWD || \ + (option) == CURLOPT_PROXY_PINNEDPUBLICKEY || \ + (option) == CURLOPT_PROXY_SERVICE_NAME || \ + (option) == CURLOPT_PROXY_SSL_CIPHER_LIST || \ + (option) == CURLOPT_PROXY_SSLCERT || \ + (option) == CURLOPT_PROXY_SSLCERTTYPE || \ + (option) == CURLOPT_PROXY_SSLKEY || \ + (option) == CURLOPT_PROXY_SSLKEYTYPE || \ + (option) == CURLOPT_PROXY_TLS13_CIPHERS || \ + (option) == CURLOPT_PROXY_TLSAUTH_PASSWORD || \ + (option) == CURLOPT_PROXY_TLSAUTH_TYPE || \ + (option) == CURLOPT_PROXY_TLSAUTH_USERNAME || \ + (option) == CURLOPT_PROXYPASSWORD || \ + (option) == CURLOPT_PROXYUSERNAME || \ + (option) == CURLOPT_PROXYUSERPWD || \ + (option) == CURLOPT_RANDOM_FILE || \ + (option) == CURLOPT_RANGE || \ + (option) == CURLOPT_REDIR_PROTOCOLS_STR || \ + (option) == CURLOPT_REFERER || \ + (option) == CURLOPT_REQUEST_TARGET || \ + (option) == CURLOPT_RTSP_SESSION_ID || \ + (option) == CURLOPT_RTSP_STREAM_URI || \ + (option) == CURLOPT_RTSP_TRANSPORT || \ + (option) == CURLOPT_SASL_AUTHZID || \ + (option) == CURLOPT_SERVICE_NAME || \ + (option) == CURLOPT_SOCKS5_GSSAPI_SERVICE || \ + (option) == CURLOPT_SSH_HOST_PUBLIC_KEY_MD5 || \ + (option) == CURLOPT_SSH_HOST_PUBLIC_KEY_SHA256 || \ + (option) == CURLOPT_SSH_KNOWNHOSTS || \ + (option) == CURLOPT_SSH_PRIVATE_KEYFILE || \ + (option) == CURLOPT_SSH_PUBLIC_KEYFILE || \ + (option) == CURLOPT_SSLCERT || \ + (option) == CURLOPT_SSLCERTTYPE || \ + (option) == CURLOPT_SSLENGINE || \ + (option) == CURLOPT_SSLKEY || \ + (option) == CURLOPT_SSLKEYTYPE || \ + (option) == CURLOPT_SSL_CIPHER_LIST || \ + (option) == CURLOPT_SSL_EC_CURVES || \ + (option) == CURLOPT_SSL_SIGNATURE_ALGORITHMS || \ + (option) == CURLOPT_TLS13_CIPHERS || \ + (option) == CURLOPT_TLSAUTH_PASSWORD || \ + (option) == CURLOPT_TLSAUTH_TYPE || \ + (option) == CURLOPT_TLSAUTH_USERNAME || \ + (option) == CURLOPT_UNIX_SOCKET_PATH || \ + (option) == CURLOPT_URL || \ + (option) == CURLOPT_USERAGENT || \ + (option) == CURLOPT_USERNAME || \ + (option) == CURLOPT_AWS_SIGV4 || \ + (option) == CURLOPT_USERPWD || \ + (option) == CURLOPT_XOAUTH2_BEARER || \ + 0) + +/* evaluates to true if option takes a curl_write_callback argument */ +#define curlcheck_write_cb_option(option) \ + ((option) == CURLOPT_HEADERFUNCTION || \ + (option) == CURLOPT_WRITEFUNCTION) + +/* evaluates to true if option takes a curl_conv_callback argument */ +#define curlcheck_conv_cb_option(option) \ + ((option) == CURLOPT_CONV_TO_NETWORK_FUNCTION || \ + (option) == CURLOPT_CONV_FROM_NETWORK_FUNCTION || \ + (option) == CURLOPT_CONV_FROM_UTF8_FUNCTION) + +/* evaluates to true if option takes a data argument to pass to a callback */ +#define curlcheck_cb_data_option(option) \ + ((option) == CURLOPT_CHUNK_DATA || \ + (option) == CURLOPT_CLOSESOCKETDATA || \ + (option) == CURLOPT_DEBUGDATA || \ + (option) == CURLOPT_FNMATCH_DATA || \ + (option) == CURLOPT_HEADERDATA || \ + (option) == CURLOPT_HSTSREADDATA || \ + (option) == CURLOPT_HSTSWRITEDATA || \ + (option) == CURLOPT_INTERLEAVEDATA || \ + (option) == CURLOPT_IOCTLDATA || \ + (option) == CURLOPT_OPENSOCKETDATA || \ + (option) == CURLOPT_PREREQDATA || \ + (option) == CURLOPT_XFERINFODATA || \ + (option) == CURLOPT_READDATA || \ + (option) == CURLOPT_SEEKDATA || \ + (option) == CURLOPT_SOCKOPTDATA || \ + (option) == CURLOPT_SSH_KEYDATA || \ + (option) == CURLOPT_SSL_CTX_DATA || \ + (option) == CURLOPT_WRITEDATA || \ + (option) == CURLOPT_RESOLVER_START_DATA || \ + (option) == CURLOPT_TRAILERDATA || \ + (option) == CURLOPT_SSH_HOSTKEYDATA || \ + 0) + +/* evaluates to true if option takes a POST data argument (void* or char*) */ +#define curlcheck_postfields_option(option) \ + ((option) == CURLOPT_POSTFIELDS || \ + (option) == CURLOPT_COPYPOSTFIELDS || \ + 0) + +/* evaluates to true if option takes a struct curl_slist * argument */ +#define curlcheck_slist_option(option) \ + ((option) == CURLOPT_HTTP200ALIASES || \ + (option) == CURLOPT_HTTPHEADER || \ + (option) == CURLOPT_MAIL_RCPT || \ + (option) == CURLOPT_POSTQUOTE || \ + (option) == CURLOPT_PREQUOTE || \ + (option) == CURLOPT_PROXYHEADER || \ + (option) == CURLOPT_QUOTE || \ + (option) == CURLOPT_RESOLVE || \ + (option) == CURLOPT_TELNETOPTIONS || \ + (option) == CURLOPT_CONNECT_TO || \ + 0) + +/* groups of curl_easy_getinfo infos that take the same type of argument */ + +/* evaluates to true if info expects a pointer to char * argument */ +#define curlcheck_string_info(info) \ + (CURLINFO_STRING < (info) && (info) < CURLINFO_LONG && \ + (info) != CURLINFO_PRIVATE) + +/* evaluates to true if info expects a pointer to long argument */ +#define curlcheck_long_info(info) \ + (CURLINFO_LONG < (info) && (info) < CURLINFO_DOUBLE) + +/* evaluates to true if info expects a pointer to double argument */ +#define curlcheck_double_info(info) \ + (CURLINFO_DOUBLE < (info) && (info) < CURLINFO_SLIST) + +/* true if info expects a pointer to struct curl_slist * argument */ +#define curlcheck_slist_info(info) \ + (((info) == CURLINFO_SSL_ENGINES) || \ + ((info) == CURLINFO_COOKIELIST)) + +/* true if info expects a pointer to struct curl_tlssessioninfo * argument */ +#define curlcheck_tlssessioninfo_info(info) \ + (((info) == CURLINFO_TLS_SSL_PTR) || \ + ((info) == CURLINFO_TLS_SESSION)) + +/* true if info expects a pointer to struct curl_certinfo * argument */ +#define curlcheck_certinfo_info(info) ((info) == CURLINFO_CERTINFO) + +/* true if info expects a pointer to struct curl_socket_t argument */ +#define curlcheck_socket_info(info) \ + (CURLINFO_SOCKET < (info) && (info) < CURLINFO_OFF_T) + +/* true if info expects a pointer to curl_off_t argument */ +#define curlcheck_off_t_info(info) \ + (CURLINFO_OFF_T < (info)) + +/* + * typecheck helpers -- check whether given expression has requested type + */ + +/* For pointers, you can use the curlcheck_ptr/curlcheck_arr macros, + * otherwise define a new macro. Search for __builtin_types_compatible_p + * in the GCC manual. + * NOTE: these macros MUST NOT EVALUATE their arguments! The argument is + * the actual expression passed to the curl_easy_setopt macro. This + * means that you can only apply the sizeof and __typeof__ operators, no + * == or whatsoever. + */ + +/* XXX: should evaluate to true if expr is a pointer */ +#define curlcheck_any_ptr(expr) \ + (sizeof(expr) == sizeof(void *)) + +/* evaluates to true if expr is NULL */ +/* XXX: must not evaluate expr, so this check is not accurate */ +#define curlcheck_NULL(expr) \ + (__builtin_types_compatible_p(__typeof__(expr), __typeof__(NULL))) + +/* evaluates to true if expr is type*, const type* or NULL */ +#define curlcheck_ptr(expr, type) \ + (curlcheck_NULL(expr) || \ + __builtin_types_compatible_p(__typeof__(expr), type *) || \ + __builtin_types_compatible_p(__typeof__(expr), const type *)) + +/* evaluates to true if expr is type**, const type** or NULL */ +#define curlcheck_ptrptr(expr, type) \ + (curlcheck_NULL(expr) || \ + __builtin_types_compatible_p(__typeof__(expr), type **) || \ + __builtin_types_compatible_p(__typeof__(expr), type *[]) || \ + __builtin_types_compatible_p(__typeof__(expr), const type *[]) || \ + __builtin_types_compatible_p(__typeof__(expr), const type **)) + +/* evaluates to true if expr is one of type[], type*, NULL or const type* */ +#define curlcheck_arr(expr, type) \ + (curlcheck_ptr((expr), type) || \ + __builtin_types_compatible_p(__typeof__(expr), type [])) + +/* evaluates to true if expr is a string */ +#define curlcheck_string(expr) \ + (curlcheck_arr((expr), char) || \ + curlcheck_arr((expr), signed char) || \ + curlcheck_arr((expr), unsigned char)) + +/* evaluates to true if expr is a CURL * */ +#define curlcheck_curl(expr) \ + (curlcheck_NULL(expr) || \ + __builtin_types_compatible_p(__typeof__(expr), CURL *)) + +/* evaluates to true if expr is a long (no matter the signedness) + * XXX: for now, int is also accepted (and therefore short and char, which + * are promoted to int when passed to a variadic function) */ +#define curlcheck_long(expr) \ + ( \ + ((sizeof(long) != sizeof(int)) && \ + (__builtin_types_compatible_p(__typeof__(expr), long) || \ + __builtin_types_compatible_p(__typeof__(expr), signed long) || \ + __builtin_types_compatible_p(__typeof__(expr), unsigned long))) \ + || \ + ((sizeof(long) == sizeof(int)) && \ + (__builtin_types_compatible_p(__typeof__(expr), long) || \ + __builtin_types_compatible_p(__typeof__(expr), signed long) || \ + __builtin_types_compatible_p(__typeof__(expr), unsigned long) || \ + __builtin_types_compatible_p(__typeof__(expr), int) || \ + __builtin_types_compatible_p(__typeof__(expr), signed int) || \ + __builtin_types_compatible_p(__typeof__(expr), unsigned int) || \ + __builtin_types_compatible_p(__typeof__(expr), short) || \ + __builtin_types_compatible_p(__typeof__(expr), signed short) || \ + __builtin_types_compatible_p(__typeof__(expr), unsigned short) || \ + __builtin_types_compatible_p(__typeof__(expr), char) || \ + __builtin_types_compatible_p(__typeof__(expr), signed char) || \ + __builtin_types_compatible_p(__typeof__(expr), unsigned char))) \ + ) + +/* evaluates to true if expr is of type curl_off_t */ +#define curlcheck_off_t(expr) \ + (__builtin_types_compatible_p(__typeof__(expr), curl_off_t)) + +/* evaluates to true if expr is abuffer suitable for CURLOPT_ERRORBUFFER */ +/* XXX: also check size of an char[] array? */ +#define curlcheck_error_buffer(expr) \ + (curlcheck_NULL(expr) || \ + __builtin_types_compatible_p(__typeof__(expr), char *) || \ + __builtin_types_compatible_p(__typeof__(expr), char[])) + +/* evaluates to true if expr is of type (const) void* or (const) FILE* */ +#if 0 +#define curlcheck_cb_data(expr) \ + (curlcheck_ptr((expr), void) || \ + curlcheck_ptr((expr), FILE)) +#else /* be less strict */ +#define curlcheck_cb_data(expr) \ + curlcheck_any_ptr(expr) +#endif + +/* evaluates to true if expr is of type FILE* */ +#define curlcheck_FILE(expr) \ + (curlcheck_NULL(expr) || \ + (__builtin_types_compatible_p(__typeof__(expr), FILE *))) + +/* evaluates to true if expr can be passed as POST data (void* or char*) */ +#define curlcheck_postfields(expr) \ + (curlcheck_ptr((expr), void) || \ + curlcheck_arr((expr), char) || \ + curlcheck_arr((expr), unsigned char)) + +/* helper: __builtin_types_compatible_p distinguishes between functions and + * function pointers, hide it */ +#define curlcheck_cb_compatible(func, type) \ + (__builtin_types_compatible_p(__typeof__(func), type) || \ + __builtin_types_compatible_p(__typeof__(func) *, type)) + +/* evaluates to true if expr is of type curl_resolver_start_callback */ +#define curlcheck_resolver_start_callback(expr) \ + (curlcheck_NULL(expr) || \ + curlcheck_cb_compatible((expr), curl_resolver_start_callback)) + +/* evaluates to true if expr is of type curl_read_callback or "similar" */ +#define curlcheck_read_cb(expr) \ + (curlcheck_NULL(expr) || \ + curlcheck_cb_compatible((expr), __typeof__(fread) *) || \ + curlcheck_cb_compatible((expr), curl_read_callback) || \ + curlcheck_cb_compatible((expr), Wcurl_read_callback1) || \ + curlcheck_cb_compatible((expr), Wcurl_read_callback2) || \ + curlcheck_cb_compatible((expr), Wcurl_read_callback3) || \ + curlcheck_cb_compatible((expr), Wcurl_read_callback4) || \ + curlcheck_cb_compatible((expr), Wcurl_read_callback5) || \ + curlcheck_cb_compatible((expr), Wcurl_read_callback6)) +typedef size_t (*Wcurl_read_callback1)(char *, size_t, size_t, void *); +typedef size_t (*Wcurl_read_callback2)(char *, size_t, size_t, const void *); +typedef size_t (*Wcurl_read_callback3)(char *, size_t, size_t, FILE *); +typedef size_t (*Wcurl_read_callback4)(void *, size_t, size_t, void *); +typedef size_t (*Wcurl_read_callback5)(void *, size_t, size_t, const void *); +typedef size_t (*Wcurl_read_callback6)(void *, size_t, size_t, FILE *); + +/* evaluates to true if expr is of type curl_write_callback or "similar" */ +#define curlcheck_write_cb(expr) \ + (curlcheck_read_cb(expr) || \ + curlcheck_cb_compatible((expr), __typeof__(fwrite) *) || \ + curlcheck_cb_compatible((expr), curl_write_callback) || \ + curlcheck_cb_compatible((expr), Wcurl_write_callback1) || \ + curlcheck_cb_compatible((expr), Wcurl_write_callback2) || \ + curlcheck_cb_compatible((expr), Wcurl_write_callback3) || \ + curlcheck_cb_compatible((expr), Wcurl_write_callback4) || \ + curlcheck_cb_compatible((expr), Wcurl_write_callback5) || \ + curlcheck_cb_compatible((expr), Wcurl_write_callback6)) +typedef size_t (*Wcurl_write_callback1)(const char *, size_t, size_t, void *); +typedef size_t (*Wcurl_write_callback2)(const char *, size_t, size_t, + const void *); +typedef size_t (*Wcurl_write_callback3)(const char *, size_t, size_t, FILE *); +typedef size_t (*Wcurl_write_callback4)(const void *, size_t, size_t, void *); +typedef size_t (*Wcurl_write_callback5)(const void *, size_t, size_t, + const void *); +typedef size_t (*Wcurl_write_callback6)(const void *, size_t, size_t, FILE *); + +/* evaluates to true if expr is of type curl_ioctl_callback or "similar" */ +#define curlcheck_ioctl_cb(expr) \ + (curlcheck_NULL(expr) || \ + curlcheck_cb_compatible((expr), curl_ioctl_callback) || \ + curlcheck_cb_compatible((expr), Wcurl_ioctl_callback1) || \ + curlcheck_cb_compatible((expr), Wcurl_ioctl_callback2) || \ + curlcheck_cb_compatible((expr), Wcurl_ioctl_callback3) || \ + curlcheck_cb_compatible((expr), Wcurl_ioctl_callback4)) +typedef curlioerr (*Wcurl_ioctl_callback1)(CURL *, int, void *); +typedef curlioerr (*Wcurl_ioctl_callback2)(CURL *, int, const void *); +typedef curlioerr (*Wcurl_ioctl_callback3)(CURL *, curliocmd, void *); +typedef curlioerr (*Wcurl_ioctl_callback4)(CURL *, curliocmd, const void *); + +/* evaluates to true if expr is of type curl_sockopt_callback or "similar" */ +#define curlcheck_sockopt_cb(expr) \ + (curlcheck_NULL(expr) || \ + curlcheck_cb_compatible((expr), curl_sockopt_callback) || \ + curlcheck_cb_compatible((expr), Wcurl_sockopt_callback1) || \ + curlcheck_cb_compatible((expr), Wcurl_sockopt_callback2)) +typedef int (*Wcurl_sockopt_callback1)(void *, curl_socket_t, curlsocktype); +typedef int (*Wcurl_sockopt_callback2)(const void *, curl_socket_t, + curlsocktype); + +/* evaluates to true if expr is of type curl_opensocket_callback or + "similar" */ +#define curlcheck_opensocket_cb(expr) \ + (curlcheck_NULL(expr) || \ + curlcheck_cb_compatible((expr), curl_opensocket_callback) || \ + curlcheck_cb_compatible((expr), Wcurl_opensocket_callback1) || \ + curlcheck_cb_compatible((expr), Wcurl_opensocket_callback2) || \ + curlcheck_cb_compatible((expr), Wcurl_opensocket_callback3) || \ + curlcheck_cb_compatible((expr), Wcurl_opensocket_callback4)) +typedef curl_socket_t (*Wcurl_opensocket_callback1) + (void *, curlsocktype, struct curl_sockaddr *); +typedef curl_socket_t (*Wcurl_opensocket_callback2) + (void *, curlsocktype, const struct curl_sockaddr *); +typedef curl_socket_t (*Wcurl_opensocket_callback3) + (const void *, curlsocktype, struct curl_sockaddr *); +typedef curl_socket_t (*Wcurl_opensocket_callback4) + (const void *, curlsocktype, const struct curl_sockaddr *); + +/* evaluates to true if expr is of type curl_progress_callback or "similar" */ +#define curlcheck_progress_cb(expr) \ + (curlcheck_NULL(expr) || \ + curlcheck_cb_compatible((expr), curl_progress_callback) || \ + curlcheck_cb_compatible((expr), Wcurl_progress_callback1) || \ + curlcheck_cb_compatible((expr), Wcurl_progress_callback2)) +typedef int (*Wcurl_progress_callback1)(void *, + double, double, double, double); +typedef int (*Wcurl_progress_callback2)(const void *, + double, double, double, double); + +/* evaluates to true if expr is of type curl_xferinfo_callback */ +#define curlcheck_xferinfo_cb(expr) \ + (curlcheck_NULL(expr) || \ + curlcheck_cb_compatible((expr), curl_xferinfo_callback)) + +/* evaluates to true if expr is of type curl_debug_callback or "similar" */ +#define curlcheck_debug_cb(expr) \ + (curlcheck_NULL(expr) || \ + curlcheck_cb_compatible((expr), curl_debug_callback) || \ + curlcheck_cb_compatible((expr), Wcurl_debug_callback1) || \ + curlcheck_cb_compatible((expr), Wcurl_debug_callback2) || \ + curlcheck_cb_compatible((expr), Wcurl_debug_callback3) || \ + curlcheck_cb_compatible((expr), Wcurl_debug_callback4) || \ + curlcheck_cb_compatible((expr), Wcurl_debug_callback5) || \ + curlcheck_cb_compatible((expr), Wcurl_debug_callback6) || \ + curlcheck_cb_compatible((expr), Wcurl_debug_callback7) || \ + curlcheck_cb_compatible((expr), Wcurl_debug_callback8)) +typedef int (*Wcurl_debug_callback1)(CURL *, + curl_infotype, char *, size_t, void *); +typedef int (*Wcurl_debug_callback2)(CURL *, + curl_infotype, char *, size_t, const void *); +typedef int (*Wcurl_debug_callback3)(CURL *, + curl_infotype, const char *, size_t, void *); +typedef int (*Wcurl_debug_callback4)(CURL *, + curl_infotype, const char *, size_t, const void *); +typedef int (*Wcurl_debug_callback5)(CURL *, + curl_infotype, unsigned char *, size_t, void *); +typedef int (*Wcurl_debug_callback6)(CURL *, + curl_infotype, unsigned char *, size_t, const void *); +typedef int (*Wcurl_debug_callback7)(CURL *, + curl_infotype, const unsigned char *, size_t, void *); +typedef int (*Wcurl_debug_callback8)(CURL *, + curl_infotype, const unsigned char *, size_t, const void *); + +/* evaluates to true if expr is of type curl_ssl_ctx_callback or "similar" */ +/* this is getting even messier... */ +#define curlcheck_ssl_ctx_cb(expr) \ + (curlcheck_NULL(expr) || \ + curlcheck_cb_compatible((expr), curl_ssl_ctx_callback) || \ + curlcheck_cb_compatible((expr), Wcurl_ssl_ctx_callback1) || \ + curlcheck_cb_compatible((expr), Wcurl_ssl_ctx_callback2) || \ + curlcheck_cb_compatible((expr), Wcurl_ssl_ctx_callback3) || \ + curlcheck_cb_compatible((expr), Wcurl_ssl_ctx_callback4) || \ + curlcheck_cb_compatible((expr), Wcurl_ssl_ctx_callback5) || \ + curlcheck_cb_compatible((expr), Wcurl_ssl_ctx_callback6) || \ + curlcheck_cb_compatible((expr), Wcurl_ssl_ctx_callback7) || \ + curlcheck_cb_compatible((expr), Wcurl_ssl_ctx_callback8)) +typedef CURLcode (*Wcurl_ssl_ctx_callback1)(CURL *, void *, void *); +typedef CURLcode (*Wcurl_ssl_ctx_callback2)(CURL *, void *, const void *); +typedef CURLcode (*Wcurl_ssl_ctx_callback3)(CURL *, const void *, void *); +typedef CURLcode (*Wcurl_ssl_ctx_callback4)(CURL *, const void *, + const void *); +#ifdef HEADER_SSL_H +/* hack: if we included OpenSSL's ssl.h, we know about SSL_CTX + * this of course breaks if we are included before OpenSSL headers... + */ +typedef CURLcode (*Wcurl_ssl_ctx_callback5)(CURL *, SSL_CTX *, void *); +typedef CURLcode (*Wcurl_ssl_ctx_callback6)(CURL *, SSL_CTX *, const void *); +typedef CURLcode (*Wcurl_ssl_ctx_callback7)(CURL *, const SSL_CTX *, void *); +typedef CURLcode (*Wcurl_ssl_ctx_callback8)(CURL *, const SSL_CTX *, + const void *); +#else +typedef Wcurl_ssl_ctx_callback1 Wcurl_ssl_ctx_callback5; +typedef Wcurl_ssl_ctx_callback1 Wcurl_ssl_ctx_callback6; +typedef Wcurl_ssl_ctx_callback1 Wcurl_ssl_ctx_callback7; +typedef Wcurl_ssl_ctx_callback1 Wcurl_ssl_ctx_callback8; +#endif + +/* evaluates to true if expr is of type curl_conv_callback or "similar" */ +#define curlcheck_conv_cb(expr) \ + (curlcheck_NULL(expr) || \ + curlcheck_cb_compatible((expr), curl_conv_callback) || \ + curlcheck_cb_compatible((expr), Wcurl_conv_callback1) || \ + curlcheck_cb_compatible((expr), Wcurl_conv_callback2) || \ + curlcheck_cb_compatible((expr), Wcurl_conv_callback3) || \ + curlcheck_cb_compatible((expr), Wcurl_conv_callback4)) +typedef CURLcode (*Wcurl_conv_callback1)(char *, size_t length); +typedef CURLcode (*Wcurl_conv_callback2)(const char *, size_t length); +typedef CURLcode (*Wcurl_conv_callback3)(void *, size_t length); +typedef CURLcode (*Wcurl_conv_callback4)(const void *, size_t length); + +/* evaluates to true if expr is of type curl_seek_callback or "similar" */ +#define curlcheck_seek_cb(expr) \ + (curlcheck_NULL(expr) || \ + curlcheck_cb_compatible((expr), curl_seek_callback) || \ + curlcheck_cb_compatible((expr), Wcurl_seek_callback1) || \ + curlcheck_cb_compatible((expr), Wcurl_seek_callback2)) +typedef CURLcode (*Wcurl_seek_callback1)(void *, curl_off_t, int); +typedef CURLcode (*Wcurl_seek_callback2)(const void *, curl_off_t, int); + +/* evaluates to true if expr is of type curl_chunk_bgn_callback */ +#define curlcheck_chunk_bgn_cb(expr) \ + (curlcheck_NULL(expr) || \ + curlcheck_cb_compatible((expr), curl_chunk_bgn_callback) || \ + curlcheck_cb_compatible((expr), Wcurl_chunk_bgn_callback1) || \ + curlcheck_cb_compatible((expr), Wcurl_chunk_bgn_callback2)) +typedef long (*Wcurl_chunk_bgn_callback1)(struct curl_fileinfo *, + void *, int); +typedef long (*Wcurl_chunk_bgn_callback2)(void *, void *, int); + +/* evaluates to true if expr is of type curl_chunk_end_callback */ +#define curlcheck_chunk_end_cb(expr) \ + (curlcheck_NULL(expr) || \ + curlcheck_cb_compatible((expr), curl_chunk_end_callback)) + +/* evaluates to true if expr is of type curl_closesocket_callback */ +#define curlcheck_close_socket_cb(expr) \ + (curlcheck_NULL(expr) || \ + curlcheck_cb_compatible((expr), curl_closesocket_callback)) + +/* evaluates to true if expr is of type curl_fnmatch_callback */ +#define curlcheck_fnmatch_cb(expr) \ + (curlcheck_NULL(expr) || \ + curlcheck_cb_compatible((expr), curl_fnmatch_callback)) + +/* evaluates to true if expr is of type curl_hstsread_callback */ +#define curlcheck_hstsread_cb(expr) \ + (curlcheck_NULL(expr) || \ + curlcheck_cb_compatible((expr), curl_hstsread_callback)) + +/* evaluates to true if expr is of type curl_hstswrite_callback */ +#define curlcheck_hstswrite_cb(expr) \ + (curlcheck_NULL(expr) || \ + curlcheck_cb_compatible((expr), curl_hstswrite_callback)) + +/* evaluates to true if expr is of type curl_sshhostkeycallback */ +#define curlcheck_ssh_hostkey_cb(expr) \ + (curlcheck_NULL(expr) || \ + curlcheck_cb_compatible((expr), curl_sshhostkeycallback)) + +/* evaluates to true if expr is of type curl_sshkeycallback */ +#define curlcheck_ssh_key_cb(expr) \ + (curlcheck_NULL(expr) || \ + curlcheck_cb_compatible((expr), curl_sshkeycallback)) + +/* evaluates to true if expr is of type curl_interleave_callback */ +#define curlcheck_interleave_cb(expr) \ + (curlcheck_NULL(expr) || \ + curlcheck_cb_compatible((expr), Wcurl_interleave_callback1) || \ + curlcheck_cb_compatible((expr), Wcurl_interleave_callback2)) +typedef size_t (*Wcurl_interleave_callback1)(void *p, size_t s, + size_t n, void *u); +typedef size_t (*Wcurl_interleave_callback2)(char *p, size_t s, + size_t n, void *u); + +/* evaluates to true if expr is of type curl_prereq_callback */ +#define curlcheck_prereq_cb(expr) \ + (curlcheck_NULL(expr) || \ + curlcheck_cb_compatible((expr), curl_prereq_callback)) + +/* evaluates to true if expr is of type curl_trailer_callback */ +#define curlcheck_trailer_cb(expr) \ + (curlcheck_NULL(expr) || \ + curlcheck_cb_compatible((expr), curl_trailer_callback)) + +#endif /* CURLINC_TYPECHECK_GCC_H */ diff --git a/3rdparty/curl-8.21.0/include/curl/urlapi.h b/3rdparty/curl-8.21.0/include/curl/urlapi.h new file mode 100644 index 0000000000..b1f3a2316b --- /dev/null +++ b/3rdparty/curl-8.21.0/include/curl/urlapi.h @@ -0,0 +1,155 @@ +#ifndef CURLINC_URLAPI_H +#define CURLINC_URLAPI_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +#include "curl.h" + +#ifdef __cplusplus +extern "C" { +#endif + +/* the error codes for the URL API */ +typedef enum { + CURLUE_OK, + CURLUE_BAD_HANDLE, /* 1 */ + CURLUE_BAD_PARTPOINTER, /* 2 */ + CURLUE_MALFORMED_INPUT, /* 3 */ + CURLUE_BAD_PORT_NUMBER, /* 4 */ + CURLUE_UNSUPPORTED_SCHEME, /* 5 */ + CURLUE_URLDECODE, /* 6 */ + CURLUE_OUT_OF_MEMORY, /* 7 */ + CURLUE_USER_NOT_ALLOWED, /* 8 */ + CURLUE_UNKNOWN_PART, /* 9 */ + CURLUE_NO_SCHEME, /* 10 */ + CURLUE_NO_USER, /* 11 */ + CURLUE_NO_PASSWORD, /* 12 */ + CURLUE_NO_OPTIONS, /* 13 */ + CURLUE_NO_HOST, /* 14 */ + CURLUE_NO_PORT, /* 15 */ + CURLUE_NO_QUERY, /* 16 */ + CURLUE_NO_FRAGMENT, /* 17 */ + CURLUE_NO_ZONEID, /* 18 */ + CURLUE_BAD_FILE_URL, /* 19 */ + CURLUE_BAD_FRAGMENT, /* 20 */ + CURLUE_BAD_HOSTNAME, /* 21 */ + CURLUE_BAD_IPV6, /* 22 */ + CURLUE_BAD_LOGIN, /* 23 */ + CURLUE_BAD_PASSWORD, /* 24 */ + CURLUE_BAD_PATH, /* 25 */ + CURLUE_BAD_QUERY, /* 26 */ + CURLUE_BAD_SCHEME, /* 27 */ + CURLUE_BAD_SLASHES, /* 28 */ + CURLUE_BAD_USER, /* 29 */ + CURLUE_LACKS_IDN, /* 30 */ + CURLUE_TOO_LARGE, /* 31 */ + CURLUE_LAST +} CURLUcode; + +typedef enum { + CURLUPART_URL, + CURLUPART_SCHEME, + CURLUPART_USER, + CURLUPART_PASSWORD, + CURLUPART_OPTIONS, + CURLUPART_HOST, + CURLUPART_PORT, + CURLUPART_PATH, + CURLUPART_QUERY, + CURLUPART_FRAGMENT, + CURLUPART_ZONEID /* added in 7.65.0 */ +} CURLUPart; + +#define CURLU_DEFAULT_PORT (1 << 0) /* return default port number */ +#define CURLU_NO_DEFAULT_PORT (1 << 1) /* act as if no port number was set, + if the port number matches the + default for the scheme */ +#define CURLU_DEFAULT_SCHEME (1 << 2) /* return default scheme if + missing */ +#define CURLU_NON_SUPPORT_SCHEME (1 << 3) /* allow non-supported scheme */ +#define CURLU_PATH_AS_IS (1 << 4) /* leave dot sequences */ +#define CURLU_DISALLOW_USER (1 << 5) /* no user+password allowed */ +#define CURLU_URLDECODE (1 << 6) /* URL decode on get */ +#define CURLU_URLENCODE (1 << 7) /* URL encode on set */ +#define CURLU_APPENDQUERY (1 << 8) /* append a form style part */ +#define CURLU_GUESS_SCHEME (1 << 9) /* legacy curl-style guessing */ +#define CURLU_NO_AUTHORITY (1 << 10) /* Allow empty authority when the + scheme is unknown. */ +#define CURLU_ALLOW_SPACE (1 << 11) /* Allow spaces in the URL */ +#define CURLU_PUNYCODE (1 << 12) /* get the hostname in punycode */ +#define CURLU_PUNY2IDN (1 << 13) /* punycode => IDN conversion */ +#define CURLU_GET_EMPTY (1 << 14) /* allow empty queries and fragments + when extracting the URL or the + components */ +#define CURLU_NO_GUESS_SCHEME (1 << 15) /* for get, do not accept a guess */ + +typedef struct Curl_URL CURLU; + +/* + * curl_url() creates a new CURLU handle and returns a pointer to it. + * Must be freed with curl_url_cleanup(). + */ +CURL_EXTERN CURLU *curl_url(void); + +/* + * curl_url_cleanup() frees the CURLU handle and related resources used for + * the URL parsing. It does not free strings previously returned with the URL + * API. + */ +CURL_EXTERN void curl_url_cleanup(CURLU *u); + +/* + * curl_url_dup() duplicates a CURLU handle and returns a new copy. The new + * handle must also be freed with curl_url_cleanup(). + */ +CURL_EXTERN CURLU *curl_url_dup(const CURLU *in); + +/* + * curl_url_get() extracts a specific part of the URL from a CURLU + * handle. Returns error code. The returned pointer MUST be freed with + * curl_free() afterwards. + */ +CURL_EXTERN CURLUcode curl_url_get(const CURLU *u, CURLUPart what, + char **part, unsigned int flags); + +/* + * curl_url_set() sets a specific part of the URL in a CURLU handle. Returns + * error code. The passed in string is copied. Passing a NULL instead of + * a part string, clears that part. + */ +CURL_EXTERN CURLUcode curl_url_set(CURLU *u, CURLUPart what, + const char *part, unsigned int flags); + +/* + * curl_url_strerror() turns a CURLUcode value into the equivalent human + * readable error string. This is useful for printing meaningful error + * messages. + */ +CURL_EXTERN const char *curl_url_strerror(CURLUcode error); + +#ifdef __cplusplus +} /* end of extern "C" */ +#endif + +#endif /* CURLINC_URLAPI_H */ diff --git a/3rdparty/curl-8.21.0/include/curl/websockets.h b/3rdparty/curl-8.21.0/include/curl/websockets.h new file mode 100644 index 0000000000..bf93715abf --- /dev/null +++ b/3rdparty/curl-8.21.0/include/curl/websockets.h @@ -0,0 +1,98 @@ +#ifndef CURLINC_WEBSOCKETS_H +#define CURLINC_WEBSOCKETS_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +#ifdef __cplusplus +extern "C" { +#endif + +struct curl_ws_frame { + int age; /* zero */ + int flags; /* See the CURLWS_* defines */ + curl_off_t offset; /* the offset of this data into the frame */ + curl_off_t bytesleft; /* number of pending bytes left of the payload */ + size_t len; /* size of the current data chunk */ +}; + +/* flag bits */ +#define CURLWS_TEXT (1 << 0) +#define CURLWS_BINARY (1 << 1) +#define CURLWS_CONT (1 << 2) +#define CURLWS_CLOSE (1 << 3) +#define CURLWS_PING (1 << 4) +#define CURLWS_OFFSET (1 << 5) + +/* + * NAME curl_ws_recv() + * + * DESCRIPTION + * + * Receives data from the websocket connection. Use after successful + * curl_easy_perform() with CURLOPT_CONNECT_ONLY option. + */ +CURL_EXTERN CURLcode curl_ws_recv(CURL *curl, void *buffer, size_t buflen, + size_t *recv, + const struct curl_ws_frame **metap); + +/* flags for curl_ws_send() */ +#define CURLWS_PONG (1 << 6) + +/* + * NAME curl_ws_send() + * + * DESCRIPTION + * + * Sends data over the websocket connection. Use after successful + * curl_easy_perform() with CURLOPT_CONNECT_ONLY option. + */ +CURL_EXTERN CURLcode curl_ws_send(CURL *curl, const void *buffer_arg, + size_t buflen, size_t *sent, + curl_off_t fragsize, + unsigned int flags); + +/* + * NAME curl_ws_start_frame() + * + * DESCRIPTION + * + * Buffers a websocket frame header with the given flags and length. + * Errors when a previous frame is not complete, e.g. not all its + * payload has been added. + */ +CURL_EXTERN CURLcode curl_ws_start_frame(CURL *curl, + unsigned int flags, + curl_off_t frame_len); + +/* bits for the CURLOPT_WS_OPTIONS bitmask: */ +#define CURLWS_RAW_MODE (1L << 0) +#define CURLWS_NOAUTOPONG (1L << 1) + +CURL_EXTERN const struct curl_ws_frame *curl_ws_meta(CURL *curl); + +#ifdef __cplusplus +} +#endif + +#endif /* CURLINC_WEBSOCKETS_H */ diff --git a/3rdparty/curl-8.21.0/install-sh b/3rdparty/curl-8.21.0/install-sh new file mode 100755 index 0000000000..ec298b5374 --- /dev/null +++ b/3rdparty/curl-8.21.0/install-sh @@ -0,0 +1,541 @@ +#!/bin/sh +# install - install a program, script, or datafile + +scriptversion=2020-11-14.01; # UTC + +# This originates from X11R5 (mit/util/scripts/install.sh), which was +# later released in X11R6 (xc/config/util/install.sh) with the +# following copyright and license. +# +# Copyright (C) 1994 X Consortium +# +# 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 +# X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN +# AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNEC- +# TION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +# +# Except as contained in this notice, the name of the X Consortium shall not +# be used in advertising or otherwise to promote the sale, use or other deal- +# ings in this Software without prior written authorization from the X Consor- +# tium. +# +# +# FSF changes to this file are in the public domain. +# +# Calling this script install-sh is preferred over install.sh, to prevent +# 'make' implicit rules from creating a file called install from it +# when there is no Makefile. +# +# This script is compatible with the BSD install script, but was written +# from scratch. + +tab=' ' +nl=' +' +IFS=" $tab$nl" + +# Set DOITPROG to "echo" to test this script. + +doit=${DOITPROG-} +doit_exec=${doit:-exec} + +# Put in absolute file names if you don't have them in your path; +# or use environment vars. + +chgrpprog=${CHGRPPROG-chgrp} +chmodprog=${CHMODPROG-chmod} +chownprog=${CHOWNPROG-chown} +cmpprog=${CMPPROG-cmp} +cpprog=${CPPROG-cp} +mkdirprog=${MKDIRPROG-mkdir} +mvprog=${MVPROG-mv} +rmprog=${RMPROG-rm} +stripprog=${STRIPPROG-strip} + +posix_mkdir= + +# Desired mode of installed file. +mode=0755 + +# Create dirs (including intermediate dirs) using mode 755. +# This is like GNU 'install' as of coreutils 8.32 (2020). +mkdir_umask=22 + +backupsuffix= +chgrpcmd= +chmodcmd=$chmodprog +chowncmd= +mvcmd=$mvprog +rmcmd="$rmprog -f" +stripcmd= + +src= +dst= +dir_arg= +dst_arg= + +copy_on_change=false +is_target_a_directory=possibly + +usage="\ +Usage: $0 [OPTION]... [-T] SRCFILE DSTFILE + or: $0 [OPTION]... SRCFILES... DIRECTORY + or: $0 [OPTION]... -t DIRECTORY SRCFILES... + or: $0 [OPTION]... -d DIRECTORIES... + +In the 1st form, copy SRCFILE to DSTFILE. +In the 2nd and 3rd, copy all SRCFILES to DIRECTORY. +In the 4th, create DIRECTORIES. + +Options: + --help display this help and exit. + --version display version info and exit. + + -c (ignored) + -C install only if different (preserve data modification time) + -d create directories instead of installing files. + -g GROUP $chgrpprog installed files to GROUP. + -m MODE $chmodprog installed files to MODE. + -o USER $chownprog installed files to USER. + -p pass -p to $cpprog. + -s $stripprog installed files. + -S SUFFIX attempt to back up existing files, with suffix SUFFIX. + -t DIRECTORY install into DIRECTORY. + -T report an error if DSTFILE is a directory. + +Environment variables override the default commands: + CHGRPPROG CHMODPROG CHOWNPROG CMPPROG CPPROG MKDIRPROG MVPROG + RMPROG STRIPPROG + +By default, rm is invoked with -f; when overridden with RMPROG, +it's up to you to specify -f if you want it. + +If -S is not specified, no backups are attempted. + +Email bug reports to bug-automake@gnu.org. +Automake home page: https://www.gnu.org/software/automake/ +" + +while test $# -ne 0; do + case $1 in + -c) ;; + + -C) copy_on_change=true;; + + -d) dir_arg=true;; + + -g) chgrpcmd="$chgrpprog $2" + shift;; + + --help) echo "$usage"; exit $?;; + + -m) mode=$2 + case $mode in + *' '* | *"$tab"* | *"$nl"* | *'*'* | *'?'* | *'['*) + echo "$0: invalid mode: $mode" >&2 + exit 1;; + esac + shift;; + + -o) chowncmd="$chownprog $2" + shift;; + + -p) cpprog="$cpprog -p";; + + -s) stripcmd=$stripprog;; + + -S) backupsuffix="$2" + shift;; + + -t) + is_target_a_directory=always + dst_arg=$2 + # Protect names problematic for 'test' and other utilities. + case $dst_arg in + -* | [=\(\)!]) dst_arg=./$dst_arg;; + esac + shift;; + + -T) is_target_a_directory=never;; + + --version) echo "$0 $scriptversion"; exit $?;; + + --) shift + break;; + + -*) echo "$0: invalid option: $1" >&2 + exit 1;; + + *) break;; + esac + shift +done + +# We allow the use of options -d and -T together, by making -d +# take the precedence; this is for compatibility with GNU install. + +if test -n "$dir_arg"; then + if test -n "$dst_arg"; then + echo "$0: target directory not allowed when installing a directory." >&2 + exit 1 + fi +fi + +if test $# -ne 0 && test -z "$dir_arg$dst_arg"; then + # When -d is used, all remaining arguments are directories to create. + # When -t is used, the destination is already specified. + # Otherwise, the last argument is the destination. Remove it from $@. + for arg + do + if test -n "$dst_arg"; then + # $@ is not empty: it contains at least $arg. + set fnord "$@" "$dst_arg" + shift # fnord + fi + shift # arg + dst_arg=$arg + # Protect names problematic for 'test' and other utilities. + case $dst_arg in + -* | [=\(\)!]) dst_arg=./$dst_arg;; + esac + done +fi + +if test $# -eq 0; then + if test -z "$dir_arg"; then + echo "$0: no input file specified." >&2 + exit 1 + fi + # It's OK to call 'install-sh -d' without argument. + # This can happen when creating conditional directories. + exit 0 +fi + +if test -z "$dir_arg"; then + if test $# -gt 1 || test "$is_target_a_directory" = always; then + if test ! -d "$dst_arg"; then + echo "$0: $dst_arg: Is not a directory." >&2 + exit 1 + fi + fi +fi + +if test -z "$dir_arg"; then + do_exit='(exit $ret); exit $ret' + trap "ret=129; $do_exit" 1 + trap "ret=130; $do_exit" 2 + trap "ret=141; $do_exit" 13 + trap "ret=143; $do_exit" 15 + + # Set umask so as not to create temps with too-generous modes. + # However, 'strip' requires both read and write access to temps. + case $mode in + # Optimize common cases. + *644) cp_umask=133;; + *755) cp_umask=22;; + + *[0-7]) + if test -z "$stripcmd"; then + u_plus_rw= + else + u_plus_rw='% 200' + fi + cp_umask=`expr '(' 777 - $mode % 1000 ')' $u_plus_rw`;; + *) + if test -z "$stripcmd"; then + u_plus_rw= + else + u_plus_rw=,u+rw + fi + cp_umask=$mode$u_plus_rw;; + esac +fi + +for src +do + # Protect names problematic for 'test' and other utilities. + case $src in + -* | [=\(\)!]) src=./$src;; + esac + + if test -n "$dir_arg"; then + dst=$src + dstdir=$dst + test -d "$dstdir" + dstdir_status=$? + # Don't chown directories that already exist. + if test $dstdir_status = 0; then + chowncmd="" + fi + else + + # Waiting for this to be detected by the "$cpprog $src $dsttmp" command + # might cause directories to be created, which would be especially bad + # if $src (and thus $dsttmp) contains '*'. + if test ! -f "$src" && test ! -d "$src"; then + echo "$0: $src does not exist." >&2 + exit 1 + fi + + if test -z "$dst_arg"; then + echo "$0: no destination specified." >&2 + exit 1 + fi + dst=$dst_arg + + # If destination is a directory, append the input filename. + if test -d "$dst"; then + if test "$is_target_a_directory" = never; then + echo "$0: $dst_arg: Is a directory" >&2 + exit 1 + fi + dstdir=$dst + dstbase=`basename "$src"` + case $dst in + */) dst=$dst$dstbase;; + *) dst=$dst/$dstbase;; + esac + dstdir_status=0 + else + dstdir=`dirname "$dst"` + test -d "$dstdir" + dstdir_status=$? + fi + fi + + case $dstdir in + */) dstdirslash=$dstdir;; + *) dstdirslash=$dstdir/;; + esac + + obsolete_mkdir_used=false + + if test $dstdir_status != 0; then + case $posix_mkdir in + '') + # With -d, create the new directory with the user-specified mode. + # Otherwise, rely on $mkdir_umask. + if test -n "$dir_arg"; then + mkdir_mode=-m$mode + else + mkdir_mode= + fi + + posix_mkdir=false + # The $RANDOM variable is not portable (e.g., dash). Use it + # here however when possible just to lower collision chance. + tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$ + + trap ' + ret=$? + rmdir "$tmpdir/a/b" "$tmpdir/a" "$tmpdir" 2>/dev/null + exit $ret + ' 0 + + # Because "mkdir -p" follows existing symlinks and we likely work + # directly in world-writeable /tmp, make sure that the '$tmpdir' + # directory is successfully created first before we actually test + # 'mkdir -p'. + if (umask $mkdir_umask && + $mkdirprog $mkdir_mode "$tmpdir" && + exec $mkdirprog $mkdir_mode -p -- "$tmpdir/a/b") >/dev/null 2>&1 + then + if test -z "$dir_arg" || { + # Check for POSIX incompatibilities with -m. + # HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or + # other-writable bit of parent directory when it shouldn't. + # FreeBSD 6.1 mkdir -m -p sets mode of existing directory. + test_tmpdir="$tmpdir/a" + ls_ld_tmpdir=`ls -ld "$test_tmpdir"` + case $ls_ld_tmpdir in + d????-?r-*) different_mode=700;; + d????-?--*) different_mode=755;; + *) false;; + esac && + $mkdirprog -m$different_mode -p -- "$test_tmpdir" && { + ls_ld_tmpdir_1=`ls -ld "$test_tmpdir"` + test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1" + } + } + then posix_mkdir=: + fi + rmdir "$tmpdir/a/b" "$tmpdir/a" "$tmpdir" + else + # Remove any dirs left behind by ancient mkdir implementations. + rmdir ./$mkdir_mode ./-p ./-- "$tmpdir" 2>/dev/null + fi + trap '' 0;; + esac + + if + $posix_mkdir && ( + umask $mkdir_umask && + $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir" + ) + then : + else + + # mkdir does not conform to POSIX, + # or it failed possibly due to a race condition. Create the + # directory the slow way, step by step, checking for races as we go. + + case $dstdir in + /*) prefix='/';; + [-=\(\)!]*) prefix='./';; + *) prefix='';; + esac + + oIFS=$IFS + IFS=/ + set -f + set fnord $dstdir + shift + set +f + IFS=$oIFS + + prefixes= + + for d + do + test X"$d" = X && continue + + prefix=$prefix$d + if test -d "$prefix"; then + prefixes= + else + if $posix_mkdir; then + (umask $mkdir_umask && + $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break + # Don't fail if two instances are running concurrently. + test -d "$prefix" || exit 1 + else + case $prefix in + *\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;; + *) qprefix=$prefix;; + esac + prefixes="$prefixes '$qprefix'" + fi + fi + prefix=$prefix/ + done + + if test -n "$prefixes"; then + # Don't fail if two instances are running concurrently. + (umask $mkdir_umask && + eval "\$doit_exec \$mkdirprog $prefixes") || + test -d "$dstdir" || exit 1 + obsolete_mkdir_used=true + fi + fi + fi + + if test -n "$dir_arg"; then + { test -z "$chowncmd" || $doit $chowncmd "$dst"; } && + { test -z "$chgrpcmd" || $doit $chgrpcmd "$dst"; } && + { test "$obsolete_mkdir_used$chowncmd$chgrpcmd" = false || + test -z "$chmodcmd" || $doit $chmodcmd $mode "$dst"; } || exit 1 + else + + # Make a couple of temp file names in the proper directory. + dsttmp=${dstdirslash}_inst.$$_ + rmtmp=${dstdirslash}_rm.$$_ + + # Trap to clean up those temp files at exit. + trap 'ret=$?; rm -f "$dsttmp" "$rmtmp" && exit $ret' 0 + + # Copy the file name to the temp name. + (umask $cp_umask && + { test -z "$stripcmd" || { + # Create $dsttmp read-write so that cp doesn't create it read-only, + # which would cause strip to fail. + if test -z "$doit"; then + : >"$dsttmp" # No need to fork-exec 'touch'. + else + $doit touch "$dsttmp" + fi + } + } && + $doit_exec $cpprog "$src" "$dsttmp") && + + # and set any options; do chmod last to preserve setuid bits. + # + # If any of these fail, we abort the whole thing. If we want to + # ignore errors from any of these, just make sure not to ignore + # errors from the above "$doit $cpprog $src $dsttmp" command. + # + { test -z "$chowncmd" || $doit $chowncmd "$dsttmp"; } && + { test -z "$chgrpcmd" || $doit $chgrpcmd "$dsttmp"; } && + { test -z "$stripcmd" || $doit $stripcmd "$dsttmp"; } && + { test -z "$chmodcmd" || $doit $chmodcmd $mode "$dsttmp"; } && + + # If -C, don't bother to copy if it wouldn't change the file. + if $copy_on_change && + old=`LC_ALL=C ls -dlL "$dst" 2>/dev/null` && + new=`LC_ALL=C ls -dlL "$dsttmp" 2>/dev/null` && + set -f && + set X $old && old=:$2:$4:$5:$6 && + set X $new && new=:$2:$4:$5:$6 && + set +f && + test "$old" = "$new" && + $cmpprog "$dst" "$dsttmp" >/dev/null 2>&1 + then + rm -f "$dsttmp" + else + # If $backupsuffix is set, and the file being installed + # already exists, attempt a backup. Don't worry if it fails, + # e.g., if mv doesn't support -f. + if test -n "$backupsuffix" && test -f "$dst"; then + $doit $mvcmd -f "$dst" "$dst$backupsuffix" 2>/dev/null + fi + + # Rename the file to the real destination. + $doit $mvcmd -f "$dsttmp" "$dst" 2>/dev/null || + + # The rename failed, perhaps because mv can't rename something else + # to itself, or perhaps because mv is so ancient that it does not + # support -f. + { + # Now remove or move aside any old file at destination location. + # We try this two ways since rm can't unlink itself on some + # systems and the destination file might be busy for other + # reasons. In this case, the final cleanup might fail but the new + # file should still install successfully. + { + test ! -f "$dst" || + $doit $rmcmd "$dst" 2>/dev/null || + { $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null && + { $doit $rmcmd "$rmtmp" 2>/dev/null; :; } + } || + { echo "$0: cannot unlink or rename $dst" >&2 + (exit 1); exit 1 + } + } && + + # Now rename the file to the real destination. + $doit $mvcmd "$dsttmp" "$dst" + } + fi || exit 1 + + trap '' 0 + fi +done + +# Local variables: +# eval: (add-hook 'before-save-hook 'time-stamp) +# time-stamp-start: "scriptversion=" +# time-stamp-format: "%:y-%02m-%02d.%02H" +# time-stamp-time-zone: "UTC0" +# time-stamp-end: "; # UTC" +# End: diff --git a/3rdparty/curl-8.21.0/lib/CMakeLists.txt b/3rdparty/curl-8.21.0/lib/CMakeLists.txt new file mode 100644 index 0000000000..3ef623536e --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/CMakeLists.txt @@ -0,0 +1,356 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### + +set(LIBCURL_OUTPUT_NAME "${LIB_NAME}" CACHE STRING "Basename of the curl library") + +set_property(DIRECTORY APPEND PROPERTY COMPILE_DEFINITIONS ${CURL_DEBUG_MACROS} "BUILDING_LIBCURL") + +configure_file("curl_config-cmake.h.in" "${CMAKE_CURRENT_BINARY_DIR}/curl_config.h") + +# Get CSOURCES, HHEADERS, LIB_RCFILES variables +curl_transform_makefile_inc("Makefile.inc" "${CMAKE_CURRENT_BINARY_DIR}/Makefile.inc.cmake") +include("${CMAKE_CURRENT_BINARY_DIR}/Makefile.inc.cmake") + +list(APPEND HHEADERS "${CMAKE_CURRENT_BINARY_DIR}/curl_config.h") + +# The rest of the build + +set_property(DIRECTORY APPEND PROPERTY INCLUDE_DIRECTORIES + "${PROJECT_BINARY_DIR}/lib" # for "curl_config.h" + "${PROJECT_SOURCE_DIR}/lib" +) + +if(CURL_BUILD_TESTING) + # special libcurlu library for unittests + add_library(curlu STATIC EXCLUDE_FROM_ALL ${HHEADERS} ${CSOURCES}) + target_compile_definitions(curlu PUBLIC "CURL_STATICLIB" "UNITTESTS") + target_link_libraries(curlu PUBLIC ${CURL_LIBS}) + # There is plenty of parallelism when building the testdeps target. + # Override the curlu batch size with the maximum to optimize performance. + set_target_properties(curlu PROPERTIES UNITY_BUILD ON UNITY_BUILD_BATCH_SIZE 0 C_CLANG_TIDY "") + + add_custom_command(OUTPUT "${CMAKE_CURRENT_BINARY_DIR}/unitprotos.h" + WORKING_DIRECTORY "${CMAKE_CURRENT_SOURCE_DIR}" + COMMAND ${PERL_EXECUTABLE} "${PROJECT_SOURCE_DIR}/scripts/extract-unit-protos" + ${CSOURCES} > "${CMAKE_CURRENT_BINARY_DIR}/unitprotos.h" + DEPENDS "${PROJECT_SOURCE_DIR}/scripts/extract-unit-protos" ${CSOURCES} + VERBATIM) + add_custom_target(curlu-unitprotos DEPENDS "${CMAKE_CURRENT_BINARY_DIR}/unitprotos.h") +endif() + +## Library definition + +if(NOT DEFINED IMPORT_LIB_SUFFIX) + # Suffix implib name with "_imp" by default, to avoid conflicting with + # the generated static "libcurl.lib" (typically with MSVC). + if(WIN32 AND BUILD_SHARED_LIBS AND + CMAKE_IMPORT_LIBRARY_SUFFIX STREQUAL CMAKE_STATIC_LIBRARY_SUFFIX) + set(IMPORT_LIB_SUFFIX "_imp") + else() + set(IMPORT_LIB_SUFFIX "") + endif() +endif() +if(NOT DEFINED STATIC_LIB_SUFFIX) + set(STATIC_LIB_SUFFIX "") +endif() + +# Detect implib static lib filename collision +if(WIN32 AND BUILD_STATIC_LIBS AND BUILD_SHARED_LIBS AND + "${IMPORT_LIB_SUFFIX}${CMAKE_IMPORT_LIBRARY_SUFFIX}" STREQUAL + "${STATIC_LIB_SUFFIX}${CMAKE_STATIC_LIBRARY_SUFFIX}") + message(FATAL_ERROR "Library suffix is the same ('${STATIC_LIB_SUFFIX}${CMAKE_STATIC_LIBRARY_SUFFIX}') " + "for the import and static '${LIBCURL_OUTPUT_NAME}' library. " + "Set IMPORT_LIB_SUFFIX and/or STATIC_LIB_SUFFIX to different values, " + "or disable building either the shared or static library to avoid the filename collision.") +endif() + +# Whether to do a single compilation pass for libcurl sources and reuse these +# objects to generate both static and shared target. +if(NOT DEFINED SHARE_LIB_OBJECT) + # Enable it by default on platforms where PIC is the default for both shared + # and static and there is a way to tell the linker which libcurl symbols it + # should export (vs. marking these symbols exportable at compile-time). + if(WIN32) + set(SHARE_LIB_OBJECT ON) + else() + # On other platforms, make it an option disabled by default + set(SHARE_LIB_OBJECT OFF) + endif() +endif() + +if(SHARE_LIB_OBJECT) + set(LIB_OBJECT "libcurl_object") + add_library(${LIB_OBJECT} OBJECT ${HHEADERS} ${CSOURCES}) + if(WIN32) + # Define CURL_STATICLIB always, to disable __declspec(dllexport) for + # exported libcurl symbols. We handle exports via libcurl.def instead. + # Except with symbol hiding disabled or debug mode enabled, when we export + # _all_ symbols from libcurl DLL, without using libcurl.def. + set_property(TARGET ${LIB_OBJECT} APPEND PROPERTY COMPILE_DEFINITIONS "CURL_STATICLIB") + endif() + target_link_libraries(${LIB_OBJECT} PRIVATE ${CURL_LIBS}) + set_target_properties(${LIB_OBJECT} PROPERTIES POSITION_INDEPENDENT_CODE ON) + set_property(TARGET ${LIB_OBJECT} APPEND PROPERTY COMPILE_OPTIONS "${CURL_CFLAGS}") + if(CURL_HIDES_PRIVATE_SYMBOLS) + set_property(TARGET ${LIB_OBJECT} APPEND PROPERTY COMPILE_OPTIONS "${CURL_CFLAG_SYMBOLS_HIDE}") + set_property(TARGET ${LIB_OBJECT} APPEND PROPERTY COMPILE_DEFINITIONS "CURL_HIDDEN_SYMBOLS") + endif() + if(CURL_HAS_LTO) + if(CMAKE_CONFIGURATION_TYPES) + set_target_properties(${LIB_OBJECT} PROPERTIES + INTERPROCEDURAL_OPTIMIZATION_RELEASE TRUE + INTERPROCEDURAL_OPTIMIZATION_RELWITHDEBINFO TRUE) + else() + set_target_properties(${LIB_OBJECT} PROPERTIES INTERPROCEDURAL_OPTIMIZATION TRUE) + endif() + endif() + if(CURL_CLANG_TIDY) + set_target_properties(${LIB_OBJECT} PROPERTIES UNITY_BUILD OFF) + endif() + if(CURL_ANALYZER_CFLAGS) + set_target_properties(${LIB_OBJECT} PROPERTIES UNITY_BUILD OFF) + set_property(TARGET ${LIB_OBJECT} APPEND PROPERTY COMPILE_OPTIONS ${CURL_ANALYZER_CFLAGS}) + endif() + if(CURL_CODE_COVERAGE) + set_property(TARGET ${LIB_OBJECT} APPEND PROPERTY COMPILE_DEFINITIONS ${CURL_COVERAGE_MACROS}) + set_property(TARGET ${LIB_OBJECT} APPEND PROPERTY COMPILE_OPTIONS ${CURL_COVERAGE_CFLAGS}) + endif() + + target_include_directories(${LIB_OBJECT} INTERFACE + "$" + "$") + + set(LIB_SOURCE $) +else() + set(LIB_SOURCE ${HHEADERS} ${CSOURCES}) +endif() + +# We want it to be called libcurl on all platforms +if(BUILD_STATIC_LIBS) + list(APPEND libcurl_export ${LIB_STATIC}) + add_library(${LIB_STATIC} STATIC ${LIB_SOURCE}) + add_library(${PROJECT_NAME}::${LIB_STATIC} ALIAS ${LIB_STATIC}) + if(WIN32) + set_property(TARGET ${LIB_STATIC} APPEND PROPERTY COMPILE_DEFINITIONS "CURL_STATICLIB") + endif() + target_link_libraries(${LIB_STATIC} PRIVATE ${CURL_LIBS}) + # Remove the "lib" prefix since the library is already named "libcurl". + set_target_properties(${LIB_STATIC} PROPERTIES + PREFIX "" OUTPUT_NAME "${LIBCURL_OUTPUT_NAME}" + SUFFIX "${STATIC_LIB_SUFFIX}${CMAKE_STATIC_LIBRARY_SUFFIX}" + INTERFACE_COMPILE_DEFINITIONS "CURL_STATICLIB") + set_property(TARGET ${LIB_STATIC} APPEND PROPERTY COMPILE_OPTIONS "${CURL_CFLAGS}") + if(CURL_HIDES_PRIVATE_SYMBOLS) + set_property(TARGET ${LIB_STATIC} APPEND PROPERTY COMPILE_OPTIONS "${CURL_CFLAG_SYMBOLS_HIDE}") + set_property(TARGET ${LIB_STATIC} APPEND PROPERTY COMPILE_DEFINITIONS "CURL_HIDDEN_SYMBOLS") + endif() + if(CURL_HAS_LTO) + if(CMAKE_CONFIGURATION_TYPES) + set_target_properties(${LIB_STATIC} PROPERTIES + INTERPROCEDURAL_OPTIMIZATION_RELEASE TRUE + INTERPROCEDURAL_OPTIMIZATION_RELWITHDEBINFO TRUE) + else() + set_target_properties(${LIB_STATIC} PROPERTIES INTERPROCEDURAL_OPTIMIZATION TRUE) + endif() + endif() + if(CURL_CLANG_TIDY) + if(BUILD_SHARED_LIBS) # disable clang-tidy for static, and limit to the shared library, if both enabled + set_target_properties(${LIB_STATIC} PROPERTIES C_CLANG_TIDY "") + else() + set_target_properties(${LIB_STATIC} PROPERTIES UNITY_BUILD OFF) + endif() + endif() + if(CURL_ANALYZER_CFLAGS) + set_target_properties(${LIB_STATIC} PROPERTIES UNITY_BUILD OFF) + set_property(TARGET ${LIB_STATIC} APPEND PROPERTY COMPILE_OPTIONS ${CURL_ANALYZER_CFLAGS}) + endif() + if(CURL_CODE_COVERAGE) + set_property(TARGET ${LIB_STATIC} APPEND PROPERTY COMPILE_DEFINITIONS ${CURL_COVERAGE_MACROS}) + set_property(TARGET ${LIB_STATIC} APPEND PROPERTY COMPILE_OPTIONS ${CURL_COVERAGE_CFLAGS}) + endif() + + target_include_directories(${LIB_STATIC} INTERFACE + "$" + "$") +endif() + +if(BUILD_SHARED_LIBS) + list(APPEND libcurl_export ${LIB_SHARED}) + add_library(${LIB_SHARED} SHARED ${LIB_SOURCE}) + add_library(${PROJECT_NAME}::${LIB_SHARED} ALIAS ${LIB_SHARED}) + if(WIN32) + set_property(TARGET ${LIB_SHARED} APPEND PROPERTY SOURCES "dllmain.c") + set_property(TARGET ${LIB_SHARED} APPEND PROPERTY SOURCES ${LIB_RCFILES}) + if(CURL_HIDES_PRIVATE_SYMBOLS) + set_property(TARGET ${LIB_SHARED} APPEND PROPERTY SOURCES "${PROJECT_SOURCE_DIR}/lib/libcurl.def") + endif() + endif() + target_link_libraries(${LIB_SHARED} PRIVATE ${CURL_LIBS}) + # Remove the "lib" prefix since the library is already named "libcurl". + set_target_properties(${LIB_SHARED} PROPERTIES + PREFIX "" OUTPUT_NAME "${LIBCURL_OUTPUT_NAME}" + IMPORT_PREFIX "" IMPORT_SUFFIX "${IMPORT_LIB_SUFFIX}${CMAKE_IMPORT_LIBRARY_SUFFIX}" + POSITION_INDEPENDENT_CODE ON) + set_property(TARGET ${LIB_SHARED} APPEND PROPERTY COMPILE_OPTIONS "${CURL_CFLAGS}") + if(CURL_HIDES_PRIVATE_SYMBOLS) + set_property(TARGET ${LIB_SHARED} APPEND PROPERTY COMPILE_OPTIONS "${CURL_CFLAG_SYMBOLS_HIDE}") + set_property(TARGET ${LIB_SHARED} APPEND PROPERTY COMPILE_DEFINITIONS "CURL_HIDDEN_SYMBOLS") + endif() + if(CURL_HAS_LTO) + if(CMAKE_CONFIGURATION_TYPES) + set_target_properties(${LIB_SHARED} PROPERTIES + INTERPROCEDURAL_OPTIMIZATION_RELEASE TRUE + INTERPROCEDURAL_OPTIMIZATION_RELWITHDEBINFO TRUE) + else() + set_target_properties(${LIB_SHARED} PROPERTIES INTERPROCEDURAL_OPTIMIZATION TRUE) + endif() + endif() + if(CURL_CLANG_TIDY) + set_target_properties(${LIB_SHARED} PROPERTIES UNITY_BUILD OFF) + endif() + if(CURL_ANALYZER_CFLAGS) + set_target_properties(${LIB_SHARED} PROPERTIES UNITY_BUILD OFF) + set_property(TARGET ${LIB_SHARED} APPEND PROPERTY COMPILE_OPTIONS ${CURL_ANALYZER_CFLAGS}) + endif() + if(CURL_CODE_COVERAGE) + set_property(TARGET ${LIB_SHARED} APPEND PROPERTY COMPILE_DEFINITIONS ${CURL_COVERAGE_MACROS}) + set_property(TARGET ${LIB_SHARED} APPEND PROPERTY COMPILE_OPTIONS ${CURL_COVERAGE_CFLAGS}) + set_property(TARGET ${LIB_SHARED} APPEND PROPERTY LINK_OPTIONS ${CURL_COVERAGE_LDFLAGS}) + endif() + + target_include_directories(${LIB_SHARED} INTERFACE + "$" + "$") + + if(CMAKE_DLL_NAME_WITH_SOVERSION OR + CYGWIN OR + APPLE OR + AIX OR CMAKE_SYSTEM_NAME STREQUAL "AIX" OR + CMAKE_SYSTEM_NAME STREQUAL "Linux" OR + CMAKE_SYSTEM_NAME STREQUAL "SunOS" OR + CMAKE_SYSTEM_NAME STREQUAL "Haiku" OR + CMAKE_SYSTEM_NAME STREQUAL "OHOS" OR # OpenHarmony + CMAKE_SYSTEM_NAME STREQUAL "GNU/kFreeBSD" OR + # FreeBSD comes with the a.out and ELF flavors but a.out was supported + # up to v3.x and ELF from v3.x. I cannot imagine someone running CMake + # on those ancient systems. + CMAKE_SYSTEM_NAME STREQUAL "FreeBSD") + set(_soversion_default TRUE) + else() + set(_soversion_default FALSE) + endif() + + option(CURL_LIBCURL_SOVERSION "Enable libcurl SOVERSION" ${_soversion_default}) + option(CURL_LIBCURL_VERSIONED_SYMBOLS "Enable libcurl versioned symbols" OFF) + + if(CURL_LIBCURL_SOVERSION OR CURL_LIBCURL_VERSIONED_SYMBOLS) + # Get VERSIONCHANGE, VERSIONADD, VERSIONDEL, VERSIONINFO variables + curl_transform_makefile_inc("Makefile.soname" "${CMAKE_CURRENT_BINARY_DIR}/Makefile.soname.cmake") + include("${CMAKE_CURRENT_BINARY_DIR}/Makefile.soname.cmake") + + math(EXPR _cmakesoname "${VERSIONCHANGE} - ${VERSIONDEL}") + set(_cmakeversion "${_cmakesoname}.${VERSIONDEL}.${VERSIONADD}") + endif() + + if(CURL_LIBCURL_SOVERSION) + set_target_properties(${LIB_SHARED} PROPERTIES + VERSION "${_cmakeversion}" SOVERSION "${_cmakesoname}") + endif() + + ## Versioned symbols + + if(CURL_LIBCURL_VERSIONED_SYMBOLS) + if(NOT DEFINED CURL_LIBCURL_VERSIONED_SYMBOLS_PREFIX) + # Default to prefixes used by autotools + if(CURL_WITH_MULTI_SSL) + set(CURL_LIBCURL_VERSIONED_SYMBOLS_PREFIX "MULTISSL_") + elseif(CURL_USE_OPENSSL) + set(CURL_LIBCURL_VERSIONED_SYMBOLS_PREFIX "OPENSSL_") + elseif(CURL_USE_MBEDTLS) + set(CURL_LIBCURL_VERSIONED_SYMBOLS_PREFIX "MBEDTLS_") + elseif(CURL_USE_WOLFSSL) + set(CURL_LIBCURL_VERSIONED_SYMBOLS_PREFIX "WOLFSSL_") + elseif(CURL_USE_GNUTLS) + set(CURL_LIBCURL_VERSIONED_SYMBOLS_PREFIX "GNUTLS_") + elseif(CURL_USE_RUSTLS) + set(CURL_LIBCURL_VERSIONED_SYMBOLS_PREFIX "RUSTLS_") + endif() + endif() + # Generate version script for the linker, for versioned symbols. + # Consumed variables: + # CURL_LIBCURL_VERSIONED_SYMBOLS_PREFIX + # CURL_LIBCURL_VERSIONED_SYMBOLS_SONAME + set(CURL_LIBCURL_VERSIONED_SYMBOLS_SONAME ${_cmakesoname}) + configure_file( + "${CMAKE_CURRENT_SOURCE_DIR}/libcurl.vers.in" + "${CMAKE_CURRENT_BINARY_DIR}/libcurl.vers" @ONLY) + include(CMakePushCheckState) + include(CheckCSourceCompiles) + cmake_push_check_state() + set(CMAKE_REQUIRED_LINK_OPTIONS "-Wl,--version-script=${CMAKE_CURRENT_BINARY_DIR}/libcurl.vers") + check_c_source_compiles("int main(void) { return 0; }" HAVE_VERSIONED_SYMBOLS) + if(HAVE_VERSIONED_SYMBOLS) + set_property(TARGET ${LIB_SHARED} APPEND PROPERTY LINK_OPTIONS "${CMAKE_REQUIRED_LINK_OPTIONS}") + else() + message(WARNING "Versioned symbols requested, but not supported by the toolchain.") + endif() + cmake_pop_check_state() + endif() +endif() + +add_library(${LIB_NAME} ALIAS ${LIB_SELECTED}) +add_library(${PROJECT_NAME}::${LIB_NAME} ALIAS ${LIB_SELECTED}) + +if(CURL_ENABLE_EXPORT_TARGET) + if(NOT CURL_DISABLE_INSTALL AND BUILD_STATIC_LIBS) + install(TARGETS ${LIB_STATIC} + EXPORT ${TARGETS_EXPORT_NAME} + ARCHIVE DESTINATION ${CMAKE_INSTALL_LIBDIR} + LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR} + RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR} + ) + endif() + if(NOT CURL_DISABLE_INSTALL AND BUILD_SHARED_LIBS) + install(TARGETS ${LIB_SHARED} + EXPORT ${TARGETS_EXPORT_NAME} + ARCHIVE DESTINATION ${CMAKE_INSTALL_LIBDIR} + LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR} + RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR} + ) + endif() + + export(TARGETS ${libcurl_export} + FILE "${PROJECT_BINARY_DIR}/libcurl-target.cmake" + NAMESPACE ${PROJECT_NAME}:: + ) +endif() + +if(PERL_EXECUTABLE) + add_custom_target(curl-optiontable + COMMENT "Generating lib/easyoptions.c" VERBATIM USES_TERMINAL + COMMAND "${PERL_EXECUTABLE}" "${CMAKE_CURRENT_SOURCE_DIR}/optiontable.pl" "${PROJECT_SOURCE_DIR}/include/curl/curl.h" + > "${PROJECT_SOURCE_DIR}/lib/easyoptions.c" + DEPENDS "${CMAKE_CURRENT_SOURCE_DIR}/optiontable.pl" "${PROJECT_SOURCE_DIR}/include/curl/curl.h" + ) +endif() diff --git a/3rdparty/curl-8.21.0/lib/Makefile.am b/3rdparty/curl-8.21.0/lib/Makefile.am new file mode 100644 index 0000000000..8a2bd4e68e --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/Makefile.am @@ -0,0 +1,187 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +AUTOMAKE_OPTIONS = foreign nostdinc + +# Get CSOURCES, HHEADERS, LIB_RCFILES variables +include Makefile.inc + +CMAKE_DIST = CMakeLists.txt curl_config-cmake.h.in + +EXTRA_DIST = config-mac.h config-os400.h config-riscos.h config-win32.h \ + curl_config.h.in $(LIB_RCFILES) libcurl.def $(CMAKE_DIST) Makefile.soname \ + optiontable.pl + +lib_LTLIBRARIES = libcurl.la + +if BUILD_UNITTESTS +noinst_LTLIBRARIES = libcurlu.la + +# generate a file with "private" prototypes for unit testing +UNITPROTOS = unitprotos.h + +else +noinst_LTLIBRARIES = +endif + +# This might hold -Werror +CFLAGS += @CURL_CFLAG_EXTRAS@ + +# Specify our include paths here, and do it relative to $(top_srcdir) and +# $(top_builddir), to ensure that these paths which belong to the library +# being currently built and tested are searched before the library which +# might possibly already be installed in the system. +# +# $(top_srcdir)/include is for libcurl's external include files +# $(top_builddir)/lib is for libcurl's generated lib/curl_config.h file +# $(srcdir) for the generated unity source to find included sources + +AM_CPPFLAGS = -I$(top_srcdir)/include \ + -I$(top_builddir)/lib \ + -I$(top_srcdir)/lib \ + -I$(srcdir) + +# Prevent LIBS from being used for all link targets +LIBS = $(BLANK_AT_MAKETIME) + +if DEBUGBUILD +AM_CPPFLAGS += -DDEBUGBUILD +endif +AM_CPPFLAGS += -DBUILDING_LIBCURL + +if DOING_NATIVE_WINDOWS +CSOURCES += dllmain.c +endif + +if USE_UNITY +libcurl_unity.c: $(top_srcdir)/scripts/mk-unity.pl $(CSOURCES) + @PERL@ $(top_srcdir)/scripts/mk-unity.pl --include $(CSOURCES) > libcurl_unity.c + +nodist_libcurl_la_SOURCES = libcurl_unity.c +libcurl_la_SOURCES = +nodist_libcurlu_la_SOURCES = libcurl_unity.c +libcurlu_la_SOURCES = +CLEANFILES = libcurl_unity.c +else +libcurl_la_SOURCES = $(CSOURCES) $(HHEADERS) +libcurlu_la_SOURCES = $(CSOURCES) $(HHEADERS) +CLEANFILES = +endif + +CLEANFILES += $(UNITPROTOS) + +libcurl_la_CPPFLAGS_EXTRA = +libcurl_la_LDFLAGS_EXTRA = +libcurl_la_CFLAGS_EXTRA = + +if CURL_LT_SHLIB_USE_VERSION_INFO +# Get VERSIONCHANGE, VERSIONADD, VERSIONDEL, VERSIONINFO variables +include Makefile.soname +libcurl_la_LDFLAGS_EXTRA += $(VERSIONINFO) +endif + +if CURL_LT_SHLIB_USE_NO_UNDEFINED +libcurl_la_LDFLAGS_EXTRA += -no-undefined +endif + +if CURL_LT_SHLIB_USE_MIMPURE_TEXT +libcurl_la_LDFLAGS_EXTRA += -mimpure-text +endif + +if CURL_LT_SHLIB_USE_VERSIONED_SYMBOLS +libcurl_la_LDFLAGS_EXTRA += -Wl,--version-script=libcurl.vers +else +# if symbol-hiding is enabled, hide them! +if DOING_CURL_SYMBOL_HIDING +libcurl_la_LDFLAGS_EXTRA += -export-symbols-regex '^curl_.*' +endif +endif + +if USE_CPPFLAG_CURL_STATICLIB +libcurl_la_CPPFLAGS_EXTRA += -DCURL_STATICLIB +else +if HAVE_WINDRES +libcurl_la_SOURCES += $(LIB_RCFILES) +$(LIB_RCFILES): $(top_srcdir)/include/curl/curlver.h +endif +endif + +if DOING_CURL_SYMBOL_HIDING +libcurl_la_CPPFLAGS_EXTRA += -DCURL_HIDDEN_SYMBOLS +libcurl_la_CFLAGS_EXTRA += $(CFLAG_CURL_SYMBOL_HIDING) +endif + +libcurl_la_CPPFLAGS = $(AM_CPPFLAGS) $(libcurl_la_CPPFLAGS_EXTRA) +libcurl_la_LDFLAGS = $(libcurl_la_LDFLAGS_EXTRA) $(CURL_LDFLAGS_LIB) $(LIBCURL_PC_LIBS_PRIVATE) +libcurl_la_CFLAGS = $(libcurl_la_CFLAGS_EXTRA) + +libcurlu_la_CPPFLAGS = $(AM_CPPFLAGS) -DCURL_STATICLIB -DUNITTESTS +libcurlu_la_LDFLAGS = -static $(LIBCURL_PC_LIBS_PRIVATE) + +CHECKSRC = $(CS_$(V)) +CS_0 = @echo " RUN " $@; +CS_1 = +CS_ = $(CS_0) + +checksrc: + $(CHECKSRC)(@PERL@ $(top_srcdir)/scripts/checksrc.pl -D$(srcdir) $(CSOURCES) $(HHEADERS)) + +if NOT_CURL_CI +if DEBUGBUILD +# for debug builds, we scan the sources on all regular make invokes +CHECKSOURCES = checksrc +endif +endif + +all-local: $(CHECKSOURCES) + +UNIT_V = $(UNITV_$(V)) +UNITV_0 = @echo " UNITPR " $@; +UNITV_1 = +UNITV_ = $(UNITV_0) + +# UNITPROTOS depends on every C file in the lib/ dir +$(UNITPROTOS): $(CSOURCES) + $(UNIT_V)(cd $(srcdir) && @PERL@ ../scripts/extract-unit-protos $(CSOURCES)) > $(top_builddir)/lib/$(UNITPROTOS) + +_tidy_cflags = +TIDYFLAGS = +if CURL_WERROR +TIDYFLAGS += '--warnings-as-errors=*' +endif +if CLANG +_tidy_cflags += $(CFLAGS) +endif + +tidy: + (_csources=`echo ' $(CSOURCES)' | sed -E -e 's/ +$$//' -e 's/ +/ /g' -e 's| | $(srcdir)/|g'`; \ + @CLANG_TIDY@ --config-file=$(top_srcdir)/.clang-tidy.yml $(TIDYFLAGS) $(CURL_CLANG_TIDYFLAGS) $$_csources \ + -- $(AM_CPPFLAGS) $(CPPFLAGS) -DHAVE_CONFIG_H $(_tidy_cflags)) + +optiontable: + @PERL@ $(srcdir)/optiontable.pl $(top_srcdir)/include/curl/curl.h > $(srcdir)/easyoptions.c + +if HAVE_WINDRES +.rc.lo: + $(LIBTOOL) --tag=RC --mode=compile $(RC) -I$(top_srcdir)/include $(RCFLAGS) -i $< -o $@ +endif diff --git a/3rdparty/curl-8.21.0/lib/Makefile.in b/3rdparty/curl-8.21.0/lib/Makefile.in new file mode 100644 index 0000000000..548c2c10f2 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/Makefile.in @@ -0,0 +1,6304 @@ +# Makefile.in generated by automake 1.16.5 from Makefile.am. +# @configure_input@ + +# Copyright (C) 1994-2021 Free Software Foundation, Inc. + +# This Makefile.in is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY, to the extent permitted by law; without +# even the implied warranty of MERCHANTABILITY or FITNESS FOR A +# PARTICULAR PURPOSE. + +@SET_MAKE@ + +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# Shared between CMakeLists.txt and Makefile.am + +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# Shared between CMakeLists.txt and Makefile.am + +VPATH = @srcdir@ +am__is_gnu_make = { \ + if test -z '$(MAKELEVEL)'; then \ + false; \ + elif test -n '$(MAKE_HOST)'; then \ + true; \ + elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \ + true; \ + else \ + false; \ + fi; \ +} +am__make_running_with_option = \ + case $${target_option-} in \ + ?) ;; \ + *) echo "am__make_running_with_option: internal error: invalid" \ + "target option '$${target_option-}' specified" >&2; \ + exit 1;; \ + esac; \ + has_opt=no; \ + sane_makeflags=$$MAKEFLAGS; \ + if $(am__is_gnu_make); then \ + sane_makeflags=$$MFLAGS; \ + else \ + case $$MAKEFLAGS in \ + *\\[\ \ ]*) \ + bs=\\; \ + sane_makeflags=`printf '%s\n' "$$MAKEFLAGS" \ + | sed "s/$$bs$$bs[$$bs $$bs ]*//g"`;; \ + esac; \ + fi; \ + skip_next=no; \ + strip_trailopt () \ + { \ + flg=`printf '%s\n' "$$flg" | sed "s/$$1.*$$//"`; \ + }; \ + for flg in $$sane_makeflags; do \ + test $$skip_next = yes && { skip_next=no; continue; }; \ + case $$flg in \ + *=*|--*) continue;; \ + -*I) strip_trailopt 'I'; skip_next=yes;; \ + -*I?*) strip_trailopt 'I';; \ + -*O) strip_trailopt 'O'; skip_next=yes;; \ + -*O?*) strip_trailopt 'O';; \ + -*l) strip_trailopt 'l'; skip_next=yes;; \ + -*l?*) strip_trailopt 'l';; \ + -[dEDm]) skip_next=yes;; \ + -[JT]) skip_next=yes;; \ + esac; \ + case $$flg in \ + *$$target_option*) has_opt=yes; break;; \ + esac; \ + done; \ + test $$has_opt = yes +am__make_dryrun = (target_option=n; $(am__make_running_with_option)) +am__make_keepgoing = (target_option=k; $(am__make_running_with_option)) +pkgdatadir = $(datadir)/@PACKAGE@ +pkgincludedir = $(includedir)/@PACKAGE@ +pkglibdir = $(libdir)/@PACKAGE@ +pkglibexecdir = $(libexecdir)/@PACKAGE@ +am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd +install_sh_DATA = $(install_sh) -c -m 644 +install_sh_PROGRAM = $(install_sh) -c +install_sh_SCRIPT = $(install_sh) -c +INSTALL_HEADER = $(INSTALL_DATA) +transform = $(program_transform_name) +NORMAL_INSTALL = : +PRE_INSTALL = : +POST_INSTALL = : +NORMAL_UNINSTALL = : +PRE_UNINSTALL = : +POST_UNINSTALL = : +build_triplet = @build@ +host_triplet = @host@ +@DEBUGBUILD_TRUE@am__append_1 = -DDEBUGBUILD +@DOING_NATIVE_WINDOWS_TRUE@am__append_2 = dllmain.c + +# Get VERSIONCHANGE, VERSIONADD, VERSIONDEL, VERSIONINFO variables +@CURL_LT_SHLIB_USE_VERSION_INFO_TRUE@am__append_3 = $(VERSIONINFO) +@CURL_LT_SHLIB_USE_NO_UNDEFINED_TRUE@am__append_4 = -no-undefined +@CURL_LT_SHLIB_USE_MIMPURE_TEXT_TRUE@am__append_5 = -mimpure-text +@CURL_LT_SHLIB_USE_VERSIONED_SYMBOLS_TRUE@am__append_6 = -Wl,--version-script=libcurl.vers +# if symbol-hiding is enabled, hide them! +@CURL_LT_SHLIB_USE_VERSIONED_SYMBOLS_FALSE@@DOING_CURL_SYMBOL_HIDING_TRUE@am__append_7 = -export-symbols-regex '^curl_.*' +@USE_CPPFLAG_CURL_STATICLIB_TRUE@am__append_8 = -DCURL_STATICLIB +@HAVE_WINDRES_TRUE@@USE_CPPFLAG_CURL_STATICLIB_FALSE@am__append_9 = $(LIB_RCFILES) +@DOING_CURL_SYMBOL_HIDING_TRUE@am__append_10 = -DCURL_HIDDEN_SYMBOLS +@DOING_CURL_SYMBOL_HIDING_TRUE@am__append_11 = $(CFLAG_CURL_SYMBOL_HIDING) +@CURL_WERROR_TRUE@am__append_12 = '--warnings-as-errors=*' +@CLANG_TRUE@am__append_13 = $(CFLAGS) +subdir = lib +ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 +am__aclocal_m4_deps = $(top_srcdir)/m4/curl-amissl.m4 \ + $(top_srcdir)/m4/curl-apple-sectrust.m4 \ + $(top_srcdir)/m4/curl-compilers.m4 \ + $(top_srcdir)/m4/curl-confopts.m4 \ + $(top_srcdir)/m4/curl-functions.m4 \ + $(top_srcdir)/m4/curl-gnutls.m4 \ + $(top_srcdir)/m4/curl-mbedtls.m4 \ + $(top_srcdir)/m4/curl-openssl.m4 \ + $(top_srcdir)/m4/curl-override.m4 \ + $(top_srcdir)/m4/curl-reentrant.m4 \ + $(top_srcdir)/m4/curl-rustls.m4 \ + $(top_srcdir)/m4/curl-schannel.m4 \ + $(top_srcdir)/m4/curl-sysconfig.m4 \ + $(top_srcdir)/m4/curl-wolfssl.m4 $(top_srcdir)/m4/libtool.m4 \ + $(top_srcdir)/m4/ltoptions.m4 $(top_srcdir)/m4/ltsugar.m4 \ + $(top_srcdir)/m4/ltversion.m4 $(top_srcdir)/m4/lt~obsolete.m4 \ + $(top_srcdir)/m4/xc-am-iface.m4 \ + $(top_srcdir)/m4/xc-cc-check.m4 \ + $(top_srcdir)/m4/xc-lt-iface.m4 \ + $(top_srcdir)/m4/xc-val-flgs.m4 \ + $(top_srcdir)/m4/zz40-xc-ovr.m4 \ + $(top_srcdir)/m4/zz50-xc-ovr.m4 $(top_srcdir)/acinclude.m4 \ + $(top_srcdir)/configure.ac +am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ + $(ACLOCAL_M4) +DIST_COMMON = $(srcdir)/Makefile.am $(am__DIST_COMMON) +mkinstalldirs = $(install_sh) -d +CONFIG_HEADER = curl_config.h +CONFIG_CLEAN_FILES = libcurl.vers +CONFIG_CLEAN_VPATH_FILES = +am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; +am__vpath_adj = case $$p in \ + $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \ + *) f=$$p;; \ + esac; +am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`; +am__install_max = 40 +am__nobase_strip_setup = \ + srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'` +am__nobase_strip = \ + for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||" +am__nobase_list = $(am__nobase_strip_setup); \ + for p in $$list; do echo "$$p $$p"; done | \ + sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \ + $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \ + if (++n[$$2] == $(am__install_max)) \ + { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \ + END { for (dir in files) print dir, files[dir] }' +am__base_list = \ + sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \ + sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g' +am__uninstall_files_from_dir = { \ + test -z "$$files" \ + || { test ! -d "$$dir" && test ! -f "$$dir" && test ! -r "$$dir"; } \ + || { echo " ( cd '$$dir' && rm -f" $$files ")"; \ + $(am__cd) "$$dir" && rm -f $$files; }; \ + } +am__installdirs = "$(DESTDIR)$(libdir)" +LTLIBRARIES = $(lib_LTLIBRARIES) $(noinst_LTLIBRARIES) +libcurl_la_LIBADD = +am__libcurl_la_SOURCES_DIST = altsvc.c amigaos.c asyn-ares.c \ + asyn-base.c asyn-thrdd.c bufq.c bufref.c cf-dns.c \ + cf-h1-proxy.c cf-h2-proxy.c cf-haproxy.c cf-https-connect.c \ + cf-ip-happy.c cf-recvbuf.c cf-setup.c cf-socket.c cfilters.c \ + conncache.c connect.c content_encoding.c cookie.c creds.c \ + cshutdn.c curl_addrinfo.c curl_endian.c curl_fnmatch.c \ + curl_fopen.c curl_get_line.c curl_gethostname.c curl_gssapi.c \ + curl_memrchr.c curl_ntlm_core.c curl_range.c curl_sasl.c \ + curl_sha512_256.c curl_share.c curl_sspi.c curl_threads.c \ + curl_trc.c cw-out.c cw-pause.c dict.c dnscache.c doh.c \ + dynhds.c easy.c easygetopt.c easyoptions.c escape.c \ + fake_addrinfo.c file.c fileinfo.c formdata.c ftp.c \ + ftplistparser.c getenv.c getinfo.c gopher.c hash.c headers.c \ + hmac.c hostip.c hostip4.c hostip6.c hsts.c http.c http1.c \ + http2.c http_aws_sigv4.c http_chunks.c http_digest.c \ + http_negotiate.c http_ntlm.c http_proxy.c httpsrr.c idn.c \ + if2ip.c imap.c ldap.c llist.c macos.c md4.c md5.c memdebug.c \ + mime.c mprintf.c mqtt.c multi.c multi_ev.c multi_ntfy.c \ + netrc.c openldap.c parsedate.c peer.c pingpong.c pop3.c \ + progress.c protocol.c proxy.c psl.c rand.c ratelimit.c \ + request.c rtsp.c select.c sendf.c setopt.c sha256.c slist.c \ + smb.c smtp.c socketpair.c socks.c socks_gssapi.c socks_sspi.c \ + splay.c strcase.c strequal.c strerror.c system_win32.c \ + telnet.c tftp.c thrdpool.c thrdqueue.c transfer.c uint-bset.c \ + uint-hash.c uint-spbset.c uint-table.c url.c urlapi.c \ + version.c ws.c vauth/cleartext.c vauth/cram.c vauth/digest.c \ + vauth/digest_sspi.c vauth/gsasl.c vauth/krb5_gssapi.c \ + vauth/krb5_sspi.c vauth/ntlm.c vauth/ntlm_sspi.c \ + vauth/oauth2.c vauth/spnego_gssapi.c vauth/spnego_sspi.c \ + vauth/vauth.c vtls/apple.c vtls/cipher_suite.c vtls/gtls.c \ + vtls/hostcheck.c vtls/keylog.c vtls/mbedtls.c vtls/openssl.c \ + vtls/rustls.c vtls/schannel.c vtls/schannel_verify.c \ + vtls/vtls.c vtls/vtls_config.c vtls/vtls_scache.c \ + vtls/vtls_spack.c vtls/wolfssl.c vtls/x509asn1.c \ + vquic/capsule.c vquic/cf-capsule.c vquic/cf-ngtcp2.c \ + vquic/cf-ngtcp2-cmn.c vquic/cf-ngtcp2-proxy.c \ + vquic/cf-quiche.c vquic/vquic.c vquic/vquic-tls.c \ + vssh/libssh.c vssh/libssh2.c vssh/vssh.c curlx/base64.c \ + curlx/basename.c curlx/dynbuf.c curlx/fopen.c \ + curlx/inet_ntop.c curlx/inet_pton.c curlx/multibyte.c \ + curlx/nonblock.c curlx/snprintf.c curlx/strcopy.c \ + curlx/strdup.c curlx/strerr.c curlx/strparse.c \ + curlx/timediff.c curlx/timeval.c curlx/version_win32.c \ + curlx/wait.c curlx/warnless.c curlx/winapi.c dllmain.c \ + altsvc.h amigaos.h arpa_telnet.h asyn.h bufq.h bufref.h \ + cf-dns.h cf-h1-proxy.h cf-h2-proxy.h cf-haproxy.h \ + cf-https-connect.h cf-ip-happy.h cf-recvbuf.h cf-setup.h \ + cf-socket.h cfilters.h conncache.h cshutdn.h connect.h \ + content_encoding.h cookie.h creds.h curl_addrinfo.h \ + curl_ctype.h curl_endian.h curl_fnmatch.h curl_fopen.h \ + curl_get_line.h curl_gethostname.h curl_gssapi.h curl_hmac.h \ + curl_ldap.h curl_md4.h curl_md5.h curl_memrchr.h \ + curl_ntlm_core.h curl_printf.h curl_range.h curl_sasl.h \ + curl_setup.h curl_sha256.h curl_sha512_256.h curl_share.h \ + curl_sspi.h curl_threads.h curl_trc.h cw-out.h cw-pause.h \ + dict.h dnscache.h doh.h dynhds.h easy_lock.h easyif.h \ + easyoptions.h escape.h fake_addrinfo.h file.h fileinfo.h \ + formdata.h ftp.h ftp-int.h ftplistparser.h functypes.h \ + getinfo.h gopher.h hash.h headers.h hostip.h hsts.h http.h \ + http1.h http2.h http_aws_sigv4.h http_chunks.h http_digest.h \ + http_negotiate.h http_ntlm.h http_proxy.h httpsrr.h idn.h \ + if2ip.h imap.h llist.h macos.h mime.h mqtt.h multihandle.h \ + multi_ev.h multi_ntfy.h multiif.h netrc.h parsedate.h peer.h \ + pingpong.h pop3.h progress.h protocol.h proxy.h psl.h rand.h \ + ratelimit.h request.h rtsp.h select.h sendf.h setopt.h \ + setup-os400.h setup-vms.h setup-win32.h sigpipe.h slist.h \ + smb.h smtp.h sockaddr.h socketpair.h socks.h splay.h strcase.h \ + strerror.h system_win32.h telnet.h tftp.h thrdpool.h \ + thrdqueue.h transfer.h uint-bset.h uint-hash.h uint-spbset.h \ + uint-table.h url.h urlapi-int.h urldata.h ws.h vauth/digest.h \ + vauth/vauth.h vtls/apple.h vtls/cipher_suite.h vtls/gtls.h \ + vtls/hostcheck.h vtls/keylog.h vtls/mbedtls.h vtls/openssl.h \ + vtls/rustls.h vtls/schannel.h vtls/schannel_int.h vtls/vtls.h \ + vtls/vtls_config.h vtls/vtls_int.h vtls/vtls_scache.h \ + vtls/vtls_spack.h vtls/wolfssl.h vtls/x509asn1.h \ + vquic/capsule.h vquic/cf-capsule.h vquic/cf-ngtcp2.h \ + vquic/cf-ngtcp2-cmn.h vquic/cf-ngtcp2-proxy.h \ + vquic/cf-quiche.h vquic/vquic.h vquic/vquic_int.h \ + vquic/vquic-tls.h vssh/vssh.h vssh/ssh.h curlx/base64.h \ + curlx/basename.h curlx/dynbuf.h curlx/fopen.h \ + curlx/inet_ntop.h curlx/inet_pton.h curlx/multibyte.h \ + curlx/nonblock.h curlx/snprintf.h curlx/strcopy.h \ + curlx/strdup.h curlx/strerr.h curlx/strparse.h \ + curlx/timediff.h curlx/timeval.h curlx/version_win32.h \ + curlx/wait.h curlx/warnless.h curlx/winapi.h libcurl.rc +am__objects_1 = libcurl_la-altsvc.lo libcurl_la-amigaos.lo \ + libcurl_la-asyn-ares.lo libcurl_la-asyn-base.lo \ + libcurl_la-asyn-thrdd.lo libcurl_la-bufq.lo \ + libcurl_la-bufref.lo libcurl_la-cf-dns.lo \ + libcurl_la-cf-h1-proxy.lo libcurl_la-cf-h2-proxy.lo \ + libcurl_la-cf-haproxy.lo libcurl_la-cf-https-connect.lo \ + libcurl_la-cf-ip-happy.lo libcurl_la-cf-recvbuf.lo \ + libcurl_la-cf-setup.lo libcurl_la-cf-socket.lo \ + libcurl_la-cfilters.lo libcurl_la-conncache.lo \ + libcurl_la-connect.lo libcurl_la-content_encoding.lo \ + libcurl_la-cookie.lo libcurl_la-creds.lo libcurl_la-cshutdn.lo \ + libcurl_la-curl_addrinfo.lo libcurl_la-curl_endian.lo \ + libcurl_la-curl_fnmatch.lo libcurl_la-curl_fopen.lo \ + libcurl_la-curl_get_line.lo libcurl_la-curl_gethostname.lo \ + libcurl_la-curl_gssapi.lo libcurl_la-curl_memrchr.lo \ + libcurl_la-curl_ntlm_core.lo libcurl_la-curl_range.lo \ + libcurl_la-curl_sasl.lo libcurl_la-curl_sha512_256.lo \ + libcurl_la-curl_share.lo libcurl_la-curl_sspi.lo \ + libcurl_la-curl_threads.lo libcurl_la-curl_trc.lo \ + libcurl_la-cw-out.lo libcurl_la-cw-pause.lo libcurl_la-dict.lo \ + libcurl_la-dnscache.lo libcurl_la-doh.lo libcurl_la-dynhds.lo \ + libcurl_la-easy.lo libcurl_la-easygetopt.lo \ + libcurl_la-easyoptions.lo libcurl_la-escape.lo \ + libcurl_la-fake_addrinfo.lo libcurl_la-file.lo \ + libcurl_la-fileinfo.lo libcurl_la-formdata.lo \ + libcurl_la-ftp.lo libcurl_la-ftplistparser.lo \ + libcurl_la-getenv.lo libcurl_la-getinfo.lo \ + libcurl_la-gopher.lo libcurl_la-hash.lo libcurl_la-headers.lo \ + libcurl_la-hmac.lo libcurl_la-hostip.lo libcurl_la-hostip4.lo \ + libcurl_la-hostip6.lo libcurl_la-hsts.lo libcurl_la-http.lo \ + libcurl_la-http1.lo libcurl_la-http2.lo \ + libcurl_la-http_aws_sigv4.lo libcurl_la-http_chunks.lo \ + libcurl_la-http_digest.lo libcurl_la-http_negotiate.lo \ + libcurl_la-http_ntlm.lo libcurl_la-http_proxy.lo \ + libcurl_la-httpsrr.lo libcurl_la-idn.lo libcurl_la-if2ip.lo \ + libcurl_la-imap.lo libcurl_la-ldap.lo libcurl_la-llist.lo \ + libcurl_la-macos.lo libcurl_la-md4.lo libcurl_la-md5.lo \ + libcurl_la-memdebug.lo libcurl_la-mime.lo \ + libcurl_la-mprintf.lo libcurl_la-mqtt.lo libcurl_la-multi.lo \ + libcurl_la-multi_ev.lo libcurl_la-multi_ntfy.lo \ + libcurl_la-netrc.lo libcurl_la-openldap.lo \ + libcurl_la-parsedate.lo libcurl_la-peer.lo \ + libcurl_la-pingpong.lo libcurl_la-pop3.lo \ + libcurl_la-progress.lo libcurl_la-protocol.lo \ + libcurl_la-proxy.lo libcurl_la-psl.lo libcurl_la-rand.lo \ + libcurl_la-ratelimit.lo libcurl_la-request.lo \ + libcurl_la-rtsp.lo libcurl_la-select.lo libcurl_la-sendf.lo \ + libcurl_la-setopt.lo libcurl_la-sha256.lo libcurl_la-slist.lo \ + libcurl_la-smb.lo libcurl_la-smtp.lo libcurl_la-socketpair.lo \ + libcurl_la-socks.lo libcurl_la-socks_gssapi.lo \ + libcurl_la-socks_sspi.lo libcurl_la-splay.lo \ + libcurl_la-strcase.lo libcurl_la-strequal.lo \ + libcurl_la-strerror.lo libcurl_la-system_win32.lo \ + libcurl_la-telnet.lo libcurl_la-tftp.lo libcurl_la-thrdpool.lo \ + libcurl_la-thrdqueue.lo libcurl_la-transfer.lo \ + libcurl_la-uint-bset.lo libcurl_la-uint-hash.lo \ + libcurl_la-uint-spbset.lo libcurl_la-uint-table.lo \ + libcurl_la-url.lo libcurl_la-urlapi.lo libcurl_la-version.lo \ + libcurl_la-ws.lo +am__dirstamp = $(am__leading_dot)dirstamp +am__objects_2 = vauth/libcurl_la-cleartext.lo vauth/libcurl_la-cram.lo \ + vauth/libcurl_la-digest.lo vauth/libcurl_la-digest_sspi.lo \ + vauth/libcurl_la-gsasl.lo vauth/libcurl_la-krb5_gssapi.lo \ + vauth/libcurl_la-krb5_sspi.lo vauth/libcurl_la-ntlm.lo \ + vauth/libcurl_la-ntlm_sspi.lo vauth/libcurl_la-oauth2.lo \ + vauth/libcurl_la-spnego_gssapi.lo \ + vauth/libcurl_la-spnego_sspi.lo vauth/libcurl_la-vauth.lo +am__objects_3 = vtls/libcurl_la-apple.lo \ + vtls/libcurl_la-cipher_suite.lo vtls/libcurl_la-gtls.lo \ + vtls/libcurl_la-hostcheck.lo vtls/libcurl_la-keylog.lo \ + vtls/libcurl_la-mbedtls.lo vtls/libcurl_la-openssl.lo \ + vtls/libcurl_la-rustls.lo vtls/libcurl_la-schannel.lo \ + vtls/libcurl_la-schannel_verify.lo vtls/libcurl_la-vtls.lo \ + vtls/libcurl_la-vtls_config.lo vtls/libcurl_la-vtls_scache.lo \ + vtls/libcurl_la-vtls_spack.lo vtls/libcurl_la-wolfssl.lo \ + vtls/libcurl_la-x509asn1.lo +am__objects_4 = vquic/libcurl_la-capsule.lo \ + vquic/libcurl_la-cf-capsule.lo vquic/libcurl_la-cf-ngtcp2.lo \ + vquic/libcurl_la-cf-ngtcp2-cmn.lo \ + vquic/libcurl_la-cf-ngtcp2-proxy.lo \ + vquic/libcurl_la-cf-quiche.lo vquic/libcurl_la-vquic.lo \ + vquic/libcurl_la-vquic-tls.lo +am__objects_5 = vssh/libcurl_la-libssh.lo vssh/libcurl_la-libssh2.lo \ + vssh/libcurl_la-vssh.lo +am__objects_6 = curlx/libcurl_la-base64.lo \ + curlx/libcurl_la-basename.lo curlx/libcurl_la-dynbuf.lo \ + curlx/libcurl_la-fopen.lo curlx/libcurl_la-inet_ntop.lo \ + curlx/libcurl_la-inet_pton.lo curlx/libcurl_la-multibyte.lo \ + curlx/libcurl_la-nonblock.lo curlx/libcurl_la-snprintf.lo \ + curlx/libcurl_la-strcopy.lo curlx/libcurl_la-strdup.lo \ + curlx/libcurl_la-strerr.lo curlx/libcurl_la-strparse.lo \ + curlx/libcurl_la-timediff.lo curlx/libcurl_la-timeval.lo \ + curlx/libcurl_la-version_win32.lo curlx/libcurl_la-wait.lo \ + curlx/libcurl_la-warnless.lo curlx/libcurl_la-winapi.lo +@DOING_NATIVE_WINDOWS_TRUE@am__objects_7 = libcurl_la-dllmain.lo +am__objects_8 = $(am__objects_1) $(am__objects_2) $(am__objects_3) \ + $(am__objects_4) $(am__objects_5) $(am__objects_6) \ + $(am__objects_7) +am__objects_9 = +am__objects_10 = $(am__objects_9) $(am__objects_9) $(am__objects_9) \ + $(am__objects_9) $(am__objects_9) $(am__objects_9) +am__objects_11 = libcurl.lo +@HAVE_WINDRES_TRUE@@USE_CPPFLAG_CURL_STATICLIB_FALSE@am__objects_12 = $(am__objects_11) +@USE_UNITY_FALSE@am_libcurl_la_OBJECTS = $(am__objects_8) \ +@USE_UNITY_FALSE@ $(am__objects_10) $(am__objects_12) +@USE_UNITY_TRUE@am_libcurl_la_OBJECTS = $(am__objects_12) +@USE_UNITY_TRUE@nodist_libcurl_la_OBJECTS = \ +@USE_UNITY_TRUE@ libcurl_la-libcurl_unity.lo +libcurl_la_OBJECTS = $(am_libcurl_la_OBJECTS) \ + $(nodist_libcurl_la_OBJECTS) +AM_V_lt = $(am__v_lt_@AM_V@) +am__v_lt_ = $(am__v_lt_@AM_DEFAULT_V@) +am__v_lt_0 = --silent +am__v_lt_1 = +libcurl_la_LINK = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ + $(LIBTOOLFLAGS) --mode=link $(CCLD) $(libcurl_la_CFLAGS) \ + $(CFLAGS) $(libcurl_la_LDFLAGS) $(LDFLAGS) -o $@ +libcurlu_la_LIBADD = +am__libcurlu_la_SOURCES_DIST = altsvc.c amigaos.c asyn-ares.c \ + asyn-base.c asyn-thrdd.c bufq.c bufref.c cf-dns.c \ + cf-h1-proxy.c cf-h2-proxy.c cf-haproxy.c cf-https-connect.c \ + cf-ip-happy.c cf-recvbuf.c cf-setup.c cf-socket.c cfilters.c \ + conncache.c connect.c content_encoding.c cookie.c creds.c \ + cshutdn.c curl_addrinfo.c curl_endian.c curl_fnmatch.c \ + curl_fopen.c curl_get_line.c curl_gethostname.c curl_gssapi.c \ + curl_memrchr.c curl_ntlm_core.c curl_range.c curl_sasl.c \ + curl_sha512_256.c curl_share.c curl_sspi.c curl_threads.c \ + curl_trc.c cw-out.c cw-pause.c dict.c dnscache.c doh.c \ + dynhds.c easy.c easygetopt.c easyoptions.c escape.c \ + fake_addrinfo.c file.c fileinfo.c formdata.c ftp.c \ + ftplistparser.c getenv.c getinfo.c gopher.c hash.c headers.c \ + hmac.c hostip.c hostip4.c hostip6.c hsts.c http.c http1.c \ + http2.c http_aws_sigv4.c http_chunks.c http_digest.c \ + http_negotiate.c http_ntlm.c http_proxy.c httpsrr.c idn.c \ + if2ip.c imap.c ldap.c llist.c macos.c md4.c md5.c memdebug.c \ + mime.c mprintf.c mqtt.c multi.c multi_ev.c multi_ntfy.c \ + netrc.c openldap.c parsedate.c peer.c pingpong.c pop3.c \ + progress.c protocol.c proxy.c psl.c rand.c ratelimit.c \ + request.c rtsp.c select.c sendf.c setopt.c sha256.c slist.c \ + smb.c smtp.c socketpair.c socks.c socks_gssapi.c socks_sspi.c \ + splay.c strcase.c strequal.c strerror.c system_win32.c \ + telnet.c tftp.c thrdpool.c thrdqueue.c transfer.c uint-bset.c \ + uint-hash.c uint-spbset.c uint-table.c url.c urlapi.c \ + version.c ws.c vauth/cleartext.c vauth/cram.c vauth/digest.c \ + vauth/digest_sspi.c vauth/gsasl.c vauth/krb5_gssapi.c \ + vauth/krb5_sspi.c vauth/ntlm.c vauth/ntlm_sspi.c \ + vauth/oauth2.c vauth/spnego_gssapi.c vauth/spnego_sspi.c \ + vauth/vauth.c vtls/apple.c vtls/cipher_suite.c vtls/gtls.c \ + vtls/hostcheck.c vtls/keylog.c vtls/mbedtls.c vtls/openssl.c \ + vtls/rustls.c vtls/schannel.c vtls/schannel_verify.c \ + vtls/vtls.c vtls/vtls_config.c vtls/vtls_scache.c \ + vtls/vtls_spack.c vtls/wolfssl.c vtls/x509asn1.c \ + vquic/capsule.c vquic/cf-capsule.c vquic/cf-ngtcp2.c \ + vquic/cf-ngtcp2-cmn.c vquic/cf-ngtcp2-proxy.c \ + vquic/cf-quiche.c vquic/vquic.c vquic/vquic-tls.c \ + vssh/libssh.c vssh/libssh2.c vssh/vssh.c curlx/base64.c \ + curlx/basename.c curlx/dynbuf.c curlx/fopen.c \ + curlx/inet_ntop.c curlx/inet_pton.c curlx/multibyte.c \ + curlx/nonblock.c curlx/snprintf.c curlx/strcopy.c \ + curlx/strdup.c curlx/strerr.c curlx/strparse.c \ + curlx/timediff.c curlx/timeval.c curlx/version_win32.c \ + curlx/wait.c curlx/warnless.c curlx/winapi.c dllmain.c \ + altsvc.h amigaos.h arpa_telnet.h asyn.h bufq.h bufref.h \ + cf-dns.h cf-h1-proxy.h cf-h2-proxy.h cf-haproxy.h \ + cf-https-connect.h cf-ip-happy.h cf-recvbuf.h cf-setup.h \ + cf-socket.h cfilters.h conncache.h cshutdn.h connect.h \ + content_encoding.h cookie.h creds.h curl_addrinfo.h \ + curl_ctype.h curl_endian.h curl_fnmatch.h curl_fopen.h \ + curl_get_line.h curl_gethostname.h curl_gssapi.h curl_hmac.h \ + curl_ldap.h curl_md4.h curl_md5.h curl_memrchr.h \ + curl_ntlm_core.h curl_printf.h curl_range.h curl_sasl.h \ + curl_setup.h curl_sha256.h curl_sha512_256.h curl_share.h \ + curl_sspi.h curl_threads.h curl_trc.h cw-out.h cw-pause.h \ + dict.h dnscache.h doh.h dynhds.h easy_lock.h easyif.h \ + easyoptions.h escape.h fake_addrinfo.h file.h fileinfo.h \ + formdata.h ftp.h ftp-int.h ftplistparser.h functypes.h \ + getinfo.h gopher.h hash.h headers.h hostip.h hsts.h http.h \ + http1.h http2.h http_aws_sigv4.h http_chunks.h http_digest.h \ + http_negotiate.h http_ntlm.h http_proxy.h httpsrr.h idn.h \ + if2ip.h imap.h llist.h macos.h mime.h mqtt.h multihandle.h \ + multi_ev.h multi_ntfy.h multiif.h netrc.h parsedate.h peer.h \ + pingpong.h pop3.h progress.h protocol.h proxy.h psl.h rand.h \ + ratelimit.h request.h rtsp.h select.h sendf.h setopt.h \ + setup-os400.h setup-vms.h setup-win32.h sigpipe.h slist.h \ + smb.h smtp.h sockaddr.h socketpair.h socks.h splay.h strcase.h \ + strerror.h system_win32.h telnet.h tftp.h thrdpool.h \ + thrdqueue.h transfer.h uint-bset.h uint-hash.h uint-spbset.h \ + uint-table.h url.h urlapi-int.h urldata.h ws.h vauth/digest.h \ + vauth/vauth.h vtls/apple.h vtls/cipher_suite.h vtls/gtls.h \ + vtls/hostcheck.h vtls/keylog.h vtls/mbedtls.h vtls/openssl.h \ + vtls/rustls.h vtls/schannel.h vtls/schannel_int.h vtls/vtls.h \ + vtls/vtls_config.h vtls/vtls_int.h vtls/vtls_scache.h \ + vtls/vtls_spack.h vtls/wolfssl.h vtls/x509asn1.h \ + vquic/capsule.h vquic/cf-capsule.h vquic/cf-ngtcp2.h \ + vquic/cf-ngtcp2-cmn.h vquic/cf-ngtcp2-proxy.h \ + vquic/cf-quiche.h vquic/vquic.h vquic/vquic_int.h \ + vquic/vquic-tls.h vssh/vssh.h vssh/ssh.h curlx/base64.h \ + curlx/basename.h curlx/dynbuf.h curlx/fopen.h \ + curlx/inet_ntop.h curlx/inet_pton.h curlx/multibyte.h \ + curlx/nonblock.h curlx/snprintf.h curlx/strcopy.h \ + curlx/strdup.h curlx/strerr.h curlx/strparse.h \ + curlx/timediff.h curlx/timeval.h curlx/version_win32.h \ + curlx/wait.h curlx/warnless.h curlx/winapi.h +am__objects_13 = libcurlu_la-altsvc.lo libcurlu_la-amigaos.lo \ + libcurlu_la-asyn-ares.lo libcurlu_la-asyn-base.lo \ + libcurlu_la-asyn-thrdd.lo libcurlu_la-bufq.lo \ + libcurlu_la-bufref.lo libcurlu_la-cf-dns.lo \ + libcurlu_la-cf-h1-proxy.lo libcurlu_la-cf-h2-proxy.lo \ + libcurlu_la-cf-haproxy.lo libcurlu_la-cf-https-connect.lo \ + libcurlu_la-cf-ip-happy.lo libcurlu_la-cf-recvbuf.lo \ + libcurlu_la-cf-setup.lo libcurlu_la-cf-socket.lo \ + libcurlu_la-cfilters.lo libcurlu_la-conncache.lo \ + libcurlu_la-connect.lo libcurlu_la-content_encoding.lo \ + libcurlu_la-cookie.lo libcurlu_la-creds.lo \ + libcurlu_la-cshutdn.lo libcurlu_la-curl_addrinfo.lo \ + libcurlu_la-curl_endian.lo libcurlu_la-curl_fnmatch.lo \ + libcurlu_la-curl_fopen.lo libcurlu_la-curl_get_line.lo \ + libcurlu_la-curl_gethostname.lo libcurlu_la-curl_gssapi.lo \ + libcurlu_la-curl_memrchr.lo libcurlu_la-curl_ntlm_core.lo \ + libcurlu_la-curl_range.lo libcurlu_la-curl_sasl.lo \ + libcurlu_la-curl_sha512_256.lo libcurlu_la-curl_share.lo \ + libcurlu_la-curl_sspi.lo libcurlu_la-curl_threads.lo \ + libcurlu_la-curl_trc.lo libcurlu_la-cw-out.lo \ + libcurlu_la-cw-pause.lo libcurlu_la-dict.lo \ + libcurlu_la-dnscache.lo libcurlu_la-doh.lo \ + libcurlu_la-dynhds.lo libcurlu_la-easy.lo \ + libcurlu_la-easygetopt.lo libcurlu_la-easyoptions.lo \ + libcurlu_la-escape.lo libcurlu_la-fake_addrinfo.lo \ + libcurlu_la-file.lo libcurlu_la-fileinfo.lo \ + libcurlu_la-formdata.lo libcurlu_la-ftp.lo \ + libcurlu_la-ftplistparser.lo libcurlu_la-getenv.lo \ + libcurlu_la-getinfo.lo libcurlu_la-gopher.lo \ + libcurlu_la-hash.lo libcurlu_la-headers.lo libcurlu_la-hmac.lo \ + libcurlu_la-hostip.lo libcurlu_la-hostip4.lo \ + libcurlu_la-hostip6.lo libcurlu_la-hsts.lo libcurlu_la-http.lo \ + libcurlu_la-http1.lo libcurlu_la-http2.lo \ + libcurlu_la-http_aws_sigv4.lo libcurlu_la-http_chunks.lo \ + libcurlu_la-http_digest.lo libcurlu_la-http_negotiate.lo \ + libcurlu_la-http_ntlm.lo libcurlu_la-http_proxy.lo \ + libcurlu_la-httpsrr.lo libcurlu_la-idn.lo libcurlu_la-if2ip.lo \ + libcurlu_la-imap.lo libcurlu_la-ldap.lo libcurlu_la-llist.lo \ + libcurlu_la-macos.lo libcurlu_la-md4.lo libcurlu_la-md5.lo \ + libcurlu_la-memdebug.lo libcurlu_la-mime.lo \ + libcurlu_la-mprintf.lo libcurlu_la-mqtt.lo \ + libcurlu_la-multi.lo libcurlu_la-multi_ev.lo \ + libcurlu_la-multi_ntfy.lo libcurlu_la-netrc.lo \ + libcurlu_la-openldap.lo libcurlu_la-parsedate.lo \ + libcurlu_la-peer.lo libcurlu_la-pingpong.lo \ + libcurlu_la-pop3.lo libcurlu_la-progress.lo \ + libcurlu_la-protocol.lo libcurlu_la-proxy.lo \ + libcurlu_la-psl.lo libcurlu_la-rand.lo \ + libcurlu_la-ratelimit.lo libcurlu_la-request.lo \ + libcurlu_la-rtsp.lo libcurlu_la-select.lo libcurlu_la-sendf.lo \ + libcurlu_la-setopt.lo libcurlu_la-sha256.lo \ + libcurlu_la-slist.lo libcurlu_la-smb.lo libcurlu_la-smtp.lo \ + libcurlu_la-socketpair.lo libcurlu_la-socks.lo \ + libcurlu_la-socks_gssapi.lo libcurlu_la-socks_sspi.lo \ + libcurlu_la-splay.lo libcurlu_la-strcase.lo \ + libcurlu_la-strequal.lo libcurlu_la-strerror.lo \ + libcurlu_la-system_win32.lo libcurlu_la-telnet.lo \ + libcurlu_la-tftp.lo libcurlu_la-thrdpool.lo \ + libcurlu_la-thrdqueue.lo libcurlu_la-transfer.lo \ + libcurlu_la-uint-bset.lo libcurlu_la-uint-hash.lo \ + libcurlu_la-uint-spbset.lo libcurlu_la-uint-table.lo \ + libcurlu_la-url.lo libcurlu_la-urlapi.lo \ + libcurlu_la-version.lo libcurlu_la-ws.lo +am__objects_14 = vauth/libcurlu_la-cleartext.lo \ + vauth/libcurlu_la-cram.lo vauth/libcurlu_la-digest.lo \ + vauth/libcurlu_la-digest_sspi.lo vauth/libcurlu_la-gsasl.lo \ + vauth/libcurlu_la-krb5_gssapi.lo \ + vauth/libcurlu_la-krb5_sspi.lo vauth/libcurlu_la-ntlm.lo \ + vauth/libcurlu_la-ntlm_sspi.lo vauth/libcurlu_la-oauth2.lo \ + vauth/libcurlu_la-spnego_gssapi.lo \ + vauth/libcurlu_la-spnego_sspi.lo vauth/libcurlu_la-vauth.lo +am__objects_15 = vtls/libcurlu_la-apple.lo \ + vtls/libcurlu_la-cipher_suite.lo vtls/libcurlu_la-gtls.lo \ + vtls/libcurlu_la-hostcheck.lo vtls/libcurlu_la-keylog.lo \ + vtls/libcurlu_la-mbedtls.lo vtls/libcurlu_la-openssl.lo \ + vtls/libcurlu_la-rustls.lo vtls/libcurlu_la-schannel.lo \ + vtls/libcurlu_la-schannel_verify.lo vtls/libcurlu_la-vtls.lo \ + vtls/libcurlu_la-vtls_config.lo \ + vtls/libcurlu_la-vtls_scache.lo vtls/libcurlu_la-vtls_spack.lo \ + vtls/libcurlu_la-wolfssl.lo vtls/libcurlu_la-x509asn1.lo +am__objects_16 = vquic/libcurlu_la-capsule.lo \ + vquic/libcurlu_la-cf-capsule.lo vquic/libcurlu_la-cf-ngtcp2.lo \ + vquic/libcurlu_la-cf-ngtcp2-cmn.lo \ + vquic/libcurlu_la-cf-ngtcp2-proxy.lo \ + vquic/libcurlu_la-cf-quiche.lo vquic/libcurlu_la-vquic.lo \ + vquic/libcurlu_la-vquic-tls.lo +am__objects_17 = vssh/libcurlu_la-libssh.lo \ + vssh/libcurlu_la-libssh2.lo vssh/libcurlu_la-vssh.lo +am__objects_18 = curlx/libcurlu_la-base64.lo \ + curlx/libcurlu_la-basename.lo curlx/libcurlu_la-dynbuf.lo \ + curlx/libcurlu_la-fopen.lo curlx/libcurlu_la-inet_ntop.lo \ + curlx/libcurlu_la-inet_pton.lo curlx/libcurlu_la-multibyte.lo \ + curlx/libcurlu_la-nonblock.lo curlx/libcurlu_la-snprintf.lo \ + curlx/libcurlu_la-strcopy.lo curlx/libcurlu_la-strdup.lo \ + curlx/libcurlu_la-strerr.lo curlx/libcurlu_la-strparse.lo \ + curlx/libcurlu_la-timediff.lo curlx/libcurlu_la-timeval.lo \ + curlx/libcurlu_la-version_win32.lo curlx/libcurlu_la-wait.lo \ + curlx/libcurlu_la-warnless.lo curlx/libcurlu_la-winapi.lo +@DOING_NATIVE_WINDOWS_TRUE@am__objects_19 = libcurlu_la-dllmain.lo +am__objects_20 = $(am__objects_13) $(am__objects_14) $(am__objects_15) \ + $(am__objects_16) $(am__objects_17) $(am__objects_18) \ + $(am__objects_19) +@USE_UNITY_FALSE@am_libcurlu_la_OBJECTS = $(am__objects_20) \ +@USE_UNITY_FALSE@ $(am__objects_10) +@USE_UNITY_TRUE@nodist_libcurlu_la_OBJECTS = \ +@USE_UNITY_TRUE@ libcurlu_la-libcurl_unity.lo +libcurlu_la_OBJECTS = $(am_libcurlu_la_OBJECTS) \ + $(nodist_libcurlu_la_OBJECTS) +libcurlu_la_LINK = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ + $(LIBTOOLFLAGS) --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) \ + $(libcurlu_la_LDFLAGS) $(LDFLAGS) -o $@ +@BUILD_UNITTESTS_TRUE@am_libcurlu_la_rpath = +AM_V_P = $(am__v_P_@AM_V@) +am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) +am__v_P_0 = false +am__v_P_1 = : +AM_V_GEN = $(am__v_GEN_@AM_V@) +am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@) +am__v_GEN_0 = @echo " GEN " $@; +am__v_GEN_1 = +AM_V_at = $(am__v_at_@AM_V@) +am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) +am__v_at_0 = @ +am__v_at_1 = +DEFAULT_INCLUDES = +depcomp = $(SHELL) $(top_srcdir)/depcomp +am__maybe_remake_depfiles = depfiles +am__depfiles_remade = ./$(DEPDIR)/libcurl_la-altsvc.Plo \ + ./$(DEPDIR)/libcurl_la-amigaos.Plo \ + ./$(DEPDIR)/libcurl_la-asyn-ares.Plo \ + ./$(DEPDIR)/libcurl_la-asyn-base.Plo \ + ./$(DEPDIR)/libcurl_la-asyn-thrdd.Plo \ + ./$(DEPDIR)/libcurl_la-bufq.Plo \ + ./$(DEPDIR)/libcurl_la-bufref.Plo \ + ./$(DEPDIR)/libcurl_la-cf-dns.Plo \ + ./$(DEPDIR)/libcurl_la-cf-h1-proxy.Plo \ + ./$(DEPDIR)/libcurl_la-cf-h2-proxy.Plo \ + ./$(DEPDIR)/libcurl_la-cf-haproxy.Plo \ + ./$(DEPDIR)/libcurl_la-cf-https-connect.Plo \ + ./$(DEPDIR)/libcurl_la-cf-ip-happy.Plo \ + ./$(DEPDIR)/libcurl_la-cf-recvbuf.Plo \ + ./$(DEPDIR)/libcurl_la-cf-setup.Plo \ + ./$(DEPDIR)/libcurl_la-cf-socket.Plo \ + ./$(DEPDIR)/libcurl_la-cfilters.Plo \ + ./$(DEPDIR)/libcurl_la-conncache.Plo \ + ./$(DEPDIR)/libcurl_la-connect.Plo \ + ./$(DEPDIR)/libcurl_la-content_encoding.Plo \ + ./$(DEPDIR)/libcurl_la-cookie.Plo \ + ./$(DEPDIR)/libcurl_la-creds.Plo \ + ./$(DEPDIR)/libcurl_la-cshutdn.Plo \ + ./$(DEPDIR)/libcurl_la-curl_addrinfo.Plo \ + ./$(DEPDIR)/libcurl_la-curl_endian.Plo \ + ./$(DEPDIR)/libcurl_la-curl_fnmatch.Plo \ + ./$(DEPDIR)/libcurl_la-curl_fopen.Plo \ + ./$(DEPDIR)/libcurl_la-curl_get_line.Plo \ + ./$(DEPDIR)/libcurl_la-curl_gethostname.Plo \ + ./$(DEPDIR)/libcurl_la-curl_gssapi.Plo \ + ./$(DEPDIR)/libcurl_la-curl_memrchr.Plo \ + ./$(DEPDIR)/libcurl_la-curl_ntlm_core.Plo \ + ./$(DEPDIR)/libcurl_la-curl_range.Plo \ + ./$(DEPDIR)/libcurl_la-curl_sasl.Plo \ + ./$(DEPDIR)/libcurl_la-curl_sha512_256.Plo \ + ./$(DEPDIR)/libcurl_la-curl_share.Plo \ + ./$(DEPDIR)/libcurl_la-curl_sspi.Plo \ + ./$(DEPDIR)/libcurl_la-curl_threads.Plo \ + ./$(DEPDIR)/libcurl_la-curl_trc.Plo \ + ./$(DEPDIR)/libcurl_la-cw-out.Plo \ + ./$(DEPDIR)/libcurl_la-cw-pause.Plo \ + ./$(DEPDIR)/libcurl_la-dict.Plo \ + ./$(DEPDIR)/libcurl_la-dllmain.Plo \ + ./$(DEPDIR)/libcurl_la-dnscache.Plo \ + ./$(DEPDIR)/libcurl_la-doh.Plo \ + ./$(DEPDIR)/libcurl_la-dynhds.Plo \ + ./$(DEPDIR)/libcurl_la-easy.Plo \ + ./$(DEPDIR)/libcurl_la-easygetopt.Plo \ + ./$(DEPDIR)/libcurl_la-easyoptions.Plo \ + ./$(DEPDIR)/libcurl_la-escape.Plo \ + ./$(DEPDIR)/libcurl_la-fake_addrinfo.Plo \ + ./$(DEPDIR)/libcurl_la-file.Plo \ + ./$(DEPDIR)/libcurl_la-fileinfo.Plo \ + ./$(DEPDIR)/libcurl_la-formdata.Plo \ + ./$(DEPDIR)/libcurl_la-ftp.Plo \ + ./$(DEPDIR)/libcurl_la-ftplistparser.Plo \ + ./$(DEPDIR)/libcurl_la-getenv.Plo \ + ./$(DEPDIR)/libcurl_la-getinfo.Plo \ + ./$(DEPDIR)/libcurl_la-gopher.Plo \ + ./$(DEPDIR)/libcurl_la-hash.Plo \ + ./$(DEPDIR)/libcurl_la-headers.Plo \ + ./$(DEPDIR)/libcurl_la-hmac.Plo \ + ./$(DEPDIR)/libcurl_la-hostip.Plo \ + ./$(DEPDIR)/libcurl_la-hostip4.Plo \ + ./$(DEPDIR)/libcurl_la-hostip6.Plo \ + ./$(DEPDIR)/libcurl_la-hsts.Plo \ + ./$(DEPDIR)/libcurl_la-http.Plo \ + ./$(DEPDIR)/libcurl_la-http1.Plo \ + ./$(DEPDIR)/libcurl_la-http2.Plo \ + ./$(DEPDIR)/libcurl_la-http_aws_sigv4.Plo \ + ./$(DEPDIR)/libcurl_la-http_chunks.Plo \ + ./$(DEPDIR)/libcurl_la-http_digest.Plo \ + ./$(DEPDIR)/libcurl_la-http_negotiate.Plo \ + ./$(DEPDIR)/libcurl_la-http_ntlm.Plo \ + ./$(DEPDIR)/libcurl_la-http_proxy.Plo \ + ./$(DEPDIR)/libcurl_la-httpsrr.Plo \ + ./$(DEPDIR)/libcurl_la-idn.Plo \ + ./$(DEPDIR)/libcurl_la-if2ip.Plo \ + ./$(DEPDIR)/libcurl_la-imap.Plo \ + ./$(DEPDIR)/libcurl_la-ldap.Plo \ + ./$(DEPDIR)/libcurl_la-libcurl_unity.Plo \ + ./$(DEPDIR)/libcurl_la-llist.Plo \ + ./$(DEPDIR)/libcurl_la-macos.Plo \ + ./$(DEPDIR)/libcurl_la-md4.Plo ./$(DEPDIR)/libcurl_la-md5.Plo \ + ./$(DEPDIR)/libcurl_la-memdebug.Plo \ + ./$(DEPDIR)/libcurl_la-mime.Plo \ + ./$(DEPDIR)/libcurl_la-mprintf.Plo \ + ./$(DEPDIR)/libcurl_la-mqtt.Plo \ + ./$(DEPDIR)/libcurl_la-multi.Plo \ + ./$(DEPDIR)/libcurl_la-multi_ev.Plo \ + ./$(DEPDIR)/libcurl_la-multi_ntfy.Plo \ + ./$(DEPDIR)/libcurl_la-netrc.Plo \ + ./$(DEPDIR)/libcurl_la-openldap.Plo \ + ./$(DEPDIR)/libcurl_la-parsedate.Plo \ + ./$(DEPDIR)/libcurl_la-peer.Plo \ + ./$(DEPDIR)/libcurl_la-pingpong.Plo \ + ./$(DEPDIR)/libcurl_la-pop3.Plo \ + ./$(DEPDIR)/libcurl_la-progress.Plo \ + ./$(DEPDIR)/libcurl_la-protocol.Plo \ + ./$(DEPDIR)/libcurl_la-proxy.Plo \ + ./$(DEPDIR)/libcurl_la-psl.Plo ./$(DEPDIR)/libcurl_la-rand.Plo \ + ./$(DEPDIR)/libcurl_la-ratelimit.Plo \ + ./$(DEPDIR)/libcurl_la-request.Plo \ + ./$(DEPDIR)/libcurl_la-rtsp.Plo \ + ./$(DEPDIR)/libcurl_la-select.Plo \ + ./$(DEPDIR)/libcurl_la-sendf.Plo \ + ./$(DEPDIR)/libcurl_la-setopt.Plo \ + ./$(DEPDIR)/libcurl_la-sha256.Plo \ + ./$(DEPDIR)/libcurl_la-slist.Plo \ + ./$(DEPDIR)/libcurl_la-smb.Plo ./$(DEPDIR)/libcurl_la-smtp.Plo \ + ./$(DEPDIR)/libcurl_la-socketpair.Plo \ + ./$(DEPDIR)/libcurl_la-socks.Plo \ + ./$(DEPDIR)/libcurl_la-socks_gssapi.Plo \ + ./$(DEPDIR)/libcurl_la-socks_sspi.Plo \ + ./$(DEPDIR)/libcurl_la-splay.Plo \ + ./$(DEPDIR)/libcurl_la-strcase.Plo \ + ./$(DEPDIR)/libcurl_la-strequal.Plo \ + ./$(DEPDIR)/libcurl_la-strerror.Plo \ + ./$(DEPDIR)/libcurl_la-system_win32.Plo \ + ./$(DEPDIR)/libcurl_la-telnet.Plo \ + ./$(DEPDIR)/libcurl_la-tftp.Plo \ + ./$(DEPDIR)/libcurl_la-thrdpool.Plo \ + ./$(DEPDIR)/libcurl_la-thrdqueue.Plo \ + ./$(DEPDIR)/libcurl_la-transfer.Plo \ + ./$(DEPDIR)/libcurl_la-uint-bset.Plo \ + ./$(DEPDIR)/libcurl_la-uint-hash.Plo \ + ./$(DEPDIR)/libcurl_la-uint-spbset.Plo \ + ./$(DEPDIR)/libcurl_la-uint-table.Plo \ + ./$(DEPDIR)/libcurl_la-url.Plo \ + ./$(DEPDIR)/libcurl_la-urlapi.Plo \ + ./$(DEPDIR)/libcurl_la-version.Plo \ + ./$(DEPDIR)/libcurl_la-ws.Plo \ + ./$(DEPDIR)/libcurlu_la-altsvc.Plo \ + ./$(DEPDIR)/libcurlu_la-amigaos.Plo \ + ./$(DEPDIR)/libcurlu_la-asyn-ares.Plo \ + ./$(DEPDIR)/libcurlu_la-asyn-base.Plo \ + ./$(DEPDIR)/libcurlu_la-asyn-thrdd.Plo \ + ./$(DEPDIR)/libcurlu_la-bufq.Plo \ + ./$(DEPDIR)/libcurlu_la-bufref.Plo \ + ./$(DEPDIR)/libcurlu_la-cf-dns.Plo \ + ./$(DEPDIR)/libcurlu_la-cf-h1-proxy.Plo \ + ./$(DEPDIR)/libcurlu_la-cf-h2-proxy.Plo \ + ./$(DEPDIR)/libcurlu_la-cf-haproxy.Plo \ + ./$(DEPDIR)/libcurlu_la-cf-https-connect.Plo \ + ./$(DEPDIR)/libcurlu_la-cf-ip-happy.Plo \ + ./$(DEPDIR)/libcurlu_la-cf-recvbuf.Plo \ + ./$(DEPDIR)/libcurlu_la-cf-setup.Plo \ + ./$(DEPDIR)/libcurlu_la-cf-socket.Plo \ + ./$(DEPDIR)/libcurlu_la-cfilters.Plo \ + ./$(DEPDIR)/libcurlu_la-conncache.Plo \ + ./$(DEPDIR)/libcurlu_la-connect.Plo \ + ./$(DEPDIR)/libcurlu_la-content_encoding.Plo \ + ./$(DEPDIR)/libcurlu_la-cookie.Plo \ + ./$(DEPDIR)/libcurlu_la-creds.Plo \ + ./$(DEPDIR)/libcurlu_la-cshutdn.Plo \ + ./$(DEPDIR)/libcurlu_la-curl_addrinfo.Plo \ + ./$(DEPDIR)/libcurlu_la-curl_endian.Plo \ + ./$(DEPDIR)/libcurlu_la-curl_fnmatch.Plo \ + ./$(DEPDIR)/libcurlu_la-curl_fopen.Plo \ + ./$(DEPDIR)/libcurlu_la-curl_get_line.Plo \ + ./$(DEPDIR)/libcurlu_la-curl_gethostname.Plo \ + ./$(DEPDIR)/libcurlu_la-curl_gssapi.Plo \ + ./$(DEPDIR)/libcurlu_la-curl_memrchr.Plo \ + ./$(DEPDIR)/libcurlu_la-curl_ntlm_core.Plo \ + ./$(DEPDIR)/libcurlu_la-curl_range.Plo \ + ./$(DEPDIR)/libcurlu_la-curl_sasl.Plo \ + ./$(DEPDIR)/libcurlu_la-curl_sha512_256.Plo \ + ./$(DEPDIR)/libcurlu_la-curl_share.Plo \ + ./$(DEPDIR)/libcurlu_la-curl_sspi.Plo \ + ./$(DEPDIR)/libcurlu_la-curl_threads.Plo \ + ./$(DEPDIR)/libcurlu_la-curl_trc.Plo \ + ./$(DEPDIR)/libcurlu_la-cw-out.Plo \ + ./$(DEPDIR)/libcurlu_la-cw-pause.Plo \ + ./$(DEPDIR)/libcurlu_la-dict.Plo \ + ./$(DEPDIR)/libcurlu_la-dllmain.Plo \ + ./$(DEPDIR)/libcurlu_la-dnscache.Plo \ + ./$(DEPDIR)/libcurlu_la-doh.Plo \ + ./$(DEPDIR)/libcurlu_la-dynhds.Plo \ + ./$(DEPDIR)/libcurlu_la-easy.Plo \ + ./$(DEPDIR)/libcurlu_la-easygetopt.Plo \ + ./$(DEPDIR)/libcurlu_la-easyoptions.Plo \ + ./$(DEPDIR)/libcurlu_la-escape.Plo \ + ./$(DEPDIR)/libcurlu_la-fake_addrinfo.Plo \ + ./$(DEPDIR)/libcurlu_la-file.Plo \ + ./$(DEPDIR)/libcurlu_la-fileinfo.Plo \ + ./$(DEPDIR)/libcurlu_la-formdata.Plo \ + ./$(DEPDIR)/libcurlu_la-ftp.Plo \ + ./$(DEPDIR)/libcurlu_la-ftplistparser.Plo \ + ./$(DEPDIR)/libcurlu_la-getenv.Plo \ + ./$(DEPDIR)/libcurlu_la-getinfo.Plo \ + ./$(DEPDIR)/libcurlu_la-gopher.Plo \ + ./$(DEPDIR)/libcurlu_la-hash.Plo \ + ./$(DEPDIR)/libcurlu_la-headers.Plo \ + ./$(DEPDIR)/libcurlu_la-hmac.Plo \ + ./$(DEPDIR)/libcurlu_la-hostip.Plo \ + ./$(DEPDIR)/libcurlu_la-hostip4.Plo \ + ./$(DEPDIR)/libcurlu_la-hostip6.Plo \ + ./$(DEPDIR)/libcurlu_la-hsts.Plo \ + ./$(DEPDIR)/libcurlu_la-http.Plo \ + ./$(DEPDIR)/libcurlu_la-http1.Plo \ + ./$(DEPDIR)/libcurlu_la-http2.Plo \ + ./$(DEPDIR)/libcurlu_la-http_aws_sigv4.Plo \ + ./$(DEPDIR)/libcurlu_la-http_chunks.Plo \ + ./$(DEPDIR)/libcurlu_la-http_digest.Plo \ + ./$(DEPDIR)/libcurlu_la-http_negotiate.Plo \ + ./$(DEPDIR)/libcurlu_la-http_ntlm.Plo \ + ./$(DEPDIR)/libcurlu_la-http_proxy.Plo \ + ./$(DEPDIR)/libcurlu_la-httpsrr.Plo \ + ./$(DEPDIR)/libcurlu_la-idn.Plo \ + ./$(DEPDIR)/libcurlu_la-if2ip.Plo \ + ./$(DEPDIR)/libcurlu_la-imap.Plo \ + ./$(DEPDIR)/libcurlu_la-ldap.Plo \ + ./$(DEPDIR)/libcurlu_la-libcurl_unity.Plo \ + ./$(DEPDIR)/libcurlu_la-llist.Plo \ + ./$(DEPDIR)/libcurlu_la-macos.Plo \ + ./$(DEPDIR)/libcurlu_la-md4.Plo \ + ./$(DEPDIR)/libcurlu_la-md5.Plo \ + ./$(DEPDIR)/libcurlu_la-memdebug.Plo \ + ./$(DEPDIR)/libcurlu_la-mime.Plo \ + ./$(DEPDIR)/libcurlu_la-mprintf.Plo \ + ./$(DEPDIR)/libcurlu_la-mqtt.Plo \ + ./$(DEPDIR)/libcurlu_la-multi.Plo \ + ./$(DEPDIR)/libcurlu_la-multi_ev.Plo \ + ./$(DEPDIR)/libcurlu_la-multi_ntfy.Plo \ + ./$(DEPDIR)/libcurlu_la-netrc.Plo \ + ./$(DEPDIR)/libcurlu_la-openldap.Plo \ + ./$(DEPDIR)/libcurlu_la-parsedate.Plo \ + ./$(DEPDIR)/libcurlu_la-peer.Plo \ + ./$(DEPDIR)/libcurlu_la-pingpong.Plo \ + ./$(DEPDIR)/libcurlu_la-pop3.Plo \ + ./$(DEPDIR)/libcurlu_la-progress.Plo \ + ./$(DEPDIR)/libcurlu_la-protocol.Plo \ + ./$(DEPDIR)/libcurlu_la-proxy.Plo \ + ./$(DEPDIR)/libcurlu_la-psl.Plo \ + ./$(DEPDIR)/libcurlu_la-rand.Plo \ + ./$(DEPDIR)/libcurlu_la-ratelimit.Plo \ + ./$(DEPDIR)/libcurlu_la-request.Plo \ + ./$(DEPDIR)/libcurlu_la-rtsp.Plo \ + ./$(DEPDIR)/libcurlu_la-select.Plo \ + ./$(DEPDIR)/libcurlu_la-sendf.Plo \ + ./$(DEPDIR)/libcurlu_la-setopt.Plo \ + ./$(DEPDIR)/libcurlu_la-sha256.Plo \ + ./$(DEPDIR)/libcurlu_la-slist.Plo \ + ./$(DEPDIR)/libcurlu_la-smb.Plo \ + ./$(DEPDIR)/libcurlu_la-smtp.Plo \ + ./$(DEPDIR)/libcurlu_la-socketpair.Plo \ + ./$(DEPDIR)/libcurlu_la-socks.Plo \ + ./$(DEPDIR)/libcurlu_la-socks_gssapi.Plo \ + ./$(DEPDIR)/libcurlu_la-socks_sspi.Plo \ + ./$(DEPDIR)/libcurlu_la-splay.Plo \ + ./$(DEPDIR)/libcurlu_la-strcase.Plo \ + ./$(DEPDIR)/libcurlu_la-strequal.Plo \ + ./$(DEPDIR)/libcurlu_la-strerror.Plo \ + ./$(DEPDIR)/libcurlu_la-system_win32.Plo \ + ./$(DEPDIR)/libcurlu_la-telnet.Plo \ + ./$(DEPDIR)/libcurlu_la-tftp.Plo \ + ./$(DEPDIR)/libcurlu_la-thrdpool.Plo \ + ./$(DEPDIR)/libcurlu_la-thrdqueue.Plo \ + ./$(DEPDIR)/libcurlu_la-transfer.Plo \ + ./$(DEPDIR)/libcurlu_la-uint-bset.Plo \ + ./$(DEPDIR)/libcurlu_la-uint-hash.Plo \ + ./$(DEPDIR)/libcurlu_la-uint-spbset.Plo \ + ./$(DEPDIR)/libcurlu_la-uint-table.Plo \ + ./$(DEPDIR)/libcurlu_la-url.Plo \ + ./$(DEPDIR)/libcurlu_la-urlapi.Plo \ + ./$(DEPDIR)/libcurlu_la-version.Plo \ + ./$(DEPDIR)/libcurlu_la-ws.Plo \ + curlx/$(DEPDIR)/libcurl_la-base64.Plo \ + curlx/$(DEPDIR)/libcurl_la-basename.Plo \ + curlx/$(DEPDIR)/libcurl_la-dynbuf.Plo \ + curlx/$(DEPDIR)/libcurl_la-fopen.Plo \ + curlx/$(DEPDIR)/libcurl_la-inet_ntop.Plo \ + curlx/$(DEPDIR)/libcurl_la-inet_pton.Plo \ + curlx/$(DEPDIR)/libcurl_la-multibyte.Plo \ + curlx/$(DEPDIR)/libcurl_la-nonblock.Plo \ + curlx/$(DEPDIR)/libcurl_la-snprintf.Plo \ + curlx/$(DEPDIR)/libcurl_la-strcopy.Plo \ + curlx/$(DEPDIR)/libcurl_la-strdup.Plo \ + curlx/$(DEPDIR)/libcurl_la-strerr.Plo \ + curlx/$(DEPDIR)/libcurl_la-strparse.Plo \ + curlx/$(DEPDIR)/libcurl_la-timediff.Plo \ + curlx/$(DEPDIR)/libcurl_la-timeval.Plo \ + curlx/$(DEPDIR)/libcurl_la-version_win32.Plo \ + curlx/$(DEPDIR)/libcurl_la-wait.Plo \ + curlx/$(DEPDIR)/libcurl_la-warnless.Plo \ + curlx/$(DEPDIR)/libcurl_la-winapi.Plo \ + curlx/$(DEPDIR)/libcurlu_la-base64.Plo \ + curlx/$(DEPDIR)/libcurlu_la-basename.Plo \ + curlx/$(DEPDIR)/libcurlu_la-dynbuf.Plo \ + curlx/$(DEPDIR)/libcurlu_la-fopen.Plo \ + curlx/$(DEPDIR)/libcurlu_la-inet_ntop.Plo \ + curlx/$(DEPDIR)/libcurlu_la-inet_pton.Plo \ + curlx/$(DEPDIR)/libcurlu_la-multibyte.Plo \ + curlx/$(DEPDIR)/libcurlu_la-nonblock.Plo \ + curlx/$(DEPDIR)/libcurlu_la-snprintf.Plo \ + curlx/$(DEPDIR)/libcurlu_la-strcopy.Plo \ + curlx/$(DEPDIR)/libcurlu_la-strdup.Plo \ + curlx/$(DEPDIR)/libcurlu_la-strerr.Plo \ + curlx/$(DEPDIR)/libcurlu_la-strparse.Plo \ + curlx/$(DEPDIR)/libcurlu_la-timediff.Plo \ + curlx/$(DEPDIR)/libcurlu_la-timeval.Plo \ + curlx/$(DEPDIR)/libcurlu_la-version_win32.Plo \ + curlx/$(DEPDIR)/libcurlu_la-wait.Plo \ + curlx/$(DEPDIR)/libcurlu_la-warnless.Plo \ + curlx/$(DEPDIR)/libcurlu_la-winapi.Plo \ + vauth/$(DEPDIR)/libcurl_la-cleartext.Plo \ + vauth/$(DEPDIR)/libcurl_la-cram.Plo \ + vauth/$(DEPDIR)/libcurl_la-digest.Plo \ + vauth/$(DEPDIR)/libcurl_la-digest_sspi.Plo \ + vauth/$(DEPDIR)/libcurl_la-gsasl.Plo \ + vauth/$(DEPDIR)/libcurl_la-krb5_gssapi.Plo \ + vauth/$(DEPDIR)/libcurl_la-krb5_sspi.Plo \ + vauth/$(DEPDIR)/libcurl_la-ntlm.Plo \ + vauth/$(DEPDIR)/libcurl_la-ntlm_sspi.Plo \ + vauth/$(DEPDIR)/libcurl_la-oauth2.Plo \ + vauth/$(DEPDIR)/libcurl_la-spnego_gssapi.Plo \ + vauth/$(DEPDIR)/libcurl_la-spnego_sspi.Plo \ + vauth/$(DEPDIR)/libcurl_la-vauth.Plo \ + vauth/$(DEPDIR)/libcurlu_la-cleartext.Plo \ + vauth/$(DEPDIR)/libcurlu_la-cram.Plo \ + vauth/$(DEPDIR)/libcurlu_la-digest.Plo \ + vauth/$(DEPDIR)/libcurlu_la-digest_sspi.Plo \ + vauth/$(DEPDIR)/libcurlu_la-gsasl.Plo \ + vauth/$(DEPDIR)/libcurlu_la-krb5_gssapi.Plo \ + vauth/$(DEPDIR)/libcurlu_la-krb5_sspi.Plo \ + vauth/$(DEPDIR)/libcurlu_la-ntlm.Plo \ + vauth/$(DEPDIR)/libcurlu_la-ntlm_sspi.Plo \ + vauth/$(DEPDIR)/libcurlu_la-oauth2.Plo \ + vauth/$(DEPDIR)/libcurlu_la-spnego_gssapi.Plo \ + vauth/$(DEPDIR)/libcurlu_la-spnego_sspi.Plo \ + vauth/$(DEPDIR)/libcurlu_la-vauth.Plo \ + vquic/$(DEPDIR)/libcurl_la-capsule.Plo \ + vquic/$(DEPDIR)/libcurl_la-cf-capsule.Plo \ + vquic/$(DEPDIR)/libcurl_la-cf-ngtcp2-cmn.Plo \ + vquic/$(DEPDIR)/libcurl_la-cf-ngtcp2-proxy.Plo \ + vquic/$(DEPDIR)/libcurl_la-cf-ngtcp2.Plo \ + vquic/$(DEPDIR)/libcurl_la-cf-quiche.Plo \ + vquic/$(DEPDIR)/libcurl_la-vquic-tls.Plo \ + vquic/$(DEPDIR)/libcurl_la-vquic.Plo \ + vquic/$(DEPDIR)/libcurlu_la-capsule.Plo \ + vquic/$(DEPDIR)/libcurlu_la-cf-capsule.Plo \ + vquic/$(DEPDIR)/libcurlu_la-cf-ngtcp2-cmn.Plo \ + vquic/$(DEPDIR)/libcurlu_la-cf-ngtcp2-proxy.Plo \ + vquic/$(DEPDIR)/libcurlu_la-cf-ngtcp2.Plo \ + vquic/$(DEPDIR)/libcurlu_la-cf-quiche.Plo \ + vquic/$(DEPDIR)/libcurlu_la-vquic-tls.Plo \ + vquic/$(DEPDIR)/libcurlu_la-vquic.Plo \ + vssh/$(DEPDIR)/libcurl_la-libssh.Plo \ + vssh/$(DEPDIR)/libcurl_la-libssh2.Plo \ + vssh/$(DEPDIR)/libcurl_la-vssh.Plo \ + vssh/$(DEPDIR)/libcurlu_la-libssh.Plo \ + vssh/$(DEPDIR)/libcurlu_la-libssh2.Plo \ + vssh/$(DEPDIR)/libcurlu_la-vssh.Plo \ + vtls/$(DEPDIR)/libcurl_la-apple.Plo \ + vtls/$(DEPDIR)/libcurl_la-cipher_suite.Plo \ + vtls/$(DEPDIR)/libcurl_la-gtls.Plo \ + vtls/$(DEPDIR)/libcurl_la-hostcheck.Plo \ + vtls/$(DEPDIR)/libcurl_la-keylog.Plo \ + vtls/$(DEPDIR)/libcurl_la-mbedtls.Plo \ + vtls/$(DEPDIR)/libcurl_la-openssl.Plo \ + vtls/$(DEPDIR)/libcurl_la-rustls.Plo \ + vtls/$(DEPDIR)/libcurl_la-schannel.Plo \ + vtls/$(DEPDIR)/libcurl_la-schannel_verify.Plo \ + vtls/$(DEPDIR)/libcurl_la-vtls.Plo \ + vtls/$(DEPDIR)/libcurl_la-vtls_config.Plo \ + vtls/$(DEPDIR)/libcurl_la-vtls_scache.Plo \ + vtls/$(DEPDIR)/libcurl_la-vtls_spack.Plo \ + vtls/$(DEPDIR)/libcurl_la-wolfssl.Plo \ + vtls/$(DEPDIR)/libcurl_la-x509asn1.Plo \ + vtls/$(DEPDIR)/libcurlu_la-apple.Plo \ + vtls/$(DEPDIR)/libcurlu_la-cipher_suite.Plo \ + vtls/$(DEPDIR)/libcurlu_la-gtls.Plo \ + vtls/$(DEPDIR)/libcurlu_la-hostcheck.Plo \ + vtls/$(DEPDIR)/libcurlu_la-keylog.Plo \ + vtls/$(DEPDIR)/libcurlu_la-mbedtls.Plo \ + vtls/$(DEPDIR)/libcurlu_la-openssl.Plo \ + vtls/$(DEPDIR)/libcurlu_la-rustls.Plo \ + vtls/$(DEPDIR)/libcurlu_la-schannel.Plo \ + vtls/$(DEPDIR)/libcurlu_la-schannel_verify.Plo \ + vtls/$(DEPDIR)/libcurlu_la-vtls.Plo \ + vtls/$(DEPDIR)/libcurlu_la-vtls_config.Plo \ + vtls/$(DEPDIR)/libcurlu_la-vtls_scache.Plo \ + vtls/$(DEPDIR)/libcurlu_la-vtls_spack.Plo \ + vtls/$(DEPDIR)/libcurlu_la-wolfssl.Plo \ + vtls/$(DEPDIR)/libcurlu_la-x509asn1.Plo +am__mv = mv -f +COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \ + $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) +LTCOMPILE = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ + $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) \ + $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) \ + $(AM_CFLAGS) $(CFLAGS) +AM_V_CC = $(am__v_CC_@AM_V@) +am__v_CC_ = $(am__v_CC_@AM_DEFAULT_V@) +am__v_CC_0 = @echo " CC " $@; +am__v_CC_1 = +CCLD = $(CC) +LINK = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ + $(LIBTOOLFLAGS) --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) \ + $(AM_LDFLAGS) $(LDFLAGS) -o $@ +AM_V_CCLD = $(am__v_CCLD_@AM_V@) +am__v_CCLD_ = $(am__v_CCLD_@AM_DEFAULT_V@) +am__v_CCLD_0 = @echo " CCLD " $@; +am__v_CCLD_1 = +SOURCES = $(libcurl_la_SOURCES) $(nodist_libcurl_la_SOURCES) \ + $(libcurlu_la_SOURCES) $(nodist_libcurlu_la_SOURCES) +DIST_SOURCES = $(am__libcurl_la_SOURCES_DIST) \ + $(am__libcurlu_la_SOURCES_DIST) +am__can_run_installinfo = \ + case $$AM_UPDATE_INFO_DIR in \ + n|no|NO) false;; \ + *) (install-info --version) >/dev/null 2>&1;; \ + esac +am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) $(LISP) \ + curl_config.h.in +# Read a list of newline-separated strings from the standard input, +# and print each of them once, without duplicates. Input order is +# *not* preserved. +am__uniquify_input = $(AWK) '\ + BEGIN { nonempty = 0; } \ + { items[$$0] = 1; nonempty = 1; } \ + END { if (nonempty) { for (i in items) print i; }; } \ +' +# Make sure the list of sources is unique. This is necessary because, +# e.g., the same source file might be shared among _SOURCES variables +# for different programs/libraries. +am__define_uniq_tagged_files = \ + list='$(am__tagged_files)'; \ + unique=`for i in $$list; do \ + if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ + done | $(am__uniquify_input)` +am__DIST_COMMON = $(srcdir)/Makefile.in $(srcdir)/Makefile.inc \ + $(srcdir)/Makefile.soname $(srcdir)/curl_config.h.in \ + $(srcdir)/libcurl.vers.in $(top_srcdir)/depcomp +DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) +ACLOCAL = @ACLOCAL@ +AMTAR = @AMTAR@ +AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ +APXS = @APXS@ +AR = @AR@ +AR_FLAGS = @AR_FLAGS@ +AS = @AS@ +AUTOCONF = @AUTOCONF@ +AUTOHEADER = @AUTOHEADER@ +AUTOMAKE = @AUTOMAKE@ +AWK = @AWK@ +BLANK_AT_MAKETIME = @BLANK_AT_MAKETIME@ +CADDY = @CADDY@ +CC = @CC@ +CCDEPMODE = @CCDEPMODE@ + +# This might hold -Werror +CFLAGS = @CFLAGS@ @CURL_CFLAG_EXTRAS@ +CFLAG_CURL_SYMBOL_HIDING = @CFLAG_CURL_SYMBOL_HIDING@ +CLANG_TIDY = @CLANG_TIDY@ +CONFIGURE_OPTIONS = @CONFIGURE_OPTIONS@ +CPP = @CPP@ +CPPFLAGS = @CPPFLAGS@ +CSCOPE = @CSCOPE@ +CTAGS = @CTAGS@ +CURLVERSION = @CURLVERSION@ +CURL_CA_BUNDLE = @CURL_CA_BUNDLE@ +CURL_CA_EMBED = @CURL_CA_EMBED@ +CURL_CFLAG_EXTRAS = @CURL_CFLAG_EXTRAS@ +CURL_CPP = @CURL_CPP@ +CURL_LIBCURL_VERSIONED_SYMBOLS_PREFIX = @CURL_LIBCURL_VERSIONED_SYMBOLS_PREFIX@ +CURL_LIBCURL_VERSIONED_SYMBOLS_SONAME = @CURL_LIBCURL_VERSIONED_SYMBOLS_SONAME@ +CURL_NETWORK_AND_TIME_LIBS = @CURL_NETWORK_AND_TIME_LIBS@ +CYGPATH_W = @CYGPATH_W@ +DANTED = @DANTED@ +DEFS = @DEFS@ +DEPDIR = @DEPDIR@ +DLLTOOL = @DLLTOOL@ +DSYMUTIL = @DSYMUTIL@ +DUMPBIN = @DUMPBIN@ +ECHO_C = @ECHO_C@ +ECHO_N = @ECHO_N@ +ECHO_T = @ECHO_T@ +EGREP = @EGREP@ +ENABLE_SHARED = @ENABLE_SHARED@ +ENABLE_STATIC = @ENABLE_STATIC@ +ETAGS = @ETAGS@ +EXEEXT = @EXEEXT@ +FGREP = @FGREP@ +FILECMD = @FILECMD@ +FISH_FUNCTIONS_DIR = @FISH_FUNCTIONS_DIR@ +GCOV = @GCOV@ +GREP = @GREP@ +H2O = @H2O@ +HAVE_LIBZ = @HAVE_LIBZ@ +HTTPD = @HTTPD@ +HTTPD_NGHTTPX = @HTTPD_NGHTTPX@ +INSTALL = @INSTALL@ +INSTALL_DATA = @INSTALL_DATA@ +INSTALL_PROGRAM = @INSTALL_PROGRAM@ +INSTALL_SCRIPT = @INSTALL_SCRIPT@ +INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ +LCOV = @LCOV@ +LD = @LD@ +LDFLAGS = @LDFLAGS@ +LIBCURL_PC_CFLAGS = @LIBCURL_PC_CFLAGS@ +LIBCURL_PC_CFLAGS_PRIVATE = @LIBCURL_PC_CFLAGS_PRIVATE@ +LIBCURL_PC_LDFLAGS_PRIVATE = @LIBCURL_PC_LDFLAGS_PRIVATE@ +LIBCURL_PC_LIBS = @LIBCURL_PC_LIBS@ +LIBCURL_PC_LIBS_PRIVATE = @LIBCURL_PC_LIBS_PRIVATE@ +LIBCURL_PC_REQUIRES = @LIBCURL_PC_REQUIRES@ +LIBCURL_PC_REQUIRES_PRIVATE = @LIBCURL_PC_REQUIRES_PRIVATE@ +LIBOBJS = @LIBOBJS@ + +# Prevent LIBS from being used for all link targets +LIBS = $(BLANK_AT_MAKETIME) +LIBTOOL = @LIBTOOL@ +LIPO = @LIPO@ +LN_S = @LN_S@ +LTLIBOBJS = @LTLIBOBJS@ +LT_SYS_LIBRARY_PATH = @LT_SYS_LIBRARY_PATH@ +MAINT = @MAINT@ +MAKEINFO = @MAKEINFO@ +MANIFEST_TOOL = @MANIFEST_TOOL@ +MKDIR_P = @MKDIR_P@ +NM = @NM@ +NMEDIT = @NMEDIT@ +OBJDUMP = @OBJDUMP@ +OBJEXT = @OBJEXT@ +OTOOL = @OTOOL@ +OTOOL64 = @OTOOL64@ +PACKAGE = @PACKAGE@ +PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ +PACKAGE_NAME = @PACKAGE_NAME@ +PACKAGE_STRING = @PACKAGE_STRING@ +PACKAGE_TARNAME = @PACKAGE_TARNAME@ +PACKAGE_URL = @PACKAGE_URL@ +PACKAGE_VERSION = @PACKAGE_VERSION@ +PATH_SEPARATOR = @PATH_SEPARATOR@ +PERL = @PERL@ +PKGCONFIG = @PKGCONFIG@ +RANLIB = @RANLIB@ +RC = @RC@ +SED = @SED@ +SET_MAKE = @SET_MAKE@ +SFTPD = @SFTPD@ +SHELL = @SHELL@ +SSHD = @SSHD@ +SSL_BACKENDS = @SSL_BACKENDS@ +STRIP = @STRIP@ +SUPPORT_FEATURES = @SUPPORT_FEATURES@ +SUPPORT_PROTOCOLS = @SUPPORT_PROTOCOLS@ +TEST_NGHTTPX = @TEST_NGHTTPX@ +VERSION = @VERSION@ +VERSIONNUM = @VERSIONNUM@ +VSFTPD = @VSFTPD@ +ZLIB_LIBS = @ZLIB_LIBS@ +ZSH_FUNCTIONS_DIR = @ZSH_FUNCTIONS_DIR@ +abs_builddir = @abs_builddir@ +abs_srcdir = @abs_srcdir@ +abs_top_builddir = @abs_top_builddir@ +abs_top_srcdir = @abs_top_srcdir@ +ac_ct_AR = @ac_ct_AR@ +ac_ct_CC = @ac_ct_CC@ +ac_ct_DUMPBIN = @ac_ct_DUMPBIN@ +am__include = @am__include@ +am__leading_dot = @am__leading_dot@ +am__quote = @am__quote@ +am__tar = @am__tar@ +am__untar = @am__untar@ +bindir = @bindir@ +build = @build@ +build_alias = @build_alias@ +build_cpu = @build_cpu@ +build_os = @build_os@ +build_vendor = @build_vendor@ +builddir = @builddir@ +datadir = @datadir@ +datarootdir = @datarootdir@ +docdir = @docdir@ +dvidir = @dvidir@ +exec_prefix = @exec_prefix@ +host = @host@ +host_alias = @host_alias@ +host_cpu = @host_cpu@ +host_os = @host_os@ +host_vendor = @host_vendor@ +htmldir = @htmldir@ +includedir = @includedir@ +infodir = @infodir@ +install_sh = @install_sh@ +libdir = @libdir@ +libexecdir = @libexecdir@ +libext = @libext@ +localedir = @localedir@ +localstatedir = @localstatedir@ +mandir = @mandir@ +mkdir_p = @mkdir_p@ +oldincludedir = @oldincludedir@ +pdfdir = @pdfdir@ +prefix = @prefix@ +program_transform_name = @program_transform_name@ +psdir = @psdir@ +runstatedir = @runstatedir@ +sbindir = @sbindir@ +sharedstatedir = @sharedstatedir@ +srcdir = @srcdir@ +sysconfdir = @sysconfdir@ +target_alias = @target_alias@ +top_build_prefix = @top_build_prefix@ +top_builddir = @top_builddir@ +top_srcdir = @top_srcdir@ + +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +AUTOMAKE_OPTIONS = foreign nostdinc +LIB_CURLX_CFILES = \ + curlx/base64.c \ + curlx/basename.c \ + curlx/dynbuf.c \ + curlx/fopen.c \ + curlx/inet_ntop.c \ + curlx/inet_pton.c \ + curlx/multibyte.c \ + curlx/nonblock.c \ + curlx/snprintf.c \ + curlx/strcopy.c \ + curlx/strdup.c \ + curlx/strerr.c \ + curlx/strparse.c \ + curlx/timediff.c \ + curlx/timeval.c \ + curlx/version_win32.c \ + curlx/wait.c \ + curlx/warnless.c \ + curlx/winapi.c + +LIB_CURLX_HFILES = \ + curlx/base64.h \ + curlx/basename.h \ + curlx/dynbuf.h \ + curlx/fopen.h \ + curlx/inet_ntop.h \ + curlx/inet_pton.h \ + curlx/multibyte.h \ + curlx/nonblock.h \ + curlx/snprintf.h \ + curlx/strcopy.h \ + curlx/strdup.h \ + curlx/strerr.h \ + curlx/strparse.h \ + curlx/timediff.h \ + curlx/timeval.h \ + curlx/version_win32.h \ + curlx/wait.h \ + curlx/warnless.h \ + curlx/winapi.h + +LIB_VAUTH_CFILES = \ + vauth/cleartext.c \ + vauth/cram.c \ + vauth/digest.c \ + vauth/digest_sspi.c \ + vauth/gsasl.c \ + vauth/krb5_gssapi.c \ + vauth/krb5_sspi.c \ + vauth/ntlm.c \ + vauth/ntlm_sspi.c \ + vauth/oauth2.c \ + vauth/spnego_gssapi.c \ + vauth/spnego_sspi.c \ + vauth/vauth.c + +LIB_VAUTH_HFILES = \ + vauth/digest.h \ + vauth/vauth.h + +LIB_VTLS_CFILES = \ + vtls/apple.c \ + vtls/cipher_suite.c \ + vtls/gtls.c \ + vtls/hostcheck.c \ + vtls/keylog.c \ + vtls/mbedtls.c \ + vtls/openssl.c \ + vtls/rustls.c \ + vtls/schannel.c \ + vtls/schannel_verify.c \ + vtls/vtls.c \ + vtls/vtls_config.c \ + vtls/vtls_scache.c \ + vtls/vtls_spack.c \ + vtls/wolfssl.c \ + vtls/x509asn1.c + +LIB_VTLS_HFILES = \ + vtls/apple.h \ + vtls/cipher_suite.h \ + vtls/gtls.h \ + vtls/hostcheck.h \ + vtls/keylog.h \ + vtls/mbedtls.h \ + vtls/openssl.h \ + vtls/rustls.h \ + vtls/schannel.h \ + vtls/schannel_int.h \ + vtls/vtls.h \ + vtls/vtls_config.h \ + vtls/vtls_int.h \ + vtls/vtls_scache.h \ + vtls/vtls_spack.h \ + vtls/wolfssl.h \ + vtls/x509asn1.h + +LIB_VQUIC_CFILES = \ + vquic/capsule.c \ + vquic/cf-capsule.c \ + vquic/cf-ngtcp2.c \ + vquic/cf-ngtcp2-cmn.c \ + vquic/cf-ngtcp2-proxy.c \ + vquic/cf-quiche.c \ + vquic/vquic.c \ + vquic/vquic-tls.c + +LIB_VQUIC_HFILES = \ + vquic/capsule.h \ + vquic/cf-capsule.h \ + vquic/cf-ngtcp2.h \ + vquic/cf-ngtcp2-cmn.h \ + vquic/cf-ngtcp2-proxy.h \ + vquic/cf-quiche.h \ + vquic/vquic.h \ + vquic/vquic_int.h \ + vquic/vquic-tls.h + +LIB_VSSH_CFILES = \ + vssh/libssh.c \ + vssh/libssh2.c \ + vssh/vssh.c + +LIB_VSSH_HFILES = \ + vssh/vssh.h \ + vssh/ssh.h + +LIB_CFILES = \ + altsvc.c \ + amigaos.c \ + asyn-ares.c \ + asyn-base.c \ + asyn-thrdd.c \ + bufq.c \ + bufref.c \ + cf-dns.c \ + cf-h1-proxy.c \ + cf-h2-proxy.c \ + cf-haproxy.c \ + cf-https-connect.c \ + cf-ip-happy.c \ + cf-recvbuf.c \ + cf-setup.c \ + cf-socket.c \ + cfilters.c \ + conncache.c \ + connect.c \ + content_encoding.c \ + cookie.c \ + creds.c \ + cshutdn.c \ + curl_addrinfo.c \ + curl_endian.c \ + curl_fnmatch.c \ + curl_fopen.c \ + curl_get_line.c \ + curl_gethostname.c \ + curl_gssapi.c \ + curl_memrchr.c \ + curl_ntlm_core.c \ + curl_range.c \ + curl_sasl.c \ + curl_sha512_256.c \ + curl_share.c \ + curl_sspi.c \ + curl_threads.c \ + curl_trc.c \ + cw-out.c \ + cw-pause.c \ + dict.c \ + dnscache.c \ + doh.c \ + dynhds.c \ + easy.c \ + easygetopt.c \ + easyoptions.c \ + escape.c \ + fake_addrinfo.c \ + file.c \ + fileinfo.c \ + formdata.c \ + ftp.c \ + ftplistparser.c \ + getenv.c \ + getinfo.c \ + gopher.c \ + hash.c \ + headers.c \ + hmac.c \ + hostip.c \ + hostip4.c \ + hostip6.c \ + hsts.c \ + http.c \ + http1.c \ + http2.c \ + http_aws_sigv4.c \ + http_chunks.c \ + http_digest.c \ + http_negotiate.c \ + http_ntlm.c \ + http_proxy.c \ + httpsrr.c \ + idn.c \ + if2ip.c \ + imap.c \ + ldap.c \ + llist.c \ + macos.c \ + md4.c \ + md5.c \ + memdebug.c \ + mime.c \ + mprintf.c \ + mqtt.c \ + multi.c \ + multi_ev.c \ + multi_ntfy.c \ + netrc.c \ + openldap.c \ + parsedate.c \ + peer.c \ + pingpong.c \ + pop3.c \ + progress.c \ + protocol.c \ + proxy.c \ + psl.c \ + rand.c \ + ratelimit.c \ + request.c \ + rtsp.c \ + select.c \ + sendf.c \ + setopt.c \ + sha256.c \ + slist.c \ + smb.c \ + smtp.c \ + socketpair.c \ + socks.c \ + socks_gssapi.c \ + socks_sspi.c \ + splay.c \ + strcase.c \ + strequal.c \ + strerror.c \ + system_win32.c \ + telnet.c \ + tftp.c \ + thrdpool.c \ + thrdqueue.c \ + transfer.c \ + uint-bset.c \ + uint-hash.c \ + uint-spbset.c \ + uint-table.c \ + url.c \ + urlapi.c \ + version.c \ + ws.c + +LIB_HFILES = \ + altsvc.h \ + amigaos.h \ + arpa_telnet.h \ + asyn.h \ + bufq.h \ + bufref.h \ + cf-dns.h \ + cf-h1-proxy.h \ + cf-h2-proxy.h \ + cf-haproxy.h \ + cf-https-connect.h \ + cf-ip-happy.h \ + cf-recvbuf.h \ + cf-setup.h \ + cf-socket.h \ + cfilters.h \ + conncache.h \ + cshutdn.h \ + connect.h \ + content_encoding.h \ + cookie.h \ + creds.h \ + curl_addrinfo.h \ + curl_ctype.h \ + curl_endian.h \ + curl_fnmatch.h \ + curl_fopen.h \ + curl_get_line.h \ + curl_gethostname.h \ + curl_gssapi.h \ + curl_hmac.h \ + curl_ldap.h \ + curl_md4.h \ + curl_md5.h \ + curl_memrchr.h \ + curl_ntlm_core.h \ + curl_printf.h \ + curl_range.h \ + curl_sasl.h \ + curl_setup.h \ + curl_sha256.h \ + curl_sha512_256.h \ + curl_share.h \ + curl_sspi.h \ + curl_threads.h \ + curl_trc.h \ + cw-out.h \ + cw-pause.h \ + dict.h \ + dnscache.h \ + doh.h \ + dynhds.h \ + easy_lock.h \ + easyif.h \ + easyoptions.h \ + escape.h \ + fake_addrinfo.h \ + file.h \ + fileinfo.h \ + formdata.h \ + ftp.h \ + ftp-int.h \ + ftplistparser.h \ + functypes.h \ + getinfo.h \ + gopher.h \ + hash.h \ + headers.h \ + hostip.h \ + hsts.h \ + http.h \ + http1.h \ + http2.h \ + http_aws_sigv4.h \ + http_chunks.h \ + http_digest.h \ + http_negotiate.h \ + http_ntlm.h \ + http_proxy.h \ + httpsrr.h \ + idn.h \ + if2ip.h \ + imap.h \ + llist.h \ + macos.h \ + mime.h \ + mqtt.h \ + multihandle.h \ + multi_ev.h \ + multi_ntfy.h \ + multiif.h \ + netrc.h \ + parsedate.h \ + peer.h \ + pingpong.h \ + pop3.h \ + progress.h \ + protocol.h \ + proxy.h \ + psl.h \ + rand.h \ + ratelimit.h \ + request.h \ + rtsp.h \ + select.h \ + sendf.h \ + setopt.h \ + setup-os400.h \ + setup-vms.h \ + setup-win32.h \ + sigpipe.h \ + slist.h \ + smb.h \ + smtp.h \ + sockaddr.h \ + socketpair.h \ + socks.h \ + splay.h \ + strcase.h \ + strerror.h \ + system_win32.h \ + telnet.h \ + tftp.h \ + thrdpool.h \ + thrdqueue.h \ + transfer.h \ + uint-bset.h \ + uint-hash.h \ + uint-spbset.h \ + uint-table.h \ + url.h \ + urlapi-int.h \ + urldata.h \ + ws.h + +LIB_RCFILES = libcurl.rc +CSOURCES = $(LIB_CFILES) $(LIB_VAUTH_CFILES) $(LIB_VTLS_CFILES) \ + $(LIB_VQUIC_CFILES) $(LIB_VSSH_CFILES) $(LIB_CURLX_CFILES) \ + $(am__append_2) +HHEADERS = $(LIB_HFILES) $(LIB_VAUTH_HFILES) $(LIB_VTLS_HFILES) \ + $(LIB_VQUIC_HFILES) $(LIB_VSSH_HFILES) $(LIB_CURLX_HFILES) + + +# Get CSOURCES, HHEADERS, LIB_RCFILES variables +CMAKE_DIST = CMakeLists.txt curl_config-cmake.h.in +EXTRA_DIST = config-mac.h config-os400.h config-riscos.h config-win32.h \ + curl_config.h.in $(LIB_RCFILES) libcurl.def $(CMAKE_DIST) Makefile.soname \ + optiontable.pl + +lib_LTLIBRARIES = libcurl.la +@BUILD_UNITTESTS_FALSE@noinst_LTLIBRARIES = +@BUILD_UNITTESTS_TRUE@noinst_LTLIBRARIES = libcurlu.la + +# generate a file with "private" prototypes for unit testing +@BUILD_UNITTESTS_TRUE@UNITPROTOS = unitprotos.h + +# Specify our include paths here, and do it relative to $(top_srcdir) and +# $(top_builddir), to ensure that these paths which belong to the library +# being currently built and tested are searched before the library which +# might possibly already be installed in the system. +# +# $(top_srcdir)/include is for libcurl's external include files +# $(top_builddir)/lib is for libcurl's generated lib/curl_config.h file +# $(srcdir) for the generated unity source to find included sources +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_builddir)/lib \ + -I$(top_srcdir)/lib -I$(srcdir) $(am__append_1) \ + -DBUILDING_LIBCURL +@USE_UNITY_TRUE@nodist_libcurl_la_SOURCES = libcurl_unity.c +@USE_UNITY_FALSE@libcurl_la_SOURCES = $(CSOURCES) $(HHEADERS) \ +@USE_UNITY_FALSE@ $(am__append_9) +@USE_UNITY_TRUE@libcurl_la_SOURCES = $(am__append_9) +@USE_UNITY_TRUE@nodist_libcurlu_la_SOURCES = libcurl_unity.c +@USE_UNITY_FALSE@libcurlu_la_SOURCES = $(CSOURCES) $(HHEADERS) +@USE_UNITY_TRUE@libcurlu_la_SOURCES = +@USE_UNITY_FALSE@CLEANFILES = $(UNITPROTOS) +@USE_UNITY_TRUE@CLEANFILES = libcurl_unity.c $(UNITPROTOS) +libcurl_la_CPPFLAGS_EXTRA = $(am__append_8) $(am__append_10) +libcurl_la_LDFLAGS_EXTRA = $(am__append_3) $(am__append_4) \ + $(am__append_5) $(am__append_6) $(am__append_7) +libcurl_la_CFLAGS_EXTRA = $(am__append_11) + +# Keep in sync with CURL_LIBCURL_VERSIONED_SYMBOLS_SONAME in configure.ac +@CURL_LT_SHLIB_USE_VERSION_INFO_TRUE@VERSIONCHANGE = 12 +@CURL_LT_SHLIB_USE_VERSION_INFO_TRUE@VERSIONADD = 0 +@CURL_LT_SHLIB_USE_VERSION_INFO_TRUE@VERSIONDEL = 8 + +# libtool version: +@CURL_LT_SHLIB_USE_VERSION_INFO_TRUE@VERSIONINFO = -version-info $(VERSIONCHANGE):$(VERSIONADD):$(VERSIONDEL) +libcurl_la_CPPFLAGS = $(AM_CPPFLAGS) $(libcurl_la_CPPFLAGS_EXTRA) +libcurl_la_LDFLAGS = $(libcurl_la_LDFLAGS_EXTRA) $(CURL_LDFLAGS_LIB) $(LIBCURL_PC_LIBS_PRIVATE) +libcurl_la_CFLAGS = $(libcurl_la_CFLAGS_EXTRA) +libcurlu_la_CPPFLAGS = $(AM_CPPFLAGS) -DCURL_STATICLIB -DUNITTESTS +libcurlu_la_LDFLAGS = -static $(LIBCURL_PC_LIBS_PRIVATE) +CHECKSRC = $(CS_$(V)) +CS_0 = @echo " RUN " $@; +CS_1 = +CS_ = $(CS_0) + +# for debug builds, we scan the sources on all regular make invokes +@DEBUGBUILD_TRUE@@NOT_CURL_CI_TRUE@CHECKSOURCES = checksrc +UNIT_V = $(UNITV_$(V)) +UNITV_0 = @echo " UNITPR " $@; +UNITV_1 = +UNITV_ = $(UNITV_0) +_tidy_cflags = $(am__append_13) +TIDYFLAGS = $(am__append_12) +all: curl_config.h + $(MAKE) $(AM_MAKEFLAGS) all-am + +.SUFFIXES: +.SUFFIXES: .c .lo .o .obj .rc +$(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(srcdir)/Makefile.inc $(srcdir)/Makefile.soname $(am__configure_deps) + @for dep in $?; do \ + case '$(am__configure_deps)' in \ + *$$dep*) \ + ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \ + && { if test -f $@; then exit 0; else break; fi; }; \ + exit 1;; \ + esac; \ + done; \ + echo ' cd $(top_srcdir) && $(AUTOMAKE) --foreign lib/Makefile'; \ + $(am__cd) $(top_srcdir) && \ + $(AUTOMAKE) --foreign lib/Makefile +Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status + @case '$?' in \ + *config.status*) \ + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ + *) \ + echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__maybe_remake_depfiles)'; \ + cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__maybe_remake_depfiles);; \ + esac; +$(srcdir)/Makefile.inc $(srcdir)/Makefile.soname $(am__empty): + +$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh + +$(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh +$(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh +$(am__aclocal_m4_deps): + +curl_config.h: stamp-h1 + @test -f $@ || rm -f stamp-h1 + @test -f $@ || $(MAKE) $(AM_MAKEFLAGS) stamp-h1 + +stamp-h1: $(srcdir)/curl_config.h.in $(top_builddir)/config.status + @rm -f stamp-h1 + cd $(top_builddir) && $(SHELL) ./config.status lib/curl_config.h +$(srcdir)/curl_config.h.in: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) + ($(am__cd) $(top_srcdir) && $(AUTOHEADER)) + rm -f stamp-h1 + touch $@ + +distclean-hdr: + -rm -f curl_config.h stamp-h1 +libcurl.vers: $(top_builddir)/config.status $(srcdir)/libcurl.vers.in + cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ + +install-libLTLIBRARIES: $(lib_LTLIBRARIES) + @$(NORMAL_INSTALL) + @list='$(lib_LTLIBRARIES)'; test -n "$(libdir)" || list=; \ + list2=; for p in $$list; do \ + if test -f $$p; then \ + list2="$$list2 $$p"; \ + else :; fi; \ + done; \ + test -z "$$list2" || { \ + echo " $(MKDIR_P) '$(DESTDIR)$(libdir)'"; \ + $(MKDIR_P) "$(DESTDIR)$(libdir)" || exit 1; \ + echo " $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(INSTALL) $(INSTALL_STRIP_FLAG) $$list2 '$(DESTDIR)$(libdir)'"; \ + $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(INSTALL) $(INSTALL_STRIP_FLAG) $$list2 "$(DESTDIR)$(libdir)"; \ + } + +uninstall-libLTLIBRARIES: + @$(NORMAL_UNINSTALL) + @list='$(lib_LTLIBRARIES)'; test -n "$(libdir)" || list=; \ + for p in $$list; do \ + $(am__strip_dir) \ + echo " $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=uninstall rm -f '$(DESTDIR)$(libdir)/$$f'"; \ + $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=uninstall rm -f "$(DESTDIR)$(libdir)/$$f"; \ + done + +clean-libLTLIBRARIES: + -test -z "$(lib_LTLIBRARIES)" || rm -f $(lib_LTLIBRARIES) + @list='$(lib_LTLIBRARIES)'; \ + locs=`for p in $$list; do echo $$p; done | \ + sed 's|^[^/]*$$|.|; s|/[^/]*$$||; s|$$|/so_locations|' | \ + sort -u`; \ + test -z "$$locs" || { \ + echo rm -f $${locs}; \ + rm -f $${locs}; \ + } + +clean-noinstLTLIBRARIES: + -test -z "$(noinst_LTLIBRARIES)" || rm -f $(noinst_LTLIBRARIES) + @list='$(noinst_LTLIBRARIES)'; \ + locs=`for p in $$list; do echo $$p; done | \ + sed 's|^[^/]*$$|.|; s|/[^/]*$$||; s|$$|/so_locations|' | \ + sort -u`; \ + test -z "$$locs" || { \ + echo rm -f $${locs}; \ + rm -f $${locs}; \ + } +vauth/$(am__dirstamp): + @$(MKDIR_P) vauth + @: > vauth/$(am__dirstamp) +vauth/$(DEPDIR)/$(am__dirstamp): + @$(MKDIR_P) vauth/$(DEPDIR) + @: > vauth/$(DEPDIR)/$(am__dirstamp) +vauth/libcurl_la-cleartext.lo: vauth/$(am__dirstamp) \ + vauth/$(DEPDIR)/$(am__dirstamp) +vauth/libcurl_la-cram.lo: vauth/$(am__dirstamp) \ + vauth/$(DEPDIR)/$(am__dirstamp) +vauth/libcurl_la-digest.lo: vauth/$(am__dirstamp) \ + vauth/$(DEPDIR)/$(am__dirstamp) +vauth/libcurl_la-digest_sspi.lo: vauth/$(am__dirstamp) \ + vauth/$(DEPDIR)/$(am__dirstamp) +vauth/libcurl_la-gsasl.lo: vauth/$(am__dirstamp) \ + vauth/$(DEPDIR)/$(am__dirstamp) +vauth/libcurl_la-krb5_gssapi.lo: vauth/$(am__dirstamp) \ + vauth/$(DEPDIR)/$(am__dirstamp) +vauth/libcurl_la-krb5_sspi.lo: vauth/$(am__dirstamp) \ + vauth/$(DEPDIR)/$(am__dirstamp) +vauth/libcurl_la-ntlm.lo: vauth/$(am__dirstamp) \ + vauth/$(DEPDIR)/$(am__dirstamp) +vauth/libcurl_la-ntlm_sspi.lo: vauth/$(am__dirstamp) \ + vauth/$(DEPDIR)/$(am__dirstamp) +vauth/libcurl_la-oauth2.lo: vauth/$(am__dirstamp) \ + vauth/$(DEPDIR)/$(am__dirstamp) +vauth/libcurl_la-spnego_gssapi.lo: vauth/$(am__dirstamp) \ + vauth/$(DEPDIR)/$(am__dirstamp) +vauth/libcurl_la-spnego_sspi.lo: vauth/$(am__dirstamp) \ + vauth/$(DEPDIR)/$(am__dirstamp) +vauth/libcurl_la-vauth.lo: vauth/$(am__dirstamp) \ + vauth/$(DEPDIR)/$(am__dirstamp) +vtls/$(am__dirstamp): + @$(MKDIR_P) vtls + @: > vtls/$(am__dirstamp) +vtls/$(DEPDIR)/$(am__dirstamp): + @$(MKDIR_P) vtls/$(DEPDIR) + @: > vtls/$(DEPDIR)/$(am__dirstamp) +vtls/libcurl_la-apple.lo: vtls/$(am__dirstamp) \ + vtls/$(DEPDIR)/$(am__dirstamp) +vtls/libcurl_la-cipher_suite.lo: vtls/$(am__dirstamp) \ + vtls/$(DEPDIR)/$(am__dirstamp) +vtls/libcurl_la-gtls.lo: vtls/$(am__dirstamp) \ + vtls/$(DEPDIR)/$(am__dirstamp) +vtls/libcurl_la-hostcheck.lo: vtls/$(am__dirstamp) \ + vtls/$(DEPDIR)/$(am__dirstamp) +vtls/libcurl_la-keylog.lo: vtls/$(am__dirstamp) \ + vtls/$(DEPDIR)/$(am__dirstamp) +vtls/libcurl_la-mbedtls.lo: vtls/$(am__dirstamp) \ + vtls/$(DEPDIR)/$(am__dirstamp) +vtls/libcurl_la-openssl.lo: vtls/$(am__dirstamp) \ + vtls/$(DEPDIR)/$(am__dirstamp) +vtls/libcurl_la-rustls.lo: vtls/$(am__dirstamp) \ + vtls/$(DEPDIR)/$(am__dirstamp) +vtls/libcurl_la-schannel.lo: vtls/$(am__dirstamp) \ + vtls/$(DEPDIR)/$(am__dirstamp) +vtls/libcurl_la-schannel_verify.lo: vtls/$(am__dirstamp) \ + vtls/$(DEPDIR)/$(am__dirstamp) +vtls/libcurl_la-vtls.lo: vtls/$(am__dirstamp) \ + vtls/$(DEPDIR)/$(am__dirstamp) +vtls/libcurl_la-vtls_config.lo: vtls/$(am__dirstamp) \ + vtls/$(DEPDIR)/$(am__dirstamp) +vtls/libcurl_la-vtls_scache.lo: vtls/$(am__dirstamp) \ + vtls/$(DEPDIR)/$(am__dirstamp) +vtls/libcurl_la-vtls_spack.lo: vtls/$(am__dirstamp) \ + vtls/$(DEPDIR)/$(am__dirstamp) +vtls/libcurl_la-wolfssl.lo: vtls/$(am__dirstamp) \ + vtls/$(DEPDIR)/$(am__dirstamp) +vtls/libcurl_la-x509asn1.lo: vtls/$(am__dirstamp) \ + vtls/$(DEPDIR)/$(am__dirstamp) +vquic/$(am__dirstamp): + @$(MKDIR_P) vquic + @: > vquic/$(am__dirstamp) +vquic/$(DEPDIR)/$(am__dirstamp): + @$(MKDIR_P) vquic/$(DEPDIR) + @: > vquic/$(DEPDIR)/$(am__dirstamp) +vquic/libcurl_la-capsule.lo: vquic/$(am__dirstamp) \ + vquic/$(DEPDIR)/$(am__dirstamp) +vquic/libcurl_la-cf-capsule.lo: vquic/$(am__dirstamp) \ + vquic/$(DEPDIR)/$(am__dirstamp) +vquic/libcurl_la-cf-ngtcp2.lo: vquic/$(am__dirstamp) \ + vquic/$(DEPDIR)/$(am__dirstamp) +vquic/libcurl_la-cf-ngtcp2-cmn.lo: vquic/$(am__dirstamp) \ + vquic/$(DEPDIR)/$(am__dirstamp) +vquic/libcurl_la-cf-ngtcp2-proxy.lo: vquic/$(am__dirstamp) \ + vquic/$(DEPDIR)/$(am__dirstamp) +vquic/libcurl_la-cf-quiche.lo: vquic/$(am__dirstamp) \ + vquic/$(DEPDIR)/$(am__dirstamp) +vquic/libcurl_la-vquic.lo: vquic/$(am__dirstamp) \ + vquic/$(DEPDIR)/$(am__dirstamp) +vquic/libcurl_la-vquic-tls.lo: vquic/$(am__dirstamp) \ + vquic/$(DEPDIR)/$(am__dirstamp) +vssh/$(am__dirstamp): + @$(MKDIR_P) vssh + @: > vssh/$(am__dirstamp) +vssh/$(DEPDIR)/$(am__dirstamp): + @$(MKDIR_P) vssh/$(DEPDIR) + @: > vssh/$(DEPDIR)/$(am__dirstamp) +vssh/libcurl_la-libssh.lo: vssh/$(am__dirstamp) \ + vssh/$(DEPDIR)/$(am__dirstamp) +vssh/libcurl_la-libssh2.lo: vssh/$(am__dirstamp) \ + vssh/$(DEPDIR)/$(am__dirstamp) +vssh/libcurl_la-vssh.lo: vssh/$(am__dirstamp) \ + vssh/$(DEPDIR)/$(am__dirstamp) +curlx/$(am__dirstamp): + @$(MKDIR_P) curlx + @: > curlx/$(am__dirstamp) +curlx/$(DEPDIR)/$(am__dirstamp): + @$(MKDIR_P) curlx/$(DEPDIR) + @: > curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurl_la-base64.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurl_la-basename.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurl_la-dynbuf.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurl_la-fopen.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurl_la-inet_ntop.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurl_la-inet_pton.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurl_la-multibyte.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurl_la-nonblock.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurl_la-snprintf.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurl_la-strcopy.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurl_la-strdup.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurl_la-strerr.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurl_la-strparse.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurl_la-timediff.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurl_la-timeval.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurl_la-version_win32.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurl_la-wait.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurl_la-warnless.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurl_la-winapi.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) + +libcurl.la: $(libcurl_la_OBJECTS) $(libcurl_la_DEPENDENCIES) $(EXTRA_libcurl_la_DEPENDENCIES) + $(AM_V_CCLD)$(libcurl_la_LINK) -rpath $(libdir) $(libcurl_la_OBJECTS) $(libcurl_la_LIBADD) $(LIBS) +vauth/libcurlu_la-cleartext.lo: vauth/$(am__dirstamp) \ + vauth/$(DEPDIR)/$(am__dirstamp) +vauth/libcurlu_la-cram.lo: vauth/$(am__dirstamp) \ + vauth/$(DEPDIR)/$(am__dirstamp) +vauth/libcurlu_la-digest.lo: vauth/$(am__dirstamp) \ + vauth/$(DEPDIR)/$(am__dirstamp) +vauth/libcurlu_la-digest_sspi.lo: vauth/$(am__dirstamp) \ + vauth/$(DEPDIR)/$(am__dirstamp) +vauth/libcurlu_la-gsasl.lo: vauth/$(am__dirstamp) \ + vauth/$(DEPDIR)/$(am__dirstamp) +vauth/libcurlu_la-krb5_gssapi.lo: vauth/$(am__dirstamp) \ + vauth/$(DEPDIR)/$(am__dirstamp) +vauth/libcurlu_la-krb5_sspi.lo: vauth/$(am__dirstamp) \ + vauth/$(DEPDIR)/$(am__dirstamp) +vauth/libcurlu_la-ntlm.lo: vauth/$(am__dirstamp) \ + vauth/$(DEPDIR)/$(am__dirstamp) +vauth/libcurlu_la-ntlm_sspi.lo: vauth/$(am__dirstamp) \ + vauth/$(DEPDIR)/$(am__dirstamp) +vauth/libcurlu_la-oauth2.lo: vauth/$(am__dirstamp) \ + vauth/$(DEPDIR)/$(am__dirstamp) +vauth/libcurlu_la-spnego_gssapi.lo: vauth/$(am__dirstamp) \ + vauth/$(DEPDIR)/$(am__dirstamp) +vauth/libcurlu_la-spnego_sspi.lo: vauth/$(am__dirstamp) \ + vauth/$(DEPDIR)/$(am__dirstamp) +vauth/libcurlu_la-vauth.lo: vauth/$(am__dirstamp) \ + vauth/$(DEPDIR)/$(am__dirstamp) +vtls/libcurlu_la-apple.lo: vtls/$(am__dirstamp) \ + vtls/$(DEPDIR)/$(am__dirstamp) +vtls/libcurlu_la-cipher_suite.lo: vtls/$(am__dirstamp) \ + vtls/$(DEPDIR)/$(am__dirstamp) +vtls/libcurlu_la-gtls.lo: vtls/$(am__dirstamp) \ + vtls/$(DEPDIR)/$(am__dirstamp) +vtls/libcurlu_la-hostcheck.lo: vtls/$(am__dirstamp) \ + vtls/$(DEPDIR)/$(am__dirstamp) +vtls/libcurlu_la-keylog.lo: vtls/$(am__dirstamp) \ + vtls/$(DEPDIR)/$(am__dirstamp) +vtls/libcurlu_la-mbedtls.lo: vtls/$(am__dirstamp) \ + vtls/$(DEPDIR)/$(am__dirstamp) +vtls/libcurlu_la-openssl.lo: vtls/$(am__dirstamp) \ + vtls/$(DEPDIR)/$(am__dirstamp) +vtls/libcurlu_la-rustls.lo: vtls/$(am__dirstamp) \ + vtls/$(DEPDIR)/$(am__dirstamp) +vtls/libcurlu_la-schannel.lo: vtls/$(am__dirstamp) \ + vtls/$(DEPDIR)/$(am__dirstamp) +vtls/libcurlu_la-schannel_verify.lo: vtls/$(am__dirstamp) \ + vtls/$(DEPDIR)/$(am__dirstamp) +vtls/libcurlu_la-vtls.lo: vtls/$(am__dirstamp) \ + vtls/$(DEPDIR)/$(am__dirstamp) +vtls/libcurlu_la-vtls_config.lo: vtls/$(am__dirstamp) \ + vtls/$(DEPDIR)/$(am__dirstamp) +vtls/libcurlu_la-vtls_scache.lo: vtls/$(am__dirstamp) \ + vtls/$(DEPDIR)/$(am__dirstamp) +vtls/libcurlu_la-vtls_spack.lo: vtls/$(am__dirstamp) \ + vtls/$(DEPDIR)/$(am__dirstamp) +vtls/libcurlu_la-wolfssl.lo: vtls/$(am__dirstamp) \ + vtls/$(DEPDIR)/$(am__dirstamp) +vtls/libcurlu_la-x509asn1.lo: vtls/$(am__dirstamp) \ + vtls/$(DEPDIR)/$(am__dirstamp) +vquic/libcurlu_la-capsule.lo: vquic/$(am__dirstamp) \ + vquic/$(DEPDIR)/$(am__dirstamp) +vquic/libcurlu_la-cf-capsule.lo: vquic/$(am__dirstamp) \ + vquic/$(DEPDIR)/$(am__dirstamp) +vquic/libcurlu_la-cf-ngtcp2.lo: vquic/$(am__dirstamp) \ + vquic/$(DEPDIR)/$(am__dirstamp) +vquic/libcurlu_la-cf-ngtcp2-cmn.lo: vquic/$(am__dirstamp) \ + vquic/$(DEPDIR)/$(am__dirstamp) +vquic/libcurlu_la-cf-ngtcp2-proxy.lo: vquic/$(am__dirstamp) \ + vquic/$(DEPDIR)/$(am__dirstamp) +vquic/libcurlu_la-cf-quiche.lo: vquic/$(am__dirstamp) \ + vquic/$(DEPDIR)/$(am__dirstamp) +vquic/libcurlu_la-vquic.lo: vquic/$(am__dirstamp) \ + vquic/$(DEPDIR)/$(am__dirstamp) +vquic/libcurlu_la-vquic-tls.lo: vquic/$(am__dirstamp) \ + vquic/$(DEPDIR)/$(am__dirstamp) +vssh/libcurlu_la-libssh.lo: vssh/$(am__dirstamp) \ + vssh/$(DEPDIR)/$(am__dirstamp) +vssh/libcurlu_la-libssh2.lo: vssh/$(am__dirstamp) \ + vssh/$(DEPDIR)/$(am__dirstamp) +vssh/libcurlu_la-vssh.lo: vssh/$(am__dirstamp) \ + vssh/$(DEPDIR)/$(am__dirstamp) +curlx/libcurlu_la-base64.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurlu_la-basename.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurlu_la-dynbuf.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurlu_la-fopen.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurlu_la-inet_ntop.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurlu_la-inet_pton.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurlu_la-multibyte.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurlu_la-nonblock.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurlu_la-snprintf.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurlu_la-strcopy.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurlu_la-strdup.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurlu_la-strerr.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurlu_la-strparse.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurlu_la-timediff.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurlu_la-timeval.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurlu_la-version_win32.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurlu_la-wait.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurlu_la-warnless.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) +curlx/libcurlu_la-winapi.lo: curlx/$(am__dirstamp) \ + curlx/$(DEPDIR)/$(am__dirstamp) + +libcurlu.la: $(libcurlu_la_OBJECTS) $(libcurlu_la_DEPENDENCIES) $(EXTRA_libcurlu_la_DEPENDENCIES) + $(AM_V_CCLD)$(libcurlu_la_LINK) $(am_libcurlu_la_rpath) $(libcurlu_la_OBJECTS) $(libcurlu_la_LIBADD) $(LIBS) + +mostlyclean-compile: + -rm -f *.$(OBJEXT) + -rm -f curlx/*.$(OBJEXT) + -rm -f curlx/*.lo + -rm -f vauth/*.$(OBJEXT) + -rm -f vauth/*.lo + -rm -f vquic/*.$(OBJEXT) + -rm -f vquic/*.lo + -rm -f vssh/*.$(OBJEXT) + -rm -f vssh/*.lo + -rm -f vtls/*.$(OBJEXT) + -rm -f vtls/*.lo + +distclean-compile: + -rm -f *.tab.c + +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-altsvc.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-amigaos.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-asyn-ares.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-asyn-base.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-asyn-thrdd.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-bufq.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-bufref.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-cf-dns.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-cf-h1-proxy.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-cf-h2-proxy.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-cf-haproxy.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-cf-https-connect.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-cf-ip-happy.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-cf-recvbuf.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-cf-setup.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-cf-socket.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-cfilters.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-conncache.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-connect.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-content_encoding.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-cookie.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-creds.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-cshutdn.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-curl_addrinfo.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-curl_endian.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-curl_fnmatch.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-curl_fopen.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-curl_get_line.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-curl_gethostname.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-curl_gssapi.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-curl_memrchr.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-curl_ntlm_core.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-curl_range.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-curl_sasl.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-curl_sha512_256.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-curl_share.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-curl_sspi.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-curl_threads.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-curl_trc.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-cw-out.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-cw-pause.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-dict.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-dllmain.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-dnscache.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-doh.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-dynhds.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-easy.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-easygetopt.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-easyoptions.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-escape.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-fake_addrinfo.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-file.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-fileinfo.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-formdata.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-ftp.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-ftplistparser.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-getenv.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-getinfo.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-gopher.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-hash.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-headers.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-hmac.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-hostip.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-hostip4.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-hostip6.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-hsts.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-http.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-http1.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-http2.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-http_aws_sigv4.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-http_chunks.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-http_digest.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-http_negotiate.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-http_ntlm.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-http_proxy.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-httpsrr.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-idn.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-if2ip.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-imap.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-ldap.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-libcurl_unity.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-llist.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-macos.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-md4.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-md5.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-memdebug.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-mime.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-mprintf.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-mqtt.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-multi.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-multi_ev.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-multi_ntfy.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-netrc.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-openldap.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-parsedate.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-peer.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-pingpong.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-pop3.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-progress.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-protocol.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-proxy.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-psl.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-rand.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-ratelimit.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-request.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-rtsp.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-select.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-sendf.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-setopt.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-sha256.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-slist.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-smb.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-smtp.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-socketpair.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-socks.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-socks_gssapi.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-socks_sspi.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-splay.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-strcase.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-strequal.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-strerror.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-system_win32.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-telnet.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-tftp.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-thrdpool.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-thrdqueue.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-transfer.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-uint-bset.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-uint-hash.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-uint-spbset.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-uint-table.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-url.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-urlapi.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-version.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurl_la-ws.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-altsvc.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-amigaos.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-asyn-ares.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-asyn-base.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-asyn-thrdd.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-bufq.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-bufref.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-cf-dns.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-cf-h1-proxy.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-cf-h2-proxy.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-cf-haproxy.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-cf-https-connect.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-cf-ip-happy.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-cf-recvbuf.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-cf-setup.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-cf-socket.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-cfilters.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-conncache.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-connect.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-content_encoding.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-cookie.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-creds.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-cshutdn.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-curl_addrinfo.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-curl_endian.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-curl_fnmatch.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-curl_fopen.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-curl_get_line.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-curl_gethostname.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-curl_gssapi.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-curl_memrchr.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-curl_ntlm_core.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-curl_range.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-curl_sasl.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-curl_sha512_256.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-curl_share.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-curl_sspi.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-curl_threads.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-curl_trc.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-cw-out.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-cw-pause.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-dict.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-dllmain.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-dnscache.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-doh.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-dynhds.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-easy.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-easygetopt.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-easyoptions.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-escape.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-fake_addrinfo.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-file.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-fileinfo.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-formdata.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-ftp.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-ftplistparser.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-getenv.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-getinfo.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-gopher.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-hash.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-headers.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-hmac.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-hostip.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-hostip4.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-hostip6.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-hsts.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-http.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-http1.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-http2.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-http_aws_sigv4.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-http_chunks.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-http_digest.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-http_negotiate.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-http_ntlm.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-http_proxy.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-httpsrr.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-idn.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-if2ip.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-imap.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-ldap.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-libcurl_unity.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-llist.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-macos.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-md4.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-md5.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-memdebug.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-mime.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-mprintf.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-mqtt.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-multi.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-multi_ev.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-multi_ntfy.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-netrc.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-openldap.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-parsedate.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-peer.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-pingpong.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-pop3.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-progress.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-protocol.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-proxy.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-psl.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-rand.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-ratelimit.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-request.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-rtsp.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-select.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-sendf.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-setopt.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-sha256.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-slist.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-smb.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-smtp.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-socketpair.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-socks.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-socks_gssapi.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-socks_sspi.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-splay.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-strcase.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-strequal.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-strerror.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-system_win32.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-telnet.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-tftp.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-thrdpool.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-thrdqueue.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-transfer.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-uint-bset.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-uint-hash.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-uint-spbset.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-uint-table.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-url.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-urlapi.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-version.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libcurlu_la-ws.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurl_la-base64.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurl_la-basename.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurl_la-dynbuf.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurl_la-fopen.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurl_la-inet_ntop.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurl_la-inet_pton.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurl_la-multibyte.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurl_la-nonblock.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurl_la-snprintf.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurl_la-strcopy.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurl_la-strdup.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurl_la-strerr.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurl_la-strparse.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurl_la-timediff.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurl_la-timeval.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurl_la-version_win32.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurl_la-wait.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurl_la-warnless.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurl_la-winapi.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurlu_la-base64.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurlu_la-basename.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurlu_la-dynbuf.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurlu_la-fopen.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurlu_la-inet_ntop.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurlu_la-inet_pton.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurlu_la-multibyte.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurlu_la-nonblock.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurlu_la-snprintf.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurlu_la-strcopy.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurlu_la-strdup.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurlu_la-strerr.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurlu_la-strparse.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurlu_la-timediff.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurlu_la-timeval.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurlu_la-version_win32.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurlu_la-wait.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurlu_la-warnless.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@curlx/$(DEPDIR)/libcurlu_la-winapi.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vauth/$(DEPDIR)/libcurl_la-cleartext.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vauth/$(DEPDIR)/libcurl_la-cram.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vauth/$(DEPDIR)/libcurl_la-digest.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vauth/$(DEPDIR)/libcurl_la-digest_sspi.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vauth/$(DEPDIR)/libcurl_la-gsasl.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vauth/$(DEPDIR)/libcurl_la-krb5_gssapi.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vauth/$(DEPDIR)/libcurl_la-krb5_sspi.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vauth/$(DEPDIR)/libcurl_la-ntlm.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vauth/$(DEPDIR)/libcurl_la-ntlm_sspi.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vauth/$(DEPDIR)/libcurl_la-oauth2.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vauth/$(DEPDIR)/libcurl_la-spnego_gssapi.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vauth/$(DEPDIR)/libcurl_la-spnego_sspi.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vauth/$(DEPDIR)/libcurl_la-vauth.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vauth/$(DEPDIR)/libcurlu_la-cleartext.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vauth/$(DEPDIR)/libcurlu_la-cram.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vauth/$(DEPDIR)/libcurlu_la-digest.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vauth/$(DEPDIR)/libcurlu_la-digest_sspi.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vauth/$(DEPDIR)/libcurlu_la-gsasl.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vauth/$(DEPDIR)/libcurlu_la-krb5_gssapi.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vauth/$(DEPDIR)/libcurlu_la-krb5_sspi.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vauth/$(DEPDIR)/libcurlu_la-ntlm.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vauth/$(DEPDIR)/libcurlu_la-ntlm_sspi.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vauth/$(DEPDIR)/libcurlu_la-oauth2.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vauth/$(DEPDIR)/libcurlu_la-spnego_gssapi.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vauth/$(DEPDIR)/libcurlu_la-spnego_sspi.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vauth/$(DEPDIR)/libcurlu_la-vauth.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vquic/$(DEPDIR)/libcurl_la-capsule.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vquic/$(DEPDIR)/libcurl_la-cf-capsule.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vquic/$(DEPDIR)/libcurl_la-cf-ngtcp2-cmn.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vquic/$(DEPDIR)/libcurl_la-cf-ngtcp2-proxy.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vquic/$(DEPDIR)/libcurl_la-cf-ngtcp2.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vquic/$(DEPDIR)/libcurl_la-cf-quiche.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vquic/$(DEPDIR)/libcurl_la-vquic-tls.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vquic/$(DEPDIR)/libcurl_la-vquic.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vquic/$(DEPDIR)/libcurlu_la-capsule.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vquic/$(DEPDIR)/libcurlu_la-cf-capsule.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vquic/$(DEPDIR)/libcurlu_la-cf-ngtcp2-cmn.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vquic/$(DEPDIR)/libcurlu_la-cf-ngtcp2-proxy.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vquic/$(DEPDIR)/libcurlu_la-cf-ngtcp2.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vquic/$(DEPDIR)/libcurlu_la-cf-quiche.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vquic/$(DEPDIR)/libcurlu_la-vquic-tls.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vquic/$(DEPDIR)/libcurlu_la-vquic.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vssh/$(DEPDIR)/libcurl_la-libssh.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vssh/$(DEPDIR)/libcurl_la-libssh2.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vssh/$(DEPDIR)/libcurl_la-vssh.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vssh/$(DEPDIR)/libcurlu_la-libssh.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vssh/$(DEPDIR)/libcurlu_la-libssh2.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vssh/$(DEPDIR)/libcurlu_la-vssh.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vtls/$(DEPDIR)/libcurl_la-apple.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vtls/$(DEPDIR)/libcurl_la-cipher_suite.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vtls/$(DEPDIR)/libcurl_la-gtls.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vtls/$(DEPDIR)/libcurl_la-hostcheck.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vtls/$(DEPDIR)/libcurl_la-keylog.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vtls/$(DEPDIR)/libcurl_la-mbedtls.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vtls/$(DEPDIR)/libcurl_la-openssl.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vtls/$(DEPDIR)/libcurl_la-rustls.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vtls/$(DEPDIR)/libcurl_la-schannel.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vtls/$(DEPDIR)/libcurl_la-schannel_verify.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vtls/$(DEPDIR)/libcurl_la-vtls.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vtls/$(DEPDIR)/libcurl_la-vtls_config.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vtls/$(DEPDIR)/libcurl_la-vtls_scache.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vtls/$(DEPDIR)/libcurl_la-vtls_spack.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vtls/$(DEPDIR)/libcurl_la-wolfssl.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vtls/$(DEPDIR)/libcurl_la-x509asn1.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vtls/$(DEPDIR)/libcurlu_la-apple.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vtls/$(DEPDIR)/libcurlu_la-cipher_suite.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vtls/$(DEPDIR)/libcurlu_la-gtls.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vtls/$(DEPDIR)/libcurlu_la-hostcheck.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vtls/$(DEPDIR)/libcurlu_la-keylog.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vtls/$(DEPDIR)/libcurlu_la-mbedtls.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vtls/$(DEPDIR)/libcurlu_la-openssl.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vtls/$(DEPDIR)/libcurlu_la-rustls.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vtls/$(DEPDIR)/libcurlu_la-schannel.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vtls/$(DEPDIR)/libcurlu_la-schannel_verify.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vtls/$(DEPDIR)/libcurlu_la-vtls.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vtls/$(DEPDIR)/libcurlu_la-vtls_config.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vtls/$(DEPDIR)/libcurlu_la-vtls_scache.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vtls/$(DEPDIR)/libcurlu_la-vtls_spack.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vtls/$(DEPDIR)/libcurlu_la-wolfssl.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@vtls/$(DEPDIR)/libcurlu_la-x509asn1.Plo@am__quote@ # am--include-marker + +$(am__depfiles_remade): + @$(MKDIR_P) $(@D) + @echo '# dummy' >$@-t && $(am__mv) $@-t $@ + +am--depfiles: $(am__depfiles_remade) + +.c.o: +@am__fastdepCC_TRUE@ $(AM_V_CC)depbase=`echo $@ | sed 's|[^/]*$$|$(DEPDIR)/&|;s|\.o$$||'`;\ +@am__fastdepCC_TRUE@ $(COMPILE) -MT $@ -MD -MP -MF $$depbase.Tpo -c -o $@ $< &&\ +@am__fastdepCC_TRUE@ $(am__mv) $$depbase.Tpo $$depbase.Po +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='$<' object='$@' libtool=no @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(COMPILE) -c -o $@ $< + +.c.obj: +@am__fastdepCC_TRUE@ $(AM_V_CC)depbase=`echo $@ | sed 's|[^/]*$$|$(DEPDIR)/&|;s|\.obj$$||'`;\ +@am__fastdepCC_TRUE@ $(COMPILE) -MT $@ -MD -MP -MF $$depbase.Tpo -c -o $@ `$(CYGPATH_W) '$<'` &&\ +@am__fastdepCC_TRUE@ $(am__mv) $$depbase.Tpo $$depbase.Po +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='$<' object='$@' libtool=no @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(COMPILE) -c -o $@ `$(CYGPATH_W) '$<'` + +.c.lo: +@am__fastdepCC_TRUE@ $(AM_V_CC)depbase=`echo $@ | sed 's|[^/]*$$|$(DEPDIR)/&|;s|\.lo$$||'`;\ +@am__fastdepCC_TRUE@ $(LTCOMPILE) -MT $@ -MD -MP -MF $$depbase.Tpo -c -o $@ $< &&\ +@am__fastdepCC_TRUE@ $(am__mv) $$depbase.Tpo $$depbase.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='$<' object='$@' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LTCOMPILE) -c -o $@ $< + +libcurl_la-altsvc.lo: altsvc.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-altsvc.lo -MD -MP -MF $(DEPDIR)/libcurl_la-altsvc.Tpo -c -o libcurl_la-altsvc.lo `test -f 'altsvc.c' || echo '$(srcdir)/'`altsvc.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-altsvc.Tpo $(DEPDIR)/libcurl_la-altsvc.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='altsvc.c' object='libcurl_la-altsvc.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-altsvc.lo `test -f 'altsvc.c' || echo '$(srcdir)/'`altsvc.c + +libcurl_la-amigaos.lo: amigaos.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-amigaos.lo -MD -MP -MF $(DEPDIR)/libcurl_la-amigaos.Tpo -c -o libcurl_la-amigaos.lo `test -f 'amigaos.c' || echo '$(srcdir)/'`amigaos.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-amigaos.Tpo $(DEPDIR)/libcurl_la-amigaos.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='amigaos.c' object='libcurl_la-amigaos.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-amigaos.lo `test -f 'amigaos.c' || echo '$(srcdir)/'`amigaos.c + +libcurl_la-asyn-ares.lo: asyn-ares.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-asyn-ares.lo -MD -MP -MF $(DEPDIR)/libcurl_la-asyn-ares.Tpo -c -o libcurl_la-asyn-ares.lo `test -f 'asyn-ares.c' || echo '$(srcdir)/'`asyn-ares.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-asyn-ares.Tpo $(DEPDIR)/libcurl_la-asyn-ares.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='asyn-ares.c' object='libcurl_la-asyn-ares.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-asyn-ares.lo `test -f 'asyn-ares.c' || echo '$(srcdir)/'`asyn-ares.c + +libcurl_la-asyn-base.lo: asyn-base.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-asyn-base.lo -MD -MP -MF $(DEPDIR)/libcurl_la-asyn-base.Tpo -c -o libcurl_la-asyn-base.lo `test -f 'asyn-base.c' || echo '$(srcdir)/'`asyn-base.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-asyn-base.Tpo $(DEPDIR)/libcurl_la-asyn-base.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='asyn-base.c' object='libcurl_la-asyn-base.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-asyn-base.lo `test -f 'asyn-base.c' || echo '$(srcdir)/'`asyn-base.c + +libcurl_la-asyn-thrdd.lo: asyn-thrdd.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-asyn-thrdd.lo -MD -MP -MF $(DEPDIR)/libcurl_la-asyn-thrdd.Tpo -c -o libcurl_la-asyn-thrdd.lo `test -f 'asyn-thrdd.c' || echo '$(srcdir)/'`asyn-thrdd.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-asyn-thrdd.Tpo $(DEPDIR)/libcurl_la-asyn-thrdd.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='asyn-thrdd.c' object='libcurl_la-asyn-thrdd.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-asyn-thrdd.lo `test -f 'asyn-thrdd.c' || echo '$(srcdir)/'`asyn-thrdd.c + +libcurl_la-bufq.lo: bufq.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-bufq.lo -MD -MP -MF $(DEPDIR)/libcurl_la-bufq.Tpo -c -o libcurl_la-bufq.lo `test -f 'bufq.c' || echo '$(srcdir)/'`bufq.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-bufq.Tpo $(DEPDIR)/libcurl_la-bufq.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='bufq.c' object='libcurl_la-bufq.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-bufq.lo `test -f 'bufq.c' || echo '$(srcdir)/'`bufq.c + +libcurl_la-bufref.lo: bufref.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-bufref.lo -MD -MP -MF $(DEPDIR)/libcurl_la-bufref.Tpo -c -o libcurl_la-bufref.lo `test -f 'bufref.c' || echo '$(srcdir)/'`bufref.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-bufref.Tpo $(DEPDIR)/libcurl_la-bufref.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='bufref.c' object='libcurl_la-bufref.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-bufref.lo `test -f 'bufref.c' || echo '$(srcdir)/'`bufref.c + +libcurl_la-cf-dns.lo: cf-dns.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-cf-dns.lo -MD -MP -MF $(DEPDIR)/libcurl_la-cf-dns.Tpo -c -o libcurl_la-cf-dns.lo `test -f 'cf-dns.c' || echo '$(srcdir)/'`cf-dns.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-cf-dns.Tpo $(DEPDIR)/libcurl_la-cf-dns.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='cf-dns.c' object='libcurl_la-cf-dns.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-cf-dns.lo `test -f 'cf-dns.c' || echo '$(srcdir)/'`cf-dns.c + +libcurl_la-cf-h1-proxy.lo: cf-h1-proxy.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-cf-h1-proxy.lo -MD -MP -MF $(DEPDIR)/libcurl_la-cf-h1-proxy.Tpo -c -o libcurl_la-cf-h1-proxy.lo `test -f 'cf-h1-proxy.c' || echo '$(srcdir)/'`cf-h1-proxy.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-cf-h1-proxy.Tpo $(DEPDIR)/libcurl_la-cf-h1-proxy.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='cf-h1-proxy.c' object='libcurl_la-cf-h1-proxy.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-cf-h1-proxy.lo `test -f 'cf-h1-proxy.c' || echo '$(srcdir)/'`cf-h1-proxy.c + +libcurl_la-cf-h2-proxy.lo: cf-h2-proxy.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-cf-h2-proxy.lo -MD -MP -MF $(DEPDIR)/libcurl_la-cf-h2-proxy.Tpo -c -o libcurl_la-cf-h2-proxy.lo `test -f 'cf-h2-proxy.c' || echo '$(srcdir)/'`cf-h2-proxy.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-cf-h2-proxy.Tpo $(DEPDIR)/libcurl_la-cf-h2-proxy.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='cf-h2-proxy.c' object='libcurl_la-cf-h2-proxy.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-cf-h2-proxy.lo `test -f 'cf-h2-proxy.c' || echo '$(srcdir)/'`cf-h2-proxy.c + +libcurl_la-cf-haproxy.lo: cf-haproxy.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-cf-haproxy.lo -MD -MP -MF $(DEPDIR)/libcurl_la-cf-haproxy.Tpo -c -o libcurl_la-cf-haproxy.lo `test -f 'cf-haproxy.c' || echo '$(srcdir)/'`cf-haproxy.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-cf-haproxy.Tpo $(DEPDIR)/libcurl_la-cf-haproxy.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='cf-haproxy.c' object='libcurl_la-cf-haproxy.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-cf-haproxy.lo `test -f 'cf-haproxy.c' || echo '$(srcdir)/'`cf-haproxy.c + +libcurl_la-cf-https-connect.lo: cf-https-connect.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-cf-https-connect.lo -MD -MP -MF $(DEPDIR)/libcurl_la-cf-https-connect.Tpo -c -o libcurl_la-cf-https-connect.lo `test -f 'cf-https-connect.c' || echo '$(srcdir)/'`cf-https-connect.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-cf-https-connect.Tpo $(DEPDIR)/libcurl_la-cf-https-connect.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='cf-https-connect.c' object='libcurl_la-cf-https-connect.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-cf-https-connect.lo `test -f 'cf-https-connect.c' || echo '$(srcdir)/'`cf-https-connect.c + +libcurl_la-cf-ip-happy.lo: cf-ip-happy.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-cf-ip-happy.lo -MD -MP -MF $(DEPDIR)/libcurl_la-cf-ip-happy.Tpo -c -o libcurl_la-cf-ip-happy.lo `test -f 'cf-ip-happy.c' || echo '$(srcdir)/'`cf-ip-happy.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-cf-ip-happy.Tpo $(DEPDIR)/libcurl_la-cf-ip-happy.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='cf-ip-happy.c' object='libcurl_la-cf-ip-happy.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-cf-ip-happy.lo `test -f 'cf-ip-happy.c' || echo '$(srcdir)/'`cf-ip-happy.c + +libcurl_la-cf-recvbuf.lo: cf-recvbuf.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-cf-recvbuf.lo -MD -MP -MF $(DEPDIR)/libcurl_la-cf-recvbuf.Tpo -c -o libcurl_la-cf-recvbuf.lo `test -f 'cf-recvbuf.c' || echo '$(srcdir)/'`cf-recvbuf.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-cf-recvbuf.Tpo $(DEPDIR)/libcurl_la-cf-recvbuf.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='cf-recvbuf.c' object='libcurl_la-cf-recvbuf.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-cf-recvbuf.lo `test -f 'cf-recvbuf.c' || echo '$(srcdir)/'`cf-recvbuf.c + +libcurl_la-cf-setup.lo: cf-setup.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-cf-setup.lo -MD -MP -MF $(DEPDIR)/libcurl_la-cf-setup.Tpo -c -o libcurl_la-cf-setup.lo `test -f 'cf-setup.c' || echo '$(srcdir)/'`cf-setup.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-cf-setup.Tpo $(DEPDIR)/libcurl_la-cf-setup.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='cf-setup.c' object='libcurl_la-cf-setup.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-cf-setup.lo `test -f 'cf-setup.c' || echo '$(srcdir)/'`cf-setup.c + +libcurl_la-cf-socket.lo: cf-socket.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-cf-socket.lo -MD -MP -MF $(DEPDIR)/libcurl_la-cf-socket.Tpo -c -o libcurl_la-cf-socket.lo `test -f 'cf-socket.c' || echo '$(srcdir)/'`cf-socket.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-cf-socket.Tpo $(DEPDIR)/libcurl_la-cf-socket.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='cf-socket.c' object='libcurl_la-cf-socket.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-cf-socket.lo `test -f 'cf-socket.c' || echo '$(srcdir)/'`cf-socket.c + +libcurl_la-cfilters.lo: cfilters.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-cfilters.lo -MD -MP -MF $(DEPDIR)/libcurl_la-cfilters.Tpo -c -o libcurl_la-cfilters.lo `test -f 'cfilters.c' || echo '$(srcdir)/'`cfilters.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-cfilters.Tpo $(DEPDIR)/libcurl_la-cfilters.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='cfilters.c' object='libcurl_la-cfilters.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-cfilters.lo `test -f 'cfilters.c' || echo '$(srcdir)/'`cfilters.c + +libcurl_la-conncache.lo: conncache.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-conncache.lo -MD -MP -MF $(DEPDIR)/libcurl_la-conncache.Tpo -c -o libcurl_la-conncache.lo `test -f 'conncache.c' || echo '$(srcdir)/'`conncache.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-conncache.Tpo $(DEPDIR)/libcurl_la-conncache.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='conncache.c' object='libcurl_la-conncache.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-conncache.lo `test -f 'conncache.c' || echo '$(srcdir)/'`conncache.c + +libcurl_la-connect.lo: connect.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-connect.lo -MD -MP -MF $(DEPDIR)/libcurl_la-connect.Tpo -c -o libcurl_la-connect.lo `test -f 'connect.c' || echo '$(srcdir)/'`connect.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-connect.Tpo $(DEPDIR)/libcurl_la-connect.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='connect.c' object='libcurl_la-connect.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-connect.lo `test -f 'connect.c' || echo '$(srcdir)/'`connect.c + +libcurl_la-content_encoding.lo: content_encoding.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-content_encoding.lo -MD -MP -MF $(DEPDIR)/libcurl_la-content_encoding.Tpo -c -o libcurl_la-content_encoding.lo `test -f 'content_encoding.c' || echo '$(srcdir)/'`content_encoding.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-content_encoding.Tpo $(DEPDIR)/libcurl_la-content_encoding.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='content_encoding.c' object='libcurl_la-content_encoding.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-content_encoding.lo `test -f 'content_encoding.c' || echo '$(srcdir)/'`content_encoding.c + +libcurl_la-cookie.lo: cookie.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-cookie.lo -MD -MP -MF $(DEPDIR)/libcurl_la-cookie.Tpo -c -o libcurl_la-cookie.lo `test -f 'cookie.c' || echo '$(srcdir)/'`cookie.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-cookie.Tpo $(DEPDIR)/libcurl_la-cookie.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='cookie.c' object='libcurl_la-cookie.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-cookie.lo `test -f 'cookie.c' || echo '$(srcdir)/'`cookie.c + +libcurl_la-creds.lo: creds.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-creds.lo -MD -MP -MF $(DEPDIR)/libcurl_la-creds.Tpo -c -o libcurl_la-creds.lo `test -f 'creds.c' || echo '$(srcdir)/'`creds.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-creds.Tpo $(DEPDIR)/libcurl_la-creds.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='creds.c' object='libcurl_la-creds.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-creds.lo `test -f 'creds.c' || echo '$(srcdir)/'`creds.c + +libcurl_la-cshutdn.lo: cshutdn.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-cshutdn.lo -MD -MP -MF $(DEPDIR)/libcurl_la-cshutdn.Tpo -c -o libcurl_la-cshutdn.lo `test -f 'cshutdn.c' || echo '$(srcdir)/'`cshutdn.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-cshutdn.Tpo $(DEPDIR)/libcurl_la-cshutdn.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='cshutdn.c' object='libcurl_la-cshutdn.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-cshutdn.lo `test -f 'cshutdn.c' || echo '$(srcdir)/'`cshutdn.c + +libcurl_la-curl_addrinfo.lo: curl_addrinfo.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-curl_addrinfo.lo -MD -MP -MF $(DEPDIR)/libcurl_la-curl_addrinfo.Tpo -c -o libcurl_la-curl_addrinfo.lo `test -f 'curl_addrinfo.c' || echo '$(srcdir)/'`curl_addrinfo.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-curl_addrinfo.Tpo $(DEPDIR)/libcurl_la-curl_addrinfo.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curl_addrinfo.c' object='libcurl_la-curl_addrinfo.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-curl_addrinfo.lo `test -f 'curl_addrinfo.c' || echo '$(srcdir)/'`curl_addrinfo.c + +libcurl_la-curl_endian.lo: curl_endian.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-curl_endian.lo -MD -MP -MF $(DEPDIR)/libcurl_la-curl_endian.Tpo -c -o libcurl_la-curl_endian.lo `test -f 'curl_endian.c' || echo '$(srcdir)/'`curl_endian.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-curl_endian.Tpo $(DEPDIR)/libcurl_la-curl_endian.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curl_endian.c' object='libcurl_la-curl_endian.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-curl_endian.lo `test -f 'curl_endian.c' || echo '$(srcdir)/'`curl_endian.c + +libcurl_la-curl_fnmatch.lo: curl_fnmatch.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-curl_fnmatch.lo -MD -MP -MF $(DEPDIR)/libcurl_la-curl_fnmatch.Tpo -c -o libcurl_la-curl_fnmatch.lo `test -f 'curl_fnmatch.c' || echo '$(srcdir)/'`curl_fnmatch.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-curl_fnmatch.Tpo $(DEPDIR)/libcurl_la-curl_fnmatch.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curl_fnmatch.c' object='libcurl_la-curl_fnmatch.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-curl_fnmatch.lo `test -f 'curl_fnmatch.c' || echo '$(srcdir)/'`curl_fnmatch.c + +libcurl_la-curl_fopen.lo: curl_fopen.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-curl_fopen.lo -MD -MP -MF $(DEPDIR)/libcurl_la-curl_fopen.Tpo -c -o libcurl_la-curl_fopen.lo `test -f 'curl_fopen.c' || echo '$(srcdir)/'`curl_fopen.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-curl_fopen.Tpo $(DEPDIR)/libcurl_la-curl_fopen.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curl_fopen.c' object='libcurl_la-curl_fopen.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-curl_fopen.lo `test -f 'curl_fopen.c' || echo '$(srcdir)/'`curl_fopen.c + +libcurl_la-curl_get_line.lo: curl_get_line.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-curl_get_line.lo -MD -MP -MF $(DEPDIR)/libcurl_la-curl_get_line.Tpo -c -o libcurl_la-curl_get_line.lo `test -f 'curl_get_line.c' || echo '$(srcdir)/'`curl_get_line.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-curl_get_line.Tpo $(DEPDIR)/libcurl_la-curl_get_line.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curl_get_line.c' object='libcurl_la-curl_get_line.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-curl_get_line.lo `test -f 'curl_get_line.c' || echo '$(srcdir)/'`curl_get_line.c + +libcurl_la-curl_gethostname.lo: curl_gethostname.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-curl_gethostname.lo -MD -MP -MF $(DEPDIR)/libcurl_la-curl_gethostname.Tpo -c -o libcurl_la-curl_gethostname.lo `test -f 'curl_gethostname.c' || echo '$(srcdir)/'`curl_gethostname.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-curl_gethostname.Tpo $(DEPDIR)/libcurl_la-curl_gethostname.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curl_gethostname.c' object='libcurl_la-curl_gethostname.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-curl_gethostname.lo `test -f 'curl_gethostname.c' || echo '$(srcdir)/'`curl_gethostname.c + +libcurl_la-curl_gssapi.lo: curl_gssapi.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-curl_gssapi.lo -MD -MP -MF $(DEPDIR)/libcurl_la-curl_gssapi.Tpo -c -o libcurl_la-curl_gssapi.lo `test -f 'curl_gssapi.c' || echo '$(srcdir)/'`curl_gssapi.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-curl_gssapi.Tpo $(DEPDIR)/libcurl_la-curl_gssapi.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curl_gssapi.c' object='libcurl_la-curl_gssapi.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-curl_gssapi.lo `test -f 'curl_gssapi.c' || echo '$(srcdir)/'`curl_gssapi.c + +libcurl_la-curl_memrchr.lo: curl_memrchr.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-curl_memrchr.lo -MD -MP -MF $(DEPDIR)/libcurl_la-curl_memrchr.Tpo -c -o libcurl_la-curl_memrchr.lo `test -f 'curl_memrchr.c' || echo '$(srcdir)/'`curl_memrchr.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-curl_memrchr.Tpo $(DEPDIR)/libcurl_la-curl_memrchr.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curl_memrchr.c' object='libcurl_la-curl_memrchr.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-curl_memrchr.lo `test -f 'curl_memrchr.c' || echo '$(srcdir)/'`curl_memrchr.c + +libcurl_la-curl_ntlm_core.lo: curl_ntlm_core.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-curl_ntlm_core.lo -MD -MP -MF $(DEPDIR)/libcurl_la-curl_ntlm_core.Tpo -c -o libcurl_la-curl_ntlm_core.lo `test -f 'curl_ntlm_core.c' || echo '$(srcdir)/'`curl_ntlm_core.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-curl_ntlm_core.Tpo $(DEPDIR)/libcurl_la-curl_ntlm_core.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curl_ntlm_core.c' object='libcurl_la-curl_ntlm_core.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-curl_ntlm_core.lo `test -f 'curl_ntlm_core.c' || echo '$(srcdir)/'`curl_ntlm_core.c + +libcurl_la-curl_range.lo: curl_range.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-curl_range.lo -MD -MP -MF $(DEPDIR)/libcurl_la-curl_range.Tpo -c -o libcurl_la-curl_range.lo `test -f 'curl_range.c' || echo '$(srcdir)/'`curl_range.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-curl_range.Tpo $(DEPDIR)/libcurl_la-curl_range.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curl_range.c' object='libcurl_la-curl_range.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-curl_range.lo `test -f 'curl_range.c' || echo '$(srcdir)/'`curl_range.c + +libcurl_la-curl_sasl.lo: curl_sasl.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-curl_sasl.lo -MD -MP -MF $(DEPDIR)/libcurl_la-curl_sasl.Tpo -c -o libcurl_la-curl_sasl.lo `test -f 'curl_sasl.c' || echo '$(srcdir)/'`curl_sasl.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-curl_sasl.Tpo $(DEPDIR)/libcurl_la-curl_sasl.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curl_sasl.c' object='libcurl_la-curl_sasl.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-curl_sasl.lo `test -f 'curl_sasl.c' || echo '$(srcdir)/'`curl_sasl.c + +libcurl_la-curl_sha512_256.lo: curl_sha512_256.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-curl_sha512_256.lo -MD -MP -MF $(DEPDIR)/libcurl_la-curl_sha512_256.Tpo -c -o libcurl_la-curl_sha512_256.lo `test -f 'curl_sha512_256.c' || echo '$(srcdir)/'`curl_sha512_256.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-curl_sha512_256.Tpo $(DEPDIR)/libcurl_la-curl_sha512_256.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curl_sha512_256.c' object='libcurl_la-curl_sha512_256.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-curl_sha512_256.lo `test -f 'curl_sha512_256.c' || echo '$(srcdir)/'`curl_sha512_256.c + +libcurl_la-curl_share.lo: curl_share.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-curl_share.lo -MD -MP -MF $(DEPDIR)/libcurl_la-curl_share.Tpo -c -o libcurl_la-curl_share.lo `test -f 'curl_share.c' || echo '$(srcdir)/'`curl_share.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-curl_share.Tpo $(DEPDIR)/libcurl_la-curl_share.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curl_share.c' object='libcurl_la-curl_share.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-curl_share.lo `test -f 'curl_share.c' || echo '$(srcdir)/'`curl_share.c + +libcurl_la-curl_sspi.lo: curl_sspi.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-curl_sspi.lo -MD -MP -MF $(DEPDIR)/libcurl_la-curl_sspi.Tpo -c -o libcurl_la-curl_sspi.lo `test -f 'curl_sspi.c' || echo '$(srcdir)/'`curl_sspi.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-curl_sspi.Tpo $(DEPDIR)/libcurl_la-curl_sspi.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curl_sspi.c' object='libcurl_la-curl_sspi.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-curl_sspi.lo `test -f 'curl_sspi.c' || echo '$(srcdir)/'`curl_sspi.c + +libcurl_la-curl_threads.lo: curl_threads.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-curl_threads.lo -MD -MP -MF $(DEPDIR)/libcurl_la-curl_threads.Tpo -c -o libcurl_la-curl_threads.lo `test -f 'curl_threads.c' || echo '$(srcdir)/'`curl_threads.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-curl_threads.Tpo $(DEPDIR)/libcurl_la-curl_threads.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curl_threads.c' object='libcurl_la-curl_threads.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-curl_threads.lo `test -f 'curl_threads.c' || echo '$(srcdir)/'`curl_threads.c + +libcurl_la-curl_trc.lo: curl_trc.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-curl_trc.lo -MD -MP -MF $(DEPDIR)/libcurl_la-curl_trc.Tpo -c -o libcurl_la-curl_trc.lo `test -f 'curl_trc.c' || echo '$(srcdir)/'`curl_trc.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-curl_trc.Tpo $(DEPDIR)/libcurl_la-curl_trc.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curl_trc.c' object='libcurl_la-curl_trc.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-curl_trc.lo `test -f 'curl_trc.c' || echo '$(srcdir)/'`curl_trc.c + +libcurl_la-cw-out.lo: cw-out.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-cw-out.lo -MD -MP -MF $(DEPDIR)/libcurl_la-cw-out.Tpo -c -o libcurl_la-cw-out.lo `test -f 'cw-out.c' || echo '$(srcdir)/'`cw-out.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-cw-out.Tpo $(DEPDIR)/libcurl_la-cw-out.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='cw-out.c' object='libcurl_la-cw-out.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-cw-out.lo `test -f 'cw-out.c' || echo '$(srcdir)/'`cw-out.c + +libcurl_la-cw-pause.lo: cw-pause.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-cw-pause.lo -MD -MP -MF $(DEPDIR)/libcurl_la-cw-pause.Tpo -c -o libcurl_la-cw-pause.lo `test -f 'cw-pause.c' || echo '$(srcdir)/'`cw-pause.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-cw-pause.Tpo $(DEPDIR)/libcurl_la-cw-pause.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='cw-pause.c' object='libcurl_la-cw-pause.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-cw-pause.lo `test -f 'cw-pause.c' || echo '$(srcdir)/'`cw-pause.c + +libcurl_la-dict.lo: dict.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-dict.lo -MD -MP -MF $(DEPDIR)/libcurl_la-dict.Tpo -c -o libcurl_la-dict.lo `test -f 'dict.c' || echo '$(srcdir)/'`dict.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-dict.Tpo $(DEPDIR)/libcurl_la-dict.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='dict.c' object='libcurl_la-dict.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-dict.lo `test -f 'dict.c' || echo '$(srcdir)/'`dict.c + +libcurl_la-dnscache.lo: dnscache.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-dnscache.lo -MD -MP -MF $(DEPDIR)/libcurl_la-dnscache.Tpo -c -o libcurl_la-dnscache.lo `test -f 'dnscache.c' || echo '$(srcdir)/'`dnscache.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-dnscache.Tpo $(DEPDIR)/libcurl_la-dnscache.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='dnscache.c' object='libcurl_la-dnscache.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-dnscache.lo `test -f 'dnscache.c' || echo '$(srcdir)/'`dnscache.c + +libcurl_la-doh.lo: doh.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-doh.lo -MD -MP -MF $(DEPDIR)/libcurl_la-doh.Tpo -c -o libcurl_la-doh.lo `test -f 'doh.c' || echo '$(srcdir)/'`doh.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-doh.Tpo $(DEPDIR)/libcurl_la-doh.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='doh.c' object='libcurl_la-doh.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-doh.lo `test -f 'doh.c' || echo '$(srcdir)/'`doh.c + +libcurl_la-dynhds.lo: dynhds.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-dynhds.lo -MD -MP -MF $(DEPDIR)/libcurl_la-dynhds.Tpo -c -o libcurl_la-dynhds.lo `test -f 'dynhds.c' || echo '$(srcdir)/'`dynhds.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-dynhds.Tpo $(DEPDIR)/libcurl_la-dynhds.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='dynhds.c' object='libcurl_la-dynhds.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-dynhds.lo `test -f 'dynhds.c' || echo '$(srcdir)/'`dynhds.c + +libcurl_la-easy.lo: easy.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-easy.lo -MD -MP -MF $(DEPDIR)/libcurl_la-easy.Tpo -c -o libcurl_la-easy.lo `test -f 'easy.c' || echo '$(srcdir)/'`easy.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-easy.Tpo $(DEPDIR)/libcurl_la-easy.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='easy.c' object='libcurl_la-easy.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-easy.lo `test -f 'easy.c' || echo '$(srcdir)/'`easy.c + +libcurl_la-easygetopt.lo: easygetopt.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-easygetopt.lo -MD -MP -MF $(DEPDIR)/libcurl_la-easygetopt.Tpo -c -o libcurl_la-easygetopt.lo `test -f 'easygetopt.c' || echo '$(srcdir)/'`easygetopt.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-easygetopt.Tpo $(DEPDIR)/libcurl_la-easygetopt.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='easygetopt.c' object='libcurl_la-easygetopt.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-easygetopt.lo `test -f 'easygetopt.c' || echo '$(srcdir)/'`easygetopt.c + +libcurl_la-easyoptions.lo: easyoptions.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-easyoptions.lo -MD -MP -MF $(DEPDIR)/libcurl_la-easyoptions.Tpo -c -o libcurl_la-easyoptions.lo `test -f 'easyoptions.c' || echo '$(srcdir)/'`easyoptions.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-easyoptions.Tpo $(DEPDIR)/libcurl_la-easyoptions.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='easyoptions.c' object='libcurl_la-easyoptions.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-easyoptions.lo `test -f 'easyoptions.c' || echo '$(srcdir)/'`easyoptions.c + +libcurl_la-escape.lo: escape.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-escape.lo -MD -MP -MF $(DEPDIR)/libcurl_la-escape.Tpo -c -o libcurl_la-escape.lo `test -f 'escape.c' || echo '$(srcdir)/'`escape.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-escape.Tpo $(DEPDIR)/libcurl_la-escape.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='escape.c' object='libcurl_la-escape.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-escape.lo `test -f 'escape.c' || echo '$(srcdir)/'`escape.c + +libcurl_la-fake_addrinfo.lo: fake_addrinfo.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-fake_addrinfo.lo -MD -MP -MF $(DEPDIR)/libcurl_la-fake_addrinfo.Tpo -c -o libcurl_la-fake_addrinfo.lo `test -f 'fake_addrinfo.c' || echo '$(srcdir)/'`fake_addrinfo.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-fake_addrinfo.Tpo $(DEPDIR)/libcurl_la-fake_addrinfo.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='fake_addrinfo.c' object='libcurl_la-fake_addrinfo.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-fake_addrinfo.lo `test -f 'fake_addrinfo.c' || echo '$(srcdir)/'`fake_addrinfo.c + +libcurl_la-file.lo: file.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-file.lo -MD -MP -MF $(DEPDIR)/libcurl_la-file.Tpo -c -o libcurl_la-file.lo `test -f 'file.c' || echo '$(srcdir)/'`file.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-file.Tpo $(DEPDIR)/libcurl_la-file.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='file.c' object='libcurl_la-file.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-file.lo `test -f 'file.c' || echo '$(srcdir)/'`file.c + +libcurl_la-fileinfo.lo: fileinfo.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-fileinfo.lo -MD -MP -MF $(DEPDIR)/libcurl_la-fileinfo.Tpo -c -o libcurl_la-fileinfo.lo `test -f 'fileinfo.c' || echo '$(srcdir)/'`fileinfo.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-fileinfo.Tpo $(DEPDIR)/libcurl_la-fileinfo.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='fileinfo.c' object='libcurl_la-fileinfo.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-fileinfo.lo `test -f 'fileinfo.c' || echo '$(srcdir)/'`fileinfo.c + +libcurl_la-formdata.lo: formdata.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-formdata.lo -MD -MP -MF $(DEPDIR)/libcurl_la-formdata.Tpo -c -o libcurl_la-formdata.lo `test -f 'formdata.c' || echo '$(srcdir)/'`formdata.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-formdata.Tpo $(DEPDIR)/libcurl_la-formdata.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='formdata.c' object='libcurl_la-formdata.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-formdata.lo `test -f 'formdata.c' || echo '$(srcdir)/'`formdata.c + +libcurl_la-ftp.lo: ftp.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-ftp.lo -MD -MP -MF $(DEPDIR)/libcurl_la-ftp.Tpo -c -o libcurl_la-ftp.lo `test -f 'ftp.c' || echo '$(srcdir)/'`ftp.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-ftp.Tpo $(DEPDIR)/libcurl_la-ftp.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='ftp.c' object='libcurl_la-ftp.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-ftp.lo `test -f 'ftp.c' || echo '$(srcdir)/'`ftp.c + +libcurl_la-ftplistparser.lo: ftplistparser.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-ftplistparser.lo -MD -MP -MF $(DEPDIR)/libcurl_la-ftplistparser.Tpo -c -o libcurl_la-ftplistparser.lo `test -f 'ftplistparser.c' || echo '$(srcdir)/'`ftplistparser.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-ftplistparser.Tpo $(DEPDIR)/libcurl_la-ftplistparser.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='ftplistparser.c' object='libcurl_la-ftplistparser.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-ftplistparser.lo `test -f 'ftplistparser.c' || echo '$(srcdir)/'`ftplistparser.c + +libcurl_la-getenv.lo: getenv.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-getenv.lo -MD -MP -MF $(DEPDIR)/libcurl_la-getenv.Tpo -c -o libcurl_la-getenv.lo `test -f 'getenv.c' || echo '$(srcdir)/'`getenv.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-getenv.Tpo $(DEPDIR)/libcurl_la-getenv.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='getenv.c' object='libcurl_la-getenv.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-getenv.lo `test -f 'getenv.c' || echo '$(srcdir)/'`getenv.c + +libcurl_la-getinfo.lo: getinfo.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-getinfo.lo -MD -MP -MF $(DEPDIR)/libcurl_la-getinfo.Tpo -c -o libcurl_la-getinfo.lo `test -f 'getinfo.c' || echo '$(srcdir)/'`getinfo.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-getinfo.Tpo $(DEPDIR)/libcurl_la-getinfo.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='getinfo.c' object='libcurl_la-getinfo.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-getinfo.lo `test -f 'getinfo.c' || echo '$(srcdir)/'`getinfo.c + +libcurl_la-gopher.lo: gopher.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-gopher.lo -MD -MP -MF $(DEPDIR)/libcurl_la-gopher.Tpo -c -o libcurl_la-gopher.lo `test -f 'gopher.c' || echo '$(srcdir)/'`gopher.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-gopher.Tpo $(DEPDIR)/libcurl_la-gopher.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='gopher.c' object='libcurl_la-gopher.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-gopher.lo `test -f 'gopher.c' || echo '$(srcdir)/'`gopher.c + +libcurl_la-hash.lo: hash.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-hash.lo -MD -MP -MF $(DEPDIR)/libcurl_la-hash.Tpo -c -o libcurl_la-hash.lo `test -f 'hash.c' || echo '$(srcdir)/'`hash.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-hash.Tpo $(DEPDIR)/libcurl_la-hash.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='hash.c' object='libcurl_la-hash.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-hash.lo `test -f 'hash.c' || echo '$(srcdir)/'`hash.c + +libcurl_la-headers.lo: headers.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-headers.lo -MD -MP -MF $(DEPDIR)/libcurl_la-headers.Tpo -c -o libcurl_la-headers.lo `test -f 'headers.c' || echo '$(srcdir)/'`headers.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-headers.Tpo $(DEPDIR)/libcurl_la-headers.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='headers.c' object='libcurl_la-headers.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-headers.lo `test -f 'headers.c' || echo '$(srcdir)/'`headers.c + +libcurl_la-hmac.lo: hmac.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-hmac.lo -MD -MP -MF $(DEPDIR)/libcurl_la-hmac.Tpo -c -o libcurl_la-hmac.lo `test -f 'hmac.c' || echo '$(srcdir)/'`hmac.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-hmac.Tpo $(DEPDIR)/libcurl_la-hmac.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='hmac.c' object='libcurl_la-hmac.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-hmac.lo `test -f 'hmac.c' || echo '$(srcdir)/'`hmac.c + +libcurl_la-hostip.lo: hostip.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-hostip.lo -MD -MP -MF $(DEPDIR)/libcurl_la-hostip.Tpo -c -o libcurl_la-hostip.lo `test -f 'hostip.c' || echo '$(srcdir)/'`hostip.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-hostip.Tpo $(DEPDIR)/libcurl_la-hostip.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='hostip.c' object='libcurl_la-hostip.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-hostip.lo `test -f 'hostip.c' || echo '$(srcdir)/'`hostip.c + +libcurl_la-hostip4.lo: hostip4.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-hostip4.lo -MD -MP -MF $(DEPDIR)/libcurl_la-hostip4.Tpo -c -o libcurl_la-hostip4.lo `test -f 'hostip4.c' || echo '$(srcdir)/'`hostip4.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-hostip4.Tpo $(DEPDIR)/libcurl_la-hostip4.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='hostip4.c' object='libcurl_la-hostip4.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-hostip4.lo `test -f 'hostip4.c' || echo '$(srcdir)/'`hostip4.c + +libcurl_la-hostip6.lo: hostip6.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-hostip6.lo -MD -MP -MF $(DEPDIR)/libcurl_la-hostip6.Tpo -c -o libcurl_la-hostip6.lo `test -f 'hostip6.c' || echo '$(srcdir)/'`hostip6.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-hostip6.Tpo $(DEPDIR)/libcurl_la-hostip6.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='hostip6.c' object='libcurl_la-hostip6.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-hostip6.lo `test -f 'hostip6.c' || echo '$(srcdir)/'`hostip6.c + +libcurl_la-hsts.lo: hsts.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-hsts.lo -MD -MP -MF $(DEPDIR)/libcurl_la-hsts.Tpo -c -o libcurl_la-hsts.lo `test -f 'hsts.c' || echo '$(srcdir)/'`hsts.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-hsts.Tpo $(DEPDIR)/libcurl_la-hsts.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='hsts.c' object='libcurl_la-hsts.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-hsts.lo `test -f 'hsts.c' || echo '$(srcdir)/'`hsts.c + +libcurl_la-http.lo: http.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-http.lo -MD -MP -MF $(DEPDIR)/libcurl_la-http.Tpo -c -o libcurl_la-http.lo `test -f 'http.c' || echo '$(srcdir)/'`http.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-http.Tpo $(DEPDIR)/libcurl_la-http.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='http.c' object='libcurl_la-http.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-http.lo `test -f 'http.c' || echo '$(srcdir)/'`http.c + +libcurl_la-http1.lo: http1.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-http1.lo -MD -MP -MF $(DEPDIR)/libcurl_la-http1.Tpo -c -o libcurl_la-http1.lo `test -f 'http1.c' || echo '$(srcdir)/'`http1.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-http1.Tpo $(DEPDIR)/libcurl_la-http1.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='http1.c' object='libcurl_la-http1.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-http1.lo `test -f 'http1.c' || echo '$(srcdir)/'`http1.c + +libcurl_la-http2.lo: http2.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-http2.lo -MD -MP -MF $(DEPDIR)/libcurl_la-http2.Tpo -c -o libcurl_la-http2.lo `test -f 'http2.c' || echo '$(srcdir)/'`http2.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-http2.Tpo $(DEPDIR)/libcurl_la-http2.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='http2.c' object='libcurl_la-http2.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-http2.lo `test -f 'http2.c' || echo '$(srcdir)/'`http2.c + +libcurl_la-http_aws_sigv4.lo: http_aws_sigv4.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-http_aws_sigv4.lo -MD -MP -MF $(DEPDIR)/libcurl_la-http_aws_sigv4.Tpo -c -o libcurl_la-http_aws_sigv4.lo `test -f 'http_aws_sigv4.c' || echo '$(srcdir)/'`http_aws_sigv4.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-http_aws_sigv4.Tpo $(DEPDIR)/libcurl_la-http_aws_sigv4.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='http_aws_sigv4.c' object='libcurl_la-http_aws_sigv4.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-http_aws_sigv4.lo `test -f 'http_aws_sigv4.c' || echo '$(srcdir)/'`http_aws_sigv4.c + +libcurl_la-http_chunks.lo: http_chunks.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-http_chunks.lo -MD -MP -MF $(DEPDIR)/libcurl_la-http_chunks.Tpo -c -o libcurl_la-http_chunks.lo `test -f 'http_chunks.c' || echo '$(srcdir)/'`http_chunks.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-http_chunks.Tpo $(DEPDIR)/libcurl_la-http_chunks.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='http_chunks.c' object='libcurl_la-http_chunks.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-http_chunks.lo `test -f 'http_chunks.c' || echo '$(srcdir)/'`http_chunks.c + +libcurl_la-http_digest.lo: http_digest.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-http_digest.lo -MD -MP -MF $(DEPDIR)/libcurl_la-http_digest.Tpo -c -o libcurl_la-http_digest.lo `test -f 'http_digest.c' || echo '$(srcdir)/'`http_digest.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-http_digest.Tpo $(DEPDIR)/libcurl_la-http_digest.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='http_digest.c' object='libcurl_la-http_digest.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-http_digest.lo `test -f 'http_digest.c' || echo '$(srcdir)/'`http_digest.c + +libcurl_la-http_negotiate.lo: http_negotiate.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-http_negotiate.lo -MD -MP -MF $(DEPDIR)/libcurl_la-http_negotiate.Tpo -c -o libcurl_la-http_negotiate.lo `test -f 'http_negotiate.c' || echo '$(srcdir)/'`http_negotiate.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-http_negotiate.Tpo $(DEPDIR)/libcurl_la-http_negotiate.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='http_negotiate.c' object='libcurl_la-http_negotiate.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-http_negotiate.lo `test -f 'http_negotiate.c' || echo '$(srcdir)/'`http_negotiate.c + +libcurl_la-http_ntlm.lo: http_ntlm.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-http_ntlm.lo -MD -MP -MF $(DEPDIR)/libcurl_la-http_ntlm.Tpo -c -o libcurl_la-http_ntlm.lo `test -f 'http_ntlm.c' || echo '$(srcdir)/'`http_ntlm.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-http_ntlm.Tpo $(DEPDIR)/libcurl_la-http_ntlm.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='http_ntlm.c' object='libcurl_la-http_ntlm.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-http_ntlm.lo `test -f 'http_ntlm.c' || echo '$(srcdir)/'`http_ntlm.c + +libcurl_la-http_proxy.lo: http_proxy.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-http_proxy.lo -MD -MP -MF $(DEPDIR)/libcurl_la-http_proxy.Tpo -c -o libcurl_la-http_proxy.lo `test -f 'http_proxy.c' || echo '$(srcdir)/'`http_proxy.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-http_proxy.Tpo $(DEPDIR)/libcurl_la-http_proxy.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='http_proxy.c' object='libcurl_la-http_proxy.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-http_proxy.lo `test -f 'http_proxy.c' || echo '$(srcdir)/'`http_proxy.c + +libcurl_la-httpsrr.lo: httpsrr.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-httpsrr.lo -MD -MP -MF $(DEPDIR)/libcurl_la-httpsrr.Tpo -c -o libcurl_la-httpsrr.lo `test -f 'httpsrr.c' || echo '$(srcdir)/'`httpsrr.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-httpsrr.Tpo $(DEPDIR)/libcurl_la-httpsrr.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='httpsrr.c' object='libcurl_la-httpsrr.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-httpsrr.lo `test -f 'httpsrr.c' || echo '$(srcdir)/'`httpsrr.c + +libcurl_la-idn.lo: idn.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-idn.lo -MD -MP -MF $(DEPDIR)/libcurl_la-idn.Tpo -c -o libcurl_la-idn.lo `test -f 'idn.c' || echo '$(srcdir)/'`idn.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-idn.Tpo $(DEPDIR)/libcurl_la-idn.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='idn.c' object='libcurl_la-idn.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-idn.lo `test -f 'idn.c' || echo '$(srcdir)/'`idn.c + +libcurl_la-if2ip.lo: if2ip.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-if2ip.lo -MD -MP -MF $(DEPDIR)/libcurl_la-if2ip.Tpo -c -o libcurl_la-if2ip.lo `test -f 'if2ip.c' || echo '$(srcdir)/'`if2ip.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-if2ip.Tpo $(DEPDIR)/libcurl_la-if2ip.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='if2ip.c' object='libcurl_la-if2ip.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-if2ip.lo `test -f 'if2ip.c' || echo '$(srcdir)/'`if2ip.c + +libcurl_la-imap.lo: imap.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-imap.lo -MD -MP -MF $(DEPDIR)/libcurl_la-imap.Tpo -c -o libcurl_la-imap.lo `test -f 'imap.c' || echo '$(srcdir)/'`imap.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-imap.Tpo $(DEPDIR)/libcurl_la-imap.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='imap.c' object='libcurl_la-imap.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-imap.lo `test -f 'imap.c' || echo '$(srcdir)/'`imap.c + +libcurl_la-ldap.lo: ldap.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-ldap.lo -MD -MP -MF $(DEPDIR)/libcurl_la-ldap.Tpo -c -o libcurl_la-ldap.lo `test -f 'ldap.c' || echo '$(srcdir)/'`ldap.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-ldap.Tpo $(DEPDIR)/libcurl_la-ldap.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='ldap.c' object='libcurl_la-ldap.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-ldap.lo `test -f 'ldap.c' || echo '$(srcdir)/'`ldap.c + +libcurl_la-llist.lo: llist.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-llist.lo -MD -MP -MF $(DEPDIR)/libcurl_la-llist.Tpo -c -o libcurl_la-llist.lo `test -f 'llist.c' || echo '$(srcdir)/'`llist.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-llist.Tpo $(DEPDIR)/libcurl_la-llist.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='llist.c' object='libcurl_la-llist.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-llist.lo `test -f 'llist.c' || echo '$(srcdir)/'`llist.c + +libcurl_la-macos.lo: macos.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-macos.lo -MD -MP -MF $(DEPDIR)/libcurl_la-macos.Tpo -c -o libcurl_la-macos.lo `test -f 'macos.c' || echo '$(srcdir)/'`macos.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-macos.Tpo $(DEPDIR)/libcurl_la-macos.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='macos.c' object='libcurl_la-macos.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-macos.lo `test -f 'macos.c' || echo '$(srcdir)/'`macos.c + +libcurl_la-md4.lo: md4.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-md4.lo -MD -MP -MF $(DEPDIR)/libcurl_la-md4.Tpo -c -o libcurl_la-md4.lo `test -f 'md4.c' || echo '$(srcdir)/'`md4.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-md4.Tpo $(DEPDIR)/libcurl_la-md4.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='md4.c' object='libcurl_la-md4.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-md4.lo `test -f 'md4.c' || echo '$(srcdir)/'`md4.c + +libcurl_la-md5.lo: md5.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-md5.lo -MD -MP -MF $(DEPDIR)/libcurl_la-md5.Tpo -c -o libcurl_la-md5.lo `test -f 'md5.c' || echo '$(srcdir)/'`md5.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-md5.Tpo $(DEPDIR)/libcurl_la-md5.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='md5.c' object='libcurl_la-md5.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-md5.lo `test -f 'md5.c' || echo '$(srcdir)/'`md5.c + +libcurl_la-memdebug.lo: memdebug.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-memdebug.lo -MD -MP -MF $(DEPDIR)/libcurl_la-memdebug.Tpo -c -o libcurl_la-memdebug.lo `test -f 'memdebug.c' || echo '$(srcdir)/'`memdebug.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-memdebug.Tpo $(DEPDIR)/libcurl_la-memdebug.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='memdebug.c' object='libcurl_la-memdebug.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-memdebug.lo `test -f 'memdebug.c' || echo '$(srcdir)/'`memdebug.c + +libcurl_la-mime.lo: mime.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-mime.lo -MD -MP -MF $(DEPDIR)/libcurl_la-mime.Tpo -c -o libcurl_la-mime.lo `test -f 'mime.c' || echo '$(srcdir)/'`mime.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-mime.Tpo $(DEPDIR)/libcurl_la-mime.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='mime.c' object='libcurl_la-mime.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-mime.lo `test -f 'mime.c' || echo '$(srcdir)/'`mime.c + +libcurl_la-mprintf.lo: mprintf.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-mprintf.lo -MD -MP -MF $(DEPDIR)/libcurl_la-mprintf.Tpo -c -o libcurl_la-mprintf.lo `test -f 'mprintf.c' || echo '$(srcdir)/'`mprintf.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-mprintf.Tpo $(DEPDIR)/libcurl_la-mprintf.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='mprintf.c' object='libcurl_la-mprintf.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-mprintf.lo `test -f 'mprintf.c' || echo '$(srcdir)/'`mprintf.c + +libcurl_la-mqtt.lo: mqtt.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-mqtt.lo -MD -MP -MF $(DEPDIR)/libcurl_la-mqtt.Tpo -c -o libcurl_la-mqtt.lo `test -f 'mqtt.c' || echo '$(srcdir)/'`mqtt.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-mqtt.Tpo $(DEPDIR)/libcurl_la-mqtt.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='mqtt.c' object='libcurl_la-mqtt.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-mqtt.lo `test -f 'mqtt.c' || echo '$(srcdir)/'`mqtt.c + +libcurl_la-multi.lo: multi.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-multi.lo -MD -MP -MF $(DEPDIR)/libcurl_la-multi.Tpo -c -o libcurl_la-multi.lo `test -f 'multi.c' || echo '$(srcdir)/'`multi.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-multi.Tpo $(DEPDIR)/libcurl_la-multi.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='multi.c' object='libcurl_la-multi.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-multi.lo `test -f 'multi.c' || echo '$(srcdir)/'`multi.c + +libcurl_la-multi_ev.lo: multi_ev.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-multi_ev.lo -MD -MP -MF $(DEPDIR)/libcurl_la-multi_ev.Tpo -c -o libcurl_la-multi_ev.lo `test -f 'multi_ev.c' || echo '$(srcdir)/'`multi_ev.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-multi_ev.Tpo $(DEPDIR)/libcurl_la-multi_ev.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='multi_ev.c' object='libcurl_la-multi_ev.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-multi_ev.lo `test -f 'multi_ev.c' || echo '$(srcdir)/'`multi_ev.c + +libcurl_la-multi_ntfy.lo: multi_ntfy.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-multi_ntfy.lo -MD -MP -MF $(DEPDIR)/libcurl_la-multi_ntfy.Tpo -c -o libcurl_la-multi_ntfy.lo `test -f 'multi_ntfy.c' || echo '$(srcdir)/'`multi_ntfy.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-multi_ntfy.Tpo $(DEPDIR)/libcurl_la-multi_ntfy.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='multi_ntfy.c' object='libcurl_la-multi_ntfy.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-multi_ntfy.lo `test -f 'multi_ntfy.c' || echo '$(srcdir)/'`multi_ntfy.c + +libcurl_la-netrc.lo: netrc.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-netrc.lo -MD -MP -MF $(DEPDIR)/libcurl_la-netrc.Tpo -c -o libcurl_la-netrc.lo `test -f 'netrc.c' || echo '$(srcdir)/'`netrc.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-netrc.Tpo $(DEPDIR)/libcurl_la-netrc.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='netrc.c' object='libcurl_la-netrc.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-netrc.lo `test -f 'netrc.c' || echo '$(srcdir)/'`netrc.c + +libcurl_la-openldap.lo: openldap.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-openldap.lo -MD -MP -MF $(DEPDIR)/libcurl_la-openldap.Tpo -c -o libcurl_la-openldap.lo `test -f 'openldap.c' || echo '$(srcdir)/'`openldap.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-openldap.Tpo $(DEPDIR)/libcurl_la-openldap.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='openldap.c' object='libcurl_la-openldap.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-openldap.lo `test -f 'openldap.c' || echo '$(srcdir)/'`openldap.c + +libcurl_la-parsedate.lo: parsedate.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-parsedate.lo -MD -MP -MF $(DEPDIR)/libcurl_la-parsedate.Tpo -c -o libcurl_la-parsedate.lo `test -f 'parsedate.c' || echo '$(srcdir)/'`parsedate.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-parsedate.Tpo $(DEPDIR)/libcurl_la-parsedate.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='parsedate.c' object='libcurl_la-parsedate.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-parsedate.lo `test -f 'parsedate.c' || echo '$(srcdir)/'`parsedate.c + +libcurl_la-peer.lo: peer.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-peer.lo -MD -MP -MF $(DEPDIR)/libcurl_la-peer.Tpo -c -o libcurl_la-peer.lo `test -f 'peer.c' || echo '$(srcdir)/'`peer.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-peer.Tpo $(DEPDIR)/libcurl_la-peer.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='peer.c' object='libcurl_la-peer.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-peer.lo `test -f 'peer.c' || echo '$(srcdir)/'`peer.c + +libcurl_la-pingpong.lo: pingpong.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-pingpong.lo -MD -MP -MF $(DEPDIR)/libcurl_la-pingpong.Tpo -c -o libcurl_la-pingpong.lo `test -f 'pingpong.c' || echo '$(srcdir)/'`pingpong.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-pingpong.Tpo $(DEPDIR)/libcurl_la-pingpong.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='pingpong.c' object='libcurl_la-pingpong.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-pingpong.lo `test -f 'pingpong.c' || echo '$(srcdir)/'`pingpong.c + +libcurl_la-pop3.lo: pop3.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-pop3.lo -MD -MP -MF $(DEPDIR)/libcurl_la-pop3.Tpo -c -o libcurl_la-pop3.lo `test -f 'pop3.c' || echo '$(srcdir)/'`pop3.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-pop3.Tpo $(DEPDIR)/libcurl_la-pop3.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='pop3.c' object='libcurl_la-pop3.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-pop3.lo `test -f 'pop3.c' || echo '$(srcdir)/'`pop3.c + +libcurl_la-progress.lo: progress.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-progress.lo -MD -MP -MF $(DEPDIR)/libcurl_la-progress.Tpo -c -o libcurl_la-progress.lo `test -f 'progress.c' || echo '$(srcdir)/'`progress.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-progress.Tpo $(DEPDIR)/libcurl_la-progress.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='progress.c' object='libcurl_la-progress.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-progress.lo `test -f 'progress.c' || echo '$(srcdir)/'`progress.c + +libcurl_la-protocol.lo: protocol.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-protocol.lo -MD -MP -MF $(DEPDIR)/libcurl_la-protocol.Tpo -c -o libcurl_la-protocol.lo `test -f 'protocol.c' || echo '$(srcdir)/'`protocol.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-protocol.Tpo $(DEPDIR)/libcurl_la-protocol.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='protocol.c' object='libcurl_la-protocol.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-protocol.lo `test -f 'protocol.c' || echo '$(srcdir)/'`protocol.c + +libcurl_la-proxy.lo: proxy.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-proxy.lo -MD -MP -MF $(DEPDIR)/libcurl_la-proxy.Tpo -c -o libcurl_la-proxy.lo `test -f 'proxy.c' || echo '$(srcdir)/'`proxy.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-proxy.Tpo $(DEPDIR)/libcurl_la-proxy.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='proxy.c' object='libcurl_la-proxy.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-proxy.lo `test -f 'proxy.c' || echo '$(srcdir)/'`proxy.c + +libcurl_la-psl.lo: psl.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-psl.lo -MD -MP -MF $(DEPDIR)/libcurl_la-psl.Tpo -c -o libcurl_la-psl.lo `test -f 'psl.c' || echo '$(srcdir)/'`psl.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-psl.Tpo $(DEPDIR)/libcurl_la-psl.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='psl.c' object='libcurl_la-psl.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-psl.lo `test -f 'psl.c' || echo '$(srcdir)/'`psl.c + +libcurl_la-rand.lo: rand.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-rand.lo -MD -MP -MF $(DEPDIR)/libcurl_la-rand.Tpo -c -o libcurl_la-rand.lo `test -f 'rand.c' || echo '$(srcdir)/'`rand.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-rand.Tpo $(DEPDIR)/libcurl_la-rand.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='rand.c' object='libcurl_la-rand.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-rand.lo `test -f 'rand.c' || echo '$(srcdir)/'`rand.c + +libcurl_la-ratelimit.lo: ratelimit.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-ratelimit.lo -MD -MP -MF $(DEPDIR)/libcurl_la-ratelimit.Tpo -c -o libcurl_la-ratelimit.lo `test -f 'ratelimit.c' || echo '$(srcdir)/'`ratelimit.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-ratelimit.Tpo $(DEPDIR)/libcurl_la-ratelimit.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='ratelimit.c' object='libcurl_la-ratelimit.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-ratelimit.lo `test -f 'ratelimit.c' || echo '$(srcdir)/'`ratelimit.c + +libcurl_la-request.lo: request.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-request.lo -MD -MP -MF $(DEPDIR)/libcurl_la-request.Tpo -c -o libcurl_la-request.lo `test -f 'request.c' || echo '$(srcdir)/'`request.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-request.Tpo $(DEPDIR)/libcurl_la-request.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='request.c' object='libcurl_la-request.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-request.lo `test -f 'request.c' || echo '$(srcdir)/'`request.c + +libcurl_la-rtsp.lo: rtsp.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-rtsp.lo -MD -MP -MF $(DEPDIR)/libcurl_la-rtsp.Tpo -c -o libcurl_la-rtsp.lo `test -f 'rtsp.c' || echo '$(srcdir)/'`rtsp.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-rtsp.Tpo $(DEPDIR)/libcurl_la-rtsp.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='rtsp.c' object='libcurl_la-rtsp.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-rtsp.lo `test -f 'rtsp.c' || echo '$(srcdir)/'`rtsp.c + +libcurl_la-select.lo: select.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-select.lo -MD -MP -MF $(DEPDIR)/libcurl_la-select.Tpo -c -o libcurl_la-select.lo `test -f 'select.c' || echo '$(srcdir)/'`select.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-select.Tpo $(DEPDIR)/libcurl_la-select.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='select.c' object='libcurl_la-select.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-select.lo `test -f 'select.c' || echo '$(srcdir)/'`select.c + +libcurl_la-sendf.lo: sendf.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-sendf.lo -MD -MP -MF $(DEPDIR)/libcurl_la-sendf.Tpo -c -o libcurl_la-sendf.lo `test -f 'sendf.c' || echo '$(srcdir)/'`sendf.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-sendf.Tpo $(DEPDIR)/libcurl_la-sendf.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='sendf.c' object='libcurl_la-sendf.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-sendf.lo `test -f 'sendf.c' || echo '$(srcdir)/'`sendf.c + +libcurl_la-setopt.lo: setopt.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-setopt.lo -MD -MP -MF $(DEPDIR)/libcurl_la-setopt.Tpo -c -o libcurl_la-setopt.lo `test -f 'setopt.c' || echo '$(srcdir)/'`setopt.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-setopt.Tpo $(DEPDIR)/libcurl_la-setopt.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='setopt.c' object='libcurl_la-setopt.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-setopt.lo `test -f 'setopt.c' || echo '$(srcdir)/'`setopt.c + +libcurl_la-sha256.lo: sha256.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-sha256.lo -MD -MP -MF $(DEPDIR)/libcurl_la-sha256.Tpo -c -o libcurl_la-sha256.lo `test -f 'sha256.c' || echo '$(srcdir)/'`sha256.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-sha256.Tpo $(DEPDIR)/libcurl_la-sha256.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='sha256.c' object='libcurl_la-sha256.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-sha256.lo `test -f 'sha256.c' || echo '$(srcdir)/'`sha256.c + +libcurl_la-slist.lo: slist.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-slist.lo -MD -MP -MF $(DEPDIR)/libcurl_la-slist.Tpo -c -o libcurl_la-slist.lo `test -f 'slist.c' || echo '$(srcdir)/'`slist.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-slist.Tpo $(DEPDIR)/libcurl_la-slist.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='slist.c' object='libcurl_la-slist.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-slist.lo `test -f 'slist.c' || echo '$(srcdir)/'`slist.c + +libcurl_la-smb.lo: smb.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-smb.lo -MD -MP -MF $(DEPDIR)/libcurl_la-smb.Tpo -c -o libcurl_la-smb.lo `test -f 'smb.c' || echo '$(srcdir)/'`smb.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-smb.Tpo $(DEPDIR)/libcurl_la-smb.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='smb.c' object='libcurl_la-smb.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-smb.lo `test -f 'smb.c' || echo '$(srcdir)/'`smb.c + +libcurl_la-smtp.lo: smtp.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-smtp.lo -MD -MP -MF $(DEPDIR)/libcurl_la-smtp.Tpo -c -o libcurl_la-smtp.lo `test -f 'smtp.c' || echo '$(srcdir)/'`smtp.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-smtp.Tpo $(DEPDIR)/libcurl_la-smtp.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='smtp.c' object='libcurl_la-smtp.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-smtp.lo `test -f 'smtp.c' || echo '$(srcdir)/'`smtp.c + +libcurl_la-socketpair.lo: socketpair.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-socketpair.lo -MD -MP -MF $(DEPDIR)/libcurl_la-socketpair.Tpo -c -o libcurl_la-socketpair.lo `test -f 'socketpair.c' || echo '$(srcdir)/'`socketpair.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-socketpair.Tpo $(DEPDIR)/libcurl_la-socketpair.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='socketpair.c' object='libcurl_la-socketpair.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-socketpair.lo `test -f 'socketpair.c' || echo '$(srcdir)/'`socketpair.c + +libcurl_la-socks.lo: socks.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-socks.lo -MD -MP -MF $(DEPDIR)/libcurl_la-socks.Tpo -c -o libcurl_la-socks.lo `test -f 'socks.c' || echo '$(srcdir)/'`socks.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-socks.Tpo $(DEPDIR)/libcurl_la-socks.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='socks.c' object='libcurl_la-socks.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-socks.lo `test -f 'socks.c' || echo '$(srcdir)/'`socks.c + +libcurl_la-socks_gssapi.lo: socks_gssapi.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-socks_gssapi.lo -MD -MP -MF $(DEPDIR)/libcurl_la-socks_gssapi.Tpo -c -o libcurl_la-socks_gssapi.lo `test -f 'socks_gssapi.c' || echo '$(srcdir)/'`socks_gssapi.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-socks_gssapi.Tpo $(DEPDIR)/libcurl_la-socks_gssapi.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='socks_gssapi.c' object='libcurl_la-socks_gssapi.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-socks_gssapi.lo `test -f 'socks_gssapi.c' || echo '$(srcdir)/'`socks_gssapi.c + +libcurl_la-socks_sspi.lo: socks_sspi.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-socks_sspi.lo -MD -MP -MF $(DEPDIR)/libcurl_la-socks_sspi.Tpo -c -o libcurl_la-socks_sspi.lo `test -f 'socks_sspi.c' || echo '$(srcdir)/'`socks_sspi.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-socks_sspi.Tpo $(DEPDIR)/libcurl_la-socks_sspi.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='socks_sspi.c' object='libcurl_la-socks_sspi.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-socks_sspi.lo `test -f 'socks_sspi.c' || echo '$(srcdir)/'`socks_sspi.c + +libcurl_la-splay.lo: splay.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-splay.lo -MD -MP -MF $(DEPDIR)/libcurl_la-splay.Tpo -c -o libcurl_la-splay.lo `test -f 'splay.c' || echo '$(srcdir)/'`splay.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-splay.Tpo $(DEPDIR)/libcurl_la-splay.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='splay.c' object='libcurl_la-splay.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-splay.lo `test -f 'splay.c' || echo '$(srcdir)/'`splay.c + +libcurl_la-strcase.lo: strcase.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-strcase.lo -MD -MP -MF $(DEPDIR)/libcurl_la-strcase.Tpo -c -o libcurl_la-strcase.lo `test -f 'strcase.c' || echo '$(srcdir)/'`strcase.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-strcase.Tpo $(DEPDIR)/libcurl_la-strcase.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='strcase.c' object='libcurl_la-strcase.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-strcase.lo `test -f 'strcase.c' || echo '$(srcdir)/'`strcase.c + +libcurl_la-strequal.lo: strequal.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-strequal.lo -MD -MP -MF $(DEPDIR)/libcurl_la-strequal.Tpo -c -o libcurl_la-strequal.lo `test -f 'strequal.c' || echo '$(srcdir)/'`strequal.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-strequal.Tpo $(DEPDIR)/libcurl_la-strequal.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='strequal.c' object='libcurl_la-strequal.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-strequal.lo `test -f 'strequal.c' || echo '$(srcdir)/'`strequal.c + +libcurl_la-strerror.lo: strerror.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-strerror.lo -MD -MP -MF $(DEPDIR)/libcurl_la-strerror.Tpo -c -o libcurl_la-strerror.lo `test -f 'strerror.c' || echo '$(srcdir)/'`strerror.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-strerror.Tpo $(DEPDIR)/libcurl_la-strerror.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='strerror.c' object='libcurl_la-strerror.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-strerror.lo `test -f 'strerror.c' || echo '$(srcdir)/'`strerror.c + +libcurl_la-system_win32.lo: system_win32.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-system_win32.lo -MD -MP -MF $(DEPDIR)/libcurl_la-system_win32.Tpo -c -o libcurl_la-system_win32.lo `test -f 'system_win32.c' || echo '$(srcdir)/'`system_win32.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-system_win32.Tpo $(DEPDIR)/libcurl_la-system_win32.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='system_win32.c' object='libcurl_la-system_win32.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-system_win32.lo `test -f 'system_win32.c' || echo '$(srcdir)/'`system_win32.c + +libcurl_la-telnet.lo: telnet.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-telnet.lo -MD -MP -MF $(DEPDIR)/libcurl_la-telnet.Tpo -c -o libcurl_la-telnet.lo `test -f 'telnet.c' || echo '$(srcdir)/'`telnet.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-telnet.Tpo $(DEPDIR)/libcurl_la-telnet.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='telnet.c' object='libcurl_la-telnet.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-telnet.lo `test -f 'telnet.c' || echo '$(srcdir)/'`telnet.c + +libcurl_la-tftp.lo: tftp.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-tftp.lo -MD -MP -MF $(DEPDIR)/libcurl_la-tftp.Tpo -c -o libcurl_la-tftp.lo `test -f 'tftp.c' || echo '$(srcdir)/'`tftp.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-tftp.Tpo $(DEPDIR)/libcurl_la-tftp.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='tftp.c' object='libcurl_la-tftp.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-tftp.lo `test -f 'tftp.c' || echo '$(srcdir)/'`tftp.c + +libcurl_la-thrdpool.lo: thrdpool.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-thrdpool.lo -MD -MP -MF $(DEPDIR)/libcurl_la-thrdpool.Tpo -c -o libcurl_la-thrdpool.lo `test -f 'thrdpool.c' || echo '$(srcdir)/'`thrdpool.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-thrdpool.Tpo $(DEPDIR)/libcurl_la-thrdpool.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='thrdpool.c' object='libcurl_la-thrdpool.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-thrdpool.lo `test -f 'thrdpool.c' || echo '$(srcdir)/'`thrdpool.c + +libcurl_la-thrdqueue.lo: thrdqueue.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-thrdqueue.lo -MD -MP -MF $(DEPDIR)/libcurl_la-thrdqueue.Tpo -c -o libcurl_la-thrdqueue.lo `test -f 'thrdqueue.c' || echo '$(srcdir)/'`thrdqueue.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-thrdqueue.Tpo $(DEPDIR)/libcurl_la-thrdqueue.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='thrdqueue.c' object='libcurl_la-thrdqueue.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-thrdqueue.lo `test -f 'thrdqueue.c' || echo '$(srcdir)/'`thrdqueue.c + +libcurl_la-transfer.lo: transfer.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-transfer.lo -MD -MP -MF $(DEPDIR)/libcurl_la-transfer.Tpo -c -o libcurl_la-transfer.lo `test -f 'transfer.c' || echo '$(srcdir)/'`transfer.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-transfer.Tpo $(DEPDIR)/libcurl_la-transfer.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='transfer.c' object='libcurl_la-transfer.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-transfer.lo `test -f 'transfer.c' || echo '$(srcdir)/'`transfer.c + +libcurl_la-uint-bset.lo: uint-bset.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-uint-bset.lo -MD -MP -MF $(DEPDIR)/libcurl_la-uint-bset.Tpo -c -o libcurl_la-uint-bset.lo `test -f 'uint-bset.c' || echo '$(srcdir)/'`uint-bset.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-uint-bset.Tpo $(DEPDIR)/libcurl_la-uint-bset.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='uint-bset.c' object='libcurl_la-uint-bset.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-uint-bset.lo `test -f 'uint-bset.c' || echo '$(srcdir)/'`uint-bset.c + +libcurl_la-uint-hash.lo: uint-hash.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-uint-hash.lo -MD -MP -MF $(DEPDIR)/libcurl_la-uint-hash.Tpo -c -o libcurl_la-uint-hash.lo `test -f 'uint-hash.c' || echo '$(srcdir)/'`uint-hash.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-uint-hash.Tpo $(DEPDIR)/libcurl_la-uint-hash.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='uint-hash.c' object='libcurl_la-uint-hash.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-uint-hash.lo `test -f 'uint-hash.c' || echo '$(srcdir)/'`uint-hash.c + +libcurl_la-uint-spbset.lo: uint-spbset.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-uint-spbset.lo -MD -MP -MF $(DEPDIR)/libcurl_la-uint-spbset.Tpo -c -o libcurl_la-uint-spbset.lo `test -f 'uint-spbset.c' || echo '$(srcdir)/'`uint-spbset.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-uint-spbset.Tpo $(DEPDIR)/libcurl_la-uint-spbset.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='uint-spbset.c' object='libcurl_la-uint-spbset.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-uint-spbset.lo `test -f 'uint-spbset.c' || echo '$(srcdir)/'`uint-spbset.c + +libcurl_la-uint-table.lo: uint-table.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-uint-table.lo -MD -MP -MF $(DEPDIR)/libcurl_la-uint-table.Tpo -c -o libcurl_la-uint-table.lo `test -f 'uint-table.c' || echo '$(srcdir)/'`uint-table.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-uint-table.Tpo $(DEPDIR)/libcurl_la-uint-table.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='uint-table.c' object='libcurl_la-uint-table.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-uint-table.lo `test -f 'uint-table.c' || echo '$(srcdir)/'`uint-table.c + +libcurl_la-url.lo: url.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-url.lo -MD -MP -MF $(DEPDIR)/libcurl_la-url.Tpo -c -o libcurl_la-url.lo `test -f 'url.c' || echo '$(srcdir)/'`url.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-url.Tpo $(DEPDIR)/libcurl_la-url.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='url.c' object='libcurl_la-url.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-url.lo `test -f 'url.c' || echo '$(srcdir)/'`url.c + +libcurl_la-urlapi.lo: urlapi.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-urlapi.lo -MD -MP -MF $(DEPDIR)/libcurl_la-urlapi.Tpo -c -o libcurl_la-urlapi.lo `test -f 'urlapi.c' || echo '$(srcdir)/'`urlapi.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-urlapi.Tpo $(DEPDIR)/libcurl_la-urlapi.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='urlapi.c' object='libcurl_la-urlapi.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-urlapi.lo `test -f 'urlapi.c' || echo '$(srcdir)/'`urlapi.c + +libcurl_la-version.lo: version.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-version.lo -MD -MP -MF $(DEPDIR)/libcurl_la-version.Tpo -c -o libcurl_la-version.lo `test -f 'version.c' || echo '$(srcdir)/'`version.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-version.Tpo $(DEPDIR)/libcurl_la-version.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='version.c' object='libcurl_la-version.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-version.lo `test -f 'version.c' || echo '$(srcdir)/'`version.c + +libcurl_la-ws.lo: ws.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-ws.lo -MD -MP -MF $(DEPDIR)/libcurl_la-ws.Tpo -c -o libcurl_la-ws.lo `test -f 'ws.c' || echo '$(srcdir)/'`ws.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-ws.Tpo $(DEPDIR)/libcurl_la-ws.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='ws.c' object='libcurl_la-ws.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-ws.lo `test -f 'ws.c' || echo '$(srcdir)/'`ws.c + +vauth/libcurl_la-cleartext.lo: vauth/cleartext.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vauth/libcurl_la-cleartext.lo -MD -MP -MF vauth/$(DEPDIR)/libcurl_la-cleartext.Tpo -c -o vauth/libcurl_la-cleartext.lo `test -f 'vauth/cleartext.c' || echo '$(srcdir)/'`vauth/cleartext.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vauth/$(DEPDIR)/libcurl_la-cleartext.Tpo vauth/$(DEPDIR)/libcurl_la-cleartext.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vauth/cleartext.c' object='vauth/libcurl_la-cleartext.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vauth/libcurl_la-cleartext.lo `test -f 'vauth/cleartext.c' || echo '$(srcdir)/'`vauth/cleartext.c + +vauth/libcurl_la-cram.lo: vauth/cram.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vauth/libcurl_la-cram.lo -MD -MP -MF vauth/$(DEPDIR)/libcurl_la-cram.Tpo -c -o vauth/libcurl_la-cram.lo `test -f 'vauth/cram.c' || echo '$(srcdir)/'`vauth/cram.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vauth/$(DEPDIR)/libcurl_la-cram.Tpo vauth/$(DEPDIR)/libcurl_la-cram.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vauth/cram.c' object='vauth/libcurl_la-cram.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vauth/libcurl_la-cram.lo `test -f 'vauth/cram.c' || echo '$(srcdir)/'`vauth/cram.c + +vauth/libcurl_la-digest.lo: vauth/digest.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vauth/libcurl_la-digest.lo -MD -MP -MF vauth/$(DEPDIR)/libcurl_la-digest.Tpo -c -o vauth/libcurl_la-digest.lo `test -f 'vauth/digest.c' || echo '$(srcdir)/'`vauth/digest.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vauth/$(DEPDIR)/libcurl_la-digest.Tpo vauth/$(DEPDIR)/libcurl_la-digest.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vauth/digest.c' object='vauth/libcurl_la-digest.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vauth/libcurl_la-digest.lo `test -f 'vauth/digest.c' || echo '$(srcdir)/'`vauth/digest.c + +vauth/libcurl_la-digest_sspi.lo: vauth/digest_sspi.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vauth/libcurl_la-digest_sspi.lo -MD -MP -MF vauth/$(DEPDIR)/libcurl_la-digest_sspi.Tpo -c -o vauth/libcurl_la-digest_sspi.lo `test -f 'vauth/digest_sspi.c' || echo '$(srcdir)/'`vauth/digest_sspi.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vauth/$(DEPDIR)/libcurl_la-digest_sspi.Tpo vauth/$(DEPDIR)/libcurl_la-digest_sspi.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vauth/digest_sspi.c' object='vauth/libcurl_la-digest_sspi.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vauth/libcurl_la-digest_sspi.lo `test -f 'vauth/digest_sspi.c' || echo '$(srcdir)/'`vauth/digest_sspi.c + +vauth/libcurl_la-gsasl.lo: vauth/gsasl.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vauth/libcurl_la-gsasl.lo -MD -MP -MF vauth/$(DEPDIR)/libcurl_la-gsasl.Tpo -c -o vauth/libcurl_la-gsasl.lo `test -f 'vauth/gsasl.c' || echo '$(srcdir)/'`vauth/gsasl.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vauth/$(DEPDIR)/libcurl_la-gsasl.Tpo vauth/$(DEPDIR)/libcurl_la-gsasl.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vauth/gsasl.c' object='vauth/libcurl_la-gsasl.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vauth/libcurl_la-gsasl.lo `test -f 'vauth/gsasl.c' || echo '$(srcdir)/'`vauth/gsasl.c + +vauth/libcurl_la-krb5_gssapi.lo: vauth/krb5_gssapi.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vauth/libcurl_la-krb5_gssapi.lo -MD -MP -MF vauth/$(DEPDIR)/libcurl_la-krb5_gssapi.Tpo -c -o vauth/libcurl_la-krb5_gssapi.lo `test -f 'vauth/krb5_gssapi.c' || echo '$(srcdir)/'`vauth/krb5_gssapi.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vauth/$(DEPDIR)/libcurl_la-krb5_gssapi.Tpo vauth/$(DEPDIR)/libcurl_la-krb5_gssapi.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vauth/krb5_gssapi.c' object='vauth/libcurl_la-krb5_gssapi.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vauth/libcurl_la-krb5_gssapi.lo `test -f 'vauth/krb5_gssapi.c' || echo '$(srcdir)/'`vauth/krb5_gssapi.c + +vauth/libcurl_la-krb5_sspi.lo: vauth/krb5_sspi.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vauth/libcurl_la-krb5_sspi.lo -MD -MP -MF vauth/$(DEPDIR)/libcurl_la-krb5_sspi.Tpo -c -o vauth/libcurl_la-krb5_sspi.lo `test -f 'vauth/krb5_sspi.c' || echo '$(srcdir)/'`vauth/krb5_sspi.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vauth/$(DEPDIR)/libcurl_la-krb5_sspi.Tpo vauth/$(DEPDIR)/libcurl_la-krb5_sspi.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vauth/krb5_sspi.c' object='vauth/libcurl_la-krb5_sspi.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vauth/libcurl_la-krb5_sspi.lo `test -f 'vauth/krb5_sspi.c' || echo '$(srcdir)/'`vauth/krb5_sspi.c + +vauth/libcurl_la-ntlm.lo: vauth/ntlm.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vauth/libcurl_la-ntlm.lo -MD -MP -MF vauth/$(DEPDIR)/libcurl_la-ntlm.Tpo -c -o vauth/libcurl_la-ntlm.lo `test -f 'vauth/ntlm.c' || echo '$(srcdir)/'`vauth/ntlm.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vauth/$(DEPDIR)/libcurl_la-ntlm.Tpo vauth/$(DEPDIR)/libcurl_la-ntlm.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vauth/ntlm.c' object='vauth/libcurl_la-ntlm.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vauth/libcurl_la-ntlm.lo `test -f 'vauth/ntlm.c' || echo '$(srcdir)/'`vauth/ntlm.c + +vauth/libcurl_la-ntlm_sspi.lo: vauth/ntlm_sspi.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vauth/libcurl_la-ntlm_sspi.lo -MD -MP -MF vauth/$(DEPDIR)/libcurl_la-ntlm_sspi.Tpo -c -o vauth/libcurl_la-ntlm_sspi.lo `test -f 'vauth/ntlm_sspi.c' || echo '$(srcdir)/'`vauth/ntlm_sspi.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vauth/$(DEPDIR)/libcurl_la-ntlm_sspi.Tpo vauth/$(DEPDIR)/libcurl_la-ntlm_sspi.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vauth/ntlm_sspi.c' object='vauth/libcurl_la-ntlm_sspi.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vauth/libcurl_la-ntlm_sspi.lo `test -f 'vauth/ntlm_sspi.c' || echo '$(srcdir)/'`vauth/ntlm_sspi.c + +vauth/libcurl_la-oauth2.lo: vauth/oauth2.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vauth/libcurl_la-oauth2.lo -MD -MP -MF vauth/$(DEPDIR)/libcurl_la-oauth2.Tpo -c -o vauth/libcurl_la-oauth2.lo `test -f 'vauth/oauth2.c' || echo '$(srcdir)/'`vauth/oauth2.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vauth/$(DEPDIR)/libcurl_la-oauth2.Tpo vauth/$(DEPDIR)/libcurl_la-oauth2.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vauth/oauth2.c' object='vauth/libcurl_la-oauth2.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vauth/libcurl_la-oauth2.lo `test -f 'vauth/oauth2.c' || echo '$(srcdir)/'`vauth/oauth2.c + +vauth/libcurl_la-spnego_gssapi.lo: vauth/spnego_gssapi.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vauth/libcurl_la-spnego_gssapi.lo -MD -MP -MF vauth/$(DEPDIR)/libcurl_la-spnego_gssapi.Tpo -c -o vauth/libcurl_la-spnego_gssapi.lo `test -f 'vauth/spnego_gssapi.c' || echo '$(srcdir)/'`vauth/spnego_gssapi.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vauth/$(DEPDIR)/libcurl_la-spnego_gssapi.Tpo vauth/$(DEPDIR)/libcurl_la-spnego_gssapi.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vauth/spnego_gssapi.c' object='vauth/libcurl_la-spnego_gssapi.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vauth/libcurl_la-spnego_gssapi.lo `test -f 'vauth/spnego_gssapi.c' || echo '$(srcdir)/'`vauth/spnego_gssapi.c + +vauth/libcurl_la-spnego_sspi.lo: vauth/spnego_sspi.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vauth/libcurl_la-spnego_sspi.lo -MD -MP -MF vauth/$(DEPDIR)/libcurl_la-spnego_sspi.Tpo -c -o vauth/libcurl_la-spnego_sspi.lo `test -f 'vauth/spnego_sspi.c' || echo '$(srcdir)/'`vauth/spnego_sspi.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vauth/$(DEPDIR)/libcurl_la-spnego_sspi.Tpo vauth/$(DEPDIR)/libcurl_la-spnego_sspi.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vauth/spnego_sspi.c' object='vauth/libcurl_la-spnego_sspi.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vauth/libcurl_la-spnego_sspi.lo `test -f 'vauth/spnego_sspi.c' || echo '$(srcdir)/'`vauth/spnego_sspi.c + +vauth/libcurl_la-vauth.lo: vauth/vauth.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vauth/libcurl_la-vauth.lo -MD -MP -MF vauth/$(DEPDIR)/libcurl_la-vauth.Tpo -c -o vauth/libcurl_la-vauth.lo `test -f 'vauth/vauth.c' || echo '$(srcdir)/'`vauth/vauth.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vauth/$(DEPDIR)/libcurl_la-vauth.Tpo vauth/$(DEPDIR)/libcurl_la-vauth.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vauth/vauth.c' object='vauth/libcurl_la-vauth.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vauth/libcurl_la-vauth.lo `test -f 'vauth/vauth.c' || echo '$(srcdir)/'`vauth/vauth.c + +vtls/libcurl_la-apple.lo: vtls/apple.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vtls/libcurl_la-apple.lo -MD -MP -MF vtls/$(DEPDIR)/libcurl_la-apple.Tpo -c -o vtls/libcurl_la-apple.lo `test -f 'vtls/apple.c' || echo '$(srcdir)/'`vtls/apple.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vtls/$(DEPDIR)/libcurl_la-apple.Tpo vtls/$(DEPDIR)/libcurl_la-apple.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vtls/apple.c' object='vtls/libcurl_la-apple.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vtls/libcurl_la-apple.lo `test -f 'vtls/apple.c' || echo '$(srcdir)/'`vtls/apple.c + +vtls/libcurl_la-cipher_suite.lo: vtls/cipher_suite.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vtls/libcurl_la-cipher_suite.lo -MD -MP -MF vtls/$(DEPDIR)/libcurl_la-cipher_suite.Tpo -c -o vtls/libcurl_la-cipher_suite.lo `test -f 'vtls/cipher_suite.c' || echo '$(srcdir)/'`vtls/cipher_suite.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vtls/$(DEPDIR)/libcurl_la-cipher_suite.Tpo vtls/$(DEPDIR)/libcurl_la-cipher_suite.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vtls/cipher_suite.c' object='vtls/libcurl_la-cipher_suite.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vtls/libcurl_la-cipher_suite.lo `test -f 'vtls/cipher_suite.c' || echo '$(srcdir)/'`vtls/cipher_suite.c + +vtls/libcurl_la-gtls.lo: vtls/gtls.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vtls/libcurl_la-gtls.lo -MD -MP -MF vtls/$(DEPDIR)/libcurl_la-gtls.Tpo -c -o vtls/libcurl_la-gtls.lo `test -f 'vtls/gtls.c' || echo '$(srcdir)/'`vtls/gtls.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vtls/$(DEPDIR)/libcurl_la-gtls.Tpo vtls/$(DEPDIR)/libcurl_la-gtls.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vtls/gtls.c' object='vtls/libcurl_la-gtls.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vtls/libcurl_la-gtls.lo `test -f 'vtls/gtls.c' || echo '$(srcdir)/'`vtls/gtls.c + +vtls/libcurl_la-hostcheck.lo: vtls/hostcheck.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vtls/libcurl_la-hostcheck.lo -MD -MP -MF vtls/$(DEPDIR)/libcurl_la-hostcheck.Tpo -c -o vtls/libcurl_la-hostcheck.lo `test -f 'vtls/hostcheck.c' || echo '$(srcdir)/'`vtls/hostcheck.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vtls/$(DEPDIR)/libcurl_la-hostcheck.Tpo vtls/$(DEPDIR)/libcurl_la-hostcheck.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vtls/hostcheck.c' object='vtls/libcurl_la-hostcheck.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vtls/libcurl_la-hostcheck.lo `test -f 'vtls/hostcheck.c' || echo '$(srcdir)/'`vtls/hostcheck.c + +vtls/libcurl_la-keylog.lo: vtls/keylog.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vtls/libcurl_la-keylog.lo -MD -MP -MF vtls/$(DEPDIR)/libcurl_la-keylog.Tpo -c -o vtls/libcurl_la-keylog.lo `test -f 'vtls/keylog.c' || echo '$(srcdir)/'`vtls/keylog.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vtls/$(DEPDIR)/libcurl_la-keylog.Tpo vtls/$(DEPDIR)/libcurl_la-keylog.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vtls/keylog.c' object='vtls/libcurl_la-keylog.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vtls/libcurl_la-keylog.lo `test -f 'vtls/keylog.c' || echo '$(srcdir)/'`vtls/keylog.c + +vtls/libcurl_la-mbedtls.lo: vtls/mbedtls.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vtls/libcurl_la-mbedtls.lo -MD -MP -MF vtls/$(DEPDIR)/libcurl_la-mbedtls.Tpo -c -o vtls/libcurl_la-mbedtls.lo `test -f 'vtls/mbedtls.c' || echo '$(srcdir)/'`vtls/mbedtls.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vtls/$(DEPDIR)/libcurl_la-mbedtls.Tpo vtls/$(DEPDIR)/libcurl_la-mbedtls.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vtls/mbedtls.c' object='vtls/libcurl_la-mbedtls.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vtls/libcurl_la-mbedtls.lo `test -f 'vtls/mbedtls.c' || echo '$(srcdir)/'`vtls/mbedtls.c + +vtls/libcurl_la-openssl.lo: vtls/openssl.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vtls/libcurl_la-openssl.lo -MD -MP -MF vtls/$(DEPDIR)/libcurl_la-openssl.Tpo -c -o vtls/libcurl_la-openssl.lo `test -f 'vtls/openssl.c' || echo '$(srcdir)/'`vtls/openssl.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vtls/$(DEPDIR)/libcurl_la-openssl.Tpo vtls/$(DEPDIR)/libcurl_la-openssl.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vtls/openssl.c' object='vtls/libcurl_la-openssl.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vtls/libcurl_la-openssl.lo `test -f 'vtls/openssl.c' || echo '$(srcdir)/'`vtls/openssl.c + +vtls/libcurl_la-rustls.lo: vtls/rustls.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vtls/libcurl_la-rustls.lo -MD -MP -MF vtls/$(DEPDIR)/libcurl_la-rustls.Tpo -c -o vtls/libcurl_la-rustls.lo `test -f 'vtls/rustls.c' || echo '$(srcdir)/'`vtls/rustls.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vtls/$(DEPDIR)/libcurl_la-rustls.Tpo vtls/$(DEPDIR)/libcurl_la-rustls.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vtls/rustls.c' object='vtls/libcurl_la-rustls.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vtls/libcurl_la-rustls.lo `test -f 'vtls/rustls.c' || echo '$(srcdir)/'`vtls/rustls.c + +vtls/libcurl_la-schannel.lo: vtls/schannel.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vtls/libcurl_la-schannel.lo -MD -MP -MF vtls/$(DEPDIR)/libcurl_la-schannel.Tpo -c -o vtls/libcurl_la-schannel.lo `test -f 'vtls/schannel.c' || echo '$(srcdir)/'`vtls/schannel.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vtls/$(DEPDIR)/libcurl_la-schannel.Tpo vtls/$(DEPDIR)/libcurl_la-schannel.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vtls/schannel.c' object='vtls/libcurl_la-schannel.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vtls/libcurl_la-schannel.lo `test -f 'vtls/schannel.c' || echo '$(srcdir)/'`vtls/schannel.c + +vtls/libcurl_la-schannel_verify.lo: vtls/schannel_verify.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vtls/libcurl_la-schannel_verify.lo -MD -MP -MF vtls/$(DEPDIR)/libcurl_la-schannel_verify.Tpo -c -o vtls/libcurl_la-schannel_verify.lo `test -f 'vtls/schannel_verify.c' || echo '$(srcdir)/'`vtls/schannel_verify.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vtls/$(DEPDIR)/libcurl_la-schannel_verify.Tpo vtls/$(DEPDIR)/libcurl_la-schannel_verify.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vtls/schannel_verify.c' object='vtls/libcurl_la-schannel_verify.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vtls/libcurl_la-schannel_verify.lo `test -f 'vtls/schannel_verify.c' || echo '$(srcdir)/'`vtls/schannel_verify.c + +vtls/libcurl_la-vtls.lo: vtls/vtls.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vtls/libcurl_la-vtls.lo -MD -MP -MF vtls/$(DEPDIR)/libcurl_la-vtls.Tpo -c -o vtls/libcurl_la-vtls.lo `test -f 'vtls/vtls.c' || echo '$(srcdir)/'`vtls/vtls.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vtls/$(DEPDIR)/libcurl_la-vtls.Tpo vtls/$(DEPDIR)/libcurl_la-vtls.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vtls/vtls.c' object='vtls/libcurl_la-vtls.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vtls/libcurl_la-vtls.lo `test -f 'vtls/vtls.c' || echo '$(srcdir)/'`vtls/vtls.c + +vtls/libcurl_la-vtls_config.lo: vtls/vtls_config.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vtls/libcurl_la-vtls_config.lo -MD -MP -MF vtls/$(DEPDIR)/libcurl_la-vtls_config.Tpo -c -o vtls/libcurl_la-vtls_config.lo `test -f 'vtls/vtls_config.c' || echo '$(srcdir)/'`vtls/vtls_config.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vtls/$(DEPDIR)/libcurl_la-vtls_config.Tpo vtls/$(DEPDIR)/libcurl_la-vtls_config.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vtls/vtls_config.c' object='vtls/libcurl_la-vtls_config.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vtls/libcurl_la-vtls_config.lo `test -f 'vtls/vtls_config.c' || echo '$(srcdir)/'`vtls/vtls_config.c + +vtls/libcurl_la-vtls_scache.lo: vtls/vtls_scache.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vtls/libcurl_la-vtls_scache.lo -MD -MP -MF vtls/$(DEPDIR)/libcurl_la-vtls_scache.Tpo -c -o vtls/libcurl_la-vtls_scache.lo `test -f 'vtls/vtls_scache.c' || echo '$(srcdir)/'`vtls/vtls_scache.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vtls/$(DEPDIR)/libcurl_la-vtls_scache.Tpo vtls/$(DEPDIR)/libcurl_la-vtls_scache.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vtls/vtls_scache.c' object='vtls/libcurl_la-vtls_scache.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vtls/libcurl_la-vtls_scache.lo `test -f 'vtls/vtls_scache.c' || echo '$(srcdir)/'`vtls/vtls_scache.c + +vtls/libcurl_la-vtls_spack.lo: vtls/vtls_spack.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vtls/libcurl_la-vtls_spack.lo -MD -MP -MF vtls/$(DEPDIR)/libcurl_la-vtls_spack.Tpo -c -o vtls/libcurl_la-vtls_spack.lo `test -f 'vtls/vtls_spack.c' || echo '$(srcdir)/'`vtls/vtls_spack.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vtls/$(DEPDIR)/libcurl_la-vtls_spack.Tpo vtls/$(DEPDIR)/libcurl_la-vtls_spack.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vtls/vtls_spack.c' object='vtls/libcurl_la-vtls_spack.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vtls/libcurl_la-vtls_spack.lo `test -f 'vtls/vtls_spack.c' || echo '$(srcdir)/'`vtls/vtls_spack.c + +vtls/libcurl_la-wolfssl.lo: vtls/wolfssl.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vtls/libcurl_la-wolfssl.lo -MD -MP -MF vtls/$(DEPDIR)/libcurl_la-wolfssl.Tpo -c -o vtls/libcurl_la-wolfssl.lo `test -f 'vtls/wolfssl.c' || echo '$(srcdir)/'`vtls/wolfssl.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vtls/$(DEPDIR)/libcurl_la-wolfssl.Tpo vtls/$(DEPDIR)/libcurl_la-wolfssl.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vtls/wolfssl.c' object='vtls/libcurl_la-wolfssl.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vtls/libcurl_la-wolfssl.lo `test -f 'vtls/wolfssl.c' || echo '$(srcdir)/'`vtls/wolfssl.c + +vtls/libcurl_la-x509asn1.lo: vtls/x509asn1.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vtls/libcurl_la-x509asn1.lo -MD -MP -MF vtls/$(DEPDIR)/libcurl_la-x509asn1.Tpo -c -o vtls/libcurl_la-x509asn1.lo `test -f 'vtls/x509asn1.c' || echo '$(srcdir)/'`vtls/x509asn1.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vtls/$(DEPDIR)/libcurl_la-x509asn1.Tpo vtls/$(DEPDIR)/libcurl_la-x509asn1.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vtls/x509asn1.c' object='vtls/libcurl_la-x509asn1.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vtls/libcurl_la-x509asn1.lo `test -f 'vtls/x509asn1.c' || echo '$(srcdir)/'`vtls/x509asn1.c + +vquic/libcurl_la-capsule.lo: vquic/capsule.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vquic/libcurl_la-capsule.lo -MD -MP -MF vquic/$(DEPDIR)/libcurl_la-capsule.Tpo -c -o vquic/libcurl_la-capsule.lo `test -f 'vquic/capsule.c' || echo '$(srcdir)/'`vquic/capsule.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vquic/$(DEPDIR)/libcurl_la-capsule.Tpo vquic/$(DEPDIR)/libcurl_la-capsule.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vquic/capsule.c' object='vquic/libcurl_la-capsule.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vquic/libcurl_la-capsule.lo `test -f 'vquic/capsule.c' || echo '$(srcdir)/'`vquic/capsule.c + +vquic/libcurl_la-cf-capsule.lo: vquic/cf-capsule.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vquic/libcurl_la-cf-capsule.lo -MD -MP -MF vquic/$(DEPDIR)/libcurl_la-cf-capsule.Tpo -c -o vquic/libcurl_la-cf-capsule.lo `test -f 'vquic/cf-capsule.c' || echo '$(srcdir)/'`vquic/cf-capsule.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vquic/$(DEPDIR)/libcurl_la-cf-capsule.Tpo vquic/$(DEPDIR)/libcurl_la-cf-capsule.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vquic/cf-capsule.c' object='vquic/libcurl_la-cf-capsule.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vquic/libcurl_la-cf-capsule.lo `test -f 'vquic/cf-capsule.c' || echo '$(srcdir)/'`vquic/cf-capsule.c + +vquic/libcurl_la-cf-ngtcp2.lo: vquic/cf-ngtcp2.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vquic/libcurl_la-cf-ngtcp2.lo -MD -MP -MF vquic/$(DEPDIR)/libcurl_la-cf-ngtcp2.Tpo -c -o vquic/libcurl_la-cf-ngtcp2.lo `test -f 'vquic/cf-ngtcp2.c' || echo '$(srcdir)/'`vquic/cf-ngtcp2.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vquic/$(DEPDIR)/libcurl_la-cf-ngtcp2.Tpo vquic/$(DEPDIR)/libcurl_la-cf-ngtcp2.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vquic/cf-ngtcp2.c' object='vquic/libcurl_la-cf-ngtcp2.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vquic/libcurl_la-cf-ngtcp2.lo `test -f 'vquic/cf-ngtcp2.c' || echo '$(srcdir)/'`vquic/cf-ngtcp2.c + +vquic/libcurl_la-cf-ngtcp2-cmn.lo: vquic/cf-ngtcp2-cmn.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vquic/libcurl_la-cf-ngtcp2-cmn.lo -MD -MP -MF vquic/$(DEPDIR)/libcurl_la-cf-ngtcp2-cmn.Tpo -c -o vquic/libcurl_la-cf-ngtcp2-cmn.lo `test -f 'vquic/cf-ngtcp2-cmn.c' || echo '$(srcdir)/'`vquic/cf-ngtcp2-cmn.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vquic/$(DEPDIR)/libcurl_la-cf-ngtcp2-cmn.Tpo vquic/$(DEPDIR)/libcurl_la-cf-ngtcp2-cmn.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vquic/cf-ngtcp2-cmn.c' object='vquic/libcurl_la-cf-ngtcp2-cmn.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vquic/libcurl_la-cf-ngtcp2-cmn.lo `test -f 'vquic/cf-ngtcp2-cmn.c' || echo '$(srcdir)/'`vquic/cf-ngtcp2-cmn.c + +vquic/libcurl_la-cf-ngtcp2-proxy.lo: vquic/cf-ngtcp2-proxy.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vquic/libcurl_la-cf-ngtcp2-proxy.lo -MD -MP -MF vquic/$(DEPDIR)/libcurl_la-cf-ngtcp2-proxy.Tpo -c -o vquic/libcurl_la-cf-ngtcp2-proxy.lo `test -f 'vquic/cf-ngtcp2-proxy.c' || echo '$(srcdir)/'`vquic/cf-ngtcp2-proxy.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vquic/$(DEPDIR)/libcurl_la-cf-ngtcp2-proxy.Tpo vquic/$(DEPDIR)/libcurl_la-cf-ngtcp2-proxy.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vquic/cf-ngtcp2-proxy.c' object='vquic/libcurl_la-cf-ngtcp2-proxy.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vquic/libcurl_la-cf-ngtcp2-proxy.lo `test -f 'vquic/cf-ngtcp2-proxy.c' || echo '$(srcdir)/'`vquic/cf-ngtcp2-proxy.c + +vquic/libcurl_la-cf-quiche.lo: vquic/cf-quiche.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vquic/libcurl_la-cf-quiche.lo -MD -MP -MF vquic/$(DEPDIR)/libcurl_la-cf-quiche.Tpo -c -o vquic/libcurl_la-cf-quiche.lo `test -f 'vquic/cf-quiche.c' || echo '$(srcdir)/'`vquic/cf-quiche.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vquic/$(DEPDIR)/libcurl_la-cf-quiche.Tpo vquic/$(DEPDIR)/libcurl_la-cf-quiche.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vquic/cf-quiche.c' object='vquic/libcurl_la-cf-quiche.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vquic/libcurl_la-cf-quiche.lo `test -f 'vquic/cf-quiche.c' || echo '$(srcdir)/'`vquic/cf-quiche.c + +vquic/libcurl_la-vquic.lo: vquic/vquic.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vquic/libcurl_la-vquic.lo -MD -MP -MF vquic/$(DEPDIR)/libcurl_la-vquic.Tpo -c -o vquic/libcurl_la-vquic.lo `test -f 'vquic/vquic.c' || echo '$(srcdir)/'`vquic/vquic.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vquic/$(DEPDIR)/libcurl_la-vquic.Tpo vquic/$(DEPDIR)/libcurl_la-vquic.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vquic/vquic.c' object='vquic/libcurl_la-vquic.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vquic/libcurl_la-vquic.lo `test -f 'vquic/vquic.c' || echo '$(srcdir)/'`vquic/vquic.c + +vquic/libcurl_la-vquic-tls.lo: vquic/vquic-tls.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vquic/libcurl_la-vquic-tls.lo -MD -MP -MF vquic/$(DEPDIR)/libcurl_la-vquic-tls.Tpo -c -o vquic/libcurl_la-vquic-tls.lo `test -f 'vquic/vquic-tls.c' || echo '$(srcdir)/'`vquic/vquic-tls.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vquic/$(DEPDIR)/libcurl_la-vquic-tls.Tpo vquic/$(DEPDIR)/libcurl_la-vquic-tls.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vquic/vquic-tls.c' object='vquic/libcurl_la-vquic-tls.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vquic/libcurl_la-vquic-tls.lo `test -f 'vquic/vquic-tls.c' || echo '$(srcdir)/'`vquic/vquic-tls.c + +vssh/libcurl_la-libssh.lo: vssh/libssh.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vssh/libcurl_la-libssh.lo -MD -MP -MF vssh/$(DEPDIR)/libcurl_la-libssh.Tpo -c -o vssh/libcurl_la-libssh.lo `test -f 'vssh/libssh.c' || echo '$(srcdir)/'`vssh/libssh.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vssh/$(DEPDIR)/libcurl_la-libssh.Tpo vssh/$(DEPDIR)/libcurl_la-libssh.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vssh/libssh.c' object='vssh/libcurl_la-libssh.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vssh/libcurl_la-libssh.lo `test -f 'vssh/libssh.c' || echo '$(srcdir)/'`vssh/libssh.c + +vssh/libcurl_la-libssh2.lo: vssh/libssh2.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vssh/libcurl_la-libssh2.lo -MD -MP -MF vssh/$(DEPDIR)/libcurl_la-libssh2.Tpo -c -o vssh/libcurl_la-libssh2.lo `test -f 'vssh/libssh2.c' || echo '$(srcdir)/'`vssh/libssh2.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vssh/$(DEPDIR)/libcurl_la-libssh2.Tpo vssh/$(DEPDIR)/libcurl_la-libssh2.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vssh/libssh2.c' object='vssh/libcurl_la-libssh2.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vssh/libcurl_la-libssh2.lo `test -f 'vssh/libssh2.c' || echo '$(srcdir)/'`vssh/libssh2.c + +vssh/libcurl_la-vssh.lo: vssh/vssh.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT vssh/libcurl_la-vssh.lo -MD -MP -MF vssh/$(DEPDIR)/libcurl_la-vssh.Tpo -c -o vssh/libcurl_la-vssh.lo `test -f 'vssh/vssh.c' || echo '$(srcdir)/'`vssh/vssh.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vssh/$(DEPDIR)/libcurl_la-vssh.Tpo vssh/$(DEPDIR)/libcurl_la-vssh.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vssh/vssh.c' object='vssh/libcurl_la-vssh.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o vssh/libcurl_la-vssh.lo `test -f 'vssh/vssh.c' || echo '$(srcdir)/'`vssh/vssh.c + +curlx/libcurl_la-base64.lo: curlx/base64.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT curlx/libcurl_la-base64.lo -MD -MP -MF curlx/$(DEPDIR)/libcurl_la-base64.Tpo -c -o curlx/libcurl_la-base64.lo `test -f 'curlx/base64.c' || echo '$(srcdir)/'`curlx/base64.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurl_la-base64.Tpo curlx/$(DEPDIR)/libcurl_la-base64.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/base64.c' object='curlx/libcurl_la-base64.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o curlx/libcurl_la-base64.lo `test -f 'curlx/base64.c' || echo '$(srcdir)/'`curlx/base64.c + +curlx/libcurl_la-basename.lo: curlx/basename.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT curlx/libcurl_la-basename.lo -MD -MP -MF curlx/$(DEPDIR)/libcurl_la-basename.Tpo -c -o curlx/libcurl_la-basename.lo `test -f 'curlx/basename.c' || echo '$(srcdir)/'`curlx/basename.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurl_la-basename.Tpo curlx/$(DEPDIR)/libcurl_la-basename.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/basename.c' object='curlx/libcurl_la-basename.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o curlx/libcurl_la-basename.lo `test -f 'curlx/basename.c' || echo '$(srcdir)/'`curlx/basename.c + +curlx/libcurl_la-dynbuf.lo: curlx/dynbuf.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT curlx/libcurl_la-dynbuf.lo -MD -MP -MF curlx/$(DEPDIR)/libcurl_la-dynbuf.Tpo -c -o curlx/libcurl_la-dynbuf.lo `test -f 'curlx/dynbuf.c' || echo '$(srcdir)/'`curlx/dynbuf.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurl_la-dynbuf.Tpo curlx/$(DEPDIR)/libcurl_la-dynbuf.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/dynbuf.c' object='curlx/libcurl_la-dynbuf.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o curlx/libcurl_la-dynbuf.lo `test -f 'curlx/dynbuf.c' || echo '$(srcdir)/'`curlx/dynbuf.c + +curlx/libcurl_la-fopen.lo: curlx/fopen.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT curlx/libcurl_la-fopen.lo -MD -MP -MF curlx/$(DEPDIR)/libcurl_la-fopen.Tpo -c -o curlx/libcurl_la-fopen.lo `test -f 'curlx/fopen.c' || echo '$(srcdir)/'`curlx/fopen.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurl_la-fopen.Tpo curlx/$(DEPDIR)/libcurl_la-fopen.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/fopen.c' object='curlx/libcurl_la-fopen.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o curlx/libcurl_la-fopen.lo `test -f 'curlx/fopen.c' || echo '$(srcdir)/'`curlx/fopen.c + +curlx/libcurl_la-inet_ntop.lo: curlx/inet_ntop.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT curlx/libcurl_la-inet_ntop.lo -MD -MP -MF curlx/$(DEPDIR)/libcurl_la-inet_ntop.Tpo -c -o curlx/libcurl_la-inet_ntop.lo `test -f 'curlx/inet_ntop.c' || echo '$(srcdir)/'`curlx/inet_ntop.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurl_la-inet_ntop.Tpo curlx/$(DEPDIR)/libcurl_la-inet_ntop.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/inet_ntop.c' object='curlx/libcurl_la-inet_ntop.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o curlx/libcurl_la-inet_ntop.lo `test -f 'curlx/inet_ntop.c' || echo '$(srcdir)/'`curlx/inet_ntop.c + +curlx/libcurl_la-inet_pton.lo: curlx/inet_pton.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT curlx/libcurl_la-inet_pton.lo -MD -MP -MF curlx/$(DEPDIR)/libcurl_la-inet_pton.Tpo -c -o curlx/libcurl_la-inet_pton.lo `test -f 'curlx/inet_pton.c' || echo '$(srcdir)/'`curlx/inet_pton.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurl_la-inet_pton.Tpo curlx/$(DEPDIR)/libcurl_la-inet_pton.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/inet_pton.c' object='curlx/libcurl_la-inet_pton.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o curlx/libcurl_la-inet_pton.lo `test -f 'curlx/inet_pton.c' || echo '$(srcdir)/'`curlx/inet_pton.c + +curlx/libcurl_la-multibyte.lo: curlx/multibyte.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT curlx/libcurl_la-multibyte.lo -MD -MP -MF curlx/$(DEPDIR)/libcurl_la-multibyte.Tpo -c -o curlx/libcurl_la-multibyte.lo `test -f 'curlx/multibyte.c' || echo '$(srcdir)/'`curlx/multibyte.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurl_la-multibyte.Tpo curlx/$(DEPDIR)/libcurl_la-multibyte.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/multibyte.c' object='curlx/libcurl_la-multibyte.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o curlx/libcurl_la-multibyte.lo `test -f 'curlx/multibyte.c' || echo '$(srcdir)/'`curlx/multibyte.c + +curlx/libcurl_la-nonblock.lo: curlx/nonblock.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT curlx/libcurl_la-nonblock.lo -MD -MP -MF curlx/$(DEPDIR)/libcurl_la-nonblock.Tpo -c -o curlx/libcurl_la-nonblock.lo `test -f 'curlx/nonblock.c' || echo '$(srcdir)/'`curlx/nonblock.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurl_la-nonblock.Tpo curlx/$(DEPDIR)/libcurl_la-nonblock.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/nonblock.c' object='curlx/libcurl_la-nonblock.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o curlx/libcurl_la-nonblock.lo `test -f 'curlx/nonblock.c' || echo '$(srcdir)/'`curlx/nonblock.c + +curlx/libcurl_la-snprintf.lo: curlx/snprintf.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT curlx/libcurl_la-snprintf.lo -MD -MP -MF curlx/$(DEPDIR)/libcurl_la-snprintf.Tpo -c -o curlx/libcurl_la-snprintf.lo `test -f 'curlx/snprintf.c' || echo '$(srcdir)/'`curlx/snprintf.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurl_la-snprintf.Tpo curlx/$(DEPDIR)/libcurl_la-snprintf.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/snprintf.c' object='curlx/libcurl_la-snprintf.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o curlx/libcurl_la-snprintf.lo `test -f 'curlx/snprintf.c' || echo '$(srcdir)/'`curlx/snprintf.c + +curlx/libcurl_la-strcopy.lo: curlx/strcopy.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT curlx/libcurl_la-strcopy.lo -MD -MP -MF curlx/$(DEPDIR)/libcurl_la-strcopy.Tpo -c -o curlx/libcurl_la-strcopy.lo `test -f 'curlx/strcopy.c' || echo '$(srcdir)/'`curlx/strcopy.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurl_la-strcopy.Tpo curlx/$(DEPDIR)/libcurl_la-strcopy.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/strcopy.c' object='curlx/libcurl_la-strcopy.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o curlx/libcurl_la-strcopy.lo `test -f 'curlx/strcopy.c' || echo '$(srcdir)/'`curlx/strcopy.c + +curlx/libcurl_la-strdup.lo: curlx/strdup.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT curlx/libcurl_la-strdup.lo -MD -MP -MF curlx/$(DEPDIR)/libcurl_la-strdup.Tpo -c -o curlx/libcurl_la-strdup.lo `test -f 'curlx/strdup.c' || echo '$(srcdir)/'`curlx/strdup.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurl_la-strdup.Tpo curlx/$(DEPDIR)/libcurl_la-strdup.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/strdup.c' object='curlx/libcurl_la-strdup.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o curlx/libcurl_la-strdup.lo `test -f 'curlx/strdup.c' || echo '$(srcdir)/'`curlx/strdup.c + +curlx/libcurl_la-strerr.lo: curlx/strerr.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT curlx/libcurl_la-strerr.lo -MD -MP -MF curlx/$(DEPDIR)/libcurl_la-strerr.Tpo -c -o curlx/libcurl_la-strerr.lo `test -f 'curlx/strerr.c' || echo '$(srcdir)/'`curlx/strerr.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurl_la-strerr.Tpo curlx/$(DEPDIR)/libcurl_la-strerr.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/strerr.c' object='curlx/libcurl_la-strerr.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o curlx/libcurl_la-strerr.lo `test -f 'curlx/strerr.c' || echo '$(srcdir)/'`curlx/strerr.c + +curlx/libcurl_la-strparse.lo: curlx/strparse.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT curlx/libcurl_la-strparse.lo -MD -MP -MF curlx/$(DEPDIR)/libcurl_la-strparse.Tpo -c -o curlx/libcurl_la-strparse.lo `test -f 'curlx/strparse.c' || echo '$(srcdir)/'`curlx/strparse.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurl_la-strparse.Tpo curlx/$(DEPDIR)/libcurl_la-strparse.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/strparse.c' object='curlx/libcurl_la-strparse.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o curlx/libcurl_la-strparse.lo `test -f 'curlx/strparse.c' || echo '$(srcdir)/'`curlx/strparse.c + +curlx/libcurl_la-timediff.lo: curlx/timediff.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT curlx/libcurl_la-timediff.lo -MD -MP -MF curlx/$(DEPDIR)/libcurl_la-timediff.Tpo -c -o curlx/libcurl_la-timediff.lo `test -f 'curlx/timediff.c' || echo '$(srcdir)/'`curlx/timediff.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurl_la-timediff.Tpo curlx/$(DEPDIR)/libcurl_la-timediff.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/timediff.c' object='curlx/libcurl_la-timediff.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o curlx/libcurl_la-timediff.lo `test -f 'curlx/timediff.c' || echo '$(srcdir)/'`curlx/timediff.c + +curlx/libcurl_la-timeval.lo: curlx/timeval.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT curlx/libcurl_la-timeval.lo -MD -MP -MF curlx/$(DEPDIR)/libcurl_la-timeval.Tpo -c -o curlx/libcurl_la-timeval.lo `test -f 'curlx/timeval.c' || echo '$(srcdir)/'`curlx/timeval.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurl_la-timeval.Tpo curlx/$(DEPDIR)/libcurl_la-timeval.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/timeval.c' object='curlx/libcurl_la-timeval.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o curlx/libcurl_la-timeval.lo `test -f 'curlx/timeval.c' || echo '$(srcdir)/'`curlx/timeval.c + +curlx/libcurl_la-version_win32.lo: curlx/version_win32.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT curlx/libcurl_la-version_win32.lo -MD -MP -MF curlx/$(DEPDIR)/libcurl_la-version_win32.Tpo -c -o curlx/libcurl_la-version_win32.lo `test -f 'curlx/version_win32.c' || echo '$(srcdir)/'`curlx/version_win32.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurl_la-version_win32.Tpo curlx/$(DEPDIR)/libcurl_la-version_win32.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/version_win32.c' object='curlx/libcurl_la-version_win32.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o curlx/libcurl_la-version_win32.lo `test -f 'curlx/version_win32.c' || echo '$(srcdir)/'`curlx/version_win32.c + +curlx/libcurl_la-wait.lo: curlx/wait.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT curlx/libcurl_la-wait.lo -MD -MP -MF curlx/$(DEPDIR)/libcurl_la-wait.Tpo -c -o curlx/libcurl_la-wait.lo `test -f 'curlx/wait.c' || echo '$(srcdir)/'`curlx/wait.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurl_la-wait.Tpo curlx/$(DEPDIR)/libcurl_la-wait.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/wait.c' object='curlx/libcurl_la-wait.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o curlx/libcurl_la-wait.lo `test -f 'curlx/wait.c' || echo '$(srcdir)/'`curlx/wait.c + +curlx/libcurl_la-warnless.lo: curlx/warnless.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT curlx/libcurl_la-warnless.lo -MD -MP -MF curlx/$(DEPDIR)/libcurl_la-warnless.Tpo -c -o curlx/libcurl_la-warnless.lo `test -f 'curlx/warnless.c' || echo '$(srcdir)/'`curlx/warnless.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurl_la-warnless.Tpo curlx/$(DEPDIR)/libcurl_la-warnless.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/warnless.c' object='curlx/libcurl_la-warnless.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o curlx/libcurl_la-warnless.lo `test -f 'curlx/warnless.c' || echo '$(srcdir)/'`curlx/warnless.c + +curlx/libcurl_la-winapi.lo: curlx/winapi.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT curlx/libcurl_la-winapi.lo -MD -MP -MF curlx/$(DEPDIR)/libcurl_la-winapi.Tpo -c -o curlx/libcurl_la-winapi.lo `test -f 'curlx/winapi.c' || echo '$(srcdir)/'`curlx/winapi.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurl_la-winapi.Tpo curlx/$(DEPDIR)/libcurl_la-winapi.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/winapi.c' object='curlx/libcurl_la-winapi.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o curlx/libcurl_la-winapi.lo `test -f 'curlx/winapi.c' || echo '$(srcdir)/'`curlx/winapi.c + +libcurl_la-dllmain.lo: dllmain.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-dllmain.lo -MD -MP -MF $(DEPDIR)/libcurl_la-dllmain.Tpo -c -o libcurl_la-dllmain.lo `test -f 'dllmain.c' || echo '$(srcdir)/'`dllmain.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-dllmain.Tpo $(DEPDIR)/libcurl_la-dllmain.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='dllmain.c' object='libcurl_la-dllmain.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-dllmain.lo `test -f 'dllmain.c' || echo '$(srcdir)/'`dllmain.c + +libcurl_la-libcurl_unity.lo: libcurl_unity.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -MT libcurl_la-libcurl_unity.lo -MD -MP -MF $(DEPDIR)/libcurl_la-libcurl_unity.Tpo -c -o libcurl_la-libcurl_unity.lo `test -f 'libcurl_unity.c' || echo '$(srcdir)/'`libcurl_unity.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurl_la-libcurl_unity.Tpo $(DEPDIR)/libcurl_la-libcurl_unity.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='libcurl_unity.c' object='libcurl_la-libcurl_unity.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurl_la_CPPFLAGS) $(CPPFLAGS) $(libcurl_la_CFLAGS) $(CFLAGS) -c -o libcurl_la-libcurl_unity.lo `test -f 'libcurl_unity.c' || echo '$(srcdir)/'`libcurl_unity.c + +libcurlu_la-altsvc.lo: altsvc.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-altsvc.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-altsvc.Tpo -c -o libcurlu_la-altsvc.lo `test -f 'altsvc.c' || echo '$(srcdir)/'`altsvc.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-altsvc.Tpo $(DEPDIR)/libcurlu_la-altsvc.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='altsvc.c' object='libcurlu_la-altsvc.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-altsvc.lo `test -f 'altsvc.c' || echo '$(srcdir)/'`altsvc.c + +libcurlu_la-amigaos.lo: amigaos.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-amigaos.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-amigaos.Tpo -c -o libcurlu_la-amigaos.lo `test -f 'amigaos.c' || echo '$(srcdir)/'`amigaos.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-amigaos.Tpo $(DEPDIR)/libcurlu_la-amigaos.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='amigaos.c' object='libcurlu_la-amigaos.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-amigaos.lo `test -f 'amigaos.c' || echo '$(srcdir)/'`amigaos.c + +libcurlu_la-asyn-ares.lo: asyn-ares.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-asyn-ares.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-asyn-ares.Tpo -c -o libcurlu_la-asyn-ares.lo `test -f 'asyn-ares.c' || echo '$(srcdir)/'`asyn-ares.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-asyn-ares.Tpo $(DEPDIR)/libcurlu_la-asyn-ares.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='asyn-ares.c' object='libcurlu_la-asyn-ares.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-asyn-ares.lo `test -f 'asyn-ares.c' || echo '$(srcdir)/'`asyn-ares.c + +libcurlu_la-asyn-base.lo: asyn-base.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-asyn-base.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-asyn-base.Tpo -c -o libcurlu_la-asyn-base.lo `test -f 'asyn-base.c' || echo '$(srcdir)/'`asyn-base.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-asyn-base.Tpo $(DEPDIR)/libcurlu_la-asyn-base.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='asyn-base.c' object='libcurlu_la-asyn-base.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-asyn-base.lo `test -f 'asyn-base.c' || echo '$(srcdir)/'`asyn-base.c + +libcurlu_la-asyn-thrdd.lo: asyn-thrdd.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-asyn-thrdd.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-asyn-thrdd.Tpo -c -o libcurlu_la-asyn-thrdd.lo `test -f 'asyn-thrdd.c' || echo '$(srcdir)/'`asyn-thrdd.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-asyn-thrdd.Tpo $(DEPDIR)/libcurlu_la-asyn-thrdd.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='asyn-thrdd.c' object='libcurlu_la-asyn-thrdd.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-asyn-thrdd.lo `test -f 'asyn-thrdd.c' || echo '$(srcdir)/'`asyn-thrdd.c + +libcurlu_la-bufq.lo: bufq.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-bufq.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-bufq.Tpo -c -o libcurlu_la-bufq.lo `test -f 'bufq.c' || echo '$(srcdir)/'`bufq.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-bufq.Tpo $(DEPDIR)/libcurlu_la-bufq.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='bufq.c' object='libcurlu_la-bufq.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-bufq.lo `test -f 'bufq.c' || echo '$(srcdir)/'`bufq.c + +libcurlu_la-bufref.lo: bufref.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-bufref.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-bufref.Tpo -c -o libcurlu_la-bufref.lo `test -f 'bufref.c' || echo '$(srcdir)/'`bufref.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-bufref.Tpo $(DEPDIR)/libcurlu_la-bufref.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='bufref.c' object='libcurlu_la-bufref.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-bufref.lo `test -f 'bufref.c' || echo '$(srcdir)/'`bufref.c + +libcurlu_la-cf-dns.lo: cf-dns.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-cf-dns.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-cf-dns.Tpo -c -o libcurlu_la-cf-dns.lo `test -f 'cf-dns.c' || echo '$(srcdir)/'`cf-dns.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-cf-dns.Tpo $(DEPDIR)/libcurlu_la-cf-dns.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='cf-dns.c' object='libcurlu_la-cf-dns.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-cf-dns.lo `test -f 'cf-dns.c' || echo '$(srcdir)/'`cf-dns.c + +libcurlu_la-cf-h1-proxy.lo: cf-h1-proxy.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-cf-h1-proxy.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-cf-h1-proxy.Tpo -c -o libcurlu_la-cf-h1-proxy.lo `test -f 'cf-h1-proxy.c' || echo '$(srcdir)/'`cf-h1-proxy.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-cf-h1-proxy.Tpo $(DEPDIR)/libcurlu_la-cf-h1-proxy.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='cf-h1-proxy.c' object='libcurlu_la-cf-h1-proxy.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-cf-h1-proxy.lo `test -f 'cf-h1-proxy.c' || echo '$(srcdir)/'`cf-h1-proxy.c + +libcurlu_la-cf-h2-proxy.lo: cf-h2-proxy.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-cf-h2-proxy.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-cf-h2-proxy.Tpo -c -o libcurlu_la-cf-h2-proxy.lo `test -f 'cf-h2-proxy.c' || echo '$(srcdir)/'`cf-h2-proxy.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-cf-h2-proxy.Tpo $(DEPDIR)/libcurlu_la-cf-h2-proxy.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='cf-h2-proxy.c' object='libcurlu_la-cf-h2-proxy.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-cf-h2-proxy.lo `test -f 'cf-h2-proxy.c' || echo '$(srcdir)/'`cf-h2-proxy.c + +libcurlu_la-cf-haproxy.lo: cf-haproxy.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-cf-haproxy.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-cf-haproxy.Tpo -c -o libcurlu_la-cf-haproxy.lo `test -f 'cf-haproxy.c' || echo '$(srcdir)/'`cf-haproxy.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-cf-haproxy.Tpo $(DEPDIR)/libcurlu_la-cf-haproxy.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='cf-haproxy.c' object='libcurlu_la-cf-haproxy.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-cf-haproxy.lo `test -f 'cf-haproxy.c' || echo '$(srcdir)/'`cf-haproxy.c + +libcurlu_la-cf-https-connect.lo: cf-https-connect.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-cf-https-connect.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-cf-https-connect.Tpo -c -o libcurlu_la-cf-https-connect.lo `test -f 'cf-https-connect.c' || echo '$(srcdir)/'`cf-https-connect.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-cf-https-connect.Tpo $(DEPDIR)/libcurlu_la-cf-https-connect.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='cf-https-connect.c' object='libcurlu_la-cf-https-connect.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-cf-https-connect.lo `test -f 'cf-https-connect.c' || echo '$(srcdir)/'`cf-https-connect.c + +libcurlu_la-cf-ip-happy.lo: cf-ip-happy.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-cf-ip-happy.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-cf-ip-happy.Tpo -c -o libcurlu_la-cf-ip-happy.lo `test -f 'cf-ip-happy.c' || echo '$(srcdir)/'`cf-ip-happy.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-cf-ip-happy.Tpo $(DEPDIR)/libcurlu_la-cf-ip-happy.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='cf-ip-happy.c' object='libcurlu_la-cf-ip-happy.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-cf-ip-happy.lo `test -f 'cf-ip-happy.c' || echo '$(srcdir)/'`cf-ip-happy.c + +libcurlu_la-cf-recvbuf.lo: cf-recvbuf.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-cf-recvbuf.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-cf-recvbuf.Tpo -c -o libcurlu_la-cf-recvbuf.lo `test -f 'cf-recvbuf.c' || echo '$(srcdir)/'`cf-recvbuf.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-cf-recvbuf.Tpo $(DEPDIR)/libcurlu_la-cf-recvbuf.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='cf-recvbuf.c' object='libcurlu_la-cf-recvbuf.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-cf-recvbuf.lo `test -f 'cf-recvbuf.c' || echo '$(srcdir)/'`cf-recvbuf.c + +libcurlu_la-cf-setup.lo: cf-setup.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-cf-setup.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-cf-setup.Tpo -c -o libcurlu_la-cf-setup.lo `test -f 'cf-setup.c' || echo '$(srcdir)/'`cf-setup.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-cf-setup.Tpo $(DEPDIR)/libcurlu_la-cf-setup.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='cf-setup.c' object='libcurlu_la-cf-setup.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-cf-setup.lo `test -f 'cf-setup.c' || echo '$(srcdir)/'`cf-setup.c + +libcurlu_la-cf-socket.lo: cf-socket.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-cf-socket.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-cf-socket.Tpo -c -o libcurlu_la-cf-socket.lo `test -f 'cf-socket.c' || echo '$(srcdir)/'`cf-socket.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-cf-socket.Tpo $(DEPDIR)/libcurlu_la-cf-socket.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='cf-socket.c' object='libcurlu_la-cf-socket.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-cf-socket.lo `test -f 'cf-socket.c' || echo '$(srcdir)/'`cf-socket.c + +libcurlu_la-cfilters.lo: cfilters.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-cfilters.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-cfilters.Tpo -c -o libcurlu_la-cfilters.lo `test -f 'cfilters.c' || echo '$(srcdir)/'`cfilters.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-cfilters.Tpo $(DEPDIR)/libcurlu_la-cfilters.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='cfilters.c' object='libcurlu_la-cfilters.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-cfilters.lo `test -f 'cfilters.c' || echo '$(srcdir)/'`cfilters.c + +libcurlu_la-conncache.lo: conncache.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-conncache.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-conncache.Tpo -c -o libcurlu_la-conncache.lo `test -f 'conncache.c' || echo '$(srcdir)/'`conncache.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-conncache.Tpo $(DEPDIR)/libcurlu_la-conncache.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='conncache.c' object='libcurlu_la-conncache.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-conncache.lo `test -f 'conncache.c' || echo '$(srcdir)/'`conncache.c + +libcurlu_la-connect.lo: connect.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-connect.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-connect.Tpo -c -o libcurlu_la-connect.lo `test -f 'connect.c' || echo '$(srcdir)/'`connect.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-connect.Tpo $(DEPDIR)/libcurlu_la-connect.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='connect.c' object='libcurlu_la-connect.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-connect.lo `test -f 'connect.c' || echo '$(srcdir)/'`connect.c + +libcurlu_la-content_encoding.lo: content_encoding.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-content_encoding.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-content_encoding.Tpo -c -o libcurlu_la-content_encoding.lo `test -f 'content_encoding.c' || echo '$(srcdir)/'`content_encoding.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-content_encoding.Tpo $(DEPDIR)/libcurlu_la-content_encoding.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='content_encoding.c' object='libcurlu_la-content_encoding.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-content_encoding.lo `test -f 'content_encoding.c' || echo '$(srcdir)/'`content_encoding.c + +libcurlu_la-cookie.lo: cookie.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-cookie.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-cookie.Tpo -c -o libcurlu_la-cookie.lo `test -f 'cookie.c' || echo '$(srcdir)/'`cookie.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-cookie.Tpo $(DEPDIR)/libcurlu_la-cookie.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='cookie.c' object='libcurlu_la-cookie.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-cookie.lo `test -f 'cookie.c' || echo '$(srcdir)/'`cookie.c + +libcurlu_la-creds.lo: creds.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-creds.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-creds.Tpo -c -o libcurlu_la-creds.lo `test -f 'creds.c' || echo '$(srcdir)/'`creds.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-creds.Tpo $(DEPDIR)/libcurlu_la-creds.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='creds.c' object='libcurlu_la-creds.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-creds.lo `test -f 'creds.c' || echo '$(srcdir)/'`creds.c + +libcurlu_la-cshutdn.lo: cshutdn.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-cshutdn.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-cshutdn.Tpo -c -o libcurlu_la-cshutdn.lo `test -f 'cshutdn.c' || echo '$(srcdir)/'`cshutdn.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-cshutdn.Tpo $(DEPDIR)/libcurlu_la-cshutdn.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='cshutdn.c' object='libcurlu_la-cshutdn.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-cshutdn.lo `test -f 'cshutdn.c' || echo '$(srcdir)/'`cshutdn.c + +libcurlu_la-curl_addrinfo.lo: curl_addrinfo.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-curl_addrinfo.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-curl_addrinfo.Tpo -c -o libcurlu_la-curl_addrinfo.lo `test -f 'curl_addrinfo.c' || echo '$(srcdir)/'`curl_addrinfo.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-curl_addrinfo.Tpo $(DEPDIR)/libcurlu_la-curl_addrinfo.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curl_addrinfo.c' object='libcurlu_la-curl_addrinfo.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-curl_addrinfo.lo `test -f 'curl_addrinfo.c' || echo '$(srcdir)/'`curl_addrinfo.c + +libcurlu_la-curl_endian.lo: curl_endian.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-curl_endian.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-curl_endian.Tpo -c -o libcurlu_la-curl_endian.lo `test -f 'curl_endian.c' || echo '$(srcdir)/'`curl_endian.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-curl_endian.Tpo $(DEPDIR)/libcurlu_la-curl_endian.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curl_endian.c' object='libcurlu_la-curl_endian.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-curl_endian.lo `test -f 'curl_endian.c' || echo '$(srcdir)/'`curl_endian.c + +libcurlu_la-curl_fnmatch.lo: curl_fnmatch.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-curl_fnmatch.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-curl_fnmatch.Tpo -c -o libcurlu_la-curl_fnmatch.lo `test -f 'curl_fnmatch.c' || echo '$(srcdir)/'`curl_fnmatch.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-curl_fnmatch.Tpo $(DEPDIR)/libcurlu_la-curl_fnmatch.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curl_fnmatch.c' object='libcurlu_la-curl_fnmatch.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-curl_fnmatch.lo `test -f 'curl_fnmatch.c' || echo '$(srcdir)/'`curl_fnmatch.c + +libcurlu_la-curl_fopen.lo: curl_fopen.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-curl_fopen.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-curl_fopen.Tpo -c -o libcurlu_la-curl_fopen.lo `test -f 'curl_fopen.c' || echo '$(srcdir)/'`curl_fopen.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-curl_fopen.Tpo $(DEPDIR)/libcurlu_la-curl_fopen.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curl_fopen.c' object='libcurlu_la-curl_fopen.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-curl_fopen.lo `test -f 'curl_fopen.c' || echo '$(srcdir)/'`curl_fopen.c + +libcurlu_la-curl_get_line.lo: curl_get_line.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-curl_get_line.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-curl_get_line.Tpo -c -o libcurlu_la-curl_get_line.lo `test -f 'curl_get_line.c' || echo '$(srcdir)/'`curl_get_line.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-curl_get_line.Tpo $(DEPDIR)/libcurlu_la-curl_get_line.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curl_get_line.c' object='libcurlu_la-curl_get_line.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-curl_get_line.lo `test -f 'curl_get_line.c' || echo '$(srcdir)/'`curl_get_line.c + +libcurlu_la-curl_gethostname.lo: curl_gethostname.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-curl_gethostname.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-curl_gethostname.Tpo -c -o libcurlu_la-curl_gethostname.lo `test -f 'curl_gethostname.c' || echo '$(srcdir)/'`curl_gethostname.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-curl_gethostname.Tpo $(DEPDIR)/libcurlu_la-curl_gethostname.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curl_gethostname.c' object='libcurlu_la-curl_gethostname.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-curl_gethostname.lo `test -f 'curl_gethostname.c' || echo '$(srcdir)/'`curl_gethostname.c + +libcurlu_la-curl_gssapi.lo: curl_gssapi.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-curl_gssapi.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-curl_gssapi.Tpo -c -o libcurlu_la-curl_gssapi.lo `test -f 'curl_gssapi.c' || echo '$(srcdir)/'`curl_gssapi.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-curl_gssapi.Tpo $(DEPDIR)/libcurlu_la-curl_gssapi.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curl_gssapi.c' object='libcurlu_la-curl_gssapi.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-curl_gssapi.lo `test -f 'curl_gssapi.c' || echo '$(srcdir)/'`curl_gssapi.c + +libcurlu_la-curl_memrchr.lo: curl_memrchr.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-curl_memrchr.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-curl_memrchr.Tpo -c -o libcurlu_la-curl_memrchr.lo `test -f 'curl_memrchr.c' || echo '$(srcdir)/'`curl_memrchr.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-curl_memrchr.Tpo $(DEPDIR)/libcurlu_la-curl_memrchr.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curl_memrchr.c' object='libcurlu_la-curl_memrchr.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-curl_memrchr.lo `test -f 'curl_memrchr.c' || echo '$(srcdir)/'`curl_memrchr.c + +libcurlu_la-curl_ntlm_core.lo: curl_ntlm_core.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-curl_ntlm_core.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-curl_ntlm_core.Tpo -c -o libcurlu_la-curl_ntlm_core.lo `test -f 'curl_ntlm_core.c' || echo '$(srcdir)/'`curl_ntlm_core.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-curl_ntlm_core.Tpo $(DEPDIR)/libcurlu_la-curl_ntlm_core.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curl_ntlm_core.c' object='libcurlu_la-curl_ntlm_core.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-curl_ntlm_core.lo `test -f 'curl_ntlm_core.c' || echo '$(srcdir)/'`curl_ntlm_core.c + +libcurlu_la-curl_range.lo: curl_range.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-curl_range.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-curl_range.Tpo -c -o libcurlu_la-curl_range.lo `test -f 'curl_range.c' || echo '$(srcdir)/'`curl_range.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-curl_range.Tpo $(DEPDIR)/libcurlu_la-curl_range.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curl_range.c' object='libcurlu_la-curl_range.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-curl_range.lo `test -f 'curl_range.c' || echo '$(srcdir)/'`curl_range.c + +libcurlu_la-curl_sasl.lo: curl_sasl.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-curl_sasl.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-curl_sasl.Tpo -c -o libcurlu_la-curl_sasl.lo `test -f 'curl_sasl.c' || echo '$(srcdir)/'`curl_sasl.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-curl_sasl.Tpo $(DEPDIR)/libcurlu_la-curl_sasl.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curl_sasl.c' object='libcurlu_la-curl_sasl.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-curl_sasl.lo `test -f 'curl_sasl.c' || echo '$(srcdir)/'`curl_sasl.c + +libcurlu_la-curl_sha512_256.lo: curl_sha512_256.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-curl_sha512_256.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-curl_sha512_256.Tpo -c -o libcurlu_la-curl_sha512_256.lo `test -f 'curl_sha512_256.c' || echo '$(srcdir)/'`curl_sha512_256.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-curl_sha512_256.Tpo $(DEPDIR)/libcurlu_la-curl_sha512_256.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curl_sha512_256.c' object='libcurlu_la-curl_sha512_256.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-curl_sha512_256.lo `test -f 'curl_sha512_256.c' || echo '$(srcdir)/'`curl_sha512_256.c + +libcurlu_la-curl_share.lo: curl_share.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-curl_share.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-curl_share.Tpo -c -o libcurlu_la-curl_share.lo `test -f 'curl_share.c' || echo '$(srcdir)/'`curl_share.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-curl_share.Tpo $(DEPDIR)/libcurlu_la-curl_share.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curl_share.c' object='libcurlu_la-curl_share.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-curl_share.lo `test -f 'curl_share.c' || echo '$(srcdir)/'`curl_share.c + +libcurlu_la-curl_sspi.lo: curl_sspi.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-curl_sspi.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-curl_sspi.Tpo -c -o libcurlu_la-curl_sspi.lo `test -f 'curl_sspi.c' || echo '$(srcdir)/'`curl_sspi.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-curl_sspi.Tpo $(DEPDIR)/libcurlu_la-curl_sspi.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curl_sspi.c' object='libcurlu_la-curl_sspi.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-curl_sspi.lo `test -f 'curl_sspi.c' || echo '$(srcdir)/'`curl_sspi.c + +libcurlu_la-curl_threads.lo: curl_threads.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-curl_threads.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-curl_threads.Tpo -c -o libcurlu_la-curl_threads.lo `test -f 'curl_threads.c' || echo '$(srcdir)/'`curl_threads.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-curl_threads.Tpo $(DEPDIR)/libcurlu_la-curl_threads.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curl_threads.c' object='libcurlu_la-curl_threads.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-curl_threads.lo `test -f 'curl_threads.c' || echo '$(srcdir)/'`curl_threads.c + +libcurlu_la-curl_trc.lo: curl_trc.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-curl_trc.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-curl_trc.Tpo -c -o libcurlu_la-curl_trc.lo `test -f 'curl_trc.c' || echo '$(srcdir)/'`curl_trc.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-curl_trc.Tpo $(DEPDIR)/libcurlu_la-curl_trc.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curl_trc.c' object='libcurlu_la-curl_trc.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-curl_trc.lo `test -f 'curl_trc.c' || echo '$(srcdir)/'`curl_trc.c + +libcurlu_la-cw-out.lo: cw-out.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-cw-out.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-cw-out.Tpo -c -o libcurlu_la-cw-out.lo `test -f 'cw-out.c' || echo '$(srcdir)/'`cw-out.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-cw-out.Tpo $(DEPDIR)/libcurlu_la-cw-out.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='cw-out.c' object='libcurlu_la-cw-out.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-cw-out.lo `test -f 'cw-out.c' || echo '$(srcdir)/'`cw-out.c + +libcurlu_la-cw-pause.lo: cw-pause.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-cw-pause.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-cw-pause.Tpo -c -o libcurlu_la-cw-pause.lo `test -f 'cw-pause.c' || echo '$(srcdir)/'`cw-pause.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-cw-pause.Tpo $(DEPDIR)/libcurlu_la-cw-pause.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='cw-pause.c' object='libcurlu_la-cw-pause.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-cw-pause.lo `test -f 'cw-pause.c' || echo '$(srcdir)/'`cw-pause.c + +libcurlu_la-dict.lo: dict.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-dict.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-dict.Tpo -c -o libcurlu_la-dict.lo `test -f 'dict.c' || echo '$(srcdir)/'`dict.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-dict.Tpo $(DEPDIR)/libcurlu_la-dict.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='dict.c' object='libcurlu_la-dict.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-dict.lo `test -f 'dict.c' || echo '$(srcdir)/'`dict.c + +libcurlu_la-dnscache.lo: dnscache.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-dnscache.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-dnscache.Tpo -c -o libcurlu_la-dnscache.lo `test -f 'dnscache.c' || echo '$(srcdir)/'`dnscache.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-dnscache.Tpo $(DEPDIR)/libcurlu_la-dnscache.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='dnscache.c' object='libcurlu_la-dnscache.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-dnscache.lo `test -f 'dnscache.c' || echo '$(srcdir)/'`dnscache.c + +libcurlu_la-doh.lo: doh.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-doh.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-doh.Tpo -c -o libcurlu_la-doh.lo `test -f 'doh.c' || echo '$(srcdir)/'`doh.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-doh.Tpo $(DEPDIR)/libcurlu_la-doh.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='doh.c' object='libcurlu_la-doh.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-doh.lo `test -f 'doh.c' || echo '$(srcdir)/'`doh.c + +libcurlu_la-dynhds.lo: dynhds.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-dynhds.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-dynhds.Tpo -c -o libcurlu_la-dynhds.lo `test -f 'dynhds.c' || echo '$(srcdir)/'`dynhds.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-dynhds.Tpo $(DEPDIR)/libcurlu_la-dynhds.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='dynhds.c' object='libcurlu_la-dynhds.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-dynhds.lo `test -f 'dynhds.c' || echo '$(srcdir)/'`dynhds.c + +libcurlu_la-easy.lo: easy.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-easy.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-easy.Tpo -c -o libcurlu_la-easy.lo `test -f 'easy.c' || echo '$(srcdir)/'`easy.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-easy.Tpo $(DEPDIR)/libcurlu_la-easy.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='easy.c' object='libcurlu_la-easy.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-easy.lo `test -f 'easy.c' || echo '$(srcdir)/'`easy.c + +libcurlu_la-easygetopt.lo: easygetopt.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-easygetopt.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-easygetopt.Tpo -c -o libcurlu_la-easygetopt.lo `test -f 'easygetopt.c' || echo '$(srcdir)/'`easygetopt.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-easygetopt.Tpo $(DEPDIR)/libcurlu_la-easygetopt.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='easygetopt.c' object='libcurlu_la-easygetopt.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-easygetopt.lo `test -f 'easygetopt.c' || echo '$(srcdir)/'`easygetopt.c + +libcurlu_la-easyoptions.lo: easyoptions.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-easyoptions.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-easyoptions.Tpo -c -o libcurlu_la-easyoptions.lo `test -f 'easyoptions.c' || echo '$(srcdir)/'`easyoptions.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-easyoptions.Tpo $(DEPDIR)/libcurlu_la-easyoptions.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='easyoptions.c' object='libcurlu_la-easyoptions.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-easyoptions.lo `test -f 'easyoptions.c' || echo '$(srcdir)/'`easyoptions.c + +libcurlu_la-escape.lo: escape.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-escape.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-escape.Tpo -c -o libcurlu_la-escape.lo `test -f 'escape.c' || echo '$(srcdir)/'`escape.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-escape.Tpo $(DEPDIR)/libcurlu_la-escape.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='escape.c' object='libcurlu_la-escape.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-escape.lo `test -f 'escape.c' || echo '$(srcdir)/'`escape.c + +libcurlu_la-fake_addrinfo.lo: fake_addrinfo.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-fake_addrinfo.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-fake_addrinfo.Tpo -c -o libcurlu_la-fake_addrinfo.lo `test -f 'fake_addrinfo.c' || echo '$(srcdir)/'`fake_addrinfo.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-fake_addrinfo.Tpo $(DEPDIR)/libcurlu_la-fake_addrinfo.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='fake_addrinfo.c' object='libcurlu_la-fake_addrinfo.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-fake_addrinfo.lo `test -f 'fake_addrinfo.c' || echo '$(srcdir)/'`fake_addrinfo.c + +libcurlu_la-file.lo: file.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-file.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-file.Tpo -c -o libcurlu_la-file.lo `test -f 'file.c' || echo '$(srcdir)/'`file.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-file.Tpo $(DEPDIR)/libcurlu_la-file.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='file.c' object='libcurlu_la-file.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-file.lo `test -f 'file.c' || echo '$(srcdir)/'`file.c + +libcurlu_la-fileinfo.lo: fileinfo.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-fileinfo.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-fileinfo.Tpo -c -o libcurlu_la-fileinfo.lo `test -f 'fileinfo.c' || echo '$(srcdir)/'`fileinfo.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-fileinfo.Tpo $(DEPDIR)/libcurlu_la-fileinfo.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='fileinfo.c' object='libcurlu_la-fileinfo.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-fileinfo.lo `test -f 'fileinfo.c' || echo '$(srcdir)/'`fileinfo.c + +libcurlu_la-formdata.lo: formdata.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-formdata.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-formdata.Tpo -c -o libcurlu_la-formdata.lo `test -f 'formdata.c' || echo '$(srcdir)/'`formdata.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-formdata.Tpo $(DEPDIR)/libcurlu_la-formdata.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='formdata.c' object='libcurlu_la-formdata.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-formdata.lo `test -f 'formdata.c' || echo '$(srcdir)/'`formdata.c + +libcurlu_la-ftp.lo: ftp.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-ftp.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-ftp.Tpo -c -o libcurlu_la-ftp.lo `test -f 'ftp.c' || echo '$(srcdir)/'`ftp.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-ftp.Tpo $(DEPDIR)/libcurlu_la-ftp.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='ftp.c' object='libcurlu_la-ftp.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-ftp.lo `test -f 'ftp.c' || echo '$(srcdir)/'`ftp.c + +libcurlu_la-ftplistparser.lo: ftplistparser.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-ftplistparser.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-ftplistparser.Tpo -c -o libcurlu_la-ftplistparser.lo `test -f 'ftplistparser.c' || echo '$(srcdir)/'`ftplistparser.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-ftplistparser.Tpo $(DEPDIR)/libcurlu_la-ftplistparser.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='ftplistparser.c' object='libcurlu_la-ftplistparser.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-ftplistparser.lo `test -f 'ftplistparser.c' || echo '$(srcdir)/'`ftplistparser.c + +libcurlu_la-getenv.lo: getenv.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-getenv.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-getenv.Tpo -c -o libcurlu_la-getenv.lo `test -f 'getenv.c' || echo '$(srcdir)/'`getenv.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-getenv.Tpo $(DEPDIR)/libcurlu_la-getenv.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='getenv.c' object='libcurlu_la-getenv.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-getenv.lo `test -f 'getenv.c' || echo '$(srcdir)/'`getenv.c + +libcurlu_la-getinfo.lo: getinfo.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-getinfo.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-getinfo.Tpo -c -o libcurlu_la-getinfo.lo `test -f 'getinfo.c' || echo '$(srcdir)/'`getinfo.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-getinfo.Tpo $(DEPDIR)/libcurlu_la-getinfo.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='getinfo.c' object='libcurlu_la-getinfo.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-getinfo.lo `test -f 'getinfo.c' || echo '$(srcdir)/'`getinfo.c + +libcurlu_la-gopher.lo: gopher.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-gopher.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-gopher.Tpo -c -o libcurlu_la-gopher.lo `test -f 'gopher.c' || echo '$(srcdir)/'`gopher.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-gopher.Tpo $(DEPDIR)/libcurlu_la-gopher.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='gopher.c' object='libcurlu_la-gopher.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-gopher.lo `test -f 'gopher.c' || echo '$(srcdir)/'`gopher.c + +libcurlu_la-hash.lo: hash.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-hash.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-hash.Tpo -c -o libcurlu_la-hash.lo `test -f 'hash.c' || echo '$(srcdir)/'`hash.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-hash.Tpo $(DEPDIR)/libcurlu_la-hash.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='hash.c' object='libcurlu_la-hash.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-hash.lo `test -f 'hash.c' || echo '$(srcdir)/'`hash.c + +libcurlu_la-headers.lo: headers.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-headers.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-headers.Tpo -c -o libcurlu_la-headers.lo `test -f 'headers.c' || echo '$(srcdir)/'`headers.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-headers.Tpo $(DEPDIR)/libcurlu_la-headers.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='headers.c' object='libcurlu_la-headers.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-headers.lo `test -f 'headers.c' || echo '$(srcdir)/'`headers.c + +libcurlu_la-hmac.lo: hmac.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-hmac.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-hmac.Tpo -c -o libcurlu_la-hmac.lo `test -f 'hmac.c' || echo '$(srcdir)/'`hmac.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-hmac.Tpo $(DEPDIR)/libcurlu_la-hmac.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='hmac.c' object='libcurlu_la-hmac.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-hmac.lo `test -f 'hmac.c' || echo '$(srcdir)/'`hmac.c + +libcurlu_la-hostip.lo: hostip.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-hostip.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-hostip.Tpo -c -o libcurlu_la-hostip.lo `test -f 'hostip.c' || echo '$(srcdir)/'`hostip.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-hostip.Tpo $(DEPDIR)/libcurlu_la-hostip.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='hostip.c' object='libcurlu_la-hostip.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-hostip.lo `test -f 'hostip.c' || echo '$(srcdir)/'`hostip.c + +libcurlu_la-hostip4.lo: hostip4.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-hostip4.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-hostip4.Tpo -c -o libcurlu_la-hostip4.lo `test -f 'hostip4.c' || echo '$(srcdir)/'`hostip4.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-hostip4.Tpo $(DEPDIR)/libcurlu_la-hostip4.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='hostip4.c' object='libcurlu_la-hostip4.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-hostip4.lo `test -f 'hostip4.c' || echo '$(srcdir)/'`hostip4.c + +libcurlu_la-hostip6.lo: hostip6.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-hostip6.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-hostip6.Tpo -c -o libcurlu_la-hostip6.lo `test -f 'hostip6.c' || echo '$(srcdir)/'`hostip6.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-hostip6.Tpo $(DEPDIR)/libcurlu_la-hostip6.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='hostip6.c' object='libcurlu_la-hostip6.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-hostip6.lo `test -f 'hostip6.c' || echo '$(srcdir)/'`hostip6.c + +libcurlu_la-hsts.lo: hsts.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-hsts.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-hsts.Tpo -c -o libcurlu_la-hsts.lo `test -f 'hsts.c' || echo '$(srcdir)/'`hsts.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-hsts.Tpo $(DEPDIR)/libcurlu_la-hsts.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='hsts.c' object='libcurlu_la-hsts.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-hsts.lo `test -f 'hsts.c' || echo '$(srcdir)/'`hsts.c + +libcurlu_la-http.lo: http.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-http.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-http.Tpo -c -o libcurlu_la-http.lo `test -f 'http.c' || echo '$(srcdir)/'`http.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-http.Tpo $(DEPDIR)/libcurlu_la-http.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='http.c' object='libcurlu_la-http.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-http.lo `test -f 'http.c' || echo '$(srcdir)/'`http.c + +libcurlu_la-http1.lo: http1.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-http1.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-http1.Tpo -c -o libcurlu_la-http1.lo `test -f 'http1.c' || echo '$(srcdir)/'`http1.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-http1.Tpo $(DEPDIR)/libcurlu_la-http1.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='http1.c' object='libcurlu_la-http1.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-http1.lo `test -f 'http1.c' || echo '$(srcdir)/'`http1.c + +libcurlu_la-http2.lo: http2.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-http2.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-http2.Tpo -c -o libcurlu_la-http2.lo `test -f 'http2.c' || echo '$(srcdir)/'`http2.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-http2.Tpo $(DEPDIR)/libcurlu_la-http2.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='http2.c' object='libcurlu_la-http2.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-http2.lo `test -f 'http2.c' || echo '$(srcdir)/'`http2.c + +libcurlu_la-http_aws_sigv4.lo: http_aws_sigv4.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-http_aws_sigv4.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-http_aws_sigv4.Tpo -c -o libcurlu_la-http_aws_sigv4.lo `test -f 'http_aws_sigv4.c' || echo '$(srcdir)/'`http_aws_sigv4.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-http_aws_sigv4.Tpo $(DEPDIR)/libcurlu_la-http_aws_sigv4.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='http_aws_sigv4.c' object='libcurlu_la-http_aws_sigv4.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-http_aws_sigv4.lo `test -f 'http_aws_sigv4.c' || echo '$(srcdir)/'`http_aws_sigv4.c + +libcurlu_la-http_chunks.lo: http_chunks.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-http_chunks.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-http_chunks.Tpo -c -o libcurlu_la-http_chunks.lo `test -f 'http_chunks.c' || echo '$(srcdir)/'`http_chunks.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-http_chunks.Tpo $(DEPDIR)/libcurlu_la-http_chunks.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='http_chunks.c' object='libcurlu_la-http_chunks.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-http_chunks.lo `test -f 'http_chunks.c' || echo '$(srcdir)/'`http_chunks.c + +libcurlu_la-http_digest.lo: http_digest.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-http_digest.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-http_digest.Tpo -c -o libcurlu_la-http_digest.lo `test -f 'http_digest.c' || echo '$(srcdir)/'`http_digest.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-http_digest.Tpo $(DEPDIR)/libcurlu_la-http_digest.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='http_digest.c' object='libcurlu_la-http_digest.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-http_digest.lo `test -f 'http_digest.c' || echo '$(srcdir)/'`http_digest.c + +libcurlu_la-http_negotiate.lo: http_negotiate.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-http_negotiate.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-http_negotiate.Tpo -c -o libcurlu_la-http_negotiate.lo `test -f 'http_negotiate.c' || echo '$(srcdir)/'`http_negotiate.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-http_negotiate.Tpo $(DEPDIR)/libcurlu_la-http_negotiate.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='http_negotiate.c' object='libcurlu_la-http_negotiate.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-http_negotiate.lo `test -f 'http_negotiate.c' || echo '$(srcdir)/'`http_negotiate.c + +libcurlu_la-http_ntlm.lo: http_ntlm.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-http_ntlm.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-http_ntlm.Tpo -c -o libcurlu_la-http_ntlm.lo `test -f 'http_ntlm.c' || echo '$(srcdir)/'`http_ntlm.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-http_ntlm.Tpo $(DEPDIR)/libcurlu_la-http_ntlm.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='http_ntlm.c' object='libcurlu_la-http_ntlm.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-http_ntlm.lo `test -f 'http_ntlm.c' || echo '$(srcdir)/'`http_ntlm.c + +libcurlu_la-http_proxy.lo: http_proxy.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-http_proxy.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-http_proxy.Tpo -c -o libcurlu_la-http_proxy.lo `test -f 'http_proxy.c' || echo '$(srcdir)/'`http_proxy.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-http_proxy.Tpo $(DEPDIR)/libcurlu_la-http_proxy.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='http_proxy.c' object='libcurlu_la-http_proxy.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-http_proxy.lo `test -f 'http_proxy.c' || echo '$(srcdir)/'`http_proxy.c + +libcurlu_la-httpsrr.lo: httpsrr.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-httpsrr.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-httpsrr.Tpo -c -o libcurlu_la-httpsrr.lo `test -f 'httpsrr.c' || echo '$(srcdir)/'`httpsrr.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-httpsrr.Tpo $(DEPDIR)/libcurlu_la-httpsrr.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='httpsrr.c' object='libcurlu_la-httpsrr.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-httpsrr.lo `test -f 'httpsrr.c' || echo '$(srcdir)/'`httpsrr.c + +libcurlu_la-idn.lo: idn.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-idn.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-idn.Tpo -c -o libcurlu_la-idn.lo `test -f 'idn.c' || echo '$(srcdir)/'`idn.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-idn.Tpo $(DEPDIR)/libcurlu_la-idn.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='idn.c' object='libcurlu_la-idn.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-idn.lo `test -f 'idn.c' || echo '$(srcdir)/'`idn.c + +libcurlu_la-if2ip.lo: if2ip.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-if2ip.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-if2ip.Tpo -c -o libcurlu_la-if2ip.lo `test -f 'if2ip.c' || echo '$(srcdir)/'`if2ip.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-if2ip.Tpo $(DEPDIR)/libcurlu_la-if2ip.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='if2ip.c' object='libcurlu_la-if2ip.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-if2ip.lo `test -f 'if2ip.c' || echo '$(srcdir)/'`if2ip.c + +libcurlu_la-imap.lo: imap.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-imap.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-imap.Tpo -c -o libcurlu_la-imap.lo `test -f 'imap.c' || echo '$(srcdir)/'`imap.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-imap.Tpo $(DEPDIR)/libcurlu_la-imap.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='imap.c' object='libcurlu_la-imap.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-imap.lo `test -f 'imap.c' || echo '$(srcdir)/'`imap.c + +libcurlu_la-ldap.lo: ldap.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-ldap.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-ldap.Tpo -c -o libcurlu_la-ldap.lo `test -f 'ldap.c' || echo '$(srcdir)/'`ldap.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-ldap.Tpo $(DEPDIR)/libcurlu_la-ldap.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='ldap.c' object='libcurlu_la-ldap.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-ldap.lo `test -f 'ldap.c' || echo '$(srcdir)/'`ldap.c + +libcurlu_la-llist.lo: llist.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-llist.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-llist.Tpo -c -o libcurlu_la-llist.lo `test -f 'llist.c' || echo '$(srcdir)/'`llist.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-llist.Tpo $(DEPDIR)/libcurlu_la-llist.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='llist.c' object='libcurlu_la-llist.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-llist.lo `test -f 'llist.c' || echo '$(srcdir)/'`llist.c + +libcurlu_la-macos.lo: macos.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-macos.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-macos.Tpo -c -o libcurlu_la-macos.lo `test -f 'macos.c' || echo '$(srcdir)/'`macos.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-macos.Tpo $(DEPDIR)/libcurlu_la-macos.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='macos.c' object='libcurlu_la-macos.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-macos.lo `test -f 'macos.c' || echo '$(srcdir)/'`macos.c + +libcurlu_la-md4.lo: md4.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-md4.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-md4.Tpo -c -o libcurlu_la-md4.lo `test -f 'md4.c' || echo '$(srcdir)/'`md4.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-md4.Tpo $(DEPDIR)/libcurlu_la-md4.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='md4.c' object='libcurlu_la-md4.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-md4.lo `test -f 'md4.c' || echo '$(srcdir)/'`md4.c + +libcurlu_la-md5.lo: md5.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-md5.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-md5.Tpo -c -o libcurlu_la-md5.lo `test -f 'md5.c' || echo '$(srcdir)/'`md5.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-md5.Tpo $(DEPDIR)/libcurlu_la-md5.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='md5.c' object='libcurlu_la-md5.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-md5.lo `test -f 'md5.c' || echo '$(srcdir)/'`md5.c + +libcurlu_la-memdebug.lo: memdebug.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-memdebug.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-memdebug.Tpo -c -o libcurlu_la-memdebug.lo `test -f 'memdebug.c' || echo '$(srcdir)/'`memdebug.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-memdebug.Tpo $(DEPDIR)/libcurlu_la-memdebug.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='memdebug.c' object='libcurlu_la-memdebug.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-memdebug.lo `test -f 'memdebug.c' || echo '$(srcdir)/'`memdebug.c + +libcurlu_la-mime.lo: mime.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-mime.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-mime.Tpo -c -o libcurlu_la-mime.lo `test -f 'mime.c' || echo '$(srcdir)/'`mime.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-mime.Tpo $(DEPDIR)/libcurlu_la-mime.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='mime.c' object='libcurlu_la-mime.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-mime.lo `test -f 'mime.c' || echo '$(srcdir)/'`mime.c + +libcurlu_la-mprintf.lo: mprintf.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-mprintf.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-mprintf.Tpo -c -o libcurlu_la-mprintf.lo `test -f 'mprintf.c' || echo '$(srcdir)/'`mprintf.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-mprintf.Tpo $(DEPDIR)/libcurlu_la-mprintf.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='mprintf.c' object='libcurlu_la-mprintf.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-mprintf.lo `test -f 'mprintf.c' || echo '$(srcdir)/'`mprintf.c + +libcurlu_la-mqtt.lo: mqtt.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-mqtt.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-mqtt.Tpo -c -o libcurlu_la-mqtt.lo `test -f 'mqtt.c' || echo '$(srcdir)/'`mqtt.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-mqtt.Tpo $(DEPDIR)/libcurlu_la-mqtt.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='mqtt.c' object='libcurlu_la-mqtt.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-mqtt.lo `test -f 'mqtt.c' || echo '$(srcdir)/'`mqtt.c + +libcurlu_la-multi.lo: multi.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-multi.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-multi.Tpo -c -o libcurlu_la-multi.lo `test -f 'multi.c' || echo '$(srcdir)/'`multi.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-multi.Tpo $(DEPDIR)/libcurlu_la-multi.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='multi.c' object='libcurlu_la-multi.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-multi.lo `test -f 'multi.c' || echo '$(srcdir)/'`multi.c + +libcurlu_la-multi_ev.lo: multi_ev.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-multi_ev.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-multi_ev.Tpo -c -o libcurlu_la-multi_ev.lo `test -f 'multi_ev.c' || echo '$(srcdir)/'`multi_ev.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-multi_ev.Tpo $(DEPDIR)/libcurlu_la-multi_ev.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='multi_ev.c' object='libcurlu_la-multi_ev.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-multi_ev.lo `test -f 'multi_ev.c' || echo '$(srcdir)/'`multi_ev.c + +libcurlu_la-multi_ntfy.lo: multi_ntfy.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-multi_ntfy.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-multi_ntfy.Tpo -c -o libcurlu_la-multi_ntfy.lo `test -f 'multi_ntfy.c' || echo '$(srcdir)/'`multi_ntfy.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-multi_ntfy.Tpo $(DEPDIR)/libcurlu_la-multi_ntfy.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='multi_ntfy.c' object='libcurlu_la-multi_ntfy.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-multi_ntfy.lo `test -f 'multi_ntfy.c' || echo '$(srcdir)/'`multi_ntfy.c + +libcurlu_la-netrc.lo: netrc.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-netrc.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-netrc.Tpo -c -o libcurlu_la-netrc.lo `test -f 'netrc.c' || echo '$(srcdir)/'`netrc.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-netrc.Tpo $(DEPDIR)/libcurlu_la-netrc.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='netrc.c' object='libcurlu_la-netrc.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-netrc.lo `test -f 'netrc.c' || echo '$(srcdir)/'`netrc.c + +libcurlu_la-openldap.lo: openldap.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-openldap.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-openldap.Tpo -c -o libcurlu_la-openldap.lo `test -f 'openldap.c' || echo '$(srcdir)/'`openldap.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-openldap.Tpo $(DEPDIR)/libcurlu_la-openldap.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='openldap.c' object='libcurlu_la-openldap.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-openldap.lo `test -f 'openldap.c' || echo '$(srcdir)/'`openldap.c + +libcurlu_la-parsedate.lo: parsedate.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-parsedate.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-parsedate.Tpo -c -o libcurlu_la-parsedate.lo `test -f 'parsedate.c' || echo '$(srcdir)/'`parsedate.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-parsedate.Tpo $(DEPDIR)/libcurlu_la-parsedate.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='parsedate.c' object='libcurlu_la-parsedate.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-parsedate.lo `test -f 'parsedate.c' || echo '$(srcdir)/'`parsedate.c + +libcurlu_la-peer.lo: peer.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-peer.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-peer.Tpo -c -o libcurlu_la-peer.lo `test -f 'peer.c' || echo '$(srcdir)/'`peer.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-peer.Tpo $(DEPDIR)/libcurlu_la-peer.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='peer.c' object='libcurlu_la-peer.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-peer.lo `test -f 'peer.c' || echo '$(srcdir)/'`peer.c + +libcurlu_la-pingpong.lo: pingpong.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-pingpong.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-pingpong.Tpo -c -o libcurlu_la-pingpong.lo `test -f 'pingpong.c' || echo '$(srcdir)/'`pingpong.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-pingpong.Tpo $(DEPDIR)/libcurlu_la-pingpong.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='pingpong.c' object='libcurlu_la-pingpong.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-pingpong.lo `test -f 'pingpong.c' || echo '$(srcdir)/'`pingpong.c + +libcurlu_la-pop3.lo: pop3.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-pop3.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-pop3.Tpo -c -o libcurlu_la-pop3.lo `test -f 'pop3.c' || echo '$(srcdir)/'`pop3.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-pop3.Tpo $(DEPDIR)/libcurlu_la-pop3.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='pop3.c' object='libcurlu_la-pop3.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-pop3.lo `test -f 'pop3.c' || echo '$(srcdir)/'`pop3.c + +libcurlu_la-progress.lo: progress.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-progress.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-progress.Tpo -c -o libcurlu_la-progress.lo `test -f 'progress.c' || echo '$(srcdir)/'`progress.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-progress.Tpo $(DEPDIR)/libcurlu_la-progress.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='progress.c' object='libcurlu_la-progress.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-progress.lo `test -f 'progress.c' || echo '$(srcdir)/'`progress.c + +libcurlu_la-protocol.lo: protocol.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-protocol.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-protocol.Tpo -c -o libcurlu_la-protocol.lo `test -f 'protocol.c' || echo '$(srcdir)/'`protocol.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-protocol.Tpo $(DEPDIR)/libcurlu_la-protocol.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='protocol.c' object='libcurlu_la-protocol.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-protocol.lo `test -f 'protocol.c' || echo '$(srcdir)/'`protocol.c + +libcurlu_la-proxy.lo: proxy.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-proxy.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-proxy.Tpo -c -o libcurlu_la-proxy.lo `test -f 'proxy.c' || echo '$(srcdir)/'`proxy.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-proxy.Tpo $(DEPDIR)/libcurlu_la-proxy.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='proxy.c' object='libcurlu_la-proxy.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-proxy.lo `test -f 'proxy.c' || echo '$(srcdir)/'`proxy.c + +libcurlu_la-psl.lo: psl.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-psl.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-psl.Tpo -c -o libcurlu_la-psl.lo `test -f 'psl.c' || echo '$(srcdir)/'`psl.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-psl.Tpo $(DEPDIR)/libcurlu_la-psl.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='psl.c' object='libcurlu_la-psl.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-psl.lo `test -f 'psl.c' || echo '$(srcdir)/'`psl.c + +libcurlu_la-rand.lo: rand.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-rand.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-rand.Tpo -c -o libcurlu_la-rand.lo `test -f 'rand.c' || echo '$(srcdir)/'`rand.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-rand.Tpo $(DEPDIR)/libcurlu_la-rand.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='rand.c' object='libcurlu_la-rand.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-rand.lo `test -f 'rand.c' || echo '$(srcdir)/'`rand.c + +libcurlu_la-ratelimit.lo: ratelimit.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-ratelimit.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-ratelimit.Tpo -c -o libcurlu_la-ratelimit.lo `test -f 'ratelimit.c' || echo '$(srcdir)/'`ratelimit.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-ratelimit.Tpo $(DEPDIR)/libcurlu_la-ratelimit.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='ratelimit.c' object='libcurlu_la-ratelimit.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-ratelimit.lo `test -f 'ratelimit.c' || echo '$(srcdir)/'`ratelimit.c + +libcurlu_la-request.lo: request.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-request.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-request.Tpo -c -o libcurlu_la-request.lo `test -f 'request.c' || echo '$(srcdir)/'`request.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-request.Tpo $(DEPDIR)/libcurlu_la-request.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='request.c' object='libcurlu_la-request.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-request.lo `test -f 'request.c' || echo '$(srcdir)/'`request.c + +libcurlu_la-rtsp.lo: rtsp.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-rtsp.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-rtsp.Tpo -c -o libcurlu_la-rtsp.lo `test -f 'rtsp.c' || echo '$(srcdir)/'`rtsp.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-rtsp.Tpo $(DEPDIR)/libcurlu_la-rtsp.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='rtsp.c' object='libcurlu_la-rtsp.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-rtsp.lo `test -f 'rtsp.c' || echo '$(srcdir)/'`rtsp.c + +libcurlu_la-select.lo: select.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-select.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-select.Tpo -c -o libcurlu_la-select.lo `test -f 'select.c' || echo '$(srcdir)/'`select.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-select.Tpo $(DEPDIR)/libcurlu_la-select.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='select.c' object='libcurlu_la-select.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-select.lo `test -f 'select.c' || echo '$(srcdir)/'`select.c + +libcurlu_la-sendf.lo: sendf.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-sendf.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-sendf.Tpo -c -o libcurlu_la-sendf.lo `test -f 'sendf.c' || echo '$(srcdir)/'`sendf.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-sendf.Tpo $(DEPDIR)/libcurlu_la-sendf.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='sendf.c' object='libcurlu_la-sendf.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-sendf.lo `test -f 'sendf.c' || echo '$(srcdir)/'`sendf.c + +libcurlu_la-setopt.lo: setopt.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-setopt.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-setopt.Tpo -c -o libcurlu_la-setopt.lo `test -f 'setopt.c' || echo '$(srcdir)/'`setopt.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-setopt.Tpo $(DEPDIR)/libcurlu_la-setopt.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='setopt.c' object='libcurlu_la-setopt.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-setopt.lo `test -f 'setopt.c' || echo '$(srcdir)/'`setopt.c + +libcurlu_la-sha256.lo: sha256.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-sha256.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-sha256.Tpo -c -o libcurlu_la-sha256.lo `test -f 'sha256.c' || echo '$(srcdir)/'`sha256.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-sha256.Tpo $(DEPDIR)/libcurlu_la-sha256.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='sha256.c' object='libcurlu_la-sha256.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-sha256.lo `test -f 'sha256.c' || echo '$(srcdir)/'`sha256.c + +libcurlu_la-slist.lo: slist.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-slist.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-slist.Tpo -c -o libcurlu_la-slist.lo `test -f 'slist.c' || echo '$(srcdir)/'`slist.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-slist.Tpo $(DEPDIR)/libcurlu_la-slist.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='slist.c' object='libcurlu_la-slist.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-slist.lo `test -f 'slist.c' || echo '$(srcdir)/'`slist.c + +libcurlu_la-smb.lo: smb.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-smb.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-smb.Tpo -c -o libcurlu_la-smb.lo `test -f 'smb.c' || echo '$(srcdir)/'`smb.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-smb.Tpo $(DEPDIR)/libcurlu_la-smb.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='smb.c' object='libcurlu_la-smb.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-smb.lo `test -f 'smb.c' || echo '$(srcdir)/'`smb.c + +libcurlu_la-smtp.lo: smtp.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-smtp.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-smtp.Tpo -c -o libcurlu_la-smtp.lo `test -f 'smtp.c' || echo '$(srcdir)/'`smtp.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-smtp.Tpo $(DEPDIR)/libcurlu_la-smtp.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='smtp.c' object='libcurlu_la-smtp.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-smtp.lo `test -f 'smtp.c' || echo '$(srcdir)/'`smtp.c + +libcurlu_la-socketpair.lo: socketpair.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-socketpair.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-socketpair.Tpo -c -o libcurlu_la-socketpair.lo `test -f 'socketpair.c' || echo '$(srcdir)/'`socketpair.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-socketpair.Tpo $(DEPDIR)/libcurlu_la-socketpair.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='socketpair.c' object='libcurlu_la-socketpair.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-socketpair.lo `test -f 'socketpair.c' || echo '$(srcdir)/'`socketpair.c + +libcurlu_la-socks.lo: socks.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-socks.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-socks.Tpo -c -o libcurlu_la-socks.lo `test -f 'socks.c' || echo '$(srcdir)/'`socks.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-socks.Tpo $(DEPDIR)/libcurlu_la-socks.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='socks.c' object='libcurlu_la-socks.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-socks.lo `test -f 'socks.c' || echo '$(srcdir)/'`socks.c + +libcurlu_la-socks_gssapi.lo: socks_gssapi.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-socks_gssapi.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-socks_gssapi.Tpo -c -o libcurlu_la-socks_gssapi.lo `test -f 'socks_gssapi.c' || echo '$(srcdir)/'`socks_gssapi.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-socks_gssapi.Tpo $(DEPDIR)/libcurlu_la-socks_gssapi.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='socks_gssapi.c' object='libcurlu_la-socks_gssapi.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-socks_gssapi.lo `test -f 'socks_gssapi.c' || echo '$(srcdir)/'`socks_gssapi.c + +libcurlu_la-socks_sspi.lo: socks_sspi.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-socks_sspi.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-socks_sspi.Tpo -c -o libcurlu_la-socks_sspi.lo `test -f 'socks_sspi.c' || echo '$(srcdir)/'`socks_sspi.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-socks_sspi.Tpo $(DEPDIR)/libcurlu_la-socks_sspi.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='socks_sspi.c' object='libcurlu_la-socks_sspi.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-socks_sspi.lo `test -f 'socks_sspi.c' || echo '$(srcdir)/'`socks_sspi.c + +libcurlu_la-splay.lo: splay.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-splay.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-splay.Tpo -c -o libcurlu_la-splay.lo `test -f 'splay.c' || echo '$(srcdir)/'`splay.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-splay.Tpo $(DEPDIR)/libcurlu_la-splay.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='splay.c' object='libcurlu_la-splay.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-splay.lo `test -f 'splay.c' || echo '$(srcdir)/'`splay.c + +libcurlu_la-strcase.lo: strcase.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-strcase.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-strcase.Tpo -c -o libcurlu_la-strcase.lo `test -f 'strcase.c' || echo '$(srcdir)/'`strcase.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-strcase.Tpo $(DEPDIR)/libcurlu_la-strcase.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='strcase.c' object='libcurlu_la-strcase.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-strcase.lo `test -f 'strcase.c' || echo '$(srcdir)/'`strcase.c + +libcurlu_la-strequal.lo: strequal.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-strequal.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-strequal.Tpo -c -o libcurlu_la-strequal.lo `test -f 'strequal.c' || echo '$(srcdir)/'`strequal.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-strequal.Tpo $(DEPDIR)/libcurlu_la-strequal.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='strequal.c' object='libcurlu_la-strequal.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-strequal.lo `test -f 'strequal.c' || echo '$(srcdir)/'`strequal.c + +libcurlu_la-strerror.lo: strerror.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-strerror.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-strerror.Tpo -c -o libcurlu_la-strerror.lo `test -f 'strerror.c' || echo '$(srcdir)/'`strerror.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-strerror.Tpo $(DEPDIR)/libcurlu_la-strerror.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='strerror.c' object='libcurlu_la-strerror.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-strerror.lo `test -f 'strerror.c' || echo '$(srcdir)/'`strerror.c + +libcurlu_la-system_win32.lo: system_win32.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-system_win32.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-system_win32.Tpo -c -o libcurlu_la-system_win32.lo `test -f 'system_win32.c' || echo '$(srcdir)/'`system_win32.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-system_win32.Tpo $(DEPDIR)/libcurlu_la-system_win32.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='system_win32.c' object='libcurlu_la-system_win32.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-system_win32.lo `test -f 'system_win32.c' || echo '$(srcdir)/'`system_win32.c + +libcurlu_la-telnet.lo: telnet.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-telnet.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-telnet.Tpo -c -o libcurlu_la-telnet.lo `test -f 'telnet.c' || echo '$(srcdir)/'`telnet.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-telnet.Tpo $(DEPDIR)/libcurlu_la-telnet.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='telnet.c' object='libcurlu_la-telnet.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-telnet.lo `test -f 'telnet.c' || echo '$(srcdir)/'`telnet.c + +libcurlu_la-tftp.lo: tftp.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-tftp.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-tftp.Tpo -c -o libcurlu_la-tftp.lo `test -f 'tftp.c' || echo '$(srcdir)/'`tftp.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-tftp.Tpo $(DEPDIR)/libcurlu_la-tftp.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='tftp.c' object='libcurlu_la-tftp.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-tftp.lo `test -f 'tftp.c' || echo '$(srcdir)/'`tftp.c + +libcurlu_la-thrdpool.lo: thrdpool.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-thrdpool.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-thrdpool.Tpo -c -o libcurlu_la-thrdpool.lo `test -f 'thrdpool.c' || echo '$(srcdir)/'`thrdpool.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-thrdpool.Tpo $(DEPDIR)/libcurlu_la-thrdpool.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='thrdpool.c' object='libcurlu_la-thrdpool.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-thrdpool.lo `test -f 'thrdpool.c' || echo '$(srcdir)/'`thrdpool.c + +libcurlu_la-thrdqueue.lo: thrdqueue.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-thrdqueue.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-thrdqueue.Tpo -c -o libcurlu_la-thrdqueue.lo `test -f 'thrdqueue.c' || echo '$(srcdir)/'`thrdqueue.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-thrdqueue.Tpo $(DEPDIR)/libcurlu_la-thrdqueue.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='thrdqueue.c' object='libcurlu_la-thrdqueue.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-thrdqueue.lo `test -f 'thrdqueue.c' || echo '$(srcdir)/'`thrdqueue.c + +libcurlu_la-transfer.lo: transfer.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-transfer.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-transfer.Tpo -c -o libcurlu_la-transfer.lo `test -f 'transfer.c' || echo '$(srcdir)/'`transfer.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-transfer.Tpo $(DEPDIR)/libcurlu_la-transfer.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='transfer.c' object='libcurlu_la-transfer.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-transfer.lo `test -f 'transfer.c' || echo '$(srcdir)/'`transfer.c + +libcurlu_la-uint-bset.lo: uint-bset.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-uint-bset.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-uint-bset.Tpo -c -o libcurlu_la-uint-bset.lo `test -f 'uint-bset.c' || echo '$(srcdir)/'`uint-bset.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-uint-bset.Tpo $(DEPDIR)/libcurlu_la-uint-bset.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='uint-bset.c' object='libcurlu_la-uint-bset.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-uint-bset.lo `test -f 'uint-bset.c' || echo '$(srcdir)/'`uint-bset.c + +libcurlu_la-uint-hash.lo: uint-hash.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-uint-hash.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-uint-hash.Tpo -c -o libcurlu_la-uint-hash.lo `test -f 'uint-hash.c' || echo '$(srcdir)/'`uint-hash.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-uint-hash.Tpo $(DEPDIR)/libcurlu_la-uint-hash.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='uint-hash.c' object='libcurlu_la-uint-hash.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-uint-hash.lo `test -f 'uint-hash.c' || echo '$(srcdir)/'`uint-hash.c + +libcurlu_la-uint-spbset.lo: uint-spbset.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-uint-spbset.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-uint-spbset.Tpo -c -o libcurlu_la-uint-spbset.lo `test -f 'uint-spbset.c' || echo '$(srcdir)/'`uint-spbset.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-uint-spbset.Tpo $(DEPDIR)/libcurlu_la-uint-spbset.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='uint-spbset.c' object='libcurlu_la-uint-spbset.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-uint-spbset.lo `test -f 'uint-spbset.c' || echo '$(srcdir)/'`uint-spbset.c + +libcurlu_la-uint-table.lo: uint-table.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-uint-table.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-uint-table.Tpo -c -o libcurlu_la-uint-table.lo `test -f 'uint-table.c' || echo '$(srcdir)/'`uint-table.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-uint-table.Tpo $(DEPDIR)/libcurlu_la-uint-table.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='uint-table.c' object='libcurlu_la-uint-table.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-uint-table.lo `test -f 'uint-table.c' || echo '$(srcdir)/'`uint-table.c + +libcurlu_la-url.lo: url.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-url.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-url.Tpo -c -o libcurlu_la-url.lo `test -f 'url.c' || echo '$(srcdir)/'`url.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-url.Tpo $(DEPDIR)/libcurlu_la-url.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='url.c' object='libcurlu_la-url.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-url.lo `test -f 'url.c' || echo '$(srcdir)/'`url.c + +libcurlu_la-urlapi.lo: urlapi.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-urlapi.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-urlapi.Tpo -c -o libcurlu_la-urlapi.lo `test -f 'urlapi.c' || echo '$(srcdir)/'`urlapi.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-urlapi.Tpo $(DEPDIR)/libcurlu_la-urlapi.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='urlapi.c' object='libcurlu_la-urlapi.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-urlapi.lo `test -f 'urlapi.c' || echo '$(srcdir)/'`urlapi.c + +libcurlu_la-version.lo: version.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-version.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-version.Tpo -c -o libcurlu_la-version.lo `test -f 'version.c' || echo '$(srcdir)/'`version.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-version.Tpo $(DEPDIR)/libcurlu_la-version.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='version.c' object='libcurlu_la-version.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-version.lo `test -f 'version.c' || echo '$(srcdir)/'`version.c + +libcurlu_la-ws.lo: ws.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-ws.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-ws.Tpo -c -o libcurlu_la-ws.lo `test -f 'ws.c' || echo '$(srcdir)/'`ws.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-ws.Tpo $(DEPDIR)/libcurlu_la-ws.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='ws.c' object='libcurlu_la-ws.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-ws.lo `test -f 'ws.c' || echo '$(srcdir)/'`ws.c + +vauth/libcurlu_la-cleartext.lo: vauth/cleartext.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vauth/libcurlu_la-cleartext.lo -MD -MP -MF vauth/$(DEPDIR)/libcurlu_la-cleartext.Tpo -c -o vauth/libcurlu_la-cleartext.lo `test -f 'vauth/cleartext.c' || echo '$(srcdir)/'`vauth/cleartext.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vauth/$(DEPDIR)/libcurlu_la-cleartext.Tpo vauth/$(DEPDIR)/libcurlu_la-cleartext.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vauth/cleartext.c' object='vauth/libcurlu_la-cleartext.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vauth/libcurlu_la-cleartext.lo `test -f 'vauth/cleartext.c' || echo '$(srcdir)/'`vauth/cleartext.c + +vauth/libcurlu_la-cram.lo: vauth/cram.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vauth/libcurlu_la-cram.lo -MD -MP -MF vauth/$(DEPDIR)/libcurlu_la-cram.Tpo -c -o vauth/libcurlu_la-cram.lo `test -f 'vauth/cram.c' || echo '$(srcdir)/'`vauth/cram.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vauth/$(DEPDIR)/libcurlu_la-cram.Tpo vauth/$(DEPDIR)/libcurlu_la-cram.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vauth/cram.c' object='vauth/libcurlu_la-cram.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vauth/libcurlu_la-cram.lo `test -f 'vauth/cram.c' || echo '$(srcdir)/'`vauth/cram.c + +vauth/libcurlu_la-digest.lo: vauth/digest.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vauth/libcurlu_la-digest.lo -MD -MP -MF vauth/$(DEPDIR)/libcurlu_la-digest.Tpo -c -o vauth/libcurlu_la-digest.lo `test -f 'vauth/digest.c' || echo '$(srcdir)/'`vauth/digest.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vauth/$(DEPDIR)/libcurlu_la-digest.Tpo vauth/$(DEPDIR)/libcurlu_la-digest.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vauth/digest.c' object='vauth/libcurlu_la-digest.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vauth/libcurlu_la-digest.lo `test -f 'vauth/digest.c' || echo '$(srcdir)/'`vauth/digest.c + +vauth/libcurlu_la-digest_sspi.lo: vauth/digest_sspi.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vauth/libcurlu_la-digest_sspi.lo -MD -MP -MF vauth/$(DEPDIR)/libcurlu_la-digest_sspi.Tpo -c -o vauth/libcurlu_la-digest_sspi.lo `test -f 'vauth/digest_sspi.c' || echo '$(srcdir)/'`vauth/digest_sspi.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vauth/$(DEPDIR)/libcurlu_la-digest_sspi.Tpo vauth/$(DEPDIR)/libcurlu_la-digest_sspi.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vauth/digest_sspi.c' object='vauth/libcurlu_la-digest_sspi.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vauth/libcurlu_la-digest_sspi.lo `test -f 'vauth/digest_sspi.c' || echo '$(srcdir)/'`vauth/digest_sspi.c + +vauth/libcurlu_la-gsasl.lo: vauth/gsasl.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vauth/libcurlu_la-gsasl.lo -MD -MP -MF vauth/$(DEPDIR)/libcurlu_la-gsasl.Tpo -c -o vauth/libcurlu_la-gsasl.lo `test -f 'vauth/gsasl.c' || echo '$(srcdir)/'`vauth/gsasl.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vauth/$(DEPDIR)/libcurlu_la-gsasl.Tpo vauth/$(DEPDIR)/libcurlu_la-gsasl.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vauth/gsasl.c' object='vauth/libcurlu_la-gsasl.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vauth/libcurlu_la-gsasl.lo `test -f 'vauth/gsasl.c' || echo '$(srcdir)/'`vauth/gsasl.c + +vauth/libcurlu_la-krb5_gssapi.lo: vauth/krb5_gssapi.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vauth/libcurlu_la-krb5_gssapi.lo -MD -MP -MF vauth/$(DEPDIR)/libcurlu_la-krb5_gssapi.Tpo -c -o vauth/libcurlu_la-krb5_gssapi.lo `test -f 'vauth/krb5_gssapi.c' || echo '$(srcdir)/'`vauth/krb5_gssapi.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vauth/$(DEPDIR)/libcurlu_la-krb5_gssapi.Tpo vauth/$(DEPDIR)/libcurlu_la-krb5_gssapi.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vauth/krb5_gssapi.c' object='vauth/libcurlu_la-krb5_gssapi.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vauth/libcurlu_la-krb5_gssapi.lo `test -f 'vauth/krb5_gssapi.c' || echo '$(srcdir)/'`vauth/krb5_gssapi.c + +vauth/libcurlu_la-krb5_sspi.lo: vauth/krb5_sspi.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vauth/libcurlu_la-krb5_sspi.lo -MD -MP -MF vauth/$(DEPDIR)/libcurlu_la-krb5_sspi.Tpo -c -o vauth/libcurlu_la-krb5_sspi.lo `test -f 'vauth/krb5_sspi.c' || echo '$(srcdir)/'`vauth/krb5_sspi.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vauth/$(DEPDIR)/libcurlu_la-krb5_sspi.Tpo vauth/$(DEPDIR)/libcurlu_la-krb5_sspi.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vauth/krb5_sspi.c' object='vauth/libcurlu_la-krb5_sspi.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vauth/libcurlu_la-krb5_sspi.lo `test -f 'vauth/krb5_sspi.c' || echo '$(srcdir)/'`vauth/krb5_sspi.c + +vauth/libcurlu_la-ntlm.lo: vauth/ntlm.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vauth/libcurlu_la-ntlm.lo -MD -MP -MF vauth/$(DEPDIR)/libcurlu_la-ntlm.Tpo -c -o vauth/libcurlu_la-ntlm.lo `test -f 'vauth/ntlm.c' || echo '$(srcdir)/'`vauth/ntlm.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vauth/$(DEPDIR)/libcurlu_la-ntlm.Tpo vauth/$(DEPDIR)/libcurlu_la-ntlm.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vauth/ntlm.c' object='vauth/libcurlu_la-ntlm.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vauth/libcurlu_la-ntlm.lo `test -f 'vauth/ntlm.c' || echo '$(srcdir)/'`vauth/ntlm.c + +vauth/libcurlu_la-ntlm_sspi.lo: vauth/ntlm_sspi.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vauth/libcurlu_la-ntlm_sspi.lo -MD -MP -MF vauth/$(DEPDIR)/libcurlu_la-ntlm_sspi.Tpo -c -o vauth/libcurlu_la-ntlm_sspi.lo `test -f 'vauth/ntlm_sspi.c' || echo '$(srcdir)/'`vauth/ntlm_sspi.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vauth/$(DEPDIR)/libcurlu_la-ntlm_sspi.Tpo vauth/$(DEPDIR)/libcurlu_la-ntlm_sspi.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vauth/ntlm_sspi.c' object='vauth/libcurlu_la-ntlm_sspi.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vauth/libcurlu_la-ntlm_sspi.lo `test -f 'vauth/ntlm_sspi.c' || echo '$(srcdir)/'`vauth/ntlm_sspi.c + +vauth/libcurlu_la-oauth2.lo: vauth/oauth2.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vauth/libcurlu_la-oauth2.lo -MD -MP -MF vauth/$(DEPDIR)/libcurlu_la-oauth2.Tpo -c -o vauth/libcurlu_la-oauth2.lo `test -f 'vauth/oauth2.c' || echo '$(srcdir)/'`vauth/oauth2.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vauth/$(DEPDIR)/libcurlu_la-oauth2.Tpo vauth/$(DEPDIR)/libcurlu_la-oauth2.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vauth/oauth2.c' object='vauth/libcurlu_la-oauth2.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vauth/libcurlu_la-oauth2.lo `test -f 'vauth/oauth2.c' || echo '$(srcdir)/'`vauth/oauth2.c + +vauth/libcurlu_la-spnego_gssapi.lo: vauth/spnego_gssapi.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vauth/libcurlu_la-spnego_gssapi.lo -MD -MP -MF vauth/$(DEPDIR)/libcurlu_la-spnego_gssapi.Tpo -c -o vauth/libcurlu_la-spnego_gssapi.lo `test -f 'vauth/spnego_gssapi.c' || echo '$(srcdir)/'`vauth/spnego_gssapi.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vauth/$(DEPDIR)/libcurlu_la-spnego_gssapi.Tpo vauth/$(DEPDIR)/libcurlu_la-spnego_gssapi.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vauth/spnego_gssapi.c' object='vauth/libcurlu_la-spnego_gssapi.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vauth/libcurlu_la-spnego_gssapi.lo `test -f 'vauth/spnego_gssapi.c' || echo '$(srcdir)/'`vauth/spnego_gssapi.c + +vauth/libcurlu_la-spnego_sspi.lo: vauth/spnego_sspi.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vauth/libcurlu_la-spnego_sspi.lo -MD -MP -MF vauth/$(DEPDIR)/libcurlu_la-spnego_sspi.Tpo -c -o vauth/libcurlu_la-spnego_sspi.lo `test -f 'vauth/spnego_sspi.c' || echo '$(srcdir)/'`vauth/spnego_sspi.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vauth/$(DEPDIR)/libcurlu_la-spnego_sspi.Tpo vauth/$(DEPDIR)/libcurlu_la-spnego_sspi.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vauth/spnego_sspi.c' object='vauth/libcurlu_la-spnego_sspi.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vauth/libcurlu_la-spnego_sspi.lo `test -f 'vauth/spnego_sspi.c' || echo '$(srcdir)/'`vauth/spnego_sspi.c + +vauth/libcurlu_la-vauth.lo: vauth/vauth.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vauth/libcurlu_la-vauth.lo -MD -MP -MF vauth/$(DEPDIR)/libcurlu_la-vauth.Tpo -c -o vauth/libcurlu_la-vauth.lo `test -f 'vauth/vauth.c' || echo '$(srcdir)/'`vauth/vauth.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vauth/$(DEPDIR)/libcurlu_la-vauth.Tpo vauth/$(DEPDIR)/libcurlu_la-vauth.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vauth/vauth.c' object='vauth/libcurlu_la-vauth.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vauth/libcurlu_la-vauth.lo `test -f 'vauth/vauth.c' || echo '$(srcdir)/'`vauth/vauth.c + +vtls/libcurlu_la-apple.lo: vtls/apple.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vtls/libcurlu_la-apple.lo -MD -MP -MF vtls/$(DEPDIR)/libcurlu_la-apple.Tpo -c -o vtls/libcurlu_la-apple.lo `test -f 'vtls/apple.c' || echo '$(srcdir)/'`vtls/apple.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vtls/$(DEPDIR)/libcurlu_la-apple.Tpo vtls/$(DEPDIR)/libcurlu_la-apple.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vtls/apple.c' object='vtls/libcurlu_la-apple.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vtls/libcurlu_la-apple.lo `test -f 'vtls/apple.c' || echo '$(srcdir)/'`vtls/apple.c + +vtls/libcurlu_la-cipher_suite.lo: vtls/cipher_suite.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vtls/libcurlu_la-cipher_suite.lo -MD -MP -MF vtls/$(DEPDIR)/libcurlu_la-cipher_suite.Tpo -c -o vtls/libcurlu_la-cipher_suite.lo `test -f 'vtls/cipher_suite.c' || echo '$(srcdir)/'`vtls/cipher_suite.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vtls/$(DEPDIR)/libcurlu_la-cipher_suite.Tpo vtls/$(DEPDIR)/libcurlu_la-cipher_suite.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vtls/cipher_suite.c' object='vtls/libcurlu_la-cipher_suite.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vtls/libcurlu_la-cipher_suite.lo `test -f 'vtls/cipher_suite.c' || echo '$(srcdir)/'`vtls/cipher_suite.c + +vtls/libcurlu_la-gtls.lo: vtls/gtls.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vtls/libcurlu_la-gtls.lo -MD -MP -MF vtls/$(DEPDIR)/libcurlu_la-gtls.Tpo -c -o vtls/libcurlu_la-gtls.lo `test -f 'vtls/gtls.c' || echo '$(srcdir)/'`vtls/gtls.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vtls/$(DEPDIR)/libcurlu_la-gtls.Tpo vtls/$(DEPDIR)/libcurlu_la-gtls.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vtls/gtls.c' object='vtls/libcurlu_la-gtls.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vtls/libcurlu_la-gtls.lo `test -f 'vtls/gtls.c' || echo '$(srcdir)/'`vtls/gtls.c + +vtls/libcurlu_la-hostcheck.lo: vtls/hostcheck.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vtls/libcurlu_la-hostcheck.lo -MD -MP -MF vtls/$(DEPDIR)/libcurlu_la-hostcheck.Tpo -c -o vtls/libcurlu_la-hostcheck.lo `test -f 'vtls/hostcheck.c' || echo '$(srcdir)/'`vtls/hostcheck.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vtls/$(DEPDIR)/libcurlu_la-hostcheck.Tpo vtls/$(DEPDIR)/libcurlu_la-hostcheck.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vtls/hostcheck.c' object='vtls/libcurlu_la-hostcheck.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vtls/libcurlu_la-hostcheck.lo `test -f 'vtls/hostcheck.c' || echo '$(srcdir)/'`vtls/hostcheck.c + +vtls/libcurlu_la-keylog.lo: vtls/keylog.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vtls/libcurlu_la-keylog.lo -MD -MP -MF vtls/$(DEPDIR)/libcurlu_la-keylog.Tpo -c -o vtls/libcurlu_la-keylog.lo `test -f 'vtls/keylog.c' || echo '$(srcdir)/'`vtls/keylog.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vtls/$(DEPDIR)/libcurlu_la-keylog.Tpo vtls/$(DEPDIR)/libcurlu_la-keylog.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vtls/keylog.c' object='vtls/libcurlu_la-keylog.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vtls/libcurlu_la-keylog.lo `test -f 'vtls/keylog.c' || echo '$(srcdir)/'`vtls/keylog.c + +vtls/libcurlu_la-mbedtls.lo: vtls/mbedtls.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vtls/libcurlu_la-mbedtls.lo -MD -MP -MF vtls/$(DEPDIR)/libcurlu_la-mbedtls.Tpo -c -o vtls/libcurlu_la-mbedtls.lo `test -f 'vtls/mbedtls.c' || echo '$(srcdir)/'`vtls/mbedtls.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vtls/$(DEPDIR)/libcurlu_la-mbedtls.Tpo vtls/$(DEPDIR)/libcurlu_la-mbedtls.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vtls/mbedtls.c' object='vtls/libcurlu_la-mbedtls.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vtls/libcurlu_la-mbedtls.lo `test -f 'vtls/mbedtls.c' || echo '$(srcdir)/'`vtls/mbedtls.c + +vtls/libcurlu_la-openssl.lo: vtls/openssl.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vtls/libcurlu_la-openssl.lo -MD -MP -MF vtls/$(DEPDIR)/libcurlu_la-openssl.Tpo -c -o vtls/libcurlu_la-openssl.lo `test -f 'vtls/openssl.c' || echo '$(srcdir)/'`vtls/openssl.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vtls/$(DEPDIR)/libcurlu_la-openssl.Tpo vtls/$(DEPDIR)/libcurlu_la-openssl.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vtls/openssl.c' object='vtls/libcurlu_la-openssl.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vtls/libcurlu_la-openssl.lo `test -f 'vtls/openssl.c' || echo '$(srcdir)/'`vtls/openssl.c + +vtls/libcurlu_la-rustls.lo: vtls/rustls.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vtls/libcurlu_la-rustls.lo -MD -MP -MF vtls/$(DEPDIR)/libcurlu_la-rustls.Tpo -c -o vtls/libcurlu_la-rustls.lo `test -f 'vtls/rustls.c' || echo '$(srcdir)/'`vtls/rustls.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vtls/$(DEPDIR)/libcurlu_la-rustls.Tpo vtls/$(DEPDIR)/libcurlu_la-rustls.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vtls/rustls.c' object='vtls/libcurlu_la-rustls.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vtls/libcurlu_la-rustls.lo `test -f 'vtls/rustls.c' || echo '$(srcdir)/'`vtls/rustls.c + +vtls/libcurlu_la-schannel.lo: vtls/schannel.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vtls/libcurlu_la-schannel.lo -MD -MP -MF vtls/$(DEPDIR)/libcurlu_la-schannel.Tpo -c -o vtls/libcurlu_la-schannel.lo `test -f 'vtls/schannel.c' || echo '$(srcdir)/'`vtls/schannel.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vtls/$(DEPDIR)/libcurlu_la-schannel.Tpo vtls/$(DEPDIR)/libcurlu_la-schannel.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vtls/schannel.c' object='vtls/libcurlu_la-schannel.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vtls/libcurlu_la-schannel.lo `test -f 'vtls/schannel.c' || echo '$(srcdir)/'`vtls/schannel.c + +vtls/libcurlu_la-schannel_verify.lo: vtls/schannel_verify.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vtls/libcurlu_la-schannel_verify.lo -MD -MP -MF vtls/$(DEPDIR)/libcurlu_la-schannel_verify.Tpo -c -o vtls/libcurlu_la-schannel_verify.lo `test -f 'vtls/schannel_verify.c' || echo '$(srcdir)/'`vtls/schannel_verify.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vtls/$(DEPDIR)/libcurlu_la-schannel_verify.Tpo vtls/$(DEPDIR)/libcurlu_la-schannel_verify.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vtls/schannel_verify.c' object='vtls/libcurlu_la-schannel_verify.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vtls/libcurlu_la-schannel_verify.lo `test -f 'vtls/schannel_verify.c' || echo '$(srcdir)/'`vtls/schannel_verify.c + +vtls/libcurlu_la-vtls.lo: vtls/vtls.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vtls/libcurlu_la-vtls.lo -MD -MP -MF vtls/$(DEPDIR)/libcurlu_la-vtls.Tpo -c -o vtls/libcurlu_la-vtls.lo `test -f 'vtls/vtls.c' || echo '$(srcdir)/'`vtls/vtls.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vtls/$(DEPDIR)/libcurlu_la-vtls.Tpo vtls/$(DEPDIR)/libcurlu_la-vtls.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vtls/vtls.c' object='vtls/libcurlu_la-vtls.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vtls/libcurlu_la-vtls.lo `test -f 'vtls/vtls.c' || echo '$(srcdir)/'`vtls/vtls.c + +vtls/libcurlu_la-vtls_config.lo: vtls/vtls_config.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vtls/libcurlu_la-vtls_config.lo -MD -MP -MF vtls/$(DEPDIR)/libcurlu_la-vtls_config.Tpo -c -o vtls/libcurlu_la-vtls_config.lo `test -f 'vtls/vtls_config.c' || echo '$(srcdir)/'`vtls/vtls_config.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vtls/$(DEPDIR)/libcurlu_la-vtls_config.Tpo vtls/$(DEPDIR)/libcurlu_la-vtls_config.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vtls/vtls_config.c' object='vtls/libcurlu_la-vtls_config.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vtls/libcurlu_la-vtls_config.lo `test -f 'vtls/vtls_config.c' || echo '$(srcdir)/'`vtls/vtls_config.c + +vtls/libcurlu_la-vtls_scache.lo: vtls/vtls_scache.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vtls/libcurlu_la-vtls_scache.lo -MD -MP -MF vtls/$(DEPDIR)/libcurlu_la-vtls_scache.Tpo -c -o vtls/libcurlu_la-vtls_scache.lo `test -f 'vtls/vtls_scache.c' || echo '$(srcdir)/'`vtls/vtls_scache.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vtls/$(DEPDIR)/libcurlu_la-vtls_scache.Tpo vtls/$(DEPDIR)/libcurlu_la-vtls_scache.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vtls/vtls_scache.c' object='vtls/libcurlu_la-vtls_scache.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vtls/libcurlu_la-vtls_scache.lo `test -f 'vtls/vtls_scache.c' || echo '$(srcdir)/'`vtls/vtls_scache.c + +vtls/libcurlu_la-vtls_spack.lo: vtls/vtls_spack.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vtls/libcurlu_la-vtls_spack.lo -MD -MP -MF vtls/$(DEPDIR)/libcurlu_la-vtls_spack.Tpo -c -o vtls/libcurlu_la-vtls_spack.lo `test -f 'vtls/vtls_spack.c' || echo '$(srcdir)/'`vtls/vtls_spack.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vtls/$(DEPDIR)/libcurlu_la-vtls_spack.Tpo vtls/$(DEPDIR)/libcurlu_la-vtls_spack.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vtls/vtls_spack.c' object='vtls/libcurlu_la-vtls_spack.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vtls/libcurlu_la-vtls_spack.lo `test -f 'vtls/vtls_spack.c' || echo '$(srcdir)/'`vtls/vtls_spack.c + +vtls/libcurlu_la-wolfssl.lo: vtls/wolfssl.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vtls/libcurlu_la-wolfssl.lo -MD -MP -MF vtls/$(DEPDIR)/libcurlu_la-wolfssl.Tpo -c -o vtls/libcurlu_la-wolfssl.lo `test -f 'vtls/wolfssl.c' || echo '$(srcdir)/'`vtls/wolfssl.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vtls/$(DEPDIR)/libcurlu_la-wolfssl.Tpo vtls/$(DEPDIR)/libcurlu_la-wolfssl.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vtls/wolfssl.c' object='vtls/libcurlu_la-wolfssl.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vtls/libcurlu_la-wolfssl.lo `test -f 'vtls/wolfssl.c' || echo '$(srcdir)/'`vtls/wolfssl.c + +vtls/libcurlu_la-x509asn1.lo: vtls/x509asn1.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vtls/libcurlu_la-x509asn1.lo -MD -MP -MF vtls/$(DEPDIR)/libcurlu_la-x509asn1.Tpo -c -o vtls/libcurlu_la-x509asn1.lo `test -f 'vtls/x509asn1.c' || echo '$(srcdir)/'`vtls/x509asn1.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vtls/$(DEPDIR)/libcurlu_la-x509asn1.Tpo vtls/$(DEPDIR)/libcurlu_la-x509asn1.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vtls/x509asn1.c' object='vtls/libcurlu_la-x509asn1.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vtls/libcurlu_la-x509asn1.lo `test -f 'vtls/x509asn1.c' || echo '$(srcdir)/'`vtls/x509asn1.c + +vquic/libcurlu_la-capsule.lo: vquic/capsule.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vquic/libcurlu_la-capsule.lo -MD -MP -MF vquic/$(DEPDIR)/libcurlu_la-capsule.Tpo -c -o vquic/libcurlu_la-capsule.lo `test -f 'vquic/capsule.c' || echo '$(srcdir)/'`vquic/capsule.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vquic/$(DEPDIR)/libcurlu_la-capsule.Tpo vquic/$(DEPDIR)/libcurlu_la-capsule.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vquic/capsule.c' object='vquic/libcurlu_la-capsule.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vquic/libcurlu_la-capsule.lo `test -f 'vquic/capsule.c' || echo '$(srcdir)/'`vquic/capsule.c + +vquic/libcurlu_la-cf-capsule.lo: vquic/cf-capsule.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vquic/libcurlu_la-cf-capsule.lo -MD -MP -MF vquic/$(DEPDIR)/libcurlu_la-cf-capsule.Tpo -c -o vquic/libcurlu_la-cf-capsule.lo `test -f 'vquic/cf-capsule.c' || echo '$(srcdir)/'`vquic/cf-capsule.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vquic/$(DEPDIR)/libcurlu_la-cf-capsule.Tpo vquic/$(DEPDIR)/libcurlu_la-cf-capsule.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vquic/cf-capsule.c' object='vquic/libcurlu_la-cf-capsule.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vquic/libcurlu_la-cf-capsule.lo `test -f 'vquic/cf-capsule.c' || echo '$(srcdir)/'`vquic/cf-capsule.c + +vquic/libcurlu_la-cf-ngtcp2.lo: vquic/cf-ngtcp2.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vquic/libcurlu_la-cf-ngtcp2.lo -MD -MP -MF vquic/$(DEPDIR)/libcurlu_la-cf-ngtcp2.Tpo -c -o vquic/libcurlu_la-cf-ngtcp2.lo `test -f 'vquic/cf-ngtcp2.c' || echo '$(srcdir)/'`vquic/cf-ngtcp2.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vquic/$(DEPDIR)/libcurlu_la-cf-ngtcp2.Tpo vquic/$(DEPDIR)/libcurlu_la-cf-ngtcp2.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vquic/cf-ngtcp2.c' object='vquic/libcurlu_la-cf-ngtcp2.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vquic/libcurlu_la-cf-ngtcp2.lo `test -f 'vquic/cf-ngtcp2.c' || echo '$(srcdir)/'`vquic/cf-ngtcp2.c + +vquic/libcurlu_la-cf-ngtcp2-cmn.lo: vquic/cf-ngtcp2-cmn.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vquic/libcurlu_la-cf-ngtcp2-cmn.lo -MD -MP -MF vquic/$(DEPDIR)/libcurlu_la-cf-ngtcp2-cmn.Tpo -c -o vquic/libcurlu_la-cf-ngtcp2-cmn.lo `test -f 'vquic/cf-ngtcp2-cmn.c' || echo '$(srcdir)/'`vquic/cf-ngtcp2-cmn.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vquic/$(DEPDIR)/libcurlu_la-cf-ngtcp2-cmn.Tpo vquic/$(DEPDIR)/libcurlu_la-cf-ngtcp2-cmn.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vquic/cf-ngtcp2-cmn.c' object='vquic/libcurlu_la-cf-ngtcp2-cmn.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vquic/libcurlu_la-cf-ngtcp2-cmn.lo `test -f 'vquic/cf-ngtcp2-cmn.c' || echo '$(srcdir)/'`vquic/cf-ngtcp2-cmn.c + +vquic/libcurlu_la-cf-ngtcp2-proxy.lo: vquic/cf-ngtcp2-proxy.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vquic/libcurlu_la-cf-ngtcp2-proxy.lo -MD -MP -MF vquic/$(DEPDIR)/libcurlu_la-cf-ngtcp2-proxy.Tpo -c -o vquic/libcurlu_la-cf-ngtcp2-proxy.lo `test -f 'vquic/cf-ngtcp2-proxy.c' || echo '$(srcdir)/'`vquic/cf-ngtcp2-proxy.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vquic/$(DEPDIR)/libcurlu_la-cf-ngtcp2-proxy.Tpo vquic/$(DEPDIR)/libcurlu_la-cf-ngtcp2-proxy.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vquic/cf-ngtcp2-proxy.c' object='vquic/libcurlu_la-cf-ngtcp2-proxy.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vquic/libcurlu_la-cf-ngtcp2-proxy.lo `test -f 'vquic/cf-ngtcp2-proxy.c' || echo '$(srcdir)/'`vquic/cf-ngtcp2-proxy.c + +vquic/libcurlu_la-cf-quiche.lo: vquic/cf-quiche.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vquic/libcurlu_la-cf-quiche.lo -MD -MP -MF vquic/$(DEPDIR)/libcurlu_la-cf-quiche.Tpo -c -o vquic/libcurlu_la-cf-quiche.lo `test -f 'vquic/cf-quiche.c' || echo '$(srcdir)/'`vquic/cf-quiche.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vquic/$(DEPDIR)/libcurlu_la-cf-quiche.Tpo vquic/$(DEPDIR)/libcurlu_la-cf-quiche.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vquic/cf-quiche.c' object='vquic/libcurlu_la-cf-quiche.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vquic/libcurlu_la-cf-quiche.lo `test -f 'vquic/cf-quiche.c' || echo '$(srcdir)/'`vquic/cf-quiche.c + +vquic/libcurlu_la-vquic.lo: vquic/vquic.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vquic/libcurlu_la-vquic.lo -MD -MP -MF vquic/$(DEPDIR)/libcurlu_la-vquic.Tpo -c -o vquic/libcurlu_la-vquic.lo `test -f 'vquic/vquic.c' || echo '$(srcdir)/'`vquic/vquic.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vquic/$(DEPDIR)/libcurlu_la-vquic.Tpo vquic/$(DEPDIR)/libcurlu_la-vquic.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vquic/vquic.c' object='vquic/libcurlu_la-vquic.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vquic/libcurlu_la-vquic.lo `test -f 'vquic/vquic.c' || echo '$(srcdir)/'`vquic/vquic.c + +vquic/libcurlu_la-vquic-tls.lo: vquic/vquic-tls.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vquic/libcurlu_la-vquic-tls.lo -MD -MP -MF vquic/$(DEPDIR)/libcurlu_la-vquic-tls.Tpo -c -o vquic/libcurlu_la-vquic-tls.lo `test -f 'vquic/vquic-tls.c' || echo '$(srcdir)/'`vquic/vquic-tls.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vquic/$(DEPDIR)/libcurlu_la-vquic-tls.Tpo vquic/$(DEPDIR)/libcurlu_la-vquic-tls.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vquic/vquic-tls.c' object='vquic/libcurlu_la-vquic-tls.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vquic/libcurlu_la-vquic-tls.lo `test -f 'vquic/vquic-tls.c' || echo '$(srcdir)/'`vquic/vquic-tls.c + +vssh/libcurlu_la-libssh.lo: vssh/libssh.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vssh/libcurlu_la-libssh.lo -MD -MP -MF vssh/$(DEPDIR)/libcurlu_la-libssh.Tpo -c -o vssh/libcurlu_la-libssh.lo `test -f 'vssh/libssh.c' || echo '$(srcdir)/'`vssh/libssh.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vssh/$(DEPDIR)/libcurlu_la-libssh.Tpo vssh/$(DEPDIR)/libcurlu_la-libssh.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vssh/libssh.c' object='vssh/libcurlu_la-libssh.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vssh/libcurlu_la-libssh.lo `test -f 'vssh/libssh.c' || echo '$(srcdir)/'`vssh/libssh.c + +vssh/libcurlu_la-libssh2.lo: vssh/libssh2.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vssh/libcurlu_la-libssh2.lo -MD -MP -MF vssh/$(DEPDIR)/libcurlu_la-libssh2.Tpo -c -o vssh/libcurlu_la-libssh2.lo `test -f 'vssh/libssh2.c' || echo '$(srcdir)/'`vssh/libssh2.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vssh/$(DEPDIR)/libcurlu_la-libssh2.Tpo vssh/$(DEPDIR)/libcurlu_la-libssh2.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vssh/libssh2.c' object='vssh/libcurlu_la-libssh2.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vssh/libcurlu_la-libssh2.lo `test -f 'vssh/libssh2.c' || echo '$(srcdir)/'`vssh/libssh2.c + +vssh/libcurlu_la-vssh.lo: vssh/vssh.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT vssh/libcurlu_la-vssh.lo -MD -MP -MF vssh/$(DEPDIR)/libcurlu_la-vssh.Tpo -c -o vssh/libcurlu_la-vssh.lo `test -f 'vssh/vssh.c' || echo '$(srcdir)/'`vssh/vssh.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) vssh/$(DEPDIR)/libcurlu_la-vssh.Tpo vssh/$(DEPDIR)/libcurlu_la-vssh.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='vssh/vssh.c' object='vssh/libcurlu_la-vssh.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o vssh/libcurlu_la-vssh.lo `test -f 'vssh/vssh.c' || echo '$(srcdir)/'`vssh/vssh.c + +curlx/libcurlu_la-base64.lo: curlx/base64.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT curlx/libcurlu_la-base64.lo -MD -MP -MF curlx/$(DEPDIR)/libcurlu_la-base64.Tpo -c -o curlx/libcurlu_la-base64.lo `test -f 'curlx/base64.c' || echo '$(srcdir)/'`curlx/base64.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurlu_la-base64.Tpo curlx/$(DEPDIR)/libcurlu_la-base64.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/base64.c' object='curlx/libcurlu_la-base64.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o curlx/libcurlu_la-base64.lo `test -f 'curlx/base64.c' || echo '$(srcdir)/'`curlx/base64.c + +curlx/libcurlu_la-basename.lo: curlx/basename.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT curlx/libcurlu_la-basename.lo -MD -MP -MF curlx/$(DEPDIR)/libcurlu_la-basename.Tpo -c -o curlx/libcurlu_la-basename.lo `test -f 'curlx/basename.c' || echo '$(srcdir)/'`curlx/basename.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurlu_la-basename.Tpo curlx/$(DEPDIR)/libcurlu_la-basename.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/basename.c' object='curlx/libcurlu_la-basename.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o curlx/libcurlu_la-basename.lo `test -f 'curlx/basename.c' || echo '$(srcdir)/'`curlx/basename.c + +curlx/libcurlu_la-dynbuf.lo: curlx/dynbuf.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT curlx/libcurlu_la-dynbuf.lo -MD -MP -MF curlx/$(DEPDIR)/libcurlu_la-dynbuf.Tpo -c -o curlx/libcurlu_la-dynbuf.lo `test -f 'curlx/dynbuf.c' || echo '$(srcdir)/'`curlx/dynbuf.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurlu_la-dynbuf.Tpo curlx/$(DEPDIR)/libcurlu_la-dynbuf.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/dynbuf.c' object='curlx/libcurlu_la-dynbuf.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o curlx/libcurlu_la-dynbuf.lo `test -f 'curlx/dynbuf.c' || echo '$(srcdir)/'`curlx/dynbuf.c + +curlx/libcurlu_la-fopen.lo: curlx/fopen.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT curlx/libcurlu_la-fopen.lo -MD -MP -MF curlx/$(DEPDIR)/libcurlu_la-fopen.Tpo -c -o curlx/libcurlu_la-fopen.lo `test -f 'curlx/fopen.c' || echo '$(srcdir)/'`curlx/fopen.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurlu_la-fopen.Tpo curlx/$(DEPDIR)/libcurlu_la-fopen.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/fopen.c' object='curlx/libcurlu_la-fopen.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o curlx/libcurlu_la-fopen.lo `test -f 'curlx/fopen.c' || echo '$(srcdir)/'`curlx/fopen.c + +curlx/libcurlu_la-inet_ntop.lo: curlx/inet_ntop.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT curlx/libcurlu_la-inet_ntop.lo -MD -MP -MF curlx/$(DEPDIR)/libcurlu_la-inet_ntop.Tpo -c -o curlx/libcurlu_la-inet_ntop.lo `test -f 'curlx/inet_ntop.c' || echo '$(srcdir)/'`curlx/inet_ntop.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurlu_la-inet_ntop.Tpo curlx/$(DEPDIR)/libcurlu_la-inet_ntop.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/inet_ntop.c' object='curlx/libcurlu_la-inet_ntop.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o curlx/libcurlu_la-inet_ntop.lo `test -f 'curlx/inet_ntop.c' || echo '$(srcdir)/'`curlx/inet_ntop.c + +curlx/libcurlu_la-inet_pton.lo: curlx/inet_pton.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT curlx/libcurlu_la-inet_pton.lo -MD -MP -MF curlx/$(DEPDIR)/libcurlu_la-inet_pton.Tpo -c -o curlx/libcurlu_la-inet_pton.lo `test -f 'curlx/inet_pton.c' || echo '$(srcdir)/'`curlx/inet_pton.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurlu_la-inet_pton.Tpo curlx/$(DEPDIR)/libcurlu_la-inet_pton.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/inet_pton.c' object='curlx/libcurlu_la-inet_pton.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o curlx/libcurlu_la-inet_pton.lo `test -f 'curlx/inet_pton.c' || echo '$(srcdir)/'`curlx/inet_pton.c + +curlx/libcurlu_la-multibyte.lo: curlx/multibyte.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT curlx/libcurlu_la-multibyte.lo -MD -MP -MF curlx/$(DEPDIR)/libcurlu_la-multibyte.Tpo -c -o curlx/libcurlu_la-multibyte.lo `test -f 'curlx/multibyte.c' || echo '$(srcdir)/'`curlx/multibyte.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurlu_la-multibyte.Tpo curlx/$(DEPDIR)/libcurlu_la-multibyte.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/multibyte.c' object='curlx/libcurlu_la-multibyte.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o curlx/libcurlu_la-multibyte.lo `test -f 'curlx/multibyte.c' || echo '$(srcdir)/'`curlx/multibyte.c + +curlx/libcurlu_la-nonblock.lo: curlx/nonblock.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT curlx/libcurlu_la-nonblock.lo -MD -MP -MF curlx/$(DEPDIR)/libcurlu_la-nonblock.Tpo -c -o curlx/libcurlu_la-nonblock.lo `test -f 'curlx/nonblock.c' || echo '$(srcdir)/'`curlx/nonblock.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurlu_la-nonblock.Tpo curlx/$(DEPDIR)/libcurlu_la-nonblock.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/nonblock.c' object='curlx/libcurlu_la-nonblock.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o curlx/libcurlu_la-nonblock.lo `test -f 'curlx/nonblock.c' || echo '$(srcdir)/'`curlx/nonblock.c + +curlx/libcurlu_la-snprintf.lo: curlx/snprintf.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT curlx/libcurlu_la-snprintf.lo -MD -MP -MF curlx/$(DEPDIR)/libcurlu_la-snprintf.Tpo -c -o curlx/libcurlu_la-snprintf.lo `test -f 'curlx/snprintf.c' || echo '$(srcdir)/'`curlx/snprintf.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurlu_la-snprintf.Tpo curlx/$(DEPDIR)/libcurlu_la-snprintf.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/snprintf.c' object='curlx/libcurlu_la-snprintf.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o curlx/libcurlu_la-snprintf.lo `test -f 'curlx/snprintf.c' || echo '$(srcdir)/'`curlx/snprintf.c + +curlx/libcurlu_la-strcopy.lo: curlx/strcopy.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT curlx/libcurlu_la-strcopy.lo -MD -MP -MF curlx/$(DEPDIR)/libcurlu_la-strcopy.Tpo -c -o curlx/libcurlu_la-strcopy.lo `test -f 'curlx/strcopy.c' || echo '$(srcdir)/'`curlx/strcopy.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurlu_la-strcopy.Tpo curlx/$(DEPDIR)/libcurlu_la-strcopy.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/strcopy.c' object='curlx/libcurlu_la-strcopy.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o curlx/libcurlu_la-strcopy.lo `test -f 'curlx/strcopy.c' || echo '$(srcdir)/'`curlx/strcopy.c + +curlx/libcurlu_la-strdup.lo: curlx/strdup.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT curlx/libcurlu_la-strdup.lo -MD -MP -MF curlx/$(DEPDIR)/libcurlu_la-strdup.Tpo -c -o curlx/libcurlu_la-strdup.lo `test -f 'curlx/strdup.c' || echo '$(srcdir)/'`curlx/strdup.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurlu_la-strdup.Tpo curlx/$(DEPDIR)/libcurlu_la-strdup.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/strdup.c' object='curlx/libcurlu_la-strdup.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o curlx/libcurlu_la-strdup.lo `test -f 'curlx/strdup.c' || echo '$(srcdir)/'`curlx/strdup.c + +curlx/libcurlu_la-strerr.lo: curlx/strerr.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT curlx/libcurlu_la-strerr.lo -MD -MP -MF curlx/$(DEPDIR)/libcurlu_la-strerr.Tpo -c -o curlx/libcurlu_la-strerr.lo `test -f 'curlx/strerr.c' || echo '$(srcdir)/'`curlx/strerr.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurlu_la-strerr.Tpo curlx/$(DEPDIR)/libcurlu_la-strerr.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/strerr.c' object='curlx/libcurlu_la-strerr.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o curlx/libcurlu_la-strerr.lo `test -f 'curlx/strerr.c' || echo '$(srcdir)/'`curlx/strerr.c + +curlx/libcurlu_la-strparse.lo: curlx/strparse.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT curlx/libcurlu_la-strparse.lo -MD -MP -MF curlx/$(DEPDIR)/libcurlu_la-strparse.Tpo -c -o curlx/libcurlu_la-strparse.lo `test -f 'curlx/strparse.c' || echo '$(srcdir)/'`curlx/strparse.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurlu_la-strparse.Tpo curlx/$(DEPDIR)/libcurlu_la-strparse.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/strparse.c' object='curlx/libcurlu_la-strparse.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o curlx/libcurlu_la-strparse.lo `test -f 'curlx/strparse.c' || echo '$(srcdir)/'`curlx/strparse.c + +curlx/libcurlu_la-timediff.lo: curlx/timediff.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT curlx/libcurlu_la-timediff.lo -MD -MP -MF curlx/$(DEPDIR)/libcurlu_la-timediff.Tpo -c -o curlx/libcurlu_la-timediff.lo `test -f 'curlx/timediff.c' || echo '$(srcdir)/'`curlx/timediff.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurlu_la-timediff.Tpo curlx/$(DEPDIR)/libcurlu_la-timediff.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/timediff.c' object='curlx/libcurlu_la-timediff.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o curlx/libcurlu_la-timediff.lo `test -f 'curlx/timediff.c' || echo '$(srcdir)/'`curlx/timediff.c + +curlx/libcurlu_la-timeval.lo: curlx/timeval.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT curlx/libcurlu_la-timeval.lo -MD -MP -MF curlx/$(DEPDIR)/libcurlu_la-timeval.Tpo -c -o curlx/libcurlu_la-timeval.lo `test -f 'curlx/timeval.c' || echo '$(srcdir)/'`curlx/timeval.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurlu_la-timeval.Tpo curlx/$(DEPDIR)/libcurlu_la-timeval.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/timeval.c' object='curlx/libcurlu_la-timeval.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o curlx/libcurlu_la-timeval.lo `test -f 'curlx/timeval.c' || echo '$(srcdir)/'`curlx/timeval.c + +curlx/libcurlu_la-version_win32.lo: curlx/version_win32.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT curlx/libcurlu_la-version_win32.lo -MD -MP -MF curlx/$(DEPDIR)/libcurlu_la-version_win32.Tpo -c -o curlx/libcurlu_la-version_win32.lo `test -f 'curlx/version_win32.c' || echo '$(srcdir)/'`curlx/version_win32.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurlu_la-version_win32.Tpo curlx/$(DEPDIR)/libcurlu_la-version_win32.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/version_win32.c' object='curlx/libcurlu_la-version_win32.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o curlx/libcurlu_la-version_win32.lo `test -f 'curlx/version_win32.c' || echo '$(srcdir)/'`curlx/version_win32.c + +curlx/libcurlu_la-wait.lo: curlx/wait.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT curlx/libcurlu_la-wait.lo -MD -MP -MF curlx/$(DEPDIR)/libcurlu_la-wait.Tpo -c -o curlx/libcurlu_la-wait.lo `test -f 'curlx/wait.c' || echo '$(srcdir)/'`curlx/wait.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurlu_la-wait.Tpo curlx/$(DEPDIR)/libcurlu_la-wait.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/wait.c' object='curlx/libcurlu_la-wait.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o curlx/libcurlu_la-wait.lo `test -f 'curlx/wait.c' || echo '$(srcdir)/'`curlx/wait.c + +curlx/libcurlu_la-warnless.lo: curlx/warnless.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT curlx/libcurlu_la-warnless.lo -MD -MP -MF curlx/$(DEPDIR)/libcurlu_la-warnless.Tpo -c -o curlx/libcurlu_la-warnless.lo `test -f 'curlx/warnless.c' || echo '$(srcdir)/'`curlx/warnless.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurlu_la-warnless.Tpo curlx/$(DEPDIR)/libcurlu_la-warnless.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/warnless.c' object='curlx/libcurlu_la-warnless.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o curlx/libcurlu_la-warnless.lo `test -f 'curlx/warnless.c' || echo '$(srcdir)/'`curlx/warnless.c + +curlx/libcurlu_la-winapi.lo: curlx/winapi.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT curlx/libcurlu_la-winapi.lo -MD -MP -MF curlx/$(DEPDIR)/libcurlu_la-winapi.Tpo -c -o curlx/libcurlu_la-winapi.lo `test -f 'curlx/winapi.c' || echo '$(srcdir)/'`curlx/winapi.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) curlx/$(DEPDIR)/libcurlu_la-winapi.Tpo curlx/$(DEPDIR)/libcurlu_la-winapi.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='curlx/winapi.c' object='curlx/libcurlu_la-winapi.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o curlx/libcurlu_la-winapi.lo `test -f 'curlx/winapi.c' || echo '$(srcdir)/'`curlx/winapi.c + +libcurlu_la-dllmain.lo: dllmain.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-dllmain.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-dllmain.Tpo -c -o libcurlu_la-dllmain.lo `test -f 'dllmain.c' || echo '$(srcdir)/'`dllmain.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-dllmain.Tpo $(DEPDIR)/libcurlu_la-dllmain.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='dllmain.c' object='libcurlu_la-dllmain.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-dllmain.lo `test -f 'dllmain.c' || echo '$(srcdir)/'`dllmain.c + +libcurlu_la-libcurl_unity.lo: libcurl_unity.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libcurlu_la-libcurl_unity.lo -MD -MP -MF $(DEPDIR)/libcurlu_la-libcurl_unity.Tpo -c -o libcurlu_la-libcurl_unity.lo `test -f 'libcurl_unity.c' || echo '$(srcdir)/'`libcurl_unity.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libcurlu_la-libcurl_unity.Tpo $(DEPDIR)/libcurlu_la-libcurl_unity.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='libcurl_unity.c' object='libcurlu_la-libcurl_unity.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcurlu_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libcurlu_la-libcurl_unity.lo `test -f 'libcurl_unity.c' || echo '$(srcdir)/'`libcurl_unity.c + +mostlyclean-libtool: + -rm -f *.lo + +clean-libtool: + -rm -rf .libs _libs + -rm -rf curlx/.libs curlx/_libs + -rm -rf vauth/.libs vauth/_libs + -rm -rf vquic/.libs vquic/_libs + -rm -rf vssh/.libs vssh/_libs + -rm -rf vtls/.libs vtls/_libs + +ID: $(am__tagged_files) + $(am__define_uniq_tagged_files); mkid -fID $$unique +tags: tags-am +TAGS: tags + +tags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) + set x; \ + here=`pwd`; \ + $(am__define_uniq_tagged_files); \ + shift; \ + if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \ + test -n "$$unique" || unique=$$empty_fix; \ + if test $$# -gt 0; then \ + $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ + "$$@" $$unique; \ + else \ + $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ + $$unique; \ + fi; \ + fi +ctags: ctags-am + +CTAGS: ctags +ctags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) + $(am__define_uniq_tagged_files); \ + test -z "$(CTAGS_ARGS)$$unique" \ + || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ + $$unique + +GTAGS: + here=`$(am__cd) $(top_builddir) && pwd` \ + && $(am__cd) $(top_srcdir) \ + && gtags -i $(GTAGS_ARGS) "$$here" +cscopelist: cscopelist-am + +cscopelist-am: $(am__tagged_files) + list='$(am__tagged_files)'; \ + case "$(srcdir)" in \ + [\\/]* | ?:[\\/]*) sdir="$(srcdir)" ;; \ + *) sdir=$(subdir)/$(srcdir) ;; \ + esac; \ + for i in $$list; do \ + if test -f "$$i"; then \ + echo "$(subdir)/$$i"; \ + else \ + echo "$$sdir/$$i"; \ + fi; \ + done >> $(top_builddir)/cscope.files + +distclean-tags: + -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags +distdir: $(BUILT_SOURCES) + $(MAKE) $(AM_MAKEFLAGS) distdir-am + +distdir-am: $(DISTFILES) + @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ + topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ + list='$(DISTFILES)'; \ + dist_files=`for file in $$list; do echo $$file; done | \ + sed -e "s|^$$srcdirstrip/||;t" \ + -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ + case $$dist_files in \ + */*) $(MKDIR_P) `echo "$$dist_files" | \ + sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ + sort -u` ;; \ + esac; \ + for file in $$dist_files; do \ + if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ + if test -d $$d/$$file; then \ + dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ + if test -d "$(distdir)/$$file"; then \ + find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ + fi; \ + if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ + cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ + find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ + fi; \ + cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ + else \ + test -f "$(distdir)/$$file" \ + || cp -p $$d/$$file "$(distdir)/$$file" \ + || exit 1; \ + fi; \ + done +check-am: all-am +check: check-am +all-am: Makefile $(LTLIBRARIES) curl_config.h all-local +installdirs: + for dir in "$(DESTDIR)$(libdir)"; do \ + test -z "$$dir" || $(MKDIR_P) "$$dir"; \ + done +install: install-am +install-exec: install-exec-am +install-data: install-data-am +uninstall: uninstall-am + +install-am: all-am + @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am + +installcheck: installcheck-am +install-strip: + if test -z '$(STRIP)'; then \ + $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ + install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ + install; \ + else \ + $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ + install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ + "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \ + fi +mostlyclean-generic: + +clean-generic: + -test -z "$(CLEANFILES)" || rm -f $(CLEANFILES) + +distclean-generic: + -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) + -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) + -rm -f curlx/$(DEPDIR)/$(am__dirstamp) + -rm -f curlx/$(am__dirstamp) + -rm -f vauth/$(DEPDIR)/$(am__dirstamp) + -rm -f vauth/$(am__dirstamp) + -rm -f vquic/$(DEPDIR)/$(am__dirstamp) + -rm -f vquic/$(am__dirstamp) + -rm -f vssh/$(DEPDIR)/$(am__dirstamp) + -rm -f vssh/$(am__dirstamp) + -rm -f vtls/$(DEPDIR)/$(am__dirstamp) + -rm -f vtls/$(am__dirstamp) + +maintainer-clean-generic: + @echo "This command is intended for maintainers to use" + @echo "it deletes files that may require special tools to rebuild." +clean: clean-am + +clean-am: clean-generic clean-libLTLIBRARIES clean-libtool \ + clean-noinstLTLIBRARIES mostlyclean-am + +distclean: distclean-am + -rm -f ./$(DEPDIR)/libcurl_la-altsvc.Plo + -rm -f ./$(DEPDIR)/libcurl_la-amigaos.Plo + -rm -f ./$(DEPDIR)/libcurl_la-asyn-ares.Plo + -rm -f ./$(DEPDIR)/libcurl_la-asyn-base.Plo + -rm -f ./$(DEPDIR)/libcurl_la-asyn-thrdd.Plo + -rm -f ./$(DEPDIR)/libcurl_la-bufq.Plo + -rm -f ./$(DEPDIR)/libcurl_la-bufref.Plo + -rm -f ./$(DEPDIR)/libcurl_la-cf-dns.Plo + -rm -f ./$(DEPDIR)/libcurl_la-cf-h1-proxy.Plo + -rm -f ./$(DEPDIR)/libcurl_la-cf-h2-proxy.Plo + -rm -f ./$(DEPDIR)/libcurl_la-cf-haproxy.Plo + -rm -f ./$(DEPDIR)/libcurl_la-cf-https-connect.Plo + -rm -f ./$(DEPDIR)/libcurl_la-cf-ip-happy.Plo + -rm -f ./$(DEPDIR)/libcurl_la-cf-recvbuf.Plo + -rm -f ./$(DEPDIR)/libcurl_la-cf-setup.Plo + -rm -f ./$(DEPDIR)/libcurl_la-cf-socket.Plo + -rm -f ./$(DEPDIR)/libcurl_la-cfilters.Plo + -rm -f ./$(DEPDIR)/libcurl_la-conncache.Plo + -rm -f ./$(DEPDIR)/libcurl_la-connect.Plo + -rm -f ./$(DEPDIR)/libcurl_la-content_encoding.Plo + -rm -f ./$(DEPDIR)/libcurl_la-cookie.Plo + -rm -f ./$(DEPDIR)/libcurl_la-creds.Plo + -rm -f ./$(DEPDIR)/libcurl_la-cshutdn.Plo + -rm -f ./$(DEPDIR)/libcurl_la-curl_addrinfo.Plo + -rm -f ./$(DEPDIR)/libcurl_la-curl_endian.Plo + -rm -f ./$(DEPDIR)/libcurl_la-curl_fnmatch.Plo + -rm -f ./$(DEPDIR)/libcurl_la-curl_fopen.Plo + -rm -f ./$(DEPDIR)/libcurl_la-curl_get_line.Plo + -rm -f ./$(DEPDIR)/libcurl_la-curl_gethostname.Plo + -rm -f ./$(DEPDIR)/libcurl_la-curl_gssapi.Plo + -rm -f ./$(DEPDIR)/libcurl_la-curl_memrchr.Plo + -rm -f ./$(DEPDIR)/libcurl_la-curl_ntlm_core.Plo + -rm -f ./$(DEPDIR)/libcurl_la-curl_range.Plo + -rm -f ./$(DEPDIR)/libcurl_la-curl_sasl.Plo + -rm -f ./$(DEPDIR)/libcurl_la-curl_sha512_256.Plo + -rm -f ./$(DEPDIR)/libcurl_la-curl_share.Plo + -rm -f ./$(DEPDIR)/libcurl_la-curl_sspi.Plo + -rm -f ./$(DEPDIR)/libcurl_la-curl_threads.Plo + -rm -f ./$(DEPDIR)/libcurl_la-curl_trc.Plo + -rm -f ./$(DEPDIR)/libcurl_la-cw-out.Plo + -rm -f ./$(DEPDIR)/libcurl_la-cw-pause.Plo + -rm -f ./$(DEPDIR)/libcurl_la-dict.Plo + -rm -f ./$(DEPDIR)/libcurl_la-dllmain.Plo + -rm -f ./$(DEPDIR)/libcurl_la-dnscache.Plo + -rm -f ./$(DEPDIR)/libcurl_la-doh.Plo + -rm -f ./$(DEPDIR)/libcurl_la-dynhds.Plo + -rm -f ./$(DEPDIR)/libcurl_la-easy.Plo + -rm -f ./$(DEPDIR)/libcurl_la-easygetopt.Plo + -rm -f ./$(DEPDIR)/libcurl_la-easyoptions.Plo + -rm -f ./$(DEPDIR)/libcurl_la-escape.Plo + -rm -f ./$(DEPDIR)/libcurl_la-fake_addrinfo.Plo + -rm -f ./$(DEPDIR)/libcurl_la-file.Plo + -rm -f ./$(DEPDIR)/libcurl_la-fileinfo.Plo + -rm -f ./$(DEPDIR)/libcurl_la-formdata.Plo + -rm -f ./$(DEPDIR)/libcurl_la-ftp.Plo + -rm -f ./$(DEPDIR)/libcurl_la-ftplistparser.Plo + -rm -f ./$(DEPDIR)/libcurl_la-getenv.Plo + -rm -f ./$(DEPDIR)/libcurl_la-getinfo.Plo + -rm -f ./$(DEPDIR)/libcurl_la-gopher.Plo + -rm -f ./$(DEPDIR)/libcurl_la-hash.Plo + -rm -f ./$(DEPDIR)/libcurl_la-headers.Plo + -rm -f ./$(DEPDIR)/libcurl_la-hmac.Plo + -rm -f ./$(DEPDIR)/libcurl_la-hostip.Plo + -rm -f ./$(DEPDIR)/libcurl_la-hostip4.Plo + -rm -f ./$(DEPDIR)/libcurl_la-hostip6.Plo + -rm -f ./$(DEPDIR)/libcurl_la-hsts.Plo + -rm -f ./$(DEPDIR)/libcurl_la-http.Plo + -rm -f ./$(DEPDIR)/libcurl_la-http1.Plo + -rm -f ./$(DEPDIR)/libcurl_la-http2.Plo + -rm -f ./$(DEPDIR)/libcurl_la-http_aws_sigv4.Plo + -rm -f ./$(DEPDIR)/libcurl_la-http_chunks.Plo + -rm -f ./$(DEPDIR)/libcurl_la-http_digest.Plo + -rm -f ./$(DEPDIR)/libcurl_la-http_negotiate.Plo + -rm -f ./$(DEPDIR)/libcurl_la-http_ntlm.Plo + -rm -f ./$(DEPDIR)/libcurl_la-http_proxy.Plo + -rm -f ./$(DEPDIR)/libcurl_la-httpsrr.Plo + -rm -f ./$(DEPDIR)/libcurl_la-idn.Plo + -rm -f ./$(DEPDIR)/libcurl_la-if2ip.Plo + -rm -f ./$(DEPDIR)/libcurl_la-imap.Plo + -rm -f ./$(DEPDIR)/libcurl_la-ldap.Plo + -rm -f ./$(DEPDIR)/libcurl_la-libcurl_unity.Plo + -rm -f ./$(DEPDIR)/libcurl_la-llist.Plo + -rm -f ./$(DEPDIR)/libcurl_la-macos.Plo + -rm -f ./$(DEPDIR)/libcurl_la-md4.Plo + -rm -f ./$(DEPDIR)/libcurl_la-md5.Plo + -rm -f ./$(DEPDIR)/libcurl_la-memdebug.Plo + -rm -f ./$(DEPDIR)/libcurl_la-mime.Plo + -rm -f ./$(DEPDIR)/libcurl_la-mprintf.Plo + -rm -f ./$(DEPDIR)/libcurl_la-mqtt.Plo + -rm -f ./$(DEPDIR)/libcurl_la-multi.Plo + -rm -f ./$(DEPDIR)/libcurl_la-multi_ev.Plo + -rm -f ./$(DEPDIR)/libcurl_la-multi_ntfy.Plo + -rm -f ./$(DEPDIR)/libcurl_la-netrc.Plo + -rm -f ./$(DEPDIR)/libcurl_la-openldap.Plo + -rm -f ./$(DEPDIR)/libcurl_la-parsedate.Plo + -rm -f ./$(DEPDIR)/libcurl_la-peer.Plo + -rm -f ./$(DEPDIR)/libcurl_la-pingpong.Plo + -rm -f ./$(DEPDIR)/libcurl_la-pop3.Plo + -rm -f ./$(DEPDIR)/libcurl_la-progress.Plo + -rm -f ./$(DEPDIR)/libcurl_la-protocol.Plo + -rm -f ./$(DEPDIR)/libcurl_la-proxy.Plo + -rm -f ./$(DEPDIR)/libcurl_la-psl.Plo + -rm -f ./$(DEPDIR)/libcurl_la-rand.Plo + -rm -f ./$(DEPDIR)/libcurl_la-ratelimit.Plo + -rm -f ./$(DEPDIR)/libcurl_la-request.Plo + -rm -f ./$(DEPDIR)/libcurl_la-rtsp.Plo + -rm -f ./$(DEPDIR)/libcurl_la-select.Plo + -rm -f ./$(DEPDIR)/libcurl_la-sendf.Plo + -rm -f ./$(DEPDIR)/libcurl_la-setopt.Plo + -rm -f ./$(DEPDIR)/libcurl_la-sha256.Plo + -rm -f ./$(DEPDIR)/libcurl_la-slist.Plo + -rm -f ./$(DEPDIR)/libcurl_la-smb.Plo + -rm -f ./$(DEPDIR)/libcurl_la-smtp.Plo + -rm -f ./$(DEPDIR)/libcurl_la-socketpair.Plo + -rm -f ./$(DEPDIR)/libcurl_la-socks.Plo + -rm -f ./$(DEPDIR)/libcurl_la-socks_gssapi.Plo + -rm -f ./$(DEPDIR)/libcurl_la-socks_sspi.Plo + -rm -f ./$(DEPDIR)/libcurl_la-splay.Plo + -rm -f ./$(DEPDIR)/libcurl_la-strcase.Plo + -rm -f ./$(DEPDIR)/libcurl_la-strequal.Plo + -rm -f ./$(DEPDIR)/libcurl_la-strerror.Plo + -rm -f ./$(DEPDIR)/libcurl_la-system_win32.Plo + -rm -f ./$(DEPDIR)/libcurl_la-telnet.Plo + -rm -f ./$(DEPDIR)/libcurl_la-tftp.Plo + -rm -f ./$(DEPDIR)/libcurl_la-thrdpool.Plo + -rm -f ./$(DEPDIR)/libcurl_la-thrdqueue.Plo + -rm -f ./$(DEPDIR)/libcurl_la-transfer.Plo + -rm -f ./$(DEPDIR)/libcurl_la-uint-bset.Plo + -rm -f ./$(DEPDIR)/libcurl_la-uint-hash.Plo + -rm -f ./$(DEPDIR)/libcurl_la-uint-spbset.Plo + -rm -f ./$(DEPDIR)/libcurl_la-uint-table.Plo + -rm -f ./$(DEPDIR)/libcurl_la-url.Plo + -rm -f ./$(DEPDIR)/libcurl_la-urlapi.Plo + -rm -f ./$(DEPDIR)/libcurl_la-version.Plo + -rm -f ./$(DEPDIR)/libcurl_la-ws.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-altsvc.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-amigaos.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-asyn-ares.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-asyn-base.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-asyn-thrdd.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-bufq.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-bufref.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-cf-dns.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-cf-h1-proxy.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-cf-h2-proxy.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-cf-haproxy.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-cf-https-connect.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-cf-ip-happy.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-cf-recvbuf.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-cf-setup.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-cf-socket.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-cfilters.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-conncache.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-connect.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-content_encoding.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-cookie.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-creds.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-cshutdn.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-curl_addrinfo.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-curl_endian.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-curl_fnmatch.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-curl_fopen.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-curl_get_line.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-curl_gethostname.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-curl_gssapi.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-curl_memrchr.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-curl_ntlm_core.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-curl_range.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-curl_sasl.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-curl_sha512_256.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-curl_share.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-curl_sspi.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-curl_threads.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-curl_trc.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-cw-out.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-cw-pause.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-dict.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-dllmain.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-dnscache.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-doh.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-dynhds.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-easy.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-easygetopt.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-easyoptions.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-escape.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-fake_addrinfo.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-file.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-fileinfo.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-formdata.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-ftp.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-ftplistparser.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-getenv.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-getinfo.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-gopher.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-hash.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-headers.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-hmac.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-hostip.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-hostip4.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-hostip6.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-hsts.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-http.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-http1.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-http2.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-http_aws_sigv4.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-http_chunks.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-http_digest.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-http_negotiate.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-http_ntlm.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-http_proxy.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-httpsrr.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-idn.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-if2ip.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-imap.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-ldap.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-libcurl_unity.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-llist.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-macos.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-md4.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-md5.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-memdebug.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-mime.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-mprintf.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-mqtt.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-multi.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-multi_ev.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-multi_ntfy.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-netrc.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-openldap.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-parsedate.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-peer.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-pingpong.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-pop3.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-progress.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-protocol.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-proxy.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-psl.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-rand.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-ratelimit.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-request.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-rtsp.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-select.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-sendf.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-setopt.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-sha256.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-slist.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-smb.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-smtp.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-socketpair.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-socks.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-socks_gssapi.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-socks_sspi.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-splay.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-strcase.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-strequal.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-strerror.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-system_win32.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-telnet.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-tftp.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-thrdpool.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-thrdqueue.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-transfer.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-uint-bset.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-uint-hash.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-uint-spbset.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-uint-table.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-url.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-urlapi.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-version.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-ws.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-base64.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-basename.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-dynbuf.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-fopen.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-inet_ntop.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-inet_pton.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-multibyte.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-nonblock.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-snprintf.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-strcopy.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-strdup.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-strerr.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-strparse.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-timediff.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-timeval.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-version_win32.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-wait.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-warnless.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-winapi.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-base64.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-basename.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-dynbuf.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-fopen.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-inet_ntop.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-inet_pton.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-multibyte.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-nonblock.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-snprintf.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-strcopy.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-strdup.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-strerr.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-strparse.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-timediff.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-timeval.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-version_win32.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-wait.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-warnless.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-winapi.Plo + -rm -f vauth/$(DEPDIR)/libcurl_la-cleartext.Plo + -rm -f vauth/$(DEPDIR)/libcurl_la-cram.Plo + -rm -f vauth/$(DEPDIR)/libcurl_la-digest.Plo + -rm -f vauth/$(DEPDIR)/libcurl_la-digest_sspi.Plo + -rm -f vauth/$(DEPDIR)/libcurl_la-gsasl.Plo + -rm -f vauth/$(DEPDIR)/libcurl_la-krb5_gssapi.Plo + -rm -f vauth/$(DEPDIR)/libcurl_la-krb5_sspi.Plo + -rm -f vauth/$(DEPDIR)/libcurl_la-ntlm.Plo + -rm -f vauth/$(DEPDIR)/libcurl_la-ntlm_sspi.Plo + -rm -f vauth/$(DEPDIR)/libcurl_la-oauth2.Plo + -rm -f vauth/$(DEPDIR)/libcurl_la-spnego_gssapi.Plo + -rm -f vauth/$(DEPDIR)/libcurl_la-spnego_sspi.Plo + -rm -f vauth/$(DEPDIR)/libcurl_la-vauth.Plo + -rm -f vauth/$(DEPDIR)/libcurlu_la-cleartext.Plo + -rm -f vauth/$(DEPDIR)/libcurlu_la-cram.Plo + -rm -f vauth/$(DEPDIR)/libcurlu_la-digest.Plo + -rm -f vauth/$(DEPDIR)/libcurlu_la-digest_sspi.Plo + -rm -f vauth/$(DEPDIR)/libcurlu_la-gsasl.Plo + -rm -f vauth/$(DEPDIR)/libcurlu_la-krb5_gssapi.Plo + -rm -f vauth/$(DEPDIR)/libcurlu_la-krb5_sspi.Plo + -rm -f vauth/$(DEPDIR)/libcurlu_la-ntlm.Plo + -rm -f vauth/$(DEPDIR)/libcurlu_la-ntlm_sspi.Plo + -rm -f vauth/$(DEPDIR)/libcurlu_la-oauth2.Plo + -rm -f vauth/$(DEPDIR)/libcurlu_la-spnego_gssapi.Plo + -rm -f vauth/$(DEPDIR)/libcurlu_la-spnego_sspi.Plo + -rm -f vauth/$(DEPDIR)/libcurlu_la-vauth.Plo + -rm -f vquic/$(DEPDIR)/libcurl_la-capsule.Plo + -rm -f vquic/$(DEPDIR)/libcurl_la-cf-capsule.Plo + -rm -f vquic/$(DEPDIR)/libcurl_la-cf-ngtcp2-cmn.Plo + -rm -f vquic/$(DEPDIR)/libcurl_la-cf-ngtcp2-proxy.Plo + -rm -f vquic/$(DEPDIR)/libcurl_la-cf-ngtcp2.Plo + -rm -f vquic/$(DEPDIR)/libcurl_la-cf-quiche.Plo + -rm -f vquic/$(DEPDIR)/libcurl_la-vquic-tls.Plo + -rm -f vquic/$(DEPDIR)/libcurl_la-vquic.Plo + -rm -f vquic/$(DEPDIR)/libcurlu_la-capsule.Plo + -rm -f vquic/$(DEPDIR)/libcurlu_la-cf-capsule.Plo + -rm -f vquic/$(DEPDIR)/libcurlu_la-cf-ngtcp2-cmn.Plo + -rm -f vquic/$(DEPDIR)/libcurlu_la-cf-ngtcp2-proxy.Plo + -rm -f vquic/$(DEPDIR)/libcurlu_la-cf-ngtcp2.Plo + -rm -f vquic/$(DEPDIR)/libcurlu_la-cf-quiche.Plo + -rm -f vquic/$(DEPDIR)/libcurlu_la-vquic-tls.Plo + -rm -f vquic/$(DEPDIR)/libcurlu_la-vquic.Plo + -rm -f vssh/$(DEPDIR)/libcurl_la-libssh.Plo + -rm -f vssh/$(DEPDIR)/libcurl_la-libssh2.Plo + -rm -f vssh/$(DEPDIR)/libcurl_la-vssh.Plo + -rm -f vssh/$(DEPDIR)/libcurlu_la-libssh.Plo + -rm -f vssh/$(DEPDIR)/libcurlu_la-libssh2.Plo + -rm -f vssh/$(DEPDIR)/libcurlu_la-vssh.Plo + -rm -f vtls/$(DEPDIR)/libcurl_la-apple.Plo + -rm -f vtls/$(DEPDIR)/libcurl_la-cipher_suite.Plo + -rm -f vtls/$(DEPDIR)/libcurl_la-gtls.Plo + -rm -f vtls/$(DEPDIR)/libcurl_la-hostcheck.Plo + -rm -f vtls/$(DEPDIR)/libcurl_la-keylog.Plo + -rm -f vtls/$(DEPDIR)/libcurl_la-mbedtls.Plo + -rm -f vtls/$(DEPDIR)/libcurl_la-openssl.Plo + -rm -f vtls/$(DEPDIR)/libcurl_la-rustls.Plo + -rm -f vtls/$(DEPDIR)/libcurl_la-schannel.Plo + -rm -f vtls/$(DEPDIR)/libcurl_la-schannel_verify.Plo + -rm -f vtls/$(DEPDIR)/libcurl_la-vtls.Plo + -rm -f vtls/$(DEPDIR)/libcurl_la-vtls_config.Plo + -rm -f vtls/$(DEPDIR)/libcurl_la-vtls_scache.Plo + -rm -f vtls/$(DEPDIR)/libcurl_la-vtls_spack.Plo + -rm -f vtls/$(DEPDIR)/libcurl_la-wolfssl.Plo + -rm -f vtls/$(DEPDIR)/libcurl_la-x509asn1.Plo + -rm -f vtls/$(DEPDIR)/libcurlu_la-apple.Plo + -rm -f vtls/$(DEPDIR)/libcurlu_la-cipher_suite.Plo + -rm -f vtls/$(DEPDIR)/libcurlu_la-gtls.Plo + -rm -f vtls/$(DEPDIR)/libcurlu_la-hostcheck.Plo + -rm -f vtls/$(DEPDIR)/libcurlu_la-keylog.Plo + -rm -f vtls/$(DEPDIR)/libcurlu_la-mbedtls.Plo + -rm -f vtls/$(DEPDIR)/libcurlu_la-openssl.Plo + -rm -f vtls/$(DEPDIR)/libcurlu_la-rustls.Plo + -rm -f vtls/$(DEPDIR)/libcurlu_la-schannel.Plo + -rm -f vtls/$(DEPDIR)/libcurlu_la-schannel_verify.Plo + -rm -f vtls/$(DEPDIR)/libcurlu_la-vtls.Plo + -rm -f vtls/$(DEPDIR)/libcurlu_la-vtls_config.Plo + -rm -f vtls/$(DEPDIR)/libcurlu_la-vtls_scache.Plo + -rm -f vtls/$(DEPDIR)/libcurlu_la-vtls_spack.Plo + -rm -f vtls/$(DEPDIR)/libcurlu_la-wolfssl.Plo + -rm -f vtls/$(DEPDIR)/libcurlu_la-x509asn1.Plo + -rm -f Makefile +distclean-am: clean-am distclean-compile distclean-generic \ + distclean-hdr distclean-tags + +dvi: dvi-am + +dvi-am: + +html: html-am + +html-am: + +info: info-am + +info-am: + +install-data-am: + +install-dvi: install-dvi-am + +install-dvi-am: + +install-exec-am: install-libLTLIBRARIES + +install-html: install-html-am + +install-html-am: + +install-info: install-info-am + +install-info-am: + +install-man: + +install-pdf: install-pdf-am + +install-pdf-am: + +install-ps: install-ps-am + +install-ps-am: + +installcheck-am: + +maintainer-clean: maintainer-clean-am + -rm -f ./$(DEPDIR)/libcurl_la-altsvc.Plo + -rm -f ./$(DEPDIR)/libcurl_la-amigaos.Plo + -rm -f ./$(DEPDIR)/libcurl_la-asyn-ares.Plo + -rm -f ./$(DEPDIR)/libcurl_la-asyn-base.Plo + -rm -f ./$(DEPDIR)/libcurl_la-asyn-thrdd.Plo + -rm -f ./$(DEPDIR)/libcurl_la-bufq.Plo + -rm -f ./$(DEPDIR)/libcurl_la-bufref.Plo + -rm -f ./$(DEPDIR)/libcurl_la-cf-dns.Plo + -rm -f ./$(DEPDIR)/libcurl_la-cf-h1-proxy.Plo + -rm -f ./$(DEPDIR)/libcurl_la-cf-h2-proxy.Plo + -rm -f ./$(DEPDIR)/libcurl_la-cf-haproxy.Plo + -rm -f ./$(DEPDIR)/libcurl_la-cf-https-connect.Plo + -rm -f ./$(DEPDIR)/libcurl_la-cf-ip-happy.Plo + -rm -f ./$(DEPDIR)/libcurl_la-cf-recvbuf.Plo + -rm -f ./$(DEPDIR)/libcurl_la-cf-setup.Plo + -rm -f ./$(DEPDIR)/libcurl_la-cf-socket.Plo + -rm -f ./$(DEPDIR)/libcurl_la-cfilters.Plo + -rm -f ./$(DEPDIR)/libcurl_la-conncache.Plo + -rm -f ./$(DEPDIR)/libcurl_la-connect.Plo + -rm -f ./$(DEPDIR)/libcurl_la-content_encoding.Plo + -rm -f ./$(DEPDIR)/libcurl_la-cookie.Plo + -rm -f ./$(DEPDIR)/libcurl_la-creds.Plo + -rm -f ./$(DEPDIR)/libcurl_la-cshutdn.Plo + -rm -f ./$(DEPDIR)/libcurl_la-curl_addrinfo.Plo + -rm -f ./$(DEPDIR)/libcurl_la-curl_endian.Plo + -rm -f ./$(DEPDIR)/libcurl_la-curl_fnmatch.Plo + -rm -f ./$(DEPDIR)/libcurl_la-curl_fopen.Plo + -rm -f ./$(DEPDIR)/libcurl_la-curl_get_line.Plo + -rm -f ./$(DEPDIR)/libcurl_la-curl_gethostname.Plo + -rm -f ./$(DEPDIR)/libcurl_la-curl_gssapi.Plo + -rm -f ./$(DEPDIR)/libcurl_la-curl_memrchr.Plo + -rm -f ./$(DEPDIR)/libcurl_la-curl_ntlm_core.Plo + -rm -f ./$(DEPDIR)/libcurl_la-curl_range.Plo + -rm -f ./$(DEPDIR)/libcurl_la-curl_sasl.Plo + -rm -f ./$(DEPDIR)/libcurl_la-curl_sha512_256.Plo + -rm -f ./$(DEPDIR)/libcurl_la-curl_share.Plo + -rm -f ./$(DEPDIR)/libcurl_la-curl_sspi.Plo + -rm -f ./$(DEPDIR)/libcurl_la-curl_threads.Plo + -rm -f ./$(DEPDIR)/libcurl_la-curl_trc.Plo + -rm -f ./$(DEPDIR)/libcurl_la-cw-out.Plo + -rm -f ./$(DEPDIR)/libcurl_la-cw-pause.Plo + -rm -f ./$(DEPDIR)/libcurl_la-dict.Plo + -rm -f ./$(DEPDIR)/libcurl_la-dllmain.Plo + -rm -f ./$(DEPDIR)/libcurl_la-dnscache.Plo + -rm -f ./$(DEPDIR)/libcurl_la-doh.Plo + -rm -f ./$(DEPDIR)/libcurl_la-dynhds.Plo + -rm -f ./$(DEPDIR)/libcurl_la-easy.Plo + -rm -f ./$(DEPDIR)/libcurl_la-easygetopt.Plo + -rm -f ./$(DEPDIR)/libcurl_la-easyoptions.Plo + -rm -f ./$(DEPDIR)/libcurl_la-escape.Plo + -rm -f ./$(DEPDIR)/libcurl_la-fake_addrinfo.Plo + -rm -f ./$(DEPDIR)/libcurl_la-file.Plo + -rm -f ./$(DEPDIR)/libcurl_la-fileinfo.Plo + -rm -f ./$(DEPDIR)/libcurl_la-formdata.Plo + -rm -f ./$(DEPDIR)/libcurl_la-ftp.Plo + -rm -f ./$(DEPDIR)/libcurl_la-ftplistparser.Plo + -rm -f ./$(DEPDIR)/libcurl_la-getenv.Plo + -rm -f ./$(DEPDIR)/libcurl_la-getinfo.Plo + -rm -f ./$(DEPDIR)/libcurl_la-gopher.Plo + -rm -f ./$(DEPDIR)/libcurl_la-hash.Plo + -rm -f ./$(DEPDIR)/libcurl_la-headers.Plo + -rm -f ./$(DEPDIR)/libcurl_la-hmac.Plo + -rm -f ./$(DEPDIR)/libcurl_la-hostip.Plo + -rm -f ./$(DEPDIR)/libcurl_la-hostip4.Plo + -rm -f ./$(DEPDIR)/libcurl_la-hostip6.Plo + -rm -f ./$(DEPDIR)/libcurl_la-hsts.Plo + -rm -f ./$(DEPDIR)/libcurl_la-http.Plo + -rm -f ./$(DEPDIR)/libcurl_la-http1.Plo + -rm -f ./$(DEPDIR)/libcurl_la-http2.Plo + -rm -f ./$(DEPDIR)/libcurl_la-http_aws_sigv4.Plo + -rm -f ./$(DEPDIR)/libcurl_la-http_chunks.Plo + -rm -f ./$(DEPDIR)/libcurl_la-http_digest.Plo + -rm -f ./$(DEPDIR)/libcurl_la-http_negotiate.Plo + -rm -f ./$(DEPDIR)/libcurl_la-http_ntlm.Plo + -rm -f ./$(DEPDIR)/libcurl_la-http_proxy.Plo + -rm -f ./$(DEPDIR)/libcurl_la-httpsrr.Plo + -rm -f ./$(DEPDIR)/libcurl_la-idn.Plo + -rm -f ./$(DEPDIR)/libcurl_la-if2ip.Plo + -rm -f ./$(DEPDIR)/libcurl_la-imap.Plo + -rm -f ./$(DEPDIR)/libcurl_la-ldap.Plo + -rm -f ./$(DEPDIR)/libcurl_la-libcurl_unity.Plo + -rm -f ./$(DEPDIR)/libcurl_la-llist.Plo + -rm -f ./$(DEPDIR)/libcurl_la-macos.Plo + -rm -f ./$(DEPDIR)/libcurl_la-md4.Plo + -rm -f ./$(DEPDIR)/libcurl_la-md5.Plo + -rm -f ./$(DEPDIR)/libcurl_la-memdebug.Plo + -rm -f ./$(DEPDIR)/libcurl_la-mime.Plo + -rm -f ./$(DEPDIR)/libcurl_la-mprintf.Plo + -rm -f ./$(DEPDIR)/libcurl_la-mqtt.Plo + -rm -f ./$(DEPDIR)/libcurl_la-multi.Plo + -rm -f ./$(DEPDIR)/libcurl_la-multi_ev.Plo + -rm -f ./$(DEPDIR)/libcurl_la-multi_ntfy.Plo + -rm -f ./$(DEPDIR)/libcurl_la-netrc.Plo + -rm -f ./$(DEPDIR)/libcurl_la-openldap.Plo + -rm -f ./$(DEPDIR)/libcurl_la-parsedate.Plo + -rm -f ./$(DEPDIR)/libcurl_la-peer.Plo + -rm -f ./$(DEPDIR)/libcurl_la-pingpong.Plo + -rm -f ./$(DEPDIR)/libcurl_la-pop3.Plo + -rm -f ./$(DEPDIR)/libcurl_la-progress.Plo + -rm -f ./$(DEPDIR)/libcurl_la-protocol.Plo + -rm -f ./$(DEPDIR)/libcurl_la-proxy.Plo + -rm -f ./$(DEPDIR)/libcurl_la-psl.Plo + -rm -f ./$(DEPDIR)/libcurl_la-rand.Plo + -rm -f ./$(DEPDIR)/libcurl_la-ratelimit.Plo + -rm -f ./$(DEPDIR)/libcurl_la-request.Plo + -rm -f ./$(DEPDIR)/libcurl_la-rtsp.Plo + -rm -f ./$(DEPDIR)/libcurl_la-select.Plo + -rm -f ./$(DEPDIR)/libcurl_la-sendf.Plo + -rm -f ./$(DEPDIR)/libcurl_la-setopt.Plo + -rm -f ./$(DEPDIR)/libcurl_la-sha256.Plo + -rm -f ./$(DEPDIR)/libcurl_la-slist.Plo + -rm -f ./$(DEPDIR)/libcurl_la-smb.Plo + -rm -f ./$(DEPDIR)/libcurl_la-smtp.Plo + -rm -f ./$(DEPDIR)/libcurl_la-socketpair.Plo + -rm -f ./$(DEPDIR)/libcurl_la-socks.Plo + -rm -f ./$(DEPDIR)/libcurl_la-socks_gssapi.Plo + -rm -f ./$(DEPDIR)/libcurl_la-socks_sspi.Plo + -rm -f ./$(DEPDIR)/libcurl_la-splay.Plo + -rm -f ./$(DEPDIR)/libcurl_la-strcase.Plo + -rm -f ./$(DEPDIR)/libcurl_la-strequal.Plo + -rm -f ./$(DEPDIR)/libcurl_la-strerror.Plo + -rm -f ./$(DEPDIR)/libcurl_la-system_win32.Plo + -rm -f ./$(DEPDIR)/libcurl_la-telnet.Plo + -rm -f ./$(DEPDIR)/libcurl_la-tftp.Plo + -rm -f ./$(DEPDIR)/libcurl_la-thrdpool.Plo + -rm -f ./$(DEPDIR)/libcurl_la-thrdqueue.Plo + -rm -f ./$(DEPDIR)/libcurl_la-transfer.Plo + -rm -f ./$(DEPDIR)/libcurl_la-uint-bset.Plo + -rm -f ./$(DEPDIR)/libcurl_la-uint-hash.Plo + -rm -f ./$(DEPDIR)/libcurl_la-uint-spbset.Plo + -rm -f ./$(DEPDIR)/libcurl_la-uint-table.Plo + -rm -f ./$(DEPDIR)/libcurl_la-url.Plo + -rm -f ./$(DEPDIR)/libcurl_la-urlapi.Plo + -rm -f ./$(DEPDIR)/libcurl_la-version.Plo + -rm -f ./$(DEPDIR)/libcurl_la-ws.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-altsvc.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-amigaos.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-asyn-ares.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-asyn-base.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-asyn-thrdd.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-bufq.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-bufref.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-cf-dns.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-cf-h1-proxy.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-cf-h2-proxy.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-cf-haproxy.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-cf-https-connect.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-cf-ip-happy.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-cf-recvbuf.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-cf-setup.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-cf-socket.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-cfilters.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-conncache.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-connect.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-content_encoding.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-cookie.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-creds.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-cshutdn.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-curl_addrinfo.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-curl_endian.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-curl_fnmatch.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-curl_fopen.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-curl_get_line.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-curl_gethostname.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-curl_gssapi.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-curl_memrchr.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-curl_ntlm_core.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-curl_range.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-curl_sasl.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-curl_sha512_256.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-curl_share.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-curl_sspi.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-curl_threads.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-curl_trc.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-cw-out.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-cw-pause.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-dict.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-dllmain.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-dnscache.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-doh.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-dynhds.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-easy.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-easygetopt.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-easyoptions.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-escape.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-fake_addrinfo.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-file.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-fileinfo.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-formdata.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-ftp.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-ftplistparser.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-getenv.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-getinfo.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-gopher.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-hash.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-headers.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-hmac.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-hostip.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-hostip4.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-hostip6.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-hsts.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-http.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-http1.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-http2.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-http_aws_sigv4.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-http_chunks.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-http_digest.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-http_negotiate.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-http_ntlm.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-http_proxy.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-httpsrr.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-idn.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-if2ip.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-imap.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-ldap.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-libcurl_unity.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-llist.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-macos.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-md4.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-md5.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-memdebug.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-mime.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-mprintf.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-mqtt.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-multi.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-multi_ev.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-multi_ntfy.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-netrc.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-openldap.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-parsedate.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-peer.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-pingpong.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-pop3.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-progress.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-protocol.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-proxy.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-psl.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-rand.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-ratelimit.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-request.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-rtsp.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-select.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-sendf.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-setopt.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-sha256.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-slist.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-smb.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-smtp.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-socketpair.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-socks.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-socks_gssapi.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-socks_sspi.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-splay.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-strcase.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-strequal.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-strerror.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-system_win32.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-telnet.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-tftp.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-thrdpool.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-thrdqueue.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-transfer.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-uint-bset.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-uint-hash.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-uint-spbset.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-uint-table.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-url.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-urlapi.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-version.Plo + -rm -f ./$(DEPDIR)/libcurlu_la-ws.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-base64.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-basename.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-dynbuf.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-fopen.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-inet_ntop.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-inet_pton.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-multibyte.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-nonblock.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-snprintf.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-strcopy.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-strdup.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-strerr.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-strparse.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-timediff.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-timeval.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-version_win32.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-wait.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-warnless.Plo + -rm -f curlx/$(DEPDIR)/libcurl_la-winapi.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-base64.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-basename.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-dynbuf.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-fopen.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-inet_ntop.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-inet_pton.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-multibyte.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-nonblock.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-snprintf.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-strcopy.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-strdup.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-strerr.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-strparse.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-timediff.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-timeval.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-version_win32.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-wait.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-warnless.Plo + -rm -f curlx/$(DEPDIR)/libcurlu_la-winapi.Plo + -rm -f vauth/$(DEPDIR)/libcurl_la-cleartext.Plo + -rm -f vauth/$(DEPDIR)/libcurl_la-cram.Plo + -rm -f vauth/$(DEPDIR)/libcurl_la-digest.Plo + -rm -f vauth/$(DEPDIR)/libcurl_la-digest_sspi.Plo + -rm -f vauth/$(DEPDIR)/libcurl_la-gsasl.Plo + -rm -f vauth/$(DEPDIR)/libcurl_la-krb5_gssapi.Plo + -rm -f vauth/$(DEPDIR)/libcurl_la-krb5_sspi.Plo + -rm -f vauth/$(DEPDIR)/libcurl_la-ntlm.Plo + -rm -f vauth/$(DEPDIR)/libcurl_la-ntlm_sspi.Plo + -rm -f vauth/$(DEPDIR)/libcurl_la-oauth2.Plo + -rm -f vauth/$(DEPDIR)/libcurl_la-spnego_gssapi.Plo + -rm -f vauth/$(DEPDIR)/libcurl_la-spnego_sspi.Plo + -rm -f vauth/$(DEPDIR)/libcurl_la-vauth.Plo + -rm -f vauth/$(DEPDIR)/libcurlu_la-cleartext.Plo + -rm -f vauth/$(DEPDIR)/libcurlu_la-cram.Plo + -rm -f vauth/$(DEPDIR)/libcurlu_la-digest.Plo + -rm -f vauth/$(DEPDIR)/libcurlu_la-digest_sspi.Plo + -rm -f vauth/$(DEPDIR)/libcurlu_la-gsasl.Plo + -rm -f vauth/$(DEPDIR)/libcurlu_la-krb5_gssapi.Plo + -rm -f vauth/$(DEPDIR)/libcurlu_la-krb5_sspi.Plo + -rm -f vauth/$(DEPDIR)/libcurlu_la-ntlm.Plo + -rm -f vauth/$(DEPDIR)/libcurlu_la-ntlm_sspi.Plo + -rm -f vauth/$(DEPDIR)/libcurlu_la-oauth2.Plo + -rm -f vauth/$(DEPDIR)/libcurlu_la-spnego_gssapi.Plo + -rm -f vauth/$(DEPDIR)/libcurlu_la-spnego_sspi.Plo + -rm -f vauth/$(DEPDIR)/libcurlu_la-vauth.Plo + -rm -f vquic/$(DEPDIR)/libcurl_la-capsule.Plo + -rm -f vquic/$(DEPDIR)/libcurl_la-cf-capsule.Plo + -rm -f vquic/$(DEPDIR)/libcurl_la-cf-ngtcp2-cmn.Plo + -rm -f vquic/$(DEPDIR)/libcurl_la-cf-ngtcp2-proxy.Plo + -rm -f vquic/$(DEPDIR)/libcurl_la-cf-ngtcp2.Plo + -rm -f vquic/$(DEPDIR)/libcurl_la-cf-quiche.Plo + -rm -f vquic/$(DEPDIR)/libcurl_la-vquic-tls.Plo + -rm -f vquic/$(DEPDIR)/libcurl_la-vquic.Plo + -rm -f vquic/$(DEPDIR)/libcurlu_la-capsule.Plo + -rm -f vquic/$(DEPDIR)/libcurlu_la-cf-capsule.Plo + -rm -f vquic/$(DEPDIR)/libcurlu_la-cf-ngtcp2-cmn.Plo + -rm -f vquic/$(DEPDIR)/libcurlu_la-cf-ngtcp2-proxy.Plo + -rm -f vquic/$(DEPDIR)/libcurlu_la-cf-ngtcp2.Plo + -rm -f vquic/$(DEPDIR)/libcurlu_la-cf-quiche.Plo + -rm -f vquic/$(DEPDIR)/libcurlu_la-vquic-tls.Plo + -rm -f vquic/$(DEPDIR)/libcurlu_la-vquic.Plo + -rm -f vssh/$(DEPDIR)/libcurl_la-libssh.Plo + -rm -f vssh/$(DEPDIR)/libcurl_la-libssh2.Plo + -rm -f vssh/$(DEPDIR)/libcurl_la-vssh.Plo + -rm -f vssh/$(DEPDIR)/libcurlu_la-libssh.Plo + -rm -f vssh/$(DEPDIR)/libcurlu_la-libssh2.Plo + -rm -f vssh/$(DEPDIR)/libcurlu_la-vssh.Plo + -rm -f vtls/$(DEPDIR)/libcurl_la-apple.Plo + -rm -f vtls/$(DEPDIR)/libcurl_la-cipher_suite.Plo + -rm -f vtls/$(DEPDIR)/libcurl_la-gtls.Plo + -rm -f vtls/$(DEPDIR)/libcurl_la-hostcheck.Plo + -rm -f vtls/$(DEPDIR)/libcurl_la-keylog.Plo + -rm -f vtls/$(DEPDIR)/libcurl_la-mbedtls.Plo + -rm -f vtls/$(DEPDIR)/libcurl_la-openssl.Plo + -rm -f vtls/$(DEPDIR)/libcurl_la-rustls.Plo + -rm -f vtls/$(DEPDIR)/libcurl_la-schannel.Plo + -rm -f vtls/$(DEPDIR)/libcurl_la-schannel_verify.Plo + -rm -f vtls/$(DEPDIR)/libcurl_la-vtls.Plo + -rm -f vtls/$(DEPDIR)/libcurl_la-vtls_config.Plo + -rm -f vtls/$(DEPDIR)/libcurl_la-vtls_scache.Plo + -rm -f vtls/$(DEPDIR)/libcurl_la-vtls_spack.Plo + -rm -f vtls/$(DEPDIR)/libcurl_la-wolfssl.Plo + -rm -f vtls/$(DEPDIR)/libcurl_la-x509asn1.Plo + -rm -f vtls/$(DEPDIR)/libcurlu_la-apple.Plo + -rm -f vtls/$(DEPDIR)/libcurlu_la-cipher_suite.Plo + -rm -f vtls/$(DEPDIR)/libcurlu_la-gtls.Plo + -rm -f vtls/$(DEPDIR)/libcurlu_la-hostcheck.Plo + -rm -f vtls/$(DEPDIR)/libcurlu_la-keylog.Plo + -rm -f vtls/$(DEPDIR)/libcurlu_la-mbedtls.Plo + -rm -f vtls/$(DEPDIR)/libcurlu_la-openssl.Plo + -rm -f vtls/$(DEPDIR)/libcurlu_la-rustls.Plo + -rm -f vtls/$(DEPDIR)/libcurlu_la-schannel.Plo + -rm -f vtls/$(DEPDIR)/libcurlu_la-schannel_verify.Plo + -rm -f vtls/$(DEPDIR)/libcurlu_la-vtls.Plo + -rm -f vtls/$(DEPDIR)/libcurlu_la-vtls_config.Plo + -rm -f vtls/$(DEPDIR)/libcurlu_la-vtls_scache.Plo + -rm -f vtls/$(DEPDIR)/libcurlu_la-vtls_spack.Plo + -rm -f vtls/$(DEPDIR)/libcurlu_la-wolfssl.Plo + -rm -f vtls/$(DEPDIR)/libcurlu_la-x509asn1.Plo + -rm -f Makefile +maintainer-clean-am: distclean-am maintainer-clean-generic + +mostlyclean: mostlyclean-am + +mostlyclean-am: mostlyclean-compile mostlyclean-generic \ + mostlyclean-libtool + +pdf: pdf-am + +pdf-am: + +ps: ps-am + +ps-am: + +uninstall-am: uninstall-libLTLIBRARIES + +.MAKE: all install-am install-strip + +.PHONY: CTAGS GTAGS TAGS all all-am all-local am--depfiles check \ + check-am clean clean-generic clean-libLTLIBRARIES \ + clean-libtool clean-noinstLTLIBRARIES cscopelist-am ctags \ + ctags-am distclean distclean-compile distclean-generic \ + distclean-hdr distclean-libtool distclean-tags distdir dvi \ + dvi-am html html-am info info-am install install-am \ + install-data install-data-am install-dvi install-dvi-am \ + install-exec install-exec-am install-html install-html-am \ + install-info install-info-am install-libLTLIBRARIES \ + install-man install-pdf install-pdf-am install-ps \ + install-ps-am install-strip installcheck installcheck-am \ + installdirs maintainer-clean maintainer-clean-generic \ + mostlyclean mostlyclean-compile mostlyclean-generic \ + mostlyclean-libtool pdf pdf-am ps ps-am tags tags-am uninstall \ + uninstall-am uninstall-libLTLIBRARIES + +.PRECIOUS: Makefile + + +@USE_UNITY_TRUE@libcurl_unity.c: $(top_srcdir)/scripts/mk-unity.pl $(CSOURCES) +@USE_UNITY_TRUE@ @PERL@ $(top_srcdir)/scripts/mk-unity.pl --include $(CSOURCES) > libcurl_unity.c +# This flag accepts an argument of the form current[:revision[:age]]. It means +# passing -version-info 3:12:1 sets current to 3, revision to 12, and age to 1. +# +# Here's the simplified rule guide on how to change -version-info: +# (current version is C:R:A) +# +# 1. if there are only source changes, use C:R+1:A +# 2. if interfaces were added use C+1:0:A+1 +# 3. if interfaces were removed, then use C+1:0:0 +# +# For the full guide on libcurl ABI rules, see docs/libcurl/ABI +@HAVE_WINDRES_TRUE@@USE_CPPFLAG_CURL_STATICLIB_FALSE@$(LIB_RCFILES): $(top_srcdir)/include/curl/curlver.h + +checksrc: + $(CHECKSRC)(@PERL@ $(top_srcdir)/scripts/checksrc.pl -D$(srcdir) $(CSOURCES) $(HHEADERS)) + +all-local: $(CHECKSOURCES) + +# UNITPROTOS depends on every C file in the lib/ dir +$(UNITPROTOS): $(CSOURCES) + $(UNIT_V)(cd $(srcdir) && @PERL@ ../scripts/extract-unit-protos $(CSOURCES)) > $(top_builddir)/lib/$(UNITPROTOS) + +tidy: + (_csources=`echo ' $(CSOURCES)' | sed -E -e 's/ +$$//' -e 's/ +/ /g' -e 's| | $(srcdir)/|g'`; \ + @CLANG_TIDY@ --config-file=$(top_srcdir)/.clang-tidy.yml $(TIDYFLAGS) $(CURL_CLANG_TIDYFLAGS) $$_csources \ + -- $(AM_CPPFLAGS) $(CPPFLAGS) -DHAVE_CONFIG_H $(_tidy_cflags)) + +optiontable: + @PERL@ $(srcdir)/optiontable.pl $(top_srcdir)/include/curl/curl.h > $(srcdir)/easyoptions.c + +@HAVE_WINDRES_TRUE@.rc.lo: +@HAVE_WINDRES_TRUE@ $(LIBTOOL) --tag=RC --mode=compile $(RC) -I$(top_srcdir)/include $(RCFLAGS) -i $< -o $@ + +# Tell versions [3.59,3.63) of GNU make to not export all variables. +# Otherwise a system limit (for SysV at least) may be exceeded. +.NOEXPORT: diff --git a/3rdparty/curl-8.21.0/lib/Makefile.inc b/3rdparty/curl-8.21.0/lib/Makefile.inc new file mode 100644 index 0000000000..266ba52af3 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/Makefile.inc @@ -0,0 +1,430 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# Shared between CMakeLists.txt and Makefile.am + +LIB_CURLX_CFILES = \ + curlx/base64.c \ + curlx/basename.c \ + curlx/dynbuf.c \ + curlx/fopen.c \ + curlx/inet_ntop.c \ + curlx/inet_pton.c \ + curlx/multibyte.c \ + curlx/nonblock.c \ + curlx/snprintf.c \ + curlx/strcopy.c \ + curlx/strdup.c \ + curlx/strerr.c \ + curlx/strparse.c \ + curlx/timediff.c \ + curlx/timeval.c \ + curlx/version_win32.c \ + curlx/wait.c \ + curlx/warnless.c \ + curlx/winapi.c + +LIB_CURLX_HFILES = \ + curlx/base64.h \ + curlx/basename.h \ + curlx/dynbuf.h \ + curlx/fopen.h \ + curlx/inet_ntop.h \ + curlx/inet_pton.h \ + curlx/multibyte.h \ + curlx/nonblock.h \ + curlx/snprintf.h \ + curlx/strcopy.h \ + curlx/strdup.h \ + curlx/strerr.h \ + curlx/strparse.h \ + curlx/timediff.h \ + curlx/timeval.h \ + curlx/version_win32.h \ + curlx/wait.h \ + curlx/warnless.h \ + curlx/winapi.h + +LIB_VAUTH_CFILES = \ + vauth/cleartext.c \ + vauth/cram.c \ + vauth/digest.c \ + vauth/digest_sspi.c \ + vauth/gsasl.c \ + vauth/krb5_gssapi.c \ + vauth/krb5_sspi.c \ + vauth/ntlm.c \ + vauth/ntlm_sspi.c \ + vauth/oauth2.c \ + vauth/spnego_gssapi.c \ + vauth/spnego_sspi.c \ + vauth/vauth.c + +LIB_VAUTH_HFILES = \ + vauth/digest.h \ + vauth/vauth.h + +LIB_VTLS_CFILES = \ + vtls/apple.c \ + vtls/cipher_suite.c \ + vtls/gtls.c \ + vtls/hostcheck.c \ + vtls/keylog.c \ + vtls/mbedtls.c \ + vtls/openssl.c \ + vtls/rustls.c \ + vtls/schannel.c \ + vtls/schannel_verify.c \ + vtls/vtls.c \ + vtls/vtls_config.c \ + vtls/vtls_scache.c \ + vtls/vtls_spack.c \ + vtls/wolfssl.c \ + vtls/x509asn1.c + +LIB_VTLS_HFILES = \ + vtls/apple.h \ + vtls/cipher_suite.h \ + vtls/gtls.h \ + vtls/hostcheck.h \ + vtls/keylog.h \ + vtls/mbedtls.h \ + vtls/openssl.h \ + vtls/rustls.h \ + vtls/schannel.h \ + vtls/schannel_int.h \ + vtls/vtls.h \ + vtls/vtls_config.h \ + vtls/vtls_int.h \ + vtls/vtls_scache.h \ + vtls/vtls_spack.h \ + vtls/wolfssl.h \ + vtls/x509asn1.h + +LIB_VQUIC_CFILES = \ + vquic/capsule.c \ + vquic/cf-capsule.c \ + vquic/cf-ngtcp2.c \ + vquic/cf-ngtcp2-cmn.c \ + vquic/cf-ngtcp2-proxy.c \ + vquic/cf-quiche.c \ + vquic/vquic.c \ + vquic/vquic-tls.c + +LIB_VQUIC_HFILES = \ + vquic/capsule.h \ + vquic/cf-capsule.h \ + vquic/cf-ngtcp2.h \ + vquic/cf-ngtcp2-cmn.h \ + vquic/cf-ngtcp2-proxy.h \ + vquic/cf-quiche.h \ + vquic/vquic.h \ + vquic/vquic_int.h \ + vquic/vquic-tls.h + +LIB_VSSH_CFILES = \ + vssh/libssh.c \ + vssh/libssh2.c \ + vssh/vssh.c + +LIB_VSSH_HFILES = \ + vssh/vssh.h \ + vssh/ssh.h + +LIB_CFILES = \ + altsvc.c \ + amigaos.c \ + asyn-ares.c \ + asyn-base.c \ + asyn-thrdd.c \ + bufq.c \ + bufref.c \ + cf-dns.c \ + cf-h1-proxy.c \ + cf-h2-proxy.c \ + cf-haproxy.c \ + cf-https-connect.c \ + cf-ip-happy.c \ + cf-recvbuf.c \ + cf-setup.c \ + cf-socket.c \ + cfilters.c \ + conncache.c \ + connect.c \ + content_encoding.c \ + cookie.c \ + creds.c \ + cshutdn.c \ + curl_addrinfo.c \ + curl_endian.c \ + curl_fnmatch.c \ + curl_fopen.c \ + curl_get_line.c \ + curl_gethostname.c \ + curl_gssapi.c \ + curl_memrchr.c \ + curl_ntlm_core.c \ + curl_range.c \ + curl_sasl.c \ + curl_sha512_256.c \ + curl_share.c \ + curl_sspi.c \ + curl_threads.c \ + curl_trc.c \ + cw-out.c \ + cw-pause.c \ + dict.c \ + dnscache.c \ + doh.c \ + dynhds.c \ + easy.c \ + easygetopt.c \ + easyoptions.c \ + escape.c \ + fake_addrinfo.c \ + file.c \ + fileinfo.c \ + formdata.c \ + ftp.c \ + ftplistparser.c \ + getenv.c \ + getinfo.c \ + gopher.c \ + hash.c \ + headers.c \ + hmac.c \ + hostip.c \ + hostip4.c \ + hostip6.c \ + hsts.c \ + http.c \ + http1.c \ + http2.c \ + http_aws_sigv4.c \ + http_chunks.c \ + http_digest.c \ + http_negotiate.c \ + http_ntlm.c \ + http_proxy.c \ + httpsrr.c \ + idn.c \ + if2ip.c \ + imap.c \ + ldap.c \ + llist.c \ + macos.c \ + md4.c \ + md5.c \ + memdebug.c \ + mime.c \ + mprintf.c \ + mqtt.c \ + multi.c \ + multi_ev.c \ + multi_ntfy.c \ + netrc.c \ + openldap.c \ + parsedate.c \ + peer.c \ + pingpong.c \ + pop3.c \ + progress.c \ + protocol.c \ + proxy.c \ + psl.c \ + rand.c \ + ratelimit.c \ + request.c \ + rtsp.c \ + select.c \ + sendf.c \ + setopt.c \ + sha256.c \ + slist.c \ + smb.c \ + smtp.c \ + socketpair.c \ + socks.c \ + socks_gssapi.c \ + socks_sspi.c \ + splay.c \ + strcase.c \ + strequal.c \ + strerror.c \ + system_win32.c \ + telnet.c \ + tftp.c \ + thrdpool.c \ + thrdqueue.c \ + transfer.c \ + uint-bset.c \ + uint-hash.c \ + uint-spbset.c \ + uint-table.c \ + url.c \ + urlapi.c \ + version.c \ + ws.c + +LIB_HFILES = \ + altsvc.h \ + amigaos.h \ + arpa_telnet.h \ + asyn.h \ + bufq.h \ + bufref.h \ + cf-dns.h \ + cf-h1-proxy.h \ + cf-h2-proxy.h \ + cf-haproxy.h \ + cf-https-connect.h \ + cf-ip-happy.h \ + cf-recvbuf.h \ + cf-setup.h \ + cf-socket.h \ + cfilters.h \ + conncache.h \ + cshutdn.h \ + connect.h \ + content_encoding.h \ + cookie.h \ + creds.h \ + curl_addrinfo.h \ + curl_ctype.h \ + curl_endian.h \ + curl_fnmatch.h \ + curl_fopen.h \ + curl_get_line.h \ + curl_gethostname.h \ + curl_gssapi.h \ + curl_hmac.h \ + curl_ldap.h \ + curl_md4.h \ + curl_md5.h \ + curl_memrchr.h \ + curl_ntlm_core.h \ + curl_printf.h \ + curl_range.h \ + curl_sasl.h \ + curl_setup.h \ + curl_sha256.h \ + curl_sha512_256.h \ + curl_share.h \ + curl_sspi.h \ + curl_threads.h \ + curl_trc.h \ + cw-out.h \ + cw-pause.h \ + dict.h \ + dnscache.h \ + doh.h \ + dynhds.h \ + easy_lock.h \ + easyif.h \ + easyoptions.h \ + escape.h \ + fake_addrinfo.h \ + file.h \ + fileinfo.h \ + formdata.h \ + ftp.h \ + ftp-int.h \ + ftplistparser.h \ + functypes.h \ + getinfo.h \ + gopher.h \ + hash.h \ + headers.h \ + hostip.h \ + hsts.h \ + http.h \ + http1.h \ + http2.h \ + http_aws_sigv4.h \ + http_chunks.h \ + http_digest.h \ + http_negotiate.h \ + http_ntlm.h \ + http_proxy.h \ + httpsrr.h \ + idn.h \ + if2ip.h \ + imap.h \ + llist.h \ + macos.h \ + mime.h \ + mqtt.h \ + multihandle.h \ + multi_ev.h \ + multi_ntfy.h \ + multiif.h \ + netrc.h \ + parsedate.h \ + peer.h \ + pingpong.h \ + pop3.h \ + progress.h \ + protocol.h \ + proxy.h \ + psl.h \ + rand.h \ + ratelimit.h \ + request.h \ + rtsp.h \ + select.h \ + sendf.h \ + setopt.h \ + setup-os400.h \ + setup-vms.h \ + setup-win32.h \ + sigpipe.h \ + slist.h \ + smb.h \ + smtp.h \ + sockaddr.h \ + socketpair.h \ + socks.h \ + splay.h \ + strcase.h \ + strerror.h \ + system_win32.h \ + telnet.h \ + tftp.h \ + thrdpool.h \ + thrdqueue.h \ + transfer.h \ + uint-bset.h \ + uint-hash.h \ + uint-spbset.h \ + uint-table.h \ + url.h \ + urlapi-int.h \ + urldata.h \ + ws.h + +LIB_RCFILES = libcurl.rc + +CSOURCES = $(LIB_CFILES) $(LIB_VAUTH_CFILES) $(LIB_VTLS_CFILES) \ + $(LIB_VQUIC_CFILES) $(LIB_VSSH_CFILES) $(LIB_CURLX_CFILES) +HHEADERS = $(LIB_HFILES) $(LIB_VAUTH_HFILES) $(LIB_VTLS_HFILES) \ + $(LIB_VQUIC_HFILES) $(LIB_VSSH_HFILES) $(LIB_CURLX_HFILES) diff --git a/3rdparty/curl-8.21.0/lib/Makefile.soname b/3rdparty/curl-8.21.0/lib/Makefile.soname new file mode 100644 index 0000000000..aadc7f413e --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/Makefile.soname @@ -0,0 +1,43 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# Shared between CMakeLists.txt and Makefile.am + +# Keep in sync with CURL_LIBCURL_VERSIONED_SYMBOLS_SONAME in configure.ac +VERSIONCHANGE=12 +VERSIONADD=0 +VERSIONDEL=8 + +# libtool version: +VERSIONINFO=-version-info $(VERSIONCHANGE):$(VERSIONADD):$(VERSIONDEL) +# This flag accepts an argument of the form current[:revision[:age]]. It means +# passing -version-info 3:12:1 sets current to 3, revision to 12, and age to 1. +# +# Here's the simplified rule guide on how to change -version-info: +# (current version is C:R:A) +# +# 1. if there are only source changes, use C:R+1:A +# 2. if interfaces were added use C+1:0:A+1 +# 3. if interfaces were removed, then use C+1:0:0 +# +# For the full guide on libcurl ABI rules, see docs/libcurl/ABI diff --git a/3rdparty/curl-8.21.0/lib/altsvc.c b/3rdparty/curl-8.21.0/lib/altsvc.c new file mode 100644 index 0000000000..80913d9a1d --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/altsvc.c @@ -0,0 +1,684 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +/* + * The Alt-Svc: header is defined in RFC 7838: + * https://datatracker.ietf.org/doc/html/rfc7838 + */ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_HTTP) && !defined(CURL_DISABLE_ALTSVC) +#include "urldata.h" +#include "altsvc.h" +#include "curl_fopen.h" +#include "curl_get_line.h" +#include "parsedate.h" +#include "curl_trc.h" +#include "curlx/inet_pton.h" +#include "curlx/strparse.h" +#include "connect.h" + +#define MAX_ALTSVC_LINE 4095 +#define MAX_ALTSVC_DATELEN 17 +#define MAX_ALTSVC_HOSTLEN 2048 +#define MAX_ALTSVC_ALPNLEN 10 + +#define H3VERSION "h3" + +#if defined(DEBUGBUILD) || defined(UNITTESTS) +/* to play well with debug builds, we can *set* a fixed time this will + return */ +static time_t altsvc_debugtime(void *unused) +{ + const char *timestr = getenv("CURL_TIME"); + (void)unused; + if(timestr) { + curl_off_t val; + curlx_str_number(×tr, &val, TIME_T_MAX); + return (time_t)val; + } + return time(NULL); +} +#undef time +#define time(x) altsvc_debugtime(x) +#endif + +/* Given the ALPN ID, return the name */ +const char *Curl_alpnid2str(enum alpnid id) +{ + switch(id) { + case ALPN_h1: + return "h1"; + case ALPN_h2: + return "h2"; + case ALPN_h3: + return H3VERSION; + default: + return ""; /* bad */ + } +} + +#define altsvc_free(x) curlx_free(x) + +static struct altsvc *altsvc_createid(const char *srchost, + size_t hlen, + const char *dsthost, + size_t dlen, /* dsthost length */ + enum alpnid srcalpnid, + enum alpnid dstalpnid, + size_t srcport, + size_t dstport) +{ + struct altsvc *as; + if((hlen > 2) && srchost[0] == '[') { + /* IPv6 address, strip off brackets */ + srchost++; + hlen -= 2; + } + else if(hlen && (srchost[hlen - 1] == '.')) { + /* strip off trailing dot */ + hlen--; + } + if((dlen > 2) && dsthost[0] == '[') { + /* IPv6 address, strip off brackets */ + dsthost++; + dlen -= 2; + } + if(!hlen || !dlen) + /* bad input */ + return NULL; + /* struct size plus both strings */ + as = curlx_calloc(1, sizeof(struct altsvc) + (hlen + 1) + (dlen + 1)); + if(!as) + return NULL; + as->src.host = (char *)as + sizeof(struct altsvc); + memcpy(as->src.host, srchost, hlen); + /* the null-terminator is already there */ + + as->dst.host = (char *)as + sizeof(struct altsvc) + hlen + 1; + memcpy(as->dst.host, dsthost, dlen); + /* the null-terminator is already there */ + + as->src.alpnid = srcalpnid; + as->dst.alpnid = dstalpnid; + as->src.port = (unsigned short)srcport; + as->dst.port = (unsigned short)dstport; + + return as; +} + +static struct altsvc *altsvc_create(struct Curl_str *srchost, + struct Curl_str *dsthost, + struct Curl_str *srcalpn, + struct Curl_str *dstalpn, + size_t srcport, + size_t dstport) +{ + enum alpnid dstalpnid = Curl_str2alpnid(dstalpn); + enum alpnid srcalpnid = Curl_str2alpnid(srcalpn); + if(!srcalpnid || !dstalpnid) + return NULL; + return altsvc_createid(curlx_str(srchost), curlx_strlen(srchost), + curlx_str(dsthost), curlx_strlen(dsthost), + srcalpnid, dstalpnid, + srcport, dstport); +} + +/* append the new entry to the list after possibly removing an old entry + first */ +static void altsvc_append(struct altsvcinfo *asi, struct altsvc *as) +{ + while(Curl_llist_count(&asi->list) >= MAX_ALTSVC_ENTRIES) { + /* It is full. Remove the first entry in the list */ + struct Curl_llist_node *e = Curl_llist_head(&asi->list); + struct altsvc *oldas = Curl_node_elem(e); + Curl_node_remove(e); + altsvc_free(oldas); + } + Curl_llist_append(&asi->list, as, &as->node); +} + +/* only returns SERIOUS errors */ +static CURLcode altsvc_add(struct altsvcinfo *asi, const char *line) +{ + /* Example line: + h2 example.com 443 h3 shiny.example.com 8443 "20191231 10:00:00" 1 + */ + struct Curl_str srchost; + struct Curl_str dsthost; + struct Curl_str srcalpn; + struct Curl_str dstalpn; + struct Curl_str date; + curl_off_t srcport; + curl_off_t dstport; + curl_off_t persist; + curl_off_t prio; + + if(curlx_str_word(&line, &srcalpn, MAX_ALTSVC_ALPNLEN) || + curlx_str_singlespace(&line) || + curlx_str_word(&line, &srchost, MAX_ALTSVC_HOSTLEN) || + curlx_str_singlespace(&line) || + curlx_str_number(&line, &srcport, 65535) || + curlx_str_singlespace(&line) || + curlx_str_word(&line, &dstalpn, MAX_ALTSVC_ALPNLEN) || + curlx_str_singlespace(&line) || + curlx_str_word(&line, &dsthost, MAX_ALTSVC_HOSTLEN) || + curlx_str_singlespace(&line) || + curlx_str_number(&line, &dstport, 65535) || + curlx_str_singlespace(&line) || + curlx_str_quotedword(&line, &date, MAX_ALTSVC_DATELEN) || + curlx_str_singlespace(&line) || + curlx_str_number(&line, &persist, 1) || + curlx_str_singlespace(&line) || + curlx_str_number(&line, &prio, 0) || + curlx_str_newline(&line)) + ; + else { + char dbuf[MAX_ALTSVC_DATELEN + 1]; + time_t expires = 0; + time_t now = time(NULL); + + /* The date parser works on a null-terminated string. The maximum length + is upheld by curlx_str_quotedword(). */ + memcpy(dbuf, curlx_str(&date), curlx_strlen(&date)); + dbuf[curlx_strlen(&date)] = 0; + Curl_getdate_capped(dbuf, &expires); + + if(now < expires) { + struct altsvc *as = altsvc_create(&srchost, &dsthost, &srcalpn, &dstalpn, + (size_t)srcport, (size_t)dstport); + if(as) { + as->expires = expires; + as->persist = persist ? 1 : 0; + altsvc_append(asi, as); + } + else + return CURLE_OUT_OF_MEMORY; + } + } + + return CURLE_OK; +} + +/* + * Load alt-svc entries from the given file. The text based line-oriented file + * format is documented here: https://curl.se/docs/alt-svc.html + * + * This function only returns error on major problems that prevent alt-svc + * handling to work completely. It will ignore individual syntactical errors + * etc. + */ +static CURLcode altsvc_load(struct altsvcinfo *asi, const char *file) +{ + CURLcode result = CURLE_OK; + FILE *fp; + + /* we need a private copy of the filename so that the altsvc cache file + name survives an easy handle reset */ + curlx_free(asi->filename); + asi->filename = curlx_strdup(file); + if(!asi->filename) + return CURLE_OUT_OF_MEMORY; + + fp = curlx_fopen(file, FOPEN_READTEXT); + if(fp) { + curlx_struct_stat stat; + if((curlx_fstat(fileno(fp), &stat) == -1) || !S_ISDIR(stat.st_mode)) { + bool eof = FALSE; + struct dynbuf buf; + curlx_dyn_init(&buf, MAX_ALTSVC_LINE); + do { + result = Curl_get_line(&buf, fp, &eof); + if(!result) { + const char *lineptr = curlx_dyn_ptr(&buf); + curlx_str_passblanks(&lineptr); + if(curlx_str_single(&lineptr, '#')) + altsvc_add(asi, lineptr); + } + } while(!result && !eof); + curlx_dyn_free(&buf); /* free the line buffer */ + } + curlx_fclose(fp); + } + return result; +} + +/* + * Write this single altsvc entry to a single output line + */ +static CURLcode altsvc_out(struct altsvc *as, FILE *fp) +{ + struct tm stamp; + const char *dst6_pre = ""; + const char *dst6_post = ""; + const char *src6_pre = ""; + const char *src6_post = ""; + CURLcode result = curlx_gmtime(as->expires, &stamp); + if(result) + return result; +#ifdef USE_IPV6 + else { + char ipv6_unused[16]; + if(curlx_inet_pton(AF_INET6, as->dst.host, ipv6_unused) == 1) { + dst6_pre = "["; + dst6_post = "]"; + } + if(curlx_inet_pton(AF_INET6, as->src.host, ipv6_unused) == 1) { + src6_pre = "["; + src6_post = "]"; + } + } +#endif + curl_mfprintf(fp, + "%s %s%s%s %u " + "%s %s%s%s %u " + "\"%d%02d%02d " + "%02d:%02d:%02d\" " + "%d 0\n", /* prio still always zero */ + Curl_alpnid2str(as->src.alpnid), + src6_pre, as->src.host, src6_post, + as->src.port, + + Curl_alpnid2str(as->dst.alpnid), + dst6_pre, as->dst.host, dst6_post, + as->dst.port, + + stamp.tm_year + 1900, stamp.tm_mon + 1, stamp.tm_mday, + stamp.tm_hour, stamp.tm_min, stamp.tm_sec, + as->persist); + return CURLE_OK; +} + +/* ---- library-wide functions below ---- */ + +/* + * Curl_altsvc_init() creates a new altsvc cache. + * It returns the new instance or NULL if something goes wrong. + */ +struct altsvcinfo *Curl_altsvc_init(void) +{ + struct altsvcinfo *asi = curlx_calloc(1, sizeof(struct altsvcinfo)); + if(!asi) + return NULL; + Curl_llist_init(&asi->list, NULL); + + /* set default behavior */ + asi->flags = CURLALTSVC_H1 +#ifdef USE_HTTP2 + | CURLALTSVC_H2 +#endif +#ifdef USE_HTTP3 + | CURLALTSVC_H3 +#endif + ; + return asi; +} + +/* + * Curl_altsvc_load() loads alt-svc from file. + */ +CURLcode Curl_altsvc_load(struct altsvcinfo *asi, const char *file) +{ + DEBUGASSERT(asi); + return altsvc_load(asi, file); +} + +/* + * Curl_altsvc_ctrl() passes on the external bitmask. + */ +CURLcode Curl_altsvc_ctrl(struct Curl_easy *data, const long ctrl) +{ + DEBUGASSERT(data); + if(!ctrl) + return CURLE_BAD_FUNCTION_ARGUMENT; + + if(!data->asi) { + data->asi = Curl_altsvc_init(); + if(!data->asi) + return CURLE_OUT_OF_MEMORY; + } + data->asi->flags = ctrl; + return CURLE_OK; +} + +/* + * Curl_altsvc_cleanup() frees an altsvc cache instance and all associated + * resources. + */ +void Curl_altsvc_cleanup(struct altsvcinfo **asi) +{ + if(*asi) { + struct Curl_llist_node *e; + struct Curl_llist_node *n; + struct altsvcinfo *altsvc = *asi; + for(e = Curl_llist_head(&altsvc->list); e; e = n) { + struct altsvc *as = Curl_node_elem(e); + n = Curl_node_next(e); + altsvc_free(as); + } + curlx_free(altsvc->filename); + curlx_free(altsvc); + *asi = NULL; /* clear the pointer */ + } +} + +/* + * Curl_altsvc_save() writes the altsvc cache to a file. + */ +CURLcode Curl_altsvc_save(struct Curl_easy *data, + struct altsvcinfo *asi, const char *file) +{ + CURLcode result = CURLE_OK; + FILE *out; + char *tempstore = NULL; + + if(!asi) + /* no cache activated */ + return CURLE_OK; + + /* if not new name is given, use the one we stored from the load */ + if(!file && asi->filename) + file = asi->filename; + + if((asi->flags & CURLALTSVC_READONLYFILE) || !file || !file[0]) + /* marked as read-only, no file or zero length filename */ + return CURLE_OK; + + result = Curl_fopen(data, file, &out, &tempstore); + if(!result) { + struct Curl_llist_node *e; + struct Curl_llist_node *n; + fputs("# Your alt-svc cache. https://curl.se/docs/alt-svc.html\n" + "# This file was generated by libcurl! Edit at your own risk.\n", + out); + for(e = Curl_llist_head(&asi->list); e; e = n) { + struct altsvc *as = Curl_node_elem(e); + n = Curl_node_next(e); + result = altsvc_out(as, out); + if(result) + break; + } + curlx_fclose(out); + if(!result && tempstore && curlx_rename(tempstore, file)) + result = CURLE_WRITE_ERROR; + + if(result && tempstore) + unlink(tempstore); + } + curlx_free(tempstore); + return result; +} + +/* hostcompare() returns true if 'host' matches 'check'. The first host + * argument may have a trailing dot present that will be ignored. + */ +static bool hostcompare(const char *host, const char *check) +{ + size_t hlen = strlen(host); + size_t clen = strlen(check); + + if(hlen && (host[hlen - 1] == '.')) + hlen--; + if(hlen != clen) + /* they cannot match if they have different lengths */ + return FALSE; + return curl_strnequal(host, check, hlen); +} + +/* altsvc_flush() removes all alternatives for this source origin from the + list */ +static void altsvc_flush(struct altsvcinfo *asi, enum alpnid srcalpnid, + const char *srchost, unsigned short srcport) +{ + struct Curl_llist_node *e; + struct Curl_llist_node *n; + for(e = Curl_llist_head(&asi->list); e; e = n) { + struct altsvc *as = Curl_node_elem(e); + n = Curl_node_next(e); + if((srcalpnid == as->src.alpnid) && + (srcport == as->src.port) && + hostcompare(srchost, as->src.host)) { + Curl_node_remove(e); + altsvc_free(as); + } + } +} + +/* + * Curl_altsvc_parse() takes an incoming alt-svc response header and stores + * the data correctly in the cache. + * + * 'value' points to the header *value*. That is contents to the right of the + * header name. + * + * Currently this function rejects invalid data without returning an error. + * Invalid hostname, port number will result in the specific alternative + * being rejected. Unknown protocols are skipped. + */ +CURLcode Curl_altsvc_parse(struct Curl_easy *data, + struct altsvcinfo *asi, const char *value, + enum alpnid srcalpnid, const char *srchost, + unsigned short srcport) +{ + const char *p = value; + struct altsvc *as; + unsigned short dstport = srcport; /* the same by default */ + size_t entries = 0; + struct Curl_str alpn; + + DEBUGASSERT(asi); + + /* initial check for "clear" */ + if(!curlx_str_cspn(&p, &alpn, ";\n\r")) { + curlx_str_trimblanks(&alpn); + /* "clear" is a magic keyword */ + if(curlx_str_casecompare(&alpn, "clear")) { + /* Flush cached alternatives for this source origin */ + altsvc_flush(asi, srcalpnid, srchost, srcport); + return CURLE_OK; + } + } + + p = value; + + if(curlx_str_until(&p, &alpn, MAX_ALTSVC_LINE, '=')) + return CURLE_OK; /* strange line */ + + curlx_str_trimblanks(&alpn); + + do { + if(!curlx_str_single(&p, '=')) { + time_t maxage = 24 * 3600; /* default is 24 hours */ + bool persist = FALSE; + /* [protocol]="[host][:port], [protocol]="[host][:port]" */ + enum alpnid dstalpnid = Curl_str2alpnid(&alpn); + if(!curlx_str_single(&p, '\"')) { + struct Curl_str dsthost; + curl_off_t port = 0; + if(curlx_str_single(&p, ':')) { + /* hostname starts here */ + if(curlx_str_single(&p, '[')) { + if(curlx_str_until(&p, &dsthost, MAX_ALTSVC_HOSTLEN, ':')) { + infof(data, "Bad alt-svc hostname, ignoring."); + break; + } + } + else { + /* IPv6 hostname */ + if(curlx_str_until(&p, &dsthost, MAX_IPADR_LEN, ']') || + curlx_str_single(&p, ']')) { + infof(data, "Bad alt-svc IPv6 hostname, ignoring."); + break; + } + } + if(curlx_str_single(&p, ':')) + break; + } + else + /* no destination name, use source host */ + curlx_str_assign(&dsthost, srchost, strlen(srchost)); + + if(curlx_str_number(&p, &port, 0xffff)) { + infof(data, "Unknown alt-svc port number, ignoring."); + break; + } + + dstport = (unsigned short)port; + + if(curlx_str_single(&p, '\"')) + break; + + /* Handle the optional 'ma' and 'persist' flags. Unknown flags are + skipped. */ + curlx_str_passblanks(&p); + if(!curlx_str_single(&p, ';')) { + for(;;) { + struct Curl_str name; + struct Curl_str val; + const char *vp; + curl_off_t num; + bool quoted; + /* allow some extra whitespaces around name and value */ + if(curlx_str_until(&p, &name, 20, '=') || + curlx_str_single(&p, '=') || + curlx_str_cspn(&p, &val, ",;")) + break; + curlx_str_trimblanks(&name); + curlx_str_trimblanks(&val); + /* the value might be quoted */ + vp = curlx_str(&val); + quoted = (*vp == '\"'); + if(quoted) + vp++; + if(!curlx_str_number(&vp, &num, TIME_T_MAX)) { + if(curlx_str_casecompare(&name, "ma")) + maxage = (time_t)num; + else if(curlx_str_casecompare(&name, "persist") && (num == 1)) + persist = TRUE; + } + else + break; + p = vp; /* point to the byte ending the value */ + curlx_str_passblanks(&p); + if(quoted && curlx_str_single(&p, '\"')) + break; + curlx_str_passblanks(&p); + if(curlx_str_single(&p, ';')) + break; + } + } + if(dstalpnid) { + if(!entries++) + /* Flush cached alternatives for this source origin, if any - when + this is the first entry of the line. */ + altsvc_flush(asi, srcalpnid, srchost, srcport); + + as = altsvc_createid(srchost, strlen(srchost), + curlx_str(&dsthost), + curlx_strlen(&dsthost), + srcalpnid, dstalpnid, + srcport, dstport); + if(as) { + time_t secs = time(NULL); + /* The expires time also needs to take the Age: value (if any) + into account. [See RFC 7838 section 3.1] */ + if(maxage > (TIME_T_MAX - secs)) + as->expires = TIME_T_MAX; + else + as->expires = maxage + secs; + as->persist = persist; + altsvc_append(asi, as); + infof(data, "Added alt-svc: %.*s:%d over %s", + (int)curlx_strlen(&dsthost), curlx_str(&dsthost), + dstport, Curl_alpnid2str(dstalpnid)); + } + else + return CURLE_OUT_OF_MEMORY; + } + } + else + break; + + /* after the double quote there can be a comma if there is another + string or a semicolon if no more */ + if(curlx_str_single(&p, ',')) + break; + + /* comma means another alternative is present */ + if(curlx_str_until(&p, &alpn, MAX_ALTSVC_LINE, '=')) + break; + curlx_str_trimblanks(&alpn); + } + else + break; + } while(1); + + return CURLE_OK; +} + +/* + * Return TRUE on a match + */ +bool Curl_altsvc_lookup(struct altsvcinfo *asi, + enum alpnid srcalpnid, const char *srchost, + int srcport, + struct altsvc **dstentry, + const int versions, /* one or more bits */ + bool *psame_destination) +{ + struct Curl_llist_node *e; + struct Curl_llist_node *n; + time_t now = time(NULL); + DEBUGASSERT(asi); + DEBUGASSERT(srchost); + DEBUGASSERT(dstentry); + + *psame_destination = FALSE; + for(e = Curl_llist_head(&asi->list); e; e = n) { + struct altsvc *as = Curl_node_elem(e); + n = Curl_node_next(e); + if(as->expires < now) { + /* an expired entry, remove */ + Curl_node_remove(e); + altsvc_free(as); + continue; + } + if((as->src.alpnid == srcalpnid) && + hostcompare(srchost, as->src.host) && + (as->src.port == srcport) && + (versions & (int)as->dst.alpnid)) { + /* match */ + *dstentry = as; + *psame_destination = (srcport == as->dst.port) && + hostcompare(srchost, as->dst.host); + return TRUE; + } + } + return FALSE; +} + +#if defined(DEBUGBUILD) || defined(UNITTESTS) +#undef time +#endif + +#endif /* !CURL_DISABLE_HTTP && !CURL_DISABLE_ALTSVC */ diff --git a/3rdparty/curl-8.21.0/lib/altsvc.h b/3rdparty/curl-8.21.0/lib/altsvc.h new file mode 100644 index 0000000000..dc1740bce1 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/altsvc.h @@ -0,0 +1,76 @@ +#ifndef HEADER_CURL_ALTSVC_H +#define HEADER_CURL_ALTSVC_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_HTTP) && !defined(CURL_DISABLE_ALTSVC) +#include "llist.h" + +/* the maximum number of alt-svc entries kept in a single cache */ +#define MAX_ALTSVC_ENTRIES 5000 + +struct althost { + char *host; + uint16_t port; + enum alpnid alpnid; +}; + +struct altsvc { + struct althost src; + struct althost dst; + time_t expires; + struct Curl_llist_node node; + BIT(persist); +}; + +struct altsvcinfo { + char *filename; + struct Curl_llist list; /* list of entries */ + long flags; /* the publicly set bitmask */ +}; + +const char *Curl_alpnid2str(enum alpnid id); +struct altsvcinfo *Curl_altsvc_init(void); +CURLcode Curl_altsvc_load(struct altsvcinfo *asi, const char *file); +CURLcode Curl_altsvc_save(struct Curl_easy *data, + struct altsvcinfo *asi, const char *file); +CURLcode Curl_altsvc_ctrl(struct Curl_easy *data, const long ctrl); +void Curl_altsvc_cleanup(struct altsvcinfo **asi); +CURLcode Curl_altsvc_parse(struct Curl_easy *data, + struct altsvcinfo *asi, const char *value, + enum alpnid srcalpnid, const char *srchost, + unsigned short srcport); +bool Curl_altsvc_lookup(struct altsvcinfo *asi, + enum alpnid srcalpnid, const char *srchost, + int srcport, + struct altsvc **dstentry, + const int versions, /* CURLALTSVC_H* bits */ + bool *psame_destination); +#else +/* disabled */ +#define Curl_altsvc_save(a, b, c) +#define Curl_altsvc_cleanup(x) +#endif /* !CURL_DISABLE_HTTP && !CURL_DISABLE_ALTSVC */ +#endif /* HEADER_CURL_ALTSVC_H */ diff --git a/3rdparty/curl-8.21.0/lib/amigaos.c b/3rdparty/curl-8.21.0/lib/amigaos.c new file mode 100644 index 0000000000..e4f3bfb77c --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/amigaos.c @@ -0,0 +1,239 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef __AMIGA__ + +#include "hostip.h" +#include "curl_addrinfo.h" +#include "amigaos.h" + +#ifdef HAVE_PROTO_BSDSOCKET_H +# ifdef __amigaos4__ +# include +# elif !defined(USE_AMISSL) +# include +# endif +# ifdef __libnix__ +# include +# endif +#endif + +#ifdef HAVE_PROTO_BSDSOCKET_H + +#ifdef __amigaos4__ +/* + * AmigaOS 4.x specific code + */ + +/* + * hostip4.c - Curl_ipv4_resolve_r() replacement code + * + * Logic that needs to be considered are the following build cases: + * - newlib networking + * - clib2 networking + * - direct bsdsocket.library networking (usually AmiSSL builds) + * Each with the threaded resolver enabled or not. + * + * With the threaded resolver enabled, try to use gethostbyname_r() where + * available, otherwise (re)open bsdsocket.library and fallback to + * gethostbyname(). + */ + +#include + +static struct SocketIFace *__CurlISocket = NULL; +static uint32 SocketFeatures = 0; + +#define HAVE_BSDSOCKET_GETHOSTBYNAME_R 0x01 +#define HAVE_BSDSOCKET_GETADDRINFO 0x02 + +CURLcode Curl_amiga_init(void) +{ + struct SocketIFace *ISocket; + struct Library *base = OpenLibrary("bsdsocket.library", 4); + + if(base) { + ISocket = (struct SocketIFace *)GetInterface(base, "main", 1, NULL); + if(ISocket) { + ULONG enabled = 0; + + SocketBaseTags(SBTM_SETVAL(SBTC_CAN_SHARE_LIBRARY_BASES), TRUE, + SBTM_GETREF(SBTC_HAVE_GETHOSTADDR_R_API), (ULONG)&enabled, + TAG_DONE); + + if(enabled) { + SocketFeatures |= HAVE_BSDSOCKET_GETHOSTBYNAME_R; + } + + __CurlISocket = ISocket; + + atexit(Curl_amiga_cleanup); + + return CURLE_OK; + } + CloseLibrary(base); + } + + return CURLE_FAILED_INIT; +} + +void Curl_amiga_cleanup(void) +{ + if(__CurlISocket) { + struct Library *base = __CurlISocket->Data.LibBase; + DropInterface((struct Interface *)__CurlISocket); + CloseLibrary(base); + __CurlISocket = NULL; + } +} + +#ifdef CURLRES_AMIGA +/* + * Because we need to handle the different cases in hostip4.c at runtime, + * not at compile-time, based on what was detected in Curl_amiga_init(), + * we replace it completely with our own as to not complicate the baseline + * code. Assumes malloc/calloc/free are thread-safe because Curl_he2ai() + * allocates memory also. + */ + +struct Curl_addrinfo *Curl_ipv4_resolve_r(const char *hostname, uint16_t port) +{ + struct Curl_addrinfo *ai = NULL; + struct hostent *h; + struct SocketIFace *ISocket = __CurlISocket; + + if(SocketFeatures & HAVE_BSDSOCKET_GETHOSTBYNAME_R) { + LONG h_errnop = 0; + struct hostent *buf; + + buf = curlx_calloc(1, CURL_HOSTENT_SIZE); + if(buf) { + h = gethostbyname_r((STRPTR)hostname, buf, + (char *)buf + sizeof(struct hostent), + CURL_HOSTENT_SIZE - sizeof(struct hostent), + &h_errnop); + if(h) { + ai = Curl_he2ai(h, port); + } + curlx_free(buf); + } + } + else { +#ifdef USE_RESOLV_THREADED + /* gethostbyname() is not thread-safe, so we need to reopen bsdsocket + * on the thread's context + */ + struct Library *base = OpenLibrary("bsdsocket.library", 4); + if(base) { + ISocket = (struct SocketIFace *)GetInterface(base, "main", 1, NULL); + if(ISocket) { + h = gethostbyname((STRPTR)hostname); + if(h) { + ai = Curl_he2ai(h, port); + } + DropInterface((struct Interface *)ISocket); + } + CloseLibrary(base); + } +#else + /* not using threaded resolver - safe to use this as-is */ + h = gethostbyname(hostname); + if(h) { + ai = Curl_he2ai(h, port); + } +#endif + } + + return ai; +} +#endif /* CURLRES_AMIGA */ + +#ifdef USE_AMISSL +#include +int Curl_amiga_select(int nfds, fd_set *readfds, fd_set *writefds, + fd_set *errorfds, struct timeval *timeout) +{ + int r = WaitSelect(nfds, readfds, writefds, errorfds, timeout, 0); + /* Ensure Ctrl-C signal is actioned */ + if((r == -1) && (SOCKERRNO == SOCKEINTR)) + raise(SIGINT); + return r; +} +#endif /* USE_AMISSL */ + +#elif !defined(USE_AMISSL) /* __amigaos4__ */ +/* + * Amiga OS3 specific code + */ + +struct Library *SocketBase = NULL; + +#ifdef __libnix__ +void __request(const char *msg); +#define CURL_AMIGA_REQUEST(msg) __request(msg) +#else +#define CURL_AMIGA_REQUEST(msg) Printf((const unsigned char *)(msg "\n\a"), 0) +#endif + +void Curl_amiga_cleanup(void) +{ + if(SocketBase) { + CloseLibrary(SocketBase); + SocketBase = NULL; + } +} + +CURLcode Curl_amiga_init(void) +{ + if(!SocketBase) + SocketBase = OpenLibrary((const unsigned char *)"bsdsocket.library", 4); + + if(!SocketBase) { + CURL_AMIGA_REQUEST("No TCP/IP Stack running!"); + return CURLE_FAILED_INIT; + } + + if(SocketBaseTags(SBTM_SETVAL(SBTC_ERRNOPTR(sizeof(errno))), (ULONG)&errno, + SBTM_SETVAL(SBTC_LOGTAGPTR), (ULONG)"curl", TAG_DONE)) { + CURL_AMIGA_REQUEST("SocketBaseTags ERROR"); + return CURLE_FAILED_INIT; + } + +#ifndef __libnix__ + atexit(Curl_amiga_cleanup); +#endif + + return CURLE_OK; +} + +#ifdef __libnix__ +ADD2EXIT(Curl_amiga_cleanup, -50); +#endif + +#endif /* !USE_AMISSL */ + +#endif /* HAVE_PROTO_BSDSOCKET_H */ + +#endif /* __AMIGA__ */ diff --git a/3rdparty/curl-8.21.0/lib/amigaos.h b/3rdparty/curl-8.21.0/lib/amigaos.h new file mode 100644 index 0000000000..58278f0935 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/amigaos.h @@ -0,0 +1,41 @@ +#ifndef HEADER_CURL_AMIGAOS_H +#define HEADER_CURL_AMIGAOS_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if defined(__AMIGA__) && defined(HAVE_PROTO_BSDSOCKET_H) && \ + (!defined(USE_AMISSL) || defined(__amigaos4__)) + +CURLcode Curl_amiga_init(void); +void Curl_amiga_cleanup(void); + +#else + +#define Curl_amiga_init() CURLE_OK +#define Curl_amiga_cleanup() Curl_nop_stmt + +#endif + +#endif /* HEADER_CURL_AMIGAOS_H */ diff --git a/3rdparty/curl-8.21.0/lib/arpa_telnet.h b/3rdparty/curl-8.21.0/lib/arpa_telnet.h new file mode 100644 index 0000000000..826f937537 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/arpa_telnet.h @@ -0,0 +1,116 @@ +#ifndef HEADER_CURL_ARPA_TELNET_H +#define HEADER_CURL_ARPA_TELNET_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#ifndef CURL_DISABLE_TELNET +/* + * Telnet option defines. Add more here if in need. + */ +#define CURL_TELOPT_BINARY 0 /* binary 8-bit data */ +#define CURL_TELOPT_ECHO 1 /* echo */ +#define CURL_TELOPT_SGA 3 /* Suppress Go Ahead */ +#define CURL_TELOPT_EXOPL 255 /* EXtended OPtions List */ +#define CURL_TELOPT_TTYPE 24 /* Terminal TYPE */ +#define CURL_TELOPT_NAWS 31 /* Negotiate About Window Size */ +#define CURL_TELOPT_XDISPLOC 35 /* X DISPlay LOCation */ +#define CURL_TELOPT_NEW_ENVIRON 39 /* NEW ENVIRONment variables */ + +#define CURL_NEW_ENV_VAR 0 +#define CURL_NEW_ENV_VALUE 1 + +#ifdef CURLVERBOSE +/* + * The telnet options represented as strings + */ +static const char * const telnetoptions[] = { + "BINARY", "ECHO", "RCP", "SUPPRESS GO AHEAD", + "NAME", "STATUS", "TIMING MARK", "RCTE", + "NAOL", "NAOP", "NAOCRD", "NAOHTS", + "NAOHTD", "NAOFFD", "NAOVTS", "NAOVTD", + "NAOLFD", "EXTEND ASCII", "LOGOUT", "BYTE MACRO", + "DE TERMINAL", "SUPDUP", "SUPDUP OUTPUT", "SEND LOCATION", + "TERM TYPE", "END OF RECORD", "TACACS UID", "OUTPUT MARKING", + "TTYLOC", "3270 REGIME", "X3 PAD", "NAWS", + "TERM SPEED", "LFLOW", "LINEMODE", "XDISPLOC", + "OLD-ENVIRON", "AUTHENTICATION", "ENCRYPT", "NEW-ENVIRON" +}; +#define CURL_TELOPT(x) telnetoptions[x] +#else +#define CURL_TELOPT(x) "" +#endif + +#define CURL_TELOPT_MAXIMUM CURL_TELOPT_NEW_ENVIRON + +#define CURL_TELOPT_OK(x) ((x) <= CURL_TELOPT_MAXIMUM) + +#define CURL_NTELOPTS 40 + +/* + * First some defines + */ +#define CURL_xEOF 236 /* End Of File */ +#define CURL_SE 240 /* Sub negotiation End */ +#define CURL_NOP 241 /* No OPeration */ +#define CURL_DM 242 /* Data Mark */ +#define CURL_GA 249 /* Go Ahead, reverse the line */ +#define CURL_SB 250 /* SuBnegotiation */ +#define CURL_WILL 251 /* Our side WILL use this option */ +#define CURL_WONT 252 /* Our side will not use this option */ +#define CURL_DO 253 /* DO use this option! */ +#define CURL_DONT 254 /* DO NOT use this option! */ +#define CURL_IAC 255 /* Interpret As Command */ + +#ifdef CURLVERBOSE +/* + * Then those numbers represented as strings: + */ +static const char * const telnetcmds[] = { + "EOF", "SUSP", "ABORT", "EOR", "SE", + "NOP", "DMARK", "BRK", "IP", "AO", + "AYT", "EC", "EL", "GA", "SB", + "WILL", "WONT", "DO", "DONT", "IAC" +}; +#endif + +#define CURL_TELCMD_MINIMUM CURL_xEOF /* the first one */ +#define CURL_TELCMD_MAXIMUM CURL_IAC /* surprise, 255 is the last one! ;-) */ + +#define CURL_TELQUAL_IS 0 +#define CURL_TELQUAL_SEND 1 +#define CURL_TELQUAL_INFO 2 +#define CURL_TELQUAL_NAME 3 + +#define CURL_TELCMD_OK(x) \ + (((unsigned int)(x) >= CURL_TELCMD_MINIMUM) && \ + ((unsigned int)(x) <= CURL_TELCMD_MAXIMUM)) + +#ifdef CURLVERBOSE +#define CURL_TELCMD(x) telnetcmds[(x) - CURL_TELCMD_MINIMUM] +#else +#define CURL_TELCMD(x) "" +#endif + +#endif /* CURL_DISABLE_TELNET */ + +#endif /* HEADER_CURL_ARPA_TELNET_H */ diff --git a/3rdparty/curl-8.21.0/lib/asyn-ares.c b/3rdparty/curl-8.21.0/lib/asyn-ares.c new file mode 100644 index 0000000000..d17a6038e2 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/asyn-ares.c @@ -0,0 +1,828 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_RESOLV_ARES + +/*********************************************************************** + * Only for ares-enabled builds and only for functions that fulfill + * the asynch resolver backend API as defined in asyn.h, + * nothing else belongs in this file! + **********************************************************************/ + +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETDB_H +#include +#endif +#ifdef HAVE_ARPA_INET_H +#include +#endif +#ifdef __VMS +#include +#include +#endif + +#include "urldata.h" +#include "cfilters.h" +#include "curl_addrinfo.h" +#include "curl_trc.h" +#include "hostip.h" +#include "url.h" +#include "multiif.h" +#include "curlx/inet_pton.h" +#include "connect.h" +#include "select.h" +#include "progress.h" +#include "curlx/timediff.h" +#include "httpsrr.h" +#include + +#if ARES_VERSION < 0x011000 +#error "requires c-ares 1.16.0 or newer" +#endif + +#ifdef USE_HTTPSRR +#if ARES_VERSION < 0x011c00 +#error "requires c-ares 1.28.0 or newer for HTTPSRR" +#endif +#define HTTPSRR_WORKS +#endif + +#define CARES_TIMEOUT_PER_ATTEMPT 2000 + +static int ares_ver = 0; + +static CURLcode async_ares_set_dns_servers(struct Curl_easy *data, + struct Curl_resolv_async *async); +static CURLcode async_ares_set_dns_interface(struct Curl_easy *data, + struct Curl_resolv_async *async); +static CURLcode async_ares_set_dns_local_ip4(struct Curl_easy *data, + struct Curl_resolv_async *async); +static CURLcode async_ares_set_dns_local_ip6(struct Curl_easy *data, + struct Curl_resolv_async *async); + +/* + * Curl_async_global_init() - the generic low-level asynchronous name + * resolve API. Called from curl_global_init() to initialize global resolver + * environment. Initializes ares library. + */ +int Curl_async_global_init(void) +{ +#ifdef CARES_HAVE_ARES_LIBRARY_INIT + if(ares_library_init(ARES_LIB_INIT_ALL)) { + return CURLE_FAILED_INIT; + } +#endif + ares_version(&ares_ver); + return CURLE_OK; +} + +/* + * Curl_async_global_cleanup() + * + * Called from curl_global_cleanup() to destroy global resolver environment. + * Deinitializes ares library. + */ +void Curl_async_global_cleanup(void) +{ +#ifdef CARES_HAVE_ARES_LIBRARY_CLEANUP + ares_library_cleanup(); +#endif +} + +static void sock_state_cb(void *data, ares_socket_t socket_fd, + int readable, int writable) +{ + struct Curl_easy *easy = data; + if(!readable && !writable) { + DEBUGASSERT(easy); + Curl_multi_will_close(easy, socket_fd); + } +} + +static CURLcode async_ares_init(struct Curl_easy *data, + struct Curl_resolv_async *async) +{ + struct async_ares_ctx *ares = &async->ares; + int status; + struct ares_options options; + int optmask = ARES_OPT_SOCK_STATE_CB; + CURLcode result = CURLE_OK; + + /* initial status - failed */ + ares->ares_status = ARES_ENOTFOUND; + async->queries_ongoing = 0; + + options.sock_state_cb = sock_state_cb; + options.sock_state_cb_data = data; + + DEBUGASSERT(!ares->channel); + /* + if c ares < 1.20.0: curl set timeout to CARES_TIMEOUT_PER_ATTEMPT (2s) + + if c-ares >= 1.20.0 it already has the timeout to 2s, curl does not need + to set the timeout value; + + if c-ares >= 1.24.0, user can set the timeout via /etc/resolv.conf to + overwrite c-ares' timeout. + */ + DEBUGASSERT(ares_ver); + if(ares_ver < 0x011400) { + options.timeout = CARES_TIMEOUT_PER_ATTEMPT; + optmask |= ARES_OPT_TIMEOUTMS; + } + + status = ares_init_options(&ares->channel, &options, optmask); + if(status != ARES_SUCCESS) { + ares->channel = NULL; + result = (status == ARES_ENOMEM) ? CURLE_OUT_OF_MEMORY : CURLE_FAILED_INIT; + goto out; + } + + result = async_ares_set_dns_servers(data, async); + if(result && result != CURLE_NOT_BUILT_IN) + goto out; + + result = async_ares_set_dns_interface(data, async); + if(result && result != CURLE_NOT_BUILT_IN) + goto out; + + result = async_ares_set_dns_local_ip4(data, async); + if(result && result != CURLE_NOT_BUILT_IN) + goto out; + + result = async_ares_set_dns_local_ip6(data, async); + if(result && result != CURLE_NOT_BUILT_IN) + goto out; + + result = CURLE_OK; + +out: + if(result && ares->channel) { + ares_destroy(ares->channel); + ares->channel = NULL; + } + return result; +} + +/* + * async_ares_cleanup() cleans up async resolver data. + */ +static void async_ares_cleanup(struct Curl_resolv_async *async) +{ + struct async_ares_ctx *ares = &async->ares; + if(ares->res_A) { + Curl_freeaddrinfo(ares->res_A); + ares->res_A = NULL; + } + if(ares->res_AAAA) { + Curl_freeaddrinfo(ares->res_AAAA); + ares->res_AAAA = NULL; + } +#ifdef USE_HTTPSRR + Curl_httpsrr_cleanup(&ares->hinfo); +#endif +} + +void Curl_async_ares_shutdown(struct Curl_easy *data, + struct Curl_resolv_async *async) +{ + /* c-ares has a method to "cancel" operations on a channel, but + * as reported in #18216, this does not totally reset the channel + * and ares may get stuck. + * We need to destroy the channel and on demand create a new + * one to avoid that. */ + Curl_async_ares_destroy(data, async); +} + +void Curl_async_ares_destroy(struct Curl_easy *data, + struct Curl_resolv_async *async) +{ + struct async_ares_ctx *ares = &async->ares; + (void)data; + if(ares->channel) { + ares_destroy(ares->channel); + ares->channel = NULL; + } + async_ares_cleanup(async); +} + +CURLcode Curl_async_pollset(struct Curl_easy *data, + struct Curl_resolv_async *async, + struct easy_pollset *ps) +{ + struct async_ares_ctx *ares = &async->ares; + CURLcode result = CURLE_OK; + + if(ares->channel) { + result = Curl_ares_pollset(data, ares->channel, ps); + if(!result) { + timediff_t ms = Curl_ares_timeout_ms(data, async, ares->channel); + Curl_expire(data, ms, EXPIRE_ASYNC_NAME); + } + } + return result; +} + +/* + * Curl_async_take_result() is called repeatedly to check if a previous + * name resolve request has completed. It should also make sure to time-out if + * the operation seems to take too long. + * + * Returns normal CURLcode errors. + */ +CURLcode Curl_async_take_result(struct Curl_easy *data, + struct Curl_resolv_async *async, + struct Curl_dns_entry **pdns) +{ + struct async_ares_ctx *ares = &async->ares; + CURLcode result = CURLE_OK; + + DEBUGASSERT(pdns); + *pdns = NULL; + if(!ares) + return CURLE_FAILED_INIT; + + if(Curl_ares_perform(ares->channel, 0) < 0) { + result = CURLE_UNRECOVERABLE_POLL; + goto out; + } + + if(async->queries_ongoing) { + result = CURLE_AGAIN; + goto out; + } + + /* all c-ares operations done, what is the result to report? */ + result = ares->result; + if(ares->ares_status == ARES_SUCCESS && !result) { + struct Curl_dns_entry *dns = + Curl_dnscache_mk_entry2(data, async->dns_queries, + &ares->res_AAAA, &ares->res_A, + async->hostname, async->port); + if(!dns) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } +#ifdef HTTPSRR_WORKS + if(async->dns_queries & CURL_DNSQ_HTTPS) { + if(ares->hinfo.complete) { + struct Curl_https_rrinfo *lhrr = Curl_httpsrr_dup_move(&ares->hinfo); + if(!lhrr) + result = CURLE_OUT_OF_MEMORY; + else + Curl_dns_entry_set_https_rr(dns, lhrr); + } + else + Curl_dns_entry_set_https_rr(dns, NULL); + } +#endif + if(!result) { + *pdns = dns; + } + } + /* if we have not found anything, report the proper + * CURLE_COULDNT_RESOLVE_* code */ + if(!result && !*pdns) { + const char *msg = NULL; + if(ares->ares_status != ARES_SUCCESS) + msg = ares_strerror(ares->ares_status); + result = Curl_async_failed(data, async, msg); + } + + CURL_TRC_DNS(data, "ares: is_resolved() result=%d, dns=%sfound", + (int)result, *pdns ? "" : "not "); + async_ares_cleanup(async); + +out: + if(result != CURLE_AGAIN) + ares->result = result; + return result; +} + +static timediff_t async_ares_poll_timeout(struct async_ares_ctx *ares, + timediff_t timeout_ms) +{ + struct timeval *ares_calced, time_buf, max_timeout; + int itimeout_ms; + +#if TIMEDIFF_T_MAX > INT_MAX + itimeout_ms = (timeout_ms > INT_MAX) ? INT_MAX : + ((timeout_ms < 0) ? -1 : (int)timeout_ms); +#else + itimeout_ms = (int)timeout_ms; +#endif + max_timeout.tv_sec = itimeout_ms / 1000; + max_timeout.tv_usec = (itimeout_ms % 1000) * 1000; + + /* c-ares tells us the shortest timeout of any operation on channel */ + ares_calced = ares_timeout(ares->channel, &max_timeout, &time_buf); + /* use the timeout period ares returned to us above if less than one + second is left, otherwise use 1000ms to make sure the progress callback + gets called frequent enough */ + if(!ares_calced->tv_sec) + return (timediff_t)(ares_calced->tv_usec / 1000); + else + return 1000; +} + +static const struct Curl_addrinfo *async_ares_get_ai( + const struct Curl_addrinfo *ai, + int ai_family, + unsigned int index) +{ + unsigned int i = 0; + for(i = 0; ai; ai = ai->ai_next) { + if(ai->ai_family == ai_family) { + if(i == index) + return ai; + ++i; + } + } + return NULL; +} + +const struct Curl_addrinfo *Curl_async_get_ai(struct Curl_easy *data, + struct Curl_resolv_async *async, + int ai_family, + unsigned int index) +{ + struct async_ares_ctx *ares = &async->ares; + + (void)data; + switch(ai_family) { + case AF_INET: + if(ares->res_A) + return async_ares_get_ai(ares->res_A, ai_family, index); + break; + case AF_INET6: + if(ares->res_AAAA) + return async_ares_get_ai(ares->res_AAAA, ai_family, index); + break; + default: + break; + } + return NULL; +} + +#ifdef USE_HTTPSRR +const struct Curl_https_rrinfo *Curl_async_get_https( + struct Curl_easy *data, + struct Curl_resolv_async *async) +{ + if(Curl_async_knows_https(data, async)) + return &async->ares.hinfo; + return NULL; +} + +bool Curl_async_knows_https(struct Curl_easy *data, + struct Curl_resolv_async *async) +{ + (void)data; + if(async->dns_queries & CURL_DNSQ_HTTPS) + return ((async->dns_responses & CURL_DNSQ_HTTPS) || + !async->queries_ongoing); + return TRUE; /* we know it will never come */ +} + +#endif /* USE_HTTPSRR */ + +/* + * Curl_async_await() + * + * Waits for a resolve to finish. This function should be avoided since using + * this risk getting the multi interface to "hang". + * + * 'pdns' MUST be non-NULL. + * + * Returns CURLE_COULDNT_RESOLVE_HOST if the host was not resolved, + * CURLE_OPERATION_TIMEDOUT if a time-out occurred, or other errors. + */ +CURLcode Curl_async_await(struct Curl_easy *data, uint32_t resolv_id, + struct Curl_dns_entry **pdns) +{ + struct Curl_resolv_async *async = Curl_async_get(data, resolv_id); + struct async_ares_ctx *ares = async ? &async->ares : NULL; + struct curltime start = *Curl_pgrs_now(data); + CURLcode result = CURLE_OK; + + DEBUGASSERT(pdns); + *pdns = NULL; /* clear on entry */ + + if(!ares) + return CURLE_FAILED_INIT; + + /* Wait for the name resolve query to complete or time out. */ + while(!result) { + timediff_t timeout_ms; + + timeout_ms = Curl_timeleft_ms(data); + if(!timeout_ms) { /* no applicable timeout from `data`*/ + timediff_t elapsed_ms = curlx_ptimediff_ms(Curl_pgrs_now(data), &start); + if(elapsed_ms < CURL_TIMEOUT_RESOLVE_MS) + timeout_ms = CURL_TIMEOUT_RESOLVE_MS - elapsed_ms; + else + timeout_ms = -1; + } + + if(timeout_ms < 0) { + result = CURLE_OPERATION_TIMEDOUT; + break; + } + + if(Curl_ares_perform(ares->channel, + async_ares_poll_timeout(ares, timeout_ms)) < 0) { + result = CURLE_UNRECOVERABLE_POLL; + break; + } + + result = Curl_async_take_result(data, async, pdns); + if(result == CURLE_AGAIN) + result = CURLE_OK; + else if(result || *pdns) + break; + + if(Curl_pgrsUpdate(data)) { + result = CURLE_ABORTED_BY_CALLBACK; + break; + } + } + + if(result) + ares_cancel(ares->channel); + return result; +} + +/* + * async_ares_node2addr() converts an address list provided by c-ares + * to an internal libcurl compatible list. + */ +static struct Curl_addrinfo *async_ares_node2addr( + struct ares_addrinfo_node *node) +{ + /* traverse the ares_addrinfo_node list */ + struct ares_addrinfo_node *ai; + struct Curl_addrinfo *cafirst = NULL; + struct Curl_addrinfo *calast = NULL; + int error = 0; + + for(ai = node; ai; ai = ai->ai_next) { + size_t ss_size; + struct Curl_addrinfo *ca; + /* ignore elements with unsupported address family, + settle family-specific sockaddr structure size. */ + if(ai->ai_family == AF_INET) + ss_size = sizeof(struct sockaddr_in); +#ifdef USE_IPV6 + else if(ai->ai_family == AF_INET6) + ss_size = sizeof(struct sockaddr_in6); +#endif + else + continue; + + /* ignore elements without required address info */ + if(!ai->ai_addr || !(ai->ai_addrlen > 0)) + continue; + + /* ignore elements with bogus address size */ + if((size_t)ai->ai_addrlen < ss_size) + continue; + + ca = curlx_malloc(sizeof(struct Curl_addrinfo) + ss_size); + if(!ca) { + error = EAI_MEMORY; + break; + } + + /* copy each structure member individually, member ordering, + size, or padding might be different for each platform. */ + + ca->ai_flags = ai->ai_flags; + ca->ai_family = ai->ai_family; + ca->ai_socktype = ai->ai_socktype; + ca->ai_protocol = ai->ai_protocol; + ca->ai_addrlen = (curl_socklen_t)ss_size; + ca->ai_addr = NULL; + ca->ai_canonname = NULL; + ca->ai_next = NULL; + + ca->ai_addr = (void *)((char *)ca + sizeof(struct Curl_addrinfo)); + memcpy(ca->ai_addr, ai->ai_addr, ss_size); + + /* if the return list is empty, this becomes the first element */ + if(!cafirst) + cafirst = ca; + + /* add this element last in the return list */ + if(calast) + calast->ai_next = ca; + calast = ca; + } + + /* if we failed, destroy the Curl_addrinfo list */ + if(error) { + Curl_freeaddrinfo(cafirst); + cafirst = NULL; + } + + return cafirst; +} + +static void async_ares_A_cb(void *user_data, int status, int timeouts, + struct ares_addrinfo *ares_ai) +{ + struct Curl_resolv_async *async = user_data; + struct async_ares_ctx *ares = async ? &async->ares : NULL; + + (void)timeouts; + if(!async) + return; + + async->dns_responses |= CURL_DNSQ_A; + async->queries_ongoing--; + async->done = !async->queries_ongoing; + if(status == ARES_SUCCESS) { + ares->ares_status = ARES_SUCCESS; + ares->res_A = async_ares_node2addr(ares_ai->nodes); + ares_freeaddrinfo(ares_ai); + } + else if(ares->ares_status != ARES_SUCCESS) /* do not overwrite success */ + ares->ares_status = status; +} + +#ifdef CURLRES_IPV6 +static void async_ares_AAAA_cb(void *user_data, int status, int timeouts, + struct ares_addrinfo *ares_ai) +{ + struct Curl_resolv_async *async = user_data; + struct async_ares_ctx *ares = async ? &async->ares : NULL; + + (void)timeouts; + if(!async) + return; + + async->dns_responses |= CURL_DNSQ_AAAA; + async->queries_ongoing--; + async->done = !async->queries_ongoing; + if(status == ARES_SUCCESS) { + ares->ares_status = ARES_SUCCESS; + ares->res_AAAA = async_ares_node2addr(ares_ai->nodes); + ares_freeaddrinfo(ares_ai); + } + else if(ares->ares_status != ARES_SUCCESS) /* do not overwrite success */ + ares->ares_status = status; +} +#endif /* CURLRES_IPV6 */ + +#ifdef USE_HTTPSRR +static void async_ares_rr_done(void *user_data, ares_status_t status, + size_t timeouts, + const ares_dns_record_t *dnsrec) +{ + struct Curl_resolv_async *async = user_data; + struct async_ares_ctx *ares = async ? &async->ares : NULL; + + if(!async) + return; + + (void)timeouts; + async->dns_responses |= CURL_DNSQ_HTTPS; + async->queries_ongoing--; + async->done = !async->queries_ongoing; + if((ARES_SUCCESS != status) || !dnsrec) + return; + ares->result = Curl_httpsrr_from_ares(dnsrec, &ares->hinfo); +} +#endif /* USE_HTTPSRR */ + +/* + * Curl_async_getaddrinfo() - when using ares + * + * Starts a name resolve for the given hostname and port number. + */ +CURLcode Curl_async_getaddrinfo(struct Curl_easy *data, + struct Curl_resolv_async *async) +{ + struct async_ares_ctx *ares = &async->ares; + char service[12]; + int socktype; + CURLcode result = CURLE_OK; + + if(ares->channel) { + DEBUGASSERT(0); + result = CURLE_FAILED_INIT; + goto out; + } + + result = async_ares_init(data, async); + if(result) + goto out; + + result = Curl_resolv_announce_start(data, ares->channel); + if(result) + goto out; + +#if defined(CURLVERBOSE) && ARES_VERSION >= 0x011800 /* >= v1.24.0 */ + if(CURL_TRC_DNS_is_verbose(data)) { + char *csv = ares_get_servers_csv(ares->channel); + CURL_TRC_DNS(data, "ares: servers=%s", csv); + ares_free_string(csv); + } +#endif + + curl_msnprintf(service, sizeof(service), "%d", async->port); + socktype = + (Curl_conn_get_transport(data, data->conn) == TRNSPRT_TCP) ? + SOCK_STREAM : SOCK_DGRAM; + +#ifdef CURLRES_IPV6 + if(async->dns_queries & CURL_DNSQ_AAAA) { + struct ares_addrinfo_hints hints; + + memset(&hints, 0, sizeof(hints)); + CURL_TRC_DNS(data, "ares: query AAAA records for %s", async->hostname); + hints.ai_family = PF_INET6; + hints.ai_socktype = socktype; + hints.ai_flags = ARES_AI_NUMERICSERV; + async->queries_ongoing++; + ares_getaddrinfo(ares->channel, async->hostname, + service, &hints, async_ares_AAAA_cb, async); + } +#endif /* CURLRES_IPV6 */ + + if(async->dns_queries & CURL_DNSQ_A) { + struct ares_addrinfo_hints hints; + + memset(&hints, 0, sizeof(hints)); + CURL_TRC_DNS(data, "ares: query A records for %s", async->hostname); + hints.ai_family = PF_INET; + hints.ai_socktype = socktype; + hints.ai_flags = ARES_AI_NUMERICSERV; + async->queries_ongoing++; + ares_getaddrinfo(ares->channel, async->hostname, + service, &hints, async_ares_A_cb, async); + } + +#ifdef USE_HTTPSRR + memset(&ares->hinfo, 0, sizeof(ares->hinfo)); + if(async->dns_queries & CURL_DNSQ_HTTPS) { + char *rrname = NULL; + if(async->port != 443) { + rrname = curl_maprintf("_%d._https.%s", async->port, async->hostname); + if(!rrname) + return CURLE_OUT_OF_MEMORY; + } + CURL_TRC_DNS(data, "ares: query HTTPS records for %s", + rrname ? rrname : async->hostname); + ares->hinfo.rrname = rrname; + async->queries_ongoing++; + ares_query_dnsrec(ares->channel, + rrname ? rrname : async->hostname, + ARES_CLASS_IN, ARES_REC_TYPE_HTTPS, + async_ares_rr_done, async, NULL); + } +#endif /* USE_HTTPSRR */ + +out: + ares->result = result; + return result ? result : (async->queries_ongoing ? CURLE_AGAIN : CURLE_OK); +} + +/* Set what DNS server are is to use. This is called in 2 situations: + * 1. when the application does 'CURLOPT_DNS_SERVERS' and passing NULL + * means any previous set value should be unset. Which means + * we need to destroy and create the are channel anew, if there is one. + * 2. When we lazy init the ares channel and NULL means that there + * are no preferences and we do not reset any existing channel. */ +static CURLcode async_ares_set_dns_servers(struct Curl_easy *data, + struct Curl_resolv_async *async) +{ + struct async_ares_ctx *ares = async ? &async->ares : NULL; + CURLcode result = CURLE_NOT_BUILT_IN; + const char *servers = data->set.str[STRING_DNS_SERVERS]; + int ares_result = ARES_SUCCESS; + +#ifdef DEBUGBUILD + if(getenv("CURL_DNS_SERVER")) + servers = getenv("CURL_DNS_SERVER"); +#endif + + if(!servers) + return CURLE_OK; + + /* if channel is not there, this is a parameter check */ + if(ares && ares->channel) + ares_result = ares_set_servers_ports_csv(ares->channel, servers); + switch(ares_result) { + case ARES_SUCCESS: + result = CURLE_OK; + break; + case ARES_ENOMEM: + result = CURLE_OUT_OF_MEMORY; + break; + case ARES_ENOTINITIALIZED: + case ARES_ENODATA: + case ARES_EBADSTR: + default: + DEBUGF(infof(data, "bad servers set")); + result = CURLE_BAD_FUNCTION_ARGUMENT; + break; + } + return result; +} + +static CURLcode async_ares_set_dns_interface(struct Curl_easy *data, + struct Curl_resolv_async *async) +{ + struct async_ares_ctx *ares = async ? &async->ares : NULL; + const char *interf = data->set.str[STRING_DNS_INTERFACE]; + + if(!interf) + interf = ""; + + /* if channel is not there, this is a parameter check */ + if(ares && ares->channel) + ares_set_local_dev(ares->channel, interf); + + return CURLE_OK; +} + +static CURLcode async_ares_set_dns_local_ip4(struct Curl_easy *data, + struct Curl_resolv_async *async) +{ + struct async_ares_ctx *ares = async ? &async->ares : NULL; + struct in_addr a4; + const char *local_ip4 = data->set.str[STRING_DNS_LOCAL_IP4]; + + if(!local_ip4 || (local_ip4[0] == 0)) { + a4.s_addr = 0; /* disabled: do not bind to a specific address */ + } + else { + if(curlx_inet_pton(AF_INET, local_ip4, &a4) != 1) { + DEBUGF(infof(data, "bad DNS IPv4 address")); + return CURLE_BAD_FUNCTION_ARGUMENT; + } + } + + /* if channel is not there yet, this is a parameter check */ + if(ares && ares->channel) + ares_set_local_ip4(ares->channel, ntohl(a4.s_addr)); + + return CURLE_OK; +} + +static CURLcode async_ares_set_dns_local_ip6(struct Curl_easy *data, + struct Curl_resolv_async *async) +{ +#ifdef USE_IPV6 + struct async_ares_ctx *ares = async ? &async->ares : NULL; + unsigned char a6[INET6_ADDRSTRLEN]; + const char *local_ip6 = data->set.str[STRING_DNS_LOCAL_IP6]; + + if(!local_ip6 || (local_ip6[0] == 0)) { + /* disabled: do not bind to a specific address */ + memset(a6, 0, sizeof(a6)); + } + else { + if(curlx_inet_pton(AF_INET6, local_ip6, a6) != 1) { + DEBUGF(infof(data, "bad DNS IPv6 address")); + return CURLE_BAD_FUNCTION_ARGUMENT; + } + } + + /* if channel is not there, this is a parameter check */ + if(ares && ares->channel) + ares_set_local_ip6(ares->channel, a6); + + return CURLE_OK; +#else /* no IPv6 support */ + (void)data; + (void)async; + return CURLE_NOT_BUILT_IN; +#endif +} + +#endif /* USE_RESOLV_ARES */ diff --git a/3rdparty/curl-8.21.0/lib/asyn-base.c b/3rdparty/curl-8.21.0/lib/asyn-base.c new file mode 100644 index 0000000000..62cb0effe4 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/asyn-base.c @@ -0,0 +1,265 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETDB_H +#include +#endif +#ifdef HAVE_ARPA_INET_H +#include +#endif +#ifdef __VMS +#include +#include +#endif + +#ifdef USE_ARES +#include +#endif + +#include "urldata.h" +#include "connect.h" +#include "curl_trc.h" +#include "hostip.h" +#include "multiif.h" +#include "progress.h" +#include "select.h" +#include "url.h" + +/*********************************************************************** + * Only for builds using asynchronous name resolves + **********************************************************************/ +#ifdef CURLRES_ASYNCH + +timediff_t Curl_async_timeleft_ms(struct Curl_easy *data, + struct Curl_resolv_async *async) +{ + if(async->timeout_ms) { + timediff_t elapsed_ms = + curlx_ptimediff_ms(Curl_pgrs_now(data), &async->start); + return async->timeout_ms - elapsed_ms; + } + return Curl_timeleft_ms(data); +} + +#ifdef USE_ARES + +#if ARES_VERSION < 0x011000 +#error "requires c-ares 1.16.0 or newer" +#endif + +/* + * Curl_ares_pollset() is called when the outside world (using + * curl_multi_fdset()) wants to get our fd_set setup and we are talking with + * ares. The caller must make sure that this function is only called when we + * have a working ares channel. + * + * Returns: sockets-in-use-bitmap + */ +CURLcode Curl_ares_pollset(struct Curl_easy *data, + ares_channel channel, + struct easy_pollset *ps) +{ + curl_socket_t sockets[16]; /* ARES documented limit */ + unsigned int bitmap, i; + CURLcode result = CURLE_OK; + + DEBUGASSERT(channel); + if(!channel) + return CURLE_FAILED_INIT; + + bitmap = ares_getsock(channel, (ares_socket_t *)sockets, + CURL_ARRAYSIZE(sockets)); + for(i = 0; i < CURL_ARRAYSIZE(sockets); ++i) { + int flags = 0; + if(ARES_GETSOCK_READABLE(bitmap, i)) + flags |= CURL_POLL_IN; + if(ARES_GETSOCK_WRITABLE(bitmap, i)) + flags |= CURL_POLL_OUT; + if(!flags) + break; + result = Curl_pollset_change(data, ps, sockets[i], flags, 0); + if(result) + return result; + } + return result; +} + +timediff_t Curl_ares_timeout_ms(struct Curl_easy *data, + struct Curl_resolv_async *async, + ares_channel channel) +{ + timediff_t async_timeout_ms; + + DEBUGASSERT(channel); + if(!channel) + return -1; + + async_timeout_ms = Curl_async_timeleft_ms(data, async); + if((async_timeout_ms > 0) && (async_timeout_ms < INT_MAX)) { + struct timeval timebuf; + struct timeval *timeout; + struct timeval end = { (int)async_timeout_ms / 1000, + ((int)async_timeout_ms % 1000) * 1000 }; + + timeout = ares_timeout(channel, &end, &timebuf); + if(timeout) + return curlx_tvtoms(timeout); + } + return async_timeout_ms; +} + +/* + * Curl_ares_perform() + * + * 1) Ask ares what sockets it currently plays with, then + * 2) wait for the timeout period to check for action on ares' sockets. + * 3) tell ares to act on all the sockets marked as "with action" + * + * return number of sockets it worked on, or -1 on error + */ +int Curl_ares_perform(ares_channel channel, timediff_t timeout_ms) +{ + int nfds; + int bitmask; + ares_socket_t socks[ARES_GETSOCK_MAXNUM]; + struct pollfd pfd[ARES_GETSOCK_MAXNUM]; + int i; + int num = 0; + + if(!channel) + return 0; + + bitmask = ares_getsock(channel, socks, ARES_GETSOCK_MAXNUM); + + for(i = 0; i < ARES_GETSOCK_MAXNUM; i++) { + pfd[i].events = 0; + pfd[i].revents = 0; + if(ARES_GETSOCK_READABLE(bitmask, i)) { + pfd[i].fd = socks[i]; + pfd[i].events |= POLLRDNORM | POLLIN; + } + if(ARES_GETSOCK_WRITABLE(bitmask, i)) { + pfd[i].fd = socks[i]; + pfd[i].events |= POLLWRNORM | POLLOUT; + } + if(pfd[i].events) + num++; + else + break; + } + + if(num) { + nfds = Curl_poll(pfd, (unsigned int)num, timeout_ms); + if(nfds < 0) + return -1; + } + else + nfds = 0; + + if(!nfds) + /* Call ares_process() unconditionally here, even if we timed out + above, as otherwise the ares name resolve will not timeout! */ + ares_process_fd(channel, ARES_SOCKET_BAD, ARES_SOCKET_BAD); + else { + /* move through the descriptors and ask for processing on them */ + for(i = 0; i < num; i++) + ares_process_fd(channel, + (pfd[i].revents & (POLLRDNORM | POLLIN)) ? + pfd[i].fd : ARES_SOCKET_BAD, + (pfd[i].revents & (POLLWRNORM | POLLOUT)) ? + pfd[i].fd : ARES_SOCKET_BAD); + } + return nfds; +} + +#endif /* USE_ARES */ + +#endif /* CURLRES_ASYNCH */ + +#ifdef USE_CURL_ASYNC + +#include "doh.h" + +void Curl_async_shutdown(struct Curl_easy *data, + struct Curl_resolv_async *async) +{ + if(async) { + CURL_TRC_DNS(data, "[%u] shutdown async", async->id); + async->shutdown = TRUE; +#ifdef USE_RESOLV_ARES + Curl_async_ares_shutdown(data, async); +#endif +#ifdef USE_RESOLV_THREADED + Curl_async_thrdd_shutdown(data, async); +#endif +#ifndef CURL_DISABLE_DOH + Curl_doh_cleanup(data, async); +#endif + } +} + +void Curl_async_destroy(struct Curl_easy *data, + struct Curl_resolv_async *async) +{ + if(async) { + CURL_TRC_DNS(data, "[%u] destroy async", async->id); + async->shutdown = TRUE; +#ifdef USE_RESOLV_ARES + Curl_async_ares_destroy(data, async); +#endif +#ifdef USE_RESOLV_THREADED + Curl_async_thrdd_destroy(data, async); +#endif +#ifndef CURL_DISABLE_DOH + Curl_doh_cleanup(data, async); +#endif + curlx_safefree(async); + } +} + +CURLcode Curl_async_failed(struct Curl_easy *data, + struct Curl_resolv_async *async, + const char *detail) +{ + const char *host_or_proxy = "host"; + CURLcode result = CURLE_COULDNT_RESOLVE_HOST; + +#ifndef CURL_DISABLE_PROXY + if(async->for_proxy) { + host_or_proxy = "proxy"; + result = CURLE_COULDNT_RESOLVE_PROXY; + } +#endif + + failf(data, "Could not resolve %s: %s%s%s%s", + host_or_proxy, async->hostname, + detail ? " (" : "", detail ? detail : "", detail ? ")" : ""); + return result; +} + +#endif /* USE_CURL_ASYNC */ diff --git a/3rdparty/curl-8.21.0/lib/asyn-thrdd.c b/3rdparty/curl-8.21.0/lib/asyn-thrdd.c new file mode 100644 index 0000000000..aeadec11a4 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/asyn-thrdd.c @@ -0,0 +1,838 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +/*********************************************************************** + * Only for threaded name resolves builds + **********************************************************************/ +#ifdef USE_RESOLV_THREADED + +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETDB_H +#include +#endif +#ifdef HAVE_ARPA_INET_H +#include +#endif +#ifdef __VMS +#include +#include +#endif + +#ifdef HAVE_GETADDRINFO +#define RESOLVER_ENOMEM EAI_MEMORY /* = WSA_NOT_ENOUGH_MEMORY on Windows */ +#else +#define RESOLVER_ENOMEM SOCKENOMEM +#endif + +#include "urldata.h" +#include "cfilters.h" +#include "curl_addrinfo.h" +#include "curl_trc.h" +#include "hostip.h" +#include "httpsrr.h" +#include "url.h" +#include "multiif.h" +#include "curl_threads.h" +#include "progress.h" +#include "rand.h" +#include "select.h" +#include "thrdqueue.h" +#include "curlx/strparse.h" +#include "curlx/wait.h" + +#ifdef USE_ARES +#include +#ifdef USE_HTTPSRR +#define USE_HTTPSRR_ARES /* the combo */ +#endif +#endif + + +/* + * Curl_async_global_init() + * Called from curl_global_init() to initialize global resolver environment. + * Does nothing here. + */ +int Curl_async_global_init(void) +{ +#if defined(USE_ARES) && defined(CARES_HAVE_ARES_LIBRARY_INIT) + if(ares_library_init(ARES_LIB_INIT_ALL)) { + return CURLE_FAILED_INIT; + } +#endif + return CURLE_OK; +} + +/* + * Curl_async_global_cleanup() + * Called from curl_global_cleanup() to destroy global resolver environment. + * Does nothing here. + */ +void Curl_async_global_cleanup(void) +{ +#if defined(USE_ARES) && defined(CARES_HAVE_ARES_LIBRARY_INIT) + ares_library_cleanup(); +#endif +} + +#ifdef CURLVERBOSE +#define CURL_ASYN_ITEM_DESC_LEN 64 +#define async_item_description(x) (x)->description +#else +#define async_item_description(x) NULL +#endif + +struct async_thrdd_item { + struct Curl_addrinfo *res; +#ifdef CURLVERBOSE + char description[CURL_ASYN_ITEM_DESC_LEN]; +#endif + int sockerr; + uint32_t mid; + uint32_t resolv_id; + uint16_t port; + uint8_t transport; + uint8_t dns_queries; +#ifdef DEBUGBUILD + uint32_t delay_ms; + uint32_t delay_fail_ms; +#endif + char hostname[1]; +}; + +/* Give up reference to add_ctx */ +static void async_thrdd_item_destroy(struct async_thrdd_item *item) +{ + if(item) { + if(item->res) + Curl_freeaddrinfo(item->res); + curlx_free(item); + } +} + +/* Initialize context for threaded resolver */ +static struct async_thrdd_item *async_thrdd_item_create( + struct Curl_easy *data, + uint32_t resolv_id, uint8_t dns_queries, + const char *hostname, uint16_t port, + uint8_t transport) +{ + size_t hostlen = strlen(hostname); + struct async_thrdd_item *item; + + item = curlx_calloc(1, sizeof(*item) + hostlen); + if(!item) + return NULL; + + if(hostlen) /* NUL byte of name already in struct size */ + memcpy(item->hostname, hostname, hostlen); + item->mid = data->mid; + item->resolv_id = resolv_id; + item->dns_queries = dns_queries; + item->port = port; + item->transport = transport; + +#ifdef CURLVERBOSE + curl_msnprintf(item->description, sizeof(item->description), + "[%" FMT_OFF_T "/%u] %s %s:%u", + data->id, item->resolv_id, + Curl_resolv_query_str(dns_queries), + item->hostname, item->port); +#endif + +#ifdef DEBUGBUILD + { + const char *p = getenv("CURL_DBG_RESOLV_DELAY"); + if(p) { + curl_off_t l; + if(!curlx_str_number(&p, &l, UINT32_MAX)) { + item->delay_ms = (uint32_t)l; + } + } + p = getenv("CURL_DBG_RESOLV_FAIL_DELAY"); + if(p) { + curl_off_t l; + if(!curlx_str_number(&p, &l, UINT32_MAX)) { + unsigned char c = 0; + Curl_rand_bytes(data, FALSE, &c, 1); + item->delay_fail_ms = (uint32_t)l + c; + } + } + } +#endif + + return item; +} + +#ifdef USE_HTTPSRR_ARES + +static void async_thrdd_rr_done(void *user_data, ares_status_t status, + size_t timeouts, + const ares_dns_record_t *dnsrec) +{ + struct Curl_resolv_async *async = user_data; + struct async_thrdd_ctx *thrdd = async ? &async->thrdd : NULL; + + (void)timeouts; + if(!thrdd) + return; + + async->dns_responses |= CURL_DNSQ_HTTPS; + async->queries_ongoing--; + async->done = !async->queries_ongoing; + if((ARES_SUCCESS == status) && dnsrec) + async->result = Curl_httpsrr_from_ares(dnsrec, &thrdd->rr.hinfo); +} + +static CURLcode async_rr_start(struct Curl_easy *data, + struct Curl_resolv_async *async) +{ + struct async_thrdd_ctx *thrdd = &async->thrdd; + int status; + char *rrname = NULL; + + DEBUGASSERT(!thrdd->rr.channel); + if(async->port != 443) { + rrname = curl_maprintf("_%d_.https.%s", async->port, async->hostname); + if(!rrname) + return CURLE_OUT_OF_MEMORY; + } + status = ares_init_options(&thrdd->rr.channel, NULL, 0); + if(status != ARES_SUCCESS) { + thrdd->rr.channel = NULL; + curlx_free(rrname); + return CURLE_FAILED_INIT; + } +#ifdef DEBUGBUILD + if(getenv("CURL_DNS_SERVER")) { + const char *servers = getenv("CURL_DNS_SERVER"); + status = ares_set_servers_ports_csv(thrdd->rr.channel, servers); + if(status) { + curlx_free(rrname); + return CURLE_FAILED_INIT; + } + } +#endif + + memset(&thrdd->rr.hinfo, 0, sizeof(thrdd->rr.hinfo)); + thrdd->rr.hinfo.rrname = rrname; + async->queries_ongoing++; + ares_query_dnsrec(thrdd->rr.channel, + rrname ? rrname : async->hostname, ARES_CLASS_IN, + ARES_REC_TYPE_HTTPS, + async_thrdd_rr_done, async, NULL); + CURL_TRC_DNS(data, "[HTTPS-RR] initiated request for %s", + rrname ? rrname : async->hostname); + return CURLE_OK; +} +#endif + +void Curl_async_thrdd_shutdown(struct Curl_easy *data, + struct Curl_resolv_async *async) +{ + Curl_async_thrdd_destroy(data, async); +} + +struct async_thrdd_match_ctx { + uint32_t mid; + uint32_t resolv_id; +}; + +static bool async_thrdd_match_item(void *qitem, void *match_data) +{ + const struct async_thrdd_match_ctx *ctx = match_data; + struct async_thrdd_item *item = qitem; + return (item->mid == ctx->mid) && (item->resolv_id == ctx->resolv_id); +} + +void Curl_async_thrdd_destroy(struct Curl_easy *data, + struct Curl_resolv_async *async) +{ + (void)data; + if(async->queries_ongoing && !async->done && + data->multi && data->multi->resolv_thrdq) { + /* Remove any resolve items still queued */ + struct async_thrdd_match_ctx mctx; + mctx.mid = data->mid; + mctx.resolv_id = async->id; + Curl_thrdq_clear(data->multi->resolv_thrdq, + async_thrdd_match_item, &mctx); + } +#ifdef USE_HTTPSRR_ARES + if(async->thrdd.rr.channel) { + ares_destroy(async->thrdd.rr.channel); + async->thrdd.rr.channel = NULL; + } + Curl_httpsrr_cleanup(&async->thrdd.rr.hinfo); +#endif + async_thrdd_item_destroy(async->thrdd.res_A); + async->thrdd.res_A = NULL; + async_thrdd_item_destroy(async->thrdd.res_AAAA); + async->thrdd.res_AAAA = NULL; +} + +/* + * Waits for a resolve to finish. This function should be avoided since using + * this risk getting the multi interface to "hang". + */ +CURLcode Curl_async_await(struct Curl_easy *data, uint32_t resolv_id, + struct Curl_dns_entry **pdns) +{ + struct Curl_resolv_async *async = Curl_async_get(data, resolv_id); + struct async_thrdd_ctx *thrdd = async ? &async->thrdd : NULL; + timediff_t milli, ms; + + if(!thrdd) + return CURLE_FAILED_INIT; + + while(async->queries_ongoing && !async->done) { + Curl_async_thrdd_multi_process(data->multi); + if(async->done) + break; + + ms = curlx_ptimediff_ms(Curl_pgrs_now(data), &async->start); + if(ms < 3) + milli = 0; + else if(ms <= 50) + milli = ms / 3; + else if(ms <= 250) + milli = 50; + else + milli = 200; + CURL_TRC_DNS(data, "await, waiting %" FMT_TIMEDIFF_T "ms", milli); + curlx_wait_ms(milli); + } + return Curl_async_take_result(data, async, pdns); +} + +#ifdef HAVE_GETADDRINFO + +/* Process the item, using Curl_getaddrinfo_ex() */ +static void async_thrdd_item_process(void *arg) +{ + struct async_thrdd_item *item = arg; + struct addrinfo hints; + char service[12]; + int pf = PF_INET; + int rc; + +#ifdef DEBUGBUILD + if(item->delay_ms) { + curlx_wait_ms(item->delay_ms); + } + if(item->delay_fail_ms) { + curlx_wait_ms(item->delay_fail_ms); + return; + } +#endif + + memset(&hints, 0, sizeof(hints)); +#ifdef CURLRES_IPV6 + if(item->dns_queries & CURL_DNSQ_AAAA) { + pf = (item->dns_queries & CURL_DNSQ_A) ? PF_UNSPEC : PF_INET6; + } +#endif + hints.ai_family = pf; + hints.ai_socktype = Curl_socktype_for_transport(item->transport); + hints.ai_protocol = Curl_protocol_for_transport(item->transport); +#ifdef __APPLE__ + /* If we leave `ai_flags == 0` then macOS is looking for IPV4MAPPED + * when doing AAAA queries. We do not want this "help". */ + hints.ai_flags = AI_ADDRCONFIG; +#endif + + curl_msnprintf(service, sizeof(service), "%u", item->port); +#ifdef AI_NUMERICSERV + hints.ai_flags |= AI_NUMERICSERV; +#endif + + rc = Curl_getaddrinfo_ex(item->hostname, service, &hints, &item->res); + if(rc) { + item->sockerr = SOCKERRNO ? SOCKERRNO : rc; + if(item->sockerr == 0) + item->sockerr = RESOLVER_ENOMEM; + } + else { + Curl_addrinfo_set_port(item->res, item->port); + } +} + +#else /* HAVE_GETADDRINFO */ + +/* Process the item, using Curl_ipv4_resolve_r() */ +static void async_thrdd_item_process(void *arg) +{ + struct async_thrdd_item *item = arg; + +#ifdef DEBUGBUILD + if(item->delay_ms) { + curlx_wait_ms(item->delay_ms); + } + if(item->delay_fail_ms) { + curlx_wait_ms(item->delay_fail_ms); + return; + } +#endif + item->res = Curl_ipv4_resolve_r(item->hostname, item->port); + if(!item->res) { + item->sockerr = SOCKERRNO; + if(item->sockerr == 0) + item->sockerr = RESOLVER_ENOMEM; + } +} + +#endif /* HAVE_GETADDRINFO */ + +#ifdef ENABLE_WAKEUP +static void async_thrdd_event(const struct curl_thrdq *tqueue, + Curl_thrdq_event ev, + void *user_data) +{ + struct Curl_multi *multi = user_data; + (void)tqueue; + switch(ev) { + case CURL_THRDQ_EV_ITEM_DONE: + (void)curl_multi_wakeup(multi); + break; + default: + break; + } +} +#else +#define async_thrdd_event NULL +#endif + +static void async_thrdd_item_free(void *item) +{ + async_thrdd_item_destroy(item); +} + +/* Create a thread queue for processing resolv items */ +CURLcode Curl_async_thrdd_multi_init(struct Curl_multi *multi, + uint32_t min_threads, + uint32_t max_threads, + uint32_t idle_time_ms) +{ + CURLcode result; + DEBUGASSERT(!multi->resolv_thrdq); + result = Curl_thrdq_create(&multi->resolv_thrdq, "DNS", 0, + min_threads, max_threads, idle_time_ms, + async_thrdd_item_free, + async_thrdd_item_process, + async_thrdd_event, + multi); +#ifdef DEBUGBUILD + if(!result) { + const char *p = getenv("CURL_DBG_RESOLV_MAX_THREADS"); + if(p) { + curl_off_t l; + if(!curlx_str_number(&p, &l, UINT32_MAX)) { + result = Curl_async_thrdd_multi_set_props( + multi, min_threads, (uint32_t)l, idle_time_ms); + } + } + } +#endif + return result; +} + +/* Tear down the thread queue, joining active threads or detaching them */ +void Curl_async_thrdd_multi_destroy(struct Curl_multi *multi, bool join) +{ + if(multi->resolv_thrdq) { +#ifdef CURLVERBOSE + CURL_TRC_DNS(multi->admin, "destroy thread queue+pool, join=%d", join); + Curl_thrdq_trace(multi->resolv_thrdq, multi->admin); +#endif + Curl_thrdq_destroy(multi->resolv_thrdq, join); + multi->resolv_thrdq = NULL; + } +} + +#ifdef CURLVERBOSE +static void async_thrdd_report_item(struct Curl_easy *data, + struct async_thrdd_item *item) +{ + char buf[MAX_IPADR_LEN]; + struct dynbuf tmp; + const char *sep = ""; + const struct Curl_addrinfo *ai = item->res; + CURLcode result; + int ai_family; +#ifdef USE_IPV6 + ai_family = (item->dns_queries & CURL_DNSQ_AAAA) ? AF_INET6 : AF_INET; +#else + ai_family = AF_INET; +#endif + + if(!CURL_TRC_DNS_is_verbose(data)) + return; + + curlx_dyn_init(&tmp, 1024); + for(; ai; ai = ai->ai_next) { + if(ai->ai_family == ai_family) { + Curl_printable_address(ai, buf, sizeof(buf)); + result = curlx_dyn_addf(&tmp, "%s%s", sep, buf); + if(result) { + CURL_TRC_DNS(data, "too many IP, cannot show"); + goto out; + } + sep = ", "; + } + } + + CURL_TRC_DNS(data, "Host %s:%u resolved IPv%c: %s", + item->hostname, item->port, + (item->dns_queries & CURL_DNSQ_AAAA) ? '6' : '4', + (curlx_dyn_len(&tmp) ? curlx_dyn_ptr(&tmp) : "(none)")); +out: + curlx_dyn_free(&tmp); +} +#endif /* CURLVERBOSE */ + +/* Process the receiving end of the thread queue, dispatching + * processed items to their transfer when it can still be found + * and has an `async` state present. Otherwise, destroy the item. */ +void Curl_async_thrdd_multi_process(struct Curl_multi *multi) +{ + struct Curl_easy *data; + void *qitem; + + while(!Curl_thrdq_recv(multi->resolv_thrdq, &qitem)) { + /* dispatch resolve result */ + struct async_thrdd_item *item = qitem; + struct Curl_resolv_async *async = NULL; + + data = Curl_multi_get_easy(multi, item->mid); + if(data) + async = Curl_async_get(data, item->resolv_id); + if(async) { + struct async_thrdd_item **pdest = &async->thrdd.res_A; + + async->dns_responses |= item->dns_queries; + --async->queries_ongoing; + async->done = !async->queries_ongoing; + +#ifdef CURLRES_IPV6 + if(item->dns_queries & CURL_DNSQ_AAAA) + pdest = &async->thrdd.res_AAAA; +#endif + if(!*pdest) { + VERBOSE(async_thrdd_report_item(data, item)); + *pdest = item; + item = NULL; + } + else + DEBUGASSERT(0); /* should not receive duplicates here */ + Curl_multi_mark_dirty(data); + } + async_thrdd_item_free(item); + } +#ifdef CURLVERBOSE + Curl_thrdq_trace(multi->resolv_thrdq, multi->admin); +#endif +} + +CURLcode Curl_async_thrdd_multi_set_props(struct Curl_multi *multi, + uint32_t min_threads, + uint32_t max_threads, + uint32_t idle_time_ms) +{ + return Curl_thrdq_set_props(multi->resolv_thrdq, 0, + min_threads, max_threads, idle_time_ms); +} + +static CURLcode async_thrdd_query(struct Curl_easy *data, + struct Curl_resolv_async *async, + uint8_t dns_queries) +{ + struct async_thrdd_item *item; + CURLcode result; + + item = async_thrdd_item_create(data, async->id, dns_queries, + async->hostname, async->port, + async->transport); + if(!item) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + CURL_TRC_DNS(data, "queueing query %s", item->description); + result = Curl_thrdq_send(data->multi->resolv_thrdq, item, + async_item_description(item), async->timeout_ms); + if(result) + goto out; + item = NULL; + async->queries_ongoing++; + +out: + if(item) + async_thrdd_item_free(item); + return result; +} + +CURLcode Curl_async_getaddrinfo(struct Curl_easy *data, + struct Curl_resolv_async *async) +{ + CURLcode result = CURLE_FAILED_INIT; + void *resolver = NULL; + + if(async->queries_ongoing || async->done) + return CURLE_FAILED_INIT; + +#ifdef USE_HTTPSRR_ARES + DEBUGASSERT(!async->thrdd.rr.channel); + if((async->dns_queries & CURL_DNSQ_HTTPS) && !async->is_ipaddr) { + result = async_rr_start(data, async); + if(result) + goto out; + resolver = async->thrdd.rr.channel; + } +#endif + + result = Curl_resolv_announce_start(data, resolver); + if(result) + return result; + +#ifdef CURLRES_IPV6 + /* Do not start an AAAA query for an ipv4 address when + * we will start an A query for it. */ + if((async->dns_queries & CURL_DNSQ_AAAA) && + !(async->is_ipv4addr && (async->dns_queries & CURL_DNSQ_A))) { + result = async_thrdd_query(data, async, CURL_DNSQ_AAAA); + if(result) + goto out; + } +#endif + if(async->dns_queries & CURL_DNSQ_A) { + result = async_thrdd_query(data, async, CURL_DNSQ_A); + if(result) + goto out; + } + +#ifdef CURLVERBOSE + Curl_thrdq_trace(data->multi->resolv_thrdq, data); +#endif + +out: + if(result) + CURL_TRC_DNS(data, "error queueing query %s:%d -> %d", + async->hostname, async->port, (int)result); + return result; +} + +CURLcode Curl_async_pollset(struct Curl_easy *data, + struct Curl_resolv_async *async, + struct easy_pollset *ps) +{ + timediff_t timeout_ms; + + timeout_ms = Curl_async_timeleft_ms(data, async); +#ifdef USE_HTTPSRR_ARES + if(async->thrdd.rr.channel) { + CURLcode result = Curl_ares_pollset(data, async->thrdd.rr.channel, ps); + if(result) + return result; + timeout_ms = Curl_ares_timeout_ms(data, async, async->thrdd.rr.channel); + } +#else + (void)ps; +#endif + + if(!async->done) { +#ifndef ENABLE_WAKEUP + timediff_t stutter_ms, elapsed_ms; + elapsed_ms = curlx_ptimediff_ms(Curl_pgrs_now(data), &async->start); + if(elapsed_ms < 3) + stutter_ms = 1; + else if(elapsed_ms <= 50) + stutter_ms = elapsed_ms / 3; + else if(elapsed_ms <= 250) + stutter_ms = 50; + else + stutter_ms = 200; + timeout_ms = CURLMIN(stutter_ms, timeout_ms); +#endif + Curl_expire(data, timeout_ms, EXPIRE_ASYNC_NAME); + } + return CURLE_OK; +} + +/* + * Curl_async_take_result() is called repeatedly to check if a previous + * name resolve request has completed. It should also make sure to time-out if + * the operation seems to take too long. + */ +CURLcode Curl_async_take_result(struct Curl_easy *data, + struct Curl_resolv_async *async, + struct Curl_dns_entry **pdns) +{ + struct async_thrdd_ctx *thrdd = &async->thrdd; + struct Curl_dns_entry *dns = NULL; + CURLcode result = CURLE_OK; + + DEBUGASSERT(pdns); + *pdns = NULL; + if(!async->queries_ongoing && !async->done) { + DEBUGASSERT(0); + return CURLE_FAILED_INIT; + } + +#ifdef USE_HTTPSRR_ARES + /* best effort, ignore errors */ + if(thrdd->rr.channel) + (void)Curl_ares_perform(thrdd->rr.channel, 0); +#endif +#ifndef ENABLE_WAKEUP + Curl_async_thrdd_multi_process(data->multi); +#endif + + if(!async->done) + return CURLE_AGAIN; + + Curl_expire_done(data, EXPIRE_ASYNC_NAME); + if(async->result) { + result = async->result; + goto out; + } + + if((thrdd->res_A && thrdd->res_A->res) || + (thrdd->res_AAAA && thrdd->res_AAAA->res)) { + dns = Curl_dnscache_mk_entry2( + data, async->dns_queries, + thrdd->res_A ? &thrdd->res_A->res : NULL, + thrdd->res_AAAA ? &thrdd->res_AAAA->res : NULL, + async->hostname, async->port); + if(!dns) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + +#ifdef USE_HTTPSRR_ARES + if(thrdd->rr.channel) { + struct Curl_https_rrinfo *lhrr = NULL; + if(thrdd->rr.hinfo.complete) { + lhrr = Curl_httpsrr_dup_move(&thrdd->rr.hinfo); + if(!lhrr) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + } + Curl_httpsrr_trace(data, lhrr); + Curl_dns_entry_set_https_rr(dns, lhrr); + } +#endif + } + + if(dns) { + *pdns = dns; + dns = NULL; + } +#ifdef CURLVERBOSE + Curl_thrdq_trace(data->multi->resolv_thrdq, data); +#endif + +out: + Curl_dns_entry_unlink(data, &dns); + Curl_async_thrdd_shutdown(data, async); + if(!result && !*pdns) + result = Curl_async_failed(data, async, NULL); + if(result && + (result != CURLE_COULDNT_RESOLVE_HOST) && + (result != CURLE_COULDNT_RESOLVE_PROXY)) { + CURL_TRC_DNS(data, "Error %d resolving %s:%d", + (int)result, async->hostname, async->port); + } + return result; +} + +static const struct Curl_addrinfo *async_thrdd_get_ai( + const struct Curl_addrinfo *ai, + int ai_family, unsigned int index) +{ + unsigned int i = 0; + for(i = 0; ai; ai = ai->ai_next) { + if(ai->ai_family == ai_family) { + if(i == index) + return ai; + ++i; + } + } + return NULL; +} + +const struct Curl_addrinfo *Curl_async_get_ai(struct Curl_easy *data, + struct Curl_resolv_async *async, + int ai_family, + unsigned int index) +{ + struct async_thrdd_ctx *thrdd = &async->thrdd; + + (void)data; + switch(ai_family) { + case AF_INET: + if(thrdd->res_A) + return async_thrdd_get_ai(thrdd->res_A->res, ai_family, index); + break; +#ifdef USE_IPV6 + case AF_INET6: + if(thrdd->res_AAAA) + return async_thrdd_get_ai(thrdd->res_AAAA->res, ai_family, index); + break; +#endif + default: + break; + } + return NULL; +} + +#ifdef USE_HTTPSRR +const struct Curl_https_rrinfo *Curl_async_get_https( + struct Curl_easy *data, + struct Curl_resolv_async *async) +{ +#ifdef USE_HTTPSRR_ARES + if(Curl_async_knows_https(data, async)) + return &async->thrdd.rr.hinfo; +#else + (void)data; + (void)async; +#endif + return NULL; +} + +bool Curl_async_knows_https(struct Curl_easy *data, + struct Curl_resolv_async *async) +{ + (void)data; + if(async->dns_queries & CURL_DNSQ_HTTPS) + return ((async->dns_responses & CURL_DNSQ_HTTPS) || async->done); + return TRUE; /* we know it will never come */ +} + +#endif /* USE_HTTPSRR */ + +#endif /* USE_RESOLV_THREADED */ diff --git a/3rdparty/curl-8.21.0/lib/asyn.h b/3rdparty/curl-8.21.0/lib/asyn.h new file mode 100644 index 0000000000..ed50933654 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/asyn.h @@ -0,0 +1,277 @@ +#ifndef HEADER_CURL_ASYN_H +#define HEADER_CURL_ASYN_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if defined(USE_HTTPSRR) && defined(USE_ARES) +#include "httpsrr.h" +#endif + +struct Curl_easy; +struct Curl_dns_entry; +struct Curl_resolv_async; +struct Curl_multi; +struct easy_pollset; + +#ifdef CURLRES_ASYNCH + +#include "curl_addrinfo.h" + +struct hostent; +struct connectdata; +struct easy_pollset; + +#if defined(USE_RESOLV_ARES) && defined(USE_RESOLV_THREADED) +#error cannot have both USE_RESOLV_ARES and USE_RESOLV_THREADED defined +#endif + +/* + * This header defines all functions in the internal asynch resolver interface. + * All asynch resolvers need to provide these functions. + * asyn-ares.c and asyn-thread.c are the current implementations of asynch + * resolver backends. + */ + +/* + * Curl_async_global_init() + * + * Called from curl_global_init() to initialize global resolver environment. + * Returning anything else than CURLE_OK fails curl_global_init(). + */ +int Curl_async_global_init(void); + +/* + * Curl_async_global_cleanup() + * Called from curl_global_cleanup() to destroy global resolver environment. + */ +void Curl_async_global_cleanup(void); + +/* + * Curl_async_getaddrinfo() - when using this resolver + * + * Returns name information about the given hostname and port number. If + * successful, the 'hostent' is returned and the fourth argument will point to + * memory we need to free after use. That memory *MUST* be freed with + * Curl_freeaddrinfo(), nothing else. + * + * Each resolver backend must of course make sure to return data in the + * correct format to comply with this. + */ +CURLcode Curl_async_getaddrinfo(struct Curl_easy *data, + struct Curl_resolv_async *async); + +const struct Curl_addrinfo *Curl_async_get_ai(struct Curl_easy *data, + struct Curl_resolv_async *async, + int ai_family, + unsigned int index); + +#ifdef USE_HTTPSRR +const struct Curl_https_rrinfo *Curl_async_get_https( + struct Curl_easy *data, + struct Curl_resolv_async *async); +bool Curl_async_knows_https(struct Curl_easy *data, + struct Curl_resolv_async *async); +#endif /* USE_HTTPSRR */ + +#ifdef USE_ARES +/* common functions for c-ares and threaded resolver with HTTPSRR */ +#include + +CURLcode Curl_ares_pollset(struct Curl_easy *data, + ares_channel channel, + struct easy_pollset *ps); + +timediff_t Curl_ares_timeout_ms(struct Curl_easy *data, + struct Curl_resolv_async *async, + ares_channel channel); + +int Curl_ares_perform(ares_channel channel, timediff_t timeout_ms); +#endif + +#ifdef USE_RESOLV_ARES +/* async resolving implementation using c-ares alone */ +struct async_ares_ctx { + ares_channel channel; + struct Curl_addrinfo *res_A; + struct Curl_addrinfo *res_AAAA; + int ares_status; /* ARES_SUCCESS, ARES_ENOTFOUND, etc. */ + CURLcode result; /* CURLE_OK or error handling response */ + struct curltime happy_eyeballs_dns_time; /* when this timer started, or 0 */ +#ifdef USE_HTTPSRR + struct Curl_https_rrinfo hinfo; +#endif +}; + +void Curl_async_ares_shutdown(struct Curl_easy *data, + struct Curl_resolv_async *async); +void Curl_async_ares_destroy(struct Curl_easy *data, + struct Curl_resolv_async *async); + +#endif /* USE_RESOLV_ARES */ + +#ifdef USE_RESOLV_THREADED + +struct async_thrdd_item; + +/* Context for threaded resolver */ +struct async_thrdd_ctx { + struct async_thrdd_item *res_A; /* ipv4 result */ + struct async_thrdd_item *res_AAAA; /* ipv6 result */ +#if defined(USE_HTTPSRR) && defined(USE_ARES) + struct { + ares_channel channel; + struct Curl_https_rrinfo hinfo; + } rr; +#endif +}; + +void Curl_async_thrdd_shutdown(struct Curl_easy *data, + struct Curl_resolv_async *async); +void Curl_async_thrdd_destroy(struct Curl_easy *data, + struct Curl_resolv_async *async); + +CURLcode Curl_async_thrdd_multi_init(struct Curl_multi *multi, + uint32_t min_threads, + uint32_t max_threads, + uint32_t idle_time_ms); +void Curl_async_thrdd_multi_destroy(struct Curl_multi *multi, bool join); +void Curl_async_thrdd_multi_process(struct Curl_multi *multi); + +CURLcode Curl_async_thrdd_multi_set_props(struct Curl_multi *multi, + uint32_t min_threads, + uint32_t max_threads, + uint32_t idle_time_ms); + +#endif /* USE_RESOLV_THREADED */ + +#ifndef CURL_DISABLE_DOH +struct doh_probes; +#endif + +/* + * Curl_async_await() + * + * Waits for a resolve to finish. This function should be avoided since using + * this risk getting the multi interface to "hang". + * + * On return 'dns' is assigned the resolved dns (CURLE_OK or NULL otherwise. + * + * Returns CURLE_COULDNT_RESOLVE_HOST if the host was not resolved, + * CURLE_OPERATION_TIMEDOUT if a time-out occurred, or other errors. + */ +CURLcode Curl_async_await(struct Curl_easy *data, uint32_t resolv_id, + struct Curl_dns_entry **pdns); + +/* + * Take the result of an async resolve operation. + * Returns CURLE_OK with `*pdns` != NULL, CURLE_AGAIN while still + * ongoing or an error code for a failed resolve. + */ +CURLcode Curl_async_take_result(struct Curl_easy *data, + struct Curl_resolv_async *async, + struct Curl_dns_entry **pdns); + +/* Curl_async_pollset() + * + * This function is called from the Curl_multi_pollset() function. 'sock' is a + * pointer to an array to hold the file descriptors, with 'numsock' being the + * size of that array (in number of entries). This function is supposed to + * return bitmask indicating what file descriptors (referring to array indexes + * in the 'sock' array) to wait for, read/write. + */ +CURLcode Curl_async_pollset(struct Curl_easy *data, + struct Curl_resolv_async *async, + struct easy_pollset *ps); + +#else /* CURLRES_ASYNCH */ + +/* convert these functions if an asynch resolver is not used */ +#define Curl_async_global_init() CURLE_OK +#define Curl_async_global_cleanup() Curl_nop_stmt +#define Curl_async_get_ai(a, b, c, d) NULL +#define Curl_async_await(a, b, c) CURLE_COULDNT_RESOLVE_HOST +#define Curl_async_take_result(x, y, z) CURLE_COULDNT_RESOLVE_HOST +#define Curl_async_pollset(x, y, z) CURLE_OK +#define Curl_async_get_https(x, y) NULL +#define Curl_async_knows_https(x, y) TRUE +#endif /* !CURLRES_ASYNCH */ + +#if defined(CURLRES_ASYNCH) || !defined(CURL_DISABLE_DOH) +#define USE_CURL_ASYNC +#endif + +#ifdef USE_CURL_ASYNC + +struct Curl_resolv_async { + struct Curl_resolv_async *next; +#ifdef USE_RESOLV_ARES + struct async_ares_ctx ares; +#elif defined(USE_RESOLV_THREADED) + struct async_thrdd_ctx thrdd; +#endif +#ifndef CURL_DISABLE_DOH + struct doh_probes *doh; /* DoH specific data for this request */ +#endif + struct curltime start; + timediff_t interval_end; + timediff_t timeout_ms; + CURLcode result; + uint32_t poll_interval; + uint32_t id; /* unique id per easy handle of the resolve operation */ + /* what is being resolved */ + uint16_t port; + uint8_t dns_queries; /* what queries are being performed */ + uint8_t dns_responses; /* what queries had responses so far. */ + uint8_t transport; + uint8_t queries_ongoing; + BIT(is_ipaddr); + BIT(is_ipv4addr); + BIT(for_proxy); + BIT(done); + BIT(shutdown); + char hostname[1]; +}; + +timediff_t Curl_async_timeleft_ms(struct Curl_easy *data, + struct Curl_resolv_async *async); + +/* Shut down the given async resolve. */ +void Curl_async_shutdown(struct Curl_easy *data, + struct Curl_resolv_async *async); + +/* Frees the resources of the given async resolve and the struct itself. */ +void Curl_async_destroy(struct Curl_easy *data, + struct Curl_resolv_async *async); + +CURLcode Curl_async_failed(struct Curl_easy *data, + struct Curl_resolv_async *async, + const char *detail); + +#else /* !USE_CURL_ASYNC */ +#define Curl_async_shutdown(x, y) Curl_nop_stmt +#endif /* USE_CURL_ASYNC */ + +/********** end of generic resolver interface functions *****************/ +#endif /* HEADER_CURL_ASYN_H */ diff --git a/3rdparty/curl-8.21.0/lib/bufq.c b/3rdparty/curl-8.21.0/lib/bufq.c new file mode 100644 index 0000000000..750d86888f --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/bufq.c @@ -0,0 +1,619 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "bufq.h" + +static bool chunk_is_empty(const struct buf_chunk *chunk) +{ + return chunk->r_offset >= chunk->w_offset; +} + +static bool chunk_is_full(const struct buf_chunk *chunk) +{ + return chunk->w_offset >= chunk->dlen; +} + +static size_t chunk_len(const struct buf_chunk *chunk) +{ + return chunk->w_offset - chunk->r_offset; +} + +static void chunk_reset(struct buf_chunk *chunk) +{ + chunk->next = NULL; + chunk->r_offset = chunk->w_offset = 0; +} + +static size_t chunk_append(struct buf_chunk *chunk, + const uint8_t *buf, size_t len) +{ + uint8_t *p = &chunk->x.data[chunk->w_offset]; + size_t n = chunk->dlen - chunk->w_offset; + DEBUGASSERT(chunk->dlen >= chunk->w_offset); + if(n) { + n = CURLMIN(n, len); + memcpy(p, buf, n); + chunk->w_offset += n; + } + return n; +} + +static size_t chunk_read(struct buf_chunk *chunk, + uint8_t *buf, size_t len) +{ + uint8_t *p = &chunk->x.data[chunk->r_offset]; + size_t n = chunk->w_offset - chunk->r_offset; + DEBUGASSERT(chunk->w_offset >= chunk->r_offset); + if(!n) { + return 0; + } + else if(n <= len) { + memcpy(buf, p, n); + chunk->r_offset = chunk->w_offset = 0; + return n; + } + else { + memcpy(buf, p, len); + chunk->r_offset += len; + return len; + } +} + +static CURLcode chunk_slurpn(struct buf_chunk *chunk, size_t max_len, + Curl_bufq_reader *reader, + void *reader_ctx, size_t *pnread) +{ + uint8_t *p = &chunk->x.data[chunk->w_offset]; + size_t n = chunk->dlen - chunk->w_offset; /* free amount */ + CURLcode result; + + *pnread = 0; + DEBUGASSERT(chunk->dlen >= chunk->w_offset); + if(!n) + return CURLE_AGAIN; + if(max_len && n > max_len) + n = max_len; + result = reader(reader_ctx, p, n, pnread); + if(!result) { + DEBUGASSERT(*pnread <= n); + chunk->w_offset += *pnread; + } + return result; +} + +static void chunk_peek(const struct buf_chunk *chunk, + const uint8_t **pbuf, size_t *plen) +{ + DEBUGASSERT(chunk->w_offset >= chunk->r_offset); + *pbuf = &chunk->x.data[chunk->r_offset]; + *plen = chunk->w_offset - chunk->r_offset; +} + +static void chunk_peek_at(const struct buf_chunk *chunk, size_t offset, + const uint8_t **pbuf, size_t *plen) +{ + offset += chunk->r_offset; + DEBUGASSERT(chunk->w_offset >= offset); + *pbuf = &chunk->x.data[offset]; + *plen = chunk->w_offset - offset; +} + +static size_t chunk_skip(struct buf_chunk *chunk, size_t amount) +{ + size_t n = chunk->w_offset - chunk->r_offset; + DEBUGASSERT(chunk->w_offset >= chunk->r_offset); + if(n) { + n = CURLMIN(n, amount); + chunk->r_offset += n; + if(chunk->r_offset == chunk->w_offset) + chunk->r_offset = chunk->w_offset = 0; + } + return n; +} + +static void chunk_list_free(struct buf_chunk **anchor) +{ + struct buf_chunk *chunk; + while(*anchor) { + chunk = *anchor; + *anchor = chunk->next; + curlx_free(chunk); + } +} + +void Curl_bufcp_init(struct bufc_pool *pool, + size_t chunk_size, size_t spare_max) +{ + DEBUGASSERT(chunk_size > 0); + DEBUGASSERT(spare_max > 0); + memset(pool, 0, sizeof(*pool)); + pool->chunk_size = chunk_size; + pool->spare_max = spare_max; +} + +static CURLcode bufcp_take(struct bufc_pool *pool, + struct buf_chunk **pchunk) +{ + struct buf_chunk *chunk = NULL; + + if(pool->spare) { + chunk = pool->spare; + pool->spare = chunk->next; + --pool->spare_count; + chunk_reset(chunk); + *pchunk = chunk; + return CURLE_OK; + } + + /* Check for integer overflow before allocation */ + if(pool->chunk_size > SIZE_MAX - sizeof(*chunk)) { + *pchunk = NULL; + return CURLE_OUT_OF_MEMORY; + } + + chunk = curlx_calloc(1, sizeof(*chunk) + pool->chunk_size); + if(!chunk) { + *pchunk = NULL; + return CURLE_OUT_OF_MEMORY; + } + chunk->dlen = pool->chunk_size; + *pchunk = chunk; + return CURLE_OK; +} + +static void bufcp_put(struct bufc_pool *pool, + struct buf_chunk *chunk) +{ + if(pool->spare_count >= pool->spare_max) { + curlx_free(chunk); + } + else { + chunk_reset(chunk); + chunk->next = pool->spare; + pool->spare = chunk; + ++pool->spare_count; + } +} + +void Curl_bufcp_free(struct bufc_pool *pool) +{ + chunk_list_free(&pool->spare); + pool->spare_count = 0; +} + +static void bufq_init(struct bufq *q, struct bufc_pool *pool, + size_t chunk_size, size_t max_chunks, int opts) +{ + DEBUGASSERT(chunk_size > 0); + DEBUGASSERT(max_chunks > 0); + memset(q, 0, sizeof(*q)); + q->chunk_size = chunk_size; + q->max_chunks = max_chunks; + q->pool = pool; + q->opts = opts; +} + +void Curl_bufq_init2(struct bufq *q, size_t chunk_size, size_t max_chunks, + int opts) +{ + bufq_init(q, NULL, chunk_size, max_chunks, opts); +} + +void Curl_bufq_init(struct bufq *q, size_t chunk_size, size_t max_chunks) +{ + bufq_init(q, NULL, chunk_size, max_chunks, BUFQ_OPT_NONE); +} + +void Curl_bufq_initp(struct bufq *q, struct bufc_pool *pool, + size_t max_chunks, int opts) +{ + bufq_init(q, pool, pool->chunk_size, max_chunks, opts); +} + +void Curl_bufq_free(struct bufq *q) +{ + chunk_list_free(&q->head); + chunk_list_free(&q->spare); + q->tail = NULL; + q->chunk_count = 0; +} + +void Curl_bufq_reset(struct bufq *q) +{ + struct buf_chunk *chunk; + while(q->head) { + chunk = q->head; + q->head = chunk->next; + chunk->next = q->spare; + q->spare = chunk; + } + q->tail = NULL; +} + +size_t Curl_bufq_len(const struct bufq *q) +{ + const struct buf_chunk *chunk = q->head; + size_t len = 0; + while(chunk) { + len += chunk_len(chunk); + chunk = chunk->next; + } + return len; +} + +bool Curl_bufq_is_empty(const struct bufq *q) +{ + return !q->head || chunk_is_empty(q->head); +} + +bool Curl_bufq_is_full(const struct bufq *q) +{ + if(!q->tail || q->spare) + return FALSE; + if(q->chunk_count < q->max_chunks) + return FALSE; + if(q->chunk_count > q->max_chunks) + return TRUE; + /* we have no spares and cannot make more, is the tail full? */ + return chunk_is_full(q->tail); +} + +static struct buf_chunk *get_spare(struct bufq *q) +{ + struct buf_chunk *chunk = NULL; + + if(q->spare) { + chunk = q->spare; + q->spare = chunk->next; + chunk_reset(chunk); + return chunk; + } + + if(q->chunk_count >= q->max_chunks && (!(q->opts & BUFQ_OPT_SOFT_LIMIT))) + return NULL; + + if(q->pool) { + if(bufcp_take(q->pool, &chunk)) + return NULL; + ++q->chunk_count; + return chunk; + } + else { + /* Check for integer overflow before allocation */ + if(q->chunk_size > SIZE_MAX - sizeof(*chunk)) { + return NULL; + } + + chunk = curlx_calloc(1, sizeof(*chunk) + q->chunk_size); + if(!chunk) + return NULL; + chunk->dlen = q->chunk_size; + ++q->chunk_count; + return chunk; + } +} + +static void prune_head(struct bufq *q) +{ + struct buf_chunk *chunk; + + while(q->head && chunk_is_empty(q->head)) { + chunk = q->head; + q->head = chunk->next; + if(q->tail == chunk) + q->tail = q->head; + if(q->pool) { + bufcp_put(q->pool, chunk); + --q->chunk_count; + } + else if((q->chunk_count > q->max_chunks) || + (q->opts & BUFQ_OPT_NO_SPARES)) { + /* SOFT_LIMIT allowed us more than max. free spares until + * we are at max again. Or free them if we are configured + * to not use spares. */ + curlx_free(chunk); + --q->chunk_count; + } + else { + chunk->next = q->spare; + q->spare = chunk; + } + } +} + +static struct buf_chunk *get_non_full_tail(struct bufq *q) +{ + struct buf_chunk *chunk; + + if(q->tail && !chunk_is_full(q->tail)) + return q->tail; + chunk = get_spare(q); + if(chunk) { + /* new tail, and possibly new head */ + if(q->tail) { + q->tail->next = chunk; + q->tail = chunk; + } + else { + DEBUGASSERT(!q->head); + q->head = q->tail = chunk; + } + } + return chunk; +} + +CURLcode Curl_bufq_write(struct bufq *q, + const uint8_t *buf, size_t len, + size_t *pnwritten) +{ + struct buf_chunk *tail; + size_t n; + + DEBUGASSERT(q->max_chunks > 0); + *pnwritten = 0; + while(len) { + tail = get_non_full_tail(q); + if(!tail) { + if((q->chunk_count < q->max_chunks) || (q->opts & BUFQ_OPT_SOFT_LIMIT)) + /* should have gotten a tail, but did not */ + return CURLE_OUT_OF_MEMORY; + break; + } + n = chunk_append(tail, buf, len); + if(!n) + break; + *pnwritten += n; + buf += n; + len -= n; + } + return (!*pnwritten && len) ? CURLE_AGAIN : CURLE_OK; +} + +CURLcode Curl_bufq_cwrite(struct bufq *q, + const char *buf, size_t len, + size_t *pnwritten) +{ + return Curl_bufq_write(q, (const uint8_t *)buf, len, pnwritten); +} + +CURLcode Curl_bufq_read(struct bufq *q, uint8_t *buf, size_t len, + size_t *pnread) +{ + *pnread = 0; + while(len && q->head) { + size_t n = chunk_read(q->head, buf, len); + if(n) { + *pnread += n; + buf += n; + len -= n; + } + prune_head(q); + } + return (!*pnread) ? CURLE_AGAIN : CURLE_OK; +} + +CURLcode Curl_bufq_cread(struct bufq *q, char *buf, size_t len, + size_t *pnread) +{ + return Curl_bufq_read(q, (uint8_t *)buf, len, pnread); +} + +bool Curl_bufq_peek(struct bufq *q, + const uint8_t **pbuf, size_t *plen) +{ + if(q->head && chunk_is_empty(q->head)) { + prune_head(q); + } + if(q->head && !chunk_is_empty(q->head)) { + chunk_peek(q->head, pbuf, plen); + return TRUE; + } + *pbuf = NULL; + *plen = 0; + return FALSE; +} + +bool Curl_bufq_peek_at(struct bufq *q, size_t offset, + const uint8_t **pbuf, size_t *plen) +{ + struct buf_chunk *c = q->head; + size_t clen; + + while(c) { + clen = chunk_len(c); + if(!clen) + break; + if(offset >= clen) { + offset -= clen; + c = c->next; + continue; + } + chunk_peek_at(c, offset, pbuf, plen); + return TRUE; + } + *pbuf = NULL; + *plen = 0; + return FALSE; +} + +void Curl_bufq_skip(struct bufq *q, size_t amount) +{ + size_t n; + + while(amount && q->head) { + n = chunk_skip(q->head, amount); + amount -= n; + prune_head(q); + } +} + +CURLcode Curl_bufq_pass(struct bufq *q, Curl_bufq_writer *writer, + void *writer_ctx, size_t *pwritten) +{ + const uint8_t *buf; + size_t blen; + CURLcode result = CURLE_OK; + + *pwritten = 0; + while(Curl_bufq_peek(q, &buf, &blen)) { + size_t chunk_written; + + result = writer(writer_ctx, buf, blen, &chunk_written); + if(result) { + if((result == CURLE_AGAIN) && *pwritten) { + /* blocked on subsequent write, report success */ + result = CURLE_OK; + } + break; + } + if(!chunk_written) { + if(!*pwritten) { + /* treat as blocked */ + result = CURLE_AGAIN; + } + break; + } + *pwritten += chunk_written; + Curl_bufq_skip(q, chunk_written); + } + return result; +} + +CURLcode Curl_bufq_write_pass(struct bufq *q, + const uint8_t *buf, size_t len, + Curl_bufq_writer *writer, void *writer_ctx, + size_t *pwritten) +{ + CURLcode result = CURLE_OK; + size_t n; + + *pwritten = 0; + while(len) { + if(Curl_bufq_is_full(q)) { + /* try to make room in case we are full */ + result = Curl_bufq_pass(q, writer, writer_ctx, &n); + if(result) { + if(result != CURLE_AGAIN) { + /* real error, fail */ + return result; + } + /* would block, bufq is full, give up */ + break; + } + } + + /* Add to bufq as much as there is room for */ + result = Curl_bufq_write(q, buf, len, &n); + if(result) { + if(result != CURLE_AGAIN) + /* real error, fail */ + return result; + /* result == CURLE_AGAIN */ + if(*pwritten) + /* we did write successfully before */ + result = CURLE_OK; + return result; + } + else if(n == 0) + /* edge case of writer returning 0 (and len is >0) + * break or we might enter an infinite loop here */ + break; + + /* Track what we added to bufq */ + buf += n; + len -= n; + *pwritten += n; + } + + return (!*pwritten && len) ? CURLE_AGAIN : CURLE_OK; +} + +CURLcode Curl_bufq_sipn(struct bufq *q, size_t max_len, + Curl_bufq_reader *reader, void *reader_ctx, + size_t *pnread) +{ + struct buf_chunk *tail = NULL; + + *pnread = 0; + tail = get_non_full_tail(q); + if(!tail) { + if(q->chunk_count < q->max_chunks) + return CURLE_OUT_OF_MEMORY; + /* full, blocked */ + return CURLE_AGAIN; + } + + return chunk_slurpn(tail, max_len, reader, reader_ctx, pnread); +} + +/** + * Read up to `max_len` bytes and append it to the end of the buffer queue. + * if `max_len` is 0, no limit is imposed and the call behaves exactly + * the same as `Curl_bufq_slurp()`. + * Returns the total amount of buf read (may be 0) in `pnread` or error + * Note that even in case of an error chunks may have been read and + * the buffer queue will have different length than before. + */ +static CURLcode bufq_slurpn(struct bufq *q, size_t max_len, + Curl_bufq_reader *reader, void *reader_ctx, + size_t *pnread) +{ + CURLcode result; + + *pnread = 0; + while(1) { + size_t n; + result = Curl_bufq_sipn(q, max_len, reader, reader_ctx, &n); + if(result) { + if(!*pnread || result != CURLE_AGAIN) { + /* blocked on first read or real error, fail */ + return result; + } + result = CURLE_OK; + break; + } + else if(n == 0) { + /* eof, result remains CURLE_OK */ + break; + } + *pnread += n; + if(max_len) { + DEBUGASSERT(n <= max_len); + max_len -= n; + if(!max_len) + break; + } + /* give up slurping when we get less bytes than we asked for */ + if(q->tail && !chunk_is_full(q->tail)) + break; + } + return result; +} + +CURLcode Curl_bufq_slurp(struct bufq *q, Curl_bufq_reader *reader, + void *reader_ctx, size_t *pnread) +{ + return bufq_slurpn(q, 0, reader, reader_ctx, pnread); +} diff --git a/3rdparty/curl-8.21.0/lib/bufq.h b/3rdparty/curl-8.21.0/lib/bufq.h new file mode 100644 index 0000000000..c53749d84e --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/bufq.h @@ -0,0 +1,257 @@ +#ifndef HEADER_CURL_BUFQ_H +#define HEADER_CURL_BUFQ_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +/** + * A chunk of bytes for reading and writing. + * The size is fixed a creation with read and write offset + * for where unread content is. + */ +struct buf_chunk { + struct buf_chunk *next; /* to keep it in a list */ + size_t dlen; /* the amount of allocated x.data[] */ + size_t r_offset; /* first unread bytes */ + size_t w_offset; /* one after last written byte */ + union { + uint8_t data[1]; /* the buffer for `dlen` bytes */ + void *dummy; /* alignment */ + } x; +}; + +/** + * A pool for providing/keeping a number of chunks of the same size + * + * The same pool can be shared by many `bufq` instances. A pool is not thread + * safe. All bufqs using it are supposed to operate in the same thread. + */ +struct bufc_pool { + struct buf_chunk *spare; /* list of available spare chunks */ + size_t chunk_size; /* the size of chunks in this pool */ + size_t spare_count; /* current number of spare chunks in list */ + size_t spare_max; /* max number of spares to keep */ +}; + +void Curl_bufcp_init(struct bufc_pool *pool, + size_t chunk_size, size_t spare_max); + +void Curl_bufcp_free(struct bufc_pool *pool); + +/** + * A queue of byte chunks for reading and writing. + * Reading is done from `head`, writing is done to `tail`. + * + * `bufq`s can be empty or full or neither. Its `len` is the number + * of bytes that can be read. For an empty bufq, `len` will be 0. + * + * By default, a bufq can hold up to `max_chunks * chunk_size` number + * of bytes. When `max_chunks` are used (in the `head` list) and the + * `tail` chunk is full, the bufq will report that it is full. + * + * On a full bufq, `len` may be less than the maximum number of bytes, + * e.g. when the head chunk is partially read. `len` may also become + * larger than the max when option `BUFQ_OPT_SOFT_LIMIT` is used. + * + * By default, writing to a full bufq will return (-1, CURLE_AGAIN). Same + * as reading from an empty bufq. + * With `BUFQ_OPT_SOFT_LIMIT` set, a bufq will allow writing beyond this limit + * and use more than `max_chunks`. It will report that it is full + * nevertheless. This is provided for situation where writes preferably never + * fail (except for memory exhaustion). + * + * By default and without a pool, a bufq will keep chunks that read + * empty in its `spare` list. Option `BUFQ_OPT_NO_SPARES` will + * disable that and free chunks once they become empty. + * + * When providing a pool to a bufq, all chunk creation and spare handling + * will be delegated to that pool. + */ +struct bufq { + struct buf_chunk *head; /* chunk with bytes to read from */ + struct buf_chunk *tail; /* chunk to write to */ + struct buf_chunk *spare; /* list of free chunks, unless `pool` */ + struct bufc_pool *pool; /* optional pool for free chunks */ + size_t chunk_count; /* current number of chunks in `head+spare` */ + size_t max_chunks; /* max `head` chunks to use */ + size_t chunk_size; /* size of chunks to manage */ + int opts; /* options for handling queue, see below */ +}; + +/** + * Default behaviour: chunk limit is "hard", meaning attempts to write + * more bytes than can be hold in `max_chunks` is refused and will return + * -1, CURLE_AGAIN. */ +#define BUFQ_OPT_NONE 0 +/** + * Make `max_chunks` a "soft" limit. A bufq will report that it is "full" + * when `max_chunks` are used, but allows writing beyond this limit. + */ +#define BUFQ_OPT_SOFT_LIMIT (1 << 0) +/** + * Do not keep spare chunks. + */ +#define BUFQ_OPT_NO_SPARES (1 << 1) + +/** + * Initialize a buffer queue that can hold up to `max_chunks` buffers + * each of size `chunk_size`. The bufq will not allow writing of + * more bytes than can be held in `max_chunks`. + */ +void Curl_bufq_init(struct bufq *q, size_t chunk_size, size_t max_chunks); + +/** + * Initialize a buffer queue that can hold up to `max_chunks` buffers + * each of size `chunk_size` with the given options. See `BUFQ_OPT_*`. + */ +void Curl_bufq_init2(struct bufq *q, size_t chunk_size, + size_t max_chunks, int opts); + +void Curl_bufq_initp(struct bufq *q, struct bufc_pool *pool, + size_t max_chunks, int opts); + +/** + * Reset the buffer queue to be empty. Keep any allocated buffer chunks + * around. + */ +void Curl_bufq_reset(struct bufq *q); + +/** + * Free all resources held by the buffer queue. + */ +void Curl_bufq_free(struct bufq *q); + +/** + * Return the total amount of data in the queue. + */ +size_t Curl_bufq_len(const struct bufq *q); + +/** + * Returns TRUE iff there is no data in the buffer queue. + */ +bool Curl_bufq_is_empty(const struct bufq *q); + +/** + * Returns TRUE iff there is no space left in the buffer queue. + */ +bool Curl_bufq_is_full(const struct bufq *q); + +/** + * Write buf to the end of the buffer queue. The buf is copied + * and the amount of copied bytes is returned. + * CURLE_AGAIN is returned if the buffer queue is full. + */ +CURLcode Curl_bufq_write(struct bufq *q, + const uint8_t *buf, size_t len, + size_t *pnwritten); + +CURLcode Curl_bufq_cwrite(struct bufq *q, + const char *buf, size_t len, + size_t *pnwritten); + +/** + * Read buf from the start of the buffer queue. The buf is copied + * and the amount of copied bytes is returned. + */ +CURLcode Curl_bufq_read(struct bufq *q, uint8_t *buf, size_t len, + size_t *pnread); + +CURLcode Curl_bufq_cread(struct bufq *q, char *buf, size_t len, + size_t *pnread); + +/** + * Peek at the head chunk in the buffer queue. Returns a pointer to + * the chunk buf (at the current offset) and its length. Does not + * modify the buffer queue. + * Returns TRUE iff bytes are available. Sets `pbuf` to NULL and `plen` + * to 0 when no bytes are available. + * Repeated calls return the same information until the buffer queue + * is modified, see `Curl_bufq_skip()`` + */ +bool Curl_bufq_peek(struct bufq *q, + const uint8_t **pbuf, size_t *plen); + +bool Curl_bufq_peek_at(struct bufq *q, size_t offset, + const uint8_t **pbuf, size_t *plen); + +/** + * Tell the buffer queue to discard `amount` buf bytes at the head of the + * queue. Skipping more buf than is currently buffered will empty the queue. + */ +void Curl_bufq_skip(struct bufq *q, size_t amount); + +typedef CURLcode Curl_bufq_writer(void *writer_ctx, + const uint8_t *buf, size_t len, + size_t *pwritten); + +/** + * Passes the chunks in the buffer queue to the writer and returns + * the amount of buf written. A writer may return -1 and CURLE_AGAIN + * to indicate blocking at which point the queue will stop and return + * the amount of buf passed so far. + * -1 is returned on any other errors reported by the writer. + * Note that in case of a -1 chunks may have been written and + * the buffer queue will have different length than before. + */ +CURLcode Curl_bufq_pass(struct bufq *q, Curl_bufq_writer *writer, + void *writer_ctx, size_t *pwritten); + +typedef CURLcode Curl_bufq_reader(void *reader_ctx, + uint8_t *buf, size_t len, + size_t *pnread); + +/** + * Read bytes and append them to the end of the buffer queue until the + * reader returns blocking or the queue is full. A reader returns + * CURLE_AGAIN to indicate blocking. + * Returns the total amount of buf read (may be 0) in `pnread` on success. + * Note that in case of an error chunks may have been read and + * the buffer queue will have different length than before. + */ +CURLcode Curl_bufq_slurp(struct bufq *q, Curl_bufq_reader *reader, + void *reader_ctx, size_t *pnread); + +/** + * Read *once* up to `max_len` bytes and append it to the buffer. + * if `max_len` is 0, no limit is imposed besides the chunk space. + * Returns the total amount of buf read (may be 0) or -1 on other + * reader errors. + */ +CURLcode Curl_bufq_sipn(struct bufq *q, size_t max_len, + Curl_bufq_reader *reader, void *reader_ctx, + size_t *pnread); + +/** + * Write buf to the end of the buffer queue. + * Write bufq content or passed `buf` directly using the `writer` + * callback when it sees fit. 'buf' might get passed directly + * on or is placed into the buffer, depending on `len` and current + * amount buffered, chunk size, etc. + */ +CURLcode Curl_bufq_write_pass(struct bufq *q, + const uint8_t *buf, size_t len, + Curl_bufq_writer *writer, void *writer_ctx, + size_t *pwritten); + +#endif /* HEADER_CURL_BUFQ_H */ diff --git a/3rdparty/curl-8.21.0/lib/bufref.c b/3rdparty/curl-8.21.0/lib/bufref.c new file mode 100644 index 0000000000..50fafdac03 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/bufref.c @@ -0,0 +1,138 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "urldata.h" +#include "bufref.h" +#include "curlx/strdup.h" + +#ifdef DEBUGBUILD +#define SIGNATURE 0x5c48e9b2 /* Random pattern. */ +#endif + +/* + * Init a bufref struct. + */ +void Curl_bufref_init(struct bufref *br) +{ + DEBUGASSERT(br); + br->dtor = NULL; + br->ptr = NULL; + br->len = 0; + +#ifdef DEBUGBUILD + br->signature = SIGNATURE; +#endif +} + +/* + * Free the buffer and re-init the necessary fields. It does not touch the + * 'signature' field and thus this buffer reference can be reused. + */ + +void Curl_bufref_free(struct bufref *br) +{ + DEBUGASSERT(br); + DEBUGASSERT(br->signature == SIGNATURE); + DEBUGASSERT(br->ptr || !br->len); + + if(br->ptr && br->dtor) + br->dtor(CURL_UNCONST(br->ptr)); + + br->dtor = NULL; + br->ptr = NULL; + br->len = 0; +} + +/* + * Set the buffer reference to new values. The previously referenced buffer + * is released before assignment. + */ +void Curl_bufref_set(struct bufref *br, const void *ptr, size_t len, + void (*dtor)(void *)) +{ + DEBUGASSERT(ptr || !len); + DEBUGASSERT(len <= CURL_MAX_INPUT_LENGTH); + + Curl_bufref_free(br); + br->ptr = (const unsigned char *)ptr; + br->len = len; + br->dtor = dtor; +} + +/* + * Get a pointer to the referenced buffer. + */ +const unsigned char *Curl_bufref_uptr(const struct bufref *br) +{ + DEBUGASSERT(br); + DEBUGASSERT(br->signature == SIGNATURE); + DEBUGASSERT(br->ptr || !br->len); + + return br->ptr; +} + +/* + * Get a pointer to the referenced string. + */ +const char *Curl_bufref_ptr(const struct bufref *br) +{ + DEBUGASSERT(br); + DEBUGASSERT(br->signature == SIGNATURE); + DEBUGASSERT(br->ptr || !br->len); + + return (const char *)br->ptr; +} + +/* + * Get the length of the referenced buffer data. + */ +size_t Curl_bufref_len(const struct bufref *br) +{ + DEBUGASSERT(br); + DEBUGASSERT(br->signature == SIGNATURE); + DEBUGASSERT(br->ptr || !br->len); + + return br->len; +} + +CURLcode Curl_bufref_memdup0(struct bufref *br, const void *ptr, size_t len) +{ + unsigned char *cpy = NULL; + + DEBUGASSERT(br); + DEBUGASSERT(br->signature == SIGNATURE); + DEBUGASSERT(br->ptr || !br->len); + DEBUGASSERT(ptr || !len); + DEBUGASSERT(len <= CURL_MAX_INPUT_LENGTH); + + if(ptr) { + cpy = curlx_memdup0(ptr, len); + if(!cpy) + return CURLE_OUT_OF_MEMORY; + } + + Curl_bufref_set(br, cpy, len, curl_free); + return CURLE_OK; +} diff --git a/3rdparty/curl-8.21.0/lib/bufref.h b/3rdparty/curl-8.21.0/lib/bufref.h new file mode 100644 index 0000000000..5d331adbdf --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/bufref.h @@ -0,0 +1,51 @@ +#ifndef HEADER_CURL_BUFREF_H +#define HEADER_CURL_BUFREF_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +/* + * Generic buffer reference. + */ +struct bufref { + void (*dtor)(void *); /* Associated destructor. */ + const unsigned char *ptr; /* Referenced data buffer. */ + size_t len; /* The data size in bytes. */ +#ifdef DEBUGBUILD + int signature; /* Detect API use mistakes. */ +#endif +}; + +void Curl_bufref_init(struct bufref *br); +void Curl_bufref_set(struct bufref *br, const void *ptr, size_t len, + void (*dtor)(void *)); +const char *Curl_bufref_ptr(const struct bufref *br); +const unsigned char *Curl_bufref_uptr(const struct bufref *br); +size_t Curl_bufref_len(const struct bufref *br); +CURLcode Curl_bufref_memdup0(struct bufref *br, const void *ptr, size_t len); +void Curl_bufref_free(struct bufref *br); + +/* return a strdup() version of the buffer */ +#define Curl_bufref_dup(x) curlx_strdup(Curl_bufref_ptr(x)) + +#endif diff --git a/3rdparty/curl-8.21.0/lib/cf-dns.c b/3rdparty/curl-8.21.0/lib/cf-dns.c new file mode 100644 index 0000000000..631c987be2 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/cf-dns.c @@ -0,0 +1,596 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "urldata.h" +#include "curl_addrinfo.h" +#include "cfilters.h" +#include "connect.h" +#include "dnscache.h" +#include "httpsrr.h" +#include "curl_trc.h" +#include "progress.h" +#include "url.h" +#include "cf-dns.h" + + +struct cf_dns_ctx { + struct Curl_dns_entry *dns; + struct Curl_peer *peer; + CURLcode resolv_result; + uint32_t resolv_id; + uint8_t dns_queries; + uint8_t transport; + BIT(started); + BIT(announced); + BIT(complete_resolve); + BIT(for_proxy); +}; + +static struct cf_dns_ctx *cf_dns_ctx_create(struct Curl_easy *data, + struct Curl_peer *peer, + uint8_t dns_queries, + uint8_t transport, + bool for_proxy, + bool complete_resolve) +{ + struct cf_dns_ctx *ctx; + + ctx = curlx_calloc(1, sizeof(*ctx)); + if(!ctx) + return NULL; + + Curl_peer_link(&ctx->peer, peer); + ctx->dns_queries = dns_queries; + ctx->transport = transport; + ctx->for_proxy = for_proxy; + ctx->complete_resolve = complete_resolve; + + CURL_TRC_DNS(data, "created DNS filter for %s:%u, transport=%x, queries=%x", + peer->hostname, peer->port, ctx->transport, ctx->dns_queries); + return ctx; +} + +static void cf_dns_ctx_destroy(struct Curl_easy *data, + struct cf_dns_ctx *ctx) +{ + if(ctx) { + Curl_peer_unlink(&ctx->peer); + Curl_dns_entry_unlink(data, &ctx->dns); + curlx_free(ctx); + } +} + +#ifdef CURLVERBOSE +static void cf_dns_report_addr(struct Curl_easy *data, + struct dynbuf *tmp, + const char *label, + int ai_family, + const struct Curl_addrinfo *ai) +{ + char buf[MAX_IPADR_LEN]; + const char *sep = ""; + CURLcode result; + + curlx_dyn_reset(tmp); + for(; ai; ai = ai->ai_next) { + if(ai->ai_family == ai_family) { + Curl_printable_address(ai, buf, sizeof(buf)); + result = curlx_dyn_addf(tmp, "%s%s", sep, buf); + if(result) { + infof(data, "too many IP, cannot show"); + return; + } + sep = ", "; + } + } + + infof(data, "%s%s", label, + (curlx_dyn_len(tmp) ? curlx_dyn_ptr(tmp) : "(none)")); +} + +static void cf_dns_report(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct Curl_dns_entry *dns) +{ + struct cf_dns_ctx *ctx = cf->ctx; + struct dynbuf tmp; + + if(!Curl_trc_is_verbose(data) || + /* ignore no name or numerical IP addresses */ + !dns->hostname[0] || Curl_host_is_ipnum(dns->hostname)) + return; + + if(ctx->peer->unix_socket) { +#ifdef USE_UNIX_SOCKETS + CURL_TRC_CF(data, cf, "resolved unix://%s", ctx->peer->hostname); +#else + DEBUGASSERT(0); +#endif + } + else { + curlx_dyn_init(&tmp, 1024); + infof(data, "Host %s:%u was resolved.", dns->hostname, dns->port); +#ifdef CURLRES_IPV6 + cf_dns_report_addr(data, &tmp, "IPv6: ", AF_INET6, dns->addr); +#endif + cf_dns_report_addr(data, &tmp, "IPv4: ", AF_INET, dns->addr); +#ifdef USE_HTTPSRR + if(!dns->hinfo) + infof(data, "HTTPS-RR: -"); + else if(!Curl_httpsrr_applicable(data, dns->hinfo)) + infof(data, "HTTPS-RR: not applicable"); + else { + CURLcode result = Curl_httpsrr_print(&tmp, dns->hinfo); + if(!result) + infof(data, "HTTPS-RR: %s", curlx_dyn_ptr(&tmp)); + else + infof(data, "Error printing HTTPS-RR information"); + } +#endif + curlx_dyn_free(&tmp); + } +} +#else +#define cf_dns_report(x, y, z) Curl_nop_stmt +#endif + +/************************************************************* + * Resolve the address of the server or proxy + *************************************************************/ +static CURLcode cf_dns_start(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct Curl_dns_entry **pdns) +{ + struct cf_dns_ctx *ctx = cf->ctx; + timediff_t timeout_ms = Curl_timeleft_ms(data); + CURLcode result; + + *pdns = NULL; + + CURL_TRC_CF(data, cf, "cf_dns_start %s %s:%u", + ctx->peer->unix_socket ? "unix-domain-socket" : "host", + ctx->peer->hostname, ctx->peer->port); + if(ctx->peer->unix_socket) + ctx->dns_queries = 0; + else if(Curl_is_ipv4addr(ctx->peer->hostname)) + ctx->dns_queries |= CURL_DNSQ_A; +#ifdef USE_IPV6 + else if(ctx->peer->ipv6) + ctx->dns_queries |= CURL_DNSQ_AAAA; +#endif + + result = Curl_resolv(data, ctx->peer, ctx->dns_queries, ctx->transport, + (bool)ctx->for_proxy, timeout_ms, + &ctx->resolv_id, pdns); + DEBUGASSERT(!result || !*pdns); + if(!result) { /* resolved right away, either sync or from dnscache */ + DEBUGASSERT(*pdns); + return CURLE_OK; + } + else if(result == CURLE_AGAIN) { /* async resolv in progress */ + return CURLE_OK; + } + else if(result == CURLE_OPERATION_TIMEDOUT) { /* took too long */ + failf(data, "Failed to resolve '%s' with timeout after %" + FMT_TIMEDIFF_T " ms", ctx->peer->hostname, + curlx_ptimediff_ms(Curl_pgrs_now(data), + &data->progress.t_startsingle)); + return CURLE_OPERATION_TIMEDOUT; + } + else { + DEBUGASSERT(result); + failf(data, "Could not resolve: %s", ctx->peer->hostname); + return result; + } +} + +#define CURL_HEV3_RESOLVE_DELAY_MS 50 + +static bool cf_dns_ready_to_connect(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_dns_ctx *ctx = cf->ctx; + + if(ctx->resolv_result) + return TRUE; + else if(ctx->dns) + return TRUE; +#ifdef USE_CURL_ASYNC + else { + /* We want AAAA answer as we prefer ipv6. If a sub-filter desires + * HTTPS-RR, we check for that query as well. */ + uint8_t wanted_answers = CURL_DNSQ_AAAA; + if(Curl_conn_cf_wants_httpsrr(cf, data)) + wanted_answers |= CURL_DNSQ_HTTPS; + + /* Note: if a query was never started, it is considered to have + * an answer (e.g. a negative one). */ + if(Curl_resolv_has_answers(data, ctx->resolv_id, wanted_answers)) + return TRUE; + /* If the wanted answers are not available after a delay, + * we let the connect attempts start anyway. */ + return Curl_resolv_elapsed_ms(data, ctx->resolv_id) >= + CURL_HEV3_RESOLVE_DELAY_MS; + } +#else + (void)data; + DEBUGASSERT(0); /* We should not come here */ + return FALSE; +#endif /* USE_CURL_ASYNC */ +} + +static CURLcode cf_dns_connect(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ + struct cf_dns_ctx *ctx = cf->ctx; + + if(cf->connected) { + *done = TRUE; + return CURLE_OK; + } + + *done = FALSE; + if(!ctx->started) { + ctx->started = TRUE; + ctx->resolv_result = cf_dns_start(cf, data, &ctx->dns); + } + + if(!ctx->dns && !ctx->resolv_result) { + ctx->resolv_result = + Curl_resolv_take_result(data, ctx->resolv_id, &ctx->dns); + } + + if(ctx->resolv_result) { + CURL_TRC_CF(data, cf, "error resolving: %d", (int)ctx->resolv_result); + return ctx->resolv_result; + } + + if(ctx->dns && !ctx->announced) { + ctx->announced = TRUE; + if(cf->sockindex == FIRSTSOCKET) { + cf->conn->bits.dns_resolved = TRUE; + Curl_pgrsTime(data, TIMER_NAMELOOKUP); + } + cf_dns_report(cf, data, ctx->dns); + } + + if(!cf_dns_ready_to_connect(cf, data)) { + return CURLE_OK; + } + + if(cf->next && !cf->next->connected) { + bool sub_done; + CURLcode result = Curl_conn_cf_connect(cf->next, data, &sub_done); + if(result || !sub_done) + return result; + DEBUGASSERT(sub_done); + } + + /* sub filter chain is connected */ + CURL_TRC_CF(data, cf, "connected filter chain below"); + if(ctx->complete_resolve && !ctx->dns && !ctx->resolv_result) { + /* This filter only connects when it has resolved everything. */ + CURL_TRC_CF(data, cf, "delay connect until resolve complete"); + return CURLE_OK; + } + *done = TRUE; + cf->connected = TRUE; + Curl_resolv_destroy(data, ctx->resolv_id); + return CURLE_OK; +} + +static void cf_dns_destroy(struct Curl_cfilter *cf, struct Curl_easy *data) +{ + struct cf_dns_ctx *ctx = cf->ctx; + + CURL_TRC_CF(data, cf, "destroy"); + cf_dns_ctx_destroy(data, ctx); +} + +static CURLcode cf_dns_adjust_pollset(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct easy_pollset *ps) +{ +#ifdef USE_CURL_ASYNC + if(!cf->connected) + return Curl_resolv_pollset(data, ps); +#else + (void)cf; + (void)data; + (void)ps; +#endif + return CURLE_OK; +} + +static CURLcode cf_dns_cntrl(struct Curl_cfilter *cf, + struct Curl_easy *data, + int event, int arg1, void *arg2) +{ + struct cf_dns_ctx *ctx = cf->ctx; + CURLcode result = CURLE_OK; + + (void)arg1; + (void)arg2; + switch(event) { + case CF_CTRL_DATA_DONE: + if(ctx->dns) { + /* Should only come here when the connect attempt failed and + * `data` is giving up on it. On a successful connect, we already + * unlinked the DNS entry. */ + Curl_dns_entry_unlink(data, &ctx->dns); + } + break; + default: + break; + } + return result; +} + +struct Curl_cftype Curl_cft_dns = { + "DNS", + CF_TYPE_SETUP, + CURL_LOG_LVL_NONE, + cf_dns_destroy, + cf_dns_connect, + Curl_cf_def_shutdown, + cf_dns_adjust_pollset, + Curl_cf_def_data_pending, + Curl_cf_def_send, + Curl_cf_def_recv, + cf_dns_cntrl, + Curl_cf_def_conn_is_alive, + Curl_cf_def_conn_keep_alive, + Curl_cf_def_query, +}; + +static CURLcode cf_dns_create(struct Curl_cfilter **pcf, + struct Curl_easy *data, + struct Curl_peer *peer, + uint8_t dns_queries, + uint8_t transport, + bool for_proxy, + bool complete_resolve) +{ + struct Curl_cfilter *cf = NULL; + struct cf_dns_ctx *ctx; + CURLcode result = CURLE_OK; + + (void)data; + ctx = cf_dns_ctx_create(data, peer, dns_queries, transport, + for_proxy, complete_resolve); + if(!ctx) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + result = Curl_cf_create(&cf, &Curl_cft_dns, ctx); + +out: + *pcf = result ? NULL : cf; + if(result) + cf_dns_ctx_destroy(data, ctx); + return result; +} + +/* Adds a "resolv" filter at the top of the connection's filter chain. + * The filter will resolve the peer on the first connect attempt. */ +CURLcode Curl_cf_dns_add(struct Curl_easy *data, + struct connectdata *conn, + int sockindex, + struct Curl_peer *peer, + uint8_t dns_queries, + uint8_t transport) +{ + struct Curl_cfilter *cf = NULL; + bool for_proxy = FALSE; + CURLcode result; + + if(!peer) + return CURLE_FAILED_INIT; +#ifndef CURL_DISABLE_PROXY + for_proxy = (peer == conn->socks_proxy.peer) || + (peer == conn->http_proxy.peer); +#endif + + result = cf_dns_create(&cf, data, peer, dns_queries, transport, + for_proxy, FALSE); + if(result) + goto out; + Curl_conn_cf_add(data, conn, sockindex, cf); +out: + return result; +} + +/* Insert a new "resolv" filter directly after `cf`. It will + * start a DNS resolve for the given peer on the + * first connect attempt. + * See socks.c on how this is used to make a non-blocking DNS + * resolve during connect. + */ +CURLcode Curl_cf_dns_insert_after(struct Curl_cfilter *cf_at, + struct Curl_easy *data, + uint8_t dns_queries, + struct Curl_peer *peer, + uint8_t transport, + bool complete_resolve) +{ + struct Curl_cfilter *cf; + CURLcode result; + + result = cf_dns_create(&cf, data, peer, dns_queries, transport, + FALSE, complete_resolve); + if(result) + return result; + + Curl_conn_cf_insert_after(cf_at, cf); + return CURLE_OK; +} + +/* Return the resolv result from the first "resolv" filter, starting + * the given filter `cf` downwards. + */ +static CURLcode cf_dns_result(struct Curl_cfilter *cf, + struct Curl_peer *peer) +{ + for(; cf; cf = cf->next) { + if(cf->cft == &Curl_cft_dns) { + struct cf_dns_ctx *ctx = cf->ctx; + if(Curl_peer_same_destination(ctx->peer, peer)) { + if(ctx->dns || ctx->resolv_result) + return ctx->resolv_result; + return CURLE_AGAIN; + } + return CURLE_OK; /* ok, but no results */ + } + } + return CURLE_FAILED_INIT; +} + +/* Return the result of the DNS resolution for peer. Searches for a "resolv" + * filter from the top of the filter chain down. Returns + * - CURLE_AGAIN when not done yet + * - CURLE_OK when DNS was successfully resolved + * - CURLR_FAILED_INIT when no resolv filter was found + * - error returned by the DNS resolv + */ +CURLcode Curl_conn_dns_result(struct connectdata *conn, + int sockindex, + struct Curl_peer *peer) +{ + return cf_dns_result(conn->cfilter[sockindex], peer); +} + +static const struct Curl_addrinfo *cf_dns_get_nth_ai( + struct Curl_cfilter *cf, + const struct Curl_addrinfo *ai, + int ai_family, unsigned int index) +{ + struct cf_dns_ctx *ctx = cf->ctx; + unsigned int i = 0; + + if((ai_family == AF_INET) && !(ctx->dns_queries & CURL_DNSQ_A)) + return NULL; +#ifdef USE_IPV6 + if((ai_family == AF_INET6) && !(ctx->dns_queries & CURL_DNSQ_AAAA)) + return NULL; +#endif + for(i = 0; ai; ai = ai->ai_next) { + if(ai->ai_family == ai_family) { + if(i == index) + return ai; + ++i; + } + } + return NULL; +} + +/* Return the addrinfo at `index` for the given `family` from the + * first "resolve" filter underneath `cf`. If the DNS resolving is + * not done yet or if no address for the family exists, returns NULL. + */ +const struct Curl_addrinfo *Curl_cf_dns_get_ai(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct Curl_peer *peer, + int ai_family, + unsigned int index) +{ + (void)data; + for(; cf; cf = cf->next) { + if(cf->cft == &Curl_cft_dns) { + struct cf_dns_ctx *ctx = cf->ctx; + if(Curl_peer_same_destination(ctx->peer, peer)) { + if(ctx->resolv_result) + return NULL; + else if(ctx->dns) + return cf_dns_get_nth_ai(cf, ctx->dns->addr, ai_family, index); + else + return Curl_resolv_get_ai(data, ctx->resolv_id, ai_family, index); + } + } + } + return NULL; +} + +/* Return the addrinfo at `index` for the given `family` from the + * first "resolve" filter at the connection. If the DNS resolving is + * not done yet or if no address for the family exists, returns NULL. + */ +const struct Curl_addrinfo *Curl_conn_dns_get_ai(struct Curl_easy *data, + struct Curl_peer *peer, + int sockindex, + int ai_family, + unsigned int index) +{ + struct connectdata *conn = data->conn; + return Curl_cf_dns_get_ai(conn->cfilter[sockindex], data, peer, + ai_family, index); +} + +#ifdef USE_HTTPSRR +/* Return the HTTPS-RR info from the first "resolve" filter at the + * connection. If the DNS resolving is not done yet or if there + * is no HTTPS-RR info, returns NULL. + */ +const struct Curl_https_rrinfo * +Curl_conn_dns_get_https(struct Curl_easy *data, + int sockindex, + struct Curl_peer *peer) +{ + struct Curl_cfilter *cf = data->conn->cfilter[sockindex]; + for(; cf; cf = cf->next) { + if(cf->cft == &Curl_cft_dns) { + struct cf_dns_ctx *ctx = cf->ctx; + if(Curl_peer_same_destination(ctx->peer, peer)) { + if(ctx->dns) + return ctx->dns->hinfo; + else + return Curl_resolv_get_https(data, ctx->resolv_id); + } + } + } + return NULL; +} + +bool Curl_conn_dns_resolved_https(struct Curl_easy *data, + int sockindex, + struct Curl_peer *peer) +{ + struct Curl_cfilter *cf = data->conn->cfilter[sockindex]; + for(; cf; cf = cf->next) { + if(cf->cft == &Curl_cft_dns) { + struct cf_dns_ctx *ctx = cf->ctx; + if(Curl_peer_same_destination(ctx->peer, peer)) { + if(ctx->dns) + return TRUE; + else + return Curl_resolv_knows_https(data, ctx->resolv_id); + } + } + } + return TRUE; +} + +#endif /* USE_HTTPSRR */ diff --git a/3rdparty/curl-8.21.0/lib/cf-dns.h b/3rdparty/curl-8.21.0/lib/cf-dns.h new file mode 100644 index 0000000000..891b1efea6 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/cf-dns.h @@ -0,0 +1,79 @@ +#ifndef HEADER_CURL_CF_DNS_H +#define HEADER_CURL_CF_DNS_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +struct Curl_easy; +struct connectdata; +struct Curl_dns_entry; +struct Curl_addrinfo; +struct Curl_peer; + +CURLcode Curl_cf_dns_add(struct Curl_easy *data, + struct connectdata *conn, + int sockindex, + struct Curl_peer *peer, + uint8_t dns_queries, + uint8_t transport); + +CURLcode Curl_cf_dns_insert_after(struct Curl_cfilter *cf_at, + struct Curl_easy *data, + uint8_t dns_queries, + struct Curl_peer *peer, + uint8_t transport, + bool complete_resolve); + +CURLcode Curl_conn_dns_result(struct connectdata *conn, + int sockindex, + struct Curl_peer *peer); + +const struct Curl_addrinfo *Curl_conn_dns_get_ai(struct Curl_easy *data, + struct Curl_peer *peer, + int sockindex, + int ai_family, + unsigned int index); + +const struct Curl_addrinfo *Curl_cf_dns_get_ai(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct Curl_peer *peer, + int ai_family, + unsigned int index); + +#ifdef USE_HTTPSRR +const struct Curl_https_rrinfo * +Curl_conn_dns_get_https(struct Curl_easy *data, + int sockindex, + struct Curl_peer *peer); +bool Curl_conn_dns_resolved_https(struct Curl_easy *data, + int sockindex, + struct Curl_peer *peer); +#else +#define Curl_conn_dns_get_https(a, b, c) NULL +#define Curl_conn_dns_resolved_https(a, b, c) TRUE +#endif + +extern struct Curl_cftype Curl_cft_dns; + +#endif /* HEADER_CURL_CF_DNS_H */ diff --git a/3rdparty/curl-8.21.0/lib/cf-h1-proxy.c b/3rdparty/curl-8.21.0/lib/cf-h1-proxy.c new file mode 100644 index 0000000000..f1e5c7a42a --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/cf-h1-proxy.c @@ -0,0 +1,1005 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_PROXY) && !defined(CURL_DISABLE_HTTP) + + +#include +#include "urldata.h" +#include "curlx/dynbuf.h" +#include "sendf.h" +#include "http.h" +#include "http1.h" +#include "http_proxy.h" +#include "select.h" +#include "progress.h" +#include "multiif.h" +#include "cfilters.h" +#include "cf-h1-proxy.h" +#include "connect.h" +#include "curl_trc.h" +#include "strcase.h" +#include "curlx/strparse.h" + +typedef enum { + H1_TUNNEL_INIT, /* init/default/no tunnel state */ + H1_TUNNEL_CONNECT, /* CONNECT request is being send */ + H1_TUNNEL_RECEIVE, /* CONNECT answer is being received */ + H1_TUNNEL_RESPONSE, /* CONNECT response received completely */ + H1_TUNNEL_ESTABLISHED, + H1_TUNNEL_FAILED +} h1_tunnel_state; + +/* struct for HTTP CONNECT tunneling */ +struct h1_tunnel_state { + struct Curl_peer *dest; + struct dynbuf rcvbuf; + struct dynbuf request_data; + size_t nsent; + size_t headerlines; + struct Curl_chunker ch; + int httpversion; + enum keeponval { + KEEPON_DONE, + KEEPON_CONNECT, + KEEPON_IGNORE + } keepon; + curl_off_t cl; /* size of content to read and ignore */ + h1_tunnel_state tunnel_state; + BIT(chunked_encoding); + BIT(close_connection); + BIT(maybe_folded); + BIT(leading_unfold); +}; + +/* Persistent context for the H1-PROXY filter */ +struct cf_h1_proxy_ctx { + struct h1_tunnel_state *ts; + BIT(udp_tunnel); +}; + +static bool tunnel_is_established(struct h1_tunnel_state *ts) +{ + return ts && (ts->tunnel_state == H1_TUNNEL_ESTABLISHED); +} + +static bool tunnel_is_failed(struct h1_tunnel_state *ts) +{ + return ts && (ts->tunnel_state == H1_TUNNEL_FAILED); +} + +static bool h1_proxy_is_udp(struct Curl_cfilter *cf) +{ + struct cf_h1_proxy_ctx *pctx = cf->ctx; + return (pctx->udp_tunnel ? TRUE : FALSE); +} + +static CURLcode tunnel_reinit(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h1_tunnel_state *ts) +{ + (void)data; + (void)cf; + DEBUGASSERT(ts); + curlx_dyn_reset(&ts->rcvbuf); + curlx_dyn_reset(&ts->request_data); + ts->tunnel_state = H1_TUNNEL_INIT; + ts->keepon = KEEPON_CONNECT; + ts->cl = 0; + ts->close_connection = FALSE; + ts->maybe_folded = FALSE; + ts->leading_unfold = FALSE; + ts->nsent = 0; + ts->headerlines = 0; + return CURLE_OK; +} + +static CURLcode tunnel_init(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h1_tunnel_state **pts) +{ + struct h1_tunnel_state *ts; + + if(cf->conn->scheme->flags & PROTOPT_NOTCPPROXY) { + failf(data, "%s cannot be done over CONNECT", cf->conn->scheme->name); + return CURLE_UNSUPPORTED_PROTOCOL; + } + + ts = curlx_calloc(1, sizeof(*ts)); + if(!ts) + return CURLE_OUT_OF_MEMORY; + + infof(data, "allocate connect buffer"); + + curlx_dyn_init(&ts->rcvbuf, DYN_PROXY_CONNECT_HEADERS); + curlx_dyn_init(&ts->request_data, DYN_HTTP_REQUEST); + Curl_httpchunk_init(data, &ts->ch, TRUE); + + *pts = ts; + return tunnel_reinit(cf, data, ts); +} + +static void h1_tunnel_go_state(struct Curl_cfilter *cf, + struct h1_tunnel_state *ts, + h1_tunnel_state new_state, + struct Curl_easy *data) +{ + if(ts->tunnel_state == new_state) + return; + /* entering this one */ + switch(new_state) { + case H1_TUNNEL_INIT: + CURL_TRC_CF(data, cf, "new tunnel state 'init'"); + tunnel_reinit(cf, data, ts); + break; + + case H1_TUNNEL_CONNECT: + CURL_TRC_CF(data, cf, "new tunnel state 'connect'"); + ts->tunnel_state = H1_TUNNEL_CONNECT; + ts->keepon = KEEPON_CONNECT; + curlx_dyn_reset(&ts->rcvbuf); + break; + + case H1_TUNNEL_RECEIVE: + CURL_TRC_CF(data, cf, "new tunnel state 'receive'"); + ts->tunnel_state = H1_TUNNEL_RECEIVE; + break; + + case H1_TUNNEL_RESPONSE: + CURL_TRC_CF(data, cf, "new tunnel state 'response'"); + ts->tunnel_state = H1_TUNNEL_RESPONSE; + break; + + case H1_TUNNEL_ESTABLISHED: + CURL_TRC_CF(data, cf, "new tunnel state 'established'"); + infof(data, "CONNECT%s phase completed for HTTP proxy", + h1_proxy_is_udp(cf) ? "-UDP" : ""); + + data->state.authproxy.done = TRUE; + data->state.authproxy.multipass = FALSE; + FALLTHROUGH(); + case H1_TUNNEL_FAILED: + if(new_state == H1_TUNNEL_FAILED) + CURL_TRC_CF(data, cf, "new tunnel state 'failed'"); + ts->tunnel_state = new_state; + curlx_dyn_reset(&ts->rcvbuf); + curlx_dyn_reset(&ts->request_data); + /* restore the protocol pointer */ + data->info.httpcode = 0; /* clear it as it might have been used for the + proxy */ + /* If a proxy-authorization header was used for the proxy, then we should + make sure that it is not accidentally used for the document request + after we have connected. Let's thus free and clear it here. */ + curlx_safefree(data->req.hd_proxy_auth); + break; + } +} + +static void tunnel_free(struct h1_tunnel_state *ts, + struct Curl_easy *data) +{ + if(ts) { + Curl_peer_unlink(&ts->dest); + curlx_dyn_free(&ts->rcvbuf); + curlx_dyn_free(&ts->request_data); + Curl_httpchunk_free(data, &ts->ch); + curlx_free(ts); + } +} + +static void cf_tunnel_free(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + if(cf) { + struct cf_h1_proxy_ctx *pctx = cf->ctx; + struct h1_tunnel_state *ts = pctx ? pctx->ts : NULL; + if(ts) { + h1_tunnel_go_state(cf, ts, H1_TUNNEL_FAILED, data); + tunnel_free(ts, data); + pctx->ts = NULL; + } + } +} + +static bool tunnel_want_send(struct h1_tunnel_state *ts) +{ + return ts->tunnel_state == H1_TUNNEL_CONNECT; +} + +static CURLcode start_CONNECT(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h1_tunnel_state *ts) +{ + struct httpreq *req = NULL; + int http_minor; + CURLcode result; + + DEBUGASSERT(data); + /* This only happens if we have looped here due to authentication reasons, + and we do not really use the newly cloned URL here then. Free it. */ + curlx_safefree(data->req.newurl); + + result = Curl_http_proxy_create_tunnel_request(&req, cf, data, ts->dest, + PROXY_HTTP_V1, + h1_proxy_is_udp(cf)); + if(result) + goto out; + + curlx_dyn_reset(&ts->request_data); + ts->nsent = 0; + ts->headerlines = 0; + http_minor = ts->httpversion % 10; + + result = Curl_h1_req_write_head(req, http_minor, &ts->request_data); + if(!result) + result = Curl_creader_set_null(data); + +out: + if(result) + failf(data, "Failed sending CONNECT to proxy"); + if(req) + Curl_http_req_free(req); + return result; +} + +static CURLcode send_CONNECT(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h1_tunnel_state *ts, + bool *done) +{ + const uint8_t *buf = curlx_dyn_uptr(&ts->request_data); + size_t request_len = curlx_dyn_len(&ts->request_data); + size_t blen = request_len; + CURLcode result = CURLE_OK; + size_t nwritten; + + if(blen <= ts->nsent) + goto out; /* we are done */ + + blen -= ts->nsent; + buf += ts->nsent; + + result = cf->next->cft->do_send(cf->next, data, buf, blen, FALSE, &nwritten); + if(result) { + if(result == CURLE_AGAIN) + result = CURLE_OK; + goto out; + } + + DEBUGASSERT(blen >= nwritten); + ts->nsent += nwritten; + Curl_debug(data, CURLINFO_HEADER_OUT, (const char *)buf, nwritten); + +out: + if(result) + failf(data, "Failed sending CONNECT to proxy"); + *done = (!result && (ts->nsent >= request_len)); + return result; +} + +static CURLcode on_resp_header_udp(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h1_tunnel_state *ts, + const char *header) +{ + CURLcode result = CURLE_OK; + struct SingleRequest *k = &data->req; + + if((checkprefix("WWW-Authenticate:", header) && (401 == k->httpcode)) || + (checkprefix("Proxy-authenticate:", header) && (407 == k->httpcode))) { + + bool proxy = (k->httpcode == 407); + char *auth = Curl_copy_header_value(header); + if(!auth) + return CURLE_OUT_OF_MEMORY; + + CURL_TRC_CF(data, cf, "CONNECT-UDP: fwd auth header '%s'", header); + result = Curl_http_input_auth(data, proxy, auth); + + curlx_free(auth); + + if(result) + return result; + } + else if(checkprefix("Content-Length:", header)) { + if(k->httpcode / 100 == 2 || k->httpcode == 101) { + infof(data, "Ignoring Content-Length in CONNECT-UDP %03d response", + k->httpcode); + } + else { + const char *p = header + strlen("Content-Length:"); + if(curlx_str_numblanks(&p, &ts->cl)) { + failf(data, "Unsupported Content-Length value"); + return CURLE_WEIRD_SERVER_REPLY; + } + } + } + else if(checkprefix("Transfer-Encoding:", header)) { + if(k->httpcode / 100 == 2 || k->httpcode == 101) { + infof(data, "Ignoring Transfer-Encoding in " + "CONNECT-UDP %03d response", k->httpcode); + } + else if(Curl_compareheader(header, + STRCONST("Transfer-Encoding:"), + STRCONST("chunked"))) { + CURL_TRC_CF(data, cf, "CONNECT-UDP Response --> " + "Transfer-Encoding: chunked"); + ts->chunked_encoding = TRUE; + /* reset our chunky engine */ + Curl_httpchunk_reset(data, &ts->ch, TRUE); + } + } + else if(checkprefix("Capsule-protocol:", header)) { + if(Curl_compareheader(header, + STRCONST("Capsule-protocol:"), + STRCONST("?1"))) { + CURL_TRC_CF(data, cf, "CONNECT-UDP Response --> Capsule-protocol: ?1"); + } + } + else if(Curl_compareheader(header, + STRCONST("Connection:"), STRCONST("close"))) { + ts->close_connection = TRUE; + CURL_TRC_CF(data, cf, "CONNECT-UDP Response --> Connection: close"); + } + else if(Curl_compareheader(header, + STRCONST("Proxy-Connection:"), + STRCONST("close"))) { + ts->close_connection = TRUE; + CURL_TRC_CF(data, cf, + "CONNECT-UDP Response --> Proxy-Connection: close"); + } + else if(!strncmp(header, "HTTP/1.", 7) && + ((header[7] == '0') || (header[7] == '1')) && + (header[8] == ' ') && + ISDIGIT(header[9]) && ISDIGIT(header[10]) && ISDIGIT(header[11]) && + !ISDIGIT(header[12])) { + /* store the HTTP code from the proxy */ + data->info.httpproxycode = k->httpcode = + ((header[9] - '0') * 100) + + ((header[10] - '0') * 10) + + (header[11] - '0'); + CURL_TRC_CF(data, cf, "CONNECT-UDP Response --> %d", k->httpcode); + } + return result; +} + +static CURLcode on_resp_header(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h1_tunnel_state *ts, + const char *header) +{ + CURLcode result = CURLE_OK; + struct SingleRequest *k = &data->req; + (void)cf; + + if((checkprefix("WWW-Authenticate:", header) && (401 == k->httpcode)) || + (checkprefix("Proxy-authenticate:", header) && (407 == k->httpcode))) { + + bool proxy = (k->httpcode == 407); + char *auth = Curl_copy_header_value(header); + if(!auth) + return CURLE_OUT_OF_MEMORY; + + CURL_TRC_CF(data, cf, "CONNECT: fwd auth header '%s'", header); + result = Curl_http_input_auth(data, proxy, auth); + + curlx_free(auth); + + if(result) + return result; + } + else if(checkprefix("Content-Length:", header)) { + if(k->httpcode / 100 == 2) { + /* A client MUST ignore any Content-Length or Transfer-Encoding + header fields received in a successful response to CONNECT. + "Successful" described as: 2xx (Successful). RFC 7231 4.3.6 */ + infof(data, "Ignoring Content-Length in CONNECT %03d response", + k->httpcode); + } + else { + const char *p = header + strlen("Content-Length:"); + if(curlx_str_numblanks(&p, &ts->cl)) { + failf(data, "Unsupported Content-Length value"); + return CURLE_WEIRD_SERVER_REPLY; + } + } + } + else if(Curl_compareheader(header, + STRCONST("Connection:"), STRCONST("close"))) + ts->close_connection = TRUE; + else if(checkprefix("Transfer-Encoding:", header)) { + if(k->httpcode / 100 == 2) { + /* A client MUST ignore any Content-Length or Transfer-Encoding + header fields received in a successful response to CONNECT. + "Successful" described as: 2xx (Successful). RFC 7231 4.3.6 */ + infof(data, "Ignoring Transfer-Encoding in " + "CONNECT %03d response", k->httpcode); + } + else if(Curl_compareheader(header, + STRCONST("Transfer-Encoding:"), + STRCONST("chunked"))) { + infof(data, "CONNECT responded chunked"); + ts->chunked_encoding = TRUE; + /* reset our chunky engine */ + Curl_httpchunk_reset(data, &ts->ch, TRUE); + } + } + else if(Curl_compareheader(header, + STRCONST("Proxy-Connection:"), + STRCONST("close"))) + ts->close_connection = TRUE; + else if(!strncmp(header, "HTTP/1.", 7) && + ((header[7] == '0') || (header[7] == '1')) && + (header[8] == ' ') && + ISDIGIT(header[9]) && ISDIGIT(header[10]) && ISDIGIT(header[11]) && + !ISDIGIT(header[12])) { + /* store the HTTP code from the proxy */ + data->info.httpproxycode = k->httpcode = ((header[9] - '0') * 100) + + ((header[10] - '0') * 10) + (header[11] - '0'); + } + return result; +} + +static CURLcode single_header(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h1_tunnel_state *ts) +{ + CURLcode result = CURLE_OK; + const char *linep = curlx_dyn_ptr(&ts->rcvbuf); + size_t line_len = curlx_dyn_len(&ts->rcvbuf); /* bytes in this line */ + const struct SingleRequest *k = &data->req; + int writetype; + ts->headerlines++; + + /* output debug if that is requested */ + Curl_debug(data, CURLINFO_HEADER_IN, linep, line_len); + + /* a CONNECT response line is handed to the client as a header, so it must + pass the same checks as a regular response header before delivery */ + result = Curl_verify_header(data, linep, line_len); + if(result) + return result; + + /* send the header to the callback */ + writetype = CLIENTWRITE_HEADER | CLIENTWRITE_CONNECT | + (ts->headerlines == 1 ? CLIENTWRITE_STATUS : 0); + result = Curl_client_write(data, writetype, linep, line_len); + if(result) + return result; + + result = Curl_bump_headersize(data, line_len, TRUE); + if(result) + return result; + + /* Newlines are CRLF, so the CR is ignored as the line is not + really terminated until the LF comes. Treat a following CR + as end-of-headers as well.*/ + + if(ISNEWLINE(linep[0])) { + /* end of response-headers from the proxy */ + + if((407 == k->httpcode) && !data->state.authproblem) { + /* If we get a 407 response code with content length + when we have no auth problem, we must ignore the + whole response-body */ + ts->keepon = KEEPON_IGNORE; + + if(ts->cl) { + infof(data, "Ignore %" FMT_OFF_T " bytes of response-body", ts->cl); + } + else if(ts->chunked_encoding) { + infof(data, "Ignore chunked response-body"); + } + else { + /* without content-length or chunked encoding, we + cannot keep the connection alive since the close is + the end signal so we bail out at once instead */ + CURL_TRC_CF(data, cf, "CONNECT: no content-length or chunked"); + ts->keepon = KEEPON_DONE; + } + } + else { + ts->keepon = KEEPON_DONE; + } + + DEBUGASSERT(ts->keepon == KEEPON_IGNORE || + ts->keepon == KEEPON_DONE); + return result; + } + + if(h1_proxy_is_udp(cf)) { + result = on_resp_header_udp(cf, data, ts, linep); + } + else { + result = on_resp_header(cf, data, ts, linep); + } + + if(result) + return result; + + curlx_dyn_reset(&ts->rcvbuf); + return result; +} + +static CURLcode recv_CONNECT_resp(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h1_tunnel_state *ts, + bool *done) +{ + CURLcode result = CURLE_OK; + int error; + +#define SELECT_OK 0 +#define SELECT_ERROR 1 + + error = SELECT_OK; + *done = FALSE; + + while(ts->keepon) { + size_t nread; + char byte; + + /* Read one byte at a time to avoid a race condition. Wait at most one + second before looping to ensure continuous pgrsUpdates. */ + result = Curl_conn_recv(data, cf->sockindex, &byte, 1, &nread); + if(result == CURLE_AGAIN) + /* socket buffer drained, return */ + return CURLE_OK; + + if(!result) + result = Curl_pgrsUpdate(data); + + if(result) { + ts->keepon = KEEPON_DONE; + break; + } + + if(!nread) { + if(ts->maybe_folded) { + /* EOF right after LF: finalize the pending header line. */ + result = single_header(cf, data, ts); + if(result) + return result; + ts->maybe_folded = FALSE; + } + if(data->set.proxyauth && data->state.authproxy.avail && + data->req.hd_proxy_auth) { + /* proxy auth was requested and there was proxy auth available, + then deem this as "mere" proxy disconnect */ + ts->close_connection = TRUE; + infof(data, "Proxy CONNECT connection closed"); + } + else { + error = SELECT_ERROR; + failf(data, "Proxy CONNECT aborted"); + } + ts->keepon = KEEPON_DONE; + break; + } + + if(ts->keepon == KEEPON_IGNORE) { + /* This means we are currently ignoring a response-body */ + if(ts->chunked_encoding) { + /* chunked-encoded body, so we need to do the chunked dance + properly to know when the end of the body is reached */ + size_t consumed = 0; + + /* now parse the chunked piece of data so that we can + properly tell when the stream ends */ + result = Curl_httpchunk_read(data, &ts->ch, &byte, 1, &consumed); + if(result) + return result; + if(Curl_httpchunk_is_done(data, &ts->ch)) { + /* we are done reading chunks! */ + infof(data, "chunk reading DONE"); + ts->keepon = KEEPON_DONE; + } + } + else if(ts->cl) { + /* A Content-Length based body: count down the counter + and make sure to break out of the loop when we are done! */ + ts->cl--; + if(ts->cl <= 0) { + ts->keepon = KEEPON_DONE; + break; + } + } + continue; + } + + if(ts->maybe_folded) { + if(ISBLANK(byte)) { + Curl_http_to_fold(&ts->rcvbuf); + ts->leading_unfold = TRUE; + } + else { + result = single_header(cf, data, ts); + if(result) + return result; + /* now handle the new byte */ + } + ts->maybe_folded = FALSE; + } + + if(ts->leading_unfold) { + if(ISBLANK(byte)) + /* skip a bit brother */ + continue; + /* non-blank, insert a space then continue the unfolding */ + if(curlx_dyn_addn(&ts->rcvbuf, " ", 1)) { + failf(data, "CONNECT response too large"); + return CURLE_RECV_ERROR; + } + ts->leading_unfold = FALSE; + } + if(curlx_dyn_addn(&ts->rcvbuf, &byte, 1)) { + failf(data, "CONNECT response too large"); + return CURLE_RECV_ERROR; + } + + /* if this is not the end of a header line then continue */ + if(byte != 0x0a) + continue; + else { + const char *linep = curlx_dyn_ptr(&ts->rcvbuf); + size_t hlen = curlx_dyn_len(&ts->rcvbuf); + if(hlen && ISNEWLINE(linep[0])) { + /* end of headers */ + result = single_header(cf, data, ts); + if(result) + return result; + } + else + ts->maybe_folded = TRUE; + } + + if(result) + return result; + } /* while there is buffer left and loop is requested */ + + if(error) + result = CURLE_RECV_ERROR; + *done = (ts->keepon == KEEPON_DONE); + if(!result && *done && + data->info.httpproxycode / 100 != 2 && + !(h1_proxy_is_udp(cf) && data->info.httpproxycode == 101)) { + /* Deal with the possibly already received authenticate + headers. 'newurl' is set to a new URL if we must loop. */ + result = Curl_http_auth_act(data); + } + return result; +} + +static CURLcode H1_CONNECT(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h1_tunnel_state *ts) +{ + struct connectdata *conn = cf->conn; + CURLcode result; + bool done; + + if(tunnel_is_established(ts)) + return CURLE_OK; + if(tunnel_is_failed(ts)) + return CURLE_RECV_ERROR; /* Need a cfilter close and new bootstrap */ + + do { + + if(Curl_timeleft_ms(data) < 0) { + failf(data, "Proxy CONNECT aborted due to timeout"); + result = CURLE_OPERATION_TIMEDOUT; + goto out; + } + + switch(ts->tunnel_state) { + case H1_TUNNEL_INIT: + /* Prepare the CONNECT request and make a first attempt to send. */ + CURL_TRC_CF(data, cf, "CONNECT start"); + result = start_CONNECT(cf, data, ts); + if(result) + goto out; + h1_tunnel_go_state(cf, ts, H1_TUNNEL_CONNECT, data); + FALLTHROUGH(); + + case H1_TUNNEL_CONNECT: + /* see that the request is completely sent */ + CURL_TRC_CF(data, cf, "CONNECT send"); + result = send_CONNECT(cf, data, ts, &done); + if(result || !done) + goto out; + h1_tunnel_go_state(cf, ts, H1_TUNNEL_RECEIVE, data); + FALLTHROUGH(); + + case H1_TUNNEL_RECEIVE: + /* read what is there */ + CURL_TRC_CF(data, cf, "CONNECT receive"); + result = recv_CONNECT_resp(cf, data, ts, &done); + if(result) + CURL_TRC_CF(data, cf, "error receiving CONNECT response: %d", + (int)result); + if(!result) + result = Curl_pgrsUpdate(data); + /* error or not complete yet. return for more multi-multi */ + if(result || !done) + goto out; + /* got it */ + h1_tunnel_go_state(cf, ts, H1_TUNNEL_RESPONSE, data); + FALLTHROUGH(); + + case H1_TUNNEL_RESPONSE: + CURL_TRC_CF(data, cf, "CONNECT response"); + if(data->req.newurl) { + /* not the "final" response, we need to do a follow up request. + * If the other side indicated a connection close, or if someone + * else told us to close this connection, do so now. + */ + Curl_req_soft_reset(&data->req, data); + if(ts->close_connection || conn->bits.close) { + /* Close this filter and the sub-chain, re-connect the + * sub-chain and continue. Closing this filter will + * reset our tunnel state. To avoid recursion, we return + * and expect to be called again. + */ + CURL_TRC_CF(data, cf, "CONNECT need to close+open"); + infof(data, "Connect me again please"); + return CURLE_AGAIN; + } + else { + /* staying on this connection, reset state */ + h1_tunnel_go_state(cf, ts, H1_TUNNEL_INIT, data); + } + } + break; + + default: + break; + } + + } while(data->req.newurl); + + DEBUGASSERT(ts->tunnel_state == H1_TUNNEL_RESPONSE); + if(h1_proxy_is_udp(cf)) { + /* RFC 9298: Accept 101 Upgrade for HTTP/1.1 and + * 2xx responses for HTTP/2 and HTTP/3 proxies. */ + if(data->info.httpproxycode / 100 != 2 && + data->info.httpproxycode != 101) { + curlx_safefree(data->req.newurl); + h1_tunnel_go_state(cf, ts, H1_TUNNEL_FAILED, data); + failf(data, "CONNECT-UDP tunnel failed, response %d", + data->req.httpcode); + return CURLE_COULDNT_CONNECT; + } + } + else { + if(data->info.httpproxycode / 100 != 2) { + /* a non-2xx response and we have no next URL to try. */ + curlx_safefree(data->req.newurl); + h1_tunnel_go_state(cf, ts, H1_TUNNEL_FAILED, data); + failf(data, "CONNECT tunnel failed, response %d", data->req.httpcode); + return CURLE_COULDNT_CONNECT; + } + } + /* 2xx response, SUCCESS! */ + /* 101 Switching Protocol for CONNECT-UDP */ + h1_tunnel_go_state(cf, ts, H1_TUNNEL_ESTABLISHED, data); + if(h1_proxy_is_udp(cf)) + infof(data, "CONNECT-UDP tunnel established, response %d", + data->info.httpproxycode); + else + infof(data, "CONNECT tunnel established, response %d", + data->info.httpproxycode); + result = CURLE_OK; + +out: + if(result) + h1_tunnel_go_state(cf, ts, H1_TUNNEL_FAILED, data); + return result; +} + +static CURLcode cf_h1_proxy_connect(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ + CURLcode result; + struct cf_h1_proxy_ctx *pctx = cf->ctx; + struct h1_tunnel_state *ts = pctx->ts; + + if(cf->connected) { + *done = TRUE; + return CURLE_OK; + } + + CURL_TRC_CF(data, cf, "connect"); + result = cf->next->cft->do_connect(cf->next, data, done); + if(result || !*done) + return result; + + *done = FALSE; + if(!ts) { + result = tunnel_init(cf, data, &ts); + if(result) + return result; + pctx->ts = ts; + } + + /* We want "seamless" operations through HTTP proxy tunnel */ + + result = H1_CONNECT(cf, data, ts); + if(result) + goto out; + curlx_safefree(data->req.hd_proxy_auth); + +out: + *done = (result == CURLE_OK) && tunnel_is_established(pctx->ts); + if(*done) { + cf->connected = TRUE; + /* The real request will follow the CONNECT, reset request partially */ + Curl_req_soft_reset(&data->req, data); + Curl_client_reset(data); + Curl_pgrsReset(data); + cf_tunnel_free(cf, data); + } + return result; +} + +static CURLcode cf_h1_proxy_adjust_pollset(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct easy_pollset *ps) +{ + struct cf_h1_proxy_ctx *pctx = cf->ctx; + struct h1_tunnel_state *ts = pctx->ts; + CURLcode result = CURLE_OK; + + if(!cf->connected) { + /* If we are not connected, but the filter "below" is + * and not waiting on something, we are tunneling. */ + curl_socket_t sock = Curl_conn_cf_get_socket(cf, data); + if(ts) { + /* when we have sent a CONNECT to a proxy, we should rather either + wait for the socket to become readable to be able to get the + response headers or if we are still sending the request, wait + for write. */ + if(tunnel_want_send(ts)) + result = Curl_pollset_set_out_only(data, ps, sock); + else + result = Curl_pollset_set_in_only(data, ps, sock); + } + else + result = Curl_pollset_set_out_only(data, ps, sock); + } + else { + if(cf->next) + result = cf->next->cft->adjust_pollset(cf->next, data, ps); + } + return result; +} + +static bool cf_h1_proxy_data_pending(struct Curl_cfilter *cf, + const struct Curl_easy *data) +{ + return cf->next ? cf->next->cft->has_data_pending(cf->next, data) : FALSE; +} + +static void cf_h1_proxy_destroy(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + CURL_TRC_CF(data, cf, "destroy"); + cf_tunnel_free(cf, data); + curlx_safefree(cf->ctx); +} + +static CURLcode cf_h1_proxy_query(struct Curl_cfilter *cf, + struct Curl_easy *data, + int query, int *pres1, void *pres2) +{ + struct cf_h1_proxy_ctx *pctx = cf->ctx; + struct h1_tunnel_state *ts = pctx ? pctx->ts : NULL; + switch(query) { + case CF_QUERY_HOST_PORT: + if(!ts || !ts->dest) + break; + *pres1 = (int)ts->dest->port; + *((const char **)pres2) = ts->dest->hostname; + return CURLE_OK; + case CF_QUERY_ALPN_NEGOTIATED: { + const char **palpn = pres2; + DEBUGASSERT(palpn); + *palpn = NULL; + return CURLE_OK; + } + default: + break; + } + return cf->next ? + cf->next->cft->query(cf->next, data, query, pres1, pres2) : + CURLE_UNKNOWN_OPTION; +} + +struct Curl_cftype Curl_cft_h1_proxy = { + "H1-PROXY", + CF_TYPE_IP_CONNECT | CF_TYPE_PROXY, + 0, + cf_h1_proxy_destroy, + cf_h1_proxy_connect, + Curl_cf_def_shutdown, + cf_h1_proxy_adjust_pollset, + cf_h1_proxy_data_pending, + Curl_cf_def_send, + Curl_cf_def_recv, + Curl_cf_def_cntrl, + Curl_cf_def_conn_is_alive, + Curl_cf_def_conn_keep_alive, + cf_h1_proxy_query, +}; + +CURLcode Curl_cf_h1_proxy_insert_after(struct Curl_cfilter *cf_at, + struct Curl_easy *data, + struct Curl_peer *dest, + int httpversion, + bool udp_tunnel) +{ + struct Curl_cfilter *cf; + struct cf_h1_proxy_ctx *pctx; + struct h1_tunnel_state *ts; + CURLcode result; + + (void)data; + if(!dest) + return CURLE_FAILED_INIT; + if((httpversion < 10) || (httpversion >= 20)) + return CURLE_FAILED_INIT; + + ts = curlx_calloc(1, sizeof(*ts)); + if(!ts) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + Curl_peer_link(&ts->dest, dest); + ts->httpversion = httpversion; + curlx_dyn_init(&ts->rcvbuf, DYN_PROXY_CONNECT_HEADERS); + curlx_dyn_init(&ts->request_data, DYN_HTTP_REQUEST); + Curl_httpchunk_init(data, &ts->ch, TRUE); + + pctx = curlx_calloc(1, sizeof(*pctx)); + if(!pctx) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + pctx->udp_tunnel = udp_tunnel; + pctx->ts = ts; + result = Curl_cf_create(&cf, &Curl_cft_h1_proxy, pctx); + if(result) { + curlx_free(pctx); + goto out; + } + ts = NULL; + Curl_conn_cf_insert_after(cf_at, cf); + +out: + tunnel_free(ts, data); + return result; +} + +#endif /* !CURL_DISABLE_PROXY && !CURL_DISABLE_HTTP */ diff --git a/3rdparty/curl-8.21.0/lib/cf-h1-proxy.h b/3rdparty/curl-8.21.0/lib/cf-h1-proxy.h new file mode 100644 index 0000000000..3255bf79f2 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/cf-h1-proxy.h @@ -0,0 +1,42 @@ +#ifndef HEADER_CURL_H1_PROXY_H +#define HEADER_CURL_H1_PROXY_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_PROXY) && !defined(CURL_DISABLE_HTTP) + +struct Curl_peer; + +CURLcode Curl_cf_h1_proxy_insert_after(struct Curl_cfilter *cf_at, + struct Curl_easy *data, + struct Curl_peer *dest, + int httpversion, + bool udp_tunnel); + +extern struct Curl_cftype Curl_cft_h1_proxy; + +#endif /* !CURL_DISABLE_PROXY && !CURL_DISABLE_HTTP */ + +#endif /* HEADER_CURL_H1_PROXY_H */ diff --git a/3rdparty/curl-8.21.0/lib/cf-h2-proxy.c b/3rdparty/curl-8.21.0/lib/cf-h2-proxy.c new file mode 100644 index 0000000000..be303ffd3e --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/cf-h2-proxy.c @@ -0,0 +1,1509 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_HTTP) && !defined(CURL_DISABLE_PROXY) && \ + defined(USE_NGHTTP2) + +#include + +#include "urldata.h" +#include "url.h" +#include "cfilters.h" +#include "connect.h" +#include "curl_trc.h" +#include "bufq.h" +#include "curlx/dynbuf.h" +#include "dynhds.h" +#include "http2.h" +#include "http_proxy.h" +#include "multiif.h" +#include "sendf.h" +#include "select.h" +#include "cf-h2-proxy.h" + +#define PROXY_H2_CHUNK_SIZE (16 * 1024) + +#define PROXY_HTTP2_HUGE_WINDOW_SIZE (100 * 1024 * 1024) +#define H2_TUNNEL_WINDOW_SIZE (10 * 1024 * 1024) + +#define PROXY_H2_NW_RECV_CHUNKS (H2_TUNNEL_WINDOW_SIZE / PROXY_H2_CHUNK_SIZE) +#define PROXY_H2_NW_SEND_CHUNKS 1 + +#define H2_TUNNEL_RECV_CHUNKS (H2_TUNNEL_WINDOW_SIZE / PROXY_H2_CHUNK_SIZE) +#define H2_TUNNEL_SEND_CHUNKS ((128 * 1024) / PROXY_H2_CHUNK_SIZE) + + +typedef enum { + H2_TUNNEL_INIT, /* init/default/no tunnel state */ + H2_TUNNEL_CONNECT, /* CONNECT request is being send */ + H2_TUNNEL_RESPONSE, /* CONNECT response received completely */ + H2_TUNNEL_ESTABLISHED, + H2_TUNNEL_FAILED +} h2_tunnel_state; + +struct tunnel_stream { + struct http_resp *resp; + struct bufq recvbuf; + struct bufq sendbuf; + char *authority; + int32_t stream_id; + uint32_t error; + h2_tunnel_state state; + BIT(has_final_response); + BIT(closed); + BIT(reset); +}; + +static CURLcode tunnel_stream_init(struct tunnel_stream *ts, + struct Curl_peer *dest) +{ + ts->state = H2_TUNNEL_INIT; + ts->stream_id = -1; + Curl_bufq_init2(&ts->recvbuf, PROXY_H2_CHUNK_SIZE, H2_TUNNEL_RECV_CHUNKS, + BUFQ_OPT_SOFT_LIMIT); + Curl_bufq_init(&ts->sendbuf, PROXY_H2_CHUNK_SIZE, H2_TUNNEL_SEND_CHUNKS); + + /* host:port with IPv6 support */ + ts->authority = curl_maprintf("%s%s%s:%u", dest->ipv6 ? "[" : "", + dest->hostname, + dest->ipv6 ? "]" : "", + dest->port); + if(!ts->authority) + return CURLE_OUT_OF_MEMORY; + + return CURLE_OK; +} + +static void tunnel_stream_reset(struct tunnel_stream *ts) +{ + Curl_http_resp_free(ts->resp); + ts->resp = NULL; + Curl_bufq_reset(&ts->recvbuf); + Curl_bufq_reset(&ts->sendbuf); + ts->stream_id = -1; + ts->error = 0; + ts->has_final_response = FALSE; + ts->closed = FALSE; + ts->reset = FALSE; + ts->state = H2_TUNNEL_INIT; +} + +static void tunnel_stream_clear(struct tunnel_stream *ts) +{ + Curl_http_resp_free(ts->resp); + Curl_bufq_free(&ts->recvbuf); + Curl_bufq_free(&ts->sendbuf); + curlx_safefree(ts->authority); + memset(ts, 0, sizeof(*ts)); + ts->state = H2_TUNNEL_INIT; +} + +static void h2_tunnel_go_state(struct Curl_cfilter *cf, + struct tunnel_stream *ts, + h2_tunnel_state new_state, + struct Curl_easy *data, + bool udp_tunnel) +{ + (void)cf; + (void)udp_tunnel; + + if(ts->state == new_state) + return; + /* leaving this one */ + switch(ts->state) { + case H2_TUNNEL_CONNECT: + data->req.ignorebody = FALSE; + break; + default: + break; + } + /* entering this one */ + switch(new_state) { + case H2_TUNNEL_INIT: + CURL_TRC_CF(data, cf, "[%d] new tunnel state 'init'", ts->stream_id); + tunnel_stream_reset(ts); + break; + + case H2_TUNNEL_CONNECT: + CURL_TRC_CF(data, cf, "[%d] new tunnel state 'connect'", ts->stream_id); + ts->state = H2_TUNNEL_CONNECT; + break; + + case H2_TUNNEL_RESPONSE: + CURL_TRC_CF(data, cf, "[%d] new tunnel state 'response'", ts->stream_id); + ts->state = H2_TUNNEL_RESPONSE; + break; + + case H2_TUNNEL_ESTABLISHED: + CURL_TRC_CF(data, cf, "[%d] new tunnel state 'established'", + ts->stream_id); + infof(data, "CONNECT%s phase completed for HTTP/2 proxy", + udp_tunnel ? "-UDP" : ""); + data->state.authproxy.done = TRUE; + data->state.authproxy.multipass = FALSE; + FALLTHROUGH(); + case H2_TUNNEL_FAILED: + if(new_state == H2_TUNNEL_FAILED) + CURL_TRC_CF(data, cf, "[%d] new tunnel state 'failed'", ts->stream_id); + ts->state = new_state; + /* If a proxy-authorization header was used for the proxy, then we should + make sure that it is not accidentally used for the document request + after we have connected. Let's thus free and clear it here. */ + curlx_safefree(data->req.hd_proxy_auth); + break; + } +} + +struct cf_h2_proxy_ctx { + nghttp2_session *h2; + /* The easy handle used in the current filter call, cleared at return */ + struct cf_call_data call_data; + + struct bufq inbufq; /* network receive buffer */ + struct bufq outbufq; /* network send buffer */ + + struct Curl_peer *dest; /* where to tunnel to */ + struct tunnel_stream tunnel; /* our tunnel CONNECT stream */ + int32_t goaway_error; + int32_t last_stream_id; + BIT(conn_closed); + BIT(rcvd_goaway); + BIT(sent_goaway); + BIT(nw_out_blocked); + BIT(udp_tunnel); +}; + +/* How to access `call_data` from a cf_h2 filter */ +#undef CF_CTX_CALL_DATA +#define CF_CTX_CALL_DATA(cf) ((struct cf_h2_proxy_ctx *)(cf)->ctx)->call_data + +static void cf_h2_proxy_ctx_clear(struct cf_h2_proxy_ctx *ctx) +{ + struct cf_call_data save = ctx->call_data; + + if(ctx->h2) { + nghttp2_session_del(ctx->h2); + } + Curl_bufq_free(&ctx->inbufq); + Curl_bufq_free(&ctx->outbufq); + Curl_peer_unlink(&ctx->dest); + tunnel_stream_clear(&ctx->tunnel); + memset(ctx, 0, sizeof(*ctx)); + ctx->call_data = save; +} + +static void cf_h2_proxy_ctx_free(struct cf_h2_proxy_ctx *ctx) +{ + if(ctx) { + cf_h2_proxy_ctx_clear(ctx); + curlx_free(ctx); + } +} + +static void drain_tunnel(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct tunnel_stream *tunnel) +{ + struct cf_h2_proxy_ctx *ctx = cf->ctx; + (void)cf; + if(!tunnel->closed && !tunnel->reset && + (!Curl_bufq_is_empty(&ctx->tunnel.sendbuf) || + !Curl_bufq_is_empty(&ctx->tunnel.recvbuf))) + Curl_multi_mark_dirty(data); +} + +static CURLcode proxy_h2_nw_out_writer(void *writer_ctx, + const uint8_t *buf, size_t buflen, + size_t *pnwritten) +{ + struct Curl_cfilter *cf = writer_ctx; + *pnwritten = 0; + if(cf) { + struct Curl_easy *data = CF_DATA_CURRENT(cf); + CURLcode result; + result = Curl_conn_cf_send(cf->next, data, buf, buflen, FALSE, pnwritten); + CURL_TRC_CF(data, cf, "[0] nw_out_writer(len=%zu) -> %d, %zu", + buflen, (int)result, *pnwritten); + return result; + } + return CURLE_FAILED_INIT; +} + +static int proxy_h2_client_new(struct Curl_cfilter *cf, + nghttp2_session_callbacks *cbs) +{ + struct cf_h2_proxy_ctx *ctx = cf->ctx; + nghttp2_option *o; + nghttp2_mem mem = { NULL, Curl_nghttp2_malloc, Curl_nghttp2_free, + Curl_nghttp2_calloc, Curl_nghttp2_realloc }; + + int rc = nghttp2_option_new(&o); + if(rc) + return rc; + /* We handle window updates ourself to enforce buffer limits */ + nghttp2_option_set_no_auto_window_update(o, 1); +#if NGHTTP2_VERSION_NUM >= 0x013200 /* with 1.50.0 */ + /* turn off RFC 9113 leading and trailing white spaces validation against + HTTP field value. */ + nghttp2_option_set_no_rfc9113_leading_and_trailing_ws_validation(o, 1); +#endif + rc = nghttp2_session_client_new3(&ctx->h2, cbs, cf, o, &mem); + nghttp2_option_del(o); + return rc; +} + +static int proxy_h2_should_close_session(struct cf_h2_proxy_ctx *ctx) +{ + return !nghttp2_session_want_read(ctx->h2) && + !nghttp2_session_want_write(ctx->h2); +} + +static CURLcode proxy_h2_nw_out_flush(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_h2_proxy_ctx *ctx = cf->ctx; + size_t nwritten; + CURLcode result; + + if(Curl_bufq_is_empty(&ctx->outbufq)) + return CURLE_OK; + + result = Curl_bufq_pass(&ctx->outbufq, proxy_h2_nw_out_writer, cf, + &nwritten); + if(result) { + if(result == CURLE_AGAIN) { + CURL_TRC_CF(data, cf, "[0] flush nw send buffer(%zu) -> EAGAIN", + Curl_bufq_len(&ctx->outbufq)); + ctx->nw_out_blocked = 1; + } + return result; + } + CURL_TRC_CF(data, cf, "[0] nw send buffer flushed"); + return Curl_bufq_is_empty(&ctx->outbufq) ? CURLE_OK : CURLE_AGAIN; +} + +/* + * Processes pending input left in network input buffer. + * This function returns 0 if it succeeds, or -1 and error code will + * be assigned to *err. + */ +static CURLcode proxy_h2_process_pending_input(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_h2_proxy_ctx *ctx = cf->ctx; + const unsigned char *buf; + size_t blen, nread; + ssize_t rv; + + while(Curl_bufq_peek(&ctx->inbufq, &buf, &blen)) { + + rv = nghttp2_session_mem_recv(ctx->h2, (const uint8_t *)buf, blen); + CURL_TRC_CF(data, cf, "[0] %zu bytes to nghttp2 -> %zd", blen, rv); + if(!curlx_sztouz(rv, &nread)) { + failf(data, + "process_pending_input: nghttp2_session_mem_recv() returned " + "%zd:%s", rv, nghttp2_strerror((int)rv)); + return CURLE_RECV_ERROR; + } + else if(!nread) { + /* nghttp2 does not want to process more, but has no error. This + * probably cannot happen, but be safe. */ + break; + } + Curl_bufq_skip(&ctx->inbufq, nread); + if(Curl_bufq_is_empty(&ctx->inbufq)) { + CURL_TRC_CF(data, cf, "[0] all data in connection buffer processed"); + break; + } + else { + CURL_TRC_CF(data, cf, "[0] process_pending_input: %zu bytes left " + "in connection buffer", Curl_bufq_len(&ctx->inbufq)); + } + } + return CURLE_OK; +} + +static CURLcode proxy_h2_progress_ingress(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_h2_proxy_ctx *ctx = cf->ctx; + CURLcode result = CURLE_OK; + size_t nread; + + /* Process network input buffer first */ + if(!Curl_bufq_is_empty(&ctx->inbufq)) { + CURL_TRC_CF(data, cf, "[0] process %zu bytes in connection buffer", + Curl_bufq_len(&ctx->inbufq)); + result = proxy_h2_process_pending_input(cf, data); + if(result) + return result; + } + + /* Receive data from the "lower" filters, e.g. network until + * it is time to stop or we have enough data for this stream */ + while(!ctx->conn_closed && /* not closed the connection */ + !ctx->tunnel.closed && /* nor the tunnel */ + Curl_bufq_is_empty(&ctx->inbufq) && /* and we consumed our input */ + !Curl_bufq_is_full(&ctx->tunnel.recvbuf)) { + + result = Curl_cf_recv_bufq(cf->next, data, &ctx->inbufq, 0, &nread); + CURL_TRC_CF(data, cf, "[0] read %zu bytes nw data -> %d, %zu", + Curl_bufq_len(&ctx->inbufq), (int)result, nread); + if(result) { + if(result != CURLE_AGAIN) { + failf(data, "Failed receiving HTTP2 proxy data"); + return result; + } + break; + } + else if(nread == 0) { + CURL_TRC_CF(data, cf, "server closed connection"); + ctx->conn_closed = TRUE; + break; + } + + result = proxy_h2_process_pending_input(cf, data); + if(result) + return result; + } + + return CURLE_OK; +} + +static CURLcode proxy_h2_progress_egress(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_h2_proxy_ctx *ctx = cf->ctx; + int rv = 0; + + ctx->nw_out_blocked = 0; + while(!rv && !ctx->nw_out_blocked && nghttp2_session_want_write(ctx->h2)) + rv = nghttp2_session_send(ctx->h2); + + if(nghttp2_is_fatal(rv)) { + CURL_TRC_CF(data, cf, "[0] nghttp2_session_send error (%s)%d", + nghttp2_strerror(rv), rv); + return CURLE_SEND_ERROR; + } + return proxy_h2_nw_out_flush(cf, data); +} + +static ssize_t on_session_send(nghttp2_session *h2, + const uint8_t *buf, size_t blen, int flags, + void *userp) +{ + struct Curl_cfilter *cf = userp; + struct cf_h2_proxy_ctx *ctx = cf->ctx; + struct Curl_easy *data = CF_DATA_CURRENT(cf); + size_t nwritten; + CURLcode result = CURLE_OK; + + (void)h2; + (void)flags; + DEBUGASSERT(data); + + result = Curl_bufq_write_pass(&ctx->outbufq, buf, blen, + proxy_h2_nw_out_writer, cf, &nwritten); + if(result) { + if(result == CURLE_AGAIN) { + ctx->nw_out_blocked = 1; + return NGHTTP2_ERR_WOULDBLOCK; + } + failf(data, "Failed sending HTTP2 data"); + return NGHTTP2_ERR_CALLBACK_FAILURE; + } + + if(!nwritten) + return NGHTTP2_ERR_WOULDBLOCK; + + return (nwritten > SSIZE_MAX) ? + NGHTTP2_ERR_CALLBACK_FAILURE : (ssize_t)nwritten; +} + +#ifdef CURLVERBOSE +static int proxy_h2_on_frame_send(nghttp2_session *session, + const nghttp2_frame *frame, + void *userp) +{ + struct Curl_cfilter *cf = userp; + struct Curl_easy *data = CF_DATA_CURRENT(cf); + + (void)session; + DEBUGASSERT(data); + if(Curl_trc_cf_is_verbose(cf, data)) { + char buffer[256]; + int len; + len = Curl_nghttp2_fr_print(frame, buffer, sizeof(buffer) - 1); + buffer[len] = 0; + CURL_TRC_CF(data, cf, "[%d] -> %s", frame->hd.stream_id, buffer); + } + return 0; +} +#endif /* CURLVERBOSE */ + +static int proxy_h2_on_frame_recv(nghttp2_session *session, + const nghttp2_frame *frame, + void *userp) +{ + struct Curl_cfilter *cf = userp; + struct cf_h2_proxy_ctx *ctx = cf->ctx; + struct Curl_easy *data = CF_DATA_CURRENT(cf); + int32_t stream_id = frame->hd.stream_id; + + (void)session; + DEBUGASSERT(data); +#ifdef CURLVERBOSE + if(Curl_trc_cf_is_verbose(cf, data)) { + char buffer[256]; + int len; + len = Curl_nghttp2_fr_print(frame, buffer, sizeof(buffer) - 1); + buffer[len] = 0; + CURL_TRC_CF(data, cf, "[%d] <- %s", frame->hd.stream_id, buffer); + } +#endif /* CURLVERBOSE */ + + if(!stream_id) { + /* stream ID zero is for connection-oriented stuff */ + DEBUGASSERT(data); + switch(frame->hd.type) { + case NGHTTP2_SETTINGS: + /* Since the initial stream window is 64K, a request might be on HOLD, + * due to exhaustion. The (initial) SETTINGS may announce a much larger + * window and *assume* that we treat this like a WINDOW_UPDATE. Some + * servers send an explicit WINDOW_UPDATE, but not all seem to do that. + * To be safe, we UNHOLD a stream in order not to stall. */ + if(CURL_REQ_WANT_SEND(data)) { + drain_tunnel(cf, data, &ctx->tunnel); + } + break; + case NGHTTP2_GOAWAY: + ctx->rcvd_goaway = TRUE; + break; + default: + break; + } + return 0; + } + + if(stream_id != ctx->tunnel.stream_id) { + CURL_TRC_CF(data, cf, "[%d] rcvd FRAME not for tunnel", stream_id); + return NGHTTP2_ERR_CALLBACK_FAILURE; + } + + switch(frame->hd.type) { + case NGHTTP2_HEADERS: + /* nghttp2 guarantees that :status is received, and we store it to + stream->status_code. Fuzzing has proven this can still be reached + without status code having been set. */ + if(!ctx->tunnel.resp) + return NGHTTP2_ERR_CALLBACK_FAILURE; + /* Only final status code signals the end of header */ + CURL_TRC_CF(data, cf, "[%d] got http status: %d", + stream_id, ctx->tunnel.resp->status); + if(!ctx->tunnel.has_final_response) { + if(ctx->tunnel.resp->status / 100 != 1) { + ctx->tunnel.has_final_response = TRUE; + } + } + break; + case NGHTTP2_WINDOW_UPDATE: + if(CURL_REQ_WANT_SEND(data)) { + drain_tunnel(cf, data, &ctx->tunnel); + } + break; + case NGHTTP2_RST_STREAM: + if(frame->rst_stream.error_code) + ctx->tunnel.reset = TRUE; + break; + default: + break; + } + return 0; +} + +static int proxy_h2_on_header(nghttp2_session *session, + const nghttp2_frame *frame, + const uint8_t *name, size_t namelen, + const uint8_t *value, size_t valuelen, + uint8_t flags, + void *userp) +{ + struct Curl_cfilter *cf = userp; + struct cf_h2_proxy_ctx *ctx = cf->ctx; + struct Curl_easy *data = CF_DATA_CURRENT(cf); + int32_t stream_id = frame->hd.stream_id; + CURLcode result; + + (void)flags; + (void)session; + DEBUGASSERT(stream_id); /* should never be a zero stream ID here */ + if(stream_id != ctx->tunnel.stream_id) { + CURL_TRC_CF(data, cf, "[%d] header for non-tunnel stream: " + "%.*s: %.*s", stream_id, + (int)namelen, name, (int)valuelen, value); + return NGHTTP2_ERR_CALLBACK_FAILURE; + } + + if(frame->hd.type == NGHTTP2_PUSH_PROMISE) + return NGHTTP2_ERR_CALLBACK_FAILURE; + + if(ctx->tunnel.has_final_response) { + /* we do not do anything with trailers for tunnel streams */ + return 0; + } + + if(namelen == sizeof(HTTP_PSEUDO_STATUS) - 1 && + !memcmp(HTTP_PSEUDO_STATUS, name, namelen)) { + int http_status; + struct http_resp *resp; + + /* status: always comes first, we might get more than one response, + * discard previous, interim responses */ + result = Curl_http_decode_status(&http_status, + (const char *)value, valuelen); + if(result) + return NGHTTP2_ERR_CALLBACK_FAILURE; + result = Curl_http_resp_make(&resp, http_status, NULL); + if(result) + return NGHTTP2_ERR_CALLBACK_FAILURE; + if(ctx->tunnel.resp) + Curl_http_resp_free(ctx->tunnel.resp); + ctx->tunnel.resp = resp; + CURL_TRC_CF(data, cf, "[%d] status: HTTP/2 %03d", + stream_id, ctx->tunnel.resp->status); + return 0; + } + + if(!ctx->tunnel.resp) + return NGHTTP2_ERR_CALLBACK_FAILURE; + + result = Curl_dynhds_add(&ctx->tunnel.resp->headers, + (const char *)name, namelen, + (const char *)value, valuelen); + if(result) + return NGHTTP2_ERR_CALLBACK_FAILURE; + + CURL_TRC_CF(data, cf, "[%d] header: %.*s: %.*s", + stream_id, (int)namelen, name, (int)valuelen, value); + + return 0; /* 0 is successful */ +} + +static ssize_t tunnel_send_callback(nghttp2_session *session, + int32_t stream_id, + uint8_t *buf, size_t length, + uint32_t *data_flags, + nghttp2_data_source *source, + void *userp) +{ + struct Curl_cfilter *cf = userp; + struct cf_h2_proxy_ctx *ctx = cf->ctx; + struct Curl_easy *data = CF_DATA_CURRENT(cf); + struct tunnel_stream *ts; + CURLcode result; + size_t nread; + + (void)source; + (void)ctx; + + if(!stream_id) + return NGHTTP2_ERR_INVALID_ARGUMENT; + + ts = nghttp2_session_get_stream_user_data(session, stream_id); + if(!ts) + return NGHTTP2_ERR_CALLBACK_FAILURE; + DEBUGASSERT(ts == &ctx->tunnel); + + result = Curl_bufq_read(&ts->sendbuf, buf, length, &nread); + if(result) { + if(result != CURLE_AGAIN) + return NGHTTP2_ERR_CALLBACK_FAILURE; + return NGHTTP2_ERR_DEFERRED; + } + if(ts->closed && Curl_bufq_is_empty(&ts->sendbuf)) + *data_flags = NGHTTP2_DATA_FLAG_EOF; + + CURL_TRC_CF(data, cf, "[%d] tunnel_send_callback -> %zu", + ts->stream_id, nread); + return (nread > SSIZE_MAX) ? + NGHTTP2_ERR_CALLBACK_FAILURE : (ssize_t)nread; +} + +static int tunnel_recv_callback(nghttp2_session *session, uint8_t flags, + int32_t stream_id, + const uint8_t *mem, size_t len, void *userp) +{ + struct Curl_cfilter *cf = userp; + struct cf_h2_proxy_ctx *ctx = cf->ctx; + size_t nwritten; + CURLcode result; + + (void)flags; + (void)session; + DEBUGASSERT(stream_id); /* should never be a zero stream ID here */ + + if(stream_id != ctx->tunnel.stream_id) + return NGHTTP2_ERR_CALLBACK_FAILURE; + + result = Curl_bufq_write(&ctx->tunnel.recvbuf, mem, len, &nwritten); + if(result) { + if(result != CURLE_AGAIN) + return NGHTTP2_ERR_CALLBACK_FAILURE; +#ifdef DEBUGBUILD + nwritten = 0; +#endif + } + /* tunnel.recbuf has soft limit, any success MUST add all data */ + DEBUGASSERT(nwritten == len); + return 0; +} + +static int proxy_h2_on_stream_close(nghttp2_session *session, + int32_t stream_id, + uint32_t error_code, void *userp) +{ + struct Curl_cfilter *cf = userp; + struct cf_h2_proxy_ctx *ctx = cf->ctx; + struct Curl_easy *data = CF_DATA_CURRENT(cf); + + (void)session; + + if(stream_id != ctx->tunnel.stream_id) + return 0; + + CURL_TRC_CF(data, cf, "[%d] proxy_h2_on_stream_close, %s (err %u)", + stream_id, nghttp2_http2_strerror(error_code), error_code); + ctx->tunnel.closed = TRUE; + ctx->tunnel.error = error_code; + if(error_code) + ctx->tunnel.reset = TRUE; + + return 0; +} + +static CURLcode proxy_h2_submit( + int32_t *pstream_id, + struct Curl_cfilter *cf, + struct Curl_easy *data, + nghttp2_session *h2, + struct httpreq *req, + const nghttp2_priority_spec *pri_spec, + void *stream_user_data, + nghttp2_data_source_read_callback read_callback, + void *read_ctx) +{ + struct dynhds h2_headers; + nghttp2_nv *nva = NULL; + int32_t stream_id = -1; + size_t nheader; + CURLcode result; + + (void)cf; + Curl_dynhds_init(&h2_headers, 0, DYN_HTTP_REQUEST); + result = Curl_http_req_to_h2(&h2_headers, req, data); + if(result) + goto out; + + nva = Curl_dynhds_to_nva(&h2_headers, &nheader); + if(!nva) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + if(read_callback) { + nghttp2_data_provider data_prd; + + data_prd.read_callback = read_callback; + data_prd.source.ptr = read_ctx; + stream_id = nghttp2_submit_request(h2, pri_spec, nva, nheader, + &data_prd, stream_user_data); + } + else { + stream_id = nghttp2_submit_request(h2, pri_spec, nva, nheader, + NULL, stream_user_data); + } + + if(stream_id < 0) { + failf(data, "nghttp2_session_upgrade2() failed: %s(%d)", + nghttp2_strerror(stream_id), stream_id); + result = CURLE_SEND_ERROR; + goto out; + } + result = CURLE_OK; + +out: + curlx_free(nva); + Curl_dynhds_free(&h2_headers); + *pstream_id = stream_id; + return result; +} + +static CURLcode submit_CONNECT(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct tunnel_stream *ts) +{ + struct cf_h2_proxy_ctx *ctx = cf->ctx; + CURLcode result; + struct httpreq *req = NULL; + + result = Curl_http_proxy_create_tunnel_request(&req, cf, data, ctx->dest, + PROXY_HTTP_V2, + (bool)ctx->udp_tunnel); + if(result) + goto out; + result = Curl_creader_set_null(data); + if(result) + goto out; + + result = proxy_h2_submit(&ts->stream_id, cf, data, ctx->h2, req, + NULL, ts, tunnel_send_callback, cf); + if(result) { + CURL_TRC_CF(data, cf, "[%d] send, nghttp2_submit_request error: %s", + ts->stream_id, nghttp2_strerror(ts->stream_id)); + } + +out: + if(req) + Curl_http_req_free(req); + if(result) + failf(data, "Failed sending CONNECT to proxy"); + return result; +} + +static CURLcode inspect_response(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct tunnel_stream *ts) +{ + struct cf_h2_proxy_ctx *ctx = cf->ctx; + proxy_inspect_result res; + CURLcode result; + + result = Curl_http_proxy_inspect_tunnel_response( + cf, data, ts->resp, (bool)ctx->udp_tunnel, &res); + if(result) + return result; + switch(res) { + case PROXY_INSPECT_OK: + h2_tunnel_go_state(cf, ts, H2_TUNNEL_ESTABLISHED, data, + (bool)ctx->udp_tunnel); + break; + case PROXY_INSPECT_FAILED: + h2_tunnel_go_state(cf, ts, H2_TUNNEL_FAILED, data, + (bool)ctx->udp_tunnel); + result = CURLE_COULDNT_CONNECT; + break; + case PROXY_INSPECT_AUTH_RETRY: + h2_tunnel_go_state(cf, ts, H2_TUNNEL_INIT, data, + (bool)ctx->udp_tunnel); + break; + } + return result; +} + +static CURLcode H2_CONNECT(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct tunnel_stream *ts) +{ + struct cf_h2_proxy_ctx *ctx = cf->ctx; + CURLcode result = CURLE_OK; + + DEBUGASSERT(ts); + DEBUGASSERT(ts->authority); + if(ctx->conn_closed) { + failf(data, "proxy closed connection"); + return CURLE_COULDNT_CONNECT; + } + + do { + switch(ts->state) { + case H2_TUNNEL_INIT: + /* Prepare the CONNECT request and make a first attempt to send. */ + CURL_TRC_CF(data, cf, "[0] CONNECT start for %s", ts->authority); + result = submit_CONNECT(cf, data, ts); + if(result) + goto out; + h2_tunnel_go_state(cf, ts, H2_TUNNEL_CONNECT, data, + (bool)ctx->udp_tunnel); + FALLTHROUGH(); + + case H2_TUNNEL_CONNECT: + /* see that the request is completely sent */ + result = proxy_h2_progress_ingress(cf, data); + if(!result) + result = proxy_h2_progress_egress(cf, data); + if(result && result != CURLE_AGAIN) { + h2_tunnel_go_state(cf, ts, H2_TUNNEL_FAILED, data, + (bool)ctx->udp_tunnel); + break; + } + + if(ts->has_final_response) { + h2_tunnel_go_state(cf, ts, H2_TUNNEL_RESPONSE, data, + (bool)ctx->udp_tunnel); + } + else { + result = CURLE_OK; + goto out; + } + FALLTHROUGH(); + + case H2_TUNNEL_RESPONSE: + DEBUGASSERT(ts->has_final_response); + result = inspect_response(cf, data, ts); + if(result) + goto out; + break; + + case H2_TUNNEL_ESTABLISHED: + return CURLE_OK; + + case H2_TUNNEL_FAILED: + return CURLE_RECV_ERROR; + + default: + break; + } + + } while(ts->state == H2_TUNNEL_INIT); + +out: + if((result && (result != CURLE_AGAIN)) || ctx->tunnel.closed) + h2_tunnel_go_state(cf, ts, H2_TUNNEL_FAILED, data, + (bool)ctx->udp_tunnel); + return result; +} + +/* + * Initialize the cfilter context + */ +static CURLcode cf_h2_proxy_ctx_init(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_h2_proxy_ctx *ctx = cf->ctx; + CURLcode result = CURLE_OUT_OF_MEMORY; + nghttp2_session_callbacks *cbs = NULL; + int rc; + + DEBUGASSERT(!ctx->h2); + memset(&ctx->tunnel, 0, sizeof(ctx->tunnel)); + + Curl_bufq_init(&ctx->inbufq, PROXY_H2_CHUNK_SIZE, PROXY_H2_NW_RECV_CHUNKS); + Curl_bufq_init(&ctx->outbufq, PROXY_H2_CHUNK_SIZE, PROXY_H2_NW_SEND_CHUNKS); + + if(tunnel_stream_init(&ctx->tunnel, ctx->dest)) + goto out; + + rc = nghttp2_session_callbacks_new(&cbs); + if(rc) { + failf(data, "Could not initialize nghttp2 callbacks"); + goto out; + } + + nghttp2_session_callbacks_set_send_callback(cbs, on_session_send); + nghttp2_session_callbacks_set_on_frame_recv_callback( + cbs, proxy_h2_on_frame_recv); +#ifdef CURLVERBOSE + nghttp2_session_callbacks_set_on_frame_send_callback(cbs, + proxy_h2_on_frame_send); +#endif + nghttp2_session_callbacks_set_on_data_chunk_recv_callback( + cbs, tunnel_recv_callback); + nghttp2_session_callbacks_set_on_stream_close_callback( + cbs, proxy_h2_on_stream_close); + nghttp2_session_callbacks_set_on_header_callback(cbs, proxy_h2_on_header); + + /* The nghttp2 session is not yet setup, do it */ + rc = proxy_h2_client_new(cf, cbs); + if(rc) { + failf(data, "Could not initialize nghttp2"); + goto out; + } + + { + nghttp2_settings_entry iv[3]; + + iv[0].settings_id = NGHTTP2_SETTINGS_MAX_CONCURRENT_STREAMS; + iv[0].value = Curl_multi_max_concurrent_streams(data->multi); + iv[1].settings_id = NGHTTP2_SETTINGS_INITIAL_WINDOW_SIZE; + iv[1].value = H2_TUNNEL_WINDOW_SIZE; + iv[2].settings_id = NGHTTP2_SETTINGS_ENABLE_PUSH; + iv[2].value = 0; + rc = nghttp2_submit_settings(ctx->h2, NGHTTP2_FLAG_NONE, iv, 3); + if(rc) { + failf(data, "nghttp2_submit_settings() failed: %s(%d)", + nghttp2_strerror(rc), rc); + result = CURLE_HTTP2; + goto out; + } + } + + rc = nghttp2_session_set_local_window_size(ctx->h2, NGHTTP2_FLAG_NONE, 0, + PROXY_HTTP2_HUGE_WINDOW_SIZE); + if(rc) { + failf(data, "nghttp2_session_set_local_window_size() failed: %s(%d)", + nghttp2_strerror(rc), rc); + result = CURLE_HTTP2; + goto out; + } + + /* all set, traffic will be send on connect */ + result = CURLE_OK; + +out: + if(cbs) + nghttp2_session_callbacks_del(cbs); + CURL_TRC_CF(data, cf, "[0] init proxy ctx -> %d", (int)result); + return result; +} + +static CURLcode cf_h2_proxy_connect(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ + struct cf_h2_proxy_ctx *ctx = cf->ctx; + CURLcode result = CURLE_OK; + struct cf_call_data save; + struct tunnel_stream *ts = &ctx->tunnel; + + if(cf->connected) { + *done = TRUE; + return CURLE_OK; + } + + /* Connect the lower filters first */ + if(!cf->next->connected) { + result = Curl_conn_cf_connect(cf->next, data, done); + if(result || !*done) + return result; + } + + *done = FALSE; + + CF_DATA_SAVE(save, cf, data); + if(!ctx->h2) { + result = cf_h2_proxy_ctx_init(cf, data); + if(result) + goto out; + } + DEBUGASSERT(ts->authority); + + if(Curl_timeleft_ms(data) < 0) { + failf(data, "Proxy CONNECT aborted due to timeout"); + result = CURLE_OPERATION_TIMEDOUT; + goto out; + } + + /* for the secondary socket (FTP), use the "connect to host" + * but ignore the "connect to port" (use the secondary port) + */ + result = H2_CONNECT(cf, data, ts); + +out: + *done = (result == CURLE_OK) && (ts->state == H2_TUNNEL_ESTABLISHED); + if(*done) { + cf->connected = TRUE; + /* The real request will follow the CONNECT, reset request partially */ + Curl_req_soft_reset(&data->req, data); + Curl_client_reset(data); + } + CF_DATA_RESTORE(cf, save); + return result; +} + +static void cf_h2_proxy_destroy(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_h2_proxy_ctx *ctx = cf->ctx; + + (void)data; + if(ctx) { + cf_h2_proxy_ctx_free(ctx); + cf->ctx = NULL; + } +} + +static CURLcode cf_h2_proxy_shutdown(struct Curl_cfilter *cf, + struct Curl_easy *data, bool *done) +{ + struct cf_h2_proxy_ctx *ctx = cf->ctx; + struct cf_call_data save; + CURLcode result; + int rv; + + if(!cf->connected || !ctx->h2 || cf->shutdown || ctx->conn_closed) { + *done = TRUE; + return CURLE_OK; + } + + CF_DATA_SAVE(save, cf, data); + + if(!ctx->sent_goaway) { + rv = nghttp2_submit_goaway(ctx->h2, NGHTTP2_FLAG_NONE, + 0, 0, + (const uint8_t *)"shutdown", + sizeof("shutdown")); + if(rv) { + failf(data, "nghttp2_submit_goaway() failed: %s(%d)", + nghttp2_strerror(rv), rv); + result = CURLE_SEND_ERROR; + goto out; + } + ctx->sent_goaway = TRUE; + } + /* GOAWAY submitted, process egress and ingress until nghttp2 is done. */ + result = CURLE_OK; + if(nghttp2_session_want_write(ctx->h2)) + result = proxy_h2_progress_egress(cf, data); + if(!result && nghttp2_session_want_read(ctx->h2)) + result = proxy_h2_progress_ingress(cf, data); + + *done = (ctx->conn_closed || + (!result && !nghttp2_session_want_write(ctx->h2) && + !nghttp2_session_want_read(ctx->h2))); +out: + CF_DATA_RESTORE(cf, save); + cf->shutdown = (result || *done); + return result; +} + +static bool cf_h2_proxy_data_pending(struct Curl_cfilter *cf, + const struct Curl_easy *data) +{ + struct cf_h2_proxy_ctx *ctx = cf->ctx; + if((ctx && !Curl_bufq_is_empty(&ctx->inbufq)) || + (ctx && ctx->tunnel.state == H2_TUNNEL_ESTABLISHED && + !Curl_bufq_is_empty(&ctx->tunnel.recvbuf))) + return TRUE; + return cf->next ? cf->next->cft->has_data_pending(cf->next, data) : FALSE; +} + +static CURLcode cf_h2_proxy_adjust_pollset(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct easy_pollset *ps) +{ + struct cf_h2_proxy_ctx *ctx = cf->ctx; + struct cf_call_data save; + curl_socket_t sock = Curl_conn_cf_get_socket(cf, data); + bool want_recv, want_send; + CURLcode result = CURLE_OK; + + if(!cf->connected && ctx->h2) { + want_send = nghttp2_session_want_write(ctx->h2) || + !Curl_bufq_is_empty(&ctx->outbufq) || + !Curl_bufq_is_empty(&ctx->tunnel.sendbuf); + want_recv = nghttp2_session_want_read(ctx->h2); + } + else + Curl_pollset_check(data, ps, sock, &want_recv, &want_send); + + if(ctx->h2 && (want_recv || want_send)) { + bool c_exhaust, s_exhaust; + + CF_DATA_SAVE(save, cf, data); + c_exhaust = !nghttp2_session_get_remote_window_size(ctx->h2); + s_exhaust = ctx->tunnel.stream_id >= 0 && + !nghttp2_session_get_stream_remote_window_size( + ctx->h2, ctx->tunnel.stream_id); + want_recv = (want_recv || c_exhaust || s_exhaust); + want_send = (!s_exhaust && want_send) || + (!c_exhaust && nghttp2_session_want_write(ctx->h2)) || + !Curl_bufq_is_empty(&ctx->outbufq) || + !Curl_bufq_is_empty(&ctx->tunnel.sendbuf); + + result = Curl_pollset_set(data, ps, sock, want_recv, want_send); + CURL_TRC_CF(data, cf, "adjust_pollset, want_recv=%d want_send=%d -> %d", + want_recv, want_send, (int)result); + CF_DATA_RESTORE(cf, save); + } + else if(ctx->sent_goaway && !cf->shutdown) { + /* shutdown in progress */ + CF_DATA_SAVE(save, cf, data); + want_send = nghttp2_session_want_write(ctx->h2) || + !Curl_bufq_is_empty(&ctx->outbufq) || + !Curl_bufq_is_empty(&ctx->tunnel.sendbuf); + want_recv = nghttp2_session_want_read(ctx->h2); + result = Curl_pollset_set(data, ps, sock, want_recv, want_send); + CURL_TRC_CF(data, cf, "adjust_pollset, want_recv=%d want_send=%d -> %d", + want_recv, want_send, (int)result); + CF_DATA_RESTORE(cf, save); + } + return result; +} + +static CURLcode h2_handle_tunnel_close(struct Curl_cfilter *cf, + struct Curl_easy *data, + size_t *pnread) +{ + struct cf_h2_proxy_ctx *ctx = cf->ctx; + + *pnread = 0; + if(ctx->tunnel.error) { + failf(data, "HTTP/2 stream %d reset by %s (error 0x%x %s)", + ctx->tunnel.stream_id, ctx->tunnel.reset ? "server" : "curl", + ctx->tunnel.error, nghttp2_http2_strerror(ctx->tunnel.error)); + return CURLE_RECV_ERROR; + } + + CURL_TRC_CF(data, cf, "[%d] handle_tunnel_close -> 0", + ctx->tunnel.stream_id); + return CURLE_OK; +} + +static CURLcode tunnel_recv(struct Curl_cfilter *cf, struct Curl_easy *data, + char *buf, size_t len, size_t *pnread) +{ + struct cf_h2_proxy_ctx *ctx = cf->ctx; + CURLcode result = CURLE_AGAIN; + + *pnread = 0; + if(!Curl_bufq_is_empty(&ctx->tunnel.recvbuf)) + result = Curl_bufq_cread(&ctx->tunnel.recvbuf, buf, len, pnread); + else { + if(ctx->tunnel.closed) { + result = h2_handle_tunnel_close(cf, data, pnread); + } + else if(ctx->tunnel.reset || + (ctx->conn_closed && Curl_bufq_is_empty(&ctx->inbufq)) || + (ctx->rcvd_goaway && + ctx->last_stream_id < ctx->tunnel.stream_id)) { + result = CURLE_RECV_ERROR; + } + else + result = CURLE_AGAIN; + } + + CURL_TRC_CF(data, cf, "[%d] tunnel_recv(len=%zu) -> %d, %zu", + ctx->tunnel.stream_id, len, (int)result, *pnread); + return result; +} + +static CURLcode cf_h2_proxy_recv(struct Curl_cfilter *cf, + struct Curl_easy *data, + char *buf, size_t len, + size_t *pnread) +{ + struct cf_h2_proxy_ctx *ctx = cf->ctx; + struct cf_call_data save; + CURLcode result; + + *pnread = 0; + CF_DATA_SAVE(save, cf, data); + + if(ctx->tunnel.state != H2_TUNNEL_ESTABLISHED) { + result = CURLE_RECV_ERROR; + goto out; + } + + if(Curl_bufq_is_empty(&ctx->tunnel.recvbuf)) { + result = proxy_h2_progress_ingress(cf, data); + if(result) + goto out; + } + + result = tunnel_recv(cf, data, buf, len, pnread); + + if(!result) { + CURL_TRC_CF(data, cf, "[%d] increase window by %zu", + ctx->tunnel.stream_id, *pnread); + nghttp2_session_consume(ctx->h2, ctx->tunnel.stream_id, *pnread); + } + + result = Curl_1st_fatal(result, proxy_h2_progress_egress(cf, data)); + +out: + if((!Curl_bufq_is_empty(&ctx->tunnel.recvbuf) || + !Curl_bufq_is_empty(&ctx->tunnel.sendbuf)) && + (!result || (result == CURLE_AGAIN))) { + /* data pending and no fatal error to report. Need to trigger + * draining to avoid stalling when no socket events happen. */ + drain_tunnel(cf, data, &ctx->tunnel); + } + CURL_TRC_CF(data, cf, "[%d] cf_recv(len=%zu) -> %d, %zu", + ctx->tunnel.stream_id, len, (int)result, *pnread); + CF_DATA_RESTORE(cf, save); + return result; +} + +static CURLcode cf_h2_proxy_send(struct Curl_cfilter *cf, + struct Curl_easy *data, + const uint8_t *buf, size_t len, bool eos, + size_t *pnwritten) +{ + struct cf_h2_proxy_ctx *ctx = cf->ctx; + struct cf_call_data save; + int rv; + CURLcode result; + + (void)eos; + *pnwritten = 0; + CF_DATA_SAVE(save, cf, data); + + if(ctx->tunnel.state != H2_TUNNEL_ESTABLISHED) { + result = CURLE_SEND_ERROR; + goto out; + } + + if(ctx->tunnel.closed) { + result = CURLE_SEND_ERROR; + goto out; + } + + result = Curl_bufq_write(&ctx->tunnel.sendbuf, buf, len, pnwritten); + CURL_TRC_CF(data, cf, "cf_send(), bufq_write %d, %zu", (int)result, + *pnwritten); + if(result && (result != CURLE_AGAIN)) + goto out; + + if(!Curl_bufq_is_empty(&ctx->tunnel.sendbuf)) { + /* req body data is buffered, resume the potentially suspended stream */ + rv = nghttp2_session_resume_data(ctx->h2, ctx->tunnel.stream_id); + if(nghttp2_is_fatal(rv)) { + result = CURLE_SEND_ERROR; + goto out; + } + } + + result = Curl_1st_fatal(result, proxy_h2_progress_ingress(cf, data)); + result = Curl_1st_fatal(result, proxy_h2_progress_egress(cf, data)); + + if(!result && proxy_h2_should_close_session(ctx)) { + /* nghttp2 thinks this session is done. If the stream has not been + * closed, this is an error state for out transfer */ + if(ctx->tunnel.closed) { + result = CURLE_SEND_ERROR; + } + else { + CURL_TRC_CF(data, cf, "[0] send: nothing to do in this session"); + result = CURLE_HTTP2; + } + } + +out: + if((!Curl_bufq_is_empty(&ctx->tunnel.recvbuf) || + !Curl_bufq_is_empty(&ctx->tunnel.sendbuf)) && + (!result || (result == CURLE_AGAIN))) { + /* data pending and no fatal error to report. Need to trigger + * draining to avoid stalling when no socket events happen. */ + drain_tunnel(cf, data, &ctx->tunnel); + } + CURL_TRC_CF(data, cf, "[%d] cf_send(len=%zu) -> %d, %zu, " + "h2 windows %d-%d (stream-conn), buffers %zu-%zu (stream-conn)", + ctx->tunnel.stream_id, len, (int)result, *pnwritten, + nghttp2_session_get_stream_remote_window_size( + ctx->h2, ctx->tunnel.stream_id), + nghttp2_session_get_remote_window_size(ctx->h2), + Curl_bufq_len(&ctx->tunnel.sendbuf), + Curl_bufq_len(&ctx->outbufq)); + CF_DATA_RESTORE(cf, save); + return result; +} + +static CURLcode cf_h2_proxy_flush(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_h2_proxy_ctx *ctx = cf->ctx; + struct cf_call_data save; + CURLcode result = CURLE_OK; + + CF_DATA_SAVE(save, cf, data); + if(!Curl_bufq_is_empty(&ctx->tunnel.sendbuf)) { + /* resume the potentially suspended tunnel */ + int rv = nghttp2_session_resume_data(ctx->h2, ctx->tunnel.stream_id); + if(nghttp2_is_fatal(rv)) { + result = CURLE_SEND_ERROR; + goto out; + } + } + + result = proxy_h2_progress_egress(cf, data); + +out: + CURL_TRC_CF(data, cf, "[%d] flush -> %d, " + "h2 windows %d-%d (stream-conn), buffers %zu-%zu (stream-conn)", + ctx->tunnel.stream_id, (int)result, + nghttp2_session_get_stream_remote_window_size( + ctx->h2, ctx->tunnel.stream_id), + nghttp2_session_get_remote_window_size(ctx->h2), + Curl_bufq_len(&ctx->tunnel.sendbuf), + Curl_bufq_len(&ctx->outbufq)); + CF_DATA_RESTORE(cf, save); + return result; +} + +static bool proxy_h2_connisalive(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *input_pending) +{ + struct cf_h2_proxy_ctx *ctx = cf->ctx; + bool alive = TRUE; + + *input_pending = FALSE; + if(!cf->next || !cf->next->cft->is_alive(cf->next, data, input_pending)) + return FALSE; + + if(*input_pending) { + /* This happens before we have sent off a request and the connection is + not in use by any other transfer, there should not be any data here, + only "protocol frames" */ + CURLcode result; + size_t nread; + + *input_pending = FALSE; + result = Curl_cf_recv_bufq(cf->next, data, &ctx->inbufq, 0, &nread); + if(!result) { + if(proxy_h2_process_pending_input(cf, data)) + /* immediate error, considered dead */ + alive = FALSE; + else { + alive = !proxy_h2_should_close_session(ctx); + } + } + else if(result != CURLE_AGAIN) { + /* the read failed so let's say this is dead anyway */ + alive = FALSE; + } + } + + return alive; +} + +static bool cf_h2_proxy_is_alive(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *input_pending) +{ + struct cf_h2_proxy_ctx *ctx = cf->ctx; + bool alive; + struct cf_call_data save; + + *input_pending = FALSE; + CF_DATA_SAVE(save, cf, data); + alive = (ctx && ctx->h2 && proxy_h2_connisalive(cf, data, input_pending)); + CURL_TRC_CF(data, cf, "[0] conn alive -> %d, input_pending=%d", + alive, *input_pending); + CF_DATA_RESTORE(cf, save); + return alive; +} + +static CURLcode cf_h2_proxy_query(struct Curl_cfilter *cf, + struct Curl_easy *data, + int query, int *pres1, void *pres2) +{ + struct cf_h2_proxy_ctx *ctx = cf->ctx; + + switch(query) { + case CF_QUERY_HOST_PORT: + *pres1 = (int)ctx->dest->port; + *((const char **)pres2) = ctx->dest->hostname; + return CURLE_OK; + case CF_QUERY_NEED_FLUSH: { + if(!Curl_bufq_is_empty(&ctx->outbufq) || + !Curl_bufq_is_empty(&ctx->tunnel.sendbuf)) { + CURL_TRC_CF(data, cf, "needs flush"); + *pres1 = TRUE; + return CURLE_OK; + } + break; + } + case CF_QUERY_ALPN_NEGOTIATED: { + const char **palpn = pres2; + DEBUGASSERT(palpn); + *palpn = NULL; + return CURLE_OK; + } + default: + break; + } + return cf->next ? + cf->next->cft->query(cf->next, data, query, pres1, pres2) : + CURLE_UNKNOWN_OPTION; +} + +static CURLcode cf_h2_proxy_cntrl(struct Curl_cfilter *cf, + struct Curl_easy *data, + int event, int arg1, void *arg2) +{ + CURLcode result = CURLE_OK; + struct cf_call_data save; + + (void)arg1; + (void)arg2; + + switch(event) { + case CF_CTRL_FLUSH: + CF_DATA_SAVE(save, cf, data); + result = cf_h2_proxy_flush(cf, data); + CF_DATA_RESTORE(cf, save); + break; + default: + break; + } + return result; +} + +struct Curl_cftype Curl_cft_h2_proxy = { + "H2-PROXY", + CF_TYPE_IP_CONNECT | CF_TYPE_PROXY, + CURL_LOG_LVL_NONE, + cf_h2_proxy_destroy, + cf_h2_proxy_connect, + cf_h2_proxy_shutdown, + cf_h2_proxy_adjust_pollset, + cf_h2_proxy_data_pending, + cf_h2_proxy_send, + cf_h2_proxy_recv, + cf_h2_proxy_cntrl, + cf_h2_proxy_is_alive, + Curl_cf_def_conn_keep_alive, + cf_h2_proxy_query, +}; + +CURLcode Curl_cf_h2_proxy_insert_after(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct Curl_peer *dest, + bool udp_tunnel) +{ + struct Curl_cfilter *cf_h2_proxy = NULL; + struct cf_h2_proxy_ctx *ctx; + CURLcode result = CURLE_OUT_OF_MEMORY; + + (void)data; + ctx = curlx_calloc(1, sizeof(*ctx)); + if(!ctx) + goto out; + Curl_peer_link(&ctx->dest, dest); + ctx->udp_tunnel = udp_tunnel; + + result = Curl_cf_create(&cf_h2_proxy, &Curl_cft_h2_proxy, ctx); + if(result) + goto out; + ctx = NULL; + Curl_conn_cf_insert_after(cf, cf_h2_proxy); + +out: + cf_h2_proxy_ctx_free(ctx); + return result; +} + +#endif /* !CURL_DISABLE_HTTP && !CURL_DISABLE_PROXY && USE_NGHTTP2 */ diff --git a/3rdparty/curl-8.21.0/lib/cf-h2-proxy.h b/3rdparty/curl-8.21.0/lib/cf-h2-proxy.h new file mode 100644 index 0000000000..07e3c9aedf --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/cf-h2-proxy.h @@ -0,0 +1,39 @@ +#ifndef HEADER_CURL_H2_PROXY_H +#define HEADER_CURL_H2_PROXY_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if defined(USE_NGHTTP2) && !defined(CURL_DISABLE_PROXY) + +CURLcode Curl_cf_h2_proxy_insert_after(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct Curl_peer *dest, + bool udp_tunnel); + +extern struct Curl_cftype Curl_cft_h2_proxy; + +#endif /* USE_NGHTTP2 && !CURL_DISABLE_PROXY */ + +#endif /* HEADER_CURL_H2_PROXY_H */ diff --git a/3rdparty/curl-8.21.0/lib/cf-haproxy.c b/3rdparty/curl-8.21.0/lib/cf-haproxy.c new file mode 100644 index 0000000000..16ee25066c --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/cf-haproxy.c @@ -0,0 +1,241 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifndef CURL_DISABLE_PROXY + +#include "urldata.h" +#include "cfilters.h" +#include "cf-haproxy.h" +#include "connect.h" +#include "curl_addrinfo.h" +#include "curl_trc.h" +#include "select.h" + + +typedef enum { + HAPROXY_INIT, /* init/default/no tunnel state */ + HAPROXY_SEND, /* data_out being sent */ + HAPROXY_DONE /* all work done */ +} haproxy_state; + +struct cf_haproxy_ctx { + int state; + struct dynbuf data_out; +}; + +static void cf_haproxy_ctx_free(struct cf_haproxy_ctx *ctx) +{ + if(ctx) { + curlx_dyn_free(&ctx->data_out); + curlx_free(ctx); + } +} + +static CURLcode cf_haproxy_date_out_set(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + /* We fake a client connection report to the upstream server + * with the HAProxy protocol, reporting the client's source + * and destination IP addresses and ports. + * addresses: either the ones used to talk to the upstream + * OR the value supplied by the user + * ports: the ports used in the upstream connection */ + const char *client_source_ip; + const char *client_dest_ip; + struct cf_haproxy_ctx *ctx = cf->ctx; + CURLcode result; + struct ip_quadruple ipquad; + bool is_ipv6; + + DEBUGASSERT(ctx); + DEBUGASSERT(ctx->state == HAPROXY_INIT); +#ifdef USE_UNIX_SOCKETS + if(Curl_conn_get_first_peer(cf->conn, cf->sockindex)->unix_socket) + /* the buffer is large enough to hold this! */ + result = curlx_dyn_addn(&ctx->data_out, STRCONST("PROXY UNKNOWN\r\n")); + else { +#endif /* USE_UNIX_SOCKETS */ + result = Curl_conn_cf_get_ip_info(cf->next, data, &is_ipv6, &ipquad); + if(result) + return result; + + if(data->set.str[STRING_HAPROXY_CLIENT_IP]) { + client_source_ip = data->set.str[STRING_HAPROXY_CLIENT_IP]; + client_dest_ip = client_source_ip; + is_ipv6 = !Curl_is_ipv4addr(client_source_ip); + } + else { + client_source_ip = ipquad.local_ip; + client_dest_ip = ipquad.remote_ip; + } + + result = curlx_dyn_addf(&ctx->data_out, "PROXY %s %s %s %d %d\r\n", + is_ipv6 ? "TCP6" : "TCP4", + client_source_ip, client_dest_ip, + ipquad.local_port, ipquad.remote_port); + +#ifdef USE_UNIX_SOCKETS + } +#endif /* USE_UNIX_SOCKETS */ + return result; +} + +static CURLcode cf_haproxy_connect(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ + struct cf_haproxy_ctx *ctx = cf->ctx; + CURLcode result; + size_t len; + + DEBUGASSERT(ctx); + if(cf->connected) { + *done = TRUE; + return CURLE_OK; + } + + result = cf->next->cft->do_connect(cf->next, data, done); + if(result || !*done) + return result; + + switch(ctx->state) { + case HAPROXY_INIT: + result = cf_haproxy_date_out_set(cf, data); + if(result) + goto out; + ctx->state = HAPROXY_SEND; + FALLTHROUGH(); + case HAPROXY_SEND: + len = curlx_dyn_len(&ctx->data_out); + if(len > 0) { + size_t nwritten; + result = Curl_conn_cf_send(cf->next, data, + curlx_dyn_uptr(&ctx->data_out), len, FALSE, + &nwritten); + if(result) { + if(result != CURLE_AGAIN) + goto out; + result = CURLE_OK; + nwritten = 0; + } + curlx_dyn_tail(&ctx->data_out, len - nwritten); + if(curlx_dyn_len(&ctx->data_out) > 0) { + result = CURLE_OK; + goto out; + } + } + ctx->state = HAPROXY_DONE; + FALLTHROUGH(); + default: + curlx_dyn_free(&ctx->data_out); + break; + } + +out: + *done = (!result) && (ctx->state == HAPROXY_DONE); + cf->connected = *done; + return result; +} + +static void cf_haproxy_destroy(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + CURL_TRC_CF(data, cf, "destroy"); + cf_haproxy_ctx_free(cf->ctx); +} + +static CURLcode cf_haproxy_adjust_pollset(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct easy_pollset *ps) +{ + if(cf->next->connected && !cf->connected) { + /* If we are not connected, but the filter "below" is + * and not waiting on something, we are sending. */ + return Curl_pollset_set_out_only( + data, ps, Curl_conn_cf_get_socket(cf, data)); + } + return CURLE_OK; +} + +struct Curl_cftype Curl_cft_haproxy = { + "HAPROXY", + CF_TYPE_PROXY | CF_TYPE_SETUP, + 0, + cf_haproxy_destroy, + cf_haproxy_connect, + Curl_cf_def_shutdown, + cf_haproxy_adjust_pollset, + Curl_cf_def_data_pending, + Curl_cf_def_send, + Curl_cf_def_recv, + Curl_cf_def_cntrl, + Curl_cf_def_conn_is_alive, + Curl_cf_def_conn_keep_alive, + Curl_cf_def_query, +}; + +static CURLcode cf_haproxy_create(struct Curl_cfilter **pcf, + struct Curl_easy *data) +{ + struct Curl_cfilter *cf = NULL; + struct cf_haproxy_ctx *ctx; + CURLcode result; + + (void)data; + ctx = curlx_calloc(1, sizeof(*ctx)); + if(!ctx) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + ctx->state = HAPROXY_INIT; + curlx_dyn_init(&ctx->data_out, DYN_HAXPROXY); + + result = Curl_cf_create(&cf, &Curl_cft_haproxy, ctx); + if(result) + goto out; + ctx = NULL; + +out: + cf_haproxy_ctx_free(ctx); + *pcf = result ? NULL : cf; + return result; +} + +CURLcode Curl_cf_haproxy_insert_after(struct Curl_cfilter *cf_at, + struct Curl_easy *data) +{ + struct Curl_cfilter *cf; + CURLcode result; + + result = cf_haproxy_create(&cf, data); + if(result) + goto out; + Curl_conn_cf_insert_after(cf_at, cf); + +out: + return result; +} + +#endif /* !CURL_DISABLE_PROXY */ diff --git a/3rdparty/curl-8.21.0/lib/cf-haproxy.h b/3rdparty/curl-8.21.0/lib/cf-haproxy.h new file mode 100644 index 0000000000..6d67597cd7 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/cf-haproxy.h @@ -0,0 +1,39 @@ +#ifndef HEADER_CURL_CF_HAPROXY_H +#define HEADER_CURL_CF_HAPROXY_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "urldata.h" + +#ifndef CURL_DISABLE_PROXY + +CURLcode Curl_cf_haproxy_insert_after(struct Curl_cfilter *cf_at, + struct Curl_easy *data); + +extern struct Curl_cftype Curl_cft_haproxy; + +#endif /* !CURL_DISABLE_PROXY */ + +#endif /* HEADER_CURL_CF_HAPROXY_H */ diff --git a/3rdparty/curl-8.21.0/lib/cf-https-connect.c b/3rdparty/curl-8.21.0/lib/cf-https-connect.c new file mode 100644 index 0000000000..1a2e966ef6 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/cf-https-connect.c @@ -0,0 +1,830 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifndef CURL_DISABLE_HTTP + +#include "urldata.h" +#include "curl_trc.h" +#include "cfilters.h" +#include "cf-dns.h" +#include "cf-setup.h" +#include "connect.h" +#include "hostip.h" +#include "httpsrr.h" +#include "multiif.h" +#include "cf-https-connect.h" +#include "http2.h" +#include "progress.h" +#include "select.h" +#include "vquic/vquic.h" + +typedef enum { + CF_HC_RESOLV, + CF_HC_INIT, + CF_HC_CONNECT, + CF_HC_SUCCESS, + CF_HC_FAILURE +} cf_hc_state; + +struct cf_hc_baller { + const char *name; + struct Curl_cfilter *cf; + CURLcode result; + struct curltime started; + int reply_ms; + uint8_t transport; + enum alpnid alpn_id; + BIT(shutdown); +}; + +static void cf_hc_baller_discard(struct cf_hc_baller *b, + struct Curl_easy *data) +{ + if(b->cf) { + Curl_conn_cf_discard_chain(&b->cf, data); + b->cf = NULL; + } +} + +static bool cf_hc_baller_is_connecting(struct cf_hc_baller *b) +{ + return b->cf && !b->result; +} + +static bool cf_hc_baller_has_started(struct cf_hc_baller *b) +{ + return !!b->cf; +} + +static int cf_hc_baller_reply_ms(struct cf_hc_baller *b, + struct Curl_easy *data) +{ + if(b->cf && (b->reply_ms < 0)) + b->cf->cft->query(b->cf, data, CF_QUERY_CONNECT_REPLY_MS, + &b->reply_ms, NULL); + return b->reply_ms; +} + +static bool cf_hc_baller_data_pending(struct cf_hc_baller *b, + const struct Curl_easy *data) +{ + return b->cf && !b->result && b->cf->cft->has_data_pending(b->cf, data); +} + +static bool cf_hc_baller_needs_flush(struct cf_hc_baller *b, + struct Curl_easy *data) +{ + return b->cf && !b->result && Curl_conn_cf_needs_flush(b->cf, data); +} + +static CURLcode cf_hc_baller_cntrl(struct cf_hc_baller *b, + struct Curl_easy *data, + int event, int arg1, void *arg2) +{ + if(b->cf && !b->result) + return Curl_conn_cf_cntrl(b->cf, data, FALSE, event, arg1, arg2); + return CURLE_OK; +} + +struct cf_hc_ctx { + cf_hc_state state; + struct curltime started; /* when connect started */ + CURLcode result; /* overall result */ + CURLcode check_h3_result; + struct cf_hc_baller ballers[2]; + size_t baller_count; + timediff_t soft_eyeballs_timeout_ms; + timediff_t hard_eyeballs_timeout_ms; + uint8_t def_transport; + BIT(httpsrr_resolved); + BIT(checked_h3); + BIT(ballers_complete); +}; + +static void cf_hc_ctx_close(struct Curl_easy *data, + struct cf_hc_ctx *ctx) +{ + if(ctx) { + size_t i; + for(i = 0; i < ctx->baller_count; ++i) + cf_hc_baller_discard(&ctx->ballers[i], data); + } +} + +static void cf_hc_ctx_destroy(struct Curl_easy *data, + struct cf_hc_ctx *ctx) +{ + if(ctx) { + cf_hc_ctx_close(data, ctx); + curlx_free(ctx); + } +} + +static void cf_hc_baller_assign(struct cf_hc_baller *b, + enum alpnid alpn_id, + uint8_t def_transport) +{ + b->alpn_id = alpn_id; + b->transport = def_transport; + b->cf = NULL; + b->result = CURLE_OK; + b->reply_ms = -1; + b->shutdown = FALSE; + switch(b->alpn_id) { + case ALPN_h3: + b->name = "h3"; + b->transport = TRNSPRT_QUIC; + break; + case ALPN_h2: + b->name = "h2"; + break; + case ALPN_h1: + b->name = "h1"; + break; + case ALPN_none: + b->name = "no-alpn"; + break; + default: + b->result = CURLE_FAILED_INIT; + break; + } +} + +static void cf_hc_baller_init(struct cf_hc_baller *b, + struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct Curl_cfilter *save = cf->next; + + cf->next = NULL; + b->started = *Curl_pgrs_now(data); + b->result = Curl_cf_setup_insert_after(cf, data, b->transport, + CURL_CF_SSL_ENABLE); + b->cf = cf->next; + cf->next = save; +} + +static CURLcode cf_hc_baller_connect(struct cf_hc_baller *b, + struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ + struct Curl_cfilter *save = cf->next; + + cf->next = b->cf; + b->result = Curl_conn_cf_connect(cf->next, data, done); + b->cf = cf->next; /* it might mutate */ + cf->next = save; + return b->result; +} + +static CURLcode baller_connected(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct cf_hc_baller *winner) +{ + struct cf_hc_ctx *ctx = cf->ctx; + + /* Make the winner's connection filter out own sub-filter, check, move, + * close all remaining. */ + if(cf->next) { + DEBUGASSERT(0); + return CURLE_FAILED_INIT; + } + if(!winner->cf) { + DEBUGASSERT(0); + return CURLE_FAILED_INIT; + } + + cf->next = winner->cf; + winner->cf = NULL; + ctx->state = CF_HC_SUCCESS; + cf->connected = TRUE; + + cf_hc_ctx_close(data, ctx); + /* ballers may have failf()'d, the winner resets it, so our + * errorbuf is clean again. */ + Curl_reset_fail(data); + +#ifdef USE_NGHTTP2 + { + /* For a negotiated HTTP/2 connection insert the h2 filter. */ + const char *alpn = Curl_conn_cf_get_alpn_negotiated(cf->next, data); + if(alpn && !strcmp("h2", alpn)) { + CURLcode result = Curl_http2_switch_at(cf, data); + if(result) { + ctx->state = CF_HC_FAILURE; + ctx->result = result; + return result; + } + } + } +#endif + return CURLE_OK; +} + +static bool time_to_start_baller2(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_hc_ctx *ctx = cf->ctx; + timediff_t elapsed_ms; + + if(ctx->baller_count < 2) + return FALSE; + else if(cf_hc_baller_has_started(&ctx->ballers[1])) + return FALSE; + else if(ctx->ballers[0].result) { + CURL_TRC_CF(data, cf, "%s baller failed, starting %s", + ctx->ballers[0].name, ctx->ballers[1].name); + return TRUE; + } + + elapsed_ms = curlx_ptimediff_ms(Curl_pgrs_now(data), &ctx->started); + if(elapsed_ms >= ctx->hard_eyeballs_timeout_ms) { + CURL_TRC_CF(data, cf, "%s inconclusive after %" FMT_TIMEDIFF_T ", " + "starting %s", ctx->ballers[0].name, + ctx->hard_eyeballs_timeout_ms, ctx->ballers[1].name); + return TRUE; + } + else if(elapsed_ms >= ctx->soft_eyeballs_timeout_ms) { + if(cf_hc_baller_reply_ms(&ctx->ballers[0], data) < 0) { + CURL_TRC_CF(data, cf, "%s has not seen any data after %" + FMT_TIMEDIFF_T "ms, starting %s", + ctx->ballers[0].name, ctx->soft_eyeballs_timeout_ms, + ctx->ballers[1].name); + return TRUE; + } + } + return FALSE; +} + +static bool cf_hc_may_h3(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_hc_ctx *ctx = cf->ctx; + if(!ctx->checked_h3) { + ctx->check_h3_result = + Curl_conn_may_http3(data, cf->conn, ctx->def_transport); + ctx->checked_h3 = TRUE; + } + return !ctx->check_h3_result; +} + +static enum alpnid cf_hc_get_httpsrr_alpn(struct Curl_cfilter *cf, + struct Curl_easy *data, + enum alpnid not_this_one) +{ +#ifdef USE_HTTPSRR + /* Is there an HTTPSRR use its ALPNs here. + * We are here after having selected a connection to a host+port and + * can no longer change that. Any HTTPSRR advice for other hosts and ports + * we need to ignore. */ + const struct Curl_https_rrinfo *rr; + size_t i; + + /* Do we have HTTPS-RR information? */ + rr = Curl_conn_dns_get_https( + data, cf->sockindex, Curl_conn_get_destination(cf->conn, cf->sockindex)); + + /* We do not support `rr->no_def_alpn`. */ + if(Curl_httpsrr_applicable(data, rr) && !rr->no_def_alpn) { + for(i = 0; i < CURL_ARRAYSIZE(rr->alpns); ++i) { + enum alpnid alpn_rr = (enum alpnid)rr->alpns[i]; + if(alpn_rr == not_this_one) /* do not want this one */ + continue; + switch(alpn_rr) { + case ALPN_h3: + if((data->state.http_neg.allowed & CURL_HTTP_V3x) && + cf_hc_may_h3(cf, data)) { + return alpn_rr; + } + break; + case ALPN_h2: + if(data->state.http_neg.allowed & CURL_HTTP_V2x) { + return alpn_rr; + } + break; + case ALPN_h1: + if(data->state.http_neg.allowed & CURL_HTTP_V1x) { + return alpn_rr; + } + break; + default: /* ignore */ + break; + } + } + } +#else + (void)cf; + (void)data; + (void)not_this_one; +#endif + return ALPN_none; +} + +static enum alpnid cf_hc_get_pref_alpn(struct Curl_cfilter *cf, + struct Curl_easy *data, + enum alpnid not_this_one) +{ + if((data->state.http_neg.preferred & data->state.http_neg.allowed)) { + switch(data->state.http_neg.preferred) { + case CURL_HTTP_V3x: + if(cf_hc_may_h3(cf, data) && (ALPN_h3 != not_this_one)) + return ALPN_h3; + break; + case CURL_HTTP_V2x: + if(ALPN_h2 != not_this_one) + return ALPN_h2; + break; + case CURL_HTTP_V1x: + /* If we are trying h2 already, h1 is already used as fallback */ + if((ALPN_h1 != not_this_one) && (ALPN_h2 != not_this_one)) + return ALPN_h1; + break; + default: + break; + } + } + return ALPN_none; +} + +static enum alpnid cf_hc_get_first_alpn(struct Curl_cfilter *cf, + struct Curl_easy *data, + http_majors choices, + enum alpnid not_this_one) +{ + /* When told to not try h2, we also do not try h1 and vice versa */ + bool allow_h1_or_h2 = (not_this_one != ALPN_h1) && + (not_this_one != ALPN_h2); + if((ALPN_h3 != not_this_one) && (choices & CURL_HTTP_V3x) && + cf_hc_may_h3(cf, data)) { + return ALPN_h3; + } + if(allow_h1_or_h2 && (choices & CURL_HTTP_V2x)) { + return ALPN_h2; + } + if(allow_h1_or_h2 && (choices & CURL_HTTP_V1x)) { + return ALPN_h1; + } + return ALPN_none; +} + +static CURLcode cf_hc_set_baller1(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_hc_ctx *ctx = cf->ctx; + enum alpnid alpn1 = ALPN_none; + VERBOSE(const char *source = "HTTPS-RR"); + + DEBUGASSERT(cf->conn->bits.tls_enable_alpn); + + alpn1 = cf_hc_get_httpsrr_alpn(cf, data, ALPN_none); + if(alpn1 == ALPN_none) { + /* preference is configured and allowed, can we use it? */ + VERBOSE(source = "preferred version"); + alpn1 = cf_hc_get_pref_alpn(cf, data, ALPN_none); + } + if(alpn1 == ALPN_none) { + VERBOSE(source = "wanted versions"); + alpn1 = cf_hc_get_first_alpn(cf, data, + data->state.http_neg.wanted, + ALPN_none); + } + if(alpn1 == ALPN_none) { + VERBOSE(source = "allowed versions"); + alpn1 = cf_hc_get_first_alpn(cf, data, + data->state.http_neg.allowed, + ALPN_none); + } + + if(alpn1 == ALPN_none) { + /* None of the wanted/allowed HTTP versions could be chosen */ + if(ctx->check_h3_result) { + CURL_TRC_CF(data, cf, "unable to use HTTP/3"); + return ctx->check_h3_result; + } + CURL_TRC_CF(data, cf, "unable to select HTTP version"); + return CURLE_FAILED_INIT; + } + + cf_hc_baller_assign(&ctx->ballers[0], alpn1, ctx->def_transport); + ctx->baller_count = 1; + CURL_TRC_CF(data, cf, "1st attempt uses %s from %s", + ctx->ballers[0].name, source); + + switch(alpn1) { + case ALPN_h1: + /* We really want h1, switch off h2 to make it disappear in ALPN */ + data->state.http_neg.wanted &= (uint8_t)~CURL_HTTP_V2x; + break; + default: + break; + } + + return CURLE_OK; +} + +static void cf_hc_set_baller2(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_hc_ctx *ctx = cf->ctx; + enum alpnid alpn2 = ALPN_none, alpn1 = ctx->ballers[0].alpn_id; + VERBOSE(const char *source = "HTTPS-RR"); + + if(ctx->ballers_complete) + return; /* already done */ + if(!ctx->httpsrr_resolved) + return; /* HTTPS-RR pending */ + + alpn2 = cf_hc_get_httpsrr_alpn(cf, data, alpn1); + if(alpn2 == ALPN_none) { + /* preference is configured and allowed, can we use it? */ + VERBOSE(source = "preferred version"); + alpn2 = cf_hc_get_pref_alpn(cf, data, alpn1); + } + if(alpn2 == ALPN_none) { + VERBOSE(source = "wanted versions"); + alpn2 = cf_hc_get_first_alpn(cf, data, + data->state.http_neg.wanted, + alpn1); + } + + if(alpn2 != ALPN_none) { + cf_hc_baller_assign(&ctx->ballers[1], alpn2, ctx->def_transport); + ctx->baller_count = 2; + CURL_TRC_CF(data, cf, "2nd attempt uses %s from %s", + ctx->ballers[1].name, source); + } + ctx->ballers_complete = TRUE; +} + +static CURLcode cf_hc_connect(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ + struct cf_hc_ctx *ctx = cf->ctx; + CURLcode result = CURLE_OK; + + if(cf->connected) { + *done = TRUE; + return CURLE_OK; + } + + *done = FALSE; + + if(!ctx->httpsrr_resolved) { + ctx->httpsrr_resolved = Curl_conn_dns_resolved_https( + data, cf->sockindex, Curl_conn_get_destination(cf->conn, cf->sockindex)); +#ifdef DEBUGBUILD + if(!ctx->httpsrr_resolved && getenv("CURL_DBG_AWAIT_HTTPSRR")) { + CURL_TRC_CF(data, cf, "awaiting HTTPS-RR"); + return CURLE_OK; + } +#endif + } + + switch(ctx->state) { + case CF_HC_RESOLV: + ctx->state = CF_HC_INIT; + FALLTHROUGH(); + + case CF_HC_INIT: + DEBUGASSERT(!cf->next); + CURL_TRC_CF(data, cf, "connect, init"); + result = cf_hc_set_baller1(cf, data); + if(result) { + ctx->result = result; + ctx->state = CF_HC_FAILURE; + goto out; + } + cf_hc_set_baller2(cf, data); + ctx->started = *Curl_pgrs_now(data); + cf_hc_baller_init(&ctx->ballers[0], cf, data); + if((ctx->baller_count > 1) || !ctx->ballers_complete) { + Curl_expire(data, ctx->soft_eyeballs_timeout_ms, EXPIRE_ALPN_EYEBALLS); + } + ctx->state = CF_HC_CONNECT; + FALLTHROUGH(); + + case CF_HC_CONNECT: + if(!ctx->ballers_complete) + cf_hc_set_baller2(cf, data); + + if(cf_hc_baller_is_connecting(&ctx->ballers[0])) { + result = cf_hc_baller_connect(&ctx->ballers[0], cf, data, done); + if(!result && *done) { + result = baller_connected(cf, data, &ctx->ballers[0]); + goto out; + } + } + + if(time_to_start_baller2(cf, data)) { + cf_hc_baller_init(&ctx->ballers[1], cf, data); + } + + if(cf_hc_baller_is_connecting(&ctx->ballers[1])) { + result = cf_hc_baller_connect(&ctx->ballers[1], cf, data, done); + if(!result && *done) { + result = baller_connected(cf, data, &ctx->ballers[1]); + goto out; + } + } + + if(ctx->ballers[0].result && + (ctx->ballers[1].result || + (ctx->ballers_complete && (ctx->baller_count < 2)))) { + /* all have failed. we give up */ + CURL_TRC_CF(data, cf, "connect, all attempts failed"); + ctx->result = result = ctx->ballers[0].result; + ctx->state = CF_HC_FAILURE; + goto out; + } + result = CURLE_OK; + *done = FALSE; + break; + + case CF_HC_FAILURE: + result = ctx->result; + cf->connected = FALSE; + *done = FALSE; + break; + + case CF_HC_SUCCESS: + result = CURLE_OK; + cf->connected = TRUE; + *done = TRUE; + break; + } + +out: + CURL_TRC_CF(data, cf, "connect -> %d, done=%d", (int)result, *done); + return result; +} + +static CURLcode cf_hc_shutdown(struct Curl_cfilter *cf, + struct Curl_easy *data, bool *done) +{ + struct cf_hc_ctx *ctx = cf->ctx; + size_t i; + CURLcode result = CURLE_OK; + + DEBUGASSERT(data); + if(cf->connected) { + *done = TRUE; + return CURLE_OK; + } + + /* shutdown all ballers that have not done so already. If one fails, + * continue shutting down others until all are shutdown. */ + for(i = 0; i < ctx->baller_count; i++) { + struct cf_hc_baller *b = &ctx->ballers[i]; + bool bdone = FALSE; + if(!cf_hc_baller_is_connecting(b) || b->shutdown) + continue; + b->result = b->cf->cft->do_shutdown(b->cf, data, &bdone); + if(b->result || bdone) + b->shutdown = TRUE; /* treat a failed shutdown as done */ + } + + *done = TRUE; + for(i = 0; i < ctx->baller_count; i++) { + if(!ctx->ballers[i].shutdown) + *done = FALSE; + } + if(*done) { + for(i = 0; i < ctx->baller_count; i++) { + if(ctx->ballers[i].result) + result = ctx->ballers[i].result; + } + } + CURL_TRC_CF(data, cf, "shutdown -> %d, done=%d", (int)result, *done); + return result; +} + +static CURLcode cf_hc_adjust_pollset(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct easy_pollset *ps) +{ + CURLcode result = CURLE_OK; + if(!cf->connected) { + struct cf_hc_ctx *ctx = cf->ctx; + size_t i; + + for(i = 0; (i < ctx->baller_count) && !result; i++) { + struct cf_hc_baller *b = &ctx->ballers[i]; + if(!cf_hc_baller_is_connecting(b)) + continue; + result = Curl_conn_cf_adjust_pollset(b->cf, data, ps); + } + CURL_TRC_CF(data, cf, "adjust_pollset -> %d, %u socks", (int)result, + ps->n); + } + return result; +} + +static bool cf_hc_data_pending(struct Curl_cfilter *cf, + const struct Curl_easy *data) +{ + struct cf_hc_ctx *ctx = cf->ctx; + size_t i; + + if(cf->connected) + return cf->next->cft->has_data_pending(cf->next, data); + + for(i = 0; i < ctx->baller_count; i++) + if(cf_hc_baller_data_pending(&ctx->ballers[i], data)) + return TRUE; + return FALSE; +} + +static struct curltime cf_get_max_baller_time(struct Curl_cfilter *cf, + struct Curl_easy *data, + int query) +{ + struct cf_hc_ctx *ctx = cf->ctx; + struct curltime t, tmax; + size_t i; + + memset(&tmax, 0, sizeof(tmax)); + for(i = 0; i < ctx->baller_count; i++) { + struct Curl_cfilter *cfb = ctx->ballers[i].cf; + memset(&t, 0, sizeof(t)); + if(cfb && !cfb->cft->query(cfb, data, query, NULL, &t)) { + if((t.tv_sec || t.tv_usec) && curlx_ptimediff_us(&t, &tmax) > 0) + tmax = t; + } + } + return tmax; +} + +static CURLcode cf_hc_query(struct Curl_cfilter *cf, + struct Curl_easy *data, + int query, int *pres1, void *pres2) +{ + struct cf_hc_ctx *ctx = cf->ctx; + size_t i; + + if(!cf->connected) { + switch(query) { + case CF_QUERY_TIMER_CONNECT: { + struct curltime *when = pres2; + *when = cf_get_max_baller_time(cf, data, CF_QUERY_TIMER_CONNECT); + return CURLE_OK; + } + case CF_QUERY_TIMER_APPCONNECT: { + struct curltime *when = pres2; + *when = cf_get_max_baller_time(cf, data, CF_QUERY_TIMER_APPCONNECT); + return CURLE_OK; + } + case CF_QUERY_NEED_FLUSH: { + for(i = 0; i < ctx->baller_count; i++) + if(cf_hc_baller_needs_flush(&ctx->ballers[i], data)) { + *pres1 = TRUE; + return CURLE_OK; + } + break; + } + default: + break; + } + } + return cf->next ? + cf->next->cft->query(cf->next, data, query, pres1, pres2) : + CURLE_UNKNOWN_OPTION; +} + +static CURLcode cf_hc_cntrl(struct Curl_cfilter *cf, + struct Curl_easy *data, + int event, int arg1, void *arg2) +{ + struct cf_hc_ctx *ctx = cf->ctx; + CURLcode result = CURLE_OK; + size_t i; + + if(!cf->connected) { + for(i = 0; i < ctx->baller_count; i++) { + result = cf_hc_baller_cntrl(&ctx->ballers[i], data, event, arg1, arg2); + if(result && (result != CURLE_AGAIN)) + goto out; + } + result = CURLE_OK; + } +out: + return result; +} + +static void cf_hc_destroy(struct Curl_cfilter *cf, struct Curl_easy *data) +{ + struct cf_hc_ctx *ctx = cf->ctx; + + CURL_TRC_CF(data, cf, "destroy"); + cf_hc_ctx_destroy(data, ctx); +} + +struct Curl_cftype Curl_cft_http_connect = { + "HTTPS-CONNECT", + CF_TYPE_SETUP | CF_TYPE_HTTPSRR, + CURL_LOG_LVL_NONE, + cf_hc_destroy, + cf_hc_connect, + cf_hc_shutdown, + cf_hc_adjust_pollset, + cf_hc_data_pending, + Curl_cf_def_send, + Curl_cf_def_recv, + cf_hc_cntrl, + Curl_cf_def_conn_is_alive, + Curl_cf_def_conn_keep_alive, + cf_hc_query, +}; + +static CURLcode cf_hc_create(struct Curl_cfilter **pcf, + struct Curl_easy *data, + uint8_t def_transport) +{ + struct Curl_cfilter *cf = NULL; + struct cf_hc_ctx *ctx; + CURLcode result = CURLE_OK; + + ctx = curlx_calloc(1, sizeof(*ctx)); + if(!ctx) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + ctx->def_transport = def_transport; + ctx->hard_eyeballs_timeout_ms = data->set.happy_eyeballs_timeout; + ctx->soft_eyeballs_timeout_ms = data->set.happy_eyeballs_timeout / 2; + + result = Curl_cf_create(&cf, &Curl_cft_http_connect, ctx); + if(result) + goto out; + ctx = NULL; + +out: + *pcf = result ? NULL : cf; + cf_hc_ctx_destroy(data, ctx); + return result; +} + +static CURLcode cf_hc_add(struct Curl_easy *data, + struct connectdata *conn, + int sockindex, + uint8_t def_transport) +{ + struct Curl_cfilter *cf; + CURLcode result = CURLE_OK; + + DEBUGASSERT(data); + result = cf_hc_create(&cf, data, def_transport); + if(result) + goto out; + Curl_conn_cf_add(data, conn, sockindex, cf); +out: + return result; +} + +CURLcode Curl_cf_https_setup(struct Curl_easy *data, + struct connectdata *conn, + int sockindex) +{ + CURLcode result = CURLE_OK; + + DEBUGASSERT(conn->scheme->protocol == CURLPROTO_HTTPS); + + /* This filter is intended for HTTPS using ALPN and does + * not support HTTPS Eyeballing to a proxy. */ + if((conn->scheme->protocol != CURLPROTO_HTTPS) || +#ifndef CURL_DISABLE_PROXY + conn->bits.origin_is_proxy || +#endif + !conn->bits.tls_enable_alpn) + goto out; + + result = cf_hc_add(data, conn, sockindex, conn->transport_wanted); + +out: + return result; +} + +#endif /* !CURL_DISABLE_HTTP */ diff --git a/3rdparty/curl-8.21.0/lib/cf-https-connect.h b/3rdparty/curl-8.21.0/lib/cf-https-connect.h new file mode 100644 index 0000000000..3160c0382a --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/cf-https-connect.h @@ -0,0 +1,42 @@ +#ifndef HEADER_CURL_CF_HTTP_H +#define HEADER_CURL_CF_HTTP_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifndef CURL_DISABLE_HTTP + +struct Curl_cfilter; +struct Curl_easy; +struct connectdata; +struct Curl_cftype; + +extern struct Curl_cftype Curl_cft_http_connect; + +CURLcode Curl_cf_https_setup(struct Curl_easy *data, + struct connectdata *conn, + int sockindex); + +#endif /* !CURL_DISABLE_HTTP */ +#endif /* HEADER_CURL_CF_HTTP_H */ diff --git a/3rdparty/curl-8.21.0/lib/cf-ip-happy.c b/3rdparty/curl-8.21.0/lib/cf-ip-happy.c new file mode 100644 index 0000000000..963ccea94d --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/cf-ip-happy.c @@ -0,0 +1,1054 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef HAVE_NETINET_IN_H +#include /* may need it */ +#endif +#ifdef HAVE_LINUX_TCP_H +#include +#elif defined(HAVE_NETINET_TCP_H) +#include +#endif +#ifdef HAVE_SYS_IOCTL_H +#include +#endif +#ifdef HAVE_NETDB_H +#include +#endif +#ifdef HAVE_ARPA_INET_H +#include +#endif + +#ifdef __VMS +#include +#include +#endif + +#include "urldata.h" +#include "connect.h" +#include "cfilters.h" +#include "cf-dns.h" +#include "cf-ip-happy.h" +#include "curl_addrinfo.h" +#include "curl_trc.h" +#include "multiif.h" +#include "progress.h" +#include "select.h" +#include "sockaddr.h" +#include "vquic/vquic.h" /* for quic cfilters */ + + +struct transport_provider { + cf_ip_connect_create *cf_create; + uint8_t transport; + bool tunnel; +}; + +static +#ifndef UNITTESTS +const +#endif +struct transport_provider transport_providers[] = { + { Curl_cf_tcp_create, TRNSPRT_TCP, FALSE }, + { Curl_cf_tcp_create, TRNSPRT_TCP, TRUE }, +#if !defined(CURL_DISABLE_HTTP) && defined(USE_HTTP3) + { Curl_cf_quic_create, TRNSPRT_QUIC, FALSE }, +#endif +#if !defined(CURL_DISABLE_HTTP) && defined(USE_PROXY_HTTP3) + { Curl_cf_h3_proxy_create, TRNSPRT_QUIC, TRUE }, +#endif +#ifndef CURL_DISABLE_TFTP + { Curl_cf_udp_create, TRNSPRT_UDP, FALSE }, +#endif +#ifdef USE_UNIX_SOCKETS + { Curl_cf_unix_create, TRNSPRT_UNIX, FALSE }, + { Curl_cf_unix_create, TRNSPRT_UNIX, TRUE }, +#endif +}; + +static cf_ip_connect_create *get_cf_create(uint8_t transport, + bool tunnel) +{ + size_t i; + for(i = 0; i < CURL_ARRAYSIZE(transport_providers); ++i) { + if((transport == transport_providers[i].transport) && + (tunnel == transport_providers[i].tunnel)) + return transport_providers[i].cf_create; + } + return NULL; +} + +#ifdef UNITTESTS +/* @unittest 2600 */ +UNITTEST void debug_set_transport_provider( + uint8_t transport, cf_ip_connect_create *cf_create); +UNITTEST void debug_set_transport_provider( + uint8_t transport, cf_ip_connect_create *cf_create) +{ + size_t i; + for(i = 0; i < CURL_ARRAYSIZE(transport_providers); ++i) { + if(transport == transport_providers[i].transport) { + transport_providers[i].cf_create = cf_create; + } + } +} +#endif /* UNITTESTS */ + +struct cf_ai_iter { + struct Curl_cfilter *cf; + struct Curl_peer *peer; + int ai_family; + unsigned int n; +}; + +static void cf_ai_iter_init(struct cf_ai_iter *iter, + struct Curl_cfilter *cf, + struct Curl_peer *peer, + int ai_family) +{ + iter->cf = cf; + iter->peer = peer; /* not linked, ctx->ballers owns and has same lifetime */ + iter->ai_family = ai_family; + iter->n = 0; +} + +static const struct Curl_addrinfo *cf_ai_iter_next(struct cf_ai_iter *iter, + struct Curl_easy *data) +{ + const struct Curl_addrinfo *addr; + + if(!iter->cf) + return NULL; + + addr = Curl_conn_dns_get_ai(data, iter->peer, iter->cf->sockindex, + iter->ai_family, iter->n); + if(addr) + iter->n++; + return addr; +} + +static bool cf_ai_iter_has_more(struct cf_ai_iter *iter, + struct Curl_easy *data) +{ + return (iter->cf && + !!Curl_conn_dns_get_ai(data, iter->peer, iter->cf->sockindex, + iter->ai_family, iter->n)); +} + +struct cf_ip_attempt { + struct cf_ip_attempt *next; + struct Curl_peer *origin; + struct Curl_peer *peer; + struct Curl_peer *tunnel_peer; + struct Curl_sockaddr_ex addr; + struct Curl_cfilter *cf; /* current sub-cfilter connecting */ + cf_ip_connect_create *cf_create; + struct curltime started; /* start of current attempt */ + CURLcode result; + int ai_family; + uint8_t transport_peer; + uint8_t tunnel_transport; + int error; + BIT(connected); /* cf has connected */ + BIT(shutdown); /* cf has shutdown */ + BIT(inconclusive); /* connect was not a hard failure, we + * might talk to a restarting server */ +}; + +static void cf_ip_attempt_free(struct cf_ip_attempt *a, + struct Curl_easy *data) +{ + if(a) { + if(a->cf) + Curl_conn_cf_discard_chain(&a->cf, data); + Curl_peer_unlink(&a->origin); + Curl_peer_unlink(&a->peer); + Curl_peer_unlink(&a->tunnel_peer); + curlx_free(a); + } +} + +static CURLcode cf_ip_attempt_new(struct cf_ip_attempt **pa, + struct Curl_easy *data, + struct Curl_cfilter *cf, + struct Curl_peer *origin, + struct Curl_peer *peer, + uint8_t transport_peer, + struct Curl_sockaddr_ex *addr, + int ai_family, + struct Curl_peer *tunnel_peer, + uint8_t tunnel_transport, + cf_ip_connect_create *cf_create) +{ + struct Curl_cfilter *wcf; + struct cf_ip_attempt *a; + CURLcode result = CURLE_OK; + + *pa = NULL; + a = curlx_calloc(1, sizeof(*a)); + if(!a) + return CURLE_OUT_OF_MEMORY; + + Curl_peer_link(&a->origin, origin); + Curl_peer_link(&a->peer, peer); + a->transport_peer = transport_peer; + Curl_peer_link(&a->tunnel_peer, tunnel_peer); + a->tunnel_transport = tunnel_transport; + a->addr = *addr; + a->ai_family = ai_family; + a->result = CURLE_OK; + a->cf_create = cf_create; + *pa = a; + + result = a->cf_create(&a->cf, data, a->origin, a->peer, a->transport_peer, + cf->conn, &a->addr, a->tunnel_peer, + a->tunnel_transport); + if(result) + goto out; + + /* the new filter might have sub-filters */ + for(wcf = a->cf; wcf; wcf = wcf->next) { + wcf->conn = cf->conn; + wcf->sockindex = cf->sockindex; + } + +out: + if(result) { + cf_ip_attempt_free(a, data); + *pa = NULL; + } + return result; +} + +static CURLcode cf_ip_attempt_connect(struct cf_ip_attempt *a, + struct Curl_easy *data, + bool *connected) +{ + *connected = (bool)a->connected; + if(!a->result && !*connected) { + /* evaluate again */ + a->result = Curl_conn_cf_connect(a->cf, data, connected); + + if(!a->result) { + if(*connected) { + a->connected = TRUE; + } + } + else { + if(a->result == CURLE_WEIRD_SERVER_REPLY) + a->inconclusive = TRUE; + if(a->cf) + Curl_conn_cf_discard_chain(&a->cf, data); + } + } + return a->result; +} + +struct cf_ip_ballers { + struct cf_ip_attempt *running; + struct cf_ip_attempt *winner; + struct cf_ai_iter addr_iter; +#ifdef USE_IPV6 + struct cf_ai_iter ipv6_iter; +#endif + struct Curl_peer *origin; + struct Curl_peer *peer; + struct Curl_peer *tunnel_peer; + cf_ip_connect_create *cf_create; /* for creating cf */ + struct curltime started; + struct curltime last_attempt_started; + timediff_t attempt_delay_ms; + int last_attempt_ai_family; + uint32_t max_concurrent; + uint8_t transport_peer; + uint8_t tunnel_transport; +}; + +static CURLcode cf_ip_attempt_restart(struct cf_ip_attempt *a, + struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct Curl_cfilter *wcf; + CURLcode result; + + if(a->cf) + Curl_conn_cf_discard_chain(&a->cf, data); + + a->result = CURLE_OK; + a->connected = FALSE; + a->inconclusive = FALSE; + a->cf = NULL; + + result = a->cf_create(&a->cf, data, a->origin, a->peer, a->transport_peer, + cf->conn, &a->addr, + a->tunnel_peer, a->tunnel_transport); + if(!result) { + bool dummy; + /* the new filter might have sub-filters */ + for(wcf = a->cf; wcf; wcf = wcf->next) { + wcf->conn = cf->conn; + wcf->sockindex = cf->sockindex; + } + a->result = cf_ip_attempt_connect(a, data, &dummy); + } + return result; +} + +static void cf_ip_ballers_clear(struct Curl_easy *data, + struct cf_ip_ballers *bs) +{ + while(bs->running) { + struct cf_ip_attempt *a = bs->running; + bs->running = a->next; + cf_ip_attempt_free(a, data); + } + cf_ip_attempt_free(bs->winner, data); + bs->winner = NULL; + Curl_peer_unlink(&bs->origin); + Curl_peer_unlink(&bs->peer); + Curl_peer_unlink(&bs->tunnel_peer); +} + +static CURLcode cf_ip_ballers_init(struct cf_ip_ballers *bs, + struct Curl_easy *data, + struct Curl_peer *origin, + struct Curl_peer *peer, + uint8_t transport_peer, + struct Curl_peer *tunnel_peer, + uint8_t tunnel_transport, + timediff_t attempt_delay_ms, + uint32_t max_concurrent) +{ + memset(bs, 0, sizeof(*bs)); + bs->cf_create = get_cf_create(transport_peer, !!tunnel_peer); + if(!bs->cf_create) { + failf(data, "unsupported transport type %u%s", + transport_peer, tunnel_peer ? " to proxy" : ""); + return CURLE_UNSUPPORTED_PROTOCOL; + } + Curl_peer_link(&bs->origin, origin); + Curl_peer_link(&bs->peer, peer); + bs->transport_peer = transport_peer; + Curl_peer_link(&bs->tunnel_peer, tunnel_peer); + bs->tunnel_transport = tunnel_transport; + bs->attempt_delay_ms = attempt_delay_ms; + bs->max_concurrent = max_concurrent; + bs->last_attempt_ai_family = AF_INET; /* so AF_INET6 is next */ + return CURLE_OK; +} + +static void cf_ip_ballers_prune(struct cf_ip_ballers *bs, + struct Curl_cfilter *cf, + struct Curl_easy *data, + uint32_t max_concurrent) +{ + struct cf_ip_attempt *a = NULL, **panchor; + uint32_t ongoing = 0; + + for(a = bs->running; a; a = a->next) { + if(!a->result && !a->connected) + ++ongoing; + } + + panchor = &bs->running; + while(*panchor && (ongoing > max_concurrent)) { + a = *panchor; + if(!a->result && !a->connected) { + *panchor = a->next; + a->next = NULL; + cf_ip_attempt_free(a, data); + --ongoing; + CURL_TRC_CF(data, cf, "discarding oldest attempt to keep limit"); + } + else { + panchor = &a->next; + } + } +} + +static CURLcode cf_ip_ballers_run(struct cf_ip_ballers *bs, + struct Curl_cfilter *cf, + struct Curl_easy *data, + bool dns_resolved, + bool *connected) +{ + CURLcode result = CURLE_OK; + struct cf_ip_attempt *a = NULL, **panchor; + bool do_more; + timediff_t next_expire_ms; + uint32_t inconclusive, ongoing; + VERBOSE(int i); + + if(bs->winner) + return CURLE_OK; + +evaluate: + ongoing = inconclusive = 0; + + /* check if a running baller connects now */ + VERBOSE(i = -1); + for(panchor = &bs->running; *panchor; panchor = &((*panchor)->next)) { + VERBOSE(++i); + a = *panchor; + a->result = cf_ip_attempt_connect(a, data, connected); + if(!a->result) { + if(*connected) { + /* connected, declare the winner, remove from running, + * clear remaining running list. */ + CURL_TRC_CF(data, cf, "connect attempt #%d successful", i); + bs->winner = a; + *panchor = a->next; + a->next = NULL; + while(bs->running) { + a = bs->running; + bs->running = a->next; + cf_ip_attempt_free(a, data); + } + return CURLE_OK; + } + /* still running */ + ++ongoing; + } + else if(a->inconclusive) /* failed, but inconclusive */ + ++inconclusive; + } + if(bs->running) + CURL_TRC_CF(data, cf, "checked connect attempts: " + "%u ongoing, %u inconclusive", ongoing, inconclusive); + + /* no attempt connected yet, start another one? */ + if(!ongoing) { + if(!bs->started.tv_sec && !bs->started.tv_usec) + bs->started = *Curl_pgrs_now(data); + do_more = TRUE; + } + else { + bool more_possible = cf_ai_iter_has_more(&bs->addr_iter, data); +#ifdef USE_IPV6 + if(!more_possible) + more_possible = cf_ai_iter_has_more(&bs->ipv6_iter, data); +#endif + do_more = more_possible && + (curlx_ptimediff_ms(Curl_pgrs_now(data), &bs->last_attempt_started) >= + bs->attempt_delay_ms); + if(do_more) + CURL_TRC_CF(data, cf, "happy eyeballs timeout expired, " + "start next attempt"); + } + + if(do_more) { + /* start the next attempt if there is another ip address to try. + * Alternate between address families when possible. */ + const struct Curl_addrinfo *ai = NULL; + int ai_family = 0; + CURL_TRC_CF(data, cf, "want to do more"); +#ifdef USE_IPV6 + if((bs->last_attempt_ai_family == AF_INET) || + !cf_ai_iter_has_more(&bs->addr_iter, data)) { + ai = cf_ai_iter_next(&bs->ipv6_iter, data); + ai_family = bs->ipv6_iter.ai_family; + CURL_TRC_CF(data, cf, "check for next AAAA address: %s", + ai ? "found" : "none"); + } +#endif + if(!ai) { + ai = cf_ai_iter_next(&bs->addr_iter, data); + ai_family = bs->addr_iter.ai_family; + CURL_TRC_CF(data, cf, "check for next A address: %s", + ai ? "found" : "none"); + } + /* We are (re-)starting attempts. We are not interested in + * keeping old failure information. The new attempt will either + * succeed or persist new failure. */ + Curl_reset_fail(data); + + if(ai) { /* try another address */ + struct Curl_sockaddr_ex addr; + + /* Discard oldest to make room for new attempt */ + if(bs->max_concurrent) + cf_ip_ballers_prune(bs, cf, data, bs->max_concurrent - 1); + + result = Curl_socket_addr_from_ai(&addr, ai, bs->transport_peer); + if(result) + goto out; + + result = cf_ip_attempt_new(&a, data, cf, bs->origin, bs->peer, + bs->transport_peer, &addr, ai_family, + bs->tunnel_peer, bs->tunnel_transport, + bs->cf_create); + CURL_TRC_CF(data, cf, "starting %s attempt for ipv%s -> %d", + bs->running ? "next" : "first", + (ai_family == AF_INET) ? "4" : "6", (int)result); + if(result) + goto out; + DEBUGASSERT(a); + + /* append to running list */ + panchor = &bs->running; + while(*panchor) + panchor = &((*panchor)->next); + *panchor = a; + bs->last_attempt_started = *Curl_pgrs_now(data); + bs->last_attempt_ai_family = ai_family; + /* and run everything again */ + goto evaluate; + } + else if(inconclusive) { + /* tried all addresses, no success but some where inconclusive. + * Let's restart the inconclusive ones. */ + timediff_t since_ms = + curlx_ptimediff_ms(Curl_pgrs_now(data), &bs->last_attempt_started); + timediff_t delay_ms = bs->attempt_delay_ms - since_ms; + if(delay_ms <= 0) { + CURL_TRC_CF(data, cf, "all attempts inconclusive, restarting one"); + VERBOSE(i = -1); + for(a = bs->running; a; a = a->next) { + VERBOSE(++i); + if(!a->inconclusive) + continue; + result = cf_ip_attempt_restart(a, cf, data); + CURL_TRC_CF(data, cf, "restarted baller %d -> %d", i, (int)result); + if(result) /* serious failure */ + goto out; + bs->last_attempt_started = *Curl_pgrs_now(data); + goto evaluate; + } + DEBUGASSERT(0); /* should not come here */ + } + else { + /* let's wait some more before restarting */ + infof(data, "connect attempts inconclusive, retrying " + "in %" FMT_TIMEDIFF_T "ms", delay_ms); + Curl_expire(data, delay_ms, EXPIRE_HAPPY_EYEBALLS); + } + /* attempt timeout for restart has not expired yet */ + goto out; + } + else if(!ongoing && dns_resolved) { + /* no more addresses, no inconclusive attempts */ + CURL_TRC_CF(data, cf, "no more attempts to try"); + result = CURLE_COULDNT_CONNECT; + VERBOSE(i = 0); + for(a = bs->running; a; a = a->next) { + CURL_TRC_CF(data, cf, "baller %d: result=%d", i, (int)a->result); + if(a->result) + result = a->result; + } + } + } + +out: + if(!result) { + bool more_possible; + + /* when do we need to be called again? */ + next_expire_ms = Curl_timeleft_ms(data); + if(next_expire_ms < 0) { + failf(data, "Connection timeout after %" FMT_OFF_T " ms", + curlx_ptimediff_ms(Curl_pgrs_now(data), + &data->progress.t_startsingle)); + return CURLE_OPERATION_TIMEDOUT; + } + + more_possible = cf_ai_iter_has_more(&bs->addr_iter, data); +#ifdef USE_IPV6 + if(!more_possible) + more_possible = cf_ai_iter_has_more(&bs->ipv6_iter, data); +#endif + if(more_possible) { + timediff_t expire_ms, elapsed_ms; + elapsed_ms = + curlx_ptimediff_ms(Curl_pgrs_now(data), &bs->last_attempt_started); + expire_ms = CURLMAX(bs->attempt_delay_ms - elapsed_ms, 0); + next_expire_ms = CURLMIN(next_expire_ms, expire_ms); + if(next_expire_ms <= 0) { + CURL_TRC_CF(data, cf, "HAPPY_EYEBALLS timeout due, re-evaluate"); + goto evaluate; + } + CURL_TRC_CF(data, cf, "next HAPPY_EYEBALLS timeout in %" FMT_TIMEDIFF_T + "ms", next_expire_ms); + Curl_expire(data, next_expire_ms, EXPIRE_HAPPY_EYEBALLS); + } + } + return result; +} + +static CURLcode cf_ip_ballers_shutdown(struct cf_ip_ballers *bs, + struct Curl_easy *data, + bool *done) +{ + struct cf_ip_attempt *a; + + /* shutdown all ballers that have not done so already. If one fails, + * continue shutting down others until all are shutdown. */ + *done = TRUE; + for(a = bs->running; a; a = a->next) { + bool bdone = FALSE; + if(a->shutdown || !a->cf) + continue; + a->result = a->cf->cft->do_shutdown(a->cf, data, &bdone); + if(a->result || bdone) + a->shutdown = TRUE; /* treat a failed shutdown as done */ + else + *done = FALSE; + } + return CURLE_OK; +} + +static CURLcode cf_ip_ballers_pollset(struct cf_ip_ballers *bs, + struct Curl_easy *data, + struct easy_pollset *ps) +{ + struct cf_ip_attempt *a; + CURLcode result = CURLE_OK; + for(a = bs->running; a && !result; a = a->next) { + if(a->result) + continue; + result = Curl_conn_cf_adjust_pollset(a->cf, data, ps); + } + return result; +} + +static bool cf_ip_ballers_pending(struct cf_ip_ballers *bs, + const struct Curl_easy *data) +{ + struct cf_ip_attempt *a; + + for(a = bs->running; a; a = a->next) { + if(a->result) + continue; + if(a->cf && a->cf->cft->has_data_pending(a->cf, data)) + return TRUE; + } + return FALSE; +} + +static struct curltime cf_ip_ballers_max_time(struct cf_ip_ballers *bs, + struct Curl_easy *data, + int query) +{ + struct curltime t, tmax; + struct cf_ip_attempt *a; + + memset(&tmax, 0, sizeof(tmax)); + for(a = bs->running; a; a = a->next) { + memset(&t, 0, sizeof(t)); + if(a->cf && !a->cf->cft->query(a->cf, data, query, NULL, &t)) { + if((t.tv_sec || t.tv_usec) && curlx_ptimediff_us(&t, &tmax) > 0) + tmax = t; + } + } + return tmax; +} + +static int cf_ip_ballers_min_reply_ms(struct cf_ip_ballers *bs, + struct Curl_easy *data) +{ + int reply_ms = -1, breply_ms; + struct cf_ip_attempt *a; + + for(a = bs->running; a; a = a->next) { + if(a->cf && !a->cf->cft->query(a->cf, data, CF_QUERY_CONNECT_REPLY_MS, + &breply_ms, NULL)) { + if(breply_ms >= 0 && (reply_ms < 0 || breply_ms < reply_ms)) + reply_ms = breply_ms; + } + } + return reply_ms; +} + +typedef enum { + SCFST_INIT, + SCFST_WAITING, + SCFST_DONE +} cf_connect_state; + +struct cf_ip_happy_ctx { + cf_ip_connect_create *cf_create; + cf_connect_state state; + struct cf_ip_ballers ballers; + struct curltime started; + BIT(dns_resolved); +}; + +static CURLcode is_connected(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *connected) +{ + struct cf_ip_happy_ctx *ctx = cf->ctx; + struct connectdata *conn = cf->conn; + CURLcode result; + + result = cf_ip_ballers_run(&ctx->ballers, cf, data, + (bool)ctx->dns_resolved, connected); + + if(!result) + return CURLE_OK; + else { + struct Curl_peer *peer = NULL, *proxy_peer = NULL; + char viamsg[160]; + + peer = Curl_conn_get_first_peer(conn, cf->sockindex); + if(!conn->origin || !peer) + return CURLE_FAILED_INIT; + +#ifndef CURL_DISABLE_PROXY + if(conn->socks_proxy.peer) + proxy_peer = conn->socks_proxy.peer; + else if(conn->http_proxy.peer) + proxy_peer = conn->http_proxy.peer; +#endif + + viamsg[0] = 0; + if(!Curl_peer_equal(peer, conn->origin) && + !Curl_peer_equal(peer, proxy_peer)) { +#ifdef USE_UNIX_SOCKETS + if(peer->unix_socket) + curl_msnprintf(viamsg, sizeof(viamsg), " over unix://%s", + peer->hostname); + else +#endif + curl_msnprintf(viamsg, sizeof(viamsg), " via %s:%u", + peer->hostname, peer->port); + } + + failf(data, "Failed to connect to %s:%u%s %s%s%safter " + "%" FMT_TIMEDIFF_T " ms: %s", + conn->origin->hostname, conn->origin->port, viamsg, + proxy_peer ? "over proxy " : "", + proxy_peer ? proxy_peer->hostname : "", + proxy_peer ? " " : "", + curlx_ptimediff_ms(Curl_pgrs_now(data), + &data->progress.t_startsingle), + curl_easy_strerror(result)); + +#ifdef SOCKETIMEDOUT + if(SOCKETIMEDOUT == data->state.os_errno) + result = CURLE_OPERATION_TIMEDOUT; +#endif + + return result; + } +} + +#define IP_HE_MAX_CONCURRENT_ATTEMPTS 6 + +static CURLcode cf_ip_happy_init(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_ip_happy_ctx *ctx = cf->ctx; + + if(Curl_timeleft_ms(data) < 0) { + /* a precaution, no need to continue if time already is up */ + failf(data, "Connection time-out"); + return CURLE_OPERATION_TIMEDOUT; + } + + if(ctx->ballers.transport_peer == TRNSPRT_UNIX) { +#ifdef USE_UNIX_SOCKETS + cf_ai_iter_init(&ctx->ballers.addr_iter, cf, ctx->ballers.peer, AF_UNIX); +#else + return CURLE_UNSUPPORTED_PROTOCOL; +#endif + } + else { /* TCP/UDP/QUIC */ +#ifdef USE_IPV6 + cf_ai_iter_init(&ctx->ballers.ipv6_iter, cf, ctx->ballers.peer, AF_INET6); +#endif + cf_ai_iter_init(&ctx->ballers.addr_iter, cf, ctx->ballers.peer, AF_INET); + } + + CURL_TRC_CF(data, cf, "init ip ballers for transport %u", + ctx->ballers.transport_peer); + ctx->started = *Curl_pgrs_now(data); + return CURLE_OK; +} + +static void cf_ip_happy_ctx_clear(struct cf_ip_happy_ctx *ctx, + struct Curl_easy *data) +{ + DEBUGASSERT(ctx); + if(ctx) + cf_ip_ballers_clear(data, &ctx->ballers); +} + +static void cf_ip_happy_ctx_destroy(struct cf_ip_happy_ctx *ctx, + struct Curl_easy *data) +{ + if(ctx) { + cf_ip_happy_ctx_clear(ctx, data); + curlx_free(ctx); + } +} + +static CURLcode cf_ip_happy_shutdown(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ + struct cf_ip_happy_ctx *ctx = cf->ctx; + CURLcode result = CURLE_OK; + + DEBUGASSERT(data); + if(cf->connected) { + *done = TRUE; + return CURLE_OK; + } + + result = cf_ip_ballers_shutdown(&ctx->ballers, data, done); + CURL_TRC_CF(data, cf, "shutdown -> %d, done=%d", (int)result, *done); + return result; +} + +static CURLcode cf_ip_happy_adjust_pollset(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct easy_pollset *ps) +{ + struct cf_ip_happy_ctx *ctx = cf->ctx; + CURLcode result = CURLE_OK; + + if(!cf->connected) { + result = cf_ip_ballers_pollset(&ctx->ballers, data, ps); + CURL_TRC_CF(data, cf, "adjust_pollset -> %d, %u socks", (int)result, + ps->n); + } + return result; +} + +static CURLcode cf_ip_happy_connect(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ + struct cf_ip_happy_ctx *ctx = cf->ctx; + CURLcode result = CURLE_OK; + + /* -Werror=null-dereference finds false positives suddenly. */ + if(!data) + return CURLE_FAILED_INIT; + + if(cf->connected) { + *done = TRUE; + return CURLE_OK; + } + + DEBUGASSERT(ctx); + *done = FALSE; + + if(!ctx->dns_resolved) { + result = Curl_conn_dns_result(cf->conn, cf->sockindex, ctx->ballers.peer); + if(!result) + ctx->dns_resolved = TRUE; + else if(result == CURLE_AGAIN) { + result = CURLE_OK; + } + else /* real error */ + goto out; + } + + switch(ctx->state) { + case SCFST_INIT: + DEBUGASSERT(CURL_SOCKET_BAD == Curl_conn_cf_get_socket(cf, data)); + DEBUGASSERT(!cf->connected); + result = cf_ip_happy_init(cf, data); + if(result) + goto out; + ctx->state = SCFST_WAITING; + FALLTHROUGH(); + case SCFST_WAITING: + result = is_connected(cf, data, done); + if(!result && *done) { + DEBUGASSERT(ctx->ballers.winner); + DEBUGASSERT(ctx->ballers.winner->cf); + DEBUGASSERT(ctx->ballers.winner->cf->connected); + /* we have a winner. Install and activate it. + * close/free all others. */ + ctx->state = SCFST_DONE; + cf->connected = TRUE; + cf->next = ctx->ballers.winner->cf; + ctx->ballers.winner->cf = NULL; + cf_ip_happy_ctx_clear(ctx, data); + Curl_expire_done(data, EXPIRE_HAPPY_EYEBALLS); + /* whatever errors were reported by ballers, clear our errorbuf */ + Curl_reset_fail(data); + + if(cf->conn->scheme->protocol & PROTO_FAMILY_SSH) + Curl_pgrsTime(data, TIMER_APPCONNECT); /* we are connected already */ +#ifdef CURLVERBOSE + if(Curl_trc_cf_is_verbose(cf, data)) { + struct ip_quadruple ipquad; + bool is_ipv6; + if(!Curl_conn_cf_get_ip_info(cf->next, data, &is_ipv6, &ipquad)) { + const char *host; + Curl_conn_get_current_host(data, cf->sockindex, &host, NULL); + CURL_TRC_CF(data, cf, "Connected to %s (%s) port %u", + host, ipquad.remote_ip, ipquad.remote_port); + } + } +#endif + data->info.numconnects++; /* to track the # of connections made */ + } + break; + case SCFST_DONE: + *done = TRUE; + break; + } +out: + return result; +} + +static bool cf_ip_happy_data_pending(struct Curl_cfilter *cf, + const struct Curl_easy *data) +{ + struct cf_ip_happy_ctx *ctx = cf->ctx; + + if(!cf->connected) { + return cf_ip_ballers_pending(&ctx->ballers, data); + } + return cf->next->cft->has_data_pending(cf->next, data); +} + +static CURLcode cf_ip_happy_query(struct Curl_cfilter *cf, + struct Curl_easy *data, + int query, int *pres1, void *pres2) +{ + struct cf_ip_happy_ctx *ctx = cf->ctx; + + if(!cf->connected) { + switch(query) { + case CF_QUERY_CONNECT_REPLY_MS: { + *pres1 = cf_ip_ballers_min_reply_ms(&ctx->ballers, data); + CURL_TRC_CF(data, cf, "query connect reply: %dms", *pres1); + return CURLE_OK; + } + case CF_QUERY_TIMER_CONNECT: { + struct curltime *when = pres2; + *when = cf_ip_ballers_max_time(&ctx->ballers, data, + CF_QUERY_TIMER_CONNECT); + return CURLE_OK; + } + case CF_QUERY_TIMER_APPCONNECT: { + struct curltime *when = pres2; + *when = cf_ip_ballers_max_time(&ctx->ballers, data, + CF_QUERY_TIMER_APPCONNECT); + return CURLE_OK; + } + default: + break; + } + } + + return cf->next ? + cf->next->cft->query(cf->next, data, query, pres1, pres2) : + CURLE_UNKNOWN_OPTION; +} + +static void cf_ip_happy_destroy(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_ip_happy_ctx *ctx = cf->ctx; + + CURL_TRC_CF(data, cf, "destroy"); + if(ctx) { + cf_ip_happy_ctx_clear(ctx, data); + cf_ip_happy_ctx_destroy(ctx, data); + } +} + +struct Curl_cftype Curl_cft_ip_happy = { + "HAPPY-EYEBALLS", + CF_TYPE_SETUP, + CURL_LOG_LVL_NONE, + cf_ip_happy_destroy, + cf_ip_happy_connect, + cf_ip_happy_shutdown, + cf_ip_happy_adjust_pollset, + cf_ip_happy_data_pending, + Curl_cf_def_send, + Curl_cf_def_recv, + Curl_cf_def_cntrl, + Curl_cf_def_conn_is_alive, + Curl_cf_def_conn_keep_alive, + cf_ip_happy_query, +}; + +static CURLcode cf_ip_happy_create(struct Curl_cfilter **pcf, + struct Curl_easy *data, + struct Curl_peer *origin, + struct Curl_peer *peer, + uint8_t transport_peer, + struct connectdata *conn, + struct Curl_peer *tunnel_peer, + uint8_t tunnel_transport) +{ + struct cf_ip_happy_ctx *ctx = NULL; + CURLcode result; + + (void)data; + (void)conn; + *pcf = NULL; + ctx = curlx_calloc(1, sizeof(*ctx)); + if(!ctx) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + result = cf_ip_ballers_init(&ctx->ballers, data, + origin, peer, transport_peer, + tunnel_peer, tunnel_transport, + data->set.happy_eyeballs_timeout, + IP_HE_MAX_CONCURRENT_ATTEMPTS); + if(result) + goto out; + + result = Curl_cf_create(pcf, &Curl_cft_ip_happy, ctx); + +out: + if(result) { + curlx_safefree(*pcf); + cf_ip_happy_ctx_destroy(ctx, data); + } + return result; +} + +CURLcode cf_ip_happy_insert_after(struct Curl_cfilter *cf_at, + struct Curl_easy *data, + struct Curl_peer *origin, + struct Curl_peer *peer, + uint8_t transport_peer, + struct Curl_peer *tunnel_peer, + uint8_t tunnel_transport) +{ + struct Curl_cfilter *cf; + CURLcode result; + + /* Need to be first */ + DEBUGASSERT(cf_at); + result = cf_ip_happy_create(&cf, data, origin, peer, transport_peer, + cf_at->conn, tunnel_peer, tunnel_transport); + if(result) + return result; + + Curl_conn_cf_insert_after(cf_at, cf); + return CURLE_OK; +} diff --git a/3rdparty/curl-8.21.0/lib/cf-ip-happy.h b/3rdparty/curl-8.21.0/lib/cf-ip-happy.h new file mode 100644 index 0000000000..dd9b29ac8f --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/cf-ip-happy.h @@ -0,0 +1,73 @@ +#ifndef HEADER_CURL_IP_HAPPY_H +#define HEADER_CURL_IP_HAPPY_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +struct connectdata; +struct Curl_addrinfo; +struct Curl_cfilter; +struct Curl_easy; +struct Curl_peer; +struct Curl_sockaddr_ex; + +/** + * Create a cfilter to connect to `origin` via an optional `peer` + * using `transport_peer` and `addr`. + * With a `tunnel_peer` present, the filter will be used to proxy tunnel + * to it and the tunnel will use `tunnel_transport`. + * `pcf`: the filter created on success + * `data`: the transfer initiating the connect + * `conn`: the connection that gets connected + * + * The filter is used in "happy eyeball" scenarios. Once connected, + * it MAY be installed in the connection filter chain to serve transfers. + */ +typedef CURLcode cf_ip_connect_create(struct Curl_cfilter **pcf, + struct Curl_easy *data, + struct Curl_peer *origin, + struct Curl_peer *peer, + uint8_t transport_peer, + struct connectdata *conn, + struct Curl_sockaddr_ex *addr, + struct Curl_peer *tunnel_peer, + uint8_t tunnel_transport); + +/** + * Create an IP happy eyeball connection filter that connects to `origin` + * via an optional `peer` using `transport_peer`. + * With a `tunnel_peer` present, the filter will be used to proxy tunnel + * to it and the tunnel will use `tunnel_transport`. + */ +CURLcode cf_ip_happy_insert_after(struct Curl_cfilter *cf_at, + struct Curl_easy *data, + struct Curl_peer *origin, + struct Curl_peer *peer, + uint8_t transport_peer, + struct Curl_peer *tunnel_peer, + uint8_t tunnel_transport); + +extern struct Curl_cftype Curl_cft_ip_happy; + +#endif /* HEADER_CURL_IP_HAPPY_H */ diff --git a/3rdparty/curl-8.21.0/lib/cf-recvbuf.c b/3rdparty/curl-8.21.0/lib/cf-recvbuf.c new file mode 100644 index 0000000000..8ccc148bd3 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/cf-recvbuf.c @@ -0,0 +1,157 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifndef CURL_DISABLE_WEBSOCKETS +/* only used for this protocol, so far */ + +#include "urldata.h" +#include "bufq.h" +#include "cfilters.h" +#include "cf-recvbuf.h" +#include "curl_trc.h" + +#define CURL_CF_RECVBUF_CHUNK (16 * 1024) + +struct cf_recvbuf_ctx { + struct bufq recvbuf; +}; + +static void cf_recvbuf_destroy(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_recvbuf_ctx *ctx = cf->ctx; + (void)data; + if(ctx) { + Curl_bufq_free(&ctx->recvbuf); + curlx_free(ctx); + } +} + +static CURLcode cf_recvbuf_recv(struct Curl_cfilter *cf, + struct Curl_easy *data, + char *buf, size_t len, + size_t *pnread) +{ + struct cf_recvbuf_ctx *ctx = cf->ctx; + + if(!Curl_bufq_is_empty(&ctx->recvbuf)) { + return Curl_bufq_cread(&ctx->recvbuf, buf, len, pnread); + } + + if(cf->next) + return cf->next->cft->do_recv(cf->next, data, buf, len, pnread); + *pnread = 0; + return CURLE_RECV_ERROR; +} + +static bool cf_recvbuf_data_pending(struct Curl_cfilter *cf, + const struct Curl_easy *data) +{ + struct cf_recvbuf_ctx *ctx = cf->ctx; + + if(!Curl_bufq_is_empty(&ctx->recvbuf)) + return TRUE; + + return cf->next ? + cf->next->cft->has_data_pending(cf->next, data) : FALSE; +} + +struct Curl_cftype Curl_cft_recvbuf = { + "RECVBUF", + 0, + CURL_LOG_LVL_NONE, + cf_recvbuf_destroy, + Curl_cf_def_connect, + Curl_cf_def_shutdown, + Curl_cf_def_adjust_pollset, + cf_recvbuf_data_pending, + Curl_cf_def_send, + cf_recvbuf_recv, + Curl_cf_def_cntrl, + Curl_cf_def_conn_is_alive, + Curl_cf_def_conn_keep_alive, + Curl_cf_def_query, +}; + +static CURLcode cf_recvbuf_create(struct Curl_cfilter **pcf, + struct Curl_easy *data, + const uint8_t *buf, size_t blen) +{ + struct Curl_cfilter *cf = NULL; + struct cf_recvbuf_ctx *ctx; + CURLcode result = CURLE_OK; + size_t nwritten = 0; + + (void)data; + ctx = curlx_calloc(1, sizeof(*ctx)); + if(!ctx) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + Curl_bufq_init2(&ctx->recvbuf, CURL_CF_RECVBUF_CHUNK, + (blen / CURL_CF_RECVBUF_CHUNK) + 1, + (BUFQ_OPT_SOFT_LIMIT | BUFQ_OPT_NO_SPARES)); + result = Curl_bufq_write(&ctx->recvbuf, buf, blen, &nwritten); + if(result) + goto out; + if(nwritten != blen) { + result = CURLE_FAILED_INIT; + goto out; + } + + result = Curl_cf_create(&cf, &Curl_cft_recvbuf, ctx); + if(result) + goto out; + ctx = NULL; + +out: + *pcf = result ? NULL : cf; + if(ctx) { + Curl_bufq_free(&ctx->recvbuf); + curlx_free(ctx); + } + return result; +} + +CURLcode Curl_cf_recvbuf_add(struct Curl_easy *data, + struct connectdata *conn, + int sockindex, + const uint8_t *buf, size_t blen) +{ + struct Curl_cfilter *cf; + CURLcode result = CURLE_OK; + + DEBUGASSERT(data); + result = cf_recvbuf_create(&cf, data, buf, blen); + if(result) + goto out; + + cf->connected = Curl_conn_is_connected(conn, sockindex); + Curl_conn_cf_add(data, conn, sockindex, cf); +out: + return result; +} + +#endif /* !CURL_DISABLE_WEBSOCKETS */ diff --git a/3rdparty/curl-8.21.0/lib/cf-recvbuf.h b/3rdparty/curl-8.21.0/lib/cf-recvbuf.h new file mode 100644 index 0000000000..1b08fcc3be --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/cf-recvbuf.h @@ -0,0 +1,40 @@ +#ifndef HEADER_CURL_CF_RECVBUF_H +#define HEADER_CURL_CF_RECVBUF_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifndef CURL_DISABLE_WEBSOCKETS +/* only used for this protocol, so far */ + +CURLcode Curl_cf_recvbuf_add(struct Curl_easy *data, + struct connectdata *conn, + int sockindex, + const uint8_t *buf, size_t blen); + +extern struct Curl_cftype Curl_cft_recvbuf; + +#endif /* !CURL_DISABLE_WEBSOCKETS */ + +#endif /* HEADER_CURL_CF_RECVBUF_H */ diff --git a/3rdparty/curl-8.21.0/lib/cf-setup.c b/3rdparty/curl-8.21.0/lib/cf-setup.c new file mode 100644 index 0000000000..119294a89a --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/cf-setup.c @@ -0,0 +1,476 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "urldata.h" +#include "cfilters.h" +#include "cf-haproxy.h" +#include "cf-ip-happy.h" +#include "cf-setup.h" +#include "curl_trc.h" +#include "connect.h" +#include "http_proxy.h" +#include "socks.h" +#include "vquic/cf-capsule.h" +#include "vquic/vquic.h" +#include "vtls/vtls.h" + + +typedef enum { + CF_SETUP_INIT, + CF_SETUP_CNNCT_EYEBALLS, + CF_SETUP_CNNCT_SOCKS, + CF_SETUP_CNNCT_HTTP_PROXY, + CF_SETUP_CNNCT_HAPROXY, + CF_SETUP_CNNCT_SSL, + CF_SETUP_DONE +} cf_setup_state; + +struct cf_setup_ctx { + cf_setup_state state; + int ssl_mode; + uint8_t transport; + uint8_t retry_count; +}; + +#ifndef CURL_DISABLE_PROXY + +static CURLcode cf_setup_add_haproxy(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_setup_ctx *ctx = cf->ctx; + CURLcode result = CURLE_OK; + + if(ctx->state < CF_SETUP_CNNCT_HAPROXY) { + if(data->set.haproxyprotocol) { + if(ctx->transport == TRNSPRT_QUIC) { + failf(data, "haproxy protocol does not support QUIC"); + return CURLE_UNSUPPORTED_PROTOCOL; + } + result = Curl_cf_haproxy_insert_after(cf, data); + if(result) { + CURL_TRC_CF(data, cf, "adding HAPROXY filter failed -> %d", + (int)result); + return result; + } + CURL_TRC_CF(data, cf, "added HAPROXY filter"); + } + ctx->state = CF_SETUP_CNNCT_HAPROXY; + } + return result; +} + +static CURLcode cf_setup_add_socks(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_setup_ctx *ctx = cf->ctx; + CURLcode result = CURLE_OK; + if(ctx->state < CF_SETUP_CNNCT_SOCKS && cf->conn->socks_proxy.peer) { + /* Add a SOCKS proxy to go through `first_peer` to `second_peer`*/ + struct Curl_peer *second_peer; + + if(cf->conn->http_proxy.peer) + second_peer = cf->conn->http_proxy.peer; + else + second_peer = Curl_conn_get_destination(cf->conn, cf->sockindex); + if(!second_peer) + return CURLE_FAILED_INIT; + + result = Curl_cf_socks_proxy_insert_after( + cf, data, second_peer, cf->conn->ip_version, + cf->conn->socks_proxy.proxytype, + cf->conn->socks_proxy.creds); + if(result) { + CURL_TRC_CF(data, cf, "adding SOCKS filter failed -> %d", (int)result); + return result; + } + + CURL_TRC_CF(data, cf, "added SOCKS filter to %s:%u", + second_peer->hostname, second_peer->port); + ctx->state = CF_SETUP_CNNCT_SOCKS; + } + return result; +} + +#ifndef CURL_DISABLE_HTTP +static CURLcode cf_setup_add_http_proxy(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_setup_ctx *ctx = cf->ctx; + CURLcode result = CURLE_OK; + + if(ctx->state < CF_SETUP_CNNCT_HTTP_PROXY && + cf->conn->http_proxy.peer && !cf->conn->bits.origin_is_proxy) { + struct Curl_peer *peer = cf->conn->http_proxy.peer; + struct Curl_peer *tunnel_peer = + Curl_conn_get_destination(cf->conn, cf->sockindex); + +#ifdef USE_SSL + if(CURL_PROXY_IS_HTTPS(cf->conn->http_proxy.proxytype) && + !Curl_conn_is_ssl(cf->conn, cf->sockindex)) { + result = Curl_cf_ssl_proxy_insert_after( + cf, data, cf->conn->http_proxy.peer); + if(result) { + CURL_TRC_CF(data, cf, "adding SSL filter for HTTP proxy failed -> %d", + (int)result); + return result; + } + CURL_TRC_CF(data, cf, "added SSL filter for HTTP proxy"); + } +#endif /* USE_SSL */ + + result = Curl_cf_http_proxy_insert_after( + cf, data, peer, tunnel_peer, + ctx->transport, cf->conn->http_proxy.proxytype); + if(result) { + CURL_TRC_CF(data, cf, "adding HTTP proxy tunnel filter failed -> %d", + (int)result); + return result; + } + CURL_TRC_CF(data, cf, "added HTTP proxy tunnel filter"); + ctx->state = CF_SETUP_CNNCT_HTTP_PROXY; + } + return result; +} +#endif /* !CURL_DISABLE_HTTP */ +#endif /* CURL_DISABLE_PROXY */ + +/* Get the origin curl connects its socket to. + * Can be origin or the first proxy. */ +static struct Curl_peer *conn_get_first_origin(struct connectdata *conn, + int sockindex) +{ +#ifndef CURL_DISABLE_PROXY + if(conn->socks_proxy.peer) + return conn->socks_proxy.peer; + if(conn->http_proxy.peer) + return conn->http_proxy.peer; +#endif + return (sockindex == SECONDARYSOCKET) ? conn->origin2 : conn->origin; +} + +static CURLcode cf_setup_add_ip_happy(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_setup_ctx *ctx = cf->ctx; + CURLcode result = CURLE_OK; + + if(ctx->state < CF_SETUP_CNNCT_EYEBALLS) { + /* What is the first hop we directly connect to and what transport + * do we use for it? Only on the first hop we can do Happy Eyeballs. + * first_origin and first_peer differ on --connect-to. */ + struct Curl_peer *first_origin = + conn_get_first_origin(cf->conn, cf->sockindex); + struct Curl_peer *first_peer = + Curl_conn_get_first_peer(cf->conn, cf->sockindex); + struct Curl_peer *tunnel_peer = NULL; + uint8_t first_transport = ctx->transport; + + if(!first_peer) + return CURLE_FAILED_INIT; + +#if !defined(CURL_DISABLE_PROXY) && !defined(CURL_DISABLE_HTTP) + if(cf->conn->http_proxy.peer && !cf->conn->bits.origin_is_proxy) { + first_transport = + Curl_http_proxy_transport(cf->conn->http_proxy.proxytype); + tunnel_peer = Curl_conn_get_destination(cf->conn, cf->sockindex); + if((first_transport == TRNSPRT_QUIC) && cf->conn->socks_proxy.peer) { + failf(data, "HTTP/3 proxy not possible via SOCKS"); + return CURLE_UNSUPPORTED_PROTOCOL; + } + } +#endif /* !CURL_DISABLE_PROXY && !CURL_DISABLE_HTTP */ + + result = cf_ip_happy_insert_after(cf, data, first_origin, first_peer, + first_transport, + tunnel_peer, ctx->transport); + if(result) { + CURL_TRC_CF(data, cf, "adding happy eyeballs failed -> %d", (int)result); + return result; + } + + if(tunnel_peer && (first_transport == TRNSPRT_QUIC)) { + CURL_TRC_CF(data, cf, "happy eyeballing to HTTP/3 proxy %s:%u", + first_peer->hostname, first_peer->port); + ctx->state = CF_SETUP_CNNCT_HTTP_PROXY; + } + else { + CURL_TRC_CF(data, cf, "happy eyeballing to %s %s:%u", + tunnel_peer ? "proxy" : "origin", + first_peer->hostname, first_peer->port); + ctx->state = CF_SETUP_CNNCT_EYEBALLS; + } + } + return result; +} + +static CURLcode cf_setup_add_origin_filters(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_setup_ctx *ctx = cf->ctx; + CURLcode result = CURLE_OK; + + (void)data; /* not used in all builds */ + if(ctx->state < CF_SETUP_CNNCT_SSL) { +#if !defined(CURL_DISABLE_HTTP) && defined(USE_HTTP3) && \ + !defined(CURL_DISABLE_PROXY) + + /* Wanting QUIC with an HTTP tunneling filter, we now need to add + * the QUIC filter on top. Without tunneling, this has already + * happened in the Happy Eyeball filter. */ + if(ctx->transport == TRNSPRT_QUIC && + cf->conn->http_proxy.peer && !cf->conn->bits.origin_is_proxy) { + struct Curl_peer *origin = Curl_conn_get_origin(cf->conn, cf->sockindex); + struct Curl_peer *peer = + Curl_conn_get_destination(cf->conn, cf->sockindex); + + result = Curl_cf_capsule_insert_after(cf, data); + if(result) { + CURL_TRC_CF(data, cf, "adding capsule filter failed -> %d", + (int)result); + return result; + } + result = Curl_cf_quic_insert_after(cf, origin, peer); + if(result) { + CURL_TRC_CF(data, cf, "adding QUIC filter failed -> %d", (int)result); + return result; + } + CURL_TRC_CF(data, cf, "added QUIC filter for origin"); + } + else +#endif /* !CURL_DISABLE_HTTP && USE_HTTP3 && CURL_DISABLE_PROXY */ +#ifdef USE_SSL + if((ctx->ssl_mode == CURL_CF_SSL_ENABLE || + (ctx->ssl_mode != CURL_CF_SSL_DISABLE && + cf->conn->scheme->flags & PROTOPT_SSL)) && /* we want SSL */ + !Curl_conn_is_ssl(cf->conn, cf->sockindex)) { /* it is missing */ + +#ifndef CURL_DISABLE_PROXY + if(cf->conn->bits.origin_is_proxy) { + result = Curl_cf_ssl_proxy_insert_after(cf, data, cf->conn->origin); + } + else +#endif + { + /* Another FTP quirk: when adding SSL verification, to a DATA + * connection, always verify against the control's origin */ + struct Curl_peer *origin = Curl_conn_get_origin(cf->conn, FIRSTSOCKET); + struct Curl_peer *peer = + Curl_conn_get_destination(cf->conn, cf->sockindex); + result = Curl_cf_ssl_insert_after(cf, data, origin, peer); + } + if(result) { + CURL_TRC_CF(data, cf, "adding SSL filter for origin failed -> %d", + (int)result); + return result; + } + CURL_TRC_CF(data, cf, "added SSL filter for origin"); + } +#endif /* USE_SSL */ + ctx->state = CF_SETUP_CNNCT_SSL; + } + return result; +} + +static CURLcode cf_setup_connect_steps(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ + struct cf_setup_ctx *ctx = cf->ctx; + CURLcode result = CURLE_OK; + + if(cf->connected) { + *done = TRUE; + return CURLE_OK; + } + + /* connect current sub-chain */ +connect_sub_chain: + VERBOSE(Curl_conn_trc_filters(data, cf->sockindex, "cf_setup_connect")); + + if(cf->next && !cf->next->connected) { + result = Curl_conn_cf_connect(cf->next, data, done); + if(result || !*done) + return result; + } + + result = cf_setup_add_ip_happy(cf, data); + if(result) + return result; + if(!cf->next || !cf->next->connected) + goto connect_sub_chain; + +#ifndef CURL_DISABLE_PROXY + result = cf_setup_add_socks(cf, data); + if(result) + return result; + if(!cf->next || !cf->next->connected) + goto connect_sub_chain; + +#ifndef CURL_DISABLE_HTTP + result = cf_setup_add_http_proxy(cf, data); + if(result) + return result; + if(!cf->next || !cf->next->connected) + goto connect_sub_chain; +#endif /* !CURL_DISABLE_HTTP */ + + result = cf_setup_add_haproxy(cf, data); + if(result) + return result; + if(!cf->next || !cf->next->connected) + goto connect_sub_chain; +#endif /* !CURL_DISABLE_PROXY */ + + result = cf_setup_add_origin_filters(cf, data); + if(result) + return result; + if(!cf->next || !cf->next->connected) + goto connect_sub_chain; + + ctx->state = CF_SETUP_DONE; + cf->connected = TRUE; + *done = TRUE; + return CURLE_OK; +} + +static CURLcode cf_setup_connect(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ + struct cf_setup_ctx *ctx = cf->ctx; + CURLcode result; + + /* In some situations, a server/proxy may close the connection and + * we need to connect again (HTTP/1.x proxy auth, for example). + * We used to close the filters and reuse them for another attempt, + * however that complicates filter code and it is simpler to tear them + * all down and start over. */ +retry: + result = cf_setup_connect_steps(cf, data, done); + + if(result == CURLE_AGAIN) { + ++ctx->retry_count; + if(ctx->retry_count > 5) /* arbitrary limit, better just timeout? */ + return CURLE_COULDNT_CONNECT; + + CURL_TRC_CF(data, cf, "retrying connect, %d. time", ctx->retry_count); + Curl_conn_cf_discard_chain(&cf->next, data); + ctx->state = CF_SETUP_INIT; + goto retry; + } + return result; +} + +static void cf_setup_destroy(struct Curl_cfilter *cf, struct Curl_easy *data) +{ + struct cf_setup_ctx *ctx = cf->ctx; + + CURL_TRC_CF(data, cf, "destroy"); + curlx_safefree(ctx); +} + +struct Curl_cftype Curl_cft_setup = { + "SETUP", + CF_TYPE_SETUP, + CURL_LOG_LVL_NONE, + cf_setup_destroy, + cf_setup_connect, + Curl_cf_def_shutdown, + Curl_cf_def_adjust_pollset, + Curl_cf_def_data_pending, + Curl_cf_def_send, + Curl_cf_def_recv, + Curl_cf_def_cntrl, + Curl_cf_def_conn_is_alive, + Curl_cf_def_conn_keep_alive, + Curl_cf_def_query, +}; + +static CURLcode cf_setup_create(struct Curl_cfilter **pcf, + struct Curl_easy *data, + uint8_t transport, + int ssl_mode) +{ + struct Curl_cfilter *cf = NULL; + struct cf_setup_ctx *ctx; + CURLcode result = CURLE_OK; + + (void)data; + ctx = curlx_calloc(1, sizeof(*ctx)); + if(!ctx) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + ctx->state = CF_SETUP_INIT; + ctx->ssl_mode = ssl_mode; + ctx->transport = transport; + + result = Curl_cf_create(&cf, &Curl_cft_setup, ctx); + if(result) + goto out; + ctx = NULL; + +out: + *pcf = result ? NULL : cf; + if(ctx) { + curlx_free(ctx); + } + return result; +} + +CURLcode Curl_cf_setup_add(struct Curl_easy *data, + struct connectdata *conn, + int sockindex, + uint8_t transport, + int ssl_mode) +{ + struct Curl_cfilter *cf; + CURLcode result = CURLE_OK; + + DEBUGASSERT(data); + result = cf_setup_create(&cf, data, transport, ssl_mode); + if(result) + goto out; + Curl_conn_cf_add(data, conn, sockindex, cf); +out: + return result; +} + +CURLcode Curl_cf_setup_insert_after(struct Curl_cfilter *cf_at, + struct Curl_easy *data, + uint8_t transport, + int ssl_mode) +{ + struct Curl_cfilter *cf; + CURLcode result; + + DEBUGASSERT(data); + result = cf_setup_create(&cf, data, transport, ssl_mode); + if(result) + goto out; + Curl_conn_cf_insert_after(cf_at, cf); +out: + return result; +} diff --git a/3rdparty/curl-8.21.0/lib/cf-setup.h b/3rdparty/curl-8.21.0/lib/cf-setup.h new file mode 100644 index 0000000000..80e20064b8 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/cf-setup.h @@ -0,0 +1,46 @@ +#ifndef HEADER_CURL_CF_SETUP_H +#define HEADER_CURL_CF_SETUP_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +struct Curl_dns_entry; +struct ip_quadruple; +struct Curl_peer; +struct Curl_str; + +CURLcode Curl_cf_setup_add(struct Curl_easy *data, + struct connectdata *conn, + int sockindex, + uint8_t transport, + int ssl_mode); + +CURLcode Curl_cf_setup_insert_after(struct Curl_cfilter *cf_at, + struct Curl_easy *data, + uint8_t transport, + int ssl_mode); + +extern struct Curl_cftype Curl_cft_setup; + +#endif /* HEADER_CURL_CF_SETUP_H */ diff --git a/3rdparty/curl-8.21.0/lib/cf-socket.c b/3rdparty/curl-8.21.0/lib/cf-socket.c new file mode 100644 index 0000000000..0741f2ba41 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/cf-socket.c @@ -0,0 +1,2349 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef HAVE_NETINET_IN_H +#include /* may need it */ +#endif +#ifdef HAVE_SYS_UN_H +#include /* for sockaddr_un */ +#endif +#ifdef HAVE_LINUX_TCP_H +#include +#elif defined(HAVE_NETINET_TCP_H) +#include +#endif +#ifdef HAVE_NETINET_UDP_H +#include +#endif +#ifdef HAVE_SYS_IOCTL_H +#include +#endif +#ifdef HAVE_NETDB_H +#include +#endif +#ifdef HAVE_ARPA_INET_H +#include +#endif + +#ifdef HAVE_IFADDRS_H +#include +#endif +#ifdef HAVE_NET_IF_H +#include +#endif +#ifdef __VMS +#include +#include +#endif + +#include "urldata.h" +#include "curl_trc.h" +#include "if2ip.h" +#include "cfilters.h" +#include "cf-socket.h" +#include "connect.h" +#include "curl_addrinfo.h" +#include "select.h" +#include "multiif.h" +#include "curlx/inet_ntop.h" +#include "curlx/inet_pton.h" +#include "progress.h" +#include "conncache.h" +#include "multihandle.h" +#include "rand.h" +#include "sockaddr.h" +#include "curlx/strdup.h" +#include "system_win32.h" +#include "curlx/nonblock.h" +#include "curlx/strcopy.h" +#include "curlx/version_win32.h" +#include "curlx/strerr.h" +#include "curlx/strparse.h" + + +/* retrieves ip address and port from a sockaddr structure. note it calls + * curlx_inet_ntop which sets errno on fail, not SOCKERRNO. + * @unittest 1607 + */ +UNITTEST bool sockaddr2string(struct sockaddr *sa, curl_socklen_t salen, + char *addr, uint16_t *port); +UNITTEST bool sockaddr2string(struct sockaddr *sa, curl_socklen_t salen, + char *addr, uint16_t *port) +{ + struct sockaddr_in *si = NULL; +#ifdef USE_IPV6 + struct sockaddr_in6 *si6 = NULL; +#endif +#ifdef USE_UNIX_SOCKETS + struct sockaddr_un *su = NULL; +#else + (void)salen; +#endif + + switch(sa->sa_family) { + case AF_INET: + si = (struct sockaddr_in *)(void *)sa; + if(curlx_inet_ntop(sa->sa_family, &si->sin_addr, addr, MAX_IPADR_LEN)) { + *port = ntohs(si->sin_port); + return TRUE; + } + break; +#ifdef USE_IPV6 + case AF_INET6: + si6 = (struct sockaddr_in6 *)(void *)sa; + if(curlx_inet_ntop(sa->sa_family, &si6->sin6_addr, addr, MAX_IPADR_LEN)) { + *port = ntohs(si6->sin6_port); + return TRUE; + } + break; +#endif +#ifdef USE_UNIX_SOCKETS + case AF_UNIX: + if(salen > (curl_socklen_t)sizeof(CURL_SA_FAMILY_T)) { + su = (struct sockaddr_un *)sa; + curl_msnprintf(addr, MAX_IPADR_LEN, "%s", su->sun_path); + } + else + addr[0] = 0; /* socket with no name */ + *port = 0; + return TRUE; +#endif + default: + break; + } + + addr[0] = '\0'; + *port = 0; + errno = SOCKEAFNOSUPPORT; + return FALSE; +} + +static void tcpnodelay(struct Curl_cfilter *cf, + struct Curl_easy *data, + curl_socket_t sockfd) +{ +#if defined(TCP_NODELAY) && defined(CURL_TCP_NODELAY_SUPPORTED) + curl_socklen_t onoff = (curl_socklen_t)1; + int level = IPPROTO_TCP; + VERBOSE(char buffer[STRERROR_LEN]); + + if(setsockopt(sockfd, level, TCP_NODELAY, (void *)&onoff, sizeof(onoff)) < 0) + CURL_TRC_CF(data, cf, "Could not set TCP_NODELAY: %s", + curlx_strerror(SOCKERRNO, buffer, sizeof(buffer))); +#else + (void)cf; + (void)data; + (void)sockfd; +#endif +} + +#if defined(USE_WINSOCK) || defined(TCP_KEEPIDLE) || \ + defined(TCP_KEEPALIVE) || defined(TCP_KEEPALIVE_THRESHOLD) || \ + defined(TCP_KEEPINTVL) || defined(TCP_KEEPALIVE_ABORT_THRESHOLD) +#if defined(USE_WINSOCK) || \ + (defined(__sun) && !defined(TCP_KEEPIDLE)) || \ + (defined(__DragonFly__) && __DragonFly_version < 500702) || \ + (defined(_WIN32) && !defined(TCP_KEEPIDLE)) +/* Solaris < 11.4, DragonFlyBSD < 500702 and Windows < 10.0.16299 + * use millisecond units. */ +#define KEEPALIVE_FACTOR(x) ((x) *= 1000) +#else +#define KEEPALIVE_FACTOR(x) +#endif +#endif + +static void tcpkeepalive(struct Curl_cfilter *cf, + struct Curl_easy *data, + curl_socket_t sockfd) +{ + int optval = data->set.tcp_keepalive ? 1 : 0; + + /* only set IDLE and INTVL if setting KEEPALIVE is successful */ + if(setsockopt(sockfd, SOL_SOCKET, SO_KEEPALIVE, + (void *)&optval, sizeof(optval)) < 0) { + CURL_TRC_CF(data, cf, "Failed to set SO_KEEPALIVE on fd " + "%" FMT_SOCKET_T ": errno %d", sockfd, SOCKERRNO); + } + else { +#ifdef USE_WINSOCK + /* Windows 10, version 1709 (10.0.16299) and later versions can use + setsockopt() TCP_KEEP*. Older versions return with failure. */ + if(curlx_verify_windows_version(10, 0, 16299, PLATFORM_WINNT, + VERSION_GREATER_THAN_EQUAL)) { + CURL_TRC_CF(data, cf, "Set TCP_KEEP* on fd=%" FMT_SOCKET_T, sockfd); + optval = curlx_sltosi(data->set.tcp_keepidle); +/* Offered by mingw-w64 v12+, MS SDK 6.0A/VS2008+ */ +#ifndef TCP_KEEPALIVE +#define TCP_KEEPALIVE 3 +#endif +/* Offered by mingw-w64 v12+, MS SDK 10.0.15063.0/VS2017 15.1+ */ +#ifndef TCP_KEEPCNT +#define TCP_KEEPCNT 16 +#endif +/* Offered by mingw-w64 v12+, MS SDK 10.0.16299.0/VS2017 15.4+ */ +#ifndef TCP_KEEPIDLE +#define TCP_KEEPIDLE TCP_KEEPALIVE +#endif +#ifndef TCP_KEEPINTVL +#define TCP_KEEPINTVL 17 +#endif + if(setsockopt(sockfd, IPPROTO_TCP, TCP_KEEPIDLE, + (const char *)&optval, sizeof(optval)) < 0) { + CURL_TRC_CF(data, cf, "Failed to set TCP_KEEPIDLE on fd " + "%" FMT_SOCKET_T ": errno %d", sockfd, SOCKERRNO); + } + optval = curlx_sltosi(data->set.tcp_keepintvl); + if(setsockopt(sockfd, IPPROTO_TCP, TCP_KEEPINTVL, + (const char *)&optval, sizeof(optval)) < 0) { + CURL_TRC_CF(data, cf, "Failed to set TCP_KEEPINTVL on fd " + "%" FMT_SOCKET_T ": errno %d", sockfd, SOCKERRNO); + } + optval = curlx_sltosi(data->set.tcp_keepcnt); + if(setsockopt(sockfd, IPPROTO_TCP, TCP_KEEPCNT, + (const char *)&optval, sizeof(optval)) < 0) { + CURL_TRC_CF(data, cf, "Failed to set TCP_KEEPCNT on fd " + "%" FMT_SOCKET_T ": errno %d", sockfd, SOCKERRNO); + } + } + else { +/* Offered by mingw-w64 and MS SDK. Latter only when targeting Win7+. */ +#ifndef SIO_KEEPALIVE_VALS +#define SIO_KEEPALIVE_VALS _WSAIOW(IOC_VENDOR, 4) + struct tcp_keepalive { + u_long onoff; + u_long keepalivetime; + u_long keepaliveinterval; + }; +#endif + struct tcp_keepalive vals; + DWORD dummy; + vals.onoff = 1; + optval = curlx_sltosi(data->set.tcp_keepidle); + KEEPALIVE_FACTOR(optval); + vals.keepalivetime = (u_long)optval; + optval = curlx_sltosi(data->set.tcp_keepintvl); + KEEPALIVE_FACTOR(optval); + vals.keepaliveinterval = (u_long)optval; + if(WSAIoctl(sockfd, SIO_KEEPALIVE_VALS, (LPVOID)&vals, sizeof(vals), + NULL, 0, &dummy, NULL, NULL) != 0) { + CURL_TRC_CF(data, cf, "Failed to set SIO_KEEPALIVE_VALS on fd " + "%" FMT_SOCKET_T ": errno %d", sockfd, SOCKERRNO); + } + } +#else /* !USE_WINSOCK */ +#ifdef TCP_KEEPIDLE + optval = curlx_sltosi(data->set.tcp_keepidle); + KEEPALIVE_FACTOR(optval); + if(setsockopt(sockfd, IPPROTO_TCP, TCP_KEEPIDLE, + (void *)&optval, sizeof(optval)) < 0) { + CURL_TRC_CF(data, cf, "Failed to set TCP_KEEPIDLE on fd " + "%" FMT_SOCKET_T ": errno %d", sockfd, SOCKERRNO); + } +#elif defined(TCP_KEEPALIVE) + /* macOS style */ + optval = curlx_sltosi(data->set.tcp_keepidle); + KEEPALIVE_FACTOR(optval); + if(setsockopt(sockfd, IPPROTO_TCP, TCP_KEEPALIVE, + (void *)&optval, sizeof(optval)) < 0) { + CURL_TRC_CF(data, cf, "Failed to set TCP_KEEPALIVE on fd " + "%" FMT_SOCKET_T ": errno %d", sockfd, SOCKERRNO); + } +#elif defined(TCP_KEEPALIVE_THRESHOLD) + /* Solaris <11.4 style */ + optval = curlx_sltosi(data->set.tcp_keepidle); + KEEPALIVE_FACTOR(optval); + if(setsockopt(sockfd, IPPROTO_TCP, TCP_KEEPALIVE_THRESHOLD, + (void *)&optval, sizeof(optval)) < 0) { + CURL_TRC_CF(data, cf, "Failed to set TCP_KEEPALIVE_THRESHOLD on fd " + "%" FMT_SOCKET_T ": errno %d", sockfd, SOCKERRNO); + } +#endif +#ifdef TCP_KEEPINTVL + optval = curlx_sltosi(data->set.tcp_keepintvl); + KEEPALIVE_FACTOR(optval); + if(setsockopt(sockfd, IPPROTO_TCP, TCP_KEEPINTVL, + (void *)&optval, sizeof(optval)) < 0) { + CURL_TRC_CF(data, cf, "Failed to set TCP_KEEPINTVL on fd " + "%" FMT_SOCKET_T ": errno %d", sockfd, SOCKERRNO); + } +#elif defined(TCP_KEEPALIVE_ABORT_THRESHOLD) + /* Solaris <11.4 style */ + /* TCP_KEEPALIVE_ABORT_THRESHOLD should equal to + * TCP_KEEPCNT * TCP_KEEPINTVL on other platforms. + * The default value of TCP_KEEPCNT is 9 on Linux, + * 8 on *BSD/macOS, 5 or 10 on Windows. We use the + * default config for Solaris <11.4 because there is + * no default value for TCP_KEEPCNT on Solaris 11.4. + * + * Note that the consequent probes will not be sent + * at equal intervals on Solaris, but will be sent + * using the exponential backoff algorithm. */ + { + int keepcnt = curlx_sltosi(data->set.tcp_keepcnt); + int keepintvl = curlx_sltosi(data->set.tcp_keepintvl); + + if(keepcnt > 0 && keepintvl > (INT_MAX / keepcnt)) + optval = INT_MAX; + else + optval = keepcnt * keepintvl; + } + KEEPALIVE_FACTOR(optval); + if(setsockopt(sockfd, IPPROTO_TCP, TCP_KEEPALIVE_ABORT_THRESHOLD, + (void *)&optval, sizeof(optval)) < 0) { + CURL_TRC_CF(data, cf, "Failed to set TCP_KEEPALIVE_ABORT_THRESHOLD" + " on fd %" FMT_SOCKET_T ": errno %d", sockfd, SOCKERRNO); + } +#endif +#ifdef TCP_KEEPCNT + optval = curlx_sltosi(data->set.tcp_keepcnt); + if(setsockopt(sockfd, IPPROTO_TCP, TCP_KEEPCNT, + (void *)&optval, sizeof(optval)) < 0) { + CURL_TRC_CF(data, cf, "Failed to set TCP_KEEPCNT on fd " + "%" FMT_SOCKET_T ": errno %d", sockfd, SOCKERRNO); + } +#endif +#endif /* USE_WINSOCK */ + } +} + +/** + * Assign the addrinfo `ai` to the Curl_sockaddr_ex `addr` with + * transport determining socktype and protocol. + */ +CURLcode Curl_socket_addr_from_ai(struct Curl_sockaddr_ex *addr, + const struct Curl_addrinfo *ai, + uint8_t transport) +{ + /* + * The Curl_sockaddr_ex structure is libcurl's external API + * curl_sockaddr structure with enough space available to directly hold + * any protocol-specific address structures. The variable declared here + * will be used to pass / receive data to/from the fopensocket callback + * if this has been set, before that, it is initialized from parameters. + */ + addr->family = ai->ai_family; + addr->socktype = Curl_socktype_for_transport(transport); + addr->protocol = Curl_protocol_for_transport(transport); + addr->addrlen = (unsigned int)ai->ai_addrlen; + + DEBUGASSERT(addr->addrlen <= sizeof(addr->curl_sa_addrbuf)); + if(addr->addrlen > sizeof(addr->curl_sa_addrbuf)) + return CURLE_TOO_LARGE; + + memcpy(&addr->curl_sa_addrbuf, ai->ai_addr, addr->addrlen); + return CURLE_OK; +} + +#ifdef USE_SO_NOSIGPIPE +int Curl_sock_nosigpipe(curl_socket_t sockfd) +{ + int onoff = 1; + return setsockopt(sockfd, SOL_SOCKET, SO_NOSIGPIPE, + (void *)&onoff, sizeof(onoff)); +} +#endif /* USE_SO_NOSIGPIPE */ + +#if defined(USE_IPV6) && defined(HAVE_SOCKADDR_IN6_SIN6_SCOPE_ID) +static uint32_t get_scope_id(struct Curl_easy *data, + struct sockaddr_in6 *sa6) +{ + uint32_t scope_id = 0; + if(data->conn->scope_id) + return data->conn->scope_id; + /* NOLINTNEXTLINE(clang-analyzer-core.uninitialized.Assign) */ + scope_id = sa6->sin6_scope_id; + if(!scope_id && IN6_IS_ADDR_LINKLOCAL(&sa6->sin6_addr)) { + /* The resolver did not set scope_id for this link-local address. + * Try to determine it from the system's network interfaces. + * Without a scope_id, connect() to a link-local address fails + * with EINVAL on Linux. + * NOTE: On multi-homed hosts with several interfaces having + * link-local addresses, this picks the first one found, which + * may not be the correct outgoing interface. */ +#if defined(HAVE_GETIFADDRS) && defined(HAVE_NET_IF_H) + struct ifaddrs *ifa, *ifa_list; + if(getifaddrs(&ifa_list) == 0) { + for(ifa = ifa_list; ifa; ifa = ifa->ifa_next) { + if(ifa->ifa_addr && ifa->ifa_addr->sa_family == AF_INET6 && + (ifa->ifa_flags & IFF_UP) && + !(ifa->ifa_flags & IFF_LOOPBACK)) { + struct sockaddr_in6 *s6 = (void *)ifa->ifa_addr; + if(IN6_IS_ADDR_LINKLOCAL(&s6->sin6_addr) && s6->sin6_scope_id) { + scope_id = s6->sin6_scope_id; + infof(data, + "determined scope_id=%lu for link-local address " + "from local interface", + (unsigned long)scope_id); + break; + } + } + } + freeifaddrs(ifa_list); + } +#endif /* HAVE_GETIFADDRS && HAVE_NET_IF_H */ + } + return scope_id; +} +#endif + +static CURLcode socket_open(struct Curl_easy *data, + struct Curl_sockaddr_ex *addr, + curl_socket_t *sockfd) +{ + char errbuf[STRERROR_LEN]; + +#ifdef SOCK_CLOEXEC + addr->socktype |= SOCK_CLOEXEC; +#endif + + DEBUGASSERT(data); + DEBUGASSERT(data->conn); + if(data->set.fopensocket) { + /* + * If the opensocket callback is set, all the destination address + * information is passed to the callback. Depending on this information the + * callback may opt to abort the connection, this is indicated returning + * CURL_SOCKET_BAD; otherwise it will return a not-connected socket. When + * the callback returns a valid socket the destination address information + * might have been changed and this 'new' address will actually be used + * here to connect. + */ + Curl_set_in_callback(data, TRUE); + *sockfd = data->set.fopensocket(data->set.opensocket_client, + CURLSOCKTYPE_IPCXN, + (struct curl_sockaddr *)addr); + Curl_set_in_callback(data, FALSE); + } + else { + /* opensocket callback not set, so create the socket now */ +#ifdef DEBUGBUILD + if((addr->family == AF_INET6) && getenv("CURL_DBG_SOCK_FAIL_IPV6")) { + failf(data, "CURL_DBG_SOCK_FAIL_IPV6: failed to open socket"); + return CURLE_COULDNT_CONNECT; + } +#endif + *sockfd = CURL_SOCKET(addr->family, addr->socktype, addr->protocol); + if((*sockfd == CURL_SOCKET_BAD) && (SOCKERRNO == SOCKENOMEM)) + return CURLE_OUT_OF_MEMORY; + } + + if(*sockfd == CURL_SOCKET_BAD) { + /* no socket, no connection */ + failf(data, "failed to open socket: %s", + curlx_strerror(SOCKERRNO, errbuf, sizeof(errbuf))); + return CURLE_COULDNT_CONNECT; + } + +#ifdef USE_SO_NOSIGPIPE + if(Curl_sock_nosigpipe(*sockfd) < 0) { + failf(data, "setsockopt enable SO_NOSIGPIPE: %s", + curlx_strerror(SOCKERRNO, errbuf, sizeof(errbuf))); + sclose(*sockfd); + *sockfd = CURL_SOCKET_BAD; + return CURLE_COULDNT_CONNECT; + } +#endif /* USE_SO_NOSIGPIPE */ + +#if defined(HAVE_FCNTL) && !defined(SOCK_CLOEXEC) + if(fcntl(*sockfd, F_SETFD, FD_CLOEXEC) < 0) { + failf(data, "fcntl set CLOEXEC: %s", + curlx_strerror(SOCKERRNO, errbuf, sizeof(errbuf))); + sclose(*sockfd); + *sockfd = CURL_SOCKET_BAD; + return CURLE_COULDNT_CONNECT; + } +#endif + +#if defined(USE_IPV6) && defined(HAVE_SOCKADDR_IN6_SIN6_SCOPE_ID) + if(addr->family == AF_INET6) { + struct sockaddr_in6 * const sa6 = (void *)&addr->curl_sa_addr; + sa6->sin6_scope_id = get_scope_id(data, sa6); + } +#endif + return CURLE_OK; +} + +/* + * Create a socket based on info from 'conn' and 'ai'. + * + * 'addr' should be a pointer to the correct struct to get data back, or NULL. + * 'sockfd' must be a pointer to a socket descriptor. + * + * If the open socket callback is set, used that! + * + */ +CURLcode Curl_socket_open(struct Curl_easy *data, + const struct Curl_addrinfo *ai, + struct Curl_sockaddr_ex *addr, + uint8_t transport, + curl_socket_t *sockfd) +{ + struct Curl_sockaddr_ex dummy; + CURLcode result; + + if(!addr) + /* if the caller does not want info back, use a local temp copy */ + addr = &dummy; + + result = Curl_socket_addr_from_ai(addr, ai, transport); + if(result) + return result; + + return socket_open(data, addr, sockfd); +} + +static int socket_close(struct Curl_easy *data, struct connectdata *conn, + int use_callback, curl_socket_t sock) +{ + if(sock == CURL_SOCKET_BAD) + return 0; + + if(use_callback && conn && conn->fclosesocket) { + int rc; + Curl_multi_will_close(data, sock); + Curl_set_in_callback(data, TRUE); + rc = conn->fclosesocket(conn->closesocket_client, sock); + Curl_set_in_callback(data, FALSE); + return rc; + } + + if(conn) + /* tell the multi-socket code about this */ + Curl_multi_will_close(data, sock); + + sclose(sock); + + return 0; +} + +/* + * Close a socket. + * + * 'conn' can be NULL, beware! + */ +int Curl_socket_close(struct Curl_easy *data, struct connectdata *conn, + curl_socket_t sock) +{ + return socket_close(data, conn, FALSE, sock); +} + +/* + * Curl_parse_interface() + * + * This is used to parse interface argument in the following formats. + * In all the examples, `host` can be an IP address or a hostname. + * + * - can be either an interface name or a host. + * if! - interface name. + * host! - hostname. + * ifhost!! - interface name and hostname. + * + * Parameters: + * + * input [in] - input string. + * len [in] - length of the input string. + * dev [in/out] - address where a pointer to newly allocated memory + * holding the interface-or-host will be stored upon + * completion. + * iface [in/out] - address where a pointer to newly allocated memory + * holding the interface will be stored upon completion. + * host [in/out] - address where a pointer to newly allocated memory + * holding the host will be stored upon completion. + * + * Returns CURLE_OK on success. + */ +CURLcode Curl_parse_interface(const char *input, + char **dev, char **iface, char **host) +{ + static const char if_prefix[] = "if!"; + static const char host_prefix[] = "host!"; + static const char if_host_prefix[] = "ifhost!"; + size_t len; + + DEBUGASSERT(dev); + DEBUGASSERT(iface); + DEBUGASSERT(host); + + len = strlen(input); + if(len > 512) + return CURLE_BAD_FUNCTION_ARGUMENT; + + if(!strncmp(if_prefix, input, strlen(if_prefix))) { + input += strlen(if_prefix); + if(!*input) + return CURLE_BAD_FUNCTION_ARGUMENT; + *iface = curlx_memdup0(input, len - strlen(if_prefix)); + return *iface ? CURLE_OK : CURLE_OUT_OF_MEMORY; + } + else if(!strncmp(host_prefix, input, strlen(host_prefix))) { + input += strlen(host_prefix); + if(!*input) + return CURLE_BAD_FUNCTION_ARGUMENT; + *host = curlx_memdup0(input, len - strlen(host_prefix)); + return *host ? CURLE_OK : CURLE_OUT_OF_MEMORY; + } + else if(!strncmp(if_host_prefix, input, strlen(if_host_prefix))) { + const char *host_part; + input += strlen(if_host_prefix); + len -= strlen(if_host_prefix); + host_part = memchr(input, '!', len); + if(!host_part || !*(host_part + 1)) + return CURLE_BAD_FUNCTION_ARGUMENT; + *iface = curlx_memdup0(input, host_part - input); + if(!*iface) + return CURLE_OUT_OF_MEMORY; + ++host_part; + *host = curlx_memdup0(host_part, len - (host_part - input)); + if(!*host) { + curlx_safefree(*iface); + return CURLE_OUT_OF_MEMORY; + } + return CURLE_OK; + } + + if(!*input) + return CURLE_BAD_FUNCTION_ARGUMENT; + *dev = curlx_memdup0(input, len); + return *dev ? CURLE_OK : CURLE_OUT_OF_MEMORY; +} + +#ifndef CURL_DISABLE_BINDLOCAL +static CURLcode bindlocal(struct Curl_easy *data, struct connectdata *conn, + curl_socket_t sockfd, int af, unsigned int scope, + uint8_t transport) +{ + struct Curl_sockaddr_storage sa; + struct sockaddr *sock = (struct sockaddr *)&sa; /* bind to this address */ + curl_socklen_t sizeof_sa = 0; /* size of the data sock points to */ + struct sockaddr_in *si4 = (struct sockaddr_in *)&sa; +#ifdef USE_IPV6 + struct sockaddr_in6 *si6 = (struct sockaddr_in6 *)&sa; +#endif + + struct Curl_dns_entry *h = NULL; + unsigned short port = data->set.localport; /* use this port number, 0 for + "random" */ + /* how many port numbers to try to bind to, increasing one at a time */ + int portnum = data->set.localportrange; + const char *dev = data->set.str[STRING_DEVICE]; + const char *iface_input = data->set.str[STRING_INTERFACE]; + const char *host_input = data->set.str[STRING_BINDHOST]; + const char *iface = iface_input ? iface_input : dev; + const char *host = host_input ? host_input : dev; + int sockerr; +#ifdef IP_BIND_ADDRESS_NO_PORT + int on = 1; +#endif +#ifndef USE_IPV6 + (void)scope; +#endif + + /************************************************************* + * Select device to bind socket to + *************************************************************/ + if(!iface && !host && !port) + /* no local kind of binding was requested */ + return CURLE_OK; + else if(iface && (strlen(iface) >= 255)) + return CURLE_BAD_FUNCTION_ARGUMENT; + + memset(&sa, 0, sizeof(struct Curl_sockaddr_storage)); + + if(iface || host) { + char myhost[256] = ""; + int done = 0; /* -1 for error, 1 for address found */ + if2ip_result_t if2ip_result = IF2IP_NOT_FOUND; + +#ifdef SO_BINDTODEVICE + if(iface) { + /* + * This binds the local socket to a particular interface. This will + * force even requests to other local interfaces to go out the external + * interface. Only bind to the interface when specified as interface, + * not as a hostname or ip address. + * + * The interface might be a VRF, eg: vrf-blue, which means it cannot be + * converted to an IP address and would fail Curl_if2ip. Try to + * use it straight away. + */ + if(setsockopt(sockfd, SOL_SOCKET, SO_BINDTODEVICE, + iface, (curl_socklen_t)strlen(iface) + 1) == 0) { + /* This is often "errno 1, error: Operation not permitted" if you are + * not running as root or another suitable privileged user. If it + * succeeds it means the parameter was a valid interface and not an IP + * address. Return immediately. + */ + if(!host_input) { + infof(data, "socket successfully bound to interface '%s'", iface); + return CURLE_OK; + } + } + } +#endif + if(!host_input) { + /* Discover IP from input device, then bind to it */ + if2ip_result = Curl_if2ip(af, +#ifdef USE_IPV6 + scope, conn->scope_id, +#endif + iface, myhost, sizeof(myhost)); + } + switch(if2ip_result) { + case IF2IP_NOT_FOUND: + if(iface_input && !host_input) { + /* Do not fall back to treating it as a hostname */ + char buffer[STRERROR_LEN]; + data->state.os_errno = sockerr = SOCKERRNO; + failf(data, "Could not bind to interface '%s' with errno %d: %s", + iface, sockerr, curlx_strerror(sockerr, buffer, sizeof(buffer))); + return CURLE_INTERFACE_FAILED; + } + break; + case IF2IP_AF_NOT_SUPPORTED: + /* Signal the caller to try another address family if available */ + return CURLE_UNSUPPORTED_PROTOCOL; + case IF2IP_FOUND: + /* + * We now have the numerical IP address in the 'myhost' buffer + */ + host = myhost; + infof(data, "Local Interface %s is ip %s using address family %d", + iface, host, af); + done = 1; + break; + } + if(!iface_input || host_input) { + /* + * This was not an interface, resolve the name as a hostname + * or IP number + * + * Temporarily force name resolution to use only the address type + * of the connection. The resolve functions should really be changed + * to take a type parameter instead. + */ + uint8_t dns_queries = (af == AF_INET) ? + CURL_DNSQ_A : (CURL_DNSQ_A | CURL_DNSQ_AAAA); +#ifdef USE_IPV6 + if(af == AF_INET6) + dns_queries = CURL_DNSQ_AAAA; +#endif + + (void)Curl_resolv_blocking(data, dns_queries, host, 80, transport, &h); + if(h) { + int h_af = h->addr->ai_family; + /* convert the resolved address, sizeof myhost >= INET_ADDRSTRLEN */ + Curl_printable_address(h->addr, myhost, sizeof(myhost)); + infof(data, "Name '%s' family %d resolved to '%s' family %d", + host, af, myhost, h_af); + Curl_dns_entry_unlink(data, &h); /* this will NULL, potential free h */ + if(af != h_af) { + /* bad IP version combo, signal the caller to try another address + family if available */ + return CURLE_UNSUPPORTED_PROTOCOL; + } + done = 1; + } + else { + /* + * provided dev was no interface (or interfaces are not supported + * e.g. Solaris) no ip address and no domain we fail here + */ + done = -1; + } + } + + if(done > 0) { +#ifdef USE_IPV6 + /* IPv6 address */ + if(af == AF_INET6) { +#ifdef HAVE_SOCKADDR_IN6_SIN6_SCOPE_ID + char *scope_ptr = strchr(myhost, '%'); + if(scope_ptr) + *(scope_ptr++) = '\0'; +#endif + if(curlx_inet_pton(AF_INET6, myhost, &si6->sin6_addr) > 0) { + si6->sin6_family = AF_INET6; + si6->sin6_port = htons(port); +#ifdef HAVE_SOCKADDR_IN6_SIN6_SCOPE_ID + if(scope_ptr) { + /* The "myhost" string either comes from Curl_if2ip or from + Curl_printable_address. The latter returns only numeric scope + IDs and the former returns none at all. Making the scope ID, + if present, known to be numeric */ + curl_off_t scope_id; + if(curlx_str_number((const char **)CURL_UNCONST(&scope_ptr), + &scope_id, UINT_MAX)) + return CURLE_UNSUPPORTED_PROTOCOL; + si6->sin6_scope_id = (unsigned int)scope_id; + } +#endif + } + sizeof_sa = sizeof(struct sockaddr_in6); + } + else +#endif + /* IPv4 address */ + if((af == AF_INET) && + (curlx_inet_pton(AF_INET, myhost, &si4->sin_addr) > 0)) { + si4->sin_family = AF_INET; + si4->sin_port = htons(port); + sizeof_sa = sizeof(struct sockaddr_in); + } + } + + if(done < 1) { + /* errorbuf is set false so failf will overwrite any message already in + the error buffer, so the user receives this error message instead of a + generic resolve error. */ + char buffer[STRERROR_LEN]; + data->state.errorbuf = FALSE; + data->state.os_errno = sockerr = SOCKERRNO; + failf(data, "Could not bind to '%s' with errno %d: %s", host, + sockerr, curlx_strerror(sockerr, buffer, sizeof(buffer))); + return CURLE_INTERFACE_FAILED; + } + } + else { + /* no device was given, prepare sa to match af's needs */ +#ifdef USE_IPV6 + if(af == AF_INET6) { + si6->sin6_family = AF_INET6; + si6->sin6_port = htons(port); + sizeof_sa = sizeof(struct sockaddr_in6); + } + else +#endif + if(af == AF_INET) { + si4->sin_family = AF_INET; + si4->sin_port = htons(port); + sizeof_sa = sizeof(struct sockaddr_in); + } + } +#ifdef IP_BIND_ADDRESS_NO_PORT + (void)setsockopt(sockfd, SOL_IP, IP_BIND_ADDRESS_NO_PORT, &on, sizeof(on)); +#endif + for(;;) { + if(bind(sockfd, sock, sizeof_sa) >= 0) { + /* we succeeded to bind */ + infof(data, "Local port: %hu", port); + conn->bits.bound = TRUE; + return CURLE_OK; + } + + if(--portnum > 0) { + port++; /* try next port */ + if(port == 0) + break; + infof(data, "Bind to local port %d failed, trying next", port - 1); + /* We reuse/clobber the port variable here below */ + if(sock->sa_family == AF_INET) + si4->sin_port = htons(port); +#ifdef USE_IPV6 + else + si6->sin6_port = htons(port); +#endif + } + else + break; + } + { + char buffer[STRERROR_LEN]; + data->state.os_errno = sockerr = SOCKERRNO; + failf(data, "bind failed with errno %d: %s", + sockerr, curlx_strerror(sockerr, buffer, sizeof(buffer))); + } + + return CURLE_INTERFACE_FAILED; +} +#endif + +/* + * verifyconnect() returns TRUE if the connect really has happened. + */ +static bool verifyconnect(curl_socket_t sockfd, int *psockerr) +{ + bool rc = TRUE; +#ifdef SO_ERROR + int sockerr = 0; + curl_socklen_t errSize = sizeof(sockerr); + +#ifdef _WIN32 + /* + * In October 2003 we effectively nullified this function on Windows due to + * problems with it using all CPU in multi-threaded cases. + * + * In May 2004, we brought it back to offer more info back on connect + * failures. We could reproduce the former problems with this function, but + * could avoid them by adding this SleepEx() call below: + * + * "I do not have Rational Quantify, but the hint from his post was + * ntdll::NtRemoveIoCompletion(). I would assume the SleepEx (or maybe + * Sleep(0) would be enough?) would release whatever + * mutex/critical-section the ntdll call is waiting on. + * + * Someone got to verify this on Win-NT 4.0, 2000." + */ + SleepEx(0, FALSE); +#endif + + if(getsockopt(sockfd, SOL_SOCKET, SO_ERROR, (void *)&sockerr, &errSize)) + sockerr = SOCKERRNO; +#if defined(EBADIOCTL) && defined(__minix) + /* Minix 3.1.x does not support getsockopt on UDP sockets */ + if(EBADIOCTL == sockerr) { + SET_SOCKERRNO(0); + sockerr = 0; + } +#endif + if((sockerr == 0) || (SOCKEISCONN == sockerr)) + /* we are connected, awesome! */ + rc = TRUE; + else + /* This was not a successful connect */ + rc = FALSE; + if(psockerr) + *psockerr = sockerr; +#else + (void)sockfd; + if(psockerr) + *psockerr = SOCKERRNO; +#endif + return rc; +} + +/** + * Determine the curl code for a socket connect() == -1 with errno. + */ +static CURLcode socket_connect_result(struct Curl_easy *data, + const char *ipaddress, int sockerr) +{ + if(sockerr == SOCKEINPROGRESS || SOCK_EAGAIN(sockerr)) + return CURLE_OK; + + /* unknown error, fallthrough and try another address! */ + { + VERBOSE(char buffer[STRERROR_LEN]); + infof(data, "Immediate connect fail for %s: %s", ipaddress, + curlx_strerror(sockerr, buffer, sizeof(buffer))); + NOVERBOSE((void)ipaddress); + } + data->state.os_errno = sockerr; + /* connect failed */ + return CURLE_COULDNT_CONNECT; +} + +struct cf_socket_ctx { + struct Curl_peer *peer; + struct Curl_sockaddr_ex addr; /* address to connect to */ + curl_socket_t sock; /* current attempt socket */ + struct ip_quadruple ip; /* The IP quadruple 2x(addr+port) */ + struct curltime started_at; /* when socket was created */ + struct curltime connected_at; /* when socket connected/got first byte */ + struct curltime first_byte_at; /* when first byte was recvd */ +#ifdef USE_WINSOCK + struct curltime last_sndbuf_query_at; /* when SO_SNDBUF last queried */ + ULONG sndbuf_size; /* the last set SO_SNDBUF size */ +#endif + int sockerr; /* socket error of last failure or 0 */ +#ifdef DEBUGBUILD + int wblock_percent; /* percent of writes doing EAGAIN */ + int wpartial_percent; /* percent of bytes written in send */ + int rblock_percent; /* percent of reads doing EAGAIN */ + size_t recv_max; /* max enforced read size */ +#endif + uint8_t transport; + BIT(got_first_byte); /* if first byte was received */ + BIT(listening); /* socket is listening */ + BIT(accepted); /* socket was accepted, not connected */ + BIT(sock_connected); /* socket is "connected", e.g. in UDP */ + BIT(active); +}; + +static CURLcode cf_socket_ctx_init(struct cf_socket_ctx *ctx, + struct Curl_peer *peer, + struct Curl_sockaddr_ex *addr, + uint8_t transport) +{ + memset(ctx, 0, sizeof(*ctx)); + Curl_peer_link(&ctx->peer, peer); + ctx->sock = CURL_SOCKET_BAD; + ctx->transport = transport; + ctx->addr = *addr; + +#ifdef DEBUGBUILD + { + const char *p = getenv("CURL_DBG_SOCK_WBLOCK"); + if(p) { + curl_off_t l; + if(!curlx_str_number(&p, &l, 100)) + ctx->wblock_percent = (int)l; + } + p = getenv("CURL_DBG_SOCK_WPARTIAL"); + if(p) { + curl_off_t l; + if(!curlx_str_number(&p, &l, 100)) + ctx->wpartial_percent = (int)l; + } + p = getenv("CURL_DBG_SOCK_RBLOCK"); + if(p) { + curl_off_t l; + if(!curlx_str_number(&p, &l, 100)) + ctx->rblock_percent = (int)l; + } + p = getenv("CURL_DBG_SOCK_RMAX"); + if(p) { + curl_off_t l; + if(!curlx_str_number(&p, &l, CURL_OFF_T_MAX)) + ctx->recv_max = (size_t)l; + } + } +#endif + + return CURLE_OK; +} + +static void cf_socket_ctx_free(struct cf_socket_ctx *ctx) +{ + if(ctx) { + Curl_peer_unlink(&ctx->peer); + curlx_free(ctx); + } +} + +static CURLcode cf_socket_shutdown(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ + if(cf->connected) { + struct cf_socket_ctx *ctx = cf->ctx; + + CURL_TRC_CF(data, cf, "cf_socket_shutdown, fd=%" FMT_SOCKET_T, ctx->sock); + /* On TCP, and when the socket looks well and non-blocking mode + * can be enabled, receive dangling bytes before close to avoid + * entering RST states unnecessarily. */ + if(ctx->sock != CURL_SOCKET_BAD && + ctx->transport == TRNSPRT_TCP && + (curlx_nonblock(ctx->sock, TRUE) >= 0)) { + unsigned char buf[1024]; + (void)sread(ctx->sock, buf, sizeof(buf)); + } + } + *done = TRUE; + return CURLE_OK; +} + +static void cf_socket_destroy(struct Curl_cfilter *cf, struct Curl_easy *data) +{ + struct cf_socket_ctx *ctx = cf->ctx; + + CURL_TRC_CF(data, cf, "destroy"); + if(ctx) { + if(ctx->sock != CURL_SOCKET_BAD) { + CURL_TRC_CF(data, cf, "cf_socket_close, fd=%" FMT_SOCKET_T, ctx->sock); + if(ctx->sock == cf->conn->sock[cf->sockindex]) + cf->conn->sock[cf->sockindex] = CURL_SOCKET_BAD; + socket_close(data, cf->conn, !ctx->accepted, ctx->sock); + } + cf_socket_ctx_free(ctx); + } +} + +static void set_local_ip(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_socket_ctx *ctx = cf->ctx; + ctx->ip.local_ip[0] = 0; + ctx->ip.local_port = 0; + +#ifdef HAVE_GETSOCKNAME + if((ctx->sock != CURL_SOCKET_BAD) && + !(data->conn->scheme->protocol & CURLPROTO_TFTP)) { + /* TFTP does not connect, so it cannot get the IP like this */ + struct Curl_sockaddr_storage ssloc; + curl_socklen_t slen = sizeof(struct Curl_sockaddr_storage); + VERBOSE(char buffer[STRERROR_LEN]); + + memset(&ssloc, 0, sizeof(ssloc)); + if(getsockname(ctx->sock, (struct sockaddr *)&ssloc, &slen)) { + VERBOSE(int sockerr = SOCKERRNO); + infof(data, "getsockname() failed with errno %d: %s", + sockerr, curlx_strerror(sockerr, buffer, sizeof(buffer))); + } + else if(!sockaddr2string((struct sockaddr *)&ssloc, slen, + ctx->ip.local_ip, &ctx->ip.local_port)) { + infof(data, "ssloc inet_ntop() failed with errno %d: %s", + errno, curlx_strerror(errno, buffer, sizeof(buffer))); + } + } +#else + (void)data; +#endif +} + +static CURLcode set_remote_ip(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_socket_ctx *ctx = cf->ctx; + + /* store remote address and port used in this connection attempt */ + ctx->ip.transport = ctx->transport; + if(!sockaddr2string(&ctx->addr.curl_sa_addr, + (curl_socklen_t)ctx->addr.addrlen, + ctx->ip.remote_ip, &ctx->ip.remote_port)) { + char buffer[STRERROR_LEN]; + + /* using bare errno instead of SOCKERRNO is safe here, because + sockaddr2string() calls curlx_inet_ntop(), and they both report failures + via errno (even on Windows builds). */ + ctx->sockerr = errno; + /* malformed address or bug in inet_ntop, try next address */ + failf(data, "curl_sa_addr inet_ntop() failed with errno %d: %s", + errno, curlx_strerror(errno, buffer, sizeof(buffer))); + return CURLE_FAILED_INIT; + } + return CURLE_OK; +} + +/* to figure out the type of the socket safely, remove the possibly ORed + bits before comparing */ +static int cf_socktype(int x) +{ +#ifdef SOCK_CLOEXEC + x &= ~SOCK_CLOEXEC; +#endif +#ifdef SOCK_NONBLOCK + x &= ~SOCK_NONBLOCK; +#endif + return x; +} + +static CURLcode cf_socket_open(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_socket_ctx *ctx = cf->ctx; + int error = 0; + bool isconnected = FALSE; + CURLcode result = CURLE_COULDNT_CONNECT; + bool is_tcp; + + DEBUGASSERT(ctx->sock == CURL_SOCKET_BAD); + ctx->started_at = *Curl_pgrs_now(data); +#ifdef SOCK_NONBLOCK + /* Do not tuck SOCK_NONBLOCK into socktype when opensocket callback is set + * because we would not know how socketype is about to be used in the + * callback, SOCK_NONBLOCK might get factored out before calling socket(). + */ + if(!data->set.fopensocket) + ctx->addr.socktype |= SOCK_NONBLOCK; +#endif + result = socket_open(data, &ctx->addr, &ctx->sock); +#ifdef SOCK_NONBLOCK + /* Restore the socktype after the socket is created. */ + if(!data->set.fopensocket) + ctx->addr.socktype &= ~SOCK_NONBLOCK; +#endif + if(result) + goto out; + + result = set_remote_ip(cf, data); + if(result) + goto out; + +#ifdef USE_IPV6 + if(ctx->addr.family == AF_INET6) { +#ifdef USE_WINSOCK + /* Turn on support for IPv4-mapped IPv6 addresses. + * Linux kernel, NetBSD, FreeBSD, Darwin, lwIP: default is off; + * Windows Vista and later: default is on; + * DragonFly BSD: acts like off, and dummy setting; + * OpenBSD and earlier Windows: unsupported. + * Linux: controlled by /proc/sys/net/ipv6/bindv6only. + */ + int on = 0; + (void)setsockopt(ctx->sock, IPPROTO_IPV6, IPV6_V6ONLY, + (void *)&on, sizeof(on)); +#endif +#ifdef HAVE_SOCKADDR_IN6_SIN6_SCOPE_ID + { + struct sockaddr_in6 *sa6 = (void *)&ctx->addr.curl_sa_addr; + if(sa6->sin6_scope_id) + infof(data, " Trying [%s]:%d scope_id=%lu...", + ctx->ip.remote_ip, ctx->ip.remote_port, + (unsigned long)sa6->sin6_scope_id); + else +#endif + infof(data, " Trying [%s]:%d...", + ctx->ip.remote_ip, ctx->ip.remote_port); +#ifdef HAVE_SOCKADDR_IN6_SIN6_SCOPE_ID + } +#endif + } + else +#endif + infof(data, " Trying %s:%d...", ctx->ip.remote_ip, ctx->ip.remote_port); + +#ifdef USE_IPV6 + is_tcp = (ctx->addr.family == AF_INET || + ctx->addr.family == AF_INET6) && + cf_socktype(ctx->addr.socktype) == SOCK_STREAM; +#else + is_tcp = (ctx->addr.family == AF_INET) && + cf_socktype(ctx->addr.socktype) == SOCK_STREAM; +#endif + if(is_tcp && data->set.tcp_nodelay) + tcpnodelay(cf, data, ctx->sock); + + if(is_tcp && data->set.tcp_keepalive) + tcpkeepalive(cf, data, ctx->sock); + + if(data->set.fsockopt) { + /* activate callback for setting socket options */ + Curl_set_in_callback(data, TRUE); + error = data->set.fsockopt(data->set.sockopt_client, + ctx->sock, + CURLSOCKTYPE_IPCXN); + Curl_set_in_callback(data, FALSE); + + if(error == CURL_SOCKOPT_ALREADY_CONNECTED) + isconnected = TRUE; + else if(error) { + result = CURLE_ABORTED_BY_CALLBACK; + goto out; + } + } + +#ifndef CURL_DISABLE_BINDLOCAL + /* possibly bind the local end to an IP, interface or port */ + if(ctx->addr.family == AF_INET +#ifdef USE_IPV6 + || ctx->addr.family == AF_INET6 +#endif + ) { + result = bindlocal(data, cf->conn, ctx->sock, ctx->addr.family, + Curl_ipv6_scope(&ctx->addr.curl_sa_addr), + ctx->transport); + if(result) { + if(result == CURLE_UNSUPPORTED_PROTOCOL) { + /* The address family is not supported on this interface. + We can continue trying addresses */ + result = CURLE_COULDNT_CONNECT; + } + goto out; + } + } +#endif + +#ifndef SOCK_NONBLOCK + /* Set socket non-blocking, must be a non-blocking socket for + * a non-blocking connect. */ + error = curlx_nonblock(ctx->sock, TRUE); + if(error < 0) { + result = CURLE_UNSUPPORTED_PROTOCOL; + ctx->sockerr = SOCKERRNO; + goto out; + } +#else + if(data->set.fopensocket) { + /* Set socket non-blocking, must be a non-blocking socket for + * a non-blocking connect. */ + error = curlx_nonblock(ctx->sock, TRUE); + if(error < 0) { + result = CURLE_UNSUPPORTED_PROTOCOL; + ctx->sockerr = SOCKERRNO; + goto out; + } + } +#endif + ctx->sock_connected = (cf_socktype(ctx->addr.socktype) != SOCK_DGRAM); +out: + if(result) { + if(ctx->sock != CURL_SOCKET_BAD) { + socket_close(data, cf->conn, TRUE, ctx->sock); + ctx->sock = CURL_SOCKET_BAD; + } + } + else if(isconnected) { + set_local_ip(cf, data); + ctx->connected_at = *Curl_pgrs_now(data); + cf->connected = TRUE; + } + CURL_TRC_CF(data, cf, "cf_socket_open() -> %d, fd=%" FMT_SOCKET_T, + (int)result, ctx->sock); + return result; +} + +static int do_connect(struct Curl_cfilter *cf, struct Curl_easy *data, + bool is_tcp_fastopen) +{ + struct cf_socket_ctx *ctx = cf->ctx; +#ifdef TCP_FASTOPEN_CONNECT + int optval = 1; +#endif + int rc = -1; + + (void)data; + if(is_tcp_fastopen) { +#ifdef CONNECT_DATA_IDEMPOTENT /* Darwin */ +# ifdef HAVE_BUILTIN_AVAILABLE + /* while connectx function is available since macOS 10.11 / iOS 9, + it did not have the interface declared correctly until + Xcode 9 / macOS SDK 10.13 */ + if(__builtin_available(macOS 10.11, iOS 9.0, tvOS 9.0, watchOS 2.0, *)) { + sa_endpoints_t endpoints; + endpoints.sae_srcif = 0; + endpoints.sae_srcaddr = NULL; + endpoints.sae_srcaddrlen = 0; + endpoints.sae_dstaddr = &ctx->addr.curl_sa_addr; + endpoints.sae_dstaddrlen = ctx->addr.addrlen; + + rc = connectx(ctx->sock, &endpoints, SAE_ASSOCID_ANY, + CONNECT_RESUME_ON_READ_WRITE | CONNECT_DATA_IDEMPOTENT, + NULL, 0, NULL, NULL); + } + else { + rc = connect(ctx->sock, &ctx->addr.curl_sa_addr, ctx->addr.addrlen); + } +# else + rc = connect(ctx->sock, &ctx->addr.curl_sa_addr, ctx->addr.addrlen); +# endif /* HAVE_BUILTIN_AVAILABLE */ +#elif defined(TCP_FASTOPEN_CONNECT) /* Linux >= 4.11 */ + if(setsockopt(ctx->sock, IPPROTO_TCP, TCP_FASTOPEN_CONNECT, + (void *)&optval, sizeof(optval)) < 0) + CURL_TRC_CF(data, cf, "Failed to enable TCP Fast Open on fd %" + FMT_SOCKET_T, ctx->sock); + + rc = connect(ctx->sock, &ctx->addr.curl_sa_addr, ctx->addr.addrlen); +#elif defined(MSG_FASTOPEN) /* old Linux */ + if(Curl_conn_is_ssl(cf->conn, cf->sockindex)) + rc = connect(ctx->sock, &ctx->addr.curl_sa_addr, ctx->addr.addrlen); + else + rc = 0; /* Do nothing */ +#endif + } + else { + rc = connect(ctx->sock, &ctx->addr.curl_sa_addr, + (curl_socklen_t)ctx->addr.addrlen); + } + return rc; +} + +static CURLcode cf_tcp_connect(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ + struct cf_socket_ctx *ctx = cf->ctx; + CURLcode result = CURLE_COULDNT_CONNECT; + int rc = 0; + + if(cf->connected) { + *done = TRUE; + return CURLE_OK; + } + + *done = FALSE; /* a negative world view is best */ + if(ctx->sock == CURL_SOCKET_BAD) { + int sockerr; + + result = cf_socket_open(cf, data); + if(result) + goto out; + + if(cf->connected) { + *done = TRUE; + return CURLE_OK; + } + + /* Connect TCP socket */ + rc = do_connect(cf, data, (bool)cf->conn->bits.tcp_fastopen); + sockerr = SOCKERRNO; + set_local_ip(cf, data); + CURL_TRC_CF(data, cf, "local address %s port %d...", + ctx->ip.local_ip, ctx->ip.local_port); + if(rc == -1) { + ctx->sockerr = sockerr; + result = socket_connect_result(data, ctx->ip.remote_ip, sockerr); + goto out; + } + } + +#ifdef mpeix + /* Call this function once now, and ignore the results. We do this to + "clear" the error state on the socket so that we can later read it + reliably. This is reported necessary on the MPE/iX operating + system. */ + (void)verifyconnect(ctx->sock, NULL); +#endif + /* check socket for connect */ + rc = SOCKET_WRITABLE(ctx->sock, 0); + + if(rc == 0) { /* no connection yet */ + CURL_TRC_CF(data, cf, "not connected yet on fd=%" FMT_SOCKET_T, ctx->sock); + return CURLE_OK; + } + else if(rc == CURL_CSELECT_OUT || cf->conn->bits.tcp_fastopen) { + if(verifyconnect(ctx->sock, &ctx->sockerr)) { + /* we are connected with TCP, awesome! */ + ctx->connected_at = *Curl_pgrs_now(data); + set_local_ip(cf, data); + *done = TRUE; + cf->connected = TRUE; + CURL_TRC_CF(data, cf, "connected on fd=%" FMT_SOCKET_T, ctx->sock); + return CURLE_OK; + } + } + else if(rc & CURL_CSELECT_ERR) { + CURL_TRC_CF(data, cf, "poll/select error on fd=%" FMT_SOCKET_T, ctx->sock); + (void)verifyconnect(ctx->sock, &ctx->sockerr); + result = CURLE_COULDNT_CONNECT; + } + +out: + if(result) { + VERBOSE(char buffer[STRERROR_LEN]); + set_local_ip(cf, data); + if(ctx->sockerr) { + data->state.os_errno = ctx->sockerr; + SET_SOCKERRNO(ctx->sockerr); + VERBOSE(curlx_strerror(ctx->sockerr, buffer, sizeof(buffer))); + } + else { + VERBOSE(curlx_strcopy(buffer, sizeof(buffer), STRCONST("peer closed"))); + } + if(ctx->sock != CURL_SOCKET_BAD) { + socket_close(data, cf->conn, TRUE, ctx->sock); + ctx->sock = CURL_SOCKET_BAD; + } + infof(data, "connect to %s port %u from %s port %d failed: %s", + ctx->ip.remote_ip, ctx->ip.remote_port, + ctx->ip.local_ip, ctx->ip.local_port, + curlx_strerror(ctx->sockerr, buffer, sizeof(buffer))); + *done = FALSE; + } + return result; +} + +static CURLcode cf_socket_adjust_pollset(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct easy_pollset *ps) +{ + struct cf_socket_ctx *ctx = cf->ctx; + CURLcode result = CURLE_OK; + + if(ctx->sock != CURL_SOCKET_BAD) { + /* A listening socket filter needs to be connected before the accept + * for some weird FTP interaction. This should be rewritten, so that + * FTP no longer does the socket checks and accept calls and delegates + * all that to the filter. */ + if(ctx->listening) { + result = Curl_pollset_set_in_only(data, ps, ctx->sock); + CURL_TRC_CF(data, cf, "adjust_pollset, listening, POLLIN fd=%" + FMT_SOCKET_T, ctx->sock); + } + else if(!cf->connected) { + result = Curl_pollset_set_out_only(data, ps, ctx->sock); + CURL_TRC_CF(data, cf, "adjust_pollset, !connected, POLLOUT fd=%" + FMT_SOCKET_T, ctx->sock); + } + else if(!ctx->active) { + result = Curl_pollset_add_in(data, ps, ctx->sock); + CURL_TRC_CF(data, cf, "adjust_pollset, !active, POLLIN fd=%" + FMT_SOCKET_T, ctx->sock); + } + } + return result; +} + +#ifdef USE_WINSOCK + +/* Offered by mingw-w64 v13+, MS SDK 7.0A/VS2010+ */ +#ifndef SIO_IDEAL_SEND_BACKLOG_QUERY +#define SIO_IDEAL_SEND_BACKLOG_QUERY 0x4004747B +#endif + +static void win_update_sndbuf_size(struct Curl_easy *data, + struct cf_socket_ctx *ctx) +{ + ULONG ideal; + DWORD ideallen; + + if(curlx_ptimediff_ms(Curl_pgrs_now(data), + &ctx->last_sndbuf_query_at) > 1000) { + if(!WSAIoctl(ctx->sock, SIO_IDEAL_SEND_BACKLOG_QUERY, 0, 0, + &ideal, sizeof(ideal), &ideallen, 0, 0) && + ideal != ctx->sndbuf_size && + !setsockopt(ctx->sock, SOL_SOCKET, SO_SNDBUF, + (const char *)&ideal, sizeof(ideal))) { + ctx->sndbuf_size = ideal; + } + ctx->last_sndbuf_query_at = *Curl_pgrs_now(data); + } +} + +#endif /* USE_WINSOCK */ + +static CURLcode cf_socket_send(struct Curl_cfilter *cf, struct Curl_easy *data, + const uint8_t *buf, size_t len, bool eos, + size_t *pnwritten) +{ + struct cf_socket_ctx *ctx = cf->ctx; + curl_socket_t fdsave; + ssize_t rv; + CURLcode result = CURLE_OK; + VERBOSE(size_t orig_len = len); + + (void)eos; + *pnwritten = 0; + fdsave = cf->conn->sock[cf->sockindex]; + cf->conn->sock[cf->sockindex] = ctx->sock; + +#ifdef DEBUGBUILD + /* simulate network blocking/partial writes */ + if(ctx->wblock_percent > 0) { + unsigned char c = 0; + Curl_rand_bytes(data, FALSE, &c, 1); + if(c >= ((100 - ctx->wblock_percent) * 256 / 100)) { + CURL_TRC_CF(data, cf, "send(len=%zu) SIMULATE EWOULDBLOCK", orig_len); + cf->conn->sock[cf->sockindex] = fdsave; + return CURLE_AGAIN; + } + } + if(cf->cft != &Curl_cft_udp && ctx->wpartial_percent > 0 && len > 8) { + len = len * ctx->wpartial_percent / 100; + if(!len) + len = 1; + CURL_TRC_CF(data, cf, "send(len=%zu) SIMULATE partial write of %zu bytes", + orig_len, len); + } +#endif + +#if defined(MSG_FASTOPEN) && !defined(TCP_FASTOPEN_CONNECT) /* Linux */ + if(cf->conn->bits.tcp_fastopen) { + rv = sendto(ctx->sock, buf, len, MSG_FASTOPEN, + &ctx->addr.curl_sa_addr, ctx->addr.addrlen); + cf->conn->bits.tcp_fastopen = FALSE; + } + else +#endif + rv = swrite(ctx->sock, buf, len); + + if(!curlx_sztouz(rv, pnwritten)) { + int sockerr = SOCKERRNO; + if(SOCK_EAGAIN(sockerr) +#ifndef USE_WINSOCK + || (sockerr == SOCKEINTR) || (sockerr == SOCKEINPROGRESS) +#endif + ) { + result = CURLE_AGAIN; /* EWOULDBLOCK */ + } + else { + char buffer[STRERROR_LEN]; + failf(data, "Send failure: %s", + curlx_strerror(sockerr, buffer, sizeof(buffer))); + data->state.os_errno = sockerr; + result = CURLE_SEND_ERROR; + } + } + +#ifdef USE_WINSOCK + if(!result) + win_update_sndbuf_size(data, ctx); +#endif + + CURL_TRC_CF(data, cf, "send(len=%zu) -> %d, %zu", + orig_len, (int)result, *pnwritten); + cf->conn->sock[cf->sockindex] = fdsave; + return result; +} + +static CURLcode cf_socket_recv(struct Curl_cfilter *cf, struct Curl_easy *data, + char *buf, size_t len, size_t *pnread) +{ + struct cf_socket_ctx *ctx = cf->ctx; + CURLcode result = CURLE_OK; + ssize_t rv; + + *pnread = 0; +#ifdef DEBUGBUILD + /* simulate network blocking/partial reads */ + if(cf->cft != &Curl_cft_udp && ctx->rblock_percent > 0) { + unsigned char c = 0; + Curl_rand(data, &c, 1); + if(c >= ((100 - ctx->rblock_percent) * 256 / 100)) { + CURL_TRC_CF(data, cf, "recv(len=%zu) SIMULATE EWOULDBLOCK", len); + return CURLE_AGAIN; + } + } + if(cf->cft != &Curl_cft_udp && ctx->recv_max && ctx->recv_max < len) { + CURL_TRC_CF(data, cf, "recv(len=%zu) SIMULATE max read of %zu bytes", + len, ctx->recv_max); + len = ctx->recv_max; + } +#endif + + rv = sread(ctx->sock, buf, len); + + if(!curlx_sztouz(rv, pnread)) { + int sockerr = SOCKERRNO; + if(SOCK_EAGAIN(sockerr) +#ifndef USE_WINSOCK + || (sockerr == SOCKEINTR) +#endif + ) { + result = CURLE_AGAIN; /* EWOULDBLOCK */ + } + else { + char buffer[STRERROR_LEN]; + failf(data, "Recv failure: %s", + curlx_strerror(sockerr, buffer, sizeof(buffer))); + data->state.os_errno = sockerr; + result = CURLE_RECV_ERROR; + } + } + + CURL_TRC_CF(data, cf, "recv(len=%zu) -> %d, %zu", len, (int)result, *pnread); + if(!result && !ctx->got_first_byte) { + ctx->first_byte_at = *Curl_pgrs_now(data); + ctx->got_first_byte = TRUE; + } + return result; +} + +static void cf_socket_update_data(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + /* Update the IP info held in the transfer, if we have that. */ + if(cf->connected && (cf->sockindex == FIRSTSOCKET)) { + struct cf_socket_ctx *ctx = cf->ctx; + data->info.primary = ctx->ip; + } +} + +static void cf_socket_active(struct Curl_cfilter *cf, struct Curl_easy *data) +{ + struct cf_socket_ctx *ctx = cf->ctx; + + /* use this socket from now on */ + cf->conn->sock[cf->sockindex] = ctx->sock; + set_local_ip(cf, data); +#ifdef USE_IPV6 + if(cf->sockindex == FIRSTSOCKET) + cf->conn->bits.ipv6 = (ctx->addr.family == AF_INET6); +#endif + ctx->active = TRUE; +} + +static CURLcode cf_socket_cntrl(struct Curl_cfilter *cf, + struct Curl_easy *data, + int event, int arg1, void *arg2) +{ + struct cf_socket_ctx *ctx = cf->ctx; + + (void)arg1; + (void)arg2; + switch(event) { + case CF_CTRL_CONN_INFO_UPDATE: + cf_socket_active(cf, data); + cf_socket_update_data(cf, data); + break; + case CF_CTRL_DATA_SETUP: + cf_socket_update_data(cf, data); + break; + case CF_CTRL_FORGET_SOCKET: + ctx->sock = CURL_SOCKET_BAD; + break; + } + return CURLE_OK; +} + +static bool cf_socket_conn_is_alive(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *input_pending) +{ + struct cf_socket_ctx *ctx = cf->ctx; + struct pollfd pfd[1]; + int r; + + *input_pending = FALSE; + + if(!ctx || ctx->sock == CURL_SOCKET_BAD) + return FALSE; + + /* Check with 0 timeout if there are any events pending on the socket */ + pfd[0].fd = ctx->sock; + pfd[0].events = POLLRDNORM | POLLIN | POLLRDBAND | POLLPRI; + pfd[0].revents = 0; + + r = Curl_poll(pfd, 1, 0); + if(r < 0) { + CURL_TRC_CF(data, cf, "is_alive: poll error, assume dead"); + return FALSE; + } + else if(r == 0) { + CURL_TRC_CF(data, cf, "is_alive: poll timeout, assume alive"); + return TRUE; + } + else if(pfd[0].revents & (POLLERR | POLLHUP | POLLPRI | POLLNVAL)) { + CURL_TRC_CF(data, cf, "is_alive: err/hup/etc events, assume dead"); + return FALSE; + } + + CURL_TRC_CF(data, cf, "is_alive: valid events, looks alive"); + *input_pending = TRUE; + return TRUE; +} + +static CURLcode cf_socket_query(struct Curl_cfilter *cf, + struct Curl_easy *data, + int query, int *pres1, void *pres2) +{ + struct cf_socket_ctx *ctx = cf->ctx; + + switch(query) { + case CF_QUERY_SOCKET: + DEBUGASSERT(pres2); + *((curl_socket_t *)pres2) = ctx->sock; + return CURLE_OK; + case CF_QUERY_TRANSPORT: + DEBUGASSERT(pres1); + *pres1 = ctx->transport; + return CURLE_OK; + case CF_QUERY_REMOTE_ADDR: + DEBUGASSERT(pres2); + *((const struct Curl_sockaddr_ex **)pres2) = cf->connected ? + &ctx->addr : NULL; + return CURLE_OK; + case CF_QUERY_CONNECT_REPLY_MS: + if(ctx->got_first_byte) { + timediff_t ms = curlx_ptimediff_ms(&ctx->first_byte_at, + &ctx->started_at); + *pres1 = (ms < INT_MAX) ? (int)ms : INT_MAX; + } + else + *pres1 = -1; + return CURLE_OK; + case CF_QUERY_TIMER_CONNECT: { + struct curltime *when = pres2; + switch(ctx->transport) { + case TRNSPRT_UDP: + case TRNSPRT_QUIC: + /* Since UDP connected sockets work different from TCP, we use the + * time of the first byte from the peer as the "connect" time. */ + if(ctx->got_first_byte) { + *when = ctx->first_byte_at; + break; + } + FALLTHROUGH(); + default: + *when = ctx->connected_at; + break; + } + return CURLE_OK; + } + case CF_QUERY_IP_INFO: +#ifdef USE_IPV6 + *pres1 = (ctx->addr.family == AF_INET6); +#else + *pres1 = FALSE; +#endif + *(struct ip_quadruple *)pres2 = ctx->ip; + return CURLE_OK; + default: + break; + } + return cf->next ? + cf->next->cft->query(cf->next, data, query, pres1, pres2) : + CURLE_UNKNOWN_OPTION; +} + +struct Curl_cftype Curl_cft_tcp = { + "TCP", + CF_TYPE_IP_CONNECT, + CURL_LOG_LVL_NONE, + cf_socket_destroy, + cf_tcp_connect, + cf_socket_shutdown, + cf_socket_adjust_pollset, + Curl_cf_def_data_pending, + cf_socket_send, + cf_socket_recv, + cf_socket_cntrl, + cf_socket_conn_is_alive, + Curl_cf_def_conn_keep_alive, + cf_socket_query, +}; + +CURLcode Curl_cf_tcp_create(struct Curl_cfilter **pcf, + struct Curl_easy *data, + struct Curl_peer *origin, + struct Curl_peer *peer, + uint8_t transport_peer, + struct connectdata *conn, + struct Curl_sockaddr_ex *addr, + struct Curl_peer *tunnel_peer, + uint8_t tunnel_transport) +{ + struct cf_socket_ctx *ctx = NULL; + struct Curl_cfilter *cf = NULL; + CURLcode result; + + (void)data; + (void)origin; + (void)conn; + (void)tunnel_peer; + (void)tunnel_transport; + DEBUGASSERT(transport_peer == TRNSPRT_TCP); + if(!addr) { + result = CURLE_BAD_FUNCTION_ARGUMENT; + goto out; + } + + ctx = curlx_calloc(1, sizeof(*ctx)); + if(!ctx) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + result = cf_socket_ctx_init(ctx, peer, addr, transport_peer); + if(result) + goto out; + + result = Curl_cf_create(&cf, &Curl_cft_tcp, ctx); + +out: + *pcf = (!result) ? cf : NULL; + if(result) { + curlx_safefree(cf); + cf_socket_ctx_free(ctx); + } + + return result; +} + +#ifdef __linux__ +static void linux_quic_mtu(struct cf_socket_ctx *ctx) +{ + int val; + switch(ctx->addr.family) { +#ifdef IP_MTU_DISCOVER + case AF_INET: + val = IP_PMTUDISC_DO; + (void)setsockopt(ctx->sock, IPPROTO_IP, IP_MTU_DISCOVER, &val, + sizeof(val)); + break; +#endif +#ifdef IPV6_MTU_DISCOVER + case AF_INET6: + val = IPV6_PMTUDISC_DO; + (void)setsockopt(ctx->sock, IPPROTO_IPV6, IPV6_MTU_DISCOVER, &val, + sizeof(val)); + break; +#endif + } +} +#else +#define linux_quic_mtu(x) +#endif + +#if defined(UDP_GRO) && \ + (defined(HAVE_SENDMMSG) || defined(HAVE_SENDMSG)) && \ + ((defined(USE_NGTCP2) && defined(USE_NGHTTP3)) || defined(USE_QUICHE)) +static void linux_quic_gro(struct cf_socket_ctx *ctx) +{ + int one = 1; + (void)setsockopt(ctx->sock, IPPROTO_UDP, UDP_GRO, &one, + (socklen_t)sizeof(one)); +} +#else +#define linux_quic_gro(x) +#endif + +static CURLcode cf_udp_setup_quic(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_socket_ctx *ctx = cf->ctx; + int rc; + + /* QUIC needs a connected socket, nonblocking */ + DEBUGASSERT(ctx->sock != CURL_SOCKET_BAD); + + /* error: The 1st argument to 'connect' is -1 but should be >= 0 + NOLINTNEXTLINE(clang-analyzer-unix.StdCLibraryFunctions) */ + rc = connect(ctx->sock, &ctx->addr.curl_sa_addr, + (curl_socklen_t)ctx->addr.addrlen); + if(rc == -1) { + return socket_connect_result(data, ctx->ip.remote_ip, SOCKERRNO); + } + ctx->sock_connected = TRUE; + set_local_ip(cf, data); + CURL_TRC_CF(data, cf, "%s socket %" FMT_SOCKET_T + " connected: [%s:%d] -> [%s:%d]", + (ctx->transport == TRNSPRT_QUIC) ? "QUIC" : "UDP", + ctx->sock, ctx->ip.local_ip, ctx->ip.local_port, + ctx->ip.remote_ip, ctx->ip.remote_port); + + /* Currently, cf->ctx->sock is always non-blocking because the only + * caller to cf_udp_setup_quic() is cf_udp_connect() that passes the + * non-blocking socket created by cf_socket_open() to it. Thus, we + * do not need to call curlx_nonblock() in cf_udp_setup_quic() anymore. + */ + linux_quic_mtu(ctx); + linux_quic_gro(ctx); + + return CURLE_OK; +} + +static CURLcode cf_udp_connect(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ + struct cf_socket_ctx *ctx = cf->ctx; + CURLcode result = CURLE_COULDNT_CONNECT; + + if(cf->connected) { + *done = TRUE; + return CURLE_OK; + } + + *done = FALSE; + if(ctx->sock == CURL_SOCKET_BAD) { + result = cf_socket_open(cf, data); + if(result) { + CURL_TRC_CF(data, cf, "cf_udp_connect(), open failed -> %d", + (int)result); + goto out; + } + + if(ctx->transport == TRNSPRT_QUIC) { + result = cf_udp_setup_quic(cf, data); + if(result) + goto out; + CURL_TRC_CF(data, cf, "cf_udp_connect(), opened socket=%" + FMT_SOCKET_T " (%s:%d)", + ctx->sock, ctx->ip.local_ip, ctx->ip.local_port); + } + *done = TRUE; + cf->connected = TRUE; + } +out: + return result; +} + +struct Curl_cftype Curl_cft_udp = { + "UDP", + CF_TYPE_IP_CONNECT, + CURL_LOG_LVL_NONE, + cf_socket_destroy, + cf_udp_connect, + cf_socket_shutdown, + cf_socket_adjust_pollset, + Curl_cf_def_data_pending, + cf_socket_send, + cf_socket_recv, + cf_socket_cntrl, + cf_socket_conn_is_alive, + Curl_cf_def_conn_keep_alive, + cf_socket_query, +}; + +CURLcode Curl_cf_udp_create(struct Curl_cfilter **pcf, + struct Curl_easy *data, + struct Curl_peer *origin, + struct Curl_peer *peer, + uint8_t transport_peer, + struct connectdata *conn, + struct Curl_sockaddr_ex *addr, + struct Curl_peer *tunnel_peer, + uint8_t tunnel_transport) +{ + struct cf_socket_ctx *ctx = NULL; + struct Curl_cfilter *cf = NULL; + CURLcode result; + + (void)data; + (void)origin; + (void)conn; + (void)tunnel_peer; + (void)tunnel_transport; + DEBUGASSERT(transport_peer == TRNSPRT_UDP || transport_peer == TRNSPRT_QUIC); + ctx = curlx_calloc(1, sizeof(*ctx)); + if(!ctx) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + result = cf_socket_ctx_init(ctx, peer, addr, transport_peer); + if(result) + goto out; + + result = Curl_cf_create(&cf, &Curl_cft_udp, ctx); + +out: + *pcf = (!result) ? cf : NULL; + if(result) { + curlx_safefree(cf); + cf_socket_ctx_free(ctx); + } + + return result; +} + +/* this is the TCP filter which can also handle this case */ +struct Curl_cftype Curl_cft_unix = { + "UNIX", + CF_TYPE_IP_CONNECT, + CURL_LOG_LVL_NONE, + cf_socket_destroy, + cf_tcp_connect, + cf_socket_shutdown, + cf_socket_adjust_pollset, + Curl_cf_def_data_pending, + cf_socket_send, + cf_socket_recv, + cf_socket_cntrl, + cf_socket_conn_is_alive, + Curl_cf_def_conn_keep_alive, + cf_socket_query, +}; + +CURLcode Curl_cf_unix_create(struct Curl_cfilter **pcf, + struct Curl_easy *data, + struct Curl_peer *origin, + struct Curl_peer *peer, + uint8_t transport_peer, + struct connectdata *conn, + struct Curl_sockaddr_ex *addr, + struct Curl_peer *tunnel_peer, + uint8_t tunnel_transport) +{ + struct cf_socket_ctx *ctx = NULL; + struct Curl_cfilter *cf = NULL; + CURLcode result; + + (void)data; + (void)origin; + (void)conn; + (void)tunnel_peer; + (void)tunnel_transport; + DEBUGASSERT(transport_peer == TRNSPRT_UNIX); + ctx = curlx_calloc(1, sizeof(*ctx)); + if(!ctx) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + result = cf_socket_ctx_init(ctx, peer, addr, transport_peer); + if(result) + goto out; + + result = Curl_cf_create(&cf, &Curl_cft_unix, ctx); + +out: + *pcf = (!result) ? cf : NULL; + if(result) { + curlx_safefree(cf); + cf_socket_ctx_free(ctx); + } + + return result; +} + +static timediff_t cf_tcp_accept_timeleft(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_socket_ctx *ctx = cf->ctx; + timediff_t timeout_ms = DEFAULT_ACCEPT_TIMEOUT; + timediff_t other_ms; + +#ifndef CURL_DISABLE_FTP + if(data->set.accepttimeout > 0) + timeout_ms = data->set.accepttimeout; +#endif + + /* check if the generic timeout possibly is set shorter */ + other_ms = Curl_timeleft_ms(data); + if(other_ms && (other_ms < timeout_ms)) + /* note that this also works fine for when other_ms happens to be negative + due to it already having elapsed */ + timeout_ms = other_ms; + else { + /* subtract elapsed time */ + timeout_ms -= curlx_ptimediff_ms(Curl_pgrs_now(data), &ctx->started_at); + if(!timeout_ms) + /* avoid returning 0 as that means no timeout! */ + timeout_ms = -1; + } + return timeout_ms; +} + +static void cf_tcp_set_accepted_remote_ip(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_socket_ctx *ctx = cf->ctx; +#ifdef HAVE_GETPEERNAME + char buffer[STRERROR_LEN]; + struct Curl_sockaddr_storage ssrem; + curl_socklen_t plen; + + ctx->ip.remote_ip[0] = 0; + ctx->ip.remote_port = 0; + plen = sizeof(ssrem); + memset(&ssrem, 0, plen); + if(getpeername(ctx->sock, (struct sockaddr *)&ssrem, &plen)) { + int sockerr = SOCKERRNO; + failf(data, "getpeername() failed with errno %d: %s", + sockerr, curlx_strerror(sockerr, buffer, sizeof(buffer))); + return; + } + if(!sockaddr2string((struct sockaddr *)&ssrem, plen, + ctx->ip.remote_ip, &ctx->ip.remote_port)) { + failf(data, "ssrem inet_ntop() failed with errno %d: %s", + errno, curlx_strerror(errno, buffer, sizeof(buffer))); + return; + } +#else + ctx->ip.remote_ip[0] = 0; + ctx->ip.remote_port = 0; + (void)data; +#endif +} + +static CURLcode cf_tcp_accept_connect(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ + struct cf_socket_ctx *ctx = cf->ctx; + char errbuf[STRERROR_LEN]; +#ifdef USE_IPV6 + struct Curl_sockaddr_storage add; +#else + struct sockaddr_in add; +#endif + curl_socklen_t size = (curl_socklen_t)sizeof(add); + curl_socket_t s_accepted = CURL_SOCKET_BAD; + timediff_t timeout_ms; + int socketstate = 0; + bool incoming = FALSE; + + /* we start accepted, if we ever close, we cannot go on */ + (void)data; + if(cf->connected) { + *done = TRUE; + return CURLE_OK; + } + + *done = FALSE; + timeout_ms = cf_tcp_accept_timeleft(cf, data); + if(timeout_ms < 0) { + /* if a timeout was already reached, bail out */ + failf(data, "Accept timeout occurred while waiting server connect"); + return CURLE_FTP_ACCEPT_TIMEOUT; + } + + CURL_TRC_CF(data, cf, "Checking for incoming on fd=%" FMT_SOCKET_T + " ip=%s:%d", ctx->sock, ctx->ip.local_ip, ctx->ip.local_port); + socketstate = SOCKET_READABLE(ctx->sock, 0); + CURL_TRC_CF(data, cf, "socket_check -> %x", (unsigned int)socketstate); + switch(socketstate) { + case -1: /* error */ + /* let's die here */ + failf(data, "Error while waiting for server connect"); + return CURLE_FTP_ACCEPT_FAILED; + default: + if(socketstate & CURL_CSELECT_IN) { + infof(data, "Ready to accept data connection from server"); + incoming = TRUE; + } + break; + } + + if(!incoming) { + CURL_TRC_CF(data, cf, "nothing heard from the server yet"); + return CURLE_OK; + } + + size = sizeof(add); +#ifdef HAVE_ACCEPT4 + s_accepted = CURL_ACCEPT4(ctx->sock, (struct sockaddr *)&add, &size, + SOCK_NONBLOCK | SOCK_CLOEXEC); +#else + s_accepted = CURL_ACCEPT(ctx->sock, (struct sockaddr *)&add, &size); +#endif + + if(s_accepted == CURL_SOCKET_BAD) { + failf(data, "Error accept()ing server connect: %s", + curlx_strerror(SOCKERRNO, errbuf, sizeof(errbuf))); + return CURLE_FTP_ACCEPT_FAILED; + } +#ifndef HAVE_ACCEPT4 +#ifdef HAVE_FCNTL + if(fcntl(s_accepted, F_SETFD, FD_CLOEXEC) < 0) { + failf(data, "fcntl set CLOEXEC: %s", + curlx_strerror(SOCKERRNO, errbuf, sizeof(errbuf))); + Curl_socket_close(data, cf->conn, s_accepted); + return CURLE_FTP_ACCEPT_FAILED; + } +#endif /* HAVE_FCNTL */ + if(curlx_nonblock(s_accepted, TRUE) < 0) { + failf(data, "set socket NONBLOCK: %s", + curlx_strerror(SOCKERRNO, errbuf, sizeof(errbuf))); + Curl_socket_close(data, cf->conn, s_accepted); + return CURLE_FTP_ACCEPT_FAILED; + } +#endif /* !HAVE_ACCEPT4 */ + infof(data, "Connection accepted from server"); + + /* Replace any filter on SECONDARY with one listening on this socket */ + ctx->listening = FALSE; + ctx->accepted = TRUE; + socket_close(data, cf->conn, TRUE, ctx->sock); + ctx->sock = s_accepted; + + cf->conn->sock[cf->sockindex] = ctx->sock; + cf_tcp_set_accepted_remote_ip(cf, data); + set_local_ip(cf, data); + ctx->active = TRUE; + ctx->connected_at = *Curl_pgrs_now(data); + cf->connected = TRUE; + CURL_TRC_CF(data, cf, "accepted_set(sock=%" FMT_SOCKET_T + ", remote=%s port=%d)", + ctx->sock, ctx->ip.remote_ip, ctx->ip.remote_port); + + if(data->set.fsockopt) { + int error = 0; + + /* activate callback for setting socket options */ + Curl_set_in_callback(data, TRUE); + error = data->set.fsockopt(data->set.sockopt_client, + ctx->sock, CURLSOCKTYPE_ACCEPT); + Curl_set_in_callback(data, FALSE); + + if(error) + return CURLE_ABORTED_BY_CALLBACK; + } + *done = TRUE; + return CURLE_OK; +} + +struct Curl_cftype Curl_cft_tcp_accept = { + "TCP-ACCEPT", + CF_TYPE_IP_CONNECT, + CURL_LOG_LVL_NONE, + cf_socket_destroy, + cf_tcp_accept_connect, + cf_socket_shutdown, + cf_socket_adjust_pollset, + Curl_cf_def_data_pending, + cf_socket_send, + cf_socket_recv, + cf_socket_cntrl, + cf_socket_conn_is_alive, + Curl_cf_def_conn_keep_alive, + cf_socket_query, +}; + +CURLcode Curl_conn_tcp_listen_set(struct Curl_easy *data, + struct connectdata *conn, + int sockindex, curl_socket_t *s) +{ + CURLcode result; + struct Curl_cfilter *cf = NULL; + struct cf_socket_ctx *ctx = NULL; + + /* replace any existing */ + Curl_conn_cf_discard_all(data, conn, sockindex); + DEBUGASSERT(conn->sock[sockindex] == CURL_SOCKET_BAD); + + ctx = curlx_calloc(1, sizeof(*ctx)); + if(!ctx) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + ctx->transport = TRNSPRT_TCP; + ctx->sock = *s; + ctx->listening = TRUE; + ctx->accepted = FALSE; + result = Curl_cf_create(&cf, &Curl_cft_tcp_accept, ctx); + if(result) + goto out; + Curl_conn_cf_add(data, conn, sockindex, cf); + + ctx->started_at = *Curl_pgrs_now(data); + conn->sock[sockindex] = ctx->sock; + set_local_ip(cf, data); + CURL_TRC_CF(data, cf, "set filter for listen socket fd=%" FMT_SOCKET_T + " ip=%s:%d", ctx->sock, + ctx->ip.local_ip, ctx->ip.local_port); + +out: + if(result) { + curlx_safefree(cf); + curlx_safefree(ctx); + } + return result; +} + +bool Curl_conn_is_tcp_listen(struct Curl_easy *data, + int sockindex) +{ + struct Curl_cfilter *cf = data->conn->cfilter[sockindex]; + while(cf) { + if(cf->cft == &Curl_cft_tcp_accept) + return TRUE; + cf = cf->next; + } + return FALSE; +} + +/** + * Return TRUE iff `cf` is a socket filter. + */ +static bool cf_is_socket(struct Curl_cfilter *cf) +{ + return cf && (cf->cft == &Curl_cft_tcp || + cf->cft == &Curl_cft_udp || + cf->cft == &Curl_cft_unix || + cf->cft == &Curl_cft_tcp_accept); +} + +CURLcode Curl_cf_socket_peek(struct Curl_cfilter *cf, + struct Curl_easy *data, + curl_socket_t *psock, + const struct Curl_sockaddr_ex **paddr, + struct ip_quadruple *pip) +{ + (void)data; + if(cf_is_socket(cf) && cf->ctx) { + struct cf_socket_ctx *ctx = cf->ctx; + + if(psock) + *psock = ctx->sock; + if(paddr) + *paddr = &ctx->addr; + if(pip) + *pip = ctx->ip; + return CURLE_OK; + } + return CURLE_FAILED_INIT; +} diff --git a/3rdparty/curl-8.21.0/lib/cf-socket.h b/3rdparty/curl-8.21.0/lib/cf-socket.h new file mode 100644 index 0000000000..37ddc02576 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/cf-socket.h @@ -0,0 +1,154 @@ +#ifndef HEADER_CURL_CF_SOCKET_H +#define HEADER_CURL_CF_SOCKET_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +struct Curl_addrinfo; +struct Curl_cfilter; +struct Curl_easy; +struct connectdata; +struct Curl_sockaddr_ex; +struct ip_quadruple; + +#define curl_sa_addr addr.sa +#define curl_sa_addrbuf addr.buf + +/* + * Parse interface option, and return the interface name and the host part. + */ +CURLcode Curl_parse_interface(const char *input, + char **dev, char **iface, char **host); + +CURLcode Curl_socket_addr_from_ai(struct Curl_sockaddr_ex *addr, + const struct Curl_addrinfo *ai, + uint8_t transport); + +/* + * Create a socket based on info from 'conn' and 'ai'. + * + * Fill in 'addr' and 'sockfd' accordingly if OK is returned. If the open + * socket callback is set, used that! + * + */ +CURLcode Curl_socket_open(struct Curl_easy *data, + const struct Curl_addrinfo *ai, + struct Curl_sockaddr_ex *addr, + uint8_t transport, + curl_socket_t *sockfd); + +#ifdef USE_SO_NOSIGPIPE +/* Set SO_NOSIGPIPE on socket, return < 0 on error. */ +int Curl_sock_nosigpipe(curl_socket_t sockfd); +#endif + +int Curl_socket_close(struct Curl_easy *data, struct connectdata *conn, + curl_socket_t sock); + +/** + * Creates a cfilter that opens a TCP socket to the given address + * when calling its `connect` implementation. + * The filter will not touch any connection/data flags and can be + * used in happy eyeballing. Once selected for use, its `_active()` + * method needs to be called. + */ +CURLcode Curl_cf_tcp_create(struct Curl_cfilter **pcf, + struct Curl_easy *data, + struct Curl_peer *origin, + struct Curl_peer *peer, + uint8_t transport_peer, + struct connectdata *conn, + struct Curl_sockaddr_ex *addr, + struct Curl_peer *tunnel_peer, + uint8_t tunnel_transport); + +/** + * Creates a cfilter that opens a UDP socket to the given address + * when calling its `connect` implementation. + * The filter will not touch any connection/data flags and can be + * used in happy eyeballing. Once selected for use, its `_active()` + * method needs to be called. + */ +CURLcode Curl_cf_udp_create(struct Curl_cfilter **pcf, + struct Curl_easy *data, + struct Curl_peer *origin, + struct Curl_peer *peer, + uint8_t transport_peer, + struct connectdata *conn, + struct Curl_sockaddr_ex *addr, + struct Curl_peer *tunnel_peer, + uint8_t tunnel_transport); + +/** + * Creates a cfilter that opens a UNIX socket to the given address + * when calling its `connect` implementation. + * The filter will not touch any connection/data flags and can be + * used in happy eyeballing. Once selected for use, its `_active()` + * method needs to be called. + */ +CURLcode Curl_cf_unix_create(struct Curl_cfilter **pcf, + struct Curl_easy *data, + struct Curl_peer *origin, + struct Curl_peer *peer, + uint8_t transport_peer, + struct connectdata *conn, + struct Curl_sockaddr_ex *addr, + struct Curl_peer *tunnel_peer, + uint8_t tunnel_transport); + +/** + * Creates a cfilter that keeps a listening socket. + */ +CURLcode Curl_conn_tcp_listen_set(struct Curl_easy *data, + struct connectdata *conn, + int sockindex, + curl_socket_t *s); + +/** + * Return TRUE iff the last filter at `sockindex` was set via + * Curl_conn_tcp_listen_set(). + */ +bool Curl_conn_is_tcp_listen(struct Curl_easy *data, + int sockindex); + +/** + * Peek at the socket and remote ip/port the socket filter is using. + * The filter owns all returned values. + * @param psock pointer to hold socket descriptor or NULL + * @param paddr pointer to hold addr reference or NULL + * @param pip pointer to get IP quadruple or NULL + * Returns error if the filter is of invalid type. + */ +CURLcode Curl_cf_socket_peek(struct Curl_cfilter *cf, + struct Curl_easy *data, + curl_socket_t *psock, + const struct Curl_sockaddr_ex **paddr, + struct ip_quadruple *pip) WARN_UNUSED_RESULT; + +extern struct Curl_cftype Curl_cft_tcp; +extern struct Curl_cftype Curl_cft_udp; +extern struct Curl_cftype Curl_cft_unix; +extern struct Curl_cftype Curl_cft_tcp_accept; + +#endif /* HEADER_CURL_CF_SOCKET_H */ diff --git a/3rdparty/curl-8.21.0/lib/cfilters.c b/3rdparty/curl-8.21.0/lib/cfilters.c new file mode 100644 index 0000000000..fb1914d133 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/cfilters.c @@ -0,0 +1,1087 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "urldata.h" +#include "strerror.h" +#include "cfilters.h" +#include "connect.h" +#include "url.h" +#include "curl_trc.h" +#include "progress.h" +#include "select.h" +#include "curlx/strparse.h" + +CURLcode Curl_cf_def_connect(struct Curl_cfilter *cf, + struct Curl_easy *data, bool *done) +{ + CURLcode result; + + if(cf->connected) { + *done = TRUE; + return CURLE_OK; + } + + if(cf->next) { + result = cf->next->cft->do_connect(cf->next, data, done); + if(result || !*done) + return result; + } + + cf->connected = TRUE; + *done = TRUE; + return CURLE_OK; +} + +CURLcode Curl_cf_def_shutdown(struct Curl_cfilter *cf, + struct Curl_easy *data, bool *done) +{ + (void)cf; + (void)data; + *done = TRUE; + return CURLE_OK; +} + +CURLcode Curl_cf_def_adjust_pollset(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct easy_pollset *ps) +{ + /* NOP */ + (void)cf; + (void)data; + (void)ps; + return CURLE_OK; +} + +bool Curl_cf_def_data_pending(struct Curl_cfilter *cf, + const struct Curl_easy *data) +{ + return cf->next ? + cf->next->cft->has_data_pending(cf->next, data) : FALSE; +} + +CURLcode Curl_cf_def_send(struct Curl_cfilter *cf, struct Curl_easy *data, + const uint8_t *buf, size_t len, bool eos, + size_t *pnwritten) +{ + if(cf->next) + return cf->next->cft->do_send(cf->next, data, buf, len, eos, pnwritten); + *pnwritten = 0; + return CURLE_RECV_ERROR; +} + +CURLcode Curl_cf_def_recv(struct Curl_cfilter *cf, struct Curl_easy *data, + char *buf, size_t len, size_t *pnread) +{ + if(cf->next) + return cf->next->cft->do_recv(cf->next, data, buf, len, pnread); + *pnread = 0; + return CURLE_SEND_ERROR; +} + +bool Curl_cf_def_conn_is_alive(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *input_pending) +{ + return cf->next ? + cf->next->cft->is_alive(cf->next, data, input_pending) : + FALSE; /* pessimistic in absence of data */ +} + +CURLcode Curl_cf_def_conn_keep_alive(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + return cf->next ? + cf->next->cft->keep_alive(cf->next, data) : + CURLE_OK; +} + +CURLcode Curl_cf_def_query(struct Curl_cfilter *cf, + struct Curl_easy *data, + int query, int *pres1, void *pres2) +{ + return cf->next ? + cf->next->cft->query(cf->next, data, query, pres1, pres2) : + CURLE_UNKNOWN_OPTION; +} + +#ifdef CURLVERBOSE +void Curl_conn_trc_filters(struct Curl_easy *data, + int sockindex, const char *info) +{ + if(CURL_TRC_M_is_verbose(data) && data->conn) { + struct Curl_cfilter *cf = data->conn->cfilter[sockindex]; + + if(cf) { + char msg[256], *buf; + int blen, n; + + buf = msg; + blen = sizeof(msg) - 1; + n = curl_msnprintf(buf, blen, "%s [%d]", info, sockindex); + buf += n; + blen -= n; + for(; cf && blen; cf = cf->next) { + n = curl_msnprintf(buf, blen, "[%s%s]", + cf->connected ? "" : "!", cf->cft->name); + buf += n; + blen -= n; + } + CURL_TRC_M(data, "%s%s", msg, blen ? "" : "..."); + } + else + CURL_TRC_M(data, "%s [%d][-]", info, sockindex); + } +} +#endif /* CURLVERBOSE */ + +void Curl_conn_cf_discard_chain(struct Curl_cfilter **pcf, + struct Curl_easy *data) +{ + struct Curl_cfilter *cfn, *cf = *pcf; + + if(cf) { + *pcf = NULL; + while(cf) { + cfn = cf->next; + /* prevent destroying filter to mess with its sub-chain, since + * we have the reference now and will call destroy on it. + */ + cf->next = NULL; + cf->cft->destroy(cf, data); + curlx_free(cf); + cf = cfn; + } + } +} + +void Curl_conn_cf_discard_all(struct Curl_easy *data, + struct connectdata *conn, int sockindex) +{ + struct curltime *pt = &conn->shutdown.start[sockindex]; + memset(pt, 0, sizeof(*pt)); + Curl_conn_cf_discard_chain(&conn->cfilter[sockindex], data); +} + +CURLcode Curl_conn_shutdown(struct Curl_easy *data, int sockindex, bool *done) +{ + struct Curl_cfilter *cf; + CURLcode result = CURLE_OK; + timediff_t timeout_ms; + + DEBUGASSERT(data->conn); + + if(!CONN_SOCK_IDX_VALID(sockindex)) + return CURLE_BAD_FUNCTION_ARGUMENT; + + /* Get the first connected filter that is not shut down already. */ + cf = data->conn->cfilter[sockindex]; + while(cf && (!cf->connected || cf->shutdown)) + cf = cf->next; + + if(!cf) { + *done = TRUE; + return CURLE_OK; + } + + *done = FALSE; + if(!Curl_shutdown_started(data, sockindex)) { + Curl_shutdown_start(data, sockindex, 0); + } + else { + timeout_ms = Curl_shutdown_timeleft(data, data->conn, sockindex); + if(timeout_ms < 0) { + /* info message, since this might be regarded as acceptable */ + infof(data, "shutdown timeout"); + return CURLE_OPERATION_TIMEDOUT; + } + } + + while(cf) { + if(!cf->shutdown) { + bool cfdone = FALSE; + result = cf->cft->do_shutdown(cf, data, &cfdone); + if(result) { + CURL_TRC_CF(data, cf, "shut down failed with %d", (int)result); + return result; + } + else if(!cfdone) { + CURL_TRC_CF(data, cf, "shut down not done yet"); + return CURLE_OK; + } + CURL_TRC_CF(data, cf, "shut down successfully"); + cf->shutdown = TRUE; + } + cf = cf->next; + } + *done = (!result); + return result; +} + +CURLcode Curl_cf_recv(struct Curl_easy *data, int sockindex, char *buf, + size_t len, size_t *pnread) +{ + struct Curl_cfilter *cf; + + DEBUGASSERT(data); + DEBUGASSERT(data->conn); + cf = data->conn->cfilter[sockindex]; + while(cf && !cf->connected) + cf = cf->next; + if(cf) + return cf->cft->do_recv(cf, data, buf, len, pnread); + failf(data, "recv: no filter connected"); + DEBUGASSERT(0); + *pnread = 0; + return CURLE_FAILED_INIT; +} + +CURLcode Curl_cf_send(struct Curl_easy *data, int sockindex, + const uint8_t *buf, size_t len, bool eos, + size_t *pnwritten) +{ + struct Curl_cfilter *cf; + + DEBUGASSERT(data); + DEBUGASSERT(data->conn); + cf = data->conn->cfilter[sockindex]; + while(cf && !cf->connected) + cf = cf->next; + if(cf) { + return cf->cft->do_send(cf, data, buf, len, eos, pnwritten); + } + failf(data, "send: no filter connected"); + DEBUGASSERT(0); + *pnwritten = 0; + return CURLE_FAILED_INIT; +} + +struct cf_io_ctx { + struct Curl_easy *data; + struct Curl_cfilter *cf; +}; + +static CURLcode cf_bufq_reader(void *writer_ctx, + unsigned char *buf, size_t blen, + size_t *pnread) +{ + struct cf_io_ctx *io = writer_ctx; + return Curl_conn_cf_recv(io->cf, io->data, (char *)buf, blen, pnread); +} + +CURLcode Curl_cf_recv_bufq(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct bufq *bufq, + size_t maxlen, + size_t *pnread) +{ + struct cf_io_ctx io; + + if(!cf || !data) { + *pnread = 0; + return CURLE_BAD_FUNCTION_ARGUMENT; + } + io.data = data; + io.cf = cf; + return Curl_bufq_sipn(bufq, maxlen, cf_bufq_reader, &io, pnread); +} + +static CURLcode cf_bufq_writer(void *writer_ctx, + const uint8_t *buf, size_t buflen, + size_t *pnwritten) +{ + struct cf_io_ctx *io = writer_ctx; + return Curl_conn_cf_send(io->cf, io->data, buf, buflen, FALSE, pnwritten); +} + +CURLcode Curl_cf_send_bufq(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct bufq *bufq, + const unsigned char *buf, size_t blen, + size_t *pnwritten) +{ + struct cf_io_ctx io; + + if(!cf || !data) { + *pnwritten = 0; + return CURLE_BAD_FUNCTION_ARGUMENT; + } + io.data = data; + io.cf = cf; + if(buf && blen) + return Curl_bufq_write_pass(bufq, buf, blen, cf_bufq_writer, &io, + pnwritten); + else + return Curl_bufq_pass(bufq, cf_bufq_writer, &io, pnwritten); +} + +CURLcode Curl_cf_create(struct Curl_cfilter **pcf, + const struct Curl_cftype *cft, + void *ctx) +{ + struct Curl_cfilter *cf; + CURLcode result = CURLE_OUT_OF_MEMORY; + + DEBUGASSERT(cft); + cf = curlx_calloc(1, sizeof(*cf)); + if(!cf) + goto out; + + cf->cft = cft; + cf->ctx = ctx; + result = CURLE_OK; +out: + *pcf = cf; + return result; +} + +void Curl_conn_cf_add(struct Curl_easy *data, + struct connectdata *conn, + int sockindex, + struct Curl_cfilter *cf) +{ + DEBUGASSERT(conn); + DEBUGASSERT(!cf->conn); + DEBUGASSERT(!cf->next); + + cf->next = conn->cfilter[sockindex]; + cf->conn = conn; + cf->sockindex = sockindex; + conn->cfilter[sockindex] = cf; + CURL_TRC_CF(data, cf, "added"); +} + +void Curl_conn_cf_insert_after(struct Curl_cfilter *cf_at, + struct Curl_cfilter *cf_new) +{ + struct Curl_cfilter *tail, **pnext; + + DEBUGASSERT(cf_at); + DEBUGASSERT(cf_new); + DEBUGASSERT(!cf_new->conn); + + tail = cf_at->next; + cf_at->next = cf_new; + do { + cf_new->conn = cf_at->conn; + cf_new->sockindex = cf_at->sockindex; + pnext = &cf_new->next; + cf_new = cf_new->next; + } while(cf_new); + *pnext = tail; +} + +bool Curl_conn_cf_discard(struct Curl_cfilter **pcf, + struct Curl_easy *data) +{ + struct Curl_cfilter *cf = pcf ? *pcf : NULL; + bool found = FALSE; + if(cf) { + if(cf->conn) { + /* unlink if present in connection filter chain */ + struct Curl_cfilter **pprev = &cf->conn->cfilter[cf->sockindex]; + while(*pprev) { + if(*pprev == *pcf) { + *pprev = (*pcf)->next; + cf->next = NULL; + found = TRUE; + break; + } + pprev = &((*pprev)->next); + } + } + Curl_conn_cf_discard_chain(pcf, data); + } + return found; +} + +CURLcode Curl_conn_cf_connect(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ + if(cf) + return cf->cft->do_connect(cf, data, done); + return CURLE_FAILED_INIT; +} + +CURLcode Curl_conn_cf_send(struct Curl_cfilter *cf, struct Curl_easy *data, + const uint8_t *buf, size_t len, bool eos, + size_t *pnwritten) +{ + if(cf) + return cf->cft->do_send(cf, data, buf, len, eos, pnwritten); + *pnwritten = 0; + return CURLE_SEND_ERROR; +} + +CURLcode Curl_conn_cf_recv(struct Curl_cfilter *cf, struct Curl_easy *data, + char *buf, size_t len, size_t *pnread) +{ + if(cf) + return cf->cft->do_recv(cf, data, buf, len, pnread); + *pnread = 0; + return CURLE_RECV_ERROR; +} + +static CURLcode cf_cntrl_all(struct connectdata *conn, + struct Curl_easy *data, + bool ignore_result, + int event, int arg1, void *arg2) +{ + CURLcode result = CURLE_OK; + size_t i; + + for(i = 0; i < CURL_ARRAYSIZE(conn->cfilter); ++i) { + result = Curl_conn_cf_cntrl(conn->cfilter[i], data, ignore_result, + event, arg1, arg2); + if(!ignore_result && result) + break; + } + return result; +} + +void Curl_conn_cntrl_update_info(struct Curl_easy *data, + struct connectdata *conn) +{ + cf_cntrl_all(conn, data, TRUE, CF_CTRL_CONN_INFO_UPDATE, 0, NULL); +} + +void Curl_conn_remove_setup_filters(struct Curl_easy *data, + int sockindex) +{ + struct Curl_cfilter **anchor = &data->conn->cfilter[sockindex]; + while(*anchor) { + struct Curl_cfilter *cf = *anchor; + if(cf->connected && (cf->cft->flags & CF_TYPE_SETUP)) { + *anchor = cf->next; + cf->next = NULL; + CURL_TRC_CF(data, cf, "removing connected setup filter"); + cf->cft->destroy(cf, data); + curlx_free(cf); + } + else + anchor = &cf->next; + } +} + +bool Curl_conn_is_setup(struct connectdata *conn, int sockindex) +{ + if(!CONN_SOCK_IDX_VALID(sockindex)) + return FALSE; + return !!conn->cfilter[sockindex]; +} + +bool Curl_conn_is_connected(struct connectdata *conn, int sockindex) +{ + struct Curl_cfilter *cf; + + if(!CONN_SOCK_IDX_VALID(sockindex)) + return FALSE; + cf = conn->cfilter[sockindex]; + if(cf) + return (bool)cf->connected; + else if(conn->scheme->flags & PROTOPT_NONETWORK) + return TRUE; + return FALSE; +} + +bool Curl_conn_is_ip_connected(struct Curl_easy *data, int sockindex) +{ + struct Curl_cfilter *cf; + + if(!CONN_SOCK_IDX_VALID(sockindex)) + return FALSE; + cf = data->conn->cfilter[sockindex]; + while(cf) { + if(cf->connected) + return TRUE; + if(cf->cft->flags & CF_TYPE_IP_CONNECT) + return FALSE; + cf = cf->next; + } + return FALSE; +} + +#ifndef CURL_DISABLE_PROXY +static bool cf_is_tunneling(struct Curl_cfilter *cf) +{ + for(; cf; cf = cf->next) { + if((cf->cft->flags & CF_TYPE_PROXY)) + return TRUE; + } + return FALSE; +} + +bool Curl_conn_is_tunneling(struct connectdata *conn, int sockindex) +{ + if(!CONN_SOCK_IDX_VALID(sockindex)) + return FALSE; + return conn ? cf_is_tunneling(conn->cfilter[sockindex]) : FALSE; +} +#else +bool Curl_conn_is_tunneling(struct connectdata *conn, int sockindex) +{ + (void)conn; + (void)sockindex; + return FALSE; +} +#endif /* CURL_DISABLE_PROXY */ + +static bool cf_is_ssl(struct Curl_cfilter *cf) +{ + for(; cf; cf = cf->next) { + /* A tunneling proxy does not offer end2end encryption, even if + * it does SSL itself (e.g. QUIC H3 proxy) */ + if((cf->cft->flags & CF_TYPE_SSL) && !(cf->cft->flags & CF_TYPE_PROXY)) + return TRUE; + if(cf->cft->flags & CF_TYPE_IP_CONNECT) + return FALSE; + } + return FALSE; +} + +bool Curl_conn_is_ssl(struct connectdata *conn, int sockindex) +{ + if(!CONN_SOCK_IDX_VALID(sockindex)) + return FALSE; + return conn ? cf_is_ssl(conn->cfilter[sockindex]) : FALSE; +} + +bool Curl_conn_get_ssl_info(struct Curl_easy *data, + struct connectdata *conn, int sockindex, + int query, + struct curl_tlssessioninfo *info) +{ + if(!CONN_SOCK_IDX_VALID(sockindex)) + return FALSE; + if(Curl_conn_is_ssl(conn, sockindex)) { + struct Curl_cfilter *cf = conn->cfilter[sockindex]; + CURLcode result = cf ? + cf->cft->query(cf, data, query, NULL, (void *)info) : + CURLE_UNKNOWN_OPTION; + return !result; + } + return FALSE; +} + +CURLcode Curl_conn_get_ip_info(struct Curl_easy *data, + struct connectdata *conn, int sockindex, + bool *is_ipv6, struct ip_quadruple *ipquad) +{ + struct Curl_cfilter *cf; + if(!CONN_SOCK_IDX_VALID(sockindex)) + return CURLE_BAD_FUNCTION_ARGUMENT; + cf = conn ? conn->cfilter[sockindex] : NULL; + return Curl_conn_cf_get_ip_info(cf, data, is_ipv6, ipquad); +} + +bool Curl_conn_is_multiplex(struct connectdata *conn, int sockindex) +{ + struct Curl_cfilter *cf; + + if(!CONN_SOCK_IDX_VALID(sockindex)) + return FALSE; + cf = conn ? conn->cfilter[sockindex] : NULL; + + for(; cf; cf = cf->next) { + if(cf->cft->flags & CF_TYPE_MULTIPLEX) + return TRUE; + if(cf->cft->flags & (CF_TYPE_IP_CONNECT | CF_TYPE_SSL)) + return FALSE; + } + return FALSE; +} + +unsigned char Curl_conn_get_transport(struct Curl_easy *data, + struct connectdata *conn) +{ + struct Curl_cfilter *cf = conn->cfilter[FIRSTSOCKET]; + return Curl_conn_cf_get_transport(cf, data); +} + +int Curl_socktype_for_transport(uint8_t transport) +{ + switch(transport) { + case TRNSPRT_TCP: + return SOCK_STREAM; + case TRNSPRT_UNIX: + return SOCK_STREAM; + default: /* UDP and QUIC */ + return SOCK_DGRAM; + } +} + +int Curl_protocol_for_transport(uint8_t transport) +{ + switch(transport) { + case TRNSPRT_TCP: + return IPPROTO_TCP; + case TRNSPRT_UNIX: + return IPPROTO_IP; + default: /* UDP and QUIC */ + return IPPROTO_UDP; + } +} + +bool Curl_conn_cf_wants_httpsrr(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + (void)data; + for(; cf; cf = cf->next) { + if(cf->cft->flags & CF_TYPE_HTTPSRR) + return TRUE; + } + return FALSE; +} + +const char *Curl_conn_get_alpn_negotiated(struct Curl_easy *data, + struct connectdata *conn) +{ + struct Curl_cfilter *cf = conn->cfilter[FIRSTSOCKET]; + return Curl_conn_cf_get_alpn_negotiated(cf, data); +} + +unsigned char Curl_conn_http_version(struct Curl_easy *data, + struct connectdata *conn) +{ + struct Curl_cfilter *cf; + CURLcode result = CURLE_UNKNOWN_OPTION; + unsigned char v = 0; + + cf = conn->cfilter[FIRSTSOCKET]; + for(; cf; cf = cf->next) { + if(cf->cft->flags & CF_TYPE_HTTP) { + int value = 0; + result = cf->cft->query(cf, data, CF_QUERY_HTTP_VERSION, &value, NULL); + if(!result && ((value < 0) || (value > 255))) + result = CURLE_FAILED_INIT; + else + v = (unsigned char)value; + break; + } + if(cf->cft->flags & (CF_TYPE_IP_CONNECT | CF_TYPE_SSL)) + break; + } + return (unsigned char)(result ? 0 : v); +} + +bool Curl_conn_data_pending(struct Curl_easy *data, int sockindex) +{ + struct Curl_cfilter *cf; + + (void)data; + DEBUGASSERT(data); + DEBUGASSERT(data->conn); + if(!CONN_SOCK_IDX_VALID(sockindex)) + return FALSE; + + cf = data->conn->cfilter[sockindex]; + while(cf && !cf->connected) { + cf = cf->next; + } + if(cf) { + return cf->cft->has_data_pending(cf, data); + } + return FALSE; +} + +bool Curl_conn_cf_needs_flush(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + CURLcode result; + int pending = 0; + result = cf ? cf->cft->query(cf, data, CF_QUERY_NEED_FLUSH, + &pending, NULL) : CURLE_UNKNOWN_OPTION; + return (result || !pending) ? FALSE : TRUE; +} + +bool Curl_conn_needs_flush(struct Curl_easy *data, int sockindex) +{ + if(!CONN_SOCK_IDX_VALID(sockindex)) + return FALSE; + return Curl_conn_cf_needs_flush(data->conn->cfilter[sockindex], data); +} + +CURLcode Curl_conn_cf_adjust_pollset(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct easy_pollset *ps) +{ + CURLcode result = CURLE_OK; + /* Get the lowest not-connected filter, if there are any */ + while(cf && !cf->connected && cf->next && !cf->next->connected) + cf = cf->next; + /* Skip all filters that have already shut down */ + while(cf && cf->shutdown) + cf = cf->next; + /* From there on, give all filters a chance to adjust the pollset. + * Lower filters are called later, so they may override */ + while(cf && !result) { + result = cf->cft->adjust_pollset(cf, data, ps); + cf = cf->next; + } + return result; +} + +CURLcode Curl_conn_adjust_pollset(struct Curl_easy *data, + struct connectdata *conn, + struct easy_pollset *ps) +{ + CURLcode result = CURLE_OK; + int i; + + DEBUGASSERT(data); + DEBUGASSERT(conn); + /* During connect time, connection filters may add sockets to the pollset + * even when the transfer neither wants to send nor receive. And those + * sockets, when having events, are served. + * Once connected however, a transfer that neither wants to send nor receive + * will never call the connection filters. Any sockets added by the filters + * will not change state and POLLIN/POLLOUT events will trigger forever, + * making us busy loop. See #21671 */ + if(ps->n || !Curl_conn_is_connected(conn, FIRSTSOCKET) || + (conn->cfilter[SECONDARYSOCKET] && + !Curl_conn_is_connected(conn, SECONDARYSOCKET))) { + for(i = 0; (i < 2) && !result && conn; ++i) { + result = Curl_conn_cf_adjust_pollset(conn->cfilter[i], data, ps); + } + } + return result; +} + +/* + * Return values: + * -1 = error + * 0 = timeout + * N = number of structures with non zero revent fields + */ +int Curl_conn_cf_poll(struct Curl_cfilter *cf, + struct Curl_easy *data, + timediff_t timeout_ms) +{ + struct easy_pollset ps; + int rc; + CURLcode result; + + DEBUGASSERT(cf); + DEBUGASSERT(data); + DEBUGASSERT(data->conn); + Curl_pollset_init(&ps); + + result = Curl_conn_cf_adjust_pollset(cf, data, &ps); + if(!result) + rc = Curl_pollset_poll(data, &ps, timeout_ms); + else + rc = -1; + Curl_pollset_cleanup(&ps); + return rc; +} + +void Curl_conn_get_current_host(struct Curl_easy *data, int sockindex, + const char **phost, int *pport) +{ + struct Curl_cfilter *cf, *cf_proxy = NULL; + int portarg = -1; + + if(!data->conn) { + DEBUGASSERT(0); + *phost = ""; + if(pport) + *pport = -1; + return; + } + + cf = CONN_SOCK_IDX_VALID(sockindex) ? data->conn->cfilter[sockindex] : NULL; + /* Find the "lowest" tunneling proxy filter that has not connected yet. */ + while(cf && !cf->connected) { + if((cf->cft->flags & (CF_TYPE_IP_CONNECT | CF_TYPE_PROXY)) == + (CF_TYPE_IP_CONNECT | CF_TYPE_PROXY)) + cf_proxy = cf; + cf = cf->next; + } + /* cf_proxy (!= NULL) is not connected yet. It is talking + * to an interim host and any authentication or other things apply + * to this interim host and port. */ + if(!cf_proxy || cf_proxy->cft->query(cf_proxy, data, CF_QUERY_HOST_PORT, + &portarg, CURL_UNCONST(phost))) { + /* Everything connected or query unsuccessful, the overall + * connection's destination is the answer */ + *phost = data->conn->origin->hostname; + portarg = data->conn->origin->port; + } + if(pport) + *pport = portarg; +} + +CURLcode Curl_cf_def_cntrl(struct Curl_cfilter *cf, + struct Curl_easy *data, + int event, int arg1, void *arg2) +{ + (void)cf; + (void)data; + (void)event; + (void)arg1; + (void)arg2; + return CURLE_OK; +} + +CURLcode Curl_conn_cf_cntrl(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool ignore_result, + int event, int arg1, void *arg2) +{ + CURLcode result = CURLE_OK; + + for(; cf; cf = cf->next) { + if(cf->cft->cntrl == Curl_cf_def_cntrl) + continue; + result = cf->cft->cntrl(cf, data, event, arg1, arg2); + if(!ignore_result && result) + break; + } + return result; +} + +curl_socket_t Curl_conn_cf_get_socket(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + curl_socket_t sock; + if(cf && !cf->cft->query(cf, data, CF_QUERY_SOCKET, NULL, &sock)) + return sock; + return CURL_SOCKET_BAD; +} + +unsigned char Curl_conn_cf_get_transport(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + int transport = 0; + if(cf && !cf->cft->query(cf, data, CF_QUERY_TRANSPORT, &transport, NULL)) + return (unsigned char)transport; + return (unsigned char)(data->conn ? data->conn->transport_wanted : 0); +} + +const char *Curl_conn_cf_get_alpn_negotiated(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + const char *alpn = NULL; + CURL_TRC_CF(data, cf, "query ALPN"); + if(cf && !cf->cft->query(cf, data, CF_QUERY_ALPN_NEGOTIATED, NULL, + CURL_UNCONST(&alpn))) + return alpn; + return NULL; +} + +static const struct Curl_sockaddr_ex *cf_get_remote_addr( + struct Curl_cfilter *cf, struct Curl_easy *data) +{ + const struct Curl_sockaddr_ex *remote_addr = NULL; + if(cf && + !cf->cft->query(cf, data, CF_QUERY_REMOTE_ADDR, NULL, + CURL_UNCONST(&remote_addr))) + return remote_addr; + return NULL; +} + +CURLcode Curl_conn_cf_get_ip_info(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *is_ipv6, struct ip_quadruple *ipquad) +{ + CURLcode result = CURLE_UNKNOWN_OPTION; + if(cf) { + int ipv6 = 0; + result = cf->cft->query(cf, data, CF_QUERY_IP_INFO, &ipv6, ipquad); + *is_ipv6 = !!ipv6; + } + return result; +} + +curl_socket_t Curl_conn_get_first_socket(struct Curl_easy *data) +{ + struct Curl_cfilter *cf; + + if(!data->conn) + return CURL_SOCKET_BAD; + + cf = data->conn->cfilter[FIRSTSOCKET]; + /* if the top filter has not connected, ask it (and its sub-filters) + * for the socket. Otherwise conn->sock[sockindex] should have it. */ + if(cf && !cf->connected) + return Curl_conn_cf_get_socket(cf, data); + return data->conn->sock[FIRSTSOCKET]; +} + +const struct Curl_sockaddr_ex *Curl_conn_get_remote_addr( + struct Curl_easy *data, int sockindex) +{ + struct Curl_cfilter *cf = + (data->conn && CONN_SOCK_IDX_VALID(sockindex)) ? + data->conn->cfilter[sockindex] : NULL; + return cf ? cf_get_remote_addr(cf, data) : NULL; +} + +CURLcode Curl_conn_ev_data_setup(struct Curl_easy *data) +{ + return cf_cntrl_all(data->conn, data, FALSE, CF_CTRL_DATA_SETUP, 0, NULL); +} + +CURLcode Curl_conn_flush(struct Curl_easy *data, int sockindex) +{ + if(!CONN_SOCK_IDX_VALID(sockindex)) + return CURLE_BAD_FUNCTION_ARGUMENT; + return Curl_conn_cf_cntrl(data->conn->cfilter[sockindex], data, FALSE, + CF_CTRL_FLUSH, 0, NULL); +} + +/** + * Notify connection filters that the transfer represented by `data` + * is done with sending data (e.g. has uploaded everything). + */ +void Curl_conn_ev_data_done_send(struct Curl_easy *data) +{ + cf_cntrl_all(data->conn, data, TRUE, CF_CTRL_DATA_DONE_SEND, 0, NULL); +} + +/** + * Notify connection filters that the transfer represented by `data` + * is finished - eventually premature, e.g. before being complete. + */ +void Curl_conn_ev_data_done(struct Curl_easy *data, bool premature) +{ + cf_cntrl_all(data->conn, data, TRUE, CF_CTRL_DATA_DONE, premature, NULL); +} + +CURLcode Curl_conn_ev_data_pause(struct Curl_easy *data, bool do_pause) +{ + return cf_cntrl_all(data->conn, data, FALSE, + CF_CTRL_DATA_PAUSE, do_pause, NULL); +} + +bool Curl_conn_is_alive(struct Curl_easy *data, struct connectdata *conn, + bool *input_pending) +{ + struct Curl_cfilter *cf = conn->cfilter[FIRSTSOCKET]; + return cf && !cf->conn->bits.close && + cf->cft->is_alive(cf, data, input_pending); +} + +CURLcode Curl_conn_keep_alive(struct Curl_easy *data, + struct connectdata *conn, + int sockindex) +{ + struct Curl_cfilter *cf; + + if(!CONN_SOCK_IDX_VALID(sockindex)) + return CURLE_BAD_FUNCTION_ARGUMENT; + cf = conn->cfilter[sockindex]; + return cf ? cf->cft->keep_alive(cf, data) : CURLE_OK; +} + +size_t Curl_conn_get_max_concurrent(struct Curl_easy *data, + struct connectdata *conn, + int sockindex) +{ + struct Curl_cfilter *cf; + CURLcode result; + int n = -1; + + if(!CONN_SOCK_IDX_VALID(sockindex)) + return 0; + + cf = conn->cfilter[sockindex]; + result = cf ? cf->cft->query(cf, data, CF_QUERY_MAX_CONCURRENT, + &n, NULL) : CURLE_UNKNOWN_OPTION; + /* If no filter answered the query, the default is a non-multiplexed + * connection with limit 1. Otherwise, the query may return 0 + * for connections that are in shutdown, e.g. server HTTP/2 GOAWAY. */ + return (result || n < 0) ? 1 : (size_t)n; +} + +int Curl_conn_get_stream_error(struct Curl_easy *data, + struct connectdata *conn, + int sockindex) +{ + struct Curl_cfilter *cf; + CURLcode result; + int n = 0; + + if(!CONN_SOCK_IDX_VALID(sockindex)) + return 0; + + cf = conn->cfilter[sockindex]; + result = cf ? cf->cft->query(cf, data, CF_QUERY_STREAM_ERROR, + &n, NULL) : CURLE_UNKNOWN_OPTION; + return (result || n < 0) ? 0 : n; +} + +int Curl_conn_sockindex(struct Curl_easy *data, curl_socket_t sockfd) +{ + if(data && data->conn && + sockfd != CURL_SOCKET_BAD && sockfd == data->conn->sock[SECONDARYSOCKET]) + return SECONDARYSOCKET; + return FIRSTSOCKET; +} + +CURLcode Curl_conn_recv(struct Curl_easy *data, int sockindex, + char *buf, size_t len, size_t *pnread) +{ + DEBUGASSERT(data); + DEBUGASSERT(data->conn); + if(!CONN_SOCK_IDX_VALID(sockindex)) + return CURLE_BAD_FUNCTION_ARGUMENT; + if(data && data->conn && data->conn->recv[sockindex]) + return data->conn->recv[sockindex](data, sockindex, buf, len, pnread); + *pnread = 0; + return CURLE_FAILED_INIT; +} + +CURLcode Curl_conn_send(struct Curl_easy *data, int sockindex, + const void *buf, size_t len, bool eos, + size_t *pnwritten) +{ + size_t write_len = len; + + DEBUGASSERT(data); + DEBUGASSERT(data->conn); + DEBUGASSERT(CONN_SOCK_IDX_VALID(sockindex)); + if(!CONN_SOCK_IDX_VALID(sockindex)) + return CURLE_BAD_FUNCTION_ARGUMENT; +#ifdef DEBUGBUILD + if(write_len) { + /* Allow debug builds to override this logic to force short sends */ + const char *p = getenv("CURL_SMALLSENDS"); + if(p) { + curl_off_t altsize; + if(!curlx_str_number(&p, &altsize, write_len)) { + write_len = (size_t)altsize; + if(write_len != len) + eos = FALSE; + } + } + } +#endif + if(data && data->conn && data->conn->send[sockindex]) + return data->conn->send[sockindex](data, sockindex, buf, write_len, eos, + pnwritten); + *pnwritten = 0; + return CURLE_FAILED_INIT; +} diff --git a/3rdparty/curl-8.21.0/lib/cfilters.h b/3rdparty/curl-8.21.0/lib/cfilters.h new file mode 100644 index 0000000000..b1aad029e0 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/cfilters.h @@ -0,0 +1,691 @@ +#ifndef HEADER_CURL_CFILTERS_H +#define HEADER_CURL_CFILTERS_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curlx/timediff.h" + +struct bufq; +struct Curl_cfilter; +struct Curl_easy; +struct Curl_dns_entry; +struct connectdata; +struct ip_quadruple; +struct curl_tlssessioninfo; + +/* Callback to destroy resources held by this filter instance. + * Implementations MUST NOT chain calls to cf->next. + */ +typedef void Curl_cft_destroy_this(struct Curl_cfilter *cf, + struct Curl_easy *data); + +/* Callback to close the connection filter gracefully, non-blocking. + * Implementations MUST NOT chain calls to cf->next. + */ +typedef CURLcode Curl_cft_shutdown(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done); + +typedef CURLcode Curl_cft_connect(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done); + +struct easy_pollset; + +/* Passing in an easy_pollset for monitoring of sockets, let + * filters add or remove sockets actions (CURL_POLL_OUT, CURL_POLL_IN). + * This may add a socket or, in case no actions remain, remove + * a socket from the set. + * + * Filter implementations need to call filters "below" *after* they have + * made their adjustments. This allows lower filters to override "upper" + * actions. If a "lower" filter is unable to write, it needs to be able + * to disallow POLL_OUT. + * + * A filter without own restrictions/preferences should not modify + * the pollset. Filters, whose filter "below" is not connected, should + * also do no adjustments. + * + * Examples: a TLS handshake, while ongoing, might remove POLL_IN when it + * needs to write, or vice versa. An HTTP/2 filter might remove POLL_OUT when + * a stream window is exhausted and a WINDOW_UPDATE needs to be received first + * and add instead POLL_IN. + * + * @param cf the filter to ask + * @param data the easy handle the pollset is about + * @param ps the pollset (inout) for the easy handle + */ +typedef CURLcode Curl_cft_adjust_pollset(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct easy_pollset *ps); + +typedef bool Curl_cft_data_pending(struct Curl_cfilter *cf, + const struct Curl_easy *data); + +typedef CURLcode Curl_cft_send(struct Curl_cfilter *cf, + struct Curl_easy *data, /* transfer */ + const uint8_t *buf, /* data to write */ + size_t len, /* amount to write */ + bool eos, /* last chunk */ + size_t *pnwritten); /* how much sent */ + +typedef CURLcode Curl_cft_recv(struct Curl_cfilter *cf, + struct Curl_easy *data, /* transfer */ + char *buf, /* store data here */ + size_t len, /* amount to read */ + size_t *pnread); /* how much received */ + +typedef bool Curl_cft_conn_is_alive(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *input_pending); + +typedef CURLcode Curl_cft_conn_keep_alive(struct Curl_cfilter *cf, + struct Curl_easy *data); + +/** + * Events/controls for connection filters, their arguments and + * return code handling. Filter callbacks are invoked "top down". + * Return code handling: + * "first fail" meaning that the first filter returning != CURLE_OK, will + * abort further event distribution and determine the result. + * "ignored" meaning return values are ignored and the event is distributed + * to all filters in the chain. Overall result is always CURLE_OK. + */ +/* data event arg1 arg2 return */ +#define CF_CTRL_DATA_SETUP 4 /* 0 NULL first fail */ +/* unused now 5 */ +#define CF_CTRL_DATA_PAUSE 6 /* on/off NULL first fail */ +#define CF_CTRL_DATA_DONE 7 /* premature NULL ignored */ +#define CF_CTRL_DATA_DONE_SEND 8 /* 0 NULL ignored */ +/* update conn info at connection and data */ +#define CF_CTRL_CONN_INFO_UPDATE (256 + 0) /* 0 NULL ignored */ +#define CF_CTRL_FORGET_SOCKET (256 + 1) /* 0 NULL ignored */ +#define CF_CTRL_FLUSH (256 + 2) /* 0 NULL first fail */ + +/** + * Handle event/control for the filter. + * Implementations MUST NOT chain calls to cf->next. + */ +typedef CURLcode Curl_cft_cntrl(struct Curl_cfilter *cf, + struct Curl_easy *data, + int event, int arg1, void *arg2); + +/** + * Queries to ask via a `Curl_cft_query *query` method on a cfilter chain. + * - MAX_CONCURRENT: the maximum number of parallel transfers the filter + * chain expects to handle at the same time. + * default: 1 if no filter overrides. + * - CONNECT_REPLY_MS: milliseconds until the first indication of a server + * response was received on a connect. For TCP, this + * reflects the time until the socket connected. On UDP + * this gives the time the first bytes from the server + * were received. + * -1 if not determined yet. + * - CF_QUERY_SOCKET: the socket used by the filter chain + * - CF_QUERY_NEED_FLUSH: TRUE iff any of the filters have unsent data + * - CF_QUERY_IP_INFO: res1 says if connection used IPv6, res2 is the + * ip quadruple + * - CF_QUERY_HOST_PORT: the remote hostname and port a filter talks to + * - CF_QUERY_SSL_INFO: fill out the passed curl_tlssessioninfo with the + * internal from the SSL secured connection when + * available. + * - CF_QUERY_SSL_CTX_INFO: same as CF_QUERY_SSL_INFO, but give the SSL_CTX + * when available, or the same internal pointer + * when the TLS stack does not differentiate. + * - CF_QUERY_ALPN_NEGOTIATED: The ALPN selected by the server as + null-terminated string or NULL if none + selected/handshake not done. Implemented by filter + types CF_TYPE_SSL or CF_TYPE_IP_CONNECT. + */ +/* query res1 res2 */ +#define CF_QUERY_MAX_CONCURRENT 1 /* number - */ +#define CF_QUERY_CONNECT_REPLY_MS 2 /* number - */ +#define CF_QUERY_SOCKET 3 /* - curl_socket_t */ +#define CF_QUERY_TIMER_CONNECT 4 /* - struct curltime */ +#define CF_QUERY_TIMER_APPCONNECT 5 /* - struct curltime */ +#define CF_QUERY_STREAM_ERROR 6 /* error code - */ +#define CF_QUERY_NEED_FLUSH 7 /* TRUE/FALSE - */ +#define CF_QUERY_IP_INFO 8 /* TRUE/FALSE struct ip_quadruple */ +#define CF_QUERY_HTTP_VERSION 9 /* number (10/11/20/30) - */ +/* pass in a `const struct Curl_sockaddr_ex **` as `pres2`. Gets set + * to NULL when not connected. */ +#define CF_QUERY_REMOTE_ADDR 10 /* - `Curl_sockaddr_ex *` */ +#define CF_QUERY_HOST_PORT 11 /* port const char * */ +#define CF_QUERY_SSL_INFO 12 /* - struct curl_tlssessioninfo * */ +#define CF_QUERY_SSL_CTX_INFO 13 /* - struct curl_tlssessioninfo * */ +#define CF_QUERY_TRANSPORT 14 /* TRNSPRT_* - * */ +#define CF_QUERY_ALPN_NEGOTIATED 15 /* - const char * */ + +/** + * Query the cfilter for properties. Filters ignorant of a query will + * pass it "down" the filter chain. + */ +typedef CURLcode Curl_cft_query(struct Curl_cfilter *cf, + struct Curl_easy *data, + int query, int *pres1, void *pres2); + +/** + * Type flags for connection filters. A filter can have none, one or + * many of those. Use to evaluate state/capabilities of a filter chain. + * + * CF_TYPE_IP_CONNECT: provides an IP connection or sth equivalent, like + * a CONNECT tunnel, a UNIX domain socket, a QUIC + * connection, etc. + * CF_TYPE_SSL: provide SSL/TLS + * CF_TYPE_MULTIPLEX: provides multiplexing of easy handles + * CF_TYPE_PROXY provides proxying + * CF_TYPE_HTTP implement a version of the HTTP protocol + * CF_TYPE_SETUP filter is only needed for connection setup and + * can be removed once connected + * CF_TYPE_HTTPSRR filter that wants HTTPS-RR information + */ +#define CF_TYPE_IP_CONNECT (1 << 0) +#define CF_TYPE_SSL (1 << 1) +#define CF_TYPE_MULTIPLEX (1 << 2) +#define CF_TYPE_PROXY (1 << 3) +#define CF_TYPE_HTTP (1 << 4) +#define CF_TYPE_SETUP (1 << 5) +#define CF_TYPE_HTTPSRR (1 << 6) + +/* A connection filter type, e.g. specific implementation. */ +struct Curl_cftype { + const char *name; /* name of the filter type */ + int flags; /* flags of filter type */ + int log_level; /* log level for such filters */ + Curl_cft_destroy_this *destroy; /* destroy resources of this cf */ + Curl_cft_connect *do_connect; /* establish connection */ + Curl_cft_shutdown *do_shutdown; /* shutdown conn */ + Curl_cft_adjust_pollset *adjust_pollset; /* adjust transfer poll set */ + Curl_cft_data_pending *has_data_pending; /* conn has data pending */ + Curl_cft_send *do_send; /* send data */ + Curl_cft_recv *do_recv; /* receive data */ + Curl_cft_cntrl *cntrl; /* events/control */ + Curl_cft_conn_is_alive *is_alive; /* FALSE if conn is dead, Jim! */ + Curl_cft_conn_keep_alive *keep_alive; /* try to keep it alive */ + Curl_cft_query *query; /* query filter chain */ +}; + +/* A connection filter instance, e.g. registered at a connection */ +struct Curl_cfilter { + const struct Curl_cftype *cft; /* the type providing implementation */ + struct Curl_cfilter *next; /* next filter in chain */ + void *ctx; /* filter type specific settings */ + struct connectdata *conn; /* the connection this filter belongs to */ + int sockindex; /* the index the filter is installed at */ + BIT(connected); /* != 0 iff this filter is connected */ + BIT(shutdown); /* != 0 iff this filter has shut down */ +}; + +/* Default implementations for the type functions, implementing nop. */ +void Curl_cf_def_destroy_this(struct Curl_cfilter *cf, + struct Curl_easy *data); + +/* Default implementations for the type functions, implementing pass-through + * the filter chain. */ +CURLcode Curl_cf_def_adjust_pollset(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct easy_pollset *ps); +bool Curl_cf_def_data_pending(struct Curl_cfilter *cf, + const struct Curl_easy *data); +CURLcode Curl_cf_def_send(struct Curl_cfilter *cf, struct Curl_easy *data, + const uint8_t *buf, size_t len, bool eos, + size_t *pnwritten); +CURLcode Curl_cf_def_recv(struct Curl_cfilter *cf, struct Curl_easy *data, + char *buf, size_t len, size_t *pnread); +CURLcode Curl_cf_def_cntrl(struct Curl_cfilter *cf, + struct Curl_easy *data, + int event, int arg1, void *arg2); +bool Curl_cf_def_conn_is_alive(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *input_pending); +CURLcode Curl_cf_def_conn_keep_alive(struct Curl_cfilter *cf, + struct Curl_easy *data); +CURLcode Curl_cf_def_query(struct Curl_cfilter *cf, + struct Curl_easy *data, + int query, int *pres1, void *pres2); +CURLcode Curl_cf_def_shutdown(struct Curl_cfilter *cf, + struct Curl_easy *data, bool *done); +CURLcode Curl_cf_def_connect(struct Curl_cfilter *cf, + struct Curl_easy *data, bool *done); + +/** + * Create a new filter instance, unattached to the filter chain. + * Use Curl_conn_cf_add() to add it to the chain. + * @param pcf on success holds the created instance + * @param cft the filter type + * @param ctx the type specific context to use + */ +CURLcode Curl_cf_create(struct Curl_cfilter **pcf, + const struct Curl_cftype *cft, + void *ctx); + +/** + * Add a filter instance to the `sockindex` filter chain at connection + * `conn`. The filter must not already be attached. It is inserted at + * the start of the chain (top). + */ +void Curl_conn_cf_add(struct Curl_easy *data, + struct connectdata *conn, + int sockindex, + struct Curl_cfilter *cf); + +/** + * Insert a filter (chain) after `cf_at`. + * `cf_new` must not already be attached. + */ +void Curl_conn_cf_insert_after(struct Curl_cfilter *cf_at, + struct Curl_cfilter *cf_new); + +/** + * Extract filter `*pcf` from its connection filter chain. + * Destroy `*pcf`, even if it was not part of the chain and NULL it. + * Returns TRUE of cf has been part of chain. + */ +bool Curl_conn_cf_discard(struct Curl_cfilter **pcf, + struct Curl_easy *data); + +/** + * Discard all cfilters starting with `*pcf` and clearing it afterwards. + */ +void Curl_conn_cf_discard_chain(struct Curl_cfilter **pcf, + struct Curl_easy *data); + +/** + * Remove and destroy all filters at chain `sockindex` on connection `conn`. + */ +void Curl_conn_cf_discard_all(struct Curl_easy *data, + struct connectdata *conn, int sockindex); + +CURLcode Curl_conn_cf_connect(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done); +CURLcode Curl_conn_cf_send(struct Curl_cfilter *cf, struct Curl_easy *data, + const uint8_t *buf, size_t len, bool eos, + size_t *pnwritten); +CURLcode Curl_conn_cf_recv(struct Curl_cfilter *cf, struct Curl_easy *data, + char *buf, size_t len, size_t *pnread); +CURLcode Curl_conn_cf_cntrl(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool ignore_result, + int event, int arg1, void *arg2); + +/** + * Get the socket used by the filter chain starting at `cf`. + * Returns CURL_SOCKET_BAD if not available. + */ +curl_socket_t Curl_conn_cf_get_socket(struct Curl_cfilter *cf, + struct Curl_easy *data); + +CURLcode Curl_conn_cf_get_ip_info(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *is_ipv6, struct ip_quadruple *ipquad); + +bool Curl_conn_cf_needs_flush(struct Curl_cfilter *cf, + struct Curl_easy *data); + +unsigned char Curl_conn_cf_get_transport(struct Curl_cfilter *cf, + struct Curl_easy *data); + +int Curl_socktype_for_transport(uint8_t transport); +int Curl_protocol_for_transport(uint8_t transport); + +const char *Curl_conn_cf_get_alpn_negotiated(struct Curl_cfilter *cf, + struct Curl_easy *data); + +/* The filter (or one of its sub-filters) wants HTTPS-RR information. */ +bool Curl_conn_cf_wants_httpsrr(struct Curl_cfilter *cf, + struct Curl_easy *data); + +#define CURL_CF_SSL_DEFAULT (-1) +#define CURL_CF_SSL_DISABLE 0 +#define CURL_CF_SSL_ENABLE 1 + +/** + * Check if a filter chain at `sockindex` for connection `conn` exists. + */ +bool Curl_conn_is_setup(struct connectdata *conn, int sockindex); + +/** + * Check if the filter chain at `sockindex` for connection `conn` is + * completely connected. + */ +bool Curl_conn_is_connected(struct connectdata *conn, int sockindex); + +/** + * Determine if we have reached the remote host on IP level, e.g. + * have a TCP connection. This turns TRUE before a possible SSL + * handshake has been started/done. + */ +bool Curl_conn_is_ip_connected(struct Curl_easy *data, int sockindex); + +/** + * Determine if the connection is using SSL to the remote host + * (or will be once connected). This will return FALSE, if SSL + * is only used in proxying and not for the tunnel itself. + */ +bool Curl_conn_is_ssl(struct connectdata *conn, int sockindex); + +/* Determine if the connection has one or more proxy filters. + * e.g. is tunneling. */ +bool Curl_conn_is_tunneling(struct connectdata *conn, int sockindex); + +/* + * Fill `info` with information about the TLS instance securing the connection + * when available, otherwise e.g. when Curl_conn_is_ssl() is FALSE, return + * FALSE. 'query' should be CF_QUERY_SSL_INFO or CF_QUERY_SSL_CTX_INFO. + */ +bool Curl_conn_get_ssl_info(struct Curl_easy *data, + struct connectdata *conn, int sockindex, + int query, + struct curl_tlssessioninfo *info); + +CURLcode Curl_conn_get_ip_info(struct Curl_easy *data, + struct connectdata *conn, int sockindex, + bool *is_ipv6, struct ip_quadruple *ipquad); + +/** + * Connection provides multiplexing of easy handles at `socketindex`. + */ +bool Curl_conn_is_multiplex(struct connectdata *conn, int sockindex); + +/** + * Return the HTTP version used on the FIRSTSOCKET connection filters + * or 0 if unknown. Value otherwise is 09, 10, 11, etc. + */ +unsigned char Curl_conn_http_version(struct Curl_easy *data, + struct connectdata *conn); + +/* Get the TRNSPRT_* the connection is using */ +unsigned char Curl_conn_get_transport(struct Curl_easy *data, + struct connectdata *conn); + +/* Get the negotiated ALPN protocol or NULL if none in play */ +const char *Curl_conn_get_alpn_negotiated(struct Curl_easy *data, + struct connectdata *conn); + +void Curl_conn_cntrl_update_info(struct Curl_easy *data, + struct connectdata *conn); + +void Curl_conn_remove_setup_filters(struct Curl_easy *data, + int sockindex); + +/** + * Shutdown the connection at `sockindex` non-blocking, using timeout + * from `data->set.shutdowntimeout`, default DEFAULT_SHUTDOWN_TIMEOUT_MS. + * Return CURLE_OK and *done == FALSE if not finished. + */ +CURLcode Curl_conn_shutdown(struct Curl_easy *data, int sockindex, bool *done); + +/** + * Return if data is pending in some connection filter at chain + * `sockindex` for connection `data->conn`. + */ +bool Curl_conn_data_pending(struct Curl_easy *data, + int sockindex); + +/** + * Return TRUE if any of the connection filters at chain `sockindex` + * have data still to send. + */ +bool Curl_conn_needs_flush(struct Curl_easy *data, int sockindex); + +/** + * Flush any pending data on the connection filters at chain `sockindex`. + */ +CURLcode Curl_conn_flush(struct Curl_easy *data, int sockindex); + +/** + * Return the socket used on data's connection for FIRSTSOCKET, + * querying filters if the whole chain has not connected yet. + * Returns CURL_SOCKET_BAD if not available. + */ +curl_socket_t Curl_conn_get_first_socket(struct Curl_easy *data); + +/* Return a pointer to the connected socket address or NULL. */ +const struct Curl_sockaddr_ex * +Curl_conn_get_remote_addr(struct Curl_easy *data, int sockindex); + +/** + * Tell filters to forget about the socket at sockindex. + */ +void Curl_conn_forget_socket(struct Curl_easy *data, int sockindex); + +/** + * Adjust the pollset for the filter chain starting at `cf`. + */ +CURLcode Curl_conn_cf_adjust_pollset(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct easy_pollset *ps); + +/** + * Adjust pollset from filters installed at transfer's connection. + */ +CURLcode Curl_conn_adjust_pollset(struct Curl_easy *data, + struct connectdata *conn, + struct easy_pollset *ps); + +/** + * Curl_poll() the filter chain at `cf` with timeout `timeout_ms`. + * Returns 0 on timeout, negative on error or number of sockets + * with requested poll events. + */ +int Curl_conn_cf_poll(struct Curl_cfilter *cf, + struct Curl_easy *data, + timediff_t timeout_ms); + +/** + * Receive data through the filter chain at `sockindex` for connection + * `data->conn`. Copy at most `len` bytes into `buf`. Return the + * actual number of bytes copied in `*pnread`or an error. + */ +CURLcode Curl_cf_recv(struct Curl_easy *data, int sockindex, char *buf, + size_t len, size_t *pnread); + +/** + * Send `len` bytes of data from `buf` through the filter chain `sockindex` + * at connection `data->conn`. Return the actual number of bytes written + * in `*pnwritten` or on error. + */ +CURLcode Curl_cf_send(struct Curl_easy *data, int sockindex, + const uint8_t *buf, size_t len, bool eos, + size_t *pnwritten); + +/** + * Receive bytes from connection filter `cf` into `bufq`. + * Convenience wrapper around `Curl_bufq_sipn()`, + * so users do not have to implement a callback. + */ +CURLcode Curl_cf_recv_bufq(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct bufq *bufq, + size_t maxlen, + size_t *pnread); + +/** + * Send bytes in `bufq` using connection filter `cf`. + * A convenience wrapper around `Curl_bufq_write_pass()`, + * so users do not have to implement a callback. + */ +CURLcode Curl_cf_send_bufq(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct bufq *bufq, + const unsigned char *buf, size_t blen, + size_t *pnwritten); + +/** + * Notify connection filters that they need to setup data for + * a transfer. + */ +CURLcode Curl_conn_ev_data_setup(struct Curl_easy *data); + +/** + * Notify connection filters that the transfer represented by `data` + * is done with sending data (e.g. has uploaded everything). + */ +void Curl_conn_ev_data_done_send(struct Curl_easy *data); + +/** + * Notify connection filters that the transfer represented by `data` + * is finished - eventually premature, e.g. before being complete. + */ +void Curl_conn_ev_data_done(struct Curl_easy *data, bool premature); + +/** + * Notify connection filters that the transfer of data is paused/unpaused. + */ +CURLcode Curl_conn_ev_data_pause(struct Curl_easy *data, bool do_pause); + +/** + * Check if FIRSTSOCKET's cfilter chain deems connection alive. + */ +bool Curl_conn_is_alive(struct Curl_easy *data, struct connectdata *conn, + bool *input_pending); + +/** + * Try to upkeep the connection filters at sockindex. + */ +CURLcode Curl_conn_keep_alive(struct Curl_easy *data, + struct connectdata *conn, + int sockindex); + +/** + * Get the remote hostname and port that the connection is currently + * talking to (or will talk to). + * Once connected or before connect starts, + * it is `conn->origin->hostname` and `conn->origin->port`. + * During connect, when tunneling proxies are involved (http or socks), + * it will be the name and port the proxy currently negotiates with. + */ +void Curl_conn_get_current_host(struct Curl_easy *data, int sockindex, + const char **phost, int *pport); + +/** + * Get the maximum number of parallel transfers the connection + * expects to be able to handle at `sockindex`. + */ +size_t Curl_conn_get_max_concurrent(struct Curl_easy *data, + struct connectdata *conn, + int sockindex); + +/** + * Get the underlying error code for a transfer stream or 0 if not known. + */ +int Curl_conn_get_stream_error(struct Curl_easy *data, + struct connectdata *conn, + int sockindex); + +#ifdef CURLVERBOSE +void Curl_conn_trc_filters(struct Curl_easy *data, + int sockindex, const char *info); +#endif + +/** + * Get the index of the given socket in the connection's sockets. + * Useful in calling `Curl_conn_send()/Curl_conn_recv()` with the + * correct socket index. + */ +int Curl_conn_sockindex(struct Curl_easy *data, curl_socket_t sockfd); + +/* + * Receive data on the connection, using FIRSTSOCKET/SECONDARYSOCKET. + * Return CURLE_AGAIN iff blocked on receiving. + */ +CURLcode Curl_conn_recv(struct Curl_easy *data, int sockindex, + char *buf, size_t len, size_t *pnread); + +/* + * Send data on the connection, using FIRSTSOCKET/SECONDARYSOCKET. + * Return CURLE_AGAIN iff blocked on sending. + */ +CURLcode Curl_conn_send(struct Curl_easy *data, int sockindex, + const void *buf, size_t len, bool eos, + size_t *pnwritten); + +/** + * Types and macros used to keep the current easy handle in filter calls, + * allowing for nested invocations. See #10336. + * + * `cf_call_data` is intended to be a member of the cfilter's `ctx` type. + * A filter defines the macro `CF_CTX_CALL_DATA` to give access to that. + * + * With all values 0, the default, this indicates that there is no cfilter + * call with `data` ongoing. + * Macro `CF_DATA_SAVE` preserves the current `cf_call_data` in a local + * variable and sets the `data` given, incrementing the `depth` counter. + * + * Macro `CF_DATA_RESTORE` restores the old values from the local variable, + * while checking that `depth` values are as expected (debug build), catching + * cases where a "lower" RESTORE was not called. + * + * Finally, macro `CF_DATA_CURRENT` gives the easy handle of the current + * invocation. + */ +struct cf_call_data { + struct Curl_easy *data; +#ifdef DEBUGBUILD + int depth; +#endif +}; + +/** + * define to access the `struct cf_call_data for a cfilter. Normally + * a member in the cfilter's `ctx`. + * + * #define CF_CTX_CALL_DATA(cf) -> struct cf_call_data instance + */ + +#ifdef DEBUGBUILD + +#define CF_DATA_SAVE(save, cf, data) \ + do { \ + (save) = CF_CTX_CALL_DATA(cf); \ + DEBUGASSERT(!(save).data || (save).depth > 0); \ + CF_CTX_CALL_DATA(cf).depth++; \ + CF_CTX_CALL_DATA(cf).data = (struct Curl_easy *)CURL_UNCONST(data); \ + } while(0) + +#define CF_DATA_RESTORE(cf, save) \ + do { \ + DEBUGASSERT(CF_CTX_CALL_DATA(cf).depth == (save).depth + 1); \ + DEBUGASSERT(!(save).data || (save).depth > 0); \ + CF_CTX_CALL_DATA(cf) = (save); \ + } while(0) + +#else /* DEBUGBUILD */ + +#define CF_DATA_SAVE(save, cf, data) \ + do { \ + (save) = CF_CTX_CALL_DATA(cf); \ + CF_CTX_CALL_DATA(cf).data = (struct Curl_easy *)CURL_UNCONST(data); \ + } while(0) + +#define CF_DATA_RESTORE(cf, save) \ + do { \ + CF_CTX_CALL_DATA(cf) = (save); \ + } while(0) + +#endif /* !DEBUGBUILD */ + +#define CF_DATA_CURRENT(cf) ((cf) ? (CF_CTX_CALL_DATA(cf).data) : NULL) + +#endif /* HEADER_CURL_CFILTERS_H */ diff --git a/3rdparty/curl-8.21.0/lib/config-mac.h b/3rdparty/curl-8.21.0/lib/config-mac.h new file mode 100644 index 0000000000..fd9d3e7b60 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/config-mac.h @@ -0,0 +1,84 @@ +#ifndef HEADER_CURL_CONFIG_MAC_H +#define HEADER_CURL_CONFIG_MAC_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +/* =================================================================== */ +/* Hand crafted config file for Mac OS 9 */ +/* =================================================================== */ +/* On macOS you must run configure to generate curl_config.h file */ +/* =================================================================== */ + +#ifndef CURL_OS +#define CURL_OS "mac" +#endif + +#include + +/* Define if you want the built-in manual */ +#define USE_MANUAL 1 + +#define HAVE_NETINET_IN_H 1 +#define HAVE_NETDB_H 1 +#define HAVE_ARPA_INET_H 1 +#define HAVE_UNISTD_H 1 +#define HAVE_NET_IF_H 1 +#define HAVE_SYS_TYPES_H 1 +#define HAVE_GETTIMEOFDAY 1 +#define HAVE_FCNTL_H 1 +#define HAVE_UTIME_H 1 +#define HAVE_SYS_UTIME_H 1 +#define HAVE_SYS_IOCTL_H 1 +#define HAVE_ALARM 1 +#define HAVE_UTIME 1 +#define HAVE_SELECT 1 +#define HAVE_SOCKET 1 +#define HAVE_STRUCT_TIMEVAL 1 + +#define HAVE_SIGACTION 1 + +#define CURL_DISABLE_LDAP + +#define HAVE_IOCTL_FIONBIO 1 + +#define SIZEOF_INT 4 +#define SIZEOF_LONG 4 +#define SIZEOF_SIZE_T 4 +#define SIZEOF_CURL_OFF_T 8 + +#define HAVE_RECV 1 +#define RECV_TYPE_ARG1 int +#define RECV_TYPE_ARG2 void * +#define RECV_TYPE_ARG3 size_t +#define RECV_TYPE_ARG4 int +#define RECV_TYPE_RETV ssize_t + +#define HAVE_SEND 1 +#define SEND_TYPE_ARG1 int +#define SEND_TYPE_ARG2 void * +#define SEND_TYPE_ARG3 size_t +#define SEND_TYPE_ARG4 int +#define SEND_TYPE_RETV ssize_t + +#endif /* HEADER_CURL_CONFIG_MAC_H */ diff --git a/3rdparty/curl-8.21.0/lib/config-os400.h b/3rdparty/curl-8.21.0/lib/config-os400.h new file mode 100644 index 0000000000..76841af202 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/config-os400.h @@ -0,0 +1,297 @@ +#ifndef HEADER_CURL_CONFIG_OS400_H +#define HEADER_CURL_CONFIG_OS400_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +/* ================================================================ */ +/* Hand crafted config file for OS/400 */ +/* ================================================================ */ + +#pragma enum(int) + +/* ---------------------------------------------------------------- */ +/* Global configuration parameters: normally generated by autoconf. */ +/* ---------------------------------------------------------------- */ + +/* Location of default CA bundle */ +/* Use the system keyring as the default CA bundle. */ +#define CURL_CA_BUNDLE "/QIBM/UserData/ICSS/Cert/Server/DEFAULT.KDB" + +/* Definition to make a library symbol externally visible. */ +#define CURL_EXTERN_SYMBOL + +/* cpu-machine-OS */ +#ifndef CURL_OS +#define CURL_OS "OS/400" +#endif + +/* Define to 1 if you have the alarm function. */ +#define HAVE_ALARM 1 + +/* Define if you have the header file. */ +#define HAVE_ARPA_INET_H 1 + +/* if you have */ +#define HAVE_DIRENT_H + +/* Define to 1 if you have the fcntl function. */ +#define HAVE_FCNTL 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_FCNTL_H 1 + +/* Define to 1 if you have a working fcntl O_NONBLOCK function. */ +#define HAVE_FCNTL_O_NONBLOCK 1 + +/* Define to 1 if you have the freeaddrinfo function. */ +#define HAVE_FREEADDRINFO 1 + +/* Define to 1 if you have a working getaddrinfo function. */ +#define HAVE_GETADDRINFO 1 + +/* Define to 1 if the getaddrinfo function is thread-safe. */ +#define HAVE_GETADDRINFO_THREADSAFE 1 + +/* Define to 1 if you have the 'geteuid' function. */ +#define HAVE_GETEUID 1 + +/* Define to 1 if you have the gethostname function. */ +#define HAVE_GETHOSTNAME 1 + +/* Define to 1 if you have the getpeername function. */ +#define HAVE_GETPEERNAME 1 + +/* Define to 1 if you have the 'getppid' function. */ +#define HAVE_GETPPID 1 + +/* Define to 1 if you have the 'getpwuid' function. */ +#define HAVE_GETPWUID 1 + +/* Define to 1 if you have the getsockname function. */ +#define HAVE_GETSOCKNAME 1 + +/* Define to 1 if you have the 'gettimeofday' function. */ +#define HAVE_GETTIMEOFDAY 1 + +/* if you have GSS-API libraries */ +#define HAVE_GSSAPI + +/* Define to 1 if you have a working ioctl FIONBIO function. */ +#define HAVE_IOCTL_FIONBIO 1 + +/* Define to 1 if you have a working ioctl SIOCGIFADDR function. */ +#define HAVE_IOCTL_SIOCGIFADDR 1 + +/* Define to 1 if you have the lber.h header file. */ +#define HAVE_LBER_H 1 + +/* Define to 1 if you have the ldap.h header file. */ +#define HAVE_LDAP_H 1 + +/* Define to 1 if you have a working localtime_r function. */ +#define HAVE_LOCALTIME_R 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_NETDB_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_NETINET_IN_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_NETINET_TCP_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_NETINET_UDP_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_NET_IF_H 1 + +/* if you have opendir */ +#define HAVE_OPENDIR + +/* Define to 1 if you have the 'pipe' function. */ +#define HAVE_PIPE 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_PWD_H 1 + +/* Define to 1 if you have the recv function. */ +#define HAVE_RECV 1 + +/* Define to 1 if symbol `sa_family_t' exists */ +#define HAVE_SA_FAMILY_T 1 + +/* Define to 1 if you have the select function. */ +#define HAVE_SELECT 1 + +/* Define to 1 if you have the send function. */ +#define HAVE_SEND 1 + +/* Define to 1 if you have the 'sendmsg' function. */ +#define HAVE_SENDMSG 1 + +/* Define to 1 if you have the sigaction function. */ +#define HAVE_SIGACTION 1 + +/* Define to 1 if struct sockaddr_in6 has the sin6_scope_id member */ +#define HAVE_SOCKADDR_IN6_SIN6_SCOPE_ID 1 + +/* Define to 1 if you have the socketpair function. */ +#define HAVE_SOCKET 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_STDBOOL_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_STDINT_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_STDIO_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_STDLIB_H 1 + +/* Define to 1 if you have the stricmp function. */ +#define HAVE_STRICMP 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_STRINGS_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_STRING_H 1 + +/* if struct sockaddr_storage is defined */ +#define HAVE_STRUCT_SOCKADDR_STORAGE + +/* Define to 1 if you have the timeval struct. */ +#define HAVE_STRUCT_TIMEVAL 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_SYS_IOCTL_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_SYS_PARAM_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_SYS_RESOURCE_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_SYS_STAT_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_SYS_TYPES_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_SYS_UN_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_UNICODE_UIDNA_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_UNISTD_H 1 + +/* Define to 1 if you have the 'utime' function. */ +#define HAVE_UTIME 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_UTIME_H 1 + +/* Size of curl_off_t in number of bytes */ +#define SIZEOF_CURL_OFF_T 8 + +/* Size of curl_socket_t in number of bytes */ +#define SIZEOF_CURL_SOCKET_T 4 + +/* Size of int in number of bytes */ +#define SIZEOF_INT 4 + +/* Size of long in number of bytes */ +#define SIZEOF_LONG 4 + +/* Size of off_t in number of bytes */ +#define SIZEOF_OFF_T 8 /* _LARGE_FILES (*IFS64IO) version. */ + +/* Size of size_t in number of bytes */ +#define SIZEOF_SIZE_T 4 + +/* Size of time_t in number of bytes */ +#define SIZEOF_TIME_T 4 + +/* Define to 1 if all of the C89 standard headers exist (not only the ones + required in a freestanding environment). This macro is provided for + backward compatibility; new code need not use it. */ +#define STDC_HEADERS 1 + +/* Define if you want to enable IPv6 support */ +#define USE_IPV6 + +/* Use Unix domain sockets */ +#define USE_UNIX_SOCKETS + +/* Define to 1 if OS is AIX. */ +#ifndef _ALL_SOURCE +# undef _ALL_SOURCE +#endif + +/* ---------------------------------------------------------------- */ +/* recv/send parameter types (see lib/functypes.h) */ +/* ---------------------------------------------------------------- */ + +/* int recv(int, char *, int, int); */ +#define RECV_TYPE_ARG1 int +#define RECV_TYPE_ARG2 char * +#define RECV_TYPE_ARG3 int +#define RECV_TYPE_ARG4 int +#define RECV_TYPE_RETV int + +/* int send(int, char *, int, int); */ +#define SEND_TYPE_ARG1 int +#define SEND_NONCONST_ARG2 +#define SEND_TYPE_ARG2 char * +#define SEND_TYPE_ARG3 int +#define SEND_TYPE_ARG4 int +#define SEND_TYPE_RETV int + +/* ---------------------------------------------------------------- */ +/* Additional definitions specific to OS/400 */ +/* ---------------------------------------------------------------- */ + +/* The header file is in the main system include directory. */ +#define HAVE_GSSAPI_H + +/* Define to use the OS/400 crypto library. */ +#define USE_OS400CRYPTO + +/* The following definition is required on OS/400 to enable strcmpi(), + stricmp() and strdup(). */ +#define __cplusplus__strings__ + +/* The following must be defined BEFORE system header files inclusion. */ + +#define __ptr128 /* No teraspace. */ +#define qadrt_use_fputc_inline /* Generate fputc() wrapper inline. */ +#define qadrt_use_fread_inline /* Generate fread() wrapper inline. */ +#define qadrt_use_fwrite_inline /* Generate fwrite() wrapper inline. */ + +#endif /* HEADER_CURL_CONFIG_OS400_H */ diff --git a/3rdparty/curl-8.21.0/lib/config-riscos.h b/3rdparty/curl-8.21.0/lib/config-riscos.h new file mode 100644 index 0000000000..afff218a76 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/config-riscos.h @@ -0,0 +1,141 @@ +#ifndef HEADER_CURL_CONFIG_RISCOS_H +#define HEADER_CURL_CONFIG_RISCOS_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +/* ================================================================ */ +/* Hand crafted config file for RISC OS */ +/* ================================================================ */ + +/* Define cpu-machine-OS */ +#ifndef CURL_OS +#define CURL_OS "ARM-RISC OS" +#endif + +/* Define if you want the built-in manual */ +#define USE_MANUAL + +/* Define if struct sockaddr_in6 has the sin6_scope_id member */ +#define HAVE_SOCKADDR_IN6_SIN6_SCOPE_ID 1 + +/* Define if you have the alarm function. */ +#define HAVE_ALARM + +/* Define if you have the header file. */ +#define HAVE_ARPA_INET_H + +/* Define if you have the header file. */ +#define HAVE_FCNTL_H + +/* Define if getaddrinfo exists and works */ +#define HAVE_GETADDRINFO + +/* Define if you have the `gethostname' function. */ +#define HAVE_GETHOSTNAME + +/* Define if you have the `gettimeofday' function. */ +#define HAVE_GETTIMEOFDAY + +/* Define if you have the `timeval' struct. */ +#define HAVE_STRUCT_TIMEVAL + +/* Define if you have the header file. */ +#define HAVE_NETDB_H + +/* Define if you have the header file. */ +#define HAVE_NETINET_IN_H + +/* Define if you have the header file. */ +#define HAVE_NET_IF_H + +/* Define if you have the `select' function. */ +#define HAVE_SELECT + +/* Define if you have the `signal' function. */ +#define HAVE_SIGNAL + +/* Define if you have the `socket' function. */ +#define HAVE_SOCKET + +/* Define if you have the `stricmp' function. */ +#define HAVE_STRICMP + +/* Define if you have the header file. */ +#define HAVE_SYS_TYPES_H + +/* Define if you have the header file. */ +#define HAVE_TERMIOS_H + +/* Define if you have the header file. */ +#define HAVE_UNISTD_H + +/* The size of `int', as computed by sizeof. */ +#define SIZEOF_INT 4 + +/* The size of `size_t', as computed by sizeof. */ +#define SIZEOF_SIZE_T 4 + +/* Define if you have a working ioctl FIONBIO function. */ +#define HAVE_IOCTL_FIONBIO + +/* to disable LDAP */ +#define CURL_DISABLE_LDAP + +/* Define if you have the recv function. */ +#define HAVE_RECV 1 + +/* Define to the type of arg 1 for recv. */ +#define RECV_TYPE_ARG1 int + +/* Define to the type of arg 2 for recv. */ +#define RECV_TYPE_ARG2 void * + +/* Define to the type of arg 3 for recv. */ +#define RECV_TYPE_ARG3 size_t + +/* Define to the type of arg 4 for recv. */ +#define RECV_TYPE_ARG4 int + +/* Define to the function return type for recv. */ +#define RECV_TYPE_RETV ssize_t + +/* Define if you have the send function. */ +#define HAVE_SEND 1 + +/* Define to the type of arg 1 for send. */ +#define SEND_TYPE_ARG1 int + +/* Define to the type of arg 2 for send. */ +#define SEND_TYPE_ARG2 void * + +/* Define to the type of arg 3 for send. */ +#define SEND_TYPE_ARG3 size_t + +/* Define to the type of arg 4 for send. */ +#define SEND_TYPE_ARG4 int + +/* Define to the function return type for send. */ +#define SEND_TYPE_RETV ssize_t + +#endif /* HEADER_CURL_CONFIG_RISCOS_H */ diff --git a/3rdparty/curl-8.21.0/lib/config-win32.h b/3rdparty/curl-8.21.0/lib/config-win32.h new file mode 100644 index 0000000000..b1fc102209 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/config-win32.h @@ -0,0 +1,309 @@ +#ifndef HEADER_CURL_CONFIG_WIN32_H +#define HEADER_CURL_CONFIG_WIN32_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +/* ================================================================ */ +/* Hand crafted config file for Windows */ +/* ================================================================ */ + +/* ---------------------------------------------------------------- */ +/* HEADER FILES */ +/* ---------------------------------------------------------------- */ + +/* Define if you have the header file. */ +#define HAVE_FCNTL_H 1 + +/* Define if you have the header file. */ +#define HAVE_IO_H 1 + +/* Define if you have the header file. */ +#define HAVE_LOCALE_H 1 + +/* Define to 1 if you have the header file. */ +#if (defined(_MSC_VER) && (_MSC_VER >= 1800)) || defined(__MINGW32__) +#define HAVE_STDBOOL_H 1 +#endif + +/* Define if you have the header file. */ +#ifdef __MINGW32__ +#define HAVE_SYS_PARAM_H 1 +#endif + +/* Define if you have the header file. */ +#define HAVE_SYS_TYPES_H 1 + +/* Define if you have the header file. */ +#define HAVE_SYS_UTIME_H 1 + +/* Define if you have the header file. */ +#ifdef __MINGW32__ +#define HAVE_UNISTD_H 1 +#endif + +/* Define to 1 if you have the header file. */ +#ifdef __MINGW32__ +#define HAVE_LIBGEN_H 1 +#endif + +/* ---------------------------------------------------------------- */ +/* OTHER HEADER INFO */ +/* ---------------------------------------------------------------- */ + +/* Define if you have the ANSI C header files. */ +#define STDC_HEADERS 1 + +/* Define to 1 if bool is an available type. */ +#if (defined(_MSC_VER) && (_MSC_VER >= 1800)) || defined(__MINGW32__) +#define HAVE_BOOL_T 1 +#endif + +/* ---------------------------------------------------------------- */ +/* FUNCTIONS */ +/* ---------------------------------------------------------------- */ + +/* Define if you have the closesocket function. */ +#define HAVE_CLOSESOCKET 1 + +/* Define to 1 if you have the `getpeername' function. */ +#define HAVE_GETPEERNAME 1 + +/* Define to 1 if you have the getsockname function. */ +#define HAVE_GETSOCKNAME 1 + +/* Define if you have the gethostname function. */ +#define HAVE_GETHOSTNAME 1 + +/* Define if you have the gettimeofday function. */ +#ifdef __MINGW32__ +#define HAVE_GETTIMEOFDAY 1 +#endif + +/* Define if you have the ioctlsocket function. */ +#define HAVE_IOCTLSOCKET 1 + +/* Define if you have a working ioctlsocket FIONBIO function. */ +#define HAVE_IOCTLSOCKET_FIONBIO 1 + +/* Define if you have the select function. */ +#define HAVE_SELECT 1 + +/* Define if you have the setlocale function. */ +#define HAVE_SETLOCALE 1 + +/* Define if you have the socket function. */ +#define HAVE_SOCKET 1 + +/* Define if you have the utime function. */ +#define HAVE_UTIME 1 + +/* Define if you have the recv function. */ +#define HAVE_RECV 1 + +/* Define to the type of arg 1 for recv. */ +#define RECV_TYPE_ARG1 SOCKET + +/* Define to the type of arg 2 for recv. */ +#define RECV_TYPE_ARG2 char * + +/* Define to the type of arg 3 for recv. */ +#define RECV_TYPE_ARG3 int + +/* Define to the type of arg 4 for recv. */ +#define RECV_TYPE_ARG4 int + +/* Define to the function return type for recv. */ +#define RECV_TYPE_RETV int + +/* Define if you have the send function. */ +#define HAVE_SEND 1 + +/* Define to the type of arg 1 for send. */ +#define SEND_TYPE_ARG1 SOCKET + +/* Define to the type of arg 2 for send. */ +#define SEND_TYPE_ARG2 char * + +/* Define to the type of arg 3 for send. */ +#define SEND_TYPE_ARG3 int + +/* Define to the type of arg 4 for send. */ +#define SEND_TYPE_ARG4 int + +/* Define to the function return type for send. */ +#define SEND_TYPE_RETV int + +/* Must always use local implementations on Windows. */ +/* Define to 1 if you have an IPv6 capable working inet_ntop function. */ +/* #undef HAVE_INET_NTOP */ +/* Define to 1 if you have an IPv6 capable working inet_pton function. */ +/* #undef HAVE_INET_PTON */ + +/* Define to 1 if you have the `basename' function. */ +#ifdef __MINGW32__ +#define HAVE_BASENAME 1 +#endif + +/* Define to 1 if you have the signal function. */ +#define HAVE_SIGNAL 1 + +/* ---------------------------------------------------------------- */ +/* TYPEDEF REPLACEMENTS */ +/* ---------------------------------------------------------------- */ + +/* Define if ssize_t is not an available 'typedefed' type. */ +#ifndef _SSIZE_T_DEFINED +# ifdef __MINGW32__ +# elif defined(_WIN64) +# define _SSIZE_T_DEFINED +# define ssize_t __int64 +# else +# define _SSIZE_T_DEFINED +# define ssize_t int +# endif +#endif + +/* ---------------------------------------------------------------- */ +/* TYPE SIZES */ +/* ---------------------------------------------------------------- */ + +/* Define to the size of `int', as computed by sizeof. */ +#define SIZEOF_INT 4 + +/* Define to the size of `long', as computed by sizeof. */ +#define SIZEOF_LONG 4 + +/* Define to the size of `size_t', as computed by sizeof. */ +#ifdef _WIN64 +# define SIZEOF_SIZE_T 8 +#else +# define SIZEOF_SIZE_T 4 +#endif + +/* Define to the size of `curl_off_t', as computed by sizeof. */ +#define SIZEOF_CURL_OFF_T 8 + +/* ---------------------------------------------------------------- */ +/* COMPILER SPECIFIC */ +/* ---------------------------------------------------------------- */ + +/* Default to 64-bit time_t unless _USE_32BIT_TIME_T is defined */ +#if defined(_MSC_VER) || defined(__MINGW32__) +# ifndef _USE_32BIT_TIME_T +# define SIZEOF_TIME_T 8 +# else +# define SIZEOF_TIME_T 4 +# endif +#endif + +/* Windows XP is required for freeaddrinfo, getaddrinfo */ +#define HAVE_FREEADDRINFO 1 +#define HAVE_GETADDRINFO 1 +#define HAVE_GETADDRINFO_THREADSAFE 1 + +/* ---------------------------------------------------------------- */ +/* STRUCT RELATED */ +/* ---------------------------------------------------------------- */ + +/* Define if you have struct sockaddr_storage. */ +#define HAVE_STRUCT_SOCKADDR_STORAGE 1 + +/* Define if you have struct timeval. */ +#define HAVE_STRUCT_TIMEVAL 1 + +/* Define if struct sockaddr_in6 has the sin6_scope_id member. */ +#define HAVE_SOCKADDR_IN6_SIN6_SCOPE_ID 1 + +/* ---------------------------------------------------------------- */ +/* LARGE FILE SUPPORT */ +/* ---------------------------------------------------------------- */ + +/* Number of bits in a file offset, on hosts where this is settable. */ +#ifdef __MINGW32__ +# undef _FILE_OFFSET_BITS +# define _FILE_OFFSET_BITS 64 +#endif + +/* Define to the size of `off_t', as computed by sizeof. */ +#ifdef __MINGW32__ +# define SIZEOF_OFF_T 8 +#else +# define SIZEOF_OFF_T 4 +#endif + +/* ---------------------------------------------------------------- */ +/* DNS RESOLVER SPECIALTY */ +/* ---------------------------------------------------------------- */ + +/* + * Undefine both USE_ARES and USE_RESOLV_THREADED for synchronous DNS. + */ + +/* Default define to enable threaded asynchronous DNS lookups. */ +#if !defined(USE_SYNC_DNS) && !defined(USE_ARES) && \ + !defined(USE_RESOLV_THREADED) +# define USE_RESOLV_THREADED 1 +#endif + +#if defined(USE_ARES) && defined(USE_RESOLV_THREADED) +# error "Only one DNS lookup specialty may be defined at most" +#endif + +/* ---------------------------------------------------------------- */ +/* LDAP SUPPORT */ +/* ---------------------------------------------------------------- */ + +#ifndef CURL_WINDOWS_UWP +#define HAVE_LDAP_SSL 1 +#define USE_WIN32_LDAP 1 + +/* Define to use the Windows crypto library. */ +#define USE_WIN32_CRYPTO +#endif /* CURL_WINDOWS_UWP */ + +/* Define to use Unix sockets. */ +#define USE_UNIX_SOCKETS + +/* ---------------------------------------------------------------- */ +/* ADDITIONAL DEFINITIONS */ +/* ---------------------------------------------------------------- */ + +/* Define cpu-machine-OS */ +#ifndef CURL_OS +# if defined(_M_IX86) || defined(__i386__) /* x86 (MSVC or gcc) */ +# define CURL_OS "i386-pc-win32" +# elif defined(_M_X64) || defined(__x86_64__) /* x86_64 (VS2005+ or gcc) */ +# define CURL_OS "x86_64-pc-win32" +# elif defined(_M_IA64) || defined(__ia64__) /* Itanium */ +# define CURL_OS "ia64-pc-win32" +# elif defined(_M_ARM_NT) || defined(__arm__) /* ARMv7-Thumb2 */ +# define CURL_OS "thumbv7a-pc-win32" +# elif defined(_M_ARM64) || defined(__aarch64__) /* ARM64 (Windows 10) */ +# define CURL_OS "aarch64-pc-win32" +# else +# define CURL_OS "unknown-pc-win32" +# endif +#endif /* !CURL_OS */ + +#endif /* HEADER_CURL_CONFIG_WIN32_H */ diff --git a/3rdparty/curl-8.21.0/lib/conncache.c b/3rdparty/curl-8.21.0/lib/conncache.c new file mode 100644 index 0000000000..5ba2368622 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/conncache.c @@ -0,0 +1,910 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Linus Nielsen Feltzing, + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "urldata.h" +#include "url.h" +#include "cfilters.h" +#include "progress.h" +#include "multiif.h" +#include "curl_trc.h" +#include "cshutdn.h" +#include "conncache.h" +#include "curl_share.h" +#include "sigpipe.h" + + +#define CPOOL_IS_LOCKED(c) ((c) && (c)->locked) + +#define CPOOL_LOCK(c, d) \ + do { \ + if(c) { \ + if(CURL_SHARE_KEEP_CONNECT((c)->share)) \ + Curl_share_lock((d), CURL_LOCK_DATA_CONNECT, \ + CURL_LOCK_ACCESS_SINGLE); \ + DEBUGASSERT(!(c)->locked); \ + (c)->locked = TRUE; \ + } \ + } while(0) + +#define CPOOL_UNLOCK(c, d) \ + do { \ + if(c) { \ + DEBUGASSERT((c)->locked); \ + (c)->locked = FALSE; \ + if(CURL_SHARE_KEEP_CONNECT((c)->share)) \ + Curl_share_unlock((d), CURL_LOCK_DATA_CONNECT); \ + } \ + } while(0) + +/* A list of connections to the same destination. */ +struct cpool_bundle { + struct Curl_llist conns; /* connections in the bundle */ + size_t dest_len; /* total length of destination, including NUL */ + char dest[1]; /* destination of bundle, allocated to keep dest_len bytes */ +}; + +static struct cpool_bundle *cpool_bundle_create(const char *dest) +{ + struct cpool_bundle *bundle; + size_t dest_len = strlen(dest) + 1; + + bundle = curlx_calloc(1, sizeof(*bundle) + dest_len - 1); + if(!bundle) + return NULL; + Curl_llist_init(&bundle->conns, NULL); + bundle->dest_len = dest_len; + memcpy(bundle->dest, dest, bundle->dest_len); + return bundle; +} + +static void cpool_bundle_destroy(struct cpool_bundle *bundle) +{ + DEBUGASSERT(!Curl_llist_count(&bundle->conns)); + curlx_free(bundle); +} + +/* Add a connection to a bundle */ +static void cpool_bundle_add(struct cpool_bundle *bundle, + struct connectdata *conn) +{ + DEBUGASSERT(!Curl_node_llist(&conn->cpool_node)); + Curl_llist_append(&bundle->conns, conn, &conn->cpool_node); + conn->bits.in_cpool = TRUE; +} + +/* Remove a connection from a bundle */ +static void cpool_bundle_remove(struct cpool_bundle *bundle, + struct connectdata *conn) +{ + (void)bundle; + DEBUGASSERT(Curl_node_llist(&conn->cpool_node) == &bundle->conns); + Curl_node_remove(&conn->cpool_node); + conn->bits.in_cpool = FALSE; +} + +static void cpool_bundle_free_entry(void *freethis) +{ + cpool_bundle_destroy((struct cpool_bundle *)freethis); +} + +void Curl_cpool_init(struct cpool *cpool, + struct Curl_easy *idata, + struct Curl_share *share, + size_t size) +{ + Curl_hash_init(&cpool->dest2bundle, size, Curl_hash_str, + curlx_str_key_compare, cpool_bundle_free_entry); + + DEBUGASSERT(idata); + + cpool->idata = idata; + cpool->share = share; + cpool->initialized = TRUE; +} + +/* Return the "first" connection in the pool or NULL. */ +static struct connectdata *cpool_get_first(struct cpool *cpool) +{ + struct Curl_hash_iterator iter; + struct Curl_hash_element *he; + struct cpool_bundle *bundle; + struct Curl_llist_node *conn_node; + + Curl_hash_start_iterate(&cpool->dest2bundle, &iter); + for(he = Curl_hash_next_element(&iter); he; + he = Curl_hash_next_element(&iter)) { + bundle = he->ptr; + conn_node = Curl_llist_head(&bundle->conns); + if(conn_node) + return Curl_node_elem(conn_node); + } + return NULL; +} + +static struct cpool_bundle *cpool_find_bundle(struct cpool *cpool, + struct connectdata *conn) +{ + return Curl_hash_pick(&cpool->dest2bundle, + conn->destination, strlen(conn->destination) + 1); +} + +static void cpool_remove_bundle(struct cpool *cpool, + struct cpool_bundle *bundle) +{ + if(!cpool) + return; + Curl_hash_delete(&cpool->dest2bundle, bundle->dest, bundle->dest_len); +} + +static void cpool_remove_conn(struct cpool *cpool, + struct connectdata *conn) +{ + struct Curl_llist *list = Curl_node_llist(&conn->cpool_node); + DEBUGASSERT(cpool); + if(list) { + /* The connection is certainly in the pool, but where? */ + struct cpool_bundle *bundle = cpool_find_bundle(cpool, conn); + if(bundle && (list == &bundle->conns)) { + cpool_bundle_remove(bundle, conn); + if(!Curl_llist_count(&bundle->conns)) + cpool_remove_bundle(cpool, bundle); + conn->bits.in_cpool = FALSE; + cpool->num_conn--; + } + else { + /* Should have been in the bundle list */ + DEBUGASSERT(NULL); + } + } +} + +static void cpool_discard_conn(struct cpool *cpool, + struct Curl_easy *data, + struct connectdata *conn, + bool aborted) +{ + bool done = FALSE; + + DEBUGASSERT(data); + DEBUGASSERT(!data->conn); + DEBUGASSERT(cpool); + DEBUGASSERT(!conn->bits.in_cpool); + + /* + * If this connection is not marked to force-close, leave it open if there + * are other users of it + */ + if(CONN_INUSE(conn) && !aborted) { + CURL_TRC_M(data, "[CPOOL] not discarding #%" FMT_OFF_T + " still in use by %u transfers", conn->connection_id, + conn->attached_xfers); + return; + } + + /* treat the connection as aborted in CONNECT_ONLY situations, we do + * not know what the APP did with it. */ + if(conn->bits.connect_only) + aborted = TRUE; + conn->bits.aborted = aborted; + + /* We do not shutdown dead connections. The term 'dead' can be misleading + * here, as we also mark errored connections/transfers as 'dead'. + * If we do a shutdown for an aborted transfer, the server might think + * it was successful otherwise (for example an ftps: upload). This is + * not what we want. */ + if(aborted) + done = TRUE; + if(!done) { + /* Attempt to shutdown the connection right away. */ + Curl_cshutdn_run_once(cpool->idata, conn, &done); + } + + if(done || !data->multi) + Curl_cshutdn_terminate(cpool->idata, conn, FALSE); + else + Curl_cshutdn_add(&data->multi->cshutdn, conn, cpool->num_conn); +} + +void Curl_cpool_destroy(struct cpool *cpool) +{ + if(cpool && cpool->initialized && cpool->idata) { + struct connectdata *conn; + struct Curl_sigpipe_ctx pipe_ctx; + + CURL_TRC_M(cpool->idata, "%s[CPOOL] destroy, %zu connections", + cpool->share ? "[SHARE] " : "", cpool->num_conn); + /* Move all connections to the shutdown list */ + sigpipe_init(&pipe_ctx); + CPOOL_LOCK(cpool, cpool->idata); + conn = cpool_get_first(cpool); + if(conn) + sigpipe_apply(cpool->idata, &pipe_ctx); + while(conn) { + cpool_remove_conn(cpool, conn); + cpool_discard_conn(cpool, cpool->idata, conn, FALSE); + conn = cpool_get_first(cpool); + } + CPOOL_UNLOCK(cpool, cpool->idata); + sigpipe_restore(&pipe_ctx); + Curl_hash_destroy(&cpool->dest2bundle); + } +} + +static struct cpool *cpool_get_instance(struct Curl_easy *data) +{ + if(data) { + if(CURL_SHARE_KEEP_CONNECT(data->share)) + return &data->share->cpool; + else if(data->multi_easy) + return &data->multi_easy->cpool; + else if(data->multi) + return &data->multi->cpool; + } + return NULL; +} + +void Curl_cpool_xfer_init(struct Curl_easy *data) +{ + struct cpool *cpool = cpool_get_instance(data); + + DEBUGASSERT(cpool); + if(cpool) { + CPOOL_LOCK(cpool, data); + /* the identifier inside the connection cache */ + data->id = cpool->next_easy_id++; + if(cpool->next_easy_id <= 0) + cpool->next_easy_id = 0; + data->state.lastconnect_id = -1; + + CPOOL_UNLOCK(cpool, data); + } + else { + /* We should not get here, but in a non-debug build, do something */ + data->id = 0; + data->state.lastconnect_id = -1; + } +} + +static struct cpool_bundle *cpool_add_bundle(struct cpool *cpool, + struct connectdata *conn) +{ + struct cpool_bundle *bundle; + + bundle = cpool_bundle_create(conn->destination); + if(!bundle) + return NULL; + + if(!Curl_hash_add(&cpool->dest2bundle, + bundle->dest, bundle->dest_len, bundle)) { + cpool_bundle_destroy(bundle); + return NULL; + } + return bundle; +} + +static struct connectdata *cpool_bundle_get_oldest_idle( + struct cpool_bundle *bundle, + const struct curltime *pnow) +{ + struct Curl_llist_node *curr; + timediff_t highscore = -1; + timediff_t score; + struct connectdata *oldest_idle = NULL; + struct connectdata *conn; + + curr = Curl_llist_head(&bundle->conns); + while(curr) { + conn = Curl_node_elem(curr); + + if(!CONN_INUSE(conn)) { + /* Set higher score for the age passed since the connection was used */ + score = curlx_ptimediff_ms(pnow, &conn->lastused); + + if(score > highscore) { + highscore = score; + oldest_idle = conn; + } + } + curr = Curl_node_next(curr); + } + return oldest_idle; +} + +static struct connectdata *cpool_get_oldest_idle(struct cpool *cpool, + const struct curltime *pnow) +{ + struct Curl_hash_iterator iter; + struct Curl_llist_node *curr; + struct Curl_hash_element *he; + struct connectdata *oldest_idle = NULL; + struct cpool_bundle *bundle; + timediff_t highscore = -1; + timediff_t score; + + Curl_hash_start_iterate(&cpool->dest2bundle, &iter); + + for(he = Curl_hash_next_element(&iter); he; + he = Curl_hash_next_element(&iter)) { + struct connectdata *conn; + bundle = he->ptr; + + for(curr = Curl_llist_head(&bundle->conns); curr; + curr = Curl_node_next(curr)) { + conn = Curl_node_elem(curr); + if(CONN_INUSE(conn) || conn->bits.close || conn->bits.connect_only) + continue; + /* Set higher score for the age passed since the connection was used */ + score = curlx_ptimediff_ms(pnow, &conn->lastused); + if(score > highscore) { + highscore = score; + oldest_idle = conn; + } + } + } + return oldest_idle; +} + +int Curl_cpool_check_limits(struct Curl_easy *data, + struct connectdata *conn) +{ + struct cpool *cpool = cpool_get_instance(data); + struct cpool_bundle *bundle; + size_t dest_limit = 0; + size_t total_limit = 0; + size_t shutdowns; + int res = CPOOL_LIMIT_OK; + + if(!cpool) + return CPOOL_LIMIT_OK; + + if(cpool->idata->multi) { + dest_limit = cpool->idata->multi->max_host_connections; + total_limit = cpool->idata->multi->max_total_connections; + } + + if(!dest_limit && !total_limit) + return CPOOL_LIMIT_OK; + + CPOOL_LOCK(cpool, cpool->idata); + if(dest_limit) { + size_t live; + + bundle = cpool_find_bundle(cpool, conn); + live = bundle ? Curl_llist_count(&bundle->conns) : 0; + shutdowns = Curl_cshutdn_dest_count(data, conn->destination); + while((live + shutdowns) >= dest_limit) { + if(shutdowns) { + /* close one connection in shutdown right away, if we can */ + if(!Curl_cshutdn_close_oldest(data, conn->destination)) + break; + } + else if(!bundle) + break; + else { + struct connectdata *oldest_idle = NULL; + /* The bundle is full. Extract the oldest connection that may + * be removed now, if there is one. */ + oldest_idle = cpool_bundle_get_oldest_idle(bundle, + Curl_pgrs_now(data)); + if(!oldest_idle) + break; + /* disconnect the old conn and continue */ + CURL_TRC_M(data, "Discarding connection #%" FMT_OFF_T + " from %zu to reach destination limit of %zu", + oldest_idle->connection_id, + Curl_llist_count(&bundle->conns), dest_limit); + Curl_conn_terminate(cpool->idata, oldest_idle, FALSE); + + /* in case the bundle was destroyed in disconnect, look it up again */ + bundle = cpool_find_bundle(cpool, conn); + live = bundle ? Curl_llist_count(&bundle->conns) : 0; + } + shutdowns = Curl_cshutdn_dest_count(cpool->idata, conn->destination); + } + if((live + shutdowns) >= dest_limit) { + res = CPOOL_LIMIT_DEST; + goto out; + } + } + + if(total_limit) { + shutdowns = Curl_cshutdn_count(cpool->idata); + while((cpool->num_conn + shutdowns) >= total_limit) { + if(shutdowns) { + /* close one connection in shutdown right away, if we can */ + if(!Curl_cshutdn_close_oldest(data, NULL)) + break; + } + else { + struct connectdata *oldest_idle = + cpool_get_oldest_idle(cpool, Curl_pgrs_now(data)); + if(!oldest_idle) + break; + /* disconnect the old conn and continue */ + CURL_TRC_M(data, "Discarding connection #%" + FMT_OFF_T " from %zu to reach total " + "limit of %zu", + oldest_idle->connection_id, cpool->num_conn, total_limit); + Curl_conn_terminate(cpool->idata, oldest_idle, FALSE); + } + shutdowns = Curl_cshutdn_count(cpool->idata); + } + if((cpool->num_conn + shutdowns) >= total_limit) { + res = CPOOL_LIMIT_TOTAL; + goto out; + } + } + +out: + CPOOL_UNLOCK(cpool, cpool->idata); + return res; +} + +CURLcode Curl_cpool_add(struct Curl_easy *data, + struct connectdata *conn) +{ + CURLcode result = CURLE_OK; + struct cpool_bundle *bundle = NULL; + struct cpool *cpool = cpool_get_instance(data); + DEBUGASSERT(conn); + + DEBUGASSERT(cpool); + if(!cpool) + return CURLE_FAILED_INIT; + + CPOOL_LOCK(cpool, data); + bundle = cpool_find_bundle(cpool, conn); + if(!bundle) { + bundle = cpool_add_bundle(cpool, conn); + if(!bundle) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + } + + cpool_bundle_add(bundle, conn); + conn->connection_id = cpool->next_connection_id++; + cpool->num_conn++; + CURL_TRC_M(data, "[CPOOL] added connection %" FMT_OFF_T ". " + "The cache now contains %zu members", + conn->connection_id, cpool->num_conn); +out: + CPOOL_UNLOCK(cpool, data); + + return result; +} + +/* This function iterates the entire connection pool and calls the function + func() with the connection pointer as the first argument and the supplied + 'param' argument as the other. + + The cpool lock is still held when the callback is called. It needs it, + so that it can safely continue traversing the lists once the callback + returns. + + Returns TRUE if the loop was aborted due to the callback's return code. + + Return 0 from func() to continue the loop, return 1 to abort it. + */ +static bool cpool_foreach(struct Curl_easy *data, + struct cpool *cpool, + void *param, + int (*func)(struct Curl_easy *data, + struct connectdata *conn, void *param)) +{ + struct Curl_hash_iterator iter; + struct Curl_hash_element *he; + + if(!cpool) + return FALSE; + + Curl_hash_start_iterate(&cpool->dest2bundle, &iter); + + he = Curl_hash_next_element(&iter); + while(he) { + struct Curl_llist_node *curr; + struct cpool_bundle *bundle = he->ptr; + he = Curl_hash_next_element(&iter); + + curr = Curl_llist_head(&bundle->conns); + while(curr) { + /* Yes, we need to update curr before calling func(), because func() + might decide to remove the connection */ + struct connectdata *conn = Curl_node_elem(curr); + curr = Curl_node_next(curr); + + if(func(data, conn, param) == 1) { + return TRUE; + } + } + } + return FALSE; +} + +/* + * A connection (already in the pool) has become idle. Do any + * cleanups in regard to the pool's limits. + * + * Return TRUE if idle connection kept in pool, FALSE if closed. + */ +bool Curl_cpool_conn_now_idle(struct Curl_easy *data, + struct connectdata *conn) +{ + unsigned int maxconnects; + struct connectdata *oldest_idle = NULL; + struct cpool *cpool = cpool_get_instance(data); + bool kept = TRUE; + + if(!data || !data->multi) + return kept; + + if(!data->multi->maxconnects) { + unsigned int running = Curl_multi_xfers_running(data->multi); + maxconnects = (running <= UINT_MAX / 4) ? running * 4 : UINT_MAX; + } + else { + maxconnects = data->multi->maxconnects; + } + + conn->lastused = *Curl_pgrs_now(data); /* it was used up until now */ + if(cpool && maxconnects) { + /* may be called form a callback already under lock */ + bool do_lock = !CPOOL_IS_LOCKED(cpool); + if(do_lock) + CPOOL_LOCK(cpool, data); + if(cpool->num_conn > maxconnects) { + infof(data, "Connection pool is full, closing the oldest of %zu/%u", + cpool->num_conn, maxconnects); + + oldest_idle = cpool_get_oldest_idle(cpool, Curl_pgrs_now(data)); + kept = (oldest_idle != conn); + if(oldest_idle) { + Curl_conn_terminate(data, oldest_idle, FALSE); + } + } + if(do_lock) + CPOOL_UNLOCK(cpool, data); + } + + return kept; +} + +bool Curl_cpool_find(struct Curl_easy *data, + const char *destination, + Curl_cpool_conn_match_cb *conn_cb, + Curl_cpool_done_match_cb *done_cb, + void *userdata) +{ + struct cpool *cpool = cpool_get_instance(data); + struct cpool_bundle *bundle; + bool found = FALSE; + + DEBUGASSERT(cpool); + DEBUGASSERT(conn_cb); + if(!cpool) + return FALSE; + + CPOOL_LOCK(cpool, data); + bundle = Curl_hash_pick(&cpool->dest2bundle, + CURL_UNCONST(destination), + strlen(destination) + 1); + if(bundle) { + struct Curl_llist_node *curr = Curl_llist_head(&bundle->conns); + while(curr) { + struct connectdata *conn = Curl_node_elem(curr); + /* Get next node now. callback might discard current */ + curr = Curl_node_next(curr); + + if(conn_cb(conn, userdata)) { + found = TRUE; + break; + } + } + } + + if(done_cb) { + found = done_cb(userdata); + } + CPOOL_UNLOCK(cpool, data); + return found; +} + +void Curl_conn_terminate(struct Curl_easy *data, + struct connectdata *conn, + bool aborted) +{ + struct cpool *cpool = cpool_get_instance(data); + bool do_lock; + + DEBUGASSERT(cpool); + DEBUGASSERT(data && !data->conn); + if(!cpool) + return; + + /* If this connection is not marked to force-close, leave it open if there + * are other users of it */ + if(CONN_INUSE(conn) && !aborted) { + DEBUGASSERT(0); /* does this ever happen? */ + DEBUGF(infof(data, "conn terminate when inuse: %u", conn->attached_xfers)); + return; + } + + /* This method may be called while we are under lock, e.g. from a + * user callback in find. */ + do_lock = !CPOOL_IS_LOCKED(cpool); + if(do_lock) + CPOOL_LOCK(cpool, data); + + if(conn->bits.in_cpool) { + cpool_remove_conn(cpool, conn); + DEBUGASSERT(!conn->bits.in_cpool); + } + + /* treat the connection as aborted in CONNECT_ONLY situations, + * so no graceful shutdown is attempted. */ + if(conn->bits.connect_only) + aborted = TRUE; + + if(data->multi) { + /* Add it to the multi's cpool for shutdown handling */ + infof(data, "%s connection #%" FMT_OFF_T, + aborted ? "closing" : "shutting down", conn->connection_id); + cpool_discard_conn(&data->multi->cpool, data, conn, aborted); + } + else { + /* No multi available, terminate */ + infof(data, "closing connection #%" FMT_OFF_T, conn->connection_id); + Curl_cshutdn_terminate(cpool->idata, conn, !aborted); + } + + if(do_lock) + CPOOL_UNLOCK(cpool, data); +} + +struct cpool_reaper_ctx { + size_t checked; + size_t reaped; +}; + +static int cpool_reap_dead_cb(struct Curl_easy *data, + struct connectdata *conn, void *param) +{ + struct cpool_reaper_ctx *reaper = param; + bool terminate = !CONN_INUSE(conn) && conn->bits.no_reuse; + + if(!terminate) { + reaper->checked++; + terminate = Curl_conn_seems_dead(conn, data); + } + if(terminate) { + /* stop the iteration here, pass back the connection that was pruned */ + reaper->reaped++; + Curl_conn_terminate(data, conn, FALSE); + return 1; + } + return 0; /* continue iteration */ +} + +/* + * This function scans the data's connection pool for half-open/dead + * connections, closes and removes them. + * The cleanup is done at most once per second. + * + * When called, this transfer has no connection attached. + */ +void Curl_cpool_prune_dead(struct Curl_easy *data) +{ + struct cpool *cpool = cpool_get_instance(data); + struct cpool_reaper_ctx reaper; + timediff_t elapsed; + + if(!cpool) + return; + + memset(&reaper, 0, sizeof(reaper)); + CPOOL_LOCK(cpool, data); + elapsed = curlx_ptimediff_ms(Curl_pgrs_now(data), &cpool->last_cleanup); + + if(elapsed >= 1000L) { + while(cpool_foreach(data, cpool, &reaper, cpool_reap_dead_cb)) + ; + cpool->last_cleanup = *Curl_pgrs_now(data); + } + CPOOL_UNLOCK(cpool, data); +} + +static int conn_upkeep(struct Curl_easy *data, + struct connectdata *conn, + void *param) +{ + (void)param; + Curl_conn_upkeep(data, conn); + return 0; /* continue iteration */ +} + +CURLcode Curl_cpool_upkeep(struct Curl_easy *data) +{ + struct cpool *cpool = cpool_get_instance(data); + + if(!cpool) + return CURLE_OK; + + CPOOL_LOCK(cpool, data); + cpool_foreach(data, cpool, NULL, conn_upkeep); + CPOOL_UNLOCK(cpool, data); + return CURLE_OK; +} + +struct cpool_find_ctx { + curl_off_t id; + struct connectdata *conn; +}; + +static int cpool_find_conn(struct Curl_easy *data, + struct connectdata *conn, void *param) +{ + struct cpool_find_ctx *fctx = param; + (void)data; + if(conn->connection_id == fctx->id) { + fctx->conn = conn; + return 1; + } + return 0; +} + +struct connectdata *Curl_cpool_get_conn(struct Curl_easy *data, + curl_off_t conn_id) +{ + struct cpool *cpool = cpool_get_instance(data); + struct cpool_find_ctx fctx; + + if(!cpool) + return NULL; + fctx.id = conn_id; + fctx.conn = NULL; + CPOOL_LOCK(cpool, data); + cpool_foreach(data, cpool, &fctx, cpool_find_conn); + CPOOL_UNLOCK(cpool, data); + return fctx.conn; +} + +struct cpool_do_conn_ctx { + curl_off_t id; + Curl_cpool_conn_do_cb *cb; + void *cbdata; +}; + +static int cpool_do_conn(struct Curl_easy *data, + struct connectdata *conn, void *param) +{ + struct cpool_do_conn_ctx *dctx = param; + + if(conn->connection_id == dctx->id) { + dctx->cb(conn, data, dctx->cbdata); + return 1; + } + return 0; +} + +void Curl_cpool_do_by_id(struct Curl_easy *data, curl_off_t conn_id, + Curl_cpool_conn_do_cb *cb, void *cbdata) +{ + struct cpool *cpool = cpool_get_instance(data); + struct cpool_do_conn_ctx dctx; + + if(!cpool) + return; + dctx.id = conn_id; + dctx.cb = cb; + dctx.cbdata = cbdata; + CPOOL_LOCK(cpool, data); + cpool_foreach(data, cpool, &dctx, cpool_do_conn); + CPOOL_UNLOCK(cpool, data); +} + +void Curl_cpool_do_locked(struct Curl_easy *data, + struct connectdata *conn, + Curl_cpool_conn_do_cb *cb, void *cbdata) +{ + struct cpool *cpool = cpool_get_instance(data); + if(cpool) { + CPOOL_LOCK(cpool, data); + cb(conn, data, cbdata); + CPOOL_UNLOCK(cpool, data); + } + else + cb(conn, data, cbdata); +} + +static int cpool_mark_stale(struct Curl_easy *data, + struct connectdata *conn, void *param) +{ + (void)data; + (void)param; + conn->bits.no_reuse = TRUE; + return 0; +} + +static int cpool_reap_no_reuse(struct Curl_easy *data, + struct connectdata *conn, void *param) +{ + (void)param; + if(!CONN_INUSE(conn) && conn->bits.no_reuse) { + Curl_conn_terminate(data, conn, FALSE); + return 1; + } + return 0; /* continue iteration */ +} + +void Curl_cpool_nw_changed(struct Curl_easy *data) +{ + struct cpool *cpool = cpool_get_instance(data); + + if(cpool) { + CPOOL_LOCK(cpool, data); + cpool_foreach(data, cpool, NULL, cpool_mark_stale); + while(cpool_foreach(data, cpool, NULL, cpool_reap_no_reuse)) + ; + CPOOL_UNLOCK(cpool, data); + } +} + +#if 0 +/* Useful for debugging the connection pool */ +void Curl_cpool_print(struct cpool *cpool) +{ + struct Curl_hash_iterator iter; + struct Curl_llist_node *curr; + struct Curl_hash_element *he; + + if(!cpool) + return; + + curl_mfprintf(stderr, "=Bundle cache=\n"); + + Curl_hash_start_iterate(cpool->dest2bundle, &iter); + + he = Curl_hash_next_element(&iter); + while(he) { + struct cpool_bundle *bundle; + struct connectdata *conn; + + bundle = he->ptr; + + curl_mfprintf(stderr, "%s -", he->key); + curr = Curl_llist_head(bundle->conns); + while(curr) { + conn = Curl_node_elem(curr); + + curl_mfprintf(stderr, " [%p %d]", (void *)conn, conn->refcount); + curr = Curl_node_next(curr); + } + curl_mfprintf(stderr, "\n"); + + he = Curl_hash_next_element(&iter); + } +} +#endif diff --git a/3rdparty/curl-8.21.0/lib/conncache.h b/3rdparty/curl-8.21.0/lib/conncache.h new file mode 100644 index 0000000000..71940d724c --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/conncache.h @@ -0,0 +1,167 @@ +#ifndef HEADER_CURL_CONNCACHE_H +#define HEADER_CURL_CONNCACHE_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * Copyright (C) Linus Nielsen Feltzing, + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curlx/timeval.h" + +struct connectdata; +struct Curl_easy; +struct curl_pollfds; +struct Curl_waitfds; +struct Curl_multi; +struct Curl_share; + +/** + * Terminate the connection, e.g. close and destroy. + * If the connection is in a cpool, remove it. + * If a `cshutdn` is available (e.g. data has a multi handle), + * pass the connection to that for controlled shutdown. + * Otherwise terminate it right away. + * Takes ownership of `conn`. + * `data` should not be attached to a connection. + */ +void Curl_conn_terminate(struct Curl_easy *data, + struct connectdata *conn, + bool aborted); + +struct cpool { + /* the pooled connections, bundled per destination */ + struct Curl_hash dest2bundle; + size_t num_conn; + curl_off_t next_connection_id; + curl_off_t next_easy_id; + struct curltime last_cleanup; + struct Curl_easy *idata; /* internal handle for maintenance */ + struct Curl_share *share; /* != NULL if pool belongs to share */ + BIT(locked); + BIT(initialized); +}; + +/* Init the pool, pass multi only if pool is owned by it. + * Cannot fail. + */ +void Curl_cpool_init(struct cpool *cpool, + struct Curl_easy *idata, + struct Curl_share *share, + size_t size); + +/* Destroy all connections and free all members */ +void Curl_cpool_destroy(struct cpool *cpool); + +/* Init the transfer to be used within its connection pool. + * Assigns `data->id`. */ +void Curl_cpool_xfer_init(struct Curl_easy *data); + +/* Get the connection with the given id from `data`'s conn pool. */ +struct connectdata *Curl_cpool_get_conn(struct Curl_easy *data, + curl_off_t conn_id); + +/* Add the connection to the pool. */ +CURLcode Curl_cpool_add(struct Curl_easy *data, + struct connectdata *conn) WARN_UNUSED_RESULT; + +/** + * Return if the pool has reached its configured limits for adding + * the given connection. Try to discard the oldest, idle connections + * to make space. + */ +#define CPOOL_LIMIT_OK 0 +#define CPOOL_LIMIT_DEST 1 +#define CPOOL_LIMIT_TOTAL 2 +int Curl_cpool_check_limits(struct Curl_easy *data, + struct connectdata *conn); + +/* Return of conn is suitable. If so, stops iteration. */ +typedef bool Curl_cpool_conn_match_cb(struct connectdata *conn, + void *userdata); + +/* Act on the result of the find, may override it. */ +typedef bool Curl_cpool_done_match_cb(void *userdata); + +/** + * Find a connection in the pool matching `destination`. + * All callbacks are invoked while the pool's lock is held. + * @param data current transfer + * @param destination match against `conn->destination` in pool + * @param conn_cb must be present, called for each connection in the + * bundle until it returns TRUE + * @return combined result of last conn_db and result_cb or FALSE if no + connections were present. + */ +bool Curl_cpool_find(struct Curl_easy *data, + const char *destination, + Curl_cpool_conn_match_cb *conn_cb, + Curl_cpool_done_match_cb *done_cb, + void *userdata); + +/* + * A connection (already in the pool) is now idle. Do any + * cleanups in regard to the pool's limits. + * + * Return TRUE if idle connection kept in pool, FALSE if closed. + */ +bool Curl_cpool_conn_now_idle(struct Curl_easy *data, + struct connectdata *conn); + +/** + * This function scans the data's connection pool for half-open/dead + * connections, closes and removes them. + * The cleanup is done at most once per second. + * + * When called, this transfer has no connection attached. + */ +void Curl_cpool_prune_dead(struct Curl_easy *data); + +/** + * Perform upkeep actions on connections in the transfer's pool. + */ +CURLcode Curl_cpool_upkeep(struct Curl_easy *data); + +typedef void Curl_cpool_conn_do_cb(struct connectdata *conn, + struct Curl_easy *data, + void *cbdata); + +/** + * Invoke the callback on the pool's connection with the + * given connection id (if it exists). + */ +void Curl_cpool_do_by_id(struct Curl_easy *data, + curl_off_t conn_id, + Curl_cpool_conn_do_cb *cb, void *cbdata); + +/** + * Invoked the callback for the given data + connection under the + * connection pool's lock. + * The callback is always invoked, even if the transfer has no connection + * pool associated. + */ +void Curl_cpool_do_locked(struct Curl_easy *data, + struct connectdata *conn, + Curl_cpool_conn_do_cb *cb, void *cbdata); + +/* Close all unused connections, prevent reuse of existing ones. */ +void Curl_cpool_nw_changed(struct Curl_easy *data); + +#endif /* HEADER_CURL_CONNCACHE_H */ diff --git a/3rdparty/curl-8.21.0/lib/connect.c b/3rdparty/curl-8.21.0/lib/connect.c new file mode 100644 index 0000000000..a2b86c7458 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/connect.c @@ -0,0 +1,494 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "urldata.h" +#include "curl_trc.h" +#include "strerror.h" +#include "cfilters.h" +#include "connect.h" +#include "cf-dns.h" +#include "cf-https-connect.h" +#include "cf-setup.h" +#include "multiif.h" +#include "progress.h" +#include "conncache.h" +#include "multihandle.h" +#include "select.h" +#include "curlx/strparse.h" + +#if !defined(CURL_DISABLE_ALTSVC) || defined(USE_HTTPSRR) + +enum alpnid Curl_alpn2alpnid(const unsigned char *name, size_t len) +{ + if(len == 2) { + if(!memcmp(name, "h1", 2)) + return ALPN_h1; + if(!memcmp(name, "h2", 2)) + return ALPN_h2; + if(!memcmp(name, "h3", 2)) + return ALPN_h3; + } + else if(len == 8) { + if(!memcmp(name, "http/1.1", 8)) + return ALPN_h1; + } + return ALPN_none; /* unknown, probably rubbish input */ +} + +enum alpnid Curl_str2alpnid(const struct Curl_str *cstr) +{ + return Curl_alpn2alpnid((const unsigned char *)curlx_str(cstr), + curlx_strlen(cstr)); +} + +#endif + +/* + * timeleft_now_ms() returns the amount of milliseconds left allowed for the + * transfer/connection. If the value is 0, there is no timeout (ie there is + * infinite time left). If the value is negative, the timeout time has already + * elapsed. + * + * @unittest 1303 + */ +UNITTEST timediff_t timeleft_now_ms(struct Curl_easy *data, + const struct curltime *pnow); +UNITTEST timediff_t timeleft_now_ms(struct Curl_easy *data, + const struct curltime *pnow) +{ + timediff_t timeleft_ms = 0; + timediff_t ctimeleft_ms = 0; + + if(Curl_shutdown_started(data, FIRSTSOCKET)) + return Curl_shutdown_timeleft(data, data->conn, FIRSTSOCKET); + else if(Curl_is_connecting(data)) { + timediff_t ctimeout_ms = (data->set.connecttimeout > 0) ? + data->set.connecttimeout : DEFAULT_CONNECT_TIMEOUT; + ctimeleft_ms = ctimeout_ms - + curlx_ptimediff_ms(pnow, &data->progress.t_startsingle); + if(!ctimeleft_ms) + ctimeleft_ms = -1; /* 0 is "no limit", fake 1 ms expiry */ + } + else if(!data->set.timeout || data->set.connect_only) { + return 0; /* no timeout in place or checked, return "no limit" */ + } + + if(data->set.timeout) { + timeleft_ms = data->set.timeout - + curlx_ptimediff_ms(pnow, &data->progress.t_startop); + if(!timeleft_ms) + timeleft_ms = -1; /* 0 is "no limit", fake 1 ms expiry */ + } + + if(!ctimeleft_ms) + return timeleft_ms; + else if(!timeleft_ms) + return ctimeleft_ms; + return CURLMIN(ctimeleft_ms, timeleft_ms); +} + +timediff_t Curl_timeleft_ms(struct Curl_easy *data) +{ + return timeleft_now_ms(data, Curl_pgrs_now(data)); +} + +void Curl_shutdown_start(struct Curl_easy *data, int sockindex, + int timeout_ms) +{ + struct connectdata *conn = data->conn; + + DEBUGASSERT(conn); + conn->shutdown.start[sockindex] = *Curl_pgrs_now(data); + conn->shutdown.timeout_ms = (timeout_ms > 0) ? + (timediff_t)timeout_ms : + ((data->set.shutdowntimeout > 0) ? + data->set.shutdowntimeout : DEFAULT_SHUTDOWN_TIMEOUT_MS); + /* Set a timer, unless we operate on the admin handle */ + if(data->mid) + Curl_expire_ex(data, conn->shutdown.timeout_ms, EXPIRE_SHUTDOWN); + CURL_TRC_M(data, "shutdown start on%s connection", + sockindex ? " secondary" : ""); +} + +timediff_t Curl_shutdown_timeleft(struct Curl_easy *data, + struct connectdata *conn, + int sockindex) +{ + timediff_t left_ms; + + if(!conn->shutdown.start[sockindex].tv_sec || + (conn->shutdown.timeout_ms <= 0)) + return 0; /* not started or no limits */ + + left_ms = conn->shutdown.timeout_ms - + curlx_ptimediff_ms(Curl_pgrs_now(data), + &conn->shutdown.start[sockindex]); + return left_ms ? left_ms : -1; +} + +timediff_t Curl_conn_shutdown_timeleft(struct Curl_easy *data, + struct connectdata *conn) +{ + timediff_t left_ms = 0, ms; + int i; + + for(i = 0; conn->shutdown.timeout_ms && (i < 2); ++i) { + if(!conn->shutdown.start[i].tv_sec) + continue; + ms = Curl_shutdown_timeleft(data, conn, i); + if(ms && (!left_ms || ms < left_ms)) + left_ms = ms; + } + return left_ms; +} + +void Curl_shutdown_clear(struct Curl_easy *data, int sockindex) +{ + struct curltime *pt = &data->conn->shutdown.start[sockindex]; + memset(pt, 0, sizeof(*pt)); +} + +bool Curl_shutdown_started(struct Curl_easy *data, int sockindex) +{ + if(data->conn) { + struct curltime *pt = &data->conn->shutdown.start[sockindex]; + return (pt->tv_sec > 0) || (pt->tv_usec > 0); + } + return FALSE; +} + +/* + * Used to extract socket and connectdata struct for the most recent + * transfer on the given Curl_easy. + * + * The returned socket will be CURL_SOCKET_BAD in case of failure! + */ +curl_socket_t Curl_getconnectinfo(struct Curl_easy *data, + struct connectdata **connp) +{ + DEBUGASSERT(data); + + /* this works for an easy handle: + * - that has been used for curl_easy_perform() + * - that is associated with a multi handle, and whose connection + * was detached with CURLOPT_CONNECT_ONLY + */ + if(data->state.lastconnect_id != -1) { + struct connectdata *conn; + + conn = Curl_cpool_get_conn(data, data->state.lastconnect_id); + if(!conn) { + data->state.lastconnect_id = -1; + return CURL_SOCKET_BAD; + } + + if(connp) + /* only store this if the caller cares for it */ + *connp = conn; + return conn->sock[FIRSTSOCKET]; + } + return CURL_SOCKET_BAD; +} + +/* + * Curl_conncontrol() marks streams or connection for closure. + */ +void Curl_conncontrol(struct connectdata *conn, + int ctrl /* see defines in header */ +#if defined(DEBUGBUILD) && defined(CURLVERBOSE) + , const char *reason +#endif + ) +{ + /* close if a connection, or a stream that is not multiplexed. */ + /* This function will be called both before and after this connection is + associated with a transfer. */ + bool closeit, is_multiplex; + DEBUGASSERT(conn); +#if defined(DEBUGBUILD) && defined(CURLVERBOSE) + (void)reason; /* useful for debugging */ +#endif + is_multiplex = Curl_conn_is_multiplex(conn, FIRSTSOCKET); + closeit = (ctrl == CONNCTRL_CONNECTION) || + ((ctrl == CONNCTRL_STREAM) && !is_multiplex); + if((ctrl == CONNCTRL_STREAM) && is_multiplex) + ; /* stream signal on multiplex conn never affects close state */ + else if((curl_bit)closeit != conn->bits.close) { + conn->bits.close = closeit; /* the only place in the source code that + should assign this bit */ + } +} + +CURLcode Curl_conn_setup(struct Curl_easy *data, + struct connectdata *conn, + int sockindex, + int ssl_mode) +{ + CURLcode result = CURLE_OK; + struct Curl_peer *peer = Curl_conn_get_first_peer(conn, sockindex); + uint8_t dns_queries; + + DEBUGASSERT(data); + DEBUGASSERT(conn->scheme); + DEBUGASSERT(!conn->cfilter[sockindex]); + + if(!peer) + return CURLE_FAILED_INIT; + +#ifndef CURL_DISABLE_HTTP + if(!conn->cfilter[sockindex] && + conn->scheme->protocol == CURLPROTO_HTTPS) { + DEBUGASSERT(ssl_mode != CURL_CF_SSL_DISABLE); + result = Curl_cf_https_setup(data, conn, sockindex); + if(result) + goto out; + } +#endif /* !CURL_DISABLE_HTTP */ + + /* Still no cfilter set, apply default. */ + if(!conn->cfilter[sockindex]) { + result = Curl_cf_setup_add(data, conn, sockindex, + conn->transport_wanted, ssl_mode); + if(result) + goto out; + } + + dns_queries = Curl_resolv_dns_queries(data, conn->ip_version); +#ifdef USE_HTTPSRR + if(sockindex == FIRSTSOCKET) + dns_queries |= CURL_DNSQ_HTTPS; +#endif + result = Curl_cf_dns_add(data, conn, sockindex, peer, dns_queries, + conn->transport_wanted); + DEBUGASSERT(conn->cfilter[sockindex]); +out: + return result; +} + +#ifdef CURLVERBOSE +static CURLcode conn_connect_trace(struct Curl_easy *data, + struct Curl_cfilter *cf) +{ + if(Curl_trc_is_verbose(data)) { + struct ip_quadruple ipquad; + bool is_ipv6; + CURLcode result; + + result = Curl_conn_cf_get_ip_info(cf, data, &is_ipv6, &ipquad); + if(result) + return result; + + infof(data, "Established %sconnection to %s (%s port %u) from %s port %u ", + (cf->sockindex == SECONDARYSOCKET) ? "2nd " : "", + CURL_CONN_HOST_DISPNAME(data->conn), + ipquad.remote_ip, ipquad.remote_port, + ipquad.local_ip, ipquad.local_port); + } + return CURLE_OK; +} +#endif + +/** + * Update connection statistics + */ +static void conn_report_connect_stats(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + if(cf) { + struct curltime connected; + struct curltime appconnected; + + memset(&connected, 0, sizeof(connected)); + cf->cft->query(cf, data, CF_QUERY_TIMER_CONNECT, NULL, &connected); + if(connected.tv_sec || connected.tv_usec) + Curl_pgrsTimeWas(data, TIMER_CONNECT, connected); + + memset(&appconnected, 0, sizeof(appconnected)); + cf->cft->query(cf, data, CF_QUERY_TIMER_APPCONNECT, NULL, &appconnected); + if(appconnected.tv_sec || appconnected.tv_usec) + Curl_pgrsTimeWas(data, TIMER_APPCONNECT, appconnected); + } +} + +CURLcode Curl_conn_connect(struct Curl_easy *data, + int sockindex, + bool blocking, + bool *done) +{ +#define CF_CONN_NUM_POLLS_ON_STACK 5 + struct pollfd a_few_on_stack[CF_CONN_NUM_POLLS_ON_STACK]; + struct easy_pollset ps; + struct curl_pollfds cpfds; + struct Curl_cfilter *cf; + CURLcode result = CURLE_OK; + + DEBUGASSERT(data); + DEBUGASSERT(data->conn); + if(!CONN_SOCK_IDX_VALID(sockindex)) + return CURLE_BAD_FUNCTION_ARGUMENT; + + if(data->conn->scheme->flags & PROTOPT_NONETWORK) { + *done = TRUE; + return CURLE_OK; + } + + cf = data->conn->cfilter[sockindex]; + if(!cf) { + *done = FALSE; + return CURLE_FAILED_INIT; + } + + *done = (bool)cf->connected; + if(*done) + return CURLE_OK; + + Curl_pollset_init(&ps); + Curl_pollfds_init(&cpfds, a_few_on_stack, CF_CONN_NUM_POLLS_ON_STACK); + while(!*done) { + if(Curl_conn_needs_flush(data, sockindex)) { + DEBUGF(infof(data, "Curl_conn_connect(index=%d), flush", sockindex)); + result = Curl_conn_flush(data, sockindex); + if(result && (result != CURLE_AGAIN)) + goto out; + } + + result = cf->cft->do_connect(cf, data, done); + CURL_TRC_CF(data, cf, "Curl_conn_connect(block=%d) -> %d, done=%d", + blocking, (int)result, *done); + if(!result && *done) { + /* A final sanity check on connection security */ + if((data->state.origin->scheme->flags & PROTOPT_SSL) && + (sockindex == FIRSTSOCKET) && + !Curl_conn_is_ssl(data->conn, FIRSTSOCKET)) { + DEBUGASSERT(0); + failf(data, "transfer requires SSL, but not connected via SSL"); + result = CURLE_FAILED_INIT; + goto out; + } + /* Now that the complete filter chain is connected, let all filters + * persist information at the connection. E.g. cf-socket sets the + * socket and ip related information. */ + Curl_conn_cntrl_update_info(data, data->conn); + conn_report_connect_stats(cf, data); + data->conn->keepalive = *Curl_pgrs_now(data); + VERBOSE(result = conn_connect_trace(data, cf)); + VERBOSE(Curl_conn_trc_filters(data, sockindex, "connected")); + Curl_conn_remove_setup_filters(data, sockindex); + VERBOSE(Curl_conn_trc_filters(data, sockindex, "reduced to")); + goto out; + } + else if(result) { + CURL_TRC_CF(data, cf, "Curl_conn_connect(), filter returned %d", + (int)result); + VERBOSE(Curl_conn_trc_filters(data, sockindex, "failed to connect")); + conn_report_connect_stats(cf, data); + goto out; + } + + if(!blocking) + goto out; + else { + /* check allowed time left */ + const timediff_t timeout_ms = Curl_timeleft_ms(data); + curl_socket_t sockfd = Curl_conn_cf_get_socket(cf, data); + int rc; + + if(timeout_ms < 0) { + /* no need to continue if time already is up */ + failf(data, "connect timeout"); + result = CURLE_OPERATION_TIMEDOUT; + goto out; + } + + CURL_TRC_CF(data, cf, "Curl_conn_connect(block=1), do poll"); + Curl_pollset_reset(&ps); + Curl_pollfds_reset(&cpfds); + /* In general, we want to send after connect, wait on that. */ + if(sockfd != CURL_SOCKET_BAD) + result = Curl_pollset_set_out_only(data, &ps, sockfd); + if(!result) + result = Curl_conn_adjust_pollset(data, data->conn, &ps); + if(result) + goto out; + result = Curl_pollfds_add_ps(&cpfds, &ps); + if(result) + goto out; + + rc = Curl_poll(cpfds.pfds, cpfds.n, + CURLMIN(timeout_ms, (cpfds.n ? 1000 : 10))); + CURL_TRC_CF(data, cf, "Curl_conn_connect(block=1), Curl_poll() -> %d", + rc); + if(rc < 0) { + result = CURLE_COULDNT_CONNECT; + goto out; + } + /* continue iterating */ + } + } + +out: + Curl_pollset_cleanup(&ps); + Curl_pollfds_cleanup(&cpfds); + return result; +} + +void Curl_conn_set_multiplex(struct connectdata *conn) +{ + if(!conn->bits.multiplex) { + conn->bits.multiplex = TRUE; + if(conn->attached_multi) { + Curl_multi_connchanged(conn->attached_multi); + } + } +} + +struct Curl_peer *Curl_conn_get_origin(struct connectdata *conn, + int sockindex) +{ + return (sockindex == SECONDARYSOCKET) ? + conn->origin2 : conn->origin; +} + +struct Curl_peer *Curl_conn_get_destination(struct connectdata *conn, + int sockindex) +{ + return (sockindex == SECONDARYSOCKET) ? + (conn->via_peer2 ? conn->via_peer2 : conn->origin2) : + (conn->via_peer ? conn->via_peer : conn->origin); +} + +struct Curl_peer *Curl_conn_get_first_peer(struct connectdata *conn, + int sockindex) +{ +#ifndef CURL_DISABLE_PROXY + if(conn->socks_proxy.peer) + return conn->socks_proxy.peer; + if(conn->http_proxy.peer) + return conn->http_proxy.peer; +#endif + return (sockindex == SECONDARYSOCKET) ? + (conn->via_peer2 ? conn->via_peer2 : conn->origin2) : + (conn->via_peer ? conn->via_peer : conn->origin); +} diff --git a/3rdparty/curl-8.21.0/lib/connect.h b/3rdparty/curl-8.21.0/lib/connect.h new file mode 100644 index 0000000000..95bde1eb4c --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/connect.h @@ -0,0 +1,144 @@ +#ifndef HEADER_CURL_CONNECT_H +#define HEADER_CURL_CONNECT_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "hostip.h" +#include "curlx/timeval.h" + +struct Curl_peer; +struct Curl_str; + +enum alpnid Curl_alpn2alpnid(const unsigned char *name, size_t len); +enum alpnid Curl_str2alpnid(const struct Curl_str *cstr); + +/* generic function that returns how much time there is left to run, according + to the timeouts set */ +timediff_t Curl_timeleft_ms(struct Curl_easy *data); + +#define DEFAULT_CONNECT_TIMEOUT 300000 /* milliseconds == five minutes */ + +#define DEFAULT_SHUTDOWN_TIMEOUT_MS (2 * 1000) + +void Curl_shutdown_start(struct Curl_easy *data, int sockindex, + int timeout_ms); + +/* return how much time there is left to shutdown the connection at + * sockindex. Returns 0 if there is no limit or shutdown has not started. */ +timediff_t Curl_shutdown_timeleft(struct Curl_easy *data, + struct connectdata *conn, + int sockindex); + +/* return how much time there is left to shutdown the connection. + * Returns 0 if there is no limit or shutdown has not started. */ +timediff_t Curl_conn_shutdown_timeleft(struct Curl_easy *data, + struct connectdata *conn); + +void Curl_shutdown_clear(struct Curl_easy *data, int sockindex); + +/* TRUE iff shutdown has been started */ +bool Curl_shutdown_started(struct Curl_easy *data, int sockindex); + +/* + * Used to extract socket and connectdata struct for the most recent + * transfer on the given Curl_easy. + * + * The returned socket will be CURL_SOCKET_BAD in case of failure! + */ +curl_socket_t Curl_getconnectinfo(struct Curl_easy *data, + struct connectdata **connp); + +/* + * Curl_conncontrol() marks the end of a connection/stream. The 'ctrl' + * argument specifies if it is the end of a connection or a stream. + * + * For stream-based protocols (such as HTTP/2), a stream close will not cause + * a connection close. Other protocols will close the connection for both + * cases. + * + * It sets the bit.close bit to TRUE (with an explanation for debug builds), + * when the connection will close. + */ + +#define CONNCTRL_KEEP 0 /* undo a marked closure */ +#define CONNCTRL_CONNECTION 1 +#define CONNCTRL_STREAM 2 + +void Curl_conncontrol(struct connectdata *conn, + int ctrl +#if defined(DEBUGBUILD) && defined(CURLVERBOSE) + , const char *reason +#endif + ); + +#if defined(DEBUGBUILD) && defined(CURLVERBOSE) +#define streamclose(x, y) Curl_conncontrol(x, CONNCTRL_STREAM, y) +#define connclose(x, y) Curl_conncontrol(x, CONNCTRL_CONNECTION, y) +#define connkeep(x, y) Curl_conncontrol(x, CONNCTRL_KEEP, y) +#else /* !DEBUGBUILD || !CURLVERBOSE */ +#define streamclose(x, y) Curl_conncontrol(x, CONNCTRL_STREAM) +#define connclose(x, y) Curl_conncontrol(x, CONNCTRL_CONNECTION) +#define connkeep(x, y) Curl_conncontrol(x, CONNCTRL_KEEP) +#endif + +/** + * Setup the cfilters at `sockindex` in connection `conn`. + * If no filter chain is installed yet, inspects the configuration + * in `data` and `conn` to install a suitable filter chain. + */ +CURLcode Curl_conn_setup(struct Curl_easy *data, + struct connectdata *conn, + int sockindex, + int ssl_mode); + +/** + * Bring the filter chain at `sockindex` for connection `data->conn` into + * connected state. Which will set `*done` to TRUE. + * This can be called on an already connected chain with no side effects. + * When not `blocking`, calls may return without error and `*done != TRUE`, + * while the individual filters negotiated the connection. + */ +CURLcode Curl_conn_connect(struct Curl_easy *data, int sockindex, + bool blocking, bool *done); + +/* Set conn to allow multiplexing. */ +void Curl_conn_set_multiplex(struct connectdata *conn); + +/* Get the origin peer at sockindex. */ +struct Curl_peer *Curl_conn_get_origin(struct connectdata *conn, + int sockindex); + +/* Get the peer the connection actually connects to at sockindex. + * Often the same as "origin", but can be redirected via "connect-to" + * or "alt-svc". May tunnel through proxies. */ +struct Curl_peer *Curl_conn_get_destination(struct connectdata *conn, + int sockindex); + +/* Get the peer curl connects its socket to. + * Can be origin, "connect-to" or the first proxy. */ +struct Curl_peer *Curl_conn_get_first_peer(struct connectdata *conn, + int sockindex); + +#endif /* HEADER_CURL_CONNECT_H */ diff --git a/3rdparty/curl-8.21.0/lib/content_encoding.c b/3rdparty/curl-8.21.0/lib/content_encoding.c new file mode 100644 index 0000000000..fd08077259 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/content_encoding.c @@ -0,0 +1,856 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "urldata.h" +#include "curlx/dynbuf.h" + +#ifdef HAVE_LIBZ +#include +#endif + +#ifdef HAVE_BROTLI +#ifdef CURL_HAVE_DIAG +/* Ignore -Wvla warnings in brotli headers */ +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Wvla" +#endif +#include +#ifdef CURL_HAVE_DIAG +#pragma GCC diagnostic pop +#endif +#endif + +#ifdef HAVE_ZSTD +#include +#endif + +#include "connect.h" +#include "sendf.h" +#include "curl_trc.h" +#include "content_encoding.h" + +#define CONTENT_ENCODING_DEFAULT "identity" + +#ifndef CURL_DISABLE_HTTP + +/* allow no more than 5 "chained" compression steps */ +#define MAX_ENCODE_STACK 5 + +#if defined(HAVE_LIBZ) || defined(HAVE_BROTLI) || defined(HAVE_ZSTD) +#define DECOMPRESS_BUFFER_SIZE 16384 /* buffer size for decompressed data */ +#endif + +#ifdef HAVE_LIBZ + +#if !defined(ZLIB_VERNUM) || (ZLIB_VERNUM < 0x1252) +#error "requires zlib 1.2.5.2 or newer" +#endif + +typedef enum { + ZLIB_UNINIT, /* uninitialized */ + ZLIB_INIT, /* initialized */ + ZLIB_INFLATING, /* inflating started. */ + ZLIB_EXTERNAL_TRAILER, /* reading external trailer */ + ZLIB_INIT_GZIP /* initialized in transparent gzip mode */ +} zlibInitState; + +/* Deflate and gzip writer. */ +struct zlib_writer { + struct Curl_cwriter super; + zlibInitState zlib_init; /* zlib init state */ + char buffer[DECOMPRESS_BUFFER_SIZE]; /* Put the decompressed data here. */ + uInt trailerlen; /* Remaining trailer byte count. */ + z_stream z; /* State structure for zlib. */ +}; + +static voidpf zalloc_cb(voidpf opaque, unsigned int items, unsigned int size) +{ + (void)opaque; + /* not a typo, keep it curlx_calloc() */ + return curlx_calloc(items, size); +} + +static void zfree_cb(voidpf opaque, voidpf ptr) +{ + (void)opaque; + curlx_free(ptr); +} + +static CURLcode process_zlib_error(struct Curl_easy *data, z_stream *z) +{ + if(z->msg) + failf(data, "Error while processing content unencoding: %s", z->msg); + else + failf(data, "Error while processing content unencoding: " + "Unknown failure within decompression software."); + + return CURLE_BAD_CONTENT_ENCODING; +} + +static CURLcode exit_zlib(struct Curl_easy *data, z_stream *z, + zlibInitState *zlib_init, CURLcode result) +{ + if(*zlib_init != ZLIB_UNINIT) { + if(inflateEnd(z) != Z_OK && result == CURLE_OK) + result = process_zlib_error(data, z); + *zlib_init = ZLIB_UNINIT; + } + + return result; +} + +static CURLcode process_trailer(struct Curl_easy *data, struct zlib_writer *zp) +{ + z_stream *z = &zp->z; + CURLcode result = CURLE_OK; + uInt len = z->avail_in < zp->trailerlen ? z->avail_in : zp->trailerlen; + + /* Consume expected trailer bytes. Terminate stream if exhausted. + Issue an error if unexpected bytes follow. */ + + zp->trailerlen -= len; + z->avail_in -= len; + z->next_in += len; + if(z->avail_in) + result = CURLE_WRITE_ERROR; + if(result || !zp->trailerlen) + result = exit_zlib(data, z, &zp->zlib_init, result); + else { + /* Only occurs for gzip with zlib < 1.2.0.4 or raw deflate. */ + zp->zlib_init = ZLIB_EXTERNAL_TRAILER; + } + return result; +} + +static CURLcode inflate_stream(struct Curl_easy *data, + struct Curl_cwriter *writer, int type, + zlibInitState started) +{ + struct zlib_writer *zp = (struct zlib_writer *)writer; + z_stream *z = &zp->z; /* zlib state structure */ + uInt nread = z->avail_in; + z_const Bytef *orig_in = z->next_in; + bool done = FALSE; + CURLcode result = CURLE_OK; /* Curl_client_write status */ + int i = 0; + + /* Check state. */ + if(zp->zlib_init != ZLIB_INIT && + zp->zlib_init != ZLIB_INFLATING && + zp->zlib_init != ZLIB_INIT_GZIP) + return exit_zlib(data, z, &zp->zlib_init, CURLE_WRITE_ERROR); + + /* because the buffer size is fixed, iteratively decompress and transfer to + the client via next_write function. */ + while(!done) { + int status; /* zlib status */ + done = TRUE; + + if(++i > (1024 * 1024 / DECOMPRESS_BUFFER_SIZE)) { + /* check every MB of output if we are not exceeding time limit */ + i = 0; + if(Curl_timeleft_ms(data) < 0) { + failf(data, "Operation timed out while decoding payload"); + return exit_zlib(data, z, &zp->zlib_init, CURLE_OPERATION_TIMEDOUT); + } + } + + /* (re)set buffer for decompressed output for every iteration */ + z->next_out = (Bytef *)zp->buffer; + z->avail_out = DECOMPRESS_BUFFER_SIZE; + + status = inflate(z, Z_BLOCK); + + /* Flush output data if some. */ + if(z->avail_out != DECOMPRESS_BUFFER_SIZE) { + if(status == Z_OK || status == Z_STREAM_END) { + zp->zlib_init = started; /* Data started. */ + result = Curl_cwriter_write(data, writer->next, type, zp->buffer, + DECOMPRESS_BUFFER_SIZE - z->avail_out); + if(result) { + exit_zlib(data, z, &zp->zlib_init, result); + break; + } + } + } + + /* Dispatch by inflate() status. */ + switch(status) { + case Z_OK: + /* Always loop: there may be unflushed latched data in zlib state. */ + done = FALSE; + break; + case Z_BUF_ERROR: + /* No more data to flush: exit loop. */ + break; + case Z_STREAM_END: + result = process_trailer(data, zp); + break; + case Z_DATA_ERROR: + /* some servers seem to not generate zlib headers, so this is an attempt + to fix and continue anyway */ + if(zp->zlib_init == ZLIB_INIT) { + if(inflateReset2(z, -MAX_WBITS) == Z_OK) { + z->next_in = orig_in; + z->avail_in = nread; + zp->zlib_init = ZLIB_INFLATING; + zp->trailerlen = 4; /* Tolerate up to 4 unknown trailer bytes. */ + done = FALSE; + break; + } + zp->zlib_init = ZLIB_UNINIT; /* inflateEnd() already called. */ + } + result = exit_zlib(data, z, &zp->zlib_init, process_zlib_error(data, z)); + break; + default: + result = exit_zlib(data, z, &zp->zlib_init, process_zlib_error(data, z)); + break; + } + } + + /* We are about to leave this call so the `nread' data bytes will not be seen + again. If we are in a state that would wrongly allow restart in raw mode + at the next call, assume output has already started. */ + if(nread && zp->zlib_init == ZLIB_INIT) + zp->zlib_init = started; /* Cannot restart anymore. */ + + return result; +} + +/* Deflate handler. */ +static CURLcode deflate_do_init(struct Curl_easy *data, + struct Curl_cwriter *writer) +{ + struct zlib_writer *zp = (struct zlib_writer *)writer; + z_stream *z = &zp->z; /* zlib state structure */ + + /* Initialize zlib */ + z->zalloc = (alloc_func)zalloc_cb; + z->zfree = (free_func)zfree_cb; + + if(inflateInit(z) != Z_OK) + return process_zlib_error(data, z); + zp->zlib_init = ZLIB_INIT; + return CURLE_OK; +} + +static CURLcode deflate_do_write(struct Curl_easy *data, + struct Curl_cwriter *writer, int type, + const char *buf, size_t nbytes) +{ + struct zlib_writer *zp = (struct zlib_writer *)writer; + z_stream *z = &zp->z; /* zlib state structure */ + + if(!(type & CLIENTWRITE_BODY) || !nbytes) + return Curl_cwriter_write(data, writer->next, type, buf, nbytes); + + /* Set the compressed input when this function is called */ + z->next_in = (z_const Bytef *)buf; + z->avail_in = (uInt)nbytes; + + if(zp->zlib_init == ZLIB_EXTERNAL_TRAILER) + return process_trailer(data, zp); + + /* Now uncompress the data */ + return inflate_stream(data, writer, type, ZLIB_INFLATING); +} + +static void deflate_do_close(struct Curl_easy *data, + struct Curl_cwriter *writer) +{ + struct zlib_writer *zp = (struct zlib_writer *)writer; + z_stream *z = &zp->z; /* zlib state structure */ + + exit_zlib(data, z, &zp->zlib_init, CURLE_OK); +} + +static const struct Curl_cwtype deflate_encoding = { + "deflate", + NULL, + deflate_do_init, + deflate_do_write, + deflate_do_close, + sizeof(struct zlib_writer) +}; + +/* + * Gzip handler. + */ + +static CURLcode gzip_do_init(struct Curl_easy *data, + struct Curl_cwriter *writer) +{ + struct zlib_writer *zp = (struct zlib_writer *)writer; + z_stream *z = &zp->z; /* zlib state structure */ + + /* Initialize zlib */ + z->zalloc = (alloc_func)zalloc_cb; + z->zfree = (free_func)zfree_cb; + + if(inflateInit2(z, MAX_WBITS + 32) != Z_OK) + return process_zlib_error(data, z); + + zp->zlib_init = ZLIB_INIT_GZIP; /* Transparent gzip decompress state */ + return CURLE_OK; +} + +static CURLcode gzip_do_write(struct Curl_easy *data, + struct Curl_cwriter *writer, int type, + const char *buf, size_t nbytes) +{ + struct zlib_writer *zp = (struct zlib_writer *)writer; + z_stream *z = &zp->z; /* zlib state structure */ + + if(!(type & CLIENTWRITE_BODY) || !nbytes) + return Curl_cwriter_write(data, writer->next, type, buf, nbytes); + + if(zp->zlib_init == ZLIB_INIT_GZIP) { + /* Let zlib handle the gzip decompression entirely */ + z->next_in = (z_const Bytef *)buf; + z->avail_in = (uInt)nbytes; + /* Now uncompress the data */ + return inflate_stream(data, writer, type, ZLIB_INIT_GZIP); + } + + /* We are running with an old version: return error. */ + return exit_zlib(data, z, &zp->zlib_init, CURLE_WRITE_ERROR); +} + +static void gzip_do_close(struct Curl_easy *data, + struct Curl_cwriter *writer) +{ + struct zlib_writer *zp = (struct zlib_writer *)writer; + z_stream *z = &zp->z; /* zlib state structure */ + + exit_zlib(data, z, &zp->zlib_init, CURLE_OK); +} + +static const struct Curl_cwtype gzip_encoding = { + "gzip", + "x-gzip", + gzip_do_init, + gzip_do_write, + gzip_do_close, + sizeof(struct zlib_writer) +}; + +#endif /* HAVE_LIBZ */ + +#ifdef HAVE_BROTLI +/* Brotli writer. */ +struct brotli_writer { + struct Curl_cwriter super; + char buffer[DECOMPRESS_BUFFER_SIZE]; + BrotliDecoderState *br; /* State structure for brotli. */ +}; + +static CURLcode brotli_map_error(BrotliDecoderErrorCode be) +{ + switch(be) { + case BROTLI_DECODER_ERROR_FORMAT_EXUBERANT_NIBBLE: + case BROTLI_DECODER_ERROR_FORMAT_EXUBERANT_META_NIBBLE: + case BROTLI_DECODER_ERROR_FORMAT_SIMPLE_HUFFMAN_ALPHABET: + case BROTLI_DECODER_ERROR_FORMAT_SIMPLE_HUFFMAN_SAME: + case BROTLI_DECODER_ERROR_FORMAT_CL_SPACE: + case BROTLI_DECODER_ERROR_FORMAT_HUFFMAN_SPACE: + case BROTLI_DECODER_ERROR_FORMAT_CONTEXT_MAP_REPEAT: + case BROTLI_DECODER_ERROR_FORMAT_BLOCK_LENGTH_1: + case BROTLI_DECODER_ERROR_FORMAT_BLOCK_LENGTH_2: + case BROTLI_DECODER_ERROR_FORMAT_TRANSFORM: + case BROTLI_DECODER_ERROR_FORMAT_DICTIONARY: + case BROTLI_DECODER_ERROR_FORMAT_WINDOW_BITS: + case BROTLI_DECODER_ERROR_FORMAT_PADDING_1: + case BROTLI_DECODER_ERROR_FORMAT_PADDING_2: +#ifdef BROTLI_DECODER_ERROR_COMPOUND_DICTIONARY /* brotli v1.1.0+ */ + case BROTLI_DECODER_ERROR_COMPOUND_DICTIONARY: +#endif + case BROTLI_DECODER_ERROR_DICTIONARY_NOT_SET: + case BROTLI_DECODER_ERROR_INVALID_ARGUMENTS: + return CURLE_BAD_CONTENT_ENCODING; + case BROTLI_DECODER_ERROR_ALLOC_CONTEXT_MODES: + case BROTLI_DECODER_ERROR_ALLOC_TREE_GROUPS: + case BROTLI_DECODER_ERROR_ALLOC_CONTEXT_MAP: + case BROTLI_DECODER_ERROR_ALLOC_RING_BUFFER_1: + case BROTLI_DECODER_ERROR_ALLOC_RING_BUFFER_2: + case BROTLI_DECODER_ERROR_ALLOC_BLOCK_TYPE_TREES: + return CURLE_OUT_OF_MEMORY; + default: + break; + } + return CURLE_WRITE_ERROR; +} + +static CURLcode brotli_do_init(struct Curl_easy *data, + struct Curl_cwriter *writer) +{ + struct brotli_writer *bp = (struct brotli_writer *)writer; + (void)data; + + bp->br = BrotliDecoderCreateInstance(NULL, NULL, NULL); + return bp->br ? CURLE_OK : CURLE_OUT_OF_MEMORY; +} + +static CURLcode brotli_do_write(struct Curl_easy *data, + struct Curl_cwriter *writer, int type, + const char *buf, size_t nbytes) +{ + struct brotli_writer *bp = (struct brotli_writer *)writer; + const uint8_t *src = (const uint8_t *)buf; + uint8_t *dst; + size_t dstleft; + CURLcode result = CURLE_OK; + BrotliDecoderResult r = BROTLI_DECODER_RESULT_NEEDS_MORE_OUTPUT; + int i = 0; + + if(!(type & CLIENTWRITE_BODY) || !nbytes) + return Curl_cwriter_write(data, writer->next, type, buf, nbytes); + + if(!bp->br) + return CURLE_WRITE_ERROR; /* Stream already ended. */ + + while((nbytes || r == BROTLI_DECODER_RESULT_NEEDS_MORE_OUTPUT) && + result == CURLE_OK) { + + if(++i > (1024 * 1024 / DECOMPRESS_BUFFER_SIZE)) { + /* check every MB of output if we are not exceeding time limit */ + i = 0; + if(Curl_timeleft_ms(data) < 0) { + failf(data, "Operation timed out while decoding payload"); + return CURLE_OPERATION_TIMEDOUT; + } + } + + dst = (uint8_t *)bp->buffer; + dstleft = DECOMPRESS_BUFFER_SIZE; + r = BrotliDecoderDecompressStream(bp->br, + &nbytes, &src, &dstleft, &dst, NULL); + result = Curl_cwriter_write(data, writer->next, type, + bp->buffer, DECOMPRESS_BUFFER_SIZE - dstleft); + if(result) + break; + switch(r) { + case BROTLI_DECODER_RESULT_NEEDS_MORE_OUTPUT: + case BROTLI_DECODER_RESULT_NEEDS_MORE_INPUT: + break; + case BROTLI_DECODER_RESULT_SUCCESS: + BrotliDecoderDestroyInstance(bp->br); + bp->br = NULL; + if(nbytes) + result = CURLE_WRITE_ERROR; + break; + default: + result = brotli_map_error(BrotliDecoderGetErrorCode(bp->br)); + break; + } + } + return result; +} + +static void brotli_do_close(struct Curl_easy *data, + struct Curl_cwriter *writer) +{ + struct brotli_writer *bp = (struct brotli_writer *)writer; + (void)data; + + if(bp->br) { + BrotliDecoderDestroyInstance(bp->br); + bp->br = NULL; + } +} + +static const struct Curl_cwtype brotli_encoding = { + "br", + NULL, + brotli_do_init, + brotli_do_write, + brotli_do_close, + sizeof(struct brotli_writer) +}; +#endif + +#ifdef HAVE_ZSTD +/* Zstd writer. */ +struct zstd_writer { + struct Curl_cwriter super; + ZSTD_DStream *zds; /* State structure for zstd. */ + char buffer[DECOMPRESS_BUFFER_SIZE]; +}; + +#ifdef ZSTD_STATIC_LINKING_ONLY +static void *Curl_zstd_alloc(void *opaque, size_t size) +{ + (void)opaque; + return Curl_cmalloc(size); +} + +static void Curl_zstd_free(void *opaque, void *address) +{ + (void)opaque; + Curl_cfree(address); +} +#endif + +static CURLcode zstd_do_init(struct Curl_easy *data, + struct Curl_cwriter *writer) +{ + struct zstd_writer *zp = (struct zstd_writer *)writer; + + (void)data; + +#ifdef ZSTD_STATIC_LINKING_ONLY + zp->zds = ZSTD_createDStream_advanced((ZSTD_customMem) { + .customAlloc = Curl_zstd_alloc, + .customFree = Curl_zstd_free, + .opaque = NULL + }); +#else + zp->zds = ZSTD_createDStream(); +#endif + + return zp->zds ? CURLE_OK : CURLE_OUT_OF_MEMORY; +} + +static CURLcode zstd_do_write(struct Curl_easy *data, + struct Curl_cwriter *writer, int type, + const char *buf, size_t nbytes) +{ + CURLcode result = CURLE_OK; + struct zstd_writer *zp = (struct zstd_writer *)writer; + ZSTD_inBuffer in; + ZSTD_outBuffer out; + size_t errorCode; + int i = 0; + + if(!(type & CLIENTWRITE_BODY) || !nbytes) + return Curl_cwriter_write(data, writer->next, type, buf, nbytes); + + in.pos = 0; + in.src = buf; + in.size = nbytes; + + for(;;) { + if(++i > (1024 * 1024 / DECOMPRESS_BUFFER_SIZE)) { + /* check every MB of output if we are not exceeding time limit */ + i = 0; + if(Curl_timeleft_ms(data) < 0) { + failf(data, "Operation timed out while decoding payload"); + return CURLE_OPERATION_TIMEDOUT; + } + } + + out.pos = 0; + out.dst = zp->buffer; + out.size = DECOMPRESS_BUFFER_SIZE; + + errorCode = ZSTD_decompressStream(zp->zds, &out, &in); + if(ZSTD_isError(errorCode)) { + return CURLE_BAD_CONTENT_ENCODING; + } + if(out.pos > 0) { + result = Curl_cwriter_write(data, writer->next, type, + zp->buffer, out.pos); + if(result) + break; + } + if((in.pos == nbytes) && (out.pos < out.size)) + break; + } + + return result; +} + +static void zstd_do_close(struct Curl_easy *data, + struct Curl_cwriter *writer) +{ + struct zstd_writer *zp = (struct zstd_writer *)writer; + (void)data; + + if(zp->zds) { + ZSTD_freeDStream(zp->zds); + zp->zds = NULL; + } +} + +static const struct Curl_cwtype zstd_encoding = { + "zstd", + NULL, + zstd_do_init, + zstd_do_write, + zstd_do_close, + sizeof(struct zstd_writer) +}; +#endif + +/* Identity handler. */ +static const struct Curl_cwtype identity_encoding = { + "identity", + "none", + Curl_cwriter_def_init, + Curl_cwriter_def_write, + Curl_cwriter_def_close, + sizeof(struct Curl_cwriter) +}; + +/* supported general content decoders. */ +static const struct Curl_cwtype * const general_unencoders[] = { + &identity_encoding, +#ifdef HAVE_LIBZ + &deflate_encoding, + &gzip_encoding, +#endif +#ifdef HAVE_BROTLI + &brotli_encoding, +#endif +#ifdef HAVE_ZSTD + &zstd_encoding, +#endif + NULL +}; + +/* supported content decoders only for transfer encodings */ +static const struct Curl_cwtype * const transfer_unencoders[] = { + &Curl_httpchunk_unencoder, + NULL +}; + +/* Return the list of comma-separated names of supported encodings. + */ +char *Curl_get_content_encodings(void) +{ + struct dynbuf enc; + const struct Curl_cwtype * const *cep; + CURLcode result = CURLE_OK; + curlx_dyn_init(&enc, 255); + + for(cep = general_unencoders; *cep && !result; cep++) { + const struct Curl_cwtype *ce = *cep; + if(!curl_strequal(ce->name, CONTENT_ENCODING_DEFAULT)) { + if(curlx_dyn_len(&enc)) + result = curlx_dyn_addn(&enc, ", ", 2); + if(!result) + result = curlx_dyn_add(&enc, ce->name); + } + } + if(!result && !curlx_dyn_len(&enc)) + result = curlx_dyn_add(&enc, CONTENT_ENCODING_DEFAULT); + + if(!result) + return curlx_dyn_ptr(&enc); + return NULL; +} + +/* Deferred error dummy writer. */ +static CURLcode error_do_init(struct Curl_easy *data, + struct Curl_cwriter *writer) +{ + (void)data; + (void)writer; + return CURLE_OK; +} + +static CURLcode error_do_write(struct Curl_easy *data, + struct Curl_cwriter *writer, int type, + const char *buf, size_t nbytes) +{ + (void)writer; + (void)buf; + (void)nbytes; + + if(!(type & CLIENTWRITE_BODY) || !nbytes) + return Curl_cwriter_write(data, writer->next, type, buf, nbytes); + failf(data, "Unrecognized content encoding type"); + return CURLE_BAD_CONTENT_ENCODING; +} + +static void error_do_close(struct Curl_easy *data, + struct Curl_cwriter *writer) +{ + (void)data; + (void)writer; +} + +static const struct Curl_cwtype error_writer = { + "ce-error", + NULL, + error_do_init, + error_do_write, + error_do_close, + sizeof(struct Curl_cwriter) +}; + +/* Find the content encoding by name. */ +static const struct Curl_cwtype *find_unencode_writer(const char *name, + size_t len, + Curl_cwriter_phase phase) +{ + const struct Curl_cwtype * const *cep; + + if(phase == CURL_CW_TRANSFER_DECODE) { + for(cep = transfer_unencoders; *cep; cep++) { + const struct Curl_cwtype *ce = *cep; + if((curl_strnequal(name, ce->name, len) && !ce->name[len]) || + (ce->alias && curl_strnequal(name, ce->alias, len) && + !ce->alias[len])) + return ce; + } + } + /* look among the general decoders */ + for(cep = general_unencoders; *cep; cep++) { + const struct Curl_cwtype *ce = *cep; + if((curl_strnequal(name, ce->name, len) && !ce->name[len]) || + (ce->alias && curl_strnequal(name, ce->alias, len) && !ce->alias[len])) + return ce; + } + return NULL; +} + +/* Setup the unencoding stack from the Content-Encoding header value. + * See RFC 7231 section 3.1.2.2. */ +CURLcode Curl_build_unencoding_stack(struct Curl_easy *data, + const char *enclist, int is_transfer) +{ + Curl_cwriter_phase phase = is_transfer ? + CURL_CW_TRANSFER_DECODE : CURL_CW_CONTENT_DECODE; + CURLcode result; + bool has_chunked = FALSE; + + do { + const char *name; + size_t namelen; + bool is_chunked = FALSE; + + /* Parse a single encoding name. */ + while(ISBLANK(*enclist) || *enclist == ',') + enclist++; + + name = enclist; + + for(namelen = 0; *enclist && *enclist != ','; enclist++) + if(*enclist > ' ') + namelen = enclist - name + 1; + + if(namelen) { + const struct Curl_cwtype *cwt; + struct Curl_cwriter *writer; + + CURL_TRC_WRITE(data, "looking for %s decoder: %.*s", + is_transfer ? "transfer" : "content", (int)namelen, name); + is_chunked = (is_transfer && (namelen == 7) && + curl_strnequal(name, "chunked", 7)); + /* if we skip the decoding in this phase, do not look further. + * Exception is "chunked" transfer-encoding which always must happen */ + if((is_transfer && !data->set.http_transfer_encoding && !is_chunked) || + (!is_transfer && data->set.http_ce_skip)) { + bool is_identity = curl_strnequal(name, "identity", 8); + /* not requested, ignore */ + CURL_TRC_WRITE(data, "decoder not requested, ignored: %.*s", + (int)namelen, name); + if(is_transfer && !data->set.http_te_skip) { + if(has_chunked) + failf(data, "A Transfer-Encoding (%.*s) was listed after chunked", + (int)namelen, name); + else if(is_identity) + continue; + else + failf(data, "Unsolicited Transfer-Encoding (%.*s) found", + (int)namelen, name); + return CURLE_BAD_CONTENT_ENCODING; + } + return CURLE_OK; + } + + if(Curl_cwriter_count(data, phase) >= MAX_ENCODE_STACK) { + failf(data, "Reject response exceeding limit of %d %s encodings", + MAX_ENCODE_STACK, + is_transfer ? "transfer" : "content"); + return CURLE_BAD_CONTENT_ENCODING; + } + + cwt = find_unencode_writer(name, namelen, phase); + if(is_transfer && !is_chunked && + Curl_cwriter_get_by_name(data, "chunked")) { + /* RFC 9112, ch. 6.1: + * "If any transfer coding other than chunked is applied to a + * response's content, the sender MUST either apply chunked as the + * final transfer coding or terminate the message by closing the + * connection." + * "chunked" must be the last added to be the first in its phase, + * reject this. + */ + failf(data, "Reject response due to 'chunked' not being the last " + "Transfer-Encoding"); + return CURLE_BAD_CONTENT_ENCODING; + } + if(cwt && is_chunked && Curl_cwriter_get_by_type(data, cwt)) { + /* A 'chunked' transfer encoding has already been added. + * Ignore duplicates. See #13451. + * Also RFC 9112, ch. 6.1: + * "A sender MUST NOT apply the chunked transfer coding more than + * once to a message body." + */ + CURL_TRC_WRITE(data, "ignoring duplicate 'chunked' decoder"); + } + else { + if(!cwt) + cwt = &error_writer; /* Defer error at use. */ + + result = Curl_cwriter_create(&writer, data, cwt, phase); + CURL_TRC_WRITE(data, "added %s decoder %s -> %d", + is_transfer ? "transfer" : "content", cwt->name, + (int)result); + if(result) + return result; + + result = Curl_cwriter_add(data, writer); + if(result) { + Curl_cwriter_free(data, writer); + return result; + } + } + if(is_chunked) + has_chunked = TRUE; + } + } while(*enclist); + + return CURLE_OK; +} + +#else +/* Stubs for builds without HTTP. */ +CURLcode Curl_build_unencoding_stack(struct Curl_easy *data, + const char *enclist, int is_transfer) +{ + (void)data; + (void)enclist; + (void)is_transfer; + return CURLE_NOT_BUILT_IN; +} + +char *Curl_get_content_encodings(void) +{ + return curlx_strdup(CONTENT_ENCODING_DEFAULT); +} + +#endif /* CURL_DISABLE_HTTP */ diff --git a/3rdparty/curl-8.21.0/lib/content_encoding.h b/3rdparty/curl-8.21.0/lib/content_encoding.h new file mode 100644 index 0000000000..e84a739761 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/content_encoding.h @@ -0,0 +1,35 @@ +#ifndef HEADER_CURL_CONTENT_ENCODING_H +#define HEADER_CURL_CONTENT_ENCODING_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +struct Curl_cwriter; + +/* returns an allocated string or NULL */ +char *Curl_get_content_encodings(void); + +CURLcode Curl_build_unencoding_stack(struct Curl_easy *data, + const char *enclist, int is_transfer); +#endif /* HEADER_CURL_CONTENT_ENCODING_H */ diff --git a/3rdparty/curl-8.21.0/lib/cookie.c b/3rdparty/curl-8.21.0/lib/cookie.c new file mode 100644 index 0000000000..91dc8d5fd0 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/cookie.c @@ -0,0 +1,1684 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_HTTP) && !defined(CURL_DISABLE_COOKIES) + +#include "urldata.h" +#include "cookie.h" +#include "psl.h" +#include "curl_trc.h" +#include "transfer.h" +#include "slist.h" +#include "curl_share.h" +#include "strcase.h" +#include "curl_fopen.h" +#include "curl_get_line.h" +#include "curl_memrchr.h" +#include "parsedate.h" +#include "curlx/strdup.h" +#include "llist.h" +#include "curlx/strparse.h" + +/* number of seconds in 400 days */ +#define COOKIES_MAXAGE (400 * 24 * 3600) + +/* Make sure cookies never expire further away in time than 400 days into the + future. (from RFC6265bis draft-19) + + For the sake of easier testing, align the capped time to an even 60 second + boundary. +*/ +static void cap_expires(time_t now, struct Cookie *co) +{ + if(co->expires && (TIME_T_MAX - COOKIES_MAXAGE - 30) > now) { + timediff_t cap = now + COOKIES_MAXAGE; + if(co->expires > cap) { + cap += 30; + co->expires = (cap / 60) * 60; + } + } +} + +static void freecookie(struct Cookie *co, bool maintoo) +{ + curlx_free(co->domain); + curlx_free(co->path); + curlx_free(co->name); + curlx_free(co->value); + if(maintoo) + curlx_free(co); +} + +static bool cookie_tailmatch(const char *cookie_domain, + const size_t cookie_domain_len, + const char *hostname) +{ + size_t hostname_len = strlen(hostname); + + if(hostname_len < cookie_domain_len) + return FALSE; + + if(!curl_strnequal(cookie_domain, + hostname + hostname_len - cookie_domain_len, + cookie_domain_len)) + return FALSE; + + /* + * A lead char of cookie_domain is not '.'. + * RFC6265 4.1.2.3. The Domain Attribute says: + * For example, if the value of the Domain attribute is + * "example.com", the user agent will include the cookie in the Cookie + * header when making HTTP requests to example.com, www.example.com, and + * www.corp.example.com. + */ + if(hostname_len == cookie_domain_len) + return TRUE; + if('.' == *(hostname + hostname_len - cookie_domain_len - 1)) + return TRUE; + return FALSE; +} + +/* + * matching cookie path and URL path + * RFC6265 5.1.4 Paths and Path-Match + */ +static bool pathmatch(const char *cookie_path, const char *uri_path) +{ + size_t cookie_path_len; + size_t uri_path_len; + bool ret = FALSE; + + /* cookie_path must not have last '/' separator. ex: /sample */ + cookie_path_len = strlen(cookie_path); + if(cookie_path_len == 1) { + /* cookie_path must be '/' */ + return TRUE; + } + + /* #-fragments are already cut off! */ + if(strlen(uri_path) == 0 || uri_path[0] != '/') + uri_path = "/"; + + /* + * here, RFC6265 5.1.4 says + * 4. Output the characters of the uri-path from the first character up + * to, but not including, the right-most %x2F ("/"). + * but URL path /hoge?fuga=xxx means /hoge/index.cgi?fuga=xxx in some site + * without redirect. + * Ignore this algorithm because /hoge is uri path for this case + * (uri path is not /). + */ + + uri_path_len = strlen(uri_path); + + if(uri_path_len < cookie_path_len) + goto pathmatched; + + /* not using checkprefix() because matching should be case-sensitive */ + if(strncmp(cookie_path, uri_path, cookie_path_len)) + goto pathmatched; + + /* The cookie-path and the uri-path are identical. */ + if(cookie_path_len == uri_path_len) { + ret = TRUE; + goto pathmatched; + } + + /* here, cookie_path_len < uri_path_len */ + if(uri_path[cookie_path_len] == '/') { + ret = TRUE; + goto pathmatched; + } + +pathmatched: + return ret; +} + +/* + * Return the top-level domain, for optimal hashing. + */ +static const char *get_top_domain(const char * const domain, size_t *outlen) +{ + size_t len = 0; + const char *first = NULL, *last; + + if(domain) { + len = strlen(domain); + last = memrchr(domain, '.', len); + if(last) { + first = memrchr(domain, '.', (last - domain)); + if(first) + len -= (++first - domain); + } + } + + if(outlen) + *outlen = len; + + return first ? first : domain; +} + +/* Avoid C1001, an "internal error" with MSVC14 */ +#if defined(_MSC_VER) && (_MSC_VER == 1900) +#pragma optimize("", off) +#endif + +/* + * A case-insensitive hash for the cookie domains. + */ +static size_t cookie_hash_domain(const char *domain, const size_t len) +{ + const char *end = domain + len; + size_t h = 5381; + + while(domain < end) { + size_t j = (size_t)Curl_raw_toupper(*domain++); + h += h << 5; + h ^= j; + } + + return (h % COOKIE_HASH_SIZE); +} + +#if defined(_MSC_VER) && (_MSC_VER == 1900) +#pragma optimize("", on) +#endif + +/* + * Hash this domain. + */ +static size_t cookiehash(const char * const domain) +{ + const char *top; + size_t len; + + if(!domain || Curl_host_is_ipnum(domain)) + return 0; + + top = get_top_domain(domain, &len); + return cookie_hash_domain(top, len); +} + +/* + * cookie path sanitize + */ +static char *sanitize_cookie_path(const char *cookie_path, size_t len) +{ + /* some sites send path attribute within '"'. */ + if(len && (cookie_path[0] == '\"')) { + cookie_path++; + len--; + + if(len && (cookie_path[len - 1] == '\"')) + len--; + } + + /* RFC6265 5.2.4 The Path Attribute */ + if(!len || (cookie_path[0] != '/')) + /* Let cookie-path be the default-path. */ + return curlx_strdup("/"); + + /* remove trailing slash when path is non-empty */ + /* convert /hoge/ to /hoge */ + if(len > 1 && cookie_path[len - 1] == '/') + len--; + + return curlx_memdup0(cookie_path, len); +} + +/* + * strstore + * + * A thin wrapper around curlx_memdup0(). + */ +static CURLcode strstore(char **str, const char *newstr, size_t len) +{ + DEBUGASSERT(str); + *str = curlx_memdup0(newstr, len); + if(!*str) + return CURLE_OUT_OF_MEMORY; + return CURLE_OK; +} + +/* + * remove_expired + * + * Remove expired cookies from the hash by inspecting the expires timestamp on + * each cookie in the hash, freeing and deleting any where the timestamp is in + * the past. If the cookiejar has recorded the next timestamp at which one or + * more cookies expire, then processing will exit early in case this timestamp + * is in the future. + */ +static void remove_expired(struct CookieInfo *ci) +{ + struct Cookie *co; + curl_off_t now = (curl_off_t)time(NULL); + unsigned int i; + + /* + * If the earliest expiration timestamp in the jar is in the future we can + * skip scanning the whole jar and instead exit early as there will not be + * any cookies to evict. If we need to evict, reset the next_expiration + * counter in order to track the next one. In case the recorded first + * expiration is the max offset, then perform the safe fallback of checking + * all cookies. + */ + if(now < ci->next_expiration && + ci->next_expiration != CURL_OFF_T_MAX) + return; + else + ci->next_expiration = CURL_OFF_T_MAX; + + for(i = 0; i < COOKIE_HASH_SIZE; i++) { + struct Curl_llist_node *n; + struct Curl_llist_node *e = NULL; + + for(n = Curl_llist_head(&ci->cookielist[i]); n; n = e) { + co = Curl_node_elem(n); + e = Curl_node_next(n); + if(co->expires) { + if(co->expires < now) { + Curl_node_remove(n); + freecookie(co, TRUE); + ci->numcookies--; + } + else if(co->expires < ci->next_expiration) + /* + * If this cookie has an expiration timestamp earlier than what we + * have seen so far then record it for the next round of expirations. + */ + ci->next_expiration = co->expires; + } + } + } +} + +#ifndef USE_LIBPSL +/* Make sure domain contains a dot or is localhost. */ +static bool bad_domain(const char *domain, size_t len) +{ + if((len == 9) && curl_strnequal(domain, "localhost", 9)) + return FALSE; + else { + /* there must be a dot present, but that dot must not be a trailing dot */ + const char *dot = memchr(domain, '.', len); + if(dot) { + size_t i = dot - domain; + if((len - i) > 1) + /* the dot is not the last byte */ + return FALSE; + } + } + return TRUE; +} +#endif + +/* + RFC 6265 section 4.1.1 says a server should accept this range: + + cookie-octet = %x21 / %x23-2B / %x2D-3A / %x3C-5B / %x5D-7E + + Yet, Firefox and Chrome as of June 2022 accept space, comma and double-quotes + fine. The prime reason for filtering out control bytes is that some HTTP + servers return 400 for requests that contain such. +*/ +static bool invalid_octets(const char *ptr, size_t len) +{ + const unsigned char *p = (const unsigned char *)ptr; + /* Reject all bytes \x01 - \x1f + \x7f */ + while(len && *p) { + if((*p < 0x20) || (*p == 0x7f)) + return TRUE; + p++; + len--; + } + return FALSE; +} + +/* The maximum length we accept a date string for the 'expire' keyword. The + standard date formats are within the 30 bytes range. This adds an extra + margin to make sure it realistically works with what is used out there. +*/ +#define MAX_DATE_LENGTH 80 + +#define COOKIE_NAME 0 +#define COOKIE_VALUE 1 +#define COOKIE_DOMAIN 2 +#define COOKIE_PATH 3 + +#define COOKIE_PIECES 4 /* the list above */ + +static CURLcode storecookie(struct Cookie *co, const struct Curl_str *cp, + const char *path, const char *domain) +{ + CURLcode result; + result = strstore(&co->name, curlx_str(&cp[COOKIE_NAME]), + curlx_strlen(&cp[COOKIE_NAME])); + if(!result) + result = strstore(&co->value, curlx_str(&cp[COOKIE_VALUE]), + curlx_strlen(&cp[COOKIE_VALUE])); + if(!result) { + size_t plen = 0; + if(curlx_strlen(&cp[COOKIE_PATH])) { + path = curlx_str(&cp[COOKIE_PATH]); + plen = curlx_strlen(&cp[COOKIE_PATH]); + } + else if(path) { + /* No path was given in the header line, set the default */ + const char *endslash = strrchr(path, '/'); + if(endslash) + plen = endslash - path + 1; /* include end slash */ + else + plen = strlen(path); + } + + if(path) { + co->path = sanitize_cookie_path(path, plen); + if(!co->path) + result = CURLE_OUT_OF_MEMORY; + } + } + if(!result) { + if(curlx_strlen(&cp[COOKIE_DOMAIN])) + result = strstore(&co->domain, curlx_str(&cp[COOKIE_DOMAIN]), + curlx_strlen(&cp[COOKIE_DOMAIN])); + else if(domain) { + /* no domain was given in the header line, set the default */ + co->domain = curlx_strdup(domain); + if(!co->domain) + result = CURLE_OUT_OF_MEMORY; + } + } + return result; +} + +/* + * Parse the first name/value pair of the cookie header, which is the actual + * cookie name and value. + */ +static bool parse_first_pair(struct Curl_easy *data, struct Cookie *co, + struct Curl_str *cookie, + struct Curl_str *name, + struct Curl_str *val, + bool sep) +{ + /* The first name/value pair is the actual cookie name */ + if(!sep || !curlx_strlen(name)) { + infof(data, "invalid cookie, dropped"); + return FALSE; + } + + /* + * Check for too long individual name or contents. Chrome and Firefox + * support 4095 or 4096 bytes combo + */ + if((curlx_strlen(name) + curlx_strlen(val)) > MAX_NAME) { + infof(data, "oversized cookie dropped, name/val %zu + %zu bytes", + curlx_strlen(name), curlx_strlen(val)); + return FALSE; + } + + /* Check if we have a reserved prefix set. */ + if(!strncmp("__Secure-", curlx_str(name), 9)) + co->prefix_secure = TRUE; + else if(!strncmp("__Host-", curlx_str(name), 7)) + co->prefix_host = TRUE; + + cookie[COOKIE_NAME] = *name; + cookie[COOKIE_VALUE] = *val; + return TRUE; +} + +static bool parse_flag(struct Curl_easy *data, struct Cookie *co, + const struct CookieInfo *ci, + struct Curl_str *name, bool secure) +{ + /* + * secure cookies are only allowed to be set when the connection is + * using a secure protocol, or when the cookie is being set by + * reading from file + */ + if(curlx_str_casecompare(name, "secure")) { + if(secure || !ci->running) + co->secure = TRUE; + else { + infof(data, "skipped cookie because not 'secure'"); + return FALSE; + } + } + else if(curlx_str_casecompare(name, "httponly")) + co->httponly = TRUE; + + return TRUE; +} + +static bool parse_domain(struct Curl_easy *data, struct Cookie *co, + struct Curl_str *cookie_domain, + struct Curl_str *val, + const char **domainp) +{ + bool is_ip; + const char *domain = *domainp; + const char *v = curlx_str(val); + /* + * Now, we make sure that our host is within the given domain, or + * the given domain is not valid and thus cannot be set. + */ + + if('.' == *v) + curlx_str_nudge(val, 1); + +#ifndef USE_LIBPSL + /* + * Without PSL we do not know when the incoming cookie is set on a + * TLD or otherwise "protected" suffix. To reduce risk, we require a + * dot OR the exact hostname being "localhost". + */ + if(bad_domain(curlx_str(val), curlx_strlen(val))) { + *domainp = ":"; + domain = ":"; + } +#endif + + is_ip = Curl_host_is_ipnum(domain ? domain : curlx_str(val)); + + if(!domain || + (is_ip && + !strncmp(curlx_str(val), domain, curlx_strlen(val)) && + (curlx_strlen(val) == strlen(domain))) || + (!is_ip && cookie_tailmatch(curlx_str(val), + curlx_strlen(val), domain))) { + *cookie_domain = *val; + if(!is_ip) + co->tailmatch = TRUE; /* we always do that if the domain name was + given */ + } + else { + /* + * We did not get a tailmatch and then the attempted set domain is + * not a domain to which the current host belongs. Mark as bad. + */ + infof(data, "skipped cookie with bad tailmatch domain: %s", + curlx_str(val)); + return FALSE; + } + return TRUE; +} + +static void parse_maxage(struct Cookie *co, struct Curl_str *val, + time_t *nowp) +{ + int rc; + const char *maxage = curlx_str(val); + if(*maxage == '\"') + maxage++; + rc = curlx_str_number(&maxage, &co->expires, CURL_OFF_T_MAX); + if(!*nowp) + *nowp = time(NULL); + switch(rc) { + case STRE_OVERFLOW: + /* overflow, used max value */ + co->expires = CURL_OFF_T_MAX; + break; + default: + /* negative or otherwise bad, expire */ + co->expires = 1; + break; + case STRE_OK: + if(!co->expires) + co->expires = 1; /* expire now */ + else if(CURL_OFF_T_MAX - *nowp < co->expires) + /* would overflow */ + co->expires = CURL_OFF_T_MAX; + else + co->expires += *nowp; + break; + } + cap_expires(*nowp, co); +} + +static void parse_expires(struct Cookie *co, struct Curl_str *val, + time_t *nowp) +{ + /* + * Let max-age have priority. + * + * If the date cannot get parsed for whatever reason, the cookie + * will be treated as a session cookie + */ + if(!co->expires && (curlx_strlen(val) < MAX_DATE_LENGTH)) { + char dbuf[MAX_DATE_LENGTH + 1]; + time_t date = 0; + memcpy(dbuf, curlx_str(val), curlx_strlen(val)); + dbuf[curlx_strlen(val)] = 0; + if(!Curl_getdate_capped(dbuf, &date)) { + if(!date) + date++; + co->expires = (curl_off_t)date; + } + else + co->expires = 0; + if(!*nowp) + *nowp = time(NULL); + cap_expires(*nowp, co); + } +} + +/* this function returns errors on OOM etc, not for cookie format problems */ +static CURLcode +parse_cookie_header(struct Curl_easy *data, + struct Cookie *co, + const struct CookieInfo *ci, + bool *okay, /* if the cookie was fine */ + const char *ptr, /* the header */ + const char *domain, /* default domain */ + /* full path used when this cookie is set */ + const char *path, + bool secure_origin) +{ + /* This line was read off an HTTP-header */ + time_t now = 0; + size_t linelength = strlen(ptr); + CURLcode result = CURLE_OK; + struct Curl_str cookie[COOKIE_PIECES]; + *okay = FALSE; + if(linelength > MAX_COOKIE_LINE) + /* discard overly long lines at once */ + return CURLE_OK; + + /* memset instead of initializer because gcc 4.8.1 is silly */ + memset(cookie, 0, sizeof(cookie)); + do { + struct Curl_str name; + + /* we have a = pair or a stand-alone word here */ + if(!curlx_str_cspn(&ptr, &name, ";\t\r\n=")) { + struct Curl_str val; + bool sep = FALSE; + curlx_str_trimblanks(&name); + + if(invalid_octets(curlx_str(&name), curlx_strlen(&name))) { + infof(data, "invalid octets in name, cookie dropped"); + return CURLE_OK; + } + + if(!curlx_str_single(&ptr, '=')) { + sep = TRUE; /* a '=' was used */ + if(!curlx_str_cspn(&ptr, &val, ";\r\n")) + curlx_str_trimblanks(&val); + + if(invalid_octets(curlx_str(&val), curlx_strlen(&val))) { + infof(data, "invalid octets in value, cookie dropped"); + return CURLE_OK; + } + } + else + curlx_str_init(&val); + + if(!curlx_strlen(&cookie[COOKIE_NAME])) { + if(!parse_first_pair(data, co, cookie, &name, &val, sep)) + return CURLE_OK; + } + else if(!sep) { + if(!parse_flag(data, co, ci, &name, secure_origin)) + return CURLE_OK; + } + else if(curlx_str_casecompare(&name, "path")) + cookie[COOKIE_PATH] = val; + else if(curlx_str_casecompare(&name, "domain") && curlx_strlen(&val)) { + if(!parse_domain(data, co, &cookie[COOKIE_DOMAIN], &val, &domain)) + return CURLE_OK; + } + else if(curlx_str_casecompare(&name, "max-age") && curlx_strlen(&val)) + parse_maxage(co, &val, &now); + else if(curlx_str_casecompare(&name, "expires") && curlx_strlen(&val)) + parse_expires(co, &val, &now); + } + } while(!curlx_str_single(&ptr, ';')); + + if(curlx_strlen(&cookie[COOKIE_NAME])) { + /* the header was fine, now store the data */ + result = storecookie(co, &cookie[0], path, domain); + if(!result) + *okay = TRUE; + } + return result; +} + +static CURLcode parse_netscape(struct Cookie *co, + const struct CookieInfo *ci, + bool *okay, + const char *lineptr, + bool secure_origin) +{ + /* + * This line is NOT an HTTP header style line, we do offer support for + * reading the odd netscape cookies-file format here + */ + const char *ptr, *next; + int fields; + size_t len; + *okay = FALSE; + + /* + * In 2008, Internet Explorer introduced HTTP-only cookies to prevent XSS + * attacks. Cookies marked httpOnly are not accessible to JavaScript. In + * Firefox's cookie files, they are prefixed #HttpOnly_ and the rest + * remains as usual, so we skip 10 characters of the line. + */ + if(!strncmp(lineptr, "#HttpOnly_", 10)) { + lineptr += 10; + co->httponly = TRUE; + } + + if(lineptr[0] == '#') + /* do not even try the comments */ + return CURLE_OK; + + /* + * Now loop through the fields and init the struct we already have + * allocated + */ + fields = 0; + for(next = lineptr; next; fields++) { + ptr = next; + len = strcspn(ptr, "\t\r\n"); + next = (ptr[len] == '\t' ? &ptr[len + 1] : NULL); + switch(fields) { + case 0: + if(ptr[0] == '.') { /* skip preceding dots */ + ptr++; + len--; + } + co->domain = curlx_memdup0(ptr, len); + if(!co->domain) + return CURLE_OUT_OF_MEMORY; + break; + case 1: + /* + * flag: A TRUE/FALSE value indicating if all machines within a given + * domain can access the variable. Set TRUE when the cookie says + * .example.com and to false when the domain is complete www.example.com + */ + co->tailmatch = !!curl_strnequal(ptr, "TRUE", len); + break; + case 2: + /* The file format allows the path field to remain not filled in */ + if(strncmp("TRUE", ptr, len) && strncmp("FALSE", ptr, len)) { + /* only if the path does not look like a boolean option! */ + co->path = sanitize_cookie_path(ptr, len); + if(!co->path) + return CURLE_OUT_OF_MEMORY; + break; + } + else { + /* this does not look like a path, make one up! */ + co->path = curlx_strdup("/"); + if(!co->path) + return CURLE_OUT_OF_MEMORY; + } + fields++; /* add a field and fall down to secure */ + FALLTHROUGH(); + case 3: + co->secure = FALSE; + if(curl_strnequal(ptr, "TRUE", len)) { + if(secure_origin || ci->running) + co->secure = TRUE; + else + return CURLE_OK; + } + break; + case 4: + if(curlx_str_number(&ptr, &co->expires, CURL_OFF_T_MAX)) + return CURLE_OK; + break; + case 5: + co->name = curlx_memdup0(ptr, len); + if(!co->name) + return CURLE_OUT_OF_MEMORY; + else { + /* For Netscape file format cookies we check prefix on the name. + These prefixes are matched case sensitively, same as on the + header path and as the 6265bis document specifies. */ + if(!strncmp("__Secure-", co->name, 9)) + co->prefix_secure = TRUE; + else if(!strncmp("__Host-", co->name, 7)) + co->prefix_host = TRUE; + } + break; + case 6: + co->value = curlx_memdup0(ptr, len); + if(!co->value) + return CURLE_OUT_OF_MEMORY; + break; + } + } + if(fields == 6) { + /* we got a cookie with blank contents, fix it */ + co->value = curlx_strdup(""); + if(!co->value) + return CURLE_OUT_OF_MEMORY; + else + fields++; + } + + if(fields != 7) + /* we did not find the sufficient number of fields */ + return CURLE_OK; + + /* Reject control octets in the name or value, matching the filtering done + for cookies set over HTTP. A cookie loaded from a file is later sent in + request headers, so the same bytes that make a server reject a request + must not slip in through the file. */ + if(invalid_octets(co->name, strlen(co->name)) || + invalid_octets(co->value, strlen(co->value))) + return CURLE_OK; + + *okay = TRUE; + return CURLE_OK; +} + +static bool is_public_suffix(struct Curl_easy *data, + const struct Cookie *co, + const char *domain) +{ +#ifdef USE_LIBPSL + /* + * Check if the domain is a Public Suffix and if yes, ignore the cookie. We + * must also check that the data handle is not NULL since the psl code will + * dereference it. + */ + DEBUGF(infof(data, "PSL check set-cookie '%s' for domain=%s in %s", + co->name, co->domain, domain)); + if(data && (domain && co->domain && !Curl_host_is_ipnum(co->domain))) { + bool acceptable = FALSE; + char lcase[256]; + char lcookie[256]; + size_t dlen = strlen(domain); + size_t clen = strlen(co->domain); + + /* trim trailing dots */ + if(dlen && (domain[dlen - 1] == '.')) + dlen--; + if(clen && (co->domain[clen - 1] == '.')) + clen--; + + if((dlen < sizeof(lcase)) && (clen < sizeof(lcookie))) { + const psl_ctx_t *psl = Curl_psl_use(data); + if(psl) { + /* the PSL check requires lowercase domain name and pattern */ + Curl_strntolower(lcase, domain, dlen); + lcase[dlen] = 0; + Curl_strntolower(lcookie, co->domain, clen); + lcookie[clen] = 0; + acceptable = psl_is_cookie_domain_acceptable(psl, lcase, lcookie); + Curl_psl_release(data); + } + else + infof(data, "libpsl problem, rejecting cookie for safety"); + } + + if(!acceptable) { + infof(data, "cookie '%s' dropped, domain '%s' must not " + "set cookies for '%s'", co->name, domain, co->domain); + return TRUE; + } + } +#else + (void)data; + (void)co; + (void)domain; + DEBUGF(infof(data, "NO PSL to check set-cookie '%s' for domain=%s in %s", + co->name, co->domain, domain)); +#endif + return FALSE; +} + +/* returns TRUE when replaced */ +static bool replace_existing(struct Curl_easy *data, + struct Cookie *co, + const struct CookieInfo *ci, + bool secure, + bool *replacep) +{ + bool replace_old = FALSE; + struct Curl_llist_node *replace_n = NULL; + struct Curl_llist_node *n; + size_t myhash = cookiehash(co->domain); + for(n = Curl_llist_head(&ci->cookielist[myhash]); n; n = Curl_node_next(n)) { + struct Cookie *clist = Curl_node_elem(n); + if(!strcmp(clist->name, co->name)) { + /* the names are identical */ + bool matching_domains = FALSE; + + if(clist->domain && co->domain) { + if(cookie_tailmatch(clist->domain, strlen(clist->domain), + co->domain) || + cookie_tailmatch(co->domain, strlen(co->domain), clist->domain)) + /* The existing one is a tail of the new or vice versa */ + matching_domains = TRUE; + } + else if(!clist->domain && !co->domain) + matching_domains = TRUE; + + if(matching_domains && /* the domains were identical */ + clist->path && co->path && /* both have paths */ + clist->secure && !co->secure && !secure) { + size_t cllen; + const char *sep = NULL; + + /* + * A non-secure cookie may not overlay an existing secure cookie. + * For an existing cookie "a" with path "/login", refuse a new + * cookie "a" with for example path "/login/en", while the path + * "/loginhelper" is ok. + */ + + DEBUGASSERT(clist->path[0]); + if(clist->path[0]) + sep = strchr(clist->path + 1, '/'); + if(sep) + cllen = sep - clist->path; + else + cllen = strlen(clist->path); + + if(!strncmp(clist->path, co->path, cllen)) { + infof(data, "cookie '%s' for domain '%s' dropped, would " + "overlay an existing cookie", co->name, co->domain); + return FALSE; + } + } + } + + if(!replace_n && !strcmp(clist->name, co->name)) { + /* the names are identical */ + + if(clist->domain && co->domain) { + if(curl_strequal(clist->domain, co->domain) && + (clist->tailmatch == co->tailmatch)) + /* The domains are identical */ + replace_old = TRUE; + } + else if(!clist->domain && !co->domain) + replace_old = TRUE; + + if(replace_old) { + /* the domains were identical */ + + if(clist->path && co->path && + strcmp(clist->path, co->path)) + replace_old = FALSE; + else if(!clist->path != !co->path) + replace_old = FALSE; + } + + if(replace_old && !co->livecookie && clist->livecookie) { + /* + * Both cookies matched fine, except that the already present cookie + * is "live", which means it was set from a header, while the new one + * was read from a file and thus is not "live". "live" cookies are + * preferred so the new cookie is freed. + */ + return FALSE; + } + if(replace_old) + replace_n = n; + } + } + if(replace_n) { + struct Cookie *repl = Curl_node_elem(replace_n); + + /* when replacing, creationtime is kept from old */ + co->creationtime = repl->creationtime; + + /* unlink the old */ + Curl_node_remove(replace_n); + + /* free the old cookie */ + freecookie(repl, TRUE); + } + *replacep = replace_old; + return TRUE; +} + +/* + * Curl_cookie_add + * + * Add a single cookie line to the cookie keeping object. Be aware that + * sometimes we get an IP-only hostname, and that might also be a numerical + * IPv6 address. + * + */ +CURLcode Curl_cookie_add( + struct Curl_easy *data, + struct CookieInfo *ci, + bool httpheader, /* TRUE if HTTP header-style line */ + bool noexpire, /* if TRUE, skip remove_expired() */ + const char *lineptr, /* first character of the line */ + const char *domain, /* default domain */ + const char *path, /* full path used when this cookie is set, used + to get default path for the cookie unless set */ + bool secure) /* TRUE if connection is over secure origin */ +{ + struct Cookie comem; + struct Cookie *co; + size_t myhash; + CURLcode result; + bool replaces = FALSE; + bool okay; + + DEBUGASSERT(data); + DEBUGASSERT(MAX_SET_COOKIE_AMOUNT <= 255); /* counter is an unsigned char */ + if(data->req.setcookies >= MAX_SET_COOKIE_AMOUNT) + return CURLE_OK; /* silently ignore */ + + co = &comem; + memset(co, 0, sizeof(comem)); + + if(httpheader) + result = parse_cookie_header(data, co, ci, &okay, + lineptr, domain, path, secure); + else + result = parse_netscape(co, ci, &okay, lineptr, secure); + + if(result || !okay) + goto fail; + + if(co->prefix_secure && !co->secure) + /* The __Secure- prefix only requires that the cookie be set secure */ + goto fail; + + if(co->prefix_host) { + /* + * The __Host- prefix requires the cookie to be secure, have a "/" path + * and not have a domain set. + */ + if(co->secure && co->path && !strcmp(co->path, "/") && !co->tailmatch) + ; + else + goto fail; + } + + if(!ci->running && /* read from a file */ + ci->newsession && /* clean session cookies */ + !co->expires) /* this is a session cookie */ + goto fail; + + co->livecookie = ci->running; + co->creationtime = ++ci->lastct; + + /* + * Now we have parsed the incoming line, we must now check if this supersedes + * an already existing cookie, which it may if the previous have the same + * domain and path as this. + */ + + /* remove expired cookies */ + if(!noexpire) + remove_expired(ci); + + if(is_public_suffix(data, co, domain)) + goto fail; + + if(!replace_existing(data, co, ci, secure, &replaces)) + goto fail; + + /* clone the stack struct into heap */ + co = curlx_memdup(&comem, sizeof(comem)); + if(!co) { + co = &comem; + result = CURLE_OUT_OF_MEMORY; + goto fail; /* bail out if we are this low on memory */ + } + + /* add this cookie to the list */ + myhash = cookiehash(co->domain); + Curl_llist_append(&ci->cookielist[myhash], co, &co->node); + + if(ci->running) + /* Only show this when NOT reading the cookies from a file */ + infof(data, "%s cookie %s=\"%s\" for domain %s, path %s, " + "expire %" FMT_OFF_T, + replaces ? "Replaced" : "Added", co->name, co->value, + co->domain, co->path, co->expires); + + if(!replaces) + ci->numcookies++; /* one more cookie in the jar */ + + /* + * Now that we have added a new cookie to the jar, update the expiration + * tracker in case it is the next one to expire. + */ + if(co->expires && (co->expires < ci->next_expiration)) + ci->next_expiration = co->expires; + + if(httpheader) + data->req.setcookies++; + + return result; +fail: + freecookie(co, FALSE); + return result; +} + +/* + * Curl_cookie_init() + * + * Inits a cookie struct to read data from a local file. This is always + * called before any cookies are set. File may be NULL in which case only the + * struct is initialized. Is file is "-" then STDIN is read. + * + * If 'newsession' is TRUE, discard all "session cookies" on read from file. + * + * Note that 'data' might be called as NULL pointer. If data is NULL, 'file' + * will be ignored. + * + * Returns NULL on out of memory. + */ +struct CookieInfo *Curl_cookie_init(void) +{ + int i; + struct CookieInfo *ci = curlx_calloc(1, sizeof(struct CookieInfo)); + if(!ci) + return NULL; + + /* This does not use the destructor callback since we want to add + and remove to lists while keeping the cookie struct intact */ + for(i = 0; i < COOKIE_HASH_SIZE; i++) + Curl_llist_init(&ci->cookielist[i], NULL); + /* + * Initialize the next_expiration time to signal that we do not have enough + * information yet. + */ + ci->next_expiration = CURL_OFF_T_MAX; + + return ci; +} + +/* + * cookie_load() + * + * Reads cookies from a local file. This is always called before any cookies + * are set. If file is "-" then STDIN is read. + * + * If 'newsession' is TRUE, discard all "session cookies" on read from file. + * + */ +static CURLcode cookie_load(struct Curl_easy *data, const char *file, + struct CookieInfo *ci, bool newsession) +{ + FILE *handle = NULL; + CURLcode result = CURLE_OK; + FILE *fp = NULL; + DEBUGASSERT(ci); + DEBUGASSERT(data); + DEBUGASSERT(file); + + ci->newsession = newsession; /* new session? */ + ci->running = FALSE; /* this is not running, this is init */ + + if(file && *file) { + if(!strcmp(file, "-")) + fp = stdin; + else { + fp = curlx_fopen(file, "rb"); + if(!fp) + infof(data, "WARNING: failed to open cookie file \"%s\"", file); + else { + curlx_struct_stat stat; + if((curlx_fstat(fileno(fp), &stat) != -1) && S_ISDIR(stat.st_mode)) { + curlx_fclose(fp); + fp = NULL; + infof(data, "WARNING: cookie filename points to a directory: \"%s\"", + file); + } + else + handle = fp; + } + } + } + + if(fp) { + struct dynbuf buf; + bool eof = FALSE; + curlx_dyn_init(&buf, MAX_COOKIE_LINE); + do { + result = Curl_get_line(&buf, fp, &eof); + if(!result) { + const char *lineptr = curlx_dyn_ptr(&buf); + bool headerline = FALSE; + if(checkprefix("Set-Cookie:", lineptr)) { + /* This is a cookie line, get it! */ + lineptr += 11; + headerline = TRUE; + curlx_str_passblanks(&lineptr); + } + + result = Curl_cookie_add(data, ci, headerline, TRUE, lineptr, NULL, + NULL, TRUE); + /* File reading cookie failures are not propagated back to the + caller because there is no way to do that */ + } + } while(!result && !eof); + curlx_dyn_free(&buf); /* free the line buffer */ + + /* + * Remove expired cookies from the hash. We must make sure to run this + * after reading the file, and not on every cookie. + */ + remove_expired(ci); + + if(handle) + curlx_fclose(handle); + } + data->state.cookie_engine = TRUE; + ci->running = TRUE; /* now, we are running */ + + return result; +} + +/* + * Load cookies from all given cookie files (CURLOPT_COOKIEFILE). + */ +CURLcode Curl_cookie_loadfiles(struct Curl_easy *data) +{ + CURLcode result = CURLE_OK; + struct curl_slist *list = data->state.cookielist; + if(list) { + Curl_share_lock(data, CURL_LOCK_DATA_COOKIE, CURL_LOCK_ACCESS_SINGLE); + if(!data->cookies) + data->cookies = Curl_cookie_init(); + if(!data->cookies) + result = CURLE_OUT_OF_MEMORY; + else { + data->state.cookie_engine = TRUE; + while(list) { + result = cookie_load(data, list->data, data->cookies, + (bool)data->set.cookiesession); + if(result) + break; + list = list->next; + } + } + Curl_share_unlock(data, CURL_LOCK_DATA_COOKIE); + } + return result; +} + +/* + * cookie_sort + * + * Helper function to sort cookies such that the longest path gets before the + * shorter path. Path, domain and name lengths are considered in that order, + * with the creationtime as the tiebreaker. The creationtime is guaranteed to + * be unique per cookie, so we know we will get an ordering at that point. + */ +static int cookie_sort(const void *p1, const void *p2) +{ + const struct Cookie *c1 = *(const struct Cookie * const *)p1; + const struct Cookie *c2 = *(const struct Cookie * const *)p2; + size_t l1, l2; + + /* 1 - compare cookie path lengths */ + l1 = c1->path ? strlen(c1->path) : 0; + l2 = c2->path ? strlen(c2->path) : 0; + + if(l1 != l2) + return (l2 > l1) ? 1 : -1; /* avoid size_t <=> int conversions */ + + /* 2 - compare cookie domain lengths */ + l1 = c1->domain ? strlen(c1->domain) : 0; + l2 = c2->domain ? strlen(c2->domain) : 0; + + if(l1 != l2) + return (l2 > l1) ? 1 : -1; /* avoid size_t <=> int conversions */ + + /* 3 - compare cookie name lengths */ + l1 = c1->name ? strlen(c1->name) : 0; + l2 = c2->name ? strlen(c2->name) : 0; + + if(l1 != l2) + return (l2 > l1) ? 1 : -1; + + /* 4 - compare cookie creation time */ + return (c2->creationtime > c1->creationtime) ? 1 : -1; +} + +/* + * cookie_sort_ct + * + * Helper function to sort cookies according to creation time. + */ +static int cookie_sort_ct(const void *p1, const void *p2) +{ + const struct Cookie *c1 = *(const struct Cookie * const *)p1; + const struct Cookie *c2 = *(const struct Cookie * const *)p2; + + return (c2->creationtime > c1->creationtime) ? 1 : -1; +} + +bool Curl_secure_context(struct Curl_easy *data, const char *host) +{ + return Curl_xfer_is_secure(data) || + curl_strequal("localhost", host) || + !strcmp(host, "127.0.0.1") || + !strcmp(host, "::1"); +} + +/* + * Curl_cookie_getlist + * + * For a given host and path, return a linked list of cookies that the client + * should send to the server if used now. + * + * It shall only return cookies that have not expired. + * + * 'okay' is TRUE when there is a list returned. + */ +CURLcode Curl_cookie_getlist(struct Curl_easy *data, + bool *okay, + const char *host, + struct Curl_llist *list) +{ + size_t matches = 0; + const bool is_ip = Curl_host_is_ipnum(host); + const size_t myhash = cookiehash(host); + struct Curl_llist_node *n; + const bool secure = Curl_secure_context(data, host); + struct CookieInfo *ci = data->cookies; + const char *path = data->state.up.path; + CURLcode result = CURLE_OK; + *okay = FALSE; + + Curl_llist_init(list, NULL); + + if(!ci || !Curl_llist_count(&ci->cookielist[myhash])) + return CURLE_OK; /* no cookie struct or no cookies in the struct */ + + /* at first, remove expired cookies */ + remove_expired(ci); + + for(n = Curl_llist_head(&ci->cookielist[myhash]); n; n = Curl_node_next(n)) { + struct Cookie *co = Curl_node_elem(n); + + /* if the cookie requires we are secure we must only continue if we are! */ + if(co->secure ? secure : TRUE) { + + /* now check if the domain is correct */ + if(!co->domain || + (co->tailmatch && !is_ip && + cookie_tailmatch(co->domain, strlen(co->domain), host)) || + ((!co->tailmatch || is_ip) && curl_strequal(host, co->domain))) { + /* + * the right part of the host matches the domain stuff in the + * cookie data + */ + + /* + * now check the left part of the path with the cookies path + * requirement + */ + if(!co->path || pathmatch(co->path, path)) { + + /* + * This is a match and we add it to the return-linked-list + */ + Curl_llist_append(list, co, &co->getnode); + matches++; + if(matches >= MAX_COOKIE_SEND_AMOUNT) { + infof(data, "Included max number of cookies (%zu) in request!", + matches); + break; + } + } + } + } + } + + if(matches) { + /* + * Now we need to make sure that if there is a name appearing more than + * once, the longest specified path version comes first. To make this the + * swiftest way, we sort them all based on path length. + */ + struct Cookie **array; + size_t i; + + /* alloc an array and store all cookie pointers */ + array = curlx_malloc(sizeof(struct Cookie *) * matches); + if(!array) { + result = CURLE_OUT_OF_MEMORY; + goto fail; + } + + n = Curl_llist_head(list); + + for(i = 0; n; n = Curl_node_next(n)) + array[i++] = Curl_node_elem(n); + + /* now sort the cookie pointers in path length order */ + qsort(array, matches, sizeof(struct Cookie *), cookie_sort); + + /* remake the linked list order according to the new order */ + Curl_llist_destroy(list, NULL); + + for(i = 0; i < matches; i++) + Curl_llist_append(list, array[i], &array[i]->getnode); + + curlx_free(array); /* remove the temporary data again */ + } + + *okay = TRUE; + return CURLE_OK; /* success */ + +fail: + /* failure, clear up the allocated chain and return NULL */ + Curl_llist_destroy(list, NULL); + return result; /* error */ +} + +/* + * Curl_cookie_clearall + * + * Clear all existing cookies and reset the counter. + */ +void Curl_cookie_clearall(struct CookieInfo *ci) +{ + if(ci) { + unsigned int i; + for(i = 0; i < COOKIE_HASH_SIZE; i++) { + struct Curl_llist_node *n; + for(n = Curl_llist_head(&ci->cookielist[i]); n;) { + struct Cookie *c = Curl_node_elem(n); + struct Curl_llist_node *e = Curl_node_next(n); + Curl_node_remove(n); + freecookie(c, TRUE); + n = e; + } + } + ci->numcookies = 0; + } +} + +/* + * Curl_cookie_clearsess + * + * Free all session cookies in the cookies list. + */ +void Curl_cookie_clearsess(struct CookieInfo *ci) +{ + unsigned int i; + + if(!ci) + return; + + for(i = 0; i < COOKIE_HASH_SIZE; i++) { + struct Curl_llist_node *n = Curl_llist_head(&ci->cookielist[i]); + struct Curl_llist_node *e = NULL; + + for(; n; n = e) { + struct Cookie *curr = Curl_node_elem(n); + e = Curl_node_next(n); /* in case the node is removed, get it early */ + if(!curr->expires) { + Curl_node_remove(n); + freecookie(curr, TRUE); + ci->numcookies--; + } + } + } +} + +/* + * Curl_cookie_cleanup() + * + * Free a "cookie object" previous created with Curl_cookie_init(). + */ +void Curl_cookie_cleanup(struct CookieInfo *ci) +{ + if(ci) { + Curl_cookie_clearall(ci); + curlx_free(ci); /* free the base struct as well */ + } +} + +/* + * get_netscape_format() + * + * Formats a string for Netscape output file, w/o a newline at the end. + * Function returns a char * to a formatted line. The caller is responsible + * for freeing the returned pointer. + */ +static char *get_netscape_format(const struct Cookie *co) +{ + return curl_maprintf( + "%s" /* httponly preamble */ + "%s%s\t" /* domain */ + "%s\t" /* tailmatch */ + "%s\t" /* path */ + "%s\t" /* secure */ + "%" FMT_OFF_T "\t" /* expires */ + "%s\t" /* name */ + "%s", /* value */ + co->httponly ? "#HttpOnly_" : "", + /* + * Make sure all domains are prefixed with a dot if they allow + * tailmatching. This is Mozilla-style. + */ + (co->tailmatch && co->domain && co->domain[0] != '.') ? "." : "", + co->domain ? co->domain : "unknown", + co->tailmatch ? "TRUE" : "FALSE", + co->path ? co->path : "/", + co->secure ? "TRUE" : "FALSE", + co->expires, + co->name, + co->value ? co->value : ""); +} + +/* + * cookie_output() + * + * Writes all internally known cookies to the specified file. Specify + * "-" as filename to write to stdout. + * + * The function returns non-zero on write failure. + */ +static CURLcode cookie_output(struct Curl_easy *data, + struct CookieInfo *ci, + const char *filename) +{ + FILE *out = NULL; + bool use_stdout = FALSE; + char *tempstore = NULL; + CURLcode result = CURLE_OK; + + if(!ci) + /* no cookie engine alive */ + return CURLE_OK; + + /* at first, remove expired cookies */ + remove_expired(ci); + + if(!strcmp("-", filename)) { + /* use stdout */ + out = stdout; + use_stdout = TRUE; + } + else { + result = Curl_fopen(data, filename, &out, &tempstore); + if(result) + goto error; + } + + fputs("# Netscape HTTP Cookie File\n" + "# https://curl.se/docs/http-cookies.html\n" + "# This file was generated by libcurl! Edit at your own risk.\n\n", + out); + + if(ci->numcookies) { + unsigned int i; + size_t nvalid = 0; + struct Cookie **array; + struct Curl_llist_node *n; + + array = curlx_calloc(1, sizeof(struct Cookie *) * ci->numcookies); + if(!array) { + result = CURLE_OUT_OF_MEMORY; + goto error; + } + + /* only sort the cookies with a domain property */ + for(i = 0; i < COOKIE_HASH_SIZE; i++) { + for(n = Curl_llist_head(&ci->cookielist[i]); n; n = Curl_node_next(n)) { + struct Cookie *co = Curl_node_elem(n); + if(!co->domain) + continue; + array[nvalid++] = co; + } + } + + qsort(array, nvalid, sizeof(struct Cookie *), cookie_sort_ct); + + for(i = 0; i < nvalid; i++) { + char *format_ptr = get_netscape_format(array[i]); + if(!format_ptr) { + curlx_free(array); + result = CURLE_OUT_OF_MEMORY; + goto error; + } + curl_mfprintf(out, "%s\n", format_ptr); + curlx_free(format_ptr); + } + + curlx_free(array); + } + + if(!use_stdout) { + curlx_fclose(out); + out = NULL; + if(tempstore && curlx_rename(tempstore, filename)) { + result = CURLE_WRITE_ERROR; + goto error; + } + } + + /* + * If we reach here we have successfully written a cookie file so there is + * no need to inspect the error, any error case should have jumped into the + * error block below. + */ + curlx_free(tempstore); + return CURLE_OK; + +error: + if(out && !use_stdout) + curlx_fclose(out); + if(tempstore) { + unlink(tempstore); + curlx_free(tempstore); + } + return result; +} + +static struct curl_slist *cookie_list(const struct Curl_easy *data) +{ + struct curl_slist *list = NULL; + struct curl_slist *beg; + unsigned int i; + struct Curl_llist_node *n; + + if(!data->cookies || (data->cookies->numcookies == 0)) + return NULL; + + /* at first, remove expired cookies */ + remove_expired(data->cookies); + + for(i = 0; i < COOKIE_HASH_SIZE; i++) { + for(n = Curl_llist_head(&data->cookies->cookielist[i]); n; + n = Curl_node_next(n)) { + struct Cookie *c = Curl_node_elem(n); + char *line; + if(!c->domain) + continue; + line = get_netscape_format(c); + if(!line) { + curl_slist_free_all(list); + return NULL; + } + beg = Curl_slist_append_nodup(list, line); + if(!beg) { + curlx_free(line); + curl_slist_free_all(list); + return NULL; + } + list = beg; + } + } + + return list; +} + +struct curl_slist *Curl_cookie_list(struct Curl_easy *data) +{ + struct curl_slist *list; + Curl_share_lock(data, CURL_LOCK_DATA_COOKIE, CURL_LOCK_ACCESS_SINGLE); + list = cookie_list(data); + Curl_share_unlock(data, CURL_LOCK_DATA_COOKIE); + return list; +} + +void Curl_flush_cookies(struct Curl_easy *data, bool cleanup) +{ + Curl_share_lock(data, CURL_LOCK_DATA_COOKIE, CURL_LOCK_ACCESS_SINGLE); + /* only save the cookie file if a transfer was started (cookies->running is + set), as otherwise the cookies were not completely initialized and there + might be cookie files that were not loaded so saving the file is the + wrong thing. */ + if(data->cookies) { + if(data->set.str[STRING_COOKIEJAR] && data->cookies->running) { + /* if we have a destination file for all the cookies to get dumped to */ + CURLcode result = cookie_output(data, data->cookies, + data->set.str[STRING_COOKIEJAR]); + if(result) + infof(data, "WARNING: failed to save cookies in %s: %s", + data->set.str[STRING_COOKIEJAR], curl_easy_strerror(result)); + } + + if(cleanup && (!data->share || (data->cookies != data->share->cookies))) { + Curl_cookie_cleanup(data->cookies); + data->cookies = NULL; + } + } + Curl_share_unlock(data, CURL_LOCK_DATA_COOKIE); +} + +void Curl_cookie_run(struct Curl_easy *data) +{ + Curl_share_lock(data, CURL_LOCK_DATA_COOKIE, CURL_LOCK_ACCESS_SINGLE); + if(data->cookies) + data->cookies->running = TRUE; + Curl_share_unlock(data, CURL_LOCK_DATA_COOKIE); +} + +#endif /* CURL_DISABLE_HTTP || CURL_DISABLE_COOKIES */ diff --git a/3rdparty/curl-8.21.0/lib/cookie.h b/3rdparty/curl-8.21.0/lib/cookie.h new file mode 100644 index 0000000000..b8ef8b8ea1 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/cookie.h @@ -0,0 +1,143 @@ +#ifndef HEADER_CURL_COOKIE_H +#define HEADER_CURL_COOKIE_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "llist.h" + +struct Cookie { + struct Curl_llist_node node; /* for the main cookie list */ + struct Curl_llist_node getnode; /* for getlist */ + char *name; /* = value */ + char *value; /* name = */ + char *path; /* canonical path */ + char *domain; /* domain = */ + curl_off_t expires; /* expires = */ + unsigned int creationtime; /* time when the cookie was written */ + BIT(tailmatch); /* tail-match the domain name */ + BIT(secure); /* the 'secure' keyword was used */ + BIT(livecookie); /* updated from server, not a stored file */ + BIT(httponly); /* the httponly directive is present */ + BIT(prefix_secure); /* secure prefix is set */ + BIT(prefix_host); /* host prefix is set */ +}; + +/* + * Available cookie prefixes, as defined in + * draft-ietf-httpbis-rfc6265bis-02 + */ +#define COOKIE_PREFIX__SECURE (1 << 0) +#define COOKIE_PREFIX__HOST (1 << 1) + +#define COOKIE_HASH_SIZE 63 + +struct CookieInfo { + /* linked lists of cookies we know of */ + struct Curl_llist cookielist[COOKIE_HASH_SIZE]; + curl_off_t next_expiration; /* the next time at which expiration happens */ + unsigned int numcookies; /* number of cookies in the "jar" */ + unsigned int lastct; /* last creation-time used in the jar */ + BIT(running); /* state info, for cookie adding information */ + BIT(newsession); /* new session, discard session cookies on load */ +}; + +/* The maximum sizes we accept for cookies. RFC 6265 section 6.1 says + "general-use user agents SHOULD provide each of the following minimum + capabilities": + + - At least 4096 bytes per cookie (as measured by the sum of the length of + the cookie's name, value, and attributes). + In the 6265bis draft document section 5.4 it is phrased even stronger: "If + the sum of the lengths of the name string and the value string is more than + 4096 octets, abort these steps and ignore the set-cookie-string entirely." +*/ + +/** Limits for INCOMING cookies **/ + +/* The longest we allow a line to be when reading a cookie from an HTTP header + or from a cookie jar */ +#define MAX_COOKIE_LINE 5000 + +/* Maximum length of an incoming cookie name or content we deal with. Longer + cookies are ignored. */ +#define MAX_NAME 4096 + +/* Maximum number of Set-Cookie: lines accepted in a single response. If more + such header lines are received, they are ignored. This value must be less + than 256 since an unsigned char is used to count. */ +#define MAX_SET_COOKIE_AMOUNT 50 + +/** Limits for OUTGOING cookies **/ + +/* Maximum size for an outgoing cookie line libcurl will use in an http + request. This is the default maximum length used in some versions of Apache + httpd. */ +#define MAX_COOKIE_HEADER_LEN 8190 + +/* Maximum number of cookies libcurl will send in a single request, even if + there might be more cookies that match. One reason to cap the number is to + keep the maximum HTTP request within the maximum allowed size. */ +#define MAX_COOKIE_SEND_AMOUNT 150 + +struct Curl_easy; +struct connectdata; + +/* + * Add a cookie to the internal list of cookies. The domain and path arguments + * are only used if the header boolean is TRUE. + */ + +bool Curl_secure_context(struct Curl_easy *data, const char *host); +CURLcode Curl_cookie_add(struct Curl_easy *data, + struct CookieInfo *ci, + bool httpheader, + bool noexpire, + const char *lineptr, + const char *domain, + const char *path, + bool secure) WARN_UNUSED_RESULT; +CURLcode Curl_cookie_getlist(struct Curl_easy *data, + bool *okay, const char *host, + struct Curl_llist *list) WARN_UNUSED_RESULT; +void Curl_cookie_clearall(struct CookieInfo *ci); +void Curl_cookie_clearsess(struct CookieInfo *ci); + +#if defined(CURL_DISABLE_HTTP) || defined(CURL_DISABLE_COOKIES) +#define Curl_cookie_list(x) NULL +#define Curl_cookie_loadfiles(x) CURLE_OK +#define Curl_cookie_init() NULL +#define Curl_cookie_run(x) Curl_nop_stmt +#define Curl_cookie_cleanup(x) Curl_nop_stmt +#define Curl_flush_cookies(x, y) Curl_nop_stmt +#else +void Curl_flush_cookies(struct Curl_easy *data, bool cleanup); +void Curl_cookie_cleanup(struct CookieInfo *ci); +struct CookieInfo *Curl_cookie_init(void); +struct curl_slist *Curl_cookie_list(struct Curl_easy *data); +CURLcode Curl_cookie_loadfiles(struct Curl_easy *data) WARN_UNUSED_RESULT; +void Curl_cookie_run(struct Curl_easy *data); +#endif + +#endif /* HEADER_CURL_COOKIE_H */ diff --git a/3rdparty/curl-8.21.0/lib/creds.c b/3rdparty/curl-8.21.0/lib/creds.c new file mode 100644 index 0000000000..d22c166a42 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/creds.c @@ -0,0 +1,189 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include /* for offsetof() */ + +#include "creds.h" +#include "curl_trc.h" +#include "strcase.h" +#include "urldata.h" + + +CURLcode Curl_creds_create(const char *user, + const char *passwd, + const char *oauth_bearer, + const char *sasl_authzid, + const char *sasl_service, + uint8_t source, + struct Curl_creds **pcreds) +{ + struct Curl_creds *creds = NULL; + size_t ulen = user ? strlen(user) : 0; + size_t plen = passwd ? strlen(passwd) : 0; + size_t olen = oauth_bearer ? strlen(oauth_bearer) : 0; + size_t salen = sasl_authzid ? strlen(sasl_authzid) : 0; + size_t sslen = sasl_service ? strlen(sasl_service) : 0; + char *s, *buf; + CURLcode result = CURLE_OK; + + Curl_creds_unlink(pcreds); + + /* Everything empty/NULL, this is the NULL credential */ + if(!user && !passwd && !olen && !salen && !sslen) + goto out; + + if((ulen > CURL_MAX_INPUT_LENGTH) || + (plen > CURL_MAX_INPUT_LENGTH) || + (olen > CURL_MAX_INPUT_LENGTH) || + (salen > CURL_MAX_INPUT_LENGTH) || + (sslen > CURL_MAX_INPUT_LENGTH)) { + result = CURLE_BAD_FUNCTION_ARGUMENT; + goto out; + } + + /* null-terminator for user already part of struct */ + creds = curlx_calloc(1, sizeof(*creds) + + ulen + plen + 1 + olen + 1 + salen + 1 + sslen + 1); + if(!creds) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + creds->refcount = 1; + creds->source = source; + /* Some compilers try to be too smart about our dynamic struct size */ + buf = ((char *)creds) + offsetof(struct Curl_creds, buf); + creds->user = s = buf; + if(ulen) + memcpy(s, user, ulen + 1); + creds->passwd = s = buf + ulen + 1; + if(plen) + memcpy(s, passwd, plen + 1); + creds->oauth_bearer = s = buf + ulen + 1 + plen + 1; + if(olen) + memcpy(s, oauth_bearer, olen + 1); + creds->sasl_authzid = s = buf + ulen + 1 + plen + 1 + olen + 1; + if(salen) + memcpy(s, sasl_authzid, salen + 1); + creds->sasl_service = s = buf + ulen + 1 + plen + 1 + olen + 1 + salen + 1; + if(sslen) + memcpy(s, sasl_service, sslen + 1); + +out: + if(!result) + *pcreds = creds; + else + Curl_creds_unlink(&creds); + return result; +} + +CURLcode Curl_creds_merge(const char *user, + const char *passwd, + struct Curl_creds *creds_in, + uint8_t source, + struct Curl_creds **pcreds_out) +{ + struct Curl_creds *creds_out = NULL; + CURLcode result; + + if(!creds_in) { + result = Curl_creds_create(user, passwd, NULL, NULL, NULL, + source, &creds_out); + } + else { + result = Curl_creds_create(user ? user : Curl_creds_user(creds_in), + passwd ? passwd : Curl_creds_passwd(creds_in), + Curl_creds_oauth_bearer(creds_in), + Curl_creds_sasl_authzid(creds_in), + Curl_creds_sasl_service(creds_in), + source, &creds_out); + } + Curl_creds_link(pcreds_out, creds_out); + Curl_creds_unlink(&creds_out); + return result; +} + +void Curl_creds_link(struct Curl_creds **pdest, struct Curl_creds *src) +{ + if(*pdest != src) { + Curl_creds_unlink(pdest); + *pdest = src; + if(src) { + DEBUGASSERT(src->refcount < UINT32_MAX); + src->refcount++; + } + } +} + +void Curl_creds_unlink(struct Curl_creds **pcreds) +{ + if(*pcreds) { + struct Curl_creds *creds = *pcreds; + + DEBUGASSERT(creds->refcount); + *pcreds = NULL; + if(creds->refcount) + creds->refcount--; + if(!creds->refcount) { + curlx_free(creds); + } + } +} + +bool Curl_creds_same(struct Curl_creds *c1, struct Curl_creds *c2) +{ + return (c1 == c2) || + (c1 && c2 && + !Curl_timestrcmp(c1->user, c2->user) && + !Curl_timestrcmp(c1->passwd, c2->passwd) && + !Curl_timestrcmp(c1->oauth_bearer, c2->oauth_bearer) && + !Curl_timestrcmp(c1->sasl_authzid, c2->sasl_authzid) && + !Curl_timestrcmp(c1->sasl_service, c2->sasl_service)); +} + +bool Curl_creds_equal(struct Curl_creds *c1, struct Curl_creds *c2) +{ + return Curl_creds_same(c1, c2) && + ((c1 == c2) || (c1 && c2 && (c1->source == c2->source))); +} + +#ifdef CURLVERBOSE +void Curl_creds_trace(struct Curl_easy *data, struct Curl_creds *creds, + const char *msg) +{ + if(creds) { + CURL_TRC_M(data, "%s: user=%s, passwd=%s, " + "sasl_authzid=%s, oauth_bearer=%s, source=%d", + msg, + Curl_creds_user(creds), + Curl_creds_has_passwd(creds) ? "***" : "", + Curl_creds_sasl_authzid(creds), + Curl_creds_has_oauth_bearer(creds) ? "***" : "", + creds->source); + } + else + CURL_TRC_M(data, "%s: -", msg); +} +#endif diff --git a/3rdparty/curl-8.21.0/lib/creds.h b/3rdparty/curl-8.21.0/lib/creds.h new file mode 100644 index 0000000000..0664d08a4f --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/creds.h @@ -0,0 +1,91 @@ +#ifndef HEADER_CURL_CREDS_H +#define HEADER_CURL_CREDS_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +struct Curl_easy; + +#define CREDS_NONE 0 /* used for default username/passwd */ +#define CREDS_URL 1 /* username/passwd from URL */ +#define CREDS_OPTION 2 /* username/passwd set with a CURLOPT_ */ +#define CREDS_NETRC 3 /* username/passwd found in netrc */ + +struct Curl_creds { + const char *user; /* non-NULL, maybe empty string */ + const char *passwd; /* non-NULL, maybe empty string */ + const char *oauth_bearer; /* non-NULL, maybe empty string */ + const char *sasl_authzid; /* non-NULL, maybe empty string */ + const char *sasl_service; /* non-NULL, maybe empty string */ + uint32_t refcount; + uint8_t source; /* CREDS_* value */ + char buf[1]; +}; + +CURLcode Curl_creds_create(const char *user, + const char *passwd, + const char *oauth_bearer, + const char *sasl_authzid, + const char *sasl_service, + uint8_t source, + struct Curl_creds **pcreds); + +/* Create credentials by overriding `user` and/or `passwd` in `creds_in` */ +CURLcode Curl_creds_merge(const char *user, + const char *passwd, + struct Curl_creds *creds_in, + uint8_t source, + struct Curl_creds **pcreds_out); + +/* Unlink any creds in `*pdest`, assign src, increase src + * refcount when not NULL. */ +void Curl_creds_link(struct Curl_creds **pdest, struct Curl_creds *src); + +/* Drop a reference, creds may be passed as NULL */ +void Curl_creds_unlink(struct Curl_creds **pcreds); + +/* TRUE if both creds are NULL or have same values, except source. */ +bool Curl_creds_same(struct Curl_creds *c1, struct Curl_creds *c2); + +/* TRUE if both creds are NULL or have all values equal. */ +bool Curl_creds_equal(struct Curl_creds *c1, struct Curl_creds *c2); + +/* Provides properties for creds or, if creds is NULL, the empty string */ +#define Curl_creds_has_user(c) ((c) && (c)->user[0]) +#define Curl_creds_has_passwd(c) ((c) && (c)->passwd[0]) +#define Curl_creds_has_user_or_pass(c) \ + ((c) && ((c)->user[0] || (c)->passwd[0])) +#define Curl_creds_has_oauth_bearer(c) ((c) && (c)->oauth_bearer[0]) +#define Curl_creds_has_sasl_service(c) ((c) && (c)->sasl_service[0]) +#define Curl_creds_user(c) ((c) ? (c)->user : "") +#define Curl_creds_passwd(c) ((c) ? (c)->passwd : "") +#define Curl_creds_oauth_bearer(c) ((c) ? (c)->oauth_bearer : "") +#define Curl_creds_sasl_authzid(c) ((c) ? (c)->sasl_authzid : "") +#define Curl_creds_sasl_service(c) ((c) ? (c)->sasl_service : "") + +#ifdef CURLVERBOSE +void Curl_creds_trace(struct Curl_easy *data, struct Curl_creds *creds, + const char *msg); +#endif + +#endif /* HEADER_CURL_CREDS_H */ diff --git a/3rdparty/curl-8.21.0/lib/cshutdn.c b/3rdparty/curl-8.21.0/lib/cshutdn.c new file mode 100644 index 0000000000..cc77e401fd --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/cshutdn.c @@ -0,0 +1,534 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Linus Nielsen Feltzing, + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "urldata.h" +#include "url.h" +#include "cfilters.h" +#include "progress.h" +#include "multiif.h" +#include "multi_ev.h" +#include "curl_trc.h" +#include "cshutdn.h" +#include "sigpipe.h" +#include "connect.h" +#include "select.h" +#include "curlx/strparse.h" + + +static void cshutdn_run_conn_handler(struct Curl_easy *data, + struct connectdata *conn) +{ + if(!conn->bits.shutdown_handler) { + + if(conn->scheme && conn->scheme->run->disconnect) { + /* Some disconnect handlers do a blocking wait on server responses. + * FTP/IMAP/SMTP and SFTP are among them. When using the internal + * handle, set an overall short timeout so we do not hang for the + * default 120 seconds. */ + if(data->state.internal) { + data->set.timeout = DEFAULT_SHUTDOWN_TIMEOUT_MS; + Curl_pgrsTime(data, TIMER_STARTOP); + } + + /* This is set if protocol-specific cleanups should be made */ + DEBUGF(infof(data, "connection #%" FMT_OFF_T + ", shutdown protocol handler (aborted=%d)", + conn->connection_id, conn->bits.aborted)); + /* There are protocol handlers that block on retrieving + * server responses here (FTP). Set a short timeout. */ + conn->scheme->run->disconnect(data, conn, (bool)conn->bits.aborted); + } + + conn->bits.shutdown_handler = TRUE; + } +} + +static void cshutdn_run_once(struct Curl_easy *data, + struct connectdata *conn, + bool *done) +{ + CURLcode r1, r2; + bool done1, done2; + + /* We expect to be attached when called */ + DEBUGASSERT(data->conn == conn); + + if(!Curl_shutdown_started(data, FIRSTSOCKET)) { + Curl_shutdown_start(data, FIRSTSOCKET, 0); + } + + cshutdn_run_conn_handler(data, conn); + + if(conn->bits.shutdown_filters) { + *done = TRUE; + return; + } + + if(!conn->bits.connect_only && Curl_conn_is_connected(conn, FIRSTSOCKET)) + r1 = Curl_conn_shutdown(data, FIRSTSOCKET, &done1); + else { + r1 = CURLE_OK; + done1 = TRUE; + } + + if(!conn->bits.connect_only && Curl_conn_is_connected(conn, SECONDARYSOCKET)) + r2 = Curl_conn_shutdown(data, SECONDARYSOCKET, &done2); + else { + r2 = CURLE_OK; + done2 = TRUE; + } + + /* we are done when any failed or both report success */ + *done = (r1 || r2 || (done1 && done2)); + if(*done) + conn->bits.shutdown_filters = TRUE; +} + +void Curl_cshutdn_run_once(struct Curl_easy *data, + struct connectdata *conn, + bool *done) +{ + DEBUGASSERT(!data->conn); + Curl_attach_connection(data, conn); + cshutdn_run_once(data, conn, done); + CURL_TRC_M(data, "[SHUTDOWN] shutdown, done=%d", *done); + Curl_detach_connection(data); +} + +void Curl_cshutdn_terminate(struct Curl_easy *data, + struct connectdata *conn, + bool do_shutdown) +{ + struct Curl_easy *admin = data; + bool done; + + /* there must be a connection to close */ + DEBUGASSERT(conn); + /* it must be removed from the connection pool */ + DEBUGASSERT(!conn->bits.in_cpool); + /* the transfer must be detached from the connection */ + DEBUGASSERT(data && !data->conn); + + /* If we can obtain an internal admin handle, use that to attach + * and terminate the connection. Some protocol will try to mess with + * `data` during shutdown and we do not want that with a `data` from + * the application. */ + if(data->multi && data->multi->admin) + admin = data->multi->admin; + + Curl_attach_connection(admin, conn); + + cshutdn_run_conn_handler(admin, conn); + if(do_shutdown) { + /* Make a last attempt to shutdown handlers and filters, if + * not done so already. */ + cshutdn_run_once(admin, conn, &done); + } + CURL_TRC_M(admin, "[SHUTDOWN] %sclosing connection #%" FMT_OFF_T, + conn->bits.shutdown_filters ? "" : "force ", + conn->connection_id); + Curl_conn_cf_discard_all(admin, conn, SECONDARYSOCKET); + Curl_conn_cf_discard_all(admin, conn, FIRSTSOCKET); + Curl_detach_connection(admin); + + if(data->multi) + Curl_multi_ev_conn_done(data->multi, data, conn); + Curl_conn_free(admin, conn); + + if(data->multi) { + CURL_TRC_M(data, "[SHUTDOWN] trigger multi connchanged"); + Curl_multi_connchanged(data->multi); + } +} + +static bool cshutdn_destroy_oldest(struct cshutdn *cshutdn, + struct Curl_easy *data, + const char *destination) +{ + struct Curl_llist_node *e; + struct connectdata *conn; + + e = Curl_llist_head(&cshutdn->list); + while(e) { + conn = Curl_node_elem(e); + if(!destination || !strcmp(destination, conn->destination)) + break; + e = Curl_node_next(e); + } + + if(e) { + struct Curl_sigpipe_ctx sigpipe_ctx; + conn = Curl_node_elem(e); + Curl_node_remove(e); + sigpipe_init(&sigpipe_ctx); + sigpipe_apply(data, &sigpipe_ctx); + Curl_cshutdn_terminate(data, conn, FALSE); + sigpipe_restore(&sigpipe_ctx); + return TRUE; + } + return FALSE; +} + +bool Curl_cshutdn_close_oldest(struct Curl_easy *data, + const char *destination) +{ + if(data && data->multi) { + struct cshutdn *csd = &data->multi->cshutdn; + return cshutdn_destroy_oldest(csd, data, destination); + } + return FALSE; +} + +#define NUM_POLLS_ON_STACK 10 + +static CURLcode cshutdn_wait(struct cshutdn *cshutdn, + struct Curl_easy *data, + int timeout_ms) +{ + struct pollfd a_few_on_stack[NUM_POLLS_ON_STACK]; + struct curl_pollfds cpfds; + CURLcode result; + + Curl_pollfds_init(&cpfds, a_few_on_stack, NUM_POLLS_ON_STACK); + + result = Curl_cshutdn_add_pollfds(cshutdn, data, &cpfds); + if(result) + goto out; + + Curl_poll(cpfds.pfds, cpfds.n, CURLMIN(timeout_ms, 1000)); + +out: + Curl_pollfds_cleanup(&cpfds); + return result; +} + +static void cshutdn_perform(struct cshutdn *cshutdn, + struct Curl_easy *data, + struct Curl_sigpipe_ctx *sigpipe_ctx) +{ + struct Curl_llist_node *e = Curl_llist_head(&cshutdn->list); + struct Curl_llist_node *enext; + struct connectdata *conn; + timediff_t next_expire_ms = 0, ms; + bool done; + + if(!e) + return; + + CURL_TRC_M(data, "[SHUTDOWN] perform on %zu connections", + Curl_llist_count(&cshutdn->list)); + sigpipe_apply(data, sigpipe_ctx); + while(e) { + enext = Curl_node_next(e); + conn = Curl_node_elem(e); + Curl_cshutdn_run_once(data, conn, &done); + if(done) { + Curl_node_remove(e); + Curl_cshutdn_terminate(data, conn, FALSE); + } + else { + /* idata has one timer list, but maybe more than one connection. + * Set EXPIRE_SHUTDOWN to the smallest time left for all. */ + ms = Curl_conn_shutdown_timeleft(data, conn); + if(ms && ms < next_expire_ms) + next_expire_ms = ms; + } + e = enext; + } + + if(next_expire_ms) + Curl_expire_ex(data, next_expire_ms, EXPIRE_SHUTDOWN); +} + +static void cshutdn_terminate_all(struct cshutdn *cshutdn, + struct Curl_easy *data, + int timeout_ms) +{ + struct curltime started = *Curl_pgrs_now(data); + struct Curl_llist_node *e; + struct Curl_sigpipe_ctx sigpipe_ctx; + + DEBUGASSERT(cshutdn); + DEBUGASSERT(data); + + CURL_TRC_M(data, "[SHUTDOWN] shutdown all"); + sigpipe_init(&sigpipe_ctx); + + while(Curl_llist_head(&cshutdn->list)) { + timediff_t spent_ms; + int remain_ms; + + cshutdn_perform(cshutdn, data, &sigpipe_ctx); + + if(!Curl_llist_head(&cshutdn->list)) { + CURL_TRC_M(data, "[SHUTDOWN] shutdown finished cleanly"); + break; + } + + /* wait for activity, timeout or "nothing" */ + spent_ms = curlx_ptimediff_ms(Curl_pgrs_now(data), &started); + if(spent_ms >= (timediff_t)timeout_ms) { + CURL_TRC_M(data, "[SHUTDOWN] shutdown finished, %s", + (timeout_ms > 0) ? "timeout" : "best effort done"); + break; + } + + remain_ms = timeout_ms - (int)spent_ms; + if(cshutdn_wait(cshutdn, data, remain_ms)) { + CURL_TRC_M(data, "[SHUTDOWN] shutdown finished, aborted"); + break; + } + } + + /* Terminate any remaining. */ + e = Curl_llist_head(&cshutdn->list); + while(e) { + struct connectdata *conn = Curl_node_elem(e); + Curl_node_remove(e); + Curl_cshutdn_terminate(data, conn, FALSE); + e = Curl_llist_head(&cshutdn->list); + } + DEBUGASSERT(!Curl_llist_count(&cshutdn->list)); + + sigpipe_restore(&sigpipe_ctx); +} + +int Curl_cshutdn_init(struct cshutdn *cshutdn, + struct Curl_multi *multi) +{ + DEBUGASSERT(multi); + cshutdn->multi = multi; + Curl_llist_init(&cshutdn->list, NULL); + cshutdn->initialized = TRUE; + return 0; /* good */ +} + +void Curl_cshutdn_destroy(struct cshutdn *cshutdn, + struct Curl_easy *data) +{ + if(cshutdn->initialized && data) { + int timeout_ms = 0; + /* for testing, run graceful shutdown */ +#ifdef DEBUGBUILD + { + const char *p = getenv("CURL_GRACEFUL_SHUTDOWN"); + if(p) { + curl_off_t l; + if(!curlx_str_number(&p, &l, INT_MAX)) + timeout_ms = (int)l; + } + } +#endif + + CURL_TRC_M(data, "[SHUTDOWN] destroy, %zu connections, timeout=%dms", + Curl_llist_count(&cshutdn->list), timeout_ms); + cshutdn_terminate_all(cshutdn, data, timeout_ms); + } + cshutdn->multi = NULL; +} + +size_t Curl_cshutdn_count(struct Curl_easy *data) +{ + if(data && data->multi) { + struct cshutdn *csd = &data->multi->cshutdn; + return Curl_llist_count(&csd->list); + } + return 0; +} + +size_t Curl_cshutdn_dest_count(struct Curl_easy *data, + const char *destination) +{ + if(data && data->multi) { + struct cshutdn *csd = &data->multi->cshutdn; + size_t n = 0; + struct Curl_llist_node *e = Curl_llist_head(&csd->list); + while(e) { + struct connectdata *conn = Curl_node_elem(e); + if(!strcmp(destination, conn->destination)) + ++n; + e = Curl_node_next(e); + } + return n; + } + return 0; +} + +static CURLMcode cshutdn_update_ev(struct cshutdn *cshutdn, + struct Curl_easy *data, + struct connectdata *conn) +{ + CURLMcode mresult; + + DEBUGASSERT(cshutdn); + DEBUGASSERT(cshutdn->multi->socket_cb); + + Curl_attach_connection(data, conn); + mresult = Curl_multi_ev_assess_conn(cshutdn->multi, data, conn); + Curl_detach_connection(data); + return mresult; +} + +void Curl_cshutdn_add(struct cshutdn *cshutdn, + struct connectdata *conn, + size_t conns_in_pool) +{ + struct Curl_easy *data = cshutdn->multi->admin; + size_t max_total = cshutdn->multi->max_total_connections; + + /* Add the connection to our shutdown list for non-blocking shutdown + * during multi processing. */ + if(max_total > 0 && + (max_total <= (conns_in_pool + Curl_llist_count(&cshutdn->list)))) { + CURL_TRC_M(data, "[SHUTDOWN] discarding oldest shutdown connection " + "due to connection limit of %zu", max_total); + cshutdn_destroy_oldest(cshutdn, data, NULL); + } + + if(cshutdn->multi->socket_cb) { + if(cshutdn_update_ev(cshutdn, data, conn)) { + CURL_TRC_M(data, "[SHUTDOWN] update events failed, discarding #%" + FMT_OFF_T, conn->connection_id); + Curl_cshutdn_terminate(data, conn, FALSE); + return; + } + } + + Curl_llist_append(&cshutdn->list, conn, &conn->cshutdn_node); + CURL_TRC_M(data, "[SHUTDOWN] added #%" FMT_OFF_T + " to shutdowns, now %zu conns in shutdown", + conn->connection_id, Curl_llist_count(&cshutdn->list)); +} + +void Curl_cshutdn_perform(struct cshutdn *cshutdn, + struct Curl_easy *data, + struct Curl_sigpipe_ctx *sigpipe_ctx) +{ + cshutdn_perform(cshutdn, data, sigpipe_ctx); +} + +/* return fd_set info about the shutdown connections */ +void Curl_cshutdn_setfds(struct cshutdn *cshutdn, + struct Curl_easy *data, + fd_set *read_fd_set, fd_set *write_fd_set, + int *maxfd) +{ + if(Curl_llist_head(&cshutdn->list)) { + struct Curl_llist_node *e; + struct easy_pollset ps; + + Curl_pollset_init(&ps); + for(e = Curl_llist_head(&cshutdn->list); e; e = Curl_node_next(e)) { + unsigned int i; + struct connectdata *conn = Curl_node_elem(e); + CURLcode result; + + Curl_pollset_reset(&ps); + Curl_attach_connection(data, conn); + result = Curl_conn_adjust_pollset(data, conn, &ps); + Curl_detach_connection(data); + + if(result) + continue; + + for(i = 0; i < ps.n; i++) { + curl_socket_t sock = ps.sockets[i]; + if(!FDSET_SOCK(sock)) + continue; + if(ps.actions[i] & CURL_POLL_IN) + FD_SET(sock, read_fd_set); + if(ps.actions[i] & CURL_POLL_OUT) + FD_SET(sock, write_fd_set); + if((ps.actions[i] & (CURL_POLL_OUT | CURL_POLL_IN)) && + ((int)sock > *maxfd)) + *maxfd = (int)sock; + } + } + Curl_pollset_cleanup(&ps); + } +} + +/* return information about the shutdown connections */ +unsigned int Curl_cshutdn_add_waitfds(struct cshutdn *cshutdn, + struct Curl_easy *data, + struct Curl_waitfds *cwfds) +{ + unsigned int need = 0; + + if(Curl_llist_head(&cshutdn->list)) { + struct Curl_llist_node *e; + struct easy_pollset ps; + struct connectdata *conn; + CURLcode result; + + Curl_pollset_init(&ps); + for(e = Curl_llist_head(&cshutdn->list); e; e = Curl_node_next(e)) { + conn = Curl_node_elem(e); + Curl_pollset_reset(&ps); + Curl_attach_connection(data, conn); + result = Curl_conn_adjust_pollset(data, conn, &ps); + Curl_detach_connection(data); + + if(!result) + need += Curl_waitfds_add_ps(cwfds, &ps); + } + Curl_pollset_cleanup(&ps); + } + return need; +} + +CURLcode Curl_cshutdn_add_pollfds(struct cshutdn *cshutdn, + struct Curl_easy *data, + struct curl_pollfds *cpfds) +{ + CURLcode result = CURLE_OK; + + if(Curl_llist_head(&cshutdn->list)) { + struct Curl_llist_node *e; + struct easy_pollset ps; + struct connectdata *conn; + + Curl_pollset_init(&ps); + for(e = Curl_llist_head(&cshutdn->list); e; e = Curl_node_next(e)) { + conn = Curl_node_elem(e); + Curl_pollset_reset(&ps); + Curl_attach_connection(data, conn); + result = Curl_conn_adjust_pollset(data, conn, &ps); + Curl_detach_connection(data); + + if(!result) + result = Curl_pollfds_add_ps(cpfds, &ps); + if(result) { + Curl_pollset_cleanup(&ps); + Curl_pollfds_cleanup(cpfds); + goto out; + } + } + Curl_pollset_cleanup(&ps); + } +out: + return result; +} diff --git a/3rdparty/curl-8.21.0/lib/cshutdn.h b/3rdparty/curl-8.21.0/lib/cshutdn.h new file mode 100644 index 0000000000..8479524993 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/cshutdn.h @@ -0,0 +1,106 @@ +#ifndef HEADER_CURL_CSHUTDN_H +#define HEADER_CURL_CSHUTDN_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * Copyright (C) Linus Nielsen Feltzing, + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +struct connectdata; +struct Curl_easy; +struct curl_pollfds; +struct Curl_waitfds; +struct Curl_multi; +struct Curl_share; +struct Curl_sigpipe_ctx; + +/* Run the shutdown of the connection once. + * Shortly attach/detach `data` to `conn` while doing so. + * `done` will be set TRUE if any error was encountered or if + * the connection was shut down completely. */ +void Curl_cshutdn_run_once(struct Curl_easy *data, + struct connectdata *conn, + bool *done); + +/* Terminates the connection, e.g. closes and destroys it. + * If `do_shutdown` is TRUE, the shutdown will be run once before + * terminating it. + * Takes ownership of `conn`. */ +void Curl_cshutdn_terminate(struct Curl_easy *data, + struct connectdata *conn, + bool do_shutdown); + +/* A `cshutdown` is always owned by a multi handle to maintain + * the connections to be shut down. It registers timers and + * sockets to monitor via the multi handle. */ +struct cshutdn { + struct Curl_llist list; /* connections being shut down */ + struct Curl_multi *multi; /* the multi owning this */ + BIT(initialized); +}; + +/* Init as part of the given multi handle. */ +int Curl_cshutdn_init(struct cshutdn *cshutdn, + struct Curl_multi *multi); + +/* Terminate all remaining connections and free resources. */ +void Curl_cshutdn_destroy(struct cshutdn *cshutdn, + struct Curl_easy *data); + +/* Number of connections being shut down. */ +size_t Curl_cshutdn_count(struct Curl_easy *data); + +/* Number of connections to the destination being shut down. */ +size_t Curl_cshutdn_dest_count(struct Curl_easy *data, + const char *destination); + +/* Close the oldest connection in shutdown to destination or, + * when destination is NULL for any destination. + * Return TRUE if a connection has been closed. */ +bool Curl_cshutdn_close_oldest(struct Curl_easy *data, + const char *destination); + +/* Add a connection to have it shut down. Terminate the oldest + * connection when total connection limit of multi is being reached. */ +void Curl_cshutdn_add(struct cshutdn *cshutdn, + struct connectdata *conn, + size_t conns_in_pool); + +/* Add sockets and POLLIN/OUT flags for connections being shut down. */ +CURLcode Curl_cshutdn_add_pollfds(struct cshutdn *cshutdn, + struct Curl_easy *data, + struct curl_pollfds *cpfds); + +unsigned int Curl_cshutdn_add_waitfds(struct cshutdn *cshutdn, + struct Curl_easy *data, + struct Curl_waitfds *cwfds); + +void Curl_cshutdn_setfds(struct cshutdn *cshutdn, + struct Curl_easy *data, + fd_set *read_fd_set, fd_set *write_fd_set, + int *maxfd); + +/* Run maintenance on all connections. */ +void Curl_cshutdn_perform(struct cshutdn *cshutdn, + struct Curl_easy *data, + struct Curl_sigpipe_ctx *sigpipe_ctx); + +#endif /* HEADER_CURL_CSHUTDN_H */ diff --git a/3rdparty/curl-8.21.0/lib/curl_addrinfo.c b/3rdparty/curl-8.21.0/lib/curl_addrinfo.c new file mode 100644 index 0000000000..a927d44c99 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_addrinfo.c @@ -0,0 +1,632 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef HAVE_NETINET_IN_H +# include +#endif +#ifdef HAVE_NETINET_IN6_H +# include +#endif +#ifdef HAVE_NETDB_H +# include +#endif +#ifdef HAVE_ARPA_INET_H +# include +#endif +#ifdef HAVE_SYS_UN_H +# include +#endif + +#ifdef __VMS +# include +# include +#endif + +#include /* for offsetof() */ + +#include "curl_addrinfo.h" +#include "fake_addrinfo.h" +#include "curlx/inet_pton.h" +#include "curlx/strparse.h" + +/* + * Curl_freeaddrinfo() + * + * This is used to free a linked list of Curl_addrinfo structs along + * with all its associated allocated storage. This function should be + * called once for each successful call to Curl_getaddrinfo_ex() or to + * any function call which actually allocates a Curl_addrinfo struct. + */ + +#if defined(__INTEL_COMPILER) && (__INTEL_COMPILER == 910) && \ + defined(__OPTIMIZE__) && defined(__unix__) && defined(__i386__) + /* workaround icc 9.1 optimizer issue */ +# define vqualifier volatile +#else +# define vqualifier +#endif + +void Curl_freeaddrinfo(struct Curl_addrinfo *cahead) +{ + struct Curl_addrinfo *vqualifier canext; + struct Curl_addrinfo *ca; + + for(ca = cahead; ca; ca = canext) { + canext = ca->ai_next; + curlx_free(ca); + } +} + +#ifdef HAVE_GETADDRINFO +/* + * Curl_getaddrinfo_ex() + * + * This is a wrapper function around system's getaddrinfo(), with + * the only difference that instead of returning a linked list of + * addrinfo structs this one returns a linked list of Curl_addrinfo + * ones. The memory allocated by this function *MUST* be free'd with + * Curl_freeaddrinfo(). For each successful call to this function + * there must be an associated call later to Curl_freeaddrinfo(). + * + * There should be no single call to system's getaddrinfo() in the + * whole library, any such call should be 'routed' through this one. + */ +int Curl_getaddrinfo_ex(const char *nodename, + const char *servname, + const struct addrinfo *hints, + struct Curl_addrinfo **result) +{ + const struct addrinfo *ai; + struct addrinfo *aihead; + struct Curl_addrinfo *cafirst = NULL; + struct Curl_addrinfo *calast = NULL; + struct Curl_addrinfo *ca; + size_t ss_size; + int error; + + *result = NULL; /* assume failure */ + + error = CURL_GETADDRINFO(nodename, servname, hints, &aihead); + if(error) + return error; + + /* traverse the addrinfo list */ + + for(ai = aihead; ai; ai = ai->ai_next) { + size_t namelen = ai->ai_canonname ? strlen(ai->ai_canonname) + 1 : 0; + /* ignore elements with unsupported address family, + settle family-specific sockaddr structure size. */ + if(ai->ai_family == AF_INET) + ss_size = sizeof(struct sockaddr_in); +#ifdef USE_IPV6 + else if(ai->ai_family == AF_INET6) + ss_size = sizeof(struct sockaddr_in6); +#endif + else + continue; + + /* ignore elements without required address info */ + if(!ai->ai_addr || !(ai->ai_addrlen > 0)) + continue; + + /* ignore elements with bogus address size */ + if((size_t)ai->ai_addrlen < ss_size) + continue; + + ca = curlx_malloc(sizeof(struct Curl_addrinfo) + ss_size + namelen); + if(!ca) { + error = EAI_MEMORY; + break; + } + + /* copy each structure member individually, member ordering, + size, or padding might be different for each platform. */ + + ca->ai_flags = ai->ai_flags; + ca->ai_family = ai->ai_family; + ca->ai_socktype = ai->ai_socktype; + ca->ai_protocol = ai->ai_protocol; + ca->ai_addrlen = (curl_socklen_t)ss_size; + ca->ai_addr = NULL; + ca->ai_canonname = NULL; + ca->ai_next = NULL; + + ca->ai_addr = (void *)((char *)ca + sizeof(struct Curl_addrinfo)); + memcpy(ca->ai_addr, ai->ai_addr, ss_size); + + if(namelen) { + ca->ai_canonname = (void *)((char *)ca->ai_addr + ss_size); + memcpy(ca->ai_canonname, ai->ai_canonname, namelen); + } + + /* if the return list is empty, this becomes the first element */ + if(!cafirst) + cafirst = ca; + + /* add this element last in the return list */ + if(calast) + calast->ai_next = ca; + calast = ca; + } + + /* destroy the addrinfo list */ + if(aihead) + CURL_FREEADDRINFO(aihead); + + /* if we failed, also destroy the Curl_addrinfo list */ + if(error) { + Curl_freeaddrinfo(cafirst); + cafirst = NULL; + } + else if(!cafirst) { +#ifdef EAI_NONAME + /* rfc3493 conformant */ + error = EAI_NONAME; +#else + /* rfc3493 obsoleted */ + error = EAI_NODATA; +#endif +#ifdef USE_WINSOCK + SET_SOCKERRNO(error); +#endif + } + + *result = cafirst; + + /* This is not a CURLcode */ + return error; +} +#endif /* HAVE_GETADDRINFO */ + +/* + * Curl_he2ai() + * + * This function returns a pointer to the first element of a newly allocated + * Curl_addrinfo struct linked list filled with the data of a given hostent. + * Curl_addrinfo is meant to work like the addrinfo struct does for an IPv6 + * stack, but usable also for IPv4, all hosts and environments. + * + * The memory allocated by this function *MUST* be free'd later on calling + * Curl_freeaddrinfo(). For each successful call to this function there + * must be an associated call later to Curl_freeaddrinfo(). + * + * Curl_addrinfo defined in "lib/curl_addrinfo.h" + * + * struct Curl_addrinfo { + * int ai_flags; + * int ai_family; + * int ai_socktype; + * int ai_protocol; + * curl_socklen_t ai_addrlen; * Follow rfc3493 struct addrinfo * + * char *ai_canonname; + * struct sockaddr *ai_addr; + * struct Curl_addrinfo *ai_next; + * }; + * + * hostent defined in + * + * struct hostent { + * char *h_name; + * char **h_aliases; + * int h_addrtype; + * int h_length; + * char **h_addr_list; + * }; + * + * for backward compatibility: + * + * #define h_addr h_addr_list[0] + */ +#if !(defined(HAVE_GETADDRINFO) && defined(HAVE_GETADDRINFO_THREADSAFE)) +struct Curl_addrinfo *Curl_he2ai(const struct hostent *he, int port) +{ + struct Curl_addrinfo *ai; + struct Curl_addrinfo *prevai = NULL; + struct Curl_addrinfo *firstai = NULL; + struct sockaddr_in *addr; +#ifdef USE_IPV6 + struct sockaddr_in6 *addr6; +#endif + CURLcode result = CURLE_OK; + int i; + char *curr; + + if(!he) + /* no input == no output! */ + return NULL; + + DEBUGASSERT(he->h_name && he->h_addr_list); + + for(i = 0; (curr = he->h_addr_list[i]) != NULL; i++) { + size_t ss_size; + size_t namelen = strlen(he->h_name) + 1; /* include null-terminator */ +#ifdef USE_IPV6 + if(he->h_addrtype == AF_INET6) + ss_size = sizeof(struct sockaddr_in6); + else +#endif + ss_size = sizeof(struct sockaddr_in); + + /* allocate memory to hold the struct, the address and the name */ + ai = curlx_calloc(1, sizeof(struct Curl_addrinfo) + ss_size + namelen); + if(!ai) { + result = CURLE_OUT_OF_MEMORY; + break; + } + /* put the address after the struct */ + ai->ai_addr = (void *)((char *)ai + sizeof(struct Curl_addrinfo)); + /* then put the name after the address */ + ai->ai_canonname = (char *)ai->ai_addr + ss_size; + memcpy(ai->ai_canonname, he->h_name, namelen); + + if(!firstai) + /* store the pointer we want to return from this function */ + firstai = ai; + + if(prevai) + /* make the previous entry point to this */ + prevai->ai_next = ai; + + ai->ai_family = he->h_addrtype; + + /* we return all names as STREAM, so when using this address for TFTP + the type must be ignored and conn->socktype be used instead! */ + ai->ai_socktype = SOCK_STREAM; + + ai->ai_addrlen = (curl_socklen_t)ss_size; + + /* leave the rest of the struct filled with zero */ + + switch(ai->ai_family) { + case AF_INET: + addr = (void *)ai->ai_addr; /* storage area for this info */ + + memcpy(&addr->sin_addr, curr, sizeof(struct in_addr)); + addr->sin_family = (CURL_SA_FAMILY_T)(he->h_addrtype); + addr->sin_port = htons((unsigned short)port); + break; + +#ifdef USE_IPV6 + case AF_INET6: + addr6 = (void *)ai->ai_addr; /* storage area for this info */ + + memcpy(&addr6->sin6_addr, curr, sizeof(struct in6_addr)); + addr6->sin6_family = (CURL_SA_FAMILY_T)(he->h_addrtype); + addr6->sin6_port = htons((unsigned short)port); + break; +#endif + } + + prevai = ai; + } + + if(result) { + Curl_freeaddrinfo(firstai); + firstai = NULL; + } + + return firstai; +} +#endif + +/* + * ip2addr() + * + * This function takes an Internet address, in binary form, as input parameter + * along with its address family and the string version of the address, and it + * returns a Curl_addrinfo chain filled in correctly with information for the + * given address/host + */ +static CURLcode ip2addr(struct Curl_addrinfo **addrp, int af, + const void *inaddr, const char *hostname, int port) +{ + struct Curl_addrinfo *ai; + size_t addrsize; + size_t namelen; + struct sockaddr_in *addr; +#ifdef USE_IPV6 + struct sockaddr_in6 *addr6; +#endif + + DEBUGASSERT(inaddr && hostname); + + namelen = strlen(hostname) + 1; + *addrp = NULL; + + if(af == AF_INET) + addrsize = sizeof(struct sockaddr_in); +#ifdef USE_IPV6 + else if(af == AF_INET6) + addrsize = sizeof(struct sockaddr_in6); +#endif + else + return CURLE_BAD_FUNCTION_ARGUMENT; + + /* allocate memory to hold the struct, the address and the name */ + ai = curlx_calloc(1, sizeof(struct Curl_addrinfo) + addrsize + namelen); + if(!ai) + return CURLE_OUT_OF_MEMORY; + /* put the address after the struct */ + ai->ai_addr = (void *)((char *)ai + sizeof(struct Curl_addrinfo)); + /* then put the name after the address */ + ai->ai_canonname = (char *)ai->ai_addr + addrsize; + memcpy(ai->ai_canonname, hostname, namelen); + ai->ai_family = af; + ai->ai_socktype = SOCK_STREAM; + ai->ai_addrlen = (curl_socklen_t)addrsize; + /* leave the rest of the struct filled with zero */ + + switch(af) { + case AF_INET: + addr = (void *)ai->ai_addr; /* storage area for this info */ + + memcpy(&addr->sin_addr, inaddr, sizeof(struct in_addr)); + addr->sin_family = (CURL_SA_FAMILY_T)af; + addr->sin_port = htons((unsigned short)port); + break; + +#ifdef USE_IPV6 + case AF_INET6: + addr6 = (void *)ai->ai_addr; /* storage area for this info */ + + memcpy(&addr6->sin6_addr, inaddr, sizeof(struct in6_addr)); + addr6->sin6_family = (CURL_SA_FAMILY_T)af; + addr6->sin6_port = htons((unsigned short)port); + break; +#endif + } + *addrp = ai; + return CURLE_OK; +} + +/* + * Given an IPv4 or IPv6 dotted string address, this converts it to a proper + * allocated Curl_addrinfo struct and returns it. + */ +CURLcode Curl_str2addr(const char *dotted, uint16_t port, + struct Curl_addrinfo **addrp) +{ + struct in_addr in; + if(curlx_inet_pton(AF_INET, dotted, &in) > 0) + /* This is a dotted IP address 123.123.123.123-style */ + return ip2addr(addrp, AF_INET, &in, dotted, port); +#ifdef USE_IPV6 + { + struct in6_addr in6; + if(curlx_inet_pton(AF_INET6, dotted, &in6) > 0) + /* This is a dotted IPv6 address ::1-style */ + return ip2addr(addrp, AF_INET6, &in6, dotted, port); + } +#endif + return CURLE_BAD_FUNCTION_ARGUMENT; /* bad input format */ +} + +bool Curl_is_ipv4addr(const char *address) +{ + struct in_addr in; + return (curlx_inet_pton(AF_INET, address, &in) > 0); +} + +bool Curl_is_ipaddr(const char *address) +{ + if(Curl_is_ipv4addr(address)) + return TRUE; +#ifdef USE_IPV6 + { + struct in6_addr in6; + if(curlx_inet_pton(AF_INET6, address, &in6) > 0) + /* This is a dotted IPv6 address ::1-style */ + return TRUE; + } +#endif + return FALSE; +} + +bool Curl_looks_like_ipv6(const char *s, size_t len, bool maybe_url_encoded, + struct Curl_str *host, struct Curl_str *zone) +{ + const char *zonep = NULL; + size_t i = 0, hlen = 0, zlen = 0; + + if(host) + memset(host, 0, sizeof(*host)); + if(zone) + memset(zone, 0, sizeof(*zone)); + + for(i = 0; i < len; ++i, ++hlen) { + if(!s[i] || !(ISXDIGIT(s[i]) || (s[i] == ':') || (s[i] == '.'))) + break; + } + + if((i < len) && (s[i] == '%')) { /* address followed by a zone? */ + i += 1; + if(maybe_url_encoded && !strncmp("25", s + i, 2)) + i += 2; + zonep = s + i; + for(; i < len; ++i, ++zlen) { + /* Allow unreserved characters as defined in RFC 3986 */ + if(!s[i] || !(ISALPHA(s[i]) || ISXDIGIT(s[i]) || (s[i] == '-') || + (s[i] == '.') || (s[i] == '_') || (s[i] == '~'))) + break; + } + } + + if(i != len) + return FALSE; /* invalid chars in zone */ + if(host && hlen) { + host->str = s; + host->len = hlen; + } + if(zone && zlen) { + zone->str = zonep; + zone->len = zlen; + } + return TRUE; +} + +#ifdef USE_UNIX_SOCKETS +/** + * Given a path to a Unix domain socket, return a newly allocated Curl_addrinfo + * struct initialized with this path. + * Returns CURLE_TOO_LARGE when path is too long. + */ +CURLcode Curl_unix2addr(const char *path, bool abstract, + struct Curl_addrinfo **paddr) +{ + struct Curl_addrinfo *ai; + struct sockaddr_un *sa_un; + size_t path_len; + + *paddr = NULL; + + /* sun_path must be able to store the null-terminated path */ + path_len = strlen(path) + 1; + if(path_len > sizeof(sa_un->sun_path)) + return CURLE_TOO_LARGE; + + ai = curlx_calloc(1, + sizeof(struct Curl_addrinfo) + sizeof(struct sockaddr_un)); + if(!ai) + return CURLE_OUT_OF_MEMORY; + + ai->ai_addr = (void *)((char *)ai + sizeof(struct Curl_addrinfo)); + sa_un = (void *)ai->ai_addr; + sa_un->sun_family = AF_UNIX; + + ai->ai_family = AF_UNIX; + ai->ai_socktype = SOCK_STREAM; /* assume reliable transport for HTTP */ + ai->ai_addrlen = (curl_socklen_t) + ((offsetof(struct sockaddr_un, sun_path) + path_len) & 0x7FFFFFFF); + + /* Abstract Unix domain socket have NULL prefix instead of suffix */ + if(abstract) + memcpy(sa_un->sun_path + 1, path, path_len - 1); + else + memcpy(sa_un->sun_path, path, path_len); /* copy NUL byte */ + + *paddr = ai; + return CURLE_OK; +} +#endif + +#if defined(CURL_MEMDEBUG) && defined(HAVE_GETADDRINFO) && \ + defined(HAVE_FREEADDRINFO) +/* + * curl_dbg_freeaddrinfo() + * + * This is strictly for memory tracing and are using the same style as the + * family otherwise present in memdebug.c. I put these ones here since they + * require a bunch of structs I did not want to include in memdebug.c + */ +void curl_dbg_freeaddrinfo(struct addrinfo *freethis, + int line, const char *source) +{ + curl_dbg_log("ADDR %s:%d freeaddrinfo(%p)\n", + source, line, (void *)freethis); +#ifdef USE_LWIPSOCK + lwip_freeaddrinfo(freethis); +#elif defined(USE_FAKE_GETADDRINFO) + { + const char *env = getenv("CURL_DNS_SERVER"); + if(env) + r_freeaddrinfo(freethis); + else + /* !checksrc! disable BANNEDFUNC 1 */ + freeaddrinfo(freethis); + } +#else + /* !checksrc! disable BANNEDFUNC 1 */ + freeaddrinfo(freethis); +#endif +} +#endif /* CURL_MEMDEBUG && HAVE_FREEADDRINFO */ + +#if defined(CURL_MEMDEBUG) && defined(HAVE_GETADDRINFO) +/* + * curl_dbg_getaddrinfo() + * + * This is strictly for memory tracing and are using the same style as the + * family otherwise present in memdebug.c. I put these ones here since they + * require a bunch of structs I did not want to include in memdebug.c + */ +int curl_dbg_getaddrinfo(const char *hostname, + const char *service, + const struct addrinfo *hints, + struct addrinfo **result, + int line, const char *source) +{ +#ifdef USE_LWIPSOCK + int res = lwip_getaddrinfo(hostname, service, hints, result); +#elif defined(USE_FAKE_GETADDRINFO) + int res; + const char *env = getenv("CURL_DNS_SERVER"); + if(env) + res = r_getaddrinfo(hostname, service, hints, result); + else + /* !checksrc! disable BANNEDFUNC 1 */ + res = getaddrinfo(hostname, service, hints, result); +#else + /* !checksrc! disable BANNEDFUNC 1 */ + int res = getaddrinfo(hostname, service, hints, result); +#endif + if(res == 0) + /* success */ + curl_dbg_log("ADDR %s:%d getaddrinfo() = %p\n", source, line, + (void *)*result); + else + curl_dbg_log("ADDR %s:%d getaddrinfo() failed\n", source, line); + return res; +} +#endif /* CURL_MEMDEBUG && HAVE_GETADDRINFO */ + +#if defined(HAVE_GETADDRINFO) && defined(USE_RESOLVE_ON_IPS) +/* + * Works around the sin6_port is always zero bug on iOS 9.3.2 and macOS + * 10.11.5. + */ +void Curl_addrinfo_set_port(struct Curl_addrinfo *addrinfo, int port) +{ + struct Curl_addrinfo *ca; + struct sockaddr_in *addr; +#ifdef USE_IPV6 + struct sockaddr_in6 *addr6; +#endif + for(ca = addrinfo; ca; ca = ca->ai_next) { + switch(ca->ai_family) { + case AF_INET: + addr = (void *)ca->ai_addr; /* storage area for this info */ + addr->sin_port = htons((unsigned short)port); + break; + +#ifdef USE_IPV6 + case AF_INET6: + addr6 = (void *)ca->ai_addr; /* storage area for this info */ + addr6->sin6_port = htons((unsigned short)port); + break; +#endif + } + } +} +#endif diff --git a/3rdparty/curl-8.21.0/lib/curl_addrinfo.h b/3rdparty/curl-8.21.0/lib/curl_addrinfo.h new file mode 100644 index 0000000000..046be23816 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_addrinfo.h @@ -0,0 +1,110 @@ +#ifndef HEADER_CURL_ADDRINFO_H +#define HEADER_CURL_ADDRINFO_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef HAVE_NETINET_IN_H +# include +#endif +#ifdef HAVE_NETDB_H +# include +#endif +#ifdef HAVE_ARPA_INET_H +# include +#endif + +#ifdef __VMS +# include +# include +#endif + +struct Curl_str; + +/* + * Curl_addrinfo is our internal struct definition that we use to allow + * consistent internal handling of this data. We use this even when the system + * provides an addrinfo structure definition. We use this for all sorts of + * IPv4 and IPV6 builds. + */ + +struct Curl_addrinfo { + int ai_flags; + int ai_family; + int ai_socktype; + int ai_protocol; + curl_socklen_t ai_addrlen; /* Follow rfc3493 struct addrinfo */ + char *ai_canonname; + struct sockaddr *ai_addr; + struct Curl_addrinfo *ai_next; +}; + +void Curl_freeaddrinfo(struct Curl_addrinfo *cahead); + +#ifdef HAVE_GETADDRINFO +int Curl_getaddrinfo_ex(const char *nodename, + const char *servname, + const struct addrinfo *hints, + struct Curl_addrinfo **result); +#endif + +#if !(defined(HAVE_GETADDRINFO) && defined(HAVE_GETADDRINFO_THREADSAFE)) +struct Curl_addrinfo *Curl_he2ai(const struct hostent *he, int port); +#endif + +bool Curl_is_ipv4addr(const char *address); +bool Curl_is_ipaddr(const char *address); +bool Curl_looks_like_ipv6(const char *s, size_t len, bool maybe_url_encoded, + struct Curl_str *host, struct Curl_str *zone); + +CURLcode Curl_str2addr(const char *dotted, uint16_t port, + struct Curl_addrinfo **addrp); + +#ifdef USE_UNIX_SOCKETS +CURLcode Curl_unix2addr(const char *path, bool abstract, + struct Curl_addrinfo **paddr); +#endif + +#if defined(CURL_MEMDEBUG) && defined(HAVE_GETADDRINFO) && \ + defined(HAVE_FREEADDRINFO) +void curl_dbg_freeaddrinfo(struct addrinfo *freethis, int line, + const char *source); +#endif + +#if defined(CURL_MEMDEBUG) && defined(HAVE_GETADDRINFO) +int curl_dbg_getaddrinfo(const char *hostname, const char *service, + const struct addrinfo *hints, + struct addrinfo **result, int line, + const char *source); +#endif + +#ifdef HAVE_GETADDRINFO +#ifdef USE_RESOLVE_ON_IPS +void Curl_addrinfo_set_port(struct Curl_addrinfo *addrinfo, int port); +#else +#define Curl_addrinfo_set_port(x, y) +#endif +#endif + +#endif /* HEADER_CURL_ADDRINFO_H */ diff --git a/3rdparty/curl-8.21.0/lib/curl_config-cmake.h.in b/3rdparty/curl-8.21.0/lib/curl_config-cmake.h.in new file mode 100644 index 0000000000..c38caa2a03 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_config-cmake.h.in @@ -0,0 +1,801 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +/* Location of default CA bundle */ +#cmakedefine CURL_CA_BUNDLE "${CURL_CA_BUNDLE}" + +/* define "1" to use built-in CA store of TLS backend */ +#cmakedefine CURL_CA_FALLBACK 1 + +/* Location of default CA path */ +#cmakedefine CURL_CA_PATH "${CURL_CA_PATH}" + +/* Default SSL backend */ +#cmakedefine CURL_DEFAULT_SSL_BACKEND "${CURL_DEFAULT_SSL_BACKEND}" + +/* Use native CA store */ +#cmakedefine CURL_CA_NATIVE 1 + +/* disables alt-svc */ +#cmakedefine CURL_DISABLE_ALTSVC 1 + +/* disables cookies support */ +#cmakedefine CURL_DISABLE_COOKIES 1 + +/* disables Basic authentication */ +#cmakedefine CURL_DISABLE_BASIC_AUTH 1 + +/* disables Bearer authentication */ +#cmakedefine CURL_DISABLE_BEARER_AUTH 1 + +/* disables Digest authentication */ +#cmakedefine CURL_DISABLE_DIGEST_AUTH 1 + +/* disables Kerberos authentication */ +#cmakedefine CURL_DISABLE_KERBEROS_AUTH 1 + +/* disables negotiate authentication */ +#cmakedefine CURL_DISABLE_NEGOTIATE_AUTH 1 + +/* disables aws-sigv4 */ +#cmakedefine CURL_DISABLE_AWS 1 + +/* disables DICT */ +#cmakedefine CURL_DISABLE_DICT 1 + +/* disables DNS-over-HTTPS */ +#cmakedefine CURL_DISABLE_DOH 1 + +/* disables FILE */ +#cmakedefine CURL_DISABLE_FILE 1 + +/* disables form api */ +#cmakedefine CURL_DISABLE_FORM_API 1 + +/* disables FTP */ +#cmakedefine CURL_DISABLE_FTP 1 + +/* disables curl_easy_options API for existing options to curl_easy_setopt */ +#cmakedefine CURL_DISABLE_GETOPTIONS 1 + +/* disables GOPHER */ +#cmakedefine CURL_DISABLE_GOPHER 1 + +/* disables headers-api support */ +#cmakedefine CURL_DISABLE_HEADERS_API 1 + +/* disables HSTS support */ +#cmakedefine CURL_DISABLE_HSTS 1 + +/* disables HTTP */ +#cmakedefine CURL_DISABLE_HTTP 1 + +/* disabled all HTTP authentication methods */ +#cmakedefine CURL_DISABLE_HTTP_AUTH 1 + +/* disables IMAP */ +#cmakedefine CURL_DISABLE_IMAP 1 + +/* disables LDAP */ +#cmakedefine CURL_DISABLE_LDAP 1 + +/* disables LDAPS */ +#cmakedefine CURL_DISABLE_LDAPS 1 + +/* disables --libcurl option from the curl tool */ +#cmakedefine CURL_DISABLE_LIBCURL_OPTION 1 + +/* disables MIME support */ +#cmakedefine CURL_DISABLE_MIME 1 + +/* disables local binding support */ +#cmakedefine CURL_DISABLE_BINDLOCAL 1 + +/* disables MQTT */ +#cmakedefine CURL_DISABLE_MQTT 1 + +/* disables netrc parser */ +#cmakedefine CURL_DISABLE_NETRC 1 + +/* enables NTLM support */ +#cmakedefine CURL_ENABLE_NTLM 1 + +/* disables date parsing */ +#cmakedefine CURL_DISABLE_PARSEDATE 1 + +/* disables POP3 */ +#cmakedefine CURL_DISABLE_POP3 1 + +/* disables built-in progress meter */ +#cmakedefine CURL_DISABLE_PROGRESS_METER 1 + +/* disables proxies */ +#cmakedefine CURL_DISABLE_PROXY 1 + +/* disables IPFS from the curl tool */ +#cmakedefine CURL_DISABLE_IPFS 1 + +/* disables RTSP */ +#cmakedefine CURL_DISABLE_RTSP 1 + +/* disables SHA-512/256 hash algorithm */ +#cmakedefine CURL_DISABLE_SHA512_256 1 + +/* disabled shuffle DNS feature */ +#cmakedefine CURL_DISABLE_SHUFFLE_DNS 1 + +/* disables SMB */ +#cmakedefine CURL_ENABLE_SMB 1 + +/* disables SMTP */ +#cmakedefine CURL_DISABLE_SMTP 1 + +/* disabled WebSocket */ +#cmakedefine CURL_DISABLE_WEBSOCKETS 1 + +/* disables use of socketpair for curl_multi_poll() */ +#cmakedefine CURL_DISABLE_SOCKETPAIR 1 + +/* disables TELNET */ +#cmakedefine CURL_DISABLE_TELNET 1 + +/* disables TFTP */ +#cmakedefine CURL_DISABLE_TFTP 1 + +/* disables verbose strings */ +#cmakedefine CURL_DISABLE_VERBOSE_STRINGS 1 + +/* disables unsafe CA bundle search on Windows from the curl tool */ +#cmakedefine CURL_DISABLE_CA_SEARCH 1 + +/* safe CA bundle search (within the curl tool directory) on Windows */ +#cmakedefine CURL_CA_SEARCH_SAFE 1 + +/* to make a symbol visible */ +#cmakedefine CURL_EXTERN_SYMBOL ${CURL_EXTERN_SYMBOL} +/* Ensure using CURL_EXTERN_SYMBOL is possible */ +#ifndef CURL_EXTERN_SYMBOL +#define CURL_EXTERN_SYMBOL +#endif + +/* Allow SMB to work on Windows */ +#cmakedefine USE_WIN32_CRYPTO 1 + +/* Use Windows LDAP implementation */ +#cmakedefine USE_WIN32_LDAP 1 + +/* Define if you want to enable IPv6 support */ +#cmakedefine USE_IPV6 1 + +/* Define to 1 if you have the alarm function. */ +#cmakedefine HAVE_ALARM 1 + +/* Define to 1 if you have the arc4random function. */ +#cmakedefine HAVE_ARC4RANDOM 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_ARPA_INET_H 1 + +/* Define to 1 if you have _Atomic support. */ +#cmakedefine HAVE_ATOMIC 1 + +/* Define to 1 if you have the `accept4' function. */ +#cmakedefine HAVE_ACCEPT4 1 + +/* Define to 1 if you have the `fnmatch' function. */ +#cmakedefine HAVE_FNMATCH 1 + +/* Define to 1 if you have the `basename' function. */ +#cmakedefine HAVE_BASENAME 1 + +/* Define to 1 if bool is an available type. */ +#cmakedefine HAVE_BOOL_T 1 + +/* Define to 1 if you have the __builtin_available function. */ +#cmakedefine HAVE_BUILTIN_AVAILABLE 1 + +/* Define to 1 if you have the clock_gettime function and monotonic timer. */ +#cmakedefine HAVE_CLOCK_GETTIME_MONOTONIC 1 + +/* Define to 1 if you have the clock_gettime function and raw monotonic timer. + */ +#cmakedefine HAVE_CLOCK_GETTIME_MONOTONIC_RAW 1 + +/* Define to 1 if you have the `closesocket' function. */ +#cmakedefine HAVE_CLOSESOCKET 1 + +/* Define to 1 if you have the `CloseSocket' function. */ +#cmakedefine HAVE_CLOSESOCKET_CAMEL 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_DIRENT_H 1 + +/* Define to 1 if you have the `opendir' function. */ +#cmakedefine HAVE_OPENDIR 1 + +/* Define to 1 if you have the memset_explicit (C23) function. */ +#cmakedefine HAVE_MEMSET_EXPLICIT 1 + +/* Define to 1 if you have the memset_s (C11) function. */ +#cmakedefine HAVE_MEMSET_S 1 + +/* Define to 1 if you have the fcntl function. */ +#cmakedefine HAVE_FCNTL 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_FCNTL_H 1 + +/* Define to 1 if you have a working fcntl O_NONBLOCK function. */ +#cmakedefine HAVE_FCNTL_O_NONBLOCK 1 + +/* Define to 1 if you have the freeaddrinfo function. */ +#cmakedefine HAVE_FREEADDRINFO 1 + +/* Define to 1 if you have the fseeko function. */ +#cmakedefine HAVE_FSEEKO 1 + +/* Define to 1 if you have the fseeko declaration. */ +#cmakedefine HAVE_DECL_FSEEKO 1 + +/* Define to 1 if you have a working getaddrinfo function. */ +#cmakedefine HAVE_GETADDRINFO 1 + +/* Define to 1 if the getaddrinfo function is thread-safe. */ +#cmakedefine HAVE_GETADDRINFO_THREADSAFE 1 + +/* Define to 1 if you have the `geteuid' function. */ +#cmakedefine HAVE_GETEUID 1 + +/* Define to 1 if you have the `getppid' function. */ +#cmakedefine HAVE_GETPPID 1 + +/* Define to 1 if you have the gethostbyname_r function. */ +#cmakedefine HAVE_GETHOSTBYNAME_R 1 + +/* gethostbyname_r() takes 3 args */ +#cmakedefine HAVE_GETHOSTBYNAME_R_3 1 + +/* gethostbyname_r() takes 5 args */ +#cmakedefine HAVE_GETHOSTBYNAME_R_5 1 + +/* gethostbyname_r() takes 6 args */ +#cmakedefine HAVE_GETHOSTBYNAME_R_6 1 + +/* Define to 1 if you have the gethostname function. */ +#cmakedefine HAVE_GETHOSTNAME 1 + +/* Define to 1 if you have a working getifaddrs function. */ +#cmakedefine HAVE_GETIFADDRS 1 + +/* Define to 1 if you have the `getpass_r' function. */ +#cmakedefine HAVE_GETPASS_R 1 + +/* Define to 1 if you have the `getpeername' function. */ +#cmakedefine HAVE_GETPEERNAME 1 + +/* Define to 1 if you have the `getsockname' function. */ +#cmakedefine HAVE_GETSOCKNAME 1 + +/* Define to 1 if you have the `if_nametoindex' function. */ +#cmakedefine HAVE_IF_NAMETOINDEX 1 + +/* Define to 1 if you have the `getpwuid' function. */ +#cmakedefine HAVE_GETPWUID 1 + +/* Define to 1 if you have the `getpwuid_r' function. */ +#cmakedefine HAVE_GETPWUID_R 1 + +/* Define to 1 if you have the `getrlimit' function. */ +#cmakedefine HAVE_GETRLIMIT 1 + +/* Define to 1 if you have the `gettimeofday' function. */ +#cmakedefine HAVE_GETTIMEOFDAY 1 + +/* Define to 1 if you have a working glibc-style strerror_r function. */ +#cmakedefine HAVE_GLIBC_STRERROR_R 1 + +/* Define to 1 if you have a working gmtime_r function. */ +#cmakedefine HAVE_GMTIME_R 1 + +/* if you have the gssapi libraries */ +#cmakedefine HAVE_GSSAPI 1 + +/* if you have the GNU gssapi libraries */ +#cmakedefine HAVE_GSSGNU 1 + +/* MIT Kerberos version */ +#cmakedefine CURL_KRB5_VERSION ${CURL_KRB5_VERSION} + +/* BoringSSL version */ +#cmakedefine CURL_BORINGSSL_VERSION ${CURL_BORINGSSL_VERSION} + +/* Patch stamp */ +#cmakedefine CURL_PATCHSTAMP ${CURL_PATCHSTAMP} + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_IFADDRS_H 1 + +/* Define to 1 if you have an IPv6 capable working inet_ntop function. */ +#cmakedefine HAVE_INET_NTOP 1 + +/* Define to 1 if you have an IPv6 capable working inet_pton function. */ +#cmakedefine HAVE_INET_PTON 1 + +/* Define to 1 if symbol `sa_family_t' exists */ +#cmakedefine HAVE_SA_FAMILY_T 1 + +/* Define to 1 if you have the ioctlsocket function. */ +#cmakedefine HAVE_IOCTLSOCKET 1 + +/* Define to 1 if you have the IoctlSocket camel case function. */ +#cmakedefine HAVE_IOCTLSOCKET_CAMEL 1 + +/* Define to 1 if you have a working IoctlSocket camel case FIONBIO function. + */ +#cmakedefine HAVE_IOCTLSOCKET_CAMEL_FIONBIO 1 + +/* Define to 1 if you have a working ioctlsocket FIONBIO function. */ +#cmakedefine HAVE_IOCTLSOCKET_FIONBIO 1 + +/* Define to 1 if you have a working ioctl FIONBIO function. */ +#cmakedefine HAVE_IOCTL_FIONBIO 1 + +/* Define to 1 if you have a working ioctl SIOCGIFADDR function. */ +#cmakedefine HAVE_IOCTL_SIOCGIFADDR 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_IO_H 1 + +/* Define to 1 if you have the lber.h header file. */ +#cmakedefine HAVE_LBER_H 1 + +/* Use LDAPS implementation */ +#cmakedefine HAVE_LDAP_SSL 1 + +/* Define to 1 if you have the ldap_ssl.h header file. */ +#cmakedefine HAVE_LDAP_SSL_H 1 + +/* Define to 1 if you have the `ldap_url_parse' function. */ +#cmakedefine HAVE_LDAP_URL_PARSE 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_LIBGEN_H 1 + +/* Define to 1 if you have the `idn2' library (-lidn2). */ +#cmakedefine HAVE_LIBIDN2 1 + +/* Define to 1 if you have the idn2.h header file. */ +#cmakedefine HAVE_IDN2_H 1 + +/* if zlib is available */ +#cmakedefine HAVE_LIBZ 1 + +/* if brotli is available */ +#cmakedefine HAVE_BROTLI 1 + +/* if zstd is available */ +#cmakedefine HAVE_ZSTD 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_LOCALE_H 1 + +/* Define to 1 if you have a working localtime_r function. */ +#cmakedefine HAVE_LOCALTIME_R 1 + +/* Define to 1 if you have the 'suseconds_t' data type. */ +#cmakedefine HAVE_SUSECONDS_T 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_NETDB_H 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_NETINET_IN_H 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_NETINET_IN6_H 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_NETINET_TCP_H 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_NETINET_UDP_H 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_LINUX_TCP_H 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_NET_IF_H 1 + +/* Define to 1 if you have the `pipe' function. */ +#cmakedefine HAVE_PIPE 1 + +/* Define to 1 if you have the `pipe2' function. */ +#cmakedefine HAVE_PIPE2 1 + +/* Define to 1 if you have the `eventfd' function. */ +#cmakedefine HAVE_EVENTFD 1 + +/* If you have poll */ +#cmakedefine HAVE_POLL 1 + +/* If you have realpath */ +#cmakedefine HAVE_REALPATH 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_POLL_H 1 + +/* Define to 1 if you have a working POSIX-style strerror_r function. */ +#cmakedefine HAVE_POSIX_STRERROR_R 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_PWD_H 1 + +/* Define to 1 if OpenSSL has the `SSL_set0_wbio` function. */ +#cmakedefine HAVE_SSL_SET0_WBIO 1 + +/* Define to 1 if you have the recv function. */ +#cmakedefine HAVE_RECV 1 + +/* Define to 1 if you have the select function. */ +#cmakedefine HAVE_SELECT 1 + +/* Define to 1 if you have the sched_yield function. */ +#cmakedefine HAVE_SCHED_YIELD 1 + +/* Define to 1 if you have the send function. */ +#cmakedefine HAVE_SEND 1 + +/* Define to 1 if you have the sendmsg function. */ +#cmakedefine HAVE_SENDMSG 1 + +/* Define to 1 if you have the sendmmsg function. */ +#cmakedefine HAVE_SENDMMSG 1 + +/* Define to 1 if you have the 'fsetxattr' function. */ +#cmakedefine HAVE_FSETXATTR 1 + +/* fsetxattr() takes 5 args */ +#cmakedefine HAVE_FSETXATTR_5 1 + +/* fsetxattr() takes 6 args */ +#cmakedefine HAVE_FSETXATTR_6 1 + +/* Define to 1 if you have the `setlocale' function. */ +#cmakedefine HAVE_SETLOCALE 1 + +/* Define to 1 if you have the `setrlimit' function. */ +#cmakedefine HAVE_SETRLIMIT 1 + +/* Define to 1 if you have a working setsockopt SO_NONBLOCK function. */ +#cmakedefine HAVE_SETSOCKOPT_SO_NONBLOCK 1 + +/* Define to 1 if you have the sigaction function. */ +#cmakedefine HAVE_SIGACTION 1 + +/* Define to 1 if you have the siginterrupt function. */ +#cmakedefine HAVE_SIGINTERRUPT 1 + +/* Define to 1 if you have the signal function. */ +#cmakedefine HAVE_SIGNAL 1 + +/* Define to 1 if you have the sigsetjmp function or macro. */ +#cmakedefine HAVE_SIGSETJMP 1 + +/* Define to 1 if struct sockaddr_in6 has the sin6_scope_id member */ +#cmakedefine HAVE_SOCKADDR_IN6_SIN6_SCOPE_ID 1 + +/* Define to 1 if you have the `socket' function. */ +#cmakedefine HAVE_SOCKET 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_PROTO_BSDSOCKET_H 1 + +/* Define to 1 if you have the socketpair function. */ +#cmakedefine HAVE_SOCKETPAIR 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_STDATOMIC_H 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_STDBOOL_H 1 + +/* Define to 1 if you have the strcasecmp function. */ +#cmakedefine HAVE_STRCASECMP 1 + +/* Define to 1 if you have the strcmpi function. */ +#cmakedefine HAVE_STRCMPI 1 + +/* Define to 1 if you have the strerror_r function. */ +#cmakedefine HAVE_STRERROR_R 1 + +/* Define to 1 if you have the stricmp function. */ +#cmakedefine HAVE_STRICMP 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_STRINGS_H 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_STROPTS_H 1 + +/* Define to 1 if you have the memrchr function. */ +#cmakedefine HAVE_MEMRCHR 1 + +/* if struct sockaddr_storage is defined */ +#cmakedefine HAVE_STRUCT_SOCKADDR_STORAGE 1 + +/* Define to 1 if you have the timeval struct. */ +#cmakedefine HAVE_STRUCT_TIMEVAL 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_SYS_EVENTFD_H 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_SYS_FILIO_H 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_SYS_IOCTL_H 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_SYS_PARAM_H 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_SYS_POLL_H 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_SYS_RESOURCE_H 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_SYS_SELECT_H 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_SYS_SOCKIO_H 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_SYS_TYPES_H 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_SYS_UN_H 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_SYS_UTIME_H 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_TERMIOS_H 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_TERMIO_H 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_UNISTD_H 1 + +/* Define to 1 if you have the `utime' function. */ +#cmakedefine HAVE_UTIME 1 + +/* Define to 1 if you have the `utimes' function. */ +#cmakedefine HAVE_UTIMES 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_UTIME_H 1 + +/* Define this symbol if your OS supports changing the contents of argv */ +#cmakedefine HAVE_WRITABLE_ARGV 1 + +/* Define this if time_t is unsigned */ +#cmakedefine HAVE_TIME_T_UNSIGNED 1 + +/* Define to 1 if _REENTRANT preprocessor symbol must be defined. */ +#cmakedefine NEED_REENTRANT 1 + +/* cpu-machine-OS */ +#cmakedefine CURL_OS ${CURL_OS} + +/* + Note: SIZEOF_* variables are fetched with CMake through check_type_size(). + As per CMake documentation on CheckTypeSize, C preprocessor code is + generated by CMake into SIZEOF_*_CODE. This is what we use in the + following statements. + + Reference: https://cmake.org/cmake/help/latest/module/CheckTypeSize.html +*/ + +/* The size of `int', as computed by sizeof. */ +${SIZEOF_INT_CODE} + +/* The size of `long', as computed by sizeof. */ +${SIZEOF_LONG_CODE} + +/* The size of `off_t', as computed by sizeof. */ +${SIZEOF_OFF_T_CODE} + +/* The size of `curl_off_t', as computed by sizeof. */ +${SIZEOF_CURL_OFF_T_CODE} + +/* The size of `curl_socket_t', as computed by sizeof. */ +${SIZEOF_CURL_SOCKET_T_CODE} + +/* The size of `size_t', as computed by sizeof. */ +${SIZEOF_SIZE_T_CODE} + +/* The size of `time_t', as computed by sizeof. */ +${SIZEOF_TIME_T_CODE} + +/* Define to 1 if you have the ANSI C header files. */ +#cmakedefine STDC_HEADERS 1 + +/* Define if you have POSIX pthreads */ +#cmakedefine HAVE_THREADS_POSIX 1 + +/* Define if you want to enable c-ares support */ +#cmakedefine USE_ARES 1 + +/* Define if you want to enable c-ares DNS lookup */ +#cmakedefine USE_RESOLV_ARES 1 + +/* Define if you want to enable threaded DNS lookup */ +#cmakedefine USE_RESOLV_THREADED 1 + +/* if GnuTLS is enabled */ +#cmakedefine USE_GNUTLS 1 + +/* if SSL session export support is available */ +#cmakedefine USE_SSLS_EXPORT 1 + +/* if mbedTLS is enabled */ +#cmakedefine USE_MBEDTLS 1 + +/* if mbedTLS <4 has the mbedtls_des_crypt_ecb function. */ +#cmakedefine HAVE_MBEDTLS_DES_CRYPT_ECB 1 + +/* if Rustls is enabled */ +#cmakedefine USE_RUSTLS 1 + +/* if wolfSSL is enabled */ +#cmakedefine USE_WOLFSSL 1 + +/* if wolfSSL has the wolfSSL_get_peer_certificate function. */ +#cmakedefine HAVE_WOLFSSL_GET_PEER_CERTIFICATE 1 + +/* if wolfSSL has the wolfSSL_UseALPN function. */ +#cmakedefine HAVE_WOLFSSL_USEALPN 1 + +/* if wolfSSL has the wolfSSL_BIO_new function. */ +#cmakedefine HAVE_WOLFSSL_BIO_NEW 1 + +/* if wolfSSL has the wolfSSL_BIO_set_shutdown function. */ +#cmakedefine HAVE_WOLFSSL_BIO_SET_SHUTDOWN 1 + +/* if wolfSSL has the wc_Des_EcbEncrypt function. */ +#cmakedefine HAVE_WC_DES_ECBENCRYPT 1 + +/* if libssh is in use */ +#cmakedefine USE_LIBSSH 1 + +/* if libssh2 is in use */ +#cmakedefine USE_LIBSSH2 1 + +/* if libpsl is in use */ +#cmakedefine USE_LIBPSL 1 + +/* if you want to use OpenLDAP code instead of legacy ldap implementation */ +#cmakedefine USE_OPENLDAP 1 + +/* if OpenSSL is in use */ +#cmakedefine USE_OPENSSL 1 + +/* if AmiSSL is in use */ +#cmakedefine USE_AMISSL 1 + +/* if GSASL is in use */ +#cmakedefine USE_GSASL 1 + +/* if libuv is in use */ +#cmakedefine USE_LIBUV 1 + +/* if HTTP/3 proxy support is available */ +#cmakedefine USE_PROXY_HTTP3 1 + +/* Define to 1 if you have the header file. */ +#cmakedefine HAVE_UV_H 1 + +/* if libbacktrace is in use */ +#cmakedefine USE_BACKTRACE 1 + +/* Define to 1 if you do not want the OpenSSL configuration to be loaded + automatically */ +#cmakedefine CURL_DISABLE_OPENSSL_AUTO_LOAD_CONFIG 1 + +/* to enable NGHTTP2 */ +#cmakedefine USE_NGHTTP2 1 + +/* to enable NGTCP2 */ +#cmakedefine USE_NGTCP2 1 + +/* to enable NGHTTP3 */ +#cmakedefine USE_NGHTTP3 1 + +/* to enable quiche */ +#cmakedefine USE_QUICHE 1 + +/* to enable openssl + ngtcp2 + nghttp3 */ +#cmakedefine OPENSSL_QUIC_API2 1 + +/* Define to 1 if you have the quiche_conn_set_qlog_fd function. */ +#cmakedefine HAVE_QUICHE_CONN_SET_QLOG_FD 1 + +/* if Unix domain sockets are enabled */ +#cmakedefine USE_UNIX_SOCKETS 1 + +/* to enable SSPI support */ +#cmakedefine USE_WINDOWS_SSPI 1 + +/* to enable Windows SSL */ +#cmakedefine USE_SCHANNEL 1 + +/* if Watt-32 is in use */ +#cmakedefine USE_WATT32 1 + +/* enable multiple SSL backends */ +#cmakedefine CURL_WITH_MULTI_SSL 1 + +/* Number of bits in a file offset, on hosts where this is settable. */ +#cmakedefine _FILE_OFFSET_BITS ${_FILE_OFFSET_BITS} + +/* the signed version of size_t */ +#cmakedefine ssize_t ${ssize_t} + +/* Define to 1 if you have the mach_absolute_time function. */ +#cmakedefine HAVE_MACH_ABSOLUTE_TIME 1 + +/* to enable Windows IDN */ +#cmakedefine USE_WIN32_IDN 1 + +/* to enable Apple IDN */ +#cmakedefine USE_APPLE_IDN 1 + +/* to enable Apple OS-native certificate verification */ +#cmakedefine USE_APPLE_SECTRUST 1 + +/* Define to 1 if OpenSSL has the SSL_CTX_set_srp_username function. */ +#cmakedefine HAVE_OPENSSL_SRP 1 + +/* Define to 1 if GnuTLS has the gnutls_srp_verifier function. */ +#cmakedefine HAVE_GNUTLS_SRP 1 + +/* Define to 1 to enable TLS-SRP support. */ +#cmakedefine USE_TLS_SRP 1 + +/* Define to 1 to query for HTTPSRR when using DoH */ +#cmakedefine USE_HTTPSRR 1 + +/* if ECH support is available */ +#cmakedefine USE_ECH 1 + +/* Define to 1 if you have the wolfSSL_CTX_GenerateEchConfig function. */ +#cmakedefine HAVE_WOLFSSL_CTX_GENERATEECHCONFIG 1 + +/* Define to 1 if you have the SSL_set1_ech_config_list function. */ +#cmakedefine HAVE_SSL_SET1_ECH_CONFIG_LIST 1 + +/* Define to 1 if OpenSSL has the DES_ecb_encrypt function. */ +#cmakedefine HAVE_DES_ECB_ENCRYPT 1 diff --git a/3rdparty/curl-8.21.0/lib/curl_config.h.in b/3rdparty/curl-8.21.0/lib/curl_config.h.in new file mode 100644 index 0000000000..405ba1aa6c --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_config.h.in @@ -0,0 +1,925 @@ +/* lib/curl_config.h.in. Generated from configure.ac by autoheader. */ + +/* !checksrc! disable COPYRIGHT all */ + +/* Location of default CA bundle */ +#undef CURL_CA_BUNDLE + +/* define "1" to use OpenSSL's built-in CA store */ +#undef CURL_CA_FALLBACK + +/* If native CA store is enabled */ +#undef CURL_CA_NATIVE + +/* Location of default CA path */ +#undef CURL_CA_PATH + +/* If safe CA bundle search is enabled */ +#undef CURL_CA_SEARCH_SAFE + +/* curl_debug_global_mem debug build */ +#undef CURL_DEBUG_GLOBAL_MEM + +/* Default SSL backend */ +#undef CURL_DEFAULT_SSL_BACKEND + +/* disable alt-svc */ +#undef CURL_DISABLE_ALTSVC + +/* to disable AWS sig support */ +#undef CURL_DISABLE_AWS + +/* to disable basic authentication */ +#undef CURL_DISABLE_BASIC_AUTH + +/* to disable bearer authentication */ +#undef CURL_DISABLE_BEARER_AUTH + +/* disable local binding support */ +#undef CURL_DISABLE_BINDLOCAL + +/* If unsafe CA bundle search in PATH on Windows is disabled */ +#undef CURL_DISABLE_CA_SEARCH + +/* to disable cookies support */ +#undef CURL_DISABLE_COOKIES + +/* to disable DICT */ +#undef CURL_DISABLE_DICT + +/* to disable digest authentication */ +#undef CURL_DISABLE_DIGEST_AUTH + +/* disable DoH */ +#undef CURL_DISABLE_DOH + +/* to disable FILE */ +#undef CURL_DISABLE_FILE + +/* disable form API */ +#undef CURL_DISABLE_FORM_API + +/* to disable FTP */ +#undef CURL_DISABLE_FTP + +/* to disable curl_easy_options */ +#undef CURL_DISABLE_GETOPTIONS + +/* to disable Gopher */ +#undef CURL_DISABLE_GOPHER + +/* disable headers-api */ +#undef CURL_DISABLE_HEADERS_API + +/* disable alt-svc */ +#undef CURL_DISABLE_HSTS + +/* to disable HTTP */ +#undef CURL_DISABLE_HTTP + +/* disable HTTP authentication */ +#undef CURL_DISABLE_HTTP_AUTH + +/* to disable IMAP */ +#undef CURL_DISABLE_IMAP + +/* to disable IPFS */ +#undef CURL_DISABLE_IPFS + +/* to disable kerberos authentication */ +#undef CURL_DISABLE_KERBEROS_AUTH + +/* to disable LDAP */ +#undef CURL_DISABLE_LDAP + +/* to disable LDAPS */ +#undef CURL_DISABLE_LDAPS + +/* to disable --libcurl C code generation option */ +#undef CURL_DISABLE_LIBCURL_OPTION + +/* disable mime API */ +#undef CURL_DISABLE_MIME + +/* to disable MQTT */ +#undef CURL_DISABLE_MQTT + +/* to disable negotiate authentication */ +#undef CURL_DISABLE_NEGOTIATE_AUTH + +/* disable netrc parsing */ +#undef CURL_DISABLE_NETRC + +/* if the OpenSSL configuration is not loaded automatically */ +#undef CURL_DISABLE_OPENSSL_AUTO_LOAD_CONFIG + +/* disable date parsing */ +#undef CURL_DISABLE_PARSEDATE + +/* to disable POP3 */ +#undef CURL_DISABLE_POP3 + +/* disable progress-meter */ +#undef CURL_DISABLE_PROGRESS_METER + +/* to disable proxies */ +#undef CURL_DISABLE_PROXY + +/* to disable RTSP */ +#undef CURL_DISABLE_RTSP + +/* disable SHA-512/256 hash algorithm */ +#undef CURL_DISABLE_SHA512_256 + +/* disable DNS shuffling */ +#undef CURL_DISABLE_SHUFFLE_DNS + +/* to disable SMTP */ +#undef CURL_DISABLE_SMTP + +/* to disable socketpair support */ +#undef CURL_DISABLE_SOCKETPAIR + +/* to disable TELNET */ +#undef CURL_DISABLE_TELNET + +/* to disable TFTP */ +#undef CURL_DISABLE_TFTP + +/* to disable verbose strings */ +#undef CURL_DISABLE_VERBOSE_STRINGS + +/* disable WebSockets */ +#undef CURL_DISABLE_WEBSOCKETS + +/* enable NTLM support */ +#undef CURL_ENABLE_NTLM + +/* to enable SMB */ +#undef CURL_ENABLE_SMB + +/* Definition to make a library symbol externally visible. */ +#undef CURL_EXTERN_SYMBOL + +/* MIT Kerberos version */ +#undef CURL_KRB5_VERSION + +/* cpu-machine-OS */ +#undef CURL_OS + +/* built with multiple SSL backends */ +#undef CURL_WITH_MULTI_SSL + +/* Define to the type of arg 2 for gethostname. */ +#undef GETHOSTNAME_TYPE_ARG2 + +/* Define to 1 if you have the `accept4' function. */ +#undef HAVE_ACCEPT4 + +/* Define to 1 if you have the alarm function. */ +#undef HAVE_ALARM + +/* Define to 1 if you have the `arc4random' function. */ +#undef HAVE_ARC4RANDOM + +/* Define to 1 if you have the header file. */ +#undef HAVE_ARPA_INET_H + +/* Define to 1 if you have _Atomic support. */ +#undef HAVE_ATOMIC + +/* Define to 1 if you have the basename function. */ +#undef HAVE_BASENAME + +/* Define to 1 if bool is an available type. */ +#undef HAVE_BOOL_T + +/* if BROTLI is in use */ +#undef HAVE_BROTLI + +/* Define to 1 if you have the header file. */ +#undef HAVE_BROTLI_DECODE_H + +/* Define to 1 if you have the __builtin_available function. */ +#undef HAVE_BUILTIN_AVAILABLE + +/* Define to 1 if you have the clock_gettime function and monotonic timer. */ +#undef HAVE_CLOCK_GETTIME_MONOTONIC + +/* Define to 1 if you have the clock_gettime function and raw monotonic timer. + */ +#undef HAVE_CLOCK_GETTIME_MONOTONIC_RAW + +/* Define to 1 if you have the closesocket function. */ +#undef HAVE_CLOSESOCKET + +/* Define to 1 if you have the CloseSocket camel case function. */ +#undef HAVE_CLOSESOCKET_CAMEL + +/* Define to 1 if you have the fseeko declaration */ +#undef HAVE_DECL_FSEEKO + +/* if you have the function DES_ecb_encrypt */ +#undef HAVE_DES_ECB_ENCRYPT + +/* if you have */ +#undef HAVE_DIRENT_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_DLFCN_H + +/* Define to 1 if you have the `eventfd' function. */ +#undef HAVE_EVENTFD + +/* Define to 1 if you have the fcntl function. */ +#undef HAVE_FCNTL + +/* Define to 1 if you have the header file. */ +#undef HAVE_FCNTL_H + +/* Define to 1 if you have a working fcntl O_NONBLOCK function. */ +#undef HAVE_FCNTL_O_NONBLOCK + +/* Define to 1 if you have the `fnmatch' function. */ +#undef HAVE_FNMATCH + +/* Define to 1 if you have the freeaddrinfo function. */ +#undef HAVE_FREEADDRINFO + +/* Define to 1 if you have the `fseeko' function. */ +#undef HAVE_FSEEKO + +/* Define to 1 if you have the fsetxattr function. */ +#undef HAVE_FSETXATTR + +/* fsetxattr() takes 5 args */ +#undef HAVE_FSETXATTR_5 + +/* fsetxattr() takes 6 args */ +#undef HAVE_FSETXATTR_6 + +/* Define to 1 if you have a working getaddrinfo function. */ +#undef HAVE_GETADDRINFO + +/* Define to 1 if the getaddrinfo function is thread-safe. */ +#undef HAVE_GETADDRINFO_THREADSAFE + +/* Define to 1 if you have the `geteuid' function. */ +#undef HAVE_GETEUID + +/* Define to 1 if you have the gethostbyname_r function. */ +#undef HAVE_GETHOSTBYNAME_R + +/* gethostbyname_r() takes 3 args */ +#undef HAVE_GETHOSTBYNAME_R_3 + +/* gethostbyname_r() takes 5 args */ +#undef HAVE_GETHOSTBYNAME_R_5 + +/* gethostbyname_r() takes 6 args */ +#undef HAVE_GETHOSTBYNAME_R_6 + +/* Define to 1 if you have the gethostname function. */ +#undef HAVE_GETHOSTNAME + +/* Define to 1 if you have a working getifaddrs function. */ +#undef HAVE_GETIFADDRS + +/* Define to 1 if you have the `getpass_r' function. */ +#undef HAVE_GETPASS_R + +/* Define to 1 if you have the getpeername function. */ +#undef HAVE_GETPEERNAME + +/* Define to 1 if you have the `getppid' function. */ +#undef HAVE_GETPPID + +/* Define to 1 if you have the `getpwuid' function. */ +#undef HAVE_GETPWUID + +/* Define to 1 if you have the `getpwuid_r' function. */ +#undef HAVE_GETPWUID_R + +/* Define to 1 if you have the `getrlimit' function. */ +#undef HAVE_GETRLIMIT + +/* Define to 1 if you have the getsockname function. */ +#undef HAVE_GETSOCKNAME + +/* Define to 1 if you have the `gettimeofday' function. */ +#undef HAVE_GETTIMEOFDAY + +/* Define to 1 if you have a working glibc-style strerror_r function. */ +#undef HAVE_GLIBC_STRERROR_R + +/* Define to 1 if you have a working gmtime_r function. */ +#undef HAVE_GMTIME_R + +/* if you have the function gnutls_srp_verifier */ +#undef HAVE_GNUTLS_SRP + +/* Define to 1 if you have the header file. */ +#undef HAVE_GSASL_H + +/* if you have GSS-API libraries */ +#undef HAVE_GSSAPI + +/* Define to 1 if you have the header file. */ +#undef HAVE_GSSAPI_GSSAPI_GENERIC_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_GSSAPI_GSSAPI_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_GSSAPI_GSSAPI_KRB5_H + +/* if you have GNU GSS */ +#undef HAVE_GSSGNU + +/* Define to 1 if you have the header file. */ +#undef HAVE_IDN2_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_IFADDRS_H + +/* Define to 1 if you have the `if_nametoindex' function. */ +#undef HAVE_IF_NAMETOINDEX + +/* Define to 1 if you have an IPv6 capable working inet_ntop function. */ +#undef HAVE_INET_NTOP + +/* Define to 1 if you have an IPv6 capable working inet_pton function. */ +#undef HAVE_INET_PTON + +/* Define to 1 if you have the header file. */ +#undef HAVE_INTTYPES_H + +/* Define to 1 if you have the ioctlsocket function. */ +#undef HAVE_IOCTLSOCKET + +/* Define to 1 if you have the IoctlSocket camel case function. */ +#undef HAVE_IOCTLSOCKET_CAMEL + +/* Define to 1 if you have a working IoctlSocket camel case FIONBIO function. + */ +#undef HAVE_IOCTLSOCKET_CAMEL_FIONBIO + +/* Define to 1 if you have a working ioctlsocket FIONBIO function. */ +#undef HAVE_IOCTLSOCKET_FIONBIO + +/* Define to 1 if you have a working ioctl FIONBIO function. */ +#undef HAVE_IOCTL_FIONBIO + +/* Define to 1 if you have a working ioctl SIOCGIFADDR function. */ +#undef HAVE_IOCTL_SIOCGIFADDR + +/* Define to 1 if you have the header file. */ +#undef HAVE_IO_H + +/* Define to 1 if you have the lber.h header file. */ +#undef HAVE_LBER_H + +/* Define to 1 if you have the ldap.h header file. */ +#undef HAVE_LDAP_H + +/* Define to 1 if you have the `ldap_init_fd' function. */ +#undef HAVE_LDAP_INIT_FD + +/* Use LDAPS implementation */ +#undef HAVE_LDAP_SSL + +/* Define to 1 if you have the ldap_ssl.h header file. */ +#undef HAVE_LDAP_SSL_H + +/* Define to 1 if you have the `ldap_url_parse' function. */ +#undef HAVE_LDAP_URL_PARSE + +/* Define to 1 if you have the `brotlidec' library (-lbrotlidec). */ +#undef HAVE_LIBBROTLIDEC + +/* Define to 1 if you have the header file. */ +#undef HAVE_LIBGEN_H + +/* Define to 1 if you have the `idn2' library (-lidn2). */ +#undef HAVE_LIBIDN2 + +/* Define to 1 if you have the header file. */ +#undef HAVE_LIBPSL_H + +/* Define to 1 if you have the `ssh' library (-lssh). */ +#undef HAVE_LIBSSH + +/* Define to 1 if you have the `ssh2' library (-lssh2). */ +#undef HAVE_LIBSSH2 + +/* Define to 1 if you have the `ssl' library (-lssl). */ +#undef HAVE_LIBSSL + +/* if zlib is available */ +#undef HAVE_LIBZ + +/* Define to 1 if you have the `zstd' library (-lzstd). */ +#undef HAVE_LIBZSTD + +/* Define to 1 if you have the header file. */ +#undef HAVE_LINUX_TCP_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_LOCALE_H + +/* Define to 1 if you have a working localtime_r function. */ +#undef HAVE_LOCALTIME_R + +/* Define to 1 if you have the `mach_absolute_time' function. */ +#undef HAVE_MACH_ABSOLUTE_TIME + +/* Define to 1 if you have the `mbedtls_des_crypt_ecb' function. */ +#undef HAVE_MBEDTLS_DES_CRYPT_ECB + +/* Define to 1 if you have the memrchr function or macro. */ +#undef HAVE_MEMRCHR + +/* Define to 1 if you have the `memset_explicit' function. */ +#undef HAVE_MEMSET_EXPLICIT + +/* Define to 1 if you have the memset_s function. */ +#undef HAVE_MEMSET_S + +/* Define to 1 if you have the header file. */ +#undef HAVE_NETDB_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_NETINET_IN6_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_NETINET_IN_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_NETINET_TCP_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_NETINET_UDP_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_NET_IF_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_NGHTTP2_NGHTTP2_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_NGHTTP3_NGHTTP3_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_NGTCP2_NGTCP2_CRYPTO_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_NGTCP2_NGTCP2_H + +/* if you have opendir */ +#undef HAVE_OPENDIR + +/* Define to 1 if you have the header file. */ +#undef HAVE_OPENSSL_CRYPTO_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_OPENSSL_ERR_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_OPENSSL_PEM_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_OPENSSL_RSA_H + +/* if you have the functions SSL_CTX_set_srp_username and + SSL_CTX_set_srp_password */ +#undef HAVE_OPENSSL_SRP + +/* Define to 1 if you have the header file. */ +#undef HAVE_OPENSSL_SSL_H + +/* Define to 1 if you have the `pipe' function. */ +#undef HAVE_PIPE + +/* Define to 1 if you have the `pipe2' function. */ +#undef HAVE_PIPE2 + +/* Define to 1 if you have the `poll' function. */ +#undef HAVE_POLL + +/* Define to 1 if you have the header file. */ +#undef HAVE_POLL_H + +/* Define to 1 if you have a working POSIX-style strerror_r function. */ +#undef HAVE_POSIX_STRERROR_R + +/* Define to 1 if you have the header file. */ +#undef HAVE_PROTO_BSDSOCKET_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_PWD_H + +/* Define to 1 if you have the `quiche_conn_set_qlog_fd' function. */ +#undef HAVE_QUICHE_CONN_SET_QLOG_FD + +/* Define to 1 if you have the header file. */ +#undef HAVE_QUICHE_H + +/* Define to 1 if you have the `realpath' function. */ +#undef HAVE_REALPATH + +/* Define to 1 if you have the recv function. */ +#undef HAVE_RECV + +/* Define to 1 if symbol `sa_family_t' exists */ +#undef HAVE_SA_FAMILY_T + +/* Define to 1 if you have the `sched_yield' function. */ +#undef HAVE_SCHED_YIELD + +/* Define to 1 if you have the select function. */ +#undef HAVE_SELECT + +/* Define to 1 if you have the send function. */ +#undef HAVE_SEND + +/* Define to 1 if you have the `sendmmsg' function. */ +#undef HAVE_SENDMMSG + +/* Define to 1 if you have the `sendmsg' function. */ +#undef HAVE_SENDMSG + +/* Define to 1 if you have the `setlocale' function. */ +#undef HAVE_SETLOCALE + +/* Define to 1 if you have the `setrlimit' function. */ +#undef HAVE_SETRLIMIT + +/* Define to 1 if you have the sigaction function. */ +#undef HAVE_SIGACTION + +/* Define to 1 if you have the siginterrupt function. */ +#undef HAVE_SIGINTERRUPT + +/* Define to 1 if you have the signal function. */ +#undef HAVE_SIGNAL + +/* Define to 1 if you have the sigsetjmp function or macro. */ +#undef HAVE_SIGSETJMP + +/* Define to 1 if struct sockaddr_in6 has the sin6_scope_id member */ +#undef HAVE_SOCKADDR_IN6_SIN6_SCOPE_ID + +/* Define to 1 if you have the socket function. */ +#undef HAVE_SOCKET + +/* Define to 1 if you have the socketpair function. */ +#undef HAVE_SOCKETPAIR + +/* Define to 1 if you have the `SSL_set0_wbio' function. */ +#undef HAVE_SSL_SET0_WBIO + +/* Define to 1 if you have the `SSL_set1_ech_config_list' function. */ +#undef HAVE_SSL_SET1_ECH_CONFIG_LIST + +/* Define to 1 if you have the `SSL_set_quic_tls_cbs' function. */ +#undef HAVE_SSL_SET_QUIC_TLS_CBS + +/* Define to 1 if you have the `SSL_set_quic_use_legacy_codepoint' function. + */ +#undef HAVE_SSL_SET_QUIC_USE_LEGACY_CODEPOINT + +/* Define to 1 if you have the header file. */ +#undef HAVE_STDATOMIC_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_STDBOOL_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_STDINT_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_STDIO_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_STDLIB_H + +/* Define to 1 if you have the strcasecmp function. */ +#undef HAVE_STRCASECMP + +/* Define to 1 if you have the strcmpi function. */ +#undef HAVE_STRCMPI + +/* Define to 1 if you have the strerror_r function. */ +#undef HAVE_STRERROR_R + +/* Define to 1 if you have the stricmp function. */ +#undef HAVE_STRICMP + +/* Define to 1 if you have the header file. */ +#undef HAVE_STRINGS_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_STRING_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_STROPTS_H + +/* if struct sockaddr_storage is defined */ +#undef HAVE_STRUCT_SOCKADDR_STORAGE + +/* Define to 1 if you have the timeval struct. */ +#undef HAVE_STRUCT_TIMEVAL + +/* Define to 1 if suseconds_t is an available type. */ +#undef HAVE_SUSECONDS_T + +/* Define to 1 if you have the header file. */ +#undef HAVE_SYS_EVENTFD_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_SYS_FILIO_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_SYS_IOCTL_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_SYS_PARAM_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_SYS_POLL_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_SYS_RESOURCE_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_SYS_SELECT_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_SYS_SOCKIO_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_SYS_STAT_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_SYS_TYPES_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_SYS_UN_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_SYS_UTIME_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_SYS_XATTR_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_TERMIOS_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_TERMIO_H + +/* if POSIX pthreads are supported */ +#undef HAVE_THREADS_POSIX + +/* Define this if time_t is unsigned */ +#undef HAVE_TIME_T_UNSIGNED + +/* Define to 1 if you have the header file. */ +#undef HAVE_UNICODE_UIDNA_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_UNISTD_H + +/* Define to 1 if you have the `utime' function. */ +#undef HAVE_UTIME + +/* Define to 1 if you have the `utimes' function. */ +#undef HAVE_UTIMES + +/* Define to 1 if you have the header file. */ +#undef HAVE_UTIME_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_UV_H + +/* Define to 1 if you have the `wc_Des_EcbEncrypt' function. */ +#undef HAVE_WC_DES_ECBENCRYPT + +/* Define to 1 if you have the `wolfSSL_BIO_new' function. */ +#undef HAVE_WOLFSSL_BIO_NEW + +/* Define to 1 if you have the `wolfSSL_BIO_set_shutdown' function. */ +#undef HAVE_WOLFSSL_BIO_SET_SHUTDOWN + +/* Define to 1 if you have the `wolfSSL_CTX_GenerateEchConfig' function. */ +#undef HAVE_WOLFSSL_CTX_GENERATEECHCONFIG + +/* Define to 1 if you have the `wolfSSL_get_peer_certificate' function. */ +#undef HAVE_WOLFSSL_GET_PEER_CERTIFICATE + +/* Define to 1 if you have the `wolfSSL_set_quic_use_legacy_codepoint' + function. */ +#undef HAVE_WOLFSSL_SET_QUIC_USE_LEGACY_CODEPOINT + +/* Define to 1 if you have the `wolfSSL_UseALPN' function. */ +#undef HAVE_WOLFSSL_USEALPN + +/* Define this symbol if your OS supports changing the contents of argv */ +#undef HAVE_WRITABLE_ARGV + +/* if libzstd is in use */ +#undef HAVE_ZSTD + +/* Define to 1 if you have the header file. */ +#undef HAVE_ZSTD_H + +/* Define to the sub-directory where libtool stores uninstalled libraries. */ +#undef LT_OBJDIR + +/* Define to 1 if you need the lber.h header file even with ldap.h */ +#undef NEED_LBER_H + +/* Define to 1 if _REENTRANT preprocessor symbol must be defined. */ +#undef NEED_REENTRANT + +/* Define to 1 if _THREAD_SAFE preprocessor symbol must be defined. */ +#undef NEED_THREAD_SAFE + +/* openssl with new QUIC API */ +#undef OPENSSL_QUIC_API2 + +/* Name of package */ +#undef PACKAGE + +/* Define to the address where bug reports for this package should be sent. */ +#undef PACKAGE_BUGREPORT + +/* Define to the full name of this package. */ +#undef PACKAGE_NAME + +/* Define to the full name and version of this package. */ +#undef PACKAGE_STRING + +/* Define to the one symbol short name of this package. */ +#undef PACKAGE_TARNAME + +/* Define to the home page for this package. */ +#undef PACKAGE_URL + +/* Define to the version of this package. */ +#undef PACKAGE_VERSION + +/* Size of curl_off_t in number of bytes */ +#undef SIZEOF_CURL_OFF_T + +/* Size of curl_socket_t in number of bytes */ +#undef SIZEOF_CURL_SOCKET_T + +/* Size of int in number of bytes */ +#undef SIZEOF_INT + +/* Size of long in number of bytes */ +#undef SIZEOF_LONG + +/* Size of off_t in number of bytes */ +#undef SIZEOF_OFF_T + +/* Size of size_t in number of bytes */ +#undef SIZEOF_SIZE_T + +/* Size of time_t in number of bytes */ +#undef SIZEOF_TIME_T + +/* Define to 1 if all of the C90 standard headers exist (not just the ones + required in a freestanding environment). This macro is provided for + backward compatibility; new code need not use it. */ +#undef STDC_HEADERS + +/* if AmiSSL is in use */ +#undef USE_AMISSL + +/* if AppleIDN */ +#undef USE_APPLE_IDN + +/* enable Apple OS certificate validation */ +#undef USE_APPLE_SECTRUST + +/* Define to enable c-ares support */ +#undef USE_ARES + +/* if libbacktrace is in use */ +#undef USE_BACKTRACE + +/* if ECH support is available */ +#undef USE_ECH + +/* if GnuTLS is enabled */ +#undef USE_GNUTLS + +/* GSASL support enabled */ +#undef USE_GSASL + +/* enable HTTPS RR support */ +#undef USE_HTTPSRR + +/* Define if you want to enable IPv6 support */ +#undef USE_IPV6 + +/* if libpsl is in use */ +#undef USE_LIBPSL + +/* if libssh is in use */ +#undef USE_LIBSSH + +/* if libssh2 is in use */ +#undef USE_LIBSSH2 + +/* if libuv is in use */ +#undef USE_LIBUV + +/* if mbedTLS is enabled */ +#undef USE_MBEDTLS + +/* if nghttp2 is in use */ +#undef USE_NGHTTP2 + +/* if nghttp3 is in use */ +#undef USE_NGHTTP3 + +/* if ngtcp2 is in use */ +#undef USE_NGTCP2 + +/* Use OpenLDAP-specific code */ +#undef USE_OPENLDAP + +/* if OpenSSL is in use */ +#undef USE_OPENSSL + +/* if HTTP/3 proxy support is available */ +#undef USE_PROXY_HTTP3 + +/* if quiche is in use */ +#undef USE_QUICHE + +/* if you want c-ares for DNS lookup */ +#undef USE_RESOLV_ARES + +/* if you want threaded DNS lookup */ +#undef USE_RESOLV_THREADED + +/* if Rustls is enabled */ +#undef USE_RUSTLS + +/* to enable Windows native SSL/TLS support */ +#undef USE_SCHANNEL + +/* if SSL session export support is available */ +#undef USE_SSLS_EXPORT + +/* Use TLS-SRP authentication */ +#undef USE_TLS_SRP + +/* Use Unix domain sockets */ +#undef USE_UNIX_SOCKETS + +/* if Watt-32 is in use */ +#undef USE_WATT32 + +/* Define to 1 if you are building a Windows target with crypto API support. + */ +#undef USE_WIN32_CRYPTO + +/* Define to 1 if you have the `normaliz' (WinIDN) library (-lnormaliz). */ +#undef USE_WIN32_IDN + +/* Use Windows LDAP implementation */ +#undef USE_WIN32_LDAP + +/* to enable SSPI support */ +#undef USE_WINDOWS_SSPI + +/* if wolfSSL is enabled */ +#undef USE_WOLFSSL + +/* Version number of package */ +#undef VERSION + +/* Define to 1 if OS is AIX. */ +#ifndef _ALL_SOURCE +# undef _ALL_SOURCE +#endif + +/* Number of bits in a file offset, on hosts where this is settable. */ +#undef _FILE_OFFSET_BITS + +/* Define for large files, on AIX-style hosts. */ +#undef _LARGE_FILES + +/* Define to empty if `const' does not conform to ANSI C. */ +#undef const + +/* Define to `unsigned int' if does not define. */ +#undef size_t + +/* the signed version of size_t */ +#undef ssize_t diff --git a/3rdparty/curl-8.21.0/lib/curl_ctype.h b/3rdparty/curl-8.21.0/lib/curl_ctype.h new file mode 100644 index 0000000000..f3291ad818 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_ctype.h @@ -0,0 +1,52 @@ +#ifndef HEADER_CURL_CTYPE_H +#define HEADER_CURL_CTYPE_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +#define ISLOWHEXALPHA(x) (((x) >= 'a') && ((x) <= 'f')) +#define ISUPHEXALPHA(x) (((x) >= 'A') && ((x) <= 'F')) + +#define ISLOWCNTRL(x) ((unsigned char)(x) <= 0x1f) +#define IS7F(x) ((x) == 0x7f) + +#define ISLOWPRINT(x) (((x) >= 9) && ((x) <= 0x0d)) + +#define ISPRINT(x) (ISLOWPRINT(x) || (((x) >= ' ') && ((x) <= 0x7e))) +#define ISGRAPH(x) (ISLOWPRINT(x) || (((x) > ' ') && ((x) <= 0x7e))) +#define ISCNTRL(x) (ISLOWCNTRL(x) || IS7F(x)) +#define ISALPHA(x) (ISLOWER(x) || ISUPPER(x)) +#define ISXDIGIT(x) (ISDIGIT(x) || ISLOWHEXALPHA(x) || ISUPHEXALPHA(x)) +#define ISODIGIT(x) (((x) >= '0') && ((x) <= '7')) +#define ISALNUM(x) (ISDIGIT(x) || ISLOWER(x) || ISUPPER(x)) +#define ISUPPER(x) (((x) >= 'A') && ((x) <= 'Z')) +#define ISLOWER(x) (((x) >= 'a') && ((x) <= 'z')) +#define ISDIGIT(x) (((x) >= '0') && ((x) <= '9')) +#define ISBLANK(x) (((x) == ' ') || ((x) == '\t')) +#define ISSPACE(x) (ISBLANK(x) || (((x) >= 0xa) && ((x) <= 0x0d))) +#define ISURLPUNTCS(x) \ + (((x) == '-') || ((x) == '.') || ((x) == '_') || ((x) == '~')) +#define ISUNRESERVED(x) (ISALNUM(x) || ISURLPUNTCS(x)) +#define ISNEWLINE(x) (((x) == '\n') || (x) == '\r') + +#endif /* HEADER_CURL_CTYPE_H */ diff --git a/3rdparty/curl-8.21.0/lib/curl_endian.c b/3rdparty/curl-8.21.0/lib/curl_endian.c new file mode 100644 index 0000000000..b3689417a4 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_endian.c @@ -0,0 +1,83 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "curl_endian.h" + +/* + * Curl_read16_le() + * + * This function converts a 16-bit integer from the little endian format, as + * used in the incoming package to whatever endian format we are using + * natively. + * + * Parameters: + * + * buf [in] - A pointer to a 2-byte buffer. + * + * Returns the integer. + */ +unsigned short Curl_read16_le(const unsigned char *buf) +{ + return (unsigned short)(((unsigned short)buf[0]) | + ((unsigned short)buf[1] << 8)); +} + +/* + * Curl_read32_le() + * + * This function converts a 32-bit integer from the little endian format, as + * used in the incoming package to whatever endian format we are using + * natively. + * + * Parameters: + * + * buf [in] - A pointer to a 4-byte buffer. + * + * Returns the integer. + */ +unsigned int Curl_read32_le(const unsigned char *buf) +{ + return ((unsigned int)buf[0]) | ((unsigned int)buf[1] << 8) | + ((unsigned int)buf[2] << 16) | ((unsigned int)buf[3] << 24); +} + +/* + * Curl_read16_be() + * + * This function converts a 16-bit integer from the big endian format, as + * used in the incoming package to whatever endian format we are using + * natively. + * + * Parameters: + * + * buf [in] - A pointer to a 2-byte buffer. + * + * Returns the integer. + */ +unsigned short Curl_read16_be(const unsigned char *buf) +{ + return (unsigned short)(((unsigned short)buf[0] << 8) | + ((unsigned short)buf[1])); +} diff --git a/3rdparty/curl-8.21.0/lib/curl_endian.h b/3rdparty/curl-8.21.0/lib/curl_endian.h new file mode 100644 index 0000000000..fa283214b1 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_endian.h @@ -0,0 +1,36 @@ +#ifndef HEADER_CURL_ENDIAN_H +#define HEADER_CURL_ENDIAN_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +/* Converts a 16-bit integer from little endian */ +unsigned short Curl_read16_le(const unsigned char *buf); + +/* Converts a 32-bit integer from little endian */ +unsigned int Curl_read32_le(const unsigned char *buf); + +/* Converts a 16-bit integer from big endian */ +unsigned short Curl_read16_be(const unsigned char *buf); + +#endif /* HEADER_CURL_ENDIAN_H */ diff --git a/3rdparty/curl-8.21.0/lib/curl_fnmatch.c b/3rdparty/curl-8.21.0/lib/curl_fnmatch.c new file mode 100644 index 0000000000..d165554f8d --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_fnmatch.c @@ -0,0 +1,385 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifndef CURL_DISABLE_FTP + +#include "curl_fnmatch.h" + +#ifndef HAVE_FNMATCH + +#define CURLFNM_CHARSET_LEN (sizeof(char) * 256) +#define CURLFNM_CHSET_SIZE (CURLFNM_CHARSET_LEN + 15) + +#define CURLFNM_NEGATE CURLFNM_CHARSET_LEN + +#define CURLFNM_ALNUM (CURLFNM_CHARSET_LEN + 1) +#define CURLFNM_DIGIT (CURLFNM_CHARSET_LEN + 2) +#define CURLFNM_XDIGIT (CURLFNM_CHARSET_LEN + 3) +#define CURLFNM_ALPHA (CURLFNM_CHARSET_LEN + 4) +#define CURLFNM_PRINT (CURLFNM_CHARSET_LEN + 5) +#define CURLFNM_BLANK (CURLFNM_CHARSET_LEN + 6) +#define CURLFNM_LOWER (CURLFNM_CHARSET_LEN + 7) +#define CURLFNM_GRAPH (CURLFNM_CHARSET_LEN + 8) +#define CURLFNM_SPACE (CURLFNM_CHARSET_LEN + 9) +#define CURLFNM_UPPER (CURLFNM_CHARSET_LEN + 10) + +typedef enum { + CURLFNM_SCHS_DEFAULT = 0, + CURLFNM_SCHS_RIGHTBR, + CURLFNM_SCHS_RIGHTBRLEFTBR +} setcharset_state; + +typedef enum { + CURLFNM_PKW_INIT = 0, + CURLFNM_PKW_DDOT +} parsekey_state; + +typedef enum { + CCLASS_OTHER = 0, + CCLASS_DIGIT, + CCLASS_UPPER, + CCLASS_LOWER +} char_class; + +#define SETCHARSET_OK 1 +#define SETCHARSET_FAIL 0 + +static int parsekeyword(const unsigned char **pattern, unsigned char *charset) +{ + parsekey_state state = CURLFNM_PKW_INIT; + char keyword[10] = { 0 }; + size_t i; + const unsigned char *p = *pattern; + bool found = FALSE; + for(i = 0; !found; i++) { + char c = (char)*p++; + if(i >= sizeof(keyword)) + return SETCHARSET_FAIL; + switch(state) { + case CURLFNM_PKW_INIT: + if(ISLOWER(c)) + keyword[i] = c; + else if(c == ':') + state = CURLFNM_PKW_DDOT; + else + return SETCHARSET_FAIL; + break; + case CURLFNM_PKW_DDOT: + if(c == ']') + found = TRUE; + else + return SETCHARSET_FAIL; + } + } +#undef KEYLEN + + *pattern = p; /* move caller's pattern pointer */ + if(!strcmp(keyword, "digit")) + charset[CURLFNM_DIGIT] = 1; + else if(!strcmp(keyword, "alnum")) + charset[CURLFNM_ALNUM] = 1; + else if(!strcmp(keyword, "alpha")) + charset[CURLFNM_ALPHA] = 1; + else if(!strcmp(keyword, "xdigit")) + charset[CURLFNM_XDIGIT] = 1; + else if(!strcmp(keyword, "print")) + charset[CURLFNM_PRINT] = 1; + else if(!strcmp(keyword, "graph")) + charset[CURLFNM_GRAPH] = 1; + else if(!strcmp(keyword, "space")) + charset[CURLFNM_SPACE] = 1; + else if(!strcmp(keyword, "blank")) + charset[CURLFNM_BLANK] = 1; + else if(!strcmp(keyword, "upper")) + charset[CURLFNM_UPPER] = 1; + else if(!strcmp(keyword, "lower")) + charset[CURLFNM_LOWER] = 1; + else + return SETCHARSET_FAIL; + return SETCHARSET_OK; +} + +/* Return the character class. */ +static char_class charclass(unsigned char c) +{ + if(ISUPPER(c)) + return CCLASS_UPPER; + if(ISLOWER(c)) + return CCLASS_LOWER; + if(ISDIGIT(c)) + return CCLASS_DIGIT; + return CCLASS_OTHER; +} + +/* Include a character or a range in set. */ +static void setcharorrange(const unsigned char **pp, unsigned char *charset) +{ + const unsigned char *p = (*pp)++; + unsigned char c = *p++; + + charset[c] = 1; + if(ISALNUM(c) && *p++ == '-') { + char_class cc = charclass(c); + unsigned char endrange = *p++; + + if(endrange == '\\') + endrange = *p++; + if(endrange >= c && charclass(endrange) == cc) { + while(c++ != endrange) + if(charclass(c) == cc) /* Chars in class may be not consecutive. */ + charset[c] = 1; + *pp = p; + } + } +} + +/* returns 1 (TRUE) if pattern is OK, 0 if is bad ("p" is pattern pointer) */ +static int setcharset(const unsigned char **p, unsigned char *charset) +{ + setcharset_state state = CURLFNM_SCHS_DEFAULT; + bool something_found = FALSE; + unsigned char c; + + memset(charset, 0, CURLFNM_CHSET_SIZE); + for(;;) { + c = **p; + if(!c) + return SETCHARSET_FAIL; + + switch(state) { + case CURLFNM_SCHS_DEFAULT: + if(c == ']') { + if(something_found) + return SETCHARSET_OK; + something_found = TRUE; + state = CURLFNM_SCHS_RIGHTBR; + charset[c] = 1; + (*p)++; + } + else if(c == '[') { + const unsigned char *pp = *p + 1; + + if(*pp++ == ':' && parsekeyword(&pp, charset)) + *p = pp; + else { + charset[c] = 1; + (*p)++; + } + something_found = TRUE; + } + else if(c == '^' || c == '!') { + if(!something_found) { + if(charset[CURLFNM_NEGATE]) { + charset[c] = 1; + something_found = TRUE; + } + else + charset[CURLFNM_NEGATE] = 1; /* negate charset */ + } + else + charset[c] = 1; + (*p)++; + } + else if(c == '\\') { + c = *(++(*p)); + if(c) + setcharorrange(p, charset); + else + charset['\\'] = 1; + something_found = TRUE; + } + else { + setcharorrange(p, charset); + something_found = TRUE; + } + break; + case CURLFNM_SCHS_RIGHTBR: + if(c == '[') { + state = CURLFNM_SCHS_RIGHTBRLEFTBR; + charset[c] = 1; + (*p)++; + } + else if(c == ']') { + return SETCHARSET_OK; + } + else if(ISPRINT(c)) { + charset[c] = 1; + (*p)++; + state = CURLFNM_SCHS_DEFAULT; + } + else + /* used 'goto fail' instead of 'return SETCHARSET_FAIL' to avoid a + * nonsense warning 'statement not reached' at end of the fnc when + * compiling on Solaris */ + goto fail; + break; + case CURLFNM_SCHS_RIGHTBRLEFTBR: + if(c == ']') + return SETCHARSET_OK; + state = CURLFNM_SCHS_DEFAULT; + charset[c] = 1; + (*p)++; + break; + } + } +fail: + return SETCHARSET_FAIL; +} + +static int loop(const unsigned char *pattern, const unsigned char *string, + int maxstars) +{ + const unsigned char *p = pattern; + const unsigned char *s = string; + unsigned char charset[CURLFNM_CHSET_SIZE] = { 0 }; + + for(;;) { + const unsigned char *pp; + + switch(*p) { + case '*': + if(!maxstars) + return CURL_FNMATCH_NOMATCH; + /* Regroup consecutive stars and question marks. This can be done because + '*?*?*' can be expressed as '??*'. */ + for(;;) { + if(*++p == '\0') + return CURL_FNMATCH_MATCH; + if(*p == '?') { + if(!*s++) + return CURL_FNMATCH_NOMATCH; + } + else if(*p != '*') + break; + } + /* Skip string characters until we find a match with pattern suffix. */ + for(maxstars--; *s; s++) { + if(loop(p, s, maxstars) == CURL_FNMATCH_MATCH) + return CURL_FNMATCH_MATCH; + } + return CURL_FNMATCH_NOMATCH; + case '?': + if(!*s) + return CURL_FNMATCH_NOMATCH; + s++; + p++; + break; + case '\0': + return *s ? CURL_FNMATCH_NOMATCH : CURL_FNMATCH_MATCH; + case '\\': + if(p[1]) + p++; + if(*s++ != *p++) + return CURL_FNMATCH_NOMATCH; + break; + case '[': + pp = p + 1; /* Copy in case of syntax error in set. */ + if(setcharset(&pp, charset)) { + bool found = FALSE; + if(!*s) + return CURL_FNMATCH_NOMATCH; + if(charset[(unsigned int)*s]) + found = TRUE; + else if(charset[CURLFNM_ALNUM]) + found = ISALNUM(*s); + else if(charset[CURLFNM_ALPHA]) + found = ISALPHA(*s); + else if(charset[CURLFNM_DIGIT]) + found = ISDIGIT(*s); + else if(charset[CURLFNM_XDIGIT]) + found = ISXDIGIT(*s); + else if(charset[CURLFNM_PRINT]) + found = ISPRINT(*s); + else if(charset[CURLFNM_SPACE]) + found = ISBLANK(*s); + else if(charset[CURLFNM_UPPER]) + found = ISUPPER(*s); + else if(charset[CURLFNM_LOWER]) + found = ISLOWER(*s); + else if(charset[CURLFNM_BLANK]) + found = ISBLANK(*s); + else if(charset[CURLFNM_GRAPH]) + found = ISGRAPH(*s); + + if(charset[CURLFNM_NEGATE]) + found = !found; + + if(!found) + return CURL_FNMATCH_NOMATCH; + p = pp + 1; + s++; + break; + } + /* Syntax error in set; mismatch! */ + return CURL_FNMATCH_NOMATCH; + + default: + if(*p++ != *s++) + return CURL_FNMATCH_NOMATCH; + break; + } + } +} + +/* + * @unittest: 1307 + */ +int Curl_fnmatch(void *ptr, const char *pattern, const char *string) +{ + (void)ptr; /* the argument is specified by the curl_fnmatch_callback + prototype, but not used by Curl_fnmatch() */ + if(!pattern || !string) { + return CURL_FNMATCH_FAIL; + } + return loop((const unsigned char *)pattern, + (const unsigned char *)string, 2); +} +#else /* HAVE_FNMATCH */ + +#include +/* + * @unittest: 1307 + */ +int Curl_fnmatch(void *ptr, const char *pattern, const char *string) +{ + (void)ptr; /* the argument is specified by the curl_fnmatch_callback + prototype, but not used by Curl_fnmatch() */ + if(!pattern || !string) { + return CURL_FNMATCH_FAIL; + } + + switch(fnmatch(pattern, string, 0)) { + case 0: + return CURL_FNMATCH_MATCH; + case FNM_NOMATCH: + return CURL_FNMATCH_NOMATCH; + default: + return CURL_FNMATCH_FAIL; + } + /* not reached */ +} +#endif /* !HAVE_FNMATCH */ + +#endif /* !CURL_DISABLE_FTP */ diff --git a/3rdparty/curl-8.21.0/lib/curl_fnmatch.h b/3rdparty/curl-8.21.0/lib/curl_fnmatch.h new file mode 100644 index 0000000000..61d2a0c4e9 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_fnmatch.h @@ -0,0 +1,45 @@ +#ifndef HEADER_CURL_FNMATCH_H +#define HEADER_CURL_FNMATCH_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#define CURL_FNMATCH_MATCH 0 +#define CURL_FNMATCH_NOMATCH 1 +#define CURL_FNMATCH_FAIL 2 + +/* default pattern matching function + * ================================= + * Implemented with recursive backtracking, if you want to use Curl_fnmatch, + * please note that there is not implemented UTF/Unicode support. + * + * Implemented features: + * '?' notation, does not match UTF characters + * '*' can also work with UTF string + * [a-zA-Z0-9] enumeration support + * + * keywords: alnum, digit, xdigit, alpha, print, blank, lower, graph, space + * and upper (use as "[[:alnum:]]") + */ +int Curl_fnmatch(void *ptr, const char *pattern, const char *string); + +#endif /* HEADER_CURL_FNMATCH_H */ diff --git a/3rdparty/curl-8.21.0/lib/curl_fopen.c b/3rdparty/curl-8.21.0/lib/curl_fopen.c new file mode 100644 index 0000000000..abb17eab4b --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_fopen.c @@ -0,0 +1,165 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_COOKIES) || !defined(CURL_DISABLE_ALTSVC) || \ + !defined(CURL_DISABLE_HSTS) + +#include "urldata.h" +#include "rand.h" +#include "curl_fopen.h" + +/* + The dirslash() function breaks a null-terminated pathname string into + directory and filename components then returns the directory component up + to, *AND INCLUDING*, a final '/'. If there is no directory in the path, + this instead returns a "" string. + + This function returns a pointer to malloc'ed memory. + + The input path to this function is expected to have a filename part. +*/ + +#ifdef _WIN32 +#define PATHSEP "\\" +#define IS_SEP(x) (((x) == '/') || ((x) == '\\')) +#elif defined(MSDOS) || defined(OS2) +#define PATHSEP "\\" +#define IS_SEP(x) ((x) == '\\') +#else +#define PATHSEP "/" +#define IS_SEP(x) ((x) == '/') +#endif + +static char *dirslash(const char *path) +{ + size_t n; + struct dynbuf out; + DEBUGASSERT(path); + curlx_dyn_init(&out, CURL_MAX_INPUT_LENGTH); + n = strlen(path); + if(n) { + /* find the rightmost path separator, if any */ + while(n && !IS_SEP(path[n - 1])) + --n; + /* skip over all the path separators, if any */ + while(n && IS_SEP(path[n - 1])) + --n; + } + if(curlx_dyn_addn(&out, path, n)) + return NULL; + /* if there was a directory, append a single trailing slash */ + if(n && curlx_dyn_addn(&out, PATHSEP, 1)) + return NULL; + return curlx_dyn_ptr(&out); +} + +/* + * Curl_fopen() opens a file for writing with a temp name, to be renamed + * to the final name when completed. If there is an existing file using this + * name at the time of the open, this function will clone the mode from that + * file. if 'tempname' is non-NULL, it needs a rename after the file is + * written. + */ +CURLcode Curl_fopen(struct Curl_easy *data, const char *filename, + FILE **fh, char **tempname) +{ + CURLcode result = CURLE_WRITE_ERROR; + unsigned char randbuf[41]; + char *tempstore = NULL; +#ifndef _WIN32 + curlx_struct_stat sb; +#endif + int fd = -1; + char *dir = NULL; + *tempname = NULL; + +#ifndef _WIN32 + *fh = curlx_fopen(filename, FOPEN_WRITETEXT); + if(!*fh) + goto fail; + if(curlx_fstat(fileno(*fh), &sb) == -1 || !S_ISREG(sb.st_mode)) { + return CURLE_OK; + } + curlx_fclose(*fh); +#ifdef HAVE_GETEUID + /* If the existing file is not owned by the user, do not inherit + * its permissions at the temp file created below. The permissions + * might be unsuitable for holding user private data. */ + if(sb.st_uid != geteuid()) + sb.st_mode = 0; +#endif +#endif /* !_WIN32 */ + *fh = NULL; + + result = Curl_rand_alnum(data, randbuf, sizeof(randbuf)); + if(result) + goto fail; + + dir = dirslash(filename); + if(dir) { + /* The temp filename should not end up too long for the target file + system */ + tempstore = curl_maprintf("%s%s.tmp", dir, randbuf); + curlx_free(dir); + } + + if(!tempstore) { + result = CURLE_OUT_OF_MEMORY; + goto fail; + } + + result = CURLE_WRITE_ERROR; +#ifdef _WIN32 + fd = curlx_open(tempstore, _O_WRONLY | _O_CREAT | _O_EXCL, + _S_IREAD | _S_IWRITE); +#elif (defined(ANDROID) || defined(__ANDROID__)) && \ + (defined(__i386__) || defined(__arm__)) + fd = curlx_open(tempstore, O_WRONLY | O_CREAT | O_EXCL, + (mode_t)(S_IRUSR | S_IWUSR | sb.st_mode)); +#else + fd = curlx_open(tempstore, O_WRONLY | O_CREAT | O_EXCL, + S_IRUSR | S_IWUSR | sb.st_mode); +#endif + if(fd == -1) + goto fail; + + *fh = curlx_fdopen(fd, FOPEN_WRITETEXT); + if(!*fh) + goto fail; + + *tempname = tempstore; + return CURLE_OK; + +fail: + if(fd != -1) { + curlx_close(fd); + unlink(tempstore); + } + + curlx_free(tempstore); + return result; +} + +#endif /* !disabled */ diff --git a/3rdparty/curl-8.21.0/lib/curl_fopen.h b/3rdparty/curl-8.21.0/lib/curl_fopen.h new file mode 100644 index 0000000000..bd402d4489 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_fopen.h @@ -0,0 +1,31 @@ +#ifndef HEADER_CURL_FOPEN_H +#define HEADER_CURL_FOPEN_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curlx/fopen.h" + +CURLcode Curl_fopen(struct Curl_easy *data, const char *filename, + FILE **fh, char **tempname); + +#endif diff --git a/3rdparty/curl-8.21.0/lib/curl_get_line.c b/3rdparty/curl-8.21.0/lib/curl_get_line.c new file mode 100644 index 0000000000..6fcd043c93 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_get_line.c @@ -0,0 +1,69 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_COOKIES) || !defined(CURL_DISABLE_ALTSVC) || \ + !defined(CURL_DISABLE_HSTS) || !defined(CURL_DISABLE_NETRC) + +#include "curl_get_line.h" + +/* + * Curl_get_line() returns only complete whole lines that end with newline. + * When 'eof' is set TRUE, the last line has been read. + */ +CURLcode Curl_get_line(struct dynbuf *buf, FILE *input, bool *eof) +{ + CURLcode result; + char buffer[128]; + curlx_dyn_reset(buf); + while(1) { + size_t rlen; + const char *b = fgets(buffer, sizeof(buffer), input); + if(!b && ferror(input)) + return CURLE_READ_ERROR; + + *eof = feof(input); + + rlen = b ? strlen(b) : 0; + if(rlen) { + result = curlx_dyn_addn(buf, b, rlen); + if(result) + /* too long line or out of memory */ + return result; + } + /* now check the full line */ + rlen = curlx_dyn_len(buf); + b = curlx_dyn_ptr(buf); + if(rlen && (b[rlen - 1] == '\n')) + /* LF at end of the line */ + return CURLE_OK; /* all good */ + if(*eof) + /* append a newline */ + return curlx_dyn_addn(buf, "\n", 1); + /* otherwise get next line to append */ + } + /* UNREACHABLE */ +} + +#endif /* if not disabled */ diff --git a/3rdparty/curl-8.21.0/lib/curl_get_line.h b/3rdparty/curl-8.21.0/lib/curl_get_line.h new file mode 100644 index 0000000000..6b90ac4727 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_get_line.h @@ -0,0 +1,31 @@ +#ifndef HEADER_CURL_GET_LINE_H +#define HEADER_CURL_GET_LINE_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curlx/dynbuf.h" + +/* Curl_get_line() returns complete lines that end with a newline. */ +CURLcode Curl_get_line(struct dynbuf *buf, FILE *input, bool *eof); + +#endif /* HEADER_CURL_GET_LINE_H */ diff --git a/3rdparty/curl-8.21.0/lib/curl_gethostname.c b/3rdparty/curl-8.21.0/lib/curl_gethostname.c new file mode 100644 index 0000000000..f154c837f6 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_gethostname.c @@ -0,0 +1,96 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "curl_gethostname.h" +#include "curlx/strcopy.h" + +/* + * Curl_gethostname() is a wrapper around gethostname() which allows + * overriding the hostname that the function would normally return. + * This capability is used by the test suite to verify exact matching + * of NTLM authentication, which exercises libcurl's MD4 and DES code + * as well as by the SMTP module when a hostname is not provided. + * + * For libcurl debug enabled builds hostname overriding takes place + * when environment variable CURL_GETHOSTNAME is set, using the value + * held by the variable to override returned hostname. + * + * Note: The function always returns the un-qualified hostname rather + * than being provider dependent. + */ + +int Curl_gethostname(char * const name, GETHOSTNAME_TYPE_ARG2 namelen) +{ +#ifndef HAVE_GETHOSTNAME + + /* Allow compilation and return failure when unavailable */ + (void)name; + (void)namelen; + return -1; + +#else + int err; + char *dot; + +#ifdef DEBUGBUILD + + /* Override hostname when environment variable CURL_GETHOSTNAME is set */ + const char *force_hostname = getenv("CURL_GETHOSTNAME"); + if(force_hostname) { + if(strlen(force_hostname) < (size_t)namelen) + curlx_strcopy(name, namelen, force_hostname, strlen(force_hostname)); + else + return 1; /* cannot do it */ + err = 0; + } + else { + name[0] = '\0'; + err = gethostname(name, namelen); + } + +#else /* DEBUGBUILD */ + + name[0] = '\0'; +#ifdef __AMIGA__ + err = gethostname((unsigned char *)name, namelen); +#else + err = gethostname(name, namelen); +#endif + +#endif + + name[namelen - 1] = '\0'; + + if(err) + return err; + + /* Truncate domain, leave only machine name */ + dot = strchr(name, '.'); + if(dot) + *dot = '\0'; + + return 0; +#endif +} diff --git a/3rdparty/curl-8.21.0/lib/curl_gethostname.h b/3rdparty/curl-8.21.0/lib/curl_gethostname.h new file mode 100644 index 0000000000..9281d9c242 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_gethostname.h @@ -0,0 +1,33 @@ +#ifndef HEADER_CURL_GETHOSTNAME_H +#define HEADER_CURL_GETHOSTNAME_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +/* Hostname buffer size */ +#define HOSTNAME_MAX 1024 + +/* This returns the local machine's un-qualified hostname */ +int Curl_gethostname(char * const name, GETHOSTNAME_TYPE_ARG2 namelen); + +#endif /* HEADER_CURL_GETHOSTNAME_H */ diff --git a/3rdparty/curl-8.21.0/lib/curl_gssapi.c b/3rdparty/curl-8.21.0/lib/curl_gssapi.c new file mode 100644 index 0000000000..07a6c1e7ed --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_gssapi.c @@ -0,0 +1,447 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef HAVE_GSSAPI + +#include "curl_gssapi.h" +#include "curl_trc.h" +#include "curlx/strcopy.h" + +#ifdef DEBUGBUILD +#if defined(HAVE_GSSGNU) || !defined(_WIN32) +#define Curl_gss_alloc malloc /* freed via the GSS API gss_release_buffer() */ +#define Curl_gss_free free /* pair of the above */ +#define CURL_GSS_STUB +/* For correctness this would be required for all platforms, not only Windows, + but, as of v1.22.1, MIT Kerberos uses a special allocator only for Windows, + and the availability of 'gssapi/gssapi_alloc.h' is difficult to detect, + because GSS headers are not versioned, and there is also no other macro to + indicate 1.18+ vs. previous versions. On Windows we can use 'GSS_S_BAD_MIC'. + */ +#elif defined(_WIN32) && defined(GSS_S_BAD_MIC) /* MIT Kerberos 1.15+ */ +/* MIT Kerberos 1.10+ (Windows), 1.18+ (all platforms), missing from GNU GSS */ +#include +#define Curl_gss_alloc gssalloc_malloc +#define Curl_gss_free gssalloc_free +#define CURL_GSS_STUB +#endif +#endif /* DEBUGBUILD */ + +#ifdef __GNUC__ +#define CURL_ALIGN8 __attribute__((aligned(8))) +#else +#define CURL_ALIGN8 +#endif + +#if defined(CURL_HAVE_DIAG) && defined(__APPLE__) +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Wdeprecated-declarations" +#endif + +gss_OID_desc Curl_spnego_mech_oid CURL_ALIGN8 = { + 6, CURL_UNCONST("\x2b\x06\x01\x05\x05\x02") +}; +gss_OID_desc Curl_krb5_mech_oid CURL_ALIGN8 = { + 9, CURL_UNCONST("\x2a\x86\x48\x86\xf7\x12\x01\x02\x02") +}; + +#ifdef CURL_GSS_STUB +enum min_err_code { + STUB_GSS_OK = 0, + STUB_GSS_NO_MEMORY, + STUB_GSS_INVALID_ARGS, + STUB_GSS_INVALID_CREDS, + STUB_GSS_INVALID_CTX, + STUB_GSS_SERVER_ERR, + STUB_GSS_NO_MECH, + STUB_GSS_LAST +}; + +/* libcurl is also passing this struct to these functions, which are not yet + * stubbed: + * gss_inquire_context() + * gss_unwrap() + * gss_wrap() + */ +struct stub_gss_ctx_id_t_desc { + enum { STUB_GSS_NONE, STUB_GSS_KRB5, STUB_GSS_NTLM1, STUB_GSS_NTLM3 } sent; + int have_krb5; + int have_ntlm; + OM_uint32 flags; + char creds[250]; +}; + +static OM_uint32 stub_gss_init_sec_context( + OM_uint32 *min, + gss_cred_id_t initiator_cred_handle, + struct stub_gss_ctx_id_t_desc **context, + gss_name_t target_name, + const gss_OID mech_type, + OM_uint32 req_flags, + OM_uint32 time_req, + const gss_channel_bindings_t input_chan_bindings, + gss_buffer_desc *input_token, + gss_OID *actual_mech_type, + gss_buffer_desc *output_token, + OM_uint32 *ret_flags, + OM_uint32 *time_rec) +{ + struct stub_gss_ctx_id_t_desc *ctx = NULL; + + /* The token will be encoded in base64 */ + size_t length = sizeof(ctx->creds) * 3 / 4; + size_t used = 0; + char *token = NULL; + const char *creds = NULL; + + (void)initiator_cred_handle; + (void)mech_type; + (void)time_req; + (void)input_chan_bindings; + (void)actual_mech_type; + + if(!min) + return GSS_S_FAILURE; + + *min = 0; + + if(!context || !target_name || !output_token) { + *min = STUB_GSS_INVALID_ARGS; + return GSS_S_FAILURE; + } + + creds = getenv("CURL_STUB_GSS_CREDS"); + if(!creds || strlen(creds) >= sizeof(ctx->creds)) { + *min = STUB_GSS_INVALID_CREDS; + return GSS_S_FAILURE; + } + + ctx = *context; + if(ctx && strcmp(ctx->creds, creds)) { + *min = STUB_GSS_INVALID_CREDS; + return GSS_S_FAILURE; + } + + output_token->length = 0; + output_token->value = NULL; + + if(input_token && input_token->length) { + if(!ctx) { + *min = STUB_GSS_INVALID_CTX; + return GSS_S_FAILURE; + } + + /* Server response, either D (RA==) or C (Qw==) */ + if(((char *)input_token->value)[0] == 'D') { + /* Done */ + switch(ctx->sent) { + case STUB_GSS_KRB5: + case STUB_GSS_NTLM3: + if(ret_flags) + *ret_flags = ctx->flags; + if(time_rec) + *time_rec = GSS_C_INDEFINITE; + return GSS_S_COMPLETE; + default: + *min = STUB_GSS_SERVER_ERR; + return GSS_S_FAILURE; + } + } + + if(((char *)input_token->value)[0] != 'C') { + /* We only support Done or Continue */ + *min = STUB_GSS_SERVER_ERR; + return GSS_S_FAILURE; + } + + /* Continue */ + switch(ctx->sent) { + case STUB_GSS_KRB5: + /* We sent KRB5 and it failed, let's try NTLM */ + if(ctx->have_ntlm) { + ctx->sent = STUB_GSS_NTLM1; + break; + } + else { + *min = STUB_GSS_SERVER_ERR; + return GSS_S_FAILURE; + } + case STUB_GSS_NTLM1: + ctx->sent = STUB_GSS_NTLM3; + break; + default: + *min = STUB_GSS_SERVER_ERR; + return GSS_S_FAILURE; + } + } + else { + if(ctx) { + *min = STUB_GSS_INVALID_CTX; + return GSS_S_FAILURE; + } + + ctx = curlx_calloc(1, sizeof(*ctx)); + if(!ctx) { + *min = STUB_GSS_NO_MEMORY; + return GSS_S_FAILURE; + } + + if(strstr(creds, "KRB5")) + ctx->have_krb5 = 1; + + if(strstr(creds, "NTLM")) + ctx->have_ntlm = 1; + + if(ctx->have_krb5) + ctx->sent = STUB_GSS_KRB5; + else if(ctx->have_ntlm) + ctx->sent = STUB_GSS_NTLM1; + else { + curlx_free(ctx); + *min = STUB_GSS_NO_MECH; + return GSS_S_FAILURE; + } + + curlx_strcopy(ctx->creds, sizeof(ctx->creds), creds, strlen(creds)); + ctx->flags = req_flags; + } + + token = Curl_gss_alloc(length); + if(!token) { + curlx_free(ctx); + *min = STUB_GSS_NO_MEMORY; + return GSS_S_FAILURE; + } + + { + gss_buffer_desc target_desc; + gss_OID name_type = GSS_C_NO_OID; + OM_uint32 minor_status; + OM_uint32 major_status; + major_status = gss_display_name(&minor_status, target_name, + &target_desc, &name_type); + if(GSS_ERROR(major_status)) { + Curl_gss_free(token); + curlx_free(ctx); + *min = STUB_GSS_NO_MEMORY; + return GSS_S_FAILURE; + } + + if(strlen(creds) + target_desc.length + 5 >= sizeof(ctx->creds)) { + Curl_gss_free(token); + curlx_free(ctx); + *min = STUB_GSS_NO_MEMORY; + return GSS_S_FAILURE; + } + + /* Token format: creds:target:type:padding */ + used = curl_msnprintf(token, length, "%s:%.*s:%d:", creds, + (int)target_desc.length, + (const char *)target_desc.value, + (int)ctx->sent); + + gss_release_buffer(&minor_status, &target_desc); + } + + if(used >= length) { + Curl_gss_free(token); + curlx_free(ctx); + *min = STUB_GSS_NO_MEMORY; + return GSS_S_FAILURE; + } + + /* Overwrite null-terminator */ + memset(token + used, 'A', length - used); + + *context = ctx; + + output_token->value = token; + output_token->length = length; + + return GSS_S_CONTINUE_NEEDED; +} + +static OM_uint32 stub_gss_delete_sec_context( + OM_uint32 *min, + struct stub_gss_ctx_id_t_desc **context, + gss_buffer_t output_token) +{ + (void)output_token; + + if(!min) + return GSS_S_FAILURE; + + if(!context) { + *min = STUB_GSS_INVALID_CTX; + return GSS_S_FAILURE; + } + if(!*context) { + *min = STUB_GSS_INVALID_CTX; + return GSS_S_FAILURE; + } + + curlx_safefree(*context); + *min = 0; + + return GSS_S_COMPLETE; +} +#endif /* CURL_GSS_STUB */ + +OM_uint32 Curl_gss_init_sec_context(struct Curl_easy *data, + OM_uint32 *minor_status, + gss_ctx_id_t *context, + gss_name_t target_name, + gss_OID mech_type, + gss_channel_bindings_t input_chan_bindings, + gss_buffer_t input_token, + gss_buffer_t output_token, + const bool mutual_auth, + OM_uint32 *ret_flags) +{ + OM_uint32 req_flags = GSS_C_REPLAY_FLAG; + + if(mutual_auth) + req_flags |= GSS_C_MUTUAL_FLAG; + + if(data->set.gssapi_delegation & CURLGSSAPI_DELEGATION_POLICY_FLAG) { +#ifdef GSS_C_DELEG_POLICY_FLAG /* MIT Kerberos 1.8+, missing from GNU GSS */ + req_flags |= GSS_C_DELEG_POLICY_FLAG; +#else + infof(data, "WARNING: support for CURLGSSAPI_DELEGATION_POLICY_FLAG not " + "compiled in"); +#endif + } + + if(data->set.gssapi_delegation & CURLGSSAPI_DELEGATION_FLAG) + req_flags |= GSS_C_DELEG_FLAG; + +#ifdef CURL_GSS_STUB + if(getenv("CURL_STUB_GSS_CREDS")) + return stub_gss_init_sec_context(minor_status, + GSS_C_NO_CREDENTIAL, /* cred_handle */ + (struct stub_gss_ctx_id_t_desc **)context, + target_name, + mech_type, + req_flags, + 0, /* time_req */ + input_chan_bindings, + input_token, + NULL, /* actual_mech_type */ + output_token, + ret_flags, + NULL /* time_rec */); +#endif /* CURL_GSS_STUB */ + + return gss_init_sec_context(minor_status, + GSS_C_NO_CREDENTIAL, /* cred_handle */ + context, + target_name, + mech_type, + req_flags, + 0, /* time_req */ + input_chan_bindings, + input_token, + NULL, /* actual_mech_type */ + output_token, + ret_flags, + NULL /* time_rec */); +} + +OM_uint32 Curl_gss_delete_sec_context(OM_uint32 *min, + gss_ctx_id_t *context, + gss_buffer_t output_token) +{ +#ifdef CURL_GSS_STUB + if(getenv("CURL_STUB_GSS_CREDS")) + return stub_gss_delete_sec_context(min, + (struct stub_gss_ctx_id_t_desc **)context, + output_token); +#endif /* CURL_GSS_STUB */ + + return gss_delete_sec_context(min, context, output_token); +} + +#ifdef CURLVERBOSE +#define GSS_LOG_BUFFER_LEN 1024 +static size_t display_gss_error(OM_uint32 status, int type, + char *buf, size_t len) +{ + OM_uint32 maj_stat; + OM_uint32 min_stat; + OM_uint32 msg_ctx = 0; + gss_buffer_desc status_string = GSS_C_EMPTY_BUFFER; + + do { + maj_stat = gss_display_status(&min_stat, + status, + type, + GSS_C_NO_OID, + &msg_ctx, + &status_string); + if(maj_stat == GSS_S_COMPLETE && status_string.length > 0) { + if(GSS_LOG_BUFFER_LEN > len + status_string.length + 3) { + len += curl_msnprintf(buf + len, GSS_LOG_BUFFER_LEN - len, + "%.*s. ", (int)status_string.length, + (char *)status_string.value); + } + } + gss_release_buffer(&min_stat, &status_string); + } while(!GSS_ERROR(maj_stat) && msg_ctx); + + return len; +} + +/* + * Curl_gss_log_error() + * + * This is used to log a GSS-API error status. + * + * Parameters: + * + * data [in] - The session handle. + * prefix [in] - The prefix of the log message. + * major [in] - The major status code. + * minor [in] - The minor status code. + */ +void Curl_gss_log_error(struct Curl_easy *data, const char *prefix, + OM_uint32 major, OM_uint32 minor) +{ + char buf[GSS_LOG_BUFFER_LEN] = ""; + size_t len = 0; + + if(major != GSS_S_FAILURE) + len = display_gss_error(major, GSS_C_GSS_CODE, buf, len); + + display_gss_error(minor, GSS_C_MECH_CODE, buf, len); + + infof(data, "%s%s", prefix, buf); +} +#endif /* CURLVERBOSE */ + +#if defined(CURL_HAVE_DIAG) && defined(__APPLE__) +#pragma GCC diagnostic pop +#endif + +#endif /* HAVE_GSSAPI */ diff --git a/3rdparty/curl-8.21.0/lib/curl_gssapi.h b/3rdparty/curl-8.21.0/lib/curl_gssapi.h new file mode 100644 index 0000000000..fc3759ebcb --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_gssapi.h @@ -0,0 +1,70 @@ +#ifndef HEADER_CURL_GSSAPI_H +#define HEADER_CURL_GSSAPI_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "urldata.h" + +#ifdef HAVE_GSSAPI +extern gss_OID_desc Curl_spnego_mech_oid; +extern gss_OID_desc Curl_krb5_mech_oid; + +/* Common method for using GSS-API */ +OM_uint32 Curl_gss_init_sec_context(struct Curl_easy *data, + OM_uint32 *minor_status, + gss_ctx_id_t *context, + gss_name_t target_name, + gss_OID mech_type, + gss_channel_bindings_t input_chan_bindings, + gss_buffer_t input_token, + gss_buffer_t output_token, + const bool mutual_auth, + OM_uint32 *ret_flags); + +OM_uint32 Curl_gss_delete_sec_context(OM_uint32 *min, + gss_ctx_id_t *context, + gss_buffer_t output_token); + +#ifdef CURLVERBOSE +/* Helper to log a GSS-API error status */ +void Curl_gss_log_error(struct Curl_easy *data, const char *prefix, + OM_uint32 major, OM_uint32 minor); +#else +#define Curl_gss_log_error(data, prefix, major, minor) \ + do { \ + (void)(data); \ + (void)(prefix); \ + (void)(major); \ + (void)(minor); \ + } while(0) +#endif + +/* Define our privacy and integrity protection values */ +#define GSSAUTH_P_NONE 1 +#define GSSAUTH_P_INTEGRITY 2 +#define GSSAUTH_P_PRIVACY 4 + +#endif /* HAVE_GSSAPI */ +#endif /* HEADER_CURL_GSSAPI_H */ diff --git a/3rdparty/curl-8.21.0/lib/curl_hmac.h b/3rdparty/curl-8.21.0/lib/curl_hmac.h new file mode 100644 index 0000000000..d9a697a0a5 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_hmac.h @@ -0,0 +1,71 @@ +#ifndef HEADER_CURL_HMAC_H +#define HEADER_CURL_HMAC_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +#if (defined(USE_CURL_NTLM_CORE) && !defined(USE_WINDOWS_SSPI)) || \ + !defined(CURL_DISABLE_AWS) || !defined(CURL_DISABLE_DIGEST_AUTH) || \ + defined(USE_LIBSSH2) || defined(USE_SSL) + +#define HMAC_MD5_LENGTH 16 + +typedef CURLcode (*HMAC_hinit)(void *context); +typedef void (*HMAC_hupdate)(void *context, + const unsigned char *data, + unsigned int len); +typedef void (*HMAC_hfinal)(unsigned char *result, void *context); + +/* Per-hash function HMAC parameters. */ +struct HMAC_params { + HMAC_hinit hinit; /* Initialize context procedure. */ + HMAC_hupdate hupdate; /* Update context with data. */ + HMAC_hfinal hfinal; /* Get final result procedure. */ + unsigned int ctxtsize; /* Context structure size. */ + unsigned int maxkeylen; /* Maximum key length (bytes). */ + unsigned int resultlen; /* Result length (bytes). */ +}; + +/* HMAC computation context. */ +struct HMAC_context { + const struct HMAC_params *hash; /* Hash function definition. */ + void *hashctxt1; /* Hash function context 1. */ + void *hashctxt2; /* Hash function context 2. */ +}; + +/* Prototypes. */ +struct HMAC_context *Curl_HMAC_init(const struct HMAC_params *hashparams, + const unsigned char *key, + unsigned int keylen); +void Curl_HMAC_update(struct HMAC_context *ctxt, + const unsigned char *data, + unsigned int len); +int Curl_HMAC_final(struct HMAC_context *ctxt, unsigned char *output); + +CURLcode Curl_hmacit(const struct HMAC_params *hashparams, + const unsigned char *key, const size_t keylen, + const unsigned char *data, size_t datalen, + unsigned char *output); +#endif + +#endif /* HEADER_CURL_HMAC_H */ diff --git a/3rdparty/curl-8.21.0/lib/curl_ldap.h b/3rdparty/curl-8.21.0/lib/curl_ldap.h new file mode 100644 index 0000000000..0ccc1289e2 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_ldap.h @@ -0,0 +1,30 @@ +#ifndef HEADER_CURL_LDAP_H +#define HEADER_CURL_LDAP_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +extern const struct Curl_protocol Curl_protocol_ldap; + +void Curl_ldap_version(char *buf, size_t bufsz); + +#endif /* HEADER_CURL_LDAP_H */ diff --git a/3rdparty/curl-8.21.0/lib/curl_md4.h b/3rdparty/curl-8.21.0/lib/curl_md4.h new file mode 100644 index 0000000000..05d1624974 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_md4.h @@ -0,0 +1,37 @@ +#ifndef HEADER_CURL_MD4_H +#define HEADER_CURL_MD4_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_CURL_NTLM_CORE + +#define MD4_DIGEST_LENGTH 16 + +CURLcode Curl_md4it(unsigned char *output, const unsigned char *input, + const size_t len); + +#endif /* USE_CURL_NTLM_CORE */ + +#endif /* HEADER_CURL_MD4_H */ diff --git a/3rdparty/curl-8.21.0/lib/curl_md5.h b/3rdparty/curl-8.21.0/lib/curl_md5.h new file mode 100644 index 0000000000..1beaed5e66 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_md5.h @@ -0,0 +1,67 @@ +#ifndef HEADER_CURL_MD5_H +#define HEADER_CURL_MD5_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +#if (defined(USE_CURL_NTLM_CORE) && !defined(USE_WINDOWS_SSPI)) || \ + !defined(CURL_DISABLE_DIGEST_AUTH) + +#include "curl_hmac.h" + +#define MD5_DIGEST_LEN 16 + +typedef CURLcode (*Curl_MD5_init_func)(void *context); +typedef void (*Curl_MD5_update_func)(void *context, + const unsigned char *data, + unsigned int len); +typedef void (*Curl_MD5_final_func)(unsigned char *result, void *context); + +struct MD5_params { + Curl_MD5_init_func md5_init_func; /* Initialize context procedure */ + Curl_MD5_update_func md5_update_func; /* Update context with data */ + Curl_MD5_final_func md5_final_func; /* Get final result procedure */ + unsigned int md5_ctxtsize; /* Context structure size */ + unsigned int md5_resultlen; /* Result length (bytes) */ +}; + +struct MD5_context { + const struct MD5_params *md5_hash; /* Hash function definition */ + void *md5_hashctx; /* Hash function context */ +}; + +extern const struct MD5_params Curl_DIGEST_MD5; +extern const struct HMAC_params Curl_HMAC_MD5; + +CURLcode Curl_md5it(unsigned char *output, const unsigned char *input, + size_t len); + +struct MD5_context *Curl_MD5_init(const struct MD5_params *md5params); +CURLcode Curl_MD5_update(struct MD5_context *context, + const unsigned char *input, + unsigned int len); +CURLcode Curl_MD5_final(struct MD5_context *context, unsigned char *result); + +#endif + +#endif /* HEADER_CURL_MD5_H */ diff --git a/3rdparty/curl-8.21.0/lib/curl_memrchr.c b/3rdparty/curl-8.21.0/lib/curl_memrchr.c new file mode 100644 index 0000000000..59ee176bc9 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_memrchr.c @@ -0,0 +1,53 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "curl_memrchr.h" + +#ifndef HAVE_MEMRCHR +/* + * Curl_memrchr() + * + * Our memrchr() function clone for systems which lack this function. The + * memrchr() function is like the memchr() function, except that it searches + * backwards from the end of the n bytes pointed to by s instead of forward + * from the beginning. + */ +void *Curl_memrchr(const void *s, int c, size_t n) +{ + if(n > 0) { + const unsigned char *p = s; + const unsigned char *q = s; + + p += n - 1; + + while(p >= q) { + if(*p == (unsigned char)c) + return CURL_UNCONST(p); + p--; + } + } + return NULL; +} +#endif /* HAVE_MEMRCHR */ diff --git a/3rdparty/curl-8.21.0/lib/curl_memrchr.h b/3rdparty/curl-8.21.0/lib/curl_memrchr.h new file mode 100644 index 0000000000..248368b25c --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_memrchr.h @@ -0,0 +1,40 @@ +#ifndef HEADER_CURL_MEMRCHR_H +#define HEADER_CURL_MEMRCHR_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef HAVE_MEMRCHR + +#ifdef HAVE_STRINGS_H +# include +#endif + +#else /* HAVE_MEMRCHR */ +void *Curl_memrchr(const void *s, int c, size_t n); +#define memrchr(x, y, z) Curl_memrchr(x, y, z) + +#endif /* HAVE_MEMRCHR */ + +#endif /* HEADER_CURL_MEMRCHR_H */ diff --git a/3rdparty/curl-8.21.0/lib/curl_ntlm_core.c b/3rdparty/curl-8.21.0/lib/curl_ntlm_core.c new file mode 100644 index 0000000000..58a446c95d --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_ntlm_core.c @@ -0,0 +1,667 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_CURL_NTLM_CORE + +/* + * NTLM details: + * + * https://davenport.sourceforge.net/ntlm.html + * https://www.innovation.ch/java/ntlm.html + */ + +/* Please keep the SSL backend-specific #if branches in this order: + + 1. USE_OPENSSL + 2. USE_WOLFSSL + 3. USE_GNUTLS + 4. USE_MBEDTLS + 5. USE_OS400CRYPTO + 6. USE_WIN32_CRYPTO + + This ensures that: + - the same SSL branch gets activated throughout this source + file even if multiple backends are enabled at the same time. + - OpenSSL has higher priority than Windows Crypt, due + to issues with the latter supporting NTLM2Session responses + in NTLM type-3 messages. + */ + +#ifdef USE_GNUTLS +#include +#if NETTLE_VERSION_MAJOR < 4 +#define USE_GNUTLS_DES +#endif +#endif + +#if defined(USE_OPENSSL) && defined(HAVE_DES_ECB_ENCRYPT) + +# include +# ifdef OPENSSL_IS_AWSLC /* for versions 1.2.0 to 1.30.1 */ +# define DES_set_key_unchecked (void)DES_set_key +# endif +# define USE_OPENSSL_DES + +#elif defined(USE_WOLFSSL) && defined(HAVE_WC_DES_ECBENCRYPT) + +# include +# include +# define USE_WOLFSSL_DES + +#elif defined(USE_GNUTLS_DES) +# include +# define USE_CURL_DES_SET_ODD_PARITY +#elif defined(USE_MBEDTLS) && defined(HAVE_MBEDTLS_DES_CRYPT_ECB) +# include +# if MBEDTLS_VERSION_NUMBER < 0x03020000 +# error "mbedTLS 3.2.0 or later required" +# endif +# include +# define USE_MBEDTLS_DES +#elif defined(USE_OS400CRYPTO) +# include "cipher.mih" /* mih/cipher */ +# define USE_CURL_DES_SET_ODD_PARITY +#elif defined(USE_WIN32_CRYPTO) +# include +# define USE_CURL_DES_SET_ODD_PARITY +#else +# error "cannot compile NTLM support without a crypto library with DES." +#endif + +#include "urldata.h" +#include "strcase.h" +#include "curl_ntlm_core.h" +#include "curl_md5.h" +#include "curl_hmac.h" +#include "curl_md4.h" +#include "vauth/vauth.h" + +#ifdef USE_CURL_DES_SET_ODD_PARITY +/* + * curl_des_set_odd_parity() + * + * Copyright (C) Steve Holme, + * + * This is used to apply odd parity to the given byte array. It is typically + * used by when a cryptography engine does not have its own version. + * + * The function is a port of the Java based oddParity() function over at: + * + * https://davenport.sourceforge.net/ntlm.html + * + * Parameters: + * + * bytes [in/out] - The data whose parity bits are to be adjusted for + * odd parity. + * len [in] - The length of the data. + */ +static void curl_des_set_odd_parity(unsigned char *bytes, size_t len) +{ + size_t i; + + for(i = 0; i < len; i++) { + unsigned char b = bytes[i]; + + bool needs_parity = (((b >> 7) ^ (b >> 6) ^ (b >> 5) ^ + (b >> 4) ^ (b >> 3) ^ (b >> 2) ^ + (b >> 1)) & 0x01) == 0; + + if(needs_parity) + bytes[i] |= 0x01; + else + bytes[i] &= 0xfe; + } +} +#endif /* USE_CURL_DES_SET_ODD_PARITY */ + +/* + * Turns a 56-bit key into being 64-bit wide. + */ +static void extend_key_56_to_64(const unsigned char *key_56, char *key) +{ + key[0] = (char)key_56[0]; + key[1] = (char)(((key_56[0] << 7) & 0xFF) | (key_56[1] >> 1)); + key[2] = (char)(((key_56[1] << 6) & 0xFF) | (key_56[2] >> 2)); + key[3] = (char)(((key_56[2] << 5) & 0xFF) | (key_56[3] >> 3)); + key[4] = (char)(((key_56[3] << 4) & 0xFF) | (key_56[4] >> 4)); + key[5] = (char)(((key_56[4] << 3) & 0xFF) | (key_56[5] >> 5)); + key[6] = (char)(((key_56[5] << 2) & 0xFF) | (key_56[6] >> 6)); + key[7] = (char)((key_56[6] << 1) & 0xFF); +} + +#ifdef USE_OPENSSL_DES +/* + * Turns a 56-bit key into a 64-bit, odd parity key and sets the key. The + * key schedule ks is also set. + */ +static void setup_des_key(const unsigned char *key_56, DES_key_schedule *ks) +{ + DES_cblock key; + + /* Expand the 56-bit key to 64 bits */ + extend_key_56_to_64(key_56, (char *)&key); + + /* Set the key parity to odd */ + DES_set_odd_parity(&key); + + /* Set the key */ + DES_set_key_unchecked(&key, ks); +} + +#elif defined(USE_WOLFSSL_DES) +static void setup_des_key(const unsigned char *key_56, Des *des) +{ + byte key[8]; + + /* Expand the 56-bit key to 64 bits */ + extend_key_56_to_64(key_56, (char *)key); + + /* Set the key */ + wc_Des_SetKey(des, key, NULL, 0); +} + +#elif defined(USE_GNUTLS_DES) +static void setup_des_key(const unsigned char *key_56, struct des_ctx *des) +{ + char key[8]; + + /* Expand the 56-bit key to 64 bits */ + extend_key_56_to_64(key_56, key); + + /* Set the key parity to odd */ + curl_des_set_odd_parity((unsigned char *)key, sizeof(key)); + + /* Set the key */ + des_set_key(des, (const uint8_t *)key); +} + +#elif defined(USE_MBEDTLS_DES) +static bool encrypt_des(const unsigned char *in, unsigned char *out, + const unsigned char *key_56) +{ + mbedtls_des_context ctx; + char key[8]; + + /* Expand the 56-bit key to 64 bits */ + extend_key_56_to_64(key_56, key); + + /* Set the key parity to odd */ + mbedtls_des_key_set_parity((unsigned char *)key); + + /* Perform the encryption */ + mbedtls_des_init(&ctx); + mbedtls_des_setkey_enc(&ctx, (unsigned char *)key); + return mbedtls_des_crypt_ecb(&ctx, in, out) == 0; +} + +#elif defined(USE_OS400CRYPTO) +static bool encrypt_des(const unsigned char *in, unsigned char *out, + const unsigned char *key_56) +{ + char key[8]; + _CIPHER_Control_T ctl; + + /* Setup the cipher control structure */ + ctl.Func_ID = ENCRYPT_ONLY; + ctl.Data_Len = sizeof(key); + + /* Expand the 56-bit key to 64 bits */ + extend_key_56_to_64(key_56, ctl.Crypto_Key); + + /* Set the key parity to odd */ + curl_des_set_odd_parity((unsigned char *)ctl.Crypto_Key, ctl.Data_Len); + + /* Perform the encryption */ + _CIPHER((_SPCPTR *)&out, &ctl, (_SPCPTR *)&in); + + return TRUE; +} + +#elif defined(USE_WIN32_CRYPTO) +static bool encrypt_des(const unsigned char *in, unsigned char *out, + const unsigned char *key_56) +{ + HCRYPTPROV hprov; + HCRYPTKEY hkey; + struct { + BLOBHEADER hdr; + unsigned int len; + char key[8]; + } blob; + DWORD len = 8; + BOOL res; + + /* Acquire the crypto provider */ + if(!CryptAcquireContext(&hprov, NULL, NULL, PROV_RSA_FULL, + CRYPT_VERIFYCONTEXT | CRYPT_SILENT)) + return FALSE; + + /* Setup the key blob structure */ + memset(&blob, 0, sizeof(blob)); + blob.hdr.bType = PLAINTEXTKEYBLOB; + blob.hdr.bVersion = 2; + blob.hdr.aiKeyAlg = CALG_DES; + blob.len = sizeof(blob.key); + + /* Expand the 56-bit key to 64 bits */ + extend_key_56_to_64(key_56, blob.key); + + /* Set the key parity to odd */ + curl_des_set_odd_parity((unsigned char *)blob.key, sizeof(blob.key)); + + /* Import the key */ + if(!CryptImportKey(hprov, (BYTE *)&blob, sizeof(blob), 0, 0, &hkey)) { + CryptReleaseContext(hprov, 0); + + return FALSE; + } + + memcpy(out, in, 8); + + /* Perform the encryption */ + res = CryptEncrypt(hkey, 0, FALSE, 0, out, &len, len); + + CryptDestroyKey(hkey); + CryptReleaseContext(hprov, 0); + + return res; +} + +#endif /* crypto backends */ + +/* + * takes a 21-byte array and treats it as 3 56-bit DES keys. The + * 8-byte plaintext is encrypted with each key and the resulting 24 + * bytes are stored in the results array. + */ +void Curl_ntlm_core_lm_resp(const unsigned char *keys, + const unsigned char *plaintext, + unsigned char *results) +{ +#ifdef USE_OPENSSL_DES + DES_key_schedule ks; + + setup_des_key(keys, &ks); + DES_ecb_encrypt((DES_cblock *)CURL_UNCONST(plaintext), + (DES_cblock *)results, &ks, DES_ENCRYPT); + + setup_des_key(keys + 7, &ks); + DES_ecb_encrypt((DES_cblock *)CURL_UNCONST(plaintext), + (DES_cblock *)(results + 8), &ks, DES_ENCRYPT); + + setup_des_key(keys + 14, &ks); + DES_ecb_encrypt((DES_cblock *)CURL_UNCONST(plaintext), + (DES_cblock *)(results + 16), &ks, DES_ENCRYPT); +#elif defined(USE_WOLFSSL_DES) + Des des; + setup_des_key(keys, &des); + wc_Des_EcbEncrypt(&des, results, plaintext, DES_KEY_SIZE); + setup_des_key(keys + 7, &des); + wc_Des_EcbEncrypt(&des, results + 8, plaintext, DES_KEY_SIZE); + setup_des_key(keys + 14, &des); + wc_Des_EcbEncrypt(&des, results + 16, plaintext, DES_KEY_SIZE); +#elif defined(USE_GNUTLS_DES) + struct des_ctx des; + setup_des_key(keys, &des); + des_encrypt(&des, 8, results, plaintext); + setup_des_key(keys + 7, &des); + des_encrypt(&des, 8, results + 8, plaintext); + setup_des_key(keys + 14, &des); + des_encrypt(&des, 8, results + 16, plaintext); +#elif defined(USE_MBEDTLS_DES) || defined(USE_OS400CRYPTO) || \ + defined(USE_WIN32_CRYPTO) + encrypt_des(plaintext, results, keys); + encrypt_des(plaintext, results + 8, keys + 7); + encrypt_des(plaintext, results + 16, keys + 14); +#else + (void)keys; + (void)plaintext; + (void)results; +#endif +} + +/* + * Set up lanmanager hashed password + */ +CURLcode Curl_ntlm_core_mk_lm_hash(const char *password, + unsigned char *lmbuffer /* 21 bytes */) +{ + unsigned char pw[14]; + static const unsigned char magic[] = { + 0x4B, 0x47, 0x53, 0x21, 0x40, 0x23, 0x24, 0x25 /* i.e. KGS!@#$% */ + }; + size_t len = CURLMIN(strlen(password), 14); + + Curl_strntoupper((char *)pw, password, len); + memset(&pw[len], 0, 14 - len); + + { + /* Create LanManager hashed password. */ +#ifdef USE_OPENSSL_DES + DES_key_schedule ks; + + setup_des_key(pw, &ks); + DES_ecb_encrypt((DES_cblock *)CURL_UNCONST(magic), + (DES_cblock *)lmbuffer, &ks, DES_ENCRYPT); + + setup_des_key(pw + 7, &ks); + DES_ecb_encrypt((DES_cblock *)CURL_UNCONST(magic), + (DES_cblock *)(lmbuffer + 8), &ks, DES_ENCRYPT); +#elif defined(USE_WOLFSSL_DES) + Des des; + setup_des_key(pw, &des); + wc_Des_EcbEncrypt(&des, lmbuffer, magic, DES_KEY_SIZE); + setup_des_key(pw + 7, &des); + wc_Des_EcbEncrypt(&des, lmbuffer + 8, magic, DES_KEY_SIZE); +#elif defined(USE_GNUTLS_DES) + struct des_ctx des; + setup_des_key(pw, &des); + des_encrypt(&des, 8, lmbuffer, magic); + setup_des_key(pw + 7, &des); + des_encrypt(&des, 8, lmbuffer + 8, magic); +#elif defined(USE_MBEDTLS_DES) || defined(USE_OS400CRYPTO) || \ + defined(USE_WIN32_CRYPTO) + encrypt_des(magic, lmbuffer, pw); + encrypt_des(magic, lmbuffer + 8, pw + 7); +#endif + + memset(lmbuffer + 16, 0, 21 - 16); + } + + return CURLE_OK; +} + +static void ascii_to_unicode_le(unsigned char *dest, const char *src, + size_t srclen) +{ + size_t i; + for(i = 0; i < srclen; i++) { + dest[2 * i] = (unsigned char)src[i]; + dest[(2 * i) + 1] = '\0'; + } +} + +/* + * Set up nt hashed passwords + * @unittest: 1600 + */ +CURLcode Curl_ntlm_core_mk_nt_hash(const char *password, + unsigned char *ntbuffer /* 21 bytes */) +{ + size_t len = strlen(password); + unsigned char *pw; + CURLcode result; + if(len > SIZE_MAX / 2) /* avoid integer overflow */ + return CURLE_OUT_OF_MEMORY; + pw = len ? curlx_malloc(len * 2) : (unsigned char *)curlx_strdup(""); + if(!pw) + return CURLE_OUT_OF_MEMORY; + + ascii_to_unicode_le(pw, password, len); + + /* Create NT hashed password. */ + result = Curl_md4it(ntbuffer, pw, 2 * len); + if(!result) + memset(ntbuffer + 16, 0, 21 - 16); + + curlx_free(pw); + + return result; +} + +#ifndef USE_WINDOWS_SSPI + +#define NTLMv2_BLOB_SIGNATURE "\x01\x01\x00\x00" +#define NTLMv2_BLOB_LEN (44 - 16 + ntlm->target_info_len + 4) + +/* Timestamp in tenths of a microsecond since January 1, 1601 00:00:00 UTC. */ +struct ms_filetime { + unsigned int dwLowDateTime; + unsigned int dwHighDateTime; +}; + +/* Convert a time_t to an MS FILETIME (MS-DTYP section 2.3.3). */ +static void time2filetime(struct ms_filetime *ft, time_t t) +{ +#if SIZEOF_TIME_T > 4 + t = (t + (curl_off_t)11644473600) * 10000000; + ft->dwLowDateTime = (unsigned int)(t & 0xFFFFFFFF); + ft->dwHighDateTime = (unsigned int)(t >> 32); +#else + unsigned int r, s; + unsigned int i; + + ft->dwLowDateTime = (unsigned int)(t & 0xFFFFFFFF); + ft->dwHighDateTime = 0; + +#ifndef HAVE_TIME_T_UNSIGNED + /* Extend sign if needed. */ + if(ft->dwLowDateTime & 0x80000000) + ft->dwHighDateTime = ~(unsigned int)0; +#endif + + /* Bias seconds to Jan 1, 1601. + 134774 days = 11644473600 seconds = 0x2B6109100 */ + r = ft->dwLowDateTime; + ft->dwLowDateTime = (ft->dwLowDateTime + 0xB6109100U) & 0xFFFFFFFF; + ft->dwHighDateTime += ft->dwLowDateTime < r ? 0x03 : 0x02; + + /* Convert to tenths of microseconds. */ + ft->dwHighDateTime *= 10000000; + i = 32; + do { + i -= 8; + s = ((ft->dwLowDateTime >> i) & 0xFF) * (10000000 - 1); + r = (s << i) & 0xFFFFFFFF; + s >>= 1; /* Split shift to avoid width overflow. */ + s >>= 31 - i; + ft->dwLowDateTime = (ft->dwLowDateTime + r) & 0xFFFFFFFF; + if(ft->dwLowDateTime < r) + s++; + ft->dwHighDateTime += s; + } while(i); + ft->dwHighDateTime &= 0xFFFFFFFF; +#endif +} + +static void ascii_uppercase_to_unicode_le(unsigned char *dest, + const char *src, size_t srclen) +{ + size_t i; + for(i = 0; i < srclen; i++) { + dest[2 * i] = (unsigned char)(Curl_raw_toupper(src[i])); + dest[(2 * i) + 1] = '\0'; + } +} + +/* This creates the NTLMv2 hash by using NTLM hash as the key and Unicode + * (uppercase UserName + Domain) as the data + */ +CURLcode Curl_ntlm_core_mk_ntlmv2_hash(const char *user, size_t userlen, + const char *domain, size_t domlen, + unsigned char *ntlmhash, + unsigned char *ntlmv2hash) +{ + /* Unicode representation */ + size_t identity_len; + unsigned char *identity; + CURLcode result = CURLE_OK; + + if((userlen > CURL_MAX_INPUT_LENGTH) || (domlen > CURL_MAX_INPUT_LENGTH)) + return CURLE_OUT_OF_MEMORY; + + identity_len = (userlen + domlen) * 2; + identity = curlx_malloc(identity_len + 1); + + if(!identity) + return CURLE_OUT_OF_MEMORY; + + ascii_uppercase_to_unicode_le(identity, user, userlen); + ascii_to_unicode_le(identity + (userlen << 1), domain, domlen); + + result = Curl_hmacit(&Curl_HMAC_MD5, ntlmhash, 16, identity, identity_len, + ntlmv2hash); + curlx_free(identity); + + return result; +} + +/* + * Curl_ntlm_core_mk_ntlmv2_resp() + * + * This creates the NTLMv2 response as set in the NTLM type-3 message. + * + * Parameters: + * + * ntlmv2hash [in] - The NTLMv2 hash (16 bytes) + * challenge_client [in] - The client nonce (8 bytes) + * ntlm [in] - The NTLM data struct being used to read TargetInfo + and Server challenge received in the type-2 message + * ntresp [out] - The address where a pointer to newly allocated + * memory holding the NTLMv2 response. + * ntresp_len [out] - The length of the output message. + * + * Returns CURLE_OK on success. + */ +CURLcode Curl_ntlm_core_mk_ntlmv2_resp(const unsigned char *ntlmv2hash, + const unsigned char *challenge_client, + const struct ntlmdata *ntlm, + unsigned char **ntresp, + unsigned int *ntresp_len) +{ + /* NTLMv2 response structure : + ----------------------------------------------------------------------------- + 0 HMAC MD5 16 bytes + ------BLOB------------------------------------------------------------------- + 16 Signature 0x01010000 + 20 Reserved long (0x00000000) + 24 Timestamp LE, 64-bit signed value representing the number of + tenths of a microsecond since January 1, 1601. + 32 Client Nonce 8 bytes + 40 Unknown 4 bytes + 44 Target Info N bytes (from the type-2 message) + 44+N Unknown 4 bytes + ----------------------------------------------------------------------------- + */ + + unsigned int len = 0; + unsigned char *ptr = NULL; + unsigned char hmac_output[HMAC_MD5_LENGTH]; + struct ms_filetime tw; + + CURLcode result = CURLE_OK; + + /* Calculate the timestamp */ +#ifdef DEBUGBUILD + char *force_timestamp = getenv("CURL_FORCETIME"); + if(force_timestamp) + time2filetime(&tw, (time_t)0); + else +#endif + time2filetime(&tw, time(NULL)); + + /* Calculate the response len */ + len = HMAC_MD5_LENGTH + NTLMv2_BLOB_LEN; + + /* Allocate the response */ + ptr = curlx_calloc(1, len); + if(!ptr) + return CURLE_OUT_OF_MEMORY; + + /* Create the BLOB structure */ + curl_msnprintf((char *)ptr + HMAC_MD5_LENGTH, NTLMv2_BLOB_LEN, + "%c%c%c%c" /* NTLMv2_BLOB_SIGNATURE */ + "%c%c%c%c" /* Reserved = 0 */ + "%c%c%c%c%c%c%c%c", /* Timestamp */ + NTLMv2_BLOB_SIGNATURE[0], NTLMv2_BLOB_SIGNATURE[1], + NTLMv2_BLOB_SIGNATURE[2], NTLMv2_BLOB_SIGNATURE[3], + 0, 0, 0, 0, + LONGQUARTET(tw.dwLowDateTime), + LONGQUARTET(tw.dwHighDateTime)); + + memcpy(ptr + 32, challenge_client, 8); + if(ntlm->target_info_len) + memcpy(ptr + 44, ntlm->target_info, ntlm->target_info_len); + + /* Concatenate the Type 2 challenge with the BLOB and do HMAC MD5 */ + memcpy(ptr + 8, &ntlm->nonce[0], 8); + result = Curl_hmacit(&Curl_HMAC_MD5, ntlmv2hash, HMAC_MD5_LENGTH, ptr + 8, + NTLMv2_BLOB_LEN + 8, hmac_output); + if(result) { + curlx_free(ptr); + return result; + } + + /* Concatenate the HMAC MD5 output with the BLOB */ + memcpy(ptr, hmac_output, HMAC_MD5_LENGTH); + + /* Return the response */ + *ntresp = ptr; + *ntresp_len = len; + + return result; +} + +/* + * Curl_ntlm_core_mk_lmv2_resp() + * + * This creates the LMv2 response as used in the NTLM type-3 message. + * + * Parameters: + * + * ntlmv2hash [in] - The NTLMv2 hash (16 bytes) + * challenge_client [in] - The client nonce (8 bytes) + * challenge_server [in] - The server challenge (8 bytes) + * lmresp [out] - The LMv2 response (24 bytes) + * + * Returns CURLE_OK on success. + */ +CURLcode Curl_ntlm_core_mk_lmv2_resp(const unsigned char *ntlmv2hash, + const unsigned char *challenge_client, + const unsigned char *challenge_server, + unsigned char *lmresp) +{ + unsigned char data[16]; + unsigned char hmac_output[16]; + CURLcode result = CURLE_OK; + + memcpy(&data[0], challenge_server, 8); + memcpy(&data[8], challenge_client, 8); + + result = Curl_hmacit(&Curl_HMAC_MD5, ntlmv2hash, 16, &data[0], 16, + hmac_output); + if(result) + return result; + + /* Concatenate the HMAC MD5 output with the client nonce */ + memcpy(lmresp, hmac_output, 16); + memcpy(lmresp + 16, challenge_client, 8); + + return result; +} + +#endif /* !USE_WINDOWS_SSPI */ + +#endif /* USE_CURL_NTLM_CORE */ diff --git a/3rdparty/curl-8.21.0/lib/curl_ntlm_core.h b/3rdparty/curl-8.21.0/lib/curl_ntlm_core.h new file mode 100644 index 0000000000..df24158f8e --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_ntlm_core.h @@ -0,0 +1,73 @@ +#ifndef HEADER_CURL_NTLM_CORE_H +#define HEADER_CURL_NTLM_CORE_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_CURL_NTLM_CORE + +struct ntlmdata; + +/* Helpers to generate function byte arguments in little endian order */ +#define SHORTPAIR(x) ((int)((x) & 0xff)), ((int)(((x) >> 8) & 0xff)) +#define LONGQUARTET(x) ((int)((x) & 0xff)), ((int)(((x) >> 8) & 0xff)), \ + ((int)(((x) >> 16) & 0xff)), ((int)(((x) >> 24) & 0xff)) + +void Curl_ntlm_core_lm_resp(const unsigned char *keys, + const unsigned char *plaintext, + unsigned char *results); + +CURLcode Curl_ntlm_core_mk_lm_hash(const char *password, + unsigned char *lmbuffer /* 21 bytes */); + +CURLcode Curl_ntlm_core_mk_nt_hash(const char *password, + unsigned char *ntbuffer /* 21 bytes */); + +#ifndef USE_WINDOWS_SSPI + +CURLcode Curl_hmac_md5(const unsigned char *key, unsigned int keylen, + const unsigned char *data, unsigned int datalen, + unsigned char *output); + +CURLcode Curl_ntlm_core_mk_ntlmv2_hash(const char *user, size_t userlen, + const char *domain, size_t domlen, + unsigned char *ntlmhash, + unsigned char *ntlmv2hash); + +CURLcode Curl_ntlm_core_mk_ntlmv2_resp(const unsigned char *ntlmv2hash, + const unsigned char *challenge_client, + const struct ntlmdata *ntlm, + unsigned char **ntresp, + unsigned int *ntresp_len); + +CURLcode Curl_ntlm_core_mk_lmv2_resp(const unsigned char *ntlmv2hash, + const unsigned char *challenge_client, + const unsigned char *challenge_server, + unsigned char *lmresp); + +#endif /* !USE_WINDOWS_SSPI */ + +#endif /* USE_CURL_NTLM_CORE */ + +#endif /* HEADER_CURL_NTLM_CORE_H */ diff --git a/3rdparty/curl-8.21.0/lib/curl_printf.h b/3rdparty/curl-8.21.0/lib/curl_printf.h new file mode 100644 index 0000000000..3b1a5af3b4 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_printf.h @@ -0,0 +1,37 @@ +#ifndef HEADER_CURL_PRINTF_H +#define HEADER_CURL_PRINTF_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +#define MERR_OK 0 +#define MERR_MEM 1 +#define MERR_TOO_LARGE 2 + +/* Lower-case digits. */ +extern const unsigned char Curl_ldigits[]; + +/* Upper-case digits. */ +extern const unsigned char Curl_udigits[]; + +#endif /* HEADER_CURL_PRINTF_H */ diff --git a/3rdparty/curl-8.21.0/lib/curl_range.c b/3rdparty/curl-8.21.0/lib/curl_range.c new file mode 100644 index 0000000000..9bbafa40cf --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_range.c @@ -0,0 +1,91 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "curl_range.h" +#include "curl_trc.h" +#include "curlx/strparse.h" + +/* Only include this function if one or more of FTP, FILE are enabled. */ +#if !defined(CURL_DISABLE_FTP) || !defined(CURL_DISABLE_FILE) + +/* Check if this is a range download, and if so, set the internal variables + properly. */ +CURLcode Curl_range(struct Curl_easy *data) +{ + if(data->state.use_range && data->state.range) { + curl_off_t from, to; + bool first_num = TRUE; + const char *p = data->state.range; + if(curlx_str_number(&p, &from, CURL_OFF_T_MAX)) + first_num = FALSE; + + if(curlx_str_single(&p, '-')) + /* no leading dash or after the first number is an error */ + return CURLE_RANGE_ERROR; + + if(curlx_str_number(&p, &to, CURL_OFF_T_MAX)) { + /* no second number */ + /* X - */ + data->state.resume_from = from; + DEBUGF(infof(data, "RANGE %" FMT_OFF_T " to end of file", from)); + } + else if(!first_num) { + /* -Y */ + if(!to) + /* "-0" is wrong */ + return CURLE_RANGE_ERROR; + + data->req.maxdownload = to; + data->state.resume_from = -to; + DEBUGF(infof(data, "RANGE the last %" FMT_OFF_T " bytes", to)); + } + else { + /* X-Y */ + curl_off_t totalsize; + + /* Ensure the range is sensible - to should follow from. */ + if(from > to) + return CURLE_RANGE_ERROR; + + totalsize = to - from; + if(totalsize == CURL_OFF_T_MAX) + return CURLE_RANGE_ERROR; + + data->req.maxdownload = totalsize + 1; /* include last byte */ + data->state.resume_from = from; + DEBUGF(infof(data, "RANGE from %" FMT_OFF_T + " getting %" FMT_OFF_T " bytes", + from, data->req.maxdownload)); + } + DEBUGF(infof(data, "range-download from %" FMT_OFF_T + " to %" FMT_OFF_T ", totally %" FMT_OFF_T " bytes", + from, to, data->req.maxdownload)); + } + else + data->req.maxdownload = -1; + return CURLE_OK; +} + +#endif diff --git a/3rdparty/curl-8.21.0/lib/curl_range.h b/3rdparty/curl-8.21.0/lib/curl_range.h new file mode 100644 index 0000000000..97354677c2 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_range.h @@ -0,0 +1,31 @@ +#ifndef HEADER_CURL_RANGE_H +#define HEADER_CURL_RANGE_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "urldata.h" + +CURLcode Curl_range(struct Curl_easy *data); +#endif /* HEADER_CURL_RANGE_H */ diff --git a/3rdparty/curl-8.21.0/lib/curl_sasl.c b/3rdparty/curl-8.21.0/lib/curl_sasl.c new file mode 100644 index 0000000000..7e867d753f --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_sasl.c @@ -0,0 +1,910 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + * RFC2195 CRAM-MD5 authentication + * RFC2617 Basic and Digest Access Authentication + * RFC2831 DIGEST-MD5 authentication + * RFC4422 Simple Authentication and Security Layer (SASL) + * RFC4616 PLAIN authentication + * RFC5802 SCRAM-SHA-1 authentication + * RFC7677 SCRAM-SHA-256 authentication + * RFC6749 OAuth 2.0 Authorization Framework + * RFC7628 A Set of SASL Mechanisms for OAuth + * Draft LOGIN SASL Mechanism + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_IMAP) || !defined(CURL_DISABLE_SMTP) || \ + !defined(CURL_DISABLE_POP3) || \ + (!defined(CURL_DISABLE_LDAP) && defined(USE_OPENLDAP)) + +#include "urldata.h" +#include "curlx/base64.h" +#include "vauth/vauth.h" +#include "cfilters.h" +#include "curl_sasl.h" +#include "curl_trc.h" + +/* Supported mechanisms */ +static const struct { + const char *name; /* Name */ + size_t len; /* Name length */ + unsigned short bit; /* Flag bit */ +} mechtable[] = { + { "LOGIN", 5, SASL_MECH_LOGIN }, + { "PLAIN", 5, SASL_MECH_PLAIN }, + { "CRAM-MD5", 8, SASL_MECH_CRAM_MD5 }, + { "DIGEST-MD5", 10, SASL_MECH_DIGEST_MD5 }, + { "GSSAPI", 6, SASL_MECH_GSSAPI }, + { "EXTERNAL", 8, SASL_MECH_EXTERNAL }, + { "NTLM", 4, SASL_MECH_NTLM }, + { "XOAUTH2", 7, SASL_MECH_XOAUTH2 }, + { "OAUTHBEARER", 11, SASL_MECH_OAUTHBEARER }, + { "SCRAM-SHA-1", 11, SASL_MECH_SCRAM_SHA_1 }, + { "SCRAM-SHA-256",13, SASL_MECH_SCRAM_SHA_256 }, + { ZERO_NULL, 0, 0 } +}; + +/* + * Curl_sasl_decode_mech() + * + * Convert a SASL mechanism name into a token. + * + * Parameters: + * + * ptr [in] - The mechanism string. + * maxlen [in] - Maximum mechanism string length. + * len [out] - If not NULL, effective name length. + * + * Returns the SASL mechanism token or 0 if no match. + */ +unsigned short Curl_sasl_decode_mech(const char *ptr, size_t maxlen, + size_t *len) +{ + unsigned int i; + char c; + + for(i = 0; mechtable[i].name; i++) { + if(maxlen >= mechtable[i].len && + curl_strnequal(ptr, mechtable[i].name, mechtable[i].len)) { + if(len) + *len = mechtable[i].len; + + if(maxlen == mechtable[i].len) + return mechtable[i].bit; + + c = ptr[mechtable[i].len]; + if(!ISUPPER(c) && !ISDIGIT(c) && c != '-' && c != '_') + return mechtable[i].bit; + } + } + + return 0; +} + +/* + * Curl_sasl_parse_url_auth_option() + * + * Parse the URL login options. + */ +CURLcode Curl_sasl_parse_url_auth_option(struct SASL *sasl, + const char *value, size_t len) +{ + CURLcode result = CURLE_OK; + size_t mechlen; + + if(!len) + return CURLE_URL_MALFORMAT; + + if(sasl->resetprefs) { + sasl->resetprefs = FALSE; + sasl->prefmech = SASL_AUTH_NONE; + } + + if(!strncmp(value, "*", len)) + sasl->prefmech = SASL_AUTH_DEFAULT; + else { + unsigned short mechbit = Curl_sasl_decode_mech(value, len, &mechlen); + if(mechbit && mechlen == len) + sasl->prefmech |= mechbit; + else + result = CURLE_URL_MALFORMAT; + } + + return result; +} + +/* + * Curl_sasl_init() + * + * Initializes the SASL structure. + */ +void Curl_sasl_init(struct SASL *sasl, struct Curl_easy *data, + const struct SASLproto *params) +{ + unsigned long auth = data->set.httpauth; + + sasl->params = params; /* Set protocol dependent parameters */ + sasl->state = SASL_STOP; /* Not yet running */ + sasl->curmech = NULL; /* No mechanism yet. */ + sasl->authmechs = SASL_AUTH_NONE; /* No known authentication mechanism yet */ + sasl->prefmech = params->defmechs; /* Default preferred mechanisms */ + sasl->authused = SASL_AUTH_NONE; /* The authentication mechanism used */ + sasl->resetprefs = TRUE; /* Reset prefmech upon AUTH parsing. */ + sasl->mutual_auth = FALSE; /* No mutual authentication (GSSAPI only) */ + sasl->force_ir = FALSE; /* Respect external option */ + + if(auth != CURLAUTH_BASIC) { + unsigned short mechs = SASL_AUTH_NONE; + + /* If some usable http authentication options have been set, determine + new defaults from them. */ + if(auth & CURLAUTH_BASIC) + mechs |= SASL_MECH_PLAIN | SASL_MECH_LOGIN; + if(auth & CURLAUTH_DIGEST) + mechs |= SASL_MECH_DIGEST_MD5; + if(auth & CURLAUTH_NTLM) + mechs |= SASL_MECH_NTLM; + if(auth & CURLAUTH_BEARER) + mechs |= SASL_MECH_OAUTHBEARER | SASL_MECH_XOAUTH2; + if(auth & CURLAUTH_GSSAPI) + mechs |= SASL_MECH_GSSAPI; + + if(mechs != SASL_AUTH_NONE) + sasl->prefmech = mechs; + } +} + +/* + * sasl_state() + * + * This is the ONLY way to change SASL state! + */ +static void sasl_state(struct SASL *sasl, struct Curl_easy *data, + saslstate newstate) +{ +#if defined(DEBUGBUILD) && defined(CURLVERBOSE) + /* for debug purposes */ + static const char * const names[] = { + "STOP", + "PLAIN", + "LOGIN", + "LOGIN_PASSWD", + "EXTERNAL", + "CRAMMD5", + "DIGESTMD5", + "DIGESTMD5_RESP", + "NTLM", + "NTLM_TYPE2MSG", + "GSSAPI", + "GSSAPI_TOKEN", + "GSSAPI_NO_DATA", + "OAUTH2", + "OAUTH2_RESP", + "GSASL", + "CANCEL", + "FINAL", + /* LAST */ + }; + + if(sasl->state != newstate) + infof(data, "SASL %p state change from %s to %s", + (void *)sasl, names[sasl->state], names[newstate]); +#else + (void)data; +#endif + + sasl->state = newstate; +} + +#if defined(USE_NTLM) || defined(USE_GSASL) || defined(USE_KERBEROS5) || \ + !defined(CURL_DISABLE_DIGEST_AUTH) +/* Get the SASL server message and convert it to binary. */ +static CURLcode get_server_message(struct SASL *sasl, struct Curl_easy *data, + struct bufref *out) +{ + CURLcode result = CURLE_OK; + + result = sasl->params->getmessage(data, out); + if(!result && (sasl->params->flags & SASL_FLAG_BASE64)) { + const char *serverdata = Curl_bufref_ptr(out); + + if(!*serverdata || *serverdata == '=') + Curl_bufref_set(out, NULL, 0, NULL); + else { + unsigned char *msg; + size_t msglen; + + result = curlx_base64_decode(serverdata, &msg, &msglen); + if(!result) + Curl_bufref_set(out, msg, msglen, curl_free); + } + } + return result; +} +#endif + +/* Encode the outgoing SASL message. */ +static CURLcode build_message(struct SASL *sasl, struct bufref *msg) +{ + CURLcode result = CURLE_OK; + + if(sasl->params->flags & SASL_FLAG_BASE64) { + if(!Curl_bufref_ptr(msg)) /* Empty message. */ + Curl_bufref_set(msg, "", 0, NULL); + else if(!Curl_bufref_len(msg)) /* Explicit empty response. */ + Curl_bufref_set(msg, "=", 1, NULL); + else { + char *base64; + size_t base64len; + + result = curlx_base64_encode(Curl_bufref_uptr(msg), + Curl_bufref_len(msg), &base64, &base64len); + if(!result) + Curl_bufref_set(msg, base64, base64len, curl_free); + } + } + + return result; +} + +/* + * Curl_sasl_can_authenticate() + * + * Check if we have enough auth data and capabilities to authenticate. + */ +bool Curl_sasl_can_authenticate(struct SASL *sasl, struct Curl_easy *data) +{ + /* Have credentials been provided? */ + if(data->conn->creds) + return TRUE; + + /* EXTERNAL can authenticate without a username and/or password */ + if(sasl->authmechs & sasl->prefmech & SASL_MECH_EXTERNAL) + return TRUE; + + return FALSE; +} + +struct sasl_ctx { + struct SASL *sasl; + struct connectdata *conn; + unsigned short enabledmechs; + const char *mech; + saslstate state1; + saslstate state2; + struct bufref resp; + CURLcode result; +}; + +static bool sasl_choose_external(struct Curl_easy *data, struct sasl_ctx *sctx) +{ + if((sctx->enabledmechs & SASL_MECH_EXTERNAL) && + !Curl_creds_has_passwd(sctx->conn->creds)) { + sctx->mech = SASL_MECH_STRING_EXTERNAL; + sctx->state1 = SASL_EXTERNAL; + sctx->sasl->authused = SASL_MECH_EXTERNAL; + + if(sctx->sasl->force_ir || data->set.sasl_ir) + Curl_auth_create_external_message( + Curl_creds_user(sctx->conn->creds), &sctx->resp); + return TRUE; + } + return FALSE; +} + +#ifdef USE_KERBEROS5 +static bool sasl_choose_krb5(struct Curl_easy *data, struct sasl_ctx *sctx) +{ + if((sctx->enabledmechs & SASL_MECH_GSSAPI) && + Curl_auth_is_gssapi_supported() && + Curl_auth_user_contains_domain(sctx->conn->creds)) { + const char *service = Curl_creds_has_sasl_service(sctx->conn->creds) ? + Curl_creds_sasl_service(sctx->conn->creds) : sctx->sasl->params->service; + + sctx->sasl->mutual_auth = FALSE; + sctx->mech = SASL_MECH_STRING_GSSAPI; + sctx->state1 = SASL_GSSAPI; + sctx->state2 = SASL_GSSAPI_TOKEN; + sctx->sasl->authused = SASL_MECH_GSSAPI; + + if(sctx->sasl->force_ir || data->set.sasl_ir) { + struct kerberos5data *krb5 = Curl_auth_krb5_get(sctx->conn); + sctx->result = !krb5 ? CURLE_OUT_OF_MEMORY : + Curl_auth_create_gssapi_user_message(data, sctx->conn->creds, + service, + sctx->conn->origin->hostname, + (bool)sctx->sasl->mutual_auth, + NULL, krb5, &sctx->resp); + } + return TRUE; + } + return FALSE; +} +#endif /* USE_KERBEROS5 */ + +#ifdef USE_GSASL +static bool sasl_choose_gsasl(struct Curl_easy *data, struct sasl_ctx *sctx) +{ + struct gsasldata *gsasl; + struct bufref nullmsg; + + if((sctx->enabledmechs & + (SASL_MECH_SCRAM_SHA_256 | SASL_MECH_SCRAM_SHA_1))) { + gsasl = Curl_auth_gsasl_get(sctx->conn); + if(!gsasl) { + sctx->result = CURLE_OUT_OF_MEMORY; + return TRUE; /* attempted, but failed */ + } + + if((sctx->enabledmechs & SASL_MECH_SCRAM_SHA_256) && + Curl_auth_gsasl_is_supported(data, SASL_MECH_STRING_SCRAM_SHA_256, + gsasl)) { + sctx->mech = SASL_MECH_STRING_SCRAM_SHA_256; + sctx->sasl->authused = SASL_MECH_SCRAM_SHA_256; + } + else if((sctx->enabledmechs & SASL_MECH_SCRAM_SHA_1) && + Curl_auth_gsasl_is_supported(data, SASL_MECH_STRING_SCRAM_SHA_1, + gsasl)) { + sctx->mech = SASL_MECH_STRING_SCRAM_SHA_1; + sctx->sasl->authused = SASL_MECH_SCRAM_SHA_1; + } + else + return FALSE; + + Curl_bufref_init(&nullmsg); + sctx->state1 = SASL_GSASL; + sctx->state2 = SASL_GSASL; + sctx->result = Curl_auth_gsasl_start(data, sctx->conn->creds, gsasl); + if(!sctx->result && (sctx->sasl->force_ir || data->set.sasl_ir)) + sctx->result = Curl_auth_gsasl_token(data, &nullmsg, gsasl, &sctx->resp); + return TRUE; + } + return FALSE; +} + +#endif /* USE_GSASL */ + +#ifndef CURL_DISABLE_DIGEST_AUTH +static bool sasl_choose_digest(struct Curl_easy *data, struct sasl_ctx *sctx) +{ + (void)data; + if((sctx->enabledmechs & SASL_MECH_DIGEST_MD5) && + Curl_auth_is_digest_supported()) { + sctx->mech = SASL_MECH_STRING_DIGEST_MD5; + sctx->state1 = SASL_DIGESTMD5; + sctx->sasl->authused = SASL_MECH_DIGEST_MD5; + return TRUE; + } + else if(sctx->enabledmechs & SASL_MECH_CRAM_MD5) { + sctx->mech = SASL_MECH_STRING_CRAM_MD5; + sctx->state1 = SASL_CRAMMD5; + sctx->sasl->authused = SASL_MECH_CRAM_MD5; + return TRUE; + } + return FALSE; +} +#endif /* !CURL_DISABLE_DIGEST_AUTH */ + +#ifdef USE_NTLM +static bool sasl_choose_ntlm(struct Curl_easy *data, struct sasl_ctx *sctx) +{ + if((sctx->enabledmechs & SASL_MECH_NTLM) && + Curl_auth_is_ntlm_supported()) { + const char *service = Curl_creds_has_sasl_service(sctx->conn->creds) ? + Curl_creds_sasl_service(sctx->conn->creds) : sctx->sasl->params->service; + const char *hostname; + + Curl_conn_get_current_host(data, FIRSTSOCKET, &hostname, NULL); + + sctx->mech = SASL_MECH_STRING_NTLM; + sctx->state1 = SASL_NTLM; + sctx->state2 = SASL_NTLM_TYPE2MSG; + sctx->sasl->authused = SASL_MECH_NTLM; + + if(sctx->sasl->force_ir || data->set.sasl_ir) { + struct ntlmdata *ntlm = Curl_auth_ntlm_get(sctx->conn, FALSE); + sctx->result = !ntlm ? CURLE_OUT_OF_MEMORY : + Curl_auth_create_ntlm_type1_message(data, sctx->conn->creds, + service, hostname, + ntlm, &sctx->resp); + } + return TRUE; + } + return FALSE; +} +#endif /* USE_NTLM */ + +static bool sasl_choose_oauth(struct Curl_easy *data, struct sasl_ctx *sctx) +{ + if(Curl_creds_has_oauth_bearer(data->state.creds) && + (sctx->enabledmechs & SASL_MECH_OAUTHBEARER)) { + const char *hostname; + int port; + Curl_conn_get_current_host(data, FIRSTSOCKET, &hostname, &port); + + sctx->mech = SASL_MECH_STRING_OAUTHBEARER; + sctx->state1 = SASL_OAUTH2; + sctx->state2 = SASL_OAUTH2_RESP; + sctx->sasl->authused = SASL_MECH_OAUTHBEARER; + + if(sctx->sasl->force_ir || data->set.sasl_ir) + sctx->result = + Curl_auth_create_oauth_bearer_message(sctx->conn->creds, + hostname, port, &sctx->resp); + return TRUE; + } + return FALSE; +} + +static bool sasl_choose_oauth2(struct Curl_easy *data, struct sasl_ctx *sctx) +{ + if(Curl_creds_has_oauth_bearer(sctx->conn->creds) && + (sctx->enabledmechs & SASL_MECH_XOAUTH2)) { + sctx->mech = SASL_MECH_STRING_XOAUTH2; + sctx->state1 = SASL_OAUTH2; + sctx->sasl->authused = SASL_MECH_XOAUTH2; + + if(sctx->sasl->force_ir || data->set.sasl_ir) + sctx->result = Curl_auth_create_xoauth_bearer_message( + sctx->conn->creds, &sctx->resp); + return TRUE; + } + return FALSE; +} + +static bool sasl_choose_plain(struct Curl_easy *data, struct sasl_ctx *sctx) +{ + if(sctx->enabledmechs & SASL_MECH_PLAIN) { + sctx->mech = SASL_MECH_STRING_PLAIN; + sctx->state1 = SASL_PLAIN; + sctx->sasl->authused = SASL_MECH_PLAIN; + + if(sctx->sasl->force_ir || data->set.sasl_ir) + sctx->result = + Curl_auth_create_plain_message(sctx->conn->creds, &sctx->resp); + return TRUE; + } + return FALSE; +} + +static bool sasl_choose_login(struct Curl_easy *data, struct sasl_ctx *sctx) +{ + if(sctx->enabledmechs & SASL_MECH_LOGIN) { + sctx->mech = SASL_MECH_STRING_LOGIN; + sctx->state1 = SASL_LOGIN; + sctx->state2 = SASL_LOGIN_PASSWD; + sctx->sasl->authused = SASL_MECH_LOGIN; + + if(sctx->sasl->force_ir || data->set.sasl_ir) + Curl_auth_create_login_message( + Curl_creds_user(sctx->conn->creds), &sctx->resp); + return TRUE; + } + return FALSE; +} + +/* + * Curl_sasl_start() + * + * Calculate the required login details for SASL authentication. + */ +CURLcode Curl_sasl_start(struct SASL *sasl, struct Curl_easy *data, + bool force_ir, saslprogress *progress) +{ + struct sasl_ctx sctx; + + sasl->force_ir = force_ir; /* Latch for future use */ + sasl->authused = 0; /* No mechanism used yet */ + *progress = SASL_IDLE; + + memset(&sctx, 0, sizeof(sctx)); + sctx.sasl = sasl; + sctx.conn = data->conn; + Curl_bufref_init(&sctx.resp); + sctx.enabledmechs = sasl->authmechs & sasl->prefmech; + sctx.state1 = SASL_STOP; + sctx.state2 = SASL_FINAL; + + /* Calculate the supported authentication mechanism, by decreasing order of + security, as well as the initial response where appropriate */ + if(sasl_choose_external(data, &sctx) || +#ifdef USE_KERBEROS5 + sasl_choose_krb5(data, &sctx) || +#endif +#ifdef USE_GSASL + sasl_choose_gsasl(data, &sctx) || +#endif +#ifndef CURL_DISABLE_DIGEST_AUTH + sasl_choose_digest(data, &sctx) || +#endif +#ifdef USE_NTLM + sasl_choose_ntlm(data, &sctx) || +#endif + sasl_choose_oauth(data, &sctx) || + sasl_choose_oauth2(data, &sctx) || + sasl_choose_plain(data, &sctx) || + sasl_choose_login(data, &sctx)) { + /* selected, either we have a mechanism or a failure */ + DEBUGASSERT(sctx.mech || sctx.result); + } + + if(!sctx.result && sctx.mech) { + sasl->curmech = sctx.mech; + if(Curl_bufref_ptr(&sctx.resp)) + sctx.result = build_message(sasl, &sctx.resp); + + if(sasl->params->maxirlen && + strlen(sctx.mech) + Curl_bufref_len(&sctx.resp) > + sasl->params->maxirlen) + Curl_bufref_free(&sctx.resp); + + if(!sctx.result) + sctx.result = sasl->params->sendauth(data, sctx.mech, &sctx.resp); + + if(!sctx.result) { + *progress = SASL_INPROGRESS; + sasl_state(sasl, data, Curl_bufref_ptr(&sctx.resp) ? + sctx.state2 : sctx.state1); + } + } + + Curl_bufref_free(&sctx.resp); + return sctx.result; +} + +/* + * Curl_sasl_continue() + * + * Continue the authentication. + */ +CURLcode Curl_sasl_continue(struct SASL *sasl, struct Curl_easy *data, + int code, saslprogress *progress) +{ + CURLcode result = CURLE_OK; + struct connectdata *conn = data->conn; + saslstate newstate = SASL_FINAL; + struct bufref resp; + const char *hostname; + int port; + struct bufref serverdata; + + Curl_conn_get_current_host(data, FIRSTSOCKET, &hostname, &port); + Curl_bufref_init(&serverdata); + Curl_bufref_init(&resp); + *progress = SASL_INPROGRESS; + + if(sasl->state == SASL_FINAL) { + if(code != sasl->params->finalcode) + result = CURLE_LOGIN_DENIED; + *progress = SASL_DONE; + sasl_state(sasl, data, SASL_STOP); + return result; + } + + if(sasl->state != SASL_CANCEL && sasl->state != SASL_OAUTH2_RESP && + code != sasl->params->contcode) { + *progress = SASL_DONE; + sasl_state(sasl, data, SASL_STOP); + return CURLE_LOGIN_DENIED; + } + + switch(sasl->state) { + case SASL_STOP: + *progress = SASL_DONE; + return result; + case SASL_PLAIN: + result = Curl_auth_create_plain_message(conn->creds, &resp); + break; + case SASL_LOGIN: + Curl_auth_create_login_message(Curl_creds_user(conn->creds), &resp); + newstate = SASL_LOGIN_PASSWD; + break; + case SASL_LOGIN_PASSWD: + Curl_auth_create_login_message(Curl_creds_passwd(conn->creds), &resp); + break; + case SASL_EXTERNAL: + Curl_auth_create_external_message(Curl_creds_user(conn->creds), &resp); + break; +#ifdef USE_GSASL + case SASL_GSASL: + result = get_server_message(sasl, data, &serverdata); + if(!result) { + struct gsasldata *gsasl = Curl_auth_gsasl_get(conn); + result = !gsasl ? CURLE_OUT_OF_MEMORY : + Curl_auth_gsasl_token(data, &serverdata, gsasl, &resp); + } + if(!result && Curl_bufref_len(&resp) > 0) + newstate = SASL_GSASL; + break; +#endif +#ifndef CURL_DISABLE_DIGEST_AUTH + case SASL_CRAMMD5: + result = get_server_message(sasl, data, &serverdata); + if(!result) + result = Curl_auth_create_cram_md5_message(&serverdata, conn->creds, + &resp); + break; + case SASL_DIGESTMD5: + result = get_server_message(sasl, data, &serverdata); + if(!result) + result = Curl_auth_create_digest_md5_message(data, &serverdata, + conn->creds, + sasl->params->service, + &resp); + if(!result && (sasl->params->flags & SASL_FLAG_BASE64)) + newstate = SASL_DIGESTMD5_RESP; + break; + case SASL_DIGESTMD5_RESP: + /* Keep response NULL to output an empty line. */ + break; +#endif + +#ifdef USE_NTLM + case SASL_NTLM: { + /* Create the type-1 message */ + struct ntlmdata *ntlm = Curl_auth_ntlm_get(conn, FALSE); + result = !ntlm ? CURLE_OUT_OF_MEMORY : + Curl_auth_create_ntlm_type1_message(data, conn->creds, + sasl->params->service, hostname, + ntlm, &resp); + newstate = SASL_NTLM_TYPE2MSG; + break; + } + case SASL_NTLM_TYPE2MSG: { + /* Decode the type-2 message */ + struct ntlmdata *ntlm = Curl_auth_ntlm_get(conn, FALSE); + result = !ntlm ? CURLE_OUT_OF_MEMORY : + get_server_message(sasl, data, &serverdata); + if(!result) + result = Curl_auth_decode_ntlm_type2_message(data, &serverdata, ntlm); + if(!result) + result = Curl_auth_create_ntlm_type3_message(data, conn->creds, + ntlm, &resp); + break; + } +#endif + +#ifdef USE_KERBEROS5 + case SASL_GSSAPI: { + struct kerberos5data *krb5 = Curl_auth_krb5_get(conn); + result = !krb5 ? CURLE_OUT_OF_MEMORY : + Curl_auth_create_gssapi_user_message(data, conn->creds, + sasl->params->service, + conn->origin->hostname, + (bool)sasl->mutual_auth, NULL, + krb5, &resp); + newstate = SASL_GSSAPI_TOKEN; + break; + } + case SASL_GSSAPI_TOKEN: + result = get_server_message(sasl, data, &serverdata); + if(!result) { + struct kerberos5data *krb5 = Curl_auth_krb5_get(conn); + if(!krb5) + result = CURLE_OUT_OF_MEMORY; + else if(sasl->mutual_auth) { + /* Decode the user token challenge and create the optional response + message */ + result = Curl_auth_create_gssapi_user_message(data, NULL, + NULL, NULL, + (bool)sasl->mutual_auth, + &serverdata, + krb5, &resp); + newstate = SASL_GSSAPI_NO_DATA; + } + else + /* Decode the security challenge and create the response message */ + result = Curl_auth_create_gssapi_security_message( + data, Curl_creds_sasl_authzid(conn->creds), &serverdata, + krb5, &resp); + } + break; + case SASL_GSSAPI_NO_DATA: + /* Decode the security challenge and create the response message */ + result = get_server_message(sasl, data, &serverdata); + if(!result) { + struct kerberos5data *krb5 = Curl_auth_krb5_get(conn); + if(!krb5) + result = CURLE_OUT_OF_MEMORY; + else + result = Curl_auth_create_gssapi_security_message( + data, Curl_creds_sasl_authzid(conn->creds), &serverdata, + krb5, &resp); + } + break; +#endif + + case SASL_OAUTH2: + /* Create the authorization message */ + if(sasl->authused == SASL_MECH_OAUTHBEARER) { + result = Curl_auth_create_oauth_bearer_message(conn->creds, + hostname, + port, + &resp); + + /* Failures maybe sent by the server as continuations for OAUTHBEARER */ + newstate = SASL_OAUTH2_RESP; + } + else + result = Curl_auth_create_xoauth_bearer_message(conn->creds, + &resp); + break; + + case SASL_OAUTH2_RESP: + /* The continuation is optional so check the response code */ + if(code == sasl->params->finalcode) { + /* Final response was received so we are done */ + *progress = SASL_DONE; + sasl_state(sasl, data, SASL_STOP); + return result; + } + else if(code == sasl->params->contcode) { + /* Acknowledge the continuation by sending a 0x01 response. */ + Curl_bufref_set(&resp, "\x01", 1, NULL); + break; + } + else { + *progress = SASL_DONE; + sasl_state(sasl, data, SASL_STOP); + return CURLE_LOGIN_DENIED; + } + + case SASL_CANCEL: + /* Remove the offending mechanism from the supported list */ + sasl->authmechs &= (unsigned short)~sasl->authused; + sasl->authused = SASL_AUTH_NONE; + sasl->curmech = NULL; + + /* Start an alternative SASL authentication */ + return Curl_sasl_start(sasl, data, (bool)sasl->force_ir, progress); + default: + failf(data, "Unsupported SASL authentication mechanism"); + result = CURLE_UNSUPPORTED_PROTOCOL; /* Should not happen */ + break; + } + + Curl_bufref_free(&serverdata); + + switch(result) { + case CURLE_BAD_CONTENT_ENCODING: + /* Cancel dialog */ + result = sasl->params->cancelauth(data, sasl->curmech); + newstate = SASL_CANCEL; + break; + case CURLE_OK: + result = build_message(sasl, &resp); + if(!result) + result = sasl->params->contauth(data, sasl->curmech, &resp); + break; + default: + newstate = SASL_STOP; /* Stop on error */ + *progress = SASL_DONE; + break; + } + + Curl_bufref_free(&resp); + + sasl_state(sasl, data, newstate); + + return result; +} + +#ifdef CURLVERBOSE +static void sasl_unchosen(struct Curl_easy *data, unsigned short mech, + unsigned short enabledmechs, + bool built_in, bool platform, + const char *param_missing) +{ + const char *mname = NULL; + size_t i; + + if(!(enabledmechs & mech)) + return; + + for(i = 0; mechtable[i].name; ++i) { + if(mechtable[i].bit == mech) { + mname = mechtable[i].name; + break; + } + } + if(!mname) /* should not happen */ + return; + if(!built_in) + infof(data, "SASL: %s not builtin", mname); + else if(!platform) + infof(data, "SASL: %s not supported by the platform/libraries", mname); + else { + if(param_missing) + infof(data, "SASL: %s is missing %s", mname, param_missing); + if(!Curl_creds_has_user(data->conn->creds)) + infof(data, "SASL: %s is missing username", mname); + } +} +#endif /* CURLVERBOSE */ + +CURLcode Curl_sasl_is_blocked(struct SASL *sasl, struct Curl_easy *data) +{ +#ifdef CURLVERBOSE +#ifdef USE_KERBEROS5 +#define CURL_SASL_KERBEROS5 TRUE +#else +#define CURL_SASL_KERBEROS5 FALSE +#endif +#ifdef USE_GSASL +#define CURL_SASL_GASL TRUE +#else +#define CURL_SASL_GASL FALSE +#endif +#ifdef CURL_DISABLE_DIGEST_AUTH +#define CURL_SASL_DIGEST TRUE +#else +#define CURL_SASL_DIGEST FALSE +#endif +#ifndef USE_NTLM +#define CURL_SASL_NTLM TRUE +#else +#define CURL_SASL_NTLM FALSE +#endif + /* Failing SASL authentication is a pain. Give a helping hand if + * we were unable to select an AUTH mechanism. + * `sasl->authmechs` are mechanisms offered by the peer + * `sasl->prefmech` are mechanisms preferred by us */ + unsigned short enabledmechs = sasl->authmechs & sasl->prefmech; + + if(!sasl->authmechs) + infof(data, "SASL: no auth mechanism was offered or recognized"); + else if(!enabledmechs) + infof(data, "SASL: no overlap between offered and configured " + "auth mechanisms"); + else { + infof(data, "SASL: no auth mechanism offered could be selected"); + if((enabledmechs & SASL_MECH_EXTERNAL) && + Curl_creds_has_passwd(data->conn->creds)) + infof(data, "SASL: auth EXTERNAL not chosen with password"); + sasl_unchosen(data, SASL_MECH_GSSAPI, enabledmechs, + CURL_SASL_KERBEROS5, Curl_auth_is_gssapi_supported(), NULL); + sasl_unchosen(data, SASL_MECH_SCRAM_SHA_256, enabledmechs, + CURL_SASL_GASL, FALSE, NULL); + sasl_unchosen(data, SASL_MECH_SCRAM_SHA_1, enabledmechs, + CURL_SASL_GASL, FALSE, NULL); + sasl_unchosen(data, SASL_MECH_DIGEST_MD5, enabledmechs, + CURL_SASL_DIGEST, Curl_auth_is_digest_supported(), NULL); + sasl_unchosen(data, SASL_MECH_CRAM_MD5, enabledmechs, + CURL_SASL_DIGEST, TRUE, NULL); + sasl_unchosen(data, SASL_MECH_NTLM, enabledmechs, + CURL_SASL_NTLM, Curl_auth_is_ntlm_supported(), NULL); + sasl_unchosen(data, SASL_MECH_OAUTHBEARER, enabledmechs, TRUE, TRUE, + Curl_creds_has_oauth_bearer(data->conn->creds) ? + NULL : "CURLOPT_XOAUTH2_BEARER"); + sasl_unchosen(data, SASL_MECH_XOAUTH2, enabledmechs, TRUE, TRUE, + Curl_creds_has_oauth_bearer(data->conn->creds) ? + NULL : "CURLOPT_XOAUTH2_BEARER"); + } +#endif /* CURLVERBOSE */ + (void)sasl; + (void)data; + return CURLE_LOGIN_DENIED; +} + +#endif /* protocols are enabled that use SASL */ diff --git a/3rdparty/curl-8.21.0/lib/curl_sasl.h b/3rdparty/curl-8.21.0/lib/curl_sasl.h new file mode 100644 index 0000000000..8a97f52adc --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_sasl.h @@ -0,0 +1,160 @@ +#ifndef HEADER_CURL_SASL_H +#define HEADER_CURL_SASL_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "bufref.h" + +struct Curl_easy; +struct connectdata; + +/* Authentication mechanism flags */ +#define SASL_MECH_LOGIN (1 << 0) +#define SASL_MECH_PLAIN (1 << 1) +#define SASL_MECH_CRAM_MD5 (1 << 2) +#define SASL_MECH_DIGEST_MD5 (1 << 3) +#define SASL_MECH_GSSAPI (1 << 4) +#define SASL_MECH_EXTERNAL (1 << 5) +#define SASL_MECH_NTLM (1 << 6) +#define SASL_MECH_XOAUTH2 (1 << 7) +#define SASL_MECH_OAUTHBEARER (1 << 8) +#define SASL_MECH_SCRAM_SHA_1 (1 << 9) +#define SASL_MECH_SCRAM_SHA_256 (1 << 10) + +/* Authentication mechanism values */ +#define SASL_AUTH_NONE 0 +#define SASL_AUTH_ANY 0xffff +#define SASL_AUTH_DEFAULT (SASL_AUTH_ANY & ~SASL_MECH_EXTERNAL) + +/* Authentication mechanism strings */ +#define SASL_MECH_STRING_LOGIN "LOGIN" +#define SASL_MECH_STRING_PLAIN "PLAIN" +#define SASL_MECH_STRING_CRAM_MD5 "CRAM-MD5" +#define SASL_MECH_STRING_DIGEST_MD5 "DIGEST-MD5" +#define SASL_MECH_STRING_GSSAPI "GSSAPI" +#define SASL_MECH_STRING_EXTERNAL "EXTERNAL" +#define SASL_MECH_STRING_NTLM "NTLM" +#define SASL_MECH_STRING_XOAUTH2 "XOAUTH2" +#define SASL_MECH_STRING_OAUTHBEARER "OAUTHBEARER" +#define SASL_MECH_STRING_SCRAM_SHA_1 "SCRAM-SHA-1" +#define SASL_MECH_STRING_SCRAM_SHA_256 "SCRAM-SHA-256" + +/* SASL flags */ +#define SASL_FLAG_BASE64 0x0001 /* Messages are base64-encoded */ + +/* SASL machine states */ +typedef enum { + SASL_STOP, + SASL_PLAIN, + SASL_LOGIN, + SASL_LOGIN_PASSWD, + SASL_EXTERNAL, + SASL_CRAMMD5, + SASL_DIGESTMD5, + SASL_DIGESTMD5_RESP, + SASL_NTLM, + SASL_NTLM_TYPE2MSG, + SASL_GSSAPI, + SASL_GSSAPI_TOKEN, + SASL_GSSAPI_NO_DATA, + SASL_OAUTH2, + SASL_OAUTH2_RESP, + SASL_GSASL, + SASL_CANCEL, + SASL_FINAL +} saslstate; + +/* Progress indicator */ +typedef enum { + SASL_IDLE, + SASL_INPROGRESS, + SASL_DONE +} saslprogress; + +/* Protocol dependent SASL parameters */ +struct SASLproto { + const char *service; /* The service name */ + CURLcode (*sendauth)(struct Curl_easy *data, const char *mech, + const struct bufref *ir); + /* Send authentication command */ + CURLcode (*contauth)(struct Curl_easy *data, const char *mech, + const struct bufref *contauth); + /* Send authentication continuation */ + CURLcode (*cancelauth)(struct Curl_easy *data, const char *mech); + /* Cancel authentication. */ + CURLcode (*getmessage)(struct Curl_easy *data, struct bufref *out); + /* Get SASL response message */ + size_t maxirlen; /* Maximum initial response + mechanism length, + or zero if no max. This is normally the max + command length - other characters count. + This has to be zero for non-base64 protocols. */ + int contcode; /* Code to receive when continuation is expected */ + int finalcode; /* Code to receive upon authentication success */ + unsigned short defmechs; /* Mechanisms enabled by default */ + unsigned short flags; /* Configuration flags. */ +}; + +/* Per-connection parameters */ +struct SASL { + const struct SASLproto *params; /* Protocol dependent parameters */ + saslstate state; /* Current machine state */ + const char *curmech; /* Current mechanism id. */ + unsigned short authmechs; /* Accepted authentication mechanisms */ + unsigned short prefmech; /* Preferred authentication mechanism */ + unsigned short authused; /* Auth mechanism used for the connection */ + BIT(resetprefs); /* For URL auth option parsing. */ + BIT(mutual_auth); /* Mutual authentication enabled (GSSAPI only) */ + BIT(force_ir); /* Protocol always supports initial response */ +}; + +/* This is used to test whether the line starts with the given mechanism */ +#define sasl_mech_equal(line, wordlen, mech) \ + ((wordlen) == (sizeof(mech) - 1) / sizeof(char) && \ + !memcmp(line, mech, wordlen)) + +/* Convert a mechanism name to a token */ +unsigned short Curl_sasl_decode_mech(const char *ptr, + size_t maxlen, size_t *len); + +/* Parse the URL login options */ +CURLcode Curl_sasl_parse_url_auth_option(struct SASL *sasl, + const char *value, size_t len); + +/* Initializes an SASL structure */ +void Curl_sasl_init(struct SASL *sasl, struct Curl_easy *data, + const struct SASLproto *params); + +/* Check if we have enough auth data and capabilities to authenticate */ +bool Curl_sasl_can_authenticate(struct SASL *sasl, struct Curl_easy *data); + +/* Calculate the required login details for SASL authentication */ +CURLcode Curl_sasl_start(struct SASL *sasl, struct Curl_easy *data, + bool force_ir, saslprogress *progress); + +/* Continue an SASL authentication */ +CURLcode Curl_sasl_continue(struct SASL *sasl, struct Curl_easy *data, + int code, saslprogress *progress); + +CURLcode Curl_sasl_is_blocked(struct SASL *sasl, struct Curl_easy *data); + +#endif /* HEADER_CURL_SASL_H */ diff --git a/3rdparty/curl-8.21.0/lib/curl_setup.h b/3rdparty/curl-8.21.0/lib/curl_setup.h new file mode 100644 index 0000000000..861e07649d --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_setup.h @@ -0,0 +1,1673 @@ +#ifndef HEADER_CURL_SETUP_H +#define HEADER_CURL_SETUP_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +#if defined(BUILDING_LIBCURL) && !defined(CURL_NO_OLDIES) +#define CURL_NO_OLDIES +#endif + +/* Set default _WIN32_WINNT */ +#ifdef __MINGW32__ +#include <_mingw.h> +#endif + +/* Workaround for Homebrew gcc 12.4.0, 13.3.0, 14.1.0, 14.2.0 (initial build) + that started advertising the `availability` attribute, which then gets used + by Apple SDK, but, in a way incompatible with gcc, resulting in misc errors + inside SDK headers, e.g.: + error: attributes should be specified before the declarator in a function + definition + error: expected ',' or '}' before + Followed by missing declarations. + Work it around by overriding the built-in feature-check macro used by the + headers to enable the problematic attributes. This makes the feature check + fail. Fixed in 14.2.0_1. Disable the workaround if the fix is detected. */ +#if defined(__APPLE__) && !defined(__clang__) && defined(__GNUC__) && \ + defined(__has_attribute) +# if !defined(__has_feature) /* Keep this PP check separate from others */ +# define availability curl_pp_attribute_disabled +# elif !__has_feature(attribute_availability) +# define availability curl_pp_attribute_disabled +# endif +#endif + +#ifdef __APPLE__ +#include +#include +/* Fixup faulty target macro initialization in macOS SDK since v14.4 (as of + 15.0 beta). The SDK target detection in `TargetConditionals.h` correctly + detects macOS, but fails to set the macro's old name `TARGET_OS_OSX`, then + continues to set it to a default value of 0. Other parts of the SDK still + rely on the old name, and with this inconsistency our builds fail due to + missing declarations. It happens when using mainline llvm older than v18. + Later versions fixed it by predefining these target macros, avoiding the + faulty dynamic detection. gcc is not affected (for now) because it lacks + the necessary dynamic detection features, so the SDK falls back to + a codepath that sets both the old and new macro to 1. */ +#if defined(TARGET_OS_MAC) && TARGET_OS_MAC && \ + defined(TARGET_OS_OSX) && !TARGET_OS_OSX && \ + (!defined(TARGET_OS_IPHONE) || !TARGET_OS_IPHONE) && \ + (!defined(TARGET_OS_SIMULATOR) || !TARGET_OS_SIMULATOR) +#undef TARGET_OS_OSX +#define TARGET_OS_OSX TARGET_OS_MAC +#endif +#endif + +#if defined(__MINGW32__) && \ + (!defined(__MINGW64_VERSION_MAJOR) || (__MINGW64_VERSION_MAJOR < 3)) +#error "Building curl requires mingw-w64 3.0 or later" +#endif + +/* Visual Studio 2010 is the minimum Visual Studio version we support. + Workarounds for older versions of Visual Studio have been removed. */ +#if defined(_MSC_VER) && (_MSC_VER < 1600) +#error "Ancient versions of Visual Studio are no longer supported due to bugs." +#endif + +#ifdef _MSC_VER +/* Disable Visual Studio warnings: 4127 "conditional expression is constant" */ +#pragma warning(disable:4127) +#ifndef _CRT_SECURE_NO_WARNINGS +#define _CRT_SECURE_NO_WARNINGS /* for getenv(), sscanf() */ +#endif +#endif /* _MSC_VER */ + +#ifdef _WIN32 +/* + * Do not include unneeded stuff in Windows headers to avoid compiler + * warnings and macro clashes. + * Make sure to define this macro before including any Windows headers. + */ +# ifndef WIN32_LEAN_AND_MEAN +# define WIN32_LEAN_AND_MEAN +# endif +# ifndef NOGDI +# define NOGDI +# endif + +/* Detect Windows App environment which has a restricted access + * to the Win32 APIs. */ +# if (defined(_WIN32_WINNT) && (_WIN32_WINNT >= 0x0602)) || \ + defined(WINAPI_FAMILY) +# include +# if WINAPI_FAMILY_PARTITION(WINAPI_PARTITION_APP) && \ + !WINAPI_FAMILY_PARTITION(WINAPI_PARTITION_DESKTOP) +# define CURL_WINDOWS_UWP +# endif +# endif + +/* Mandatory to define SECURITY_WIN32 or SECURITY_KERNEL to indicating who is + compiling the code. */ +#undef SECURITY_KERNEL +#undef SECURITY_WIN32 +#define SECURITY_WIN32 /* for */ +#endif + +/* Compatibility */ +#ifdef ENABLE_IPV6 +#define USE_IPV6 1 +#endif + +/* + * Include configuration script results or hand-crafted + * configuration file for platforms which lack config tool. + */ + +#ifdef HAVE_CONFIG_H + +#include "curl_config.h" + +#else /* HAVE_CONFIG_H */ + +#ifdef _WIN32 +# include "config-win32.h" +#endif + +#ifdef macintosh +# include "config-mac.h" +#endif + +#ifdef __riscos__ +# include "config-riscos.h" +#endif + +#ifdef __OS400__ +# include "config-os400.h" +#endif + +#endif /* HAVE_CONFIG_H */ + +#ifdef _WIN32 +# if defined(_WIN32_WINNT) && (_WIN32_WINNT < 0x0600) +# error The minimum build target is Windows Vista (0x0600) +# endif + +# if !defined(CURL_WINDOWS_UWP) && (defined(_MSC_VER) || defined(__MINGW32__)) +# ifndef HAVE_IF_NAMETOINDEX +# define HAVE_IF_NAMETOINDEX +# endif +# endif +#endif + +/* ================================================================ */ +/* Definition of preprocessor macros/symbols which modify compiler */ +/* behavior or generated code characteristics must be done here, */ +/* as appropriate, before any system header file is included. It is */ +/* also possible to have them defined in the config file included */ +/* before this point. As a result of all this we frown inclusion of */ +/* system header files in our config files, avoid this at any cost. */ +/* ================================================================ */ + +#ifdef HAVE_LIBZ +# ifndef ZLIB_CONST +# define ZLIB_CONST /* Use z_const. Supported by v1.2.5.2 and upper. */ +# endif +#endif + +/* + * AIX 4.3 and newer needs _THREAD_SAFE defined to build + * proper reentrant code. Others may also need it. + */ +#ifdef NEED_THREAD_SAFE +# ifndef _THREAD_SAFE +# define _THREAD_SAFE +# endif +#endif + +/* + * Tru64 needs _REENTRANT set for a few function prototypes and + * things to appear in the system header files. Unixware needs it + * to build proper reentrant code. Others may also need it. + */ +#ifdef NEED_REENTRANT +# ifndef _REENTRANT +# define _REENTRANT +# endif +#endif + +/* Solaris needs this to get a POSIX-conformant getpwuid_r */ +#if defined(sun) || defined(__sun) +# ifndef _POSIX_PTHREAD_SEMANTICS +# define _POSIX_PTHREAD_SEMANTICS 1 +# endif +#endif + +/* ================================================================ */ +/* If you need to include a system header file for your platform, */ +/* please, do it beyond the point further indicated in this file. */ +/* ================================================================ */ + +/* Give calloc a chance to be included early, so we do not redefine */ +#ifdef HAVE_THREADS_POSIX +# include +#endif + +/* + * Disable other protocols when http is the only one desired. + */ +#ifdef HTTP_ONLY +# ifndef CURL_DISABLE_DICT +# define CURL_DISABLE_DICT +# endif +# ifndef CURL_DISABLE_FILE +# define CURL_DISABLE_FILE +# endif +# ifndef CURL_DISABLE_FTP +# define CURL_DISABLE_FTP +# endif +# ifndef CURL_DISABLE_GOPHER +# define CURL_DISABLE_GOPHER +# endif +# ifndef CURL_DISABLE_IMAP +# define CURL_DISABLE_IMAP +# endif +# ifndef CURL_DISABLE_LDAP +# define CURL_DISABLE_LDAP +# endif +# ifndef CURL_DISABLE_LDAPS +# define CURL_DISABLE_LDAPS +# endif +# ifndef CURL_DISABLE_MQTT +# define CURL_DISABLE_MQTT +# endif +# ifndef CURL_DISABLE_POP3 +# define CURL_DISABLE_POP3 +# endif +# ifndef CURL_DISABLE_RTSP +# define CURL_DISABLE_RTSP +# endif +# ifndef CURL_DISABLE_SMTP +# define CURL_DISABLE_SMTP +# endif +# ifndef CURL_DISABLE_TELNET +# define CURL_DISABLE_TELNET +# endif +# ifndef CURL_DISABLE_TFTP +# define CURL_DISABLE_TFTP +# endif +# ifndef CURL_DISABLE_WEBSOCKETS +# define CURL_DISABLE_WEBSOCKETS +# endif +#endif + +/* + * When http is disabled rtsp is not supported. + */ +#if defined(CURL_DISABLE_HTTP) && !defined(CURL_DISABLE_RTSP) +# define CURL_DISABLE_RTSP +#endif + +/* + * When HTTP is disabled, disable HTTP-only features + */ +#ifdef CURL_DISABLE_HTTP +# ifndef CURL_DISABLE_ALTSVC +# define CURL_DISABLE_ALTSVC +# endif +# ifndef CURL_DISABLE_COOKIES +# define CURL_DISABLE_COOKIES +# endif +# ifndef CURL_DISABLE_BASIC_AUTH +# define CURL_DISABLE_BASIC_AUTH +# endif +# ifndef CURL_DISABLE_BEARER_AUTH +# define CURL_DISABLE_BEARER_AUTH +# endif +# ifndef CURL_DISABLE_AWS +# define CURL_DISABLE_AWS +# endif +# ifndef CURL_DISABLE_DOH +# define CURL_DISABLE_DOH +# endif +# ifndef CURL_DISABLE_FORM_API +# define CURL_DISABLE_FORM_API +# endif +# ifndef CURL_DISABLE_HEADERS_API +# define CURL_DISABLE_HEADERS_API +# endif +# ifndef CURL_DISABLE_HSTS +# define CURL_DISABLE_HSTS +# endif +# ifndef CURL_DISABLE_HTTP_AUTH +# define CURL_DISABLE_HTTP_AUTH +# endif +# ifndef CURL_DISABLE_WEBSOCKETS +# define CURL_DISABLE_WEBSOCKETS /* no WebSockets without HTTP present */ +# endif +#endif + +/* ================================================================ */ +/* No system header file shall be included in this file before this */ +/* point. */ +/* ================================================================ */ + +/* + * OS/400 setup file includes some system headers. + */ +#ifdef __OS400__ +# include "setup-os400.h" +#endif + +/* + * VMS setup file includes some system headers. + */ +#ifdef __VMS +# include "setup-vms.h" +#endif + +/* + * Windows setup file includes some system headers. + */ +#ifdef _WIN32 +# include "setup-win32.h" +#endif + +#include + +/* Helper macro to expand and concatenate two macros. + * Direct macros concatenation does not work because macros + * are not expanded before direct concatenation. + */ +#define CURL_CONC_MACROS_(A, B) A ## B +#define CURL_CONC_MACROS(A, B) CURL_CONC_MACROS_(A, B) + +/* curl uses its own printf() function internally. It understands the GNU + * format. Use this format, so that it matches the GNU format attribute we + * use with the MinGW compiler, allowing it to verify them at compile-time. + */ +#ifdef __MINGW32__ +# undef CURL_FORMAT_CURL_OFF_T +# undef CURL_FORMAT_CURL_OFF_TU +# define CURL_FORMAT_CURL_OFF_T "lld" +# define CURL_FORMAT_CURL_OFF_TU "llu" +#endif + +/* based on logic in "curl/mprintf.h" */ +#if (defined(__GNUC__) || defined(__clang__) || \ + defined(__IAR_SYSTEMS_ICC__)) && \ + defined(__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L) && \ + !defined(CURL_NO_FMT_CHECKS) +#if defined(__MINGW32__) && !defined(__clang__) +#define CURL_PRINTF(fmt, arg) __attribute__((format(gnu_printf, fmt, arg))) +#else +#define CURL_PRINTF(fmt, arg) __attribute__((format(__printf__, fmt, arg))) +#endif +#else +#define CURL_PRINTF(fmt, arg) +#endif + +/* Override default printf mask check rules in "curl/mprintf.h" */ +#define CURL_TEMP_PRINTF CURL_PRINTF + +/* Workaround for mainline llvm v16 and earlier missing a built-in macro + expected by macOS SDK v14 / Xcode v15 (2023) and newer. + gcc (as of v14) is also missing it. */ +#if defined(__APPLE__) && \ + ((!defined(__apple_build_version__) && \ + defined(__clang__) && __clang_major__ < 17) || \ + (defined(__GNUC__) && __GNUC__ <= 14)) && \ + defined(__ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__) && \ + !defined(__ENVIRONMENT_OS_VERSION_MIN_REQUIRED__) +#define __ENVIRONMENT_OS_VERSION_MIN_REQUIRED__ \ + __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ +#endif + +/* + * Use getaddrinfo to resolve the IPv4 address literal. If the current network + * interface does not support IPv4, but supports IPv6, NAT64, and DNS64, + * performing this task will result in a synthesized IPv6 address. + */ +#if defined(__APPLE__) && !defined(USE_ARES) +# define USE_RESOLVE_ON_IPS 1 +# if TARGET_OS_MAC && !(defined(TARGET_OS_IPHONE) && TARGET_OS_IPHONE) && \ + defined(USE_IPV6) +# define CURL_MACOS_CALL_COPYPROXIES 1 +# endif +#endif + +#ifdef USE_ARES +# ifndef CARES_NO_DEPRECATED +# define CARES_NO_DEPRECATED /* for ares_getsock() */ +# endif +# if defined(CURL_STATICLIB) && !defined(CARES_STATICLIB) && defined(_WIN32) +# define CARES_STATICLIB /* define it before including ares.h */ +# endif +#endif + +#ifdef USE_LWIPSOCK +# include +# include +# include +#endif + +#ifdef macintosh +# include +# include +#endif + +#ifdef __AMIGA__ +# ifdef __amigaos4__ +# define __USE_INLINE__ + /* use our own resolver which uses runtime feature detection */ +# define CURLRES_AMIGA + /* getaddrinfo() currently crashes bsdsocket.library, so disable */ +# undef HAVE_GETADDRINFO +# if !(defined(__NEWLIB__) || \ + (defined(__CLIB2__) && defined(__THREAD_SAFE))) + /* disable threaded resolver with clib2 - requires newlib or clib-ts */ +# undef USE_RESOLV_THREADED +# endif +# endif +# include +# include +# include +# include +# include +# if defined(HAVE_PROTO_BSDSOCKET_H) && \ + (!defined(__amigaos4__) || defined(USE_AMISSL)) + /* use bsdsocket.library directly, instead of libc networking functions */ +# define _SYS_MBUF_H /* m_len define clashes with curl */ +# include +# ifdef __amigaos4__ + int Curl_amiga_select(int nfds, fd_set *readfds, fd_set *writefds, + fd_set *errorfds, struct timeval *timeout); +# define select(a, b, c, d, e) Curl_amiga_select(a, b, c, d, e) +# else +# define select(a, b, c, d, e) WaitSelect(a, b, c, d, e, 0) +# endif + /* must not use libc's fcntl() on bsdsocket.library sockfds! */ +# undef HAVE_FCNTL +# undef HAVE_FCNTL_O_NONBLOCK +# else + /* use libc networking and hence close() and fcntl() */ +# undef HAVE_CLOSESOCKET_CAMEL +# undef HAVE_IOCTLSOCKET_CAMEL +# endif +/* + * In clib2 arpa/inet.h warns that some prototypes may clash + * with bsdsocket.library. This avoids the definition of those. + */ +# define __NO_NET_API +#endif + +/* Whether to use eventfd() */ +#if defined(HAVE_EVENTFD) && defined(HAVE_SYS_EVENTFD_H) +#define USE_EVENTFD +#endif + +#ifdef SO_NOSIGPIPE +#define USE_SO_NOSIGPIPE +#endif + +#include +#include + +#ifdef __TANDEM /* for ns*-tandem-nsk systems */ +# ifndef __LP64 +# include /* FLOSS is only used for 32-bit builds. */ +# endif +#endif + +#ifndef STDC_HEADERS /* no standard C headers! */ +#include +#endif + +#include +#define HAVE_UINTPTR_T /* assume uintptr_t is provided by stdint.h */ + +#ifdef __DJGPP__ +/* By default, DJGPP provides this type as a version of 'unsigned long' which + forces us to use a define use it in printf() format strings without + warnings. long and int are both 32 bits for this platform. */ +#define uint32_t unsigned int +#endif + +/* Disable uintptr_t for targets known to miss it from stdint.h */ +#ifdef __OS400__ +#undef HAVE_UINTPTR_T +#endif + +#include + +#ifdef _WIN32 +# ifdef HAVE_IO_H +# include +# endif +# include +# include + /* Large file (>2Gb) support using Win32 functions. */ +# define curl_lseek _lseeki64 +# define LSEEK_ERROR ((__int64)-1) +#elif defined(__DJGPP__) + /* Requires DJGPP 2.04 */ +# include +# define curl_lseek llseek +# define LSEEK_ERROR ((offset_t)-1) +#elif defined(__AMIGA__) +# define curl_lseek(fd, offset, whence) lseek(fd, (off_t)(offset), whence) +# define LSEEK_ERROR ((off_t)-1) +#else +# define curl_lseek lseek +# define LSEEK_ERROR ((off_t)-1) +#endif + +#ifndef SIZEOF_TIME_T +/* assume default size of time_t to be 32 bits */ +#define SIZEOF_TIME_T 4 +#endif + +#ifndef SIZEOF_CURL_SOCKET_T +/* configure and cmake check and set the define */ +# if defined(USE_WINSOCK) && defined(_WIN64) +# define SIZEOF_CURL_SOCKET_T 8 +# else +/* default guess */ +# define SIZEOF_CURL_SOCKET_T 4 +# endif +#endif + +#if SIZEOF_CURL_SOCKET_T < 8 +#ifdef USE_WINSOCK +# define FMT_SOCKET_T "u" +#else +# define FMT_SOCKET_T "d" +#endif +#elif defined(USE_WINSOCK) +# define FMT_SOCKET_T "zu" +#else +# define FMT_SOCKET_T "qd" +#endif + +/* + * Default sizeof(off_t) in case it has not been defined in config file. + */ + +#ifndef SIZEOF_OFF_T +# if defined(__VMS) && !defined(__VAX) +# ifdef _LARGEFILE +# define SIZEOF_OFF_T 8 +# endif +# elif defined(__OS400__) && defined(__ILEC400__) +# ifdef _LARGE_FILES +# define SIZEOF_OFF_T 8 +# endif +# elif defined(__MVS__) && defined(__IBMC__) +# if defined(_LP64) || defined(_LARGE_FILES) +# define SIZEOF_OFF_T 8 +# endif +# elif defined(__370__) && defined(__IBMC__) +# if defined(_LP64) || defined(_LARGE_FILES) +# define SIZEOF_OFF_T 8 +# endif +# endif +# ifndef SIZEOF_OFF_T +# define SIZEOF_OFF_T 4 +# endif +#endif + +#if SIZEOF_CURL_OFF_T < 8 +#error "too small curl_off_t" +#else + /* assume SIZEOF_CURL_OFF_T == 8 */ +# define CURL_OFF_T_MAX 0x7FFFFFFFFFFFFFFF +#endif +#define CURL_OFF_T_MIN (-CURL_OFF_T_MAX - 1) + +#define FMT_OFF_T CURL_FORMAT_CURL_OFF_T +#define FMT_OFF_TU CURL_FORMAT_CURL_OFF_TU + +#if SIZEOF_TIME_T == 4 +# ifdef HAVE_TIME_T_UNSIGNED +# define TIME_T_MAX UINT_MAX +# define TIME_T_MIN 0 +# else +# define TIME_T_MAX INT_MAX +# define TIME_T_MIN INT_MIN +# endif +#else +# ifdef HAVE_TIME_T_UNSIGNED +# define TIME_T_MAX 0xFFFFFFFFFFFFFFFF +# define TIME_T_MIN 0 +# else +# define TIME_T_MAX 0x7FFFFFFFFFFFFFFF +# define TIME_T_MIN (-TIME_T_MAX - 1) +# endif +#endif + +#ifndef SIZE_MAX +/* some limits.h headers have this defined, some do not */ +#if defined(SIZEOF_SIZE_T) && (SIZEOF_SIZE_T > 4) +#define SIZE_MAX 18446744073709551615U +#else +#define SIZE_MAX 4294967295U +#endif +#endif + +#ifndef SSIZE_MAX +/* some limits.h headers have this defined, some do not */ +#if defined(SIZEOF_SIZE_T) && (SIZEOF_SIZE_T > 4) +#define SSIZE_MAX 9223372036854775807 +#else +#define SSIZE_MAX 2147483647 +#endif +#endif + +#if SIZEOF_LONG > SIZEOF_SIZE_T +#error "unexpected: 'long' is larger than 'size_t'" +#endif + +/* + * Arg 2 type for gethostname in case it has not been defined in config file. + */ +#ifndef GETHOSTNAME_TYPE_ARG2 +# ifdef USE_WINSOCK +# define GETHOSTNAME_TYPE_ARG2 int +# else +# define GETHOSTNAME_TYPE_ARG2 size_t +# endif +#endif + +/* Below we define some functions. They should + 4. set the SIGALRM signal timeout + 5. set dir/file naming defines + */ + +#ifdef _WIN32 + +# define DIR_CHAR "\\" + +#else /* _WIN32 */ + +# ifdef MSDOS /* Watt-32 */ + +# include +# define select(n, r, w, x, t) select_s(n, r, w, x, t) +# define ioctl(x, y, z) ioctlsocket(x, y, (char *)(z)) +# include +# undef word +# undef byte + +# endif /* MSDOS */ + +# ifdef __minix + /* Minix 3 versions up to at least 3.1.3 are missing these prototypes */ + extern struct tm *gmtime_r(const time_t * const timep, struct tm *tmp); +# endif + +# define DIR_CHAR "/" + +#endif /* _WIN32 */ + +/* We want to use mutex when available. */ +#if defined(HAVE_THREADS_POSIX) || defined(_WIN32) +#define USE_MUTEX +#endif + +/* threaded resolver is the only feature requiring threads. */ +#ifdef USE_RESOLV_THREADED +#define USE_THREADS +#endif + +/* ---------------------------------------------------------------- */ +/* resolver specialty compile-time defines */ +/* CURLRES_* defines to use in the host*.c sources */ +/* ---------------------------------------------------------------- */ + +/* + * Mutually exclusive CURLRES_* definitions. + */ +#if defined(USE_IPV6) && defined(HAVE_GETADDRINFO) +# define CURLRES_IPV6 +#elif defined(USE_IPV6) && (defined(_WIN32) || defined(__CYGWIN__)) +/* assume on Windows that IPv6 without getaddrinfo is a broken build */ +# error "Unexpected build: IPv6 is enabled but getaddrinfo was not found." +#else +# define CURLRES_IPV4 +#endif + +#ifdef USE_RESOLV_THREADED +# define CURLRES_ASYNCH +#elif defined(USE_RESOLV_ARES) +# define CURLRES_ASYNCH +/* now undef the stock libc functions to avoid them being used */ +# undef HAVE_GETADDRINFO +# undef HAVE_FREEADDRINFO +#else +# define CURLRES_SYNCH +#endif + +/* ---------------------------------------------------------------- */ + +#if defined(HAVE_LIBIDN2) && defined(HAVE_IDN2_H) && \ + !defined(USE_WIN32_IDN) && !defined(USE_APPLE_IDN) +/* The lib and header are present */ +#define USE_LIBIDN2 +#endif + +#if defined(USE_LIBIDN2) && (defined(USE_WIN32_IDN) || defined(USE_APPLE_IDN)) +#error "libidn2 cannot be enabled with WinIDN or AppleIDN, choose one." +#endif + +#if defined(USE_GNUTLS) || defined(USE_OPENSSL) || defined(USE_MBEDTLS) || \ + defined(USE_WOLFSSL) || defined(USE_SCHANNEL) || defined(USE_RUSTLS) +#define USE_SSL /* SSL support has been enabled */ +#endif + +#if defined(USE_OPENSSL) && defined(USE_WOLFSSL) +#ifndef OPENSSL_COEXIST +#define OPENSSL_COEXIST +#endif +#endif + +#if defined(USE_WOLFSSL) && defined(USE_GNUTLS) +/* Avoid defining unprefixed wolfSSL SHA macros colliding with nettle ones */ +#define NO_OLD_WC_NAMES +#endif + +/* Single point where USE_SPNEGO definition might be defined */ +#if !defined(CURL_DISABLE_NEGOTIATE_AUTH) && \ + (defined(HAVE_GSSAPI) || defined(USE_WINDOWS_SSPI)) +#define USE_SPNEGO +#endif + +/* Single point where USE_KERBEROS5 definition might be defined */ +#if !defined(CURL_DISABLE_KERBEROS_AUTH) && \ + (defined(HAVE_GSSAPI) || defined(USE_WINDOWS_SSPI)) +#define USE_KERBEROS5 +#endif + +/* Single point where USE_NTLM definition might be defined */ +#ifdef CURL_ENABLE_NTLM +# if (defined(USE_OPENSSL) && defined(HAVE_DES_ECB_ENCRYPT)) || \ + defined(USE_GNUTLS) || \ + (defined(USE_MBEDTLS) && defined(HAVE_MBEDTLS_DES_CRYPT_ECB)) || \ + defined(USE_OS400CRYPTO) || defined(USE_WIN32_CRYPTO) || \ + (defined(USE_WOLFSSL) && defined(HAVE_WC_DES_ECBENCRYPT)) +# define USE_CURL_NTLM_CORE +# endif +# if defined(USE_CURL_NTLM_CORE) || defined(USE_WINDOWS_SSPI) +# define USE_NTLM +# endif +#endif + +#if defined(USE_LIBSSH2) || defined(USE_LIBSSH) +#define USE_SSH +#endif + +/* GCC <4.6 does not support '#pragma GCC diagnostic push' and does not support + 'pragma GCC diagnostic' inside functions. + Use CURL_HAVE_DIAG to guard the above in the curl codebase, instead of + defined(__GNUC__) || defined(__clang__). + */ +#if defined(__clang__) || (defined(__GNUC__) && \ + ((__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ >= 6)))) +#define CURL_HAVE_DIAG +#endif + +/* + * Provide a mechanism to silence picky compilers, such as gcc 4.6+. + * Parameters should of course normally not be unused, but for example when + * we have multiple implementations of the same interface it may happen. + */ +#if defined(__GNUC__) && ((__GNUC__ >= 3) || \ + ((__GNUC__ == 2) && defined(__GNUC_MINOR__) && (__GNUC_MINOR__ >= 7))) +# define WARN_UNUSED_RESULT __attribute__((warn_unused_result)) +#elif defined(__IAR_SYSTEMS_ICC__) && (__VER__ >= 9040001) +# define WARN_UNUSED_RESULT __attribute__((warn_unused_result)) +#else +# define WARN_UNUSED_RESULT +#endif + +/* noreturn attribute */ + +#ifndef CURL_NORETURN +#if (defined(__GNUC__) && (__GNUC__ >= 3)) || defined(__clang__) || \ + defined(__IAR_SYSTEMS_ICC__) +# define CURL_NORETURN __attribute__((__noreturn__)) +#elif defined(_MSC_VER) +# define CURL_NORETURN __declspec(noreturn) +#else +# define CURL_NORETURN +#endif +#endif + +/* fallthrough attribute */ + +#ifndef FALLTHROUGH +#if (defined(__GNUC__) && __GNUC__ >= 7) || \ + (defined(__clang__) && __clang_major__ >= 10) +# define FALLTHROUGH() __attribute__((fallthrough)) +#else +# define FALLTHROUGH() do {} while(0) +#endif +#endif + +/* + * Inclusion of common header files. + */ + +#include +#include +#include +#include +#include + +#ifdef HAVE_SYS_TYPES_H +#include +#endif + +#include + +#if !defined(_WIN32) || defined(__MINGW32__) +#include +#endif + +#ifdef HAVE_IO_H +#include +#endif + +#ifdef HAVE_FCNTL_H +#include +#endif + +#if defined(HAVE_STDBOOL_H) && defined(HAVE_BOOL_T) +#include +#endif + +#ifdef HAVE_UNISTD_H +#include +#endif + +/* Macro to strip 'const' without triggering a compiler warning. + Use it for APIs that do not or cannot support the const qualifier. */ +#ifdef HAVE_UINTPTR_T +#define CURL_UNCONST(p) ((void *)(uintptr_t)(const void *)(p)) +#else +#define CURL_UNCONST(p) ((void *)(p)) /* Fall back to simple cast */ +#endif + +#ifdef USE_SCHANNEL +/* Must set this before is included directly or indirectly by + another Windows header. */ +# define SCHANNEL_USE_BLACKLISTS /* for SCH_CREDENTIALS */ +# include /* for [P]UNICODE_STRING in SCH_CREDENTIALS */ +#endif + +#ifdef __hpux +# if !defined(_XOPEN_SOURCE_EXTENDED) || defined(_KERNEL) +# ifdef _APP32_64BIT_OFF_T +# define OLD_APP32_64BIT_OFF_T _APP32_64BIT_OFF_T +# undef _APP32_64BIT_OFF_T +# else +# undef OLD_APP32_64BIT_OFF_T +# endif +# endif +#endif + +#ifndef _WIN32 +#include /* also for MSG_NOSIGNAL */ +#endif + +#include "functypes.h" + +#ifdef __hpux +# if !defined(_XOPEN_SOURCE_EXTENDED) || defined(_KERNEL) +# ifdef OLD_APP32_64BIT_OFF_T +# define _APP32_64BIT_OFF_T OLD_APP32_64BIT_OFF_T +# undef OLD_APP32_64BIT_OFF_T +# endif +# endif +#endif + +/* + * Definition of timeval struct for platforms that do not have it. + */ +#ifndef HAVE_STRUCT_TIMEVAL +struct timeval { + long tv_sec; + long tv_usec; +}; +#endif + +/* + * If we have the MSG_NOSIGNAL define, make sure we use + * it as the fourth argument of function send() + */ +#ifdef MSG_NOSIGNAL +#define SEND_4TH_ARG MSG_NOSIGNAL +#else +#define SEND_4TH_ARG 0 +#endif + +#ifdef __minix +/* Minix does not support recv on TCP sockets */ +#define sread(x, y, z) (ssize_t)read((RECV_TYPE_ARG1)(x), \ + (RECV_TYPE_ARG2)(y), \ + (RECV_TYPE_ARG3)(z)) + +#elif defined(HAVE_RECV) +/* + * The definitions for the return type and arguments types + * of functions recv() and send() belong and come from the + * configuration file. Do not define them in any other place. + * + * HAVE_RECV is defined if you have a function named recv() + * which is used to read incoming data from sockets. If your + * function has another name then do not define HAVE_RECV. + * + * If HAVE_RECV is defined then RECV_TYPE_ARG1, RECV_TYPE_ARG2, + * RECV_TYPE_ARG3, RECV_TYPE_ARG4 and RECV_TYPE_RETV must also + * be defined. + * + * HAVE_SEND is defined if you have a function named send() + * which is used to write outgoing data on a connected socket. + * If yours has another name then do not define HAVE_SEND. + * + * If HAVE_SEND is defined then SEND_TYPE_ARG1, SEND_TYPE_ARG2, + * SEND_TYPE_ARG3, SEND_TYPE_ARG4 and SEND_TYPE_RETV must also + * be defined. SEND_NONCONST_ARG2 must also be defined if ARG2 + * does not accept const. + */ + +#define sread(x, y, z) (ssize_t)recv((RECV_TYPE_ARG1)(x), \ + (RECV_TYPE_ARG2)(y), \ + (RECV_TYPE_ARG3)(z), \ + (RECV_TYPE_ARG4)(0)) +#else /* HAVE_RECV */ +#ifndef sread +#error "Missing definition of macro sread!" +#endif +#endif /* HAVE_RECV */ + +#ifdef __minix +/* Minix does not support send on TCP sockets */ +#define swrite(x, y, z) (ssize_t)write((SEND_TYPE_ARG1)(x), \ + (SEND_TYPE_ARG2)CURL_UNCONST(y), \ + (SEND_TYPE_ARG3)(z)) +#elif defined(HAVE_SEND) +#ifdef SEND_NONCONST_ARG2 +#define swrite(x, y, z) (ssize_t)send((SEND_TYPE_ARG1)(x), \ + (SEND_TYPE_ARG2)CURL_UNCONST(y), \ + (SEND_TYPE_ARG3)(z), \ + (SEND_TYPE_ARG4)(SEND_4TH_ARG)) +#else +#define swrite(x, y, z) (ssize_t)send((SEND_TYPE_ARG1)(x), \ + (const SEND_TYPE_ARG2)(y), \ + (SEND_TYPE_ARG3)(z), \ + (SEND_TYPE_ARG4)(SEND_4TH_ARG)) +#endif /* SEND_NONCONST_ARG2 */ +#else /* HAVE_SEND */ +#ifndef swrite +#error "Missing definition of macro swrite!" +#endif +#endif /* HAVE_SEND */ + +/* + * Function-like macro definition used to close a socket. + */ +#ifdef HAVE_CLOSESOCKET +# define CURL_SCLOSE(x) closesocket(x) +#elif defined(HAVE_CLOSESOCKET_CAMEL) +# define CURL_SCLOSE(x) CloseSocket(x) +#elif defined(MSDOS) /* Watt-32 */ +# define CURL_SCLOSE(x) close_s(x) +#elif defined(USE_LWIPSOCK) +# define CURL_SCLOSE(x) lwip_close(x) +#else +# define CURL_SCLOSE(x) close(x) +#endif + +/* + * Stack-independent version of fcntl() on sockets: + */ +#ifdef USE_LWIPSOCK +# define sfcntl lwip_fcntl +#else +# define sfcntl fcntl +#endif + +/* + * 'bool' stuff compatible with HP-UX headers. + */ +#if defined(__hpux) && !defined(HAVE_BOOL_T) +typedef int bool; +# define false 0 +# define true 1 +# define HAVE_BOOL_T +#endif + +/* + * 'bool' exists on platforms with , i.e. C99 platforms. + * On non-C99 platforms there is no bool, so define an enum for that. + * On C99 platforms 'false' and 'true' also exist. Enum uses a + * global namespace though, so use bool_false and bool_true. + */ +#ifndef HAVE_BOOL_T +typedef enum { + bool_false = 0, + bool_true = 1 +} bool; + +/* + * Use a define to let 'true' and 'false' use those enums. There + * are currently no use of true and false in libcurl proper, but + * there are some in the examples. This will cater for any later + * code happening to use true and false. + */ +# define false bool_false +# define true bool_true +# define HAVE_BOOL_T +#endif + +/* the type we use for storing a single boolean bit */ +typedef unsigned int curl_bit; +#define BIT(x) curl_bit x:1 + +/* + * Redefine TRUE and FALSE too, to catch current use. With this + * change, 'bool found = 1' will give a warning on MIPSPro, but + * 'bool found = TRUE' will not. Change tested on IRIX/MIPSPro, + * AIX 5.1/Xlc, Tru64 5.1/cc, w/make test too. + */ +#ifndef TRUE +#define TRUE true +#endif +#ifndef FALSE +#define FALSE false +#endif + +#include "curl_ctype.h" + +/* + * Macro used to include code only in debug builds. + */ +#ifdef DEBUGBUILD +#define DEBUGF(x) x +#else +#define DEBUGF(x) do {} while(0) +#endif + +/* + * Macro used to include assertion code only in debug builds. + */ +#undef DEBUGASSERT +#ifdef DEBUGBUILD +#ifdef CURL_DEBUGASSERT +/* External assertion handler for custom integrations */ +#define DEBUGASSERT(x) CURL_DEBUGASSERT(x) +#else +#define DEBUGASSERT(x) assert(x) +#endif +#else +#define DEBUGASSERT(x) do {} while(0) +#endif + +/* + * Macro SOCKERRNO / SET_SOCKERRNO() returns / sets the *socket-related* errno + * (or equivalent) on this platform to hide platform details to code using it. + */ +#ifdef USE_WINSOCK +#define SOCKERRNO ((int)WSAGetLastError()) +#define SET_SOCKERRNO(x) WSASetLastError((int)(x)) +#else +#define SOCKERRNO errno +#define SET_SOCKERRNO(x) (errno = (x)) +#endif + +/* + * Portable error number symbolic names defined to Winsock error codes. + */ +#ifdef USE_WINSOCK +#define SOCKEACCES WSAEACCES +#define SOCKEADDRINUSE WSAEADDRINUSE +#define SOCKEADDRNOTAVAIL WSAEADDRNOTAVAIL +#define SOCKEAFNOSUPPORT WSAEAFNOSUPPORT +#define SOCKEBADF WSAEBADF +#define SOCKECONNREFUSED WSAECONNREFUSED +#define SOCKECONNRESET WSAECONNRESET +#define SOCKEINPROGRESS WSAEINPROGRESS +#define SOCKEINTR WSAEINTR +#define SOCKEINVAL WSAEINVAL +#define SOCKEISCONN WSAEISCONN +#define SOCKEMSGSIZE WSAEMSGSIZE +/* Use literal value to work around clang-tidy <=20 misreporting + 'readability-uppercase-literal-suffix' with mingw-w64 headers */ +#define SOCKENOMEM 8L /* WSA_NOT_ENOUGH_MEMORY */ +#define SOCKETIMEDOUT WSAETIMEDOUT +#define SOCKEWOULDBLOCK WSAEWOULDBLOCK +#else +#define SOCKEACCES EACCES +#define SOCKEADDRINUSE EADDRINUSE +#define SOCKEADDRNOTAVAIL EADDRNOTAVAIL +#define SOCKEAFNOSUPPORT EAFNOSUPPORT +#define SOCKEBADF EBADF +#define SOCKECONNREFUSED ECONNREFUSED +#define SOCKECONNRESET ECONNRESET +#define SOCKEINPROGRESS EINPROGRESS +#define SOCKEINTR EINTR +#define SOCKEINVAL EINVAL +#define SOCKEISCONN EISCONN +#define SOCKEMSGSIZE EMSGSIZE +#define SOCKENOMEM ENOMEM +#ifdef ETIMEDOUT +#define SOCKETIMEDOUT ETIMEDOUT +#endif +#define SOCKEWOULDBLOCK EWOULDBLOCK +#endif + +/* The socket error may be EWOULDBLOCK or on some systems EAGAIN when + it returned due to its inability to send/read data without blocking. + We treat both error codes the same here. */ +#if !defined(USE_WINSOCK) && EAGAIN != SOCKEWOULDBLOCK +#define SOCK_EAGAIN(e) ((e) == SOCKEWOULDBLOCK || (e) == EAGAIN) +#else +#define SOCK_EAGAIN(e) ((e) == SOCKEWOULDBLOCK) +#endif + +/* + * Macro argv_item_t hides platform details to code using it. + */ +#ifdef __VMS +#define argv_item_t __char_ptr32 +#elif defined(_UNICODE) +#define argv_item_t wchar_t * +#else +#define argv_item_t char * +#endif + +/* + * We use this ZERO_NULL to avoid picky compiler warnings, + * when assigning a NULL pointer to a function pointer var. + */ +#define ZERO_NULL 0 + +/* + * Macros and functions to safely suppress warnings + */ +#include "curlx/warnless.h" + +#ifdef _WIN32 +# undef read +# define read(fd, buf, count) (ssize_t)_read(fd, buf, curlx_uztoui(count)) +# undef write +# define write(fd, buf, count) (ssize_t)_write(fd, buf, curlx_uztoui(count)) +/* Avoid VS2005+ _CRT_NONSTDC_NO_DEPRECATE warnings about non-portable funcs */ +# undef fileno +# define fileno(fh) _fileno(fh) +# undef unlink +# define unlink(fn) _unlink(fn) +# undef isatty +# define isatty(fd) _isatty(fd) +#endif + +/* + * Definition of our NOP statement Object-like macro + */ +#ifndef Curl_nop_stmt +#define Curl_nop_stmt do {} while(0) +#endif + +/* + * Ensure that Winsock and lwIP TCP/IP stacks are not mixed. + */ +#if defined(__LWIP_OPT_H__) || defined(LWIP_HDR_OPT_H) +# if defined(SOCKET) || defined(USE_WINSOCK) +# error "Winsock and lwIP TCP/IP stack definitions shall not coexist!" +# endif +#endif + +/* + * shutdown() flags for systems that do not define them + */ +#ifndef SHUT_RD +#define SHUT_RD 0x00 +#endif + +#ifndef SHUT_WR +#define SHUT_WR 0x01 +#endif + +#ifndef SHUT_RDWR +#define SHUT_RDWR 0x02 +#endif + +/* Define S_ISREG if not defined by system headers, e.g. MSVC */ +#if !defined(S_ISREG) && defined(S_IFMT) && defined(S_IFREG) +#define S_ISREG(m) (((m) & S_IFMT) == S_IFREG) +#endif + +/* Define S_ISDIR if not defined by system headers, e.g. MSVC */ +#if !defined(S_ISDIR) && defined(S_IFMT) && defined(S_IFDIR) +#define S_ISDIR(m) (((m) & S_IFMT) == S_IFDIR) +#endif + +/* For MSVC (all versions as of VS2022) */ +#ifndef STDIN_FILENO +#define STDIN_FILENO fileno(stdin) +#endif +#ifndef STDOUT_FILENO +#define STDOUT_FILENO fileno(stdout) +#endif +#ifndef STDERR_FILENO +#define STDERR_FILENO fileno(stderr) +#endif + +/* Since O_BINARY is used in bitmasks, setting it to zero makes it usable in + source code but yet it does not ruin anything */ +#ifdef _O_BINARY /* for _WIN32 || MSDOS */ +#define CURL_O_BINARY _O_BINARY +#elif defined(O_BINARY) /* __CYGWIN__ */ +#define CURL_O_BINARY O_BINARY +#else +#define CURL_O_BINARY 0 +#endif + +/* Requires io.h when available */ +#ifdef MSDOS +#define CURL_BINMODE(stream) (void)setmode(fileno(stream), CURL_O_BINARY) +#elif defined(_WIN32) || defined(__CYGWIN__) +#define CURL_BINMODE(stream) (void)_setmode(fileno(stream), CURL_O_BINARY) +#else +#define CURL_BINMODE(stream) (void)(stream) +#endif + +/* In Windows the default file mode is text but an application can override it. +Therefore we specify it explicitly. https://github.com/curl/curl/pull/258 +*/ +#if defined(_WIN32) || defined(MSDOS) +#define FOPEN_READTEXT "rt" +#define FOPEN_WRITETEXT "wt" +#define FOPEN_APPENDTEXT "at" +#elif defined(__CYGWIN__) +/* Cygwin has specific behavior we need to address when _WIN32 is not defined. +https://cygwin.com/cygwin-ug-net/using-textbinary.html +For write we want our output to have line endings of LF and be compatible with +other Cygwin utilities. For read we want to handle input that may have line +endings either CRLF or LF so 't' is appropriate. +*/ +#define FOPEN_READTEXT "rt" +#define FOPEN_WRITETEXT "w" +#define FOPEN_APPENDTEXT "a" +#else +#define FOPEN_READTEXT "r" +#define FOPEN_WRITETEXT "w" +#define FOPEN_APPENDTEXT "a" +#endif + +/* for systems that do not detect this in configure */ +#ifndef CURL_SA_FAMILY_T +# ifdef USE_WINSOCK +# define CURL_SA_FAMILY_T ADDRESS_FAMILY +# elif defined(HAVE_SA_FAMILY_T) +# define CURL_SA_FAMILY_T sa_family_t +# elif defined(__AMIGA__) +# define CURL_SA_FAMILY_T unsigned char +# else +/* use a sensible default */ +# define CURL_SA_FAMILY_T unsigned short +# endif +#endif + +/* Some convenience macros to get the larger/smaller value out of two given. + We prefix with CURL to prevent name collisions. */ +#define CURLMAX(x, y) ((x) > (y) ? (x) : (y)) +#define CURLMIN(x, y) ((x) < (y) ? (x) : (y)) + +/* A convenience macro to provide both the string literal and the length of + the string literal in one go, useful for functions that take "string,len" + as their argument */ +#define STRCONST(x) x, sizeof(x) - 1 + +#define CURL_ARRAYSIZE(A) (sizeof(A) / sizeof((A)[0])) + +/* Buffer size for error messages retrieved via + curlx_strerror() and Curl_sspi_strerror() */ +#define STRERROR_LEN 256 + +#ifndef CURL_DID_MEMORY_FUNC_TYPEDEFS /* only if not already done */ +/* + * The following memory function replacement typedef's are COPIED from + * curl/curl.h and MUST match the originals. We copy them to avoid having to + * include curl/curl.h here. We avoid that include since it includes stdio.h + * and other headers that may get messed up with defines done here. + */ +typedef void *(*curl_malloc_callback)(size_t size); +typedef void (*curl_free_callback)(void *ptr); +typedef void *(*curl_realloc_callback)(void *ptr, size_t size); +typedef char *(*curl_strdup_callback)(const char *str); +typedef void *(*curl_calloc_callback)(size_t nmemb, size_t size); +#define CURL_DID_MEMORY_FUNC_TYPEDEFS +#endif + +extern curl_malloc_callback Curl_cmalloc; +extern curl_free_callback Curl_cfree; +extern curl_realloc_callback Curl_crealloc; +extern curl_strdup_callback Curl_cstrdup; +extern curl_calloc_callback Curl_ccalloc; + +/* + * curlx_safefree() defined as a macro to allow MemoryTracking feature + * to log free() calls at same location where curlx_safefree() is used. + * This macro also assigns NULL to given pointer when free'd. + */ +#define curlx_safefree(ptr) \ + do { \ + curlx_free(ptr); \ + (ptr) = NULL; \ + } while(0) + +/* Same as curlx_safefree() but zeroes memory before freeing */ +#define curlx_safefreezero(ptr, size) \ + do { \ + curlx_freezero(ptr, size); \ + (ptr) = NULL; \ + } while(0) + +/* Same as curlx_safefreezero() but determines length with strlen() */ +#define curlx_safefreezeroz(ptr) \ + do { \ + curlx_freezeroz(ptr); \ + (ptr) = NULL; \ + } while(0) + +#include /* for CURL_EXTERN, curl_socket_t, mprintf.h */ + +#ifdef DEBUGBUILD +#define CURL_MEMDEBUG +#endif + +#ifdef CURL_MEMDEBUG +#ifdef __clang__ +# define ALLOC_FUNC __attribute__((__malloc__)) +# if __clang_major__ >= 4 +# define ALLOC_SIZE(s) __attribute__((__alloc_size__(s))) +# define ALLOC_SIZE2(n, s) __attribute__((__alloc_size__(n, s))) +# else +# define ALLOC_SIZE(s) +# define ALLOC_SIZE2(n, s) +# endif +#elif defined(__GNUC__) && __GNUC__ >= 3 +# define ALLOC_FUNC __attribute__((__malloc__)) +# define ALLOC_SIZE(s) __attribute__((__alloc_size__(s))) +# define ALLOC_SIZE2(n, s) __attribute__((__alloc_size__(n, s))) +#elif defined(_MSC_VER) +# define ALLOC_FUNC __declspec(restrict) +# define ALLOC_SIZE(s) +# define ALLOC_SIZE2(n, s) +#else +# define ALLOC_FUNC +# define ALLOC_SIZE(s) +# define ALLOC_SIZE2(n, s) +#endif + +extern FILE *curl_dbg_logfile; + +/* memory functions */ +CURL_EXTERN void curl_dbg_free(void *ptr, int line, const char *source); +CURL_EXTERN ALLOC_FUNC ALLOC_SIZE(1) + void *curl_dbg_malloc(size_t size, int line, const char *source); +CURL_EXTERN ALLOC_FUNC ALLOC_SIZE2(1, 2) + void *curl_dbg_calloc(size_t n, size_t size, int line, const char *source); +CURL_EXTERN ALLOC_SIZE(2) + void *curl_dbg_realloc(void *ptr, size_t size, int line, const char *source); +CURL_EXTERN ALLOC_FUNC + char *curl_dbg_strdup(const char *str, int line, const char *src); +#if defined(_WIN32) && defined(UNICODE) +CURL_EXTERN ALLOC_FUNC + wchar_t *curl_dbg_wcsdup(const wchar_t *str, int line, const char *source); +#endif + +CURL_EXTERN void curl_dbg_memdebug(const char *logname); +CURL_EXTERN void curl_dbg_memlimit(long limit); +CURL_EXTERN void curl_dbg_log(const char *format, ...) CURL_PRINTF(1, 2); + +/* file descriptor manipulators */ +CURL_EXTERN curl_socket_t curl_dbg_socket(int domain, int type, int protocol, + int line, const char *source); +CURL_EXTERN void curl_dbg_mark_sclose(curl_socket_t sockfd, + int line, const char *source); +CURL_EXTERN int curl_dbg_sclose(curl_socket_t sockfd, + int line, const char *source); +CURL_EXTERN curl_socket_t curl_dbg_accept(curl_socket_t s, + void *saddr, void *saddrlen, + int line, const char *source); +#ifdef HAVE_ACCEPT4 +CURL_EXTERN curl_socket_t curl_dbg_accept4(curl_socket_t s, void *saddr, + void *saddrlen, int flags, + int line, const char *source); +#endif +#ifdef HAVE_SOCKETPAIR +CURL_EXTERN int curl_dbg_socketpair(int domain, int type, int protocol, + curl_socket_t socket_vector[2], + int line, const char *source); +#endif + +/* FILE functions */ +CURL_EXTERN int curl_dbg_fclose(FILE *file, int line, const char *source); +CURL_EXTERN ALLOC_FUNC FILE *curl_dbg_fopen(const char *file, const char *mode, + int line, const char *source); +CURL_EXTERN ALLOC_FUNC FILE *curl_dbg_freopen(const char *file, + const char *mode, FILE *fh, + int line, const char *source); +CURL_EXTERN ALLOC_FUNC FILE *curl_dbg_fdopen(int filedes, const char *mode, + int line, const char *source); + +#define sclose(sockfd) curl_dbg_sclose(sockfd, __LINE__, __FILE__) +#define fake_sclose(sockfd) curl_dbg_mark_sclose(sockfd, __LINE__, __FILE__) + +#define CURL_GETADDRINFO(host, serv, hint, res) \ + curl_dbg_getaddrinfo(host, serv, hint, res, __LINE__, __FILE__) +#define CURL_FREEADDRINFO(data) \ + curl_dbg_freeaddrinfo(data, __LINE__, __FILE__) +#define CURL_SOCKET(domain, type, protocol) \ + curl_dbg_socket((int)(domain), type, protocol, __LINE__, __FILE__) +#ifdef HAVE_SOCKETPAIR +#define CURL_SOCKETPAIR(domain, type, protocol, socket_vector) \ + curl_dbg_socketpair((int)(domain), type, protocol, socket_vector, \ + __LINE__, __FILE__) +#endif +#define CURL_ACCEPT(sock, addr, len) \ + curl_dbg_accept(sock, addr, len, __LINE__, __FILE__) +#ifdef HAVE_ACCEPT4 +#define CURL_ACCEPT4(sock, addr, len, flags) \ + curl_dbg_accept4(sock, addr, len, flags, __LINE__, __FILE__) +#endif + +#else /* !CURL_MEMDEBUG */ + +#define sclose(x) CURL_SCLOSE(x) +#define fake_sclose(x) Curl_nop_stmt + +#define CURL_GETADDRINFO getaddrinfo +#define CURL_FREEADDRINFO freeaddrinfo +#define CURL_SOCKET socket +#ifdef HAVE_SOCKETPAIR +#define CURL_SOCKETPAIR socketpair +#endif +#define CURL_ACCEPT accept +#ifdef HAVE_ACCEPT4 +#define CURL_ACCEPT4 accept4 +#endif + +#endif /* CURL_MEMDEBUG */ + +/* Allocator macros */ + +#ifdef _WIN32 +#define CURLX_STRDUP_LOW _strdup +#else +#define CURLX_STRDUP_LOW strdup +#endif + +#ifdef CURL_MEMDEBUG + +#define curlx_strdup(ptr) curl_dbg_strdup(ptr, __LINE__, __FILE__) +#define curlx_malloc(size) curl_dbg_malloc(size, __LINE__, __FILE__) +#define curlx_calloc(nbelem, size) \ + curl_dbg_calloc(nbelem, size, __LINE__, __FILE__) +#define curlx_realloc(ptr, size) \ + curl_dbg_realloc(ptr, size, __LINE__, __FILE__) +#define curlx_free(ptr) curl_dbg_free(ptr, __LINE__, __FILE__) + +#ifdef _WIN32 +#ifdef UNICODE +#define curlx_tcsdup(ptr) curl_dbg_wcsdup(ptr, __LINE__, __FILE__) +#else +#define curlx_tcsdup curlx_strdup +#endif +#endif /* _WIN32 */ + +#else /* !CURL_MEMDEBUG */ + +#ifdef BUILDING_LIBCURL +#define curlx_strdup Curl_cstrdup +#define curlx_malloc Curl_cmalloc +#define curlx_calloc Curl_ccalloc +#define curlx_realloc Curl_crealloc +#define curlx_free Curl_cfree +#else /* !BUILDING_LIBCURL */ +#define curlx_strdup CURLX_STRDUP_LOW +#define curlx_malloc malloc +#define curlx_calloc calloc +#define curlx_realloc realloc +#define curlx_free free +#endif /* BUILDING_LIBCURL */ + +#ifdef _WIN32 +#ifdef UNICODE +#define curlx_tcsdup curlx_wcsdup +#else +#define curlx_tcsdup curlx_strdup +#endif +#endif /* _WIN32 */ + +#endif /* CURL_MEMDEBUG */ + +/* Some versions of the Android NDK is missing the declaration */ +#if defined(HAVE_GETPWUID_R) && \ + defined(__ANDROID_API__) && (__ANDROID_API__ < 21) +struct passwd; +int getpwuid_r(uid_t uid, struct passwd *pwd, char *buf, + size_t buflen, struct passwd **result); +#endif + +#ifdef UNITTESTS +#define UNITTEST +#else +#define UNITTEST static +#endif + +#ifdef USE_NGHTTP2 +#define USE_HTTP2 +#endif + +#if (defined(USE_NGTCP2) && defined(USE_NGHTTP3)) || defined(USE_QUICHE) + +#ifdef CURL_WITH_MULTI_SSL +#error "MultiSSL combined with QUIC is not supported" +#endif + +#define USE_HTTP3 +#endif + +/* WebAssembly builds have TCP_NODELAY, but runtime support is missing. */ +#ifndef __EMSCRIPTEN__ +#define CURL_TCP_NODELAY_SUPPORTED +#endif + +/* Certain Windows implementations are not aligned with what curl expects, + so always use the local one on this platform. E.g. the mingw-w64 + implementation can return wrong results for non-ASCII inputs. */ +#if defined(HAVE_BASENAME) && defined(_WIN32) +#undef HAVE_BASENAME +#endif + +#if defined(USE_UNIX_SOCKETS) && defined(_WIN32) +/* Offered by mingw-w64 v10+, MS SDK 10.0.16299.0/VS2017 15.4+ */ +#if defined(__MINGW32__) && (__MINGW64_VERSION_MAJOR >= 10) +# include +#elif !defined(UNIX_PATH_MAX) /* Replicate logic present in afunix.h */ +# define UNIX_PATH_MAX 108 +/* !checksrc! disable TYPEDEFSTRUCT 1 */ +typedef struct sockaddr_un { + CURL_SA_FAMILY_T sun_family; + char sun_path[UNIX_PATH_MAX]; +} SOCKADDR_UN, *PSOCKADDR_UN; +#endif +#endif + +#ifdef USE_OPENSSL +/* OpenSSL 3 marks these functions deprecated but we have no replacements (yet) + so tell the compiler to not warn for them: + - DES_* (for NTLM), SSL_CTX_set_srp_* (for TLS-SRP) + - EVP_PKEY_get1_RSA, MD5_*, RSA_flags, RSA_free (auto-skipped for OpenSSL + built with no-deprecated) */ +# define OPENSSL_SUPPRESS_DEPRECATED +# ifdef _WIN32 +/* Silence LibreSSL warnings about wincrypt.h collision. Works in 3.8.2+ */ +# ifndef LIBRESSL_DISABLE_OVERRIDE_WINCRYPT_DEFINES_WARNING +# define LIBRESSL_DISABLE_OVERRIDE_WINCRYPT_DEFINES_WARNING +# endif +# endif +#endif + +#ifdef CURL_INLINE +/* 'CURL_INLINE' defined, use as-is */ +#elif defined(inline) +# define CURL_INLINE inline /* 'inline' defined, assumed correct */ +#elif defined(__cplusplus) +/* The code is compiled with C++ compiler. + C++ always supports 'inline'. */ +# define CURL_INLINE inline /* 'inline' keyword supported */ +#elif defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L +/* C99 (and later) supports 'inline' keyword */ +# define CURL_INLINE inline /* 'inline' keyword supported */ +#elif defined(__GNUC__) && __GNUC__ >= 3 +/* GCC supports '__inline__' as an extension */ +# define CURL_INLINE __inline__ +#elif defined(_MSC_VER) +# define CURL_INLINE __inline +#else +/* Probably 'inline' is not supported by compiler. + Define to the empty string to be on the safe side. */ +# define CURL_INLINE /* empty */ +#endif + +/* Detect if compiler supports C99 variadic macros */ +#if (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) || \ + defined(_MSC_VER) +#define CURL_HAVE_MACRO_VARARG +#endif + +#if !defined(CURL_HAVE_MACRO_VARARG) || \ + (defined(CURL_HAVE_MACRO_VARARG) && !defined(CURL_DISABLE_VERBOSE_STRINGS)) +#define CURLVERBOSE +#define VERBOSE(x) x +#define NOVERBOSE(x) Curl_nop_stmt +#else +#define VERBOSE(x) Curl_nop_stmt +#define NOVERBOSE(x) x +#endif + +/* For FreeBSD it is included from curl/curl.h */ +#if defined(__DragonFly__) || defined(__OpenBSD__) || defined(__NetBSD__) +#include /* for __DragonFly_version, OpenBSD, + __NetBSD_Version__ */ +#endif + +#ifndef _CURL_LOCAL_MEMZERO /* to be removed after a couple of releases */ +#ifdef _WIN32 +#if defined(_MSC_VER) && defined(NTDDI_VERSION) && \ + (NTDDI_VERSION >= 0x0A000010) /* MS SDK 10.0.26100.0+ */ +#pragma comment(lib, "volatileaccessu.lib") +#define curlx_memzero(buf, size) SecureZeroMemory2(buf, size) +#else +#define curlx_memzero(buf, size) SecureZeroMemory(buf, size) +#endif +#elif defined(HAVE_MEMSET_S) +#define curlx_memzero(buf, size) (void)memset_s(buf, size, 0, size) +#elif defined(HAVE_MEMSET_EXPLICIT) +#define curlx_memzero(buf, size) (void)memset_explicit(buf, 0, size) +#elif defined(__CYGWIN__) || \ + (defined(__NEWLIB__) && !defined(__CLIB2__)) || \ + (defined(__GLIBC__) && \ + (__GLIBC__ > 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ >= 25))) || \ + (defined(__DragonFly__) && __DragonFly_version >= 500600 /* v5.6+ */) || \ + (defined(__FreeBSD__) && __FreeBSD_version >= 1100037 /* v11.0+ */) || \ + (defined(__OpenBSD__) && OpenBSD >= 201405 /* v5.5+ */) +#define curlx_memzero(buf, size) explicit_bzero(buf, size) +#elif defined(__NetBSD__) && __NetBSD_Version__ >= 702000000 /* v7.2+ */ +#define curlx_memzero(buf, size) (void)explicit_memset(buf, 0, size) +#endif +#endif /* !_CURL_LOCAL_MEMZERO */ + +#ifndef curlx_memzero +#define USE_CURLX_MEMZERO +void curlx_memzero(void *buf, size_t size); +#endif +void curlx_freezero(void *buf, size_t size); +void curlx_freezeroz(void *buf); + +#endif /* HEADER_CURL_SETUP_H */ diff --git a/3rdparty/curl-8.21.0/lib/curl_sha256.h b/3rdparty/curl-8.21.0/lib/curl_sha256.h new file mode 100644 index 0000000000..6c48a8e176 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_sha256.h @@ -0,0 +1,45 @@ +#ifndef HEADER_CURL_SHA256_H +#define HEADER_CURL_SHA256_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Florin Petriuc, + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_AWS) || !defined(CURL_DISABLE_DIGEST_AUTH) || \ + defined(USE_LIBSSH2) || defined(USE_SSL) + +#include "curl_hmac.h" + +extern const struct HMAC_params Curl_HMAC_SHA256; + +#ifndef CURL_SHA256_DIGEST_LENGTH +#define CURL_SHA256_DIGEST_LENGTH 32 /* fixed size */ +#endif + +CURLcode Curl_sha256it(unsigned char *output, const unsigned char *input, + size_t len); + +#endif + +#endif /* HEADER_CURL_SHA256_H */ diff --git a/3rdparty/curl-8.21.0/lib/curl_sha512_256.c b/3rdparty/curl-8.21.0/lib/curl_sha512_256.c new file mode 100644 index 0000000000..c429bba8f2 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_sha512_256.c @@ -0,0 +1,847 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Evgeny Grin (Karlson2k), . + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_DIGEST_AUTH) && !defined(CURL_DISABLE_SHA512_256) + +#include "curl_sha512_256.h" + +/* The recommended order of the TLS backends: + * 1. USE_OPENSSL + * 2. USE_WOLFSSL + * 3. USE_GNUTLS + * 4. USE_MBEDTLS (TBD) + * 5. USE_RUSTLS (TBD) + * 6. USE_WIN32_CRYPTO (TBD) + * Skip the backend if it does not support the required algorithm */ + +#ifdef USE_OPENSSL +# include +# if !defined(LIBRESSL_VERSION_NUMBER) || \ + (defined(LIBRESSL_VERSION_NUMBER) && LIBRESSL_VERSION_NUMBER >= 0x3080000fL) +# include +# define USE_OPENSSL_SHA512_256 1 +# define HAS_SHA512_256_IMPLEMENTATION 1 +# ifdef __NetBSD__ +/* Some NetBSD versions have a bug in SHA-512/256. + * See https://gnats.netbsd.org/cgi-bin/query-pr-single.pl?number=58039 + * The problematic versions: + * - NetBSD before 9.4 + * - NetBSD 9 all development versions (9.99.x) + * - NetBSD 10 development versions (10.99.x) before 10.99.11 + * The bug was fixed in NetBSD 9.4 release, NetBSD 10.0 release, + * NetBSD 10.99.11 development. + * It is safe to apply the workaround even if the bug is not present, as + * the workaround reduces performance slightly. */ +# if __NetBSD_Version__ < 904000000 || \ + (__NetBSD_Version__ >= 999000000 && \ + __NetBSD_Version__ < 1000000000) || \ + (__NetBSD_Version__ >= 1099000000 && \ + __NetBSD_Version__ < 1099001100) +# define NEED_NETBSD_SHA512_256_WORKAROUND 1 +# endif +# endif +# endif +#endif /* USE_OPENSSL */ + +#if !defined(HAS_SHA512_256_IMPLEMENTATION) && defined(USE_WOLFSSL) +# include +# ifndef WOLFSSL_NOSHA512_256 +# define USE_WOLFSSL_SHA512_256 1 +# define HAS_SHA512_256_IMPLEMENTATION 1 +# endif +#endif + +#if !defined(HAS_SHA512_256_IMPLEMENTATION) && defined(USE_GNUTLS) +# include +# include +# ifdef SHA512_256_DIGEST_SIZE +# define USE_GNUTLS_SHA512_256 1 +# endif +#endif /* !HAS_SHA512_256_IMPLEMENTATION && USE_GNUTLS */ + +#ifdef USE_OPENSSL_SHA512_256 + +/* OpenSSL does not provide macros for SHA-512/256 sizes */ + +/** + * Size of the SHA-512/256 single processing block in bytes. + */ +#define CURL_SHA512_256_BLOCK_SIZE 128 + +/** + * Size of the SHA-512/256 resulting digest in bytes. + * This is the final digest size, not intermediate hash. + */ +#define CURL_SHA512_256_DIGEST_SIZE CURL_SHA512_256_DIGEST_LENGTH + +/** + * Context type used for SHA-512/256 calculations + */ +typedef EVP_MD_CTX *Curl_sha512_256_ctx; + +/** + * Initialize structure for SHA-512/256 calculation. + * + * @param context the calculation context + * @return CURLE_OK if succeed, + * error code otherwise + */ +static CURLcode Curl_sha512_256_init(void *context) +{ + Curl_sha512_256_ctx * const ctx = (Curl_sha512_256_ctx *)context; + + *ctx = EVP_MD_CTX_create(); + if(!*ctx) + return CURLE_OUT_OF_MEMORY; + + if(EVP_DigestInit_ex(*ctx, EVP_sha512_256(), NULL)) { + /* Check whether the header and this file use the same numbers */ + DEBUGASSERT(EVP_MD_CTX_size(*ctx) == CURL_SHA512_256_DIGEST_SIZE); + /* Check whether the block size is correct */ + DEBUGASSERT(EVP_MD_CTX_block_size(*ctx) == CURL_SHA512_256_BLOCK_SIZE); + + return CURLE_OK; /* Success */ + } + + /* Cleanup */ + EVP_MD_CTX_destroy(*ctx); + return CURLE_FAILED_INIT; +} + +/** + * Process portion of bytes. + * + * @param context the calculation context + * @param data bytes to add to hash + * @return CURLE_OK if succeed, + * error code otherwise + */ +static CURLcode Curl_sha512_256_update(void *context, + const unsigned char *data, + size_t length) +{ + Curl_sha512_256_ctx * const ctx = (Curl_sha512_256_ctx *)context; + + if(!EVP_DigestUpdate(*ctx, data, length)) + return CURLE_BAD_FUNCTION_ARGUMENT; + + return CURLE_OK; +} + +/** + * Finalise SHA-512/256 calculation, return digest. + * + * @param context the calculation context + * @param[out] digest set to the hash, must be #CURL_SHA512_256_DIGEST_SIZE + * bytes + * @return CURLE_OK if succeed, + * error code otherwise + */ +static CURLcode Curl_sha512_256_finish(unsigned char *digest, void *context) +{ + CURLcode result; + Curl_sha512_256_ctx * const ctx = (Curl_sha512_256_ctx *)context; + +#ifdef NEED_NETBSD_SHA512_256_WORKAROUND + /* Use a larger buffer to work around a bug in NetBSD: + https://gnats.netbsd.org/cgi-bin/query-pr-single.pl?number=58039 */ + unsigned char tmp_digest[CURL_SHA512_256_DIGEST_SIZE * 2]; + result = EVP_DigestFinal_ex(*ctx, tmp_digest, NULL) ? + CURLE_OK : CURLE_BAD_FUNCTION_ARGUMENT; + if(result == CURLE_OK) + memcpy(digest, tmp_digest, CURL_SHA512_256_DIGEST_SIZE); + curlx_memzero(tmp_digest, sizeof(tmp_digest)); +#else /* !NEED_NETBSD_SHA512_256_WORKAROUND */ + result = EVP_DigestFinal_ex(*ctx, digest, NULL) ? + CURLE_OK : CURLE_BAD_FUNCTION_ARGUMENT; +#endif /* NEED_NETBSD_SHA512_256_WORKAROUND */ + + EVP_MD_CTX_destroy(*ctx); + *ctx = NULL; + + return result; +} + +#elif defined(USE_WOLFSSL_SHA512_256) +#include + +#define CURL_SHA512_256_DIGEST_SIZE WC_SHA512_256_DIGEST_SIZE +#define CURL_SHA512_256_BLOCK_SIZE WC_SHA512_256_BLOCK_SIZE + +typedef struct wc_Sha512 Curl_sha512_256_ctx; + +static CURLcode Curl_sha512_256_init(void *ctx) +{ + if(wc_InitSha512_256(ctx)) + return CURLE_FAILED_INIT; + return CURLE_OK; +} + +static CURLcode Curl_sha512_256_update(void *ctx, + const unsigned char *data, + size_t length) +{ + do { + word32 ilen = (word32)CURLMIN(length, UINT_MAX); + if(wc_Sha512_256Update(ctx, data, ilen)) + return CURLE_BAD_FUNCTION_ARGUMENT; + length -= ilen; + data += ilen; + } while(length); + return CURLE_OK; +} + +static CURLcode Curl_sha512_256_finish(unsigned char *digest, void *ctx) +{ + if(wc_Sha512_256Final(ctx, digest)) + return CURLE_BAD_FUNCTION_ARGUMENT; + return CURLE_OK; +} + +#elif defined(USE_GNUTLS_SHA512_256) + +#define CURL_SHA512_256_BLOCK_SIZE SHA512_256_BLOCK_SIZE +#define CURL_SHA512_256_DIGEST_SIZE SHA512_256_DIGEST_SIZE + +/** + * Context type used for SHA-512/256 calculations + */ +typedef struct sha512_256_ctx Curl_sha512_256_ctx; + +/** + * Initialize structure for SHA-512/256 calculation. + * + * @param context the calculation context + * @return always CURLE_OK + */ +static CURLcode Curl_sha512_256_init(void *context) +{ + Curl_sha512_256_ctx * const ctx = (Curl_sha512_256_ctx *)context; + + /* Check whether the header and this file use the same numbers */ + DEBUGASSERT(CURL_SHA512_256_DIGEST_LENGTH == CURL_SHA512_256_DIGEST_SIZE); + + sha512_256_init(ctx); + + return CURLE_OK; +} + +/** + * Process portion of bytes. + * + * @param context the calculation context + * @param data bytes to add to hash + * @param length number of bytes in @a data + * @return always CURLE_OK + */ +static CURLcode Curl_sha512_256_update(void *context, + const unsigned char *data, + size_t length) +{ + Curl_sha512_256_ctx * const ctx = (Curl_sha512_256_ctx *)context; + + DEBUGASSERT(data || (length == 0)); + + sha512_256_update(ctx, length, (const uint8_t *)data); + + return CURLE_OK; +} + +/** + * Finalise SHA-512/256 calculation, return digest. + * + * @param context the calculation context + * @param[out] digest set to the hash, must be #CURL_SHA512_256_DIGEST_SIZE + * bytes + * @return always CURLE_OK + */ +static CURLcode Curl_sha512_256_finish(unsigned char *digest, void *context) +{ + Curl_sha512_256_ctx * const ctx = (Curl_sha512_256_ctx *)context; + +#if NETTLE_VERSION_MAJOR >= 4 + sha512_256_digest(ctx, (uint8_t *)digest); +#else + sha512_256_digest(ctx, + (size_t)CURL_SHA512_256_DIGEST_SIZE, (uint8_t *)digest); +#endif + + return CURLE_OK; +} + +#else /* No system or TLS backend SHA-512/256 implementation available */ + +/* ** This implementation of SHA-512/256 hash calculation was originally ** * + * ** written by Evgeny Grin (Karlson2k) for GNU libmicrohttpd. ** * + * ** The author ported the code to libcurl. The ported code is provided ** * + * ** under curl license. ** */ + +#ifdef __GNUC__ +# if defined(__has_attribute) && defined(__STDC_VERSION__) +# if __has_attribute(always_inline) && __STDC_VERSION__ >= 199901L +# define CURL_FORCEINLINE CURL_INLINE __attribute__((always_inline)) +# endif +# endif +#endif + +#if !defined(CURL_FORCEINLINE) && \ + defined(_MSC_VER) && !defined(__GNUC__) && !defined(__clang__) +#define CURL_FORCEINLINE __forceinline +#endif + +/* Assume that 'CURL_INLINE' keyword works or the + * macro was already defined correctly. */ +#ifndef CURL_FORCEINLINE +#define CURL_FORCEINLINE CURL_INLINE +#endif + +/* Bits manipulation macros and functions. + Can be moved to other headers to reuse. */ + +#define CURL_GET_64BIT_BE(ptr) \ + (((uint64_t)(((const uint8_t *)(ptr))[0]) << 56) | \ + ((uint64_t)(((const uint8_t *)(ptr))[1]) << 48) | \ + ((uint64_t)(((const uint8_t *)(ptr))[2]) << 40) | \ + ((uint64_t)(((const uint8_t *)(ptr))[3]) << 32) | \ + ((uint64_t)(((const uint8_t *)(ptr))[4]) << 24) | \ + ((uint64_t)(((const uint8_t *)(ptr))[5]) << 16) | \ + ((uint64_t)(((const uint8_t *)(ptr))[6]) << 8) | \ + (uint64_t)(((const uint8_t *)(ptr))[7])) + +#define CURL_PUT_64BIT_BE(ptr, val) \ + do { \ + ((uint8_t *)(ptr))[7] = (uint8_t)((uint64_t)(val)); \ + ((uint8_t *)(ptr))[6] = (uint8_t)(((uint64_t)(val)) >> 8); \ + ((uint8_t *)(ptr))[5] = (uint8_t)(((uint64_t)(val)) >> 16); \ + ((uint8_t *)(ptr))[4] = (uint8_t)(((uint64_t)(val)) >> 24); \ + ((uint8_t *)(ptr))[3] = (uint8_t)(((uint64_t)(val)) >> 32); \ + ((uint8_t *)(ptr))[2] = (uint8_t)(((uint64_t)(val)) >> 40); \ + ((uint8_t *)(ptr))[1] = (uint8_t)(((uint64_t)(val)) >> 48); \ + ((uint8_t *)(ptr))[0] = (uint8_t)(((uint64_t)(val)) >> 56); \ + } while(0) + +/* Defined as a function. The macro version may duplicate the binary code + * size as each argument is used twice, so if any calculation is used + * as an argument, the calculation could be done twice. */ +static CURL_FORCEINLINE uint64_t Curl_rotr64(uint64_t value, unsigned int bits) +{ + bits %= 64; + if(bits == 0) + return value; + /* Defined in a form which modern compiler could optimize. */ + return (value >> bits) | (value << (64 - bits)); +} + +/* SHA-512/256 specific data */ + +/** + * Number of bits in a single SHA-512/256 word. + */ +#define SHA512_256_WORD_SIZE_BITS 64 + +/** + * Number of bytes in a single SHA-512/256 word. + */ +#define SHA512_256_BYTES_IN_WORD (SHA512_256_WORD_SIZE_BITS / 8) + +/** + * Hash is kept internally as 8 64-bit words. + * This is the intermediate hash size, used during computing the final digest. + */ +#define SHA512_256_HASH_SIZE_WORDS 8 + +/** + * Size of the SHA-512/256 resulting digest in words. + * This is the final digest size, not intermediate hash. + */ +#define SHA512_256_DIGEST_SIZE_WORDS (SHA512_256_HASH_SIZE_WORDS / 2) + +/** + * Size of the SHA-512/256 resulting digest in bytes + * This is the final digest size, not intermediate hash. + */ +#define CURL_SHA512_256_DIGEST_SIZE \ + (SHA512_256_DIGEST_SIZE_WORDS * SHA512_256_BYTES_IN_WORD) + +/** + * Size of the SHA-512/256 single processing block in bits. + */ +#define SHA512_256_BLOCK_SIZE_BITS 1024 + +/** + * Size of the SHA-512/256 single processing block in bytes. + */ +#define CURL_SHA512_256_BLOCK_SIZE (SHA512_256_BLOCK_SIZE_BITS / 8) + +/** + * Size of the SHA-512/256 single processing block in words. + */ +#define SHA512_256_BLOCK_SIZE_WORDS \ + (SHA512_256_BLOCK_SIZE_BITS / SHA512_256_WORD_SIZE_BITS) + +/** + * SHA-512/256 calculation context + */ +struct Curl_sha512_256ctx { + /** + * Intermediate hash value. The variable is properly aligned. Smart + * compilers may automatically use fast load/store instruction for big + * endian data on little endian machine. + */ + uint64_t H[SHA512_256_HASH_SIZE_WORDS]; + /** + * SHA-512/256 input data buffer. The buffer is properly aligned. Smart + * compilers may automatically use fast load/store instruction for big + * endian data on little endian machine. + */ + uint64_t buffer[SHA512_256_BLOCK_SIZE_WORDS]; + /** + * The number of bytes, lower part + */ + uint64_t count; + /** + * The number of bits, high part. Unlike lower part, this counts the number + * of bits, not bytes. + */ + uint64_t count_bits_hi; +}; + +/** + * Context type used for SHA-512/256 calculations + */ +typedef struct Curl_sha512_256ctx Curl_sha512_256_ctx; + +/** + * Initialize structure for SHA-512/256 calculation. + * + * @param context the calculation context + * @return always CURLE_OK + */ +static CURLcode Curl_sha512_256_init(void *context) +{ + struct Curl_sha512_256ctx * const ctx = (struct Curl_sha512_256ctx *)context; + + /* Check whether the header and this file use the same numbers */ + DEBUGASSERT(CURL_SHA512_256_DIGEST_LENGTH == CURL_SHA512_256_DIGEST_SIZE); + + DEBUGASSERT(sizeof(uint64_t) == 8); + + /* Initial hash values, see FIPS PUB 180-4 section 5.3.6.2 */ + /* Values generated by "IV Generation Function" as described in + * section 5.3.6 */ + ctx->H[0] = UINT64_C(0x22312194FC2BF72C); + ctx->H[1] = UINT64_C(0x9F555FA3C84C64C2); + ctx->H[2] = UINT64_C(0x2393B86B6F53B151); + ctx->H[3] = UINT64_C(0x963877195940EABD); + ctx->H[4] = UINT64_C(0x96283EE2A88EFFE3); + ctx->H[5] = UINT64_C(0xBE5E1E2553863992); + ctx->H[6] = UINT64_C(0x2B0199FC2C85B8AA); + ctx->H[7] = UINT64_C(0x0EB72DDC81C52CA2); + + /* Initialize number of bytes and high part of number of bits. */ + ctx->count = UINT64_C(0); + ctx->count_bits_hi = UINT64_C(0); + + return CURLE_OK; +} + +/** + * Base of the SHA-512/256 transformation. + * Gets a full 128 bytes block of data and updates hash values; + * @param H hash values + * @param data the data buffer with #CURL_SHA512_256_BLOCK_SIZE bytes block + */ +static void Curl_sha512_256_transform(uint64_t H[SHA512_256_HASH_SIZE_WORDS], + const void *data) +{ + /* Working variables, + see FIPS PUB 180-4 section 6.7, 6.4. */ + uint64_t a = H[0]; + uint64_t b = H[1]; + uint64_t c = H[2]; + uint64_t d = H[3]; + uint64_t e = H[4]; + uint64_t f = H[5]; + uint64_t g = H[6]; + uint64_t h = H[7]; + + /* Data buffer, used as a cyclic buffer. + See FIPS PUB 180-4 section 5.2.2, 6.7, 6.4. */ + uint64_t W[16]; + + /* 'Ch' and 'Maj' macro functions are defined with widely-used optimization. + See FIPS PUB 180-4 formulae 4.8, 4.9. */ +#define Sha512_Ch(x, y, z) ((z) ^ ((x) & ((y) ^ (z)))) +#define Sha512_Maj(x, y, z) (((x) & (y)) ^ ((z) & ((x) ^ (y)))) + + /* Four 'Sigma' macro functions. + See FIPS PUB 180-4 formulae 4.10, 4.11, 4.12, 4.13. */ +#define SIG0(x) (Curl_rotr64(x, 28) ^ Curl_rotr64(x, 34) ^ Curl_rotr64(x, 39)) +#define SIG1(x) (Curl_rotr64(x, 14) ^ Curl_rotr64(x, 18) ^ Curl_rotr64(x, 41)) +#define sig0(x) (Curl_rotr64(x, 1) ^ Curl_rotr64(x, 8) ^ ((x) >> 7)) +#define sig1(x) (Curl_rotr64(x, 19) ^ Curl_rotr64(x, 61) ^ ((x) >> 6)) + + if(1) { + unsigned int t; + /* K constants array. + See FIPS PUB 180-4 section 4.2.3 for K values. */ + static const uint64_t K[80] = { + UINT64_C(0x428a2f98d728ae22), UINT64_C(0x7137449123ef65cd), + UINT64_C(0xb5c0fbcfec4d3b2f), UINT64_C(0xe9b5dba58189dbbc), + UINT64_C(0x3956c25bf348b538), UINT64_C(0x59f111f1b605d019), + UINT64_C(0x923f82a4af194f9b), UINT64_C(0xab1c5ed5da6d8118), + UINT64_C(0xd807aa98a3030242), UINT64_C(0x12835b0145706fbe), + UINT64_C(0x243185be4ee4b28c), UINT64_C(0x550c7dc3d5ffb4e2), + UINT64_C(0x72be5d74f27b896f), UINT64_C(0x80deb1fe3b1696b1), + UINT64_C(0x9bdc06a725c71235), UINT64_C(0xc19bf174cf692694), + UINT64_C(0xe49b69c19ef14ad2), UINT64_C(0xefbe4786384f25e3), + UINT64_C(0x0fc19dc68b8cd5b5), UINT64_C(0x240ca1cc77ac9c65), + UINT64_C(0x2de92c6f592b0275), UINT64_C(0x4a7484aa6ea6e483), + UINT64_C(0x5cb0a9dcbd41fbd4), UINT64_C(0x76f988da831153b5), + UINT64_C(0x983e5152ee66dfab), UINT64_C(0xa831c66d2db43210), + UINT64_C(0xb00327c898fb213f), UINT64_C(0xbf597fc7beef0ee4), + UINT64_C(0xc6e00bf33da88fc2), UINT64_C(0xd5a79147930aa725), + UINT64_C(0x06ca6351e003826f), UINT64_C(0x142929670a0e6e70), + UINT64_C(0x27b70a8546d22ffc), UINT64_C(0x2e1b21385c26c926), + UINT64_C(0x4d2c6dfc5ac42aed), UINT64_C(0x53380d139d95b3df), + UINT64_C(0x650a73548baf63de), UINT64_C(0x766a0abb3c77b2a8), + UINT64_C(0x81c2c92e47edaee6), UINT64_C(0x92722c851482353b), + UINT64_C(0xa2bfe8a14cf10364), UINT64_C(0xa81a664bbc423001), + UINT64_C(0xc24b8b70d0f89791), UINT64_C(0xc76c51a30654be30), + UINT64_C(0xd192e819d6ef5218), UINT64_C(0xd69906245565a910), + UINT64_C(0xf40e35855771202a), UINT64_C(0x106aa07032bbd1b8), + UINT64_C(0x19a4c116b8d2d0c8), UINT64_C(0x1e376c085141ab53), + UINT64_C(0x2748774cdf8eeb99), UINT64_C(0x34b0bcb5e19b48a8), + UINT64_C(0x391c0cb3c5c95a63), UINT64_C(0x4ed8aa4ae3418acb), + UINT64_C(0x5b9cca4f7763e373), UINT64_C(0x682e6ff3d6b2b8a3), + UINT64_C(0x748f82ee5defb2fc), UINT64_C(0x78a5636f43172f60), + UINT64_C(0x84c87814a1f0ab72), UINT64_C(0x8cc702081a6439ec), + UINT64_C(0x90befffa23631e28), UINT64_C(0xa4506cebde82bde9), + UINT64_C(0xbef9a3f7b2c67915), UINT64_C(0xc67178f2e372532b), + UINT64_C(0xca273eceea26619c), UINT64_C(0xd186b8c721c0c207), + UINT64_C(0xeada7dd6cde0eb1e), UINT64_C(0xf57d4f7fee6ed178), + UINT64_C(0x06f067aa72176fba), UINT64_C(0x0a637dc5a2c898a6), + UINT64_C(0x113f9804bef90dae), UINT64_C(0x1b710b35131c471b), + UINT64_C(0x28db77f523047d84), UINT64_C(0x32caab7b40c72493), + UINT64_C(0x3c9ebe0a15c9bebc), UINT64_C(0x431d67c49c100d4c), + UINT64_C(0x4cc5d4becb3e42b6), UINT64_C(0x597f299cfc657e2a), + UINT64_C(0x5fcb6fab3ad6faec), UINT64_C(0x6c44198c4a475817) + }; + + /* One step of SHA-512/256 computation, + see FIPS PUB 180-4 section 6.4.2 step 3. + * Note: this macro updates working variables in-place, without rotation. + * Note: the first (vH += SIG1(vE) + Ch(vE,vF,vG) + kt + wt) equals T1 in + FIPS PUB 180-4 section 6.4.2 step 3. + the second (vH += SIG0(vA) + Maj(vE,vF,vC) equals T1 + T2 in + FIPS PUB 180-4 section 6.4.2 step 3. + * Note: 'wt' must be used exactly one time in this macro as macro for + 'wt' calculation may change other data as well every time when + used. */ +#define SHA2STEP64(vA, vB, vC, vD, vE, vF, vG, vH, kt, wt) \ + do { \ + (vD) += ((vH) += SIG1(vE) + Sha512_Ch(vE, vF, vG) + (kt) + (wt)); \ + (vH) += SIG0(vA) + Sha512_Maj(vA, vB, vC); \ + } while(0) + + /* One step of SHA-512/256 computation with working variables rotation, + see FIPS PUB 180-4 section 6.4.2 step 3. This macro version reassigns + all working variables on each step. */ +#define SHA2STEP64RV(vA, vB, vC, vD, vE, vF, vG, vH, kt, wt) \ + do { \ + uint64_t tmp_h_ = (vH); \ + SHA2STEP64(vA, vB, vC, vD, vE, vF, vG, tmp_h_, kt, wt); \ + (vH) = (vG); \ + (vG) = (vF); \ + (vF) = (vE); \ + (vE) = (vD); \ + (vD) = (vC); \ + (vC) = (vB); \ + (vB) = (vA); \ + (vA) = tmp_h_; \ + } while(0) + + /* Get value of W(t) from input data buffer for 0 <= t <= 15, + See FIPS PUB 180-4 section 6.2. + Input data must be read in big-endian bytes order, + see FIPS PUB 180-4 section 3.1.2. */ +#define SHA512_GET_W_FROM_DATA(buf, t) \ + CURL_GET_64BIT_BE((const uint8_t *)(buf) + ((t) * SHA512_256_BYTES_IN_WORD)) + + /* During first 16 steps, before making any calculation on each step, the + W element is read from the input data buffer as a big-endian value and + stored in the array of W elements. */ + for(t = 0; t < 16; ++t) { + SHA2STEP64RV(a, b, c, d, e, f, g, h, K[t], + W[t] = SHA512_GET_W_FROM_DATA(data, t)); + } + + /* 'W' generation and assignment for 16 <= t <= 79. + See FIPS PUB 180-4 section 6.4.2. + As only the last 16 'W' are used in calculations, it is possible to + use 16 elements array of W as a cyclic buffer. + Note: ((t-16) & 15) have same value as (t & 15) */ +#define Wgen(w, t) \ + (uint64_t)((w)[((t) - 16) & 15] + sig1((w)[((t) - 2) & 15]) + \ + (w)[((t) - 7) & 15] + sig0((w)[((t) - 15) & 15])) + + /* During the last 64 steps, before making any calculation on each step, + current W element is generated from other W elements of the cyclic + buffer and the generated value is stored back in the cyclic buffer. */ + for(t = 16; t < 80; ++t) { + SHA2STEP64RV(a, b, c, d, e, f, g, h, K[t], + W[t & 15] = Wgen(W, t)); + } + } + + /* Compute and store the intermediate hash. + See FIPS PUB 180-4 section 6.4.2 step 4. */ + H[0] += a; + H[1] += b; + H[2] += c; + H[3] += d; + H[4] += e; + H[5] += f; + H[6] += g; + H[7] += h; +} + +/** + * Process portion of bytes. + * + * @param context the calculation context + * @param data bytes to add to hash + * @param length number of bytes in @a data + * @return always CURLE_OK + */ +static CURLcode Curl_sha512_256_update(void *context, + const unsigned char *data, + size_t length) +{ + unsigned int bytes_have; /* Number of bytes in the context buffer */ + struct Curl_sha512_256ctx * const ctx = (struct Curl_sha512_256ctx *)context; + /* the void pointer here is required to mute Intel compiler warning */ + void * const ctx_buf = ctx->buffer; + + DEBUGASSERT(data || (length == 0)); + + if(length == 0) + return CURLE_OK; /* Shortcut, do nothing */ + + /* Note: (count & (CURL_SHA512_256_BLOCK_SIZE-1)) + equals (count % CURL_SHA512_256_BLOCK_SIZE) for this block size. */ + bytes_have = (unsigned int)(ctx->count & (CURL_SHA512_256_BLOCK_SIZE - 1)); + ctx->count += length; + if(length > ctx->count) + ctx->count_bits_hi += 1U << 3; /* Value wrap */ + ctx->count_bits_hi += ctx->count >> 61; + ctx->count &= UINT64_C(0x1FFFFFFFFFFFFFFF); + + if(bytes_have) { + unsigned int bytes_left = CURL_SHA512_256_BLOCK_SIZE - bytes_have; + if(length >= bytes_left) { + /* Combine new data with data in the buffer and process the full + block. */ + memcpy((unsigned char *)ctx_buf + bytes_have, data, bytes_left); + data += bytes_left; + length -= bytes_left; + Curl_sha512_256_transform(ctx->H, ctx->buffer); + bytes_have = 0; + } + } + + while(CURL_SHA512_256_BLOCK_SIZE <= length) { + /* Process any full blocks of new data directly, + without copying to the buffer. */ + Curl_sha512_256_transform(ctx->H, data); + data += CURL_SHA512_256_BLOCK_SIZE; + length -= CURL_SHA512_256_BLOCK_SIZE; + } + + if(length) { + /* Copy incomplete block of new data (if any) + to the buffer. */ + memcpy((unsigned char *)ctx_buf + bytes_have, data, length); + } + + return CURLE_OK; +} + +/** + * Size of "length" insertion in bits. + * See FIPS PUB 180-4 section 5.1.2. + */ +#define SHA512_256_SIZE_OF_LEN_ADD_BITS 128 + +/** + * Size of "length" insertion in bytes. + */ +#define SHA512_256_SIZE_OF_LEN_ADD (SHA512_256_SIZE_OF_LEN_ADD_BITS / 8) + +/** + * Finalise SHA-512/256 calculation, return digest. + * + * @param context the calculation context + * @param[out] digest set to the hash, must be #CURL_SHA512_256_DIGEST_SIZE + * bytes + * @return always CURLE_OK + */ +static CURLcode Curl_sha512_256_finish(unsigned char *digest, void *context) +{ + struct Curl_sha512_256ctx * const ctx = (struct Curl_sha512_256ctx *)context; + uint64_t num_bits; /* Number of processed bits */ + unsigned int bytes_have; /* Number of bytes in the context buffer */ + /* the void pointer here is required to mute Intel compiler warning */ + void * const ctx_buf = ctx->buffer; + + /* Memorise the number of processed bits. + The padding and other data added here during the postprocessing must + not change the amount of hashed data. */ + num_bits = ctx->count << 3; + + /* Note: (count & (CURL_SHA512_256_BLOCK_SIZE-1)) + equals (count % CURL_SHA512_256_BLOCK_SIZE) for this block size. */ + bytes_have = (unsigned int)(ctx->count & (CURL_SHA512_256_BLOCK_SIZE - 1)); + + /* Input data must be padded with a single bit "1", then with zeros and + the finally the length of data in bits must be added as the final bytes + of the last block. + See FIPS PUB 180-4 section 5.1.2. */ + + /* Data is always processed in form of bytes (not by individual bits), + therefore position of the first padding bit in byte is always + predefined (0x80). */ + /* Buffer always have space at least for one byte (as full buffers are + processed when formed). */ + ((unsigned char *)ctx_buf)[bytes_have++] = 0x80U; + + if(CURL_SHA512_256_BLOCK_SIZE - bytes_have < SHA512_256_SIZE_OF_LEN_ADD) { + /* No space in the current block to put the total length of message. + Pad the current block with zeros and process it. */ + if(bytes_have < CURL_SHA512_256_BLOCK_SIZE) + memset((unsigned char *)ctx_buf + bytes_have, 0, + CURL_SHA512_256_BLOCK_SIZE - bytes_have); + /* Process the full block. */ + Curl_sha512_256_transform(ctx->H, ctx->buffer); + /* Start the new block. */ + bytes_have = 0; + } + + /* Pad the rest of the buffer with zeros. */ + memset((unsigned char *)ctx_buf + bytes_have, 0, + CURL_SHA512_256_BLOCK_SIZE - SHA512_256_SIZE_OF_LEN_ADD - bytes_have); + /* Put high part of number of bits in processed message and then lower + part of number of bits as big-endian values. + See FIPS PUB 180-4 section 5.1.2. */ + /* Note: the target location is predefined and buffer is always aligned */ + CURL_PUT_64BIT_BE((unsigned char *)ctx_buf + + CURL_SHA512_256_BLOCK_SIZE - SHA512_256_SIZE_OF_LEN_ADD, + ctx->count_bits_hi); + CURL_PUT_64BIT_BE((unsigned char *)ctx_buf + + CURL_SHA512_256_BLOCK_SIZE - SHA512_256_SIZE_OF_LEN_ADD + + SHA512_256_BYTES_IN_WORD, + num_bits); + /* Process the full final block. */ + Curl_sha512_256_transform(ctx->H, ctx->buffer); + + /* Put in BE mode the leftmost part of the hash as the final digest. + See FIPS PUB 180-4 section 6.7. */ + + CURL_PUT_64BIT_BE(digest + (0 * SHA512_256_BYTES_IN_WORD), ctx->H[0]); + CURL_PUT_64BIT_BE(digest + (1 * SHA512_256_BYTES_IN_WORD), ctx->H[1]); + CURL_PUT_64BIT_BE(digest + (2 * SHA512_256_BYTES_IN_WORD), ctx->H[2]); + CURL_PUT_64BIT_BE(digest + (3 * SHA512_256_BYTES_IN_WORD), ctx->H[3]); + + /* Erase potentially sensitive data. */ + memset(ctx, 0, sizeof(struct Curl_sha512_256ctx)); + + return CURLE_OK; +} + +#endif /* Local SHA-512/256 code */ + +/** + * Compute SHA-512/256 hash for the given data in one function call + * @param[out] output the pointer to put the hash + * @param[in] input the pointer to the data to process + * @param input_size the size of the data pointed by @a input + * @return always #CURLE_OK + */ +CURLcode Curl_sha512_256it(unsigned char *output, const unsigned char *input, + size_t input_size) +{ + Curl_sha512_256_ctx ctx; + CURLcode result; + + result = Curl_sha512_256_init(&ctx); + if(result != CURLE_OK) + return result; + + result = Curl_sha512_256_update(&ctx, (const void *)input, input_size); + + if(result != CURLE_OK) { + (void)Curl_sha512_256_finish(output, &ctx); + return result; + } + + return Curl_sha512_256_finish(output, &ctx); +} + +/* Wrapper function, takes 'unsigned int' as length type, returns void */ +static void Curl_sha512_256_update_i(void *context, + const unsigned char *data, + unsigned int length) +{ + /* Hypothetically the function may fail, but assume it does not */ + (void)Curl_sha512_256_update(context, data, length); +} + +/* Wrapper function, returns void */ +static void Curl_sha512_256_finish_v(unsigned char *result, void *context) +{ + /* Hypothetically the function may fail, but assume it does not */ + (void)Curl_sha512_256_finish(result, context); +} + +/* Wrapper function, takes 'unsigned int' as length type, returns void */ + +const struct HMAC_params Curl_HMAC_SHA512_256[] = { + { + /* Initialize context procedure. */ + Curl_sha512_256_init, + /* Update context with data. */ + Curl_sha512_256_update_i, + /* Get final result procedure. */ + Curl_sha512_256_finish_v, + /* Context structure size. */ + sizeof(Curl_sha512_256_ctx), + /* Maximum key length (bytes). */ + CURL_SHA512_256_BLOCK_SIZE, + /* Result length (bytes). */ + CURL_SHA512_256_DIGEST_SIZE + } +}; + +#endif /* !CURL_DISABLE_DIGEST_AUTH && !CURL_DISABLE_SHA512_256 */ diff --git a/3rdparty/curl-8.21.0/lib/curl_sha512_256.h b/3rdparty/curl-8.21.0/lib/curl_sha512_256.h new file mode 100644 index 0000000000..ddaf8be91d --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_sha512_256.h @@ -0,0 +1,43 @@ +#ifndef HEADER_CURL_SHA512_256_H +#define HEADER_CURL_SHA512_256_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Evgeny Grin (Karlson2k), . + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_DIGEST_AUTH) && !defined(CURL_DISABLE_SHA512_256) + +#include "curl_hmac.h" + +#define CURL_HAVE_SHA512_256 + +extern const struct HMAC_params Curl_HMAC_SHA512_256[1]; + +#define CURL_SHA512_256_DIGEST_LENGTH 32 + +CURLcode Curl_sha512_256it(unsigned char *output, const unsigned char *input, + size_t input_size); + +#endif /* !CURL_DISABLE_DIGEST_AUTH && !CURL_DISABLE_SHA512_256 */ + +#endif /* HEADER_CURL_SHA256_H */ diff --git a/3rdparty/curl-8.21.0/lib/curl_share.c b/3rdparty/curl-8.21.0/lib/curl_share.c new file mode 100644 index 0000000000..94469bc3ef --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_share.c @@ -0,0 +1,472 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "urldata.h" +#include "multiif.h" +#include "curl_threads.h" +#include "curl_share.h" +#include "vtls/vtls.h" +#include "vtls/vtls_scache.h" +#include "hsts.h" +#include "url.h" + +static void share_destroy(struct Curl_share *share) +{ + if(share->specifier & (1 << CURL_LOCK_DATA_CONNECT)) { + Curl_cpool_destroy(&share->cpool); + } + + Curl_dnscache_destroy(&share->dnscache); + +#if !defined(CURL_DISABLE_HTTP) && !defined(CURL_DISABLE_COOKIES) + Curl_cookie_cleanup(share->cookies); +#endif + +#ifndef CURL_DISABLE_HSTS + Curl_hsts_cleanup(&share->hsts); +#endif + +#ifdef USE_SSL + if(share->ssl_scache) { + Curl_ssl_scache_destroy(share->ssl_scache); + share->ssl_scache = NULL; + } +#endif + + Curl_psl_destroy(&share->psl); + Curl_close(&share->admin); + +#ifdef USE_MUTEX + Curl_mutex_destroy(&share->lock); +#endif + share->magic = 0; + curlx_free(share); +} + +CURLSH *curl_share_init(void) +{ + struct Curl_share *share = curlx_calloc(1, sizeof(struct Curl_share)); + if(share) { + share->magic = CURL_GOOD_SHARE; + share->specifier |= (1 << CURL_LOCK_DATA_SHARE); +#ifdef USE_MUTEX + Curl_mutex_init(&share->lock); +#endif + share->ref_count = 1; + Curl_dnscache_init(&share->dnscache, 23); + share->admin = curl_easy_init(); + if(!share->admin) { + share_destroy(share); + return NULL; + } + /* admin handles have mid 0 */ + share->admin->mid = 0; + share->admin->state.internal = TRUE; +#ifdef DEBUGBUILD + if(getenv("CURL_DEBUG")) + share->admin->set.verbose = TRUE; +#endif + } + return share; +} + +static uint32_t share_ref_inc(struct Curl_share *share) +{ + uint32_t n; +#ifdef USE_MUTEX + Curl_mutex_acquire(&share->lock); + n = ++(share->ref_count); + share->has_been_shared = TRUE; + Curl_mutex_release(&share->lock); +#else + n = ++(share->ref_count); + share->has_been_shared = TRUE; +#endif + return n; +} + +static uint32_t share_ref_dec(struct Curl_share *share) +{ + uint32_t n; +#ifdef USE_MUTEX + Curl_mutex_acquire(&share->lock); + DEBUGASSERT(share->ref_count); + n = --(share->ref_count); + Curl_mutex_release(&share->lock); +#else + n = --(share->ref_count); +#endif + return n; +} + +static bool share_has_been_shared(struct Curl_share *share) +{ + bool was_shared; +#ifdef USE_MUTEX + Curl_mutex_acquire(&share->lock); + was_shared = share->has_been_shared; + Curl_mutex_release(&share->lock); +#else + was_shared = share->has_been_shared; +#endif + return was_shared; +} + +static bool share_lock_acquire(struct Curl_share *share, + struct Curl_easy *data) +{ + if(share->lockfunc && share->unlockfunc && + (data || share_has_been_shared(share))) { + share->lockfunc(data, CURL_LOCK_DATA_SHARE, CURL_LOCK_ACCESS_SINGLE, + share->clientdata); + return TRUE; + } + return FALSE; +} + +static void share_lock_release(struct Curl_share *share, + struct Curl_easy *data, + bool locked) +{ + if(locked) { + DEBUGASSERT(share->unlockfunc); + if(share->unlockfunc) + share->unlockfunc(data, CURL_LOCK_DATA_SHARE, share->clientdata); + } +} + +static bool share_in_use(struct Curl_share *share) +{ + bool in_use; +#ifdef USE_MUTEX + Curl_mutex_acquire(&share->lock); + in_use = (share->ref_count > 1); + Curl_mutex_release(&share->lock); +#else + bool locked = share_lock_acquire(share, NULL); + in_use = (share->ref_count > 1); + share_lock_release(share, NULL, locked); +#endif + return in_use; +} + +static void share_unlink(struct Curl_share **pshare, + struct Curl_easy *data, + bool locked) +{ + struct Curl_share *share = *pshare; + uint32_t n; + + *pshare = NULL; + n = share_ref_dec(share); + if(locked) + share_lock_release(share, data, locked); + if(!n) /* last reference gone */ + share_destroy(share); +} + +#undef curl_share_setopt +CURLSHcode curl_share_setopt(CURLSH *sh, CURLSHoption option, ...) +{ + va_list param; + int type; + curl_lock_function lockfunc; + curl_unlock_function unlockfunc; + void *ptr; + CURLSHcode res = CURLSHE_OK; + struct Curl_share *share = sh; + + if(!GOOD_SHARE_HANDLE(share)) + return CURLSHE_INVALID; + + if(share_in_use(share)) { + /* do not allow setting options while one or more handles are already + using this share */ + return CURLSHE_IN_USE; + } + + va_start(param, option); + + switch(option) { + case CURLSHOPT_SHARE: + /* this is a type this share will share */ + type = va_arg(param, int); + + switch(type) { + case CURL_LOCK_DATA_DNS: + break; + + case CURL_LOCK_DATA_COOKIE: +#if !defined(CURL_DISABLE_HTTP) && !defined(CURL_DISABLE_COOKIES) + if(!share->cookies) { + share->cookies = Curl_cookie_init(); + if(!share->cookies) + res = CURLSHE_NOMEM; + } +#else /* CURL_DISABLE_HTTP || CURL_DISABLE_COOKIES */ + res = CURLSHE_NOT_BUILT_IN; +#endif + break; + + case CURL_LOCK_DATA_HSTS: +#ifndef CURL_DISABLE_HSTS + if(!share->hsts) { + share->hsts = Curl_hsts_init(); + if(!share->hsts) + res = CURLSHE_NOMEM; + } +#else /* CURL_DISABLE_HSTS */ + res = CURLSHE_NOT_BUILT_IN; +#endif + break; + + case CURL_LOCK_DATA_SSL_SESSION: +#ifdef USE_SSL + if(!share->ssl_scache) { + /* There is no way (yet) for the application to configure the + * session cache size, shared between many transfers. As for curl + * itself, a high session count will impact startup time. Also, the + * scache is not optimized for several hundreds of peers. + * Keep it at a reasonable level. */ + if(Curl_ssl_scache_create(25, 2, &share->ssl_scache)) + res = CURLSHE_NOMEM; + } +#else + res = CURLSHE_NOT_BUILT_IN; +#endif + break; + + case CURL_LOCK_DATA_CONNECT: + /* It is safe to set this option several times on a share. */ + if(!share->cpool.initialized) { + Curl_cpool_init(&share->cpool, share->admin, share, 103); + } + break; + + case CURL_LOCK_DATA_PSL: +#ifndef USE_LIBPSL + res = CURLSHE_NOT_BUILT_IN; +#endif + break; + + default: + res = CURLSHE_BAD_OPTION; + } + if(!res) + share->specifier |= (unsigned int)(1 << type); + break; + + case CURLSHOPT_UNSHARE: + /* this is a type this share will no longer share */ + type = va_arg(param, int); + switch(type) { + case CURL_LOCK_DATA_DNS: + break; + + case CURL_LOCK_DATA_COOKIE: +#if !defined(CURL_DISABLE_HTTP) && !defined(CURL_DISABLE_COOKIES) + if(share->cookies) { + Curl_cookie_cleanup(share->cookies); + share->cookies = NULL; + } +#else /* CURL_DISABLE_HTTP || CURL_DISABLE_COOKIES */ + res = CURLSHE_NOT_BUILT_IN; +#endif + break; + + case CURL_LOCK_DATA_HSTS: +#ifndef CURL_DISABLE_HSTS + if(share->hsts) { + Curl_hsts_cleanup(&share->hsts); + } +#else /* CURL_DISABLE_HSTS */ + res = CURLSHE_NOT_BUILT_IN; +#endif + break; + + case CURL_LOCK_DATA_SSL_SESSION: +#ifdef USE_SSL + if(share->ssl_scache) { + Curl_ssl_scache_destroy(share->ssl_scache); + share->ssl_scache = NULL; + } +#else + res = CURLSHE_NOT_BUILT_IN; +#endif + break; + + case CURL_LOCK_DATA_CONNECT: + break; + + default: + res = CURLSHE_BAD_OPTION; + break; + } + if(!res) + share->specifier &= ~(unsigned int)(1 << type); + break; + + case CURLSHOPT_LOCKFUNC: + lockfunc = va_arg(param, curl_lock_function); + share->lockfunc = lockfunc; + break; + + case CURLSHOPT_UNLOCKFUNC: + unlockfunc = va_arg(param, curl_unlock_function); + share->unlockfunc = unlockfunc; + break; + + case CURLSHOPT_USERDATA: + ptr = va_arg(param, void *); + share->clientdata = ptr; + break; + + default: + res = CURLSHE_BAD_OPTION; + break; + } + + va_end(param); + + return res; +} + +CURLSHcode curl_share_cleanup(CURLSH *sh) +{ + struct Curl_share *share = sh; + bool locked; + if(!GOOD_SHARE_HANDLE(share)) + return CURLSHE_INVALID; + + if(share_in_use(share)) + return CURLSHE_IN_USE; + + locked = share_lock_acquire(share, NULL); + share_unlink(&share, NULL, locked); + return CURLSHE_OK; +} + +CURLSHcode Curl_share_lock(struct Curl_easy *data, curl_lock_data type, + curl_lock_access accesstype) +{ + struct Curl_share *share = data->share; + + if(!share) + return CURLSHE_INVALID; + + if(share->specifier & (unsigned int)(1 << type)) { + if(share->lockfunc) /* only call this if set! */ + share->lockfunc(data, type, accesstype, share->clientdata); + } + /* else if we do not share this, pretend successful lock */ + + return CURLSHE_OK; +} + +CURLSHcode Curl_share_unlock(struct Curl_easy *data, curl_lock_data type) +{ + struct Curl_share *share = data->share; + + if(!share) + return CURLSHE_INVALID; + + if(share->specifier & (unsigned int)(1 << type)) { + if(share->unlockfunc) /* only call this if set! */ + share->unlockfunc(data, type, share->clientdata); + } + + return CURLSHE_OK; +} + +CURLcode Curl_share_easy_unlink(struct Curl_easy *data) +{ + struct Curl_share *share = data->share; + + if(share) { + bool locked = share_lock_acquire(share, data); + + /* If data has a connection from this share, detach it. */ + if(data->conn && (share->specifier & (1 << CURL_LOCK_DATA_CONNECT))) + Curl_detach_connection(data); + +#if !defined(CURL_DISABLE_HTTP) && !defined(CURL_DISABLE_COOKIES) + if(share->cookies == data->cookies) + data->cookies = NULL; +#endif + +#ifndef CURL_DISABLE_HSTS + if(share->hsts == data->hsts) + data->hsts = NULL; +#endif +#ifdef USE_LIBPSL + if(&share->psl == data->psl) + data->psl = data->multi ? &data->multi->psl : NULL; +#endif + + share_unlink(&data->share, data, locked); + } + return CURLE_OK; +} + +CURLcode Curl_share_easy_link(struct Curl_easy *data, + struct Curl_share *share) +{ + if(data->share) { + DEBUGASSERT(0); + return CURLE_FAILED_INIT; + } + + if(share) { + bool locked = share_lock_acquire(share, data); + + share_ref_inc(share); + data->share = share; + +#if !defined(CURL_DISABLE_HTTP) && !defined(CURL_DISABLE_COOKIES) + if(share->cookies) { + /* use shared cookie list, first free own one if any */ + Curl_cookie_cleanup(data->cookies); + /* enable cookies since we now use a share that uses cookies! */ + data->cookies = share->cookies; + } +#endif /* CURL_DISABLE_HTTP */ +#ifndef CURL_DISABLE_HSTS + if(share->hsts) { + /* first free the private one if any */ + Curl_hsts_cleanup(&data->hsts); + data->hsts = share->hsts; + } +#endif +#ifdef USE_LIBPSL + if(share->specifier & (1 << CURL_LOCK_DATA_PSL)) + data->psl = &share->psl; +#endif + + /* check for host cache not needed, + * it will be done by curl_easy_perform */ + share_lock_release(share, data, locked); + } + return CURLE_OK; +} diff --git a/3rdparty/curl-8.21.0/lib/curl_share.h b/3rdparty/curl-8.21.0/lib/curl_share.h new file mode 100644 index 0000000000..1d49a8d1dd --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_share.h @@ -0,0 +1,92 @@ +#ifndef HEADER_CURL_SHARE_H +#define HEADER_CURL_SHARE_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "curl_threads.h" +#include "cookie.h" +#include "psl.h" +#include "urldata.h" +#include "conncache.h" + +struct Curl_easy; +struct Curl_ssl_scache; + +#define CURL_GOOD_SHARE 0x7e117a1e +#define GOOD_SHARE_HANDLE(x) ((x) && (x)->magic == CURL_GOOD_SHARE) + +#define CURL_SHARE_KEEP_CONNECT(s) \ + ((s) && ((s)->specifier & (1 << CURL_LOCK_DATA_CONNECT))) + +/* this struct is libcurl-private, do not export details */ +struct Curl_share { + unsigned int magic; /* CURL_GOOD_SHARE */ + unsigned int specifier; + + uint32_t ref_count; +#ifdef USE_MUTEX + /* do `ref_count` and `has_been_shared` checks using this mutex. */ + curl_mutex_t lock; + int has_been_shared; +#else + /* this only ever goes from FALSE -> TRUE once. We need to check + * this without being able to use the `lockfunc`. */ + volatile int has_been_shared; +#endif + curl_lock_function lockfunc; + curl_unlock_function unlockfunc; + void *clientdata; + struct Curl_easy *admin; + + struct cpool cpool; + struct Curl_dnscache dnscache; /* DNS cache */ +#if !defined(CURL_DISABLE_HTTP) && !defined(CURL_DISABLE_COOKIES) + struct CookieInfo *cookies; +#endif +#ifdef USE_LIBPSL + struct PslCache psl; +#endif +#ifndef CURL_DISABLE_HSTS + struct hsts *hsts; +#endif +#ifdef USE_SSL + struct Curl_ssl_scache *ssl_scache; +#endif +}; + +CURLSHcode Curl_share_lock(struct Curl_easy *data, curl_lock_data type, + curl_lock_access accesstype); +CURLSHcode Curl_share_unlock(struct Curl_easy *data, curl_lock_data type); + +/* convenience macro to check if this handle is using a shared SSL spool */ +#define CURL_SHARE_ssl_scache(data) \ + ((data)->share && \ + ((data)->share->specifier & (1 << CURL_LOCK_DATA_SSL_SESSION))) + +CURLcode Curl_share_easy_unlink(struct Curl_easy *data); +CURLcode Curl_share_easy_link(struct Curl_easy *data, + struct Curl_share *share); + +#endif /* HEADER_CURL_SHARE_H */ diff --git a/3rdparty/curl-8.21.0/lib/curl_sspi.c b/3rdparty/curl-8.21.0/lib/curl_sspi.c new file mode 100644 index 0000000000..3ea17621b1 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_sspi.c @@ -0,0 +1,207 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_WINDOWS_SSPI + +#include "curl_sspi.h" +#include "curlx/strdup.h" +#include "curlx/multibyte.h" + +/* Pointer to SSPI dispatch table */ +PSecurityFunctionTable Curl_pSecFn = NULL; + +/* + * Curl_sspi_global_init() + * + * This is used to load the Security Service Provider Interface (SSPI) + * dynamic link library portably across all Windows versions, without + * the need to directly link libcurl, nor the application using it, at + * build time. + * + * Once this function has been executed, Windows SSPI functions can be + * called through the Security Service Provider Interface dispatch table. + * + * Parameters: + * + * None. + * + * Returns CURLE_OK on success. + */ +CURLcode Curl_sspi_global_init(void) +{ + /* If security interface is not yet initialized try to do this */ + if(!Curl_pSecFn) { + /* Get pointer to Security Service Provider Interface dispatch table */ + Curl_pSecFn = InitSecurityInterface(); + if(!Curl_pSecFn) + return CURLE_FAILED_INIT; + } + + return CURLE_OK; +} + +/* + * Curl_sspi_global_cleanup() + * + * This deinitializes the Security Service Provider Interface from libcurl. + * + * Parameters: + * + * None. + */ +void Curl_sspi_global_cleanup(void) +{ + if(Curl_pSecFn) { + Curl_pSecFn = NULL; + } +} + +/* + * Curl_create_sspi_identity() + * + * This is used to populate an SSPI identity structure based on the supplied + * username and password. + * + * Parameters: + * + * userp [in] - The username in the format User or Domain\User. + * passwdp [in] - The user's password. + * identity [in/out] - The identity structure. + * + * Returns CURLE_OK on success. + */ +CURLcode Curl_create_sspi_identity(const char *userp, const char *passwdp, + SEC_WINNT_AUTH_IDENTITY *identity) +{ + xcharp_u useranddomain; + xcharp_u user, dup_user; + xcharp_u domain, dup_domain; + xcharp_u passwd, dup_passwd; + size_t domlen = 0; + + domain.const_tchar_ptr = TEXT(""); + + /* Initialize the identity */ + memset(identity, 0, sizeof(*identity)); + + useranddomain.tchar_ptr = curlx_convert_UTF8_to_tchar(userp); + if(!useranddomain.tchar_ptr) + return CURLE_OUT_OF_MEMORY; + + user.const_tchar_ptr = _tcschr(useranddomain.const_tchar_ptr, TEXT('\\')); + if(!user.const_tchar_ptr) + user.const_tchar_ptr = _tcschr(useranddomain.const_tchar_ptr, TEXT('/')); + + if(user.tchar_ptr) { + domain.tchar_ptr = useranddomain.tchar_ptr; + domlen = user.tchar_ptr - useranddomain.tchar_ptr; + user.tchar_ptr++; + } + else { + user.tchar_ptr = useranddomain.tchar_ptr; + domain.const_tchar_ptr = TEXT(""); + domlen = 0; + } + + /* Setup the identity's user and length */ + dup_user.tchar_ptr = curlx_tcsdup(user.tchar_ptr); + if(!dup_user.tchar_ptr) { + curlx_free(useranddomain.tchar_ptr); + return CURLE_OUT_OF_MEMORY; + } + + /* Setup the identity's domain and length */ + dup_domain.tchar_ptr = curlx_malloc(sizeof(TCHAR) * (domlen + 1)); + if(!dup_domain.tchar_ptr) { + curlx_free(dup_user.tchar_ptr); + curlx_free(useranddomain.tchar_ptr); + return CURLE_OUT_OF_MEMORY; + } + if(_tcsncpy_s(dup_domain.tchar_ptr, domlen + 1, domain.tchar_ptr, domlen)) { + curlx_free(dup_user.tchar_ptr); + curlx_free(dup_domain.tchar_ptr); + curlx_free(useranddomain.tchar_ptr); + return CURLE_OUT_OF_MEMORY; + } + + curlx_free(useranddomain.tchar_ptr); + + /* Setup the identity's password and length */ + passwd.tchar_ptr = curlx_convert_UTF8_to_tchar(passwdp); + if(!passwd.tchar_ptr) { + curlx_free(dup_user.tchar_ptr); + curlx_free(dup_domain.tchar_ptr); + return CURLE_OUT_OF_MEMORY; + } + dup_passwd.tchar_ptr = curlx_tcsdup(passwd.tchar_ptr); + if(!dup_passwd.tchar_ptr) { + curlx_free(dup_user.tchar_ptr); + curlx_free(dup_domain.tchar_ptr); + curlx_free(passwd.tchar_ptr); + return CURLE_OUT_OF_MEMORY; + } + identity->Password = dup_passwd.tbyte_ptr; + identity->PasswordLength = curlx_uztoul(_tcslen(dup_passwd.tchar_ptr)); + dup_passwd.tchar_ptr = NULL; + + curlx_free(passwd.tchar_ptr); + + identity->User = dup_user.tbyte_ptr; + identity->UserLength = curlx_uztoul(_tcslen(dup_user.tchar_ptr)); + dup_user.tchar_ptr = NULL; + identity->Domain = dup_domain.tbyte_ptr; + identity->DomainLength = curlx_uztoul(domlen); + dup_domain.tchar_ptr = NULL; + + /* Setup the identity's flags */ + identity->Flags = (unsigned long) +#ifdef UNICODE + SEC_WINNT_AUTH_IDENTITY_UNICODE; +#else + SEC_WINNT_AUTH_IDENTITY_ANSI; +#endif + + return CURLE_OK; +} + +/* + * Curl_sspi_free_identity() + * + * This is used to free the contents of an SSPI identifier structure. + * + * Parameters: + * + * identity [in/out] - The identity structure. + */ +void Curl_sspi_free_identity(SEC_WINNT_AUTH_IDENTITY *identity) +{ + if(identity) { + curlx_safefree(identity->User); + curlx_safefree(identity->Password); + curlx_safefree(identity->Domain); + } +} + +#endif /* USE_WINDOWS_SSPI */ diff --git a/3rdparty/curl-8.21.0/lib/curl_sspi.h b/3rdparty/curl-8.21.0/lib/curl_sspi.h new file mode 100644 index 0000000000..2bd7eb4be8 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_sspi.h @@ -0,0 +1,86 @@ +#ifndef HEADER_CURL_SSPI_H +#define HEADER_CURL_SSPI_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_WINDOWS_SSPI + +#include + +CURLcode Curl_sspi_global_init(void); +void Curl_sspi_global_cleanup(void); + +/* This is used to populate the domain in an SSPI identity structure */ +CURLcode Curl_override_sspi_http_realm(const char *chlg, + SEC_WINNT_AUTH_IDENTITY *identity); + +/* This is used to generate an SSPI identity structure */ +CURLcode Curl_create_sspi_identity(const char *userp, const char *passwdp, + SEC_WINNT_AUTH_IDENTITY *identity); + +/* This is used to free an SSPI identity structure */ +void Curl_sspi_free_identity(SEC_WINNT_AUTH_IDENTITY *identity); + +/* Forward-declaration of global variables defined in curl_sspi.c */ +extern PSecurityFunctionTable Curl_pSecFn; + +/* Provide Service Principal names as macros */ +#define SP_NAME_DIGEST "WDigest" +#define SP_NAME_NTLM "NTLM" +#define SP_NAME_NEGOTIATE "Negotiate" +#define SP_NAME_KERBEROS "Kerberos" + +/* Offered by mingw-w64 v9+, MS SDK 7.0A/VS2010+ */ +#ifndef ISC_REQ_USE_HTTP_STYLE +#define ISC_REQ_USE_HTTP_STYLE 0x01000000 +#endif + +/* Offered by mingw-w64 v8+, MS SDK 6.0A/VS2008+ */ +#ifndef SEC_E_INVALID_PARAMETER +#define SEC_E_INVALID_PARAMETER ((HRESULT)0x8009035DL) +#endif +/* Offered by mingw-w64 v8+, MS SDK 6.0A/VS2008+ */ +#ifndef SEC_E_DELEGATION_POLICY +#define SEC_E_DELEGATION_POLICY ((HRESULT)0x8009035EL) +#endif +/* Offered by mingw-w64 v8+, MS SDK 6.0A/VS2008+ */ +#ifndef SEC_E_POLICY_NLTM_ONLY +#define SEC_E_POLICY_NLTM_ONLY ((HRESULT)0x8009035FL) +#endif + +/* Offered by mingw-w64 v8+, MS SDK 6.0A/VS2008+ */ +#ifndef SEC_I_SIGNATURE_NEEDED +#define SEC_I_SIGNATURE_NEEDED ((HRESULT)0x0009035CL) +#endif + +/* + * Definitions required from ntsecapi.h are directly provided below this point + * to avoid including ntsecapi.h due to a conflict with OpenSSL's safestack.h + */ +#define KERB_WRAP_NO_ENCRYPT 0x80000001 + +#endif /* USE_WINDOWS_SSPI */ + +#endif /* HEADER_CURL_SSPI_H */ diff --git a/3rdparty/curl-8.21.0/lib/curl_threads.c b/3rdparty/curl-8.21.0/lib/curl_threads.c new file mode 100644 index 0000000000..01041f63c3 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_threads.c @@ -0,0 +1,214 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" +#include "curl_threads.h" +#include "curlx/timeval.h" + +#ifdef USE_THREADS + +#ifdef HAVE_THREADS_POSIX + +struct Curl_actual_call { + unsigned int (*func)(void *); + void *arg; +}; + +static void *curl_thread_create_thunk(void *arg) +{ + struct Curl_actual_call *ac = arg; + unsigned int (*func)(void *) = ac->func; + void *real_arg = ac->arg; + + curlx_free(ac); + + (*func)(real_arg); + + return 0; +} + +curl_thread_t Curl_thread_create( + CURL_THREAD_RETURN_T(CURL_STDCALL *func)(void *), void *arg) +{ + curl_thread_t t = curlx_malloc(sizeof(pthread_t)); + struct Curl_actual_call *ac = NULL; + int rc; + + if(t) + ac = curlx_malloc(sizeof(struct Curl_actual_call)); + if(!(ac && t)) + goto err; + + ac->func = func; + ac->arg = arg; + + rc = pthread_create(t, NULL, curl_thread_create_thunk, ac); + if(rc) { + errno = rc; + goto err; + } + + return t; + +err: + curlx_free(t); + curlx_free(ac); + return curl_thread_t_null; +} + +void Curl_thread_destroy(curl_thread_t *hnd) +{ + if(*hnd != curl_thread_t_null) { + pthread_detach(**hnd); + curlx_free(*hnd); + *hnd = curl_thread_t_null; + } +} + +int Curl_thread_join(curl_thread_t *hnd) +{ + int ret = (pthread_join(**hnd, NULL) == 0); + + curlx_free(*hnd); + *hnd = curl_thread_t_null; + + return ret; +} + +#elif defined(_WIN32) + +curl_thread_t Curl_thread_create( + CURL_THREAD_RETURN_T(CURL_STDCALL *func)(void *), void *arg) +{ + curl_thread_t t = CreateThread(NULL, 0, func, arg, 0, NULL); + if(!t) { + DWORD gle = GetLastError(); + /* !checksrc! disable ERRNOVAR 1 */ + errno = (gle == ERROR_ACCESS_DENIED || + gle == ERROR_NOT_ENOUGH_MEMORY) ? + EACCES : EINVAL; + return curl_thread_t_null; + } + return t; +} + +void Curl_thread_destroy(curl_thread_t *hnd) +{ + if(*hnd != curl_thread_t_null) { + CloseHandle(*hnd); + *hnd = curl_thread_t_null; + } +} + +int Curl_thread_join(curl_thread_t *hnd) +{ + int ret = (WaitForSingleObjectEx(*hnd, INFINITE, FALSE) == WAIT_OBJECT_0); + + Curl_thread_destroy(hnd); + + return ret; +} + +#else +#error neither HAVE_THREADS_POSIX nor _WIN32 defined +#endif +#endif /* USE_THREADS */ + +#ifdef USE_MUTEX + +#ifdef HAVE_THREADS_POSIX + +void Curl_cond_signal(pthread_cond_t *c) +{ + /* return code defined as always 0 */ + (void)pthread_cond_signal(c); +} + +void Curl_cond_wait(pthread_cond_t *c, pthread_mutex_t *m) +{ + /* return code defined as always 0 */ + (void)pthread_cond_wait(c, m); +} + +CURLcode Curl_cond_timedwait(pthread_cond_t *c, pthread_mutex_t *m, + uint32_t timeout_ms) +{ + struct curltime now; + struct timespec ts; + timediff_t usec; + int rc; + + /* POSIX expects an "absolute" time until the condition wait ends. + * We cannot use `curlx_now()` here that may run on some monotonic clock + * that will be most likely in the past, as far as POSIX abstime is + * concerned. */ +#ifdef HAVE_GETTIMEOFDAY + struct timeval tv; + (void)gettimeofday(&tv, NULL); + now.tv_sec = tv.tv_sec; + now.tv_usec = (int)tv.tv_usec; +#else + now.tv_sec = time(NULL); + now.tv_usec = 0; +#endif + + ts.tv_sec = now.tv_sec + (timeout_ms / 1000); + usec = now.tv_usec + ((timeout_ms % 1000) * 1000); + if(usec >= 1000000) { + ++ts.tv_sec; + usec %= 1000000; + } + ts.tv_nsec = (long)usec * 1000; + + rc = pthread_cond_timedwait(c, m, &ts); + if(rc == SOCKETIMEDOUT) + return CURLE_OPERATION_TIMEDOUT; + return rc ? CURLE_UNRECOVERABLE_POLL : CURLE_OK; +} + +#elif defined(_WIN32) + +void Curl_cond_signal(CONDITION_VARIABLE *c) +{ + WakeConditionVariable(c); +} + +void Curl_cond_wait(CONDITION_VARIABLE *c, CRITICAL_SECTION *m) +{ + SleepConditionVariableCS(c, m, INFINITE); +} + +CURLcode Curl_cond_timedwait(CONDITION_VARIABLE *c, CRITICAL_SECTION *m, + uint32_t timeout_ms) +{ + if(!SleepConditionVariableCS(c, m, (DWORD)timeout_ms)) { + DWORD err = GetLastError(); + return (err == ERROR_TIMEOUT) ? + CURLE_OPERATION_TIMEDOUT : CURLE_UNRECOVERABLE_POLL; + } + return CURLE_OK; +} +#else +#error neither HAVE_THREADS_POSIX nor _WIN32 defined +#endif +#endif /* USE_MUTEX */ diff --git a/3rdparty/curl-8.21.0/lib/curl_threads.h b/3rdparty/curl-8.21.0/lib/curl_threads.h new file mode 100644 index 0000000000..081d155695 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_threads.h @@ -0,0 +1,77 @@ +#ifndef HEADER_CURL_THREADS_H +#define HEADER_CURL_THREADS_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_MUTEX +#ifdef HAVE_THREADS_POSIX +# define CURL_THREAD_RETURN_T unsigned int +# define CURL_STDCALL +# define curl_mutex_t pthread_mutex_t +# define curl_thread_t pthread_t * +# define curl_thread_t_null (pthread_t *)0 +# define Curl_mutex_init(m) pthread_mutex_init(m, NULL) +# define Curl_mutex_acquire(m) pthread_mutex_lock(m) +# define Curl_mutex_release(m) pthread_mutex_unlock(m) +# define Curl_mutex_destroy(m) pthread_mutex_destroy(m) +# define curl_cond_t pthread_cond_t +# define Curl_cond_init(c) pthread_cond_init(c, NULL) +# define Curl_cond_destroy(c) pthread_cond_destroy(c) +#elif defined(_WIN32) +# define CURL_THREAD_RETURN_T DWORD +# define CURL_STDCALL WINAPI +# define curl_mutex_t CRITICAL_SECTION +# define curl_thread_t HANDLE +# define curl_thread_t_null (HANDLE)0 +# define Curl_mutex_init(m) InitializeCriticalSectionEx(m, 0, 1) +# define Curl_mutex_acquire(m) EnterCriticalSection(m) +# define Curl_mutex_release(m) LeaveCriticalSection(m) +# define Curl_mutex_destroy(m) DeleteCriticalSection(m) +# define curl_cond_t CONDITION_VARIABLE +# define Curl_cond_init(c) InitializeConditionVariable(c) +# define Curl_cond_destroy(c) (void)(c) +#else +#error neither HAVE_THREADS_POSIX nor _WIN32 defined +#endif + +void Curl_cond_signal(curl_cond_t *c); +void Curl_cond_wait(curl_cond_t *c, curl_mutex_t *m); +/* Returns CURLE_OPERATION_TIMEDOUT on timeout */ +CURLcode Curl_cond_timedwait(curl_cond_t *c, curl_mutex_t *m, + uint32_t timeout_ms); +#endif /* USE_MUTEX */ + +#ifdef USE_THREADS + +curl_thread_t Curl_thread_create( + CURL_THREAD_RETURN_T(CURL_STDCALL *func)(void *), void *arg); + +void Curl_thread_destroy(curl_thread_t *hnd); + +int Curl_thread_join(curl_thread_t *hnd); + +#endif /* USE_THREADS */ + +#endif /* HEADER_CURL_THREADS_H */ diff --git a/3rdparty/curl-8.21.0/lib/curl_trc.c b/3rdparty/curl-8.21.0/lib/curl_trc.c new file mode 100644 index 0000000000..f8287e420f --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_trc.c @@ -0,0 +1,780 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "curl_trc.h" +#include "urldata.h" +#include "cfilters.h" +#include "multiif.h" + +#include "cf-dns.h" +#include "cf-recvbuf.h" +#include "cf-socket.h" +#include "cf-setup.h" +#include "http2.h" +#include "http_proxy.h" +#include "cf-h1-proxy.h" +#include "cf-h2-proxy.h" +#include "cf-haproxy.h" +#include "cf-https-connect.h" +#include "cf-ip-happy.h" +#include "progress.h" +#include "socks.h" +#include "curlx/strparse.h" +#include "vtls/vtls.h" +#include "vquic/vquic.h" +#include "curlx/strcopy.h" + +static void trc_write(struct Curl_easy *data, curl_infotype type, + const char *ptr, size_t size) +{ + if(data->set.verbose) { + if(data->set.fdebug) { + bool inCallback = Curl_is_in_callback(data); + Curl_set_in_callback(data, TRUE); + (void)(*data->set.fdebug)(data, type, CURL_UNCONST(ptr), size, + data->set.debugdata); + Curl_set_in_callback(data, inCallback); + } + else { + static const char s_infotype[CURLINFO_END][3] = { + "* ", "< ", "> ", "{ ", "} ", "{ ", "} " }; + switch(type) { + case CURLINFO_TEXT: + case CURLINFO_HEADER_OUT: + case CURLINFO_HEADER_IN: + fwrite(s_infotype[type], 2, 1, data->set.err); + fwrite(ptr, size, 1, data->set.err); + break; + default: /* nada */ + break; + } + } + } +} + +/* max length we trace before ending in '...' */ +#define TRC_LINE_MAX 2048 + +#define CURL_TRC_FMT_IDSC "[x-%" CURL_FORMAT_CURL_OFF_T "] " +#define CURL_TRC_FMT_IDSD "[%" CURL_FORMAT_CURL_OFF_T "-x] " +#define CURL_TRC_FMT_IDSDC "[%" CURL_FORMAT_CURL_OFF_T "-%" \ + CURL_FORMAT_CURL_OFF_T "] " + +static struct curl_trc_feat Curl_trc_feat_ids = { + "LIB-IDS", + CURL_LOG_LVL_NONE, +}; +#define CURL_TRC_IDS(data) \ + (Curl_trc_is_verbose(data) && \ + Curl_trc_feat_ids.log_level >= CURL_LOG_LVL_INFO) + +static size_t trc_print_ids(struct Curl_easy *data, char *buf, size_t maxlen) +{ + curl_off_t cid = data->conn ? + data->conn->connection_id : data->state.recent_conn_id; + if(data->id >= 0) { + if(cid >= 0) + return curl_msnprintf(buf, maxlen, CURL_TRC_FMT_IDSDC, data->id, cid); + else + return curl_msnprintf(buf, maxlen, CURL_TRC_FMT_IDSD, data->id); + } + else if(cid >= 0) + return curl_msnprintf(buf, maxlen, CURL_TRC_FMT_IDSC, cid); + else { + return curl_msnprintf(buf, maxlen, "[x-x] "); + } +} + +static size_t trc_end_buf(char *buf, size_t len, size_t maxlen, bool addnl) +{ + /* make sure we end the trace line in `buf` properly. It needs + * to end with a terminating '\0' or '\n\0' */ + if(len >= (maxlen - (addnl ? 2 : 1))) { + len = maxlen - 5; + buf[len++] = '.'; + buf[len++] = '.'; + buf[len++] = '.'; + buf[len++] = '\n'; + } + else if(addnl) + buf[len++] = '\n'; + buf[len] = '\0'; + return len; +} + +void Curl_debug(struct Curl_easy *data, curl_infotype type, + const char *ptr, size_t size) +{ + if(data->set.verbose) { + static const char s_infotype[CURLINFO_END][3] = { + "* ", "< ", "> ", "{ ", "} ", "{ ", "} " }; + char buf[TRC_LINE_MAX]; + size_t len; + if(data->set.fdebug) { + bool inCallback = Curl_is_in_callback(data); + + if(CURL_TRC_IDS(data) && (size < TRC_LINE_MAX)) { + len = trc_print_ids(data, buf, TRC_LINE_MAX); + len += curl_msnprintf(buf + len, TRC_LINE_MAX - len, "%.*s", + (int)size, ptr); + len = trc_end_buf(buf, len, TRC_LINE_MAX, FALSE); + Curl_set_in_callback(data, TRUE); + (void)(*data->set.fdebug)(data, type, buf, len, data->set.debugdata); + Curl_set_in_callback(data, inCallback); + } + else { + Curl_set_in_callback(data, TRUE); + (void)(*data->set.fdebug)(data, type, CURL_UNCONST(ptr), + size, data->set.debugdata); + Curl_set_in_callback(data, inCallback); + } + } + else { + switch(type) { + case CURLINFO_TEXT: + case CURLINFO_HEADER_OUT: + case CURLINFO_HEADER_IN: +#ifndef CURL_DISABLE_VERBOSE_STRINGS + if(CURL_TRC_IDS(data)) { + len = trc_print_ids(data, buf, TRC_LINE_MAX); + fwrite(buf, len, 1, data->set.err); + } +#endif + fwrite(s_infotype[type], 2, 1, data->set.err); + fwrite(ptr, size, 1, data->set.err); + break; + default: /* nada */ + break; + } + } + } +} + +/* Curl_failf() is for messages stating why we failed. + * The message SHALL NOT include any LF or CR. + */ +void Curl_failf(struct Curl_easy *data, const char *fmt, ...) +{ + DEBUGASSERT(!strchr(fmt, '\n')); + if(data->set.verbose || data->set.errorbuffer) { + va_list ap; + size_t len; + char error[CURL_ERROR_SIZE + 2]; + va_start(ap, fmt); + len = curl_mvsnprintf(error, CURL_ERROR_SIZE, fmt, ap); + + if(data->set.errorbuffer && !data->state.errorbuf) { + curlx_strcopy(data->set.errorbuffer, CURL_ERROR_SIZE, error, len); + data->state.errorbuf = TRUE; /* wrote error string */ + } + error[len++] = '\n'; + error[len] = '\0'; + trc_write(data, CURLINFO_TEXT, error, len); + va_end(ap); + } +} + +void Curl_reset_fail(struct Curl_easy *data) +{ + if(data->set.errorbuffer) + data->set.errorbuffer[0] = 0; + data->state.errorbuf = FALSE; +} + +#ifdef CURLVERBOSE +struct curl_trc_feat Curl_trc_feat_multi = { + "MULTI", + CURL_LOG_LVL_NONE, +}; +struct curl_trc_feat Curl_trc_feat_read = { + "READ", + CURL_LOG_LVL_NONE, +}; +struct curl_trc_feat Curl_trc_feat_write = { + "WRITE", + CURL_LOG_LVL_NONE, +}; +struct curl_trc_feat Curl_trc_feat_dns = { + "DNS", + CURL_LOG_LVL_NONE, +}; +struct curl_trc_feat Curl_trc_feat_timer = { + "TIMER", + CURL_LOG_LVL_NONE, +}; +#ifdef USE_THREADS +struct curl_trc_feat Curl_trc_feat_threads = { + "THREADS", + CURL_LOG_LVL_NONE, +}; +#endif +#endif + +#ifndef CURL_DISABLE_VERBOSE_STRINGS + +static void trc_infof(struct Curl_easy *data, + struct curl_trc_feat *feat, + const char *opt_id, int opt_id_idx, + const char * const fmt, va_list ap) CURL_PRINTF(5, 0); + +static void trc_infof(struct Curl_easy *data, + struct curl_trc_feat *feat, + const char *opt_id, int opt_id_idx, + const char * const fmt, va_list ap) +{ + size_t len = 0; + char buf[TRC_LINE_MAX]; + + if(CURL_TRC_IDS(data)) + len += trc_print_ids(data, buf + len, TRC_LINE_MAX - len); + if(feat) + len += curl_msnprintf(buf + len, TRC_LINE_MAX - len, "[%s] ", feat->name); + if(opt_id) { + if(opt_id_idx > 0) + len += curl_msnprintf(buf + len, TRC_LINE_MAX - len, "[%s-%d] ", + opt_id, opt_id_idx); + else + len += curl_msnprintf(buf + len, TRC_LINE_MAX - len, "[%s] ", opt_id); + } + len += curl_mvsnprintf(buf + len, TRC_LINE_MAX - len, fmt, ap); + len = trc_end_buf(buf, len, TRC_LINE_MAX, TRUE); + trc_write(data, CURLINFO_TEXT, buf, len); +} + +void Curl_infof(struct Curl_easy *data, const char *fmt, ...) +{ + DEBUGASSERT(!strchr(fmt, '\n')); + if(Curl_trc_is_verbose(data)) { + va_list ap; + va_start(ap, fmt); + trc_infof(data, data->state.feat, NULL, 0, fmt, ap); + va_end(ap); + } +} + +void Curl_trc_cf_infof(struct Curl_easy *data, const struct Curl_cfilter *cf, + const char *fmt, ...) +{ + DEBUGASSERT(cf); + if(Curl_trc_cf_is_verbose(cf, data)) { + va_list ap; + va_start(ap, fmt); + trc_infof(data, data->state.feat, cf->cft->name, cf->sockindex, fmt, ap); + va_end(ap); + } +} + +void Curl_trc_feat_infof(struct Curl_easy *data, + struct curl_trc_feat *feat, + const char *fmt, ...) +{ + DEBUGASSERT(feat); + if(Curl_trc_ft_is_verbose(data, feat)) { + va_list ap; + va_start(ap, fmt); + trc_infof(data, feat, NULL, 0, fmt, ap); + va_end(ap); + } +} + +static const char * const Curl_trc_timer_names[] = { + "100_TIMEOUT", + "ASYNC_NAME", + "CONNECTTIMEOUT", + "DNS_PER_NAME", + "DNS_PER_NAME2", + "HAPPY_EYEBALLS_DNS", + "HAPPY_EYEBALLS", + "MULTI_PENDING", + "SPEEDCHECK", + "TIMEOUT", + "TOOFAST", + "QUIC", + "FTP_ACCEPT", + "ALPN_EYEBALLS", + "SHUTDOWN", +}; + +static const char *trc_timer_name(int tid) +{ + if((tid >= 0) && ((size_t)tid < CURL_ARRAYSIZE(Curl_trc_timer_names))) + return Curl_trc_timer_names[(size_t)tid]; + return "UNKNOWN?"; +} + +void Curl_trc_timer(struct Curl_easy *data, int tid, const char *fmt, ...) +{ + DEBUGASSERT(!strchr(fmt, '\n')); + if(Curl_trc_ft_is_verbose(data, &Curl_trc_feat_timer)) { + const char *tname = trc_timer_name(tid); + va_list ap; + va_start(ap, fmt); + trc_infof(data, &Curl_trc_feat_timer, tname, 0, fmt, ap); + va_end(ap); + } +} + +void Curl_trc_easy_timers(struct Curl_easy *data) +{ + if(CURL_TRC_TIMER_is_verbose(data)) { + struct Curl_llist_node *e = Curl_llist_head(&data->state.timeoutlist); + if(e) { + const struct curltime *pnow = Curl_pgrs_now(data); + while(e) { + struct time_node *n = Curl_node_elem(e); + e = Curl_node_next(e); + CURL_TRC_TIMER(data, n->eid, "expires in %" FMT_TIMEDIFF_T "ns", + curlx_ptimediff_us(&n->time, pnow)); + } + } + } +} + +static const char * const Curl_trc_mstate_names[] = { + "INIT", + "PENDING", + "SETUP", + "CONNECT", + "CONNECTING", + "PROTOCONNECT", + "PROTOCONNECTING", + "DO", + "DOING", + "DOING_MORE", + "DID", + "PERFORMING", + "RATELIMITING", + "DONE", + "COMPLETED", + "MSGSENT", +}; + +const char *Curl_trc_mstate_name(int state) +{ + if((state >= 0) && ((size_t)state < CURL_ARRAYSIZE(Curl_trc_mstate_names))) + return Curl_trc_mstate_names[(size_t)state]; + return "?"; +} + +void Curl_trc_multi(struct Curl_easy *data, const char *fmt, ...) +{ + DEBUGASSERT(!strchr(fmt, '\n')); + if(Curl_trc_ft_is_verbose(data, &Curl_trc_feat_multi)) { + const char *sname = (data->id >= 0) ? + Curl_trc_mstate_name(data->mstate) : NULL; + va_list ap; + va_start(ap, fmt); + trc_infof(data, &Curl_trc_feat_multi, sname, 0, fmt, ap); + va_end(ap); + } +} + +void Curl_trc_read(struct Curl_easy *data, const char *fmt, ...) +{ + DEBUGASSERT(!strchr(fmt, '\n')); + if(Curl_trc_ft_is_verbose(data, &Curl_trc_feat_read)) { + va_list ap; + va_start(ap, fmt); + trc_infof(data, &Curl_trc_feat_read, NULL, 0, fmt, ap); + va_end(ap); + } +} + +void Curl_trc_write(struct Curl_easy *data, const char *fmt, ...) +{ + DEBUGASSERT(!strchr(fmt, '\n')); + if(Curl_trc_ft_is_verbose(data, &Curl_trc_feat_write)) { + va_list ap; + va_start(ap, fmt); + trc_infof(data, &Curl_trc_feat_write, NULL, 0, fmt, ap); + va_end(ap); + } +} + +void Curl_trc_dns(struct Curl_easy *data, const char *fmt, ...) +{ + DEBUGASSERT(!strchr(fmt, '\n')); + if(Curl_trc_ft_is_verbose(data, &Curl_trc_feat_dns)) { + va_list ap; + va_start(ap, fmt); + trc_infof(data, &Curl_trc_feat_dns, NULL, 0, fmt, ap); + va_end(ap); + } +} + +#ifndef CURL_DISABLE_FTP +struct curl_trc_feat Curl_trc_feat_ftp = { + "FTP", + CURL_LOG_LVL_NONE, +}; + +void Curl_trc_ftp(struct Curl_easy *data, const char *fmt, ...) +{ + DEBUGASSERT(!strchr(fmt, '\n')); + if(Curl_trc_ft_is_verbose(data, &Curl_trc_feat_ftp)) { + va_list ap; + va_start(ap, fmt); + trc_infof(data, &Curl_trc_feat_ftp, NULL, 0, fmt, ap); + va_end(ap); + } +} +#endif /* !CURL_DISABLE_FTP */ + +#ifndef CURL_DISABLE_SMTP +struct curl_trc_feat Curl_trc_feat_smtp = { + "SMTP", + CURL_LOG_LVL_NONE, +}; + +void Curl_trc_smtp(struct Curl_easy *data, const char *fmt, ...) +{ + DEBUGASSERT(!strchr(fmt, '\n')); + if(Curl_trc_ft_is_verbose(data, &Curl_trc_feat_smtp)) { + va_list ap; + va_start(ap, fmt); + trc_infof(data, &Curl_trc_feat_smtp, NULL, 0, fmt, ap); + va_end(ap); + } +} +#endif /* !CURL_DISABLE_SMTP */ + +#ifdef USE_SSL +struct curl_trc_feat Curl_trc_feat_ssls = { + "SSLS", + CURL_LOG_LVL_NONE, +}; + +void Curl_trc_ssls(struct Curl_easy *data, const char *fmt, ...) +{ + DEBUGASSERT(!strchr(fmt, '\n')); + if(Curl_trc_ft_is_verbose(data, &Curl_trc_feat_ssls)) { + va_list ap; + va_start(ap, fmt); + trc_infof(data, &Curl_trc_feat_ssls, NULL, 0, fmt, ap); + va_end(ap); + } +} +#endif /* USE_SSL */ + +#ifdef USE_SSH +struct curl_trc_feat Curl_trc_feat_ssh = { + "SSH", + CURL_LOG_LVL_NONE, +}; + +void Curl_trc_ssh(struct Curl_easy *data, const char *fmt, ...) +{ + DEBUGASSERT(!strchr(fmt, '\n')); + if(Curl_trc_ft_is_verbose(data, &Curl_trc_feat_ssh)) { + va_list ap; + va_start(ap, fmt); + trc_infof(data, &Curl_trc_feat_ssh, NULL, 0, fmt, ap); + va_end(ap); + } +} +#endif /* USE_SSH */ + +#if !defined(CURL_DISABLE_WEBSOCKETS) && !defined(CURL_DISABLE_HTTP) +struct curl_trc_feat Curl_trc_feat_ws = { + "WS", + CURL_LOG_LVL_NONE, +}; + +void Curl_trc_ws(struct Curl_easy *data, const char *fmt, ...) +{ + DEBUGASSERT(!strchr(fmt, '\n')); + if(Curl_trc_ft_is_verbose(data, &Curl_trc_feat_ws)) { + va_list ap; + va_start(ap, fmt); + trc_infof(data, &Curl_trc_feat_ws, NULL, 0, fmt, ap); + va_end(ap); + } +} +#endif /* !CURL_DISABLE_WEBSOCKETS && !CURL_DISABLE_HTTP */ + +#define TRC_CT_NONE 0 +#define TRC_CT_PROTOCOL (1 << 0) +#define TRC_CT_NETWORK (1 << 1) +#define TRC_CT_PROXY (1 << 2) +#define TRC_CT_INTERNALS (1 << 3) + +struct trc_feat_def { + struct curl_trc_feat *feat; + unsigned int category; +}; + +static struct trc_feat_def trc_feats[] = { + { &Curl_trc_feat_ids, TRC_CT_INTERNALS }, + { &Curl_trc_feat_multi, TRC_CT_NETWORK }, + { &Curl_trc_feat_read, TRC_CT_NONE }, + { &Curl_trc_feat_write, TRC_CT_NONE }, + { &Curl_trc_feat_dns, TRC_CT_NETWORK }, + { &Curl_trc_feat_timer, TRC_CT_NETWORK }, +#ifdef USE_THREADS + { &Curl_trc_feat_threads, TRC_CT_NONE }, +#endif +#ifndef CURL_DISABLE_FTP + { &Curl_trc_feat_ftp, TRC_CT_PROTOCOL }, +#endif +#ifndef CURL_DISABLE_SMTP + { &Curl_trc_feat_smtp, TRC_CT_PROTOCOL }, +#endif +#ifdef USE_SSL + { &Curl_trc_feat_ssls, TRC_CT_NETWORK }, +#endif +#ifdef USE_SSH + { &Curl_trc_feat_ssh, TRC_CT_PROTOCOL }, +#endif +#if !defined(CURL_DISABLE_WEBSOCKETS) && !defined(CURL_DISABLE_HTTP) + { &Curl_trc_feat_ws, TRC_CT_PROTOCOL }, +#endif +}; + +struct trc_cft_def { + struct Curl_cftype *cft; + unsigned int category; +}; + +static struct trc_cft_def trc_cfts[] = { + { &Curl_cft_dns, TRC_CT_NETWORK }, + { &Curl_cft_tcp, TRC_CT_NETWORK }, + { &Curl_cft_udp, TRC_CT_NETWORK }, + { &Curl_cft_unix, TRC_CT_NETWORK }, + { &Curl_cft_tcp_accept, TRC_CT_NETWORK }, + { &Curl_cft_ip_happy, TRC_CT_NETWORK }, +#ifndef CURL_DISABLE_WEBSOCKETS + { &Curl_cft_recvbuf, TRC_CT_PROTOCOL }, +#endif + { &Curl_cft_setup, TRC_CT_PROTOCOL }, +#if !defined(CURL_DISABLE_HTTP) && defined(USE_NGHTTP2) + { &Curl_cft_nghttp2, TRC_CT_PROTOCOL }, +#endif +#ifdef USE_SSL + { &Curl_cft_ssl, TRC_CT_NETWORK }, +#ifndef CURL_DISABLE_PROXY + { &Curl_cft_ssl_proxy, TRC_CT_PROXY }, +#endif +#endif +#ifndef CURL_DISABLE_PROXY +#ifndef CURL_DISABLE_HTTP + { &Curl_cft_h1_proxy, TRC_CT_PROXY }, +#ifdef USE_NGHTTP2 + { &Curl_cft_h2_proxy, TRC_CT_PROXY }, +#endif +#if defined(USE_PROXY_HTTP3) && defined(USE_NGHTTP3) + { &Curl_cft_h3_proxy, TRC_CT_PROXY }, +#endif + { &Curl_cft_http_proxy, TRC_CT_PROXY }, +#endif /* !CURL_DISABLE_HTTP */ + { &Curl_cft_haproxy, TRC_CT_PROXY }, + { &Curl_cft_socks_proxy, TRC_CT_PROXY }, +#endif /* !CURL_DISABLE_PROXY */ +#if !defined(CURL_DISABLE_HTTP) && defined(USE_HTTP3) + { &Curl_cft_http3, TRC_CT_PROTOCOL }, +#endif +#ifndef CURL_DISABLE_HTTP + { &Curl_cft_http_connect, TRC_CT_PROTOCOL }, +#endif +}; + +static void trc_apply_level_by_name(struct Curl_str *token, int lvl) +{ + size_t i; + + for(i = 0; i < CURL_ARRAYSIZE(trc_cfts); ++i) { + if(curlx_str_casecompare(token, trc_cfts[i].cft->name)) { + trc_cfts[i].cft->log_level = lvl; + break; + } + } + for(i = 0; i < CURL_ARRAYSIZE(trc_feats); ++i) { + if(curlx_str_casecompare(token, trc_feats[i].feat->name)) { + trc_feats[i].feat->log_level = lvl; + break; + } + } +} + +static void trc_apply_level_by_category(unsigned int category, int lvl) +{ + size_t i; + + for(i = 0; i < CURL_ARRAYSIZE(trc_cfts); ++i) { + if(!category || (trc_cfts[i].category & category)) + trc_cfts[i].cft->log_level = lvl; + } + for(i = 0; i < CURL_ARRAYSIZE(trc_feats); ++i) { + if(!category || (trc_feats[i].category & category)) + trc_feats[i].feat->log_level = lvl; + } +} + +static CURLcode trc_opt(const char *config) +{ + struct Curl_str out; + while(!curlx_str_until(&config, &out, 32, ',')) { + int lvl = CURL_LOG_LVL_INFO; + const char *token = curlx_str(&out); + + if(*token == '-') { + lvl = CURL_LOG_LVL_NONE; + curlx_str_nudge(&out, 1); + } + else if(*token == '+') + curlx_str_nudge(&out, 1); + + if(curlx_str_casecompare(&out, "all")) + trc_apply_level_by_category(TRC_CT_NONE, lvl); + else if(curlx_str_casecompare(&out, "protocol")) + trc_apply_level_by_category(TRC_CT_PROTOCOL, lvl); + else if(curlx_str_casecompare(&out, "network")) + trc_apply_level_by_category(TRC_CT_NETWORK, lvl); + else if(curlx_str_casecompare(&out, "proxy")) + trc_apply_level_by_category(TRC_CT_PROXY, lvl); + else if(curlx_str_casecompare(&out, "doh")) { + struct Curl_str dns = { "dns", 3 }; + trc_apply_level_by_name(&dns, lvl); + } + else + trc_apply_level_by_name(&out, lvl); + + if(curlx_str_single(&config, ',')) + break; + } + return CURLE_OK; +} + +CURLcode Curl_trc_opt(const char *config) +{ + CURLcode result = config ? trc_opt(config) : CURLE_OK; +#ifdef DEBUGBUILD + /* CURL_DEBUG can override anything */ + if(!result) { + const char *dbg_config = getenv("CURL_DEBUG"); + if(dbg_config) + result = trc_opt(dbg_config); + } +#endif /* DEBUGBUILD */ + return result; +} + +CURLcode Curl_trc_init(void) +{ +#ifdef DEBUGBUILD + return Curl_trc_opt(NULL); +#else + return CURLE_OK; +#endif +} + +#else /* CURL_DISABLE_VERBOSE_STRINGS */ + +CURLcode Curl_trc_init(void) +{ + return CURLE_OK; +} + +void Curl_infof(struct Curl_easy *data, const char *fmt, ...) +{ + (void)data; + (void)fmt; +} + +void Curl_trc_cf_infof(struct Curl_easy *data, const struct Curl_cfilter *cf, + const char *fmt, ...) +{ + (void)data; + (void)cf; + (void)fmt; +} + +void Curl_trc_multi(struct Curl_easy *data, const char *fmt, ...) +{ + (void)data; + (void)fmt; +} + +void Curl_trc_write(struct Curl_easy *data, const char *fmt, ...) +{ + (void)data; + (void)fmt; +} + +void Curl_trc_dns(struct Curl_easy *data, const char *fmt, ...) +{ + (void)data; + (void)fmt; +} + +void Curl_trc_timer(struct Curl_easy *data, int tid, const char *fmt, ...) +{ + (void)data; + (void)tid; + (void)fmt; +} + +void Curl_trc_read(struct Curl_easy *data, const char *fmt, ...) +{ + (void)data; + (void)fmt; +} + +#ifndef CURL_DISABLE_FTP +void Curl_trc_ftp(struct Curl_easy *data, const char *fmt, ...) +{ + (void)data; + (void)fmt; +} +#endif +#ifndef CURL_DISABLE_SMTP +void Curl_trc_smtp(struct Curl_easy *data, const char *fmt, ...) +{ + (void)data; + (void)fmt; +} +#endif +#if !defined(CURL_DISABLE_WEBSOCKETS) && !defined(CURL_DISABLE_HTTP) +void Curl_trc_ws(struct Curl_easy *data, const char *fmt, ...) +{ + (void)data; + (void)fmt; +} +#endif +#ifdef USE_SSH +void Curl_trc_ssh(struct Curl_easy *data, const char *fmt, ...) +{ + (void)data; + (void)fmt; +} +#endif +#ifdef USE_SSL +void Curl_trc_ssls(struct Curl_easy *data, const char *fmt, ...) +{ + (void)data; + (void)fmt; +} +#endif + +#endif /* !CURL_DISABLE_VERBOSE_STRINGS */ diff --git a/3rdparty/curl-8.21.0/lib/curl_trc.h b/3rdparty/curl-8.21.0/lib/curl_trc.h new file mode 100644 index 0000000000..b4ae8e5314 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curl_trc.h @@ -0,0 +1,344 @@ +#ifndef HEADER_CURL_TRC_H +#define HEADER_CURL_TRC_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +struct Curl_easy; +struct Curl_cfilter; + +/** + * Init logging, return != 0 on failure. + */ +CURLcode Curl_trc_init(void); + +/** + * Configure tracing. May be called several times during global + * initialization. Later calls may not take effect. + * + * Configuration format supported: + * - comma-separated list of component names to enable logging on. + * E.g. 'http/2,ssl'. Unknown names are ignored. Names are compared + * case-insensitive. + * - component 'all' applies to all known log components + * - prefixing a component with '+' or '-' will en-/disable logging for + * that component + * Example: 'all,-ssl' would enable logging for all components but the + * SSL filters. + * + * @param config configuration string + */ +CURLcode Curl_trc_opt(const char *config); + +/* the function used to output verbose information */ +void Curl_debug(struct Curl_easy *data, curl_infotype type, + const char *ptr, size_t size); + +/** + * Output a failure message on registered callbacks for transfer. + */ +void Curl_failf(struct Curl_easy *data, + const char *fmt, ...) CURL_PRINTF(2, 3); + +#define failf Curl_failf + +/* In case failf() reported into the errorbuf, clear it again. + * This is used to clear information from happy eyeballing attempts + * when ultimately a successful attempt was made. */ +void Curl_reset_fail(struct Curl_easy *data); + +#define CURL_LOG_LVL_NONE 0 +#define CURL_LOG_LVL_INFO 1 + +/** + * Output an informational message when transfer's verbose logging is enabled. + */ +void Curl_infof(struct Curl_easy *data, + const char *fmt, ...) CURL_PRINTF(2, 3); + +/** + * Output an informational message when both transfer's verbose logging + * and connection filters verbose logging are enabled. + */ +void Curl_trc_cf_infof(struct Curl_easy *data, const struct Curl_cfilter *cf, + const char *fmt, ...) CURL_PRINTF(3, 4); +void Curl_trc_multi(struct Curl_easy *data, + const char *fmt, ...) CURL_PRINTF(2, 3); +const char *Curl_trc_mstate_name(int state); +const char *Curl_trc_timer_name(int tid); +void Curl_trc_easy_timers(struct Curl_easy *data); + +void Curl_trc_write(struct Curl_easy *data, + const char *fmt, ...) CURL_PRINTF(2, 3); +void Curl_trc_read(struct Curl_easy *data, + const char *fmt, ...) CURL_PRINTF(2, 3); +void Curl_trc_dns(struct Curl_easy *data, + const char *fmt, ...) CURL_PRINTF(2, 3); +void Curl_trc_timer(struct Curl_easy *data, int tid, + const char *fmt, ...) CURL_PRINTF(3, 4); + +struct curl_trc_feat { + const char *name; + int log_level; +}; + +void Curl_trc_feat_infof(struct Curl_easy *data, + struct curl_trc_feat *feat, + const char *fmt, ...) CURL_PRINTF(3, 4); + +#ifndef CURL_DISABLE_FTP +extern struct curl_trc_feat Curl_trc_feat_ftp; +void Curl_trc_ftp(struct Curl_easy *data, + const char *fmt, ...) CURL_PRINTF(2, 3); +#endif +#ifndef CURL_DISABLE_SMTP +extern struct curl_trc_feat Curl_trc_feat_smtp; +void Curl_trc_smtp(struct Curl_easy *data, + const char *fmt, ...) CURL_PRINTF(2, 3); +#endif +#ifdef USE_SSL +extern struct curl_trc_feat Curl_trc_feat_ssls; +void Curl_trc_ssls(struct Curl_easy *data, + const char *fmt, ...) CURL_PRINTF(2, 3); +#endif +#ifdef USE_SSH +extern struct curl_trc_feat Curl_trc_feat_ssh; +void Curl_trc_ssh(struct Curl_easy *data, + const char *fmt, ...) CURL_PRINTF(2, 3); +#endif +#if !defined(CURL_DISABLE_WEBSOCKETS) && !defined(CURL_DISABLE_HTTP) +extern struct curl_trc_feat Curl_trc_feat_ws; +void Curl_trc_ws(struct Curl_easy *data, + const char *fmt, ...) CURL_PRINTF(2, 3); +#endif + +#define CURL_TRC_M_is_verbose(data) \ + Curl_trc_ft_is_verbose(data, &Curl_trc_feat_multi) +#define CURL_TRC_DNS_is_verbose(data) \ + Curl_trc_ft_is_verbose(data, &Curl_trc_feat_dns) +#define CURL_TRC_TIMER_is_verbose(data) \ + Curl_trc_ft_is_verbose(data, &Curl_trc_feat_timer) + +#if defined(CURL_HAVE_MACRO_VARARG) && !defined(CURL_DISABLE_VERBOSE_STRINGS) +#define infof(data, ...) \ + do { \ + if(Curl_trc_is_verbose(data)) \ + Curl_infof(data, __VA_ARGS__); \ + } while(0) +#define CURL_TRC_M(data, ...) \ + do { \ + if(CURL_TRC_M_is_verbose(data)) \ + Curl_trc_multi(data, __VA_ARGS__); \ + } while(0) +#define CURL_TRC_CF(data, cf, ...) \ + do { \ + if(Curl_trc_cf_is_verbose(cf, data)) \ + Curl_trc_cf_infof(data, cf, __VA_ARGS__); \ + } while(0) +#define CURL_TRC_WRITE(data, ...) \ + do { \ + if(Curl_trc_ft_is_verbose(data, &Curl_trc_feat_write)) \ + Curl_trc_write(data, __VA_ARGS__); \ + } while(0) +#define CURL_TRC_READ(data, ...) \ + do { \ + if(Curl_trc_ft_is_verbose(data, &Curl_trc_feat_read)) \ + Curl_trc_read(data, __VA_ARGS__); \ + } while(0) +#define CURL_TRC_DNS(data, ...) \ + do { \ + if(CURL_TRC_DNS_is_verbose(data)) \ + Curl_trc_dns(data, __VA_ARGS__); \ + } while(0) +#define CURL_TRC_TIMER(data, tid, ...) \ + do { \ + if(CURL_TRC_TIMER_is_verbose(data)) \ + Curl_trc_timer(data, tid, __VA_ARGS__); \ + } while(0) + +#ifndef CURL_DISABLE_FTP +#define CURL_TRC_FTP(data, ...) \ + do { \ + if(Curl_trc_ft_is_verbose(data, &Curl_trc_feat_ftp)) \ + Curl_trc_ftp(data, __VA_ARGS__); \ + } while(0) +#endif /* !CURL_DISABLE_FTP */ +#ifndef CURL_DISABLE_SMTP +#define CURL_TRC_SMTP(data, ...) \ + do { \ + if(Curl_trc_ft_is_verbose(data, &Curl_trc_feat_smtp)) \ + Curl_trc_smtp(data, __VA_ARGS__); \ + } while(0) +#endif /* !CURL_DISABLE_SMTP */ +#ifdef USE_SSL +#define CURL_TRC_SSLS(data, ...) \ + do { \ + if(Curl_trc_ft_is_verbose(data, &Curl_trc_feat_ssls)) \ + Curl_trc_ssls(data, __VA_ARGS__); \ + } while(0) +#endif /* USE_SSL */ +#ifdef USE_SSH +#define CURL_TRC_SSH(data, ...) \ + do { \ + if(Curl_trc_ft_is_verbose(data, &Curl_trc_feat_ssh)) \ + Curl_trc_ssh(data, __VA_ARGS__); \ + } while(0) +#endif /* USE_SSH */ +#if !defined(CURL_DISABLE_WEBSOCKETS) && !defined(CURL_DISABLE_HTTP) +#define CURL_TRC_WS(data, ...) \ + do { \ + if(Curl_trc_ft_is_verbose(data, &Curl_trc_feat_ws)) \ + Curl_trc_ws(data, __VA_ARGS__); \ + } while(0) +#endif /* !CURL_DISABLE_WEBSOCKETS && !CURL_DISABLE_HTTP */ + +#elif defined(CURL_HAVE_MACRO_VARARG) && defined(CURL_DISABLE_VERBOSE_STRINGS) + +#define infof(data, ...) \ + do { \ + (void)(data); \ + } while(0) +#define CURL_TRC_M(data, ...) \ + do { \ + (void)(data); \ + } while(0) +#define CURL_TRC_CF(data, cf, ...) \ + do { \ + (void)(data); \ + (void)(cf); \ + } while(0) +#define CURL_TRC_WRITE(data, ...) \ + do { \ + (void)(data); \ + } while(0) +#define CURL_TRC_READ(data, ...) \ + do { \ + (void)(data); \ + } while(0) +#define CURL_TRC_DNS(data, ...) \ + do { \ + (void)(data); \ + } while(0) +#define CURL_TRC_TIMER(data, tid, ...) \ + do { \ + (void)(data); \ + (void)(tid); \ + } while(0) +#ifndef CURL_DISABLE_FTP +#define CURL_TRC_FTP(data, ...) \ + do { \ + (void)(data); \ + } while(0) +#endif /* !CURL_DISABLE_FTP */ +#ifndef CURL_DISABLE_SMTP +#define CURL_TRC_SMTP(data, ...) \ + do { \ + (void)(data); \ + } while(0) +#endif /* !CURL_DISABLE_SMTP */ +#ifdef USE_SSL +#define CURL_TRC_SSLS(data, ...) \ + do { \ + (void)(data); \ + } while(0) +#endif /* USE_SSL */ +#ifdef USE_SSH +#define CURL_TRC_SSH(data, ...) \ + do { \ + (void)(data); \ + } while(0) +#endif /* USE_SSH */ +#if !defined(CURL_DISABLE_WEBSOCKETS) && !defined(CURL_DISABLE_HTTP) +#define CURL_TRC_WS(data, ...) \ + do { \ + (void)(data); \ + } while(0) +#endif + +#else /* !CURL_HAVE_MACRO_VARARG */ + +#define infof Curl_infof +#define CURL_TRC_M Curl_trc_multi +#define CURL_TRC_CF Curl_trc_cf_infof +#define CURL_TRC_WRITE Curl_trc_write +#define CURL_TRC_READ Curl_trc_read +#define CURL_TRC_DNS Curl_trc_dns +#define CURL_TRC_TIMER Curl_trc_timer + +#ifndef CURL_DISABLE_FTP +#define CURL_TRC_FTP Curl_trc_ftp +#endif +#ifndef CURL_DISABLE_SMTP +#define CURL_TRC_SMTP Curl_trc_smtp +#endif +#ifdef USE_SSL +#define CURL_TRC_SSLS Curl_trc_ssls +#endif +#ifdef USE_SSH +#define CURL_TRC_SSH Curl_trc_ssh +#endif +#if !defined(CURL_DISABLE_WEBSOCKETS) && !defined(CURL_DISABLE_HTTP) +#define CURL_TRC_WS Curl_trc_ws +#endif + +#endif /* CURL_HAVE_MACRO_VARARG */ + +#ifdef CURLVERBOSE +extern struct curl_trc_feat Curl_trc_feat_multi; +extern struct curl_trc_feat Curl_trc_feat_read; +extern struct curl_trc_feat Curl_trc_feat_write; +extern struct curl_trc_feat Curl_trc_feat_dns; +extern struct curl_trc_feat Curl_trc_feat_timer; +#ifdef USE_THREADS +extern struct curl_trc_feat Curl_trc_feat_threads; +#endif +#endif + +#ifndef CURL_DISABLE_VERBOSE_STRINGS +/* informational messages enabled */ +#define Curl_trc_is_verbose(data) \ + ((data) && (data)->set.verbose && \ + (!(data)->state.feat || \ + ((data)->state.feat->log_level >= CURL_LOG_LVL_INFO))) +#define Curl_trc_cf_is_verbose(cf, data) \ + (Curl_trc_is_verbose(data) && \ + (cf) && (cf)->cft->log_level >= CURL_LOG_LVL_INFO) +#define Curl_trc_ft_is_verbose(data, ft) \ + (Curl_trc_is_verbose(data) && \ + (ft)->log_level >= CURL_LOG_LVL_INFO) +#define CURL_MSTATE_NAME(s) Curl_trc_mstate_name((int)(s)) +#define CURL_TRC_EASY_TIMERS(data) \ + do { \ + if(CURL_TRC_TIMER_is_verbose(data)) \ + Curl_trc_easy_timers(data); \ + } while(0) + +#else /* CURL_DISABLE_VERBOSE_STRINGS */ +/* All informational messages are not compiled in for size savings */ +#define Curl_trc_is_verbose(d) FALSE +#define Curl_trc_cf_is_verbose(x, y) FALSE +#define Curl_trc_ft_is_verbose(x, y) FALSE +#define CURL_MSTATE_NAME(x) ((void)(x), "-") +#define CURL_TRC_EASY_TIMERS(x) Curl_nop_stmt +#endif /* !CURL_DISABLE_VERBOSE_STRINGS */ + +#endif /* HEADER_CURL_TRC_H */ diff --git a/3rdparty/curl-8.21.0/lib/curlx/base64.c b/3rdparty/curl-8.21.0/lib/curlx/base64.c new file mode 100644 index 0000000000..7f51576f50 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/base64.c @@ -0,0 +1,267 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +/* Base64 encoding/decoding */ + +#include "curl_setup.h" + +#include "curlx/base64.h" + +/* ---- Base64 Encoding/Decoding Table --- */ +const char curlx_base64encdec[] = + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"; + +/* The Base 64 encoding with a URL and filename safe alphabet, RFC 4648 + section 5 */ +static const char base64url[] = + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_"; + +static const unsigned char decodetable[] = { + 62, 255, 255, 255, 63, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 255, + 255, 255, 255, 255, 255, 255, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, + 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, + 255, 255, 255, 255, 255, 255, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, + 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51 +}; +/* + * curlx_base64_decode() + * + * Given a base64 null-terminated string at src, decode it and return a + * pointer in *outptr to a newly allocated memory area holding decoded data. + * Size of decoded data is returned in variable pointed by outlen. + * + * Returns CURLE_OK on success, otherwise specific error code. Function + * output shall not be considered valid unless CURLE_OK is returned. + * + * When decoded data length is 0, returns NULL in *outptr. + * + * @unittest: 1302 + */ +CURLcode curlx_base64_decode(const char *src, + uint8_t **outptr, size_t *outlen) +{ + size_t srclen = 0; + size_t padding = 0; + size_t i; + size_t numQuantums; + size_t fullQuantums; + size_t rawlen = 0; + unsigned char *pos; + unsigned char *newstr; + unsigned char lookup[256]; + + *outptr = NULL; + *outlen = 0; + srclen = strlen(src); + + /* Check the length of the input string is valid */ + if(!srclen || srclen % 4) + return CURLE_BAD_CONTENT_ENCODING; + + /* srclen is at least 4 here */ + while(src[srclen - 1 - padding] == '=') { + /* count padding characters */ + padding++; + /* A maximum of two = padding characters is allowed */ + if(padding > 2) + return CURLE_BAD_CONTENT_ENCODING; + } + + /* Calculate the number of quantums */ + numQuantums = srclen / 4; + fullQuantums = numQuantums - (padding ? 1 : 0); + + /* Calculate the size of the decoded string */ + rawlen = (numQuantums * 3) - padding; + + /* Allocate our buffer including room for a null-terminator */ + newstr = curlx_malloc(rawlen + 1); + if(!newstr) + return CURLE_OUT_OF_MEMORY; + + pos = newstr; + + memset(lookup, 0xff, sizeof(lookup)); + memcpy(&lookup['+'], decodetable, sizeof(decodetable)); + + /* Decode the complete quantums first */ + for(i = 0; i < fullQuantums; i++) { + unsigned char val; + unsigned int x = 0; + int j; + + for(j = 0; j < 4; j++) { + val = lookup[(unsigned char)*src++]; + if(val == 0xff) /* bad symbol */ + goto bad; + x = (x << 6) | val; + } + pos[2] = x & 0xff; + pos[1] = (x >> 8) & 0xff; + pos[0] = (x >> 16) & 0xff; + pos += 3; + } + if(padding) { + /* this means either 8 or 16 bits output */ + unsigned char val; + unsigned int x = 0; + int j; + size_t padc = 0; + for(j = 0; j < 4; j++) { + if(*src == '=') { + x <<= 6; + src++; + if(++padc > padding) + /* this is a badly placed '=' symbol! */ + goto bad; + } + else { + val = lookup[(unsigned char)*src++]; + if(val == 0xff) /* bad symbol */ + goto bad; + x = (x << 6) | val; + } + } + if(padding == 1) + pos[1] = (x >> 8) & 0xff; + pos[0] = (x >> 16) & 0xff; + pos += 3 - padding; + } + + /* Null-terminate */ + *pos = '\0'; + + /* Return the decoded data */ + *outptr = newstr; + *outlen = rawlen; + + return CURLE_OK; +bad: + curlx_free(newstr); + return CURLE_BAD_CONTENT_ENCODING; +} + +static CURLcode base64_encode(const char *table64, + uint8_t padbyte, + const uint8_t *inputbuff, size_t insize, + char **outptr, size_t *outlen) +{ + char *output; + char *base64data; + const unsigned char *in = (const unsigned char *)inputbuff; + + *outptr = NULL; + *outlen = 0; + + if(!insize) + return CURLE_OK; + + /* safety precaution */ + DEBUGASSERT(insize <= CURL_MAX_BASE64_INPUT); + if(insize > CURL_MAX_BASE64_INPUT) + return CURLE_TOO_LARGE; + + base64data = output = curlx_malloc(((insize + 2) / 3 * 4) + 1); + if(!output) + return CURLE_OUT_OF_MEMORY; + + while(insize >= 3) { + *output++ = table64[in[0] >> 2]; + *output++ = table64[((in[0] & 0x03) << 4) | (in[1] >> 4)]; + *output++ = table64[((in[1] & 0x0F) << 2) | ((in[2] & 0xC0) >> 6)]; + *output++ = table64[in[2] & 0x3F]; + insize -= 3; + in += 3; + } + if(insize) { + /* this is only one or two bytes now */ + *output++ = table64[in[0] >> 2]; + if(insize == 1) { + *output++ = table64[((in[0] & 0x03) << 4)]; + if(padbyte) { + *output++ = padbyte; + *output++ = padbyte; + } + } + else { + /* insize == 2 */ + *output++ = table64[((in[0] & 0x03) << 4) | ((in[1] & 0xF0) >> 4)]; + *output++ = table64[((in[1] & 0x0F) << 2)]; + if(padbyte) + *output++ = padbyte; + } + } + + /* Null-terminate */ + *output = '\0'; + + /* Return the pointer to the new data (allocated memory) */ + *outptr = base64data; + + /* Return the length of the new data */ + *outlen = (size_t)(output - base64data); + + return CURLE_OK; +} + +/* + * curlx_base64_encode() + * + * Given a pointer to an input buffer and an input size, encode it and + * return a pointer in *outptr to a newly allocated memory area holding + * encoded data. Size of encoded data is returned in variable pointed by + * outlen. + * + * Returns CURLE_OK on success, otherwise specific error code. Function + * output shall not be considered valid unless CURLE_OK is returned. + * + * @unittest: 1302 + */ +CURLcode curlx_base64_encode(const uint8_t *inputbuff, size_t insize, + char **outptr, size_t *outlen) +{ + return base64_encode(curlx_base64encdec, '=', + inputbuff, insize, outptr, outlen); +} + +/* + * curlx_base64url_encode() + * + * Given a pointer to an input buffer and an input size, encode it and + * return a pointer in *outptr to a newly allocated memory area holding + * encoded data. Size of encoded data is returned in variable pointed by + * outlen. + * + * Input length of 0 indicates input buffer holds a null-terminated string. + * + * Returns CURLE_OK on success, otherwise specific error code. Function + * output shall not be considered valid unless CURLE_OK is returned. + * + * @unittest: 1302 + */ +CURLcode curlx_base64url_encode(const uint8_t *inputbuff, size_t insize, + char **outptr, size_t *outlen) +{ + return base64_encode(base64url, 0, inputbuff, insize, outptr, outlen); +} diff --git a/3rdparty/curl-8.21.0/lib/curlx/base64.h b/3rdparty/curl-8.21.0/lib/curlx/base64.h new file mode 100644 index 0000000000..2e77814822 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/base64.h @@ -0,0 +1,40 @@ +#ifndef HEADER_CURL_BASE64_H +#define HEADER_CURL_BASE64_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +CURLcode curlx_base64_encode(const uint8_t *inputbuff, size_t insize, + char **outptr, size_t *outlen); +CURLcode curlx_base64url_encode(const uint8_t *inputbuff, size_t insize, + char **outptr, size_t *outlen); +CURLcode curlx_base64_decode(const char *src, + uint8_t **outptr, size_t *outlen); + +extern const char curlx_base64encdec[]; + +/* maximum input length acceptable to base64 encode, here to catch and prevent + mistakes */ +#define CURL_MAX_BASE64_INPUT 16000000 + +#endif /* HEADER_CURL_BASE64_H */ diff --git a/3rdparty/curl-8.21.0/lib/curlx/basename.c b/3rdparty/curl-8.21.0/lib/curlx/basename.c new file mode 100644 index 0000000000..d2fd160ff2 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/basename.c @@ -0,0 +1,74 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifndef HAVE_BASENAME + +#include "curlx/basename.h" + +/* + (Quote from The Open Group Base Specifications Issue 6 IEEE Std 1003.1, 2004 + Edition) + + The basename() function shall take the pathname pointed to by path and + return a pointer to the final component of the pathname, deleting any + trailing '/' characters. + + If the string pointed to by path consists entirely of the '/' character, + basename() shall return a pointer to the string "/". If the string pointed + to by path is exactly "//", it is implementation-defined whether '/' or "//" + is returned. + + If path is a null pointer or points to an empty string, basename() shall + return a pointer to the string ".". + + The basename() function may modify the string pointed to by path, and may + return a pointer to static storage that may then be overwritten by a + subsequent call to basename(). + + The basename() function need not be reentrant. A function that is not + required to be reentrant is not required to be thread-safe. + +*/ +char *curlx_basename(char *path) +{ + /* Ignore all the details above for now and make a quick and simple + implementation here */ + char *s1; + char *s2; + + s1 = strrchr(path, '/'); + s2 = strrchr(path, '\\'); + + if(s1 && s2) + path = ((s1 > s2) ? s1 : s2) + 1; + else if(s1) + path = s1 + 1; + else if(s2) + path = s2 + 1; + + return path; +} + +#endif /* !HAVE_BASENAME */ diff --git a/3rdparty/curl-8.21.0/lib/curlx/basename.h b/3rdparty/curl-8.21.0/lib/curlx/basename.h new file mode 100644 index 0000000000..fb79fed805 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/basename.h @@ -0,0 +1,39 @@ +#ifndef HEADER_CURLX_BASENAME_H +#define HEADER_CURLX_BASENAME_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifndef HAVE_BASENAME +char *curlx_basename(char *path); +#else + +#ifdef HAVE_LIBGEN_H +#include +#endif + +#define curlx_basename(x) basename(x) +#endif /* !HAVE_BASENAME */ + +#endif /* HEADER_CURLX_BASENAME_H */ diff --git a/3rdparty/curl-8.21.0/lib/curlx/dynbuf.c b/3rdparty/curl-8.21.0/lib/curlx/dynbuf.c new file mode 100644 index 0000000000..1e5ea5177d --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/dynbuf.c @@ -0,0 +1,292 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "curlx/dynbuf.h" +#include "curl_printf.h" + +#define MIN_FIRST_ALLOC 32 + +#ifdef DEBUGBUILD +#define DYNINIT 0xbee51da /* random pattern */ +#endif + +/* + * Init a dynbuf struct. + */ +void curlx_dyn_init(struct dynbuf *s, size_t toobig) +{ + DEBUGASSERT(s); + DEBUGASSERT(toobig); + DEBUGASSERT(toobig <= MAX_DYNBUF_SIZE); /* catch crazy mistakes */ + s->bufr = NULL; + s->leng = 0; + s->allc = 0; + s->toobig = toobig; +#ifdef DEBUGBUILD + s->init = DYNINIT; +#endif +} + +/* + * free the buffer and re-init the necessary fields. It does not touch the + * 'init' field and thus this buffer can be reused to add data to again. + */ +void curlx_dyn_free(struct dynbuf *s) +{ + DEBUGASSERT(s); + DEBUGASSERT(s->init == DYNINIT); + curlx_safefree(s->bufr); + s->leng = s->allc = 0; +} + +/* + * Store/append an chunk of memory to the dynbuf. + */ +static CURLcode dyn_nappend(struct dynbuf *s, + const unsigned char *mem, size_t len) +{ + size_t idx = s->leng; + size_t a = s->allc; + size_t fit = len + idx + 1; /* new string + old string + zero byte */ + + /* try to detect if there is rubbish in the struct */ + DEBUGASSERT(s->init == DYNINIT); + DEBUGASSERT(s->toobig); + DEBUGASSERT(idx < s->toobig); + DEBUGASSERT(!s->leng || s->bufr); + DEBUGASSERT(a <= s->toobig); + DEBUGASSERT(!len || mem); + + if(fit > s->toobig) { + curlx_dyn_free(s); + return CURLE_TOO_LARGE; + } + else if(!a) { + DEBUGASSERT(!idx); + /* first invoke */ + if(MIN_FIRST_ALLOC > s->toobig) + a = s->toobig; + else if(fit < MIN_FIRST_ALLOC) + a = MIN_FIRST_ALLOC; + else + a = fit; + } + else { + while(a < fit) + a *= 2; + if(a > s->toobig) + /* no point in allocating a larger buffer than this is allowed to use */ + a = s->toobig; + } + + if(a != s->allc) { + void *p = curlx_realloc(s->bufr, a); + if(!p) { + curlx_dyn_free(s); + return CURLE_OUT_OF_MEMORY; + } + s->bufr = p; + s->allc = a; + } + + if(len) + memcpy(&s->bufr[idx], mem, len); + s->leng = idx + len; + s->bufr[s->leng] = 0; + return CURLE_OK; +} + +/* + * Clears the string, keeps the allocation. This can also be called on a + * buffer that already was freed. + */ +void curlx_dyn_reset(struct dynbuf *s) +{ + DEBUGASSERT(s); + DEBUGASSERT(s->init == DYNINIT); + DEBUGASSERT(!s->leng || s->bufr); + if(s->leng) + s->bufr[0] = 0; + s->leng = 0; +} + +/* + * Specify the size of the tail to keep (number of bytes from the end of the + * buffer). The rest is dropped. + */ +CURLcode curlx_dyn_tail(struct dynbuf *s, size_t trail) +{ + DEBUGASSERT(s); + DEBUGASSERT(s->init == DYNINIT); + DEBUGASSERT(!s->leng || s->bufr); + if(trail > s->leng) + return CURLE_BAD_FUNCTION_ARGUMENT; + else if(trail == s->leng) + return CURLE_OK; + else if(!trail) { + curlx_dyn_reset(s); + } + else { + memmove(&s->bufr[0], &s->bufr[s->leng - trail], trail); + s->leng = trail; + s->bufr[s->leng] = 0; + } + return CURLE_OK; +} + +/* + * Appends a buffer with length. + */ +CURLcode curlx_dyn_addn(struct dynbuf *s, const void *mem, size_t len) +{ + DEBUGASSERT(s); + DEBUGASSERT(s->init == DYNINIT); + DEBUGASSERT(!s->leng || s->bufr); + return dyn_nappend(s, mem, len); +} + +/* + * Append a null-terminated string at the end. + */ +CURLcode curlx_dyn_add(struct dynbuf *s, const char *str) +{ + size_t n; + DEBUGASSERT(str); + DEBUGASSERT(s); + DEBUGASSERT(s->init == DYNINIT); + DEBUGASSERT(!s->leng || s->bufr); + n = strlen(str); + return dyn_nappend(s, (const unsigned char *)str, n); +} + +/* + * Append a string vprintf()-style + */ +CURLcode curlx_dyn_vaddf(struct dynbuf *s, const char *fmt, va_list ap) +{ +#ifdef BUILDING_LIBCURL + int rc; + DEBUGASSERT(s); + DEBUGASSERT(s->init == DYNINIT); + DEBUGASSERT(!s->leng || s->bufr); + DEBUGASSERT(fmt); + rc = curlx_dyn_vprintf(s, fmt, ap); + + if(!rc) + return CURLE_OK; + else if(rc == MERR_TOO_LARGE) + return CURLE_TOO_LARGE; + return CURLE_OUT_OF_MEMORY; +#else + char *str; + str = curl_mvaprintf(fmt, ap); /* this allocs a new string to append */ + + if(str) { + CURLcode result = dyn_nappend(s, (const unsigned char *)str, strlen(str)); + curl_free(str); + return result; + } + /* If we failed, we cleanup the whole buffer and return error */ + curlx_dyn_free(s); + return CURLE_OUT_OF_MEMORY; +#endif +} + +/* + * Append a string printf()-style + */ +CURLcode curlx_dyn_addf(struct dynbuf *s, const char *fmt, ...) +{ + CURLcode result; + va_list ap; + DEBUGASSERT(s); + DEBUGASSERT(s->init == DYNINIT); + DEBUGASSERT(!s->leng || s->bufr); + DEBUGASSERT(strcmp(fmt, "%s")); /* use curlx_dyn_add instead */ + va_start(ap, fmt); + result = curlx_dyn_vaddf(s, fmt, ap); + va_end(ap); + return result; +} + +/* + * Returns a pointer to the buffer. + */ +char *curlx_dyn_ptr(const struct dynbuf *s) +{ + DEBUGASSERT(s); + DEBUGASSERT(s->init == DYNINIT); + DEBUGASSERT(!s->leng || s->bufr); + return s->bufr; +} + +char *curlx_dyn_take(struct dynbuf *s, size_t *plen) +{ + char *ptr = s->bufr; + DEBUGASSERT(s); + DEBUGASSERT(s->init == DYNINIT); + *plen = s->leng; + s->bufr = NULL; + s->leng = 0; + s->allc = 0; + return ptr; +} + +/* + * Returns an unsigned pointer to the buffer. + */ +unsigned char *curlx_dyn_uptr(const struct dynbuf *s) +{ + DEBUGASSERT(s); + DEBUGASSERT(s->init == DYNINIT); + DEBUGASSERT(!s->leng || s->bufr); + return (unsigned char *)s->bufr; +} + +/* + * Returns the length of the buffer. + */ +size_t curlx_dyn_len(const struct dynbuf *s) +{ + DEBUGASSERT(s); + DEBUGASSERT(s->init == DYNINIT); + DEBUGASSERT(!s->leng || s->bufr); + return s->leng; +} + +/* + * Set a new (smaller) length. + */ +CURLcode curlx_dyn_setlen(struct dynbuf *s, size_t set) +{ + DEBUGASSERT(s); + DEBUGASSERT(s->init == DYNINIT); + DEBUGASSERT(!s->leng || s->bufr); + if(set > s->leng) + return CURLE_BAD_FUNCTION_ARGUMENT; + s->leng = set; + s->bufr[s->leng] = 0; + return CURLE_OK; +} diff --git a/3rdparty/curl-8.21.0/lib/curlx/dynbuf.h b/3rdparty/curl-8.21.0/lib/curlx/dynbuf.h new file mode 100644 index 0000000000..0cf4a2c576 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/dynbuf.h @@ -0,0 +1,83 @@ +#ifndef HEADER_CURL_DYNBUF_H +#define HEADER_CURL_DYNBUF_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +struct dynbuf { + char *bufr; /* point to a null-terminated allocated buffer */ + size_t leng; /* number of bytes *EXCLUDING* the null-terminator */ + size_t allc; /* size of the current allocation */ + size_t toobig; /* size limit for the buffer */ +#ifdef DEBUGBUILD + int init; /* detect API usage mistakes */ +#endif +}; + +void curlx_dyn_init(struct dynbuf *s, size_t toobig); +void curlx_dyn_free(struct dynbuf *s); +CURLcode curlx_dyn_addn(struct dynbuf *s, const void *mem, size_t len) + WARN_UNUSED_RESULT; +CURLcode curlx_dyn_add(struct dynbuf *s, const char *str) + WARN_UNUSED_RESULT; +CURLcode curlx_dyn_addf(struct dynbuf *s, const char *fmt, ...) + WARN_UNUSED_RESULT CURL_PRINTF(2, 3); +CURLcode curlx_dyn_vaddf(struct dynbuf *s, const char *fmt, va_list ap) + WARN_UNUSED_RESULT CURL_PRINTF(2, 0); +void curlx_dyn_reset(struct dynbuf *s); +CURLcode curlx_dyn_tail(struct dynbuf *s, size_t trail); +CURLcode curlx_dyn_setlen(struct dynbuf *s, size_t set); +char *curlx_dyn_ptr(const struct dynbuf *s); +unsigned char *curlx_dyn_uptr(const struct dynbuf *s); +size_t curlx_dyn_len(const struct dynbuf *s); + +/* returns 0 on success, -1 on error */ +/* The implementation of this function exists in mprintf.c */ +int curlx_dyn_vprintf(struct dynbuf *dyn, const char *format, va_list args); + +/* Take the buffer out of the dynbuf. Caller has ownership and + * dynbuf resets to initial state. */ +char *curlx_dyn_take(struct dynbuf *s, size_t *plen); + +/* Dynamic buffer max sizes */ +#define MAX_DYNBUF_SIZE (SIZE_MAX / 2) + +#define DYN_DOH_RESPONSE 3000 +#define DYN_DOH_CNAME 256 +#define DYN_PAUSE_BUFFER (64 * 1024 * 1024) +#define DYN_HAXPROXY 2048 +#define DYN_HTTP_REQUEST (1024 * 1024) +#define DYN_APRINTF 8000000 +#define DYN_RTSP_REQ_HEADER (64 * 1024) +#define DYN_TRAILERS (64 * 1024) +#define DYN_PROXY_CONNECT_HEADERS 16384 +#define DYN_QLOG_NAME 1024 +#define DYN_H1_TRAILER 4096 +#define DYN_PINGPPONG_CMD (64 * 1024) +#define DYN_IMAP_CMD (64 * 1024) +#define DYN_MQTT_RECV (64 * 1024) +#define DYN_MQTT_SEND 0xFFFFFFF +#define DYN_CRLFILE_SIZE (400 * 1024 * 1024) /* 400MiB */ +#define DYN_CERTFILE_SIZE (100 * 1024) /* 100KiB */ +#define DYN_KEYFILE_SIZE (100 * 1024) /* 100KiB */ +#endif diff --git a/3rdparty/curl-8.21.0/lib/curlx/fopen.c b/3rdparty/curl-8.21.0/lib/curlx/fopen.c new file mode 100644 index 0000000000..37ca02671a --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/fopen.c @@ -0,0 +1,508 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "curlx/fopen.h" + +int curlx_fseek(void *stream, curl_off_t offset, int whence) +{ +#ifdef _WIN32 + return _fseeki64(stream, (__int64)offset, whence); +#elif defined(HAVE_FSEEKO) && defined(HAVE_DECL_FSEEKO) + return fseeko(stream, (off_t)offset, whence); +#else + if(offset > LONG_MAX) + return -1; + return fseek(stream, (long)offset, whence); +#endif +} + +#ifdef _WIN32 + +#include /* for _SH_DENYNO */ + +#include "curlx/multibyte.h" +#include "curlx/timeval.h" + +#ifdef CURL_MEMDEBUG +/* + * Use system allocators to avoid infinite recursion when called by curl's + * memory tracker memdebug functions. + */ +#define CURLX_MALLOC(x) malloc(x) +#define CURLX_FREE(x) free(x) +#else +#define CURLX_MALLOC(x) curlx_malloc(x) +#define CURLX_FREE(x) curlx_free(x) +#endif + +#ifdef _UNICODE +static wchar_t *fn_convert_UTF8_to_wchar(const char *str_utf8) +{ + wchar_t *str_w = NULL; + + if(str_utf8) { + int str_w_len = MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, + str_utf8, -1, NULL, 0); + if(str_w_len > 0) { + str_w = CURLX_MALLOC(str_w_len * sizeof(wchar_t)); + if(str_w) { + if(MultiByteToWideChar(CP_UTF8, 0, + str_utf8, -1, str_w, str_w_len) == 0) { + CURLX_FREE(str_w); + return NULL; + } + } + } + } + return str_w; +} +#endif + +/* declare GetFullPathNameW for mingw-w64 UWP builds targeting old Windows */ +#if defined(CURL_WINDOWS_UWP) && defined(__MINGW32__) && \ + (_WIN32_WINNT < _WIN32_WINNT_WIN10) +WINBASEAPI DWORD WINAPI GetFullPathNameW(LPCWSTR, DWORD, LPWSTR, LPWSTR *); +#endif + +/* Fix excessive paths (paths that exceed MAX_PATH length of 260). + * + * This is a helper function to fix paths that would exceed the MAX_PATH + * limitation check done by Windows APIs. It does so by normalizing the passed + * in filename or path 'in' to its full canonical path, and if that path is + * longer than MAX_PATH then setting 'out' to "\\?\" prefix + that full path. + * + * For example 'in' filename255chars in current directory C:\foo\bar is + * fixed as \\?\C:\foo\bar\filename255chars for 'out' which tells Windows + * it is ok to access that filename even though the actual full path is longer + * than 260 chars. + * + * For non-Unicode builds this function may fail sometimes because only the + * Unicode versions of some Windows API functions can access paths longer than + * MAX_PATH, for example GetFullPathNameW which is used in this function. When + * the full path is then converted from Unicode to multibyte that fails if any + * directories in the path contain characters not in the current codepage. + */ +static bool fix_excessive_path(const TCHAR *in, TCHAR **out) +{ + size_t needed, count; + const wchar_t *in_w; + wchar_t *fbuf = NULL; + + /* MS documented "approximate" limit for the maximum path length */ + const size_t max_path_len = 32767; + +#ifndef _UNICODE + wchar_t *ibuf = NULL; + char *obuf = NULL; +#endif + + *out = NULL; + + /* skip paths already normalized */ + if(!_tcsncmp(in, _T("\\\\?\\"), 4)) + goto cleanup; + +#ifndef _UNICODE + /* convert multibyte input to unicode */ + if(mbstowcs_s(&needed, NULL, 0, in, 0)) + goto cleanup; + if(!needed || needed >= max_path_len) + goto cleanup; + ibuf = CURLX_MALLOC(needed * sizeof(wchar_t)); + if(!ibuf) + goto cleanup; + if(mbstowcs_s(&count, ibuf, needed, in, needed - 1)) + goto cleanup; + if(count != needed) + goto cleanup; + in_w = ibuf; +#else + in_w = in; +#endif + + /* GetFullPathNameW returns the normalized full path in unicode. It converts + forward slashes to backslashes, processes .. to remove directory segments, + etc. Unlike GetFullPathNameA it can process paths that exceed MAX_PATH. */ + needed = (size_t)GetFullPathNameW(in_w, 0, NULL, NULL); + if(!needed || needed > max_path_len) + goto cleanup; + /* skip paths that are not excessive and do not need modification */ + if(needed <= MAX_PATH) + goto cleanup; + fbuf = CURLX_MALLOC(needed * sizeof(wchar_t)); + if(!fbuf) + goto cleanup; + count = (size_t)GetFullPathNameW(in_w, (DWORD)needed, fbuf, NULL); + if(!count || count >= needed) + goto cleanup; + + /* prepend \\?\ or \\?\UNC\ to the excessively long path. + * + * c:\longpath ---> \\?\c:\longpath + * \\.\c:\longpath ---> \\?\c:\longpath + * \\?\c:\longpath ---> \\?\c:\longpath (unchanged) + * \\server\c$\longpath ---> \\?\UNC\server\c$\longpath + * + * https://learn.microsoft.com/dotnet/standard/io/file-path-formats + */ + if(!wcsncmp(fbuf, L"\\\\?\\", 4)) + ; /* do nothing */ + else if(!wcsncmp(fbuf, L"\\\\.\\", 4)) + fbuf[2] = '?'; + else if(!wcsncmp(fbuf, L"\\\\.", 3) || !wcsncmp(fbuf, L"\\\\?", 3)) { + /* Unexpected, not UNC. The formatting doc does not allow this AFAICT. */ + goto cleanup; + } + else { + wchar_t *temp; + + if(!wcsncmp(fbuf, L"\\\\", 2)) { + /* "\\?\UNC\" + full path without "\\" + null */ + needed = 8 + (count - 2) + 1; + if(needed > max_path_len) + goto cleanup; + + temp = CURLX_MALLOC(needed * sizeof(wchar_t)); + if(!temp) + goto cleanup; + + if(wcsncpy_s(temp, needed, L"\\\\?\\UNC\\", 8)) { + CURLX_FREE(temp); + goto cleanup; + } + if(wcscpy_s(temp + 8, needed, fbuf + 2)) { + CURLX_FREE(temp); + goto cleanup; + } + } + else { + /* "\\?\" + full path + null */ + needed = 4 + count + 1; + if(needed > max_path_len) + goto cleanup; + + temp = CURLX_MALLOC(needed * sizeof(wchar_t)); + if(!temp) + goto cleanup; + + if(wcsncpy_s(temp, needed, L"\\\\?\\", 4)) { + CURLX_FREE(temp); + goto cleanup; + } + if(wcscpy_s(temp + 4, needed, fbuf)) { + CURLX_FREE(temp); + goto cleanup; + } + } + + CURLX_FREE(fbuf); + fbuf = temp; + } + +#ifndef _UNICODE + /* convert unicode full path to multibyte output */ + if(wcstombs_s(&needed, NULL, 0, fbuf, 0)) + goto cleanup; + if(!needed || needed >= max_path_len) + goto cleanup; + obuf = CURLX_MALLOC(needed); + if(!obuf) + goto cleanup; + if(wcstombs_s(&count, obuf, needed, fbuf, needed - 1)) + goto cleanup; + if(count != needed) + goto cleanup; + *out = obuf; + obuf = NULL; +#else + *out = fbuf; + fbuf = NULL; +#endif + +cleanup: + CURLX_FREE(fbuf); +#ifndef _UNICODE + CURLX_FREE(ibuf); + CURLX_FREE(obuf); +#endif + return !!*out; +} + +#ifndef CURL_WINDOWS_UWP +HANDLE curlx_CreateFile(const char *filename, + DWORD dwDesiredAccess, + DWORD dwShareMode, + LPSECURITY_ATTRIBUTES lpSecurityAttributes, + DWORD dwCreationDisposition, + DWORD dwFlagsAndAttributes, + HANDLE hTemplateFile) +{ + HANDLE handle = INVALID_HANDLE_VALUE; + +#ifdef UNICODE + TCHAR *filename_t = curlx_convert_UTF8_to_wchar(filename); +#else + const TCHAR *filename_t = filename; +#endif + + if(filename_t) { + TCHAR *fixed = NULL; + const TCHAR *target = NULL; + + if(fix_excessive_path(filename_t, &fixed)) + target = fixed; + else + target = filename_t; + /* !checksrc! disable BANNEDFUNC 1 */ + handle = CreateFile(target, + dwDesiredAccess, + dwShareMode, + lpSecurityAttributes, + dwCreationDisposition, + dwFlagsAndAttributes, + hTemplateFile); + CURLX_FREE(fixed); +#ifdef UNICODE + curlx_free(filename_t); +#endif + } + + return handle; +} +#endif /* !CURL_WINDOWS_UWP */ + +int curlx_win32_open(const char *filename, int oflag, ...) +{ + int pmode = 0; + int res = -1; + TCHAR *fixed = NULL; + const TCHAR *target = NULL; + +#ifdef _UNICODE + wchar_t *filename_w = fn_convert_UTF8_to_wchar(filename); +#endif + + va_list param; + va_start(param, oflag); + if(oflag & O_CREAT) + pmode = va_arg(param, int); + va_end(param); + +#ifdef _UNICODE + if(filename_w) { + if(fix_excessive_path(filename_w, &fixed)) + target = fixed; + else + target = filename_w; + errno = _wsopen_s(&res, target, oflag, _SH_DENYNO, pmode); + CURLX_FREE(filename_w); + } + else + /* !checksrc! disable ERRNOVAR 1 */ + errno = EINVAL; +#else + if(fix_excessive_path(filename, &fixed)) + target = fixed; + else + target = filename; + errno = _sopen_s(&res, target, oflag, _SH_DENYNO, pmode); +#endif + + CURLX_FREE(fixed); + return res; +} + +FILE *curlx_win32_fopen(const char *filename, const char *mode) +{ + FILE *file = NULL; + TCHAR *fixed = NULL; + const TCHAR *target = NULL; + +#ifdef _UNICODE + wchar_t *filename_w = fn_convert_UTF8_to_wchar(filename); + wchar_t *mode_w = fn_convert_UTF8_to_wchar(mode); + if(filename_w && mode_w) { + if(fix_excessive_path(filename_w, &fixed)) + target = fixed; + else + target = filename_w; + file = _wfsopen(target, mode_w, _SH_DENYNO); + } + else + /* !checksrc! disable ERRNOVAR 1 */ + errno = EINVAL; + CURLX_FREE(filename_w); + CURLX_FREE(mode_w); +#else + if(fix_excessive_path(filename, &fixed)) + target = fixed; + else + target = filename; + file = _fsopen(target, mode, _SH_DENYNO); +#endif + + CURLX_FREE(fixed); + return file; +} + +#if defined(__MINGW32__) && (__MINGW64_VERSION_MAJOR < 5) +_CRTIMP errno_t __cdecl freopen_s(FILE **file, const char *filename, + const char *mode, FILE *stream); +#endif + +FILE *curlx_win32_freopen(const char *filename, const char *mode, FILE *fp) +{ + FILE *file = NULL; + TCHAR *fixed = NULL; + const TCHAR *target = NULL; + +#ifdef _UNICODE + wchar_t *filename_w = fn_convert_UTF8_to_wchar(filename); + wchar_t *mode_w = fn_convert_UTF8_to_wchar(mode); + if(filename_w && mode_w) { + if(fix_excessive_path(filename_w, &fixed)) + target = fixed; + else + target = filename_w; + errno = _wfreopen_s(&file, target, mode_w, fp); + } + else + /* !checksrc! disable ERRNOVAR 1 */ + errno = EINVAL; + CURLX_FREE(filename_w); + CURLX_FREE(mode_w); +#else + if(fix_excessive_path(filename, &fixed)) + target = fixed; + else + target = filename; + errno = freopen_s(&file, target, mode, fp); +#endif + + CURLX_FREE(fixed); + return file; +} + +int curlx_win32_stat(const char *path, curlx_struct_stat *buffer) +{ + int res = -1; + TCHAR *fixed = NULL; + const TCHAR *target = NULL; + +#ifdef _UNICODE + wchar_t *path_w = curlx_convert_UTF8_to_wchar(path); + if(path_w) { + if(fix_excessive_path(path_w, &fixed)) + target = fixed; + else + target = path_w; + res = _wstati64(target, buffer); + curlx_free(path_w); + } + else + /* !checksrc! disable ERRNOVAR 1 */ + errno = EINVAL; +#else + if(fix_excessive_path(path, &fixed)) + target = fixed; + else + target = path; + res = _stati64(target, buffer); +#endif + + CURLX_FREE(fixed); + return res; +} + +#if !defined(CURL_DISABLE_HTTP) || !defined(CURL_DISABLE_COOKIES) || \ + !defined(CURL_DISABLE_ALTSVC) +/* rename() on Windows does not overwrite, so we cannot use it here. + MoveFileEx() does overwrite and is usually atomic but fails when there are + open handles to the file. */ +int curlx_win32_rename(const char *oldpath, const char *newpath) +{ + int res = -1; /* fail */ + +#ifdef UNICODE + TCHAR *tchar_oldpath = curlx_convert_UTF8_to_wchar(oldpath); + TCHAR *tchar_newpath = curlx_convert_UTF8_to_wchar(newpath); +#else + const TCHAR *tchar_oldpath = oldpath; + const TCHAR *tchar_newpath = newpath; +#endif + + if(tchar_oldpath && tchar_newpath) { + const int max_wait_ms = 1000; + struct curltime start; + + TCHAR *oldpath_fixed = NULL; + TCHAR *newpath_fixed = NULL; + const TCHAR *target_oldpath; + const TCHAR *target_newpath; + + if(fix_excessive_path(tchar_oldpath, &oldpath_fixed)) + target_oldpath = oldpath_fixed; + else + target_oldpath = tchar_oldpath; + + if(fix_excessive_path(tchar_newpath, &newpath_fixed)) + target_newpath = newpath_fixed; + else + target_newpath = tchar_newpath; + + start = curlx_now(); + + for(;;) { + timediff_t diff; + /* !checksrc! disable BANNEDFUNC 1 */ + if(MoveFileEx(target_oldpath, target_newpath, + MOVEFILE_REPLACE_EXISTING)) { + res = 0; /* success */ + break; + } + diff = curlx_timediff_ms(curlx_now(), start); + if(diff < 0 || diff > max_wait_ms) { + break; + } + Sleep(1); + } + + CURLX_FREE(oldpath_fixed); + CURLX_FREE(newpath_fixed); + } + +#ifdef UNICODE + curlx_free(tchar_oldpath); + curlx_free(tchar_newpath); +#endif + + return res; +} +#endif + +#undef CURLX_MALLOC +#undef CURLX_FREE + +#endif /* _WIN32 */ diff --git a/3rdparty/curl-8.21.0/lib/curlx/fopen.h b/3rdparty/curl-8.21.0/lib/curlx/fopen.h new file mode 100644 index 0000000000..b64fbf6514 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/fopen.h @@ -0,0 +1,87 @@ +#ifndef HEADER_CURLX_FOPEN_H +#define HEADER_CURLX_FOPEN_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "curlx/multibyte.h" + +#ifdef HAVE_FCNTL_H +#include /* for open() and attributes */ +#endif + +int curlx_fseek(void *stream, curl_off_t offset, int whence); + +#ifdef _WIN32 +#include /* for _fstati64(), struct _stati64 */ +#ifndef CURL_WINDOWS_UWP +HANDLE curlx_CreateFile(const char *filename, + DWORD dwDesiredAccess, + DWORD dwShareMode, + LPSECURITY_ATTRIBUTES lpSecurityAttributes, + DWORD dwCreationDisposition, + DWORD dwFlagsAndAttributes, + HANDLE hTemplateFile); +#endif /* !CURL_WINDOWS_UWP */ +#define curlx_fstat _fstati64 +#define curlx_struct_stat struct _stati64 +FILE *curlx_win32_fopen(const char *filename, const char *mode); +FILE *curlx_win32_freopen(const char *filename, const char *mode, FILE *fp); +int curlx_win32_stat(const char *path, curlx_struct_stat *buffer); +int curlx_win32_open(const char *filename, int oflag, ...); +int curlx_win32_rename(const char *oldpath, const char *newpath); +#define CURLX_FOPEN_LOW curlx_win32_fopen +#define CURLX_FREOPEN_LOW curlx_win32_freopen +#define CURLX_FDOPEN_LOW _fdopen +#define curlx_stat curlx_win32_stat +#define curlx_open curlx_win32_open +#define curlx_close _close +#define curlx_rename curlx_win32_rename +#else +#define curlx_fstat fstat +#define curlx_struct_stat struct stat +#define CURLX_FOPEN_LOW fopen +#define CURLX_FREOPEN_LOW freopen +#define CURLX_FDOPEN_LOW fdopen +#define curlx_stat stat +#define curlx_open open +#define curlx_close close +#define curlx_rename rename +#endif + +#ifdef CURL_MEMDEBUG +#define curlx_fopen(file, mode) curl_dbg_fopen(file, mode, __LINE__, __FILE__) +#define curlx_freopen(file, mode, fh) \ + curl_dbg_freopen(file, mode, fh, __LINE__, __FILE__) +#define curlx_fdopen(file, mode) \ + curl_dbg_fdopen(file, mode, __LINE__, __FILE__) +#define curlx_fclose(file) curl_dbg_fclose(file, __LINE__, __FILE__) +#else +#define curlx_fopen CURLX_FOPEN_LOW +#define curlx_freopen CURLX_FREOPEN_LOW +#define curlx_fdopen CURLX_FDOPEN_LOW +#define curlx_fclose fclose +#endif + +#endif /* HEADER_CURLX_FOPEN_H */ diff --git a/3rdparty/curl-8.21.0/lib/curlx/inet_ntop.c b/3rdparty/curl-8.21.0/lib/curlx/inet_ntop.c new file mode 100644 index 0000000000..803b9887ac --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/inet_ntop.c @@ -0,0 +1,222 @@ +/* + * Copyright (C) 1996-2022 Internet Software Consortium. + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND INTERNET SOFTWARE CONSORTIUM + * DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL + * INTERNET SOFTWARE CONSORTIUM BE LIABLE FOR ANY SPECIAL, DIRECT, + * INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING + * FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, + * NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION + * WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + * + * SPDX-License-Identifier: ISC + */ +#include "curl_setup.h" + +#ifndef HAVE_INET_NTOP + +#ifdef HAVE_SYS_PARAM_H +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_ARPA_INET_H +#include +#endif + +#include "curlx/inet_ntop.h" +#include "curlx/snprintf.h" +#include "curlx/strcopy.h" + +#define IN6ADDRSZ 16 +/* #define INADDRSZ 4 */ +#define INT16SZ 2 + +/* + * If USE_IPV6 is disabled, we still want to parse IPv6 addresses, so make + * sure we have _some_ value for AF_INET6 without polluting our fake value + * everywhere. + */ +#if !defined(USE_IPV6) && !defined(AF_INET6) +#define AF_INET6 (AF_INET + 1) +#endif + +/* + * Format an IPv4 address, more or less like inet_ntop(). + * + * Returns `dst' (as a const) + * Note: + * - uses no static variables + * - takes an unsigned char* not an in_addr as input + */ +static char *inet_ntop4(const unsigned char *src, char *dst, size_t size) +{ + char tmp[sizeof("255.255.255.255")]; + size_t len; + + DEBUGASSERT(size >= 16); + + /* this snprintf() does not overflow the buffer. */ + SNPRINTF(tmp, sizeof(tmp), "%d.%d.%d.%d", + ((int)((unsigned char)src[0])) & 0xff, + ((int)((unsigned char)src[1])) & 0xff, + ((int)((unsigned char)src[2])) & 0xff, + ((int)((unsigned char)src[3])) & 0xff); + + len = strlen(tmp); + if(len == 0 || len >= size) { +#ifdef USE_WINSOCK + errno = WSAEINVAL; +#else + errno = ENOSPC; +#endif + return NULL; + } + curlx_strcopy(dst, size, tmp, len); + return dst; +} + +/* + * Convert IPv6 binary address into presentation (printable) format. + */ +static char *inet_ntop6(const unsigned char *src, char *dst, size_t size) +{ + /* + * Note that int32_t and int16_t need only be "at least" large enough + * to contain a value of the specified size. On some systems, like + * Crays, there is no such thing as an integer variable with 16 bits. + * Keep this in mind if you think this function should have been coded + * to use pointer overlays. All the world's not a VAX. + */ + char tmp[sizeof("ffff:ffff:ffff:ffff:ffff:ffff:255.255.255.255")]; + char *tp; + struct { + int base; + int len; + } best, cur; + unsigned int words[IN6ADDRSZ / INT16SZ]; + int i; + + /* Preprocess: + * Copy the input (bytewise) array into a wordwise array. + * Find the longest run of 0x00's in src[] for :: shorthanding. + */ + memset(words, '\0', sizeof(words)); + for(i = 0; i < IN6ADDRSZ; i++) + words[i / 2] |= ((unsigned int)src[i] << ((1 - (i % 2)) << 3)); + + best.base = -1; + cur.base = -1; + best.len = 0; + cur.len = 0; + + for(i = 0; i < (IN6ADDRSZ / INT16SZ); i++) { + if(words[i] == 0) { + if(cur.base == -1) { + cur.base = i; + cur.len = 1; + } + else + cur.len++; + } + else if(cur.base != -1) { + if(best.base == -1 || cur.len > best.len) + best = cur; + cur.base = -1; + } + } + if((cur.base != -1) && (best.base == -1 || cur.len > best.len)) + best = cur; + if(best.base != -1 && best.len < 2) + best.base = -1; + /* Format the result. */ + tp = tmp; + for(i = 0; i < (IN6ADDRSZ / INT16SZ); i++) { + /* Are we inside the best run of 0x00's? */ + if(best.base != -1 && i >= best.base && i < (best.base + best.len)) { + if(i == best.base) + *tp++ = ':'; + continue; + } + + /* Are we following an initial run of 0x00s or any real hex? + */ + if(i) + *tp++ = ':'; + + /* Is this address an encapsulated IPv4? + */ + if(i == 6 && best.base == 0 && + (best.len == 6 || (best.len == 5 && words[5] == 0xffff))) { + if(!inet_ntop4(src + 12, tp, sizeof(tmp) - (tp - tmp))) { + return NULL; + } + tp += strlen(tp); + break; + } + else { + /* Lower-case digits. Cannot use the set from mprintf.c since this + needs to work as a curlx function */ + static const unsigned char ldigits[] = "0123456789abcdef"; + + unsigned int w = words[i]; + /* output lowercase 16-bit hex number but ignore leading zeroes */ + if(w & 0xf000) + *tp++ = ldigits[(w & 0xf000) >> 12]; + if(w & 0xff00) + *tp++ = ldigits[(w & 0x0f00) >> 8]; + if(w & 0xfff0) + *tp++ = ldigits[(w & 0x00f0) >> 4]; + *tp++ = ldigits[(w & 0x000f)]; + } + } + + /* Was it a trailing run of 0x00's? + */ + if(best.base != -1 && (best.base + best.len) == (IN6ADDRSZ / INT16SZ)) + *tp++ = ':'; + + /* Check for overflow, copy, and we are done. */ + if((size_t)(tp - tmp) >= size) { +#ifdef USE_WINSOCK + errno = WSAEINVAL; +#else + errno = ENOSPC; +#endif + return NULL; + } + + curlx_strcopy(dst, size, tmp, tp - tmp); + return dst; +} + +/* + * Convert a network format address to presentation format. + * + * Returns pointer to presentation format address (`buf'). + * Returns NULL on error and errno set with the specific + * error, EAFNOSUPPORT or ENOSPC. + * + * On Windows we store the error in the thread errno, not in the Winsock error + * code. This is to avoid losing the actual last Winsock error. When this + * function returns NULL, check errno not SOCKERRNO. + */ +char *curlx_inet_ntop(int af, const void *src, char *buf, size_t size) +{ + switch(af) { + case AF_INET: + return inet_ntop4((const unsigned char *)src, buf, size); + case AF_INET6: + return inet_ntop6((const unsigned char *)src, buf, size); + default: + errno = SOCKEAFNOSUPPORT; + return NULL; + } +} +#endif /* HAVE_INET_NTOP */ diff --git a/3rdparty/curl-8.21.0/lib/curlx/inet_ntop.h b/3rdparty/curl-8.21.0/lib/curlx/inet_ntop.h new file mode 100644 index 0000000000..ba8299fe4e --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/inet_ntop.h @@ -0,0 +1,50 @@ +#ifndef HEADER_CURL_INET_NTOP_H +#define HEADER_CURL_INET_NTOP_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef HAVE_INET_NTOP +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifndef _WIN32 +#include +#endif +#ifdef HAVE_ARPA_INET_H +#include +#endif +#ifdef __AMIGA__ +#define curlx_inet_ntop(af, src, buf, size) \ + (char *)inet_ntop(af, CURL_UNCONST(src), (unsigned char *)(buf), \ + (curl_socklen_t)(size)) +#else +#define curlx_inet_ntop(af, src, buf, size) \ + inet_ntop(af, src, buf, (curl_socklen_t)(size)) +#endif +#else +char *curlx_inet_ntop(int af, const void *src, char *buf, size_t size); +#endif /* HAVE_INET_NTOP */ + +#endif /* HEADER_CURL_INET_NTOP_H */ diff --git a/3rdparty/curl-8.21.0/lib/curlx/inet_pton.c b/3rdparty/curl-8.21.0/lib/curlx/inet_pton.c new file mode 100644 index 0000000000..7994f258fe --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/inet_pton.c @@ -0,0 +1,221 @@ +/* This is from the BIND 4.9.4 release, modified to compile by itself */ + +/* Copyright (c) Internet Software Consortium. + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND INTERNET SOFTWARE CONSORTIUM DISCLAIMS + * ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES + * OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL INTERNET SOFTWARE + * CONSORTIUM BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL + * DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR + * PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS + * ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS + * SOFTWARE. + * + * SPDX-License-Identifier: ISC + */ +#include "curl_setup.h" + +#ifndef HAVE_INET_PTON + +#ifdef HAVE_SYS_PARAM_H +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_ARPA_INET_H +#include +#endif + +#include "curlx/inet_pton.h" +#include "curlx/strparse.h" + +#define IN6ADDRSZ 16 +#define INADDRSZ 4 +#define INT16SZ 2 + +/* + * If USE_IPV6 is disabled, we still want to parse IPv6 addresses, so make + * sure we have _some_ value for AF_INET6 without polluting our fake value + * everywhere. + */ +#if !defined(USE_IPV6) && !defined(AF_INET6) +#define AF_INET6 (AF_INET + 1) +#endif + +/* + * WARNING: Do not even consider trying to compile this on a system where + * sizeof(int) < 4. sizeof(int) > 4 is fine; all the world's not a VAX. + */ + +/* int inet_pton4(src, dst) + * like inet_aton() but without all the hexadecimal and shorthand. + * return: + * 1 if `src' is a valid dotted quad, else 0. + * notice: + * does not touch `dst' unless it is returning 1. + * author: + * Paul Vixie, 1996. + */ +static int inet_pton4(const char *src, unsigned char *dst) +{ + int saw_digit, octets, ch; + unsigned char tmp[INADDRSZ], *tp; + + saw_digit = 0; + octets = 0; + tp = tmp; + *tp = 0; + while((ch = (unsigned char)*src++) != '\0') { + if(ISDIGIT(ch)) { + unsigned int val = (*tp * 10) + (ch - '0'); + + if(saw_digit && *tp == 0) + return 0; + if(val > 255) + return 0; + *tp = (unsigned char)val; + if(!saw_digit) { + if(++octets > 4) + return 0; + saw_digit = 1; + } + } + else if(ch == '.' && saw_digit) { + if(octets == 4) + return 0; + *++tp = 0; + saw_digit = 0; + } + else + return 0; + } + if(octets < 4) + return 0; + memcpy(dst, tmp, INADDRSZ); + return 1; +} + +/* int inet_pton6(src, dst) + * convert presentation level address to network order binary form. + * return: + * 1 if `src' is a valid [RFC1884 2.2] address, else 0. + * notice: + * (1) does not touch `dst' unless it is returning 1. + * (2) :: in a full address is silently ignored. + * credit: + * inspired by Mark Andrews. + * author: + * Paul Vixie, 1996. + */ +static int inet_pton6(const char *src, unsigned char *dst) +{ + unsigned char tmp[IN6ADDRSZ], *tp, *endp, *colonp; + const char *curtok; + int ch, saw_xdigit; + size_t val; + + memset((tp = tmp), 0, IN6ADDRSZ); + endp = tp + IN6ADDRSZ; + colonp = NULL; + /* Leading :: requires some special handling. */ + if(*src == ':') + if(*++src != ':') + return 0; + curtok = src; + saw_xdigit = 0; + val = 0; + while((ch = (unsigned char)*src++) != '\0') { + if(ISXDIGIT(ch)) { + val <<= 4; + val |= curlx_hexval(ch); + if(++saw_xdigit > 4) + return 0; + continue; + } + if(ch == ':') { + curtok = src; + if(!saw_xdigit) { + if(colonp) + return 0; + colonp = tp; + continue; + } + if(tp + INT16SZ > endp) + return 0; + *tp++ = (unsigned char)((val >> 8) & 0xff); + *tp++ = (unsigned char)(val & 0xff); + saw_xdigit = 0; + val = 0; + continue; + } + if(ch == '.' && ((tp + INADDRSZ) <= endp) && + inet_pton4(curtok, tp) > 0) { + tp += INADDRSZ; + saw_xdigit = 0; + break; /* '\0' was seen by inet_pton4(). */ + } + return 0; + } + if(saw_xdigit) { + if(tp + INT16SZ > endp) + return 0; + *tp++ = (unsigned char)((val >> 8) & 0xff); + *tp++ = (unsigned char)(val & 0xff); + } + if(colonp) { + /* + * Since some memmove()'s erroneously fail to handle + * overlapping regions, we do the shift by hand. + */ + const ssize_t n = tp - colonp; + ssize_t i; + + if(tp == endp) + return 0; + for(i = 1; i <= n; i++) { + *(endp - i) = *(colonp + n - i); + *(colonp + n - i) = 0; + } + tp = endp; + } + if(tp != endp) + return 0; + memcpy(dst, tmp, IN6ADDRSZ); + return 1; +} + +/* int inet_pton(af, src, dst) + * convert from presentation format (which usually means ASCII printable) + * to network format (which is usually some kind of binary format). + * return: + * 1 if the address was valid for the specified address family + * 0 if the address was not valid (`dst' is untouched in this case) + * -1 if some other error occurred (`dst' is untouched in this case, too) + * notice: + * On Windows we store the error in the thread errno, not + * in the Winsock error code. This is to avoid losing the + * actual last Winsock error. When this function returns + * -1, check errno not SOCKERRNO. + * author: + * Paul Vixie, 1996. + */ +int curlx_inet_pton(int af, const char *src, void *dst) +{ + switch(af) { + case AF_INET: + return inet_pton4(src, (unsigned char *)dst); + case AF_INET6: + return inet_pton6(src, (unsigned char *)dst); + default: + errno = SOCKEAFNOSUPPORT; + return -1; + } + /* NOTREACHED */ +} + +#endif /* HAVE_INET_PTON */ diff --git a/3rdparty/curl-8.21.0/lib/curlx/inet_pton.h b/3rdparty/curl-8.21.0/lib/curlx/inet_pton.h new file mode 100644 index 0000000000..02ae7f2269 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/inet_pton.h @@ -0,0 +1,49 @@ +#ifndef HEADER_CURL_INET_PTON_H +#define HEADER_CURL_INET_PTON_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef HAVE_INET_PTON +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifndef _WIN32 +#include +#endif +#ifdef HAVE_ARPA_INET_H +#include +#endif +#ifdef __AMIGA__ +#define curlx_inet_pton(x, y, z) \ + inet_pton(x, (unsigned char *)CURL_UNCONST(y), z) +#else +#define curlx_inet_pton(x, y, z) \ + inet_pton(x, y, z) +#endif +#else +int curlx_inet_pton(int af, const char *src, void *dst); +#endif /* HAVE_INET_PTON */ + +#endif /* HEADER_CURL_INET_PTON_H */ diff --git a/3rdparty/curl-8.21.0/lib/curlx/multibyte.c b/3rdparty/curl-8.21.0/lib/curlx/multibyte.c new file mode 100644 index 0000000000..715d2b8dc2 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/multibyte.c @@ -0,0 +1,78 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if defined(_WIN32) && defined(UNICODE) + +#include "curlx/multibyte.h" + +/* + * MultiByte conversions using Windows kernel32 library. + */ + +wchar_t *curlx_convert_UTF8_to_wchar(const char *str_utf8) +{ + wchar_t *str_w = NULL; + + if(str_utf8) { + int str_w_len = MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, + str_utf8, -1, NULL, 0); + if(str_w_len > 0) { + str_w = curlx_malloc(str_w_len * sizeof(wchar_t)); + if(str_w) { + if(MultiByteToWideChar(CP_UTF8, 0, str_utf8, -1, str_w, + str_w_len) == 0) { + curlx_free(str_w); + return NULL; + } + } + } + } + + return str_w; +} + +char *curlx_convert_wchar_to_UTF8(const wchar_t *str_w) +{ + char *str_utf8 = NULL; + + if(str_w) { + int bytes = WideCharToMultiByte(CP_UTF8, 0, str_w, -1, + NULL, 0, NULL, NULL); + if(bytes > 0) { + str_utf8 = curlx_malloc(bytes); + if(str_utf8) { + if(WideCharToMultiByte(CP_UTF8, 0, str_w, -1, str_utf8, bytes, + NULL, NULL) == 0) { + curlx_free(str_utf8); + return NULL; + } + } + } + } + + return str_utf8; +} + +#endif /* _WIN32 && UNICODE */ diff --git a/3rdparty/curl-8.21.0/lib/curlx/multibyte.h b/3rdparty/curl-8.21.0/lib/curlx/multibyte.h new file mode 100644 index 0000000000..8863fb0249 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/multibyte.h @@ -0,0 +1,73 @@ +#ifndef HEADER_CURL_MULTIBYTE_H +#define HEADER_CURL_MULTIBYTE_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef _WIN32 + +/* + * Macros curlx_convert_UTF8_to_tchar(), curlx_convert_tchar_to_UTF8() + * main purpose is to minimize the number of preprocessor conditional + * directives needed by code using these to differentiate Unicode from + * non-Unicode builds. + * + * In the case of a non-Unicode build the tchar strings are char strings that + * are duplicated via strdup and remain in whatever the passed in encoding is, + * which is assumed to be UTF-8 but may be other encoding. Therefore the + * significance of the conversion functions is primarily for Unicode builds. + */ + +#ifdef UNICODE + +/* MultiByte conversions using Windows kernel32 library. */ +wchar_t *curlx_convert_UTF8_to_wchar(const char *str_utf8); +char *curlx_convert_wchar_to_UTF8(const wchar_t *str_w); + +#define curlx_convert_UTF8_to_tchar(ptr) curlx_convert_UTF8_to_wchar(ptr) +#define curlx_convert_tchar_to_UTF8(ptr) curlx_convert_wchar_to_UTF8(ptr) + +typedef union { + unsigned short *tchar_ptr; + const unsigned short *const_tchar_ptr; + unsigned short *tbyte_ptr; + const unsigned short *const_tbyte_ptr; +} xcharp_u; + +#else /* !UNICODE */ + +#define curlx_convert_UTF8_to_tchar(ptr) curlx_strdup(ptr) +#define curlx_convert_tchar_to_UTF8(ptr) curlx_strdup(ptr) + +typedef union { + char *tchar_ptr; + const char *const_tchar_ptr; + unsigned char *tbyte_ptr; + const unsigned char *const_tbyte_ptr; +} xcharp_u; + +#endif /* UNICODE */ +#endif /* _WIN32 */ + +#endif /* HEADER_CURL_MULTIBYTE_H */ diff --git a/3rdparty/curl-8.21.0/lib/curlx/nonblock.c b/3rdparty/curl-8.21.0/lib/curlx/nonblock.c new file mode 100644 index 0000000000..6f6458f2b3 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/nonblock.c @@ -0,0 +1,92 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef HAVE_SYS_IOCTL_H +#include +#endif +#ifdef HAVE_FCNTL_H +#include +#endif + +#ifdef __VMS +#include +#include +#endif + +#include "curlx/nonblock.h" + +/* + * curlx_nonblock() set the given socket to either blocking or non-blocking + * mode based on the 'nonblock' boolean argument. This function is highly + * portable. + */ +int curlx_nonblock(curl_socket_t sockfd, /* operate on this */ + int nonblock /* TRUE or FALSE */) +{ +#ifdef HAVE_FCNTL_O_NONBLOCK + /* most recent Unix versions */ + int flags; + flags = sfcntl(sockfd, F_GETFL, 0); + if(flags < 0) + return -1; + /* Check if the current file status flags have already satisfied + * the request, if so, it is no need to call fcntl() to replicate it. + */ + if(!!(flags & O_NONBLOCK) == !!nonblock) + return 0; + if(nonblock) + flags |= O_NONBLOCK; + else + flags &= ~O_NONBLOCK; + return sfcntl(sockfd, F_SETFL, flags); + +#elif defined(HAVE_IOCTLSOCKET_CAMEL_FIONBIO) + + /* Amiga */ + long flags = nonblock ? 1L : 0L; + return IoctlSocket(sockfd, FIONBIO, (char *)&flags); + +#elif defined(HAVE_IOCTL_FIONBIO) + + /* older Unix versions */ + int flags = nonblock ? 1 : 0; + return ioctl(sockfd, FIONBIO, &flags); + +#elif defined(HAVE_IOCTLSOCKET_FIONBIO) + + /* Windows */ + unsigned long flags = nonblock ? 1UL : 0UL; + return ioctlsocket(sockfd, (long)FIONBIO, &flags); + +#elif defined(HAVE_SETSOCKOPT_SO_NONBLOCK) + + /* Orbis OS */ + long b = nonblock ? 1L : 0L; + return setsockopt(sockfd, SOL_SOCKET, SO_NONBLOCK, &b, sizeof(b)); + +#else +#error "no non-blocking method was found/used/set" +#endif +} diff --git a/3rdparty/curl-8.21.0/lib/curlx/nonblock.h b/3rdparty/curl-8.21.0/lib/curlx/nonblock.h new file mode 100644 index 0000000000..ee2cd286a7 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/nonblock.h @@ -0,0 +1,30 @@ +#ifndef HEADER_CURL_NONBLOCK_H +#define HEADER_CURL_NONBLOCK_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +int curlx_nonblock(curl_socket_t sockfd, /* operate on this */ + int nonblock /* TRUE or FALSE */); + +#endif /* HEADER_CURL_NONBLOCK_H */ diff --git a/3rdparty/curl-8.21.0/lib/curlx/snprintf.c b/3rdparty/curl-8.21.0/lib/curlx/snprintf.c new file mode 100644 index 0000000000..911c42e6ad --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/snprintf.c @@ -0,0 +1,49 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curlx/snprintf.h" + +#ifdef _WIN32 +#include + +/* Simplified wrapper for the Windows platform to use the correct symbol and + ensuring null-termination. Omit returning a length to keep it simple. */ +void curlx_win32_snprintf(char *buf, size_t maxlen, const char *fmt, ...) +{ + va_list ap; + if(!maxlen) + return; + va_start(ap, fmt); +#ifdef CURL_HAVE_DIAG +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Wformat-nonliteral" +#endif + /* !checksrc! disable BANNEDFUNC 1 */ + (void)vsnprintf(buf, maxlen, fmt, ap); +#ifdef CURL_HAVE_DIAG +#pragma GCC diagnostic pop +#endif + buf[maxlen - 1] = 0; + va_end(ap); +} +#endif /* _WIN32 */ diff --git a/3rdparty/curl-8.21.0/lib/curlx/snprintf.h b/3rdparty/curl-8.21.0/lib/curlx/snprintf.h new file mode 100644 index 0000000000..d6260e4e39 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/snprintf.h @@ -0,0 +1,45 @@ +#ifndef HEADER_CURLX_SNPRINTF_H +#define HEADER_CURLX_SNPRINTF_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +/* Raw snprintf() for curlx */ + +#ifdef _WIN32 +void curlx_win32_snprintf(char *buf, size_t maxlen, const char *fmt, ...) + CURL_PRINTF(3, 4); +#endif + +#ifdef WITHOUT_LIBCURL /* when built for the test servers */ +#ifdef _WIN32 +#define SNPRINTF curlx_win32_snprintf +#else +#define SNPRINTF snprintf +#endif +#else /* !WITHOUT_LIBCURL */ +#include +#define SNPRINTF curl_msnprintf +#endif /* WITHOUT_LIBCURL */ +#endif /* HEADER_CURLX_SNPRINTF_H */ diff --git a/3rdparty/curl-8.21.0/lib/curlx/strcopy.c b/3rdparty/curl-8.21.0/lib/curlx/strcopy.c new file mode 100644 index 0000000000..3b80930a19 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/strcopy.c @@ -0,0 +1,50 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "curlx/strcopy.h" + +/* + * curlx_strcopy() is a replacement for strcpy. + * + * Provide the target buffer @dest and size of the target buffer @dsize, If + * the source string @src with its *string length* @slen fits in the target + * buffer it is copied there - including storing a null-terminator. + * + * If the target buffer is too small, the copy is not performed but if the + * target buffer has a non-zero size it gets a null-terminator stored. + */ +void curlx_strcopy(char *dest, /* destination buffer */ + size_t dsize, /* size of target buffer */ + const char *src, /* source string */ + size_t slen) /* length of source string to copy */ +{ + DEBUGASSERT(slen < dsize); + if(slen < dsize) { + memcpy(dest, src, slen); + dest[slen] = 0; + } + else if(dsize) + dest[0] = 0; +} diff --git a/3rdparty/curl-8.21.0/lib/curlx/strcopy.h b/3rdparty/curl-8.21.0/lib/curlx/strcopy.h new file mode 100644 index 0000000000..d671149cb8 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/strcopy.h @@ -0,0 +1,32 @@ +#ifndef HEADER_CURLX_STRCOPY_H +#define HEADER_CURLX_STRCOPY_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +void curlx_strcopy(char *dest, + size_t dsize, /* size of target buffer */ + const char *src, + size_t slen); /* length of string to copy */ + +#endif /* HEADER_CURLX_STRCOPY_H */ diff --git a/3rdparty/curl-8.21.0/lib/curlx/strdup.c b/3rdparty/curl-8.21.0/lib/curlx/strdup.c new file mode 100644 index 0000000000..8e788ea34c --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/strdup.c @@ -0,0 +1,125 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef _WIN32 +#include +#endif + +#include "curlx/strdup.h" + +#ifdef _WIN32 +/*************************************************************************** + * + * curlx_wcsdup(source) + * + * Copies the 'source' wchar string to a newly allocated buffer (that is + * returned). Used by macro curlx_tcsdup(). + * + * Returns the new pointer or NULL on failure. + * + ***************************************************************************/ +wchar_t *curlx_wcsdup(const wchar_t *src) +{ + size_t length = wcslen(src); + + if(length > (SIZE_MAX / sizeof(wchar_t)) - 1) + return (wchar_t *)NULL; /* integer overflow */ + + return (wchar_t *)curlx_memdup(src, (length + 1) * sizeof(wchar_t)); +} +#endif + +/*************************************************************************** + * + * curlx_memdup(source, length) + * + * Copies the 'source' data to a newly allocated buffer (that is + * returned). Copies 'length' bytes. + * + * Returns the new pointer or NULL on failure. + * + ***************************************************************************/ +void *curlx_memdup(const void *src, size_t length) +{ + void *buffer = curlx_malloc(length); + if(!buffer) + return NULL; /* fail */ + + memcpy(buffer, src, length); + + return buffer; +} + +/*************************************************************************** + * + * curlx_memdup0(source, length) + * + * Copies the 'source' string to a newly allocated buffer (that is returned). + * Copies 'length' bytes then adds a null-terminator. + * + * Returns the new pointer or NULL on failure. + * + ***************************************************************************/ +void *curlx_memdup0(const char *src, size_t length) +{ + char *buf = (length < SIZE_MAX) ? curlx_malloc(length + 1) : NULL; + if(!buf) + return NULL; + if(length) { + DEBUGASSERT(src); /* must never be NULL */ + memcpy(buf, src, length); + } + buf[length] = 0; + return buf; +} + +#ifdef USE_CURLX_MEMZERO +static void *(* const volatile p_curlx_memset)(void *buf, int val, + size_t size) = memset; + +/* Local fallback in case there is no system function to securely zero a memory + buffer. */ +void curlx_memzero(void *buf, size_t size) +{ + if(buf) + p_curlx_memset(buf, 0, size); +} +#endif + +/* Free 'buf' after zeroing its content. */ +void curlx_freezero(void *buf, size_t size) +{ + if(buf) + curlx_memzero(buf, size); + curlx_free(buf); +} + +/* Free 'buf' after zeroing its content, where 'buf' is null-terminated. */ +void curlx_freezeroz(void *buf) +{ + if(buf) + curlx_memzero(buf, strlen(buf)); + curlx_free(buf); +} diff --git a/3rdparty/curl-8.21.0/lib/curlx/strdup.h b/3rdparty/curl-8.21.0/lib/curlx/strdup.h new file mode 100644 index 0000000000..0c4b14161e --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/strdup.h @@ -0,0 +1,33 @@ +#ifndef HEADER_CURLX_STRDUP_H +#define HEADER_CURLX_STRDUP_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef _WIN32 +wchar_t *curlx_wcsdup(const wchar_t *src); /* for curlx_tcsdup() */ +#endif +void *curlx_memdup(const void *src, size_t length); +void *curlx_memdup0(const char *src, size_t length); +#endif /* HEADER_CURLX_STRDUP_H */ diff --git a/3rdparty/curl-8.21.0/lib/curlx/strerr.c b/3rdparty/curl-8.21.0/lib/curlx/strerr.c new file mode 100644 index 0000000000..8e906cc6bd --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/strerr.c @@ -0,0 +1,329 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef HAVE_STRERROR_R +# if (!defined(HAVE_POSIX_STRERROR_R) && \ + !defined(HAVE_GLIBC_STRERROR_R)) || \ + (defined(HAVE_POSIX_STRERROR_R) && defined(HAVE_GLIBC_STRERROR_R)) +# error "strerror_r MUST be either POSIX, glibc style" +# endif +#endif + +#include "curlx/winapi.h" +#include "curlx/snprintf.h" +#include "curlx/strerr.h" +#include "curlx/strcopy.h" + +#ifdef USE_WINSOCK +/* This is a helper function for curlx_strerror that converts Winsock error + * codes (WSAGetLastError) to error messages. + * Returns NULL if no error message was found for error code. + */ +static const char *get_winsock_error(int err, char *buf, size_t len) +{ + VERBOSE(const char *p); + + if(!len) + return NULL; + + *buf = '\0'; + +#ifndef CURLVERBOSE + (void)err; + return NULL; +#else + switch(err) { + case WSAEINTR: + p = "Call interrupted"; + break; + case WSAEBADF: + p = "Bad file"; + break; + case WSAEACCES: + p = "Bad access"; + break; + case WSAEFAULT: + p = "Bad argument"; + break; + case WSAEINVAL: + p = "Invalid arguments"; + break; + case WSAEMFILE: + p = "Out of file descriptors"; + break; + case WSAEWOULDBLOCK: + p = "Call would block"; + break; + case WSAEINPROGRESS: + case WSAEALREADY: + p = "Blocking call in progress"; + break; + case WSAENOTSOCK: + p = "Descriptor is not a socket"; + break; + case WSAEDESTADDRREQ: + p = "Need destination address"; + break; + case WSAEMSGSIZE: + p = "Bad message size"; + break; + case WSAEPROTOTYPE: + p = "Bad protocol"; + break; + case WSAENOPROTOOPT: + p = "Protocol option is unsupported"; + break; + case WSAEPROTONOSUPPORT: + p = "Protocol is unsupported"; + break; + case WSAESOCKTNOSUPPORT: + p = "Socket is unsupported"; + break; + case WSAEOPNOTSUPP: + p = "Operation not supported"; + break; + case WSAEAFNOSUPPORT: + p = "Address family not supported"; + break; + case WSAEPFNOSUPPORT: + p = "Protocol family not supported"; + break; + case WSAEADDRINUSE: + p = "Address already in use"; + break; + case WSAEADDRNOTAVAIL: + p = "Address not available"; + break; + case WSAENETDOWN: + p = "Network down"; + break; + case WSAENETUNREACH: + p = "Network unreachable"; + break; + case WSAENETRESET: + p = "Network has been reset"; + break; + case WSAECONNABORTED: + p = "Connection was aborted"; + break; + case WSAECONNRESET: + p = "Connection was reset"; + break; + case WSAENOBUFS: + p = "No buffer space"; + break; + case WSAEISCONN: + p = "Socket is already connected"; + break; + case WSAENOTCONN: + p = "Socket is not connected"; + break; + case WSAESHUTDOWN: + p = "Socket has been shut down"; + break; + case WSAETOOMANYREFS: + p = "Too many references"; + break; + case WSAETIMEDOUT: + p = "Timed out"; + break; + case WSAECONNREFUSED: + p = "Connection refused"; + break; + case WSAELOOP: + p = "Loop??"; + break; + case WSAENAMETOOLONG: + p = "Name too long"; + break; + case WSAEHOSTDOWN: + p = "Host down"; + break; + case WSAEHOSTUNREACH: + p = "Host unreachable"; + break; + case WSAENOTEMPTY: + p = "Not empty"; + break; + case WSAEPROCLIM: + p = "Process limit reached"; + break; + case WSAEUSERS: + p = "Too many users"; + break; + case WSAEDQUOT: + p = "Bad quota"; + break; + case WSAESTALE: + p = "Something is stale"; + break; + case WSAEREMOTE: + p = "Remote error"; + break; + case WSAEDISCON: + p = "Disconnected"; + break; + /* Extended Winsock errors */ + case WSASYSNOTREADY: + p = "Winsock library is not ready"; + break; + case WSANOTINITIALISED: + p = "Winsock library not initialized"; + break; + case WSAVERNOTSUPPORTED: + p = "Winsock version not supported"; + break; + + /* getXbyY() errors (already handled in herrmsg): + * Authoritative Answer: Host not found */ + case WSAHOST_NOT_FOUND: + p = "Host not found"; + break; + + /* Non-Authoritative: Host not found, or SERVERFAIL */ + case WSATRY_AGAIN: + p = "Host not found, try again"; + break; + + /* Non recoverable errors, FORMERR, REFUSED, NOTIMP */ + case WSANO_RECOVERY: + p = "Unrecoverable error in call to nameserver"; + break; + + /* Valid name, no data record of requested type */ + case WSANO_DATA: + p = "No data record of requested type"; + break; + + default: + return NULL; + } + curlx_strcopy(buf, len, p, strlen(p)); + return buf; +#endif +} +#endif /* USE_WINSOCK */ + +/* + * Our thread-safe and smart strerror() replacement. + * + * The 'err' argument passed in to this function MUST be a true errno number + * as reported on this system. We do no range checking on the number before + * we pass it to the "number-to-message" conversion function and there might + * be systems that do not do proper range checking in there themselves. + * + * We do not do range checking (on systems other than Windows) since there is + * no good reliable and portable way to do it. + * + * On Windows different types of error codes overlap. This function has an + * order of preference when trying to match error codes: + * CRT (errno), Winsock (WSAGetLastError), Windows API (GetLastError). + * + * It may be more correct to call one of the variant functions instead: + * Call Curl_sspi_strerror if the error code is definitely Windows SSPI. + * Call curlx_winapi_strerror if the error code is definitely Windows API. + */ +const char *curlx_strerror(int err, char *buf, size_t buflen) +{ +#ifdef _WIN32 + DWORD old_win_err = GetLastError(); +#endif + int old_errno = errno; + char *p; + + if(!buflen) + return NULL; + +#ifndef _WIN32 + DEBUGASSERT(err >= 0); +#endif + + *buf = '\0'; + +#ifdef _WIN32 + if((strerror_s(buf, buflen, err) || !strcmp(buf, "Unknown error")) && +#ifdef USE_WINSOCK + !get_winsock_error(err, buf, buflen) && +#endif + !curlx_get_winapi_error((DWORD)err, buf, buflen)) + SNPRINTF(buf, buflen, "Unknown error %d (%#x)", err, (unsigned int)err); +#else /* !_WIN32 */ + +#if defined(HAVE_STRERROR_R) && defined(HAVE_POSIX_STRERROR_R) + /* + * The POSIX-style strerror_r() may set errno to ERANGE if insufficient + * storage is supplied via 'strerrbuf' and 'buflen' to hold the generated + * message string, or EINVAL if 'errnum' is not a valid error number. + */ + if(strerror_r(err, buf, buflen) && + buflen > sizeof("Unknown error ") + 20) { + if(buf[0] == '\0') + SNPRINTF(buf, buflen, "Unknown error %d", err); + } +#elif defined(HAVE_STRERROR_R) && defined(HAVE_GLIBC_STRERROR_R) + /* + * The glibc-style strerror_r() only *might* use the buffer we pass to + * the function, but it always returns the error message as a pointer, + * so we must copy that string unconditionally (if non-NULL). + */ + { + char buffer[256]; + const char *msg = strerror_r(err, buffer, sizeof(buffer)); + if(msg && buflen > 1) + SNPRINTF(buf, buflen, "%s", msg); + else if(buflen > sizeof("Unknown error ") + 20) + SNPRINTF(buf, buflen, "Unknown error %d", err); + } +#else + { + /* !checksrc! disable BANNEDFUNC 1 */ + const char *msg = strerror(err); + if(msg && buflen > 1) + SNPRINTF(buf, buflen, "%s", msg); + else if(buflen > sizeof("Unknown error ") + 20) + SNPRINTF(buf, buflen, "Unknown error %d", err); + } +#endif + +#endif /* _WIN32 */ + + /* strip trailing '\r\n' or '\n'. */ + p = strrchr(buf, '\n'); + if(p && (p - buf) >= 2) + *p = '\0'; + p = strrchr(buf, '\r'); + if(p && (p - buf) >= 1) + *p = '\0'; + + if(errno != old_errno) + errno = old_errno; + +#ifdef _WIN32 + if(old_win_err != GetLastError()) + SetLastError(old_win_err); +#endif + + return buf; +} diff --git a/3rdparty/curl-8.21.0/lib/curlx/strerr.h b/3rdparty/curl-8.21.0/lib/curlx/strerr.h new file mode 100644 index 0000000000..4413e6738c --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/strerr.h @@ -0,0 +1,29 @@ +#ifndef HEADER_CURL_STRERR_H +#define HEADER_CURL_STRERR_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +const char *curlx_strerror(int err, char *buf, size_t buflen); + +#endif /* HEADER_CURL_STRERR_H */ diff --git a/3rdparty/curl-8.21.0/lib/curlx/strparse.c b/3rdparty/curl-8.21.0/lib/curlx/strparse.c new file mode 100644 index 0000000000..736f620504 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/strparse.c @@ -0,0 +1,317 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curlx/strparse.h" + +void curlx_str_init(struct Curl_str *out) +{ + out->str = NULL; + out->len = 0; +} + +void curlx_str_assign(struct Curl_str *out, const char *str, size_t len) +{ + out->str = str; + out->len = len; +} + +/* remove bytes from the end of the string, never remove more bytes than what + the string holds! */ +void curlx_str_trim(struct Curl_str *out, size_t len) +{ + DEBUGASSERT(out); + DEBUGASSERT(out->len >= len); + out->len -= len; +} + +/* Get a word until the first DELIM or end of string. At least one byte long. + return non-zero on error. If 'max' is zero, it will always return error. */ +int curlx_str_until(const char **linep, struct Curl_str *out, + const size_t max, char delim) +{ + const char *s; + size_t len = 0; + DEBUGASSERT(linep); + DEBUGASSERT(*linep); + DEBUGASSERT(out); + DEBUGASSERT(delim); + s = *linep; + + curlx_str_init(out); + while(*s && (*s != delim)) { + s++; + if(++len > max) { + return STRE_BIG; + } + } + if(!len) + return STRE_SHORT; + out->str = *linep; + out->len = len; + *linep = s; /* point to the first byte after the word */ + return STRE_OK; +} + +/* Get a word until the first space or end of string. At least one byte long. + return non-zero on error */ +int curlx_str_word(const char **linep, struct Curl_str *out, const size_t max) +{ + return curlx_str_until(linep, out, max, ' '); +} + +/* Get a word until a newline byte or end of string. At least one byte long. + return non-zero on error */ +int curlx_str_untilnl(const char **linep, struct Curl_str *out, + const size_t max) +{ + const char *s = *linep; + size_t len = 0; + DEBUGASSERT(linep && *linep && out && max); + + curlx_str_init(out); + while(*s && !ISNEWLINE(*s)) { + s++; + if(++len > max) + return STRE_BIG; + } + if(!len) + return STRE_SHORT; + out->str = *linep; + out->len = len; + *linep = s; /* point to the first byte after the word */ + return STRE_OK; +} + +/* Get a "quoted" word. Escaped quotes are supported. + return non-zero on error */ +int curlx_str_quotedword(const char **linep, struct Curl_str *out, + const size_t max) +{ + const char *s = *linep; + size_t len = 0; + DEBUGASSERT(linep && *linep && out && max); + + curlx_str_init(out); + if(*s != '\"') + return STRE_BEGQUOTE; + s++; + while(*s && (*s != '\"')) { + if(*s == '\\' && s[1]) { + s++; + if(++len > max) + return STRE_BIG; + } + s++; + if(++len > max) + return STRE_BIG; + } + if(*s != '\"') + return STRE_ENDQUOTE; + out->str = (*linep) + 1; + out->len = len; + *linep = s + 1; + return STRE_OK; +} + +/* Advance over a single character. + return non-zero on error */ +int curlx_str_single(const char **linep, char byte) +{ + DEBUGASSERT(linep && *linep); + if(**linep != byte) + return STRE_BYTE; + (*linep)++; /* move over it */ + return STRE_OK; +} + +/* Advance over a single space. + return non-zero on error */ +int curlx_str_singlespace(const char **linep) +{ + return curlx_str_single(linep, ' '); +} + +/* given an ASCII character and max ascii, return TRUE if valid */ +#define valid_digit(x, m) \ + (((x) >= '0') && ((x) <= (m)) && curlx_hexasciitable[(x) - '0']) + +/* We use 16 for the zero index (and the necessary bitwise AND in the loop) + to be able to have a non-zero value there to make valid_digit() able to + use the info */ +const unsigned char curlx_hexasciitable[] = { + 16, 1, 2, 3, 4, 5, 6, 7, 8, 9, /* 0x30: 0 - 9 */ + 0, 0, 0, 0, 0, 0, 0, + 10, 11, 12, 13, 14, 15, /* 0x41: A - F */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 10, 11, 12, 13, 14, 15 /* 0x61: a - f */ +}; + +/* no support for 0x prefix nor leading spaces */ +static int str_num_base(const char **linep, curl_off_t *nump, curl_off_t max, + int base) /* 8, 10 or 16, nothing else */ +{ + curl_off_t num = 0; + const char *p; + int m = (base == 10) ? '9' : /* the largest digit possible */ + (base == 16) ? 'f' : '7'; + DEBUGASSERT(linep && *linep && nump); + DEBUGASSERT((base == 8) || (base == 10) || (base == 16)); + DEBUGASSERT(max >= 0); /* mostly to catch SIZE_MAX, which is too large */ + *nump = 0; + p = *linep; + if(!valid_digit(*p, m)) + return STRE_NO_NUM; + if(max < base) { + /* special-case low max scenario because check needs to be different */ + do { + int n = curlx_hexval(*p++); + num = (num * base) + n; + if(num > max) + return STRE_OVERFLOW; + } while(valid_digit(*p, m)); + } + else { + do { + int n = curlx_hexval(*p++); + if(num > ((max - n) / base)) + return STRE_OVERFLOW; + num = (num * base) + n; + } while(valid_digit(*p, m)); + } + *nump = num; + *linep = p; + return STRE_OK; +} + +/* Get an unsigned decimal number with no leading space or minus. Leading + zeroes are accepted. return non-zero on error */ +int curlx_str_number(const char **linep, curl_off_t *nump, curl_off_t max) +{ + return str_num_base(linep, nump, max, 10); +} + +/* Get an unsigned hexadecimal number with no leading space or minus and no + "0x" support. Leading zeroes are accepted. return non-zero on error */ +int curlx_str_hex(const char **linep, curl_off_t *nump, curl_off_t max) +{ + return str_num_base(linep, nump, max, 16); +} + +/* Get an unsigned octal number with no leading space or minus and no "0" + prefix support. Leading zeroes are accepted. return non-zero on error */ +int curlx_str_octal(const char **linep, curl_off_t *nump, curl_off_t max) +{ + return str_num_base(linep, nump, max, 8); +} + +/* + * Parse a positive number up to 63-bit number written in ASCII. Skip leading + * blanks. No support for prefixes. + */ +int curlx_str_numblanks(const char **str, curl_off_t *num) +{ + curlx_str_passblanks(str); + return curlx_str_number(str, num, CURL_OFF_T_MAX); +} + +/* CR or LF + return non-zero on error */ +int curlx_str_newline(const char **linep) +{ + DEBUGASSERT(linep && *linep); + if(ISNEWLINE(**linep)) { + (*linep)++; + return STRE_OK; /* yessir */ + } + return STRE_NEWLINE; +} + +#ifndef WITHOUT_LIBCURL +/* case insensitive compare that the parsed string matches the given string. + Returns non-zero on match. */ +int curlx_str_casecompare(struct Curl_str *str, const char *check) +{ + size_t clen = check ? strlen(check) : 0; + return ((str->len == clen) && curl_strnequal(str->str, check, clen)); +} +#endif + +/* case sensitive string compare. Returns non-zero on match. */ +int curlx_str_cmp(struct Curl_str *str, const char *check) +{ + if(check) { + size_t clen = strlen(check); + return ((str->len == clen) && !strncmp(str->str, check, clen)); + } + return !!(str->len); +} + +/* Trim off 'num' number of bytes from the beginning (left side) of the + string. If 'num' is larger than the string, return error. */ +int curlx_str_nudge(struct Curl_str *str, size_t num) +{ + if(num <= str->len) { + str->str += num; + str->len -= num; + return STRE_OK; + } + return STRE_OVERFLOW; +} + +/* Get the following character sequence that consists only of bytes not + present in the 'reject' string. Like strcspn(). */ +int curlx_str_cspn(const char **linep, struct Curl_str *out, + const char *reject) +{ + const char *s = *linep; + size_t len; + DEBUGASSERT(linep && *linep); + + len = strcspn(s, reject); + if(len) { + out->str = s; + out->len = len; + *linep = &s[len]; + return STRE_OK; + } + curlx_str_init(out); + return STRE_SHORT; +} + +/* remove ISBLANK()s from both ends of the string */ +void curlx_str_trimblanks(struct Curl_str *out) +{ + while(out->len && ISBLANK(*out->str)) + curlx_str_nudge(out, 1); + + /* trim trailing spaces and tabs */ + while(out->len && ISBLANK(out->str[out->len - 1])) + out->len--; +} + +/* increase the pointer until it has moved over all blanks */ +void curlx_str_passblanks(const char **linep) +{ + while(ISBLANK(**linep)) + (*linep)++; /* move over it */ +} diff --git a/3rdparty/curl-8.21.0/lib/curlx/strparse.h b/3rdparty/curl-8.21.0/lib/curlx/strparse.h new file mode 100644 index 0000000000..c7801b2cb3 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/strparse.h @@ -0,0 +1,114 @@ +#ifndef HEADER_CURL_STRPARSE_H +#define HEADER_CURL_STRPARSE_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#define STRE_OK 0 +#define STRE_BIG 1 +#define STRE_SHORT 2 +#define STRE_BEGQUOTE 3 +#define STRE_ENDQUOTE 4 +#define STRE_BYTE 5 +#define STRE_NEWLINE 6 +#define STRE_OVERFLOW 7 +#define STRE_NO_NUM 8 + +/* public struct, but all accesses should be done using the provided + functions */ +struct Curl_str { + const char *str; + size_t len; +}; + +void curlx_str_init(struct Curl_str *out); +void curlx_str_assign(struct Curl_str *out, const char *str, size_t len); +void curlx_str_trim(struct Curl_str *out, size_t len); + +#define curlx_str(x) ((x)->str) +#define curlx_strlen(x) ((x)->len) + +/* Get a word until the first space + return non-zero on error */ +int curlx_str_word(const char **linep, struct Curl_str *out, const size_t max); + +/* Get a word until the first DELIM or end of string + return non-zero on error */ +int curlx_str_until(const char **linep, struct Curl_str *out, const size_t max, + char delim); + +/* Get a word until a newline byte or end of string. At least one byte long. + return non-zero on error */ +int curlx_str_untilnl(const char **linep, struct Curl_str *out, + const size_t max); + +/* Get a "quoted" word. Escaped quotes are supported. + return non-zero on error */ +int curlx_str_quotedword(const char **linep, struct Curl_str *out, + const size_t max); + +/* Advance over a single character. + return non-zero on error */ +int curlx_str_single(const char **linep, char byte); + +/* Advance over a single space. + return non-zero on error */ +int curlx_str_singlespace(const char **linep); + +/* Get an unsigned decimal number. Return non-zero on error */ +int curlx_str_number(const char **linep, curl_off_t *nump, curl_off_t max); + +/* As above with CURL_OFF_T_MAX but also pass leading blanks */ +int curlx_str_numblanks(const char **str, curl_off_t *num); + +/* Get an unsigned hexadecimal number. Return non-zero on error */ +int curlx_str_hex(const char **linep, curl_off_t *nump, curl_off_t max); + +/* Get an unsigned octal number. Return non-zero on error */ +int curlx_str_octal(const char **linep, curl_off_t *nump, curl_off_t max); + +/* Check for CR or LF + return non-zero on error */ +int curlx_str_newline(const char **linep); + +/* case insensitive compare that the parsed string matches the + given string. */ +int curlx_str_casecompare(struct Curl_str *str, const char *check); +int curlx_str_cmp(struct Curl_str *str, const char *check); + +int curlx_str_nudge(struct Curl_str *str, size_t num); + +int curlx_str_cspn(const char **linep, struct Curl_str *out, + const char *reject); +void curlx_str_trimblanks(struct Curl_str *out); +void curlx_str_passblanks(const char **linep); + +/* given a hexadecimal letter, return the binary value. '0' returns 0, 'a' + returns 10. THIS ONLY WORKS ON VALID HEXADECIMAL LETTER INPUT. Verify + before calling this! +*/ +extern const unsigned char curlx_hexasciitable[]; +#define curlx_hexval(x) (unsigned char)(curlx_hexasciitable[(x) - '0'] & 0x0f) + +#endif /* HEADER_CURL_STRPARSE_H */ diff --git a/3rdparty/curl-8.21.0/lib/curlx/timediff.c b/3rdparty/curl-8.21.0/lib/curlx/timediff.c new file mode 100644 index 0000000000..2bf786941d --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/timediff.c @@ -0,0 +1,85 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curlx/timediff.h" + +/* + * Converts number of milliseconds into a timeval structure. + * + * Return values: + * NULL IF tv is NULL or ms < 0 (eg. no timeout -> blocking select) + * tv with 0 in both fields IF ms == 0 (eg. 0ms timeout -> polling select) + * tv with converted fields IF ms > 0 (eg. >0ms timeout -> waiting select) + */ +struct timeval *curlx_mstotv(struct timeval *tv, timediff_t ms) +{ + if(!tv) + return NULL; + + if(ms < 0) + return NULL; + + if(ms > 0) { + timediff_t tv_sec = ms / 1000; + timediff_t tv_usec = (ms % 1000) * 1000; /* max=999000 */ +#ifdef HAVE_SUSECONDS_T +#if TIMEDIFF_T_MAX > TIME_T_MAX + /* tv_sec overflow check in case time_t is signed */ + if(tv_sec > TIME_T_MAX) + tv_sec = TIME_T_MAX; +#endif + tv->tv_sec = (time_t)tv_sec; + tv->tv_usec = (suseconds_t)tv_usec; +#elif defined(_WIN32) /* maybe also others in the future */ +#if TIMEDIFF_T_MAX > LONG_MAX + /* tv_sec overflow check on Windows there we know it is long */ + if(tv_sec > LONG_MAX) + tv_sec = LONG_MAX; +#endif + tv->tv_sec = (long)tv_sec; + tv->tv_usec = (long)tv_usec; +#else +#if TIMEDIFF_T_MAX > INT_MAX + /* tv_sec overflow check in case time_t is signed */ + if(tv_sec > INT_MAX) + tv_sec = INT_MAX; +#endif + tv->tv_sec = (int)tv_sec; + tv->tv_usec = (int)tv_usec; +#endif + } + else { + tv->tv_sec = 0; + tv->tv_usec = 0; + } + + return tv; +} + +/* + * Converts a timeval structure into number of milliseconds. + */ +timediff_t curlx_tvtoms(struct timeval *tv) +{ + return (tv->tv_sec * 1000) + (timediff_t)(tv->tv_usec / 1000); +} diff --git a/3rdparty/curl-8.21.0/lib/curlx/timediff.h b/3rdparty/curl-8.21.0/lib/curlx/timediff.h new file mode 100644 index 0000000000..1081c75d1c --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/timediff.h @@ -0,0 +1,51 @@ +#ifndef HEADER_CURL_TIMEDIFF_H +#define HEADER_CURL_TIMEDIFF_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +/* Use a larger type even for 32-bit time_t systems so that we can keep + microsecond accuracy in it */ +typedef curl_off_t timediff_t; +#define FMT_TIMEDIFF_T FMT_OFF_T + +#define TIMEDIFF_T_MAX CURL_OFF_T_MAX +#define TIMEDIFF_T_MIN CURL_OFF_T_MIN + +/* + * Converts number of milliseconds into a timeval structure. + * + * Return values: + * NULL IF tv is NULL or ms < 0 (eg. no timeout -> blocking select) + * tv with 0 in both fields IF ms == 0 (eg. 0ms timeout -> polling select) + * tv with converted fields IF ms > 0 (eg. >0ms timeout -> waiting select) + */ +struct timeval *curlx_mstotv(struct timeval *tv, timediff_t ms); + +/* + * Converts a timeval structure into number of milliseconds. + */ +timediff_t curlx_tvtoms(struct timeval *tv); + +#endif /* HEADER_CURL_TIMEDIFF_H */ diff --git a/3rdparty/curl-8.21.0/lib/curlx/timeval.c b/3rdparty/curl-8.21.0/lib/curlx/timeval.c new file mode 100644 index 0000000000..2363e60839 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/timeval.c @@ -0,0 +1,273 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curlx/timeval.h" + +#ifdef _WIN32 + +#include "system_win32.h" + +LARGE_INTEGER Curl_freq; + +/* For tool or tests, we must initialize before calling curlx_now(). + Providing this function here is wrong. */ +void curlx_now_init(void) +{ + QueryPerformanceFrequency(&Curl_freq); +} + +/* In case of bug fix this function has a counterpart in tool_util.c */ +void curlx_pnow(struct curltime *pnow) +{ + LARGE_INTEGER count; + DEBUGASSERT(Curl_freq.QuadPart); + QueryPerformanceCounter(&count); + pnow->tv_sec = (time_t)(count.QuadPart / Curl_freq.QuadPart); + pnow->tv_usec = (int)((count.QuadPart % Curl_freq.QuadPart) * 1000000 / + Curl_freq.QuadPart); +} + +#elif defined(HAVE_CLOCK_GETTIME_MONOTONIC) || \ + defined(HAVE_CLOCK_GETTIME_MONOTONIC_RAW) + +void curlx_pnow(struct curltime *pnow) +{ + /* + * clock_gettime() is granted to be increased monotonically when the + * monotonic clock is queried. Time starting point is unspecified, it + * could be the system start-up time, the Epoch, or something else, + * in any case the time starting point does not change once that the + * system has started up. + */ + struct timespec tsnow; + + /* + * clock_gettime() may be defined by Apple's SDK as weak symbol thus + * code compiles but fails during runtime if clock_gettime() is + * called on unsupported OS version. + */ +#if defined(__APPLE__) && defined(HAVE_BUILTIN_AVAILABLE) && \ + (HAVE_BUILTIN_AVAILABLE == 1) + bool have_clock_gettime = FALSE; + if(__builtin_available(macOS 10.12, iOS 10, tvOS 10, watchOS 3, *)) + have_clock_gettime = TRUE; +#endif + +#ifdef HAVE_CLOCK_GETTIME_MONOTONIC_RAW + if( +#if defined(__APPLE__) && defined(HAVE_BUILTIN_AVAILABLE) && \ + (HAVE_BUILTIN_AVAILABLE == 1) + have_clock_gettime && +#endif + (clock_gettime(CLOCK_MONOTONIC_RAW, &tsnow) == 0)) { + pnow->tv_sec = tsnow.tv_sec; + pnow->tv_usec = (int)(tsnow.tv_nsec / 1000); + } + else +#endif + + if( +#if defined(__APPLE__) && defined(HAVE_BUILTIN_AVAILABLE) && \ + (HAVE_BUILTIN_AVAILABLE == 1) + have_clock_gettime && +#endif + (clock_gettime(CLOCK_MONOTONIC, &tsnow) == 0)) { + pnow->tv_sec = tsnow.tv_sec; + pnow->tv_usec = (int)(tsnow.tv_nsec / 1000); + } + /* + * Even when the configure process has truly detected monotonic clock + * availability, it might happen that it is not actually available at + * runtime. When this occurs, fallback to other time source. + */ +#ifdef HAVE_GETTIMEOFDAY + else { + struct timeval now; + (void)gettimeofday(&now, NULL); + pnow->tv_sec = now.tv_sec; + pnow->tv_usec = (int)now.tv_usec; + } +#else + else { + pnow->tv_sec = time(NULL); + pnow->tv_usec = 0; + } +#endif +} + +#elif defined(HAVE_MACH_ABSOLUTE_TIME) + +#include + +void curlx_pnow(struct curltime *pnow) +{ + /* + * Monotonic timer on macOS is provided by mach_absolute_time(), which + * returns time in Mach "absolute time units," which are platform-dependent. + * To convert to nanoseconds, one must use conversion factors specified by + * mach_timebase_info(). + */ + static mach_timebase_info_data_t timebase; + uint64_t usecs; + + if(timebase.denom == 0) + (void)mach_timebase_info(&timebase); + + usecs = mach_absolute_time(); + usecs *= timebase.numer; /* spellchecker:disable-line */ + usecs /= timebase.denom; + usecs /= 1000; + + pnow->tv_sec = usecs / 1000000; + pnow->tv_usec = (int)(usecs % 1000000); +} + +#elif defined(HAVE_GETTIMEOFDAY) + +void curlx_pnow(struct curltime *pnow) +{ + /* + * gettimeofday() is not granted to be increased monotonically, due to + * clock drifting and external source time synchronization it can jump + * forward or backward in time. + */ + struct timeval now; + (void)gettimeofday(&now, NULL); + pnow->tv_sec = now.tv_sec; + pnow->tv_usec = (int)now.tv_usec; +} + +#else + +void curlx_pnow(struct curltime *pnow) +{ + /* + * time() returns the value of time in seconds since the Epoch. + */ + pnow->tv_sec = time(NULL); + pnow->tv_usec = 0; + if(!pnow->tv_sec) /* avoid a `now` fully zero */ + pnow->tv_usec = 1; +} + +#endif + +struct curltime curlx_now(void) +{ + struct curltime now; + curlx_pnow(&now); + return now; +} + +/* + * Returns: time difference in number of milliseconds. For too large diffs it + * returns max value. + * + * @unittest: 1323 + */ +timediff_t curlx_ptimediff_ms(const struct curltime *newer, + const struct curltime *older) +{ + timediff_t diff = (timediff_t)newer->tv_sec - older->tv_sec; + if(diff >= (TIMEDIFF_T_MAX / 1000)) + return TIMEDIFF_T_MAX; + else if(diff <= (TIMEDIFF_T_MIN / 1000)) + return TIMEDIFF_T_MIN; + return (diff * 1000) + ((newer->tv_usec - older->tv_usec) / 1000); +} + +timediff_t curlx_timediff_ms(struct curltime newer, struct curltime older) +{ + return curlx_ptimediff_ms(&newer, &older); +} + +/* + * Returns: time difference in number of milliseconds, rounded up. + * For too large diffs it returns max value. + */ +timediff_t curlx_timediff_ceil_ms(struct curltime newer, + struct curltime older) +{ + timediff_t diff = (timediff_t)newer.tv_sec - older.tv_sec; + if(diff >= (TIMEDIFF_T_MAX / 1000)) + return TIMEDIFF_T_MAX; + else if(diff <= (TIMEDIFF_T_MIN / 1000)) + return TIMEDIFF_T_MIN; + return (diff * 1000) + ((newer.tv_usec - older.tv_usec + 999) / 1000); +} + +/* + * Returns: time difference in number of microseconds. For too large diffs it + * returns max value. + */ +timediff_t curlx_ptimediff_us(const struct curltime *newer, + const struct curltime *older) +{ + timediff_t diff = (timediff_t)newer->tv_sec - older->tv_sec; + if(diff >= (TIMEDIFF_T_MAX / 1000000)) + return TIMEDIFF_T_MAX; + else if(diff <= (TIMEDIFF_T_MIN / 1000000)) + return TIMEDIFF_T_MIN; + return (diff * 1000000) + newer->tv_usec - older->tv_usec; +} + +timediff_t curlx_timediff_us(struct curltime newer, struct curltime older) +{ + return curlx_ptimediff_us(&newer, &older); +} + +#if defined(__MINGW32__) && (__MINGW64_VERSION_MAJOR <= 3) +#include /* for _gmtime32_s(), _gmtime64_s() */ +#ifdef _USE_32BIT_TIME_T +#define gmtime_s _gmtime32_s +#else +#define gmtime_s _gmtime64_s +#endif +#endif + +/* + * curlx_gmtime() is a gmtime() replacement for portability. Do not use + * the gmtime_s(), gmtime_r() or gmtime() functions anywhere else but here. + */ +CURLcode curlx_gmtime(time_t intime, struct tm *store) +{ +#ifdef _WIN32 + if(gmtime_s(store, &intime)) /* thread-safe */ + return CURLE_BAD_FUNCTION_ARGUMENT; +#elif defined(HAVE_GMTIME_R) + const struct tm *tm; + tm = gmtime_r(&intime, store); /* thread-safe */ + if(!tm) + return CURLE_BAD_FUNCTION_ARGUMENT; +#else + const struct tm *tm; + /* !checksrc! disable BANNEDFUNC 1 */ + tm = gmtime(&intime); /* not thread-safe */ + if(tm) + *store = *tm; /* copy the pointed struct to the local copy */ + else + return CURLE_BAD_FUNCTION_ARGUMENT; +#endif + + return CURLE_OK; +} diff --git a/3rdparty/curl-8.21.0/lib/curlx/timeval.h b/3rdparty/curl-8.21.0/lib/curlx/timeval.h new file mode 100644 index 0000000000..c01f95d87d --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/timeval.h @@ -0,0 +1,74 @@ +#ifndef HEADER_CURL_TIMEVAL_H +#define HEADER_CURL_TIMEVAL_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "curlx/timediff.h" + +struct curltime { + time_t tv_sec; /* seconds */ + int tv_usec; /* microseconds */ +}; + +#ifdef _WIN32 +/* For tool or tests, we must initialize before calling curlx_now() */ +void curlx_now_init(void); +#endif + +struct curltime curlx_now(void); +void curlx_pnow(struct curltime *pnow); + +/* + * Make sure that the first argument (newer) is the more recent time and older + * is the older time, as otherwise you get a weird negative time-diff back... + * + * Returns: the time difference in number of milliseconds. + */ +timediff_t curlx_timediff_ms(struct curltime newer, struct curltime older); +timediff_t curlx_ptimediff_ms(const struct curltime *newer, + const struct curltime *older); + +/* + * Make sure that the first argument (newer) is the more recent time and older + * is the older time, as otherwise you get a weird negative time-diff back... + * + * Returns: the time difference in number of milliseconds, rounded up. + */ +timediff_t curlx_timediff_ceil_ms(struct curltime newer, + struct curltime older); + +/* + * Make sure that the first argument (newer) is the more recent time and older + * is the older time, as otherwise you get a weird negative time-diff back... + * + * Returns: the time difference in number of microseconds. + */ +timediff_t curlx_timediff_us(struct curltime newer, struct curltime older); +timediff_t curlx_ptimediff_us(const struct curltime *newer, + const struct curltime *older); + +CURLcode curlx_gmtime(time_t intime, struct tm *store); + +#endif /* HEADER_CURL_TIMEVAL_H */ diff --git a/3rdparty/curl-8.21.0/lib/curlx/version_win32.c b/3rdparty/curl-8.21.0/lib/curlx/version_win32.c new file mode 100644 index 0000000000..296a38d924 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/version_win32.c @@ -0,0 +1,238 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Steve Holme, . + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef _WIN32 + +#include "curlx/version_win32.h" + +#ifndef CURL_WINDOWS_UWP +/* This Unicode version struct works for VerifyVersionInfoW (OSVERSIONINFOEXW) + and RtlVerifyVersionInfo (RTLOSVERSIONINFOEXW) */ +struct OUR_OSVERSIONINFOEXW { + ULONG dwOSVersionInfoSize; + ULONG dwMajorVersion; + ULONG dwMinorVersion; + ULONG dwBuildNumber; + ULONG dwPlatformId; + WCHAR szCSDVersion[128]; + USHORT wServicePackMajor; + USHORT wServicePackMinor; + USHORT wSuiteMask; + UCHAR wProductType; + UCHAR wReserved; +}; + +typedef LONG (APIENTRY *RTLVERIFYVERSIONINFO_FN) + (struct OUR_OSVERSIONINFOEXW *, ULONG, ULONGLONG); +static RTLVERIFYVERSIONINFO_FN s_pRtlVerifyVersionInfo; + +void curlx_verify_windows_init(void) +{ +#if defined(__clang__) && __clang_major__ >= 16 +#pragma clang diagnostic push +#pragma clang diagnostic ignored "-Wcast-function-type-strict" +#endif + s_pRtlVerifyVersionInfo = CURLX_FUNCTION_CAST(RTLVERIFYVERSIONINFO_FN, + GetProcAddress(GetModuleHandle(TEXT("ntdll")), "RtlVerifyVersionInfo")); +#if defined(__clang__) && __clang_major__ >= 16 +#pragma clang diagnostic pop +#endif +} +#endif /* !CURL_WINDOWS_UWP */ + +/* + * curlx_verify_windows_version() + * + * This is used to verify if we are running on a specific Windows version. + * + * Parameters: + * + * majorVersion [in] - The major version number. + * minorVersion [in] - The minor version number. + * buildVersion [in] - The build version number. If 0, this parameter is + * ignored. + * platform [in] - The optional platform identifier. + * condition [in] - The test condition used to specifier whether we are + * checking a version less than, equal to or greater than + * what is specified in the major and minor version + * numbers. + * + * Returns TRUE if matched; otherwise FALSE. + */ +bool curlx_verify_windows_version(const unsigned int majorVersion, + const unsigned int minorVersion, + const unsigned int buildVersion, + const PlatformIdentifier platform, + const VersionCondition condition) +{ + bool matched = FALSE; + +#ifdef CURL_WINDOWS_UWP + /* We have no way to determine the Windows version from Windows apps, + so let's assume we are running on the target Windows version. */ + const WORD fullVersion = MAKEWORD(minorVersion, majorVersion); + const WORD targetVersion = (WORD)_WIN32_WINNT; + + (void)buildVersion; + + switch(condition) { + case VERSION_LESS_THAN: + matched = targetVersion < fullVersion; + break; + + case VERSION_LESS_THAN_EQUAL: + matched = targetVersion <= fullVersion; + break; + + case VERSION_EQUAL: + matched = targetVersion == fullVersion; + break; + + case VERSION_GREATER_THAN_EQUAL: + matched = targetVersion >= fullVersion; + break; + + case VERSION_GREATER_THAN: + matched = targetVersion > fullVersion; + break; + } + + if(matched && (platform == PLATFORM_WINDOWS)) { + /* we are always running on PLATFORM_WINNT */ + matched = FALSE; + } +#else + ULONGLONG cm = 0; + struct OUR_OSVERSIONINFOEXW osver; + BYTE majorCondition; + BYTE minorCondition; + BYTE buildCondition; + BYTE spMajorCondition; + BYTE spMinorCondition; + DWORD dwTypeMask = VER_MAJORVERSION | VER_MINORVERSION | + VER_SERVICEPACKMAJOR | VER_SERVICEPACKMINOR; + + switch(condition) { + case VERSION_LESS_THAN: + majorCondition = VER_LESS; + minorCondition = VER_LESS; + buildCondition = VER_LESS; + spMajorCondition = VER_LESS_EQUAL; + spMinorCondition = VER_LESS_EQUAL; + break; + + case VERSION_LESS_THAN_EQUAL: + majorCondition = VER_LESS_EQUAL; + minorCondition = VER_LESS_EQUAL; + buildCondition = VER_LESS_EQUAL; + spMajorCondition = VER_LESS_EQUAL; + spMinorCondition = VER_LESS_EQUAL; + break; + + case VERSION_EQUAL: + majorCondition = VER_EQUAL; + minorCondition = VER_EQUAL; + buildCondition = VER_EQUAL; + spMajorCondition = VER_GREATER_EQUAL; + spMinorCondition = VER_GREATER_EQUAL; + break; + + case VERSION_GREATER_THAN_EQUAL: + majorCondition = VER_GREATER_EQUAL; + minorCondition = VER_GREATER_EQUAL; + buildCondition = VER_GREATER_EQUAL; + spMajorCondition = VER_GREATER_EQUAL; + spMinorCondition = VER_GREATER_EQUAL; + break; + + case VERSION_GREATER_THAN: + majorCondition = VER_GREATER; + minorCondition = VER_GREATER; + buildCondition = VER_GREATER; + spMajorCondition = VER_GREATER_EQUAL; + spMinorCondition = VER_GREATER_EQUAL; + break; + + default: + return FALSE; + } + + memset(&osver, 0, sizeof(osver)); + osver.dwOSVersionInfoSize = sizeof(osver); + osver.dwMajorVersion = majorVersion; + osver.dwMinorVersion = minorVersion; + osver.dwBuildNumber = buildVersion; + if(platform == PLATFORM_WINDOWS) + osver.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS; + else if(platform == PLATFORM_WINNT) + osver.dwPlatformId = VER_PLATFORM_WIN32_NT; + + cm = VerSetConditionMask(cm, VER_MAJORVERSION, majorCondition); + cm = VerSetConditionMask(cm, VER_MINORVERSION, minorCondition); + cm = VerSetConditionMask(cm, VER_SERVICEPACKMAJOR, spMajorCondition); + cm = VerSetConditionMask(cm, VER_SERVICEPACKMINOR, spMinorCondition); + + if(platform != PLATFORM_DONT_CARE) { + cm = VerSetConditionMask(cm, VER_PLATFORMID, VER_EQUAL); + dwTypeMask |= VER_PLATFORMID; + } + + /* Later versions of Windows have version functions that may not return the + real version of Windows unless the application is so manifested. We prefer + the real version always, so we use the Rtl variant of the function when + possible. Note though the function signatures have underlying fundamental + types that are the same, the return values are different. */ + if(s_pRtlVerifyVersionInfo) + matched = !s_pRtlVerifyVersionInfo(&osver, dwTypeMask, cm); + else + matched = !!VerifyVersionInfoW((OSVERSIONINFOEXW *)&osver, dwTypeMask, cm); + + /* Compare the build number separately. VerifyVersionInfo normally compares + major.minor in hierarchical order (eg 1.9 is less than 2.0) but does not + do the same for build (eg 1.9 build 222 is not less than 2.0 build 111). + Build comparison is only needed when build numbers are equal (eg 1.9 is + always less than 2.0 so build comparison is not needed). */ + if(matched && buildVersion && + (condition == VERSION_EQUAL || + ((condition == VERSION_GREATER_THAN_EQUAL || + condition == VERSION_LESS_THAN_EQUAL) && + curlx_verify_windows_version(majorVersion, minorVersion, 0, + platform, VERSION_EQUAL)))) { + + cm = VerSetConditionMask(0, VER_BUILDNUMBER, buildCondition); + dwTypeMask = VER_BUILDNUMBER; + if(s_pRtlVerifyVersionInfo) + matched = !s_pRtlVerifyVersionInfo(&osver, dwTypeMask, cm); + else + matched = !!VerifyVersionInfoW((OSVERSIONINFOEXW *)&osver, + dwTypeMask, cm); + } + +#endif + + return matched; +} + +#endif /* _WIN32 */ diff --git a/3rdparty/curl-8.21.0/lib/curlx/version_win32.h b/3rdparty/curl-8.21.0/lib/curlx/version_win32.h new file mode 100644 index 0000000000..c4a1c0f758 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/version_win32.h @@ -0,0 +1,60 @@ +#ifndef HEADER_CURL_VERSION_WIN32_H +#define HEADER_CURL_VERSION_WIN32_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Steve Holme, . + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef _WIN32 + +/* Version condition */ +typedef enum { + VERSION_LESS_THAN, + VERSION_LESS_THAN_EQUAL, + VERSION_EQUAL, + VERSION_GREATER_THAN_EQUAL, + VERSION_GREATER_THAN +} VersionCondition; + +/* Platform identifier */ +typedef enum { + PLATFORM_DONT_CARE, + PLATFORM_WINDOWS, + PLATFORM_WINNT +} PlatformIdentifier; + +#ifdef CURL_WINDOWS_UWP +#define curlx_verify_windows_init() Curl_nop_stmt +#else +void curlx_verify_windows_init(void); +#endif +/* This is used to verify if we are running on a specific Windows version */ +bool curlx_verify_windows_version(const unsigned int majorVersion, + const unsigned int minorVersion, + const unsigned int buildVersion, + const PlatformIdentifier platform, + const VersionCondition condition); + +#endif /* _WIN32 */ + +#endif /* HEADER_CURL_VERSION_WIN32_H */ diff --git a/3rdparty/curl-8.21.0/lib/curlx/wait.c b/3rdparty/curl-8.21.0/lib/curlx/wait.c new file mode 100644 index 0000000000..e50a0f0af6 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/wait.c @@ -0,0 +1,94 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifndef HAVE_SELECT +#error "We cannot compile without select() support." +#endif + +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif + +#ifdef MSDOS +#include /* delay() */ +#endif + +#include "curlx/timediff.h" +#include "curlx/wait.h" + +/* + * Internal function used for waiting a specific amount of ms in + * Curl_socket_check() and Curl_poll() when no file descriptor is provided to + * wait on, being used to delay execution. Winsock select() and poll() timeout + * mechanisms need a valid socket descriptor in a not null file descriptor set + * to work. Waiting indefinitely with this function is not allowed, a zero or + * negative timeout value is returned immediately. Timeout resolution, + * accuracy, as well as maximum supported value is system dependent, neither + * factor is a critical issue for the intended use of this function in the + * library. + * + * Return values: + * -1 = system call error, or invalid timeout value + * 0 = specified timeout has elapsed, or interrupted + */ +int curlx_wait_ms(timediff_t timeout_ms) +{ + int r = 0; + + if(!timeout_ms) + return 0; + if(timeout_ms < 0) { + SET_SOCKERRNO(SOCKEINVAL); + return -1; + } +#ifdef MSDOS + delay((unsigned int)timeout_ms); +#elif defined(_WIN32) + /* prevent overflow, timeout_ms is typecast to ULONG/DWORD. */ +#if TIMEDIFF_T_MAX >= ULONG_MAX + if(timeout_ms >= ULONG_MAX) + timeout_ms = ULONG_MAX - 1; + /* do not use ULONG_MAX, because that is equal to INFINITE */ +#endif + Sleep((DWORD)timeout_ms); +#else + /* avoid using poll() for this since it behaves incorrectly with no sockets + on Apple operating systems */ + { + struct timeval pending_tv; + r = select(0, NULL, NULL, NULL, curlx_mstotv(&pending_tv, timeout_ms)); + } +#endif /* _WIN32 */ + if(r) { + if((r == -1) && (SOCKERRNO == SOCKEINTR)) + /* make EINTR from select or poll not a "lethal" error */ + r = 0; + else + r = -1; + } + return r; +} diff --git a/3rdparty/curl-8.21.0/lib/curlx/wait.h b/3rdparty/curl-8.21.0/lib/curlx/wait.h new file mode 100644 index 0000000000..9b9c27386e --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/wait.h @@ -0,0 +1,30 @@ +#ifndef HEADER_CURL_WAIT_H +#define HEADER_CURL_WAIT_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +int curlx_wait_ms(timediff_t timeout_ms); + +#endif /* HEADER_CURL_WAIT_H */ diff --git a/3rdparty/curl-8.21.0/lib/curlx/warnless.c b/3rdparty/curl-8.21.0/lib/curlx/warnless.c new file mode 100644 index 0000000000..5fc36ac9a8 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/warnless.c @@ -0,0 +1,341 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "curlx/warnless.h" + +#if defined(__INTEL_COMPILER) && defined(__unix__) + +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_ARPA_INET_H +#include +#endif + +#endif /* __INTEL_COMPILER && __unix__ */ + +#define CURL_MASK_UCHAR ((unsigned char)~0) + +#define CURL_MASK_USHORT ((unsigned short)~0) + +#define CURL_MASK_UINT ((unsigned int)~0) +#define CURL_MASK_SINT (CURL_MASK_UINT >> 1) + +#define CURL_MASK_ULONG ((unsigned long)~0) + +#define CURL_MASK_USIZE_T ((size_t)~0) +#define CURL_MASK_SSIZE_T (CURL_MASK_USIZE_T >> 1) + +/* + * unsigned long to unsigned char + */ +unsigned char curlx_ultouc(unsigned long ulnum) +{ +#ifdef __INTEL_COMPILER +#pragma warning(push) +#pragma warning(disable:810) /* conversion may lose significant bits */ +#endif + + DEBUGASSERT(ulnum <= (unsigned long)CURL_MASK_UCHAR); + return (unsigned char)(ulnum & (unsigned long)CURL_MASK_UCHAR); + +#ifdef __INTEL_COMPILER +#pragma warning(pop) +#endif +} + +/* + * unsigned size_t to signed int + */ +int curlx_uztosi(size_t uznum) +{ +#ifdef __INTEL_COMPILER +#pragma warning(push) +#pragma warning(disable:810) /* conversion may lose significant bits */ +#endif + + DEBUGASSERT(uznum <= (size_t)CURL_MASK_SINT); + return (int)(uznum & (size_t)CURL_MASK_SINT); + +#ifdef __INTEL_COMPILER +#pragma warning(pop) +#endif +} + +/* + * unsigned size_t to unsigned long + */ +unsigned long curlx_uztoul(size_t uznum) +{ +#ifdef __INTEL_COMPILER +#pragma warning(push) +#pragma warning(disable:810) /* conversion may lose significant bits */ +#endif + +#if ULONG_MAX < SIZE_MAX + DEBUGASSERT(uznum <= (size_t)CURL_MASK_ULONG); +#endif + return (unsigned long)(uznum & (size_t)CURL_MASK_ULONG); + +#ifdef __INTEL_COMPILER +#pragma warning(pop) +#endif +} + +/* + * unsigned size_t to unsigned int + */ +unsigned int curlx_uztoui(size_t uznum) +{ +#ifdef __INTEL_COMPILER +#pragma warning(push) +#pragma warning(disable:810) /* conversion may lose significant bits */ +#endif + +#if UINT_MAX < SIZE_MAX + DEBUGASSERT(uznum <= (size_t)CURL_MASK_UINT); +#endif + return (unsigned int)(uznum & (size_t)CURL_MASK_UINT); + +#ifdef __INTEL_COMPILER +#pragma warning(pop) +#endif +} + +/* + * signed long to signed int + */ +int curlx_sltosi(long slnum) +{ +#ifdef __INTEL_COMPILER +#pragma warning(push) +#pragma warning(disable:810) /* conversion may lose significant bits */ +#endif + + DEBUGASSERT(slnum >= 0); +#if INT_MAX < LONG_MAX + DEBUGASSERT((unsigned long)slnum <= (unsigned long)CURL_MASK_SINT); +#endif + return (int)(slnum & (long)CURL_MASK_SINT); + +#ifdef __INTEL_COMPILER +#pragma warning(pop) +#endif +} + +/* + * signed long to unsigned int + */ +unsigned int curlx_sltoui(long slnum) +{ +#ifdef __INTEL_COMPILER +#pragma warning(push) +#pragma warning(disable:810) /* conversion may lose significant bits */ +#endif + + DEBUGASSERT(slnum >= 0); +#if UINT_MAX < LONG_MAX + DEBUGASSERT((unsigned long)slnum <= (unsigned long)CURL_MASK_UINT); +#endif + return (unsigned int)(slnum & (long)CURL_MASK_UINT); + +#ifdef __INTEL_COMPILER +#pragma warning(pop) +#endif +} + +/* + * signed long to unsigned short + */ +unsigned short curlx_sltous(long slnum) +{ +#ifdef __INTEL_COMPILER +#pragma warning(push) +#pragma warning(disable:810) /* conversion may lose significant bits */ +#endif + + DEBUGASSERT(slnum >= 0); + DEBUGASSERT((unsigned long)slnum <= (unsigned long)CURL_MASK_USHORT); + return (unsigned short)(slnum & (long)CURL_MASK_USHORT); + +#ifdef __INTEL_COMPILER +#pragma warning(pop) +#endif +} + +/* + * unsigned size_t to signed ssize_t + */ +ssize_t curlx_uztosz(size_t uznum) +{ +#ifdef __INTEL_COMPILER +#pragma warning(push) +#pragma warning(disable:810) /* conversion may lose significant bits */ +#endif + + DEBUGASSERT(uznum <= (size_t)CURL_MASK_SSIZE_T); + return (ssize_t)(uznum & (size_t)CURL_MASK_SSIZE_T); + +#ifdef __INTEL_COMPILER +#pragma warning(pop) +#endif +} + +/* + * signed curl_off_t to unsigned size_t + */ +size_t curlx_sotouz(curl_off_t sonum) +{ +#ifdef __INTEL_COMPILER +#pragma warning(push) +#pragma warning(disable:810) /* conversion may lose significant bits */ +#endif + + DEBUGASSERT(sonum >= 0); + return (size_t)(sonum & (curl_off_t)CURL_MASK_USIZE_T); + +#ifdef __INTEL_COMPILER +#pragma warning(pop) +#endif +} + +/* + * signed ssize_t to signed int + */ +int curlx_sztosi(ssize_t sznum) +{ +#ifdef __INTEL_COMPILER +#pragma warning(push) +#pragma warning(disable:810) /* conversion may lose significant bits */ +#endif + + DEBUGASSERT(sznum >= 0); +#if INT_MAX < SSIZE_MAX + DEBUGASSERT((size_t)sznum <= (size_t)CURL_MASK_SINT); +#endif + return (int)(sznum & (ssize_t)CURL_MASK_SINT); + +#ifdef __INTEL_COMPILER +#pragma warning(pop) +#endif +} + +/* + * unsigned int to unsigned short + */ +unsigned short curlx_uitous(unsigned int uinum) +{ +#ifdef __INTEL_COMPILER +#pragma warning(push) +#pragma warning(disable:810) /* conversion may lose significant bits */ +#endif + + DEBUGASSERT(uinum <= (unsigned int)CURL_MASK_USHORT); + return (unsigned short)(uinum & (unsigned int)CURL_MASK_USHORT); + +#ifdef __INTEL_COMPILER +#pragma warning(pop) +#endif +} + +/* + * signed int to unsigned size_t + */ +size_t curlx_sitouz(int sinum) +{ +#ifdef __INTEL_COMPILER +#pragma warning(push) +#pragma warning(disable:810) /* conversion may lose significant bits */ +#endif + + DEBUGASSERT(sinum >= 0); + return (size_t)sinum; + +#ifdef __INTEL_COMPILER +#pragma warning(pop) +#endif +} + +size_t curlx_uitouz(unsigned int uinum) +{ + return (size_t)uinum; +} + +size_t curlx_sotouz_range(curl_off_t sonum, size_t uzmin, size_t uzmax) +{ + if(sonum < 0) + return uzmin; +#if SIZEOF_CURL_OFF_T > SIZEOF_SIZE_T + if(sonum > SIZE_MAX) + return uzmax; +#endif + return CURLMIN(CURLMAX((size_t)sonum, uzmin), uzmax); +} + +bool curlx_sztouz(ssize_t sznum, size_t *puznum) +{ + if(sznum < 0) { + *puznum = 0; + return FALSE; + } + *puznum = (size_t)sznum; + return TRUE; +} + +bool curlx_sotouz_fits(curl_off_t sonum, size_t *puznum) +{ + if(sonum < 0) { + *puznum = 0; + return FALSE; + } +#if SIZEOF_CURL_OFF_T > SIZEOF_SIZE_T + if(sonum > SIZE_MAX) { + *puznum = 0; + return FALSE; + } +#endif + *puznum = (size_t)sonum; + return TRUE; +} + +bool curlx_sltouz(long slnum, size_t *puznum) +{ + if(slnum < 0) { + *puznum = 0; + return FALSE; + } + /* We error in curl_setup.h if SIZEOF_LONG > SIZEOF_SIZE_T */ + *puznum = (size_t)slnum; + return TRUE; +} + +curl_off_t curlx_uztoso(size_t uznum) +{ +#if SIZEOF_SIZE_T >= SIZEOF_CURL_OFF_T + if(uznum > (size_t)CURL_OFF_T_MAX) + return CURL_OFF_T_MAX; +#endif + return (curl_off_t)uznum; +} diff --git a/3rdparty/curl-8.21.0/lib/curlx/warnless.h b/3rdparty/curl-8.21.0/lib/curlx/warnless.h new file mode 100644 index 0000000000..3d0341e418 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/warnless.h @@ -0,0 +1,74 @@ +#ifndef HEADER_CURL_WARNLESS_H +#define HEADER_CURL_WARNLESS_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +#define CURLX_FUNCTION_CAST(target_type, func) \ + (target_type)(void (*)(void))(func) + +unsigned char curlx_ultouc(unsigned long ulnum); + +int curlx_uztosi(size_t uznum); + +unsigned long curlx_uztoul(size_t uznum); + +unsigned int curlx_uztoui(size_t uznum); + +int curlx_sltosi(long slnum); + +unsigned int curlx_sltoui(long slnum); + +unsigned short curlx_sltous(long slnum); + +ssize_t curlx_uztosz(size_t uznum); + +size_t curlx_sotouz(curl_off_t sonum); + +int curlx_sztosi(ssize_t sznum); + +unsigned short curlx_uitous(unsigned int uinum); + +size_t curlx_sitouz(int sinum); + +size_t curlx_uitouz(unsigned int uinum); + +/* Convert a curl_off_t to fit into size_t interval [uzmin, uzmax]. + * values outside this interval give the lower/upper bound. */ +size_t curlx_sotouz_range(curl_off_t sonum, size_t uzmin, size_t uzmax); + +/* Convert a size_t to curl_off_t, return CURL_OFF_T_MAX if too large. */ +curl_off_t curlx_uztoso(size_t uznum); + +/* Convert a ssize_t to size_t, return FALSE if negative and set 0 */ +bool curlx_sztouz(ssize_t sznum, size_t *puznum); + +/* Convert a curl_off_t to size_t, return FALSE if negative or + * too large and set 0 */ +bool curlx_sotouz_fits(curl_off_t sonum, size_t *puznum); + +/* Convert a long to size_t, return FALSE if negative or too large + * and set 0 */ +bool curlx_sltouz(long slnum, size_t *puznum); + +#endif /* HEADER_CURL_WARNLESS_H */ diff --git a/3rdparty/curl-8.21.0/lib/curlx/winapi.c b/3rdparty/curl-8.21.0/lib/curlx/winapi.c new file mode 100644 index 0000000000..f025ca48c9 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/winapi.c @@ -0,0 +1,106 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +/* + * curlx_winapi_strerror: + * Variant of curlx_strerror if the error code is definitely Windows API. + */ +#ifdef _WIN32 +#include "curlx/winapi.h" +#include "curlx/snprintf.h" +#include "curlx/strcopy.h" + +/* This is a helper function for curlx_strerror that converts Windows API error + * codes (GetLastError) to error messages. + * Returns NULL if no error message was found for error code. + */ +const char *curlx_get_winapi_error(DWORD err, char *buf, size_t buflen) +{ + char *p; + + if(!buflen) + return NULL; + + /* We return the local codepage version of the error string because if it is + output to the user's terminal, it is likely done with functions which + expect the local codepage (eg fprintf, failf, infof). */ + if(!FormatMessageA((FORMAT_MESSAGE_FROM_SYSTEM | + FORMAT_MESSAGE_IGNORE_INSERTS), NULL, err, + LANG_NEUTRAL, buf, (DWORD)buflen, NULL)) { + *buf = '\0'; + return NULL; + } + + /* Truncate multiple lines */ + p = strchr(buf, '\n'); + if(p) { + if(p > buf && *(p - 1) == '\r') + *(p - 1) = '\0'; + else + *p = '\0'; + } + + return *buf ? buf : NULL; +} + +const char *curlx_winapi_strerror(DWORD err, char *buf, size_t buflen) +{ + DWORD old_win_err = GetLastError(); + int old_errno = errno; + + if(!buflen) + return NULL; + + *buf = '\0'; + +#ifdef CURLVERBOSE + if(!curlx_get_winapi_error(err, buf, buflen)) { +#if defined(__GNUC__) && __GNUC__ >= 7 +#pragma GCC diagnostic push +#pragma GCC diagnostic warning "-Wformat-truncation=1" +#endif + /* some GCC compilers cause false positive warnings if we allow this + warning */ + SNPRINTF(buf, buflen, "Unknown error %lu (0x%08lx)", err, err); +#if defined(__GNUC__) && __GNUC__ >= 7 +#pragma GCC diagnostic pop +#endif + } +#else + { + const char *txt = (err == ERROR_SUCCESS) ? "No error" : "Error"; + curlx_strcopy(buf, buflen, txt, strlen(txt)); + } +#endif + + if(errno != old_errno) + errno = old_errno; + + if(old_win_err != GetLastError()) + SetLastError(old_win_err); + + return buf; +} +#endif /* _WIN32 */ diff --git a/3rdparty/curl-8.21.0/lib/curlx/winapi.h b/3rdparty/curl-8.21.0/lib/curlx/winapi.h new file mode 100644 index 0000000000..d30f5efa13 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/curlx/winapi.h @@ -0,0 +1,33 @@ +#ifndef HEADER_CURLX_WINAPI_H +#define HEADER_CURLX_WINAPI_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +#ifdef _WIN32 +#define WINAPI_ERROR_LEN 100 +const char *curlx_get_winapi_error(DWORD err, char *buf, size_t buflen); +const char *curlx_winapi_strerror(DWORD err, char *buf, size_t buflen); +#endif + +#endif /* HEADER_CURLX_WINAPI_H */ diff --git a/3rdparty/curl-8.21.0/lib/cw-out.c b/3rdparty/curl-8.21.0/lib/cw-out.c new file mode 100644 index 0000000000..fad89b392c --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/cw-out.c @@ -0,0 +1,522 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "urldata.h" +#include "cfilters.h" +#include "multiif.h" +#include "sendf.h" +#include "curl_trc.h" +#include "transfer.h" +#include "cw-out.h" +#include "cw-pause.h" +#include "progress.h" + +/** + * OVERALL DESIGN of this client writer + * + * The 'cw-out' writer is supposed to be the last writer in a transfer's + * stack. It is always added when that stack is initialized. Its purpose + * is to pass BODY and HEADER bytes to the client-installed callback + * functions. + * + * These callback may return `CURL_WRITEFUNC_PAUSE` to indicate that the + * data had not been written and the whole transfer should stop receiving + * new data. Or at least, stop calling the functions. When the transfer + * is "unpaused" by the client, the previous data shall be passed as + * if nothing happened. + * + * The `cw-out` writer therefore manages buffers for bytes that could + * not be written. Data that was already in flight from the server also + * needs buffering on paused transfer when it arrives. + * + * In addition, the writer allows buffering of "small" body writes, + * so client functions are called less often. That is only enabled on a + * number of conditions. + * + * HEADER and BODY data may arrive in any order. For paused transfers, + * a list of `struct cw_out_buf` is kept for `cw_out_type` types. The + * list may be: [BODY]->[HEADER]->[BODY]->[HEADER].... + * When unpausing, this list is "played back" to the client callbacks. + * + * The amount of bytes being buffered is limited by `DYN_PAUSE_BUFFER` + * and when that is exceeded `CURLE_TOO_LARGE` is returned as error. + */ +typedef enum { + CW_OUT_NONE, + CW_OUT_BODY, + CW_OUT_BODY_0LEN, + CW_OUT_HDS +} cw_out_type; + +struct cw_out_buf { + struct cw_out_buf *next; + struct dynbuf b; + cw_out_type type; +}; + +static struct cw_out_buf *cw_out_buf_create(cw_out_type otype) +{ + struct cw_out_buf *cwbuf = curlx_calloc(1, sizeof(*cwbuf)); + if(cwbuf) { + cwbuf->type = otype; + curlx_dyn_init(&cwbuf->b, DYN_PAUSE_BUFFER); + } + return cwbuf; +} + +static void cw_out_buf_free(struct cw_out_buf *cwbuf) +{ + if(cwbuf) { + curlx_dyn_free(&cwbuf->b); + curlx_free(cwbuf); + } +} + +struct cw_out_ctx { + struct Curl_cwriter super; + struct cw_out_buf *buf; + BIT(paused); + BIT(errored); +}; + +static CURLcode cw_out_init(struct Curl_easy *data, + struct Curl_cwriter *writer) +{ + struct cw_out_ctx *ctx = writer->ctx; + (void)data; + ctx->buf = NULL; + return CURLE_OK; +} + +static void cw_out_bufs_free(struct cw_out_ctx *ctx) +{ + while(ctx->buf) { + struct cw_out_buf *next = ctx->buf->next; + cw_out_buf_free(ctx->buf); + ctx->buf = next; + } +} + +static size_t cw_out_bufs_len(struct cw_out_ctx *ctx) +{ + struct cw_out_buf *cwbuf = ctx->buf; + size_t len = 0; + while(cwbuf) { + len += curlx_dyn_len(&cwbuf->b); + cwbuf = cwbuf->next; + } + return len; +} + +static void cw_out_close(struct Curl_easy *data, struct Curl_cwriter *writer) +{ + struct cw_out_ctx *ctx = writer->ctx; + + (void)data; + cw_out_bufs_free(ctx); +} + +/** + * Return the current curl_write_callback and user_data for the buf type + */ +static void cw_get_writefunc(struct Curl_easy *data, cw_out_type otype, + curl_write_callback *pwcb, void **pwcb_data, + size_t *pmax_write, size_t *pmin_write) +{ + switch(otype) { + case CW_OUT_BODY: + case CW_OUT_BODY_0LEN: + *pwcb = data->set.fwrite_func; + *pwcb_data = data->set.out; + *pmax_write = CURL_MAX_WRITE_SIZE; + /* if we ever want buffering of BODY output, we can set `min_write` + * the preferred size. The default should always be to pass data + * to the client as it comes without delay */ + *pmin_write = 0; + break; + case CW_OUT_HDS: + *pwcb = data->set.fwrite_header ? data->set.fwrite_header : + (data->set.writeheader ? data->set.fwrite_func : NULL); + *pwcb_data = data->set.writeheader; + *pmax_write = 0; /* do not chunk-write headers, write them as they are */ + *pmin_write = 0; + break; + default: + *pwcb = NULL; + *pwcb_data = NULL; + *pmax_write = CURL_MAX_WRITE_SIZE; + *pmin_write = 0; + } +} + +static CURLcode cw_out_cb_write(struct cw_out_ctx *ctx, + struct Curl_easy *data, + curl_write_callback wcb, + void *wcb_data, + cw_out_type otype, + const char *buf, size_t blen, + size_t *pnwritten) +{ + size_t nwritten; + CURLcode result; + + NOVERBOSE((void)otype); + + DEBUGASSERT(data->conn); + *pnwritten = 0; + Curl_set_in_callback(data, TRUE); + nwritten = wcb((char *)CURL_UNCONST(buf), 1, blen, wcb_data); + Curl_set_in_callback(data, FALSE); + CURL_TRC_WRITE(data, "[OUT] wrote %zu %s bytes -> %zu", + blen, (otype == CW_OUT_HDS) ? "header" : "body", + nwritten); + if(nwritten == CURL_WRITEFUNC_PAUSE) { + if(data->conn->scheme->flags & PROTOPT_NONETWORK) { + /* Protocols that work without network cannot be paused. This is + actually only file:// now, and it cannot pause since the transfer is + not done using the "normal" procedure. */ + failf(data, "Write callback asked for PAUSE when not supported"); + return CURLE_WRITE_ERROR; + } + ctx->paused = TRUE; + CURL_TRC_WRITE(data, "[OUT] PAUSE requested by client"); + result = Curl_xfer_pause_recv(data, TRUE); + return result ? result : CURLE_AGAIN; + } + else if(nwritten == CURL_WRITEFUNC_ERROR) { + failf(data, "client returned ERROR on write of %zu bytes", blen); + return CURLE_WRITE_ERROR; + } + else if(nwritten != blen) { + failf(data, "Failure writing output to destination, " + "passed %zu returned %zu", blen, nwritten); + return CURLE_WRITE_ERROR; + } + *pnwritten = nwritten; + return CURLE_OK; +} + +static CURLcode cw_out_ptr_flush(struct cw_out_ctx *ctx, + struct Curl_easy *data, + cw_out_type otype, + bool flush_all, + const char *buf, size_t blen, + size_t *pconsumed) +{ + curl_write_callback wcb = NULL; + void *wcb_data; + size_t max_write, min_write; + size_t wlen, nwritten = 0; + CURLcode result = CURLE_OK; + + /* If we errored once, we do not invoke the client callback again */ + if(ctx->errored) + return CURLE_WRITE_ERROR; + + /* write callbacks may get NULLed by the client between calls. */ + cw_get_writefunc(data, otype, &wcb, &wcb_data, &max_write, &min_write); + if(!wcb) { + *pconsumed = blen; + return CURLE_OK; + } + + *pconsumed = 0; + if(otype == CW_OUT_BODY_0LEN) { + DEBUGASSERT(!blen); + return cw_out_cb_write(ctx, data, wcb, wcb_data, otype, + buf, blen, &nwritten); + } + else { + while(blen && !ctx->paused) { + if(!flush_all && blen < min_write) + break; + wlen = max_write ? CURLMIN(blen, max_write) : blen; + if(otype == CW_OUT_BODY) + result = Curl_pgrs_deliver_check(data, wlen); + if(!result) + result = cw_out_cb_write(ctx, data, wcb, wcb_data, otype, + buf, wlen, &nwritten); + if(result) + return result; + if(otype == CW_OUT_BODY) + Curl_pgrs_deliver_inc(data, nwritten); + *pconsumed += nwritten; + blen -= nwritten; + buf += nwritten; + } + } + return CURLE_OK; +} + +static CURLcode cw_out_buf_flush(struct cw_out_ctx *ctx, + struct Curl_easy *data, + struct cw_out_buf *cwbuf, + bool flush_all) +{ + CURLcode result = CURLE_OK; + + if(curlx_dyn_len(&cwbuf->b) || (cwbuf->type == CW_OUT_BODY_0LEN)) { + size_t consumed; + + result = cw_out_ptr_flush(ctx, data, cwbuf->type, flush_all, + curlx_dyn_ptr(&cwbuf->b), + curlx_dyn_len(&cwbuf->b), + &consumed); + if(result && (result != CURLE_AGAIN)) + return result; + result = CURLE_OK; + + if(consumed) { + if(consumed == curlx_dyn_len(&cwbuf->b)) { + curlx_dyn_free(&cwbuf->b); + } + else { + DEBUGASSERT(consumed < curlx_dyn_len(&cwbuf->b)); + result = curlx_dyn_tail(&cwbuf->b, + curlx_dyn_len(&cwbuf->b) - consumed); + if(result) + return result; + } + } + } + return result; +} + +static CURLcode cw_out_flush_chain(struct cw_out_ctx *ctx, + struct Curl_easy *data, + struct cw_out_buf **pcwbuf, + bool flush_all) +{ + struct cw_out_buf *cwbuf = *pcwbuf; + CURLcode result; + + if(!cwbuf) + return CURLE_OK; + if(ctx->paused) + return CURLE_OK; + + /* write the end of the chain until it blocks or gets empty */ + while(cwbuf->next) { + struct cw_out_buf **plast = &cwbuf->next; + while((*plast)->next) + plast = &(*plast)->next; + result = cw_out_flush_chain(ctx, data, plast, flush_all); + if(result) + return result; + if(*plast) { + /* could not write last, paused again? */ + DEBUGASSERT(ctx->paused); + return CURLE_OK; + } + } + + result = cw_out_buf_flush(ctx, data, cwbuf, flush_all); + if(result) + return result; + if(!curlx_dyn_len(&cwbuf->b)) { + cw_out_buf_free(cwbuf); + *pcwbuf = NULL; + } + return CURLE_OK; +} + +static CURLcode cw_out_append(struct cw_out_ctx *ctx, + struct Curl_easy *data, + cw_out_type otype, + const char *buf, size_t blen) +{ + CURL_TRC_WRITE(data, "[OUT] paused, buffering %zu more bytes (%zu/%d)", + blen, cw_out_bufs_len(ctx), DYN_PAUSE_BUFFER); + if(cw_out_bufs_len(ctx) + blen > DYN_PAUSE_BUFFER) { + failf(data, "pause buffer not large enough -> CURLE_TOO_LARGE"); + return CURLE_TOO_LARGE; + } + + /* if we do not have a buffer, or it is of another type, make a new one. + * For CW_OUT_HDS always make a new one, so we "replay" headers exactly + * as they came in */ + if(!ctx->buf || (ctx->buf->type != otype) || (otype == CW_OUT_HDS)) { + struct cw_out_buf *cwbuf = cw_out_buf_create(otype); + if(!cwbuf) + return CURLE_OUT_OF_MEMORY; + cwbuf->next = ctx->buf; + ctx->buf = cwbuf; + } + DEBUGASSERT(ctx->buf && (ctx->buf->type == otype)); + return curlx_dyn_addn(&ctx->buf->b, buf, blen); +} + +static CURLcode cw_out_do_write(struct cw_out_ctx *ctx, + struct Curl_easy *data, + cw_out_type otype, + bool flush_all, + const char *buf, size_t blen) +{ + CURLcode result = CURLE_OK; + + /* if we have buffered data and it is a different type than what + * we are writing now, try to flush all */ + if(ctx->buf && ctx->buf->type != otype) { + result = cw_out_flush_chain(ctx, data, &ctx->buf, TRUE); + if(result) + goto out; + } + + if(ctx->buf) { + /* still have buffered data, append and flush */ + result = cw_out_append(ctx, data, otype, buf, blen); + if(result) + goto out; + result = cw_out_flush_chain(ctx, data, &ctx->buf, flush_all); + if(result) + goto out; + } + else { + /* nothing buffered, try direct write */ + size_t consumed; + result = cw_out_ptr_flush(ctx, data, otype, flush_all, + buf, blen, &consumed); + if(result && (result != CURLE_AGAIN)) + return result; + result = CURLE_OK; + if(consumed < blen) { + /* did not write all, append the rest */ + result = cw_out_append(ctx, data, otype, + buf + consumed, blen - consumed); + if(result) + goto out; + } + } + +out: + if(result) { + /* We do not want to invoked client callbacks a second time after + * encountering an error. See issue #13337 */ + ctx->errored = TRUE; + cw_out_bufs_free(ctx); + } + return result; +} + +static CURLcode cw_out_write(struct Curl_easy *data, + struct Curl_cwriter *writer, int type, + const char *buf, size_t blen) +{ + struct cw_out_ctx *ctx = writer->ctx; + CURLcode result; + bool flush_all = !!(type & CLIENTWRITE_EOS); + + if((type & CLIENTWRITE_BODY) || + ((type & CLIENTWRITE_HEADER) && data->set.include_header)) { + cw_out_type otype = (!blen && (type & CLIENTWRITE_0LEN)) ? + CW_OUT_BODY_0LEN : CW_OUT_BODY; + result = cw_out_do_write(ctx, data, otype, flush_all, buf, blen); + if(result) + return result; + } + + if(type & (CLIENTWRITE_HEADER | CLIENTWRITE_INFO)) { + result = cw_out_do_write(ctx, data, CW_OUT_HDS, flush_all, buf, blen); + if(result) + return result; + } + + return CURLE_OK; +} + +const struct Curl_cwtype Curl_cwt_out = { + "cw-out", + NULL, + cw_out_init, + cw_out_write, + cw_out_close, + sizeof(struct cw_out_ctx) +}; + +bool Curl_cw_out_is_paused(struct Curl_easy *data) +{ + struct Curl_cwriter *cw_out; + struct cw_out_ctx *ctx; + + cw_out = Curl_cwriter_get_by_type(data, &Curl_cwt_out); + if(!cw_out) + return FALSE; + + ctx = (struct cw_out_ctx *)cw_out; + return (bool)ctx->paused; +} + +static CURLcode cw_out_flush(struct Curl_easy *data, + struct Curl_cwriter *cw_out, + bool flush_all) +{ + struct cw_out_ctx *ctx = (struct cw_out_ctx *)cw_out; + CURLcode result = CURLE_OK; + + if(ctx->errored) + return CURLE_WRITE_ERROR; + if(ctx->paused) + return CURLE_OK; /* not doing it */ + + result = cw_out_flush_chain(ctx, data, &ctx->buf, flush_all); + if(result) { + ctx->errored = TRUE; + cw_out_bufs_free(ctx); + return result; + } + return result; +} + +CURLcode Curl_cw_out_unpause(struct Curl_easy *data) +{ + struct Curl_cwriter *cw_out; + CURLcode result = CURLE_OK; + + cw_out = Curl_cwriter_get_by_type(data, &Curl_cwt_out); + if(cw_out) { + struct cw_out_ctx *ctx = (struct cw_out_ctx *)cw_out; + CURL_TRC_WRITE(data, "[OUT] unpause"); + ctx->paused = FALSE; + result = Curl_cw_pause_flush(data); + if(!result) + result = cw_out_flush(data, cw_out, FALSE); + } + return result; +} + +CURLcode Curl_cw_out_done(struct Curl_easy *data) +{ + struct Curl_cwriter *cw_out; + CURLcode result = CURLE_OK; + + cw_out = Curl_cwriter_get_by_type(data, &Curl_cwt_out); + if(cw_out) { + CURL_TRC_WRITE(data, "[OUT] done"); + result = Curl_cw_pause_flush(data); + if(!result) + result = cw_out_flush(data, cw_out, TRUE); + } + return result; +} diff --git a/3rdparty/curl-8.21.0/lib/cw-out.h b/3rdparty/curl-8.21.0/lib/cw-out.h new file mode 100644 index 0000000000..7de6524bc5 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/cw-out.h @@ -0,0 +1,52 @@ +#ifndef HEADER_CURL_CW_OUT_H +#define HEADER_CURL_CW_OUT_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +struct Curl_easy; + +/** + * The client writer type "cw-out" that does the actual writing to + * the client callbacks. Intended to be the last installed in the + * client writer stack of a transfer. + */ +extern const struct Curl_cwtype Curl_cwt_out; + +/** + * Return TRUE iff 'cw-out' client write has paused data. + */ +bool Curl_cw_out_is_paused(struct Curl_easy *data); + +/** + * Flush any buffered date to the client, chunk collation still applies. + */ +CURLcode Curl_cw_out_unpause(struct Curl_easy *data); + +/** + * Mark EndOfStream reached and flush ALL data to the client. + */ +CURLcode Curl_cw_out_done(struct Curl_easy *data); + +#endif /* HEADER_CURL_CW_OUT_H */ diff --git a/3rdparty/curl-8.21.0/lib/cw-pause.c b/3rdparty/curl-8.21.0/lib/cw-pause.c new file mode 100644 index 0000000000..5561a8d7b7 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/cw-pause.c @@ -0,0 +1,227 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "urldata.h" +#include "bufq.h" +#include "cfilters.h" +#include "sendf.h" +#include "curl_trc.h" +#include "cw-pause.h" + + +/* body dynbuf sizes */ +#define CW_PAUSE_BUF_CHUNK (16 * 1024) +/* when content decoding, write data in chunks */ +#define CW_PAUSE_DEC_WRITE_CHUNK 4096 + +struct cw_pause_buf { + struct cw_pause_buf *next; + struct bufq b; + int type; +}; + +static struct cw_pause_buf *cw_pause_buf_create(int type, size_t buflen) +{ + struct cw_pause_buf *cwbuf = curlx_calloc(1, sizeof(*cwbuf)); + if(cwbuf) { + cwbuf->type = type; + if(type & CLIENTWRITE_BODY) + Curl_bufq_init2(&cwbuf->b, CW_PAUSE_BUF_CHUNK, 1, + (BUFQ_OPT_SOFT_LIMIT | BUFQ_OPT_NO_SPARES)); + else + Curl_bufq_init(&cwbuf->b, buflen, 1); + } + return cwbuf; +} + +static void cw_pause_buf_free(struct cw_pause_buf *cwbuf) +{ + if(cwbuf) { + Curl_bufq_free(&cwbuf->b); + curlx_free(cwbuf); + } +} + +struct cw_pause_ctx { + struct Curl_cwriter super; + struct cw_pause_buf *buf; + size_t buf_total; +}; + +static CURLcode cw_pause_init(struct Curl_easy *data, + struct Curl_cwriter *writer) +{ + struct cw_pause_ctx *ctx = writer->ctx; + (void)data; + ctx->buf = NULL; + return CURLE_OK; +} + +static void cw_pause_bufs_free(struct cw_pause_ctx *ctx) +{ + while(ctx->buf) { + struct cw_pause_buf *next = ctx->buf->next; + cw_pause_buf_free(ctx->buf); + ctx->buf = next; + } +} + +static void cw_pause_close(struct Curl_easy *data, struct Curl_cwriter *writer) +{ + struct cw_pause_ctx *ctx = writer->ctx; + + (void)data; + cw_pause_bufs_free(ctx); +} + +static CURLcode cw_pause_flush(struct Curl_easy *data, + struct Curl_cwriter *cw_pause) +{ + struct cw_pause_ctx *ctx = (struct cw_pause_ctx *)cw_pause; + bool decoding = Curl_cwriter_is_content_decoding(data); + CURLcode result = CURLE_OK; + + /* write the end of the chain until it blocks or gets empty */ + while(ctx->buf && !Curl_cwriter_is_paused(data)) { + struct cw_pause_buf **plast = &ctx->buf; + size_t blen, wlen = 0; + const unsigned char *buf = NULL; + + while((*plast)->next) /* got to last in list */ + plast = &(*plast)->next; + if(Curl_bufq_peek(&(*plast)->b, &buf, &blen)) { + wlen = (decoding && ((*plast)->type & CLIENTWRITE_BODY)) ? + CURLMIN(blen, CW_PAUSE_DEC_WRITE_CHUNK) : blen; + result = Curl_cwriter_write(data, cw_pause->next, (*plast)->type, + (const char *)buf, wlen); + CURL_TRC_WRITE(data, "[PAUSE] flushed %zu/%zu bytes, type=%x -> %d", + wlen, ctx->buf_total, (unsigned int)(*plast)->type, + (int)result); + Curl_bufq_skip(&(*plast)->b, wlen); + DEBUGASSERT(ctx->buf_total >= wlen); + ctx->buf_total -= wlen; + if(result) + return result; + } + else if((*plast)->type & CLIENTWRITE_EOS) { + result = Curl_cwriter_write(data, cw_pause->next, (*plast)->type, + (const char *)buf, 0); + CURL_TRC_WRITE(data, "[PAUSE] flushed 0/%zu bytes, type=%x -> %d", + ctx->buf_total, (unsigned int)(*plast)->type, + (int)result); + } + + if(Curl_bufq_is_empty(&(*plast)->b)) { + cw_pause_buf_free(*plast); + *plast = NULL; + } + } + return result; +} + +static CURLcode cw_pause_write(struct Curl_easy *data, + struct Curl_cwriter *writer, int type, + const char *buf, size_t blen) +{ + struct cw_pause_ctx *ctx = writer->ctx; + CURLcode result = CURLE_OK; + size_t wlen = 0; + bool decoding = Curl_cwriter_is_content_decoding(data); + + if(ctx->buf && !Curl_cwriter_is_paused(data)) { + result = cw_pause_flush(data, writer); + if(result) + return result; + } + + while(!ctx->buf && !Curl_cwriter_is_paused(data)) { + int wtype = type; + DEBUGASSERT(!ctx->buf); + /* content decoding might blow up size considerably, write smaller + * chunks to make pausing need buffer less. */ + wlen = (decoding && (type & CLIENTWRITE_BODY)) ? + CURLMIN(blen, CW_PAUSE_DEC_WRITE_CHUNK) : blen; + if(wlen < blen) + wtype &= ~CLIENTWRITE_EOS; + result = Curl_cwriter_write(data, writer->next, wtype, buf, wlen); + CURL_TRC_WRITE(data, "[PAUSE] writing %zu/%zu bytes of type %x -> %d", + wlen, blen, (unsigned int)wtype, (int)result); + if(result) + return result; + buf += wlen; + blen -= wlen; + if(!blen) + return result; + } + + do { + size_t nwritten = 0; + if(ctx->buf && (ctx->buf->type == type) && (type & CLIENTWRITE_BODY)) { + /* same type and body, append to current buffer which has a soft + * limit and should take everything up to OOM. */ + result = Curl_bufq_cwrite(&ctx->buf->b, buf, blen, &nwritten); + } + else { + /* Need a new buf, type changed */ + struct cw_pause_buf *cwbuf = cw_pause_buf_create(type, blen); + if(!cwbuf) + return CURLE_OUT_OF_MEMORY; + cwbuf->next = ctx->buf; + ctx->buf = cwbuf; + result = Curl_bufq_cwrite(&ctx->buf->b, buf, blen, &nwritten); + } + CURL_TRC_WRITE(data, "[PAUSE] buffer %zu more bytes of type %x, " + "total=%zu -> %d", nwritten, (unsigned int)type, + ctx->buf_total + wlen, (int)result); + if(result) + return result; + buf += nwritten; + blen -= nwritten; + ctx->buf_total += nwritten; + } while(blen); + + return result; +} + +const struct Curl_cwtype Curl_cwt_pause = { + "cw-pause", + NULL, + cw_pause_init, + cw_pause_write, + cw_pause_close, + sizeof(struct cw_pause_ctx) +}; + +CURLcode Curl_cw_pause_flush(struct Curl_easy *data) +{ + struct Curl_cwriter *cw_pause; + CURLcode result = CURLE_OK; + + cw_pause = Curl_cwriter_get_by_type(data, &Curl_cwt_pause); + if(cw_pause) + result = cw_pause_flush(data, cw_pause); + + return result; +} diff --git a/3rdparty/curl-8.21.0/lib/cw-pause.h b/3rdparty/curl-8.21.0/lib/cw-pause.h new file mode 100644 index 0000000000..544cbfa577 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/cw-pause.h @@ -0,0 +1,38 @@ +#ifndef HEADER_CURL_CW_PAUSE_H +#define HEADER_CURL_CW_PAUSE_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +struct Curl_easy; + +/** + * The client writer type "cw-pause" that buffers writes for + * paused transfer writes. + */ +extern const struct Curl_cwtype Curl_cwt_pause; + +CURLcode Curl_cw_pause_flush(struct Curl_easy *data); + +#endif /* HEADER_CURL_CW_PAUSE_H */ diff --git a/3rdparty/curl-8.21.0/lib/dict.c b/3rdparty/curl-8.21.0/lib/dict.c new file mode 100644 index 0000000000..db25d5a721 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/dict.c @@ -0,0 +1,297 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" +#include "urldata.h" +#include "dict.h" + +#ifndef CURL_DISABLE_DICT + +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETDB_H +#include +#endif +#ifdef HAVE_ARPA_INET_H +#include +#endif +#ifdef HAVE_NET_IF_H +#include +#endif +#ifdef HAVE_SYS_IOCTL_H +#include +#endif + +#ifdef HAVE_SYS_PARAM_H +#include +#endif + +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif + +#include "transfer.h" +#include "curl_trc.h" +#include "escape.h" + +#define DICT_MATCH "/MATCH:" +#define DICT_MATCH2 "/M:" +#define DICT_MATCH3 "/FIND:" +#define DICT_DEFINE "/DEFINE:" +#define DICT_DEFINE2 "/D:" +#define DICT_DEFINE3 "/LOOKUP:" + +#define DYN_DICT_WORD 10000 +static char *unescape_word(const char *input) +{ + struct dynbuf out; + const char *ptr; + CURLcode result = CURLE_OK; + curlx_dyn_init(&out, DYN_DICT_WORD); + + /* According to RFC2229 section 2.2, these letters need to be escaped with + \[letter] */ + for(ptr = input; *ptr; ptr++) { + char ch = *ptr; + if((ch <= 32) || (ch == 127) || + (ch == '\'') || (ch == '\"') || (ch == '\\')) + result = curlx_dyn_addn(&out, "\\", 1); + if(!result) + result = curlx_dyn_addn(&out, ptr, 1); + if(result) + return NULL; + } + return curlx_dyn_ptr(&out); +} + +/* sendf() sends formatted data to the server */ +static CURLcode sendf(struct Curl_easy *data, + const char *fmt, ...) CURL_PRINTF(2, 3); + +static CURLcode sendf(struct Curl_easy *data, const char *fmt, ...) +{ + size_t bytes_written; + size_t write_len; + CURLcode result = CURLE_OK; + char *s; + char *sptr; + va_list ap; + va_start(ap, fmt); + s = curl_mvaprintf(fmt, ap); /* returns an allocated string */ + va_end(ap); + if(!s) + return CURLE_OUT_OF_MEMORY; /* failure */ + + bytes_written = 0; + write_len = strlen(s); + sptr = s; + + for(;;) { + /* Write the buffer to the socket */ + result = Curl_xfer_send(data, sptr, write_len, FALSE, &bytes_written); + + if(result) + break; + + Curl_debug(data, CURLINFO_DATA_OUT, sptr, bytes_written); + + if(bytes_written != write_len) { + /* if not all was written at once, we must advance the pointer, decrease + the size left and try again! */ + write_len -= bytes_written; + sptr += bytes_written; + } + else + break; + } + + curlx_free(s); /* free the output string */ + + return result; +} + +static CURLcode dict_do(struct Curl_easy *data, bool *done) +{ + char *word; + char *eword = NULL; + char *ppath; + char *database = NULL; + char *strategy = NULL; + char *nthdef = NULL; /* This is not part of the protocol, but required + by RFC 2229 */ + CURLcode result; + + char *path; + + *done = TRUE; /* unconditionally */ + + /* URL-decode path before further evaluation */ + result = Curl_urldecode(data->state.up.path, 0, &path, NULL, REJECT_CTRL); + if(result) + return result; + + if(curl_strnequal(path, DICT_MATCH, sizeof(DICT_MATCH) - 1) || + curl_strnequal(path, DICT_MATCH2, sizeof(DICT_MATCH2) - 1) || + curl_strnequal(path, DICT_MATCH3, sizeof(DICT_MATCH3) - 1)) { + + word = strchr(path, ':'); + if(word) { + word++; + database = strchr(word, ':'); + if(database) { + *database++ = (char)0; + strategy = strchr(database, ':'); + if(strategy) { + *strategy++ = (char)0; + nthdef = strchr(strategy, ':'); + if(nthdef) { + *nthdef = (char)0; + } + } + } + } + + if(!word || (*word == (char)0)) { + infof(data, "lookup word is missing"); + } + eword = unescape_word((!word || (*word == (char)0)) ? "default" : word); + if(!eword) { + result = CURLE_OUT_OF_MEMORY; + goto error; + } + + result = sendf(data, + "CLIENT " LIBCURL_NAME " " LIBCURL_VERSION "\r\n" + "MATCH " + "%s " /* database */ + "%s " /* strategy */ + "%s\r\n" /* word */ + "QUIT\r\n", + (!database || (*database == (char)0)) ? "!" : database, + (!strategy || (*strategy == (char)0)) ? "." : strategy, + eword); + + if(result) { + failf(data, "Failed sending DICT request"); + goto error; + } + Curl_xfer_setup_recv(data, FIRSTSOCKET, -1); + } + else if(curl_strnequal(path, DICT_DEFINE, sizeof(DICT_DEFINE) - 1) || + curl_strnequal(path, DICT_DEFINE2, sizeof(DICT_DEFINE2) - 1) || + curl_strnequal(path, DICT_DEFINE3, sizeof(DICT_DEFINE3) - 1)) { + + word = strchr(path, ':'); + if(word) { + word++; + database = strchr(word, ':'); + if(database) { + *database++ = (char)0; + nthdef = strchr(database, ':'); + if(nthdef) { + *nthdef = (char)0; + } + } + } + + if(!word || (*word == (char)0)) { + infof(data, "lookup word is missing"); + } + eword = unescape_word((!word || (*word == (char)0)) ? "default" : word); + if(!eword) { + result = CURLE_OUT_OF_MEMORY; + goto error; + } + + result = sendf(data, + "CLIENT " LIBCURL_NAME " " LIBCURL_VERSION "\r\n" + "DEFINE " + "%s " /* database */ + "%s\r\n" /* word */ + "QUIT\r\n", + (!database || (*database == (char)0)) ? "!" : database, + eword); + + if(result) { + failf(data, "Failed sending DICT request"); + goto error; + } + Curl_xfer_setup_recv(data, FIRSTSOCKET, -1); + } + else { + + ppath = strchr(path, '/'); + if(ppath) { + int i; + + ppath++; + for(i = 0; ppath[i]; i++) { + if(ppath[i] == ':') + ppath[i] = ' '; + } + result = sendf(data, + "CLIENT " LIBCURL_NAME " " LIBCURL_VERSION "\r\n" + "%s\r\n" + "QUIT\r\n", ppath); + if(result) { + failf(data, "Failed sending DICT request"); + goto error; + } + + Curl_xfer_setup_recv(data, FIRSTSOCKET, -1); + } + } + +error: + curlx_free(eword); + curlx_free(path); + return result; +} + +/* + * DICT protocol + */ +const struct Curl_protocol Curl_protocol_dict = { + ZERO_NULL, /* setup_connection */ + dict_do, /* do_it */ + ZERO_NULL, /* done */ + ZERO_NULL, /* do_more */ + ZERO_NULL, /* connect_it */ + ZERO_NULL, /* connecting */ + ZERO_NULL, /* doing */ + ZERO_NULL, /* proto_pollset */ + ZERO_NULL, /* doing_pollset */ + ZERO_NULL, /* domore_pollset */ + ZERO_NULL, /* perform_pollset */ + ZERO_NULL, /* disconnect */ + ZERO_NULL, /* write_resp */ + ZERO_NULL, /* write_resp_hd */ + ZERO_NULL, /* connection_is_dead */ + ZERO_NULL, /* attach connection */ + ZERO_NULL, /* follow */ +}; + +#endif /* CURL_DISABLE_DICT */ diff --git a/3rdparty/curl-8.21.0/lib/dict.h b/3rdparty/curl-8.21.0/lib/dict.h new file mode 100644 index 0000000000..5bdfcff816 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/dict.h @@ -0,0 +1,30 @@ +#ifndef HEADER_CURL_DICT_H +#define HEADER_CURL_DICT_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#ifndef CURL_DISABLE_DICT +extern const struct Curl_protocol Curl_protocol_dict; +#endif + +#endif /* HEADER_CURL_DICT_H */ diff --git a/3rdparty/curl-8.21.0/lib/dllmain.c b/3rdparty/curl-8.21.0/lib/dllmain.c new file mode 100644 index 0000000000..5aa6565010 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/dllmain.c @@ -0,0 +1,64 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_OPENSSL +#include +#endif + +/* DllMain() must only be defined for Windows DLL builds. */ +#if defined(_WIN32) && !defined(CURL_STATICLIB) + +#if defined(USE_OPENSSL) && \ + !defined(OPENSSL_IS_AWSLC) && !defined(OPENSSL_IS_BORINGSSL) && \ + !defined(LIBRESSL_VERSION_NUMBER) +#define PREVENT_OPENSSL_MEMLEAK +#endif + +#ifdef PREVENT_OPENSSL_MEMLEAK +BOOL WINAPI DllMain(HINSTANCE hinstDLL, DWORD fdwReason, LPVOID lpvReserved); +BOOL WINAPI DllMain(HINSTANCE hinstDLL, DWORD fdwReason, LPVOID lpvReserved) +{ + (void)hinstDLL; + (void)lpvReserved; + + switch(fdwReason) { + case DLL_PROCESS_ATTACH: + break; + case DLL_PROCESS_DETACH: + break; + case DLL_THREAD_ATTACH: + break; + case DLL_THREAD_DETACH: + /* Call OPENSSL_thread_stop to prevent a memory leak in case OpenSSL is + linked statically. + https://github.com/curl/curl/issues/12327#issuecomment-1826405944 */ + OPENSSL_thread_stop(); + break; + } + return TRUE; +} +#endif /* USE_OPENSSL (non-fork) */ + +#endif /* _WIN32 && !CURL_STATICLIB */ diff --git a/3rdparty/curl-8.21.0/lib/dnscache.c b/3rdparty/curl-8.21.0/lib/dnscache.c new file mode 100644 index 0000000000..9c8341e56f --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/dnscache.c @@ -0,0 +1,859 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include +#endif +#ifdef HAVE_NETDB_H +#include +#endif +#ifdef HAVE_ARPA_INET_H +#include +#endif +#ifdef __VMS +#include +#include +#endif + +#include "urldata.h" +#include "curl_addrinfo.h" +#include "curl_share.h" +#include "curl_trc.h" +#include "dnscache.h" +#include "hash.h" +#include "hostip.h" +#include "httpsrr.h" +#include "progress.h" +#include "rand.h" +#include "strcase.h" +#include "curlx/inet_ntop.h" +#include "curlx/inet_pton.h" +#include "curlx/strcopy.h" +#include "curlx/strparse.h" + +#define MAX_HOSTCACHE_LEN (255 + 7) /* max FQDN + colon + port number + zero */ + +#define MAX_DNS_CACHE_SIZE 29999 + +static void dnscache_entry_free(struct Curl_dns_entry *dns) +{ + Curl_freeaddrinfo(dns->addr); +#ifdef USE_HTTPSRR + if(dns->hinfo) { + Curl_httpsrr_cleanup(dns->hinfo); + curlx_free(dns->hinfo); + } +#endif + curlx_free(dns); +} + +/* + * Create a hostcache id string for the provided host + port, to be used by + * the DNS caching. Without alloc. Return length of the id string. + */ +static size_t create_dnscache_id(const char *name, + size_t nlen, /* 0 or actual name length */ + uint16_t port, char *ptr, size_t buflen) +{ + size_t len = nlen ? nlen : strlen(name); + DEBUGASSERT(buflen >= MAX_HOSTCACHE_LEN); + if(len > (buflen - 7)) + len = buflen - 7; + /* store and lower case the name */ + Curl_strntolower(ptr, name, len); + return curl_msnprintf(&ptr[len], 7, ":%u", port) + len; +} + +struct dnscache_prune_data { + struct curltime now; + timediff_t oldest_ms; /* oldest time in cache not pruned. */ + timediff_t max_age_ms; +}; + +/* + * This function is set as a callback to be called for every entry in the DNS + * cache when we want to prune old unused entries. + * + * Returning non-zero means remove the entry, return 0 to keep it in the + * cache. + */ +static int dnscache_entry_is_stale(void *datap, void *hc) +{ + struct dnscache_prune_data *prune = (struct dnscache_prune_data *)datap; + struct Curl_dns_entry *dns = (struct Curl_dns_entry *)hc; + + if(dns->timestamp.tv_sec || dns->timestamp.tv_usec) { + /* get age in milliseconds */ + timediff_t age = curlx_ptimediff_ms(&prune->now, &dns->timestamp); + if(!dns->addr) + age *= 2; /* negative entries age twice as fast */ + if(age >= prune->max_age_ms) + return TRUE; + if(age > prune->oldest_ms) + prune->oldest_ms = age; + } + return FALSE; +} + +/* + * Prune the DNS cache. This assumes that a lock has already been taken. + * Returns the 'age' of the oldest still kept entry - in milliseconds. + */ +static timediff_t dnscache_prune(struct Curl_hash *hostcache, + timediff_t cache_timeout_ms, + struct curltime now) +{ + struct dnscache_prune_data user; + + user.max_age_ms = cache_timeout_ms; + user.now = now; + user.oldest_ms = 0; + + Curl_hash_clean_with_criterium(hostcache, + (void *)&user, + dnscache_entry_is_stale); + + return user.oldest_ms; +} + +static struct Curl_dnscache *dnscache_get(struct Curl_easy *data) +{ + if(data->share && data->share->specifier & (1 << CURL_LOCK_DATA_DNS)) + return &data->share->dnscache; + if(data->multi) + return &data->multi->dnscache; + return NULL; +} + +static void dnscache_lock(struct Curl_easy *data, + struct Curl_dnscache *dnscache) +{ + if(data->share && dnscache == &data->share->dnscache) + Curl_share_lock(data, CURL_LOCK_DATA_DNS, CURL_LOCK_ACCESS_SINGLE); +} + +static void dnscache_unlock(struct Curl_easy *data, + struct Curl_dnscache *dnscache) +{ + if(data->share && dnscache == &data->share->dnscache) + Curl_share_unlock(data, CURL_LOCK_DATA_DNS); +} + +/* + * Library-wide function for pruning the DNS cache. This function takes and + * returns the appropriate locks. + */ +void Curl_dnscache_prune(struct Curl_easy *data) +{ + struct Curl_dnscache *dnscache = dnscache_get(data); + /* the timeout may be set -1 (forever) */ + timediff_t timeout_ms = data->set.dns_cache_timeout_ms; + + if(!dnscache || (timeout_ms == -1)) + /* NULL hostcache means we cannot do it */ + return; + + dnscache_lock(data, dnscache); + + do { + /* Remove outdated and unused entries from the hostcache */ + timediff_t oldest_ms = + dnscache_prune(&dnscache->entries, timeout_ms, *Curl_pgrs_now(data)); + + if(Curl_hash_count(&dnscache->entries) > MAX_DNS_CACHE_SIZE) + /* prune the ones over half this age */ + timeout_ms = oldest_ms / 2; + else + break; + + /* if the cache size is still too big, use the oldest age as new prune + limit */ + } while(timeout_ms); + + dnscache_unlock(data, dnscache); +} + +void Curl_dnscache_clear(struct Curl_easy *data) +{ + struct Curl_dnscache *dnscache = dnscache_get(data); + if(dnscache) { + dnscache_lock(data, dnscache); + Curl_hash_clean(&dnscache->entries); + dnscache_unlock(data, dnscache); + } +} + +/* lookup address, returns entry if found and not stale */ +static CURLcode fetch_addr(struct Curl_easy *data, + struct Curl_dnscache *dnscache, + uint8_t dns_queries, + const char *hostname, + uint16_t port, + struct Curl_dns_entry **pdns) +{ + struct Curl_dns_entry *dns = NULL; + char entry_id[MAX_HOSTCACHE_LEN]; + size_t entry_len; + CURLcode result = CURLE_OK; + + *pdns = NULL; + if(!dnscache) + return CURLE_OK; + + /* Create an entry id, based upon the hostname and port */ + entry_len = create_dnscache_id(hostname, 0, port, + entry_id, sizeof(entry_id)); + + /* See if it is already in our dns cache */ + dns = Curl_hash_pick(&dnscache->entries, entry_id, entry_len + 1); + + /* No entry found in cache, check if we might have a wildcard entry */ + if(!dns && data->state.wildcard_resolve) { + entry_len = create_dnscache_id("*", 1, port, entry_id, sizeof(entry_id)); + + /* See if it is already in our dns cache */ + dns = Curl_hash_pick(&dnscache->entries, entry_id, entry_len + 1); + } + + if(dns && (data->set.dns_cache_timeout_ms != -1)) { + /* See whether the returned entry is stale. Done before we release lock */ + struct dnscache_prune_data user; + + user.now = *Curl_pgrs_now(data); + user.max_age_ms = data->set.dns_cache_timeout_ms; + user.oldest_ms = 0; + + if(dnscache_entry_is_stale(&user, dns)) { + infof(data, "Hostname in DNS cache was stale, zapped"); + dns = NULL; /* the memory deallocation is being handled by the hash */ + Curl_hash_delete(&dnscache->entries, entry_id, entry_len + 1); + } + } + + if(dns) { + if((dns->dns_queries & dns_queries) != dns_queries) { + /* The entry does not cover all wanted DNS queries, a miss. */ + dns = NULL; + } + else if(!(dns->dns_responses & dns_queries)) { + /* The entry has no responses for the wanted DNS queries. */ + CURL_TRC_DNS(data, "cache entry does not have type=%s addresses", + Curl_resolv_query_str(dns_queries)); + dns = NULL; + result = CURLE_COULDNT_RESOLVE_HOST; + } + } + + if(dns && !dns->addr) { /* negative entry */ + dns = NULL; + result = CURLE_COULDNT_RESOLVE_HOST; + } + *pdns = dns; + return result; +} + +/* + * Curl_dnscache_get() fetches a 'Curl_dns_entry' already in the DNS cache. + * + * Curl_resolv() checks initially and multi_runsingle() checks each time + * it discovers the handle in the state WAITRESOLVE whether the hostname + * has already been resolved and the address has already been stored in + * the DNS cache. This short circuits waiting for a lot of pending + * lookups for the same hostname requested by different handles. + * + * Returns the Curl_dns_entry entry pointer or NULL if not in the cache. + * + * The returned data *MUST* be "released" with Curl_dns_entry_unlink() after + * use, or we will leak memory! + */ +CURLcode Curl_dnscache_get(struct Curl_easy *data, + uint8_t dns_queries, + const char *hostname, + uint16_t port, + struct Curl_dns_entry **pentry) +{ + struct Curl_dnscache *dnscache = dnscache_get(data); + struct Curl_dns_entry *dns = NULL; + CURLcode result = CURLE_OK; + + dnscache_lock(data, dnscache); + result = fetch_addr(data, dnscache, dns_queries, hostname, port, &dns); + if(!result && dns) + dns->refcount++; /* we pass out a reference */ + else if(result) { + DEBUGASSERT(!dns); + dns = NULL; + } + dnscache_unlock(data, dnscache); + + *pentry = dns; + return result; +} + +#ifndef CURL_DISABLE_SHUFFLE_DNS +/* + * Return # of addresses in a Curl_addrinfo struct + */ +static int num_addresses(const struct Curl_addrinfo *addr) +{ + int i = 0; + while(addr) { + addr = addr->ai_next; + i++; + } + return i; +} + +/* + * dns_shuffle_addr() shuffles the order of addresses in a 'Curl_addrinfo' + * struct by re-linking its linked list. + * + * The addr argument should be the address of a pointer to the head node of a + * `Curl_addrinfo` list and it will be modified to point to the new head after + * shuffling. + * + * Not declared static only to make it easy to use in a unit test! + * + * @unittest 1608 + */ +UNITTEST CURLcode dns_shuffle_addr(struct Curl_easy *data, + struct Curl_addrinfo **addr); +UNITTEST CURLcode dns_shuffle_addr(struct Curl_easy *data, + struct Curl_addrinfo **addr) +{ + CURLcode result = CURLE_OK; + const int num_addrs = num_addresses(*addr); + + if(num_addrs > 1) { + struct Curl_addrinfo **nodes; + CURL_TRC_DNS(data, "Shuffling %d addresses", num_addrs); + + nodes = curlx_malloc(num_addrs * sizeof(*nodes)); + if(nodes) { + int i; + unsigned int *rnd; + const size_t rnd_size = num_addrs * sizeof(*rnd); + + /* build a plain array of Curl_addrinfo pointers */ + nodes[0] = *addr; + for(i = 1; i < num_addrs; i++) { + nodes[i] = nodes[i - 1]->ai_next; + } + + rnd = curlx_malloc(rnd_size); + if(rnd) { + /* Fisher-Yates shuffle */ + if(Curl_rand(data, (unsigned char *)rnd, rnd_size) == CURLE_OK) { + struct Curl_addrinfo *swap_tmp; + for(i = num_addrs - 1; i > 0; i--) { + swap_tmp = nodes[rnd[i] % (unsigned int)(i + 1)]; + nodes[rnd[i] % (unsigned int)(i + 1)] = nodes[i]; + nodes[i] = swap_tmp; + } + + /* relink list in the new order */ + for(i = 1; i < num_addrs; i++) { + nodes[i - 1]->ai_next = nodes[i]; + } + + nodes[num_addrs - 1]->ai_next = NULL; + *addr = nodes[0]; + } + curlx_free(rnd); + } + else + result = CURLE_OUT_OF_MEMORY; + curlx_free(nodes); + } + else + result = CURLE_OUT_OF_MEMORY; + } + return result; +} +#endif + +static bool dnscache_ai_has_family(struct Curl_addrinfo *ai, + int ai_family) +{ + for(; ai; ai = ai->ai_next) { + if(ai->ai_family == ai_family) + return TRUE; + } + return FALSE; +} + +static struct Curl_dns_entry *dnscache_entry_create( + struct Curl_easy *data, + uint8_t dns_queries, + struct Curl_addrinfo **paddr1, + struct Curl_addrinfo **paddr2, + const char *hostname, + size_t hostlen, + uint16_t port, + bool permanent) +{ + struct Curl_dns_entry *dns = NULL; + + /* Create a new cache entry, struct already has the hostname NUL */ + dns = curlx_calloc(1, sizeof(struct Curl_dns_entry) + hostlen); + if(!dns) + goto out; + + dns->refcount = 1; /* the cache has the first reference */ + dns->dns_queries = dns_queries; + dns->port = port; + if(hostlen) + memcpy(dns->hostname, hostname, hostlen); + + if(permanent) { + dns->timestamp.tv_sec = 0; /* an entry that never goes stale */ + dns->timestamp.tv_usec = 0; /* an entry that never goes stale */ + } + else { + dns->timestamp = *Curl_pgrs_now(data); + } + + /* Take the given address lists into the entry */ + if(paddr1 && *paddr1) { + dns->addr = *paddr1; + *paddr1 = NULL; + } + if(paddr2 && *paddr2) { + struct Curl_addrinfo **phead = &dns->addr; + while(*phead) + phead = &(*phead)->ai_next; + *phead = *paddr2; + *paddr2 = NULL; + } + + if((dns_queries & CURL_DNSQ_A) && + dnscache_ai_has_family(dns->addr, PF_INET)) + dns->dns_responses |= CURL_DNSQ_A; + +#ifdef USE_IPV6 + if((dns_queries & CURL_DNSQ_AAAA) && + dnscache_ai_has_family(dns->addr, PF_INET6)) + dns->dns_responses |= CURL_DNSQ_AAAA; +#endif /* USE_IPV6 */ + +#ifndef CURL_DISABLE_SHUFFLE_DNS + /* shuffle addresses if requested */ + if(data->set.dns_shuffle_addresses && dns->addr) { + CURLcode result = dns_shuffle_addr(data, &dns->addr); + if(result) { + /* free without lock, we are the sole owner */ + dnscache_entry_free(dns); + dns = NULL; + goto out; + } + } +#else + (void)data; +#endif + +out: + if(paddr1 && *paddr1) { + Curl_freeaddrinfo(*paddr1); + *paddr1 = NULL; + } + if(paddr2 && *paddr2) { + Curl_freeaddrinfo(*paddr2); + *paddr2 = NULL; + } + return dns; +} + +struct Curl_dns_entry *Curl_dnscache_mk_entry(struct Curl_easy *data, + uint8_t dns_queries, + struct Curl_addrinfo **paddr, + const char *hostname, + uint16_t port) +{ + return dnscache_entry_create(data, dns_queries, paddr, NULL, hostname, + hostname ? strlen(hostname) : 0, + port, FALSE); +} + +struct Curl_dns_entry *Curl_dnscache_mk_entry2(struct Curl_easy *data, + uint8_t dns_queries, + struct Curl_addrinfo **paddr1, + struct Curl_addrinfo **paddr2, + const char *hostname, + uint16_t port) +{ + return dnscache_entry_create(data, dns_queries, paddr1, paddr2, hostname, + hostname ? strlen(hostname) : 0, + port, FALSE); +} + +#ifdef USE_HTTPSRR +void Curl_dns_entry_set_https_rr(struct Curl_dns_entry *dns, + struct Curl_https_rrinfo *hinfo) +{ + /* only do this when this is the only reference */ + DEBUGASSERT(dns->refcount == 1); + /* it should have been in the queries */ + DEBUGASSERT(dns->dns_queries & CURL_DNSQ_HTTPS); + if(dns->hinfo) { + Curl_httpsrr_cleanup(dns->hinfo); + curlx_free(dns->hinfo); + } + dns->hinfo = hinfo; + dns->dns_responses |= CURL_DNSQ_HTTPS; +} +#endif /* USE_HTTPSRR */ + +static struct Curl_dns_entry *dnscache_add_addr(struct Curl_easy *data, + struct Curl_dnscache *dnscache, + uint8_t dns_queries, + struct Curl_addrinfo **paddr, + const char *hostname, + size_t hlen, + uint16_t port, + bool permanent) +{ + char entry_id[MAX_HOSTCACHE_LEN]; + size_t entry_len; + struct Curl_dns_entry *dns; + struct Curl_dns_entry *dns2; + + dns = dnscache_entry_create(data, dns_queries, paddr, NULL, + hostname, hlen, port, permanent); + if(!dns) + return NULL; + + /* Create an entry id, based upon the hostname and port */ + entry_len = create_dnscache_id(hostname, hlen, port, + entry_id, sizeof(entry_id)); + + /* Store the resolved data in our DNS cache. */ + dns2 = Curl_hash_add(&dnscache->entries, entry_id, entry_len + 1, + (void *)dns); + if(!dns2) { + dnscache_entry_free(dns); + return NULL; + } + + dns = dns2; + dns->refcount++; /* mark entry as in-use */ + return dns; +} + +CURLcode Curl_dnscache_add(struct Curl_easy *data, + struct Curl_dns_entry *entry) +{ + struct Curl_dnscache *dnscache = dnscache_get(data); + char id[MAX_HOSTCACHE_LEN]; + size_t idlen; + + if(!dnscache) + return CURLE_FAILED_INIT; + /* Create an entry id, based upon the hostname and port */ + idlen = create_dnscache_id(entry->hostname, 0, entry->port, id, sizeof(id)); + + /* Store the resolved data in our DNS cache and up ref count */ + dnscache_lock(data, dnscache); + if(!Curl_hash_add(&dnscache->entries, id, idlen + 1, (void *)entry)) { + dnscache_unlock(data, dnscache); + return CURLE_OUT_OF_MEMORY; + } + entry->refcount++; + dnscache_unlock(data, dnscache); + return CURLE_OK; +} + +CURLcode Curl_dnscache_add_negative(struct Curl_easy *data, + uint8_t dns_queries, + const char *host, + uint16_t port) +{ + struct Curl_dnscache *dnscache = dnscache_get(data); + struct Curl_dns_entry *dns; + DEBUGASSERT(dnscache); + if(!dnscache) + return CURLE_FAILED_INIT; + + dnscache_lock(data, dnscache); + + /* put this new host in the cache */ + dns = dnscache_add_addr(data, dnscache, dns_queries, NULL, + host, strlen(host), port, FALSE); + if(dns) { + /* release the returned reference; the cache itself will keep the + * entry alive: */ + dns->refcount--; + dnscache_unlock(data, dnscache); + CURL_TRC_DNS(data, "cache negative name resolve for %s:%d type=%s", + host, port, Curl_resolv_query_str(dns_queries)); + return CURLE_OK; + } + dnscache_unlock(data, dnscache); + return CURLE_OUT_OF_MEMORY; +} + +/* + * Curl_dns_entry_unlink() releases a reference to the given cached DNS entry. + * When the reference count reaches 0, the entry is destroyed. It is important + * that only one unlink is made for each Curl_resolv() call. + * + * May be called with 'data' == NULL for global cache. + */ +void Curl_dns_entry_unlink(struct Curl_easy *data, + struct Curl_dns_entry **pdns) +{ + if(*pdns) { + struct Curl_dnscache *dnscache = dnscache_get(data); + struct Curl_dns_entry *dns = *pdns; + *pdns = NULL; + dnscache_lock(data, dnscache); + dns->refcount--; + if(dns->refcount == 0) + dnscache_entry_free(dns); + dnscache_unlock(data, dnscache); + } +} + +static void dnscache_entry_dtor(void *entry) +{ + struct Curl_dns_entry *dns = (struct Curl_dns_entry *)entry; + DEBUGASSERT(dns && (dns->refcount > 0)); + dns->refcount--; + if(dns->refcount == 0) + dnscache_entry_free(dns); +} + +/* + * Curl_dnscache_init() inits a new DNS cache. + */ +void Curl_dnscache_init(struct Curl_dnscache *dns, size_t size) +{ + Curl_hash_init(&dns->entries, size, Curl_hash_str, curlx_str_key_compare, + dnscache_entry_dtor); +} + +void Curl_dnscache_destroy(struct Curl_dnscache *dns) +{ + Curl_hash_destroy(&dns->entries); +} + +CURLcode Curl_loadhostpairs(struct Curl_easy *data) +{ + struct Curl_dnscache *dnscache = dnscache_get(data); + struct curl_slist *hostp; + + if(!dnscache) + return CURLE_FAILED_INIT; + + /* Default is no wildcard found */ + data->state.wildcard_resolve = FALSE; + + for(hostp = data->state.resolve; hostp; hostp = hostp->next) { + char entry_id[MAX_HOSTCACHE_LEN]; + const char *host = hostp->data; + struct Curl_str source; + if(!host) + continue; + if(*host == '-') { + curl_off_t num = 0; + size_t entry_len; + host++; + if(!curlx_str_single(&host, '[')) { + if(curlx_str_until(&host, &source, MAX_IPADR_LEN, ']') || + curlx_str_single(&host, ']') || + curlx_str_single(&host, ':')) + continue; + } + else { + if(curlx_str_until(&host, &source, 4096, ':') || + curlx_str_single(&host, ':')) { + continue; + } + } + + if(!curlx_str_number(&host, &num, 0xffff)) { + /* Create an entry id, based upon the hostname and port */ + entry_len = create_dnscache_id(curlx_str(&source), + curlx_strlen(&source), (uint16_t)num, + entry_id, sizeof(entry_id)); + dnscache_lock(data, dnscache); + /* delete entry, ignore if it did not exist */ + Curl_hash_delete(&dnscache->entries, entry_id, entry_len + 1); + dnscache_unlock(data, dnscache); + } + } + else { + struct Curl_dns_entry *dns; + struct Curl_addrinfo *head = NULL, *tail = NULL; + size_t entry_len; + char address[64]; + curl_off_t tmpofft = 0; + uint16_t port = 0; + bool permanent = TRUE; + bool error = TRUE; + VERBOSE(const char *addresses = NULL); + + if(*host == '+') { + host++; + permanent = FALSE; + } + if(!curlx_str_single(&host, '[')) { + if(curlx_str_until(&host, &source, MAX_IPADR_LEN, ']') || + curlx_str_single(&host, ']')) + continue; + } + else { + if(curlx_str_until(&host, &source, 4096, ':')) + continue; + } + if(curlx_str_single(&host, ':') || + curlx_str_number(&host, &tmpofft, 0xffff) || + curlx_str_single(&host, ':')) + goto err; + port = (uint16_t)tmpofft; + + VERBOSE(addresses = host); + + /* start the address section */ + while(*host) { + struct Curl_str target; + struct Curl_addrinfo *ai; + CURLcode result; + + if(!curlx_str_single(&host, '[')) { + if(curlx_str_until(&host, &target, MAX_IPADR_LEN, ']') || + curlx_str_single(&host, ']')) + goto err; + } + else { + if(curlx_str_until(&host, &target, 4096, ',')) { + if(curlx_str_single(&host, ',')) + goto err; + /* survive nothing but a comma */ + continue; + } + } +#ifndef USE_IPV6 + if(memchr(curlx_str(&target), ':', curlx_strlen(&target))) { + infof(data, "Ignoring resolve address '%.*s', missing IPv6 support.", + (int)curlx_strlen(&target), curlx_str(&target)); + if(curlx_str_single(&host, ',')) + goto err; + continue; + } +#endif + + if(curlx_strlen(&target) >= sizeof(address)) + goto err; + + memcpy(address, curlx_str(&target), curlx_strlen(&target)); + address[curlx_strlen(&target)] = '\0'; + + result = Curl_str2addr(address, port, &ai); + if(result) { + infof(data, "Resolve IP address '%s' found is illegal", address); + goto err; + } + + if(tail) { + tail->ai_next = ai; + tail = tail->ai_next; + } + else { + head = tail = ai; + } + if(curlx_str_single(&host, ',')) + break; + } + + if(!head) + goto err; + + error = FALSE; +err: + if(error) { + failf(data, "Could not parse CURLOPT_RESOLVE entry '%s'", hostp->data); + Curl_freeaddrinfo(head); + return CURLE_SETOPT_OPTION_SYNTAX; + } + + /* Create an entry id, based upon the hostname and port */ + entry_len = create_dnscache_id(curlx_str(&source), curlx_strlen(&source), + port, entry_id, sizeof(entry_id)); + + dnscache_lock(data, dnscache); + + /* See if it is already in our dns cache */ + dns = Curl_hash_pick(&dnscache->entries, entry_id, entry_len + 1); + + if(dns) { + infof(data, "RESOLVE %.*s:%u - old addresses discarded", + (int)curlx_strlen(&source), + curlx_str(&source), port); + /* delete old entry, there are two reasons for this + 1. old entry may have different addresses. + 2. even if entry with correct addresses is already in the cache, + but if it is close to expire, then by the time next http + request is made, it can get expired and pruned because old + entry is not necessarily marked as permanent. + 3. when adding a non-permanent entry, we want it to remove and + replace an existing permanent entry. + 4. when adding a non-permanent entry, we want it to get a "fresh" + timeout that starts _now_. */ + + Curl_hash_delete(&dnscache->entries, entry_id, entry_len + 1); + } + + /* put this new host in the cache, an override for ALL dns queries */ + dns = dnscache_add_addr(data, dnscache, CURL_DNSQ_ALL, + &head, curlx_str(&source), + curlx_strlen(&source), port, permanent); + if(dns) + /* release the returned reference; the cache itself will keep the + * entry alive: */ + dns->refcount--; + + dnscache_unlock(data, dnscache); + + if(!dns) + return CURLE_OUT_OF_MEMORY; + + infof(data, "Added %.*s:%u:%s to DNS cache%s", + (int)curlx_strlen(&source), curlx_str(&source), port, addresses, + permanent ? "" : " (non-permanent)"); + + /* Wildcard hostname */ + if(curlx_str_casecompare(&source, "*")) { + infof(data, "RESOLVE *:%u using wildcard", port); + data->state.wildcard_resolve = TRUE; + } + } + } + data->state.resolve = NULL; /* dealt with now */ + + return CURLE_OK; +} diff --git a/3rdparty/curl-8.21.0/lib/dnscache.h b/3rdparty/curl-8.21.0/lib/dnscache.h new file mode 100644 index 0000000000..9239977cf8 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/dnscache.h @@ -0,0 +1,138 @@ +#ifndef HEADER_CURL_DNSCACHE_H +#define HEADER_CURL_DNSCACHE_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "hash.h" +#include "curlx/timeval.h" + +struct addrinfo; +struct hostent; +struct Curl_easy; +struct connectdata; +struct easy_pollset; +struct Curl_https_rrinfo; +struct Curl_multi; + +struct Curl_dns_entry { + struct Curl_addrinfo *addr; +#ifdef USE_HTTPSRR + struct Curl_https_rrinfo *hinfo; +#endif + /* timestamp == 0 -- permanent CURLOPT_RESOLVE entry (does not time out) */ + struct curltime timestamp; + /* reference counter, entry is freed on reaching 0 */ + uint32_t refcount; + /* hostname port number that resolved to addr. */ + uint16_t port; + uint8_t dns_queries; /* CURL_DNSQ_* type of queries performed for this */ + uint8_t dns_responses; /* CURL_DNSQ_* type this entry has responses for */ + /* hostname that resolved to addr. may be NULL (Unix domain sockets). */ + char hostname[1]; +}; + +/* + * Create a `Curl_dns_entry` with a reference count of 1. + * Use `Curl_dns_entry_unlink()` to release your hold on it. + * + * The call takes ownership of `paddr`, even in case of failure, and always + * clears `*paddr`. It makes a copy of `hostname`. + * + * Returns entry or NULL on OOM. + */ +struct Curl_dns_entry *Curl_dnscache_mk_entry(struct Curl_easy *data, + uint8_t dns_queries, + struct Curl_addrinfo **paddr, + const char *hostname, + uint16_t port); + +struct Curl_dns_entry *Curl_dnscache_mk_entry2(struct Curl_easy *data, + uint8_t dns_queries, + struct Curl_addrinfo **paddr1, + struct Curl_addrinfo **paddr2, + const char *hostname, + uint16_t port); + +#ifdef USE_HTTPSRR +void Curl_dns_entry_set_https_rr(struct Curl_dns_entry *dns, + struct Curl_https_rrinfo *hinfo); +#endif /* USE_HTTPSRR */ + +/* unlink a dns entry, frees all resources if it was the last reference. + * Always clears `*pdns`` */ +void Curl_dns_entry_unlink(struct Curl_easy *data, + struct Curl_dns_entry **pdns); + +struct Curl_dnscache { + struct Curl_hash entries; +}; + +/* init a new dns cache */ +void Curl_dnscache_init(struct Curl_dnscache *dns, size_t size); + +void Curl_dnscache_destroy(struct Curl_dnscache *dns); + +/* prune old entries from the DNS cache */ +void Curl_dnscache_prune(struct Curl_easy *data); + +/* clear the DNS cache */ +void Curl_dnscache_clear(struct Curl_easy *data); + +/* + * Curl_dnscache_get() fetches a 'Curl_dns_entry' already in the DNS cache. + * + * Returns the Curl_dns_entry entry pointer or NULL if not in the cache. + * + * The returned data *MUST* be "released" with Curl_dns_entry_unlink() after + * use, or we will leak memory! + * Returns CURLE_OK or CURLE_COULDNT_RESOLVE_HOST when a negative + * entry was in the cache. + */ +CURLcode Curl_dnscache_get(struct Curl_easy *data, + uint8_t dns_queries, + const char *hostname, + uint16_t port, + struct Curl_dns_entry **pentry); + +/* + * Curl_dnscache_addr() adds `entry` to the cache, increasing its + * reference count on success. + */ +CURLcode Curl_dnscache_add(struct Curl_easy *data, + struct Curl_dns_entry *entry); + +/* Store a "negative" entry for host:port, e.g. remember that + * it could not be resolved. */ +CURLcode Curl_dnscache_add_negative(struct Curl_easy *data, + uint8_t dns_queries, + const char *host, + uint16_t port); + +/* + * Populate the cache with specified entries from CURLOPT_RESOLVE. + */ +CURLcode Curl_loadhostpairs(struct Curl_easy *data); + +#endif /* HEADER_CURL_DNSCACHE_H */ diff --git a/3rdparty/curl-8.21.0/lib/doh.c b/3rdparty/curl-8.21.0/lib/doh.c new file mode 100644 index 0000000000..8b643aa0b4 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/doh.c @@ -0,0 +1,1375 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifndef CURL_DISABLE_DOH + +#include "urldata.h" +#include "curl_addrinfo.h" +#include "doh.h" +#include "curl_trc.h" +#include "httpsrr.h" +#include "multiif.h" +#include "url.h" +#include "connect.h" +#include "curlx/strdup.h" +#include "curlx/dynbuf.h" +#include "escape.h" /* for Curl_hexencode() */ +#include "urlapi-int.h" + +#define DNS_CLASS_IN 0x01 + +static void doh_close(struct Curl_easy *data, + struct Curl_resolv_async *async); + +#ifdef CURLVERBOSE +static const char * const errors[] = { + "", + "Bad label", + "Out of range", + "Label loop", + "Too small", + "Out of memory", + "RDATA length", + "Malformat", + "Bad RCODE", + "Unexpected TYPE", + "Unexpected CLASS", + "No content", + "Bad ID", + "Name too long" +}; + +static const char *doh_strerror(DOHcode code) +{ + if((code >= DOH_OK) && (code <= DOH_DNS_NAME_TOO_LONG)) + return errors[code]; + return "bad error code"; +} + +#endif /* CURLVERBOSE */ + +/* @unittest 1655 + */ +UNITTEST DOHcode doh_req_encode(const char *host, + DNStype dnstype, + unsigned char *dnsp, /* buffer */ + size_t len, /* buffer size */ + size_t *olen); /* output length */ +UNITTEST DOHcode doh_req_encode(const char *host, + DNStype dnstype, + unsigned char *dnsp, /* buffer */ + size_t len, /* buffer size */ + size_t *olen) /* output length */ +{ + const size_t hostlen = strlen(host); + unsigned char *orig = dnsp; + const char *hostp = host; + + /* The expected output length is 16 bytes more than the length of + * the QNAME-encoding of the hostname. + * + * A valid DNS name may not contain a zero-length label, except at + * the end. For this reason, a name beginning with a dot, or + * containing a sequence of two or more consecutive dots, is invalid + * and cannot be encoded as a QNAME. + * + * If the hostname ends with a trailing dot, the corresponding + * QNAME-encoding is one byte longer than the hostname. If (as is + * also valid) the hostname is shortened by the omission of the + * trailing dot, then its QNAME-encoding will be two bytes longer + * than the hostname. + * + * Each [ label, dot ] pair is encoded as [ length, label ], + * preserving overall length. A final [ label ] without a dot is + * also encoded as [ length, label ], increasing overall length + * by one. The encoding is completed by appending a zero byte, + * representing the zero-length root label, again increasing + * the overall length by one. + */ + + size_t expected_len; + DEBUGASSERT(hostlen); + expected_len = 12 + 1 + hostlen + 4; + if(host[hostlen - 1] != '.') + expected_len++; + + if(expected_len > DOH_MAX_DNSREQ_SIZE) + return DOH_DNS_NAME_TOO_LONG; + + if(len < expected_len) + return DOH_TOO_SMALL_BUFFER; + + *dnsp++ = 0; /* 16-bit id */ + *dnsp++ = 0; + *dnsp++ = 0x01; /* |QR| Opcode |AA|TC|RD| Set the RD bit */ + *dnsp++ = '\0'; /* |RA| Z | RCODE | */ + *dnsp++ = '\0'; + *dnsp++ = 1; /* QDCOUNT (number of entries in the question section) */ + *dnsp++ = '\0'; + *dnsp++ = '\0'; /* ANCOUNT */ + *dnsp++ = '\0'; + *dnsp++ = '\0'; /* NSCOUNT */ + *dnsp++ = '\0'; + *dnsp++ = '\0'; /* ARCOUNT */ + + /* encode each label and store it in the QNAME */ + while(*hostp) { + size_t labellen; + const char *dot = strchr(hostp, '.'); + if(dot) + labellen = dot - hostp; + else + labellen = strlen(hostp); + if((labellen > 63) || (!labellen)) { + /* label is too long or too short, error out */ + *olen = 0; + return DOH_DNS_BAD_LABEL; + } + /* label is non-empty, process it */ + *dnsp++ = (unsigned char)labellen; + memcpy(dnsp, hostp, labellen); + dnsp += labellen; + hostp += labellen; + /* advance past dot, but only if there is one */ + if(dot) + hostp++; + } /* next label */ + + *dnsp++ = 0; /* append zero-length label for root */ + + /* There are assigned TYPE codes beyond 255: use range [1..65535] */ + *dnsp++ = (unsigned char)(255 & (dnstype >> 8)); /* upper 8-bit TYPE */ + *dnsp++ = (unsigned char)(255 & dnstype); /* lower 8-bit TYPE */ + + *dnsp++ = '\0'; /* upper 8-bit CLASS */ + *dnsp++ = DNS_CLASS_IN; /* IN - "the Internet" */ + + *olen = dnsp - orig; + + /* verify that our estimation of length is valid, since + * this has led to buffer overflows in this function */ + DEBUGASSERT(*olen == expected_len); + return DOH_OK; +} + +static size_t doh_probe_write_cb(char *contents, size_t size, size_t nmemb, + void *userp) +{ + size_t realsize = size * nmemb; + struct Curl_easy *data = userp; + struct doh_request *doh_req = Curl_meta_get(data, CURL_EZM_DOH_PROBE); + if(!doh_req) + return CURL_WRITEFUNC_ERROR; + + if(curlx_dyn_addn(&doh_req->resp_body, contents, realsize)) + return 0; + + return realsize; +} + +#if defined(USE_HTTPSRR) && defined(DEBUGBUILD) && defined(CURLVERBOSE) + +/* doh_print_buf truncates if the hex string will be more than this */ +#define LOCAL_PB_HEXMAX 400 + +static void doh_print_buf(struct Curl_easy *data, + const char *prefix, + unsigned char *buf, size_t len) +{ + unsigned char hexstr[LOCAL_PB_HEXMAX]; + size_t hlen = LOCAL_PB_HEXMAX; + bool truncated = FALSE; + + if(len > (LOCAL_PB_HEXMAX / 2)) + truncated = TRUE; + Curl_hexencode(buf, len, hexstr, hlen); + if(!truncated) + infof(data, "%s: len=%d, val=%s", prefix, (int)len, hexstr); + else + infof(data, "%s: len=%d (truncated)val=%s", prefix, (int)len, hexstr); +} +#endif + +/* called from multi when a sub transfer, e.g. doh probe, is done. + * This looks up the probe response at its meta CURL_EZM_DOH_PROBE + * and copies the response body over to the struct at the master's + * meta at CURL_EZM_DOH_MASTER. */ +static void doh_probe_done(struct Curl_easy *data, + struct Curl_easy *doh, CURLcode result) +{ + struct Curl_resolv_async *async = NULL; + struct doh_probes *dohp = NULL; + struct doh_request *doh_req = NULL; + int i; + + doh_req = Curl_meta_get(doh, CURL_EZM_DOH_PROBE); + if(!doh_req) { + DEBUGASSERT(0); + return; + } + + async = Curl_async_get(data, doh_req->resolv_id); + if(!async) { + CURL_TRC_DNS(data, "[%u] ignoring outdated DoH response", + doh_req->resolv_id); + return; + } + dohp = async->doh; + + for(i = 0; i < DOH_SLOT_COUNT; ++i) { + if(dohp->probe_resp[i].probe_mid == doh->mid) + break; + } + /* We really should have found the slot where to store the response */ + if(i >= DOH_SLOT_COUNT) { + DEBUGASSERT(0); + failf(data, "DoH: unknown sub request done"); + return; + } + + dohp->pending--; + infof(doh, "a DoH request is completed, %u to go", dohp->pending); + dohp->probe_resp[i].result = result; + /* We expect either the meta data still to exist or the sub request + * to have already failed. */ + if(!result) { + dohp->probe_resp[i].dnstype = doh_req->dnstype; + result = curlx_dyn_addn(&dohp->probe_resp[i].body, + curlx_dyn_ptr(&doh_req->resp_body), + curlx_dyn_len(&doh_req->resp_body)); + } + Curl_meta_remove(doh, CURL_EZM_DOH_PROBE); + + if(result) + infof(doh, "DoH request %s", curl_easy_strerror(result)); + + if(!dohp->pending) { + /* DoH completed, run the transfer picking up the results */ + Curl_multi_mark_dirty(data); + } +} + +static void doh_probe_dtor(void *key, size_t klen, void *e) +{ + (void)key; + (void)klen; + if(e) { + struct doh_request *doh_req = e; + curl_slist_free_all(doh_req->req_hds); + curlx_dyn_free(&doh_req->resp_body); + curlx_free(e); + } +} + +#define ERROR_CHECK_SETOPT(x, y) \ + do { \ + result = curl_easy_setopt((CURL *)doh, x, y); \ + if(result && \ + result != CURLE_NOT_BUILT_IN && \ + result != CURLE_UNKNOWN_OPTION) \ + goto error; \ + } while(0) + +static CURLcode doh_probe_run(struct Curl_easy *data, + DNStype dnstype, + const char *host, + const char *url, CURLM *multi, + uint32_t resolv_id, + uint32_t *pmid) +{ + struct Curl_easy *doh = NULL; + CURLcode result = CURLE_OK; + timediff_t timeout_ms; + struct doh_request *doh_req; + DOHcode d; + + *pmid = UINT32_MAX; + + doh_req = curlx_calloc(1, sizeof(*doh_req)); + if(!doh_req) + return CURLE_OUT_OF_MEMORY; + doh_req->resolv_id = resolv_id; + doh_req->dnstype = dnstype; + curlx_dyn_init(&doh_req->resp_body, DYN_DOH_RESPONSE); + + d = doh_req_encode(host, dnstype, doh_req->req_body, + sizeof(doh_req->req_body), + &doh_req->req_body_len); + if(d) { + failf(data, "Failed to encode DoH packet [%d]", (int)d); + result = CURLE_OUT_OF_MEMORY; + goto error; + } + + timeout_ms = Curl_timeleft_ms(data); + if(timeout_ms < 0) { + result = CURLE_OPERATION_TIMEDOUT; + goto error; + } + + doh_req->req_hds = + curl_slist_append(NULL, "Content-Type: application/dns-message"); + if(!doh_req->req_hds) { + result = CURLE_OUT_OF_MEMORY; + goto error; + } + + /* Curl_open() is the internal version of curl_easy_init() */ + result = Curl_open(&doh); + if(result) + goto error; + + /* pass in the struct pointer via a local variable to please coverity and + the gcc typecheck helpers */ + VERBOSE(doh->state.feat = &Curl_trc_feat_dns); + ERROR_CHECK_SETOPT(CURLOPT_URL, url); + ERROR_CHECK_SETOPT(CURLOPT_DEFAULT_PROTOCOL, "https"); + ERROR_CHECK_SETOPT(CURLOPT_WRITEFUNCTION, doh_probe_write_cb); + ERROR_CHECK_SETOPT(CURLOPT_WRITEDATA, doh); + ERROR_CHECK_SETOPT(CURLOPT_POSTFIELDS, doh_req->req_body); + ERROR_CHECK_SETOPT(CURLOPT_POSTFIELDSIZE, (long)doh_req->req_body_len); + ERROR_CHECK_SETOPT(CURLOPT_HTTPHEADER, doh_req->req_hds); +#ifdef USE_HTTP2 + ERROR_CHECK_SETOPT(CURLOPT_HTTP_VERSION, CURL_HTTP_VERSION_2TLS); + ERROR_CHECK_SETOPT(CURLOPT_PIPEWAIT, 1L); +#endif +#ifndef DEBUGBUILD + /* enforce HTTPS if not debug */ + ERROR_CHECK_SETOPT(CURLOPT_PROTOCOLS, CURLPROTO_HTTPS); +#else + /* in debug mode, also allow http */ + ERROR_CHECK_SETOPT(CURLOPT_PROTOCOLS, CURLPROTO_HTTP | CURLPROTO_HTTPS); +#endif + ERROR_CHECK_SETOPT(CURLOPT_TIMEOUT_MS, (long)timeout_ms); + ERROR_CHECK_SETOPT(CURLOPT_SHARE, (CURLSH *)data->share); + if(data->set.err && data->set.err != stderr) + ERROR_CHECK_SETOPT(CURLOPT_STDERR, data->set.err); + if(Curl_trc_ft_is_verbose(data, &Curl_trc_feat_dns)) + ERROR_CHECK_SETOPT(CURLOPT_VERBOSE, 1L); + if(data->set.no_signal) + ERROR_CHECK_SETOPT(CURLOPT_NOSIGNAL, 1L); + + ERROR_CHECK_SETOPT(CURLOPT_SSL_VERIFYHOST, + data->set.doh_verifyhost ? 2L : 0L); + ERROR_CHECK_SETOPT(CURLOPT_SSL_VERIFYPEER, + data->set.doh_verifypeer ? 1L : 0L); + ERROR_CHECK_SETOPT(CURLOPT_SSL_VERIFYSTATUS, + data->set.doh_verifystatus ? 1L : 0L); + + /* Inherit *some* SSL options from the user's transfer. This is a + best-guess as to which options are needed for compatibility. #3661 + + Note DoH does not inherit the user's proxy server so proxy SSL settings + have no effect and are not inherited. If that changes then two new + options should be added to check doh proxy insecure separately, + CURLOPT_DOH_PROXY_SSL_VERIFYHOST and CURLOPT_DOH_PROXY_SSL_VERIFYPEER. + */ + doh->set.ssl.custom_cafile = data->set.ssl.custom_cafile; + doh->set.ssl.custom_capath = data->set.ssl.custom_capath; + doh->set.ssl.custom_cablob = data->set.ssl.custom_cablob; + if(data->set.str[STRING_SSL_CAFILE]) { + ERROR_CHECK_SETOPT(CURLOPT_CAINFO, data->set.str[STRING_SSL_CAFILE]); + } + if(data->set.blobs[BLOB_CAINFO]) { + ERROR_CHECK_SETOPT(CURLOPT_CAINFO_BLOB, data->set.blobs[BLOB_CAINFO]); + } + if(data->set.str[STRING_SSL_CAPATH]) { + ERROR_CHECK_SETOPT(CURLOPT_CAPATH, data->set.str[STRING_SSL_CAPATH]); + } + if(data->set.str[STRING_SSL_CRLFILE]) { + ERROR_CHECK_SETOPT(CURLOPT_CRLFILE, data->set.str[STRING_SSL_CRLFILE]); + } + if(data->set.ssl.certinfo) + ERROR_CHECK_SETOPT(CURLOPT_CERTINFO, 1L); + if(data->set.ssl.fsslctx) + ERROR_CHECK_SETOPT(CURLOPT_SSL_CTX_FUNCTION, data->set.ssl.fsslctx); + if(data->set.ssl.fsslctxp) + ERROR_CHECK_SETOPT(CURLOPT_SSL_CTX_DATA, data->set.ssl.fsslctxp); + if(data->set.fdebug) + ERROR_CHECK_SETOPT(CURLOPT_DEBUGFUNCTION, data->set.fdebug); + if(data->set.debugdata) + ERROR_CHECK_SETOPT(CURLOPT_DEBUGDATA, data->set.debugdata); + if(data->set.str[STRING_SSL_EC_CURVES]) { + ERROR_CHECK_SETOPT(CURLOPT_SSL_EC_CURVES, + data->set.str[STRING_SSL_EC_CURVES]); + } + + (void)curl_easy_setopt(doh, CURLOPT_SSL_OPTIONS, + ((long)data->set.ssl.primary.ssl_options & + ~CURLSSLOPT_AUTO_CLIENT_CERT)); + + doh->state.internal = TRUE; + doh->master_mid = data->mid; /* master transfer of this one */ + + result = Curl_meta_set(doh, CURL_EZM_DOH_PROBE, doh_req, doh_probe_dtor); + doh_req = NULL; /* call took ownership */ + if(result) + goto error; + + /* DoH handles must not inherit private_data. The handles may be passed to + the user via callbacks and the user will be able to identify them as + internal handles because private data is not set. The user can then set + private_data via CURLOPT_PRIVATE if they so choose. */ + DEBUGASSERT(!doh->set.private_data); + + if(curl_multi_add_handle(multi, doh)) + goto error; + + *pmid = doh->mid; + return CURLE_OK; + +error: + Curl_close(&doh); + if(doh_req) + doh_probe_dtor(NULL, 0, doh_req); + return result; +} + +/* + * Curl_doh() starts a name resolve using DoH. It resolves a name and returns + * a 'Curl_addrinfo *' with the address information. + */ + +CURLcode Curl_doh(struct Curl_easy *data, + struct Curl_resolv_async *async) +{ + CURLcode result = CURLE_OK; + struct doh_probes *dohp = NULL; + size_t i; + + DEBUGASSERT(!async->doh); + DEBUGASSERT(async->hostname[0]); + if(async->doh) { + DEBUGASSERT(0); /* should not happen */ + Curl_doh_cleanup(data, async); + } + + /* start clean, consider allocating this struct on demand */ + async->doh = dohp = curlx_calloc(1, sizeof(struct doh_probes)); + if(!dohp) + return CURLE_OUT_OF_MEMORY; + + for(i = 0; i < DOH_SLOT_COUNT; ++i) { + dohp->probe_resp[i].probe_mid = UINT32_MAX; + curlx_dyn_init(&dohp->probe_resp[i].body, DYN_DOH_RESPONSE); + } + + dohp->host = async->hostname; + dohp->port = async->port; + /* We are making sub easy handles and want to be called back when + * one is done. */ + data->sub_xfer_done = doh_probe_done; + + /* create IPv4 DoH request */ + if(async->dns_queries & CURL_DNSQ_A) { + result = doh_probe_run(data, CURL_DNS_TYPE_A, + async->hostname, data->set.str[STRING_DOH], + data->multi, async->id, + &dohp->probe_resp[DOH_SLOT_IPV4].probe_mid); + if(result) + goto error; + dohp->pending++; + } + +#ifdef USE_IPV6 + if(async->dns_queries & CURL_DNSQ_AAAA) { + /* create IPv6 DoH request */ + result = doh_probe_run(data, CURL_DNS_TYPE_AAAA, + async->hostname, data->set.str[STRING_DOH], + data->multi, async->id, + &dohp->probe_resp[DOH_SLOT_IPV6].probe_mid); + if(result) + goto error; + dohp->pending++; + } +#endif + +#ifdef USE_HTTPSRR + if(async->dns_queries & CURL_DNSQ_HTTPS) { + char *qname = NULL; + if(async->port != PORT_HTTPS) { + qname = curl_maprintf("_%d._https.%s", async->port, async->hostname); + if(!qname) + goto error; + } + result = doh_probe_run(data, CURL_DNS_TYPE_HTTPS, + qname ? qname : async->hostname, + data->set.str[STRING_DOH], data->multi, + async->id, + &dohp->probe_resp[DOH_SLOT_HTTPS_RR].probe_mid); + curlx_free(qname); + if(result) + goto error; + dohp->pending++; + } +#endif + return CURLE_OK; + +error: + Curl_doh_cleanup(data, async); + return result; +} + +static DOHcode doh_skipqname(const unsigned char *doh, size_t dohlen, + unsigned int *indexp) +{ + unsigned char length; + do { + if(dohlen < (*indexp + 1)) + return DOH_DNS_OUT_OF_RANGE; + length = doh[*indexp]; + if((length & 0xc0) == 0xc0) { + /* name pointer, advance over it and be done */ + if(dohlen < (*indexp + 2)) + return DOH_DNS_OUT_OF_RANGE; + *indexp += 2; + break; + } + if(length & 0xc0) + return DOH_DNS_BAD_LABEL; + if(dohlen < (*indexp + 1 + length)) + return DOH_DNS_OUT_OF_RANGE; + *indexp += (unsigned int)(1 + length); + } while(length); + return DOH_OK; +} + +static unsigned short doh_get16bit(const unsigned char *doh, + unsigned int index) +{ + return (unsigned short)((doh[index] << 8) | doh[index + 1]); +} + +static unsigned int doh_get32bit(const unsigned char *doh, unsigned int index) +{ + /* make clang and gcc optimize this to bswap by incrementing + the pointer first. */ + doh += index; + + /* avoid undefined behavior by casting to unsigned before shifting + 24 bits, possibly into the sign bit. codegen is same, but + ub sanitizer will not be upset */ + return ((unsigned)doh[0] << 24) | ((unsigned)doh[1] << 16) | + ((unsigned)doh[2] << 8) | doh[3]; +} + +static void doh_store_a(const unsigned char *doh, int index, + struct dohentry *d) +{ + /* silently ignore addresses over the limit */ + if(d->numaddr < DOH_MAX_ADDR) { + struct dohaddr *a = &d->addr[d->numaddr]; + a->type = CURL_DNS_TYPE_A; + memcpy(&a->ip.v4, &doh[index], 4); + d->numaddr++; + } +} + +static void doh_store_aaaa(const unsigned char *doh, int index, + struct dohentry *d) +{ + /* silently ignore addresses over the limit */ + if(d->numaddr < DOH_MAX_ADDR) { + struct dohaddr *a = &d->addr[d->numaddr]; + a->type = CURL_DNS_TYPE_AAAA; + memcpy(&a->ip.v6, &doh[index], 16); + d->numaddr++; + } +} + +#ifdef USE_HTTPSRR +static DOHcode doh_store_https(const unsigned char *doh, int index, + struct dohentry *d, uint16_t len) +{ + /* silently ignore RRs over the limit */ + if(d->numhttps_rrs < DOH_MAX_HTTPS) { + struct dohhttps_rr *h = &d->https_rrs[d->numhttps_rrs]; + h->val = curlx_memdup(&doh[index], len); + if(!h->val) + return DOH_OUT_OF_MEM; + h->len = len; + d->numhttps_rrs++; + } + return DOH_OK; +} +#endif + +static DOHcode doh_store_cname(const unsigned char *doh, size_t dohlen, + unsigned int index, struct dohentry *d) +{ + struct dynbuf *c; + unsigned int loop = 128; /* a valid DNS name can never loop this much */ + unsigned char length; + + if(d->numcname == DOH_MAX_CNAME) + return DOH_OK; /* skip! */ + + c = &d->cname[d->numcname++]; + do { + if(index >= dohlen) + return DOH_DNS_OUT_OF_RANGE; + length = doh[index]; + if((length & 0xc0) == 0xc0) { + int newpos; + /* name pointer, get the new offset (14 bits) */ + if((index + 1) >= dohlen) + return DOH_DNS_OUT_OF_RANGE; + + /* move to the new index */ + newpos = (length & 0x3f) << 8 | doh[index + 1]; + index = (unsigned int)newpos; + continue; + } + else if(length & 0xc0) + return DOH_DNS_BAD_LABEL; /* bad input */ + else + index++; + + if(length) { + if(curlx_dyn_len(c)) { + if(curlx_dyn_addn(c, STRCONST("."))) + return DOH_OUT_OF_MEM; + } + if((index + length) > dohlen) + return DOH_DNS_BAD_LABEL; + + if(curlx_dyn_addn(c, &doh[index], length)) + return DOH_OUT_OF_MEM; + index += length; + } + } while(length && --loop); + + if(!loop) + return DOH_DNS_LABEL_LOOP; + return DOH_OK; +} + +static DOHcode doh_rdata(const unsigned char *doh, + size_t dohlen, + unsigned short rdlength, + unsigned short type, + int index, + struct dohentry *d) +{ + /* RDATA + - A (TYPE 1): 4 bytes + - AAAA (TYPE 28): 16 bytes + - NS (TYPE 2): N bytes + - HTTPS (TYPE 65): N bytes */ + DOHcode rc; + + switch(type) { + case CURL_DNS_TYPE_A: + if(rdlength != 4) + return DOH_DNS_RDATA_LEN; + doh_store_a(doh, index, d); + break; + case CURL_DNS_TYPE_AAAA: + if(rdlength != 16) + return DOH_DNS_RDATA_LEN; + doh_store_aaaa(doh, index, d); + break; +#ifdef USE_HTTPSRR + case CURL_DNS_TYPE_HTTPS: + rc = doh_store_https(doh, index, d, rdlength); + if(rc) + return rc; + break; +#endif + case CURL_DNS_TYPE_CNAME: + rc = doh_store_cname(doh, dohlen, (unsigned int)index, d); + if(rc) + return rc; + break; + case CURL_DNS_TYPE_DNAME: + /* explicit for clarity; skip; rely on synthesized CNAME */ + break; + default: + /* unsupported type, skip it */ + break; + } + return DOH_OK; +} + +/* @unittest 1655 */ +UNITTEST void de_init(struct dohentry *de); +UNITTEST void de_init(struct dohentry *de) +{ + int i; + memset(de, 0, sizeof(*de)); + de->ttl = INT_MAX; + for(i = 0; i < DOH_MAX_CNAME; i++) + curlx_dyn_init(&de->cname[i], DYN_DOH_CNAME); +} + +/* TTL value cap */ +#define MAX_DNS_TTL 86400U /* 24 hours */ +/* @unittest 1650 */ +UNITTEST DOHcode doh_resp_decode(const unsigned char *doh, + size_t dohlen, + DNStype dnstype, + struct dohentry *d); +UNITTEST DOHcode doh_resp_decode(const unsigned char *doh, + size_t dohlen, + DNStype dnstype, + struct dohentry *d) +{ + unsigned char rcode; + unsigned short qdcount; + unsigned short ancount; + unsigned short type = 0; + unsigned short rdlength; + unsigned short nscount; + unsigned short arcount; + unsigned int index = 12; + DOHcode rc; + + if(dohlen < 12) + return DOH_TOO_SMALL_BUFFER; /* too small */ + if(!doh || doh[0] || doh[1]) + return DOH_DNS_BAD_ID; /* bad ID */ + rcode = doh[3] & 0x0f; + if(rcode) + return DOH_DNS_BAD_RCODE; /* bad rcode */ + + qdcount = doh_get16bit(doh, 4); + while(qdcount) { + rc = doh_skipqname(doh, dohlen, &index); + if(rc) + return rc; /* bad qname */ + if(dohlen < (index + 4)) + return DOH_DNS_OUT_OF_RANGE; + index += 4; /* skip question's type and class */ + qdcount--; + } + + ancount = doh_get16bit(doh, 6); + while(ancount) { + unsigned short dnsclass; + unsigned int ttl; + + rc = doh_skipqname(doh, dohlen, &index); + if(rc) + return rc; /* bad qname */ + + if(dohlen < (index + 2)) + return DOH_DNS_OUT_OF_RANGE; + + type = doh_get16bit(doh, index); + if((type != CURL_DNS_TYPE_CNAME) && /* may be synthesized from DNAME */ + (type != CURL_DNS_TYPE_DNAME) && /* if present, accept and ignore */ + (type != dnstype)) + /* Not the same type as was asked for nor CNAME nor DNAME */ + return DOH_DNS_UNEXPECTED_TYPE; + index += 2; + + if(dohlen < (index + 2)) + return DOH_DNS_OUT_OF_RANGE; + dnsclass = doh_get16bit(doh, index); + if(DNS_CLASS_IN != dnsclass) + return DOH_DNS_UNEXPECTED_CLASS; /* unsupported */ + index += 2; + + if(dohlen < (index + 4)) + return DOH_DNS_OUT_OF_RANGE; + + ttl = doh_get32bit(doh, index); + if(ttl > MAX_DNS_TTL) + ttl = MAX_DNS_TTL; + if(ttl < d->ttl) + d->ttl = ttl; + index += 4; + + if(dohlen < (index + 2)) + return DOH_DNS_OUT_OF_RANGE; + + rdlength = doh_get16bit(doh, index); + index += 2; + if(dohlen < (index + rdlength)) + return DOH_DNS_OUT_OF_RANGE; + + rc = doh_rdata(doh, dohlen, rdlength, type, (int)index, d); + if(rc) + return rc; /* bad doh_rdata */ + index += rdlength; + ancount--; + } + + nscount = doh_get16bit(doh, 8); + while(nscount) { + rc = doh_skipqname(doh, dohlen, &index); + if(rc) + return rc; /* bad qname */ + + if(dohlen < (index + 8)) + return DOH_DNS_OUT_OF_RANGE; + + index += 2 + 2 + 4; /* type, dnsclass and ttl */ + + if(dohlen < (index + 2)) + return DOH_DNS_OUT_OF_RANGE; + + rdlength = doh_get16bit(doh, index); + index += 2; + if(dohlen < (index + rdlength)) + return DOH_DNS_OUT_OF_RANGE; + index += rdlength; + nscount--; + } + + arcount = doh_get16bit(doh, 10); + while(arcount) { + rc = doh_skipqname(doh, dohlen, &index); + if(rc) + return rc; /* bad qname */ + + if(dohlen < (index + 8)) + return DOH_DNS_OUT_OF_RANGE; + + index += 2 + 2 + 4; /* type, dnsclass and ttl */ + + if(dohlen < (index + 2)) + return DOH_DNS_OUT_OF_RANGE; + + rdlength = doh_get16bit(doh, index); + index += 2; + if(dohlen < (index + rdlength)) + return DOH_DNS_OUT_OF_RANGE; + index += rdlength; + arcount--; + } + + if(index != dohlen) + return DOH_DNS_MALFORMAT; /* something is wrong */ + +#ifdef USE_HTTPSRR + if((type != CURL_DNS_TYPE_NS) && !d->numcname && !d->numaddr && + !d->numhttps_rrs) +#else + if((type != CURL_DNS_TYPE_NS) && !d->numcname && !d->numaddr) +#endif + /* nothing stored! */ + return DOH_NO_CONTENT; + + return DOH_OK; /* ok */ +} + +#ifdef CURLVERBOSE +static void doh_show(struct Curl_easy *data, + const struct dohentry *d) +{ + int i; + infof(data, "[DoH] TTL: %u seconds", d->ttl); + for(i = 0; i < d->numaddr; i++) { + const struct dohaddr *a = &d->addr[i]; + if(a->type == CURL_DNS_TYPE_A) { + infof(data, "[DoH] A: %u.%u.%u.%u", + a->ip.v4[0], a->ip.v4[1], + a->ip.v4[2], a->ip.v4[3]); + } + else if(a->type == CURL_DNS_TYPE_AAAA) { + int j; + char buffer[128] = "[DoH] AAAA: "; + size_t len = strlen(buffer); + char *ptr = &buffer[len]; + len = sizeof(buffer) - len; + for(j = 0; j < 16; j += 2) { + size_t l; + curl_msnprintf(ptr, len, "%s%02x%02x", j ? ":" : "", + d->addr[i].ip.v6[j], + d->addr[i].ip.v6[j + 1]); + l = strlen(ptr); + len -= l; + ptr += l; + } + infof(data, "%s", buffer); + } + } +#ifdef USE_HTTPSRR + for(i = 0; i < d->numhttps_rrs; i++) { +#if defined(DEBUGBUILD) && defined(CURLVERBOSE) + doh_print_buf(data, "DoH HTTPS", d->https_rrs[i].val, d->https_rrs[i].len); +#else + infof(data, "DoH HTTPS RR: length %d", d->https_rrs[i].len); +#endif + } +#endif /* USE_HTTPSRR */ + for(i = 0; i < d->numcname; i++) { + infof(data, "CNAME: %s", curlx_dyn_ptr(&d->cname[i])); + } +} +#else +#define doh_show(x, y) +#endif + +/* + * doh2ai() + * + * This function returns a pointer to the first element of a newly allocated + * Curl_addrinfo struct linked list filled with the data from a set of DoH + * lookups. Curl_addrinfo is meant to work like the addrinfo struct does for + * an IPv6 stack, but usable also for IPv4, all hosts and environments. + * + * The memory allocated by this function *MUST* be free'd later on calling + * Curl_freeaddrinfo(). For each successful call to this function there + * must be an associated call later to Curl_freeaddrinfo(). + */ + +static CURLcode doh2ai(const struct dohentry *de, const char *hostname, + int port, struct Curl_addrinfo **aip) +{ + struct Curl_addrinfo *ai; + struct Curl_addrinfo *prevai = NULL; + struct Curl_addrinfo *firstai = NULL; + struct sockaddr_in *addr; +#ifdef USE_IPV6 + struct sockaddr_in6 *addr6; +#endif + CURLcode result = CURLE_OK; + int i; + size_t hostlen = strlen(hostname) + 1; /* include null-terminator */ + + DEBUGASSERT(de); + + if(!de->numaddr) + return CURLE_COULDNT_RESOLVE_HOST; + + for(i = 0; i < de->numaddr; i++) { + size_t ss_size; + CURL_SA_FAMILY_T addrtype; + if(de->addr[i].type == CURL_DNS_TYPE_AAAA) { +#ifndef USE_IPV6 + /* we cannot handle IPv6 addresses */ + continue; +#else + ss_size = sizeof(struct sockaddr_in6); + addrtype = AF_INET6; +#endif + } + else { + ss_size = sizeof(struct sockaddr_in); + addrtype = AF_INET; + } + + ai = curlx_calloc(1, sizeof(struct Curl_addrinfo) + ss_size + hostlen); + if(!ai) { + result = CURLE_OUT_OF_MEMORY; + break; + } + ai->ai_addr = (void *)((char *)ai + sizeof(struct Curl_addrinfo)); + ai->ai_canonname = (void *)((char *)ai->ai_addr + ss_size); + memcpy(ai->ai_canonname, hostname, hostlen); + + if(!firstai) + /* store the pointer we want to return from this function */ + firstai = ai; + + if(prevai) + /* make the previous entry point to this */ + prevai->ai_next = ai; + + ai->ai_family = addrtype; + + /* we return all names as STREAM, so when using this address for TFTP + the type must be ignored and conn->socktype be used instead! */ + ai->ai_socktype = SOCK_STREAM; + + ai->ai_addrlen = (curl_socklen_t)ss_size; + + /* leave the rest of the struct filled with zero */ + + switch(ai->ai_family) { + case AF_INET: + addr = (void *)ai->ai_addr; /* storage area for this info */ + DEBUGASSERT(sizeof(struct in_addr) == sizeof(de->addr[i].ip.v4)); + memcpy(&addr->sin_addr, &de->addr[i].ip.v4, sizeof(struct in_addr)); + addr->sin_family = addrtype; + addr->sin_port = htons((unsigned short)port); + break; + +#ifdef USE_IPV6 + case AF_INET6: + addr6 = (void *)ai->ai_addr; /* storage area for this info */ + DEBUGASSERT(sizeof(struct in6_addr) == sizeof(de->addr[i].ip.v6)); + memcpy(&addr6->sin6_addr, &de->addr[i].ip.v6, sizeof(struct in6_addr)); + addr6->sin6_family = addrtype; + addr6->sin6_port = htons((unsigned short)port); + break; +#endif + } + + prevai = ai; + } + + if(result) { + Curl_freeaddrinfo(firstai); + firstai = NULL; + } + *aip = firstai; + + return result; +} + +#ifdef CURLVERBOSE +static const char *doh_type2name(DNStype dnstype) +{ + switch(dnstype) { + case CURL_DNS_TYPE_A: + return "A"; + case CURL_DNS_TYPE_AAAA: + return "AAAA"; +#ifdef USE_HTTPSRR + case CURL_DNS_TYPE_HTTPS: + return "HTTPS"; +#endif + default: + return "unknown"; + } +} +#endif + +/* @unittest 1655 */ +UNITTEST void de_cleanup(struct dohentry *d); +UNITTEST void de_cleanup(struct dohentry *d) +{ + int i = 0; + for(i = 0; i < d->numcname; i++) { + curlx_dyn_free(&d->cname[i]); + } +#ifdef USE_HTTPSRR + for(i = 0; i < d->numhttps_rrs; i++) + curlx_safefree(d->https_rrs[i].val); +#endif +} + +#ifdef USE_HTTPSRR + +/* + * @brief decode the DNS name in a binary RRData + * @param buf points to the buffer (in/out) + * @param remaining points to the remaining buffer length (in/out) + * @param dnsname returns the string form name on success + * @return is 1 for success, error otherwise + * + * The encoding here is defined in + * https://datatracker.ietf.org/doc/html/rfc1035#section-3.1 + * + * The input buffer pointer will be modified so it points to after the end of + * the DNS name encoding on output. (that is why it is an "unsigned char + * **" :-) + */ +static CURLcode doh_decode_rdata_name(const unsigned char **buf, + size_t *remaining, char **dnsname) +{ + const unsigned char *cp = NULL; + size_t rem = 0; + unsigned char clen = 0; /* chunk len */ + struct dynbuf thename; + + DEBUGASSERT(buf && remaining && dnsname); + if(!buf || !remaining || !dnsname || !*remaining) + return CURLE_OUT_OF_MEMORY; + curlx_dyn_init(&thename, CURL_MAXLEN_HOST_NAME); + rem = *remaining; + cp = *buf; + clen = *cp++; + /* RFC 9460 says it must be uncompressed */ + if(clen > 63) + return CURLE_WEIRD_SERVER_REPLY; + + if(clen == 0) { + /* special case - return "." as name */ + if(curlx_dyn_addn(&thename, ".", 1)) + return CURLE_OUT_OF_MEMORY; + } + while(clen) { + if(clen >= rem) { + curlx_dyn_free(&thename); + return CURLE_OUT_OF_MEMORY; + } + if(curlx_dyn_addn(&thename, cp, clen) || + curlx_dyn_addn(&thename, ".", 1)) + return CURLE_TOO_LARGE; + + cp += clen; + rem -= (clen + 1); + if(rem <= 0) { + curlx_dyn_free(&thename); + return CURLE_OUT_OF_MEMORY; + } + clen = *cp++; + if(clen > 63) { + /* invalid format */ + curlx_dyn_free(&thename); + return CURLE_WEIRD_SERVER_REPLY; + } + } + *buf = cp; + *remaining = rem - 1; + *dnsname = curlx_dyn_ptr(&thename); + return CURLE_OK; +} + +/* @unittest 1658 */ +UNITTEST CURLcode doh_resp_decode_httpsrr(struct Curl_easy *data, + const unsigned char *cp, size_t len, + struct Curl_https_rrinfo **hrr); +UNITTEST CURLcode doh_resp_decode_httpsrr(struct Curl_easy *data, + const unsigned char *cp, size_t len, + struct Curl_https_rrinfo **hrr) +{ + uint16_t pcode = 0, plen = 0; + uint32_t expected_min_pcode = 0; + struct Curl_https_rrinfo *lhrr = NULL; + char *dnsname = NULL; + CURLcode result = CURLE_OUT_OF_MEMORY; + size_t olen; + + (void)data; + *hrr = NULL; + if(len <= 2) + return CURLE_BAD_FUNCTION_ARGUMENT; + lhrr = curlx_calloc(1, sizeof(struct Curl_https_rrinfo)); + if(!lhrr) + return CURLE_OUT_OF_MEMORY; + lhrr->priority = doh_get16bit(cp, 0); + cp += 2; + len -= 2; + if(doh_decode_rdata_name(&cp, &len, &dnsname) != CURLE_OK) + goto err; + lhrr->target = dnsname; + if(Curl_junkscan(dnsname, &olen, FALSE)) { + /* unacceptable hostname content */ + result = CURLE_WEIRD_SERVER_REPLY; + goto err; + } + while(len >= 4) { + pcode = doh_get16bit(cp, 0); + plen = doh_get16bit(cp, 2); + cp += 4; + len -= 4; + if(pcode < expected_min_pcode || plen > len) { + result = CURLE_WEIRD_SERVER_REPLY; + goto err; + } + result = Curl_httpsrr_set(lhrr, pcode, cp, plen); + if(result) + goto err; + Curl_httpsrr_trace(data, lhrr); + cp += plen; + len -= plen; + expected_min_pcode = pcode + 1; + } + DEBUGASSERT(!len); + *hrr = lhrr; + return CURLE_OK; +err: + Curl_httpsrr_cleanup(lhrr); + curlx_safefree(lhrr); + return result; +} + +#if defined(DEBUGBUILD) && defined(CURLVERBOSE) +static void doh_print_httpsrr(struct Curl_easy *data, + struct Curl_https_rrinfo *hrr) +{ + DEBUGASSERT(hrr); + infof(data, "HTTPS RR: priority %d, target: %s", hrr->priority, hrr->target); + if(hrr->alpns[0] != ALPN_none) + infof(data, "HTTPS RR: alpns %u %u %u %u", + hrr->alpns[0], hrr->alpns[1], hrr->alpns[2], hrr->alpns[3]); + else + infof(data, "HTTPS RR: no alpns"); + if(hrr->no_def_alpn) + infof(data, "HTTPS RR: no_def_alpn set"); + else + infof(data, "HTTPS RR: no_def_alpn not set"); + if(hrr->ipv4hints) { + doh_print_buf(data, "HTTPS RR: ipv4hints", + hrr->ipv4hints, hrr->ipv4hints_len); + } + else + infof(data, "HTTPS RR: no ipv4hints"); + if(hrr->echconfiglist) { + doh_print_buf(data, "HTTPS RR: ECHConfigList", + hrr->echconfiglist, hrr->echconfiglist_len); + } + else + infof(data, "HTTPS RR: no ECHConfigList"); + if(hrr->ipv6hints) { + doh_print_buf(data, "HTTPS RR: ipv6hint", + hrr->ipv6hints, hrr->ipv6hints_len); + } + else + infof(data, "HTTPS RR: no ipv6hints"); +} +# endif +#endif + +CURLcode Curl_doh_take_result(struct Curl_easy *data, + struct Curl_resolv_async *async, + struct Curl_dns_entry **pdns) +{ + struct doh_probes *dohp = async->doh; + CURLcode result = CURLE_OK; + struct dohentry de; + + *pdns = NULL; /* defaults to no response */ + if(!dohp) + return CURLE_OUT_OF_MEMORY; + + if(dohp->probe_resp[DOH_SLOT_IPV4].probe_mid == UINT32_MAX && + dohp->probe_resp[DOH_SLOT_IPV6].probe_mid == UINT32_MAX) { + failf(data, "Could not DoH-resolve: %s", dohp->host); + return async->for_proxy ? + CURLE_COULDNT_RESOLVE_PROXY : CURLE_COULDNT_RESOLVE_HOST; + } + else if(!dohp->pending) { + DOHcode rc[DOH_SLOT_COUNT]; + int slot; + + memset(rc, 0, sizeof(rc)); + /* remove DoH handles from multi handle and close them */ + doh_close(data, async); + /* parse the responses, create the struct and return it! */ + de_init(&de); + for(slot = 0; slot < DOH_SLOT_COUNT; slot++) { + struct doh_response *p = &dohp->probe_resp[slot]; + if(!p->dnstype) + continue; + rc[slot] = doh_resp_decode(curlx_dyn_uptr(&p->body), + curlx_dyn_len(&p->body), + p->dnstype, &de); + if(rc[slot]) { + CURL_TRC_DNS(data, "DoH: %s type %s for %s", doh_strerror(rc[slot]), + doh_type2name(p->dnstype), dohp->host); + } + } /* next slot */ + + if(!rc[DOH_SLOT_IPV4] || !rc[DOH_SLOT_IPV6]) { + /* we have an address, of one kind or other */ + struct Curl_dns_entry *dns; + struct Curl_addrinfo *ai; + + if(Curl_trc_ft_is_verbose(data, &Curl_trc_feat_dns)) { + CURL_TRC_DNS(data, "hostname: %s", dohp->host); + doh_show(data, &de); + } + + result = doh2ai(&de, dohp->host, dohp->port, &ai); + if(result) + goto error; + + /* we got a response, create a dns entry. */ + dns = Curl_dnscache_mk_entry(data, async->dns_queries, + &ai, dohp->host, dohp->port); + if(!dns) { + result = CURLE_OUT_OF_MEMORY; + goto error; + } + + /* Now add and HTTPSRR information if we have */ +#ifdef USE_HTTPSRR + if(de.numhttps_rrs > 0 && result == CURLE_OK) { + struct Curl_https_rrinfo *hrr = NULL; + result = doh_resp_decode_httpsrr(data, de.https_rrs->val, + de.https_rrs->len, &hrr); + if(result) { + infof(data, "Failed to decode HTTPS RR"); + Curl_dns_entry_unlink(data, &dns); + goto error; + } + infof(data, "Some HTTPS RR to process"); +#if defined(DEBUGBUILD) && defined(CURLVERBOSE) + doh_print_httpsrr(data, hrr); +#endif + Curl_dns_entry_set_https_rr(dns, hrr); + } +#endif /* USE_HTTPSRR */ + + /* and add the entry to the cache */ + result = Curl_dnscache_add(data, dns); + *pdns = dns; + } /* address processing done */ + else { + result = async->for_proxy ? + CURLE_COULDNT_RESOLVE_PROXY : CURLE_COULDNT_RESOLVE_HOST; + } + + } /* !dohp->pending */ + else + /* wait for pending DoH transactions to complete */ + return CURLE_AGAIN; + +error: + de_cleanup(&de); + Curl_doh_cleanup(data, async); + return result; +} + +static void doh_close(struct Curl_easy *data, + struct Curl_resolv_async *async) +{ + struct doh_probes *doh = async ? async->doh : NULL; + if(doh && data->multi) { + struct Curl_easy *probe_data; + uint32_t mid; + size_t slot; + for(slot = 0; slot < DOH_SLOT_COUNT; slot++) { + mid = doh->probe_resp[slot].probe_mid; + if(mid == UINT32_MAX) + continue; + doh->probe_resp[slot].probe_mid = UINT32_MAX; + /* should have been called before data is removed from multi handle */ + DEBUGASSERT(data->multi); + probe_data = data->multi ? Curl_multi_get_easy(data->multi, mid) : NULL; + if(!probe_data) { + DEBUGF(infof(data, "Curl_doh_close: xfer for mid=%u not found!", + doh->probe_resp[slot].probe_mid)); + continue; + } + /* data->multi might already be reset at this time */ + curl_multi_remove_handle(data->multi, probe_data); + Curl_close(&probe_data); + } + data->sub_xfer_done = NULL; + } +} + +void Curl_doh_cleanup(struct Curl_easy *data, + struct Curl_resolv_async *async) +{ + struct doh_probes *dohp = async->doh; + if(dohp) { + int i; + doh_close(data, async); + for(i = 0; i < DOH_SLOT_COUNT; ++i) { + curlx_dyn_free(&dohp->probe_resp[i].body); + } + curlx_safefree(async->doh); + } +} + +#endif /* CURL_DISABLE_DOH */ diff --git a/3rdparty/curl-8.21.0/lib/doh.h b/3rdparty/curl-8.21.0/lib/doh.h new file mode 100644 index 0000000000..cd2aad9254 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/doh.h @@ -0,0 +1,176 @@ +#ifndef HEADER_CURL_DOH_H +#define HEADER_CURL_DOH_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "urldata.h" + +/* enums outside of the #ifdef to make the types work in unitprotos.h even on + builds without DoH support */ + +struct Curl_resolv_async; + +typedef enum { + DOH_OK, + DOH_DNS_BAD_LABEL, /* 1 */ + DOH_DNS_OUT_OF_RANGE, /* 2 */ + DOH_DNS_LABEL_LOOP, /* 3 */ + DOH_TOO_SMALL_BUFFER, /* 4 */ + DOH_OUT_OF_MEM, /* 5 */ + DOH_DNS_RDATA_LEN, /* 6 */ + DOH_DNS_MALFORMAT, /* 7 */ + DOH_DNS_BAD_RCODE, /* 8 - no such name */ + DOH_DNS_UNEXPECTED_TYPE, /* 9 */ + DOH_DNS_UNEXPECTED_CLASS, /* 10 */ + DOH_NO_CONTENT, /* 11 */ + DOH_DNS_BAD_ID, /* 12 */ + DOH_DNS_NAME_TOO_LONG /* 13 */ +} DOHcode; + +typedef enum { + CURL_DNS_TYPE_A = 1, + CURL_DNS_TYPE_NS = 2, + CURL_DNS_TYPE_CNAME = 5, + CURL_DNS_TYPE_AAAA = 28, + CURL_DNS_TYPE_DNAME = 39, /* RFC6672 */ + CURL_DNS_TYPE_HTTPS = 65 +} DNStype; + +struct dohentry; /* forward-declare for non-DoH builds */ + +#ifndef CURL_DISABLE_DOH + +enum doh_slot_num { + /* Explicit values for first two symbols so as to match hard-coded + * constants in existing code + */ + DOH_SLOT_IPV4 = 0, /* make 'V4' stand out for readability */ + DOH_SLOT_IPV6 = 1, /* 'V6' likewise */ + + /* Space here for (possibly build-specific) additional slot definitions */ +#ifdef USE_HTTPSRR + DOH_SLOT_HTTPS_RR = 2, /* for HTTPS RR */ +#endif + + /* for example */ + /* #ifdef WANT_DOH_FOOBAR_TXT */ + /* DOH_PROBE_SLOT_FOOBAR_TXT, */ + /* #endif */ + + /* AFTER all slot definitions, establish how many we have */ + DOH_SLOT_COUNT +}; + +#define CURL_EZM_DOH_PROBE "ezm:doh-p" + +/* the largest one we can make, based on RFCs 1034, 1035 */ +#define DOH_MAX_DNSREQ_SIZE (256 + 16) + +/* each DoH probe request has this + * as easy meta for CURL_EZM_DOH_PROBE */ +struct doh_request { + unsigned char req_body[DOH_MAX_DNSREQ_SIZE]; + struct curl_slist *req_hds; + struct dynbuf resp_body; + size_t req_body_len; + uint32_t resolv_id; /* id of the resolve operation */ + DNStype dnstype; +}; + +struct doh_response { + uint32_t probe_mid; + struct dynbuf body; + DNStype dnstype; + CURLcode result; +}; + +/* each transfer firing off DoH requests has this + * as easy meta for CURL_EZM_DOH_MASTER */ +struct doh_probes { + struct doh_response probe_resp[DOH_SLOT_COUNT]; + unsigned int pending; /* still outstanding probes */ + uint16_t port; + const char *host; +}; + +/* + * Curl_doh() starts a name resolve using DoH (DNS-over-HTTPS). It resolves a + * name and returns a 'Curl_addrinfo *' with the address information. + */ +CURLcode Curl_doh(struct Curl_easy *data, + struct Curl_resolv_async *async); + +CURLcode Curl_doh_take_result(struct Curl_easy *data, + struct Curl_resolv_async *async, + struct Curl_dns_entry **pdns); + +#define DOH_MAX_ADDR 24 +#define DOH_MAX_CNAME 4 +#define DOH_MAX_HTTPS 4 + +struct dohaddr { + int type; + union { + unsigned char v4[4]; /* network byte order */ + unsigned char v6[16]; + } ip; +}; + +#ifdef USE_HTTPSRR + +/* + * These may need escaping when found within an ALPN string + * value. + */ +#define COMMA_CHAR ',' +#define BACKSLASH_CHAR '\\' + +struct dohhttps_rr { + uint16_t len; /* raw encoded length */ + unsigned char *val; /* raw encoded octets */ +}; +#endif + +struct dohentry { + struct dynbuf cname[DOH_MAX_CNAME]; + struct dohaddr addr[DOH_MAX_ADDR]; + int numaddr; + unsigned int ttl; + int numcname; +#ifdef USE_HTTPSRR + struct dohhttps_rr https_rrs[DOH_MAX_HTTPS]; + int numhttps_rrs; +#endif +}; + +void Curl_doh_cleanup(struct Curl_easy *data, + struct Curl_resolv_async *async); +#define Curl_doh_wanted(d) (!!(d)->set.doh) + +#else /* CURL_DISABLE_DOH */ +#define Curl_doh(a, b) NULL +#define Curl_doh_take_result(x, y, z) CURLE_COULDNT_RESOLVE_HOST +#define Curl_doh_wanted(d) FALSE +#endif /* !CURL_DISABLE_DOH */ + +#endif /* HEADER_CURL_DOH_H */ diff --git a/3rdparty/curl-8.21.0/lib/dynhds.c b/3rdparty/curl-8.21.0/lib/dynhds.c new file mode 100644 index 0000000000..097306cec9 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/dynhds.c @@ -0,0 +1,385 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "dynhds.h" +#include "strcase.h" + +static struct dynhds_entry *entry_new(const char *name, size_t namelen, + const char *value, size_t valuelen, + int opts) +{ + struct dynhds_entry *e; + char *p; + + DEBUGASSERT(name); + DEBUGASSERT(value); + e = curlx_calloc(1, sizeof(*e) + namelen + valuelen + 2); + if(!e) + return NULL; + e->name = p = (char *)e + sizeof(*e); + memcpy(p, name, namelen); + e->namelen = namelen; + e->value = p += namelen + 1; /* leave a \0 at the end of name */ + memcpy(p, value, valuelen); + e->valuelen = valuelen; + if(opts & DYNHDS_OPT_LOWERCASE) + Curl_strntolower(e->name, e->name, e->namelen); + return e; +} + +static void entry_free(struct dynhds_entry *e) +{ + curlx_free(e); +} + +void Curl_dynhds_init(struct dynhds *dynhds, size_t max_entries, + size_t max_strs_size) +{ + DEBUGASSERT(dynhds); + DEBUGASSERT(max_strs_size); + dynhds->hds = NULL; + dynhds->hds_len = dynhds->hds_allc = dynhds->strs_len = 0; + dynhds->max_entries = max_entries; + dynhds->max_strs_size = max_strs_size; + dynhds->opts = 0; +} + +void Curl_dynhds_free(struct dynhds *dynhds) +{ + DEBUGASSERT(dynhds); + if(dynhds->hds && dynhds->hds_len) { + size_t i; + DEBUGASSERT(dynhds->hds); + for(i = 0; i < dynhds->hds_len; ++i) { + entry_free(dynhds->hds[i]); + } + } + curlx_safefree(dynhds->hds); + dynhds->hds_len = dynhds->hds_allc = dynhds->strs_len = 0; +} + +void Curl_dynhds_reset(struct dynhds *dynhds) +{ + DEBUGASSERT(dynhds); + if(dynhds->hds_len) { + size_t i; + DEBUGASSERT(dynhds->hds); + for(i = 0; i < dynhds->hds_len; ++i) { + entry_free(dynhds->hds[i]); + dynhds->hds[i] = NULL; + } + } + dynhds->hds_len = dynhds->strs_len = 0; +} + +size_t Curl_dynhds_count(struct dynhds *dynhds) +{ + return dynhds->hds_len; +} + +void Curl_dynhds_set_opts(struct dynhds *dynhds, int opts) +{ + dynhds->opts = opts; +} + +struct dynhds_entry *Curl_dynhds_getn(struct dynhds *dynhds, size_t n) +{ + DEBUGASSERT(dynhds); + return (n < dynhds->hds_len) ? dynhds->hds[n] : NULL; +} + +struct dynhds_entry *Curl_dynhds_get(struct dynhds *dynhds, const char *name, + size_t namelen) +{ + size_t i; + for(i = 0; i < dynhds->hds_len; ++i) { + if(dynhds->hds[i]->namelen == namelen && + curl_strnequal(dynhds->hds[i]->name, name, namelen)) { + return dynhds->hds[i]; + } + } + return NULL; +} + +struct dynhds_entry *Curl_dynhds_cget(struct dynhds *dynhds, const char *name) +{ + return Curl_dynhds_get(dynhds, name, strlen(name)); +} + +CURLcode Curl_dynhds_add(struct dynhds *dynhds, + const char *name, size_t namelen, + const char *value, size_t valuelen) +{ + struct dynhds_entry *entry = NULL; + CURLcode result = CURLE_OUT_OF_MEMORY; + + DEBUGASSERT(dynhds); + if(dynhds->max_entries && dynhds->hds_len >= dynhds->max_entries) + return CURLE_OUT_OF_MEMORY; + if(dynhds->strs_len + namelen + valuelen > dynhds->max_strs_size) + return CURLE_OUT_OF_MEMORY; + + entry = entry_new(name, namelen, value, valuelen, dynhds->opts); + if(!entry) + goto out; + + if(dynhds->hds_len + 1 >= dynhds->hds_allc) { + size_t nallc = dynhds->hds_len + 16; + struct dynhds_entry **nhds; + + if(dynhds->max_entries && nallc > dynhds->max_entries) + nallc = dynhds->max_entries; + + nhds = curlx_calloc(nallc, sizeof(struct dynhds_entry *)); + if(!nhds) + goto out; + if(dynhds->hds) { + memcpy(nhds, dynhds->hds, + dynhds->hds_len * sizeof(struct dynhds_entry *)); + curlx_safefree(dynhds->hds); + } + dynhds->hds = nhds; + dynhds->hds_allc = nallc; + } + dynhds->hds[dynhds->hds_len++] = entry; + entry = NULL; + dynhds->strs_len += namelen + valuelen; + result = CURLE_OK; + +out: + if(entry) + entry_free(entry); + return result; +} + +CURLcode Curl_dynhds_cadd(struct dynhds *dynhds, + const char *name, const char *value) +{ + return Curl_dynhds_add(dynhds, name, strlen(name), value, strlen(value)); +} + +CURLcode Curl_dynhds_h1_add_line(struct dynhds *dynhds, + const char *line, size_t line_len) +{ + const char *p; + const char *name; + size_t namelen; + const char *value; + size_t valuelen, i; + + if(!line || !line_len) + return CURLE_OK; + + p = memchr(line, ':', line_len); + if(!p) + return CURLE_BAD_FUNCTION_ARGUMENT; + name = line; + namelen = p - line; + p++; /* move past the colon */ + for(i = namelen + 1; i < line_len; ++i, ++p) { + if(!ISBLANK(*p)) + break; + } + value = p; + valuelen = line_len - i; + + p = memchr(value, '\r', valuelen); + if(!p) + p = memchr(value, '\n', valuelen); + if(p) + valuelen = (size_t)(p - value); + + return Curl_dynhds_add(dynhds, name, namelen, value, valuelen); +} + +CURLcode Curl_dynhds_h1_cadd_line(struct dynhds *dynhds, const char *line) +{ + return Curl_dynhds_h1_add_line(dynhds, line, line ? strlen(line) : 0); +} + +#ifdef UNITTESTS +/* @unittest 2602 */ + +/** + * Return TRUE iff one or more headers with the given name exist. + */ +UNITTEST bool dynhds_contains(struct dynhds *dynhds, + const char *name, size_t namelen); +UNITTEST bool dynhds_contains(struct dynhds *dynhds, + const char *name, size_t namelen) +{ + return !!Curl_dynhds_get(dynhds, name, namelen); +} + +/* @unittest 2602 */ +UNITTEST bool dynhds_ccontains(struct dynhds *dynhds, const char *name); +UNITTEST bool dynhds_ccontains(struct dynhds *dynhds, const char *name) +{ + return dynhds_contains(dynhds, name, strlen(name)); +} + +/** + * Return how often the given name appears in `dynhds`. + * Names are case-insensitive. + * + * @unittest 2602 + */ +UNITTEST size_t dynhds_count_name(struct dynhds *dynhds, + const char *name, size_t namelen); +UNITTEST size_t dynhds_count_name(struct dynhds *dynhds, + const char *name, size_t namelen) +{ + size_t n = 0; + if(dynhds->hds_len) { + size_t i; + for(i = 0; i < dynhds->hds_len; ++i) { + if((namelen == dynhds->hds[i]->namelen) && + curl_strnequal(name, dynhds->hds[i]->name, namelen)) + ++n; + } + } + return n; +} + +/** + * Return how often the given null-terminated name appears in `dynhds`. + * Names are case-insensitive. + * + * @unittest 2602 + */ +UNITTEST size_t dynhds_ccount_name(struct dynhds *dynhds, + const char *name); +UNITTEST size_t dynhds_ccount_name(struct dynhds *dynhds, + const char *name) +{ + return dynhds_count_name(dynhds, name, strlen(name)); +} + +/** + * Remove all entries with the given name. + * Returns number of entries removed. + * + * @unittest 2602 + */ +UNITTEST size_t dynhds_remove(struct dynhds *dynhds, + const char *name, size_t namelen); +UNITTEST size_t dynhds_remove(struct dynhds *dynhds, + const char *name, size_t namelen) +{ + size_t n = 0; + if(dynhds->hds_len) { + size_t i, len; + for(i = 0; i < dynhds->hds_len; ++i) { + if((namelen == dynhds->hds[i]->namelen) && + curl_strnequal(name, dynhds->hds[i]->name, namelen)) { + ++n; + --dynhds->hds_len; + dynhds->strs_len -= (dynhds->hds[i]->namelen + + dynhds->hds[i]->valuelen); + entry_free(dynhds->hds[i]); + len = dynhds->hds_len - i; /* remaining entries */ + if(len) { + memmove(&dynhds->hds[i], &dynhds->hds[i + 1], + len * sizeof(dynhds->hds[i])); + } + --i; /* do this index again */ + } + } + } + return n; +} + +/** + * Set the give header name and value, replacing any entries with + * the same name. The header is added at the end of all (remaining) + * entries. + * + * @unittest 2602 + */ +UNITTEST CURLcode dynhds_set(struct dynhds *dynhds, + const char *name, size_t namelen, + const char *value, size_t valuelen); +UNITTEST CURLcode dynhds_set(struct dynhds *dynhds, + const char *name, size_t namelen, + const char *value, size_t valuelen) +{ + dynhds_remove(dynhds, name, namelen); + return Curl_dynhds_add(dynhds, name, namelen, value, valuelen); +} + +/* @unittest 2602 */ +UNITTEST size_t dynhds_cremove(struct dynhds *dynhds, const char *name); +UNITTEST size_t dynhds_cremove(struct dynhds *dynhds, const char *name) +{ + return dynhds_remove(dynhds, name, strlen(name)); +} + +#endif /* UNITTESTS */ + +CURLcode Curl_dynhds_h1_dprint(struct dynhds *dynhds, struct dynbuf *dbuf) +{ + CURLcode result = CURLE_OK; + size_t i; + + if(!dynhds->hds_len) + return result; + + for(i = 0; i < dynhds->hds_len; ++i) { + result = curlx_dyn_addf(dbuf, "%.*s: %.*s\r\n", + (int)dynhds->hds[i]->namelen, dynhds->hds[i]->name, + (int)dynhds->hds[i]->valuelen, + dynhds->hds[i]->value); + if(result) + break; + } + + return result; +} + +#ifdef USE_NGHTTP2 + +nghttp2_nv *Curl_dynhds_to_nva(struct dynhds *dynhds, size_t *pcount) +{ + nghttp2_nv *nva = curlx_calloc(1, sizeof(nghttp2_nv) * dynhds->hds_len); + size_t i; + + *pcount = 0; + if(!nva) + return NULL; + + for(i = 0; i < dynhds->hds_len; ++i) { + struct dynhds_entry *e = dynhds->hds[i]; + DEBUGASSERT(e); + nva[i].name = (unsigned char *)e->name; + nva[i].namelen = e->namelen; + nva[i].value = (unsigned char *)e->value; + nva[i].valuelen = e->valuelen; + nva[i].flags = NGHTTP2_NV_FLAG_NONE; + } + *pcount = dynhds->hds_len; + return nva; +} + +#endif /* USE_NGHTTP2 */ diff --git a/3rdparty/curl-8.21.0/lib/dynhds.h b/3rdparty/curl-8.21.0/lib/dynhds.h new file mode 100644 index 0000000000..d5337eb353 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/dynhds.h @@ -0,0 +1,141 @@ +#ifndef HEADER_CURL_DYNHDS_H +#define HEADER_CURL_DYNHDS_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "curlx/dynbuf.h" + +struct dynbuf; + +/** + * A single header entry. + * `name` and `value` are non-NULL and always null-terminated. + */ +struct dynhds_entry { + char *name; + char *value; + size_t namelen; + size_t valuelen; +}; + +struct dynhds { + struct dynhds_entry **hds; + size_t hds_len; /* number of entries in hds */ + size_t hds_allc; /* size of hds allocation */ + size_t max_entries; /* size limit number of entries */ + size_t strs_len; /* length of all strings */ + size_t max_strs_size; /* max length of all strings */ + int opts; +}; + +#define DYNHDS_OPT_NONE 0 +#define DYNHDS_OPT_LOWERCASE (1 << 0) + +/** + * Init for use on first time or after a reset. + * Allow `max_entries` headers to be added, 0 for unlimited. + * Allow size of all name and values added to not exceed `max_strs_size`` + */ +void Curl_dynhds_init(struct dynhds *dynhds, size_t max_entries, + size_t max_strs_size); +/** + * Frees all data held in `dynhds`, but not the struct itself. + */ +void Curl_dynhds_free(struct dynhds *dynhds); + +/** + * Reset `dyndns` to the initial init state. May keep allocations + * around. + */ +void Curl_dynhds_reset(struct dynhds *dynhds); + +/** + * Return the number of header entries. + */ +size_t Curl_dynhds_count(struct dynhds *dynhds); + +/** + * Set the options to use, replacing any existing ones. + * This will not have an effect on already existing headers. + */ +void Curl_dynhds_set_opts(struct dynhds *dynhds, int opts); + +/** + * Return the n-th header entry or NULL if it does not exist. + */ +struct dynhds_entry *Curl_dynhds_getn(struct dynhds *dynhds, size_t n); + +/** + * Return the 1st header entry of the name or NULL if none exists. + */ +struct dynhds_entry *Curl_dynhds_get(struct dynhds *dynhds, + const char *name, size_t namelen); +struct dynhds_entry *Curl_dynhds_cget(struct dynhds *dynhds, const char *name); + +CURLcode Curl_dynhds_cset(struct dynhds *dynhds, + const char *name, const char *value); + +/** + * Add a header, name + value, to `dynhds` at the end. Does *not* + * check for duplicate names. + */ +CURLcode Curl_dynhds_add(struct dynhds *dynhds, + const char *name, size_t namelen, + const char *value, size_t valuelen); + +/** + * Add a header, c-string name + value, to `dynhds` at the end. + */ +CURLcode Curl_dynhds_cadd(struct dynhds *dynhds, + const char *name, const char *value); + +/** + * Add a single header from an HTTP/1.1 formatted line at the end. Line may + * contain a delimiting CRLF or LF. Any characters after that will be ignored. + */ +CURLcode Curl_dynhds_h1_cadd_line(struct dynhds *dynhds, const char *line); + +/** + * Add a single header from an HTTP/1.1 formatted line at the end. Line may + * contain a delimiting CRLF or LF. Any characters after that will be ignored. + */ +CURLcode Curl_dynhds_h1_add_line(struct dynhds *dynhds, + const char *line, size_t line_len); + +/** + * Add the headers to the given `dynbuf` in HTTP/1.1 format with + * CR+LF line endings. Does NOT output a last empty line. + */ +CURLcode Curl_dynhds_h1_dprint(struct dynhds *dynhds, struct dynbuf *dbuf); + +#ifdef USE_NGHTTP2 + +#include + +nghttp2_nv *Curl_dynhds_to_nva(struct dynhds *dynhds, size_t *pcount); + +#endif /* USE_NGHTTP2 */ + +#endif /* HEADER_CURL_DYNHDS_H */ diff --git a/3rdparty/curl-8.21.0/lib/easy.c b/3rdparty/curl-8.21.0/lib/easy.c new file mode 100644 index 0000000000..d60bdaed7b --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/easy.c @@ -0,0 +1,1406 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETDB_H +#include +#endif +#ifdef HAVE_ARPA_INET_H +#include +#endif +#ifdef HAVE_NET_IF_H +#include +#endif +#ifdef HAVE_SYS_IOCTL_H +#include +#endif + +#ifdef HAVE_SYS_PARAM_H +#include +#endif + +#include "urldata.h" +#include "transfer.h" +#include "vtls/vtls.h" +#include "vtls/vtls_scache.h" +#include "vquic/vquic.h" +#include "url.h" +#include "getinfo.h" +#include "hostip.h" +#include "curlx/strdup.h" +#include "easyif.h" +#include "multiif.h" +#include "multi_ev.h" +#include "select.h" +#include "cfilters.h" +#include "sendf.h" +#include "curl_trc.h" +#include "connect.h" /* for Curl_getconnectinfo */ +#include "slist.h" +#include "mime.h" +#include "amigaos.h" +#include "macos.h" +#include "curlx/wait.h" +#include "sigpipe.h" +#include "vssh/ssh.h" +#include "setopt.h" +#include "http_digest.h" +#include "system_win32.h" +#include "curlx/dynbuf.h" +#include "bufref.h" +#include "altsvc.h" +#include "hsts.h" + +#include "easy_lock.h" + +/* true globals -- for curl_global_init() and curl_global_cleanup() */ +static unsigned int initialized; +static long easy_init_flags; + +#ifdef GLOBAL_INIT_IS_THREADSAFE + +static curl_simple_lock s_lock = CURL_SIMPLE_LOCK_INIT; +#define global_init_lock() curl_simple_lock_lock(&s_lock) +#define global_init_unlock() curl_simple_lock_unlock(&s_lock) + +#else + +#define global_init_lock() +#define global_init_unlock() + +#endif + +#if defined(_MSC_VER) && defined(_DLL) +# pragma warning(push) +# pragma warning(disable:4232) /* MSVC extension, dllimport identity */ +#endif + +/* + * If a memory-using function (like curl_getenv) is used before + * curl_global_init() is called, we need to have these pointers set already. + */ +curl_malloc_callback Curl_cmalloc = (curl_malloc_callback)malloc; +curl_free_callback Curl_cfree = (curl_free_callback)free; +curl_realloc_callback Curl_crealloc = (curl_realloc_callback)realloc; +curl_strdup_callback Curl_cstrdup = (curl_strdup_callback)CURLX_STRDUP_LOW; +curl_calloc_callback Curl_ccalloc = (curl_calloc_callback)calloc; + +#if defined(_MSC_VER) && defined(_DLL) +# pragma warning(pop) +#endif + +#ifdef DEBUGBUILD +static char *leakpointer; +#endif + +/** + * curl_global_init() globally initializes curl given a bitwise set of the + * different features of what to initialize. + */ +static CURLcode global_init(long flags, bool memoryfuncs) +{ + if(initialized++) + return CURLE_OK; + + if(memoryfuncs) { + /* Setup the default memory functions here (again) */ + Curl_cmalloc = (curl_malloc_callback)malloc; + Curl_cfree = (curl_free_callback)free; + Curl_crealloc = (curl_realloc_callback)realloc; + Curl_cstrdup = (curl_strdup_callback)CURLX_STRDUP_LOW; + Curl_ccalloc = (curl_calloc_callback)calloc; + } + + if(Curl_trc_init()) { + DEBUGF(curl_mfprintf(stderr, "Error: Curl_trc_init failed\n")); + goto fail; + } + + if(!Curl_ssl_init()) { + DEBUGF(curl_mfprintf(stderr, "Error: Curl_ssl_init failed\n")); + goto fail; + } + + if(!Curl_vquic_init()) { + DEBUGF(curl_mfprintf(stderr, "Error: Curl_vquic_init failed\n")); + goto fail; + } + + if(Curl_win32_init(flags)) { + DEBUGF(curl_mfprintf(stderr, "Error: win32_init failed\n")); + goto fail; + } + + if(Curl_amiga_init()) { + DEBUGF(curl_mfprintf(stderr, "Error: Curl_amiga_init failed\n")); + goto fail; + } + + if(Curl_macos_init()) { + DEBUGF(curl_mfprintf(stderr, "Error: Curl_macos_init failed\n")); + goto fail; + } + + if(Curl_async_global_init()) { + DEBUGF(curl_mfprintf(stderr, "Error: resolver_global_init failed\n")); + goto fail; + } + + if(Curl_ssh_init()) { + DEBUGF(curl_mfprintf(stderr, "Error: Curl_ssh_init failed\n")); + goto fail; + } + + easy_init_flags = flags; + +#ifdef DEBUGBUILD + if(getenv("CURL_GLOBAL_INIT")) + /* alloc data that will leak if *cleanup() is not called! */ + leakpointer = curlx_malloc(1); +#endif + + return CURLE_OK; + +fail: + initialized--; /* undo the increase */ + return CURLE_FAILED_INIT; +} + +/** + * curl_global_init() globally initializes curl given a bitwise set of the + * different features of what to initialize. + */ +CURLcode curl_global_init(long flags) +{ + CURLcode result; + global_init_lock(); + + result = global_init(flags, TRUE); + + global_init_unlock(); + + return result; +} + +/* + * curl_global_init_mem() globally initializes curl and also registers the + * user provided callback routines. + */ +CURLcode curl_global_init_mem(long flags, curl_malloc_callback m, + curl_free_callback f, curl_realloc_callback r, + curl_strdup_callback s, curl_calloc_callback c) +{ + CURLcode result; + + /* Invalid input, return immediately */ + if(!m || !f || !r || !s || !c) + return CURLE_FAILED_INIT; + + global_init_lock(); + + if(initialized) { + /* Already initialized, do not do it again, but bump the variable anyway to + work like curl_global_init() and require the same amount of cleanup + calls. */ + initialized++; + global_init_unlock(); + return CURLE_OK; + } + + /* set memory functions before global_init() in case it wants memory + functions */ + Curl_cmalloc = m; + Curl_cfree = f; + Curl_cstrdup = s; + Curl_crealloc = r; + Curl_ccalloc = c; + + /* Call the actual init function, but without setting */ + result = global_init(flags, FALSE); + + global_init_unlock(); + + return result; +} + +/** + * curl_global_cleanup() globally cleanups curl, uses the value of + * "easy_init_flags" to determine what needs to be cleaned up and what does + * not. + */ +void curl_global_cleanup(void) +{ + global_init_lock(); + + if(!initialized) { + global_init_unlock(); + return; + } + + if(--initialized) { + global_init_unlock(); + return; + } + + Curl_ssl_cleanup(); + Curl_async_global_cleanup(); + +#ifdef _WIN32 + Curl_win32_cleanup(easy_init_flags); +#endif + + Curl_amiga_cleanup(); + + Curl_ssh_cleanup(); + +#ifdef DEBUGBUILD + curlx_free(leakpointer); +#endif + + easy_init_flags = 0; + + global_init_unlock(); +} + +/** + * curl_global_trace() globally initializes curl logging. + */ +CURLcode curl_global_trace(const char *config) +{ +#ifndef CURL_DISABLE_VERBOSE_STRINGS + CURLcode result; + global_init_lock(); + + result = Curl_trc_opt(config); + + global_init_unlock(); + + return result; +#else + (void)config; + return CURLE_OK; +#endif +} + +/* + * curl_global_sslset() globally initializes the SSL backend to use. + */ +CURLsslset curl_global_sslset(curl_sslbackend id, const char *name, + const curl_ssl_backend ***avail) +{ + CURLsslset rc; + + global_init_lock(); + + rc = Curl_init_sslset_nolock(id, name, avail); + + global_init_unlock(); + + return rc; +} + +/* + * curl_easy_init() is the external interface to alloc, setup and init an + * easy handle that is returned. If anything goes wrong, NULL is returned. + */ +CURL *curl_easy_init(void) +{ + CURLcode result; + struct Curl_easy *data; + + /* Make sure we inited the global SSL stuff */ + global_init_lock(); + + if(!initialized) { + result = global_init(CURL_GLOBAL_DEFAULT, TRUE); + if(result) { + /* something in the global init failed, return nothing */ + DEBUGF(curl_mfprintf(stderr, "Error: curl_global_init failed\n")); + global_init_unlock(); + return NULL; + } + } + global_init_unlock(); + + /* We use Curl_open() with undefined URL so far */ + result = Curl_open(&data); + if(result) { + DEBUGF(curl_mfprintf(stderr, "Error: Curl_open failed\n")); + return NULL; + } + + return data; +} + +#ifdef DEBUGBUILD + +struct socketmonitor { + struct socketmonitor *next; /* the next node in the list or NULL */ + struct pollfd socket; /* socket info of what to monitor */ +}; + +struct events { + long ms; /* timeout, run the timeout function when reached */ + bool msbump; /* set TRUE when timeout is set by callback */ + int num_sockets; /* number of nodes in the monitor list */ + struct socketmonitor *list; /* list of sockets to monitor */ + int running_handles; /* store the returned number */ +}; + +#define DEBUG_EV_POLL 0 + +/* events_timer + * + * Callback that gets called with a new value when the timeout should be + * updated. + */ +static int events_timer(CURLM *multi, /* multi handle */ + long timeout_ms, /* see above */ + void *userp) /* private callback pointer */ +{ + struct events *ev = userp; + (void)multi; +#if DEBUG_EV_POLL + curl_mfprintf(stderr, "events_timer: set timeout %ldms\n", timeout_ms); +#endif + ev->ms = timeout_ms; + ev->msbump = TRUE; + return 0; +} + +/* poll2cselect + * + * convert from poll() bit definitions to libcurl's CURL_CSELECT_* ones + */ +static int poll2cselect(int pollmask) +{ + int omask = 0; + if(pollmask & POLLIN) + omask |= CURL_CSELECT_IN; + if(pollmask & POLLOUT) + omask |= CURL_CSELECT_OUT; + if(pollmask & POLLERR) + omask |= CURL_CSELECT_ERR; + return omask; +} + +/* socketcb2poll + * + * convert from libcurl' CURL_POLL_* bit definitions to poll()'s + */ +static short socketcb2poll(int pollmask) +{ + short omask = 0; + if(pollmask & CURL_POLL_IN) + omask |= POLLIN; + if(pollmask & CURL_POLL_OUT) + omask |= POLLOUT; + return omask; +} + +/* events_socket + * + * Callback that gets called with information about socket activity to + * monitor. + */ +static int events_socket(CURL *easy, /* easy handle */ + curl_socket_t s, /* socket */ + int what, /* see above */ + void *userp, /* private callback + pointer */ + void *socketp) /* private socket + pointer */ +{ + struct events *ev = userp; + struct socketmonitor *m; + struct socketmonitor *prev = NULL; + bool found = FALSE; + struct Curl_easy *data = easy; + +#ifdef CURL_DISABLE_VERBOSE_STRINGS + (void)easy; +#endif + (void)socketp; + + m = ev->list; + while(m) { + if(m->socket.fd == s) { + found = TRUE; + if(what == CURL_POLL_REMOVE) { + struct socketmonitor *nxt = m->next; + /* remove this node from the list of monitored sockets */ + if(prev) + prev->next = nxt; + else + ev->list = nxt; + curlx_free(m); + infof(data, "socket cb: socket %" FMT_SOCKET_T " REMOVED", s); + } + else { + /* The socket 's' is already being monitored, update the activity + mask. Convert from libcurl bitmask to the poll one. */ + m->socket.events = socketcb2poll(what); + infof(data, "socket cb: socket %" FMT_SOCKET_T " UPDATED as %s%s", s, + (what & CURL_POLL_IN) ? "IN" : "", + (what & CURL_POLL_OUT) ? "OUT" : ""); + } + break; + } + prev = m; + m = m->next; /* move to next node */ + } + + if(!found) { + if(what == CURL_POLL_REMOVE) { + /* should not happen if our logic is correct, but is no drama. */ + DEBUGF(infof(data, "socket cb: asked to REMOVE socket %" + FMT_SOCKET_T "but not present!", s)); + DEBUGASSERT(0); + } + else { + m = curlx_malloc(sizeof(struct socketmonitor)); + if(m) { + m->next = ev->list; + m->socket.fd = s; + m->socket.events = socketcb2poll(what); + m->socket.revents = 0; + ev->list = m; + infof(data, "socket cb: socket %" FMT_SOCKET_T " ADDED as %s%s", s, + (what & CURL_POLL_IN) ? "IN" : "", + (what & CURL_POLL_OUT) ? "OUT" : ""); + } + else + return CURLE_OUT_OF_MEMORY; + } + } + + return 0; +} + +/* + * events_setup() + * + * Do the multi handle setups that only event-based transfers need. + */ +static void events_setup(struct Curl_multi *multi, struct events *ev) +{ + /* timer callback */ + curl_multi_setopt(multi, CURLMOPT_TIMERFUNCTION, events_timer); + curl_multi_setopt(multi, CURLMOPT_TIMERDATA, ev); + + /* socket callback */ + curl_multi_setopt(multi, CURLMOPT_SOCKETFUNCTION, events_socket); + curl_multi_setopt(multi, CURLMOPT_SOCKETDATA, ev); +} + +/* populate_fds() + * + * populate the fds[] array + */ +static unsigned int populate_fds(struct pollfd *fds, struct events *ev) +{ + unsigned int numfds = 0; + struct pollfd *f; + struct socketmonitor *m; + + f = &fds[0]; + for(m = ev->list; m; m = m->next) { + f->fd = m->socket.fd; + f->events = m->socket.events; + f->revents = 0; +#if DEBUG_EV_POLL + curl_mfprintf(stderr, "poll() %d check socket %d\n", numfds, f->fd); +#endif + f++; + numfds++; + } + return numfds; +} + +/* poll_fds() + * + * poll the fds[] array + */ +static CURLcode poll_fds(struct events *ev, + struct pollfd *fds, + const unsigned int numfds, + int *pollrc) +{ + if(numfds) { + /* wait for activity or timeout */ +#if DEBUG_EV_POLL + curl_mfprintf(stderr, "poll(numfds=%u, timeout=%ldms)\n", numfds, ev->ms); +#endif + *pollrc = Curl_poll(fds, numfds, ev->ms); +#if DEBUG_EV_POLL + curl_mfprintf(stderr, "poll(numfds=%u, timeout=%ldms) -> %d\n", + numfds, ev->ms, *pollrc); +#endif + if(*pollrc < 0) + return CURLE_UNRECOVERABLE_POLL; + } + else { +#if DEBUG_EV_POLL + curl_mfprintf(stderr, "poll, but no fds, wait timeout=%ldms\n", ev->ms); +#endif + *pollrc = 0; + if(ev->ms > 0) + curlx_wait_ms(ev->ms); + } + return CURLE_OK; +} + +/* wait_or_timeout() + * + * waits for activity on any of the given sockets, or the timeout to trigger. + */ +static CURLcode wait_or_timeout(struct Curl_multi *multi, struct events *ev) +{ + bool done = FALSE; + CURLMcode mresult = CURLM_OK; + CURLcode result = CURLE_OK; + + while(!done) { + CURLMsg *msg; + struct pollfd fds[4]; + int pollrc; + struct curltime start; + const unsigned int numfds = populate_fds(fds, ev); + + /* get the time stamp to use to figure out how long poll takes */ + curlx_pnow(&start); + + result = poll_fds(ev, fds, numfds, &pollrc); + if(result) + return result; + + ev->msbump = FALSE; /* reset here */ + + if(!pollrc) { + /* timeout! */ + ev->ms = 0; +#if 0 + curl_mfprintf(stderr, "call curl_multi_socket_action(TIMEOUT)\n"); +#endif + mresult = curl_multi_socket_action(multi, CURL_SOCKET_TIMEOUT, 0, + &ev->running_handles); + } + else { + /* here pollrc is > 0 */ + /* loop over the monitored sockets to see which ones had activity */ + unsigned int i; + for(i = 0; i < numfds; i++) { + if(fds[i].revents) { + /* socket activity, tell libcurl */ + int act = poll2cselect(fds[i].revents); /* convert */ + + /* sending infof "randomly" to the first easy handle */ + infof(multi->admin, "call curl_multi_socket_action(socket " + "%" FMT_SOCKET_T ")", (curl_socket_t)fds[i].fd); + mresult = curl_multi_socket_action(multi, fds[i].fd, act, + &ev->running_handles); + } + } + + if(!ev->msbump && ev->ms >= 0) { + /* If nothing updated the timeout, we decrease it by the spent time. + * If it was updated, it has the new timeout time stored already. + */ + timediff_t spent_ms = curlx_timediff_ms(curlx_now(), start); + if(spent_ms > 0) { +#if DEBUG_EV_POLL + curl_mfprintf(stderr, "poll timeout %ldms not updated, decrease by " + "time spent %ldms\n", ev->ms, (long)spent_ms); +#endif + if(spent_ms > ev->ms) + ev->ms = 0; + else + ev->ms -= (long)spent_ms; + } + } + } + + if(mresult) + return CURLE_URL_MALFORMAT; + + /* we do not really care about the "msgs_in_queue" value returned in the + second argument */ + msg = curl_multi_info_read(multi, &pollrc); + if(msg) { + result = msg->data.result; + done = TRUE; + } + } + + return result; +} + +/* easy_events() + * + * Runs a transfer in a blocking manner using the events-based API + */ +static CURLcode easy_events(struct Curl_multi *multi) +{ + /* this struct is made static to allow it to be used after this function + returns and curl_multi_remove_handle() is called */ + static struct events evs = { -1, FALSE, 0, NULL, 0 }; + + /* if running event-based, do some further multi inits */ + events_setup(multi, &evs); + + return wait_or_timeout(multi, &evs); +} +#else /* DEBUGBUILD */ +/* when not built with debug, this function does not exist */ +#define easy_events(x) CURLE_NOT_BUILT_IN +#endif + +static CURLcode easy_transfer(struct Curl_multi *multi) +{ + bool done = FALSE; + CURLMcode mresult = CURLM_OK; + CURLcode result = CURLE_OK; + + while(!done && !mresult) { + int still_running = 0; + + mresult = curl_multi_poll(multi, NULL, 0, 1000, NULL); + + if(!mresult) + mresult = curl_multi_perform(multi, &still_running); + + /* only read 'still_running' if curl_multi_perform() return OK */ + if(!mresult && !still_running) { + int rc; + CURLMsg *msg = curl_multi_info_read(multi, &rc); + if(msg) { + result = msg->data.result; + done = TRUE; + } + } + } + + /* Make sure to return some kind of error if there was a multi problem */ + if(mresult) { + result = (mresult == CURLM_OUT_OF_MEMORY) ? CURLE_OUT_OF_MEMORY : + /* The other multi errors should never happen, so return + something suitably generic */ + CURLE_BAD_FUNCTION_ARGUMENT; + } + + return result; +} + +/* + * easy_perform() is the internal interface that performs a blocking + * transfer as previously setup. + * + * CONCEPT: This function creates a multi handle, adds the easy handle to it, + * runs curl_multi_perform() until the transfer is done, then detaches the + * easy handle, destroys the multi handle and returns the easy handle's return + * code. + * + * REALITY: it cannot create and destroy the multi handle that easily. It + * needs to keep it around since if this easy handle is used again by this + * function, the same multi handle must be reused so that the same pools and + * caches can be used. + * + * DEBUG: if 'events' is set TRUE, this function will use a replacement engine + * instead of curl_multi_perform() and use curl_multi_socket_action(). + */ +static CURLcode easy_perform(struct Curl_easy *data, bool events) +{ + struct Curl_multi *multi; + CURLMcode mresult; + CURLcode result = CURLE_OK; + struct Curl_sigpipe_ctx sigpipe_ctx; + + if(!data) + return CURLE_BAD_FUNCTION_ARGUMENT; + + if(data->set.errorbuffer) + /* clear this as early as possible */ + data->set.errorbuffer[0] = 0; + + data->state.os_errno = 0; + + if(data->multi) { + failf(data, "easy handle already used in multi handle"); + return CURLE_FAILED_INIT; + } + + /* if the handle has a connection still attached (it is/was a connect-only + handle) then disconnect before performing */ + if(data->conn) { + struct connectdata *c; + curl_socket_t s; + Curl_detach_connection(data); + s = Curl_getconnectinfo(data, &c); + if((s != CURL_SOCKET_BAD) && c) { + Curl_conn_terminate(data, c, TRUE); + } + DEBUGASSERT(!data->conn); + } + + if(data->multi_easy) + multi = data->multi_easy; + else { + /* this multi handle will only ever have a single easy handle attached to + it, so make it use minimal hash sizes */ + multi = Curl_multi_handle(16, 1, 3, 7, 3); + if(!multi) + return CURLE_OUT_OF_MEMORY; + } + + if(multi->in_callback) + return CURLE_RECURSIVE_API_CALL; + + /* Copy relevant easy options to the multi handle */ + curl_multi_setopt(multi, CURLMOPT_MAXCONNECTS, (long)data->set.maxconnects); + curl_multi_setopt(multi, CURLMOPT_QUICK_EXIT, (long)data->set.quick_exit); + + data->multi_easy = NULL; /* pretend it does not exist */ + mresult = curl_multi_add_handle(multi, data); + if(mresult) { + curl_multi_cleanup(multi); + if(mresult == CURLM_OUT_OF_MEMORY) + return CURLE_OUT_OF_MEMORY; + return CURLE_FAILED_INIT; + } + + /* assign this after curl_multi_add_handle() */ + data->multi_easy = multi; + + sigpipe_init(&sigpipe_ctx); + sigpipe_apply(data, &sigpipe_ctx); + + /* run the transfer */ + result = events ? easy_events(multi) : easy_transfer(multi); + + /* ignoring the return code is not nice, but atm we cannot really handle + a failure here, room for future improvement! */ + (void)curl_multi_remove_handle(multi, data); + + sigpipe_restore(&sigpipe_ctx); + + /* The multi handle is kept alive, owned by the easy handle */ + return result; +} + +/* + * curl_easy_perform() is the external interface that performs a blocking + * transfer as previously setup. + */ +CURLcode curl_easy_perform(CURL *curl) +{ + return easy_perform(curl, FALSE); +} + +#ifdef DEBUGBUILD +/* + * curl_easy_perform_ev() is the external interface that performs a blocking + * transfer using the event-based API internally. + */ +CURLcode curl_easy_perform_ev(struct Curl_easy *easy) +{ + return easy_perform(easy, TRUE); +} +#endif + +/* + * curl_easy_cleanup() is the external interface to cleaning/freeing the given + * easy handle. + */ +void curl_easy_cleanup(CURL *curl) +{ + struct Curl_easy *data = curl; + if(GOOD_EASY_HANDLE(data)) { + struct Curl_sigpipe_ctx sigpipe_ctx; + sigpipe_ignore(data, &sigpipe_ctx); + Curl_close(&data); + sigpipe_restore(&sigpipe_ctx); + } +} + +/* + * curl_easy_getinfo() is an external interface that allows an app to retrieve + * information from a performed transfer and similar. + */ +#undef curl_easy_getinfo +CURLcode curl_easy_getinfo(CURL *curl, CURLINFO info, ...) +{ + struct Curl_easy *data = curl; + va_list arg; + void *paramp; + CURLcode result; + + if(!GOOD_EASY_HANDLE(data)) + return CURLE_BAD_FUNCTION_ARGUMENT; + + va_start(arg, info); + paramp = va_arg(arg, void *); + + result = Curl_getinfo(data, info, paramp); + + va_end(arg); + return result; +} + +static CURLcode dupset(struct Curl_easy *dst, struct Curl_easy *src) +{ + CURLcode result = CURLE_OK; + enum dupstring i; + enum dupblob j; + + /* Copy src->set into dst->set first, then deal with the strings + afterwards */ + dst->set = src->set; +#if !defined(CURL_DISABLE_MIME) || !defined(CURL_DISABLE_FORM_API) + dst->set.mimepostp = NULL; +#endif + /* clear all dest string and blob pointers first, in case we error out + mid-function */ + memset(dst->set.str, 0, STRING_LAST * sizeof(char *)); + memset(dst->set.blobs, 0, BLOB_LAST * sizeof(struct curl_blob *)); + + /* duplicate all strings */ + for(i = (enum dupstring)0; i < STRING_LASTZEROTERMINATED; i++) { + result = Curl_setstropt(&dst->set.str[i], src->set.str[i]); + if(result) + return result; + } + + /* duplicate all blobs */ + for(j = (enum dupblob)0; j < BLOB_LAST; j++) { + result = Curl_setblobopt(&dst->set.blobs[j], src->set.blobs[j]); + if(result) + return result; + } + + /* duplicate memory areas pointed to */ + i = STRING_COPYPOSTFIELDS; + if(src->set.str[i]) { + if(src->set.postfieldsize == -1) + dst->set.str[i] = curlx_strdup(src->set.str[i]); + else + /* postfieldsize is curl_off_t, curlx_memdup() takes a size_t ... */ + dst->set.str[i] = curlx_memdup(src->set.str[i], + curlx_sotouz(src->set.postfieldsize)); + if(!dst->set.str[i]) + return CURLE_OUT_OF_MEMORY; + /* point to the new copy */ + dst->set.postfields = dst->set.str[i]; + } + +#if !defined(CURL_DISABLE_MIME) || !defined(CURL_DISABLE_FORM_API) + if(src->set.mimepostp) { + /* Duplicate mime data. Get a mimepost struct for the clone as well */ + dst->set.mimepostp = curlx_malloc(sizeof(*dst->set.mimepostp)); + if(!dst->set.mimepostp) + return CURLE_OUT_OF_MEMORY; + + Curl_mime_initpart(dst->set.mimepostp); + result = Curl_mime_duppart(dst, dst->set.mimepostp, src->set.mimepostp); + if(result) + return result; + } +#endif + + if(src->set.resolve) + dst->state.resolve = dst->set.resolve; + + return result; +} + +static void dupeasy_meta_freeentry(void *p) +{ + (void)p; + /* Always FALSE. Cannot use a 0 assert here since compilers + * are not in agreement if they then want a NORETURN attribute or + * not. *sigh* */ + DEBUGASSERT(!p); +} + +/* + * curl_easy_duphandle() is an external interface to allow duplication of a + * given input easy handle. The returned handle will be a new working handle + * with all options set exactly as the input source handle. + */ +CURL *curl_easy_duphandle(CURL *curl) +{ + struct Curl_easy *data = curl; + struct Curl_easy *outcurl = NULL; + + if(!GOOD_EASY_HANDLE(data)) + goto fail; + outcurl = curlx_calloc(1, sizeof(struct Curl_easy)); + if(!outcurl) + goto fail; + + /* + * We setup a few buffers we need. We should probably make them + * get setup on-demand in the code, as that would probably decrease + * the likeliness of us forgetting to init a buffer here in the future. + */ + outcurl->set.buffer_size = data->set.buffer_size; + + Curl_hash_init(&outcurl->meta_hash, 23, + Curl_hash_str, curlx_str_key_compare, dupeasy_meta_freeentry); + curlx_dyn_init(&outcurl->state.headerb, CURL_MAX_HTTP_HEADER); + Curl_bufref_init(&outcurl->state.url); + Curl_bufref_init(&outcurl->state.referer); + Curl_netrc_init(&outcurl->state.netrc); + + /* the connection pool is setup on demand */ + outcurl->state.lastconnect_id = -1; + outcurl->state.recent_conn_id = -1; + outcurl->id = -1; + outcurl->mid = UINT32_MAX; + outcurl->master_mid = UINT32_MAX; + +#ifndef CURL_DISABLE_HTTP + Curl_llist_init(&outcurl->state.httphdrs, NULL); +#endif + Curl_initinfo(outcurl); + + /* copy all userdefined values */ + if(dupset(outcurl, data)) + goto fail; + + outcurl->progress.hide = data->progress.hide; + outcurl->progress.callback = data->progress.callback; + +#ifndef CURL_DISABLE_COOKIES + outcurl->state.cookielist = NULL; + if(data->cookies && data->state.cookie_engine) { + /* If cookies are enabled in the parent handle, we enable them + in the clone as well! */ + outcurl->cookies = Curl_cookie_init(); + if(!outcurl->cookies) + goto fail; + outcurl->state.cookie_engine = TRUE; + } + + if(data->state.cookielist) { + outcurl->state.cookielist = Curl_slist_duplicate(data->state.cookielist); + if(!outcurl->state.cookielist) + goto fail; + } +#endif + + if(Curl_bufref_ptr(&data->state.url)) { + Curl_bufref_set(&outcurl->state.url, + Curl_bufref_dup(&data->state.url), 0, + curl_free); + if(!Curl_bufref_ptr(&outcurl->state.url)) + goto fail; + } + if(Curl_bufref_ptr(&data->state.referer)) { + Curl_bufref_set(&outcurl->state.referer, + Curl_bufref_dup(&data->state.referer), 0, + curl_free); + if(!Curl_bufref_ptr(&outcurl->state.referer)) + goto fail; + } + + /* Reinitialize an SSL engine for the new handle + * note: the engine name has already been copied by dupset */ + if(outcurl->set.str[STRING_SSL_ENGINE]) { + if(Curl_ssl_set_engine(outcurl, outcurl->set.str[STRING_SSL_ENGINE])) + goto fail; + } + +#ifndef CURL_DISABLE_ALTSVC + if(data->asi) { + outcurl->asi = Curl_altsvc_init(); + if(!outcurl->asi) + goto fail; + if(outcurl->set.str[STRING_ALTSVC]) + (void)Curl_altsvc_load(outcurl->asi, outcurl->set.str[STRING_ALTSVC]); + } +#endif +#ifndef CURL_DISABLE_HSTS + if(data->hsts) { + outcurl->hsts = Curl_hsts_init(); + if(!outcurl->hsts) + goto fail; + if(outcurl->set.str[STRING_HSTS]) + (void)Curl_hsts_loadfile(outcurl, + outcurl->hsts, outcurl->set.str[STRING_HSTS]); + (void)Curl_hsts_loadcb(outcurl, outcurl->hsts); + + /* Copy entries learned at runtime. (E.g. Strict-Transport-Security + headers.) */ + if(Curl_hsts_copy(outcurl->hsts, data->hsts)) + goto fail; + } +#endif + + outcurl->magic = CURLEASY_MAGIC_NUMBER; + + /* we reach this point and thus we are OK */ + + return outcurl; + +fail: + + if(outcurl) { +#ifndef CURL_DISABLE_COOKIES + curlx_free(outcurl->cookies); +#endif + curlx_dyn_free(&outcurl->state.headerb); + Curl_altsvc_cleanup(&outcurl->asi); + Curl_hsts_cleanup(&outcurl->hsts); + Curl_freeset(outcurl); + curlx_free(outcurl); + } + + return NULL; +} + +/* + * curl_easy_reset() is an external interface that allows an app to re- + * initialize a session handle to the default values. + */ +void curl_easy_reset(CURL *curl) +{ + struct Curl_easy *data = curl; + if(!GOOD_EASY_HANDLE(data)) + return; + + Curl_req_hard_reset(&data->req, data); + Curl_hash_clean(&data->meta_hash); + + /* clear all meta data */ + Curl_meta_reset(data); + /* zero out UserDefined data: */ + Curl_freeset(data); + memset(&data->set, 0, sizeof(struct UserDefined)); + Curl_init_userdefined(data); + + /* zero out Progress data: */ + memset(&data->progress, 0, sizeof(struct Progress)); + + /* zero out PureInfo data: */ + Curl_initinfo(data); + + data->progress.hide = TRUE; + data->state.current_speed = -1; /* init to negative == impossible */ + data->state.recent_conn_id = -1; /* clear remembered connection id */ + + /* zero out authentication data: */ + memset(&data->state.authhost, 0, sizeof(struct auth)); + memset(&data->state.authproxy, 0, sizeof(struct auth)); + +#if !defined(CURL_DISABLE_HTTP) && !defined(CURL_DISABLE_DIGEST_AUTH) + Curl_http_auth_cleanup_digest(data); +#endif + data->master_mid = UINT32_MAX; +} + +/* + * curl_easy_pause() allows an application to pause or unpause a specific + * transfer and direction. This function sets the full new state for the + * current connection this easy handle operates on. + * + * NOTE: if you have the receiving paused and you call this function to remove + * the pausing, you may get your write callback called at this point. + * + * Action is a bitmask consisting of CURLPAUSE_* bits in curl/curl.h + * + * NOTE: This is one of few API functions that are allowed to be called from + * within a callback. + */ +CURLcode curl_easy_pause(CURL *curl, int action) +{ + CURLcode result = CURLE_OK; + bool recursive = FALSE; + bool changed = FALSE; + struct Curl_easy *data = curl; + bool recv_paused, recv_paused_new; + bool send_paused, send_paused_new; + + if(!GOOD_EASY_HANDLE(data) || !data->conn) + /* crazy input, do not continue */ + return CURLE_BAD_FUNCTION_ARGUMENT; + + if(Curl_is_in_callback(data)) + recursive = TRUE; + + recv_paused = Curl_xfer_recv_is_paused(data); + recv_paused_new = (action & CURLPAUSE_RECV); + send_paused = Curl_xfer_send_is_paused(data); + send_paused_new = (action & CURLPAUSE_SEND); + + if((send_paused != send_paused_new) || + (send_paused_new != Curl_creader_is_paused(data))) { + changed = TRUE; + result = Curl_1st_fatal( + result, Curl_xfer_pause_send(data, send_paused_new)); + } + + if(recv_paused != recv_paused_new) { + changed = TRUE; + result = Curl_1st_fatal( + result, Curl_xfer_pause_recv(data, recv_paused_new)); + } + + /* If not completely pausing both directions now, run again in any case. */ + if(!Curl_xfer_is_blocked(data)) { + /* reset the too-slow time keeper */ + data->state.keeps_speed.tv_sec = 0; + if(data->multi) { + Curl_multi_mark_dirty(data); /* make it run */ + /* On changes, tell application to update its timers. */ + if(changed) { + if(Curl_update_timer(data->multi) && !result) + result = CURLE_ABORTED_BY_CALLBACK; + } + } + } + + if(!result && changed && !data->state.done && data->multi) + /* pause/unpausing may result in multi event changes */ + if(Curl_multi_ev_assess_xfer(data->multi, data) && !result) + result = CURLE_ABORTED_BY_CALLBACK; + + if(recursive) + /* this might have called a callback recursively which might have set this + to false again on exit */ + Curl_set_in_callback(data, TRUE); + + return result; +} + +static CURLcode easy_connection(struct Curl_easy *data, + struct connectdata **connp) +{ + curl_socket_t sfd; + + if(!data) + return CURLE_BAD_FUNCTION_ARGUMENT; + + /* only allow these to be called on handles with CURLOPT_CONNECT_ONLY */ + if(!data->set.connect_only) { + failf(data, "CONNECT_ONLY is required"); + return CURLE_UNSUPPORTED_PROTOCOL; + } + + sfd = Curl_getconnectinfo(data, connp); + + if(sfd == CURL_SOCKET_BAD) { + failf(data, "Failed to get recent socket"); + return CURLE_UNSUPPORTED_PROTOCOL; + } + + return CURLE_OK; +} + +/* + * Receives data from the connected socket. Use after successful + * curl_easy_perform() with CURLOPT_CONNECT_ONLY option. + * Returns CURLE_OK on success, error code on error. + */ +CURLcode curl_easy_recv(CURL *curl, void *buffer, size_t buflen, size_t *n) +{ + CURLcode result; + struct connectdata *c; + struct Curl_easy *data = curl; + + if(!GOOD_EASY_HANDLE(data)) + return CURLE_BAD_FUNCTION_ARGUMENT; + if(Curl_is_in_callback(data)) + return CURLE_RECURSIVE_API_CALL; + + result = easy_connection(data, &c); + if(result) + return result; + + if(!data->conn) + /* on first invoke, the transfer has been detached from the connection and + needs to be reattached */ + Curl_attach_connection(data, c); + + *n = 0; + return Curl_conn_recv(data, FIRSTSOCKET, buffer, buflen, n); +} + +#ifndef CURL_DISABLE_WEBSOCKETS +CURLcode Curl_connect_only_attach(struct Curl_easy *data) +{ + CURLcode result; + struct connectdata *c = NULL; + + result = easy_connection(data, &c); + if(result) + return result; + + if(!data->conn) + /* on first invoke, the transfer has been detached from the connection and + needs to be reattached */ + Curl_attach_connection(data, c); + + return CURLE_OK; +} +#endif /* !CURL_DISABLE_WEBSOCKETS */ + +/* + * Sends data over the connected socket. + * + * This is the private internal version of curl_easy_send() + */ +CURLcode Curl_senddata(struct Curl_easy *data, const void *buffer, + size_t buflen, size_t *n) +{ + CURLcode result; + struct connectdata *c = NULL; + struct Curl_sigpipe_ctx sigpipe_ctx; + + *n = 0; + result = easy_connection(data, &c); + if(result) + return result; + + if(!data->conn) + /* on first invoke, the transfer has been detached from the connection and + needs to be reattached */ + Curl_attach_connection(data, c); + + sigpipe_ignore(data, &sigpipe_ctx); + result = Curl_conn_send(data, FIRSTSOCKET, buffer, buflen, FALSE, n); + sigpipe_restore(&sigpipe_ctx); + + if(result && result != CURLE_AGAIN) + return CURLE_SEND_ERROR; + return result; +} + +/* + * Sends data over the connected socket. Use after successful + * curl_easy_perform() with CURLOPT_CONNECT_ONLY option. + */ +CURLcode curl_easy_send(CURL *curl, const void *buffer, size_t buflen, + size_t *n) +{ + size_t written = 0; + CURLcode result; + struct Curl_easy *data = curl; + if(!GOOD_EASY_HANDLE(data)) + return CURLE_BAD_FUNCTION_ARGUMENT; + if(Curl_is_in_callback(data)) + return CURLE_RECURSIVE_API_CALL; + + result = Curl_senddata(data, buffer, buflen, &written); + *n = written; + return result; +} + +/* + * Performs connection upkeep for the given session handle. + */ +CURLcode curl_easy_upkeep(CURL *curl) +{ + struct Curl_easy *data = curl; + /* Verify that we got an easy handle we can work with. */ + if(!GOOD_EASY_HANDLE(data)) + return CURLE_BAD_FUNCTION_ARGUMENT; + + if(Curl_is_in_callback(data)) + return CURLE_RECURSIVE_API_CALL; + + /* Use the common function to keep connections alive. */ + return Curl_cpool_upkeep(data); +} + +CURLcode curl_easy_ssls_import(CURL *curl, const char *session_key, + const unsigned char *shmac, size_t shmac_len, + const unsigned char *sdata, size_t sdata_len) +{ +#if defined(USE_SSL) && defined(USE_SSLS_EXPORT) + struct Curl_easy *data = curl; + if(!GOOD_EASY_HANDLE(data)) + return CURLE_BAD_FUNCTION_ARGUMENT; + if(Curl_is_in_callback(data) || Curl_ssl_scache_is_locked(data)) + return CURLE_RECURSIVE_API_CALL; + return Curl_ssl_session_import(data, session_key, + shmac, shmac_len, sdata, sdata_len); +#else + (void)curl; + (void)session_key; + (void)shmac; + (void)shmac_len; + (void)sdata; + (void)sdata_len; + return CURLE_NOT_BUILT_IN; +#endif +} + +CURLcode curl_easy_ssls_export(CURL *curl, + curl_ssls_export_cb *export_fn, + void *userptr) +{ +#if defined(USE_SSL) && defined(USE_SSLS_EXPORT) + struct Curl_easy *data = curl; + if(!GOOD_EASY_HANDLE(data)) + return CURLE_BAD_FUNCTION_ARGUMENT; + if(Curl_is_in_callback(data) || Curl_ssl_scache_is_locked(data)) + return CURLE_RECURSIVE_API_CALL; + return Curl_ssl_session_export(data, export_fn, userptr); +#else + (void)curl; + (void)export_fn; + (void)userptr; + return CURLE_NOT_BUILT_IN; +#endif +} + +CURLcode Curl_meta_set(struct Curl_easy *data, const char *key, + void *meta_data, Curl_meta_dtor *meta_dtor) +{ + DEBUGASSERT(meta_data); /* never set to NULL */ + if(!Curl_hash_add2(&data->meta_hash, CURL_UNCONST(key), strlen(key) + 1, + meta_data, meta_dtor)) { + meta_dtor(CURL_UNCONST(key), strlen(key) + 1, meta_data); + return CURLE_OUT_OF_MEMORY; + } + return CURLE_OK; +} + +void Curl_meta_remove(struct Curl_easy *data, const char *key) +{ + Curl_hash_delete(&data->meta_hash, CURL_UNCONST(key), strlen(key) + 1); +} + +void *Curl_meta_get(struct Curl_easy *data, const char *key) +{ + return Curl_hash_pick(&data->meta_hash, CURL_UNCONST(key), strlen(key) + 1); +} + +void Curl_meta_reset(struct Curl_easy *data) +{ + Curl_hash_clean(&data->meta_hash); +} diff --git a/3rdparty/curl-8.21.0/lib/easy_lock.h b/3rdparty/curl-8.21.0/lib/easy_lock.h new file mode 100644 index 0000000000..b8f916ff65 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/easy_lock.h @@ -0,0 +1,100 @@ +#ifndef HEADER_CURL_EASY_LOCK_H +#define HEADER_CURL_EASY_LOCK_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#define GLOBAL_INIT_IS_THREADSAFE + +#ifdef _WIN32 + +#define curl_simple_lock SRWLOCK +#define CURL_SIMPLE_LOCK_INIT SRWLOCK_INIT + +#define curl_simple_lock_lock(m) AcquireSRWLockExclusive(m) +#define curl_simple_lock_unlock(m) ReleaseSRWLockExclusive(m) + +#elif defined(HAVE_ATOMIC) && defined(HAVE_STDATOMIC_H) +#include +#ifdef HAVE_SCHED_YIELD +#include +#endif + +#define curl_simple_lock atomic_int +#define CURL_SIMPLE_LOCK_INIT 0 + +#ifndef __INTEL_COMPILER +/* The Intel compiler tries to look like GCC *and* clang *and* lies in its + __has_builtin() function, so override it. */ + +/* if GCC on i386/x86_64 or if the built-in is present */ +#if (defined(__GNUC__) && !defined(__clang__)) && \ + (defined(__i386__) || defined(__x86_64__)) +#define HAVE_BUILTIN_IA32_PAUSE +#elif defined(__has_builtin) /* Keep this PP check separate from others */ +#if __has_builtin(__builtin_ia32_pause) +#define HAVE_BUILTIN_IA32_PAUSE +#endif +#endif + +#endif /* !__INTEL_COMPILER */ + +static CURL_INLINE void curl_simple_lock_lock(curl_simple_lock *lock) +{ + for(;;) { + if(!atomic_exchange_explicit(lock, true, memory_order_acquire)) + break; + /* Reduce cache coherency traffic */ + while(atomic_load_explicit(lock, memory_order_relaxed)) { + /* Reduce load (not mandatory) */ +#ifdef HAVE_BUILTIN_IA32_PAUSE + __builtin_ia32_pause(); +#elif defined(__aarch64__) + __asm__ volatile("yield" ::: "memory"); +#elif defined(HAVE_SCHED_YIELD) + sched_yield(); +#endif + } + } +} + +static CURL_INLINE void curl_simple_lock_unlock(curl_simple_lock *lock) +{ + atomic_store_explicit(lock, false, memory_order_release); +} + +#elif defined(HAVE_THREADS_POSIX) + +#define curl_simple_lock pthread_mutex_t +#define CURL_SIMPLE_LOCK_INIT PTHREAD_MUTEX_INITIALIZER +#define curl_simple_lock_lock(m) pthread_mutex_lock(m) +#define curl_simple_lock_unlock(m) pthread_mutex_unlock(m) + +#else + +#undef GLOBAL_INIT_IS_THREADSAFE + +#endif + +#endif /* HEADER_CURL_EASY_LOCK_H */ diff --git a/3rdparty/curl-8.21.0/lib/easygetopt.c b/3rdparty/curl-8.21.0/lib/easygetopt.c new file mode 100644 index 0000000000..533d7e3670 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/easygetopt.c @@ -0,0 +1,97 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "easyoptions.h" + +#ifndef CURL_DISABLE_GETOPTIONS + +/* Lookups easy options at runtime */ +static const struct curl_easyoption *lookup(const char *name, CURLoption id) +{ + DEBUGASSERT(name || id); + DEBUGASSERT(!Curl_easyopts_check()); + if(name || id) { + const struct curl_easyoption *o = &Curl_easyopts[0]; + do { + if(name) { + if(curl_strequal(o->name, name)) + return o; + } + else { + if((o->id == id) && !(o->flags & CURLOT_FLAG_ALIAS)) + /* do not match alias options */ + return o; + } + o++; + } while(o->name); + } + return NULL; +} + +const struct curl_easyoption *curl_easy_option_by_name(const char *name) +{ + /* when name is used, the id argument is ignored */ + return lookup(name, CURLOPT_LASTENTRY); +} + +const struct curl_easyoption *curl_easy_option_by_id(CURLoption id) +{ + return lookup(NULL, id); +} + +/* Iterates over available options */ +const struct curl_easyoption *curl_easy_option_next( + const struct curl_easyoption *prev) +{ + if(prev && prev->name) { + prev++; + if(prev->name) + return prev; + } + else if(!prev) + return &Curl_easyopts[0]; + return NULL; +} + +#else +const struct curl_easyoption *curl_easy_option_by_name(const char *name) +{ + (void)name; + return NULL; +} + +const struct curl_easyoption *curl_easy_option_by_id(CURLoption id) +{ + (void)id; + return NULL; +} + +const struct curl_easyoption *curl_easy_option_next( + const struct curl_easyoption *prev) +{ + (void)prev; + return NULL; +} +#endif diff --git a/3rdparty/curl-8.21.0/lib/easyif.h b/3rdparty/curl-8.21.0/lib/easyif.h new file mode 100644 index 0000000000..213fd027da --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/easyif.h @@ -0,0 +1,40 @@ +#ifndef HEADER_CURL_EASYIF_H +#define HEADER_CURL_EASYIF_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +/* + * Prototypes for library-wide functions provided by easy.c + */ +CURLcode Curl_senddata(struct Curl_easy *data, const void *buffer, + size_t buflen, size_t *n); + +#ifndef CURL_DISABLE_WEBSOCKETS +CURLcode Curl_connect_only_attach(struct Curl_easy *data); +#endif + +#ifdef DEBUGBUILD +CURL_EXTERN CURLcode curl_easy_perform_ev(struct Curl_easy *easy); +#endif + +#endif /* HEADER_CURL_EASYIF_H */ diff --git a/3rdparty/curl-8.21.0/lib/easyoptions.c b/3rdparty/curl-8.21.0/lib/easyoptions.c new file mode 100644 index 0000000000..4c0b4f0ce4 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/easyoptions.c @@ -0,0 +1,390 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +/* This source code is generated by optiontable.pl - DO NOT EDIT BY HAND */ + +#include "curl_setup.h" + +#include "easyoptions.h" + +/* all easy setopt options listed in alphabetical order */ +const struct curl_easyoption Curl_easyopts[] = { + { "ABSTRACT_UNIX_SOCKET", CURLOPT_ABSTRACT_UNIX_SOCKET, CURLOT_STRING, 0 }, + { "ACCEPTTIMEOUT_MS", CURLOPT_ACCEPTTIMEOUT_MS, CURLOT_LONG, 0 }, + { "ACCEPT_ENCODING", CURLOPT_ACCEPT_ENCODING, CURLOT_STRING, 0 }, + { "ADDRESS_SCOPE", CURLOPT_ADDRESS_SCOPE, CURLOT_LONG, 0 }, + { "ALTSVC", CURLOPT_ALTSVC, CURLOT_STRING, 0 }, + { "ALTSVC_CTRL", CURLOPT_ALTSVC_CTRL, CURLOT_LONG, 0 }, + { "APPEND", CURLOPT_APPEND, CURLOT_LONG, 0 }, + { "AUTOREFERER", CURLOPT_AUTOREFERER, CURLOT_LONG, 0 }, + { "AWS_SIGV4", CURLOPT_AWS_SIGV4, CURLOT_STRING, 0 }, + { "BUFFERSIZE", CURLOPT_BUFFERSIZE, CURLOT_LONG, 0 }, + { "CAINFO", CURLOPT_CAINFO, CURLOT_STRING, 0 }, + { "CAINFO_BLOB", CURLOPT_CAINFO_BLOB, CURLOT_BLOB, 0 }, + { "CAPATH", CURLOPT_CAPATH, CURLOT_STRING, 0 }, + { "CA_CACHE_TIMEOUT", CURLOPT_CA_CACHE_TIMEOUT, CURLOT_LONG, 0 }, + { "CERTINFO", CURLOPT_CERTINFO, CURLOT_LONG, 0 }, + { "CHUNK_BGN_FUNCTION", CURLOPT_CHUNK_BGN_FUNCTION, CURLOT_FUNCTION, 0 }, + { "CHUNK_DATA", CURLOPT_CHUNK_DATA, CURLOT_CBPTR, 0 }, + { "CHUNK_END_FUNCTION", CURLOPT_CHUNK_END_FUNCTION, CURLOT_FUNCTION, 0 }, + { "CLOSESOCKETDATA", CURLOPT_CLOSESOCKETDATA, CURLOT_CBPTR, 0 }, + { "CLOSESOCKETFUNCTION", CURLOPT_CLOSESOCKETFUNCTION, CURLOT_FUNCTION, 0 }, + { "CONNECTTIMEOUT", CURLOPT_CONNECTTIMEOUT, CURLOT_LONG, 0 }, + { "CONNECTTIMEOUT_MS", CURLOPT_CONNECTTIMEOUT_MS, CURLOT_LONG, 0 }, + { "CONNECT_ONLY", CURLOPT_CONNECT_ONLY, CURLOT_LONG, 0 }, + { "CONNECT_TO", CURLOPT_CONNECT_TO, CURLOT_SLIST, 0 }, + { "CONV_FROM_NETWORK_FUNCTION", CURLOPT_CONV_FROM_NETWORK_FUNCTION, + CURLOT_FUNCTION, 0 }, + { "CONV_FROM_UTF8_FUNCTION", CURLOPT_CONV_FROM_UTF8_FUNCTION, + CURLOT_FUNCTION, 0 }, + { "CONV_TO_NETWORK_FUNCTION", CURLOPT_CONV_TO_NETWORK_FUNCTION, + CURLOT_FUNCTION, 0 }, + { "COOKIE", CURLOPT_COOKIE, CURLOT_STRING, 0 }, + { "COOKIEFILE", CURLOPT_COOKIEFILE, CURLOT_STRING, 0 }, + { "COOKIEJAR", CURLOPT_COOKIEJAR, CURLOT_STRING, 0 }, + { "COOKIELIST", CURLOPT_COOKIELIST, CURLOT_STRING, 0 }, + { "COOKIESESSION", CURLOPT_COOKIESESSION, CURLOT_LONG, 0 }, + { "COPYPOSTFIELDS", CURLOPT_COPYPOSTFIELDS, CURLOT_OBJECT, 0 }, + { "CRLF", CURLOPT_CRLF, CURLOT_LONG, 0 }, + { "CRLFILE", CURLOPT_CRLFILE, CURLOT_STRING, 0 }, + { "CURLU", CURLOPT_CURLU, CURLOT_OBJECT, 0 }, + { "CUSTOMREQUEST", CURLOPT_CUSTOMREQUEST, CURLOT_STRING, 0 }, + { "DEBUGDATA", CURLOPT_DEBUGDATA, CURLOT_CBPTR, 0 }, + { "DEBUGFUNCTION", CURLOPT_DEBUGFUNCTION, CURLOT_FUNCTION, 0 }, + { "DEFAULT_PROTOCOL", CURLOPT_DEFAULT_PROTOCOL, CURLOT_STRING, 0 }, + { "DIRLISTONLY", CURLOPT_DIRLISTONLY, CURLOT_LONG, 0 }, + { "DISALLOW_USERNAME_IN_URL", CURLOPT_DISALLOW_USERNAME_IN_URL, + CURLOT_LONG, 0 }, + { "DNS_CACHE_TIMEOUT", CURLOPT_DNS_CACHE_TIMEOUT, CURLOT_LONG, 0 }, + { "DNS_INTERFACE", CURLOPT_DNS_INTERFACE, CURLOT_STRING, 0 }, + { "DNS_LOCAL_IP4", CURLOPT_DNS_LOCAL_IP4, CURLOT_STRING, 0 }, + { "DNS_LOCAL_IP6", CURLOPT_DNS_LOCAL_IP6, CURLOT_STRING, 0 }, + { "DNS_SERVERS", CURLOPT_DNS_SERVERS, CURLOT_STRING, 0 }, + { "DNS_SHUFFLE_ADDRESSES", CURLOPT_DNS_SHUFFLE_ADDRESSES, CURLOT_LONG, 0 }, + { "DNS_USE_GLOBAL_CACHE", CURLOPT_DNS_USE_GLOBAL_CACHE, CURLOT_LONG, 0 }, + { "DOH_SSL_VERIFYHOST", CURLOPT_DOH_SSL_VERIFYHOST, CURLOT_LONG, 0 }, + { "DOH_SSL_VERIFYPEER", CURLOPT_DOH_SSL_VERIFYPEER, CURLOT_LONG, 0 }, + { "DOH_SSL_VERIFYSTATUS", CURLOPT_DOH_SSL_VERIFYSTATUS, CURLOT_LONG, 0 }, + { "DOH_URL", CURLOPT_DOH_URL, CURLOT_STRING, 0 }, + { "ECH", CURLOPT_ECH, CURLOT_STRING, 0 }, + { "EGDSOCKET", CURLOPT_EGDSOCKET, CURLOT_STRING, 0 }, + { "ENCODING", CURLOPT_ACCEPT_ENCODING, CURLOT_STRING, CURLOT_FLAG_ALIAS }, + { "ERRORBUFFER", CURLOPT_ERRORBUFFER, CURLOT_OBJECT, 0 }, + { "EXPECT_100_TIMEOUT_MS", CURLOPT_EXPECT_100_TIMEOUT_MS, CURLOT_LONG, 0 }, + { "FAILONERROR", CURLOPT_FAILONERROR, CURLOT_LONG, 0 }, + { "FILE", CURLOPT_WRITEDATA, CURLOT_CBPTR, CURLOT_FLAG_ALIAS }, + { "FILETIME", CURLOPT_FILETIME, CURLOT_LONG, 0 }, + { "FNMATCH_DATA", CURLOPT_FNMATCH_DATA, CURLOT_CBPTR, 0 }, + { "FNMATCH_FUNCTION", CURLOPT_FNMATCH_FUNCTION, CURLOT_FUNCTION, 0 }, + { "FOLLOWLOCATION", CURLOPT_FOLLOWLOCATION, CURLOT_LONG, 0 }, + { "FORBID_REUSE", CURLOPT_FORBID_REUSE, CURLOT_LONG, 0 }, + { "FRESH_CONNECT", CURLOPT_FRESH_CONNECT, CURLOT_LONG, 0 }, + { "FTPAPPEND", CURLOPT_APPEND, CURLOT_LONG, CURLOT_FLAG_ALIAS }, + { "FTPLISTONLY", CURLOPT_DIRLISTONLY, CURLOT_LONG, CURLOT_FLAG_ALIAS }, + { "FTPPORT", CURLOPT_FTPPORT, CURLOT_STRING, 0 }, + { "FTPSSLAUTH", CURLOPT_FTPSSLAUTH, CURLOT_VALUES, 0 }, + { "FTP_ACCOUNT", CURLOPT_FTP_ACCOUNT, CURLOT_STRING, 0 }, + { "FTP_ALTERNATIVE_TO_USER", CURLOPT_FTP_ALTERNATIVE_TO_USER, + CURLOT_STRING, 0 }, + { "FTP_CREATE_MISSING_DIRS", CURLOPT_FTP_CREATE_MISSING_DIRS, + CURLOT_LONG, 0 }, + { "FTP_FILEMETHOD", CURLOPT_FTP_FILEMETHOD, CURLOT_VALUES, 0 }, + { "FTP_RESPONSE_TIMEOUT", CURLOPT_SERVER_RESPONSE_TIMEOUT, + CURLOT_LONG, CURLOT_FLAG_ALIAS }, + { "FTP_SKIP_PASV_IP", CURLOPT_FTP_SKIP_PASV_IP, CURLOT_LONG, 0 }, + { "FTP_SSL", CURLOPT_USE_SSL, CURLOT_VALUES, CURLOT_FLAG_ALIAS }, + { "FTP_SSL_CCC", CURLOPT_FTP_SSL_CCC, CURLOT_LONG, 0 }, + { "FTP_USE_EPRT", CURLOPT_FTP_USE_EPRT, CURLOT_LONG, 0 }, + { "FTP_USE_EPSV", CURLOPT_FTP_USE_EPSV, CURLOT_LONG, 0 }, + { "FTP_USE_PRET", CURLOPT_FTP_USE_PRET, CURLOT_LONG, 0 }, + { "GSSAPI_DELEGATION", CURLOPT_GSSAPI_DELEGATION, CURLOT_VALUES, 0 }, + { "HAPPY_EYEBALLS_TIMEOUT_MS", CURLOPT_HAPPY_EYEBALLS_TIMEOUT_MS, + CURLOT_LONG, 0 }, + { "HAPROXYPROTOCOL", CURLOPT_HAPROXYPROTOCOL, CURLOT_LONG, 0 }, + { "HAPROXY_CLIENT_IP", CURLOPT_HAPROXY_CLIENT_IP, CURLOT_STRING, 0 }, + { "HEADER", CURLOPT_HEADER, CURLOT_LONG, 0 }, + { "HEADERDATA", CURLOPT_HEADERDATA, CURLOT_CBPTR, 0 }, + { "HEADERFUNCTION", CURLOPT_HEADERFUNCTION, CURLOT_FUNCTION, 0 }, + { "HEADEROPT", CURLOPT_HEADEROPT, CURLOT_VALUES, 0 }, + { "HSTS", CURLOPT_HSTS, CURLOT_STRING, 0 }, + { "HSTSREADDATA", CURLOPT_HSTSREADDATA, CURLOT_CBPTR, 0 }, + { "HSTSREADFUNCTION", CURLOPT_HSTSREADFUNCTION, CURLOT_FUNCTION, 0 }, + { "HSTSWRITEDATA", CURLOPT_HSTSWRITEDATA, CURLOT_CBPTR, 0 }, + { "HSTSWRITEFUNCTION", CURLOPT_HSTSWRITEFUNCTION, CURLOT_FUNCTION, 0 }, + { "HSTS_CTRL", CURLOPT_HSTS_CTRL, CURLOT_LONG, 0 }, + { "HTTP09_ALLOWED", CURLOPT_HTTP09_ALLOWED, CURLOT_LONG, 0 }, + { "HTTP200ALIASES", CURLOPT_HTTP200ALIASES, CURLOT_SLIST, 0 }, + { "HTTPAUTH", CURLOPT_HTTPAUTH, CURLOT_VALUES, 0 }, + { "HTTPGET", CURLOPT_HTTPGET, CURLOT_LONG, 0 }, + { "HTTPHEADER", CURLOPT_HTTPHEADER, CURLOT_SLIST, 0 }, + { "HTTPPOST", CURLOPT_HTTPPOST, CURLOT_OBJECT, 0 }, + { "HTTPPROXYTUNNEL", CURLOPT_HTTPPROXYTUNNEL, CURLOT_LONG, 0 }, + { "HTTP_CONTENT_DECODING", CURLOPT_HTTP_CONTENT_DECODING, CURLOT_LONG, 0 }, + { "HTTP_TRANSFER_DECODING", CURLOPT_HTTP_TRANSFER_DECODING, + CURLOT_LONG, 0 }, + { "HTTP_VERSION", CURLOPT_HTTP_VERSION, CURLOT_VALUES, 0 }, + { "IGNORE_CONTENT_LENGTH", CURLOPT_IGNORE_CONTENT_LENGTH, CURLOT_LONG, 0 }, + { "INFILE", CURLOPT_READDATA, CURLOT_CBPTR, CURLOT_FLAG_ALIAS }, + { "INFILESIZE", CURLOPT_INFILESIZE, CURLOT_LONG, 0 }, + { "INFILESIZE_LARGE", CURLOPT_INFILESIZE_LARGE, CURLOT_OFF_T, 0 }, + { "INTERFACE", CURLOPT_INTERFACE, CURLOT_STRING, 0 }, + { "INTERLEAVEDATA", CURLOPT_INTERLEAVEDATA, CURLOT_CBPTR, 0 }, + { "INTERLEAVEFUNCTION", CURLOPT_INTERLEAVEFUNCTION, CURLOT_FUNCTION, 0 }, + { "IOCTLDATA", CURLOPT_IOCTLDATA, CURLOT_CBPTR, 0 }, + { "IOCTLFUNCTION", CURLOPT_IOCTLFUNCTION, CURLOT_FUNCTION, 0 }, + { "IPRESOLVE", CURLOPT_IPRESOLVE, CURLOT_VALUES, 0 }, + { "ISSUERCERT", CURLOPT_ISSUERCERT, CURLOT_STRING, 0 }, + { "ISSUERCERT_BLOB", CURLOPT_ISSUERCERT_BLOB, CURLOT_BLOB, 0 }, + { "KEEP_SENDING_ON_ERROR", CURLOPT_KEEP_SENDING_ON_ERROR, CURLOT_LONG, 0 }, + { "KEYPASSWD", CURLOPT_KEYPASSWD, CURLOT_STRING, 0 }, + { "KRB4LEVEL", CURLOPT_KRBLEVEL, CURLOT_STRING, CURLOT_FLAG_ALIAS }, + { "KRBLEVEL", CURLOPT_KRBLEVEL, CURLOT_STRING, 0 }, + { "LOCALPORT", CURLOPT_LOCALPORT, CURLOT_LONG, 0 }, + { "LOCALPORTRANGE", CURLOPT_LOCALPORTRANGE, CURLOT_LONG, 0 }, + { "LOGIN_OPTIONS", CURLOPT_LOGIN_OPTIONS, CURLOT_STRING, 0 }, + { "LOW_SPEED_LIMIT", CURLOPT_LOW_SPEED_LIMIT, CURLOT_LONG, 0 }, + { "LOW_SPEED_TIME", CURLOPT_LOW_SPEED_TIME, CURLOT_LONG, 0 }, + { "MAIL_AUTH", CURLOPT_MAIL_AUTH, CURLOT_STRING, 0 }, + { "MAIL_FROM", CURLOPT_MAIL_FROM, CURLOT_STRING, 0 }, + { "MAIL_RCPT", CURLOPT_MAIL_RCPT, CURLOT_SLIST, 0 }, + { "MAIL_RCPT_ALLLOWFAILS", CURLOPT_MAIL_RCPT_ALLOWFAILS, + CURLOT_LONG, CURLOT_FLAG_ALIAS }, + { "MAIL_RCPT_ALLOWFAILS", CURLOPT_MAIL_RCPT_ALLOWFAILS, CURLOT_LONG, 0 }, + { "MAXAGE_CONN", CURLOPT_MAXAGE_CONN, CURLOT_LONG, 0 }, + { "MAXCONNECTS", CURLOPT_MAXCONNECTS, CURLOT_LONG, 0 }, + { "MAXFILESIZE", CURLOPT_MAXFILESIZE, CURLOT_LONG, 0 }, + { "MAXFILESIZE_LARGE", CURLOPT_MAXFILESIZE_LARGE, CURLOT_OFF_T, 0 }, + { "MAXLIFETIME_CONN", CURLOPT_MAXLIFETIME_CONN, CURLOT_LONG, 0 }, + { "MAXREDIRS", CURLOPT_MAXREDIRS, CURLOT_LONG, 0 }, + { "MAX_RECV_SPEED_LARGE", CURLOPT_MAX_RECV_SPEED_LARGE, CURLOT_OFF_T, 0 }, + { "MAX_SEND_SPEED_LARGE", CURLOPT_MAX_SEND_SPEED_LARGE, CURLOT_OFF_T, 0 }, + { "MIMEPOST", CURLOPT_MIMEPOST, CURLOT_OBJECT, 0 }, + { "MIME_OPTIONS", CURLOPT_MIME_OPTIONS, CURLOT_LONG, 0 }, + { "NETRC", CURLOPT_NETRC, CURLOT_VALUES, 0 }, + { "NETRC_FILE", CURLOPT_NETRC_FILE, CURLOT_STRING, 0 }, + { "NEW_DIRECTORY_PERMS", CURLOPT_NEW_DIRECTORY_PERMS, CURLOT_LONG, 0 }, + { "NEW_FILE_PERMS", CURLOPT_NEW_FILE_PERMS, CURLOT_LONG, 0 }, + { "NOBODY", CURLOPT_NOBODY, CURLOT_LONG, 0 }, + { "NOPROGRESS", CURLOPT_NOPROGRESS, CURLOT_LONG, 0 }, + { "NOPROXY", CURLOPT_NOPROXY, CURLOT_STRING, 0 }, + { "NOSIGNAL", CURLOPT_NOSIGNAL, CURLOT_LONG, 0 }, + { "OPENSOCKETDATA", CURLOPT_OPENSOCKETDATA, CURLOT_CBPTR, 0 }, + { "OPENSOCKETFUNCTION", CURLOPT_OPENSOCKETFUNCTION, CURLOT_FUNCTION, 0 }, + { "PASSWORD", CURLOPT_PASSWORD, CURLOT_STRING, 0 }, + { "PATH_AS_IS", CURLOPT_PATH_AS_IS, CURLOT_LONG, 0 }, + { "PINNEDPUBLICKEY", CURLOPT_PINNEDPUBLICKEY, CURLOT_STRING, 0 }, + { "PIPEWAIT", CURLOPT_PIPEWAIT, CURLOT_LONG, 0 }, + { "PORT", CURLOPT_PORT, CURLOT_LONG, 0 }, + { "POST", CURLOPT_POST, CURLOT_LONG, 0 }, + { "POST301", CURLOPT_POSTREDIR, CURLOT_VALUES, CURLOT_FLAG_ALIAS }, + { "POSTFIELDS", CURLOPT_POSTFIELDS, CURLOT_OBJECT, 0 }, + { "POSTFIELDSIZE", CURLOPT_POSTFIELDSIZE, CURLOT_LONG, 0 }, + { "POSTFIELDSIZE_LARGE", CURLOPT_POSTFIELDSIZE_LARGE, CURLOT_OFF_T, 0 }, + { "POSTQUOTE", CURLOPT_POSTQUOTE, CURLOT_SLIST, 0 }, + { "POSTREDIR", CURLOPT_POSTREDIR, CURLOT_VALUES, 0 }, + { "PREQUOTE", CURLOPT_PREQUOTE, CURLOT_SLIST, 0 }, + { "PREREQDATA", CURLOPT_PREREQDATA, CURLOT_CBPTR, 0 }, + { "PREREQFUNCTION", CURLOPT_PREREQFUNCTION, CURLOT_FUNCTION, 0 }, + { "PRE_PROXY", CURLOPT_PRE_PROXY, CURLOT_STRING, 0 }, + { "PRIVATE", CURLOPT_PRIVATE, CURLOT_OBJECT, 0 }, + { "PROGRESSDATA", CURLOPT_XFERINFODATA, CURLOT_CBPTR, CURLOT_FLAG_ALIAS }, + { "PROGRESSFUNCTION", CURLOPT_PROGRESSFUNCTION, CURLOT_FUNCTION, 0 }, + { "PROTOCOLS", CURLOPT_PROTOCOLS, CURLOT_LONG, 0 }, + { "PROTOCOLS_STR", CURLOPT_PROTOCOLS_STR, CURLOT_STRING, 0 }, + { "PROXY", CURLOPT_PROXY, CURLOT_STRING, 0 }, + { "PROXYAUTH", CURLOPT_PROXYAUTH, CURLOT_VALUES, 0 }, + { "PROXYHEADER", CURLOPT_PROXYHEADER, CURLOT_SLIST, 0 }, + { "PROXYPASSWORD", CURLOPT_PROXYPASSWORD, CURLOT_STRING, 0 }, + { "PROXYPORT", CURLOPT_PROXYPORT, CURLOT_LONG, 0 }, + { "PROXYTYPE", CURLOPT_PROXYTYPE, CURLOT_VALUES, 0 }, + { "PROXYUSERNAME", CURLOPT_PROXYUSERNAME, CURLOT_STRING, 0 }, + { "PROXYUSERPWD", CURLOPT_PROXYUSERPWD, CURLOT_STRING, 0 }, + { "PROXY_CAINFO", CURLOPT_PROXY_CAINFO, CURLOT_STRING, 0 }, + { "PROXY_CAINFO_BLOB", CURLOPT_PROXY_CAINFO_BLOB, CURLOT_BLOB, 0 }, + { "PROXY_CAPATH", CURLOPT_PROXY_CAPATH, CURLOT_STRING, 0 }, + { "PROXY_CRLFILE", CURLOPT_PROXY_CRLFILE, CURLOT_STRING, 0 }, + { "PROXY_ISSUERCERT", CURLOPT_PROXY_ISSUERCERT, CURLOT_STRING, 0 }, + { "PROXY_ISSUERCERT_BLOB", CURLOPT_PROXY_ISSUERCERT_BLOB, CURLOT_BLOB, 0 }, + { "PROXY_KEYPASSWD", CURLOPT_PROXY_KEYPASSWD, CURLOT_STRING, 0 }, + { "PROXY_PINNEDPUBLICKEY", CURLOPT_PROXY_PINNEDPUBLICKEY, + CURLOT_STRING, 0 }, + { "PROXY_SERVICE_NAME", CURLOPT_PROXY_SERVICE_NAME, CURLOT_STRING, 0 }, + { "PROXY_SSLCERT", CURLOPT_PROXY_SSLCERT, CURLOT_STRING, 0 }, + { "PROXY_SSLCERTTYPE", CURLOPT_PROXY_SSLCERTTYPE, CURLOT_STRING, 0 }, + { "PROXY_SSLCERT_BLOB", CURLOPT_PROXY_SSLCERT_BLOB, CURLOT_BLOB, 0 }, + { "PROXY_SSLKEY", CURLOPT_PROXY_SSLKEY, CURLOT_STRING, 0 }, + { "PROXY_SSLKEYTYPE", CURLOPT_PROXY_SSLKEYTYPE, CURLOT_STRING, 0 }, + { "PROXY_SSLKEY_BLOB", CURLOPT_PROXY_SSLKEY_BLOB, CURLOT_BLOB, 0 }, + { "PROXY_SSLVERSION", CURLOPT_PROXY_SSLVERSION, CURLOT_VALUES, 0 }, + { "PROXY_SSL_CIPHER_LIST", CURLOPT_PROXY_SSL_CIPHER_LIST, + CURLOT_STRING, 0 }, + { "PROXY_SSL_OPTIONS", CURLOPT_PROXY_SSL_OPTIONS, CURLOT_LONG, 0 }, + { "PROXY_SSL_VERIFYHOST", CURLOPT_PROXY_SSL_VERIFYHOST, CURLOT_LONG, 0 }, + { "PROXY_SSL_VERIFYPEER", CURLOPT_PROXY_SSL_VERIFYPEER, CURLOT_LONG, 0 }, + { "PROXY_TLS13_CIPHERS", CURLOPT_PROXY_TLS13_CIPHERS, CURLOT_STRING, 0 }, + { "PROXY_TLSAUTH_PASSWORD", CURLOPT_PROXY_TLSAUTH_PASSWORD, + CURLOT_STRING, 0 }, + { "PROXY_TLSAUTH_TYPE", CURLOPT_PROXY_TLSAUTH_TYPE, CURLOT_STRING, 0 }, + { "PROXY_TLSAUTH_USERNAME", CURLOPT_PROXY_TLSAUTH_USERNAME, + CURLOT_STRING, 0 }, + { "PROXY_TRANSFER_MODE", CURLOPT_PROXY_TRANSFER_MODE, CURLOT_LONG, 0 }, + { "PUT", CURLOPT_PUT, CURLOT_LONG, 0 }, + { "QUICK_EXIT", CURLOPT_QUICK_EXIT, CURLOT_LONG, 0 }, + { "QUOTE", CURLOPT_QUOTE, CURLOT_SLIST, 0 }, + { "RANDOM_FILE", CURLOPT_RANDOM_FILE, CURLOT_STRING, 0 }, + { "RANGE", CURLOPT_RANGE, CURLOT_STRING, 0 }, + { "READDATA", CURLOPT_READDATA, CURLOT_CBPTR, 0 }, + { "READFUNCTION", CURLOPT_READFUNCTION, CURLOT_FUNCTION, 0 }, + { "REDIR_PROTOCOLS", CURLOPT_REDIR_PROTOCOLS, CURLOT_LONG, 0 }, + { "REDIR_PROTOCOLS_STR", CURLOPT_REDIR_PROTOCOLS_STR, CURLOT_STRING, 0 }, + { "REFERER", CURLOPT_REFERER, CURLOT_STRING, 0 }, + { "REQUEST_TARGET", CURLOPT_REQUEST_TARGET, CURLOT_STRING, 0 }, + { "RESOLVE", CURLOPT_RESOLVE, CURLOT_SLIST, 0 }, + { "RESOLVER_START_DATA", CURLOPT_RESOLVER_START_DATA, CURLOT_CBPTR, 0 }, + { "RESOLVER_START_FUNCTION", CURLOPT_RESOLVER_START_FUNCTION, + CURLOT_FUNCTION, 0 }, + { "RESUME_FROM", CURLOPT_RESUME_FROM, CURLOT_LONG, 0 }, + { "RESUME_FROM_LARGE", CURLOPT_RESUME_FROM_LARGE, CURLOT_OFF_T, 0 }, + { "RTSPHEADER", CURLOPT_HTTPHEADER, CURLOT_SLIST, CURLOT_FLAG_ALIAS }, + { "RTSP_CLIENT_CSEQ", CURLOPT_RTSP_CLIENT_CSEQ, CURLOT_LONG, 0 }, + { "RTSP_REQUEST", CURLOPT_RTSP_REQUEST, CURLOT_VALUES, 0 }, + { "RTSP_SERVER_CSEQ", CURLOPT_RTSP_SERVER_CSEQ, CURLOT_LONG, 0 }, + { "RTSP_SESSION_ID", CURLOPT_RTSP_SESSION_ID, CURLOT_STRING, 0 }, + { "RTSP_STREAM_URI", CURLOPT_RTSP_STREAM_URI, CURLOT_STRING, 0 }, + { "RTSP_TRANSPORT", CURLOPT_RTSP_TRANSPORT, CURLOT_STRING, 0 }, + { "SASL_AUTHZID", CURLOPT_SASL_AUTHZID, CURLOT_STRING, 0 }, + { "SASL_IR", CURLOPT_SASL_IR, CURLOT_LONG, 0 }, + { "SEEKDATA", CURLOPT_SEEKDATA, CURLOT_CBPTR, 0 }, + { "SEEKFUNCTION", CURLOPT_SEEKFUNCTION, CURLOT_FUNCTION, 0 }, + { "SERVER_RESPONSE_TIMEOUT", CURLOPT_SERVER_RESPONSE_TIMEOUT, + CURLOT_LONG, 0 }, + { "SERVER_RESPONSE_TIMEOUT_MS", CURLOPT_SERVER_RESPONSE_TIMEOUT_MS, + CURLOT_LONG, 0 }, + { "SERVICE_NAME", CURLOPT_SERVICE_NAME, CURLOT_STRING, 0 }, + { "SHARE", CURLOPT_SHARE, CURLOT_OBJECT, 0 }, + { "SOCKOPTDATA", CURLOPT_SOCKOPTDATA, CURLOT_CBPTR, 0 }, + { "SOCKOPTFUNCTION", CURLOPT_SOCKOPTFUNCTION, CURLOT_FUNCTION, 0 }, + { "SOCKS5_AUTH", CURLOPT_SOCKS5_AUTH, CURLOT_LONG, 0 }, + { "SOCKS5_GSSAPI_NEC", CURLOPT_SOCKS5_GSSAPI_NEC, CURLOT_LONG, 0 }, + { "SOCKS5_GSSAPI_SERVICE", CURLOPT_SOCKS5_GSSAPI_SERVICE, + CURLOT_STRING, 0 }, + { "SSH_AUTH_TYPES", CURLOPT_SSH_AUTH_TYPES, CURLOT_VALUES, 0 }, + { "SSH_COMPRESSION", CURLOPT_SSH_COMPRESSION, CURLOT_LONG, 0 }, + { "SSH_HOSTKEYDATA", CURLOPT_SSH_HOSTKEYDATA, CURLOT_CBPTR, 0 }, + { "SSH_HOSTKEYFUNCTION", CURLOPT_SSH_HOSTKEYFUNCTION, CURLOT_FUNCTION, 0 }, + { "SSH_HOST_PUBLIC_KEY_MD5", CURLOPT_SSH_HOST_PUBLIC_KEY_MD5, + CURLOT_STRING, 0 }, + { "SSH_HOST_PUBLIC_KEY_SHA256", CURLOPT_SSH_HOST_PUBLIC_KEY_SHA256, + CURLOT_STRING, 0 }, + { "SSH_KEYDATA", CURLOPT_SSH_KEYDATA, CURLOT_CBPTR, 0 }, + { "SSH_KEYFUNCTION", CURLOPT_SSH_KEYFUNCTION, CURLOT_FUNCTION, 0 }, + { "SSH_KNOWNHOSTS", CURLOPT_SSH_KNOWNHOSTS, CURLOT_STRING, 0 }, + { "SSH_PRIVATE_KEYFILE", CURLOPT_SSH_PRIVATE_KEYFILE, CURLOT_STRING, 0 }, + { "SSH_PUBLIC_KEYFILE", CURLOPT_SSH_PUBLIC_KEYFILE, CURLOT_STRING, 0 }, + { "SSLCERT", CURLOPT_SSLCERT, CURLOT_STRING, 0 }, + { "SSLCERTPASSWD", CURLOPT_KEYPASSWD, CURLOT_STRING, CURLOT_FLAG_ALIAS }, + { "SSLCERTTYPE", CURLOPT_SSLCERTTYPE, CURLOT_STRING, 0 }, + { "SSLCERT_BLOB", CURLOPT_SSLCERT_BLOB, CURLOT_BLOB, 0 }, + { "SSLENGINE", CURLOPT_SSLENGINE, CURLOT_STRING, 0 }, + { "SSLENGINE_DEFAULT", CURLOPT_SSLENGINE_DEFAULT, CURLOT_LONG, 0 }, + { "SSLKEY", CURLOPT_SSLKEY, CURLOT_STRING, 0 }, + { "SSLKEYPASSWD", CURLOPT_KEYPASSWD, CURLOT_STRING, CURLOT_FLAG_ALIAS }, + { "SSLKEYTYPE", CURLOPT_SSLKEYTYPE, CURLOT_STRING, 0 }, + { "SSLKEY_BLOB", CURLOPT_SSLKEY_BLOB, CURLOT_BLOB, 0 }, + { "SSLVERSION", CURLOPT_SSLVERSION, CURLOT_VALUES, 0 }, + { "SSL_CIPHER_LIST", CURLOPT_SSL_CIPHER_LIST, CURLOT_STRING, 0 }, + { "SSL_CTX_DATA", CURLOPT_SSL_CTX_DATA, CURLOT_CBPTR, 0 }, + { "SSL_CTX_FUNCTION", CURLOPT_SSL_CTX_FUNCTION, CURLOT_FUNCTION, 0 }, + { "SSL_EC_CURVES", CURLOPT_SSL_EC_CURVES, CURLOT_STRING, 0 }, + { "SSL_ENABLE_ALPN", CURLOPT_SSL_ENABLE_ALPN, CURLOT_LONG, 0 }, + { "SSL_ENABLE_NPN", CURLOPT_SSL_ENABLE_NPN, CURLOT_LONG, 0 }, + { "SSL_FALSESTART", CURLOPT_SSL_FALSESTART, CURLOT_LONG, 0 }, + { "SSL_OPTIONS", CURLOPT_SSL_OPTIONS, CURLOT_VALUES, 0 }, + { "SSL_SESSIONID_CACHE", CURLOPT_SSL_SESSIONID_CACHE, CURLOT_LONG, 0 }, + { "SSL_SIGNATURE_ALGORITHMS", CURLOPT_SSL_SIGNATURE_ALGORITHMS, + CURLOT_STRING, 0 }, + { "SSL_VERIFYHOST", CURLOPT_SSL_VERIFYHOST, CURLOT_LONG, 0 }, + { "SSL_VERIFYPEER", CURLOPT_SSL_VERIFYPEER, CURLOT_LONG, 0 }, + { "SSL_VERIFYSTATUS", CURLOPT_SSL_VERIFYSTATUS, CURLOT_LONG, 0 }, + { "STDERR", CURLOPT_STDERR, CURLOT_OBJECT, 0 }, + { "STREAM_DEPENDS", CURLOPT_STREAM_DEPENDS, CURLOT_OBJECT, 0 }, + { "STREAM_DEPENDS_E", CURLOPT_STREAM_DEPENDS_E, CURLOT_OBJECT, 0 }, + { "STREAM_WEIGHT", CURLOPT_STREAM_WEIGHT, CURLOT_LONG, 0 }, + { "SUPPRESS_CONNECT_HEADERS", CURLOPT_SUPPRESS_CONNECT_HEADERS, + CURLOT_LONG, 0 }, + { "TCP_FASTOPEN", CURLOPT_TCP_FASTOPEN, CURLOT_LONG, 0 }, + { "TCP_KEEPALIVE", CURLOPT_TCP_KEEPALIVE, CURLOT_LONG, 0 }, + { "TCP_KEEPCNT", CURLOPT_TCP_KEEPCNT, CURLOT_LONG, 0 }, + { "TCP_KEEPIDLE", CURLOPT_TCP_KEEPIDLE, CURLOT_LONG, 0 }, + { "TCP_KEEPINTVL", CURLOPT_TCP_KEEPINTVL, CURLOT_LONG, 0 }, + { "TCP_NODELAY", CURLOPT_TCP_NODELAY, CURLOT_LONG, 0 }, + { "TELNETOPTIONS", CURLOPT_TELNETOPTIONS, CURLOT_SLIST, 0 }, + { "TFTP_BLKSIZE", CURLOPT_TFTP_BLKSIZE, CURLOT_LONG, 0 }, + { "TFTP_NO_OPTIONS", CURLOPT_TFTP_NO_OPTIONS, CURLOT_LONG, 0 }, + { "TIMECONDITION", CURLOPT_TIMECONDITION, CURLOT_VALUES, 0 }, + { "TIMEOUT", CURLOPT_TIMEOUT, CURLOT_LONG, 0 }, + { "TIMEOUT_MS", CURLOPT_TIMEOUT_MS, CURLOT_LONG, 0 }, + { "TIMEVALUE", CURLOPT_TIMEVALUE, CURLOT_LONG, 0 }, + { "TIMEVALUE_LARGE", CURLOPT_TIMEVALUE_LARGE, CURLOT_OFF_T, 0 }, + { "TLS13_CIPHERS", CURLOPT_TLS13_CIPHERS, CURLOT_STRING, 0 }, + { "TLSAUTH_PASSWORD", CURLOPT_TLSAUTH_PASSWORD, CURLOT_STRING, 0 }, + { "TLSAUTH_TYPE", CURLOPT_TLSAUTH_TYPE, CURLOT_STRING, 0 }, + { "TLSAUTH_USERNAME", CURLOPT_TLSAUTH_USERNAME, CURLOT_STRING, 0 }, + { "TRAILERDATA", CURLOPT_TRAILERDATA, CURLOT_CBPTR, 0 }, + { "TRAILERFUNCTION", CURLOPT_TRAILERFUNCTION, CURLOT_FUNCTION, 0 }, + { "TRANSFERTEXT", CURLOPT_TRANSFERTEXT, CURLOT_LONG, 0 }, + { "TRANSFER_ENCODING", CURLOPT_TRANSFER_ENCODING, CURLOT_LONG, 0 }, + { "UNIX_SOCKET_PATH", CURLOPT_UNIX_SOCKET_PATH, CURLOT_STRING, 0 }, + { "UNRESTRICTED_AUTH", CURLOPT_UNRESTRICTED_AUTH, CURLOT_LONG, 0 }, + { "UPKEEP_INTERVAL_MS", CURLOPT_UPKEEP_INTERVAL_MS, CURLOT_LONG, 0 }, + { "UPLOAD", CURLOPT_UPLOAD, CURLOT_LONG, 0 }, + { "UPLOAD_BUFFERSIZE", CURLOPT_UPLOAD_BUFFERSIZE, CURLOT_LONG, 0 }, + { "UPLOAD_FLAGS", CURLOPT_UPLOAD_FLAGS, CURLOT_LONG, 0 }, + { "URL", CURLOPT_URL, CURLOT_STRING, 0 }, + { "USERAGENT", CURLOPT_USERAGENT, CURLOT_STRING, 0 }, + { "USERNAME", CURLOPT_USERNAME, CURLOT_STRING, 0 }, + { "USERPWD", CURLOPT_USERPWD, CURLOT_STRING, 0 }, + { "USE_SSL", CURLOPT_USE_SSL, CURLOT_VALUES, 0 }, + { "VERBOSE", CURLOPT_VERBOSE, CURLOT_LONG, 0 }, + { "WILDCARDMATCH", CURLOPT_WILDCARDMATCH, CURLOT_LONG, 0 }, + { "WRITEDATA", CURLOPT_WRITEDATA, CURLOT_CBPTR, 0 }, + { "WRITEFUNCTION", CURLOPT_WRITEFUNCTION, CURLOT_FUNCTION, 0 }, + { "WRITEHEADER", CURLOPT_HEADERDATA, CURLOT_CBPTR, CURLOT_FLAG_ALIAS }, + { "WS_OPTIONS", CURLOPT_WS_OPTIONS, CURLOT_LONG, 0 }, + { "XFERINFODATA", CURLOPT_XFERINFODATA, CURLOT_CBPTR, 0 }, + { "XFERINFOFUNCTION", CURLOPT_XFERINFOFUNCTION, CURLOT_FUNCTION, 0 }, + { "XOAUTH2_BEARER", CURLOPT_XOAUTH2_BEARER, CURLOT_STRING, 0 }, + { NULL, CURLOPT_LASTENTRY, CURLOT_LONG, 0 } /* end of table */ +}; + +#ifdef DEBUGBUILD +/* + * Curl_easyopts_check() is a debug-only function that returns non-zero + * if this source file is not in sync with the options listed in curl/curl.h + */ +int Curl_easyopts_check(void) +{ + return (CURLOPT_LASTENTRY % 10000) != (328 + 1); +} +#endif diff --git a/3rdparty/curl-8.21.0/lib/easyoptions.h b/3rdparty/curl-8.21.0/lib/easyoptions.h new file mode 100644 index 0000000000..d895653ce9 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/easyoptions.h @@ -0,0 +1,35 @@ +#ifndef HEADER_CURL_EASYOPTIONS_H +#define HEADER_CURL_EASYOPTIONS_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +/* should probably go into the public header */ + +/* generated table with all easy options */ +extern const struct curl_easyoption Curl_easyopts[]; + +#ifdef DEBUGBUILD +int Curl_easyopts_check(void); +#endif + +#endif /* HEADER_CURL_EASYOPTIONS_H */ diff --git a/3rdparty/curl-8.21.0/lib/escape.c b/3rdparty/curl-8.21.0/lib/escape.c new file mode 100644 index 0000000000..4aff583de1 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/escape.c @@ -0,0 +1,228 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +/* Escape and unescape URL encoding in strings. The functions return a new + * allocated string or NULL if an error occurred. */ +#include "curl_setup.h" + +struct Curl_easy; + +#include "urldata.h" +#include "escape.h" +#include "curlx/strparse.h" +#include "curl_printf.h" + +/* for ABI-compatibility with previous versions */ +char *curl_escape(const char *string, int length) +{ + return curl_easy_escape(NULL, string, length); +} + +/* for ABI-compatibility with previous versions */ +char *curl_unescape(const char *string, int length) +{ + return curl_easy_unescape(NULL, string, length, NULL); +} + +/* Escapes for URL the given unescaped string of given length. + * 'data' is ignored since 7.82.0. + */ +char *curl_easy_escape(CURL *curl, const char *string, int length) +{ + size_t len; + struct dynbuf d; + (void)curl; + + if(!string || (length < 0)) + return NULL; + + len = (length ? (size_t)length : strlen(string)); + if(!len) + return curlx_strdup(""); + + if(len > SIZE_MAX / 16) + return NULL; + + curlx_dyn_init(&d, (len * 3) + 1); + + while(len--) { + /* treat the characters unsigned */ + unsigned char in = (unsigned char)*string++; + + if(ISUNRESERVED(in)) { + /* append this */ + if(curlx_dyn_addn(&d, &in, 1)) + return NULL; + } + else { + /* encode it */ + unsigned char out[3] = { '%' }; + Curl_hexbyte(&out[1], in); + if(curlx_dyn_addn(&d, out, 3)) + return NULL; + } + } + + return curlx_dyn_ptr(&d); +} + +/* + * Curl_urldecode() URL decodes the given string. + * + * Returns a pointer to a malloced string in *ostring with length given in + * *olen. If length == 0, the length is assumed to be strlen(string). + * + * ctrl options: + * - REJECT_NADA: accept everything + * - REJECT_CTRL: rejects control characters (byte codes lower than 32) in + * the data + * - REJECT_ZERO: rejects decoded zero bytes + * + * The values for the enum starts at 2, to make the assert detect legacy + * invokes that used TRUE/FALSE (0 and 1). + */ + +CURLcode Curl_urldecode(const char *string, size_t length, + char **ostring, size_t *olen, + enum urlreject ctrl) +{ + size_t alloc; + char *ns; + + DEBUGASSERT(string); + DEBUGASSERT(ctrl >= REJECT_NADA); /* crash on TRUE/FALSE */ + + alloc = (length ? length : strlen(string)); + ns = curlx_malloc(alloc + 1); + + if(!ns) + return CURLE_OUT_OF_MEMORY; + + /* store output string */ + *ostring = ns; + + while(alloc) { + unsigned char in = (unsigned char)*string; + if(('%' == in) && (alloc > 2) && + ISXDIGIT(string[1]) && ISXDIGIT(string[2])) { + /* this is two hexadecimal digits following a '%' */ + in = (unsigned char)((curlx_hexval(string[1]) << 4) | + curlx_hexval(string[2])); + string += 3; + alloc -= 3; + } + else { + string++; + alloc--; + } + + if(((ctrl == REJECT_CTRL) && (in < 0x20)) || + ((ctrl == REJECT_ZERO) && (in == 0))) { + curlx_safefree(*ostring); + return CURLE_URL_MALFORMAT; + } + + *ns++ = (char)in; + } + *ns = 0; /* terminate it */ + + if(olen) + /* store output size */ + *olen = ns - *ostring; + + return CURLE_OK; +} + +/* + * Unescapes the given URL escaped string of given length. Returns a + * pointer to a malloced string with length given in *olen. + * If length == 0, the length is assumed to be strlen(string). + * If olen == NULL, no output length is stored. + * 'data' is ignored since 7.82.0. + */ +char *curl_easy_unescape(CURL *curl, const char *string, int inlength, + int *outlength) +{ + char *str = NULL; + (void)curl; + if(string && (inlength >= 0)) { + size_t inputlen = (size_t)inlength; + size_t outputlen; + CURLcode res = Curl_urldecode(string, inputlen, &str, &outputlen, + REJECT_NADA); + if(res) + return NULL; + + if(outlength) { + if(outputlen <= (size_t)INT_MAX) + *outlength = curlx_uztosi(outputlen); + else + /* too large to return in an int, fail! */ + curlx_safefree(str); + } + } + return str; +} + +/* For operating systems/environments that use different malloc/free + systems for the app and for this library, we provide a free that uses + the library's memory system */ +void curl_free(void *p) +{ + curlx_free(p); +} + +/* + * Curl_hexencode() + * + * Converts binary input to lowercase hex-encoded ASCII output. + * Null-terminated. + */ +void Curl_hexencode(const unsigned char *src, size_t len, /* input length */ + unsigned char *out, size_t olen) /* output buffer size */ +{ + DEBUGASSERT(src && len && (olen >= 3)); + if(src && len && (olen >= 3)) { + while(len-- && (olen >= 3)) { + out[0] = Curl_ldigits[*src >> 4]; + out[1] = Curl_ldigits[*src & 0x0F]; + ++src; + out += 2; + olen -= 2; + } + *out = 0; + } + else if(olen) + *out = 0; +} + +/* Curl_hexbyte + * + * Output a single unsigned char as a two-digit UPPERCASE hex number. + */ +void Curl_hexbyte(unsigned char *dest, /* must fit two bytes */ + unsigned char val) +{ + dest[0] = Curl_udigits[val >> 4]; + dest[1] = Curl_udigits[val & 0x0F]; +} diff --git a/3rdparty/curl-8.21.0/lib/escape.h b/3rdparty/curl-8.21.0/lib/escape.h new file mode 100644 index 0000000000..9f9a89e402 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/escape.h @@ -0,0 +1,45 @@ +#ifndef HEADER_CURL_ESCAPE_H +#define HEADER_CURL_ESCAPE_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +/* Escape and unescape URL encoding in strings. The functions return a new + * allocated string or NULL if an error occurred. */ + +enum urlreject { + REJECT_NADA = 2, + REJECT_CTRL, + REJECT_ZERO +}; + +CURLcode Curl_urldecode(const char *string, size_t length, + char **ostring, size_t *olen, + enum urlreject ctrl); + +void Curl_hexencode(const unsigned char *src, size_t len, /* input length */ + unsigned char *out, size_t olen); /* output buffer size */ + +void Curl_hexbyte(unsigned char *dest, /* must fit two bytes */ + unsigned char val); + +#endif /* HEADER_CURL_ESCAPE_H */ diff --git a/3rdparty/curl-8.21.0/lib/fake_addrinfo.c b/3rdparty/curl-8.21.0/lib/fake_addrinfo.c new file mode 100644 index 0000000000..6b04b5d2f5 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/fake_addrinfo.c @@ -0,0 +1,202 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "fake_addrinfo.h" + +#ifdef USE_FAKE_GETADDRINFO + +#include + +void r_freeaddrinfo(struct addrinfo *cahead) +{ + struct addrinfo *canext; + struct addrinfo *ca; + + for(ca = cahead; ca; ca = canext) { + canext = ca->ai_next; + curlx_free(ca); + } +} + +struct context { + struct ares_addrinfo *addr; +}; + +static void async_addrinfo_cb(void *userp, int status, int timeouts, + struct ares_addrinfo *addr) +{ + struct context *ctx = (struct context *)userp; + (void)timeouts; + if(ARES_SUCCESS == status) { + ctx->addr = addr; + } +} + +/* convert the c-ares version into the "native" version */ +static struct addrinfo *mk_getaddrinfo(const struct ares_addrinfo *aihead) +{ + const struct ares_addrinfo_node *ai; + struct addrinfo *ca; + struct addrinfo *cafirst = NULL; + struct addrinfo *calast = NULL; + const char *name = aihead->name; + + /* traverse the addrinfo list */ + for(ai = aihead->nodes; ai; ai = ai->ai_next) { + size_t ss_size; + size_t namelen = name ? strlen(name) + 1 : 0; + /* ignore elements with unsupported address family, + settle family-specific sockaddr structure size. */ + if(ai->ai_family == AF_INET) + ss_size = sizeof(struct sockaddr_in); + else if(ai->ai_family == AF_INET6) + ss_size = sizeof(struct sockaddr_in6); + else + continue; + + /* ignore elements without required address info */ + if(!ai->ai_addr || !(ai->ai_addrlen > 0)) + continue; + + /* ignore elements with bogus address size */ + if((size_t)ai->ai_addrlen < ss_size) + continue; + + ca = curlx_malloc(sizeof(struct addrinfo) + ss_size + namelen); + if(!ca) { + r_freeaddrinfo(cafirst); + return NULL; + } + + /* copy each structure member individually, member ordering, + size, or padding might be different for each platform. */ + + ca->ai_flags = ai->ai_flags; + ca->ai_family = ai->ai_family; + ca->ai_socktype = ai->ai_socktype; + ca->ai_protocol = ai->ai_protocol; + ca->ai_addrlen = (curl_socklen_t)ss_size; + ca->ai_addr = NULL; + ca->ai_canonname = NULL; + ca->ai_next = NULL; + + ca->ai_addr = (void *)((char *)ca + sizeof(struct addrinfo)); + memcpy(ca->ai_addr, ai->ai_addr, ss_size); + + if(namelen) { + ca->ai_canonname = (void *)((char *)ca->ai_addr + ss_size); + memcpy(ca->ai_canonname, name, namelen); + + /* the name is only pointed to by the first entry in the "real" + addrinfo chain, so stop now */ + name = NULL; + } + + /* if the return list is empty, this becomes the first element */ + if(!cafirst) + cafirst = ca; + + /* add this element last in the return list */ + if(calast) + calast->ai_next = ca; + calast = ca; + } + + return cafirst; +} + +/* + RETURN VALUE + + getaddrinfo() returns 0 if it succeeds, or one of the following nonzero + error codes: + + ... +*/ +int r_getaddrinfo(const char *node, + const char *service, + const struct addrinfo *hints, + struct addrinfo **res) +{ + int status; + struct context ctx; + struct ares_options options; + int optmask = 0; + struct ares_addrinfo_hints ahints; + ares_channel channel; + int rc = 0; + + memset(&options, 0, sizeof(options)); + optmask |= ARES_OPT_EVENT_THREAD; + options.evsys = ARES_EVSYS_DEFAULT; + + memset(&ahints, 0, sizeof(ahints)); + memset(&ctx, 0, sizeof(ctx)); + + if(hints) { + ahints.ai_flags = hints->ai_flags; + ahints.ai_family = hints->ai_family; + ahints.ai_socktype = hints->ai_socktype; + ahints.ai_protocol = hints->ai_protocol; + } + + status = ares_init_options(&channel, &options, optmask); + if(status) + return EAI_MEMORY; /* major problem */ + + else { + const char *env = getenv("CURL_DNS_SERVER"); + if(env) { + rc = ares_set_servers_ports_csv(channel, env); + if(rc) { + curl_mfprintf(stderr, "ares_set_servers_ports_csv failed: %d", rc); + /* Cleanup */ + ares_destroy(channel); + return EAI_MEMORY; /* we cannot run */ + } + } + } + + ares_getaddrinfo(channel, node, service, &ahints, async_addrinfo_cb, &ctx); + + /* Wait until no more requests are left to be processed */ + ares_queue_wait_empty(channel, -1); + + if(ctx.addr) { + /* convert the c-ares version */ + *res = mk_getaddrinfo(ctx.addr); + /* free the old */ + ares_freeaddrinfo(ctx.addr); + } + else + rc = EAI_NONAME; /* got nothing */ + + /* Cleanup */ + ares_destroy(channel); + + return rc; +} + +#endif /* USE_FAKE_GETADDRINFO */ diff --git a/3rdparty/curl-8.21.0/lib/fake_addrinfo.h b/3rdparty/curl-8.21.0/lib/fake_addrinfo.h new file mode 100644 index 0000000000..07d5b6da8c --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/fake_addrinfo.h @@ -0,0 +1,53 @@ +#ifndef HEADER_FAKE_ADDRINFO_H +#define HEADER_FAKE_ADDRINFO_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_ARES +#include +#endif + +#if defined(CURL_MEMDEBUG) && defined(HAVE_GETADDRINFO) && \ + defined(USE_ARES) && (ARES_VERSION >= 0x011a00) /* >= 1.26.0 */ +#define USE_FAKE_GETADDRINFO 1 +#endif + +#ifdef USE_FAKE_GETADDRINFO + +#ifdef HAVE_NETDB_H +# include +#endif +#ifdef HAVE_ARPA_INET_H +# include +#endif + +void r_freeaddrinfo(struct addrinfo *res); +int r_getaddrinfo(const char *node, + const char *service, + const struct addrinfo *hints, + struct addrinfo **res); +#endif /* USE_FAKE_GETADDRINFO */ + +#endif /* HEADER_FAKE_ADDRINFO_H */ diff --git a/3rdparty/curl-8.21.0/lib/file.c b/3rdparty/curl-8.21.0/lib/file.c new file mode 100644 index 0000000000..fff8feeb92 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/file.c @@ -0,0 +1,623 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" +#include "urldata.h" +#include "file.h" + +#ifndef CURL_DISABLE_FILE + +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETDB_H +#include +#endif +#ifdef HAVE_ARPA_INET_H +#include +#endif +#ifdef HAVE_NET_IF_H +#include +#endif +#ifdef HAVE_SYS_IOCTL_H +#include +#endif + +#ifdef HAVE_SYS_PARAM_H +#include +#endif + +#ifdef HAVE_SYS_TYPES_H +#include +#endif + +#ifdef HAVE_DIRENT_H +#include +#endif + +#include "progress.h" +#include "sendf.h" +#include "curl_trc.h" +#include "escape.h" +#include "multiif.h" +#include "transfer.h" +#include "url.h" +#include "parsedate.h" /* for the week day and month names */ +#include "curlx/fopen.h" +#include "curl_range.h" + +#if defined(_WIN32) || defined(MSDOS) +#define DOS_FILESYSTEM 1 +#elif defined(__amigaos4__) +#define AMIGA_FILESYSTEM 1 +#endif + +/* meta key for storing protocol meta at easy handle */ +#define CURL_META_FILE_EASY "meta:proto:file:easy" + +struct FILEPROTO { + char *path; /* the path we operate on */ + char *freepath; /* pointer to the allocated block we must free, this might + differ from the 'path' pointer */ + int fd; /* open file descriptor to read from! */ +}; + +static void file_cleanup(struct FILEPROTO *file) +{ + curlx_safefree(file->freepath); + file->path = NULL; + if(file->fd != -1) { + curlx_close(file->fd); + file->fd = -1; + } +} + +static void file_easy_dtor(void *key, size_t klen, void *entry) +{ + struct FILEPROTO *file = entry; + (void)key; + (void)klen; + file_cleanup(file); + curlx_free(file); +} + +static CURLcode file_setup_connection(struct Curl_easy *data, + struct connectdata *conn) +{ + struct FILEPROTO *filep; + (void)conn; + /* allocate the FILE specific struct */ + filep = curlx_calloc(1, sizeof(*filep)); + if(filep) + filep->fd = -1; + if(!filep || + Curl_meta_set(data, CURL_META_FILE_EASY, filep, file_easy_dtor)) + return CURLE_OUT_OF_MEMORY; + + return CURLE_OK; +} + +static CURLcode file_done(struct Curl_easy *data, + CURLcode status, bool premature) +{ + struct FILEPROTO *file = Curl_meta_get(data, CURL_META_FILE_EASY); + (void)status; + (void)premature; + + if(file) + file_cleanup(file); + + return CURLE_OK; +} + +/* + * file_connect() gets called from Curl_protocol_connect() to allow us to + * do protocol-specific actions at connect-time. We emulate a + * connect-then-transfer protocol and "connect" to the file here + */ +static CURLcode file_connect(struct Curl_easy *data, bool *done) +{ + char *real_path; + struct FILEPROTO *file = Curl_meta_get(data, CURL_META_FILE_EASY); + int fd; +#ifdef DOS_FILESYSTEM + size_t i; + char *actual_path; +#endif + size_t real_path_len; + CURLcode result; + + if(!file) + return CURLE_FAILED_INIT; + + if(file->path) { + /* already connected. + * the handler->connect_it() is normally only called once, but + * FILE does a special check on setting up the connection which + * calls this explicitly. */ + *done = TRUE; + return CURLE_OK; + } + + result = Curl_urldecode(data->state.up.path, 0, &real_path, + &real_path_len, REJECT_ZERO); + if(result) + return result; + +#ifdef DOS_FILESYSTEM + /* If the first character is a slash, and there is + something that looks like a drive at the beginning of + the path, skip the slash. If we remove the initial + slash in all cases, paths without drive letters end up + relative to the current directory which is not how + browsers work. + + Some browsers accept | instead of : as the drive letter + separator, so we do too. + + On other platforms, we need the slash to indicate an + absolute pathname. On Windows, absolute paths start + with a drive letter. + */ + actual_path = real_path; + if((actual_path[0] == '/') && + actual_path[1] && + (actual_path[2] == ':' || actual_path[2] == '|')) { + actual_path[2] = ':'; + actual_path++; + real_path_len--; + } + + /* change path separators from '/' to '\\' for DOS, Windows and OS/2 */ + for(i = 0; i < real_path_len; ++i) + if(actual_path[i] == '/') + actual_path[i] = '\\'; + else if(!actual_path[i]) { /* binary zero */ + curlx_safefree(real_path); + return CURLE_URL_MALFORMAT; + } + + fd = curlx_open(actual_path, O_RDONLY | CURL_O_BINARY); + file->path = actual_path; +#else + if(memchr(real_path, 0, real_path_len)) { + /* binary zeroes indicate foul play */ + curlx_safefree(real_path); + return CURLE_URL_MALFORMAT; + } + +#ifdef AMIGA_FILESYSTEM + /* + * A leading slash in an AmigaDOS path denotes the parent + * directory, and hence we block this as it is relative. + * Absolute paths start with 'volumename:', so we check for + * this first. Failing that, we treat the path as a real Unix + * path, but only if the application was compiled with -lunix. + */ + fd = -1; + file->path = real_path; + + if(real_path[0] == '/') { + extern int __unix_path_semantics; + if(strchr(real_path + 1, ':')) { + /* Amiga absolute path */ + fd = curlx_open(real_path + 1, O_RDONLY); + file->path++; + } + else if(__unix_path_semantics) { + /* -lunix fallback */ + fd = curlx_open(real_path, O_RDONLY); + } + } +#else + fd = curlx_open(real_path, O_RDONLY); + file->path = real_path; +#endif +#endif + curlx_free(file->freepath); + file->freepath = real_path; /* free this when done */ + + file->fd = fd; + if(!data->state.upload && (fd == -1)) { + failf(data, "Could not open file %s", data->state.up.path); + file_done(data, CURLE_FILE_COULDNT_READ_FILE, FALSE); + return CURLE_FILE_COULDNT_READ_FILE; + } + *done = TRUE; + + return CURLE_OK; +} + +static CURLcode file_disconnect(struct Curl_easy *data, + struct connectdata *conn, + bool dead_connection) +{ + (void)dead_connection; + (void)conn; + return file_done(data, CURLE_OK, FALSE); +} + +#ifdef DOS_FILESYSTEM +#define DIRSEP '\\' +#else +#define DIRSEP '/' +#endif + +static CURLcode file_upload(struct Curl_easy *data, + struct FILEPROTO *file) +{ + const char *dir = strchr(file->path, DIRSEP); + int fd; + int mode; + CURLcode result = CURLE_OK; + char *xfer_ulbuf; + size_t xfer_ulblen; + curlx_struct_stat file_stat; + const char *sendbuf; + bool eos = FALSE; + + /* + * Since FILE: does not do the full init, we need to provide some extra + * assignments here. + */ + + if(!dir) + return CURLE_FILE_COULDNT_READ_FILE; /* fix: better error code */ + + if(!dir[1]) + return CURLE_FILE_COULDNT_READ_FILE; /* fix: better error code */ + + mode = O_WRONLY | O_CREAT | CURL_O_BINARY; + if(data->state.resume_from) + mode |= O_APPEND; + else + mode |= O_TRUNC; + +#ifdef _WIN32 + fd = curlx_open(file->path, mode, + data->set.new_file_perms & (_S_IREAD | _S_IWRITE)); +#elif (defined(ANDROID) || defined(__ANDROID__)) && \ + (defined(__i386__) || defined(__arm__)) + fd = curlx_open(file->path, mode, (mode_t)data->set.new_file_perms); +#else + fd = curlx_open(file->path, mode, data->set.new_file_perms); +#endif + if(fd < 0) { + failf(data, "cannot open %s for writing", file->path); + return CURLE_WRITE_ERROR; + } + + if(data->state.infilesize != -1) + /* known size of data to "upload" */ + Curl_pgrsSetUploadSize(data, data->state.infilesize); + + /* treat the negative resume offset value as the case of "-" */ + if(data->state.resume_from < 0) { + if(curlx_fstat(fd, &file_stat)) { + curlx_close(fd); + failf(data, "cannot get the size of %s", file->path); + return CURLE_WRITE_ERROR; + } + data->state.resume_from = (curl_off_t)file_stat.st_size; + } + + result = Curl_multi_xfer_ulbuf_borrow(data, &xfer_ulbuf, &xfer_ulblen); + if(result) + goto out; + + while(!result && !eos) { + size_t nread, nwritten; + ssize_t rv; + size_t readcount; + + result = Curl_client_read(data, xfer_ulbuf, xfer_ulblen, &readcount, &eos); + if(result) + break; + + if(!readcount) + break; + + nread = readcount; + + /* skip bytes before resume point */ + if(data->state.resume_from) { + if((curl_off_t)nread <= data->state.resume_from) { + data->state.resume_from -= nread; + nread = 0; + sendbuf = xfer_ulbuf; + } + else { + sendbuf = xfer_ulbuf + data->state.resume_from; + nread -= (size_t)data->state.resume_from; + data->state.resume_from = 0; + } + } + else + sendbuf = xfer_ulbuf; + + /* write the data to the target */ + rv = write(fd, sendbuf, nread); + if(!curlx_sztouz(rv, &nwritten) || (nwritten != nread)) { + result = CURLE_SEND_ERROR; + break; + } + Curl_pgrs_upload_inc(data, nwritten); + + result = Curl_pgrsCheck(data); + } + if(!result) + result = Curl_pgrsUpdate(data); + +out: + curlx_close(fd); + Curl_multi_xfer_ulbuf_release(data, xfer_ulbuf); + + return result; +} + +/* + * file_do() is the protocol-specific function for the do-phase, separated + * from the connect-phase above. Other protocols merely setup the transfer in + * the do-phase, to have it done in the main transfer loop but since some + * platforms we support do not allow select()ing etc on file handles (as + * opposed to sockets) we instead perform the whole do-operation in this + * function. + */ +static CURLcode file_do(struct Curl_easy *data, bool *done) +{ + /* This implementation ignores the hostname in conformance with + RFC 1738. Only local files (reachable via the standard file system) + are supported. This means that files on remotely mounted directories + (via NFS, Samba, NT sharing) can be accessed through a file:// URL + */ + struct FILEPROTO *file = Curl_meta_get(data, CURL_META_FILE_EASY); + CURLcode result = CURLE_OK; + curlx_struct_stat statbuf; + curl_off_t expected_size = -1; + bool size_known; + bool fstated = FALSE; + int fd; + char *xfer_buf; + size_t xfer_blen; + + *done = TRUE; /* unconditionally */ + if(!file) + return CURLE_FAILED_INIT; + + if(data->state.upload) + return file_upload(data, file); + + /* get the fd from the connection phase */ + fd = file->fd; + + /* VMS: This only works reliable for STREAMLF files */ + if(curlx_fstat(fd, &statbuf) != -1) { + if(!S_ISDIR(statbuf.st_mode)) + expected_size = statbuf.st_size; + /* and store the modification time */ + data->info.filetime = statbuf.st_mtime; + fstated = TRUE; + } + + if(fstated && !data->state.range && data->set.timecondition && + !Curl_meets_timecondition(data, data->info.filetime)) + return CURLE_OK; + + if(fstated) { + time_t filetime; + struct tm buffer; + const struct tm *tm = &buffer; + char header[80]; + int headerlen; + static const char accept_ranges[] = { "Accept-ranges: bytes\r\n" }; + if(expected_size >= 0) { + headerlen = + curl_msnprintf(header, sizeof(header), + "Content-Length: %" FMT_OFF_T "\r\n", expected_size); + result = Curl_client_write(data, CLIENTWRITE_HEADER, header, headerlen); + if(result) + return result; + + result = Curl_client_write(data, CLIENTWRITE_HEADER, + accept_ranges, sizeof(accept_ranges) - 1); + if(result != CURLE_OK) + return result; + } + + filetime = (time_t)statbuf.st_mtime; + result = curlx_gmtime(filetime, &buffer); + if(result) + return result; + + /* format: "Tue, 15 Nov 1994 12:45:26 GMT" */ + headerlen = + curl_msnprintf(header, sizeof(header), + "Last-Modified: %s, %02d %s %4d %02d:%02d:%02d GMT\r\n", + Curl_wkday[tm->tm_wday ? tm->tm_wday - 1 : 6], + tm->tm_mday, + Curl_month[tm->tm_mon], + tm->tm_year + 1900, + tm->tm_hour, + tm->tm_min, + tm->tm_sec); + result = Curl_client_write(data, CLIENTWRITE_HEADER, header, headerlen); + if(!result) + /* end of headers */ + result = Curl_client_write(data, CLIENTWRITE_HEADER, "\r\n", 2); + if(result) + return result; + /* set the file size to make it available post transfer */ + Curl_pgrsSetDownloadSize(data, expected_size); + if(data->req.no_body) + return CURLE_OK; + } + + /* Check whether file range has been specified */ + result = Curl_range(data); + if(result) + return result; + + /* Adjust the start offset in case we want to get the N last bytes + * of the stream if the filesize could be determined */ + if(data->state.resume_from < 0) { + if(!fstated) { + failf(data, "cannot get the size of file."); + return CURLE_READ_ERROR; + } + data->state.resume_from += (curl_off_t)statbuf.st_size; + } + + if(data->state.resume_from > 0) { + /* We check explicitly if we have a start offset, because + * expected_size may be -1 if we do not know how large the file is, + * in which case we should not adjust it. */ + if(data->state.resume_from <= expected_size) + expected_size -= data->state.resume_from; + else { + failf(data, "failed to resume file:// transfer"); + return CURLE_BAD_DOWNLOAD_RESUME; + } + } + + /* A high water mark has been specified so we obey... */ + if(data->req.maxdownload > 0) + expected_size = data->req.maxdownload; + + if(!fstated || (expected_size <= 0)) + size_known = FALSE; + else + size_known = TRUE; + + /* The following is a shortcut implementation of file reading + this is both more efficient than the former call to download() and + it avoids problems with select() and recv() on file descriptors + in Winsock */ + if(size_known) + Curl_pgrsSetDownloadSize(data, expected_size); + + if(data->state.resume_from) { + if(!S_ISDIR(statbuf.st_mode)) { + if(data->state.resume_from != + curl_lseek(fd, data->state.resume_from, SEEK_SET)) + return CURLE_BAD_DOWNLOAD_RESUME; + } + else { + return CURLE_BAD_DOWNLOAD_RESUME; + } + } + + result = Curl_multi_xfer_buf_borrow(data, &xfer_buf, &xfer_blen); + if(result) + goto out; + + if(!S_ISDIR(statbuf.st_mode)) { + while(!result) { + ssize_t nread; + /* Do not fill a whole buffer if we want less than all data */ + size_t bytestoread; + + if(size_known) { + bytestoread = (expected_size < (curl_off_t)(xfer_blen - 1)) ? + curlx_sotouz(expected_size) : (xfer_blen - 1); + } + else + bytestoread = xfer_blen - 1; + + nread = read(fd, xfer_buf, bytestoread); + + if(nread > 0) + xfer_buf[nread] = 0; + + if(nread <= 0 || (size_known && (expected_size == 0))) + break; + + if(size_known) + expected_size -= nread; + + result = Curl_client_write(data, CLIENTWRITE_BODY, xfer_buf, nread); + if(result) + goto out; + + result = Curl_pgrsCheck(data); + if(result) + goto out; + } + } + else { +#ifdef HAVE_OPENDIR + DIR *dir = opendir(file->path); + struct dirent *entry; + + if(!dir) { + result = CURLE_READ_ERROR; + goto out; + } + else { + while((entry = readdir(dir))) { + if(entry->d_name[0] != '.') { + result = Curl_client_write(data, CLIENTWRITE_BODY, + entry->d_name, strlen(entry->d_name)); + if(result) + break; + result = Curl_client_write(data, CLIENTWRITE_BODY, "\n", 1); + if(result) + break; + } + } + closedir(dir); + } +#else + failf(data, "Directory listing not yet implemented on this platform."); + result = CURLE_READ_ERROR; +#endif + } + + if(!result) + result = Curl_pgrsUpdate(data); + +out: + Curl_multi_xfer_buf_release(data, xfer_buf); + return result; +} + +const struct Curl_protocol Curl_protocol_file = { + file_setup_connection, /* setup_connection */ + file_do, /* do_it */ + file_done, /* done */ + ZERO_NULL, /* do_more */ + file_connect, /* connect_it */ + ZERO_NULL, /* connecting */ + ZERO_NULL, /* doing */ + ZERO_NULL, /* proto_pollset */ + ZERO_NULL, /* doing_pollset */ + ZERO_NULL, /* domore_pollset */ + ZERO_NULL, /* perform_pollset */ + file_disconnect, /* disconnect */ + ZERO_NULL, /* write_resp */ + ZERO_NULL, /* write_resp_hd */ + ZERO_NULL, /* connection_is_dead */ + ZERO_NULL, /* attach connection */ + ZERO_NULL, /* follow */ +}; + +#endif diff --git a/3rdparty/curl-8.21.0/lib/file.h b/3rdparty/curl-8.21.0/lib/file.h new file mode 100644 index 0000000000..0aa411b19f --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/file.h @@ -0,0 +1,30 @@ +#ifndef HEADER_CURL_FILE_H +#define HEADER_CURL_FILE_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#ifndef CURL_DISABLE_FILE +extern const struct Curl_protocol Curl_protocol_file; +#endif + +#endif /* HEADER_CURL_FILE_H */ diff --git a/3rdparty/curl-8.21.0/lib/fileinfo.c b/3rdparty/curl-8.21.0/lib/fileinfo.c new file mode 100644 index 0000000000..33e5acde01 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/fileinfo.c @@ -0,0 +1,44 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifndef CURL_DISABLE_FTP + +#include "fileinfo.h" + +struct fileinfo *Curl_fileinfo_alloc(void) +{ + return curlx_calloc(1, sizeof(struct fileinfo)); +} + +void Curl_fileinfo_cleanup(struct fileinfo *finfo) +{ + if(!finfo) + return; + + curlx_dyn_free(&finfo->buf); + curlx_free(finfo); +} + +#endif /* !CURL_DISABLE_FTP */ diff --git a/3rdparty/curl-8.21.0/lib/fileinfo.h b/3rdparty/curl-8.21.0/lib/fileinfo.h new file mode 100644 index 0000000000..737966788c --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/fileinfo.h @@ -0,0 +1,40 @@ +#ifndef HEADER_CURL_FILEINFO_H +#define HEADER_CURL_FILEINFO_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "llist.h" +#include "curlx/dynbuf.h" + +struct fileinfo { + struct curl_fileinfo info; + struct Curl_llist_node list; + struct dynbuf buf; +}; + +struct fileinfo *Curl_fileinfo_alloc(void); +void Curl_fileinfo_cleanup(struct fileinfo *finfo); + +#endif /* HEADER_CURL_FILEINFO_H */ diff --git a/3rdparty/curl-8.21.0/lib/formdata.c b/3rdparty/curl-8.21.0/lib/formdata.c new file mode 100644 index 0000000000..681902db71 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/formdata.c @@ -0,0 +1,866 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +struct Curl_easy; + +#include "formdata.h" + +#if !defined(CURL_DISABLE_HTTP) && !defined(CURL_DISABLE_FORM_API) + +#include "urldata.h" /* for struct Curl_easy */ +#include "mime.h" +#include "curlx/strdup.h" +#include "bufref.h" +#include "curlx/fopen.h" + + +#define HTTPPOST_PTRNAME CURL_HTTPPOST_PTRNAME +#define HTTPPOST_FILENAME CURL_HTTPPOST_FILENAME +#define HTTPPOST_PTRCONTENTS CURL_HTTPPOST_PTRCONTENTS +#define HTTPPOST_READFILE CURL_HTTPPOST_READFILE +#define HTTPPOST_PTRBUFFER CURL_HTTPPOST_PTRBUFFER +#define HTTPPOST_CALLBACK CURL_HTTPPOST_CALLBACK +#define HTTPPOST_BUFFER CURL_HTTPPOST_BUFFER + +/*************************************************************************** + * + * AddHttpPost() + * + * Adds an HttpPost structure to the list, if parent_post is given becomes + * a subpost of parent_post instead of a direct list element. + * + * Returns newly allocated HttpPost on success and NULL if malloc failed. + * + ***************************************************************************/ +static struct curl_httppost *AddHttpPost(struct FormInfo *src, + struct curl_httppost *parent_post, + struct curl_httppost **httppost, + struct curl_httppost **last_post) +{ + struct curl_httppost *post; + size_t namelength = src->namelength; + if(!namelength && Curl_bufref_ptr(&src->name)) + namelength = strlen(Curl_bufref_ptr(&src->name)); + if((src->bufferlength > LONG_MAX) || (namelength > LONG_MAX)) + /* avoid overflow in typecasts below */ + return NULL; + post = curlx_calloc(1, sizeof(struct curl_httppost)); + if(post) { + post->name = CURL_UNCONST(Curl_bufref_ptr(&src->name)); + post->namelength = (long)namelength; + post->contents = CURL_UNCONST(Curl_bufref_ptr(&src->value)); + post->contentlen = src->contentslength; + post->buffer = src->buffer; + post->bufferlength = (long)src->bufferlength; + post->contenttype = CURL_UNCONST(Curl_bufref_ptr(&src->contenttype)); + post->flags = src->flags | CURL_HTTPPOST_LARGE; + post->contentheader = src->contentheader; + post->showfilename = CURL_UNCONST(Curl_bufref_ptr(&src->showfilename)); + post->userp = src->userp; + } + else + return NULL; + + if(parent_post) { + /* now, point our 'more' to the original 'more' */ + post->more = parent_post->more; + + /* then move the original 'more' to point to ourselves */ + parent_post->more = post; + } + else { + /* make the previous point to this */ + if(*last_post) + (*last_post)->next = post; + else + (*httppost) = post; + + (*last_post) = post; + } + return post; +} + +/* Allocate and initialize a new FormInfo structure. */ +static struct FormInfo *NewFormInfo(void) +{ + struct FormInfo *form_info = curlx_calloc(1, sizeof(struct FormInfo)); + + if(form_info) { + Curl_bufref_init(&form_info->name); + Curl_bufref_init(&form_info->value); + Curl_bufref_init(&form_info->contenttype); + Curl_bufref_init(&form_info->showfilename); + } + + return form_info; +} + +/* Replace the target field data by a dynamic copy of it. */ +static CURLcode FormInfoCopyField(struct bufref *field, size_t len) +{ + const char *value = Curl_bufref_ptr(field); + CURLcode result = CURLE_OK; + + if(value) { + if(!len) + len = strlen(value); + result = Curl_bufref_memdup0(field, value, len); + } + + return result; +} + +/*************************************************************************** + * + * AddFormInfo() + * + * Adds a FormInfo structure to the list presented by parent. + * + ***************************************************************************/ +static void AddFormInfo(struct FormInfo *form_info, struct FormInfo *parent) +{ + form_info->flags |= HTTPPOST_FILENAME; + + if(parent) { + /* now, point our 'more' to the original 'more' */ + form_info->more = parent->more; + + /* then move the original 'more' to point to ourselves */ + parent->more = form_info; + } +} + +static void free_formlist(struct FormInfo *ptr) +{ + for(; ptr; ptr = ptr->more) { + Curl_bufref_free(&ptr->name); + Curl_bufref_free(&ptr->value); + Curl_bufref_free(&ptr->contenttype); + Curl_bufref_free(&ptr->showfilename); + } +} + +/*************************************************************************** + * + * FormAdd() + * + * Stores a formpost parameter and builds the appropriate linked list. + * + * Has two principal functionalities: using files and byte arrays as post + * parts. Byte arrays are either copied or the pointer is stored (as the user + * requests) while for files only the filename and not the content is stored. + * + * While you may have only one byte array for each name, multiple filenames + * are allowed (and because of this feature CURLFORM_END is needed after + * using CURLFORM_FILE). + * + * Examples: + * + * Simple name/value pair with copied contents: + * curl_formadd(&post, &last, CURLFORM_COPYNAME, "name", + * CURLFORM_COPYCONTENTS, "value", CURLFORM_END); + * + * name/value pair where only the content pointer is remembered: + * curl_formadd(&post, &last, CURLFORM_COPYNAME, "name", + * CURLFORM_PTRCONTENTS, ptr, CURLFORM_CONTENTSLENGTH, 10L, + * CURLFORM_END); + * (if CURLFORM_CONTENTSLENGTH is missing strlen () is used) + * + * storing a filename (CONTENTTYPE is optional!): + * curl_formadd(&post, &last, CURLFORM_COPYNAME, "name", + * CURLFORM_FILE, "filename1", CURLFORM_CONTENTTYPE, "plain/text", + * CURLFORM_END); + * + * storing multiple filenames: + * curl_formadd(&post, &last, CURLFORM_COPYNAME, "name", + * CURLFORM_FILE, "filename1", CURLFORM_FILE, "filename2", + * CURLFORM_END); + * + * Returns: + * CURL_FORMADD_OK on success + * CURL_FORMADD_MEMORY if the FormInfo allocation fails + * CURL_FORMADD_OPTION_TWICE if one option is given twice for one Form + * CURL_FORMADD_NULL if a null pointer was given for a char + * CURL_FORMADD_MEMORY if the allocation of a FormInfo struct failed + * CURL_FORMADD_UNKNOWN_OPTION if an unknown option was used + * CURL_FORMADD_INCOMPLETE if the some FormInfo is not complete (or error) + * CURL_FORMADD_MEMORY if an HttpPost struct cannot be allocated + * CURL_FORMADD_MEMORY if some allocation for string copying failed. + * CURL_FORMADD_ILLEGAL_ARRAY if an illegal option is used in an array + * + ***************************************************************************/ + +static CURLFORMcode FormAddCheck(struct FormInfo *first_form, + struct curl_httppost **httppost, + struct curl_httppost **last_post) +{ + const char *prevtype = NULL; + struct FormInfo *form = NULL; + struct curl_httppost *post = NULL; + + /* go through the list, check for completeness and if everything is + * alright add the HttpPost item otherwise set retval accordingly */ + + for(form = first_form; form; form = form->more) { + const char *name = Curl_bufref_ptr(&form->name); + + if(((!name || !Curl_bufref_ptr(&form->value)) && !post) || + (form->contentslength && + (form->flags & HTTPPOST_FILENAME)) || + ((form->flags & HTTPPOST_FILENAME) && + (form->flags & HTTPPOST_PTRCONTENTS)) || + + (!form->buffer && + (form->flags & HTTPPOST_BUFFER) && + (form->flags & HTTPPOST_PTRBUFFER)) || + + ((form->flags & HTTPPOST_READFILE) && + (form->flags & HTTPPOST_PTRCONTENTS)) + ) { + return CURL_FORMADD_INCOMPLETE; + } + if(((form->flags & HTTPPOST_FILENAME) || + (form->flags & HTTPPOST_BUFFER)) && + !Curl_bufref_ptr(&form->contenttype)) { + const char *f = Curl_bufref_ptr((form->flags & HTTPPOST_BUFFER) ? + &form->showfilename : &form->value); + const char *type = Curl_mime_contenttype(f); + if(!type) + type = prevtype; + if(!type) + type = FILE_CONTENTTYPE_DEFAULT; + + /* our contenttype is missing */ + if(Curl_bufref_memdup0(&form->contenttype, type, strlen(type))) + return CURL_FORMADD_MEMORY; + } + if(name && form->namelength) { + if(memchr(name, 0, form->namelength)) + return CURL_FORMADD_NULL; + } + if(!(form->flags & HTTPPOST_PTRNAME)) { + /* Note that there is small risk that form->name is NULL here if the app + passed in a bad combo, so we check for that. */ + if(FormInfoCopyField(&form->name, form->namelength)) + return CURL_FORMADD_MEMORY; + } + if(!(form->flags & (HTTPPOST_FILENAME | HTTPPOST_READFILE | + HTTPPOST_PTRCONTENTS | HTTPPOST_PTRBUFFER | + HTTPPOST_CALLBACK))) { + if(FormInfoCopyField(&form->value, (size_t)form->contentslength)) + return CURL_FORMADD_MEMORY; + } + post = AddHttpPost(form, post, httppost, last_post); + + if(!post) + return CURL_FORMADD_MEMORY; + + if(Curl_bufref_ptr(&form->contenttype)) + prevtype = Curl_bufref_ptr(&form->contenttype); + } + + return CURL_FORMADD_OK; +} + +/* Shallow cleanup. Remove the newly created chain, the structs only and not + the content they point to */ +static void free_chain(struct curl_httppost *c) +{ + while(c) { + struct curl_httppost *next = c->next; + if(c->more) + free_chain(c->more); + curlx_free(c); + c = next; + } +} + +static CURLFORMcode FormAdd(struct curl_httppost **httppost, + struct curl_httppost **last_post, va_list params) +{ + struct FormInfo *first_form, *curr, *form = NULL; + CURLFORMcode retval = CURL_FORMADD_OK; + CURLformoption option; + const struct curl_forms *forms = NULL; + char *avalue = NULL; + struct curl_httppost *newchain = NULL; + struct curl_httppost *lastnode = NULL; + +#define form_ptr_arg(t) (forms ? (t)(void *)avalue : va_arg(params, t)) +#ifdef HAVE_UINTPTR_T +#define form_int_arg(t) (forms ? (t)(uintptr_t)avalue : va_arg(params, t)) +#else +#define form_int_arg(t) (forms ? (t)(void *)avalue : va_arg(params, t)) +#endif + + /* + * We need to allocate the first struct to fill in. + */ + first_form = NewFormInfo(); + if(!first_form) + return CURL_FORMADD_MEMORY; + + curr = first_form; + + /* + * Loop through all the options set. Break if we have an error to report. + */ + while(retval == CURL_FORMADD_OK) { + + /* first see if we have more parts of the array param */ + if(forms) { + /* get the upcoming option from the given array */ + option = forms->option; + avalue = (char *)CURL_UNCONST(forms->value); + + forms++; /* advance this to next entry */ + if(CURLFORM_END == option) { + /* end of array state */ + forms = NULL; + continue; + } + } + else { + /* This is not array-state, get next option. This gets an 'int' with + va_arg() because CURLformoption might be a smaller type than int and + might cause compiler warnings and wrong behavior. */ + option = (CURLformoption)va_arg(params, int); + if(CURLFORM_END == option) + break; + } + + switch(option) { + case CURLFORM_ARRAY: + if(forms) + /* we do not support an array from within an array */ + retval = CURL_FORMADD_ILLEGAL_ARRAY; + else { + forms = va_arg(params, struct curl_forms *); + if(!forms) + retval = CURL_FORMADD_NULL; + } + break; + + /* + * Set the Name property. + */ + case CURLFORM_PTRNAME: + curr->flags |= HTTPPOST_PTRNAME; + FALLTHROUGH(); + case CURLFORM_COPYNAME: + if(Curl_bufref_ptr(&curr->name)) + retval = CURL_FORMADD_OPTION_TWICE; + else { + avalue = form_ptr_arg(char *); + if(avalue) + Curl_bufref_set(&curr->name, avalue, 0, NULL); /* No copy yet. */ + else + retval = CURL_FORMADD_NULL; + } + break; + case CURLFORM_NAMELENGTH: + if(curr->namelength) + retval = CURL_FORMADD_OPTION_TWICE; + else + curr->namelength = (size_t)form_int_arg(long); + break; + + /* + * Set the contents property. + */ + case CURLFORM_PTRCONTENTS: + curr->flags |= HTTPPOST_PTRCONTENTS; + FALLTHROUGH(); + case CURLFORM_COPYCONTENTS: + if(Curl_bufref_ptr(&curr->value)) + retval = CURL_FORMADD_OPTION_TWICE; + else { + avalue = form_ptr_arg(char *); + if(avalue) + Curl_bufref_set(&curr->value, avalue, 0, NULL); /* No copy yet. */ + else + retval = CURL_FORMADD_NULL; + } + break; + case CURLFORM_CONTENTSLENGTH: + curr->contentslength = (curl_off_t)(size_t)form_int_arg(long); + break; + + case CURLFORM_CONTENTLEN: + curr->flags |= CURL_HTTPPOST_LARGE; + curr->contentslength = form_int_arg(curl_off_t); + break; + + /* Get contents from a given filename */ + case CURLFORM_FILECONTENT: + if(curr->flags & (HTTPPOST_PTRCONTENTS | HTTPPOST_READFILE)) + retval = CURL_FORMADD_OPTION_TWICE; + else { + avalue = form_ptr_arg(char *); + if(avalue) { + if(Curl_bufref_memdup0(&curr->value, avalue, strlen(avalue))) + retval = CURL_FORMADD_MEMORY; + else + curr->flags |= HTTPPOST_READFILE; + } + else + retval = CURL_FORMADD_NULL; + } + break; + + /* We upload a file */ + case CURLFORM_FILE: + avalue = form_ptr_arg(char *); + if(Curl_bufref_ptr(&curr->value)) { + if(curr->flags & HTTPPOST_FILENAME) { + if(avalue) { + form = NewFormInfo(); + if(!form || + Curl_bufref_memdup0(&form->value, avalue, strlen(avalue))) { + curlx_free(form); + retval = CURL_FORMADD_MEMORY; + } + else { + AddFormInfo(form, curr); + curr = form; + form = NULL; + } + } + else + retval = CURL_FORMADD_NULL; + } + else + retval = CURL_FORMADD_OPTION_TWICE; + } + else { + if(avalue) { + if(Curl_bufref_memdup0(&curr->value, avalue, strlen(avalue))) + retval = CURL_FORMADD_MEMORY; + else + curr->flags |= HTTPPOST_FILENAME; + } + else + retval = CURL_FORMADD_NULL; + } + break; + + case CURLFORM_BUFFERPTR: + curr->flags |= HTTPPOST_PTRBUFFER | HTTPPOST_BUFFER; + if(curr->buffer) + retval = CURL_FORMADD_OPTION_TWICE; + else { + avalue = form_ptr_arg(char *); + if(avalue) { + curr->buffer = avalue; /* store for the moment */ + /* Make value non-NULL to be accepted as fine */ + Curl_bufref_set(&curr->value, avalue, 0, NULL); + } + else + retval = CURL_FORMADD_NULL; + } + break; + + case CURLFORM_BUFFERLENGTH: + if(curr->bufferlength) + retval = CURL_FORMADD_OPTION_TWICE; + else + curr->bufferlength = (size_t)form_int_arg(long); + break; + + case CURLFORM_STREAM: + curr->flags |= HTTPPOST_CALLBACK; + if(curr->userp) + retval = CURL_FORMADD_OPTION_TWICE; + else { + avalue = form_ptr_arg(char *); + if(avalue) { + curr->userp = avalue; + /* The following line is not strictly true but we derive a value + from this later on and we need this non-NULL to be accepted as + a fine form part */ + Curl_bufref_set(&curr->value, avalue, 0, NULL); + } + else + retval = CURL_FORMADD_NULL; + } + break; + + case CURLFORM_CONTENTTYPE: + avalue = form_ptr_arg(char *); + if(Curl_bufref_ptr(&curr->contenttype)) { + if(curr->flags & HTTPPOST_FILENAME) { + if(avalue) { + form = NewFormInfo(); + if(!form || Curl_bufref_memdup0(&form->contenttype, avalue, + strlen(avalue))) { + curlx_free(form); + retval = CURL_FORMADD_MEMORY; + } + else { + AddFormInfo(form, curr); + curr = form; + form = NULL; + } + } + else + retval = CURL_FORMADD_NULL; + } + else + retval = CURL_FORMADD_OPTION_TWICE; + } + else if(avalue) { + if(Curl_bufref_memdup0(&curr->contenttype, avalue, strlen(avalue))) + retval = CURL_FORMADD_MEMORY; + } + else + retval = CURL_FORMADD_NULL; + break; + + case CURLFORM_CONTENTHEADER: { + /* this "cast increases required alignment of target type" but + we consider it OK anyway */ + struct curl_slist *list = form_ptr_arg(struct curl_slist *); + + if(curr->contentheader) + retval = CURL_FORMADD_OPTION_TWICE; + else + curr->contentheader = list; + + break; + } + case CURLFORM_FILENAME: + case CURLFORM_BUFFER: + avalue = form_ptr_arg(char *); + if(Curl_bufref_ptr(&curr->showfilename)) + retval = CURL_FORMADD_OPTION_TWICE; + else if(Curl_bufref_memdup0(&curr->showfilename, avalue, strlen(avalue))) + retval = CURL_FORMADD_MEMORY; + break; + + default: + retval = CURL_FORMADD_UNKNOWN_OPTION; + break; + } + } + + if(!retval) + retval = FormAddCheck(first_form, &newchain, &lastnode); + + if(retval) + /* On error, free allocated fields for all nodes of the FormInfo linked + list without deallocating nodes. List nodes are deallocated later on */ + free_formlist(first_form); + + /* Always deallocate FormInfo linked list nodes without touching node + fields given that these have either been deallocated or are owned + now by the httppost linked list */ + while(first_form) { + struct FormInfo *ptr = first_form->more; + curlx_free(first_form); + first_form = ptr; + } + + if(!retval) { + /* Only if all is fine, link the new chain into the provided list */ + if(*last_post) + (*last_post)->next = newchain; + else + (*httppost) = newchain; + + (*last_post) = lastnode; + } + else + free_chain(newchain); + + return retval; +#undef form_ptr_arg +#undef form_int_arg +} + +/* + * curl_formadd() is a public API to add a section to the multipart formpost. + * + * @unittest: 1308 + */ + +CURLFORMcode curl_formadd(struct curl_httppost **httppost, + struct curl_httppost **last_post, ...) +{ + va_list arg; + CURLFORMcode form; + va_start(arg, last_post); + form = FormAdd(httppost, last_post, arg); + va_end(arg); + return form; +} + +/* + * curl_formget() + * Serialize a curl_httppost struct. + * Returns 0 on success. + * + * @unittest: 1308 + */ +int curl_formget(struct curl_httppost *form, void *arg, + curl_formget_callback append) +{ + CURLcode result; + curl_mimepart toppart; + + /* Validate callback is provided */ + if(!append) + return (int)CURLE_BAD_FUNCTION_ARGUMENT; + + Curl_mime_initpart(&toppart); /* default form is empty */ + result = Curl_getformdata(NULL, &toppart, form, NULL); + if(!result) + result = Curl_mime_prepare_headers(NULL, &toppart, "multipart/form-data", + NULL, MIMESTRATEGY_FORM); + + while(!result) { + char buffer[8192]; + size_t nread = Curl_mime_read(buffer, 1, sizeof(buffer), &toppart); + + if(!nread) + break; + + if(nread > sizeof(buffer) || append(arg, buffer, nread) != nread) { + result = CURLE_READ_ERROR; + if(nread == CURL_READFUNC_ABORT) + result = CURLE_ABORTED_BY_CALLBACK; + } + } + + Curl_mime_cleanpart(&toppart); + return (int)result; +} + +/* + * curl_formfree() is an external function to free up a whole form post + * chain + */ +void curl_formfree(struct curl_httppost *form) +{ + struct curl_httppost *next; + + if(!form) + /* no form to free, get out of this */ + return; + + do { + next = form->next; /* the following form line */ + + /* recurse to sub-contents */ + curl_formfree(form->more); + + if(!(form->flags & HTTPPOST_PTRNAME)) + curlx_free(form->name); /* free the name */ + if(!(form->flags & + (HTTPPOST_PTRCONTENTS | HTTPPOST_BUFFER | HTTPPOST_CALLBACK))) + curlx_free(form->contents); /* free the contents */ + curlx_free(form->contenttype); /* free the content type */ + curlx_free(form->showfilename); /* free the faked filename */ + curlx_free(form); /* free the struct */ + form = next; + } while(form); /* continue */ +} + +/* Set mime part name, taking care of non null-terminated name string. */ +static CURLcode setname(curl_mimepart *part, const char *name, size_t len) +{ + char *zname; + CURLcode result; + + if(!name || !len) + return curl_mime_name(part, name); + zname = curlx_memdup0(name, len); + if(!zname) + return CURLE_OUT_OF_MEMORY; + result = curl_mime_name(part, zname); + curlx_free(zname); + return result; +} + +/* + * Curl_getformdata() converts a linked list of "meta data" into a mime + * structure. The input list is in 'post', while the output is stored in + * mime part at '*finalform'. + * + * This function will not do a failf() for the potential memory failures but + * should for all other errors it spots. Note that this function MAY get a + * NULL pointer in the 'data' argument. + */ + +CURLcode Curl_getformdata(CURL *data, + curl_mimepart *finalform, + struct curl_httppost *post, + curl_read_callback fread_func) +{ + CURLcode result = CURLE_OK; + curl_mime *form = NULL; + curl_mimepart *part; + struct curl_httppost *file; + + Curl_mime_cleanpart(finalform); /* default form is empty */ + + if(!post) + return result; /* no input => no output! */ + + form = curl_mime_init(data); + if(!form) + result = CURLE_OUT_OF_MEMORY; + + if(!result) + result = curl_mime_subparts(finalform, form); + + /* Process each top part. */ + for(; !result && post; post = post->next) { + /* If we have more than a file here, create a mime subpart and fill it. */ + curl_mime *multipart = form; + if(post->more) { + part = curl_mime_addpart(form); + if(!part) + result = CURLE_OUT_OF_MEMORY; + if(!result) + result = setname(part, post->name, post->namelength); + if(!result) { + multipart = curl_mime_init(data); + if(!multipart) + result = CURLE_OUT_OF_MEMORY; + } + if(!result) + result = curl_mime_subparts(part, multipart); + } + + /* Generate all the part contents. */ + for(file = post; !result && file; file = file->more) { + /* Create the part. */ + part = curl_mime_addpart(multipart); + if(!part) + result = CURLE_OUT_OF_MEMORY; + + /* Set the headers. */ + if(!result) + result = curl_mime_headers(part, file->contentheader, 0); + + /* Set the content type. */ + if(!result && file->contenttype) + result = curl_mime_type(part, file->contenttype); + + /* Set field name. */ + if(!result && !post->more) + result = setname(part, post->name, post->namelength); + + /* Process contents. */ + if(!result) { + curl_off_t clen = post->contentslength; + + if(post->flags & CURL_HTTPPOST_LARGE) + clen = post->contentlen; + + if(post->flags & (HTTPPOST_FILENAME | HTTPPOST_READFILE)) { + if(!strcmp(file->contents, "-")) { + /* There are a few cases where the code below will not work; in + particular, freopen(stdin) by the caller is not guaranteed + to result as expected. This feature has been kept for backward + compatibility: use of "-" pseudo filename should be avoided. */ +#if defined(__clang__) && __clang_major__ >= 16 +#pragma clang diagnostic push +#pragma clang diagnostic ignored "-Wcast-function-type-strict" +#endif + result = curl_mime_data_cb(part, (curl_off_t)-1, + (curl_read_callback)fread, + curlx_fseek, + NULL, (void *)stdin); +#if defined(__clang__) && __clang_major__ >= 16 +#pragma clang diagnostic pop +#endif + } + else + result = curl_mime_filedata(part, file->contents); + if(!result && (post->flags & HTTPPOST_READFILE)) + result = curl_mime_filename(part, NULL); + } + else if(post->flags & HTTPPOST_BUFFER) + result = curl_mime_data(part, post->buffer, + post->bufferlength ? + post->bufferlength : -1); + else if(post->flags & HTTPPOST_CALLBACK) { + /* the contents should be read with the callback and the size is set + with the contentslength */ + if(!clen) + clen = -1; + result = curl_mime_data_cb(part, clen, + fread_func, NULL, NULL, post->userp); + } + else { + size_t uclen; + if(!clen) + uclen = CURL_ZERO_TERMINATED; + else + uclen = (size_t)clen; + result = curl_mime_data(part, post->contents, uclen); + } + } + + /* Set fake filename. */ + if(!result && post->showfilename) + if(post->more || (post->flags & (HTTPPOST_FILENAME | HTTPPOST_BUFFER | + HTTPPOST_CALLBACK))) + result = curl_mime_filename(part, post->showfilename); + } + } + + if(result) + Curl_mime_cleanpart(finalform); + + return result; +} + +#else /* if disabled */ +CURLFORMcode curl_formadd(struct curl_httppost **httppost, + struct curl_httppost **last_post, ...) +{ + (void)httppost; + (void)last_post; + return CURL_FORMADD_DISABLED; +} + +int curl_formget(struct curl_httppost *form, void *arg, + curl_formget_callback append) +{ + (void)form; + (void)arg; + (void)append; + return CURL_FORMADD_DISABLED; +} + +void curl_formfree(struct curl_httppost *form) +{ + (void)form; + /* Nothing to do. */ +} + +#endif /* if disabled */ diff --git a/3rdparty/curl-8.21.0/lib/formdata.h b/3rdparty/curl-8.21.0/lib/formdata.h new file mode 100644 index 0000000000..33d7d0ae33 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/formdata.h @@ -0,0 +1,55 @@ +#ifndef HEADER_CURL_FORMDATA_H +#define HEADER_CURL_FORMDATA_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifndef CURL_DISABLE_FORM_API + +#include "bufref.h" + +/* used by FormAdd for temporary storage */ +struct FormInfo { + struct bufref name; + struct bufref value; + struct bufref contenttype; + struct bufref showfilename; /* The filename to show. If not set, the actual + filename will be used */ + char *buffer; /* pointer to existing buffer used for file upload */ + char *userp; /* pointer for the read callback */ + struct FormInfo *more; + struct curl_slist *contentheader; + curl_off_t contentslength; + size_t namelength; + size_t bufferlength; + unsigned char flags; +}; + +CURLcode Curl_getformdata(CURL *data, + curl_mimepart *finalform, + struct curl_httppost *post, + curl_read_callback fread_func); +#endif /* CURL_DISABLE_FORM_API */ + +#endif /* HEADER_CURL_FORMDATA_H */ diff --git a/3rdparty/curl-8.21.0/lib/ftp-int.h b/3rdparty/curl-8.21.0/lib/ftp-int.h new file mode 100644 index 0000000000..8d7e141274 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/ftp-int.h @@ -0,0 +1,160 @@ +#ifndef HEADER_CURL_FTP_INT_H +#define HEADER_CURL_FTP_INT_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "pingpong.h" + +#ifndef CURL_DISABLE_FTP + +/**************************************************************************** + * FTP unique setup + ***************************************************************************/ +enum { + FTP_STOP, /* do nothing state, stops the state machine */ + FTP_WAIT220, /* waiting for the initial 220 response immediately after + a connect */ + FTP_AUTH, + FTP_USER, + FTP_PASS, + FTP_ACCT, + FTP_PBSZ, + FTP_PROT, + FTP_CCC, + FTP_PWD, + FTP_SYST, + FTP_NAMEFMT, + FTP_QUOTE, /* waiting for a response to a command sent in a quote list */ + FTP_RETR_PREQUOTE, + FTP_STOR_PREQUOTE, + FTP_LIST_PREQUOTE, + FTP_POSTQUOTE, + FTP_CWD, /* change directory */ + FTP_MKD, /* if the directory did not exist */ + FTP_MDTM, /* to figure out the datestamp */ + FTP_TYPE, /* to set type when doing a head-like request */ + FTP_LIST_TYPE, /* set type when about to do a directory list */ + FTP_RETR_LIST_TYPE, + FTP_RETR_TYPE, /* set type when about to RETR a file */ + FTP_STOR_TYPE, /* set type when about to STOR a file */ + FTP_SIZE, /* get the remote file's size for head-like request */ + FTP_RETR_SIZE, /* get the remote file's size for RETR */ + FTP_STOR_SIZE, /* get the size for STOR */ + FTP_REST, /* when used to check if the server supports it in head-like */ + FTP_RETR_REST, /* when asking for "resume" in for RETR */ + FTP_PORT, /* generic state for PORT, LPRT and EPRT, check count1 */ + FTP_PRET, /* generic state for PRET RETR, PRET STOR and PRET LIST/NLST */ + FTP_PASV, /* generic state for PASV and EPSV, check count1 */ + FTP_LIST, /* generic state for LIST, NLST or a custom list command */ + FTP_RETR, + FTP_STOR, /* generic state for STOR and APPE */ + FTP_QUIT, + FTP_LAST /* never used */ +}; +typedef unsigned char ftpstate; /* use the enum values */ + +struct ftp_parselist_data; /* defined later in ftplistparser.c */ + +struct ftp_wc { + struct ftp_parselist_data *parser; + + struct { + curl_write_callback write_function; + FILE *file_descriptor; + } backup; +}; + +/* This FTP struct is used in the Curl_easy. All FTP data that is + connection-oriented must be in FTP_conn to properly deal with the fact that + perhaps the Curl_easy is changed between the times the connection is + used. */ +struct FTP { + char *path; /* points to the urlpieces struct field */ + char *pathalloc; /* if non-NULL a pointer to an allocated path */ + + /* transfer a file/body or not, done as a typedefed enum to make debuggers + display the full symbol and not the numerical value */ + curl_pp_transfer transfer; + curl_off_t downloadsize; +}; + +/* one struct entry for each path component (of 'rawpath') */ +struct pathcomp { + int start; /* start column */ + int len; /* length in bytes */ +}; + +/* ftp_conn is used for struct connection-oriented data in the connectdata + struct */ +struct ftp_conn { + struct pingpong pp; + char *account; + char *alternative_to_user; + char *entrypath; /* the PWD reply when we logged on */ + const char *file; /* URL-decoded filename (or path), points into rawpath */ + char *rawpath; /* URL decoded, allocated, version of the path */ + struct pathcomp *dirs; /* allocated array for path components */ + char *prevpath; /* URL-decoded conn->path from the previous transfer */ + char transfertype; /* set by ftp_transfertype for use by Curl_client_write()a + and others (A/I or zero) */ + char *server_os; /* The target server operating system. */ + curl_off_t known_filesize; /* file size is different from -1, if wildcard + LIST parsing was done and wc_statemach set + it */ + int count1; /* general purpose counter for the state machine */ + int count2; /* general purpose counter for the state machine */ + int count3; /* general purpose counter for the state machine */ + unsigned short dirdepth; /* number of entries used in the 'dirs' array, + < FTP_MAX_DIR_DEPTH */ + unsigned short cwdcount; /* number of CWD commands issued, + < FTP_MAX_DIR_DEPTH */ + unsigned char state; /* (ftpstate enum) always use ftp.c:state() to change + state! */ + unsigned char use_ssl; /* if AUTH TLS is to be attempted etc, for FTP or + IMAP or POP3 or others! (type: curl_usessl)*/ + unsigned char ccc; /* ccc level for this connection */ + BIT(ftp_trying_alternative); + BIT(dont_check); /* Set to TRUE to prevent the final (post-transfer) + file size and 226/250 status check. It should still + read the line, ignore the result. */ + BIT(ctl_valid); /* Tells Curl_ftp_quit() whether or not to do anything. If + the connection has timed out or been closed, this + should be FALSE when it gets to Curl_ftp_quit() */ + BIT(cwddone); /* if it has been determined that the proper CWD combo + already has been done */ + BIT(cwdfail); /* set TRUE if a CWD command fails, as then we must prevent + caching the current directory */ + BIT(wait_data_conn); /* this is set TRUE if data connection is waited */ + BIT(shutdown); /* connection is being shutdown, e.g. QUIT */ +}; + +/* meta key for storing `struct FTP` as easy meta data */ +#define CURL_META_FTP_EASY "meta:proto:ftp:easy" +/* meta key for storing `struct ftp_conn` as connection meta data */ +#define CURL_META_FTP_CONN "meta:proto:ftp:conn" + +#endif /* CURL_DISABLE_FTP */ + +#endif /* HEADER_CURL_FTP_INT_H */ diff --git a/3rdparty/curl-8.21.0/lib/ftp.c b/3rdparty/curl-8.21.0/lib/ftp.c new file mode 100644 index 0000000000..05d17064a0 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/ftp.c @@ -0,0 +1,4498 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" +#include "urldata.h" + +#ifndef CURL_DISABLE_FTP + +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_ARPA_INET_H +#include +#endif +#ifdef HAVE_NETDB_H +#include +#endif +#ifdef __VMS +#include +#include +#endif + +#include "sendf.h" +#include "curl_addrinfo.h" +#include "curl_trc.h" +#include "if2ip.h" +#include "hostip.h" +#include "progress.h" +#include "transfer.h" +#include "escape.h" +#include "ftp.h" +#include "ftp-int.h" +#include "ftplistparser.h" +#include "curl_range.h" +#include "strcase.h" +#include "vtls/vtls.h" +#include "cfilters.h" +#include "cf-socket.h" +#include "connect.h" +#include "curlx/inet_ntop.h" +#include "curlx/inet_pton.h" +#include "select.h" +#include "parsedate.h" /* for the week day and month names */ +#include "sockaddr.h" /* required for Curl_sockaddr_storage */ +#include "multiif.h" +#include "url.h" +#include "http_proxy.h" +#include "curlx/strdup.h" +#include "curlx/strerr.h" +#include "curlx/strparse.h" +#include "curl_ctype.h" + +#ifndef NI_MAXHOST +#define NI_MAXHOST 1025 +#endif +#ifndef INET_ADDRSTRLEN +#define INET_ADDRSTRLEN 16 +#endif + +/* macro to check for a three-digit ftp status code at the start of the + given string */ +#define STATUSCODE(line) \ + (ISDIGIT((line)[0]) && ISDIGIT((line)[1]) && ISDIGIT((line)[2])) + +/* macro to check for the last line in an FTP server response */ +#define LASTLINE(line) (STATUSCODE(line) && (' ' == (line)[3])) + +#ifdef CURLVERBOSE +/* for tracing purposes */ +static const char * const ftp_state_names[] = { + "STOP", + "WAIT220", + "AUTH", + "USER", + "PASS", + "ACCT", + "PBSZ", + "PROT", + "CCC", + "PWD", + "SYST", + "NAMEFMT", + "QUOTE", + "RETR_PREQUOTE", + "STOR_PREQUOTE", + "LIST_PREQUOTE", + "POSTQUOTE", + "CWD", + "MKD", + "MDTM", + "TYPE", + "LIST_TYPE", + "RETR_LIST_TYPE", + "RETR_TYPE", + "STOR_TYPE", + "SIZE", + "RETR_SIZE", + "STOR_SIZE", + "REST", + "RETR_REST", + "PORT", + "PRET", + "PASV", + "LIST", + "RETR", + "STOR", + "QUIT" +}; +#define FTP_CSTATE(ftpc) ((ftpc) ? ftp_state_names[(ftpc)->state] : "???") + +#endif /* CURLVERBOSE */ + +/* This is the ONLY way to change FTP state! */ +static void ftp_state_low(struct Curl_easy *data, + struct ftp_conn *ftpc, + ftpstate newstate +#ifdef DEBUGBUILD + , int lineno +#endif + ) +{ + if(ftpc->state != newstate) { +#ifdef DEBUGBUILD + NOVERBOSE((void)lineno); + CURL_TRC_FTP(data, "[%s] -> [%s] (line %d)", FTP_CSTATE(ftpc), + ftp_state_names[newstate], lineno); +#else + CURL_TRC_FTP(data, "[%s] -> [%s]", FTP_CSTATE(ftpc), + ftp_state_names[newstate]); +#endif + } + ftpc->state = newstate; +} + +/* Local API functions */ +#ifndef DEBUGBUILD +#define ftp_state(x, y, z) ftp_state_low(x, y, z) +#else /* !DEBUGBUILD */ +#define ftp_state(x, y, z) ftp_state_low(x, y, z, __LINE__) +#endif /* DEBUGBUILD */ + +static CURLcode ftp_state_mdtm(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct FTP *ftp); +static CURLcode ftp_state_quote(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct FTP *ftp, + bool init, ftpstate instate); +static CURLcode ftp_nb_type(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct FTP *ftp, + bool ascii, ftpstate newstate); +static CURLcode getftpresponse(struct Curl_easy *data, size_t *nreadp, + int *ftpcodep); + +static void freedirs(struct ftp_conn *ftpc) +{ + curlx_safefree(ftpc->dirs); + ftpc->dirdepth = 0; + curlx_safefree(ftpc->rawpath); + ftpc->file = NULL; +} + +static size_t numof_slashes(const char *str) +{ + const char *slashPos; + size_t num = 0; + do { + slashPos = strchr(str, '/'); + if(slashPos) { + ++num; + str = slashPos + 1; + } + } while(slashPos); + return num; +} + +#define FTP_MAX_DIR_DEPTH 1000 + +/*********************************************************************** + * + * ftp_parse_url_path() + * + * Parse the URL path into separate path components. + * + */ +static CURLcode ftp_parse_url_path(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct FTP *ftp) +{ + const char *slashPos = NULL; + const char *fileName = NULL; + CURLcode result = CURLE_OK; + const char *rawPath = NULL; /* URL-decoded "raw" path */ + size_t pathLen = 0; + + ftpc->ctl_valid = FALSE; + ftpc->cwdfail = FALSE; + + if(ftpc->rawpath) + freedirs(ftpc); + /* URL-decode ftp path before further evaluation */ + result = Curl_urldecode(ftp->path, 0, &ftpc->rawpath, &pathLen, REJECT_CTRL); + if(result) { + failf(data, "path contains control characters"); + return result; + } + rawPath = ftpc->rawpath; + + switch(data->set.ftp_filemethod) { + case FTPFILE_NOCWD: /* fastest, but less standard-compliant */ + + if((pathLen > 0) && (rawPath[pathLen - 1] != '/')) + fileName = rawPath; /* this is a full file path */ + /* + else: ftpc->file is not used anywhere other than for operations on + a file. In other words, never for directory operations, + so we can safely leave filename as NULL here and use it as a + argument in dir/file decisions. + */ + break; + + case FTPFILE_SINGLECWD: + slashPos = strrchr(rawPath, '/'); + if(slashPos) { + /* get path before last slash, except for / */ + size_t dirlen = slashPos - rawPath; + if(dirlen == 0) + dirlen = 1; + + ftpc->dirs = curlx_calloc(1, sizeof(ftpc->dirs[0])); + if(!ftpc->dirs) + return CURLE_OUT_OF_MEMORY; + + ftpc->dirs[0].start = 0; + ftpc->dirs[0].len = (int)dirlen; + ftpc->dirdepth = 1; /* we consider it to be a single directory */ + fileName = slashPos + 1; /* rest is filename */ + } + else + fileName = rawPath; /* filename only (or empty) */ + break; + + default: /* allow pretty much anything */ + case FTPFILE_MULTICWD: { + /* current position: begin of next path component */ + const char *curPos = rawPath; + + /* number of entries to allocate for the 'dirs' array */ + size_t dirAlloc = numof_slashes(rawPath); + + if(dirAlloc >= FTP_MAX_DIR_DEPTH) + /* suspiciously deep directory hierarchy */ + return CURLE_URL_MALFORMAT; + + if(dirAlloc) { + ftpc->dirs = curlx_calloc(dirAlloc, sizeof(ftpc->dirs[0])); + if(!ftpc->dirs) + return CURLE_OUT_OF_MEMORY; + + /* parse the URL path into separate path components */ + while(dirAlloc--) { + const char *spos = strchr(curPos, '/'); + size_t clen = spos - curPos; + + /* path starts with a slash: add that as a directory */ + if(!clen && (ftpc->dirdepth == 0)) + ++clen; + + /* we skip empty path components, like "x//y" since the FTP command + CWD requires a parameter and a non-existent parameter a) does not + work on many servers and b) has no effect on the others. */ + if(clen) { + ftpc->dirs[ftpc->dirdepth].start = (int)(curPos - rawPath); + ftpc->dirs[ftpc->dirdepth].len = (int)clen; + ftpc->dirdepth++; + } + curPos = spos + 1; + } + } + fileName = curPos; /* the rest is the filename (or empty) */ + } + break; + } /* switch */ + + if(fileName && *fileName) + ftpc->file = fileName; + else + ftpc->file = NULL; /* instead of point to a zero byte, + we make it a NULL pointer */ + + if(data->state.upload && !ftpc->file && (ftp->transfer == PPTRANSFER_BODY)) { + /* We need a filename when uploading. Return error! */ + failf(data, "Uploading to a URL without a filename"); + return CURLE_URL_MALFORMAT; + } + + ftpc->cwddone = FALSE; /* default to not done */ + + if((data->set.ftp_filemethod == FTPFILE_NOCWD) && (rawPath[0] == '/')) + ftpc->cwddone = TRUE; /* skip CWD for absolute paths */ + else { /* newly created FTP connections are already in entry path */ + const char *oldPath = data->conn->bits.reuse ? ftpc->prevpath : ""; + if(oldPath) { + size_t n = pathLen; + if(data->set.ftp_filemethod == FTPFILE_NOCWD) + n = 0; /* CWD to entry for relative paths */ + else + n -= ftpc->file ? strlen(ftpc->file) : 0; + + if((strlen(oldPath) == n) && rawPath && !strncmp(rawPath, oldPath, n)) { + infof(data, "Request has same path as previous transfer"); + ftpc->cwddone = TRUE; + } + } + } + + return CURLE_OK; +} + +/*********************************************************************** + * + * ftp_need_type() + * + * Returns TRUE if we in the current situation should send TYPE + */ +static int ftp_need_type(struct ftp_conn *ftpc, + bool ascii_wanted) +{ + return ftpc->transfertype != (ascii_wanted ? 'A' : 'I'); +} + +static void close_secondarysocket(struct Curl_easy *data, + struct ftp_conn *ftpc) +{ + (void)ftpc; + CURL_TRC_FTP(data, "[%s] closing DATA connection", FTP_CSTATE(ftpc)); + Curl_conn_cf_discard_all(data, data->conn, SECONDARYSOCKET); +} + +#ifdef CURL_PREFER_LF_LINEENDS +/* + * Lineend Conversions + * On ASCII transfers, e.g. directory listings, we might get lines + * ending in '\r\n' and we prefer '\n'. + * We might also get a lonely '\r' which we convert into a '\n'. + */ +struct ftp_cw_lc_ctx { + struct Curl_cwriter super; + bool newline_pending; +}; + +static CURLcode ftp_cw_lc_write(struct Curl_easy *data, + struct Curl_cwriter *writer, int type, + const char *buf, size_t blen) +{ + static const char nl = '\n'; + struct ftp_cw_lc_ctx *ctx = writer->ctx; + struct ftp_conn *ftpc = Curl_conn_meta_get(data->conn, CURL_META_FTP_CONN); + + if(!ftpc) + return CURLE_FAILED_INIT; + + if(!(type & CLIENTWRITE_BODY) || ftpc->transfertype != 'A') + return Curl_cwriter_write(data, writer->next, type, buf, blen); + + /* ASCII mode BODY data, convert lineends */ + while(blen) { + /* do not pass EOS when writing parts */ + int chunk_type = (type & ~CLIENTWRITE_EOS); + const char *cp; + size_t chunk_len; + CURLcode result; + + if(ctx->newline_pending) { + if(buf[0] != '\n') { + /* previous chunk ended in '\r' and we do not see a '\n' in this one, + * need to write a newline. */ + result = Curl_cwriter_write(data, writer->next, chunk_type, &nl, 1); + if(result) + return result; + } + /* either we wrote the newline or it is part of the next chunk of bytes + * we write. */ + ctx->newline_pending = FALSE; + } + + cp = memchr(buf, '\r', blen); + if(!cp) + break; + + /* write the bytes before the '\r', excluding the '\r' */ + chunk_len = cp - buf; + if(chunk_len) { + result = Curl_cwriter_write(data, writer->next, chunk_type, + buf, chunk_len); + if(result) + return result; + } + /* skip the '\r', we now have a newline pending */ + buf = cp + 1; + blen = blen - chunk_len - 1; + ctx->newline_pending = TRUE; + } + + /* Any remaining data does not contain a '\r' */ + if(blen) { + DEBUGASSERT(!ctx->newline_pending); + return Curl_cwriter_write(data, writer->next, type, buf, blen); + } + else if(type & CLIENTWRITE_EOS) { + /* EndOfStream, if we have a trailing cr, now is the time to write it */ + if(ctx->newline_pending) { + ctx->newline_pending = FALSE; + return Curl_cwriter_write(data, writer->next, type, &nl, 1); + } + /* Always pass on the EOS type indicator */ + return Curl_cwriter_write(data, writer->next, type, buf, 0); + } + return CURLE_OK; +} + +static const struct Curl_cwtype ftp_cw_lc = { + "ftp-lineconv", + NULL, + Curl_cwriter_def_init, + ftp_cw_lc_write, + Curl_cwriter_def_close, + sizeof(struct ftp_cw_lc_ctx) +}; + +#endif /* CURL_PREFER_LF_LINEENDS */ + +/*********************************************************************** + * + * ftp_check_ctrl_on_data_wait() + * + */ +static CURLcode ftp_check_ctrl_on_data_wait(struct Curl_easy *data, + struct ftp_conn *ftpc) +{ + struct connectdata *conn = data->conn; + curl_socket_t ctrl_sock = conn->sock[FIRSTSOCKET]; + struct pingpong *pp = &ftpc->pp; + size_t nread; + int ftpcode; + bool response = FALSE; + + /* First check whether there is a cached response from server */ + if(curlx_dyn_len(&pp->recvbuf)) { + const char *l = curlx_dyn_ptr(&pp->recvbuf); + if(!ISDIGIT(*l) || (*l > '3')) { + /* Data connection could not be established, let's return */ + infof(data, "There is negative response in cache while serv connect"); + (void)getftpresponse(data, &nread, &ftpcode); + return CURLE_FTP_ACCEPT_FAILED; + } + } + + if(pp->overflow) + /* there is pending control data still in the buffer to read */ + response = TRUE; + else { + int socketstate = SOCKET_READABLE(ctrl_sock, 0); + /* see if the connection request is already here */ + switch(socketstate) { + case -1: /* error */ + /* let's die here */ + failf(data, "Error while waiting for server connect"); + return CURLE_FTP_ACCEPT_FAILED; + default: + if(socketstate & CURL_CSELECT_IN) + response = TRUE; + break; + } + } + + if(response) { + infof(data, "Ctrl conn has data while waiting for data conn"); + if(pp->overflow > 3) { + const char *r = curlx_dyn_ptr(&pp->recvbuf); + size_t len = curlx_dyn_len(&pp->recvbuf); + + DEBUGASSERT((pp->overflow + pp->nfinal) <= curlx_dyn_len(&pp->recvbuf)); + /* move over the most recently handled response line */ + r += pp->nfinal; + len -= pp->nfinal; + + if((len > 3) && LASTLINE(r)) { + curl_off_t status; + if(!curlx_str_number(&r, &status, 999) && (status == 226)) { + /* funny timing situation where we get the final message on the + control connection before traffic on the data connection has been + noticed. Leave the 226 in there and use this as a trigger to read + the data socket. */ + infof(data, "Got 226 before data activity"); + return CURLE_OK; + } + } + } + + (void)getftpresponse(data, &nread, &ftpcode); + + infof(data, "FTP code: %03d", ftpcode); + + if(ftpcode / 100 > 3) + return CURLE_FTP_ACCEPT_FAILED; + + return CURLE_WEIRD_SERVER_REPLY; + } + + return CURLE_OK; +} + +/*********************************************************************** + * + * ftp_initiate_transfer() + * + * After connection from server is accepted this function is called to + * setup transfer parameters and initiate the data transfer. + * + */ +static CURLcode ftp_initiate_transfer(struct Curl_easy *data, + struct ftp_conn *ftpc) +{ + CURLcode result = CURLE_OK; + bool connected; + + CURL_TRC_FTP(data, "ftp_initiate_transfer()"); + result = Curl_conn_connect(data, SECONDARYSOCKET, TRUE, &connected); + if(result || !connected) + return result; + + if(data->state.upload) { + /* When we know we are uploading a specified file, we can get the file + size prior to the actual upload. */ + Curl_pgrsSetUploadSize(data, data->state.infilesize); + + /* FTP upload, shutdown DATA, ignore shutdown errors, as we rely + * on the server response on the CONTROL connection. */ + Curl_xfer_setup_send(data, SECONDARYSOCKET); + Curl_xfer_set_shutdown(data, TRUE, TRUE); + } + else { + /* FTP download, shutdown, do not ignore errors */ + Curl_xfer_setup_recv(data, SECONDARYSOCKET, data->req.size); + Curl_xfer_set_shutdown(data, TRUE, FALSE); + } + + ftpc->pp.pending_resp = TRUE; /* expect server response */ + ftp_state(data, ftpc, FTP_STOP); + + return CURLE_OK; +} + +static bool ftp_endofresp(struct Curl_easy *data, struct connectdata *conn, + const char *line, size_t len, int *code) +{ + curl_off_t status; + (void)data; + (void)conn; + + if((len > 3) && LASTLINE(line) && !curlx_str_number(&line, &status, 999)) { + *code = (int)status; + return TRUE; + } + + return FALSE; +} + +static CURLcode ftp_readresp(struct Curl_easy *data, + struct ftp_conn *ftpc, + int sockindex, + struct pingpong *pp, + int *ftpcodep, /* return the ftp-code if done */ + size_t *size) /* size of the response */ +{ + int code; + CURLcode result = Curl_pp_readresp(data, sockindex, pp, &code, size); + DEBUGASSERT(ftpcodep); + + /* store the latest code for later retrieval, except during shutdown */ + if(!ftpc->shutdown) + data->info.httpcode = code; + + *ftpcodep = code; + + if(code == 421) { + /* 421 means "Service not available, closing control connection." and FTP + * servers use it to signal that idle session timeout has been exceeded. + * If we ignored the response, it could end up hanging in some cases. + * + * This response code can come at any point so having it treated + * generically is a good idea. + */ + infof(data, "We got a 421 - timeout"); + ftp_state(data, ftpc, FTP_STOP); + return CURLE_OPERATION_TIMEDOUT; + } + + return result; +} + +/* --- parse FTP server responses --- */ + +/* + * getftpresponse() is a BLOCKING function to read the full response from a + * server after a command. + * + */ +static CURLcode getftpresponse(struct Curl_easy *data, + size_t *nreadp, /* return number of bytes + read */ + int *ftpcodep) /* return the ftp-code */ +{ + /* + * We cannot read one byte per read() and then go back to select() as the + * OpenSSL read() does not grok that properly. + * + * Alas, read as much as possible, split up into lines, use the ending + * line in a response or continue reading. */ + + struct connectdata *conn = data->conn; + curl_socket_t sockfd = conn->sock[FIRSTSOCKET]; + CURLcode result = CURLE_OK; + struct ftp_conn *ftpc = Curl_conn_meta_get(data->conn, CURL_META_FTP_CONN); + struct pingpong *pp = &ftpc->pp; + size_t nread; + int cache_skip = 0; + DEBUGASSERT(ftpcodep); + + CURL_TRC_FTP(data, "getftpresponse start"); + *nreadp = 0; + *ftpcodep = 0; /* 0 for errors */ + + if(!ftpc) + return CURLE_FAILED_INIT; + + while(!*ftpcodep && !result) { + /* check and reset timeout value every lap */ + timediff_t timeout = Curl_pp_state_timeleft_ms(data, pp); + timediff_t interval_ms; + + if(timeout <= 0) { + failf(data, "FTP response timeout"); + return CURLE_OPERATION_TIMEDOUT; /* already too little time */ + } + + interval_ms = 1000; /* use 1 second timeout intervals */ + if(timeout < interval_ms) + interval_ms = timeout; + + /* + * Since this function is blocking, we need to wait here for input on the + * connection and only then we call the response reading function. We do + * timeout at least every second to make the timeout check run. + * + * A caution here is that the ftp_readresp() function has a cache that may + * contain pieces of a response from the previous invoke and we need to + * make sure we do not wait for input while there is unhandled data in + * that cache. Also, if the cache is there, we call ftp_readresp() and + * the cache was not good enough to continue we must not busy-loop around + * this function. + * + */ + + if(curlx_dyn_len(&pp->recvbuf) && (cache_skip < 2)) { + /* + * There is a cache left since before. We then skipping the wait for + * socket action, unless this is the same cache like the previous round + * as then the cache was deemed not enough to act on and we then need to + * wait for more data anyway. + */ + } + else if(!Curl_conn_data_pending(data, FIRSTSOCKET)) { + curl_socket_t wsock = Curl_pp_needs_flush(data, pp) ? + sockfd : CURL_SOCKET_BAD; + int ev = Curl_socket_check(sockfd, CURL_SOCKET_BAD, wsock, interval_ms); + if(ev < 0) { + failf(data, "FTP response aborted due to select/poll error: %d", + SOCKERRNO); + return CURLE_RECV_ERROR; + } + else if(ev == 0) { + result = Curl_pgrsUpdate(data); + continue; /* continue in our loop for the timeout duration */ + } + } + + if(Curl_pp_needs_flush(data, pp)) { + result = Curl_pp_flushsend(data, pp); + if(result) + break; + } + + result = ftp_readresp(data, ftpc, FIRSTSOCKET, pp, ftpcodep, &nread); + if(result) + break; + + if(!nread && curlx_dyn_len(&pp->recvbuf)) + /* bump cache skip counter as on repeated skips we must wait for more + data */ + cache_skip++; + else + /* when we got data or there is no cache left, we reset the cache skip + counter */ + cache_skip = 0; + + *nreadp += nread; + + } /* while there is buffer left and loop is requested */ + + pp->pending_resp = FALSE; + CURL_TRC_FTP(data, "getftpresponse -> result=%d, nread=%zu, ftpcode=%d", + (int)result, *nreadp, *ftpcodep); + + return result; +} + +static CURLcode ftp_state_user(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct connectdata *conn) +{ + CURLcode result = Curl_pp_sendf(data, &ftpc->pp, "USER %s", + Curl_creds_user(conn->creds)); + if(!result) { + ftpc->ftp_trying_alternative = FALSE; + ftp_state(data, ftpc, FTP_USER); + } + return result; +} + +static CURLcode ftp_state_pwd(struct Curl_easy *data, + struct ftp_conn *ftpc) +{ + CURLcode result; +#ifdef DEBUGBUILD + if(!data->id && getenv("CURL_FTP_PWD_STOP")) + return CURLE_OK; +#endif + result = Curl_pp_sendf(data, &ftpc->pp, "%s", "PWD"); + if(!result) + ftp_state(data, ftpc, FTP_PWD); + + return result; +} + +/* For the FTP "protocol connect" and "doing" phases only */ +static CURLcode ftp_pollset(struct Curl_easy *data, + struct easy_pollset *ps) +{ + struct ftp_conn *ftpc = Curl_conn_meta_get(data->conn, CURL_META_FTP_CONN); + return ftpc ? Curl_pp_pollset(data, &ftpc->pp, ps) : CURLE_OK; +} + +/* For the FTP "DO_MORE" phase only */ +static CURLcode ftp_domore_pollset(struct Curl_easy *data, + struct easy_pollset *ps) +{ + struct ftp_conn *ftpc = Curl_conn_meta_get(data->conn, CURL_META_FTP_CONN); + + if(!ftpc) + return CURLE_OK; + + /* When in DO_MORE state, we could be either waiting for us to connect to a + * remote site, or we could wait for that site to connect to us. Or handle + * ordinary commands. + */ + CURL_TRC_FTP(data, "[%s] ftp_domore_pollset()", FTP_CSTATE(ftpc)); + + if(FTP_STOP == ftpc->state) { + /* if stopped and still in this state, then we are also waiting for a + connect on the secondary connection */ + DEBUGASSERT(data->conn->sock[SECONDARYSOCKET] != CURL_SOCKET_BAD || + (data->conn->cfilter[SECONDARYSOCKET] && + !Curl_conn_is_connected(data->conn, SECONDARYSOCKET))); + /* An unconnected SECONDARY will add its socket by itself + * via its adjust_pollset() */ + return Curl_pollset_add_in(data, ps, data->conn->sock[FIRSTSOCKET]); + } + return Curl_pp_pollset(data, &ftpc->pp, ps); +} + +static int pathlen(struct ftp_conn *ftpc, int num) +{ + DEBUGASSERT(ftpc->dirs); + DEBUGASSERT(ftpc->dirdepth > num); + return ftpc->dirs[num].len; +} + +static const char *pathpiece(struct ftp_conn *ftpc, int num) +{ + DEBUGASSERT(ftpc->dirs); + DEBUGASSERT(ftpc->dirdepth > num); + return &ftpc->rawpath[ftpc->dirs[num].start]; +} + +/* This is called after the FTP_QUOTE state is passed. + + ftp_state_cwd() sends the range of CWD commands to the server to change to + the correct directory. It may also need to send MKD commands to create + missing ones, if that option is enabled. +*/ +static CURLcode ftp_state_cwd(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct FTP *ftp) +{ + CURLcode result = CURLE_OK; + + if(ftpc->cwddone) + /* already done and fine */ + result = ftp_state_mdtm(data, ftpc, ftp); + else { + /* FTPFILE_NOCWD with full path: expect ftpc->cwddone! */ + DEBUGASSERT((data->set.ftp_filemethod != FTPFILE_NOCWD) || + !(ftpc->dirdepth && ftpc->rawpath[0] == '/')); + + ftpc->count2 = 0; /* count2 counts failed CWDs */ + + if(data->conn->bits.reuse && ftpc->entrypath && + /* no need to go to entrypath when we have an absolute path */ + !(ftpc->dirdepth && ftpc->rawpath[0] == '/')) { + /* This is a reused connection. Since we change directory to where the + transfer is taking place, we must first get back to the original dir + where we ended up after login: */ + ftpc->cwdcount = 0; /* we count this as the first path, then we add one + for all upcoming ones in the ftp->dirs[] array */ + result = Curl_pp_sendf(data, &ftpc->pp, "CWD %s", ftpc->entrypath); + if(!result) + ftp_state(data, ftpc, FTP_CWD); + } + else { + if(ftpc->dirdepth) { + ftpc->cwdcount = 1; + /* issue the first CWD, the rest is sent when the CWD responses are + received... */ + result = Curl_pp_sendf(data, &ftpc->pp, "CWD %.*s", + pathlen(ftpc, 0), pathpiece(ftpc, 0)); + if(!result) + ftp_state(data, ftpc, FTP_CWD); + } + else { + /* No CWD necessary */ + result = ftp_state_mdtm(data, ftpc, ftp); + } + } + } + return result; +} + +typedef enum { + EPRT, + PORT, + DONE +} ftpport; + +/* + * Parse the CURLOPT_FTPPORT string + * "(ipv4|ipv6|domain|interface)?(:port(-range)?)?" + * and extract addr/addrlen and port_min/port_max. + */ +static CURLcode ftp_port_parse_string(struct Curl_easy *data, + struct connectdata *conn, + const char *string_ftpport, + struct Curl_sockaddr_storage *ss, + unsigned short *port_minp, + unsigned short *port_maxp, + const char **hostp, + char *hbuf, size_t hbuflen) +{ + const char *ip_end = NULL; + const char *addr = NULL; + size_t addrlen = 0; + unsigned short port_min = 0; + unsigned short port_max = 0; + char ipstr[50]; +#ifndef USE_IPV6 + (void)conn; + (void)ss; +#endif + + /* default to nothing */ + *hostp = NULL; + *port_minp = *port_maxp = 0; + + if(!string_ftpport || (strlen(string_ftpport) <= 1)) + goto done; + +#ifdef USE_IPV6 + if(*string_ftpport == '[') { + /* [ipv6]:port(-range) */ + const char *ip_start = string_ftpport + 1; + ip_end = strchr(ip_start, ']'); + if(ip_end) { + addrlen = ip_end - ip_start; + addr = ip_start; + } + } + else +#endif + if(*string_ftpport == ':') { + /* :port */ + ip_end = string_ftpport; + } + else { + ip_end = strchr(string_ftpport, ':'); + addr = string_ftpport; + if(ip_end) { +#ifdef USE_IPV6 + struct sockaddr_in6 * const sa6 = (void *)ss; +#endif + /* either ipv6 or (ipv4|domain|interface):port(-range) */ + addrlen = ip_end - string_ftpport; +#ifdef USE_IPV6 + if(curlx_inet_pton(AF_INET6, string_ftpport, &sa6->sin6_addr) == 1) { + /* ipv6 */ + addrlen = strlen(string_ftpport); + ip_end = NULL; /* this got no port ! */ + } +#endif + } + else + /* ipv4|interface */ + addrlen = strlen(string_ftpport); + } + + /* parse the port */ + if(ip_end) { + const char *portp = strchr(ip_end, ':'); + if(portp) { + curl_off_t start; + curl_off_t end; + portp++; + if(!curlx_str_number(&portp, &start, 0xffff)) { + port_min = (unsigned short)start; + if(!curlx_str_single(&portp, '-') && + !curlx_str_number(&portp, &end, 0xffff)) + port_max = (unsigned short)end; + else + port_max = port_min; + } + } + } + + /* correct errors like :1234-1230 or :-4711 */ + if(port_min > port_max) + port_min = port_max = 0; + + if(addrlen) { + const struct Curl_sockaddr_ex *remote_addr = + Curl_conn_get_remote_addr(data, FIRSTSOCKET); + + DEBUGASSERT(remote_addr); + DEBUGASSERT(addr); + if(!remote_addr || (addrlen >= sizeof(ipstr)) || (addrlen >= hbuflen)) + return CURLE_FTP_PORT_FAILED; + memcpy(ipstr, addr, addrlen); + ipstr[addrlen] = 0; + + /* attempt to get the address of the given interface name */ + switch(Curl_if2ip(remote_addr->family, +#ifdef USE_IPV6 + Curl_ipv6_scope(&remote_addr->curl_sa_addr), + conn->scope_id, +#endif + ipstr, hbuf, hbuflen)) { + case IF2IP_NOT_FOUND: + /* not an interface, use the string as hostname instead */ + memcpy(hbuf, addr, addrlen); + hbuf[addrlen] = 0; + *hostp = hbuf; + break; + case IF2IP_AF_NOT_SUPPORTED: + return CURLE_FTP_PORT_FAILED; + case IF2IP_FOUND: + *hostp = hbuf; /* use the hbuf for hostname */ + break; + } + } + /* else: only a port(-range) given, leave host as NULL */ + +done: + *port_minp = port_min; + *port_maxp = port_max; + return CURLE_OK; +} + +/* + * If no host was derived from the FTPPORT string, fall back to the IP address + * of the control connection's local socket. + */ +static CURLcode ftp_port_default_host(struct Curl_easy *data, + struct connectdata *conn, + struct Curl_sockaddr_storage *ss, + curl_socklen_t *sslenp, + const char **hostp, + char *hbuf, size_t hbuflen, + bool *non_localp) +{ + struct sockaddr *sa = (struct sockaddr *)ss; + struct sockaddr_in * const sa4 = (void *)sa; +#ifdef USE_IPV6 + struct sockaddr_in6 * const sa6 = (void *)sa; +#endif + char buffer[STRERROR_LEN]; + const char *r; + + *sslenp = sizeof(*ss); + if(getsockname(conn->sock[FIRSTSOCKET], sa, sslenp)) { + failf(data, "getsockname() failed: %s", + curlx_strerror(SOCKERRNO, buffer, sizeof(buffer))); + return CURLE_FTP_PORT_FAILED; + } + switch(sa->sa_family) { +#ifdef USE_IPV6 + case AF_INET6: + r = curlx_inet_ntop(sa->sa_family, &sa6->sin6_addr, hbuf, hbuflen); + break; +#endif + default: + r = curlx_inet_ntop(sa->sa_family, &sa4->sin_addr, hbuf, hbuflen); + break; + } + if(!r) + return CURLE_FTP_PORT_FAILED; + + *hostp = hbuf; + *non_localp = FALSE; /* we know it is local now */ + return CURLE_OK; +} + +/* + * Resolve the host string to a list of addresses. + */ +static CURLcode ftp_port_resolve_host(struct Curl_easy *data, + struct connectdata *conn, + const char *host, + struct Curl_dns_entry **dns_entryp, + const struct Curl_addrinfo **resp) +{ + CURLcode result; + + *resp = NULL; + result = Curl_resolv_blocking( + data, Curl_resolv_dns_queries(data, conn->ip_version), + host, 0, Curl_conn_get_transport(data, conn), dns_entryp); + if(result) + failf(data, "failed to resolve the address provided to PORT: %s", host); + else { + DEBUGASSERT(*dns_entryp); + *resp = (*dns_entryp)->addr; + } + return result; +} + +/* + * Open a TCP socket for the resolved address family. + */ +static CURLcode ftp_port_open_socket(struct Curl_easy *data, + struct connectdata *conn, + const struct Curl_addrinfo *res, + const struct Curl_addrinfo **aip, + curl_socket_t *portsockp) +{ + char buffer[STRERROR_LEN]; + int sockerr = 0; + const struct Curl_addrinfo *ai; + CURLcode result = CURLE_FTP_PORT_FAILED; + + for(ai = res; ai; ai = ai->ai_next) { + result = + Curl_socket_open(data, ai, NULL, + Curl_conn_get_transport(data, conn), portsockp); + if(result) { + if(result == CURLE_OUT_OF_MEMORY) + return result; + result = CURLE_FTP_PORT_FAILED; + sockerr = SOCKERRNO; + continue; + } + break; + } + if(!ai) { + failf(data, "socket failure: %s", + curlx_strerror(sockerr, buffer, sizeof(buffer))); + return CURLE_FTP_PORT_FAILED; + } + *aip = ai; + return result; +} + +/* + * Bind the socket to a local address and port within the requested range. + * Falls back to the control-connection address if the user-requested address + * is non-local. + */ +static CURLcode ftp_port_bind_socket(struct Curl_easy *data, + struct connectdata *conn, + curl_socket_t portsock, + const struct Curl_addrinfo *ai, + struct Curl_sockaddr_storage *ss, + curl_socklen_t *sslen_io, + unsigned short port_min, + unsigned short port_max, + bool non_local) +{ + struct sockaddr *sa = (struct sockaddr *)ss; + struct sockaddr_in * const sa4 = (void *)sa; +#ifdef USE_IPV6 + struct sockaddr_in6 * const sa6 = (void *)sa; +#endif + char buffer[STRERROR_LEN]; + unsigned short port; + int sockerr; + + memcpy(sa, ai->ai_addr, ai->ai_addrlen); + *sslen_io = ai->ai_addrlen; + + for(port = port_min; port <= port_max;) { + if(sa->sa_family == AF_INET) + sa4->sin_port = htons(port); +#ifdef USE_IPV6 + else + sa6->sin6_port = htons(port); +#endif + if(bind(portsock, sa, *sslen_io)) { + sockerr = SOCKERRNO; + if(non_local && (sockerr == SOCKEADDRNOTAVAIL)) { + /* The requested bind address is not local. Use the address used for + * the control connection instead and restart the port loop. + */ + infof(data, "bind(port=%hu) on non-local address failed: %s", port, + curlx_strerror(sockerr, buffer, sizeof(buffer))); + + *sslen_io = sizeof(*ss); + if(getsockname(conn->sock[FIRSTSOCKET], sa, sslen_io)) { + failf(data, "getsockname() failed: %s", + curlx_strerror(SOCKERRNO, buffer, sizeof(buffer))); + return CURLE_FTP_PORT_FAILED; + } + port = port_min; + non_local = FALSE; /* do not try this again */ + continue; + } + if(sockerr != SOCKEADDRINUSE && sockerr != SOCKEACCES) { + failf(data, "bind(port=%hu) failed: %s", port, + curlx_strerror(sockerr, buffer, sizeof(buffer))); + return CURLE_FTP_PORT_FAILED; + } + } + else + break; + + /* check if port is the maximum value here, because it might be 0xffff + and then the increment below will wrap the 16-bit counter */ + if(port == port_max) { + failf(data, "bind() failed, ran out of ports"); + return CURLE_FTP_PORT_FAILED; + } + port++; + } + + /* re-read the name so we can extract the actual port chosen */ + *sslen_io = sizeof(*ss); + if(getsockname(portsock, sa, sslen_io)) { + failf(data, "getsockname() failed: %s", + curlx_strerror(SOCKERRNO, buffer, sizeof(buffer))); + return CURLE_FTP_PORT_FAILED; + } + CURL_TRC_FTP(data, "ftp_port_bind_socket(), socket bound to port %d", port); + return CURLE_OK; +} + +/* + * Start listening on the data socket. + */ +static CURLcode ftp_port_listen(struct Curl_easy *data, curl_socket_t portsock) +{ + char buffer[STRERROR_LEN]; + + if(listen(portsock, 1)) { + failf(data, "socket failure: %s", + curlx_strerror(SOCKERRNO, buffer, sizeof(buffer))); + return CURLE_FTP_PORT_FAILED; + } + CURL_TRC_FTP(data, "ftp_port_listen(), listening on port"); + return CURLE_OK; +} + +/* + * Send the EPRT or PORT command to the server. + */ +static CURLcode ftp_port_send_command(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct connectdata *conn, + struct Curl_sockaddr_storage *ss, + const struct Curl_addrinfo *ai, + ftpport fcmd) +{ + static const char mode[][5] = { "EPRT", "PORT" }; + struct sockaddr *sa = (struct sockaddr *)ss; + struct sockaddr_in * const sa4 = (void *)sa; +#ifdef USE_IPV6 + struct sockaddr_in6 * const sa6 = (void *)sa; +#endif + char myhost[MAX_IPADR_LEN + 1] = ""; + unsigned short port; + CURLcode result; + + /* Get a plain printable version of the numerical address to work with. This + logic uses the address provided by the FTPPORT option, which at times + might differ from the address in 'ss' used to bind to: when a user asks + the server to connect to a specific address knowing that it works, but + curl instead selects to listen to the local address because it cannot use + the provided address. FTP is strange. */ + Curl_printable_address(ai, myhost, sizeof(myhost)); + +#ifdef USE_IPV6 + if(!conn->bits.ftp_use_eprt && conn->bits.ipv6) + /* EPRT is disabled but we are connected to an IPv6 host, so we ignore the + request and enable EPRT again! */ + conn->bits.ftp_use_eprt = TRUE; +#endif + + for(; fcmd != DONE; fcmd++) { + + if(!conn->bits.ftp_use_eprt && (EPRT == fcmd)) + /* if disabled, goto next */ + continue; + + if((PORT == fcmd) && sa->sa_family != AF_INET) + /* PORT is IPv4 only */ + continue; + + switch(sa->sa_family) { + case AF_INET: + port = ntohs(sa4->sin_port); + break; +#ifdef USE_IPV6 + case AF_INET6: + port = ntohs(sa6->sin6_port); + break; +#endif + default: + continue; /* might as well skip this */ + } + + if(EPRT == fcmd) { + /* + * Two fine examples from RFC2428; + * + * EPRT |1|132.235.1.2|6275| + * + * EPRT |2|1080::8:800:200C:417A|5282| + */ + result = Curl_pp_sendf(data, &ftpc->pp, "%s |%d|%s|%hu|", mode[fcmd], + sa->sa_family == AF_INET ? 1 : 2, myhost, port); + if(result) { + failf(data, "Failure sending EPRT command: %s", + curl_easy_strerror(result)); + return result; + } + break; + } + if(PORT == fcmd) { + /* large enough for [IP address],[num],[num] */ + char target[sizeof(myhost) + 20]; + const char *source = myhost; + char *dest = target; + + /* translate x.x.x.x to x,x,x,x */ + while(*source) { + if(*source == '.') + *dest = ','; + else + *dest = *source; + dest++; + source++; + } + *dest = 0; + curl_msnprintf(dest, 20, ",%d,%d", (int)(port >> 8), (int)(port & 0xff)); + + result = Curl_pp_sendf(data, &ftpc->pp, "%s %s", mode[fcmd], target); + if(result) { + failf(data, "Failure sending PORT command: %s", + curl_easy_strerror(result)); + return result; + } + break; + } + } + + /* store which command was sent */ + ftpc->count1 = fcmd; + ftp_state(data, ftpc, FTP_PORT); + return CURLE_OK; +} + +/* + * ftp_state_use_port() + * + * Set up an active-mode FTP data connection (using PORT or EPRT) and start + * listening for the server's incoming connection on SECONDARYSOCKET. + */ +static CURLcode ftp_state_use_port(struct Curl_easy *data, + struct ftp_conn *ftpc, + ftpport fcmd) /* start with this */ +{ + CURLcode result = CURLE_FTP_PORT_FAILED; + struct connectdata *conn = data->conn; + curl_socket_t portsock = CURL_SOCKET_BAD; + + struct Curl_sockaddr_storage ss; + curl_socklen_t sslen; + char hbuf[NI_MAXHOST]; + const char *host = NULL; + const char *string_ftpport = data->set.str[STRING_FTPPORT]; + struct Curl_dns_entry *dns_entry = NULL; + const struct Curl_addrinfo *res = NULL; + const struct Curl_addrinfo *ai = NULL; + unsigned short port_min = 0; + unsigned short port_max = 0; + bool non_local = TRUE; + + /* parse the FTPPORT string for address and port range */ + result = ftp_port_parse_string(data, conn, string_ftpport, + &ss, &port_min, &port_max, + &host, hbuf, sizeof(hbuf)); + if(!result && !host) + /* if no host was specified, use the control connection's local IP */ + result = ftp_port_default_host(data, conn, &ss, &sslen, &host, + hbuf, sizeof(hbuf), &non_local); + + /* resolve host string to address list */ + if(!result) + result = ftp_port_resolve_host(data, conn, host, &dns_entry, &res); + + /* Open a TCP socket for the data connection */ + if(!result) + result = ftp_port_open_socket(data, conn, res, &ai, &portsock); + if(!result) { + CURL_TRC_FTP(data, "[%s] ftp_state_use_port(), opened socket", + FTP_CSTATE(ftpc)); + + /* bind to a suitable local address / port */ + result = ftp_port_bind_socket(data, conn, portsock, ai, &ss, &sslen, + port_min, port_max, non_local); + } + + /* listen */ + if(!result) + result = ftp_port_listen(data, portsock); + + /* send the PORT / EPRT command */ + if(!result) + result = ftp_port_send_command(data, ftpc, conn, &ss, ai, fcmd); + + /* replace any filter on SECONDARY with one listening on this socket */ + if(!result) + result = Curl_conn_tcp_listen_set(data, conn, SECONDARYSOCKET, &portsock); + + if(!result) + portsock = CURL_SOCKET_BAD; /* now held in filter */ + + /* cleanup */ + + if(dns_entry) + Curl_dns_entry_unlink(data, &dns_entry); + if(result) { + ftp_state(data, ftpc, FTP_STOP); + } + else { + /* successfully set up the listen socket filter. SSL needed? + * Use the control connections origin for cert verification. */ + if(conn->bits.ftp_use_data_ssl && data->set.ftp_use_port && + !Curl_conn_is_ssl(conn, SECONDARYSOCKET)) { + result = Curl_ssl_cfilter_add( + data, Curl_conn_get_origin(conn, FIRSTSOCKET), + conn, SECONDARYSOCKET); + } + conn->bits.do_more = FALSE; + Curl_pgrsTime(data, TIMER_STARTACCEPT); + Curl_expire(data, (data->set.accepttimeout > 0) ? + data->set.accepttimeout: DEFAULT_ACCEPT_TIMEOUT, + EXPIRE_FTP_ACCEPT); + } + if(portsock != CURL_SOCKET_BAD) + Curl_socket_close(data, conn, portsock); + return result; +} + +static CURLcode ftp_state_use_pasv(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct connectdata *conn) +{ + CURLcode result = CURLE_OK; + /* + Here's the executive summary on what to do: + + PASV is RFC959, expect: + 227 Entering Passive Mode (a1,a2,a3,a4,p1,p2) + + LPSV is RFC1639, expect: + 228 Entering Long Passive Mode (4,4,a1,a2,a3,a4,2,p1,p2) + + EPSV is RFC2428, expect: + 229 Entering Extended Passive Mode (|||port|) + + */ + + static const char mode[][5] = { "EPSV", "PASV" }; + int modeoff; + +#ifdef PF_INET6 + if(!conn->bits.ftp_use_epsv && conn->bits.ipv6) + /* EPSV is disabled but we are connected to an IPv6 host, so we ignore the + request and enable EPSV again! */ + conn->bits.ftp_use_epsv = TRUE; +#endif + + modeoff = conn->bits.ftp_use_epsv ? 0 : 1; + + result = Curl_pp_sendf(data, &ftpc->pp, "%s", mode[modeoff]); + if(!result) { + ftpc->count1 = modeoff; + ftp_state(data, ftpc, FTP_PASV); + infof(data, "Connect data stream passively"); + } + return result; +} + +/* + * ftp_state_prepare_transfer() starts PORT, PASV or PRET etc. + * + * REST is the last command in the chain of commands when a "head"-like + * request is made. Thus, if an actual transfer is to be made this is where we + * take off for real. + */ +static CURLcode ftp_state_prepare_transfer(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct FTP *ftp) +{ + CURLcode result = CURLE_OK; + struct connectdata *conn = data->conn; + + if(ftp->transfer != PPTRANSFER_BODY) { + /* does not transfer any data */ + + /* still possibly do PRE QUOTE jobs */ + ftp_state(data, ftpc, FTP_RETR_PREQUOTE); + result = ftp_state_quote(data, ftpc, ftp, TRUE, FTP_RETR_PREQUOTE); + } + else if(data->set.ftp_use_port) { + /* We have chosen to use the PORT (or similar) command */ + result = ftp_state_use_port(data, ftpc, EPRT); + } + else { + /* We have chosen (this is default) to use the PASV (or similar) command */ + if(data->set.ftp_use_pret) { + /* The user has requested that we send a PRET command + to prepare the server for the upcoming PASV */ + if(!ftpc->file) + result = Curl_pp_sendf(data, &ftpc->pp, "PRET %s", + data->set.str[STRING_CUSTOMREQUEST] ? + data->set.str[STRING_CUSTOMREQUEST] : + (data->state.list_only ? "NLST" : "LIST")); + else if(data->state.upload) + result = Curl_pp_sendf(data, &ftpc->pp, "PRET STOR %s", ftpc->file); + else + result = Curl_pp_sendf(data, &ftpc->pp, "PRET RETR %s", ftpc->file); + if(!result) + ftp_state(data, ftpc, FTP_PRET); + } + else + result = ftp_state_use_pasv(data, ftpc, conn); + } + return result; +} + +static CURLcode ftp_state_rest(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct FTP *ftp) +{ + CURLcode result = CURLE_OK; + + if((ftp->transfer != PPTRANSFER_BODY) && ftpc->file) { + /* if a "head"-like request is being made (on a file) */ + + /* Determine if server can respond to REST command and therefore + whether it supports range */ + result = Curl_pp_sendf(data, &ftpc->pp, "REST %d", 0); + if(!result) + ftp_state(data, ftpc, FTP_REST); + } + else + result = ftp_state_prepare_transfer(data, ftpc, ftp); + + return result; +} + +static CURLcode ftp_state_size(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct FTP *ftp) +{ + CURLcode result = CURLE_OK; + + if((ftp->transfer == PPTRANSFER_INFO) && ftpc->file) { + /* if a "head"-like request is being made (on a file) */ + + /* we know ftpc->file is a valid pointer to a filename */ + result = Curl_pp_sendf(data, &ftpc->pp, "SIZE %s", ftpc->file); + if(!result) + ftp_state(data, ftpc, FTP_SIZE); + } + else + result = ftp_state_rest(data, ftpc, ftp); + + return result; +} + +static CURLcode ftp_state_list(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct FTP *ftp) +{ + CURLcode result = CURLE_OK; + + /* If this output is to be machine-parsed, the NLST command might be better + to use, since the LIST command output is not specified or standard in any + way. It has turned out that the NLST list output is not the same on all + servers either... */ + + /* + if FTPFILE_NOCWD was specified, we should add the path + as argument for the LIST / NLST / or custom command. + Whether the server will support this, is uncertain. + + The other ftp_filemethods will CWD into dir/dir/ first and + then do LIST (in that case: nothing to do here) + */ + const char *lstArg = NULL; + int lstArglen = 0; + char *cmd; + + if((data->set.ftp_filemethod == FTPFILE_NOCWD) && ftp->path) { + /* URL-decode before evaluation: e.g. paths starting/ending with %2f */ + const char *rawPath = ftpc->rawpath; + const char *slashPos = strrchr(rawPath, '/'); + if(slashPos) { + /* chop off the file part if format is dir/file otherwise remove + the trailing slash for dir/dir/ except for absolute path / */ + size_t n = slashPos - rawPath; + if(n == 0) + ++n; + + lstArg = rawPath; + lstArglen = (int)n; + } + } + + cmd = curl_maprintf("%s%s%.*s", + data->set.str[STRING_CUSTOMREQUEST] ? + data->set.str[STRING_CUSTOMREQUEST] : + (data->state.list_only ? "NLST" : "LIST"), + lstArg ? " " : "", + lstArglen, lstArg ? lstArg : ""); + + if(!cmd) + return CURLE_OUT_OF_MEMORY; + + result = Curl_pp_sendf(data, &ftpc->pp, "%s", cmd); + curlx_free(cmd); + + if(!result) + ftp_state(data, ftpc, FTP_LIST); + + return result; +} + +static CURLcode ftp_state_list_prequote(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct FTP *ftp) +{ + /* We have sent the TYPE, now we must send the list of prequote strings */ + return ftp_state_quote(data, ftpc, ftp, TRUE, FTP_LIST_PREQUOTE); +} + +static CURLcode ftp_state_retr_prequote(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct FTP *ftp) +{ + /* We have sent the TYPE, now we must send the list of prequote strings */ + return ftp_state_quote(data, ftpc, ftp, TRUE, FTP_RETR_PREQUOTE); +} + +static CURLcode ftp_state_stor_prequote(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct FTP *ftp) +{ + /* We have sent the TYPE, now we must send the list of prequote strings */ + return ftp_state_quote(data, ftpc, ftp, TRUE, FTP_STOR_PREQUOTE); +} + +static CURLcode ftp_state_type(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct FTP *ftp) +{ + CURLcode result = CURLE_OK; + + /* If we have selected NOBODY and HEADER, it means that we only want file + information. Which in FTP cannot be much more than the file size and + date. */ + if(data->req.no_body && ftpc->file && + ftp_need_type(ftpc, (bool)data->state.prefer_ascii)) { + /* The SIZE command is _not_ RFC 959 specified, and therefore many servers + may not support it! It is however the only way we have to get a file's + size! */ + + ftp->transfer = PPTRANSFER_INFO; + /* this means no actual transfer will be made */ + + /* Some servers return different sizes for different modes, and thus we + must set the proper type before we check the size */ + result = ftp_nb_type(data, ftpc, ftp, (bool)data->state.prefer_ascii, + FTP_TYPE); + if(result) + return result; + } + else + result = ftp_state_size(data, ftpc, ftp); + + return result; +} + +/* This is called after the CWD commands have been done in the beginning of + the DO phase */ +static CURLcode ftp_state_mdtm(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct FTP *ftp) +{ + CURLcode result = CURLE_OK; + + /* Requested time of file or time-depended transfer? */ + if((data->set.get_filetime || data->set.timecondition) && ftpc->file) { + + /* we have requested to get the modified-time of the file, this is a white + spot as the MDTM is not mentioned in RFC959 */ + result = Curl_pp_sendf(data, &ftpc->pp, "MDTM %s", ftpc->file); + + if(!result) + ftp_state(data, ftpc, FTP_MDTM); + } + else + result = ftp_state_type(data, ftpc, ftp); + + return result; +} + +/* This is called after the TYPE and possible quote commands have been sent */ +static CURLcode ftp_state_ul_setup(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct FTP *ftp, + bool sizechecked) +{ + CURLcode result = CURLE_OK; + curl_bit append = data->set.remote_append; + + if((data->state.resume_from && !sizechecked) || + ((data->state.resume_from > 0) && sizechecked)) { + /* we are about to continue the uploading of a file + 1. get already existing file's size. We use the SIZE command for this + which may not exist in the server! The SIZE command is not in + RFC959. + + 2. This used to set REST, but since we can do append, we issue no + another ftp command. Skip the source file offset and APPEND the rest + on the file instead + + 3. pass file-size number of bytes in the source file + 4. lower the infilesize counter */ + /* => transfer as usual */ + int seekerr = CURL_SEEKFUNC_OK; + + if(data->state.resume_from < 0) { + /* Got no given size to start from, figure it out */ + result = Curl_pp_sendf(data, &ftpc->pp, "SIZE %s", ftpc->file); + if(!result) + ftp_state(data, ftpc, FTP_STOR_SIZE); + return result; + } + + /* enable append */ + append = TRUE; + + /* Let's read off the proper amount of bytes from the input. */ + if(data->set.seek_func) { + Curl_set_in_callback(data, TRUE); + seekerr = data->set.seek_func(data->set.seek_client, + data->state.resume_from, SEEK_SET); + Curl_set_in_callback(data, FALSE); + } + + if(seekerr != CURL_SEEKFUNC_OK) { + curl_off_t passed = 0; + if(seekerr != CURL_SEEKFUNC_CANTSEEK) { + failf(data, "Could not seek stream"); + return CURLE_FTP_COULDNT_USE_REST; + } + /* seekerr == CURL_SEEKFUNC_CANTSEEK (cannot seek to offset) */ + do { + char scratch[4 * 1024]; + size_t readthisamountnow = + (data->state.resume_from - passed > (curl_off_t)sizeof(scratch)) ? + sizeof(scratch) : + curlx_sotouz(data->state.resume_from - passed); + + size_t actuallyread = + data->state.fread_func(scratch, 1, readthisamountnow, + data->state.in); + + passed += actuallyread; + if((actuallyread == 0) || (actuallyread > readthisamountnow)) { + /* this checks for greater-than only to make sure that the + CURL_READFUNC_ABORT return code still aborts */ + failf(data, "Failed to read data"); + return CURLE_FTP_COULDNT_USE_REST; + } + } while(passed < data->state.resume_from); + } + /* now, decrease the size of the read */ + if(data->state.infilesize > 0) { + data->state.infilesize -= data->state.resume_from; + + if(data->state.infilesize <= 0) { + infof(data, "File already completely uploaded"); + + /* no data to transfer */ + Curl_xfer_setup_nop(data); + + /* Set ->transfer so that we will not get any error in + * ftp_done() because we did not transfer anything! */ + ftp->transfer = PPTRANSFER_NONE; + + ftp_state(data, ftpc, FTP_STOP); + return CURLE_OK; + } + } + /* we have passed, proceed as normal */ + } /* resume_from */ + + result = Curl_pp_sendf(data, &ftpc->pp, append ? "APPE %s" : "STOR %s", + ftpc->file); + if(!result) + ftp_state(data, ftpc, FTP_STOR); + + return result; +} + +static CURLcode ftp_state_retr(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct FTP *ftp, + curl_off_t filesize) +{ + CURLcode result = CURLE_OK; + + CURL_TRC_FTP(data, "[%s] ftp_state_retr()", FTP_CSTATE(ftpc)); + if(data->set.max_filesize && (filesize > data->set.max_filesize)) { + failf(data, "Maximum file size exceeded"); + return CURLE_FILESIZE_EXCEEDED; + } + ftp->downloadsize = filesize; + + if(data->state.resume_from) { + /* We always (attempt to) get the size of downloads, so it is done before + this even when not doing resumes. */ + if(filesize == -1) { + infof(data, "ftp server does not support SIZE"); + /* We could not get the size and therefore we cannot know if there + really is a part of the file left to get, although the server will + close the connection when we start the connection so it will not + cause us any harm, not make us exit as nicely. */ + } + else { + /* We got a file size report, so we check that there actually is a + part of the file left to get, or else we go home. */ + if(data->state.resume_from < 0) { + /* We are supposed to download the last abs(from) bytes */ + if(filesize < -data->state.resume_from) { + failf(data, "Offset (%" FMT_OFF_T + ") was beyond file size (%" FMT_OFF_T ")", + data->state.resume_from, filesize); + return CURLE_BAD_DOWNLOAD_RESUME; + } + /* convert to size to download */ + ftp->downloadsize = -data->state.resume_from; + /* download from where? */ + data->state.resume_from = filesize - ftp->downloadsize; + } + else { + if(filesize < data->state.resume_from) { + failf(data, "Offset (%" FMT_OFF_T + ") was beyond file size (%" FMT_OFF_T ")", + data->state.resume_from, filesize); + return CURLE_BAD_DOWNLOAD_RESUME; + } + /* Now store the number of bytes we are expected to download */ + ftp->downloadsize = filesize - data->state.resume_from; + } + } + + if(ftp->downloadsize == 0) { + /* no data to transfer */ + Curl_xfer_setup_nop(data); + infof(data, "File already completely downloaded"); + + /* Set ->transfer so that we will not get any error in ftp_done() + * because we did not transfer the any file */ + ftp->transfer = PPTRANSFER_NONE; + ftp_state(data, ftpc, FTP_STOP); + return CURLE_OK; + } + + /* Set resume file transfer offset */ + infof(data, "Instructs server to resume from offset %" FMT_OFF_T, + data->state.resume_from); + + result = Curl_pp_sendf(data, &ftpc->pp, "REST %" FMT_OFF_T, + data->state.resume_from); + if(!result) + ftp_state(data, ftpc, FTP_RETR_REST); + } + else { + /* no resume */ + result = Curl_pp_sendf(data, &ftpc->pp, "RETR %s", ftpc->file); + if(!result) + ftp_state(data, ftpc, FTP_RETR); + } + + return result; +} + +static CURLcode ftp_state_quote(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct FTP *ftp, + bool init, + ftpstate instate) +{ + CURLcode result = CURLE_OK; + bool quote = FALSE; + struct curl_slist *item; + + switch(instate) { + case FTP_QUOTE: + default: + item = data->set.quote; + break; + case FTP_RETR_PREQUOTE: + case FTP_STOR_PREQUOTE: + case FTP_LIST_PREQUOTE: + item = data->set.prequote; + break; + case FTP_POSTQUOTE: + item = data->set.postquote; + break; + } + + /* + * This state uses: + * 'count1' to iterate over the commands to send + * 'count2' to store whether to allow commands to fail + */ + + if(init) + ftpc->count1 = 0; + else + ftpc->count1++; + + if(item) { + int i = 0; + + /* Skip count1 items in the linked list */ + while((i < ftpc->count1) && item) { + item = item->next; + i++; + } + if(item) { + const char *cmd = item->data; + if(cmd[0] == '*') { + cmd++; + ftpc->count2 = 1; /* the sent command is allowed to fail */ + } + else + ftpc->count2 = 0; /* failure means cancel operation */ + + result = Curl_pp_sendf(data, &ftpc->pp, "%s", cmd); + if(result) + return result; + ftp_state(data, ftpc, instate); + quote = TRUE; + } + } + + if(!quote) { + /* No more quote to send, continue to ... */ + switch(instate) { + case FTP_QUOTE: + default: + result = ftp_state_cwd(data, ftpc, ftp); + break; + case FTP_RETR_PREQUOTE: + if(ftp->transfer != PPTRANSFER_BODY) + ftp_state(data, ftpc, FTP_STOP); + else { + if(ftpc->known_filesize != -1) { + Curl_pgrsSetDownloadSize(data, ftpc->known_filesize); + result = ftp_state_retr(data, ftpc, ftp, ftpc->known_filesize); + } + else { + if(data->set.ignorecl || data->state.prefer_ascii) { + /* 'ignorecl' is used to support download of growing files. It + prevents the state machine from requesting the file size from + the server. With an unknown file size the download continues + until the server terminates it, otherwise the client stops if + the received byte count exceeds the reported file size. Set + option CURLOPT_IGNORE_CONTENT_LENGTH to 1 to enable this + behavior. + + In addition: asking for the size for 'TYPE A' transfers is not + constructive since servers do not report the converted size. + Thus, skip it. + */ + result = Curl_pp_sendf(data, &ftpc->pp, "RETR %s", ftpc->file); + if(!result) + ftp_state(data, ftpc, FTP_RETR); + } + else { + result = Curl_pp_sendf(data, &ftpc->pp, "SIZE %s", ftpc->file); + if(!result) + ftp_state(data, ftpc, FTP_RETR_SIZE); + } + } + } + break; + case FTP_STOR_PREQUOTE: + result = ftp_state_ul_setup(data, ftpc, ftp, FALSE); + break; + case FTP_POSTQUOTE: + break; + case FTP_LIST_PREQUOTE: + ftp_state(data, ftpc, FTP_LIST_TYPE); + result = ftp_state_list(data, ftpc, ftp); + break; + } + } + + return result; +} + +/* called from ftp_state_pasv_resp to switch to PASV in case of EPSV + problems */ +static CURLcode ftp_epsv_disable(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct connectdata *conn) +{ + CURLcode result = CURLE_OK; + + if(conn->bits.ipv6 && !Curl_conn_is_tunneling(conn, FIRSTSOCKET)) { + /* We cannot disable EPSV when doing IPv6, so this is instead a fail */ + failf(data, "Failed EPSV attempt, exiting"); + return CURLE_WEIRD_SERVER_REPLY; + } + + infof(data, "Failed EPSV attempt. Disabling EPSV"); + /* disable it for next transfer */ + conn->bits.ftp_use_epsv = FALSE; + close_secondarysocket(data, ftpc); + data->state.errorbuf = FALSE; /* allow error message to get + rewritten */ + result = Curl_pp_sendf(data, &ftpc->pp, "%s", "PASV"); + if(!result) { + ftpc->count1++; + /* remain in/go to the FTP_PASV state */ + ftp_state(data, ftpc, FTP_PASV); + } + return result; +} + +static CURLcode ftp_control_addr_dup(struct Curl_easy *data, char **newhostp) +{ + struct connectdata *conn = data->conn; + struct ip_quadruple ipquad; + bool is_ipv6; + + /* Returns the control connection IP address. + If a proxy tunnel is used, returns the original hostname instead, because + the effective control connection address is the proxy address, + not the ftp host. */ +#ifndef CURL_DISABLE_PROXY + if(Curl_conn_is_tunneling(conn, FIRSTSOCKET)) + *newhostp = curlx_strdup(conn->origin->hostname); + else +#endif + if(!Curl_conn_get_ip_info(data, conn, FIRSTSOCKET, &is_ipv6, &ipquad) && + *ipquad.remote_ip) + *newhostp = curlx_strdup(ipquad.remote_ip); + else { + /* failed to get the remote_ip of the DATA connection */ + failf(data, "unable to get peername of DATA connection"); + *newhostp = NULL; + return CURLE_FTP_CANT_GET_HOST; + } + return *newhostp ? CURLE_OK : CURLE_OUT_OF_MEMORY; +} + +static bool match_pasv_6nums(const char *p, + unsigned int *array) /* 6 numbers */ +{ + int i; + for(i = 0; i < 6; i++) { + curl_off_t num; + if(i) { + if(*p != ',') + return FALSE; + p++; + } + if(curlx_str_number(&p, &num, 0xff)) + return FALSE; + array[i] = (unsigned int)num; + } + return TRUE; +} + +static CURLcode ftp_state_pasv_resp(struct Curl_easy *data, + struct ftp_conn *ftpc, + int ftpcode) +{ + struct connectdata *conn = data->conn; + CURLcode result; + const struct pingpong *pp = &ftpc->pp; + char *newhost = NULL; + unsigned short newport = 0; + const char *str = curlx_dyn_ptr(&pp->recvbuf) + 4; /* start on the first + letter */ + if((ftpc->count1 == 0) && + (ftpcode == 229)) { + /* positive EPSV response */ + const char *ptr = strchr(str, '('); + if(ptr) { + char sep; + ptr++; + /* |||12345| */ + sep = ptr[0]; + if(sep && (ptr[1] == sep) && (ptr[2] == sep) && ISDIGIT(ptr[3])) { + const char *p = &ptr[3]; + curl_off_t num; + if(curlx_str_number(&p, &num, 0xffff) || (*p != sep)) { + failf(data, "Illegal port number in EPSV reply"); + return CURLE_FTP_WEIRD_PASV_REPLY; + } + newport = (unsigned short)num; + result = ftp_control_addr_dup(data, &newhost); + if(result) + return result; + } + else + ptr = NULL; + } + if(!ptr) { + failf(data, "Weirdly formatted EPSV reply"); + return CURLE_FTP_WEIRD_PASV_REPLY; + } + } + else if((ftpc->count1 == 1) && + (ftpcode == 227)) { + /* positive PASV response */ + unsigned int ip[6]; + + /* + * Scan for a sequence of six comma-separated numbers and use them as + * IP+port indicators. + * + * Found reply-strings include: + * "227 Entering Passive Mode (127,0,0,1,4,51)" + * "227 Data transfer will passively listen to 127,0,0,1,4,51" + * "227 Entering passive mode. 127,0,0,1,4,51" + */ + while(*str) { + if(match_pasv_6nums(str, ip)) + break; + str++; + } + + if(!*str) { + failf(data, "Could not interpret the 227-response"); + return CURLE_FTP_WEIRD_227_FORMAT; + } + + /* we got OK from server */ + if(data->set.ftp_skip_ip) { + /* told to ignore the remotely given IP but instead use the host we used + for the control connection */ + infof(data, "Skip %u.%u.%u.%u for data connection, reuse %s instead", + ip[0], ip[1], ip[2], ip[3], conn->origin->hostname); + result = ftp_control_addr_dup(data, &newhost); + if(result) + return result; + } + else + newhost = curl_maprintf("%u.%u.%u.%u", ip[0], ip[1], ip[2], ip[3]); + + if(!newhost) + return CURLE_OUT_OF_MEMORY; + + newport = (unsigned short)(((ip[4] << 8) + ip[5]) & 0xffff); + } + else if(ftpc->count1 == 0) { + /* EPSV failed, move on to PASV */ + return ftp_epsv_disable(data, ftpc, conn); + } + else { + failf(data, "Bad PASV/EPSV response: %03d", ftpcode); + return CURLE_FTP_WEIRD_PASV_REPLY; + } + + DEBUGASSERT(newhost); + Curl_peer_unlink(&conn->origin2); + result = Curl_peer_create(data, conn->scheme, newhost, newport, + &conn->origin2); + if(result) + goto error; + + /* If FIRSTSOCKET goes via another peer, SECONDARY needs as well, + * but with its new port. */ + if(conn->via_peer) { + Curl_peer_unlink(&conn->via_peer2); + result = Curl_peer_create(data, conn->via_peer->scheme, + conn->via_peer->hostname, newport, + &conn->via_peer2); + if(result) + goto error; + } + + result = Curl_conn_setup(data, conn, SECONDARYSOCKET, + conn->bits.ftp_use_data_ssl ? + CURL_CF_SSL_ENABLE : CURL_CF_SSL_DISABLE); + + if(result) { + if((result != CURLE_OUT_OF_MEMORY) && + (ftpc->count1 == 0) && (ftpcode == 229)) { + result = ftp_epsv_disable(data, ftpc, conn); + } + goto error; + } + + /* + * When this is used from the multi interface, this might have returned with + * the 'connected' set to FALSE and thus we are now awaiting a non-blocking + * connect to connect. + */ + +#ifdef CURLVERBOSE + if(data->set.verbose) { + /* Dump information about this second connection when we have issued + * a PASV command. */ + infof(data, "Connecting to %s port %d", + conn->origin2->hostname, conn->origin2->port); + } +#endif + + conn->bits.do_more = TRUE; + ftp_state(data, ftpc, FTP_STOP); /* this phase is completed */ + +error: + curlx_free(newhost); + return result; +} + +/* called repeatedly until done from multi.c */ +static CURLcode ftp_statemach(struct Curl_easy *data, + struct ftp_conn *ftpc, + bool *done) +{ + CURLcode result = Curl_pp_statemach(data, &ftpc->pp, FALSE, FALSE); + + /* Check for the state outside of the Curl_socket_check() return code checks + since at times we are in fact already in this state when this function + gets called. */ + *done = (ftpc->state == FTP_STOP); + + return result; +} + +/* + * ftp_do_more() + * + * This function shall be called when the second FTP (data) connection is + * connected. + * + * 'more' can return DOMORE_INCOMPLETE, DOMORE_DONE or DOMORE_GOBACK + * (which is for when PASV is being sent to retry a failed EPSV). + */ +static CURLcode ftp_do_more(struct Curl_easy *data, domore *more) +{ + struct connectdata *conn = data->conn; + struct ftp_conn *ftpc = Curl_conn_meta_get(data->conn, CURL_META_FTP_CONN); + struct FTP *ftp = Curl_meta_get(data, CURL_META_FTP_EASY); + CURLcode result = CURLE_OK; + bool connected = FALSE; + bool complete = FALSE; + /* the ftp struct is inited in ftp_connect(). If we are connecting to an HTTP + * proxy then the state will not be valid until after that connection is + * complete */ + + if(!ftpc || !ftp) + return CURLE_FAILED_INIT; + + *more = DOMORE_INCOMPLETE; /* default to stay in the state */ + + /* if the second connection has been set up, try to connect it fully + * to the remote host. This may not complete at this time, for several + * reasons: + * - we do EPTR and the server will not connect to our listen socket + * until we send more FTP commands + * - an SSL filter is in place and the server will not start the TLS + * handshake until we send more FTP commands + */ + if(conn->cfilter[SECONDARYSOCKET]) { + bool is_eptr = Curl_conn_is_tcp_listen(data, SECONDARYSOCKET); + result = Curl_conn_connect(data, SECONDARYSOCKET, FALSE, &connected); + if(result == CURLE_OUT_OF_MEMORY) + return result; + if(result || (!connected && !is_eptr && + !Curl_conn_is_ip_connected(data, SECONDARYSOCKET))) { + if(result && !is_eptr && (ftpc->count1 == 0)) { + *more = DOMORE_GOBACK; /* go back to DOING please */ + /* this is a EPSV connect failing, try PASV instead */ + return ftp_epsv_disable(data, ftpc, conn); + } + return result; + } + } + + if(ftpc->state) { + /* already in a state so skip the initial commands. + They are only done to kickstart the do_more state */ + result = ftp_statemach(data, ftpc, &complete); + + if(complete) + *more = DOMORE_DONE; + + /* if we got an error or if we do not wait for a data connection return + immediately */ + if(result || !ftpc->wait_data_conn) + return result; + + /* if we reach the end of the FTP state machine here, *complete will be + TRUE but so is ftpc->wait_data_conn, which says we need to wait for the + data connection and therefore we are not actually complete */ + *more = DOMORE_INCOMPLETE; + } + + if(ftp->transfer <= PPTRANSFER_INFO) { + /* a transfer is about to take place, or if not a filename was given so we + will do a SIZE on it later and then we need the right TYPE first */ + + if(ftpc->wait_data_conn) { + bool serv_conned; + + result = Curl_conn_connect(data, SECONDARYSOCKET, FALSE, &serv_conned); + if(result) + return result; /* Failed to accept data connection */ + + if(serv_conned) { + /* It looks data connection is established */ + ftpc->wait_data_conn = FALSE; + result = ftp_initiate_transfer(data, ftpc); + + if(result) + return result; + + *more = DOMORE_DONE; /* this state is now complete when the server has + connected back to us */ + } + else { + result = ftp_check_ctrl_on_data_wait(data, ftpc); + if(result) + return result; + } + } + else if(data->state.upload) { + result = ftp_nb_type(data, ftpc, ftp, (bool)data->state.prefer_ascii, + FTP_STOR_TYPE); + if(result) + return result; + + result = ftp_statemach(data, ftpc, &complete); + /* ftp_nb_type() might have skipped sending `TYPE A|I` when not + * deemed necessary and directly sent `STORE name`. If this was + * then complete, but we are still waiting on the data connection, + * the transfer has not been initiated yet. */ + *more = (!ftpc->wait_data_conn && complete) ? + DOMORE_DONE : DOMORE_INCOMPLETE; + } + else { + /* download */ + ftp->downloadsize = -1; /* unknown as of yet */ + + result = Curl_range(data); + + if(result == CURLE_OK && data->req.maxdownload >= 0) { + /* Do not check for successful transfer */ + ftpc->dont_check = TRUE; + } + + if(result) + ; + else if((data->state.list_only || !ftpc->file) && + !(data->set.prequote)) { + /* The specified path ends with a slash, and therefore we think this + is a directory that is requested, use LIST. Before that, we also + need to set ASCII transfer mode. */ + + /* Only if a body transfer was requested. */ + if(ftp->transfer == PPTRANSFER_BODY) { + result = ftp_nb_type(data, ftpc, ftp, TRUE, FTP_LIST_TYPE); + if(result) + return result; + } + /* otherwise fall through */ + } + else { + if(data->set.prequote && !ftpc->file) { + result = ftp_nb_type(data, ftpc, ftp, TRUE, + FTP_RETR_LIST_TYPE); + } + else { + result = ftp_nb_type(data, ftpc, ftp, (bool)data->state.prefer_ascii, + FTP_RETR_TYPE); + } + if(result) + return result; + } + + result = ftp_statemach(data, ftpc, &complete); + if(complete) + *more = DOMORE_DONE; + } + return result; + } + + /* no data to transfer */ + Curl_xfer_setup_nop(data); + + if(!ftpc->wait_data_conn) { + /* no waiting for the data connection so this is now complete */ + *more = DOMORE_DONE; + CURL_TRC_FTP(data, "[%s] DO-MORE phase ends with %d", FTP_CSTATE(ftpc), + (int)result); + } + + return result; +} + +/* call this when the DO phase has completed */ +static CURLcode ftp_dophase_done(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct FTP *ftp, + bool connected) +{ + if(connected) { + domore completed; + CURLcode result = ftp_do_more(data, &completed); + + if(result) { + close_secondarysocket(data, ftpc); + return result; + } + } + + if(ftp->transfer != PPTRANSFER_BODY) + /* no data to transfer */ + Curl_xfer_setup_nop(data); + else if(!connected) + /* since we did not connect now, we want do_more to get called */ + data->conn->bits.do_more = TRUE; + + ftpc->ctl_valid = TRUE; /* seems good */ + + return CURLE_OK; +} + +static CURLcode ftp_state_port_resp(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct FTP *ftp, + int ftpcode) +{ + struct connectdata *conn = data->conn; + ftpport fcmd = (ftpport)ftpc->count1; + CURLcode result = CURLE_OK; + + /* The FTP spec tells a positive response should have code 200. + Be more permissive here to tolerate deviant servers. */ + if(ftpcode / 100 != 2) { + /* the command failed */ + + if(EPRT == fcmd) { + infof(data, "disabling EPRT usage"); + conn->bits.ftp_use_eprt = FALSE; + } + fcmd++; + + if(fcmd == DONE) { + failf(data, "Failed to do PORT"); + result = CURLE_FTP_PORT_FAILED; + } + else + /* try next */ + result = ftp_state_use_port(data, ftpc, fcmd); + } + else { + infof(data, "Connect data stream actively"); + ftp_state(data, ftpc, FTP_STOP); /* end of DO phase */ + result = ftp_dophase_done(data, ftpc, ftp, FALSE); + } + + return result; +} + +/* return TRUE on error, FALSE on success */ +static bool twodigit(const char *p, int *val) +{ + if(!ISDIGIT(p[0]) || !ISDIGIT(p[1])) + return TRUE; + /* curlx_hexval() works fine here since we make sure it is decimal above */ + *val = (curlx_hexval(p[0]) * 10) + curlx_hexval(p[1]); + return FALSE; +} + +/* + * @unittest 1668 + */ +UNITTEST bool ftp_213_date(const char *p, int *year, int *month, int *day, + int *hour, int *minute, int *second); +UNITTEST bool ftp_213_date(const char *p, int *year, int *month, int *day, + int *hour, int *minute, int *second) +{ + int century; + if((strlen(p) < 14) || twodigit(&p[0], ¢ury) || twodigit(&p[2], year) || + twodigit(&p[4], month) || twodigit(&p[6], day) || + twodigit(&p[8], hour) || twodigit(&p[10], minute) || + twodigit(&p[12], second)) + return FALSE; + + *year += century * 100; + if((*month > 12) || (*day > 31) || (*hour > 23) || (*minute > 59) || + (*second > 60)) + return FALSE; + return TRUE; +} + +static CURLcode client_write_header(struct Curl_easy *data, + char *buf, size_t blen) +{ + /* Some replies from an FTP server are written to the client + * as CLIENTWRITE_HEADER, formatted as if they came from a + * HTTP conversation. + * In all protocols, CLIENTWRITE_HEADER data is only passed to + * the body write callback when data->set.include_header is set + * via CURLOPT_HEADER. + * For historic reasons, FTP never played this game and expects + * all its headers to do that always. Set that flag during the + * call to Curl_client_write() so it does the right thing. + * + * Notice that we cannot enable this flag for FTP in general, + * as an FTP transfer might involve an HTTP proxy connection and + * headers from CONNECT should not automatically be part of the + * output. */ + CURLcode result; + bool save = (bool)data->set.include_header; + data->set.include_header = TRUE; + result = Curl_client_write(data, CLIENTWRITE_HEADER, buf, blen); + data->set.include_header = save; + return result; +} + +static CURLcode ftp_state_mdtm_resp(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct FTP *ftp, + int ftpcode) +{ + CURLcode result = CURLE_OK; + + switch(ftpcode) { + case 213: { + /* we got a time. Format should be: "YYYYMMDDHHMMSS[.sss]" where the + last .sss part is optional and means fractions of a second */ + int year, month, day, hour, minute, second; + struct pingpong *pp = &ftpc->pp; + const char *resp = curlx_dyn_ptr(&pp->recvbuf) + 4; + bool showtime = FALSE; + if(ftp_213_date(resp, &year, &month, &day, &hour, &minute, &second)) { + /* we have a time, reformat it */ + char timebuf[24]; + curl_msnprintf(timebuf, sizeof(timebuf), + "%04d%02d%02d %02d:%02d:%02d GMT", + year, month, day, hour, minute, second); + /* now, convert this into a time() value: */ + if(!Curl_getdate_capped(timebuf, &data->info.filetime)) + showtime = TRUE; + } + + /* If we asked for a time of the file and we actually got one as well, + we "emulate" an HTTP-style header in our output. */ + +#if defined(CURL_HAVE_DIAG) && (defined(__DJGPP__) || defined(__AMIGA__)) +#pragma GCC diagnostic push +/* 'time_t' is unsigned in MSDOS and AmigaOS. Silence: + warning: comparison of unsigned expression in '>= 0' is always true */ +#pragma GCC diagnostic ignored "-Wtype-limits" +#endif + if(data->req.no_body && ftpc->file && + data->set.get_filetime && showtime) { +#if defined(CURL_HAVE_DIAG) && (defined(__DJGPP__) || defined(__AMIGA__)) +#pragma GCC diagnostic pop +#endif + char headerbuf[128]; + int headerbuflen; + time_t filetime = data->info.filetime; + struct tm buffer; + const struct tm *tm = &buffer; + + result = curlx_gmtime(filetime, &buffer); + if(result) + return result; + + /* format: "Tue, 15 Nov 1994 12:45:26" */ + headerbuflen = + curl_msnprintf(headerbuf, sizeof(headerbuf), + "Last-Modified: %s, %02d %s %4d %02d:%02d:%02d " + "GMT\r\n", + Curl_wkday[tm->tm_wday ? tm->tm_wday-1 : 6], + tm->tm_mday, + Curl_month[tm->tm_mon], + tm->tm_year + 1900, + tm->tm_hour, + tm->tm_min, + tm->tm_sec); + result = client_write_header(data, headerbuf, headerbuflen); + if(result) + return result; + } /* end of a ridiculous amount of conditionals */ + } + break; + default: + infof(data, "unsupported MDTM reply format"); + break; + case 550: /* 550 is used for several different problems, e.g. + "No such file or directory" or "Permission denied". + It does not mean that the file does not exist at all. */ + infof(data, "MDTM failed: file does not exist or permission problem," + " continuing"); + break; + } + + if(data->set.timecondition) { + if((data->info.filetime > 0) && (data->set.timevalue > 0)) { + switch(data->set.timecondition) { + case CURL_TIMECOND_IFMODSINCE: + default: + if(data->info.filetime <= data->set.timevalue) { + infof(data, "The requested document is not new enough"); + ftp->transfer = PPTRANSFER_NONE; /* mark to not transfer data */ + data->info.timecond = TRUE; + ftp_state(data, ftpc, FTP_STOP); + return CURLE_OK; + } + break; + case CURL_TIMECOND_IFUNMODSINCE: + if(data->info.filetime > data->set.timevalue) { + infof(data, "The requested document is not old enough"); + ftp->transfer = PPTRANSFER_NONE; /* mark to not transfer data */ + data->info.timecond = TRUE; + ftp_state(data, ftpc, FTP_STOP); + return CURLE_OK; + } + break; + } /* switch */ + } + else { + infof(data, "Skipping time comparison"); + } + } + + if(!result) + result = ftp_state_type(data, ftpc, ftp); + + return result; +} + +static CURLcode ftp_state_type_resp(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct FTP *ftp, + int ftpcode, + ftpstate instate) +{ + CURLcode result = CURLE_OK; + + if(ftpcode / 100 != 2) { + /* "sasserftpd" and "(u)r(x)bot ftpd" both responds with 226 after a + successful 'TYPE I'. While that is not as RFC959 says, it is still a + positive response code and we allow that. */ + failf(data, "Could not set desired mode"); + return CURLE_FTP_COULDNT_SET_TYPE; + } + if(ftpcode != 200) + infof(data, "Got a %03d response code instead of the assumed 200", + ftpcode); + + if(instate == FTP_TYPE) + result = ftp_state_size(data, ftpc, ftp); + else if(instate == FTP_LIST_TYPE) + result = ftp_state_list(data, ftpc, ftp); + else if(instate == FTP_RETR_TYPE) + result = ftp_state_retr_prequote(data, ftpc, ftp); + else if(instate == FTP_STOR_TYPE) + result = ftp_state_stor_prequote(data, ftpc, ftp); + else if(instate == FTP_RETR_LIST_TYPE) + result = ftp_state_list_prequote(data, ftpc, ftp); + + return result; +} + +static CURLcode ftp_state_size_resp(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct FTP *ftp, + int ftpcode, + ftpstate instate) +{ + CURLcode result = CURLE_OK; + curl_off_t filesize = -1; + const char *buf = curlx_dyn_ptr(&ftpc->pp.recvbuf); + size_t len = ftpc->pp.nfinal; + + /* get the size from the ascii string: */ + if(ftpcode == 213) { + /* To allow servers to prepend "rubbish" in the response string, we scan + for all the digits at the end of the response and parse only those as a + number. */ + const char *start = &buf[4]; + const char *fdigit = memchr(start, '\r', len - 4); + if(fdigit) { + fdigit--; + if(*fdigit == '\n') + fdigit--; + while(ISDIGIT(fdigit[-1]) && (fdigit > start)) + fdigit--; + } + else + fdigit = start; + if(curlx_str_number(&fdigit, &filesize, CURL_OFF_T_MAX)) + filesize = -1; /* size remain unknown */ + } + else if(ftpcode == 550) { /* "No such file or directory" */ + /* allow a SIZE failure for (resumed) uploads, when probing what command + to use */ + if(instate != FTP_STOR_SIZE) { + failf(data, "The file does not exist"); + return CURLE_REMOTE_FILE_NOT_FOUND; + } + } + + if(instate == FTP_SIZE) { + if(filesize != -1) { + char clbuf[128]; + int clbuflen = curl_msnprintf(clbuf, sizeof(clbuf), + "Content-Length: %" FMT_OFF_T "\r\n", + filesize); + result = client_write_header(data, clbuf, clbuflen); + if(result) + return result; + } + Curl_pgrsSetDownloadSize(data, filesize); + result = ftp_state_rest(data, ftpc, ftp); + } + else if(instate == FTP_RETR_SIZE) { + Curl_pgrsSetDownloadSize(data, filesize); + result = ftp_state_retr(data, ftpc, ftp, filesize); + } + else if(instate == FTP_STOR_SIZE) { + data->state.resume_from = filesize; + result = ftp_state_ul_setup(data, ftpc, ftp, TRUE); + } + + return result; +} + +static CURLcode ftp_state_rest_resp(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct FTP *ftp, + int ftpcode, + ftpstate instate) +{ + CURLcode result = CURLE_OK; + + switch(instate) { + case FTP_REST: + default: + if(ftpcode == 350) { + char buffer[24] = { "Accept-ranges: bytes\r\n" }; + result = client_write_header(data, buffer, strlen(buffer)); + if(result) + return result; + } + result = ftp_state_prepare_transfer(data, ftpc, ftp); + break; + + case FTP_RETR_REST: + if(ftpcode != 350) { + failf(data, "Could not use REST"); + result = CURLE_FTP_COULDNT_USE_REST; + } + else { + result = Curl_pp_sendf(data, &ftpc->pp, "RETR %s", ftpc->file); + if(!result) + ftp_state(data, ftpc, FTP_RETR); + } + break; + } + + return result; +} + +static CURLcode ftp_state_stor_resp(struct Curl_easy *data, + struct ftp_conn *ftpc, + int ftpcode) +{ + CURLcode result = CURLE_OK; + + if(ftpcode >= 400) { + failf(data, "Failed FTP upload: %0d", ftpcode); + ftp_state(data, ftpc, FTP_STOP); + return CURLE_UPLOAD_FAILED; + } + + /* PORT means we are now awaiting the server to connect to us. */ + if(data->set.ftp_use_port) { + bool connected; + + ftp_state(data, ftpc, FTP_STOP); /* no longer in STOR state */ + + result = Curl_conn_connect(data, SECONDARYSOCKET, FALSE, &connected); + if(result) + return result; + + if(!connected) { + infof(data, "Data conn was not available immediately"); + ftpc->wait_data_conn = TRUE; + return ftp_check_ctrl_on_data_wait(data, ftpc); + } + ftpc->wait_data_conn = FALSE; + } + return ftp_initiate_transfer(data, ftpc); +} + +/* for LIST and RETR responses */ +static CURLcode ftp_state_get_resp(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct FTP *ftp, + int ftpcode, + ftpstate instate) +{ + CURLcode result = CURLE_OK; + + if((ftpcode == 150) || (ftpcode == 125)) { + + /* + A; + 150 Opening BINARY mode data connection for /etc/passwd (2241 + bytes). (ok, the file is being transferred) + + B: + 150 Opening ASCII mode data connection for /bin/ls + + C: + 150 ASCII data connection for /bin/ls (137.167.104.91,37445) (0 bytes). + + D: + 150 Opening ASCII mode data connection for [file] (0.0.0.0,0) (545 bytes) + + E: + 125 Data connection already open; Transfer starting. */ + + data->req.size = -1; /* default unknown size */ + + /* + * It appears that there are FTP-servers that return size 0 for files when + * SIZE is used on the file while being in BINARY mode. To work around + * that (stupid) behavior, we attempt to parse the RETR response even if + * the SIZE returned size zero. + * + * Debugging help from Salvatore Sorrentino on February 26, 2003. + */ + + if((instate != FTP_LIST) && + !data->state.prefer_ascii && + !data->set.ignorecl && + (ftp->downloadsize < 1)) { + /* + * It seems directory listings either do not show the size or often uses + * size 0 anyway. ASCII transfers may cause that the transferred amount + * of data is not the same as this line tells, why using this number in + * those cases only confuses us. + * + * Example D above makes this parsing a little tricky */ + size_t len = curlx_dyn_len(&ftpc->pp.recvbuf); + if(len >= 7) { /* "1 bytes" is 7 characters */ + size_t i; + for(i = 0; i < len - 7; i++) { + curl_off_t what; + const char *buf = curlx_dyn_ptr(&ftpc->pp.recvbuf); + const char *c = &buf[i]; + if(!curlx_str_number(&c, &what, CURL_OFF_T_MAX) && + !curlx_str_single(&c, ' ') && + !strncmp(c, "bytes", 5)) { + data->req.size = what; + break; + } + } + } + } + else if(ftp->downloadsize > -1) + data->req.size = ftp->downloadsize; + + if(data->req.size > data->req.maxdownload && data->req.maxdownload > 0) + data->req.size = data->req.maxdownload; + else if((instate != FTP_LIST) && (data->state.prefer_ascii)) + data->req.size = -1; /* for servers that understate ASCII mode file + size */ + + infof(data, "Maxdownload = %" FMT_OFF_T, data->req.maxdownload); + + if(instate != FTP_LIST) + infof(data, "Getting file with size: %" FMT_OFF_T, data->req.size); + + if(data->set.ftp_use_port) { + bool connected; + + result = Curl_conn_connect(data, SECONDARYSOCKET, FALSE, &connected); + if(result) + return result; + + if(!connected) { + infof(data, "Data conn was not available immediately"); + ftp_state(data, ftpc, FTP_STOP); + ftpc->wait_data_conn = TRUE; + return ftp_check_ctrl_on_data_wait(data, ftpc); + } + ftpc->wait_data_conn = FALSE; + } + return ftp_initiate_transfer(data, ftpc); + } + else { + if((instate == FTP_LIST) && (ftpcode == 450)) { + /* no matching files in the directory listing */ + ftp->transfer = PPTRANSFER_NONE; /* do not download anything */ + ftp_state(data, ftpc, FTP_STOP); /* this phase is over */ + } + else { + failf(data, "RETR response: %03d", ftpcode); + return instate == FTP_RETR && ftpcode == 550 ? + CURLE_REMOTE_FILE_NOT_FOUND : + CURLE_FTP_COULDNT_RETR_FILE; + } + } + + return result; +} + +/* after USER, PASS and ACCT */ +static CURLcode ftp_state_loggedin(struct Curl_easy *data, + struct ftp_conn *ftpc) +{ + CURLcode result = CURLE_OK; + + if(Curl_conn_is_ssl(data->conn, FIRSTSOCKET)) { + /* PBSZ = PROTECTION BUFFER SIZE. + + The 'draft-murray-auth-ftp-ssl' (draft 12, page 7) says: + + Specifically, the PROT command MUST be preceded by a PBSZ + command and a PBSZ command MUST be preceded by a successful + security data exchange (the TLS negotiation in this case) + + ... (and on page 8): + + Thus the PBSZ command must still be issued, but must have a + parameter of '0' to indicate that no buffering is taking place + and the data connection should not be encapsulated. + */ + result = Curl_pp_sendf(data, &ftpc->pp, "PBSZ %d", 0); + if(!result) + ftp_state(data, ftpc, FTP_PBSZ); + } + else { + result = ftp_state_pwd(data, ftpc); + } + return result; +} + +/* for USER and PASS responses */ +static CURLcode ftp_state_user_resp(struct Curl_easy *data, + struct ftp_conn *ftpc, + int ftpcode) +{ + CURLcode result = CURLE_OK; + + /* some need password anyway, and others return 2xx ignored */ + if((ftpcode == 331) && (ftpc->state == FTP_USER)) { + /* 331 Password required for ... + (the server requires to send the user's password too) */ + result = Curl_pp_sendf(data, &ftpc->pp, "PASS %s", + Curl_creds_passwd(data->conn->creds)); + if(!result) + ftp_state(data, ftpc, FTP_PASS); + } + else if(ftpcode / 100 == 2) { + /* 230 User ... logged in. + (the user logged in with or without password) */ + result = ftp_state_loggedin(data, ftpc); + } + else if(ftpcode == 332) { + if(data->set.str[STRING_FTP_ACCOUNT]) { + result = Curl_pp_sendf(data, &ftpc->pp, "ACCT %s", + data->set.str[STRING_FTP_ACCOUNT]); + if(!result) + ftp_state(data, ftpc, FTP_ACCT); + } + else { + failf(data, "ACCT requested but none available"); + result = CURLE_LOGIN_DENIED; + } + } + else { + /* All other response codes, like: + + 530 User ... access denied + (the server denies to log the specified user) */ + + if(data->set.str[STRING_FTP_ALTERNATIVE_TO_USER] && + !ftpc->ftp_trying_alternative) { + /* Ok, USER failed. Let's try the supplied command. */ + result = Curl_pp_sendf(data, &ftpc->pp, "%s", + data->set.str[STRING_FTP_ALTERNATIVE_TO_USER]); + if(!result) { + ftpc->ftp_trying_alternative = TRUE; + ftp_state(data, ftpc, FTP_USER); + } + } + else { + failf(data, "Access denied: %03d", ftpcode); + result = CURLE_LOGIN_DENIED; + } + } + return result; +} + +/* for ACCT response */ +static CURLcode ftp_state_acct_resp(struct Curl_easy *data, + struct ftp_conn *ftpc, + int ftpcode) +{ + CURLcode result = CURLE_OK; + if(ftpcode != 230) { + failf(data, "ACCT rejected by server: %03d", ftpcode); + result = CURLE_FTP_WEIRD_PASS_REPLY; /* FIX */ + } + else + result = ftp_state_loggedin(data, ftpc); + + return result; +} + +static CURLcode ftp_pwd_resp(struct Curl_easy *data, + struct ftp_conn *ftpc, + int ftpcode) +{ + struct pingpong *pp = &ftpc->pp; + CURLcode result; + + if(ftpcode == 257) { + const char *ptr = curlx_dyn_ptr(&pp->recvbuf) + 4; /* start on the first + letter */ + bool entry_extracted = FALSE; + struct dynbuf out; + curlx_dyn_init(&out, 1000); + + /* Reply format is like + 257[rubbish]"" and the + RFC959 says + + The directory name can contain any character; embedded + double-quotes should be escaped by double-quotes (the + "quote-doubling" convention). + */ + + /* scan for the first double-quote for non-standard responses */ + while(*ptr != '\n' && *ptr != '\0' && *ptr != '"') + ptr++; + + if('\"' == *ptr) { + /* it started good */ + for(ptr++; *ptr; ptr++) { + if('\"' == *ptr) { + if('\"' == ptr[1]) { + /* "quote-doubling" */ + result = curlx_dyn_addn(&out, &ptr[1], 1); + ptr++; + } + else { + /* end of path */ + if(curlx_dyn_len(&out)) + entry_extracted = TRUE; + break; /* get out of this loop */ + } + } + else { + if(ISCNTRL(*ptr)) { + /* control characters have no business in a path */ + curlx_dyn_free(&out); + return CURLE_WEIRD_SERVER_REPLY; + } + result = curlx_dyn_addn(&out, ptr, 1); + } + if(result) { + curlx_dyn_free(&out); + return result; + } + } + } + if(entry_extracted) { + /* If the path name does not look like an absolute path (i.e.: it + does not start with a '/'), we probably need some server-dependent + adjustments. For example, this is the case when connecting to + an OS400 FTP server: this server supports two name syntaxes, + the default one being incompatible with standard paths. In + addition, this server switches automatically to the regular path + syntax when one is encountered in a command: this results in + having an entrypath in the wrong syntax when later used in CWD. + The method used here is to check the server OS: we do it only + if the path name looks strange to minimize overhead on other + systems. */ + char *dir = curlx_dyn_ptr(&out); + + if(!ftpc->server_os && dir[0] != '/') { + result = Curl_pp_sendf(data, &ftpc->pp, "%s", "SYST"); + if(result) { + curlx_dyn_free(&out); + return result; + } + } + + curlx_free(ftpc->entrypath); + ftpc->entrypath = dir; /* remember this */ + infof(data, "Entry path is '%s'", ftpc->entrypath); + /* also save it where getinfo can access it: */ + curlx_free(data->state.most_recent_ftp_entrypath); + data->state.most_recent_ftp_entrypath = curlx_strdup(ftpc->entrypath); + if(!data->state.most_recent_ftp_entrypath) + return CURLE_OUT_OF_MEMORY; + + if(!ftpc->server_os && dir[0] != '/') { + ftp_state(data, ftpc, FTP_SYST); + return CURLE_OK; + } + } + else { + /* could not get the path */ + curlx_dyn_free(&out); + infof(data, "Failed to figure out path"); + } + } + ftp_state(data, ftpc, FTP_STOP); /* we are done with CONNECT phase! */ + CURL_TRC_FTP(data, "[%s] protocol connect phase DONE", FTP_CSTATE(ftpc)); + return CURLE_OK; +} + +static const char * const ftpauth[] = { "SSL", "TLS" }; + +static CURLcode ftp_wait_resp(struct Curl_easy *data, + struct connectdata *conn, + struct ftp_conn *ftpc, + int ftpcode) +{ + CURLcode result = CURLE_OK; + if(ftpcode == 230) { + /* 230 User logged in - already! Take as 220 if TLS required. */ + if(ftpc->use_ssl <= CURLUSESSL_TRY || + Curl_conn_is_ssl(conn, FIRSTSOCKET)) + return ftp_state_user_resp(data, ftpc, ftpcode); + } + else if(ftpcode != 220) { + failf(data, "Got a %03d ftp-server response when 220 was expected", + ftpcode); + return CURLE_WEIRD_SERVER_REPLY; + } + + if(ftpc->use_ssl && !Curl_conn_is_ssl(conn, FIRSTSOCKET)) { + /* We do not have an SSL/TLS control connection yet, but FTPS is + requested. Try an FTPS connection now */ + + ftpc->count3 = 0; + switch((long)data->set.ftpsslauth) { + case CURLFTPAUTH_DEFAULT: + case CURLFTPAUTH_SSL: + ftpc->count2 = 1; /* add one to get next */ + ftpc->count1 = 0; + break; + case CURLFTPAUTH_TLS: + ftpc->count2 = -1; /* subtract one to get next */ + ftpc->count1 = 1; + break; + default: + failf(data, "unsupported parameter to CURLOPT_FTPSSLAUTH: %d", + (int)data->set.ftpsslauth); + return CURLE_UNKNOWN_OPTION; /* we do not know what to do */ + } + result = Curl_pp_sendf(data, &ftpc->pp, "AUTH %s", ftpauth[ftpc->count1]); + if(!result) + ftp_state(data, ftpc, FTP_AUTH); + } + else + result = ftp_state_user(data, ftpc, conn); + return result; +} + +static CURLcode ftp_pp_statemachine(struct Curl_easy *data, + struct connectdata *conn) +{ + CURLcode result; + int ftpcode; + struct ftp_conn *ftpc = Curl_conn_meta_get(conn, CURL_META_FTP_CONN); + struct FTP *ftp = Curl_meta_get(data, CURL_META_FTP_EASY); + struct pingpong *pp; + size_t nread = 0; + + if(!ftpc || !ftp) + return CURLE_FAILED_INIT; + pp = &ftpc->pp; + if(pp->sendleft) + return Curl_pp_flushsend(data, pp); + + result = ftp_readresp(data, ftpc, FIRSTSOCKET, pp, &ftpcode, &nread); + if(result || !ftpcode) + return result; + + /* we have now received a full FTP server response */ + switch(ftpc->state) { + case FTP_WAIT220: + result = ftp_wait_resp(data, conn, ftpc, ftpcode); + break; + + case FTP_AUTH: + /* we have gotten the response to a previous AUTH command */ + + if(pp->overflow) + return CURLE_WEIRD_SERVER_REPLY; /* Forbid pipelining in response. */ + + /* RFC2228 (page 5) says: + * + * If the server is willing to accept the named security mechanism, + * and does not require any security data, it must respond with + * reply code 234/334. + */ + + if((ftpcode == 234) || (ftpcode == 334)) { + /* this was BLOCKING, keep it so for now */ + bool done; + if(!Curl_conn_is_ssl(conn, FIRSTSOCKET)) { + result = Curl_ssl_cfilter_add( + data, Curl_conn_get_origin(conn, FIRSTSOCKET), conn, FIRSTSOCKET); + if(result) { + /* we failed and bail out */ + return CURLE_USE_SSL_FAILED; + } + } + /* BLOCKING */ + result = Curl_conn_connect(data, FIRSTSOCKET, TRUE, &done); + if(!result) { + conn->bits.ftp_use_data_ssl = FALSE; /* clear-text data */ + result = ftp_state_user(data, ftpc, conn); + } + } + else if(ftpc->count3 < 1) { + ftpc->count3++; + ftpc->count1 += ftpc->count2; /* get next attempt */ + result = Curl_pp_sendf(data, &ftpc->pp, "AUTH %s", + ftpauth[ftpc->count1]); + /* remain in this same state */ + } + else { + if(ftpc->use_ssl > CURLUSESSL_TRY) + /* we failed and CURLUSESSL_CONTROL or CURLUSESSL_ALL is set */ + result = CURLE_USE_SSL_FAILED; + else + /* ignore the failure and continue */ + result = ftp_state_user(data, ftpc, conn); + } + break; + + case FTP_USER: + case FTP_PASS: + result = ftp_state_user_resp(data, ftpc, ftpcode); + break; + + case FTP_ACCT: + result = ftp_state_acct_resp(data, ftpc, ftpcode); + break; + + case FTP_PBSZ: + result = + Curl_pp_sendf(data, &ftpc->pp, "PROT %c", + ftpc->use_ssl == CURLUSESSL_CONTROL ? 'C' : 'P'); + if(!result) + ftp_state(data, ftpc, FTP_PROT); + break; + + case FTP_PROT: + if(ftpcode / 100 == 2) + /* We have enabled SSL for the data connection! */ + conn->bits.ftp_use_data_ssl = (ftpc->use_ssl != CURLUSESSL_CONTROL); + /* FTP servers typically responds with 500 if they decide to reject + our 'P' request */ + else if(ftpc->use_ssl > CURLUSESSL_CONTROL) + /* we failed and bails out */ + return CURLE_USE_SSL_FAILED; + + if(data->set.ftp_ccc) { + /* CCC - Clear Command Channel + */ + result = Curl_pp_sendf(data, &ftpc->pp, "%s", "CCC"); + if(!result) + ftp_state(data, ftpc, FTP_CCC); + } + else + result = ftp_state_pwd(data, ftpc); + break; + + case FTP_CCC: + if(ftpcode < 500) { + /* First shut down the SSL layer (note: this call will block) */ + /* This has only been tested on the proftpd server, and the mod_tls + * code sends a close notify alert without waiting for a close notify + * alert in response. Thus we wait for a close notify alert from the + * server, but we do not send one. Let's hope other servers do + * the same... */ + result = Curl_ssl_cfilter_remove(data, FIRSTSOCKET, + (data->set.ftp_ccc == + (unsigned char)CURLFTPSSL_CCC_ACTIVE)); + if(result) + failf(data, "Failed to clear the command channel (CCC)"); + } + if(!result) + /* Then continue as normal */ + result = ftp_state_pwd(data, ftpc); + break; + + case FTP_PWD: + result = ftp_pwd_resp(data, ftpc, ftpcode); + break; + + case FTP_SYST: + if(ftpcode == 215) { + const char *ptr = curlx_dyn_ptr(&pp->recvbuf) + 4; /* start on the first + letter */ + const char *start; + char *os; + + /* Reply format is like + 215 + */ + while(*ptr == ' ') + ptr++; + for(start = ptr; *ptr && *ptr != ' '; ptr++) + ; + os = curlx_memdup0(start, ptr - start); + if(!os) + return CURLE_OUT_OF_MEMORY; + + /* Check for special servers here. */ + if(curl_strequal(os, "OS/400")) { + /* Force OS400 name format 1. */ + result = Curl_pp_sendf(data, &ftpc->pp, "%s", "SITE NAMEFMT 1"); + if(result) { + curlx_free(os); + return result; + } + /* remember target server OS */ + curlx_free(ftpc->server_os); + ftpc->server_os = os; + ftp_state(data, ftpc, FTP_NAMEFMT); + break; + } + /* Nothing special for the target server. */ + /* remember target server OS */ + curlx_free(ftpc->server_os); + ftpc->server_os = os; + } + else { + /* Cannot identify server OS. Continue anyway and cross fingers. */ + } + + ftp_state(data, ftpc, FTP_STOP); /* we are done with CONNECT phase! */ + CURL_TRC_FTP(data, "[%s] protocol connect phase DONE", FTP_CSTATE(ftpc)); + break; + + case FTP_NAMEFMT: + if(ftpcode == 250) { + /* Name format change successful: reload initial path. */ + ftp_state_pwd(data, ftpc); + break; + } + + ftp_state(data, ftpc, FTP_STOP); /* we are done with CONNECT phase! */ + CURL_TRC_FTP(data, "[%s] protocol connect phase DONE", FTP_CSTATE(ftpc)); + break; + + case FTP_QUOTE: + case FTP_POSTQUOTE: + case FTP_RETR_PREQUOTE: + case FTP_STOR_PREQUOTE: + case FTP_LIST_PREQUOTE: + if((ftpcode >= 400) && !ftpc->count2) { + /* failure response code, and not allowed to fail */ + failf(data, "QUOT command failed with %03d", ftpcode); + result = CURLE_QUOTE_ERROR; + } + else + result = ftp_state_quote(data, ftpc, ftp, FALSE, ftpc->state); + break; + + case FTP_CWD: + if(ftpcode / 100 != 2) { + /* failure to CWD there */ + if(data->set.ftp_create_missing_dirs && + ftpc->cwdcount && !ftpc->count2) { + /* try making it */ + ftpc->count2++; /* counter to prevent CWD-MKD loops */ + + /* count3 is set to allow MKD to fail once per dir. In the case when + CWD fails and then MKD fails (due to another session raced it to + create the dir) this then allows for a second try to CWD to it. */ + ftpc->count3 = (data->set.ftp_create_missing_dirs == 2) ? 1 : 0; + + result = Curl_pp_sendf(data, &ftpc->pp, "MKD %.*s", + pathlen(ftpc, ftpc->cwdcount - 1), + pathpiece(ftpc, ftpc->cwdcount - 1)); + if(!result) + ftp_state(data, ftpc, FTP_MKD); + } + else { + /* return failure */ + failf(data, "Server denied you to change to the given directory"); + ftpc->cwdfail = TRUE; /* do not remember this path as we failed + to enter it */ + result = CURLE_REMOTE_ACCESS_DENIED; + } + } + else { + /* success */ + ftpc->count2 = 0; + if(ftpc->cwdcount >= ftpc->dirdepth) + result = ftp_state_mdtm(data, ftpc, ftp); + else { + ftpc->cwdcount++; + /* send next CWD */ + result = Curl_pp_sendf(data, &ftpc->pp, "CWD %.*s", + pathlen(ftpc, ftpc->cwdcount - 1), + pathpiece(ftpc, ftpc->cwdcount - 1)); + } + } + break; + + case FTP_MKD: + if((ftpcode / 100 != 2) && !ftpc->count3--) { + /* failure to MKD the directory */ + failf(data, "Failed to MKD dir: %03d", ftpcode); + result = CURLE_REMOTE_ACCESS_DENIED; + } + else { + ftp_state(data, ftpc, FTP_CWD); + /* send CWD */ + result = Curl_pp_sendf(data, &ftpc->pp, "CWD %.*s", + pathlen(ftpc, ftpc->cwdcount - 1), + pathpiece(ftpc, ftpc->cwdcount - 1)); + } + break; + + case FTP_MDTM: + result = ftp_state_mdtm_resp(data, ftpc, ftp, ftpcode); + break; + + case FTP_TYPE: + case FTP_LIST_TYPE: + case FTP_RETR_TYPE: + case FTP_STOR_TYPE: + case FTP_RETR_LIST_TYPE: + result = ftp_state_type_resp(data, ftpc, ftp, ftpcode, ftpc->state); + break; + + case FTP_SIZE: + case FTP_RETR_SIZE: + case FTP_STOR_SIZE: + result = ftp_state_size_resp(data, ftpc, ftp, ftpcode, ftpc->state); + break; + + case FTP_REST: + case FTP_RETR_REST: + result = ftp_state_rest_resp(data, ftpc, ftp, ftpcode, ftpc->state); + break; + + case FTP_PRET: + if(ftpcode != 200) { + /* there only is this one standard OK return code. */ + failf(data, "PRET command not accepted: %03d", ftpcode); + return CURLE_FTP_PRET_FAILED; + } + result = ftp_state_use_pasv(data, ftpc, conn); + break; + + case FTP_PASV: + result = ftp_state_pasv_resp(data, ftpc, ftpcode); + break; + + case FTP_PORT: + result = ftp_state_port_resp(data, ftpc, ftp, ftpcode); + break; + + case FTP_LIST: + case FTP_RETR: + result = ftp_state_get_resp(data, ftpc, ftp, ftpcode, ftpc->state); + break; + + case FTP_STOR: + result = ftp_state_stor_resp(data, ftpc, ftpcode); + break; + + case FTP_QUIT: + default: + /* internal error */ + ftp_state(data, ftpc, FTP_STOP); + break; + } + + return result; +} + +/* called repeatedly until done from multi.c */ +static CURLcode ftp_multi_statemach(struct Curl_easy *data, + bool *done) +{ + struct ftp_conn *ftpc = Curl_conn_meta_get(data->conn, CURL_META_FTP_CONN); + return ftpc ? ftp_statemach(data, ftpc, done) : CURLE_FAILED_INIT; +} + +static CURLcode ftp_block_statemach(struct Curl_easy *data, + struct ftp_conn *ftpc) +{ + struct pingpong *pp = &ftpc->pp; + CURLcode result = CURLE_OK; + + while(ftpc->state != FTP_STOP) { + if(ftpc->shutdown) + CURL_TRC_FTP(data, "in shutdown, waiting for server response"); + result = Curl_pp_statemach(data, pp, TRUE, TRUE /* disconnecting */); + if(result) + break; + } + + return result; +} + +/* + * ftp_connect() should do everything that is to be considered a part of + * the connection phase. + * + * The variable 'done' points to will be TRUE if the protocol-layer connect + * phase is done when this function returns, or FALSE if not. + * + */ +static CURLcode ftp_connect(struct Curl_easy *data, + bool *done) /* see description above */ +{ + CURLcode result; + struct connectdata *conn = data->conn; + struct ftp_conn *ftpc = Curl_conn_meta_get(data->conn, CURL_META_FTP_CONN); + struct pingpong *pp; + + *done = FALSE; /* default to not done yet */ + if(!ftpc) + return CURLE_FAILED_INIT; + pp = &ftpc->pp; + PINGPONG_SETUP(pp, ftp_pp_statemachine, ftp_endofresp); + + if(Curl_conn_is_ssl(conn, FIRSTSOCKET)) { + /* BLOCKING */ + result = Curl_conn_connect(data, FIRSTSOCKET, TRUE, done); + if(result) + return result; + } + + Curl_pp_init(pp, Curl_pgrs_now(data)); /* once per transfer */ + + /* When we connect, we start in the state where we await the 220 + response */ + ftp_state(data, ftpc, FTP_WAIT220); + + result = ftp_statemach(data, ftpc, done); + + return result; +} + +/*********************************************************************** + * + * ftp_sendquote() + * + * Where a 'quote' means a list of custom commands to send to the server. + * The quote list is passed as an argument. + * + * BLOCKING + */ +static CURLcode ftp_sendquote(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct curl_slist *quote) +{ + struct curl_slist *item; + struct pingpong *pp = &ftpc->pp; + + item = quote; + while(item) { + if(item->data) { + size_t nread; + const char *cmd = item->data; + bool acceptfail = FALSE; + CURLcode result; + int ftpcode = 0; + + /* if a command starts with an asterisk, which a legal FTP command never + can, the command will be allowed to fail without it causing any + aborts or cancels etc. It will cause libcurl to act as if the command + is successful, whatever the server responds. */ + + if(cmd[0] == '*') { + cmd++; + acceptfail = TRUE; + } + + result = Curl_pp_sendf(data, &ftpc->pp, "%s", cmd); + if(!result) { + pp->response = *Curl_pgrs_now(data); /* timeout relative now */ + result = getftpresponse(data, &nread, &ftpcode); + } + if(result) + return result; + + if(!acceptfail && (ftpcode >= 400)) { + failf(data, "QUOT string not accepted: %s", cmd); + return CURLE_QUOTE_ERROR; + } + } + + item = item->next; + } + + return CURLE_OK; +} + +static CURLcode ftp_done_status(struct connectdata *conn, + struct ftp_conn *ftpc, CURLcode status, + bool premature) +{ + switch(status) { + case CURLE_BAD_DOWNLOAD_RESUME: + case CURLE_FTP_WEIRD_PASV_REPLY: + case CURLE_FTP_PORT_FAILED: + case CURLE_FTP_ACCEPT_FAILED: + case CURLE_FTP_ACCEPT_TIMEOUT: + case CURLE_FTP_COULDNT_SET_TYPE: + case CURLE_FTP_COULDNT_RETR_FILE: + case CURLE_PARTIAL_FILE: + case CURLE_UPLOAD_FAILED: + case CURLE_REMOTE_ACCESS_DENIED: + case CURLE_FILESIZE_EXCEEDED: + case CURLE_REMOTE_FILE_NOT_FOUND: + case CURLE_WRITE_ERROR: + /* the connection stays alive fine even though this happened */ + case CURLE_OK: /* does not affect the control connection's status */ + if(!premature) + break; + + /* until we cope better with prematurely ended requests, let them + * fallback as if in complete failure */ + FALLTHROUGH(); + default: /* by default, an error means the control connection is + wedged and should not be used anymore */ + ftpc->ctl_valid = FALSE; + ftpc->cwdfail = TRUE; /* set this TRUE to prevent us to remember the + current path, as this connection is going */ + connclose(conn, "FTP ended with bad error code"); + return status; /* use the already set error code */ + } + return CURLE_OK; +} + +static void ftp_done_wildcard(struct Curl_easy *data, struct ftp_conn *ftpc) +{ + if(data->state.wildcardmatch) { + if(data->set.chunk_end && ftpc->file) { + Curl_set_in_callback(data, TRUE); + data->set.chunk_end(data->set.wildcardptr); + Curl_set_in_callback(data, FALSE); + freedirs(ftpc); + } + ftpc->known_filesize = -1; + } +} + +static void ftp_done_path(struct Curl_easy *data, struct ftp_conn *ftpc, + CURLcode result) +{ + struct connectdata *conn = data->conn; + if(result) { + /* We can limp along anyway (and should try to since we may already be in + * the error path) */ + ftpc->ctl_valid = FALSE; /* mark control connection as bad */ + connclose(conn, "FTP: out of memory!"); /* mark for connection closure */ + curlx_safefree(ftpc->prevpath); /* no path remembering */ + } + else { /* remember working directory for connection reuse */ + const char *rawPath = ftpc->rawpath; + if(rawPath) { + if((data->set.ftp_filemethod == FTPFILE_NOCWD) && (rawPath[0] == '/')) + ; /* full path => no CWDs happened => keep ftpc->prevpath */ + else { + size_t pathLen = strlen(ftpc->rawpath); + + curlx_free(ftpc->prevpath); + + if(!ftpc->cwdfail) { + if(data->set.ftp_filemethod == FTPFILE_NOCWD) + pathLen = 0; /* relative path => working directory is FTP home */ + else + /* file is URL-decoded */ + pathLen -= ftpc->file ? strlen(ftpc->file) : 0; + ftpc->prevpath = curlx_memdup0(rawPath, pathLen); + } + else + ftpc->prevpath = NULL; /* no path */ + } + } + if(ftpc->prevpath) + infof(data, "Remembering we are in directory \"%s\"", ftpc->prevpath); + } +} + +static CURLcode ftp_done_secondary_socket(struct Curl_easy *data, + struct ftp_conn *ftpc, + CURLcode result) +{ + struct connectdata *conn = data->conn; + if(Curl_conn_is_setup(conn, SECONDARYSOCKET)) { + if(!result && ftpc->dont_check && data->req.maxdownload > 0) { + /* partial download completed */ + result = Curl_pp_sendf(data, &ftpc->pp, "%s", "ABOR"); + if(result) { + failf(data, "Failure sending ABOR command: %s", + curl_easy_strerror(result)); + ftpc->ctl_valid = FALSE; /* mark control connection as bad */ + connclose(conn, "ABOR command failed"); /* connection closure */ + } + } + + close_secondarysocket(data, ftpc); + } + return result; +} + +static CURLcode ftp_done_control_reply(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct FTP *ftp, CURLcode result, + bool premature) +{ + struct connectdata *conn = data->conn; + size_t nread; + int ftpcode; + + if(!result && (ftp->transfer == PPTRANSFER_BODY) && ftpc->ctl_valid && + ftpc->pp.pending_resp && !premature) { + /* + * Let's see what the server says about the transfer we performed, but + * lower the timeout as sometimes this connection has died while the data + * has been transferred. This happens when doing through NATs etc that + * abandon old silent connections. + */ + ftpc->pp.response = *Curl_pgrs_now(data); /* timeout relative now */ + result = getftpresponse(data, &nread, &ftpcode); + + if(!nread && (result == CURLE_OPERATION_TIMEDOUT)) { + failf(data, "control connection looks dead"); + ftpc->ctl_valid = FALSE; /* mark control connection as bad */ + connclose(conn, "Timeout or similar in FTP DONE operation"); /* close */ + } + + if(result) + return result; + + if(ftpc->dont_check && data->req.maxdownload > 0) { + /* we have sent ABOR and there is no reliable way to check if it was + * successful or not; we have to close the connection now */ + infof(data, "partial download completed, closing connection"); + connclose(conn, "Partial download with no ability to check"); + return result; + } + + if(!ftpc->dont_check) { + /* 226 Transfer complete, 250 Requested file action okay, completed. */ + switch(ftpcode) { + case 226: + case 250: + break; + case 552: + failf(data, "Exceeded storage allocation"); + result = CURLE_REMOTE_DISK_FULL; + break; + default: + failf(data, "server did not report OK, got %d", ftpcode); + result = CURLE_PARTIAL_FILE; + break; + } + } + } + return result; +} + +static CURLcode ftp_done_check_partial(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct FTP *ftp, CURLcode result, + bool premature) +{ + if(result || premature) + /* the response code from the transfer showed an error already so no + use checking further */ + ; + else if(data->state.upload) { + if((ftp->transfer == PPTRANSFER_BODY) && + (data->state.infilesize != -1) && /* upload with known size */ + ((!data->set.crlf && !data->state.prefer_ascii && /* no conversion */ + (data->state.infilesize != data->req.writebytecount)) || + ((data->set.crlf || data->state.prefer_ascii) && /* maybe crlf conv */ + (data->state.infilesize > data->req.writebytecount)) + )) { + failf(data, "Uploaded unaligned file size (%" FMT_OFF_T + " out of %" FMT_OFF_T " bytes)", + data->req.writebytecount, data->state.infilesize); + result = CURLE_PARTIAL_FILE; + } + } + else { + if((data->req.size != -1) && + (data->req.size != data->req.bytecount) && + (data->req.maxdownload != data->req.bytecount)) { + failf(data, "Received only partial file: %" FMT_OFF_T " bytes", + data->req.bytecount); + result = CURLE_PARTIAL_FILE; + } + else if(!ftpc->dont_check && + !data->req.bytecount && + (data->req.size > 0)) { + failf(data, "No data was received"); + result = CURLE_FTP_COULDNT_RETR_FILE; + } + } + return result; +} + +/*********************************************************************** + * + * ftp_done() + * + * The DONE function. This does what needs to be done after a single DO has + * performed. + * + * Input argument is already checked for validity. + */ +static CURLcode ftp_done(struct Curl_easy *data, CURLcode status, + bool premature) +{ + struct FTP *ftp = Curl_meta_get(data, CURL_META_FTP_EASY); + struct ftp_conn *ftpc = Curl_conn_meta_get(data->conn, CURL_META_FTP_CONN); + CURLcode result; + + if(!ftp || !ftpc) + return CURLE_OK; + + result = ftp_done_status(data->conn, ftpc, status, premature); + + ftp_done_wildcard(data, ftpc); + ftp_done_path(data, ftpc, result); + result = ftp_done_secondary_socket(data, ftpc, result); + result = ftp_done_control_reply(data, ftpc, ftp, result, premature); + result = ftp_done_check_partial(data, ftpc, ftp, result, premature); + + /* clear these for next connection */ + ftp->transfer = PPTRANSFER_BODY; + ftpc->dont_check = FALSE; + + /* Send any post-transfer QUOTE strings? */ + if(!status && !result && !premature && data->set.postquote) + result = ftp_sendquote(data, ftpc, data->set.postquote); + CURL_TRC_FTP(data, "[%s] done, result=%d", FTP_CSTATE(ftpc), (int)result); + return result; +} + +/*********************************************************************** + * + * ftp_nb_type() + * + * Set TYPE. We only deal with ASCII or BINARY so this function + * sets one of them. + * If the transfer type is not sent, simulate on OK response in newstate + */ +static CURLcode ftp_nb_type(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct FTP *ftp, + bool ascii, ftpstate newstate) +{ + CURLcode result; + char want = (char)(ascii ? 'A' : 'I'); + + if(ftpc->transfertype == want) { + ftp_state(data, ftpc, newstate); + return ftp_state_type_resp(data, ftpc, ftp, 200, newstate); + } + + result = Curl_pp_sendf(data, &ftpc->pp, "TYPE %c", want); + if(!result) { + ftp_state(data, ftpc, newstate); + + /* keep track of our current transfer type */ + ftpc->transfertype = want; + } + return result; +} + +/*********************************************************************** + * + * ftp_perform() + * + * This is the actual DO function for FTP. Get a file/directory according to + * the options previously setup. + */ +static CURLcode ftp_perform( + struct Curl_easy *data, + struct ftp_conn *ftpc, + struct FTP *ftp, + bool *connected, /* connect status after PASV / PORT */ + bool *dophase_done) +{ + /* this is FTP and no proxy */ + CURLcode result = CURLE_OK; + + CURL_TRC_FTP(data, "[%s] DO phase starts", FTP_CSTATE(ftpc)); + + if(data->req.no_body) { + /* requested no body means no transfer... */ + ftp->transfer = PPTRANSFER_INFO; + } + + *dophase_done = FALSE; /* not done yet */ + + /* start the first command in the DO phase */ + result = ftp_state_quote(data, ftpc, ftp, TRUE, FTP_QUOTE); + if(result) + return result; + + /* run the state-machine */ + result = ftp_statemach(data, ftpc, dophase_done); + + *connected = Curl_conn_is_connected(data->conn, SECONDARYSOCKET); + + if(*connected) + infof(data, "[FTP] [%s] perform, DATA connection established", + FTP_CSTATE(ftpc)); + else + CURL_TRC_FTP(data, "[%s] perform, awaiting DATA connect", + FTP_CSTATE(ftpc)); + + if(*dophase_done) + CURL_TRC_FTP(data, "[%s] DO phase is complete1", FTP_CSTATE(ftpc)); + + return result; +} + +static void wc_data_dtor(void *ptr) +{ + struct ftp_wc *ftpwc = ptr; + if(ftpwc && ftpwc->parser) + Curl_ftp_parselist_data_free(&ftpwc->parser); + curlx_free(ftpwc); +} + +static CURLcode init_wc_data(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct FTP *ftp) +{ + char *last_slash; + char *path = ftp->path; + struct WildcardData *wildcard = data->wildcard; + CURLcode result = CURLE_OK; + struct ftp_wc *ftpwc = NULL; + + last_slash = strrchr(ftp->path, '/'); + if(last_slash) { + last_slash++; + if(last_slash[0] == '\0') { + wildcard->state = CURLWC_CLEAN; + return ftp_parse_url_path(data, ftpc, ftp); + } + wildcard->pattern = curlx_strdup(last_slash); + if(!wildcard->pattern) + return CURLE_OUT_OF_MEMORY; + last_slash[0] = '\0'; /* cut file from path */ + } + else { /* there is only 'wildcard pattern' or nothing */ + if(path[0]) { + wildcard->pattern = curlx_strdup(path); + if(!wildcard->pattern) + return CURLE_OUT_OF_MEMORY; + path[0] = '\0'; + } + else { /* only list */ + wildcard->state = CURLWC_CLEAN; + return ftp_parse_url_path(data, ftpc, ftp); + } + } + + /* program continues only if URL is not ending with slash, allocate needed + resources for wildcard transfer */ + + /* allocate ftp protocol specific wildcard data */ + ftpwc = curlx_calloc(1, sizeof(struct ftp_wc)); + if(!ftpwc) { + result = CURLE_OUT_OF_MEMORY; + goto fail; + } + + /* INITIALIZE parselist structure */ + ftpwc->parser = Curl_ftp_parselist_data_alloc(); + if(!ftpwc->parser) { + result = CURLE_OUT_OF_MEMORY; + goto fail; + } + + wildcard->ftpwc = ftpwc; /* put it to the WildcardData tmp pointer */ + wildcard->dtor = wc_data_dtor; + + /* wildcard does not support NOCWD option (assert it?) */ + if(data->set.ftp_filemethod == FTPFILE_NOCWD) + data->set.ftp_filemethod = FTPFILE_MULTICWD; + + /* try to parse ftp URL */ + result = ftp_parse_url_path(data, ftpc, ftp); + if(result) { + goto fail; + } + + wildcard->path = curlx_strdup(ftp->path); + if(!wildcard->path) { + result = CURLE_OUT_OF_MEMORY; + goto fail; + } + + /* backup old write_function */ + ftpwc->backup.write_function = data->set.fwrite_func; + /* parsing write function */ + data->set.fwrite_func = Curl_ftp_parselist; + /* backup old file descriptor */ + ftpwc->backup.file_descriptor = data->set.out; + /* let the writefunc callback know the transfer */ + data->set.out = data; + + infof(data, "Wildcard - Parsing started"); + return CURLE_OK; + +fail: + if(ftpwc) { + Curl_ftp_parselist_data_free(&ftpwc->parser); + curlx_free(ftpwc); + } + curlx_safefree(wildcard->pattern); + wildcard->dtor = ZERO_NULL; + wildcard->ftpwc = NULL; + return result; +} + +static CURLcode wc_statemach(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct FTP *ftp) +{ + struct WildcardData * const wildcard = data->wildcard; + CURLcode result = CURLE_OK; + + for(;;) { + switch(wildcard->state) { + case CURLWC_INIT: + result = init_wc_data(data, ftpc, ftp); + if(wildcard->state == CURLWC_CLEAN) + /* only listing! */ + return result; + wildcard->state = result ? CURLWC_ERROR : CURLWC_MATCHING; + return result; + + case CURLWC_MATCHING: { + /* In this state is LIST response successfully parsed, so lets restore + previous WRITEFUNCTION callback and WRITEDATA pointer */ + struct ftp_wc *ftpwc = wildcard->ftpwc; + data->set.fwrite_func = ftpwc->backup.write_function; + data->set.out = ftpwc->backup.file_descriptor; + ftpwc->backup.write_function = ZERO_NULL; + ftpwc->backup.file_descriptor = NULL; + wildcard->state = CURLWC_DOWNLOADING; + + if(Curl_ftp_parselist_geterror(ftpwc->parser)) { + /* error found in LIST parsing */ + wildcard->state = CURLWC_CLEAN; + continue; + } + if(Curl_llist_count(&wildcard->filelist) == 0) { + /* no corresponding file */ + wildcard->state = CURLWC_CLEAN; + return CURLE_REMOTE_FILE_NOT_FOUND; + } + continue; + } + + case CURLWC_DOWNLOADING: { + /* filelist has at least one file, lets get first one */ + struct Curl_llist_node *head = Curl_llist_head(&wildcard->filelist); + struct curl_fileinfo *finfo = Curl_node_elem(head); + + char *tmp_path = curl_maprintf("%s%s", wildcard->path, finfo->filename); + if(!tmp_path) + return CURLE_OUT_OF_MEMORY; + + /* switch default ftp->path and tmp_path */ + curlx_free(ftp->pathalloc); + ftp->pathalloc = ftp->path = tmp_path; + + infof(data, "Wildcard - START of \"%s\"", finfo->filename); + if(data->set.chunk_bgn) { + long userresponse; + Curl_set_in_callback(data, TRUE); + userresponse = data->set.chunk_bgn( + finfo, data->set.wildcardptr, + (int)Curl_llist_count(&wildcard->filelist)); + Curl_set_in_callback(data, FALSE); + switch(userresponse) { + case CURL_CHUNK_BGN_FUNC_SKIP: + infof(data, "Wildcard - \"%s\" skipped by user", finfo->filename); + wildcard->state = CURLWC_SKIP; + continue; + case CURL_CHUNK_BGN_FUNC_FAIL: + return CURLE_CHUNK_FAILED; + } + } + + if(finfo->filetype != CURLFILETYPE_FILE) { + wildcard->state = CURLWC_SKIP; + continue; + } + + if(finfo->flags & CURLFINFOFLAG_KNOWN_SIZE) + ftpc->known_filesize = finfo->size; + + result = ftp_parse_url_path(data, ftpc, ftp); + if(result) + return result; + + /* we do not need the Curl_fileinfo of first file anymore */ + Curl_node_remove(Curl_llist_head(&wildcard->filelist)); + + if(Curl_llist_count(&wildcard->filelist) == 0) { + /* remains only one file to down. */ + wildcard->state = CURLWC_CLEAN; + /* after that will be ftp_do called once again and no transfer + will be done because of CURLWC_CLEAN state */ + return CURLE_OK; + } + return result; + } + + case CURLWC_SKIP: { + if(data->set.chunk_end) { + Curl_set_in_callback(data, TRUE); + data->set.chunk_end(data->set.wildcardptr); + Curl_set_in_callback(data, FALSE); + } + Curl_node_remove(Curl_llist_head(&wildcard->filelist)); + wildcard->state = (Curl_llist_count(&wildcard->filelist) == 0) ? + CURLWC_CLEAN : CURLWC_DOWNLOADING; + continue; + } + + case CURLWC_CLEAN: { + struct ftp_wc *ftpwc = wildcard->ftpwc; + result = CURLE_OK; + if(ftpwc) + result = Curl_ftp_parselist_geterror(ftpwc->parser); + + wildcard->state = result ? CURLWC_ERROR : CURLWC_DONE; + return result; + } + + case CURLWC_DONE: + case CURLWC_ERROR: + case CURLWC_CLEAR: + if(wildcard->dtor) { + wildcard->dtor(wildcard->ftpwc); + wildcard->ftpwc = NULL; + } + return result; + } + } + /* UNREACHABLE */ +} + +/*********************************************************************** + * + * ftp_regular_transfer() + * + * The input argument is already checked for validity. + * + * Performs all commands done before a regular transfer between a local and a + * remote host. + * + * ftp->ctl_valid starts out as FALSE, and gets set to TRUE if we reach the + * ftp_done() function without finding any major problem. + */ +static CURLcode ftp_regular_transfer(struct Curl_easy *data, + struct ftp_conn *ftpc, + struct FTP *ftp, + bool *dophase_done) +{ + CURLcode result = CURLE_OK; + bool connected = FALSE; + data->req.size = -1; /* make sure this is unknown at this point */ + + Curl_pgrsReset(data); + + ftpc->ctl_valid = TRUE; /* starts good */ + + result = ftp_perform(data, ftpc, ftp, + &connected, /* have we connected after PASV/PORT */ + dophase_done); /* all commands in the DO-phase done? */ + + if(!result) { + + if(!*dophase_done) + /* the DO phase has not completed yet */ + return CURLE_OK; + + result = ftp_dophase_done(data, ftpc, ftp, connected); + + if(result) + return result; + } + else + freedirs(ftpc); + + return result; +} + +/*********************************************************************** + * + * ftp_do() + * + * This function is registered as 'curl_do' function. It decodes the path + * parts etc as a wrapper to the actual DO function (ftp_perform). + * + * The input argument is already checked for validity. + */ +static CURLcode ftp_do(struct Curl_easy *data, bool *done) +{ + CURLcode result = CURLE_OK; + struct ftp_conn *ftpc = Curl_conn_meta_get(data->conn, CURL_META_FTP_CONN); + struct FTP *ftp = Curl_meta_get(data, CURL_META_FTP_EASY); + + *done = FALSE; /* default to false */ + if(!ftpc || !ftp) + return CURLE_FAILED_INIT; + ftpc->wait_data_conn = FALSE; /* default to no such wait */ + +#ifdef CURL_PREFER_LF_LINEENDS + { + /* FTP data may need conversion. */ + struct Curl_cwriter *ftp_lc_writer; + + result = Curl_cwriter_create(&ftp_lc_writer, data, &ftp_cw_lc, + CURL_CW_CONTENT_DECODE); + if(result) + return result; + + result = Curl_cwriter_add(data, ftp_lc_writer); + if(result) { + Curl_cwriter_free(data, ftp_lc_writer); + return result; + } + } +#endif /* CURL_PREFER_LF_LINEENDS */ + + if(data->state.wildcardmatch) { + result = wc_statemach(data, ftpc, ftp); + if(data->wildcard->state == CURLWC_SKIP || + data->wildcard->state == CURLWC_DONE) { + /* do not call ftp_regular_transfer */ + return CURLE_OK; + } + if(result) /* error, loop or skipping the file */ + return result; + } + else { /* no wildcard FSM needed */ + result = ftp_parse_url_path(data, ftpc, ftp); + if(result) + return result; + } + + result = ftp_regular_transfer(data, ftpc, ftp, done); + + return result; +} + +/*********************************************************************** + * + * ftp_quit() + * + * This should be called before calling sclose() on an ftp control connection + * (not data connections). We should then wait for the response from the + * server before returning. The calling code should then try to close the + * connection. + * + */ +static CURLcode ftp_quit(struct Curl_easy *data, + struct ftp_conn *ftpc) +{ + CURLcode result = CURLE_OK; + + if(ftpc->ctl_valid) { + CURL_TRC_FTP(data, "sending QUIT to close session"); + result = Curl_pp_sendf(data, &ftpc->pp, "%s", "QUIT"); + if(result) { + failf(data, "Failure sending QUIT command: %s", + curl_easy_strerror(result)); + ftpc->ctl_valid = FALSE; /* mark control connection as bad */ + connclose(data->conn, "QUIT command failed"); /* mark for closure */ + ftp_state(data, ftpc, FTP_STOP); + return result; + } + + ftp_state(data, ftpc, FTP_QUIT); + + result = ftp_block_statemach(data, ftpc); + } + + return result; +} + +/*********************************************************************** + * + * ftp_disconnect() + * + * Disconnect from an FTP server. Cleanup protocol-specific per-connection + * resources. BLOCKING. + */ +static CURLcode ftp_disconnect(struct Curl_easy *data, + struct connectdata *conn, + bool dead_connection) +{ + struct ftp_conn *ftpc = Curl_conn_meta_get(conn, CURL_META_FTP_CONN); + + if(!ftpc) + return CURLE_FAILED_INIT; + /* We cannot send quit unconditionally. If this connection is stale or + bad in any way, sending quit and waiting around here will make the + disconnect wait in vain and cause more problems than we need to. + + ftp_quit() will check the state of ftp->ctl_valid. If it is ok it + will try to send the QUIT command, otherwise it will return. + */ + ftpc->shutdown = TRUE; + if(dead_connection || Curl_pp_needs_flush(data, &ftpc->pp)) + ftpc->ctl_valid = FALSE; + + /* The FTP session may or may not have been allocated/setup at this point! */ + (void)ftp_quit(data, ftpc); /* ignore errors on the QUIT */ + return CURLE_OK; +} + +/* called from multi.c while DOing */ +static CURLcode ftp_doing(struct Curl_easy *data, + bool *dophase_done) +{ + struct ftp_conn *ftpc = Curl_conn_meta_get(data->conn, CURL_META_FTP_CONN); + struct FTP *ftp = Curl_meta_get(data, CURL_META_FTP_EASY); + CURLcode result; + + if(!ftpc || !ftp) + return CURLE_FAILED_INIT; + result = ftp_statemach(data, ftpc, dophase_done); + + if(result) + CURL_TRC_FTP(data, "[%s] DO phase failed", FTP_CSTATE(ftpc)); + else if(*dophase_done) { + result = ftp_dophase_done(data, ftpc, ftp, FALSE /* not connected */); + + CURL_TRC_FTP(data, "[%s] DO phase is complete2", FTP_CSTATE(ftpc)); + } + return result; +} + +static void ftp_easy_dtor(void *key, size_t klen, void *entry) +{ + struct FTP *ftp = entry; + (void)key; + (void)klen; + curlx_safefree(ftp->pathalloc); + curlx_free(ftp); +} + +static void ftp_conn_dtor(void *key, size_t klen, void *entry) +{ + struct ftp_conn *ftpc = entry; + (void)key; + (void)klen; + freedirs(ftpc); + curlx_safefree(ftpc->account); + curlx_safefree(ftpc->alternative_to_user); + curlx_safefree(ftpc->entrypath); + curlx_safefree(ftpc->prevpath); + curlx_safefree(ftpc->server_os); + Curl_pp_disconnect(&ftpc->pp); + curlx_free(ftpc); +} + +static void type_url_check(struct Curl_easy *data, struct FTP *ftp) +{ + size_t len = strlen(ftp->path); + /* FTP URLs support an extension like ";type=" that + * we will try to get now! */ + if((len >= 7) && !memcmp(&ftp->path[len - 7], ";type=", 6)) { + char *type = &ftp->path[len - 7]; + char command = Curl_raw_toupper(type[6]); + + *type = 0; /* cut it off */ + + switch(command) { + case 'A': /* ASCII mode */ + data->state.prefer_ascii = TRUE; + break; + + case 'D': /* directory mode */ + data->state.list_only = TRUE; + break; + + case 'I': /* binary mode */ + default: + /* switch off ASCII */ + data->state.prefer_ascii = FALSE; + break; + } + } +} + +static CURLcode ftp_setup_connection(struct Curl_easy *data, + struct connectdata *conn) +{ + struct FTP *ftp; + CURLcode result = CURLE_OK; + struct ftp_conn *ftpc; + + ftp = curlx_calloc(1, sizeof(*ftp)); + if(!ftp || + Curl_meta_set(data, CURL_META_FTP_EASY, ftp, ftp_easy_dtor)) + return CURLE_OUT_OF_MEMORY; + + ftpc = curlx_calloc(1, sizeof(*ftpc)); + if(!ftpc || + Curl_conn_meta_set(conn, CURL_META_FTP_CONN, ftpc, ftp_conn_dtor)) + return CURLE_OUT_OF_MEMORY; + + /* clone connection related data that is FTP specific */ + if(data->set.str[STRING_FTP_ACCOUNT]) { + ftpc->account = curlx_strdup(data->set.str[STRING_FTP_ACCOUNT]); + if(!ftpc->account) { + Curl_conn_meta_remove(conn, CURL_META_FTP_CONN); + return CURLE_OUT_OF_MEMORY; + } + } + if(data->set.str[STRING_FTP_ALTERNATIVE_TO_USER]) { + ftpc->alternative_to_user = + curlx_strdup(data->set.str[STRING_FTP_ALTERNATIVE_TO_USER]); + if(!ftpc->alternative_to_user) { + curlx_safefree(ftpc->account); + Curl_conn_meta_remove(conn, CURL_META_FTP_CONN); + return CURLE_OUT_OF_MEMORY; + } + } + + ftp->path = &data->state.up.path[1]; /* do not include the initial slash */ + + type_url_check(data, ftp); + + /* get some initial data into the ftp struct */ + ftp->transfer = PPTRANSFER_BODY; + ftp->downloadsize = 0; + ftpc->known_filesize = -1; /* unknown size for now */ + ftpc->use_ssl = data->set.use_ssl; + ftpc->ccc = data->set.ftp_ccc; + + CURL_TRC_FTP(data, "[%s] setup connection -> %d", FTP_CSTATE(ftpc), + (int)result); + return result; +} + +bool ftp_conns_match(struct connectdata *needle, struct connectdata *conn) +{ + struct ftp_conn *nftpc = Curl_conn_meta_get(needle, CURL_META_FTP_CONN); + struct ftp_conn *cftpc = Curl_conn_meta_get(conn, CURL_META_FTP_CONN); + /* Also match ACCOUNT, ALTERNATIVE-TO-USER and CCC options */ + if(!nftpc || !cftpc || + Curl_timestrcmp(nftpc->account, cftpc->account) || + Curl_timestrcmp(nftpc->alternative_to_user, + cftpc->alternative_to_user) || + (nftpc->ccc != cftpc->ccc)) + return FALSE; + /* A mismatch on `use_ssl` MUST have been found in connection matching + * before we come here. This is a check on MAYBE/MUST use of STARTTLS and + * it only works on FTP. But IMAP/SMTP etc have the same `use_ssl` and + * no extra match like FTP. We lack tests in this area, so let FTP fail + * loudly here to help other cases. */ + if(nftpc->use_ssl > cftpc->use_ssl) { + DEBUGASSERT(0); + return FALSE; + } + return TRUE; +} + +/* + * FTP protocol. + */ +const struct Curl_protocol Curl_protocol_ftp = { + ftp_setup_connection, /* setup_connection */ + ftp_do, /* do_it */ + ftp_done, /* done */ + ftp_do_more, /* do_more */ + ftp_connect, /* connect_it */ + ftp_multi_statemach, /* connecting */ + ftp_doing, /* doing */ + ftp_pollset, /* proto_pollset */ + ftp_pollset, /* doing_pollset */ + ftp_domore_pollset, /* domore_pollset */ + ZERO_NULL, /* perform_pollset */ + ftp_disconnect, /* disconnect */ + ZERO_NULL, /* write_resp */ + ZERO_NULL, /* write_resp_hd */ + ZERO_NULL, /* connection_is_dead */ + ZERO_NULL, /* attach connection */ + ZERO_NULL, /* follow */ +}; + +#endif /* CURL_DISABLE_FTP */ diff --git a/3rdparty/curl-8.21.0/lib/ftp.h b/3rdparty/curl-8.21.0/lib/ftp.h new file mode 100644 index 0000000000..257f595826 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/ftp.h @@ -0,0 +1,44 @@ +#ifndef HEADER_CURL_FTP_H +#define HEADER_CURL_FTP_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifndef CURL_DISABLE_FTP +extern const struct Curl_protocol Curl_protocol_ftp; + +bool ftp_conns_match(struct connectdata *needle, struct connectdata *conn); + +typedef enum { + FTPFILE_MULTICWD = 1, /* as defined by RFC1738 */ + FTPFILE_NOCWD = 2, /* use SIZE / RETR / STOR on the full path */ + FTPFILE_SINGLECWD = 3 /* make one CWD, then SIZE / RETR / STOR on the + file */ +} curl_ftpfile; + +#endif /* CURL_DISABLE_FTP */ + +#define DEFAULT_ACCEPT_TIMEOUT 60000 /* milliseconds == one minute */ + +#endif /* HEADER_CURL_FTP_H */ diff --git a/3rdparty/curl-8.21.0/lib/ftplistparser.c b/3rdparty/curl-8.21.0/lib/ftplistparser.c new file mode 100644 index 0000000000..23fbd1f07c --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/ftplistparser.c @@ -0,0 +1,1090 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifndef CURL_DISABLE_FTP + +/** + * Now implemented: + * + * 1) Unix version 1 + * drwxr-xr-x 1 user01 ftp 512 Jan 29 23:32 prog + * 2) Unix version 2 + * drwxr-xr-x 1 user01 ftp 512 Jan 29 1997 prog + * 3) Unix version 3 + * drwxr-xr-x 1 1 1 512 Jan 29 23:32 prog + * 4) Unix symlink + * lrwxr-xr-x 1 user01 ftp 512 Jan 29 23:32 prog -> prog2000 + * 5) DOS style + * 01-29-97 11:32PM prog + */ + +#include "urldata.h" +#include "fileinfo.h" +#include "llist.h" +#include "ftp.h" +#include "ftp-int.h" +#include "ftplistparser.h" +#include "curl_fnmatch.h" +#include "multiif.h" +#include "curlx/strparse.h" + +typedef enum { + PL_UNIX_TOTALSIZE = 0, + PL_UNIX_FILETYPE, + PL_UNIX_PERMISSION, + PL_UNIX_HLINKS, + PL_UNIX_USER, + PL_UNIX_GROUP, + PL_UNIX_SIZE, + PL_UNIX_TIME, + PL_UNIX_FILENAME, + PL_UNIX_SYMLINK +} pl_unix_mainstate; + +typedef union { + enum { + PL_UNIX_TOTALSIZE_INIT = 0, + PL_UNIX_TOTALSIZE_READING + } total_dirsize; + + enum { + PL_UNIX_HLINKS_PRESPACE = 0, + PL_UNIX_HLINKS_NUMBER + } hlinks; + + enum { + PL_UNIX_USER_PRESPACE = 0, + PL_UNIX_USER_PARSING + } user; + + enum { + PL_UNIX_GROUP_PRESPACE = 0, + PL_UNIX_GROUP_NAME + } group; + + enum { + PL_UNIX_SIZE_PRESPACE = 0, + PL_UNIX_SIZE_NUMBER + } size; + + enum { + PL_UNIX_TIME_PREPART1 = 0, + PL_UNIX_TIME_PART1, + PL_UNIX_TIME_PREPART2, + PL_UNIX_TIME_PART2, + PL_UNIX_TIME_PREPART3, + PL_UNIX_TIME_PART3 + } time; + + enum { + PL_UNIX_FILENAME_PRESPACE = 0, + PL_UNIX_FILENAME_NAME, + PL_UNIX_FILENAME_WINDOWSEOL + } filename; + + enum { + PL_UNIX_SYMLINK_PRESPACE = 0, + PL_UNIX_SYMLINK_NAME, + PL_UNIX_SYMLINK_PRETARGET1, + PL_UNIX_SYMLINK_PRETARGET2, + PL_UNIX_SYMLINK_PRETARGET3, + PL_UNIX_SYMLINK_PRETARGET4, + PL_UNIX_SYMLINK_TARGET, + PL_UNIX_SYMLINK_WINDOWSEOL + } symlink; +} pl_unix_substate; + +typedef enum { + PL_WINNT_DATE = 0, + PL_WINNT_TIME, + PL_WINNT_DIRORSIZE, + PL_WINNT_FILENAME +} pl_winNT_mainstate; + +typedef union { + enum { + PL_WINNT_TIME_PRESPACE = 0, + PL_WINNT_TIME_TIME + } time; + enum { + PL_WINNT_DIRORSIZE_PRESPACE = 0, + PL_WINNT_DIRORSIZE_CONTENT + } dirorsize; + enum { + PL_WINNT_FILENAME_PRESPACE = 0, + PL_WINNT_FILENAME_CONTENT, + PL_WINNT_FILENAME_WINEOL + } filename; +} pl_winNT_substate; + +/* This struct is used in wildcard downloading - for parsing LIST response */ +struct ftp_parselist_data { + enum { + OS_TYPE_UNKNOWN = 0, + OS_TYPE_UNIX, + OS_TYPE_WIN_NT + } os_type; + + union { + struct { + pl_unix_mainstate main; + pl_unix_substate sub; + } UNIX; + + struct { + pl_winNT_mainstate main; + pl_winNT_substate sub; + } NT; + } state; + + CURLcode error; + struct fileinfo *file_data; + unsigned int item_length; + size_t item_offset; + struct { + size_t filename; + size_t user; + size_t group; + size_t time; + size_t perm; + size_t symlink_target; + } offsets; +}; + +static void fileinfo_dtor(void *user, void *element) +{ + (void)user; + Curl_fileinfo_cleanup(element); +} + +void Curl_wildcard_init(struct WildcardData *wc) +{ + Curl_llist_init(&wc->filelist, fileinfo_dtor); + wc->state = CURLWC_INIT; +} + +void Curl_wildcard_dtor(struct WildcardData **wcp) +{ + struct WildcardData *wc = *wcp; + if(!wc) + return; + + if(wc->dtor) { + wc->dtor(wc->ftpwc); + wc->dtor = ZERO_NULL; + wc->ftpwc = NULL; + } + DEBUGASSERT(!wc->ftpwc); + + Curl_llist_destroy(&wc->filelist, NULL); + curlx_safefree(wc->path); + curlx_safefree(wc->pattern); + wc->state = CURLWC_INIT; + curlx_free(wc); + *wcp = NULL; +} + +struct ftp_parselist_data *Curl_ftp_parselist_data_alloc(void) +{ + return curlx_calloc(1, sizeof(struct ftp_parselist_data)); +} + +void Curl_ftp_parselist_data_free(struct ftp_parselist_data **parserp) +{ + struct ftp_parselist_data *parser = *parserp; + if(parser) + Curl_fileinfo_cleanup(parser->file_data); + curlx_free(parser); + *parserp = NULL; +} + +CURLcode Curl_ftp_parselist_geterror(struct ftp_parselist_data *pl_data) +{ + return pl_data->error; +} + +#define FTP_LP_MALFORMATED_PERM 0x01000000 + +static unsigned int ftp_pl_get_permission(const char *str) +{ + unsigned int permissions = 0; + /* USER */ + if(str[0] == 'r') + permissions |= 1 << 8; + else if(str[0] != '-') + permissions |= FTP_LP_MALFORMATED_PERM; + if(str[1] == 'w') + permissions |= 1 << 7; + else if(str[1] != '-') + permissions |= FTP_LP_MALFORMATED_PERM; + + if(str[2] == 'x') + permissions |= 1 << 6; + else if(str[2] == 's') { + permissions |= 1 << 6; + permissions |= 1 << 11; + } + else if(str[2] == 'S') + permissions |= 1 << 11; + else if(str[2] != '-') + permissions |= FTP_LP_MALFORMATED_PERM; + /* GROUP */ + if(str[3] == 'r') + permissions |= 1 << 5; + else if(str[3] != '-') + permissions |= FTP_LP_MALFORMATED_PERM; + if(str[4] == 'w') + permissions |= 1 << 4; + else if(str[4] != '-') + permissions |= FTP_LP_MALFORMATED_PERM; + if(str[5] == 'x') + permissions |= 1 << 3; + else if(str[5] == 's') { + permissions |= 1 << 3; + permissions |= 1 << 10; + } + else if(str[5] == 'S') + permissions |= 1 << 10; + else if(str[5] != '-') + permissions |= FTP_LP_MALFORMATED_PERM; + /* others */ + if(str[6] == 'r') + permissions |= 1 << 2; + else if(str[6] != '-') + permissions |= FTP_LP_MALFORMATED_PERM; + if(str[7] == 'w') + permissions |= 1 << 1; + else if(str[7] != '-') + permissions |= FTP_LP_MALFORMATED_PERM; + if(str[8] == 'x') + permissions |= 1; + else if(str[8] == 't') { + permissions |= 1; + permissions |= 1 << 9; + } + else if(str[8] == 'T') + permissions |= 1 << 9; + else if(str[8] != '-') + permissions |= FTP_LP_MALFORMATED_PERM; + + return permissions; +} + +static CURLcode ftp_pl_insert_finfo(struct Curl_easy *data, + struct fileinfo *infop) +{ + curl_fnmatch_callback compare; + struct WildcardData *wc = data->wildcard; + struct ftp_wc *ftpwc = wc->ftpwc; + struct Curl_llist *llist = &wc->filelist; + struct ftp_parselist_data *parser = ftpwc->parser; + bool add = TRUE; + struct curl_fileinfo *finfo = &infop->info; + + /* set the finfo pointers */ + char *str = curlx_dyn_ptr(&infop->buf); + finfo->filename = str + parser->offsets.filename; + finfo->strings.group = parser->offsets.group ? + str + parser->offsets.group : NULL; + finfo->strings.perm = parser->offsets.perm ? + str + parser->offsets.perm : NULL; + finfo->strings.target = parser->offsets.symlink_target && + (finfo->filetype == CURLFILETYPE_SYMLINK) ? + str + parser->offsets.symlink_target : NULL; + finfo->strings.time = str + parser->offsets.time; + finfo->strings.user = parser->offsets.user ? + str + parser->offsets.user : NULL; + + /* get correct fnmatch callback */ + compare = data->set.fnmatch; + if(!compare) + compare = Curl_fnmatch; + + /* filter pattern-corresponding filenames */ + Curl_set_in_callback(data, TRUE); + if(compare(data->set.fnmatch_data, wc->pattern, finfo->filename) == 0) { + /* discard symlink which is containing multiple " -> " */ + if((finfo->filetype == CURLFILETYPE_SYMLINK) && finfo->strings.target && + (strstr(finfo->strings.target, " -> "))) { + add = FALSE; + } + } + else { + add = FALSE; + } + Curl_set_in_callback(data, FALSE); + + if(add) { + Curl_llist_append(llist, finfo, &infop->list); + } + else { + Curl_fileinfo_cleanup(infop); + } + + ftpwc->parser->file_data = NULL; + return CURLE_OK; +} + +#define MAX_FTPLIST_BUFFER 10000 /* arbitrarily set */ + +static CURLcode unix_filetype(const char c, curlfiletype *t) +{ + switch(c) { + case '-': + *t = CURLFILETYPE_FILE; + break; + case 'd': + *t = CURLFILETYPE_DIRECTORY; + break; + case 'l': + *t = CURLFILETYPE_SYMLINK; + break; + case 'p': + *t = CURLFILETYPE_NAMEDPIPE; + break; + case 's': + *t = CURLFILETYPE_SOCKET; + break; + case 'c': + *t = CURLFILETYPE_DEVICE_CHAR; + break; + case 'b': + *t = CURLFILETYPE_DEVICE_BLOCK; + break; + case 'D': + *t = CURLFILETYPE_DOOR; + break; + default: + return CURLE_FTP_BAD_FILE_LIST; + } + return CURLE_OK; +} + +static CURLcode parse_unix_totalsize(struct ftp_parselist_data *parser, + struct fileinfo *infop, + const char c) +{ + size_t len = curlx_dyn_len(&infop->buf); + char *mem = curlx_dyn_ptr(&infop->buf); + switch(parser->state.UNIX.sub.total_dirsize) { + case PL_UNIX_TOTALSIZE_INIT: + if(c == 't') { + parser->state.UNIX.sub.total_dirsize = PL_UNIX_TOTALSIZE_READING; + parser->item_length++; + } + else { + parser->state.UNIX.main = PL_UNIX_FILETYPE; + /* continue to fall through */ + } + break; + case PL_UNIX_TOTALSIZE_READING: + parser->item_length++; + if(c == '\r') { + parser->item_length--; + if(len) + curlx_dyn_setlen(&infop->buf, --len); + } + else if(c == '\n') { + mem[parser->item_length - 1] = 0; + if(!strncmp("total ", mem, 6)) { + const char *endptr = mem + 6; + /* here we can deal with directory size, pass the leading + whitespace and then the digits */ + curlx_str_passblanks(&endptr); + while(ISDIGIT(*endptr)) + endptr++; + if(*endptr) { + return CURLE_FTP_BAD_FILE_LIST; + } + parser->state.UNIX.main = PL_UNIX_FILETYPE; + curlx_dyn_reset(&infop->buf); + } + else + return CURLE_FTP_BAD_FILE_LIST; + } + break; + } + return CURLE_OK; +} + +static CURLcode parse_unix_permission(struct ftp_parselist_data *parser, + struct fileinfo *infop, + const char c) +{ + char *mem = curlx_dyn_ptr(&infop->buf); + parser->item_length++; + if((parser->item_length <= 9) && !strchr("rwx-tTsS", c)) + return CURLE_FTP_BAD_FILE_LIST; + + else if(parser->item_length == 10) { + unsigned int perm; + if(c != ' ') + return CURLE_FTP_BAD_FILE_LIST; + + mem[10] = 0; /* terminate permissions */ + perm = ftp_pl_get_permission(mem + parser->item_offset); + if(perm & FTP_LP_MALFORMATED_PERM) + return CURLE_FTP_BAD_FILE_LIST; + + parser->file_data->info.flags |= CURLFINFOFLAG_KNOWN_PERM; + parser->file_data->info.perm = perm; + parser->offsets.perm = parser->item_offset; + + parser->item_length = 0; + parser->state.UNIX.main = PL_UNIX_HLINKS; + parser->state.UNIX.sub.hlinks = PL_UNIX_HLINKS_PRESPACE; + } + return CURLE_OK; +} + +static CURLcode parse_unix_hlinks(struct ftp_parselist_data *parser, + struct fileinfo *infop, + const char c) +{ + size_t len = curlx_dyn_len(&infop->buf); + char *mem = curlx_dyn_ptr(&infop->buf); + + switch(parser->state.UNIX.sub.hlinks) { + case PL_UNIX_HLINKS_PRESPACE: + if(c != ' ') { + if(ISDIGIT(c) && len) { + parser->item_offset = len - 1; + parser->item_length = 1; + parser->state.UNIX.sub.hlinks = PL_UNIX_HLINKS_NUMBER; + } + else + return CURLE_FTP_BAD_FILE_LIST; + } + break; + case PL_UNIX_HLINKS_NUMBER: + parser->item_length++; + if(c == ' ') { + const char *p = &mem[parser->item_offset]; + curl_off_t hlinks; + mem[parser->item_offset + parser->item_length - 1] = 0; + + if(!curlx_str_number(&p, &hlinks, LONG_MAX)) { + parser->file_data->info.flags |= CURLFINFOFLAG_KNOWN_HLINKCOUNT; + parser->file_data->info.hardlinks = (long)hlinks; + } + parser->item_length = 0; + parser->item_offset = 0; + parser->state.UNIX.main = PL_UNIX_USER; + parser->state.UNIX.sub.user = PL_UNIX_USER_PRESPACE; + } + else if(!ISDIGIT(c)) + return CURLE_FTP_BAD_FILE_LIST; + + break; + } + return CURLE_OK; +} + +static CURLcode parse_unix_user(struct ftp_parselist_data *parser, + struct fileinfo *infop, + const char c) +{ + size_t len = curlx_dyn_len(&infop->buf); + char *mem = curlx_dyn_ptr(&infop->buf); + switch(parser->state.UNIX.sub.user) { + case PL_UNIX_USER_PRESPACE: + if(c != ' ' && len) { + parser->item_offset = len - 1; + parser->item_length = 1; + parser->state.UNIX.sub.user = PL_UNIX_USER_PARSING; + } + break; + case PL_UNIX_USER_PARSING: + parser->item_length++; + if(c == ' ') { + mem[parser->item_offset + parser->item_length - 1] = 0; + parser->offsets.user = parser->item_offset; + parser->state.UNIX.main = PL_UNIX_GROUP; + parser->state.UNIX.sub.group = PL_UNIX_GROUP_PRESPACE; + parser->item_offset = 0; + parser->item_length = 0; + } + break; + } + return CURLE_OK; +} + +static CURLcode parse_unix_group(struct ftp_parselist_data *parser, + struct fileinfo *infop, + const char c) +{ + size_t len = curlx_dyn_len(&infop->buf); + char *mem = curlx_dyn_ptr(&infop->buf); + switch(parser->state.UNIX.sub.group) { + case PL_UNIX_GROUP_PRESPACE: + if(c != ' ' && len) { + parser->item_offset = len - 1; + parser->item_length = 1; + parser->state.UNIX.sub.group = PL_UNIX_GROUP_NAME; + } + break; + case PL_UNIX_GROUP_NAME: + parser->item_length++; + if(c == ' ') { + mem[parser->item_offset + parser->item_length - 1] = 0; + parser->offsets.group = parser->item_offset; + parser->state.UNIX.main = PL_UNIX_SIZE; + parser->state.UNIX.sub.size = PL_UNIX_SIZE_PRESPACE; + parser->item_offset = 0; + parser->item_length = 0; + } + break; + } + return CURLE_OK; +} + +static CURLcode parse_unix_size(struct ftp_parselist_data *parser, + struct fileinfo *infop, + const char c) +{ + size_t len = curlx_dyn_len(&infop->buf); + char *mem = curlx_dyn_ptr(&infop->buf); + switch(parser->state.UNIX.sub.size) { + case PL_UNIX_SIZE_PRESPACE: + if(c != ' ') { + if(ISDIGIT(c) && len) { + parser->item_offset = len - 1; + parser->item_length = 1; + parser->state.UNIX.sub.size = PL_UNIX_SIZE_NUMBER; + } + else + return CURLE_FTP_BAD_FILE_LIST; + } + break; + case PL_UNIX_SIZE_NUMBER: + parser->item_length++; + if(c == ' ') { + const char *p = mem + parser->item_offset; + curl_off_t fsize; + mem[parser->item_offset + parser->item_length - 1] = 0; + if(!curlx_str_numblanks(&p, &fsize)) { + if(p[0] == '\0' && fsize != CURL_OFF_T_MAX) { + parser->file_data->info.flags |= CURLFINFOFLAG_KNOWN_SIZE; + parser->file_data->info.size = fsize; + } + parser->item_length = 0; + parser->item_offset = 0; + parser->state.UNIX.main = PL_UNIX_TIME; + parser->state.UNIX.sub.time = PL_UNIX_TIME_PREPART1; + } + } + else if(!ISDIGIT(c)) + return CURLE_FTP_BAD_FILE_LIST; + + break; + } + return CURLE_OK; +} + +static CURLcode parse_unix_time(struct ftp_parselist_data *parser, + struct fileinfo *infop, + const char c) +{ + size_t len = curlx_dyn_len(&infop->buf); + char *mem = curlx_dyn_ptr(&infop->buf); + struct curl_fileinfo *finfo = &infop->info; + + switch(parser->state.UNIX.sub.time) { + case PL_UNIX_TIME_PREPART1: + if(c != ' ') { + if(ISALNUM(c) && len) { + parser->item_offset = len - 1; + parser->item_length = 1; + parser->state.UNIX.sub.time = PL_UNIX_TIME_PART1; + } + else + return CURLE_FTP_BAD_FILE_LIST; + } + break; + case PL_UNIX_TIME_PART1: + parser->item_length++; + if(c == ' ') + parser->state.UNIX.sub.time = PL_UNIX_TIME_PREPART2; + + else if(!ISALNUM(c) && c != '.') + return CURLE_FTP_BAD_FILE_LIST; + + break; + case PL_UNIX_TIME_PREPART2: + parser->item_length++; + if(c != ' ') { + if(ISALNUM(c)) + parser->state.UNIX.sub.time = PL_UNIX_TIME_PART2; + else + return CURLE_FTP_BAD_FILE_LIST; + } + break; + case PL_UNIX_TIME_PART2: + parser->item_length++; + if(c == ' ') + parser->state.UNIX.sub.time = PL_UNIX_TIME_PREPART3; + else if(!ISALNUM(c) && c != '.') + return CURLE_FTP_BAD_FILE_LIST; + break; + case PL_UNIX_TIME_PREPART3: + parser->item_length++; + if(c != ' ') { + if(ISALNUM(c)) + parser->state.UNIX.sub.time = PL_UNIX_TIME_PART3; + else + return CURLE_FTP_BAD_FILE_LIST; + } + break; + case PL_UNIX_TIME_PART3: + parser->item_length++; + if(c == ' ') { + mem[parser->item_offset + parser->item_length - 1] = 0; + parser->offsets.time = parser->item_offset; + if(finfo->filetype == CURLFILETYPE_SYMLINK) { + parser->state.UNIX.main = PL_UNIX_SYMLINK; + parser->state.UNIX.sub.symlink = PL_UNIX_SYMLINK_PRESPACE; + } + else { + parser->state.UNIX.main = PL_UNIX_FILENAME; + parser->state.UNIX.sub.filename = PL_UNIX_FILENAME_PRESPACE; + } + } + else if(!ISALNUM(c) && c != '.' && c != ':') + return CURLE_FTP_BAD_FILE_LIST; + break; + } + return CURLE_OK; +} + +static CURLcode parse_unix_filename(struct Curl_easy *data, + struct ftp_parselist_data *parser, + struct fileinfo *infop, + const char c) +{ + size_t len = curlx_dyn_len(&infop->buf); + char *mem = curlx_dyn_ptr(&infop->buf); + CURLcode result = CURLE_OK; + + switch(parser->state.UNIX.sub.filename) { + case PL_UNIX_FILENAME_PRESPACE: + if(c != ' ' && len) { + parser->item_offset = len - 1; + parser->item_length = 1; + parser->state.UNIX.sub.filename = PL_UNIX_FILENAME_NAME; + } + break; + case PL_UNIX_FILENAME_NAME: + parser->item_length++; + if(c == '\r') + parser->state.UNIX.sub.filename = PL_UNIX_FILENAME_WINDOWSEOL; + + else if(c == '\n') { + mem[parser->item_offset + parser->item_length - 1] = 0; + parser->offsets.filename = parser->item_offset; + parser->state.UNIX.main = PL_UNIX_FILETYPE; + result = ftp_pl_insert_finfo(data, infop); + } + break; + case PL_UNIX_FILENAME_WINDOWSEOL: + if(c == '\n') { + mem[parser->item_offset + parser->item_length - 1] = 0; + parser->offsets.filename = parser->item_offset; + parser->state.UNIX.main = PL_UNIX_FILETYPE; + result = ftp_pl_insert_finfo(data, infop); + } + else + result = CURLE_FTP_BAD_FILE_LIST; + break; + } + return result; +} + +static CURLcode parse_unix_symlink(struct Curl_easy *data, + struct ftp_parselist_data *parser, + struct fileinfo *infop, + const char c) +{ + size_t len = curlx_dyn_len(&infop->buf); + char *mem = curlx_dyn_ptr(&infop->buf); + CURLcode result = CURLE_OK; + + switch(parser->state.UNIX.sub.symlink) { + case PL_UNIX_SYMLINK_PRESPACE: + if(c != ' ' && len) { + parser->item_offset = len - 1; + parser->item_length = 1; + parser->state.UNIX.sub.symlink = PL_UNIX_SYMLINK_NAME; + } + break; + case PL_UNIX_SYMLINK_NAME: + parser->item_length++; + if(c == ' ') + parser->state.UNIX.sub.symlink = PL_UNIX_SYMLINK_PRETARGET1; + + else if(c == '\r' || c == '\n') + return CURLE_FTP_BAD_FILE_LIST; + + break; + case PL_UNIX_SYMLINK_PRETARGET1: + parser->item_length++; + if(c == '-') + parser->state.UNIX.sub.symlink = PL_UNIX_SYMLINK_PRETARGET2; + + else if(c == '\r' || c == '\n') + return CURLE_FTP_BAD_FILE_LIST; + else + parser->state.UNIX.sub.symlink = PL_UNIX_SYMLINK_NAME; + break; + case PL_UNIX_SYMLINK_PRETARGET2: + parser->item_length++; + if(c == '>') + parser->state.UNIX.sub.symlink = PL_UNIX_SYMLINK_PRETARGET3; + else if(c == '\r' || c == '\n') + return CURLE_FTP_BAD_FILE_LIST; + else + parser->state.UNIX.sub.symlink = PL_UNIX_SYMLINK_NAME; + + break; + case PL_UNIX_SYMLINK_PRETARGET3: + parser->item_length++; + if(c == ' ') { + parser->state.UNIX.sub.symlink = PL_UNIX_SYMLINK_PRETARGET4; + /* now place where is symlink following */ + mem[parser->item_offset + parser->item_length - 4] = 0; + parser->offsets.filename = parser->item_offset; + parser->item_length = 0; + parser->item_offset = 0; + } + else if(c == '\r' || c == '\n') + return CURLE_FTP_BAD_FILE_LIST; + else + parser->state.UNIX.sub.symlink = PL_UNIX_SYMLINK_NAME; + break; + case PL_UNIX_SYMLINK_PRETARGET4: + if(c != '\r' && c != '\n' && len) { + parser->state.UNIX.sub.symlink = PL_UNIX_SYMLINK_TARGET; + parser->item_offset = len - 1; + parser->item_length = 1; + } + else + return CURLE_FTP_BAD_FILE_LIST; + + break; + case PL_UNIX_SYMLINK_TARGET: + parser->item_length++; + if(c == '\r') + parser->state.UNIX.sub.symlink = PL_UNIX_SYMLINK_WINDOWSEOL; + + else if(c == '\n') { + mem[parser->item_offset + parser->item_length - 1] = 0; + parser->offsets.symlink_target = parser->item_offset; + result = ftp_pl_insert_finfo(data, infop); + if(result) + break; + + parser->state.UNIX.main = PL_UNIX_FILETYPE; + } + break; + case PL_UNIX_SYMLINK_WINDOWSEOL: + if(c == '\n') { + mem[parser->item_offset + parser->item_length - 1] = 0; + parser->offsets.symlink_target = parser->item_offset; + result = ftp_pl_insert_finfo(data, infop); + if(result) + break; + + parser->state.UNIX.main = PL_UNIX_FILETYPE; + } + else + result = CURLE_FTP_BAD_FILE_LIST; + + break; + } + return result; +} + +static CURLcode parse_unix(struct Curl_easy *data, + struct ftp_parselist_data *parser, + struct fileinfo *infop, + const char c) +{ + struct curl_fileinfo *finfo = &infop->info; + CURLcode result = CURLE_OK; + + switch(parser->state.UNIX.main) { + case PL_UNIX_TOTALSIZE: + result = parse_unix_totalsize(parser, infop, c); + if(result) + break; + if(parser->state.UNIX.main != PL_UNIX_FILETYPE) + break; + FALLTHROUGH(); + case PL_UNIX_FILETYPE: + result = unix_filetype(c, &finfo->filetype); + if(!result) { + parser->state.UNIX.main = PL_UNIX_PERMISSION; + parser->item_length = 0; + parser->item_offset = 1; + } + break; + case PL_UNIX_PERMISSION: + result = parse_unix_permission(parser, infop, c); + break; + case PL_UNIX_HLINKS: + result = parse_unix_hlinks(parser, infop, c); + break; + case PL_UNIX_USER: + result = parse_unix_user(parser, infop, c); + break; + case PL_UNIX_GROUP: + result = parse_unix_group(parser, infop, c); + break; + case PL_UNIX_SIZE: + result = parse_unix_size(parser, infop, c); + break; + case PL_UNIX_TIME: + result = parse_unix_time(parser, infop, c); + break; + case PL_UNIX_FILENAME: + result = parse_unix_filename(data, parser, infop, c); + break; + case PL_UNIX_SYMLINK: + result = parse_unix_symlink(data, parser, infop, c); + break; + } + return result; +} + +static CURLcode parse_winnt(struct Curl_easy *data, + struct ftp_parselist_data *parser, + struct fileinfo *infop, + const char c) +{ + struct curl_fileinfo *finfo = &infop->info; + size_t len = curlx_dyn_len(&infop->buf); + char *mem = curlx_dyn_ptr(&infop->buf); + CURLcode result = CURLE_OK; + + switch(parser->state.NT.main) { + case PL_WINNT_DATE: + parser->item_length++; + if(parser->item_length < 9) { + if(!strchr("0123456789-", c)) { /* only simple control */ + return CURLE_FTP_BAD_FILE_LIST; + } + } + else if(parser->item_length == 9) { + if(c == ' ') { + parser->state.NT.main = PL_WINNT_TIME; + parser->state.NT.sub.time = PL_WINNT_TIME_PRESPACE; + } + else + return CURLE_FTP_BAD_FILE_LIST; + } + else + return CURLE_FTP_BAD_FILE_LIST; + break; + case PL_WINNT_TIME: + parser->item_length++; + switch(parser->state.NT.sub.time) { + case PL_WINNT_TIME_PRESPACE: + if(!ISBLANK(c)) + parser->state.NT.sub.time = PL_WINNT_TIME_TIME; + break; + case PL_WINNT_TIME_TIME: + if(c == ' ') { + parser->offsets.time = parser->item_offset; + mem[parser->item_offset + parser->item_length - 1] = 0; + parser->state.NT.main = PL_WINNT_DIRORSIZE; + parser->state.NT.sub.dirorsize = PL_WINNT_DIRORSIZE_PRESPACE; + parser->item_length = 0; + } + else if(!strchr("APM0123456789:", c)) + return CURLE_FTP_BAD_FILE_LIST; + break; + } + break; + case PL_WINNT_DIRORSIZE: + switch(parser->state.NT.sub.dirorsize) { + case PL_WINNT_DIRORSIZE_PRESPACE: + if(c != ' ' && len) { + parser->item_offset = len - 1; + parser->item_length = 1; + parser->state.NT.sub.dirorsize = PL_WINNT_DIRORSIZE_CONTENT; + } + break; + case PL_WINNT_DIRORSIZE_CONTENT: + parser->item_length++; + if(c == ' ') { + mem[parser->item_offset + parser->item_length - 1] = 0; + if(!strcmp("", mem + parser->item_offset)) { + finfo->filetype = CURLFILETYPE_DIRECTORY; + finfo->size = 0; + } + else { + const char *p = mem + parser->item_offset; + if(curlx_str_numblanks(&p, &finfo->size)) { + return CURLE_FTP_BAD_FILE_LIST; + } + /* correct file type */ + parser->file_data->info.filetype = CURLFILETYPE_FILE; + } + + parser->file_data->info.flags |= CURLFINFOFLAG_KNOWN_SIZE; + parser->item_length = 0; + parser->state.NT.main = PL_WINNT_FILENAME; + parser->state.NT.sub.filename = PL_WINNT_FILENAME_PRESPACE; + } + break; + } + break; + case PL_WINNT_FILENAME: + switch(parser->state.NT.sub.filename) { + case PL_WINNT_FILENAME_PRESPACE: + if(c != ' ' && len) { + parser->item_offset = len - 1; + parser->item_length = 1; + parser->state.NT.sub.filename = PL_WINNT_FILENAME_CONTENT; + } + break; + case PL_WINNT_FILENAME_CONTENT: + parser->item_length++; + if(!len) + return CURLE_FTP_BAD_FILE_LIST; + if(c == '\r') { + parser->state.NT.sub.filename = PL_WINNT_FILENAME_WINEOL; + mem[len - 1] = 0; + } + else if(c == '\n') { + parser->offsets.filename = parser->item_offset; + mem[len - 1] = 0; + result = ftp_pl_insert_finfo(data, infop); + if(result) + return result; + + parser->state.NT.main = PL_WINNT_DATE; + parser->state.NT.sub.filename = PL_WINNT_FILENAME_PRESPACE; + } + break; + case PL_WINNT_FILENAME_WINEOL: + if(c == '\n') { + parser->offsets.filename = parser->item_offset; + result = ftp_pl_insert_finfo(data, infop); + if(result) + return result; + + parser->state.NT.main = PL_WINNT_DATE; + parser->state.NT.sub.filename = PL_WINNT_FILENAME_PRESPACE; + } + else + return CURLE_FTP_BAD_FILE_LIST; + + break; + } + break; + } + + return CURLE_OK; +} + +size_t Curl_ftp_parselist(char *buffer, size_t size, size_t nmemb, + void *connptr) +{ + size_t bufflen = size * nmemb; + struct Curl_easy *data = (struct Curl_easy *)connptr; + struct ftp_wc *ftpwc = data->wildcard->ftpwc; + struct ftp_parselist_data *parser = ftpwc->parser; + size_t i = 0; + CURLcode result; + size_t retsize = bufflen; + + if(parser->error) { /* error in previous call */ + /* scenario: + * 1. call => OK.. + * 2. call => OUT_OF_MEMORY (or other error) + * 3. (last) call => is skipped RIGHT HERE and the error is handled later + * in wc_statemach() + */ + goto fail; + } + + if(parser->os_type == OS_TYPE_UNKNOWN && bufflen > 0) { + /* considering info about FILE response format */ + parser->os_type = ISDIGIT(buffer[0]) ? OS_TYPE_WIN_NT : OS_TYPE_UNIX; + } + + while(i < bufflen) { /* FSM */ + char c = buffer[i]; + struct fileinfo *infop; + if(!parser->file_data) { /* tmp file data is not allocated yet */ + parser->file_data = Curl_fileinfo_alloc(); + if(!parser->file_data) { + parser->error = CURLE_OUT_OF_MEMORY; + goto fail; + } + parser->item_offset = 0; + parser->item_length = 0; + curlx_dyn_init(&parser->file_data->buf, MAX_FTPLIST_BUFFER); + } + + infop = parser->file_data; + + if(curlx_dyn_addn(&infop->buf, &c, 1)) { + parser->error = CURLE_OUT_OF_MEMORY; + goto fail; + } + + switch(parser->os_type) { + case OS_TYPE_UNIX: + result = parse_unix(data, parser, infop, c); + break; + case OS_TYPE_WIN_NT: + result = parse_winnt(data, parser, infop, c); + break; + default: + retsize = bufflen + 1; + goto fail; + } + if(result) { + parser->error = result; + goto fail; + } + + i++; + } + return retsize; + +fail: + + /* Clean up any allocated memory. */ + if(parser->file_data) { + Curl_fileinfo_cleanup(parser->file_data); + parser->file_data = NULL; + } + + return retsize; +} + +#endif /* !CURL_DISABLE_FTP */ diff --git a/3rdparty/curl-8.21.0/lib/ftplistparser.h b/3rdparty/curl-8.21.0/lib/ftplistparser.h new file mode 100644 index 0000000000..5d7aa492ba --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/ftplistparser.h @@ -0,0 +1,77 @@ +#ifndef HEADER_CURL_FTPLISTPARSER_H +#define HEADER_CURL_FTPLISTPARSER_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifndef CURL_DISABLE_FTP + +/* WRITEFUNCTION callback for parsing LIST responses */ +size_t Curl_ftp_parselist(char *buffer, size_t size, size_t nmemb, + void *connptr); + +struct ftp_parselist_data; /* defined inside ftplibparser.c */ + +CURLcode Curl_ftp_parselist_geterror(struct ftp_parselist_data *pl_data); + +struct ftp_parselist_data *Curl_ftp_parselist_data_alloc(void); + +void Curl_ftp_parselist_data_free(struct ftp_parselist_data **parserp); + +/* list of wildcard process states */ +typedef enum { + CURLWC_CLEAR = 0, + CURLWC_INIT = 1, + CURLWC_MATCHING, /* library is trying to get list of addresses for + downloading */ + CURLWC_DOWNLOADING, + CURLWC_CLEAN, /* deallocate resources and reset settings */ + CURLWC_SKIP, /* skip over concrete file */ + CURLWC_ERROR, /* error cases */ + CURLWC_DONE /* if is wildcard->state == CURLWC_DONE wildcard loop + will end */ +} wildcard_states; + +typedef void (*wildcard_dtor)(void *ptr); + +/* struct keeping information about wildcard download process */ +struct WildcardData { + char *path; /* path to the directory, where we trying wildcard-match */ + char *pattern; /* wildcard pattern */ + struct Curl_llist filelist; /* llist with struct Curl_fileinfo */ + struct ftp_wc *ftpwc; /* pointer to FTP wildcard data */ + wildcard_dtor dtor; + unsigned char state; /* wildcard_states */ +}; + +void Curl_wildcard_init(struct WildcardData *wc); +void Curl_wildcard_dtor(struct WildcardData **wcp); + +struct Curl_easy; + +#else /* CURL_DISABLE_FTP */ +#define Curl_wildcard_dtor(x) +#endif /* !CURL_DISABLE_FTP */ + +#endif /* HEADER_CURL_FTPLISTPARSER_H */ diff --git a/3rdparty/curl-8.21.0/lib/functypes.h b/3rdparty/curl-8.21.0/lib/functypes.h new file mode 100644 index 0000000000..3938295dd1 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/functypes.h @@ -0,0 +1,108 @@ +#ifndef HEADER_CURL_FUNCTYPES_H +#define HEADER_CURL_FUNCTYPES_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +/* defaults: + + ssize_t recv(int, void *, size_t, int); + ssize_t send(int, const void *, size_t, int); + + If other argument or return types are needed: + + 1. For systems that run configure or cmake, the alternatives are provided + here. + 2. For systems with config-*.h files, define them there. +*/ + +#ifdef USE_WINSOCK +/* int recv(SOCKET, char *, int, int) */ +#define RECV_TYPE_ARG1 SOCKET +#define RECV_TYPE_ARG2 char * +#define RECV_TYPE_ARG3 int +#define RECV_TYPE_RETV int + +/* int send(SOCKET, const char *, int, int); */ +#define SEND_TYPE_ARG1 SOCKET +#define SEND_TYPE_ARG2 char * +#define SEND_TYPE_ARG3 int +#define SEND_TYPE_RETV int + +#elif defined(__AMIGA__) /* Any AmigaOS flavor */ + +/* long recv(long, char *, long, long); */ +#define RECV_TYPE_ARG1 long +#define RECV_TYPE_ARG2 char * +#define RECV_TYPE_ARG3 long +#define RECV_TYPE_ARG4 long +#define RECV_TYPE_RETV long + +/* int send(int, char *, int, int); */ +#define SEND_TYPE_ARG1 int +#define SEND_NONCONST_ARG2 +#define SEND_TYPE_ARG2 char * +#define SEND_TYPE_ARG3 int +#define SEND_TYPE_RETV int +#endif + +#ifndef RECV_TYPE_ARG1 +#define RECV_TYPE_ARG1 int +#endif + +#ifndef RECV_TYPE_ARG2 +#define RECV_TYPE_ARG2 void * +#endif + +#ifndef RECV_TYPE_ARG3 +#define RECV_TYPE_ARG3 size_t +#endif + +#ifndef RECV_TYPE_ARG4 +#define RECV_TYPE_ARG4 int +#endif + +#ifndef RECV_TYPE_RETV +#define RECV_TYPE_RETV ssize_t +#endif + +#ifndef SEND_TYPE_ARG1 +#define SEND_TYPE_ARG1 int +#endif + +#ifndef SEND_TYPE_ARG2 +#define SEND_TYPE_ARG2 void * +#endif + +#ifndef SEND_TYPE_ARG3 +#define SEND_TYPE_ARG3 size_t +#endif + +#ifndef SEND_TYPE_ARG4 +#define SEND_TYPE_ARG4 int +#endif + +#ifndef SEND_TYPE_RETV +#define SEND_TYPE_RETV ssize_t +#endif + +#endif /* HEADER_CURL_FUNCTYPES_H */ diff --git a/3rdparty/curl-8.21.0/lib/getenv.c b/3rdparty/curl-8.21.0/lib/getenv.c new file mode 100644 index 0000000000..a957e6e801 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/getenv.c @@ -0,0 +1,69 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +char *curl_getenv(const char *variable) +{ +#if defined(CURL_WINDOWS_UWP) || \ + defined(__ORBIS__) || defined(__PROSPERO__) /* PlayStation 4 and 5 */ + (void)variable; + return NULL; +#elif defined(_WIN32) + /* This uses Windows API instead of C runtime getenv() to get the environment + variable since some changes are not always visible to the latter. #4774 */ + char *buf = NULL; + char *tmp; + DWORD bufsize; + DWORD rc = 1; + const DWORD max = 32768; /* max env var size from MSCRT source */ + + for(;;) { + tmp = curlx_realloc(buf, rc); + if(!tmp) { + curlx_free(buf); + return NULL; + } + + buf = tmp; + bufsize = rc; + + /* it is possible for rc to be 0 if the variable was found but empty. + Since getenv does not make that distinction we ignore it as well. */ + rc = GetEnvironmentVariableA(variable, buf, bufsize); + if(!rc || rc == bufsize || rc > max) { + curlx_free(buf); + return NULL; + } + + /* if rc < bufsize then rc is bytes written not including null */ + if(rc < bufsize) + return buf; + + /* else rc is bytes needed, try again */ + } +#else + char *env = getenv(variable); + return (env && env[0]) ? curlx_strdup(env) : NULL; +#endif +} diff --git a/3rdparty/curl-8.21.0/lib/getinfo.c b/3rdparty/curl-8.21.0/lib/getinfo.c new file mode 100644 index 0000000000..fde4aa4ef2 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/getinfo.c @@ -0,0 +1,679 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "urldata.h" +#include "getinfo.h" +#include "cfilters.h" +#include "vtls/vtls.h" +#include "connect.h" /* Curl_getconnectinfo() */ +#include "bufref.h" +#include "curlx/strparse.h" + +/* + * Initialize statistical and informational data. + * + * This function is called in curl_easy_reset, curl_easy_duphandle and at the + * beginning of a perform session. It must reset the session-info variables, + * in particular all variables in struct PureInfo. + */ +void Curl_initinfo(struct Curl_easy *data) +{ + struct Progress *pro = &data->progress; + struct PureInfo *info = &data->info; + + pro->t_nslookup = 0; + pro->t_connect = 0; + pro->t_appconnect = 0; + pro->t_pretransfer = 0; + pro->t_posttransfer = 0; + pro->t_starttransfer = 0; + pro->timespent = 0; + pro->t_redirect = 0; + pro->is_t_startransfer_set = FALSE; + + info->httpcode = 0; + info->httpproxycode = 0; + info->httpversion = 0; + info->filetime = -1; /* -1 is an illegal time and thus means unknown */ + info->timecond = FALSE; + + info->header_size = 0; + info->request_size = 0; + info->proxyauthavail = 0; + info->httpauthavail = 0; + info->proxyauthpicked = 0; + info->httpauthpicked = 0; + info->numconnects = 0; + + curlx_safefree(info->contenttype); + curlx_safefree(info->wouldredirect); + + memset(&info->primary, 0, sizeof(info->primary)); + info->retry_after = 0; + + info->conn_scheme = 0; + info->conn_protocol = 0; + info->used_proxy = 0; + +#ifdef USE_SSL + Curl_ssl_free_certinfo(data); +#endif +} + +static CURLcode getinfo_char(struct Curl_easy *data, CURLINFO info, + const char **param_charp) +{ + switch(info) { + case CURLINFO_EFFECTIVE_URL: { + const char *s = Curl_bufref_ptr(&data->state.url); + *param_charp = s ? s : ""; + } + break; + case CURLINFO_EFFECTIVE_METHOD: { + const char *m = data->set.str[STRING_CUSTOMREQUEST]; + if(!m) { + if(data->set.opt_no_body) + m = "HEAD"; +#ifndef CURL_DISABLE_HTTP + else { + switch(data->state.httpreq) { + case HTTPREQ_POST: + case HTTPREQ_POST_FORM: + case HTTPREQ_POST_MIME: + m = "POST"; + break; + case HTTPREQ_PUT: + m = "PUT"; + break; + default: /* this should never happen */ + case HTTPREQ_GET: + m = "GET"; + break; + case HTTPREQ_HEAD: + m = "HEAD"; + break; + } + } +#endif + } + *param_charp = m; + } + break; + case CURLINFO_CONTENT_TYPE: + *param_charp = data->info.contenttype; + break; + case CURLINFO_PRIVATE: + *param_charp = (const char *)data->set.private_data; + break; + case CURLINFO_FTP_ENTRY_PATH: + /* Return the entrypath string from the most recent connection. + This pointer was copied from the connectdata structure by FTP. + The actual string may be freed by subsequent libcurl calls so + it must be copied to a safer area before the next libcurl call. + Callers must never free it themselves. */ + *param_charp = data->state.most_recent_ftp_entrypath; + break; + case CURLINFO_REDIRECT_URL: + /* Return the URL this request would have been redirected to if that + option had been enabled! */ + *param_charp = data->info.wouldredirect; + break; + case CURLINFO_REFERER: + /* Return the referrer header for this request, or NULL if unset */ + *param_charp = Curl_bufref_ptr(&data->state.referer); + break; + case CURLINFO_PRIMARY_IP: + /* Return the ip address of the most recent (primary) connection */ + *param_charp = data->info.primary.remote_ip; + break; + case CURLINFO_LOCAL_IP: + /* Return the source/local ip address of the most recent (primary) + connection */ + *param_charp = data->info.primary.local_ip; + break; + case CURLINFO_RTSP_SESSION_ID: +#ifndef CURL_DISABLE_RTSP + *param_charp = data->set.str[STRING_RTSP_SESSION_ID]; +#else + *param_charp = NULL; +#endif + break; + case CURLINFO_SCHEME: + *param_charp = data->info.conn_scheme; + break; + case CURLINFO_CAPATH: +#ifdef CURL_CA_PATH + *param_charp = CURL_CA_PATH; +#else + *param_charp = NULL; +#endif + break; + case CURLINFO_CAINFO: +#ifdef CURL_CA_BUNDLE + *param_charp = CURL_CA_BUNDLE; +#else + *param_charp = NULL; +#endif + break; + default: + return CURLE_UNKNOWN_OPTION; + } + + return CURLE_OK; +} + +static CURLcode getinfo_long(struct Curl_easy *data, CURLINFO info, + long *param_longp) +{ + curl_socket_t sockfd; + + union { + unsigned long *to_ulong; + long *to_long; + } lptr; + +#ifdef DEBUGBUILD + const char *envstr; + + /* use another variable for this to allow different values */ + switch(info) { + case CURLINFO_LOCAL_PORT: + envstr = getenv("CURL_TIME"); + if(envstr) { + curl_off_t val; + curlx_str_number(&envstr, &val, TIME_T_MAX); + *param_longp = (long)val; + return CURLE_OK; + } + break; + case CURLINFO_HEADER_SIZE: + case CURLINFO_REQUEST_SIZE: + envstr = getenv("CURL_DEBUG_SIZE"); + if(envstr) { + curl_off_t val; + curlx_str_number(&envstr, &val, LONG_MAX); + *param_longp = (long)val; + return CURLE_OK; + } + break; + default: + break; + } +#endif + + switch(info) { + case CURLINFO_RESPONSE_CODE: + *param_longp = data->info.httpcode; + break; + case CURLINFO_HTTP_CONNECTCODE: + *param_longp = data->info.httpproxycode; + break; + case CURLINFO_FILETIME: + if(data->info.filetime > LONG_MAX) + *param_longp = LONG_MAX; +#if !defined(MSDOS) && !defined(__AMIGA__) + else if(data->info.filetime < LONG_MIN) + *param_longp = LONG_MIN; +#endif + else + *param_longp = (long)data->info.filetime; + break; + case CURLINFO_HEADER_SIZE: + *param_longp = (long)data->info.header_size; + break; + case CURLINFO_REQUEST_SIZE: + *param_longp = (long)data->info.request_size; + break; + case CURLINFO_SSL_VERIFYRESULT: + *param_longp = data->set.ssl.certverifyresult; + break; + case CURLINFO_PROXY_SSL_VERIFYRESULT: +#ifndef CURL_DISABLE_PROXY + *param_longp = data->set.proxy_ssl.certverifyresult; +#else + *param_longp = 0; +#endif + break; + case CURLINFO_REDIRECT_COUNT: + *param_longp = data->state.followlocation; + break; + case CURLINFO_HTTPAUTH_AVAIL: + lptr.to_long = param_longp; + *lptr.to_ulong = data->info.httpauthavail; + break; + case CURLINFO_PROXYAUTH_AVAIL: + lptr.to_long = param_longp; + *lptr.to_ulong = data->info.proxyauthavail; + break; + case CURLINFO_HTTPAUTH_USED: + lptr.to_long = param_longp; + *lptr.to_ulong = data->info.httpauthpicked; + break; + case CURLINFO_PROXYAUTH_USED: + lptr.to_long = param_longp; + *lptr.to_ulong = data->info.proxyauthpicked; + break; + case CURLINFO_OS_ERRNO: + *param_longp = data->state.os_errno; + break; + case CURLINFO_NUM_CONNECTS: +#if SIZEOF_LONG < SIZEOF_CURL_OFF_T + if(data->info.numconnects > LONG_MAX) + *param_longp = LONG_MAX; + else +#endif + *param_longp = (long)data->info.numconnects; + break; + case CURLINFO_LASTSOCKET: + sockfd = Curl_getconnectinfo(data, NULL); + + /* note: this is not a good conversion for systems with 64-bit sockets and + 32-bit longs */ + if(sockfd != CURL_SOCKET_BAD) + *param_longp = (long)sockfd; + else + /* this interface is documented to return -1 in case of badness, which + may not be the same as the CURL_SOCKET_BAD value */ + *param_longp = -1; + break; + case CURLINFO_PRIMARY_PORT: + /* Return the (remote) port of the most recent (primary) connection */ + if(CUR_IP_QUAD_HAS_PORTS(&data->info.primary)) + *param_longp = data->info.primary.remote_port; + else + *param_longp = -1; + break; + case CURLINFO_LOCAL_PORT: + /* Return the local port of the most recent (primary) connection */ + if(CUR_IP_QUAD_HAS_PORTS(&data->info.primary)) + *param_longp = data->info.primary.local_port; + else + *param_longp = -1; + break; + case CURLINFO_PROXY_ERROR: + *param_longp = (long)data->info.pxcode; + break; + case CURLINFO_CONDITION_UNMET: + if(data->info.httpcode == 304) + *param_longp = 1L; + else + /* return if the condition prevented the document to get transferred */ + *param_longp = data->info.timecond ? 1L : 0L; + break; +#ifndef CURL_DISABLE_RTSP + case CURLINFO_RTSP_CLIENT_CSEQ: + *param_longp = data->state.rtsp_next_client_CSeq; + break; + case CURLINFO_RTSP_SERVER_CSEQ: + *param_longp = data->state.rtsp_next_server_CSeq; + break; + case CURLINFO_RTSP_CSEQ_RECV: + *param_longp = data->state.rtsp_CSeq_recv; + break; +#else + case CURLINFO_RTSP_CLIENT_CSEQ: + case CURLINFO_RTSP_SERVER_CSEQ: + case CURLINFO_RTSP_CSEQ_RECV: + *param_longp = 0; + break; +#endif + case CURLINFO_HTTP_VERSION: + switch(data->info.httpversion) { + case 10: + *param_longp = CURL_HTTP_VERSION_1_0; + break; + case 11: + *param_longp = CURL_HTTP_VERSION_1_1; + break; + case 20: + *param_longp = CURL_HTTP_VERSION_2_0; + break; + case 30: + *param_longp = CURL_HTTP_VERSION_3; + break; + default: + *param_longp = CURL_HTTP_VERSION_NONE; + break; + } + break; + case CURLINFO_PROTOCOL: + *param_longp = (long)data->info.conn_protocol; + break; + case CURLINFO_USED_PROXY: + *param_longp = +#ifdef CURL_DISABLE_PROXY + 0 +#else + data->info.used_proxy +#endif + ; + break; + default: + return CURLE_UNKNOWN_OPTION; + } + + return CURLE_OK; +} + +#define DOUBLE_SECS(x) ((double)(x) / 1000000) + +static CURLcode getinfo_offt(struct Curl_easy *data, CURLINFO info, + curl_off_t *param_offt) +{ +#ifdef DEBUGBUILD + const char *envstr; + switch(info) { + case CURLINFO_TOTAL_TIME_T: + case CURLINFO_NAMELOOKUP_TIME_T: + case CURLINFO_CONNECT_TIME_T: + case CURLINFO_APPCONNECT_TIME_T: + case CURLINFO_PRETRANSFER_TIME_T: + case CURLINFO_POSTTRANSFER_TIME_T: + case CURLINFO_QUEUE_TIME_T: + case CURLINFO_STARTTRANSFER_TIME_T: + case CURLINFO_REDIRECT_TIME_T: + case CURLINFO_SPEED_DOWNLOAD_T: + case CURLINFO_SPEED_UPLOAD_T: + envstr = getenv("CURL_TIME"); + if(envstr) { + curl_off_t val; + curlx_str_number(&envstr, &val, CURL_OFF_T_MAX); + *param_offt = (curl_off_t)val; + return CURLE_OK; + } + break; + default: + break; + } +#endif + switch(info) { + case CURLINFO_FILETIME_T: + *param_offt = (curl_off_t)data->info.filetime; + break; + case CURLINFO_SIZE_DELIVERED: + *param_offt = data->progress.deliver; + break; + case CURLINFO_SIZE_UPLOAD_T: + *param_offt = data->progress.ul.cur_size; + break; + case CURLINFO_SIZE_DOWNLOAD_T: + *param_offt = data->progress.dl.cur_size; + break; + case CURLINFO_SPEED_DOWNLOAD_T: + *param_offt = data->progress.dl.speed; + break; + case CURLINFO_SPEED_UPLOAD_T: + *param_offt = data->progress.ul.speed; + break; + case CURLINFO_CONTENT_LENGTH_DOWNLOAD_T: + *param_offt = data->progress.dl_size_known ? + data->progress.dl.total_size : -1; + break; + case CURLINFO_CONTENT_LENGTH_UPLOAD_T: + *param_offt = data->progress.ul_size_known ? + data->progress.ul.total_size : -1; + break; + case CURLINFO_TOTAL_TIME_T: + *param_offt = data->progress.timespent; + break; + case CURLINFO_NAMELOOKUP_TIME_T: + *param_offt = data->progress.t_nslookup; + break; + case CURLINFO_CONNECT_TIME_T: + *param_offt = data->progress.t_connect; + break; + case CURLINFO_APPCONNECT_TIME_T: + *param_offt = data->progress.t_appconnect; + break; + case CURLINFO_PRETRANSFER_TIME_T: + *param_offt = data->progress.t_pretransfer; + break; + case CURLINFO_POSTTRANSFER_TIME_T: + *param_offt = data->progress.t_posttransfer; + break; + case CURLINFO_STARTTRANSFER_TIME_T: + *param_offt = data->progress.t_starttransfer; + break; + case CURLINFO_QUEUE_TIME_T: + *param_offt = data->progress.t_postqueue; + break; + case CURLINFO_REDIRECT_TIME_T: + *param_offt = data->progress.t_redirect; + break; + case CURLINFO_RETRY_AFTER: + *param_offt = data->info.retry_after; + break; + case CURLINFO_XFER_ID: + *param_offt = data->id; + break; + case CURLINFO_CONN_ID: + *param_offt = data->conn ? + data->conn->connection_id : data->state.recent_conn_id; + break; + case CURLINFO_EARLYDATA_SENT_T: + *param_offt = data->progress.earlydata_sent; + break; + default: + return CURLE_UNKNOWN_OPTION; + } + + return CURLE_OK; +} + +static CURLcode getinfo_double(struct Curl_easy *data, CURLINFO info, + double *param_doublep) +{ +#ifdef DEBUGBUILD + const char *envstr; + + switch(info) { + case CURLINFO_TOTAL_TIME: + case CURLINFO_NAMELOOKUP_TIME: + case CURLINFO_CONNECT_TIME: + case CURLINFO_APPCONNECT_TIME: + case CURLINFO_PRETRANSFER_TIME: + case CURLINFO_STARTTRANSFER_TIME: + case CURLINFO_REDIRECT_TIME: + case CURLINFO_SPEED_DOWNLOAD: + case CURLINFO_SPEED_UPLOAD: + envstr = getenv("CURL_TIME"); + if(envstr) { + curl_off_t val; + curlx_str_number(&envstr, &val, CURL_OFF_T_MAX); + *param_doublep = (double)val; + return CURLE_OK; + } + break; + default: + break; + } +#endif + switch(info) { + case CURLINFO_TOTAL_TIME: + *param_doublep = DOUBLE_SECS(data->progress.timespent); + break; + case CURLINFO_NAMELOOKUP_TIME: + *param_doublep = DOUBLE_SECS(data->progress.t_nslookup); + break; + case CURLINFO_CONNECT_TIME: + *param_doublep = DOUBLE_SECS(data->progress.t_connect); + break; + case CURLINFO_APPCONNECT_TIME: + *param_doublep = DOUBLE_SECS(data->progress.t_appconnect); + break; + case CURLINFO_PRETRANSFER_TIME: + *param_doublep = DOUBLE_SECS(data->progress.t_pretransfer); + break; + case CURLINFO_STARTTRANSFER_TIME: + *param_doublep = DOUBLE_SECS(data->progress.t_starttransfer); + break; + case CURLINFO_SIZE_UPLOAD: + *param_doublep = (double)data->progress.ul.cur_size; + break; + case CURLINFO_SIZE_DOWNLOAD: + *param_doublep = (double)data->progress.dl.cur_size; + break; + case CURLINFO_SPEED_DOWNLOAD: + *param_doublep = (double)data->progress.dl.speed; + break; + case CURLINFO_SPEED_UPLOAD: + *param_doublep = (double)data->progress.ul.speed; + break; + case CURLINFO_CONTENT_LENGTH_DOWNLOAD: + *param_doublep = data->progress.dl_size_known ? + (double)data->progress.dl.total_size : -1; + break; + case CURLINFO_CONTENT_LENGTH_UPLOAD: + *param_doublep = data->progress.ul_size_known ? + (double)data->progress.ul.total_size : -1; + break; + case CURLINFO_REDIRECT_TIME: + *param_doublep = DOUBLE_SECS(data->progress.t_redirect); + break; + + default: + return CURLE_UNKNOWN_OPTION; + } + + return CURLE_OK; +} + +static CURLcode getinfo_slist(struct Curl_easy *data, CURLINFO info, + struct curl_slist **param_slistp) +{ + union { + struct curl_certinfo *to_certinfo; + struct curl_slist *to_slist; + } ptr; + + switch(info) { + case CURLINFO_SSL_ENGINES: + *param_slistp = Curl_ssl_engines_list(data); + break; + case CURLINFO_COOKIELIST: + *param_slistp = Curl_cookie_list(data); + break; + case CURLINFO_CERTINFO: + /* Return the a pointer to the certinfo struct. Not really an slist + pointer but we can pretend it is here */ + ptr.to_certinfo = &data->info.certs; + *param_slistp = ptr.to_slist; + break; + case CURLINFO_TLS_SESSION: + case CURLINFO_TLS_SSL_PTR: { + int query = (info == CURLINFO_TLS_SSL_PTR) ? + CF_QUERY_SSL_INFO : CF_QUERY_SSL_CTX_INFO; + struct curl_tlssessioninfo **tsip = (struct curl_tlssessioninfo **) + param_slistp; + struct curl_tlssessioninfo *tsi = &data->tsi; + + /* we are exposing a pointer to internal memory with unknown + * lifetime here. */ + *tsip = tsi; + if(!Curl_conn_get_ssl_info(data, data->conn, FIRSTSOCKET, query, tsi)) { + tsi->backend = Curl_ssl_backend(); + tsi->internals = NULL; + } + } + break; + default: + return CURLE_UNKNOWN_OPTION; + } + + return CURLE_OK; +} + +static CURLcode getinfo_socket(struct Curl_easy *data, CURLINFO info, + curl_socket_t *param_socketp) +{ + switch(info) { + case CURLINFO_ACTIVESOCKET: + *param_socketp = Curl_getconnectinfo(data, NULL); + break; + default: + return CURLE_UNKNOWN_OPTION; + } + + return CURLE_OK; +} + +CURLcode Curl_getinfo(struct Curl_easy *data, CURLINFO info, ...) +{ + va_list arg; + long *param_longp = NULL; + double *param_doublep = NULL; + curl_off_t *param_offt = NULL; + const char **param_charp = NULL; + struct curl_slist **param_slistp = NULL; + curl_socket_t *param_socketp = NULL; + int type; + CURLcode result = CURLE_BAD_FUNCTION_ARGUMENT; + + if(!data) + return CURLE_BAD_FUNCTION_ARGUMENT; + + va_start(arg, info); + + type = CURLINFO_TYPEMASK & (int)info; + switch(type) { + case CURLINFO_STRING: + param_charp = va_arg(arg, const char **); + if(param_charp) + result = getinfo_char(data, info, param_charp); + break; + case CURLINFO_LONG: + param_longp = va_arg(arg, long *); + if(param_longp) + result = getinfo_long(data, info, param_longp); + break; + case CURLINFO_DOUBLE: + param_doublep = va_arg(arg, double *); + if(param_doublep) + result = getinfo_double(data, info, param_doublep); + break; + case CURLINFO_OFF_T: + param_offt = va_arg(arg, curl_off_t *); + if(param_offt) + result = getinfo_offt(data, info, param_offt); + break; + case CURLINFO_SLIST: + param_slistp = va_arg(arg, struct curl_slist **); + if(param_slistp) + result = getinfo_slist(data, info, param_slistp); + break; + case CURLINFO_SOCKET: + param_socketp = va_arg(arg, curl_socket_t *); + if(param_socketp) + result = getinfo_socket(data, info, param_socketp); + break; + default: + result = CURLE_UNKNOWN_OPTION; + break; + } + + va_end(arg); + + return result; +} diff --git a/3rdparty/curl-8.21.0/lib/getinfo.h b/3rdparty/curl-8.21.0/lib/getinfo.h new file mode 100644 index 0000000000..f5efe4185c --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/getinfo.h @@ -0,0 +1,29 @@ +#ifndef HEADER_CURL_GETINFO_H +#define HEADER_CURL_GETINFO_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +CURLcode Curl_getinfo(struct Curl_easy *data, CURLINFO info, ...); +void Curl_initinfo(struct Curl_easy *data); + +#endif /* HEADER_CURL_GETINFO_H */ diff --git a/3rdparty/curl-8.21.0/lib/gopher.c b/3rdparty/curl-8.21.0/lib/gopher.c new file mode 100644 index 0000000000..039697466b --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/gopher.c @@ -0,0 +1,217 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" +#include "urldata.h" +#include "gopher.h" + +#ifndef CURL_DISABLE_GOPHER + +#include "transfer.h" +#include "sendf.h" +#include "curl_trc.h" +#include "cfilters.h" +#include "connect.h" +#include "select.h" +#include "url.h" +#include "escape.h" + +#ifdef USE_SSL +static CURLcode gopher_connect(struct Curl_easy *data, bool *done) +{ + (void)data; + (void)done; + return CURLE_OK; +} + +static CURLcode gopher_connecting(struct Curl_easy *data, bool *done) +{ + struct connectdata *conn = data->conn; + CURLcode result; + + result = Curl_conn_connect(data, FIRSTSOCKET, TRUE, done); + if(result) + connclose(conn, "Failed TLS connection"); + *done = TRUE; + return result; +} +#endif + +static CURLcode gopher_do(struct Curl_easy *data, bool *done) +{ + CURLcode result = CURLE_OK; + struct connectdata *conn = data->conn; + curl_socket_t sockfd = conn->sock[FIRSTSOCKET]; + char *gopherpath; + const char *path = data->state.up.path; + const char *query = data->state.up.query; + const char *buf = NULL; + char *buf_alloc = NULL; + size_t nwritten, buf_len; + timediff_t timeout_ms; + int what; + + *done = TRUE; /* unconditionally */ + + /* path is guaranteed non-NULL */ + DEBUGASSERT(path); + + if(query) + gopherpath = curl_maprintf("%s?%s", path, query); + else + gopherpath = curlx_strdup(path); + + if(!gopherpath) + return CURLE_OUT_OF_MEMORY; + + /* Create selector. Degenerate cases: / and /1 => convert to "" */ + if(strlen(gopherpath) <= 2) { + buf = ""; + buf_len = 0; + curlx_free(gopherpath); + } + else { + const char *newp; + + /* Otherwise, drop / and the first character (i.e., item type) ... */ + newp = gopherpath; + newp += 2; + + /* ... and finally unescape */ + result = Curl_urldecode(newp, 0, &buf_alloc, &buf_len, REJECT_ZERO); + curlx_free(gopherpath); + if(result) + return result; + buf = buf_alloc; + } + + for(; buf_len;) { + + result = Curl_xfer_send(data, buf, buf_len, FALSE, &nwritten); + if(!result) { /* Which may not have written it all! */ + result = Curl_client_write(data, CLIENTWRITE_HEADER, buf, nwritten); + if(result) + break; + + if(nwritten > buf_len) { + DEBUGASSERT(0); + break; + } + buf_len -= nwritten; + buf += nwritten; + if(!buf_len) + break; /* but it did write it all */ + } + else + break; + + timeout_ms = Curl_timeleft_ms(data); + if(timeout_ms < 0) { + result = CURLE_OPERATION_TIMEDOUT; + break; + } + if(!timeout_ms) + timeout_ms = TIMEDIFF_T_MAX; + + /* Do not busyloop. The entire loop thing is a workaround as it causes a + BLOCKING behavior which is a NO-NO. This function should rather be + split up in a do and a doing piece where the pieces that are not + possible to send now will be sent in the doing function repeatedly + until the entire request is sent. + */ + what = SOCKET_WRITABLE(sockfd, timeout_ms); + if(what < 0) { + result = CURLE_SEND_ERROR; + break; + } + else if(!what) { + result = CURLE_OPERATION_TIMEDOUT; + break; + } + } + + curlx_free(buf_alloc); + + if(!result) + result = Curl_xfer_send(data, "\r\n", 2, FALSE, &nwritten); + if(result) { + failf(data, "Failed sending Gopher request"); + return result; + } + result = Curl_client_write(data, CLIENTWRITE_HEADER, "\r\n", 2); + if(result) + return result; + + Curl_xfer_setup_recv(data, FIRSTSOCKET, -1); + return CURLE_OK; +} + +/* + * Gopher protocol handler. + * This is also a nice simple template to build off for simple + * connect-command-download protocols. + */ + +const struct Curl_protocol Curl_protocol_gopher = { + ZERO_NULL, /* setup_connection */ + gopher_do, /* do_it */ + ZERO_NULL, /* done */ + ZERO_NULL, /* do_more */ + ZERO_NULL, /* connect_it */ + ZERO_NULL, /* connecting */ + ZERO_NULL, /* doing */ + ZERO_NULL, /* proto_pollset */ + ZERO_NULL, /* doing_pollset */ + ZERO_NULL, /* domore_pollset */ + ZERO_NULL, /* perform_pollset */ + ZERO_NULL, /* disconnect */ + ZERO_NULL, /* write_resp */ + ZERO_NULL, /* write_resp_hd */ + ZERO_NULL, /* connection_is_dead */ + ZERO_NULL, /* attach connection */ + ZERO_NULL, /* follow */ +}; + +#ifdef USE_SSL +const struct Curl_protocol Curl_protocol_gophers = { + ZERO_NULL, /* setup_connection */ + gopher_do, /* do_it */ + ZERO_NULL, /* done */ + ZERO_NULL, /* do_more */ + gopher_connect, /* connect_it */ + gopher_connecting, /* connecting */ + ZERO_NULL, /* doing */ + ZERO_NULL, /* proto_pollset */ + ZERO_NULL, /* doing_pollset */ + ZERO_NULL, /* domore_pollset */ + ZERO_NULL, /* perform_pollset */ + ZERO_NULL, /* disconnect */ + ZERO_NULL, /* write_resp */ + ZERO_NULL, /* write_resp_hd */ + ZERO_NULL, /* connection_is_dead */ + ZERO_NULL, /* attach connection */ + ZERO_NULL, /* follow */ +}; +#endif + +#endif /* CURL_DISABLE_GOPHER */ diff --git a/3rdparty/curl-8.21.0/lib/gopher.h b/3rdparty/curl-8.21.0/lib/gopher.h new file mode 100644 index 0000000000..1c126be16a --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/gopher.h @@ -0,0 +1,31 @@ +#ifndef HEADER_CURL_GOPHER_H +#define HEADER_CURL_GOPHER_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#ifndef CURL_DISABLE_GOPHER +extern const struct Curl_protocol Curl_protocol_gopher; +extern const struct Curl_protocol Curl_protocol_gophers; +#endif + +#endif /* HEADER_CURL_GOPHER_H */ diff --git a/3rdparty/curl-8.21.0/lib/hash.c b/3rdparty/curl-8.21.0/lib/hash.c new file mode 100644 index 0000000000..3eae1d26a7 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/hash.c @@ -0,0 +1,388 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "hash.h" + +/* random patterns for API verification */ +#ifdef DEBUGBUILD +#define HASHINIT 0x7017e781 +#define ITERINIT 0x5FEDCBA9 +#endif + +#if 0 /* useful function for debugging hashes and their contents */ +void Curl_hash_print(struct Curl_hash *h, void (*func)(void *)) +{ + struct Curl_hash_iterator iter; + struct Curl_hash_element *he; + size_t last_index = UINT_MAX; + + if(!h) + return; + + curl_mfprintf(stderr, "=Hash dump=\n"); + + Curl_hash_start_iterate(h, &iter); + + he = Curl_hash_next_element(&iter); + while(he) { + if(iter.slot_index != last_index) { + curl_mfprintf(stderr, "index %d:", (int)iter.slot_index); + if(last_index != UINT_MAX) { + curl_mfprintf(stderr, "\n"); + } + last_index = iter.slot_index; + } + + if(func) + func(he->ptr); + else + curl_mfprintf(stderr, " [key=%.*s, he=%p, ptr=%p]", + (int)he->key_len, (char *)he->key, + (void *)he, (void *)he->ptr); + + he = Curl_hash_next_element(&iter); + } + curl_mfprintf(stderr, "\n"); +} +#endif + +/* Initializes a hash structure. + * Return 1 on error, 0 is fine. + * + * @unittest: 1602 + * @unittest: 1603 + */ +void Curl_hash_init(struct Curl_hash *h, + size_t slots, + hash_function hfunc, + comp_function comparator, + Curl_hash_dtor dtor) +{ + DEBUGASSERT(h); + DEBUGASSERT(slots); + DEBUGASSERT(hfunc); + DEBUGASSERT(comparator); + DEBUGASSERT(dtor); + + h->table = NULL; + h->hash_func = hfunc; + h->comp_func = comparator; + h->dtor = dtor; + h->size = 0; + h->slots = slots; +#ifdef DEBUGBUILD + h->init = HASHINIT; +#endif +} + +static struct Curl_hash_element *hash_elem_create(const void *key, + size_t key_len, + const void *p, + Curl_hash_elem_dtor dtor) +{ + struct Curl_hash_element *he; + + /* allocate the struct plus memory after it to store the key */ + he = curlx_malloc(sizeof(struct Curl_hash_element) + key_len); + if(he) { + he->next = NULL; + /* copy the key */ + memcpy(he->key, key, key_len); + he->key_len = key_len; + he->ptr = CURL_UNCONST(p); + he->dtor = dtor; + } + return he; +} + +static void hash_elem_clear_ptr(struct Curl_hash *h, + struct Curl_hash_element *he) +{ + DEBUGASSERT(h); + DEBUGASSERT(he); + if(he->ptr) { + if(he->dtor) + he->dtor(he->key, he->key_len, he->ptr); + else + h->dtor(he->ptr); + he->ptr = NULL; + } +} + +static void hash_elem_destroy(struct Curl_hash *h, + struct Curl_hash_element *he) +{ + hash_elem_clear_ptr(h, he); + curlx_free(he); +} + +static void hash_elem_unlink(struct Curl_hash *h, + struct Curl_hash_element **he_anchor, + struct Curl_hash_element *he) +{ + *he_anchor = he->next; + --h->size; +} + +static void hash_elem_link(struct Curl_hash *h, + struct Curl_hash_element **he_anchor, + struct Curl_hash_element *he) +{ + he->next = *he_anchor; + *he_anchor = he; + ++h->size; +} + +#define CURL_HASH_SLOT(x, y, z) x->table[(x)->hash_func(y, z, (x)->slots)] +#define CURL_HASH_SLOT_ADDR(x, y, z) &CURL_HASH_SLOT(x, y, z) + +void *Curl_hash_add2(struct Curl_hash *h, void *key, size_t key_len, void *p, + Curl_hash_elem_dtor dtor) +{ + struct Curl_hash_element *he, **slot; + + DEBUGASSERT(h); + DEBUGASSERT(h->slots); + DEBUGASSERT(h->init == HASHINIT); + if(!h->table) { + h->table = curlx_calloc(h->slots, sizeof(struct Curl_hash_element *)); + if(!h->table) + return NULL; /* OOM */ + } + + slot = CURL_HASH_SLOT_ADDR(h, key, key_len); + for(he = *slot; he; he = he->next) { + if(h->comp_func(he->key, he->key_len, key, key_len)) { + /* existing key entry, overwrite by clearing old pointer */ + hash_elem_clear_ptr(h, he); + he->ptr = p; + he->dtor = dtor; + return p; + } + } + + he = hash_elem_create(key, key_len, p, dtor); + if(!he) + return NULL; /* OOM */ + + hash_elem_link(h, slot, he); + return p; /* return the new entry */ +} + +/* Insert the data in the hash. If there already was a match in the hash, that + * data is replaced. This function also "lazily" allocates the table if + * needed, as it is not done in the _init function (anymore). + * + * @unittest: 1305 + * @unittest: 1602 + * @unittest: 1603 + */ +void *Curl_hash_add(struct Curl_hash *h, void *key, size_t key_len, void *p) +{ + return Curl_hash_add2(h, key, key_len, p, NULL); +} + +/* Remove the identified hash entry. + * Returns non-zero on failure. + * + * @unittest: 1603 + */ +int Curl_hash_delete(struct Curl_hash *h, void *key, size_t key_len) +{ + DEBUGASSERT(h); + DEBUGASSERT(h->slots); + DEBUGASSERT(h->init == HASHINIT); + if(h->table) { + struct Curl_hash_element *he, **he_anchor; + + he_anchor = CURL_HASH_SLOT_ADDR(h, key, key_len); + while(*he_anchor) { + he = *he_anchor; + if(h->comp_func(he->key, he->key_len, key, key_len)) { + hash_elem_unlink(h, he_anchor, he); + hash_elem_destroy(h, he); + return 0; + } + he_anchor = &he->next; + } + } + return 1; +} + +/* Retrieves a hash element. + * + * @unittest: 1603 + */ +void *Curl_hash_pick(struct Curl_hash *h, void *key, size_t key_len) +{ + DEBUGASSERT(h); + DEBUGASSERT(h->init == HASHINIT); + if(h->table) { + struct Curl_hash_element *he; + DEBUGASSERT(h->slots); + he = CURL_HASH_SLOT(h, key, key_len); + while(he) { + if(h->comp_func(he->key, he->key_len, key, key_len)) { + return he->ptr; + } + he = he->next; + } + } + return NULL; +} + +/* Destroys all the entries in the given hash and resets its attributes, + * prepping the given hash for [static|dynamic] deallocation. + * + * @unittest: 1305 + * @unittest: 1602 + * @unittest: 1603 + */ +void Curl_hash_destroy(struct Curl_hash *h) +{ + DEBUGASSERT(h->init == HASHINIT); + if(h->table) { + Curl_hash_clean(h); + curlx_safefree(h->table); + } + DEBUGASSERT(h->size == 0); + h->slots = 0; +} + +/* Removes all the entries in the given hash. + * + * @unittest: 1602 + */ +void Curl_hash_clean(struct Curl_hash *h) +{ + if(h && h->table) { + struct Curl_hash_element *he, **he_anchor; + size_t i; + DEBUGASSERT(h->init == HASHINIT); + for(i = 0; i < h->slots; ++i) { + he_anchor = &h->table[i]; + while(*he_anchor) { + he = *he_anchor; + hash_elem_unlink(h, he_anchor, he); + hash_elem_destroy(h, he); + } + } + } +} + +size_t Curl_hash_count(struct Curl_hash *h) +{ + DEBUGASSERT(h->init == HASHINIT); + return h->size; +} + +/* Cleans all entries that pass the comp function criteria. */ +void Curl_hash_clean_with_criterium(struct Curl_hash *h, void *user, + int (*comp)(void *, void *)) +{ + size_t i; + + if(!h || !h->table) + return; + + DEBUGASSERT(h->init == HASHINIT); + for(i = 0; i < h->slots; ++i) { + struct Curl_hash_element *he, **he_anchor = &h->table[i]; + while(*he_anchor) { + /* ask the callback function if we shall remove this entry or not */ + if(!comp || comp(user, (*he_anchor)->ptr)) { + he = *he_anchor; + hash_elem_unlink(h, he_anchor, he); + hash_elem_destroy(h, he); + } + else + he_anchor = &(*he_anchor)->next; + } + } +} + +size_t Curl_hash_str(void *key, size_t key_length, size_t slots_num) +{ + const char *key_str = (const char *)key; + const char *end = key_str + key_length; + size_t h = 5381; + + while(key_str < end) { + size_t j = (size_t)*key_str++; + h += h << 5; + h ^= j; + } + + return (h % slots_num); +} + +size_t curlx_str_key_compare(void *k1, size_t key1_len, + void *k2, size_t key2_len) +{ + if((key1_len == key2_len) && !memcmp(k1, k2, key1_len)) + return 1; + + return 0; +} + +void Curl_hash_start_iterate(struct Curl_hash *hash, + struct Curl_hash_iterator *iter) +{ + DEBUGASSERT(hash->init == HASHINIT); + iter->hash = hash; + iter->slot_index = 0; + iter->current = NULL; +#ifdef DEBUGBUILD + iter->init = ITERINIT; +#endif +} + +struct Curl_hash_element *Curl_hash_next_element( + struct Curl_hash_iterator *iter) +{ + struct Curl_hash *h; + DEBUGASSERT(iter->init == ITERINIT); + h = iter->hash; + if(!h->table) + return NULL; /* empty hash, nothing to return */ + + /* Get the next element in the current list, if any */ + if(iter->current) + iter->current = iter->current->next; + + /* If we have reached the end of the list, find the next one */ + if(!iter->current) { + size_t i; + for(i = iter->slot_index; i < h->slots; i++) { + if(h->table[i]) { + iter->current = h->table[i]; + iter->slot_index = i + 1; + break; + } + } + } + + return iter->current; +} diff --git a/3rdparty/curl-8.21.0/lib/hash.h b/3rdparty/curl-8.21.0/lib/hash.h new file mode 100644 index 0000000000..1d7d3de8ce --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/hash.h @@ -0,0 +1,105 @@ +#ifndef HEADER_CURL_HASH_H +#define HEADER_CURL_HASH_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +/* Hash function prototype */ +typedef size_t (*hash_function)(void *key, + size_t key_length, + size_t slots_num); + +/* + Comparator function prototype. Compares two keys. +*/ +typedef size_t (*comp_function)(void *key1, + size_t key1_len, + void *key2, + size_t key2_len); + +typedef void (*Curl_hash_dtor)(void *); + +typedef void (*Curl_hash_elem_dtor)(void *key, size_t key_len, void *p); + +struct Curl_hash_element { + struct Curl_hash_element *next; + void *ptr; + Curl_hash_elem_dtor dtor; + size_t key_len; + char key[1]; /* allocated memory following the struct */ +}; + +struct Curl_hash { + struct Curl_hash_element **table; + + /* Hash function to be used for this hash table */ + hash_function hash_func; + /* Comparator function to compare keys */ + comp_function comp_func; + /* General element construct, unless element itself carries one */ + Curl_hash_dtor dtor; + size_t slots; + size_t size; +#ifdef DEBUGBUILD + int init; +#endif +}; + +struct Curl_hash_iterator { + struct Curl_hash *hash; + size_t slot_index; + struct Curl_hash_element *current; +#ifdef DEBUGBUILD + int init; +#endif +}; + +void Curl_hash_init(struct Curl_hash *h, + size_t slots, + hash_function hfunc, + comp_function comparator, + Curl_hash_dtor dtor); + +void *Curl_hash_add(struct Curl_hash *h, void *key, size_t key_len, void *p); +void *Curl_hash_add2(struct Curl_hash *h, void *key, size_t key_len, void *p, + Curl_hash_elem_dtor dtor); +int Curl_hash_delete(struct Curl_hash *h, void *key, size_t key_len); +void *Curl_hash_pick(struct Curl_hash *h, void *key, size_t key_len); + +void Curl_hash_destroy(struct Curl_hash *h); +size_t Curl_hash_count(struct Curl_hash *h); +void Curl_hash_clean(struct Curl_hash *h); +void Curl_hash_clean_with_criterium(struct Curl_hash *h, void *user, + int (*comp)(void *, void *)); +size_t Curl_hash_str(void *key, size_t key_length, size_t slots_num); +size_t curlx_str_key_compare(void *k1, size_t key1_len, void *k2, + size_t key2_len); +void Curl_hash_start_iterate(struct Curl_hash *hash, + struct Curl_hash_iterator *iter); +struct Curl_hash_element *Curl_hash_next_element( + struct Curl_hash_iterator *iter); + +void Curl_hash_print(struct Curl_hash *h, void (*func)(void *)); + +#endif /* HEADER_CURL_HASH_H */ diff --git a/3rdparty/curl-8.21.0/lib/headers.c b/3rdparty/curl-8.21.0/lib/headers.c new file mode 100644 index 0000000000..b290a9e5b3 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/headers.c @@ -0,0 +1,394 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "urldata.h" +#include "sendf.h" +#include "curl_trc.h" +#include "headers.h" + +#if !defined(CURL_DISABLE_HTTP) && !defined(CURL_DISABLE_HEADERS_API) + +/* Generate the curl_header struct for the user. This function MUST assign all + struct fields in the output struct. */ +static void copy_header_external(struct Curl_header_store *hs, + size_t index, + size_t amount, + struct Curl_llist_node *e, + struct curl_header *hout) +{ + struct curl_header *h = hout; + h->name = hs->name; + h->value = hs->value; + h->amount = amount; + h->index = index; + /* this will randomly OR a reserved bit for the sole purpose of making it + impossible for applications to do == comparisons, as that would otherwise + be tempting and then lead to the reserved bits not being reserved + anymore. */ + h->origin = (unsigned int)(hs->type | (1 << 27)); + h->anchor = e; +} + +/* public API */ +CURLHcode curl_easy_header(CURL *curl, + const char *name, + size_t nameindex, + unsigned int origin, + int request, + struct curl_header **hout) +{ + struct Curl_llist_node *e; + struct Curl_llist_node *e_pick = NULL; + struct Curl_easy *data = curl; + size_t match = 0; + size_t amount = 0; + struct Curl_header_store *hs = NULL; + struct Curl_header_store *pick = NULL; + if(!name || !hout || !data || + (origin > (CURLH_HEADER | CURLH_TRAILER | CURLH_CONNECT | CURLH_1XX | + CURLH_PSEUDO)) || !origin || (request < -1)) + return CURLHE_BAD_ARGUMENT; + if(!Curl_llist_count(&data->state.httphdrs)) + return CURLHE_NOHEADERS; /* no headers available */ + if(request > data->state.requests) + return CURLHE_NOREQUEST; + if(request == -1) + request = data->state.requests; + + /* we need a first round to count amount of this header */ + for(e = Curl_llist_head(&data->state.httphdrs); e; e = Curl_node_next(e)) { + hs = Curl_node_elem(e); + if(curl_strequal(hs->name, name) && + (hs->type & origin) && + (hs->request == request)) { + amount++; + pick = hs; + e_pick = e; + } + } + if(!amount) + return CURLHE_MISSING; + else if(nameindex >= amount) + return CURLHE_BADINDEX; + + if(nameindex == amount - 1) + /* if the last or only occurrence is what's asked for, then we know it */ + hs = pick; + else { + for(e = Curl_llist_head(&data->state.httphdrs); e; e = Curl_node_next(e)) { + hs = Curl_node_elem(e); + if(curl_strequal(hs->name, name) && + (hs->type & origin) && + (hs->request == request) && + (match++ == nameindex)) { + e_pick = e; + break; + } + } + if(!e) /* this should not happen */ + return CURLHE_MISSING; + } + /* this is the name we want */ + copy_header_external(hs, nameindex, amount, e_pick, + &data->state.headerout[0]); + *hout = &data->state.headerout[0]; + return CURLHE_OK; +} + +/* public API */ +struct curl_header *curl_easy_nextheader(CURL *curl, + unsigned int origin, + int request, + struct curl_header *prev) +{ + struct Curl_easy *data = curl; + struct Curl_llist_node *pick; + struct Curl_llist_node *e; + struct Curl_header_store *hs; + size_t amount = 0; + size_t index = 0; + + if(request > data->state.requests) + return NULL; + if(request == -1) + request = data->state.requests; + + if(prev) { + pick = prev->anchor; + if(!pick) + /* something is wrong */ + return NULL; + pick = Curl_node_next(pick); + } + else + pick = Curl_llist_head(&data->state.httphdrs); + + if(pick) { + /* make sure it is the next header of the desired type */ + do { + hs = Curl_node_elem(pick); + if((hs->type & origin) && (hs->request == request)) + break; + pick = Curl_node_next(pick); + } while(pick); + } + + if(!pick) + /* no more headers available */ + return NULL; + + hs = Curl_node_elem(pick); + + /* count number of occurrences of this name within the mask and figure out + the index for the currently selected entry */ + for(e = Curl_llist_head(&data->state.httphdrs); e; e = Curl_node_next(e)) { + struct Curl_header_store *check = Curl_node_elem(e); + if(curl_strequal(hs->name, check->name) && + (check->request == request) && + (check->type & origin)) + amount++; + if(e == pick) + index = amount - 1; + } + + copy_header_external(hs, index, amount, pick, + &data->state.headerout[1]); + return &data->state.headerout[1]; +} + +static CURLcode namevalue(char *header, size_t hlen, unsigned int type, + char **name, char **value) +{ + char *end = header + hlen - 1; /* point to the last byte */ + DEBUGASSERT(hlen); + *name = header; + + if(type == CURLH_PSEUDO) { + if(*header != ':') + return CURLE_BAD_FUNCTION_ARGUMENT; + header++; + } + + /* Find the end of the header name */ + while(*header && (*header != ':')) + ++header; + + if(*header) + /* Skip over colon, null it */ + *header++ = 0; + else + return CURLE_BAD_FUNCTION_ARGUMENT; + + /* skip all leading blank letters */ + while(ISBLANK(*header)) + header++; + + *value = header; + + /* skip all trailing space letters */ + while((end > header) && ISBLANK(*end)) + *end-- = 0; /* null-terminate */ + return CURLE_OK; +} + +/* + * Curl_headers_push() gets passed a full HTTP header to store. It gets called + * immediately before the header callback. The header is CRLF, CR or LF + * terminated. + */ +CURLcode Curl_headers_push(struct Curl_easy *data, const char *header, + size_t hlen, /* length of header */ + unsigned char type) +{ + char *value = NULL; + char *name = NULL; + struct Curl_header_store *hs; + CURLcode result = CURLE_OUT_OF_MEMORY; + const size_t ilen = hlen; + + if((header[0] == '\r') || (header[0] == '\n')) + /* ignore the body separator */ + return CURLE_OK; + + /* trim off newline characters */ + if(hlen && (header[hlen - 1] == '\n')) + hlen--; + if(hlen && (header[hlen - 1] == '\r')) + hlen--; + if(hlen == ilen) + /* neither CR nor LF as terminator is not a valid header */ + return CURLE_WEIRD_SERVER_REPLY; + + if(ISBLANK(header[0])) { + /* pass leading blanks */ + while(hlen && ISBLANK(*header)) { + header++; + hlen--; + } + if(!hlen) + return CURLE_WEIRD_SERVER_REPLY; + } + if(Curl_llist_count(&data->state.httphdrs) >= MAX_HTTP_RESP_HEADER_COUNT) { + failf(data, "Too many response headers, %d is max", + MAX_HTTP_RESP_HEADER_COUNT); + return CURLE_TOO_LARGE; + } + + hs = curlx_calloc(1, sizeof(*hs) + hlen); + if(!hs) + return CURLE_OUT_OF_MEMORY; + memcpy(hs->buffer, header, hlen); + hs->buffer[hlen] = 0; /* null-terminate */ + + result = namevalue(hs->buffer, hlen, type, &name, &value); + if(!result) { + hs->name = name; + hs->value = value; + hs->type = type; + hs->request = data->state.requests; + + /* insert this node into the list of headers */ + Curl_llist_append(&data->state.httphdrs, hs, &hs->node); + data->state.prevhead = hs; + } + else { + failf(data, "Invalid response header"); + curlx_free(hs); + } + return result; +} + +/* + * Curl_headers_reset(). Reset the headers subsystem. + */ +static void headers_reset(struct Curl_easy *data) +{ + Curl_llist_init(&data->state.httphdrs, NULL); + data->state.prevhead = NULL; +} + +struct hds_cw_collect_ctx { + struct Curl_cwriter super; +}; + +static CURLcode hds_cw_collect_write(struct Curl_easy *data, + struct Curl_cwriter *writer, int type, + const char *buf, size_t blen) +{ + if((type & CLIENTWRITE_HEADER) && !(type & CLIENTWRITE_STATUS)) { + unsigned char htype = (unsigned char) + (type & CLIENTWRITE_CONNECT ? CURLH_CONNECT : + (type & CLIENTWRITE_1XX ? CURLH_1XX : + (type & CLIENTWRITE_TRAILER ? CURLH_TRAILER : + CURLH_HEADER))); + CURLcode result = Curl_headers_push(data, buf, blen, htype); + CURL_TRC_WRITE(data, "header_collect pushed(type=%x, len=%zu) -> %d", + htype, blen, (int)result); + if(result) + return result; + } + return Curl_cwriter_write(data, writer->next, type, buf, blen); +} + +static const struct Curl_cwtype hds_cw_collect = { + "hds-collect", + NULL, + Curl_cwriter_def_init, + hds_cw_collect_write, + Curl_cwriter_def_close, + sizeof(struct hds_cw_collect_ctx) +}; + +CURLcode Curl_headers_init(struct Curl_easy *data) +{ + struct Curl_cwriter *writer; + CURLcode result; + + if(data->conn && (data->conn->scheme->protocol & PROTO_FAMILY_HTTP)) { + /* avoid installing it twice */ + if(Curl_cwriter_get_by_name(data, hds_cw_collect.name)) + return CURLE_OK; + + result = Curl_cwriter_create(&writer, data, &hds_cw_collect, + CURL_CW_PROTOCOL); + if(result) + return result; + + result = Curl_cwriter_add(data, writer); + if(result) { + Curl_cwriter_free(data, writer); + return result; + } + } + return CURLE_OK; +} + +/* + * Curl_headers_cleanup(). Free all stored headers and associated memory. + */ +CURLcode Curl_headers_cleanup(struct Curl_easy *data) +{ + struct Curl_llist_node *e; + struct Curl_llist_node *n; + + for(e = Curl_llist_head(&data->state.httphdrs); e; e = n) { + struct Curl_header_store *hs = Curl_node_elem(e); + n = Curl_node_next(e); + curlx_free(hs); + } + headers_reset(data); + return CURLE_OK; +} + +#else /* HTTP-disabled builds below */ + +CURLHcode curl_easy_header(CURL *easy, + const char *name, + size_t index, + unsigned int origin, + int request, + struct curl_header **hout) +{ + (void)easy; + (void)name; + (void)index; + (void)origin; + (void)request; + (void)hout; + return CURLHE_NOT_BUILT_IN; +} + +struct curl_header *curl_easy_nextheader(CURL *easy, + unsigned int type, + int request, + struct curl_header *prev) +{ + (void)easy; + (void)type; + (void)request; + (void)prev; + return NULL; +} +#endif diff --git a/3rdparty/curl-8.21.0/lib/headers.h b/3rdparty/curl-8.21.0/lib/headers.h new file mode 100644 index 0000000000..283179acdc --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/headers.h @@ -0,0 +1,63 @@ +#ifndef HEADER_CURL_HEADER_H +#define HEADER_CURL_HEADER_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_HTTP) && !defined(CURL_DISABLE_HEADERS_API) + +struct Curl_header_store { + struct Curl_llist_node node; + char *name; /* points into 'buffer' */ + char *value; /* points into 'buffer' */ + int request; /* 0 is the first request, then 1.. 2.. */ + unsigned char type; /* CURLH_* defines */ + char buffer[1]; /* this is the raw header blob */ +}; + +/* + * Initialize header collecting for a transfer. + * Add a client writer that catches CLIENTWRITE_HEADER writes. + */ +CURLcode Curl_headers_init(struct Curl_easy *data); + +/* + * Curl_headers_push() gets passed a full header to store. + */ +CURLcode Curl_headers_push(struct Curl_easy *data, const char *header, + size_t hlen, unsigned char type); + +/* + * Curl_headers_cleanup(). Free all stored headers and associated memory. + */ +CURLcode Curl_headers_cleanup(struct Curl_easy *data); + +#else +#define Curl_headers_init(x) CURLE_OK +#define Curl_headers_push(x, y, z, a) \ + ((void)(x), (void)(y), (void)(z), (void)(a), CURLE_OK) +#define Curl_headers_cleanup(x) Curl_nop_stmt +#endif + +#endif /* HEADER_CURL_HEADER_H */ diff --git a/3rdparty/curl-8.21.0/lib/hmac.c b/3rdparty/curl-8.21.0/lib/hmac.c new file mode 100644 index 0000000000..a4d6ebdd8a --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/hmac.c @@ -0,0 +1,170 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + * RFC2104 Keyed-Hashing for Message Authentication + * + ***************************************************************************/ +#include "curl_setup.h" + +#if (defined(USE_CURL_NTLM_CORE) && !defined(USE_WINDOWS_SSPI)) || \ + !defined(CURL_DISABLE_AWS) || !defined(CURL_DISABLE_DIGEST_AUTH) || \ + defined(USE_SSL) + +#include "curl_hmac.h" + +/* + * Generic HMAC algorithm. + * + * This module computes HMAC digests based on any hash function. Parameters + * and computing procedures are setup dynamically at HMAC computation context + * initialization. + */ + +static const unsigned char hmac_ipad = 0x36; +static const unsigned char hmac_opad = 0x5C; + +struct HMAC_context *Curl_HMAC_init(const struct HMAC_params *hashparams, + const unsigned char *key, + unsigned int keylen) +{ + size_t i; + struct HMAC_context *ctxt; + unsigned char *hkey; + unsigned char b; + + /* Create HMAC context. */ + i = sizeof(*ctxt) + (2 * hashparams->ctxtsize) + hashparams->resultlen; + ctxt = curlx_malloc(i); + + if(!ctxt) + return ctxt; + + ctxt->hash = hashparams; + ctxt->hashctxt1 = (void *)(ctxt + 1); + ctxt->hashctxt2 = (void *)((char *)ctxt->hashctxt1 + hashparams->ctxtsize); + + /* If the key is too long, replace it by its hash digest. */ + if(keylen > hashparams->maxkeylen) { + if(hashparams->hinit(ctxt->hashctxt1)) + goto fail; + hashparams->hupdate(ctxt->hashctxt1, key, keylen); + hkey = (unsigned char *)ctxt->hashctxt2 + hashparams->ctxtsize; + hashparams->hfinal(hkey, ctxt->hashctxt1); + key = hkey; + keylen = hashparams->resultlen; + } + + /* Prime the two hash contexts with the modified key. */ + if(hashparams->hinit(ctxt->hashctxt1) || + hashparams->hinit(ctxt->hashctxt2)) + goto fail; + + for(i = 0; i < keylen; i++) { + b = (unsigned char)(*key ^ hmac_ipad); + hashparams->hupdate(ctxt->hashctxt1, &b, 1); + b = (unsigned char)(*key++ ^ hmac_opad); + hashparams->hupdate(ctxt->hashctxt2, &b, 1); + } + + for(; i < hashparams->maxkeylen; i++) { + hashparams->hupdate(ctxt->hashctxt1, &hmac_ipad, 1); + hashparams->hupdate(ctxt->hashctxt2, &hmac_opad, 1); + } + + /* Done, return pointer to HMAC context. */ + return ctxt; + +fail: + curlx_free(ctxt); + return NULL; +} + +void Curl_HMAC_update(struct HMAC_context *ctxt, + const unsigned char *data, + unsigned int len) +{ + /* Update first hash calculation. */ + ctxt->hash->hupdate(ctxt->hashctxt1, data, len); +} + +int Curl_HMAC_final(struct HMAC_context *ctxt, unsigned char *output) +{ + const struct HMAC_params *hashparams = ctxt->hash; + + /* Do not get output if called with a null parameter: only release + storage. */ + + if(!output) + output = (unsigned char *)ctxt->hashctxt2 + ctxt->hash->ctxtsize; + + hashparams->hfinal(output, ctxt->hashctxt1); + hashparams->hupdate(ctxt->hashctxt2, output, hashparams->resultlen); + hashparams->hfinal(output, ctxt->hashctxt2); + curlx_free(ctxt); + return 0; +} + +/* + * Curl_hmacit() + * + * This is used to generate a HMAC hash, for the specified input data, given + * the specified hash function and key. + * + * Parameters: + * + * hashparams [in] - The hash function (Curl_HMAC_MD5). + * key [in] - The key to use. + * keylen [in] - The length of the key. + * buf [in] - The data to encrypt. + * buflen [in] - The length of the data. + * output [in/out] - The output buffer. + * + * Returns CURLE_OK on success. + */ +CURLcode Curl_hmacit(const struct HMAC_params *hashparams, + const unsigned char *key, const size_t keylen, + const unsigned char *data, size_t datalen, + unsigned char *output) +{ + struct HMAC_context *ctxt; + if(keylen > UINT_MAX) /* unlikely to ever happen */ + return CURLE_BAD_FUNCTION_ARGUMENT; + ctxt = Curl_HMAC_init(hashparams, key, curlx_uztoui(keylen)); + + if(!ctxt) + return CURLE_OUT_OF_MEMORY; + + /* Update the digest with the given challenge */ + do { + unsigned int ilen = (unsigned int)CURLMIN(datalen, UINT_MAX); + Curl_HMAC_update(ctxt, data, ilen); + datalen -= ilen; + data += ilen; + } while(datalen); + + /* Finalise the digest */ + Curl_HMAC_final(ctxt, output); + + return CURLE_OK; +} + +#endif /* Using NTLM (without SSPI) or AWS */ diff --git a/3rdparty/curl-8.21.0/lib/hostip.c b/3rdparty/curl-8.21.0/lib/hostip.c new file mode 100644 index 0000000000..a18d9a62bb --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/hostip.c @@ -0,0 +1,1129 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include +#endif +#ifdef HAVE_NETDB_H +#include +#endif +#ifdef HAVE_ARPA_INET_H +#include +#endif +#ifdef __VMS +#include +#include +#endif + +#include /* for sigjmp_buf, sigsetjmp() */ +#include + +#include "urldata.h" +#include "curl_addrinfo.h" +#include "curl_trc.h" +#include "dnscache.h" +#include "hostip.h" +#include "httpsrr.h" +#include "url.h" +#include "multiif.h" +#include "progress.h" +#include "doh.h" +#include "select.h" +#include "strcase.h" +#include "easy_lock.h" +#include "curlx/inet_ntop.h" +#include "curlx/inet_pton.h" +#include "curlx/strcopy.h" +#include "curlx/strparse.h" + +#if defined(CURLRES_SYNCH) && \ + defined(HAVE_ALARM) && \ + defined(SIGALRM) && \ + defined(HAVE_SIGSETJMP) && \ + defined(GLOBAL_INIT_IS_THREADSAFE) +/* alarm-based timeouts can only be used with all the dependencies satisfied */ +#define USE_ALARM_TIMEOUT +#endif + +#define RESOLV_FAIL(for_proxy) \ + ((for_proxy) ? CURLE_COULDNT_RESOLVE_PROXY : CURLE_COULDNT_RESOLVE_HOST) + +#define IS_RESOLV_FAIL(result) \ + (((result) == CURLE_COULDNT_RESOLVE_HOST) || \ + ((result) == CURLE_COULDNT_RESOLVE_PROXY)) +/* + * ipv6works() returns TRUE if IPv6 seems to work. + */ +#ifdef USE_IPV6 +static bool ipv6works(struct Curl_easy *data); +#else +#define ipv6works(x) FALSE +#endif + +/* + * hostip.c explained + * ================== + * + * The main COMPILE-TIME DEFINES to keep in mind when reading the host*.c + * source file are these: + * + * CURLRES_IPV6 - this host has getaddrinfo() and family, and thus we use + * that. The host may not be able to resolve IPv6, but we do not really have to + * take that into account. Hosts that are not IPv6-enabled have CURLRES_IPV4 + * defined. + * + * USE_RESOLV_ARES - is defined if libcurl is built to use c-ares for + * asynchronous name resolves. This can be Windows or *nix. + * + * USE_RESOLV_THREADED - is defined if libcurl is built to run under (native) + * Windows, and then the name resolve will be done in a new thread, and the + * supported API will be the same as for ares-builds. + * + * If any of the two previous are defined, CURLRES_ASYNCH is defined too. If + * libcurl is not built to use an asynchronous resolver, CURLRES_SYNCH is + * defined. + * + * The host*.c sources files are split up like this: + * + * hostip.c - method-independent resolver functions and utility functions + * hostip4.c - IPv4 specific functions + * hostip6.c - IPv6 specific functions + * asyn.h - common functions for all async resolvers + * The two asynchronous name resolver backends are implemented in: + * asyn-ares.c - async resolver using c-ares + * asyn-thread.c - async resolver using POSIX threads + * + * The hostip.h is the united header file for all this. It defines the + * CURLRES_* defines based on the config*.h and curl_setup.h defines. + */ + +uint8_t Curl_resolv_dns_queries(struct Curl_easy *data, uint8_t ip_version) +{ + (void)data; + switch(ip_version) { + case CURL_IPRESOLVE_V6: + return CURL_DNSQ_AAAA; + case CURL_IPRESOLVE_V4: + return CURL_DNSQ_A; + default: + if(ipv6works(data)) + return (CURL_DNSQ_A | CURL_DNSQ_AAAA); + else + return CURL_DNSQ_A; + } +} + +#ifdef CURLVERBOSE +const char *Curl_resolv_query_str(uint8_t dns_queries) +{ + switch(dns_queries) { + case (CURL_DNSQ_A | CURL_DNSQ_AAAA | CURL_DNSQ_HTTPS): + return "A+AAAA+HTTPS"; + case (CURL_DNSQ_A | CURL_DNSQ_AAAA): + return "A+AAAA"; + case (CURL_DNSQ_AAAA | CURL_DNSQ_HTTPS): + return "AAAA+HTTPS"; + case (CURL_DNSQ_AAAA): + return "AAAA"; + case (CURL_DNSQ_A | CURL_DNSQ_HTTPS): + return "A+HTTPS"; + case (CURL_DNSQ_A): + return "A"; + case (CURL_DNSQ_HTTPS): + return "HTTPS"; + case 0: + return "-"; + default: + DEBUGASSERT(0); + return "???"; + } +} +#endif + +/* + * Curl_printable_address() stores a printable version of the 1st address + * given in the 'ai' argument. The result will be stored in the buf that is + * bufsize bytes big. + * + * If the conversion fails, the target buffer is empty. + */ +void Curl_printable_address(const struct Curl_addrinfo *ai, char *buf, + size_t bufsize) +{ + DEBUGASSERT(bufsize); + buf[0] = 0; + + switch(ai->ai_family) { + case AF_INET: { + const struct sockaddr_in *sa4 = (const void *)ai->ai_addr; + const struct in_addr *ipaddr4 = &sa4->sin_addr; + (void)curlx_inet_ntop(ai->ai_family, (const void *)ipaddr4, buf, bufsize); + break; + } +#ifdef USE_IPV6 + case AF_INET6: { + const struct sockaddr_in6 *sa6 = (const void *)ai->ai_addr; + const struct in6_addr *ipaddr6 = &sa6->sin6_addr; + (void)curlx_inet_ntop(ai->ai_family, (const void *)ipaddr6, buf, bufsize); + break; + } +#endif + default: + break; + } +} + +#ifdef USE_ALARM_TIMEOUT +/* Beware this is a global and unique instance. This is used to store the + return address that we can jump back to from inside a signal handler. This + is not thread-safe stuff. */ +static sigjmp_buf curl_jmpenv; +static curl_simple_lock curl_jmpenv_lock = CURL_SIMPLE_LOCK_INIT; +#endif + +#ifdef USE_IPV6 +/* return a static IPv6 ::1 for the name */ +static struct Curl_addrinfo *get_localhost6(uint16_t port, const char *name) +{ + struct Curl_addrinfo *ca; + const size_t ss_size = sizeof(struct sockaddr_in6); + const size_t hostlen = strlen(name); + struct sockaddr_in6 sa6; + unsigned char ipv6[16]; + unsigned short port16 = (unsigned short)(port & 0xffff); + ca = curlx_calloc(1, sizeof(struct Curl_addrinfo) + ss_size + hostlen + 1); + if(!ca) + return NULL; + + memset(&sa6, 0, sizeof(sa6)); + sa6.sin6_family = AF_INET6; + sa6.sin6_port = htons(port16); + + (void)curlx_inet_pton(AF_INET6, "::1", ipv6); + memcpy(&sa6.sin6_addr, ipv6, sizeof(ipv6)); + + ca->ai_flags = 0; + ca->ai_family = AF_INET6; + ca->ai_socktype = SOCK_STREAM; + ca->ai_protocol = IPPROTO_TCP; + ca->ai_addrlen = (curl_socklen_t)ss_size; + ca->ai_next = NULL; + ca->ai_addr = (void *)((char *)ca + sizeof(struct Curl_addrinfo)); + memcpy(ca->ai_addr, &sa6, ss_size); + ca->ai_canonname = (char *)ca->ai_addr + ss_size; + curlx_strcopy(ca->ai_canonname, hostlen + 1, name, hostlen); + return ca; +} +#else +#define get_localhost6(x, y) NULL +#endif + +/* return a static IPv4 127.0.0.1 for the given name */ +static struct Curl_addrinfo *get_localhost(uint16_t port, const char *name) +{ + struct Curl_addrinfo *ca; + struct Curl_addrinfo *ca6; + const size_t ss_size = sizeof(struct sockaddr_in); + const size_t hostlen = strlen(name); + struct sockaddr_in sa; + unsigned int ipv4; + unsigned short port16 = (unsigned short)(port & 0xffff); + + /* memset to clear the sa.sin_zero field */ + memset(&sa, 0, sizeof(sa)); + sa.sin_family = AF_INET; + sa.sin_port = htons(port16); + if(curlx_inet_pton(AF_INET, "127.0.0.1", (char *)&ipv4) < 1) + return NULL; + memcpy(&sa.sin_addr, &ipv4, sizeof(ipv4)); + + ca = curlx_calloc(1, sizeof(struct Curl_addrinfo) + ss_size + hostlen + 1); + if(!ca) + return NULL; + ca->ai_flags = 0; + ca->ai_family = AF_INET; + ca->ai_socktype = SOCK_STREAM; + ca->ai_protocol = IPPROTO_TCP; + ca->ai_addrlen = (curl_socklen_t)ss_size; + ca->ai_addr = (void *)((char *)ca + sizeof(struct Curl_addrinfo)); + memcpy(ca->ai_addr, &sa, ss_size); + ca->ai_canonname = (char *)ca->ai_addr + ss_size; + curlx_strcopy(ca->ai_canonname, hostlen + 1, name, hostlen); + + ca6 = get_localhost6(port, name); + if(!ca6) + return ca; + ca6->ai_next = ca; + return ca6; +} + +#ifdef USE_IPV6 +/* the nature of most systems is that IPv6 status does not come and go during a + program's lifetime so we only probe the first time and then we have the + info kept for fast reuse */ +CURLcode Curl_probeipv6(struct Curl_multi *multi) +{ + /* probe to see if we have a working IPv6 stack */ + curl_socket_t s = CURL_SOCKET(PF_INET6, SOCK_DGRAM, 0); + multi->ipv6_works = FALSE; + if(s == CURL_SOCKET_BAD) { + if(SOCKERRNO == SOCKENOMEM) + return CURLE_OUT_OF_MEMORY; + } + else { + multi->ipv6_works = TRUE; + sclose(s); + } + return CURLE_OK; +} + +/* + * ipv6works() returns TRUE if IPv6 seems to work. + */ +static bool ipv6works(struct Curl_easy *data) +{ + DEBUGASSERT(data); + DEBUGASSERT(data->multi); + return data ? data->multi->ipv6_works : FALSE; +} +#endif /* USE_IPV6 */ + +/* + * Curl_host_is_ipnum() returns TRUE if the given string is a numerical IPv4 + * (or IPv6 if supported) address. + */ +bool Curl_host_is_ipnum(const char *hostname) +{ + struct in_addr in; +#ifdef USE_IPV6 + struct in6_addr in6; +#endif + if(curlx_inet_pton(AF_INET, hostname, &in) > 0 +#ifdef USE_IPV6 + || curlx_inet_pton(AF_INET6, hostname, &in6) > 0 +#endif + ) + return TRUE; + return FALSE; +} + +/* return TRUE if 'part' is a case insensitive tail of 'full' */ +static bool tailmatch(const char *full, size_t flen, + const char *part, size_t plen) +{ + if(plen > flen) + return FALSE; + return curl_strnequal(part, &full[flen - plen], plen); +} + +static CURLcode hostip_resolv_failed(struct Curl_easy *data, + const char *hostname, + bool for_proxy) +{ + failf(data, "Could not resolve %s: %s", + for_proxy ? "proxy" : "host", hostname); + return RESOLV_FAIL(for_proxy); +} + +static bool can_resolve_dns_queries(struct Curl_easy *data, + uint8_t dns_queries) +{ + (void)data; + if((CURL_DNSQ_IP(dns_queries) == CURL_DNSQ_AAAA) && !ipv6works(data)) + return FALSE; + return TRUE; +} + +CURLcode Curl_resolv_announce_start(struct Curl_easy *data, + void *resolver) +{ + if(data->set.resolver_start) { + int rc; + + CURL_TRC_DNS(data, "announcing resolve to application"); + Curl_set_in_callback(data, TRUE); + rc = data->set.resolver_start(resolver, NULL, + data->set.resolver_start_client); + Curl_set_in_callback(data, FALSE); + if(rc) { + CURL_TRC_DNS(data, "application aborted resolve"); + return CURLE_ABORTED_BY_CALLBACK; + } + } + return CURLE_OK; +} + +#ifdef USE_CURL_ASYNC + +static struct Curl_resolv_async *hostip_async_new(struct Curl_easy *data, + uint8_t dns_queries, + const char *hostname, + uint16_t port, + uint8_t transport, + bool for_proxy, + timediff_t timeout_ms) +{ + struct Curl_resolv_async *async; + size_t hostlen = strlen(hostname); + + if(!data->multi) { + DEBUGASSERT(0); + return NULL; + } + + /* struct size already includes the NUL for hostname */ + async = curlx_calloc(1, sizeof(*async) + hostlen); + if(!async) + return NULL; + + /* Give every async resolve operation a "unique" id. This may + * wrap around after a long time, making collisions highly unlikely. + * As we keep the async structs at the easy handle, chances of + * easy `mid plus resolv->id` colliding should be astronomical. + * `resolv_id == 0` is never used. */ + if(data->multi->last_resolv_id == UINT32_MAX) + data->multi->last_resolv_id = 1; /* wrap around */ + else + data->multi->last_resolv_id++; + async->id = data->multi->last_resolv_id; + async->dns_queries = dns_queries; + async->port = port; + async->transport = transport; + async->for_proxy = for_proxy; + async->start = *Curl_pgrs_now(data); + async->timeout_ms = timeout_ms; + if(hostlen) { + memcpy(async->hostname, hostname, hostlen); + async->is_ipaddr = Curl_is_ipaddr(async->hostname); + if(async->is_ipaddr) + async->is_ipv4addr = Curl_is_ipv4addr(async->hostname); + } + + return async; +} + +static CURLcode hostip_resolv_take_result(struct Curl_easy *data, + struct Curl_resolv_async *async, + struct Curl_dns_entry **pdns) +{ + CURLcode result; + + /* If async resolving is ongoing, this must be set */ + if(!async) + return CURLE_FAILED_INIT; + +#ifndef CURL_DISABLE_DOH + if(async->doh) + result = Curl_doh_take_result(data, async, pdns); + else +#endif + result = Curl_async_take_result(data, async, pdns); + + if(result == CURLE_AGAIN) { + CURL_TRC_DNS(data, "resolve incomplete, queries=%s, responses=%s, " + "ongoing=%d for %s:%d", + Curl_resolv_query_str(async->dns_queries), + Curl_resolv_query_str(async->dns_responses), + async->queries_ongoing, async->hostname, async->port); + result = CURLE_OK; + } + else if(result) { + result = Curl_async_failed(data, async, NULL); + } + else { + CURL_TRC_DNS(data, "resolve complete for %s:%u", + async->hostname, async->port); + DEBUGASSERT(*pdns); + } + + return result; +} + +timediff_t Curl_resolv_elapsed_ms(struct Curl_easy *data, + uint32_t resolv_id) +{ + struct Curl_resolv_async *async = Curl_async_get(data, resolv_id); + if(!async) + return CURL_TIMEOUT_RESOLVE_MS; + return curlx_ptimediff_ms(Curl_pgrs_now(data), &async->start); +} + +bool Curl_resolv_has_answers(struct Curl_easy *data, + uint32_t resolv_id, uint8_t dns_queries) +{ + struct Curl_resolv_async *async = Curl_async_get(data, resolv_id); + uint8_t check_queries; + /* a no longer existing/running resolve has all answers. */ + if(!async || async->done) + return TRUE; + /* Relevant are only queries undertaken. Others are considered answered. */ + check_queries = (dns_queries & async->dns_queries); + if((check_queries & async->dns_responses) != check_queries) { + return FALSE; + } + return TRUE; +} + +const struct Curl_addrinfo *Curl_resolv_get_ai(struct Curl_easy *data, + uint32_t resolv_id, + int ai_family, + unsigned int index) +{ + struct Curl_resolv_async *async = Curl_async_get(data, resolv_id); + (void)index; + if(!async) + return NULL; + if((ai_family == AF_INET) && !(async->dns_queries & CURL_DNSQ_A)) + return NULL; +#ifdef USE_IPV6 + if((ai_family == AF_INET6) && !(async->dns_queries & CURL_DNSQ_AAAA)) + return NULL; +#endif + return Curl_async_get_ai(data, async, ai_family, index); +} + +#ifdef USE_HTTPSRR +const struct Curl_https_rrinfo * +Curl_resolv_get_https(struct Curl_easy *data, uint32_t resolv_id) +{ + struct Curl_resolv_async *async = Curl_async_get(data, resolv_id); + if(!async) + return NULL; + return Curl_async_get_https(data, async); +} + +bool Curl_resolv_knows_https(struct Curl_easy *data, uint32_t resolv_id) +{ + struct Curl_resolv_async *async = Curl_async_get(data, resolv_id); + if(!async) + return TRUE; + return Curl_async_knows_https(data, async); +} +#endif /* USE_HTTPSRR */ + +#endif /* USE_CURL_ASYNC */ + +static CURLcode hostip_resolv_start(struct Curl_easy *data, + uint8_t dns_queries, + const char *hostname, + uint16_t port, + uint8_t transport, + bool for_proxy, + timediff_t timeout_ms, + bool allowDOH, + uint32_t *presolv_id, + struct Curl_dns_entry **pdns) +{ +#ifdef USE_CURL_ASYNC + struct Curl_resolv_async *async = NULL; +#endif + struct Curl_addrinfo *addr = NULL; + size_t hostname_len; + CURLcode result = CURLE_OK; + + (void)timeout_ms; /* not in all ifdefs */ + *presolv_id = 0; + *pdns = NULL; + + /* Check for "known" things to resolve ourselves. */ +#ifndef USE_RESOLVE_ON_IPS + if(Curl_is_ipaddr(hostname)) { + /* test655 verifies that the announce is done, even though there + * is no real resolving. So, keep doing this. */ + result = Curl_resolv_announce_start(data, NULL); + if(result) + goto out; + /* shortcut literal IP addresses, if we are not told to resolve them. */ + result = Curl_str2addr(hostname, port, &addr); + goto out; + } +#endif + + hostname_len = strlen(hostname); + if(curl_strequal(hostname, "localhost") || + curl_strequal(hostname, "localhost.") || + tailmatch(hostname, hostname_len, STRCONST(".localhost")) || + tailmatch(hostname, hostname_len, STRCONST(".localhost."))) { + result = Curl_resolv_announce_start(data, NULL); + if(result) + goto out; + addr = get_localhost(port, hostname); + if(!addr) + result = CURLE_OUT_OF_MEMORY; + goto out; + } + +#ifndef CURL_DISABLE_DOH + if(!Curl_is_ipaddr(hostname) && allowDOH && data->set.doh) { + result = Curl_resolv_announce_start(data, NULL); + if(result) + goto out; + if(!async) { + async = hostip_async_new(data, dns_queries, hostname, port, + transport, for_proxy, timeout_ms); + if(!async) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + } + result = Curl_doh(data, async); + goto out; + } +#else + (void)allowDOH; +#endif + + /* Can we provide the requested IP specifics in resolving? */ + if(!can_resolve_dns_queries(data, dns_queries)) { + result = RESOLV_FAIL(for_proxy); + goto out; + } + +#ifdef CURLRES_ASYNCH + (void)addr; + if(!async) { + async = hostip_async_new(data, dns_queries, hostname, port, + transport, for_proxy, timeout_ms); + if(!async) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + } + result = Curl_async_getaddrinfo(data, async); + if(result == CURLE_AGAIN) { + /* the answer might be there already. Check. */ + CURLcode r2 = hostip_resolv_take_result(data, async, pdns); + if(r2) + result = r2; + else if(*pdns) + result = CURLE_OK; + } +#else + result = Curl_resolv_announce_start(data, NULL); + if(result) + goto out; + addr = Curl_sync_getaddrinfo(data, dns_queries, hostname, port, transport); + if(!addr) + result = RESOLV_FAIL(for_proxy); +#endif + +out: + if(!result) { + if(addr) { + /* we got a response, create a dns entry, add to cache, return */ + DEBUGASSERT(!*pdns); + *pdns = Curl_dnscache_mk_entry(data, dns_queries, &addr, hostname, port); + if(!*pdns) + result = CURLE_OUT_OF_MEMORY; + } + else if(!*pdns) + result = CURLE_AGAIN; + } + else if(*pdns) + Curl_dns_entry_unlink(data, pdns); + else if(addr) + Curl_freeaddrinfo(addr); + +#ifdef USE_CURL_ASYNC + if(async) { + if(result == CURLE_AGAIN) { /* still need it, link, return id. */ + *presolv_id = async->id; + async->next = data->state.async; + data->state.async = async; + } + else { + Curl_async_destroy(data, async); + } + } +#endif + return result; +} + +static CURLcode hostip_resolv(struct Curl_easy *data, + uint8_t dns_queries, + const char *hostname, + uint16_t port, + uint8_t transport, + bool for_proxy, + timediff_t timeout_ms, + bool allowDOH, + uint32_t *presolv_id, + struct Curl_dns_entry **pdns) +{ + size_t hostname_len; + CURLcode result = RESOLV_FAIL(for_proxy); + bool cache_dns = FALSE; + + (void)timeout_ms; /* not used in all ifdefs */ + *presolv_id = 0; + *pdns = NULL; + +#ifdef CURL_DISABLE_DOH + (void)allowDOH; +#endif + + /* We should intentionally error and not resolve .onion TLDs */ + hostname_len = strlen(hostname); + DEBUGASSERT(hostname_len); + if(hostname_len >= 7 && + (curl_strequal(&hostname[hostname_len - 6], ".onion") || + curl_strequal(&hostname[hostname_len - 7], ".onion."))) { + failf(data, "Not resolving .onion address (RFC 7686)"); + goto out; + } + +#ifdef DEBUGBUILD + CURL_TRC_DNS(data, "hostip_resolv(%s:%u, queries=%s)", + hostname, port, Curl_resolv_query_str(dns_queries)); + if((CURL_DNSQ_IP(dns_queries) == CURL_DNSQ_AAAA) && + getenv("CURL_DBG_RESOLV_FAIL_IPV6")) { + infof(data, "DEBUG fail ipv6 resolve"); + result = hostip_resolv_failed(data, hostname, for_proxy); + goto out; + } +#endif + /* Let's check our DNS cache first */ + result = Curl_dnscache_get(data, dns_queries, hostname, port, pdns); + if(*pdns) { + infof(data, "Hostname %s was found in DNS cache", hostname); + result = CURLE_OK; + } + else if(result) { + infof(data, "Negative DNS entry"); + result = hostip_resolv_failed(data, hostname, for_proxy); + } + else { + /* No luck, we need to start resolving. */ + cache_dns = TRUE; + result = hostip_resolv_start(data, dns_queries, hostname, port, + transport, for_proxy, timeout_ms, allowDOH, + presolv_id, pdns); + } + +out: + if(result && (result != CURLE_AGAIN)) { + Curl_dns_entry_unlink(data, pdns); + if(IS_RESOLV_FAIL(result)) { + if(cache_dns) + Curl_dnscache_add_negative(data, dns_queries, hostname, port); + failf(data, "Could not resolve: %s:%u", hostname, port); + } + else { + failf(data, "Error %d resolving %s:%u", (int)result, hostname, port); + } + } + else if(cache_dns && *pdns) { + result = Curl_dnscache_add(data, *pdns); + if(result) + Curl_dns_entry_unlink(data, pdns); + } + + return result; +} + +CURLcode Curl_resolv_blocking(struct Curl_easy *data, + uint8_t dns_queries, + const char *hostname, + uint16_t port, + uint8_t transport, + struct Curl_dns_entry **pdns) +{ + CURLcode result; + uint32_t resolv_id; + DEBUGASSERT(hostname && *hostname); + *pdns = NULL; + /* We cannot do a blocking resolve using DoH currently */ + result = hostip_resolv(data, dns_queries, + hostname, port, transport, FALSE, 0, FALSE, + &resolv_id, pdns); + switch(result) { + case CURLE_OK: + DEBUGASSERT(*pdns); + break; +#ifdef USE_CURL_ASYNC + case CURLE_AGAIN: + DEBUGASSERT(!*pdns); + result = Curl_async_await(data, resolv_id, pdns); + Curl_resolv_destroy(data, resolv_id); + break; +#endif + default: + break; + } + return result; +} + +#ifdef USE_ALARM_TIMEOUT +/* + * This signal handler jumps back into the main libcurl code and continues + * execution. This effectively causes the remainder of the application to run + * within a signal handler which is nonportable and could lead to problems. + */ +CURL_NORETURN static void alarmfunc(int sig) +{ + (void)sig; + siglongjmp(curl_jmpenv, 1); +} + +static CURLcode resolv_alarm_timeout(struct Curl_easy *data, + uint8_t dns_queries, + const char *hostname, + uint16_t port, + uint8_t transport, + bool for_proxy, + timediff_t timeout_ms, + uint32_t *presolv_id, + struct Curl_dns_entry **entry) +{ +#ifdef HAVE_SIGACTION + struct sigaction keep_sigact; /* store the old struct here */ + volatile bool keep_copysig = FALSE; /* whether old sigact has been saved */ + struct sigaction sigact; +#else +#ifdef HAVE_SIGNAL + void (*keep_sigact)(int); /* store the old handler here */ +#endif /* HAVE_SIGNAL */ +#endif /* HAVE_SIGACTION */ + volatile long timeout; + volatile unsigned int prev_alarm = 0; + CURLcode result; + + DEBUGASSERT(hostname && *hostname); + DEBUGASSERT(timeout_ms > 0); + DEBUGASSERT(!data->set.no_signal); +#ifndef CURL_DISABLE_DOH + DEBUGASSERT(!data->set.doh); +#endif + + *entry = NULL; + timeout = (timeout_ms > LONG_MAX) ? LONG_MAX : (long)timeout_ms; + if(timeout < 1000) { + /* The alarm() function only provides integer second resolution, so if + we want to wait less than one second we must bail out already now. */ + failf(data, + "remaining timeout of %ld too small to resolve via SIGALRM method", + timeout); + return CURLE_OPERATION_TIMEDOUT; + } + /* This allows us to time-out from the name resolver, as the timeout + will generate a signal and we will siglongjmp() from that here. + This technique has problems (see alarmfunc). + This should be the last thing we do before calling Curl_resolv(), + as otherwise we would have to worry about variables that get modified + before we invoke Curl_resolv() (and thus use "volatile"). */ + curl_simple_lock_lock(&curl_jmpenv_lock); + + if(sigsetjmp(curl_jmpenv, 1)) { + /* this is coming from a siglongjmp() after an alarm signal */ + failf(data, "name lookup timed out"); + result = CURLE_OPERATION_TIMEDOUT; + goto clean_up; + } + else { + /************************************************************* + * Set signal handler to catch SIGALRM + * Store the old value to be able to set it back later! + *************************************************************/ +#ifdef HAVE_SIGACTION + sigaction(SIGALRM, NULL, &sigact); + keep_sigact = sigact; + keep_copysig = TRUE; /* yes, we have a copy */ + sigact.sa_handler = alarmfunc; +#ifdef SA_RESTART + /* HP-UX does not have SA_RESTART but defaults to that behavior! */ + sigact.sa_flags &= ~SA_RESTART; +#endif + /* now set the new struct */ + sigaction(SIGALRM, &sigact, NULL); +#else /* HAVE_SIGACTION */ + /* no sigaction(), revert to the much lamer signal() */ +#ifdef HAVE_SIGNAL + keep_sigact = signal(SIGALRM, alarmfunc); +#endif +#endif /* HAVE_SIGACTION */ + + /* alarm() makes a signal get sent when the timeout fires off, and that + will abort system calls */ + prev_alarm = alarm(curlx_sltoui(timeout / 1000L)); + } + + /* Perform the actual name resolution. This might be interrupted by an + * alarm if it takes too long. */ + result = hostip_resolv(data, dns_queries, hostname, port, transport, + for_proxy, timeout_ms, FALSE, presolv_id, entry); + +clean_up: + if(!prev_alarm) + /* deactivate a possibly active alarm before uninstalling the handler */ + alarm(0); + +#ifdef HAVE_SIGACTION + if(keep_copysig) { + /* we got a struct as it looked before, now put that one back nice + and clean */ + sigaction(SIGALRM, &keep_sigact, NULL); /* put it back */ + } +#else +#ifdef HAVE_SIGNAL + /* restore the previous SIGALRM handler */ + signal(SIGALRM, keep_sigact); +#endif +#endif /* HAVE_SIGACTION */ + + curl_simple_lock_unlock(&curl_jmpenv_lock); + + /* switch back the alarm() to either zero or to what it was before minus + the time we spent until now! */ + if(prev_alarm) { + /* there was an alarm() set before us, now put it back */ + timediff_t elapsed_secs = curlx_ptimediff_ms(Curl_pgrs_now(data), + &data->conn->created) / 1000; + + /* the alarm period is counted in even number of seconds */ + unsigned long alarm_set = (unsigned long)(prev_alarm - elapsed_secs); + + if(!alarm_set || + ((alarm_set >= 0x80000000) && (prev_alarm < 0x80000000))) { + /* if the alarm time-left reached zero or turned "negative" (counted + with unsigned values), we should fire off a SIGALRM here, but we + will not, and zero would be to switch it off so we never set it to + less than 1! */ + alarm(1); + result = CURLE_OPERATION_TIMEDOUT; + failf(data, "Previous alarm fired off"); + } + else + alarm((unsigned int)alarm_set); + } + + return result; +} + +#endif /* USE_ALARM_TIMEOUT */ + +#ifdef USE_UNIX_SOCKETS +static CURLcode resolv_unix(struct Curl_easy *data, + const char *unix_path, + bool abstract_path, + struct Curl_dns_entry **pdns) +{ + struct Curl_addrinfo *addr; + CURLcode result; + + DEBUGASSERT(unix_path); + *pdns = NULL; + + result = Curl_unix2addr(unix_path, abstract_path, &addr); + if(result) { + if(result == CURLE_TOO_LARGE) { + /* Long paths are not supported for now */ + failf(data, "Unix socket path too long: '%s'", unix_path); + result = CURLE_COULDNT_RESOLVE_HOST; + } + return result; + } + + *pdns = Curl_dnscache_mk_entry(data, 0, &addr, NULL, 0); + return *pdns ? CURLE_OK : CURLE_OUT_OF_MEMORY; +} +#endif /* USE_UNIX_SOCKETS */ + +/* + * Curl_resolv() is the main name resolve function within libcurl. It resolves + * a name and returns a pointer to the entry in the 'entry' argument. This + * function might return immediately if we are using asynch resolves. See the + * return codes. + * + * The cache entry we return will get its 'inuse' counter increased when this + * function is used. You MUST call Curl_dns_entry_unlink() later (when you are + * done using this struct) to decrease the reference counter again. + * + * If built with a synchronous resolver and use of signals is not + * disabled by the application, then a nonzero timeout will cause a + * timeout after the specified number of milliseconds. Otherwise, timeout + * is ignored. + * + * Return codes: + * CURLE_OK = success, *pdns set to non-NULL + * CURLE_AGAIN = resolving in progress, *pdns == NULL + * any other CURLcode error, *pdns == NULL + */ +CURLcode Curl_resolv(struct Curl_easy *data, + struct Curl_peer *peer, + uint8_t dns_queries, + uint8_t transport, + bool for_proxy, + timediff_t timeout_ms, + uint32_t *presolv_id, + struct Curl_dns_entry **pdns) +{ + *presolv_id = 0; + *pdns = NULL; + + if(timeout_ms < 0) + /* got an already expired timeout */ + return CURLE_OPERATION_TIMEDOUT; + else if(!timeout_ms) + timeout_ms = CURL_TIMEOUT_RESOLVE_MS; + +#ifdef USE_UNIX_SOCKETS + if(peer->unix_socket) + return resolv_unix(data, peer->hostname, (bool)peer->abstract_uds, pdns); +#else + if(peer->unix_socket) + return hostip_resolv_failed(data, peer->hostname, for_proxy); +#endif + +#ifdef USE_ALARM_TIMEOUT + if(timeout_ms && data->set.no_signal) { + /* Cannot use ALARM when signals are disabled */ + timeout_ms = 0; + } + if(timeout_ms && !Curl_doh_wanted(data)) { + return resolv_alarm_timeout(data, dns_queries, peer->hostname, peer->port, + transport, for_proxy, timeout_ms, presolv_id, + pdns); + } +#endif /* !USE_ALARM_TIMEOUT */ + +#ifndef CURLRES_ASYNCH + if(timeout_ms) + infof(data, "timeout on name lookup is not supported"); +#endif + + return hostip_resolv(data, dns_queries, peer->hostname, peer->port, + transport, for_proxy, timeout_ms, TRUE, presolv_id, + pdns); +} + +#ifdef USE_CURL_ASYNC + +struct Curl_resolv_async *Curl_async_get(struct Curl_easy *data, + uint32_t resolv_id) +{ + struct Curl_resolv_async *async = data->state.async; + for(; async; async = async->next) { + if(async->id == resolv_id) + return async; + } + return NULL; +} + +CURLcode Curl_resolv_take_result(struct Curl_easy *data, uint32_t resolv_id, + struct Curl_dns_entry **pdns) +{ + struct Curl_resolv_async *async = Curl_async_get(data, resolv_id); + CURLcode result; + + /* If async resolving is ongoing, this must be set */ + if(!async) + return CURLE_FAILED_INIT; + + /* check if we have the name resolved by now (from someone else) */ + result = Curl_dnscache_get(data, async->dns_queries, + async->hostname, async->port, pdns); + if(*pdns) { + /* Tell a possibly async resolver we no longer need the results. */ + infof(data, "Hostname '%s' was found in DNS cache", async->hostname); + Curl_async_shutdown(data, async); + return CURLE_OK; + } + else if(result) { + Curl_async_shutdown(data, async); + return Curl_async_failed(data, async, NULL); + } + + result = hostip_resolv_take_result(data, async, pdns); + + if(*pdns) { + /* Add to cache */ + result = Curl_dnscache_add(data, *pdns); + if(result) + Curl_dns_entry_unlink(data, pdns); + } + else if(IS_RESOLV_FAIL(result)) { + Curl_dnscache_add_negative(data, async->dns_queries, + async->hostname, async->port); + failf(data, "Could not resolve: %s:%u", async->hostname, async->port); + } + else if(result) { + failf(data, "Error %d resolving %s:%u", + (int)result, async->hostname, async->port); + } + return result; +} + +CURLcode Curl_resolv_pollset(struct Curl_easy *data, + struct easy_pollset *ps) +{ + struct Curl_resolv_async *async = data->state.async; + CURLcode result = CURLE_OK; + + (void)ps; + for(; async && !result; async = async->next) { +#ifndef CURL_DISABLE_DOH + if(async->doh) /* DoH has nothing for the pollset */ + continue; +#endif + result = Curl_async_pollset(data, async, ps); + } + return result; +} + +void Curl_resolv_destroy(struct Curl_easy *data, uint32_t resolv_id) +{ + struct Curl_resolv_async **panchor = &data->state.async; + + for(; *panchor; panchor = &(*panchor)->next) { + struct Curl_resolv_async *async = *panchor; + if(async->id == resolv_id) { + *panchor = async->next; + Curl_async_destroy(data, async); + break; + } + } +} + +void Curl_resolv_shutdown_all(struct Curl_easy *data) +{ + struct Curl_resolv_async *async = data->state.async; + for(; async; async = async->next) { + Curl_async_shutdown(data, async); + } +} + +void Curl_resolv_destroy_all(struct Curl_easy *data) +{ + while(data->state.async) { + struct Curl_resolv_async *async = data->state.async; + data->state.async = async->next; + Curl_async_destroy(data, async); + } +} + +#endif /* USE_CURL_ASYNC */ diff --git a/3rdparty/curl-8.21.0/lib/hostip.h b/3rdparty/curl-8.21.0/lib/hostip.h new file mode 100644 index 0000000000..45370ec48e --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/hostip.h @@ -0,0 +1,187 @@ +#ifndef HEADER_CURL_HOSTIP_H +#define HEADER_CURL_HOSTIP_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "hash.h" +#include "curlx/timeval.h" /* for curltime, timediff_t */ + +/* Allocate enough memory to hold the full name information structs and + * everything. OSF1 is known to require at least 8872 bytes. The buffer + * required for storing all possible aliases and IP numbers is according to + * Stevens' Unix Network Programming 2nd edition, p. 304: 8192 bytes! + */ +#define CURL_HOSTENT_SIZE 9000 + +#define CURL_TIMEOUT_RESOLVE_MS (300 * 1000) + +struct addrinfo; +struct hostent; +struct Curl_easy; +struct connectdata; +struct easy_pollset; +struct Curl_https_rrinfo; +struct Curl_multi; +struct Curl_dns_entry; +struct Curl_peer; + +/* DNS query types */ +#define CURL_DNSQ_A (1U << 0) +#define CURL_DNSQ_AAAA (1U << 1) +#define CURL_DNSQ_HTTPS (1U << 2) + +#define CURL_DNSQ_ALL (CURL_DNSQ_A | CURL_DNSQ_AAAA | CURL_DNSQ_HTTPS) +#define CURL_DNSQ_IP(x) (uint8_t)((x)&(CURL_DNSQ_A | CURL_DNSQ_AAAA)) + +#ifdef CURLVERBOSE +const char *Curl_resolv_query_str(uint8_t dns_queries); +#endif + +/* Return CURL_DNSQ_* bits for the transfer and ip_version. */ +uint8_t Curl_resolv_dns_queries(struct Curl_easy *data, uint8_t ip_version); + +enum alpnid { + ALPN_none = 0, + ALPN_h1 = CURLALTSVC_H1, + ALPN_h2 = CURLALTSVC_H2, + ALPN_h3 = CURLALTSVC_H3 +}; + +bool Curl_host_is_ipnum(const char *hostname); + +#ifdef USE_IPV6 +/* probe if it seems to work */ +CURLcode Curl_probeipv6(struct Curl_multi *multi); +#else +#define Curl_probeipv6(x) CURLE_OK +#endif + +/* IPv4 thread-safe resolve function used for synch and asynch builds */ +struct Curl_addrinfo *Curl_ipv4_resolve_r(const char *hostname, uint16_t port); + +/* + * Curl_printable_address() returns a printable version of the 1st address + * given in the 'ai' argument. The result will be stored in the buf that is + * bufsize bytes big. + */ +void Curl_printable_address(const struct Curl_addrinfo *ai, + char *buf, size_t bufsize); + +/* Start DNS resolving for the given parameters. Returns + * - CURLE_OK: `*pdns` is the resolved DNS entry (needs to be unlinked). + * `*presolv_id` is 0. + * - CURLE_AGAIN: resolve is asynchronous and not finished yet. + * `presolv_id` is the identifier for querying results later. + * - other: the operation failed, `*pdns` is NULL, `*presolv_id` is 0. + */ +CURLcode Curl_resolv(struct Curl_easy *data, + struct Curl_peer *peer, + uint8_t dns_queries, + uint8_t transport, + bool for_proxy, + timediff_t timeout_ms, + uint32_t *presolv_id, + struct Curl_dns_entry **pdns); + +CURLcode Curl_resolv_blocking(struct Curl_easy *data, + uint8_t dns_queries, + const char *hostname, + uint16_t port, + uint8_t transport, + struct Curl_dns_entry **pdns); + +/* Announce start of a resolve operation to application callback, + * passing the resolver implementation (maybe NULL). */ +CURLcode Curl_resolv_announce_start(struct Curl_easy *data, + void *resolver); + +#ifdef USE_CURL_ASYNC + +CURLcode Curl_resolv_pollset(struct Curl_easy *data, + struct easy_pollset *ps); + +/* Get the `async` struct for the given `resolv_id`, if it exists. */ +struct Curl_resolv_async *Curl_async_get(struct Curl_easy *data, + uint32_t resolv_id); + +/* Shut down all resolves of the given easy handle. */ +void Curl_resolv_shutdown_all(struct Curl_easy *data); + +/* Destroy all resolve resources of the given easy handle. */ +void Curl_resolv_destroy_all(struct Curl_easy *data); + +CURLcode Curl_resolv_take_result(struct Curl_easy *data, uint32_t resolv_id, + struct Curl_dns_entry **pdns); + +void Curl_resolv_destroy(struct Curl_easy *data, uint32_t resolv_id); + +/* How much time has gone by since start of resolve. + * Returns CURL_TIMEOUT_RESOLVE_MS if `resolv_id` is no longer valid. */ +timediff_t Curl_resolv_elapsed_ms(struct Curl_easy *data, + uint32_t resolv_id); + +/* Return TRUE if `resolv_id` has answers (positive or negative) to + * all queries in `dns_queries`. + * Queries not requested are considered answered. */ +bool Curl_resolv_has_answers(struct Curl_easy *data, + uint32_t resolv_id, uint8_t dns_queries); + +const struct Curl_addrinfo *Curl_resolv_get_ai(struct Curl_easy *data, + uint32_t resolv_id, + int ai_family, + unsigned int index); +#ifdef USE_HTTPSRR +const struct Curl_https_rrinfo *Curl_resolv_get_https(struct Curl_easy *data, + uint32_t resolv_id); +bool Curl_resolv_knows_https(struct Curl_easy *data, uint32_t resolv_id); +#endif /* USE_HTTPSRR */ + +#else /* !USE_CURL_ASYNC */ +#define Curl_resolv_shutdown_all(x) Curl_nop_stmt +#define Curl_resolv_destroy_all(x) Curl_nop_stmt +#define Curl_resolv_take_result(x, y, z) CURLE_NOT_BUILT_IN +#define Curl_resolv_elapsed_ms(x, y) CURL_TIMEOUT_RESOLVE_MS +#define Curl_resolv_has_answers(x, y, z) TRUE +#define Curl_resolv_get_ai(x, y, z, a) NULL +#define Curl_resolv_get_https(x, y) NULL +#define Curl_resolv_knows_https(x, y) TRUE +#define Curl_resolv_pollset(x, y) CURLE_OK +#define Curl_resolv_destroy(x, y) Curl_nop_stmt +#endif /* USE_CURL_ASYNC */ + +#ifdef CURLRES_SYNCH +/* + * Curl_sync_getaddrinfo() is the non-async low-level name resolve API. + * There are several versions of this function - depending on IPV6 + * support and platform. + */ +struct Curl_addrinfo *Curl_sync_getaddrinfo(struct Curl_easy *data, + uint8_t dns_queries, + const char *hostname, + uint16_t port, + uint8_t transport); +#endif + +#endif /* HEADER_CURL_HOSTIP_H */ diff --git a/3rdparty/curl-8.21.0/lib/hostip4.c b/3rdparty/curl-8.21.0/lib/hostip4.c new file mode 100644 index 0000000000..c8cc4dc340 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/hostip4.c @@ -0,0 +1,283 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +/*********************************************************************** + * Only for plain IPv4 builds + **********************************************************************/ +#ifdef CURLRES_IPV4 /* plain IPv4 code coming up */ + +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETDB_H +#include +#endif +#ifdef HAVE_ARPA_INET_H +#include +#endif +#ifdef __VMS +#include +#include +#endif + +#include "urldata.h" +#include "curl_addrinfo.h" +#include "curl_trc.h" +#include "hostip.h" +#include "url.h" + + +#ifdef CURLRES_SYNCH + +/* + * Curl_sync_getaddrinfo() - the IPv4 synchronous version. + * + * The original code to this function was from the Dancer source code, written + * by Bjorn Reese, it has since been patched and modified considerably. + * + * gethostbyname_r() is the thread-safe version of the gethostbyname() + * function. When we build for plain IPv4, we attempt to use this + * function. There are _three_ different gethostbyname_r() versions, and we + * detect which one this platform supports in the configure script and set up + * the HAVE_GETHOSTBYNAME_R_3, HAVE_GETHOSTBYNAME_R_5 or + * HAVE_GETHOSTBYNAME_R_6 defines accordingly. Note that HAVE_GETADDRBYNAME + * has the corresponding rules. This is primarily on *nix. Note that some Unix + * flavors have thread-safe versions of the plain gethostbyname() etc. + * + */ +struct Curl_addrinfo *Curl_sync_getaddrinfo(struct Curl_easy *data, + uint8_t dns_queries, + const char *hostname, + uint16_t port, + uint8_t transport) +{ + struct Curl_addrinfo *ai = NULL; + + (void)dns_queries; + (void)transport; + + ai = Curl_ipv4_resolve_r(hostname, port); + if(!ai) + infof(data, "Curl_ipv4_resolve_r failed for %s", hostname); + + return ai; +} +#endif /* CURLRES_SYNCH */ +#endif /* CURLRES_IPV4 */ + +#if defined(CURLRES_IPV4) && !defined(USE_RESOLV_ARES) && \ + !defined(CURLRES_AMIGA) + +/* + * Curl_ipv4_resolve_r() - ipv4 thread-safe resolver function. + * + * This is used for both synchronous and asynchronous resolver builds, + * implying that only thread-safe code and function calls may be used. + * + */ +struct Curl_addrinfo *Curl_ipv4_resolve_r(const char *hostname, + uint16_t port) +{ +#if !(defined(HAVE_GETADDRINFO) && defined(HAVE_GETADDRINFO_THREADSAFE)) && \ + defined(HAVE_GETHOSTBYNAME_R_3) + int res; +#endif + struct Curl_addrinfo *ai = NULL; +#if !(defined(HAVE_GETADDRINFO) && defined(HAVE_GETADDRINFO_THREADSAFE)) + struct hostent *h = NULL; + struct hostent *buf = NULL; +#endif + +#if defined(HAVE_GETADDRINFO) && defined(HAVE_GETADDRINFO_THREADSAFE) + struct addrinfo hints; + char sbuf[12]; + char *sbufptr = NULL; + + memset(&hints, 0, sizeof(hints)); + hints.ai_family = PF_INET; + hints.ai_socktype = SOCK_STREAM; + if(port) { + curl_msnprintf(sbuf, sizeof(sbuf), "%d", port); + sbufptr = sbuf; + } + + (void)Curl_getaddrinfo_ex(hostname, sbufptr, &hints, &ai); + +#elif defined(HAVE_GETHOSTBYNAME_R) + /* + * gethostbyname_r() is the preferred resolve function for many platforms. + * Since there are three different versions of it, the following code is + * somewhat #ifdef-ridden. + */ + int h_errnop; + + buf = curlx_calloc(1, CURL_HOSTENT_SIZE); + if(!buf) + return NULL; /* major failure */ + /* + * The clearing of the buffer is a workaround for a gethostbyname_r bug in + * QNX Neutrino and it is also _required_ for some of these functions on some + * platforms. + */ + +#ifdef HAVE_GETHOSTBYNAME_R_5 + /* Solaris, IRIX and more */ + h = gethostbyname_r(hostname, + (struct hostent *)buf, + (char *)buf + sizeof(struct hostent), + CURL_HOSTENT_SIZE - sizeof(struct hostent), + &h_errnop); + + /* If the buffer is too small, it returns NULL and sets errno to + * ERANGE. The errno is thread-safe if this is compiled with + * -D_REENTRANT as then the 'errno' variable is a macro defined to get + * used properly for threads. + */ + + if(h) { + ; + } + else +#elif defined(HAVE_GETHOSTBYNAME_R_6) + /* Linux */ + + (void)gethostbyname_r(hostname, + (struct hostent *)buf, + (char *)buf + sizeof(struct hostent), + CURL_HOSTENT_SIZE - sizeof(struct hostent), + &h, /* DIFFERENCE */ + &h_errnop); + /* Redhat 8, using glibc 2.2.93 changed the behavior. Now all of a + * sudden this function returns EAGAIN if the given buffer size is too + * small. Previous versions are known to return ERANGE for the same + * problem. + * + * This would not be such a big problem if older versions would not + * sometimes return EAGAIN on a common failure case. Alas, we cannot + * assume that EAGAIN *or* ERANGE means ERANGE for any given version of + * glibc. + * + * For now, we do that and thus we may call the function repeatedly and + * fail for older glibc versions that return EAGAIN, until we run out of + * buffer size (step_size grows beyond CURL_HOSTENT_SIZE). + * + * If anyone has a better fix, please tell us! + * + * ------------------------------------------------------------------- + * + * On October 23rd 2003, Dan C dug up more details on the mysteries of + * gethostbyname_r() in glibc: + * + * In glibc 2.2.5 the interface is different (this has also been + * discovered in glibc 2.1.1-6 as shipped by Redhat 6). What I cannot + * explain, is that tests performed on glibc 2.2.4-34 and 2.2.4-32 + * (shipped/upgraded by Redhat 7.2) do not show this behavior! + * + * In this "buggy" version, the return code is -1 on error and 'errno' + * is set to the ERANGE or EAGAIN code. Note that 'errno' is not a + * thread-safe variable. + */ + + if(!h) /* failure */ +#elif defined(HAVE_GETHOSTBYNAME_R_3) + /* AIX, Digital UNIX/Tru64, HP-UX 10, more? */ + + /* For AIX 4.3 or later, we do not use gethostbyname_r() at all, because of + * the plain fact that it does not return unique full buffers on each + * call, but instead several of the pointers in the hostent structs will + * point to the same actual data! This have the unfortunate down-side that + * our caching system breaks down horribly. Luckily for us though, AIX 4.3 + * and more recent versions have a "completely thread-safe"[*] libc where + * all the data is stored in thread-specific memory areas making calls to + * the plain old gethostbyname() work fine even for multi-threaded + * programs. + * + * This AIX 4.3 or later detection is all made in the configure script. + * + * Troels Walsted Hansen helped us work this out on March 3rd, 2003. + * + * [*] = much later we have found out that it is not at all "completely + * thread-safe", but at least the gethostbyname() function is. + */ + + if(CURL_HOSTENT_SIZE >= + (sizeof(struct hostent) + sizeof(struct hostent_data))) { + + /* August 22nd, 2000: Albert Chin-A-Young brought an updated version + * that should work! September 20: Richard Prescott worked on the buffer + * size dilemma. + */ + + res = gethostbyname_r(hostname, + (struct hostent *)buf, + (struct hostent_data *)((char *)buf + + sizeof(struct hostent))); + h_errnop = SOCKERRNO; /* we do not deal with this, but set it anyway */ + } + else + res = -1; /* failure, too smallish buffer size */ + + if(!res) { /* success */ + + h = buf; /* result expected in h */ + + /* This is the worst kind of the different gethostbyname_r() interfaces. + * Since we do not know how big buffer this particular lookup required, + * we cannot realloc down the huge alloc without doing closer analysis of + * the returned data. Thus, we always use CURL_HOSTENT_SIZE for every + * name lookup. Fixing this would require an extra allocation and then + * calling Curl_addrinfo_copy() that subsequent reallocation down the new + * memory area to the actually used amount. + */ + } + else +#endif /* HAVE_...BYNAME_R_5 || HAVE_...BYNAME_R_6 || HAVE_...BYNAME_R_3 */ + { + h = NULL; /* set return code to NULL */ + curlx_free(buf); + } +#else /* (HAVE_GETADDRINFO && HAVE_GETADDRINFO_THREADSAFE) || + HAVE_GETHOSTBYNAME_R */ + /* + * Here is code for platforms that do not have a thread-safe + * getaddrinfo() nor gethostbyname_r() function or for which + * gethostbyname() is the preferred one. + */ + h = gethostbyname(CURL_UNCONST(hostname)); +#endif /* (HAVE_GETADDRINFO && HAVE_GETADDRINFO_THREADSAFE) || + HAVE_GETHOSTBYNAME_R */ + +#if !(defined(HAVE_GETADDRINFO) && defined(HAVE_GETADDRINFO_THREADSAFE)) + if(h) { + ai = Curl_he2ai(h, port); + + if(buf) /* used a *_r() function */ + curlx_free(buf); + } +#endif + + return ai; +} +#endif /* CURLRES_IPV4 && !USE_RESOLV_ARES && !CURLRES_AMIGA */ diff --git a/3rdparty/curl-8.21.0/lib/hostip6.c b/3rdparty/curl-8.21.0/lib/hostip6.c new file mode 100644 index 0000000000..7412f428a4 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/hostip6.c @@ -0,0 +1,120 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +/*********************************************************************** + * Only for IPv6-enabled builds + **********************************************************************/ +#ifdef CURLRES_IPV6 + +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETDB_H +#include +#endif +#ifdef HAVE_ARPA_INET_H +#include +#endif +#ifdef __VMS +#include +#include +#endif + +#include "urldata.h" +#include "cfilters.h" +#include "curl_addrinfo.h" +#include "curl_trc.h" +#include "hostip.h" +#include "url.h" +#include "curlx/inet_pton.h" +#include "connect.h" + +#ifdef CURLRES_SYNCH + +/* + * Curl_sync_getaddrinfo() when built IPv6-enabled (non-threading and + * non-ares version). + * + * Returns name information about the given hostname and port number. If + * successful, the 'addrinfo' is returned and the fourth argument will point + * to memory we need to free after use. That memory *MUST* be freed with + * Curl_freeaddrinfo(), nothing else. + */ +struct Curl_addrinfo *Curl_sync_getaddrinfo(struct Curl_easy *data, + uint8_t dns_queries, + const char *hostname, + uint16_t port, + uint8_t transport) +{ + struct addrinfo hints; + struct Curl_addrinfo *res; + int error; + char sbuf[12]; + char *sbufptr = NULL; +#ifndef USE_RESOLVE_ON_IPS + char addrbuf[128]; +#endif + int pf = PF_INET; + + if(dns_queries & CURL_DNSQ_AAAA) + pf = PF_UNSPEC; + + memset(&hints, 0, sizeof(hints)); + hints.ai_family = pf; + hints.ai_socktype = (transport == TRNSPRT_TCP) ? + SOCK_STREAM : SOCK_DGRAM; + +#ifndef USE_RESOLVE_ON_IPS + /* + * The AI_NUMERICHOST must not be set to get synthesized IPv6 address from + * an IPv4 address on iOS and macOS. + */ + if((curlx_inet_pton(AF_INET, hostname, addrbuf) == 1) || + (curlx_inet_pton(AF_INET6, hostname, addrbuf) == 1)) { + /* the given address is numerical only, prevent a reverse lookup */ + hints.ai_flags = AI_NUMERICHOST; + } +#endif + + if(port) { + curl_msnprintf(sbuf, sizeof(sbuf), "%d", port); + sbufptr = sbuf; + } + + error = Curl_getaddrinfo_ex(hostname, sbufptr, &hints, &res); + if(error) { + infof(data, "getaddrinfo(3) failed for %s:%d", hostname, port); + return NULL; + } + + if(port) { + Curl_addrinfo_set_port(res, port); + } + + return res; +} +#endif /* CURLRES_SYNCH */ + +#endif /* CURLRES_IPV6 */ diff --git a/3rdparty/curl-8.21.0/lib/hsts.c b/3rdparty/curl-8.21.0/lib/hsts.c new file mode 100644 index 0000000000..b8745a5195 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/hsts.c @@ -0,0 +1,646 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +/* + * The Strict-Transport-Security header is defined in RFC 6797: + * https://datatracker.ietf.org/doc/html/rfc6797 + */ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_HTTP) && !defined(CURL_DISABLE_HSTS) +#include "urldata.h" +#include "llist.h" +#include "hsts.h" +#include "curl_fopen.h" +#include "curl_get_line.h" +#include "parsedate.h" +#include "curl_share.h" +#include "curlx/strparse.h" +#include "curlx/strcopy.h" + +#define MAX_HSTS_LINE 4095 +#define MAX_HSTS_HOSTLEN 2048 +#define MAX_HSTS_DATELEN 17 +#define UNLIMITED "unlimited" + +#if defined(DEBUGBUILD) || defined(UNITTESTS) +/* to play well with debug builds, we can *set* a fixed time this will + return */ +time_t deltatime; /* allow for "adjustments" for unit test purposes */ +static time_t hsts_debugtime(void *unused) +{ + const char *timestr = getenv("CURL_TIME"); + (void)unused; + if(timestr) { + curl_off_t val; + if(!curlx_str_number(×tr, &val, TIME_T_MAX)) + val += (curl_off_t)deltatime; + return (time_t)val; + } + return time(NULL); +} +#undef time +#define time(x) hsts_debugtime(x) +#endif + +struct hsts *Curl_hsts_init(void) +{ + struct hsts *h = curlx_calloc(1, sizeof(struct hsts)); + if(h) { + Curl_llist_init(&h->list, NULL); + } + return h; +} + +#define hsts_free(x) curlx_free(x) + +void Curl_hsts_cleanup(struct hsts **hp) +{ + struct hsts *h = *hp; + if(h) { + struct Curl_llist_node *e; + struct Curl_llist_node *n; + for(e = Curl_llist_head(&h->list); e; e = n) { + struct stsentry *sts = Curl_node_elem(e); + n = Curl_node_next(e); + hsts_free(sts); + } + curlx_free(h->filename); + curlx_free(h); + *hp = NULL; + } +} + +/* append the new entry to the list after possibly removing an old entry + first */ +static void hsts_append(struct hsts *h, struct stsentry *sts) +{ + if(Curl_llist_count(&h->list) == MAX_HSTS_ENTRIES) { + /* It is full. Remove the first entry in the list */ + struct Curl_llist_node *e = Curl_llist_head(&h->list); + struct stsentry *oldsts = Curl_node_elem(e); + Curl_node_remove(e); + hsts_free(oldsts); + } + Curl_llist_append(&h->list, sts, &sts->node); +} + +static CURLcode hsts_create(struct hsts *h, + const char *hostname, + size_t hlen, + bool subdomains, + curl_off_t expires) +{ + DEBUGASSERT(h); + DEBUGASSERT(hostname); + + if(hlen && (hostname[hlen - 1] == '.')) + /* strip off any trailing dot */ + --hlen; + if(hlen) { + struct stsentry *sts = curlx_calloc(1, sizeof(struct stsentry) + hlen); + if(!sts) + return CURLE_OUT_OF_MEMORY; + /* the null-terminator is already there */ + memcpy(sts->host, hostname, hlen); + sts->expires = expires; + sts->includeSubDomains = subdomains; + hsts_append(h, sts); + } + return CURLE_OK; +} + +/* Copy all live entries from src into dst. Used by curl_easy_duphandle so the + * clone inherits entries learned at runtime. E.g. Strict-Transport-Security. + */ +CURLcode Curl_hsts_copy(struct hsts *dst, struct hsts *src) +{ + struct Curl_llist_node *e; + time_t now = time(NULL); + for(e = Curl_llist_head(&src->list); e; e = Curl_node_next(e)) { + struct stsentry *sts = Curl_node_elem(e); + if(sts->expires > now) { + CURLcode result = hsts_create(dst, sts->host, strlen(sts->host), + sts->includeSubDomains != 0, sts->expires); + if(result) + return result; + } + } + return CURLE_OK; +} + +/* + * Return the matching HSTS entry, or NULL if the given hostname is not + * currently an HSTS one. + * + * The 'subdomain' argument tells the function if subdomain matching should be + * attempted. + * + * @unittest 1660 + */ +UNITTEST struct stsentry *hsts_check(struct hsts *h, const char *hostname, + size_t hlen, bool subdomain); +UNITTEST struct stsentry *hsts_check(struct hsts *h, const char *hostname, + size_t hlen, bool subdomain) +{ + struct stsentry *bestsub = NULL; + if(h) { + time_t now = time(NULL); + struct Curl_llist_node *e; + struct Curl_llist_node *n; + size_t blen = 0; + + if((hlen > MAX_HSTS_HOSTLEN) || !hlen) + return NULL; + if(hostname[hlen - 1] == '.') + /* remove the trailing dot */ + --hlen; + + for(e = Curl_llist_head(&h->list); e; e = n) { + struct stsentry *sts = Curl_node_elem(e); + size_t ntail; + n = Curl_node_next(e); + if(sts->expires <= now) { + /* remove expired entries */ + Curl_node_remove(&sts->node); + hsts_free(sts); + continue; + } + ntail = strlen(sts->host); + if((subdomain && sts->includeSubDomains) && (ntail < hlen)) { + size_t offs = hlen - ntail; + if((hostname[offs - 1] == '.') && + curl_strnequal(&hostname[offs], sts->host, ntail) && + (ntail > blen)) { + /* save the tail match with the longest tail */ + bestsub = sts; + blen = ntail; + } + } + /* avoid curl_strequal because the hostname is not null-terminated */ + if((hlen == ntail) && curl_strnequal(hostname, sts->host, hlen)) + return sts; + } + } + return bestsub; +} + +CURLcode Curl_hsts_parse(struct hsts *h, const char *hostname, + const char *header) +{ + const char *p = header; + curl_off_t expires = 0; + bool gotma = FALSE; + bool gotinc = FALSE; + bool subdomains = FALSE; + struct stsentry *sts; + time_t now = time(NULL); + size_t hlen = strlen(hostname); + + if(Curl_host_is_ipnum(hostname)) + /* "explicit IP address identification of all forms is excluded." + / RFC 6797 */ + return CURLE_OK; + + do { + curlx_str_passblanks(&p); + if(curl_strnequal("max-age", p, 7)) { + bool quoted = FALSE; + int rc; + + if(gotma) + return CURLE_BAD_FUNCTION_ARGUMENT; + + p += 7; + curlx_str_passblanks(&p); + if(curlx_str_single(&p, '=')) + return CURLE_BAD_FUNCTION_ARGUMENT; + curlx_str_passblanks(&p); + + if(!curlx_str_single(&p, '\"')) + quoted = TRUE; + + rc = curlx_str_number(&p, &expires, TIME_T_MAX); + if(rc == STRE_OVERFLOW) + expires = CURL_OFF_T_MAX; + else if(rc) + /* invalid max-age */ + return CURLE_BAD_FUNCTION_ARGUMENT; + + if(quoted) { + if(*p != '\"') + return CURLE_BAD_FUNCTION_ARGUMENT; + p++; + } + gotma = TRUE; + } + else if(curl_strnequal("includesubdomains", p, 17)) { + if(gotinc) + return CURLE_BAD_FUNCTION_ARGUMENT; + subdomains = TRUE; + p += 17; + gotinc = TRUE; + } + else { + /* unknown directive, do a lame attempt to skip */ + while(*p && (*p != ';')) + p++; + } + + curlx_str_passblanks(&p); + if(*p == ';') + p++; + } while(*p); + + if(!gotma) + /* max-age is mandatory */ + return CURLE_BAD_FUNCTION_ARGUMENT; + + if(!expires) { + /* remove the entry if present verbatim (without subdomain match) */ + sts = hsts_check(h, hostname, hlen, FALSE); + if(sts) { + Curl_node_remove(&sts->node); + hsts_free(sts); + } + return CURLE_OK; + } + + if(CURL_OFF_T_MAX - now < expires) + /* would overflow, use maximum value */ + expires = CURL_OFF_T_MAX; + else + expires += now; + + /* check if it already exists */ + sts = hsts_check(h, hostname, hlen, FALSE); + if(sts) { + /* update these fields */ + sts->expires = expires; + sts->includeSubDomains = subdomains; + } + else + return hsts_create(h, hostname, hlen, subdomains, expires); + + return CURLE_OK; +} + +/* + * Send this HSTS entry to the write callback. + */ +static CURLcode hsts_push(struct Curl_easy *data, + struct curl_index *i, + struct stsentry *sts, + bool *stop) +{ + struct curl_hstsentry e; + CURLSTScode sc; + struct tm stamp; + CURLcode result; + + e.name = (char *)sts->host; + e.namelen = strlen(sts->host); + e.includeSubDomains = sts->includeSubDomains; + + if(sts->expires != TIME_T_MAX) { + result = curlx_gmtime((time_t)sts->expires, &stamp); + if(result) + return result; + + curl_msnprintf(e.expire, sizeof(e.expire), "%d%02d%02d %02d:%02d:%02d", + stamp.tm_year + 1900, stamp.tm_mon + 1, stamp.tm_mday, + stamp.tm_hour, stamp.tm_min, stamp.tm_sec); + } + else + curlx_strcopy(e.expire, sizeof(e.expire), STRCONST(UNLIMITED)); + + sc = data->set.hsts_write(data, &e, i, data->set.hsts_write_userp); + *stop = (sc != CURLSTS_OK); + return sc == CURLSTS_FAIL ? CURLE_BAD_FUNCTION_ARGUMENT : CURLE_OK; +} + +/* + * Write this single hsts entry to a single output line + */ +static CURLcode hsts_out(struct stsentry *sts, FILE *fp) +{ + struct tm stamp; + if(sts->expires != TIME_T_MAX) { + CURLcode result = curlx_gmtime((time_t)sts->expires, &stamp); + if(result) + return result; + curl_mfprintf(fp, "%s%s \"%d%02d%02d %02d:%02d:%02d\"\n", + sts->includeSubDomains ? "." : "", sts->host, + stamp.tm_year + 1900, stamp.tm_mon + 1, stamp.tm_mday, + stamp.tm_hour, stamp.tm_min, stamp.tm_sec); + } + else + curl_mfprintf(fp, "%s%s \"%s\"\n", + sts->includeSubDomains ? "." : "", sts->host, UNLIMITED); + return CURLE_OK; +} + +/* + * Curl_https_save() writes the HSTS cache to file and callback. + */ +CURLcode Curl_hsts_save(struct Curl_easy *data, struct hsts *h, + const char *file) +{ + struct Curl_llist_node *e; + struct Curl_llist_node *n; + CURLcode result = CURLE_OK; + FILE *out; + char *tempstore = NULL; + + if(!h) + /* no cache activated */ + return CURLE_OK; + + /* if no new name is given, use the one we stored from the load */ + if(!file && h->filename) + file = h->filename; + + if((h->flags & CURLHSTS_READONLYFILE) || !file || !file[0]) + /* marked as read-only, no file or zero length filename */ + goto skipsave; + + result = Curl_fopen(data, file, &out, &tempstore); + if(!result) { + fputs("# Your HSTS cache. https://curl.se/docs/hsts.html\n" + "# This file was generated by libcurl! Edit at your own risk.\n", + out); + for(e = Curl_llist_head(&h->list); e; e = n) { + struct stsentry *sts = Curl_node_elem(e); + n = Curl_node_next(e); + result = hsts_out(sts, out); + if(result) + break; + } + curlx_fclose(out); + if(!result && tempstore && curlx_rename(tempstore, file)) + result = CURLE_WRITE_ERROR; + + if(result && tempstore) + unlink(tempstore); + } + curlx_free(tempstore); +skipsave: + if(data->set.hsts_write) { + /* if there is a write callback */ + struct curl_index i; /* count */ + i.total = Curl_llist_count(&h->list); + i.index = 0; + for(e = Curl_llist_head(&h->list); e; e = n) { + struct stsentry *sts = Curl_node_elem(e); + bool stop; + n = Curl_node_next(e); + result = hsts_push(data, &i, sts, &stop); + if(result || stop) + break; + i.index++; + } + } + return result; +} + +/* only returns SERIOUS errors */ +static CURLcode hsts_add_host_expire(struct hsts *h, + const char *host, size_t hostlen, + const char *expire, size_t explen, + bool subdomain) /* default */ +{ + CURLcode result = CURLE_OK; + struct stsentry *e; + char dbuf[MAX_HSTS_DATELEN + 1]; + time_t expires = 0; + time_t now = time(NULL); + + /* The date parser works on a null-terminated string. */ + if(explen > MAX_HSTS_DATELEN) + return CURLE_BAD_FUNCTION_ARGUMENT; + memcpy(dbuf, expire, explen); + dbuf[explen] = 0; + + if(!strcmp(dbuf, UNLIMITED)) + expires = TIME_T_MAX; + else + Curl_getdate_capped(dbuf, &expires); + + if(expires <= now) + /* this entry already expired */ + return CURLE_OK; + + if(host[0] == '.') { + host++; + hostlen--; + subdomain = TRUE; + } + if(hostlen && (host[hostlen - 1] == '.')) + /* strip off any trailing dot */ + hostlen--; + + if(hostlen) { + /* only add it if not already present */ + e = hsts_check(h, host, hostlen, subdomain); + if(!e) + result = hsts_create(h, host, hostlen, subdomain, expires); + /* 'host' is not necessarily null-terminated */ + else if((hostlen == strlen(e->host) && + curl_strnequal(host, e->host, hostlen))) { + /* the same hostname, use the largest expire time and keep the strictest + subdomain policy */ + if(expires > e->expires) + e->expires = expires; + if(subdomain) + e->includeSubDomains = TRUE; + } + } + return result; +} + +/* only returns SERIOUS errors */ +static CURLcode hsts_add(struct hsts *h, const char *line) +{ + /* Example lines: + example.com "20191231 10:00:00" + .example.net "20191231 10:00:00" + */ + struct Curl_str host; + struct Curl_str date; + + if(curlx_str_word(&line, &host, MAX_HSTS_HOSTLEN) || + curlx_str_singlespace(&line) || + curlx_str_quotedword(&line, &date, MAX_HSTS_DATELEN) || + curlx_str_newline(&line)) + ; + else { + return hsts_add_host_expire(h, curlx_str(&host), curlx_strlen(&host), + curlx_str(&date), curlx_strlen(&date), + FALSE); + } + + return CURLE_OK; +} + +/* + * Load HSTS data from callback. + * + */ +static CURLcode hsts_pull(struct Curl_easy *data, struct hsts *h) +{ + /* if the HSTS read callback is set, use it */ + if(data->set.hsts_read) { + CURLSTScode sc; + DEBUGASSERT(h); + do { + char buffer[MAX_HSTS_HOSTLEN + 1]; + struct curl_hstsentry e; + e.name = buffer; + e.namelen = sizeof(buffer) - 1; + e.includeSubDomains = FALSE; /* default */ + e.expire[0] = 0; + e.expire[MAX_HSTS_DATELEN] = 0; + e.name[0] = 0; /* to make it clean */ + e.name[MAX_HSTS_HOSTLEN] = 0; + sc = data->set.hsts_read(data, &e, data->set.hsts_read_userp); + if(sc == CURLSTS_OK) { + CURLcode result; + const char *date = e.expire; + if(!e.name[0] || e.expire[MAX_HSTS_DATELEN] || + e.name[MAX_HSTS_HOSTLEN]) + /* bail out if no name was stored or if a null-terminator is gone */ + return CURLE_BAD_FUNCTION_ARGUMENT; + if(!date[0]) + date = UNLIMITED; + result = hsts_add_host_expire(h, e.name, strlen(e.name), + date, strlen(date), + /* bitfield to bool conversion: */ + e.includeSubDomains ? TRUE : FALSE); + if(result) + return result; + } + else if(sc == CURLSTS_FAIL) + return CURLE_ABORTED_BY_CALLBACK; + } while(sc == CURLSTS_OK); + } + return CURLE_OK; +} + +/* + * Load the HSTS cache from the given file. The text based line-oriented file + * format is documented here: https://curl.se/docs/hsts.html + * + * This function only returns error on major problems that prevent hsts + * handling to work completely. It will ignore individual syntactical errors + * etc. + */ +static CURLcode hsts_load(struct hsts *h, const char *file) +{ + CURLcode result = CURLE_OK; + FILE *fp; + + /* we need a private copy of the filename so that the hsts cache file + name survives an easy handle reset */ + curlx_free(h->filename); + h->filename = curlx_strdup(file); + if(!h->filename) + return CURLE_OUT_OF_MEMORY; + + fp = curlx_fopen(file, FOPEN_READTEXT); + if(fp) { + curlx_struct_stat stat; + if((curlx_fstat(fileno(fp), &stat) == -1) || !S_ISDIR(stat.st_mode)) { + struct dynbuf buf; + bool eof = FALSE; + curlx_dyn_init(&buf, MAX_HSTS_LINE); + do { + result = Curl_get_line(&buf, fp, &eof); + if(!result) { + const char *lineptr = curlx_dyn_ptr(&buf); + curlx_str_passblanks(&lineptr); + + /* Skip empty or commented lines, since we know the line will have + a trailing newline from Curl_get_line we can treat length 1 as + empty. */ + if((*lineptr == '#') || strlen(lineptr) <= 1) + continue; + + hsts_add(h, lineptr); + } + } while(!result && !eof); + curlx_dyn_free(&buf); /* free the line buffer */ + } + curlx_fclose(fp); + } + return result; +} + +/* + * Curl_hsts_loadfile() loads HSTS from file + */ +CURLcode Curl_hsts_loadfile(struct Curl_easy *data, + struct hsts *h, const char *file) +{ + DEBUGASSERT(h); + (void)data; + return hsts_load(h, file); +} + +/* + * Curl_hsts_loadcb() loads HSTS from callback + */ +CURLcode Curl_hsts_loadcb(struct Curl_easy *data, struct hsts *h) +{ + if(h) + return hsts_pull(data, h); + return CURLE_OK; +} + +CURLcode Curl_hsts_loadfiles(struct Curl_easy *data) +{ + CURLcode result = CURLE_OK; + struct curl_slist *l = data->state.hstslist; + if(l) { + Curl_share_lock(data, CURL_LOCK_DATA_HSTS, CURL_LOCK_ACCESS_SINGLE); + + while(l) { + result = Curl_hsts_loadfile(data, data->hsts, l->data); + if(result) + break; + l = l->next; + } + Curl_share_unlock(data, CURL_LOCK_DATA_HSTS); + } + return result; +} + +bool Curl_hsts_applies(struct hsts *h, const struct Curl_peer *dest) +{ + return !!hsts_check(h, dest->hostname, strlen(dest->hostname), TRUE); +} + +#if defined(DEBUGBUILD) || defined(UNITTESTS) +#undef time +#endif + +#endif /* CURL_DISABLE_HTTP || CURL_DISABLE_HSTS */ diff --git a/3rdparty/curl-8.21.0/lib/hsts.h b/3rdparty/curl-8.21.0/lib/hsts.h new file mode 100644 index 0000000000..08215f5eaa --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/hsts.h @@ -0,0 +1,76 @@ +#ifndef HEADER_CURL_HSTS_H +#define HEADER_CURL_HSTS_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +struct hsts; + +#if !defined(CURL_DISABLE_HTTP) && !defined(CURL_DISABLE_HSTS) +#include "llist.h" + +struct Curl_peer; + +#define MAX_HSTS_ENTRIES 10000 + +#if defined(DEBUGBUILD) || defined(UNITTESTS) +extern time_t deltatime; +#endif + +struct stsentry { + struct Curl_llist_node node; + curl_off_t expires; /* the timestamp of this entry's expiry */ + BIT(includeSubDomains); + char host[1]; +}; + +/* The HSTS cache. Needs to be able to tailmatch hostnames. */ +struct hsts { + struct Curl_llist list; + char *filename; + unsigned int flags; +}; + +struct hsts *Curl_hsts_init(void); +void Curl_hsts_cleanup(struct hsts **hp); +CURLcode Curl_hsts_copy(struct hsts *dst, struct hsts *src); +CURLcode Curl_hsts_parse(struct hsts *h, const char *hostname, + const char *header); +CURLcode Curl_hsts_save(struct Curl_easy *data, struct hsts *h, + const char *file); +CURLcode Curl_hsts_loadfile(struct Curl_easy *data, + struct hsts *h, const char *file); +CURLcode Curl_hsts_loadcb(struct Curl_easy *data, + struct hsts *h); +CURLcode Curl_hsts_loadfiles(struct Curl_easy *data); + +bool Curl_hsts_applies(struct hsts *h, const struct Curl_peer *dest); + +#else +#define Curl_hsts_cleanup(x) +#define Curl_hsts_loadcb(x, y) CURLE_OK +#define Curl_hsts_save(x, y, z) +#define Curl_hsts_loadfiles(x) CURLE_OK +#endif /* CURL_DISABLE_HTTP || CURL_DISABLE_HSTS */ +#endif /* HEADER_CURL_HSTS_H */ diff --git a/3rdparty/curl-8.21.0/lib/http.c b/3rdparty/curl-8.21.0/lib/http.c new file mode 100644 index 0000000000..83d0e01152 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/http.c @@ -0,0 +1,5055 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" +#include "urldata.h" + +#ifndef CURL_DISABLE_HTTP + +#ifdef HAVE_NETINET_IN_H +#include +#endif + +#ifdef HAVE_NETDB_H +#include +#endif +#ifdef HAVE_ARPA_INET_H +#include +#endif +#ifdef HAVE_NET_IF_H +#include +#endif +#ifdef HAVE_SYS_IOCTL_H +#include +#endif + +#ifdef HAVE_SYS_PARAM_H +#include +#endif + +#include "transfer.h" +#include "sendf.h" +#include "curl_trc.h" +#include "formdata.h" +#include "mime.h" +#include "progress.h" +#include "curlx/base64.h" +#include "cookie.h" +#include "vauth/vauth.h" +#include "vquic/vquic.h" +#include "http_digest.h" +#include "http_ntlm.h" +#include "http_negotiate.h" +#include "http_aws_sigv4.h" +#include "url.h" +#include "urlapi-int.h" +#include "curl_share.h" +#include "hostip.h" +#include "dynhds.h" +#include "http.h" +#include "headers.h" +#include "select.h" +#include "parsedate.h" /* for the week day and month names */ +#include "multiif.h" +#include "strcase.h" +#include "content_encoding.h" +#include "http_proxy.h" +#include "http2.h" +#include "cfilters.h" +#include "connect.h" +#include "curlx/strdup.h" +#include "altsvc.h" +#include "hsts.h" +#include "rtsp.h" +#include "ws.h" +#include "bufref.h" +#include "curlx/strparse.h" + +void Curl_http_neg_init(struct Curl_easy *data, struct http_negotiation *neg) +{ + memset(neg, 0, sizeof(*neg)); + neg->accept_09 = data->set.http09_allowed; + switch(data->set.httpwant) { + case CURL_HTTP_VERSION_1_0: + neg->wanted = neg->allowed = (CURL_HTTP_V1x); + neg->only_10 = TRUE; + break; + case CURL_HTTP_VERSION_1_1: + neg->wanted = neg->allowed = (CURL_HTTP_V1x); + break; + case CURL_HTTP_VERSION_2_0: + neg->wanted = neg->allowed = (CURL_HTTP_V1x | CURL_HTTP_V2x); + neg->h2_upgrade = TRUE; + break; + case CURL_HTTP_VERSION_2TLS: + neg->wanted = neg->allowed = (CURL_HTTP_V1x | CURL_HTTP_V2x); + break; + case CURL_HTTP_VERSION_2_PRIOR_KNOWLEDGE: + neg->wanted = neg->allowed = (CURL_HTTP_V2x); + data->state.http_neg.h2_prior_knowledge = TRUE; + break; + case CURL_HTTP_VERSION_3: + neg->wanted = (CURL_HTTP_V1x | CURL_HTTP_V2x | CURL_HTTP_V3x); + neg->allowed = neg->wanted; + break; + case CURL_HTTP_VERSION_3ONLY: + neg->wanted = neg->allowed = (CURL_HTTP_V3x); + break; + case CURL_HTTP_VERSION_NONE: + default: + neg->wanted = (CURL_HTTP_V1x | CURL_HTTP_V2x); + neg->allowed = (CURL_HTTP_V1x | CURL_HTTP_V2x | CURL_HTTP_V3x); + break; + } +} + +CURLcode Curl_http_setup_conn(struct Curl_easy *data, + struct connectdata *conn) +{ + /* allocate the HTTP-specific struct for the Curl_easy, only to survive + during this request */ + if(data->state.http_neg.wanted == CURL_HTTP_V3x) { + /* only HTTP/3, needs to work */ + CURLcode result = Curl_conn_may_http3(data, conn, conn->transport_wanted); + if(result) + return result; + } + return CURLE_OK; +} + +#ifndef CURL_DISABLE_PROXY +/* + * checkProxyHeaders() checks the linked list of custom proxy headers + * if proxy headers are not available, then it will lookup into http header + * link list + * + * It takes a connectdata struct as input to see if this is a proxy request or + * not, as it then might check a different header list. Provide the header + * prefix without colon! + */ +char *Curl_checkProxyheaders(struct Curl_easy *data, + const struct connectdata *conn, + const char *thisheader, + const size_t thislen) +{ + struct curl_slist *head; + + for(head = (conn->http_proxy.peer && data->set.sep_headers) ? + data->set.proxyheaders : data->set.headers; + head; head = head->next) { + if(curl_strnequal(head->data, thisheader, thislen) && + Curl_headersep(head->data[thislen])) + return head->data; + } + + return NULL; +} +#endif + +/* If the header has a value, this function returns TRUE and the value is in + 'outp' with blanks trimmed off. +*/ +static bool header_has_value(const char **headerp, struct Curl_str *outp) +{ + bool value = !curlx_str_cspn(headerp, outp, ";:") && + (!curlx_str_single(headerp, ':') || !curlx_str_single(headerp, ';')); + + if(value) { + curlx_str_untilnl(headerp, outp, MAX_HTTP_RESP_HEADER_SIZE); + curlx_str_trimblanks(outp); + } + return value; +} + +static bool http_header_is_empty(const char *header) +{ + struct Curl_str out; + + if(header_has_value(&header, &out)) { + return curlx_strlen(&out) == 0; + } + return TRUE; /* invalid header format, treat as empty */ +} + +/* + * Strip off leading and trailing whitespace from the value in the given HTTP + * header line and return a strdup-ed copy in 'valp' - returns an empty + * string if the header value consists entirely of whitespace. + * + * If the header is provided as "name;", ending with a semicolon, it returns a + * blank string. + */ +static CURLcode copy_custom_value(const char *header, char **valp) +{ + struct Curl_str out; + + /* find the end of the header name */ + if(header_has_value(&header, &out)) { + *valp = curlx_memdup0(curlx_str(&out), curlx_strlen(&out)); + if(*valp) + return CURLE_OK; + return CURLE_OUT_OF_MEMORY; + } + /* bad input */ + *valp = NULL; + return CURLE_BAD_FUNCTION_ARGUMENT; +} + +/* + * Strip off leading and trailing whitespace from the value in the given HTTP + * header line and return a strdup-ed copy in 'valp' - returns an empty + * string if the header value consists entirely of whitespace. + * + * This function MUST be used after the header has already been confirmed to + * lead with "word:". + * + * @unittest: 1626 + */ +char *Curl_copy_header_value(const char *header) +{ + struct Curl_str out; + + /* find the end of the header name */ + if(!curlx_str_until(&header, &out, MAX_HTTP_RESP_HEADER_SIZE, ':') && + !curlx_str_single(&header, ':')) { + curlx_str_untilnl(&header, &out, MAX_HTTP_RESP_HEADER_SIZE); + curlx_str_trimblanks(&out); + return curlx_memdup0(curlx_str(&out), curlx_strlen(&out)); + } + /* bad input, should never happen */ + DEBUGASSERT(0); + return NULL; +} + +#ifndef CURL_DISABLE_HTTP_AUTH + +#ifndef CURL_DISABLE_BASIC_AUTH +/* + * http_output_basic() sets up an Authorization: header (or the proxy version) + * for HTTP Basic authentication. + * + * Returns CURLcode. + */ +static CURLcode http_output_basic(struct Curl_easy *data, + struct connectdata *conn, bool proxy) +{ + size_t size = 0; + char *authorization = NULL; + char **p_hd; + CURLcode result; + struct Curl_creds *creds = NULL; + char *out; + + /* credentials are unique per transfer for HTTP, do not use the ones for the + connection */ + if(proxy) { +#ifndef CURL_DISABLE_PROXY + p_hd = &data->req.hd_proxy_auth; + creds = conn->http_proxy.creds; +#else + (void)conn; + return CURLE_NOT_BUILT_IN; +#endif + } + else { + p_hd = &data->req.hd_auth; + creds = data->state.creds; + } + + if(!creds) { + DEBUGASSERT(0); + return CURLE_FAILED_INIT; + } + + out = curl_maprintf("%s:%s", creds->user, creds->passwd); + if(!out) + return CURLE_OUT_OF_MEMORY; + + result = curlx_base64_encode((uint8_t *)out, strlen(out), + &authorization, &size); + if(result) + goto fail; + + if(!authorization) { + result = CURLE_REMOTE_ACCESS_DENIED; + goto fail; + } + + curlx_free(*p_hd); + *p_hd = curl_maprintf("%sAuthorization: Basic %s\r\n", + proxy ? "Proxy-" : "", + authorization); + curlx_free(authorization); + if(!*p_hd) { + result = CURLE_OUT_OF_MEMORY; + goto fail; + } + +fail: + curlx_free(out); + return result; +} + +#endif + +#ifndef CURL_DISABLE_BEARER_AUTH +/* + * http_output_bearer() sets up an Authorization: header + * for HTTP Bearer authentication. + * + * Returns CURLcode. + */ +static CURLcode http_output_bearer(struct Curl_easy *data) +{ + char **userp; + CURLcode result = CURLE_OK; + + DEBUGASSERT(Curl_creds_has_oauth_bearer(data->state.creds)); + userp = &data->req.hd_auth; + curlx_free(*userp); + *userp = curl_maprintf("Authorization: Bearer %s\r\n", + Curl_creds_oauth_bearer(data->state.creds)); + + if(!*userp) { + result = CURLE_OUT_OF_MEMORY; + goto fail; + } + +fail: + return result; +} +#endif + +#endif + +/* pickoneauth() selects the most favorable authentication method from the + * ones available and the ones we want. + * + * return TRUE if one was picked + */ +static bool pickoneauth(struct auth *pick, unsigned long mask, + struct Curl_creds *creds) +{ + bool have_user_pass = Curl_creds_has_user_or_pass(creds); + bool picked; + /* only deal with authentication we want */ + unsigned long avail = pick->avail & pick->want & mask; + picked = TRUE; + + /* The order of these checks is highly relevant, as this will be the order + of preference in case of the existence of multiple accepted types. */ + if(avail & CURLAUTH_NEGOTIATE) /* available on empty creds */ + pick->picked = CURLAUTH_NEGOTIATE; +#ifndef CURL_DISABLE_BEARER_AUTH + else if((avail & CURLAUTH_BEARER) && Curl_creds_has_oauth_bearer(creds)) + pick->picked = CURLAUTH_BEARER; +#endif +#ifndef CURL_DISABLE_DIGEST_AUTH + else if((avail & CURLAUTH_DIGEST) && have_user_pass) + pick->picked = CURLAUTH_DIGEST; +#endif + else if(avail & CURLAUTH_NTLM) + pick->picked = CURLAUTH_NTLM; +#ifndef CURL_DISABLE_BASIC_AUTH + else if((avail & CURLAUTH_BASIC) && have_user_pass) + pick->picked = CURLAUTH_BASIC; +#endif +#ifndef CURL_DISABLE_AWS + else if(avail & CURLAUTH_AWS_SIGV4) + pick->picked = CURLAUTH_AWS_SIGV4; +#endif + else { + pick->picked = CURLAUTH_PICKNONE; /* we select to use nothing */ + picked = FALSE; + } + pick->avail = CURLAUTH_NONE; /* clear it here */ + + return picked; +} + +/* + * http_perhapsrewind() + * + * The current request needs to be done again - maybe due to a follow + * or authentication negotiation. Check if: + * 1) a rewind of the data sent to the server is necessary + * 2) the current transfer should continue or be stopped early + */ +static CURLcode http_perhapsrewind(struct Curl_easy *data, + struct connectdata *conn) +{ + curl_off_t bytessent = data->req.writebytecount; + curl_off_t expectsend = Curl_creader_total_length(data); + curl_off_t upload_remain = (expectsend >= 0) ? (expectsend - bytessent) : -1; + bool little_upload_remains = (upload_remain >= 0 && upload_remain < 2000); + bool needs_rewind = Curl_creader_needs_rewind(data); + /* By default, we would like to abort the transfer when little or unknown + * amount remains. This may be overridden by authentications further + * below! */ + bool abort_upload = (!data->req.upload_done && !little_upload_remains); + VERBOSE(const char *ongoing_auth = NULL); + + /* We need a rewind before uploading client read data again. The + * checks below influence of the upload is to be continued + * or aborted early. + * This depends on how much remains to be sent and in what state + * the authentication is. Some auth schemes such as NTLM do not work + * for a new connection. */ + if(needs_rewind) { + infof(data, "Need to rewind upload for next request"); + Curl_creader_set_rewind(data, TRUE); + } + + if(conn->bits.close) + /* If we already decided to close this connection, we cannot veto. */ + return CURLE_OK; + + if(abort_upload) { + /* We would like to abort the upload - but should we? */ +#ifdef USE_NTLM + if((data->state.authproxy.picked == CURLAUTH_NTLM) || + (data->state.authhost.picked == CURLAUTH_NTLM)) { + VERBOSE(ongoing_auth = "NTLM"); + if((conn->http_ntlm_state != NTLMSTATE_NONE) || + (conn->proxy_ntlm_state != NTLMSTATE_NONE)) { + /* The NTLM-negotiation has started, keep on sending. + * Need to do further work on same connection */ + abort_upload = FALSE; + } + } +#endif +#ifdef USE_SPNEGO + /* There is still data left to send */ + if((data->state.authproxy.picked == CURLAUTH_NEGOTIATE) || + (data->state.authhost.picked == CURLAUTH_NEGOTIATE)) { + VERBOSE(ongoing_auth = "NEGOTIATE"); + if((conn->http_negotiate_state != GSS_AUTHNONE) || + (conn->proxy_negotiate_state != GSS_AUTHNONE)) { + /* The NEGOTIATE-negotiation has started, keep on sending. + * Need to do further work on same connection */ + abort_upload = FALSE; + } + } +#endif + } + + if(abort_upload) { + if(upload_remain >= 0) + infof(data, "%s%sclose instead of sending %" FMT_OFF_T " more bytes", + ongoing_auth ? ongoing_auth : "", + ongoing_auth ? " send, " : "", + upload_remain); + else + infof(data, "%s%sclose instead of sending unknown amount " + "of more bytes", + ongoing_auth ? ongoing_auth : "", + ongoing_auth ? " send, " : ""); + /* We decided to abort the ongoing transfer */ + streamclose(conn, "Mid-auth HTTP and much data left to send"); + data->req.size = 0; /* do not download any more than 0 bytes */ + data->req.http_bodyless = TRUE; + } + return CURLE_OK; +} + +/** + * http_should_fail() determines whether an HTTP response code has gotten us + * into an error state or not. + * + * @retval FALSE communications should continue + * + * @retval TRUE communications should not continue + */ +static bool http_should_fail(struct Curl_easy *data, int httpcode) +{ + DEBUGASSERT(data); + DEBUGASSERT(data->conn); + + /* + * If we have not been asked to fail on error, + * do not fail. + */ + if(!data->set.http_fail_on_error) + return FALSE; + + /* + * Any code < 400 is never terminal. + */ + if(httpcode < 400) + return FALSE; + + /* + * A 416 response to a resume request is presumably because the file is + * already completely downloaded and thus not actually a fail. + */ + if(data->state.resume_from && data->state.httpreq == HTTPREQ_GET && + httpcode == 416) + return FALSE; + + /* + * Any code >= 400 that is not 401 or 407 is always + * a terminal error + */ + if((httpcode != 401) && (httpcode != 407)) + return TRUE; + + /* + * All we have left to deal with is 401 and 407 + */ + DEBUGASSERT((httpcode == 401) || (httpcode == 407)); + + /* + * Examine the current authentication state to see if this is an error. The + * idea is for this function to get called after processing all the headers + * in a response message. If we have been to asked to authenticate + * a particular stage, and we have done it, we are OK. If we are already + * completely authenticated, it is not OK to get another 401 or 407. + * + * It is possible for authentication to go stale such that the client needs + * to reauthenticate. Once that info is available, use it here. + */ + + /* + * Either we are not authenticating, or we are supposed to be authenticating + * something else. This is an error. + */ + if((httpcode == 401) && !data->state.creds) + return TRUE; +#ifndef CURL_DISABLE_PROXY + if((httpcode == 407) && !data->conn->http_proxy.creds) + return TRUE; +#endif + + return (bool)data->state.authproblem; +} + +/* + * Curl_http_auth_act() gets called when all HTTP headers have been received + * and it checks what authentication methods that are available and decides + * which one (if any) to use. It will set 'newurl' if an auth method was + * picked. + */ +CURLcode Curl_http_auth_act(struct Curl_easy *data) +{ + struct connectdata *conn = data->conn; + bool pickhost = FALSE; + bool pickproxy = FALSE; + CURLcode result = CURLE_OK; + unsigned long authmask = ~0UL; + + if(!Curl_creds_has_oauth_bearer(data->state.creds)) + authmask &= (unsigned long)~CURLAUTH_BEARER; + + if(100 <= data->req.httpcode && data->req.httpcode <= 199) + /* this is a transient response code, ignore */ + return CURLE_OK; + + if(data->state.authproblem) + return data->set.http_fail_on_error ? CURLE_HTTP_RETURNED_ERROR : CURLE_OK; + + if(data->state.creds && + ((data->req.httpcode == 401) || + (data->req.authneg && data->req.httpcode < 300))) { + pickhost = pickoneauth(&data->state.authhost, authmask, data->state.creds); + if(!pickhost) + data->state.authproblem = TRUE; + else + data->info.httpauthpicked = data->state.authhost.picked; + if(data->state.authhost.picked == CURLAUTH_NTLM && + (data->req.httpversion_sent > 11)) { + infof(data, "Forcing HTTP/1.1 for NTLM"); + connclose(conn, "Force HTTP/1.1 connection"); + data->state.http_neg.wanted = CURL_HTTP_V1x; + data->state.http_neg.allowed = CURL_HTTP_V1x; + } + } +#ifndef CURL_DISABLE_PROXY + if(conn->http_proxy.creds && + ((data->req.httpcode == 407) || + (data->req.authneg && data->req.httpcode < 300))) { + pickproxy = pickoneauth(&data->state.authproxy, + authmask & ~CURLAUTH_BEARER, + conn->http_proxy.creds); + if(!pickproxy) + data->state.authproblem = TRUE; + else + data->info.proxyauthpicked = data->state.authproxy.picked; + } +#endif + + if(pickhost || pickproxy) { + result = http_perhapsrewind(data, conn); + if(result) + return result; + + /* In case this is GSS auth, the newurl field is already allocated so + we must make sure to free it before allocating a new one. As figured + out in bug #2284386 */ + curlx_free(data->req.newurl); + /* clone URL */ + data->req.newurl = Curl_bufref_dup(&data->state.url); + if(!data->req.newurl) + return CURLE_OUT_OF_MEMORY; + } + else if((data->req.httpcode < 300) && + !data->state.authhost.done && + data->req.authneg) { + /* no (known) authentication available, + authentication is not "done" yet and + no authentication seems to be required and + we did not try HEAD or GET */ + if((data->state.httpreq != HTTPREQ_GET) && + (data->state.httpreq != HTTPREQ_HEAD)) { + /* clone URL */ + data->req.newurl = Curl_bufref_dup(&data->state.url); + if(!data->req.newurl) + return CURLE_OUT_OF_MEMORY; + data->state.authhost.done = TRUE; + } + } + if(http_should_fail(data, data->req.httpcode)) { + failf(data, "The requested URL returned error: %d", + data->req.httpcode); + result = CURLE_HTTP_RETURNED_ERROR; + } + + return result; +} + +#ifndef CURL_DISABLE_HTTP_AUTH +/* + * Output the correct authentication header depending on the auth type + * and whether or not it is to a proxy. + */ +static CURLcode output_auth_headers(struct Curl_easy *data, + struct connectdata *conn, + struct auth *authstatus, + const char *request, + const char *path, + bool proxy) +{ + const char *auth = NULL; + CURLcode result = CURLE_OK; + (void)conn; + +#ifdef CURL_DISABLE_DIGEST_AUTH + (void)request; + (void)path; +#endif +#ifndef CURL_DISABLE_AWS + if((authstatus->picked == CURLAUTH_AWS_SIGV4) && !proxy) { + /* this method is never for proxy */ + auth = "AWS_SIGV4"; + result = Curl_output_aws_sigv4(data); + if(result) + return result; + } + else +#endif +#ifdef USE_SPNEGO + if(authstatus->picked == CURLAUTH_NEGOTIATE) { + auth = "Negotiate"; + result = Curl_output_negotiate(data, conn, proxy); + if(result) + return result; + } + else +#endif +#ifdef USE_NTLM + if(authstatus->picked == CURLAUTH_NTLM) { + auth = "NTLM"; + result = Curl_output_ntlm(data, proxy); + if(result) + return result; + } + else +#endif +#ifndef CURL_DISABLE_DIGEST_AUTH + if(authstatus->picked == CURLAUTH_DIGEST) { + auth = "Digest"; + result = Curl_output_digest(data, + proxy, + (const unsigned char *)request, + (const unsigned char *)path); + if(result) + return result; + } + else +#endif +#ifndef CURL_DISABLE_BASIC_AUTH + if(authstatus->picked == CURLAUTH_BASIC) { + /* Basic */ + if( +#ifndef CURL_DISABLE_PROXY + (proxy && conn->http_proxy.creds && + Curl_creds_has_user_or_pass(conn->http_proxy.creds) && + !Curl_checkProxyheaders(data, conn, + STRCONST("Proxy-authorization"))) || +#endif + (!proxy && data->state.creds && + Curl_creds_has_user_or_pass(data->state.creds) && + !Curl_checkheaders(data, STRCONST("Authorization")))) { + auth = "Basic"; + result = http_output_basic(data, conn, proxy); + if(result) + return result; + } + + /* NOTE: this function should set 'done' TRUE, as the other auth + functions work that way */ + authstatus->done = TRUE; + } +#endif +#ifndef CURL_DISABLE_BEARER_AUTH + if(authstatus->picked == CURLAUTH_BEARER) { + /* Bearer */ + if(!proxy && Curl_creds_has_oauth_bearer(data->state.creds) && + !Curl_checkheaders(data, STRCONST("Authorization"))) { + auth = "Bearer"; + result = http_output_bearer(data); + if(result) + return result; + } + + /* NOTE: this function should set 'done' TRUE, as the other auth + functions work that way */ + authstatus->done = TRUE; + } +#endif + + if(auth) { +#ifndef CURL_DISABLE_PROXY + if(proxy) + data->info.proxyauthpicked = authstatus->picked; + else + data->info.httpauthpicked = authstatus->picked; + infof(data, "%s auth using %s with user '%s'", + proxy ? "Proxy" : "Server", auth, + proxy ? (conn->http_proxy.creds ? + conn->http_proxy.creds->user : "") : + (data->state.creds ? + data->state.creds->user : "")); +#else + (void)proxy; + infof(data, "Server auth using %s with user '%s'", + auth, data->state.creds ? + data->state.creds->user : ""); +#endif + authstatus->multipass = !authstatus->done; + } + else { + authstatus->multipass = FALSE; + if(proxy) + data->info.proxyauthpicked = 0; + else + data->info.httpauthpicked = 0; + } + + return result; +} + +CURLcode Curl_http_output_auth(struct Curl_easy *data, + struct connectdata *conn, + const char *request, + Curl_HttpReq httpreq, + const char *path, + const char *query, + bool is_connect) +{ + CURLcode result = CURLE_OK; + struct auth *authhost; + struct auth *authproxy; + const char *path_and_query = path; + char *tmp_str = NULL; + + DEBUGASSERT(data); + authhost = &data->state.authhost; + authproxy = &data->state.authproxy; + + if( +#ifndef CURL_DISABLE_PROXY + (!conn->http_proxy.peer || !conn->http_proxy.creds) && +#endif +#ifdef USE_SPNEGO + !(authhost->want & CURLAUTH_NEGOTIATE) && + !(authproxy->want & CURLAUTH_NEGOTIATE) && +#endif + !data->state.creds) { + /* no authentication with no user or password */ + authhost->done = TRUE; + authproxy->done = TRUE; + result = CURLE_OK; + goto out; + } + + if(query) { + tmp_str = curl_maprintf("%s?%s", path, query); + if(!tmp_str) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + path_and_query = tmp_str; + } + + if(authhost->want && !authhost->picked) + /* The app has selected one or more methods, but none has been picked + so far by a server round-trip. Then we set the picked one to the + want one, and if this is one single bit it will be used instantly. */ + authhost->picked = authhost->want; + + if(authproxy->want && !authproxy->picked) + /* The app has selected one or more methods, but none has been picked so + far by a proxy round-trip. Then we set the picked one to the want one, + and if this is one single bit it will be used instantly. */ + authproxy->picked = authproxy->want; + +#ifndef CURL_DISABLE_PROXY + /* Send proxy authentication header if needed */ + if(conn->bits.origin_is_proxy || is_connect) { + result = output_auth_headers(data, conn, authproxy, request, + path_and_query, TRUE); + if(result) + goto out; + } + else +#else + (void)is_connect; +#endif /* CURL_DISABLE_PROXY */ + /* we have no proxy so let's pretend we are done authenticating + with it */ + authproxy->done = TRUE; + + /* Either we have credentials for the origin we talk to or + performing authentication is allowed here */ + if(data->state.creds || Curl_auth_allowed_to_host(data)) + result = output_auth_headers(data, conn, authhost, request, + path_and_query, FALSE); + else + authhost->done = TRUE; + + if(((authhost->multipass && !authhost->done) || + (authproxy->multipass && !authproxy->done)) && + (httpreq != HTTPREQ_GET) && + (httpreq != HTTPREQ_HEAD)) { + /* Auth is required and we are not authenticated yet. Make a PUT or POST + with content-length zero as a "probe". */ + data->req.authneg = TRUE; + } + else + data->req.authneg = FALSE; + +out: + curlx_free(tmp_str); + return result; +} + +#else /* !CURL_DISABLE_HTTP_AUTH */ +/* when disabled */ +CURLcode Curl_http_output_auth(struct Curl_easy *data, + struct connectdata *conn, + const char *request, + Curl_HttpReq httpreq, + const char *path, + const char *query, + bool is_connect) +{ + (void)data; + (void)conn; + (void)request; + (void)httpreq; + (void)path; + (void)query; + (void)is_connect; + return CURLE_OK; +} +#endif /* !CURL_DISABLE_HTTP_AUTH, else */ + +#if defined(USE_SPNEGO) || defined(USE_NTLM) || \ + !defined(CURL_DISABLE_DIGEST_AUTH) || \ + !defined(CURL_DISABLE_BASIC_AUTH) || \ + !defined(CURL_DISABLE_BEARER_AUTH) +static bool authcmp(const char *auth, const char *line) +{ + /* the auth string must not have an alnum following */ + size_t n = strlen(auth); + return curl_strnequal(auth, line, n) && !ISALNUM(line[n]); +} +#endif + +#ifdef USE_SPNEGO +static CURLcode auth_spnego(struct Curl_easy *data, + bool proxy, + const char *auth, + struct auth *authp, + uint32_t *availp) +{ + if((authp->avail & CURLAUTH_NEGOTIATE) || Curl_auth_is_spnego_supported()) { + *availp |= CURLAUTH_NEGOTIATE; + authp->avail |= CURLAUTH_NEGOTIATE; + + if(authp->picked == CURLAUTH_NEGOTIATE) { + struct connectdata *conn = data->conn; + CURLcode result = Curl_input_negotiate(data, conn, proxy, auth); + curlnegotiate *negstate = proxy ? &conn->proxy_negotiate_state : + &conn->http_negotiate_state; + if(!result) { + curlx_free(data->req.newurl); + data->req.newurl = Curl_bufref_dup(&data->state.url); + if(!data->req.newurl) + return CURLE_OUT_OF_MEMORY; + data->state.authproblem = FALSE; + /* we received a GSS auth token and we dealt with it fine */ + *negstate = GSS_AUTHRECV; + } + else + data->state.authproblem = TRUE; + } + } + return CURLE_OK; +} +#endif + +#ifdef USE_NTLM +static CURLcode auth_ntlm(struct Curl_easy *data, + bool proxy, + const char *auth, + struct auth *authp, + uint32_t *availp) +{ + /* NTLM support requires the SSL crypto libs */ + if((authp->avail & CURLAUTH_NTLM) || Curl_auth_is_ntlm_supported()) { + *availp |= CURLAUTH_NTLM; + authp->avail |= CURLAUTH_NTLM; + + if(authp->picked == CURLAUTH_NTLM) { + /* NTLM authentication is picked and activated */ + CURLcode result = Curl_input_ntlm(data, proxy, auth); + if(!result) + data->state.authproblem = FALSE; + else { + if(result == CURLE_OUT_OF_MEMORY) + return result; + infof(data, "NTLM authentication problem, ignoring."); + data->state.authproblem = TRUE; + } + } + } + return CURLE_OK; +} +#endif + +#ifndef CURL_DISABLE_DIGEST_AUTH +static CURLcode auth_digest(struct Curl_easy *data, + bool proxy, + const char *auth, + struct auth *authp, + uint32_t *availp) +{ + if(authp->avail & CURLAUTH_DIGEST) { + *availp |= CURLAUTH_DIGEST; + infof(data, "Ignoring duplicate digest auth header."); + } + else if(Curl_auth_is_digest_supported()) { + CURLcode result; + + *availp |= CURLAUTH_DIGEST; + authp->avail |= CURLAUTH_DIGEST; + + /* We call this function on input Digest headers even if Digest + * authentication is not activated yet, as we need to store the + * incoming data from this header in case we are going to use + * Digest */ + result = Curl_input_digest(data, proxy, auth); + if(result) { + if(result == CURLE_OUT_OF_MEMORY) + return result; + infof(data, "Digest authentication problem, ignoring."); + data->state.authproblem = TRUE; + } + } + return CURLE_OK; +} +#endif + +#ifndef CURL_DISABLE_BASIC_AUTH +static CURLcode auth_basic(struct Curl_easy *data, + struct auth *authp, + uint32_t *availp) +{ + *availp |= CURLAUTH_BASIC; + authp->avail |= CURLAUTH_BASIC; + if(authp->picked == CURLAUTH_BASIC) { + /* We asked for Basic authentication but got a 40X back anyway, which + means our name+password is not valid. */ + authp->avail = CURLAUTH_NONE; + infof(data, "Basic authentication problem, ignoring."); + data->state.authproblem = TRUE; + } + return CURLE_OK; +} +#endif + +#ifndef CURL_DISABLE_BEARER_AUTH +static CURLcode auth_bearer(struct Curl_easy *data, + struct auth *authp, + uint32_t *availp) +{ + *availp |= CURLAUTH_BEARER; + authp->avail |= CURLAUTH_BEARER; + if(authp->picked == CURLAUTH_BEARER) { + /* We asked for Bearer authentication but got a 40X back anyway, which + means our token is not valid. */ + authp->avail = CURLAUTH_NONE; + infof(data, "Bearer authentication problem, ignoring."); + data->state.authproblem = TRUE; + } + return CURLE_OK; +} +#endif + +/* + * Curl_http_input_auth() deals with Proxy-Authenticate: and WWW-Authenticate: + * headers. They are dealt with both in the transfer.c main loop and in the + * proxy CONNECT loop. + * + * The 'auth' line ends with a null byte without CR or LF present. + */ +CURLcode Curl_http_input_auth(struct Curl_easy *data, bool proxy, + const char *auth) /* the first non-space */ +{ + /* + * This resource requires authentication + */ +#if defined(USE_SPNEGO) || \ + defined(USE_NTLM) || \ + !defined(CURL_DISABLE_DIGEST_AUTH) || \ + !defined(CURL_DISABLE_BASIC_AUTH) || \ + !defined(CURL_DISABLE_BEARER_AUTH) + + uint32_t *availp; + struct auth *authp; + CURLcode result = CURLE_OK; + DEBUGASSERT(auth); + DEBUGASSERT(data); + + if(proxy) { + availp = &data->info.proxyauthavail; + authp = &data->state.authproxy; + } + else { + availp = &data->info.httpauthavail; + authp = &data->state.authhost; + } + + /* + * Here we check if we want the specific single authentication (using ==) and + * if we do, we initiate usage of it. + * + * If the provided authentication is wanted as one out of several accepted + * types (using &), we OR this authentication type to the authavail + * variable. + * + * Note: + * + * ->picked is first set to the 'want' value (one or more bits) before the + * request is sent, and then it is again set _after_ all response 401/407 + * headers have been received but then only to a single preferred method + * (bit). + */ + + while(*auth) { +#ifdef USE_SPNEGO + if(authcmp("Negotiate", auth)) + result = auth_spnego(data, proxy, auth, authp, availp); +#endif +#ifdef USE_NTLM + if(!result && authcmp("NTLM", auth)) + result = auth_ntlm(data, proxy, auth, authp, availp); +#endif +#ifndef CURL_DISABLE_DIGEST_AUTH + if(!result && authcmp("Digest", auth)) + result = auth_digest(data, proxy, auth, authp, availp); +#endif +#ifndef CURL_DISABLE_BASIC_AUTH + if(!result && authcmp("Basic", auth)) + result = auth_basic(data, authp, availp); +#endif +#ifndef CURL_DISABLE_BEARER_AUTH + if(authcmp("Bearer", auth)) + result = auth_bearer(data, authp, availp); +#endif + + if(result) + break; + + /* there may be multiple methods on one line, so keep reading */ + auth = strchr(auth, ','); + if(auth) /* if we are on a comma, skip it */ + auth++; + else + break; + curlx_str_passblanks(&auth); + } + return result; +#else + (void)data; + (void)proxy; + (void)auth; + /* nothing to do when disabled */ + return CURLE_OK; +#endif +} + +static void http_switch_to_get(struct Curl_easy *data, int code) +{ + const char *req = data->set.str[STRING_CUSTOMREQUEST]; + + if((req || data->state.httpreq != HTTPREQ_GET) && + (data->set.http_follow_mode == CURLFOLLOW_OBEYCODE)) { + NOVERBOSE((void)code); + infof(data, "Switch to GET because of %d response", code); + data->state.http_ignorecustom = TRUE; + } + else if(req && (data->set.http_follow_mode != CURLFOLLOW_FIRSTONLY)) + infof(data, "Stick to %s instead of GET", req); + + data->state.httpreq = HTTPREQ_GET; + Curl_creader_set_rewind(data, FALSE); +} + +#define HTTPREQ_IS_POST(data) \ + ((data)->state.httpreq == HTTPREQ_POST || \ + (data)->state.httpreq == HTTPREQ_POST_FORM || \ + (data)->state.httpreq == HTTPREQ_POST_MIME) + +CURLcode Curl_http_follow(struct Curl_easy *data, const char *newurl, + followtype type) +{ + bool disallowport = FALSE; + bool reachedmax = FALSE; + char *follow_url = NULL; + CURLUcode uc; + CURLcode rewind_result; + bool switch_to_get = FALSE; + + DEBUGASSERT(type != FOLLOW_NONE); + + if(type != FOLLOW_FAKE) + data->state.requests++; /* count all real follows */ + if(type == FOLLOW_REDIR) { + if((data->set.maxredirs != -1) && + (data->state.followlocation >= data->set.maxredirs)) { + reachedmax = TRUE; + type = FOLLOW_FAKE; /* switch to fake to store the would-be-redirected + to URL */ + } + else { + data->state.followlocation++; /* count redirect-followings, including + auth reloads */ + + if(data->set.http_auto_referer) { + CURLU *u; + char *referer = NULL; + + /* We are asked to automatically set the previous URL as the referer + when we get the next URL. We pick the ->url field, which may or may + not be 100% correct */ + Curl_bufref_free(&data->state.referer); + + /* Make a copy of the URL without credentials and fragment */ + u = curl_url(); + if(!u) + return CURLE_OUT_OF_MEMORY; + + uc = curl_url_set(u, CURLUPART_URL, + Curl_bufref_ptr(&data->state.url), 0); + if(!uc) + uc = curl_url_set(u, CURLUPART_FRAGMENT, NULL, 0); + if(!uc) + uc = curl_url_set(u, CURLUPART_USER, NULL, 0); + if(!uc) + uc = curl_url_set(u, CURLUPART_PASSWORD, NULL, 0); + if(!uc) + uc = curl_url_get(u, CURLUPART_URL, &referer, 0); + + curl_url_cleanup(u); + + if(uc || !referer) + return CURLE_OUT_OF_MEMORY; + + Curl_bufref_set(&data->state.referer, referer, 0, curl_free); + } + } + } + + if((type != FOLLOW_RETRY) && + (data->req.httpcode != 401) && (data->req.httpcode != 407) && + Curl_is_absolute_url(newurl, NULL, 0, FALSE)) { + /* If this is not redirect due to a 401 or 407 response and an absolute + URL: do not allow a custom port number */ + disallowport = TRUE; + } + + DEBUGASSERT(data->state.uh); + uc = curl_url_set(data->state.uh, CURLUPART_URL, newurl, (unsigned int) + ((type == FOLLOW_FAKE) ? CURLU_NON_SUPPORT_SCHEME : + ((type == FOLLOW_REDIR) ? CURLU_URLENCODE : 0) | + CURLU_ALLOW_SPACE | + (data->set.path_as_is ? CURLU_PATH_AS_IS : 0))); + if(uc) { + if((uc == CURLUE_OUT_OF_MEMORY) || (type != FOLLOW_FAKE)) { + failf(data, "The redirect target URL could not be parsed: %s", + curl_url_strerror(uc)); + return Curl_uc_to_curlcode(uc); + } + + /* the URL could not be parsed for some reason, but since this is FAKE + mode, duplicate the field as-is */ + follow_url = curlx_strdup(newurl); + if(!follow_url) + return CURLE_OUT_OF_MEMORY; + } + else { + CURLU *u = curl_url(); + if(!u) + return CURLE_OUT_OF_MEMORY; + uc = curl_url_set(u, CURLUPART_URL, + Curl_bufref_ptr(&data->state.url), + CURLU_URLENCODE | CURLU_ALLOW_SPACE); + if(!uc) + uc = curl_url_get(data->state.uh, CURLUPART_URL, &follow_url, 0); + if(uc) { + curl_url_cleanup(u); + return Curl_uc_to_curlcode(uc); + } + +#ifndef CURL_DISABLE_DIGEST_AUTH + { + bool same_origin = Curl_url_same_origin(u, data->state.uh); + curl_url_cleanup(u); + if(!same_origin) + Curl_auth_digest_cleanup(&data->state.digest); + } +#else + curl_url_cleanup(u); +#endif + } + DEBUGASSERT(follow_url); + + if(type == FOLLOW_FAKE) { + /* we are only figuring out the new URL if we would have followed locations + but now we are done so we can get out! */ + data->info.wouldredirect = follow_url; + + if(reachedmax) { + failf(data, "Maximum (%d) redirects followed", data->set.maxredirs); + return CURLE_TOO_MANY_REDIRECTS; + } + return CURLE_OK; + } + + if(disallowport) + data->state.allow_port = FALSE; + + Curl_bufref_set(&data->state.url, follow_url, 0, curl_free); + rewind_result = Curl_req_soft_reset(&data->req, data); + infof(data, "Issue another request to this URL: '%s'", follow_url); + if((data->set.http_follow_mode == CURLFOLLOW_FIRSTONLY) && + data->set.str[STRING_CUSTOMREQUEST] && + !data->state.http_ignorecustom) { + data->state.http_ignorecustom = TRUE; + infof(data, "Drop custom request method for next request"); + } + + /* + * We get here when the HTTP code is 300-399 (and 401). We need to perform + * differently based on exactly what return code there was. + * + * News from 7.10.6: we can also get here on a 401 or 407, in case we act on + * an HTTP (proxy-) authentication scheme other than Basic. + */ + switch(data->info.httpcode) { + /* 401 - Act on a WWW-Authenticate, we keep on moving and do the + Authorization: XXXX header in the HTTP request code snippet */ + /* 407 - Act on a Proxy-Authenticate, we keep on moving and do the + Proxy-Authorization: XXXX header in the HTTP request code snippet */ + /* 300 - Multiple Choices */ + /* 306 - Not used */ + /* 307 - Temporary Redirect */ + default: /* for all above (and the unknown ones) */ + /* Some codes are explicitly mentioned since I have checked RFC2616 and + * they seem to be OK to POST to. + */ + break; + case 301: /* Moved Permanently */ + /* (quote from RFC7231, section 6.4.2) + * + * Note: For historical reasons, a user agent MAY change the request + * method from POST to GET for the subsequent request. If this + * behavior is undesired, the 307 (Temporary Redirect) status code + * can be used instead. + * + * ---- + * + * Many webservers expect this, so these servers often answers to a POST + * request with an error page. To be sure that libcurl gets the page that + * most user agents would get, libcurl has to force GET. + * + * This behavior is forbidden by RFC1945 and the obsolete RFC2616, and + * can be overridden with CURLOPT_POSTREDIR. + */ + if(HTTPREQ_IS_POST(data) && !data->set.post301) { + http_switch_to_get(data, 301); + switch_to_get = TRUE; + } + break; + case 302: /* Found */ + /* (quote from RFC7231, section 6.4.3) + * + * Note: For historical reasons, a user agent MAY change the request + * method from POST to GET for the subsequent request. If this + * behavior is undesired, the 307 (Temporary Redirect) status code + * can be used instead. + * + * ---- + * + * Many webservers expect this, so these servers often answers to a POST + * request with an error page. To be sure that libcurl gets the page that + * most user agents would get, libcurl has to force GET. + * + * This behavior is forbidden by RFC1945 and the obsolete RFC2616, and + * can be overridden with CURLOPT_POSTREDIR. + */ + if(HTTPREQ_IS_POST(data) && !data->set.post302) { + http_switch_to_get(data, 302); + switch_to_get = TRUE; + } + break; + + case 303: /* See Other */ + /* 'See Other' location is not the resource but a substitute for the + * resource. In this case we switch the method to GET/HEAD, unless the + * method is POST and the user specified to keep it as POST. + */ + if(!HTTPREQ_IS_POST(data) || !data->set.post303) { + http_switch_to_get(data, 303); + switch_to_get = TRUE; + } + break; + case 304: /* Not Modified */ + /* 304 means we did a conditional request and it was "Not modified". + * We should not get any Location: header in this response! + */ + break; + case 305: /* Use Proxy */ + /* (quote from RFC2616, section 10.3.6): + * "The requested resource MUST be accessed through the proxy given + * by the Location field. The Location field gives the URI of the + * proxy. The recipient is expected to repeat this single request + * via the proxy. 305 responses MUST only be generated by origin + * servers." + */ + break; + } + + /* When rewind of upload data failed and we are not switching to GET, + * we need to fail the follow, as we cannot send the data again. */ + if(rewind_result && !switch_to_get) + return rewind_result; + + Curl_pgrsTime(data, TIMER_REDIRECT); + Curl_pgrsResetTransferSizes(data); + + return CURLE_OK; +} + +/* + * Curl_compareheader() + * + * Returns TRUE if 'headerline' contains the 'header' with given 'content' + * (within a comma-separated list of tokens). Pass 'header' WITH the colon. + * + * @unittest: 1625 + */ +bool Curl_compareheader(const char *headerline, /* line to check */ + const char *header, /* header keyword _with_ colon */ + const size_t hlen, /* len of the keyword in bytes */ + const char *content, /* content string to find */ + const size_t clen) /* len of the content in bytes */ +{ + /* RFC2616, section 4.2 says: "Each header field consists of a name followed + * by a colon (":") and the field value. Field names are case-insensitive. + * The field value MAY be preceded by any amount of LWS, though a single SP + * is preferred." */ + + const char *p; + struct Curl_str val; + DEBUGASSERT(hlen); + DEBUGASSERT(clen); + DEBUGASSERT(header); + DEBUGASSERT(content); + + if(!curl_strnequal(headerline, header, hlen)) + return FALSE; /* does not start with header */ + + /* pass the header */ + p = &headerline[hlen]; + + if(curlx_str_untilnl(&p, &val, MAX_HTTP_RESP_HEADER_SIZE)) + return FALSE; + curlx_str_trimblanks(&val); + + /* find the content string in the rest of the line */ + if(curlx_strlen(&val) >= clen) { + size_t len; + p = curlx_str(&val); + for(len = curlx_strlen(&val); len >= clen;) { + struct Curl_str next; + const char *o = p; + /* after a match there must be a comma, space, newline or null byte */ + if(curl_strnequal(p, content, clen) && + ((p[clen] == ',') || ISBLANK(p[clen]) || ISNEWLINE(p[clen]) || + !p[clen])) + return TRUE; /* match! */ + /* advance to the next comma */ + if(curlx_str_until(&p, &next, MAX_HTTP_RESP_HEADER_SIZE, ',') || + curlx_str_single(&p, ',')) + break; /* no comma, get out */ + + /* if there are more dummy commas, move over them as well */ + do + curlx_str_passblanks(&p); + while(!curlx_str_single(&p, ',')); + len -= (p - o); + } + } + return FALSE; /* no match */ +} + +struct cr_exp100_ctx { + struct Curl_creader super; + struct curltime start; /* time started waiting */ + enum expect100 state; +}; + +/* Expect: 100-continue client reader, blocking uploads */ + +static void http_exp100_continue(struct Curl_easy *data, + struct Curl_creader *reader) +{ + struct cr_exp100_ctx *ctx = reader->ctx; + if(ctx->state > EXP100_SEND_DATA) { + ctx->state = EXP100_SEND_DATA; + Curl_expire_done(data, EXPIRE_100_TIMEOUT); + } +} + +static CURLcode cr_exp100_read(struct Curl_easy *data, + struct Curl_creader *reader, + char *buf, size_t blen, + size_t *nread, bool *eos) +{ + struct cr_exp100_ctx *ctx = reader->ctx; + timediff_t ms; + + switch(ctx->state) { + case EXP100_SENDING_REQUEST: + if(!Curl_req_sendbuf_empty(data)) { + /* The initial request data has not been fully sent yet. Do + * not start the timer yet. */ + DEBUGF(infof(data, "cr_exp100_read, request not full sent yet")); + *nread = 0; + *eos = FALSE; + return CURLE_OK; + } + /* We are now waiting for a reply from the server or + * a timeout on our side IFF the request has been fully sent. */ + DEBUGF(infof(data, "cr_exp100_read, start AWAITING_CONTINUE, " + "timeout %dms", data->set.expect_100_timeout)); + ctx->state = EXP100_AWAITING_CONTINUE; + ctx->start = *Curl_pgrs_now(data); + Curl_expire(data, data->set.expect_100_timeout, EXPIRE_100_TIMEOUT); + *nread = 0; + *eos = FALSE; + return CURLE_OK; + case EXP100_FAILED: + DEBUGF(infof(data, "cr_exp100_read, expectation failed, error")); + *nread = 0; + *eos = FALSE; + return CURLE_READ_ERROR; + case EXP100_AWAITING_CONTINUE: + ms = curlx_ptimediff_ms(Curl_pgrs_now(data), &ctx->start); + if(ms < data->set.expect_100_timeout) { + DEBUGF(infof(data, "cr_exp100_read, AWAITING_CONTINUE, not expired")); + *nread = 0; + *eos = FALSE; + return CURLE_OK; + } + /* we have waited long enough, continue anyway */ + http_exp100_continue(data, reader); + infof(data, "Done waiting for 100-continue"); + FALLTHROUGH(); + default: + DEBUGF(infof(data, "cr_exp100_read, pass through")); + return Curl_creader_read(data, reader->next, buf, blen, nread, eos); + } +} + +static void cr_exp100_done(struct Curl_easy *data, + struct Curl_creader *reader, int premature) +{ + struct cr_exp100_ctx *ctx = reader->ctx; + ctx->state = premature ? EXP100_FAILED : EXP100_SEND_DATA; + Curl_expire_done(data, EXPIRE_100_TIMEOUT); +} + +static const struct Curl_crtype cr_exp100 = { + "cr-exp100", + Curl_creader_def_init, + cr_exp100_read, + Curl_creader_def_close, + Curl_creader_def_needs_rewind, + Curl_creader_def_total_length, + Curl_creader_def_resume_from, + Curl_creader_def_cntrl, + Curl_creader_def_is_paused, + cr_exp100_done, + sizeof(struct cr_exp100_ctx) +}; + +static CURLcode http_exp100_add_reader(struct Curl_easy *data) +{ + struct Curl_creader *reader = NULL; + CURLcode result; + + result = Curl_creader_create(&reader, data, &cr_exp100, CURL_CR_PROTOCOL); + if(!result) + result = Curl_creader_add(data, reader); + if(!result) { + struct cr_exp100_ctx *ctx = reader->ctx; + ctx->state = EXP100_SENDING_REQUEST; + } + + if(result && reader) + Curl_creader_free(data, reader); + return result; +} + +static void http_exp100_got100(struct Curl_easy *data) +{ + struct Curl_creader *r = Curl_creader_get_by_type(data, &cr_exp100); + if(r) + http_exp100_continue(data, r); +} + +static bool http_exp100_is_waiting(struct Curl_easy *data) +{ + struct Curl_creader *r = Curl_creader_get_by_type(data, &cr_exp100); + if(r) { + struct cr_exp100_ctx *ctx = r->ctx; + return ctx->state == EXP100_AWAITING_CONTINUE; + } + return FALSE; +} + +static void http_exp100_send_anyway(struct Curl_easy *data) +{ + struct Curl_creader *r = Curl_creader_get_by_type(data, &cr_exp100); + if(r) + http_exp100_continue(data, r); +} + +static bool http_exp100_is_selected(struct Curl_easy *data) +{ + struct Curl_creader *r = Curl_creader_get_by_type(data, &cr_exp100); + return !!r; +} + +/* this returns the socket to wait for in the DO and DOING state for the multi + interface and then we are always _sending_ a request and thus we wait for + the single socket to become writable only */ +CURLcode Curl_http_doing_pollset(struct Curl_easy *data, + struct easy_pollset *ps) +{ + /* write mode */ + return Curl_pollset_add_out(data, ps, data->conn->sock[FIRSTSOCKET]); +} + +CURLcode Curl_http_perform_pollset(struct Curl_easy *data, + struct easy_pollset *ps) +{ + struct connectdata *conn = data->conn; + CURLcode result = CURLE_OK; + + if(CURL_REQ_WANT_RECV(data)) { + result = Curl_pollset_add_in(data, ps, conn->sock[FIRSTSOCKET]); + } + + /* on a "Expect: 100-continue" timed wait, do not poll for outgoing */ + if(!result && Curl_req_want_send(data) && !http_exp100_is_waiting(data)) { + result = Curl_pollset_add_out(data, ps, conn->sock[FIRSTSOCKET]); + } + return result; +} + +static CURLcode http_write_header(struct Curl_easy *data, + const char *hd, size_t hdlen) +{ + CURLcode result; + int writetype; + + /* now, only output this if the header AND body are requested: + */ + Curl_debug(data, CURLINFO_HEADER_IN, hd, hdlen); + + writetype = CLIENTWRITE_HEADER | + ((data->req.httpcode / 100 == 1) ? CLIENTWRITE_1XX : 0); + + result = Curl_client_write(data, writetype, hd, hdlen); + if(result) + return result; + + result = Curl_bump_headersize(data, hdlen, FALSE); + if(result) + return result; + + data->req.deductheadercount = (100 <= data->req.httpcode && + 199 >= data->req.httpcode) ? + data->req.headerbytecount : 0; + return result; +} + +/* + * Curl_http_done() gets called after a single HTTP request has been + * performed. + */ + +CURLcode Curl_http_done(struct Curl_easy *data, + CURLcode status, bool premature) +{ + struct connectdata *conn = data->conn; + + /* Clear multipass flag. If authentication is not done yet, then it will get + * a chance to be set back to true when we output the next auth header */ + data->state.authhost.multipass = FALSE; + data->state.authproxy.multipass = FALSE; + + if(curlx_dyn_len(&data->state.headerb)) { + (void)http_write_header(data, curlx_dyn_ptr(&data->state.headerb), + curlx_dyn_len(&data->state.headerb)); + } + curlx_dyn_reset(&data->state.headerb); + + if(status) + return status; + + if(!premature && /* this check is pointless when DONE is called before the + entire operation is complete */ + !conn->bits.retry && + !data->set.connect_only && + (data->req.bytecount + + data->req.headerbytecount - + data->req.deductheadercount) <= 0) { + /* If this connection is not closed to be retried, AND nothing was + read from the HTTP server (that counts), this cannot be right so we + return an error here */ + failf(data, "Empty reply from server"); + /* Mark it as closed to avoid the "left intact" message */ + streamclose(conn, "Empty reply from server"); + return CURLE_GOT_NOTHING; + } + + return CURLE_OK; +} + +/* Determine if we may use HTTP 1.1 for this request. */ +static bool http_may_use_1_1(const struct Curl_easy *data) +{ + const struct connectdata *conn = data->conn; + /* We have seen a previous response for *this* transfer with 1.0, + * on another connection or the same one. */ + if(data->state.http_neg.rcvd_min == 10) + return FALSE; + /* We have seen a previous response on *this* connection with 1.0. */ + if(conn && conn->httpversion_seen == 10) + return FALSE; + /* We want 1.0 and have seen no previous response on *this* connection + with a higher version (maybe no response at all yet). */ + if((data->state.http_neg.only_10) && + (!conn || conn->httpversion_seen <= 10)) + return FALSE; + /* We are not restricted to use 1.0 only. */ + return !data->state.http_neg.only_10; +} + +static unsigned char http_request_version(struct Curl_easy *data) +{ + unsigned char v = Curl_conn_http_version(data, data->conn); + if(!v) { + /* No specific HTTP connection filter installed. */ + v = http_may_use_1_1(data) ? 11 : 10; + } + return v; +} + +static const char *get_http_string(int httpversion) +{ + switch(httpversion) { + case 30: + return "3"; + case 20: + return "2"; + case 11: + return "1.1"; + default: + return "1.0"; + } +} + +CURLcode Curl_add_custom_headers(struct Curl_easy *data, + bool is_connect, int httpversion, + struct dynbuf *req) +{ + struct curl_slist *h[2]; + struct curl_slist *headers; + int numlists = 1; /* by default */ + int i; + +#ifndef CURL_DISABLE_PROXY + enum Curl_proxy_use proxy; + + if(is_connect) + proxy = HEADER_CONNECT; + else + proxy = data->conn->bits.origin_is_proxy ? HEADER_PROXY : HEADER_SERVER; + + switch(proxy) { + case HEADER_SERVER: + h[0] = data->set.headers; + break; + case HEADER_PROXY: + h[0] = data->set.headers; + if(data->set.sep_headers) { + h[1] = data->set.proxyheaders; + numlists++; + } + break; + case HEADER_CONNECT: + if(data->set.sep_headers) + h[0] = data->set.proxyheaders; + else + h[0] = data->set.headers; + break; + case HEADER_CONNECT_UDP: + if(data->set.sep_headers) + h[0] = data->set.proxyheaders; + else + h[0] = data->set.headers; + break; + } +#else + (void)is_connect; + h[0] = data->set.headers; +#endif + + /* loop through one or two lists */ + for(i = 0; i < numlists; i++) { + for(headers = h[i]; headers; headers = headers->next) { + CURLcode result = CURLE_OK; + bool blankheader = FALSE; + struct Curl_str name; + const char *p = headers->data; + const char *origp = p; + + /* explicitly asked to send header without content is done by a header + that ends with a semicolon, but there must be no colon present in the + name */ + if(!curlx_str_until(&p, &name, MAX_HTTP_RESP_HEADER_SIZE, ';') && + !curlx_str_single(&p, ';') && + !curlx_str_single(&p, '\0') && + !memchr(curlx_str(&name), ':', curlx_strlen(&name))) + blankheader = TRUE; + else { + p = origp; + if(!curlx_str_until(&p, &name, MAX_HTTP_RESP_HEADER_SIZE, ':') && + !curlx_str_single(&p, ':')) { + struct Curl_str val; + curlx_str_untilnl(&p, &val, MAX_HTTP_RESP_HEADER_SIZE); + curlx_str_trimblanks(&val); + if(!curlx_strlen(&val)) + /* no content, do not send this */ + continue; + } + else + /* no colon */ + continue; + } + + /* only send this if the contents was non-blank or done special */ + + if(data->state.aptr.host && + /* a Host: header was sent already, do not pass on any custom + Host: header as that will produce *two* in the same + request! */ + curlx_str_casecompare(&name, "Host")) + ; + else if(data->state.httpreq == HTTPREQ_POST_FORM && + /* this header (extended by formdata.c) is sent later */ + curlx_str_casecompare(&name, "Content-Type")) + ; + else if(data->state.httpreq == HTTPREQ_POST_MIME && + /* this header is sent later */ + curlx_str_casecompare(&name, "Content-Type")) + ; + else if(data->req.authneg && + /* while doing auth neg, do not allow the custom length since + we will force length zero then */ + curlx_str_casecompare(&name, "Content-Length")) + ; + else if(curlx_str_casecompare(&name, "Connection")) + /* Connection headers are handled specially */ + ; + else if((httpversion >= 20) && + curlx_str_casecompare(&name, "Transfer-Encoding")) + /* HTTP/2 does not support chunked requests */ + ; + else if((curlx_str_casecompare(&name, "Authorization") || + curlx_str_casecompare(&name, "Cookie")) && + /* be careful of sending this potentially sensitive header to + other hosts */ + !Curl_auth_allowed_to_host(data)) + ; + else if(blankheader) + result = curlx_dyn_addf(req, "%.*s:\r\n", (int)curlx_strlen(&name), + curlx_str(&name)); + else + result = curlx_dyn_addf(req, "%s\r\n", origp); + + if(result) + return result; + } + } + + return CURLE_OK; +} + +#ifndef CURL_DISABLE_PARSEDATE +CURLcode Curl_add_timecondition(struct Curl_easy *data, + struct dynbuf *req) +{ + const struct tm *tm; + struct tm keeptime; + CURLcode result; + char datestr[80]; + const char *condp; + size_t len; + + if(data->set.timecondition == CURL_TIMECOND_NONE) + /* no condition was asked for */ + return CURLE_OK; + + result = curlx_gmtime(data->set.timevalue, &keeptime); + if(result) { + failf(data, "Invalid TIMEVALUE"); + return result; + } + tm = &keeptime; + + switch(data->set.timecondition) { + default: + DEBUGF(infof(data, "invalid time condition")); + return CURLE_BAD_FUNCTION_ARGUMENT; + + case CURL_TIMECOND_IFMODSINCE: + condp = "If-Modified-Since"; + len = 17; + break; + case CURL_TIMECOND_IFUNMODSINCE: + condp = "If-Unmodified-Since"; + len = 19; + break; + case CURL_TIMECOND_LASTMOD: + condp = "Last-Modified"; + len = 13; + break; + } + + if(Curl_checkheaders(data, condp, len)) { + /* A custom header was specified; it will be sent instead. */ + return CURLE_OK; + } + + /* The If-Modified-Since header family should have their times set in + * GMT as RFC2616 defines: "All HTTP date/time stamps MUST be + * represented in Greenwich Mean Time (GMT), without exception. For the + * purposes of HTTP, GMT is exactly equal to UTC (Coordinated Universal + * Time)." (see page 20 of RFC2616). + */ + + /* format: "Tue, 15 Nov 1994 12:45:26 GMT" */ + curl_msnprintf(datestr, sizeof(datestr), + "%s: %s, %02d %s %4d %02d:%02d:%02d GMT\r\n", + condp, + Curl_wkday[tm->tm_wday ? tm->tm_wday - 1 : 6], + tm->tm_mday, + Curl_month[tm->tm_mon], + tm->tm_year + 1900, + tm->tm_hour, + tm->tm_min, + tm->tm_sec); + + result = curlx_dyn_add(req, datestr); + return result; +} +#else +/* disabled */ +CURLcode Curl_add_timecondition(struct Curl_easy *data, + struct dynbuf *req) +{ + (void)data; + (void)req; + return CURLE_OK; +} +#endif + +void Curl_http_method(struct Curl_easy *data, + const char **method, Curl_HttpReq *reqp) +{ + Curl_HttpReq httpreq = (Curl_HttpReq)data->state.httpreq; + const char *request; +#ifndef CURL_DISABLE_WEBSOCKETS + if(data->conn->scheme->protocol & (CURLPROTO_WS | CURLPROTO_WSS)) + httpreq = HTTPREQ_GET; + else +#endif + if((data->conn->scheme->protocol & (PROTO_FAMILY_HTTP | CURLPROTO_FTP)) && + data->state.upload) + httpreq = HTTPREQ_PUT; + + /* Now set the 'request' pointer to the proper request string */ + if(data->set.str[STRING_CUSTOMREQUEST] && + !data->state.http_ignorecustom) { + request = data->set.str[STRING_CUSTOMREQUEST]; + } + else { + if(data->req.no_body) + request = "HEAD"; + else { + DEBUGASSERT((httpreq >= HTTPREQ_GET) && (httpreq <= HTTPREQ_HEAD)); + switch(httpreq) { + case HTTPREQ_POST: + case HTTPREQ_POST_FORM: + case HTTPREQ_POST_MIME: + request = "POST"; + break; + case HTTPREQ_PUT: + request = "PUT"; + break; + default: /* this should never happen */ + case HTTPREQ_GET: + request = "GET"; + break; + case HTTPREQ_HEAD: + request = "HEAD"; + break; + } + } + } + *method = request; + *reqp = httpreq; +} + +static CURLcode http_useragent(struct Curl_easy *data) +{ + /* The User-Agent string might have been allocated already, because + it might have been used in the proxy connect, but if we have got a header + with the user-agent string specified, we erase the previously made string + here. */ + if(Curl_checkheaders(data, STRCONST("User-Agent"))) + curlx_safefree(data->state.aptr.uagent); + return CURLE_OK; +} + +static CURLcode http_set_aptr_host(struct Curl_easy *data) +{ + struct connectdata *conn = data->conn; + struct dynamically_allocated_data *aptr = &data->state.aptr; + const char *ptr; + + curlx_safefree(aptr->host); +#ifndef CURL_DISABLE_COOKIES + curlx_safefree(data->req.cookiehost); +#endif + + ptr = Curl_checkheaders(data, STRCONST("Host")); + if(ptr && + (!data->state.this_is_a_follow || + Curl_peer_equal(data->state.initial_origin, data->state.origin))) { +#ifndef CURL_DISABLE_COOKIES + /* If we have a given custom Host: header, we extract the hostname in + order to possibly use it for cookie reasons later on. We only allow the + custom Host: header if this is NOT a redirect, as setting Host: in the + redirected request is being out on thin ice. Except if the hostname + is the same as the first one! */ + char *cookiehost; + CURLcode result = copy_custom_value(ptr, &cookiehost); + if(result) + return result; + if(!*cookiehost) + /* ignore empty data */ + curlx_free(cookiehost); + else { + /* If the host begins with '[', we start searching for the port after + the bracket has been closed */ + if(*cookiehost == '[') { + char *closingbracket; + /* since the 'cookiehost' is an allocated memory area that will be + freed later we cannot increment the pointer */ + memmove(cookiehost, cookiehost + 1, strlen(cookiehost) - 1); + closingbracket = strchr(cookiehost, ']'); + if(closingbracket) + *closingbracket = 0; + } + else { + int startsearch = 0; + char *colon = strchr(cookiehost + startsearch, ':'); + if(colon) + *colon = 0; /* The host must not include an embedded port number */ + } + data->req.cookiehost = cookiehost; + } +#endif + + if(!curl_strequal("Host:", ptr)) { + aptr->host = curl_maprintf("Host:%s\r\n", &ptr[5]); + if(!aptr->host) + return CURLE_OUT_OF_MEMORY; + } + } + else { + /* Use the hostname as present in the URL if it was IPv6. */ + char *host = (data->state.origin->user_hostname[0] == '[') ? + data->state.origin->user_hostname : data->state.origin->hostname; + + if(((conn->given->protocol & (CURLPROTO_HTTPS | CURLPROTO_WSS)) && + (data->state.origin->port == PORT_HTTPS)) || + ((conn->given->protocol & (CURLPROTO_HTTP | CURLPROTO_WS)) && + (data->state.origin->port == PORT_HTTP))) + /* if(HTTPS on port 443) OR (HTTP on port 80) then do not include + the port number in the host string */ + aptr->host = curl_maprintf("Host: %s\r\n", host); + else + aptr->host = curl_maprintf("Host: %s:%d\r\n", + host, data->state.origin->port); + + if(!aptr->host) + /* without Host: we cannot make a nice request */ + return CURLE_OUT_OF_MEMORY; + } + return CURLE_OK; +} + +/* + * Append the request-target to the HTTP request + */ +static CURLcode http_target(struct Curl_easy *data, + struct dynbuf *r) +{ + CURLcode result = CURLE_OK; + const char *path = data->state.up.path; + const char *query = data->state.up.query; +#ifndef CURL_DISABLE_PROXY + struct connectdata *conn = data->conn; +#endif + + if(data->set.str[STRING_TARGET]) { + path = data->set.str[STRING_TARGET]; + query = NULL; + } + +#ifndef CURL_DISABLE_PROXY + if(conn->bits.origin_is_proxy) { + /* Using a proxy but does not tunnel through it */ + + /* The path sent to the proxy is in fact the entire URL, but if the remote + host is a IDN-name, we must make sure that the request we produce only + uses the encoded hostname! */ + + /* and no fragment part */ + CURLUcode uc; + char *url; + CURLU *h = curl_url_dup(data->state.uh); + if(!h) + return CURLE_OUT_OF_MEMORY; + + if(data->state.origin->user_hostname != data->state.origin->hostname) { + uc = curl_url_set(h, CURLUPART_HOST, data->state.origin->hostname, 0); + if(uc) { + curl_url_cleanup(h); + return CURLE_OUT_OF_MEMORY; + } + } + uc = curl_url_set(h, CURLUPART_FRAGMENT, NULL, 0); + if(uc) { + curl_url_cleanup(h); + return CURLE_OUT_OF_MEMORY; + } + + if(curl_strequal("http", data->state.up.scheme)) { + /* when getting HTTP, we do not want the userinfo the URL */ + uc = curl_url_set(h, CURLUPART_USER, NULL, 0); + if(uc) { + curl_url_cleanup(h); + return CURLE_OUT_OF_MEMORY; + } + uc = curl_url_set(h, CURLUPART_PASSWORD, NULL, 0); + if(uc) { + curl_url_cleanup(h); + return CURLE_OUT_OF_MEMORY; + } + } + else if(data->state.creds && (data->state.creds->source != CREDS_URL)) { + /* credentials not from the URL need to be set */ + uc = curl_url_set(h, CURLUPART_USER, + data->state.creds->user, CURLU_URLENCODE); + if(!uc) + uc = curl_url_set(h, CURLUPART_PASSWORD, + data->state.creds->passwd, CURLU_URLENCODE); + if(uc) { + curl_url_cleanup(h); + return Curl_uc_to_curlcode(uc); + } + } + + /* Extract the URL to use in the request. */ + uc = curl_url_get(h, CURLUPART_URL, &url, CURLU_NO_DEFAULT_PORT); + if(uc) { + curl_url_cleanup(h); + return CURLE_OUT_OF_MEMORY; + } + + curl_url_cleanup(h); + + /* target or URL */ + result = curlx_dyn_add(r, data->set.str[STRING_TARGET] ? + data->set.str[STRING_TARGET] : url); + curlx_free(url); + if(result) + return result; + + if(curl_strequal("ftp", data->state.up.scheme) && + data->set.proxy_transfer_mode) { + /* when doing ftp, append ;type= if not present */ + size_t len = strlen(path); + bool type_present = FALSE; + if((len >= 7) && !memcmp(&path[len - 7], ";type=", 6)) { + switch(Curl_raw_toupper(path[len - 1])) { + case 'A': + case 'D': + case 'I': + type_present = TRUE; + break; + } + } + if(!type_present) { + result = curlx_dyn_addf(r, ";type=%c", + data->state.prefer_ascii ? 'a' : 'i'); + if(result) + return result; + } + } + } + + else +#endif + { + result = curlx_dyn_add(r, path); + if(result) + return result; + if(query) + result = curlx_dyn_addf(r, "?%s", query); + } + + return result; +} + +#if !defined(CURL_DISABLE_MIME) || !defined(CURL_DISABLE_FORM_API) +static CURLcode set_post_reader(struct Curl_easy *data, Curl_HttpReq httpreq) +{ + CURLcode result; + + switch(httpreq) { +#ifndef CURL_DISABLE_MIME + case HTTPREQ_POST_MIME: + data->state.mimepost = data->set.mimepostp; + break; +#endif +#ifndef CURL_DISABLE_FORM_API + case HTTPREQ_POST_FORM: + /* Convert the form structure into a mime structure, then keep + the conversion */ + if(!data->state.formp) { + data->state.formp = curlx_calloc(1, sizeof(curl_mimepart)); + if(!data->state.formp) + return CURLE_OUT_OF_MEMORY; + Curl_mime_cleanpart(data->state.formp); + result = Curl_getformdata(data, data->state.formp, data->set.httppost, + data->state.fread_func); + if(result) { + curlx_safefree(data->state.formp); + return result; + } + data->state.mimepost = data->state.formp; + } + break; +#endif + default: + data->state.mimepost = NULL; + break; + } + + switch(httpreq) { + case HTTPREQ_POST_FORM: + case HTTPREQ_POST_MIME: + /* This is form posting using mime data. */ +#ifndef CURL_DISABLE_MIME + if(data->state.mimepost) { + const char *cthdr = Curl_checkheaders(data, STRCONST("Content-Type")); + + /* Read and seek body only. */ + data->state.mimepost->flags |= MIME_BODY_ONLY; + + /* Prepare the mime structure headers & set content type. */ + + if(cthdr) + for(cthdr += 13; *cthdr == ' '; cthdr++) + ; + else if(data->state.mimepost->kind == MIMEKIND_MULTIPART) + cthdr = "multipart/form-data"; + + curl_mime_headers(data->state.mimepost, data->set.headers, 0); + result = Curl_mime_prepare_headers(data, data->state.mimepost, cthdr, + NULL, MIMESTRATEGY_FORM); + if(result) + return result; + curl_mime_headers(data->state.mimepost, NULL, 0); + result = Curl_creader_set_mime(data, data->state.mimepost); + if(result) + return result; + } + else +#endif + { + result = Curl_creader_set_null(data); + } + data->state.infilesize = Curl_creader_total_length(data); + return result; + + default: + return Curl_creader_set_null(data); + } + /* never reached */ +} +#endif + +static CURLcode set_reader(struct Curl_easy *data, Curl_HttpReq httpreq) +{ + CURLcode result = CURLE_OK; + curl_off_t postsize = data->state.infilesize; + + DEBUGASSERT(data->conn); + + if(data->req.authneg) { + return Curl_creader_set_null(data); + } + + switch(httpreq) { + case HTTPREQ_PUT: /* Let's PUT the data to the server! */ + return postsize ? Curl_creader_set_fread(data, postsize) : + Curl_creader_set_null(data); + +#if !defined(CURL_DISABLE_MIME) || !defined(CURL_DISABLE_FORM_API) + case HTTPREQ_POST_FORM: + case HTTPREQ_POST_MIME: + return set_post_reader(data, httpreq); +#endif + + case HTTPREQ_POST: + /* this is the simple POST, using x-www-form-urlencoded style */ + /* the size of the post body */ + if(!postsize) { + result = Curl_creader_set_null(data); + } + else if(data->set.postfields) { + size_t plen = curlx_sotouz_range(postsize, 0, SIZE_MAX); + if(plen == SIZE_MAX) + return CURLE_OUT_OF_MEMORY; + else if(plen) + result = Curl_creader_set_buf(data, data->set.postfields, plen); + else + result = Curl_creader_set_null(data); + } + else { + /* we read the bytes from the callback. In case "chunked" encoding + * is forced by the application, we disregard `postsize`. This is + * a backward compatibility decision to earlier versions where + * chunking disregarded this. See issue #13229. */ + bool chunked = FALSE; + char *ptr = Curl_checkheaders(data, STRCONST("Transfer-Encoding")); + if(ptr) { + /* Some kind of TE is requested, check if 'chunked' is chosen */ + chunked = Curl_compareheader(ptr, STRCONST("Transfer-Encoding:"), + STRCONST("chunked")); + } + result = Curl_creader_set_fread(data, chunked ? -1 : postsize); + } + return result; + + default: + /* HTTP GET/HEAD download, has no body, needs no Content-Length */ + data->state.infilesize = 0; + return Curl_creader_set_null(data); + } + /* not reached */ +} + +static CURLcode http_resume(struct Curl_easy *data, Curl_HttpReq httpreq) +{ + if((HTTPREQ_POST == httpreq || HTTPREQ_PUT == httpreq) && + data->state.resume_from) { + /********************************************************************** + * Resuming upload in HTTP means that we PUT or POST and that we have + * got a resume_from value set. The resume value has already created + * a Range: header that will be passed along. We need to "fast forward" + * the file the given number of bytes and decrease the assume upload + * file size before we continue this venture in the dark lands of HTTP. + * Resuming mime/form posting at an offset > 0 has no sense and is ignored. + *********************************************************************/ + + if(data->state.resume_from < 0) { + /* + * This is meant to get the size of the present remote-file by itself. + * We do not support this now. Bail out! + */ + data->state.resume_from = 0; + } + + if(data->state.resume_from && !data->req.authneg) { + /* only act on the first request */ + CURLcode result; + result = Curl_creader_resume_from(data, data->state.resume_from); + if(result) { + failf(data, "Unable to resume from offset %" FMT_OFF_T, + data->state.resume_from); + return result; + } + } + } + return CURLE_OK; +} + +static CURLcode http_req_set_TE(struct Curl_easy *data, + struct dynbuf *req, + int httpversion) +{ + CURLcode result = CURLE_OK; + const char *ptr; + + ptr = Curl_checkheaders(data, STRCONST("Transfer-Encoding")); + if(ptr) { + /* Some kind of TE is requested, check if 'chunked' is chosen */ + data->req.upload_chunky = + Curl_compareheader(ptr, + STRCONST("Transfer-Encoding:"), STRCONST("chunked")); + if(data->req.upload_chunky && (httpversion >= 20)) { + infof(data, "suppressing chunked transfer encoding on connection " + "using HTTP version 2 or higher"); + data->req.upload_chunky = FALSE; + } + } + else { + curl_off_t req_clen = Curl_creader_total_length(data); + + if(req_clen < 0) { + /* indeterminate request content length */ + if(httpversion > 10) { + /* On HTTP/1.1, enable chunked, on HTTP/2 and later we do not + * need it */ + data->req.upload_chunky = (httpversion < 20); + } + else { + failf(data, "Chunky upload is not supported by HTTP 1.0"); + return CURLE_UPLOAD_FAILED; + } + } + else { + /* else, no chunky upload */ + data->req.upload_chunky = FALSE; + } + + if(data->req.upload_chunky) + result = curlx_dyn_add(req, "Transfer-Encoding: chunked\r\n"); + } + return result; +} + +static CURLcode addexpect(struct Curl_easy *data, struct dynbuf *r, + int httpversion, bool *announced_exp100) +{ + CURLcode result; + char *ptr; + + *announced_exp100 = FALSE; + /* Avoid Expect: 100-continue if Upgrade: is used */ + if(data->req.upgr101 != UPGR101_NONE) + return CURLE_OK; + + /* For really small puts we do not use Expect: headers at all, and for + the somewhat bigger ones we allow the app to disable it. Make + sure that the expect100header is always set to the preferred value + here. */ + ptr = Curl_checkheaders(data, STRCONST("Expect")); + if(ptr) { + *announced_exp100 = + Curl_compareheader(ptr, STRCONST("Expect:"), STRCONST("100-continue")); + } + else if(!data->state.disableexpect && (httpversion == 11)) { + /* if not doing HTTP 1.0 or version 2, or disabled explicitly, we add an + Expect: 100-continue to the headers which actually speeds up post + operations (as there is one packet coming back from the web server) */ + curl_off_t client_len = Curl_creader_client_length(data); + if(client_len > EXPECT_100_THRESHOLD || client_len < 0) { + result = curlx_dyn_addn(r, STRCONST("Expect: 100-continue\r\n")); + if(result) + return result; + *announced_exp100 = TRUE; + } + } + return CURLE_OK; +} + +static CURLcode http_add_content_hds(struct Curl_easy *data, + struct dynbuf *r, + int httpversion, + Curl_HttpReq httpreq) +{ + CURLcode result = CURLE_OK; + curl_off_t req_clen; + bool announced_exp100 = FALSE; + + DEBUGASSERT(data->conn); + if(data->req.upload_chunky) { + result = Curl_httpchunk_add_reader(data); + if(result) + return result; + } + + /* Get the request body length that has been set up */ + req_clen = Curl_creader_total_length(data); + switch(httpreq) { + case HTTPREQ_PUT: + case HTTPREQ_POST: +#if !defined(CURL_DISABLE_MIME) || !defined(CURL_DISABLE_FORM_API) + case HTTPREQ_POST_FORM: + case HTTPREQ_POST_MIME: +#endif + /* We only set Content-Length and allow a custom Content-Length if + we do not upload data chunked, as RFC2616 forbids us to set both + kinds of headers (Transfer-Encoding: chunked and Content-Length). + We do not override a custom "Content-Length" header, but during + authentication negotiation that header is suppressed. + */ + if(req_clen >= 0 && !data->req.upload_chunky && + (data->req.authneg || + !Curl_checkheaders(data, STRCONST("Content-Length")))) { + /* we allow replacing this header if not during auth negotiation, + although it is not wise to actually set your own */ + result = curlx_dyn_addf(r, "Content-Length: %" FMT_OFF_T "\r\n", + req_clen); + } + if(result) + goto out; + +#ifndef CURL_DISABLE_MIME + /* Output mime-generated headers. */ + if(data->state.mimepost && + ((httpreq == HTTPREQ_POST_FORM) || (httpreq == HTTPREQ_POST_MIME))) { + struct curl_slist *hdr; + + for(hdr = data->state.mimepost->curlheaders; hdr; hdr = hdr->next) { + result = curlx_dyn_addf(r, "%s\r\n", hdr->data); + if(result) + goto out; + } + } +#endif + if(httpreq == HTTPREQ_POST) { + if(!Curl_checkheaders(data, STRCONST("Content-Type"))) { + result = curlx_dyn_addn(r, STRCONST("Content-Type: application/" + "x-www-form-urlencoded\r\n")); + if(result) + goto out; + } + } + result = addexpect(data, r, httpversion, &announced_exp100); + if(result) + goto out; + break; + default: + break; + } + + Curl_pgrsSetUploadSize(data, req_clen); + if(announced_exp100) + result = http_exp100_add_reader(data); + +out: + return result; +} + +#ifndef CURL_DISABLE_COOKIES + +static CURLcode http_cookies(struct Curl_easy *data, + struct dynbuf *r) +{ + CURLcode result = CURLE_OK; + char *addcookies = NULL; + bool linecap = FALSE; + if(data->set.str[STRING_COOKIE] && + !Curl_checkheaders(data, STRCONST("Cookie")) && + Curl_auth_allowed_to_host(data)) + addcookies = data->set.str[STRING_COOKIE]; + + if(data->cookies || addcookies) { + struct Curl_llist list; + int count = 0; + + if(data->cookies && data->state.cookie_engine) { + bool okay; + const char *host = data->req.cookiehost ? + data->req.cookiehost : data->state.origin->hostname; + Curl_share_lock(data, CURL_LOCK_DATA_COOKIE, CURL_LOCK_ACCESS_SINGLE); + result = Curl_cookie_getlist(data, &okay, host, &list); + if(!result && okay) { + struct Curl_llist_node *n; + size_t clen = 8; /* hold the size of the generated Cookie: header */ + + /* loop through all cookies that matched */ + for(n = Curl_llist_head(&list); n; n = Curl_node_next(n)) { + struct Cookie *co = Curl_node_elem(n); + if(co->value) { + size_t add; + if(!count) { + result = curlx_dyn_addn(r, STRCONST("Cookie: ")); + if(result) + break; + } + add = strlen(co->name) + strlen(co->value) + 1; + if(clen + add >= MAX_COOKIE_HEADER_LEN) { + infof(data, "Restricted outgoing cookies due to header size, " + "'%s' not sent", co->name); + linecap = TRUE; + break; + } + result = curlx_dyn_addf(r, "%s%s=%s", count ? "; " : "", + co->name, co->value); + if(result) + break; + clen += add + (count ? 2 : 0); + count++; + } + } + Curl_llist_destroy(&list, NULL); + } + Curl_share_unlock(data, CURL_LOCK_DATA_COOKIE); + } + if(addcookies && !result && !linecap) { + if(!count) + result = curlx_dyn_addn(r, STRCONST("Cookie: ")); + if(!result) { + result = curlx_dyn_addf(r, "%s%s", count ? "; " : "", addcookies); + count++; + } + } + if(count && !result) + result = curlx_dyn_addn(r, STRCONST("\r\n")); + + if(result) + return result; + } + return result; +} +#else +#define http_cookies(a, b) CURLE_OK +#endif + +static CURLcode http_range(struct Curl_easy *data, + Curl_HttpReq httpreq) +{ + if(data->state.use_range) { + /* + * A range is selected. We use different headers whether we are downloading + * or uploading and we always let customized headers override our internal + * ones if any such are specified. + */ + if(((httpreq == HTTPREQ_GET) || (httpreq == HTTPREQ_HEAD)) && + !Curl_checkheaders(data, STRCONST("Range"))) { + /* if a line like this was already allocated, free the previous one */ + curlx_free(data->state.aptr.rangeline); + data->state.aptr.rangeline = curl_maprintf("Range: bytes=%s\r\n", + data->state.range); + if(!data->state.aptr.rangeline) + return CURLE_OUT_OF_MEMORY; + } + else if((httpreq == HTTPREQ_POST || httpreq == HTTPREQ_PUT) && + !Curl_checkheaders(data, STRCONST("Content-Range"))) { + curl_off_t req_clen = Curl_creader_total_length(data); + /* if a line like this was already allocated, free the previous one */ + curlx_free(data->state.aptr.rangeline); + + if(data->set.set_resume_from < 0) { + /* Upload resume was asked for, but we do not know the size of the + remote part so we tell the server (and act accordingly) that we + upload the whole file (again) */ + data->state.aptr.rangeline = + curl_maprintf("Content-Range: bytes 0-%" FMT_OFF_T "/" + "%" FMT_OFF_T "\r\n", req_clen - 1, req_clen); + } + else if(data->state.resume_from) { + /* This is because "resume" was selected */ + /* Not sure if we want to send this header during authentication + * negotiation, but test1084 checks for it. In which case we have a + * "null" client reader installed that gives an unexpected length. */ + curl_off_t total_len = data->req.authneg ? + data->state.infilesize : + (data->state.resume_from + req_clen); + data->state.aptr.rangeline = + curl_maprintf("Content-Range: bytes %s%" FMT_OFF_T "/" + "%" FMT_OFF_T "\r\n", + data->state.range, total_len - 1, total_len); + } + else { + /* Range was selected and then we pass the incoming range and append + total size */ + data->state.aptr.rangeline = + curl_maprintf("Content-Range: bytes %s/%" FMT_OFF_T "\r\n", + data->state.range, req_clen); + } + if(!data->state.aptr.rangeline) + return CURLE_OUT_OF_MEMORY; + } + } + return CURLE_OK; +} + +static CURLcode http_firstwrite(struct Curl_easy *data) +{ + struct connectdata *conn = data->conn; + struct SingleRequest *k = &data->req; + + if(data->req.newurl) { + if(conn->bits.close) { + /* Abort after the headers if "follow Location" is set + and we are set to close anyway. */ + CURL_REQ_CLEAR_RECV(data); + k->done = TRUE; + return CURLE_OK; + } + /* We have a new URL to load, but since we want to be able to reuse this + connection properly, we read the full response in "ignore more" */ + k->ignorebody = TRUE; + infof(data, "Ignoring the response-body"); + } + if(data->state.resume_from && !k->content_range && + (data->state.httpreq == HTTPREQ_GET) && + !k->ignorebody) { + + if(k->size == data->state.resume_from) { + /* The resume point is at the end of file, consider this fine even if it + does not allow resume from here. */ + infof(data, "The entire document is already downloaded"); + streamclose(conn, "already downloaded"); + /* Abort download */ + CURL_REQ_CLEAR_RECV(data); + k->done = TRUE; + return CURLE_OK; + } + + /* we wanted to resume a download, although the server does not seem to + * support this and we did this with a GET (if it was not a GET we did a + * POST or PUT resume) */ + failf(data, "HTTP server does not seem to support " + "byte ranges. Cannot resume."); + return CURLE_RANGE_ERROR; + } + + if(data->set.timecondition && !data->state.range) { + /* A time condition has been set AND no ranges have been requested. This + seems to be what chapter 13.3.4 of RFC 2616 defines to be the correct + action for an HTTP/1.1 client */ + + if(!Curl_meets_timecondition(data, k->timeofdoc)) { + k->done = TRUE; + /* We are simulating an HTTP 304 from server so we return + what should have been returned from the server */ + data->info.httpcode = 304; + infof(data, "Simulate an HTTP 304 response"); + /* we abort the transfer before it is completed == we ruin the + reuse ability. Close the connection */ + streamclose(conn, "Simulated 304 handling"); + return CURLE_OK; + } + } /* we have a time condition */ + + return CURLE_OK; +} + +static CURLcode http_check_new_conn(struct Curl_easy *data) +{ + struct connectdata *conn = data->conn; + const char *info_version = NULL; + const char *alpn; + CURLcode result; + + alpn = Curl_conn_get_alpn_negotiated(data, conn); + if(alpn && !strcmp("h3", alpn)) { +#ifndef CURL_DISABLE_PROXY + if(!conn->bits.origin_is_proxy) +#endif + DEBUGASSERT(Curl_conn_http_version(data, conn) == 30); + info_version = "HTTP/3"; + } + else if(alpn && !strcmp("h2", alpn)) { +#ifndef CURL_DISABLE_PROXY + if((Curl_conn_http_version(data, conn) != 20) && + conn->bits.origin_is_proxy) { + result = Curl_http2_switch(data); + if(result) + return result; + } + else +#endif + DEBUGASSERT(Curl_conn_http_version(data, conn) == 20); + info_version = "HTTP/2"; + } + else { + /* Check if user wants to use HTTP/2 with clear TCP */ + if(Curl_http2_may_switch(data)) { + DEBUGF(infof(data, "HTTP/2 over clean TCP")); + result = Curl_http2_switch(data); + if(result) + return result; + info_version = "HTTP/2"; + /* There is no ALPN here, but the connection is now definitely h2 */ + conn->httpversion_seen = 20; + Curl_conn_set_multiplex(conn); + } + else + info_version = "HTTP/1.x"; + } + + if(info_version) + infof(data, "using %s", info_version); + return CURLE_OK; +} + +static CURLcode http_add_connection_hd(struct Curl_easy *data, + struct dynbuf *req) +{ + struct curl_slist *head; + const char *sep = "Connection: "; + CURLcode result = CURLE_OK; + size_t rlen = curlx_dyn_len(req); + bool skip; + + /* Add the 1st custom "Connection: " header, if there is one */ + for(head = data->set.headers; head; head = head->next) { + if(curl_strnequal(head->data, "Connection", 10) && + Curl_headersep(head->data[10]) && + !http_header_is_empty(head->data)) { + char *value; + result = copy_custom_value(head->data, &value); + if(result) + return result; + result = curlx_dyn_addf(req, "%s%s", sep, value); + sep = ", "; + curlx_free(value); + break; /* leave, having added 1st one */ + } + } + + /* add our internal Connection: header values, if we have any */ + if(!result && data->state.http_hd_te) { + result = curlx_dyn_addf(req, "%s%s", sep, "TE"); + sep = ", "; + } + if(!result && data->state.http_hd_upgrade) { + result = curlx_dyn_addf(req, "%s%s", sep, "Upgrade"); + sep = ", "; + } + if(!result && data->state.http_hd_h2_settings) { + result = curlx_dyn_addf(req, "%s%s", sep, "HTTP2-Settings"); + } + if(!result && (rlen < curlx_dyn_len(req))) + result = curlx_dyn_addn(req, STRCONST("\r\n")); + if(result) + return result; + + /* Add all user-defined Connection: headers after the first */ + skip = TRUE; + for(head = data->set.headers; head; head = head->next) { + if(curl_strnequal(head->data, "Connection", 10) && + Curl_headersep(head->data[10]) && + !http_header_is_empty(head->data)) { + if(skip) { + skip = FALSE; + continue; + } + result = curlx_dyn_addf(req, "%s\r\n", head->data); + if(result) + return result; + } + } + + return CURLE_OK; +} + +/* Header identifier in order we send them by default */ +typedef enum { + H1_HD_REQUEST, + H1_HD_HOST, +#ifndef CURL_DISABLE_PROXY + H1_HD_PROXY_AUTH, +#endif + H1_HD_AUTH, + H1_HD_RANGE, + H1_HD_USER_AGENT, + H1_HD_ACCEPT, + H1_HD_TE, + H1_HD_ACCEPT_ENCODING, + H1_HD_REFERER, +#ifndef CURL_DISABLE_PROXY + H1_HD_PROXY_CONNECTION, +#endif + H1_HD_TRANSFER_ENCODING, +#ifndef CURL_DISABLE_ALTSVC + H1_HD_ALT_USED, +#endif + H1_HD_UPGRADE, + H1_HD_COOKIES, + H1_HD_CONDITIONALS, + H1_HD_CUSTOM, + H1_HD_CONTENT, + H1_HD_CONNECTION, + H1_HD_LAST /* the last, empty header line */ +} http_hd_t; + +static CURLcode http_add_hd(struct Curl_easy *data, + struct dynbuf *req, + http_hd_t id, + unsigned char httpversion, + const char *method, + Curl_HttpReq httpreq) +{ + CURLcode result = CURLE_OK; +#if !defined(CURL_DISABLE_ALTSVC) || \ + !defined(CURL_DISABLE_PROXY) || \ + !defined(CURL_DISABLE_WEBSOCKETS) + struct connectdata *conn = data->conn; +#endif + switch(id) { + case H1_HD_REQUEST: + /* add the main request stuff */ + /* GET/HEAD/POST/PUT */ + result = curlx_dyn_addf(req, "%s ", method); + if(!result) + result = http_target(data, req); + if(!result) + result = curlx_dyn_addf(req, " HTTP/%s\r\n", + get_http_string(httpversion)); + break; + + case H1_HD_HOST: + if(data->state.aptr.host) + result = curlx_dyn_add(req, data->state.aptr.host); + break; + +#ifndef CURL_DISABLE_PROXY + case H1_HD_PROXY_AUTH: + if(data->req.hd_proxy_auth) + result = curlx_dyn_add(req, data->req.hd_proxy_auth); + break; +#endif + + case H1_HD_AUTH: + if(data->req.hd_auth) + result = curlx_dyn_add(req, data->req.hd_auth); + break; + + case H1_HD_RANGE: + if(data->state.use_range && data->state.aptr.rangeline) + result = curlx_dyn_add(req, data->state.aptr.rangeline); + break; + + case H1_HD_USER_AGENT: + if(data->set.str[STRING_USERAGENT] && /* User-Agent: */ + *data->set.str[STRING_USERAGENT] && + data->state.aptr.uagent) + result = curlx_dyn_add(req, data->state.aptr.uagent); + break; + + case H1_HD_ACCEPT: + if(!Curl_checkheaders(data, STRCONST("Accept"))) + result = curlx_dyn_add(req, "Accept: */*\r\n"); + break; + + case H1_HD_TE: +#ifdef HAVE_LIBZ + if(!Curl_checkheaders(data, STRCONST("TE")) && + data->set.http_transfer_encoding) { + data->state.http_hd_te = TRUE; + result = curlx_dyn_add(req, "TE: gzip\r\n"); + } +#endif + break; + + case H1_HD_ACCEPT_ENCODING: + curlx_safefree(data->state.aptr.accept_encoding); + if(!Curl_checkheaders(data, STRCONST("Accept-Encoding")) && + data->set.str[STRING_ENCODING]) + result = curlx_dyn_addf(req, "Accept-Encoding: %s\r\n", + data->set.str[STRING_ENCODING]); + break; + + case H1_HD_REFERER: + curlx_safefree(data->state.aptr.ref); + if(Curl_bufref_ptr(&data->state.referer) && + !Curl_checkheaders(data, STRCONST("Referer"))) + result = curlx_dyn_addf(req, "Referer: %s\r\n", + Curl_bufref_ptr(&data->state.referer)); + break; + +#ifndef CURL_DISABLE_PROXY + case H1_HD_PROXY_CONNECTION: + if(conn->bits.origin_is_proxy && + !Curl_checkheaders(data, STRCONST("Proxy-Connection")) && + !Curl_checkProxyheaders(data, data->conn, STRCONST("Proxy-Connection"))) + result = curlx_dyn_add(req, "Proxy-Connection: Keep-Alive\r\n"); + break; +#endif + + case H1_HD_TRANSFER_ENCODING: + result = http_req_set_TE(data, req, httpversion); + break; + +#ifndef CURL_DISABLE_ALTSVC + case H1_HD_ALT_USED: + if(conn->bits.altused && conn->via_peer && + !Curl_checkheaders(data, STRCONST("Alt-Used"))) + result = curlx_dyn_addf(req, "Alt-Used: %s:%u\r\n", + conn->via_peer->hostname, conn->via_peer->port); + break; +#endif + + case H1_HD_UPGRADE: + if(!Curl_conn_is_ssl(data->conn, FIRSTSOCKET) && (httpversion < 20) && + (data->state.http_neg.wanted & CURL_HTTP_V2x) && + data->state.http_neg.h2_upgrade) { + /* append HTTP2 upgrade magic stuff to the HTTP request if it is not done + over SSL */ + result = Curl_http2_request_upgrade(req, data); + } +#ifndef CURL_DISABLE_WEBSOCKETS + if(!result && conn->scheme->protocol & (CURLPROTO_WS | CURLPROTO_WSS)) + result = Curl_ws_request(data, req); +#endif + break; + + case H1_HD_COOKIES: + result = http_cookies(data, req); + break; + + case H1_HD_CONDITIONALS: + result = Curl_add_timecondition(data, req); + break; + + case H1_HD_CUSTOM: + result = Curl_add_custom_headers(data, FALSE, httpversion, req); + break; + + case H1_HD_CONTENT: + result = http_add_content_hds(data, req, httpversion, httpreq); + break; + + case H1_HD_CONNECTION: { + result = http_add_connection_hd(data, req); + break; + } + + case H1_HD_LAST: + result = curlx_dyn_addn(req, STRCONST("\r\n")); + break; + } + return result; +} + +/* + * Curl_http() gets called from the generic multi_do() function when an HTTP + * request is to be performed. This creates and sends a properly constructed + * HTTP request. + */ +CURLcode Curl_http(struct Curl_easy *data, bool *done) +{ + CURLcode result = CURLE_OK; + Curl_HttpReq httpreq; + const char *method; + struct dynbuf req; + unsigned char httpversion; + size_t hd_id; + + /* Always consider the DO phase done after this function call, even if there + may be parts of the request that are not yet sent, since we can deal with + the rest of the request in the PERFORM phase. */ + *done = TRUE; + /* initialize a dynamic send-buffer */ + curlx_dyn_init(&req, DYN_HTTP_REQUEST); + /* make sure the header buffer is reset - if there are leftovers from a + previous transfer */ + curlx_dyn_reset(&data->state.headerb); + data->state.maybe_folded = FALSE; + + if(!data->conn->bits.reuse) { + result = http_check_new_conn(data); + if(result) + goto out; + } + + /* Add collecting of headers written to client. For a new connection, + * we might have done that already, but reuse + * or multiplex needs it here as well. */ + result = Curl_headers_init(data); + if(result) + goto out; + + data->state.http_hd_te = FALSE; + data->state.http_hd_upgrade = FALSE; + data->state.http_hd_h2_settings = FALSE; + + /* what kind of request do we need to send? */ + Curl_http_method(data, &method, &httpreq); + + /* select host to send */ + result = http_set_aptr_host(data); + /* setup the authentication headers, how that method and host are known */ + if(!result) + result = Curl_http_output_auth(data, data->conn, method, httpreq, + data->state.up.path, + data->state.up.query, FALSE); + if(!result) + result = http_useragent(data); + /* Setup input reader, resume information and ranges */ + if(!result) + result = set_reader(data, httpreq); + if(!result) + result = http_resume(data, httpreq); + if(!result) + result = http_range(data, httpreq); + if(result) + goto out; + + httpversion = http_request_version(data); + /* Add request line and all headers to `req` */ + for(hd_id = 0; hd_id <= H1_HD_LAST; ++hd_id) { + result = http_add_hd(data, &req, (http_hd_t)hd_id, + httpversion, method, httpreq); + if(result) + goto out; + } + + /* setup variables for the upcoming transfer and send */ + Curl_xfer_setup_sendrecv(data, FIRSTSOCKET, -1); + result = Curl_req_send(data, &req, httpversion); + + if((httpversion >= 20) && data->req.upload_chunky) + /* upload_chunky was set above to set up the request in a chunky fashion, + but is disabled here again to avoid that the chunked encoded version is + actually used when sending the request body over h2 */ + data->req.upload_chunky = FALSE; + +out: + if(result == CURLE_TOO_LARGE) + failf(data, "HTTP request too large"); + + curlx_dyn_free(&req); + return result; +} + +typedef enum { + STATUS_UNKNOWN, /* not enough data to tell yet */ + STATUS_DONE, /* a status line was read */ + STATUS_BAD /* not a status line */ +} statusline; + +/* Check a string for a prefix. Check no more than 'len' bytes */ +static bool checkprefixmax(const char *prefix, const char *buffer, size_t len) +{ + size_t ch = CURLMIN(strlen(prefix), len); + return curl_strnequal(prefix, buffer, ch); +} + +/* + * checkhttpprefix() + * + * Returns TRUE if member of the list matches prefix of string + */ +static statusline checkhttpprefix(struct Curl_easy *data, + const char *s, size_t len) +{ + struct curl_slist *head = data->set.http200aliases; + statusline rc = STATUS_BAD; + statusline onmatch = len >= 5 ? STATUS_DONE : STATUS_UNKNOWN; + + while(head) { + if(checkprefixmax(head->data, s, len)) { + rc = onmatch; + break; + } + head = head->next; + } + + if((rc != STATUS_DONE) && (checkprefixmax("HTTP/", s, len))) + rc = onmatch; + + return rc; +} + +#ifndef CURL_DISABLE_RTSP +static statusline checkrtspprefix(struct Curl_easy *data, + const char *s, size_t len) +{ + statusline status = STATUS_BAD; + statusline onmatch = len >= 5 ? STATUS_DONE : STATUS_UNKNOWN; + (void)data; + if(checkprefixmax("RTSP/", s, len)) + status = onmatch; + + return status; +} +#endif /* CURL_DISABLE_RTSP */ + +static statusline checkprotoprefix(struct Curl_easy *data, + struct connectdata *conn, + const char *s, size_t len) +{ +#ifndef CURL_DISABLE_RTSP + if(conn->scheme->protocol & CURLPROTO_RTSP) + return checkrtspprefix(data, s, len); +#else + (void)conn; +#endif /* CURL_DISABLE_RTSP */ + + return checkhttpprefix(data, s, len); +} + +/* HTTP header has field name `n` (a string constant) */ +#define HD_IS(hd, hdlen, n) \ + (((hdlen) >= (sizeof(n) - 1)) && curl_strnequal(n, hd, sizeof(n) - 1)) + +#define HD_VAL(hd, hdlen, n) \ + ((((hdlen) >= (sizeof(n) - 1)) && (hd) && \ + curl_strnequal(n, hd, sizeof(n) - 1)) ? ((hd) + (sizeof(n) - 1)) : NULL) + +/* HTTP header has field name `n` (a string constant) and contains `v` + * (a string constant) in its value(s) */ +#define HD_IS_AND_SAYS(hd, hdlen, n, v) \ + (HD_IS(hd, hdlen, n) && \ + ((hdlen) > ((sizeof(n) - 1) + (sizeof(v) - 1))) && \ + Curl_compareheader(hd, STRCONST(n), STRCONST(v))) + +/* + * http_header_a() parses a single response header starting with A. + */ +static CURLcode http_header_a(struct Curl_easy *data, + const char *hd, size_t hdlen) +{ +#ifndef CURL_DISABLE_ALTSVC + const char *v; + v = (data->asi && + (Curl_xfer_is_secure(data) || +#ifdef DEBUGBUILD + /* allow debug builds to circumvent the HTTPS restriction */ + getenv("CURL_ALTSVC_HTTP") +#else + 0 +#endif + )) ? HD_VAL(hd, hdlen, "Alt-Svc:") : NULL; + if(v) { + /* the ALPN of the current request */ + struct SingleRequest *k = &data->req; + enum alpnid id = (k->httpversion == 30) ? ALPN_h3 : + (k->httpversion == 20) ? ALPN_h2 : ALPN_h1; + return Curl_altsvc_parse( + data, data->asi, v, id, data->state.origin->hostname, + curlx_uitous((unsigned int)data->state.origin->port)); + } +#else + (void)data; + (void)hd; + (void)hdlen; +#endif + return CURLE_OK; +} + +/* + * http_header_c() parses a single response header starting with C. + */ +static CURLcode http_header_c(struct Curl_easy *data, + const char *hd, size_t hdlen) +{ + struct connectdata *conn = data->conn; + struct SingleRequest *k = &data->req; + const char *v; + + /* Check for Content-Length: header lines to get size. Browsers insist we + should accept multiple Content-Length headers and that a comma separated + list also is fine and then we should accept them all as long as they are + the same value. Different values trigger error. + */ + v = (!k->http_bodyless && !data->set.ignorecl) ? + HD_VAL(hd, hdlen, "Content-Length:") : NULL; + if(v) { + do { + curl_off_t contentlength; + int offt = curlx_str_numblanks(&v, &contentlength); + + if(offt == STRE_OVERFLOW) { + /* out of range */ + if(data->set.max_filesize) { + failf(data, "Maximum file size exceeded"); + return CURLE_FILESIZE_EXCEEDED; + } + streamclose(conn, "overflow content-length"); + infof(data, "Overflow Content-Length: value"); + return CURLE_OK; + } + else { + if((offt == STRE_OK) && + ((k->size == -1) || /* not set to something before */ + (k->size == contentlength))) { /* or the same value */ + + k->size = contentlength; + curlx_str_passblanks(&v); + + /* on a comma, loop and get the next instead */ + if(!curlx_str_single(&v, ',')) + continue; + + if(!curlx_str_newline(&v)) { + k->maxdownload = k->size; + return CURLE_OK; + } + } + /* negative, different value or rubbish - bad HTTP */ + failf(data, "Invalid Content-Length: value"); + return CURLE_WEIRD_SERVER_REPLY; + } + } while(1); + } + v = (!k->http_bodyless && data->set.str[STRING_ENCODING]) ? + HD_VAL(hd, hdlen, "Content-Encoding:") : NULL; + if(v) { + /* + * Process Content-Encoding. Look for the values: identity, gzip, deflate, + * compress, x-gzip and x-compress. x-gzip and x-compress are the same as + * gzip and compress. (Sec 3.5 RFC 2616). zlib cannot handle compress. + * Errors are handled further down when the response body is processed + */ + return Curl_build_unencoding_stack(data, v, FALSE); + } + /* check for Content-Type: header lines to get the MIME-type */ + v = HD_VAL(hd, hdlen, "Content-Type:"); + if(v) { + char *contenttype = Curl_copy_header_value(hd); + if(!contenttype) + return CURLE_OUT_OF_MEMORY; + if(!*contenttype) + /* ignore empty data */ + curlx_free(contenttype); + else { + curlx_free(data->info.contenttype); + data->info.contenttype = contenttype; + } + return CURLE_OK; + } + if((k->httpversion < 20) && + HD_IS_AND_SAYS(hd, hdlen, "Connection:", "close")) { + /* + * [RFC 2616, section 8.1.2.1] + * "Connection: close" is HTTP/1.1 language and means that + * the connection will close when this request has been + * served. + */ + connclose(conn, "Connection: close used"); + return CURLE_OK; + } + if((k->httpversion == 10) && + HD_IS_AND_SAYS(hd, hdlen, "Connection:", "keep-alive")) { + /* + * An HTTP/1.0 reply with the 'Connection: keep-alive' line + * tells us the connection will be kept alive for our + * pleasure. Default action for 1.0 is to close. + * + * [RFC2068, section 19.7.1] */ + connkeep(conn, "Connection keep-alive"); + infof(data, "HTTP/1.0 connection set to keep alive"); + return CURLE_OK; + } + v = !k->http_bodyless ? HD_VAL(hd, hdlen, "Content-Range:") : NULL; + if(v) { + /* Content-Range: bytes [num]- + Content-Range: bytes: [num]- + Content-Range: [num]- + Content-Range: [asterisk]/[total] + + The second format was added since Sun's webserver + JavaWebServer/1.1.1 obviously sends the header this way! + The third added since some servers use that! + The fourth means the requested range was unsatisfied. + */ + + const char *ptr = v; + + /* Move forward until first digit or asterisk */ + while(*ptr && !ISDIGIT(*ptr) && *ptr != '*') + ptr++; + + /* if it truly stopped on a digit */ + if(ISDIGIT(*ptr)) { + if(!curlx_str_number(&ptr, &k->offset, CURL_OFF_T_MAX) && + (data->state.resume_from == k->offset)) + /* we asked for a resume and we got it */ + k->content_range = TRUE; + } + else if(k->httpcode < 300) + data->state.resume_from = 0; /* get everything */ + } + return CURLE_OK; +} + +/* + * http_header_l() parses a single response header starting with L. + */ +static CURLcode http_header_l(struct Curl_easy *data, + const char *hd, size_t hdlen) +{ + struct connectdata *conn = data->conn; + struct SingleRequest *k = &data->req; + const char *v = (!k->http_bodyless && + (data->set.timecondition || data->set.get_filetime)) ? + HD_VAL(hd, hdlen, "Last-Modified:") : NULL; + if(v) { + if(Curl_getdate_capped(v, &k->timeofdoc)) + k->timeofdoc = 0; + if(data->set.get_filetime) + data->info.filetime = k->timeofdoc; + return CURLE_OK; + } + if(HD_IS(hd, hdlen, "Location:")) { + /* this is the URL that the server advises us to use instead */ + char *location = Curl_copy_header_value(hd); + if(!location) + return CURLE_OUT_OF_MEMORY; + if(!*location || + (data->req.location && !strcmp(data->req.location, location))) { + /* ignore empty header, or exact repeat of a previous one */ + curlx_free(location); + return CURLE_OK; + } + else { + /* has value and is not an exact repeat */ + if(data->req.location) { + failf(data, "Multiple Location headers"); + curlx_free(location); + return CURLE_WEIRD_SERVER_REPLY; + } + data->req.location = location; + + if((k->httpcode >= 300 && k->httpcode < 400) && + data->set.http_follow_mode) { + CURLcode result; + DEBUGASSERT(!data->req.newurl); + data->req.newurl = curlx_strdup(data->req.location); /* clone */ + if(!data->req.newurl) + return CURLE_OUT_OF_MEMORY; + + /* some cases of POST and PUT etc needs to rewind the data + stream at this point */ + result = http_perhapsrewind(data, conn); + if(result) + return result; + + /* mark the next request as a followed location: */ + data->state.this_is_a_follow = TRUE; + } + } + } + return CURLE_OK; +} + +/* + * http_header_p() parses a single response header starting with P. + */ +static CURLcode http_header_p(struct Curl_easy *data, + const char *hd, size_t hdlen) +{ + struct SingleRequest *k = &data->req; + +#ifndef CURL_DISABLE_PROXY + const char *v = HD_VAL(hd, hdlen, "Proxy-Connection:"); + if(v) { + struct connectdata *conn = data->conn; + if((k->httpversion == 10) && conn->http_proxy.peer && + HD_IS_AND_SAYS(hd, hdlen, "Proxy-Connection:", "keep-alive")) { + /* + * When an HTTP/1.0 reply comes when using a proxy, the + * 'Proxy-Connection: keep-alive' line tells us the + * connection will be kept alive for our pleasure. + * Default action for 1.0 is to close. + */ + connkeep(conn, "Proxy-Connection keep-alive"); /* do not close */ + infof(data, "HTTP/1.0 proxy connection set to keep alive"); + } + else if((k->httpversion == 11) && conn->http_proxy.peer && + HD_IS_AND_SAYS(hd, hdlen, "Proxy-Connection:", "close")) { + /* + * We get an HTTP/1.1 response from a proxy and it says it will + * close down after this transfer. + */ + connclose(conn, "Proxy-Connection: asked to close after done"); + infof(data, "HTTP/1.1 proxy connection set close"); + } + return CURLE_OK; + } +#endif + if((407 == k->httpcode) && HD_IS(hd, hdlen, "Proxy-authenticate:")) { + char *auth = Curl_copy_header_value(hd); + CURLcode result = auth ? CURLE_OK : CURLE_OUT_OF_MEMORY; + if(!result) { + result = Curl_http_input_auth(data, TRUE, auth); + curlx_free(auth); + } + return result; + } +#ifdef USE_SPNEGO + if(HD_IS(hd, hdlen, "Persistent-Auth:")) { + struct connectdata *conn = data->conn; + struct negotiatedata *negdata = Curl_auth_nego_get(conn, FALSE); + struct auth *authp = &data->state.authhost; + if(!negdata) + return CURLE_OUT_OF_MEMORY; + if(authp->picked == CURLAUTH_NEGOTIATE) { + char *persistentauth = Curl_copy_header_value(hd); + if(!persistentauth) + return CURLE_OUT_OF_MEMORY; + negdata->noauthpersist = !!checkprefix("false", persistentauth); + negdata->havenoauthpersist = TRUE; + infof(data, "Negotiate: noauthpersist -> %d, header part: %s", + negdata->noauthpersist, persistentauth); + curlx_free(persistentauth); + } + } +#endif + return CURLE_OK; +} + +/* + * http_header_r() parses a single response header starting with R. + */ +static CURLcode http_header_r(struct Curl_easy *data, + const char *hd, size_t hdlen) +{ + const char *v = HD_VAL(hd, hdlen, "Retry-After:"); + if(v) { + /* Retry-After = HTTP-date / delay-seconds */ + curl_off_t retry_after = 0; /* zero for unknown or "now" */ + time_t date = 0; + curlx_str_passblanks(&v); + + /* try it as a date first, because a date can otherwise start with and + get treated as a number */ + if(!Curl_getdate_capped(v, &date)) { + time_t current = time(NULL); + if(date >= current) + /* convert date to number of seconds into the future */ + retry_after = date - current; + } + else + /* Try it as a decimal number, ignore errors */ + (void)curlx_str_number(&v, &retry_after, CURL_OFF_T_MAX); + /* limit to 6 hours max. this is not documented so that it can be changed + in the future if necessary. */ + if(retry_after > 21600) + retry_after = 21600; + data->info.retry_after = retry_after; + } + return CURLE_OK; +} + +/* + * http_header_s() parses a single response header starting with S. + */ +static CURLcode http_header_s(struct Curl_easy *data, + const char *hd, size_t hdlen) +{ +#if !defined(CURL_DISABLE_COOKIES) || !defined(CURL_DISABLE_HSTS) + const char *v; +#else + (void)data; + (void)hd; + (void)hdlen; +#endif + +#ifndef CURL_DISABLE_COOKIES + v = (data->cookies && data->state.cookie_engine) ? + HD_VAL(hd, hdlen, "Set-Cookie:") : NULL; + if(v) { + /* If there is a custom-set Host: name, use it here, or else use + * real peer hostname. */ + const char *host = data->req.cookiehost ? + data->req.cookiehost : data->state.origin->hostname; + const bool secure_context = Curl_secure_context(data, host); + CURLcode result; + Curl_share_lock(data, CURL_LOCK_DATA_COOKIE, CURL_LOCK_ACCESS_SINGLE); + result = Curl_cookie_add(data, data->cookies, TRUE, FALSE, v, host, + data->state.up.path, secure_context); + Curl_share_unlock(data, CURL_LOCK_DATA_COOKIE); + return result; + } +#endif +#ifndef CURL_DISABLE_HSTS + /* If enabled, the header is incoming and this is over HTTPS */ + v = (data->hsts && + (Curl_xfer_is_secure(data) || +#ifdef DEBUGBUILD + /* allow debug builds to circumvent the HTTPS restriction */ + getenv("CURL_HSTS_HTTP") +#else + 0 +#endif + ) + ) ? HD_VAL(hd, hdlen, "Strict-Transport-Security:") : NULL; + if(v) { + CURLcode result = Curl_hsts_parse( + data->hsts, data->state.origin->hostname, v); + if(result) { + if(result == CURLE_OUT_OF_MEMORY) + return result; + infof(data, "Illegal STS header skipped"); + } +#ifdef DEBUGBUILD + else + infof(data, "Parsed STS header fine (%zu entries)", + Curl_llist_count(&data->hsts->list)); +#endif + } +#endif + + return CURLE_OK; +} + +/* + * http_header_t() parses a single response header starting with T. + */ +static CURLcode http_header_t(struct Curl_easy *data, + const char *hd, size_t hdlen) +{ + struct connectdata *conn = data->conn; + struct SingleRequest *k = &data->req; + + /* RFC 9112, ch. 6.1 + * "Transfer-Encoding MAY be sent in a response to a HEAD request or + * in a 304 (Not Modified) response (Section 15.4.5 of [HTTP]) to a + * GET request, neither of which includes a message body, to indicate + * that the origin server would have applied a transfer coding to the + * message body if the request had been an unconditional GET." + * + * Read: in these cases the 'Transfer-Encoding' does not apply + * to any data following the response headers. Do not add any decoders. + */ + const char *v = (!k->http_bodyless && + (data->state.httpreq != HTTPREQ_HEAD) && + (k->httpcode != 304)) ? + HD_VAL(hd, hdlen, "Transfer-Encoding:") : NULL; + if(v) { + /* One or more encodings. We check for chunked and/or a compression + algorithm. */ + CURLcode result = Curl_build_unencoding_stack(data, v, TRUE); + if(result) + return result; + if(!k->chunk && data->set.http_transfer_encoding) { + /* if this is not chunked, only close can signal the end of this + * transfer as Content-Length is said not to be trusted for + * transfer-encoding! */ + connclose(conn, "HTTP/1.1 transfer-encoding without chunks"); + k->ignore_cl = TRUE; + } + return CURLE_OK; + } + v = HD_VAL(hd, hdlen, "Trailer:"); + if(v) { + data->req.resp_trailer = TRUE; + return CURLE_OK; + } + return CURLE_OK; +} + +/* + * http_header_w() parses a single response header starting with W. + */ +static CURLcode http_header_w(struct Curl_easy *data, + const char *hd, size_t hdlen) +{ + struct SingleRequest *k = &data->req; + CURLcode result = CURLE_OK; + + if((401 == k->httpcode) && HD_IS(hd, hdlen, "WWW-Authenticate:")) { + char *auth = Curl_copy_header_value(hd); + if(!auth) + result = CURLE_OUT_OF_MEMORY; + else { + result = Curl_http_input_auth(data, FALSE, auth); + curlx_free(auth); + } + } + return result; +} + +/* + * http_header() parses a single response header. + */ +static CURLcode http_header(struct Curl_easy *data, + const char *hd, size_t hdlen) +{ + CURLcode result = CURLE_OK; + + switch(hd[0]) { + case 'a': + case 'A': + result = http_header_a(data, hd, hdlen); + break; + case 'c': + case 'C': + result = http_header_c(data, hd, hdlen); + break; + case 'l': + case 'L': + result = http_header_l(data, hd, hdlen); + break; + case 'p': + case 'P': + result = http_header_p(data, hd, hdlen); + break; + case 'r': + case 'R': + result = http_header_r(data, hd, hdlen); + break; + case 's': + case 'S': + result = http_header_s(data, hd, hdlen); + break; + case 't': + case 'T': + result = http_header_t(data, hd, hdlen); + break; + case 'w': + case 'W': + result = http_header_w(data, hd, hdlen); + break; + } + + if(!result) { + struct connectdata *conn = data->conn; + if(conn->scheme->protocol & CURLPROTO_RTSP) + result = Curl_rtsp_parseheader(data, hd); + } + return result; +} + +/* + * Called after the first HTTP response line (the status line) has been + * received and parsed. + */ +static CURLcode http_statusline(struct Curl_easy *data, + struct connectdata *conn) +{ + struct SingleRequest *k = &data->req; + + switch(k->httpversion) { + case 10: + case 11: +#ifdef USE_HTTP2 + case 20: +#endif +#ifdef USE_HTTP3 + case 30: +#endif + /* no major version switch mid-connection */ + if(k->httpversion_sent && + (k->httpversion / 10 != k->httpversion_sent / 10)) { + failf(data, "Version mismatch (from HTTP/%d to HTTP/%d)", + k->httpversion_sent / 10, k->httpversion / 10); + return CURLE_WEIRD_SERVER_REPLY; + } + break; + default: + failf(data, "Unsupported HTTP version (%d.%d) in response", + k->httpversion / 10, k->httpversion % 10); + return CURLE_UNSUPPORTED_PROTOCOL; + } + + data->info.httpcode = k->httpcode; + data->info.httpversion = k->httpversion; + conn->httpversion_seen = k->httpversion; + + if(!data->state.http_neg.rcvd_min || + data->state.http_neg.rcvd_min > k->httpversion) + /* store the lowest server version we encounter */ + data->state.http_neg.rcvd_min = k->httpversion; + + /* + * This code executes as part of processing the header. As a + * result, it is not totally clear how to interpret the + * response code yet as that depends on what other headers may + * be present. 401 and 407 may be errors, but may be OK + * depending on how authentication is working. Other codes + * are definitely errors, so give up here. + */ + if(data->state.resume_from && data->state.httpreq == HTTPREQ_GET && + k->httpcode == 416) { + /* "Requested Range Not Satisfiable", proceed and pretend this is no + error */ + k->ignorebody = TRUE; /* Avoid appending error msg to good data. */ + } + + if(k->httpversion == 10) { + /* Default action for HTTP/1.0 must be to close, unless + we get one of those fancy headers that tell us the + server keeps it open for us! */ + infof(data, "HTTP 1.0, assume close after body"); + connclose(conn, "HTTP/1.0 close after body"); + } + + k->http_bodyless = k->httpcode >= 100 && k->httpcode < 200; + switch(k->httpcode) { + case 304: + /* (quote from RFC2616, section 10.3.5): The 304 response + * MUST NOT contain a message-body, and thus is always + * terminated by the first empty line after the header + * fields. */ + if(data->set.timecondition) + data->info.timecond = TRUE; + FALLTHROUGH(); + case 204: + /* (quote from RFC2616, section 10.2.5): The server has + * fulfilled the request but does not need to return an + * entity-body ... The 204 response MUST NOT include a + * message-body, and thus is always terminated by the first + * empty line after the header fields. */ + k->size = 0; + k->maxdownload = 0; + k->http_bodyless = TRUE; + break; + default: + break; + } + return CURLE_OK; +} + +/* Content-Length must be ignored if any Transfer-Encoding is present in the + response. Refer to RFC 7230 section 3.3.3 and RFC2616 section 4.4. This is + figured out here after all headers have been received but before the final + call to the user's header callback, so that a valid content length can be + retrieved by the user in the final call. */ +static CURLcode http_size(struct Curl_easy *data) +{ + struct SingleRequest *k = &data->req; + if(data->req.ignore_cl || k->chunk) { + k->size = k->maxdownload = -1; + } + else if(k->size != -1) { + if(data->set.max_filesize && + !k->ignorebody && + (k->size > data->set.max_filesize)) { + failf(data, "Maximum file size exceeded"); + return CURLE_FILESIZE_EXCEEDED; + } + if(k->ignorebody) + infof(data, "setting size while ignoring"); + Curl_pgrsSetDownloadSize(data, k->size); + k->maxdownload = k->size; + } + return CURLE_OK; +} + +CURLcode Curl_verify_header(struct Curl_easy *data, + const char *hd, size_t hdlen) +{ + struct SingleRequest *k = &data->req; + const char *ptr = memchr(hd, 0x00, hdlen); + if(ptr) { + /* this is bad, bail out */ + failf(data, "Nul byte in header"); + return CURLE_WEIRD_SERVER_REPLY; + } + if(hdlen > 2) { + ptr = memchr(hd, '\r', hdlen - 2); + if(ptr) { + /* CR may only precede the LF, nothing else */ + failf(data, "Carriage return found in header"); + return CURLE_WEIRD_SERVER_REPLY; + } + } + if(k->headerline < 2) + /* the first "header" is the status-line and it has no colon */ + return CURLE_OK; + if(((hd[0] == ' ') || (hd[0] == '\t')) && k->headerline > 2) + /* line folding, cannot happen on line 2 */ + ; + else { + ptr = memchr(hd, ':', hdlen); + if(!ptr) { + /* this is bad, bail out */ + failf(data, "Header without colon"); + return CURLE_WEIRD_SERVER_REPLY; + } + } + return CURLE_OK; +} + +CURLcode Curl_bump_headersize(struct Curl_easy *data, + size_t delta, + bool connect_only) +{ + size_t bad = 0; + unsigned int max = MAX_HTTP_RESP_HEADER_SIZE; + if(delta < MAX_HTTP_RESP_HEADER_SIZE) { + data->info.header_size += (unsigned int)delta; + data->req.allheadercount += (unsigned int)delta; + if(!connect_only) + data->req.headerbytecount += (unsigned int)delta; + if(data->req.allheadercount > max) + bad = data->req.allheadercount; + else if(data->info.header_size > (max * 20)) { + bad = data->info.header_size; + max *= 20; + } + } + else + bad = data->req.allheadercount + delta; + if(bad) { + failf(data, "Too large response headers: %zu > %u", bad, max); + return CURLE_RECV_ERROR; + } + return CURLE_OK; +} + +/* + * Handle a 101 Switching Protocols response. Performs the actual protocol + * upgrade to HTTP/2 or WebSocket based on what was requested. + */ +static CURLcode http_on_101_upgrade(struct Curl_easy *data, + const char *buf, size_t blen, + size_t *pconsumed, + bool *conn_changed) +{ + struct connectdata *conn = data->conn; + struct SingleRequest *k = &data->req; + +#if !defined(USE_NGHTTP2) && defined(CURL_DISABLE_WEBSOCKETS) + (void)buf; + (void)blen; + (void)pconsumed; +#else + CURLcode result; + int upgr101_requested = k->upgr101; +#endif + + if(k->httpversion_sent != 11) { + /* invalid for other HTTP versions */ + failf(data, "server sent 101 response while not talking HTTP/1.1"); + return CURLE_WEIRD_SERVER_REPLY; + } + + /* Whatever the success, upgrade was selected. */ + k->upgr101 = UPGR101_RECEIVED; + conn->bits.upgrade_in_progress = FALSE; + *conn_changed = TRUE; + + /* To be fully compliant, we would check the "Upgrade:" response header to + * mention the protocol we requested. */ +#ifdef USE_NGHTTP2 + if(upgr101_requested == UPGR101_H2) { + /* Switch to HTTP/2, where we will get more responses. blen bytes in buf + * are already h2 protocol bytes */ + infof(data, "Received 101, Switching to HTTP/2"); + result = Curl_http2_upgrade(data, conn, FIRSTSOCKET, buf, blen); + if(!result) + *pconsumed += blen; + return result; + } +#endif +#ifndef CURL_DISABLE_WEBSOCKETS + if(upgr101_requested == UPGR101_WS) { + /* Switch to WebSocket, where we now stream ws frames. blen bytes in buf + * are already ws protocol bytes */ + infof(data, "Received 101, Switching to WebSocket"); + result = Curl_ws_accept(data, buf, blen); + if(!result) + *pconsumed += blen; /* ws accept handled the data */ + return result; + } +#endif + /* We silently accept this as the final response. What are we switching to + * if we did not ask for an Upgrade? Maybe the application provided an + * `Upgrade: xxx` header? */ + k->header = FALSE; + return CURLE_OK; +} + +/* + * Handle 1xx intermediate HTTP responses. Sets up state for more + * headers and processes 100-continue and 101 upgrade responses. + */ +static CURLcode http_on_1xx_response(struct Curl_easy *data, + const char *buf, size_t blen, + size_t *pconsumed, + bool *conn_changed) +{ + struct SingleRequest *k = &data->req; + + /* "A user agent MAY ignore unexpected 1xx status responses." + * By default, we expect to get more responses after this one. */ + k->header = TRUE; + k->headerline = 0; /* restart the header line counter */ + + switch(k->httpcode) { + case 100: + /* We have made an HTTP PUT or POST and this is 1.1-lingo that tells us + * that the server is OK with this and ready to receive the data. */ + http_exp100_got100(data); + break; + case 101: + return http_on_101_upgrade(data, buf, blen, pconsumed, conn_changed); + default: + /* The server may send us other 1xx responses, like informative 103. This + * has no influence on request processing and we expect to receive a + * final response eventually. */ + break; + } + return CURLE_OK; +} + +#if defined(USE_NTLM) || defined(USE_SPNEGO) +/* + * Check if NTLM or SPNEGO authentication negotiation failed due to + * connection closure (typically on HTTP/1.0 servers). + */ +static void http_check_auth_closure(struct Curl_easy *data, + struct connectdata *conn) +{ + /* At this point we have some idea about the fate of the connection. If we + are closing the connection it may result auth failure. */ +#ifdef USE_NTLM + if(conn->bits.close && + (((data->req.httpcode == 401) && + (conn->http_ntlm_state == NTLMSTATE_TYPE2)) || + ((data->req.httpcode == 407) && + (conn->proxy_ntlm_state == NTLMSTATE_TYPE2)))) { + infof(data, "Connection closure while negotiating auth (HTTP 1.0?)"); + data->state.authproblem = TRUE; + } +#endif +#ifdef USE_SPNEGO + if(conn->bits.close && + (((data->req.httpcode == 401) && + (conn->http_negotiate_state == GSS_AUTHRECV)) || + ((data->req.httpcode == 407) && + (conn->proxy_negotiate_state == GSS_AUTHRECV)))) { + infof(data, "Connection closure while negotiating auth (HTTP 1.0?)"); + data->state.authproblem = TRUE; + } + if((conn->http_negotiate_state == GSS_AUTHDONE) && + (data->req.httpcode != 401)) { + conn->http_negotiate_state = GSS_AUTHSUCC; + } + if((conn->proxy_negotiate_state == GSS_AUTHDONE) && + (data->req.httpcode != 407)) { + conn->proxy_negotiate_state = GSS_AUTHSUCC; + } +#endif +} +#else +#define http_check_auth_closure(x, y) /* empty */ +#endif + +/* + * Handle an error response (>= 300) received while still sending the + * request body. Deals with 417 Expectation Failed retries, keep-sending + * on error, and aborting the send. + */ +static CURLcode http_handle_send_error(struct Curl_easy *data) +{ + struct connectdata *conn = data->conn; + struct SingleRequest *k = &data->req; + CURLcode result = CURLE_OK; + + if(!data->req.authneg && !conn->bits.close && + !Curl_creader_will_rewind(data)) { + /* + * General treatment of errors when about to send data. + * Including: "417 Expectation Failed", while waiting for + * 100-continue. + * + * The check for close above is done because if something + * else has already deemed the connection to get closed then + * something else should have considered the big picture and + * we avoid this check. + */ + + switch(data->state.httpreq) { + case HTTPREQ_PUT: + case HTTPREQ_POST: + case HTTPREQ_POST_FORM: + case HTTPREQ_POST_MIME: + /* We got an error response. If this happened before the + * whole request body has been sent we stop sending and + * mark the connection for closure after we have read the + * entire response. */ + if(!Curl_req_done_sending(data)) { + if((k->httpcode == 417) && http_exp100_is_selected(data)) { + /* 417 Expectation Failed - try again without the + Expect header */ + if(!k->writebytecount && http_exp100_is_waiting(data)) { + infof(data, "Got HTTP failure 417 while waiting for a 100"); + } + else { + infof(data, "Got HTTP failure 417 while sending data"); + streamclose(conn, "Stop sending data before everything sent"); + result = http_perhapsrewind(data, conn); + if(result) + return result; + } + data->state.disableexpect = TRUE; + Curl_req_abort_sending(data); + DEBUGASSERT(!data->req.newurl); + data->req.newurl = Curl_bufref_dup(&data->state.url); + if(!data->req.newurl) + return CURLE_OUT_OF_MEMORY; + } + else if(data->set.http_keep_sending_on_error) { + infof(data, "HTTP error before end of send, keep sending"); + http_exp100_send_anyway(data); + } + else { + infof(data, "HTTP error before end of send, stop sending"); + streamclose(conn, "Stop sending data before everything sent"); + result = Curl_req_abort_sending(data); + if(result) + return result; + } + } + break; + + default: /* default label present to avoid compiler warnings */ + break; + } + } + + if(Curl_creader_will_rewind(data) && !Curl_req_done_sending(data)) { + /* We rewind before next send, continue sending now */ + infof(data, "Keep sending data to get tossed away"); + CURL_REQ_SET_SEND(data); + } + return result; +} + +static CURLcode http_on_response(struct Curl_easy *data, + const char *last_hd, size_t last_hd_len, + const char *buf, size_t blen, + size_t *pconsumed) +{ + struct connectdata *conn = data->conn; + CURLcode result = CURLE_OK; + struct SingleRequest *k = &data->req; + bool conn_changed = FALSE; + + (void)buf; /* not used without HTTP2 enabled */ + *pconsumed = 0; + + if(k->upgr101 == UPGR101_RECEIVED) { + /* supposedly upgraded to http2 now */ + if(data->req.httpversion != 20) + infof(data, "Lying server, not serving HTTP/2"); + } + + if(k->httpcode < 200 && last_hd) { + /* Intermediate responses might trigger processing of more responses, + * write the last header to the client before proceeding. */ + result = http_write_header(data, last_hd, last_hd_len); + last_hd = NULL; /* handled it */ + if(result) + goto out; + } + + if(k->httpcode < 100) { + failf(data, "Unsupported response code in HTTP response"); + result = CURLE_UNSUPPORTED_PROTOCOL; + goto out; + } + else if(k->httpcode < 200) { + result = http_on_1xx_response(data, buf, blen, pconsumed, &conn_changed); + goto out; + } + + /* k->httpcode >= 200, final response */ + k->header = FALSE; + if(conn->bits.upgrade_in_progress) { + /* Asked for protocol upgrade, but it was not selected */ + conn->bits.upgrade_in_progress = FALSE; + conn_changed = TRUE; + } + + if((k->size == -1) && !k->chunk && !conn->bits.close && + (k->httpversion == 11) && + !(conn->scheme->protocol & CURLPROTO_RTSP) && + data->state.httpreq != HTTPREQ_HEAD) { + /* On HTTP 1.1, when connection is not to get closed, but no + Content-Length nor Transfer-Encoding chunked have been received, + according to RFC2616 section 4.4 point 5, we assume that the server + will close the connection to signal the end of the document. */ + infof(data, "no chunk, no close, no size. Assume close to signal end"); + streamclose(conn, "HTTP: No end-of-message indicator"); + } + + http_check_auth_closure(data, conn); + +#ifndef CURL_DISABLE_WEBSOCKETS + /* All >=200 HTTP status codes are errors when wanting ws */ + if(data->req.upgr101 == UPGR101_WS) { + failf(data, "Refused WebSocket upgrade: %d", k->httpcode); + result = CURLE_HTTP_RETURNED_ERROR; + goto out; + } +#endif + + /* Check if this response means the transfer errored. */ + if(http_should_fail(data, data->req.httpcode)) { + failf(data, "The requested URL returned error: %d", + k->httpcode); + result = CURLE_HTTP_RETURNED_ERROR; + goto out; + } + + /* Curl_http_auth_act() checks what authentication methods that are + * available and decides which one (if any) to use. It will set 'newurl' if + * an auth method was picked. */ + result = Curl_http_auth_act(data); + if(result) + goto out; + + if(k->httpcode >= 300) { + result = http_handle_send_error(data); + if(result) + goto out; + } + + /* final response without error, prepare to receive the body */ + result = http_firstwrite(data); + if(result) + goto out; + + /* This is the last response that we get for the current request. Check on + * the body size and determine if the response is complete. */ + result = http_size(data); + if(result) + goto out; + + /* If we requested a "no body", this is a good time to get + * out and return home. + */ + if(data->req.no_body) + k->download_done = TRUE; + + /* If max download size is *zero* (nothing) we already have nothing and can + safely return ok now! For HTTP/2, we would like to call + http2_handle_stream_close to properly close a stream. In order to do + this, we keep reading until we close the stream. */ + if((k->maxdownload == 0) && (k->httpversion_sent < 20)) + k->download_done = TRUE; + +out: + if(last_hd) + /* if not written yet, write it now */ + result = Curl_1st_fatal(result, + http_write_header(data, last_hd, last_hd_len)); + if(conn_changed) + /* poke the multi handle to allow pending pipewait to retry */ + Curl_multi_connchanged(data->multi); + return result; +} + +static CURLcode http_rw_hd(struct Curl_easy *data, + const char *hd, size_t hdlen, + const char *buf_remain, size_t blen, + size_t *pconsumed) +{ + CURLcode result = CURLE_OK; + struct SingleRequest *k = &data->req; + int writetype; + DEBUGASSERT(!hd[hdlen]); /* null-terminated */ + + *pconsumed = 0; + if((0x0a == *hd) || (0x0d == *hd)) { + /* Empty header line means end of headers! */ + struct dynbuf last_header; + size_t consumed; + + curlx_dyn_init(&last_header, hdlen + 1); + result = curlx_dyn_addn(&last_header, hd, hdlen); + if(result) + return result; + + /* analyze the response to find out what to do. */ + /* Caveat: we clear anything in the header brigade, because a + * response might switch HTTP version which may call use recursively. + * Not nice, but that is currently the way of things. */ + curlx_dyn_reset(&data->state.headerb); + result = http_on_response(data, curlx_dyn_ptr(&last_header), + curlx_dyn_len(&last_header), + buf_remain, blen, &consumed); + *pconsumed += consumed; + curlx_dyn_free(&last_header); + return result; + } + + /* + * Checks for special headers coming up. + */ + + writetype = CLIENTWRITE_HEADER; + if(!k->headerline++) { + /* This is the first header, it MUST be the error code line + or else we consider this to be the body right away! */ + bool fine_statusline = FALSE; + + k->httpversion = 0; /* Do not know yet */ + if(data->conn->scheme->protocol & PROTO_FAMILY_HTTP) { + /* + * https://datatracker.ietf.org/doc/html/rfc7230#section-3.1.2 + * + * The response code is always a three-digit number in HTTP as the spec + * says. We allow any three-digit number here, but we cannot make + * guarantees on future behaviors since it is not within the protocol. + */ + const char *p = hd; + + curlx_str_passblanks(&p); + if(!strncmp(p, "HTTP/", 5)) { + p += 5; + switch(*p) { + case '1': + p++; + if((p[0] == '.') && (p[1] == '0' || p[1] == '1')) { + if(ISBLANK(p[2])) { + k->httpversion = (unsigned char)(10 + (p[1] - '0')); + p += 3; + if(ISDIGIT(p[0]) && ISDIGIT(p[1]) && ISDIGIT(p[2])) { + k->httpcode = ((p[0] - '0') * 100) + ((p[1] - '0') * 10) + + (p[2] - '0'); + /* RFC 9112 requires a single space following the status code, + but the browsers do not so let's not insist */ + fine_statusline = TRUE; + } + } + } + if(!fine_statusline) { + failf(data, "Unsupported HTTP/1 subversion in response"); + return CURLE_UNSUPPORTED_PROTOCOL; + } + break; + case '2': + case '3': + if(!ISBLANK(p[1])) + break; + k->httpversion = (unsigned char)((*p - '0') * 10); + p += 2; + if(ISDIGIT(p[0]) && ISDIGIT(p[1]) && ISDIGIT(p[2])) { + k->httpcode = ((p[0] - '0') * 100) + ((p[1] - '0') * 10) + + (p[2] - '0'); + p += 3; + if(!ISBLANK(*p)) + break; + fine_statusline = TRUE; + } + break; + default: /* unsupported */ + failf(data, "Unsupported HTTP version in response"); + return CURLE_UNSUPPORTED_PROTOCOL; + } + } + + if(!fine_statusline) { + /* If user has set option HTTP200ALIASES, + compare header line against list of aliases + */ + statusline check = checkhttpprefix(data, hd, hdlen); + if(check == STATUS_DONE) { + fine_statusline = TRUE; + k->httpcode = 200; + k->httpversion = 10; + } + } + } + else if(data->conn->scheme->protocol & CURLPROTO_RTSP) { + const char *p = hd; + struct Curl_str ver; + curl_off_t status; + /* we set the max string a little excessive to forgive some leading + spaces */ + if(!curlx_str_until(&p, &ver, 32, ' ') && + !curlx_str_single(&p, ' ') && + !curlx_str_number(&p, &status, 999)) { + curlx_str_trimblanks(&ver); + if(curlx_str_cmp(&ver, "RTSP/1.0")) { + k->httpcode = (int)status; + fine_statusline = TRUE; + k->httpversion = 11; /* RTSP acts like HTTP 1.1 */ + } + } + if(!fine_statusline) + return CURLE_WEIRD_SERVER_REPLY; + } + + if(fine_statusline) { + result = http_statusline(data, data->conn); + if(result) + return result; + writetype |= CLIENTWRITE_STATUS; + } + else { + k->header = FALSE; /* this is not a header line */ + return CURLE_WEIRD_SERVER_REPLY; + } + } + + result = Curl_verify_header(data, hd, hdlen); + if(result) + return result; + + result = http_header(data, hd, hdlen); + if(result) + return result; + + /* + * Taken in one (more) header. Write it to the client. + */ + Curl_debug(data, CURLINFO_HEADER_IN, hd, hdlen); + + if(k->httpcode / 100 == 1) + writetype |= CLIENTWRITE_1XX; + result = Curl_client_write(data, writetype, hd, hdlen); + if(result) + return result; + + result = Curl_bump_headersize(data, hdlen, FALSE); + if(result) + return result; + + return CURLE_OK; +} + +/* remove trailing CRLF then all trailing whitespace */ +void Curl_http_to_fold(struct dynbuf *bf) +{ + size_t len = curlx_dyn_len(bf); + const char *hd = curlx_dyn_ptr(bf); + if(len && (hd[len - 1] == '\n')) + len--; + if(len && (hd[len - 1] == '\r')) + len--; + while(len && ISBLANK(hd[len - 1])) /* strip off trailing whitespace */ + len--; + curlx_dyn_setlen(bf, len); +} + +static void unfold_header(struct Curl_easy *data) +{ + Curl_http_to_fold(&data->state.headerb); + data->state.leading_unfold = TRUE; +} + +/* + * Read any HTTP header lines from the server and pass them to the client app. + */ +static CURLcode http_parse_headers(struct Curl_easy *data, + const char *buf, size_t blen, + size_t *pconsumed) +{ + struct connectdata *conn = data->conn; + CURLcode result = CURLE_OK; + struct SingleRequest *k = &data->req; + const char *end_ptr; + bool leftover_body = FALSE; + + /* we have bytes for the next header, make sure it is not a folded header + before passing it on */ + if(data->state.maybe_folded && blen) { + if(ISBLANK(buf[0])) { + /* folded, remove the trailing newlines and append the next header */ + unfold_header(data); + } + else { + /* the header data we hold is a complete header, pass it on */ + size_t ignore_this; + result = http_rw_hd(data, curlx_dyn_ptr(&data->state.headerb), + curlx_dyn_len(&data->state.headerb), + NULL, 0, &ignore_this); + curlx_dyn_reset(&data->state.headerb); + if(result) + return result; + } + data->state.maybe_folded = FALSE; + } + + /* header line within buffer loop */ + *pconsumed = 0; + while(blen && k->header) { + size_t consumed; + size_t hlen; + const char *hd; + size_t unfold_len = 0; + + if(data->state.leading_unfold) { + /* immediately after an unfold, keep only a single whitespace */ + while(blen && ISBLANK(buf[0])) { + buf++; + blen--; + unfold_len++; + } + if(blen) { + /* insert a single space */ + result = curlx_dyn_addn(&data->state.headerb, " ", 1); + if(result) + return result; + data->state.leading_unfold = FALSE; /* done now */ + } + } + + end_ptr = memchr(buf, '\n', blen); + if(!end_ptr) { + /* Not a complete header line within buffer, append the data to + the end of the headerbuff. */ + result = curlx_dyn_addn(&data->state.headerb, buf, blen); + if(result) + return result; + *pconsumed += blen + unfold_len; + + if(!k->headerline) { + /* check if this looks like a protocol header */ + statusline st = + checkprotoprefix(data, conn, + curlx_dyn_ptr(&data->state.headerb), + curlx_dyn_len(&data->state.headerb)); + + if(st == STATUS_BAD) { + /* this is not the beginning of a protocol first header line. + * Cannot be 0.9 if version was detected or connection was reused. */ + k->header = FALSE; + streamclose(conn, "bad HTTP: No end-of-message indicator"); + if((k->httpversion >= 10) || conn->bits.reuse) { + failf(data, "Invalid status line"); + return CURLE_WEIRD_SERVER_REPLY; + } + if(!data->state.http_neg.accept_09) { + failf(data, "Received HTTP/0.9 when not allowed"); + return CURLE_UNSUPPORTED_PROTOCOL; + } + leftover_body = TRUE; + goto out; + } + } + goto out; /* read more and try again */ + } + + /* the size of the remaining header line */ + consumed = (end_ptr - buf) + 1; + + result = curlx_dyn_addn(&data->state.headerb, buf, consumed); + if(result) + return result; + blen -= consumed; + buf += consumed; + *pconsumed += consumed + unfold_len; + + /**** + * We now have a FULL header line in 'headerb'. + *****/ + + hlen = curlx_dyn_len(&data->state.headerb); + hd = curlx_dyn_ptr(&data->state.headerb); + + if(!k->headerline) { + /* the first read "header", the status line */ + statusline st = checkprotoprefix(data, conn, hd, hlen); + if(st == STATUS_BAD) { + streamclose(conn, "bad HTTP: No end-of-message indicator"); + /* this is not the beginning of a protocol first header line. + * Cannot be 0.9 if version was detected or connection was reused. */ + if((k->httpversion >= 10) || conn->bits.reuse) { + failf(data, "Invalid status line"); + return CURLE_WEIRD_SERVER_REPLY; + } + if(!data->state.http_neg.accept_09) { + failf(data, "Received HTTP/0.9 when not allowed"); + return CURLE_UNSUPPORTED_PROTOCOL; + } + k->header = FALSE; + leftover_body = TRUE; + goto out; + } + } + else { + if(hlen && !ISNEWLINE(hd[0])) { + /* this is NOT the header separator */ + + /* if we have bytes for the next header, check for folding */ + if(blen && ISBLANK(buf[0])) { + /* remove the trailing CRLF and append the next header */ + unfold_header(data); + continue; + } + else if(!blen) { + /* this might be a folded header so deal with it in next invoke */ + data->state.maybe_folded = TRUE; + break; + } + } + } + + result = http_rw_hd(data, hd, hlen, buf, blen, &consumed); + /* We are done with this line. We reset because response + * processing might switch to HTTP/2 and that might call us + * directly again. */ + curlx_dyn_reset(&data->state.headerb); + if(consumed) { + blen -= consumed; + buf += consumed; + *pconsumed += consumed; + } + if(result) + return result; + } + + /* We might have reached the end of the header part here, but + there might be a non-header part left in the end of the read + buffer. */ +out: + if(!k->header && !leftover_body) { + curlx_dyn_free(&data->state.headerb); + } + return CURLE_OK; +} + +CURLcode Curl_http_write_resp_hd(struct Curl_easy *data, + const char *hd, size_t hdlen, + bool is_eos) +{ + CURLcode result; + size_t consumed; + char tmp = 0; + DEBUGASSERT(!hd[hdlen]); /* null-terminated */ + + result = http_rw_hd(data, hd, hdlen, &tmp, 0, &consumed); + if(!result && is_eos) { + result = Curl_client_write(data, (CLIENTWRITE_BODY | CLIENTWRITE_EOS), + &tmp, 0); + } + return result; +} + +/* + * HTTP protocol `write_resp` implementation. Parse headers + * when not done yet and otherwise return without consuming data. + */ +CURLcode Curl_http_write_resp_hds(struct Curl_easy *data, + const char *buf, size_t blen, + size_t *pconsumed) +{ + if(!data->req.header) { + *pconsumed = 0; + return CURLE_OK; + } + else { + CURLcode result; + + result = http_parse_headers(data, buf, blen, pconsumed); + if(!result && !data->req.header) { + if(!data->req.no_body && curlx_dyn_len(&data->state.headerb)) { + /* leftover from parsing something that turned out not + * to be a header, only happens if we allow for + * HTTP/0.9 like responses */ + result = Curl_client_write(data, CLIENTWRITE_BODY, + curlx_dyn_ptr(&data->state.headerb), + curlx_dyn_len(&data->state.headerb)); + } + curlx_dyn_free(&data->state.headerb); + } + return result; + } +} + +CURLcode Curl_http_write_resp(struct Curl_easy *data, + const char *buf, size_t blen, + bool is_eos) +{ + CURLcode result; + size_t consumed; + int flags; + + result = Curl_http_write_resp_hds(data, buf, blen, &consumed); + if(result || data->req.done) + goto out; + + DEBUGASSERT(consumed <= blen); + blen -= consumed; + buf += consumed; + /* either all was consumed in header parsing, or we have data left + * and are done with headers, e.g. it is BODY data */ + DEBUGASSERT(!blen || !data->req.header); + if(!data->req.header && (blen || is_eos)) { + /* BODY data after header been parsed, write and consume */ + flags = CLIENTWRITE_BODY; + if(is_eos) + flags |= CLIENTWRITE_EOS; + result = Curl_client_write(data, flags, buf, blen); + } +out: + return result; +} + +/* Decode HTTP status code string. */ +CURLcode Curl_http_decode_status(int *pstatus, const char *s, size_t len) +{ + CURLcode result = CURLE_BAD_FUNCTION_ARGUMENT; + int status = 0; + int i; + + if(len != 3) + goto out; + + for(i = 0; i < 3; ++i) { + char c = s[i]; + + if(c < '0' || c > '9') + goto out; + + status *= 10; + status += c - '0'; + } + result = CURLE_OK; +out: + *pstatus = result ? -1 : status; + return result; +} + +CURLcode Curl_http_req_make(struct httpreq **preq, + const char *method, size_t m_len, + const char *scheme, size_t s_len, + const char *authority, size_t a_len, + const char *path, size_t p_len) +{ + struct httpreq *req; + CURLcode result = CURLE_OUT_OF_MEMORY; + + DEBUGASSERT(method && m_len); + + req = curlx_calloc(1, sizeof(*req) + m_len); + if(!req) + goto out; +#if defined(__GNUC__) && __GNUC__ >= 13 +#pragma GCC diagnostic push +/* error: 'memcpy' offset [137, 142] from the object at 'req' is out of + the bounds of referenced subobject 'method' with type 'char[1]' at + offset 136 */ +#pragma GCC diagnostic ignored "-Warray-bounds" +#endif + memcpy(req->method, method, m_len); +#if defined(__GNUC__) && __GNUC__ >= 13 +#pragma GCC diagnostic pop +#endif + if(scheme) { + req->scheme = curlx_memdup0(scheme, s_len); + if(!req->scheme) + goto out; + } + if(authority) { + req->authority = curlx_memdup0(authority, a_len); + if(!req->authority) + goto out; + } + if(path) { + req->path = curlx_memdup0(path, p_len); + if(!req->path) + goto out; + } + Curl_dynhds_init(&req->headers, 0, DYN_HTTP_REQUEST); + Curl_dynhds_init(&req->trailers, 0, DYN_HTTP_REQUEST); + result = CURLE_OK; + +out: + if(result && req) + Curl_http_req_free(req); + *preq = result ? NULL : req; + return result; +} + +static CURLcode req_assign_url_authority(struct httpreq *req, CURLU *url) +{ + char *host, *port; + struct dynbuf buf; + CURLUcode uc; + CURLcode result = CURLE_URL_MALFORMAT; + + host = port = NULL; + curlx_dyn_init(&buf, DYN_HTTP_REQUEST); + + uc = curl_url_get(url, CURLUPART_HOST, &host, 0); + if(uc && uc != CURLUE_NO_HOST) + goto out; + if(!host) { + req->authority = NULL; + result = CURLE_OK; + goto out; + } + + uc = curl_url_get(url, CURLUPART_PORT, &port, CURLU_NO_DEFAULT_PORT); + if(uc && uc != CURLUE_NO_PORT) + goto out; + + result = curlx_dyn_add(&buf, host); + if(result) + goto out; + if(port) { + result = curlx_dyn_addf(&buf, ":%s", port); + if(result) + goto out; + } + req->authority = curlx_dyn_ptr(&buf); +out: + curlx_free(host); + curlx_free(port); + if(result) + curlx_dyn_free(&buf); + return result; +} + +static CURLcode req_assign_url_path(struct httpreq *req, CURLU *url) +{ + char *path, *query; + struct dynbuf buf; + CURLUcode uc; + CURLcode result = CURLE_URL_MALFORMAT; + + path = query = NULL; + curlx_dyn_init(&buf, DYN_HTTP_REQUEST); + + uc = curl_url_get(url, CURLUPART_PATH, &path, 0); + if(uc) + goto out; + uc = curl_url_get(url, CURLUPART_QUERY, &query, 0); + if(uc && uc != CURLUE_NO_QUERY) + goto out; + + if(!query) { + req->path = path; + path = NULL; + } + else { + result = curlx_dyn_add(&buf, path); + if(!result) + result = curlx_dyn_addf(&buf, "?%s", query); + if(result) + goto out; + req->path = curlx_dyn_ptr(&buf); + } + result = CURLE_OK; + +out: + curlx_free(path); + curlx_free(query); + if(result) + curlx_dyn_free(&buf); + return result; +} + +CURLcode Curl_http_req_make2(struct httpreq **preq, + const char *method, size_t m_len, + CURLU *url, const char *scheme_default) +{ + struct httpreq *req; + CURLcode result = CURLE_OUT_OF_MEMORY; + CURLUcode uc; + + DEBUGASSERT(method && m_len); + + req = curlx_calloc(1, sizeof(*req) + m_len); + if(!req) + goto out; + memcpy(req->method, method, m_len); + + uc = curl_url_get(url, CURLUPART_SCHEME, &req->scheme, 0); + if(uc && uc != CURLUE_NO_SCHEME) + goto out; + if(!req->scheme && scheme_default) { + req->scheme = curlx_strdup(scheme_default); + if(!req->scheme) + goto out; + } + + result = req_assign_url_authority(req, url); + if(result) + goto out; + result = req_assign_url_path(req, url); + if(result) + goto out; + + Curl_dynhds_init(&req->headers, 0, DYN_HTTP_REQUEST); + Curl_dynhds_init(&req->trailers, 0, DYN_HTTP_REQUEST); + result = CURLE_OK; + +out: + if(result && req) + Curl_http_req_free(req); + *preq = result ? NULL : req; + return result; +} + +void Curl_http_req_free(struct httpreq *req) +{ + if(req) { + curlx_free(req->scheme); + curlx_free(req->authority); + curlx_free(req->path); + Curl_dynhds_free(&req->headers); + Curl_dynhds_free(&req->trailers); + curlx_free(req); + } +} + +struct name_const { + const char *name; + size_t namelen; +}; + +static const struct name_const H2_NON_FIELD[] = { + { STRCONST("Host") }, + { STRCONST("Upgrade") }, + { STRCONST("Connection") }, + { STRCONST("Keep-Alive") }, + { STRCONST("Proxy-Connection") }, + { STRCONST("Transfer-Encoding") }, +}; + +static bool h2_permissible_field(struct dynhds_entry *e) +{ + size_t i; + for(i = 0; i < CURL_ARRAYSIZE(H2_NON_FIELD); ++i) { + if(e->namelen == H2_NON_FIELD[i].namelen && + curl_strnequal(H2_NON_FIELD[i].name, e->name, e->namelen)) + return FALSE; + } + return TRUE; +} + +static bool http_TE_has_token(const char *fvalue, const char *token) +{ + while(*fvalue) { + struct Curl_str name; + + /* skip to first token */ + while(ISBLANK(*fvalue) || *fvalue == ',') + fvalue++; + if(curlx_str_cspn(&fvalue, &name, " \t\r;,")) + return FALSE; + if(curlx_str_casecompare(&name, token)) + return TRUE; + + /* skip any remainder after token, e.g. parameters with quoted strings */ + while(*fvalue && *fvalue != ',') { + if(*fvalue == '"') { + struct Curl_str qw; + /* if we do not cleanly find a quoted word here, the header value + * does not follow HTTP syntax and we reject */ + if(curlx_str_quotedword(&fvalue, &qw, CURL_MAX_HTTP_HEADER)) + return FALSE; + } + else + fvalue++; + } + } + return FALSE; +} + +CURLcode Curl_http_req_to_h2(struct dynhds *h2_headers, + struct httpreq *req, struct Curl_easy *data) +{ + const char *scheme = NULL, *authority = NULL; + struct dynhds_entry *e; + size_t i; + CURLcode result; + + DEBUGASSERT(req); + DEBUGASSERT(h2_headers); + + if(req->scheme) { + scheme = req->scheme; + } + else if(strcmp("CONNECT", req->method)) { + scheme = Curl_checkheaders(data, STRCONST(HTTP_PSEUDO_SCHEME)); + if(scheme) { + scheme += sizeof(HTTP_PSEUDO_SCHEME); + curlx_str_passblanks(&scheme); + infof(data, "set pseudo header %s to %s", HTTP_PSEUDO_SCHEME, scheme); + } + else { + scheme = data->state.origin->scheme->name; + } + } + + if(req->authority) { + authority = req->authority; + } + else { + e = Curl_dynhds_get(&req->headers, STRCONST("Host")); + if(e) + authority = e->value; + } + + Curl_dynhds_reset(h2_headers); + Curl_dynhds_set_opts(h2_headers, DYNHDS_OPT_LOWERCASE); + result = Curl_dynhds_add(h2_headers, STRCONST(HTTP_PSEUDO_METHOD), + req->method, strlen(req->method)); + if(!result && scheme) { + result = Curl_dynhds_add(h2_headers, STRCONST(HTTP_PSEUDO_SCHEME), + scheme, strlen(scheme)); + } + if(!result && authority) { + result = Curl_dynhds_add(h2_headers, STRCONST(HTTP_PSEUDO_AUTHORITY), + authority, strlen(authority)); + } + if(!result && req->path) { + result = Curl_dynhds_add(h2_headers, STRCONST(HTTP_PSEUDO_PATH), + req->path, strlen(req->path)); + } + for(i = 0; !result && i < Curl_dynhds_count(&req->headers); ++i) { + e = Curl_dynhds_getn(&req->headers, i); + /* "TE" is special in that it is only permissible when it + * has only value "trailers". RFC 9113 ch. 8.2.2 */ + if(e->namelen == 2 && curl_strequal("TE", e->name)) { + if(http_TE_has_token(e->value, "trailers")) + result = Curl_dynhds_add(h2_headers, e->name, e->namelen, + "trailers", sizeof("trailers") - 1); + } + else if(h2_permissible_field(e)) { + result = Curl_dynhds_add(h2_headers, e->name, e->namelen, + e->value, e->valuelen); + } + } + + return result; +} + +CURLcode Curl_http_resp_make(struct http_resp **presp, + int status, + const char *description) +{ + struct http_resp *resp; + CURLcode result = CURLE_OUT_OF_MEMORY; + + resp = curlx_calloc(1, sizeof(*resp)); + if(!resp) + goto out; + + resp->status = status; + if(description) { + resp->description = curlx_strdup(description); + if(!resp->description) + goto out; + } + Curl_dynhds_init(&resp->headers, 0, DYN_HTTP_REQUEST); + Curl_dynhds_init(&resp->trailers, 0, DYN_HTTP_REQUEST); + result = CURLE_OK; + +out: + if(result && resp) + Curl_http_resp_free(resp); + *presp = result ? NULL : resp; + return result; +} + +void Curl_http_resp_free(struct http_resp *resp) +{ + if(resp) { + curlx_free(resp->description); + Curl_dynhds_free(&resp->headers); + Curl_dynhds_free(&resp->trailers); + if(resp->prev) + Curl_http_resp_free(resp->prev); + curlx_free(resp); + } +} + +/* + * HTTP handler interface. + */ +const struct Curl_protocol Curl_protocol_http = { + Curl_http_setup_conn, /* setup_connection */ + Curl_http, /* do_it */ + Curl_http_done, /* done */ + ZERO_NULL, /* do_more */ + ZERO_NULL, /* connect_it */ + ZERO_NULL, /* connecting */ + ZERO_NULL, /* doing */ + ZERO_NULL, /* proto_pollset */ + Curl_http_doing_pollset, /* doing_pollset */ + ZERO_NULL, /* domore_pollset */ + Curl_http_perform_pollset, /* perform_pollset */ + ZERO_NULL, /* disconnect */ + Curl_http_write_resp, /* write_resp */ + Curl_http_write_resp_hd, /* write_resp_hd */ + ZERO_NULL, /* connection_is_dead */ + ZERO_NULL, /* attach connection */ + Curl_http_follow, /* follow */ +}; + +#endif /* CURL_DISABLE_HTTP */ diff --git a/3rdparty/curl-8.21.0/lib/http.h b/3rdparty/curl-8.21.0/lib/http.h new file mode 100644 index 0000000000..5050215743 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/http.h @@ -0,0 +1,274 @@ +#ifndef HEADER_CURL_HTTP_H +#define HEADER_CURL_HTTP_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "bufq.h" +#include "dynhds.h" + +typedef enum { + HTTPREQ_GET, + HTTPREQ_POST, + HTTPREQ_POST_FORM, /* we make a difference internally */ + HTTPREQ_POST_MIME, /* we make a difference internally */ + HTTPREQ_PUT, + HTTPREQ_HEAD +} Curl_HttpReq; + +#define CURL_HTTP_V1x (1 << 0) +#define CURL_HTTP_V2x (1 << 1) +#define CURL_HTTP_V3x (1 << 2) +/* bitmask of CURL_HTTP_V* values */ +typedef unsigned char http_majors; + +#ifndef CURL_DISABLE_HTTP + +extern const struct Curl_protocol Curl_protocol_http; + +struct dynhds; + +struct http_negotiation { + unsigned char rcvd_min; /* minimum version seen in responses, 09, 10, 11 */ + http_majors wanted; /* wanted major versions when talking to server */ + http_majors allowed; /* allowed major versions when talking to server */ + http_majors preferred; /* preferred major version when talking to server */ + BIT(h2_upgrade); /* Do HTTP Upgrade from 1.1 to 2 */ + BIT(h2_prior_knowledge); /* Directly do HTTP/2 without ALPN/SSL */ + BIT(accept_09); /* Accept an HTTP/0.9 response */ + BIT(only_10); /* When using major version 1x, use only 1.0 */ +}; + +void Curl_http_neg_init(struct Curl_easy *data, struct http_negotiation *neg); + +CURLcode Curl_bump_headersize(struct Curl_easy *data, + size_t delta, + bool connect_only); + +/* Header specific functions */ +bool Curl_compareheader(const char *headerline, /* line to check */ + const char *header, /* header keyword _with_ colon */ + const size_t hlen, /* len of the keyword in bytes */ + const char *content, /* content string to find */ + const size_t clen); /* len of the content in bytes */ + +char *Curl_copy_header_value(const char *header); + +char *Curl_checkProxyheaders(struct Curl_easy *data, + const struct connectdata *conn, + const char *thisheader, + const size_t thislen); + +CURLcode Curl_add_timecondition(struct Curl_easy *data, struct dynbuf *req); +CURLcode Curl_add_custom_headers(struct Curl_easy *data, bool is_connect, + int httpversion, struct dynbuf *req); + +void Curl_http_to_fold(struct dynbuf *bf); + +void Curl_http_method(struct Curl_easy *data, + const char **method, Curl_HttpReq *reqp); + +/* protocol-specific functions set up to be called by the main engine */ +CURLcode Curl_http_setup_conn(struct Curl_easy *data, + struct connectdata *conn); +CURLcode Curl_http(struct Curl_easy *data, bool *done); +CURLcode Curl_http_done(struct Curl_easy *data, + CURLcode status, bool premature); +CURLcode Curl_http_doing_pollset(struct Curl_easy *data, + struct easy_pollset *ps); +CURLcode Curl_http_perform_pollset(struct Curl_easy *data, + struct easy_pollset *ps); +CURLcode Curl_http_write_resp(struct Curl_easy *data, + const char *buf, size_t blen, + bool is_eos); +CURLcode Curl_http_write_resp_hd(struct Curl_easy *data, + const char *hd, size_t hdlen, + bool is_eos); + +/* check a received header line for forbidden bytes/format, the same checks + applied to regular response headers */ +CURLcode Curl_verify_header(struct Curl_easy *data, + const char *hd, size_t hdlen); + +/* These functions are in http.c */ +CURLcode Curl_http_input_auth(struct Curl_easy *data, bool proxy, + const char *auth); + +CURLcode Curl_http_auth_act(struct Curl_easy *data); + +/* follow a redirect or not */ +CURLcode Curl_http_follow(struct Curl_easy *data, const char *newurl, + followtype type); + +/* If only the PICKNONE bit is set, there has been a round-trip and we + selected to use no auth at all. Ie, we actively select no auth, as opposed + to not having one selected. The other CURLAUTH_* defines are present in the + public curl/curl.h header. */ +#define CURLAUTH_PICKNONE (1 << 30) /* do not use auth */ + +/* MAX_INITIAL_POST_SIZE indicates the number of bytes that will make the POST + data get included in the initial data chunk sent to the server. If the + data is larger than this, it will automatically get split up in multiple + system calls. + + This value used to be fairly big (100K), but we must take into account that + if the server rejects the POST due for authentication reasons, this data + will always be unconditionally sent and thus it may not be larger than can + always be afforded to send twice. + + It must not be greater than 64K to work on VMS. +*/ +#ifndef MAX_INITIAL_POST_SIZE +#define MAX_INITIAL_POST_SIZE (64 * 1024) +#endif + +/* EXPECT_100_THRESHOLD is the request body size limit for when libcurl will + * automatically add an "Expect: 100-continue" header in HTTP requests. When + * the size is unknown, it will always add it. + * + */ +#ifndef EXPECT_100_THRESHOLD +#define EXPECT_100_THRESHOLD (1024 * 1024) +#endif + +/* MAX_HTTP_RESP_HEADER_SIZE is the maximum size of all response headers + combined that libcurl allows for a single HTTP response, any HTTP + version. This count includes CONNECT response headers. */ +#define MAX_HTTP_RESP_HEADER_SIZE (300 * 1024) + +/* MAX_HTTP_RESP_HEADER_COUNT is the maximum number of response headers that + libcurl allows for a single HTTP response, including CONNECT and + redirects. */ +#define MAX_HTTP_RESP_HEADER_COUNT 5000 + +#endif /* CURL_DISABLE_HTTP */ + +/**************************************************************************** + * HTTP unique setup + ***************************************************************************/ + +CURLcode Curl_http_write_resp_hds(struct Curl_easy *data, + const char *buf, size_t blen, + size_t *pconsumed); + +/** + * Curl_http_output_auth() setups the authentication headers for the + * host/proxy and the correct authentication + * method. data->state.authdone is set to TRUE when authentication is + * done. + * + * @param data all information about the current transfer + * @param conn all information about the current connection + * @param request pointer to the request keyword + * @param httpreq is the request type + * @param path pointer to the requested path + * @param query pointer to the requested query or NULL + * @param is_connect boolean if this is a CONNECT request + * (where httpreq is HTTPREQ_GET since there is no HTTPREQ_CONNECT) + * + * @returns CURLcode + */ +CURLcode Curl_http_output_auth(struct Curl_easy *data, + struct connectdata *conn, + const char *request, + Curl_HttpReq httpreq, + const char *path, + const char *query, + bool is_connect); + +/* Decode HTTP status code string. */ +CURLcode Curl_http_decode_status(int *pstatus, const char *s, size_t len); + +/** + * All about a core HTTP request, excluding body and trailers + */ +struct httpreq { + struct dynhds headers; + struct dynhds trailers; + char *scheme; + char *authority; + char *path; + char method[1]; +}; + +/** + * Create an HTTP request struct. + */ +CURLcode Curl_http_req_make(struct httpreq **preq, + const char *method, size_t m_len, + const char *scheme, size_t s_len, + const char *authority, size_t a_len, + const char *path, size_t p_len); + +CURLcode Curl_http_req_make2(struct httpreq **preq, + const char *method, size_t m_len, + CURLU *url, const char *scheme_default); + +void Curl_http_req_free(struct httpreq *req); + +#define HTTP_PSEUDO_METHOD ":method" +#define HTTP_PSEUDO_SCHEME ":scheme" +#define HTTP_PSEUDO_AUTHORITY ":authority" +#define HTTP_PSEUDO_PATH ":path" +#define HTTP_PSEUDO_STATUS ":status" + +/** + * Create the list of HTTP/2 headers which represent the request, + * using HTTP/2 pseudo headers preceding the `req->headers`. + * + * Applies the following transformations: + * - if `authority` is set, any "Host" header is removed. + * - if `authority` is unset and a "Host" header is present, use + * that as `authority` and remove "Host" + * - removes and Connection header fields as defined in rfc9113 ch. 8.2.2 + * - lower-cases the header field names + * + * @param h2_headers will contain the HTTP/2 headers on success + * @param req the request to transform + * @param data the handle to lookup defaults like ' :scheme' from + */ +CURLcode Curl_http_req_to_h2(struct dynhds *h2_headers, + struct httpreq *req, struct Curl_easy *data); + +/** + * All about a core HTTP response, excluding body and trailers + */ +struct http_resp { + int status; + char *description; + struct dynhds headers; + struct dynhds trailers; + struct http_resp *prev; +}; + +/** + * Create an HTTP response struct. + */ +CURLcode Curl_http_resp_make(struct http_resp **presp, + int status, + const char *description); + +void Curl_http_resp_free(struct http_resp *resp); + +#endif /* HEADER_CURL_HTTP_H */ diff --git a/3rdparty/curl-8.21.0/lib/http1.c b/3rdparty/curl-8.21.0/lib/http1.c new file mode 100644 index 0000000000..60ad32ce89 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/http1.c @@ -0,0 +1,347 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifndef CURL_DISABLE_HTTP + +#include "urldata.h" +#include "http.h" +#include "http1.h" +#include "urlapi-int.h" + + +#define H1_MAX_URL_LEN (8 * 1024) + +void Curl_h1_req_parse_init(struct h1_req_parser *parser, size_t max_line_len) +{ + memset(parser, 0, sizeof(*parser)); + parser->max_line_len = max_line_len; + curlx_dyn_init(&parser->scratch, max_line_len); +} + +void Curl_h1_req_parse_free(struct h1_req_parser *parser) +{ + if(parser) { + Curl_http_req_free(parser->req); + curlx_dyn_free(&parser->scratch); + parser->req = NULL; + parser->done = FALSE; + } +} + +static CURLcode trim_line(struct h1_req_parser *parser, int options) +{ + DEBUGASSERT(parser->line); + if(parser->line_len) { + if(parser->line[parser->line_len - 1] == '\n') + --parser->line_len; + if(parser->line_len) { + if(parser->line[parser->line_len - 1] == '\r') + --parser->line_len; + else if(options & H1_PARSE_OPT_STRICT) + return CURLE_URL_MALFORMAT; + } + else if(options & H1_PARSE_OPT_STRICT) + return CURLE_URL_MALFORMAT; + } + else if(options & H1_PARSE_OPT_STRICT) + return CURLE_URL_MALFORMAT; + + if(parser->line_len > parser->max_line_len) { + return CURLE_URL_MALFORMAT; + } + return CURLE_OK; +} + +static CURLcode detect_line(struct h1_req_parser *parser, + const uint8_t *buf, const size_t buflen, + size_t *pnread) +{ + const char *line_end; + + DEBUGASSERT(!parser->line); + *pnread = 0; + line_end = memchr(buf, '\n', buflen); + if(!line_end) + return CURLE_AGAIN; + parser->line = (const char *)buf; + parser->line_len = line_end - parser->line + 1; + *pnread = parser->line_len; + return CURLE_OK; +} + +static CURLcode next_line(struct h1_req_parser *parser, + const uint8_t *buf, const size_t buflen, int options, + size_t *pnread) +{ + CURLcode result; + + *pnread = 0; + if(parser->line) { + parser->line = NULL; + parser->line_len = 0; + curlx_dyn_reset(&parser->scratch); + } + + result = detect_line(parser, buf, buflen, pnread); + if(!result) { + if(curlx_dyn_len(&parser->scratch)) { + /* append detected line to scratch to have the complete line */ + result = curlx_dyn_addn(&parser->scratch, parser->line, + parser->line_len); + if(result) + return result; + parser->line = curlx_dyn_ptr(&parser->scratch); + parser->line_len = curlx_dyn_len(&parser->scratch); + } + result = trim_line(parser, options); + if(result) + return result; + } + else if(result == CURLE_AGAIN) { + /* no line end in `buf`, add it to our scratch */ + result = curlx_dyn_addn(&parser->scratch, (const unsigned char *)buf, + buflen); + *pnread = buflen; + } + return result; +} + +static CURLcode start_req(struct h1_req_parser *parser, + const char *scheme_default, + const char *custom_method, + int options) +{ + const char *p, *m, *target, *hv, *scheme, *authority, *path; + size_t m_len, target_len, hv_len, scheme_len, authority_len, path_len; + size_t i; + CURLU *url = NULL; + CURLcode result = CURLE_URL_MALFORMAT; /* Use this as default fail */ + + DEBUGASSERT(!parser->req); + /* line must match: "METHOD TARGET HTTP_VERSION" */ + if(custom_method && custom_method[0] && + !strncmp(custom_method, parser->line, strlen(custom_method))) { + p = parser->line + strlen(custom_method); + } + else { + p = memchr(parser->line, ' ', parser->line_len); + if(!p || p == parser->line) + goto out; + } + + m = parser->line; + m_len = p - parser->line; + target = p + 1; + target_len = hv_len = 0; + hv = NULL; + + /* URL may contain spaces so scan backwards */ + for(i = parser->line_len; i > m_len; --i) { + if(parser->line[i] == ' ') { + hv = &parser->line[i + 1]; + hv_len = parser->line_len - i; + target_len = (hv - target) - 1; + break; + } + } + /* no SPACE found or empty TARGET or empty HTTP_VERSION */ + if(!target_len || !hv_len) + goto out; + + (void)hv; + + /* The TARGET can be (rfc 9112, ch. 3.2): + * origin-form: path + optional query + * absolute-form: absolute URI + * authority-form: host+port for CONNECT + * asterisk-form: '*' for OPTIONS + * + * from TARGET, we derive `scheme` `authority` `path` + * origin-form -- -- TARGET + * absolute-form URL* URL* URL* + * authority-form -- TARGET -- + * asterisk-form -- -- TARGET + */ + scheme = authority = path = NULL; + scheme_len = authority_len = path_len = 0; + + if(target_len == 1 && target[0] == '*') { + /* asterisk-form */ + path = target; + path_len = target_len; + } + else if(!strncmp("CONNECT", m, m_len)) { + /* authority-form */ + authority = target; + authority_len = target_len; + } + else if(target[0] == '/') { + /* origin-form */ + path = target; + path_len = target_len; + } + else { + /* origin-form OR absolute-form */ + CURLUcode uc; + char tmp[H1_MAX_URL_LEN]; + + /* default, unless we see an absolute URL */ + path = target; + path_len = target_len; + + /* URL parser wants null-termination */ + if(target_len >= sizeof(tmp)) + goto out; + memcpy(tmp, target, target_len); + tmp[target_len] = '\0'; + /* See if treating TARGET as an absolute URL makes sense */ + if(Curl_is_absolute_url(tmp, NULL, 0, FALSE)) { + unsigned int url_options; + + url = curl_url(); + if(!url) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + url_options = (CURLU_NON_SUPPORT_SCHEME | + CURLU_PATH_AS_IS | + CURLU_NO_DEFAULT_PORT); + if(!(options & H1_PARSE_OPT_STRICT)) + url_options |= CURLU_ALLOW_SPACE; + uc = curl_url_set(url, CURLUPART_URL, tmp, url_options); + if(uc) { + goto out; + } + } + + if(!url && (options & H1_PARSE_OPT_STRICT)) { + /* we should have an absolute URL or have seen `/` earlier */ + goto out; + } + } + + if(url) { + result = Curl_http_req_make2(&parser->req, m, m_len, url, scheme_default); + } + else { + if(!scheme && scheme_default) { + scheme = scheme_default; + scheme_len = strlen(scheme_default); + } + result = Curl_http_req_make(&parser->req, m, m_len, scheme, scheme_len, + authority, authority_len, path, path_len); + } + +out: + curl_url_cleanup(url); + return result; +} + +CURLcode Curl_h1_req_parse_read(struct h1_req_parser *parser, + const uint8_t *buf, size_t buflen, + const char *scheme_default, + const char *custom_method, + int options, size_t *pnread) +{ + CURLcode result = CURLE_OK; + size_t nread; + + *pnread = 0; + + DEBUGASSERT(buf); + if(!buf) + return CURLE_BAD_FUNCTION_ARGUMENT; + + while(!parser->done) { + result = next_line(parser, buf, buflen, options, &nread); + if(result) { + if(result == CURLE_AGAIN) + result = CURLE_OK; + goto out; + } + + /* Consume this line */ + *pnread += nread; + buf += nread; + buflen -= nread; + + if(!parser->line) { + /* consumed bytes, but line not complete */ + if(!buflen) + goto out; + } + else if(!parser->req) { + result = start_req(parser, scheme_default, custom_method, options); + if(result) + goto out; + } + else if(parser->line_len == 0) { + /* last, empty line, we are finished */ + if(!parser->req) { + result = CURLE_URL_MALFORMAT; + goto out; + } + parser->done = TRUE; + curlx_dyn_reset(&parser->scratch); + /* last chance adjustments */ + } + else { + result = Curl_dynhds_h1_add_line(&parser->req->headers, + parser->line, parser->line_len); + if(result) + goto out; + } + } + +out: + return result; +} + +CURLcode Curl_h1_req_write_head(struct httpreq *req, int http_minor, + struct dynbuf *dbuf) +{ + CURLcode result; + + result = curlx_dyn_addf(dbuf, "%s %s%s%s%s HTTP/1.%d\r\n", + req->method, + req->scheme ? req->scheme : "", + req->scheme ? "://" : "", + req->authority ? req->authority : "", + req->path ? req->path : "", + http_minor); + if(result) + goto out; + + result = Curl_dynhds_h1_dprint(&req->headers, dbuf); + if(result) + goto out; + + result = curlx_dyn_addn(dbuf, STRCONST("\r\n")); + +out: + return result; +} + +#endif /* !CURL_DISABLE_HTTP */ diff --git a/3rdparty/curl-8.21.0/lib/http1.h b/3rdparty/curl-8.21.0/lib/http1.h new file mode 100644 index 0000000000..c2894613de --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/http1.h @@ -0,0 +1,63 @@ +#ifndef HEADER_CURL_HTTP1_H +#define HEADER_CURL_HTTP1_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifndef CURL_DISABLE_HTTP +#include "bufq.h" +#include "http.h" + +#define H1_PARSE_OPT_NONE 0 +#define H1_PARSE_OPT_STRICT (1 << 0) + +#define H1_PARSE_DEFAULT_MAX_LINE_LEN DYN_HTTP_REQUEST + +struct h1_req_parser { + struct httpreq *req; + struct dynbuf scratch; + size_t scratch_skip; + const char *line; + size_t max_line_len; + size_t line_len; + BIT(done); +}; + +void Curl_h1_req_parse_init(struct h1_req_parser *parser, size_t max_line_len); +void Curl_h1_req_parse_free(struct h1_req_parser *parser); + +CURLcode Curl_h1_req_parse_read(struct h1_req_parser *parser, + const uint8_t *buf, size_t buflen, + const char *scheme_default, + const char *custom_method, + int options, size_t *pnread); + +CURLcode Curl_h1_req_dprint(const struct httpreq *req, + struct dynbuf *dbuf); + +CURLcode Curl_h1_req_write_head(struct httpreq *req, int http_minor, + struct dynbuf *dbuf); + +#endif /* !CURL_DISABLE_HTTP */ +#endif /* HEADER_CURL_HTTP1_H */ diff --git a/3rdparty/curl-8.21.0/lib/http2.c b/3rdparty/curl-8.21.0/lib/http2.c new file mode 100644 index 0000000000..a820439ef4 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/http2.c @@ -0,0 +1,2994 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_HTTP) && defined(USE_NGHTTP2) +#include + +#include "urldata.h" +#include "bufq.h" +#include "uint-hash.h" +#include "http1.h" +#include "http2.h" +#include "http.h" +#include "sendf.h" +#include "curl_trc.h" +#include "select.h" +#include "curlx/base64.h" +#include "multiif.h" +#include "progress.h" +#include "url.h" +#include "urlapi-int.h" +#include "cfilters.h" +#include "connect.h" +#include "transfer.h" +#include "bufref.h" +#include "curlx/dynbuf.h" +#include "headers.h" + +#if NGHTTP2_VERSION_NUM < 0x010f00 +#error "nghttp2 1.15.0 or greater required" +#endif + +#define NGHTTP2_HAS_SET_LOCAL_WINDOW_SIZE 1 + +/* buffer dimensioning: + * use 16K as chunk size, as that fits H2 DATA frames well */ +#define H2_CHUNK_SIZE (16 * 1024) +/* connection window size */ +#define H2_CONN_WINDOW_SIZE (10 * 1024 * 1024) +/* on receiving from TLS, we prep for holding a full stream window */ +#define H2_NW_RECV_CHUNKS (H2_CONN_WINDOW_SIZE / H2_CHUNK_SIZE) +/* on send into TLS, we want to accumulate small frames */ +#define H2_NW_SEND_CHUNKS 1 +/* this is how much we want "in flight" for a stream, unthrottled */ +#define H2_STREAM_WINDOW_SIZE_MAX (10 * 1024 * 1024) +/* this is how much we want "in flight" for a stream, initially, IFF + * nghttp2 allows us to tweak the local window size. */ +#if NGHTTP2_HAS_SET_LOCAL_WINDOW_SIZE +#define H2_STREAM_WINDOW_SIZE_INITIAL (64 * 1024) +#else +#define H2_STREAM_WINDOW_SIZE_INITIAL H2_STREAM_WINDOW_SIZE_MAX +#endif +/* keep smaller stream upload buffer (default h2 window size) to have + * our progress bars and "upload done" reporting closer to reality */ +#define H2_STREAM_SEND_CHUNKS ((64 * 1024) / H2_CHUNK_SIZE) +/* spare chunks we keep for a full window */ +#define H2_STREAM_POOL_SPARES (H2_CONN_WINDOW_SIZE / H2_CHUNK_SIZE) + +/* We need to accommodate the max number of streams with their window sizes on + * the overall connection. Streams might become PAUSED which will block their + * received QUOTA in the connection window. If we run out of space, the server + * is blocked from sending us any data. See #10988 for an issue with this. */ +#define HTTP2_HUGE_WINDOW_SIZE (100 * H2_STREAM_WINDOW_SIZE_MAX) + +#define H2_SETTINGS_IV_LEN 3 +#define H2_BINSETTINGS_LEN 80 + +struct cf_h2_ctx { + nghttp2_session *h2; + /* The easy handle used in the current filter call, cleared at return */ + struct cf_call_data call_data; + + struct bufq inbufq; /* network input */ + struct bufq outbufq; /* network output */ + struct bufc_pool stream_bufcp; /* spares for stream buffers */ + struct dynbuf scratch; /* scratch buffer for temp use */ + + struct uint_hash streams; /* hash of `data->mid` to `h2_stream_ctx` */ + size_t drain_total; /* sum of all stream's UrlState drain */ + uint32_t initial_win_size; /* current initial window size (settings) */ + uint32_t max_concurrent_streams; + uint32_t goaway_error; /* goaway error code from server */ + int32_t remote_max_sid; /* max id processed by server */ + int32_t local_max_sid; /* max id processed by us */ + BIT(initialized); + BIT(via_h1_upgrade); + BIT(conn_closed); + BIT(rcvd_goaway); + BIT(sent_goaway); + BIT(enable_push); + BIT(nw_out_blocked); +}; + +/* How to access `call_data` from a cf_h2 filter */ +#undef CF_CTX_CALL_DATA +#define CF_CTX_CALL_DATA(cf) ((struct cf_h2_ctx *)(cf)->ctx)->call_data + +/** + * All about the H2 internals of a stream + */ +struct h2_stream_ctx { + struct bufq sendbuf; /* request buffer */ + struct h1_req_parser h1; /* parsing the request */ + struct dynhds resp_trailers; /* response trailer fields */ + size_t resp_hds_len; /* amount of response header bytes in recvbuf */ + curl_off_t nrcvd_data; /* number of DATA bytes received */ + + char **push_headers; /* allocated array */ + size_t push_headers_used; /* number of entries filled in */ + size_t push_headers_alloc; /* number of entries allocated */ + + int status_code; /* HTTP response status code */ + uint32_t error; /* stream error code */ + CURLcode xfer_result; /* Result of writing out response */ + int32_t local_window_size; /* the local recv window size */ + int32_t id; /* HTTP/2 protocol identifier for stream */ + BIT(resp_hds_complete); /* we have a complete, final response */ + BIT(closed); /* TRUE on stream close */ + BIT(reset); /* TRUE on stream reset */ + BIT(reset_by_server); /* TRUE on stream reset by server */ + BIT(close_handled); /* TRUE if stream closure is handled by libcurl */ + BIT(bodystarted); + BIT(body_eos); /* the complete body has been added to `sendbuf` and + * is being/has been processed from there. */ + BIT(write_paused); /* stream write is paused */ +}; + +static void free_push_headers(struct h2_stream_ctx *stream) +{ + size_t i; + for(i = 0; i < stream->push_headers_used; i++) + curlx_free(stream->push_headers[i]); + curlx_safefree(stream->push_headers); + stream->push_headers_used = 0; +} + +static void h2_stream_ctx_free(struct h2_stream_ctx *stream) +{ + Curl_bufq_free(&stream->sendbuf); + Curl_h1_req_parse_free(&stream->h1); + Curl_dynhds_free(&stream->resp_trailers); + free_push_headers(stream); + curlx_free(stream); +} + +static void h2_stream_hash_free(unsigned int id, void *stream) +{ + (void)id; + DEBUGASSERT(stream); + h2_stream_ctx_free((struct h2_stream_ctx *)stream); +} + +static void cf_h2_ctx_init(struct cf_h2_ctx *ctx, bool via_h1_upgrade) +{ + Curl_bufcp_init(&ctx->stream_bufcp, H2_CHUNK_SIZE, H2_STREAM_POOL_SPARES); + Curl_bufq_initp(&ctx->inbufq, &ctx->stream_bufcp, H2_NW_RECV_CHUNKS, 0); + Curl_bufq_initp(&ctx->outbufq, &ctx->stream_bufcp, H2_NW_SEND_CHUNKS, 0); + curlx_dyn_init(&ctx->scratch, CURL_MAX_HTTP_HEADER); + Curl_uint32_hash_init(&ctx->streams, 63, h2_stream_hash_free); + ctx->remote_max_sid = 2147483647; + ctx->via_h1_upgrade = via_h1_upgrade; + ctx->initialized = TRUE; +} + +static void cf_h2_ctx_free(struct cf_h2_ctx *ctx) +{ + if(ctx && ctx->initialized) { + if(ctx->h2) + nghttp2_session_del(ctx->h2); + Curl_bufq_free(&ctx->inbufq); + Curl_bufq_free(&ctx->outbufq); + Curl_bufcp_free(&ctx->stream_bufcp); + curlx_dyn_free(&ctx->scratch); + Curl_uint32_hash_destroy(&ctx->streams); + memset(ctx, 0, sizeof(*ctx)); + } + curlx_free(ctx); +} + +static uint32_t cf_h2_initial_win_size(struct Curl_easy *data) +{ +#if NGHTTP2_HAS_SET_LOCAL_WINDOW_SIZE + /* If the transfer has a rate-limit lower than the default initial + * stream window size, use that. It needs to be at least 8k or servers + * may be unhappy. */ + curl_off_t rps = Curl_rlimit_per_step(&data->progress.dl.rlimit); + if((rps > 0) && (rps < H2_STREAM_WINDOW_SIZE_INITIAL)) + return CURLMAX((uint32_t)rps, 8192); +#endif + return H2_STREAM_WINDOW_SIZE_INITIAL; +} + +static size_t populate_settings(nghttp2_settings_entry *iv, + struct Curl_easy *data, + struct cf_h2_ctx *ctx) +{ + iv[0].settings_id = NGHTTP2_SETTINGS_MAX_CONCURRENT_STREAMS; + iv[0].value = Curl_multi_max_concurrent_streams(data->multi); + + iv[1].settings_id = NGHTTP2_SETTINGS_INITIAL_WINDOW_SIZE; + iv[1].value = cf_h2_initial_win_size(data); + if(ctx) + ctx->initial_win_size = iv[1].value; + iv[2].settings_id = NGHTTP2_SETTINGS_ENABLE_PUSH; + iv[2].value = !!data->multi->push_cb; + + return 3; +} + +static ssize_t populate_binsettings(uint8_t *binsettings, + struct Curl_easy *data) +{ + nghttp2_settings_entry iv[H2_SETTINGS_IV_LEN]; + size_t ivlen; + + ivlen = populate_settings(iv, data, NULL); + /* this returns number of bytes it wrote or a negative number on error. */ + return nghttp2_pack_settings_payload(binsettings, H2_BINSETTINGS_LEN, + iv, ivlen); +} + +static CURLcode cf_h2_update_settings(struct cf_h2_ctx *ctx, + uint32_t initial_win_size) +{ + nghttp2_settings_entry entry; + entry.settings_id = NGHTTP2_SETTINGS_INITIAL_WINDOW_SIZE; + entry.value = initial_win_size; + if(nghttp2_submit_settings(ctx->h2, NGHTTP2_FLAG_NONE, &entry, 1)) + return CURLE_SEND_ERROR; + ctx->initial_win_size = initial_win_size; + return CURLE_OK; +} + +#define H2_STREAM_CTX(ctx, data) \ + ((struct h2_stream_ctx *)( \ + (data) ? Curl_uint32_hash_get(&(ctx)->streams, (data)->mid) : NULL)) + +static struct h2_stream_ctx *h2_stream_ctx_create(struct cf_h2_ctx *ctx) +{ + struct h2_stream_ctx *stream; + + (void)ctx; + stream = curlx_calloc(1, sizeof(*stream)); + if(!stream) + return NULL; + + stream->id = -1; + Curl_bufq_initp(&stream->sendbuf, &ctx->stream_bufcp, + H2_STREAM_SEND_CHUNKS, BUFQ_OPT_NONE); + Curl_h1_req_parse_init(&stream->h1, H1_PARSE_DEFAULT_MAX_LINE_LEN); + Curl_dynhds_init(&stream->resp_trailers, 0, DYN_HTTP_REQUEST); + stream->bodystarted = FALSE; + stream->status_code = -1; + stream->closed = FALSE; + stream->close_handled = FALSE; + stream->error = NGHTTP2_NO_ERROR; + stream->local_window_size = H2_STREAM_WINDOW_SIZE_INITIAL; + stream->nrcvd_data = 0; + return stream; +} + +#ifdef NGHTTP2_HAS_SET_LOCAL_WINDOW_SIZE +static int32_t cf_h2_get_desired_local_win(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + curl_off_t avail = Curl_rlimit_avail(&data->progress.dl.rlimit, + Curl_pgrs_now(data)); + + (void)cf; + if(avail < CURL_OFF_T_MAX) { /* limit in place */ + if(avail <= 0) + return 0; + else if(avail < INT32_MAX) + return (int32_t)avail; + } + return H2_STREAM_WINDOW_SIZE_MAX; +} + +static CURLcode cf_h2_update_local_win(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h2_stream_ctx *stream) +{ + struct cf_h2_ctx *ctx = cf->ctx; + int32_t dwsize; + int rv; + + dwsize = (stream->write_paused || stream->xfer_result) ? + 0 : cf_h2_get_desired_local_win(cf, data); + if(dwsize != stream->local_window_size) { + int32_t wsize = nghttp2_session_get_stream_effective_local_window_size( + ctx->h2, stream->id); + if(dwsize > wsize) { + rv = nghttp2_session_set_local_window_size(ctx->h2, NGHTTP2_FLAG_NONE, + stream->id, dwsize); + if(rv) { + failf(data, "[%d] nghttp2 set_local_window_size(%d) failed: " + "%s(%d)", stream->id, dwsize, nghttp2_strerror(rv), rv); + return CURLE_HTTP2; + } + rv = nghttp2_submit_window_update(ctx->h2, NGHTTP2_FLAG_NONE, + stream->id, dwsize - wsize); + if(rv) { + failf(data, "[%d] nghttp2_submit_window_update() failed: " + "%s(%d)", stream->id, nghttp2_strerror(rv), rv); + return CURLE_HTTP2; + } + stream->local_window_size = dwsize; + CURL_TRC_CF(data, cf, "[%d] local window update by %d", + stream->id, dwsize - wsize); + } + else { + rv = nghttp2_session_set_local_window_size(ctx->h2, NGHTTP2_FLAG_NONE, + stream->id, dwsize); + if(rv) { + failf(data, "[%d] nghttp2_session_set_local_window_size() failed: " + "%s(%d)", stream->id, nghttp2_strerror(rv), rv); + return CURLE_HTTP2; + } + stream->local_window_size = dwsize; + CURL_TRC_CF(data, cf, "[%d] local window size now %d", + stream->id, dwsize); + } + } + return CURLE_OK; +} + +#else /* NGHTTP2_HAS_SET_LOCAL_WINDOW_SIZE */ + +static CURLcode cf_h2_update_local_win(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h2_stream_ctx *stream) +{ + (void)cf; + (void)data; + (void)stream; + return CURLE_OK; +} +#endif /* !NGHTTP2_HAS_SET_LOCAL_WINDOW_SIZE */ + +static CURLcode http2_data_setup(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h2_stream_ctx **pstream) +{ + struct cf_h2_ctx *ctx = cf->ctx; + struct h2_stream_ctx *stream; + + (void)cf; + DEBUGASSERT(data); + + if(!data) + return CURLE_BAD_FUNCTION_ARGUMENT; + + stream = H2_STREAM_CTX(ctx, data); + if(stream) { + *pstream = stream; + return CURLE_OK; + } + + stream = h2_stream_ctx_create(ctx); + if(!stream) + return CURLE_OUT_OF_MEMORY; + + if(!Curl_uint32_hash_set(&ctx->streams, data->mid, stream)) { + h2_stream_ctx_free(stream); + return CURLE_OUT_OF_MEMORY; + } + + *pstream = stream; + return CURLE_OK; +} + +static CURLcode nw_out_flush(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_h2_ctx *ctx = cf->ctx; + size_t nwritten; + CURLcode result; + + if(Curl_bufq_is_empty(&ctx->outbufq)) + return CURLE_OK; + + result = Curl_cf_send_bufq(cf->next, data, &ctx->outbufq, NULL, 0, + &nwritten); + if(result) { + if(result == CURLE_AGAIN) { + CURL_TRC_CF(data, cf, "flush nw send buffer(%zu) -> EAGAIN", + Curl_bufq_len(&ctx->outbufq)); + ctx->nw_out_blocked = 1; + } + return result; + } + return Curl_bufq_is_empty(&ctx->outbufq) ? CURLE_OK : CURLE_AGAIN; +} + +static void http2_data_done(struct Curl_cfilter *cf, struct Curl_easy *data) +{ + struct cf_h2_ctx *ctx = cf->ctx; + struct h2_stream_ctx *stream = H2_STREAM_CTX(ctx, data); + + DEBUGASSERT(ctx); + if(!stream || !ctx->initialized) + return; + + if(ctx->h2) { + bool flush_egress = FALSE; + /* returns error if stream not known, which is fine here */ + (void)nghttp2_session_set_stream_user_data(ctx->h2, stream->id, NULL); + + if(!stream->closed && stream->id > 0) { + /* RST_STREAM */ + CURL_TRC_CF(data, cf, "[%d] premature DATA_DONE, RST stream", + stream->id); + stream->closed = TRUE; + stream->reset = TRUE; + nghttp2_submit_rst_stream(ctx->h2, NGHTTP2_FLAG_NONE, + stream->id, NGHTTP2_STREAM_CLOSED); + flush_egress = TRUE; + } + + if(flush_egress) { + (void)nghttp2_session_send(ctx->h2); + (void)nw_out_flush(cf, data); + } + } + + Curl_uint32_hash_remove(&ctx->streams, data->mid); +} + +static int h2_client_new(struct Curl_cfilter *cf, + nghttp2_session_callbacks *cbs) +{ + struct cf_h2_ctx *ctx = cf->ctx; + nghttp2_option *o; + nghttp2_mem mem = { NULL, Curl_nghttp2_malloc, Curl_nghttp2_free, + Curl_nghttp2_calloc, Curl_nghttp2_realloc }; + + int rc = nghttp2_option_new(&o); + if(rc) + return rc; + /* We handle window updates ourself to enforce buffer limits */ + nghttp2_option_set_no_auto_window_update(o, 1); +#if NGHTTP2_VERSION_NUM >= 0x013200 /* with 1.50.0 */ + /* turn off RFC 9113 leading and trailing white spaces validation against + HTTP field value. */ + nghttp2_option_set_no_rfc9113_leading_and_trailing_ws_validation(o, 1); +#endif + rc = nghttp2_session_client_new3(&ctx->h2, cbs, cf, o, &mem); + nghttp2_option_del(o); + return rc; +} + +/* + * Returns nonzero if current HTTP/2 session should be closed. + */ +static int should_close_session(struct cf_h2_ctx *ctx) +{ + return ctx->drain_total == 0 && !nghttp2_session_want_read(ctx->h2) && + !nghttp2_session_want_write(ctx->h2); +} + +/* + * Processes pending input left in network input buffer. + * This function returns 0 if it succeeds, or -1 and error code will + * be assigned to *err. + */ +static CURLcode h2_process_pending_input(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_h2_ctx *ctx = cf->ctx; + const unsigned char *buf; + size_t blen, nread; + ssize_t rv; + + while(Curl_bufq_peek(&ctx->inbufq, &buf, &blen)) { + rv = nghttp2_session_mem_recv(ctx->h2, (const uint8_t *)buf, blen); + if(!curlx_sztouz(rv, &nread)) { + failf(data, "nghttp2 recv error %zd: %s", rv, nghttp2_strerror((int)rv)); + return CURLE_HTTP2; + } + Curl_bufq_skip(&ctx->inbufq, nread); + if(Curl_bufq_is_empty(&ctx->inbufq)) { + break; + } + else { + CURL_TRC_CF(data, cf, "process_pending_input: %zu bytes left " + "in connection buffer", Curl_bufq_len(&ctx->inbufq)); + } + } + + if(nghttp2_session_check_request_allowed(ctx->h2) == 0) { + /* No more requests are allowed in the current session, so + the connection may not be reused. This is set when a + GOAWAY frame has been received or when the limit of stream + identifiers has been reached. */ + connclose(cf->conn, "http/2: No new requests allowed"); + } + + return CURLE_OK; +} + +/* + * The server may send us data at any point (e.g. PING frames). Therefore, we + * cannot assume that an HTTP/2 socket is dead because it is readable. + * + * Check the lower filters first and, if successful, peek at the socket + * and distinguish between closed and data. + */ +static bool http2_connisalive(struct Curl_cfilter *cf, struct Curl_easy *data, + bool *input_pending) +{ + struct cf_h2_ctx *ctx = cf->ctx; + bool alive = TRUE; + + *input_pending = FALSE; + if(!cf->next || !cf->next->cft->is_alive(cf->next, data, input_pending)) + return FALSE; + + if(*input_pending) { + /* This happens before we have sent off a request and the connection is + not in use by any other transfer, there should not be any data here, + only "protocol frames" */ + CURLcode result; + size_t nread; + + *input_pending = FALSE; + result = Curl_cf_recv_bufq(cf->next, data, &ctx->inbufq, 0, &nread); + if(!result) { + CURL_TRC_CF(data, cf, "%zu bytes stray data read before trying " + "h2 connection", nread); + result = h2_process_pending_input(cf, data); + if(result) + /* immediate error, considered dead */ + alive = FALSE; + else { + alive = !should_close_session(ctx); + } + } + else if(result != CURLE_AGAIN) { + /* the read failed so let's say this is dead anyway */ + alive = FALSE; + } + } + + return alive; +} + +static CURLcode http2_send_ping(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_h2_ctx *ctx = cf->ctx; + int rc; + + rc = nghttp2_submit_ping(ctx->h2, 0, ZERO_NULL); + if(rc) { + failf(data, "nghttp2_submit_ping() failed: %s(%d)", + nghttp2_strerror(rc), rc); + return CURLE_HTTP2; + } + + rc = nghttp2_session_send(ctx->h2); + if(rc) { + failf(data, "nghttp2_session_send() failed: %s(%d)", + nghttp2_strerror(rc), rc); + return CURLE_SEND_ERROR; + } + return CURLE_OK; +} + +/* + * Store nghttp2 version info in this buffer. + */ +void Curl_http2_ver(char *p, size_t len) +{ + nghttp2_info *h2 = nghttp2_version(0); + (void)curl_msnprintf(p, len, "nghttp2/%s", h2->version_str); +} + +/* + * The implementation of nghttp2_send_callback type. Here we write |data| with + * size |length| to the network and return the number of bytes actually + * written. See the documentation of nghttp2_send_callback for the details. + */ +static ssize_t send_callback(nghttp2_session *h2, + const uint8_t *buf, size_t blen, int flags, + void *userp) +{ + struct Curl_cfilter *cf = userp; + struct cf_h2_ctx *ctx = cf->ctx; + struct Curl_easy *data = CF_DATA_CURRENT(cf); + size_t nwritten; + CURLcode result = CURLE_OK; + + (void)h2; + (void)flags; + DEBUGASSERT(data); + + if(!cf->connected) + result = Curl_bufq_write(&ctx->outbufq, buf, blen, &nwritten); + else + result = Curl_cf_send_bufq(cf->next, data, &ctx->outbufq, buf, blen, + &nwritten); + + if(result) { + if(result == CURLE_AGAIN) { + ctx->nw_out_blocked = 1; + return NGHTTP2_ERR_WOULDBLOCK; + } + failf(data, "Failed sending HTTP2 data"); + return NGHTTP2_ERR_CALLBACK_FAILURE; + } + + if(!nwritten) { + ctx->nw_out_blocked = 1; + return NGHTTP2_ERR_WOULDBLOCK; + } + return (nwritten > SSIZE_MAX) ? + NGHTTP2_ERR_CALLBACK_FAILURE : (ssize_t)nwritten; +} + +/* We pass a pointer to this struct in the push callback, but the contents of + the struct are hidden from the user. */ +struct curl_pushheaders { + struct Curl_easy *data; + struct h2_stream_ctx *stream; + const nghttp2_push_promise *frame; +}; + +/* + * push header access function. Only to be used from within the push callback + */ +char *curl_pushheader_bynum(struct curl_pushheaders *h, size_t num) +{ + /* Verify that we got a good easy handle in the push header struct, mostly to + detect rubbish input fast(er). */ + if(!h || !GOOD_EASY_HANDLE(h->data)) + return NULL; + else { + if(h->stream && num < h->stream->push_headers_used) + return h->stream->push_headers[num]; + } + return NULL; +} + +/* + * push header access function. Only to be used from within the push callback + */ +char *curl_pushheader_byname(struct curl_pushheaders *h, const char *name) +{ + struct h2_stream_ctx *stream; + size_t len; + size_t i; + /* Verify that we got a good easy handle in the push header struct, + mostly to detect rubbish input fast(er). Also empty header name + is rubbish too. We have to allow ":" at the beginning of + the header, but header == ":" must be rejected. If we have ':' in + the middle of header, it could be matched in middle of the value, + this is because we do prefix match.*/ + if(!h || !GOOD_EASY_HANDLE(h->data) || !name || !name[0] || + !strcmp(name, ":") || strchr(name + 1, ':')) + return NULL; + + stream = h->stream; + if(!stream) + return NULL; + + len = strlen(name); + for(i = 0; i < stream->push_headers_used; i++) { + if(!strncmp(name, stream->push_headers[i], len)) { + /* sub-match, make sure that it is followed by a colon */ + if(stream->push_headers[i][len] != ':') + continue; + return &stream->push_headers[i][len + 1]; + } + } + return NULL; +} + +static struct Curl_easy *h2_duphandle(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct Curl_easy *second = curl_easy_duphandle(data); + if(second) { + struct h2_stream_ctx *second_stream; + http2_data_setup(cf, second, &second_stream); + second->state.priority.weight = data->state.priority.weight; + } + return second; +} + +static int set_transfer_url(struct Curl_easy *newhandle, + struct curl_pushheaders *hp, + struct Curl_easy *data) +{ + const char *v; + CURLUcode uc; + char *url = NULL; + int rc = 0; + CURLU *u = curl_url(); + + if(!u) + return 5; + + v = curl_pushheader_byname(hp, HTTP_PSEUDO_SCHEME); + if(v) { + uc = curl_url_set(u, CURLUPART_SCHEME, v, 0); + if(uc) { + rc = 1; + goto fail; + } + } + + v = curl_pushheader_byname(hp, HTTP_PSEUDO_AUTHORITY); + if(v) { + uc = Curl_url_set_authority(u, v); + if(uc) { + rc = 2; + goto fail; + } + } + + v = curl_pushheader_byname(hp, HTTP_PSEUDO_PATH); + if(v) { + uc = curl_url_set(u, CURLUPART_PATH, v, 0); + if(uc) { + rc = 3; + goto fail; + } + } + + /* We can only allow PUSH of resource from the same origin, e.g. + * scheme + hostname + port */ + if(!Curl_url_same_origin(data->state.uh, u)) { + rc = 1; + goto fail; + } + + uc = curl_url_get(u, CURLUPART_URL, &url, 0); + if(uc) + rc = 4; +fail: + curl_url_cleanup(u); + if(rc) + return rc; + + Curl_bufref_set(&newhandle->state.url, url, 0, curl_free); + return 0; +} + +static void discard_newhandle(struct Curl_cfilter *cf, + struct Curl_easy *newhandle) +{ + http2_data_done(cf, newhandle); + (void)Curl_close(&newhandle); +} + +static int push_promise(struct Curl_cfilter *cf, + struct Curl_easy *data, + const nghttp2_push_promise *frame) +{ + struct cf_h2_ctx *ctx = cf->ctx; + int rv; /* one of the CURL_PUSH_* defines */ + + CURL_TRC_CF(data, cf, "[%d] PUSH_PROMISE received", + frame->promised_stream_id); + if(data->multi->push_cb) { + struct h2_stream_ctx *stream; + struct h2_stream_ctx *newstream; + struct curl_pushheaders heads; + CURLMcode mresult; + CURLcode result; + /* clone the parent */ + struct Curl_easy *newhandle = h2_duphandle(cf, data); + if(!newhandle) { + infof(data, "failed to duplicate handle"); + rv = CURL_PUSH_DENY; /* FAIL HARD */ + goto fail; + } + + stream = H2_STREAM_CTX(ctx, data); + if(!stream) { + failf(data, "Internal NULL stream"); + discard_newhandle(cf, newhandle); + rv = CURL_PUSH_DENY; + goto fail; + } + + heads.data = data; + heads.stream = stream; + heads.frame = frame; + + rv = set_transfer_url(newhandle, &heads, data); + if(rv) { + CURL_TRC_CF(data, cf, "[%d] PUSH_PROMISE, failed to set URL -> %d", + frame->promised_stream_id, rv); + discard_newhandle(cf, newhandle); + rv = CURL_PUSH_DENY; + goto fail; + } + + Curl_set_in_callback(data, TRUE); + rv = data->multi->push_cb(data, newhandle, + stream->push_headers_used, &heads, + data->multi->push_userp); + Curl_set_in_callback(data, FALSE); + + /* free the headers again */ + free_push_headers(stream); + + if(rv) { + DEBUGASSERT((rv > CURL_PUSH_OK) && (rv <= CURL_PUSH_ERROROUT)); + /* denied, kill off the new handle again */ + CURL_TRC_CF(data, cf, "[%d] PUSH_PROMISE, denied by application -> %d", + frame->promised_stream_id, rv); + discard_newhandle(cf, newhandle); + goto fail; + } + + /* approved, add to the multi handle for processing. This + * assigns newhandle->mid. For the new `mid` we assign the + * h2_stream instance and remember the stream_id already known. */ + mresult = Curl_multi_add_perform(data->multi, newhandle, cf->conn); + if(mresult) { + infof(data, "failed to add handle to multi"); + discard_newhandle(cf, newhandle); + rv = CURL_PUSH_DENY; + goto fail; + } + + result = http2_data_setup(cf, newhandle, &newstream); + if(result) { + failf(data, "error setting up stream: %d", (int)result); + discard_newhandle(cf, newhandle); + rv = CURL_PUSH_DENY; + goto fail; + } + + DEBUGASSERT(newstream); + newstream->id = frame->promised_stream_id; + newhandle->req.maxdownload = -1; + newhandle->req.size = -1; + + CURL_TRC_CF(data, cf, "promise easy handle added to multi, mid=%u", + newhandle->mid); + rv = nghttp2_session_set_stream_user_data(ctx->h2, + newstream->id, + newhandle); + if(rv) { + infof(data, "failed to set user_data for stream %d", + newstream->id); + DEBUGASSERT(0); + discard_newhandle(cf, newhandle); + rv = CURL_PUSH_DENY; + goto fail; + } + + /* success, remember max stream id processed */ + if(newstream->id > ctx->local_max_sid) + ctx->local_max_sid = newstream->id; + } + else { + CURL_TRC_CF(data, cf, "Got PUSH_PROMISE, ignore it"); + rv = CURL_PUSH_DENY; + } +fail: + return rv; +} + +static void h2_xfer_write_resp_hd(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h2_stream_ctx *stream, + const char *buf, size_t blen, bool eos) +{ + /* If we already encountered an error, skip further writes */ + if(!stream->xfer_result) { + stream->xfer_result = Curl_xfer_write_resp_hd(data, buf, blen, eos); + if(!stream->xfer_result && !eos) + stream->xfer_result = cf_h2_update_local_win(cf, data, stream); + if(stream->xfer_result) + CURL_TRC_CF(data, cf, "[%d] error %d writing %zu bytes of headers", + stream->id, (int)stream->xfer_result, blen); + } +} + +static void h2_xfer_write_resp(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h2_stream_ctx *stream, + const char *buf, size_t blen, bool eos) +{ + /* If we already encountered an error, skip further writes */ + if(!stream->xfer_result) + stream->xfer_result = Curl_xfer_write_resp(data, buf, blen, eos); + /* If the transfer write is errored, we do not want any more data */ + if(stream->xfer_result) { + struct cf_h2_ctx *ctx = cf->ctx; + CURL_TRC_CF(data, cf, "[%d] error %d writing %zu bytes of data, " + "RST-ing stream", + stream->id, (int)stream->xfer_result, blen); + nghttp2_submit_rst_stream(ctx->h2, 0, stream->id, + (uint32_t)NGHTTP2_ERR_CALLBACK_FAILURE); + } + else if(!stream->write_paused && Curl_xfer_write_is_paused(data)) { + CURL_TRC_CF(data, cf, "[%d] stream output paused", stream->id); + stream->write_paused = TRUE; + } + else if(stream->write_paused && !Curl_xfer_write_is_paused(data)) { + CURL_TRC_CF(data, cf, "[%d] stream output unpaused", stream->id); + stream->write_paused = FALSE; + } + + if(!stream->xfer_result && !eos) + stream->xfer_result = cf_h2_update_local_win(cf, data, stream); +} + +static CURLcode on_stream_frame(struct Curl_cfilter *cf, + struct Curl_easy *data, + const nghttp2_frame *frame) +{ + struct cf_h2_ctx *ctx = cf->ctx; + struct h2_stream_ctx *stream = H2_STREAM_CTX(ctx, data); + int32_t stream_id = frame->hd.stream_id; + int rv; + + if(!stream) { + CURL_TRC_CF(data, cf, "[%d] No stream_ctx set", stream_id); + return CURLE_FAILED_INIT; + } + + switch(frame->hd.type) { + case NGHTTP2_DATA: + CURL_TRC_CF(data, cf, "[%d] DATA, window=%d/%d", + stream_id, + nghttp2_session_get_stream_effective_recv_data_length( + ctx->h2, stream->id), + nghttp2_session_get_stream_effective_local_window_size( + ctx->h2, stream->id)); + /* If !body started on this stream, then receiving DATA is illegal. */ + if(!stream->bodystarted) { + rv = nghttp2_submit_rst_stream(ctx->h2, NGHTTP2_FLAG_NONE, + stream_id, NGHTTP2_PROTOCOL_ERROR); + + if(nghttp2_is_fatal(rv)) { + return CURLE_RECV_ERROR; + } + } + break; + case NGHTTP2_HEADERS: + if(stream->bodystarted) { + /* Only valid HEADERS after body started is trailer HEADERS. We + buffer them in on_header callback. */ + break; + } + + /* nghttp2 guarantees that :status is received, and we store it to + stream->status_code. Fuzzing has proven this can still be reached + without status code having been set. */ + if(stream->status_code == -1) + return CURLE_RECV_ERROR; + + /* Only final status code signals the end of header */ + if(stream->status_code / 100 != 1) + stream->bodystarted = TRUE; + else + stream->status_code = -1; + + h2_xfer_write_resp_hd(cf, data, stream, STRCONST("\r\n"), + (bool)stream->closed); + + if(stream->status_code / 100 != 1) { + stream->resp_hds_complete = TRUE; + } + Curl_multi_mark_dirty(data); + break; + case NGHTTP2_PUSH_PROMISE: + rv = push_promise(cf, data, &frame->push_promise); + if(rv) { /* deny! */ + DEBUGASSERT((rv > CURL_PUSH_OK) && (rv <= CURL_PUSH_ERROROUT)); + rv = nghttp2_submit_rst_stream(ctx->h2, NGHTTP2_FLAG_NONE, + frame->push_promise.promised_stream_id, + NGHTTP2_CANCEL); + if(nghttp2_is_fatal(rv)) + return CURLE_SEND_ERROR; + else if(rv == CURL_PUSH_ERROROUT) { + CURL_TRC_CF(data, cf, "[%d] fail in PUSH_PROMISE received", + stream_id); + return CURLE_RECV_ERROR; + } + } + break; + case NGHTTP2_RST_STREAM: + if(frame->rst_stream.error_code) + stream->reset_by_server = TRUE; + Curl_multi_mark_dirty(data); + break; + case NGHTTP2_WINDOW_UPDATE: + if(CURL_REQ_WANT_SEND(data) && Curl_bufq_is_empty(&stream->sendbuf)) { + /* need more data, force processing of transfer */ + Curl_multi_mark_dirty(data); + } + else if(!Curl_bufq_is_empty(&stream->sendbuf)) { + /* resume the potentially suspended stream */ + rv = nghttp2_session_resume_data(ctx->h2, stream->id); + if(nghttp2_is_fatal(rv)) + return CURLE_SEND_ERROR; + } + break; + default: + break; + } + + if(frame->hd.flags & NGHTTP2_FLAG_END_STREAM) { + if(!stream->closed && !stream->body_eos && + ((stream->status_code >= 400) || (stream->status_code < 200))) { + /* The server did not give us a positive response and we are not + * done uploading the request body. We need to stop doing that and + * also inform the server that we aborted our side. */ + CURL_TRC_CF(data, cf, "[%d] EOS frame with unfinished upload and " + "HTTP status %d, abort upload by RST", + stream_id, stream->status_code); + nghttp2_submit_rst_stream(ctx->h2, NGHTTP2_FLAG_NONE, + stream->id, NGHTTP2_STREAM_CLOSED); + stream->closed = TRUE; + } + Curl_multi_mark_dirty(data); + } + return CURLE_OK; +} + +#ifdef CURLVERBOSE +int Curl_nghttp2_fr_print(const nghttp2_frame *frame, char *buffer, + size_t blen) +{ + switch(frame->hd.type) { + case NGHTTP2_DATA: { + return curl_msnprintf(buffer, blen, + "FRAME[DATA, len=%d, eos=%d, padlen=%d]", + (int)frame->hd.length, + !!(frame->hd.flags & NGHTTP2_FLAG_END_STREAM), + (int)frame->data.padlen); + } + case NGHTTP2_HEADERS: { + return curl_msnprintf(buffer, blen, + "FRAME[HEADERS, len=%d, hend=%d, eos=%d]", + (int)frame->hd.length, + !!(frame->hd.flags & NGHTTP2_FLAG_END_HEADERS), + !!(frame->hd.flags & NGHTTP2_FLAG_END_STREAM)); + } + case NGHTTP2_PRIORITY: { + return curl_msnprintf(buffer, blen, + "FRAME[PRIORITY, len=%d, flags=%d]", + (int)frame->hd.length, frame->hd.flags); + } + case NGHTTP2_RST_STREAM: { + return curl_msnprintf(buffer, blen, + "FRAME[RST_STREAM, len=%d, flags=%d, error=%u]", + (int)frame->hd.length, frame->hd.flags, + frame->rst_stream.error_code); + } + case NGHTTP2_SETTINGS: { + if(frame->hd.flags & NGHTTP2_FLAG_ACK) { + return curl_msnprintf(buffer, blen, "FRAME[SETTINGS, ack=1]"); + } + return curl_msnprintf(buffer, blen, + "FRAME[SETTINGS, len=%d]", (int)frame->hd.length); + } + case NGHTTP2_PUSH_PROMISE: + return curl_msnprintf(buffer, blen, + "FRAME[PUSH_PROMISE, len=%d, hend=%d]", + (int)frame->hd.length, + !!(frame->hd.flags & NGHTTP2_FLAG_END_HEADERS)); + case NGHTTP2_PING: + return curl_msnprintf(buffer, blen, + "FRAME[PING, len=%d, ack=%d]", + (int)frame->hd.length, + frame->hd.flags & NGHTTP2_FLAG_ACK); + case NGHTTP2_GOAWAY: { + char scratch[128]; + size_t s_len = CURL_ARRAYSIZE(scratch); + size_t len = (frame->goaway.opaque_data_len < s_len) ? + frame->goaway.opaque_data_len : s_len - 1; + if(len) + memcpy(scratch, frame->goaway.opaque_data, len); + scratch[len] = '\0'; + return curl_msnprintf(buffer, blen, + "FRAME[GOAWAY, error=%u, reason='%s', " + "last_stream=%d]", frame->goaway.error_code, + scratch, frame->goaway.last_stream_id); + } + case NGHTTP2_WINDOW_UPDATE: { + return curl_msnprintf(buffer, blen, + "FRAME[WINDOW_UPDATE, incr=%d]", + frame->window_update.window_size_increment); + } + default: + return curl_msnprintf(buffer, blen, "FRAME[%d, len=%d, flags=%d]", + frame->hd.type, (int)frame->hd.length, + frame->hd.flags); + } +} + +static int on_frame_send(nghttp2_session *session, const nghttp2_frame *frame, + void *userp) +{ + struct Curl_cfilter *cf = userp; + struct cf_h2_ctx *ctx = cf->ctx; + struct Curl_easy *data = CF_DATA_CURRENT(cf); + + (void)session; + DEBUGASSERT(data); + if(Curl_trc_cf_is_verbose(cf, data)) { + char buffer[256]; + int len; + len = Curl_nghttp2_fr_print(frame, buffer, sizeof(buffer) - 1); + buffer[len] = 0; + CURL_TRC_CF(data, cf, "[%d] -> %s", frame->hd.stream_id, buffer); + } + if((frame->hd.type == NGHTTP2_GOAWAY) && !ctx->sent_goaway) { + /* A GOAWAY not initiated by us, but by nghttp2 itself on detecting + * a protocol error on the connection */ + failf(data, "nghttp2 shuts down connection with error %u: %s", + frame->goaway.error_code, + nghttp2_http2_strerror(frame->goaway.error_code)); + } + return 0; +} +#endif /* CURLVERBOSE */ + +static int on_frame_recv(nghttp2_session *session, const nghttp2_frame *frame, + void *userp) +{ + struct Curl_cfilter *cf = userp; + struct cf_h2_ctx *ctx = cf->ctx; + struct Curl_easy *data = CF_DATA_CURRENT(cf), *data_s; + int32_t stream_id = frame->hd.stream_id; + + DEBUGASSERT(data); +#ifdef CURLVERBOSE + if(Curl_trc_cf_is_verbose(cf, data)) { + char buffer[256]; + int len; + len = Curl_nghttp2_fr_print(frame, buffer, sizeof(buffer) - 1); + buffer[len] = 0; + CURL_TRC_CF(data, cf, "[%d] <- %s", frame->hd.stream_id, buffer); + } +#endif /* CURLVERBOSE */ + + if(!stream_id) { + /* stream ID zero is for connection-oriented stuff */ + DEBUGASSERT(data); + switch(frame->hd.type) { + case NGHTTP2_SETTINGS: { + if(!(frame->hd.flags & NGHTTP2_FLAG_ACK)) { + uint32_t max_conn = ctx->max_concurrent_streams; + ctx->max_concurrent_streams = nghttp2_session_get_remote_settings( + session, NGHTTP2_SETTINGS_MAX_CONCURRENT_STREAMS); + ctx->enable_push = nghttp2_session_get_remote_settings( + session, NGHTTP2_SETTINGS_ENABLE_PUSH) != 0; + CURL_TRC_CF(data, cf, "[0] MAX_CONCURRENT_STREAMS: %u", + ctx->max_concurrent_streams); + CURL_TRC_CF(data, cf, "[0] ENABLE_PUSH: %s", + ctx->enable_push ? "TRUE" : "false"); + if(data && max_conn != ctx->max_concurrent_streams) { + /* only signal change if the value actually changed */ + CURL_TRC_CF(data, cf, "[0] notify MAX_CONCURRENT_STREAMS: %u", + ctx->max_concurrent_streams); + Curl_multi_connchanged(data->multi); + } + /* Since the initial stream window is 64K, a request might be on HOLD, + * due to exhaustion. The (initial) SETTINGS may announce a much larger + * window and *assume* that we treat this like a WINDOW_UPDATE. Some + * servers send an explicit WINDOW_UPDATE, but not all seem to do that. + * To be safe, we UNHOLD a stream in order not to stall. */ + if(CURL_REQ_WANT_SEND(data)) + Curl_multi_mark_dirty(data); + } + break; + } + case NGHTTP2_GOAWAY: + ctx->rcvd_goaway = TRUE; + ctx->goaway_error = frame->goaway.error_code; + ctx->remote_max_sid = frame->goaway.last_stream_id; + if(data) { + infof(data, "received GOAWAY, error=%u, last_stream=%d", + ctx->goaway_error, ctx->remote_max_sid); + Curl_multi_connchanged(data->multi); + } + break; + default: + break; + } + return 0; + } + + data_s = nghttp2_session_get_stream_user_data(session, stream_id); + if(!data_s) { + CURL_TRC_CF(data, cf, "[%d] No Curl_easy associated", stream_id); + return 0; + } + + return on_stream_frame(cf, data_s, frame) ? NGHTTP2_ERR_CALLBACK_FAILURE : 0; +} + +static int cf_h2_on_invalid_frame_recv(nghttp2_session *session, + const nghttp2_frame *frame, + int ngerr, void *userp) +{ + struct Curl_cfilter *cf = userp; + struct cf_h2_ctx *ctx = cf->ctx; + struct Curl_easy *data; + int32_t stream_id = frame->hd.stream_id; + + data = nghttp2_session_get_stream_user_data(session, stream_id); + if(data) { + struct h2_stream_ctx *stream; +#ifdef CURLVERBOSE + char buffer[256]; + int len; + len = Curl_nghttp2_fr_print(frame, buffer, sizeof(buffer) - 1); + buffer[len] = 0; + failf(data, "[HTTP2] [%d] received invalid frame: %s, error %d: %s", + stream_id, buffer, ngerr, nghttp2_strerror(ngerr)); +#endif /* CURLVERBOSE */ + stream = H2_STREAM_CTX(ctx, data); + if(stream) { + nghttp2_submit_rst_stream(ctx->h2, NGHTTP2_FLAG_NONE, + stream->id, NGHTTP2_STREAM_CLOSED); + stream->error = ngerr; + stream->closed = TRUE; + stream->reset = TRUE; + return 0; /* keep the connection alive */ + } + } + return NGHTTP2_ERR_CALLBACK_FAILURE; +} + +static int on_data_chunk_recv(nghttp2_session *session, uint8_t flags, + int32_t stream_id, + const uint8_t *mem, size_t len, void *userp) +{ + struct Curl_cfilter *cf = userp; + struct cf_h2_ctx *ctx = cf->ctx; + struct h2_stream_ctx *stream; + struct Curl_easy *data_s; + (void)flags; + + DEBUGASSERT(stream_id); /* should never be a zero stream ID here */ + DEBUGASSERT(CF_DATA_CURRENT(cf)); + + /* get the stream from the hash based on Stream ID */ + data_s = nghttp2_session_get_stream_user_data(session, stream_id); + if(!data_s) { + /* Receiving a Stream ID not in the hash should not happen - unless + we have aborted a transfer artificially and there were more data + in the pipeline. Silently ignore. */ + CURL_TRC_CF(CF_DATA_CURRENT(cf), cf, "[%d] Data for unknown", stream_id); + /* consumed explicitly as no one will read it */ + nghttp2_session_consume(session, stream_id, len); + return 0; + } + + stream = H2_STREAM_CTX(ctx, data_s); + if(!stream) + return NGHTTP2_ERR_CALLBACK_FAILURE; + + h2_xfer_write_resp(cf, data_s, stream, (const char *)mem, len, FALSE); + + nghttp2_session_consume(ctx->h2, stream_id, len); + stream->nrcvd_data += (curl_off_t)len; + return 0; +} + +static int on_stream_close(nghttp2_session *session, int32_t stream_id, + uint32_t error_code, void *userp) +{ + struct Curl_cfilter *cf = userp; + struct cf_h2_ctx *ctx = cf->ctx; + struct Curl_easy *data_s, *call_data = CF_DATA_CURRENT(cf); + struct h2_stream_ctx *stream; + int rv; + (void)session; + + DEBUGASSERT(call_data); + /* stream id 0 is the connection, do not look there for streams. */ + data_s = stream_id ? + nghttp2_session_get_stream_user_data(session, stream_id) : NULL; + if(!data_s) { + CURL_TRC_CF(call_data, cf, + "[%d] on_stream_close, no easy set on stream", stream_id); + return 0; + } + if(!GOOD_EASY_HANDLE(data_s)) { + /* nghttp2 still has an easy registered for the stream which has + * been freed be libcurl. This points to a code path that does not + * trigger DONE or DETACH events as it must. */ + CURL_TRC_CF(call_data, cf, + "[%d] on_stream_close, not a GOOD easy on stream", stream_id); + (void)nghttp2_session_set_stream_user_data(session, stream_id, 0); + return NGHTTP2_ERR_CALLBACK_FAILURE; + } + stream = H2_STREAM_CTX(ctx, data_s); + if(!stream) { + CURL_TRC_CF(data_s, cf, + "[%d] on_stream_close, GOOD easy but no stream", stream_id); + return NGHTTP2_ERR_CALLBACK_FAILURE; + } + + stream->closed = TRUE; + stream->error = error_code; + if(stream->error) + stream->reset = TRUE; + + if(stream->error) + CURL_TRC_CF(data_s, cf, "[%d] RESET: %s (err %u)", + stream_id, nghttp2_http2_strerror(error_code), error_code); + else + CURL_TRC_CF(data_s, cf, "[%d] CLOSED", stream_id); + Curl_multi_mark_dirty(data_s); + + /* remove `data_s` from the nghttp2 stream */ + rv = nghttp2_session_set_stream_user_data(session, stream_id, 0); + if(rv) { + infof(data_s, "http/2: failed to clear user_data for stream %d", + stream_id); + DEBUGASSERT(0); + } + return 0; +} + +static int on_begin_headers(nghttp2_session *session, + const nghttp2_frame *frame, void *userp) +{ + struct Curl_cfilter *cf = userp; + struct cf_h2_ctx *ctx = cf->ctx; + struct h2_stream_ctx *stream; + struct Curl_easy *data_s = NULL; + + (void)cf; + data_s = nghttp2_session_get_stream_user_data(session, frame->hd.stream_id); + if(!data_s) { + return 0; + } + + if(frame->hd.type != NGHTTP2_HEADERS) { + return 0; + } + + stream = H2_STREAM_CTX(ctx, data_s); + if(!stream || !stream->bodystarted) { + return 0; + } + + return 0; +} + +static void cf_h2_header_error(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h2_stream_ctx *stream, + CURLcode result) +{ + struct cf_h2_ctx *ctx = cf->ctx; + + failf(data, "Error receiving HTTP2 header: %d(%s)", (int)result, + curl_easy_strerror(result)); + if(stream) { + nghttp2_submit_rst_stream(ctx->h2, NGHTTP2_FLAG_NONE, + stream->id, NGHTTP2_STREAM_CLOSED); + stream->closed = TRUE; + stream->reset = TRUE; + } +} + +/* frame->hd.type is either NGHTTP2_HEADERS or NGHTTP2_PUSH_PROMISE */ +static int on_header(nghttp2_session *session, const nghttp2_frame *frame, + const uint8_t *name, size_t namelen, + const uint8_t *value, size_t valuelen, + uint8_t flags, + void *userp) +{ + struct Curl_cfilter *cf = userp; + struct cf_h2_ctx *ctx = cf->ctx; + struct h2_stream_ctx *stream; + struct Curl_easy *data; + int32_t stream_id = frame->hd.stream_id; + CURLcode result; + (void)flags; + + DEBUGASSERT(stream_id); /* should never be a zero stream ID here */ + + /* get the stream from the hash based on Stream ID */ + data = nghttp2_session_get_stream_user_data(session, stream_id); + if(!GOOD_EASY_HANDLE(data)) + /* Receiving a Stream ID not in the hash should not happen, this is an + internal error more than anything else! */ + return NGHTTP2_ERR_CALLBACK_FAILURE; + + stream = H2_STREAM_CTX(ctx, data); + if(!stream) { + failf(data, "Internal NULL stream"); + return NGHTTP2_ERR_CALLBACK_FAILURE; + } + + /* Store received PUSH_PROMISE headers to be used when the subsequent + PUSH_PROMISE callback comes */ + if(frame->hd.type == NGHTTP2_PUSH_PROMISE) { + char *h; + + if((namelen == (sizeof(HTTP_PSEUDO_AUTHORITY) - 1)) && + !strncmp(HTTP_PSEUDO_AUTHORITY, (const char *)name, namelen)) { + /* pseudo headers are lower case */ + int rc = 0; + char *check = curl_maprintf("%s:%d", data->state.origin->hostname, + data->state.origin->port); + if(!check) + /* no memory */ + return NGHTTP2_ERR_CALLBACK_FAILURE; + if(!curl_strequal(check, (const char *)value) && + ((data->state.origin->port != cf->conn->given->defport) || + !curl_strequal(data->state.origin->hostname, (const char *)value))) { + /* This is push is not for the same authority that was asked for in + * the URL. RFC 7540 section 8.2 says: "A client MUST treat a + * PUSH_PROMISE for which the server is not authoritative as a stream + * error of type PROTOCOL_ERROR." + */ + (void)nghttp2_submit_rst_stream(session, NGHTTP2_FLAG_NONE, + stream_id, NGHTTP2_PROTOCOL_ERROR); + rc = NGHTTP2_ERR_CALLBACK_FAILURE; + } + curlx_free(check); + if(rc) + return rc; + } + + if(!stream->push_headers) { + stream->push_headers_alloc = 10; + stream->push_headers = curlx_malloc(stream->push_headers_alloc * + sizeof(char *)); + if(!stream->push_headers) + return NGHTTP2_ERR_CALLBACK_FAILURE; + stream->push_headers_used = 0; + } + else if(stream->push_headers_used == + stream->push_headers_alloc) { + char **headp; + if(stream->push_headers_alloc > 1000) { + /* this is beyond crazy many headers, bail out */ + failf(data, "Too many PUSH_PROMISE headers"); + free_push_headers(stream); + return NGHTTP2_ERR_CALLBACK_FAILURE; + } + stream->push_headers_alloc *= 2; + headp = curlx_realloc(stream->push_headers, + stream->push_headers_alloc * sizeof(char *)); + if(!headp) { + free_push_headers(stream); + return NGHTTP2_ERR_CALLBACK_FAILURE; + } + stream->push_headers = headp; + } + h = curl_maprintf("%s:%s", name, value); + if(!h) { + free_push_headers(stream); + return NGHTTP2_ERR_CALLBACK_FAILURE; + } + stream->push_headers[stream->push_headers_used++] = h; + return 0; + } + + if(stream->bodystarted) { + /* This is a trailer */ + CURL_TRC_CF(data, cf, "[%d] trailer: %.*s: %.*s", + stream->id, (int)namelen, name, (int)valuelen, value); + result = Curl_dynhds_add(&stream->resp_trailers, + (const char *)name, namelen, + (const char *)value, valuelen); + if(result) { + cf_h2_header_error(cf, data, stream, result); + return NGHTTP2_ERR_CALLBACK_FAILURE; + } + + return 0; + } + + if(namelen == sizeof(HTTP_PSEUDO_STATUS) - 1 && + !memcmp(HTTP_PSEUDO_STATUS, name, namelen)) { + /* nghttp2 guarantees :status is received first and only once. */ + char buffer[32]; + size_t hlen; + result = Curl_http_decode_status(&stream->status_code, + (const char *)value, valuelen); + if(result) { + cf_h2_header_error(cf, data, stream, result); + return NGHTTP2_ERR_CALLBACK_FAILURE; + } + hlen = curl_msnprintf(buffer, sizeof(buffer), HTTP_PSEUDO_STATUS ":%d\r", + stream->status_code); + result = Curl_headers_push(data, buffer, hlen, CURLH_PSEUDO); + if(result) { + cf_h2_header_error(cf, data, stream, result); + return NGHTTP2_ERR_CALLBACK_FAILURE; + } + curlx_dyn_reset(&ctx->scratch); + result = curlx_dyn_addn(&ctx->scratch, STRCONST("HTTP/2 ")); + if(!result) + result = curlx_dyn_addn(&ctx->scratch, value, valuelen); + if(!result) + result = curlx_dyn_addn(&ctx->scratch, STRCONST(" \r\n")); + if(!result) + h2_xfer_write_resp_hd(cf, data, stream, curlx_dyn_ptr(&ctx->scratch), + curlx_dyn_len(&ctx->scratch), FALSE); + if(result) { + cf_h2_header_error(cf, data, stream, result); + return NGHTTP2_ERR_CALLBACK_FAILURE; + } + /* if we receive data for another handle, wake that up */ + if(CF_DATA_CURRENT(cf) != data) + Curl_multi_mark_dirty(data); + + CURL_TRC_CF(data, cf, "[%d] status: HTTP/2 %03d", + stream->id, stream->status_code); + return 0; + } + + /* nghttp2 guarantees that namelen > 0, and :status was already + received, and this is not pseudo-header field . */ + /* convert to an HTTP1-style header */ + curlx_dyn_reset(&ctx->scratch); + result = curlx_dyn_addn(&ctx->scratch, (const char *)name, namelen); + if(!result) + result = curlx_dyn_addn(&ctx->scratch, STRCONST(": ")); + if(!result) + result = curlx_dyn_addn(&ctx->scratch, (const char *)value, valuelen); + if(!result) + result = curlx_dyn_addn(&ctx->scratch, STRCONST("\r\n")); + if(!result) + h2_xfer_write_resp_hd(cf, data, stream, curlx_dyn_ptr(&ctx->scratch), + curlx_dyn_len(&ctx->scratch), FALSE); + if(result) { + cf_h2_header_error(cf, data, stream, result); + return NGHTTP2_ERR_CALLBACK_FAILURE; + } + /* if we receive data for another handle, wake that up */ + if(CF_DATA_CURRENT(cf) != data) + Curl_multi_mark_dirty(data); + + CURL_TRC_CF(data, cf, "[%d] header: %.*s: %.*s", + stream->id, (int)namelen, name, (int)valuelen, value); + + return 0; /* 0 is successful */ +} + +static ssize_t req_body_read_callback(nghttp2_session *session, + int32_t stream_id, + uint8_t *buf, size_t length, + uint32_t *data_flags, + nghttp2_data_source *source, + void *userp) +{ + struct Curl_cfilter *cf = userp; + struct cf_h2_ctx *ctx = cf->ctx; + struct Curl_easy *data_s; + struct h2_stream_ctx *stream = NULL; + CURLcode result; + ssize_t nread; + size_t n; + (void)source; + + (void)cf; + if(!stream_id) + return NGHTTP2_ERR_INVALID_ARGUMENT; + + /* get the stream from the hash based on Stream ID, stream ID zero is for + connection-oriented stuff */ + data_s = nghttp2_session_get_stream_user_data(session, stream_id); + if(!data_s) + /* Receiving a Stream ID not in the hash should not happen, this is an + internal error more than anything else! */ + return NGHTTP2_ERR_CALLBACK_FAILURE; + + stream = H2_STREAM_CTX(ctx, data_s); + if(!stream) + return NGHTTP2_ERR_CALLBACK_FAILURE; + + result = Curl_bufq_read(&stream->sendbuf, buf, length, &n); + if(result) { + if(result != CURLE_AGAIN) + return NGHTTP2_ERR_CALLBACK_FAILURE; + nread = 0; + } + else + nread = (ssize_t)n; + + CURL_TRC_CF(data_s, cf, "[%d] req_body_read(len=%zu) eos=%d -> %zd, %d", + stream_id, length, stream->body_eos, nread, (int)result); + + if(stream->body_eos && Curl_bufq_is_empty(&stream->sendbuf)) { + *data_flags = NGHTTP2_DATA_FLAG_EOF; + return nread; + } + return (nread == 0) ? NGHTTP2_ERR_DEFERRED : nread; +} + +#ifdef CURLVERBOSE +static int error_callback(nghttp2_session *session, + const char *msg, + size_t len, + void *userp) +{ + struct Curl_cfilter *cf = userp; + struct Curl_easy *data = CF_DATA_CURRENT(cf); + (void)session; + failf(data, "%.*s", (int)len, msg); + return 0; +} +#endif + +/* + * Append headers to ask for an HTTP1.1 to HTTP2 upgrade. + */ +CURLcode Curl_http2_request_upgrade(struct dynbuf *req, + struct Curl_easy *data) +{ + CURLcode result; + char *base64; + size_t blen; + struct SingleRequest *k = &data->req; + uint8_t binsettings[H2_BINSETTINGS_LEN]; + ssize_t rc; + size_t binlen; /* length of the binsettings data */ + + rc = populate_binsettings(binsettings, data); + if(!curlx_sztouz(rc, &binlen) || !binlen) { + failf(data, "nghttp2 unexpectedly failed on pack_settings_payload"); + curlx_dyn_free(req); + return CURLE_FAILED_INIT; + } + + result = curlx_base64url_encode(binsettings, binlen, &base64, &blen); + if(result) { + curlx_dyn_free(req); + return result; + } + + data->state.http_hd_upgrade = TRUE; + data->state.http_hd_h2_settings = TRUE; + result = curlx_dyn_addf(req, + "Upgrade: %s\r\n" + "HTTP2-Settings: %s\r\n", + NGHTTP2_CLEARTEXT_PROTO_VERSION_ID, base64); + curlx_free(base64); + + k->upgr101 = UPGR101_H2; + data->conn->bits.upgrade_in_progress = TRUE; + + return result; +} + +static CURLcode http2_handle_stream_close(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h2_stream_ctx *stream, + size_t *pnlen) +{ + CURLcode result; + + *pnlen = 0; + if(stream->reset) { + if(stream->error == NGHTTP2_REFUSED_STREAM) { + infof(data, "HTTP/2 stream %d refused by server, try again on a new " + "connection", stream->id); + connclose(cf->conn, "REFUSED_STREAM"); /* do not use this anymore */ + data->state.refused_stream = TRUE; + return CURLE_RECV_ERROR; /* trigger Curl_retry_request() later */ + } + else if(stream->resp_hds_complete && data->req.no_body) { + CURL_TRC_CF(data, cf, "[%d] error after response headers, but we did " + "not want a body anyway, ignore: %s (err %u)", + stream->id, nghttp2_http2_strerror(stream->error), + stream->error); + stream->close_handled = TRUE; + return CURLE_OK; + } + failf(data, "HTTP/2 stream %d reset by %s (error 0x%x %s)", + stream->id, stream->reset_by_server ? "server" : "curl", + stream->error, nghttp2_http2_strerror(stream->error)); + return stream->error ? CURLE_HTTP2_STREAM : + (data->req.bytecount ? CURLE_PARTIAL_FILE : CURLE_HTTP2); + } + else if(!stream->bodystarted) { + failf(data, "HTTP/2 stream %d was closed cleanly, but before getting " + "all response header fields, treated as error", stream->id); + return CURLE_HTTP2_STREAM; + } + + if(Curl_dynhds_count(&stream->resp_trailers)) { + struct dynhds_entry *e; + struct dynbuf dbuf; + size_t i; + + result = CURLE_OK; + curlx_dyn_init(&dbuf, DYN_TRAILERS); + for(i = 0; i < Curl_dynhds_count(&stream->resp_trailers); ++i) { + e = Curl_dynhds_getn(&stream->resp_trailers, i); + if(!e) + break; + curlx_dyn_reset(&dbuf); + result = curlx_dyn_addf(&dbuf, "%.*s: %.*s\x0d\x0a", + (int)e->namelen, e->name, + (int)e->valuelen, e->value); + if(result) + break; + Curl_debug(data, CURLINFO_HEADER_IN, curlx_dyn_ptr(&dbuf), + curlx_dyn_len(&dbuf)); + result = Curl_client_write(data, + CLIENTWRITE_HEADER | CLIENTWRITE_TRAILER, + curlx_dyn_ptr(&dbuf), curlx_dyn_len(&dbuf)); + if(result) + break; + } + curlx_dyn_free(&dbuf); + if(result) + goto out; + } + + stream->close_handled = TRUE; + result = CURLE_OK; + +out: + CURL_TRC_CF(data, cf, "handle_stream_close -> %d, %zu", (int)result, *pnlen); + return result; +} + +static int sweight_wanted(const struct Curl_easy *data) +{ + /* 0 weight is not set by user and we take the nghttp2 default one */ + return data->set.priority.weight ? + data->set.priority.weight : NGHTTP2_DEFAULT_WEIGHT; +} + +static int sweight_in_effect(const struct Curl_easy *data) +{ + /* 0 weight is not set by user and we take the nghttp2 default one */ + return data->state.priority.weight ? + data->state.priority.weight : NGHTTP2_DEFAULT_WEIGHT; +} + +/* + * h2_pri_spec() fills in the pri_spec struct, used by nghttp2 to send weight + * and dependency to the peer. It also stores the updated values in the state + * struct. + */ + +static void h2_pri_spec(struct Curl_easy *data, + nghttp2_priority_spec *pri_spec) +{ + struct Curl_data_priority *prio = &data->set.priority; + nghttp2_priority_spec_init(pri_spec, 0, + sweight_wanted(data), FALSE); + data->state.priority = *prio; +} + +/* + * Check if there is been an update in the priority / + * dependency settings and if so it submits a PRIORITY frame with the updated + * info. + * Flush any out data pending in the network buffer. + */ +static CURLcode h2_progress_egress(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_h2_ctx *ctx = cf->ctx; + struct h2_stream_ctx *stream = H2_STREAM_CTX(ctx, data); + int rv = 0; + + if(stream && stream->id > 0 && + (sweight_wanted(data) != sweight_in_effect(data))) { + /* send new weight and/or dependency */ + nghttp2_priority_spec pri_spec; + + h2_pri_spec(data, &pri_spec); + CURL_TRC_CF(data, cf, "[%d] Queuing PRIORITY", stream->id); + DEBUGASSERT(stream->id != -1); + rv = nghttp2_submit_priority(ctx->h2, NGHTTP2_FLAG_NONE, + stream->id, &pri_spec); + if(rv) + goto out; + } + + ctx->nw_out_blocked = 0; + while(!rv && !ctx->nw_out_blocked && nghttp2_session_want_write(ctx->h2)) + rv = nghttp2_session_send(ctx->h2); + +out: + if(nghttp2_is_fatal(rv)) { + CURL_TRC_CF(data, cf, "nghttp2_session_send error (%s)%d", + nghttp2_strerror(rv), rv); + return CURLE_SEND_ERROR; + } + /* Defer flushing during the connect phase so that the SETTINGS and + * other initial frames are sent together with the first request. + * Unless we are 'connect_only' where the request will never come. */ + if(!cf->connected && !cf->conn->bits.connect_only) + return CURLE_OK; + return nw_out_flush(cf, data); +} + +static CURLcode stream_recv(struct Curl_cfilter *cf, struct Curl_easy *data, + struct h2_stream_ctx *stream, + char *buf, size_t len, size_t *pnread) +{ + struct cf_h2_ctx *ctx = cf->ctx; + CURLcode result = CURLE_AGAIN; + + (void)buf; + (void)len; + *pnread = 0; + + if(!stream->xfer_result) + stream->xfer_result = cf_h2_update_local_win(cf, data, stream); + + if(stream->xfer_result) { + CURL_TRC_CF(data, cf, "[%d] xfer write failed", stream->id); + result = stream->xfer_result; + } + else if(stream->closed) { + CURL_TRC_CF(data, cf, "[%d] returning CLOSE", stream->id); + result = http2_handle_stream_close(cf, data, stream, pnread); + } + else if(stream->reset || + (ctx->conn_closed && Curl_bufq_is_empty(&ctx->inbufq)) || + (ctx->rcvd_goaway && ctx->remote_max_sid < stream->id)) { + CURL_TRC_CF(data, cf, "[%d] returning ERR", stream->id); + result = data->req.bytecount ? CURLE_PARTIAL_FILE : CURLE_HTTP2; + } + + if(result && (result != CURLE_AGAIN)) + CURL_TRC_CF(data, cf, "[%d] stream_recv(len=%zu) -> %d, %zu", + stream->id, len, (int)result, *pnread); + return result; +} + +static CURLcode h2_progress_ingress(struct Curl_cfilter *cf, + struct Curl_easy *data, + size_t data_max_bytes) +{ + struct cf_h2_ctx *ctx = cf->ctx; + struct h2_stream_ctx *stream; + CURLcode result = CURLE_OK; + size_t nread; + + if(should_close_session(ctx)) { + CURL_TRC_CF(data, cf, "[0] ingress: session is closed"); + return CURLE_HTTP2; + } + + /* Process network input buffer first */ + if(!Curl_bufq_is_empty(&ctx->inbufq)) { + CURL_TRC_CF(data, cf, "Process %zu bytes in connection buffer", + Curl_bufq_len(&ctx->inbufq)); + result = h2_process_pending_input(cf, data); + if(result) + return result; + } + + if(!data_max_bytes) + data_max_bytes = H2_CHUNK_SIZE; + + /* Receive data from the "lower" filters, e.g. network until + * it is time to stop due to connection close or us not processing + * all network input */ + while(!ctx->conn_closed && Curl_bufq_is_empty(&ctx->inbufq)) { + stream = H2_STREAM_CTX(ctx, data); + if(stream && (stream->closed || !data_max_bytes)) { + /* We would like to abort here and stop processing, so that the transfer + * loop can handle the data/close here. This may leave data in + * underlying buffers that will not be consumed. */ + if(!cf->next || !cf->next->cft->has_data_pending(cf->next, data)) + Curl_multi_mark_dirty(data); + break; + } + else if(!stream) { + DEBUGASSERT(0); + break; + } + + result = Curl_cf_recv_bufq(cf->next, data, &ctx->inbufq, 0, &nread); + if(result) { + if(result != CURLE_AGAIN) { + failf(data, "Failed receiving HTTP2 data: %d(%s)", (int)result, + curl_easy_strerror(result)); + return result; + } + break; + } + else if(nread == 0) { + CURL_TRC_CF(data, cf, "[0] ingress: connection closed"); + ctx->conn_closed = TRUE; + break; + } + else { + CURL_TRC_CF(data, cf, "[0] ingress: read %zu bytes", nread); + data_max_bytes = (data_max_bytes > nread) ? (data_max_bytes - nread) : 0; + } + + result = h2_process_pending_input(cf, data); + if(result) + return result; + CURL_TRC_CF(data, cf, "[0] ingress: nw-in buffered %zu", + Curl_bufq_len(&ctx->inbufq)); + } + + if(ctx->conn_closed && Curl_bufq_is_empty(&ctx->inbufq)) { + connclose(cf->conn, ctx->rcvd_goaway ? "server closed with GOAWAY" : + "server closed abruptly"); + } + + CURL_TRC_CF(data, cf, "[0] ingress: done"); + return CURLE_OK; +} + +static CURLcode cf_h2_recv(struct Curl_cfilter *cf, struct Curl_easy *data, + char *buf, size_t len, size_t *pnread) +{ + struct cf_h2_ctx *ctx = cf->ctx; + struct h2_stream_ctx *stream; + CURLcode result, r2; + struct cf_call_data save; + + if(!data) + return CURLE_HTTP2; + + stream = H2_STREAM_CTX(ctx, data); + + *pnread = 0; + if(!stream) { + /* Abnormal call sequence: either this transfer has never opened a stream + * (unlikely) or the transfer has been done, cleaned up its resources, but + * a read() is called anyway. It is not clear what the calling sequence + * is for such a case. */ + failf(data, "http/2 recv on a transfer never opened " + "or already cleared, mid=%u", data->mid); + return CURLE_HTTP2; + } + + CF_DATA_SAVE(save, cf, data); + + result = stream_recv(cf, data, stream, buf, len, pnread); + if(result && (result != CURLE_AGAIN)) + goto out; + + if(result) { + result = h2_progress_ingress(cf, data, len); + if(result) + goto out; + + result = stream_recv(cf, data, stream, buf, len, pnread); + } + + if(*pnread > 0) { + /* Now that we transferred this to the upper layer, we report + * the actual amount of DATA consumed to the H2 session, so + * that it adjusts stream flow control */ + nghttp2_session_consume(ctx->h2, stream->id, *pnread); + if(stream->closed) { + CURL_TRC_CF(data, cf, "[%d] DRAIN closed stream", stream->id); + Curl_multi_mark_dirty(data); + } + } + +out: + r2 = h2_progress_egress(cf, data); + if(r2 == CURLE_AGAIN) { + /* pending data to send, need to be called again. Ideally, we + * monitor the socket for POLLOUT, but when not SENDING + * any more, we force processing of the transfer. */ + if(!CURL_REQ_WANT_SEND(data)) + Curl_multi_mark_dirty(data); + } + else if(r2) { + result = r2; + } + CURL_TRC_CF(data, cf, "[%d] cf_recv(len=%zu) -> %d, %zu, " + "window=%d/%d, connection %d/%d", + stream->id, len, (int)result, *pnread, + nghttp2_session_get_stream_effective_recv_data_length( + ctx->h2, stream->id), + nghttp2_session_get_stream_effective_local_window_size( + ctx->h2, stream->id), + nghttp2_session_get_local_window_size(ctx->h2), + HTTP2_HUGE_WINDOW_SIZE); + + CF_DATA_RESTORE(cf, save); + return result; +} + +static CURLcode cf_h2_body_send(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h2_stream_ctx *stream, + const void *buf, size_t blen, bool eos, + size_t *pnwritten) +{ + struct cf_h2_ctx *ctx = cf->ctx; + CURLcode result; + + *pnwritten = 0; + if(stream->closed) { + if(stream->resp_hds_complete) { + /* Server decided to close the stream after having sent us a final + * response. This is valid if it is not interested in the request + * body. This happens on 30x or 40x responses. + * We silently discard the data sent, since this is not a transport + * error situation. */ + CURL_TRC_CF(data, cf, "[%d] discarding data" + "on closed stream with response", stream->id); + if(eos) + stream->body_eos = TRUE; + *pnwritten = blen; + return CURLE_OK; + } + /* Server closed before we got a response, this is an error */ + infof(data, "stream %d closed", stream->id); + return CURLE_SEND_ERROR; + } + + result = Curl_bufq_write(&stream->sendbuf, buf, blen, pnwritten); + if(result) + return result; + + if(eos && (blen == *pnwritten)) + stream->body_eos = TRUE; + + if(eos || !Curl_bufq_is_empty(&stream->sendbuf)) { + /* resume the potentially suspended stream */ + int rv = nghttp2_session_resume_data(ctx->h2, stream->id); + if(nghttp2_is_fatal(rv)) + return CURLE_SEND_ERROR; + } + + return CURLE_OK; +} + +static CURLcode h2_submit(struct h2_stream_ctx **pstream, + struct Curl_cfilter *cf, struct Curl_easy *data, + const uint8_t *buf, size_t len, + bool eos, size_t *pnwritten) +{ + struct cf_h2_ctx *ctx = cf->ctx; + struct h2_stream_ctx *stream = NULL; + struct dynhds h2_headers; + nghttp2_nv *nva = NULL; + const void *body = NULL; + size_t nheader, bodylen; + nghttp2_data_provider data_prd; + int32_t stream_id; + nghttp2_priority_spec pri_spec; + size_t nwritten; + CURLcode result = CURLE_OK; + uint32_t initial_win_size; + + *pnwritten = 0; + Curl_dynhds_init(&h2_headers, 0, DYN_HTTP_REQUEST); + + result = http2_data_setup(cf, data, &stream); + if(result) + goto out; + + result = Curl_h1_req_parse_read(&stream->h1, buf, len, NULL, + !data->state.http_ignorecustom ? + data->set.str[STRING_CUSTOMREQUEST] : NULL, + 0, &nwritten); + if(result) + goto out; + *pnwritten = nwritten; + if(!stream->h1.done) { + /* need more data */ + goto out; + } + DEBUGASSERT(stream->h1.req); + + result = Curl_http_req_to_h2(&h2_headers, stream->h1.req, data); + if(result) + goto out; + /* no longer needed */ + Curl_h1_req_parse_free(&stream->h1); + + nva = Curl_dynhds_to_nva(&h2_headers, &nheader); + if(!nva) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + h2_pri_spec(data, &pri_spec); + if(!nghttp2_session_check_request_allowed(ctx->h2)) + CURL_TRC_CF(data, cf, "send request NOT allowed (via nghttp2)"); + + /* Check the initial windows size of the transfer (rate-limits?) and + * send an updated settings on changes from previous value. */ + initial_win_size = cf_h2_initial_win_size(data); + if(initial_win_size != ctx->initial_win_size) { + result = cf_h2_update_settings(ctx, initial_win_size); + if(result) + goto out; + } + + switch(data->state.httpreq) { + case HTTPREQ_POST: + case HTTPREQ_POST_FORM: + case HTTPREQ_POST_MIME: + case HTTPREQ_PUT: + data_prd.read_callback = req_body_read_callback; + data_prd.source.ptr = NULL; + stream_id = nghttp2_submit_request(ctx->h2, &pri_spec, nva, nheader, + &data_prd, data); + break; + default: + stream_id = nghttp2_submit_request(ctx->h2, &pri_spec, nva, nheader, + NULL, data); + } + + if(stream_id < 0) { + CURL_TRC_CF(data, cf, "send: nghttp2_submit_request error (%s)%d", + nghttp2_strerror(stream_id), stream_id); + result = CURLE_SEND_ERROR; + goto out; + } + +#ifdef CURLVERBOSE +#define MAX_ACC 60000 /* <64KB to account for some overhead */ + if(Curl_trc_is_verbose(data)) { + size_t acc = 0, i; + + infof(data, "[HTTP/2] [%d] OPENED stream for %s", + stream_id, Curl_bufref_ptr(&data->state.url)); + for(i = 0; i < nheader; ++i) { + acc += nva[i].namelen + nva[i].valuelen; + + infof(data, "[HTTP/2] [%d] [%.*s: %.*s]", stream_id, + (int)nva[i].namelen, nva[i].name, + (int)nva[i].valuelen, nva[i].value); + } + + if(acc > MAX_ACC) { + infof(data, "[HTTP/2] Warning: The cumulative length of all " + "headers exceeds %d bytes and that could cause the " + "stream to be rejected.", MAX_ACC); + } + } +#endif + + stream->id = stream_id; + + body = (const char *)buf + *pnwritten; + bodylen = len - *pnwritten; + + if(bodylen || eos) { + size_t n; + result = cf_h2_body_send(cf, data, stream, body, bodylen, eos, &n); + if(!result) + *pnwritten += n; + else if(result == CURLE_AGAIN) + result = CURLE_OK; + else { + result = CURLE_SEND_ERROR; + } + } + +out: + CURL_TRC_CF(data, cf, "[%d] submit -> %d, %zu", + stream ? stream->id : -1, (int)result, *pnwritten); + curlx_safefree(nva); + *pstream = stream; + Curl_dynhds_free(&h2_headers); + return result; +} + +static CURLcode cf_h2_send(struct Curl_cfilter *cf, struct Curl_easy *data, + const uint8_t *buf, size_t len, bool eos, + size_t *pnwritten) +{ + struct cf_h2_ctx *ctx = cf->ctx; + struct h2_stream_ctx *stream = H2_STREAM_CTX(ctx, data); + struct cf_call_data save; + CURLcode result = CURLE_OK, r2; + + CF_DATA_SAVE(save, cf, data); + *pnwritten = 0; + + if(!stream || stream->id == -1) { + result = h2_submit(&stream, cf, data, buf, len, eos, pnwritten); + if(result) + goto out; + DEBUGASSERT(stream); + } + else if(stream->body_eos) { + /* We already wrote this, but CURLE_AGAIN-ed the call due to not + * being able to flush stream->sendbuf. Make a 0-length write + * to trigger flushing again. + * If this works, we report to have written `len` bytes. */ + size_t n; + DEBUGASSERT(eos); + result = cf_h2_body_send(cf, data, stream, buf, 0, eos, &n); + CURL_TRC_CF(data, cf, "[%d] cf_body_send last CHUNK -> %d, %zu, eos=%d", + stream->id, (int)result, n, eos); + if(result) + goto out; + *pnwritten = len; + } + else { + result = cf_h2_body_send(cf, data, stream, buf, len, eos, pnwritten); + CURL_TRC_CF(data, cf, "[%d] cf_body_send(len=%zu) -> %d, %zu, eos=%d", + stream->id, len, (int)result, *pnwritten, eos); + } + + /* Call the nghttp2 send loop and flush to write ALL buffered data, + * headers and/or request body completely out to the network */ + r2 = h2_progress_egress(cf, data); + + /* if the stream has been closed in egress handling (nghttp2 does that + * when it does not like the headers, for example */ + if(stream && stream->closed) { + infof(data, "stream %d closed", stream->id); + result = CURLE_SEND_ERROR; + goto out; + } + else if(r2 && (r2 != CURLE_AGAIN)) { + result = r2; + goto out; + } + + if(should_close_session(ctx)) { + /* nghttp2 thinks this session is done. If the stream has not been + * closed, this is an error state for out transfer */ + if(stream && stream->closed) { + result = http2_handle_stream_close(cf, data, stream, pnwritten); + } + else { + CURL_TRC_CF(data, cf, "send: nothing to do in this session"); + result = CURLE_HTTP2; + } + } + +out: + if(stream) { + CURL_TRC_CF(data, cf, "[%d] cf_send(len=%zu) -> %d, %zu, " + "eos=%d, h2 windows %d-%d (stream-conn), " + "buffers %zu-%zu (stream-conn)", + stream->id, len, (int)result, *pnwritten, + stream->body_eos, + nghttp2_session_get_stream_remote_window_size( + ctx->h2, stream->id), + nghttp2_session_get_remote_window_size(ctx->h2), + Curl_bufq_len(&stream->sendbuf), + Curl_bufq_len(&ctx->outbufq)); + } + else { + CURL_TRC_CF(data, cf, "cf_send(len=%zu) -> %d, %zu, " + "connection-window=%d, nw_send_buffer(%zu)", + len, (int)result, *pnwritten, + nghttp2_session_get_remote_window_size(ctx->h2), + Curl_bufq_len(&ctx->outbufq)); + } + CF_DATA_RESTORE(cf, save); + return result; +} + +static CURLcode cf_h2_flush(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_h2_ctx *ctx = cf->ctx; + struct h2_stream_ctx *stream = H2_STREAM_CTX(ctx, data); + struct cf_call_data save; + CURLcode result = CURLE_OK; + + CF_DATA_SAVE(save, cf, data); + if(stream && !Curl_bufq_is_empty(&stream->sendbuf)) { + /* resume the potentially suspended stream */ + int rv = nghttp2_session_resume_data(ctx->h2, stream->id); + if(nghttp2_is_fatal(rv)) { + result = CURLE_SEND_ERROR; + goto out; + } + } + + result = h2_progress_egress(cf, data); + +out: + if(stream) { + CURL_TRC_CF(data, cf, "[%d] flush -> %d, " + "h2 windows %d-%d (stream-conn), " + "buffers %zu-%zu (stream-conn)", + stream->id, (int)result, + nghttp2_session_get_stream_remote_window_size( + ctx->h2, stream->id), + nghttp2_session_get_remote_window_size(ctx->h2), + Curl_bufq_len(&stream->sendbuf), + Curl_bufq_len(&ctx->outbufq)); + } + else { + CURL_TRC_CF(data, cf, "flush -> %d, " + "connection-window=%d, nw_send_buffer(%zu)", + (int)result, nghttp2_session_get_remote_window_size(ctx->h2), + Curl_bufq_len(&ctx->outbufq)); + } + CF_DATA_RESTORE(cf, save); + return result; +} + +static CURLcode cf_h2_adjust_pollset(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct easy_pollset *ps) +{ + struct cf_h2_ctx *ctx = cf->ctx; + struct cf_call_data save; + curl_socket_t sock; + bool want_recv, want_send; + CURLcode result = CURLE_OK; + + if(!ctx->h2) + return CURLE_OK; + + sock = Curl_conn_cf_get_socket(cf, data); + Curl_pollset_check(data, ps, sock, &want_recv, &want_send); + if(want_recv || want_send) { + struct h2_stream_ctx *stream = H2_STREAM_CTX(ctx, data); + bool c_exhaust, s_exhaust; + + CF_DATA_SAVE(save, cf, data); + c_exhaust = want_send && !nghttp2_session_get_remote_window_size(ctx->h2); + s_exhaust = want_send && stream && stream->id >= 0 && + !nghttp2_session_get_stream_remote_window_size(ctx->h2, + stream->id); + want_recv = (want_recv || c_exhaust || s_exhaust); + want_send = (!s_exhaust && want_send) || + (!c_exhaust && nghttp2_session_want_write(ctx->h2)) || + !Curl_bufq_is_empty(&ctx->outbufq); + + result = Curl_pollset_set(data, ps, sock, want_recv, want_send); + CF_DATA_RESTORE(cf, save); + } + else if(ctx->sent_goaway && !cf->shutdown) { + /* shutdown in progress */ + CF_DATA_SAVE(save, cf, data); + want_send = nghttp2_session_want_write(ctx->h2) || + !Curl_bufq_is_empty(&ctx->outbufq); + want_recv = nghttp2_session_want_read(ctx->h2); + result = Curl_pollset_set(data, ps, sock, want_recv, want_send); + CF_DATA_RESTORE(cf, save); + } + return result; +} + +static CURLcode cf_h2_ctx_open(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_h2_ctx *ctx = cf->ctx; + struct h2_stream_ctx *stream; + CURLcode result = CURLE_OUT_OF_MEMORY; + int rc; + nghttp2_session_callbacks *cbs = NULL; + + DEBUGASSERT(!ctx->h2); + DEBUGASSERT(ctx->initialized); + + rc = nghttp2_session_callbacks_new(&cbs); + if(rc) { + failf(data, "Could not initialize nghttp2 callbacks"); + goto out; + } + + nghttp2_session_callbacks_set_send_callback(cbs, send_callback); + nghttp2_session_callbacks_set_on_frame_recv_callback(cbs, on_frame_recv); + nghttp2_session_callbacks_set_on_invalid_frame_recv_callback(cbs, + cf_h2_on_invalid_frame_recv); +#ifdef CURLVERBOSE + nghttp2_session_callbacks_set_on_frame_send_callback(cbs, on_frame_send); +#endif + nghttp2_session_callbacks_set_on_data_chunk_recv_callback( + cbs, on_data_chunk_recv); + nghttp2_session_callbacks_set_on_stream_close_callback(cbs, on_stream_close); + nghttp2_session_callbacks_set_on_begin_headers_callback( + cbs, on_begin_headers); + nghttp2_session_callbacks_set_on_header_callback(cbs, on_header); +#ifdef CURLVERBOSE + nghttp2_session_callbacks_set_error_callback(cbs, error_callback); +#endif + + /* The nghttp2 session is not yet setup, do it */ + rc = h2_client_new(cf, cbs); + if(rc) { + failf(data, "Could not initialize nghttp2"); + goto out; + } + ctx->max_concurrent_streams = DEFAULT_MAX_CONCURRENT_STREAMS; + + if(ctx->via_h1_upgrade) { + /* HTTP/1.1 Upgrade issued. H2 Settings have already been submitted + * in the H1 request and we upgrade from there. This stream + * is opened implicitly as #1. */ + uint8_t binsettings[H2_BINSETTINGS_LEN]; + ssize_t rclen; + size_t binlen; /* length of the binsettings data */ + + rclen = populate_binsettings(binsettings, data); + + if(!curlx_sztouz(rclen, &binlen) || !binlen) { + failf(data, "nghttp2 unexpectedly failed on pack_settings_payload"); + result = CURLE_FAILED_INIT; + goto out; + } + + result = http2_data_setup(cf, data, &stream); + if(result) + goto out; + DEBUGASSERT(stream); + stream->id = 1; + /* queue SETTINGS frame (again) */ + rc = nghttp2_session_upgrade2(ctx->h2, binsettings, binlen, + data->state.httpreq == HTTPREQ_HEAD, + NULL); + if(rc) { + failf(data, "nghttp2_session_upgrade2() failed: %s(%d)", + nghttp2_strerror(rc), rc); + result = CURLE_HTTP2; + goto out; + } + + rc = nghttp2_session_set_stream_user_data(ctx->h2, stream->id, + data); + if(rc) { + infof(data, "http/2: failed to set user_data for stream %d", + stream->id); + DEBUGASSERT(0); + } + CURL_TRC_CF(data, cf, "created session via Upgrade"); + } + else { + nghttp2_settings_entry iv[H2_SETTINGS_IV_LEN]; + size_t ivlen; + + ivlen = populate_settings(iv, data, ctx); + rc = nghttp2_submit_settings(ctx->h2, NGHTTP2_FLAG_NONE, + iv, ivlen); + if(rc) { + failf(data, "nghttp2_submit_settings() failed: %s(%d)", + nghttp2_strerror(rc), rc); + result = CURLE_HTTP2; + goto out; + } + } + + rc = nghttp2_session_set_local_window_size(ctx->h2, NGHTTP2_FLAG_NONE, 0, + HTTP2_HUGE_WINDOW_SIZE); + if(rc) { + failf(data, "nghttp2_session_set_local_window_size() failed: %s(%d)", + nghttp2_strerror(rc), rc); + result = CURLE_HTTP2; + goto out; + } + + /* all set, traffic will be send on connect */ + result = CURLE_OK; + CURL_TRC_CF(data, cf, "[0] created h2 session%s", + ctx->via_h1_upgrade ? " (via h1 upgrade)" : ""); + +out: + if(cbs) + nghttp2_session_callbacks_del(cbs); + return result; +} + +static CURLcode cf_h2_connect(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ + struct cf_h2_ctx *ctx = cf->ctx; + CURLcode result = CURLE_OK; + struct cf_call_data save; + bool first_time = FALSE; + + if(cf->connected) { + *done = TRUE; + return CURLE_OK; + } + + /* Connect the lower filters first */ + if(!cf->next->connected) { + result = Curl_conn_cf_connect(cf->next, data, done); + if(result || !*done) + return result; + } + + *done = FALSE; + + CF_DATA_SAVE(save, cf, data); + DEBUGASSERT(ctx->initialized); + if(!ctx->h2) { + result = cf_h2_ctx_open(cf, data); + if(result) + goto out; + first_time = TRUE; + } + + if(!first_time) { + result = h2_progress_ingress(cf, data, 0); + if(result) + goto out; + } + + /* Send out our SETTINGS and ACKs and such. If that blocks, we + * have it buffered and can count this filter as being connected */ + result = h2_progress_egress(cf, data); + if(result && (result != CURLE_AGAIN)) + goto out; + + *done = TRUE; + cf->connected = TRUE; + result = CURLE_OK; + +out: + CURL_TRC_CF(data, cf, "cf_connect() -> %d, %d, ", (int)result, *done); + CF_DATA_RESTORE(cf, save); + return result; +} + +static void cf_h2_destroy(struct Curl_cfilter *cf, struct Curl_easy *data) +{ + struct cf_h2_ctx *ctx = cf->ctx; + + (void)data; + if(ctx) { + cf_h2_ctx_free(ctx); + cf->ctx = NULL; + } +} + +static CURLcode cf_h2_shutdown(struct Curl_cfilter *cf, + struct Curl_easy *data, bool *done) +{ + struct cf_h2_ctx *ctx = cf->ctx; + struct cf_call_data save; + CURLcode result; + int rv; + + if(!cf->connected || !ctx->h2 || cf->shutdown || ctx->conn_closed) { + *done = TRUE; + return CURLE_OK; + } + + CF_DATA_SAVE(save, cf, data); + + if(!ctx->sent_goaway) { + ctx->sent_goaway = TRUE; + rv = nghttp2_submit_goaway(ctx->h2, NGHTTP2_FLAG_NONE, + ctx->local_max_sid, 0, + (const uint8_t *)"shutdown", + sizeof("shutdown")); + if(rv) { + failf(data, "nghttp2_submit_goaway() failed: %s(%d)", + nghttp2_strerror(rv), rv); + result = CURLE_SEND_ERROR; + goto out; + } + } + /* GOAWAY submitted, process egress and ingress until nghttp2 is done. */ + result = CURLE_OK; + if(nghttp2_session_want_write(ctx->h2) || + !Curl_bufq_is_empty(&ctx->outbufq)) + result = h2_progress_egress(cf, data); + if(!result && nghttp2_session_want_read(ctx->h2)) + result = h2_progress_ingress(cf, data, 0); + + if(result == CURLE_AGAIN) + result = CURLE_OK; + + *done = (ctx->conn_closed || + (!result && !nghttp2_session_want_write(ctx->h2) && + !nghttp2_session_want_read(ctx->h2) && + Curl_bufq_is_empty(&ctx->outbufq))); + +out: + CF_DATA_RESTORE(cf, save); + cf->shutdown = (result || *done); + return result; +} + +static CURLcode http2_data_pause(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool pause) +{ + struct cf_h2_ctx *ctx = cf->ctx; + struct h2_stream_ctx *stream = H2_STREAM_CTX(ctx, data); + + DEBUGASSERT(data); + if(ctx && ctx->h2 && stream) { + CURLcode result; + + stream->write_paused = pause; + result = cf_h2_update_local_win(cf, data, stream); + if(result) + return result; + + /* attempt to send the window update */ + (void)h2_progress_egress(cf, data); + + if(!pause) { + /* Unpausing a h2 transfer, requires it to be run again. The server + * may send new DATA on us increasing the flow window, and it may + * not. We may have already buffered and exhausted the new window + * by operating on things in flight during the handling of other + * transfers. */ + Curl_multi_mark_dirty(data); + } + CURL_TRC_CF(data, cf, "[%d] stream now %spaused", stream->id, + pause ? "" : "un"); + } + return CURLE_OK; +} + +static CURLcode cf_h2_cntrl(struct Curl_cfilter *cf, + struct Curl_easy *data, + int event, int arg1, void *arg2) +{ + CURLcode result = CURLE_OK; + struct cf_call_data save; + + (void)arg2; + + CF_DATA_SAVE(save, cf, data); + switch(event) { + case CF_CTRL_DATA_SETUP: + break; + case CF_CTRL_DATA_PAUSE: + result = http2_data_pause(cf, data, (arg1 != 0)); + break; + case CF_CTRL_FLUSH: + result = cf_h2_flush(cf, data); + break; + case CF_CTRL_DATA_DONE: + http2_data_done(cf, data); + break; + case CF_CTRL_CONN_INFO_UPDATE: + if(!cf->sockindex && cf->connected) { + cf->conn->httpversion_seen = 20; + Curl_conn_set_multiplex(cf->conn); + } + break; + default: + break; + } + CF_DATA_RESTORE(cf, save); + return result; +} + +static bool cf_h2_data_pending(struct Curl_cfilter *cf, + const struct Curl_easy *data) +{ + struct cf_h2_ctx *ctx = cf->ctx; + + if(ctx && !Curl_bufq_is_empty(&ctx->inbufq)) + return TRUE; + return cf->next ? cf->next->cft->has_data_pending(cf->next, data) : FALSE; +} + +static bool cf_h2_is_alive(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *input_pending) +{ + struct cf_h2_ctx *ctx = cf->ctx; + bool alive; + struct cf_call_data save; + + *input_pending = FALSE; + CF_DATA_SAVE(save, cf, data); + alive = (ctx && ctx->h2 && http2_connisalive(cf, data, input_pending)); + CURL_TRC_CF(data, cf, "conn alive -> %d, input_pending=%d", + alive, *input_pending); + CF_DATA_RESTORE(cf, save); + return alive; +} + +static CURLcode cf_h2_keep_alive(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + CURLcode result; + struct cf_call_data save; + + CF_DATA_SAVE(save, cf, data); + result = http2_send_ping(cf, data); + CF_DATA_RESTORE(cf, save); + return result; +} + +static CURLcode cf_h2_query(struct Curl_cfilter *cf, + struct Curl_easy *data, + int query, int *pres1, void *pres2) +{ + struct cf_h2_ctx *ctx = cf->ctx; + struct cf_call_data save; + size_t effective_max; + + switch(query) { + case CF_QUERY_MAX_CONCURRENT: + DEBUGASSERT(pres1); + + CF_DATA_SAVE(save, cf, data); + if(!ctx->h2 || !nghttp2_session_check_request_allowed(ctx->h2)) { + /* the limit is what we have in use right now */ + effective_max = cf->conn->attached_xfers; + } + else { + effective_max = ctx->max_concurrent_streams; + } + *pres1 = (effective_max > INT_MAX) ? INT_MAX : (int)effective_max; + CF_DATA_RESTORE(cf, save); + return CURLE_OK; + case CF_QUERY_STREAM_ERROR: { + struct h2_stream_ctx *stream = H2_STREAM_CTX(ctx, data); + *pres1 = stream ? (int)stream->error : 0; + return CURLE_OK; + } + case CF_QUERY_NEED_FLUSH: { + struct h2_stream_ctx *stream = H2_STREAM_CTX(ctx, data); + if(!Curl_bufq_is_empty(&ctx->outbufq) || + (stream && !Curl_bufq_is_empty(&stream->sendbuf))) { + *pres1 = TRUE; + return CURLE_OK; + } + break; + } + case CF_QUERY_HTTP_VERSION: + *pres1 = 20; + return CURLE_OK; + default: + break; + } + return cf->next ? + cf->next->cft->query(cf->next, data, query, pres1, pres2) : + CURLE_UNKNOWN_OPTION; +} + +struct Curl_cftype Curl_cft_nghttp2 = { + "HTTP/2", + CF_TYPE_MULTIPLEX | CF_TYPE_HTTP, + CURL_LOG_LVL_NONE, + cf_h2_destroy, + cf_h2_connect, + cf_h2_shutdown, + cf_h2_adjust_pollset, + cf_h2_data_pending, + cf_h2_send, + cf_h2_recv, + cf_h2_cntrl, + cf_h2_is_alive, + cf_h2_keep_alive, + cf_h2_query, +}; + +static CURLcode http2_cfilter_add(struct Curl_cfilter **pcf, + struct Curl_easy *data, + struct connectdata *conn, + int sockindex, + bool via_h1_upgrade) +{ + struct Curl_cfilter *cf = NULL; + struct cf_h2_ctx *ctx; + CURLcode result = CURLE_OUT_OF_MEMORY; + + DEBUGASSERT(data->conn); + ctx = curlx_calloc(1, sizeof(*ctx)); + if(!ctx) + goto out; + cf_h2_ctx_init(ctx, via_h1_upgrade); + + result = Curl_cf_create(&cf, &Curl_cft_nghttp2, ctx); + if(result) + goto out; + + ctx = NULL; + Curl_conn_cf_add(data, conn, sockindex, cf); + +out: + if(result) + cf_h2_ctx_free(ctx); + *pcf = result ? NULL : cf; + return result; +} + +static CURLcode http2_cfilter_insert_after(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool via_h1_upgrade) +{ + struct Curl_cfilter *cf_h2 = NULL; + struct cf_h2_ctx *ctx; + CURLcode result = CURLE_OUT_OF_MEMORY; + + (void)data; + ctx = curlx_calloc(1, sizeof(*ctx)); + if(!ctx) + goto out; + cf_h2_ctx_init(ctx, via_h1_upgrade); + + result = Curl_cf_create(&cf_h2, &Curl_cft_nghttp2, ctx); + if(result) + goto out; + + ctx = NULL; + Curl_conn_cf_insert_after(cf, cf_h2); + +out: + if(result) + cf_h2_ctx_free(ctx); + return result; +} + +bool Curl_http2_may_switch(struct Curl_easy *data) +{ + if(Curl_conn_http_version(data, data->conn) < 20 && + (data->state.http_neg.wanted & CURL_HTTP_V2x) && + data->state.http_neg.h2_prior_knowledge) { +#ifndef CURL_DISABLE_PROXY + if(data->conn->bits.origin_is_proxy) { + infof(data, "Ignoring HTTP/2 prior knowledge due to proxy"); + return FALSE; + } +#endif + return TRUE; + } + return FALSE; +} + +CURLcode Curl_http2_switch(struct Curl_easy *data) +{ + struct Curl_cfilter *cf; + CURLcode result; + + DEBUGASSERT(Curl_conn_http_version(data, data->conn) < 20); + + result = http2_cfilter_add(&cf, data, data->conn, FIRSTSOCKET, FALSE); + if(result) + return result; + CURL_TRC_CF(data, cf, "switching connection to HTTP/2"); + + if(cf->next) { + bool done; + return Curl_conn_cf_connect(cf, data, &done); + } + return CURLE_OK; +} + +CURLcode Curl_http2_switch_at(struct Curl_cfilter *cf, struct Curl_easy *data) +{ + struct Curl_cfilter *cf_h2; + CURLcode result; + + DEBUGASSERT(Curl_conn_http_version(data, data->conn) < 20); + + result = http2_cfilter_insert_after(cf, data, FALSE); + if(result) + return result; + + cf_h2 = cf->next; + + if(cf_h2->next) { + bool done; + return Curl_conn_cf_connect(cf_h2, data, &done); + } + return CURLE_OK; +} + +CURLcode Curl_http2_upgrade(struct Curl_easy *data, + struct connectdata *conn, int sockindex, + const char *mem, size_t nread) +{ + struct Curl_cfilter *cf; + struct cf_h2_ctx *ctx; + CURLcode result; + + DEBUGASSERT(Curl_conn_http_version(data, conn) < 20); + + result = http2_cfilter_add(&cf, data, conn, sockindex, TRUE); + if(result) + return result; + CURL_TRC_CF(data, cf, "upgrading connection to HTTP/2"); + + DEBUGASSERT(cf->cft == &Curl_cft_nghttp2); + ctx = cf->ctx; + + data->req.httpversion_sent = 20; /* it is an h2 request now */ + data->req.header = TRUE; /* we expect the real response to come in h2 */ + data->req.headerline = 0; /* restart the header line counter */ + + if(nread > 0) { + /* Remaining data from the protocol switch reply is already using + * the switched protocol, ie. HTTP/2. We add that to the network + * inbufq. */ + size_t copied; + + result = Curl_bufq_write(&ctx->inbufq, + (const unsigned char *)mem, nread, &copied); + if(result) { + failf(data, "error on copying HTTP Upgrade response: %d", (int)result); + return CURLE_RECV_ERROR; + } + if(copied < nread) { + failf(data, "connection buffer size could not take all data " + "from HTTP Upgrade response header: copied=%zu, datalen=%zu", + copied, nread); + return CURLE_HTTP2; + } + infof(data, "Copied HTTP/2 data in stream buffer to connection buffer" + " after upgrade: len=%zu", nread); + } + + if(cf->next) { + bool done; + result = Curl_conn_cf_connect(cf, data, &done); + if(!result) + cf->cft->cntrl(cf, data, CF_CTRL_CONN_INFO_UPDATE, 0, NULL); + } + return result; +} + +/* Only call this function for a transfer that already got an HTTP/2 + CURLE_HTTP2_STREAM error! */ +bool Curl_h2_http_1_1_error(struct Curl_easy *data) +{ + if(Curl_conn_http_version(data, data->conn) == 20) { + int err = Curl_conn_get_stream_error(data, data->conn, FIRSTSOCKET); + return err == NGHTTP2_HTTP_1_1_REQUIRED; + } + return FALSE; +} + +void *Curl_nghttp2_malloc(size_t size, void *user_data) +{ + (void)user_data; + return Curl_cmalloc(size); +} + +void Curl_nghttp2_free(void *ptr, void *user_data) +{ + (void)user_data; + Curl_cfree(ptr); +} + +void *Curl_nghttp2_calloc(size_t nmemb, size_t size, void *user_data) +{ + (void)user_data; + return Curl_ccalloc(nmemb, size); +} + +void *Curl_nghttp2_realloc(void *ptr, size_t size, void *user_data) +{ + (void)user_data; + return Curl_crealloc(ptr, size); +} + +#else /* CURL_DISABLE_HTTP || !USE_NGHTTP2 */ + +/* Satisfy external references even if http2 is not compiled in. */ + +char *curl_pushheader_bynum(struct curl_pushheaders *h, size_t num) +{ + (void)h; + (void)num; + return NULL; +} + +char *curl_pushheader_byname(struct curl_pushheaders *h, const char *name) +{ + (void)h; + (void)name; + return NULL; +} + +#endif /* !CURL_DISABLE_HTTP && USE_NGHTTP2 */ diff --git a/3rdparty/curl-8.21.0/lib/http2.h b/3rdparty/curl-8.21.0/lib/http2.h new file mode 100644 index 0000000000..e38dc5745c --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/http2.h @@ -0,0 +1,76 @@ +#ifndef HEADER_CURL_HTTP2_H +#define HEADER_CURL_HTTP2_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_NGHTTP2 + +/* value for MAX_CONCURRENT_STREAMS we use until we get an updated setting + from the peer */ +#define DEFAULT_MAX_CONCURRENT_STREAMS 100 + +/* + * Store nghttp2 version info in this buffer. + */ +void Curl_http2_ver(char *p, size_t len); + +#ifdef CURLVERBOSE +int Curl_nghttp2_fr_print(const nghttp2_frame *frame, char *buffer, + size_t blen); +#endif + +CURLcode Curl_http2_request_upgrade(struct dynbuf *req, + struct Curl_easy *data); + +/* returns true if the HTTP/2 stream error was HTTP_1_1_REQUIRED */ +bool Curl_h2_http_1_1_error(struct Curl_easy *data); + +bool Curl_http2_may_switch(struct Curl_easy *data); + +CURLcode Curl_http2_switch(struct Curl_easy *data); + +CURLcode Curl_http2_switch_at(struct Curl_cfilter *cf, struct Curl_easy *data); + +CURLcode Curl_http2_upgrade(struct Curl_easy *data, + struct connectdata *conn, int sockindex, + const char *mem, size_t nread); + +void *Curl_nghttp2_malloc(size_t size, void *user_data); +void Curl_nghttp2_free(void *ptr, void *user_data); +void *Curl_nghttp2_calloc(size_t nmemb, size_t size, void *user_data); +void *Curl_nghttp2_realloc(void *ptr, size_t size, void *user_data); + +extern struct Curl_cftype Curl_cft_nghttp2; + +#else /* USE_NGHTTP2 */ + +#define Curl_http2_may_switch(a) FALSE + +#define Curl_http2_request_upgrade(x, y) CURLE_UNSUPPORTED_PROTOCOL +#define Curl_http2_switch(a) CURLE_UNSUPPORTED_PROTOCOL +#define Curl_h2_http_1_1_error(x) 0 +#endif + +#endif /* HEADER_CURL_HTTP2_H */ diff --git a/3rdparty/curl-8.21.0/lib/http_aws_sigv4.c b/3rdparty/curl-8.21.0/lib/http_aws_sigv4.c new file mode 100644 index 0000000000..780eed67b9 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/http_aws_sigv4.c @@ -0,0 +1,1248 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_HTTP) && !defined(CURL_DISABLE_AWS) + +#include "urldata.h" +#include "strcase.h" +#include "curlx/strdup.h" +#include "http_aws_sigv4.h" +#include "curl_sha256.h" +#include "transfer.h" +#include "curl_trc.h" +#include "escape.h" +#include "curlx/strparse.h" +#include "slist.h" + +#include + +#define HMAC_SHA256(k, kl, d, dl, o) \ + do { \ + result = Curl_hmacit(&Curl_HMAC_SHA256, \ + (const unsigned char *)(k), \ + kl, \ + (const unsigned char *)(d), \ + dl, o); \ + if(result) { \ + goto fail; \ + } \ + } while(0) + +#define TIMESTAMP_SIZE 17 + +/* hex-encoded with trailing null */ +#define SHA256_HEX_LENGTH ((2 * CURL_SHA256_DIGEST_LENGTH) + 1) + +#define MAX_QUERY_COMPONENTS 128 + +struct pair { + struct dynbuf key; + struct dynbuf value; +}; + +static void sha256_to_hex(char *dst, unsigned char *sha) +{ + Curl_hexencode(sha, CURL_SHA256_DIGEST_LENGTH, + (unsigned char *)dst, SHA256_HEX_LENGTH); +} + +static char *find_date_hdr(struct Curl_easy *data, const char *sig_hdr) +{ + char *tmp = Curl_checkheaders(data, sig_hdr, strlen(sig_hdr)); + + if(tmp) + return tmp; + return Curl_checkheaders(data, STRCONST("Date")); +} + +/* remove whitespace, and lowercase all headers */ +static void trim_headers(struct curl_slist *head) +{ + struct curl_slist *l; + for(l = head; l; l = l->next) { + const char *value; /* to read from */ + char *store; + size_t colon = strcspn(l->data, ":"); + Curl_strntolower(l->data, l->data, colon); + + value = &l->data[colon]; + if(!*value) + continue; + ++value; + store = (char *)CURL_UNCONST(value); + + /* skip leading whitespace */ + curlx_str_passblanks(&value); + + while(*value) { + int space = 0; + while(ISBLANK(*value)) { + value++; + space++; + } + if(space) { + /* replace any number of consecutive whitespace with a single space, + unless at the end of the string, then nothing */ + if(*value) + *store++ = ' '; + } + else + *store++ = *value++; + } + *store = 0; /* null-terminate */ + } +} + +/* + * Frees all allocated strings in a dynbuf pair array, and the dynbuf itself + */ +static void pair_array_free(struct pair *pair_array, size_t num_elements) +{ + size_t index; + + for(index = 0; index != num_elements; index++) { + curlx_dyn_free(&pair_array[index].key); + curlx_dyn_free(&pair_array[index].value); + } +} + +/* + * Frees all allocated strings in a split dynbuf, and the dynbuf itself + */ +static void dyn_array_free(struct dynbuf *db, size_t num_elements) +{ + size_t index; + + for(index = 0; index < num_elements; index++) + curlx_dyn_free((&db[index])); +} + +/* + * Splits source string by SPLIT_BY, and creates an array of dynbuf in db. + * db is initialized by this function. + * Caller is responsible for freeing the array elements with dyn_array_free + */ + +#define SPLIT_BY '&' + +static CURLcode split_to_dyn_array(const char *source, + struct dynbuf db[MAX_QUERY_COMPONENTS], + size_t *num_splits_out) +{ + CURLcode result = CURLE_OK; + size_t len = strlen(source); + size_t pos; /* Position in result buffer */ + size_t start = 0; /* Start of current segment */ + size_t segment_length = 0; + size_t index = 0; + size_t num_splits = 0; + + /* Split source_ptr on SPLIT_BY and store the segment offsets and length in + * array */ + for(pos = 0; pos < len; pos++) { + if(source[pos] == SPLIT_BY) { + if(segment_length) { + curlx_dyn_init(&db[index], segment_length + 1); + result = curlx_dyn_addn(&db[index], &source[start], segment_length); + if(result) + goto fail; + + segment_length = 0; + index++; + if(++num_splits == MAX_QUERY_COMPONENTS) { + result = CURLE_TOO_LARGE; + goto fail; + } + } + start = pos + 1; + } + else { + segment_length++; + } + } + + if(segment_length) { + curlx_dyn_init(&db[index], segment_length + 1); + result = curlx_dyn_addn(&db[index], &source[start], segment_length); + if(!result) { + if(++num_splits == MAX_QUERY_COMPONENTS) + result = CURLE_TOO_LARGE; + } + } +fail: + *num_splits_out = num_splits; + return result; +} + +static bool is_reserved_char(const char c) +{ + return (ISALNUM(c) || ISURLPUNTCS(c)); +} + +static CURLcode uri_encode_path(struct Curl_str *original_path, + struct dynbuf *new_path) +{ + const char *p = curlx_str(original_path); + size_t i; + + for(i = 0; i < curlx_strlen(original_path); i++) { + /* Do not encode slashes or unreserved chars from RFC 3986 */ + CURLcode result = CURLE_OK; + unsigned char c = p[i]; + if(is_reserved_char(c) || c == '/') + result = curlx_dyn_addn(new_path, &c, 1); + else + result = curlx_dyn_addf(new_path, "%%%02X", c); + if(result) + return result; + } + + return CURLE_OK; +} + +/* Normalize the query part. Make sure %2B is left percent encoded, and not + decoded to plus, then encoded to space. +*/ +static CURLcode normalize_query(const char *string, size_t len, + struct dynbuf *db) +{ + CURLcode result = CURLE_OK; + + while(len && !result) { + unsigned char in = (unsigned char)*string; + if(('%' == in) && (len > 2) && + ISXDIGIT(string[1]) && ISXDIGIT(string[2])) { + /* this is two hexadecimal digits following a '%' */ + in = (unsigned char)((curlx_hexval(string[1]) << 4) | + curlx_hexval(string[2])); + string += 3; + len -= 3; + if(in == '+') { + /* decodes to plus, so leave this encoded */ + result = curlx_dyn_addn(db, "%2B", 3); + continue; + } + } + else { + string++; + len--; + } + + if(is_reserved_char(in)) + /* Escape unreserved chars from RFC 3986 */ + result = curlx_dyn_addn(db, &in, 1); + else if(in == '+') + /* Encode '+' as space */ + result = curlx_dyn_add(db, "%20"); + else + result = curlx_dyn_addf(db, "%%%02X", in); + } + + return result; +} + +static bool should_urlencode(struct Curl_str *service_name) +{ + /* + * These services require unmodified (not additionally URL-encoded) URL + * paths. + * should_urlencode == true is equivalent to should_urlencode_uri_path + * from the AWS SDK. Urls are already normalized by the curl URL parser + */ + if(curlx_str_cmp(service_name, "s3") || + curlx_str_cmp(service_name, "s3-express") || + curlx_str_cmp(service_name, "s3-outposts")) { + return FALSE; + } + return TRUE; +} + +/* maximum length for the aws sivg4 parts */ +#define MAX_SIGV4_LEN 64 +#define DATE_HDR_KEY_LEN (MAX_SIGV4_LEN + sizeof("X--Date")) + +/* string been x-PROVIDER-date:TIMESTAMP, I need +1 for ':' */ +#define DATE_FULL_HDR_LEN (DATE_HDR_KEY_LEN + TIMESTAMP_SIZE + 1) + +/* alphabetically compare two headers by their name, expecting + headers to use ':' at this point */ +static int compare_header_names(const char *a, const char *b) +{ + const char *colon_a; + const char *colon_b; + size_t len_a; + size_t len_b; + size_t min_len; + int cmp; + + colon_a = strchr(a, ':'); + colon_b = strchr(b, ':'); + + DEBUGASSERT(colon_a); + DEBUGASSERT(colon_b); + + len_a = colon_a ? (size_t)(colon_a - a) : strlen(a); + len_b = colon_b ? (size_t)(colon_b - b) : strlen(b); + + min_len = (len_a < len_b) ? len_a : len_b; + + cmp = strncmp(a, b, min_len); + + /* return the shorter of the two if one is shorter */ + if(!cmp) + return (int)(len_a - len_b); + + return cmp; +} + +/* Merge duplicate header definitions by comma delimiting their values + in the order defined the headers are defined, expecting headers to + be alpha-sorted and use ':' at this point */ +static CURLcode merge_duplicate_headers(struct curl_slist *head) +{ + struct curl_slist *curr = head; + CURLcode result = CURLE_OK; + + while(curr) { + struct curl_slist *next = curr->next; + if(!next) + break; + + if(compare_header_names(curr->data, next->data) == 0) { + struct dynbuf buf; + const char *colon_next; + const char *val_next; + + curlx_dyn_init(&buf, CURL_MAX_HTTP_HEADER); + + result = curlx_dyn_add(&buf, curr->data); + if(result) + return result; + + colon_next = strchr(next->data, ':'); + DEBUGASSERT(colon_next); + val_next = colon_next + 1; + + result = curlx_dyn_addn(&buf, ",", 1); + if(result) + return result; + + result = curlx_dyn_add(&buf, val_next); + if(result) + return result; + + curlx_free(curr->data); + curr->data = curlx_dyn_ptr(&buf); + + curr->next = next->next; + curlx_free(next->data); + curlx_free(next); + } + else { + curr = curr->next; + } + } + + return CURLE_OK; +} + +/* timestamp should point to a buffer of at last TIMESTAMP_SIZE bytes */ +static CURLcode make_headers(struct Curl_easy *data, + const char *hostname, + char *timestamp, + const char *provider1, + size_t plen, /* length of provider1 */ + char **date_header, + char *content_sha256_header, + struct dynbuf *canonical_headers, + struct dynbuf *signed_headers) +{ + char date_hdr_key[DATE_HDR_KEY_LEN]; + char date_full_hdr[DATE_FULL_HDR_LEN]; + struct curl_slist *head = NULL; + struct curl_slist *tmp_head = NULL; + CURLcode result = CURLE_OUT_OF_MEMORY; + struct curl_slist *l; + bool again = TRUE; + + curl_msnprintf(date_hdr_key, DATE_HDR_KEY_LEN, "X-%.*s-Date", + (int)plen, provider1); + /* provider1 ucfirst */ + Curl_strntolower(&date_hdr_key[2], provider1, plen); + date_hdr_key[2] = Curl_raw_toupper(provider1[0]); + + curl_msnprintf(date_full_hdr, DATE_FULL_HDR_LEN, + "x-%.*s-date:%s", (int)plen, provider1, timestamp); + /* provider1 lowercase */ + Curl_strntolower(&date_full_hdr[2], provider1, plen); + + if(!Curl_checkheaders(data, STRCONST("Host"))) { + char *fullhost; + + if(data->state.aptr.host) { + /* remove /r/n as the separator for canonical request must be '\n' */ + size_t pos = strcspn(data->state.aptr.host, "\n\r"); + fullhost = curlx_memdup0(data->state.aptr.host, pos); + } + else + fullhost = curl_maprintf("host:%s", hostname); + + if(fullhost) + head = Curl_slist_append_nodup(NULL, fullhost); + if(!head) { + curlx_free(fullhost); + goto fail; + } + } + + if(*content_sha256_header) { + tmp_head = curl_slist_append(head, content_sha256_header); + if(!tmp_head) + goto fail; + head = tmp_head; + } + + /* copy user headers to our header list. the logic is based on how http.c + handles user headers. + + user headers in format 'name:' with no value are used to signal that an + internal header of that name should be removed. those user headers are not + added to this list. + + user headers in format 'name;' with no value are used to signal that a + header of that name with no value should be sent. those user headers are + added to this list but in the format that they will be sent, ie the + semi-colon is changed to a colon for format 'name:'. + + user headers with a value of whitespace only, or without a colon or + semi-colon, are not added to this list. + */ + for(l = data->set.headers; l; l = l->next) { + char *dupdata; + const char *ptr; + const char *sep = strchr(l->data, ':'); + if(!sep) + sep = strchr(l->data, ';'); + if(!sep || (*sep == ':' && !*(sep + 1))) + continue; + for(ptr = sep + 1; ISBLANK(*ptr); ++ptr) + ; + if(!*ptr && ptr != sep + 1) /* a value of whitespace only */ + continue; + dupdata = curlx_strdup(l->data); + if(!dupdata) + goto fail; + dupdata[sep - l->data] = ':'; + tmp_head = Curl_slist_append_nodup(head, dupdata); + if(!tmp_head) { + curlx_free(dupdata); + goto fail; + } + head = tmp_head; + } + + trim_headers(head); + + *date_header = find_date_hdr(data, date_hdr_key); + if(!*date_header) { + tmp_head = curl_slist_append(head, date_full_hdr); + if(!tmp_head) + goto fail; + head = tmp_head; + *date_header = curl_maprintf("%s: %s\r\n", date_hdr_key, timestamp); + if(!*date_header) + goto fail; + } + else { + const char *value; + const char *endp; + value = strchr(*date_header, ':'); + if(!value) { + *date_header = NULL; + goto fail; + } + ++value; + curlx_str_passblanks(&value); + endp = value; + while(*endp && ISALNUM(*endp)) + ++endp; + /* 16 bytes => "19700101T000000Z" */ + if((endp - value) == TIMESTAMP_SIZE - 1) { + memcpy(timestamp, value, TIMESTAMP_SIZE - 1); + timestamp[TIMESTAMP_SIZE - 1] = 0; + } + else + /* bad timestamp length */ + timestamp[0] = 0; + *date_header = NULL; + } + + /* alpha-sort by header name in a case sensitive manner */ + do { + again = FALSE; + for(l = head; l; l = l->next) { + struct curl_slist *next = l->next; + + if(next && compare_header_names(l->data, next->data) > 0) { + char *tmp = l->data; + + l->data = next->data; + next->data = tmp; + again = TRUE; + } + } + } while(again); + + result = merge_duplicate_headers(head); + if(result) + goto fail; + + for(l = head; l; l = l->next) { + char *tmp; + + if(curlx_dyn_add(canonical_headers, l->data)) + goto fail; + if(curlx_dyn_add(canonical_headers, "\n")) + goto fail; + + tmp = strchr(l->data, ':'); + if(tmp) + *tmp = 0; + + if(l != head) { + if(curlx_dyn_add(signed_headers, ";")) + goto fail; + } + if(curlx_dyn_add(signed_headers, l->data)) + goto fail; + } + + result = CURLE_OK; +fail: + curl_slist_free_all(head); + + return result; +} + +#define CONTENT_SHA256_KEY_LEN (MAX_SIGV4_LEN + sizeof("X--Content-Sha256")) +/* add 2 for ": " between header name and value */ +#define CONTENT_SHA256_HDR_LEN (CONTENT_SHA256_KEY_LEN + 2 + SHA256_HEX_LENGTH) + +/* try to parse a payload hash from the content-sha256 header */ +static const char *parse_content_sha_hdr(struct Curl_easy *data, + const char *provider1, + size_t plen, + size_t *value_len) +{ + char key[CONTENT_SHA256_KEY_LEN]; + size_t key_len; + const char *value; + size_t len; + + key_len = curl_msnprintf(key, sizeof(key), "x-%.*s-content-sha256", + (int)plen, provider1); + + value = Curl_checkheaders(data, key, key_len); + if(!value) + return NULL; + + value = strchr(value, ':'); + if(!value) + return NULL; + ++value; + + curlx_str_passblanks(&value); + + len = strlen(value); + while(len > 0 && ISBLANK(value[len - 1])) + --len; + + *value_len = len; + return value; +} + +static CURLcode calc_payload_hash(struct Curl_easy *data, + unsigned char *sha_hash, char *sha_hex) +{ + const char *post_data = data->set.postfields; + size_t post_data_len = 0; + CURLcode result; + + if(post_data) { + if(data->set.postfieldsize < 0) + post_data_len = strlen(post_data); + else + post_data_len = (size_t)data->set.postfieldsize; + } + result = Curl_sha256it(sha_hash, (const unsigned char *)post_data, + post_data_len); + if(!result) + sha256_to_hex(sha_hex, sha_hash); + return result; +} + +#define S3_UNSIGNED_PAYLOAD "UNSIGNED-PAYLOAD" + +static CURLcode calc_s3_payload_hash(struct Curl_easy *data, + Curl_HttpReq httpreq, + const char *provider1, + size_t plen, + unsigned char *sha_hash, + char *sha_hex, char *header) +{ + bool empty_method = (httpreq == HTTPREQ_GET || httpreq == HTTPREQ_HEAD); + /* The request method or filesize indicate no request payload */ + bool empty_payload = (empty_method || data->set.filesize == 0); + /* The POST payload is in memory */ + bool post_payload = (httpreq == HTTPREQ_POST && data->set.postfields); + CURLcode result = CURLE_OUT_OF_MEMORY; + + if(empty_payload || post_payload) { + /* Calculate a real hash when we know the request payload */ + result = calc_payload_hash(data, sha_hash, sha_hex); + if(result) + goto fail; + } + else { + /* Fall back to s3's UNSIGNED-PAYLOAD */ + size_t len = sizeof(S3_UNSIGNED_PAYLOAD) - 1; + DEBUGASSERT(len < SHA256_HEX_LENGTH); /* 16 < 65 */ + memcpy(sha_hex, S3_UNSIGNED_PAYLOAD, len); + sha_hex[len] = 0; + } + + /* format the required content-sha256 header */ + curl_msnprintf(header, CONTENT_SHA256_HDR_LEN, + "x-%.*s-content-sha256: %s", (int)plen, provider1, sha_hex); + + result = CURLE_OK; +fail: + return result; +} + +static int compare_func(const void *a, const void *b) +{ + const struct pair *aa = a; + const struct pair *bb = b; + const size_t aa_key_len = curlx_dyn_len(&aa->key); + const size_t bb_key_len = curlx_dyn_len(&bb->key); + const size_t aa_value_len = curlx_dyn_len(&aa->value); + const size_t bb_value_len = curlx_dyn_len(&bb->value); + int compare; + + /* If one element is empty, the other is always sorted higher */ + + /* Compare keys */ + if((aa_key_len == 0) && (bb_key_len == 0)) + return 0; + if(aa_key_len == 0) + return -1; + if(bb_key_len == 0) + return 1; + compare = strcmp(curlx_dyn_ptr(&aa->key), curlx_dyn_ptr(&bb->key)); + if(compare) { + return compare; + } + + /* Compare values */ + if((aa_value_len == 0) && (bb_value_len == 0)) + return 0; + if(aa_value_len == 0) + return -1; + if(bb_value_len == 0) + return 1; + compare = strcmp(curlx_dyn_ptr(&aa->value), curlx_dyn_ptr(&bb->value)); + + return compare; +} + +/* @unittest 1979 */ +UNITTEST CURLcode canon_path(const char *q, size_t len, + struct dynbuf *new_path, + bool do_uri_encode); +UNITTEST CURLcode canon_path(const char *q, size_t len, + struct dynbuf *new_path, + bool do_uri_encode) +{ + CURLcode result = CURLE_OK; + + struct Curl_str original_path; + + curlx_str_assign(&original_path, q, len); + + /* Normalized path will be either the same or shorter than the original + * path, plus trailing slash */ + + if(do_uri_encode) + result = uri_encode_path(&original_path, new_path); + else + result = curlx_dyn_addn(new_path, q, len); + + if(!result) { + if(curlx_dyn_len(new_path) == 0) + result = curlx_dyn_add(new_path, "/"); + } + + return result; +} + +/* @unittest 1980 */ +UNITTEST CURLcode canon_query(const char *query, struct dynbuf *dq); +UNITTEST CURLcode canon_query(const char *query, struct dynbuf *dq) +{ + CURLcode result = CURLE_OK; + + struct dynbuf query_array[MAX_QUERY_COMPONENTS]; + struct pair encoded_query_array[MAX_QUERY_COMPONENTS]; + size_t num_query_components; + size_t counted_query_components = 0; + size_t index; + + if(!query) + return result; + + result = split_to_dyn_array(query, &query_array[0], &num_query_components); + if(result) { + goto fail; + } + + /* Create list of pairs, each pair containing an encoded query + * component */ + + for(index = 0; index < num_query_components; index++) { + const char *in_key; + size_t in_key_len; + const char *offset; + size_t query_part_len = curlx_dyn_len(&query_array[index]); + const char *query_part = curlx_dyn_ptr(&query_array[index]); + + in_key = query_part; + + offset = strchr(query_part, '='); + /* If there is no equals, this key has no value */ + if(!offset) { + in_key_len = strlen(in_key); + } + else { + in_key_len = offset - in_key; + } + + curlx_dyn_init(&encoded_query_array[index].key, + (query_part_len * 3) + 1); + curlx_dyn_init(&encoded_query_array[index].value, + (query_part_len * 3) + 1); + counted_query_components++; + + /* Decode/encode the key */ + result = normalize_query(in_key, in_key_len, + &encoded_query_array[index].key); + if(result) { + goto fail; + } + + /* Decode/encode the value if it exists */ + if(offset && offset != (query_part + query_part_len - 1)) { + size_t in_value_len; + const char *in_value = offset + 1; + in_value_len = query_part + query_part_len - (offset + 1); + result = normalize_query(in_value, in_value_len, + &encoded_query_array[index].value); + if(result) { + goto fail; + } + } + else { + /* If there is no value, the value is an empty string */ + curlx_dyn_init(&encoded_query_array[index].value, 2); + result = curlx_dyn_addn(&encoded_query_array[index].value, "", 1); + } + + if(result) { + goto fail; + } + } + + /* Sort the encoded query components by key and value */ + qsort(&encoded_query_array, num_query_components, + sizeof(struct pair), compare_func); + + /* Append the query components together to make a full query string */ + for(index = 0; index < num_query_components; index++) { + + if(index) + result = curlx_dyn_addn(dq, "&", 1); + if(!result) { + const char *key_ptr = curlx_dyn_ptr(&encoded_query_array[index].key); + const char *value_ptr = curlx_dyn_ptr(&encoded_query_array[index].value); + size_t vlen = curlx_dyn_len(&encoded_query_array[index].value); + if(value_ptr && vlen) { + result = curlx_dyn_addf(dq, "%s=%s", key_ptr, value_ptr); + } + else { + /* Empty value is always encoded to key= */ + result = curlx_dyn_addf(dq, "%s=", key_ptr); + } + } + if(result) + break; + } + +fail: + if(counted_query_components) + /* the encoded_query_array might not be initialized yet */ + pair_array_free(&encoded_query_array[0], counted_query_components); + dyn_array_free(&query_array[0], num_query_components); + return result; +} + +static CURLcode parse_sigv4_params(struct Curl_easy *data, + const char *hostname, + struct Curl_str *provider0, + struct Curl_str *provider1, + struct Curl_str *region, + struct Curl_str *service) +{ + const char *line = data->set.str[STRING_AWS_SIGV4]; + if(!line || !*line) + line = "aws:amz"; + + /* provider0[:provider1[:region[:service]]] + + No string can be longer than N bytes of non-whitespace + */ + if(curlx_str_until(&line, provider0, MAX_SIGV4_LEN, ':')) { + failf(data, "first aws-sigv4 provider cannot be empty"); + return CURLE_BAD_FUNCTION_ARGUMENT; + } + if(curlx_str_single(&line, ':') || + curlx_str_until(&line, provider1, MAX_SIGV4_LEN, ':')) { + *provider1 = *provider0; + } + else if(curlx_str_single(&line, ':') || + curlx_str_until(&line, region, MAX_SIGV4_LEN, ':') || + curlx_str_single(&line, ':') || + curlx_str_until(&line, service, MAX_SIGV4_LEN, ':')) { + /* nothing to do */ + } + + if(!curlx_strlen(service)) { + const char *p = hostname; + if(curlx_str_until(&p, service, MAX_SIGV4_LEN, '.') || + curlx_str_single(&p, '.')) { + failf(data, "aws-sigv4: service missing in parameters and hostname"); + return CURLE_URL_MALFORMAT; + } + + infof(data, "aws_sigv4: picked service %.*s from host", + (int)curlx_strlen(service), curlx_str(service)); + + if(!curlx_strlen(region)) { + if(curlx_str_until(&p, region, MAX_SIGV4_LEN, '.') || + curlx_str_single(&p, '.')) { + failf(data, "aws-sigv4: region missing in parameters and hostname"); + return CURLE_URL_MALFORMAT; + } + infof(data, "aws_sigv4: picked region %.*s from host", + (int)curlx_strlen(region), curlx_str(region)); + } + } + + return CURLE_OK; +} + +static CURLcode get_payload_hash(struct Curl_easy *data, + Curl_HttpReq httpreq, + struct Curl_str *provider0, + struct Curl_str *provider1, + struct Curl_str *service, + unsigned char *sha_hash, + char *sha_hex, + char *content_sha256_hdr, + const char **payload_hash_out, + size_t *payload_hash_len_out) +{ + *payload_hash_out = + parse_content_sha_hdr(data, curlx_str(provider1), + curlx_strlen(provider1), payload_hash_len_out); + + if(!*payload_hash_out) { + CURLcode result; + /* AWS S3 requires a x-amz-content-sha256 header, and supports special + * values like UNSIGNED-PAYLOAD */ + bool sign_as_s3 = curlx_str_casecompare(provider0, "aws") && + curlx_str_casecompare(service, "s3"); + + if(sign_as_s3) + result = calc_s3_payload_hash(data, httpreq, curlx_str(provider1), + curlx_strlen(provider1), sha_hash, + sha_hex, content_sha256_hdr); + else + result = calc_payload_hash(data, sha_hash, sha_hex); + if(result) + return result; + + *payload_hash_out = sha_hex; + /* may be shorter than SHA256_HEX_LENGTH, like S3_UNSIGNED_PAYLOAD */ + *payload_hash_len_out = strlen(sha_hex); + } + return CURLE_OK; +} + +static CURLcode get_timestamp(char *timestamp, size_t stampsize) +{ + time_t clock; + struct tm tm; + CURLcode result; + +#ifdef DEBUGBUILD + { + char *force_timestamp = getenv("CURL_FORCETIME"); + if(force_timestamp) + clock = 0; + else + clock = time(NULL); + } +#else + clock = time(NULL); +#endif + result = curlx_gmtime(clock, &tm); + if(result) + return result; + + if(!strftime(timestamp, stampsize, "%Y%m%dT%H%M%SZ", &tm)) + return CURLE_OUT_OF_MEMORY; + + return CURLE_OK; +} + +static CURLcode make_canonical_request(struct Curl_easy *data, + const char *hostname, + char *timestamp, + struct Curl_str *provider1, + struct Curl_str *service, + const char *method, + const char *payload_hash, + size_t payload_hash_len, + char **date_header_out, + char *content_sha256_hdr, + struct dynbuf *canonical_headers, + struct dynbuf *signed_headers, + char **canonical_request_out) +{ + struct dynbuf canonical_query; + struct dynbuf canonical_path; + CURLcode result; + + curlx_dyn_init(&canonical_query, CURL_MAX_HTTP_HEADER); + curlx_dyn_init(&canonical_path, CURL_MAX_HTTP_HEADER); + + result = make_headers(data, hostname, timestamp, + curlx_str(provider1), curlx_strlen(provider1), + date_header_out, content_sha256_hdr, + canonical_headers, signed_headers); + if(result) + goto fail; + + result = canon_query(data->state.up.query, &canonical_query); + if(result) + goto fail; + + result = canon_path(data->state.up.path, strlen(data->state.up.path), + &canonical_path, + should_urlencode(service)); + if(result) + goto fail; + + *canonical_request_out = + curl_maprintf("%s\n" /* HTTPRequestMethod */ + "%s\n" /* CanonicalURI */ + "%s\n" /* CanonicalQueryString */ + "%s\n" /* CanonicalHeaders */ + "%s\n" /* SignedHeaders */ + "%.*s", /* HashedRequestPayload in hex */ + method, + curlx_dyn_ptr(&canonical_path), + curlx_dyn_ptr(&canonical_query) ? + curlx_dyn_ptr(&canonical_query) : "", + curlx_dyn_ptr(canonical_headers), + curlx_dyn_ptr(signed_headers), + (int)payload_hash_len, payload_hash); + if(!*canonical_request_out) { + result = CURLE_OUT_OF_MEMORY; + goto fail; + } + + result = CURLE_OK; +fail: + curlx_dyn_free(&canonical_query); + curlx_dyn_free(&canonical_path); + return result; +} + +static CURLcode make_string_to_sign(struct Curl_easy *data, + struct Curl_str *provider0, + struct Curl_str *region, + struct Curl_str *service, + const char *date, + const char *timestamp, + const char *canonical_request, + char **request_type_out, + char **credential_scope_out, + char **str_to_sign_out) +{ + char *request_type; + char *credential_scope; + char *str_to_sign; + unsigned char sha_hash[CURL_SHA256_DIGEST_LENGTH]; + char sha_hex[SHA256_HEX_LENGTH]; + + request_type = curl_maprintf("%.*s4_request", + (int)curlx_strlen(provider0), + curlx_str(provider0)); + if(!request_type) + return CURLE_OUT_OF_MEMORY; + + /* provider0 is lowercased *after* curl_maprintf() so that the buffer + can be written to */ + Curl_strntolower(request_type, request_type, curlx_strlen(provider0)); + + credential_scope = curl_maprintf("%s/%.*s/%.*s/%s", date, + (int)curlx_strlen(region), + curlx_str(region), + (int)curlx_strlen(service), + curlx_str(service), + request_type); + if(!credential_scope) { + curlx_free(request_type); + return CURLE_OUT_OF_MEMORY; + } + + if(Curl_sha256it(sha_hash, (const unsigned char *)canonical_request, + strlen(canonical_request))) { + curlx_free(request_type); + curlx_free(credential_scope); + return CURLE_OUT_OF_MEMORY; + } + + sha256_to_hex(sha_hex, sha_hash); + + /* + * Google allows using RSA key instead of HMAC, so this code might change + * in the future. For now we only support HMAC. + */ + str_to_sign = curl_maprintf("%.*s4-HMAC-SHA256\n" /* Algorithm */ + "%s\n" /* RequestDateTime */ + "%s\n" /* CredentialScope */ + "%s", /* HashedCanonicalRequest in hex */ + (int)curlx_strlen(provider0), + curlx_str(provider0), + timestamp, + credential_scope, + sha_hex); + if(!str_to_sign) { + curlx_free(request_type); + curlx_free(credential_scope); + return CURLE_OUT_OF_MEMORY; + } + + /* make provider0 part done uppercase */ + Curl_strntoupper(str_to_sign, curlx_str(provider0), + curlx_strlen(provider0)); + + infof(data, "aws_sigv4: String to sign (enclosed in []) - [%s]", + str_to_sign); + + *request_type_out = request_type; + *credential_scope_out = credential_scope; + *str_to_sign_out = str_to_sign; + return CURLE_OK; +} + +static CURLcode sign_and_set_auth_headers(struct Curl_easy *data, + struct Curl_str *provider0, + struct Curl_str *region, + struct Curl_str *service, + const char *request_type, + const char *credential_scope, + const char *date, + const char *str_to_sign, + const char *date_header, + const char *content_sha256_hdr, + struct dynbuf *signed_headers) +{ + CURLcode result = CURLE_OUT_OF_MEMORY; + const char *passwd = Curl_creds_passwd(data->state.creds); + char *secret = NULL; + unsigned char sign0[CURL_SHA256_DIGEST_LENGTH] = { 0 }; + unsigned char sign1[CURL_SHA256_DIGEST_LENGTH] = { 0 }; + char sha_hex[SHA256_HEX_LENGTH]; + char *auth_headers = NULL; + char *user = curl_escape(Curl_creds_user(data->state.creds), 0); + if(!user) + return CURLE_OUT_OF_MEMORY; + + secret = curl_maprintf("%.*s4%s", (int)curlx_strlen(provider0), + curlx_str(provider0), passwd); + if(!secret) + goto fail; + /* make provider0 part done uppercase */ + Curl_strntoupper(secret, curlx_str(provider0), curlx_strlen(provider0)); + + HMAC_SHA256(secret, strlen(secret), date, strlen(date), sign0); + HMAC_SHA256(sign0, sizeof(sign0), + curlx_str(region), curlx_strlen(region), sign1); + HMAC_SHA256(sign1, sizeof(sign1), + curlx_str(service), curlx_strlen(service), sign0); + HMAC_SHA256(sign0, sizeof(sign0), + request_type, strlen(request_type), sign1); + HMAC_SHA256(sign1, sizeof(sign1), + str_to_sign, strlen(str_to_sign), sign0); + + sha256_to_hex(sha_hex, sign0); + + infof(data, "aws_sigv4: Signature - %s", sha_hex); + + auth_headers = curl_maprintf("Authorization: %.*s4-HMAC-SHA256 " + "Credential=%s/%s, " + "SignedHeaders=%s, " + "Signature=%s\r\n" + "%s" + "%s%s", + (int)curlx_strlen(provider0), + curlx_str(provider0), + user, + credential_scope, + curlx_dyn_ptr(signed_headers), + sha_hex, + /* + * date_header is added here, only if it was not + * user-specified (using CURLOPT_HTTPHEADER). + * date_header includes \r\n + */ + date_header ? date_header : "", + content_sha256_hdr, + content_sha256_hdr[0] ? "\r\n": ""); + if(!auth_headers) + goto fail; + + /* provider 0 uppercase */ + Curl_strntoupper(&auth_headers[sizeof("Authorization: ") - 1], + curlx_str(provider0), curlx_strlen(provider0)); + + curlx_free(data->req.hd_auth); + data->req.hd_auth = auth_headers; + data->state.authhost.done = TRUE; + result = CURLE_OK; + +fail: + curlx_free(user); + curlx_free(secret); + return result; +} + +CURLcode Curl_output_aws_sigv4(struct Curl_easy *data) +{ + CURLcode result = CURLE_OUT_OF_MEMORY; + struct Curl_str provider0 = { NULL, 0 }; + struct Curl_str provider1 = { NULL, 0 }; + struct Curl_str region = { NULL, 0 }; + struct Curl_str service = { NULL, 0 }; + const char *hostname = data->state.origin->hostname; + char timestamp[TIMESTAMP_SIZE]; + char date[9]; + struct dynbuf canonical_headers; + struct dynbuf signed_headers; + char *date_header = NULL; + Curl_HttpReq httpreq; + const char *method = NULL; + const char *payload_hash = NULL; + size_t payload_hash_len = 0; + unsigned char sha_hash[CURL_SHA256_DIGEST_LENGTH]; + char sha_hex[SHA256_HEX_LENGTH]; + char content_sha256_hdr[CONTENT_SHA256_HDR_LEN + 2] = ""; /* add \r\n */ + char *canonical_request = NULL; + char *request_type = NULL; + char *credential_scope = NULL; + char *str_to_sign = NULL; + + if(data->set.path_as_is) { + failf(data, "Cannot use sigv4 authentication with path-as-is flag"); + return CURLE_BAD_FUNCTION_ARGUMENT; + } + + if(Curl_checkheaders(data, STRCONST("Authorization"))) + /* Authorization already present, Bailing out */ + return CURLE_OK; + + /* we init those buffers here, so goto fail will free initialized dynbuf */ + curlx_dyn_init(&canonical_headers, CURL_MAX_HTTP_HEADER); + curlx_dyn_init(&signed_headers, CURL_MAX_HTTP_HEADER); + + result = parse_sigv4_params(data, hostname, &provider0, &provider1, + ®ion, &service); + if(!result) { + Curl_http_method(data, &method, &httpreq); + result = get_payload_hash(data, httpreq, &provider0, &provider1, &service, + sha_hash, sha_hex, content_sha256_hdr, + &payload_hash, &payload_hash_len); + } + + if(!result) + result = get_timestamp(timestamp, sizeof(timestamp)); + + if(!result) + result = make_canonical_request(data, hostname, timestamp, + &provider1, &service, + method, payload_hash, payload_hash_len, + &date_header, content_sha256_hdr, + &canonical_headers, &signed_headers, + &canonical_request); + if(!result) { + /* the timestamp might have been updated in make_canonical_request */ + memcpy(date, timestamp, sizeof(date) - 1); + date[sizeof(date) - 1] = 0; + + result = make_string_to_sign(data, &provider0, ®ion, &service, + date, timestamp, canonical_request, + &request_type, &credential_scope, + &str_to_sign); + } + if(!result) + result = sign_and_set_auth_headers(data, &provider0, ®ion, &service, + request_type, credential_scope, + date, str_to_sign, date_header, + content_sha256_hdr, &signed_headers); + + curlx_dyn_free(&canonical_headers); + curlx_dyn_free(&signed_headers); + curlx_free(canonical_request); + curlx_free(request_type); + curlx_free(credential_scope); + curlx_free(str_to_sign); + curlx_free(date_header); + return result; +} + +#endif /* !CURL_DISABLE_HTTP && !CURL_DISABLE_AWS */ diff --git a/3rdparty/curl-8.21.0/lib/http_aws_sigv4.h b/3rdparty/curl-8.21.0/lib/http_aws_sigv4.h new file mode 100644 index 0000000000..7dd002476a --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/http_aws_sigv4.h @@ -0,0 +1,34 @@ +#ifndef HEADER_CURL_HTTP_AWS_SIGV4_H +#define HEADER_CURL_HTTP_AWS_SIGV4_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "curlx/dynbuf.h" +#include "urldata.h" + +/* this is for creating aws_sigv4 header output */ +CURLcode Curl_output_aws_sigv4(struct Curl_easy *data); + +#endif /* HEADER_CURL_HTTP_AWS_SIGV4_H */ diff --git a/3rdparty/curl-8.21.0/lib/http_chunks.c b/3rdparty/curl-8.21.0/lib/http_chunks.c new file mode 100644 index 0000000000..9596fc6693 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/http_chunks.c @@ -0,0 +1,682 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifndef CURL_DISABLE_HTTP + +#include "urldata.h" /* it includes http_chunks.h */ +#include "curl_trc.h" +#include "http.h" /* for Curl_verify_header */ +#include "sendf.h" /* for the client write stuff */ +#include "curlx/dynbuf.h" +#include "multiif.h" +#include "curlx/strparse.h" + +/* + Chunk format (simplified): + + [ chunk extension ] CRLF + CRLF + + Highlights from RFC2616 section 3.6 say: + + The chunked encoding modifies the body of a message in order to + transfer it as a series of chunks, each with its own size indicator, + followed by an OPTIONAL trailer containing entity-header fields. This + allows dynamically produced content to be transferred along with the + information necessary for the recipient to verify that it has + received the full message. + + Chunked-Body = *chunk + last-chunk + trailer + CRLF + + chunk = chunk-size [ chunk-extension ] CRLF + chunk-data CRLF + chunk-size = 1*HEX + last-chunk = 1*("0") [ chunk-extension ] CRLF + + chunk-extension= *( ";" chunk-ext-name [ "=" chunk-ext-val ] ) + chunk-ext-name = token + chunk-ext-val = token | quoted-string + chunk-data = chunk-size(OCTET) + trailer = *(entity-header CRLF) + + The chunk-size field is a string of hex digits indicating the size of + the chunk. The chunked encoding is ended by any chunk whose size is + zero, followed by the trailer, which is terminated by an empty line. + + */ + +void Curl_httpchunk_init(struct Curl_easy *data, struct Curl_chunker *ch, + bool ignore_body) +{ + (void)data; + ch->hexindex = 0; /* start at 0 */ + ch->state = CHUNK_HEX; /* we get hex first! */ + ch->last_code = CHUNKE_OK; + curlx_dyn_init(&ch->trailer, DYN_H1_TRAILER); + ch->ignore_body = ignore_body; +} + +void Curl_httpchunk_reset(struct Curl_easy *data, struct Curl_chunker *ch, + bool ignore_body) +{ + (void)data; + ch->hexindex = 0; /* start at 0 */ + ch->state = CHUNK_HEX; /* we get hex first! */ + ch->last_code = CHUNKE_OK; + curlx_dyn_reset(&ch->trailer); + ch->ignore_body = ignore_body; +} + +void Curl_httpchunk_free(struct Curl_easy *data, struct Curl_chunker *ch) +{ + (void)data; + curlx_dyn_free(&ch->trailer); +} + +bool Curl_httpchunk_is_done(struct Curl_easy *data, struct Curl_chunker *ch) +{ + (void)data; + return ch->state == CHUNK_DONE; +} + +static CURLcode httpchunk_readwrite(struct Curl_easy *data, + struct Curl_chunker *ch, + struct Curl_cwriter *cw_next, + const char *buf, size_t blen, + size_t *pconsumed) +{ + CURLcode result = CURLE_OK; + size_t piece; + + *pconsumed = 0; /* nothing's written yet */ + /* first check terminal states that will not progress anywhere */ + if(ch->state == CHUNK_DONE) + return CURLE_OK; + if(ch->state == CHUNK_FAILED) + return CURLE_RECV_ERROR; + + /* the original data is written to the client, but we go on with the + chunk read process, to properly calculate the content length */ + if(data->set.http_te_skip && !ch->ignore_body) { + if(cw_next) + result = Curl_cwriter_write(data, cw_next, CLIENTWRITE_BODY, buf, blen); + else + result = Curl_client_write(data, CLIENTWRITE_BODY, buf, blen); + if(result) { + ch->state = CHUNK_FAILED; + ch->last_code = CHUNKE_PASSTHRU_ERROR; + return result; + } + } + + while(blen) { + switch(ch->state) { + case CHUNK_HEX: + if(ISXDIGIT(*buf)) { + if(ch->hexindex >= CHUNK_MAXNUM_LEN) { + failf(data, "chunk hex-length longer than %d", CHUNK_MAXNUM_LEN); + ch->state = CHUNK_FAILED; + ch->last_code = CHUNKE_TOO_LONG_HEX; /* longer than we support */ + return CURLE_RECV_ERROR; + } + ch->hexbuffer[ch->hexindex++] = *buf; + buf++; + blen--; + (*pconsumed)++; + } + else { + const char *p; + if(ch->hexindex == 0) { + /* This is illegal data, we received junk where we expected + a hexadecimal digit. */ + failf(data, "chunk hex-length char not a hex digit: 0x%x", + (unsigned int)*buf); + ch->state = CHUNK_FAILED; + ch->last_code = CHUNKE_ILLEGAL_HEX; + return CURLE_RECV_ERROR; + } + /* blen and buf are unmodified */ + ch->hexbuffer[ch->hexindex] = 0; + p = &ch->hexbuffer[0]; + if(curlx_str_hex(&p, &ch->datasize, CURL_OFF_T_MAX)) { + failf(data, "invalid chunk size: '%s'", ch->hexbuffer); + ch->state = CHUNK_FAILED; + ch->last_code = CHUNKE_ILLEGAL_HEX; + return CURLE_RECV_ERROR; + } + ch->state = CHUNK_LF; /* now wait for the CRLF */ + } + break; + + case CHUNK_LF: + /* waiting for the LF after a chunk size */ + if(*buf == 0x0a) { + /* we are now expecting data to come, unless size was zero! */ + if(ch->datasize == 0) { + ch->state = CHUNK_TRAILER; /* now check for trailers */ + } + else { + ch->state = CHUNK_DATA; + CURL_TRC_WRITE(data, "http_chunked, chunk start of %" + FMT_OFF_T " bytes", ch->datasize); + } + } + + buf++; + blen--; + (*pconsumed)++; + break; + + case CHUNK_DATA: + /* We expect 'datasize' of data. We have 'blen' right now, it can be + more or less than 'datasize'. Get the smallest piece. + */ + piece = blen; + if(ch->datasize < (curl_off_t)blen) + piece = curlx_sotouz(ch->datasize); + + /* Write the data portion available */ + if(!data->set.http_te_skip && !ch->ignore_body) { + if(cw_next) + result = Curl_cwriter_write(data, cw_next, CLIENTWRITE_BODY, + buf, piece); + else + result = Curl_client_write(data, CLIENTWRITE_BODY, buf, piece); + if(result) { + ch->state = CHUNK_FAILED; + ch->last_code = CHUNKE_PASSTHRU_ERROR; + return result; + } + } + + *pconsumed += piece; + ch->datasize -= piece; /* decrease amount left to expect */ + buf += piece; /* move read pointer forward */ + blen -= piece; /* decrease space left in this round */ + CURL_TRC_WRITE(data, "http_chunked, write %zu body bytes, %" + FMT_OFF_T " bytes in chunk remain", + piece, ch->datasize); + + if(ch->datasize == 0) + /* end of data this round, we now expect a trailing CRLF */ + ch->state = CHUNK_POSTLF; + break; + + case CHUNK_POSTLF: + if(*buf == 0x0a) { + /* The last one before we go back to hex state and start all over. */ + Curl_httpchunk_reset(data, ch, (bool)ch->ignore_body); + } + else if(*buf != 0x0d) { + ch->state = CHUNK_FAILED; + ch->last_code = CHUNKE_BAD_CHUNK; + return CURLE_RECV_ERROR; + } + buf++; + blen--; + (*pconsumed)++; + break; + + case CHUNK_TRAILER: + if((*buf == 0x0d) || (*buf == 0x0a)) { + const char *tr = curlx_dyn_ptr(&ch->trailer); + /* this is the end of a trailer, but if the trailer was zero bytes + there was no trailer and we move on */ + + if(tr) { + size_t trlen; + result = curlx_dyn_addn(&ch->trailer, STRCONST("\x0d\x0a")); + if(result) { + ch->state = CHUNK_FAILED; + ch->last_code = CHUNKE_OUT_OF_MEMORY; + return result; + } + tr = curlx_dyn_ptr(&ch->trailer); + trlen = curlx_dyn_len(&ch->trailer); + + /* a trailer is delivered to the client as a header, so it must pass + the same checks as a regular response header */ + result = Curl_verify_header(data, tr, trlen); + if(result) { + ch->state = CHUNK_FAILED; + ch->last_code = CHUNKE_BAD_CHUNK; + return result; + } + + if(!data->set.http_te_skip) { + if(cw_next) + result = Curl_cwriter_write(data, cw_next, + CLIENTWRITE_HEADER | + CLIENTWRITE_TRAILER, + tr, trlen); + else + result = Curl_client_write(data, + CLIENTWRITE_HEADER | + CLIENTWRITE_TRAILER, + tr, trlen); + if(result) { + ch->state = CHUNK_FAILED; + ch->last_code = CHUNKE_PASSTHRU_ERROR; + return result; + } + } + curlx_dyn_reset(&ch->trailer); + ch->state = CHUNK_TRAILER_CR; + if(*buf == 0x0a) + /* already on the LF */ + break; + } + else { + /* no trailer, we are on the final CRLF pair */ + ch->state = CHUNK_TRAILER_POSTCR; + break; /* do not advance the pointer */ + } + } + else { + result = curlx_dyn_addn(&ch->trailer, buf, 1); + if(result) { + ch->state = CHUNK_FAILED; + ch->last_code = CHUNKE_OUT_OF_MEMORY; + return result; + } + } + buf++; + blen--; + (*pconsumed)++; + break; + + case CHUNK_TRAILER_CR: + if(*buf == 0x0a) { + ch->state = CHUNK_TRAILER_POSTCR; + buf++; + blen--; + (*pconsumed)++; + } + else { + ch->state = CHUNK_FAILED; + ch->last_code = CHUNKE_BAD_CHUNK; + return CURLE_RECV_ERROR; + } + break; + + case CHUNK_TRAILER_POSTCR: + /* We enter this state when a CR should arrive so we expect to + have to first pass a CR before we wait for LF */ + if((*buf != 0x0d) && (*buf != 0x0a)) { + /* not a CR then it must be another header in the trailer */ + ch->state = CHUNK_TRAILER; + break; + } + if(*buf == 0x0d) { + /* skip if CR */ + buf++; + blen--; + (*pconsumed)++; + } + /* now wait for the final LF */ + ch->state = CHUNK_STOP; + break; + + case CHUNK_STOP: + if(*buf == 0x0a) { + blen--; + (*pconsumed)++; + /* Record the length of any data left in the end of the buffer + even if there is no more chunks to read */ + ch->datasize = blen; + ch->state = CHUNK_DONE; + CURL_TRC_WRITE(data, "http_chunk, response complete"); + return CURLE_OK; + } + else { + ch->state = CHUNK_FAILED; + ch->last_code = CHUNKE_BAD_CHUNK; + CURL_TRC_WRITE(data, "http_chunk error, expected 0x0a, seeing 0x%ux", + (unsigned int)*buf); + return CURLE_RECV_ERROR; + } + case CHUNK_DONE: + return CURLE_OK; + + case CHUNK_FAILED: + return CURLE_RECV_ERROR; + } + } + return CURLE_OK; +} + +static const char *Curl_chunked_strerror(CHUNKcode code) +{ + switch(code) { + default: + return "OK"; + case CHUNKE_TOO_LONG_HEX: + return "Too long hexadecimal number"; + case CHUNKE_ILLEGAL_HEX: + return "Illegal or missing hexadecimal sequence"; + case CHUNKE_BAD_CHUNK: + return "Malformed encoding found"; + case CHUNKE_PASSTHRU_ERROR: + return "Error writing data to client"; + case CHUNKE_BAD_ENCODING: + return "Bad content-encoding found"; + case CHUNKE_OUT_OF_MEMORY: + return "Out of memory"; + } +} + +CURLcode Curl_httpchunk_read(struct Curl_easy *data, + struct Curl_chunker *ch, + char *buf, size_t blen, + size_t *pconsumed) +{ + return httpchunk_readwrite(data, ch, NULL, buf, blen, pconsumed); +} + +struct chunked_writer { + struct Curl_cwriter super; + struct Curl_chunker ch; +}; + +static CURLcode cw_chunked_init(struct Curl_easy *data, + struct Curl_cwriter *writer) +{ + struct chunked_writer *ctx = writer->ctx; + + data->req.chunk = TRUE; /* chunks coming our way. */ + Curl_httpchunk_init(data, &ctx->ch, FALSE); + return CURLE_OK; +} + +static void cw_chunked_close(struct Curl_easy *data, + struct Curl_cwriter *writer) +{ + struct chunked_writer *ctx = writer->ctx; + Curl_httpchunk_free(data, &ctx->ch); +} + +static CURLcode cw_chunked_write(struct Curl_easy *data, + struct Curl_cwriter *writer, int type, + const char *buf, size_t blen) +{ + struct chunked_writer *ctx = writer->ctx; + CURLcode result; + size_t consumed; + + if(!(type & CLIENTWRITE_BODY)) + return Curl_cwriter_write(data, writer->next, type, buf, blen); + + consumed = 0; + result = httpchunk_readwrite(data, &ctx->ch, writer->next, buf, blen, + &consumed); + + if(result) { + if(CHUNKE_PASSTHRU_ERROR == ctx->ch.last_code) { + failf(data, "Failed reading the chunked-encoded stream"); + } + else { + failf(data, "%s in chunked-encoding", + Curl_chunked_strerror(ctx->ch.last_code)); + } + return result; + } + + blen -= consumed; + if(CHUNK_DONE == ctx->ch.state) { + /* chunks read successfully, download is complete */ + data->req.download_done = TRUE; + if(blen) { + infof(data, "Leftovers after chunking: %zu bytes", blen); + } + } + else if((type & CLIENTWRITE_EOS) && !data->req.no_body) { + failf(data, "transfer closed with outstanding read data remaining"); + return CURLE_PARTIAL_FILE; + } + + return CURLE_OK; +} + +/* HTTP chunked Transfer-Encoding decoder */ +const struct Curl_cwtype Curl_httpchunk_unencoder = { + "chunked", + NULL, + cw_chunked_init, + cw_chunked_write, + cw_chunked_close, + sizeof(struct chunked_writer) +}; + +/* max length of an HTTP chunk that we want to generate */ +#define CURL_CHUNKED_MINLEN 1024 +#define CURL_CHUNKED_MAXLEN (64 * 1024) + +struct chunked_reader { + struct Curl_creader super; + struct bufq chunkbuf; + BIT(read_eos); /* we read an EOS from the next reader */ + BIT(eos); /* we have returned an EOS */ +}; + +static CURLcode cr_chunked_init(struct Curl_easy *data, + struct Curl_creader *reader) +{ + struct chunked_reader *ctx = reader->ctx; + (void)data; + Curl_bufq_init2(&ctx->chunkbuf, CURL_CHUNKED_MAXLEN, 2, BUFQ_OPT_SOFT_LIMIT); + return CURLE_OK; +} + +static void cr_chunked_close(struct Curl_easy *data, + struct Curl_creader *reader) +{ + struct chunked_reader *ctx = reader->ctx; + (void)data; + Curl_bufq_free(&ctx->chunkbuf); +} + +static CURLcode add_last_chunk(struct Curl_easy *data, + struct Curl_creader *reader) +{ + struct chunked_reader *ctx = reader->ctx; + struct curl_slist *trailers = NULL, *tr; + CURLcode result; + size_t n; + int rc; + + if(!data->set.trailer_callback) { + CURL_TRC_READ(data, "http_chunk, added last, empty chunk"); + return Curl_bufq_cwrite(&ctx->chunkbuf, STRCONST("0\r\n\r\n"), &n); + } + + result = Curl_bufq_cwrite(&ctx->chunkbuf, STRCONST("0\r\n"), &n); + if(result) + goto out; + + Curl_set_in_callback(data, TRUE); + rc = data->set.trailer_callback(&trailers, data->set.trailer_data); + Curl_set_in_callback(data, FALSE); + + if(rc != CURL_TRAILERFUNC_OK) { + failf(data, "operation aborted by trailing headers callback"); + result = CURLE_ABORTED_BY_CALLBACK; + goto out; + } + + for(tr = trailers; tr; tr = tr->next) { + /* only add correctly formatted trailers */ + const char *ptr = strchr(tr->data, ':'); + if(!ptr || *(ptr + 1) != ' ') { + infof(data, "Malformatted trailing header, skipping trailer"); + continue; + } + + result = Curl_bufq_cwrite(&ctx->chunkbuf, tr->data, strlen(tr->data), &n); + if(!result) + result = Curl_bufq_cwrite(&ctx->chunkbuf, STRCONST("\r\n"), &n); + if(result) + goto out; + } + + result = Curl_bufq_cwrite(&ctx->chunkbuf, STRCONST("\r\n"), &n); + +out: + curl_slist_free_all(trailers); + CURL_TRC_READ(data, "http_chunk, added last chunk with trailers " + "from client -> %d", (int)result); + return result; +} + +static CURLcode add_chunk(struct Curl_easy *data, + struct Curl_creader *reader, + char *buf, size_t blen) +{ + struct chunked_reader *ctx = reader->ctx; + CURLcode result; + char tmp[CURL_CHUNKED_MINLEN]; + size_t nread; + bool eos; + + DEBUGASSERT(!ctx->read_eos); + blen = CURLMIN(blen, CURL_CHUNKED_MAXLEN); /* respect our buffer pref */ + if(blen < sizeof(tmp)) { + /* small read, make a chunk of decent size */ + buf = tmp; + blen = sizeof(tmp); + } + else { + /* larger read, make a chunk that will fit when read back */ + blen -= (8 + 2 + 2); /* deduct max overhead, 8 hex + 2*crlf */ + } + + result = Curl_creader_read(data, reader->next, buf, blen, &nread, &eos); + if(result) + return result; + if(eos) + ctx->read_eos = TRUE; + + if(nread) { + /* actually got bytes, wrap them into the chunkbuf */ + char hd[11] = ""; + int hdlen; + size_t n; + + hdlen = curl_msnprintf(hd, sizeof(hd), "%zx\r\n", nread); + if(hdlen <= 0) + return CURLE_READ_ERROR; + /* On a soft-limited bufq, we do not need to check that all was written */ + result = Curl_bufq_cwrite(&ctx->chunkbuf, hd, hdlen, &n); + if(!result) + result = Curl_bufq_cwrite(&ctx->chunkbuf, buf, nread, &n); + if(!result) + result = Curl_bufq_cwrite(&ctx->chunkbuf, "\r\n", 2, &n); + CURL_TRC_READ(data, "http_chunk, made chunk of %zu bytes -> %d", + nread, (int)result); + if(result) + return result; + } + + if(ctx->read_eos) + return add_last_chunk(data, reader); + return CURLE_OK; +} + +static CURLcode cr_chunked_read(struct Curl_easy *data, + struct Curl_creader *reader, + char *buf, size_t blen, + size_t *pnread, bool *peos) +{ + struct chunked_reader *ctx = reader->ctx; + CURLcode result = CURLE_READ_ERROR; + + *pnread = 0; + *peos = (bool)ctx->eos; + + if(!ctx->eos) { + if(!ctx->read_eos && Curl_bufq_is_empty(&ctx->chunkbuf)) { + /* Still getting data form the next reader, buffer is empty */ + result = add_chunk(data, reader, buf, blen); + if(result) + return result; + } + + if(!Curl_bufq_is_empty(&ctx->chunkbuf)) { + result = Curl_bufq_cread(&ctx->chunkbuf, buf, blen, pnread); + if(!result && ctx->read_eos && Curl_bufq_is_empty(&ctx->chunkbuf)) { + /* no more data, read all, done. */ + ctx->eos = TRUE; + *peos = TRUE; + } + return result; + } + } + /* We may get here, because we are done or because callbacks paused */ + DEBUGASSERT(ctx->eos || !ctx->read_eos); + return CURLE_OK; +} + +static curl_off_t cr_chunked_total_length(struct Curl_easy *data, + struct Curl_creader *reader) +{ + /* this reader changes length depending on input */ + (void)data; + (void)reader; + return -1; +} + +/* HTTP chunked Transfer-Encoding encoder */ +const struct Curl_crtype Curl_httpchunk_encoder = { + "chunked", + cr_chunked_init, + cr_chunked_read, + cr_chunked_close, + Curl_creader_def_needs_rewind, + cr_chunked_total_length, + Curl_creader_def_resume_from, + Curl_creader_def_cntrl, + Curl_creader_def_is_paused, + Curl_creader_def_done, + sizeof(struct chunked_reader) +}; + +CURLcode Curl_httpchunk_add_reader(struct Curl_easy *data) +{ + struct Curl_creader *reader = NULL; + CURLcode result; + + result = Curl_creader_create(&reader, data, &Curl_httpchunk_encoder, + CURL_CR_TRANSFER_ENCODE); + if(!result) + result = Curl_creader_add(data, reader); + + if(result && reader) + Curl_creader_free(data, reader); + return result; +} + +#endif /* CURL_DISABLE_HTTP */ diff --git a/3rdparty/curl-8.21.0/lib/http_chunks.h b/3rdparty/curl-8.21.0/lib/http_chunks.h new file mode 100644 index 0000000000..d8e5982e6d --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/http_chunks.h @@ -0,0 +1,146 @@ +#ifndef HEADER_CURL_HTTP_CHUNKS_H +#define HEADER_CURL_HTTP_CHUNKS_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifndef CURL_DISABLE_HTTP + +#include "curlx/dynbuf.h" + +struct connectdata; + +/* + * The longest possible hexadecimal number we support in a chunked transfer. + * Neither RFC2616 nor the later HTTP specs define a maximum chunk size. + * For 64-bit curl_off_t we support 16 digits. For 32-bit, 8 digits. + */ +#define CHUNK_MAXNUM_LEN (SIZEOF_CURL_OFF_T * 2) + +typedef enum { + /* await and buffer all hexadecimal digits until we get one that is not a + hexadecimal digit. When done, we go CHUNK_LF */ + CHUNK_HEX, + + /* wait for LF, ignore all else */ + CHUNK_LF, + + /* We eat the amount of data specified. When done, we move on to the + POST_CR state. */ + CHUNK_DATA, + + /* POSTLF should get a CR and then an LF and nothing else, then move back to + HEX as the CRLF combination marks the end of a chunk. A missing CR is no + big deal. */ + CHUNK_POSTLF, + + /* Used to mark that we are out of the game. NOTE: that there is a + 'datasize' field in the struct that will tell how many bytes that were + not passed to the client in the end of the last buffer! */ + CHUNK_STOP, + + /* At this point optional trailer headers can be found, unless the next line + is CRLF */ + CHUNK_TRAILER, + + /* A trailer CR has been found - next state is CHUNK_TRAILER_POSTCR. + Next char must be an LF */ + CHUNK_TRAILER_CR, + + /* A trailer LF must be found now, otherwise CHUNKE_BAD_CHUNK will be + signalled If this is an empty trailer CHUNKE_STOP will be signalled. + Otherwise the trailer will be broadcasted via Curl_client_write() and the + next state will be CHUNK_TRAILER */ + CHUNK_TRAILER_POSTCR, + + /* Successfully de-chunked everything */ + CHUNK_DONE, + + /* Failed on seeing a bad or not correctly terminated chunk */ + CHUNK_FAILED +} ChunkyState; + +typedef enum { + CHUNKE_OK = 0, + CHUNKE_TOO_LONG_HEX = 1, + CHUNKE_ILLEGAL_HEX, + CHUNKE_BAD_CHUNK, + CHUNKE_BAD_ENCODING, + CHUNKE_OUT_OF_MEMORY, + CHUNKE_PASSTHRU_ERROR /* Curl_httpchunk_read() returns a CURLcode to use */ +} CHUNKcode; + +struct Curl_chunker { + curl_off_t datasize; + ChunkyState state; + CHUNKcode last_code; + struct dynbuf trailer; /* for chunked-encoded trailer */ + unsigned char hexindex; + char hexbuffer[CHUNK_MAXNUM_LEN + 1]; /* +1 for null-terminator */ + BIT(ignore_body); /* never write response body data */ +}; + +/* The following functions are defined in http_chunks.c */ +void Curl_httpchunk_init(struct Curl_easy *data, struct Curl_chunker *ch, + bool ignore_body); +void Curl_httpchunk_free(struct Curl_easy *data, struct Curl_chunker *ch); +void Curl_httpchunk_reset(struct Curl_easy *data, struct Curl_chunker *ch, + bool ignore_body); + +/* + * Read BODY bytes in HTTP/1.1 chunked encoding from `buf` and return + * the amount of bytes consumed. The actual response bytes and trailer + * headers are written out to the client. + * On success, this will consume all bytes up to the end of the response, + * e.g. the last chunk, has been processed. + * @param data the transfer involved + * @param ch the chunker instance keeping state across calls + * @param buf the response data + * @param blen amount of bytes in `buf` + * @param pconsumed on successful return, the number of bytes in `buf` + * consumed + * + * This function always uses ASCII hex values to accommodate non-ASCII hosts. + * For example, 0x0d and 0x0a are used instead of '\r' and '\n'. + */ +CURLcode Curl_httpchunk_read(struct Curl_easy *data, struct Curl_chunker *ch, + char *buf, size_t blen, size_t *pconsumed); + +/** + * @return TRUE iff chunked decoded has finished successfully. + */ +bool Curl_httpchunk_is_done(struct Curl_easy *data, struct Curl_chunker *ch); + +extern const struct Curl_cwtype Curl_httpchunk_unencoder; + +extern const struct Curl_crtype Curl_httpchunk_encoder; + +/** + * Add a transfer-encoding "chunked" reader to the transfers reader stack + */ +CURLcode Curl_httpchunk_add_reader(struct Curl_easy *data); + +#endif /* !CURL_DISABLE_HTTP */ + +#endif /* HEADER_CURL_HTTP_CHUNKS_H */ diff --git a/3rdparty/curl-8.21.0/lib/http_digest.c b/3rdparty/curl-8.21.0/lib/http_digest.c new file mode 100644 index 0000000000..25783d0969 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/http_digest.c @@ -0,0 +1,164 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_HTTP) && !defined(CURL_DISABLE_DIGEST_AUTH) + +#include "urldata.h" +#include "strcase.h" +#include "vauth/vauth.h" +#include "http_digest.h" +#include "curlx/strparse.h" + +/* Test example headers: + +WWW-Authenticate: Digest realm="testrealm", nonce="1053604598" +Proxy-Authenticate: Digest realm="testrealm", nonce="1053604598" + +*/ + +CURLcode Curl_input_digest(struct Curl_easy *data, + bool proxy, + const char *header) /* rest of the *-authenticate: + header */ +{ + /* Point to the correct struct with this */ + struct digestdata *digest; + + if(proxy) { + digest = &data->state.proxydigest; + } + else { + digest = &data->state.digest; + } + + if(!checkprefix("Digest", header) || !ISBLANK(header[6])) + return CURLE_AUTH_ERROR; + + header += strlen("Digest"); + curlx_str_passblanks(&header); + + return Curl_auth_decode_digest_http_message(header, digest); +} + +/* Flush the Digest state if it was created for a different origin or with + different credentials than the ones now in use, then link the current + ones. */ +static void digest_flush_stale(struct digestdata *digest, + struct Curl_peer *peer, + struct Curl_creds *creds) +{ + bool flush = FALSE; + if(digest->origin && !Curl_peer_same_destination(peer, digest->origin)) + flush = TRUE; + else if(digest->creds && !Curl_creds_same(creds, digest->creds)) + flush = TRUE; + + if(flush) + /* flush Digest state */ + Curl_auth_digest_cleanup(digest); + + Curl_peer_link(&digest->origin, peer); + Curl_creds_link(&digest->creds, creds); +} + +CURLcode Curl_output_digest(struct Curl_easy *data, + bool proxy, + const unsigned char *request, + const unsigned char *uripath) +{ + CURLcode result; + char *response; + size_t len; + bool have_chlg; + + /* Point to the address of the pointer that holds the string to send to the + server, which is for a plain host or for an HTTP proxy */ + char **allocuserpwd; + + /* Point to the name and password for this */ + struct Curl_creds *creds = NULL; + + /* Point to the correct struct with this */ + struct digestdata *digest; + struct auth *authp; + + if(proxy) { +#ifdef CURL_DISABLE_PROXY + return CURLE_NOT_BUILT_IN; +#else + digest = &data->state.proxydigest; + digest_flush_stale(digest, data->conn->http_proxy.peer, + data->conn->http_proxy.creds); + allocuserpwd = &data->req.hd_proxy_auth; + creds = data->conn->http_proxy.creds; + authp = &data->state.authproxy; +#endif + } + else { + DEBUGASSERT(data->state.origin); + digest = &data->state.digest; + digest_flush_stale(digest, data->state.origin, data->state.creds); + allocuserpwd = &data->req.hd_auth; + creds = data->state.creds; + authp = &data->state.authhost; + } + + curlx_safefree(*allocuserpwd); + +#ifdef USE_WINDOWS_SSPI + have_chlg = !!digest->input_token; +#else + have_chlg = !!digest->nonce; +#endif + + if(!have_chlg) { + authp->done = FALSE; + return CURLE_OK; + } + + result = Curl_auth_create_digest_http_message(data, creds, request, + uripath, digest, + &response, &len); + if(result) + return result; + + *allocuserpwd = curl_maprintf("%sAuthorization: Digest %s\r\n", + proxy ? "Proxy-" : "", response); + curlx_free(response); + if(!*allocuserpwd) + return CURLE_OUT_OF_MEMORY; + + authp->done = TRUE; + + return CURLE_OK; +} + +void Curl_http_auth_cleanup_digest(struct Curl_easy *data) +{ + Curl_auth_digest_cleanup(&data->state.digest); + Curl_auth_digest_cleanup(&data->state.proxydigest); +} + +#endif diff --git a/3rdparty/curl-8.21.0/lib/http_digest.h b/3rdparty/curl-8.21.0/lib/http_digest.h new file mode 100644 index 0000000000..5f797310fd --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/http_digest.h @@ -0,0 +1,44 @@ +#ifndef HEADER_CURL_HTTP_DIGEST_H +#define HEADER_CURL_HTTP_DIGEST_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_HTTP) && !defined(CURL_DISABLE_DIGEST_AUTH) + +/* this is for digest header input */ +CURLcode Curl_input_digest(struct Curl_easy *data, + bool proxy, const char *header); + +/* this is for creating digest header output */ +CURLcode Curl_output_digest(struct Curl_easy *data, + bool proxy, + const unsigned char *request, + const unsigned char *uripath); + +void Curl_http_auth_cleanup_digest(struct Curl_easy *data); + +#endif /* !CURL_DISABLE_HTTP && !CURL_DISABLE_DIGEST_AUTH */ + +#endif /* HEADER_CURL_HTTP_DIGEST_H */ diff --git a/3rdparty/curl-8.21.0/lib/http_negotiate.c b/3rdparty/curl-8.21.0/lib/http_negotiate.c new file mode 100644 index 0000000000..891369b5bc --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/http_negotiate.c @@ -0,0 +1,266 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_HTTP) && defined(USE_SPNEGO) + +#include "urldata.h" +#include "cfilters.h" +#include "curl_trc.h" +#include "http_negotiate.h" +#include "vauth/vauth.h" +#include "vtls/vtls.h" +#include "curlx/strparse.h" + + +static void http_auth_nego_reset(struct connectdata *conn, + struct negotiatedata *neg_ctx, + bool proxy) +{ + if(proxy) + conn->proxy_negotiate_state = GSS_AUTHNONE; + else { + conn->http_negotiate_state = GSS_AUTHNONE; + Curl_peer_unlink(&conn->creds_origin); + Curl_creds_unlink(&conn->creds); + } + if(neg_ctx) + Curl_auth_cleanup_spnego(neg_ctx); +} + +CURLcode Curl_input_negotiate(struct Curl_easy *data, struct connectdata *conn, + bool proxy, const char *header) +{ + CURLcode result; + size_t len; + + /* Point to credentials and host */ + struct Curl_creds *creds = NULL; + const char *host; + + /* Point to the correct struct with this */ + struct negotiatedata *neg_ctx; + curlnegotiate state; + + if(proxy) { +#ifndef CURL_DISABLE_PROXY + creds = conn->http_proxy.creds; + host = conn->http_proxy.peer->hostname; + state = conn->proxy_negotiate_state; +#else + return CURLE_NOT_BUILT_IN; +#endif + } + else { + creds = data->state.creds; + host = data->state.origin->hostname; + state = conn->http_negotiate_state; + } + + neg_ctx = Curl_auth_nego_get(conn, proxy); + if(!neg_ctx) + return CURLE_OUT_OF_MEMORY; + + /* Obtain the input token, if any */ + header += strlen("Negotiate"); + curlx_str_passblanks(&header); + + len = strlen(header); + neg_ctx->havenegdata = len != 0; + if(!len) { + if(state == GSS_AUTHSUCC) { + infof(data, "Negotiate auth restarted"); + http_auth_nego_reset(conn, neg_ctx, proxy); + } + else if(state != GSS_AUTHNONE) { + /* The server rejected our authentication and has not supplied any more + negotiation mechanisms */ + http_auth_nego_reset(conn, neg_ctx, proxy); + return CURLE_LOGIN_DENIED; + } + } + + /* Supports SSL channel binding for Windows ISS extended protection */ +#if defined(USE_WINDOWS_SSPI) && defined(SECPKG_ATTR_ENDPOINT_BINDINGS) + neg_ctx->sslContext = conn->sslContext; +#endif + /* Check if the connection is using SSL and get the channel binding data */ +#ifdef GSS_C_CHANNEL_BOUND_FLAG +#ifdef USE_SSL + curlx_dyn_init(&neg_ctx->channel_binding_data, SSL_CB_MAX_SIZE + 1); + if(Curl_conn_is_ssl(conn, FIRSTSOCKET)) { + result = Curl_ssl_get_channel_binding(data, FIRSTSOCKET, + &neg_ctx->channel_binding_data); + if(result) { + http_auth_nego_reset(conn, neg_ctx, proxy); + return result; + } + } +#else + curlx_dyn_init(&neg_ctx->channel_binding_data, 1); +#endif /* USE_SSL */ +#endif /* GSS_C_CHANNEL_BOUND_FLAG */ + + /* Initialize the security context and decode our challenge */ + result = Curl_auth_decode_spnego_message(data, creds, "HTTP", + host, header, neg_ctx); + +#ifdef GSS_C_CHANNEL_BOUND_FLAG + curlx_dyn_free(&neg_ctx->channel_binding_data); +#endif + + if(result) + http_auth_nego_reset(conn, neg_ctx, proxy); + + if(!result && !proxy) { + /* Start it up. From this time onwards, the connection is tied + * tp the credentials used. */ + if(conn->creds_origin && + !Curl_peer_equal(conn->creds_origin, data->state.origin)) { + DEBUGASSERT(0); /* should not happen. */ + return CURLE_FAILED_INIT; + } + if(conn->creds && !Curl_creds_same(creds, conn->creds)) { + DEBUGASSERT(0); /* should not happen. */ + return CURLE_FAILED_INIT; + } + Curl_peer_link(&conn->creds_origin, data->state.origin); + Curl_creds_link(&conn->creds, creds); + } + + return result; +} + +CURLcode Curl_output_negotiate(struct Curl_easy *data, + struct connectdata *conn, bool proxy) +{ + struct negotiatedata *neg_ctx; + struct auth *authp; + curlnegotiate *state; + char *base64 = NULL; + size_t len = 0; + char *userp; + CURLcode result; + + if(proxy) { +#ifndef CURL_DISABLE_PROXY + authp = &data->state.authproxy; + state = &conn->proxy_negotiate_state; +#else + return CURLE_NOT_BUILT_IN; +#endif + } + else { + authp = &data->state.authhost; + state = &conn->http_negotiate_state; + } + neg_ctx = Curl_auth_nego_get(conn, proxy); + if(!neg_ctx) + return CURLE_OUT_OF_MEMORY; + + authp->done = FALSE; + + if(*state == GSS_AUTHRECV) { + if(neg_ctx->havenegdata) { + neg_ctx->havemultiplerequests = TRUE; + } + } + else if(*state == GSS_AUTHSUCC) { + if(!neg_ctx->havenoauthpersist) { + neg_ctx->noauthpersist = !neg_ctx->havemultiplerequests; + } + } + + if(neg_ctx->noauthpersist || + (*state != GSS_AUTHDONE && *state != GSS_AUTHSUCC)) { + + if(neg_ctx->noauthpersist && *state == GSS_AUTHSUCC) { + infof(data, "Curl_output_negotiate, " + "no persistent authentication: cleanup existing context"); + http_auth_nego_reset(conn, neg_ctx, proxy); + } + if(!neg_ctx->context) { + result = Curl_input_negotiate(data, conn, proxy, "Negotiate"); + if(result == CURLE_AUTH_ERROR) { + /* negotiate auth failed, let's continue unauthenticated to stay + * compatible with the behavior before curl-7_64_0-158-g6c6035532 */ + authp->done = TRUE; + return CURLE_OK; + } + else if(result) + return result; + } + + result = Curl_auth_create_spnego_message(neg_ctx, &base64, &len); + if(result) + return result; + + userp = curl_maprintf("%sAuthorization: Negotiate %s\r\n", + proxy ? "Proxy-" : "", base64); + + if(proxy) { +#ifndef CURL_DISABLE_PROXY + curlx_free(data->req.hd_proxy_auth); + data->req.hd_proxy_auth = userp; +#endif + } + else { + curlx_free(data->req.hd_auth); + data->req.hd_auth = userp; + } + + curlx_free(base64); + + if(!userp) { + return CURLE_OUT_OF_MEMORY; + } + + *state = GSS_AUTHSENT; +#ifdef HAVE_GSSAPI + if(neg_ctx->status == GSS_S_COMPLETE || + neg_ctx->status == GSS_S_CONTINUE_NEEDED) { + *state = GSS_AUTHDONE; + } +#else +#ifdef USE_WINDOWS_SSPI + if(neg_ctx->status == SEC_E_OK || + neg_ctx->status == SEC_I_CONTINUE_NEEDED) { + *state = GSS_AUTHDONE; + } +#endif +#endif + } + + if(*state == GSS_AUTHDONE || *state == GSS_AUTHSUCC) { + /* connection is already authenticated, + * do not send a header in future requests */ + authp->done = TRUE; + } + + neg_ctx->havenegdata = FALSE; + + return CURLE_OK; +} + +#endif /* !CURL_DISABLE_HTTP && USE_SPNEGO */ diff --git a/3rdparty/curl-8.21.0/lib/http_negotiate.h b/3rdparty/curl-8.21.0/lib/http_negotiate.h new file mode 100644 index 0000000000..6c285f152f --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/http_negotiate.h @@ -0,0 +1,40 @@ +#ifndef HEADER_CURL_HTTP_NEGOTIATE_H +#define HEADER_CURL_HTTP_NEGOTIATE_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_HTTP) && defined(USE_SPNEGO) + +/* this is for Negotiate header input */ +CURLcode Curl_input_negotiate(struct Curl_easy *data, struct connectdata *conn, + bool proxy, const char *header); + +/* this is for creating Negotiate header output */ +CURLcode Curl_output_negotiate(struct Curl_easy *data, + struct connectdata *conn, bool proxy); + +#endif + +#endif /* HEADER_CURL_HTTP_NEGOTIATE_H */ diff --git a/3rdparty/curl-8.21.0/lib/http_ntlm.c b/3rdparty/curl-8.21.0/lib/http_ntlm.c new file mode 100644 index 0000000000..dc9911fdac --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/http_ntlm.c @@ -0,0 +1,255 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_HTTP) && defined(USE_NTLM) + +/* + * NTLM details: + * + * https://davenport.sourceforge.net/ntlm.html + * https://www.innovation.ch/java/ntlm.html + */ + +#include "urldata.h" +#include "curl_trc.h" +#include "strcase.h" +#include "http_ntlm.h" +#include "curl_ntlm_core.h" +#include "curlx/base64.h" +#include "vauth/vauth.h" +#include "url.h" +#include "curlx/strparse.h" + +/* SSL backend-specific #if branches in this file must be kept in the order + documented in curl_ntlm_core. */ +#ifdef USE_WINDOWS_SSPI +#include "curl_sspi.h" +#endif + +CURLcode Curl_input_ntlm(struct Curl_easy *data, + bool proxy, /* if proxy or not */ + const char *header) /* rest of the www-authenticate: + header */ +{ + /* point to the correct struct with this */ + curlntlm *state; + CURLcode result = CURLE_OK; + struct connectdata *conn = data->conn; + + state = proxy ? &conn->proxy_ntlm_state : &conn->http_ntlm_state; + + if(checkprefix("NTLM", header)) { + struct ntlmdata *ntlm = Curl_auth_ntlm_get(conn, proxy); + if(!ntlm) + return CURLE_OUT_OF_MEMORY; + + header += strlen("NTLM"); + curlx_str_passblanks(&header); + if(*header) { + unsigned char *hdr; + size_t hdrlen; + + result = curlx_base64_decode(header, &hdr, &hdrlen); + if(!result) { + struct bufref hdrbuf; + + Curl_bufref_init(&hdrbuf); + Curl_bufref_set(&hdrbuf, hdr, hdrlen, curl_free); + result = Curl_auth_decode_ntlm_type2_message(data, &hdrbuf, ntlm); + Curl_bufref_free(&hdrbuf); + } + if(result) + return result; + + *state = NTLMSTATE_TYPE2; /* We got a type-2 message */ + } + else { + if(*state == NTLMSTATE_LAST) { + infof(data, "NTLM auth restarted"); + Curl_auth_ntlm_remove(conn, proxy); + } + else if(*state == NTLMSTATE_TYPE3) { + infof(data, "NTLM handshake rejected"); + Curl_auth_ntlm_remove(conn, proxy); + Curl_peer_unlink(&conn->creds_origin); + Curl_creds_unlink(&conn->creds); + *state = NTLMSTATE_NONE; + return CURLE_REMOTE_ACCESS_DENIED; + } + else if(*state >= NTLMSTATE_TYPE1) { + infof(data, "NTLM handshake failure (internal error)"); + return CURLE_REMOTE_ACCESS_DENIED; + } + + *state = NTLMSTATE_TYPE1; /* We should send away a type-1 */ + } + } + + return result; +} + +/* + * This is for creating NTLM header output + */ +CURLcode Curl_output_ntlm(struct Curl_easy *data, bool proxy) +{ + char *base64 = NULL; + size_t len = 0; + CURLcode result = CURLE_OK; + struct bufref ntlmmsg; + + /* point to the address of the pointer that holds the string to send to the + server, which is for a plain host or for an HTTP proxy */ + char **allocuserpwd; + + /* point to credentials and host */ + struct Curl_creds *creds = NULL; + const char *hostname = NULL; + + /* point to the correct struct with this */ + struct ntlmdata *ntlm; + curlntlm *state; + struct auth *authp; + struct connectdata *conn = data->conn; + + DEBUGASSERT(conn); + DEBUGASSERT(data); + + if(proxy) { +#ifndef CURL_DISABLE_PROXY + allocuserpwd = &data->req.hd_proxy_auth; + creds = conn->http_proxy.creds; + hostname = conn->http_proxy.peer->hostname; + state = &conn->proxy_ntlm_state; + authp = &data->state.authproxy; +#else + return CURLE_NOT_BUILT_IN; +#endif + } + else { + allocuserpwd = &data->req.hd_auth; + creds = data->state.creds; + hostname = data->state.origin->hostname; + state = &conn->http_ntlm_state; + authp = &data->state.authhost; + } + + ntlm = Curl_auth_ntlm_get(conn, proxy); + if(!ntlm) + return CURLE_OUT_OF_MEMORY; + authp->done = FALSE; + +#ifdef USE_WINDOWS_SSPI + if(!Curl_pSecFn) { + /* not thread-safe and leaks - use curl_global_init() to avoid */ + result = Curl_sspi_global_init(); + if(!Curl_pSecFn) + return result; + } +#ifdef SECPKG_ATTR_ENDPOINT_BINDINGS + ntlm->sslContext = conn->sslContext; +#endif +#endif + + Curl_bufref_init(&ntlmmsg); + + /* connection is already authenticated, do not send a header in future + * requests so go directly to NTLMSTATE_LAST */ + if(*state == NTLMSTATE_TYPE3) + *state = NTLMSTATE_LAST; + + switch(*state) { + case NTLMSTATE_TYPE1: + default: /* for the weird cases we (re)start here */ + if(!proxy) { + /* Start it up. From this time onwards, the connection is tied + * tp the credentials used. */ + if(conn->creds_origin && + !Curl_peer_equal(conn->creds_origin, data->state.origin)) { + DEBUGASSERT(0); /* should not happen. */ + return CURLE_FAILED_INIT; + } + if(conn->creds && !Curl_creds_same(creds, conn->creds)) { + DEBUGASSERT(0); /* should not happen. */ + return CURLE_FAILED_INIT; + } + Curl_peer_link(&conn->creds_origin, data->state.origin); + Curl_creds_link(&conn->creds, creds); + } + result = Curl_auth_create_ntlm_type1_message(data, creds, "HTTP", + hostname, ntlm, &ntlmmsg); + if(!result) { + DEBUGASSERT(Curl_bufref_len(&ntlmmsg) != 0); + result = curlx_base64_encode(Curl_bufref_uptr(&ntlmmsg), + Curl_bufref_len(&ntlmmsg), &base64, &len); + if(!result) { + curlx_free(*allocuserpwd); + *allocuserpwd = curl_maprintf("%sAuthorization: NTLM %s\r\n", + proxy ? "Proxy-" : "", base64); + curlx_free(base64); + if(!*allocuserpwd) + result = CURLE_OUT_OF_MEMORY; + } + } + break; + + case NTLMSTATE_TYPE2: + /* We already received the type-2 message, create a type-3 message */ + result = Curl_auth_create_ntlm_type3_message(data, creds, ntlm, &ntlmmsg); + if(!result && Curl_bufref_len(&ntlmmsg)) { + result = curlx_base64_encode(Curl_bufref_uptr(&ntlmmsg), + Curl_bufref_len(&ntlmmsg), &base64, &len); + if(!result) { + curlx_free(*allocuserpwd); + *allocuserpwd = curl_maprintf("%sAuthorization: NTLM %s\r\n", + proxy ? "Proxy-" : "", base64); + curlx_free(base64); + if(!*allocuserpwd) + result = CURLE_OUT_OF_MEMORY; + else { + *state = NTLMSTATE_TYPE3; /* we send a type-3 */ + authp->done = TRUE; + } + } + } + break; + + case NTLMSTATE_LAST: + /* since this is a little artificial in that this is used without any + outgoing auth headers being set, we need to set the bit by force */ + if(proxy) + data->info.proxyauthpicked = CURLAUTH_NTLM; + else + data->info.httpauthpicked = CURLAUTH_NTLM; + curlx_safefree(*allocuserpwd); + authp->done = TRUE; + break; + } + Curl_bufref_free(&ntlmmsg); + + return result; +} + +#endif /* !CURL_DISABLE_HTTP && USE_NTLM */ diff --git a/3rdparty/curl-8.21.0/lib/http_ntlm.h b/3rdparty/curl-8.21.0/lib/http_ntlm.h new file mode 100644 index 0000000000..ff5218d89f --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/http_ntlm.h @@ -0,0 +1,39 @@ +#ifndef HEADER_CURL_HTTP_NTLM_H +#define HEADER_CURL_HTTP_NTLM_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_HTTP) && defined(USE_NTLM) + +/* this is for NTLM header input */ +CURLcode Curl_input_ntlm(struct Curl_easy *data, bool proxy, + const char *header); + +/* this is for creating NTLM header output */ +CURLcode Curl_output_ntlm(struct Curl_easy *data, bool proxy); + +#endif + +#endif /* HEADER_CURL_HTTP_NTLM_H */ diff --git a/3rdparty/curl-8.21.0/lib/http_proxy.c b/3rdparty/curl-8.21.0/lib/http_proxy.c new file mode 100644 index 0000000000..d019796b53 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/http_proxy.c @@ -0,0 +1,775 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "http_proxy.h" + +#if !defined(CURL_DISABLE_HTTP) && !defined(CURL_DISABLE_PROXY) + +#include "curl_trc.h" +#include "http.h" +#include "url.h" +#include "cfilters.h" +#include "cf-h1-proxy.h" +#include "cf-h2-proxy.h" +#include "connect.h" +#include "vauth/vauth.h" +#include "vquic/vquic.h" +#include "curlx/strparse.h" + +static CURLcode dynhds_add_custom(struct Curl_easy *data, + bool is_connect, int httpversion, + bool is_udp, struct dynhds *hds) +{ + struct connectdata *conn = data->conn; + struct curl_slist *h[2]; + struct curl_slist *headers; + int numlists = 1; /* by default */ + int i; + + enum Curl_proxy_use proxy; + + if(is_connect && !is_udp) + proxy = HEADER_CONNECT; + else if(is_connect && is_udp) + proxy = HEADER_CONNECT_UDP; + else + proxy = conn->bits.origin_is_proxy ? HEADER_PROXY : HEADER_SERVER; + + switch(proxy) { + case HEADER_SERVER: + h[0] = data->set.headers; + break; + case HEADER_PROXY: + h[0] = data->set.headers; + if(data->set.sep_headers) { + h[1] = data->set.proxyheaders; + numlists++; + } + break; + case HEADER_CONNECT: + if(data->set.sep_headers) + h[0] = data->set.proxyheaders; + else + h[0] = data->set.headers; + break; + case HEADER_CONNECT_UDP: + if(data->set.sep_headers) + h[0] = data->set.proxyheaders; + else + h[0] = data->set.headers; + break; + } + + /* loop through one or two lists */ + for(i = 0; i < numlists; i++) { + for(headers = h[i]; headers; headers = headers->next) { + struct Curl_str name; + const char *value = NULL; + size_t valuelen = 0; + const char *ptr = headers->data; + + /* There are 2 quirks in place for custom headers: + * 1. setting only 'name:' to suppress a header from being sent + * 2. setting only 'name;' to send an empty (illegal) header + */ + if(!curlx_str_cspn(&ptr, &name, ";:")) { + if(!curlx_str_single(&ptr, ':')) { + curlx_str_passblanks(&ptr); + if(*ptr) { + value = ptr; + valuelen = strlen(value); + } + else { + /* quirk #1, suppress this header */ + continue; + } + } + else if(!curlx_str_single(&ptr, ';')) { + curlx_str_passblanks(&ptr); + if(!*ptr) { + /* quirk #2, send an empty header */ + value = ""; + valuelen = 0; + } + else { + /* this may be used for something else in the future, + * ignore this for now */ + continue; + } + } + else + /* neither : nor ; in provided header value. We ignore this + * silently */ + continue; + } + else + /* no name, move on */ + continue; + + DEBUGASSERT(curlx_strlen(&name) && value); + if(data->state.aptr.host && + /* a Host: header was sent already, do not pass on any custom Host: + header as that will produce *two* in the same request! */ + curlx_str_casecompare(&name, "Host")) + ; + else if(data->state.httpreq == HTTPREQ_POST_FORM && + /* this header (extended by formdata.c) is sent later */ + curlx_str_casecompare(&name, "Content-Type")) + ; + else if(data->state.httpreq == HTTPREQ_POST_MIME && + /* this header is sent later */ + curlx_str_casecompare(&name, "Content-Type")) + ; + else if(data->req.authneg && + /* while doing auth neg, do not allow the custom length since + we will force length zero then */ + curlx_str_casecompare(&name, "Content-Length")) + ; + else if((httpversion >= 20) && + curlx_str_casecompare(&name, "Transfer-Encoding")) + ; + /* HTTP/2 and HTTP/3 do not support chunked requests */ + else if((curlx_str_casecompare(&name, "Authorization") || + curlx_str_casecompare(&name, "Cookie")) && + /* be careful of sending this potentially sensitive header to + other hosts */ + !Curl_auth_allowed_to_host(data)) + ; + else { + CURLcode result = + Curl_dynhds_add(hds, curlx_str(&name), curlx_strlen(&name), + value, valuelen); + if(result) + return result; + } + } + } + + return CURLE_OK; +} + +struct cf_proxy_ctx { + struct Curl_peer *peer; /* proxy */ + struct Curl_peer *tunnel_peer; /* tunnel destination */ + uint8_t proxytype; + uint8_t tunnel_transport; + BIT(sub_filter_installed); +}; + +static int proxy_http_ver_major(proxy_http_ver ver) +{ + switch(ver) { + case PROXY_HTTP_V1: + return 11; + case PROXY_HTTP_V2: + return 20; + case PROXY_HTTP_V3: + return 30; + } + return 0; +} + +static CURLcode http_proxy_create_CONNECT(struct httpreq **preq, + struct Curl_cfilter *cf, + struct Curl_easy *data, + struct Curl_peer *dest, + proxy_http_ver ver) +{ + char *authority = NULL; + int httpversion = proxy_http_ver_major(ver); + CURLcode result; + struct httpreq *req = NULL; + + authority = curl_maprintf("%s%s%s:%u", + dest->ipv6 ? "[" : "", + dest->hostname, + dest->ipv6 ? "]" : "", + dest->port); + if(!authority) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + result = Curl_http_req_make(&req, "CONNECT", sizeof("CONNECT") - 1, + NULL, 0, authority, strlen(authority), + NULL, 0); + if(result) + goto out; + + /* Setup the proxy-authorization header, if any */ + result = Curl_http_output_auth(data, cf->conn, req->method, HTTPREQ_GET, + req->authority, NULL, TRUE); + if(result) + goto out; + + /* If user is not overriding Host: header, we add for HTTP/1.x */ + if(ver == PROXY_HTTP_V1 && + !Curl_checkProxyheaders(data, cf->conn, STRCONST("Host"))) { + result = Curl_dynhds_cadd(&req->headers, "Host", authority); + if(result) + goto out; + } + + if(data->req.hd_proxy_auth) { + result = Curl_dynhds_h1_cadd_line(&req->headers, + data->req.hd_proxy_auth); + if(result) + goto out; + } + + if(!Curl_checkProxyheaders(data, cf->conn, STRCONST("User-Agent")) && + data->set.str[STRING_USERAGENT] && *data->set.str[STRING_USERAGENT]) { + result = Curl_dynhds_cadd(&req->headers, "User-Agent", + data->set.str[STRING_USERAGENT]); + if(result) + goto out; + } + + if(ver == PROXY_HTTP_V1 && + !Curl_checkProxyheaders(data, cf->conn, STRCONST("Proxy-Connection"))) { + result = Curl_dynhds_cadd(&req->headers, "Proxy-Connection", "Keep-Alive"); + if(result) + goto out; + } + + result = dynhds_add_custom(data, TRUE, httpversion, + FALSE, &req->headers); + +out: + if(result && req) { + Curl_http_req_free(req); + req = NULL; + } + curlx_free(authority); + *preq = req; + return result; +} + +static CURLcode http_proxy_create_CONNECTUDP(struct httpreq **preq, + struct Curl_cfilter *cf, + struct Curl_easy *data, + struct Curl_peer *dest, + proxy_http_ver ver) +{ + const char *proxy_scheme = "http"; + const char *proxy_host = cf->conn->http_proxy.peer->hostname; + int httpversion = proxy_http_ver_major(ver); + char *authority = NULL; + char *path = NULL; + char *encoded_host = NULL; + struct httpreq *req = NULL; + bool proxy_ipv6_ip; + CURLcode result; + + if(cf->conn->http_proxy.proxytype == CURLPROXY_HTTPS || + cf->conn->http_proxy.proxytype == CURLPROXY_HTTPS2 || + cf->conn->http_proxy.proxytype == CURLPROXY_HTTPS3) + proxy_scheme = "https"; + + proxy_ipv6_ip = cf->conn->http_proxy.peer->ipv6 != 0; + + authority = curl_maprintf("%s%s%s:%d", + proxy_ipv6_ip ? "[" : "", + proxy_host, + proxy_ipv6_ip ? "]" : "", + cf->conn->http_proxy.peer->port); + if(!authority) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + if(dest->ipv6) { + /* RFC 9298: colons in IPv6 addresses MUST be percent-encoded + * in the URI template (e.g. "2001:db8::1" -> "2001%3Adb8%3A%3A1") */ + const char *s = dest->hostname; + char *d; + size_t hlen = strlen(s); + encoded_host = curlx_malloc(hlen * 3 + 1); + if(!encoded_host) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + d = encoded_host; + while(*s) { + if(*s == ':') { + *d++ = '%'; + *d++ = '3'; + *d++ = 'A'; + } + else + *d++ = *s; + s++; + } + *d = '\0'; + path = curl_maprintf("/.well-known/masque/udp/%s/%u/", + encoded_host, (unsigned int)dest->port); + } + else { + path = curl_maprintf("/.well-known/masque/udp/%s/%u/", + dest->hostname, (unsigned int)dest->port); + } + + if(!path) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + if(ver == PROXY_HTTP_V1) { + result = Curl_http_req_make(&req, "GET", sizeof("GET")-1, + proxy_scheme, strlen(proxy_scheme), + authority, strlen(authority), + path, strlen(path)); + if(result) + goto out; + } + else if(ver == PROXY_HTTP_V2 || ver == PROXY_HTTP_V3) { + result = Curl_http_req_make(&req, "CONNECT", sizeof("CONNECT") - 1, + proxy_scheme, strlen(proxy_scheme), + authority, strlen(authority), + path, strlen(path)); + if(result) + goto out; + } + else { + result = CURLE_FAILED_INIT; + goto out; + } + + /* Setup the proxy-authorization header, if any */ + result = Curl_http_output_auth(data, cf->conn, req->method, HTTPREQ_GET, + req->authority, NULL, TRUE); + if(result) + goto out; + + /* If user is not overriding Host: header, we add for HTTP/1.x */ + if(ver == PROXY_HTTP_V1 && + !Curl_checkProxyheaders(data, cf->conn, STRCONST("Host"))) { + result = Curl_dynhds_cadd(&req->headers, "Host", authority); + if(result) + goto out; + } + + if(data->req.hd_proxy_auth) { + result = Curl_dynhds_h1_cadd_line(&req->headers, + data->req.hd_proxy_auth); + if(result) + goto out; + } + + if(ver == PROXY_HTTP_V1 && + !Curl_checkProxyheaders(data, cf->conn, STRCONST("User-Agent")) && + data->set.str[STRING_USERAGENT] && *data->set.str[STRING_USERAGENT]) { + result = Curl_dynhds_cadd(&req->headers, "User-Agent", + data->set.str[STRING_USERAGENT]); + if(result) + goto out; + } + + if(ver == PROXY_HTTP_V1 && + !Curl_checkProxyheaders(data, cf->conn, STRCONST("Proxy-Connection"))) { + result = Curl_dynhds_cadd(&req->headers, "Proxy-Connection", "Keep-Alive"); + if(result) + goto out; + } + + if(ver == PROXY_HTTP_V1) { + result = Curl_dynhds_cadd(&req->headers, "Connection", "Upgrade"); + if(result) + goto out; + + result = Curl_dynhds_cadd(&req->headers, "Upgrade", "connect-udp"); + if(result) + goto out; + + result = Curl_dynhds_cadd(&req->headers, "Capsule-Protocol", "?1"); + if(result) + goto out; + } + else { + result = Curl_dynhds_cadd(&req->headers, ":Protocol", "connect-udp"); + if(result) + goto out; + + if(ver >= PROXY_HTTP_V2) { + result = Curl_dynhds_cadd(&req->headers, "Capsule-Protocol", "?1"); + if(result) + goto out; + } + } + + result = dynhds_add_custom(data, TRUE, httpversion, + TRUE, &req->headers); + +out: + if(result && req) { + Curl_http_req_free(req); + req = NULL; + } + curlx_free(authority); + curlx_free(path); + curlx_free(encoded_host); + *preq = req; + return result; +} + +CURLcode Curl_http_proxy_create_tunnel_request( + struct httpreq **preq, struct Curl_cfilter *cf, + struct Curl_easy *data, struct Curl_peer *dest, + proxy_http_ver ver, bool udp_tunnel) +{ + CURLcode result; + + if(udp_tunnel) + result = http_proxy_create_CONNECTUDP(preq, cf, data, dest, ver); + else + result = http_proxy_create_CONNECT(preq, cf, data, dest, ver); + if(result) + return result; + + if(udp_tunnel) + infof(data, "Establishing %s proxy UDP tunnel to %s:%s", + (ver == PROXY_HTTP_V2) ? "HTTP/2" : + (ver == PROXY_HTTP_V3) ? "HTTP/3" : "HTTP", + data->state.up.hostname, data->state.up.port); + else + infof(data, "Establishing %s proxy tunnel to %s", + (ver == PROXY_HTTP_V2) ? "HTTP/2" : + (ver == PROXY_HTTP_V3) ? "HTTP/3" : "HTTP", + (*preq)->authority); + return CURLE_OK; +} + +CURLcode Curl_http_proxy_inspect_tunnel_response( + struct Curl_cfilter *cf, struct Curl_easy *data, + struct http_resp *resp, bool udp_tunnel, + proxy_inspect_result *presult) +{ + struct dynhds_entry *capsule_protocol = NULL; + struct dynhds_entry *auth_reply = NULL; + size_t i, header_count; + CURLcode result = CURLE_OK; + + DEBUGASSERT(resp); + + header_count = Curl_dynhds_count(&resp->headers); + if(udp_tunnel) + infof(data, "CONNECT-UDP Response Status %d", resp->status); + else + infof(data, "CONNECT Response Status %d", resp->status); + infof(data, "Response Headers (%zu total):", header_count); + for(i = 0; i < header_count; i++) { + struct dynhds_entry *entry = Curl_dynhds_getn(&resp->headers, i); + if(entry) + infof(data, " %s: %s", entry->name, entry->value); + } + + if(resp->status == 401) { + auth_reply = Curl_dynhds_cget(&resp->headers, "WWW-Authenticate"); + } + else if(resp->status == 407) { + auth_reply = Curl_dynhds_cget(&resp->headers, "Proxy-Authenticate"); + } + + if(auth_reply) { + CURL_TRC_CF(data, cf, "[0] CONNECT%s: fwd auth header '%s'", + udp_tunnel ? "-UDP" : "", auth_reply->value); + result = Curl_http_input_auth(data, resp->status == 407, + auth_reply->value); + if(result) + return result; + if(data->req.newurl) { + curlx_safefree(data->req.newurl); + *presult = PROXY_INSPECT_AUTH_RETRY; + return CURLE_OK; + } + } + + if(udp_tunnel) { + if(resp->status / 100 == 2) { + capsule_protocol = Curl_dynhds_cget(&resp->headers, + "capsule-protocol"); + if(capsule_protocol) { + if(!strncmp(capsule_protocol->value, "?1", 2) && + !capsule_protocol->value[2]) { + infof(data, "CONNECT-UDP tunnel established, response %d", + resp->status); + *presult = PROXY_INSPECT_OK; + return CURLE_OK; + } + failf(data, "Failed to establish CONNECT-UDP tunnel, response %d, " + "unsupported capsule-protocol value '%s'", + resp->status, capsule_protocol->value); + *presult = PROXY_INSPECT_FAILED; + return CURLE_COULDNT_CONNECT; + } + else { + /* NOTE proxies may not set capsule protocol in the headers */ + infof(data, "CONNECT-UDP tunnel established, response %d " + "but no capsule-protocol header found", resp->status); + *presult = PROXY_INSPECT_OK; + return CURLE_OK; + } + } + else { + failf(data, "Failed to establish CONNECT-UDP tunnel, " + "response %d", resp->status); + *presult = PROXY_INSPECT_FAILED; + return CURLE_COULDNT_CONNECT; + } + } + + if(resp->status / 100 == 2) { + infof(data, "CONNECT tunnel established, response %d", resp->status); + *presult = PROXY_INSPECT_OK; + return CURLE_OK; + } + + *presult = PROXY_INSPECT_FAILED; + return CURLE_COULDNT_CONNECT; +} + +static CURLcode http_proxy_cf_connect(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ + struct cf_proxy_ctx *ctx = cf->ctx; + CURLcode result; + bool udp_tunnel = TRNSPRT_IS_DGRAM(ctx->tunnel_transport); + const char *tunnel_type = udp_tunnel ? "CONNECT-UDP" : "CONNECT"; + + if(cf->connected) { + *done = TRUE; + return CURLE_OK; + } + + CURL_TRC_CF(data, cf, "%s", tunnel_type); +connect_sub: + /* in case of h3_proxy, cf->next will be NULL initially */ + if(cf->next) { + result = cf->next->cft->do_connect(cf->next, data, done); + if(result || !*done) + return result; + } + + *done = FALSE; + if(!ctx->sub_filter_installed) { + const char *alpn = NULL; + + /* in case of h3_proxy, cf->next will be NULL initially */ + if(cf->next) { + alpn = Curl_conn_cf_get_alpn_negotiated(cf->next, data); + } + + if(alpn) + infof(data, "%s: '%s' negotiated", tunnel_type, alpn); + else if(!alpn) { + /* No ALPN, proxytype rules. Fake ALPN */ + infof(data, "%s: no ALPN negotiated", tunnel_type); + switch(ctx->proxytype) { + case CURLPROXY_HTTP_1_0: + alpn = "http/1.0"; + break; + case CURLPROXY_HTTPS2: + alpn = "h2"; + break; + case CURLPROXY_HTTPS3: + alpn = "h3"; + break; + default: + alpn = "http/1.1"; + break; + } + } + + if(!strcmp(alpn, "http/1.0")) { + CURL_TRC_CF(data, cf, "installing subfilter for HTTP/1.0"); + result = Curl_cf_h1_proxy_insert_after(cf, data, ctx->tunnel_peer, 10, + udp_tunnel); + if(result) + goto out; + } + else if(!strcmp(alpn, "http/1.1")) { + int httpversion = (ctx->proxytype == CURLPROXY_HTTP_1_0) ? 10 : 11; + CURL_TRC_CF(data, cf, "installing subfilter for HTTP/1.%d", + httpversion % 10); + result = Curl_cf_h1_proxy_insert_after(cf, data, ctx->tunnel_peer, + httpversion, udp_tunnel); + if(result) + goto out; + } +#ifdef USE_NGHTTP2 + else if(!strcmp(alpn, "h2")) { + CURL_TRC_CF(data, cf, "installing subfilter for HTTP/2"); + result = Curl_cf_h2_proxy_insert_after(cf, data, ctx->tunnel_peer, + udp_tunnel); + if(result) + goto out; + } +#endif /* USE_NGHTTP2 */ +#if defined(USE_PROXY_HTTP3) && defined(USE_NGHTTP3) && \ + defined(USE_NGTCP2) && defined(USE_OPENSSL) + else if(!strcmp(alpn, "h3")) { + CURL_TRC_CF(data, cf, "installing subfilter for HTTP/3"); + result = Curl_cf_h3_proxy_insert_after(cf, data, ctx->peer, ctx->peer, + ctx->tunnel_peer, + ctx->tunnel_transport); + if(result) + goto out; + } +#endif /* USE_PROXY_HTTP3 && USE_NGHTTP3 && USE_NGTCP2 && USE_OPENSSL */ + else { + failf(data, "%s: negotiated ALPN '%s' not supported", tunnel_type, alpn); + result = CURLE_COULDNT_CONNECT; + goto out; + } + + ctx->sub_filter_installed = TRUE; + /* after we installed the filter "below" us, we call connect + * on out sub-chain again. + */ + goto connect_sub; + } + else { + /* subchain connected and we had already installed the protocol filter. + * This means the protocol tunnel is established, we are done. */ + DEBUGASSERT(ctx->sub_filter_installed); + result = CURLE_OK; + } + +out: + if(!result) { + cf->connected = TRUE; + *done = TRUE; + } + return result; +} + +static CURLcode cf_http_proxy_query(struct Curl_cfilter *cf, + struct Curl_easy *data, + int query, int *pres1, void *pres2) +{ + struct cf_proxy_ctx *ctx = cf->ctx; + switch(query) { + case CF_QUERY_HOST_PORT: + *pres1 = (int)ctx->tunnel_peer->port; + *((const char **)pres2) = ctx->tunnel_peer->hostname; + return CURLE_OK; + case CF_QUERY_ALPN_NEGOTIATED: { + const char **palpn = pres2; + DEBUGASSERT(palpn); + *palpn = NULL; + return CURLE_OK; + } + default: + break; + } + return cf->next ? + cf->next->cft->query(cf->next, data, query, pres1, pres2) : + CURLE_UNKNOWN_OPTION; +} + +static void cf_https_proxy_ctx_free(struct cf_proxy_ctx *ctx) +{ + if(ctx) { + Curl_peer_unlink(&ctx->peer); + Curl_peer_unlink(&ctx->tunnel_peer); + curlx_free(ctx); + } +} + +static void http_proxy_cf_destroy(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_proxy_ctx *ctx = cf->ctx; + if(ctx) { + CURL_TRC_CF(data, cf, "destroy"); + cf_https_proxy_ctx_free(ctx); + } +} + +struct Curl_cftype Curl_cft_http_proxy = { + "HTTP-PROXY", + CF_TYPE_IP_CONNECT | CF_TYPE_PROXY | CF_TYPE_SETUP, + 0, + http_proxy_cf_destroy, + http_proxy_cf_connect, + Curl_cf_def_shutdown, + Curl_cf_def_adjust_pollset, + Curl_cf_def_data_pending, + Curl_cf_def_send, + Curl_cf_def_recv, + Curl_cf_def_cntrl, + Curl_cf_def_conn_is_alive, + Curl_cf_def_conn_keep_alive, + cf_http_proxy_query, +}; + +CURLcode Curl_cf_http_proxy_insert_after(struct Curl_cfilter *cf_at, + struct Curl_easy *data, + struct Curl_peer *peer, + struct Curl_peer *tunnel_peer, + uint8_t tunnel_transport, + uint8_t proxytype) +{ + struct Curl_cfilter *cf; + struct cf_proxy_ctx *ctx = NULL; + CURLcode result; + + (void)data; + if(!peer || !tunnel_peer) + return CURLE_FAILED_INIT; + + ctx = curlx_calloc(1, sizeof(*ctx)); + if(!ctx) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + Curl_peer_link(&ctx->peer, peer); + Curl_peer_link(&ctx->tunnel_peer, tunnel_peer); + ctx->proxytype = proxytype; + ctx->tunnel_transport = tunnel_transport; + + result = Curl_cf_create(&cf, &Curl_cft_http_proxy, ctx); + if(result) + goto out; + ctx = NULL; + Curl_conn_cf_insert_after(cf_at, cf); + +out: + cf_https_proxy_ctx_free(ctx); + return result; +} + +uint8_t Curl_http_proxy_transport(uint8_t proxytype) +{ + switch(proxytype) { + case CURLPROXY_HTTPS3: + return TRNSPRT_QUIC; + default: + return TRNSPRT_TCP; + } +} + +#endif /* !CURL_DISABLE_HTTP && !CURL_DISABLE_PROXY */ diff --git a/3rdparty/curl-8.21.0/lib/http_proxy.h b/3rdparty/curl-8.21.0/lib/http_proxy.h new file mode 100644 index 0000000000..86c9088093 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/http_proxy.h @@ -0,0 +1,82 @@ +#ifndef HEADER_CURL_HTTP_PROXY_H +#define HEADER_CURL_HTTP_PROXY_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_PROXY) && !defined(CURL_DISABLE_HTTP) + +#include "urldata.h" + +enum Curl_proxy_use { + HEADER_SERVER, /* direct to server */ + HEADER_PROXY, /* regular request to proxy */ + HEADER_CONNECT, /* sending CONNECT to a proxy */ + HEADER_CONNECT_UDP /* sending CONNECT-UDP to a proxy */ +}; + +/* HTTP version for proxy tunnel request creation */ +typedef enum { + PROXY_HTTP_V1 = 1, + PROXY_HTTP_V2 = 2, + PROXY_HTTP_V3 = 3 +} proxy_http_ver; + +/* Result from inspecting a proxy tunnel response */ +typedef enum { + PROXY_INSPECT_OK, /* Tunnel established */ + PROXY_INSPECT_FAILED, /* Tunnel failed */ + PROXY_INSPECT_AUTH_RETRY /* Retry with auth */ +} proxy_inspect_result; + +/* Create CONNECT or CONNECT-UDP request */ +CURLcode Curl_http_proxy_create_tunnel_request( + struct httpreq **preq, struct Curl_cfilter *cf, + struct Curl_easy *data, struct Curl_peer *dest, + proxy_http_ver ver, bool udp_tunnel); + +/* Inspect tunnel response for H2/H3 proxy (capsule-protocol, auth) */ +struct http_resp; +CURLcode Curl_http_proxy_inspect_tunnel_response( + struct Curl_cfilter *cf, struct Curl_easy *data, + struct http_resp *resp, bool udp_tunnel, + proxy_inspect_result *presult); + +/* Default proxy timeout in milliseconds */ +#define PROXY_TIMEOUT (3600 * 1000) + +CURLcode Curl_cf_http_proxy_insert_after(struct Curl_cfilter *cf_at, + struct Curl_easy *data, + struct Curl_peer *peer, + struct Curl_peer *tunnel_peer, + uint8_t tunnel_transport, + uint8_t proxytype); + +extern struct Curl_cftype Curl_cft_http_proxy; + +uint8_t Curl_http_proxy_transport(uint8_t proxytype); + +#endif /* !CURL_DISABLE_PROXY && !CURL_DISABLE_HTTP */ + +#endif /* HEADER_CURL_HTTP_PROXY_H */ diff --git a/3rdparty/curl-8.21.0/lib/httpsrr.c b/3rdparty/curl-8.21.0/lib/httpsrr.c new file mode 100644 index 0000000000..53647b81ed --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/httpsrr.c @@ -0,0 +1,311 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_HTTPSRR + +#include "urldata.h" +#include "httpsrr.h" +#include "connect.h" +#include "curl_trc.h" +#include "curlx/strdup.h" +#include "curlx/inet_ntop.h" + +static CURLcode httpsrr_decode_alpn(const uint8_t *cp, size_t len, + unsigned char *alpns) +{ + /* + * The wire-format value for "alpn" consists of at least one alpn-id + * prefixed by its length as a single octet, and these length-value pairs + * are concatenated to form the SvcParamValue. These pairs MUST exactly fill + * the SvcParamValue; otherwise, the SvcParamValue is malformed. + */ + int idnum = 0; + + while(len > 0) { + size_t tlen = *cp++; + enum alpnid id; + len--; + if(tlen > len) + return CURLE_BAD_CONTENT_ENCODING; + + /* we only store ALPN ids we know about */ + id = Curl_alpn2alpnid(cp, tlen); + if(id != ALPN_none) { + if(idnum == MAX_HTTPSRR_ALPNS) + break; + if(idnum && memchr(alpns, id, idnum)) + /* this ALPN id is already stored */ + ; + else + alpns[idnum++] = (unsigned char)id; + } + cp += tlen; + len -= tlen; + } + if(idnum < MAX_HTTPSRR_ALPNS) + alpns[idnum] = ALPN_none; /* terminate the list */ + return CURLE_OK; +} + +#ifdef CURLVERBOSE + +static CURLcode httpsrr_print_addr(struct dynbuf *dyn, + int ai_family, + const uint8_t *addr, + size_t total_len) +{ + char buf[MAX_IPADR_LEN]; + size_t i, alen = (ai_family == AF_INET6) ? 16 : 4; + const char *sep = ""; + CURLcode result = CURLE_OK; + + for(i = 0; (i < (total_len / alen)) && !result; ++i) { + if(!curlx_inet_ntop(ai_family, addr + (i * alen), buf, sizeof(buf))) + result = curlx_dyn_add(dyn, ""); + else + result = curlx_dyn_addf(dyn, "%s%s", sep, buf); + sep = ","; + } + return result; +} + +void Curl_httpsrr_trace(struct Curl_easy *data, + struct Curl_https_rrinfo *rr) +{ + struct dynbuf tmp; + CURLcode result; + + if(!rr || !rr->complete) { + CURL_TRC_DNS(data, "[HTTPS-RR] not available"); + return; + } + curlx_dyn_init(&tmp, 1024); + result = Curl_httpsrr_print(&tmp, rr); + if(!result) + CURL_TRC_DNS(data, "HTTPS-RR: %s", curlx_dyn_ptr(&tmp)); + else + CURL_TRC_DNS(data, "Error printing HTTPS-RR information"); + curlx_dyn_free(&tmp); +} + +CURLcode Curl_httpsrr_print(struct dynbuf *tmp, + struct Curl_https_rrinfo *rr) +{ + CURLcode result; + int i; + + curlx_dyn_reset(tmp); + result = curlx_dyn_addf(tmp, "%u %s", rr->priority, + rr->target ? rr->target : "."); + if(!result && rr->mandatory) + result = curlx_dyn_add(tmp, " mandatory-keys(ignored)"); + if(!result && rr->alpns[0]) { + const char *sep = "", *name; + result = curlx_dyn_add(tmp, " alpn="); + for(i = 0; !result && (i < 4); ++i) { + switch(rr->alpns[i]) { + case ALPN_h1: + name = "http/1.1"; + break; + case ALPN_h2: + name = "h2"; + break; + case ALPN_h3: + name = "h3"; + break; + default: + name = NULL; + } + if(name) { + result = curlx_dyn_addf(tmp, "%s%s", sep, name); + sep = ","; + } + } + } + if(!result && rr->port_set) { + result = curlx_dyn_addf(tmp, " port=%u", rr->port); + } + if(!result && rr->no_def_alpn) + result = curlx_dyn_add(tmp, " no-default-alpn"); + if(!result && rr->ipv6hints_len) { + result = curlx_dyn_add(tmp, " ipv6hint="); + if(!result) + result = httpsrr_print_addr( + tmp, AF_INET6, rr->ipv6hints, rr->ipv6hints_len); + } + if(!result && rr->ipv4hints_len) { + result = curlx_dyn_add(tmp, " ipv4hint="); + if(!result) + result = httpsrr_print_addr( + tmp, AF_INET, rr->ipv4hints, rr->ipv4hints_len); + } + if(!result && rr->echconfiglist_len) + result = curlx_dyn_addf(tmp, " ech=<%zu bytes>", rr->echconfiglist_len); + + return result; +} + +#endif /* CURLVERBOSE */ + +CURLcode Curl_httpsrr_set(struct Curl_https_rrinfo *rr, + uint16_t rrkey, const uint8_t *val, size_t vlen) +{ + CURLcode result = CURLE_OK; + switch(rrkey) { + case HTTPS_RR_CODE_MANDATORY: + rr->mandatory = TRUE; + break; + case HTTPS_RR_CODE_ALPN: /* str_list */ + result = httpsrr_decode_alpn(val, vlen, rr->alpns); + break; + case HTTPS_RR_CODE_NO_DEF_ALPN: + if(vlen) /* no data */ + return CURLE_BAD_FUNCTION_ARGUMENT; + rr->no_def_alpn = TRUE; + break; + case HTTPS_RR_CODE_IPV4: /* addr4 list */ + if(!vlen || (vlen & 3)) /* the size must be 4-byte aligned */ + return CURLE_BAD_FUNCTION_ARGUMENT; + curlx_free(rr->ipv4hints); + rr->ipv4hints = curlx_memdup(val, vlen); + if(!rr->ipv4hints) + return CURLE_OUT_OF_MEMORY; + rr->ipv4hints_len = vlen; + break; + case HTTPS_RR_CODE_ECH: + if(!vlen) + return CURLE_BAD_FUNCTION_ARGUMENT; + curlx_free(rr->echconfiglist); + rr->echconfiglist = curlx_memdup(val, vlen); + if(!rr->echconfiglist) + return CURLE_OUT_OF_MEMORY; + rr->echconfiglist_len = vlen; + break; + case HTTPS_RR_CODE_IPV6: /* addr6 list */ + if(!vlen || (vlen & 15)) /* the size must be 16-byte aligned */ + return CURLE_BAD_FUNCTION_ARGUMENT; + curlx_free(rr->ipv6hints); + rr->ipv6hints = curlx_memdup(val, vlen); + if(!rr->ipv6hints) + return CURLE_OUT_OF_MEMORY; + rr->ipv6hints_len = vlen; + break; + case HTTPS_RR_CODE_PORT: + if(vlen != 2) + return CURLE_BAD_FUNCTION_ARGUMENT; + rr->port = (uint16_t)((val[0] << 8) | val[1]); + rr->port_set = TRUE; + break; + default: + /* unknown code */ + break; + } + return result; +} + +struct Curl_https_rrinfo *Curl_httpsrr_dup_move( + struct Curl_https_rrinfo *rrinfo) +{ + struct Curl_https_rrinfo *dup = curlx_memdup(rrinfo, sizeof(*rrinfo)); + if(dup) + memset(rrinfo, 0, sizeof(*rrinfo)); + return dup; +} + +void Curl_httpsrr_cleanup(struct Curl_https_rrinfo *rrinfo) +{ + curlx_safefree(rrinfo->target); + curlx_safefree(rrinfo->echconfiglist); + curlx_safefree(rrinfo->ipv4hints); + curlx_safefree(rrinfo->ipv6hints); + curlx_safefree(rrinfo->rrname); + rrinfo->complete = FALSE; +} + +bool Curl_httpsrr_applicable(struct Curl_easy *data, + const struct Curl_https_rrinfo *rr) +{ + if(!data->conn || !rr) + return FALSE; + return (!rr->target || !rr->target[0] || + (rr->target[0] == '.' && !rr->target[1])) && + (!rr->port_set || rr->port == data->conn->origin->port); +} + +#ifdef USE_ARES + +static CURLcode httpsrr_opt(const ares_dns_rr_t *rr, + ares_dns_rr_key_t key, size_t idx, + struct Curl_https_rrinfo *hinfo) +{ + const unsigned char *val = NULL; + unsigned short code; + size_t len = 0; + + code = ares_dns_rr_get_opt(rr, key, idx, &val, &len); + return Curl_httpsrr_set(hinfo, code, val, len); +} + +CURLcode Curl_httpsrr_from_ares(const ares_dns_record_t *dnsrec, + struct Curl_https_rrinfo *hinfo) +{ + CURLcode result = CURLE_OK; + size_t i; + + for(i = 0; i < ares_dns_record_rr_cnt(dnsrec, ARES_SECTION_ANSWER); i++) { + const char *target; + size_t opt; + const ares_dns_rr_t *rr = + ares_dns_record_rr_get_const(dnsrec, ARES_SECTION_ANSWER, i); + if(ares_dns_rr_get_type(rr) != ARES_REC_TYPE_HTTPS) + continue; + /* When SvcPriority is 0, the SVCB record is in AliasMode. Otherwise, it + is in ServiceMode */ + target = ares_dns_rr_get_str(rr, ARES_RR_HTTPS_TARGET); + if(target && target[0]) { + curlx_free(hinfo->target); + hinfo->target = curlx_strdup(target); + if(!hinfo->target) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + } + hinfo->priority = ares_dns_rr_get_u16(rr, ARES_RR_HTTPS_PRIORITY); + for(opt = 0; opt < ares_dns_rr_get_opt_cnt(rr, ARES_RR_HTTPS_PARAMS); + opt++) { + result = httpsrr_opt(rr, ARES_RR_HTTPS_PARAMS, opt, hinfo); + if(result) + break; + } + } +out: + hinfo->complete = !result; + curlx_safefree(hinfo->rrname); + return result; +} + +#endif /* USE_ARES */ + +#endif /* USE_HTTPSRR */ diff --git a/3rdparty/curl-8.21.0/lib/httpsrr.h b/3rdparty/curl-8.21.0/lib/httpsrr.h new file mode 100644 index 0000000000..2ee1beab3e --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/httpsrr.h @@ -0,0 +1,102 @@ +#ifndef HEADER_CURL_HTTPSRR_H +#define HEADER_CURL_HTTPSRR_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_ARES +#include +#endif + +#ifdef USE_HTTPSRR + +#define CURL_MAXLEN_HOST_NAME 253 +#define MAX_HTTPSRR_ALPNS 4 + +struct Curl_easy; +struct dynbuf; + +struct Curl_https_rrinfo { + char *rrname; /* if NULL, the same as the URL hostname */ + /* + * Fields from HTTPS RR. The only mandatory fields are priority and target. + * See https://datatracker.ietf.org/doc/html/rfc9460#section-14.3.2 + */ + char *target; + unsigned char *ipv4hints; /* keytag = 4 */ + size_t ipv4hints_len; + unsigned char *echconfiglist; /* keytag = 5 */ + size_t echconfiglist_len; + unsigned char *ipv6hints; /* keytag = 6 */ + size_t ipv6hints_len; + unsigned char alpns[MAX_HTTPSRR_ALPNS]; /* keytag = 1 */ + /* store parsed alpnid entries in the array, end with ALPN_none */ + uint16_t port; + uint16_t priority; + BIT(no_def_alpn); /* keytag = 2 */ + BIT(mandatory); /* keytag = 0 */ + BIT(port_set); /* port value has been assigned */ + BIT(complete); /* values have been successfully assigned */ +}; + +CURLcode Curl_httpsrr_set(struct Curl_https_rrinfo *rr, + uint16_t rrkey, const uint8_t *val, size_t vlen); + +struct Curl_https_rrinfo *Curl_httpsrr_dup_move( + struct Curl_https_rrinfo *rrinfo); + +void Curl_httpsrr_cleanup(struct Curl_https_rrinfo *rrinfo); + +/* TRUE if the record is applicable to the transfer and its connection. */ +bool Curl_httpsrr_applicable(struct Curl_easy *data, + const struct Curl_https_rrinfo *rr); + +/* + * Code points for DNS wire format SvcParams as per RFC 9460 + */ +#define HTTPS_RR_CODE_MANDATORY 0x00 +#define HTTPS_RR_CODE_ALPN 0x01 +#define HTTPS_RR_CODE_NO_DEF_ALPN 0x02 +#define HTTPS_RR_CODE_PORT 0x03 +#define HTTPS_RR_CODE_IPV4 0x04 +#define HTTPS_RR_CODE_ECH 0x05 +#define HTTPS_RR_CODE_IPV6 0x06 + +#ifdef USE_ARES +CURLcode Curl_httpsrr_from_ares(const ares_dns_record_t *dnsrec, + struct Curl_https_rrinfo *hinfo); +#endif /* USE_ARES */ + +#ifdef CURLVERBOSE +CURLcode Curl_httpsrr_print(struct dynbuf *tmp, + struct Curl_https_rrinfo *rr); +void Curl_httpsrr_trace(struct Curl_easy *data, + struct Curl_https_rrinfo *rr); +#else +#define Curl_httpsrr_trace(a, b) Curl_nop_stmt +#endif + +#endif /* USE_HTTPSRR */ + +#endif /* HEADER_CURL_HTTPSRR_H */ diff --git a/3rdparty/curl-8.21.0/lib/idn.c b/3rdparty/curl-8.21.0/lib/idn.c new file mode 100644 index 0000000000..b26f251d97 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/idn.c @@ -0,0 +1,386 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +/* + * IDN conversions + */ +#include "curl_setup.h" + +#include "urldata.h" +#include "curlx/strparse.h" +#include "idn.h" + +#ifdef USE_LIBIDN2 +#include + +#if defined(_WIN32) && defined(UNICODE) +#define IDN2_LOOKUP(name, host, flags) \ + idn2_lookup_u8((const uint8_t *)name, (uint8_t **)host, flags) +#else +#define IDN2_LOOKUP(name, host, flags) \ + idn2_lookup_ul((const char *)(name), (char **)(host), flags) +#endif +#endif /* USE_LIBIDN2 */ + +/* for macOS and iOS targets */ +#ifdef USE_APPLE_IDN +#include +#include +#include + +#define MAX_HOST_LENGTH 512 + +static CURLcode iconv_to_utf8(const char *in, size_t inlen, + char **out, size_t *outlen) +{ + iconv_t cd = iconv_open("UTF-8", nl_langinfo(CODESET)); + if(cd != (iconv_t)-1) { + size_t iconv_outlen = *outlen; + char *iconv_in = (char *)CURL_UNCONST(in); + size_t iconv_inlen = inlen; + size_t iconv_result = iconv(cd, &iconv_in, &iconv_inlen, + out, &iconv_outlen); + *outlen -= iconv_outlen; + iconv_close(cd); + if(iconv_result == (size_t)-1) { + /* !checksrc! disable ERRNOVAR 1 */ + if(errno == ENOMEM) + return CURLE_OUT_OF_MEMORY; + else + return CURLE_URL_MALFORMAT; + } + + return CURLE_OK; + } + else { + /* !checksrc! disable ERRNOVAR 1 */ + if(errno == ENOMEM) + return CURLE_OUT_OF_MEMORY; + else + return CURLE_FAILED_INIT; + } +} + +static CURLcode mac_idn_to_ascii(const char *in, char **out) +{ + size_t inlen = strlen(in); + if(inlen < MAX_HOST_LENGTH) { + char iconv_buffer[MAX_HOST_LENGTH] = { 0 }; + char *iconv_outptr = iconv_buffer; + size_t iconv_outlen = sizeof(iconv_buffer); + CURLcode iconv_result = iconv_to_utf8(in, inlen, + &iconv_outptr, &iconv_outlen); + if(!iconv_result) { + UErrorCode err = U_ZERO_ERROR; + UIDNA *idna = uidna_openUTS46( + UIDNA_CHECK_BIDI | UIDNA_NONTRANSITIONAL_TO_ASCII, &err); + if(!U_FAILURE(err)) { + UIDNAInfo info = UIDNA_INFO_INITIALIZER; + char buffer[MAX_HOST_LENGTH] = { 0 }; + (void)uidna_nameToASCII_UTF8(idna, iconv_buffer, (int)iconv_outlen, + buffer, sizeof(buffer) - 1, &info, &err); + uidna_close(idna); + if(!U_FAILURE(err) && !info.errors) { + *out = curlx_strdup(buffer); + if(*out) + return CURLE_OK; + else + return CURLE_OUT_OF_MEMORY; + } + } + } + else + return iconv_result; + } + return CURLE_URL_MALFORMAT; +} + +static CURLcode mac_ascii_to_idn(const char *in, char **out) +{ + size_t inlen = strlen(in); + if(inlen < MAX_HOST_LENGTH) { + UErrorCode err = U_ZERO_ERROR; + UIDNA *idna = uidna_openUTS46( + UIDNA_CHECK_BIDI | UIDNA_NONTRANSITIONAL_TO_UNICODE, &err); + if(!U_FAILURE(err)) { + UIDNAInfo info = UIDNA_INFO_INITIALIZER; + char buffer[MAX_HOST_LENGTH] = { 0 }; + (void)uidna_nameToUnicodeUTF8(idna, in, -1, buffer, + sizeof(buffer) - 1, &info, &err); + uidna_close(idna); + if(!U_FAILURE(err)) { + *out = curlx_strdup(buffer); + if(*out) + return CURLE_OK; + else + return CURLE_OUT_OF_MEMORY; + } + } + } + return CURLE_URL_MALFORMAT; +} +#endif + +#ifdef USE_WIN32_IDN +/* using Windows kernel32 and normaliz libraries. */ + +#define IDN_MAX_LENGTH 255 + +static char *idn_curlx_convert_wchar_to_UTF8(const wchar_t *str_w, int chars) +{ + char *str_utf8 = NULL; + int bytes = WideCharToMultiByte(CP_UTF8, 0, str_w, chars, NULL, 0, + NULL, NULL); + if(bytes > 0) { + str_utf8 = curlx_malloc(bytes); + if(str_utf8) { + if(WideCharToMultiByte(CP_UTF8, 0, str_w, chars, str_utf8, bytes, + NULL, NULL) == 0) { + curlx_free(str_utf8); + return NULL; + } + } + } + return str_utf8; +} + +static CURLcode win32_idn_to_ascii(const char *in, char **out) +{ + wchar_t in_w[IDN_MAX_LENGTH]; + int in_w_len; + *out = NULL; + /* Returned in_w_len includes the null-terminator, which then gets + preserved across the calls that follow, ending up terminating + the buffer returned to the caller. */ + in_w_len = MultiByteToWideChar(CP_UTF8, 0, in, -1, in_w, IDN_MAX_LENGTH); + if(in_w_len) { + wchar_t punycode[IDN_MAX_LENGTH]; + int chars = IdnToAscii(0, in_w, in_w_len, punycode, IDN_MAX_LENGTH); + if(chars > 0) { + *out = idn_curlx_convert_wchar_to_UTF8(punycode, chars); + if(!*out) + return CURLE_OUT_OF_MEMORY; + } + else + return CURLE_URL_MALFORMAT; + } + else + return CURLE_URL_MALFORMAT; + + return CURLE_OK; +} + +static CURLcode win32_ascii_to_idn(const char *in, char **out) +{ + wchar_t in_w[IDN_MAX_LENGTH]; + int in_w_len; + *out = NULL; + /* Returned in_w_len includes the null-terminator, which then gets + preserved across the calls that follow, ending up terminating + the buffer returned to the caller. */ + in_w_len = MultiByteToWideChar(CP_UTF8, 0, in, -1, in_w, IDN_MAX_LENGTH); + if(in_w_len) { + WCHAR idn[IDN_MAX_LENGTH]; /* stores a UTF-16 string */ + int chars = IdnToUnicode(0, in_w, in_w_len, idn, IDN_MAX_LENGTH); + if(chars > 0) { /* 'chars' is "the number of characters retrieved" */ + *out = idn_curlx_convert_wchar_to_UTF8(idn, chars); + if(!*out) + return CURLE_OUT_OF_MEMORY; + } + else + return CURLE_URL_MALFORMAT; + } + else + return CURLE_URL_MALFORMAT; + + return CURLE_OK; +} + +#endif /* USE_WIN32_IDN */ + +/* + * Helpers for IDNA conversions. + */ +bool Curl_is_ASCII_name(const char *hostname) +{ + if(hostname) { + struct Curl_str s; + s.str = hostname; + s.len = strlen(hostname); + return Curl_is_ASCII_str(&s); + } + return TRUE; +} + +bool Curl_is_ASCII_str(struct Curl_str *s) +{ + if(s && s->len) { + const unsigned char *ch = (const unsigned char *)s->str; + size_t i; + for(i = 0; i < s->len; ++i) { + if(ch[i] & 0x80) + return FALSE; + } + } + return TRUE; +} + +#ifdef USE_IDN +/* + * Curl_idn_decode() returns an allocated IDN decoded string if it was + * possible. NULL on error. + * + * CURLE_URL_MALFORMAT - the hostname could not be converted + * CURLE_OUT_OF_MEMORY - memory problem + * + */ +static CURLcode idn_decode(const char *input, char **output) +{ + char *decoded = NULL; + CURLcode result = CURLE_OK; +#ifdef USE_LIBIDN2 + if(idn2_check_version(IDN2_VERSION)) { + int flags = IDN2_NFC_INPUT +#if IDN2_VERSION_NUMBER >= 0x00140000 + /* IDN2_NFC_INPUT: Normalize input string using normalization form C. + IDN2_NONTRANSITIONAL: Perform Unicode TR46 non-transitional + processing. */ + | IDN2_NONTRANSITIONAL +#endif + ; + int rc = IDN2_LOOKUP(input, &decoded, flags); + if(rc != IDN2_OK) + /* fallback to TR46 Transitional mode for better IDNA2003 + compatibility */ + rc = IDN2_LOOKUP(input, &decoded, IDN2_TRANSITIONAL); + if(rc != IDN2_OK) + result = CURLE_URL_MALFORMAT; + } + else + /* a too old libidn2 version */ + result = CURLE_NOT_BUILT_IN; +#elif defined(USE_WIN32_IDN) + result = win32_idn_to_ascii(input, &decoded); +#elif defined(USE_APPLE_IDN) + result = mac_idn_to_ascii(input, &decoded); +#endif + if(!result) + *output = decoded; + return result; +} + +static CURLcode idn_encode(const char *puny, char **output) +{ + char *enc = NULL; +#ifdef USE_LIBIDN2 + int rc = idn2_to_unicode_8z8z(puny, &enc, 0); + if(rc != IDNA_SUCCESS) + return rc == IDNA_MALLOC_ERROR ? CURLE_OUT_OF_MEMORY : CURLE_URL_MALFORMAT; +#elif defined(USE_WIN32_IDN) + CURLcode result = win32_ascii_to_idn(puny, &enc); + if(result) + return result; +#elif defined(USE_APPLE_IDN) + CURLcode result = mac_ascii_to_idn(puny, &enc); + if(result) + return result; +#endif + *output = enc; + return CURLE_OK; +} + +CURLcode Curl_idn_decode(const char *input, char **output) +{ + char *d = NULL; + CURLcode result = idn_decode(input, &d); +#ifdef USE_LIBIDN2 + if(!result) { + char *c = curlx_strdup(d); + idn2_free(d); + if(c) + d = c; + else + result = CURLE_OUT_OF_MEMORY; + } +#endif + if(!result) { + if(!d[0]) { /* ended up zero length, not acceptable */ + result = CURLE_URL_MALFORMAT; + curlx_free(d); + } + else + *output = d; + } + return result; +} + +CURLcode Curl_idn_encode(const char *puny, char **output) +{ + char *d = NULL; + CURLcode result = idn_encode(puny, &d); +#ifdef USE_LIBIDN2 + if(!result) { + char *c = curlx_strdup(d); + idn2_free(d); + if(c) + d = c; + else + result = CURLE_OUT_OF_MEMORY; + } +#endif + if(!result) + *output = d; + return result; +} + +/* + * Frees data allocated by idnconvert_hostname() + */ +void Curl_free_idnconverted_hostname(struct hostname *host) +{ + curlx_safefree(host->encalloc); +} + +#endif /* USE_IDN */ + +/* + * Perform any necessary IDN conversion of hostname + */ +CURLcode Curl_idnconvert_hostname(struct hostname *host) +{ + /* set the name we use to display the hostname */ + host->dispname = host->name; + +#ifdef USE_IDN + /* Check name for non-ASCII and convert hostname if we can */ + if(!Curl_is_ASCII_name(host->name)) { + char *decoded; + CURLcode result = Curl_idn_decode(host->name, &decoded); + if(result) + return result; + /* successful */ + host->name = host->encalloc = decoded; + } +#endif + return CURLE_OK; +} diff --git a/3rdparty/curl-8.21.0/lib/idn.h b/3rdparty/curl-8.21.0/lib/idn.h new file mode 100644 index 0000000000..c73b870a70 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/idn.h @@ -0,0 +1,45 @@ +#ifndef HEADER_CURL_IDN_H +#define HEADER_CURL_IDN_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +struct Curl_str; +struct hostname; + +bool Curl_is_ASCII_name(const char *hostname); +bool Curl_is_ASCII_str(struct Curl_str *s); + +CURLcode Curl_idnconvert_hostname(struct hostname *host); + +#if defined(USE_LIBIDN2) || defined(USE_WIN32_IDN) || defined(USE_APPLE_IDN) +#define USE_IDN +void Curl_free_idnconverted_hostname(struct hostname *host); +CURLcode Curl_idn_decode(const char *input, char **output); +CURLcode Curl_idn_encode(const char *puny, char **output); +#else +#define Curl_free_idnconverted_hostname(x) +#define Curl_idn_decode(x) NULL +#endif + +#endif /* HEADER_CURL_IDN_H */ diff --git a/3rdparty/curl-8.21.0/lib/if2ip.c b/3rdparty/curl-8.21.0/lib/if2ip.c new file mode 100644 index 0000000000..fd34f204b5 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/if2ip.c @@ -0,0 +1,262 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef HAVE_NETINET_IN_H +# include +#endif +#ifdef HAVE_ARPA_INET_H +# include +#endif +#ifdef HAVE_NET_IF_H +# include +#endif +#ifdef HAVE_SYS_IOCTL_H +# include +#endif +#ifdef HAVE_NETDB_H +# include +#endif +#ifdef HAVE_SYS_SOCKIO_H +# include +#endif +#ifdef HAVE_IFADDRS_H +# include +#endif +#ifdef HAVE_STROPTS_H +# include +#endif +#ifdef __VMS +# include +#endif + +#include "curlx/inet_ntop.h" +#include "if2ip.h" + +/* ------------------------------------------------------------------ */ + +#ifdef USE_IPV6 +/* Return the scope of the given address. */ +unsigned int Curl_ipv6_scope(const struct sockaddr *sa) +{ + if(sa->sa_family == AF_INET6) { + const struct sockaddr_in6 *sa6 = + (const struct sockaddr_in6 *)(const void *)sa; + const unsigned char *b = sa6->sin6_addr.s6_addr; + unsigned short w = (unsigned short)((b[0] << 8) | b[1]); + + if((b[0] & 0xFE) == 0xFC) /* Handle ULAs */ + return IPV6_SCOPE_UNIQUELOCAL; + switch(w & 0xFFC0) { + case 0xFE80: + return IPV6_SCOPE_LINKLOCAL; + case 0xFEC0: + return IPV6_SCOPE_SITELOCAL; + case 0x0000: + w = b[1] | b[2] | b[3] | b[4] | b[5] | b[6] | b[7] | b[8] | b[9] | + b[10] | b[11] | b[12] | b[13] | b[14]; + if(w || b[15] != 0x01) + break; + return IPV6_SCOPE_NODELOCAL; + default: + break; + } + } + return IPV6_SCOPE_GLOBAL; +} +#endif + +#if !defined(CURL_DISABLE_BINDLOCAL) || !defined(CURL_DISABLE_FTP) + +#ifdef HAVE_GETIFADDRS + +if2ip_result_t Curl_if2ip(int af, +#ifdef USE_IPV6 + unsigned int remote_scope, + unsigned int local_scope_id, +#endif + const char *interf, + char *buf, size_t buf_size) +{ + struct ifaddrs *iface, *head; + if2ip_result_t res = IF2IP_NOT_FOUND; + +#if defined(USE_IPV6) && !defined(HAVE_SOCKADDR_IN6_SIN6_SCOPE_ID) + (void)local_scope_id; +#endif + + if(getifaddrs(&head) >= 0) { + for(iface = head; iface; iface = iface->ifa_next) { + if(iface->ifa_addr) { + if(iface->ifa_addr->sa_family == af) { + if(curl_strequal(iface->ifa_name, interf)) { + void *addr; + const char *ip; + char scope[12] = ""; + char ipstr[64]; +#ifdef USE_IPV6 + if(af == AF_INET6) { +#ifdef HAVE_SOCKADDR_IN6_SIN6_SCOPE_ID + unsigned int scopeid = 0; +#endif + unsigned int ifscope = Curl_ipv6_scope(iface->ifa_addr); + + if(ifscope != remote_scope) { + /* We are interested only in interface addresses whose scope + matches the remote address we want to connect to: global + for global, link-local for link-local, etc... */ + if(res == IF2IP_NOT_FOUND) + res = IF2IP_AF_NOT_SUPPORTED; + continue; + } + + addr = + &((struct sockaddr_in6 *)(void *)iface->ifa_addr)->sin6_addr; +#ifdef HAVE_SOCKADDR_IN6_SIN6_SCOPE_ID + /* Include the scope of this interface as part of the address */ + scopeid = ((struct sockaddr_in6 *)(void *)iface->ifa_addr) + ->sin6_scope_id; + + /* If given, scope id should match. */ + if(local_scope_id && scopeid != local_scope_id) { + if(res == IF2IP_NOT_FOUND) + res = IF2IP_AF_NOT_SUPPORTED; + + continue; + } + + if(scopeid) + curl_msnprintf(scope, sizeof(scope), "%%%u", scopeid); +#endif + } + else +#endif + addr = + &((struct sockaddr_in *)(void *)iface->ifa_addr)->sin_addr; + res = IF2IP_FOUND; + ip = curlx_inet_ntop(af, addr, ipstr, sizeof(ipstr)); + curl_msnprintf(buf, buf_size, "%s%s", ip, scope); + break; + } + } + else if((res == IF2IP_NOT_FOUND) && + curl_strequal(iface->ifa_name, interf)) { + res = IF2IP_AF_NOT_SUPPORTED; + } + } + } + + freeifaddrs(head); + } + + return res; +} + +#elif defined(HAVE_IOCTL_SIOCGIFADDR) + +if2ip_result_t Curl_if2ip(int af, +#ifdef USE_IPV6 + unsigned int remote_scope, + unsigned int local_scope_id, +#endif + const char *interf, + char *buf, size_t buf_size) +{ + struct ifreq req; + struct in_addr in; + struct sockaddr_in *s; + curl_socket_t dummy; + size_t len; + const char *r; + +#ifdef USE_IPV6 + (void)remote_scope; + (void)local_scope_id; +#endif + + if(!interf || (af != AF_INET)) + return IF2IP_NOT_FOUND; + + len = strlen(interf); + if(len >= sizeof(req.ifr_name)) + return IF2IP_NOT_FOUND; + + dummy = CURL_SOCKET(AF_INET, SOCK_STREAM, 0); + if(dummy == CURL_SOCKET_BAD) + return IF2IP_NOT_FOUND; + + memset(&req, 0, sizeof(req)); + memcpy(req.ifr_name, interf, len + 1); + req.ifr_addr.sa_family = AF_INET; + +#if defined(CURL_HAVE_DIAG) && defined(_AIX) +/* Suppress warning inside system headers */ +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Wshift-sign-overflow" +#endif + if(ioctl(dummy, SIOCGIFADDR, &req) < 0) { +#if defined(CURL_HAVE_DIAG) && defined(_AIX) +#pragma GCC diagnostic pop +#endif + sclose(dummy); + /* With SIOCGIFADDR, we cannot tell the difference between an interface + that does not exist and an interface that has no address of the + correct family. Assume the interface does not exist */ + return IF2IP_NOT_FOUND; + } + + s = (struct sockaddr_in *)(void *)&req.ifr_addr; + memcpy(&in, &s->sin_addr, sizeof(in)); + r = curlx_inet_ntop(s->sin_family, &in, buf, buf_size); + + sclose(dummy); + if(!r) + return IF2IP_NOT_FOUND; + return IF2IP_FOUND; +} + +#else + +if2ip_result_t Curl_if2ip(int af, +#ifdef USE_IPV6 + unsigned int remote_scope, + unsigned int local_scope_id, +#endif + const char *interf, + char *buf, size_t buf_size) +{ + (void)af; +#ifdef USE_IPV6 + (void)remote_scope; + (void)local_scope_id; +#endif + (void)interf; + (void)buf; + (void)buf_size; + return IF2IP_NOT_FOUND; +} + +#endif + +#endif /* CURL_DISABLE_BINDLOCAL && CURL_DISABLE_FTP */ diff --git a/3rdparty/curl-8.21.0/lib/if2ip.h b/3rdparty/curl-8.21.0/lib/if2ip.h new file mode 100644 index 0000000000..dc79c383b7 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/if2ip.h @@ -0,0 +1,91 @@ +#ifndef HEADER_CURL_IF2IP_H +#define HEADER_CURL_IF2IP_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +/* IPv6 address scopes. */ +#define IPV6_SCOPE_GLOBAL 0 /* Global scope. */ +#define IPV6_SCOPE_LINKLOCAL 1 /* Link-local scope. */ +#define IPV6_SCOPE_SITELOCAL 2 /* Site-local scope (deprecated). */ +#define IPV6_SCOPE_UNIQUELOCAL 3 /* Unique local */ +#define IPV6_SCOPE_NODELOCAL 4 /* Loopback. */ + +#ifdef USE_IPV6 +unsigned int Curl_ipv6_scope(const struct sockaddr *sa); +#else +#define Curl_ipv6_scope(x) 0 +#endif + +typedef enum { + IF2IP_NOT_FOUND = 0, /* Interface not found */ + IF2IP_AF_NOT_SUPPORTED = 1, /* Int. exists but has no address for this af */ + IF2IP_FOUND = 2 /* The address has been stored in "buf" */ +} if2ip_result_t; + +if2ip_result_t Curl_if2ip(int af, +#ifdef USE_IPV6 + unsigned int remote_scope, + unsigned int local_scope_id, +#endif + const char *interf, + char *buf, size_t buf_size); + +#ifdef __INTERIX + +/* Nedelcho Stanev's workaround for SFU 3.0 */ +struct ifreq { +#define IFNAMSIZ 16 +#define IFHWADDRLEN 6 + union { + char ifrn_name[IFNAMSIZ]; /* if name, e.g. "en0" */ + } ifr_ifrn; + + union { + struct sockaddr ifru_addr; + struct sockaddr ifru_broadaddr; + struct sockaddr ifru_netmask; + struct sockaddr ifru_hwaddr; + short ifru_flags; + int ifru_metric; + int ifru_mtu; + } ifr_ifru; +}; + +/* This define exists to avoid an extra #ifdef INTERIX in the C code. */ + +#define ifr_name ifr_ifrn.ifrn_name /* interface name */ +#define ifr_addr ifr_ifru.ifru_addr /* address */ +#define ifr_broadaddr ifr_ifru.ifru_broadaddr /* broadcast address */ +#define ifr_netmask ifr_ifru.ifru_netmask /* interface net mask */ +#define ifr_flags ifr_ifru.ifru_flags /* flags */ +#define ifr_hwaddr ifr_ifru.ifru_hwaddr /* MAC address */ +#define ifr_metric ifr_ifru.ifru_metric /* metric */ +#define ifr_mtu ifr_ifru.ifru_mtu /* mtu */ + +#define SIOCGIFADDR _IOW('s', 102, struct ifreq) /* Get if addr */ + +#endif /* __INTERIX */ + +#endif /* HEADER_CURL_IF2IP_H */ diff --git a/3rdparty/curl-8.21.0/lib/imap.c b/3rdparty/curl-8.21.0/lib/imap.c new file mode 100644 index 0000000000..976c9f573e --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/imap.c @@ -0,0 +1,2326 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + * RFC2195 CRAM-MD5 authentication + * RFC2595 Using TLS with IMAP, POP3 and ACAP + * RFC2831 DIGEST-MD5 authentication + * RFC3501 IMAPv4 protocol + * RFC4422 Simple Authentication and Security Layer (SASL) + * RFC4616 PLAIN authentication + * RFC4752 The Kerberos V5 ("GSSAPI") SASL Mechanism + * RFC4959 IMAP Extension for SASL Initial Client Response + * RFC5092 IMAP URL Scheme + * RFC6749 OAuth 2.0 Authorization Framework + * RFC8314 Use of TLS for Email Submission and Access + * Draft LOGIN SASL Mechanism + * + ***************************************************************************/ +#include "curl_setup.h" +#include "urldata.h" +#include "imap.h" + +#ifndef CURL_DISABLE_IMAP + +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_ARPA_INET_H +#include +#endif +#ifdef HAVE_NETDB_H +#include +#endif +#ifdef __VMS +#include +#include +#endif + +#include "curlx/dynbuf.h" +#include "sendf.h" +#include "curl_trc.h" +#include "hostip.h" +#include "progress.h" +#include "transfer.h" +#include "escape.h" +#include "pingpong.h" +#include "mime.h" +#include "curlx/strparse.h" +#include "strcase.h" +#include "vtls/vtls.h" +#include "cfilters.h" +#include "connect.h" +#include "select.h" +#include "url.h" +#include "bufref.h" +#include "curl_sasl.h" +#include "curlx/strcopy.h" + +/* meta key for storing protocol meta at easy handle */ +#define CURL_META_IMAP_EASY "meta:proto:imap:easy" +/* meta key for storing protocol meta at connection */ +#define CURL_META_IMAP_CONN "meta:proto:imap:conn" + +typedef enum { + IMAP_STOP, /* do nothing state, stops the state machine */ + IMAP_SERVERGREET, /* waiting for the initial greeting immediately after + a connect */ + IMAP_CAPABILITY, + IMAP_STARTTLS, + IMAP_UPGRADETLS, /* asynchronously upgrade the connection to SSL/TLS + (multi mode only) */ + IMAP_AUTHENTICATE, + IMAP_LOGIN, + IMAP_LIST, + IMAP_SELECT, + IMAP_FETCH, + IMAP_FETCH_FINAL, + IMAP_APPEND, + IMAP_APPEND_FINAL, + IMAP_SEARCH, + IMAP_LOGOUT, + IMAP_LAST /* never used */ +} imapstate; + +/* imap_conn is used for struct connection-oriented data */ +struct imap_conn { + struct pingpong pp; + struct SASL sasl; /* SASL-related parameters */ + struct dynbuf dyn; /* for the IMAP commands */ + char *mailbox; /* The last selected mailbox */ + imapstate state; /* Always use imap.c:state() to change state! */ + unsigned int mb_uidvalidity; /* UIDVALIDITY parsed from select response */ + char resptag[5]; /* Response tag to wait for */ + unsigned char preftype; /* Preferred authentication type */ + unsigned char cmdid; /* Last used command ID */ + BIT(ssldone); /* Is connect() over SSL done? */ + BIT(preauth); /* Is this connection PREAUTH? */ + BIT(tls_supported); /* StartTLS capability supported by server */ + BIT(login_disabled); /* LOGIN command disabled by server */ + BIT(ir_supported); /* Initial response supported by server */ + BIT(mb_uidvalidity_set); +}; + +/* This IMAP struct is used in the Curl_easy. All IMAP data that is + connection-oriented must be in imap_conn to properly deal with the fact that + perhaps the Curl_easy is changed between the times the connection is + used. */ +struct IMAP { + curl_pp_transfer transfer; + char *mailbox; /* Mailbox to select */ + char *uid; /* Message UID to fetch */ + char *mindex; /* Index in mail box of mail to fetch */ + char *section; /* Message SECTION to fetch */ + char *partial; /* Message PARTIAL to fetch */ + char *query; /* Query to search for */ + char *custom; /* Custom request */ + char *custom_params; /* Parameters for the custom request */ + unsigned int uidvalidity; /* UIDVALIDITY to check in select */ + BIT(uidvalidity_set); +}; + +#define IMAP_RESP_OK 1 +#define IMAP_RESP_NOT_OK 2 +#define IMAP_RESP_PREAUTH 3 + +struct ulbits { + int bit; + const char *flag; +}; + +/*********************************************************************** + * + * imap_sendf() + * + * Sends the formatted string as an IMAP command to the server. + * + * Designed to never block. + */ +static CURLcode imap_sendf(struct Curl_easy *data, + struct imap_conn *imapc, + const char *fmt, ...) CURL_PRINTF(3, 0); +static CURLcode imap_sendf(struct Curl_easy *data, + struct imap_conn *imapc, + const char *fmt, ...) +{ + CURLcode result = CURLE_OK; + + DEBUGASSERT(fmt); + + /* Calculate the tag based on the connection ID and command ID */ + curl_msnprintf(imapc->resptag, sizeof(imapc->resptag), "%c%03d", + 'A' + curlx_sltosi((long)(data->conn->connection_id % 26)), + ++imapc->cmdid); + + /* start with a blank buffer */ + curlx_dyn_reset(&imapc->dyn); + + /* append tag + space + fmt */ + result = curlx_dyn_addf(&imapc->dyn, "%s %s", imapc->resptag, fmt); + if(!result) { + va_list ap; + va_start(ap, fmt); +#ifdef __clang__ +#pragma clang diagnostic push +#pragma clang diagnostic ignored "-Wformat-nonliteral" +#endif + result = Curl_pp_vsendf(data, &imapc->pp, curlx_dyn_ptr(&imapc->dyn), ap); +#ifdef __clang__ +#pragma clang diagnostic pop +#endif + va_end(ap); + } + return result; +} + +/*********************************************************************** + * + * imap_atom() + * + * Checks the input string for characters that need escaping and returns an + * atom ready for sending to the server. + * + * The returned string needs to be freed. + * + */ +static char *imap_atom(const char *str, bool escape_only) +{ + struct dynbuf line; + size_t nclean; + size_t len; + + if(!str) + return NULL; + + len = strlen(str); + nclean = strcspn(str, "() {%*]\\\""); + if(len == nclean) + /* nothing to escape, return a strdup */ + return curlx_strdup(str); + + curlx_dyn_init(&line, 2000); + + if(!escape_only && curlx_dyn_addn(&line, "\"", 1)) + return NULL; + + while(*str) { + if((*str == '\\' || *str == '"') && + curlx_dyn_addn(&line, "\\", 1)) + return NULL; + if(curlx_dyn_addn(&line, str, 1)) + return NULL; + str++; + } + + if(!escape_only && curlx_dyn_addn(&line, "\"", 1)) + return NULL; + + return curlx_dyn_ptr(&line); +} + +/* + * Finds the start of a literal '{size}' in line, skipping over quoted strings. + */ +static const char *imap_find_literal(const char *line, size_t len) +{ + const char *end = line + len; + bool in_quote = FALSE; + + while(line < end) { + if(in_quote) { + if(*line == '\\' && (line + 1) < end) { + line += 2; + continue; + } + if(*line == '"') + in_quote = FALSE; + } + else { + if(*line == '"') + in_quote = TRUE; + else if(*line == '{') + return line; + } + line++; + } + return NULL; +} + +/*********************************************************************** + * + * imap_matchresp() + * + * Determines whether the untagged response is related to the specified + * command by checking if it is in format "* ..." or + * "* ...". + * + * The "* " marker is assumed to have already been checked by the caller. + */ +static bool imap_matchresp(const char *line, size_t len, const char *cmd) +{ + const char *end = line + len; + size_t cmd_len = strlen(cmd); + + /* Skip the untagged response marker */ + line += 2; + + /* Do we have a number after the marker? */ + if(line < end && ISDIGIT(*line)) { + /* Skip the number */ + do + line++; + while(line < end && ISDIGIT(*line)); + + /* Do we have the space character? */ + if(line == end || *line != ' ') + return FALSE; + + line++; + } + + /* Does the command name match and is it followed by a space character or at + the end of line? */ + if(line + cmd_len <= end && curl_strnequal(line, cmd, cmd_len) && + (line[cmd_len] == ' ' || line + cmd_len + 2 == end)) + return TRUE; + + return FALSE; +} + +/*********************************************************************** + * + * imap_endofresp() + * + * Checks whether the given string is a valid tagged, untagged or continuation + * response which can be processed by the response handler. + */ +static bool imap_endofresp(struct Curl_easy *data, struct connectdata *conn, + const char *line, size_t len, int *resp) +{ + struct imap_conn *imapc = Curl_conn_meta_get(conn, CURL_META_IMAP_CONN); + struct IMAP *imap = Curl_meta_get(data, CURL_META_IMAP_EASY); + const char *id; + size_t id_len; + + DEBUGASSERT(imapc); + DEBUGASSERT(imap); + if(!imapc || !imap) + return FALSE; + + /* Do we have a tagged command response? */ + id = imapc->resptag; + id_len = strlen(id); + if(len >= id_len + 1 && !memcmp(id, line, id_len) && line[id_len] == ' ') { + line += id_len + 1; + len -= id_len + 1; + + if(len >= 2 && !memcmp(line, "OK", 2)) + *resp = IMAP_RESP_OK; + else if(len >= 7 && !memcmp(line, "PREAUTH", 7)) + *resp = IMAP_RESP_PREAUTH; + else + *resp = IMAP_RESP_NOT_OK; + + return TRUE; + } + + /* Do we have an untagged command response? */ + if(len >= 2 && !memcmp("* ", line, 2)) { + switch(imapc->state) { + /* States which are interested in untagged responses */ + case IMAP_CAPABILITY: + if(!imap_matchresp(line, len, "CAPABILITY")) + return FALSE; + break; + + case IMAP_LIST: + if((!imap->custom && !imap_matchresp(line, len, "LIST")) || + (imap->custom && !imap_matchresp(line, len, imap->custom) && + (!curl_strequal(imap->custom, "STORE") || + !imap_matchresp(line, len, "FETCH")) && + !curl_strequal(imap->custom, "SELECT") && + !curl_strequal(imap->custom, "EXAMINE") && + !curl_strequal(imap->custom, "SEARCH") && + !curl_strequal(imap->custom, "EXPUNGE") && + !curl_strequal(imap->custom, "LSUB") && + !curl_strequal(imap->custom, "UID") && + !curl_strequal(imap->custom, "GETQUOTAROOT") && + !curl_strequal(imap->custom, "NOOP"))) + return FALSE; + break; + + case IMAP_SELECT: + /* SELECT is special in that its untagged responses do not have a + common prefix so accept anything! */ + break; + + case IMAP_FETCH: + if(!imap_matchresp(line, len, "FETCH")) + return FALSE; + break; + + case IMAP_SEARCH: + if(!imap_matchresp(line, len, "SEARCH")) + return FALSE; + break; + + /* Ignore other untagged responses */ + default: + return FALSE; + } + + *resp = '*'; + return TRUE; + } + + /* Do we have a continuation response? This should be a + symbol followed by + a space and optionally some text as per RFC-3501 for the AUTHENTICATE and + APPEND commands and as outlined in Section 4. Examples of RFC-4959 but + some email servers ignore this and only send a single + instead. */ + if(!imap->custom && ((len == 3 && line[0] == '+') || + (len >= 2 && !memcmp("+ ", line, 2)))) { + switch(imapc->state) { + /* States which are interested in continuation responses */ + case IMAP_AUTHENTICATE: + case IMAP_APPEND: + *resp = '+'; + break; + + default: + failf(data, "Unexpected continuation response"); + *resp = -1; + break; + } + + return TRUE; + } + + return FALSE; /* Nothing for us */ +} + +/*********************************************************************** + * + * imap_get_message() + * + * Gets the authentication message from the response buffer. + */ +static CURLcode imap_get_message(struct Curl_easy *data, struct bufref *out) +{ + struct imap_conn *imapc = + Curl_conn_meta_get(data->conn, CURL_META_IMAP_CONN); + char *message; + size_t len; + + if(!imapc) + return CURLE_FAILED_INIT; + + message = curlx_dyn_ptr(&imapc->pp.recvbuf); + len = imapc->pp.nfinal; + if(len > 2) { + /* Find the start of the message */ + len -= 2; + for(message += 2; ISBLANK(*message); message++, len--) + ; + + /* Find the end of the message */ + while(len--) + if(!ISNEWLINE(message[len]) && !ISBLANK(message[len])) + break; + + /* Terminate the message */ + message[++len] = '\0'; + Curl_bufref_set(out, message, len, NULL); + } + else + /* junk input => zero length output */ + Curl_bufref_set(out, "", 0, NULL); + + return CURLE_OK; +} + +/*********************************************************************** + * + * imap_state() + * + * This is the ONLY way to change IMAP state! + */ +static void imap_state(struct Curl_easy *data, + struct imap_conn *imapc, + imapstate newstate) +{ +#if defined(DEBUGBUILD) && defined(CURLVERBOSE) + /* for debug purposes */ + static const char * const names[] = { + "STOP", + "SERVERGREET", + "CAPABILITY", + "STARTTLS", + "UPGRADETLS", + "AUTHENTICATE", + "LOGIN", + "LIST", + "SELECT", + "FETCH", + "FETCH_FINAL", + "APPEND", + "APPEND_FINAL", + "SEARCH", + "LOGOUT", + /* LAST */ + }; + + if(imapc->state != newstate) + infof(data, "IMAP %p state change from %s to %s", + (void *)imapc, names[imapc->state], names[newstate]); +#else + (void)data; +#endif + imapc->state = newstate; +} + +/*********************************************************************** + * + * imap_perform_capability() + * + * Sends the CAPABILITY command in order to obtain a list of server side + * supported capabilities. + */ +static CURLcode imap_perform_capability(struct Curl_easy *data, + struct imap_conn *imapc) +{ + CURLcode result = CURLE_OK; + + imapc->sasl.authmechs = SASL_AUTH_NONE; /* No known auth. mechanisms yet */ + imapc->sasl.authused = SASL_AUTH_NONE; /* Clear the auth. mechanism used */ + imapc->tls_supported = FALSE; /* Clear the TLS capability */ + + /* Send the CAPABILITY command */ + result = imap_sendf(data, imapc, "CAPABILITY"); + + if(!result) + imap_state(data, imapc, IMAP_CAPABILITY); + + return result; +} + +/*********************************************************************** + * + * imap_perform_starttls() + * + * Sends the STARTTLS command to start the upgrade to TLS. + */ +static CURLcode imap_perform_starttls(struct Curl_easy *data, + struct imap_conn *imapc) +{ + /* Send the STARTTLS command */ + CURLcode result = imap_sendf(data, imapc, "STARTTLS"); + + if(!result) + imap_state(data, imapc, IMAP_STARTTLS); + + return result; +} + +/*********************************************************************** + * + * imap_perform_upgrade_tls() + * + * Performs the upgrade to TLS. + */ +static CURLcode imap_perform_upgrade_tls(struct Curl_easy *data, + struct imap_conn *imapc, + struct connectdata *conn) +{ +#ifdef USE_SSL + /* Start the SSL connection */ + CURLcode result; + bool ssldone = FALSE; + + if(!Curl_conn_is_ssl(conn, FIRSTSOCKET)) { + result = Curl_ssl_cfilter_add( + data, Curl_conn_get_origin(conn, FIRSTSOCKET), conn, FIRSTSOCKET); + if(result) + goto out; + /* Change the connection handler */ + conn->scheme = &Curl_scheme_imaps; + } + + DEBUGASSERT(!imapc->ssldone); + result = Curl_conn_connect(data, FIRSTSOCKET, FALSE, &ssldone); + DEBUGF(infof(data, "imap_perform_upgrade_tls, connect -> %d, %d", + (int)result, ssldone)); + if(!result && ssldone) { + imapc->ssldone = ssldone; + /* perform CAPA now, changes imapc->state out of IMAP_UPGRADETLS */ + result = imap_perform_capability(data, imapc); + } +out: + return result; +#else + (void)data; + (void)imapc; + (void)conn; + return CURLE_NOT_BUILT_IN; +#endif +} + +/*********************************************************************** + * + * imap_perform_login() + * + * Sends a clear text LOGIN command to authenticate with. + */ +static CURLcode imap_perform_login(struct Curl_easy *data, + struct imap_conn *imapc, + struct connectdata *conn) +{ + CURLcode result = CURLE_OK; + char *user; + char *passwd; + + /* Check we have a username and password to authenticate with and end the + connect phase if we do not */ + if(!conn->creds) { + imap_state(data, imapc, IMAP_STOP); + + return result; + } + + /* Make sure the username and password are in the correct atom format */ + user = imap_atom(Curl_creds_user(conn->creds), FALSE); + passwd = imap_atom(Curl_creds_passwd(conn->creds), FALSE); + + /* Send the LOGIN command */ + result = imap_sendf(data, imapc, "LOGIN %s %s", user ? user : "", + passwd ? passwd : ""); + + curlx_free(user); + curlx_free(passwd); + + if(!result) + imap_state(data, imapc, IMAP_LOGIN); + + return result; +} + +/*********************************************************************** + * + * imap_perform_authenticate() + * + * Sends an AUTHENTICATE command allowing the client to login with the given + * SASL authentication mechanism. + */ +static CURLcode imap_perform_authenticate(struct Curl_easy *data, + const char *mech, + const struct bufref *initresp) +{ + struct imap_conn *imapc = + Curl_conn_meta_get(data->conn, CURL_META_IMAP_CONN); + CURLcode result = CURLE_OK; + const char *ir = Curl_bufref_ptr(initresp); + + if(!imapc) + return CURLE_FAILED_INIT; + if(ir) { + /* Send the AUTHENTICATE command with the initial response */ + result = imap_sendf(data, imapc, "AUTHENTICATE %s %s", mech, ir); + } + else { + /* Send the AUTHENTICATE command */ + result = imap_sendf(data, imapc, "AUTHENTICATE %s", mech); + } + + return result; +} + +/*********************************************************************** + * + * imap_continue_authenticate() + * + * Sends SASL continuation data. + */ +static CURLcode imap_continue_authenticate(struct Curl_easy *data, + const char *mech, + const struct bufref *resp) +{ + struct imap_conn *imapc = + Curl_conn_meta_get(data->conn, CURL_META_IMAP_CONN); + + (void)mech; + if(!imapc) + return CURLE_FAILED_INIT; + return Curl_pp_sendf(data, &imapc->pp, "%s", Curl_bufref_ptr(resp)); +} + +/*********************************************************************** + * + * imap_cancel_authenticate() + * + * Sends SASL cancellation. + */ +static CURLcode imap_cancel_authenticate(struct Curl_easy *data, + const char *mech) +{ + struct imap_conn *imapc = + Curl_conn_meta_get(data->conn, CURL_META_IMAP_CONN); + + (void)mech; + if(!imapc) + return CURLE_FAILED_INIT; + return Curl_pp_sendf(data, &imapc->pp, "*"); +} + +/*********************************************************************** + * + * imap_perform_authentication() + * + * Initiates the authentication sequence, with the appropriate SASL + * authentication mechanism, falling back to clear text should a common + * mechanism not be available between the client and server. + */ +static CURLcode imap_perform_authentication(struct Curl_easy *data, + struct imap_conn *imapc) +{ + CURLcode result = CURLE_OK; + saslprogress progress; + + /* Check if already authenticated OR if there is enough data to authenticate + with and end the connect phase if we do not */ + if(imapc->preauth || + !Curl_sasl_can_authenticate(&imapc->sasl, data)) { + imap_state(data, imapc, IMAP_STOP); + return result; + } + + /* Calculate the SASL login details */ + result = Curl_sasl_start(&imapc->sasl, data, (bool)imapc->ir_supported, + &progress); + if(!result) { + if(progress == SASL_INPROGRESS) + imap_state(data, imapc, IMAP_AUTHENTICATE); + else if(!imapc->login_disabled && (imapc->preftype & IMAP_TYPE_CLEARTEXT)) + /* Perform clear text authentication */ + result = imap_perform_login(data, imapc, data->conn); + else + result = Curl_sasl_is_blocked(&imapc->sasl, data); + } + + return result; +} + +/*********************************************************************** + * + * imap_perform_list() + * + * Sends a LIST command or an alternative custom request. + */ +static CURLcode imap_perform_list(struct Curl_easy *data, + struct imap_conn *imapc, + struct IMAP *imap) +{ + CURLcode result = CURLE_OK; + + if(imap->custom) + /* Send the custom request */ + result = imap_sendf(data, imapc, "%s%s", imap->custom, + imap->custom_params ? imap->custom_params : ""); + else { + /* Make sure the mailbox is in the correct atom format if necessary */ + char *mailbox = imap->mailbox ? imap_atom(imap->mailbox, TRUE) + : curlx_strdup(""); + if(!mailbox) + return CURLE_OUT_OF_MEMORY; + + /* Send the LIST command */ + result = imap_sendf(data, imapc, "LIST \"%s\" *", mailbox); + + curlx_free(mailbox); + } + + if(!result) + imap_state(data, imapc, IMAP_LIST); + + return result; +} + +/*********************************************************************** + * + * imap_perform_select() + * + * Sends a SELECT command to ask the server to change the selected mailbox. + */ +static CURLcode imap_perform_select(struct Curl_easy *data, + struct imap_conn *imapc, + struct IMAP *imap) +{ + CURLcode result = CURLE_OK; + char *mailbox; + + /* Invalidate old information as we are switching mailboxes */ + curlx_safefree(imapc->mailbox); + imapc->mb_uidvalidity_set = FALSE; + + /* Check we have a mailbox */ + if(!imap->mailbox) { + failf(data, "Cannot SELECT without a mailbox."); + return CURLE_URL_MALFORMAT; + } + + /* Make sure the mailbox is in the correct atom format */ + mailbox = imap_atom(imap->mailbox, FALSE); + if(!mailbox) + return CURLE_OUT_OF_MEMORY; + + /* Send the SELECT command */ + result = imap_sendf(data, imapc, "SELECT %s", mailbox); + + curlx_free(mailbox); + + if(!result) + imap_state(data, imapc, IMAP_SELECT); + + return result; +} + +/*********************************************************************** + * + * imap_perform_fetch() + * + * Sends a FETCH command to initiate the download of a message. + */ +static CURLcode imap_perform_fetch(struct Curl_easy *data, + struct imap_conn *imapc, + struct IMAP *imap) +{ + CURLcode result = CURLE_OK; + /* Check we have a UID */ + if(imap->uid) { + + /* Send the FETCH command */ + if(imap->partial) + result = imap_sendf(data, imapc, "UID FETCH %s BODY[%s]<%s>", + imap->uid, imap->section ? imap->section : "", + imap->partial); + else + result = imap_sendf(data, imapc, "UID FETCH %s BODY[%s]", + imap->uid, imap->section ? imap->section : ""); + } + else if(imap->mindex) { + /* Send the FETCH command */ + if(imap->partial) + result = imap_sendf(data, imapc, "FETCH %s BODY[%s]<%s>", + imap->mindex, imap->section ? imap->section : "", + imap->partial); + else + result = imap_sendf(data, imapc, "FETCH %s BODY[%s]", + imap->mindex, imap->section ? imap->section : ""); + } + else { + failf(data, "Cannot FETCH without a UID."); + return CURLE_URL_MALFORMAT; + } + if(!result) + imap_state(data, imapc, IMAP_FETCH); + + return result; +} + +/*********************************************************************** + * + * imap_perform_append() + * + * Sends an APPEND command to initiate the upload of a message. + */ +static CURLcode imap_perform_append(struct Curl_easy *data, + struct imap_conn *imapc, + struct IMAP *imap) +{ + CURLcode result = CURLE_OK; + char *mailbox; + struct dynbuf flags; + + /* Check we have a mailbox */ + if(!imap->mailbox) { + failf(data, "Cannot APPEND without a mailbox."); + return CURLE_URL_MALFORMAT; + } + +#ifndef CURL_DISABLE_MIME + /* Prepare the mime data if some. */ + if(IS_MIME_POST(data)) { + curl_mimepart *postp = data->set.mimepostp; + + /* Use the whole structure as data. */ + postp->flags &= ~(unsigned int)MIME_BODY_ONLY; + + /* Add external headers and mime version. */ + curl_mime_headers(postp, data->set.headers, 0); + result = Curl_mime_prepare_headers(data, postp, NULL, + NULL, MIMESTRATEGY_MAIL); + + if(!result) + if(!Curl_checkheaders(data, STRCONST("Mime-Version"))) + result = Curl_mime_add_header(&postp->curlheaders, + "Mime-Version: 1.0"); + + if(!result) + result = Curl_creader_set_mime(data, postp); + if(result) + return result; + data->state.infilesize = Curl_creader_client_length(data); + } + else +#endif + { + result = Curl_creader_set_fread(data, data->state.infilesize); + if(result) + return result; + } + + /* Check we know the size of the upload */ + if(data->state.infilesize < 0) { + failf(data, "Cannot APPEND with unknown input file size"); + return CURLE_UPLOAD_FAILED; + } + + /* Make sure the mailbox is in the correct atom format */ + mailbox = imap_atom(imap->mailbox, FALSE); + if(!mailbox) + return CURLE_OUT_OF_MEMORY; + + /* Generate flags string and send the APPEND command */ + curlx_dyn_init(&flags, 100); + if(data->set.upload_flags) { + int i; + struct ulbits ulflag[] = { + { CURLULFLAG_ANSWERED, "Answered" }, + { CURLULFLAG_DELETED, "Deleted" }, + { CURLULFLAG_DRAFT, "Draft" }, + { CURLULFLAG_FLAGGED, "Flagged" }, + { CURLULFLAG_SEEN, "Seen" }, + { 0, NULL } + }; + + result = CURLE_OUT_OF_MEMORY; + if(curlx_dyn_add(&flags, " (")) { + goto cleanup; + } + + for(i = 0; ulflag[i].bit; i++) { + if(data->set.upload_flags & ulflag[i].bit) { + if((curlx_dyn_len(&flags) > 2 && curlx_dyn_add(&flags, " ")) || + curlx_dyn_add(&flags, "\\") || + curlx_dyn_add(&flags, ulflag[i].flag)) + goto cleanup; + } + } + + if(curlx_dyn_add(&flags, ")")) + goto cleanup; + } + else if(curlx_dyn_add(&flags, "")) + goto cleanup; + + result = imap_sendf(data, imapc, "APPEND %s%s {%" FMT_OFF_T "}", + mailbox, curlx_dyn_ptr(&flags), data->state.infilesize); + +cleanup: + curlx_dyn_free(&flags); + curlx_free(mailbox); + + if(!result) + imap_state(data, imapc, IMAP_APPEND); + + return result; +} + +/*********************************************************************** + * + * imap_perform_search() + * + * Sends a SEARCH command. + */ +static CURLcode imap_perform_search(struct Curl_easy *data, + struct imap_conn *imapc, + struct IMAP *imap) +{ + CURLcode result = CURLE_OK; + + /* Check we have a query string */ + if(!imap->query) { + failf(data, "Cannot SEARCH without a query string."); + return CURLE_URL_MALFORMAT; + } + + /* Send the SEARCH command */ + result = imap_sendf(data, imapc, "SEARCH %s", imap->query); + + if(!result) + imap_state(data, imapc, IMAP_SEARCH); + + return result; +} + +/*********************************************************************** + * + * imap_perform_logout() + * + * Performs the logout action prior to sclose() being called. + */ +static CURLcode imap_perform_logout(struct Curl_easy *data, + struct imap_conn *imapc) +{ + /* Send the LOGOUT command */ + CURLcode result = imap_sendf(data, imapc, "LOGOUT"); + + if(!result) + imap_state(data, imapc, IMAP_LOGOUT); + + return result; +} + +/* For the initial server greeting */ +static CURLcode imap_state_servergreet_resp(struct Curl_easy *data, + struct imap_conn *imapc, + int imapcode, + imapstate instate) +{ + (void)instate; + + if(imapcode == IMAP_RESP_PREAUTH) { + /* PREAUTH */ + imapc->preauth = TRUE; + infof(data, "PREAUTH connection, already authenticated"); + } + else if(imapcode != IMAP_RESP_OK) { + failf(data, "Got unexpected imap-server response"); + return CURLE_WEIRD_SERVER_REPLY; + } + + return imap_perform_capability(data, imapc); +} + +/* For CAPABILITY responses */ +static CURLcode imap_state_capability_resp(struct Curl_easy *data, + struct imap_conn *imapc, + int imapcode, + imapstate instate) +{ + CURLcode result = CURLE_OK; + const char *line = curlx_dyn_ptr(&imapc->pp.recvbuf); + + (void)instate; + + /* Do we have an untagged response? */ + if(imapcode == '*') { + line += 2; + + /* Loop through the data line */ + for(;;) { + size_t wordlen; + while(*line && (ISBLANK(*line) || ISNEWLINE(*line))) + line++; + + if(!*line) + break; + + /* Extract the word */ + for(wordlen = 0; line[wordlen] && !ISBLANK(line[wordlen]) && + !ISNEWLINE(line[wordlen]);) + wordlen++; + + /* Does the server support the STARTTLS capability? */ + if(wordlen == 8 && curl_strnequal(line, "STARTTLS", 8)) + imapc->tls_supported = TRUE; + + /* Has the server explicitly disabled clear text authentication? */ + else if(wordlen == 13 && curl_strnequal(line, "LOGINDISABLED", 13)) + imapc->login_disabled = TRUE; + + /* Does the server support the SASL-IR capability? */ + else if(wordlen == 7 && curl_strnequal(line, "SASL-IR", 7)) + imapc->ir_supported = TRUE; + + /* Do we have a SASL based authentication mechanism? */ + else if(wordlen > 5 && curl_strnequal(line, "AUTH=", 5)) { + size_t llen; + unsigned short mechbit; + + line += 5; + wordlen -= 5; + + /* Test the word for a matching authentication mechanism */ + mechbit = Curl_sasl_decode_mech(line, wordlen, &llen); + if(mechbit && llen == wordlen) + imapc->sasl.authmechs |= mechbit; + } + + line += wordlen; + } + } + else if(data->set.use_ssl && !Curl_conn_is_ssl(data->conn, FIRSTSOCKET)) { + /* PREAUTH is not compatible with STARTTLS. */ + if(imapcode == IMAP_RESP_OK && imapc->tls_supported && !imapc->preauth) { + /* Switch to TLS connection now */ + result = imap_perform_starttls(data, imapc); + } + else if(data->set.use_ssl <= CURLUSESSL_TRY) + result = imap_perform_authentication(data, imapc); + else { + failf(data, "STARTTLS not available."); + result = CURLE_USE_SSL_FAILED; + } + } + else + result = imap_perform_authentication(data, imapc); + + return result; +} + +/* For STARTTLS responses */ +static CURLcode imap_state_starttls_resp(struct Curl_easy *data, + struct imap_conn *imapc, + int imapcode, + imapstate instate) +{ + CURLcode result = CURLE_OK; + + (void)instate; + + /* Pipelining in response is forbidden. */ + if(imapc->pp.overflow) + return CURLE_WEIRD_SERVER_REPLY; + + if(imapcode != IMAP_RESP_OK) { + if(data->set.use_ssl != CURLUSESSL_TRY) { + failf(data, "STARTTLS denied"); + result = CURLE_USE_SSL_FAILED; + } + else + result = imap_perform_authentication(data, imapc); + } + else + imap_state(data, imapc, IMAP_UPGRADETLS); + + return result; +} + +/* For SASL authentication responses */ +static CURLcode imap_state_auth_resp(struct Curl_easy *data, + struct imap_conn *imapc, + int imapcode, + imapstate instate) +{ + CURLcode result = CURLE_OK; + saslprogress progress; + + (void)instate; + + result = Curl_sasl_continue(&imapc->sasl, data, imapcode, &progress); + if(!result) + switch(progress) { + case SASL_DONE: + imap_state(data, imapc, IMAP_STOP); /* Authenticated */ + break; + case SASL_IDLE: /* No mechanism left after cancellation */ + if(!imapc->login_disabled && (imapc->preftype & IMAP_TYPE_CLEARTEXT)) + /* Perform clear text authentication */ + result = imap_perform_login(data, imapc, data->conn); + else { + failf(data, "Authentication cancelled"); + result = CURLE_LOGIN_DENIED; + } + break; + default: + break; + } + + return result; +} + +/* For LOGIN responses */ +static CURLcode imap_state_login_resp(struct Curl_easy *data, + struct imap_conn *imapc, + int imapcode, + imapstate instate) +{ + CURLcode result = CURLE_OK; + (void)instate; + + if(imapcode != IMAP_RESP_OK) { + failf(data, "Access denied. %c", imapcode); + result = CURLE_LOGIN_DENIED; + } + else + /* End of connect phase */ + imap_state(data, imapc, IMAP_STOP); + + return result; +} + +/* Detect IMAP listings vs. downloading a single email */ +static bool is_custom_fetch_listing_match(const char *params) +{ + /* match " 1:* (FLAGS ..." or " 1,2,3 (FLAGS ..." */ + if(*params++ != ' ') + return FALSE; + + while(ISDIGIT(*params)) { + params++; + if(*params == 0) + return FALSE; + } + if(*params == ':') + return TRUE; + if(*params == ',') + return TRUE; + return FALSE; +} + +static bool is_custom_fetch_listing(struct IMAP *imap) +{ + /* filter out "UID FETCH 1:* (FLAGS ..." queries to list emails */ + if(!imap->custom) + return FALSE; + else if(curl_strequal(imap->custom, "FETCH") && imap->custom_params) { + const char *p = imap->custom_params; + return is_custom_fetch_listing_match(p); + } + else if(curl_strequal(imap->custom, "UID") && imap->custom_params) { + if(curl_strnequal(imap->custom_params, " FETCH ", 7)) { + const char *p = imap->custom_params + 6; + return is_custom_fetch_listing_match(p); + } + } + return FALSE; +} + +/* For LIST and SEARCH responses */ +static CURLcode imap_state_listsearch_resp(struct Curl_easy *data, + struct imap_conn *imapc, + int imapcode, + imapstate instate) +{ + CURLcode result = CURLE_OK; + const char *line = curlx_dyn_ptr(&imapc->pp.recvbuf); + size_t len = imapc->pp.nfinal; + struct IMAP *imap = Curl_meta_get(data, CURL_META_IMAP_EASY); + + DEBUGASSERT(imap); + if(!imap) + return CURLE_FAILED_INIT; + (void)instate; + + if(imapcode == '*' && is_custom_fetch_listing(imap)) { + /* custom FETCH or UID FETCH for listing is not handled here */ + } + else if(imapcode == '*') { + /* Check if this response contains a literal (e.g. FETCH responses with + body data). Literal syntax is {size}\r\n */ + const char *cr = memchr(line, '\r', len); + size_t line_len = cr ? (size_t)(cr - line) : len; + const char *ptr = imap_find_literal(line, line_len); + if(ptr) { + curl_off_t size = 0; + bool parsed = FALSE; + ptr++; + if(!curlx_str_number(&ptr, &size, CURL_OFF_T_MAX) && + !curlx_str_single(&ptr, '}')) + parsed = TRUE; + + if(parsed) { + struct pingpong *pp = &imapc->pp; + size_t buffer_len = curlx_dyn_len(&pp->recvbuf); + size_t after_header = buffer_len - pp->nfinal; + + /* This is a literal response, setup to receive the body data */ + infof(data, "Found %" FMT_OFF_T " bytes to download", size); + + /* First write the header line */ + result = Curl_client_write(data, CLIENTWRITE_BODY, line, len); + if(result) + return result; + + /* Handle data already in buffer after the header line */ + if(after_header > 0) { + /* There is already data in the buffer that is part of the literal + body or subsequent responses */ + size_t chunk = after_header; + + /* Keep only the data after the header line */ + curlx_dyn_tail(&pp->recvbuf, chunk); + pp->nfinal = 0; /* done */ + + /* Limit chunk to the literal size */ + if(chunk > (size_t)size) + chunk = (size_t)size; + + if(chunk) { + /* Write the literal body data */ + result = Curl_client_write(data, CLIENTWRITE_BODY, + curlx_dyn_ptr(&pp->recvbuf), chunk); + if(result) + return result; + } + + /* Handle remaining data in buffer (either more literal data or + subsequent responses) */ + if(after_header > chunk) { + /* Keep the data after the literal body */ + pp->overflow = after_header - chunk; + curlx_dyn_tail(&pp->recvbuf, pp->overflow); + } + else { + pp->overflow = 0; + curlx_dyn_reset(&pp->recvbuf); + } + } + else { + /* No data in buffer yet, reset overflow */ + pp->overflow = 0; + } + + if((CURL_OFF_T_MAX - size) < (curl_off_t)len) + /* unlikely to actually be a transfer this big, but avoid integer + overflow */ + size = CURL_OFF_T_MAX; + else + size += len; + + /* Progress size includes both header line and literal body */ + Curl_pgrsSetDownloadSize(data, size); + + if(data->req.bytecount == size) + /* All data already transferred (header + literal body) */ + Curl_xfer_setup_nop(data); + else { + /* Setup to receive the literal body data. + maxdownload and transfer size include both header line and + literal body */ + data->req.maxdownload = size; + Curl_xfer_setup_recv(data, FIRSTSOCKET, size); + } + /* End of DO phase */ + imap_state(data, imapc, IMAP_STOP); + } + else { + /* Failed to parse literal, write the line */ + result = Curl_client_write(data, CLIENTWRITE_BODY, line, len); + } + } + else { + /* No literal, write the line as-is */ + result = Curl_client_write(data, CLIENTWRITE_BODY, line, len); + } + } + else if(imapcode != IMAP_RESP_OK) + result = CURLE_QUOTE_ERROR; + else + /* End of DO phase */ + imap_state(data, imapc, IMAP_STOP); + + return result; +} + +/* For SELECT responses */ +static CURLcode imap_state_select_resp(struct Curl_easy *data, + struct imap_conn *imapc, + struct IMAP *imap, + int imapcode, + imapstate instate) +{ + CURLcode result = CURLE_OK; + (void)instate; + + if(imapcode == '*') { + /* See if this is an UIDVALIDITY response */ + const char *line = curlx_dyn_ptr(&imapc->pp.recvbuf); + size_t len = curlx_dyn_len(&imapc->pp.recvbuf); + if((len >= 18) && checkprefix("OK [UIDVALIDITY ", &line[2])) { + curl_off_t value; + const char *p = &line[2] + strlen("OK [UIDVALIDITY "); + if(!curlx_str_number(&p, &value, UINT_MAX)) { + imapc->mb_uidvalidity = (unsigned int)value; + imapc->mb_uidvalidity_set = TRUE; + } + } + } + else if(imapcode == IMAP_RESP_OK) { + /* Check if the UIDVALIDITY has been specified and matches */ + if(imap->uidvalidity_set && imapc->mb_uidvalidity_set && + (imap->uidvalidity != imapc->mb_uidvalidity)) { + failf(data, "Mailbox UIDVALIDITY has changed"); + result = CURLE_REMOTE_FILE_NOT_FOUND; + } + else { + /* Note the currently opened mailbox on this connection */ + DEBUGASSERT(!imapc->mailbox); + imapc->mailbox = curlx_strdup(imap->mailbox); + if(!imapc->mailbox) + return CURLE_OUT_OF_MEMORY; + + if(imap->custom) + result = imap_perform_list(data, imapc, imap); + else if(imap->query) + result = imap_perform_search(data, imapc, imap); + else + result = imap_perform_fetch(data, imapc, imap); + } + } + else { + failf(data, "Select failed"); + result = CURLE_LOGIN_DENIED; + } + + return result; +} + +/* For the (first line of the) FETCH responses */ +static CURLcode imap_state_fetch_resp(struct Curl_easy *data, + struct imap_conn *imapc, + int imapcode, + imapstate instate) +{ + CURLcode result = CURLE_OK; + struct pingpong *pp = &imapc->pp; + const char *ptr = curlx_dyn_ptr(&imapc->pp.recvbuf); + size_t len = imapc->pp.nfinal; + bool parsed = FALSE; + curl_off_t size = 0; + + (void)instate; + + if(imapcode != '*') { + Curl_pgrsSetDownloadSize(data, -1); + imap_state(data, imapc, IMAP_STOP); + return CURLE_REMOTE_FILE_NOT_FOUND; + } + + /* Something like this is received "* 1 FETCH (BODY[TEXT] {2021}\r" so parse + the continuation data contained within the curly brackets */ + ptr = imap_find_literal(ptr, len); + if(ptr) { + ptr++; + if(!curlx_str_number(&ptr, &size, CURL_OFF_T_MAX) && + !curlx_str_single(&ptr, '}')) + parsed = TRUE; + } + + if(parsed) { + infof(data, "Found %" FMT_OFF_T " bytes to download", size); + Curl_pgrsSetDownloadSize(data, size); + + if(pp->overflow) { + /* At this point there is a data in the receive buffer that is body + content, send it as body and then skip it. Do note that there may + even be additional "headers" after the body. */ + size_t chunk = pp->overflow; + + /* keep only the overflow */ + curlx_dyn_tail(&pp->recvbuf, chunk); + pp->nfinal = 0; /* done */ + + if(chunk > (size_t)size) + /* The conversion from curl_off_t to size_t is always fine here */ + chunk = (size_t)size; + + if(!chunk) { + /* no size, we are done with the data */ + imap_state(data, imapc, IMAP_STOP); + return CURLE_OK; + } + result = Curl_client_write(data, CLIENTWRITE_BODY, + curlx_dyn_ptr(&pp->recvbuf), chunk); + if(result) + return result; + + infof(data, "Written %zu bytes, %" FMT_OFF_T + " bytes are left for transfer", chunk, (curl_off_t)(size - chunk)); + + /* Have we used the entire overflow or part of it?*/ + if(pp->overflow > chunk) { + /* remember the remaining trailing overflow data */ + pp->overflow -= chunk; + curlx_dyn_tail(&pp->recvbuf, pp->overflow); + } + else { + pp->overflow = 0; /* handled */ + /* Free the cache */ + curlx_dyn_reset(&pp->recvbuf); + } + } + + if(data->req.bytecount == size) + /* The entire data is already transferred! */ + Curl_xfer_setup_nop(data); + else { + /* IMAP download */ + data->req.maxdownload = size; + Curl_xfer_setup_recv(data, FIRSTSOCKET, size); + } + } + else { + /* We do not know how to parse this line */ + failf(data, "Failed to parse FETCH response."); + result = CURLE_WEIRD_SERVER_REPLY; + } + + /* End of DO phase */ + imap_state(data, imapc, IMAP_STOP); + + return result; +} + +/* For final FETCH responses performed after the download */ +static CURLcode imap_state_fetch_final_resp(struct Curl_easy *data, + struct imap_conn *imapc, + int imapcode, + imapstate instate) +{ + CURLcode result = CURLE_OK; + + (void)instate; + + if(imapcode != IMAP_RESP_OK) + result = CURLE_WEIRD_SERVER_REPLY; + else + /* End of DONE phase */ + imap_state(data, imapc, IMAP_STOP); + + return result; +} + +/* For APPEND responses */ +static CURLcode imap_state_append_resp(struct Curl_easy *data, + struct imap_conn *imapc, + int imapcode, + imapstate instate) +{ + CURLcode result = CURLE_OK; + (void)instate; + + if(imapcode != '+') { + result = CURLE_UPLOAD_FAILED; + } + else { + /* Set the progress upload size */ + Curl_pgrsSetUploadSize(data, data->state.infilesize); + + /* IMAP upload */ + Curl_xfer_setup_send(data, FIRSTSOCKET); + + /* End of DO phase */ + imap_state(data, imapc, IMAP_STOP); + } + + return result; +} + +/* For final APPEND responses performed after the upload */ +static CURLcode imap_state_append_final_resp(struct Curl_easy *data, + struct imap_conn *imapc, + int imapcode, + imapstate instate) +{ + CURLcode result = CURLE_OK; + + (void)instate; + + if(imapcode != IMAP_RESP_OK) + result = CURLE_UPLOAD_FAILED; + else + /* End of DONE phase */ + imap_state(data, imapc, IMAP_STOP); + + return result; +} + +static CURLcode imap_pp_statemachine(struct Curl_easy *data, + struct connectdata *conn) +{ + CURLcode result = CURLE_OK; + int imapcode; + struct imap_conn *imapc = Curl_conn_meta_get(conn, CURL_META_IMAP_CONN); + struct IMAP *imap = Curl_meta_get(data, CURL_META_IMAP_EASY); + struct pingpong *pp; + size_t nread = 0; + + if(!imapc || !imap) + return CURLE_FAILED_INIT; + pp = &imapc->pp; + /* Busy upgrading the connection; right now all I/O is SSL/TLS, not IMAP */ +upgrade_tls: + if(imapc->state == IMAP_UPGRADETLS) { + result = imap_perform_upgrade_tls(data, imapc, conn); + if(result || (imapc->state == IMAP_UPGRADETLS)) + return result; + } + + /* Flush any data that needs to be sent */ + if(pp->sendleft) + return Curl_pp_flushsend(data, pp); + + do { + /* Read the response from the server */ + result = Curl_pp_readresp(data, FIRSTSOCKET, pp, &imapcode, &nread); + if(result) + return result; + + /* Was there an error parsing the response line? */ + if(imapcode == -1) + return CURLE_WEIRD_SERVER_REPLY; + + if(!imapcode) + break; + + /* We have now received a full IMAP server response */ + switch(imapc->state) { + case IMAP_SERVERGREET: + result = imap_state_servergreet_resp(data, imapc, + imapcode, imapc->state); + break; + + case IMAP_CAPABILITY: + result = imap_state_capability_resp(data, imapc, imapcode, imapc->state); + break; + + case IMAP_STARTTLS: + result = imap_state_starttls_resp(data, imapc, imapcode, imapc->state); + /* During UPGRADETLS, leave the read loop as we need to connect + * (e.g. TLS handshake) before we continue sending/receiving. */ + if(!result && (imapc->state == IMAP_UPGRADETLS)) + goto upgrade_tls; + break; + + case IMAP_AUTHENTICATE: + result = imap_state_auth_resp(data, imapc, imapcode, imapc->state); + break; + + case IMAP_LOGIN: + result = imap_state_login_resp(data, imapc, imapcode, imapc->state); + break; + + case IMAP_LIST: + case IMAP_SEARCH: + result = imap_state_listsearch_resp(data, imapc, imapcode, imapc->state); + break; + + case IMAP_SELECT: + result = imap_state_select_resp(data, imapc, imap, + imapcode, imapc->state); + break; + + case IMAP_FETCH: + result = imap_state_fetch_resp(data, imapc, imapcode, imapc->state); + break; + + case IMAP_FETCH_FINAL: + result = imap_state_fetch_final_resp(data, imapc, + imapcode, imapc->state); + break; + + case IMAP_APPEND: + result = imap_state_append_resp(data, imapc, imapcode, imapc->state); + break; + + case IMAP_APPEND_FINAL: + result = imap_state_append_final_resp(data, imapc, + imapcode, imapc->state); + break; + + case IMAP_LOGOUT: + default: + /* internal error */ + imap_state(data, imapc, IMAP_STOP); + break; + } + } while(!result && imapc->state != IMAP_STOP && Curl_pp_moredata(pp)); + + return result; +} + +/* Called repeatedly until done from multi.c */ +static CURLcode imap_multi_statemach(struct Curl_easy *data, bool *done) +{ + CURLcode result = CURLE_OK; + struct imap_conn *imapc = + Curl_conn_meta_get(data->conn, CURL_META_IMAP_CONN); + + *done = FALSE; + if(!imapc) + return CURLE_FAILED_INIT; + result = Curl_pp_statemach(data, &imapc->pp, FALSE, FALSE); + *done = (imapc->state == IMAP_STOP); + + return result; +} + +static CURLcode imap_block_statemach(struct Curl_easy *data, + struct imap_conn *imapc, + bool disconnecting) +{ + CURLcode result = CURLE_OK; + + while(imapc->state != IMAP_STOP && !result) + result = Curl_pp_statemach(data, &imapc->pp, TRUE, disconnecting); + + return result; +} + +/* For the IMAP "protocol connect" and "doing" phases only */ +static CURLcode imap_pollset(struct Curl_easy *data, + struct easy_pollset *ps) +{ + struct imap_conn *imapc = + Curl_conn_meta_get(data->conn, CURL_META_IMAP_CONN); + return imapc ? Curl_pp_pollset(data, &imapc->pp, ps) : CURLE_OK; +} + +static void imap_easy_reset(struct IMAP *imap) +{ + curlx_safefree(imap->mailbox); + curlx_safefree(imap->uid); + curlx_safefree(imap->mindex); + curlx_safefree(imap->section); + curlx_safefree(imap->partial); + curlx_safefree(imap->query); + curlx_safefree(imap->custom); + curlx_safefree(imap->custom_params); + imap->uidvalidity_set = FALSE; + /* Clear the transfer mode for the next request */ + imap->transfer = PPTRANSFER_BODY; +} + +/*********************************************************************** + * + * imap_is_bchar() + * + * Portable test of whether the specified char is a "bchar" as defined in the + * grammar of RFC-5092. + */ +static bool imap_is_bchar(char ch) +{ + /* Performing the alnum check first with macro is faster because of ASCII + arithmetic */ + return ch && (ISALNUM(ch) || strchr(":@/&=-._~!$\'()*+,%", ch)); +} + +/*********************************************************************** + * + * imap_parse_url_options() + * + * Parse the URL login options. + */ +static CURLcode imap_parse_url_options(struct connectdata *conn, + struct imap_conn *imapc) +{ + CURLcode result = CURLE_OK; + const char *ptr = conn->options; + bool prefer_login = FALSE; + + while(!result && ptr && *ptr) { + const char *key = ptr; + const char *value; + + while(*ptr && *ptr != '=') + ptr++; + + value = ptr + 1; + + while(*ptr && *ptr != ';') + ptr++; + + if(curl_strnequal(key, "AUTH=+LOGIN", 11)) { + /* User prefers plaintext LOGIN over any SASL, including SASL LOGIN */ + prefer_login = TRUE; + imapc->sasl.prefmech = SASL_AUTH_NONE; + } + else if(curl_strnequal(key, "AUTH=", 5)) { + prefer_login = FALSE; + result = Curl_sasl_parse_url_auth_option(&imapc->sasl, + value, ptr - value); + } + else { + prefer_login = FALSE; + result = CURLE_URL_MALFORMAT; + } + + if(*ptr == ';') + ptr++; + } + + if(prefer_login) + imapc->preftype = IMAP_TYPE_CLEARTEXT; + else { + switch(imapc->sasl.prefmech) { + case SASL_AUTH_NONE: + imapc->preftype = IMAP_TYPE_NONE; + break; + case SASL_AUTH_DEFAULT: + imapc->preftype = IMAP_TYPE_ANY; + break; + default: + imapc->preftype = IMAP_TYPE_SASL; + break; + } + } + + return result; +} + +/*********************************************************************** + * + * imap_parse_url_path() + * + * Parse the URL path into separate path components. + * + */ +static CURLcode imap_parse_url_path(struct Curl_easy *data, + struct IMAP *imap) +{ + /* The imap struct is already initialized in imap_connect() */ + CURLcode result = CURLE_OK; + const char *begin = &data->state.up.path[1]; /* skip leading slash */ + const char *ptr = begin; + + /* See how much of the URL is a valid path and decode it */ + while(imap_is_bchar(*ptr)) + ptr++; + + if(ptr != begin) { + /* Remove the trailing slash if present */ + const char *end = ptr; + if(end > begin && end[-1] == '/') + end--; + + result = Curl_urldecode(begin, end - begin, &imap->mailbox, NULL, + REJECT_CTRL); + if(result) + return result; + } + else + imap->mailbox = NULL; + + /* There can be any number of parameters in the form ";NAME=VALUE" */ + while(*ptr == ';') { + char *name; + char *value; + size_t valuelen; + + /* Find the length of the name parameter */ + begin = ++ptr; + while(*ptr && *ptr != '=') + ptr++; + + if(!*ptr) + return CURLE_URL_MALFORMAT; + + /* Decode the name parameter */ + result = Curl_urldecode(begin, ptr - begin, &name, NULL, + REJECT_CTRL); + if(result) + return result; + + /* Find the length of the value parameter */ + begin = ++ptr; + while(imap_is_bchar(*ptr)) + ptr++; + + /* Decode the value parameter */ + result = Curl_urldecode(begin, ptr - begin, &value, &valuelen, + REJECT_CTRL); + if(result) { + curlx_free(name); + return result; + } + + DEBUGF(infof(data, "IMAP URL parameter '%s' = '%s'", name, value)); + + /* Process the known hierarchical parameters (UIDVALIDITY, UID, SECTION + and PARTIAL) stripping of the trailing slash character if it is + present. + + Note: Unknown parameters trigger a URL_MALFORMAT error. */ + if(valuelen > 0 && value[valuelen - 1] == '/') + value[valuelen - 1] = '\0'; + if(valuelen) { + if(curl_strequal(name, "UIDVALIDITY") && !imap->uidvalidity_set) { + curl_off_t num; + const char *p = (const char *)value; + if(!curlx_str_number(&p, &num, UINT_MAX)) { + imap->uidvalidity = (unsigned int)num; + imap->uidvalidity_set = TRUE; + } + curlx_free(value); + } + else if(curl_strequal(name, "UID") && !imap->uid) { + imap->uid = value; + } + else if(curl_strequal(name, "MAILINDEX") && !imap->mindex) { + imap->mindex = value; + } + else if(curl_strequal(name, "SECTION") && !imap->section) { + imap->section = value; + } + else if(curl_strequal(name, "PARTIAL") && !imap->partial) { + imap->partial = value; + } + else { + curlx_free(name); + curlx_free(value); + return CURLE_URL_MALFORMAT; + } + } + else + /* blank? */ + curlx_free(value); + curlx_free(name); + } + + /* Does the URL contain a query parameter? Only valid when we have a mailbox + and no UID as per RFC-5092 */ + if(imap->mailbox && !imap->uid && !imap->mindex) { + /* Get the query parameter, URL decoded */ + CURLUcode uc = curl_url_get(data->state.uh, CURLUPART_QUERY, &imap->query, + CURLU_URLDECODE); + if(uc == CURLUE_OUT_OF_MEMORY) + return CURLE_OUT_OF_MEMORY; + } + + /* Any extra stuff at the end of the URL is an error */ + if(*ptr) + return CURLE_URL_MALFORMAT; + + return CURLE_OK; +} + +/*********************************************************************** + * + * imap_parse_custom_request() + * + * Parse the custom request. + */ +static CURLcode imap_parse_custom_request(struct Curl_easy *data, + struct IMAP *imap) +{ + CURLcode result = CURLE_OK; + const char *custom = data->set.str[STRING_CUSTOMREQUEST]; + + if(custom) { + /* URL decode the custom request */ + result = Curl_urldecode(custom, 0, &imap->custom, NULL, REJECT_CTRL); + + /* Extract the parameters if specified */ + if(!result) { + const char *params = imap->custom; + + while(*params && *params != ' ') + params++; + + if(*params) { + imap->custom_params = curlx_strdup(params); + imap->custom[params - imap->custom] = '\0'; + + if(!imap->custom_params) + result = CURLE_OUT_OF_MEMORY; + } + } + } + + return result; +} + +/*********************************************************************** + * + * imap_connect() + * + * This function should do everything that is to be considered a part of the + * connection phase. + * + * The variable 'done' points to will be TRUE if the protocol-layer connect + * phase is done when this function returns, or FALSE if not. + */ +static CURLcode imap_connect(struct Curl_easy *data, bool *done) +{ + struct imap_conn *imapc = + Curl_conn_meta_get(data->conn, CURL_META_IMAP_CONN); + CURLcode result = CURLE_OK; + + *done = FALSE; /* default to not done yet */ + if(!imapc) + return CURLE_FAILED_INIT; + + /* Parse the URL options */ + result = imap_parse_url_options(data->conn, imapc); + if(result) + return result; + + /* Start off waiting for the server greeting response */ + imap_state(data, imapc, IMAP_SERVERGREET); + + /* Start off with an response id of '*' */ + curlx_strcopy(imapc->resptag, sizeof(imapc->resptag), STRCONST("*")); + + result = imap_multi_statemach(data, done); + + return result; +} + +/*********************************************************************** + * + * imap_done() + * + * The DONE function. This does what needs to be done after a single DO has + * performed. + * + * Input argument is already checked for validity. + */ +static CURLcode imap_done(struct Curl_easy *data, CURLcode status, + bool premature) +{ + CURLcode result = CURLE_OK; + struct connectdata *conn = data->conn; + struct imap_conn *imapc = Curl_conn_meta_get(conn, CURL_META_IMAP_CONN); + struct IMAP *imap = Curl_meta_get(data, CURL_META_IMAP_EASY); + + (void)premature; + + if(!imapc) + return CURLE_FAILED_INIT; + if(!imap) + return CURLE_OK; + + if(status) { + connclose(conn, "IMAP done with bad status"); /* marked for closure */ + result = status; /* use the already set error code */ + } + else if(!data->set.connect_only && + ((!imap->custom && (imap->uid || imap->mindex)) || + (imap->custom && data->req.maxdownload > 0) || + data->state.upload || IS_MIME_POST(data))) { + /* Handle responses after FETCH or APPEND transfer has finished. + For custom commands, check if we set up a download which indicates + a FETCH-like command with literal data. */ + + if(!data->state.upload && !IS_MIME_POST(data)) + imap_state(data, imapc, IMAP_FETCH_FINAL); + else { + /* End the APPEND command first by sending an empty line */ + result = Curl_pp_sendf(data, &imapc->pp, "%s", ""); + if(!result) + imap_state(data, imapc, IMAP_APPEND_FINAL); + } + + /* Run the state-machine */ + if(!result) + result = imap_block_statemach(data, imapc, FALSE); + } + + imap_easy_reset(imap); + return result; +} + +/*********************************************************************** + * + * imap_perform() + * + * This is the actual DO function for IMAP. Fetch or append a message, or do + * other things according to the options previously setup. + */ +static CURLcode imap_perform(struct Curl_easy *data, bool *connected, + bool *dophase_done) +{ + /* This is IMAP and no proxy */ + CURLcode result = CURLE_OK; + struct connectdata *conn = data->conn; + struct imap_conn *imapc = Curl_conn_meta_get(conn, CURL_META_IMAP_CONN); + struct IMAP *imap = Curl_meta_get(data, CURL_META_IMAP_EASY); + bool selected = FALSE; + + DEBUGF(infof(data, "DO phase starts")); + if(!imapc || !imap) + return CURLE_FAILED_INIT; + + if(data->req.no_body) { + /* Requested no body means no transfer */ + imap->transfer = PPTRANSFER_INFO; + } + + *dophase_done = FALSE; /* not done yet */ + + /* Determine if the requested mailbox (with the same UIDVALIDITY if set) + has already been selected on this connection */ + if(imap->mailbox && imapc->mailbox && + curl_strequal(imap->mailbox, imapc->mailbox) && + (!imap->uidvalidity_set || !imapc->mb_uidvalidity_set || + (imap->uidvalidity == imapc->mb_uidvalidity))) + selected = TRUE; + + /* Start the first command in the DO phase */ + if(data->state.upload || IS_MIME_POST(data)) + /* APPEND can be executed directly */ + result = imap_perform_append(data, imapc, imap); + else if(imap->custom && (selected || !imap->mailbox)) + /* Custom command using the same mailbox or no mailbox */ + result = imap_perform_list(data, imapc, imap); + else if(!imap->custom && selected && (imap->uid || imap->mindex)) + /* FETCH from the same mailbox */ + result = imap_perform_fetch(data, imapc, imap); + else if(!imap->custom && selected && imap->query) + /* SEARCH the current mailbox */ + result = imap_perform_search(data, imapc, imap); + else if(imap->mailbox && !selected && + (imap->custom || imap->uid || imap->mindex || imap->query)) + /* SELECT the mailbox */ + result = imap_perform_select(data, imapc, imap); + else + /* LIST */ + result = imap_perform_list(data, imapc, imap); + + if(result) + return result; + + /* Run the state-machine */ + result = imap_multi_statemach(data, dophase_done); + + *connected = Curl_conn_is_connected(conn, FIRSTSOCKET); + + if(*dophase_done) + DEBUGF(infof(data, "DO phase is complete")); + + return result; +} + +/* Call this when the DO phase has completed */ +static CURLcode imap_dophase_done(struct Curl_easy *data, + struct IMAP *imap, + bool connected) +{ + (void)connected; + + if(imap->transfer != PPTRANSFER_BODY) + /* no data to transfer */ + Curl_xfer_setup_nop(data); + + return CURLE_OK; +} + +/*********************************************************************** + * + * imap_regular_transfer() + * + * The input argument is already checked for validity. + * + * Performs all commands done before a regular transfer between a local and a + * remote host. + */ +static CURLcode imap_regular_transfer(struct Curl_easy *data, + struct IMAP *imap, + bool *dophase_done) +{ + CURLcode result = CURLE_OK; + bool connected = FALSE; + + /* Make sure size is unknown at this point */ + data->req.size = -1; + + /* Set the progress data */ + Curl_pgrsReset(data); + + /* Carry out the perform */ + result = imap_perform(data, &connected, dophase_done); + + /* Perform post DO phase operations if necessary */ + if(!result && *dophase_done) + result = imap_dophase_done(data, imap, connected); + + return result; +} + +/*********************************************************************** + * + * imap_do() + * + * This function is registered as 'curl_do' function. It decodes the path + * parts etc as a wrapper to the actual DO function (imap_perform). + * + * The input argument is already checked for validity. + */ +static CURLcode imap_do(struct Curl_easy *data, bool *done) +{ + struct IMAP *imap = Curl_meta_get(data, CURL_META_IMAP_EASY); + CURLcode result = CURLE_OK; + *done = FALSE; /* default to false */ + + if(!imap) + return CURLE_FAILED_INIT; + /* Parse the URL path */ + result = imap_parse_url_path(data, imap); + if(result) + return result; + + /* Parse the custom request */ + result = imap_parse_custom_request(data, imap); + if(result) + return result; + + result = imap_regular_transfer(data, imap, done); + + return result; +} + +/*********************************************************************** + * + * imap_disconnect() + * + * Disconnect from an IMAP server. Cleanup protocol-specific per-connection + * resources. BLOCKING. + */ +static CURLcode imap_disconnect(struct Curl_easy *data, + struct connectdata *conn, bool dead_connection) +{ + struct imap_conn *imapc = Curl_conn_meta_get(conn, CURL_META_IMAP_CONN); + + if(imapc) { + /* We cannot send quit unconditionally. If this connection is stale or + bad in any way (pingpong has pending data to send), + sending quit and waiting around here will make the + disconnect wait in vain and cause more problems than we need to. */ + if(!dead_connection && conn->bits.protoconnstart && + !Curl_pp_needs_flush(data, &imapc->pp)) { + if(!imap_perform_logout(data, imapc)) + (void)imap_block_statemach(data, imapc, TRUE); /* ignore errors */ + } + } + return CURLE_OK; +} + +/* Called from multi.c while DOing */ +static CURLcode imap_doing(struct Curl_easy *data, bool *dophase_done) +{ + struct IMAP *imap = Curl_meta_get(data, CURL_META_IMAP_EASY); + CURLcode result; + + if(!imap) + return CURLE_FAILED_INIT; + + result = imap_multi_statemach(data, dophase_done); + if(result) + DEBUGF(infof(data, "DO phase failed")); + else if(*dophase_done) { + result = imap_dophase_done(data, imap, FALSE /* not connected */); + + DEBUGF(infof(data, "DO phase is complete")); + } + + return result; +} + +static void imap_easy_dtor(void *key, size_t klen, void *entry) +{ + struct IMAP *imap = entry; + (void)key; + (void)klen; + imap_easy_reset(imap); + curlx_free(imap); +} + +static void imap_conn_dtor(void *key, size_t klen, void *entry) +{ + struct imap_conn *imapc = entry; + (void)key; + (void)klen; + Curl_pp_disconnect(&imapc->pp); + curlx_dyn_free(&imapc->dyn); + curlx_safefree(imapc->mailbox); + curlx_free(imapc); +} + +/* SASL parameters for the imap protocol */ +static const struct SASLproto saslimap = { + "imap", /* The service name */ + imap_perform_authenticate, /* Send authentication command */ + imap_continue_authenticate, /* Send authentication continuation */ + imap_cancel_authenticate, /* Send authentication cancellation */ + imap_get_message, /* Get SASL response message */ + 0, /* No maximum initial response length */ + '+', /* Code received when continuation is expected */ + IMAP_RESP_OK, /* Code to receive upon authentication success */ + SASL_AUTH_DEFAULT, /* Default mechanisms */ + SASL_FLAG_BASE64 /* Configuration flags */ +}; + +static CURLcode imap_setup_connection(struct Curl_easy *data, + struct connectdata *conn) +{ + struct imap_conn *imapc; + struct pingpong *pp; + struct IMAP *imap; + + imapc = curlx_calloc(1, sizeof(*imapc)); + if(!imapc) + return CURLE_OUT_OF_MEMORY; + + pp = &imapc->pp; + PINGPONG_SETUP(pp, imap_pp_statemachine, imap_endofresp); + + /* Set the default preferred authentication type and mechanism */ + imapc->preftype = IMAP_TYPE_ANY; + Curl_sasl_init(&imapc->sasl, data, &saslimap); + + curlx_dyn_init(&imapc->dyn, DYN_IMAP_CMD); + Curl_pp_init(pp, Curl_pgrs_now(data)); + + if(Curl_conn_meta_set(conn, CURL_META_IMAP_CONN, imapc, imap_conn_dtor)) + return CURLE_OUT_OF_MEMORY; + + imap = curlx_calloc(1, sizeof(struct IMAP)); + if(!imap || + Curl_meta_set(data, CURL_META_IMAP_EASY, imap, imap_easy_dtor)) + return CURLE_OUT_OF_MEMORY; + + return CURLE_OK; +} + +/* + * IMAP protocol. + */ +const struct Curl_protocol Curl_protocol_imap = { + imap_setup_connection, /* setup_connection */ + imap_do, /* do_it */ + imap_done, /* done */ + ZERO_NULL, /* do_more */ + imap_connect, /* connect_it */ + imap_multi_statemach, /* connecting */ + imap_doing, /* doing */ + imap_pollset, /* proto_pollset */ + imap_pollset, /* doing_pollset */ + ZERO_NULL, /* domore_pollset */ + ZERO_NULL, /* perform_pollset */ + imap_disconnect, /* disconnect */ + ZERO_NULL, /* write_resp */ + ZERO_NULL, /* write_resp_hd */ + ZERO_NULL, /* connection_is_dead */ + ZERO_NULL, /* attach connection */ + ZERO_NULL, /* follow */ +}; + +#endif /* CURL_DISABLE_IMAP */ diff --git a/3rdparty/curl-8.21.0/lib/imap.h b/3rdparty/curl-8.21.0/lib/imap.h new file mode 100644 index 0000000000..ecfb1ec9b9 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/imap.h @@ -0,0 +1,39 @@ +#ifndef HEADER_CURL_IMAP_H +#define HEADER_CURL_IMAP_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +/* Authentication type flags */ +#define IMAP_TYPE_CLEARTEXT (1 << 0) +#define IMAP_TYPE_SASL (1 << 1) + +/* Authentication type values */ +#define IMAP_TYPE_NONE 0 +#define IMAP_TYPE_ANY (IMAP_TYPE_CLEARTEXT | IMAP_TYPE_SASL) + +#ifndef CURL_DISABLE_IMAP +extern const struct Curl_protocol Curl_protocol_imap; +#endif + +#endif /* HEADER_CURL_IMAP_H */ diff --git a/3rdparty/curl-8.21.0/lib/ldap.c b/3rdparty/curl-8.21.0/lib/ldap.c new file mode 100644 index 0000000000..a6a69eb7f1 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/ldap.c @@ -0,0 +1,1015 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" +#include "urldata.h" +#include "curl_ldap.h" + +#if !defined(CURL_DISABLE_LDAP) && !defined(USE_OPENLDAP) + +#if defined(CURL_HAVE_DIAG) && defined(__APPLE__) +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Wdeprecated-declarations" +#endif + +/* + * Notice that USE_OPENLDAP is only a source code selection switch. When + * libcurl is built with USE_OPENLDAP defined the libcurl source code that + * gets compiled is the code from openldap.c, otherwise the code that gets + * compiled is the code from ldap.c. + * + * When USE_OPENLDAP is defined a recent version of the OpenLDAP library + * might be required for compilation and runtime. In order to use ancient + * OpenLDAP library versions, USE_OPENLDAP shall not be defined. + */ + +#ifdef USE_WIN32_LDAP /* Use Windows LDAP implementation. */ +# include +/* Undefine indirect symbols conflicting with AWS-LC/BoringSSL. */ +# undef X509_NAME +# undef X509_EXTENSIONS +# undef PKCS7_ISSUER_AND_SERIAL +# undef PKCS7_SIGNER_INFO +# undef OCSP_REQUEST +# undef OCSP_RESPONSE +# include +#else +# define LDAP_DEPRECATED 1 /* Be sure ldap_init() is defined. */ +# ifdef HAVE_LBER_H +# include +# endif +# include +# if defined(HAVE_LDAP_SSL) && defined(HAVE_LDAP_SSL_H) +# include +# endif /* HAVE_LDAP_SSL && HAVE_LDAP_SSL_H */ +#endif + +#include "cfilters.h" +#include "sendf.h" +#include "curl_trc.h" +#include "escape.h" +#include "progress.h" +#include "transfer.h" +#include "curlx/strparse.h" +#include "bufref.h" +#include "curlx/multibyte.h" +#include "curlx/base64.h" +#include "connect.h" + +#ifdef USE_WIN32_LDAP +#define FREE_ON_WINLDAP(x) curlx_free(x) +#define curl_ldap_num_t ULONG +#else +#define FREE_ON_WINLDAP(x) do {} while(0) +#define curl_ldap_num_t int +#endif + +#ifndef HAVE_LDAP_URL_PARSE + +/* Use our own implementation. */ + +struct ldap_urldesc { + char *lud_host; + int lud_port; +#ifdef USE_WIN32_LDAP + TCHAR *lud_dn; + TCHAR **lud_attrs; +#else + char *lud_dn; + char **lud_attrs; +#endif + int lud_scope; +#ifdef USE_WIN32_LDAP + TCHAR *lud_filter; +#else + char *lud_filter; +#endif + char **lud_exts; + size_t lud_attrs_dups; /* how many were dup'ed, this field is not in the + "real" struct so can only be used in code + without HAVE_LDAP_URL_PARSE defined */ +}; + +#undef LDAPURLDesc +#define LDAPURLDesc struct ldap_urldesc + +static curl_ldap_num_t ldap_url_parse_low(struct Curl_easy *data, + const struct connectdata *conn, + LDAPURLDesc **ludpp); +static void ldap_free_urldesc_low(LDAPURLDesc *ludp); + +#undef ldap_free_urldesc +#define ldap_free_urldesc ldap_free_urldesc_low + +#endif /* !HAVE_LDAP_URL_PARSE */ + +#ifdef DEBUG_LDAP +#define LDAP_TRACE(x) \ + do { \ + ldap_trace_low("%u: ", __LINE__); \ + ldap_trace_low x; \ + } while(0) + +static void ldap_trace_low(const char *fmt, ...) CURL_PRINTF(1, 2); +#else +#define LDAP_TRACE(x) Curl_nop_stmt +#endif + +#if defined(USE_WIN32_LDAP) && defined(ldap_err2string) +/* Use ANSI error strings in Unicode builds */ +#undef ldap_err2string +#define ldap_err2string ldap_err2stringA +#endif + +#if defined(USE_WIN32_LDAP) && defined(_MSC_VER) && (_MSC_VER <= 1700) +/* Workaround for warning: + 'type cast' : conversion from 'int' to 'void *' of greater size */ +#undef LDAP_OPT_ON +#undef LDAP_OPT_OFF +#define LDAP_OPT_ON ((void *)(size_t)1) +#define LDAP_OPT_OFF ((void *)(size_t)0) +#endif + +#ifdef USE_WIN32_LDAP + +#ifdef USE_WINDOWS_SSPI +static ULONG ldap_win_bind_auth(LDAP *server, const char *user, + const char *passwd, unsigned long authflags) +{ + ULONG method = 0; + SEC_WINNT_AUTH_IDENTITY cred; + ULONG rc = LDAP_AUTH_METHOD_NOT_SUPPORTED; + + memset(&cred, 0, sizeof(cred)); + +#ifdef USE_SPNEGO + if(authflags & CURLAUTH_NEGOTIATE) { + method = LDAP_AUTH_NEGOTIATE; + } + else +#endif +#ifdef USE_NTLM + if(authflags & CURLAUTH_NTLM) { + method = LDAP_AUTH_NTLM; + } + else +#endif +#ifndef CURL_DISABLE_DIGEST_AUTH + if(authflags & CURLAUTH_DIGEST) { + method = LDAP_AUTH_DIGEST; + } + else +#endif + { + /* required anyway if one of upper preprocessor definitions enabled */ + } + + if(method && user && passwd) { + CURLcode result = Curl_create_sspi_identity(user, passwd, &cred); + if(!result) { + rc = ldap_bind_s(server, NULL, (TCHAR *)&cred, method); + Curl_sspi_free_identity(&cred); + } + else { + rc = LDAP_NO_MEMORY; + } + } + else { + /* proceed with current user credentials */ + method = LDAP_AUTH_NEGOTIATE; + rc = ldap_bind_s(server, NULL, NULL, method); + } + return rc; +} +#endif /* USE_WINDOWS_SSPI */ + +static ULONG ldap_win_bind(struct Curl_easy *data, LDAP *server, + const char *user, const char *passwd) +{ + ULONG rc = LDAP_INVALID_CREDENTIALS; + + PTCHAR inuser = NULL; + PTCHAR inpass = NULL; + + if(user && passwd && (data->set.httpauth & CURLAUTH_BASIC)) { + inuser = curlx_convert_UTF8_to_tchar(user); + inpass = curlx_convert_UTF8_to_tchar(passwd); + + rc = ldap_simple_bind_s(server, inuser, inpass); + + curlx_free(inuser); + curlx_free(inpass); + } +#ifdef USE_WINDOWS_SSPI + else { + rc = ldap_win_bind_auth(server, user, passwd, data->set.httpauth); + } +#endif + + return rc; +} +#endif /* USE_WIN32_LDAP */ + +static bool ldap_value_needs_base64(const char *attr, size_t attr_len, + const BerValue *val) +{ + ber_len_t j; + + if((attr_len > 7) && curl_strequal(";binary", attr + attr_len - 7)) + return TRUE; + + /* check for leading or trailing whitespace */ + if(val->bv_len && (ISBLANK(val->bv_val[0]) || + ISBLANK(val->bv_val[val->bv_len - 1]))) + return TRUE; + + /* check for unprintable characters */ + for(j = 0; j < val->bv_len; j++) + if(!ISPRINT(val->bv_val[j])) + return TRUE; + + return FALSE; +} + +static CURLcode ldap_do(struct Curl_easy *data, bool *done) +{ + CURLcode result = CURLE_OK; + curl_ldap_num_t rc = LDAP_SUCCESS; + LDAP *server = NULL; + LDAPURLDesc *ludp = NULL; + LDAPMessage *ldapmsg = NULL; + LDAPMessage *entryIterator; + int num = 0; + struct connectdata *conn = data->conn; + int ldap_proto = LDAP_VERSION3; + int ldap_ssl = 0; +#ifdef LDAP_OPT_NETWORK_TIMEOUT + struct timeval ldap_timeout = { 10, 0 }; /* 10s connection/search timeout */ +#endif +#ifdef USE_WIN32_LDAP + TCHAR *host = NULL; +#else + char *host = NULL; +#endif + const char *user = Curl_creds_has_user(data->state.creds) ? + data->state.creds->user : NULL; + const char *passwd = Curl_creds_has_passwd(data->state.creds) ? + data->state.creds->passwd : NULL; + struct ip_quadruple ipquad; + bool is_ipv6; + BerElement *ber = NULL; + + *done = TRUE; /* unconditionally */ + infof(data, "LDAP local: LDAP Vendor = %s ; LDAP Version = %d", + LDAP_VENDOR_NAME, LDAP_VENDOR_VERSION); + infof(data, "LDAP local: %s", Curl_bufref_ptr(&data->state.url)); + +#ifdef HAVE_LDAP_URL_PARSE + rc = ldap_url_parse(Curl_bufref_ptr(&data->state.url), &ludp); +#else + rc = ldap_url_parse_low(data, conn, &ludp); +#endif + if(rc) { + failf(data, "Bad LDAP URL: %s", ldap_err2string(rc)); + result = CURLE_URL_MALFORMAT; + goto quit; + } + + result = Curl_conn_get_ip_info(data, conn, FIRSTSOCKET, &is_ipv6, &ipquad); + if(result) + goto quit; + + /* Get the URL scheme (either ldap or ldaps) */ + if(Curl_conn_is_ssl(conn, FIRSTSOCKET)) + ldap_ssl = 1; + infof(data, "LDAP local: trying to establish %s connection", + ldap_ssl ? "encrypted" : "cleartext"); + +#ifdef USE_WIN32_LDAP + host = curlx_convert_UTF8_to_tchar(conn->origin->hostname); + if(!host) { + result = CURLE_OUT_OF_MEMORY; + + goto quit; + } +#else + host = conn->origin->hostname; +#endif + +#ifdef USE_WIN32_LDAP + if(ldap_ssl) + server = ldap_sslinit(host, (curl_ldap_num_t)ipquad.remote_port, 1); + else +#endif + server = ldap_init(host, (curl_ldap_num_t)ipquad.remote_port); + if(!server) { + failf(data, "LDAP: cannot setup connect to %s:%u", + conn->origin->user_hostname, ipquad.remote_port); + result = CURLE_COULDNT_CONNECT; + goto quit; + } + +#ifdef LDAP_OPT_NETWORK_TIMEOUT + ldap_set_option(server, LDAP_OPT_NETWORK_TIMEOUT, &ldap_timeout); +#endif + ldap_set_option(server, LDAP_OPT_PROTOCOL_VERSION, &ldap_proto); + + /* Do not chase referrals. */ + ldap_set_option(server, LDAP_OPT_REFERRALS, LDAP_OPT_OFF); + + if(ldap_ssl) { +#ifdef HAVE_LDAP_SSL +#ifdef USE_WIN32_LDAP + /* Win32 LDAP SDK does not support insecure mode without CA! */ + ldap_set_option(server, LDAP_OPT_SSL, LDAP_OPT_ON); +#else /* !USE_WIN32_LDAP */ + int ldap_option; + const char *ldap_ca = conn->ssl_config.CAfile; +#ifdef LDAP_OPT_X_TLS + if(conn->ssl_config.verifypeer) { + /* OpenLDAP SDK supports BASE64 files. */ + if(data->set.ssl.primary.cert_type && + !curl_strequal(data->set.ssl.primary.cert_type, "PEM")) { + failf(data, "LDAP local: ERROR OpenLDAP only supports PEM cert-type"); + result = CURLE_SSL_CERTPROBLEM; + goto quit; + } + if(!ldap_ca) { + failf(data, "LDAP local: ERROR PEM CA cert not set"); + result = CURLE_SSL_CERTPROBLEM; + goto quit; + } + infof(data, "LDAP local: using PEM CA cert: %s", ldap_ca); + rc = ldap_set_option(server, LDAP_OPT_X_TLS_CACERTFILE, ldap_ca); + if(rc != LDAP_SUCCESS) { + failf(data, "LDAP local: ERROR setting PEM CA cert: %s", + ldap_err2string(rc)); + result = CURLE_SSL_CERTPROBLEM; + goto quit; + } + ldap_option = LDAP_OPT_X_TLS_DEMAND; + } + else + ldap_option = LDAP_OPT_X_TLS_NEVER; + + rc = ldap_set_option(server, LDAP_OPT_X_TLS_REQUIRE_CERT, &ldap_option); + if(rc != LDAP_SUCCESS) { + failf(data, "LDAP local: ERROR setting cert verify mode: %s", + ldap_err2string(rc)); + result = CURLE_SSL_CERTPROBLEM; + goto quit; + } + ldap_option = LDAP_OPT_X_TLS_HARD; + rc = ldap_set_option(server, LDAP_OPT_X_TLS, &ldap_option); + if(rc != LDAP_SUCCESS) { + failf(data, "LDAP local: ERROR setting SSL/TLS mode: %s", + ldap_err2string(rc)); + result = CURLE_SSL_CERTPROBLEM; + goto quit; + } +#else /* !LDAP_OPT_X_TLS */ + (void)ldap_option; + (void)ldap_ca; + /* we should probably never come up to here since configure + should check in first place if we can support LDAP SSL/TLS */ + failf(data, "LDAP local: SSL/TLS not supported with this version " + "of the OpenLDAP toolkit"); + result = CURLE_SSL_CERTPROBLEM; + goto quit; +#endif /* LDAP_OPT_X_TLS */ +#endif /* USE_WIN32_LDAP */ +#endif /* HAVE_LDAP_SSL */ + } + else if(data->set.use_ssl > CURLUSESSL_TRY) { + failf(data, "LDAP local: explicit TLS not supported"); + result = CURLE_NOT_BUILT_IN; + goto quit; + } + +#ifdef USE_WIN32_LDAP + rc = ldap_win_bind(data, server, user, passwd); +#else + rc = ldap_simple_bind_s(server, user, passwd); +#endif + if(!ldap_ssl && rc != LDAP_SUCCESS) { + ldap_proto = LDAP_VERSION2; + ldap_set_option(server, LDAP_OPT_PROTOCOL_VERSION, &ldap_proto); +#ifdef USE_WIN32_LDAP + rc = ldap_win_bind(data, server, user, passwd); +#else + rc = ldap_simple_bind_s(server, user, passwd); +#endif + } + if(rc != LDAP_SUCCESS) { +#ifdef USE_WIN32_LDAP + failf(data, "LDAP local: bind via ldap_win_bind %s", + ldap_err2string(rc)); +#else + failf(data, "LDAP local: bind via ldap_simple_bind_s %s", + ldap_err2string(rc)); +#endif + result = CURLE_LDAP_CANNOT_BIND; + goto quit; + } + + Curl_pgrsReset(data); + rc = ldap_search_s(server, ludp->lud_dn, + ludp->lud_scope, + ludp->lud_filter, ludp->lud_attrs, 0, &ldapmsg); + + if(rc != LDAP_SUCCESS && rc != LDAP_SIZELIMIT_EXCEEDED) { + failf(data, "LDAP remote: %s", ldap_err2string(rc)); + result = CURLE_LDAP_SEARCH_FAILED; + goto quit; + } + + num = 0; + for(entryIterator = ldap_first_entry(server, ldapmsg); + entryIterator; + entryIterator = ldap_next_entry(server, entryIterator), num++) { +#ifdef USE_WIN32_LDAP + TCHAR *attribute; +#else + char *attribute; +#endif + int i; + + /* Get the DN and write it to the client */ + { + char *name = NULL; + size_t name_len = 0; +#ifdef USE_WIN32_LDAP + TCHAR *dn = ldap_get_dn(server, entryIterator); + if(dn) + name = curlx_convert_tchar_to_UTF8(dn); +#else + char *dn = name = ldap_get_dn(server, entryIterator); +#endif + if(!name) + result = dn ? CURLE_OUT_OF_MEMORY : CURLE_FAILED_INIT; + else { + name_len = strlen(name); + result = Curl_client_write(data, CLIENTWRITE_BODY, "DN: ", 4); + } + if(!result) + result = Curl_client_write(data, CLIENTWRITE_BODY, name, name_len); + if(!result) + result = Curl_client_write(data, CLIENTWRITE_BODY, "\n", 1); + FREE_ON_WINLDAP(name); + ldap_memfree(dn); + if(result) + goto quit; + } + + /* Get the attributes and write them to the client */ + for(attribute = ldap_first_attribute(server, entryIterator, &ber); + attribute; + attribute = ldap_next_attribute(server, entryIterator, ber)) { + BerValue **vals; + size_t attr_len; +#ifdef USE_WIN32_LDAP + char *attr = curlx_convert_tchar_to_UTF8(attribute); + if(!attr) { + ldap_memfree(attribute); + result = CURLE_OUT_OF_MEMORY; + goto quit; + } +#else + char *attr = attribute; +#endif + attr_len = strlen(attr); + + vals = ldap_get_values_len(server, entryIterator, attribute); + if(vals) { + for(i = 0; vals[i]; i++) { + result = Curl_client_write(data, CLIENTWRITE_BODY, "\t", 1); + if(result) { + ldap_value_free_len(vals); + FREE_ON_WINLDAP(attr); + ldap_memfree(attribute); + goto quit; + } + + result = Curl_client_write(data, CLIENTWRITE_BODY, attr, attr_len); + if(result) { + ldap_value_free_len(vals); + FREE_ON_WINLDAP(attr); + ldap_memfree(attribute); + goto quit; + } + + result = Curl_client_write(data, CLIENTWRITE_BODY, ":", 1); + if(result) { + ldap_value_free_len(vals); + FREE_ON_WINLDAP(attr); + ldap_memfree(attribute); + goto quit; + } + + if(ldap_value_needs_base64(attr, attr_len, vals[i])) { + char *val_b64 = NULL; + size_t val_b64_sz = 0; + + /* Binary attribute, encode to base64. */ + if(vals[i]->bv_len) { + result = curlx_base64_encode((uint8_t *)vals[i]->bv_val, + vals[i]->bv_len, + &val_b64, &val_b64_sz); + if(result) { + ldap_value_free_len(vals); + FREE_ON_WINLDAP(attr); + ldap_memfree(attribute); + goto quit; + } + } + + result = Curl_client_write(data, CLIENTWRITE_BODY, ": ", 2); + if(result) { + curlx_free(val_b64); + ldap_value_free_len(vals); + FREE_ON_WINLDAP(attr); + ldap_memfree(attribute); + goto quit; + } + + if(val_b64_sz) { + result = Curl_client_write(data, CLIENTWRITE_BODY, val_b64, + val_b64_sz); + if(result) { + curlx_free(val_b64); + ldap_value_free_len(vals); + FREE_ON_WINLDAP(attr); + ldap_memfree(attribute); + goto quit; + } + } + + curlx_free(val_b64); + } + else { + result = Curl_client_write(data, CLIENTWRITE_BODY, " ", 1); + if(result) { + ldap_value_free_len(vals); + FREE_ON_WINLDAP(attr); + ldap_memfree(attribute); + goto quit; + } + + result = Curl_client_write(data, CLIENTWRITE_BODY, + vals[i]->bv_val, vals[i]->bv_len); + if(result) { + ldap_value_free_len(vals); + FREE_ON_WINLDAP(attr); + ldap_memfree(attribute); + goto quit; + } + } + + result = Curl_client_write(data, CLIENTWRITE_BODY, "\n", 1); + if(result) { + ldap_value_free_len(vals); + FREE_ON_WINLDAP(attr); + ldap_memfree(attribute); + goto quit; + } + } + + /* Free memory used to store values */ + ldap_value_free_len(vals); + } + + /* Free the attribute as we are done with it */ + FREE_ON_WINLDAP(attr); + ldap_memfree(attribute); + + result = Curl_client_write(data, CLIENTWRITE_BODY, "\n", 1); + if(result) + goto quit; + } + + if(ber) { + ber_free(ber, 0); + ber = NULL; + } + } + +quit: + if(ber) + ber_free(ber, 0); + if(ldapmsg) { + ldap_msgfree(ldapmsg); + LDAP_TRACE(("Received %d entries\n", num)); + } + if(rc == LDAP_SIZELIMIT_EXCEEDED) + infof(data, "There are more than %d entries", num); + if(ludp) + ldap_free_urldesc(ludp); + if(server) + ldap_unbind_s(server); + + FREE_ON_WINLDAP(host); + + /* no data to transfer */ + Curl_xfer_setup_nop(data); + connclose(conn, "LDAP connection always disable reuse"); + + return result; +} + +#ifdef DEBUG_LDAP +static void ldap_trace_low(const char *fmt, ...) +{ + static int do_trace = -1; + va_list args; + + if(do_trace == -1) { + const char *env = getenv("CURL_TRACE"); + curl_off_t e = 0; + if(!curlx_str_number(&env, &e, INT_MAX)) + do_trace = e > 0; + } + if(!do_trace) + return; + + va_start(args, fmt); + curl_mvfprintf(stderr, fmt, args); + va_end(args); +} +#endif /* DEBUG_LDAP */ + +#ifndef HAVE_LDAP_URL_PARSE + +/* + * Return scope-value for a scope-string. + */ +static int str2scope(const char *p) +{ + if(curl_strequal(p, "one")) + return LDAP_SCOPE_ONELEVEL; + if(curl_strequal(p, "onetree")) + return LDAP_SCOPE_ONELEVEL; + if(curl_strequal(p, "base")) + return LDAP_SCOPE_BASE; + if(curl_strequal(p, "sub")) + return LDAP_SCOPE_SUBTREE; + if(curl_strequal(p, "subtree")) + return LDAP_SCOPE_SUBTREE; + return -1; +} + +/* number of entries in the attributes list */ +static size_t num_entries(const char *s) +{ + size_t items = 1; + + s = strchr(s, ','); + while(s) { + items++; + s = strchr(s + 1, ','); + } + return items; +} + +/* + * Break apart the pieces of an LDAP URL. + * Syntax: + * ldap://:/???? + * + * already known from 'conn->origin->hostname'. + * already known from 'conn->origin->port'. + * extract the rest from 'data->state.path+1'. All fields are optional. + * e.g. + * ldap://:/??? + * yields ludp->lud_dn = "". + * + * Defined in RFC4516 section 2. + */ +static curl_ldap_num_t ldap_url_parse2_low(struct Curl_easy *data, + const struct connectdata *conn, + LDAPURLDesc *ludp) +{ + curl_ldap_num_t rc = LDAP_SUCCESS; + char *p; + char *path; + char *q = NULL; + char *query = NULL; + size_t i; + + if(!data || + !data->state.up.path || + data->state.up.path[0] != '/' || + !curl_strnequal("LDAP", data->state.up.scheme, 4)) + return LDAP_INVALID_SYNTAX; + + ludp->lud_scope = LDAP_SCOPE_BASE; + ludp->lud_port = conn->origin->port; + ludp->lud_host = conn->origin->hostname; + + /* Duplicate the path */ + p = path = curlx_strdup(data->state.up.path + 1); + if(!path) + return LDAP_NO_MEMORY; + + /* Duplicate the query if present */ + if(data->state.up.query) { + q = query = curlx_strdup(data->state.up.query); + if(!query) { + curlx_free(path); + return LDAP_NO_MEMORY; + } + } + + /* Parse the DN (Distinguished Name) */ + if(*p) { + char *dn = p; + char *unescaped; + CURLcode result; + + LDAP_TRACE(("DN '%s'\n", dn)); + + /* Unescape the DN */ + result = Curl_urldecode(dn, 0, &unescaped, NULL, REJECT_ZERO); + if(result) { + rc = LDAP_NO_MEMORY; + + goto quit; + } + +#ifdef USE_WIN32_LDAP + /* Convert the unescaped string to a tchar */ + ludp->lud_dn = curlx_convert_UTF8_to_tchar(unescaped); + + /* Free the unescaped string as we are done with it */ + curlx_free(unescaped); + + if(!ludp->lud_dn) { + rc = LDAP_NO_MEMORY; + + goto quit; + } +#else + ludp->lud_dn = unescaped; +#endif + } + + p = q; + if(!p) + goto quit; + + /* Parse the attributes. skip "??" */ + q = strchr(p, '?'); + if(q) + *q++ = '\0'; + + if(*p) { + size_t count = num_entries(p); /* at least one */ + const char *atp = p; + + /* Allocate our array (+1 for the NULL entry) */ +#ifdef USE_WIN32_LDAP + ludp->lud_attrs = curlx_calloc(count + 1, sizeof(TCHAR *)); +#else + ludp->lud_attrs = curlx_calloc(count + 1, sizeof(char *)); +#endif + if(!ludp->lud_attrs) { + rc = LDAP_NO_MEMORY; + goto quit; + } + + for(i = 0; i < count; i++) { + char *unescaped; + CURLcode result; + struct Curl_str out; + + if(curlx_str_until(&atp, &out, 1024, ',')) + break; + + LDAP_TRACE(("attr[%zu] '%.*s'\n", i, (int)out.len, out.str)); + + /* Unescape the attribute */ + result = Curl_urldecode(out.str, out.len, &unescaped, NULL, REJECT_ZERO); + if(result) { + rc = LDAP_NO_MEMORY; + goto quit; + } + +#ifdef USE_WIN32_LDAP + /* Convert the unescaped string to a tchar */ + ludp->lud_attrs[i] = curlx_convert_UTF8_to_tchar(unescaped); + + /* Free the unescaped string as we are done with it */ + curlx_free(unescaped); + + if(!ludp->lud_attrs[i]) { + rc = LDAP_NO_MEMORY; + goto quit; + } +#else + ludp->lud_attrs[i] = unescaped; +#endif + + ludp->lud_attrs_dups++; + if(curlx_str_single(&atp, ',')) + break; + } + } + + p = q; + if(!p) + goto quit; + + /* Parse the scope. skip "??" */ + q = strchr(p, '?'); + if(q) + *q++ = '\0'; + + if(*p) { + ludp->lud_scope = str2scope(p); + if(ludp->lud_scope == -1) { + rc = LDAP_INVALID_SYNTAX; + + goto quit; + } + LDAP_TRACE(("scope %d\n", ludp->lud_scope)); + } + + p = q; + if(!p) + goto quit; + + /* Parse the filter */ + q = strchr(p, '?'); + if(q) + *q++ = '\0'; + + if(*p) { + char *filter = p; + char *unescaped; + CURLcode result; + + LDAP_TRACE(("filter '%s'\n", filter)); + + /* Unescape the filter */ + result = Curl_urldecode(filter, 0, &unescaped, NULL, REJECT_ZERO); + if(result) { + rc = LDAP_NO_MEMORY; + + goto quit; + } + +#ifdef USE_WIN32_LDAP + /* Convert the unescaped string to a tchar */ + ludp->lud_filter = curlx_convert_UTF8_to_tchar(unescaped); + + /* Free the unescaped string as we are done with it */ + curlx_free(unescaped); + + if(!ludp->lud_filter) { + rc = LDAP_NO_MEMORY; + + goto quit; + } +#else + ludp->lud_filter = unescaped; +#endif + } + + p = q; + if(p && !*p) { + rc = LDAP_INVALID_SYNTAX; + + goto quit; + } + +quit: + curlx_free(path); + curlx_free(query); + + return rc; +} + +static curl_ldap_num_t ldap_url_parse_low(struct Curl_easy *data, + const struct connectdata *conn, + LDAPURLDesc **ludpp) +{ + LDAPURLDesc *ludp = curlx_calloc(1, sizeof(*ludp)); + curl_ldap_num_t rc; + + *ludpp = NULL; + if(!ludp) + return LDAP_NO_MEMORY; + + rc = ldap_url_parse2_low(data, conn, ludp); + if(rc != LDAP_SUCCESS) { + ldap_free_urldesc_low(ludp); + ludp = NULL; + } + *ludpp = ludp; + return rc; +} + +static void ldap_free_urldesc_low(LDAPURLDesc *ludp) +{ + if(!ludp) + return; + + curlx_free(ludp->lud_dn); + curlx_free(ludp->lud_filter); + + if(ludp->lud_attrs) { + size_t i; + for(i = 0; i < ludp->lud_attrs_dups; i++) { + curlx_free(ludp->lud_attrs[i]); + } + curlx_free(ludp->lud_attrs); + } + + curlx_free(ludp); +} +#endif /* !HAVE_LDAP_URL_PARSE */ + +void Curl_ldap_version(char *buf, size_t bufsz) +{ +#ifdef USE_WIN32_LDAP + curl_msnprintf(buf, bufsz, "WinLDAP"); +#else +#ifdef LDAP_OPT_X_TLS_PASSPHRASE + static const char *flavor = "/Apple"; +#else + static const char *flavor = ""; +#endif + LDAPAPIInfo api; + api.ldapai_info_version = LDAP_API_INFO_VERSION; + + /* Comparing against 0, as different platforms + disagree on the success define name */ + if(ldap_get_option(NULL, LDAP_OPT_API_INFO, &api) == 0) { + unsigned int patch = (unsigned int)(api.ldapai_vendor_version % 100); + unsigned int major = (unsigned int)(api.ldapai_vendor_version / 10000); + unsigned int minor = + (((unsigned int)api.ldapai_vendor_version - (major * 10000)) + - patch) / 100; +#ifdef __OS400__ + curl_msnprintf(buf, bufsz, "IBMLDAP/%u.%u.%u", major, minor, patch); + ldap_value_free(api.ldapai_extensions); + (void)flavor; +#else + curl_msnprintf(buf, bufsz, "%s/%u.%u.%u%s", + api.ldapai_vendor_name, major, minor, patch, flavor); + ldap_memfree(api.ldapai_vendor_name); + ber_memvfree((void **)api.ldapai_extensions); +#endif + } + else + curl_msnprintf(buf, bufsz, "LDAP/1"); +#endif /* USE_WIN32_LDAP */ +} + +/* + * LDAP protocol handler. + */ +const struct Curl_protocol Curl_protocol_ldap = { + ZERO_NULL, /* setup_connection */ + ldap_do, /* do_it */ + ZERO_NULL, /* done */ + ZERO_NULL, /* do_more */ + ZERO_NULL, /* connect_it */ + ZERO_NULL, /* connecting */ + ZERO_NULL, /* doing */ + ZERO_NULL, /* proto_pollset */ + ZERO_NULL, /* doing_pollset */ + ZERO_NULL, /* domore_pollset */ + ZERO_NULL, /* perform_pollset */ + ZERO_NULL, /* disconnect */ + ZERO_NULL, /* write_resp */ + ZERO_NULL, /* write_resp_hd */ + ZERO_NULL, /* connection_is_dead */ + ZERO_NULL, /* attach connection */ + ZERO_NULL, /* follow */ +}; + +#if defined(CURL_HAVE_DIAG) && defined(__APPLE__) +#pragma GCC diagnostic pop +#endif + +#endif /* !CURL_DISABLE_LDAP && !USE_OPENLDAP */ diff --git a/3rdparty/curl-8.21.0/lib/libcurl.def b/3rdparty/curl-8.21.0/lib/libcurl.def new file mode 100644 index 0000000000..803f372041 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/libcurl.def @@ -0,0 +1,101 @@ +EXPORTS +curl_easy_cleanup +curl_easy_duphandle +curl_easy_escape +curl_easy_getinfo +curl_easy_header +curl_easy_init +curl_easy_nextheader +curl_easy_option_by_id +curl_easy_option_by_name +curl_easy_option_next +curl_easy_pause +curl_easy_perform +curl_easy_recv +curl_easy_reset +curl_easy_send +curl_easy_setopt +curl_easy_ssls_export +curl_easy_ssls_import +curl_easy_strerror +curl_easy_unescape +curl_easy_upkeep +curl_escape +curl_formadd +curl_formfree +curl_formget +curl_free +curl_getdate +curl_getenv +curl_global_cleanup +curl_global_init +curl_global_init_mem +curl_global_sslset +curl_global_trace +curl_maprintf +curl_mfprintf +curl_mime_addpart +curl_mime_data +curl_mime_data_cb +curl_mime_encoder +curl_mime_filedata +curl_mime_filename +curl_mime_free +curl_mime_headers +curl_mime_init +curl_mime_name +curl_mime_subparts +curl_mime_type +curl_mprintf +curl_msnprintf +curl_msprintf +curl_multi_add_handle +curl_multi_assign +curl_multi_cleanup +curl_multi_fdset +curl_multi_get_handles +curl_multi_get_offt +curl_multi_info_read +curl_multi_init +curl_multi_notify_disable +curl_multi_notify_enable +curl_multi_perform +curl_multi_poll +curl_multi_remove_handle +curl_multi_setopt +curl_multi_socket +curl_multi_socket_action +curl_multi_socket_all +curl_multi_strerror +curl_multi_timeout +curl_multi_wait +curl_multi_waitfds +curl_multi_wakeup +curl_mvaprintf +curl_mvfprintf +curl_mvprintf +curl_mvsnprintf +curl_mvsprintf +curl_pushheader_byname +curl_pushheader_bynum +curl_share_cleanup +curl_share_init +curl_share_setopt +curl_share_strerror +curl_slist_append +curl_slist_free_all +curl_strequal +curl_strnequal +curl_unescape +curl_url +curl_url_cleanup +curl_url_dup +curl_url_get +curl_url_set +curl_url_strerror +curl_version +curl_version_info +curl_ws_meta +curl_ws_recv +curl_ws_send +curl_ws_start_frame diff --git a/3rdparty/curl-8.21.0/lib/libcurl.rc b/3rdparty/curl-8.21.0/lib/libcurl.rc new file mode 100644 index 0000000000..81cd8d71b4 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/libcurl.rc @@ -0,0 +1,65 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include +#include "../include/curl/curlver.h" + +LANGUAGE 0, 0 + +#define RC_VERSION LIBCURL_VERSION_MAJOR, LIBCURL_VERSION_MINOR, LIBCURL_VERSION_PATCH, 0 + +VS_VERSION_INFO VERSIONINFO + FILEVERSION RC_VERSION + PRODUCTVERSION RC_VERSION + FILEFLAGSMASK VS_FFI_FILEFLAGSMASK +#if defined(DEBUGBUILD) || defined(UNITTESTS) || defined(_DEBUG) + FILEFLAGS VS_FF_DEBUG +#else + FILEFLAGS 0L +#endif + FILEOS VOS__WINDOWS32 + FILETYPE VFT_DLL + FILESUBTYPE 0L + +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "040904b0" + BEGIN + VALUE "CompanyName", "The curl library, https://curl.se/\0" + VALUE "FileDescription", "libcurl Shared Library\0" + VALUE "FileVersion", LIBCURL_VERSION "\0" + VALUE "InternalName", "libcurl\0" + VALUE "OriginalFilename", "libcurl.dll\0" + VALUE "ProductName", "The curl library\0" + VALUE "ProductVersion", LIBCURL_VERSION "\0" + VALUE "LegalCopyright", "Copyright (C) " LIBCURL_COPYRIGHT "\0" + VALUE "License", "https://curl.se/docs/copyright.html\0" + END + END + + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x409, 1200 + END +END diff --git a/3rdparty/curl-8.21.0/lib/libcurl.vers.in b/3rdparty/curl-8.21.0/lib/libcurl.vers.in new file mode 100644 index 0000000000..8219669993 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/libcurl.vers.in @@ -0,0 +1,5 @@ +CURL_@CURL_LIBCURL_VERSIONED_SYMBOLS_PREFIX@@CURL_LIBCURL_VERSIONED_SYMBOLS_SONAME@ +{ + global: curl_*; + local: *; +}; diff --git a/3rdparty/curl-8.21.0/lib/llist.c b/3rdparty/curl-8.21.0/lib/llist.c new file mode 100644 index 0000000000..ce0c59cc50 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/llist.c @@ -0,0 +1,272 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "llist.h" + +#ifdef DEBUGBUILD +#define LLISTINIT 0x100cc001 /* random pattern */ +#define NODEINIT 0x12344321 /* random pattern */ +#define NODEREM 0x54321012 /* random pattern */ + +#define VERIFYNODE(x) verifynode(x) +static struct Curl_llist_node *verifynode(struct Curl_llist_node *n) +{ + DEBUGASSERT(!n || (n->_init == NODEINIT)); + return n; +} +#else +#define VERIFYNODE(x) x +#endif +/* + * @unittest 1300 + */ +void Curl_llist_init(struct Curl_llist *l, Curl_llist_dtor dtor) +{ + l->_size = 0; + l->_dtor = dtor; + l->_head = NULL; + l->_tail = NULL; +#ifdef DEBUGBUILD + l->_init = LLISTINIT; +#endif +} + +/* + * Curl_llist_insert_next() + * + * Inserts a new list element after the given one 'e'. If the given existing + * entry is NULL and the list already has elements, the new one will be + * inserted first in the list. + * + * The 'ne' argument should be a pointer into the object to store. + * + * @unittest 1300 + */ +void Curl_llist_insert_next(struct Curl_llist *list, + struct Curl_llist_node *e, /* may be NULL */ + const void *p, + struct Curl_llist_node *ne) +{ + DEBUGASSERT(list); + DEBUGASSERT(list->_init == LLISTINIT); + DEBUGASSERT(ne); + +#ifdef DEBUGBUILD + ne->_init = NODEINIT; +#endif + ne->_ptr = CURL_UNCONST(p); + ne->_list = list; + if(list->_size == 0) { + list->_head = ne; + list->_head->_prev = NULL; + list->_head->_next = NULL; + list->_tail = ne; + } + else { + /* if 'e' is NULL here, we insert the new element first in the list */ + ne->_next = e ? e->_next : list->_head; + ne->_prev = e; + if(!e) { + list->_head->_prev = ne; + list->_head = ne; + } + else if(e->_next) { + e->_next->_prev = ne; + } + else { + list->_tail = ne; + } + if(e) + e->_next = ne; + } + + ++list->_size; +} + +/* + * Curl_llist_append() + * + * Adds a new list element to the end of the list. + * + * The 'ne' argument should be a pointer into the object to store. + * + * @unittest 1300 + */ +void Curl_llist_append(struct Curl_llist *list, const void *p, + struct Curl_llist_node *ne) +{ + DEBUGASSERT(list); + DEBUGASSERT(list->_init == LLISTINIT); + DEBUGASSERT(ne); + Curl_llist_insert_next(list, list->_tail, p, ne); +} + +void *Curl_node_take_elem(struct Curl_llist_node *e) +{ + void *ptr; + struct Curl_llist *list; + if(!e) + return NULL; + + list = e->_list; + DEBUGASSERT(list); + DEBUGASSERT(list->_init == LLISTINIT); + DEBUGASSERT(list->_size); + DEBUGASSERT(e->_init == NODEINIT); + if(list) { + if(e == list->_head) { + list->_head = e->_next; + + if(!list->_head) + list->_tail = NULL; + else + e->_next->_prev = NULL; + } + else { + if(e->_prev) + e->_prev->_next = e->_next; + + if(!e->_next) + list->_tail = e->_prev; + else + e->_next->_prev = e->_prev; + } + --list->_size; + } + ptr = e->_ptr; + + e->_list = NULL; + e->_ptr = NULL; + e->_prev = NULL; + e->_next = NULL; +#ifdef DEBUGBUILD + e->_init = NODEREM; /* specific pattern on remove - not zero */ +#endif + + return ptr; +} + +static void node_uremove(struct Curl_llist_node *e, void *user) +{ + struct Curl_llist *list; + void *ptr; + if(!e) + return; + + list = e->_list; + DEBUGASSERT(list); + if(list) { + ptr = Curl_node_take_elem(e); + if(list->_dtor) + list->_dtor(user, ptr); + } +} + +void Curl_node_remove(struct Curl_llist_node *e) +{ + node_uremove(e, NULL); +} + +void Curl_llist_destroy(struct Curl_llist *list, void *user) +{ + if(list) { + DEBUGASSERT(list->_init == LLISTINIT); + while(list->_size > 0) + node_uremove(list->_tail, user); + } +} + +/* Curl_llist_head() returns the first 'struct Curl_llist_node *', which + might be NULL */ +struct Curl_llist_node *Curl_llist_head(const struct Curl_llist *list) +{ + DEBUGASSERT(list); + DEBUGASSERT(list->_init == LLISTINIT); + return VERIFYNODE(list->_head); +} + +#ifdef UNITTESTS +/* llist_tail() returns the last 'struct Curl_llist_node *', which might be + NULL + + @unittest 1300 +*/ +UNITTEST struct Curl_llist_node *llist_tail(const struct Curl_llist *list); +UNITTEST struct Curl_llist_node *llist_tail(const struct Curl_llist *list) +{ + DEBUGASSERT(list); + DEBUGASSERT(list->_init == LLISTINIT); + return VERIFYNODE(list->_tail); +} +#endif + +/* Curl_llist_count() returns a size_t the number of nodes in the list */ +size_t Curl_llist_count(const struct Curl_llist *list) +{ + DEBUGASSERT(list); + DEBUGASSERT(list->_init == LLISTINIT); + return list->_size; +} + +/* Curl_node_elem() returns the custom data from a Curl_llist_node */ +void *Curl_node_elem(const struct Curl_llist_node *n) +{ + DEBUGASSERT(n); + DEBUGASSERT(n->_init == NODEINIT); + return n->_ptr; +} + +/* Curl_node_next() returns the next element in a list from a given + Curl_llist_node */ +struct Curl_llist_node *Curl_node_next(const struct Curl_llist_node *n) +{ + DEBUGASSERT(n); + DEBUGASSERT(n->_init == NODEINIT); + return VERIFYNODE(n->_next); +} + +#ifdef UNITTESTS +/* llist_node_prev() returns the previous element in a list from a given + Curl_llist_node + + @unittest 1300 +*/ +UNITTEST struct Curl_llist_node *llist_node_prev( + const struct Curl_llist_node *n); +UNITTEST struct Curl_llist_node *llist_node_prev( + const struct Curl_llist_node *n) +{ + DEBUGASSERT(n); + DEBUGASSERT(n->_init == NODEINIT); + return VERIFYNODE(n->_prev); +} +#endif + +struct Curl_llist *Curl_node_llist(const struct Curl_llist_node *n) +{ + DEBUGASSERT(n); + DEBUGASSERT(!n->_list || n->_init == NODEINIT); + return n->_list; +} diff --git a/3rdparty/curl-8.21.0/lib/llist.h b/3rdparty/curl-8.21.0/lib/llist.h new file mode 100644 index 0000000000..de4adc972f --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/llist.h @@ -0,0 +1,82 @@ +#ifndef HEADER_CURL_LLIST_H +#define HEADER_CURL_LLIST_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +typedef void (*Curl_llist_dtor)(void *user, void *elem); + +/* none of these struct members should be referenced directly, use the + dedicated functions */ + +struct Curl_llist { + struct Curl_llist_node *_head; + struct Curl_llist_node *_tail; + Curl_llist_dtor _dtor; + size_t _size; +#ifdef DEBUGBUILD + int _init; /* detect API usage mistakes */ +#endif +}; + +struct Curl_llist_node { + struct Curl_llist *_list; /* the list where this belongs */ + void *_ptr; + struct Curl_llist_node *_prev; + struct Curl_llist_node *_next; +#ifdef DEBUGBUILD + int _init; /* detect API usage mistakes */ +#endif +}; + +void Curl_llist_init(struct Curl_llist *l, Curl_llist_dtor dtor); +void Curl_llist_insert_next(struct Curl_llist *list, struct Curl_llist_node *e, + const void *p, struct Curl_llist_node *ne); +void Curl_llist_append(struct Curl_llist *list, const void *p, + struct Curl_llist_node *ne); +void Curl_node_remove(struct Curl_llist_node *e); +void Curl_llist_destroy(struct Curl_llist *list, void *user); + +/* Curl_llist_head() returns the first 'struct Curl_llist_node *', which + might be NULL */ +struct Curl_llist_node *Curl_llist_head(const struct Curl_llist *list); + +/* Curl_llist_count() returns a size_t the number of nodes in the list */ +size_t Curl_llist_count(const struct Curl_llist *list); + +/* Curl_node_elem() returns the custom data from a Curl_llist_node */ +void *Curl_node_elem(const struct Curl_llist_node *n); + +/* Remove the node from the list and return the custom data + * from a Curl_llist_node. Does NOT invoke a registered `dtor`. */ +void *Curl_node_take_elem(struct Curl_llist_node *e); + +/* Curl_node_next() returns the next element in a list from a given + Curl_llist_node */ +struct Curl_llist_node *Curl_node_next(const struct Curl_llist_node *n); + +/* Curl_node_llist() return the list the node is in or NULL. */ +struct Curl_llist *Curl_node_llist(const struct Curl_llist_node *n); + +#endif /* HEADER_CURL_LLIST_H */ diff --git a/3rdparty/curl-8.21.0/lib/macos.c b/3rdparty/curl-8.21.0/lib/macos.c new file mode 100644 index 0000000000..334dbc7d1d --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/macos.c @@ -0,0 +1,50 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef CURL_MACOS_CALL_COPYPROXIES + +#include "macos.h" + +#include + +CURLcode Curl_macos_init(void) +{ + /* + * The automagic conversion from IPv4 literals to IPv6 literals only + * works if the SCDynamicStoreCopyProxies system function gets called + * first. As curl currently does not support system-wide HTTP proxies, we + * therefore do not use any value this function might return. + * + * This function is only available on macOS and is not needed for + * IPv4-only builds, hence the conditions for defining + * CURL_MACOS_CALL_COPYPROXIES in curl_setup.h. + */ + CFDictionaryRef dict = SCDynamicStoreCopyProxies(NULL); + if(dict) + CFRelease(dict); + return CURLE_OK; +} + +#endif diff --git a/3rdparty/curl-8.21.0/lib/macos.h b/3rdparty/curl-8.21.0/lib/macos.h new file mode 100644 index 0000000000..0a72a30272 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/macos.h @@ -0,0 +1,34 @@ +#ifndef HEADER_CURL_MACOS_H +#define HEADER_CURL_MACOS_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef CURL_MACOS_CALL_COPYPROXIES +CURLcode Curl_macos_init(void); +#else +#define Curl_macos_init() CURLE_OK +#endif + +#endif /* HEADER_CURL_MACOS_H */ diff --git a/3rdparty/curl-8.21.0/lib/md4.c b/3rdparty/curl-8.21.0/lib/md4.c new file mode 100644 index 0000000000..e030ffac30 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/md4.c @@ -0,0 +1,466 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_CURL_NTLM_CORE + +#include "curl_md4.h" + +#ifdef USE_OPENSSL +#include +#if OPENSSL_VERSION_NUMBER >= 0x30000000L && !defined(USE_AMISSL) +/* OpenSSL 3.0.0 marks the MD4 functions as deprecated */ +#define OPENSSL_NO_MD4 +#else +/* Cover also OPENSSL_NO_MD4 configured in OpenSSL */ +#include +#endif +#endif /* USE_OPENSSL */ + +#ifdef USE_WOLFSSL +#include +#endif + +/* When OpenSSL or wolfSSL is available, we use their MD4 functions. */ + +#if defined(USE_OPENSSL) && !defined(OPENSSL_NO_MD4) +#include + +/* Map directly to OpenSSL implementation */ +#define my_md4_ctx MD4_CTX +#define my_md4_init MD4_Init +#define my_md4_update MD4_Update +#define my_md4_final MD4_Final + +#elif defined(USE_WOLFSSL) && !defined(NO_MD4) +#include +#include + +#if LIBWOLFSSL_VERSION_HEX >= 0x05007006 +typedef wc_Md4 my_md4_ctx; +#else +typedef Md4 my_md4_ctx; +#endif + +static int my_md4_init(my_md4_ctx *ctx) +{ + wc_InitMd4(ctx); + return 1; +} + +static void my_md4_update(my_md4_ctx *ctx, + const void *input, unsigned long len) +{ + wc_Md4Update(ctx, input, (word32)len); +} + +static void my_md4_final(unsigned char *digest, my_md4_ctx *ctx) +{ + wc_Md4Final(ctx, digest); +} + +#elif (defined(__MAC_OS_X_VERSION_MAX_ALLOWED) && \ + (__MAC_OS_X_VERSION_MAX_ALLOWED >= 1040) && \ + defined(__MAC_OS_X_VERSION_MIN_REQUIRED) && \ + (__MAC_OS_X_VERSION_MIN_REQUIRED < 101500)) || \ + (defined(__IPHONE_OS_VERSION_MAX_ALLOWED) && \ + (__IPHONE_OS_VERSION_MAX_ALLOWED >= 20000) && \ + defined(__IPHONE_OS_VERSION_MIN_REQUIRED) && \ + (__IPHONE_OS_VERSION_MIN_REQUIRED < 130000)) +#include + +typedef CC_MD4_CTX my_md4_ctx; + +static int my_md4_init(my_md4_ctx *ctx) +{ + return CC_MD4_Init(ctx); +} + +static void my_md4_update(my_md4_ctx *ctx, + const void *input, unsigned long len) +{ + (void)CC_MD4_Update(ctx, input, (CC_LONG)len); +} + +static void my_md4_final(unsigned char *digest, my_md4_ctx *ctx) +{ + (void)CC_MD4_Final(digest, ctx); +} + +#elif defined(USE_WIN32_CRYPTO) +#include + +struct md4_ctx { + HCRYPTPROV hCryptProv; + HCRYPTHASH hHash; +}; +typedef struct md4_ctx my_md4_ctx; + +static int my_md4_init(my_md4_ctx *ctx) +{ + ctx->hCryptProv = 0; + ctx->hHash = 0; + + if(!CryptAcquireContext(&ctx->hCryptProv, NULL, NULL, PROV_RSA_FULL, + CRYPT_VERIFYCONTEXT | CRYPT_SILENT)) + return 0; + + if(!CryptCreateHash(ctx->hCryptProv, CALG_MD4, 0, 0, &ctx->hHash)) { + CryptReleaseContext(ctx->hCryptProv, 0); + ctx->hCryptProv = 0; + return 0; + } + + return 1; +} + +static void my_md4_update(my_md4_ctx *ctx, + const void *input, unsigned long len) +{ + CryptHashData(ctx->hHash, (const BYTE *)input, (unsigned int)len, 0); +} + +static void my_md4_final(unsigned char *digest, my_md4_ctx *ctx) +{ + unsigned long length = 0; + + CryptGetHashParam(ctx->hHash, HP_HASHVAL, NULL, &length, 0); + if(length == MD4_DIGEST_LENGTH) + CryptGetHashParam(ctx->hHash, HP_HASHVAL, digest, &length, 0); + + if(ctx->hHash) + CryptDestroyHash(ctx->hHash); + + if(ctx->hCryptProv) + CryptReleaseContext(ctx->hCryptProv, 0); +} + +#elif defined(USE_GNUTLS) +#include +#include + +typedef struct md4_ctx my_md4_ctx; + +static int my_md4_init(my_md4_ctx *ctx) +{ + md4_init(ctx); + return 1; +} + +static void my_md4_update(my_md4_ctx *ctx, + const void *input, unsigned long len) +{ + md4_update(ctx, len, input); +} + +static void my_md4_final(unsigned char *digest, my_md4_ctx *ctx) +{ +#if NETTLE_VERSION_MAJOR >= 4 + md4_digest(ctx, digest); +#else + md4_digest(ctx, MD4_DIGEST_SIZE, digest); +#endif +} + +#else +/* When no other crypto library is available, or the crypto library does not + * support MD4, we use this code segment this implementation of it + * + * This is an OpenSSL-compatible implementation of the RSA Data Security, Inc. + * MD4 Message-Digest Algorithm (RFC 1320). + * + * Homepage: + * https://openwall.info/wiki/people/solar/software/public-domain-source-code/md4 + * + * Author: + * Alexander Peslyak, better known as Solar Designer + * + * This software was written by Alexander Peslyak in 2001. No copyright is + * claimed, and the software is hereby placed in the public domain. In case + * this attempt to disclaim copyright and place the software in the public + * domain is deemed null and void, then the software is Copyright (c) 2001 + * Alexander Peslyak and it is hereby released to the general public under + * the following terms: + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted. + * + * There is ABSOLUTELY NO WARRANTY, express or implied. + * + * (This is a heavily cut-down "BSD license".) + */ + +struct md4_ctx { + uint32_t lo, hi; + uint32_t a, b, c, d; + unsigned char buffer[64]; + uint32_t block[16]; +}; +typedef struct md4_ctx my_md4_ctx; + +/* + * The basic MD4 functions. + * + * F and G are optimized compared to their RFC 1320 definitions, with the + * optimization for F borrowed from Colin Plumb's MD5 implementation. + */ +#define MD4_F(x, y, z) ((z) ^ ((x) & ((y) ^ (z)))) +#define MD4_G(x, y, z) (((x) & ((y) | (z))) | ((y) & (z))) +#define MD4_H(x, y, z) ((x) ^ (y) ^ (z)) + +/* + * The MD4 transformation for all three rounds. + */ +#define MD4_STEP(f, a, b, c, d, x, s) \ + (a) += f(b, c, d) + (x); \ + (a) = (((a) << (s)) | (((a) & 0xffffffff) >> (32 - (s)))); + +/* + * SET reads 4 input bytes in little-endian byte order and stores them + * in a properly aligned word in host byte order. + * + * The check for little-endian architectures that tolerate unaligned memory + * accesses is an optimization. Nothing will break if it does not work. + */ +#if defined(__i386__) || defined(__x86_64__) || defined(__vax__) +#define MD4_SET(n) (*(const uint32_t *)(const void *)&ptr[(n) * 4]) +#define MD4_GET(n) MD4_SET(n) +#else +#define MD4_SET(n) (ctx->block[n] = \ + (uint32_t)ptr[(n) * 4] | \ + ((uint32_t)ptr[((n) * 4) + 1] << 8) | \ + ((uint32_t)ptr[((n) * 4) + 2] << 16) | \ + ((uint32_t)ptr[((n) * 4) + 3] << 24)) +#define MD4_GET(n) ctx->block[n] +#endif + +/* + * This processes one or more 64-byte data blocks, but does NOT update + * the bit counters. There are no alignment requirements. + */ +static const void *my_md4_body(my_md4_ctx *ctx, + const void *input, unsigned long size) +{ + const unsigned char *ptr; + uint32_t a, b, c, d; + + ptr = (const unsigned char *)input; + + a = ctx->a; + b = ctx->b; + c = ctx->c; + d = ctx->d; + + do { + uint32_t saved_a, saved_b, saved_c, saved_d; + + saved_a = a; + saved_b = b; + saved_c = c; + saved_d = d; + + /* Round 1 */ + MD4_STEP(MD4_F, a, b, c, d, MD4_SET(0), 3) + MD4_STEP(MD4_F, d, a, b, c, MD4_SET(1), 7) + MD4_STEP(MD4_F, c, d, a, b, MD4_SET(2), 11) + MD4_STEP(MD4_F, b, c, d, a, MD4_SET(3), 19) + MD4_STEP(MD4_F, a, b, c, d, MD4_SET(4), 3) + MD4_STEP(MD4_F, d, a, b, c, MD4_SET(5), 7) + MD4_STEP(MD4_F, c, d, a, b, MD4_SET(6), 11) + MD4_STEP(MD4_F, b, c, d, a, MD4_SET(7), 19) + MD4_STEP(MD4_F, a, b, c, d, MD4_SET(8), 3) + MD4_STEP(MD4_F, d, a, b, c, MD4_SET(9), 7) + MD4_STEP(MD4_F, c, d, a, b, MD4_SET(10), 11) + MD4_STEP(MD4_F, b, c, d, a, MD4_SET(11), 19) + MD4_STEP(MD4_F, a, b, c, d, MD4_SET(12), 3) + MD4_STEP(MD4_F, d, a, b, c, MD4_SET(13), 7) + MD4_STEP(MD4_F, c, d, a, b, MD4_SET(14), 11) + MD4_STEP(MD4_F, b, c, d, a, MD4_SET(15), 19) + + /* Round 2 */ + MD4_STEP(MD4_G, a, b, c, d, MD4_GET(0) + 0x5a827999, 3) + MD4_STEP(MD4_G, d, a, b, c, MD4_GET(4) + 0x5a827999, 5) + MD4_STEP(MD4_G, c, d, a, b, MD4_GET(8) + 0x5a827999, 9) + MD4_STEP(MD4_G, b, c, d, a, MD4_GET(12) + 0x5a827999, 13) + MD4_STEP(MD4_G, a, b, c, d, MD4_GET(1) + 0x5a827999, 3) + MD4_STEP(MD4_G, d, a, b, c, MD4_GET(5) + 0x5a827999, 5) + MD4_STEP(MD4_G, c, d, a, b, MD4_GET(9) + 0x5a827999, 9) + MD4_STEP(MD4_G, b, c, d, a, MD4_GET(13) + 0x5a827999, 13) + MD4_STEP(MD4_G, a, b, c, d, MD4_GET(2) + 0x5a827999, 3) + MD4_STEP(MD4_G, d, a, b, c, MD4_GET(6) + 0x5a827999, 5) + MD4_STEP(MD4_G, c, d, a, b, MD4_GET(10) + 0x5a827999, 9) + MD4_STEP(MD4_G, b, c, d, a, MD4_GET(14) + 0x5a827999, 13) + MD4_STEP(MD4_G, a, b, c, d, MD4_GET(3) + 0x5a827999, 3) + MD4_STEP(MD4_G, d, a, b, c, MD4_GET(7) + 0x5a827999, 5) + MD4_STEP(MD4_G, c, d, a, b, MD4_GET(11) + 0x5a827999, 9) + MD4_STEP(MD4_G, b, c, d, a, MD4_GET(15) + 0x5a827999, 13) + + /* Round 3 */ + MD4_STEP(MD4_H, a, b, c, d, MD4_GET(0) + 0x6ed9eba1, 3) + MD4_STEP(MD4_H, d, a, b, c, MD4_GET(8) + 0x6ed9eba1, 9) + MD4_STEP(MD4_H, c, d, a, b, MD4_GET(4) + 0x6ed9eba1, 11) + MD4_STEP(MD4_H, b, c, d, a, MD4_GET(12) + 0x6ed9eba1, 15) + MD4_STEP(MD4_H, a, b, c, d, MD4_GET(2) + 0x6ed9eba1, 3) + MD4_STEP(MD4_H, d, a, b, c, MD4_GET(10) + 0x6ed9eba1, 9) + MD4_STEP(MD4_H, c, d, a, b, MD4_GET(6) + 0x6ed9eba1, 11) + MD4_STEP(MD4_H, b, c, d, a, MD4_GET(14) + 0x6ed9eba1, 15) + MD4_STEP(MD4_H, a, b, c, d, MD4_GET(1) + 0x6ed9eba1, 3) + MD4_STEP(MD4_H, d, a, b, c, MD4_GET(9) + 0x6ed9eba1, 9) + MD4_STEP(MD4_H, c, d, a, b, MD4_GET(5) + 0x6ed9eba1, 11) + MD4_STEP(MD4_H, b, c, d, a, MD4_GET(13) + 0x6ed9eba1, 15) + MD4_STEP(MD4_H, a, b, c, d, MD4_GET(3) + 0x6ed9eba1, 3) + MD4_STEP(MD4_H, d, a, b, c, MD4_GET(11) + 0x6ed9eba1, 9) + MD4_STEP(MD4_H, c, d, a, b, MD4_GET(7) + 0x6ed9eba1, 11) + MD4_STEP(MD4_H, b, c, d, a, MD4_GET(15) + 0x6ed9eba1, 15) + + a += saved_a; + b += saved_b; + c += saved_c; + d += saved_d; + + ptr += 64; + } while(size -= 64); + + ctx->a = a; + ctx->b = b; + ctx->c = c; + ctx->d = d; + + return ptr; +} + +static int my_md4_init(my_md4_ctx *ctx) +{ + ctx->a = 0x67452301; + ctx->b = 0xefcdab89; + ctx->c = 0x98badcfe; + ctx->d = 0x10325476; + + ctx->lo = 0; + ctx->hi = 0; + + return 1; +} + +static void my_md4_update(my_md4_ctx *ctx, + const void *input, unsigned long len) +{ + uint32_t saved_lo; + unsigned long used; + + saved_lo = ctx->lo; + ctx->lo = (saved_lo + len) & 0x1fffffff; + if(ctx->lo < saved_lo) + ctx->hi++; + ctx->hi += (uint32_t)len >> 29; + + used = saved_lo & 0x3f; + + if(used) { + unsigned long available = 64 - used; + + if(len < available) { + memcpy(&ctx->buffer[used], input, len); + return; + } + + memcpy(&ctx->buffer[used], input, available); + input = (const unsigned char *)input + available; + len -= available; + my_md4_body(ctx, ctx->buffer, 64); + } + + if(len >= 64) { + input = my_md4_body(ctx, input, len & ~(unsigned long)0x3f); + len &= 0x3f; + } + + memcpy(ctx->buffer, input, len); +} + +static void my_md4_final(unsigned char *digest, my_md4_ctx *ctx) +{ + unsigned long used, available; + + used = ctx->lo & 0x3f; + + ctx->buffer[used++] = 0x80; + + available = 64 - used; + + if(available < 8) { + memset(&ctx->buffer[used], 0, available); + my_md4_body(ctx, ctx->buffer, 64); + used = 0; + available = 64; + } + + memset(&ctx->buffer[used], 0, available - 8); + + ctx->lo <<= 3; + ctx->buffer[56] = curlx_ultouc((ctx->lo) & 0xff); + ctx->buffer[57] = curlx_ultouc((ctx->lo >> 8) & 0xff); + ctx->buffer[58] = curlx_ultouc((ctx->lo >> 16) & 0xff); + ctx->buffer[59] = curlx_ultouc((ctx->lo >> 24) & 0xff); + ctx->buffer[60] = curlx_ultouc((ctx->hi) & 0xff); + ctx->buffer[61] = curlx_ultouc((ctx->hi >> 8) & 0xff); + ctx->buffer[62] = curlx_ultouc((ctx->hi >> 16) & 0xff); + ctx->buffer[63] = curlx_ultouc(ctx->hi >> 24); + + my_md4_body(ctx, ctx->buffer, 64); + + digest[0] = curlx_ultouc((ctx->a) & 0xff); + digest[1] = curlx_ultouc((ctx->a >> 8) & 0xff); + digest[2] = curlx_ultouc((ctx->a >> 16) & 0xff); + digest[3] = curlx_ultouc(ctx->a >> 24); + digest[4] = curlx_ultouc((ctx->b) & 0xff); + digest[5] = curlx_ultouc((ctx->b >> 8) & 0xff); + digest[6] = curlx_ultouc((ctx->b >> 16) & 0xff); + digest[7] = curlx_ultouc(ctx->b >> 24); + digest[8] = curlx_ultouc((ctx->c) & 0xff); + digest[9] = curlx_ultouc((ctx->c >> 8) & 0xff); + digest[10] = curlx_ultouc((ctx->c >> 16) & 0xff); + digest[11] = curlx_ultouc(ctx->c >> 24); + digest[12] = curlx_ultouc((ctx->d) & 0xff); + digest[13] = curlx_ultouc((ctx->d >> 8) & 0xff); + digest[14] = curlx_ultouc((ctx->d >> 16) & 0xff); + digest[15] = curlx_ultouc(ctx->d >> 24); + + memset(ctx, 0, sizeof(*ctx)); +} + +#endif /* CRYPTO LIBS */ + +CURLcode Curl_md4it(unsigned char *output, + const unsigned char *input, const size_t len) +{ + my_md4_ctx ctx; + if(!my_md4_init(&ctx)) + return CURLE_FAILED_INIT; + my_md4_update(&ctx, input, curlx_uztoui(len)); + my_md4_final(output, &ctx); + return CURLE_OK; +} + +#endif /* USE_CURL_NTLM_CORE */ diff --git a/3rdparty/curl-8.21.0/lib/md5.c b/3rdparty/curl-8.21.0/lib/md5.c new file mode 100644 index 0000000000..1f1b4f8ad6 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/md5.c @@ -0,0 +1,612 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if (defined(USE_CURL_NTLM_CORE) && !defined(USE_WINDOWS_SSPI)) || \ + !defined(CURL_DISABLE_DIGEST_AUTH) + +#include "curl_md5.h" +#include "curl_hmac.h" + +#ifdef USE_OPENSSL +#include +#endif + +#ifdef USE_WOLFSSL +#include +#endif + +#ifdef USE_MBEDTLS +#include +#if MBEDTLS_VERSION_NUMBER < 0x03020000 +#error "mbedTLS 3.2.0 or later required" +#endif +#include +#endif + +#ifdef USE_GNUTLS +#include +#include + +typedef struct md5_ctx my_md5_ctx; + +static CURLcode my_md5_init(void *ctx) +{ + md5_init(ctx); + return CURLE_OK; +} + +static void my_md5_update(void *ctx, + const unsigned char *input, unsigned int len) +{ + md5_update(ctx, len, input); +} + +static void my_md5_final(unsigned char *digest, void *ctx) +{ +#if NETTLE_VERSION_MAJOR >= 4 + md5_digest(ctx, digest); +#else + md5_digest(ctx, 16, digest); +#endif +} + +#elif defined(USE_OPENSSL) && \ + !defined(OPENSSL_NO_MD5) && !defined(OPENSSL_NO_DEPRECATED_3_0) +#include + +typedef MD5_CTX my_md5_ctx; + +static CURLcode my_md5_init(void *ctx) +{ + if(!MD5_Init(ctx)) + return CURLE_OUT_OF_MEMORY; + + return CURLE_OK; +} + +static void my_md5_update(void *ctx, + const unsigned char *input, unsigned int len) +{ + (void)MD5_Update(ctx, input, len); +} + +static void my_md5_final(unsigned char *digest, void *ctx) +{ + (void)MD5_Final(digest, ctx); +} + +#elif defined(USE_WOLFSSL) && !defined(NO_MD5) +#include + +typedef wc_Md5 my_md5_ctx; + +static CURLcode my_md5_init(void *ctx) +{ + if(wc_InitMd5(ctx)) + return CURLE_OUT_OF_MEMORY; + return CURLE_OK; +} + +static void my_md5_update(void *ctx, + const unsigned char *input, unsigned int len) +{ + (void)wc_Md5Update(ctx, input, (word32)len); +} + +static void my_md5_final(unsigned char *digest, void *ctx) +{ + (void)wc_Md5Final(ctx, digest); +} + +#elif defined(USE_MBEDTLS) && \ + defined(PSA_WANT_ALG_MD5) && PSA_WANT_ALG_MD5 +#include + +typedef psa_hash_operation_t my_md5_ctx; + +static CURLcode my_md5_init(void *ctx) +{ + memset(ctx, 0, sizeof(my_md5_ctx)); + if(psa_hash_setup(ctx, PSA_ALG_MD5) != PSA_SUCCESS) + return CURLE_OUT_OF_MEMORY; + return CURLE_OK; +} + +static void my_md5_update(void *ctx, + const unsigned char *input, unsigned int len) +{ + (void)psa_hash_update(ctx, input, len); +} + +static void my_md5_final(unsigned char *digest, void *ctx) +{ + size_t actual_length; + (void)psa_hash_finish(ctx, digest, 16, &actual_length); +} + +#elif (defined(__MAC_OS_X_VERSION_MAX_ALLOWED) && \ + (__MAC_OS_X_VERSION_MAX_ALLOWED >= 1040) && \ + defined(__MAC_OS_X_VERSION_MIN_REQUIRED) && \ + (__MAC_OS_X_VERSION_MIN_REQUIRED < 101500)) || \ + (defined(__IPHONE_OS_VERSION_MAX_ALLOWED) && \ + (__IPHONE_OS_VERSION_MAX_ALLOWED >= 20000) && \ + defined(__IPHONE_OS_VERSION_MIN_REQUIRED) && \ + (__IPHONE_OS_VERSION_MIN_REQUIRED < 130000)) +#include + +/* For Apple operating systems: CommonCrypto has the functions we need. + These functions are available on Tiger and later, as well as iOS 2.0 + and later. If you are building for an older cat, well, sorry. + + Declaring the functions as static like this seems to be a bit more + reliable than defining COMMON_DIGEST_FOR_OPENSSL on older cats. */ +# define my_md5_ctx CC_MD5_CTX + +static CURLcode my_md5_init(void *ctx) +{ + if(!CC_MD5_Init(ctx)) + return CURLE_OUT_OF_MEMORY; + + return CURLE_OK; +} + +static void my_md5_update(void *ctx, + const unsigned char *input, unsigned int len) +{ + CC_MD5_Update(ctx, input, len); +} + +static void my_md5_final(unsigned char *digest, void *ctx) +{ + CC_MD5_Final(digest, ctx); +} + +#elif defined(USE_WIN32_CRYPTO) +#include + +struct md5_ctx { + HCRYPTPROV hCryptProv; + HCRYPTHASH hHash; +}; +typedef struct md5_ctx my_md5_ctx; + +static CURLcode my_md5_init(void *in) +{ + my_md5_ctx *ctx = (my_md5_ctx *)in; + if(!CryptAcquireContext(&ctx->hCryptProv, NULL, NULL, PROV_RSA_FULL, + CRYPT_VERIFYCONTEXT | CRYPT_SILENT)) + return CURLE_OUT_OF_MEMORY; + + if(!CryptCreateHash(ctx->hCryptProv, CALG_MD5, 0, 0, &ctx->hHash)) { + CryptReleaseContext(ctx->hCryptProv, 0); + ctx->hCryptProv = 0; + return CURLE_FAILED_INIT; + } + + return CURLE_OK; +} + +static void my_md5_update(void *in, + const unsigned char *input, unsigned int len) +{ + my_md5_ctx *ctx = in; + CryptHashData(ctx->hHash, (const BYTE *)input, len, 0); +} + +static void my_md5_final(unsigned char *digest, void *in) +{ + my_md5_ctx *ctx = (my_md5_ctx *)in; + unsigned long length = 0; + CryptGetHashParam(ctx->hHash, HP_HASHVAL, NULL, &length, 0); + if(length == 16) + CryptGetHashParam(ctx->hHash, HP_HASHVAL, digest, &length, 0); + if(ctx->hHash) + CryptDestroyHash(ctx->hHash); + if(ctx->hCryptProv) + CryptReleaseContext(ctx->hCryptProv, 0); +} + +#else + +/* When no other crypto library is available we use this code segment */ + +/* + * This is an OpenSSL-compatible implementation of the RSA Data Security, Inc. + * MD5 Message-Digest Algorithm (RFC 1321). + * + * Homepage: + * https://openwall.info/wiki/people/solar/software/public-domain-source-code/md5 + * + * Author: + * Alexander Peslyak, better known as Solar Designer + * + * This software was written by Alexander Peslyak in 2001. No copyright is + * claimed, and the software is hereby placed in the public domain. In case + * this attempt to disclaim copyright and place the software in the public + * domain is deemed null and void, then the software is Copyright (c) 2001 + * Alexander Peslyak and it is hereby released to the general public under + * the following terms: + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted. + * + * There is ABSOLUTELY NO WARRANTY, express or implied. + * + * (This is a heavily cut-down "BSD license".) + */ + +struct md5_ctx { + uint32_t lo, hi; + uint32_t a, b, c, d; + unsigned char buffer[64]; + uint32_t block[16]; +}; +typedef struct md5_ctx my_md5_ctx; + +/* + * The basic MD5 functions. + * + * F and G are optimized compared to their RFC 1321 definitions for + * architectures that lack an AND-NOT instruction, like in Colin Plumb's + * implementation. + */ +#define MD5_F(x, y, z) ((z) ^ ((x) & ((y) ^ (z)))) +#define MD5_G(x, y, z) ((y) ^ ((z) & ((x) ^ (y)))) +#define MD5_H(x, y, z) (((x) ^ (y)) ^ (z)) +#define MD5_H2(x, y, z) ((x) ^ ((y) ^ (z))) +#define MD5_I(x, y, z) ((y) ^ ((x) | ~(z))) + +/* + * The MD5 transformation for all four rounds. + */ +#define MD5_STEP(f, a, b, c, d, x, t, s) \ + (a) += f(b, c, d) + (x) + (t); \ + (a) = (((a) << (s)) | (((a) & 0xffffffff) >> (32 - (s)))); \ + (a) += (b); + +/* + * SET reads 4 input bytes in little-endian byte order and stores them + * in a properly aligned word in host byte order. + * + * The check for little-endian architectures that tolerate unaligned memory + * accesses is an optimization. Nothing will break if it does not work. + */ +#if defined(__i386__) || defined(__x86_64__) || defined(__vax__) +#define MD5_SET(n) (*(const uint32_t *)(const void *)&ptr[(n) * 4]) +#define MD5_GET(n) MD5_SET(n) +#else +#define MD5_SET(n) (ctx->block[n] = \ + (uint32_t)ptr[(n) * 4] | \ + ((uint32_t)ptr[((n) * 4) + 1] << 8) | \ + ((uint32_t)ptr[((n) * 4) + 2] << 16) | \ + ((uint32_t)ptr[((n) * 4) + 3] << 24)) +#define MD5_GET(n) ctx->block[n] +#endif + +/* + * This processes one or more 64-byte data blocks, but does NOT update + * the bit counters. There are no alignment requirements. + */ +static const void *my_md5_body(my_md5_ctx *ctx, + const void *data, unsigned long size) +{ + const unsigned char *ptr; + uint32_t a, b, c, d; + + ptr = (const unsigned char *)data; + + a = ctx->a; + b = ctx->b; + c = ctx->c; + d = ctx->d; + + do { + uint32_t saved_a, saved_b, saved_c, saved_d; + + saved_a = a; + saved_b = b; + saved_c = c; + saved_d = d; + + /* Round 1 */ + MD5_STEP(MD5_F, a, b, c, d, MD5_SET(0), 0xd76aa478, 7) + MD5_STEP(MD5_F, d, a, b, c, MD5_SET(1), 0xe8c7b756, 12) + MD5_STEP(MD5_F, c, d, a, b, MD5_SET(2), 0x242070db, 17) + MD5_STEP(MD5_F, b, c, d, a, MD5_SET(3), 0xc1bdceee, 22) + MD5_STEP(MD5_F, a, b, c, d, MD5_SET(4), 0xf57c0faf, 7) + MD5_STEP(MD5_F, d, a, b, c, MD5_SET(5), 0x4787c62a, 12) + MD5_STEP(MD5_F, c, d, a, b, MD5_SET(6), 0xa8304613, 17) + MD5_STEP(MD5_F, b, c, d, a, MD5_SET(7), 0xfd469501, 22) + MD5_STEP(MD5_F, a, b, c, d, MD5_SET(8), 0x698098d8, 7) + MD5_STEP(MD5_F, d, a, b, c, MD5_SET(9), 0x8b44f7af, 12) + MD5_STEP(MD5_F, c, d, a, b, MD5_SET(10), 0xffff5bb1, 17) + MD5_STEP(MD5_F, b, c, d, a, MD5_SET(11), 0x895cd7be, 22) + MD5_STEP(MD5_F, a, b, c, d, MD5_SET(12), 0x6b901122, 7) + MD5_STEP(MD5_F, d, a, b, c, MD5_SET(13), 0xfd987193, 12) + MD5_STEP(MD5_F, c, d, a, b, MD5_SET(14), 0xa679438e, 17) + MD5_STEP(MD5_F, b, c, d, a, MD5_SET(15), 0x49b40821, 22) + + /* Round 2 */ + MD5_STEP(MD5_G, a, b, c, d, MD5_GET(1), 0xf61e2562, 5) + MD5_STEP(MD5_G, d, a, b, c, MD5_GET(6), 0xc040b340, 9) + MD5_STEP(MD5_G, c, d, a, b, MD5_GET(11), 0x265e5a51, 14) + MD5_STEP(MD5_G, b, c, d, a, MD5_GET(0), 0xe9b6c7aa, 20) + MD5_STEP(MD5_G, a, b, c, d, MD5_GET(5), 0xd62f105d, 5) + MD5_STEP(MD5_G, d, a, b, c, MD5_GET(10), 0x02441453, 9) + MD5_STEP(MD5_G, c, d, a, b, MD5_GET(15), 0xd8a1e681, 14) + MD5_STEP(MD5_G, b, c, d, a, MD5_GET(4), 0xe7d3fbc8, 20) + MD5_STEP(MD5_G, a, b, c, d, MD5_GET(9), 0x21e1cde6, 5) + MD5_STEP(MD5_G, d, a, b, c, MD5_GET(14), 0xc33707d6, 9) + MD5_STEP(MD5_G, c, d, a, b, MD5_GET(3), 0xf4d50d87, 14) + MD5_STEP(MD5_G, b, c, d, a, MD5_GET(8), 0x455a14ed, 20) + MD5_STEP(MD5_G, a, b, c, d, MD5_GET(13), 0xa9e3e905, 5) + MD5_STEP(MD5_G, d, a, b, c, MD5_GET(2), 0xfcefa3f8, 9) + MD5_STEP(MD5_G, c, d, a, b, MD5_GET(7), 0x676f02d9, 14) + MD5_STEP(MD5_G, b, c, d, a, MD5_GET(12), 0x8d2a4c8a, 20) + + /* Round 3 */ + MD5_STEP(MD5_H, a, b, c, d, MD5_GET(5), 0xfffa3942, 4) + MD5_STEP(MD5_H2, d, a, b, c, MD5_GET(8), 0x8771f681, 11) + MD5_STEP(MD5_H, c, d, a, b, MD5_GET(11), 0x6d9d6122, 16) + MD5_STEP(MD5_H2, b, c, d, a, MD5_GET(14), 0xfde5380c, 23) + MD5_STEP(MD5_H, a, b, c, d, MD5_GET(1), 0xa4beea44, 4) + MD5_STEP(MD5_H2, d, a, b, c, MD5_GET(4), 0x4bdecfa9, 11) + MD5_STEP(MD5_H, c, d, a, b, MD5_GET(7), 0xf6bb4b60, 16) + MD5_STEP(MD5_H2, b, c, d, a, MD5_GET(10), 0xbebfbc70, 23) + MD5_STEP(MD5_H, a, b, c, d, MD5_GET(13), 0x289b7ec6, 4) + MD5_STEP(MD5_H2, d, a, b, c, MD5_GET(0), 0xeaa127fa, 11) + MD5_STEP(MD5_H, c, d, a, b, MD5_GET(3), 0xd4ef3085, 16) + MD5_STEP(MD5_H2, b, c, d, a, MD5_GET(6), 0x04881d05, 23) + MD5_STEP(MD5_H, a, b, c, d, MD5_GET(9), 0xd9d4d039, 4) + MD5_STEP(MD5_H2, d, a, b, c, MD5_GET(12), 0xe6db99e5, 11) + MD5_STEP(MD5_H, c, d, a, b, MD5_GET(15), 0x1fa27cf8, 16) + MD5_STEP(MD5_H2, b, c, d, a, MD5_GET(2), 0xc4ac5665, 23) + + /* Round 4 */ + MD5_STEP(MD5_I, a, b, c, d, MD5_GET(0), 0xf4292244, 6) + MD5_STEP(MD5_I, d, a, b, c, MD5_GET(7), 0x432aff97, 10) + MD5_STEP(MD5_I, c, d, a, b, MD5_GET(14), 0xab9423a7, 15) + MD5_STEP(MD5_I, b, c, d, a, MD5_GET(5), 0xfc93a039, 21) + MD5_STEP(MD5_I, a, b, c, d, MD5_GET(12), 0x655b59c3, 6) + MD5_STEP(MD5_I, d, a, b, c, MD5_GET(3), 0x8f0ccc92, 10) + MD5_STEP(MD5_I, c, d, a, b, MD5_GET(10), 0xffeff47d, 15) + MD5_STEP(MD5_I, b, c, d, a, MD5_GET(1), 0x85845dd1, 21) + MD5_STEP(MD5_I, a, b, c, d, MD5_GET(8), 0x6fa87e4f, 6) + MD5_STEP(MD5_I, d, a, b, c, MD5_GET(15), 0xfe2ce6e0, 10) + MD5_STEP(MD5_I, c, d, a, b, MD5_GET(6), 0xa3014314, 15) + MD5_STEP(MD5_I, b, c, d, a, MD5_GET(13), 0x4e0811a1, 21) + MD5_STEP(MD5_I, a, b, c, d, MD5_GET(4), 0xf7537e82, 6) + MD5_STEP(MD5_I, d, a, b, c, MD5_GET(11), 0xbd3af235, 10) + MD5_STEP(MD5_I, c, d, a, b, MD5_GET(2), 0x2ad7d2bb, 15) + MD5_STEP(MD5_I, b, c, d, a, MD5_GET(9), 0xeb86d391, 21) + + a += saved_a; + b += saved_b; + c += saved_c; + d += saved_d; + + ptr += 64; + } while(size -= 64); + + ctx->a = a; + ctx->b = b; + ctx->c = c; + ctx->d = d; + + return ptr; +} + +static CURLcode my_md5_init(void *in) +{ + my_md5_ctx *ctx = (my_md5_ctx *)in; + ctx->a = 0x67452301; + ctx->b = 0xefcdab89; + ctx->c = 0x98badcfe; + ctx->d = 0x10325476; + + ctx->lo = 0; + ctx->hi = 0; + + return CURLE_OK; +} + +static void my_md5_update(void *in, + const unsigned char *input, unsigned int len) +{ + uint32_t saved_lo; + unsigned int used; + my_md5_ctx *ctx = (my_md5_ctx *)in; + + saved_lo = ctx->lo; + ctx->lo = (saved_lo + len) & 0x1fffffff; + if(ctx->lo < saved_lo) + ctx->hi++; + ctx->hi += (uint32_t)len >> 29; + + used = saved_lo & 0x3f; + + if(used) { + unsigned int available = 64 - used; + + if(len < available) { + memcpy(&ctx->buffer[used], input, len); + return; + } + + memcpy(&ctx->buffer[used], input, available); + input = (const unsigned char *)input + available; + len -= available; + my_md5_body(ctx, ctx->buffer, 64); + } + + if(len >= 64) { + input = my_md5_body(ctx, input, len & ~(unsigned long)0x3f); + len &= 0x3f; + } + + memcpy(ctx->buffer, input, len); +} + +static void my_md5_final(unsigned char *digest, void *in) +{ + unsigned int used, available; + my_md5_ctx *ctx = (my_md5_ctx *)in; + + used = ctx->lo & 0x3f; + + ctx->buffer[used++] = 0x80; + + available = 64 - used; + + if(available < 8) { + memset(&ctx->buffer[used], 0, available); + my_md5_body(ctx, ctx->buffer, 64); + used = 0; + available = 64; + } + + memset(&ctx->buffer[used], 0, available - 8); + + ctx->lo <<= 3; + ctx->buffer[56] = curlx_ultouc((ctx->lo) & 0xff); + ctx->buffer[57] = curlx_ultouc((ctx->lo >> 8) & 0xff); + ctx->buffer[58] = curlx_ultouc((ctx->lo >> 16) & 0xff); + ctx->buffer[59] = curlx_ultouc(ctx->lo >> 24); + ctx->buffer[60] = curlx_ultouc((ctx->hi) & 0xff); + ctx->buffer[61] = curlx_ultouc((ctx->hi >> 8) & 0xff); + ctx->buffer[62] = curlx_ultouc((ctx->hi >> 16) & 0xff); + ctx->buffer[63] = curlx_ultouc(ctx->hi >> 24); + + my_md5_body(ctx, ctx->buffer, 64); + + digest[0] = curlx_ultouc((ctx->a) & 0xff); + digest[1] = curlx_ultouc((ctx->a >> 8) & 0xff); + digest[2] = curlx_ultouc((ctx->a >> 16) & 0xff); + digest[3] = curlx_ultouc(ctx->a >> 24); + digest[4] = curlx_ultouc((ctx->b) & 0xff); + digest[5] = curlx_ultouc((ctx->b >> 8) & 0xff); + digest[6] = curlx_ultouc((ctx->b >> 16) & 0xff); + digest[7] = curlx_ultouc(ctx->b >> 24); + digest[8] = curlx_ultouc((ctx->c) & 0xff); + digest[9] = curlx_ultouc((ctx->c >> 8) & 0xff); + digest[10] = curlx_ultouc((ctx->c >> 16) & 0xff); + digest[11] = curlx_ultouc(ctx->c >> 24); + digest[12] = curlx_ultouc((ctx->d) & 0xff); + digest[13] = curlx_ultouc((ctx->d >> 8) & 0xff); + digest[14] = curlx_ultouc((ctx->d >> 16) & 0xff); + digest[15] = curlx_ultouc(ctx->d >> 24); + + memset(ctx, 0, sizeof(*ctx)); +} + +#endif /* CRYPTO LIBS */ + +const struct HMAC_params Curl_HMAC_MD5 = { + my_md5_init, /* Hash initialization function. */ + my_md5_update, /* Hash update function. */ + my_md5_final, /* Hash computation end function. */ + sizeof(my_md5_ctx), /* Size of hash context structure. */ + 64, /* Maximum key length. */ + 16 /* Result size. */ +}; + +const struct MD5_params Curl_DIGEST_MD5 = { + my_md5_init, /* Digest initialization function */ + my_md5_update, /* Digest update function */ + my_md5_final, /* Digest computation end function */ + sizeof(my_md5_ctx), /* Size of digest context struct */ + 16 /* Result size */ +}; + +/* + * @unittest: 1601 + * Returns CURLE_OK on success. + */ +CURLcode Curl_md5it(unsigned char *output, + const unsigned char *input, size_t len) +{ + CURLcode result; + my_md5_ctx ctx; + + result = my_md5_init(&ctx); + if(!result) { + do { + unsigned int ilen = (unsigned int)CURLMIN(len, UINT_MAX); + my_md5_update(&ctx, input, ilen); + input += ilen; + len -= ilen; + } while(len); + my_md5_final(output, &ctx); + } + return result; +} + +struct MD5_context *Curl_MD5_init(const struct MD5_params *md5params) +{ + struct MD5_context *ctxt; + + /* Create MD5 context */ + ctxt = curlx_malloc(sizeof(*ctxt)); + + if(!ctxt) + return ctxt; + + ctxt->md5_hashctx = curlx_malloc(md5params->md5_ctxtsize); + + if(!ctxt->md5_hashctx) { + curlx_free(ctxt); + return NULL; + } + + ctxt->md5_hash = md5params; + + if((*md5params->md5_init_func)(ctxt->md5_hashctx)) { + curlx_free(ctxt->md5_hashctx); + curlx_free(ctxt); + return NULL; + } + + return ctxt; +} + +CURLcode Curl_MD5_update(struct MD5_context *context, + const unsigned char *input, unsigned int len) +{ + (*context->md5_hash->md5_update_func)(context->md5_hashctx, input, len); + + return CURLE_OK; +} + +CURLcode Curl_MD5_final(struct MD5_context *context, unsigned char *result) +{ + (*context->md5_hash->md5_final_func)(result, context->md5_hashctx); + + curlx_free(context->md5_hashctx); + curlx_free(context); + + return CURLE_OK; +} + +#endif /* Using NTLM (without SSPI) || Digest */ diff --git a/3rdparty/curl-8.21.0/lib/memdebug.c b/3rdparty/curl-8.21.0/lib/memdebug.c new file mode 100644 index 0000000000..b6af2c6d35 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/memdebug.c @@ -0,0 +1,579 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef CURL_MEMDEBUG + +#include /* for offsetof() */ + +#include "urldata.h" +#include "curl_threads.h" +#include "curlx/fopen.h" /* for CURLX_FOPEN_LOW(), CURLX_FREOPEN_LOW() */ + +#ifdef USE_BACKTRACE +#include +#endif + +struct memdebug { + size_t size; + union { + curl_off_t o; + double d; + void *p; + } mem[1]; + /* I am hoping this is the thing with the strictest alignment + * requirements. That also means we waste some space :-( */ +}; + +/* + * Note that these debug functions are simple and they are meant to remain so. + * For advanced analysis, record a log file and write perl scripts to analyze + * them! + * + * Do not use these with multi-threaded test programs! + */ + +FILE *curl_dbg_logfile = NULL; +static bool registered_cleanup = FALSE; /* atexit registered cleanup */ +static bool memlimit = FALSE; /* enable memory limit */ +static long memsize = 0; /* set number of mallocs allowed */ +#ifdef USE_BACKTRACE +static struct backtrace_state *btstate; +#endif + +static char membuf[10000]; +static size_t memwidx = 0; /* write index */ + +#ifdef USE_MUTEX +static bool dbg_mutex_init = 0; +static curl_mutex_t dbg_mutex; +#endif + +static bool curl_dbg_lock(void) +{ +#ifdef USE_MUTEX + if(dbg_mutex_init) { + Curl_mutex_acquire(&dbg_mutex); + return TRUE; + } +#endif + return FALSE; +} + +static void curl_dbg_unlock(bool was_locked) +{ +#ifdef USE_MUTEX + if(was_locked) + Curl_mutex_release(&dbg_mutex); +#else + (void)was_locked; +#endif +} + +static void curl_dbg_log_locked(const char *format, ...) CURL_PRINTF(1, 2); + +/* LeakSantizier (LSAN) calls _exit() instead of exit() when a leak is detected + on exit so the logfile must be closed explicitly or data could be lost. + Though _exit() does not call atexit handlers such as this, LSAN's call to + _exit() comes after the atexit handlers are called. curl/curl#6620 */ +static void curl_dbg_cleanup(void) +{ + bool locked = curl_dbg_lock(); + if(curl_dbg_logfile && + curl_dbg_logfile != stderr && + curl_dbg_logfile != stdout) { + if(memwidx) + fwrite(membuf, 1, memwidx, curl_dbg_logfile); + /* !checksrc! disable BANNEDFUNC 1 */ + fclose(curl_dbg_logfile); + } + curl_dbg_logfile = NULL; + curl_dbg_unlock(locked); +#ifdef USE_MUTEX + if(dbg_mutex_init) { + Curl_mutex_destroy(&dbg_mutex); + dbg_mutex_init = FALSE; + } +#endif +} + +#ifdef USE_BACKTRACE +static void error_bt_callback(void *data, const char *message, + int error_number) +{ + (void)data; + if(error_number == -1) + curl_dbg_log("compile with -g\n\n"); + else + curl_dbg_log("Backtrace error %d: %s\n", error_number, message); +} + +static int full_callback(void *data, uintptr_t pc, const char *pathname, + int line_number, const char *function) +{ + (void)data; + (void)pc; + if(pathname || function || line_number) + curl_dbg_log("BT %s:%d -- %s\n", pathname, line_number, function); + return 0; +} + +static void dump_bt(void) +{ + backtrace_full(btstate, 0, full_callback, error_bt_callback, NULL); +} +#else +#define dump_bt() /* nothing to do */ +#endif + +/* this sets the log filename */ +void curl_dbg_memdebug(const char *logname) +{ + if(!curl_dbg_logfile) { + if(logname && *logname) + curl_dbg_logfile = CURLX_FOPEN_LOW(logname, FOPEN_WRITETEXT); +#ifdef MEMDEBUG_LOG_SYNC + /* Flush the log file after every line so the log is not lost in a crash */ + if(curl_dbg_logfile) + setbuf(curl_dbg_logfile, (char *)NULL); +#endif + } +#ifdef USE_MUTEX + if(!dbg_mutex_init) { + dbg_mutex_init = TRUE; + Curl_mutex_init(&dbg_mutex); + } +#endif +#ifdef USE_BACKTRACE + btstate = backtrace_create_state(NULL, 0, error_bt_callback, NULL); +#endif + if(!registered_cleanup) + registered_cleanup = !atexit(curl_dbg_cleanup); +} + +/* This function sets the number of malloc() calls that should return + successfully! */ +void curl_dbg_memlimit(long limit) +{ + if(!memlimit) { + memlimit = TRUE; + memsize = limit; + } +} + +/* returns TRUE if this is not allowed! */ +static bool countcheck(const char *func, int line, const char *source) +{ + /* if source is NULL, then the call is made internally and this check + should not be made */ + if(memlimit && source) { + if(!memsize) { + /* log to file */ + curl_dbg_log("LIMIT %s:%d %s reached memlimit\n", source, line, func); + /* log to stderr also */ + curl_mfprintf(stderr, "LIMIT %s:%d %s reached memlimit\n", + source, line, func); + dump_bt(); + fflush(curl_dbg_logfile); /* because it might crash now */ + /* !checksrc! disable ERRNOVAR 1 */ + errno = ENOMEM; + return TRUE; /* RETURN ERROR! */ + } + else + memsize--; /* countdown */ + } + + return FALSE; /* allow this */ +} + +ALLOC_FUNC +void *curl_dbg_malloc(size_t wantedsize, int line, const char *source) +{ + struct memdebug *mem; + size_t size; + + DEBUGASSERT(wantedsize != 0); + + if(countcheck("malloc", line, source)) + return NULL; + + /* alloc at least 64 bytes */ + size = sizeof(struct memdebug) + wantedsize; + + mem = Curl_cmalloc(size); + if(mem) { + mem->size = wantedsize; + } + + if(source) + curl_dbg_log("MEM %s:%d malloc(%zu) = %p\n", + source, line, wantedsize, + mem ? (void *)mem->mem : (void *)0); + + return mem ? mem->mem : NULL; +} + +ALLOC_FUNC +void *curl_dbg_calloc(size_t wanted_elements, size_t wanted_size, + int line, const char *source) +{ + struct memdebug *mem; + size_t size, user_size; + + DEBUGASSERT(wanted_elements != 0); + DEBUGASSERT(wanted_size != 0); + + if(countcheck("calloc", line, source)) + return NULL; + + /* alloc at least 64 bytes */ + user_size = wanted_size * wanted_elements; + size = sizeof(struct memdebug) + user_size; + + mem = Curl_ccalloc(1, size); + if(mem) + mem->size = user_size; + + if(source) + curl_dbg_log("MEM %s:%d calloc(%zu,%zu) = %p\n", + source, line, wanted_elements, wanted_size, + mem ? (void *)mem->mem : (void *)0); + + return mem ? mem->mem : NULL; +} + +ALLOC_FUNC +char *curl_dbg_strdup(const char *str, int line, const char *source) +{ + char *mem; + size_t len; + + DEBUGASSERT(str); + + if(countcheck("strdup", line, source)) + return NULL; + + len = strlen(str) + 1; + + mem = curl_dbg_malloc(len, 0, NULL); /* NULL prevents logging */ + if(mem) + memcpy(mem, str, len); + + if(source) + curl_dbg_log("MEM %s:%d strdup(%p) (%zu) = %p\n", + source, line, (const void *)str, len, (const void *)mem); + + return mem; +} + +#if defined(_WIN32) && defined(UNICODE) +ALLOC_FUNC +wchar_t *curl_dbg_wcsdup(const wchar_t *str, int line, const char *source) +{ + wchar_t *mem; + size_t wsiz, bsiz; + + DEBUGASSERT(str); + + if(countcheck("wcsdup", line, source)) + return NULL; + + wsiz = wcslen(str) + 1; + bsiz = wsiz * sizeof(wchar_t); + + mem = curl_dbg_malloc(bsiz, 0, NULL); /* NULL prevents logging */ + if(mem) + memcpy(mem, str, bsiz); + + if(source) + curl_dbg_log("MEM %s:%d wcsdup(%p) (%zu) = %p\n", + source, line, (const void *)str, bsiz, (void *)mem); + + return mem; +} +#endif + +/* We provide a realloc() that accepts a NULL as pointer, which then + performs a malloc(). In order to work with ares. */ +void *curl_dbg_realloc(void *ptr, size_t wantedsize, + int line, const char *source) +{ + struct memdebug *mem = NULL; + bool was_locked; + + size_t size = sizeof(struct memdebug) + wantedsize; + + DEBUGASSERT(wantedsize != 0); + + if(countcheck("realloc", line, source)) + return NULL; + + /* need to realloc under lock, as we get out-of-order log + * entries otherwise, since another thread might alloc the + * memory released by realloc() before otherwise would log it. */ + was_locked = curl_dbg_lock(); +#ifdef __INTEL_COMPILER +# pragma warning(push) +# pragma warning(disable:1684) + /* 1684: conversion from pointer to same-sized integral type */ +#endif + + if(ptr) + mem = (void *)((char *)ptr - offsetof(struct memdebug, mem)); + +#ifdef __INTEL_COMPILER +# pragma warning(pop) +#endif + + mem = Curl_crealloc(mem, size); + if(source) + curl_dbg_log_locked("MEM %s:%d realloc(%p, %zu) = %p\n", + source, line, (void *)ptr, wantedsize, + mem ? (void *)mem->mem : (void *)0); + + curl_dbg_unlock(was_locked); + if(mem) { + mem->size = wantedsize; + return mem->mem; + } + + return NULL; +} + +void curl_dbg_free(void *ptr, int line, const char *source) +{ + if(ptr) { + struct memdebug *mem; + + if(source) + curl_dbg_log("MEM %s:%d free(%p)\n", source, line, (void *)ptr); + +#ifdef __INTEL_COMPILER +# pragma warning(push) +# pragma warning(disable:1684) + /* 1684: conversion from pointer to same-sized integral type */ +#endif + + mem = (void *)((char *)ptr - offsetof(struct memdebug, mem)); + +#ifdef __INTEL_COMPILER +# pragma warning(pop) +#endif + + /* free for real */ + Curl_cfree(mem); + } +} + +curl_socket_t curl_dbg_socket(int domain, int type, int protocol, + int line, const char *source) +{ + curl_socket_t sockfd; + + if(countcheck("socket", line, source)) + return CURL_SOCKET_BAD; + + /* !checksrc! disable BANNEDFUNC 1 */ + sockfd = socket(domain, type, protocol); + + if(source && (sockfd != CURL_SOCKET_BAD)) + curl_dbg_log("FD %s:%d socket() = %" FMT_SOCKET_T "\n", + source, line, sockfd); + + return sockfd; +} + +#ifdef HAVE_SOCKETPAIR +int curl_dbg_socketpair(int domain, int type, int protocol, + curl_socket_t socket_vector[2], + int line, const char *source) +{ + /* !checksrc! disable BANNEDFUNC 1 */ + int res = socketpair(domain, type, protocol, socket_vector); + + if(source && (res == 0)) + curl_dbg_log("FD %s:%d socketpair() = " + "%" FMT_SOCKET_T " %" FMT_SOCKET_T "\n", + source, line, socket_vector[0], socket_vector[1]); + + return res; +} +#endif + +curl_socket_t curl_dbg_accept(curl_socket_t s, void *saddr, void *saddrlen, + int line, const char *source) +{ + struct sockaddr *addr = (struct sockaddr *)saddr; + curl_socklen_t *addrlen = (curl_socklen_t *)saddrlen; + + /* !checksrc! disable BANNEDFUNC 1 */ + curl_socket_t sockfd = accept(s, addr, addrlen); + + if(source && (sockfd != CURL_SOCKET_BAD)) + curl_dbg_log("FD %s:%d accept() = %" FMT_SOCKET_T "\n", + source, line, sockfd); + + return sockfd; +} + +#ifdef HAVE_ACCEPT4 +curl_socket_t curl_dbg_accept4(curl_socket_t s, void *saddr, void *saddrlen, + int flags, + int line, const char *source) +{ + struct sockaddr *addr = (struct sockaddr *)saddr; + curl_socklen_t *addrlen = (curl_socklen_t *)saddrlen; + + /* !checksrc! disable BANNEDFUNC 1 */ + curl_socket_t sockfd = accept4(s, addr, addrlen, flags); + + if(source && (sockfd != CURL_SOCKET_BAD)) + curl_dbg_log("FD %s:%d accept() = %" FMT_SOCKET_T "\n", + source, line, sockfd); + + return sockfd; +} +#endif + +/* separate function to allow libcurl to mark a "faked" close */ +void curl_dbg_mark_sclose(curl_socket_t sockfd, int line, const char *source) +{ + if(source) + curl_dbg_log("FD %s:%d sclose(%" FMT_SOCKET_T ")\n", + source, line, sockfd); +} + +/* this is our own defined way to close sockets on *ALL* platforms */ +int curl_dbg_sclose(curl_socket_t sockfd, int line, const char *source) +{ + curl_dbg_mark_sclose(sockfd, line, source); + return CURL_SCLOSE(sockfd); +} + +ALLOC_FUNC +FILE *curl_dbg_fopen(const char *file, const char *mode, + int line, const char *source) +{ + FILE *res = CURLX_FOPEN_LOW(file, mode); + if(source) + curl_dbg_log("FILE %s:%d fopen(\"%s\",\"%s\") = %p\n", + source, line, file, mode, (void *)res); + + return res; +} + +ALLOC_FUNC +FILE *curl_dbg_freopen(const char *file, const char *mode, FILE *fh, + int line, const char *source) +{ + FILE *res = CURLX_FREOPEN_LOW(file, mode, fh); + if(source) + curl_dbg_log("FILE %s:%d freopen(\"%s\",\"%s\",%p) = %p\n", + source, line, file, mode, (void *)fh, (void *)res); + + return res; +} + +ALLOC_FUNC +FILE *curl_dbg_fdopen(int filedes, const char *mode, + int line, const char *source) +{ + FILE *res = CURLX_FDOPEN_LOW(filedes, mode); + if(source) + curl_dbg_log("FILE %s:%d fdopen(\"%d\",\"%s\") = %p\n", + source, line, filedes, mode, (void *)res); + return res; +} + +int curl_dbg_fclose(FILE *file, int line, const char *source) +{ + int res; + + DEBUGASSERT(file); + + if(source) + curl_dbg_log("FILE %s:%d fclose(%p)\n", source, line, (void *)file); + + /* !checksrc! disable BANNEDFUNC 1 */ + res = fclose(file); + + return res; +} + +static void curl_dbg_vlog(const char * const fmt, + va_list ap) CURL_PRINTF(1, 0); + +static void curl_dbg_vlog(const char * const fmt, va_list ap) +{ + char buf[1024]; + size_t nchars = curl_mvsnprintf(buf, sizeof(buf), fmt, ap); + + if(nchars > (int)sizeof(buf) - 1) + nchars = (int)sizeof(buf) - 1; + + if(nchars > 0) { + if(sizeof(membuf) - nchars < memwidx) { + /* flush */ + fwrite(membuf, 1, memwidx, curl_dbg_logfile); + fflush(curl_dbg_logfile); + memwidx = 0; + } + if(memwidx) { + /* the previous line ends with a newline */ + DEBUGASSERT(membuf[memwidx - 1] == '\n'); + } + memcpy(&membuf[memwidx], buf, nchars); + memwidx += nchars; + } +} + +static void curl_dbg_log_locked(const char *format, ...) +{ + va_list ap; + + if(!curl_dbg_logfile) + return; + + va_start(ap, format); + curl_dbg_vlog(format, ap); + va_end(ap); +} + +/* this does the writing to the memory tracking log file */ +void curl_dbg_log(const char *format, ...) +{ + bool was_locked; + va_list ap; + + if(!curl_dbg_logfile) + return; + + was_locked = curl_dbg_lock(); + va_start(ap, format); + curl_dbg_vlog(format, ap); + va_end(ap); + curl_dbg_unlock(was_locked); +} + +#endif /* CURL_MEMDEBUG */ diff --git a/3rdparty/curl-8.21.0/lib/mime.c b/3rdparty/curl-8.21.0/lib/mime.c new file mode 100644 index 0000000000..077e599e43 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/mime.c @@ -0,0 +1,2263 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +struct Curl_easy; + +#include "mime.h" +#include "urldata.h" +#include "sendf.h" +#include "curl_trc.h" +#include "transfer.h" +#include "curlx/strdup.h" +#include "curlx/basename.h" +#include "curlx/strcopy.h" +#include "curlx/fopen.h" +#include "curlx/base64.h" + +#if !defined(CURL_DISABLE_MIME) && (!defined(CURL_DISABLE_HTTP) || \ + !defined(CURL_DISABLE_SMTP) || \ + !defined(CURL_DISABLE_IMAP)) + +#include "rand.h" +#include "slist.h" +#include "curlx/dynbuf.h" + +#define MAX_MIME_LEVELS 40 /* avoid deep nesting */ + +#define READ_ERROR ((size_t)-1) +#define STOP_FILLING ((size_t)-2) + +static size_t mime_subparts_read(char *buffer, size_t size, size_t nitems, + void *instream, bool *hasread, + size_t call_depth); +static curl_off_t mime_size(curl_mimepart *part); + +/* Quoted-printable character class table. + * + * We cannot rely on ctype functions since quoted-printable input data + * is assumed to be ASCII-compatible, even on non-ASCII platforms. */ +#define QP_OK 1 /* Can be represented by itself. */ +#define QP_SP 2 /* Space or tab. */ +#define QP_CR 3 /* Carriage return. */ +#define QP_LF 4 /* Line-feed. */ +static const unsigned char qp_class[] = { + 0, 0, 0, 0, 0, 0, 0, 0, /* 00 - 07 */ + 0, QP_SP, QP_LF, 0, 0, QP_CR, 0, 0, /* 08 - 0F */ + 0, 0, 0, 0, 0, 0, 0, 0, /* 10 - 17 */ + 0, 0, 0, 0, 0, 0, 0, 0, /* 18 - 1F */ + QP_SP, QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, /* 20 - 27 */ + QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, /* 28 - 2F */ + QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, /* 30 - 37 */ + QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, 0 , QP_OK, QP_OK, /* 38 - 3F */ + QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, /* 40 - 47 */ + QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, /* 48 - 4F */ + QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, /* 50 - 57 */ + QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, /* 58 - 5F */ + QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, /* 60 - 67 */ + QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, /* 68 - 6F */ + QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, /* 70 - 77 */ + QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, QP_OK, 0, /* 78 - 7F */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 80 - 8F */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 90 - 9F */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* A0 - AF */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* B0 - BF */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* C0 - CF */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* D0 - DF */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* E0 - EF */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /* F0 - FF */ +}; + +/* Binary --> hexadecimal ASCII table. */ +static const char aschex[] = + "\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x41\x42\x43\x44\x45\x46"; + +#ifndef __VMS +#define filesize(name, stat_data) stat_data.st_size +#define fopen_read curlx_fopen + +#else + +#include +/* + * get_vms_file_size does what it takes to get the real size of the file + * + * For fixed files, find out the size of the EOF block and adjust. + * + * For all others, have to read the entire file in, discarding the contents. + * Most posted text files will be small, and binary files like zlib archives + * and CD/DVD images should be either a STREAM_LF format or a fixed format. + * + */ +curl_off_t VmsRealFileSize(const char *name, const curlx_struct_stat *stat_buf) +{ + char buffer[8192]; + curl_off_t count; + int ret_stat; + FILE *file; + + file = curlx_fopen(name, FOPEN_READTEXT); /* VMS */ + if(!file) + return 0; + + count = 0; + ret_stat = 1; + while(ret_stat > 0) { + ret_stat = fread(buffer, 1, sizeof(buffer), file); + if(ret_stat) + count += ret_stat; + } + curlx_fclose(file); + + return count; +} + +/* + * + * VmsSpecialSize checks to see if the stat st_size can be trusted and + * if not to call a routine to get the correct size. + * + */ +static curl_off_t VmsSpecialSize(const char *name, + const curlx_struct_stat *stat_buf) +{ + switch(stat_buf->st_fab_rfm) { + case FAB$C_VAR: + case FAB$C_VFC: + return VmsRealFileSize(name, stat_buf); + break; + default: + return stat_buf->st_size; + } +} + +#define filesize(name, stat_data) VmsSpecialSize(name, &stat_data) + +/* + * vmsfopenread + * + * For upload to work as expected on VMS, different optional + * parameters must be added to the fopen command based on + * record format of the file. + * + */ +static FILE *vmsfopenread(const char *file, const char *mode) +{ + curlx_struct_stat statbuf; + int res = curlx_stat(file, &statbuf); + + if(res != -1) { + switch(statbuf.st_fab_rfm) { + case FAB$C_VAR: + case FAB$C_VFC: + case FAB$C_STMCR: + return curlx_fopen(file, FOPEN_READTEXT); /* VMS */ + break; + default: + return curlx_fopen(file, FOPEN_READTEXT, "rfm=stmlf", "ctx=stm"); + } + } + return NULL; +} + +#define fopen_read vmsfopenread +#endif /* !__VMS */ + +/* Set readback state. */ +static void mimesetstate(struct mime_state *state, + enum mimestate tok, void *ptr) +{ + state->state = tok; + state->ptr = ptr; + state->offset = 0; +} + +/* Escape header string into allocated memory. */ +static char *escape_string(struct Curl_easy *data, + const char *src, enum mimestrategy strategy) +{ + CURLcode result; + struct dynbuf db; + const char * const *table; + const char * const *p; + /* replace first character by rest of string. */ + static const char * const mimetable[] = { + "\\\\\\", + "\"\\\"", + NULL + }; + /* WHATWG HTML living standard 4.10.21.8 2 specifies: + For field names and filenames for file fields, the result of the + encoding in the previous bullet point must be escaped by replacing + any 0x0A (LF) bytes with the byte sequence `%0A`, 0x0D (CR) with `%0D` + and 0x22 (") with `%22`. + The user agent must not perform any other escapes. */ + static const char * const formtable[] = { + "\"%22", + "\r%0D", + "\n%0A", + NULL + }; + + table = formtable; + /* data can be NULL when this function is called indirectly from + curl_formget(). */ + if(strategy == MIMESTRATEGY_MAIL || (data && (data->set.mime_formescape))) + table = mimetable; + + curlx_dyn_init(&db, CURL_MAX_INPUT_LENGTH); + + for(result = curlx_dyn_addn(&db, STRCONST("")); !result && *src; src++) { + for(p = table; *p && **p != *src; p++) + ; + + if(*p) + result = curlx_dyn_add(&db, *p + 1); + else + result = curlx_dyn_addn(&db, src, 1); + } + + return curlx_dyn_ptr(&db); +} + +/* Check if header matches. */ +static char *match_header(struct curl_slist *hdr, const char *lbl, size_t len) +{ + char *value = NULL; + + if(curl_strnequal(hdr->data, lbl, len) && hdr->data[len] == ':') + for(value = hdr->data + len + 1; *value == ' '; value++) + ; + return value; +} + +/* Get a header from an slist. */ +static char *search_header(struct curl_slist *hdrlist, + const char *hdr, size_t len) +{ + char *value = NULL; + + for(; !value && hdrlist; hdrlist = hdrlist->next) + value = match_header(hdrlist, hdr, len); + + return value; +} + +static char *strippath(const char *fullfile) +{ + char *filename; + char *base; + filename = curlx_strdup(fullfile); /* duplicate since basename() may ruin + the buffer it works on */ + if(!filename) + return NULL; + base = curlx_strdup(curlx_basename(filename)); + + curlx_free(filename); /* free temporary buffer */ + + return base; /* returns an allocated string or NULL ! */ +} + +/* Initialize data encoder state. */ +static void cleanup_encoder_state(struct mime_encoder_state *p) +{ + p->pos = 0; + p->bufbeg = 0; + p->bufend = 0; +} + +/* Dummy encoder. This is used for 8-bit and binary content encodings. */ +static size_t encoder_nop_read(char *buffer, size_t size, bool ateof, + struct curl_mimepart *part) +{ + struct mime_encoder_state *st = &part->encstate; + size_t insize = st->bufend - st->bufbeg; + + (void)ateof; + + if(!size) + return STOP_FILLING; + + if(size > insize) + size = insize; + + if(size) + memcpy(buffer, st->buf + st->bufbeg, size); + + st->bufbeg += size; + return size; +} + +static curl_off_t encoder_nop_size(curl_mimepart *part) +{ + return part->datasize; +} + +/* 7-bit encoder: the encoder is a data validity check. */ +static size_t encoder_7bit_read(char *buffer, size_t size, bool ateof, + curl_mimepart *part) +{ + struct mime_encoder_state *st = &part->encstate; + size_t cursize = st->bufend - st->bufbeg; + + (void)ateof; + + if(!size) + return STOP_FILLING; + + if(size > cursize) + size = cursize; + + for(cursize = 0; cursize < size; cursize++) { + *buffer = st->buf[st->bufbeg]; + if(*buffer++ & 0x80) + return cursize ? cursize : READ_ERROR; + st->bufbeg++; + } + + return cursize; +} + +/* Base64 content encoder. */ +static size_t encoder_base64_read(char *buffer, size_t size, bool ateof, + curl_mimepart *part) +{ + struct mime_encoder_state *st = &part->encstate; + size_t cursize = 0; + int i; + char *ptr = buffer; + + while(st->bufbeg < st->bufend) { + /* Line full ? */ + if(st->pos > MAX_ENCODED_LINE_LENGTH - 4) { + /* Yes, we need 2 characters for CRLF. */ + if(size < 2) { + if(!cursize) + return STOP_FILLING; + break; + } + *ptr++ = '\r'; + *ptr++ = '\n'; + st->pos = 0; + cursize += 2; + size -= 2; + } + + /* Be sure there is enough space and input data for a base64 group. */ + if(size < 4) { + if(!cursize) + return STOP_FILLING; + break; + } + if(st->bufend - st->bufbeg < 3) + break; + + /* Encode three bytes as four characters. */ + i = st->buf[st->bufbeg++] & 0xFF; + i = (i << 8) | (st->buf[st->bufbeg++] & 0xFF); + i = (i << 8) | (st->buf[st->bufbeg++] & 0xFF); + *ptr++ = curlx_base64encdec[(i >> 18) & 0x3F]; + *ptr++ = curlx_base64encdec[(i >> 12) & 0x3F]; + *ptr++ = curlx_base64encdec[(i >> 6) & 0x3F]; + *ptr++ = curlx_base64encdec[i & 0x3F]; + cursize += 4; + st->pos += 4; + size -= 4; + } + + /* If at eof, we have to flush the buffered data. */ + if(ateof) { + if(size < 4) { + if(!cursize) + return STOP_FILLING; + } + else { + /* Buffered data size can only be 0, 1 or 2. */ + ptr[2] = ptr[3] = '='; + i = 0; + + /* If there is buffered data */ + if(st->bufend != st->bufbeg) { + + if(st->bufend - st->bufbeg == 2) + i = (st->buf[st->bufbeg + 1] & 0xFF) << 8; + + i |= (st->buf[st->bufbeg] & 0xFF) << 16; + ptr[0] = curlx_base64encdec[(i >> 18) & 0x3F]; + ptr[1] = curlx_base64encdec[(i >> 12) & 0x3F]; + if(++st->bufbeg != st->bufend) { + ptr[2] = curlx_base64encdec[(i >> 6) & 0x3F]; + st->bufbeg++; + } + cursize += 4; + st->pos += 4; + } + } + } + + return cursize; +} + +static curl_off_t encoder_base64_size(curl_mimepart *part) +{ + curl_off_t size = part->datasize; + + if(size <= 0) + return size; /* Unknown size or no data. */ + + /* Compute base64 character count. */ + size = 4 * (1 + ((size - 1) / 3)); + + /* Effective character count must include CRLFs. */ + return size + (2 * ((size - 1) / MAX_ENCODED_LINE_LENGTH)); +} + +/* Quoted-printable lookahead. + * + * Check if a CRLF or end of data is in input buffer at current position + n. + * Return -1 if more data needed, 1 if CRLF or end of data, else 0. + */ +static int qp_lookahead_eol(struct mime_encoder_state *st, int ateof, size_t n) +{ + n += st->bufbeg; + if(n >= st->bufend && ateof) + return 1; + if(n + 2 > st->bufend) + return ateof ? 0 : -1; + if(qp_class[st->buf[n] & 0xFF] == QP_CR && + qp_class[st->buf[n + 1] & 0xFF] == QP_LF) + return 1; + return 0; +} + +/* Quoted-printable encoder. */ +static size_t encoder_qp_read(char *buffer, size_t size, bool ateof, + curl_mimepart *part) +{ + struct mime_encoder_state *st = &part->encstate; + char *ptr = buffer; + size_t cursize = 0; + int softlinebreak; + char buf[4]; + + /* On all platforms, input is supposed to be ASCII compatible: for this + reason, we use hexadecimal ASCII codes in this function rather than + character constants that can be interpreted as non-ASCII on some + platforms. Preserve ASCII encoding on output too. */ + while(st->bufbeg < st->bufend) { + size_t len = 1; + size_t consumed = 1; + int i = (unsigned char)st->buf[st->bufbeg]; + buf[0] = (char)i; + buf[1] = aschex[(i >> 4) & 0xF]; + buf[2] = aschex[i & 0xF]; + + switch(qp_class[st->buf[st->bufbeg] & 0xFF]) { + case QP_OK: /* Not a special character. */ + break; + case QP_SP: /* Space or tab. */ + /* Spacing must be escaped if followed by CRLF. */ + switch(qp_lookahead_eol(st, ateof, 1)) { + case -1: /* More input data needed. */ + return cursize; + case 0: /* No encoding needed. */ + break; + default: /* CRLF after space or tab. */ + buf[0] = '\x3D'; /* '=' */ + len = 3; + break; + } + break; + case QP_CR: /* Carriage return. */ + /* If followed by a line-feed, output the CRLF pair. + Else escape it. */ + switch(qp_lookahead_eol(st, ateof, 0)) { + case -1: /* Need more data. */ + return cursize; + case 1: /* CRLF found. */ + buf[len++] = '\x0A'; /* Append '\n'. */ + consumed = 2; + break; + default: /* Not followed by LF: escape. */ + buf[0] = '\x3D'; /* '=' */ + len = 3; + break; + } + break; + default: /* Character must be escaped. */ + buf[0] = '\x3D'; /* '=' */ + len = 3; + break; + } + + /* Be sure the encoded character fits within maximum line length. */ + if(buf[len - 1] != '\x0A') { /* '\n' */ + softlinebreak = st->pos + len > MAX_ENCODED_LINE_LENGTH; + if(!softlinebreak && st->pos + len == MAX_ENCODED_LINE_LENGTH) { + /* We may use the current line only if end of data or followed by + a CRLF. */ + switch(qp_lookahead_eol(st, ateof, consumed)) { + case -1: /* Need more data. */ + return cursize; + case 0: /* Not followed by a CRLF. */ + softlinebreak = 1; + break; + } + } + if(softlinebreak) { + curlx_strcopy(buf, sizeof(buf), STRCONST("\x3D\x0D\x0A")); /* =\r\n */ + len = 3; + consumed = 0; + } + } + + /* If the output buffer would overflow, do not store. */ + if(len > size) { + if(!cursize) + return STOP_FILLING; + break; + } + + /* Append to output buffer. */ + memcpy(ptr, buf, len); + cursize += len; + ptr += len; + size -= len; + st->pos += len; + if(buf[len - 1] == '\x0A') /* '\n' */ + st->pos = 0; + st->bufbeg += consumed; + } + + return cursize; +} + +static curl_off_t encoder_qp_size(curl_mimepart *part) +{ + /* Determining the size can only be done by reading the data: unless the + data size is 0, we return it as unknown (-1). */ + return part->datasize ? -1 : 0; +} + +/* In-memory data callbacks. */ +/* Argument is a pointer to the mime part. */ +static size_t mime_mem_read(char *buffer, size_t size, size_t nitems, + void *instream) +{ + curl_mimepart *part = (curl_mimepart *)instream; + size_t sz = curlx_sotouz(part->datasize - part->state.offset); + (void)size; /* Always 1 */ + + if(!nitems) + return STOP_FILLING; + + if(sz > nitems) + sz = nitems; + + if(sz) + memcpy(buffer, part->data + curlx_sotouz(part->state.offset), sz); + + return sz; +} + +static int mime_mem_seek(void *instream, curl_off_t offset, int whence) +{ + curl_mimepart *part = (curl_mimepart *)instream; + + switch(whence) { + case SEEK_CUR: + offset += part->state.offset; + break; + case SEEK_END: + offset += part->datasize; + break; + } + + if(offset < 0 || offset > part->datasize) + return CURL_SEEKFUNC_FAIL; + + part->state.offset = offset; + return CURL_SEEKFUNC_OK; +} + +static void mime_mem_free(void *ptr) +{ + curlx_safefree(((curl_mimepart *)ptr)->data); +} + +/* Named file callbacks. */ +/* Argument is a pointer to the mime part. */ +static bool mime_open_file(curl_mimepart *part) +{ + /* Open a MIMEKIND_FILE part. */ + + if(part->fp) + return FALSE; + part->fp = fopen_read(part->data, "rb"); + return part->fp ? FALSE : TRUE; +} + +static size_t mime_file_read(char *buffer, size_t size, size_t nitems, + void *instream) +{ + curl_mimepart *part = (curl_mimepart *)instream; + + if(!nitems) + return STOP_FILLING; + + if(mime_open_file(part)) + return READ_ERROR; + + return fread(buffer, size, nitems, part->fp); +} + +static int mime_file_seek(void *instream, curl_off_t offset, int whence) +{ + curl_mimepart *part = (curl_mimepart *)instream; + + if(whence == SEEK_SET && !offset && !part->fp) + return CURL_SEEKFUNC_OK; /* Not open: implicitly already at BOF. */ + + if(mime_open_file(part)) + return CURL_SEEKFUNC_FAIL; + + return curlx_fseek(part->fp, offset, whence) ? + CURL_SEEKFUNC_CANTSEEK : CURL_SEEKFUNC_OK; +} + +static void mime_file_free(void *ptr) +{ + curl_mimepart *part = (curl_mimepart *)ptr; + + if(part->fp) { + curlx_fclose(part->fp); + part->fp = NULL; + } + curlx_safefree(part->data); +} + +/* Subparts callbacks. */ +/* Argument is a pointer to the mime structure. */ + +/* Readback a byte string segment. */ +static size_t readback_bytes(struct mime_state *state, + char *buffer, size_t bufsize, + const char *bytes, size_t numbytes, + const char *trail, size_t traillen) +{ + size_t sz; + size_t offset = curlx_sotouz(state->offset); + + if(numbytes > offset) { + sz = numbytes - offset; + bytes += offset; + } + else { + sz = offset - numbytes; + if(sz >= traillen) + return 0; + bytes = trail + sz; + sz = traillen - sz; + } + + if(sz > bufsize) + sz = bufsize; + + memcpy(buffer, bytes, sz); + state->offset += sz; + return sz; +} + +/* Read a non-encoded part content. */ + +static size_t read_part_content(curl_mimepart *part, char *buffer, + size_t bufsize, bool *hasread, + size_t call_depth) +{ + size_t sz = 0; + + if(++call_depth > MAX_MIME_LEVELS) + return READ_ERROR; + + switch(part->lastreadstatus) { + case 0: + case CURL_READFUNC_ABORT: + case CURL_READFUNC_PAUSE: + case READ_ERROR: + return part->lastreadstatus; + default: + break; + } + + /* If we can determine we are at end of part data, spare a read. */ + if(part->datasize != (curl_off_t)-1 && + part->state.offset >= part->datasize) { + /* sz is already zero. */ + } + else { + switch(part->kind) { + case MIMEKIND_MULTIPART: + /* + * Cannot be processed as other kinds since read function requires + * an additional parameter and is highly recursive. + */ + sz = mime_subparts_read(buffer, 1, bufsize, part->arg, hasread, + call_depth); + break; + case MIMEKIND_FILE: + if(part->fp && feof(part->fp)) + break; /* At EOF. */ + FALLTHROUGH(); + default: + if(part->readfunc) { + if(!(part->flags & MIME_FAST_READ)) { + if(*hasread) + return STOP_FILLING; + *hasread = TRUE; + } + sz = part->readfunc(buffer, 1, bufsize, part->arg); + } + break; + } + } + + switch(sz) { + case STOP_FILLING: + break; + case 0: + case CURL_READFUNC_ABORT: + case CURL_READFUNC_PAUSE: + case READ_ERROR: + part->lastreadstatus = sz; + break; + default: + part->state.offset += sz; + part->lastreadstatus = sz; + break; + } + + return sz; +} + +/* Read and encode part content. */ +static size_t read_encoded_part_content(curl_mimepart *part, char *buffer, + size_t bufsize, bool *hasread, + size_t call_depth) +{ + struct mime_encoder_state *st = &part->encstate; + size_t cursize = 0; + size_t sz; + bool ateof = FALSE; + + if(++call_depth > MAX_MIME_LEVELS) + return READ_ERROR; + + for(;;) { + if(st->bufbeg < st->bufend || ateof) { + /* Encode buffered data. */ + sz = part->encoder->encodefunc(buffer, bufsize, ateof, part); + switch(sz) { + case 0: + if(ateof) + return cursize; + break; + case READ_ERROR: + case STOP_FILLING: + return cursize ? cursize : sz; + default: + cursize += sz; + buffer += sz; + bufsize -= sz; + continue; + } + } + + /* We need more data in input buffer. */ + if(st->bufbeg) { + size_t len = st->bufend - st->bufbeg; + + if(len) + memmove(st->buf, st->buf + st->bufbeg, len); + st->bufbeg = 0; + st->bufend = len; + } + if(st->bufend >= sizeof(st->buf)) + return cursize ? cursize : READ_ERROR; /* Buffer full. */ + sz = read_part_content(part, st->buf + st->bufend, + sizeof(st->buf) - st->bufend, hasread, call_depth); + switch(sz) { + case 0: + ateof = TRUE; + break; + case CURL_READFUNC_ABORT: + case CURL_READFUNC_PAUSE: + case READ_ERROR: + case STOP_FILLING: + return cursize ? cursize : sz; + default: + st->bufend += sz; + break; + } + } + + /* NOTREACHED */ +} + +/* Readback a mime part. */ +static size_t readback_part(curl_mimepart *part, + char *buffer, size_t bufsize, bool *hasread, + size_t call_depth) +{ + size_t cursize = 0; + + if(++call_depth > MAX_MIME_LEVELS) + return READ_ERROR; + + /* Readback from part. */ + while(bufsize) { + size_t sz = 0; + struct curl_slist *hdr = (struct curl_slist *)part->state.ptr; + switch(part->state.state) { + case MIMESTATE_BEGIN: + mimesetstate(&part->state, + (part->flags & MIME_BODY_ONLY) ? + MIMESTATE_BODY : MIMESTATE_CURLHEADERS, + part->curlheaders); + break; + case MIMESTATE_USERHEADERS: + if(!hdr) { + mimesetstate(&part->state, MIMESTATE_EOH, NULL); + break; + } + if(match_header(hdr, "Content-Type", 12)) { + mimesetstate(&part->state, MIMESTATE_USERHEADERS, hdr->next); + break; + } + FALLTHROUGH(); + case MIMESTATE_CURLHEADERS: + if(!hdr) + mimesetstate(&part->state, MIMESTATE_USERHEADERS, part->userheaders); + else { + sz = readback_bytes(&part->state, buffer, bufsize, + hdr->data, strlen(hdr->data), STRCONST("\r\n")); + if(!sz) + mimesetstate(&part->state, part->state.state, hdr->next); + } + break; + case MIMESTATE_EOH: + sz = readback_bytes(&part->state, buffer, bufsize, STRCONST("\r\n"), + STRCONST("")); + if(!sz) + mimesetstate(&part->state, MIMESTATE_BODY, NULL); + break; + case MIMESTATE_BODY: + cleanup_encoder_state(&part->encstate); + mimesetstate(&part->state, MIMESTATE_CONTENT, NULL); + break; + case MIMESTATE_CONTENT: + if(part->encoder) + sz = read_encoded_part_content(part, buffer, bufsize, hasread, + call_depth); + else + sz = read_part_content(part, buffer, bufsize, hasread, call_depth); + switch(sz) { + case 0: + mimesetstate(&part->state, MIMESTATE_END, NULL); + /* Try sparing open file descriptors. */ + if(part->kind == MIMEKIND_FILE && part->fp) { + curlx_fclose(part->fp); + part->fp = NULL; + } + FALLTHROUGH(); + case CURL_READFUNC_ABORT: + case CURL_READFUNC_PAUSE: + case READ_ERROR: + case STOP_FILLING: + return cursize ? cursize : sz; + } + break; + case MIMESTATE_END: + return cursize; + default: + break; /* Other values not in part state. */ + } + + /* Bump buffer and counters according to read size. */ + cursize += sz; + buffer += sz; + bufsize -= sz; + } + + return cursize; +} + +/* Readback from mime. Warning: not a read callback function. */ +static size_t mime_subparts_read(char *buffer, size_t size, size_t nitems, + void *instream, bool *hasread, + size_t call_depth) +{ + curl_mime *mime = (curl_mime *)instream; + size_t cursize = 0; + (void)size; /* Always 1 */ + + if(++call_depth > MAX_MIME_LEVELS) + return READ_ERROR; + + while(nitems) { + size_t sz = 0; + curl_mimepart *part = mime->state.ptr; + switch(mime->state.state) { + case MIMESTATE_BEGIN: + case MIMESTATE_BODY: + mimesetstate(&mime->state, MIMESTATE_BOUNDARY1, mime->firstpart); + /* The first boundary always follows the header termination empty line, + so is always preceded by a CRLF. We can then spare 2 characters + by skipping the leading CRLF in boundary. */ + mime->state.offset += 2; + break; + case MIMESTATE_BOUNDARY1: + sz = readback_bytes(&mime->state, buffer, nitems, STRCONST("\r\n--"), + STRCONST("")); + if(!sz) + mimesetstate(&mime->state, MIMESTATE_BOUNDARY2, part); + break; + case MIMESTATE_BOUNDARY2: + if(part) + sz = readback_bytes(&mime->state, buffer, nitems, mime->boundary, + MIME_BOUNDARY_LEN, STRCONST("\r\n")); + else + sz = readback_bytes(&mime->state, buffer, nitems, mime->boundary, + MIME_BOUNDARY_LEN, STRCONST("--\r\n")); + if(!sz) { + mimesetstate(&mime->state, MIMESTATE_CONTENT, part); + } + break; + case MIMESTATE_CONTENT: + if(!part) { + mimesetstate(&mime->state, MIMESTATE_END, NULL); + break; + } + sz = readback_part(part, buffer, nitems, hasread, call_depth); + switch(sz) { + case CURL_READFUNC_ABORT: + case CURL_READFUNC_PAUSE: + case READ_ERROR: + case STOP_FILLING: + return cursize ? cursize : sz; + case 0: + mimesetstate(&mime->state, MIMESTATE_BOUNDARY1, part->nextpart); + break; + } + break; + case MIMESTATE_END: + return cursize; + default: + break; /* other values not used in mime state. */ + } + + /* Bump buffer and counters according to read size. */ + cursize += sz; + buffer += sz; + nitems -= sz; + } + + return cursize; +} + +static int mime_part_rewind(curl_mimepart *part) +{ + int res = CURL_SEEKFUNC_OK; + enum mimestate targetstate = MIMESTATE_BEGIN; + + if(part->flags & MIME_BODY_ONLY) + targetstate = MIMESTATE_BODY; + cleanup_encoder_state(&part->encstate); + if(part->state.state > targetstate) { + res = CURL_SEEKFUNC_CANTSEEK; + if(part->seekfunc) { + res = part->seekfunc(part->arg, (curl_off_t)0, SEEK_SET); + switch(res) { + case CURL_SEEKFUNC_OK: + case CURL_SEEKFUNC_FAIL: + case CURL_SEEKFUNC_CANTSEEK: + break; + case -1: /* For fseek() error. */ + res = CURL_SEEKFUNC_CANTSEEK; + break; + default: + res = CURL_SEEKFUNC_FAIL; + break; + } + } + } + + if(res == CURL_SEEKFUNC_OK) + mimesetstate(&part->state, targetstate, NULL); + + part->lastreadstatus = 1; /* Successful read status. */ + return res; +} + +static int mime_subparts_seek(void *instream, curl_off_t offset, int whence) +{ + curl_mime *mime = (curl_mime *)instream; + curl_mimepart *part; + int rc = CURL_SEEKFUNC_OK; + + if(whence != SEEK_SET || offset) + return CURL_SEEKFUNC_CANTSEEK; /* Only support full rewind. */ + + if(mime->state.state == MIMESTATE_BEGIN) + return CURL_SEEKFUNC_OK; /* Already rewound. */ + + for(part = mime->firstpart; part; part = part->nextpart) { + int res = mime_part_rewind(part); + if(res != CURL_SEEKFUNC_OK) + rc = res; + } + + if(rc == CURL_SEEKFUNC_OK) + mimesetstate(&mime->state, MIMESTATE_BEGIN, NULL); + + return rc; +} + +/* Release part content. */ +static void cleanup_part_content(curl_mimepart *part) +{ + if(part->freefunc) + part->freefunc(part->arg); + + part->readfunc = NULL; + part->seekfunc = NULL; + part->freefunc = NULL; + part->arg = (void *)part; /* Defaults to part itself. */ + part->data = NULL; + part->fp = NULL; + part->datasize = (curl_off_t)0; /* No size yet. */ + cleanup_encoder_state(&part->encstate); + part->kind = MIMEKIND_NONE; + part->flags &= ~(unsigned int)MIME_FAST_READ; + part->lastreadstatus = 1; /* Successful read status. */ + part->state.state = MIMESTATE_BEGIN; +} + +static void mime_subparts_free(void *ptr) +{ + curl_mime *mime = (curl_mime *)ptr; + + if(mime && mime->parent) { + mime->parent->freefunc = NULL; /* Be sure we will not be called again. */ + cleanup_part_content(mime->parent); /* Avoid dangling pointer in part. */ + } + curl_mime_free(mime); +} + +/* Do not free subparts: unbind them. This is used for the top level only. */ +static void mime_subparts_unbind(void *ptr) +{ + curl_mime *mime = (curl_mime *)ptr; + + if(mime && mime->parent) { + mime->parent->freefunc = NULL; /* Be sure we will not be called again. */ + cleanup_part_content(mime->parent); /* Avoid dangling pointer in part. */ + mime->parent = NULL; + } +} + +void Curl_mime_cleanpart(curl_mimepart *part) +{ + if(part) { + cleanup_part_content(part); + curl_slist_free_all(part->curlheaders); + if(part->flags & MIME_USERHEADERS_OWNER) + curl_slist_free_all(part->userheaders); + curlx_safefree(part->mimetype); + curlx_safefree(part->name); + curlx_safefree(part->filename); + Curl_mime_initpart(part); + } +} + +/* Recursively delete a mime handle and its parts. */ +void curl_mime_free(curl_mime *mime) +{ + curl_mimepart *part; + + if(mime) { + mime_subparts_unbind(mime); /* Be sure it is not referenced anymore. */ + while(mime->firstpart) { + part = mime->firstpart; + mime->firstpart = part->nextpart; + Curl_mime_cleanpart(part); + curlx_free(part); + } + curlx_free(mime); + } +} + +CURLcode Curl_mime_duppart(struct Curl_easy *data, + curl_mimepart *dst, const curl_mimepart *src) +{ + curl_mime *mime; + curl_mimepart *d; + const curl_mimepart *s; + CURLcode result = CURLE_OK; + + DEBUGASSERT(dst); + + /* Duplicate content. */ + switch(src->kind) { + case MIMEKIND_NONE: + break; + case MIMEKIND_DATA: + result = curl_mime_data(dst, src->data, (size_t)src->datasize); + break; + case MIMEKIND_FILE: + result = curl_mime_filedata(dst, src->data); + /* Do not abort duplication if file is not readable. */ + if(result == CURLE_READ_ERROR) + result = CURLE_OK; + break; + case MIMEKIND_CALLBACK: + result = curl_mime_data_cb(dst, src->datasize, src->readfunc, + src->seekfunc, src->freefunc, src->arg); + break; + case MIMEKIND_MULTIPART: + /* No one knows about the cloned subparts, thus always attach ownership + to the part. */ + mime = curl_mime_init(data); + result = mime ? curl_mime_subparts(dst, mime) : CURLE_OUT_OF_MEMORY; + + /* Duplicate subparts. */ + for(s = ((curl_mime *)src->arg)->firstpart; !result && s; + s = s->nextpart) { + d = curl_mime_addpart(mime); + result = d ? Curl_mime_duppart(data, d, s) : CURLE_OUT_OF_MEMORY; + } + break; + default: /* Invalid kind: should not occur. */ + DEBUGF(infof(data, "invalid MIMEKIND* attempt")); + result = CURLE_BAD_FUNCTION_ARGUMENT; /* Internal error? */ + break; + } + + /* Duplicate headers. */ + if(!result && src->userheaders) { + struct curl_slist *hdrs = Curl_slist_duplicate(src->userheaders); + + if(!hdrs) + result = CURLE_OUT_OF_MEMORY; + else { + /* No one but this procedure knows about the new header list, + so always take ownership. */ + result = curl_mime_headers(dst, hdrs, TRUE); + if(result) + curl_slist_free_all(hdrs); + } + } + + if(!result) { + /* Duplicate other fields. */ + dst->encoder = src->encoder; + result = curl_mime_type(dst, src->mimetype); + } + if(!result) + result = curl_mime_name(dst, src->name); + if(!result) + result = curl_mime_filename(dst, src->filename); + + /* If an error occurred, rollback. */ + if(result) + Curl_mime_cleanpart(dst); + + return result; +} + +/* + * Mime build functions. + */ + +/* Create a mime handle. */ +curl_mime *curl_mime_init(void *easy) +{ + curl_mime *mime = curlx_malloc(sizeof(*mime)); + + if(mime) { + mime->parent = NULL; + mime->firstpart = NULL; + mime->lastpart = NULL; + + memset(mime->boundary, '-', MIME_BOUNDARY_DASHES); + if(Curl_rand_alnum(easy, + (unsigned char *)&mime->boundary[MIME_BOUNDARY_DASHES], + MIME_RAND_BOUNDARY_CHARS + 1)) { + /* failed to get random separator, bail out */ + curlx_free(mime); + return NULL; + } + mimesetstate(&mime->state, MIMESTATE_BEGIN, NULL); + } + + return mime; +} + +/* Initialize a mime part. */ +void Curl_mime_initpart(curl_mimepart *part) +{ + memset(part, 0, sizeof(*part)); + part->lastreadstatus = 1; /* Successful read status. */ + mimesetstate(&part->state, MIMESTATE_BEGIN, NULL); +} + +/* Create a mime part and append it to a mime handle's part list. */ +curl_mimepart *curl_mime_addpart(curl_mime *mime) +{ + curl_mimepart *part; + + if(!mime) + return NULL; + + part = curlx_malloc(sizeof(*part)); + + if(part) { + Curl_mime_initpart(part); + part->parent = mime; + + if(mime->lastpart) + mime->lastpart->nextpart = part; + else + mime->firstpart = part; + + mime->lastpart = part; + } + + return part; +} + +/* Set mime part name. */ +CURLcode curl_mime_name(curl_mimepart *part, const char *name) +{ + if(!part) + return CURLE_BAD_FUNCTION_ARGUMENT; + + curlx_safefree(part->name); + + if(name) { + part->name = curlx_strdup(name); + if(!part->name) + return CURLE_OUT_OF_MEMORY; + } + + return CURLE_OK; +} + +/* Set mime part remote filename. */ +CURLcode curl_mime_filename(curl_mimepart *part, const char *filename) +{ + if(!part) + return CURLE_BAD_FUNCTION_ARGUMENT; + + curlx_safefree(part->filename); + + if(filename) { + part->filename = curlx_strdup(filename); + if(!part->filename) + return CURLE_OUT_OF_MEMORY; + } + + return CURLE_OK; +} + +/* Set mime part content from memory data. */ +CURLcode curl_mime_data(curl_mimepart *part, const char *data, size_t datasize) +{ + if(!part) + return CURLE_BAD_FUNCTION_ARGUMENT; + + cleanup_part_content(part); + + if(data) { + if(datasize == CURL_ZERO_TERMINATED) + datasize = strlen(data); + + part->data = curlx_memdup0(data, datasize); + if(!part->data) + return CURLE_OUT_OF_MEMORY; + + part->datasize = datasize; + part->readfunc = mime_mem_read; + part->seekfunc = mime_mem_seek; + part->freefunc = mime_mem_free; + part->flags |= MIME_FAST_READ; + part->kind = MIMEKIND_DATA; + } + + return CURLE_OK; +} + +/* Set mime part content from named local file. */ +CURLcode curl_mime_filedata(curl_mimepart *part, const char *filename) +{ + CURLcode result = CURLE_OK; + + if(!part) + return CURLE_BAD_FUNCTION_ARGUMENT; + + cleanup_part_content(part); + + if(filename) { + char *base; + curlx_struct_stat sbuf; + + if(curlx_stat(filename, &sbuf)) + result = CURLE_READ_ERROR; + else { + part->data = curlx_strdup(filename); + if(!part->data) + result = CURLE_OUT_OF_MEMORY; + else { + part->datasize = -1; + if(S_ISREG(sbuf.st_mode)) { + part->datasize = filesize(filename, sbuf); + part->seekfunc = mime_file_seek; + } + + part->readfunc = mime_file_read; + part->freefunc = mime_file_free; + part->kind = MIMEKIND_FILE; + + /* As a side effect, set the filename to the current file's base name. + It is possible to withdraw this by explicitly calling + curl_mime_filename() with a NULL filename argument after the current + call. */ + base = strippath(filename); + if(!base) + result = CURLE_OUT_OF_MEMORY; + else { + result = curl_mime_filename(part, base); + curlx_free(base); + } + } + } + } + return result; +} + +/* Set mime part type. */ +CURLcode curl_mime_type(curl_mimepart *part, const char *mimetype) +{ + if(!part) + return CURLE_BAD_FUNCTION_ARGUMENT; + + curlx_safefree(part->mimetype); + + if(mimetype) { + part->mimetype = curlx_strdup(mimetype); + if(!part->mimetype) + return CURLE_OUT_OF_MEMORY; + } + + return CURLE_OK; +} + +static const struct mime_encoder encoders[] = { + { "binary", encoder_nop_read, encoder_nop_size }, + { "8bit", encoder_nop_read, encoder_nop_size }, + { "7bit", encoder_7bit_read, encoder_nop_size }, + { "base64", encoder_base64_read, encoder_base64_size }, + { "quoted-printable", encoder_qp_read, encoder_qp_size }, + { ZERO_NULL, ZERO_NULL, ZERO_NULL } +}; + +/* Set mime data transfer encoder. */ +CURLcode curl_mime_encoder(curl_mimepart *part, const char *encoding) +{ + CURLcode result = CURLE_BAD_FUNCTION_ARGUMENT; + const struct mime_encoder *mep; + + if(!part) + return result; + + part->encoder = NULL; + + if(!encoding) + return CURLE_OK; /* Removing current encoder. */ + + for(mep = encoders; mep->name; mep++) + if(curl_strequal(encoding, mep->name)) { + part->encoder = mep; + result = CURLE_OK; + } + + return result; +} + +/* Set mime part headers. */ +CURLcode curl_mime_headers(curl_mimepart *part, + struct curl_slist *headers, int take_ownership) +{ + if(!part) + return CURLE_BAD_FUNCTION_ARGUMENT; + + if(part->flags & MIME_USERHEADERS_OWNER) { + if(part->userheaders != headers) /* Allow setting twice the same list. */ + curl_slist_free_all(part->userheaders); + part->flags &= ~(unsigned int)MIME_USERHEADERS_OWNER; + } + part->userheaders = headers; + if(headers && take_ownership) + part->flags |= MIME_USERHEADERS_OWNER; + return CURLE_OK; +} + +/* Set mime part content from callback. */ +CURLcode curl_mime_data_cb(curl_mimepart *part, curl_off_t datasize, + curl_read_callback readfunc, + curl_seek_callback seekfunc, + curl_free_callback freefunc, void *arg) +{ + if(!part) + return CURLE_BAD_FUNCTION_ARGUMENT; + + cleanup_part_content(part); + + if(readfunc) { + part->readfunc = readfunc; + part->seekfunc = seekfunc; + part->freefunc = freefunc; + part->arg = arg; + part->datasize = datasize; + part->kind = MIMEKIND_CALLBACK; + } + + return CURLE_OK; +} + +/* Set mime part content from subparts. */ +CURLcode Curl_mime_set_subparts(curl_mimepart *part, + curl_mime *subparts, int take_ownership) +{ + curl_mime *root; + + if(!part) + return CURLE_BAD_FUNCTION_ARGUMENT; + + /* Accept setting twice the same subparts. */ + if(part->kind == MIMEKIND_MULTIPART && part->arg == subparts) + return CURLE_OK; + + cleanup_part_content(part); + + if(subparts) { + /* Should not have been attached already. */ + if(subparts->parent) + return CURLE_BAD_FUNCTION_ARGUMENT; + + /* Should not be the part's root. */ + root = part->parent; + if(root) { + while(root->parent && root->parent->parent) + root = root->parent->parent; + if(subparts == root) { + /* cannot add as a subpart of itself. */ + return CURLE_BAD_FUNCTION_ARGUMENT; + } + } + + /* If subparts have already been used as a top-level MIMEPOST, + they might not be positioned at start. Rewind them now, as + a future check while rewinding the parent may cause this + content to be skipped. */ + if(mime_subparts_seek(subparts, (curl_off_t)0, SEEK_SET) != + CURL_SEEKFUNC_OK) + return CURLE_SEND_FAIL_REWIND; + + subparts->parent = part; + /* Subparts are processed internally: no read callback. */ + part->seekfunc = mime_subparts_seek; + part->freefunc = take_ownership ? mime_subparts_free : + mime_subparts_unbind; + part->arg = subparts; + part->datasize = -1; + part->kind = MIMEKIND_MULTIPART; + } + + return CURLE_OK; +} + +CURLcode curl_mime_subparts(curl_mimepart *part, curl_mime *subparts) +{ + return Curl_mime_set_subparts(part, subparts, TRUE); +} + +/* Readback from top mime. */ +/* Argument is the dummy top part. */ +size_t Curl_mime_read(char *buffer, size_t size, size_t nitems, void *instream) +{ + curl_mimepart *part = (curl_mimepart *)instream; + size_t ret; + bool hasread; + + (void)size; /* Always 1 */ + + /* If `nitems` is <= 4, some encoders will return STOP_FILLING without + * adding any data and this loops infinitely. */ + do { + hasread = FALSE; + ret = readback_part(part, buffer, nitems, &hasread, 0); + /* + * If this is not possible to get some data without calling more than + * one read callback (probably because a content encoder is not able to + * deliver a new bunch for the few data accumulated so far), force another + * read until we get enough data or a special exit code. + */ + } while(ret == STOP_FILLING); + + return ret; +} + +/* Rewind mime stream. */ +static CURLcode mime_rewind(curl_mimepart *part) +{ + return mime_part_rewind(part) == CURL_SEEKFUNC_OK ? + CURLE_OK : CURLE_SEND_FAIL_REWIND; +} + +/* Compute header list size. */ +static size_t slist_size(struct curl_slist *s, + size_t overhead, const char *skip, size_t skiplen) +{ + size_t size = 0; + + for(; s; s = s->next) + if(!skip || !match_header(s, skip, skiplen)) + size += strlen(s->data) + overhead; + return size; +} + +/* Get/compute multipart size. */ +static curl_off_t multipart_size(curl_mime *mime) +{ + curl_off_t size; + curl_off_t boundarysize; + curl_mimepart *part; + + if(!mime) + return 0; /* Not present -> empty. */ + + boundarysize = 4 + MIME_BOUNDARY_LEN + 2; + size = boundarysize; /* Final boundary - CRLF after headers. */ + + for(part = mime->firstpart; part; part = part->nextpart) { + curl_off_t sz = mime_size(part); + + if(sz < 0) + size = sz; + + if(size >= 0) + size += boundarysize + sz; + } + + return size; +} + +/* Get/compute mime size. */ +static curl_off_t mime_size(curl_mimepart *part) +{ + curl_off_t size; + + if(part->kind == MIMEKIND_MULTIPART) + part->datasize = multipart_size(part->arg); + + size = part->datasize; + + if(part->encoder) + size = part->encoder->sizefunc(part); + + if(size >= 0 && !(part->flags & MIME_BODY_ONLY)) { + /* Compute total part size. */ + size += slist_size(part->curlheaders, 2, NULL, 0); + size += slist_size(part->userheaders, 2, STRCONST("Content-Type")); + size += 2; /* CRLF after headers. */ + } + return size; +} + +/* Add a header. */ +/* VARARGS2 */ +CURLcode Curl_mime_add_header(struct curl_slist **slp, const char *fmt, ...) +{ + struct curl_slist *hdr = NULL; + char *s = NULL; + va_list ap; + + va_start(ap, fmt); + s = curl_mvaprintf(fmt, ap); + va_end(ap); + + if(s) { + hdr = Curl_slist_append_nodup(*slp, s); + if(hdr) + *slp = hdr; + else + curlx_free(s); + } + + return hdr ? CURLE_OK : CURLE_OUT_OF_MEMORY; +} + +/* Add a content type header. */ +static CURLcode add_content_type(struct curl_slist **slp, + const char *type, const char *boundary) +{ + return Curl_mime_add_header(slp, "Content-Type: %s%s%s", type, + boundary ? "; boundary=" : "", + boundary ? boundary : ""); +} + +const char *Curl_mime_contenttype(const char *filename) +{ + /* + * If no content type was specified, we scan through a few well-known + * extensions and pick the first we match! + */ + struct ContentType { + const char *extension; + const char *type; + }; + static const struct ContentType ctts[] = { + { ".gif", "image/gif" }, + { ".jpg", "image/jpeg" }, + { ".jpeg", "image/jpeg" }, + { ".png", "image/png" }, + { ".svg", "image/svg+xml" }, + { ".txt", "text/plain" }, + { ".htm", "text/html" }, + { ".html", "text/html" }, + { ".pdf", "application/pdf" }, + { ".xml", "application/xml" } + }; + + if(filename) { + size_t len1 = strlen(filename); + const char *nameend = filename + len1; + unsigned int i; + + for(i = 0; i < CURL_ARRAYSIZE(ctts); i++) { + size_t len2 = strlen(ctts[i].extension); + + if(len1 >= len2 && curl_strequal(nameend - len2, ctts[i].extension)) + return ctts[i].type; + } + } + return NULL; +} + +static bool content_type_match(const char *contenttype, + const char *target, size_t len) +{ + if(contenttype && curl_strnequal(contenttype, target, len)) + switch(contenttype[len]) { + case '\0': + case '\t': + case '\r': + case '\n': + case ' ': + case ';': + return TRUE; + } + return FALSE; +} + +static CURLcode add_content_disposition(struct Curl_easy *data, + curl_mimepart *part, + const char *disposition, + const char *contenttype, + enum mimestrategy strategy) +{ + if(!disposition) + if(part->filename || part->name || + (contenttype && !curl_strnequal(contenttype, "multipart/", 10))) + disposition = DISPOSITION_DEFAULT; + if(disposition && curl_strequal(disposition, "attachment") && + !part->name && !part->filename) + disposition = NULL; + if(disposition) { + CURLcode result = CURLE_OK; + char *name = NULL; + char *filename = NULL; + + if(part->name) { + name = escape_string(data, part->name, strategy); + if(!name) + return CURLE_OUT_OF_MEMORY; + } + if(part->filename) { + filename = escape_string(data, part->filename, strategy); + if(!filename) + result = CURLE_OUT_OF_MEMORY; + } + if(!result) + result = Curl_mime_add_header(&part->curlheaders, + "Content-Disposition: %s%s%s%s%s%s%s", + disposition, + name ? "; name=\"" : "", + name ? name : "", + name ? "\"" : "", + filename ? "; filename=\"" : "", + filename ? filename : "", + filename ? "\"" : ""); + curlx_safefree(name); + curlx_safefree(filename); + if(result) + return result; + } + return CURLE_OK; +} + +CURLcode Curl_mime_prepare_headers(struct Curl_easy *data, + curl_mimepart *part, + const char *contenttype, + const char *disposition, + enum mimestrategy strategy) +{ + curl_mime *mime = NULL; + const char *boundary = NULL; + char *customct; + const char *cte = NULL; + CURLcode result = CURLE_OK; + + /* Get rid of previously prepared headers. */ + curl_slist_free_all(part->curlheaders); + part->curlheaders = NULL; + + /* Be sure we will not access old headers later. */ + if(part->state.state == MIMESTATE_CURLHEADERS) + mimesetstate(&part->state, MIMESTATE_CURLHEADERS, NULL); + + /* Check if content type is specified. */ + customct = part->mimetype; + if(!customct) + customct = search_header(part->userheaders, STRCONST("Content-Type")); + if(customct) + contenttype = customct; + + /* If content type is not specified, try to determine it. */ + if(!contenttype) { + switch(part->kind) { + case MIMEKIND_MULTIPART: + contenttype = MULTIPART_CONTENTTYPE_DEFAULT; + break; + case MIMEKIND_FILE: + contenttype = Curl_mime_contenttype(part->filename); + if(!contenttype) + contenttype = Curl_mime_contenttype(part->data); + if(!contenttype && part->filename) + contenttype = FILE_CONTENTTYPE_DEFAULT; + break; + default: + contenttype = Curl_mime_contenttype(part->filename); + break; + } + } + + if(part->kind == MIMEKIND_MULTIPART) { + mime = (curl_mime *)part->arg; + if(mime) + boundary = mime->boundary; + } + else if(contenttype && !customct && + content_type_match(contenttype, STRCONST("text/plain"))) + if(strategy == MIMESTRATEGY_MAIL || !part->filename) + contenttype = NULL; + + /* Issue content-disposition header only if not already set by caller. */ + if(!search_header(part->userheaders, STRCONST("Content-Disposition"))) { + result = add_content_disposition(data, part, disposition, + contenttype, strategy); + if(result) + return result; + } + + /* Issue Content-Type header. */ + if(contenttype) { + result = add_content_type(&part->curlheaders, contenttype, boundary); + if(result) + return result; + } + + /* Content-Transfer-Encoding header. */ + if(!search_header(part->userheaders, + STRCONST("Content-Transfer-Encoding"))) { + if(part->encoder) + cte = part->encoder->name; + else if(contenttype && strategy == MIMESTRATEGY_MAIL && + part->kind != MIMEKIND_MULTIPART) + cte = "8bit"; + if(cte) { + result = Curl_mime_add_header(&part->curlheaders, + "Content-Transfer-Encoding: %s", cte); + if(result) + return result; + } + } + + /* If we were reading curl-generated headers, restart with new ones (this + should not occur). */ + if(part->state.state == MIMESTATE_CURLHEADERS) + mimesetstate(&part->state, MIMESTATE_CURLHEADERS, part->curlheaders); + + /* Process subparts. */ + if(part->kind == MIMEKIND_MULTIPART && mime) { + curl_mimepart *subpart; + + disposition = NULL; + if(content_type_match(contenttype, STRCONST("multipart/form-data"))) + disposition = "form-data"; + for(subpart = mime->firstpart; subpart; subpart = subpart->nextpart) { + result = Curl_mime_prepare_headers(data, subpart, NULL, + disposition, strategy); + if(result) + return result; + } + } + return result; +} + +/* Recursively reset paused status in the given part. */ +static void mime_unpause(curl_mimepart *part) +{ + if(part) { + if(part->lastreadstatus == CURL_READFUNC_PAUSE) + part->lastreadstatus = 1; /* Successful read status. */ + if(part->kind == MIMEKIND_MULTIPART) { + curl_mime *mime = (curl_mime *)part->arg; + + if(mime) { + curl_mimepart *subpart; + + for(subpart = mime->firstpart; subpart; subpart = subpart->nextpart) + mime_unpause(subpart); + } + } + } +} + +struct cr_mime_ctx { + struct Curl_creader super; + curl_mimepart *part; + curl_off_t total_len; + curl_off_t read_len; + CURLcode error_result; + struct bufq tmpbuf; + BIT(seen_eos); + BIT(errored); +}; + +static CURLcode cr_mime_init(struct Curl_easy *data, + struct Curl_creader *reader) +{ + struct cr_mime_ctx *ctx = reader->ctx; + (void)data; + ctx->total_len = -1; + ctx->read_len = 0; + Curl_bufq_init2(&ctx->tmpbuf, 1024, 1, BUFQ_OPT_NO_SPARES); + return CURLE_OK; +} + +static void cr_mime_close(struct Curl_easy *data, + struct Curl_creader *reader) +{ + struct cr_mime_ctx *ctx = reader->ctx; + (void)data; + Curl_bufq_free(&ctx->tmpbuf); +} + +/* Real client reader to installed client callbacks. */ +static CURLcode cr_mime_read(struct Curl_easy *data, + struct Curl_creader *reader, + char *buf, size_t blen, + size_t *pnread, bool *peos) +{ + struct cr_mime_ctx *ctx = reader->ctx; + CURLcode result = CURLE_OK; + size_t nread; + char tmp[256]; + + /* Once we have errored, we will return the same error forever */ + if(ctx->errored) { + CURL_TRC_READ(data, "cr_mime_read(len=%zu) is errored -> %d, eos=0", + blen, (int)ctx->error_result); + *pnread = 0; + *peos = FALSE; + return ctx->error_result; + } + if(ctx->seen_eos) { + CURL_TRC_READ(data, "cr_mime_read(len=%zu) seen eos -> 0, eos=1", blen); + *pnread = 0; + *peos = TRUE; + return CURLE_OK; + } + /* respect length limitations */ + if(ctx->total_len >= 0) { + curl_off_t remain = ctx->total_len - ctx->read_len; + if(remain <= 0) + blen = 0; + else if(remain < (curl_off_t)blen) + blen = (size_t)remain; + } + + if(!Curl_bufq_is_empty(&ctx->tmpbuf)) { + result = Curl_bufq_read(&ctx->tmpbuf, (unsigned char *)buf, blen, &nread); + if(result) { + ctx->errored = TRUE; + ctx->error_result = result; + return result; + } + } + else if(blen <= 4) { + /* Curl_mime_read() may go into an infinite loop when reading + * via a base64 encoder, as it stalls when the read buffer is too small + * to contain a complete 3-byte encoding. Read into a larger buffer + * and use that until empty. */ + CURL_TRC_READ(data, "cr_mime_read(len=%zu), small read, using tmp", blen); + nread = Curl_mime_read(tmp, 1, sizeof(tmp), ctx->part); + if(nread <= sizeof(tmp)) { + size_t n; + result = Curl_bufq_write(&ctx->tmpbuf, (unsigned char *)tmp, nread, &n); + if(result) { + ctx->errored = TRUE; + ctx->error_result = result; + return result; + } + /* stored it, read again */ + result = Curl_bufq_cread(&ctx->tmpbuf, buf, blen, &nread); + if(result) { + ctx->errored = TRUE; + ctx->error_result = result; + return result; + } + } + } + else + nread = Curl_mime_read(buf, 1, blen, ctx->part); + + CURL_TRC_READ(data, "cr_mime_read(len=%zu), mime_read() -> %zu", + blen, nread); + + switch(nread) { + case 0: + if((ctx->total_len >= 0) && (ctx->read_len < ctx->total_len)) { + failf(data, "client mime read EOF fail, " + "only %" FMT_OFF_T "/%" FMT_OFF_T + " of needed bytes read", ctx->read_len, ctx->total_len); + return CURLE_READ_ERROR; + } + *pnread = 0; + *peos = TRUE; + ctx->seen_eos = TRUE; + break; + + case CURL_READFUNC_ABORT: + failf(data, "operation aborted by callback"); + *pnread = 0; + *peos = FALSE; + ctx->errored = TRUE; + ctx->error_result = CURLE_ABORTED_BY_CALLBACK; + result = CURLE_ABORTED_BY_CALLBACK; + break; + + case CURL_READFUNC_PAUSE: + /* CURL_READFUNC_PAUSE pauses read callbacks that feed socket writes */ + CURL_TRC_READ(data, "cr_mime_read(len=%zu), paused by callback", blen); + *pnread = 0; + *peos = FALSE; + result = Curl_xfer_pause_send(data, TRUE); + break; /* nothing was read */ + + case STOP_FILLING: + case READ_ERROR: + failf(data, "read error getting mime data"); + *pnread = 0; + *peos = FALSE; + ctx->errored = TRUE; + ctx->error_result = CURLE_READ_ERROR; + result = CURLE_READ_ERROR; + break; + + default: + if(nread > blen) { + /* the read function returned a too large value */ + failf(data, "read function returned funny value"); + *pnread = 0; + *peos = FALSE; + ctx->errored = TRUE; + ctx->error_result = CURLE_READ_ERROR; + return CURLE_READ_ERROR; + } + ctx->read_len += nread; + if(ctx->total_len >= 0) + ctx->seen_eos = (ctx->read_len >= ctx->total_len); + *pnread = nread; + *peos = (bool)ctx->seen_eos; + break; + } + + CURL_TRC_READ(data, "cr_mime_read(len=%zu, total=%" FMT_OFF_T + ", read=%" FMT_OFF_T ") -> %d, %zu, %d", blen, + ctx->total_len, ctx->read_len, (int)result, *pnread, *peos); + return result; +} + +static bool cr_mime_needs_rewind(struct Curl_easy *data, + struct Curl_creader *reader) +{ + struct cr_mime_ctx *ctx = reader->ctx; + (void)data; + return ctx->read_len > 0; +} + +static curl_off_t cr_mime_total_length(struct Curl_easy *data, + struct Curl_creader *reader) +{ + struct cr_mime_ctx *ctx = reader->ctx; + (void)data; + return ctx->total_len; +} + +static CURLcode cr_mime_resume_from(struct Curl_easy *data, + struct Curl_creader *reader, + curl_off_t offset) +{ + struct cr_mime_ctx *ctx = reader->ctx; + + if(offset > 0) { + curl_off_t passed = 0; + + do { + char scratch[4 * 1024]; + size_t readthisamountnow = + (offset - passed > (curl_off_t)sizeof(scratch)) ? + sizeof(scratch) : + curlx_sotouz(offset - passed); + size_t nread; + + nread = Curl_mime_read(scratch, 1, readthisamountnow, ctx->part); + passed += (curl_off_t)nread; + if((nread == 0) || (nread > readthisamountnow)) { + /* this checks for greater-than only to make sure that the + CURL_READFUNC_ABORT return code still aborts */ + failf(data, "Could only read %" FMT_OFF_T + " bytes from the mime post", passed); + return CURLE_READ_ERROR; + } + } while(passed < offset); + + /* now, decrease the size of the read */ + if(ctx->total_len > 0) { + ctx->total_len -= offset; + + if(ctx->total_len <= 0) { + failf(data, "Mime post already completely uploaded"); + return CURLE_PARTIAL_FILE; + } + } + /* we have passed, proceed as normal */ + } + return CURLE_OK; +} + +static CURLcode cr_mime_cntrl(struct Curl_easy *data, + struct Curl_creader *reader, + Curl_creader_cntrl opcode) +{ + struct cr_mime_ctx *ctx = reader->ctx; + switch(opcode) { + case CURL_CRCNTRL_REWIND: { + CURLcode result = mime_rewind(ctx->part); + if(result) + failf(data, "Cannot rewind mime/post data"); + return result; + } + case CURL_CRCNTRL_UNPAUSE: + mime_unpause(ctx->part); + break; + case CURL_CRCNTRL_CLEAR_EOS: + ctx->seen_eos = FALSE; + break; + default: + break; + } + return CURLE_OK; +} + +static bool cr_mime_is_paused(struct Curl_easy *data, + struct Curl_creader *reader) +{ + struct cr_mime_ctx *ctx = reader->ctx; + (void)data; + return ctx->part && ctx->part->lastreadstatus == CURL_READFUNC_PAUSE; +} + +static const struct Curl_crtype cr_mime = { + "cr-mime", + cr_mime_init, + cr_mime_read, + cr_mime_close, + cr_mime_needs_rewind, + cr_mime_total_length, + cr_mime_resume_from, + cr_mime_cntrl, + cr_mime_is_paused, + Curl_creader_def_done, + sizeof(struct cr_mime_ctx) +}; + +CURLcode Curl_creader_set_mime(struct Curl_easy *data, curl_mimepart *part) +{ + struct Curl_creader *r; + struct cr_mime_ctx *ctx; + CURLcode result; + + result = Curl_creader_create(&r, data, &cr_mime, CURL_CR_CLIENT); + if(result) + return result; + ctx = r->ctx; + ctx->part = part; + /* Make sure we will read the entire mime structure. */ + result = mime_rewind(ctx->part); + if(result) { + Curl_creader_free(data, r); + return result; + } + ctx->total_len = mime_size(ctx->part); + + return Curl_creader_set(data, r); +} + +#else /* !CURL_DISABLE_MIME && (!CURL_DISABLE_HTTP || + !CURL_DISABLE_SMTP || + !CURL_DISABLE_IMAP) */ + +/* Mime not compiled in: define stubs for externally-referenced functions. */ +curl_mime *curl_mime_init(CURL *easy) +{ + (void)easy; + return NULL; +} + +void curl_mime_free(curl_mime *mime) +{ + (void)mime; +} + +curl_mimepart *curl_mime_addpart(curl_mime *mime) +{ + (void)mime; + return NULL; +} + +CURLcode curl_mime_name(curl_mimepart *part, const char *name) +{ + (void)part; + (void)name; + return CURLE_NOT_BUILT_IN; +} + +CURLcode curl_mime_filename(curl_mimepart *part, const char *filename) +{ + (void)part; + (void)filename; + return CURLE_NOT_BUILT_IN; +} + +CURLcode curl_mime_type(curl_mimepart *part, const char *mimetype) +{ + (void)part; + (void)mimetype; + return CURLE_NOT_BUILT_IN; +} + +CURLcode curl_mime_encoder(curl_mimepart *part, const char *encoding) +{ + (void)part; + (void)encoding; + return CURLE_NOT_BUILT_IN; +} + +CURLcode curl_mime_data(curl_mimepart *part, const char *data, size_t datasize) +{ + (void)part; + (void)data; + (void)datasize; + return CURLE_NOT_BUILT_IN; +} + +CURLcode curl_mime_filedata(curl_mimepart *part, const char *filename) +{ + (void)part; + (void)filename; + return CURLE_NOT_BUILT_IN; +} + +CURLcode curl_mime_data_cb(curl_mimepart *part, curl_off_t datasize, + curl_read_callback readfunc, + curl_seek_callback seekfunc, + curl_free_callback freefunc, + void *arg) +{ + (void)part; + (void)datasize; + (void)readfunc; + (void)seekfunc; + (void)freefunc; + (void)arg; + return CURLE_NOT_BUILT_IN; +} + +CURLcode curl_mime_subparts(curl_mimepart *part, curl_mime *subparts) +{ + (void)part; + (void)subparts; + return CURLE_NOT_BUILT_IN; +} + +CURLcode curl_mime_headers(curl_mimepart *part, + struct curl_slist *headers, int take_ownership) +{ + (void)part; + (void)headers; + (void)take_ownership; + return CURLE_NOT_BUILT_IN; +} + +CURLcode Curl_mime_add_header(struct curl_slist **slp, const char *fmt, ...) +{ + (void)slp; + (void)fmt; + return CURLE_NOT_BUILT_IN; +} + +#endif /* if disabled */ diff --git a/3rdparty/curl-8.21.0/lib/mime.h b/3rdparty/curl-8.21.0/lib/mime.h new file mode 100644 index 0000000000..e84f04051b --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/mime.h @@ -0,0 +1,173 @@ +#ifndef HEADER_CURL_MIME_H +#define HEADER_CURL_MIME_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#define MIME_BOUNDARY_DASHES 24 /* leading boundary dashes */ +#define MIME_RAND_BOUNDARY_CHARS 22 /* Nb. of random boundary chars. */ +#define MAX_ENCODED_LINE_LENGTH 76 /* Maximum encoded line length. */ +#define ENCODING_BUFFER_SIZE 256 /* Encoding temp buffers size. */ + +/* Part flags. */ +#define MIME_USERHEADERS_OWNER (1 << 0) +#define MIME_BODY_ONLY (1 << 1) +#define MIME_FAST_READ (1 << 2) + +#define FILE_CONTENTTYPE_DEFAULT "application/octet-stream" +#define MULTIPART_CONTENTTYPE_DEFAULT "multipart/mixed" +#define DISPOSITION_DEFAULT "attachment" + +/* Part source kinds. */ +enum mimekind { + MIMEKIND_NONE = 0, /* Part not set. */ + MIMEKIND_DATA, /* Allocated mime data. */ + MIMEKIND_FILE, /* Data from file. */ + MIMEKIND_CALLBACK, /* Data from `read' callback. */ + MIMEKIND_MULTIPART, /* Data is a mime subpart. */ + MIMEKIND_LAST +}; + +/* Readback state tokens. */ +enum mimestate { + MIMESTATE_BEGIN, /* Readback has not yet started. */ + MIMESTATE_CURLHEADERS, /* In curl-generated headers. */ + MIMESTATE_USERHEADERS, /* In caller's supplied headers. */ + MIMESTATE_EOH, /* End of headers. */ + MIMESTATE_BODY, /* Placeholder. */ + MIMESTATE_BOUNDARY1, /* In boundary prefix. */ + MIMESTATE_BOUNDARY2, /* In boundary. */ + MIMESTATE_CONTENT, /* In content. */ + MIMESTATE_END, /* End of part reached. */ + MIMESTATE_LAST +}; + +/* Mime headers strategies. */ +enum mimestrategy { + MIMESTRATEGY_MAIL, /* Mime mail. */ + MIMESTRATEGY_FORM, /* HTTP post form. */ + MIMESTRATEGY_LAST +}; + +/* Content transfer encoder. */ +struct mime_encoder { + const char * name; /* Encoding name. */ + size_t (*encodefunc)(char *buffer, size_t size, bool ateof, + curl_mimepart *part); /* Encoded read. */ + curl_off_t (*sizefunc)(curl_mimepart *part); /* Encoded size. */ +}; + +/* Content transfer encoder state. */ +struct mime_encoder_state { + size_t pos; /* Position on output line. */ + size_t bufbeg; /* Next data index in input buffer. */ + size_t bufend; /* First unused byte index in input buffer. */ + char buf[ENCODING_BUFFER_SIZE]; /* Input buffer. */ +}; + +/* Mime readback state. */ +struct mime_state { + enum mimestate state; /* Current state token. */ + void *ptr; /* State-dependent pointer. */ + curl_off_t offset; /* State-dependent offset. */ +}; + +/* Boundary string length. */ +#define MIME_BOUNDARY_LEN (MIME_BOUNDARY_DASHES + MIME_RAND_BOUNDARY_CHARS) + +/* A mime multipart. */ +struct curl_mime { + curl_mimepart *parent; /* Parent part. */ + curl_mimepart *firstpart; /* First part. */ + curl_mimepart *lastpart; /* Last part. */ + char boundary[MIME_BOUNDARY_LEN + 1]; /* The part boundary. */ + struct mime_state state; /* Current readback state. */ +}; + +/* A mime part. */ +struct curl_mimepart { + curl_mime *parent; /* Parent mime structure. */ + curl_mimepart *nextpart; /* Forward linked list. */ + enum mimekind kind; /* The part kind. */ + unsigned int flags; /* Flags. */ + char *data; /* Memory data or filename. */ + curl_read_callback readfunc; /* Read function. */ + curl_seek_callback seekfunc; /* Seek function. */ + curl_free_callback freefunc; /* Argument free function. */ + void *arg; /* Argument to callback functions. */ + FILE *fp; /* File pointer. */ + struct curl_slist *curlheaders; /* Part headers. */ + struct curl_slist *userheaders; /* Part headers. */ + char *mimetype; /* Part mime type. */ + char *filename; /* Remote filename. */ + char *name; /* Data name. */ + curl_off_t datasize; /* Expected data size. */ + struct mime_state state; /* Current readback state. */ + const struct mime_encoder *encoder; /* Content data encoder. */ + struct mime_encoder_state encstate; /* Data encoder state. */ + size_t lastreadstatus; /* Last read callback returned status. */ +}; + +CURLcode Curl_mime_add_header(struct curl_slist **slp, const char *fmt, ...) + CURL_PRINTF(2, 3); + +#if !defined(CURL_DISABLE_MIME) && (!defined(CURL_DISABLE_HTTP) || \ + !defined(CURL_DISABLE_SMTP) || \ + !defined(CURL_DISABLE_IMAP)) + +/* Prototypes. */ +void Curl_mime_initpart(struct curl_mimepart *part); +void Curl_mime_cleanpart(struct curl_mimepart *part); +CURLcode Curl_mime_duppart(struct Curl_easy *data, + struct curl_mimepart *dst, + const curl_mimepart *src); +CURLcode Curl_mime_set_subparts(struct curl_mimepart *part, + struct curl_mime *subparts, + int take_ownership); +CURLcode Curl_mime_prepare_headers(struct Curl_easy *data, + struct curl_mimepart *part, + const char *contenttype, + const char *disposition, + enum mimestrategy strategy); +size_t Curl_mime_read(char *buffer, size_t size, size_t nitems, + void *instream); +const char *Curl_mime_contenttype(const char *filename); + +/** + * Install a client reader as upload source that reads the given + * mime part. + */ +CURLcode Curl_creader_set_mime(struct Curl_easy *data, curl_mimepart *part); + +#else /* if disabled */ +#define Curl_mime_initpart(x) +#define Curl_mime_cleanpart(x) +#define Curl_mime_duppart(x, y, z) CURLE_OK /* Nothing to duplicate. Succeed */ +#define Curl_mime_set_subparts(a, b, c) CURLE_NOT_BUILT_IN +#define Curl_mime_prepare_headers(a, b, c, d, e) CURLE_NOT_BUILT_IN +#define Curl_mime_read NULL +#define Curl_creader_set_mime(x, y) ((void)(x), CURLE_NOT_BUILT_IN) +#endif + +#endif /* HEADER_CURL_MIME_H */ diff --git a/3rdparty/curl-8.21.0/lib/mprintf.c b/3rdparty/curl-8.21.0/lib/mprintf.c new file mode 100644 index 0000000000..230b554191 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/mprintf.c @@ -0,0 +1,1256 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "curlx/dynbuf.h" +#include "curl_printf.h" +#include "curlx/strparse.h" +#include "curlx/snprintf.h" /* for curlx_win32_snprintf() */ + +#define BUFFSIZE 326 /* buffer for long-to-str and float-to-str calcs, should + fit negative DBL_MAX (317 letters) */ +#define MAX_PARAMETERS 128 /* number of input arguments */ +#define MAX_SEGMENTS 128 /* number of output segments */ + +/* Lower-case digits. */ +const unsigned char Curl_ldigits[] = "0123456789abcdef"; + +/* Upper-case digits. */ +const unsigned char Curl_udigits[] = "0123456789ABCDEF"; + +#define OUTCHAR(x) \ + do { \ + if(stream((unsigned char)(x), userp)) \ + return TRUE; \ + (*donep)++; \ + } while(0) + +/* Data type to read from the arglist */ +typedef enum { + MTYPE_STRING, + MTYPE_PTR, + MTYPE_INTPTR, + MTYPE_INT, + MTYPE_LONG, + MTYPE_LONGLONG, + MTYPE_INTU, + MTYPE_LONGU, + MTYPE_LONGLONGU, + MTYPE_DOUBLE, + MTYPE_LONGDOUBLE, + MTYPE_WIDTH, + MTYPE_PRECISION +} FormatType; + +/* conversion and display flags */ +enum { + FLAGS_SPACE = 1 << 0, + FLAGS_SHOWSIGN = 1 << 1, + FLAGS_LEFT = 1 << 2, + FLAGS_ALT = 1 << 3, + FLAGS_SHORT = 1 << 4, + FLAGS_LONG = 1 << 5, + FLAGS_LONGLONG = 1 << 6, + FLAGS_LONGDOUBLE = 1 << 7, + FLAGS_PAD_NIL = 1 << 8, + FLAGS_UNSIGNED = 1 << 9, + FLAGS_OCTAL = 1 << 10, + FLAGS_HEX = 1 << 11, + FLAGS_UPPER = 1 << 12, + FLAGS_WIDTH = 1 << 13, /* '*' or '*$' used */ + FLAGS_WIDTHPARAM = 1 << 14, /* width PARAMETER was specified */ + FLAGS_PREC = 1 << 15, /* precision was specified */ + FLAGS_PRECPARAM = 1 << 16, /* precision PARAMETER was specified */ + FLAGS_CHAR = 1 << 17, /* %c story */ + FLAGS_FLOATE = 1 << 18, /* %e or %E */ + FLAGS_FLOATG = 1 << 19, /* %g or %G */ + FLAGS_SUBSTR = 1 << 20 /* no input, only substring */ +}; + +enum { + DOLLAR_UNKNOWN, + DOLLAR_NOPE, + DOLLAR_USE +}; + +/* + * Describes an input va_arg type and hold its value. + */ +struct va_input { + FormatType type; /* FormatType */ + union { + const char *str; + void *ptr; + int64_t nums; /* signed */ + uint64_t numu; /* unsigned */ + double dnum; + } val; +}; + +/* + * Describes an output segment. + */ +struct outsegment { + int width; /* width OR width parameter number */ + int precision; /* precision OR precision parameter number */ + unsigned int flags; + unsigned int input; /* input argument array index */ + const char *start; /* format string start to output */ + size_t outlen; /* number of bytes from the format string to output */ +}; + +struct nsprintf { + char *buffer; + size_t length; + size_t max; +}; + +struct asprintf { + struct dynbuf *b; + char merr; +}; + +/* the provided input number is 1-based but this returns the number 0-based. + * + * returns -1 if no valid number was provided. + */ +static int dollarstring(const char *p, const char **end) +{ + curl_off_t num; + if(curlx_str_number(&p, &num, MAX_PARAMETERS) || + curlx_str_single(&p, '$') || !num) + return -1; + *end = p; + return (int)num - 1; +} + +#define is_arg_used(x, y) ((x)[(y) / 8] & (1 << ((y) & 7))) +#define mark_arg_used(x, y) ((x)[(y) / 8] |= (unsigned char)(1 << ((y) & 7))) + +/* + * Parse the format string. + * + * Create two arrays. One describes the inputs, one describes the outputs. + * + * Returns zero on success. + */ + +#define PFMT_OK 0 +#define PFMT_DOLLAR 1 /* bad dollar for main param */ +#define PFMT_DOLLARWIDTH 2 /* bad dollar use for width */ +#define PFMT_DOLLARPREC 3 /* bad dollar use for precision */ +#define PFMT_MANYARGS 4 /* too many input arguments used */ +#define PFMT_PREC 5 /* precision overflow */ +#define PFMT_PRECMIX 6 /* bad mix of precision specifiers */ +#define PFMT_WIDTH 7 /* width overflow */ +#define PFMT_INPUTGAP 8 /* gap in arguments */ +#define PFMT_WIDTHARG 9 /* attempted to use same arg twice, for width */ +#define PFMT_PRECARG 10 /* attempted to use same arg twice, for prec */ +#define PFMT_MANYSEGS 11 /* maxed out output segments */ + +static int parse_flags(const char **fmtp, unsigned int *flagsp, int use_dollar, + int *precp, int *widthp) +{ + const char *fmt = *fmtp; + bool loopit = TRUE; + unsigned int flags = 0; + int width = 0; + int precision = 0; + + /* Handle the flags */ + do { + switch(*fmt++) { + case ' ': + flags |= FLAGS_SPACE; + break; + case '+': + flags |= FLAGS_SHOWSIGN; + break; + case '-': + flags |= FLAGS_LEFT; + flags &= ~(unsigned int)FLAGS_PAD_NIL; + break; + case '#': + flags |= FLAGS_ALT; + break; + case '.': + if('*' == *fmt) { + /* The precision is picked from a specified parameter */ + flags |= FLAGS_PRECPARAM; + fmt++; + + if(use_dollar == DOLLAR_USE) { + precision = dollarstring(fmt, &fmt); + if(precision < 0) + /* illegal combo */ + return PFMT_DOLLARPREC; + } + else + /* get it from the next argument */ + precision = -1; + } + else { + bool is_neg; + curl_off_t num; + flags |= FLAGS_PREC; + is_neg = ('-' == *fmt); + if(is_neg) + fmt++; + if(curlx_str_number(&fmt, &num, INT_MAX)) + return PFMT_PREC; + precision = (int)num; + if(is_neg) + precision = -precision; + } + if((flags & (FLAGS_PREC | FLAGS_PRECPARAM)) == + (FLAGS_PREC | FLAGS_PRECPARAM)) + /* it is not permitted to use both kinds of precision for the same + argument */ + return PFMT_PRECMIX; + break; + case 'h': + flags |= FLAGS_SHORT; + break; +#ifdef _WIN32 + case 'I': + /* Non-ANSI integer extensions I32 I64 */ + if((fmt[0] == '3') && (fmt[1] == '2')) { + flags |= FLAGS_LONG; + fmt += 2; + } + else if((fmt[0] == '6') && (fmt[1] == '4')) { + flags |= FLAGS_LONGLONG; + fmt += 2; + } + else { +#if SIZEOF_CURL_OFF_T > SIZEOF_LONG + flags |= FLAGS_LONGLONG; +#else + flags |= FLAGS_LONG; +#endif + } + break; +#endif /* _WIN32 */ + case 'l': + if(flags & FLAGS_LONG) + flags |= FLAGS_LONGLONG; + else + flags |= FLAGS_LONG; + break; + case 'L': + flags |= FLAGS_LONGDOUBLE; + break; + case 'q': + flags |= FLAGS_LONGLONG; + break; + case 'z': + /* the code below generates a warning if -Wunreachable-code is + used */ +#if SIZEOF_SIZE_T > SIZEOF_LONG + flags |= FLAGS_LONGLONG; +#else + flags |= FLAGS_LONG; +#endif + break; + case 'O': +#if SIZEOF_CURL_OFF_T > SIZEOF_LONG + flags |= FLAGS_LONGLONG; +#else + flags |= FLAGS_LONG; +#endif + break; + case '0': + if(!(flags & FLAGS_LEFT)) + flags |= FLAGS_PAD_NIL; + FALLTHROUGH(); + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': { + curl_off_t num; + flags |= FLAGS_WIDTH; + fmt--; + if(curlx_str_number(&fmt, &num, INT_MAX)) + return PFMT_WIDTH; + width = (int)num; + break; + } + case '*': /* read width from argument list */ + flags |= FLAGS_WIDTHPARAM; + if(use_dollar == DOLLAR_USE) { + width = dollarstring(fmt, &fmt); + if(width < 0) + /* illegal combo */ + return PFMT_DOLLARWIDTH; + } + else + /* pick from the next argument */ + width = -1; + break; + default: + loopit = FALSE; + fmt--; + break; + } /* switch */ + } while(loopit); /* do */ + *flagsp = flags; + *precp = precision; + *widthp = width; + *fmtp = fmt; + return PFMT_OK; +} + +static bool parse_conversion(const char f, unsigned int *flagp, + FormatType *typep) +{ + unsigned int flags = *flagp; + FormatType type; + switch(f) { + case 'S': + flags |= FLAGS_ALT; + type = MTYPE_STRING; + break; + case 's': + type = MTYPE_STRING; + break; + case 'n': + type = MTYPE_INTPTR; + break; + case 'p': + type = MTYPE_PTR; + break; + case 'd': + case 'i': + if(flags & FLAGS_LONGLONG) + type = MTYPE_LONGLONG; + else if(flags & FLAGS_LONG) + type = MTYPE_LONG; + else + type = MTYPE_INT; + break; + case 'u': + if(flags & FLAGS_LONGLONG) + type = MTYPE_LONGLONGU; + else if(flags & FLAGS_LONG) + type = MTYPE_LONGU; + else + type = MTYPE_INTU; + flags |= FLAGS_UNSIGNED; + break; + case 'o': + if(flags & FLAGS_LONGLONG) + type = MTYPE_LONGLONGU; + else if(flags & FLAGS_LONG) + type = MTYPE_LONGU; + else + type = MTYPE_INTU; + flags |= FLAGS_OCTAL | FLAGS_UNSIGNED; + break; + case 'x': + if(flags & FLAGS_LONGLONG) + type = MTYPE_LONGLONGU; + else if(flags & FLAGS_LONG) + type = MTYPE_LONGU; + else + type = MTYPE_INTU; + flags |= FLAGS_HEX | FLAGS_UNSIGNED; + break; + case 'X': + if(flags & FLAGS_LONGLONG) + type = MTYPE_LONGLONGU; + else if(flags & FLAGS_LONG) + type = MTYPE_LONGU; + else + type = MTYPE_INTU; + flags |= FLAGS_HEX | FLAGS_UPPER | FLAGS_UNSIGNED; + break; + case 'c': + type = MTYPE_INT; + flags |= FLAGS_CHAR; + break; + case 'f': + type = MTYPE_DOUBLE; + break; + case 'e': + type = MTYPE_DOUBLE; + flags |= FLAGS_FLOATE; + break; + case 'E': + type = MTYPE_DOUBLE; + flags |= FLAGS_FLOATE | FLAGS_UPPER; + break; + case 'g': + type = MTYPE_DOUBLE; + flags |= FLAGS_FLOATG; + break; + case 'G': + type = MTYPE_DOUBLE; + flags |= FLAGS_FLOATG | FLAGS_UPPER; + break; + default: + /* invalid instruction, disregard and continue */ + return TRUE; + } /* switch */ + + *flagp |= flags; + *typep = type; + return FALSE; +} + +static int parsefmt(const char *format, + struct outsegment *out, + struct va_input *in, + int *opieces, + int *ipieces, va_list arglist) +{ + const char *fmt = format; + int param_num = 0; + int max_param = -1; + int i; + int ocount = 0; + unsigned char usedinput[MAX_PARAMETERS / 8]; + size_t outlen = 0; + struct outsegment *optr; + int use_dollar = DOLLAR_UNKNOWN; + const char *start = fmt; + + /* clear, set a bit for each used input */ + memset(usedinput, 0, sizeof(usedinput)); + + while(*fmt) { + if(*fmt == '%') { + struct va_input *iptr; + FormatType type; + unsigned int flags = 0; + int width = 0; + int precision = 0; + int param = -1; + int rc; + fmt++; + outlen = (size_t)(fmt - start - 1); + if(*fmt == '%') { + /* this means a %% that should be output only as %. Create an output + segment. */ + if(outlen) { + optr = &out[ocount++]; + if(ocount > MAX_SEGMENTS) + return PFMT_MANYSEGS; + optr->input = 0; + optr->flags = FLAGS_SUBSTR; + optr->start = start; + optr->outlen = outlen; + } + start = fmt; + fmt++; + continue; /* while */ + } + + if(use_dollar != DOLLAR_NOPE) { + param = dollarstring(fmt, &fmt); + if(param < 0) { + if(use_dollar == DOLLAR_USE) + /* illegal combo */ + return PFMT_DOLLAR; + + /* we got no positional, get the next arg */ + param = -1; + use_dollar = DOLLAR_NOPE; + } + else + use_dollar = DOLLAR_USE; + } + + rc = parse_flags(&fmt, &flags, use_dollar, &precision, &width); + if(rc) + return rc; + + if(parse_conversion(*fmt, &flags, &type)) + continue; + + if(flags & FLAGS_WIDTHPARAM) { + if(width < 0) + width = param_num++; + else { + /* if this identifies a parameter already used, this is illegal */ + if(is_arg_used(usedinput, width)) + return PFMT_WIDTHARG; + } + if(width >= MAX_PARAMETERS) + return PFMT_MANYARGS; + if(width >= max_param) + max_param = width; + + in[width].type = MTYPE_WIDTH; + /* mark as used */ + mark_arg_used(usedinput, width); + } + + if(flags & FLAGS_PRECPARAM) { + if(precision < 0) + precision = param_num++; + else { + /* if this identifies a parameter already used, this is illegal */ + if(is_arg_used(usedinput, precision)) + return PFMT_PRECARG; + } + if(precision >= MAX_PARAMETERS) + return PFMT_MANYARGS; + if(precision >= max_param) + max_param = precision; + + in[precision].type = MTYPE_PRECISION; + mark_arg_used(usedinput, precision); + } + + /* Handle the specifier */ + if(param < 0) + param = param_num++; + if(param >= MAX_PARAMETERS) + return PFMT_MANYARGS; + if(param >= max_param) + max_param = param; + + iptr = &in[param]; + iptr->type = type; + + /* mark this input as used */ + mark_arg_used(usedinput, param); + + fmt++; + optr = &out[ocount++]; + if(ocount > MAX_SEGMENTS) + return PFMT_MANYSEGS; + optr->input = (unsigned int)param; + optr->flags = flags; + optr->width = width; + optr->precision = precision; + optr->start = start; + optr->outlen = outlen; + start = fmt; + } + else + fmt++; + } + + /* is there a trailing piece */ + outlen = (size_t)(fmt - start); + if(outlen) { + optr = &out[ocount++]; + if(ocount > MAX_SEGMENTS) + return PFMT_MANYSEGS; + optr->input = 0; + optr->flags = FLAGS_SUBSTR; + optr->start = start; + optr->outlen = outlen; + } + + /* Read the arg list parameters into our data list */ + for(i = 0; i < max_param + 1; i++) { + struct va_input *iptr = &in[i]; + if(!is_arg_used(usedinput, i)) + /* bad input */ + return PFMT_INPUTGAP; + + /* based on the type, read the correct argument */ + switch(iptr->type) { + case MTYPE_STRING: + iptr->val.str = va_arg(arglist, const char *); + break; + + case MTYPE_INTPTR: + case MTYPE_PTR: + iptr->val.ptr = va_arg(arglist, void *); + break; + + case MTYPE_LONGLONGU: + iptr->val.numu = va_arg(arglist, uint64_t); + break; + + case MTYPE_LONGLONG: + iptr->val.nums = va_arg(arglist, int64_t); + break; + + case MTYPE_LONGU: + iptr->val.numu = va_arg(arglist, unsigned long); + break; + + case MTYPE_LONG: + iptr->val.nums = va_arg(arglist, long); + break; + + case MTYPE_INTU: + iptr->val.numu = va_arg(arglist, unsigned int); + break; + + case MTYPE_INT: + case MTYPE_WIDTH: + case MTYPE_PRECISION: + iptr->val.nums = va_arg(arglist, int); + break; + + case MTYPE_DOUBLE: + iptr->val.dnum = va_arg(arglist, double); + break; + + default: + DEBUGASSERT(NULL); /* unexpected */ + break; + } + } + *ipieces = max_param + 1; + *opieces = ocount; + + return PFMT_OK; +} + +struct mproperty { + int width; /* Width of a field. */ + int prec; /* Precision of a field. */ + unsigned int flags; +}; + +static bool out_double(void *userp, + int (*stream)(unsigned char, void *), + struct mproperty *p, + double dnum, + char *work, int *donep) +{ + char fmt[32] = "%"; + char *fptr = &fmt[1]; + size_t left = sizeof(fmt) - strlen(fmt); + int flags = p->flags; + int width = p->width; + int prec = p->prec; + + if(flags & FLAGS_LEFT) + *fptr++ = '-'; + if(flags & FLAGS_SHOWSIGN) + *fptr++ = '+'; + if(flags & FLAGS_SPACE) + *fptr++ = ' '; + if(flags & FLAGS_ALT) + *fptr++ = '#'; + + *fptr = 0; + + if(width >= 0) { + size_t dlen; + if(width >= BUFFSIZE) + width = BUFFSIZE - 1; + /* RECURSIVE USAGE */ + dlen = (size_t)curl_msnprintf(fptr, left, "%d", width); + fptr += dlen; + left -= dlen; + } + if(prec >= 0) { + /* for each digit in the integer part, we can have one less + precision */ + int maxprec = BUFFSIZE - 1; + double val = dnum; + int len; + if(prec > maxprec) + prec = maxprec - 1; + if(width > 0 && prec <= width) + maxprec -= width; + while(val >= 10.0) { + val /= 10; + maxprec--; + } + + if(prec > maxprec) + prec = maxprec - 1; + if(prec < 0) + prec = 0; + /* RECURSIVE USAGE */ + len = curl_msnprintf(fptr, left, ".%d", prec); + fptr += len; + } + if(flags & FLAGS_LONG) + *fptr++ = 'l'; + + if(flags & FLAGS_FLOATE) + *fptr++ = (char)((flags & FLAGS_UPPER) ? 'E' : 'e'); + else if(flags & FLAGS_FLOATG) + *fptr++ = (char)((flags & FLAGS_UPPER) ? 'G' : 'g'); + else + *fptr++ = 'f'; + + *fptr = 0; /* and a final null-termination */ + + /* NOTE NOTE NOTE!! Not all sprintf implementations return number of + output characters */ +#ifdef CURL_HAVE_DIAG +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Wformat-nonliteral" +#endif +#ifdef _WIN32 + curlx_win32_snprintf(work, BUFFSIZE, fmt, dnum); +#else + /* !checksrc! disable BANNEDFUNC 1 */ + /* !checksrc! disable LONGLINE */ + /* NOLINTNEXTLINE(clang-analyzer-security.insecureAPI.DeprecatedOrUnsafeBufferHandling) */ + snprintf(work, BUFFSIZE, fmt, dnum); +#endif +#ifdef CURL_HAVE_DIAG +#pragma GCC diagnostic pop +#endif + DEBUGASSERT(strlen(work) < BUFFSIZE); + while(*work) { + if(stream(*work++, userp)) + return TRUE; + (*donep)++; + } + return 0; +} + +static bool out_number(void *userp, + int (*stream)(unsigned char, void *), + struct mproperty *p, + uint64_t num, + int64_t nums, + char *work, int *donep) +{ + const unsigned char *digits = Curl_ldigits; + int flags = p->flags; + int width = p->width; + int prec = p->prec; + bool is_alt = flags & FLAGS_ALT; + bool is_neg = FALSE; + int base = 10; + + /* 'workend' points to the final buffer byte position, but with an extra + byte as margin to avoid the (FALSE?) warning Coverity gives us + otherwise */ + char *workend = &work[BUFFSIZE - 2]; + char *w; + + if(flags & FLAGS_CHAR) { + /* Character. */ + if(!(flags & FLAGS_LEFT)) + while(--width > 0) + OUTCHAR(' '); + OUTCHAR((char)num); + if(flags & FLAGS_LEFT) + while(--width > 0) + OUTCHAR(' '); + return FALSE; + } + if(flags & FLAGS_OCTAL) + /* Octal unsigned integer */ + base = 8; + + else if(flags & FLAGS_HEX) { + /* Hexadecimal unsigned integer */ + digits = (flags & FLAGS_UPPER) ? Curl_udigits : Curl_ldigits; + base = 16; + } + else if(flags & FLAGS_UNSIGNED) + /* Decimal unsigned integer */ + ; + + else { + /* Decimal integer. */ + is_neg = (nums < 0); + if(is_neg) { + /* signed_num might fail to hold absolute negative minimum by 1 */ + int64_t signed_num; /* Used to convert negative in positive. */ + signed_num = nums + (int64_t)1; + signed_num = -signed_num; + num = (uint64_t)signed_num; + num += (uint64_t)1; + } + } + + /* Supply a default precision if none was given. */ + if(prec == -1) + prec = 1; + + /* Put the number in WORK. */ + w = workend; + DEBUGASSERT(base <= 16); + switch(base) { + case 10: + while(num > 0) { + *w-- = (char)('0' + (num % 10)); + num /= 10; + } + break; + default: + while(num > 0) { + *w-- = digits[num % base]; + num /= base; + } + break; + } + width -= (int)(workend - w); + prec -= (int)(workend - w); + + if(is_alt && base == 8 && prec <= 0) { + *w-- = '0'; + --width; + } + + if(prec > 0) { + width -= prec; + while(prec-- > 0 && w >= work) + *w-- = '0'; + } + + if(is_alt && base == 16) + width -= 2; + + if(is_neg || (flags & FLAGS_SHOWSIGN) || (flags & FLAGS_SPACE)) + --width; + + if(!(flags & FLAGS_LEFT) && !(flags & FLAGS_PAD_NIL)) + while(width-- > 0) + OUTCHAR(' '); + + if(is_neg) + OUTCHAR('-'); + else if(flags & FLAGS_SHOWSIGN) + OUTCHAR('+'); + else if(flags & FLAGS_SPACE) + OUTCHAR(' '); + + if(is_alt && base == 16) { + OUTCHAR('0'); + if(flags & FLAGS_UPPER) + OUTCHAR('X'); + else + OUTCHAR('x'); + } + + if(!(flags & FLAGS_LEFT) && (flags & FLAGS_PAD_NIL)) + while(width-- > 0) + OUTCHAR('0'); + + /* Write the number. */ + while(++w <= workend) { + OUTCHAR(*w); + } + + if(flags & FLAGS_LEFT) + while(width-- > 0) + OUTCHAR(' '); + + return FALSE; +} + +static const char nilstr[] = "(nil)"; + +static bool out_string(void *userp, + int (*stream)(unsigned char, void *), + struct mproperty *p, + const char *str, + int *donep) +{ + int flags = p->flags; + int width = p->width; + int prec = p->prec; + size_t len; + + if(!str) { + /* Write null string if there is space. */ + if(prec == -1 || prec >= (int)sizeof(nilstr) - 1) { + str = nilstr; + len = sizeof(nilstr) - 1; + /* Disable quotes around (nil) */ + flags &= ~(unsigned int)FLAGS_ALT; + } + else { + str = ""; + len = 0; + } + } + else if(prec != -1) + len = (size_t)prec; + else if(*str == '\0') + len = 0; + else + len = strlen(str); + + width -= (len > INT_MAX) ? INT_MAX : (int)len; + + if(flags & FLAGS_ALT) + OUTCHAR('"'); + + if(!(flags & FLAGS_LEFT)) + while(width-- > 0) + OUTCHAR(' '); + + for(; len && *str; len--) + OUTCHAR(*str++); + if(flags & FLAGS_LEFT) + while(width-- > 0) + OUTCHAR(' '); + + if(flags & FLAGS_ALT) + OUTCHAR('"'); + + return FALSE; +} + +static bool out_pointer(void *userp, + int (*stream)(unsigned char, void *), + struct mproperty *p, + const char *ptr, + char *work, + int *donep) +{ + /* Generic pointer. */ + if(ptr) { + size_t num = (size_t)ptr; + + /* If the pointer is not NULL, write it as a %#x spec. */ + p->flags |= FLAGS_HEX | FLAGS_ALT; + if(out_number(userp, stream, p, num, 0, work, donep)) + return TRUE; + } + else { + /* Write "(nil)" for a nil pointer. */ + const char *point; + int width = p->width; + int flags = p->flags; + + width -= (int)(sizeof(nilstr) - 1); + if(flags & FLAGS_LEFT) + while(width-- > 0) + OUTCHAR(' '); + for(point = nilstr; *point; ++point) + OUTCHAR(*point); + if(!(flags & FLAGS_LEFT)) + while(width-- > 0) + OUTCHAR(' '); + } + return FALSE; +} + +/* + * formatf() - the general printf function. + * + * It calls parsefmt() to parse the format string. It populates two arrays; + * one that describes the input arguments and one that describes a number of + * output segments. + * + * On success, the input array describes the type of all arguments and their + * values. + * + * The function then iterates over the output segments and outputs them one + * by one until done. Using the appropriate input arguments (if any). + * + * All output is sent to the 'stream()' callback, one byte at a time. + */ +static int formatf(void *userp, /* untouched by format(), sent to the + stream() function in the second argument */ + /* function pointer called for each output character */ + int (*stream)(unsigned char, void *), + const char *format, /* %-formatted string */ + va_list ap_save) /* list of parameters */ +{ + int done = 0; /* number of characters written */ + int i; + int ocount = 0; /* number of output segments */ + int icount = 0; /* number of input arguments */ + + struct outsegment output[MAX_SEGMENTS]; + struct va_input input[MAX_PARAMETERS]; + char work[BUFFSIZE + 2]; + + /* Parse the format string */ + if(parsefmt(format, output, input, &ocount, &icount, ap_save)) + return 0; + + for(i = 0; i < ocount; i++) { + struct outsegment *optr = &output[i]; + struct va_input *iptr = &input[optr->input]; + struct mproperty p; + size_t outlen = optr->outlen; + + if(outlen) { + const char *str = optr->start; + for(; outlen && *str; outlen--) { + if(stream(*str++, userp)) + return done; + done++; + } + if(optr->flags & FLAGS_SUBSTR) + /* this is a substring */ + continue; + } + + p.flags = optr->flags; + + /* pick up the specified width */ + if(p.flags & FLAGS_WIDTHPARAM) { + p.width = (int)input[optr->width].val.nums; + if(p.width < 0) { + /* "A negative field width is taken as a '-' flag followed by a + positive field width." */ + if(p.width == INT_MIN) + p.width = INT_MAX; + else + p.width = -p.width; + p.flags |= FLAGS_LEFT; + p.flags &= ~(unsigned int)FLAGS_PAD_NIL; + } + } + else + p.width = optr->width; + + /* pick up the specified precision */ + if(p.flags & FLAGS_PRECPARAM) { + p.prec = (int)input[optr->precision].val.nums; + if(p.prec < 0) + /* "A negative precision is taken as if the precision were + omitted." */ + p.prec = -1; + } + else if(p.flags & FLAGS_PREC) + p.prec = optr->precision; + else + p.prec = -1; + + switch(iptr->type) { + case MTYPE_INTU: + case MTYPE_LONGU: + case MTYPE_LONGLONGU: + p.flags |= FLAGS_UNSIGNED; + if(out_number(userp, stream, &p, iptr->val.numu, 0, work, &done)) + return done; + break; + + case MTYPE_INT: + case MTYPE_LONG: + case MTYPE_LONGLONG: + if(out_number(userp, stream, &p, iptr->val.numu, + iptr->val.nums, work, &done)) + return done; + break; + + case MTYPE_STRING: + if(out_string(userp, stream, &p, iptr->val.str, &done)) + return done; + break; + + case MTYPE_PTR: + if(out_pointer(userp, stream, &p, iptr->val.ptr, work, &done)) + return done; + break; + + case MTYPE_DOUBLE: + if(out_double(userp, stream, &p, iptr->val.dnum, work, &done)) + return done; + break; + + case MTYPE_INTPTR: + /* Answer the count of characters written. */ + if(p.flags & FLAGS_LONGLONG) + *(int64_t *)iptr->val.ptr = (int64_t)done; + else if(p.flags & FLAGS_LONG) + *(long *)iptr->val.ptr = (long)done; + else if(!(p.flags & FLAGS_SHORT)) + *(int *)iptr->val.ptr = done; + else + *(short *)iptr->val.ptr = (short)done; + break; + + default: + break; + } + } + return done; +} + +/* fputc() look-alike */ +static int addbyter(unsigned char outc, void *f) +{ + struct nsprintf *infop = f; + if(infop->length < infop->max) { + /* only do this if we have not reached max length yet */ + *infop->buffer++ = (char)outc; /* store */ + infop->length++; /* we are now one byte larger */ + return 0; /* fputc() returns like this on success */ + } + return 1; +} + +int curl_mvsnprintf(char *buffer, size_t maxlength, const char *format, + va_list args) +{ + int retcode; + struct nsprintf info; + + info.buffer = buffer; + info.length = 0; + info.max = maxlength; + + retcode = formatf(&info, addbyter, format, args); + if(info.max) { + /* we terminate this with a zero byte */ + if(info.max == info.length) { + /* we are at maximum, scrap the last letter */ + info.buffer[-1] = 0; + DEBUGASSERT(retcode); + retcode--; /* do not count the nul byte */ + } + else + info.buffer[0] = 0; + } + return retcode; +} + +int curl_msnprintf(char *buffer, size_t maxlength, const char *format, ...) +{ + int retcode; + va_list args; /* argument pointer */ + va_start(args, format); + retcode = curl_mvsnprintf(buffer, maxlength, format, args); + va_end(args); + return retcode; +} + +/* fputc() look-alike */ +static int alloc_addbyter(unsigned char outc, void *f) +{ + struct asprintf *infop = f; + CURLcode result = curlx_dyn_addn(infop->b, &outc, 1); + if(result) { + infop->merr = result == CURLE_TOO_LARGE ? MERR_TOO_LARGE : MERR_MEM; + return 1; /* fail */ + } + return 0; +} + +/* appends the formatted string, returns MERR error code */ +int curlx_dyn_vprintf(struct dynbuf *dyn, const char *format, va_list args) +{ + struct asprintf info; + info.b = dyn; + info.merr = MERR_OK; + + (void)formatf(&info, alloc_addbyter, format, args); + if(info.merr) { + curlx_dyn_free(info.b); + return info.merr; + } + return 0; +} + +char *curl_mvaprintf(const char *format, va_list args) +{ + struct asprintf info; + struct dynbuf dyn; + info.b = &dyn; + curlx_dyn_init(info.b, DYN_APRINTF); + info.merr = MERR_OK; + + (void)formatf(&info, alloc_addbyter, format, args); + if(info.merr) { + curlx_dyn_free(info.b); + return NULL; + } + if(curlx_dyn_len(info.b)) + return curlx_dyn_ptr(info.b); + return curlx_strdup(""); +} + +char *curl_maprintf(const char *format, ...) +{ + va_list args; + char *s; + va_start(args, format); + s = curl_mvaprintf(format, args); + va_end(args); + return s; +} + +static int storebuffer(unsigned char outc, void *f) +{ + char **buffer = f; + **buffer = (char)outc; + (*buffer)++; + return 0; +} + +int curl_msprintf(char *buffer, const char *format, ...) +{ + va_list args; /* argument pointer */ + int retcode; + va_start(args, format); + retcode = formatf(&buffer, storebuffer, format, args); + va_end(args); + *buffer = 0; /* we terminate this with a zero byte */ + return retcode; +} + +static int fputc_wrapper(unsigned char outc, void *f) +{ + int out = outc; + FILE *s = f; + int rc = fputc(out, s); + return rc == EOF; +} + +int curl_mprintf(const char *format, ...) +{ + int retcode; + va_list args; /* argument pointer */ + va_start(args, format); + retcode = formatf(stdout, fputc_wrapper, format, args); + va_end(args); + return retcode; +} + +int curl_mfprintf(FILE *fd, const char *format, ...) +{ + int retcode; + va_list args; /* argument pointer */ + va_start(args, format); + retcode = formatf(fd, fputc_wrapper, format, args); + va_end(args); + return retcode; +} + +int curl_mvsprintf(char *buffer, const char *format, va_list args) +{ + int retcode = formatf(&buffer, storebuffer, format, args); + *buffer = 0; /* we terminate this with a zero byte */ + return retcode; +} + +int curl_mvprintf(const char *format, va_list args) +{ + return formatf(stdout, fputc_wrapper, format, args); +} + +int curl_mvfprintf(FILE *fd, const char *format, va_list args) +{ + return formatf(fd, fputc_wrapper, format, args); +} diff --git a/3rdparty/curl-8.21.0/lib/mqtt.c b/3rdparty/curl-8.21.0/lib/mqtt.c new file mode 100644 index 0000000000..8482477b97 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/mqtt.c @@ -0,0 +1,1030 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * Copyright (C) Björn Stenberg, + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" +#include "urldata.h" + +#ifndef CURL_DISABLE_MQTT + +#include "transfer.h" +#include "sendf.h" +#include "curl_trc.h" +#include "progress.h" +#include "mqtt.h" +#include "select.h" +#include "url.h" +#include "escape.h" +#include "rand.h" +#include "cfilters.h" +#include "connect.h" + +/* first byte is command. + second byte is for flags. */ +#define MQTT_MSG_CONNECT 0x10 +/* #define MQTT_MSG_CONNACK 0x20 */ +#define MQTT_MSG_PUBLISH 0x30 +#define MQTT_MSG_SUBSCRIBE 0x82 +#define MQTT_MSG_SUBACK 0x90 +#define MQTT_MSG_DISCONNECT 0xe0 +/* #define MQTT_MSG_PINGREQ 0xC0 */ +#define MQTT_MSG_PINGRESP 0xD0 + +#define MQTT_CONNACK_LEN 2 +#define MQTT_SUBACK_LEN 3 +#define MQTT_CLIENTID_LEN 12 /* "curl0123abcd" */ + +/* meta key for storing protocol meta at easy handle */ +#define CURL_META_MQTT_EASY "meta:proto:mqtt:easy" +/* meta key for storing protocol meta at connection */ +#define CURL_META_MQTT_CONN "meta:proto:mqtt:conn" + +enum mqttstate { + MQTT_FIRST, /* 0 */ + MQTT_REMAINING_LENGTH, /* 1 */ + MQTT_CONNACK, /* 2 */ + MQTT_SUBACK, /* 3 */ + MQTT_SUBACK_COMING, /* 4 - the SUBACK remainder */ + MQTT_PUBWAIT, /* 5 - wait for publish */ + MQTT_PUB_REMAIN, /* 6 - wait for the remainder of the publish */ + + MQTT_NOSTATE /* 7 - never used an actual state */ +}; + +struct mqtt_conn { + enum mqttstate state; + enum mqttstate nextstate; /* switch to this after remaining length is + done */ + unsigned int packetid; +}; + +/* protocol-specific transfer-related data */ +struct MQTT { + struct dynbuf sendbuf; + /* when receiving */ + struct dynbuf recvbuf; + size_t npacket; /* byte counter */ + size_t remaining_length; + unsigned char pkt_hd[4]; /* for decoding the arriving packet length */ + struct curltime lastTime; /* last time we sent or received data */ + unsigned char firstbyte; + BIT(pingsent); /* 1 while we wait for ping response */ +}; + +static void mqtt_easy_dtor(void *key, size_t klen, void *entry) +{ + struct MQTT *mq = entry; + (void)key; + (void)klen; + curlx_dyn_free(&mq->sendbuf); + curlx_dyn_free(&mq->recvbuf); + curlx_free(mq); +} + +static void mqtt_conn_dtor(void *key, size_t klen, void *entry) +{ + (void)key; + (void)klen; + curlx_free(entry); +} + +static CURLcode mqtt_setup_conn(struct Curl_easy *data, + struct connectdata *conn) +{ + /* setup MQTT specific meta data at easy handle and connection */ + struct mqtt_conn *mqtt; + struct MQTT *mq; + + mqtt = curlx_calloc(1, sizeof(*mqtt)); + if(!mqtt || + Curl_conn_meta_set(conn, CURL_META_MQTT_CONN, mqtt, mqtt_conn_dtor)) + return CURLE_OUT_OF_MEMORY; + + mq = curlx_calloc(1, sizeof(struct MQTT)); + if(!mq) + return CURLE_OUT_OF_MEMORY; + curlx_dyn_init(&mq->recvbuf, DYN_MQTT_RECV); + curlx_dyn_init(&mq->sendbuf, DYN_MQTT_SEND); + if(Curl_meta_set(data, CURL_META_MQTT_EASY, mq, mqtt_easy_dtor)) + return CURLE_OUT_OF_MEMORY; + return CURLE_OK; +} + +static CURLcode mqtt_send(struct Curl_easy *data, + const char *buf, size_t len) +{ + size_t n; + CURLcode result; + struct MQTT *mq = Curl_meta_get(data, CURL_META_MQTT_EASY); + + if(!mq) + return CURLE_FAILED_INIT; + + result = Curl_xfer_send(data, buf, len, FALSE, &n); + if(result) + return result; + mq->lastTime = *Curl_pgrs_now(data); + Curl_debug(data, CURLINFO_HEADER_OUT, buf, n); + if(len != n) { + size_t nsend = len - n; + if(curlx_dyn_len(&mq->sendbuf)) { + DEBUGASSERT(curlx_dyn_len(&mq->sendbuf) >= nsend); + result = curlx_dyn_tail(&mq->sendbuf, nsend); /* keep this much */ + } + else { + result = curlx_dyn_addn(&mq->sendbuf, &buf[n], nsend); + } + } + else + curlx_dyn_reset(&mq->sendbuf); + return result; +} + +/* Generic function called by the multi interface to figure out what socket(s) + to wait for and for what actions during the DOING and PROTOCONNECT + states */ +static CURLcode mqtt_pollset(struct Curl_easy *data, + struct easy_pollset *ps) +{ + return Curl_pollset_add_in(data, ps, data->conn->sock[FIRSTSOCKET]); +} + +static int mqtt_encode_len(char *buf, size_t len) +{ + int i; + + for(i = 0; (len > 0) && (i < 4); i++) { + unsigned char encoded; + encoded = len % 0x80; + len /= 0x80; + if(len) + encoded |= 0x80; + buf[i] = (char)encoded; + } + + return i; +} + +/* add the passwd to the CONNECT packet */ +static int add_passwd(const char *passwd, const size_t plen, + char *pkt, const size_t start, int remain_pos) +{ + /* magic number that need to be set properly */ + const size_t conn_flags_pos = remain_pos + 8; + if(plen > 0xffff) + return 1; + + /* set password flag */ + pkt[conn_flags_pos] |= 0x40; + + /* length of password provided */ + pkt[start] = (char)((plen >> 8) & 0xFF); + pkt[start + 1] = (char)(plen & 0xFF); + memcpy(&pkt[start + 2], passwd, plen); + return 0; +} + +/* add user to the CONNECT packet */ +static int add_user(const char *username, const size_t ulen, + unsigned char *pkt, const size_t start, int remain_pos) +{ + /* magic number that need to be set properly */ + const size_t conn_flags_pos = remain_pos + 8; + if(ulen > 0xffff) + return 1; + + /* set username flag */ + pkt[conn_flags_pos] |= 0x80; + /* length of username provided */ + pkt[start] = (unsigned char)((ulen >> 8) & 0xFF); + pkt[start + 1] = (unsigned char)(ulen & 0xFF); + memcpy(&pkt[start + 2], username, ulen); + return 0; +} + +/* add client ID to the CONNECT packet */ +static int add_client_id(const char *client_id, const size_t client_id_len, + char *pkt, const size_t start) +{ + if(client_id_len != MQTT_CLIENTID_LEN) + return 1; + pkt[start] = 0x00; + pkt[start + 1] = MQTT_CLIENTID_LEN; + memcpy(&pkt[start + 2], client_id, MQTT_CLIENTID_LEN); + return 0; +} + +/* Set initial values of CONNECT packet */ +static int init_connpack(char *packet, char *remain, int remain_pos) +{ + /* Fixed header starts */ + /* packet type */ + packet[0] = MQTT_MSG_CONNECT; + /* remaining length field */ + memcpy(&packet[1], remain, remain_pos); + /* Fixed header ends */ + + /* Variable header starts */ + /* protocol length */ + packet[remain_pos + 1] = 0x00; + packet[remain_pos + 2] = 0x04; + /* protocol name */ + packet[remain_pos + 3] = 'M'; + packet[remain_pos + 4] = 'Q'; + packet[remain_pos + 5] = 'T'; + packet[remain_pos + 6] = 'T'; + /* protocol level */ + packet[remain_pos + 7] = 0x04; + /* CONNECT flag: CleanSession */ + packet[remain_pos + 8] = 0x02; + /* keep-alive 0 = disabled */ + packet[remain_pos + 9] = 0x00; + packet[remain_pos + 10] = 0x3c; + /* end of variable header */ + return remain_pos + 10; +} + +static CURLcode mqtt_connect(struct Curl_easy *data) +{ + CURLcode result = CURLE_OK; + int pos = 0; + int rc = 0; + /* remain length */ + int remain_pos = 0; + char remain[4] = { 0 }; + size_t packetlen = 0; + size_t start_user = 0; + size_t start_pwd = 0; + char client_id[MQTT_CLIENTID_LEN + 1] = "curl"; + const size_t clen = strlen("curl"); + char *packet = NULL; + + /* extracting username from request */ + struct Curl_creds *creds = data->state.creds; + const size_t ulen = creds ? strlen(creds->user) : 0; + const size_t plen = creds ? strlen(creds->passwd) : 0; + const size_t payloadlen = ulen + plen + MQTT_CLIENTID_LEN + 2 + + /* The plus 2s below are for the MSB and LSB describing the length of the + string to be added on the payload. Refer to spec 1.5.2 and 1.5.4 */ + (ulen ? 2 : 0) + + (plen ? 2 : 0); + + /* getting how much occupy the remain length */ + remain_pos = mqtt_encode_len(remain, payloadlen + 10); + + /* 10 length of variable header and 1 the first byte of the fixed header */ + packetlen = payloadlen + 10 + remain_pos + 1; + + /* allocating packet */ + if(packetlen > 0xFFFFFFF) + return CURLE_WEIRD_SERVER_REPLY; + packet = curlx_calloc(1, packetlen); + if(!packet) + return CURLE_OUT_OF_MEMORY; + + /* set initial values for the CONNECT packet */ + pos = init_connpack(packet, remain, remain_pos); + + result = Curl_rand_alnum(data, (unsigned char *)&client_id[clen], + MQTT_CLIENTID_LEN - clen + 1); + /* add client id */ + rc = add_client_id(client_id, strlen(client_id), packet, pos + 1); + if(rc) { + failf(data, "Client ID length mismatched: [%zu]", strlen(client_id)); + result = CURLE_WEIRD_SERVER_REPLY; + goto end; + } + infof(data, "Using client id '%s'", client_id); + + /* position where the user payload starts */ + start_user = pos + 3 + MQTT_CLIENTID_LEN; + /* position where the password payload starts */ + start_pwd = start_user + ulen; + /* if username was provided, add it to the packet */ + if(ulen) { + start_pwd += 2; + + rc = add_user(creds->user, ulen, + (unsigned char *)packet, start_user, remain_pos); + if(rc) { + failf(data, "Username too long: [%zu]", ulen); + result = CURLE_WEIRD_SERVER_REPLY; + goto end; + } + } + + /* if passwd was provided, add it to the packet */ + if(plen) { + rc = add_passwd(creds->passwd, plen, packet, start_pwd, remain_pos); + if(rc) { + failf(data, "Password too long: [%zu]", plen); + result = CURLE_WEIRD_SERVER_REPLY; + goto end; + } + } + + if(!result) + result = mqtt_send(data, packet, packetlen); + +end: + if(packet) + curlx_free(packet); + Curl_creds_unlink(&data->state.creds); + return result; +} + +static CURLcode mqtt_disconnect(struct Curl_easy *data) +{ + return mqtt_send(data, "\xe0\x00", 2); +} + +static CURLcode mqtt_recv_atleast(struct Curl_easy *data, size_t nbytes) +{ + struct MQTT *mq = Curl_meta_get(data, CURL_META_MQTT_EASY); + size_t rlen; + CURLcode result; + + if(!mq) + return CURLE_FAILED_INIT; + rlen = curlx_dyn_len(&mq->recvbuf); + + if(rlen < nbytes) { + unsigned char readbuf[1024]; + size_t nread; + + DEBUGASSERT(nbytes - rlen < sizeof(readbuf)); + result = Curl_xfer_recv(data, (char *)readbuf, nbytes - rlen, &nread); + if(result) + return result; + if(!nread) /* EOF */ + return CURLE_RECV_ERROR; + if(curlx_dyn_addn(&mq->recvbuf, readbuf, nread)) + return CURLE_OUT_OF_MEMORY; + rlen = curlx_dyn_len(&mq->recvbuf); + } + return (rlen >= nbytes) ? CURLE_OK : CURLE_AGAIN; +} + +static void mqtt_recv_consume(struct Curl_easy *data, size_t nbytes) +{ + struct MQTT *mq = Curl_meta_get(data, CURL_META_MQTT_EASY); + DEBUGASSERT(mq); + if(mq) { + size_t rlen = curlx_dyn_len(&mq->recvbuf); + if(rlen <= nbytes) + curlx_dyn_reset(&mq->recvbuf); + else + curlx_dyn_tail(&mq->recvbuf, rlen - nbytes); + } +} + +static CURLcode mqtt_verify_connack(struct Curl_easy *data) +{ + struct MQTT *mq = Curl_meta_get(data, CURL_META_MQTT_EASY); + CURLcode result; + const char *ptr; + + DEBUGASSERT(mq); + if(!mq) + return CURLE_FAILED_INIT; + if(mq->remaining_length != 2) { + failf(data, "CONNACK expected Remaining Length 2, got %zu", + mq->remaining_length); + return CURLE_WEIRD_SERVER_REPLY; + } + + result = mqtt_recv_atleast(data, MQTT_CONNACK_LEN); + if(result) + return result; + + /* verify CONNACK */ + DEBUGASSERT(curlx_dyn_len(&mq->recvbuf) >= MQTT_CONNACK_LEN); + ptr = curlx_dyn_ptr(&mq->recvbuf); + Curl_debug(data, CURLINFO_HEADER_IN, ptr, MQTT_CONNACK_LEN); + + if(ptr[0] != 0x00 || ptr[1] != 0x00) { + failf(data, "Expected %02x%02x but got %02x%02x", + 0x00U, 0x00U, (unsigned char)ptr[0], (unsigned char)ptr[1]); + curlx_dyn_reset(&mq->recvbuf); + return CURLE_WEIRD_SERVER_REPLY; + } + mqtt_recv_consume(data, MQTT_CONNACK_LEN); + return CURLE_OK; +} + +static CURLcode mqtt_get_topic(struct Curl_easy *data, + char **topic, size_t *topiclen) +{ + const char *path = data->state.up.path; + CURLcode result = CURLE_URL_MALFORMAT; + if(strlen(path) > 1) { + result = Curl_urldecode(path + 1, 0, topic, topiclen, REJECT_NADA); + if(!result && (*topiclen > 0xffff)) { + failf(data, "Too long MQTT topic"); + result = CURLE_URL_MALFORMAT; + } + } + else + failf(data, "No MQTT topic found. Forgot to URL encode it?"); + + return result; +} + +static CURLcode mqtt_subscribe(struct Curl_easy *data) +{ + CURLcode result = CURLE_OK; + char *topic = NULL; + size_t topiclen; + unsigned char *packet = NULL; + size_t packetlen; + char encodedsize[4]; + size_t n; + struct connectdata *conn = data->conn; + struct mqtt_conn *mqtt = Curl_conn_meta_get(conn, CURL_META_MQTT_CONN); + + if(!mqtt) + return CURLE_FAILED_INIT; + + result = mqtt_get_topic(data, &topic, &topiclen); + if(result) + goto fail; + + mqtt->packetid++; + + packetlen = topiclen + 5; /* packetid + topic (has a two byte length field) + + 2 bytes topic length + QoS byte */ + n = mqtt_encode_len((char *)encodedsize, packetlen); + packetlen += n + 1; /* add one for the control packet type byte */ + + packet = curlx_malloc(packetlen); + if(!packet) { + result = CURLE_OUT_OF_MEMORY; + goto fail; + } + + packet[0] = MQTT_MSG_SUBSCRIBE; + memcpy(&packet[1], encodedsize, n); + packet[1 + n] = (mqtt->packetid >> 8) & 0xff; + packet[2 + n] = mqtt->packetid & 0xff; + packet[3 + n] = (topiclen >> 8) & 0xff; + packet[4 + n] = topiclen & 0xff; + memcpy(&packet[5 + n], topic, topiclen); + packet[5 + n + topiclen] = 0; /* QoS zero */ + + result = mqtt_send(data, (const char *)packet, packetlen); + +fail: + curlx_free(topic); + curlx_free(packet); + return result; +} + +/* + * Called when the first byte was already read. + */ +static CURLcode mqtt_verify_suback(struct Curl_easy *data) +{ + struct MQTT *mq = Curl_meta_get(data, CURL_META_MQTT_EASY); + struct connectdata *conn = data->conn; + struct mqtt_conn *mqtt = Curl_conn_meta_get(conn, CURL_META_MQTT_CONN); + CURLcode result; + const char *ptr; + + if(!mqtt || !mq) + return CURLE_FAILED_INIT; + + if(mq->remaining_length != 3) { + failf(data, "SUBACK expected Remaining Length 3, got %zu", + mq->remaining_length); + return CURLE_WEIRD_SERVER_REPLY; + } + + result = mqtt_recv_atleast(data, MQTT_SUBACK_LEN); + if(result) + goto fail; + + /* verify SUBACK */ + DEBUGASSERT(curlx_dyn_len(&mq->recvbuf) >= MQTT_SUBACK_LEN); + ptr = curlx_dyn_ptr(&mq->recvbuf); + Curl_debug(data, CURLINFO_HEADER_IN, ptr, MQTT_SUBACK_LEN); + + if(((unsigned char)ptr[0]) != ((mqtt->packetid >> 8) & 0xff) || + ((unsigned char)ptr[1]) != (mqtt->packetid & 0xff) || + ptr[2] != 0x00) { + curlx_dyn_reset(&mq->recvbuf); + result = CURLE_WEIRD_SERVER_REPLY; + goto fail; + } + mqtt_recv_consume(data, MQTT_SUBACK_LEN); +fail: + return result; +} + +#define MAX_MQTT_MESSAGE_SIZE 0xFFFFFFF + +static CURLcode mqtt_publish(struct Curl_easy *data) +{ + CURLcode result; + char *payload = data->set.postfields; + size_t payloadlen; + char *topic = NULL; + size_t topiclen; + unsigned char *pkt = NULL; + size_t i = 0; + size_t remaininglength; + size_t encodelen; + char encodedbytes[4]; + curl_off_t postfieldsize = data->set.postfieldsize; + + if(!payload) { + DEBUGF(infof(data, "mqtt_publish without payload, return bad arg")); + return CURLE_BAD_FUNCTION_ARGUMENT; + } + if(!curlx_sotouz_fits(postfieldsize, &payloadlen)) { + if(postfieldsize > 0) /* off_t does not fit into size_t */ + return CURLE_BAD_FUNCTION_ARGUMENT; + payloadlen = strlen(payload); + } + + result = mqtt_get_topic(data, &topic, &topiclen); + if(result) + goto fail; + + remaininglength = payloadlen + 2 + topiclen; + encodelen = mqtt_encode_len(encodedbytes, remaininglength); + if(remaininglength > (MAX_MQTT_MESSAGE_SIZE - encodelen - 1)) { + result = CURLE_TOO_LARGE; + goto fail; + } + + /* add the control byte and the encoded remaining length */ + pkt = curlx_malloc(remaininglength + 1 + encodelen); + if(!pkt) { + result = CURLE_OUT_OF_MEMORY; + goto fail; + } + + /* assemble packet */ + pkt[i++] = MQTT_MSG_PUBLISH; + memcpy(&pkt[i], encodedbytes, encodelen); + i += encodelen; + pkt[i++] = (topiclen >> 8) & 0xff; + pkt[i++] = (topiclen & 0xff); + memcpy(&pkt[i], topic, topiclen); + i += topiclen; + memcpy(&pkt[i], payload, payloadlen); + i += payloadlen; + result = mqtt_send(data, (const char *)pkt, i); + +fail: + curlx_free(pkt); + curlx_free(topic); + return result; +} + +/* return FALSE on success, TRUE on error */ +static bool mqtt_decode_len(size_t *lenp, const unsigned char *buf, + size_t buflen) +{ + size_t len = 0; + size_t mult = 1; + size_t i; + unsigned char encoded = 128; + + for(i = 0; (i < buflen) && (encoded & 128); i++) { + if(i == 4) + return TRUE; /* bad size */ + encoded = buf[i]; + len += (encoded & 127) * mult; + mult *= 128; + } + if(encoded & 128) + /* truncated size */ + return TRUE; + + *lenp = len; + return FALSE; +} + +#if defined(DEBUGBUILD) && defined(CURLVERBOSE) +static const char *statenames[] = { + "MQTT_FIRST", + "MQTT_REMAINING_LENGTH", + "MQTT_CONNACK", + "MQTT_SUBACK", + "MQTT_SUBACK_COMING", + "MQTT_PUBWAIT", + "MQTT_PUB_REMAIN", + + "NOT A STATE" +}; +#endif + +/* The only way to change state */ +static void mqstate(struct Curl_easy *data, + enum mqttstate state, + enum mqttstate nextstate) /* used if state == FIRST */ +{ + struct connectdata *conn = data->conn; + struct mqtt_conn *mqtt = Curl_conn_meta_get(conn, CURL_META_MQTT_CONN); + DEBUGASSERT(mqtt); + if(!mqtt) + return; +#ifdef DEBUGBUILD + infof(data, "%s (from %s) (next is %s)", + statenames[state], + statenames[mqtt->state], + (state == MQTT_FIRST) ? statenames[nextstate] : ""); +#endif + mqtt->state = state; + if(state == MQTT_FIRST) + mqtt->nextstate = nextstate; +} + +static CURLcode mqtt_read_publish(struct Curl_easy *data, bool *done) +{ + CURLcode result = CURLE_OK; + struct connectdata *conn = data->conn; + size_t nread; + size_t remlen; + struct mqtt_conn *mqtt = Curl_conn_meta_get(conn, CURL_META_MQTT_CONN); + struct MQTT *mq = Curl_meta_get(data, CURL_META_MQTT_EASY); + unsigned char packet; + + DEBUGASSERT(mqtt); + if(!mqtt || !mq) + return CURLE_FAILED_INIT; + + switch(mqtt->state) { +MQTT_SUBACK_COMING: + case MQTT_SUBACK_COMING: + result = mqtt_verify_suback(data); + if(result) + break; + + mqstate(data, MQTT_FIRST, MQTT_PUBWAIT); + break; + + case MQTT_SUBACK: + case MQTT_PUBWAIT: + /* we are expecting PUBLISH or SUBACK */ + packet = mq->firstbyte & 0xf0; + if(packet == MQTT_MSG_PUBLISH) + mqstate(data, MQTT_PUB_REMAIN, MQTT_NOSTATE); + else if(packet == MQTT_MSG_SUBACK) { + mqstate(data, MQTT_SUBACK_COMING, MQTT_NOSTATE); + goto MQTT_SUBACK_COMING; + } + else if(packet == MQTT_MSG_DISCONNECT) { + infof(data, "Got DISCONNECT"); + *done = TRUE; + goto end; + } + else { + result = CURLE_WEIRD_SERVER_REPLY; + goto end; + } + + /* -- switched state -- */ + remlen = mq->remaining_length; + infof(data, "Remaining length: %zu bytes", remlen); + if(data->set.max_filesize && + (curl_off_t)remlen > data->set.max_filesize) { + failf(data, "Maximum file size exceeded"); + result = CURLE_FILESIZE_EXCEEDED; + goto end; + } + Curl_pgrsSetDownloadSize(data, remlen); + data->req.bytecount = 0; + data->req.size = remlen; + mq->npacket = remlen; /* get this many bytes */ + FALLTHROUGH(); + case MQTT_PUB_REMAIN: { + /* read rest of packet, but no more. Cap to buffer size */ + char buffer[4 * 1024]; + size_t rest = mq->npacket; + if(rest > sizeof(buffer)) + rest = sizeof(buffer); + result = Curl_xfer_recv(data, buffer, rest, &nread); + if(result) { + if(result == CURLE_AGAIN) { + infof(data, "EEEE AAAAGAIN"); + } + goto end; + } + if(!nread) { + infof(data, "server disconnected"); + result = CURLE_PARTIAL_FILE; + goto end; + } + + /* we received something */ + mq->lastTime = *Curl_pgrs_now(data); + + /* if QoS is set, message contains packet id */ + result = Curl_client_write(data, CLIENTWRITE_BODY, buffer, nread); + if(result) + goto end; + + mq->npacket -= nread; + if(!mq->npacket) + /* no more PUBLISH payload, back to subscribe wait state */ + mqstate(data, MQTT_FIRST, MQTT_PUBWAIT); + break; + } + default: + DEBUGASSERT(NULL); /* illegal state */ + result = CURLE_WEIRD_SERVER_REPLY; + goto end; + } +end: + return result; +} + +static CURLcode mqtt_do(struct Curl_easy *data, bool *done) +{ + struct MQTT *mq = Curl_meta_get(data, CURL_META_MQTT_EASY); + CURLcode result = CURLE_OK; + *done = FALSE; /* unconditionally */ + + if(!mq) + return CURLE_FAILED_INIT; + mq->lastTime = *Curl_pgrs_now(data); + mq->pingsent = FALSE; + + result = mqtt_connect(data); + if(result) { + failf(data, "Error %d sending MQTT CONNECT request", (int)result); + return result; + } + mqstate(data, MQTT_FIRST, MQTT_CONNACK); + return CURLE_OK; +} + +static CURLcode mqtt_done(struct Curl_easy *data, + CURLcode status, bool premature) +{ + struct MQTT *mq = Curl_meta_get(data, CURL_META_MQTT_EASY); + (void)status; + (void)premature; + if(mq) { + curlx_dyn_free(&mq->sendbuf); + curlx_dyn_free(&mq->recvbuf); + } + return CURLE_OK; +} + +/* we ping regularly to avoid being disconnected by the server */ +static CURLcode mqtt_ping(struct Curl_easy *data) +{ + struct MQTT *mq = Curl_meta_get(data, CURL_META_MQTT_EASY); + CURLcode result = CURLE_OK; + struct connectdata *conn = data->conn; + struct mqtt_conn *mqtt = Curl_conn_meta_get(conn, CURL_META_MQTT_CONN); + + if(!mqtt || !mq) + return CURLE_FAILED_INIT; + + if(mqtt->state == MQTT_FIRST && + !mq->pingsent && + data->set.upkeep_interval_ms > 0) { + struct curltime t = *Curl_pgrs_now(data); + timediff_t diff = curlx_ptimediff_ms(&t, &mq->lastTime); + + if(diff > data->set.upkeep_interval_ms) { + /* 0xC0 is PINGREQ, and 0x00 is remaining length */ + unsigned char packet[2] = { 0xC0, 0x00 }; + size_t packetlen = sizeof(packet); + + result = mqtt_send(data, (char *)packet, packetlen); + if(!result) { + mq->pingsent = TRUE; + } + infof(data, "mqtt_ping: sent ping request."); + } + } + return result; +} + +static CURLcode mqtt_doing(struct Curl_easy *data, bool *done) +{ + struct MQTT *mq = Curl_meta_get(data, CURL_META_MQTT_EASY); + CURLcode result = CURLE_OK; + size_t nread; + unsigned char recvbyte; + struct mqtt_conn *mqtt = Curl_conn_meta_get(data->conn, CURL_META_MQTT_CONN); + + if(!mqtt || !mq) + return CURLE_FAILED_INIT; + + *done = FALSE; + + if(curlx_dyn_len(&mq->sendbuf)) { + /* send the remainder of an outgoing packet */ + result = mqtt_send(data, curlx_dyn_ptr(&mq->sendbuf), + curlx_dyn_len(&mq->sendbuf)); + if(result) + return result; + } + + result = mqtt_ping(data); + if(result) + return result; + + infof(data, "mqtt_doing: state [%d]", (int)mqtt->state); + switch(mqtt->state) { + case MQTT_FIRST: + /* Read the initial byte only */ + result = Curl_xfer_recv(data, (char *)&mq->firstbyte, 1, &nread); + if(result) + break; + else if(!nread) { + failf(data, "Connection disconnected"); + *done = TRUE; + result = CURLE_RECV_ERROR; + break; + } + Curl_debug(data, CURLINFO_HEADER_IN, (const char *)&mq->firstbyte, 1); + + /* we received something */ + mq->lastTime = *Curl_pgrs_now(data); + + /* remember the first byte */ + mq->npacket = 0; + mqstate(data, MQTT_REMAINING_LENGTH, MQTT_NOSTATE); + FALLTHROUGH(); + case MQTT_REMAINING_LENGTH: + do { + result = Curl_xfer_recv(data, (char *)&recvbyte, 1, &nread); + if(result || !nread) + break; + Curl_debug(data, CURLINFO_HEADER_IN, (const char *)&recvbyte, 1); + mq->pkt_hd[mq->npacket++] = recvbyte; + } while((recvbyte & 0x80) && (mq->npacket < 4)); + if(!result && nread && (recvbyte & 0x80)) + /* MQTT supports up to 127 * 128^0 + 127 * 128^1 + 127 * 128^2 + + 127 * 128^3 bytes. server tried to send more */ + result = CURLE_WEIRD_SERVER_REPLY; + if(result) + break; + if(mqtt_decode_len(&mq->remaining_length, mq->pkt_hd, mq->npacket)) { + result = CURLE_WEIRD_SERVER_REPLY; + break; + } + mq->npacket = 0; + /* PINGRESP and DISCONNECT must have remaining_length == 0 and + * reserved bits (low nibble) must be zero per MQTT 3.1.1 + * sections 2.2.2, 3.13.1 and 3.14.1. Reject before state + * dispatch to prevent nextstate confusion. */ + { + const unsigned char type = mq->firstbyte & 0xF0; + const unsigned char reserved = mq->firstbyte & 0x0F; + if((type == MQTT_MSG_DISCONNECT || type == MQTT_MSG_PINGRESP) && + (mq->remaining_length || reserved)) { + failf(data, + "Broker sent malformed %s " + "(remaining_length=%zu, header byte=0x%02x)", + type == MQTT_MSG_DISCONNECT ? "DISCONNECT" : "PINGRESP", + mq->remaining_length, mq->firstbyte); + result = CURLE_WEIRD_SERVER_REPLY; + break; + } + } + if(mq->remaining_length) { + mqstate(data, mqtt->nextstate, MQTT_NOSTATE); + break; + } + mqstate(data, MQTT_FIRST, MQTT_FIRST); + + if(mq->firstbyte == MQTT_MSG_DISCONNECT) { + infof(data, "Got DISCONNECT"); + *done = TRUE; + } + + /* ping response */ + if(mq->firstbyte == MQTT_MSG_PINGRESP) { + infof(data, "Received ping response."); + mq->pingsent = FALSE; + mqstate(data, MQTT_FIRST, MQTT_PUBWAIT); + } + break; + case MQTT_CONNACK: + result = mqtt_verify_connack(data); + if(result) + break; + + if(data->state.httpreq == HTTPREQ_POST) { + result = mqtt_publish(data); + if(!result) { + result = mqtt_disconnect(data); + *done = TRUE; + } + mqtt->nextstate = MQTT_FIRST; + } + else { + result = mqtt_subscribe(data); + if(!result) { + mqstate(data, MQTT_FIRST, MQTT_SUBACK); + } + } + break; + + case MQTT_SUBACK: + case MQTT_PUBWAIT: + case MQTT_PUB_REMAIN: + result = mqtt_read_publish(data, done); + break; + + default: + failf(data, "State not handled yet"); + *done = TRUE; + break; + } + + if(result == CURLE_AGAIN) + result = CURLE_OK; + return result; +} + +#ifdef USE_SSL + +static CURLcode mqtts_connecting(struct Curl_easy *data, bool *done) +{ + struct connectdata *conn = data->conn; + CURLcode result; + + result = Curl_conn_connect(data, FIRSTSOCKET, TRUE, done); + if(result) + connclose(conn, "Failed TLS connection"); + return result; +} + +/* + * MQTTS protocol. + */ +const struct Curl_protocol Curl_protocol_mqtts = { + mqtt_setup_conn, /* setup_connection */ + mqtt_do, /* do_it */ + mqtt_done, /* done */ + ZERO_NULL, /* do_more */ + ZERO_NULL, /* connect_it */ + mqtts_connecting, /* connecting */ + mqtt_doing, /* doing */ + ZERO_NULL, /* proto_pollset */ + mqtt_pollset, /* doing_pollset */ + ZERO_NULL, /* domore_pollset */ + ZERO_NULL, /* perform_pollset */ + ZERO_NULL, /* disconnect */ + ZERO_NULL, /* write_resp */ + ZERO_NULL, /* write_resp_hd */ + ZERO_NULL, /* connection_is_dead */ + ZERO_NULL, /* attach connection */ + ZERO_NULL, /* follow */ +}; + +#endif + +/* + * MQTT protocol. + */ +const struct Curl_protocol Curl_protocol_mqtt = { + mqtt_setup_conn, /* setup_connection */ + mqtt_do, /* do_it */ + mqtt_done, /* done */ + ZERO_NULL, /* do_more */ + ZERO_NULL, /* connect_it */ + ZERO_NULL, /* connecting */ + mqtt_doing, /* doing */ + ZERO_NULL, /* proto_pollset */ + mqtt_pollset, /* doing_pollset */ + ZERO_NULL, /* domore_pollset */ + ZERO_NULL, /* perform_pollset */ + ZERO_NULL, /* disconnect */ + ZERO_NULL, /* write_resp */ + ZERO_NULL, /* write_resp_hd */ + ZERO_NULL, /* connection_is_dead */ + ZERO_NULL, /* attach connection */ + ZERO_NULL, /* follow */ +}; + +#endif /* CURL_DISABLE_MQTT */ diff --git a/3rdparty/curl-8.21.0/lib/mqtt.h b/3rdparty/curl-8.21.0/lib/mqtt.h new file mode 100644 index 0000000000..3d95293f12 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/mqtt.h @@ -0,0 +1,33 @@ +#ifndef HEADER_CURL_MQTT_H +#define HEADER_CURL_MQTT_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Björn Stenberg, + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#ifndef CURL_DISABLE_MQTT +extern const struct Curl_protocol Curl_protocol_mqtt; +#ifdef USE_SSL +extern const struct Curl_protocol Curl_protocol_mqtts; +#endif +#endif + +#endif /* HEADER_CURL_MQTT_H */ diff --git a/3rdparty/curl-8.21.0/lib/multi.c b/3rdparty/curl-8.21.0/lib/multi.c new file mode 100644 index 0000000000..d6ae111d8e --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/multi.c @@ -0,0 +1,4242 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "urldata.h" +#include "transfer.h" +#include "url.h" +#include "cfilters.h" +#include "connect.h" +#include "progress.h" +#include "curl_share.h" +#include "psl.h" +#include "multiif.h" +#include "multi_ev.h" +#include "sendf.h" +#include "curl_trc.h" +#include "http.h" +#include "select.h" +#include "curlx/wait.h" +#include "conncache.h" +#include "multihandle.h" +#include "sigpipe.h" +#include "vtls/vtls.h" +#include "vtls/vtls_scache.h" +#include "http_proxy.h" +#include "http2.h" +#include "socketpair.h" +#include "bufref.h" + +/* initial multi->xfers table size for a full multi */ +#define CURL_XFER_TABLE_SIZE 512 + +/* + CURL_SOCKET_HASH_TABLE_SIZE should be a prime number. Increasing it from 97 + to 911 takes on a 32-bit machine 4 x 804 = 3211 more bytes. Still, every + curl handle takes 6K memory, therefore this 3K are not significant. +*/ +#ifndef CURL_SOCKET_HASH_TABLE_SIZE +#define CURL_SOCKET_HASH_TABLE_SIZE 911 +#endif + +#ifndef CURL_CONNECTION_HASH_SIZE +#define CURL_CONNECTION_HASH_SIZE 97 +#endif + +#ifndef CURL_DNS_HASH_SIZE +#define CURL_DNS_HASH_SIZE 71 +#endif + +#ifndef CURL_TLS_SESSION_SIZE +#define CURL_TLS_SESSION_SIZE 25 +#endif + +#define CURL_MULTI_HANDLE 0x000bab1e + +#ifdef DEBUGBUILD +/* On a debug build, we want to fail hard on multi handles that + * are not NULL, but no longer have the MAGIC touch. This gives + * us early warning on things only discovered by valgrind otherwise. */ +#define GOOD_MULTI_HANDLE(x) \ + (((x) && (x)->magic == CURL_MULTI_HANDLE) ? TRUE : \ + (DEBUGASSERT(!(x)), FALSE)) +#else +#define GOOD_MULTI_HANDLE(x) \ + ((x) && (x)->magic == CURL_MULTI_HANDLE) +#endif + +static void move_pending_to_connect(struct Curl_multi *multi, + struct Curl_easy *data); +static CURLMcode add_next_timeout(const struct curltime *pnow, + struct Curl_multi *multi, + struct Curl_easy *d); +static void multi_timeout(struct Curl_multi *multi, + struct curltime *expire_time, + long *timeout_ms); +static void process_pending_handles(struct Curl_multi *multi); +static void multi_xfer_bufs_free(struct Curl_multi *multi); +#ifdef DEBUGBUILD +static void multi_xfer_tbl_dump(struct Curl_multi *multi); +#endif + +static const struct curltime *multi_now(struct Curl_multi *multi) +{ + curlx_pnow(&multi->now); + return &multi->now; +} + +/* function pointer called once when entering a state */ +typedef void (*mstate_enter_func)(struct Curl_easy *data, + CURLMstate from_state); + +static void mstate_enter_connect(struct Curl_easy *data, + CURLMstate from_state) +{ + (void)from_state; + Curl_init_CONNECT(data); +} + +static void mstate_enter_did(struct Curl_easy *data, + CURLMstate from_state) +{ + (void)from_state; + data->req.chunk = FALSE; + Curl_pgrsTime(data, TIMER_PRETRANSFER); + if(!CURL_REQ_WANT_SEND(data)) + Curl_pgrsTime(data, TIMER_POSTRANSFER); +} + +static void mstate_enter_done(struct Curl_easy *data, + CURLMstate from_state) +{ + (void)from_state; + CURLM_NTFY(data, CURLMNOTIFY_EASY_DONE); +} + +static void mstate_enter_completed(struct Curl_easy *data, + CURLMstate from_state) +{ + /* we sometimes directly jump to COMPLETED, trigger things + * we then missed. */ + if(from_state < MSTATE_DID) { + Curl_pgrsTime(data, TIMER_PRETRANSFER); + Curl_pgrsTime(data, TIMER_POSTRANSFER); + Curl_pgrsTime(data, TIMER_STARTTRANSFER); + } + Curl_pgrsCompleted(data); + if(from_state < MSTATE_DONE) + CURLM_NTFY(data, CURLMNOTIFY_EASY_DONE); + /* changing to COMPLETED means it is in process and needs to go */ + DEBUGASSERT(Curl_uint32_bset_contains(&data->multi->process, data->mid)); + Curl_uint32_bset_remove(&data->multi->process, data->mid); + Curl_uint32_bset_remove(&data->multi->pending, data->mid); /* to be sure */ + + if(Curl_uint32_bset_empty(&data->multi->process)) { + /* free the transfer buffer when we have no more active transfers */ + multi_xfer_bufs_free(data->multi); + } + /* Important: reset the conn pointer so that we do not point to memory + that could be freed anytime */ + Curl_detach_connection(data); + Curl_expire_clear(data); /* stop all timers */ +} + +/* always use this function to change state, to make debugging easier */ +static void mstate(struct Curl_easy *data, CURLMstate state +#ifdef DEBUGBUILD + , int lineno +#endif +) +{ + CURLMstate oldstate = data->mstate; + static const mstate_enter_func state_enter[MSTATE_LAST] = { + NULL, /* INIT */ + NULL, /* PENDING */ + NULL, /* SETUP */ + mstate_enter_connect, /* CONNECT */ + NULL, /* CONNECTING */ + NULL, /* PROTOCONNECT */ + NULL, /* PROTOCONNECTING */ + NULL, /* DO */ + NULL, /* DOING */ + NULL, /* DOING_MORE */ + mstate_enter_did, /* DID */ + NULL, /* PERFORMING */ + NULL, /* RATELIMITING */ + mstate_enter_done, /* DONE */ + mstate_enter_completed, /* COMPLETED */ + NULL /* MSGSENT */ + }; + + if(oldstate == state) + /* do not bother when the new state is the same as the old state */ + return; + +#ifdef DEBUGBUILD + NOVERBOSE((void)lineno); + CURL_TRC_M(data, "-> [%s] (line %d)", CURL_MSTATE_NAME(state), lineno); +#else + CURL_TRC_M(data, "-> [%s]", CURL_MSTATE_NAME(state)); +#endif + + /* really switching state */ + data->mstate = state; + if(state_enter[state]) + state_enter[state](data, oldstate); +} + +#ifndef DEBUGBUILD +#define multistate(x, y) mstate(x, y) +#else +#define multistate(x, y) mstate(x, y, __LINE__) +#endif + +/* multi->proto_hash destructor. Should never be called as elements + * MUST be added with their own destructor */ +static void ph_freeentry(void *p) +{ + (void)p; + /* Always FALSE. Cannot use a 0 assert here since compilers + * are not in agreement if they then want a NORETURN attribute or + * not. *sigh* */ + DEBUGASSERT(!p); +} + +/* + * multi_addmsg() + * + * Called when a transfer is completed. Adds the given msg pointer to + * the list kept in the multi handle. + */ +static void multi_addmsg(struct Curl_multi *multi, struct Curl_message *msg) +{ + if(!Curl_llist_count(&multi->msglist)) + CURLM_NTFY(multi->admin, CURLMNOTIFY_INFO_READ); + Curl_llist_append(&multi->msglist, msg, &msg->list); +} + +struct Curl_multi *Curl_multi_handle(uint32_t xfer_table_size, + size_t ev_hashsize, /* event hash */ + size_t chashsize, /* connection hash */ + size_t dnssize, /* dns hash */ + size_t sesssize) /* TLS session cache */ +{ + struct Curl_multi *multi = curlx_calloc(1, sizeof(struct Curl_multi)); + + if(!multi) + return NULL; + + multi->magic = CURL_MULTI_HANDLE; + + Curl_dnscache_init(&multi->dnscache, dnssize); + Curl_mntfy_init(multi); + Curl_multi_ev_init(multi, ev_hashsize); + Curl_uint32_tbl_init(&multi->xfers, NULL); + Curl_uint32_bset_init(&multi->process); + Curl_uint32_bset_init(&multi->dirty); + Curl_uint32_bset_init(&multi->pending); + Curl_uint32_bset_init(&multi->msgsent); + Curl_hash_init(&multi->proto_hash, 23, + Curl_hash_str, curlx_str_key_compare, ph_freeentry); + Curl_llist_init(&multi->msglist, NULL); + + multi->multiplexing = TRUE; + multi->max_concurrent_streams = 100; + multi->last_timeout_ms = -1; +#ifdef ENABLE_WAKEUP + multi->wakeup_pair[0] = CURL_SOCKET_BAD; + multi->wakeup_pair[1] = CURL_SOCKET_BAD; +#endif + + if(Curl_mntfy_resize(multi) || + Curl_uint32_bset_resize(&multi->process, xfer_table_size) || + Curl_uint32_bset_resize(&multi->pending, xfer_table_size) || + Curl_uint32_bset_resize(&multi->dirty, xfer_table_size) || + Curl_uint32_bset_resize(&multi->msgsent, xfer_table_size) || + Curl_uint32_tbl_resize(&multi->xfers, xfer_table_size)) + goto error; + + multi->admin = curl_easy_init(); + if(!multi->admin) + goto error; + /* Initialize admin handle to operate inside this multi */ + multi->admin->multi = multi; + multi->admin->state.internal = TRUE; + Curl_llist_init(&multi->admin->state.timeoutlist, NULL); + +#ifdef DEBUGBUILD + if(getenv("CURL_DEBUG")) + multi->admin->set.verbose = TRUE; +#endif + Curl_uint32_tbl_add(&multi->xfers, multi->admin, &multi->admin->mid); + Curl_uint32_bset_add(&multi->process, multi->admin->mid); + + if(Curl_cshutdn_init(&multi->cshutdn, multi)) + goto error; + + Curl_cpool_init(&multi->cpool, multi->admin, NULL, chashsize); + +#ifdef USE_SSL + if(Curl_ssl_scache_create(sesssize, 2, &multi->ssl_scache)) + goto error; +#else + (void)sesssize; +#endif + +#ifdef USE_WINSOCK + multi->wsa_event = WSACreateEvent(); + if(multi->wsa_event == WSA_INVALID_EVENT) + goto error; +#endif +#ifdef ENABLE_WAKEUP + /* When enabled, rely on this to work. We ignore this in previous + * versions, but that seems an unnecessary complication. */ + if(Curl_wakeup_init(multi->wakeup_pair, TRUE) < 0) + goto error; +#endif + + if(Curl_probeipv6(multi)) + goto error; + +#ifdef USE_RESOLV_THREADED + if(xfer_table_size < CURL_XFER_TABLE_SIZE) { /* easy multi */ + if(Curl_async_thrdd_multi_init(multi, 0, 2, 10)) + goto error; + } + else { /* real multi handle */ + if(Curl_async_thrdd_multi_init(multi, 0, 20, 2000)) + goto error; + } +#endif + + return multi; + +error: + +#ifdef USE_RESOLV_THREADED + Curl_async_thrdd_multi_destroy(multi, TRUE); +#endif + Curl_multi_ev_cleanup(multi); + Curl_hash_destroy(&multi->proto_hash); + Curl_dnscache_destroy(&multi->dnscache); + Curl_cpool_destroy(&multi->cpool); + Curl_cshutdn_destroy(&multi->cshutdn, multi->admin); +#ifdef USE_SSL + Curl_ssl_scache_destroy(multi->ssl_scache); +#endif + if(multi->admin) { + Curl_multi_ev_xfer_done(multi, multi->admin); + multi->admin->multi = NULL; + Curl_close(&multi->admin); + } + Curl_mntfy_cleanup(multi); + + Curl_uint32_bset_destroy(&multi->process); + Curl_uint32_bset_destroy(&multi->dirty); + Curl_uint32_bset_destroy(&multi->pending); + Curl_uint32_bset_destroy(&multi->msgsent); + Curl_uint32_tbl_destroy(&multi->xfers); +#ifdef ENABLE_WAKEUP + Curl_wakeup_destroy(multi->wakeup_pair); +#endif + + curlx_free(multi); + return NULL; +} + +CURLM *curl_multi_init(void) +{ + return Curl_multi_handle(CURL_XFER_TABLE_SIZE, + CURL_SOCKET_HASH_TABLE_SIZE, + CURL_CONNECTION_HASH_SIZE, + CURL_DNS_HASH_SIZE, + CURL_TLS_SESSION_SIZE); +} + +#if defined(DEBUGBUILD) && defined(CURLVERBOSE) +static void multi_warn_debug(struct Curl_multi *multi, struct Curl_easy *data) +{ + if(!multi->warned) { + infof(data, "!!! WARNING !!!"); + infof(data, "This is a debug build of libcurl, " + "do not use in production."); + multi->warned = TRUE; + } +} +#else +#define multi_warn_debug(x, y) Curl_nop_stmt +#endif + +bool Curl_is_connecting(struct Curl_easy *data) +{ + return data->mstate < MSTATE_DO; +} + +static CURLMcode multi_assess_wakeup(struct Curl_multi *multi) +{ +#ifdef ENABLE_WAKEUP + if(multi->socket_cb) + return Curl_multi_ev_assess_xfer(multi, multi->admin); +#else + (void)multi; +#endif + return CURLM_OK; +} + +static CURLMcode multi_xfers_add(struct Curl_multi *multi, + struct Curl_easy *data) +{ + uint32_t capacity = Curl_uint32_tbl_capacity(&multi->xfers); + uint32_t new_size = 0; + /* Prepare to make this into a CURLMOPT_MAX_TRANSFERS, because some + * applications may want to prevent a run-away of their memory use. */ + /* UINT_MAX is our "invalid" id, do not let the table grow up to that. */ + const uint32_t max_capacity = UINT_MAX - 1; + + if(capacity < max_capacity) { + /* We want `multi->xfers` to have "sufficient" free rows, so that we do + * not have to reuse the `mid` from a removed easy right away. + * Since uint_tbl and uint_bset are memory efficient, + * regard less than 25% free as insufficient. + * (for low capacities, e.g. multi_easy, 4 or less). */ + uint32_t used = Curl_uint32_tbl_count(&multi->xfers); + uint32_t unused = capacity - used; + uint32_t min_unused = CURLMAX(capacity >> 2, 4); + if(unused <= min_unused) { + /* Make sure the uint arithmetic here works on the corner + * cases where we are close to max_capacity or UINT_MAX */ + if((min_unused >= max_capacity) || + ((max_capacity - min_unused) <= capacity) || + ((UINT_MAX - min_unused - 63) <= capacity)) { + new_size = max_capacity; /* can not be larger than this */ + } + else { + /* make it a 64 multiple, since our bitsets grow by that and + * small (easy_multi) grows to at least 64 on first resize. */ + new_size = (((used + min_unused) + 63) / 64) * 64; + } + } + } + + if(new_size > capacity) { + /* Grow the bitsets first. Should one fail, we do not need + * to downsize the already resized ones. The sets continue + * to work properly when larger than the table, but not + * the other way around. */ + CURL_TRC_M(data, "increasing xfer table size to %u", new_size); + if(Curl_uint32_bset_resize(&multi->process, new_size) || + Curl_uint32_bset_resize(&multi->dirty, new_size) || + Curl_uint32_bset_resize(&multi->pending, new_size) || + Curl_uint32_bset_resize(&multi->msgsent, new_size) || + Curl_uint32_tbl_resize(&multi->xfers, new_size)) + return CURLM_OUT_OF_MEMORY; + } + + /* Insert the easy into the table now */ + if(!Curl_uint32_tbl_add(&multi->xfers, data, &data->mid)) { + /* MUST only happen when table is full */ + DEBUGASSERT(Curl_uint32_tbl_capacity(&multi->xfers) <= + Curl_uint32_tbl_count(&multi->xfers)); + return CURLM_OUT_OF_MEMORY; + } + return CURLM_OK; +} + +CURLMcode curl_multi_add_handle(CURLM *m, CURL *curl) +{ + CURLMcode mresult; + struct Curl_multi *multi = m; + struct Curl_easy *data = curl; + + /* First, make some basic checks that the CURLM handle is a good handle */ + if(!GOOD_MULTI_HANDLE(multi)) + return CURLM_BAD_HANDLE; + + /* Verify that we got a somewhat good easy handle too */ + if(!GOOD_EASY_HANDLE(data)) + return CURLM_BAD_EASY_HANDLE; + + /* Prevent users from adding same easy handle more than once and prevent + adding to more than one multi stack */ + if(data->multi) + return CURLM_ADDED_ALREADY; + + if(multi->in_callback) + return CURLM_RECURSIVE_API_CALL; + + if(multi->dead) { + /* a "dead" handle cannot get added transfers while any existing easy + handles are still alive - but if there are none alive anymore, it is + fine to start over and unmark the "deadness" of this handle. + This means only the admin handle MUST be present. */ + if((Curl_uint32_tbl_count(&multi->xfers) != 1) || + !Curl_uint32_tbl_contains(&multi->xfers, 0)) + return CURLM_ABORTED_BY_CALLBACK; + multi->dead = FALSE; + Curl_uint32_bset_clear(&multi->process); + Curl_uint32_bset_clear(&multi->dirty); + Curl_uint32_bset_clear(&multi->pending); + Curl_uint32_bset_clear(&multi->msgsent); + } + + if(data->multi_easy) { + /* if this easy handle was previously used for curl_easy_perform(), there + is a private multi handle here that we can kill */ + curl_multi_cleanup(data->multi_easy); + data->multi_easy = NULL; + } + + /* Insert the easy into the multi->xfers table, assigning it a `mid`. */ + if(multi_xfers_add(multi, data)) + return CURLM_OUT_OF_MEMORY; + + /* Initialize timeout list for this handle */ + Curl_llist_init(&data->state.timeoutlist, NULL); + + /* + * No failure allowed in this function beyond this point. No modification of + * easy nor multi handle allowed before this except for potential multi's + * connection pool growing which will not be undone in this function no + * matter what. + */ + if(data->set.errorbuffer) + data->set.errorbuffer[0] = 0; + + data->state.os_errno = 0; + + /* make the Curl_easy refer back to this multi handle - before Curl_expire() + is called. */ + data->multi = multi; + + /* set the easy handle */ + multistate(data, MSTATE_INIT); + /* not yet passed INIT state */ + data->state.really_alive = FALSE; + +#ifdef USE_LIBPSL + /* Do the same for PSL. */ + if(data->share && (data->share->specifier & (1 << CURL_LOCK_DATA_PSL))) + data->psl = &data->share->psl; + else + data->psl = &multi->psl; +#endif + + /* add the easy handle to the process set */ + Curl_uint32_bset_add(&multi->process, data->mid); + ++multi->xfers_alive; + ++multi->xfers_total_ever; + + Curl_cpool_xfer_init(data); + multi_warn_debug(multi, data); + + /* Make sure the new handle will run */ + Curl_multi_mark_dirty(data); + + /* Necessary in event based processing, where dirty handles trigger + * a timeout callback invocation. */ + mresult = Curl_update_timer(multi); + if(mresult) { + data->multi = NULL; /* not anymore */ + Curl_uint32_tbl_remove(&multi->xfers, data->mid); + data->mid = UINT32_MAX; + return mresult; + } + + /* The admin handle only ever has default timeouts set. To improve the + state somewhat we clone the timeouts from each added handle so that the + admin handle always has the same timeouts as the most recently added + easy handle. */ + multi->admin->set.timeout = data->set.timeout; + multi->admin->set.server_response_timeout = + data->set.server_response_timeout; + multi->admin->set.no_signal = data->set.no_signal; + + CURL_TRC_M(data, "added to multi, mid=%u, running=%u, total=%u", + data->mid, Curl_multi_xfers_running(multi), + Curl_uint32_tbl_count(&multi->xfers)); + return CURLM_OK; +} + +#if 0 +/* Debug-function, used like this: + * + * Curl_hash_print(&multi->sockhash, debug_print_sock_hash); + * + * Enable the hash print function first by editing hash.c + */ +static void debug_print_sock_hash(void *p) +{ + struct Curl_sh_entry *sh = (struct Curl_sh_entry *)p; + + curl_mfprintf(stderr, " [readers %u][writers %u]", + sh->readers, sh->writers); +} +#endif + +struct multi_done_ctx { + BIT(premature); +}; + +static bool multi_conn_should_close(struct connectdata *conn, + struct Curl_easy *data, + bool premature) +{ + /* if conn->bits.close is TRUE, it means that the connection should be + closed in spite of everything else. */ + if(conn->bits.close) + return TRUE; + + /* if data->set.reuse_forbid is TRUE, it means the libcurl client has + forced us to close this connection. This is ignored for requests taking + place in a NTLM/NEGOTIATE authentication handshake. */ + if(data->set.reuse_forbid +#ifdef USE_NTLM + && !(conn->http_ntlm_state == NTLMSTATE_TYPE2 || + conn->proxy_ntlm_state == NTLMSTATE_TYPE2) +#endif +#ifdef USE_SPNEGO + && !(conn->http_negotiate_state == GSS_AUTHRECV || + conn->proxy_negotiate_state == GSS_AUTHRECV) +#endif + ) + return TRUE; + + /* Unless this connection is for a "connect-only" transfer, it + * needs to be closed if the protocol handler does not support reuse. */ + if(!data->set.connect_only && conn->scheme && + !(conn->scheme->flags & PROTOPT_CONN_REUSE)) + return TRUE; + + /* if premature is TRUE, it means this connection was said to be DONE before + the entire request operation is complete and thus we cannot know in what + state it is for reusing, so we are forced to close it. In a perfect world + we can add code that keep track of if we really must close it here or not, + but currently we have no such detail knowledge. */ + if(premature && !Curl_conn_is_multiplex(conn, FIRSTSOCKET)) + return TRUE; + + return FALSE; +} + +static void multi_done_locked(struct connectdata *conn, + struct Curl_easy *data, + void *userdata) +{ + struct multi_done_ctx *mdctx = userdata; + + Curl_detach_connection(data); + + CURL_TRC_M(data, "multi_done_locked, in use=%u", conn->attached_xfers); + if(CONN_INUSE(conn)) { + /* Stop if still used. */ + CURL_TRC_M(data, "Connection still in use %u, no more multi_done now!", + conn->attached_xfers); + return; + } + + data->state.done = TRUE; /* called now! */ + data->state.recent_conn_id = conn->connection_id; + + Curl_dnscache_prune(data); + + if(multi_conn_should_close(conn, data, (bool)mdctx->premature)) { + CURL_TRC_M(data, "multi_done, terminating conn #%" FMT_OFF_T " to %s, " + "forbid=%d, close=%d, premature=%d, conn_multiplex=%d", + conn->connection_id, conn->destination, + data->set.reuse_forbid, conn->bits.close, mdctx->premature, + Curl_conn_is_multiplex(conn, FIRSTSOCKET)); + connclose(conn, "disconnecting"); + Curl_conn_terminate(data, conn, (bool)mdctx->premature); + } + else if(!Curl_conn_get_max_concurrent(data, conn, FIRSTSOCKET)) { + CURL_TRC_M(data, "multi_done, conn #%" FMT_OFF_T " to %s was shutdown" + " by server, not reusing", conn->connection_id, + conn->destination); + connclose(conn, "server shutdown"); + Curl_conn_terminate(data, conn, (bool)mdctx->premature); + } + else { + /* the connection is no longer in use by any transfer */ + if(Curl_cpool_conn_now_idle(data, conn)) { + /* connection kept in the cpool */ + data->state.lastconnect_id = conn->connection_id; + infof(data, "Connection #%" FMT_OFF_T " to host %s left intact", + conn->connection_id, conn->destination); + } + else { + /* connection was removed from the cpool and destroyed. */ + data->state.lastconnect_id = -1; + } + } +} + +static CURLcode multi_done(struct Curl_easy *data, + CURLcode status, /* an error if this is called + after an error was detected */ + bool premature) +{ + CURLcode result; + struct connectdata *conn = data->conn; + + CURL_TRC_M(data, "multi_done: status: %d prem: %d done: %d", + (int)status, (int)premature, data->state.done); + + if(data->state.done) + /* Stop if multi_done() has already been called */ + return CURLE_OK; + + /* Shut down any ongoing async resolver operation. */ + Curl_resolv_shutdown_all(data); + + /* Cleanup possible redirect junk */ + curlx_safefree(data->req.newurl); + curlx_safefree(data->req.location); + + switch(status) { + case CURLE_ABORTED_BY_CALLBACK: + case CURLE_READ_ERROR: + case CURLE_WRITE_ERROR: + /* When we are aborted due to a callback return code it has to be counted + as premature as there is trouble ahead if we do not. We have many + callbacks and protocols work differently, we could potentially do this + more fine-grained in the future. */ + premature = TRUE; + FALLTHROUGH(); + default: + break; + } + + /* this calls the protocol-specific function pointer previously set */ + if(conn && conn->scheme->run->done && (data->mstate >= MSTATE_PROTOCONNECT)) + result = conn->scheme->run->done(data, status, premature); + else + result = status; + + if(data->mstate > MSTATE_CONNECTING && + (result != CURLE_ABORTED_BY_CALLBACK)) { + /* avoid this if + * - the transfer has not connected + * - we already aborted by callback to avoid this calling another callback + */ + int rc = Curl_pgrsDone(data); + if(!result && rc) + result = CURLE_ABORTED_BY_CALLBACK; + } + + /* Make sure that transfer client writes are really done now. */ + result = Curl_1st_fatal(result, Curl_xfer_write_done(data, premature)); + + /* Inform connection filters that this transfer is done */ + if(conn) + Curl_conn_ev_data_done(data, premature); + + process_pending_handles(data->multi); /* connection / multiplex */ + + if(!result) + result = Curl_req_done(&data->req, data, premature); + + if(conn) { + /* Under the potential connection pool's share lock, decide what to + * do with the transfer's connection. */ + struct multi_done_ctx mdctx; + + memset(&mdctx, 0, sizeof(mdctx)); + mdctx.premature = premature; + Curl_cpool_do_locked(data, data->conn, multi_done_locked, &mdctx); + } + + /* flush the netrc cache */ + Curl_netrc_cleanup(&data->state.netrc); + return result; +} + +static void close_connect_only(struct connectdata *conn, + struct Curl_easy *data, + void *userdata) +{ + (void)userdata; + (void)data; + if(conn->bits.connect_only) + connclose(conn, "Removing connect-only easy handle"); +} + +CURLMcode curl_multi_remove_handle(CURLM *m, CURL *curl) +{ + struct Curl_multi *multi = m; + struct Curl_easy *data = curl; + bool premature; + struct Curl_llist_node *e; + CURLMcode mresult; + uint32_t mid; + + /* First, make some basic checks that the CURLM handle is a good handle */ + if(!GOOD_MULTI_HANDLE(multi)) + return CURLM_BAD_HANDLE; + + /* Verify that we got a somewhat good easy handle too */ + if(!GOOD_EASY_HANDLE(data)) + return CURLM_BAD_EASY_HANDLE; + + /* Prevent users from trying to remove same easy handle more than once */ + if(!data->multi) + return CURLM_OK; /* it is already removed so let's say it is fine! */ + + /* Prevent users from trying to remove an easy handle from the wrong multi */ + if(data->multi != multi) + return CURLM_BAD_EASY_HANDLE; + + if(data->mid == UINT32_MAX) { + DEBUGASSERT(0); + return CURLM_INTERNAL_ERROR; + } + if(Curl_uint32_tbl_get(&multi->xfers, data->mid) != data) { + DEBUGASSERT(0); + return CURLM_INTERNAL_ERROR; + } + + if(multi->in_callback) + return CURLM_RECURSIVE_API_CALL; + + premature = (data->mstate < MSTATE_COMPLETED); + + /* If the 'state' is not INIT or COMPLETED, we might need to do something + nice to put the easy_handle in a good known state when this returns. */ + if(data->conn && + data->mstate > MSTATE_DO && + data->mstate < MSTATE_COMPLETED) { + /* Set connection owner so that the DONE function closes it. We can + safely do this here since connection is killed. */ + streamclose(data->conn, "Removed with partial response"); + } + + if(data->conn) { + /* multi_done() clears the association between the easy handle and the + connection. + + Note that this ignores the return code because there is + nothing really useful to do with it anyway! */ + (void)multi_done(data, data->result, premature); + } + + /* The timer must be shut down before data->multi is set to NULL, else the + timenode will remain in the splay tree after curl_easy_cleanup is + called. Do it after multi_done() in case that sets another time! */ + Curl_expire_clear(data); + + /* If in `msgsent`, it was deducted from `multi->xfers_alive` already. */ + if(!Curl_uint32_bset_contains(&multi->msgsent, data->mid)) + --multi->xfers_alive; + if(data->state.really_alive) { + data->state.really_alive = FALSE; + --multi->xfers_really_alive; + if(!multi->xfers_really_alive) + (void)multi_assess_wakeup(multi); + } + + Curl_wildcard_dtor(&data->wildcard); + + data->mstate = MSTATE_COMPLETED; + + /* Remove the association between the connection and the handle */ + Curl_detach_connection(data); + + /* Tell event handling that this transfer is definitely going away */ + Curl_multi_ev_xfer_done(multi, data); + + if(data->set.connect_only && !data->multi_easy) { + /* This removes a handle that was part the multi interface that used + CONNECT_ONLY, that connection is now left alive but since this handle + has bits.close set nothing can use that transfer anymore and it is + forbidden from reuse. This easy handle cannot find the connection + anymore once removed from the multi handle + + Better close the connection here, at once. + */ + struct connectdata *c; + curl_socket_t s; + s = Curl_getconnectinfo(data, &c); + if((s != CURL_SOCKET_BAD) && c) { + Curl_conn_terminate(data, c, TRUE); + } + } + + if(data->state.lastconnect_id != -1) { + /* Mark any connect-only connection for closure */ + Curl_cpool_do_by_id(data, data->state.lastconnect_id, + close_connect_only, NULL); + } + +#ifdef USE_LIBPSL + /* Remove the PSL association. */ + if(data->psl == &multi->psl) + data->psl = NULL; +#endif + + /* make sure there is no pending message in the queue sent from this easy + handle */ + for(e = Curl_llist_head(&multi->msglist); e; e = Curl_node_next(e)) { + struct Curl_message *msg = Curl_node_elem(e); + + if(msg->extmsg.easy_handle == data) { + Curl_node_remove(e); + /* there can only be one from this specific handle */ + break; + } + } + + /* clear the association to this multi handle */ + mid = data->mid; + DEBUGASSERT(Curl_uint32_tbl_contains(&multi->xfers, mid)); + Curl_uint32_tbl_remove(&multi->xfers, mid); + Curl_uint32_bset_remove(&multi->process, mid); + Curl_uint32_bset_remove(&multi->dirty, mid); + Curl_uint32_bset_remove(&multi->pending, mid); + Curl_uint32_bset_remove(&multi->msgsent, mid); + data->multi = NULL; + data->mid = UINT32_MAX; + data->master_mid = UINT32_MAX; + + /* NOTE NOTE NOTE + We do not touch the easy handle here! */ + process_pending_handles(multi); + + mresult = Curl_update_timer(multi); + if(mresult) + return mresult; + + mresult = multi_assess_wakeup(multi); + if(mresult) { + failf(data, "error enabling wakeup listening: %d", mresult); + return mresult; + } + + CURL_TRC_M(data, "removed from multi, mid=%u, running=%u, total=%u", + mid, Curl_multi_xfers_running(multi), + Curl_uint32_tbl_count(&multi->xfers)); + return CURLM_OK; +} + +/* Return TRUE if the application asked for multiplexing */ +bool Curl_multiplex_wanted(const struct Curl_multi *multi) +{ + return multi && multi->multiplexing; +} + +/* + * Curl_detach_connection() removes the given transfer from the connection. + * + * This is the only function that should clear data->conn. This will + * occasionally be called with the data->conn pointer already cleared. + */ +void Curl_detach_connection(struct Curl_easy *data) +{ + struct connectdata *conn = data->conn; + if(conn) { + /* this should never happen, prevent underflow */ + DEBUGASSERT(conn->attached_xfers); + if(conn->attached_xfers) { + conn->attached_xfers--; + if(!conn->attached_xfers) + conn->attached_multi = NULL; + } + } + data->conn = NULL; +} + +/* + * Curl_attach_connection() attaches this transfer to this connection. + * + * This is the only function that should assign data->conn + */ +void Curl_attach_connection(struct Curl_easy *data, + struct connectdata *conn) +{ + DEBUGASSERT(data); + DEBUGASSERT(!data->conn); + DEBUGASSERT(conn); + DEBUGASSERT(conn->attached_xfers < UINT32_MAX); + data->conn = conn; + conn->attached_xfers++; + /* all attached transfers must be from the same multi */ + if(!conn->attached_multi) + conn->attached_multi = data->multi; + DEBUGASSERT(conn->attached_multi == data->multi); + + if(conn->scheme && conn->scheme->run->attach) + conn->scheme->run->attach(data, conn); +} + +/* adjust pollset for rate limits/pauses */ +static CURLcode multi_adjust_pollset(struct Curl_easy *data, + struct easy_pollset *ps) +{ + CURLcode result = CURLE_OK; + + if(ps->n) { + const struct curltime *pnow = Curl_pgrs_now(data); + bool send_blocked, recv_blocked; + + recv_blocked = (Curl_rlimit_avail(&data->progress.dl.rlimit, pnow) <= 0); + send_blocked = (Curl_rlimit_avail(&data->progress.ul.rlimit, pnow) <= 0); + if(send_blocked || recv_blocked) { + int i; + for(i = 0; i <= SECONDARYSOCKET; ++i) { + curl_socket_t sock = data->conn->sock[i]; + if(sock == CURL_SOCKET_BAD) + continue; + if(recv_blocked && Curl_pollset_want_recv(data, ps, sock)) { + result = Curl_pollset_remove_in(data, ps, sock); + if(result) + break; + } + if(send_blocked && Curl_pollset_want_send(data, ps, sock)) { + result = Curl_pollset_remove_out(data, ps, sock); + if(result) + break; + } + } + } + + /* Not blocked and wanting to receive. If there is data pending + * in the connection filters, make transfer run again. */ + if(!recv_blocked && + ((Curl_pollset_want_recv(data, ps, data->conn->sock[FIRSTSOCKET]) && + Curl_conn_data_pending(data, FIRSTSOCKET)) || + (Curl_pollset_want_recv(data, ps, data->conn->sock[SECONDARYSOCKET]) && + Curl_conn_data_pending(data, SECONDARYSOCKET)))) { + CURL_TRC_M(data, "pollset[] has POLLIN, but there is still " + "buffered input -> mark as dirty"); + Curl_multi_mark_dirty(data); + } + } + return result; +} + +static CURLcode mstate_connecting_pollset(struct Curl_easy *data, + struct easy_pollset *ps) +{ + struct connectdata *conn = data->conn; + curl_socket_t sockfd; + CURLcode result = CURLE_OK; + + if(Curl_xfer_recv_is_paused(data)) + return CURLE_OK; + /* If a socket is set, receiving is default. If the socket + * has not been determined yet (eyeballing), always ask the + * connection filters for what to monitor. */ + sockfd = Curl_conn_get_first_socket(data); + if(sockfd != CURL_SOCKET_BAD) { + result = Curl_pollset_change(data, ps, sockfd, CURL_POLL_IN, 0); + if(!result) + result = multi_adjust_pollset(data, ps); + } + if(!result) + result = Curl_conn_adjust_pollset(data, conn, ps); + return result; +} + +static CURLcode mstate_protocol_pollset(struct Curl_easy *data, + struct easy_pollset *ps) +{ + struct connectdata *conn = data->conn; + CURLcode result = CURLE_OK; + + if(conn->scheme->run->proto_pollset) + result = conn->scheme->run->proto_pollset(data, ps); + else { + curl_socket_t sockfd = conn->sock[FIRSTSOCKET]; + if(sockfd != CURL_SOCKET_BAD) { + /* Default is to wait to something from the server */ + result = Curl_pollset_change(data, ps, sockfd, CURL_POLL_IN, 0); + } + } + if(!result) + result = multi_adjust_pollset(data, ps); + if(!result) + result = Curl_conn_adjust_pollset(data, conn, ps); + return result; +} + +static CURLcode mstate_do_pollset(struct Curl_easy *data, + struct easy_pollset *ps) +{ + struct connectdata *conn = data->conn; + CURLcode result = CURLE_OK; + + if(conn->scheme->run->doing_pollset) + result = conn->scheme->run->doing_pollset(data, ps); + else if(CONN_SOCK_IDX_VALID(conn->send_idx)) { + /* Default is that we want to send something to the server */ + result = Curl_pollset_add_out(data, ps, conn->sock[conn->send_idx]); + } + if(!result) + result = multi_adjust_pollset(data, ps); + if(!result) + result = Curl_conn_adjust_pollset(data, conn, ps); + return result; +} + +static CURLcode mstate_domore_pollset(struct Curl_easy *data, + struct easy_pollset *ps) +{ + struct connectdata *conn = data->conn; + CURLcode result = CURLE_OK; + + if(conn->scheme->run->domore_pollset) + result = conn->scheme->run->domore_pollset(data, ps); + else if(CONN_SOCK_IDX_VALID(conn->send_idx)) { + /* Default is that we want to send something to the server */ + result = Curl_pollset_add_out(data, ps, conn->sock[conn->send_idx]); + } + if(!result) + result = multi_adjust_pollset(data, ps); + if(!result) + result = Curl_conn_adjust_pollset(data, conn, ps); + return result; +} + +static CURLcode mstate_perform_pollset(struct Curl_easy *data, + struct easy_pollset *ps) +{ + struct connectdata *conn = data->conn; + CURLcode result = CURLE_OK; + + if(conn->scheme->run->perform_pollset) + result = conn->scheme->run->perform_pollset(data, ps); + else { + /* Default is to obey the request flags for send/recv */ + if(Curl_req_want_recv(data) && CONN_SOCK_IDX_VALID(conn->recv_idx)) { + result = Curl_pollset_add_in(data, ps, conn->sock[conn->recv_idx]); + } + if(!result && Curl_req_want_send(data) && + CONN_SOCK_IDX_VALID(conn->send_idx)) { + result = Curl_pollset_add_out(data, ps, conn->sock[conn->send_idx]); + } + } + if(!result) + result = multi_adjust_pollset(data, ps); + if(!result) + result = Curl_conn_adjust_pollset(data, conn, ps); + return result; +} + +/* Initializes `poll_set` with the current socket poll actions needed + * for transfer `data`. */ +CURLMcode Curl_multi_pollset(struct Curl_easy *data, + struct easy_pollset *ps) +{ + CURLcode result = CURLE_OK; + + Curl_pollset_reset(ps); +#ifdef ENABLE_WAKEUP + /* The admin handle always listens on the wakeup socket when there + * are transfers alive. */ + if(data->multi && (data == data->multi->admin) && + data->multi->xfers_really_alive) { + CURL_TRC_M(data, "adding wakeup, %u xfers really alive", + data->multi->xfers_really_alive); + result = Curl_pollset_add_in(data, ps, data->multi->wakeup_pair[0]); + } +#endif + /* If the transfer has no connection, this is fine. Happens when + called via curl_multi_remove_handle() => Curl_multi_ev_assess() => + Curl_multi_pollset(). */ + if(!result && data->conn) { + switch(data->mstate) { + case MSTATE_INIT: + case MSTATE_PENDING: + case MSTATE_SETUP: + case MSTATE_CONNECT: + /* nothing to poll for yet */ + break; + + case MSTATE_CONNECTING: + if(data->conn && !data->conn->bits.dns_resolved) + result = Curl_resolv_pollset(data, ps); + if(!result) + result = mstate_connecting_pollset(data, ps); + break; + + case MSTATE_PROTOCONNECT: + case MSTATE_PROTOCONNECTING: + result = mstate_protocol_pollset(data, ps); + break; + + case MSTATE_DO: + case MSTATE_DOING: + result = mstate_do_pollset(data, ps); + break; + + case MSTATE_DOING_MORE: + result = mstate_domore_pollset(data, ps); + break; + + case MSTATE_DID: /* same as PERFORMING in regard to polling */ + case MSTATE_PERFORMING: + result = mstate_perform_pollset(data, ps); + break; + + case MSTATE_RATELIMITING: + /* we need to let time pass, ignore socket(s) */ + break; + + case MSTATE_DONE: + case MSTATE_COMPLETED: + case MSTATE_MSGSENT: + /* nothing more to poll for */ + break; + + default: + failf(data, "multi_getsock: unexpected multi state %d", + (int)data->mstate); + DEBUGASSERT(0); + break; + } + } + + if(result) { + if(result == CURLE_OUT_OF_MEMORY) + return CURLM_OUT_OF_MEMORY; + failf(data, "error determining pollset: %d", (int)result); + return CURLM_INTERNAL_ERROR; + } + +#ifdef CURLVERBOSE + if(CURL_TRC_M_is_verbose(data)) { + size_t timeout_count = Curl_llist_count(&data->state.timeoutlist); + switch(ps->n) { + case 0: + CURL_TRC_M(data, "pollset[], timeouts=%zu, paused %d/%d (r/w)", + timeout_count, + Curl_xfer_send_is_paused(data), + Curl_xfer_recv_is_paused(data)); + break; + case 1: + CURL_TRC_M(data, "pollset[fd=%" FMT_SOCKET_T " %s%s], timeouts=%zu", + ps->sockets[0], + (ps->actions[0] & CURL_POLL_IN) ? "IN" : "", + (ps->actions[0] & CURL_POLL_OUT) ? "OUT" : "", + timeout_count); + break; + case 2: + CURL_TRC_M(data, "pollset[fd=%" FMT_SOCKET_T " %s%s, " + "fd=%" FMT_SOCKET_T " %s%s], timeouts=%zu", + ps->sockets[0], + (ps->actions[0] & CURL_POLL_IN) ? "IN" : "", + (ps->actions[0] & CURL_POLL_OUT) ? "OUT" : "", + ps->sockets[1], + (ps->actions[1] & CURL_POLL_IN) ? "IN" : "", + (ps->actions[1] & CURL_POLL_OUT) ? "OUT" : "", + timeout_count); + break; + default: + CURL_TRC_M(data, "pollset[fds=%u], timeouts=%zu", ps->n, timeout_count); + break; + } + CURL_TRC_EASY_TIMERS(data); + } +#endif + + return CURLM_OK; +} + +CURLMcode curl_multi_fdset(CURLM *m, + fd_set *read_fd_set, fd_set *write_fd_set, + fd_set *exc_fd_set, int *max_fd) +{ + /* Scan through all the easy handles to get the file descriptors set. + Some easy handles may not have connected to the remote host yet, + and then we must make sure that is done. */ + int this_max_fd = -1; + struct Curl_multi *multi = m; + struct easy_pollset ps; + unsigned int i; + uint32_t mid; + (void)exc_fd_set; + + if(!GOOD_MULTI_HANDLE(multi)) + return CURLM_BAD_HANDLE; + + if(multi->in_callback) + return CURLM_RECURSIVE_API_CALL; + + Curl_pollset_init(&ps); + if(Curl_uint32_bset_first(&multi->process, &mid)) { + do { + struct Curl_easy *data = Curl_multi_get_easy(multi, mid); + + if(!data) { + DEBUGASSERT(0); + continue; + } + + Curl_multi_pollset(data, &ps); + for(i = 0; i < ps.n; i++) { + if(!FDSET_SOCK(ps.sockets[i])) + /* pretend it does not exist */ + continue; + if(ps.actions[i] & CURL_POLL_IN) + FD_SET(ps.sockets[i], read_fd_set); + if(ps.actions[i] & CURL_POLL_OUT) + FD_SET(ps.sockets[i], write_fd_set); + if((int)ps.sockets[i] > this_max_fd) + this_max_fd = (int)ps.sockets[i]; + } + } while(Curl_uint32_bset_next(&multi->process, mid, &mid)); + } + + Curl_cshutdn_setfds(&multi->cshutdn, multi->admin, + read_fd_set, write_fd_set, &this_max_fd); + + *max_fd = this_max_fd; + Curl_pollset_cleanup(&ps); + + return CURLM_OK; +} + +CURLMcode curl_multi_waitfds(CURLM *m, + struct curl_waitfd *ufds, + unsigned int size, + unsigned int *fd_count) +{ + struct Curl_waitfds cwfds; + CURLMcode mresult = CURLM_OK; + struct Curl_multi *multi = m; + struct easy_pollset ps; + unsigned int need = 0; + uint32_t mid; + + if(!ufds && (size || !fd_count)) + return CURLM_BAD_FUNCTION_ARGUMENT; + + if(!GOOD_MULTI_HANDLE(multi)) + return CURLM_BAD_HANDLE; + + if(multi->in_callback) + return CURLM_RECURSIVE_API_CALL; + + Curl_pollset_init(&ps); + Curl_waitfds_init(&cwfds, ufds, size); + if(Curl_uint32_bset_first(&multi->process, &mid)) { + do { + struct Curl_easy *data = Curl_multi_get_easy(multi, mid); + if(!data) { + DEBUGASSERT(0); + Curl_uint32_bset_remove(&multi->process, mid); + Curl_uint32_bset_remove(&multi->dirty, mid); + continue; + } + Curl_multi_pollset(data, &ps); + need += Curl_waitfds_add_ps(&cwfds, &ps); + } while(Curl_uint32_bset_next(&multi->process, mid, &mid)); + } + + need += Curl_cshutdn_add_waitfds(&multi->cshutdn, multi->admin, &cwfds); + + if(need != cwfds.n && ufds) + mresult = CURLM_OUT_OF_MEMORY; + + if(fd_count) + *fd_count = need; + Curl_pollset_cleanup(&ps); + return mresult; +} + +#ifdef USE_WINSOCK +/* Reset FD_WRITE for TCP sockets. Nothing is actually sent. UDP sockets cannot + * be reset this way because an empty datagram would be sent. #9203 + * + * "On Windows the internal state of FD_WRITE as returned from + * WSAEnumNetworkEvents is only reset after successful send()." + */ +static void reset_socket_fdwrite(curl_socket_t s) +{ + int t; + int l = (int)sizeof(t); + if(!getsockopt(s, SOL_SOCKET, SO_TYPE, (char *)&t, &l) && t == SOCK_STREAM) + swrite(s, NULL, 0); +} + +static CURLMcode multi_winsock_select(struct Curl_multi *multi, + struct curl_pollfds *cpfds, + unsigned int curl_nfds, + struct curl_waitfd extra_fds[], + unsigned int extra_nfds, + int timeout_ms, + bool extrawait, + int *pnevents) +{ + CURLMcode mresult = CURLM_OK; + WSANETWORKEVENTS wsa_events; + int nevents = 0; + size_t i; + + DEBUGASSERT(multi->wsa_event != WSA_INVALID_EVENT); + + /* Set the WSA events based on the collected pollds */ + for(i = 0; i < cpfds->n; i++) { + long mask = 0; + if(cpfds->pfds[i].events & POLLIN) + mask |= FD_READ | FD_ACCEPT | FD_CLOSE; + if(cpfds->pfds[i].events & POLLPRI) + mask |= FD_OOB; + if(cpfds->pfds[i].events & POLLOUT) { + mask |= FD_WRITE | FD_CONNECT | FD_CLOSE; + reset_socket_fdwrite(cpfds->pfds[i].fd); + } + if(mask) { + if(WSAEventSelect(cpfds->pfds[i].fd, multi->wsa_event, mask) != 0) { + mresult = CURLM_OUT_OF_MEMORY; + goto out; + } + } + } + + if(cpfds->n || extrawait) { + int pollrc = 0; + + if(cpfds->n) { /* pre-check with Winsock */ + pollrc = Curl_poll(cpfds->pfds, cpfds->n, 0); + if(pollrc < 0) { + mresult = CURLM_UNRECOVERABLE_POLL; + goto out; + } + nevents = pollrc; + } + + if(!nevents) { + /* now wait... if not ready during the pre-check (pollrc == 0) */ + WSAWaitForMultipleEvents(1, &multi->wsa_event, FALSE, (DWORD)timeout_ms, + FALSE); + } + + /* With Winsock, we have to run the following section unconditionally + to call WSAEventSelect(fd, event, 0) on all the sockets */ + /* copy revents results from the poll to the curl_multi_wait poll + struct, the bit values of the actual underlying poll() implementation + may not be the same as the ones in the public libcurl API! */ + for(i = 0; i < extra_nfds; i++) { + unsigned short mask = 0; + curl_socket_t s = extra_fds[i].fd; + + wsa_events.lNetworkEvents = 0; + if(WSAEnumNetworkEvents(s, NULL, &wsa_events) == 0) { + if(wsa_events.lNetworkEvents & (FD_READ | FD_ACCEPT | FD_CLOSE)) + mask |= CURL_WAIT_POLLIN; + if(wsa_events.lNetworkEvents & (FD_WRITE | FD_CONNECT | FD_CLOSE)) + mask |= CURL_WAIT_POLLOUT; + if(wsa_events.lNetworkEvents & FD_OOB) + mask |= CURL_WAIT_POLLPRI; + if(!pollrc && wsa_events.lNetworkEvents) + nevents++; + } + WSAEventSelect(s, multi->wsa_event, 0); + if(!pollrc) { + extra_fds[i].revents = (short)mask; + continue; + } + else { + unsigned r = (unsigned)cpfds->pfds[curl_nfds + i].revents; + if(r & POLLIN) + mask |= CURL_WAIT_POLLIN; + if(r & POLLOUT) + mask |= CURL_WAIT_POLLOUT; + if(r & POLLPRI) + mask |= CURL_WAIT_POLLPRI; + extra_fds[i].revents = (short)mask; + } + } + + /* Count up all our own sockets that had activity, + and remove them from the event. */ + for(i = 0; i < curl_nfds; ++i) { + wsa_events.lNetworkEvents = 0; + if(WSAEnumNetworkEvents(cpfds->pfds[i].fd, NULL, &wsa_events) == 0) { + if(!pollrc && wsa_events.lNetworkEvents) + nevents++; + } + WSAEventSelect(cpfds->pfds[i].fd, multi->wsa_event, 0); + } + WSAResetEvent(multi->wsa_event); + } + +out: + *pnevents = nevents; + return mresult; +} + +#else /* USE_WINSOCK */ + +static CURLMcode multi_posix_poll(struct Curl_multi *multi, + struct curl_pollfds *cpfds, + unsigned int curl_nfds, + struct curl_waitfd extra_fds[], + unsigned int extra_nfds, + int timeout_ms, + bool extrawait, + int *pnevents) +{ + CURLMcode mresult = CURLM_OK; + int nevents = 0; + size_t i; + + (void)multi; + if(cpfds->n) { + int pollrc = Curl_poll(cpfds->pfds, cpfds->n, timeout_ms); /* wait... */ + if(pollrc < 0) { + mresult = CURLM_UNRECOVERABLE_POLL; + goto out; + } + nevents = pollrc; + + /* copy revents results from the poll to the curl_multi_wait poll + struct, the bit values of the actual underlying poll() implementation + may not be the same as the ones in the public libcurl API! */ + for(i = 0; i < extra_nfds; i++) { + unsigned r = (unsigned)cpfds->pfds[curl_nfds + i].revents; + unsigned short mask = 0; + if(r & POLLIN) + mask |= CURL_WAIT_POLLIN; + if(r & POLLOUT) + mask |= CURL_WAIT_POLLOUT; + if(r & POLLPRI) + mask |= CURL_WAIT_POLLPRI; + extra_fds[i].revents = (short)mask; + } + } + else if(extrawait) { + /* No fds to poll, but asked to obey timeout_ms anyway. We cannot + * use Curl_poll() as it, on some platforms, returns immediately + * without fds. */ + curlx_wait_ms(timeout_ms); + } + +out: + *pnevents = nevents; + return mresult; +} + +#endif /* !USE_WINSOCK */ + +#define NUM_POLLS_ON_STACK 10 + +static CURLMcode multi_wait(struct Curl_multi *multi, + struct curl_waitfd extra_fds[], + unsigned int extra_nfds, + int timeout_ms, + int *ret, + bool extrawait) /* when no socket, wait */ +{ + size_t i; + struct curltime expire_time; + long timeout_internal; + int nevents = 0; + struct easy_pollset ps; + struct pollfd a_few_on_stack[NUM_POLLS_ON_STACK]; + struct curl_pollfds cpfds; + unsigned int curl_nfds = 0; /* how many pfds are for curl transfers */ + struct Curl_easy *data = NULL; + CURLMcode mresult = CURLM_OK; + uint32_t mid; +#ifdef ENABLE_WAKEUP + int wakeup_idx = -1; +#endif + + if(!GOOD_MULTI_HANDLE(multi)) + return CURLM_BAD_HANDLE; + + if(multi->in_callback) + return CURLM_RECURSIVE_API_CALL; + + if(timeout_ms < 0) + return CURLM_BAD_FUNCTION_ARGUMENT; + + Curl_pollset_init(&ps); + Curl_pollfds_init(&cpfds, a_few_on_stack, NUM_POLLS_ON_STACK); + + /* Add the curl handles to our pollfds first */ + if(Curl_uint32_bset_first(&multi->process, &mid)) { + do { + data = Curl_multi_get_easy(multi, mid); + if(!data) { + DEBUGASSERT(0); + Curl_uint32_bset_remove(&multi->process, mid); + Curl_uint32_bset_remove(&multi->dirty, mid); + continue; + } + Curl_multi_pollset(data, &ps); + if(Curl_pollfds_add_ps(&cpfds, &ps)) { + mresult = CURLM_OUT_OF_MEMORY; + goto out; + } + } while(Curl_uint32_bset_next(&multi->process, mid, &mid)); + } + + if(Curl_cshutdn_add_pollfds(&multi->cshutdn, multi->admin, &cpfds)) { + mresult = CURLM_OUT_OF_MEMORY; + goto out; + } + +#ifdef ENABLE_WAKEUP + /* If `extrawait` is TRUE *or* we have `extra_fds`to poll *or* we + * have transfer sockets to poll, we obey `timeout_ms`. + * Then we need to also monitor the multi's wakeup + * socket to catch calls to `curl_multi_wakeup()` during the wait. */ + if(extrawait || cpfds.n || extra_nfds) { + wakeup_idx = cpfds.n; + if(Curl_pollfds_add_sock(&cpfds, multi->wakeup_pair[0], POLLIN)) { + mresult = CURLM_OUT_OF_MEMORY; + goto out; + } + } +#endif + + curl_nfds = cpfds.n; /* what curl internally uses in cpfds */ + /* Add external file descriptions from poll-like struct curl_waitfd */ + for(i = 0; i < extra_nfds; i++) { + unsigned short events = 0; + if(extra_fds[i].events & CURL_WAIT_POLLIN) + events |= POLLIN; + if(extra_fds[i].events & CURL_WAIT_POLLPRI) + events |= POLLPRI; + if(extra_fds[i].events & CURL_WAIT_POLLOUT) + events |= POLLOUT; + if(Curl_pollfds_add_sock(&cpfds, extra_fds[i].fd, events)) { + mresult = CURLM_OUT_OF_MEMORY; + goto out; + } + } + + /* We check the internal timeout *AFTER* we collected all sockets to + * poll. Collecting the sockets may install new timers by protocols + * and connection filters. + * Use the shorter one of the internal and the caller requested timeout. + * If we are called with `!extrawait` and multi_timeout() reports no + * timeouts exist, do not wait. */ + multi_timeout(multi, &expire_time, &timeout_internal); + if((timeout_internal >= 0) && (timeout_internal < (long)timeout_ms)) + timeout_ms = (int)timeout_internal; + + if(data) + CURL_TRC_M(data, "multi_wait(fds=%u, timeout=%d) tinternal=%ld", + cpfds.n, timeout_ms, timeout_internal); + +#ifdef USE_WINSOCK + mresult = multi_winsock_select(multi, &cpfds, curl_nfds, + extra_fds, extra_nfds, + timeout_ms, extrawait, &nevents); +#else + mresult = multi_posix_poll(multi, &cpfds, curl_nfds, + extra_fds, extra_nfds, + timeout_ms, extrawait, &nevents); +#endif + +#ifdef ENABLE_WAKEUP + if(nevents && (wakeup_idx >= 0)) { + if(cpfds.pfds[wakeup_idx].revents & POLLIN) { + (void)Curl_wakeup_consume(multi->wakeup_pair, TRUE); + /* do not count the wakeup socket into the returned value */ + nevents--; + } + } +#endif + +out: + Curl_pollset_cleanup(&ps); + Curl_pollfds_cleanup(&cpfds); + if(ret) + *ret = nevents; + return mresult; +} + +CURLMcode curl_multi_wait(CURLM *m, + struct curl_waitfd extra_fds[], + unsigned int extra_nfds, + int timeout_ms, + int *ret) +{ + return multi_wait(m, extra_fds, extra_nfds, timeout_ms, ret, FALSE); +} + +CURLMcode curl_multi_poll(CURLM *m, + struct curl_waitfd extra_fds[], + unsigned int extra_nfds, + int timeout_ms, + int *ret) +{ + return multi_wait(m, extra_fds, extra_nfds, timeout_ms, ret, TRUE); +} + +CURLMcode curl_multi_wakeup(CURLM *m) +{ + /* this function is usually called from another thread, + it has to be careful only to access parts of the + Curl_multi struct that are constant */ + struct Curl_multi *multi = m; + CURLMcode mresult = CURLM_WAKEUP_FAILURE; + + /* GOOD_MULTI_HANDLE can be safely called */ + if(!GOOD_MULTI_HANDLE(multi)) + return CURLM_BAD_HANDLE; + +#ifdef ENABLE_WAKEUP + /* the wakeup_pair variable is only written during init and cleanup, + making it safe to access from another thread after the init part + and before cleanup */ + if(!Curl_wakeup_signal(multi->wakeup_pair)) + mresult = CURLM_OK; +#endif +#ifdef USE_WINSOCK + if(WSASetEvent(multi->wsa_event)) + mresult = CURLM_OK; +#endif + return mresult; +} + +/* + * multi_ischanged() is called + * + * Returns TRUE/FALSE whether the state is changed to trigger a CONNECT_PEND + * => CONNECT action. + * + * Set 'clear' to TRUE to have it also clear the state variable. + */ +static bool multi_ischanged(struct Curl_multi *multi, bool clear) +{ + bool retval = FALSE; + DEBUGASSERT(multi); + if(multi) { + retval = (bool)multi->recheckstate; + if(clear) + multi->recheckstate = FALSE; + } + return retval; +} + +/* + * Curl_multi_connchanged() is called to tell that there is a connection in + * this multi handle that has changed state (multiplexing become possible, the + * number of allowed streams changed or similar), and a subsequent use of this + * multi handle should move CONNECT_PEND handles back to CONNECT to have them + * retry. + */ +void Curl_multi_connchanged(struct Curl_multi *multi) +{ + multi->recheckstate = TRUE; +} + +CURLMcode Curl_multi_add_perform(struct Curl_multi *multi, + struct Curl_easy *data, + struct connectdata *conn) +{ + CURLMcode mresult; + + if(multi->in_callback) + return CURLM_RECURSIVE_API_CALL; + + mresult = curl_multi_add_handle(multi, data); + if(!mresult) { + CURLcode result; + + /* pass in NULL for 'conn' here since we do not want to init the + connection, only this transfer */ + result = Curl_init_do(data, NULL); + if(result) { + curl_multi_remove_handle(multi, data); + return CURLM_INTERNAL_ERROR; + } + + /* take this handle to the perform state right away */ + multistate(data, MSTATE_PERFORMING); + Curl_attach_connection(data, conn); + CURL_REQ_SET_RECV(data); + } + return mresult; +} + +static CURLcode multi_do(struct Curl_easy *data, bool *done) +{ + CURLcode result = CURLE_OK; + struct connectdata *conn = data->conn; + + DEBUGASSERT(conn); + DEBUGASSERT(conn->scheme); + + if(conn->scheme->run->do_it) + result = conn->scheme->run->do_it(data, done); + + return result; +} + +/* + * multi_do_more() is called during the DO_MORE multi state. It is a second + * stage DO state which (wrongly) was introduced to support FTP's second + * connection. + * + * 'complete' can return DOMORE_INCOMPLETE, DOMORE_DONE or DOMORE_GOBACK + * (to DOING state when there is more work to do) + */ + +static CURLcode multi_do_more(struct Curl_easy *data, domore *complete) +{ + CURLcode result = CURLE_OK; + struct connectdata *conn = data->conn; + + *complete = DOMORE_INCOMPLETE; + + if(conn->scheme->run->do_more) + result = conn->scheme->run->do_more(data, complete); + + return result; +} + +/* + * Check whether a timeout occurred, and handle it if it did + */ +static bool multi_handle_timeout(struct Curl_easy *data, + bool *stream_error, + CURLcode *result) +{ + timediff_t timeout_ms; + + timeout_ms = Curl_timeleft_ms(data); + if(timeout_ms < 0) { + /* Handle timed out */ + struct curltime since; + if(Curl_is_connecting(data)) + since = data->progress.t_startsingle; + else + since = data->progress.t_startop; + if(data->mstate == MSTATE_CONNECTING) + failf(data, "%s timed out after %" FMT_TIMEDIFF_T " milliseconds", + data->conn->bits.dns_resolved ? "Connection" : "Resolving", + curlx_ptimediff_ms(Curl_pgrs_now(data), &since)); + else { + struct SingleRequest *k = &data->req; + if(k->size != -1) { + failf(data, "Operation timed out after %" FMT_TIMEDIFF_T + " milliseconds with %" FMT_OFF_T " out of %" + FMT_OFF_T " bytes received", + curlx_ptimediff_ms(Curl_pgrs_now(data), &since), + k->bytecount, k->size); + } + else { + failf(data, "Operation timed out after %" FMT_TIMEDIFF_T + " milliseconds with %" FMT_OFF_T " bytes received", + curlx_ptimediff_ms(Curl_pgrs_now(data), &since), + k->bytecount); + } + } + *result = CURLE_OPERATION_TIMEDOUT; + if(data->conn) { + /* Force connection closed if the connection has indeed been used */ + if(data->mstate > MSTATE_DO) { + streamclose(data->conn, "Disconnect due to timeout"); + *stream_error = TRUE; + } + (void)multi_done(data, *result, TRUE); + } + return TRUE; + } + + return FALSE; +} + +/* + * We are doing protocol-specific connecting and this is being called over and + * over from the multi interface until the connection phase is done on + * protocol layer. + */ + +static CURLcode protocol_connecting(struct Curl_easy *data, bool *done) +{ + CURLcode result = CURLE_OK; + struct connectdata *conn = data->conn; + + if(conn && conn->scheme->run->connecting) { + *done = FALSE; + result = conn->scheme->run->connecting(data, done); + } + else + *done = TRUE; + + return result; +} + +/* + * We are DOING this is being called over and over from the multi interface + * until the DOING phase is done on protocol layer. + */ + +static CURLcode protocol_doing(struct Curl_easy *data, bool *done) +{ + CURLcode result = CURLE_OK; + struct connectdata *conn = data->conn; + + if(conn && conn->scheme->run->doing) { + *done = FALSE; + result = conn->scheme->run->doing(data, done); + } + else + *done = TRUE; + + return result; +} + +/* + * We have discovered that the TCP connection has been successful, we can now + * proceed with some action. + * + */ +static CURLcode protocol_connect(struct Curl_easy *data, bool *protocol_done) +{ + struct connectdata *conn = data->conn; + CURLcode result = CURLE_OK; + + DEBUGASSERT(conn); + DEBUGASSERT(protocol_done); + DEBUGASSERT(Curl_conn_is_connected(conn, FIRSTSOCKET)); + + *protocol_done = FALSE; + if(!conn->bits.protoconnstart) { + if(conn->scheme->run->connect_it) { + /* Call the protocol-specific connect function */ + result = conn->scheme->run->connect_it(data, protocol_done); + if(result) + return result; + } + conn->bits.protoconnstart = TRUE; + } + + /* Unless this protocol does not have any protocol-connect callback, as + then we know we are done. */ + if(!conn->scheme->run->connecting) + *protocol_done = TRUE; + return CURLE_OK; +} + +static void set_in_callback(struct Curl_multi *multi, bool value) +{ + multi->in_callback = value; +} + +/* + * posttransfer() is called immediately after a transfer ends + */ +static void multi_posttransfer(struct Curl_easy *data) +{ +#if defined(HAVE_SIGNAL) && defined(SIGPIPE) && !defined(MSG_NOSIGNAL) + /* restore the signal handler for SIGPIPE before we get back */ + if(!data->set.no_signal) + signal(SIGPIPE, data->state.prev_signal); +#else + (void)data; +#endif +} + +/* + * multi_follow() handles the URL redirect magic. Pass in the 'newurl' string + * as given by the remote server and set up the new URL to request. + * + * This function DOES NOT FREE the given URL. + */ +static CURLcode multi_follow(struct Curl_easy *data, + const struct Curl_scheme *handler, + const char *newurl, /* the Location: string */ + followtype type) /* see transfer.h */ +{ + if(handler && handler->run->follow) + return handler->run->follow(data, newurl, type); + + if(type == FOLLOW_RETRY) + /* Retries are generic and do not require protocol-specific redirect + handling. */ + return CURLE_OK; + + return CURLE_TOO_MANY_REDIRECTS; +} + +static CURLcode mspeed_check(struct Curl_easy *data) +{ + if(Curl_rlimit_active(&data->progress.dl.rlimit) || + Curl_rlimit_active(&data->progress.ul.rlimit)) { + /* check if our send/recv limits require idle waits */ + const struct curltime *pnow = Curl_pgrs_now(data); + timediff_t recv_ms, send_ms; + + send_ms = Curl_rlimit_wait_ms(&data->progress.ul.rlimit, pnow); + recv_ms = Curl_rlimit_wait_ms(&data->progress.dl.rlimit, pnow); + + if(send_ms || recv_ms) { + if(data->mstate != MSTATE_RATELIMITING) { + multistate(data, MSTATE_RATELIMITING); + } + Curl_expire(data, CURLMAX(send_ms, recv_ms), EXPIRE_TOOFAST); + Curl_multi_clear_dirty(data); + CURL_TRC_M(data, "[RLIMIT] waiting %" FMT_TIMEDIFF_T "ms", + CURLMAX(send_ms, recv_ms)); + return CURLE_AGAIN; + } + else { + /* when will the rate limits increase next? The transfer needs + * to run again at that time or it may stall. */ + send_ms = Curl_rlimit_next_step_ms(&data->progress.ul.rlimit, pnow); + recv_ms = Curl_rlimit_next_step_ms(&data->progress.dl.rlimit, pnow); + if(send_ms || recv_ms) { + timediff_t next_ms = CURLMIN(send_ms, recv_ms); + if(!next_ms) + next_ms = CURLMAX(send_ms, recv_ms); + Curl_expire(data, next_ms, EXPIRE_TOOFAST); + CURL_TRC_M(data, "[RLIMIT] next token update in %" FMT_TIMEDIFF_T "ms", + next_ms); + } + } + } + + if(data->mstate != MSTATE_PERFORMING) { + CURL_TRC_M(data, "[RLIMIT] wait over, continue"); + multistate(data, MSTATE_PERFORMING); + } + return CURLE_OK; +} + +static CURLMcode multistate_performing(struct Curl_easy *data, + bool *stream_errorp, + CURLcode *resultp) +{ + char *newurl = NULL; + bool retry = FALSE; + CURLMcode mresult = CURLM_OK; + CURLcode result = *resultp = CURLE_OK; + *stream_errorp = FALSE; + + if(mspeed_check(data) == CURLE_AGAIN) + return CURLM_OK; + + /* read/write data if it is ready to do so */ + result = Curl_sendrecv(data); + + if(data->req.done || (result == CURLE_RECV_ERROR)) { + /* If CURLE_RECV_ERROR happens early enough, we assume it was a race + * condition and the server closed the reused connection exactly when we + * wanted to use it, so figure out if that is indeed the case. + */ + CURLcode ret = Curl_retry_request(data, &newurl); + if(!ret) + retry = !!newurl; + else if(!result) + result = ret; + + if(retry) { + /* if we are to retry, set the result to OK and consider the + request as done */ + result = CURLE_OK; + data->req.done = TRUE; + } + } +#ifndef CURL_DISABLE_HTTP + else if((result == CURLE_HTTP2_STREAM) && + Curl_h2_http_1_1_error(data)) { + CURLcode ret = Curl_retry_request(data, &newurl); + + if(!ret) { + infof(data, "Downgrades to HTTP/1.1"); + streamclose(data->conn, "Disconnect HTTP/2 for HTTP/1"); + data->state.http_neg.wanted = CURL_HTTP_V1x; + data->state.http_neg.allowed = CURL_HTTP_V1x; + /* clear the error message bit too as we ignore the one we got */ + data->state.errorbuf = FALSE; + if(!newurl) + /* typically for HTTP_1_1_REQUIRED error on first flight */ + newurl = Curl_bufref_dup(&data->state.url); + if(!newurl) { + result = CURLE_OUT_OF_MEMORY; + } + else { + /* if we are to retry, set the result to OK and consider the request + as done */ + retry = TRUE; + result = CURLE_OK; + data->req.done = TRUE; + } + } + else + result = ret; + } +#endif + + if(result) { + /* + * The transfer phase returned error, we mark the connection to get closed + * to prevent being reused. This is because we cannot possibly know if the + * connection is in a good shape or not now. Unless it is a protocol which + * uses two "channels" like FTP, as then the error happened in the data + * connection. + */ + + if(!(data->conn->scheme->flags & PROTOPT_DUAL) && + result != CURLE_HTTP2_STREAM) + streamclose(data->conn, "Transfer returned error"); + + multi_posttransfer(data); + multi_done(data, result, TRUE); + } + else if(data->req.done && !Curl_cwriter_is_paused(data)) { + const struct Curl_scheme *handler = data->conn->scheme; + + /* call this even if the readwrite function returned error */ + multi_posttransfer(data); + + /* When we follow redirects or is set to retry the connection, we must to + go back to the CONNECT state */ + if(data->req.newurl || retry) { + followtype follow = FOLLOW_NONE; + if(!retry) { + /* if the URL is a follow-location and not a retried request then + figure out the URL here */ + curlx_free(newurl); + newurl = data->req.newurl; + data->req.newurl = NULL; + follow = FOLLOW_REDIR; + } + else + follow = FOLLOW_RETRY; + (void)multi_done(data, CURLE_OK, FALSE); + /* multi_done() might return CURLE_GOT_NOTHING */ + result = multi_follow(data, handler, newurl, follow); + if(!result) { + multistate(data, MSTATE_SETUP); + mresult = CURLM_CALL_MULTI_PERFORM; + } + } + else { + /* after the transfer is done, go DONE */ + + /* but first check to see if we got a location info even though we are + not following redirects */ + if(data->req.location) { + curlx_free(newurl); + newurl = data->req.location; + data->req.location = NULL; + result = multi_follow(data, handler, newurl, FOLLOW_FAKE); + if(result) { + *stream_errorp = TRUE; + result = multi_done(data, result, TRUE); + } + } + + if(!result) { + multistate(data, MSTATE_DONE); + mresult = CURLM_CALL_MULTI_PERFORM; + } + } + } + else { /* not errored, not done */ + mspeed_check(data); + } + curlx_free(newurl); + *resultp = result; + return mresult; +} + +static CURLMcode multistate_do(struct Curl_easy *data, + bool *stream_errorp, + CURLcode *resultp) +{ + CURLMcode mresult = CURLM_OK; + CURLcode result = CURLE_OK; + if(data->set.fprereq) { + int prereq_rc; + + /* call the prerequest callback function */ + Curl_set_in_callback(data, TRUE); + prereq_rc = data->set.fprereq(data->set.prereq_userp, + data->info.primary.remote_ip, + data->info.primary.local_ip, + data->info.primary.remote_port, + data->info.primary.local_port); + Curl_set_in_callback(data, FALSE); + if(prereq_rc != CURL_PREREQFUNC_OK) { + failf(data, "operation aborted by pre-request callback"); + /* failure in pre-request callback - do not do any other processing */ + result = CURLE_ABORTED_BY_CALLBACK; + multi_posttransfer(data); + multi_done(data, result, FALSE); + *stream_errorp = TRUE; + goto end; + } + } + + if(data->set.connect_only && !data->set.connect_only_ws) { + multistate(data, MSTATE_DONE); + mresult = CURLM_CALL_MULTI_PERFORM; + } + else { + bool dophase_done = FALSE; + /* Perform the protocol's DO action */ + result = multi_do(data, &dophase_done); + + if(!result) { + if(!dophase_done) { +#ifndef CURL_DISABLE_FTP + /* some steps needed for wildcard matching */ + if(data->state.wildcardmatch) { + struct WildcardData *wc = data->wildcard; + if(wc->state == CURLWC_DONE || wc->state == CURLWC_SKIP) { + /* skip some states if it is important */ + multi_done(data, CURLE_OK, FALSE); + + /* if there is no connection left, skip the DONE state */ + multistate(data, data->conn ? MSTATE_DONE : MSTATE_COMPLETED); + mresult = CURLM_CALL_MULTI_PERFORM; + goto end; + } + } +#endif + /* DO was not completed in one function call, we must continue + DOING... */ + multistate(data, MSTATE_DOING); + mresult = CURLM_CALL_MULTI_PERFORM; + } + + /* after DO, go DO_DONE... or DO_MORE */ + else if(data->conn->bits.do_more) { + /* we are supposed to do more, but we need to sit down, relax and wait + a little while first */ + multistate(data, MSTATE_DOING_MORE); + mresult = CURLM_CALL_MULTI_PERFORM; + } + else { + /* we are done with the DO, now DID */ + multistate(data, MSTATE_DID); + mresult = CURLM_CALL_MULTI_PERFORM; + } + } + else if((result == CURLE_SEND_ERROR) && + data->conn->bits.reuse) { + /* + * In this situation, a connection that we were trying to use may have + * unexpectedly died. If possible, send the connection back to the + * CONNECT phase so we can try again. + */ + const struct Curl_scheme *handler = data->conn->scheme; + char *newurl = NULL; + followtype follow = FOLLOW_NONE; + CURLcode drc; + + drc = Curl_retry_request(data, &newurl); + if(drc) { + /* a failure here pretty much implies an out of memory */ + result = drc; + *stream_errorp = TRUE; + } + + multi_posttransfer(data); + drc = multi_done(data, result, FALSE); + + /* When set to retry the connection, we must go back to the CONNECT + * state */ + if(newurl) { + if(!drc || (drc == CURLE_SEND_ERROR)) { + follow = FOLLOW_RETRY; + drc = multi_follow(data, handler, newurl, follow); + if(!drc) { + multistate(data, MSTATE_SETUP); + mresult = CURLM_CALL_MULTI_PERFORM; + result = CURLE_OK; + } + else { + /* Follow failed */ + result = drc; + } + } + else { + /* done did not return OK or SEND_ERROR */ + result = drc; + } + } + else { + /* Have error handler disconnect conn if we cannot retry */ + *stream_errorp = TRUE; + } + curlx_free(newurl); + } + else { + /* failure detected */ + multi_posttransfer(data); + if(data->conn) + multi_done(data, result, FALSE); + *stream_errorp = TRUE; + } + } +end: + *resultp = result; + return mresult; +} + +static CURLMcode multistate_ratelimiting(struct Curl_easy *data, + CURLcode *resultp) +{ + CURLcode result = CURLE_OK; + CURLMcode mresult = CURLM_OK; + DEBUGASSERT(data->conn); + /* if both rates are within spec, resume transfer */ + result = Curl_pgrsCheck(data); + + if(result) { + if(!(data->conn->scheme->flags & PROTOPT_DUAL) && + result != CURLE_HTTP2_STREAM) + streamclose(data->conn, "Transfer returned error"); + + multi_posttransfer(data); + multi_done(data, result, TRUE); + } + else { + if(!mspeed_check(data)) + mresult = CURLM_CALL_MULTI_PERFORM; + } + *resultp = result; + return mresult; +} + +static CURLMcode multistate_connect(struct Curl_multi *multi, + struct Curl_easy *data, + CURLcode *resultp) +{ + /* Connect. We want to get a connection identifier filled in. This state can + be entered from SETUP and from PENDING. */ + bool connected; + CURLMcode mresult = CURLM_OK; + CURLcode result = Curl_connect(data, &connected); + if(result == CURLE_NO_CONNECTION_AVAILABLE) { + /* There was no connection available. We will go to the pending state and + wait for an available connection. */ + multistate(data, MSTATE_PENDING); + /* move from process to pending set */ + Curl_uint32_bset_remove(&multi->process, data->mid); + Curl_uint32_bset_remove(&multi->dirty, data->mid); + Curl_uint32_bset_add(&multi->pending, data->mid); + *resultp = CURLE_OK; + return mresult; + } + else + process_pending_handles(data->multi); + + if(!result) { + /* after the connect has been sent off, go WAITCONNECT unless the + protocol connect is already done and we can go directly to WAITDO or + DO! */ + mresult = CURLM_CALL_MULTI_PERFORM; + + if(connected) { + if(!data->conn->bits.reuse && + Curl_conn_is_multiplex(data->conn, FIRSTSOCKET)) { + /* new connection, can multiplex, wake pending handles */ + process_pending_handles(data->multi); + } + multistate(data, MSTATE_PROTOCONNECT); + } + else { + multistate(data, MSTATE_CONNECTING); + } + } + *resultp = result; + return mresult; +} + +/* returns the possibly updated result */ +static CURLcode is_finished(struct Curl_multi *multi, + struct Curl_easy *data, + bool stream_error, + CURLcode result) +{ + if(data->mstate < MSTATE_COMPLETED) { + if(result) { + /* + * If an error was returned, and we are not in completed state now, + * then we go to completed and consider this transfer aborted. + */ + + /* No attempt to disconnect connections must be made before this - + connection detach and termination happens only here */ + + /* Check if we can move pending requests to send pipe */ + process_pending_handles(multi); /* connection */ + + if(data->conn) { + if(stream_error) { + /* Do not attempt to send data over a connection that timed out */ + bool dead_connection = result == CURLE_OPERATION_TIMEDOUT; + struct connectdata *conn = data->conn; + + /* This is where we make sure that the conn pointer is reset. + We do not have to do this in every case block above where a + failure is detected */ + Curl_detach_connection(data); + Curl_conn_terminate(data, conn, dead_connection); + } + } + else if(data->mstate == MSTATE_CONNECT) { + /* Curl_connect() failed */ + multi_posttransfer(data); + Curl_pgrsUpdate_nometer(data); + } + + multistate(data, MSTATE_COMPLETED); + return result; + } + /* if there is still a connection to use, call the progress function */ + else if(data->conn && Curl_conn_is_connected(data->conn, FIRSTSOCKET)) { + result = Curl_pgrsUpdate(data); + if(result) { + /* aborted due to progress callback return code must close the + connection */ + streamclose(data->conn, "Aborted by callback"); + + /* if not yet in DONE state, go there, otherwise COMPLETED */ + multistate(data, (data->mstate < MSTATE_DONE) ? + MSTATE_DONE : MSTATE_COMPLETED); + return result; + } + } + } + return result; +} + +static void handle_completed(struct Curl_multi *multi, + struct Curl_easy *data, + CURLcode result) +{ + if(data->master_mid != UINT32_MAX) { + /* A sub transfer, not for msgsent to application */ + struct Curl_easy *mdata; + + CURL_TRC_M(data, "sub xfer done for master %u", data->master_mid); + mdata = Curl_multi_get_easy(multi, data->master_mid); + if(mdata) { + if(mdata->sub_xfer_done) + mdata->sub_xfer_done(mdata, data, result); + else + CURL_TRC_M(data, "master easy %u without sub_xfer_done callback.", + data->master_mid); + } + else { + CURL_TRC_M(data, "master easy %u already gone.", data->master_mid); + } + } + else { + /* now fill in the Curl_message with this info */ + struct Curl_message *msg = &data->msg; + + msg->extmsg.msg = CURLMSG_DONE; + msg->extmsg.easy_handle = data; + msg->extmsg.data.result = result; + + multi_addmsg(multi, msg); + DEBUGASSERT(!data->conn); + } + multistate(data, MSTATE_MSGSENT); + + /* remove from the other sets, add to msgsent */ + Curl_uint32_bset_remove(&multi->process, data->mid); + Curl_uint32_bset_remove(&multi->dirty, data->mid); + Curl_uint32_bset_remove(&multi->pending, data->mid); + Curl_uint32_bset_add(&multi->msgsent, data->mid); + if(data->state.really_alive) { + data->state.really_alive = FALSE; + --multi->xfers_really_alive; + if(!multi->xfers_really_alive) + (void)multi_assess_wakeup(multi); + } + --multi->xfers_alive; + if(!multi->xfers_alive) + multi_assess_wakeup(multi); +} + +static CURLMcode multistate_init(struct Curl_easy *data, CURLcode *result) +{ + if(!data->state.really_alive) { + data->state.really_alive = TRUE; + ++data->multi->xfers_really_alive; + if(data->multi->xfers_really_alive == 1) { + CURLMcode mresult = multi_assess_wakeup(data->multi); + if(mresult) { + failf(data, "error enabling wakeup listening: %d", mresult); + return mresult; + } + } + } + + *result = Curl_pretransfer(data); + if(*result) + return CURLM_OK; + + /* after init, go SETUP */ + multistate(data, MSTATE_SETUP); + Curl_pgrsTime(data, TIMER_STARTOP); + return CURLM_CALL_MULTI_PERFORM; +} + +static CURLMcode multistate_setup(struct Curl_easy *data) +{ + Curl_pgrsTime(data, TIMER_STARTSINGLE); + if(data->set.timeout) + Curl_expire(data, data->set.timeout, EXPIRE_TIMEOUT); + if(data->set.connecttimeout) + /* Since a connection might go to pending and back to CONNECT several + times before it actually takes off, we need to set the timeout once + in SETUP before we enter CONNECT the first time. */ + Curl_expire(data, data->set.connecttimeout, EXPIRE_CONNECTTIMEOUT); + + multistate(data, MSTATE_CONNECT); + return CURLM_CALL_MULTI_PERFORM; +} + +static CURLMcode multistate_connecting(struct Curl_easy *data, + bool *stream_error, + CURLcode *result) +{ + bool connected; + + if(!data->conn) { + DEBUGASSERT(0); + *result = CURLE_FAILED_INIT; + return CURLM_OK; + } + if(!Curl_xfer_recv_is_paused(data)) { + *result = Curl_conn_connect(data, FIRSTSOCKET, FALSE, &connected); + if(connected && !*result) { + if(!data->conn->bits.reuse && + Curl_conn_is_multiplex(data->conn, FIRSTSOCKET)) { + /* new connection, can multiplex, wake pending handles */ + process_pending_handles(data->multi); + } + multistate(data, MSTATE_PROTOCONNECT); + return CURLM_CALL_MULTI_PERFORM; + } + else if(*result) { + /* failure detected */ + CURL_TRC_M(data, "connect failed -> %d", (int)*result); + multi_posttransfer(data); + multi_done(data, *result, TRUE); + *stream_error = TRUE; + return CURLM_OK; + } + } + return CURLM_OK; +} + +static CURLMcode multistate_protoconnect(struct Curl_easy *data, + bool *stream_error, + CURLcode *result) +{ + bool protocol_connected = FALSE; + + if(!*result && data->conn->bits.reuse) { + /* ftp seems to hang when protoconnect on reused connection since we + * handle PROTOCONNECT in general inside the filters, it seems wrong to + * restart this on a reused connection. + */ + multistate(data, MSTATE_DO); + return CURLM_CALL_MULTI_PERFORM; + } + if(!*result) + *result = protocol_connect(data, &protocol_connected); + if(!*result && !protocol_connected) { + /* switch to waiting state */ + multistate(data, MSTATE_PROTOCONNECTING); + return CURLM_CALL_MULTI_PERFORM; + } + else if(!*result) { + /* protocol connect has completed, go WAITDO or DO */ + multistate(data, MSTATE_DO); + return CURLM_CALL_MULTI_PERFORM; + } + + /* failure detected */ + multi_posttransfer(data); + multi_done(data, *result, TRUE); + *stream_error = TRUE; + return CURLM_OK; +} + +static CURLMcode multistate_protoconnecting(struct Curl_easy *data, + bool *stream_error, + CURLcode *result) +{ + bool protocol_connected = FALSE; + + /* protocol-specific connect phase */ + *result = protocol_connecting(data, &protocol_connected); + if(!*result && protocol_connected) { + /* after the connect has completed, go WAITDO or DO */ + multistate(data, MSTATE_DO); + return CURLM_CALL_MULTI_PERFORM; + } + else if(*result) { + /* failure detected */ + multi_posttransfer(data); + multi_done(data, *result, TRUE); + *stream_error = TRUE; + } + return CURLM_OK; +} + +static CURLMcode multistate_doing(struct Curl_easy *data, + bool *stream_error, + CURLcode *result) +{ + bool dophase_done = FALSE; + + /* we continue DOING until the DO phase is complete */ + DEBUGASSERT(data->conn); + *result = protocol_doing(data, &dophase_done); + if(!*result) { + if(dophase_done) { + /* after DO, go DO_DONE or DO_MORE */ + multistate(data, data->conn->bits.do_more ? + MSTATE_DOING_MORE : MSTATE_DID); + return CURLM_CALL_MULTI_PERFORM; + } /* dophase_done */ + } + else { + /* failure detected */ + multi_posttransfer(data); + multi_done(data, *result, FALSE); + *stream_error = TRUE; + } + return CURLM_OK; +} + +static CURLMcode multistate_doing_more(struct Curl_easy *data, + bool *stream_error, + CURLcode *result) +{ + domore control; + + /* + * When we are connected, DOING MORE and then go DID + */ + DEBUGASSERT(data->conn); + *result = multi_do_more(data, &control); + + if(!*result) { + if(control != DOMORE_INCOMPLETE) { + /* if DONE, advance to DO_DONE + if GOBACK, go back to DOING */ + multistate(data, control == DOMORE_DONE ? MSTATE_DID : MSTATE_DOING); + return CURLM_CALL_MULTI_PERFORM; + } + /* else + stay in DO_MORE */ + } + else { + /* failure detected */ + multi_posttransfer(data); + multi_done(data, *result, FALSE); + *stream_error = TRUE; + } + return CURLM_OK; +} + +static CURLMcode multistate_did(struct Curl_multi *multi, + struct Curl_easy *data) +{ + DEBUGASSERT(data->conn); + if(data->conn->bits.multiplex) + /* Check if we can move pending requests to send pipe */ + process_pending_handles(multi); /* multiplexed */ + + /* Only perform the transfer if there is a good socket to work with. + Having both BAD is a signal to skip immediately to DONE */ + if(CONN_SOCK_IDX_VALID(data->conn->recv_idx) || + CONN_SOCK_IDX_VALID(data->conn->send_idx)) + multistate(data, MSTATE_PERFORMING); + else { +#ifndef CURL_DISABLE_FTP + if(data->state.wildcardmatch && + ((data->conn->scheme->flags & PROTOPT_WILDCARD) == 0)) { + data->wildcard->state = CURLWC_DONE; + } +#endif + multistate(data, MSTATE_DONE); + } + return CURLM_CALL_MULTI_PERFORM; +} + +static CURLMcode multistate_done(struct Curl_easy *data, CURLcode *presult) +{ + if(data->conn) { + CURLcode result; + + /* post-transfer command */ + result = multi_done(data, *presult, FALSE); + + /* allow a previously set error code take precedence */ + if(!(*presult)) + *presult = result; + } + +#ifndef CURL_DISABLE_FTP + if(data->state.wildcardmatch) { + if(data->wildcard->state != CURLWC_DONE) { + /* if a wildcard is set and we are not ending -> lets start again + with MSTATE_INIT */ + multistate(data, MSTATE_INIT); + return CURLM_CALL_MULTI_PERFORM; + } + } +#endif + /* after we have DONE what we are supposed to do, go COMPLETED, and + it does not matter what the multi_done() returned! */ + multistate(data, MSTATE_COMPLETED); + return CURLM_CALL_MULTI_PERFORM; +} + +static CURLMcode multi_runsingle(struct Curl_multi *multi, + struct Curl_easy *data, + struct Curl_sigpipe_ctx *sigpipe_ctx) +{ + CURLMcode mresult; + CURLcode result = CURLE_OK; + + if(!GOOD_EASY_HANDLE(data)) + return CURLM_BAD_EASY_HANDLE; + + if(multi->dead) { + /* a multi-level callback returned error before, meaning every individual + transfer now has failed */ + result = CURLE_ABORTED_BY_CALLBACK; + multi_posttransfer(data); + multi_done(data, result, FALSE); + multistate(data, MSTATE_COMPLETED); + } + + multi_warn_debug(multi, data); + + /* transfer runs now, clear the dirty bit. This may be set + * again during processing, triggering a re-run later. */ + Curl_uint32_bset_remove(&multi->dirty, data->mid); + + if(data == multi->admin) { +#ifdef ENABLE_WAKEUP + /* Consume any pending wakeup signals before processing. + * This is necessary for event based processing. See #21547 */ + (void)Curl_wakeup_consume(multi->wakeup_pair, TRUE); +#endif +#ifdef USE_RESOLV_THREADED + Curl_async_thrdd_multi_process(multi); +#endif + Curl_cshutdn_perform(&multi->cshutdn, multi->admin, sigpipe_ctx); + return CURLM_OK; + } + + sigpipe_apply(data, sigpipe_ctx); + do { + /* A "stream" here is a logical stream if the protocol can handle that + (HTTP/2), or the full connection for older protocols */ + bool stream_error = FALSE; + mresult = CURLM_OK; + + if(multi_ischanged(multi, TRUE)) { + CURL_TRC_M(data, "multi changed, check CONNECT_PEND queue"); + process_pending_handles(multi); /* multiplexed */ + } + + if(data->mstate > MSTATE_CONNECT && + data->mstate < MSTATE_COMPLETED) { + /* Make sure we set the connection's current owner */ + DEBUGASSERT(data->conn); + if(!data->conn) + return CURLM_INTERNAL_ERROR; + } + + /* Wait for the connect state as only then is the start time stored, but + we must not check already completed handles */ + if((data->mstate >= MSTATE_CONNECT) && (data->mstate < MSTATE_COMPLETED) && + multi_handle_timeout(data, &stream_error, &result)) + /* Skip the statemachine and go directly to error handling section. */ + goto statemachine_end; + + switch(data->mstate) { + case MSTATE_INIT: + /* Transitional state. init this transfer. A handle never comes back to + this state. */ + mresult = multistate_init(data, &result); + break; + + case MSTATE_SETUP: + /* Transitional state. Setup things for a new transfer. The handle + can come back to this state on a redirect. */ + mresult = multistate_setup(data); + break; + + case MSTATE_CONNECT: + mresult = multistate_connect(multi, data, &result); + break; + + case MSTATE_CONNECTING: + /* awaiting a completion of an asynch TCP connect */ + mresult = multistate_connecting(data, &stream_error, &result); + break; + + case MSTATE_PROTOCONNECT: + mresult = multistate_protoconnect(data, &stream_error, &result); + break; + + case MSTATE_PROTOCONNECTING: + /* protocol-specific connect phase */ + mresult = multistate_protoconnecting(data, &stream_error, &result); + break; + + case MSTATE_DO: + mresult = multistate_do(data, &stream_error, &result); + break; + + case MSTATE_DOING: + /* we continue DOING until the DO phase is complete */ + mresult = multistate_doing(data, &stream_error, &result); + break; + + case MSTATE_DOING_MORE: + /* + * When we are connected, DOING MORE and then go DID + */ + mresult = multistate_doing_more(data, &stream_error, &result); + break; + + case MSTATE_DID: + mresult = multistate_did(multi, data); + break; + + case MSTATE_RATELIMITING: /* limit-rate exceeded in either direction */ + mresult = multistate_ratelimiting(data, &result); + break; + + case MSTATE_PERFORMING: + mresult = multistate_performing(data, &stream_error, &result); + break; + + case MSTATE_DONE: + mresult = multistate_done(data, &result); + break; + + case MSTATE_COMPLETED: + break; + + case MSTATE_PENDING: + case MSTATE_MSGSENT: + /* handles in these states should NOT be in this list */ + break; + + default: + return CURLM_INTERNAL_ERROR; + } + + if(data->mstate >= MSTATE_CONNECT && + data->mstate < MSTATE_DO && + mresult != CURLM_CALL_MULTI_PERFORM && + !multi_ischanged(multi, FALSE)) { + /* We now handle stream timeouts if and only if this will be the last + * loop iteration. We only check this on the last iteration to ensure + * that if we know we have additional work to do immediately + * (i.e. CURLM_CALL_MULTI_PERFORM == TRUE) then we should do that before + * declaring the connection timed out as we may almost have a completed + * connection. */ + multi_handle_timeout(data, &stream_error, &result); + } + +statemachine_end: + + result = is_finished(multi, data, stream_error, result); + if(result) + mresult = CURLM_CALL_MULTI_PERFORM; + + if(MSTATE_COMPLETED == data->mstate) { + handle_completed(multi, data, result); + return CURLM_OK; + } + } while((mresult == CURLM_CALL_MULTI_PERFORM) || + multi_ischanged(multi, FALSE)); + + data->result = result; + return mresult; +} + +static CURLMcode multi_perform(struct Curl_multi *multi, + int *running_handles) +{ + CURLMcode returncode = CURLM_OK; + struct curltime start = *multi_now(multi); + uint32_t mid; + struct Curl_sigpipe_ctx sigpipe_ctx; + + if(multi->in_callback) + return CURLM_RECURSIVE_API_CALL; + + if(multi->in_ntfy_callback) + return CURLM_RECURSIVE_API_CALL; + + sigpipe_init(&sigpipe_ctx); + + if(Curl_uint32_bset_first(&multi->process, &mid)) { + CURL_TRC_M(multi->admin, "multi_perform(running=%u)", + Curl_multi_xfers_running(multi)); + do { + struct Curl_easy *data = Curl_multi_get_easy(multi, mid); + CURLMcode mresult; + if(!data) { + DEBUGASSERT(0); + Curl_uint32_bset_remove(&multi->process, mid); + Curl_uint32_bset_remove(&multi->dirty, mid); + continue; + } + mresult = multi_runsingle(multi, data, &sigpipe_ctx); + if(mresult) + returncode = mresult; + } while(Curl_uint32_bset_next(&multi->process, mid, &mid)); + } + sigpipe_restore(&sigpipe_ctx); + + if(multi_ischanged(multi, TRUE)) + process_pending_handles(multi); + + if(!returncode && CURL_MNTFY_HAS_ENTRIES(multi)) + returncode = Curl_mntfy_dispatch_all(multi); + + /* + * Remove all expired timers from the splay since handles are dealt + * with unconditionally by this function and curl_multi_timeout() requires + * that already passed/handled expire times are removed from the splay. + * + * It is important that the 'now' value is set at the entry of this function + * and not for the current time as it may have ticked a little while since + * then and then we risk this loop to remove timers that actually have not + * been handled! + */ + if(multi->timetree) { + struct Curl_tree *t = NULL; + do { + multi->timetree = Curl_splaygetbest(&start, multi->timetree, &t); + if(t) { + /* the removed may have another timeout in queue */ + struct Curl_easy *data = Curl_splayget(t); + (void)add_next_timeout(&start, multi, data); + if(data->mstate == MSTATE_PENDING) { + bool stream_unused; + CURLcode result_unused; + if(multi_handle_timeout(data, &stream_unused, &result_unused)) { + infof(data, "PENDING handle timeout"); + move_pending_to_connect(multi, data); + } + } + } + } while(t); + } + + if(running_handles) { + unsigned int running = Curl_multi_xfers_running(multi); + *running_handles = (running < INT_MAX) ? (int)running : INT_MAX; + } + + if(CURLM_OK >= returncode) + returncode = Curl_update_timer(multi); + + return returncode; +} + +CURLMcode curl_multi_perform(CURLM *m, int *running_handles) +{ + struct Curl_multi *multi = m; + + if(!GOOD_MULTI_HANDLE(multi)) + return CURLM_BAD_HANDLE; + + return multi_perform(multi, running_handles); +} + +CURLMcode curl_multi_cleanup(CURLM *m) +{ + struct Curl_multi *multi = m; + if(GOOD_MULTI_HANDLE(multi)) { + void *entry; + uint32_t mid; + if(multi->in_callback) + return CURLM_RECURSIVE_API_CALL; + if(multi->in_ntfy_callback) + return CURLM_RECURSIVE_API_CALL; + + /* First remove all remaining easy handles, + * close internal ones. admin handle is special */ + if(Curl_uint32_tbl_first(&multi->xfers, &mid, &entry)) { + do { + struct Curl_easy *data = entry; + if(!GOOD_EASY_HANDLE(data)) + return CURLM_BAD_HANDLE; + +#ifdef DEBUGBUILD + if(mid != data->mid) { + CURL_TRC_M(data, "multi_cleanup: still present with mid=%u, " + "but unexpected data->mid=%u\n", mid, data->mid); + DEBUGASSERT(0); + } +#endif + + if(data == multi->admin) + continue; + + if(!data->state.done && data->conn) + /* if DONE was never called for this handle */ + (void)multi_done(data, CURLE_OK, TRUE); + + data->multi = NULL; /* clear the association */ + Curl_uint32_tbl_remove(&multi->xfers, mid); + data->mid = UINT32_MAX; + +#ifdef USE_LIBPSL + if(data->psl == &multi->psl) + data->psl = NULL; +#endif + if(data->state.internal) + Curl_close(&data); + } while(Curl_uint32_tbl_next(&multi->xfers, mid, &mid, &entry)); + } + +#ifdef USE_RESOLV_THREADED + Curl_async_thrdd_multi_destroy(multi, !multi->quick_exit); +#endif + Curl_cpool_destroy(&multi->cpool); + Curl_cshutdn_destroy(&multi->cshutdn, multi->admin); + if(multi->admin) { + CURL_TRC_M(multi->admin, "multi_cleanup, closing admin handle, done"); + multi->admin->multi = NULL; + Curl_uint32_tbl_remove(&multi->xfers, multi->admin->mid); + Curl_close(&multi->admin); + } + + multi->magic = 0; /* not good anymore */ + + Curl_multi_ev_cleanup(multi); + Curl_hash_destroy(&multi->proto_hash); + Curl_dnscache_destroy(&multi->dnscache); + Curl_psl_destroy(&multi->psl); +#ifdef USE_SSL + Curl_ssl_scache_destroy(multi->ssl_scache); +#endif + +#ifdef USE_WINSOCK + WSACloseEvent(multi->wsa_event); +#endif +#ifdef ENABLE_WAKEUP + Curl_wakeup_destroy(multi->wakeup_pair); +#endif + + multi_xfer_bufs_free(multi); + Curl_mntfy_cleanup(multi); +#ifdef DEBUGBUILD + if(Curl_uint32_tbl_count(&multi->xfers)) { + multi_xfer_tbl_dump(multi); + DEBUGASSERT(0); + } +#endif + Curl_uint32_bset_destroy(&multi->process); + Curl_uint32_bset_destroy(&multi->dirty); + Curl_uint32_bset_destroy(&multi->pending); + Curl_uint32_bset_destroy(&multi->msgsent); + Curl_uint32_tbl_destroy(&multi->xfers); + curlx_free(multi); + + return CURLM_OK; + } + return CURLM_BAD_HANDLE; +} + +/* + * curl_multi_info_read() + * + * This function is the primary way for a multi/multi_socket application to + * figure out if a transfer has ended. We MUST make this function as fast as + * possible as it will be polled frequently and we MUST NOT scan any lists in + * here to figure out things. We must scale fine to thousands of handles and + * beyond. The current design is fully O(1). + */ + +CURLMsg *curl_multi_info_read(CURLM *m, int *msgs_in_queue) +{ + struct Curl_message *msg; + struct Curl_multi *multi = m; + + *msgs_in_queue = 0; /* default to none */ + + if(GOOD_MULTI_HANDLE(multi) && + !multi->in_callback && + Curl_llist_count(&multi->msglist)) { + /* there is one or more messages in the list */ + struct Curl_llist_node *e; + + /* extract the head of the list to return */ + e = Curl_llist_head(&multi->msglist); + + msg = Curl_node_elem(e); + + /* remove the extracted entry */ + Curl_node_remove(e); + + *msgs_in_queue = curlx_uztosi(Curl_llist_count(&multi->msglist)); + + return &msg->extmsg; + } + return NULL; +} + +void Curl_multi_will_close(struct Curl_easy *data, curl_socket_t s) +{ + if(data) { + struct Curl_multi *multi = data->multi; + if(multi) { + CURL_TRC_M(data, "Curl_multi_will_close fd=%" FMT_SOCKET_T, s); + Curl_multi_ev_socket_done(multi, data, s); + } + } +} + +/* + * add_next_timeout() + * + * Each Curl_easy has a list of timeouts. The add_next_timeout() is called + * when it has been removed from the splay tree because the timeout has + * expired. This function is then to advance in the list to pick the next + * timeout to use (skip the already expired ones) and add this node back to + * the splay tree again. + * + * The splay tree only has each sessionhandle as a single node and the nearest + * timeout is used to sort it on. + */ +static CURLMcode add_next_timeout(const struct curltime *pnow, + struct Curl_multi *multi, + struct Curl_easy *d) +{ + struct curltime *tv = &d->state.expiretime; + struct Curl_llist *list = &d->state.timeoutlist; + struct Curl_llist_node *e; + + /* move over the timeout list for this specific handle and remove all + timeouts that are now passed tense and store the next pending + timeout in *tv */ + for(e = Curl_llist_head(list); e;) { + struct Curl_llist_node *n = Curl_node_next(e); + struct time_node *node = Curl_node_elem(e); + timediff_t diff = curlx_ptimediff_us(&node->time, pnow); + if(diff <= 0) + /* remove outdated entry */ + Curl_node_remove(e); + else + /* the list is sorted so get out on the first mismatch */ + break; + e = n; + } + e = Curl_llist_head(list); + if(!e) { + /* clear the expire times within the handles that we remove from the + splay tree */ + tv->tv_sec = 0; + tv->tv_usec = 0; + } + else { + struct time_node *node = Curl_node_elem(e); + /* copy the first entry to 'tv' */ + memcpy(tv, &node->time, sizeof(*tv)); + + /* Insert this node again into the splay. Keep the timer in the list in + case we need to recompute future timers. */ + multi->timetree = Curl_splayinsert(tv, multi->timetree, + &d->state.timenode); + } + return CURLM_OK; +} + +static void multi_mark_expired_as_dirty(struct Curl_multi *multi, + const struct curltime *ts) +{ + struct Curl_easy *data = NULL; + struct Curl_tree *t = NULL; + + /* + * The loop following here will go on as long as there are expire-times left + * to process (compared to `ts`) in the splay and 'data' will be + * re-assigned for every expired handle we deal with. + */ + while(1) { + /* Check if there is one (more) expired timer to deal with! This function + extracts a matching node if there is one */ + multi->timetree = Curl_splaygetbest(ts, multi->timetree, &t); + if(!t) + return; + + data = Curl_splayget(t); /* assign this for next loop */ + if(!data) + continue; +#ifdef CURLVERBOSE + if(CURL_TRC_TIMER_is_verbose(data)) { + struct Curl_llist_node *e = Curl_llist_head(&data->state.timeoutlist); + if(e) { + struct time_node *n = Curl_node_elem(e); + CURL_TRC_TIMER(data, n->eid, "has expired"); + } + } +#endif + (void)add_next_timeout(ts, multi, data); + Curl_multi_mark_dirty(data); + } +} + +static CURLMcode multi_run_dirty(struct Curl_multi *multi, + struct Curl_sigpipe_ctx *sigpipe_ctx, + uint32_t *pnum) +{ + CURLMcode mresult = CURLM_OK; + uint32_t mid; + + *pnum = 0; + if(Curl_uint32_bset_first(&multi->dirty, &mid)) { + do { + struct Curl_easy *data = Curl_multi_get_easy(multi, mid); + if(data) { + CURL_TRC_M(data, "multi_run_dirty"); + + if(!Curl_uint32_bset_contains(&multi->process, mid)) { + /* We are no longer processing this transfer */ + Curl_uint32_bset_remove(&multi->dirty, mid); + continue; + } + + (*pnum)++; + /* runsingle() clears the dirty mid */ + mresult = multi_runsingle(multi, data, sigpipe_ctx); + + if(CURLM_OK >= mresult) { + /* reassess event handling of data */ + mresult = Curl_multi_ev_assess_xfer(multi, data); + if(mresult) + goto out; + } + } + else { + CURL_TRC_M(multi->admin, "multi_run_dirty, %u no longer found", mid); + Curl_uint32_bset_remove(&multi->dirty, mid); + } + } while(Curl_uint32_bset_next(&multi->dirty, mid, &mid)); + } + +out: + return mresult; +} + +static CURLMcode multi_socket(struct Curl_multi *multi, + bool checkall, + curl_socket_t s, + int ev_bitmask, + int *running_handles) +{ + CURLMcode mresult = CURLM_OK; + struct Curl_sigpipe_ctx pipe_ctx; + uint32_t run_xfers; + + (void)ev_bitmask; + sigpipe_init(&pipe_ctx); + + if(checkall) { + /* *perform() deals with running_handles on its own */ + mresult = multi_perform(multi, running_handles); + + if(mresult != CURLM_BAD_HANDLE) { + /* Reassess event status of all active transfers */ + mresult = Curl_multi_ev_assess_xfer_bset(multi, &multi->process); + } + goto out; + } + + if(s != CURL_SOCKET_TIMEOUT) { + /* Mark all transfers of that socket as dirty */ + Curl_multi_ev_dirty_xfers(multi, s); + } + else { + /* Asked to run due to time-out. Clear the 'last_expire_ts' variable to + force Curl_update_timer() to trigger a callback to the app again even + if the same timeout is still the one to run after this call. That + handles the case when the application asks libcurl to run the timeout + prematurely. */ + memset(&multi->last_expire_ts, 0, sizeof(multi->last_expire_ts)); + + /* Applications may set `socket_cb` *after* having added transfers + * first. *Then* kick off processing with a + * curl_multi_socket_action(TIMEOUT) afterwards. Make sure our + * admin handle registers its pollset with the callbacks present. */ + mresult = multi_assess_wakeup(multi); + if(mresult) + goto out; + } + + multi_mark_expired_as_dirty(multi, multi_now(multi)); + mresult = multi_run_dirty(multi, &pipe_ctx, &run_xfers); + if(mresult) + goto out; + + if(run_xfers) { + /* Running transfers takes time. With a new timestamp, we might catch + * other expires which are due now. Instead of telling the application + * to set a 0 timeout and call us again, we run them here. + * Do that only once or it might be unfair to transfers on other + * sockets. */ + multi_mark_expired_as_dirty(multi, &multi->now); + mresult = multi_run_dirty(multi, &pipe_ctx, &run_xfers); + } + +out: + sigpipe_restore(&pipe_ctx); + + if(multi_ischanged(multi, TRUE)) + process_pending_handles(multi); + + if(!mresult && CURL_MNTFY_HAS_ENTRIES(multi)) + mresult = Curl_mntfy_dispatch_all(multi); + + if(running_handles) { + unsigned int running = Curl_multi_xfers_running(multi); + *running_handles = (running < INT_MAX) ? (int)running : INT_MAX; + } + + if(CURLM_OK >= mresult) + mresult = Curl_update_timer(multi); + return mresult; +} + +#undef curl_multi_setopt +CURLMcode curl_multi_setopt(CURLM *m, CURLMoption option, ...) +{ + CURLMcode mresult = CURLM_OK; + va_list param; + unsigned long uarg; + struct Curl_multi *multi = m; + + if(!GOOD_MULTI_HANDLE(multi)) + return CURLM_BAD_HANDLE; + + if(multi->in_callback) + return CURLM_RECURSIVE_API_CALL; + + va_start(param, option); + + switch(option) { + case CURLMOPT_SOCKETFUNCTION: + multi->socket_cb = va_arg(param, curl_socket_callback); + break; + case CURLMOPT_SOCKETDATA: + multi->socket_userp = va_arg(param, void *); + break; + case CURLMOPT_PUSHFUNCTION: + multi->push_cb = va_arg(param, curl_push_callback); + break; + case CURLMOPT_PUSHDATA: + multi->push_userp = va_arg(param, void *); + break; + case CURLMOPT_PIPELINING: + multi->multiplexing = va_arg(param, long) & CURLPIPE_MULTIPLEX ? 1 : 0; + break; + case CURLMOPT_TIMERFUNCTION: + multi->timer_cb = va_arg(param, curl_multi_timer_callback); + break; + case CURLMOPT_TIMERDATA: + multi->timer_userp = va_arg(param, void *); + break; + case CURLMOPT_MAXCONNECTS: + uarg = va_arg(param, unsigned long); + if(uarg <= UINT_MAX) + multi->maxconnects = (unsigned int)uarg; + break; + case CURLMOPT_MAX_HOST_CONNECTIONS: + if(!curlx_sltouz(va_arg(param, long), &multi->max_host_connections)) + mresult = CURLM_BAD_FUNCTION_ARGUMENT; + break; + case CURLMOPT_MAX_TOTAL_CONNECTIONS: + if(!curlx_sltouz(va_arg(param, long), &multi->max_total_connections)) + mresult = CURLM_BAD_FUNCTION_ARGUMENT; + break; + /* options formerly used for pipelining */ + case CURLMOPT_MAX_PIPELINE_LENGTH: + break; + case CURLMOPT_CONTENT_LENGTH_PENALTY_SIZE: + break; + case CURLMOPT_CHUNK_LENGTH_PENALTY_SIZE: + break; + case CURLMOPT_PIPELINING_SITE_BL: + break; + case CURLMOPT_PIPELINING_SERVER_BL: + break; + case CURLMOPT_MAX_CONCURRENT_STREAMS: { + long streams = va_arg(param, long); + if((streams < 1) || (streams > INT_MAX)) + streams = 100; + multi->max_concurrent_streams = (unsigned int)streams; + break; + } + case CURLMOPT_NETWORK_CHANGED: { + long val = va_arg(param, long); + if(val & CURLMNWC_CLEAR_ALL) + /* In the beginning, all values available to set were 1 by mistake. We + converted this to mean "all", thus setting all the bits + automatically */ + val = CURLMNWC_CLEAR_DNS | CURLMNWC_CLEAR_CONNS; + if(val & CURLMNWC_CLEAR_DNS) { + Curl_dnscache_clear(multi->admin); + } + if(val & CURLMNWC_CLEAR_CONNS) { + Curl_cpool_nw_changed(multi->admin); + } + break; + } + case CURLMOPT_NOTIFYFUNCTION: + multi->ntfy.ntfy_cb = va_arg(param, curl_notify_callback); + break; + case CURLMOPT_NOTIFYDATA: + multi->ntfy.ntfy_cb_data = va_arg(param, void *); + break; + case CURLMOPT_RESOLVE_THREADS_MAX: +#ifdef USE_RESOLV_THREADED + uarg = va_arg(param, long); + if((uarg <= 0) || (uarg > UINT32_MAX)) + mresult = CURLM_BAD_FUNCTION_ARGUMENT; + else { + CURLcode result = Curl_async_thrdd_multi_set_props( + multi, 0, (uint32_t)uarg, 2000); + switch(result) { + case CURLE_OK: + mresult = CURLM_OK; + break; + case CURLE_BAD_FUNCTION_ARGUMENT: + mresult = CURLM_BAD_FUNCTION_ARGUMENT; + break; + case CURLE_OUT_OF_MEMORY: + mresult = CURLM_OUT_OF_MEMORY; + break; + default: + mresult = CURLM_INTERNAL_ERROR; + break; + } + } +#endif + break; + case CURLMOPT_QUICK_EXIT: + multi->quick_exit = va_arg(param, long) ? 1 : 0; + break; + default: + mresult = CURLM_UNKNOWN_OPTION; + break; + } + va_end(param); + return mresult; +} + +/* we define curl_multi_socket() in the public multi.h header */ +#undef curl_multi_socket + +CURLMcode curl_multi_socket(CURLM *m, curl_socket_t s, int *running_handles) +{ + struct Curl_multi *multi = m; + if(multi->in_callback) + return CURLM_RECURSIVE_API_CALL; + if(multi->in_ntfy_callback) + return CURLM_RECURSIVE_API_CALL; + return multi_socket(multi, FALSE, s, 0, running_handles); +} + +CURLMcode curl_multi_socket_action(CURLM *m, curl_socket_t s, + int ev_bitmask, int *running_handles) +{ + struct Curl_multi *multi = m; + if(multi->in_callback) + return CURLM_RECURSIVE_API_CALL; + if(multi->in_ntfy_callback) + return CURLM_RECURSIVE_API_CALL; + return multi_socket(multi, FALSE, s, ev_bitmask, running_handles); +} + +CURLMcode curl_multi_socket_all(CURLM *m, int *running_handles) +{ + struct Curl_multi *multi = m; + if(multi->in_callback) + return CURLM_RECURSIVE_API_CALL; + if(multi->in_ntfy_callback) + return CURLM_RECURSIVE_API_CALL; + return multi_socket(multi, TRUE, CURL_SOCKET_BAD, 0, running_handles); +} + +static bool multi_has_dirties(struct Curl_multi *multi) +{ + uint32_t mid; + if(Curl_uint32_bset_first(&multi->dirty, &mid)) { + do { + struct Curl_easy *data = Curl_multi_get_easy(multi, mid); + if(data) { + if(Curl_uint32_bset_contains(&multi->process, mid)) + return TRUE; + /* We are no longer processing this transfer */ + Curl_uint32_bset_remove(&multi->dirty, mid); + } + else { + CURL_TRC_M(multi->admin, "dirty transfer %u no longer found", mid); + Curl_uint32_bset_remove(&multi->dirty, mid); + } + } while(Curl_uint32_bset_next(&multi->dirty, mid, &mid)); + } + return FALSE; +} + +static void multi_timeout(struct Curl_multi *multi, + struct curltime *expire_time, + long *timeout_ms) +{ + static const struct curltime tv_zero = { 0, 0 }; + VERBOSE(struct Curl_easy *data = NULL); + + if(multi->dead) { + *timeout_ms = 0; + return; + } + + if(multi_has_dirties(multi)) { + *expire_time = *multi_now(multi); + *timeout_ms = 0; + return; + } + else if(multi->timetree) { + const struct curltime *pnow = multi_now(multi); + /* splay the lowest to the bottom */ + multi->timetree = Curl_splay(&tv_zero, multi->timetree); + /* this will not return NULL from a non-empty tree, but some compilers + * are not convinced of that. Analyzers are hard. */ + *expire_time = multi->timetree ? multi->timetree->key : tv_zero; + + /* 'multi->timetree' will be non-NULL here but the compilers sometimes + yell at us if we assume so */ + if(multi->timetree && + curlx_ptimediff_us(&multi->timetree->key, pnow) > 0) { + /* some time left before expiration */ + timediff_t diff_ms = + curlx_timediff_ceil_ms(multi->timetree->key, *pnow); + VERBOSE(data = Curl_splayget(multi->timetree)); + /* this should be safe even on 32-bit archs, as we do not use that + overly long timeouts */ + *timeout_ms = (long)diff_ms; + } + else { + if(multi->timetree) + VERBOSE(data = Curl_splayget(multi->timetree)); + /* 0 means immediately */ + *timeout_ms = 0; + } + } + else { + *expire_time = tv_zero; + *timeout_ms = -1; + } + +#ifdef CURLVERBOSE + if(CURL_TRC_TIMER_is_verbose(data)) { + struct Curl_llist_node *e = Curl_llist_head(&data->state.timeoutlist); + if(e) { + struct time_node *n = Curl_node_elem(e); + CURL_TRC_TIMER(data, n->eid, "gives multi timeout in %ldms", + *timeout_ms); + } + } +#endif +} + +CURLMcode curl_multi_timeout(CURLM *m, + long *timeout_ms) +{ + struct curltime expire_time; + struct Curl_multi *multi = m; + + /* First, make some basic checks that the CURLM handle is a good handle */ + if(!GOOD_MULTI_HANDLE(multi)) + return CURLM_BAD_HANDLE; + + if(multi->in_callback) + return CURLM_RECURSIVE_API_CALL; + + multi_timeout(multi, &expire_time, timeout_ms); + return CURLM_OK; +} + +/* + * Tell the application it should update its timers, if it subscribes to the + * update timer callback. + */ +CURLMcode Curl_update_timer(struct Curl_multi *multi) +{ + struct curltime expire_ts; + long timeout_ms; + int rc; + bool set_value = FALSE; + + if(!multi->timer_cb || multi->dead) + return CURLM_OK; + multi_timeout(multi, &expire_ts, &timeout_ms); + + if(timeout_ms < 0 && multi->last_timeout_ms < 0) { + /* nothing to do */ + } + else if(timeout_ms < 0) { + /* there is no timeout now but there was one previously */ + CURL_TRC_M(multi->admin, "[TIMER] clear"); + timeout_ms = -1; /* normalize */ + set_value = TRUE; + } + else if(multi->last_timeout_ms < 0) { + CURL_TRC_M(multi->admin, "[TIMER] set %ldms, none before", timeout_ms); + set_value = TRUE; + } + else if(curlx_ptimediff_us(&multi->last_expire_ts, &expire_ts)) { + /* We had a timeout before and have one now, the absolute timestamp + * differs. The relative timeout_ms may be the same, but the starting + * point differs. Let the application restart its timer. */ + CURL_TRC_M(multi->admin, "[TIMER] set %ldms, replace previous", + timeout_ms); + set_value = TRUE; + } + else { + /* We have same expire time as previously. Our relative 'timeout_ms' + * may be different now, but the application has the timer running + * and we do not to tell it to start this again. */ + } + + if(set_value) { + multi->last_expire_ts = expire_ts; + multi->last_timeout_ms = timeout_ms; + set_in_callback(multi, TRUE); + rc = multi->timer_cb(multi, timeout_ms, multi->timer_userp); + set_in_callback(multi, FALSE); + if(rc == -1) { + multi->dead = TRUE; + return CURLM_ABORTED_BY_CALLBACK; + } + } + return CURLM_OK; +} + +/* + * multi_deltimeout() + * + * Remove a given timestamp from the list of timeouts. + */ +static void multi_deltimeout(struct Curl_easy *data, expire_id eid) +{ + struct Curl_llist_node *e; + struct Curl_llist *timeoutlist = &data->state.timeoutlist; + /* find and remove the specific node from the list */ + for(e = Curl_llist_head(timeoutlist); e; e = Curl_node_next(e)) { + struct time_node *n = Curl_node_elem(e); + if(n->eid == eid) { + Curl_node_remove(e); + return; + } + } +} + +/* + * multi_addtimeout() + * + * Add a timestamp to the list of timeouts. Keep the list sorted so that head + * of list is always the timeout nearest in time. + * + */ +static CURLMcode multi_addtimeout(struct Curl_easy *data, + struct curltime *stamp, + expire_id eid) +{ + struct Curl_llist_node *e; + struct time_node *node; + struct Curl_llist_node *prev = NULL; + size_t n; + struct Curl_llist *timeoutlist = &data->state.timeoutlist; + + node = &data->state.expires[eid]; + + /* copy the timestamp and id */ + memcpy(&node->time, stamp, sizeof(*stamp)); + node->eid = eid; /* also marks it as in use */ + + n = Curl_llist_count(timeoutlist); + if(n) { + /* find the correct spot in the list */ + for(e = Curl_llist_head(timeoutlist); e; e = Curl_node_next(e)) { + struct time_node *check = Curl_node_elem(e); + timediff_t diff = curlx_ptimediff_ms(&check->time, &node->time); + if(diff > 0) + break; + prev = e; + } + } + /* else + this is the first timeout on the list */ + + Curl_llist_insert_next(timeoutlist, prev, node, &node->list); + CURL_TRC_TIMER(data, eid, "set for %" FMT_TIMEDIFF_T "ns", + curlx_ptimediff_us(&node->time, Curl_pgrs_now(data))); + return CURLM_OK; +} + +void Curl_expire_ex(struct Curl_easy *data, + timediff_t milli, expire_id id) +{ + struct Curl_multi *multi = data->multi; + struct curltime *curr_expire = &data->state.expiretime; + struct curltime set; + + /* this is only interesting while there is still an associated multi struct + remaining! */ + if(!multi) + return; + + DEBUGASSERT(id < EXPIRE_LAST); + + set = *Curl_pgrs_now(data); + set.tv_sec += (time_t)(milli / 1000); /* may be a 64 to 32-bit conversion */ + set.tv_usec += (int)(milli % 1000) * 1000; + + if(set.tv_usec >= 1000000) { + set.tv_sec++; + set.tv_usec -= 1000000; + } + + /* Remove any timer with the same id */ + multi_deltimeout(data, id); + + /* Add it to the timer list. It must stay in the list until it has expired + in case we need to recompute the minimum timer later. */ + multi_addtimeout(data, &set, id); + + if(curr_expire->tv_sec || curr_expire->tv_usec) { + /* This means that the struct is added as a node in the splay tree. + Compare if the new time is earlier, and only remove-old/add-new if it + is. */ + timediff_t diff = curlx_ptimediff_ms(&set, curr_expire); + int rc; + + if(diff > 0) { + /* The current splay tree entry is sooner than this new expiry time. + We do not need to update our splay tree entry. */ + return; + } + + /* Since this is an updated time, we must remove the previous entry from + the splay tree first and then re-add the new value */ + rc = Curl_splayremove(multi->timetree, &data->state.timenode, + &multi->timetree); + if(rc) + infof(data, "Internal error removing splay node = %d", rc); + } + + /* Indicate that we are in the splay tree and insert the new timer expiry + value since it is our local minimum. */ + *curr_expire = set; + Curl_splayset(&data->state.timenode, data); + multi->timetree = Curl_splayinsert(curr_expire, multi->timetree, + &data->state.timenode); +} + +/* + * Curl_expire() + * + * given a number of milliseconds from now to use to set the 'act before + * this'-time for the transfer, to be extracted by curl_multi_timeout() + * + * The timeout will be added to a queue of timeouts if it defines a moment in + * time that is later than the current head of queue. + * + * Expire replaces a former timeout using the same id if already set. + */ +void Curl_expire(struct Curl_easy *data, timediff_t milli, expire_id id) +{ + Curl_expire_ex(data, milli, id); +} + +/* + * Curl_expire_done() + * + * Removes the expire timer. Marks it as done. + * + */ +void Curl_expire_done(struct Curl_easy *data, expire_id id) +{ + /* remove the timer, if there */ + multi_deltimeout(data, id); + CURL_TRC_TIMER(data, id, "cleared"); +} + +/* + * Curl_expire_clear() + * + * Clear ALL timeout values for this handle. + */ +void Curl_expire_clear(struct Curl_easy *data) +{ + struct Curl_multi *multi = data->multi; + struct curltime *nowp = &data->state.expiretime; + + /* this is only interesting while there is still an associated multi struct + remaining! */ + if(!multi) + return; + + if(nowp->tv_sec || nowp->tv_usec) { + /* Since this is an cleared time, we must remove the previous entry from + the splay tree */ + struct Curl_llist *list = &data->state.timeoutlist; + int rc; + + rc = Curl_splayremove(multi->timetree, &data->state.timenode, + &multi->timetree); + if(rc) + infof(data, "Internal error clearing splay node = %d", rc); + + /* clear the timeout list too */ + Curl_llist_destroy(list, NULL); + + if(data->id >= 0) + CURL_TRC_M(data, "[TIMEOUT] all cleared"); + nowp->tv_sec = 0; + nowp->tv_usec = 0; + } +} + +CURLMcode curl_multi_assign(CURLM *m, curl_socket_t sockfd, + void *sockp) +{ + struct Curl_multi *multi = m; + if(!GOOD_MULTI_HANDLE(multi)) + return CURLM_BAD_HANDLE; + + return Curl_multi_ev_assign(multi, sockfd, sockp); +} + +static void move_pending_to_connect(struct Curl_multi *multi, + struct Curl_easy *data) +{ + DEBUGASSERT(data->mstate == MSTATE_PENDING); + + /* Remove this node from the pending set, add into process set */ + Curl_uint32_bset_remove(&multi->pending, data->mid); + Curl_uint32_bset_add(&multi->process, data->mid); + + multistate(data, MSTATE_CONNECT); + Curl_multi_mark_dirty(data); /* make it run */ +} + +/* process_pending_handles() moves a handle from PENDING back into the process + list and change state to CONNECT. + + We do not move all transfers because that can be a significant amount. + Since this is tried every now and then doing too many too often becomes a + performance problem. + + When there is a change for connection limits like max host connections etc, + this likely only allows one new transfer. When there is a pipewait change, + it can potentially allow hundreds of new transfers. + + We could consider an improvement where we store the queue reason and allow + more pipewait rechecks than others. +*/ +static void process_pending_handles(struct Curl_multi *multi) +{ + uint32_t mid = multi->last_pending_mid; + + if(mid) { + while(Curl_uint32_bset_next(&multi->pending, mid, &mid)) { + struct Curl_easy *data = Curl_multi_get_easy(multi, mid); + if(data) { + move_pending_to_connect(multi, data); + multi->last_pending_mid = mid; + return; + } + /* transfer no longer known, should not happen */ + Curl_uint32_bset_remove(&multi->pending, mid); + DEBUGASSERT(0); + } + /* found no pending transfers with `mid` larger than `last_pending_mid`. + * Start at the beginning of the pending set again. */ + multi->last_pending_mid = 0; + } + + if(Curl_uint32_bset_first(&multi->pending, &mid)) { + do { + struct Curl_easy *data = Curl_multi_get_easy(multi, mid); + if(data) { + move_pending_to_connect(multi, data); + multi->last_pending_mid = mid; + return; + } + /* transfer no longer known, should not happen */ + Curl_uint32_bset_remove(&multi->pending, mid); + DEBUGASSERT(0); + } while(Curl_uint32_bset_next(&multi->pending, mid, &mid)); + } +} + +void Curl_set_in_callback(struct Curl_easy *data, bool value) +{ + if(data && data->multi) + data->multi->in_callback = value; +} + +bool Curl_is_in_callback(struct Curl_easy *data) +{ + return data && data->multi && data->multi->in_callback; +} + +unsigned int Curl_multi_max_concurrent_streams(struct Curl_multi *multi) +{ + DEBUGASSERT(multi); + return multi->max_concurrent_streams; +} + +CURL **curl_multi_get_handles(CURLM *m) +{ + struct Curl_multi *multi = m; + void *entry; + size_t count = Curl_uint32_tbl_count(&multi->xfers); + CURL **a = curlx_malloc(sizeof(struct Curl_easy *) * (count + 1)); + if(a) { + unsigned int i = 0; + uint32_t mid; + + if(Curl_uint32_tbl_first(&multi->xfers, &mid, &entry)) { + do { + struct Curl_easy *data = entry; + DEBUGASSERT(i < count); + if(!data->state.internal) + a[i++] = data; + } while(Curl_uint32_tbl_next(&multi->xfers, mid, &mid, &entry)); + } + a[i] = NULL; /* last entry is a NULL */ + } + return a; +} + +CURLMcode curl_multi_get_offt(CURLM *m, + CURLMinfo_offt info, + curl_off_t *pvalue) +{ + struct Curl_multi *multi = m; + uint32_t n; + + if(!GOOD_MULTI_HANDLE(multi)) + return CURLM_BAD_HANDLE; + if(!pvalue) + return CURLM_BAD_FUNCTION_ARGUMENT; + + switch(info) { + case CURLMINFO_XFERS_CURRENT: + n = Curl_uint32_tbl_count(&multi->xfers); + if(n && multi->admin) + --n; + *pvalue = (curl_off_t)n; + return CURLM_OK; + case CURLMINFO_XFERS_RUNNING: + n = Curl_uint32_bset_count(&multi->process); + if(n && Curl_uint32_bset_contains(&multi->process, multi->admin->mid)) + --n; + *pvalue = (curl_off_t)n; + return CURLM_OK; + case CURLMINFO_XFERS_PENDING: + *pvalue = (curl_off_t)Curl_uint32_bset_count(&multi->pending); + return CURLM_OK; + case CURLMINFO_XFERS_DONE: + *pvalue = (curl_off_t)Curl_uint32_bset_count(&multi->msgsent); + return CURLM_OK; + case CURLMINFO_XFERS_ADDED: + *pvalue = multi->xfers_total_ever; + return CURLM_OK; + default: + *pvalue = -1; + return CURLM_UNKNOWN_OPTION; + } +} + +CURLcode Curl_multi_xfer_buf_borrow(struct Curl_easy *data, + char **pbuf, size_t *pbuflen) +{ + DEBUGASSERT(data); + DEBUGASSERT(data->multi); + *pbuf = NULL; + *pbuflen = 0; + if(!data->multi) { + failf(data, "transfer has no multi handle"); + return CURLE_FAILED_INIT; + } + if(!data->set.buffer_size) { + failf(data, "transfer buffer size is 0"); + return CURLE_FAILED_INIT; + } + if(data->multi->xfer_buf_borrowed) { + failf(data, "attempt to borrow xfer_buf when already borrowed"); + return CURLE_AGAIN; + } + + if(data->multi->xfer_buf && + data->set.buffer_size > data->multi->xfer_buf_len) { + /* not large enough, get a new one */ + curlx_safefree(data->multi->xfer_buf); + data->multi->xfer_buf_len = 0; + } + + if(!data->multi->xfer_buf) { + data->multi->xfer_buf = curlx_malloc(curlx_uitouz(data->set.buffer_size)); + if(!data->multi->xfer_buf) { + failf(data, "could not allocate xfer_buf of %u bytes", + data->set.buffer_size); + return CURLE_OUT_OF_MEMORY; + } + data->multi->xfer_buf_len = data->set.buffer_size; + } + + data->multi->xfer_buf_borrowed = TRUE; + *pbuf = data->multi->xfer_buf; + *pbuflen = data->multi->xfer_buf_len; + return CURLE_OK; +} + +void Curl_multi_xfer_buf_release(struct Curl_easy *data, char *buf) +{ + (void)buf; + DEBUGASSERT(data); + DEBUGASSERT(data->multi); + DEBUGASSERT(!buf || data->multi->xfer_buf == buf); + data->multi->xfer_buf_borrowed = FALSE; +} + +CURLcode Curl_multi_xfer_ulbuf_borrow(struct Curl_easy *data, + char **pbuf, size_t *pbuflen) +{ + DEBUGASSERT(data); + DEBUGASSERT(data->multi); + *pbuf = NULL; + *pbuflen = 0; + if(!data->multi) { + failf(data, "transfer has no multi handle"); + return CURLE_FAILED_INIT; + } + if(!data->set.upload_buffer_size) { + failf(data, "transfer upload buffer size is 0"); + return CURLE_FAILED_INIT; + } + if(data->multi->xfer_ulbuf_borrowed) { + failf(data, "attempt to borrow xfer_ulbuf when already borrowed"); + return CURLE_AGAIN; + } + + if(data->multi->xfer_ulbuf && + data->set.upload_buffer_size > data->multi->xfer_ulbuf_len) { + /* not large enough, get a new one */ + curlx_safefree(data->multi->xfer_ulbuf); + data->multi->xfer_ulbuf_len = 0; + } + + if(!data->multi->xfer_ulbuf) { + data->multi->xfer_ulbuf = + curlx_malloc(curlx_uitouz(data->set.upload_buffer_size)); + if(!data->multi->xfer_ulbuf) { + failf(data, "could not allocate xfer_ulbuf of %u bytes", + data->set.upload_buffer_size); + return CURLE_OUT_OF_MEMORY; + } + data->multi->xfer_ulbuf_len = data->set.upload_buffer_size; + } + + data->multi->xfer_ulbuf_borrowed = TRUE; + *pbuf = data->multi->xfer_ulbuf; + *pbuflen = data->multi->xfer_ulbuf_len; + return CURLE_OK; +} + +void Curl_multi_xfer_ulbuf_release(struct Curl_easy *data, char *buf) +{ + (void)buf; + DEBUGASSERT(data); + DEBUGASSERT(data->multi); + DEBUGASSERT(!buf || data->multi->xfer_ulbuf == buf); + data->multi->xfer_ulbuf_borrowed = FALSE; +} + +CURLcode Curl_multi_xfer_sockbuf_borrow(struct Curl_easy *data, + size_t blen, char **pbuf) +{ + DEBUGASSERT(data); + *pbuf = NULL; + if(!data->multi) { + /* When a SHARE gets destroyed and has a connection pool, we get + * call with share->admin which does not have a multi handle. */ + *pbuf = curlx_malloc(blen); + return *pbuf ? CURLE_OK : CURLE_OUT_OF_MEMORY; + } + if(data->multi->xfer_sockbuf_borrowed) { + failf(data, "attempt to borrow xfer_sockbuf when already borrowed"); + return CURLE_AGAIN; + } + + if(data->multi->xfer_sockbuf && blen > data->multi->xfer_sockbuf_len) { + /* not large enough, get a new one */ + curlx_safefree(data->multi->xfer_sockbuf); + data->multi->xfer_sockbuf_len = 0; + } + + if(!data->multi->xfer_sockbuf) { + data->multi->xfer_sockbuf = curlx_malloc(blen); + if(!data->multi->xfer_sockbuf) { + failf(data, "could not allocate xfer_sockbuf of %zu bytes", blen); + return CURLE_OUT_OF_MEMORY; + } + data->multi->xfer_sockbuf_len = blen; + } + + data->multi->xfer_sockbuf_borrowed = TRUE; + *pbuf = data->multi->xfer_sockbuf; + return CURLE_OK; +} + +void Curl_multi_xfer_sockbuf_release(struct Curl_easy *data, char *buf) +{ + DEBUGASSERT(data); + if(!data->multi) { + /* When a SHARE gets destroyed and has a connection pool, we get + * call with share->admin which does not have a multi handle. */ + curlx_free(buf); + } + else { + DEBUGASSERT(!buf || data->multi->xfer_sockbuf == buf); + data->multi->xfer_sockbuf_borrowed = FALSE; + } +} + +static void multi_xfer_bufs_free(struct Curl_multi *multi) +{ + DEBUGASSERT(multi); + curlx_safefree(multi->xfer_buf); + multi->xfer_buf_len = 0; + multi->xfer_buf_borrowed = FALSE; + curlx_safefree(multi->xfer_ulbuf); + multi->xfer_ulbuf_len = 0; + multi->xfer_ulbuf_borrowed = FALSE; + curlx_safefree(multi->xfer_sockbuf); + multi->xfer_sockbuf_len = 0; + multi->xfer_sockbuf_borrowed = FALSE; +} + +struct Curl_easy *Curl_multi_get_easy(struct Curl_multi *multi, + uint32_t mid) +{ + struct Curl_easy *data = Curl_uint32_tbl_get(&multi->xfers, mid); + if(GOOD_EASY_HANDLE(data)) + return data; + CURL_TRC_M(multi->admin, "invalid easy handle in xfer table for mid=%u", + mid); + Curl_uint32_tbl_remove(&multi->xfers, mid); + return NULL; +} + +unsigned int Curl_multi_xfers_running(struct Curl_multi *multi) +{ + DEBUGASSERT(multi); + if(!multi) + return 0; + return multi->xfers_alive; +} + +void Curl_multi_mark_dirty(struct Curl_easy *data) +{ + if(data->multi && data->mid != UINT32_MAX) + Curl_uint32_bset_add(&data->multi->dirty, data->mid); +} + +void Curl_multi_clear_dirty(struct Curl_easy *data) +{ + if(data->multi && data->mid != UINT32_MAX) + Curl_uint32_bset_remove(&data->multi->dirty, data->mid); +} + +CURLMcode curl_multi_notify_enable(CURLM *m, unsigned int notification) +{ + struct Curl_multi *multi = m; + + if(!GOOD_MULTI_HANDLE(multi)) + return CURLM_BAD_HANDLE; + return Curl_mntfy_enable(multi, notification); +} + +CURLMcode curl_multi_notify_disable(CURLM *m, unsigned int notification) +{ + struct Curl_multi *multi = m; + + if(!GOOD_MULTI_HANDLE(multi)) + return CURLM_BAD_HANDLE; + return Curl_mntfy_disable(multi, notification); +} + +#ifdef DEBUGBUILD +static void multi_xfer_dump(struct Curl_multi *multi, uint32_t mid, + void *entry) +{ + struct Curl_easy *data = entry; + + (void)multi; + if(!data) { + curl_mfprintf(stderr, "mid=%u, entry=NULL, bug in xfer table?\n", mid); + } + else { + curl_mfprintf(stderr, "mid=%u, magic=%s, p=%p, id=%" FMT_OFF_T + ", url=%s\n", + mid, + (data->magic == CURLEASY_MAGIC_NUMBER) ? "GOOD" : "BAD!", + (void *)data, data->id, Curl_bufref_ptr(&data->state.url)); + } +} + +static void multi_xfer_tbl_dump(struct Curl_multi *multi) +{ + uint32_t mid; + void *entry; + curl_mfprintf(stderr, "=== multi xfer table (count=%u, capacity=%u\n", + Curl_uint32_tbl_count(&multi->xfers), + Curl_uint32_tbl_capacity(&multi->xfers)); + if(Curl_uint32_tbl_first(&multi->xfers, &mid, &entry)) { + multi_xfer_dump(multi, mid, entry); + while(Curl_uint32_tbl_next(&multi->xfers, mid, &mid, &entry)) + multi_xfer_dump(multi, mid, entry); + } + curl_mfprintf(stderr, "===\n"); + fflush(stderr); +} +#endif /* DEBUGBUILD */ diff --git a/3rdparty/curl-8.21.0/lib/multi_ev.c b/3rdparty/curl-8.21.0/lib/multi_ev.c new file mode 100644 index 0000000000..0da5b0e904 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/multi_ev.c @@ -0,0 +1,646 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "urldata.h" +#include "url.h" +#include "cfilters.h" +#include "curl_trc.h" +#include "multiif.h" +#include "multi_ev.h" +#include "select.h" +#include "uint-bset.h" +#include "uint-spbset.h" +#include "multihandle.h" + + +static void mev_in_callback(struct Curl_multi *multi, bool value) +{ + multi->in_callback = value; +} + +#ifdef DEBUGBUILD +#define SH_ENTRY_MAGIC 0x570091d +#endif + +/* Information about a socket for which we inform the libcurl application + * what to supervise (CURL_POLL_IN/CURL_POLL_OUT/CURL_POLL_REMOVE) + */ +struct mev_sh_entry { + struct uint32_spbset xfers; /* bitset of transfers `mid`s on this socket */ + struct connectdata *conn; /* connection using this socket or NULL */ + void *user_data; /* libcurl app data via curl_multi_assign() */ + unsigned int action; /* CURL_POLL_IN/CURL_POLL_OUT we last told the + * libcurl application to watch out for */ + unsigned int readers; /* this many transfers want to read */ + unsigned int writers; /* this many transfers want to write */ +#ifdef DEBUGBUILD + unsigned int magic; +#endif + BIT(announced); /* this socket has been passed to the socket + callback at least once */ +}; + +static size_t mev_sh_entry_hash(void *key, size_t key_length, size_t slots_num) +{ + curl_socket_t fd = *((curl_socket_t *)key); + (void)key_length; + return (fd % (curl_socket_t)slots_num); +} + +static size_t mev_sh_entry_compare(void *k1, size_t k1_len, + void *k2, size_t k2_len) +{ + (void)k1_len; + (void)k2_len; + return (*((curl_socket_t *)k1)) == (*((curl_socket_t *)k2)); +} + +/* sockhash entry destructor callback */ +static void mev_sh_entry_dtor(void *freethis) +{ + struct mev_sh_entry *entry = (struct mev_sh_entry *)freethis; + Curl_uint32_spbset_destroy(&entry->xfers); +#ifdef DEBUGBUILD + entry->magic = 0; +#endif + curlx_free(entry); +} + +/* look up a given socket in the socket hash, skip invalid sockets */ +static struct mev_sh_entry *mev_sh_entry_get(struct Curl_hash *sh, + curl_socket_t s) +{ + if(s != CURL_SOCKET_BAD) { + /* only look for proper sockets */ + return Curl_hash_pick(sh, (char *)&s, sizeof(curl_socket_t)); + } + return NULL; +} + +/* make sure this socket is present in the hash for this handle */ +static struct mev_sh_entry *mev_sh_entry_add(struct Curl_hash *sh, + curl_socket_t s) +{ + struct mev_sh_entry *there = mev_sh_entry_get(sh, s); + struct mev_sh_entry *check; + + if(there) { + /* it is present, return fine */ + return there; + } + + /* not present, add it */ + check = curlx_calloc(1, sizeof(struct mev_sh_entry)); + if(!check) + return NULL; /* major failure */ + + Curl_uint32_spbset_init(&check->xfers); + + /* make/add new hash entry */ + if(!Curl_hash_add(sh, (char *)&s, sizeof(curl_socket_t), check)) { + mev_sh_entry_dtor(check); + return NULL; /* major failure */ + } +#ifdef DEBUGBUILD + check->magic = SH_ENTRY_MAGIC; +#endif + return check; /* things are good in sockhash land */ +} + +/* delete the given socket entry from the hash */ +static void mev_sh_entry_kill(struct Curl_multi *multi, curl_socket_t s) +{ + Curl_hash_delete(&multi->ev.sh_entries, (char *)&s, sizeof(curl_socket_t)); +} + +static size_t mev_sh_entry_user_count(struct mev_sh_entry *e) +{ + return Curl_uint32_spbset_count(&e->xfers) + (e->conn ? 1 : 0); +} + +static bool mev_sh_entry_xfer_known(struct mev_sh_entry *e, + struct Curl_easy *data) +{ + return Curl_uint32_spbset_contains(&e->xfers, data->mid); +} + +static bool mev_sh_entry_conn_known(struct mev_sh_entry *e, + struct connectdata *conn) +{ + return (e->conn == conn); +} + +static bool mev_sh_entry_xfer_add(struct mev_sh_entry *e, + struct Curl_easy *data) +{ + /* detect weird values */ + DEBUGASSERT(mev_sh_entry_user_count(e) < 100000); + return Curl_uint32_spbset_add(&e->xfers, data->mid); +} + +static bool mev_sh_entry_conn_add(struct mev_sh_entry *e, + struct connectdata *conn) +{ + /* detect weird values */ + DEBUGASSERT(mev_sh_entry_user_count(e) < 100000); + DEBUGASSERT(!e->conn); + if(e->conn) + return FALSE; + e->conn = conn; + return TRUE; +} + +static bool mev_sh_entry_xfer_remove(struct mev_sh_entry *e, + struct Curl_easy *data) +{ + bool present = Curl_uint32_spbset_contains(&e->xfers, data->mid); + if(present) + Curl_uint32_spbset_remove(&e->xfers, data->mid); + return present; +} + +static bool mev_sh_entry_conn_remove(struct mev_sh_entry *e, + struct connectdata *conn) +{ + DEBUGASSERT(e->conn == conn); + if(e->conn == conn) { + e->conn = NULL; + return TRUE; + } + return FALSE; +} + +/* Purge any information about socket `s`. + * Let the socket callback know as well when necessary */ +static CURLMcode mev_forget_socket(struct Curl_multi *multi, + struct Curl_easy *data, + curl_socket_t s, + const char *cause) +{ + struct mev_sh_entry *entry = mev_sh_entry_get(&multi->ev.sh_entries, s); + int rc = 0; + + if(!entry) /* we never knew or already forgot about this socket */ + return CURLM_OK; + + /* We managed this socket before, tell the socket callback to forget it. */ + if(entry->announced && multi->socket_cb) { + NOVERBOSE((void)cause); + CURL_TRC_M(data, "ev %s, call(fd=%" FMT_SOCKET_T ", ev=REMOVE)", cause, s); + mev_in_callback(multi, TRUE); + rc = multi->socket_cb(data, s, CURL_POLL_REMOVE, + multi->socket_userp, entry->user_data); + mev_in_callback(multi, FALSE); + entry->announced = FALSE; + } + + mev_sh_entry_kill(multi, s); + if(rc == -1) { + multi->dead = TRUE; + return CURLM_ABORTED_BY_CALLBACK; + } + return CURLM_OK; +} + +static CURLMcode mev_sh_entry_update(struct Curl_multi *multi, + struct Curl_easy *data, + struct mev_sh_entry *entry, + curl_socket_t s, + unsigned char last_action, + unsigned char cur_action) +{ + int rc, comboaction; + + /* we should only be called when the callback exists */ + DEBUGASSERT(multi->socket_cb); + DEBUGASSERT(entry->magic == SH_ENTRY_MAGIC); + if(!multi->socket_cb) + return CURLM_OK; + + /* Transfer `data` goes from `last_action` to `cur_action` on socket `s` + * with `multi->ev.sh_entries` entry `entry`. Update `entry` and trigger + * `multi->socket_cb` on change, if the callback is set. */ + if(last_action == cur_action) /* nothing from `data` changed */ + return CURLM_OK; + + if(last_action & CURL_POLL_IN) { + DEBUGASSERT(entry->readers); + if(!(cur_action & CURL_POLL_IN)) + entry->readers--; + } + else if(cur_action & CURL_POLL_IN) + entry->readers++; + + if(last_action & CURL_POLL_OUT) { + DEBUGASSERT(entry->writers); + if(!(cur_action & CURL_POLL_OUT)) + entry->writers--; + } + else if(cur_action & CURL_POLL_OUT) + entry->writers++; + + DEBUGASSERT(entry->readers <= mev_sh_entry_user_count(entry)); + DEBUGASSERT(entry->writers <= mev_sh_entry_user_count(entry)); + DEBUGASSERT(entry->writers + entry->readers); + + CURL_TRC_M(data, "ev update fd=%" FMT_SOCKET_T ", action '%s%s' -> '%s%s'" + " (%u/%u r/w)", s, + (last_action & CURL_POLL_IN) ? "IN" : "", + (last_action & CURL_POLL_OUT) ? "OUT" : "", + (cur_action & CURL_POLL_IN) ? "IN" : "", + (cur_action & CURL_POLL_OUT) ? "OUT" : "", + entry->readers, entry->writers); + + comboaction = (entry->writers ? CURL_POLL_OUT : 0) | + (entry->readers ? CURL_POLL_IN : 0); + if(((int)entry->action == comboaction)) /* nothing for socket changed */ + return CURLM_OK; + + CURL_TRC_M(data, "ev update call(fd=%" FMT_SOCKET_T ", ev=%s%s)", + s, (comboaction & CURL_POLL_IN) ? "IN" : "", + (comboaction & CURL_POLL_OUT) ? "OUT" : ""); + mev_in_callback(multi, TRUE); + rc = multi->socket_cb(data, s, comboaction, multi->socket_userp, + entry->user_data); + mev_in_callback(multi, FALSE); + if(rc == -1) { + multi->dead = TRUE; + return CURLM_ABORTED_BY_CALLBACK; + } + /* curl_easy_pause() is documented as callable from any callback; it + * re-enters mev_assess() which may free this 'entry'. Re-fetch. */ + entry = mev_sh_entry_get(&multi->ev.sh_entries, s); + if(entry) { + DEBUGASSERT(entry->magic == SH_ENTRY_MAGIC); + entry->announced = TRUE; + entry->action = (unsigned int)comboaction; + } + return CURLM_OK; +} + +static CURLMcode mev_pollset_diff(struct Curl_multi *multi, + struct Curl_easy *data, + struct connectdata *conn, + struct easy_pollset *ps, + struct easy_pollset *prev_ps) +{ + struct mev_sh_entry *entry; + curl_socket_t s; + unsigned int i, j; + CURLMcode mresult; + + /* The transfer `data` reports in `ps` the sockets it is interested + * in and which combination of CURL_POLL_IN/CURL_POLL_OUT it wants + * to have monitored for events. + * There can be more than 1 transfer interested in the same socket + * and 1 transfer might be interested in more than 1 socket. + * `prev_ps` is the pollset copy from the previous call here. On + * the 1st call it will be empty. + */ + DEBUGASSERT(ps); + DEBUGASSERT(prev_ps); + + /* Handle changes to sockets the transfer is interested in. */ + for(i = 0; i < ps->n; i++) { + unsigned char last_action; + bool first_time = FALSE; /* data/conn appears first time on socket */ + + s = ps->sockets[i]; + /* Have we handled this socket before? */ + entry = mev_sh_entry_get(&multi->ev.sh_entries, s); + if(!entry) { + /* new socket, add new entry */ + first_time = TRUE; + entry = mev_sh_entry_add(&multi->ev.sh_entries, s); + if(!entry) /* fatal */ + return CURLM_OUT_OF_MEMORY; + CURL_TRC_M(data, "ev new entry fd=%" FMT_SOCKET_T, s); + } + else if(conn) { + first_time = !mev_sh_entry_conn_known(entry, conn); + } + else { + first_time = !mev_sh_entry_xfer_known(entry, data); + } + + /* What was the previous action the transfer had regarding this socket? + * If the transfer is new to the socket, disregard the information + * in `last_poll`, because the socket might have been destroyed and + * reopened. We would have cleared the sh_entry for that, but the socket + * might still be mentioned in the hashed pollsets. */ + last_action = 0; + if(first_time) { + if(conn) { + if(!mev_sh_entry_conn_add(entry, conn)) + return CURLM_OUT_OF_MEMORY; + } + else { + if(!mev_sh_entry_xfer_add(entry, data)) + return CURLM_OUT_OF_MEMORY; + } + CURL_TRC_M(data, "ev entry fd=%" FMT_SOCKET_T ", added %s #%" FMT_OFF_T + ", total=%u/%d (xfer/conn)", s, + conn ? "connection" : "transfer", + conn ? conn->connection_id : data->mid, + Curl_uint32_spbset_count(&entry->xfers), + entry->conn ? 1 : 0); + } + else { + for(j = 0; j < prev_ps->n; j++) { + if(s == prev_ps->sockets[j]) { + last_action = prev_ps->actions[j]; + break; + } + } + } + /* track readers/writers changes and report to socket callback */ + mresult = mev_sh_entry_update(multi, data, entry, s, + last_action, ps->actions[i]); + if(mresult) + return mresult; + } + + /* Handle changes to sockets the transfer is NO LONGER interested in. */ + for(i = 0; i < prev_ps->n; i++) { + bool stillused = FALSE; + + s = prev_ps->sockets[i]; + for(j = 0; j < ps->n; j++) { + if(s == ps->sockets[j]) { + /* socket is still supervised */ + stillused = TRUE; + break; + } + } + if(stillused) + continue; + + entry = mev_sh_entry_get(&multi->ev.sh_entries, s); + /* if entry does not exist, we were either never told about it or + * have already cleaned up this socket via Curl_multi_ev_socket_done(). + * In other words: this is perfectly normal */ + if(!entry) + continue; + + if(conn && !mev_sh_entry_conn_remove(entry, conn)) { + /* `conn` says in `prev_ps` that it had been using a socket, + * but `conn` has not been registered for it. + * This should not happen if our book-keeping is correct? */ + CURL_TRC_M(data, "ev entry fd=%" FMT_SOCKET_T ", conn lost " + "interest but is not registered", s); + DEBUGASSERT(NULL); + continue; + } + + if(!conn && !mev_sh_entry_xfer_remove(entry, data)) { + /* `data` says in `prev_ps` that it had been using a socket, + * but `data` has not been registered for it. + * This should not happen if our book-keeping is correct? */ + CURL_TRC_M(data, "ev entry fd=%" FMT_SOCKET_T ", transfer lost " + "interest but is not registered", s); + DEBUGASSERT(NULL); + continue; + } + + if(mev_sh_entry_user_count(entry)) { + /* track readers/writers changes and report to socket callback */ + mresult = mev_sh_entry_update(multi, data, entry, s, + prev_ps->actions[i], 0); + if(mresult) + return mresult; + CURL_TRC_M(data, "ev entry fd=%" FMT_SOCKET_T ", removed transfer, " + "total=%u/%d (xfer/conn)", s, + Curl_uint32_spbset_count(&entry->xfers), + entry->conn ? 1 : 0); + } + else { + mresult = mev_forget_socket(multi, data, s, "last user gone"); + if(mresult) + return mresult; + } + } /* for loop over num */ + + /* Remember for next time */ + Curl_pollset_move(prev_ps, ps); + return CURLM_OK; +} + +static void mev_pollset_dtor(void *key, size_t klen, void *entry) +{ + struct easy_pollset *ps = entry; + (void)key; + (void)klen; + if(ps) { + Curl_pollset_cleanup(ps); + curlx_free(ps); + } +} + +static struct easy_pollset *mev_add_new_conn_pollset(struct connectdata *conn) +{ + struct easy_pollset *ps; + + ps = Curl_pollset_create(); + if(!ps) + return NULL; + if(Curl_conn_meta_set(conn, CURL_META_MEV_POLLSET, ps, mev_pollset_dtor)) + return NULL; + return ps; +} + +static struct easy_pollset *mev_add_new_xfer_pollset(struct Curl_easy *data) +{ + struct easy_pollset *ps; + + ps = Curl_pollset_create(); + if(!ps) + return NULL; + if(Curl_meta_set(data, CURL_META_MEV_POLLSET, ps, mev_pollset_dtor)) + return NULL; + return ps; +} + +static struct easy_pollset *mev_get_last_pollset(struct Curl_easy *data, + struct connectdata *conn) +{ + if(data) { + if(conn) + return Curl_conn_meta_get(conn, CURL_META_MEV_POLLSET); + return Curl_meta_get(data, CURL_META_MEV_POLLSET); + } + return NULL; +} + +static CURLMcode mev_assess(struct Curl_multi *multi, + struct Curl_easy *data, + struct connectdata *conn) +{ + struct easy_pollset ps, *last_ps; + CURLMcode mresult = CURLM_OK; + + if(!multi || !multi->socket_cb) + return CURLM_OK; + + Curl_pollset_init(&ps); + if(conn) { + CURLcode result = Curl_conn_adjust_pollset(data, conn, &ps); + if(result) { + mresult = (result == CURLE_OUT_OF_MEMORY) ? + CURLM_OUT_OF_MEMORY : CURLM_INTERNAL_ERROR; + goto out; + } + } + else + Curl_multi_pollset(data, &ps); + last_ps = mev_get_last_pollset(data, conn); + + if(!last_ps && ps.n) { + if(conn) + last_ps = mev_add_new_conn_pollset(conn); + else + last_ps = mev_add_new_xfer_pollset(data); + if(!last_ps) { + mresult = CURLM_OUT_OF_MEMORY; + goto out; + } + } + + if(last_ps) + mresult = mev_pollset_diff(multi, data, conn, &ps, last_ps); + else + DEBUGASSERT(!ps.n); +out: + Curl_pollset_cleanup(&ps); + return mresult; +} + +CURLMcode Curl_multi_ev_assess_xfer(struct Curl_multi *multi, + struct Curl_easy *data) +{ + return mev_assess(multi, data, NULL); +} + +CURLMcode Curl_multi_ev_assess_conn(struct Curl_multi *multi, + struct Curl_easy *data, + struct connectdata *conn) +{ + return mev_assess(multi, data, conn); +} + +CURLMcode Curl_multi_ev_assess_xfer_bset(struct Curl_multi *multi, + struct uint32_bset *set) +{ + uint32_t mid; + CURLMcode mresult = CURLM_OK; + + if(multi && multi->socket_cb && Curl_uint32_bset_first(set, &mid)) { + do { + struct Curl_easy *data = Curl_multi_get_easy(multi, mid); + if(data) { + mresult = Curl_multi_ev_assess_xfer(multi, data); + } + } while(!mresult && Curl_uint32_bset_next(set, mid, &mid)); + } + return mresult; +} + +CURLMcode Curl_multi_ev_assign(struct Curl_multi *multi, + curl_socket_t s, + void *user_data) +{ + struct mev_sh_entry *e = mev_sh_entry_get(&multi->ev.sh_entries, s); + if(!e) + return CURLM_BAD_SOCKET; + e->user_data = user_data; + return CURLM_OK; +} + +void Curl_multi_ev_dirty_xfers(struct Curl_multi *multi, + curl_socket_t s) +{ + struct mev_sh_entry *entry; + + DEBUGASSERT(s != CURL_SOCKET_TIMEOUT); + entry = mev_sh_entry_get(&multi->ev.sh_entries, s); + + /* Unmatched socket, we cannot act on it but we ignore this fact. In + real-world tests it has been proved that libevent can in fact give + the application actions even though the socket was previously + asked to get removed, so thus we better survive stray socket actions + and move on. */ + if(entry) { + struct Curl_easy *data; + uint32_t mid; + + if(Curl_uint32_spbset_first(&entry->xfers, &mid)) { + do { + data = Curl_multi_get_easy(multi, mid); + if(data) { + Curl_multi_mark_dirty(data); + } + else { + CURL_TRC_M(multi->admin, "socket transfer %u no longer found", mid); + Curl_uint32_spbset_remove(&entry->xfers, mid); + } + } while(Curl_uint32_spbset_next(&entry->xfers, mid, &mid)); + } + + if(entry->conn) + Curl_multi_mark_dirty(multi->admin); + } +} + +void Curl_multi_ev_socket_done(struct Curl_multi *multi, + struct Curl_easy *data, curl_socket_t s) +{ + mev_forget_socket(multi, data, s, "socket done"); +} + +void Curl_multi_ev_xfer_done(struct Curl_multi *multi, + struct Curl_easy *data) +{ + DEBUGASSERT(!data->conn); /* transfer should have been detached */ + (void)mev_assess(multi, data, NULL); + Curl_meta_remove(data, CURL_META_MEV_POLLSET); +} + +void Curl_multi_ev_conn_done(struct Curl_multi *multi, + struct Curl_easy *data, + struct connectdata *conn) +{ + (void)mev_assess(multi, data, conn); + Curl_conn_meta_remove(conn, CURL_META_MEV_POLLSET); +} + +void Curl_multi_ev_init(struct Curl_multi *multi, size_t hashsize) +{ + Curl_hash_init(&multi->ev.sh_entries, hashsize, mev_sh_entry_hash, + mev_sh_entry_compare, mev_sh_entry_dtor); +} + +void Curl_multi_ev_cleanup(struct Curl_multi *multi) +{ + Curl_hash_destroy(&multi->ev.sh_entries); +} diff --git a/3rdparty/curl-8.21.0/lib/multi_ev.h b/3rdparty/curl-8.21.0/lib/multi_ev.h new file mode 100644 index 0000000000..ddbb9331d3 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/multi_ev.h @@ -0,0 +1,80 @@ +#ifndef HEADER_CURL_MULTI_EV_H +#define HEADER_CURL_MULTI_EV_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "hash.h" + +struct Curl_easy; +struct Curl_multi; +struct easy_pollset; +struct uint32_bset; + +/* meta key for event pollset at easy handle or connection */ +#define CURL_META_MEV_POLLSET "meta:mev:ps" + +struct curl_multi_ev { + struct Curl_hash sh_entries; +}; + +/* Setup/teardown of multi event book-keeping. */ +void Curl_multi_ev_init(struct Curl_multi *multi, size_t hashsize); +void Curl_multi_ev_cleanup(struct Curl_multi *multi); + +/* Assign a 'user_data' to be passed to the socket callback when + * invoked with the given socket. This will fail if this socket + * is not active, e.g. the application has not been told to monitor it. */ +CURLMcode Curl_multi_ev_assign(struct Curl_multi *multi, curl_socket_t s, + void *user_data); + +/* Assess the transfer by getting its current pollset, compute + * any changes to the last one and inform the application's socket + * callback if things have changed. */ +CURLMcode Curl_multi_ev_assess_xfer(struct Curl_multi *multi, + struct Curl_easy *data); +/* Assess all easy handles on the list */ +CURLMcode Curl_multi_ev_assess_xfer_bset(struct Curl_multi *multi, + struct uint32_bset *set); +/* Assess the connection by getting its current pollset */ +CURLMcode Curl_multi_ev_assess_conn(struct Curl_multi *multi, + struct Curl_easy *data, + struct connectdata *conn); + +/* Mark all transfers tied to the given socket as dirty */ +void Curl_multi_ev_dirty_xfers(struct Curl_multi *multi, + curl_socket_t s); + +/* Socket will be closed, forget anything we know about it. */ +void Curl_multi_ev_socket_done(struct Curl_multi *multi, + struct Curl_easy *data, curl_socket_t s); + +/* Transfer is removed from the multi */ +void Curl_multi_ev_xfer_done(struct Curl_multi *multi, + struct Curl_easy *data); + +/* Connection is being destroyed */ +void Curl_multi_ev_conn_done(struct Curl_multi *multi, + struct Curl_easy *data, + struct connectdata *conn); + +#endif /* HEADER_CURL_MULTI_EV_H */ diff --git a/3rdparty/curl-8.21.0/lib/multi_ntfy.c b/3rdparty/curl-8.21.0/lib/multi_ntfy.c new file mode 100644 index 0000000000..1319aaec07 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/multi_ntfy.c @@ -0,0 +1,207 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "urldata.h" +#include "curl_trc.h" +#include "multihandle.h" +#include "multiif.h" +#include "multi_ntfy.h" + + +struct mntfy_entry { + uint32_t mid; + uint32_t type; +}; + +#define CURL_MNTFY_CHUNK_SIZE 128 + +struct mntfy_chunk { + struct mntfy_chunk *next; + size_t r_offset; + size_t w_offset; + struct mntfy_entry entries[CURL_MNTFY_CHUNK_SIZE]; +}; + +static struct mntfy_chunk *mnfty_chunk_create(void) +{ + return curlx_calloc(1, sizeof(struct mntfy_chunk)); +} + +static void mnfty_chunk_destroy(struct mntfy_chunk *chunk) +{ + curlx_free(chunk); +} + +static void mnfty_chunk_reset(struct mntfy_chunk *chunk) +{ + memset(chunk, 0, sizeof(*chunk)); +} + +static bool mntfy_chunk_append(struct mntfy_chunk *chunk, + struct Curl_easy *data, + uint32_t type) +{ + struct mntfy_entry *e; + + if(chunk->w_offset >= CURL_MNTFY_CHUNK_SIZE) + return FALSE; + e = &chunk->entries[chunk->w_offset++]; + e->mid = data->mid; + e->type = type; + return TRUE; +} + +static struct mntfy_chunk *mntfy_non_full_tail(struct curl_multi_ntfy *mntfy) +{ + struct mntfy_chunk *chunk; + if(!mntfy->tail) { + chunk = mnfty_chunk_create(); + if(!chunk) + return NULL; + DEBUGASSERT(!mntfy->head); + mntfy->head = mntfy->tail = chunk; + return chunk; + } + else if(mntfy->tail->w_offset < CURL_MNTFY_CHUNK_SIZE) + return mntfy->tail; + else { /* tail is full. */ + chunk = mnfty_chunk_create(); + if(!chunk) + return NULL; + DEBUGASSERT(mntfy->head); + mntfy->tail->next = chunk; + mntfy->tail = chunk; + return chunk; + } +} + +static void mntfy_chunk_dispatch_all(struct Curl_multi *multi, + struct mntfy_chunk *chunk) +{ + struct mntfy_entry *e; + struct Curl_easy *data; + + if(multi->ntfy.ntfy_cb) { + while((chunk->r_offset < chunk->w_offset) && !multi->ntfy.failure) { + e = &chunk->entries[chunk->r_offset]; + data = e->mid ? Curl_multi_get_easy(multi, e->mid) : multi->admin; + /* only when notification has not been disabled in the meantime */ + if(data && Curl_uint32_bset_contains(&multi->ntfy.enabled, e->type)) { + /* this may cause new notifications to be added! */ + CURL_TRC_M(multi->admin, "[NTFY] dispatch %u to xfer %u", + e->type, e->mid); + multi->ntfy.ntfy_cb(multi, e->type, data, multi->ntfy.ntfy_cb_data); + } + /* once dispatched, safe to increment */ + chunk->r_offset++; + } + } + mnfty_chunk_reset(chunk); +} + +void Curl_mntfy_init(struct Curl_multi *multi) +{ + memset(&multi->ntfy, 0, sizeof(multi->ntfy)); + Curl_uint32_bset_init(&multi->ntfy.enabled); +} + +CURLMcode Curl_mntfy_resize(struct Curl_multi *multi) +{ + if(Curl_uint32_bset_resize(&multi->ntfy.enabled, CURLMNOTIFY_EASY_DONE + 1)) + return CURLM_OUT_OF_MEMORY; + return CURLM_OK; +} + +void Curl_mntfy_cleanup(struct Curl_multi *multi) +{ + while(multi->ntfy.head) { + struct mntfy_chunk *chunk = multi->ntfy.head; + multi->ntfy.head = chunk->next; + mnfty_chunk_destroy(chunk); + } + multi->ntfy.tail = NULL; + Curl_uint32_bset_destroy(&multi->ntfy.enabled); +} + +CURLMcode Curl_mntfy_enable(struct Curl_multi *multi, unsigned int type) +{ + if(type > CURLMNOTIFY_EASY_DONE) + return CURLM_UNKNOWN_OPTION; + Curl_uint32_bset_add(&multi->ntfy.enabled, type); + return CURLM_OK; +} + +CURLMcode Curl_mntfy_disable(struct Curl_multi *multi, unsigned int type) +{ + if(type > CURLMNOTIFY_EASY_DONE) + return CURLM_UNKNOWN_OPTION; + Curl_uint32_bset_remove(&multi->ntfy.enabled, (uint32_t)type); + return CURLM_OK; +} + +void Curl_mntfy_add(struct Curl_easy *data, unsigned int type) +{ + struct Curl_multi *multi = data ? data->multi : NULL; + if(multi && multi->ntfy.ntfy_cb && !multi->ntfy.failure && + Curl_uint32_bset_contains(&multi->ntfy.enabled, (uint32_t)type)) { + /* append to list of outstanding notifications */ + struct mntfy_chunk *tail = mntfy_non_full_tail(&multi->ntfy); + CURL_TRC_M(data, "[NTFY] add %u for xfer %u", type, data->mid); + if(tail) + mntfy_chunk_append(tail, data, (uint32_t)type); + else + multi->ntfy.failure = CURLM_OUT_OF_MEMORY; + multi->ntfy.has_entries = TRUE; + } +} + +CURLMcode Curl_mntfy_dispatch_all(struct Curl_multi *multi) +{ + DEBUGASSERT(!multi->in_ntfy_callback); + multi->in_ntfy_callback = TRUE; + while(multi->ntfy.head && !multi->ntfy.failure) { + struct mntfy_chunk *chunk = multi->ntfy.head; + /* this may cause new notifications to be added! */ + mntfy_chunk_dispatch_all(multi, chunk); + DEBUGASSERT(chunk->r_offset == chunk->w_offset); + + if(chunk == multi->ntfy.tail) /* last one, keep */ + break; + DEBUGASSERT(chunk->next); + DEBUGASSERT(multi->ntfy.head != multi->ntfy.tail); + multi->ntfy.head = chunk->next; + mnfty_chunk_destroy(chunk); + } + multi->in_ntfy_callback = FALSE; + + if(multi->ntfy.failure) { + CURLMcode mresult = multi->ntfy.failure; + multi->ntfy.failure = CURLM_OK; /* reset, once delivered */ + return mresult; + } + else + multi->ntfy.has_entries = FALSE; + return CURLM_OK; +} diff --git a/3rdparty/curl-8.21.0/lib/multi_ntfy.h b/3rdparty/curl-8.21.0/lib/multi_ntfy.h new file mode 100644 index 0000000000..05df2d6681 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/multi_ntfy.h @@ -0,0 +1,60 @@ +#ifndef HEADER_CURL_MULTI_NTFY_H +#define HEADER_CURL_MULTI_NTFY_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "uint-bset.h" + +struct Curl_easy; +struct Curl_multi; + +struct curl_multi_ntfy { + curl_notify_callback ntfy_cb; + void *ntfy_cb_data; + struct uint32_bset enabled; + struct mntfy_chunk *head; + struct mntfy_chunk *tail; + CURLMcode failure; + BIT(has_entries); +}; + +void Curl_mntfy_init(struct Curl_multi *multi); +CURLMcode Curl_mntfy_resize(struct Curl_multi *multi); +void Curl_mntfy_cleanup(struct Curl_multi *multi); + +CURLMcode Curl_mntfy_enable(struct Curl_multi *multi, unsigned int type); +CURLMcode Curl_mntfy_disable(struct Curl_multi *multi, unsigned int type); + +void Curl_mntfy_add(struct Curl_easy *data, unsigned int type); + +#define CURLM_NTFY(d, t) \ + do { \ + if((d) && (d)->multi && (d)->multi->ntfy.ntfy_cb) \ + Curl_mntfy_add((d), (t)); \ + } while(0) + +#define CURL_MNTFY_HAS_ENTRIES(m) ((m)->ntfy.has_entries) + +CURLMcode Curl_mntfy_dispatch_all(struct Curl_multi *multi); + +#endif /* HEADER_CURL_MULTI_NTFY_H */ diff --git a/3rdparty/curl-8.21.0/lib/multihandle.h b/3rdparty/curl-8.21.0/lib/multihandle.h new file mode 100644 index 0000000000..19dd2ffcdf --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/multihandle.h @@ -0,0 +1,201 @@ +#ifndef HEADER_CURL_MULTIHANDLE_H +#define HEADER_CURL_MULTIHANDLE_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "llist.h" +#include "hash.h" +#include "conncache.h" +#include "cshutdn.h" +#include "dnscache.h" +#include "multi_ev.h" +#include "multi_ntfy.h" +#include "psl.h" +#include "socketpair.h" +#include "uint-bset.h" +#include "uint-spbset.h" +#include "uint-table.h" + +struct connectdata; +struct Curl_easy; + +struct Curl_message { + struct Curl_llist_node list; + /* the 'CURLMsg' is the part that is visible to the external user */ + struct CURLMsg extmsg; +}; + +/* NOTE: if you add a state here, add the name to the statenames[] array + * in curl_trc.c as well! + */ +typedef enum { + MSTATE_INIT, /* 0 - start in this state */ + MSTATE_PENDING, /* no connections, waiting for one */ + MSTATE_SETUP, /* start a new transfer */ + MSTATE_CONNECT, /* resolve/connect has been sent off */ + MSTATE_CONNECTING, /* awaiting the TCP connect to finalize */ + MSTATE_PROTOCONNECT, /* initiate protocol connect procedure */ + MSTATE_PROTOCONNECTING, /* completing the protocol-specific connect phase */ + MSTATE_DO, /* start send off the request (part 1) */ + MSTATE_DOING, /* sending off the request (part 1) */ + MSTATE_DOING_MORE, /* send off the request (part 2) */ + MSTATE_DID, /* done sending off request */ + MSTATE_PERFORMING, /* transfer data */ + MSTATE_RATELIMITING, /* wait because limit-rate exceeded */ + MSTATE_DONE, /* post data transfer operation */ + MSTATE_COMPLETED, /* operation complete */ + MSTATE_MSGSENT, /* the operation complete message is sent */ + MSTATE_LAST /* not a true state, never use this */ +} CURLMstate; + +#define CURLPIPE_ANY (CURLPIPE_MULTIPLEX) + +#if !defined(CURL_DISABLE_SOCKETPAIR) && !defined(USE_WINSOCK) +#define ENABLE_WAKEUP +#endif + +/* value for MAXIMUM CONCURRENT STREAMS upper limit */ +#define INITIAL_MAX_CONCURRENT_STREAMS ((1U << 31) - 1) + +/* This is the struct known as CURLM on the outside */ +struct Curl_multi { + /* First a simple identifier to easier detect if a user mix up + this multi handle with an easy handle. Set this to CURL_MULTI_HANDLE. */ + unsigned int magic; + + unsigned int xfers_alive; /* amount of added transfers that have + not yet reached COMPLETE state */ + unsigned int xfers_really_alive; /* amount of added transfers that have + passed INIT state but are not COMPLETE yet */ + curl_off_t xfers_total_ever; /* total of added transfers, ever. */ + struct uint32_tbl xfers; /* transfers added to this multi */ + /* Each transfer's mid may be present in at most one of these */ + struct uint32_bset process; /* transfer being processed */ + struct uint32_bset dirty; /* transfer to be run NOW, e.g. ASAP. */ + struct uint32_bset pending; /* transfers in waiting (conn limit etc.) */ + struct uint32_bset msgsent; /* transfers done with message for application */ + + struct Curl_llist msglist; /* a list of messages from completed transfers */ + + struct Curl_easy *admin; /* internal easy handle for admin operations. + gets assigned `mid` 0 on multi init */ + + /* callback function and user data pointer for the *socket() API */ + curl_socket_callback socket_cb; + void *socket_userp; + + /* callback function and user data pointer for server push */ + curl_push_callback push_cb; + void *push_userp; + + struct Curl_dnscache dnscache; /* DNS cache */ + struct Curl_ssl_scache *ssl_scache; /* TLS session pool */ +#ifdef USE_RESOLV_THREADED + struct curl_thrdq *resolv_thrdq; +#endif + +#ifdef USE_LIBPSL + /* PSL cache. */ + struct PslCache psl; +#endif + + /* current time for transfers running in this multi handle */ + struct curltime now; + /* timetree points to the splay-tree of time nodes to figure out expire + times of all currently set timers */ + struct Curl_tree *timetree; + + /* buffer used for transfer data, lazy initialized */ + char *xfer_buf; /* the actual buffer */ + size_t xfer_buf_len; /* the allocated length */ + /* buffer used for upload data, lazy initialized */ + char *xfer_ulbuf; /* the actual buffer */ + size_t xfer_ulbuf_len; /* the allocated length */ + /* buffer used for socket I/O operations, lazy initialized */ + char *xfer_sockbuf; /* the actual buffer */ + size_t xfer_sockbuf_len; /* the allocated length */ + + /* multi event related things */ + struct curl_multi_ev ev; + /* multi notification related things */ + struct curl_multi_ntfy ntfy; + + /* `proto_hash` is a general key-value store for protocol implementations + * with the lifetime of the multi handle. The number of elements kept here + * should be in the order of supported protocols (and sub-protocols like + * TLS), *not* in the order of connections or current transfers! + * Elements need to be added with their own destructor to be invoked when + * the multi handle is cleaned up (see Curl_hash_add2()).*/ + struct Curl_hash proto_hash; + + struct cshutdn cshutdn; /* connection shutdown handling */ + struct cpool cpool; /* connection pool (bundles) */ + + size_t max_host_connections; /* if >0, a fixed limit of the maximum number + of connections per host */ + size_t max_total_connections; /* if >0, a fixed limit of the maximum number + of connections in total */ + + /* timer callback and user data pointer for the *socket() API */ + curl_multi_timer_callback timer_cb; + void *timer_userp; + long last_timeout_ms; /* the last timeout value set via timer_cb */ + struct curltime last_expire_ts; /* timestamp of last expiry */ + +#ifdef USE_WINSOCK + WSAEVENT wsa_event; /* Winsock event used for waits */ +#endif +#ifdef ENABLE_WAKEUP + curl_socket_t wakeup_pair[2]; /* eventfd()/pipe()/socketpair() used for + wakeup 0 is used for read, 1 is used + for write */ +#endif + unsigned int max_concurrent_streams; + unsigned int maxconnects; /* if >0, a fixed limit of the maximum number of + entries we are allowed to grow the connection + cache to */ +#ifdef DEBUGBUILD + unsigned int now_access_count; +#endif + uint32_t last_pending_mid; /* mid of last pending transfer rescheduled */ + uint32_t last_resolv_id; /* id of the last DNS resolve operation */ + BIT(ipv6_works); + BIT(multiplexing); /* multiplexing wanted */ + BIT(recheckstate); /* see Curl_multi_connchanged */ + BIT(in_callback); /* true while executing a callback */ + BIT(in_ntfy_callback); /* true while dispatching notifications */ +#ifdef USE_OPENSSL + BIT(ssl_seeded); +#endif + BIT(dead); /* a callback returned error, everything needs to crash and + burn */ + BIT(xfer_buf_borrowed); /* xfer_buf is currently being borrowed */ + BIT(xfer_ulbuf_borrowed); /* xfer_ulbuf is currently being borrowed */ + BIT(xfer_sockbuf_borrowed); /* xfer_sockbuf is currently being borrowed */ + BIT(quick_exit); /* do not join threads on cleanup */ +#ifdef DEBUGBUILD + BIT(warned); /* true after user warned of DEBUGBUILD */ +#endif +}; + +#endif /* HEADER_CURL_MULTIHANDLE_H */ diff --git a/3rdparty/curl-8.21.0/lib/multiif.h b/3rdparty/curl-8.21.0/lib/multiif.h new file mode 100644 index 0000000000..039db269e0 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/multiif.h @@ -0,0 +1,167 @@ +#ifndef HEADER_CURL_MULTIIF_H +#define HEADER_CURL_MULTIIF_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +/* + * Prototypes for library-wide functions provided by multi.c + */ + +void Curl_expire(struct Curl_easy *data, timediff_t milli, expire_id id); +void Curl_expire_ex(struct Curl_easy *data, + timediff_t milli, expire_id id); +void Curl_expire_clear(struct Curl_easy *data); +void Curl_expire_done(struct Curl_easy *data, expire_id id); +CURLMcode Curl_update_timer(struct Curl_multi *multi) WARN_UNUSED_RESULT; +void Curl_attach_connection(struct Curl_easy *data, + struct connectdata *conn); +void Curl_detach_connection(struct Curl_easy *data); +bool Curl_multiplex_wanted(const struct Curl_multi *multi); +void Curl_set_in_callback(struct Curl_easy *data, bool value); +bool Curl_is_in_callback(struct Curl_easy *data); +CURLcode Curl_preconnect(struct Curl_easy *data); +bool Curl_is_connecting(struct Curl_easy *data); + +void Curl_multi_connchanged(struct Curl_multi *multi); + +/* Internal version of curl_multi_init() accepts size parameters for the + socket, connection and dns hashes */ +struct Curl_multi *Curl_multi_handle(uint32_t xfer_table_size, + size_t ev_hashsize, + size_t chashsize, + size_t dnssize, + size_t sesssize); + +/** + * Let the multi handle know that the socket is about to be closed. + * The multi will then remove anything it knows about the socket, so + * when the OS is using this socket (number) again subsequently, + * the internal book keeping will not get confused. + */ +void Curl_multi_will_close(struct Curl_easy *data, curl_socket_t s); + +/* + * Add a handle and move it into PERFORM state at once. For pushed streams. + */ +CURLMcode Curl_multi_add_perform(struct Curl_multi *multi, + struct Curl_easy *data, + struct connectdata *conn); + +/* Return the value of the CURLMOPT_MAX_CONCURRENT_STREAMS option */ +unsigned int Curl_multi_max_concurrent_streams(struct Curl_multi *multi); + +CURLMcode Curl_multi_pollset(struct Curl_easy *data, + struct easy_pollset *ps); + +/** + * Borrow the transfer buffer from the multi, suitable + * for the given transfer `data`. The buffer may only be used in one + * multi processing of the easy handle. It MUST be returned to the + * multi before it can be borrowed again. + * Pointers into the buffer remain only valid as long as it is borrowed. + * + * @param data the easy handle + * @param pbuf on return, the buffer to use or NULL on error + * @param pbuflen on return, the size of *pbuf or 0 on error + * @return CURLE_OK when buffer is available and is returned. + * CURLE_OUT_OF_MEMORy on failure to allocate the buffer, + * CURLE_FAILED_INIT if the easy handle is without multi. + * CURLE_AGAIN if the buffer is borrowed already. + */ +CURLcode Curl_multi_xfer_buf_borrow(struct Curl_easy *data, + char **pbuf, size_t *pbuflen); +/** + * Release the borrowed buffer. All references into the buffer become + * invalid after this. + * @param buf the buffer pointer borrowed for coding error checks. + */ +void Curl_multi_xfer_buf_release(struct Curl_easy *data, char *buf); + +/** + * Borrow the upload buffer from the multi, suitable + * for the given transfer `data`. The buffer may only be used in one + * multi processing of the easy handle. It MUST be returned to the + * multi before it can be borrowed again. + * Pointers into the buffer remain only valid as long as it is borrowed. + * + * @param data the easy handle + * @param pbuf on return, the buffer to use or NULL on error + * @param pbuflen on return, the size of *pbuf or 0 on error + * @return CURLE_OK when buffer is available and is returned. + * CURLE_OUT_OF_MEMORy on failure to allocate the buffer, + * CURLE_FAILED_INIT if the easy handle is without multi. + * CURLE_AGAIN if the buffer is borrowed already. + */ +CURLcode Curl_multi_xfer_ulbuf_borrow(struct Curl_easy *data, + char **pbuf, size_t *pbuflen); + +/** + * Release the borrowed upload buffer. All references into the buffer become + * invalid after this. + * @param buf the upload buffer pointer borrowed for coding error checks. + */ +void Curl_multi_xfer_ulbuf_release(struct Curl_easy *data, char *buf); + +/** + * Borrow the socket scratch buffer from the multi, suitable + * for the given transfer `data`. The buffer may only be used for + * direct socket I/O operation by one connection at a time and MUST be + * returned to the multi before the I/O call returns. + * Pointers into the buffer remain only valid as long as it is borrowed. + * + * @param data the easy handle + * @param blen requested length of the buffer + * @param pbuf on return, the buffer to use or NULL on error + * @return CURLE_OK when buffer is available and is returned. + * CURLE_OUT_OF_MEMORy on failure to allocate the buffer, + * CURLE_FAILED_INIT if the easy handle is without multi. + * CURLE_AGAIN if the buffer is borrowed already. + */ +CURLcode Curl_multi_xfer_sockbuf_borrow(struct Curl_easy *data, + size_t blen, char **pbuf); +/** + * Release the borrowed buffer. All references into the buffer become + * invalid after this. + * @param buf the buffer pointer borrowed for coding error checks. + */ +void Curl_multi_xfer_sockbuf_release(struct Curl_easy *data, char *buf); + +/** + * Get the easy handle for the given mid. + * Returns NULL if not found. + */ +struct Curl_easy *Curl_multi_get_easy(struct Curl_multi *multi, + uint32_t mid); + +/* Get the # of transfers current in process/pending. */ +unsigned int Curl_multi_xfers_running(struct Curl_multi *multi); + +/* Mark a transfer as dirty, e.g. to be rerun at earliest convenience. + * A cheap operation, can be done many times repeatedly. */ +void Curl_multi_mark_dirty(struct Curl_easy *data); +/* Clear transfer from the dirty set. */ +void Curl_multi_clear_dirty(struct Curl_easy *data); + +void Curl_multi_set_now(struct Curl_multi *multi); + +#endif /* HEADER_CURL_MULTIIF_H */ diff --git a/3rdparty/curl-8.21.0/lib/netrc.c b/3rdparty/curl-8.21.0/lib/netrc.c new file mode 100644 index 0000000000..7c8e1fb2ab --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/netrc.c @@ -0,0 +1,694 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifndef CURL_DISABLE_NETRC + +#ifdef HAVE_PWD_H +#ifdef __AMIGA__ +#undef __NO_NET_API /* required for AmigaOS to declare getpwuid() */ +#endif +#include +#ifdef __AMIGA__ +#define __NO_NET_API +#endif +#endif + +#include "netrc.h" +#include "urldata.h" +#include "creds.h" +#include "curl_trc.h" +#include "strcase.h" +#include "curl_get_line.h" +#include "curlx/fopen.h" +#include "curlx/strparse.h" + + +/* .netrc is not really a standard. The GNU definition can be found here: + * https://www.gnu.org/software/inetutils/manual/html_node/The-_002enetrc-file.html + * This gives grammar like: + * + * LITERAL := \S+ | QUOTED + * QUOTED := "(\\[rnt\]|[^"])*" + * ANYTHING := . + * EMPTY_LINE := \r*\n\r*\n + * MACHINE := machine # case-insensitive + * LOGIN := login # case-insensitive + * PASSWD := password # case-insensitive + * ACCOUNT := account # case-insensitive + * MACDEF := macdef # case-insensitive + * DEFAULT := default # case-insensitive + * + * MACRO := MACDEF ANYTHING* EMPTY_LINE + * JUNK := LITERAL + * LKEY := ( LOGIN | PASSWD | ACCOUNT ) LITERAL + * MENTRY := MACHINE LITERAL LKEY* + * DENTRY := DEFAULT LKEY* + * NETRC := (MENTRY | DENTRY | MACRO | JUNK )* EOF + * + * Tokens are separated by whitespace or newlines. which have otherwise + * no special meaning, apart from the empty line ending a MACRO. + * + * Parsing is not strict, unmatched LITERALs are ignored + */ + +#define MAX_NETRC_LINE 16384 +#define MAX_NETRC_FILE (128 * 1024) +#define MAX_NETRC_TOKEN 4096 + +#define NETRC_DEBUG 0 + +/* convert a dynbuf call CURLcode error to a NETRCcode error */ +#define curl2netrc(r) \ + ((!(r)) ? NETRC_OK : (((r) == CURLE_OUT_OF_MEMORY) ? \ + NETRC_OUT_OF_MEMORY : NETRC_SYNTAX_ERROR)) + +typedef enum { + NETRC_TOK_EOF, + NETRC_TOK_LITERAL, + NETRC_TOK_MACHINE, + NETRC_TOK_DEFAULT, + NETRC_TOK_ACCOUNT, + NETRC_TOK_LOGIN, + NETRC_TOK_PASSWD, + NETRC_TOK_MACDEF, + NETRC_TOK_JUNK +} curl_netrc_token; + +struct netrc_lexer { + struct Curl_easy *data; + const char *content; + const char *pos; + struct dynbuf literal; + curl_netrc_token token; + bool pushed; +}; + +#if NETRC_DEBUG +static const char *netrc_tokenstr(curl_netrc_token token) +{ + switch(token) { + case NETRC_TOK_EOF: + return "[EOF]"; + case NETRC_TOK_LITERAL: + return "[LITERAL]"; + case NETRC_TOK_MACHINE: + return "[MACHINE]"; + case NETRC_TOK_DEFAULT: + return "[DEFAULT]"; + case NETRC_TOK_ACCOUNT: + return "[ACCOUNT]"; + case NETRC_TOK_LOGIN: + return "[LOGIN]"; + case NETRC_TOK_PASSWD: + return "[PASSWORD]"; + case NETRC_TOK_MACDEF: + return "[MACDEF]"; + case NETRC_TOK_JUNK: + return "[JUNK]"; + default: + return "[???]"; + } +} +#endif + +static void netrc_lexer_init(struct netrc_lexer *lexer, + struct Curl_easy *data, + const char *content) +{ + curlx_dyn_init(&lexer->literal, MAX_NETRC_TOKEN); + lexer->data = data; + lexer->content = lexer->pos = content; +} + +static void netrc_lexer_cleanup(struct netrc_lexer *lexer) +{ + lexer->content = lexer->pos = NULL; + lexer->data = NULL; + curlx_dyn_free(&lexer->literal); +} + +static void netrc_skip_blanks(struct netrc_lexer *lexer) +{ + const char *s = lexer->pos; + while(*s) { + curlx_str_passblanks(&s); + while(*s == '\r') + ++s; + if(*s == '\n') { + ++s; + } + else + break; + } + lexer->pos = s; +} + +static void netrc_skip_to_empty_line(struct netrc_lexer *lexer) +{ + const char *s = lexer->pos; + while(*s) { + if(*s == '\r') + ++s; + else if(*s == '\n') { + ++s; + while(*s == '\r') + ++s; + if(*s == '\n') + goto out; + } + else + ++s; + } +out: + lexer->pos = s; +} + +/* + * Parse a quoted token starting after the opening '"'. Handles \n, \r, \t + * escape sequences. Advances *tok_endp past the closing '"'. + * + * Returns NETRC_OK or error. + */ +static NETRCcode netrc_lexer_quoted(struct netrc_lexer *lexer) +{ + NETRCcode rc = NETRC_SYNTAX_ERROR; + const char *s = lexer->pos; + bool escape = FALSE; + CURLcode result; + + DEBUGASSERT(*s == '\"'); + ++s; /* pass the leading quote */ + while(*s) { + char c = *s; + if(escape) { + escape = FALSE; + switch(c) { + case 'n': + c = '\n'; + break; + case 'r': + c = '\r'; + break; + case 't': + c = '\t'; + break; + } + } + else if(c == '\\') { + escape = TRUE; + ++s; + continue; + } + else if(c == '\"') { + ++s; /* pass the ending quote */ + rc = NETRC_OK; + goto out; + } + result = curlx_dyn_addn(&lexer->literal, &c, 1); + if(result) { + rc = curl2netrc(result); + goto out; + } + ++s; + } +out: + lexer->pos = s; + return rc; +} + +static void netrc_lexer_push(struct netrc_lexer *lexer) +{ + lexer->pushed = TRUE; +} + +static NETRCcode netrc_lexer_next(struct netrc_lexer *lexer, + bool want_literal) +{ + const char *s = lexer->pos, *start; + NETRCcode rc = NETRC_OK; + size_t slen; + CURLcode result; + + if(lexer->pushed) { + lexer->pushed = FALSE; + goto out; + } + + curlx_dyn_reset(&lexer->literal); + netrc_skip_blanks(lexer); + s = lexer->pos; + + switch(*s) { + case 0: + lexer->token = NETRC_TOK_EOF; + break; + case '\"': + rc = netrc_lexer_quoted(lexer); + lexer->token = NETRC_TOK_LITERAL; + s = lexer->pos; + break; + default: + /* unquoted token */ + start = s; + while(*s && !ISBLANK(*s) && !ISNEWLINE(*s)) + ++s; + slen = s - start; + if(!slen) { + rc = NETRC_SYNTAX_ERROR; + } + if(want_literal) { + lexer->token = NETRC_TOK_LITERAL; + result = curlx_dyn_addn(&lexer->literal, start, slen); + rc = curl2netrc(result); + } + else if((slen == 7) && curl_strnequal(start, "machine", slen)) { + lexer->token = NETRC_TOK_MACHINE; + } + else if((slen == 7) && curl_strnequal(start, "default", slen)) { + lexer->token = NETRC_TOK_DEFAULT; + } + else if((slen == 7) && curl_strnequal(start, "account", slen)) { + lexer->token = NETRC_TOK_ACCOUNT; + } + else if((slen == 5) && curl_strnequal(start, "login", slen)) { + lexer->token = NETRC_TOK_LOGIN; + } + else if((slen == 8) && curl_strnequal(start, "password", slen)) { + lexer->token = NETRC_TOK_PASSWD; + } + else if((slen == 6) && curl_strnequal(start, "macdef", slen)) { + lexer->token = NETRC_TOK_MACDEF; + } + else { + lexer->token = NETRC_TOK_JUNK; + } + break; + } + +out: +#if NETRC_DEBUG + CURL_TRC_M(lexer->data, "[NETRC] token %s '%s', rc=%d", + netrc_tokenstr(lexer->token), + curlx_dyn_ptr(&lexer->literal), rc); +#endif + lexer->pos = s; + return rc; +} + +struct netrc_scanner { + struct netrc_lexer lexer; + const char *hostname; /* non-NULL, machine to scan for */ + const char *user; /* maybe NULL, login to scan for */ + char *login; + char *passwd; + struct Curl_creds *creds; + bool matches_host; + bool found; +}; + +static void netrc_scan_reset(struct netrc_scanner *sc) +{ + curlx_safefree(sc->login); + curlx_safefree(sc->passwd); + sc->matches_host = FALSE; +} + +static void netrc_scan_init(struct netrc_scanner *sc, + struct Curl_easy *data, + const char *content, + const char *hostname, + const char *user) +{ + memset(sc, 0, sizeof(*sc)); + netrc_lexer_init(&sc->lexer, data, content); + sc->hostname = hostname; + sc->user = (user && user[0]) ? user : NULL; + netrc_scan_reset(sc); +} + +static void netrc_scan_cleanup(struct netrc_scanner *sc) +{ + netrc_scan_reset(sc); + sc->hostname = NULL; + sc->user = NULL; + Curl_creds_unlink(&sc->creds); + netrc_lexer_cleanup(&sc->lexer); +} + +static NETRCcode netrc_scan_literal(struct netrc_scanner *sc, + char **pdest) +{ + NETRCcode rc = netrc_lexer_next(&sc->lexer, TRUE); + if(!rc) { + if(sc->lexer.token == NETRC_TOK_LITERAL) { + if(pdest && sc->matches_host) { + curlx_free(*pdest); + *pdest = curlx_strdup(curlx_dyn_ptr(&sc->lexer.literal)); + if(!*pdest) + rc = NETRC_OUT_OF_MEMORY; + } + } + else + netrc_lexer_push(&sc->lexer); + } + return rc; +} + +static NETRCcode netrc_scan_end_entry(struct netrc_scanner *sc) +{ + NETRCcode rc = NETRC_OK; +#if NETRC_DEBUG + CURL_TRC_M(sc->lexer.data, + "[NETRC] entry matches_host=%d, login='%s', passwd='%s'", + sc->matches_host, sc->login, sc->passwd); +#endif + if(sc->matches_host) { + if(sc->login) { + if(sc->user) { + if(Curl_timestrcmp(sc->user, sc->login)) + goto out; + /* We look for a specific user, + * entry is only interesting with password */ + sc->found = !!sc->passwd; + } + else { + sc->found = TRUE; + } + } + else if(sc->passwd) { + /* found a passwd that applies to any user */ + sc->found = TRUE; + } + else { + /* entry has nothing interesting */ + } + if(sc->found) { +#if NETRC_DEBUG + CURL_TRC_M(sc->lexer.data, "[NETRC] entry match found"); +#endif + if(Curl_creds_create(sc->user ? sc->user : sc->login, sc->passwd, + NULL, NULL, NULL, CREDS_NETRC, &sc->creds)) + rc = NETRC_OUT_OF_MEMORY; + } + } +out: + netrc_scan_reset(sc); + return rc; +} + +static NETRCcode netrc_scan(struct Curl_easy *data, + const char *content, + const char *hostname, + const char *user, + struct Curl_creds **pcreds) +{ + struct netrc_scanner sc; + NETRCcode rc = NETRC_OK; + + Curl_creds_unlink(pcreds); + netrc_scan_init(&sc, data, content, hostname, user); + + while(!rc && !sc.found) { + rc = netrc_lexer_next(&sc.lexer, FALSE); + if(!rc) { + /* Does this token end any previous entry? */ + switch(sc.lexer.token) { + case NETRC_TOK_EOF: + case NETRC_TOK_MACHINE: + case NETRC_TOK_DEFAULT: + case NETRC_TOK_MACDEF: + rc = netrc_scan_end_entry(&sc); + if(rc || sc.found) + goto out; + break; + default: + break; + } + + switch(sc.lexer.token) { + case NETRC_TOK_EOF: + goto out; + case NETRC_TOK_MACHINE: + rc = netrc_lexer_next(&sc.lexer, TRUE); + if(!rc) { + if(sc.lexer.token == NETRC_TOK_LITERAL) { + sc.matches_host = curl_strequal( + sc.hostname, curlx_dyn_ptr(&sc.lexer.literal)); + } + else { + sc.matches_host = FALSE; + netrc_lexer_push(&sc.lexer); + } + } + break; + case NETRC_TOK_DEFAULT: + sc.matches_host = TRUE; + break; + case NETRC_TOK_ACCOUNT: + rc = netrc_scan_literal(&sc, NULL); /* ignore, not used */ + break; + case NETRC_TOK_LOGIN: + rc = netrc_scan_literal(&sc, &sc.login); + break; + case NETRC_TOK_PASSWD: + rc = netrc_scan_literal(&sc, &sc.passwd); + break; + case NETRC_TOK_MACDEF: + netrc_skip_to_empty_line(&sc.lexer); + break; + case NETRC_TOK_LITERAL: + case NETRC_TOK_JUNK: + default: + /* skip this */ + break; + } + } + } + +out: + if(!rc) { + if(sc.creds) + Curl_creds_link(pcreds, sc.creds); + else + rc = NETRC_NO_MATCH; + } + netrc_scan_cleanup(&sc); + return rc; +} + +static NETRCcode file2memory(const char *filename, struct dynbuf *filebuf) +{ + NETRCcode ret = NETRC_FILE_MISSING; /* if it cannot open the file */ + FILE *file = curlx_fopen(filename, FOPEN_READTEXT); + + curlx_dyn_reset(filebuf); + if(file) { + curlx_struct_stat stat; + if((curlx_fstat(fileno(file), &stat) == -1) || !S_ISDIR(stat.st_mode)) { + CURLcode result = CURLE_OK; + bool eof; + struct dynbuf linebuf; + curlx_dyn_init(&linebuf, MAX_NETRC_LINE); + ret = NETRC_OK; + do { + const char *line; + /* Curl_get_line always returns lines ending with a newline */ + result = Curl_get_line(&linebuf, file, &eof); + if(!result) { + line = curlx_dyn_ptr(&linebuf); + /* skip comments on load */ + curlx_str_passblanks(&line); + if(*line == '#') + continue; + result = curlx_dyn_add(filebuf, line); + } + if(result) { + curlx_dyn_free(filebuf); + ret = curl2netrc(result); + break; + } + } while(!eof); + curlx_dyn_free(&linebuf); + } + curlx_fclose(file); + } + return ret; +} + +static NETRCcode netrc_scan_file(struct Curl_easy *data, + struct store_netrc *store, + const char *hostname, + const char *user, + const char *netrcfile, + struct Curl_creds **pcreds) +{ + struct dynbuf *filebuf = &store->filebuf; + + if(!store->loaded || strcmp(netrcfile, store->filename)) { + NETRCcode ret; + store->loaded = FALSE; + ret = file2memory(netrcfile, filebuf); + if(ret) { + CURL_TRC_M(data, "[NETRC] could not load '%s'", netrcfile); + return ret; + } + curlx_free(store->filename); + store->filename = curlx_strdup(netrcfile); + if(!store->filename) { + curlx_dyn_reset(&store->filebuf); + return NETRC_OUT_OF_MEMORY; + } + store->loaded = TRUE; + } + + return netrc_scan(data, curlx_dyn_ptr(filebuf), hostname, user, pcreds); +} + +/* + * @unittest: 1304 + * + * *loginp and *passwordp MUST be allocated if they are not NULL when passed + * in. + */ +NETRCcode Curl_netrc_scan(struct Curl_easy *data, + struct store_netrc *store, + const char *hostname, + const char *user, + const char *netrcfile, + struct Curl_creds **pcreds) +{ + NETRCcode retcode = NETRC_OK; + + CURL_TRC_M(data, "[NETRC] scanning '%s' for host '%s' user '%s'", + netrcfile, hostname, user); + Curl_creds_unlink(pcreds); + if(!netrcfile) { + char *home = NULL; + char *homea = NULL; + char *filealloc = NULL; +#if defined(HAVE_GETPWUID_R) && defined(HAVE_GETEUID) + char pwbuf[1024]; +#endif + filealloc = curl_getenv("NETRC"); + if(!filealloc) { + homea = curl_getenv("HOME"); /* portable environment reader */ + if(homea) { + home = homea; +#if defined(HAVE_GETPWUID_R) && defined(HAVE_GETEUID) + } + else { + struct passwd pw, *pw_res; + if(!getpwuid_r(geteuid(), &pw, pwbuf, sizeof(pwbuf), &pw_res) && + pw_res) { + home = pw.pw_dir; + } +#elif defined(HAVE_GETPWUID) && defined(HAVE_GETEUID) + } + else { + struct passwd *pw; + pw = getpwuid(geteuid()); + if(pw) { + home = pw->pw_dir; + } +#elif defined(_WIN32) + } + else { + homea = curl_getenv("USERPROFILE"); + if(homea) { + home = homea; + } +#endif + } + + if(!home) + return NETRC_FILE_MISSING; /* no home directory found (or possibly out + of memory) */ + + filealloc = curl_maprintf("%s%s.netrc", home, DIR_CHAR); + if(!filealloc) { + curlx_free(homea); + retcode = NETRC_OUT_OF_MEMORY; + goto out; + } + } + retcode = netrc_scan_file( + data, store, hostname, user, filealloc, pcreds); + curlx_free(filealloc); +#ifdef _WIN32 + if(retcode == NETRC_FILE_MISSING) { + /* fallback to the old-style "_netrc" file */ + filealloc = curl_maprintf("%s%s_netrc", home, DIR_CHAR); + if(!filealloc) { + curlx_free(homea); + return NETRC_OUT_OF_MEMORY; + } + retcode = netrc_scan_file( + data, store, hostname, user, filealloc, pcreds); + curlx_free(filealloc); + } +#endif + curlx_free(homea); + } + else + retcode = netrc_scan_file( + data, store, hostname, user, netrcfile, pcreds); + +out: + if(retcode) + Curl_creds_unlink(pcreds); + return retcode; +} + +void Curl_netrc_init(struct store_netrc *store) +{ + curlx_dyn_init(&store->filebuf, MAX_NETRC_FILE); + store->loaded = FALSE; + store->filename = NULL; +} +void Curl_netrc_cleanup(struct store_netrc *store) +{ + curlx_dyn_free(&store->filebuf); + curlx_safefree(store->filename); + store->loaded = FALSE; +} + +const char *Curl_netrc_strerror(NETRCcode ret) +{ + switch(ret) { + default: + return ""; /* not a legit error */ + case NETRC_FILE_MISSING: + return "no such file"; + case NETRC_NO_MATCH: + return "no matching entry"; + case NETRC_OUT_OF_MEMORY: + return "out of memory"; + case NETRC_SYNTAX_ERROR: + return "syntax error"; + } + /* never reached */ +} + +#endif /* !CURL_DISABLE_NETRC */ diff --git a/3rdparty/curl-8.21.0/lib/netrc.h b/3rdparty/curl-8.21.0/lib/netrc.h new file mode 100644 index 0000000000..6be9b83316 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/netrc.h @@ -0,0 +1,68 @@ +#ifndef HEADER_CURL_NETRC_H +#define HEADER_CURL_NETRC_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifndef CURL_DISABLE_NETRC + +#include "curlx/dynbuf.h" + +struct Curl_easy; +struct Curl_creds; + +struct store_netrc { + struct dynbuf filebuf; + char *filename; + BIT(loaded); +}; + +typedef enum { + NETRC_OK, + NETRC_NO_MATCH, /* no matching entry in the file */ + NETRC_SYNTAX_ERROR, /* in the netrc file */ + NETRC_FILE_MISSING, /* the netrc file does not exist */ + NETRC_OUT_OF_MEMORY, /* while parsing netrc */ + NETRC_LAST /* never used */ +} NETRCcode; + +const char *Curl_netrc_strerror(NETRCcode ret); +void Curl_netrc_init(struct store_netrc *store); +void Curl_netrc_cleanup(struct store_netrc *store); + +/* Scan a netrc file for credentials matching hostname + * and optional user. */ +NETRCcode Curl_netrc_scan(struct Curl_easy *data, + struct store_netrc *store, + const char *hostname, + const char *user, + const char *netrcfile, + struct Curl_creds **pcreds); +#else +/* disabled */ +#define Curl_netrc_init(x) +#define Curl_netrc_cleanup(x) +#endif + +#endif /* HEADER_CURL_NETRC_H */ diff --git a/3rdparty/curl-8.21.0/lib/openldap.c b/3rdparty/curl-8.21.0/lib/openldap.c new file mode 100644 index 0000000000..8ec6bb27cd --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/openldap.c @@ -0,0 +1,1292 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * Copyright (C) Howard Chu, + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_LDAP) && defined(USE_OPENLDAP) + +/* + * Notice that USE_OPENLDAP is only a source code selection switch. When + * libcurl is built with USE_OPENLDAP defined the libcurl source code that + * gets compiled is the code from openldap.c, otherwise the code that gets + * compiled is the code from ldap.c. + * + * When USE_OPENLDAP is defined a recent version of the OpenLDAP library + * might be required for compilation and runtime. In order to use ancient + * OpenLDAP library versions, USE_OPENLDAP shall not be defined. + */ + +#include + +#include "urldata.h" +#include "url.h" +#include "sendf.h" +#include "curl_trc.h" +#include "vtls/vtls.h" +#include "transfer.h" +#include "curl_ldap.h" +#include "curlx/base64.h" +#include "cfilters.h" +#include "connect.h" +#include "curl_sasl.h" +#include "strcase.h" +#include "bufref.h" + +/* + * Uncommenting this will enable the built-in debug logging of the openldap + * library. The debug log level can be set using the CURL_OPENLDAP_TRACE + * environment variable. The debug output is written to stderr. + * + * The library supports the following debug flags: + * LDAP_DEBUG_NONE 0x0000 + * LDAP_DEBUG_TRACE 0x0001 + * LDAP_DEBUG_CONSTRUCT 0x0002 + * LDAP_DEBUG_DESTROY 0x0004 + * LDAP_DEBUG_PARAMETER 0x0008 + * LDAP_DEBUG_ANY 0xffff + * + * For example, use CURL_OPENLDAP_TRACE=0 for no debug, + * CURL_OPENLDAP_TRACE=2 for LDAP_DEBUG_CONSTRUCT messages only, + * CURL_OPENLDAP_TRACE=65535 for all debug message levels. + */ +/* #define CURL_OPENLDAP_DEBUG */ + +/* Machine states. */ +typedef enum { + OLDAP_STOP, /* Do nothing state, stops the state machine */ + OLDAP_SSL, /* Performing SSL handshake. */ + OLDAP_STARTTLS, /* STARTTLS request sent. */ + OLDAP_TLS, /* Performing TLS handshake. */ + OLDAP_MECHS, /* Get SASL authentication mechanisms. */ + OLDAP_SASL, /* SASL binding reply. */ + OLDAP_BIND, /* Simple bind reply. */ + OLDAP_BINDV2, /* Simple bind reply in protocol version 2. */ + OLDAP_LAST /* Never used */ +} ldapstate; + +#ifndef _LDAP_PVT_H +extern int ldap_pvt_url_scheme2proto(const char *); +extern int ldap_init_fd(ber_socket_t fd, int proto, const char *url, + LDAP **ld); +#endif + +static Curl_recv oldap_recv; + +struct ldapconninfo { + struct SASL sasl; /* SASL-related parameters */ + LDAP *ld; /* Openldap connection handle. */ + Curl_recv *recv; /* For stacking SSL handler */ + Curl_send *send; + struct berval *servercred; /* SASL data from server. */ + ldapstate state; /* Current machine state. */ + int proto; /* LDAP_PROTO_TCP/LDAP_PROTO_UDP/LDAP_PROTO_IPC */ + int msgid; /* Current message id. */ +}; + +struct ldapreqinfo { + int msgid; + int nument; +}; + +/* meta key for storing ldapconninfo at easy handle */ +#define CURL_META_LDAP_EASY "meta:proto:ldap:easy" +/* meta key for storing ldapconninfo at connection */ +#define CURL_META_LDAP_CONN "meta:proto:ldap:conn" + +/* + * oldap_state() + * + * This is the ONLY way to change LDAP state! + */ +static void oldap_state(struct Curl_easy *data, struct ldapconninfo *li, + ldapstate newstate) +{ +#if defined(DEBUGBUILD) && defined(CURLVERBOSE) + /* for debug purposes */ + static const char * const names[] = { + "STOP", + "SSL", + "STARTTLS", + "TLS", + "MECHS", + "SASL", + "BIND", + "BINDV2", + /* LAST */ + }; + + if(li->state != newstate) + infof(data, "LDAP %p state change from %s to %s", + (void *)li, names[li->state], names[newstate]); +#else + (void)data; +#endif + li->state = newstate; +} + +/* Map some particular LDAP error codes to CURLcode values. */ +static CURLcode oldap_map_error(int rc, CURLcode result) +{ + switch(rc) { + case LDAP_NO_MEMORY: + return CURLE_OUT_OF_MEMORY; + case LDAP_INVALID_CREDENTIALS: + return CURLE_LOGIN_DENIED; + case LDAP_PROTOCOL_ERROR: + return CURLE_UNSUPPORTED_PROTOCOL; + case LDAP_INSUFFICIENT_ACCESS: + return CURLE_REMOTE_ACCESS_DENIED; + } + return result; +} + +static CURLcode oldap_url_parse(struct Curl_easy *data, LDAPURLDesc **ludp) +{ + CURLcode result = CURLE_OK; + int rc = LDAP_URL_ERR_BADURL; + static const char * const url_errs[] = { + "success", + "out of memory", + "bad parameter", + "unrecognized scheme", + "unbalanced delimiter", + "bad URL", + "bad host or port", + "bad or missing attributes", + "bad or missing scope", + "bad or missing filter", + "bad or missing extensions" + }; + + *ludp = NULL; + if(!data->state.up.user && !data->state.up.password && + !data->state.up.options) + rc = ldap_url_parse(Curl_bufref_ptr(&data->state.url), ludp); + if(rc != LDAP_URL_SUCCESS) { + const char *msg = "url parsing problem"; + + result = rc == LDAP_URL_ERR_MEM ? CURLE_OUT_OF_MEMORY : + CURLE_URL_MALFORMAT; + rc -= LDAP_URL_SUCCESS; + if((size_t)rc < CURL_ARRAYSIZE(url_errs)) + msg = url_errs[rc]; + failf(data, "LDAP local: %s", msg); + } + return result; +} + +/* Parse the login options. */ +static CURLcode oldap_parse_login_options(struct connectdata *conn) +{ + CURLcode result = CURLE_OK; + struct ldapconninfo *li = Curl_conn_meta_get(conn, CURL_META_LDAP_CONN); + const char *ptr = conn->options; + + DEBUGASSERT(li); + if(!li) + return CURLE_FAILED_INIT; + + while(!result && ptr && *ptr) { + const char *key = ptr; + const char *value; + + while(*ptr && *ptr != '=') + ptr++; + + value = ptr + 1; + + while(*ptr && *ptr != ';') + ptr++; + + if(checkprefix("AUTH=", key)) + result = Curl_sasl_parse_url_auth_option(&li->sasl, value, ptr - value); + else + result = CURLE_SETOPT_OPTION_SYNTAX; + + if(*ptr == ';') + ptr++; + } + + return result == CURLE_URL_MALFORMAT ? CURLE_SETOPT_OPTION_SYNTAX : result; +} + +static CURLcode oldap_setup_connection(struct Curl_easy *data, + struct connectdata *conn) +{ + CURLcode result; + LDAPURLDesc *lud; + (void)conn; + + /* Early URL syntax check. */ + result = oldap_url_parse(data, &lud); + ldap_free_urldesc(lud); + + return result; +} + +/* + * Get the SASL authentication challenge from the server credential buffer. + */ +static CURLcode oldap_get_message(struct Curl_easy *data, struct bufref *out) +{ + struct ldapconninfo *li = + Curl_conn_meta_get(data->conn, CURL_META_LDAP_CONN); + struct berval *servercred = li ? li->servercred : NULL; + DEBUGASSERT(li); + if(!li) + return CURLE_FAILED_INIT; + + if(!servercred || !servercred->bv_val) + return CURLE_WEIRD_SERVER_REPLY; + Curl_bufref_set(out, servercred->bv_val, servercred->bv_len, NULL); + return CURLE_OK; +} + +/* + * Sends an initial SASL bind request to the server. + */ +static CURLcode oldap_perform_auth(struct Curl_easy *data, const char *mech, + const struct bufref *initresp) +{ + struct connectdata *conn = data->conn; + struct ldapconninfo *li = Curl_conn_meta_get(conn, CURL_META_LDAP_CONN); + struct berval cred; + struct berval *pcred = &cred; + int rc; + + DEBUGASSERT(li); + if(!li) + return CURLE_FAILED_INIT; + cred.bv_val = (char *)CURL_UNCONST(Curl_bufref_ptr(initresp)); + cred.bv_len = Curl_bufref_len(initresp); + if(!cred.bv_val) + pcred = NULL; + rc = ldap_sasl_bind(li->ld, NULL, mech, pcred, NULL, NULL, &li->msgid); + if(rc != LDAP_SUCCESS) + return oldap_map_error(rc, CURLE_LDAP_CANNOT_BIND); + return CURLE_OK; +} + +/* + * Sends SASL continuation. + */ +static CURLcode oldap_continue_auth(struct Curl_easy *data, const char *mech, + const struct bufref *resp) +{ + struct connectdata *conn = data->conn; + struct ldapconninfo *li = Curl_conn_meta_get(conn, CURL_META_LDAP_CONN); + struct berval cred; + struct berval *pcred = &cred; + int rc; + + if(!li) + return CURLE_FAILED_INIT; + cred.bv_val = (char *)CURL_UNCONST(Curl_bufref_ptr(resp)); + cred.bv_len = Curl_bufref_len(resp); + if(!cred.bv_val) + pcred = NULL; + rc = ldap_sasl_bind(li->ld, NULL, mech, pcred, NULL, NULL, &li->msgid); + if(rc != LDAP_SUCCESS) + return oldap_map_error(rc, CURLE_LDAP_CANNOT_BIND); + return CURLE_OK; +} + +/* + * Sends SASL bind cancellation. + */ +static CURLcode oldap_cancel_auth(struct Curl_easy *data, const char *mech) +{ + struct ldapconninfo *li = + Curl_conn_meta_get(data->conn, CURL_META_LDAP_CONN); + int rc; + + (void)mech; + if(!li) + return CURLE_FAILED_INIT; + rc = ldap_sasl_bind(li->ld, NULL, LDAP_SASL_NULL, NULL, NULL, NULL, + &li->msgid); + if(rc != LDAP_SUCCESS) + return oldap_map_error(rc, CURLE_LDAP_CANNOT_BIND); + return CURLE_OK; +} + +/* Starts LDAP simple bind. */ +static CURLcode oldap_perform_bind(struct Curl_easy *data, ldapstate newstate) +{ + struct connectdata *conn = data->conn; + struct ldapconninfo *li = Curl_conn_meta_get(conn, CURL_META_LDAP_CONN); + const char *binddn = NULL; + struct berval passwd; + int rc; + + if(!li) + return CURLE_FAILED_INIT; + passwd.bv_val = NULL; + passwd.bv_len = 0; + + if(conn->creds) { + binddn = Curl_creds_user(conn->creds); + passwd.bv_val = CURL_UNCONST(Curl_creds_passwd(conn->creds)); + passwd.bv_len = strlen(passwd.bv_val); + } + + rc = ldap_sasl_bind(li->ld, binddn, LDAP_SASL_SIMPLE, &passwd, + NULL, NULL, &li->msgid); + if(rc != LDAP_SUCCESS) + return oldap_map_error(rc, + data->state.creds ? + CURLE_LOGIN_DENIED : CURLE_LDAP_CANNOT_BIND); + oldap_state(data, li, newstate); + return CURLE_OK; +} + +/* Query the supported SASL authentication mechanisms. */ +static CURLcode oldap_perform_mechs(struct Curl_easy *data) +{ + struct ldapconninfo *li = + Curl_conn_meta_get(data->conn, CURL_META_LDAP_CONN); + int rc; + static const char * const supportedSASLMechanisms[] = { + "supportedSASLMechanisms", + NULL + }; + + if(!li) + return CURLE_FAILED_INIT; + /* Casting away the const for the 3rd parameter that the LDAP API expects as + a non-const char ** is potentially unsafe but we believe the lack of + const in the API was an oversight and that no LDAP implementation + actually modifies the input. */ + rc = ldap_search_ext(li->ld, "", LDAP_SCOPE_BASE, "(objectclass=*)", + (char **)CURL_UNCONST(supportedSASLMechanisms), 0, + NULL, NULL, NULL, 0, &li->msgid); + if(rc != LDAP_SUCCESS) + return oldap_map_error(rc, CURLE_LOGIN_DENIED); + oldap_state(data, li, OLDAP_MECHS); + return CURLE_OK; +} + +/* Starts SASL bind. */ +static CURLcode oldap_perform_sasl(struct Curl_easy *data) +{ + struct ldapconninfo *li = + Curl_conn_meta_get(data->conn, CURL_META_LDAP_CONN); + saslprogress progress = SASL_IDLE; + CURLcode result; + + if(!li) + return CURLE_FAILED_INIT; + result = Curl_sasl_start(&li->sasl, data, TRUE, &progress); + + oldap_state(data, li, OLDAP_SASL); + if(!result && progress != SASL_INPROGRESS) + result = Curl_sasl_is_blocked(&li->sasl, data); + return result; +} + +#ifdef USE_SSL +static int ldapsb_tls_setup(Sockbuf_IO_Desc *sbiod, void *arg) +{ + sbiod->sbiod_pvt = arg; + return 0; +} + +static int ldapsb_tls_remove(Sockbuf_IO_Desc *sbiod) +{ + sbiod->sbiod_pvt = NULL; + return 0; +} + +/* We do not need to do anything because libcurl does it already */ +static int ldapsb_tls_close(Sockbuf_IO_Desc *sbiod) +{ + (void)sbiod; + return 0; +} + +static int ldapsb_tls_ctrl(Sockbuf_IO_Desc *sbiod, int opt, void *arg) +{ + (void)arg; + if(opt == LBER_SB_OPT_DATA_READY) { + struct Curl_easy *data = sbiod->sbiod_pvt; + return Curl_conn_data_pending(data, FIRSTSOCKET); + } + return 0; +} + +static ber_slen_t ldapsb_tls_read(Sockbuf_IO_Desc *sbiod, void *buf, + ber_len_t len) +{ + struct Curl_easy *data = sbiod->sbiod_pvt; + ber_slen_t ret = 0; + if(data) { + struct connectdata *conn = data->conn; + if(conn) { + struct ldapconninfo *li = Curl_conn_meta_get(conn, CURL_META_LDAP_CONN); + CURLcode result = CURLE_RECV_ERROR; + size_t nread; + + if(!li) { + SET_SOCKERRNO(SOCKEINVAL); + return -1; + } + result = (li->recv)(data, FIRSTSOCKET, buf, len, &nread); + if(result == CURLE_AGAIN) { + SET_SOCKERRNO(SOCKEWOULDBLOCK); + } + ret = result ? -1 : (ber_slen_t)nread; + } + } + return ret; +} + +static ber_slen_t ldapsb_tls_write(Sockbuf_IO_Desc *sbiod, void *buf, + ber_len_t len) +{ + struct Curl_easy *data = sbiod->sbiod_pvt; + ber_slen_t ret = 0; + if(data) { + struct connectdata *conn = data->conn; + if(conn) { + struct ldapconninfo *li = Curl_conn_meta_get(conn, CURL_META_LDAP_CONN); + CURLcode result = CURLE_SEND_ERROR; + size_t nwritten; + + if(!li) { + SET_SOCKERRNO(SOCKEINVAL); + return -1; + } + result = (li->send)(data, FIRSTSOCKET, buf, len, FALSE, &nwritten); + if(result == CURLE_AGAIN) { + SET_SOCKERRNO(SOCKEWOULDBLOCK); + } + ret = result ? -1 : (ber_slen_t)nwritten; + } + } + return ret; +} + +static Sockbuf_IO ldapsb_tls = { + ldapsb_tls_setup, + ldapsb_tls_remove, + ldapsb_tls_ctrl, + ldapsb_tls_read, + ldapsb_tls_write, + ldapsb_tls_close +}; + +static bool ssl_installed(struct connectdata *conn) +{ + struct ldapconninfo *li = Curl_conn_meta_get(conn, CURL_META_LDAP_CONN); + return li && li->recv; +} + +static CURLcode oldap_ssl_connect(struct Curl_easy *data, ldapstate newstate) +{ + struct connectdata *conn = data->conn; + struct ldapconninfo *li = Curl_conn_meta_get(conn, CURL_META_LDAP_CONN); + bool ssldone = FALSE; + CURLcode result; + + if(!li) + return CURLE_FAILED_INIT; + result = Curl_conn_connect(data, FIRSTSOCKET, FALSE, &ssldone); + if(result) + return result; + oldap_state(data, li, newstate); + + if(ssldone) { + Sockbuf *sb; + + /* Install the libcurl SSL handlers into the sockbuf. */ + if((ldap_get_option(li->ld, LDAP_OPT_SOCKBUF, &sb) != LDAP_OPT_SUCCESS) || + ber_sockbuf_add_io(sb, &ldapsb_tls, LBER_SBIOD_LEVEL_TRANSPORT, data)) + return CURLE_FAILED_INIT; + li->recv = conn->recv[FIRSTSOCKET]; + li->send = conn->send[FIRSTSOCKET]; + } + + return result; +} + +/* Send the STARTTLS request */ +static CURLcode oldap_perform_starttls(struct Curl_easy *data) +{ + struct ldapconninfo *li = + Curl_conn_meta_get(data->conn, CURL_META_LDAP_CONN); + int rc; + + if(!li) + return CURLE_FAILED_INIT; + rc = ldap_start_tls(li->ld, NULL, NULL, &li->msgid); + if(rc != LDAP_SUCCESS) + return oldap_map_error(rc, CURLE_USE_SSL_FAILED); + oldap_state(data, li, OLDAP_STARTTLS); + return CURLE_OK; +} +#endif + +static void oldap_easy_dtor(void *key, size_t klen, void *entry) +{ + struct ldapreqinfo *lr = entry; + (void)key; + (void)klen; + curlx_free(lr); +} + +static void oldap_conn_dtor(void *key, size_t klen, void *entry) +{ + struct ldapconninfo *li = entry; + (void)key; + (void)klen; + if(li->ld) { + ldap_unbind_ext(li->ld, NULL, NULL); + li->ld = NULL; + } + curlx_free(li); +} + +/* SASL parameters for the ldap protocol */ +static const struct SASLproto saslldap = { + "ldap", /* The service name */ + oldap_perform_auth, /* Send authentication command */ + oldap_continue_auth, /* Send authentication continuation */ + oldap_cancel_auth, /* Send authentication cancellation */ + oldap_get_message, /* Get SASL response message */ + 0, /* Maximum initial response length (no max) */ + LDAP_SASL_BIND_IN_PROGRESS, /* Code received when continuation is expected */ + LDAP_SUCCESS, /* Code to receive upon authentication success */ + SASL_AUTH_NONE, /* Default mechanisms */ + 0 /* Configuration flags */ +}; + +static CURLcode oldap_connect(struct Curl_easy *data, bool *done) +{ + struct connectdata *conn = data->conn; + struct ldapconninfo *li; + static const int version = LDAP_VERSION3; + char *hosturl = NULL; + CURLcode result; + int rc; +#ifdef CURL_OPENLDAP_DEBUG + static int do_trace = -1; +#endif + + (void)done; + + li = curlx_calloc(1, sizeof(struct ldapconninfo)); + if(!li) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + result = Curl_conn_meta_set(conn, CURL_META_LDAP_CONN, li, oldap_conn_dtor); + if(result) + goto out; + + li->proto = ldap_pvt_url_scheme2proto(data->state.up.scheme); + + /* Initialize the SASL storage */ + Curl_sasl_init(&li->sasl, data, &saslldap); + + result = oldap_parse_login_options(conn); + if(result) + goto out; + + hosturl = curl_maprintf("%s://%s:%d", + conn->scheme->name, + (data->state.up.hostname[0] == '[') ? + data->state.up.hostname : conn->origin->hostname, + conn->origin->port); + if(!hosturl) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + rc = ldap_init_fd(conn->sock[FIRSTSOCKET], li->proto, hosturl, &li->ld); + if(rc) { + failf(data, "LDAP local: Cannot connect to %s, %s", + hosturl, ldap_err2string(rc)); + result = CURLE_COULDNT_CONNECT; + goto out; + } + +#ifdef CURL_OPENLDAP_DEBUG + if(do_trace < 0) { + const char *env = getenv("CURL_OPENLDAP_TRACE"); + curl_off_t e = 0; + if(!curlx_str_number(&env, &e, INT_MAX)) + do_trace = e > 0; + } + if(do_trace) + ldap_set_option(li->ld, LDAP_OPT_DEBUG_LEVEL, &do_trace); +#endif + + /* Try version 3 first. */ + ldap_set_option(li->ld, LDAP_OPT_PROTOCOL_VERSION, &version); + + /* Do not chase referrals. */ + ldap_set_option(li->ld, LDAP_OPT_REFERRALS, LDAP_OPT_OFF); + + { + ber_len_t max = 256 * 1024; + Sockbuf *sb; + if((ldap_get_option(li->ld, LDAP_OPT_SOCKBUF, &sb) != LDAP_OPT_SUCCESS) || + /* Set the maximum allowed size of an incoming message, which to + OpenLDAP means that it will malloc() memory up to this size. If not + set, there is no limit and we instead risk a malloc() failure. */ + !ber_sockbuf_ctrl(sb, LBER_SB_OPT_SET_MAX_INCOMING, &max)) { + result = CURLE_FAILED_INIT; + goto out; + } + } + +#ifdef USE_SSL + if(Curl_conn_is_ssl(conn, FIRSTSOCKET)) { + result = oldap_ssl_connect(data, OLDAP_SSL); + goto out; + } + + if(data->set.use_ssl) { + result = oldap_perform_starttls(data); + if(!result || data->set.use_ssl != CURLUSESSL_TRY) + goto out; + } +#endif + + if(li->sasl.prefmech != SASL_AUTH_NONE) { + result = oldap_perform_mechs(data); + goto out; + } + + /* Force bind even if anonymous bind is not needed in protocol version 3 + to detect missing version 3 support. */ + result = oldap_perform_bind(data, OLDAP_BIND); + +out: + curlx_free(hosturl); + return result; +} + +/* Handle the supported SASL mechanisms query response */ +static CURLcode oldap_state_mechs_resp(struct Curl_easy *data, + LDAPMessage *msg, int code) +{ + struct connectdata *conn; + struct ldapconninfo *li; + int rc; + BerElement *ber = NULL; + CURLcode result = CURLE_OK; + struct berval bv, *bvals; + + if(!data) + return CURLE_FAILED_INIT; + + conn = data->conn; + li = Curl_conn_meta_get(conn, CURL_META_LDAP_CONN); + + if(!li) + return CURLE_FAILED_INIT; + switch(ldap_msgtype(msg)) { + case LDAP_RES_SEARCH_ENTRY: + /* Got a list of supported SASL mechanisms. */ + if(code != LDAP_SUCCESS && code != LDAP_NO_RESULTS_RETURNED) + return CURLE_LOGIN_DENIED; + + rc = ldap_get_dn_ber(li->ld, msg, &ber, &bv); + if(rc < 0) + return oldap_map_error(rc, CURLE_BAD_CONTENT_ENCODING); + for(rc = ldap_get_attribute_ber(li->ld, msg, ber, &bv, &bvals); + rc == LDAP_SUCCESS; + rc = ldap_get_attribute_ber(li->ld, msg, ber, &bv, &bvals)) { + int i; + + if(!bv.bv_val) + break; + + if(bvals) { + for(i = 0; bvals[i].bv_val; i++) { + size_t llen; + unsigned short mech = + Curl_sasl_decode_mech((const char *)bvals[i].bv_val, + bvals[i].bv_len, &llen); + if(bvals[i].bv_len == llen) + li->sasl.authmechs |= mech; + } + ber_memfree(bvals); + } + } + ber_free(ber, 0); + break; + + case LDAP_RES_SEARCH_RESULT: + switch(code) { + case LDAP_SIZELIMIT_EXCEEDED: + infof(data, "Too many authentication mechanisms"); + FALLTHROUGH(); + case LDAP_SUCCESS: + case LDAP_NO_RESULTS_RETURNED: + if(Curl_sasl_can_authenticate(&li->sasl, data)) + result = oldap_perform_sasl(data); + else + result = CURLE_LOGIN_DENIED; + break; + default: + result = oldap_map_error(code, CURLE_LOGIN_DENIED); + break; + } + break; + default: + break; + } + return result; +} + +/* Handle a SASL bind response. */ +static CURLcode oldap_state_sasl_resp(struct Curl_easy *data, + LDAPMessage *msg, int code) +{ + struct connectdata *conn = data->conn; + struct ldapconninfo *li = Curl_conn_meta_get(conn, CURL_META_LDAP_CONN); + CURLcode result = CURLE_OK; + saslprogress progress; + int rc; + + if(!li) + return CURLE_FAILED_INIT; + li->servercred = NULL; + rc = ldap_parse_sasl_bind_result(li->ld, msg, &li->servercred, 0); + if(rc != LDAP_SUCCESS) { + failf(data, "LDAP local: sasl ldap_parse_result %s", ldap_err2string(rc)); + result = oldap_map_error(rc, CURLE_LOGIN_DENIED); + } + else { + result = Curl_sasl_continue(&li->sasl, data, code, &progress); + if(!result && progress != SASL_INPROGRESS) + oldap_state(data, li, OLDAP_STOP); + } + + if(li->servercred) + ber_bvfree(li->servercred); + return result; +} + +/* Handle a simple bind response. */ +static CURLcode oldap_state_bind_resp(struct Curl_easy *data, LDAPMessage *msg, + int code) +{ + struct connectdata *conn = data->conn; + struct ldapconninfo *li = Curl_conn_meta_get(conn, CURL_META_LDAP_CONN); + CURLcode result = CURLE_OK; + struct berval *bv = NULL; + int rc; + + if(!li) + return CURLE_FAILED_INIT; + + if(code != LDAP_SUCCESS) + return oldap_map_error(code, CURLE_LDAP_CANNOT_BIND); + + rc = ldap_parse_sasl_bind_result(li->ld, msg, &bv, 0); + if(rc != LDAP_SUCCESS) { + failf(data, "LDAP local: bind ldap_parse_sasl_bind_result %s", + ldap_err2string(rc)); + result = oldap_map_error(rc, CURLE_LDAP_CANNOT_BIND); + } + else + oldap_state(data, li, OLDAP_STOP); + + if(bv) + ber_bvfree(bv); + return result; +} + +static CURLcode oldap_connecting(struct Curl_easy *data, bool *done) +{ + CURLcode result = CURLE_OK; + struct connectdata *conn = data->conn; + struct ldapconninfo *li = Curl_conn_meta_get(conn, CURL_META_LDAP_CONN); + LDAPMessage *msg = NULL; + struct timeval tv = { 0, 0 }; + int code = LDAP_SUCCESS; + int rc; + + if(!li) + return CURLE_FAILED_INIT; + + if(li->state != OLDAP_SSL && li->state != OLDAP_TLS) { + /* Get response to last command. */ + rc = ldap_result(li->ld, li->msgid, LDAP_MSG_ONE, &tv, &msg); + switch(rc) { + case 0: /* Timed out. */ + return CURLE_OK; + case LDAP_RES_SEARCH_ENTRY: + case LDAP_RES_SEARCH_REFERENCE: + break; + default: + li->msgid = 0; /* Nothing to abandon upon error. */ + if(rc < 0) { + failf(data, "LDAP local: connecting ldap_result %s", + ldap_err2string(rc)); + return oldap_map_error(rc, CURLE_COULDNT_CONNECT); + } + break; + } + + /* Get error code from message. */ + rc = ldap_parse_result(li->ld, msg, &code, NULL, NULL, NULL, NULL, 0); + if(rc) + code = rc; + else { + /* store the latest code for later retrieval */ + data->info.httpcode = code; + } + + /* If protocol version 3 is not supported, fallback to version 2. */ + if(code == LDAP_PROTOCOL_ERROR && li->state != OLDAP_BINDV2 && +#ifdef USE_SSL + (ssl_installed(conn) || data->set.use_ssl <= CURLUSESSL_TRY) && +#endif + li->sasl.prefmech == SASL_AUTH_NONE) { + static const int version = LDAP_VERSION2; + + ldap_set_option(li->ld, LDAP_OPT_PROTOCOL_VERSION, &version); + ldap_msgfree(msg); + return oldap_perform_bind(data, OLDAP_BINDV2); + } + } + + /* Handle response message according to current state. */ + switch(li->state) { + +#ifdef USE_SSL + case OLDAP_SSL: + result = oldap_ssl_connect(data, OLDAP_SSL); + if(!result && ssl_installed(conn)) { + if(li->sasl.prefmech != SASL_AUTH_NONE) + result = oldap_perform_mechs(data); + else + result = oldap_perform_bind(data, OLDAP_BIND); + } + break; + case OLDAP_STARTTLS: + if(code != LDAP_SUCCESS) { + if(data->set.use_ssl != CURLUSESSL_TRY) + result = oldap_map_error(code, CURLE_USE_SSL_FAILED); + else if(li->sasl.prefmech != SASL_AUTH_NONE) + result = oldap_perform_mechs(data); + else + result = oldap_perform_bind(data, OLDAP_BIND); + break; + } + result = Curl_ssl_cfilter_add( + data, Curl_conn_get_origin(conn, FIRSTSOCKET), conn, FIRSTSOCKET); + if(result) + break; + FALLTHROUGH(); + case OLDAP_TLS: + result = oldap_ssl_connect(data, OLDAP_TLS); + if(result) + result = oldap_map_error(code, CURLE_USE_SSL_FAILED); + else if(ssl_installed(conn)) { + if(li->sasl.prefmech != SASL_AUTH_NONE) + result = oldap_perform_mechs(data); + else if(data->state.creds) + result = oldap_perform_bind(data, OLDAP_BIND); + else { + /* Version 3 supported: no bind required */ + oldap_state(data, li, OLDAP_STOP); + result = CURLE_OK; + } + } + break; +#endif + + case OLDAP_MECHS: + result = oldap_state_mechs_resp(data, msg, code); + break; + case OLDAP_SASL: + result = oldap_state_sasl_resp(data, msg, code); + break; + case OLDAP_BIND: + case OLDAP_BINDV2: + result = oldap_state_bind_resp(data, msg, code); + break; + default: + /* internal error */ + result = CURLE_COULDNT_CONNECT; + break; + } + + ldap_msgfree(msg); + + *done = li->state == OLDAP_STOP; + if(*done) + conn->recv[FIRSTSOCKET] = oldap_recv; + + if(result && li->msgid) { + ldap_abandon_ext(li->ld, li->msgid, NULL, NULL); + li->msgid = 0; + } + return result; +} + +static CURLcode oldap_disconnect(struct Curl_easy *data, + struct connectdata *conn, + bool dead_connection) +{ + struct ldapconninfo *li = Curl_conn_meta_get(conn, CURL_META_LDAP_CONN); + (void)dead_connection; +#ifndef USE_SSL + (void)data; +#endif + + if(li && li->ld) { +#ifdef USE_SSL + if(ssl_installed(conn)) { + Sockbuf *sb; + if(ldap_get_option(li->ld, LDAP_OPT_SOCKBUF, &sb) != LDAP_OPT_SUCCESS || + ber_sockbuf_add_io(sb, &ldapsb_tls, LBER_SBIOD_LEVEL_TRANSPORT, data)) + return CURLE_FAILED_INIT; + } +#endif + ldap_unbind_ext(li->ld, NULL, NULL); + li->ld = NULL; + } + return CURLE_OK; +} + +static CURLcode oldap_do(struct Curl_easy *data, bool *done) +{ + struct connectdata *conn = data->conn; + struct ldapconninfo *li = Curl_conn_meta_get(conn, CURL_META_LDAP_CONN); + struct ldapreqinfo *lr; + CURLcode result; + int rc; + LDAPURLDesc *lud; + int msgid; + + if(!li) + return CURLE_FAILED_INIT; + + infof(data, "LDAP local: %s", Curl_bufref_ptr(&data->state.url)); + + result = oldap_url_parse(data, &lud); + if(result) + goto out; + +#ifdef USE_SSL + if(ssl_installed(conn)) { + Sockbuf *sb; + /* re-install the libcurl SSL handlers into the sockbuf. */ + if((ldap_get_option(li->ld, LDAP_OPT_SOCKBUF, &sb) != LDAP_OPT_SUCCESS) || + ber_sockbuf_add_io(sb, &ldapsb_tls, LBER_SBIOD_LEVEL_TRANSPORT, data)) { + ldap_free_urldesc(lud); + return CURLE_FAILED_INIT; + } + } +#endif + + rc = ldap_search_ext(li->ld, lud->lud_dn, lud->lud_scope, + lud->lud_filter, lud->lud_attrs, 0, + NULL, NULL, NULL, 0, &msgid); + ldap_free_urldesc(lud); + if(rc != LDAP_SUCCESS) { + failf(data, "LDAP local: ldap_search_ext %s", ldap_err2string(rc)); + result = CURLE_LDAP_SEARCH_FAILED; + goto out; + } + + lr = curlx_calloc(1, sizeof(struct ldapreqinfo)); + if(!lr || + Curl_meta_set(data, CURL_META_LDAP_EASY, lr, oldap_easy_dtor)) { + ldap_abandon_ext(li->ld, msgid, NULL, NULL); + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + lr->msgid = msgid; + Curl_xfer_setup_recv(data, FIRSTSOCKET, -1); + *done = TRUE; + +out: + return result; +} + +static CURLcode oldap_done(struct Curl_easy *data, CURLcode res, + bool premature) +{ + struct connectdata *conn = data->conn; + struct ldapreqinfo *lr = Curl_meta_get(data, CURL_META_LDAP_EASY); + + (void)res; + (void)premature; + + if(lr) { + /* if there was a search in progress, abandon it */ + if(lr->msgid) { + struct ldapconninfo *li = Curl_conn_meta_get(conn, CURL_META_LDAP_CONN); + if(li && li->ld) { + ldap_abandon_ext(li->ld, lr->msgid, NULL, NULL); + } + lr->msgid = 0; + } + Curl_meta_remove(data, CURL_META_LDAP_EASY); + } + + return CURLE_OK; +} + +static CURLcode client_write(struct Curl_easy *data, + const char *prefix, size_t plen, + const char *value, size_t len, + const char *suffix, size_t slen) +{ + CURLcode result = CURLE_OK; + + if(prefix) { + /* If we have a zero-length value and the prefix ends with a space + separator, drop the latter. */ + if(!len && plen && prefix[plen - 1] == ' ') + plen--; + result = Curl_client_write(data, CLIENTWRITE_BODY, prefix, plen); + } + if(!result && value) { + result = Curl_client_write(data, CLIENTWRITE_BODY, value, len); + } + if(!result && suffix) { + result = Curl_client_write(data, CLIENTWRITE_BODY, suffix, slen); + } + return result; +} + +static CURLcode oldap_recv(struct Curl_easy *data, int sockindex, char *buf, + size_t len, size_t *pnread) +{ + struct connectdata *conn = data->conn; + struct ldapconninfo *li = Curl_conn_meta_get(conn, CURL_META_LDAP_CONN); + struct ldapreqinfo *lr = Curl_meta_get(data, CURL_META_LDAP_EASY); + int rc; + LDAPMessage *msg = NULL; + BerElement *ber = NULL; + struct timeval tv = { 0, 0 }; + struct berval bv, *bvals; + CURLcode result = CURLE_AGAIN; + int code; + char *info = NULL; + + (void)len; + (void)buf; + (void)sockindex; + *pnread = 0; + if(!li || !lr) + return CURLE_FAILED_INIT; + + rc = ldap_result(li->ld, lr->msgid, LDAP_MSG_ONE, &tv, &msg); + if(rc < 0) { + failf(data, "LDAP local: search ldap_result %s", ldap_err2string(rc)); + result = CURLE_RECV_ERROR; + } + + /* error or timed out */ + if(!msg) + return result; + + result = CURLE_OK; + + switch(ldap_msgtype(msg)) { + case LDAP_RES_SEARCH_RESULT: + lr->msgid = 0; + rc = ldap_parse_result(li->ld, msg, &code, NULL, &info, NULL, NULL, 0); + if(rc) { + failf(data, "LDAP local: search ldap_parse_result %s", + ldap_err2string(rc)); + result = CURLE_LDAP_SEARCH_FAILED; + break; + } + + /* store the latest code for later retrieval */ + data->info.httpcode = code; + + switch(code) { + case LDAP_SIZELIMIT_EXCEEDED: + infof(data, "There are more than %d entries", lr->nument); + FALLTHROUGH(); + case LDAP_SUCCESS: + data->req.size = data->req.bytecount; + break; + default: + failf(data, "LDAP remote: search failed %s %s", ldap_err2string(code), + info ? info : ""); + result = CURLE_LDAP_SEARCH_FAILED; + break; + } + if(info) + ldap_memfree(info); + break; + case LDAP_RES_SEARCH_ENTRY: + lr->nument++; + rc = ldap_get_dn_ber(li->ld, msg, &ber, &bv); + if(rc < 0) { + result = CURLE_RECV_ERROR; + break; + } + + result = client_write(data, STRCONST("DN: "), bv.bv_val, bv.bv_len, + STRCONST("\n")); + if(result) + break; + + for(rc = ldap_get_attribute_ber(li->ld, msg, ber, &bv, &bvals); + rc == LDAP_SUCCESS; + rc = ldap_get_attribute_ber(li->ld, msg, ber, &bv, &bvals)) { + int i; + bool binary; + + if(!bv.bv_val) + break; + + if(!bvals) { + result = client_write(data, STRCONST("\t"), bv.bv_val, bv.bv_len, + STRCONST(":\n")); + if(result) + break; + continue; + } + + binary = bv.bv_len > 7 && + curl_strnequal(bv.bv_val + bv.bv_len - 7, ";binary", 7); + + for(i = 0; bvals[i].bv_val; i++) { + bool binval = FALSE; + + result = client_write(data, STRCONST("\t"), bv.bv_val, bv.bv_len, + STRCONST(":")); + if(result) + break; + + if(!binary) { + /* check for leading or trailing whitespace */ + if(bvals[i].bv_len && + (ISBLANK(bvals[i].bv_val[0]) || + ISBLANK(bvals[i].bv_val[bvals[i].bv_len - 1]))) + binval = TRUE; + else { + /* check for unprintable characters */ + unsigned int j; + for(j = 0; j < bvals[i].bv_len; j++) + if(!ISPRINT(bvals[i].bv_val[j])) { + binval = TRUE; + break; + } + } + } + if(binary || binval) { + char *val_b64 = NULL; + size_t val_b64_sz = 0; + + /* Binary value, encode to base64. */ + if(bvals[i].bv_len) + result = curlx_base64_encode((uint8_t *)bvals[i].bv_val, + bvals[i].bv_len, + &val_b64, &val_b64_sz); + if(!result) + result = client_write(data, STRCONST(": "), val_b64, val_b64_sz, + STRCONST("\n")); + curlx_free(val_b64); + } + else + result = client_write(data, STRCONST(" "), + bvals[i].bv_val, bvals[i].bv_len, + STRCONST("\n")); + if(result) + break; + } + + ber_memfree(bvals); + bvals = NULL; + if(!result) + result = client_write(data, STRCONST("\n"), NULL, 0, NULL, 0); + if(result) + break; + } + + if(!result) + result = client_write(data, STRCONST("\n"), NULL, 0, NULL, 0); + if(!result) + result = CURLE_AGAIN; + break; + } + + ber_free(ber, 0); + ldap_msgfree(msg); + return result; +} + +void Curl_ldap_version(char *buf, size_t bufsz) +{ + LDAPAPIInfo api; + api.ldapai_info_version = LDAP_API_INFO_VERSION; + + if(ldap_get_option(NULL, LDAP_OPT_API_INFO, &api) == LDAP_OPT_SUCCESS) { + unsigned int patch = (unsigned int)(api.ldapai_vendor_version % 100); + unsigned int major = (unsigned int)(api.ldapai_vendor_version / 10000); + unsigned int minor = + (((unsigned int)api.ldapai_vendor_version - (major * 10000)) + - patch) / 100; + curl_msnprintf(buf, bufsz, "%s/%u.%u.%u", + api.ldapai_vendor_name, major, minor, patch); + ldap_memfree(api.ldapai_vendor_name); + ber_memvfree((void **)api.ldapai_extensions); + } + else + curl_msnprintf(buf, bufsz, "OpenLDAP"); +} + +/* + * LDAP protocol handler. + */ +const struct Curl_protocol Curl_protocol_ldap = { + oldap_setup_connection, /* setup_connection */ + oldap_do, /* do_it */ + oldap_done, /* done */ + ZERO_NULL, /* do_more */ + oldap_connect, /* connect_it */ + oldap_connecting, /* connecting */ + ZERO_NULL, /* doing */ + ZERO_NULL, /* proto_pollset */ + ZERO_NULL, /* doing_pollset */ + ZERO_NULL, /* domore_pollset */ + ZERO_NULL, /* perform_pollset */ + oldap_disconnect, /* disconnect */ + ZERO_NULL, /* write_resp */ + ZERO_NULL, /* write_resp_hd */ + ZERO_NULL, /* connection_is_dead */ + ZERO_NULL, /* attach connection */ + ZERO_NULL, /* follow */ +}; + +#endif /* !CURL_DISABLE_LDAP && USE_OPENLDAP */ + +/* The LDAP scheme structs are in ldap.c */ diff --git a/3rdparty/curl-8.21.0/lib/optiontable.pl b/3rdparty/curl-8.21.0/lib/optiontable.pl new file mode 100755 index 0000000000..de6fb55151 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/optiontable.pl @@ -0,0 +1,162 @@ +#!/usr/bin/env perl + +use strict; +use warnings; + +print <, et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +/* This source code is generated by optiontable.pl - DO NOT EDIT BY HAND */ + +#include "curl_setup.h" + +#include "easyoptions.h" + +/* all easy setopt options listed in alphabetical order */ +const struct curl_easyoption Curl_easyopts[] = { +HEAD + ; + +my $lastnum = 0; + +my %opt; +my %type; +my @names; +my %alias; + +sub add { + my($optstr, $typestr, $num) = @_; + my $name; + # remove all spaces from the type + $typestr =~ s/ //g; + my $ext = $typestr; + + if($optstr =~ /OBSOLETE/) { + # skip obsolete options + next; + } + + if($optstr =~ /^CURLOPT_(.*)/) { + $name = $1; + } + $ext =~ s/CURLOPTTYPE_//; + $ext =~ s/CBPOINT/CBPTR/; + $ext =~ s/POINT\z//; + $typestr = "CURLOT_$ext"; + + $opt{$name} = $optstr; + $type{$name} = $typestr; + push @names, $name; + if($num < $lastnum) { + print STDERR "ERROR: $optstr has bad number: $num < $lastnum\n"; + exit 2; + } + else { + $lastnum = $num; + } +} + +my $fl; +my $file = shift @ARGV; +open(CURL_H, '<', $file) or die; +while() { + my $l = $_; + if($fl) { + # continued deprecation + if($l =~ /(.*)\),/) { + $fl .= $1; + + # the end + my @p = split(/, */, $fl); + add($p[0], $p[1], $p[2]); + undef $fl; + } + else { + # another line to append + chomp $l; + $fl .= $l; + } + } + + if(/^ *CURLOPTDEPRECATED\((.*)/) { + $fl = $1; + chomp $fl; + } + + if(/^ *CURLOPT\(([^,]*), ([^,]*), (\d+)\)/) { + my($opt, $type, $num) = ($1, $2, $3); + add($opt, $type, $num); + } + + # alias for an older option + # old = new + if(/^#define (CURLOPT_[^ ]*) *(CURLOPT_\S*)/) { + my ($o, $n) = ($1, $2); + # skip obsolete ones + if(($n !~ /OBSOLETE/) && ($o !~ /OBSOLETE/)) { + $o =~ s/^CURLOPT_//; + $n =~ s/^CURLOPT_//; + $alias{$o} = $n; + push @names, $o; + } + } +} +close(CURL_H); + +for my $name (sort @names) { + my $oname = $name; + my $a = $alias{$name}; + my $flag = "0"; + if($a) { + $name = $alias{$name}; + $flag = "CURLOT_FLAG_ALIAS"; + } + my $o = sprintf(" { \"%s\", %s, %s, %s },\n", + $oname, $opt{$name}, $type{$name}, $flag); + if(length($o) < 80) { + print $o; + } + else { + printf(" { \"%s\", %s,\n %s, %s },\n", + $oname, $opt{$name}, $type{$name}, $flag); + } +} + +print <, et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "parsedate.h" +#include "curlx/strparse.h" +#include "curlx/strcopy.h" + +/* + A brief summary of the date string formats this parser groks: + + RFC 2616 3.3.1 + + Sun, 06 Nov 1994 08:49:37 GMT ; RFC 822, updated by RFC 1123 + Sunday, 06-Nov-94 08:49:37 GMT ; RFC 850, obsoleted by RFC 1036 + Sun Nov 6 08:49:37 1994 ; ANSI C's asctime() format + + we support dates without week day name: + + 06 Nov 1994 08:49:37 GMT + 06-Nov-94 08:49:37 GMT + Nov 6 08:49:37 1994 + + without the time zone: + + 06 Nov 1994 08:49:37 + 06-Nov-94 08:49:37 + + weird order: + + 1994 Nov 6 08:49:37 (GNU date fails) + GMT 08:49:37 06-Nov-94 Sunday + 94 6 Nov 08:49:37 (GNU date fails) + + time left out: + + 1994 Nov 6 + 06-Nov-94 + Sun Nov 6 94 + + unusual separators: + + 1994.Nov.6 + Sun/Nov/6/94/GMT + + commonly used time zone names: + + Sun, 06 Nov 1994 08:49:37 CET + 06 Nov 1994 08:49:37 EST + + time zones specified using RFC822 style: + + Sun, 12 Sep 2004 15:05:58 -0700 + Sat, 11 Sep 2004 21:32:11 +0200 + + compact numerical date strings: + + 20040912 15:05:58 -0700 + 20040911 +0200 + +*/ + +#if !defined(CURL_DISABLE_PARSEDATE) || !defined(CURL_DISABLE_FTP) || \ + !defined(CURL_DISABLE_FILE) || defined(USE_GNUTLS) +/* These names are also used by FTP and FILE code */ +const char * const Curl_wkday[] = { + "Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun" +}; +const char * const Curl_month[] = { + "Jan", "Feb", "Mar", "Apr", "May", "Jun", + "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" +}; +#endif + +#define PARSEDATE_OK 0 +#define PARSEDATE_FAIL (-1) + +#ifndef CURL_DISABLE_PARSEDATE + +#if SIZEOF_TIME_T < 5 +#define PARSEDATE_LATER 1 +#endif +#if SIZEOF_TIME_T < 5 || defined(HAVE_TIME_T_UNSIGNED) +#define PARSEDATE_SOONER 2 +#endif + +static const char * const weekday[] = { + "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday" +}; + +struct tzinfo { + char name[5]; + int16_t offset; /* +/- in minutes */ +}; + +#define tDAYZONE (-60) /* offset for daylight savings time */ + +/* alpha-sorted list of time zones */ +static const struct tzinfo tz[] = { + { "A", -1 * 60 }, /* Alpha */ + { "ADT", 240 + tDAYZONE }, /* Atlantic Daylight */ + { "AHST", 600 }, /* Alaska-Hawaii Standard */ + { "AST", 240 }, /* Atlantic Standard */ + { "B", -2 * 60 }, /* Bravo */ + { "BST", 0 + tDAYZONE }, /* British Summer */ + { "C", -3 * 60 }, /* Charlie */ + { "CAT", 600 }, /* Central Alaska */ + { "CCT", -480 }, /* China Coast, USSR Zone 7 */ + { "CDT", 360 + tDAYZONE }, /* Central Daylight */ + { "CEST", -60 + tDAYZONE }, /* Central European Summer */ + { "CET", -60 }, /* Central European */ + { "CST", 360 }, /* Central Standard */ + { "D", -4 * 60 }, /* Delta */ + { "E", -5 * 60 }, /* Echo */ + { "EADT", -600 + tDAYZONE }, /* Eastern Australian Daylight */ + { "EAST", -600 }, /* Eastern Australian Standard */ + { "EDT", 300 + tDAYZONE }, /* Eastern Daylight */ + { "EET", -120 }, /* Eastern Europe, USSR Zone 1 */ + { "EST", 300 }, /* Eastern Standard */ + { "F", -6 * 60 }, /* Foxtrot */ + { "FST", -60 + tDAYZONE }, /* French Summer */ + { "FWT", -60 }, /* French Winter */ + { "G", -7 * 60 }, /* Golf */ + { "GMT", 0 }, /* Greenwich Mean */ + { "GST", -600 }, /* Guam Standard, USSR Zone 9 */ + { "H", -8 * 60 }, /* Hotel */ + { "HDT", 600 + tDAYZONE }, /* Hawaii Daylight */ + { "HST", 600 }, /* Hawaii Standard */ + { "I", -9 * 60 }, /* India */ + { "IDLE", -720 }, /* International Date Line East */ + { "IDLW", 720 }, /* International Date Line West */ + { "JST", -540 }, /* Japan Standard, USSR Zone 8 */ + { "K", -10 * 60 }, /* Kilo */ + { "L", -11 * 60 }, /* Lima */ + { "M", -12 * 60 }, /* Mike */ + { "MDT", 420 + tDAYZONE }, /* Mountain Daylight */ + { "MEST", -60 + tDAYZONE }, /* Middle European Summer */ + { "MESZ", -60 + tDAYZONE }, /* Middle European Summer */ + { "MET", -60 }, /* Middle European */ + { "MEWT", -60 }, /* Middle European Winter */ + { "MST", 420 }, /* Mountain Standard */ + { "N", 60 }, /* November */ + { "NT", 660 }, /* Nome */ /* spellchecker:disable-line */ + { "NZDT", -720 + tDAYZONE }, /* New Zealand Daylight */ + { "NZST", -720 }, /* New Zealand Standard */ + { "NZT", -720 }, /* New Zealand */ + { "O", 2 * 60 }, /* Oscar */ + { "P", 3 * 60 }, /* Papa */ + { "PDT", 480 + tDAYZONE }, /* Pacific Daylight */ + { "PST", 480 }, /* Pacific Standard */ + { "Q", 4 * 60 }, /* Quebec */ + { "R", 5 * 60 }, /* Romeo */ + { "S", 6 * 60 }, /* Sierra */ + { "T", 7 * 60 }, /* Tango */ + { "U", 8 * 60 }, /* Uniform */ + { "UT", 0 }, /* Universal Time */ + { "UTC", 0 }, /* Universal (Coordinated) */ + { "V", 9 * 60 }, /* Victor */ + { "W", 10 * 60 }, /* Whiskey */ + { "WADT", -420 + tDAYZONE }, /* West Australian Daylight */ + { "WAST", -420 }, /* spellchecker:disable-line */ + /* West Australian Standard */ + { "WAT", 60 }, /* West Africa */ + { "WET", 0 }, /* Western European */ + { "X", 11 * 60 }, /* X-ray */ + { "Y", 12 * 60 }, /* Yankee */ + { "YDT", 540 + tDAYZONE }, /* Yukon Daylight */ + { "YST", 540 }, /* Yukon Standard */ + { "Z", 0 }, /* Zulu, zero meridian, a.k.a. UTC */ +}; + +/* returns: + -1 no day + 0 monday - 6 sunday +*/ + +static int checkday(const char *check, size_t len) +{ + int i; + const char * const *what; + if(len > 3) + what = &weekday[0]; + else if(len == 3) + what = &Curl_wkday[0]; + else + return -1; /* too short */ + for(i = 0; i < 7; i++) { + size_t ilen = strlen(what[0]); + if((ilen == len) && + curl_strnequal(check, what[0], len)) + return i; + what++; + } + return -1; +} + +static int checkmonth(const char *check, size_t len) +{ + int i; + const char * const *what = &Curl_month[0]; + if(len != 3) + return -1; /* not a month */ + + for(i = 0; i < 12; i++) { + if(curl_strnequal(check, what[0], 3)) + return i; + what++; + } + return -1; /* return the offset or -1, no real offset is -1 */ +} + +static int tzcompare(const void *m1, const void *m2) +{ + const struct tzinfo *tz1 = m1; + const struct tzinfo *tz2 = m2; + return strcmp(tz1->name, tz2->name); +} + +/* return the time zone offset between GMT and the input one, in number of + seconds or -1 if the timezone was not found/legal */ +static int checktz(const char *check, size_t len) +{ + if(len <= 4) { + const struct tzinfo *what; + struct tzinfo find; + curlx_strcopy(find.name, sizeof(find.name), check, len); + what = bsearch(&find, tz, CURL_ARRAYSIZE(tz), sizeof(tz[0]), tzcompare); + if(what) + return what->offset * 60; + } + return -1; +} + +static void skip(const char **date) +{ + /* skip everything that are not letters or digits */ + while(**date && !ISALNUM(**date)) + (*date)++; +} + +/* each field is exactly -1 when unknown */ +struct when { + int wday; /* day of the week, 0-6 (mon-sun) */ + int mon; /* month of the year, 0-11 */ + int mday; /* day of month, 1 - 31 */ + int hour; /* hour of day, 0 - 23 */ + int min; /* minute of hour, 0 - 59 */ + int sec; /* second of minute, 0 - 60 (leap second) */ + int year; /* year, >= 1583 */ + int tzoff; /* time zone offset in seconds */ +}; + +enum assume { + DATE_MDAY, + DATE_YEAR, + DATE_TIME +}; + +/* (1969 / 4) - (1969 / 100) + (1969 / 400) = 492 - 19 + 4 = 477 */ +#define LEAP_DAYS_BEFORE_1969 477 + +/* + * time2epoch: time stamp to seconds since epoch in GMT time zone. Similar to + * mktime but for GMT only. + */ +static curl_off_t time2epoch(struct when *w) +{ + static const int cumulative_days[12] = { + 0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334 + }; + int y = w->year - (w->mon <= 1); + int leap_days = (y / 4) - (y / 100) + (y / 400) - LEAP_DAYS_BEFORE_1969; + curl_off_t days = (curl_off_t)(w->year - 1970) * 365 + leap_days + + cumulative_days[w->mon] + w->mday - 1; + + return (((days * 24 + w->hour) * 60 + w->min) * 60) + w->sec; +} + +/* Returns the value of a single-digit or two-digit decimal number, return + then pointer to after the number. The 'date' pointer is known to point to a + digit. */ +static int oneortwodigit(const char *date, const char **endp) +{ + int num = date[0] - '0'; + if(ISDIGIT(date[1])) { + *endp = &date[2]; + return (num * 10) + (date[1] - '0'); + } + *endp = &date[1]; + return num; +} + +/* HH:MM:SS or HH:MM and accept single-digits too */ +static bool match_time(const char *date, struct when *w, char **endp) +{ + const char *p; + int hh, mm, ss = 0; + hh = oneortwodigit(date, &p); + if((hh < 24) && (*p == ':') && ISDIGIT(p[1])) { + mm = oneortwodigit(&p[1], &p); + if(mm < 60) { + if((*p == ':') && ISDIGIT(p[1])) { + ss = oneortwodigit(&p[1], &p); + if(ss <= 60) { + /* valid HH:MM:SS */ + goto match; + } + } + else { + /* valid HH:MM */ + goto match; + } + } + } + return FALSE; /* not a time string */ +match: + w->hour = hh; + w->min = mm; + w->sec = ss; + *endp = (char *)CURL_UNCONST(p); + return TRUE; +} + +/* + * parsedate() + * + * Returns: + * + * PARSEDATE_OK - a fine conversion + * PARSEDATE_FAIL - failed to convert + * PARSEDATE_LATER - time overflow at the far end of time_t + * PARSEDATE_SOONER - time underflow at the low end of time_t + */ + +/* Wednesday is the longest name this parser knows about */ +#define NAME_LEN 12 + +static void initwhen(struct when *w) +{ + w->wday = w->mon = w->mday = w->hour = w->min = w->sec = w->year = w->tzoff = + -1; +} + +static int datestring(const char **datep, struct when *w) +{ + /* a name coming up */ + size_t len = 0; + const char *p = *datep; + bool found = FALSE; + while(ISALPHA(*p) && (len < NAME_LEN)) { + p++; + len++; + } + + if(len != NAME_LEN) { + if(w->wday == -1) { + w->wday = checkday(*datep, len); + if(w->wday != -1) + found = TRUE; + } + if(!found && (w->mon == -1)) { + w->mon = checkmonth(*datep, len); + if(w->mon != -1) + found = TRUE; + } + + if(!found && (w->tzoff == -1)) { + /* this must be a time zone string */ + w->tzoff = checktz(*datep, len); + if(w->tzoff != -1) + found = TRUE; + } + } + if(!found) + return PARSEDATE_FAIL; /* bad string */ + + *datep += len; + return PARSEDATE_OK; +} + +static int datenum(const char *indate, const char **datep, struct when *w, + enum assume *dignextp) +{ + /* a digit */ + unsigned int val; + char *end; + const char *date = *datep; + enum assume dignext = *dignextp; + + if((w->sec == -1) && match_time(date, w, &end)) { + /* time stamp */ + date = end; + } + else { + bool found = FALSE; + curl_off_t lval; + int num_digits = 0; + const char *p = *datep; + if(curlx_str_number(&p, &lval, 99999999)) + return PARSEDATE_FAIL; + + /* we know num_digits cannot be larger than 8 */ + num_digits = (int)(p - *datep); + val = (unsigned int)lval; + + if((w->tzoff == -1) && + (num_digits == 4) && + (val <= 1400) && + (indate < date) && + (date[-1] == '+' || date[-1] == '-')) { + /* four digits and a value less than or equal to 1400 (to take into + account all sorts of funny time zone diffs) and it is preceded + with a plus or minus. This is a time zone indication. 1400 is + picked since +1300 is frequently used and +1400 is mentioned as + an edge number in the document "ISO C 200X Proposal: Timezone + Functions" at http://david.tribble.com/text/c0xtimezone.html If + anyone has a more authoritative source for the exact maximum time + zone offsets, please speak up! */ + found = TRUE; + w->tzoff = ((val / 100 * 60) + (val % 100)) * 60; + + /* the + and - prefix indicates the local time compared to GMT, + this we need their reversed math to get what we want */ + w->tzoff = date[-1] == '+' ? -w->tzoff : w->tzoff; + } + + else if((num_digits == 8) && (w->year == -1) && + (w->mon == -1) && (w->mday == -1)) { + /* 8 digits, no year, month or day yet. This is YYYYMMDD */ + found = TRUE; + w->year = val / 10000; + w->mon = ((val % 10000) / 100) - 1; /* month is 0 - 11 */ + w->mday = val % 100; + } + + if(!found && (dignext == DATE_MDAY) && (w->mday == -1)) { + if((val > 0) && (val < 32)) { + w->mday = val; + found = TRUE; + } + dignext = DATE_YEAR; + } + + if(!found && (dignext == DATE_YEAR) && (w->year == -1)) { + w->year = val; + found = TRUE; + if(w->year < 100) { + if(w->year > 70) + w->year += 1900; + else + w->year += 2000; + } + if(w->mday == -1) + dignext = DATE_MDAY; + } + + if(!found) + return PARSEDATE_FAIL; + + date = p; + } + *datep = date; + *dignextp = dignext; + return PARSEDATE_OK; +} + +static int datecheck(struct when *w) +{ + if(w->sec == -1) + w->sec = w->min = w->hour = 0; /* no time, make it zero */ + + if((w->mday == -1) || (w->mon == -1) || (w->year == -1)) + /* lacks vital info, fail */ + return PARSEDATE_FAIL; + + /* The Gregorian calendar was introduced 1582 */ + else if(w->year < 1583) + return PARSEDATE_FAIL; + + else if((w->mday > 31) || (w->mon > 11) || (w->hour > 23) || + (w->min > 59) || (w->sec > 60)) + return PARSEDATE_FAIL; /* clearly an illegal date */ + + return PARSEDATE_OK; +} + +static void tzadjust(curl_off_t *tp, struct when *w) +{ + if(w->tzoff == -1) /* unknown tz means no offset */ + w->tzoff = 0; + + /* Add the time zone diff between local time zone and GMT. */ + if((w->tzoff > 0) && (*tp > (curl_off_t)(CURL_OFF_T_MAX - w->tzoff))) + *tp = CURL_OFF_T_MAX; + else + *tp += w->tzoff; + /* this needs no minimum check since we require a year > 1582 */ +} + +static int mktimet(curl_off_t seconds, time_t *output) +{ +#if SIZEOF_TIME_T < 5 + if(seconds > TIME_T_MAX) { + *output = TIME_T_MAX; + return PARSEDATE_LATER; + } + else if(seconds < TIME_T_MIN) { + *output = TIME_T_MIN; + return PARSEDATE_SOONER; + } +#elif defined(HAVE_TIME_T_UNSIGNED) + if(seconds < 0) { + *output = 0; + return PARSEDATE_SOONER; + } +#endif + *output = (time_t)seconds; + return PARSEDATE_OK; +} + +static int parsedate(const char *date, time_t *output) +{ + curl_off_t seconds = 0; + enum assume dignext = DATE_MDAY; + const char *indate = date; /* save the original pointer */ + int part = 0; /* max 6 parts */ + int rc = 0; + struct when w; + initwhen(&w); + + while(*date && (part < 6)) { + skip(&date); + + if(ISALPHA(*date)) + rc = datestring(&date, &w); + else if(ISDIGIT(*date)) + rc = datenum(indate, &date, &w, &dignext); + if(rc) + return rc; + + part++; + } + + rc = datecheck(&w); + if(rc) + return rc; + + seconds = time2epoch(&w); /* get number of seconds */ + tzadjust(&seconds, &w); /* handle the time zone offset */ + rc = mktimet(seconds, output); /* squeeze seconds into a time_t */ + + return rc; +} +#else +/* disabled */ +static int parsedate(const char *date, time_t *output) +{ + (void)date; + *output = 0; + return PARSEDATE_OK; /* a lie */ +} +#endif + +time_t curl_getdate(const char *p, const time_t *unused) +{ + time_t parsed = -1; + int rc = parsedate(p, &parsed); + (void)unused; /* legacy argument from the past that we ignore */ + + if(rc == PARSEDATE_OK) { + if(parsed == (time_t)-1) + /* avoid returning -1 for a working scenario */ + parsed++; + return parsed; + } + /* everything else is fail */ + return -1; +} + +/* Curl_getdate_capped() differs from curl_getdate() in that this will return + TIME_T_MAX in case the parsed time value was too big, instead of an + error. Returns non-zero on error. */ + +int Curl_getdate_capped(const char *p, time_t *tp) +{ + int rc = parsedate(p, tp); + return (rc == PARSEDATE_FAIL); +} diff --git a/3rdparty/curl-8.21.0/lib/parsedate.h b/3rdparty/curl-8.21.0/lib/parsedate.h new file mode 100644 index 0000000000..ea136bd301 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/parsedate.h @@ -0,0 +1,35 @@ +#ifndef HEADER_CURL_PARSEDATE_H +#define HEADER_CURL_PARSEDATE_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +extern const char * const Curl_wkday[7]; +extern const char * const Curl_month[12]; + +/* Curl_getdate_capped() differs from curl_getdate() in that this returns + TIME_T_MAX in case the parsed time value was too big, instead of an + error. */ + +int Curl_getdate_capped(const char *p, time_t *tp); + +#endif /* HEADER_CURL_PARSEDATE_H */ diff --git a/3rdparty/curl-8.21.0/lib/peer.c b/3rdparty/curl-8.21.0/lib/peer.c new file mode 100644 index 0000000000..44bcb52f23 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/peer.c @@ -0,0 +1,740 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +/* + * IDN conversions + */ +#include "curl_setup.h" + +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETDB_H +#include +#endif +#ifdef HAVE_ARPA_INET_H +#include +#endif +#ifdef HAVE_NET_IF_H +#include +#endif +#ifdef HAVE_IPHLPAPI_H +#include +#endif +#ifdef HAVE_SYS_IOCTL_H +#include +#endif +#ifdef HAVE_SYS_PARAM_H +#include +#endif + +#ifdef __VMS +#include +#include +#endif + +#ifdef HAVE_SYS_UN_H +#include +#endif + +#if defined(HAVE_IF_NAMETOINDEX) && defined(USE_WINSOCK) +#if defined(__MINGW32__) && (__MINGW64_VERSION_MAJOR <= 5) +#include /* workaround for old mingw-w64 missing to include it */ +#endif +#include +#endif + +#include "curl_addrinfo.h" +#include "curl_trc.h" +#include "protocol.h" +#include "http_proxy.h" +#include "idn.h" +#include "curlx/strdup.h" +#include "curlx/strparse.h" +#include "peer.h" +#include "urldata.h" +#include "url.h" +#include "vtls/vtls.h" + +struct peer_parse { + const struct Curl_scheme *scheme; + struct Curl_str host_user; + struct Curl_str host; + struct Curl_str zoneid; + char *tmp_host_user; + char *tmp_host; + char *tmp_zoneid; + uint32_t scopeid; + uint16_t port; + bool ipv6; + bool unix_socket; + bool abstract_uds; +}; + +static void peer_parse_clear(struct peer_parse *pp) +{ + curlx_free(pp->tmp_host_user); + curlx_free(pp->tmp_host); + curlx_free(pp->tmp_zoneid); + memset(pp, 0, sizeof(*pp)); +} + +static CURLcode peer_create(struct peer_parse *pp, + struct Curl_peer **ppeer) +{ + struct Curl_peer *peer = NULL; + CURLcode result = CURLE_OK; + size_t zone_alen = 0, host_alen = 0; + + if(!pp || !pp->scheme) + return CURLE_FAILED_INIT; + if(!pp->host.len && !(pp->scheme->flags & PROTOPT_NONETWORK)) + return CURLE_FAILED_INIT; + + if((pp->host.str != pp->host_user.str) || + (pp->host.len != pp->host_user.len)) { + host_alen = pp->host.len + 1; + } + zone_alen = pp->zoneid.len ? (pp->zoneid.len + 1) : 0; + + /* null-terminator already part of struct */ + peer = curlx_calloc(1, sizeof(*peer) + + pp->host_user.len + host_alen + zone_alen); + if(!peer) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + peer->refcount = 1; + peer->scheme = pp->scheme; + peer->hostname = peer->user_hostname; + peer->port = pp->port; + peer->scopeid = pp->scopeid; + peer->ipv6 = pp->ipv6; + peer->unix_socket = pp->unix_socket; + peer->abstract_uds = pp->abstract_uds; + + if(pp->host_user.len) + memcpy(peer->user_hostname, pp->host_user.str, pp->host_user.len); + + if(host_alen) { + peer->hostname = peer->user_hostname + pp->host_user.len + 1; + memcpy(peer->hostname, pp->host.str, pp->host.len); + } + + if(zone_alen) { + peer->zoneid = peer->user_hostname + pp->host_user.len + 1 + host_alen; + memcpy(peer->zoneid, pp->zoneid.str, pp->zoneid.len); +#ifdef USE_IPV6 + /* Determine scope_id if not already provided */ + if(!peer->scopeid) { + const char *p = peer->zoneid; + curl_off_t scope; + if(!curlx_str_number(&p, &scope, UINT_MAX)) { + /* A plain number, use it directly as a scope id. */ + peer->scopeid = (uint32_t)scope; + } +#ifdef HAVE_IF_NAMETOINDEX + else { + /* Zone identifier is not numeric */ + unsigned int idx = 0; + idx = if_nametoindex(peer->zoneid); + if(idx) { + peer->scopeid = (uint32_t)idx; + } + else { + /* Do we want to return an error here? */ + } + } +#endif /* HAVE_IF_NAMETOINDEX */ + } +#endif /* USE_IPV6 */ + } + +out: + if(!result) + *ppeer = peer; + else + Curl_peer_unlink(&peer); + return result; +} + +static CURLcode peer_parse_host(struct Curl_easy *data, + struct peer_parse *pp, + bool scan_for_ipv6) +{ + if(!pp || !pp->host_user.str || !pp->host_user.len) + return CURLE_FAILED_INIT; + + if(pp->host_user.str[0] == '[') { + const char *s = pp->host_user.str + 1; + struct Curl_str tmp; + if(curlx_str_until(&s, &tmp, pp->host_user.len - 1, ']')) + return CURLE_URL_MALFORMAT; + + if(!Curl_looks_like_ipv6(tmp.str, tmp.len, TRUE, + &pp->host, &pp->zoneid)) { + failf(data, "Invalid IPv6 address format in '%.*s'", + (int)pp->host_user.len, pp->host_user.str); + return CURLE_URL_MALFORMAT; + } + pp->ipv6 = TRUE; + } + else { +#ifdef USE_IDN + if(!Curl_is_ASCII_str(&pp->host_user)) { + CURLcode result; + if(!pp->tmp_host_user) { + /* need a null-terminated string for IDN */ + pp->tmp_host_user = curlx_memdup0(pp->host_user.str, + pp->host_user.len); + if(!pp->tmp_host_user) + return CURLE_OUT_OF_MEMORY; + } + result = Curl_idn_decode(pp->tmp_host_user, &pp->tmp_host); + if(result) + return result; + pp->host.str = pp->tmp_host; + pp->host.len = strlen(pp->host.str); + } + else +#endif + if(scan_for_ipv6 && + Curl_looks_like_ipv6(pp->host_user.str, pp->host_user.len, TRUE, + &pp->host, &pp->zoneid)) { + if(pp->host_user.len < MAX_IPADR_LEN) { + char tmp[MAX_IPADR_LEN]; + memcpy(tmp, pp->host_user.str, pp->host_user.len); + tmp[pp->host_user.len] = 0; + pp->ipv6 = !Curl_is_ipv4addr(tmp); + } + else + pp->ipv6 = TRUE; + } + else + pp->host = pp->host_user; + } + return CURLE_OK; +} + +CURLcode Curl_peer_create(struct Curl_easy *data, + const struct Curl_scheme *scheme, + const char *hostname, + uint16_t port, + struct Curl_peer **ppeer) +{ + struct peer_parse pp; + CURLcode result; + + Curl_peer_unlink(ppeer); + memset(&pp, 0, sizeof(pp)); + pp.scheme = scheme; + pp.host_user.str = hostname; + pp.host_user.len = strlen(hostname); + pp.port = port; + + result = peer_parse_host(data, &pp, TRUE); + if(!result) + result = peer_create(&pp, ppeer); + + peer_parse_clear(&pp); + return result; +} + +#ifdef USE_UNIX_SOCKETS +CURLcode Curl_peer_uds_create(const struct Curl_scheme *scheme, + const char *path, + bool abstract_unix_socket, + struct Curl_peer **ppeer) +{ + struct peer_parse pp; + size_t pathlen = path ? strlen(path) : 0; + CURLcode result = CURLE_OK; + + Curl_peer_unlink(ppeer); + memset(&pp, 0, sizeof(pp)); + if(!scheme) + return CURLE_FAILED_INIT; + if(!pathlen) + return CURLE_FAILED_INIT; + + pp.scheme = scheme; + pp.host_user.str = pp.host.str = path; + pp.host_user.len = pp.host.len = pathlen; + pp.unix_socket = TRUE; + pp.abstract_uds = abstract_unix_socket; + + result = peer_create(&pp, ppeer); + peer_parse_clear(&pp); + return result; +} +#endif /* USE_UNIX_SOCKETS */ + +void Curl_peer_link(struct Curl_peer **pdest, struct Curl_peer *src) +{ + if(*pdest != src) { + Curl_peer_unlink(pdest); + *pdest = src; + if(src) { + DEBUGASSERT(src->refcount < UINT32_MAX); + src->refcount++; + } + } +} + +void Curl_peer_unlink(struct Curl_peer **ppeer) +{ + if(*ppeer) { + struct Curl_peer *peer = *ppeer; + + DEBUGASSERT(peer->refcount); + *ppeer = NULL; + if(peer->refcount) + peer->refcount--; + if(!peer->refcount) { + curlx_free(peer); + } + } +} + +bool Curl_peer_equal(struct Curl_peer *p1, struct Curl_peer *p2) +{ + return (p1 == p2) || + (p1 && p2 && + (p1->scheme == p2->scheme) && + Curl_peer_same_destination(p1, p2)); +} + +static bool peer_same_hostname(struct Curl_peer *p1, struct Curl_peer *p2) +{ + /* UNIX domain socket paths must be compared case-sensitive, + * as many filesystem are like that. */ + return (p1->unix_socket == p2->unix_socket) && + (p1->abstract_uds == p2->abstract_uds) && + (p1->ipv6 == p2->ipv6) && + (p1->unix_socket ? + !strcmp(p1->hostname, p2->hostname) : + curl_strequal(p1->hostname, p2->hostname)); +} + +bool Curl_peer_same_destination(struct Curl_peer *p1, struct Curl_peer *p2) +{ + return (p1 == p2) || + (p1 && p2 && + (p1->port == p2->port) && + peer_same_hostname(p1, p2) && + (p1->scopeid == p2->scopeid) && + (p1->scopeid || curl_strequal(p1->zoneid, p2->zoneid))); +} + +CURLcode Curl_peer_from_url(CURLU *uh, struct Curl_easy *data, + uint16_t port_override, + uint32_t scopeid_override, + struct urlpieces *up, + struct Curl_peer **ppeer) +{ + struct peer_parse pp; + char *zoneid = NULL; + CURLUcode uc; + CURLcode result; + + Curl_peer_unlink(ppeer); + memset(&pp, 0, sizeof(pp)); + + curlx_safefree(up->scheme); + uc = curl_url_get(uh, CURLUPART_SCHEME, &up->scheme, 0); + if(uc) + return Curl_uc_to_curlcode(uc); + pp.scheme = Curl_get_scheme(up->scheme); + if(!pp.scheme) { + failf(data, "Protocol \"%s\" not supported%s", up->scheme, + data->state.this_is_a_follow ? " (in redirect)" : ""); + result = CURLE_UNSUPPORTED_PROTOCOL; + goto out; + } + + curlx_safefree(up->hostname); + uc = curl_url_get(uh, CURLUPART_HOST, &up->hostname, 0); + if(uc) { + if((uc == CURLUE_NO_HOST) && (pp.scheme->flags & PROTOPT_NONETWORK)) + ; /* acceptable */ + else { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + } + else if(strlen(up->hostname) > MAX_URL_LEN) { + failf(data, "Too long hostname (maximum is %d)", MAX_URL_LEN); + result = CURLE_URL_MALFORMAT; + goto out; + } + + pp.host_user.str = up->hostname ? up->hostname : ""; + pp.host_user.len = strlen(pp.host_user.str); + if(pp.host_user.len) { + result = peer_parse_host(data, &pp, FALSE); + if(result) + goto out; + } + else + pp.host = pp.host_user; + + curlx_safefree(up->port); + if(port_override) { + /* if set, we use this instead of the port possibly given in the URL */ + char portbuf[16]; + curl_msnprintf(portbuf, sizeof(portbuf), "%d", port_override); + uc = curl_url_set(uh, CURLUPART_PORT, portbuf, 0); + if(uc) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + else + pp.port = port_override; + } + else { + uc = curl_url_get(uh, CURLUPART_PORT, &up->port, CURLU_DEFAULT_PORT); + if(uc) { + if(uc == CURLUE_OUT_OF_MEMORY) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + else if(!(pp.scheme->flags & PROTOPT_NONETWORK)) { + result = CURLE_URL_MALFORMAT; + goto out; + } + /* no port ok when not a network scheme */ + } + else { + const char *p = up->port; + curl_off_t offt; + if(curlx_str_number(&p, &offt, 0xffff)) + return CURLE_URL_MALFORMAT; + pp.port = (uint16_t)offt; + } + } + + if(scopeid_override) + /* Override any scope id from an URL zone. */ + pp.scopeid = scopeid_override; + else { + if(curl_url_get(uh, CURLUPART_ZONEID, &zoneid, 0) == + CURLUE_OUT_OF_MEMORY) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + if(zoneid) { + pp.zoneid.str = zoneid; + pp.zoneid.len = strlen(zoneid); + } + } + + result = peer_create(&pp, ppeer); + if(result) + failf(data, "Error %d creating peer for %s:%u", + (int)result, pp.host_user.str, pp.port); + +out: + peer_parse_clear(&pp); + curlx_free(zoneid); + return result; +} + +/* Parse a "host:port" string to connect to into a peer. + * IPv6 addresses might appear in brackets or without them. */ +CURLcode Curl_peer_from_connect_to(struct Curl_easy *data, + const struct Curl_peer *dest, + const char *connect_to, + struct Curl_peer **ppeer) +{ + struct peer_parse pp; + const char *portstr = NULL; + CURLcode result; + + Curl_peer_unlink(ppeer); + memset(&pp, 0, sizeof(pp)); + if(!connect_to || !*connect_to) + return CURLE_FAILED_INIT; + + pp.scheme = dest->scheme; + + /* detect and extract RFC6874-style IPv6-addresses */ + if(connect_to[0] == '[') { + const char *s = strchr(connect_to + 1, ']'); + if(!s) { + failf(data, "Invalid IPv6 address format in '%s'", connect_to); + result = CURLE_SETOPT_OPTION_SYNTAX; + goto out; + } + portstr = strchr(s, ':'); + pp.host_user.str = connect_to; + pp.host_user.len = s - pp.host_user.str + 1; + pp.ipv6 = TRUE; + } + else { + portstr = strchr(connect_to, ':'); + pp.host_user.str = connect_to; + pp.host_user.len = portstr ? + (size_t)(portstr - connect_to) : strlen(connect_to); + } + + if(!pp.host_user.len) { /* no hostname found, only port switch */ + pp.host_user.str = dest->user_hostname; + pp.host_user.len = strlen(dest->user_hostname); + } + + result = peer_parse_host(data, &pp, FALSE); + if(result) + goto out; + + if(portstr && portstr[1]) { + const char *p = portstr + 1; + curl_off_t portparse; + if(curlx_str_number(&p, &portparse, 0xffff)) { + failf(data, "No valid port number in '%s'", connect_to); + result = CURLE_SETOPT_OPTION_SYNTAX; + goto out; + } + pp.port = (uint16_t)portparse; /* we know it will fit */ + } + else + pp.port = dest->port; + +#ifndef USE_IPV6 + if(pp.ipv6) { + failf(data, "Use of IPv6 in *_CONNECT_TO without IPv6 support built-in"); + result = CURLE_NOT_BUILT_IN; + goto out; + } +#endif + + result = peer_create(&pp, ppeer); + CURL_TRC_M(data, "connect-to peer_create2 -> %d", (int)result); + +out: + CURL_TRC_M(data, "parse connect_to peer: %s -> %d", connect_to, (int)result); + peer_parse_clear(&pp); + return result; +} + +#ifndef CURL_DISABLE_PROXY + +#ifdef USE_UNIX_SOCKETS +#define UNIX_SOCKET_PREFIX "localhost" +#endif + +CURLcode Curl_scheme_to_proxytype(struct Curl_easy *data, + const char *scheme, + uint8_t *proxytype, const char *url) +{ + if(!scheme) + return CURLE_OK; + + if(curl_strequal("https", scheme)) { + if(*proxytype != CURLPROXY_HTTPS2 && *proxytype != CURLPROXY_HTTPS3) + *proxytype = CURLPROXY_HTTPS; + } + else if(curl_strequal("socks5h", scheme)) + *proxytype = CURLPROXY_SOCKS5_HOSTNAME; + else if(curl_strequal("socks5", scheme)) + *proxytype = CURLPROXY_SOCKS5; + else if(curl_strequal("socks4a", scheme)) + *proxytype = CURLPROXY_SOCKS4A; + else if(curl_strequal("socks4", scheme) || curl_strequal("socks", scheme)) + *proxytype = CURLPROXY_SOCKS4; + else if(curl_strequal("http", scheme)) { + if(*proxytype != CURLPROXY_HTTP_1_0) + *proxytype = CURLPROXY_HTTP; + } + else { + /* Any other xxx:// reject! */ + failf(data, "Unsupported proxy scheme for \'%s\'", url); + return CURLE_COULDNT_CONNECT; + } + return CURLE_OK; +} + +CURLcode Curl_peer_from_proxy_url(CURLU *uh, + struct Curl_easy *data, + const char *url, + uint8_t proxytype, + struct Curl_peer **ppeer, + uint8_t *pproxytype) +{ + struct peer_parse pp; + char *scheme = NULL; + char *portptr = NULL; +#ifdef USE_UNIX_SOCKETS + bool is_socks = FALSE; +#endif + CURLUcode uc; + CURLcode result = CURLE_OK; + + Curl_peer_unlink(ppeer); + memset(&pp, 0, sizeof(pp)); + pp.port = CURL_DEFAULT_PROXY_PORT; + uc = curl_url_get(uh, CURLUPART_SCHEME, &scheme, + CURLU_NON_SUPPORT_SCHEME | CURLU_NO_GUESS_SCHEME); + if(uc) { + if(uc == CURLUE_OUT_OF_MEMORY) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + /* URL came without scheme, the passed `proxytype` determines it */ + switch(proxytype) { + case CURLPROXY_HTTP: + case CURLPROXY_HTTP_1_0: + pp.scheme = &Curl_scheme_http; + break; + case CURLPROXY_HTTPS: + case CURLPROXY_HTTPS2: + case CURLPROXY_HTTPS3: + pp.scheme = &Curl_scheme_https; + break; + case CURLPROXY_SOCKS4: + pp.scheme = &Curl_scheme_socks4; + break; + case CURLPROXY_SOCKS4A: + pp.scheme = &Curl_scheme_socks4a; + break; + case CURLPROXY_SOCKS5: + pp.scheme = &Curl_scheme_socks5; + break; + case CURLPROXY_SOCKS5_HOSTNAME: + pp.scheme = &Curl_scheme_socks5h; + break; + default: + failf(data, "Unsupported proxy type %u for \'%s\'", proxytype, url); + result = CURLE_COULDNT_RESOLVE_PROXY; + goto out; + } + } + else { + pp.scheme = Curl_get_scheme(scheme); + result = Curl_scheme_to_proxytype(data, scheme, &proxytype, url); + if(result) + goto out; + } + DEBUGASSERT(pp.scheme); + + if(CURL_PROXY_IS_HTTPS(proxytype) && + !Curl_ssl_supports(data, SSLSUPP_HTTPS_PROXY)) { + failf(data, "Unsupported proxy \'%s\', libcurl is built without the " + "HTTPS-proxy support.", url); + result = CURLE_NOT_BUILT_IN; + goto out; + } + + switch(pp.scheme->family) { + case CURLPROTO_SOCKS: +#ifdef USE_UNIX_SOCKETS + is_socks = TRUE; +#endif + break; + case CURLPROTO_HTTP: + break; + default: + failf(data, "Unsupported proxy protocol for \'%s\'", url); + result = CURLE_COULDNT_CONNECT; + goto out; + } + + uc = curl_url_get(uh, CURLUPART_PORT, &portptr, CURLU_NO_DEFAULT_PORT); + if(uc == CURLUE_OUT_OF_MEMORY) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + if(portptr) { + curl_off_t num; + const char *p = portptr; + if(!curlx_str_number(&p, &num, UINT16_MAX)) + pp.port = (uint16_t)num; + /* Should we not error out when the port number is invalid? */ + curlx_free(portptr); + } + else { + /* No port in URL, take the set one or the scheme's default */ + if(data->set.proxyport) + pp.port = data->set.proxyport; + else + pp.port = pp.scheme->defport; + } + + /* now, clone the proxy hostname */ + uc = curl_url_get(uh, CURLUPART_HOST, &pp.tmp_host_user, CURLU_URLDECODE); + if(uc) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + pp.host_user.str = pp.tmp_host_user; + pp.host_user.len = strlen(pp.tmp_host_user); + +#ifdef USE_UNIX_SOCKETS + if(is_socks && curl_strequal(UNIX_SOCKET_PREFIX, pp.tmp_host_user)) { + uc = curl_url_get(uh, CURLUPART_PATH, &pp.tmp_host, CURLU_URLDECODE); + if(uc) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + /* path will be "/", if no path was found */ + if(strcmp("/", pp.tmp_host)) { + pp.host.str = pp.tmp_host; + pp.host.len = strlen(pp.tmp_host); + pp.unix_socket = TRUE; + } + else { + pp.host = pp.host_user; + } + } +#endif /* USE_UNIX_SOCKETS */ + + if(!pp.host.len) { + result = peer_parse_host(data, &pp, FALSE); + if(result) + goto out; + } + + uc = curl_url_get(uh, CURLUPART_ZONEID, &pp.tmp_zoneid, 0); + if(uc == CURLUE_OUT_OF_MEMORY) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + if(pp.tmp_zoneid) { + pp.zoneid.str = pp.tmp_zoneid; + pp.zoneid.len = strlen(pp.tmp_zoneid); + } + + *pproxytype = proxytype; + result = peer_create(&pp, ppeer); + +out: + peer_parse_clear(&pp); + curlx_free(scheme); +#ifdef DEBUGBUILD + if(!result) + DEBUGASSERT(*ppeer); +#endif + return result; +} + +#endif /* !CURL_DISABLE_PROXY */ diff --git a/3rdparty/curl-8.21.0/lib/peer.h b/3rdparty/curl-8.21.0/lib/peer.h new file mode 100644 index 0000000000..1ceb230739 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/peer.h @@ -0,0 +1,110 @@ +#ifndef HEADER_CURL_PEER_H +#define HEADER_CURL_PEER_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +struct Curl_scheme; +struct urlpieces; + +/* if peer hostname starts with this, the peer is a unix domain socket + * path, e.g. the remainder after 'localhost'. */ +#define CURL_PEER_UDS_PREFIX "localhost/" + +struct Curl_peer { + const struct Curl_scheme *scheme; /* url scheme */ + char *hostname; /* normalized hostname (IDN decoded when supported) */ + char *zoneid; /* NULL or ipv6 zone identifier */ + uint32_t refcount; /* created with 1, freed when dropping to 0 */ + uint32_t scopeid; /* != 0, ipv6 scope to use */ + uint16_t port; + BIT(unix_socket); /* hostname is a UDS path without the prefix */ + BIT(abstract_uds); /* only TRUE when `unix_socket` also TRUE */ + BIT(ipv6); /* hostname is an IPv6 address stripped of '[]' */ + char user_hostname[1]; /* hostname supplied by user/url */ +}; + +/* Create a new peer: + * - `peer->user_hostname` is the passed `hostname` + * - `peer->hostname` is the normalized `hostname` via + * + IDN conversion if it has non-ASCII characters + * + stripping of surrounding '[]' for URL formatted ipv6 addresses + * + the path alone in case of a unix domain socket, e.g. hostname + * starts with CURL_PEER_UDS_PREFIX and is longer + * Scans for IPv6 addresses even without surrounding '[]'. + * - `zoneid` ipv6 zone identifier or NULL + * - `scopeid` ipv6 scopeid of zoneid, when known. + */ +CURLcode Curl_peer_create(struct Curl_easy *data, + const struct Curl_scheme *scheme, + const char *hostname, + uint16_t port, + struct Curl_peer **ppeer); + +#ifdef USE_UNIX_SOCKETS +CURLcode Curl_peer_uds_create(const struct Curl_scheme *scheme, + const char *path, + bool abstract_unix_socket, + struct Curl_peer **ppeer); +#endif + +/* Unlink any peer in `*pdest`, assign src, increase src + * refcount when not NULL. */ +void Curl_peer_link(struct Curl_peer **pdest, struct Curl_peer *src); + +/* Drop a reference, peer may be passed as NULL */ +void Curl_peer_unlink(struct Curl_peer **ppeer); + +/* TRUE if both peers are NULL or have completely same properties. */ +bool Curl_peer_equal(struct Curl_peer *p1, struct Curl_peer *p2); + +/* TRUE if both peers are NULL or have same properties except the scheme. */ +bool Curl_peer_same_destination(struct Curl_peer *p1, struct Curl_peer *p2); + +CURLcode Curl_peer_from_url(CURLU *uh, struct Curl_easy *data, + uint16_t port_override, + uint32_t scopeid_override, + struct urlpieces *up, + struct Curl_peer **ppeer); + +CURLcode Curl_peer_from_connect_to(struct Curl_easy *data, + const struct Curl_peer *dest, + const char *connect_to, + struct Curl_peer **ppeer); + +#ifndef CURL_DISABLE_PROXY + +CURLcode Curl_scheme_to_proxytype(struct Curl_easy *data, + const char *scheme, + uint8_t *proxytype, + const char *url); + +CURLcode Curl_peer_from_proxy_url(CURLU *uh, + struct Curl_easy *data, + const char *url, + uint8_t proxytype, + struct Curl_peer **ppeer, + uint8_t *pproxytype); +#endif /* !CURL_DISABLE_PROXY */ + +#endif /* HEADER_CURL_PEER_H */ diff --git a/3rdparty/curl-8.21.0/lib/pingpong.c b/3rdparty/curl-8.21.0/lib/pingpong.c new file mode 100644 index 0000000000..b40d968b3f --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/pingpong.c @@ -0,0 +1,412 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + * 'pingpong' is for generic back-and-forth support functions used by FTP, + * IMAP, POP3, SMTP and whatever more that likes them. + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "urldata.h" +#include "pingpong.h" + +#ifdef USE_PINGPONG + +#include "cfilters.h" +#include "connect.h" +#include "multiif.h" +#include "sendf.h" +#include "curl_trc.h" +#include "select.h" +#include "progress.h" + +timediff_t Curl_pp_state_timeleft_ms(struct Curl_easy *data, + struct pingpong *pp) +{ + timediff_t xfer_remain_ms; + timediff_t remain_ms = data->set.server_response_timeout ? + data->set.server_response_timeout : PINGPONG_TIMEOUT_MS; + + /* If the overall transfer has less time remaining than pingpong + * has otherwise for the state, return that. */ + remain_ms -= curlx_ptimediff_ms(Curl_pgrs_now(data), &pp->response); + /* transfer remaining time is 0, when it has no timeout. */ + xfer_remain_ms = Curl_timeleft_ms(data); + if(xfer_remain_ms) + return CURLMIN(remain_ms, xfer_remain_ms); + return remain_ms; +} + +/* + * Curl_pp_statemach() + */ +CURLcode Curl_pp_statemach(struct Curl_easy *data, + struct pingpong *pp, bool block, + bool disconnecting) +{ + struct connectdata *conn = data->conn; + curl_socket_t sock = conn->sock[FIRSTSOCKET]; + int rc; + timediff_t interval_ms; + timediff_t timeout_ms = Curl_pp_state_timeleft_ms(data, pp); + CURLcode result = CURLE_OK; + + if(timeout_ms <= 0) { + failf(data, "server response timeout"); + return CURLE_OPERATION_TIMEDOUT; /* already too little time */ + } + + if(block) { + interval_ms = 1000; /* use 1 second timeout intervals */ + if(timeout_ms < interval_ms) + interval_ms = timeout_ms; + } + else + interval_ms = 0; /* immediate */ + + if(Curl_conn_data_pending(data, FIRSTSOCKET)) + rc = 1; + else if(pp->overflow) + /* We are receiving and there is data in the cache so read it */ + rc = 1; + else if(!pp->sendleft && Curl_conn_data_pending(data, FIRSTSOCKET)) + /* We are receiving and there is data ready in the SSL library */ + rc = 1; + else { + rc = Curl_socket_check(pp->sendleft ? CURL_SOCKET_BAD : sock, /* reading */ + CURL_SOCKET_BAD, + pp->sendleft ? sock : CURL_SOCKET_BAD, /* writing */ + interval_ms); + } + + if(block) { + /* if we did not wait, we do not have to spend time on this now */ + result = Curl_pgrsCheck(data); + if(result) + return result; + } + + if(rc == -1) { + failf(data, "select/poll error"); + result = CURLE_OUT_OF_MEMORY; + } + else if(rc) + result = pp->statemachine(data, data->conn); + else if(disconnecting) + return CURLE_OPERATION_TIMEDOUT; + + return result; +} + +/* initialize stuff to prepare for reading a fresh new response */ +void Curl_pp_init(struct pingpong *pp, const struct curltime *pnow) +{ + DEBUGASSERT(!pp->initialized); + pp->nread_resp = 0; + pp->response = *pnow; /* start response time-out */ + pp->pending_resp = TRUE; + curlx_dyn_init(&pp->sendbuf, DYN_PINGPPONG_CMD); + curlx_dyn_init(&pp->recvbuf, DYN_PINGPPONG_CMD); + pp->initialized = TRUE; +} + +/*********************************************************************** + * + * Curl_pp_vsendf() + * + * Send the formatted string as a command to a pingpong server. Note that + * the string should not have any CRLF appended, as this function will + * append the necessary things itself. + * + * made to never block + */ +CURLcode Curl_pp_vsendf(struct Curl_easy *data, + struct pingpong *pp, + const char *fmt, + va_list args) +{ + size_t bytes_written = 0; + size_t write_len; + char *s; + CURLcode result; + struct connectdata *conn = data->conn; + + DEBUGASSERT(pp->sendleft == 0); + DEBUGASSERT(pp->sendsize == 0); + DEBUGASSERT(!pp->sendthis); + + if(!conn) + /* cannot send without a connection! */ + return CURLE_SEND_ERROR; + + curlx_dyn_reset(&pp->sendbuf); + result = curlx_dyn_vaddf(&pp->sendbuf, fmt, args); + if(result) + return result; + + /* append CRLF */ + result = curlx_dyn_addn(&pp->sendbuf, "\r\n", 2); + if(result) + return result; + + pp->pending_resp = TRUE; + write_len = curlx_dyn_len(&pp->sendbuf); + s = curlx_dyn_ptr(&pp->sendbuf); + + result = Curl_conn_send(data, FIRSTSOCKET, s, write_len, FALSE, + &bytes_written); + if(result == CURLE_AGAIN) { + bytes_written = 0; + } + else if(result) + return result; + + Curl_debug(data, CURLINFO_HEADER_OUT, s, bytes_written); + + if(bytes_written != write_len) { + /* the whole chunk was not sent, keep it around and adjust sizes */ + pp->sendthis = s; + pp->sendsize = write_len; + pp->sendleft = write_len - bytes_written; + } + else { + pp->sendthis = NULL; + pp->sendleft = pp->sendsize = 0; + pp->response = *Curl_pgrs_now(data); + } + + return CURLE_OK; +} + +/*********************************************************************** + * + * Curl_pp_sendf() + * + * Send the formatted string as a command to a pingpong server. Note that + * the string should not have any CRLF appended, as this function will + * append the necessary things itself. + * + * made to never block + */ +CURLcode Curl_pp_sendf(struct Curl_easy *data, struct pingpong *pp, + const char *fmt, ...) +{ + CURLcode result; + va_list ap; + va_start(ap, fmt); + + result = Curl_pp_vsendf(data, pp, fmt, ap); + + va_end(ap); + + return result; +} + +static CURLcode pingpong_read(struct Curl_easy *data, + int sockindex, + char *buffer, + size_t buflen, + size_t *nread) +{ + return Curl_conn_recv(data, sockindex, buffer, buflen, nread); +} + +/* + * Curl_pp_readresp() + * + * Reads a piece of a server response. + */ +CURLcode Curl_pp_readresp(struct Curl_easy *data, + int sockindex, + struct pingpong *pp, + int *code, /* return the server code if done */ + size_t *size) /* size of the response */ +{ + struct connectdata *conn = data->conn; + CURLcode result = CURLE_OK; + size_t gotbytes; + char buffer[900]; + + *code = 0; /* 0 for errors or not done */ + *size = 0; + + do { + gotbytes = 0; + if(pp->nfinal) { + /* a previous call left this many bytes in the beginning of the buffer as + that was the final line; now ditch that */ + size_t full = curlx_dyn_len(&pp->recvbuf); + + /* trim off the "final" leading part */ + curlx_dyn_tail(&pp->recvbuf, full - pp->nfinal); + + pp->nfinal = 0; /* now gone */ + } + if(!pp->overflow) { + result = pingpong_read(data, sockindex, buffer, sizeof(buffer), + &gotbytes); + if(result == CURLE_AGAIN) + return CURLE_OK; + + if(result) + return result; + + if(!gotbytes) { + failf(data, "response reading failed (errno: %d)", SOCKERRNO); + return CURLE_RECV_ERROR; + } + + result = curlx_dyn_addn(&pp->recvbuf, buffer, gotbytes); + if(result) + return result; + + data->req.headerbytecount += (unsigned int)gotbytes; + + pp->nread_resp += gotbytes; + } + + do { + const char *line = curlx_dyn_ptr(&pp->recvbuf); + const char *nl = memchr(line, '\n', curlx_dyn_len(&pp->recvbuf)); + if(nl) { + /* a newline is CRLF in pp-talk, so the CR is ignored as + the line is not really terminated until the LF comes */ + size_t length = nl - line + 1; + + if(memchr(line, 0, length)) { + /* The response line is passed on as a "header" below, so reject an + embedded nul the same way verify_header() does for HTTP. */ + failf(data, "Nul byte in server response line"); + return CURLE_WEIRD_SERVER_REPLY; + } + + /* output debug output if that is requested */ + Curl_debug(data, CURLINFO_HEADER_IN, line, length); + + /* + * Pass all response-lines to the callback function registered for + * "headers". The response lines can be seen as a kind of headers. + */ + result = Curl_client_write(data, CLIENTWRITE_INFO, line, length); + if(result) + return result; + + if(pp->endofresp(data, conn, line, length, code)) { + /* When at "end of response", keep the endofresp line first in the + buffer since it will be accessed outside (by pingpong + parsers). Store the overflow counter to inform about additional + data in this buffer after the endofresp line. */ + pp->nfinal = length; + if(curlx_dyn_len(&pp->recvbuf) > length) + pp->overflow = curlx_dyn_len(&pp->recvbuf) - length; + else + pp->overflow = 0; + *size = pp->nread_resp; /* size of the response */ + pp->nread_resp = 0; /* restart */ + gotbytes = 0; /* force break out of outer loop */ + break; + } + if(curlx_dyn_len(&pp->recvbuf) > length) + /* keep the remaining piece */ + curlx_dyn_tail((&pp->recvbuf), curlx_dyn_len(&pp->recvbuf) - length); + else + curlx_dyn_reset(&pp->recvbuf); + } + else { + /* without a newline, there is no overflow */ + pp->overflow = 0; + break; + } + + } while(1); /* while there is buffer left to scan */ + + } while(gotbytes == sizeof(buffer)); + + pp->pending_resp = FALSE; + + return result; +} + +CURLcode Curl_pp_pollset(struct Curl_easy *data, + struct pingpong *pp, + struct easy_pollset *ps) +{ + int flags = pp->sendleft ? CURL_POLL_OUT : CURL_POLL_IN; + return Curl_pollset_change(data, ps, data->conn->sock[FIRSTSOCKET], + flags, 0); +} + +bool Curl_pp_needs_flush(struct Curl_easy *data, + struct pingpong *pp) +{ + (void)data; + return pp->sendleft > 0; +} + +CURLcode Curl_pp_flushsend(struct Curl_easy *data, + struct pingpong *pp) +{ + /* we have a piece of a command still left to send */ + size_t written; + CURLcode result; + + if(!Curl_pp_needs_flush(data, pp)) + return CURLE_OK; + + result = Curl_conn_send(data, FIRSTSOCKET, + pp->sendthis + pp->sendsize - pp->sendleft, + pp->sendleft, FALSE, &written); + if(result == CURLE_AGAIN) { + result = CURLE_OK; + written = 0; + } + if(result) + return result; + + if(written != pp->sendleft) { + /* only a fraction was sent */ + pp->sendleft -= written; + } + else { + pp->sendthis = NULL; + pp->sendleft = pp->sendsize = 0; + pp->response = *Curl_pgrs_now(data); + } + return CURLE_OK; +} + +CURLcode Curl_pp_disconnect(struct pingpong *pp) +{ + if(pp->initialized) { + curlx_dyn_free(&pp->sendbuf); + curlx_dyn_free(&pp->recvbuf); + memset(pp, 0, sizeof(*pp)); + } + return CURLE_OK; +} + +bool Curl_pp_moredata(struct pingpong *pp) +{ + return !pp->sendleft && curlx_dyn_len(&pp->recvbuf) > pp->nfinal; +} + +#endif diff --git a/3rdparty/curl-8.21.0/lib/pingpong.h b/3rdparty/curl-8.21.0/lib/pingpong.h new file mode 100644 index 0000000000..02f4961230 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/pingpong.h @@ -0,0 +1,162 @@ +#ifndef HEADER_CURL_PINGPONG_H +#define HEADER_CURL_PINGPONG_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_IMAP) || !defined(CURL_DISABLE_FTP) || \ + !defined(CURL_DISABLE_POP3) || !defined(CURL_DISABLE_SMTP) +#define USE_PINGPONG +#endif + +/* forward-declaration, this is defined in urldata.h */ +struct connectdata; + +typedef enum { + PPTRANSFER_BODY, /* yes do transfer a body */ + PPTRANSFER_INFO, /* do still go through to get info/headers */ + PPTRANSFER_NONE /* do not get anything and do not get info */ +} curl_pp_transfer; + +/* + * 'pingpong' is the generic struct used for protocols doing server<->client + * conversations in a back-and-forth style such as FTP, IMAP, POP3, SMTP etc. + * + * It holds response cache and non-blocking sending data. + */ +struct pingpong { + size_t nread_resp; /* number of bytes currently read of a server response */ + char *sendthis; /* pointer to a buffer that is to be sent to the server */ + size_t sendleft; /* number of bytes left to send from the sendthis buffer */ + size_t sendsize; /* total size of the sendthis buffer */ + struct curltime response; /* set to Curl_now() when a command has been sent + off, used to time-out response reading */ + struct dynbuf sendbuf; + struct dynbuf recvbuf; + size_t overflow; /* number of bytes left after a final response line */ + size_t nfinal; /* number of bytes in the final response line, which + after a match is first in the receive buffer */ + + /* Function pointers the protocols MUST implement and provide for the + pingpong layer to function */ + + CURLcode (*statemachine)(struct Curl_easy *data, struct connectdata *conn); + bool (*endofresp)(struct Curl_easy *data, struct connectdata *conn, + const char *ptr, size_t len, int *code); + BIT(initialized); + BIT(pending_resp); /* set TRUE when a server response is pending or in + progress, and is cleared once the last response is + read */ +}; + +/* Default pingpong response timeout in milliseconds, unless a transfer + * has CURLOPT_SERVER_RESPONSE_TIMEOUT(_MS) set. */ +#define PINGPONG_TIMEOUT_MS (60 * 1000) + +#define PINGPONG_SETUP(pp, s, e) \ + do { \ + (pp)->statemachine = s; \ + (pp)->endofresp = e; \ + } while(0) + +/* + * Curl_pp_statemach() + * + * called repeatedly until done. Set 'wait' to make it wait a while on the + * socket if there is no traffic. + */ +CURLcode Curl_pp_statemach(struct Curl_easy *data, struct pingpong *pp, + bool block, bool disconnecting); + +/* initialize stuff to prepare for reading a fresh new response */ +void Curl_pp_init(struct pingpong *pp, const struct curltime *pnow); + +/* Returns time remaining in ms. 0 or negative number means the + timeout has already triggered */ +timediff_t Curl_pp_state_timeleft_ms(struct Curl_easy *data, + struct pingpong *pp); + +/*********************************************************************** + * + * Curl_pp_sendf() + * + * Send the formatted string as a command to a pingpong server. Note that + * the string should not have any CRLF appended, as this function will + * append the necessary things itself. + * + * made to never block + */ +CURLcode Curl_pp_sendf(struct Curl_easy *data, + struct pingpong *pp, + const char *fmt, ...) CURL_PRINTF(3, 4); + +/*********************************************************************** + * + * Curl_pp_vsendf() + * + * Send the formatted string as a command to a pingpong server. Note that + * the string should not have any CRLF appended, as this function will + * append the necessary things itself. + * + * made to never block + */ +CURLcode Curl_pp_vsendf(struct Curl_easy *data, + struct pingpong *pp, + const char *fmt, + va_list args) CURL_PRINTF(3, 0); + +/* + * Curl_pp_readresp() + * + * Reads a piece of a server response. + */ +CURLcode Curl_pp_readresp(struct Curl_easy *data, + int sockindex, + struct pingpong *pp, + int *code, /* return the server code if done */ + size_t *size); /* size of the response */ + +bool Curl_pp_needs_flush(struct Curl_easy *data, + struct pingpong *pp); + +CURLcode Curl_pp_flushsend(struct Curl_easy *data, + struct pingpong *pp); + +/* call this when a pingpong connection is disconnected */ +CURLcode Curl_pp_disconnect(struct pingpong *pp); + +CURLcode Curl_pp_pollset(struct Curl_easy *data, + struct pingpong *pp, + struct easy_pollset *ps); + +/*********************************************************************** + * + * Curl_pp_moredata() + * + * Returns whether there are still more data in the cache and so a call + * to Curl_pp_readresp() will not block. + */ +bool Curl_pp_moredata(struct pingpong *pp); + +#endif /* HEADER_CURL_PINGPONG_H */ diff --git a/3rdparty/curl-8.21.0/lib/pop3.c b/3rdparty/curl-8.21.0/lib/pop3.c new file mode 100644 index 0000000000..d609b4c2b3 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/pop3.c @@ -0,0 +1,1717 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + * RFC1734 POP3 Authentication + * RFC1939 POP3 protocol + * RFC2195 CRAM-MD5 authentication + * RFC2384 POP URL Scheme + * RFC2449 POP3 Extension Mechanism + * RFC2595 Using TLS with IMAP, POP3 and ACAP + * RFC2831 DIGEST-MD5 authentication + * RFC4422 Simple Authentication and Security Layer (SASL) + * RFC4616 PLAIN authentication + * RFC4752 The Kerberos V5 ("GSSAPI") SASL Mechanism + * RFC5034 POP3 SASL Authentication Mechanism + * RFC6749 OAuth 2.0 Authorization Framework + * RFC8314 Use of TLS for Email Submission and Access + * Draft LOGIN SASL Mechanism + * + ***************************************************************************/ +#include "curl_setup.h" +#include "urldata.h" +#include "pop3.h" + +#ifndef CURL_DISABLE_POP3 + +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_ARPA_INET_H +#include +#endif +#ifdef HAVE_NETDB_H +#include +#endif +#ifdef __VMS +#include +#include +#endif + +#include "sendf.h" +#include "curl_trc.h" +#include "hostip.h" +#include "progress.h" +#include "transfer.h" +#include "escape.h" +#include "pingpong.h" +#include "vtls/vtls.h" +#include "cfilters.h" +#include "connect.h" +#include "select.h" +#include "url.h" +#include "bufref.h" +#include "curl_sasl.h" +#include "curl_md5.h" +#include "curlx/strdup.h" + +/* Authentication type flags */ +#define POP3_TYPE_CLEARTEXT (1 << 0) +#define POP3_TYPE_APOP (1 << 1) +#define POP3_TYPE_SASL (1 << 2) + +/* Authentication type values */ +#define POP3_TYPE_NONE 0 +#define POP3_TYPE_ANY (POP3_TYPE_CLEARTEXT | POP3_TYPE_APOP | POP3_TYPE_SASL) + +/* This is the 5-bytes End-Of-Body marker for POP3 */ +#define POP3_EOB "\x0d\x0a\x2e\x0d\x0a" +#define POP3_EOB_LEN 5 + +/* meta key for storing protocol meta at easy handle */ +#define CURL_META_POP3_EASY "meta:proto:pop3:easy" +/* meta key for storing protocol meta at connection */ +#define CURL_META_POP3_CONN "meta:proto:pop3:conn" + +/* + * POP3 easy handle state + */ +struct POP3 { + curl_pp_transfer transfer; + char *id; /* Message ID */ + char *custom; /* Custom Request */ +}; + +/* + * POP3 connection state + */ +typedef enum { + POP3_STOP, /* do nothing state, stops the state machine */ + POP3_SERVERGREET, /* waiting for the initial greeting immediately after + a connect */ + POP3_CAPA, + POP3_STARTTLS, + POP3_UPGRADETLS, /* asynchronously upgrade the connection to SSL/TLS + (multi mode only) */ + POP3_AUTH, + POP3_APOP, + POP3_USER, + POP3_PASS, + POP3_COMMAND, + POP3_QUIT, + POP3_LAST /* never used */ +} pop3state; + +struct pop3_conn { + struct pingpong pp; + pop3state state; /* Always use pop3.c:state() to change state! */ + size_t eob; /* Number of bytes of the EOB (End Of Body) that + have been received so far */ + size_t strip; /* Number of bytes from the start to ignore as + non-body */ + struct SASL sasl; /* SASL-related storage */ + char *apoptimestamp; /* APOP timestamp from the server greeting */ + unsigned char authtypes; /* Accepted authentication types */ + unsigned char preftype; /* Preferred authentication type */ + BIT(ssldone); /* Is connect() over SSL done? */ + BIT(tls_supported); /* StartTLS capability supported by server */ +}; + +struct pop3_cmd { + const char *name; + unsigned short nlen; + BIT(multiline); /* response is multi-line with last '.' line */ + BIT(multiline_with_args); /* is multi-line when command has args */ +}; + +static const struct pop3_cmd pop3cmds[] = { + { "APOP", 4, FALSE, FALSE }, + { "AUTH", 4, FALSE, FALSE }, + { "CAPA", 4, TRUE, TRUE }, + { "DELE", 4, FALSE, FALSE }, + { "LIST", 4, TRUE, FALSE }, + { "MSG", 3, TRUE, TRUE }, + { "NOOP", 4, FALSE, FALSE }, + { "PASS", 4, FALSE, FALSE }, + { "QUIT", 4, FALSE, FALSE }, + { "RETR", 4, TRUE, TRUE }, + { "RSET", 4, FALSE, FALSE }, + { "STAT", 4, FALSE, FALSE }, + { "STLS", 4, FALSE, FALSE }, + { "TOP", 3, TRUE, TRUE }, + { "UIDL", 4, TRUE, FALSE }, + { "USER", 4, FALSE, FALSE }, + { "UTF8", 4, FALSE, FALSE }, + { "XTND", 4, TRUE, TRUE }, +}; + +/*********************************************************************** + * + * pop3_parse_url_options() + * + * Parse the URL login options. + */ +static CURLcode pop3_parse_url_options(struct connectdata *conn) +{ + struct pop3_conn *pop3c = Curl_conn_meta_get(conn, CURL_META_POP3_CONN); + CURLcode result = CURLE_OK; + const char *ptr = conn->options; + + if(!pop3c) + return CURLE_FAILED_INIT; + + while(!result && ptr && *ptr) { + const char *key = ptr; + const char *value; + + while(*ptr && *ptr != '=') + ptr++; + + value = ptr + 1; + + while(*ptr && *ptr != ';') + ptr++; + + if(curl_strnequal(key, "AUTH=", 5)) { + result = Curl_sasl_parse_url_auth_option(&pop3c->sasl, + value, ptr - value); + + if(result && curl_strnequal(value, "+APOP", ptr - value)) { + pop3c->preftype = POP3_TYPE_APOP; + pop3c->sasl.prefmech = SASL_AUTH_NONE; + result = CURLE_OK; + } + } + else + result = CURLE_URL_MALFORMAT; + + if(*ptr == ';') + ptr++; + } + + if(pop3c->preftype != POP3_TYPE_APOP) + switch(pop3c->sasl.prefmech) { + case SASL_AUTH_NONE: + pop3c->preftype = POP3_TYPE_NONE; + break; + case SASL_AUTH_DEFAULT: + pop3c->preftype = POP3_TYPE_ANY; + break; + default: + pop3c->preftype = POP3_TYPE_SASL; + break; + } + + return result; +} + +/*********************************************************************** + * + * pop3_parse_url_path() + * + * Parse the URL path into separate path components. + */ +static CURLcode pop3_parse_url_path(struct Curl_easy *data) +{ + /* The POP3 struct is already initialized in pop3_connect() */ + struct POP3 *pop3 = Curl_meta_get(data, CURL_META_POP3_EASY); + const char *path = &data->state.up.path[1]; /* skip leading path */ + + if(!pop3) + return CURLE_FAILED_INIT; + /* URL decode the path for the message ID */ + return Curl_urldecode(path, 0, &pop3->id, NULL, REJECT_CTRL); +} + +/*********************************************************************** + * + * pop3_parse_custom_request() + * + * Parse the custom request. + */ +static CURLcode pop3_parse_custom_request(struct Curl_easy *data) +{ + CURLcode result = CURLE_OK; + struct POP3 *pop3 = Curl_meta_get(data, CURL_META_POP3_EASY); + const char *custom = data->set.str[STRING_CUSTOMREQUEST]; + + if(!pop3) + return CURLE_FAILED_INIT; + /* URL decode the custom request */ + if(custom) + result = Curl_urldecode(custom, 0, &pop3->custom, NULL, REJECT_CTRL); + + return result; +} + +/* Return iff a command is defined as "multi-line" (RFC 1939), + * has a response terminated by a last line with a '.'. + */ +static bool pop3_is_multiline(const char *cmdline) +{ + size_t i; + for(i = 0; i < CURL_ARRAYSIZE(pop3cmds); ++i) { + if(curl_strnequal(pop3cmds[i].name, cmdline, pop3cmds[i].nlen)) { + if(!cmdline[pop3cmds[i].nlen]) + return (bool)pop3cmds[i].multiline; + else if(cmdline[pop3cmds[i].nlen] == ' ') + return (bool)pop3cmds[i].multiline_with_args; + } + } + /* Unknown command, assume multi-line for backward compatibility with + * earlier curl versions that only could do multi-line responses. */ + return TRUE; +} + +/*********************************************************************** + * + * pop3_endofresp() + * + * Checks for an ending POP3 status code at the start of the given string, but + * also detects the APOP timestamp from the server greeting and various + * capabilities from the CAPA response including the supported authentication + * types and allowed SASL mechanisms. + */ +static bool pop3_endofresp(struct Curl_easy *data, struct connectdata *conn, + const char *line, size_t len, int *resp) +{ + struct pop3_conn *pop3c = Curl_conn_meta_get(conn, CURL_META_POP3_CONN); + (void)data; + DEBUGASSERT(pop3c); + if(!pop3c) /* internal error */ + return TRUE; + + /* Do we have an error response? */ + if(len >= 4 && !memcmp("-ERR", line, 4)) { + *resp = '-'; + + return TRUE; + } + + /* Are we processing CAPA command responses? */ + if(pop3c->state == POP3_CAPA) { + /* Do we have the terminating line? Per RFC 2449 this is a line + containing only a single dot */ + if((len == 3 && line[0] == '.' && line[1] == '\r') || + (len == 2 && line[0] == '.' && line[1] == '\n')) + /* Treat the response as a success */ + *resp = '+'; + else + /* Treat the response as an untagged continuation */ + *resp = '*'; + + return TRUE; + } + + /* Do we have a success response? */ + if(len >= 3 && !memcmp("+OK", line, 3)) { + *resp = '+'; + + return TRUE; + } + + /* Do we have a continuation response? */ + if(len >= 1 && line[0] == '+') { + *resp = '*'; + + return TRUE; + } + + return FALSE; /* Nothing for us */ +} + +/*********************************************************************** + * + * pop3_get_message() + * + * Gets the authentication message from the response buffer. + */ +static CURLcode pop3_get_message(struct Curl_easy *data, struct bufref *out) +{ + struct pop3_conn *pop3c = + Curl_conn_meta_get(data->conn, CURL_META_POP3_CONN); + char *message; + size_t len; + + if(!pop3c) + return CURLE_FAILED_INIT; + message = curlx_dyn_ptr(&pop3c->pp.recvbuf); + len = pop3c->pp.nfinal; + if(len > 2) { + /* Find the start of the message */ + len -= 2; + for(message += 2; ISBLANK(*message); message++, len--) + ; + + /* Find the end of the message */ + while(len--) + if(!ISBLANK(message[len]) && !ISNEWLINE(message[len])) + break; + + /* Terminate the message */ + message[++len] = '\0'; + Curl_bufref_set(out, message, len, NULL); + } + else + /* junk input => zero length output */ + Curl_bufref_set(out, "", 0, NULL); + + return CURLE_OK; +} + +/*********************************************************************** + * + * pop3_state() + * + * This is the ONLY way to change POP3 state! + */ +static void pop3_state(struct Curl_easy *data, pop3state newstate) +{ + struct pop3_conn *pop3c = + Curl_conn_meta_get(data->conn, CURL_META_POP3_CONN); + if(pop3c) { +#if defined(DEBUGBUILD) && defined(CURLVERBOSE) + /* for debug purposes */ + static const char * const names[] = { + "STOP", + "SERVERGREET", + "CAPA", + "STARTTLS", + "UPGRADETLS", + "AUTH", + "APOP", + "USER", + "PASS", + "COMMAND", + "QUIT", + /* LAST */ + }; + + if(pop3c->state != newstate) + infof(data, "POP3 %p state change from %s to %s", + (void *)pop3c, names[pop3c->state], names[newstate]); +#endif + + pop3c->state = newstate; + } +} + +/*********************************************************************** + * + * pop3_perform_capa() + * + * Sends the CAPA command in order to obtain a list of server side supported + * capabilities. + */ +static CURLcode pop3_perform_capa(struct Curl_easy *data, + struct connectdata *conn) +{ + struct pop3_conn *pop3c = Curl_conn_meta_get(conn, CURL_META_POP3_CONN); + CURLcode result = CURLE_OK; + + if(!pop3c) + return CURLE_FAILED_INIT; + + pop3c->sasl.authmechs = SASL_AUTH_NONE; /* No known auth. mechanisms yet */ + pop3c->sasl.authused = SASL_AUTH_NONE; /* Clear the auth. mechanism used */ + pop3c->tls_supported = FALSE; /* Clear the TLS capability */ + + /* Send the CAPA command */ + result = Curl_pp_sendf(data, &pop3c->pp, "%s", "CAPA"); + + if(!result) + pop3_state(data, POP3_CAPA); + + return result; +} + +/*********************************************************************** + * + * pop3_perform_starttls() + * + * Sends the STLS command to start the upgrade to TLS. + */ +static CURLcode pop3_perform_starttls(struct Curl_easy *data, + struct connectdata *conn) +{ + struct pop3_conn *pop3c = Curl_conn_meta_get(conn, CURL_META_POP3_CONN); + CURLcode result; + + if(!pop3c) + return CURLE_FAILED_INIT; + + /* Send the STLS command */ + result = Curl_pp_sendf(data, &pop3c->pp, "%s", "STLS"); + if(!result) + pop3_state(data, POP3_STARTTLS); + + return result; +} + +/*********************************************************************** + * + * pop3_perform_upgrade_tls() + * + * Performs the upgrade to TLS. + */ +static CURLcode pop3_perform_upgrade_tls(struct Curl_easy *data, + struct connectdata *conn) +{ +#ifdef USE_SSL + /* Start the SSL connection */ + struct pop3_conn *pop3c = Curl_conn_meta_get(conn, CURL_META_POP3_CONN); + CURLcode result; + bool ssldone = FALSE; + + if(!pop3c) + return CURLE_FAILED_INIT; + + if(!Curl_conn_is_ssl(conn, FIRSTSOCKET)) { + result = Curl_ssl_cfilter_add( + data, Curl_conn_get_origin(conn, FIRSTSOCKET), conn, FIRSTSOCKET); + if(result) + goto out; + /* Change the connection handler */ + conn->scheme = &Curl_scheme_pop3s; + } + + DEBUGASSERT(!pop3c->ssldone); + result = Curl_conn_connect(data, FIRSTSOCKET, FALSE, &ssldone); + DEBUGF(infof(data, "pop3_perform_upgrade_tls, connect -> %d, %d", + (int)result, ssldone)); + if(!result && ssldone) { + pop3c->ssldone = ssldone; + /* perform CAPA now, changes pop3c->state out of POP3_UPGRADETLS */ + result = pop3_perform_capa(data, conn); + } +out: + return result; +#else + (void)data; + (void)conn; + return CURLE_NOT_BUILT_IN; +#endif +} + +/*********************************************************************** + * + * pop3_perform_user() + * + * Sends a clear text USER command to authenticate with. + */ +static CURLcode pop3_perform_user(struct Curl_easy *data, + struct connectdata *conn) +{ + struct pop3_conn *pop3c = Curl_conn_meta_get(conn, CURL_META_POP3_CONN); + CURLcode result = CURLE_OK; + + if(!pop3c) + return CURLE_FAILED_INIT; + + /* Check we have a username and password to authenticate with and end the + connect phase if we do not */ + if(!conn->creds) { + pop3_state(data, POP3_STOP); + + return result; + } + + /* Send the USER command */ + result = Curl_pp_sendf(data, &pop3c->pp, "USER %s", + Curl_creds_user(conn->creds)); + if(!result) + pop3_state(data, POP3_USER); + + return result; +} + +#ifndef CURL_DISABLE_DIGEST_AUTH +/*********************************************************************** + * + * pop3_perform_apop() + * + * Sends an APOP command to authenticate with. + */ +static CURLcode pop3_perform_apop(struct Curl_easy *data, + struct connectdata *conn) +{ + struct pop3_conn *pop3c = Curl_conn_meta_get(conn, CURL_META_POP3_CONN); + CURLcode result = CURLE_OK; + size_t i; + struct MD5_context *ctxt; + unsigned char digest[MD5_DIGEST_LEN]; + char secret[(2 * MD5_DIGEST_LEN) + 1]; + + if(!pop3c) + return CURLE_FAILED_INIT; + + /* Check we have a username and password to authenticate with and end the + connect phase if we do not */ + if(!data->state.creds) { + pop3_state(data, POP3_STOP); + + return result; + } + + /* Create the digest */ + ctxt = Curl_MD5_init(&Curl_DIGEST_MD5); + if(!ctxt) + return CURLE_OUT_OF_MEMORY; + + Curl_MD5_update(ctxt, (const unsigned char *)pop3c->apoptimestamp, + curlx_uztoui(strlen(pop3c->apoptimestamp))); + + Curl_MD5_update(ctxt, (const unsigned char *)Curl_creds_passwd(conn->creds), + curlx_uztoui(strlen(Curl_creds_passwd(conn->creds)))); + + /* Finalise the digest */ + Curl_MD5_final(ctxt, digest); + + /* Convert the calculated 16 octet digest into a 32-byte hex string */ + for(i = 0; i < MD5_DIGEST_LEN; i++) + curl_msnprintf(&secret[2 * i], 3, "%02x", digest[i]); + + result = Curl_pp_sendf(data, &pop3c->pp, "APOP %s %s", + Curl_creds_user(conn->creds), secret); + + if(!result) + pop3_state(data, POP3_APOP); + + return result; +} +#endif + +/*********************************************************************** + * + * pop3_perform_auth() + * + * Sends an AUTH command allowing the client to login with the given SASL + * authentication mechanism. + */ +static CURLcode pop3_perform_auth(struct Curl_easy *data, + const char *mech, + const struct bufref *initresp) +{ + struct pop3_conn *pop3c = + Curl_conn_meta_get(data->conn, CURL_META_POP3_CONN); + CURLcode result = CURLE_OK; + const char *ir = Curl_bufref_ptr(initresp); + + if(!pop3c) + return CURLE_FAILED_INIT; + + if(ir) { /* AUTH ... */ + /* Send the AUTH command with the initial response */ + result = Curl_pp_sendf(data, &pop3c->pp, "AUTH %s %s", mech, ir); + } + else { + /* Send the AUTH command */ + result = Curl_pp_sendf(data, &pop3c->pp, "AUTH %s", mech); + } + + return result; +} + +/*********************************************************************** + * + * pop3_continue_auth() + * + * Sends SASL continuation data. + */ +static CURLcode pop3_continue_auth(struct Curl_easy *data, + const char *mech, + const struct bufref *resp) +{ + struct pop3_conn *pop3c = + Curl_conn_meta_get(data->conn, CURL_META_POP3_CONN); + + (void)mech; + if(!pop3c) + return CURLE_FAILED_INIT; + + return Curl_pp_sendf(data, &pop3c->pp, "%s", Curl_bufref_ptr(resp)); +} + +/*********************************************************************** + * + * pop3_cancel_auth() + * + * Sends SASL cancellation. + */ +static CURLcode pop3_cancel_auth(struct Curl_easy *data, const char *mech) +{ + struct pop3_conn *pop3c = + Curl_conn_meta_get(data->conn, CURL_META_POP3_CONN); + + (void)mech; + if(!pop3c) + return CURLE_FAILED_INIT; + + return Curl_pp_sendf(data, &pop3c->pp, "*"); +} + +/*********************************************************************** + * + * pop3_perform_authentication() + * + * Initiates the authentication sequence, with the appropriate SASL + * authentication mechanism, falling back to APOP and clear text should a + * common mechanism not be available between the client and server. + */ +static CURLcode pop3_perform_authentication(struct Curl_easy *data, + struct connectdata *conn) +{ + struct pop3_conn *pop3c = Curl_conn_meta_get(conn, CURL_META_POP3_CONN); + CURLcode result = CURLE_OK; + saslprogress progress = SASL_IDLE; + + if(!pop3c) + return CURLE_FAILED_INIT; + + /* Check we have enough data to authenticate with and end the + connect phase if we do not */ + if(!Curl_sasl_can_authenticate(&pop3c->sasl, data)) { + pop3_state(data, POP3_STOP); + return result; + } + + if(pop3c->authtypes & pop3c->preftype & POP3_TYPE_SASL) { + /* Calculate the SASL login details */ + result = Curl_sasl_start(&pop3c->sasl, data, FALSE, &progress); + + if(!result) + if(progress == SASL_INPROGRESS) + pop3_state(data, POP3_AUTH); + } + + if(!result && progress == SASL_IDLE) { +#ifndef CURL_DISABLE_DIGEST_AUTH + if(pop3c->authtypes & pop3c->preftype & POP3_TYPE_APOP) + /* Perform APOP authentication */ + result = pop3_perform_apop(data, conn); + else +#endif + if(pop3c->authtypes & pop3c->preftype & POP3_TYPE_CLEARTEXT) + /* Perform clear text authentication */ + result = pop3_perform_user(data, conn); + else + result = Curl_sasl_is_blocked(&pop3c->sasl, data); + } + + return result; +} + +/*********************************************************************** + * + * pop3_perform_command() + * + * Sends a POP3 based command. + */ +static CURLcode pop3_perform_command(struct Curl_easy *data) +{ + CURLcode result = CURLE_OK; + struct connectdata *conn = data->conn; + struct POP3 *pop3 = Curl_meta_get(data, CURL_META_POP3_EASY); + struct pop3_conn *pop3c = Curl_conn_meta_get(conn, CURL_META_POP3_CONN); + const char *command = NULL; + + if(!pop3 || !pop3c) + return CURLE_FAILED_INIT; + + /* Calculate the default command */ + if(pop3->id[0] == '\0' || data->set.list_only) { + command = "LIST"; + + if(pop3->id[0] != '\0') + /* Message specific LIST so skip the BODY transfer */ + pop3->transfer = PPTRANSFER_INFO; + } + else + command = "RETR"; + + if(pop3->custom && pop3->custom[0] != '\0') + command = pop3->custom; + + /* Send the command */ + if(pop3->id[0] != '\0') + result = Curl_pp_sendf(data, &pop3c->pp, "%s %s", command, pop3->id); + else + result = Curl_pp_sendf(data, &pop3c->pp, "%s", command); + + if(!result) { + pop3_state(data, POP3_COMMAND); + data->req.no_body = !pop3_is_multiline(command); + } + + return result; +} + +/*********************************************************************** + * + * pop3_perform_quit() + * + * Performs the quit action prior to sclose() be called. + */ +static CURLcode pop3_perform_quit(struct Curl_easy *data, + struct connectdata *conn) +{ + struct pop3_conn *pop3c = Curl_conn_meta_get(conn, CURL_META_POP3_CONN); + CURLcode result; + + if(!pop3c) + return CURLE_FAILED_INIT; + + /* Send the QUIT command */ + result = Curl_pp_sendf(data, &pop3c->pp, "%s", "QUIT"); + if(!result) + pop3_state(data, POP3_QUIT); + + return result; +} + +/* For the initial server greeting */ +static CURLcode pop3_state_servergreet_resp(struct Curl_easy *data, + int pop3code, + pop3state instate) +{ + CURLcode result = CURLE_OK; + struct connectdata *conn = data->conn; + struct pop3_conn *pop3c = Curl_conn_meta_get(conn, CURL_META_POP3_CONN); + const char *line; + size_t len; + + (void)instate; + if(!pop3c) + return CURLE_FAILED_INIT; + + line = curlx_dyn_ptr(&pop3c->pp.recvbuf); + len = pop3c->pp.nfinal; + + if(pop3code != '+') { + failf(data, "Got unexpected pop3-server response"); + result = CURLE_WEIRD_SERVER_REPLY; + } + else if(len > 3) { + /* Does the server support APOP authentication? */ + const char *lt; + const char *gt = NULL; + + /* Look for the APOP timestamp */ + lt = memchr(line, '<', len); + if(lt) + /* search the remainder for '>' */ + gt = memchr(lt, '>', len - (lt - line)); + if(gt) { + /* the length of the timestamp, including the brackets */ + size_t timestamplen = gt - lt + 1; + const char *at = memchr(lt, '@', timestamplen); + /* If the timestamp does not contain '@' it is not (as required by + RFC-1939) conformant to the RFC-822 message id syntax, and we + therefore do not use APOP authentication. */ + if(at) { + /* dupe the timestamp */ + pop3c->apoptimestamp = curlx_memdup0(lt, timestamplen); + if(!pop3c->apoptimestamp) + return CURLE_OUT_OF_MEMORY; + /* Store the APOP capability */ + pop3c->authtypes |= POP3_TYPE_APOP; + } + } + + if(!result) + result = pop3_perform_capa(data, conn); + } + + return result; +} + +/* For CAPA responses */ +static CURLcode pop3_state_capa_resp(struct Curl_easy *data, int pop3code, + pop3state instate) +{ + CURLcode result = CURLE_OK; + struct connectdata *conn = data->conn; + struct pop3_conn *pop3c = Curl_conn_meta_get(conn, CURL_META_POP3_CONN); + const char *line; + size_t len; + + (void)instate; + if(!pop3c) + return CURLE_FAILED_INIT; + + line = curlx_dyn_ptr(&pop3c->pp.recvbuf); + len = pop3c->pp.nfinal; + + /* Do we have an untagged continuation response? */ + if(pop3code == '*') { + /* Does the server support the STLS capability? */ + if(len >= 4 && curl_strnequal(line, "STLS", 4)) + pop3c->tls_supported = TRUE; + + /* Does the server support clear text authentication? */ + else if(len >= 4 && curl_strnequal(line, "USER", 4)) + pop3c->authtypes |= POP3_TYPE_CLEARTEXT; + + /* Does the server support SASL based authentication? */ + else if(len >= 5 && curl_strnequal(line, "SASL ", 5)) { + pop3c->authtypes |= POP3_TYPE_SASL; + + /* Advance past the SASL keyword */ + line += 5; + len -= 5; + + /* Loop through the data line */ + for(;;) { + size_t llen; + size_t wordlen = 0; + unsigned short mechbit; + + while(len && (ISBLANK(*line) || ISNEWLINE(*line))) { + line++; + len--; + } + + if(!len) + break; + + /* Extract the word */ + while(wordlen < len && !ISBLANK(line[wordlen]) && + !ISNEWLINE(line[wordlen])) + wordlen++; + + /* Test the word for a matching authentication mechanism */ + mechbit = Curl_sasl_decode_mech(line, wordlen, &llen); + if(mechbit && llen == wordlen) + pop3c->sasl.authmechs |= mechbit; + + line += wordlen; + len -= wordlen; + } + } + } + else { + /* Clear text is supported when CAPA is not recognised */ + if(pop3code != '+') + pop3c->authtypes |= POP3_TYPE_CLEARTEXT; + + if(!data->set.use_ssl || Curl_conn_is_ssl(conn, FIRSTSOCKET)) + result = pop3_perform_authentication(data, conn); + else if(pop3code == '+' && pop3c->tls_supported) + /* Switch to TLS connection now */ + result = pop3_perform_starttls(data, conn); + else if(data->set.use_ssl <= CURLUSESSL_TRY) + /* Fallback and carry on with authentication */ + result = pop3_perform_authentication(data, conn); + else { + failf(data, "STLS not supported."); + result = CURLE_USE_SSL_FAILED; + } + } + + return result; +} + +/* For STARTTLS responses */ +static CURLcode pop3_state_starttls_resp(struct Curl_easy *data, + struct connectdata *conn, + int pop3code, + pop3state instate) +{ + struct pop3_conn *pop3c = Curl_conn_meta_get(conn, CURL_META_POP3_CONN); + CURLcode result = CURLE_OK; + (void)instate; + + if(!pop3c) + return CURLE_FAILED_INIT; + + /* Pipelining in response is forbidden. */ + if(pop3c->pp.overflow) + return CURLE_WEIRD_SERVER_REPLY; + + if(pop3code != '+') { + if(data->set.use_ssl != CURLUSESSL_TRY) { + failf(data, "STARTTLS denied"); + result = CURLE_USE_SSL_FAILED; + } + else + result = pop3_perform_authentication(data, conn); + } + else + pop3_state(data, POP3_UPGRADETLS); + + return result; +} + +/* For SASL authentication responses */ +static CURLcode pop3_state_auth_resp(struct Curl_easy *data, + int pop3code, + pop3state instate) +{ + CURLcode result = CURLE_OK; + struct connectdata *conn = data->conn; + struct pop3_conn *pop3c = Curl_conn_meta_get(conn, CURL_META_POP3_CONN); + saslprogress progress; + + (void)instate; + if(!pop3c) + return CURLE_FAILED_INIT; + + result = Curl_sasl_continue(&pop3c->sasl, data, pop3code, &progress); + if(!result) + switch(progress) { + case SASL_DONE: + pop3_state(data, POP3_STOP); /* Authenticated */ + break; + case SASL_IDLE: /* No mechanism left after cancellation */ +#ifndef CURL_DISABLE_DIGEST_AUTH + if(pop3c->authtypes & pop3c->preftype & POP3_TYPE_APOP) + /* Perform APOP authentication */ + result = pop3_perform_apop(data, conn); + else +#endif + if(pop3c->authtypes & pop3c->preftype & POP3_TYPE_CLEARTEXT) + /* Perform clear text authentication */ + result = pop3_perform_user(data, conn); + else { + failf(data, "Authentication cancelled"); + result = CURLE_LOGIN_DENIED; + } + break; + default: + break; + } + + return result; +} + +#ifndef CURL_DISABLE_DIGEST_AUTH +/* For APOP responses */ +static CURLcode pop3_state_apop_resp(struct Curl_easy *data, int pop3code, + pop3state instate) +{ + CURLcode result = CURLE_OK; + (void)instate; + + if(pop3code != '+') { + failf(data, "Authentication failed: %d", pop3code); + result = CURLE_LOGIN_DENIED; + } + else + /* End of connect phase */ + pop3_state(data, POP3_STOP); + + return result; +} +#endif + +/* For USER responses */ +static CURLcode pop3_state_user_resp(struct Curl_easy *data, int pop3code, + pop3state instate) +{ + CURLcode result = CURLE_OK; + struct connectdata *conn = data->conn; + struct pop3_conn *pop3c = Curl_conn_meta_get(conn, CURL_META_POP3_CONN); + (void)instate; + + if(!pop3c) + return CURLE_FAILED_INIT; + + if(pop3code != '+') { + failf(data, "Access denied. %c", pop3code); + result = CURLE_LOGIN_DENIED; + } + else + /* Send the PASS command */ + result = Curl_pp_sendf(data, &pop3c->pp, "PASS %s", + Curl_creds_passwd(conn->creds)); + if(!result) + pop3_state(data, POP3_PASS); + + return result; +} + +/* For PASS responses */ +static CURLcode pop3_state_pass_resp(struct Curl_easy *data, int pop3code, + pop3state instate) +{ + CURLcode result = CURLE_OK; + (void)instate; + + if(pop3code != '+') { + failf(data, "Access denied. %c", pop3code); + result = CURLE_LOGIN_DENIED; + } + else + /* End of connect phase */ + pop3_state(data, POP3_STOP); + + return result; +} + +/*********************************************************************** + * + * pop3_write() + * + * This function scans the body after the end-of-body and writes everything + * until the end is found. + */ +static CURLcode pop3_write(struct Curl_easy *data, const char *str, + size_t nread, bool is_eos) +{ + /* This code could be made into a special function in the handler struct */ + CURLcode result = CURLE_OK; + struct connectdata *conn = data->conn; + struct pop3_conn *pop3c = Curl_conn_meta_get(conn, CURL_META_POP3_CONN); + bool strip_dot = FALSE; + size_t last = 0; + size_t i; + (void)is_eos; + + if(!pop3c) + return CURLE_FAILED_INIT; + + /* Search through the buffer looking for the end-of-body marker which is + 5 bytes (0d 0a 2e 0d 0a). Note that a line starting with a dot matches + the eob so the server will have prefixed it with an extra dot which we + need to strip out. Additionally the marker could of course be spread out + over 5 different data chunks. */ + for(i = 0; i < nread; i++) { + size_t prev = pop3c->eob; + + switch(str[i]) { + case 0x0d: + if(pop3c->eob == 0) { + pop3c->eob++; + + if(i) { + /* Write out the body part that did not match */ + result = Curl_client_write(data, CLIENTWRITE_BODY, &str[last], + i - last); + + if(result) + return result; + + last = i; + } + } + else if(pop3c->eob == 3) + pop3c->eob++; + else + /* If the character match was not at position 0 or 3 then restart the + pattern matching */ + pop3c->eob = 1; + break; + + case 0x0a: + if(pop3c->eob == 1 || pop3c->eob == 4) + pop3c->eob++; + else + /* If the character match was not at position 1 or 4 then start the + search again */ + pop3c->eob = 0; + break; + + case 0x2e: + if(pop3c->eob == 2) + pop3c->eob++; + else if(pop3c->eob == 3) { + /* We have an extra dot after the CRLF which we need to strip off */ + strip_dot = TRUE; + pop3c->eob = 0; + } + else + /* If the character match was not at position 2 then start the search + again */ + pop3c->eob = 0; + break; + + default: + pop3c->eob = 0; + break; + } + + /* Did we have a partial match which has subsequently failed? */ + if(prev && prev >= pop3c->eob) { + /* Strip can only be non-zero for the first mismatch after CRLF and + then both prev and strip are equal and nothing will be output below */ + while(prev && pop3c->strip) { + prev--; + pop3c->strip--; + } + + if(prev) { + /* If the partial match was the CRLF and dot then only write the CRLF + as the server would have inserted the dot */ + if(strip_dot && prev - 1 > 0) { + result = Curl_client_write(data, CLIENTWRITE_BODY, POP3_EOB, + prev - 1); + } + else if(!strip_dot) { + result = Curl_client_write(data, CLIENTWRITE_BODY, POP3_EOB, + prev); + } + else { + result = CURLE_OK; + } + + if(result) + return result; + + last = i; + strip_dot = FALSE; + } + } + } + + if(pop3c->eob == POP3_EOB_LEN) { + /* We have a full match so the transfer is done, however we must transfer + the CRLF at the start of the EOB as this is considered to be part of the + message as per RFC-1939, sect. 3 */ + result = Curl_client_write(data, CLIENTWRITE_BODY, POP3_EOB, 2); + + CURL_REQ_CLEAR_RECV(data); + pop3c->eob = 0; + + return result; + } + + if(pop3c->eob) + /* While EOB is matching nothing should be output */ + return CURLE_OK; + + if(nread - last) { + result = Curl_client_write(data, CLIENTWRITE_BODY, &str[last], + nread - last); + } + + return result; +} + +/* For command responses */ +static CURLcode pop3_state_command_resp(struct Curl_easy *data, + int pop3code, + pop3state instate) +{ + CURLcode result = CURLE_OK; + struct connectdata *conn = data->conn; + struct POP3 *pop3 = Curl_meta_get(data, CURL_META_POP3_EASY); + struct pop3_conn *pop3c = Curl_conn_meta_get(conn, CURL_META_POP3_CONN); + struct pingpong *pp; + + (void)instate; + if(!pop3 || !pop3c) + return CURLE_FAILED_INIT; + + pp = &pop3c->pp; + if(pop3code != '+') { + pop3_state(data, POP3_STOP); + return CURLE_WEIRD_SERVER_REPLY; + } + + /* This 'OK' line ends with a CR LF pair which is the two first bytes of the + EOB string so count this is two matching bytes. This is necessary to make + the code detect the EOB if the only data than comes now is %2e CR LF like + when there is no body to return. */ + pop3c->eob = 2; + + /* Since this initial CR LF pair is not part of the actual body, we set + the strip counter here so that these bytes will not be delivered. */ + pop3c->strip = 2; + + if(pop3->transfer == PPTRANSFER_BODY) { + /* POP3 download */ + Curl_xfer_setup_recv(data, FIRSTSOCKET, -1); + + if(pp->overflow) { + /* The recv buffer contains data that is actually body content so send + it as such. Note that there may even be additional "headers" after + the body */ + + /* keep only the overflow */ + curlx_dyn_tail(&pp->recvbuf, pp->overflow); + pp->nfinal = 0; /* done */ + + if(!data->req.no_body) { + result = pop3_write(data, curlx_dyn_ptr(&pp->recvbuf), + curlx_dyn_len(&pp->recvbuf), FALSE); + if(result) + return result; + } + + /* reset the buffer */ + curlx_dyn_reset(&pp->recvbuf); + pp->overflow = 0; + } + } + else + pp->overflow = 0; + + /* End of DO phase */ + pop3_state(data, POP3_STOP); + + return result; +} + +static CURLcode pop3_statemachine(struct Curl_easy *data, + struct connectdata *conn) +{ + struct pop3_conn *pop3c = Curl_conn_meta_get(conn, CURL_META_POP3_CONN); + CURLcode result = CURLE_OK; + int pop3code; + struct pingpong *pp; + size_t nread = 0; + (void)data; + + if(!pop3c) + return CURLE_FAILED_INIT; + + pp = &pop3c->pp; + /* Busy upgrading the connection; right now all I/O is SSL/TLS, not POP3 */ +upgrade_tls: + if(pop3c->state == POP3_UPGRADETLS) { + result = pop3_perform_upgrade_tls(data, conn); + if(result || (pop3c->state == POP3_UPGRADETLS)) + return result; + } + + /* Flush any data that needs to be sent */ + if(pp->sendleft) + return Curl_pp_flushsend(data, pp); + + do { + /* Read the response from the server */ + result = Curl_pp_readresp(data, FIRSTSOCKET, pp, &pop3code, &nread); + if(result) + return result; + + if(!pop3code) + break; + + /* We have now received a full POP3 server response */ + switch(pop3c->state) { + case POP3_SERVERGREET: + result = pop3_state_servergreet_resp(data, pop3code, pop3c->state); + break; + + case POP3_CAPA: + result = pop3_state_capa_resp(data, pop3code, pop3c->state); + break; + + case POP3_STARTTLS: + result = pop3_state_starttls_resp(data, conn, pop3code, pop3c->state); + /* During UPGRADETLS, leave the read loop as we need to connect + * (e.g. TLS handshake) before we continue sending/receiving. */ + if(!result && (pop3c->state == POP3_UPGRADETLS)) + goto upgrade_tls; + break; + + case POP3_AUTH: + result = pop3_state_auth_resp(data, pop3code, pop3c->state); + break; + +#ifndef CURL_DISABLE_DIGEST_AUTH + case POP3_APOP: + result = pop3_state_apop_resp(data, pop3code, pop3c->state); + break; +#endif + + case POP3_USER: + result = pop3_state_user_resp(data, pop3code, pop3c->state); + break; + + case POP3_PASS: + result = pop3_state_pass_resp(data, pop3code, pop3c->state); + break; + + case POP3_COMMAND: + result = pop3_state_command_resp(data, pop3code, pop3c->state); + break; + + case POP3_QUIT: + pop3_state(data, POP3_STOP); + break; + + default: + /* internal error */ + pop3_state(data, POP3_STOP); + break; + } + } while(!result && pop3c->state != POP3_STOP && Curl_pp_moredata(pp)); + + return result; +} + +/* Called repeatedly until done from multi.c */ +static CURLcode pop3_multi_statemach(struct Curl_easy *data, bool *done) +{ + CURLcode result = CURLE_OK; + struct connectdata *conn = data->conn; + struct pop3_conn *pop3c = Curl_conn_meta_get(conn, CURL_META_POP3_CONN); + + if(!pop3c) + return CURLE_FAILED_INIT; + result = Curl_pp_statemach(data, &pop3c->pp, FALSE, FALSE); + *done = (pop3c->state == POP3_STOP); + + return result; +} + +static CURLcode pop3_block_statemach(struct Curl_easy *data, + struct connectdata *conn, + bool disconnecting) +{ + CURLcode result = CURLE_OK; + struct pop3_conn *pop3c = Curl_conn_meta_get(conn, CURL_META_POP3_CONN); + + if(!pop3c) + return CURLE_FAILED_INIT; + + while(pop3c->state != POP3_STOP && !result) + result = Curl_pp_statemach(data, &pop3c->pp, TRUE, disconnecting); + + return result; +} + +/* For the POP3 "protocol connect" and "doing" phases only */ +static CURLcode pop3_pollset(struct Curl_easy *data, + struct easy_pollset *ps) +{ + struct pop3_conn *pop3c = + Curl_conn_meta_get(data->conn, CURL_META_POP3_CONN); + return pop3c ? Curl_pp_pollset(data, &pop3c->pp, ps) : CURLE_OK; +} + +/* SASL parameters for the pop3 protocol */ +static const struct SASLproto saslpop3 = { + "pop", /* The service name */ + pop3_perform_auth, /* Send authentication command */ + pop3_continue_auth, /* Send authentication continuation */ + pop3_cancel_auth, /* Send authentication cancellation */ + pop3_get_message, /* Get SASL response message */ + 255 - 8, /* Max line len - strlen("AUTH ") - 1 space - crlf */ + '*', /* Code received when continuation is expected */ + '+', /* Code to receive upon authentication success */ + SASL_AUTH_DEFAULT, /* Default mechanisms */ + SASL_FLAG_BASE64 /* Configuration flags */ +}; + +/*********************************************************************** + * + * pop3_connect() + * + * This function should do everything that is to be considered a part of the + * connection phase. + * + * The variable 'done' points to will be TRUE if the protocol-layer connect + * phase is done when this function returns, or FALSE if not. + */ +static CURLcode pop3_connect(struct Curl_easy *data, bool *done) +{ + CURLcode result = CURLE_OK; + struct connectdata *conn = data->conn; + struct pop3_conn *pop3c = Curl_conn_meta_get(conn, CURL_META_POP3_CONN); + struct pingpong *pp = pop3c ? &pop3c->pp : NULL; + + *done = FALSE; /* default to not done yet */ + if(!pop3c) + return CURLE_FAILED_INIT; + + PINGPONG_SETUP(pp, pop3_statemachine, pop3_endofresp); + + /* Set the default preferred authentication type and mechanism */ + pop3c->preftype = POP3_TYPE_ANY; + Curl_sasl_init(&pop3c->sasl, data, &saslpop3); + + /* Initialize the pingpong layer */ + Curl_pp_init(pp, Curl_pgrs_now(data)); + + /* Parse the URL options */ + result = pop3_parse_url_options(conn); + if(result) + return result; + + /* Start off waiting for the server greeting response */ + pop3_state(data, POP3_SERVERGREET); + + result = pop3_multi_statemach(data, done); + + return result; +} + +/*********************************************************************** + * + * pop3_done() + * + * The DONE function. This does what needs to be done after a single DO has + * performed. + * + * Input argument is already checked for validity. + */ +static CURLcode pop3_done(struct Curl_easy *data, CURLcode status, + bool premature) +{ + CURLcode result = CURLE_OK; + struct POP3 *pop3 = Curl_meta_get(data, CURL_META_POP3_EASY); + + (void)premature; + + if(!pop3) + return CURLE_OK; + + if(status) { + connclose(data->conn, "POP3 done with bad status"); + result = status; /* use the already set error code */ + } + + /* Cleanup our per-request based variables */ + curlx_safefree(pop3->id); + curlx_safefree(pop3->custom); + + /* Clear the transfer mode for the next request */ + pop3->transfer = PPTRANSFER_BODY; + + return result; +} + +/*********************************************************************** + * + * pop3_perform() + * + * This is the actual DO function for POP3. Get a message/listing according to + * the options previously setup. + */ +static CURLcode pop3_perform(struct Curl_easy *data, bool *connected, + bool *dophase_done) +{ + /* This is POP3 and no proxy */ + CURLcode result = CURLE_OK; + struct POP3 *pop3 = Curl_meta_get(data, CURL_META_POP3_EASY); + + if(!pop3) + return CURLE_FAILED_INIT; + + DEBUGF(infof(data, "DO phase starts")); + + /* Start the first command in the DO phase, may alter data->req.no_body */ + result = pop3_perform_command(data); + if(result) + return result; + + if(data->req.no_body) + /* Requested no body means no transfer */ + pop3->transfer = PPTRANSFER_INFO; + + *dophase_done = FALSE; /* not done yet */ + + /* Run the state-machine */ + result = pop3_multi_statemach(data, dophase_done); + *connected = Curl_conn_is_connected(data->conn, FIRSTSOCKET); + + if(*dophase_done) + DEBUGF(infof(data, "DO phase is complete")); + + return result; +} + +/* Call this when the DO phase has completed */ +static CURLcode pop3_dophase_done(struct Curl_easy *data, bool connected) +{ + (void)data; + (void)connected; + + return CURLE_OK; +} + +/*********************************************************************** + * + * pop3_regular_transfer() + * + * The input argument is already checked for validity. + * + * Performs all commands done before a regular transfer between a local and a + * remote host. + */ +static CURLcode pop3_regular_transfer(struct Curl_easy *data, + bool *dophase_done) +{ + CURLcode result = CURLE_OK; + bool connected = FALSE; + + /* Make sure size is unknown at this point */ + data->req.size = -1; + + /* Set the progress data */ + Curl_pgrsReset(data); + + /* Carry out the perform */ + result = pop3_perform(data, &connected, dophase_done); + + /* Perform post DO phase operations if necessary */ + if(!result && *dophase_done) + result = pop3_dophase_done(data, connected); + + return result; +} + +/*********************************************************************** + * + * pop3_do() + * + * This function is registered as 'curl_do' function. It decodes the path + * parts etc as a wrapper to the actual DO function (pop3_perform). + * + * The input argument is already checked for validity. + */ +static CURLcode pop3_do(struct Curl_easy *data, bool *done) +{ + CURLcode result = CURLE_OK; + *done = FALSE; /* default to false */ + + /* Parse the URL path */ + result = pop3_parse_url_path(data); + if(result) + return result; + + /* Parse the custom request */ + result = pop3_parse_custom_request(data); + if(result) + return result; + + result = pop3_regular_transfer(data, done); + + return result; +} + +/*********************************************************************** + * + * pop3_disconnect() + * + * Disconnect from an POP3 server. Cleanup protocol-specific per-connection + * resources. BLOCKING. + */ +static CURLcode pop3_disconnect(struct Curl_easy *data, + struct connectdata *conn, bool dead_connection) +{ + struct pop3_conn *pop3c = Curl_conn_meta_get(conn, CURL_META_POP3_CONN); + (void)data; + + if(!pop3c) + return CURLE_FAILED_INIT; + + /* We cannot send quit unconditionally. If this connection is stale or + bad in any way, sending quit and waiting around here will make the + disconnect wait in vain and cause more problems than we need to. */ + + if(!dead_connection && conn->bits.protoconnstart && + !Curl_pp_needs_flush(data, &pop3c->pp)) { + if(!pop3_perform_quit(data, conn)) + (void)pop3_block_statemach(data, conn, TRUE); /* ignore errors on QUIT */ + } + + /* Disconnect from the server */ + Curl_pp_disconnect(&pop3c->pp); + + /* Cleanup our connection based variables */ + curlx_safefree(pop3c->apoptimestamp); + + return CURLE_OK; +} + +/* Called from multi.c while DOing */ +static CURLcode pop3_doing(struct Curl_easy *data, bool *dophase_done) +{ + CURLcode result = pop3_multi_statemach(data, dophase_done); + + if(result) + DEBUGF(infof(data, "DO phase failed")); + else if(*dophase_done) { + result = pop3_dophase_done(data, FALSE /* not connected */); + + DEBUGF(infof(data, "DO phase is complete")); + } + + return result; +} + +static void pop3_easy_dtor(void *key, size_t klen, void *entry) +{ + struct POP3 *pop3 = entry; + (void)key; + (void)klen; + DEBUGASSERT(pop3); + /* Cleanup our per-request based variables */ + curlx_safefree(pop3->id); + curlx_safefree(pop3->custom); + curlx_free(pop3); +} + +static void pop3_conn_dtor(void *key, size_t klen, void *entry) +{ + struct pop3_conn *pop3c = entry; + (void)key; + (void)klen; + DEBUGASSERT(pop3c); + Curl_pp_disconnect(&pop3c->pp); + curlx_safefree(pop3c->apoptimestamp); + curlx_free(pop3c); +} + +static CURLcode pop3_setup_connection(struct Curl_easy *data, + struct connectdata *conn) +{ + struct pop3_conn *pop3c; + struct POP3 *pop3 = curlx_calloc(1, sizeof(*pop3)); + if(!pop3 || + Curl_meta_set(data, CURL_META_POP3_EASY, pop3, pop3_easy_dtor)) + return CURLE_OUT_OF_MEMORY; + + pop3c = curlx_calloc(1, sizeof(*pop3c)); + if(!pop3c || + Curl_conn_meta_set(conn, CURL_META_POP3_CONN, pop3c, pop3_conn_dtor)) + return CURLE_OUT_OF_MEMORY; + + return CURLE_OK; +} + +/* + * POP3 protocol. + */ +const struct Curl_protocol Curl_protocol_pop3 = { + pop3_setup_connection, /* setup_connection */ + pop3_do, /* do_it */ + pop3_done, /* done */ + ZERO_NULL, /* do_more */ + pop3_connect, /* connect_it */ + pop3_multi_statemach, /* connecting */ + pop3_doing, /* doing */ + pop3_pollset, /* proto_pollset */ + pop3_pollset, /* doing_pollset */ + ZERO_NULL, /* domore_pollset */ + ZERO_NULL, /* perform_pollset */ + pop3_disconnect, /* disconnect */ + pop3_write, /* write_resp */ + ZERO_NULL, /* write_resp_hd */ + ZERO_NULL, /* connection_is_dead */ + ZERO_NULL, /* attach connection */ + ZERO_NULL, /* follow */ +}; + +#endif /* CURL_DISABLE_POP3 */ diff --git a/3rdparty/curl-8.21.0/lib/pop3.h b/3rdparty/curl-8.21.0/lib/pop3.h new file mode 100644 index 0000000000..75c3a67da7 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/pop3.h @@ -0,0 +1,30 @@ +#ifndef HEADER_CURL_POP3_H +#define HEADER_CURL_POP3_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#ifndef CURL_DISABLE_POP3 +extern const struct Curl_protocol Curl_protocol_pop3; +#endif + +#endif /* HEADER_CURL_POP3_H */ diff --git a/3rdparty/curl-8.21.0/lib/progress.c b/3rdparty/curl-8.21.0/lib/progress.c new file mode 100644 index 0000000000..969b29a275 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/progress.c @@ -0,0 +1,738 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "urldata.h" +#include "curl_trc.h" +#include "multiif.h" +#include "progress.h" +#include "transfer.h" +#include "curlx/strcopy.h" + +#ifndef CURL_DISABLE_PROGRESS_METER +/* Provide a string that is 7 letters long (plus the zero byte). + + @unittest 1636 +*/ +UNITTEST void time2str(char *r, size_t rsize, curl_off_t seconds); +UNITTEST void time2str(char *r, size_t rsize, curl_off_t seconds) +{ + curl_off_t h; + if(seconds <= 0) { + curlx_strcopy(r, rsize, STRCONST(" ")); + return; + } + h = seconds / 3600; + if(h <= 99) { + curl_off_t m = (seconds - (h * 3600)) / 60; + if(h <= 9) { + curl_off_t s = (seconds - (h * 3600)) - (m * 60); + if(h) + curl_msnprintf(r, rsize, "%" FMT_OFF_T ":%02" FMT_OFF_T ":" + "%02" FMT_OFF_T, h, m, s); + else + curl_msnprintf(r, rsize, " %02" FMT_OFF_T ":%02" FMT_OFF_T, m, s); + } + else + curl_msnprintf(r, rsize, "%" FMT_OFF_T "h %02" FMT_OFF_T "m", h, m); + } + else { + curl_off_t d = seconds / 86400; + h = (seconds - (d * 86400)) / 3600; + if(d <= 99) + curl_msnprintf(r, rsize, "%2" FMT_OFF_T "d %02" FMT_OFF_T "h", d, h); + else if(d <= 999) + curl_msnprintf(r, rsize, "%6" FMT_OFF_T "d", d); + else { /* more than 999 days */ + curl_off_t m = d / 30; + if(m <= 999) + curl_msnprintf(r, rsize, "%6" FMT_OFF_T "m", m); + else { /* more than 999 months */ + curl_off_t y = d / 365; + if(y <= 99999) + curl_msnprintf(r, rsize, "%6" FMT_OFF_T "y", y); + else + curlx_strcopy(r, rsize, STRCONST(">99999y")); + } + } + } +} + +/* The point of this function would be to return a string of the input data, + but never longer than 6 columns (+ one zero byte). + Add suffix k, M, G when suitable... + + @unittest 1636 +*/ +UNITTEST char *max6out(curl_off_t bytes, char *max6, size_t mlen); +UNITTEST char *max6out(curl_off_t bytes, char *max6, size_t mlen) +{ + /* a signed 64-bit value is 8192 petabytes maximum, shown as + 8.0E (exabytes)*/ + if(bytes < 100000) + curl_msnprintf(max6, mlen, "%6" CURL_FORMAT_CURL_OFF_T, bytes); + else { + const char unit[] = { 'k', 'M', 'G', 'T', 'P', 'E', 0 }; + int k = 0; + curl_off_t nbytes; + curl_off_t rest; + do { + nbytes = bytes / 1024; + if(nbytes < 1000) + break; + bytes = nbytes; + k++; + DEBUGASSERT(unit[k]); + } while(unit[k]); + rest = bytes % 1024; + if(nbytes <= 99) + /* xx.yyU */ + curl_msnprintf(max6, mlen, "%2" CURL_FORMAT_CURL_OFF_T + ".%02" CURL_FORMAT_CURL_OFF_T "%c", nbytes, + rest * 100 / 1024, unit[k]); + else + /* xxx.yU */ + curl_msnprintf(max6, mlen, "%3" CURL_FORMAT_CURL_OFF_T + ".%" CURL_FORMAT_CURL_OFF_T "%c", nbytes, + rest * 10 / 1024, unit[k]); + } + return max6; +} +#endif + +static void pgrs_speedinit(struct Curl_easy *data) +{ + memset(&data->state.keeps_speed, 0, sizeof(struct curltime)); +} + +/* + * @unittest 1606 + */ +UNITTEST CURLcode pgrs_speedcheck(struct Curl_easy *data, + const struct curltime *pnow); +UNITTEST CURLcode pgrs_speedcheck(struct Curl_easy *data, + const struct curltime *pnow) +{ + if(!data->set.low_speed_time || !data->set.low_speed_limit || + Curl_xfer_recv_is_paused(data) || Curl_xfer_send_is_paused(data)) + /* A paused transfer is not qualified for speed checks */ + return CURLE_OK; + + if(data->progress.current_speed >= 0) { + if(data->progress.current_speed < data->set.low_speed_limit) { + if(!data->state.keeps_speed.tv_sec) + /* under the limit at this moment */ + data->state.keeps_speed = *pnow; + else { + /* how long has it been under the limit */ + timediff_t howlong = + curlx_ptimediff_ms(pnow, &data->state.keeps_speed); + + if(howlong >= data->set.low_speed_time * 1000) { + /* too long */ + failf(data, "Operation too slow. Less than %" FMT_OFF_T + " bytes/sec transferred the last %u seconds", + data->set.low_speed_limit, data->set.low_speed_time); + return CURLE_OPERATION_TIMEDOUT; + } + } + } + else + /* faster right now */ + data->state.keeps_speed.tv_sec = 0; + } + + /* since low speed limit is enabled, set the expire timer to make this + connection's speed get checked again in a second */ + Curl_expire(data, 1000, EXPIRE_SPEEDCHECK); + + return CURLE_OK; +} + +const struct curltime *Curl_pgrs_now(struct Curl_easy *data) +{ + struct curltime *pnow = data->multi ? + &data->multi->now : &data->progress.now; + curlx_pnow(pnow); + return pnow; +} + +/* + New proposed interface, 9th of February 2000: + + pgrsStartNow() - sets start time + pgrsSetDownloadSize(x) - known expected download size + pgrsSetUploadSize(x) - known expected upload size + pgrsSetDownloadCounter() - amount of data currently downloaded + pgrsSetUploadCounter() - amount of data currently uploaded + pgrsUpdate() - show progress + pgrsDone() - transfer complete +*/ + +int Curl_pgrsDone(struct Curl_easy *data) +{ + int rc; + data->progress.lastshow = 0; + rc = Curl_pgrsUpdate(data); /* the final (forced) update */ + if(rc) + return rc; + + if(!data->progress.hide && !data->progress.callback) + /* only output if we do not use a progress callback and we are not + * hidden */ + curl_mfprintf(data->set.err, "\n"); + + return 0; +} + +void Curl_pgrsReset(struct Curl_easy *data) +{ + Curl_pgrsSetUploadCounter(data, 0); + data->progress.dl.cur_size = 0; + Curl_pgrsSetUploadSize(data, -1); + Curl_pgrsSetDownloadSize(data, -1); + data->progress.speeder_c = 0; /* reset speed records */ + data->progress.deliver = 0; + pgrs_speedinit(data); +} + +/* reset the known transfer sizes */ +void Curl_pgrsResetTransferSizes(struct Curl_easy *data) +{ + Curl_pgrsSetDownloadSize(data, -1); + Curl_pgrsSetUploadSize(data, -1); +} + +void Curl_pgrsRecvPause(struct Curl_easy *data, bool enable) +{ + if(!enable) { + data->progress.speeder_c = 0; /* reset speed records */ + pgrs_speedinit(data); /* reset low speed measurements */ + } +} + +void Curl_pgrsSendPause(struct Curl_easy *data, bool enable) +{ + if(!enable) { + data->progress.speeder_c = 0; /* reset speed records */ + pgrs_speedinit(data); /* reset low speed measurements */ + } +} + +#ifdef CURLVERBOSE +static const char * const pgrs_timer_names[] = { + "PGRS-NONE", + "PGRS-STARTOP", + "PGRS-STARTSINGLE", + "PGRS-POSTQUEUE", + "PGRS-NAMELOOKUP", + "PGRS-CONNECT", + "PGRS-APPCONNECT", + "PGRS-PRETRANSFER", + "PGRS-STARTTRANSFER", + "PGRS-POSTRANSFER", + "PGRS-STARTACCEPT", + "PGRS-REDIRECT", +}; + +static const char *pgrs_timer_name(timerid timer) +{ + if((size_t)timer < CURL_ARRAYSIZE(pgrs_timer_names)) + return pgrs_timer_names[(size_t)timer]; + return "?"; +} +#endif /* CURLVERBOSE */ + +/* + * Curl_pgrsTimeWas(). Store the timestamp time at the given label. + */ +void Curl_pgrsTimeWas(struct Curl_easy *data, timerid timer, + struct curltime timestamp) +{ + timediff_t *delta = NULL; + + switch(timer) { + default: + case TIMER_NONE: + /* mistake filter */ + break; + case TIMER_STARTOP: + /* This is set at the start of a transfer */ + data->progress.t_startop = timestamp; + data->progress.t_startqueue = timestamp; + data->progress.t_postqueue = 0; + break; + case TIMER_STARTSINGLE: + /* This is set at the start of each single transfer */ + data->progress.t_startsingle = timestamp; + data->progress.is_t_startransfer_set = FALSE; + break; + case TIMER_POSTQUEUE: + /* Queue time is accumulative from all involved redirects */ + data->progress.t_postqueue += + curlx_ptimediff_us(×tamp, &data->progress.t_startqueue); + break; + case TIMER_STARTACCEPT: + data->progress.t_acceptdata = timestamp; + break; + case TIMER_NAMELOOKUP: + delta = &data->progress.t_nslookup; + break; + case TIMER_CONNECT: + delta = &data->progress.t_connect; + break; + case TIMER_APPCONNECT: + delta = &data->progress.t_appconnect; + break; + case TIMER_PRETRANSFER: + delta = &data->progress.t_pretransfer; + break; + case TIMER_STARTTRANSFER: + /* prevent updating t_starttransfer unless: + * 1. this is the first time we are setting t_starttransfer + * 2. a redirect has occurred since the last time t_starttransfer was set + * This prevents repeated invocations of the function from incorrectly + * changing the t_starttransfer time. + */ + if(data->progress.is_t_startransfer_set) { + CURL_TRC_M(data, "[%s] ignored", pgrs_timer_name(timer)); + return; + } + data->progress.is_t_startransfer_set = TRUE; + delta = &data->progress.t_starttransfer; + break; + case TIMER_POSTRANSFER: + delta = &data->progress.t_posttransfer; + break; + case TIMER_REDIRECT: + data->progress.t_redirect = curlx_ptimediff_us(×tamp, + &data->progress.start); + data->progress.t_startqueue = timestamp; + break; + } + if(delta) { + timediff_t us = curlx_ptimediff_us(×tamp, + &data->progress.t_startsingle); + if(us < 1) + us = 1; /* make sure at least one microsecond passed */ + *delta += us; + CURL_TRC_M(data, "[%s] added %" FMT_TIMEDIFF_T "ns", + pgrs_timer_name(timer), us); + } + else + CURL_TRC_M(data, "[%s] set", pgrs_timer_name(timer)); +} + +/* + * Curl_pgrsTime(). Store the current time at the given label. This fetches a + * fresh "now" and returns it. + * + * @unittest: 1399 + */ +void Curl_pgrsTime(struct Curl_easy *data, timerid timer) +{ + Curl_pgrsTimeWas(data, timer, *Curl_pgrs_now(data)); +} + +void Curl_pgrsStartNow(struct Curl_easy *data) +{ + struct Progress *p = &data->progress; + + p->speeder_c = 0; /* reset the progress meter display */ + p->start = *Curl_pgrs_now(data); + p->is_t_startransfer_set = FALSE; + p->dl.cur_size = 0; + p->ul.cur_size = 0; + /* the sizes are unknown at start */ + p->dl_size_known = FALSE; + p->ul_size_known = FALSE; +} + +/* check that the 'delta' amount of bytes are okay to deliver to the + application, or return error if not. */ +CURLcode Curl_pgrs_deliver_check(struct Curl_easy *data, size_t delta) +{ + if(data->set.max_filesize && + ((curl_off_t)delta > data->set.max_filesize - data->progress.deliver)) { + failf(data, "Would have exceeded max file size"); + return CURLE_FILESIZE_EXCEEDED; + } + return CURLE_OK; +} + +/* this counts how much data is delivered to the application, which + in compressed cases may differ from downloaded amount */ +void Curl_pgrs_deliver_inc(struct Curl_easy *data, size_t delta) +{ + data->progress.deliver += delta; +} + +void Curl_pgrs_download_inc(struct Curl_easy *data, size_t delta) +{ + if(delta) { + data->progress.dl.cur_size += delta; + Curl_rlimit_drain(&data->progress.dl.rlimit, delta, Curl_pgrs_now(data)); + } +} + +void Curl_pgrs_upload_inc(struct Curl_easy *data, size_t delta) +{ + if(delta) { + data->progress.ul.cur_size += delta; + Curl_rlimit_drain(&data->progress.ul.rlimit, delta, Curl_pgrs_now(data)); + } +} + +/* + * Set the number of uploaded bytes so far. + */ +void Curl_pgrsSetUploadCounter(struct Curl_easy *data, curl_off_t size) +{ + data->progress.ul.cur_size = size; +} + +void Curl_pgrsSetDownloadSize(struct Curl_easy *data, curl_off_t size) +{ + if(size >= 0) { + data->progress.dl.total_size = size; + data->progress.dl_size_known = TRUE; + } + else { + data->progress.dl.total_size = 0; + data->progress.dl_size_known = FALSE; + } +} + +void Curl_pgrsSetUploadSize(struct Curl_easy *data, curl_off_t size) +{ + if(size >= 0) { + data->progress.ul.total_size = size; + data->progress.ul_size_known = TRUE; + } + else { + data->progress.ul.total_size = 0; + data->progress.ul_size_known = FALSE; + } +} + +void Curl_pgrsEarlyData(struct Curl_easy *data, curl_off_t sent) +{ + data->progress.earlydata_sent = sent; +} + +/* returns the average speed in bytes / second */ +static curl_off_t trspeed(curl_off_t size, /* number of bytes */ + curl_off_t us) /* microseconds */ +{ + if(us < 1) + return size * 1000000; + else if(size < CURL_OFF_T_MAX / 1000000) + return (size * 1000000) / us; + else if(us >= 1000000) + return size / (us / 1000000); + else + return CURL_OFF_T_MAX; +} + +/* returns TRUE if it is time to show the progress meter */ +static bool progress_calc(struct Curl_easy *data, + const struct curltime *pnow) +{ + struct Progress * const p = &data->progress; + int i_next, i_oldest, i_latest; + timediff_t duration_us; + curl_off_t amount; + + /* The time spent so far (from the start) in microseconds */ + p->timespent = curlx_ptimediff_us(pnow, &p->start); + p->dl.speed = trspeed(p->dl.cur_size, p->timespent); + p->ul.speed = trspeed(p->ul.cur_size, p->timespent); + + if(!p->speeder_c) { /* no previous record exists */ + p->speed_amount[0] = p->dl.cur_size + p->ul.cur_size; + p->speed_time[0] = *pnow; + p->speeder_c++; + /* use the overall average at the start */ + p->current_speed = p->ul.speed + p->dl.speed; + p->lastshow = pnow->tv_sec; + return TRUE; + } + /* We have at least one record now. Where to put the next and + * where is the latest one? */ + i_next = p->speeder_c % CURL_SPEED_RECORDS; + i_latest = (i_next > 0) ? (i_next - 1) : (CURL_SPEED_RECORDS - 1); + + /* Make a new record only when some time has passed. + * Too frequent calls otherwise ruin the history. */ + if(curlx_ptimediff_ms(pnow, &p->speed_time[i_latest]) >= 1000) { + p->speeder_c++; + i_latest = i_next; + p->speed_amount[i_latest] = p->dl.cur_size + p->ul.cur_size; + p->speed_time[i_latest] = *pnow; + } + else if(data->req.done) { + /* When a transfer is done, and we did not have a current speed + * already, update the last record. Otherwise, stay at the speed + * we have. The last chunk of data, when rate limiting, would increase + * reported speed since it no longer measures a full second. */ + if(!p->current_speed) { + p->speed_amount[i_latest] = p->dl.cur_size + p->ul.cur_size; + p->speed_time[i_latest] = *pnow; + } + } + else { + /* transfer ongoing, wait for more time to pass. */ + return FALSE; + } + + i_oldest = (p->speeder_c < CURL_SPEED_RECORDS) ? 0 : + ((i_latest + 1) % CURL_SPEED_RECORDS); + + /* How much we transferred between oldest and current records */ + amount = p->speed_amount[i_latest] - p->speed_amount[i_oldest]; + /* How long this took */ + duration_us = curlx_ptimediff_us(&p->speed_time[i_latest], + &p->speed_time[i_oldest]); + if(duration_us <= 0) + duration_us = 1; + + if(amount > (CURL_OFF_T_MAX / 1000000)) { + /* the 'amount' value is bigger than would fit in 64 bits if + multiplied with 1000000, so we use the double math for this */ + p->current_speed = + (curl_off_t)(((double)amount * 1000000.0) / (double)duration_us); + } + else { + p->current_speed = amount * 1000000 / duration_us; + } + + if((p->lastshow == pnow->tv_sec) && !data->req.done) + return FALSE; + p->lastshow = pnow->tv_sec; + return TRUE; +} + +#ifndef CURL_DISABLE_PROGRESS_METER + +struct pgrs_estimate { + curl_off_t secs; + curl_off_t percent; +}; + +static curl_off_t pgrs_est_percent(curl_off_t total, curl_off_t cur) +{ + if(total > 10000) + return cur / (total / 100); + else if(total > 0) + return (cur * 100) / total; + return 0; +} + +static void pgrs_estimates(struct pgrs_dir *d, + bool total_known, + struct pgrs_estimate *est) +{ + est->secs = 0; + est->percent = 0; + if(total_known && (d->speed > 0)) { + est->secs = d->total_size / d->speed; + est->percent = pgrs_est_percent(d->total_size, d->cur_size); + } +} + +static void progress_meter(struct Curl_easy *data) +{ + struct Progress *p = &data->progress; + char max6[6][7]; + struct pgrs_estimate dl_estm; + struct pgrs_estimate ul_estm; + struct pgrs_estimate total_estm; + curl_off_t total_cur_size; + curl_off_t total_expected_size; + curl_off_t dl_size; + char time_left[8]; + char time_total[8]; + char time_spent[8]; + curl_off_t cur_secs = (curl_off_t)p->timespent / 1000000; /* seconds */ + + if(!p->headers_out) { + if(data->state.resume_from) { + curl_mfprintf(data->set.err, + "** Resuming transfer from byte position %" FMT_OFF_T "\n", + data->state.resume_from); + } + curl_mfprintf(data->set.err, + " %% Total %% Received %% Xferd Average Speed " + "Time Time Time Current\n" + " Dload Upload " + "Total Spent Left Speed\n"); + p->headers_out = TRUE; /* headers are shown */ + } + + /* Figure out the estimated time of arrival for upload and download */ + pgrs_estimates(&p->ul, (bool)p->ul_size_known, &ul_estm); + pgrs_estimates(&p->dl, (bool)p->dl_size_known, &dl_estm); + + /* Since both happen at the same time, total expected duration is max. */ + total_estm.secs = CURLMAX(ul_estm.secs, dl_estm.secs); + /* create the three time strings */ + time2str(time_left, sizeof(time_left), + total_estm.secs > 0 ? (total_estm.secs - cur_secs) : 0); + time2str(time_total, sizeof(time_total), total_estm.secs); + time2str(time_spent, sizeof(time_spent), cur_secs); + + /* Get the total amount of data expected to get transferred */ + total_expected_size = p->ul_size_known ? p->ul.total_size : p->ul.cur_size; + + dl_size = p->dl_size_known ? p->dl.total_size : p->dl.cur_size; + + /* integer overflow check */ + if((CURL_OFF_T_MAX - total_expected_size) < dl_size) + total_expected_size = CURL_OFF_T_MAX; /* capped */ + else + total_expected_size += dl_size; + + /* We have transferred this much so far */ + total_cur_size = p->dl.cur_size + p->ul.cur_size; + + /* Get the percentage of data transferred so far */ + total_estm.percent = pgrs_est_percent(total_expected_size, total_cur_size); + + curl_mfprintf(data->set.err, + "\r" + "%3" FMT_OFF_T " %s " + "%3" FMT_OFF_T " %s " + "%3" FMT_OFF_T " %s %s %s %s %s %s %s", + total_estm.percent, /* 3 letters */ /* total % */ + max6out(total_expected_size, max6[2], + sizeof(max6[2])), /* total size */ + dl_estm.percent, /* 3 letters */ /* rcvd % */ + max6out(p->dl.cur_size, max6[0], + sizeof(max6[0])), /* rcvd size */ + ul_estm.percent, /* 3 letters */ /* xfer % */ + max6out(p->ul.cur_size, max6[1], + sizeof(max6[1])), /* xfer size */ + max6out(p->dl.speed, max6[3], + sizeof(max6[3])), /* avrg dl speed */ + max6out(p->ul.speed, max6[4], + sizeof(max6[4])), /* avrg ul speed */ + time_total, /* 7 letters */ /* total time */ + time_spent, /* 7 letters */ /* time spent */ + time_left, /* 7 letters */ /* time left */ + max6out(p->current_speed, max6[5], + sizeof(max6[5])) /* current speed */ + ); + + /* we flush the output stream to make it appear as soon as possible */ + fflush(data->set.err); +} +#else /* CURL_DISABLE_PROGRESS_METER */ +#define progress_meter(x) Curl_nop_stmt +#endif + +/* + * Curl_pgrsUpdate() returns 0 for success or the value returned by the + * progress callback! + */ +static CURLcode pgrsupdate(struct Curl_easy *data, bool showprogress) +{ + if(!data->progress.hide) { + int rc; + if(data->set.fxferinfo) { + /* There is a callback set, call that */ + Curl_set_in_callback(data, TRUE); + rc = data->set.fxferinfo(data->set.progress_client, + data->progress.dl.total_size, + data->progress.dl.cur_size, + data->progress.ul.total_size, + data->progress.ul.cur_size); + Curl_set_in_callback(data, FALSE); + if(rc != CURL_PROGRESSFUNC_CONTINUE) { + if(rc) { + failf(data, "Callback aborted"); + return CURLE_ABORTED_BY_CALLBACK; + } + return CURLE_OK; + } + } + else if(data->set.fprogress) { + /* The older deprecated callback is set, call that */ + Curl_set_in_callback(data, TRUE); + rc = data->set.fprogress(data->set.progress_client, + (double)data->progress.dl.total_size, + (double)data->progress.dl.cur_size, + (double)data->progress.ul.total_size, + (double)data->progress.ul.cur_size); + Curl_set_in_callback(data, FALSE); + if(rc != CURL_PROGRESSFUNC_CONTINUE) { + if(rc) { + failf(data, "Callback aborted"); + return CURLE_ABORTED_BY_CALLBACK; + } + return CURLE_OK; + } + } + + if(showprogress) + progress_meter(data); + } + + return CURLE_OK; +} + +static CURLcode pgrs_update(struct Curl_easy *data, + const struct curltime *pnow) +{ + bool showprogress = progress_calc(data, pnow); + return pgrsupdate(data, showprogress); +} + +CURLcode Curl_pgrsUpdate(struct Curl_easy *data) +{ + return pgrs_update(data, Curl_pgrs_now(data)); +} + +CURLcode Curl_pgrsCheck(struct Curl_easy *data) +{ + CURLcode result; + + result = pgrs_update(data, Curl_pgrs_now(data)); + if(!result && !data->req.done) + result = pgrs_speedcheck(data, Curl_pgrs_now(data)); + return result; +} + +/* + * Update all progress, do not do progress meter/callbacks. + */ +void Curl_pgrsUpdate_nometer(struct Curl_easy *data) +{ + (void)progress_calc(data, Curl_pgrs_now(data)); +} + +void Curl_pgrsCompleted(struct Curl_easy *data) +{ + struct Progress * const p = &data->progress; + p->timespent = curlx_ptimediff_us(Curl_pgrs_now(data), &p->start); +} diff --git a/3rdparty/curl-8.21.0/lib/progress.h b/3rdparty/curl-8.21.0/lib/progress.h new file mode 100644 index 0000000000..1f2a4e71c3 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/progress.h @@ -0,0 +1,88 @@ +#ifndef HEADER_CURL_PROGRESS_H +#define HEADER_CURL_PROGRESS_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curlx/timeval.h" + +struct Curl_easy; + +typedef enum { + TIMER_NONE, + TIMER_STARTOP, + TIMER_STARTSINGLE, /* start of transfer, might get queued */ + TIMER_POSTQUEUE, /* start, immediately after dequeue */ + TIMER_NAMELOOKUP, + TIMER_CONNECT, + TIMER_APPCONNECT, + TIMER_PRETRANSFER, + TIMER_STARTTRANSFER, + TIMER_POSTRANSFER, + TIMER_STARTACCEPT, + TIMER_REDIRECT, + TIMER_LAST /* must be last */ +} timerid; + +/* Get the current timestamp of the transfer */ +const struct curltime *Curl_pgrs_now(struct Curl_easy *data); + +int Curl_pgrsDone(struct Curl_easy *data); +void Curl_pgrsStartNow(struct Curl_easy *data); +void Curl_pgrsSetDownloadSize(struct Curl_easy *data, curl_off_t size); +void Curl_pgrsSetUploadSize(struct Curl_easy *data, curl_off_t size); +CURLcode Curl_pgrs_deliver_check(struct Curl_easy *data, size_t delta); +void Curl_pgrs_deliver_inc(struct Curl_easy *data, size_t delta); +void Curl_pgrs_download_inc(struct Curl_easy *data, size_t delta); +void Curl_pgrs_upload_inc(struct Curl_easy *data, size_t delta); +void Curl_pgrsSetUploadCounter(struct Curl_easy *data, curl_off_t size); + +/* perform progress update, invoking callbacks at intervals */ +CURLcode Curl_pgrsUpdate(struct Curl_easy *data); +/* perform progress update, no callbacks invoked */ +void Curl_pgrsUpdate_nometer(struct Curl_easy *data); +/* perform progress update with callbacks and speed checks */ +CURLcode Curl_pgrsCheck(struct Curl_easy *data); + +/* Inform progress/speedcheck about receive/send pausing */ +void Curl_pgrsRecvPause(struct Curl_easy *data, bool enable); +void Curl_pgrsSendPause(struct Curl_easy *data, bool enable); + +/* Reset sizes and counters for up- and download. */ +void Curl_pgrsReset(struct Curl_easy *data); +/* Reset sizes for up- and download. */ +void Curl_pgrsResetTransferSizes(struct Curl_easy *data); + +void Curl_pgrsTime(struct Curl_easy *data, timerid timer); +/** + * Update progress timer with the elapsed time from its start to `timestamp`. + * This allows updating timers later and is used by happy eyeballing, where + * we only want to record the winner's times. + */ +void Curl_pgrsTimeWas(struct Curl_easy *data, timerid timer, + struct curltime timestamp); + +void Curl_pgrsEarlyData(struct Curl_easy *data, curl_off_t sent); + +void Curl_pgrsCompleted(struct Curl_easy *data); + +#endif /* HEADER_CURL_PROGRESS_H */ diff --git a/3rdparty/curl-8.21.0/lib/protocol.c b/3rdparty/curl-8.21.0/lib/protocol.c new file mode 100644 index 0000000000..8d57c058c6 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/protocol.c @@ -0,0 +1,536 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "protocol.h" +#include "strcase.h" + +#include "dict.h" +#include "file.h" +#include "ftp.h" +#include "gopher.h" +#include "http.h" +#include "imap.h" +#include "curl_ldap.h" +#include "mqtt.h" +#include "pop3.h" +#include "rtsp.h" +#include "smb.h" +#include "smtp.h" +#include "telnet.h" +#include "tftp.h" +#include "ws.h" +#include "vssh/ssh.h" + + +/* All URI schemes known to libcurl, but not necessarily implemented + * by protocol handlers. */ +const struct Curl_scheme Curl_scheme_dict = { + "dict", /* scheme */ +#ifdef CURL_DISABLE_DICT + ZERO_NULL, +#else + &Curl_protocol_dict, +#endif + CURLPROTO_DICT, /* protocol */ + CURLPROTO_DICT, /* family */ + PROTOPT_NONE | PROTOPT_NOURLQUERY, /* flags */ + PORT_DICT, /* defport */ +}; + +const struct Curl_scheme Curl_scheme_file = { + "file", /* scheme */ +#ifdef CURL_DISABLE_FILE + ZERO_NULL, +#else + &Curl_protocol_file, +#endif + CURLPROTO_FILE, /* protocol */ + CURLPROTO_FILE, /* family */ + PROTOPT_NONETWORK | PROTOPT_NOURLQUERY, /* flags */ + 0 /* defport */ +}; + +const struct Curl_scheme Curl_scheme_ftp = { + "ftp", /* scheme */ +#ifdef CURL_DISABLE_FTP + ZERO_NULL, +#else + &Curl_protocol_ftp, +#endif + CURLPROTO_FTP, /* protocol */ + CURLPROTO_FTP, /* family */ + PROTOPT_DUAL | PROTOPT_CLOSEACTION | PROTOPT_NEEDSPWD | + PROTOPT_NOURLQUERY | PROTOPT_PROXY_AS_HTTP | + PROTOPT_WILDCARD | PROTOPT_SSL_REUSE | + PROTOPT_CONN_REUSE, /* flags */ + PORT_FTP, /* defport */ +}; + +const struct Curl_scheme Curl_scheme_ftps = { + "ftps", /* scheme */ +#if defined(CURL_DISABLE_FTP) || !defined(USE_SSL) + ZERO_NULL, +#else + &Curl_protocol_ftp, +#endif + CURLPROTO_FTPS, /* protocol */ + CURLPROTO_FTP, /* family */ + PROTOPT_SSL | PROTOPT_DUAL | PROTOPT_CLOSEACTION | + PROTOPT_NEEDSPWD | PROTOPT_NOURLQUERY | PROTOPT_WILDCARD | + PROTOPT_CONN_REUSE, /* flags */ + PORT_FTPS, /* defport */ +}; + +const struct Curl_scheme Curl_scheme_gopher = { + "gopher", /* scheme */ +#ifdef CURL_DISABLE_GOPHER + ZERO_NULL, +#else + &Curl_protocol_gopher, +#endif + CURLPROTO_GOPHER, /* protocol */ + CURLPROTO_GOPHER, /* family */ + PROTOPT_NONE, /* flags */ + PORT_GOPHER, /* defport */ +}; + +const struct Curl_scheme Curl_scheme_gophers = { + "gophers", /* scheme */ +#if defined(CURL_DISABLE_GOPHER) || !defined(USE_SSL) + ZERO_NULL, +#else + &Curl_protocol_gophers, +#endif + CURLPROTO_GOPHERS, /* protocol */ + CURLPROTO_GOPHER, /* family */ + PROTOPT_SSL, /* flags */ + PORT_GOPHER, /* defport */ +}; + +const struct Curl_scheme Curl_scheme_http = { + "http", /* scheme */ +#ifdef CURL_DISABLE_HTTP + ZERO_NULL, +#else + &Curl_protocol_http, +#endif + CURLPROTO_HTTP, /* protocol */ + CURLPROTO_HTTP, /* family */ + PROTOPT_CREDSPERREQUEST | /* flags */ + PROTOPT_USERPWDCTRL | PROTOPT_CONN_REUSE, + PORT_HTTP, /* defport */ +}; + +const struct Curl_scheme Curl_scheme_https = { + "https", /* scheme */ +#if defined(CURL_DISABLE_HTTP) || !defined(USE_SSL) + ZERO_NULL, +#else + &Curl_protocol_http, +#endif + CURLPROTO_HTTPS, /* protocol */ + CURLPROTO_HTTP, /* family */ + PROTOPT_SSL | PROTOPT_CREDSPERREQUEST | PROTOPT_ALPN | /* flags */ + PROTOPT_USERPWDCTRL | PROTOPT_CONN_REUSE | + PROTOPT_HTTP_PROXY_TUNNEL, + PORT_HTTPS, /* defport */ +}; + +const struct Curl_scheme Curl_scheme_imap = { + "imap", /* scheme */ +#ifdef CURL_DISABLE_IMAP + ZERO_NULL, +#else + &Curl_protocol_imap, +#endif + CURLPROTO_IMAP, /* protocol */ + CURLPROTO_IMAP, /* family */ + PROTOPT_CLOSEACTION | /* flags */ + PROTOPT_URLOPTIONS | PROTOPT_SSL_REUSE | + PROTOPT_CONN_REUSE, + PORT_IMAP, /* defport */ +}; + +const struct Curl_scheme Curl_scheme_imaps = { + "imaps", /* scheme */ +#if defined(CURL_DISABLE_IMAP) || !defined(USE_SSL) + ZERO_NULL, +#else + &Curl_protocol_imap, +#endif + CURLPROTO_IMAPS, /* protocol */ + CURLPROTO_IMAP, /* family */ + PROTOPT_CLOSEACTION | PROTOPT_SSL | /* flags */ + PROTOPT_URLOPTIONS | PROTOPT_CONN_REUSE, + PORT_IMAPS, /* defport */ +}; + +const struct Curl_scheme Curl_scheme_ldap = { + "ldap", /* scheme */ +#ifdef CURL_DISABLE_LDAP + ZERO_NULL, +#else + &Curl_protocol_ldap, +#endif + CURLPROTO_LDAP, /* protocol */ + CURLPROTO_LDAP, /* family */ + PROTOPT_SSL_REUSE, /* flags */ + PORT_LDAP, /* defport */ +}; + +const struct Curl_scheme Curl_scheme_ldaps = { + "ldaps", /* scheme */ +#if defined(CURL_DISABLE_LDAP) || !defined(HAVE_LDAP_SSL) + ZERO_NULL, +#else + &Curl_protocol_ldap, +#endif + CURLPROTO_LDAPS, /* protocol */ + CURLPROTO_LDAP, /* family */ + PROTOPT_SSL, /* flags */ + PORT_LDAPS, /* defport */ +}; + +const struct Curl_scheme Curl_scheme_mqtt = { + "mqtt", /* scheme */ +#ifdef CURL_DISABLE_MQTT + ZERO_NULL, +#else + &Curl_protocol_mqtt, +#endif + CURLPROTO_MQTT, /* protocol */ + CURLPROTO_MQTT, /* family */ + PROTOPT_NONE, /* flags */ + PORT_MQTT, /* defport */ +}; + +const struct Curl_scheme Curl_scheme_mqtts = { + "mqtts", /* scheme */ +#if defined(CURL_DISABLE_MQTT) || !defined(USE_SSL) + ZERO_NULL, +#else + &Curl_protocol_mqtts, +#endif + CURLPROTO_MQTTS, /* protocol */ + CURLPROTO_MQTT, /* family */ + PROTOPT_SSL, /* flags */ + PORT_MQTTS, /* defport */ +}; + +const struct Curl_scheme Curl_scheme_pop3 = { + "pop3", /* scheme */ +#ifdef CURL_DISABLE_POP3 + ZERO_NULL, +#else + &Curl_protocol_pop3, +#endif + CURLPROTO_POP3, /* protocol */ + CURLPROTO_POP3, /* family */ + PROTOPT_CLOSEACTION | PROTOPT_NOURLQUERY | /* flags */ + PROTOPT_URLOPTIONS | PROTOPT_SSL_REUSE | PROTOPT_CONN_REUSE, + PORT_POP3, /* defport */ +}; + +const struct Curl_scheme Curl_scheme_pop3s = { + "pop3s", /* scheme */ +#if defined(CURL_DISABLE_POP3) || !defined(USE_SSL) + ZERO_NULL, +#else + &Curl_protocol_pop3, +#endif + CURLPROTO_POP3S, /* protocol */ + CURLPROTO_POP3, /* family */ + PROTOPT_CLOSEACTION | PROTOPT_SSL | /* flags */ + PROTOPT_NOURLQUERY | PROTOPT_URLOPTIONS | PROTOPT_CONN_REUSE, + PORT_POP3S, /* defport */ +}; + +const struct Curl_scheme Curl_scheme_rtsp = { + "rtsp", /* scheme */ +#ifdef CURL_DISABLE_RTSP + ZERO_NULL, +#else + &Curl_protocol_rtsp, +#endif + CURLPROTO_RTSP, /* protocol */ + CURLPROTO_RTSP, /* family */ + PROTOPT_CONN_REUSE, /* flags */ + PORT_RTSP, /* defport */ +}; + +const struct Curl_scheme Curl_scheme_sftp = { + "sftp", /* scheme */ +#ifndef USE_SSH + NULL, +#else + &Curl_protocol_sftp, +#endif + CURLPROTO_SFTP, /* protocol */ + CURLPROTO_SFTP, /* family */ + PROTOPT_DIRLOCK | PROTOPT_CLOSEACTION | /* flags */ + PROTOPT_NOURLQUERY | PROTOPT_CONN_REUSE, + PORT_SSH /* defport */ +}; + +const struct Curl_scheme Curl_scheme_scp = { + "scp", /* scheme */ +#ifndef USE_SSH + NULL, +#else + &Curl_protocol_scp, +#endif + CURLPROTO_SCP, /* protocol */ + CURLPROTO_SCP, /* family */ + PROTOPT_DIRLOCK | PROTOPT_CLOSEACTION | /* flags */ + PROTOPT_NOURLQUERY | PROTOPT_CONN_REUSE, + PORT_SSH, /* defport */ +}; + +const struct Curl_scheme Curl_scheme_smb = { + "smb", /* scheme */ +#if defined(CURL_ENABLE_SMB) && defined(USE_CURL_NTLM_CORE) + &Curl_protocol_smb, +#else + ZERO_NULL, +#endif + CURLPROTO_SMB, /* protocol */ + CURLPROTO_SMB, /* family */ + PROTOPT_NONE, /* flags */ + PORT_SMB, /* defport */ +}; + +const struct Curl_scheme Curl_scheme_smbs = { + "smbs", /* scheme */ +#if defined(CURL_ENABLE_SMB) && defined(USE_CURL_NTLM_CORE) && defined(USE_SSL) + &Curl_protocol_smb, +#else + ZERO_NULL, +#endif + CURLPROTO_SMBS, /* protocol */ + CURLPROTO_SMB, /* family */ + PROTOPT_SSL, /* flags */ + PORT_SMBS, /* defport */ +}; + +const struct Curl_scheme Curl_scheme_smtp = { + "smtp", /* scheme */ +#ifdef CURL_DISABLE_SMTP + ZERO_NULL, +#else + &Curl_protocol_smtp, +#endif + CURLPROTO_SMTP, /* protocol */ + CURLPROTO_SMTP, /* family */ + PROTOPT_CLOSEACTION | PROTOPT_NOURLQUERY | /* flags */ + PROTOPT_URLOPTIONS | PROTOPT_SSL_REUSE | PROTOPT_CONN_REUSE, + PORT_SMTP, /* defport */ +}; + +const struct Curl_scheme Curl_scheme_smtps = { + "smtps", /* scheme */ +#if defined(CURL_DISABLE_SMTP) || !defined(USE_SSL) + ZERO_NULL, +#else + &Curl_protocol_smtp, +#endif + CURLPROTO_SMTPS, /* protocol */ + CURLPROTO_SMTP, /* family */ + PROTOPT_CLOSEACTION | PROTOPT_SSL | /* flags */ + PROTOPT_NOURLQUERY | PROTOPT_URLOPTIONS | PROTOPT_CONN_REUSE, + PORT_SMTPS, /* defport */ +}; + +const struct Curl_scheme Curl_scheme_socks = { + "socks", /* scheme */ + ZERO_NULL, + CURLPROTO_SOCKS, /* protocol */ + CURLPROTO_SOCKS, /* family */ + PROTOPT_NO_TRANSFER, /* flags */ + PORT_SOCKS, /* defport */ +}; + +const struct Curl_scheme Curl_scheme_socks4 = { + "socks4", /* scheme */ + ZERO_NULL, + CURLPROTO_SOCKS, /* protocol */ + CURLPROTO_SOCKS, /* family */ + PROTOPT_NO_TRANSFER, /* flags */ + PORT_SOCKS, /* defport */ +}; + +const struct Curl_scheme Curl_scheme_socks4a = { + "socks4a", /* scheme */ + ZERO_NULL, + CURLPROTO_SOCKS, /* protocol */ + CURLPROTO_SOCKS, /* family */ + PROTOPT_NO_TRANSFER, /* flags */ + PORT_SOCKS, /* defport */ +}; + +const struct Curl_scheme Curl_scheme_socks5 = { + "socks5", /* scheme */ + ZERO_NULL, + CURLPROTO_SOCKS, /* protocol */ + CURLPROTO_SOCKS, /* family */ + PROTOPT_NO_TRANSFER, /* flags */ + PORT_SOCKS, /* defport */ +}; + +const struct Curl_scheme Curl_scheme_socks5h = { + "socks5h", /* scheme */ + ZERO_NULL, + CURLPROTO_SOCKS, /* protocol */ + CURLPROTO_SOCKS, /* family */ + PROTOPT_NO_TRANSFER, /* flags */ + PORT_SOCKS, /* defport */ +}; + +const struct Curl_scheme Curl_scheme_telnet = { + "telnet", /* scheme */ +#ifdef CURL_DISABLE_TELNET + ZERO_NULL, +#else + &Curl_protocol_telnet, +#endif + CURLPROTO_TELNET, /* protocol */ + CURLPROTO_TELNET, /* family */ + PROTOPT_NONE | PROTOPT_NOURLQUERY, /* flags */ + PORT_TELNET, /* defport */ +}; + +const struct Curl_scheme Curl_scheme_tftp = { + "tftp", /* scheme */ +#ifdef CURL_DISABLE_TFTP + ZERO_NULL, +#else + &Curl_protocol_tftp, +#endif + CURLPROTO_TFTP, /* protocol */ + CURLPROTO_TFTP, /* family */ + PROTOPT_NOTCPPROXY | PROTOPT_NOURLQUERY, /* flags */ + PORT_TFTP, /* defport */ +}; + +const struct Curl_scheme Curl_scheme_ws = { + "ws", /* scheme */ +#if defined(CURL_DISABLE_WEBSOCKETS) || defined(CURL_DISABLE_HTTP) + ZERO_NULL, +#else + &Curl_protocol_ws, +#endif + CURLPROTO_WS, /* protocol */ + CURLPROTO_HTTP, /* family */ + PROTOPT_CREDSPERREQUEST | /* flags */ + PROTOPT_USERPWDCTRL | PROTOPT_HTTP_PROXY_TUNNEL, + PORT_HTTP /* defport */ +}; + +const struct Curl_scheme Curl_scheme_wss = { + "wss", /* scheme */ +#if defined(CURL_DISABLE_WEBSOCKETS) || defined(CURL_DISABLE_HTTP) || \ + !defined(USE_SSL) + ZERO_NULL, +#else + &Curl_protocol_ws, +#endif + CURLPROTO_WSS, /* protocol */ + CURLPROTO_HTTP, /* family */ + PROTOPT_SSL | PROTOPT_CREDSPERREQUEST | /* flags */ + PROTOPT_USERPWDCTRL | PROTOPT_HTTP_PROXY_TUNNEL, + PORT_HTTPS /* defport */ +}; + +/* Returns a struct scheme pointer if the name is a known scheme. Check the + ->run struct field for non-NULL to figure out if an implementation is + present. */ +const struct Curl_scheme *Curl_getn_scheme(const char *scheme, size_t len) +{ + /* table generated by schemetable.c: + 1. gcc schemetable.c && ./a.out + 2. check how small the table gets + 3. tweak the hash algorithm, then rerun from 1 + 4. when the table is good enough + 5. copy the table into this source code + 6. make sure this function uses the same hash function that worked for + schemetable.c + */ + static const struct Curl_scheme * const all_schemes[59] = { NULL, + &Curl_scheme_pop3, NULL, + &Curl_scheme_smtps, + &Curl_scheme_socks, + &Curl_scheme_socks4, + &Curl_scheme_socks5, NULL, NULL, + &Curl_scheme_gophers, + &Curl_scheme_ws, + &Curl_scheme_sftp, + &Curl_scheme_socks4a, + &Curl_scheme_scp, + &Curl_scheme_rtsp, + &Curl_scheme_dict, NULL, NULL, + &Curl_scheme_gopher, NULL, NULL, NULL, + &Curl_scheme_wss, NULL, + &Curl_scheme_smb, NULL, + &Curl_scheme_ldap, + &Curl_scheme_ldaps, + &Curl_scheme_imap, NULL, NULL, NULL, + &Curl_scheme_imaps, + &Curl_scheme_https, + &Curl_scheme_tftp, + &Curl_scheme_telnet, NULL, NULL, NULL, + &Curl_scheme_file, + &Curl_scheme_smtp, NULL, NULL, NULL, NULL, NULL, NULL, NULL, + &Curl_scheme_ftp, + &Curl_scheme_mqtt, NULL, + &Curl_scheme_socks5h, + &Curl_scheme_http, + &Curl_scheme_pop3s, NULL, + &Curl_scheme_mqtts, NULL, + &Curl_scheme_smbs, + &Curl_scheme_ftps, + }; + + if(len && (len <= 7)) { + const char *s = scheme; + size_t l = len; + const struct Curl_scheme *h; + unsigned int c = 443; + while(l) { + c <<= 5; + c += (unsigned int)Curl_raw_tolower(*s); + s++; + l--; + } + + h = all_schemes[c % 59]; + if(h && curl_strnequal(scheme, h->name, len) && !h->name[len]) + return h; + } + return NULL; +} + +const struct Curl_scheme *Curl_get_scheme(const char *scheme) +{ + return Curl_getn_scheme(scheme, strlen(scheme)); +} diff --git a/3rdparty/curl-8.21.0/lib/protocol.h b/3rdparty/curl-8.21.0/lib/protocol.h new file mode 100644 index 0000000000..50e320d0f6 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/protocol.h @@ -0,0 +1,296 @@ +#ifndef HEADER_CURL_PROTOCOL_H +#define HEADER_CURL_PROTOCOL_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +/* This file is for lib internal stuff */ +#include "curl_setup.h" + +struct Curl_easy; +struct connectdata; +struct easy_pollset; + +/* Known protocol default port numbers */ +#define PORT_FTP 21 +#define PORT_FTPS 990 +#define PORT_TELNET 23 +#define PORT_HTTP 80 +#define PORT_HTTPS 443 +#define PORT_DICT 2628 +#define PORT_LDAP 389 +#define PORT_LDAPS 636 +#define PORT_TFTP 69 +#define PORT_SSH 22 +#define PORT_IMAP 143 +#define PORT_IMAPS 993 +#define PORT_POP3 110 +#define PORT_POP3S 995 +#define PORT_SMB 445 +#define PORT_SMBS 445 +#define PORT_SMTP 25 +#define PORT_SMTPS 465 /* sometimes called SSMTP */ +#define PORT_RTSP 554 +#define PORT_GOPHER 70 +#define PORT_SOCKS 1080 +#define PORT_MQTT 1883 +#define PORT_MQTTS 8883 + +/* CURLPROTO_GOPHERS (29) is the highest publicly used protocol bit number, + * the rest are internal information. If we use higher bits we only do this on + * platforms that have a >= 64-bit type and then we use such a type for the + * protocol fields in the scheme definition. + */ +#define CURLPROTO_WS (1L << 30) +#define CURLPROTO_WSS ((curl_prot_t)1 << 31) +#define CURLPROTO_MQTTS (1LL << 32) +#define CURLPROTO_SOCKS (1LL << 33) + +#define CURLPROTO_64ALL ((uint64_t)0xffffffffffffffff) + +/* the default protocols accepting a redirect to */ +#define CURLPROTO_REDIR (CURLPROTO_HTTP | CURLPROTO_HTTPS | CURLPROTO_FTP | \ + CURLPROTO_FTPS) + +typedef curl_off_t curl_prot_t; + +/* This mask is for all the old protocols that are provided and defined in the + public header and shall exclude protocols added since which are not exposed + in the API */ +#define CURLPROTO_MASK 0x3fffffff + +/* Convenience defines for checking protocols or their SSL based version. Each + protocol scheme should only ever have a single CURLPROTO_ in its protocol + field. */ +#define PROTO_FAMILY_HTTP (CURLPROTO_HTTP | CURLPROTO_HTTPS | CURLPROTO_WS | \ + CURLPROTO_WSS) +#define PROTO_FAMILY_FTP (CURLPROTO_FTP | CURLPROTO_FTPS) +#define PROTO_FAMILY_POP3 (CURLPROTO_POP3 | CURLPROTO_POP3S) +#define PROTO_FAMILY_SMB (CURLPROTO_SMB | CURLPROTO_SMBS) +#define PROTO_FAMILY_SMTP (CURLPROTO_SMTP | CURLPROTO_SMTPS) +#define PROTO_FAMILY_SSH (CURLPROTO_SCP | CURLPROTO_SFTP) + +#if !defined(CURL_DISABLE_FTP) || defined(USE_SSH) || \ + !defined(CURL_DISABLE_POP3) +/* these protocols support CURLOPT_DIRLISTONLY */ +#define CURL_LIST_ONLY_PROTOCOL 1 +#endif + +/* When redirecting transfers. */ +typedef enum { + FOLLOW_NONE, /* not used within the function, a placeholder to allow + initing to this */ + FOLLOW_FAKE, /* only records stuff, not actually following */ + FOLLOW_RETRY, /* set if this is a request retry as opposed to a real + redirect following */ + FOLLOW_REDIR /* a full true redirect */ +} followtype; + +typedef enum { + DOMORE_GOBACK = -1, + DOMORE_INCOMPLETE = 0, + DOMORE_DONE = 1 +} domore; + +/* + * Specific protocol handler, an implementation of one or more URI schemes. + */ +struct Curl_protocol { + /* Complement to setup_connection_internals(). This is done before the + transfer "owns" the connection. */ + CURLcode (*setup_connection)(struct Curl_easy *data, + struct connectdata *conn); + + /* These two functions MUST be set to be protocol dependent */ + CURLcode (*do_it)(struct Curl_easy *data, bool *done); + CURLcode (*done)(struct Curl_easy *, CURLcode, bool); + + /* If the curl_do() function is better made in two halves, this + * curl_do_more() function will be called afterwards, if set. For example + * for doing the FTP stuff after the PASV/PORT command. The second + * argument is an output parameter that MUST be set to one of the + * DOMORE_* values: DOMORE_INCOMPLETE if more do_more work remains, + * DOMORE_DONE when the second phase is complete, or DOMORE_GOBACK + * to return to the regular DO/DOING handling. + */ + CURLcode (*do_more)(struct Curl_easy *, domore *); + + /* This function *MAY* be set to a protocol-dependent function that is run + * after the connect() and everything is done, as a step in the connection. + * The 'done' pointer points to a bool that should be set to TRUE if the + * function completes before return. If it does not complete, the caller + * should call the ->connecting() function until it is. + */ + CURLcode (*connect_it)(struct Curl_easy *data, bool *done); + + /* See above. */ + CURLcode (*connecting)(struct Curl_easy *data, bool *done); + CURLcode (*doing)(struct Curl_easy *data, bool *done); + + /* Called from the multi interface during the PROTOCONNECT phase, and it + should then return a proper fd set */ + CURLcode (*proto_pollset)(struct Curl_easy *data, + struct easy_pollset *ps); + + /* Called from the multi interface during the DOING phase, and it should + then return a proper fd set */ + CURLcode (*doing_pollset)(struct Curl_easy *data, + struct easy_pollset *ps); + + /* Called from the multi interface during the DO_MORE phase, and it should + then return a proper fd set */ + CURLcode (*domore_pollset)(struct Curl_easy *data, + struct easy_pollset *ps); + + /* Called from the multi interface during the DO_DONE, PERFORM and + WAITPERFORM phases, and it should then return a proper fd set. Not setting + this will make libcurl use the generic default one. */ + CURLcode (*perform_pollset)(struct Curl_easy *data, + struct easy_pollset *ps); + + /* This function *MAY* be set to a protocol-dependent function that is run + * by the curl_disconnect(), as a step in the disconnection. If the handler + * is called because the connection has been considered dead, + * dead_connection is set to TRUE. The connection is (again) associated with + * the transfer here. + */ + CURLcode (*disconnect)(struct Curl_easy *, struct connectdata *, + bool dead_connection); + + /* If used, this function gets called from transfer.c to + allow the protocol to do extra handling in writing response to + the client. */ + CURLcode (*write_resp)(struct Curl_easy *data, const char *buf, size_t blen, + bool is_eos); + + /* If used, this function gets called from transfer.c to + allow the protocol to do extra handling in writing a single response + header line to the client. */ + CURLcode (*write_resp_hd)(struct Curl_easy *data, + const char *hd, size_t hdlen, bool is_eos); + + /* If used, this function checks for a connection managed by this + protocol and currently not in use, if it should be considered dead. */ + bool (*connection_is_dead)(struct Curl_easy *data, + struct connectdata *conn); + + /* attach() attaches this transfer to this connection */ + void (*attach)(struct Curl_easy *data, struct connectdata *conn); + + /* return CURLE_OK if a redirect to `newurl` should be followed, + CURLE_TOO_MANY_REDIRECTS otherwise. May alter `data` to change + the way the follow request is performed. */ + CURLcode (*follow)(struct Curl_easy *data, const char *newurl, + followtype type); +}; + +#define PROTOPT_NONE 0 /* nothing extra */ +#define PROTOPT_SSL (1 << 0) /* uses SSL */ +#define PROTOPT_DUAL (1 << 1) /* this protocol uses two connections */ +#define PROTOPT_CLOSEACTION (1 << 2) /* need action before socket close */ +/* some protocols will have to call the underlying functions without regard to + what exact state the socket signals. IE even if the socket says "readable", + the send function might need to be called while uploading, or vice versa. +*/ +#define PROTOPT_DIRLOCK (1 << 3) +#define PROTOPT_NONETWORK (1 << 4) /* protocol does not use the network! */ +#define PROTOPT_NEEDSPWD (1 << 5) /* needs a password, and if none is set it + gets a default */ +#define PROTOPT_NOURLQUERY (1 << 6) /* protocol cannot handle + URL query strings (?foo=bar) ! */ +#define PROTOPT_CREDSPERREQUEST (1 << 7) /* requires login credentials per + request instead of per + connection */ +#define PROTOPT_ALPN (1 << 8) /* set ALPN for this */ +/* (1 << 9) was PROTOPT_STREAM, now free */ +#define PROTOPT_URLOPTIONS (1 << 10) /* allow options part in the userinfo + field of the URL */ +#define PROTOPT_PROXY_AS_HTTP (1 << 11) /* allow this non-HTTP scheme over a + HTTP proxy as HTTP proxies may know + this protocol and act as + a gateway */ +#define PROTOPT_WILDCARD (1 << 12) /* protocol supports wildcard matching */ +#define PROTOPT_USERPWDCTRL (1 << 13) /* Allow "control bytes" (< 32 ASCII) in + username and password */ +#define PROTOPT_NOTCPPROXY (1 << 14) /* this protocol cannot proxy over TCP */ +#define PROTOPT_SSL_REUSE (1 << 15) /* this protocol may reuse an existing + SSL connection in the same family + without having PROTOPT_SSL. */ +#define PROTOPT_CONN_REUSE (1 << 16) /* this protocol can reuse connections */ +#define PROTOPT_NO_TRANSFER (1 << 17) /* this protocol is not for transfers */ +#define PROTOPT_HTTP_PROXY_TUNNEL (1 << 18) /* Using this protocol with a + * HTTP proxy requires tunneling */ + +/* Everything about a URI scheme. */ +struct Curl_scheme { + const char *name; /* URL scheme name in lowercase */ + const struct Curl_protocol *run; /* implementation, optional */ + curl_prot_t protocol; /* See CURLPROTO_* - this needs to be the single + specific protocol bit */ + curl_prot_t family; /* single bit for protocol family; the non-TLS name + of the protocol this is */ + uint32_t flags; /* Extra particular characteristics, see PROTOPT_* */ + uint16_t defport; /* Default port. */ +}; + +/* Get scheme definition for a URI scheme name + * @param scheme URI scheme name, case-insensitive + * @return NULL if scheme is not known + */ +const struct Curl_scheme *Curl_get_scheme(const char *scheme); +const struct Curl_scheme *Curl_getn_scheme(const char *scheme, size_t len); + +/* For direct access to a URI scheme */ +extern const struct Curl_scheme Curl_scheme_dict; +extern const struct Curl_scheme Curl_scheme_file; +extern const struct Curl_scheme Curl_scheme_ftp; +extern const struct Curl_scheme Curl_scheme_ftps; +extern const struct Curl_scheme Curl_scheme_gopher; +extern const struct Curl_scheme Curl_scheme_gophers; +extern const struct Curl_scheme Curl_scheme_http; +extern const struct Curl_scheme Curl_scheme_https; +extern const struct Curl_scheme Curl_scheme_imap; +extern const struct Curl_scheme Curl_scheme_imaps; +extern const struct Curl_scheme Curl_scheme_ldap; +extern const struct Curl_scheme Curl_scheme_ldaps; +extern const struct Curl_scheme Curl_scheme_mqtt; +extern const struct Curl_scheme Curl_scheme_mqtts; +extern const struct Curl_scheme Curl_scheme_pop3; +extern const struct Curl_scheme Curl_scheme_pop3s; +extern const struct Curl_scheme Curl_scheme_rtsp; +extern const struct Curl_scheme Curl_scheme_scp; +extern const struct Curl_scheme Curl_scheme_sftp; +extern const struct Curl_scheme Curl_scheme_smb; +extern const struct Curl_scheme Curl_scheme_smbs; +extern const struct Curl_scheme Curl_scheme_smtp; +extern const struct Curl_scheme Curl_scheme_smtps; +extern const struct Curl_scheme Curl_scheme_socks; +extern const struct Curl_scheme Curl_scheme_socks4; +extern const struct Curl_scheme Curl_scheme_socks4a; +extern const struct Curl_scheme Curl_scheme_socks5; +extern const struct Curl_scheme Curl_scheme_socks5h; +extern const struct Curl_scheme Curl_scheme_telnet; +extern const struct Curl_scheme Curl_scheme_tftp; +extern const struct Curl_scheme Curl_scheme_ws; +extern const struct Curl_scheme Curl_scheme_wss; + +#endif /* HEADER_CURL_PROTOCOL_H */ diff --git a/3rdparty/curl-8.21.0/lib/proxy.c b/3rdparty/curl-8.21.0/lib/proxy.c new file mode 100644 index 0000000000..920dc45598 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/proxy.c @@ -0,0 +1,673 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifndef CURL_DISABLE_PROXY + +#include "urldata.h" +#include "curl_trc.h" +#include "protocol.h" +#include "proxy.h" +#include "http_proxy.h" +#include "strcase.h" +#include "url.h" +#include "vauth/vauth.h" +#include "curlx/inet_pton.h" +#include "curlx/strparse.h" + +#ifdef HAVE_NETINET_IN_H +#include +#endif + +#ifdef HAVE_ARPA_INET_H +#include +#endif + +/* + * cidr4_match() returns TRUE if the given IPv4 address is within the + * specified CIDR address range. + * + * @unittest 1614 + */ +UNITTEST bool cidr4_match(const char *ipv4, /* 1.2.3.4 address */ + const char *network, /* 1.2.3.4 address */ + unsigned int bits); +UNITTEST bool cidr4_match(const char *ipv4, /* 1.2.3.4 address */ + const char *network, /* 1.2.3.4 address */ + unsigned int bits) +{ + unsigned int address = 0; + unsigned int check = 0; + + if(bits > 32) + /* strange input */ + return FALSE; + + if(curlx_inet_pton(AF_INET, ipv4, &address) != 1) + return FALSE; + if(curlx_inet_pton(AF_INET, network, &check) != 1) + return FALSE; + + if(bits && (bits != 32)) { + unsigned int mask = 0xffffffff << (32 - bits); + unsigned int haddr = htonl(address); + unsigned int hcheck = htonl(check); +#if 0 + curl_mfprintf(stderr, "Host %s (%x) network %s (%x) " + "bits %u mask %x => %x\n", + ipv4, haddr, network, hcheck, bits, mask, + (haddr ^ hcheck) & mask); +#endif + if((haddr ^ hcheck) & mask) + return FALSE; + return TRUE; + } + return address == check; +} + +/* @unittest 1614 */ +UNITTEST bool cidr6_match(const char *ipv6, const char *network, + unsigned int bits); +UNITTEST bool cidr6_match(const char *ipv6, const char *network, + unsigned int bits) +{ +#ifdef USE_IPV6 + unsigned int bytes; + unsigned int rest; + unsigned char address[16]; + unsigned char check[16]; + + if(!bits) + bits = 128; + + bytes = bits / 8; + rest = bits & 0x07; + if((bytes > 16) || ((bytes == 16) && rest)) + return FALSE; + if(curlx_inet_pton(AF_INET6, ipv6, address) != 1) + return FALSE; + if(curlx_inet_pton(AF_INET6, network, check) != 1) + return FALSE; + if(bytes && memcmp(address, check, bytes)) + return FALSE; + if(rest && ((address[bytes] ^ check[bytes]) & (0xff << (8 - rest)))) + return FALSE; + + return TRUE; +#else + (void)ipv6; + (void)network; + (void)bits; + return FALSE; +#endif +} + +enum nametype { + TYPE_HOST, + TYPE_IPV4, + TYPE_IPV6 +}; + +static bool match_host(const char *token, size_t tokenlen, + const char *name, size_t namelen) +{ + bool match = FALSE; + + /* ignore trailing dots in the token to check */ + if(token[tokenlen - 1] == '.') + tokenlen--; + + if(tokenlen && (*token == '.')) { + /* ignore leading token dot as well */ + token++; + tokenlen--; + } + /* A: example.com matches 'example.com' + B: www.example.com matches 'example.com' + C: nonexample.com DOES NOT match 'example.com' + */ + if(tokenlen == namelen) + /* case A, exact match */ + match = curl_strnequal(token, name, namelen); + else if(tokenlen < namelen) { + /* case B, tailmatch domain */ + match = (name[namelen - tokenlen - 1] == '.') && + curl_strnequal(token, name + (namelen - tokenlen), tokenlen); + } + /* case C passes through, not a match */ + return match; +} + +static bool match_ip(int type, const char *token, size_t tokenlen, + const char *name) +{ + char *slash; + unsigned int bits = 0; + char checkip[128]; + if(tokenlen >= sizeof(checkip)) + /* this cannot match */ + return FALSE; + /* copy the check name to a temp buffer */ + memcpy(checkip, token, tokenlen); + checkip[tokenlen] = 0; + + slash = strchr(checkip, '/'); + /* if the slash is part of this token, use it */ + if(slash) { + curl_off_t value; + const char *p = &slash[1]; + if(curlx_str_number(&p, &value, 128) || *p) + return FALSE; + /* a too large value is rejected in the cidr function below */ + bits = (unsigned int)value; + *slash = 0; /* null-terminate there */ + } + if(type == TYPE_IPV6) + return cidr6_match(name, checkip, bits); + else + return cidr4_match(name, checkip, bits); +} + +/**************************************************************** + * Checks if the host is in the noproxy list. returns TRUE if it matches and + * therefore the proxy should NOT be used. + ****************************************************************/ +/* @unittest 1614 */ +UNITTEST bool proxy_check_noproxy(const char *name, const char *no_proxy); +UNITTEST bool proxy_check_noproxy(const char *name, const char *no_proxy) +{ + /* + * If we do not have a hostname at all, like for example with a FILE + * transfer, we have nothing to interrogate the noproxy list with. + */ + if(!name || name[0] == '\0') + return FALSE; + + /* no_proxy=domain1.dom,host.domain2.dom + * (a comma-separated list of hosts which should + * not be proxied, or an asterisk to override + * all proxy variables) + */ + if(no_proxy && no_proxy[0]) { + const char *p = no_proxy; + size_t namelen; + char address[16]; + enum nametype type = TYPE_HOST; + if(!strcmp("*", no_proxy)) + return TRUE; + + /* NO_PROXY was specified and it was not only an asterisk */ + + /* Check if name is an IP address; if not, assume it being a hostname. */ + namelen = strlen(name); + if(curlx_inet_pton(AF_INET, name, &address) == 1) + type = TYPE_IPV4; +#ifdef USE_IPV6 + else if(curlx_inet_pton(AF_INET6, name, &address) == 1) + type = TYPE_IPV6; +#endif + else { + /* ignore trailing dots in the hostname */ + if(name[namelen - 1] == '.') + namelen--; + } + + while(*p) { + const char *token; + size_t tokenlen = 0; + + /* pass blanks */ + curlx_str_passblanks(&p); + + token = p; + /* pass over the pattern */ + while(*p && !ISBLANK(*p) && (*p != ',')) { + p++; + tokenlen++; + } + + if(tokenlen) { + bool match = FALSE; + if(type == TYPE_HOST) + match = match_host(token, tokenlen, name, namelen); + else + match = match_ip(type, token, tokenlen, name); + + if(match) + return TRUE; + } + + /* pass blanks after pattern */ + curlx_str_passblanks(&p); + /* if not a comma, this ends the loop */ + if(*p != ',') + break; + /* pass any number of commas */ + while(*p == ',') + p++; + } /* while(*p) */ + } /* NO_PROXY was specified and it was not only an asterisk */ + + return FALSE; +} + +#ifndef CURL_DISABLE_HTTP + +/**************************************************************** + * Detect what (if any) proxy to use. Remember that this selects a host + * name and is not limited to HTTP proxies only. + * The returned pointer must be freed by the caller. + ****************************************************************/ +static char *proxy_detect_proxy(struct Curl_easy *data, + const struct Curl_scheme *scheme) +{ + char *proxy = NULL; + + /* If proxy was not specified, we check for default proxy environment + * variables, to enable i.e Lynx compliance: + * + * http_proxy=http://some.server.dom:port/ + * https_proxy=http://some.server.dom:port/ + * ftp_proxy=http://some.server.dom:port/ + * no_proxy=domain1.dom,host.domain2.dom + * (a comma-separated list of hosts which should + * not be proxied, or an asterisk to override + * all proxy variables) + * all_proxy=http://some.server.dom:port/ + * (seems to exist for the CERN www lib. Probably + * the first to check for.) + * + * For compatibility, the all-uppercase versions of these variables are + * checked if the lowercase versions do not exist. + */ + char proxy_env[20]; + const char *envp; + VERBOSE(envp = proxy_env); + + curl_msnprintf(proxy_env, sizeof(proxy_env), "%s_proxy", scheme->name); + + /* read the protocol proxy: */ + proxy = curl_getenv(proxy_env); + + /* + * We do not try the uppercase version of HTTP_PROXY because of + * security reasons: + * + * When curl is used in a webserver application + * environment (cgi or php), this environment variable can + * be controlled by the web server user by setting the + * http header 'Proxy:' to some value. + * + * This can cause 'internal' http/ftp requests to be + * arbitrarily redirected by any external attacker. + */ + if(!proxy && !curl_strequal("http_proxy", proxy_env)) { + /* There was no lowercase variable, try the uppercase version: */ + Curl_strntoupper(proxy_env, proxy_env, sizeof(proxy_env)); + proxy = curl_getenv(proxy_env); + } + + if(!proxy) { +#ifndef CURL_DISABLE_WEBSOCKETS + /* websocket proxy fallbacks */ + if(curl_strequal("ws_proxy", proxy_env)) { + proxy = curl_getenv("http_proxy"); + } + else if(curl_strequal("wss_proxy", proxy_env)) { + proxy = curl_getenv("https_proxy"); + if(!proxy) + proxy = curl_getenv("HTTPS_PROXY"); + } + if(!proxy) { +#endif + envp = "all_proxy"; + proxy = curl_getenv(envp); /* default proxy to use */ + if(!proxy) { + envp = "ALL_PROXY"; + proxy = curl_getenv(envp); + } +#ifndef CURL_DISABLE_WEBSOCKETS + } +#endif + } + if(proxy) + infof(data, "Uses proxy env variable %s == '%s'", envp, proxy); + + return proxy; +} +#endif /* CURL_DISABLE_HTTP */ + +/* + * If this is supposed to use a proxy, we need to figure out the proxy + * hostname, so that we can reuse an existing connection + * that may exist registered to the same proxy host. + */ +static CURLcode parse_proxy(struct Curl_easy *data, + const char *proxy, + bool for_pre_proxy, + struct proxy_info *proxyinfo) +{ + char *proxyuser = NULL; + char *proxypasswd = NULL; + char *scheme = NULL; + CURLcode result = CURLE_OK; + /* Set the start proxy type for URL scheme guessing */ + uint8_t proxytype = for_pre_proxy ? CURLPROXY_SOCKS4 : data->set.proxytype; + CURLU *uhp = curl_url(); + CURLUcode uc; + + if(!uhp) { + result = CURLE_OUT_OF_MEMORY; + goto error; + } + /* When parsing the proxy, allowing non-supported schemes since we have + these made up ones for proxies. Guess scheme for URLs without it. */ + uc = curl_url_set(uhp, CURLUPART_URL, proxy, + CURLU_NON_SUPPORT_SCHEME | CURLU_GUESS_SCHEME); + if(!uc) { + /* parsed okay as a URL - only update proxytype when scheme was explicit */ + uc = curl_url_get(uhp, CURLUPART_SCHEME, &scheme, CURLU_NO_GUESS_SCHEME); + if(!uc) { + result = Curl_scheme_to_proxytype(data, scheme, &proxytype, proxy); + if(result) + goto error; + } + else if(uc != CURLUE_NO_SCHEME) { + result = CURLE_OUT_OF_MEMORY; + goto error; + } + /* else: no explicit scheme, keep the configured proxytype */ + } + else { + failf(data, "Unsupported proxy syntax in \'%s\': %s", proxy, + curl_url_strerror(uc)); + result = CURLE_COULDNT_RESOLVE_PROXY; + goto error; + } + + result = Curl_peer_from_proxy_url(uhp, data, proxy, proxytype, + &proxyinfo->peer, &proxytype); + if(result) + goto error; + + switch(proxytype) { + case CURLPROXY_HTTP: + case CURLPROXY_HTTP_1_0: + case CURLPROXY_HTTPS: + case CURLPROXY_HTTPS2: + case CURLPROXY_HTTPS3: + if(for_pre_proxy) { + failf(data, "Unsupported pre-proxy type for \'%s\'", proxy); + result = CURLE_COULDNT_RESOLVE_PROXY; + goto error; + } + break; + case CURLPROXY_SOCKS4: + case CURLPROXY_SOCKS4A: + case CURLPROXY_SOCKS5: + case CURLPROXY_SOCKS5_HOSTNAME: + break; + default: + failf(data, "Unsupported proxy type %u for \'%s\'", proxytype, proxy); + result = CURLE_COULDNT_RESOLVE_PROXY; + goto error; + } + + /* Is there a username and password given in this proxy URL? */ + uc = curl_url_get(uhp, CURLUPART_USER, &proxyuser, CURLU_URLDECODE); + if(uc && (uc != CURLUE_NO_USER)) { + result = Curl_uc_to_curlcode(uc); + goto error; + } + uc = curl_url_get(uhp, CURLUPART_PASSWORD, &proxypasswd, CURLU_URLDECODE); + if(uc && (uc != CURLUE_NO_PASSWORD)) { + result = Curl_uc_to_curlcode(uc); + goto error; + } + + if(proxyuser || proxypasswd) { + result = Curl_creds_create(proxyuser, proxypasswd, NULL, NULL, + data->set.str[STRING_PROXY_SERVICE_NAME], + CREDS_URL, &proxyinfo->creds); + if(result) + goto error; + } + else if(!for_pre_proxy && + (data->set.str[STRING_PROXYUSERNAME] || + data->set.str[STRING_PROXYPASSWORD] || + data->set.str[STRING_PROXY_SERVICE_NAME])) { + /* No user/passwd in URL, if this is not a pre-proxy, the + * CURLOPT_PROXY* settings apply. */ + result = Curl_creds_create(data->set.str[STRING_PROXYUSERNAME], + data->set.str[STRING_PROXYPASSWORD], + NULL, NULL, + data->set.str[STRING_PROXY_SERVICE_NAME], + CREDS_OPTION, &proxyinfo->creds); + } + else + Curl_creds_unlink(&proxyinfo->creds); + + proxyinfo->proxytype = proxytype; + +error: + curlx_free(scheme); + curlx_free(proxyuser); + curlx_free(proxypasswd); + curl_url_cleanup(uhp); +#ifdef DEBUGBUILD + if(!result) { + DEBUGASSERT(proxyinfo); + DEBUGASSERT(proxyinfo->peer); + } +#endif + return result; +} + +/* Is transfer's origin exempted from proxy use? */ +static bool proxy_do_not_proxy(struct Curl_easy *data) +{ + const char *no_proxy; + char *env_no_proxy = NULL; + bool do_not_proxy; + + /* no proxying if the transfer does not use the network */ + if(data->state.origin->scheme->flags & PROTOPT_NONETWORK) + return TRUE; + + no_proxy = data->set.str[STRING_NOPROXY]; + if(!no_proxy) { + const char *p = "no_proxy"; + env_no_proxy = curl_getenv(p); + if(!env_no_proxy) { + p = "NO_PROXY"; + env_no_proxy = curl_getenv(p); + } + if(env_no_proxy) + infof(data, "Uses proxy env variable %s == '%s'", p, env_no_proxy); + no_proxy = env_no_proxy; + } + + do_not_proxy = proxy_check_noproxy(data->state.origin->hostname, no_proxy); + curlx_safefree(env_no_proxy); + return do_not_proxy; +} + +CURLcode Curl_proxy_init_conn(struct Curl_easy *data, + struct connectdata *conn) +{ + char *proxy = NULL; + char *pre_proxy = NULL; + bool do_env_detect = TRUE; + CURLcode result = CURLE_OK; + + /* Enforce no proxy use unless we decide to use one */ + conn->bits.origin_is_proxy = FALSE; + DEBUGASSERT(!conn->socks_proxy.peer); + DEBUGASSERT(!conn->http_proxy.peer); + + if(proxy_do_not_proxy(data)) + goto out; + + /************************************************************* + * Detect what (if any) proxy to use + *************************************************************/ + /* the empty config strings disable proxy use and env detects */ + if(data->set.str[STRING_PROXY]) { + if(*data->set.str[STRING_PROXY]) { + proxy = curlx_strdup(data->set.str[STRING_PROXY]); + /* if global proxy is set, this is it */ + if(!proxy) { + failf(data, "memory shortage"); + result = CURLE_OUT_OF_MEMORY; + goto out; + } + } + else + do_env_detect = FALSE; + } + + if(data->set.str[STRING_PRE_PROXY]) { + if(*data->set.str[STRING_PRE_PROXY]) { + pre_proxy = curlx_strdup(data->set.str[STRING_PRE_PROXY]); + /* if global socks proxy is set, this is it */ + if(!pre_proxy) { + failf(data, "memory shortage"); + result = CURLE_OUT_OF_MEMORY; + goto out; + } + } + else + do_env_detect = FALSE; + } + +#ifndef CURL_DISABLE_HTTP + /* None configured, detect possible proxy from environment. */ + if(!proxy && !pre_proxy && do_env_detect) + proxy = proxy_detect_proxy(data, conn->scheme); +#else + (void)do_env_detect; +#endif /* CURL_DISABLE_HTTP */ + + if(!proxy && !pre_proxy) + goto out; + + if(pre_proxy) { + result = parse_proxy(data, pre_proxy, TRUE, &conn->socks_proxy); + if(result) + goto out; + } + + if(proxy) { + result = parse_proxy(data, proxy, FALSE, &conn->http_proxy); + if(result) + goto out; + + switch(conn->http_proxy.proxytype) { + case CURLPROXY_SOCKS4: + case CURLPROXY_SOCKS4A: + case CURLPROXY_SOCKS5: + case CURLPROXY_SOCKS5_HOSTNAME: + /* Whoops, it is not an HTTP proxy */ + if(pre_proxy) { + /* and we already have a SOCKS pre-proxy. Cannot have both */ + failf(data, "Having a SOCKS pre-proxy and proxy is not " + "supported with \'%s\'", proxy); + result = CURLE_COULDNT_RESOLVE_PROXY; + goto out; + } + /* switch */ + conn->socks_proxy = conn->http_proxy; + memset(&conn->http_proxy, 0, sizeof(conn->http_proxy)); + break; + default: + /* all other types are HTTP */ + break; + } + } + + if(conn->socks_proxy.peer) { + DEBUGASSERT(!CURL_PROXY_IS_ANY_HTTP(conn->socks_proxy.proxytype)); + } + +#ifdef CURL_DISABLE_HTTP + if(conn->http_proxy.peer) { + /* asking for an HTTP proxy is a bit funny when HTTP is disabled... */ + result = CURLE_UNSUPPORTED_PROTOCOL; + goto out; + } + +#else /* CURL_DISABLE_HTTP */ + if(conn->http_proxy.peer) { + const struct Curl_scheme *scheme = data->state.origin->scheme; + bool tunnel_proxy = (bool)data->set.tunnel_thru_httpproxy; + DEBUGASSERT(CURL_PROXY_IS_ANY_HTTP(conn->http_proxy.proxytype)); + + if(!tunnel_proxy) { + /* Decide if we tunnel through proxy automatically */ + if(conn->via_peer) { + /* With connect-to, we always tunnel */ + tunnel_proxy = TRUE; + } + else if(scheme->flags & PROTOPT_SSL) { + /* If the transfer is supposed to be secure, we tunnel */ + tunnel_proxy = TRUE; + } + else if(scheme->flags & PROTOPT_HTTP_PROXY_TUNNEL) { + /* transfer scheme required tunneling */ + tunnel_proxy = TRUE; + } + else if(!(scheme->protocol & PROTO_FAMILY_HTTP) && + !(scheme->flags & PROTOPT_PROXY_AS_HTTP)) { + /* Cannot delegate transfer URL to HTTP proxy */ + tunnel_proxy = TRUE; + } + } + + if(!tunnel_proxy) { + /* HTTP proxy used in forwarding mode. This means the connection + * is really to the proxy and NOT the origin of the transfer. */ + DEBUGASSERT(!conn->via_peer); + Curl_peer_link(&conn->origin, conn->http_proxy.peer); + conn->scheme = conn->http_proxy.peer->scheme; + conn->bits.origin_is_proxy = TRUE; + } + +#ifndef CURL_DISABLE_DIGEST_AUTH + if(!Curl_safecmp(data->state.envproxy, proxy)) { + /* proxy changed */ + Curl_auth_digest_cleanup(&data->state.proxydigest); + curlx_free(data->state.envproxy); + data->state.envproxy = curlx_strdup(proxy); + } +#endif + } +#endif /* !CURL_DISABLE_HTTP */ + +out: + curlx_free(pre_proxy); + curlx_free(proxy); + return result; +} + +#endif /* CURL_DISABLE_PROXY */ diff --git a/3rdparty/curl-8.21.0/lib/proxy.h b/3rdparty/curl-8.21.0/lib/proxy.h new file mode 100644 index 0000000000..307ee003e6 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/proxy.h @@ -0,0 +1,59 @@ +#ifndef HEADER_CURL_PROXY_H +#define HEADER_CURL_PROXY_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifndef CURL_DISABLE_PROXY + +struct Curl_easy; +struct Curl_peer; +struct Curl_creds; +struct connectdata; + +struct proxy_info { + struct Curl_peer *peer; /* proxy to this peer */ + struct Curl_creds *creds; /* use these credentials, maybe NULL */ + uint8_t proxytype; /* what kind of proxy that is in use */ +}; + +#define CURL_PROXY_IS_HTTPS(t) \ + (((t) == CURLPROXY_HTTPS) || \ + ((t) == CURLPROXY_HTTPS2) || \ + ((t) == CURLPROXY_HTTPS3)) + +#define CURL_PROXY_IS_HTTP(t) \ + (((t) == CURLPROXY_HTTP) || \ + ((t) == CURLPROXY_HTTP_1_0)) + +#define CURL_PROXY_IS_ANY_HTTP(t) \ + (CURL_PROXY_IS_HTTP(t) || \ + CURL_PROXY_IS_HTTPS(t)) + +CURLcode Curl_proxy_init_conn(struct Curl_easy *data, + struct connectdata *conn); + +#endif /* !CURL_DISABLE_PROXY */ + +#endif /* HEADER_CURL_PROXY_H */ diff --git a/3rdparty/curl-8.21.0/lib/psl.c b/3rdparty/curl-8.21.0/lib/psl.c new file mode 100644 index 0000000000..195841f3a3 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/psl.c @@ -0,0 +1,103 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_LIBPSL + +#include "psl.h" +#include "progress.h" +#include "curl_share.h" + +#if !defined(PSL_VERSION_NUMBER) || PSL_VERSION_NUMBER < 0x001000 +#error "libpsl 0.16.0 or greater required" +#endif + +void Curl_psl_destroy(struct PslCache *pslcache) +{ + if(pslcache->psl) { + if(pslcache->dynamic) + psl_free((psl_ctx_t *)CURL_UNCONST(pslcache->psl)); + pslcache->psl = NULL; + pslcache->dynamic = FALSE; + } +} + +const psl_ctx_t *Curl_psl_use(struct Curl_easy *easy) +{ + struct PslCache *pslcache = easy->psl; + const psl_ctx_t *psl; + time_t now_sec; + + if(!pslcache) + return NULL; + + Curl_share_lock(easy, CURL_LOCK_DATA_PSL, CURL_LOCK_ACCESS_SHARED); + now_sec = Curl_pgrs_now(easy)->tv_sec; + if(!pslcache->psl || pslcache->expires <= now_sec) { + /* Let a chance to other threads to do the job: avoids deadlock. */ + Curl_share_unlock(easy, CURL_LOCK_DATA_PSL); + + /* Update cache: this needs an exclusive lock. */ + Curl_share_lock(easy, CURL_LOCK_DATA_PSL, CURL_LOCK_ACCESS_SINGLE); + + /* Recheck in case another thread did the job. */ + if(pslcache->expires <= now_sec) { + now_sec = Curl_pgrs_now(easy)->tv_sec; + } + if(!pslcache->psl || pslcache->expires <= now_sec) { + bool dynamic = FALSE; + time_t expires = TIME_T_MAX; + + psl = psl_latest(NULL); + dynamic = !!psl; + /* Take care of possible time computation overflow. */ + expires = (now_sec < TIME_T_MAX - PSL_TTL) ? + (now_sec + PSL_TTL) : TIME_T_MAX; + + /* Only get the built-in PSL if we do not already have the "latest". */ + if(!psl && !pslcache->dynamic) + psl = psl_builtin(); + + if(psl) { + Curl_psl_destroy(pslcache); + pslcache->psl = psl; + pslcache->dynamic = dynamic; + pslcache->expires = expires; + } + } + Curl_share_unlock(easy, CURL_LOCK_DATA_PSL); /* Release exclusive lock. */ + Curl_share_lock(easy, CURL_LOCK_DATA_PSL, CURL_LOCK_ACCESS_SHARED); + } + psl = pslcache->psl; + if(!psl) + Curl_share_unlock(easy, CURL_LOCK_DATA_PSL); + return psl; +} + +void Curl_psl_release(struct Curl_easy *easy) +{ + Curl_share_unlock(easy, CURL_LOCK_DATA_PSL); +} + +#endif /* USE_LIBPSL */ diff --git a/3rdparty/curl-8.21.0/lib/psl.h b/3rdparty/curl-8.21.0/lib/psl.h new file mode 100644 index 0000000000..97871f9634 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/psl.h @@ -0,0 +1,51 @@ +#ifndef HEADER_PSL_H +#define HEADER_PSL_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#ifdef USE_LIBPSL + +#include + +struct Curl_easy; + +#define PSL_TTL (72 * 3600) /* PSL time to live before a refresh. */ + +struct PslCache { + const psl_ctx_t *psl; /* The PSL. */ + time_t expires; /* Time this PSL life expires. */ + BIT(dynamic); /* PSL should be released when no longer needed. */ +}; + +const psl_ctx_t *Curl_psl_use(struct Curl_easy *easy); +void Curl_psl_release(struct Curl_easy *easy); +void Curl_psl_destroy(struct PslCache *pslcache); + +#else + +#define Curl_psl_use(easy) NULL +#define Curl_psl_release(easy) +#define Curl_psl_destroy(pslcache) + +#endif /* USE_LIBPSL */ +#endif /* HEADER_PSL_H */ diff --git a/3rdparty/curl-8.21.0/lib/rand.c b/3rdparty/curl-8.21.0/lib/rand.c new file mode 100644 index 0000000000..3260fe3345 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/rand.c @@ -0,0 +1,246 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef HAVE_ARPA_INET_H +#include +#endif + +#include "urldata.h" +#include "vtls/vtls.h" +#include "curl_trc.h" +#include "rand.h" +#include "escape.h" + +#ifdef _WIN32 +#include +#ifndef STATUS_SUCCESS +#define STATUS_SUCCESS ((NTSTATUS)0x00000000L) +#endif + +CURLcode Curl_win32_random(unsigned char *entropy, size_t length) +{ + memset(entropy, 0, length); + + if(BCryptGenRandom(NULL, entropy, (ULONG)length, + BCRYPT_USE_SYSTEM_PREFERRED_RNG) != STATUS_SUCCESS) + return CURLE_FAILED_INIT; + + return CURLE_OK; +} +#endif + +#ifndef USE_SSL +/* ---- possibly non-cryptographic version following ---- */ +static CURLcode weak_random(struct Curl_easy *data, + unsigned char *entropy, + size_t length) /* always 4, size of int */ +{ + unsigned int r; + DEBUGASSERT(length == sizeof(int)); + + /* Trying cryptographically secure functions first */ +#ifdef _WIN32 + (void)data; + { + CURLcode result = Curl_win32_random(entropy, length); + if(result != CURLE_NOT_BUILT_IN) + return result; + } +#endif + +#ifdef HAVE_ARC4RANDOM + (void)data; + r = (unsigned int)arc4random(); + memcpy(entropy, &r, length); +#else + infof(data, "WARNING: using weak random seed"); + { + static unsigned int randseed; + static bool seeded = FALSE; + unsigned int rnd; + if(!seeded) { + struct curltime now; + curlx_pnow(&now); + randseed += (unsigned int)now.tv_usec + (unsigned int)now.tv_sec; + randseed = randseed * 1103515245 + 12345; + randseed = randseed * 1103515245 + 12345; + randseed = randseed * 1103515245 + 12345; + seeded = TRUE; + } + + /* Return an unsigned 32-bit pseudo-random number. */ + r = randseed = randseed * 1103515245 + 12345; + rnd = (r << 16) | ((r >> 16) & 0xFFFF); + memcpy(entropy, &rnd, length); + } +#endif + return CURLE_OK; +} +#endif + +static CURLcode randit(struct Curl_easy *data, unsigned int *rnd, + bool env_override) +{ +#ifdef DEBUGBUILD + if(env_override) { + char *force_entropy = getenv("CURL_ENTROPY"); + if(force_entropy) { + static unsigned int randseed; + static bool seeded = FALSE; + + if(!seeded) { + unsigned int seed = 0; + size_t elen = strlen(force_entropy); + size_t clen = sizeof(seed); + size_t min = elen < clen ? elen : clen; + memcpy((char *)&seed, force_entropy, min); + randseed = ntohl(seed); + seeded = TRUE; + } + else + randseed++; + *rnd = randseed; + return CURLE_OK; + } + } +#else + (void)env_override; +#endif + + /* data may be NULL! */ +#ifdef USE_SSL + return Curl_ssl_random(data, (unsigned char *)rnd, sizeof(*rnd)); +#else + return weak_random(data, (unsigned char *)rnd, sizeof(*rnd)); +#endif +} + +/* + * Curl_rand() stores 'num' number of random unsigned characters in the buffer + * 'rnd' points to. + * + * If libcurl is built without TLS support or arc4random, this function will + * use "weak" random. + * + * When built *with* TLS support, it will return error if it cannot provide + * strong random values. + * + * NOTE: 'data' may be passed in as NULL when coming from external API without + * easy handle! + * + */ + +CURLcode Curl_rand_bytes(struct Curl_easy *data, +#ifdef DEBUGBUILD + bool env_override, +#endif + unsigned char *rnd, size_t num) +{ + CURLcode result = CURLE_BAD_FUNCTION_ARGUMENT; +#ifndef DEBUGBUILD + const bool env_override = FALSE; +#endif + + DEBUGASSERT(num); + + while(num) { + unsigned int r; + size_t left = num < sizeof(unsigned int) ? num : sizeof(unsigned int); + + result = randit(data, &r, env_override); + if(result) + return result; + + while(left) { + *rnd++ = (unsigned char)(r & 0xFF); + r >>= 8; + --num; + --left; + } + } + + return result; +} + +/* + * Curl_rand_hex() fills the 'rnd' buffer with a given 'num' size with random + * hexadecimal digits PLUS a null-terminator byte. It must be an odd number + * size. + */ + +CURLcode Curl_rand_hex(struct Curl_easy *data, unsigned char *rnd, size_t num) +{ + CURLcode result = CURLE_BAD_FUNCTION_ARGUMENT; + unsigned char buffer[128]; + DEBUGASSERT(num > 1); + + if((num / 2 >= sizeof(buffer)) || !(num & 1)) { + /* make sure it fits in the local buffer and that it is an odd number! */ + DEBUGF(infof(data, "invalid buffer size with Curl_rand_hex")); + return CURLE_BAD_FUNCTION_ARGUMENT; + } + + num--; /* save one for null-termination */ + + result = Curl_rand(data, buffer, num / 2); + if(result) + return result; + + Curl_hexencode(buffer, num / 2, rnd, num + 1); + return result; +} + +/* + * Curl_rand_alnum() fills the 'rnd' buffer with a given 'num' size with random + * alphanumerical chars PLUS a null-terminator byte. + */ + +static const char alnum[] = + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"; + +CURLcode Curl_rand_alnum(struct Curl_easy *data, unsigned char *rnd, + size_t num) +{ + CURLcode result = CURLE_OK; + const unsigned int alnumspace = sizeof(alnum) - 1; + unsigned int r; + DEBUGASSERT(num > 1); + + num--; /* save one for null-termination */ + + while(num) { + do { + result = randit(data, &r, TRUE); + if(result) + return result; + } while(r >= (UINT_MAX - UINT_MAX % alnumspace)); + + *rnd++ = (unsigned char)alnum[r % alnumspace]; + num--; + } + *rnd = 0; + + return result; +} diff --git a/3rdparty/curl-8.21.0/lib/rand.h b/3rdparty/curl-8.21.0/lib/rand.h new file mode 100644 index 0000000000..a02717074f --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/rand.h @@ -0,0 +1,58 @@ +#ifndef HEADER_CURL_RAND_H +#define HEADER_CURL_RAND_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +CURLcode Curl_rand_bytes(struct Curl_easy *data, +#ifdef DEBUGBUILD + bool env_override, +#endif + unsigned char *rnd, size_t num); + +#ifdef DEBUGBUILD +#define Curl_rand(a, b, c) Curl_rand_bytes(a, TRUE, b, c) +#else +#define Curl_rand(a, b, c) Curl_rand_bytes(a, b, c) +#endif + +/* + * Curl_rand_hex() fills the 'rnd' buffer with a given 'num' size with random + * hexadecimal digits PLUS a null-terminator byte. It must be an odd number + * size. + */ +CURLcode Curl_rand_hex(struct Curl_easy *data, unsigned char *rnd, size_t num); + +/* + * Curl_rand_alnum() fills the 'rnd' buffer with a given 'num' size with random + * alphanumerical chars PLUS a null-terminator byte. + */ +CURLcode Curl_rand_alnum(struct Curl_easy *data, unsigned char *rnd, + size_t num); + +#ifdef _WIN32 +/* Random generator shared between the Schannel vtls and Curl_rand*() + functions */ +CURLcode Curl_win32_random(unsigned char *entropy, size_t length); +#endif + +#endif /* HEADER_CURL_RAND_H */ diff --git a/3rdparty/curl-8.21.0/lib/ratelimit.c b/3rdparty/curl-8.21.0/lib/ratelimit.c new file mode 100644 index 0000000000..97af01c788 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/ratelimit.c @@ -0,0 +1,295 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "urldata.h" +#include "ratelimit.h" + +#define CURL_US_PER_SEC 1000000 +#define CURL_RLIMIT_MIN_RATE (4 * 1024) /* minimum step rate */ +#define CURL_RLIMIT_STEP_MIN_MS 2 /* minimum step duration */ + +static void rlimit_update(struct Curl_rlimit *r, + const struct curltime *pts) +{ + timediff_t elapsed_us, elapsed_steps; + int64_t token_gain; + + DEBUGASSERT(r->rate_per_step); + if((r->ts.tv_sec == pts->tv_sec) && (r->ts.tv_usec == pts->tv_usec)) + return; + + elapsed_us = curlx_ptimediff_us(pts, &r->ts); + if(elapsed_us < 0) { /* not going back in time */ + DEBUGASSERT(0); + return; + } + + elapsed_us += r->spare_us; + if(elapsed_us < r->step_us) + return; + + /* we do the update */ + r->ts = *pts; + elapsed_steps = elapsed_us / r->step_us; + r->spare_us = elapsed_us % r->step_us; + + /* How many tokens did we gain since the last update? */ + if(r->rate_per_step > (INT64_MAX / elapsed_steps)) + token_gain = INT64_MAX; + else { + token_gain = r->rate_per_step * elapsed_steps; + } + + if((INT64_MAX - token_gain) > r->tokens) + r->tokens += token_gain; + else + r->tokens = INT64_MAX; + + /* Limit the token again by the burst rate (if set), so we + * do not suddenly have a huge number of tokens after inactivity. */ + if(r->burst_per_step && (r->tokens > r->burst_per_step)) { + r->tokens = r->burst_per_step; + } +} + +static void rlimit_tune_steps(struct Curl_rlimit *r, + int64_t tokens_total) +{ + int64_t tokens_last, tokens_main, msteps; + + /* Tune the ratelimit at the start *if* we know how many tokens + * are expected to be consumed in total. + * The reason for tuning is that rlimit provides tokens to be consumed + * per "step" which starts out to be a second. The tokens may be consumed + * in full at the beginning of a step. The remainder of the second will + * have no tokens available, effectively blocking the consumption and + * so keeping the "step average" in line. + * This works will up to the last step. When no more tokens are needed, + * no wait will happen and the last step would be too fast. This is + * especially noticeable when only a few steps are needed. + * + * Example: downloading 1.5kb with a ratelimit of 1k could be done in + * roughly 1 second (1k in the first second and the 0.5 at the start of + * the second one). + * + * The tuning tries to make the last step small, using only + * 1 percent of the total tokens (at least 1). The rest of the tokens + * are to be consumed in the steps before by adjusting the duration of + * the step and the amount of tokens it provides. */ + if(!r->rate_per_step || + (tokens_total <= 1) || + (tokens_total > (INT64_MAX / 1000))) + return; + + /* Calculate tokens for the last step and the ones before. */ + tokens_last = tokens_total / 100; + if(!tokens_last) /* less than 100 total, use 1 */ + tokens_last = 1; + else if(tokens_last > CURL_RLIMIT_MIN_RATE) + tokens_last = CURL_RLIMIT_MIN_RATE; + DEBUGASSERT(tokens_last); + tokens_main = tokens_total - tokens_last; + DEBUGASSERT(tokens_main); + + /* how many milli-steps will it take to consume those, give the + * original rate limit per second? */ + DEBUGASSERT(r->step_us == CURL_US_PER_SEC); + + msteps = (tokens_main * 1000 / r->rate_per_step); + if(msteps < CURL_RLIMIT_STEP_MIN_MS) { + /* Steps this small will not work. Do not tune. */ + return; + } + else if(msteps < 1000) { + /* It needs less than one step to provide the needed tokens. + * Make it exactly that long and with exactly those tokens. */ + r->step_us = (timediff_t)msteps * 1000; + r->rate_per_step = tokens_main; + r->tokens = r->rate_per_step; + } + else { + /* More than 1 step. Spread the remainder milli steps and + * the tokens they need to provide across all steps. If integer + * arithmetic can do it. */ + curl_off_t ms_unaccounted = (msteps % 1000); + curl_off_t mstep_inc = (ms_unaccounted / (msteps / 1000)); + if(mstep_inc) { + curl_off_t rate_inc = ((r->rate_per_step * mstep_inc) / 1000); + if(rate_inc) { + r->step_us = CURL_US_PER_SEC + ((timediff_t)mstep_inc * 1000); + r->rate_per_step += rate_inc; + r->tokens = r->rate_per_step; + if(r->burst_per_step) { + curl_off_t burst_inc = ((r->burst_per_step * mstep_inc) / 1000); + if(burst_inc) + r->burst_per_step += burst_inc; + } + } + } + } +} + +void Curl_rlimit_init(struct Curl_rlimit *r, + int64_t rate_per_sec, + int64_t burst_per_sec, + const struct curltime *pts) +{ + DEBUGASSERT(rate_per_sec >= 0); + DEBUGASSERT(burst_per_sec >= rate_per_sec || !burst_per_sec); + DEBUGASSERT(pts); + r->rate_per_step = r->rate_per_sec = rate_per_sec; + r->burst_per_step = r->burst_per_sec = burst_per_sec; + r->step_us = CURL_US_PER_SEC; + r->spare_us = 0; + r->tokens = r->rate_per_step; + r->ts = *pts; + r->blocked = FALSE; +} + +void Curl_rlimit_start(struct Curl_rlimit *r, const struct curltime *pts, + int64_t total_tokens) +{ + /* A start always resets the values to initial defaults, then + * fine tunes the intervals for the total_tokens expected. */ + r->rate_per_step = r->rate_per_sec; + r->burst_per_step = r->burst_per_sec; + r->step_us = CURL_US_PER_SEC; + r->spare_us = 0; + r->tokens = r->rate_per_step; + r->ts = *pts; + rlimit_tune_steps(r, total_tokens); +} + +int64_t Curl_rlimit_per_step(struct Curl_rlimit *r) +{ + return r->rate_per_step; +} + +bool Curl_rlimit_active(struct Curl_rlimit *r) +{ + return (r->rate_per_step > 0) || r->blocked; +} + +bool Curl_rlimit_is_blocked(struct Curl_rlimit *r) +{ + return (bool)r->blocked; +} + +int64_t Curl_rlimit_avail(struct Curl_rlimit *r, + const struct curltime *pts) +{ + if(r->blocked) + return 0; + else if(r->rate_per_step) { + rlimit_update(r, pts); + return r->tokens; + } + else + return INT64_MAX; +} + +void Curl_rlimit_drain(struct Curl_rlimit *r, + size_t tokens, + const struct curltime *pts) +{ + if(r->blocked || !r->rate_per_step) + return; + + rlimit_update(r, pts); +#if 8 <= SIZEOF_SIZE_T + if(tokens > INT64_MAX) { + r->tokens = INT64_MAX; + } + else +#endif + { + int64_t val = (int64_t)tokens; + if((INT64_MIN + val) < r->tokens) + r->tokens -= val; + else + r->tokens = INT64_MIN; + } +} + +timediff_t Curl_rlimit_wait_ms(struct Curl_rlimit *r, + const struct curltime *pts) +{ + timediff_t wait_us, elapsed_us; + + if(r->blocked || !r->rate_per_step) + return 0; + rlimit_update(r, pts); + if(r->tokens > 0) + return 0; + + /* How much time will it take tokens to become positive again? + * Deduct `spare_us` and check against already elapsed time */ + wait_us = r->step_us - r->spare_us; + if(r->tokens < 0) { + curl_off_t debt_pct = ((-r->tokens) * 100 / r->rate_per_step); + if(debt_pct) + wait_us += (r->step_us * debt_pct / 100); + } + + elapsed_us = curlx_ptimediff_us(pts, &r->ts); + if(elapsed_us >= wait_us) + return 0; + wait_us -= elapsed_us; + return (wait_us + 999) / 1000; /* in milliseconds */ +} + +timediff_t Curl_rlimit_next_step_ms(struct Curl_rlimit *r, + const struct curltime *pts) +{ + if(!r->blocked && r->rate_per_step) { + timediff_t elapsed_us, next_us; + + elapsed_us = curlx_ptimediff_us(pts, &r->ts) + r->spare_us; + if(r->step_us > elapsed_us) { + next_us = r->step_us - elapsed_us; + return (next_us + 999) / 1000; /* in milliseconds */ + } + } + return 0; +} + +void Curl_rlimit_block(struct Curl_rlimit *r, + bool activate, + const struct curltime *pts) +{ + if(!activate == !r->blocked) + return; + + r->ts = *pts; + r->blocked = activate; + if(!r->blocked) { + /* Start rate limiting fresh. The amount of time this was blocked + * does not generate extra tokens. */ + Curl_rlimit_start(r, pts, -1); + } + else { + r->tokens = 0; + } +} diff --git a/3rdparty/curl-8.21.0/lib/ratelimit.h b/3rdparty/curl-8.21.0/lib/ratelimit.h new file mode 100644 index 0000000000..3c3e38b895 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/ratelimit.h @@ -0,0 +1,108 @@ +#ifndef HEADER_CURL_RLIMIT_H +#define HEADER_CURL_RLIMIT_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curlx/timeval.h" + +struct Curl_easy; + +/* This is a rate limiter that provides "tokens" to be consumed + * per second. In the literature, this is referred to as a + * "token bucket" (https://en.wikipedia.org/wiki/Token_bucket). + * Example: + * A rate limit of 1 megabyte per second. + * - initially 1 million tokens are available. + * - these are drained in the first second. + * - checking available tokens before the 2nd second will return 0. + * - at/after the 2nd second, 1 million tokens are available again. + * - nothing happens for a second, the 1 million tokens would grow + * to 2 million, however the burst limit caps those at 1.5 million. + * Thus: + * - setting "burst" to CURL_OFF_T_MAX would average tokens over the + * complete lifetime. E.g. for a download, at the *end* of it, the + * average rate from start to finish would be the rate limit. + * - setting "burst" to the same value as "rate" would make a + * download always try to stay *at/below* the rate and slow times will + * not generate extra tokens. + * + * A rate limit can be blocked, causing the available tokens to become + * always 0 until unblocked. After unblocking, the rate limiting starts + * again with no history of the past. + * + * Finally, a rate limiter with rate 0 will always have CURL_OFF_T_MAX + * tokens available, unless blocked. + */ + +struct Curl_rlimit { + int64_t rate_per_sec; /* rate tokens generated per second */ + int64_t burst_per_sec; /* burst rate of tokens per second */ + int64_t rate_per_step; /* rate tokens generated per step us */ + int64_t burst_per_step; /* burst rate of tokens per step us */ + timediff_t step_us; /* microseconds between token increases */ + int64_t tokens; /* tokens available in the next second */ + timediff_t spare_us; /* microseconds unaffecting tokens */ + struct curltime ts; /* time of the last update */ + BIT(blocked); /* blocking sets available tokens to 0 */ +}; + +void Curl_rlimit_init(struct Curl_rlimit *r, + int64_t rate_per_sec, + int64_t burst_per_sec, + const struct curltime *pts); + +/* Start ratelimiting with the given timestamp. Resets available tokens. + * `total_tokens` is either -1 or the number of total tokens expected + * to be consumed. */ +void Curl_rlimit_start(struct Curl_rlimit *r, const struct curltime *pts, + int64_t total_tokens); + +/* How many milliseconds to wait until token are available again. */ +timediff_t Curl_rlimit_wait_ms(struct Curl_rlimit *r, + const struct curltime *pts); + +/* When the rate limit will update its tokens again */ +timediff_t Curl_rlimit_next_step_ms(struct Curl_rlimit *r, + const struct curltime *pts); + +/* Return if rate limiting of tokens is active */ +bool Curl_rlimit_active(struct Curl_rlimit *r); +bool Curl_rlimit_is_blocked(struct Curl_rlimit *r); +int64_t Curl_rlimit_per_step(struct Curl_rlimit *r); + +/* Return how many tokens are available to spend, may be negative */ +int64_t Curl_rlimit_avail(struct Curl_rlimit *r, + const struct curltime *pts); + +/* Drain tokens from the ratelimit, give an estimate of how many tokens + * remain to be drained in the future (-1 for unknown). */ +void Curl_rlimit_drain(struct Curl_rlimit *r, + size_t tokens, + const struct curltime *pts); + +/* Block/unblock ratelimiting. A blocked ratelimit has 0 tokens available. */ +void Curl_rlimit_block(struct Curl_rlimit *r, + bool activate, + const struct curltime *pts); + +#endif /* HEADER_CURL_RLIMIT_H */ diff --git a/3rdparty/curl-8.21.0/lib/request.c b/3rdparty/curl-8.21.0/lib/request.c new file mode 100644 index 0000000000..56dd2c4a15 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/request.c @@ -0,0 +1,503 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "urldata.h" +#include "cfilters.h" +#include "curlx/dynbuf.h" +#include "doh.h" +#include "progress.h" +#include "request.h" +#include "sendf.h" +#include "curl_trc.h" +#include "transfer.h" +#include "url.h" +#include "curlx/strparse.h" + +void Curl_req_init(struct SingleRequest *req) +{ + memset(req, 0, sizeof(*req)); +} + +CURLcode Curl_req_soft_reset(struct SingleRequest *req, + struct Curl_easy *data) +{ + CURLcode result; + + req->done = FALSE; + req->upload_done = FALSE; + req->upload_aborted = FALSE; + req->download_done = FALSE; + req->eos_written = FALSE; + req->eos_read = FALSE; + req->eos_sent = FALSE; + req->ignorebody = FALSE; + req->shutdown = FALSE; + req->bytecount = 0; + req->writebytecount = 0; + req->header = FALSE; + req->headerline = 0; + req->headerbytecount = 0; + req->allheadercount = 0; + req->deductheadercount = 0; + req->httpversion_sent = 0; + req->httpversion = 0; + req->sendbuf_hds_len = 0; + + curlx_safefree(req->hd_auth); +#ifndef CURL_DISABLE_PROXY + curlx_safefree(req->hd_proxy_auth); +#endif + + result = Curl_client_start(data); + if(result) + return result; + + if(!req->sendbuf_init) { + Curl_bufq_init2(&req->sendbuf, data->set.upload_buffer_size, 1, + BUFQ_OPT_SOFT_LIMIT); + req->sendbuf_init = TRUE; + } + else { + Curl_bufq_reset(&req->sendbuf); + if(data->set.upload_buffer_size != req->sendbuf.chunk_size) { + Curl_bufq_free(&req->sendbuf); + Curl_bufq_init2(&req->sendbuf, data->set.upload_buffer_size, 1, + BUFQ_OPT_SOFT_LIMIT); + } + } + + return CURLE_OK; +} + +CURLcode Curl_req_start(struct SingleRequest *req, + struct Curl_easy *data) +{ + req->start = *Curl_pgrs_now(data); + return Curl_req_soft_reset(req, data); +} + +static CURLcode req_flush(struct Curl_easy *data); + +CURLcode Curl_req_done(struct SingleRequest *req, + struct Curl_easy *data, bool aborted) +{ + (void)req; + if(!aborted) + (void)req_flush(data); + Curl_client_reset(data); + return CURLE_OK; +} + +void Curl_req_hard_reset(struct SingleRequest *req, struct Curl_easy *data) +{ + struct curltime t0 = { 0, 0 }; + + curlx_safefree(req->newurl); + curlx_safefree(req->hd_auth); +#ifndef CURL_DISABLE_PROXY + curlx_safefree(req->hd_proxy_auth); +#endif +#ifndef CURL_DISABLE_COOKIES + curlx_safefree(req->cookiehost); +#endif + Curl_client_reset(data); + if(req->sendbuf_init) + Curl_bufq_reset(&req->sendbuf); + + /* clear any resolve data */ + Curl_resolv_destroy_all(data); + /* Can no longer memset() this struct as we need to keep some state */ + req->size = -1; + req->maxdownload = -1; + req->bytecount = 0; + req->writebytecount = 0; + req->start = t0; + req->headerbytecount = 0; + req->allheadercount = 0; + req->deductheadercount = 0; + req->headerline = 0; + req->offset = 0; + req->httpcode = 0; + req->io_flags = 0; + req->upgr101 = UPGR101_NONE; + req->sendbuf_hds_len = 0; + req->timeofdoc = 0; + req->location = NULL; + req->newurl = NULL; +#ifndef CURL_DISABLE_COOKIES + req->setcookies = 0; +#endif + req->header = FALSE; + req->content_range = FALSE; + req->download_done = FALSE; + req->eos_written = FALSE; + req->eos_read = FALSE; + req->eos_sent = FALSE; + req->rewind_read = FALSE; + req->upload_done = FALSE; + req->upload_aborted = FALSE; + req->ignorebody = FALSE; + req->http_bodyless = FALSE; + req->chunk = FALSE; + req->resp_trailer = FALSE; + req->ignore_cl = FALSE; + req->upload_chunky = FALSE; + req->no_body = data->set.opt_no_body; + req->authneg = FALSE; + req->shutdown = FALSE; + /* Unpause all directions */ + Curl_rlimit_block(&data->progress.dl.rlimit, FALSE, &t0); + Curl_rlimit_block(&data->progress.ul.rlimit, FALSE, &t0); +} + +void Curl_req_free(struct SingleRequest *req, struct Curl_easy *data) +{ + curlx_safefree(req->newurl); + curlx_safefree(req->hd_auth); +#ifndef CURL_DISABLE_PROXY + curlx_safefree(req->hd_proxy_auth); +#endif + if(req->sendbuf_init) + Curl_bufq_free(&req->sendbuf); + Curl_client_cleanup(data); +} + +static CURLcode xfer_send(struct Curl_easy *data, + const char *buf, size_t blen, + size_t hds_len, size_t *pnwritten) +{ + CURLcode result = CURLE_OK; + bool eos = FALSE; + + *pnwritten = 0; + DEBUGASSERT(hds_len <= blen); +#ifdef DEBUGBUILD + { + /* Allow debug builds to override this logic to force short initial + sends */ + size_t body_len = blen - hds_len; + if(body_len) { + const char *p = getenv("CURL_SMALLREQSEND"); + if(p) { + curl_off_t body_small; + if(!curlx_str_number(&p, &body_small, body_len)) + blen = hds_len + (size_t)body_small; + } + } + } +#endif + /* Make sure this does not send more body bytes than what the max send + speed says. The headers do not count to the max speed. */ + if(data->set.max_send_speed) { + size_t body_bytes = blen - hds_len; + if((curl_off_t)body_bytes > data->set.max_send_speed) + blen = hds_len + (size_t)data->set.max_send_speed; + } + + if(data->req.eos_read && + (Curl_bufq_is_empty(&data->req.sendbuf) || + Curl_bufq_len(&data->req.sendbuf) == blen)) { + DEBUGF(infof(data, "sending last upload chunk of %zu bytes", blen)); + eos = TRUE; + } + result = Curl_xfer_send(data, buf, blen, eos, pnwritten); + if(!result) { + if(eos && (blen == *pnwritten)) + data->req.eos_sent = TRUE; + if(*pnwritten) { + if(hds_len) + Curl_debug(data, CURLINFO_HEADER_OUT, buf, + CURLMIN(hds_len, *pnwritten)); + if(*pnwritten > hds_len) { + size_t body_len = *pnwritten - hds_len; + Curl_debug(data, CURLINFO_DATA_OUT, buf + hds_len, body_len); + data->req.writebytecount += body_len; + Curl_pgrs_upload_inc(data, body_len); + } + } + } + return result; +} + +static CURLcode req_send_buffer_flush(struct Curl_easy *data) +{ + CURLcode result = CURLE_OK; + const unsigned char *buf; + size_t blen; + + while(Curl_bufq_peek(&data->req.sendbuf, &buf, &blen)) { + size_t nwritten, hds_len = CURLMIN(data->req.sendbuf_hds_len, blen); + result = xfer_send(data, (const char *)buf, blen, hds_len, &nwritten); + if(result) + break; + + Curl_bufq_skip(&data->req.sendbuf, nwritten); + if(hds_len) { + data->req.sendbuf_hds_len -= CURLMIN(hds_len, nwritten); + } + /* leave if we could not send all. Maybe network blocking or + * speed limits on transfer */ + if(nwritten < blen) + break; + } + return result; +} + +static CURLcode req_set_upload_done(struct Curl_easy *data) +{ + DEBUGASSERT(!data->req.upload_done); + data->req.upload_done = TRUE; + CURL_REQ_CLEAR_SEND(data); + + if(data->mstate >= MSTATE_DID) + Curl_pgrsTime(data, TIMER_POSTRANSFER); + Curl_creader_done(data, data->req.upload_aborted); + + if(data->req.upload_aborted) { + Curl_bufq_reset(&data->req.sendbuf); + if(data->req.writebytecount) + infof(data, "abort upload after having sent %" FMT_OFF_T " bytes", + data->req.writebytecount); + else + infof(data, "abort upload"); + } + else if(data->req.writebytecount) + infof(data, "upload completely sent off: %" FMT_OFF_T " bytes", + data->req.writebytecount); + else if(!data->req.download_done) { + DEBUGASSERT(Curl_bufq_is_empty(&data->req.sendbuf)); + infof(data, Curl_creader_total_length(data) ? + "We are completely uploaded and fine" : + "Request completely sent off"); + } + + return Curl_xfer_send_close(data); +} + +static CURLcode req_flush(struct Curl_easy *data) +{ + CURLcode result; + + if(!data || !data->conn) + return CURLE_FAILED_INIT; + + if(!Curl_bufq_is_empty(&data->req.sendbuf)) { + result = req_send_buffer_flush(data); + if(result) + return result; + if(!Curl_bufq_is_empty(&data->req.sendbuf)) { + DEBUGF(infof(data, "Curl_req_flush(len=%zu) -> EAGAIN", + Curl_bufq_len(&data->req.sendbuf))); + return CURLE_AGAIN; + } + } + else if(Curl_xfer_needs_flush(data)) { + DEBUGF(infof(data, "Curl_req_flush(), xfer send_pending")); + return Curl_xfer_flush(data); + } + + if(data->req.eos_read && !data->req.eos_sent) { + char tmp = 0; + size_t nwritten; + result = xfer_send(data, &tmp, 0, 0, &nwritten); + if(result) + return result; + DEBUGASSERT(data->req.eos_sent); + } + + if(!data->req.upload_done && data->req.eos_read && data->req.eos_sent) { + DEBUGASSERT(Curl_bufq_is_empty(&data->req.sendbuf)); + if(data->req.shutdown) { + bool done; + result = Curl_xfer_send_shutdown(data, &done); + if(result && data->req.shutdown_err_ignore) { + infof(data, "Shutdown send direction error: %d. Broken server? " + "Proceeding as if everything is ok.", (int)result); + result = CURLE_OK; + done = TRUE; + } + + if(result) + return result; + if(!done) + return CURLE_AGAIN; + } + return req_set_upload_done(data); + } + return CURLE_OK; +} + +static CURLcode add_from_client(void *reader_ctx, + unsigned char *buf, size_t buflen, + size_t *pnread) +{ + struct Curl_easy *data = reader_ctx; + CURLcode result; + bool eos; + + result = Curl_client_read(data, (char *)buf, buflen, pnread, &eos); + if(!result && eos) + data->req.eos_read = TRUE; + return result; +} + +static CURLcode req_send_buffer_add(struct Curl_easy *data, + const char *buf, size_t blen, + size_t hds_len) +{ + CURLcode result = CURLE_OK; + size_t n; + result = Curl_bufq_cwrite(&data->req.sendbuf, buf, blen, &n); + if(result) + return result; + /* We rely on a SOFTLIMIT on sendbuf, so it can take all data in */ + DEBUGASSERT(n == blen); + data->req.sendbuf_hds_len += hds_len; + return CURLE_OK; +} + +CURLcode Curl_req_send(struct Curl_easy *data, struct dynbuf *req, + unsigned char httpversion) +{ + CURLcode result; + const char *buf; + size_t blen, nwritten; + + if(!data || !data->conn) + return CURLE_FAILED_INIT; + + data->req.httpversion_sent = httpversion; + buf = curlx_dyn_ptr(req); + blen = curlx_dyn_len(req); + /* if the sendbuf is empty and the request without body and + * the length to send fits info a sendbuf chunk, we send it directly. + * If `blen` is larger than `chunk_size`, we can not. Because we + * might have to retry a blocked send later from sendbuf and that + * would result in retry sends with a shrunken length. That is trouble. */ + if(Curl_bufq_is_empty(&data->req.sendbuf) && + !Curl_creader_total_length(data) && + (blen <= data->req.sendbuf.chunk_size)) { + data->req.eos_read = TRUE; + result = xfer_send(data, buf, blen, blen, &nwritten); + if(result) + return result; + buf += nwritten; + blen -= nwritten; + if(!blen) { + result = req_set_upload_done(data); + if(result) + return result; + } + } + + if(blen) { + /* Either we have a request body, or we could not send the complete + * request in one go. Buffer the remainder and try to add as much + * body bytes as room is left in the buffer. Then flush. */ + result = req_send_buffer_add(data, buf, blen, blen); + if(result) + return result; + + return Curl_req_send_more(data); + } + return CURLE_OK; +} + +bool Curl_req_sendbuf_empty(struct Curl_easy *data) +{ + return !data->req.sendbuf_init || Curl_bufq_is_empty(&data->req.sendbuf); +} + +bool Curl_req_want_send(struct Curl_easy *data) +{ + /* Not done and upload not blocked and either one of + * - REQ_IO_SEND + * - request has buffered data to send + * - connection has pending data to send */ + return !data->req.done && + !Curl_rlimit_is_blocked(&data->progress.ul.rlimit) && + (CURL_REQ_WANT_SEND(data) || + !Curl_req_sendbuf_empty(data) || + Curl_xfer_needs_flush(data)); +} + +bool Curl_req_want_recv(struct Curl_easy *data) +{ + /* Not done and download not blocked and want RECV */ + return !data->req.done && + !Curl_rlimit_is_blocked(&data->progress.dl.rlimit) && + CURL_REQ_WANT_RECV(data); +} + +bool Curl_req_done_sending(struct Curl_easy *data) +{ + return data->req.upload_done && !Curl_req_want_send(data); +} + +CURLcode Curl_req_send_more(struct Curl_easy *data) +{ + CURLcode result; + + /* Fill our send buffer if more from client can be read. */ + if(!data->req.upload_aborted && + !data->req.eos_read && + !Curl_xfer_send_is_paused(data) && + !Curl_bufq_is_full(&data->req.sendbuf)) { + size_t nread; + result = Curl_bufq_sipn(&data->req.sendbuf, 0, + add_from_client, data, &nread); + if(result && result != CURLE_AGAIN) + return result; + } + + result = req_flush(data); + if(result == CURLE_AGAIN) + result = CURLE_OK; + + return result; +} + +CURLcode Curl_req_abort_sending(struct Curl_easy *data) +{ + if(!data->req.upload_done) { + Curl_bufq_reset(&data->req.sendbuf); + data->req.upload_aborted = TRUE; + CURL_REQ_CLEAR_SEND(data); + return req_set_upload_done(data); + } + return CURLE_OK; +} + +CURLcode Curl_req_stop_send_recv(struct Curl_easy *data) +{ + /* stop receiving and ALL sending as well, including PAUSE and HOLD. + * We might still be paused on receive client writes though, so + * keep those bits around. */ + CURLcode result = CURLE_OK; + if(CURL_REQ_WANT_SEND(data)) + result = Curl_req_abort_sending(data); + CURL_REQ_CLEAR_IO(data); + return result; +} diff --git a/3rdparty/curl-8.21.0/lib/request.h b/3rdparty/curl-8.21.0/lib/request.h new file mode 100644 index 0000000000..e67865a984 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/request.h @@ -0,0 +1,251 @@ +#ifndef HEADER_CURL_REQUEST_H +#define HEADER_CURL_REQUEST_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +/* This file is for lib internal stuff */ +#include "curl_setup.h" + +#include "bufq.h" + +/* forward declarations */ +struct UserDefined; + +/* Bits on the io_flags member of SingleRequest */ +#define REQ_IO_RECV (1 << 0) /* there is or may be data to read */ +#define REQ_IO_SEND (1 << 1) /* there is or may be data to write */ + +/* Low level request receive/send io_flags checks. */ +#define CURL_REQ_WANT_SEND(d) ((d)->req.io_flags & REQ_IO_SEND) +#define CURL_REQ_WANT_RECV(d) ((d)->req.io_flags & REQ_IO_RECV) +#define CURL_REQ_WANT_IO(d) \ + ((d)->req.io_flags & (REQ_IO_RECV | REQ_IO_SEND)) +/* Low level request receive/send io_flags manipulations. */ +#define CURL_REQ_SET_SEND(d) ((d)->req.io_flags |= REQ_IO_SEND) +#define CURL_REQ_SET_RECV(d) ((d)->req.io_flags |= REQ_IO_RECV) +#define CURL_REQ_CLEAR_SEND(d) \ + ((d)->req.io_flags &= (uint8_t)~REQ_IO_SEND) +#define CURL_REQ_CLEAR_RECV(d) \ + ((d)->req.io_flags &= (uint8_t)~REQ_IO_RECV) +#define CURL_REQ_CLEAR_IO(d) \ + ((d)->req.io_flags &= (uint8_t)~(REQ_IO_RECV | REQ_IO_SEND)) + +enum expect100 { + EXP100_SEND_DATA, /* enough waiting, send the body now */ + EXP100_AWAITING_CONTINUE, /* waiting for the 100 Continue header */ + EXP100_SENDING_REQUEST, /* still sending the request but will wait for + the 100 header once done with the request */ + EXP100_FAILED /* used on 417 Expectation Failed */ +}; + +enum upgrade101 { + UPGR101_NONE, /* default state */ + UPGR101_WS, /* upgrade to WebSocket requested */ + UPGR101_H2, /* upgrade to HTTP/2 requested */ + UPGR101_RECEIVED /* 101 response received */ +}; + +/* + * Request specific data in the easy handle (Curl_easy). Previously, + * these members were on the connectdata struct but since a conn struct may + * now be shared between different Curl_easys, we store connection-specific + * data here. This struct only keeps stuff that is interesting for *this* + * request, as it will be cleared between multiple ones + */ +struct SingleRequest { + curl_off_t size; /* -1 if unknown at this point */ + curl_off_t maxdownload; /* in bytes, the maximum amount of data to fetch, + -1 means unlimited */ + curl_off_t bytecount; /* total number of bytes read */ + curl_off_t writebytecount; /* number of bytes written */ + curl_off_t offset; /* possible resume offset read from the + Content-Range: header */ + + struct curltime start; /* transfer started at this time */ + unsigned int headerbytecount; /* received server headers (not CONNECT + headers) */ + unsigned int allheadercount; /* all received headers (server + CONNECT) */ + unsigned int deductheadercount; /* this amount of bytes does not count when + we check if anything has been transferred + at the end of a connection. We use this + counter to make only a 100 reply (without + a following second response code) result + in a CURLE_GOT_NOTHING error code */ + int headerline; /* counts header lines to better track the + first one */ + int httpcode; /* error code from the 'HTTP/1.? XXX' or + 'RTSP/1.? XXX' line */ + unsigned char httpversion_sent; /* Version in request (09, 10, 11, etc.) */ + unsigned char httpversion; /* Version in response (09, 10, 11, etc.) */ + enum upgrade101 upgr101; /* 101 upgrade state */ + + /* Client Writer stack, handles transfer- and content-encodings, protocol + * checks, pausing by client callbacks. */ + struct Curl_cwriter *writer_stack; + /* Client Reader stack, handles transfer- and content-encodings, protocol + * checks, pausing by client callbacks. */ + struct Curl_creader *reader_stack; + struct bufq sendbuf; /* data which needs to be send to the server */ + size_t sendbuf_hds_len; /* amount of header bytes in sendbuf */ + time_t timeofdoc; + char *location; /* This points to an allocated version of the Location: + header data */ + char *newurl; /* Set to the new URL to use when a redirect or a retry is + wanted */ + uint8_t io_flags; /* REQ_IO_RECV | REQ_IO_SEND */ + + char *hd_auth; /* Authorization header, full HTTP/1.x line */ +#ifndef CURL_DISABLE_PROXY + char *hd_proxy_auth; /* Proxy-Authorization header, full HTTP/1.x line */ +#endif +#ifndef CURL_DISABLE_COOKIES + char *cookiehost; +#endif +#ifndef CURL_DISABLE_COOKIES + unsigned char setcookies; +#endif + BIT(header); /* incoming data has HTTP header */ + BIT(done); /* request is done, e.g. no more send/recv should + * happen. This can be TRUE before `upload_done` or + * `download_done` is TRUE. */ + BIT(content_range); /* set TRUE if Content-Range: was found */ + BIT(download_done); /* set to TRUE when download is complete */ + BIT(eos_written); /* iff EOS has been written to client */ + BIT(eos_read); /* iff EOS has been read from the client */ + BIT(eos_sent); /* iff EOS has been sent to the server */ + BIT(rewind_read); /* iff reader needs rewind at next start */ + BIT(upload_done); /* set to TRUE when all request data has been sent */ + BIT(upload_aborted); /* set to TRUE when upload was aborted. Also + * shows `upload_done` as TRUE. */ + BIT(ignorebody); /* we read a response-body but we ignore it! */ + BIT(http_bodyless); /* HTTP response status code is between 100 and 199, + 204 or 304 */ + BIT(chunk); /* if set, this is a chunked transfer-encoding */ + BIT(resp_trailer); /* response carried 'Trailer:' header field */ + BIT(ignore_cl); /* ignore content-length */ + BIT(upload_chunky); /* set TRUE if we are doing chunked transfer-encoding + on upload */ + BIT(no_body); /* the response has no body */ + BIT(authneg); /* TRUE when the auth phase has started, which means + that we are creating a request with an auth header, + but it is not the final request in the auth + negotiation. */ + BIT(sendbuf_init); /* sendbuf is initialized */ + BIT(shutdown); /* request end will shutdown connection */ + BIT(shutdown_err_ignore); /* errors in shutdown will not fail request */ + BIT(reader_started); /* client reads have started */ +}; + +/** + * Initialize the state of the request for first use. + */ +void Curl_req_init(struct SingleRequest *req); + +/** + * The request is about to start. Record time and do a soft reset. + */ +CURLcode Curl_req_start(struct SingleRequest *req, + struct Curl_easy *data); + +/** + * The request may continue with a follow up. Reset + * members, but keep start time for overall duration calc. + */ +CURLcode Curl_req_soft_reset(struct SingleRequest *req, + struct Curl_easy *data); + +/** + * The request is done. If not aborted, make sure that buffers are + * flushed to the client. + * @param req the request + * @param data the transfer + * @param aborted TRUE iff the request was aborted/errored + */ +CURLcode Curl_req_done(struct SingleRequest *req, + struct Curl_easy *data, bool aborted); + +/** + * Free the state of the request, not usable afterwards. + */ +void Curl_req_free(struct SingleRequest *req, struct Curl_easy *data); + +/** + * Hard reset the state of the request to virgin state base on + * transfer settings. + */ +void Curl_req_hard_reset(struct SingleRequest *req, struct Curl_easy *data); + +/** + * Send request headers. If not all could be sent + * they will be buffered. Use `Curl_req_flush()` to make sure + * bytes are really send. + * @param data the transfer making the request + * @param req the complete header bytes, no body + * @param httpversion version used in request (09, 10, 11, etc.) + * @return CURLE_OK (on blocking with *pnwritten == 0) or error. + */ +CURLcode Curl_req_send(struct Curl_easy *data, struct dynbuf *req, + unsigned char httpversion); + +/** + * TRUE iff the request has sent all request headers and data. + */ +bool Curl_req_done_sending(struct Curl_easy *data); + +/* + * Read more from client and flush all buffered request bytes. + * @return CURLE_OK on success or the error on the sending. + * Never returns CURLE_AGAIN. + */ +CURLcode Curl_req_send_more(struct Curl_easy *data); + +/* TRUE if the request wants to send, e.g. is not done sending + * and is not blocked. */ +bool Curl_req_want_send(struct Curl_easy *data); + +/* TRUE if the request wants to receive and is not blocked. */ +bool Curl_req_want_recv(struct Curl_easy *data); + +/** + * TRUE iff the request has no buffered bytes yet to send. + */ +bool Curl_req_sendbuf_empty(struct Curl_easy *data); + +/** + * Stop sending any more request data to the server. + * Clear the send buffer and mark request sending as done. + */ +CURLcode Curl_req_abort_sending(struct Curl_easy *data); + +/** + * Stop sending and receiving any more request data. + * Abort sending if not done. + */ +CURLcode Curl_req_stop_send_recv(struct Curl_easy *data); + +/** + * Invoked when all request data has been uploaded. + */ +CURLcode Curl_req_set_upload_done(struct Curl_easy *data); + +#endif /* HEADER_CURL_REQUEST_H */ diff --git a/3rdparty/curl-8.21.0/lib/rtsp.c b/3rdparty/curl-8.21.0/lib/rtsp.c new file mode 100644 index 0000000000..8c5cdd5643 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/rtsp.c @@ -0,0 +1,1057 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" +#include "urldata.h" +#include "rtsp.h" + +#ifndef CURL_DISABLE_RTSP + +#include "transfer.h" +#include "sendf.h" +#include "curl_trc.h" +#include "multiif.h" +#include "http.h" +#include "url.h" +#include "progress.h" +#include "strcase.h" +#include "select.h" +#include "connect.h" +#include "cfilters.h" +#include "curlx/strdup.h" +#include "bufref.h" +#include "curlx/strparse.h" + +/* meta key for storing protocol meta at easy handle */ +#define CURL_META_RTSP_EASY "meta:proto:rtsp:easy" +/* meta key for storing protocol meta at connection */ +#define CURL_META_RTSP_CONN "meta:proto:rtsp:conn" + +typedef enum { + RTP_PARSE_SKIP, + RTP_PARSE_CHANNEL, + RTP_PARSE_LEN, + RTP_PARSE_DATA +} rtp_parse_st; + +/* RTSP Connection data + * Currently, only used for tracking incomplete RTP data reads */ +struct rtsp_conn { + struct dynbuf buf; + int rtp_channel; + size_t rtp_len; + rtp_parse_st state; + BIT(in_header); +}; + +/* RTSP transfer data */ +struct RTSP { + uint32_t CSeq_sent; /* CSeq of this request */ + uint32_t CSeq_recv; /* CSeq received */ +}; + +#define RTP_PKT_LENGTH(p) ((((unsigned int)((unsigned char)((p)[2]))) << 8) | \ + ((unsigned int)((unsigned char)((p)[3])))) + +/* this returns the socket to wait for in the DO and DOING state for the multi + interface and then we are always _sending_ a request and thus we wait for + the single socket to become writable only */ +static CURLcode rtsp_do_pollset(struct Curl_easy *data, + struct easy_pollset *ps) +{ + /* write mode */ + return Curl_pollset_add_out(data, ps, data->conn->sock[FIRSTSOCKET]); +} + +#define MAX_RTP_BUFFERSIZE 1000000 /* arbitrary */ + +static void rtsp_easy_dtor(void *key, size_t klen, void *entry) +{ + struct RTSP *rtsp = entry; + (void)key; + (void)klen; + curlx_free(rtsp); +} + +static void rtsp_conn_dtor(void *key, size_t klen, void *entry) +{ + struct rtsp_conn *rtspc = entry; + (void)key; + (void)klen; + curlx_dyn_free(&rtspc->buf); + curlx_free(rtspc); +} + +static CURLcode rtsp_setup_connection(struct Curl_easy *data, + struct connectdata *conn) +{ + struct rtsp_conn *rtspc; + struct RTSP *rtsp; + + rtspc = curlx_calloc(1, sizeof(*rtspc)); + if(!rtspc) + return CURLE_OUT_OF_MEMORY; + curlx_dyn_init(&rtspc->buf, MAX_RTP_BUFFERSIZE); + if(Curl_conn_meta_set(conn, CURL_META_RTSP_CONN, rtspc, rtsp_conn_dtor)) + return CURLE_OUT_OF_MEMORY; + + rtsp = curlx_calloc(1, sizeof(struct RTSP)); + if(!rtsp || + Curl_meta_set(data, CURL_META_RTSP_EASY, rtsp, rtsp_easy_dtor)) + return CURLE_OUT_OF_MEMORY; + + return CURLE_OK; +} + +/* + * Function to check on various aspects of a connection. + */ +static bool rtsp_conn_is_dead(struct Curl_easy *data, + struct connectdata *conn) +{ + bool input_pending; + /* Contrary to default handling, this protocol allows pending + * input on an unused connection. */ + return !Curl_conn_is_alive(data, conn, &input_pending); +} + +static CURLcode rtsp_connect(struct Curl_easy *data, bool *done) +{ + struct rtsp_conn *rtspc = + Curl_conn_meta_get(data->conn, CURL_META_RTSP_CONN); + + if(!rtspc) + return CURLE_FAILED_INIT; + + /* Initialize the CSeq if not already done */ + if(data->state.rtsp_next_client_CSeq == 0) + data->state.rtsp_next_client_CSeq = 1; + if(data->state.rtsp_next_server_CSeq == 0) + data->state.rtsp_next_server_CSeq = 1; + + rtspc->rtp_channel = -1; + *done = TRUE; + return CURLE_OK; +} + +static CURLcode rtsp_done(struct Curl_easy *data, + CURLcode status, bool premature) +{ + struct rtsp_conn *rtspc = + Curl_conn_meta_get(data->conn, CURL_META_RTSP_CONN); + struct RTSP *rtsp = Curl_meta_get(data, CURL_META_RTSP_EASY); + CURLcode result; + + if(!rtspc || !rtsp) + return CURLE_FAILED_INIT; + + /* Bypass HTTP empty-reply checks on receive */ + if(data->set.rtspreq == RTSPREQ_RECEIVE) + premature = TRUE; + + result = Curl_http_done(data, status, premature); + + if(!status && !result) { + /* Check the sequence numbers */ + uint32_t CSeq_sent = rtsp->CSeq_sent; + uint32_t CSeq_recv = rtsp->CSeq_recv; + if((data->set.rtspreq != RTSPREQ_RECEIVE) && (CSeq_sent != CSeq_recv)) { + failf(data, + "The CSeq of this request %u did not match the response %u", + CSeq_sent, CSeq_recv); + return CURLE_RTSP_CSEQ_ERROR; + } + if(data->set.rtspreq == RTSPREQ_RECEIVE && (rtspc->rtp_channel == -1)) { + infof(data, "Got an RTP Receive with a CSeq of %u", CSeq_recv); + } + if(data->set.rtspreq == RTSPREQ_RECEIVE && + data->req.eos_written) { + failf(data, "Server prematurely closed the RTSP connection."); + return CURLE_RECV_ERROR; + } + } + + return result; +} + +static CURLcode rtsp_setup_body(struct Curl_easy *data, + Curl_RtspReq rtspreq, + struct dynbuf *reqp) +{ + CURLcode result; + if(rtspreq == RTSPREQ_ANNOUNCE || + rtspreq == RTSPREQ_SET_PARAMETER || + rtspreq == RTSPREQ_GET_PARAMETER) { + curl_off_t req_clen; /* request content length */ + + if(data->state.upload) { + req_clen = data->state.infilesize; + data->state.httpreq = HTTPREQ_PUT; + result = Curl_creader_set_fread(data, req_clen); + if(result) + return result; + } + else { + if(data->set.postfields) { + size_t plen = (data->set.postfieldsize >= 0) ? + (size_t)data->set.postfieldsize : strlen(data->set.postfields); + req_clen = (curl_off_t)plen; + result = Curl_creader_set_buf(data, data->set.postfields, plen); + } + else if(data->state.infilesize >= 0) { + req_clen = data->state.infilesize; + result = Curl_creader_set_fread(data, req_clen); + } + else { + req_clen = 0; + result = Curl_creader_set_null(data); + } + if(result) + return result; + } + + if(req_clen > 0) { + /* As stated in the http comments, it is probably not wise to + * actually set a custom Content-Length in the headers */ + if(!Curl_checkheaders(data, STRCONST("Content-Length"))) { + result = curlx_dyn_addf(reqp, "Content-Length: %" FMT_OFF_T "\r\n", + req_clen); + if(result) + return result; + } + + if(rtspreq == RTSPREQ_SET_PARAMETER || + rtspreq == RTSPREQ_GET_PARAMETER) { + if(!Curl_checkheaders(data, STRCONST("Content-Type"))) { + result = curlx_dyn_addn(reqp, STRCONST("Content-Type: " + "text/parameters\r\n")); + if(result) + return result; + } + } + + if(rtspreq == RTSPREQ_ANNOUNCE) { + if(!Curl_checkheaders(data, STRCONST("Content-Type"))) { + result = curlx_dyn_addn(reqp, STRCONST("Content-Type: " + "application/sdp\r\n")); + if(result) + return result; + } + } + } + else if(rtspreq == RTSPREQ_GET_PARAMETER) { + /* Check for an empty GET_PARAMETER (heartbeat) request */ + data->state.httpreq = HTTPREQ_HEAD; + data->req.no_body = TRUE; + } + } + else + result = Curl_creader_set_null(data); + return result; +} + +static CURLcode rtsp_do(struct Curl_easy *data, bool *done) +{ + struct connectdata *conn = data->conn; + CURLcode result = CURLE_OK; + const Curl_RtspReq rtspreq = data->set.rtspreq; + struct RTSP *rtsp = Curl_meta_get(data, CURL_META_RTSP_EASY); + struct dynbuf req_buffer; + const unsigned char httpversion = 11; /* RTSP is close to HTTP/1.1, sort + of... */ + const char *p_request = NULL; + const char *p_session_id = NULL; + const char *p_accept = NULL; + const char *p_accept_encoding = NULL; + const char *p_range = NULL; + const char *p_referrer = NULL; + const char *p_stream_uri = NULL; + const char *p_transport = NULL; + const char *p_uagent = NULL; + const char *p_hd_proxy_auth = NULL; + const char *p_hd_auth = NULL; + + *done = TRUE; + if(!rtsp) + return CURLE_FAILED_INIT; + + /* Initialize a dynamic send buffer */ + curlx_dyn_init(&req_buffer, DYN_RTSP_REQ_HEADER); + + rtsp->CSeq_sent = data->state.rtsp_next_client_CSeq; + rtsp->CSeq_recv = 0; + + /* Setup the 'p_request' pointer to the proper p_request string + * Since all RTSP requests are included here, there is no need to + * support custom requests like HTTP. + **/ + data->req.no_body = TRUE; /* most requests do not contain a body */ + switch(rtspreq) { + default: + failf(data, "Got invalid RTSP request"); + return CURLE_BAD_FUNCTION_ARGUMENT; + case RTSPREQ_OPTIONS: + p_request = "OPTIONS"; + break; + case RTSPREQ_DESCRIBE: + p_request = "DESCRIBE"; + data->req.no_body = FALSE; + break; + case RTSPREQ_ANNOUNCE: + p_request = "ANNOUNCE"; + break; + case RTSPREQ_SETUP: + p_request = "SETUP"; + break; + case RTSPREQ_PLAY: + p_request = "PLAY"; + break; + case RTSPREQ_PAUSE: + p_request = "PAUSE"; + break; + case RTSPREQ_TEARDOWN: + p_request = "TEARDOWN"; + break; + case RTSPREQ_GET_PARAMETER: + /* GET_PARAMETER's no_body status is determined later */ + p_request = "GET_PARAMETER"; + data->req.no_body = FALSE; + break; + case RTSPREQ_SET_PARAMETER: + p_request = "SET_PARAMETER"; + break; + case RTSPREQ_RECORD: + p_request = "RECORD"; + break; + case RTSPREQ_RECEIVE: + p_request = ""; + /* Treat interleaved RTP as body */ + data->req.no_body = FALSE; + break; + case RTSPREQ_LAST: + failf(data, "Got invalid RTSP request: RTSPREQ_LAST"); + return CURLE_BAD_FUNCTION_ARGUMENT; + } + + if(rtspreq == RTSPREQ_RECEIVE) { + Curl_xfer_setup_recv(data, FIRSTSOCKET, -1); + goto out; + } + + p_session_id = data->set.str[STRING_RTSP_SESSION_ID]; + if(!p_session_id && + (rtspreq & ~(Curl_RtspReq)(RTSPREQ_OPTIONS | + RTSPREQ_DESCRIBE | + RTSPREQ_SETUP))) { + failf(data, "Refusing to issue an RTSP request [%s] without a session ID.", + p_request); + result = CURLE_BAD_FUNCTION_ARGUMENT; + goto out; + } + + /* Stream URI. Default to server '*' if not specified */ + if(data->set.str[STRING_RTSP_STREAM_URI]) { + p_stream_uri = data->set.str[STRING_RTSP_STREAM_URI]; + } + else { + p_stream_uri = "*"; + } + + /* Transport Header for SETUP requests */ + p_transport = Curl_checkheaders(data, STRCONST("Transport")); + if(rtspreq == RTSPREQ_SETUP && !p_transport) { + /* New Transport: setting? */ + if(data->set.str[STRING_RTSP_TRANSPORT]) { + curlx_free(data->state.aptr.rtsp_transport); + data->state.aptr.rtsp_transport = + curl_maprintf("Transport: %s\r\n", + data->set.str[STRING_RTSP_TRANSPORT]); + if(!data->state.aptr.rtsp_transport) + return CURLE_OUT_OF_MEMORY; + } + else { + failf(data, + "Refusing to issue an RTSP SETUP without a Transport: header."); + result = CURLE_BAD_FUNCTION_ARGUMENT; + goto out; + } + + p_transport = data->state.aptr.rtsp_transport; + } + + /* Accept Headers for DESCRIBE requests */ + if(rtspreq == RTSPREQ_DESCRIBE) { + /* Accept Header */ + p_accept = Curl_checkheaders(data, STRCONST("Accept")) ? + NULL : "Accept: application/sdp\r\n"; + + /* Accept-Encoding header */ + if(!Curl_checkheaders(data, STRCONST("Accept-Encoding")) && + data->set.str[STRING_ENCODING]) { + curlx_free(data->state.aptr.accept_encoding); + data->state.aptr.accept_encoding = + curl_maprintf("Accept-Encoding: %s\r\n", + data->set.str[STRING_ENCODING]); + + if(!data->state.aptr.accept_encoding) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + p_accept_encoding = data->state.aptr.accept_encoding; + } + } + + /* The User-Agent string might have been allocated already, because + it might have been used in the proxy connect, but if we have got a header + with the user-agent string specified, we erase the previously made string + here. */ + if(Curl_checkheaders(data, STRCONST("User-Agent")) && + data->state.aptr.uagent) { + curlx_safefree(data->state.aptr.uagent); + } + else if(!Curl_checkheaders(data, STRCONST("User-Agent")) && + data->set.str[STRING_USERAGENT]) { + p_uagent = data->state.aptr.uagent; + } + + /* setup the authentication headers */ + result = Curl_http_output_auth(data, conn, p_request, HTTPREQ_GET, + p_stream_uri, NULL, FALSE); + if(result) + goto out; + +#ifndef CURL_DISABLE_PROXY + p_hd_proxy_auth = data->req.hd_proxy_auth; +#endif + p_hd_auth = data->req.hd_auth; + + /* Referrer */ + curlx_safefree(data->state.aptr.ref); + if(Curl_bufref_ptr(&data->state.referer) && + !Curl_checkheaders(data, STRCONST("Referer"))) + data->state.aptr.ref = + curl_maprintf("Referer: %s\r\n", Curl_bufref_ptr(&data->state.referer)); + + p_referrer = data->state.aptr.ref; + + /* + * Range Header + * Only applies to PLAY, PAUSE, RECORD + * + * Go ahead and use the Range stuff supplied for HTTP + */ + if(data->state.use_range && + (rtspreq & (RTSPREQ_PLAY | RTSPREQ_PAUSE | RTSPREQ_RECORD))) { + + /* Check to see if there is a range set in the custom headers */ + if(!Curl_checkheaders(data, STRCONST("Range")) && data->state.range) { + curlx_free(data->state.aptr.rangeline); + data->state.aptr.rangeline = curl_maprintf("Range: %s\r\n", + data->state.range); + p_range = data->state.aptr.rangeline; + } + } + + /* + * Sanity check the custom headers + */ + if(Curl_checkheaders(data, STRCONST("CSeq"))) { + failf(data, "CSeq cannot be set as a custom header."); + result = CURLE_RTSP_CSEQ_ERROR; + goto out; + } + if(Curl_checkheaders(data, STRCONST("Session"))) { + failf(data, "Session ID cannot be set as a custom header."); + result = CURLE_BAD_FUNCTION_ARGUMENT; + goto out; + } + + result = + curlx_dyn_addf(&req_buffer, + "%s %s RTSP/1.0\r\n" /* Request Stream-URI RTSP/1.0 */ + "CSeq: %u\r\n", /* CSeq */ + p_request, p_stream_uri, rtsp->CSeq_sent); + if(result) + goto out; + + /* + * Rather than do a normal alloc line, keep the session_id unformatted + * to make comparison easier + */ + if(p_session_id) { + result = curlx_dyn_addf(&req_buffer, "Session: %s\r\n", p_session_id); + if(result) + goto out; + } + + /* + * Shared HTTP-like options + */ + result = curlx_dyn_addf(&req_buffer, + "%s" /* transport */ + "%s" /* accept */ + "%s" /* accept-encoding */ + "%s" /* range */ + "%s" /* referrer */ + "%s" /* user-agent */ + "%s" /* hd_proxy_auth */ + "%s" /* hd_auth */ + , + p_transport ? p_transport : "", + p_accept ? p_accept : "", + p_accept_encoding ? p_accept_encoding : "", + p_range ? p_range : "", + p_referrer ? p_referrer : "", + p_uagent ? p_uagent : "", + p_hd_proxy_auth ? p_hd_proxy_auth : "", + p_hd_auth ? p_hd_auth : ""); + + if(result) + goto out; + + if((rtspreq == RTSPREQ_SETUP) || (rtspreq == RTSPREQ_DESCRIBE)) { + result = Curl_add_timecondition(data, &req_buffer); + if(result) + goto out; + } + + result = Curl_add_custom_headers(data, FALSE, httpversion, &req_buffer); + if(result) + goto out; + + result = rtsp_setup_body(data, rtspreq, &req_buffer); + if(result) + goto out; + + /* Finish the request buffer */ + result = curlx_dyn_addn(&req_buffer, STRCONST("\r\n")); + if(result) + goto out; + + Curl_xfer_setup_sendrecv(data, FIRSTSOCKET, -1); + + /* issue the request */ + result = Curl_req_send(data, &req_buffer, httpversion); + if(result) { + failf(data, "Failed sending RTSP request"); + goto out; + } + + /* Increment the CSeq on success */ + data->state.rtsp_next_client_CSeq++; + + if(data->req.writebytecount) { + /* if a request-body has been sent off, we make sure this progress is + noted properly */ + Curl_pgrsSetUploadCounter(data, data->req.writebytecount); + result = Curl_pgrsUpdate(data); + } +out: + curlx_dyn_free(&req_buffer); + return result; +} + +/** + * write any BODY bytes missing to the client, ignore the rest. + */ +static CURLcode rtp_write_body_junk(struct Curl_easy *data, + struct rtsp_conn *rtspc, + const char *buf, + size_t blen) +{ + curl_off_t body_remain; + bool in_body; + + in_body = (data->req.headerline && !rtspc->in_header) && + (data->req.size >= 0) && + (data->req.bytecount < data->req.size); + body_remain = in_body ? (data->req.size - data->req.bytecount) : 0; + DEBUGASSERT(body_remain >= 0); + if(body_remain) { + if((curl_off_t)blen > body_remain) + blen = (size_t)body_remain; + return Curl_client_write(data, CLIENTWRITE_BODY, buf, blen); + } + return CURLE_OK; +} + +static CURLcode rtp_client_write(struct Curl_easy *data, const char *ptr, + size_t len) +{ + size_t wrote; + curl_write_callback writeit; + void *user_ptr; + + if(len == 0) { + failf(data, "Cannot write a 0 size RTP packet."); + return CURLE_WRITE_ERROR; + } + + /* If the user has configured CURLOPT_INTERLEAVEFUNCTION then use that + function and any configured CURLOPT_INTERLEAVEDATA to write out the RTP + data. Otherwise, use the CURLOPT_WRITEFUNCTION with the CURLOPT_WRITEDATA + pointer to write out the RTP data. */ + if(data->set.fwrite_rtp) { + writeit = data->set.fwrite_rtp; + user_ptr = data->set.rtp_out; + } + else { + writeit = data->set.fwrite_func; + user_ptr = data->set.out; + } + + Curl_set_in_callback(data, TRUE); + wrote = writeit((char *)CURL_UNCONST(ptr), 1, len, user_ptr); + Curl_set_in_callback(data, FALSE); + + if(wrote == CURL_WRITEFUNC_PAUSE) { + failf(data, "Cannot pause RTP"); + return CURLE_WRITE_ERROR; + } + + if(wrote != len) { + failf(data, "Failed writing RTP data"); + return CURLE_WRITE_ERROR; + } + + return CURLE_OK; +} + +static CURLcode rtsp_filter_rtp(struct Curl_easy *data, + struct rtsp_conn *rtspc, + const char *buf, + size_t blen, + size_t *pconsumed) +{ + CURLcode result = CURLE_OK; + size_t skip_len = 0; + + *pconsumed = 0; + while(blen) { + bool in_body = (data->req.headerline && !rtspc->in_header) && + (data->req.size >= 0) && + (data->req.bytecount < data->req.size); + switch(rtspc->state) { + + case RTP_PARSE_SKIP: { + DEBUGASSERT(curlx_dyn_len(&rtspc->buf) == 0); + while(blen && buf[0] != '$') { + if(!in_body && buf[0] == 'R' && + data->set.rtspreq != RTSPREQ_RECEIVE) { + if(!strncmp(buf, "RTSP/", (blen < 5) ? blen : 5)) { + /* This could be the next response, no consume and return */ + if(*pconsumed) { + DEBUGF(infof(data, "RTP rtsp_filter_rtp[SKIP] RTSP/ prefix, " + "skipping %zu bytes of junk", *pconsumed)); + } + rtspc->state = RTP_PARSE_SKIP; + rtspc->in_header = TRUE; + goto out; + } + } + /* junk/BODY, consume without buffering */ + *pconsumed += 1; + ++buf; + --blen; + ++skip_len; + } + if(blen && buf[0] == '$') { + /* possible start of an RTP message, buffer */ + if(skip_len) { + /* end of junk/BODY bytes, flush */ + result = rtp_write_body_junk(data, rtspc, buf - skip_len, skip_len); + skip_len = 0; + if(result) + goto out; + } + if(curlx_dyn_addn(&rtspc->buf, buf, 1)) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + *pconsumed += 1; + ++buf; + --blen; + rtspc->state = RTP_PARSE_CHANNEL; + } + break; + } + + case RTP_PARSE_CHANNEL: { + int idx = ((unsigned char)buf[0]) / 8; + int off = ((unsigned char)buf[0]) % 8; + DEBUGASSERT(curlx_dyn_len(&rtspc->buf) == 1); + if(!(data->state.rtp_channel_mask[idx] & (1 << off))) { + /* invalid channel number, junk or BODY data */ + rtspc->state = RTP_PARSE_SKIP; + DEBUGASSERT(skip_len == 0); + /* we do not consume this byte, it is BODY data */ + DEBUGF(infof(data, "RTSP: invalid RTP channel %d, skipping", idx)); + if(*pconsumed == 0) { + /* We did not consume the initial '$' in our buffer, but had + * it from an earlier call. We cannot un-consume it and have + * to write it directly as BODY data */ + result = rtp_write_body_junk(data, rtspc, + curlx_dyn_ptr(&rtspc->buf), 1); + if(result) + goto out; + } + else { + /* count the '$' as skip and continue */ + skip_len = 1; + } + curlx_dyn_free(&rtspc->buf); + break; + } + /* a valid channel, so we expect this to be a real RTP message */ + rtspc->rtp_channel = (unsigned char)buf[0]; + if(curlx_dyn_addn(&rtspc->buf, buf, 1)) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + *pconsumed += 1; + ++buf; + --blen; + rtspc->state = RTP_PARSE_LEN; + break; + } + + case RTP_PARSE_LEN: { + size_t rtp_len = curlx_dyn_len(&rtspc->buf); + const char *rtp_buf; + DEBUGASSERT(rtp_len >= 2 && rtp_len < 4); + if(curlx_dyn_addn(&rtspc->buf, buf, 1)) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + *pconsumed += 1; + ++buf; + --blen; + if(rtp_len == 2) + break; + rtp_buf = curlx_dyn_ptr(&rtspc->buf); + rtspc->rtp_len = RTP_PKT_LENGTH(rtp_buf) + 4; + if(rtspc->rtp_len == 4) { + /* zero-length payload, the 4-byte header is the complete RTP + message. Dispatch immediately without entering RTP_PARSE_DATA. */ + DEBUGF(infof(data, "RTP write channel %d rtp_len %zu (no payload)", + rtspc->rtp_channel, rtspc->rtp_len)); + result = rtp_client_write(data, rtp_buf, rtspc->rtp_len); + curlx_dyn_free(&rtspc->buf); + rtspc->state = RTP_PARSE_SKIP; + if(result) + goto out; + break; + } + rtspc->state = RTP_PARSE_DATA; + break; + } + + case RTP_PARSE_DATA: { + size_t rtp_len = curlx_dyn_len(&rtspc->buf); + size_t needed; + DEBUGASSERT(rtp_len < rtspc->rtp_len); + needed = rtspc->rtp_len - rtp_len; + if(needed <= blen) { + if(curlx_dyn_addn(&rtspc->buf, buf, needed)) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + *pconsumed += needed; + buf += needed; + blen -= needed; + /* complete RTP message in buffer */ + DEBUGF(infof(data, "RTP write channel %d rtp_len %zu", + rtspc->rtp_channel, rtspc->rtp_len)); + result = rtp_client_write(data, curlx_dyn_ptr(&rtspc->buf), + rtspc->rtp_len); + curlx_dyn_free(&rtspc->buf); + rtspc->state = RTP_PARSE_SKIP; + if(result) + goto out; + } + else { + if(curlx_dyn_addn(&rtspc->buf, buf, blen)) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + *pconsumed += blen; + buf += blen; + blen = 0; + } + break; + } + + default: + DEBUGASSERT(0); + return CURLE_RECV_ERROR; + } + } +out: + if(!result && skip_len) + result = rtp_write_body_junk(data, rtspc, buf - skip_len, skip_len); + return result; +} + +/* + * Parse and write out an RTSP response. + * @param data the transfer + * @param conn the connection + * @param buf data read from connection + * @param blen amount of data in buf + * @param is_eos TRUE iff this is the last write + * @param readmore out, TRUE iff complete buf was consumed and more data + * is needed + */ +static CURLcode rtsp_rtp_write_resp(struct Curl_easy *data, + const char *buf, + size_t blen, + bool is_eos) +{ + struct rtsp_conn *rtspc = + Curl_conn_meta_get(data->conn, CURL_META_RTSP_CONN); + CURLcode result = CURLE_OK; + size_t consumed = 0; + + if(!rtspc) + return CURLE_FAILED_INIT; + + if(!data->req.header) + rtspc->in_header = FALSE; + if(!blen) { + goto out; + } + + DEBUGF(infof(data, "rtsp_rtp_write_resp(len=%zu, in_header=%d, eos=%d)", + blen, rtspc->in_header, is_eos)); + + /* If header parsing is not ongoing, extract RTP messages */ + if(!rtspc->in_header) { + result = rtsp_filter_rtp(data, rtspc, buf, blen, &consumed); + if(result) + goto out; + buf += consumed; + blen -= consumed; + /* either we consumed all or are at the start of header parsing */ + if(blen && !data->req.header) + DEBUGF(infof(data, "RTSP: %zu bytes, possibly excess in response body", + blen)); + } + + /* we want to parse headers, do so */ + if(data->req.header && blen) { + rtspc->in_header = TRUE; + result = Curl_http_write_resp_hds(data, buf, blen, &consumed); + if(result) + goto out; + + buf += consumed; + blen -= consumed; + + if(!data->req.header) + rtspc->in_header = FALSE; + + if(!rtspc->in_header) { + /* If header parsing is done, extract interleaved RTP messages */ + if(data->req.size <= -1) { + /* Respect section 4.4 of rfc2326: If the Content-Length header is + absent, a length 0 must be assumed. */ + data->req.size = 0; + data->req.download_done = TRUE; + } + result = rtsp_filter_rtp(data, rtspc, buf, blen, &consumed); + if(result) + goto out; + buf += consumed; + blen -= consumed; + } + } + + if(rtspc->state != RTP_PARSE_SKIP) + data->req.done = FALSE; + /* we SHOULD have consumed all bytes, unless the response is borked. + * In which case we write out the left over bytes, letting the client + * writer deal with it (it will report EXCESS and fail the transfer). */ + DEBUGF(infof(data, "rtsp_rtp_write_resp(len=%zu, in_header=%d, done=%d, " + "rtspc->state=%d, req.size=%" FMT_OFF_T ")", + blen, rtspc->in_header, data->req.done, (int)rtspc->state, + data->req.size)); + if(!result && (is_eos || blen)) { + result = Curl_client_write(data, CLIENTWRITE_BODY | + (is_eos ? CLIENTWRITE_EOS : 0), buf, blen); + } + +out: + if((data->set.rtspreq == RTSPREQ_RECEIVE) && + (rtspc->state == RTP_PARSE_SKIP)) { + /* In special mode RECEIVE, we process one chunk of network + * data, so we stop the transfer here, if we have no incomplete + * RTP message pending. */ + data->req.download_done = TRUE; + } + return result; +} + +static CURLcode rtsp_rtp_write_resp_hd(struct Curl_easy *data, + const char *buf, + size_t blen, + bool is_eos) +{ + return rtsp_rtp_write_resp(data, buf, blen, is_eos); +} + +static CURLcode rtsp_parse_transport(struct Curl_easy *data, + const char *transport) +{ + /* If we receive multiple Transport response-headers, the interleaved + channels of each response header is recorded and used together for + subsequent data validity checks.*/ + /* e.g.: ' RTP/AVP/TCP;unicast;interleaved=5-6' */ + const char *start, *end; + start = transport; + while(start && *start) { + curlx_str_passblanks(&start); + end = strchr(start, ';'); + if(checkprefix("interleaved=", start)) { + curl_off_t chan1, chan2, chan; + const char *p = start + 12; + if(!curlx_str_number(&p, &chan1, 255)) { + unsigned char *rtp_channel_mask = data->state.rtp_channel_mask; + chan2 = chan1; + if(!curlx_str_single(&p, '-')) { + if(curlx_str_number(&p, &chan2, 255)) { + infof(data, "Unable to read the interleaved parameter from " + "Transport header: [%s]", transport); + chan2 = chan1; + } + } + for(chan = chan1; chan <= chan2; chan++) { + int idx = (int)chan / 8; + int off = (int)chan % 8; + rtp_channel_mask[idx] |= (unsigned char)(1 << off); + } + } + else { + infof(data, "Unable to read the interleaved parameter from " + "Transport header: [%s]", transport); + } + break; + } + /* skip to next parameter */ + start = (!end) ? end : (end + 1); + } + return CURLE_OK; +} + +CURLcode Curl_rtsp_parseheader(struct Curl_easy *data, const char *header) +{ + if(checkprefix("CSeq:", header)) { + curl_off_t CSeq = 0; + struct RTSP *rtsp = Curl_meta_get(data, CURL_META_RTSP_EASY); + const char *p = &header[5]; + if(!rtsp) + return CURLE_FAILED_INIT; + curlx_str_passblanks(&p); + if(curlx_str_number(&p, &CSeq, UINT_MAX)) { + failf(data, "Unable to read the CSeq header: [%s]", header); + return CURLE_RTSP_CSEQ_ERROR; + } + data->state.rtsp_CSeq_recv = rtsp->CSeq_recv = (uint32_t)CSeq; + } + else if(checkprefix("Session:", header)) { + const char *start, *end; + size_t idlen; + + /* Find the first non-space letter */ + start = header + 8; + curlx_str_passblanks(&start); + + if(!*start) { + failf(data, "Got a blank Session ID"); + return CURLE_RTSP_SESSION_ERROR; + } + + /* Find the end of Session ID + * + * Allow any non whitespace content, up to the field separator or end of + * line. RFC 2326 is not 100% clear on the session ID and for example + * gstreamer does URL-encoded session ID's not covered by the standard. + */ + end = start; + while((*end > ' ') && (*end != ';')) + end++; + idlen = end - start; + + if(data->set.str[STRING_RTSP_SESSION_ID]) { + + /* If the Session ID is set, then compare */ + if(strlen(data->set.str[STRING_RTSP_SESSION_ID]) != idlen || + strncmp(start, data->set.str[STRING_RTSP_SESSION_ID], idlen)) { + failf(data, "Got RTSP Session ID Line [%s], but wanted ID [%s]", + start, data->set.str[STRING_RTSP_SESSION_ID]); + return CURLE_RTSP_SESSION_ERROR; + } + } + else { + /* If the Session ID is not set, and we find it in a response, then set + * it. + */ + + /* Copy the id substring into a new buffer */ + data->set.str[STRING_RTSP_SESSION_ID] = curlx_memdup0(start, idlen); + if(!data->set.str[STRING_RTSP_SESSION_ID]) + return CURLE_OUT_OF_MEMORY; + } + } + else if(checkprefix("Transport:", header)) { + CURLcode result; + result = rtsp_parse_transport(data, header + 10); + if(result) + return result; + } + return CURLE_OK; +} + +/* + * RTSP handler interface. + */ +const struct Curl_protocol Curl_protocol_rtsp = { + rtsp_setup_connection, /* setup_connection */ + rtsp_do, /* do_it */ + rtsp_done, /* done */ + ZERO_NULL, /* do_more */ + rtsp_connect, /* connect_it */ + ZERO_NULL, /* connecting */ + ZERO_NULL, /* doing */ + ZERO_NULL, /* proto_pollset */ + rtsp_do_pollset, /* doing_pollset */ + ZERO_NULL, /* domore_pollset */ + Curl_http_perform_pollset, /* perform_pollset */ + ZERO_NULL, /* disconnect */ + rtsp_rtp_write_resp, /* write_resp */ + rtsp_rtp_write_resp_hd, /* write_resp_hd */ + rtsp_conn_is_dead, /* connection_is_dead */ + ZERO_NULL, /* attach connection */ + Curl_http_follow, /* follow */ +}; + +#endif /* CURL_DISABLE_RTSP */ diff --git a/3rdparty/curl-8.21.0/lib/rtsp.h b/3rdparty/curl-8.21.0/lib/rtsp.h new file mode 100644 index 0000000000..dd5df3ff73 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/rtsp.h @@ -0,0 +1,33 @@ +#ifndef HEADER_CURL_RTSP_H +#define HEADER_CURL_RTSP_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#ifndef CURL_DISABLE_RTSP +CURLcode Curl_rtsp_parseheader(struct Curl_easy *data, const char *header); +extern const struct Curl_protocol Curl_protocol_rtsp; +#else +#define Curl_rtsp_parseheader(x, y) CURLE_NOT_BUILT_IN +#endif + +#endif /* HEADER_CURL_RTSP_H */ diff --git a/3rdparty/curl-8.21.0/lib/select.c b/3rdparty/curl-8.21.0/lib/select.c new file mode 100644 index 0000000000..888490f2c9 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/select.c @@ -0,0 +1,733 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(HAVE_SELECT) && !defined(HAVE_POLL) +#error "We cannot compile without select() or poll() support." +#endif + +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif + +#include "urldata.h" +#include "connect.h" +#include "select.h" +#include "curl_trc.h" +#include "curlx/timediff.h" +#include "curlx/wait.h" + +#ifndef HAVE_POLL +/* + * This is a wrapper around select() to aid in Windows compatibility. A + * negative timeout value makes this function wait indefinitely, unless no + * valid file descriptor is given, when this happens the negative timeout is + * ignored and the function times out immediately. + * + * Return values: + * -1 = system call error or fd >= FD_SETSIZE + * 0 = timeout + * N = number of signalled file descriptors + */ +static int our_select(curl_socket_t maxfd, /* highest socket number */ + fd_set *fds_read, /* sockets ready for reading */ + fd_set *fds_write, /* sockets ready for writing */ + fd_set *fds_err, /* sockets with errors */ + timediff_t timeout_ms) /* milliseconds to wait */ +{ + struct timeval pending_tv; + struct timeval *ptimeout; + +#ifdef USE_WINSOCK + /* Winsock select() cannot handle zero events. See the comment below. */ + if((!fds_read || fds_read->fd_count == 0) && + (!fds_write || fds_write->fd_count == 0) && + (!fds_err || fds_err->fd_count == 0)) { + /* no sockets, wait */ + return curlx_wait_ms(timeout_ms); + } +#endif + + ptimeout = curlx_mstotv(&pending_tv, timeout_ms); + +#ifdef USE_WINSOCK + /* Winsock select() must not be called with an fd_set that contains zero + fd flags, or it will return WSAEINVAL. It also cannot be called with + no fd_sets at all! From the documentation: + + Any two of the parameters, readfds, writefds, or exceptfds, can be + given as null. At least one must be non-null, and any non-null + descriptor set must contain at least one handle to a socket. + + It is unclear why Winsock does not handle this for us instead of + calling this an error. Luckily, with Winsock, we can _also_ ask how + many bits are set on an fd_set. Therefore, let's check it beforehand. + */ + return select((int)maxfd + 1, + fds_read && fds_read->fd_count ? fds_read : NULL, + fds_write && fds_write->fd_count ? fds_write : NULL, + fds_err && fds_err->fd_count ? fds_err : NULL, ptimeout); +#else + return select((int)maxfd + 1, fds_read, fds_write, fds_err, ptimeout); +#endif +} + +#endif + +/* + * Wait for read or write events on a set of file descriptors. It uses poll() + * when poll() is available, in order to avoid limits with FD_SETSIZE, + * otherwise select() is used. An error is returned if select() is being used + * and a file descriptor is too large for FD_SETSIZE. + * + * A negative timeout value makes this function wait indefinitely, unless no + * valid file descriptor is given, when this happens the negative timeout is + * ignored and the function times out immediately. + * + * Return values: + * -1 = system call error or fd >= FD_SETSIZE + * 0 = timeout + * [bitmask] = action as described below + * + * CURL_CSELECT_IN - first socket is readable + * CURL_CSELECT_IN2 - second socket is readable + * CURL_CSELECT_OUT - write socket is writable + * CURL_CSELECT_ERR - an error condition occurred + */ +int Curl_socket_check(curl_socket_t readfd0, /* two sockets to read from */ + curl_socket_t readfd1, + curl_socket_t writefd, /* socket to write to */ + timediff_t timeout_ms) /* milliseconds to wait */ +{ + struct pollfd pfd[3]; + int num; + int r; + + if((readfd0 == CURL_SOCKET_BAD) && (readfd1 == CURL_SOCKET_BAD) && + (writefd == CURL_SOCKET_BAD)) { + /* no sockets, wait */ + return curlx_wait_ms(timeout_ms); + } + + /* Avoid initial timestamp, avoid curlx_now() call, when elapsed + time in this function does not need to be measured. This happens + when function is called with a zero timeout or a negative timeout + value indicating a blocking call should be performed. */ + + num = 0; + if(readfd0 != CURL_SOCKET_BAD) { + pfd[num].fd = readfd0; + pfd[num].events = POLLRDNORM | POLLIN | POLLRDBAND | POLLPRI; + pfd[num].revents = 0; + num++; + } + if(readfd1 != CURL_SOCKET_BAD) { + pfd[num].fd = readfd1; + pfd[num].events = POLLRDNORM | POLLIN | POLLRDBAND | POLLPRI; + pfd[num].revents = 0; + num++; + } + if(writefd != CURL_SOCKET_BAD) { + pfd[num].fd = writefd; + pfd[num].events = POLLWRNORM | POLLOUT | POLLPRI; + pfd[num].revents = 0; + num++; + } + + r = Curl_poll(pfd, (unsigned int)num, timeout_ms); + if(r <= 0) + return r; + + r = 0; + num = 0; + if(readfd0 != CURL_SOCKET_BAD) { + if(pfd[num].revents & (POLLRDNORM | POLLIN | POLLERR | POLLHUP)) + r |= CURL_CSELECT_IN; + if(pfd[num].revents & (POLLPRI | POLLNVAL)) + r |= CURL_CSELECT_ERR; + num++; + } + if(readfd1 != CURL_SOCKET_BAD) { + if(pfd[num].revents & (POLLRDNORM | POLLIN | POLLERR | POLLHUP)) + r |= CURL_CSELECT_IN2; + if(pfd[num].revents & (POLLPRI | POLLNVAL)) + r |= CURL_CSELECT_ERR; + num++; + } + if(writefd != CURL_SOCKET_BAD) { + if(pfd[num].revents & (POLLWRNORM | POLLOUT)) + r |= CURL_CSELECT_OUT; + if(pfd[num].revents & (POLLERR | POLLHUP | POLLPRI | POLLNVAL)) + r |= CURL_CSELECT_ERR; + } + + return r; +} + +/* + * This is a wrapper around poll(). If poll() does not exist, then + * select() is used instead. An error is returned if select() is + * being used and a file descriptor is too large for FD_SETSIZE. + * A negative timeout value makes this function wait indefinitely, + * unless no valid file descriptor is given, when this happens the + * negative timeout is ignored and the function times out immediately. + * + * Return values: + * -1 = system call error or fd >= FD_SETSIZE + * 0 = timeout + * N = number of structures with non zero revent fields + */ +int Curl_poll(struct pollfd ufds[], unsigned int nfds, timediff_t timeout_ms) +{ +#ifdef HAVE_POLL + int pending_ms; +#else + fd_set fds_read; + fd_set fds_write; + fd_set fds_err; + curl_socket_t maxfd; +#endif + bool fds_none = TRUE; + unsigned int i; + int r; + + if(ufds) { + for(i = 0; i < nfds; i++) { + if(ufds[i].fd != CURL_SOCKET_BAD) { + fds_none = FALSE; + break; + } + } + } + if(fds_none) { + /* no sockets, wait */ + return curlx_wait_ms(timeout_ms); + } + + /* Avoid initial timestamp, avoid curlx_now() call, when elapsed + time in this function does not need to be measured. This happens + when function is called with a zero timeout or a negative timeout + value indicating a blocking call should be performed. */ + +#ifdef HAVE_POLL + + /* prevent overflow, timeout_ms is typecast to int. */ +#if TIMEDIFF_T_MAX > INT_MAX + if(timeout_ms > INT_MAX) + timeout_ms = INT_MAX; +#endif + if(timeout_ms > 0) + pending_ms = (int)timeout_ms; + else if(timeout_ms < 0) + pending_ms = -1; + else + pending_ms = 0; + r = poll(ufds, nfds, pending_ms); + if(r <= 0) { + if((r == -1) && (SOCKERRNO == SOCKEINTR)) + /* make EINTR from select or poll not a "lethal" error */ + r = 0; + return r; + } + + for(i = 0; i < nfds; i++) { + if(ufds[i].fd == CURL_SOCKET_BAD) + continue; + if(ufds[i].revents & POLLHUP) + ufds[i].revents |= POLLIN; + if(ufds[i].revents & POLLERR) + ufds[i].revents |= POLLIN | POLLOUT; + } + +#else /* !HAVE_POLL */ + + FD_ZERO(&fds_read); + FD_ZERO(&fds_write); + FD_ZERO(&fds_err); + maxfd = (curl_socket_t)-1; + + for(i = 0; i < nfds; i++) { + ufds[i].revents = 0; + if(ufds[i].fd == CURL_SOCKET_BAD) + continue; + VERIFY_SOCK(ufds[i].fd); + if(ufds[i].events & (POLLIN | POLLOUT | POLLPRI | + POLLRDNORM | POLLWRNORM | POLLRDBAND)) { + if(ufds[i].fd > maxfd) + maxfd = ufds[i].fd; + if(ufds[i].events & (POLLRDNORM | POLLIN)) + FD_SET(ufds[i].fd, &fds_read); + if(ufds[i].events & (POLLWRNORM | POLLOUT)) + FD_SET(ufds[i].fd, &fds_write); + if(ufds[i].events & (POLLRDBAND | POLLPRI)) + FD_SET(ufds[i].fd, &fds_err); + } + } + + /* + Note also that Winsock ignores the first argument, so we do not worry + about the fact that maxfd is computed incorrectly with Winsock (since + curl_socket_t is unsigned in such cases and thus -1 is the largest + value). + */ + r = our_select(maxfd, &fds_read, &fds_write, &fds_err, timeout_ms); + if(r <= 0) { + if((r == -1) && (SOCKERRNO == SOCKEINTR)) + /* make EINTR from select or poll not a "lethal" error */ + r = 0; + return r; + } + + r = 0; + for(i = 0; i < nfds; i++) { + ufds[i].revents = 0; + if(ufds[i].fd == CURL_SOCKET_BAD) + continue; + if(FD_ISSET(ufds[i].fd, &fds_read)) { + if(ufds[i].events & POLLRDNORM) + ufds[i].revents |= POLLRDNORM; + if(ufds[i].events & POLLIN) + ufds[i].revents |= POLLIN; + } + if(FD_ISSET(ufds[i].fd, &fds_write)) { + if(ufds[i].events & POLLWRNORM) + ufds[i].revents |= POLLWRNORM; + if(ufds[i].events & POLLOUT) + ufds[i].revents |= POLLOUT; + } + if(FD_ISSET(ufds[i].fd, &fds_err)) { + if(ufds[i].events & POLLRDBAND) + ufds[i].revents |= POLLRDBAND; + if(ufds[i].events & POLLPRI) + ufds[i].revents |= POLLPRI; + } + if(ufds[i].revents) + r++; + } + +#endif /* HAVE_POLL */ + + return r; +} + +void Curl_pollfds_init(struct curl_pollfds *cpfds, + struct pollfd *static_pfds, + unsigned int static_count) +{ + DEBUGASSERT(cpfds); + memset(cpfds, 0, sizeof(*cpfds)); + if(static_pfds && static_count) { + cpfds->pfds = static_pfds; + cpfds->count = static_count; + } +} + +void Curl_pollfds_reset(struct curl_pollfds *cpfds) +{ + cpfds->n = 0; +} + +void Curl_pollfds_cleanup(struct curl_pollfds *cpfds) +{ + DEBUGASSERT(cpfds); + if(cpfds->allocated_pfds) { + curlx_free(cpfds->pfds); + } + memset(cpfds, 0, sizeof(*cpfds)); +} + +static CURLcode cpfds_increase(struct curl_pollfds *cpfds, unsigned int inc) +{ + struct pollfd *new_fds; + unsigned int new_count = cpfds->count + inc; + + new_fds = curlx_calloc(new_count, sizeof(struct pollfd)); + if(!new_fds) + return CURLE_OUT_OF_MEMORY; + + memcpy(new_fds, cpfds->pfds, cpfds->count * sizeof(struct pollfd)); + if(cpfds->allocated_pfds) + curlx_free(cpfds->pfds); + cpfds->pfds = new_fds; + cpfds->count = new_count; + cpfds->allocated_pfds = TRUE; + return CURLE_OK; +} + +static CURLcode cpfds_add_sock(struct curl_pollfds *cpfds, + curl_socket_t sock, short events, bool fold) +{ + int i; + + if(fold && cpfds->n <= INT_MAX) { + for(i = (int)cpfds->n - 1; i >= 0; --i) { + if(sock == cpfds->pfds[i].fd) { + cpfds->pfds[i].events |= events; + return CURLE_OK; + } + } + } + /* not folded, add new entry */ + if(cpfds->n >= cpfds->count) { + if(cpfds_increase(cpfds, 100)) + return CURLE_OUT_OF_MEMORY; + } + cpfds->pfds[cpfds->n].fd = sock; + cpfds->pfds[cpfds->n].events = events; + ++cpfds->n; + return CURLE_OK; +} + +CURLcode Curl_pollfds_add_sock(struct curl_pollfds *cpfds, + curl_socket_t sock, short events) +{ + return cpfds_add_sock(cpfds, sock, events, FALSE); +} + +CURLcode Curl_pollfds_add_ps(struct curl_pollfds *cpfds, + struct easy_pollset *ps) +{ + size_t i; + + DEBUGASSERT(cpfds); + DEBUGASSERT(ps); + for(i = 0; i < ps->n; i++) { + short events = 0; + if(ps->actions[i] & CURL_POLL_IN) + events |= POLLIN; + if(ps->actions[i] & CURL_POLL_OUT) + events |= POLLOUT; + if(events) { + if(cpfds_add_sock(cpfds, ps->sockets[i], events, TRUE)) + return CURLE_OUT_OF_MEMORY; + } + } + return CURLE_OK; +} + +void Curl_waitfds_init(struct Curl_waitfds *cwfds, + struct curl_waitfd *static_wfds, + unsigned int static_count) +{ + DEBUGASSERT(cwfds); + DEBUGASSERT(static_wfds || !static_count); + memset(cwfds, 0, sizeof(*cwfds)); + cwfds->wfds = static_wfds; + cwfds->count = static_count; +} + +static unsigned int cwfds_add_sock(struct Curl_waitfds *cwfds, + curl_socket_t sock, short events) +{ + int i; + if(!cwfds->wfds) { + DEBUGASSERT(!cwfds->count && !cwfds->n); + return 1; + } + if(cwfds->n <= INT_MAX) { + for(i = (int)cwfds->n - 1; i >= 0; --i) { + if(sock == cwfds->wfds[i].fd) { + cwfds->wfds[i].events |= events; + return 0; + } + } + } + /* not folded, add new entry */ + if(cwfds->n < cwfds->count) { + cwfds->wfds[cwfds->n].fd = sock; + cwfds->wfds[cwfds->n].events = events; + ++cwfds->n; + } + return 1; +} + +unsigned int Curl_waitfds_add_ps(struct Curl_waitfds *cwfds, + struct easy_pollset *ps) +{ + size_t i; + unsigned int need = 0; + + DEBUGASSERT(cwfds); + DEBUGASSERT(ps); + for(i = 0; i < ps->n; i++) { + short events = 0; + if(ps->actions[i] & CURL_POLL_IN) + events |= CURL_WAIT_POLLIN; + if(ps->actions[i] & CURL_POLL_OUT) + events |= CURL_WAIT_POLLOUT; + if(events) + need += cwfds_add_sock(cwfds, ps->sockets[i], events); + } + return need; +} + +void Curl_pollset_reset(struct easy_pollset *ps) +{ + unsigned int i; + ps->n = 0; +#ifdef DEBUGBUILD + DEBUGASSERT(ps->init == CURL_EASY_POLLSET_MAGIC); +#endif + DEBUGASSERT(ps->count); + for(i = 0; i < ps->count; i++) + ps->sockets[i] = CURL_SOCKET_BAD; + memset(ps->actions, 0, ps->count * sizeof(ps->actions[0])); +} + +void Curl_pollset_init(struct easy_pollset *ps) +{ +#ifdef DEBUGBUILD + ps->init = CURL_EASY_POLLSET_MAGIC; +#endif + ps->sockets = ps->def_sockets; + ps->actions = ps->def_actions; + ps->count = CURL_ARRAYSIZE(ps->def_sockets); + ps->n = 0; + Curl_pollset_reset(ps); +} + +struct easy_pollset *Curl_pollset_create(void) +{ + struct easy_pollset *ps = curlx_calloc(1, sizeof(*ps)); + if(ps) + Curl_pollset_init(ps); + return ps; +} + +void Curl_pollset_cleanup(struct easy_pollset *ps) +{ +#ifdef DEBUGBUILD + DEBUGASSERT(ps->init == CURL_EASY_POLLSET_MAGIC); +#endif + if(ps->sockets != ps->def_sockets) { + curlx_free(ps->sockets); + ps->sockets = ps->def_sockets; + } + if(ps->actions != ps->def_actions) { + curlx_free(ps->actions); + ps->actions = ps->def_actions; + } + ps->count = CURL_ARRAYSIZE(ps->def_sockets); + Curl_pollset_reset(ps); +} + +void Curl_pollset_move(struct easy_pollset *to, struct easy_pollset *from) +{ + Curl_pollset_cleanup(to); /* deallocate anything in to */ + if(from->sockets != from->def_sockets) { + DEBUGASSERT(from->actions != from->def_actions); + to->sockets = from->sockets; + to->actions = from->actions; + to->count = from->count; + to->n = from->n; + Curl_pollset_init(from); + } + else { + DEBUGASSERT(to->sockets == to->def_sockets); + DEBUGASSERT(to->actions == to->def_actions); + memcpy(to->sockets, from->sockets, to->count * sizeof(to->sockets[0])); + memcpy(to->actions, from->actions, to->count * sizeof(to->actions[0])); + to->n = from->n; + Curl_pollset_init(from); + } +} + +/** + * + */ +CURLcode Curl_pollset_change(struct Curl_easy *data, + struct easy_pollset *ps, curl_socket_t sock, + int add_flags, int remove_flags) +{ + unsigned int i; + +#ifdef DEBUGBUILD + DEBUGASSERT(ps->init == CURL_EASY_POLLSET_MAGIC); +#endif + + DEBUGASSERT(VALID_SOCK(sock)); + if(!VALID_SOCK(sock)) + return CURLE_BAD_FUNCTION_ARGUMENT; + + DEBUGASSERT(add_flags <= (CURL_POLL_IN | CURL_POLL_OUT)); + DEBUGASSERT(remove_flags <= (CURL_POLL_IN | CURL_POLL_OUT)); + DEBUGASSERT((add_flags & remove_flags) == 0); /* no overlap */ + for(i = 0; i < ps->n; ++i) { + if(ps->sockets[i] == sock) { + ps->actions[i] &= (unsigned char)(~remove_flags); + ps->actions[i] |= (unsigned char)add_flags; + /* all gone? remove socket */ + if(!ps->actions[i]) { + if((i + 1) < ps->n) { + memmove(&ps->sockets[i], &ps->sockets[i + 1], + (ps->n - (i + 1)) * sizeof(ps->sockets[0])); + memmove(&ps->actions[i], &ps->actions[i + 1], + (ps->n - (i + 1)) * sizeof(ps->actions[0])); + } + --ps->n; + } + return CURLE_OK; + } + } + /* not present */ + if(add_flags) { + if(i >= ps->count) { /* need to grow */ + unsigned int new_count = CURLMAX(ps->count * 2, 8); + curl_socket_t *nsockets; + unsigned char *nactions; + + CURL_TRC_M(data, "growing pollset capacity from %u to %u", + ps->count, new_count); + if(new_count <= ps->count) + return CURLE_OUT_OF_MEMORY; + nsockets = curlx_calloc(new_count, sizeof(nsockets[0])); + if(!nsockets) + return CURLE_OUT_OF_MEMORY; + nactions = curlx_calloc(new_count, sizeof(nactions[0])); + if(!nactions) { + curlx_free(nsockets); + return CURLE_OUT_OF_MEMORY; + } + memcpy(nsockets, ps->sockets, ps->count * sizeof(ps->sockets[0])); + memcpy(nactions, ps->actions, ps->count * sizeof(ps->actions[0])); + if(ps->sockets != ps->def_sockets) + curlx_free(ps->sockets); + ps->sockets = nsockets; + if(ps->actions != ps->def_actions) + curlx_free(ps->actions); + ps->actions = nactions; + ps->count = new_count; + } + DEBUGASSERT(i < ps->count); + if(i < ps->count) { + ps->sockets[i] = sock; + ps->actions[i] = (unsigned char)add_flags; + ps->n = i + 1; + } + } + return CURLE_OK; +} + +CURLcode Curl_pollset_set(struct Curl_easy *data, + struct easy_pollset *ps, curl_socket_t sock, + bool do_in, bool do_out) +{ + return Curl_pollset_change(data, ps, sock, + (do_in ? CURL_POLL_IN : 0) | + (do_out ? CURL_POLL_OUT : 0), + (!do_in ? CURL_POLL_IN : 0) | + (!do_out ? CURL_POLL_OUT : 0)); +} + +/* + * Return values: + * -1 = error + * 0 = timeout + * N = number of structures with non zero revent fields + */ +int Curl_pollset_poll(struct Curl_easy *data, + struct easy_pollset *ps, + timediff_t timeout_ms) +{ + struct pollfd *pfds; + unsigned int i, npfds; + int rc; + + (void)data; + DEBUGASSERT(data); + DEBUGASSERT(data->conn); + + if(!ps->n) + return curlx_wait_ms(timeout_ms); + + pfds = curlx_calloc(ps->n, sizeof(*pfds)); + if(!pfds) + return -1; + + npfds = 0; + for(i = 0; i < ps->n; ++i) { + short events = 0; + if(ps->actions[i] & CURL_POLL_IN) { + events |= POLLIN; + } + if(ps->actions[i] & CURL_POLL_OUT) { + events |= POLLOUT; + } + if(events) { + pfds[npfds].fd = ps->sockets[i]; + pfds[npfds].events = events; + ++npfds; + } + } + + rc = Curl_poll(pfds, npfds, timeout_ms); + curlx_free(pfds); + return rc; +} + +void Curl_pollset_check(struct Curl_easy *data, + struct easy_pollset *ps, curl_socket_t sock, + bool *pwant_read, bool *pwant_write) +{ + unsigned int i; + + (void)data; + DEBUGASSERT(VALID_SOCK(sock)); + for(i = 0; i < ps->n; ++i) { + if(ps->sockets[i] == sock) { + *pwant_read = !!(ps->actions[i] & CURL_POLL_IN); + *pwant_write = !!(ps->actions[i] & CURL_POLL_OUT); + return; + } + } + *pwant_read = *pwant_write = FALSE; +} + +bool Curl_pollset_want_recv(struct Curl_easy *data, + struct easy_pollset *ps, + curl_socket_t sock) +{ + unsigned int i; + (void)data; + for(i = 0; i < ps->n; ++i) { + if((ps->sockets[i] == sock) && (ps->actions[i] & CURL_POLL_IN)) + return TRUE; + } + return FALSE; +} + +bool Curl_pollset_want_send(struct Curl_easy *data, + struct easy_pollset *ps, + curl_socket_t sock) +{ + unsigned int i; + (void)data; + for(i = 0; i < ps->n; ++i) { + if((ps->sockets[i] == sock) && (ps->actions[i] & CURL_POLL_OUT)) + return TRUE; + } + return FALSE; +} diff --git a/3rdparty/curl-8.21.0/lib/select.h b/3rdparty/curl-8.21.0/lib/select.h new file mode 100644 index 0000000000..dbbace4527 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/select.h @@ -0,0 +1,232 @@ +#ifndef HEADER_CURL_SELECT_H +#define HEADER_CURL_SELECT_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef HAVE_POLL_H +#include +#elif defined(HAVE_SYS_POLL_H) +#include +#endif + +/* + * Definition of pollfd struct and constants for platforms lacking them. + */ + +#if !defined(HAVE_SYS_POLL_H) && !defined(HAVE_POLL_H) && !defined(POLLIN) + +#define POLLIN 0x01 +#define POLLPRI 0x02 +#define POLLOUT 0x04 +#define POLLERR 0x08 +#define POLLHUP 0x10 +#define POLLNVAL 0x20 + +struct pollfd { + curl_socket_t fd; + short events; + short revents; +}; + +#endif + +#ifndef POLLRDNORM +#define POLLRDNORM POLLIN +#endif + +#ifndef POLLWRNORM +#define POLLWRNORM POLLOUT +#endif + +#ifndef POLLRDBAND +#define POLLRDBAND POLLPRI +#endif + +/* there are three CSELECT defines that are defined in the public header that + are exposed to users, but this *IN2 bit is only ever used internally and + therefore defined here */ +#define CURL_CSELECT_IN2 (CURL_CSELECT_ERR << 1) + +int Curl_socket_check(curl_socket_t readfd0, + curl_socket_t readfd1, + curl_socket_t writefd, + timediff_t timeout_ms); +#define SOCKET_READABLE(x, z) \ + Curl_socket_check(x, CURL_SOCKET_BAD, CURL_SOCKET_BAD, z) +#define SOCKET_WRITABLE(x, z) \ + Curl_socket_check(CURL_SOCKET_BAD, CURL_SOCKET_BAD, x, z) + +int Curl_poll(struct pollfd ufds[], unsigned int nfds, timediff_t timeout_ms); + +/* + With Winsock the valid range is [0..INVALID_SOCKET-1] according to + https://learn.microsoft.com/windows/win32/winsock/socket-data-type-2 +*/ +#ifdef USE_WINSOCK +#define VALID_SOCK(s) ((s) < INVALID_SOCKET) +#define FDSET_SOCK(x) 1 +#define VERIFY_SOCK(x) \ + do { \ + if(!VALID_SOCK(x)) { \ + SET_SOCKERRNO(SOCKEINVAL); \ + return -1; \ + } \ + } while(0) +#else +#define VALID_SOCK(s) ((s) >= 0) + +/* If the socket is small enough to get set or read from an fdset */ +#define FDSET_SOCK(s) ((s) < FD_SETSIZE) + +#define VERIFY_SOCK(x) \ + do { \ + if(!VALID_SOCK(x) || !FDSET_SOCK(x)) { \ + SET_SOCKERRNO(SOCKEINVAL); \ + return -1; \ + } \ + } while(0) +#endif + +/* Keep the sockets to poll for an easy handle. + * `actions` are bitmaps of CURL_POLL_IN and CURL_POLL_OUT. + * Starts with small capacity, grows on demand. + */ +#define EZ_POLLSET_DEF_COUNT 2 + +struct easy_pollset { + curl_socket_t *sockets; + unsigned char *actions; + unsigned int n; + unsigned int count; +#ifdef DEBUGBUILD + int init; +#endif + curl_socket_t def_sockets[EZ_POLLSET_DEF_COUNT]; + unsigned char def_actions[EZ_POLLSET_DEF_COUNT]; +}; + +#ifdef DEBUGBUILD +#define CURL_EASY_POLLSET_MAGIC 0x7a657370 +#endif + +/* allocate and initialize */ +struct easy_pollset *Curl_pollset_create(void); + +/* Initialize before first use */ +void Curl_pollset_init(struct easy_pollset *ps); +/* Free any allocated resources */ +void Curl_pollset_cleanup(struct easy_pollset *ps); +/* Reset to an empty pollset */ +void Curl_pollset_reset(struct easy_pollset *ps); +/* Move pollset from to pollset to, replacing all in to, + * leaving from empty. */ +void Curl_pollset_move(struct easy_pollset *to, struct easy_pollset *from); + +/* Change the poll flags (CURL_POLL_IN/CURL_POLL_OUT) to the poll set for + * socket `sock`. If the socket is not already part of the poll set, it + * will be added. + * If the socket is present and all poll flags are cleared, it will be removed. + */ +CURLcode Curl_pollset_change(struct Curl_easy *data, + struct easy_pollset *ps, curl_socket_t sock, + int add_flags, + int remove_flags) WARN_UNUSED_RESULT; + +CURLcode Curl_pollset_set(struct Curl_easy *data, + struct easy_pollset *ps, curl_socket_t sock, + bool do_in, bool do_out) WARN_UNUSED_RESULT; + +#define Curl_pollset_add_in(data, ps, sock) \ + Curl_pollset_change(data, ps, sock, CURL_POLL_IN, 0) +#define Curl_pollset_remove_in(data, ps, sock) \ + Curl_pollset_change(data, ps, sock, 0, CURL_POLL_IN) +#define Curl_pollset_add_out(data, ps, sock) \ + Curl_pollset_change(data, ps, sock, CURL_POLL_OUT, 0) +#define Curl_pollset_remove_out(data, ps, sock) \ + Curl_pollset_change(data, ps, sock, 0, CURL_POLL_OUT) +#define Curl_pollset_add_inout(data, ps, sock) \ + Curl_pollset_change(data, ps, sock, CURL_POLL_IN | CURL_POLL_OUT, 0) +#define Curl_pollset_set_in_only(data, ps, sock) \ + Curl_pollset_change(data, ps, sock, CURL_POLL_IN, CURL_POLL_OUT) +#define Curl_pollset_set_out_only(data, ps, sock) \ + Curl_pollset_change(data, ps, sock, CURL_POLL_OUT, CURL_POLL_IN) + +/* return < = on error, 0 on timeout or how many sockets are ready */ +int Curl_pollset_poll(struct Curl_easy *data, + struct easy_pollset *ps, + timediff_t timeout_ms); + +/** + * Check if the pollset, as is, wants to read and/or write regarding + * the given socket. + */ +void Curl_pollset_check(struct Curl_easy *data, + struct easy_pollset *ps, curl_socket_t sock, + bool *pwant_read, bool *pwant_write); + +/* TRUE if the pollset contains socket with CURL_POLL_IN. */ +bool Curl_pollset_want_recv(struct Curl_easy *data, + struct easy_pollset *ps, + curl_socket_t sock); +/* TRUE if the pollset contains socket with CURL_POLL_OUT. */ +bool Curl_pollset_want_send(struct Curl_easy *data, + struct easy_pollset *ps, + curl_socket_t sock); + +struct curl_pollfds { + struct pollfd *pfds; + unsigned int n; + unsigned int count; + BIT(allocated_pfds); +}; + +void Curl_pollfds_init(struct curl_pollfds *cpfds, + struct pollfd *static_pfds, + unsigned int static_count); + +void Curl_pollfds_reset(struct curl_pollfds *cpfds); + +void Curl_pollfds_cleanup(struct curl_pollfds *cpfds); + +CURLcode Curl_pollfds_add_ps(struct curl_pollfds *cpfds, + struct easy_pollset *ps); + +CURLcode Curl_pollfds_add_sock(struct curl_pollfds *cpfds, + curl_socket_t sock, short events); + +struct Curl_waitfds { + struct curl_waitfd *wfds; + unsigned int n; + unsigned int count; +}; + +void Curl_waitfds_init(struct Curl_waitfds *cwfds, + struct curl_waitfd *static_wfds, + unsigned int static_count); + +unsigned int Curl_waitfds_add_ps(struct Curl_waitfds *cwfds, + struct easy_pollset *ps); + +#endif /* HEADER_CURL_SELECT_H */ diff --git a/3rdparty/curl-8.21.0/lib/sendf.c b/3rdparty/curl-8.21.0/lib/sendf.c new file mode 100644 index 0000000000..7559f64f84 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/sendf.c @@ -0,0 +1,1478 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef HAVE_NETINET_IN_H +#include +#endif + +#ifdef HAVE_LINUX_TCP_H +#include +#elif defined(HAVE_NETINET_TCP_H) +#include +#endif + +#include "urldata.h" +#include "sendf.h" +#include "curl_trc.h" +#include "transfer.h" +#include "cfilters.h" +#include "connect.h" +#include "cw-out.h" +#include "cw-pause.h" +#include "multiif.h" +#include "progress.h" + +static void cl_reset_writer(struct Curl_easy *data) +{ + struct Curl_cwriter *writer = data->req.writer_stack; + while(writer) { + data->req.writer_stack = writer->next; + writer->cwt->do_close(data, writer); + curlx_free(writer); + writer = data->req.writer_stack; + } +} + +static void cl_reset_reader(struct Curl_easy *data) +{ + struct Curl_creader *reader = data->req.reader_stack; + data->req.reader_started = FALSE; + while(reader) { + data->req.reader_stack = reader->next; + reader->crt->do_close(data, reader); + curlx_free(reader); + reader = data->req.reader_stack; + } +} + +void Curl_client_cleanup(struct Curl_easy *data) +{ + cl_reset_reader(data); + cl_reset_writer(data); + + data->req.bytecount = 0; + data->req.headerline = 0; +} + +void Curl_client_reset(struct Curl_easy *data) +{ + if(data->req.rewind_read) { + /* already requested */ + CURL_TRC_READ(data, "client_reset, will rewind reader"); + } + else { + CURL_TRC_READ(data, "client_reset, clear readers"); + cl_reset_reader(data); + } + cl_reset_writer(data); + + data->req.bytecount = 0; + data->req.headerline = 0; +} + +CURLcode Curl_client_start(struct Curl_easy *data) +{ + if(data->req.rewind_read) { + struct Curl_creader *r = data->req.reader_stack; + CURLcode result = CURLE_OK; + + CURL_TRC_READ(data, "client start, rewind readers"); + while(r) { + result = r->crt->cntrl(data, r, CURL_CRCNTRL_REWIND); + if(result) { + failf(data, "rewind of client reader '%s' failed: %d", + r->crt->name, (int)result); + return result; + } + r = r->next; + } + data->req.rewind_read = FALSE; + cl_reset_reader(data); + } + return CURLE_OK; +} + +bool Curl_creader_will_rewind(struct Curl_easy *data) +{ + return (bool)data->req.rewind_read; +} + +void Curl_creader_set_rewind(struct Curl_easy *data, bool enable) +{ + data->req.rewind_read = !!enable; +} + +/* Write data using an unencoding writer stack. */ +CURLcode Curl_cwriter_write(struct Curl_easy *data, + struct Curl_cwriter *writer, int type, + const char *buf, size_t nbytes) +{ + if(!writer) + return CURLE_WRITE_ERROR; + return writer->cwt->do_write(data, writer, type, buf, nbytes); +} + +CURLcode Curl_cwriter_def_init(struct Curl_easy *data, + struct Curl_cwriter *writer) +{ + (void)data; + (void)writer; + return CURLE_OK; +} + +CURLcode Curl_cwriter_def_write(struct Curl_easy *data, + struct Curl_cwriter *writer, int type, + const char *buf, size_t nbytes) +{ + return Curl_cwriter_write(data, writer->next, type, buf, nbytes); +} + +void Curl_cwriter_def_close(struct Curl_easy *data, + struct Curl_cwriter *writer) +{ + (void)data; + (void)writer; +} + +static size_t get_max_body_write_len(struct Curl_easy *data, curl_off_t limit) +{ + if(limit != -1) { + /* How much more are we allowed to write? */ + return curlx_sotouz_range(limit - data->req.bytecount, 0, SIZE_MAX); + } + return SIZE_MAX; +} + +struct cw_download_ctx { + struct Curl_cwriter super; + BIT(started_response); + BIT(started_body); +}; + +/* Download client writer in phase CURL_CW_PROTOCOL that + * sees the "real" download body data. */ +static CURLcode cw_download_write(struct Curl_easy *data, + struct Curl_cwriter *writer, int type, + const char *buf, size_t nbytes) +{ + struct cw_download_ctx *ctx = writer->ctx; + CURLcode result; + size_t nwrite, excess_len = 0; + bool is_connect = !!(type & CLIENTWRITE_CONNECT); + + if(!ctx->started_response && + !(type & CLIENTWRITE_CONNECT) && + (!(type & CLIENTWRITE_INFO) || data->req.upload_done)) { + Curl_pgrsTime(data, TIMER_STARTTRANSFER); + ctx->started_response = TRUE; + } + + if(!(type & CLIENTWRITE_BODY)) { + if(is_connect && data->set.suppress_connect_headers) + return CURLE_OK; + result = Curl_cwriter_write(data, writer->next, type, buf, nbytes); + CURL_TRC_WRITE(data, "download_write header(type=%x, blen=%zu) -> %d", + (unsigned int)type, nbytes, (int)result); + return result; + } + + if(!ctx->started_body && + !(type & (CLIENTWRITE_INFO | CLIENTWRITE_CONNECT))) { + Curl_rlimit_start(&data->progress.dl.rlimit, Curl_pgrs_now(data), + data->req.size); + ctx->started_body = TRUE; + } + + /* Here, we deal with REAL BODY bytes. All filtering and transfer + * encodings have been applied and only the true content, e.g. BODY, + * bytes are passed here. + * This allows us to check sizes, update stats, etc. independent + * from the protocol in play. */ + + if(data->req.no_body && nbytes > 0) { + /* BODY arrives although we want none, bail out */ + streamclose(data->conn, "ignoring body"); + CURL_TRC_WRITE(data, "download_write body(type=%x, blen=%zu), " + "did not want a BODY", (unsigned int)type, nbytes); + data->req.download_done = TRUE; + if(data->info.header_size) + /* if headers have been received, this is fine */ + return CURLE_OK; + return CURLE_WEIRD_SERVER_REPLY; + } + + /* Determine if we see any bytes in excess to what is allowed. + * We write the allowed bytes and handle excess further below. + * This gives deterministic BODY writes on varying buffer receive + * lengths. */ + nwrite = nbytes; + if(data->req.maxdownload != -1) { + size_t wmax = get_max_body_write_len(data, data->req.maxdownload); + if(nwrite > wmax) { + excess_len = nbytes - wmax; + nwrite = wmax; + } + + if(nwrite == wmax) { + data->req.download_done = TRUE; + } + + if((type & CLIENTWRITE_EOS) && !data->req.no_body && + (data->req.size > data->req.bytecount)) { + failf(data, "end of response with %" FMT_OFF_T " bytes missing", + data->req.size - data->req.bytecount); + return CURLE_PARTIAL_FILE; + } + } + + /* Error on too large filesize is handled below, after writing + * the permitted bytes */ + if(data->set.max_filesize && !data->req.ignorebody) { + size_t wmax = get_max_body_write_len(data, data->set.max_filesize); + if(nwrite > wmax) { + nwrite = wmax; + } + } + + if(!data->req.ignorebody && (nwrite || (type & CLIENTWRITE_EOS))) { + result = Curl_cwriter_write(data, writer->next, type, buf, nwrite); + CURL_TRC_WRITE(data, "download_write body(type=%x, blen=%zu) -> %d", + (unsigned int)type, nbytes, (int)result); + if(result) + return result; + } + + /* Update stats, write and report progress */ + if(nwrite) { + data->req.bytecount += nwrite; + Curl_pgrs_download_inc(data, nwrite); + } + + if(excess_len) { + if(!data->req.ignorebody) { + infof(data, + "Excess found writing body:" + " excess = %zu" + ", size = %" FMT_OFF_T + ", maxdownload = %" FMT_OFF_T + ", bytecount = %" FMT_OFF_T, + excess_len, data->req.size, data->req.maxdownload, + data->req.bytecount); + connclose(data->conn, "excess found in a read"); + } + } + else if((nwrite < nbytes) && !data->req.ignorebody) { + failf(data, "Exceeded the maximum allowed file size " + "(%" FMT_OFF_T ") with %" FMT_OFF_T " bytes", + data->set.max_filesize, data->req.bytecount); + return CURLE_FILESIZE_EXCEEDED; + } + + return CURLE_OK; +} + +static const struct Curl_cwtype cw_download = { + "protocol", + NULL, + Curl_cwriter_def_init, + cw_download_write, + Curl_cwriter_def_close, + sizeof(struct cw_download_ctx) +}; + +/* RAW client writer in phase CURL_CW_RAW that + * enabled tracing of raw data. */ +static CURLcode cw_raw_write(struct Curl_easy *data, + struct Curl_cwriter *writer, int type, + const char *buf, size_t nbytes) +{ + if(type & CLIENTWRITE_BODY && data->set.verbose && !data->req.ignorebody) { + Curl_debug(data, CURLINFO_DATA_IN, buf, nbytes); + } + return Curl_cwriter_write(data, writer->next, type, buf, nbytes); +} + +static const struct Curl_cwtype cw_raw = { + "raw", + NULL, + Curl_cwriter_def_init, + cw_raw_write, + Curl_cwriter_def_close, + sizeof(struct Curl_cwriter) +}; + +static CURLcode do_init_writer_stack(struct Curl_easy *data) +{ + struct Curl_cwriter *writer; + CURLcode result; + + DEBUGASSERT(!data->req.writer_stack); + result = Curl_cwriter_create(&data->req.writer_stack, + data, &Curl_cwt_out, CURL_CW_CLIENT); + if(result) + return result; + + /* This places the "pause" writer behind the "download" writer that + * is added below. Meaning the "download" can do checks on content length + * and other things *before* write outs are buffered for paused transfers. */ + result = Curl_cwriter_create(&writer, data, &Curl_cwt_pause, + CURL_CW_PROTOCOL); + if(!result) { + result = Curl_cwriter_add(data, writer); + if(result) + Curl_cwriter_free(data, writer); + } + if(result) + return result; + + result = Curl_cwriter_create(&writer, data, &cw_download, CURL_CW_PROTOCOL); + if(!result) { + result = Curl_cwriter_add(data, writer); + if(result) + Curl_cwriter_free(data, writer); + } + if(result) + return result; + + result = Curl_cwriter_create(&writer, data, &cw_raw, CURL_CW_RAW); + if(!result) { + result = Curl_cwriter_add(data, writer); + if(result) + Curl_cwriter_free(data, writer); + } + if(result) + return result; + + return result; +} + +/* Curl_client_write() sends data to the write callback(s) + + The bit pattern defines to what "streams" to write to. Body and/or header. + The defines are in sendf.h of course. + */ +CURLcode Curl_client_write(struct Curl_easy *data, int type, const char *buf, + size_t len) +{ + CURLcode result; + + /* it is one of those, at least */ + DEBUGASSERT(type & + (CLIENTWRITE_BODY | CLIENTWRITE_HEADER | CLIENTWRITE_INFO)); + /* BODY is only BODY (with optional EOS) */ + DEBUGASSERT(!(type & CLIENTWRITE_BODY) || + ((type & ~(CLIENTWRITE_BODY | CLIENTWRITE_EOS)) == 0)); + /* INFO is only INFO (with optional EOS) */ + DEBUGASSERT(!(type & CLIENTWRITE_INFO) || + ((type & ~(CLIENTWRITE_INFO | CLIENTWRITE_EOS)) == 0)); + + if(!data->req.writer_stack) { + result = do_init_writer_stack(data); + if(result) + return result; + DEBUGASSERT(data->req.writer_stack); + } + + result = Curl_cwriter_write(data, data->req.writer_stack, type, buf, len); + CURL_TRC_WRITE(data, "client_write(type=%x, len=%zu) -> %d", + (unsigned int)type, len, (int)result); + return result; +} + +/* Create an unencoding writer stage using the given handler. */ +CURLcode Curl_cwriter_create(struct Curl_cwriter **pwriter, + struct Curl_easy *data, + const struct Curl_cwtype *cwt, + Curl_cwriter_phase phase) +{ + struct Curl_cwriter *writer = NULL; + CURLcode result = CURLE_OUT_OF_MEMORY; + void *p; + + DEBUGASSERT(cwt->cwriter_size >= sizeof(struct Curl_cwriter)); + p = curlx_calloc(1, cwt->cwriter_size); + if(!p) + goto out; + + writer = (struct Curl_cwriter *)p; + writer->cwt = cwt; + writer->ctx = p; + writer->phase = phase; + result = cwt->do_init(data, writer); + +out: + *pwriter = result ? NULL : writer; + if(result) + curlx_free(writer); + return result; +} + +void Curl_cwriter_free(struct Curl_easy *data, + struct Curl_cwriter *writer) +{ + if(writer) { + writer->cwt->do_close(data, writer); + curlx_free(writer); + } +} + +size_t Curl_cwriter_count(struct Curl_easy *data, Curl_cwriter_phase phase) +{ + struct Curl_cwriter *w; + size_t n = 0; + + for(w = data->req.writer_stack; w; w = w->next) { + if(w->phase == phase) + ++n; + } + return n; +} + +CURLcode Curl_cwriter_add(struct Curl_easy *data, + struct Curl_cwriter *writer) +{ + CURLcode result; + struct Curl_cwriter **anchor = &data->req.writer_stack; + + if(!*anchor) { + result = do_init_writer_stack(data); + if(result) + return result; + } + + /* Insert the writer as first in its phase. + * Skip existing writers of lower phases. */ + while(*anchor && (*anchor)->phase < writer->phase) + anchor = &((*anchor)->next); + writer->next = *anchor; + *anchor = writer; + return CURLE_OK; +} + +struct Curl_cwriter *Curl_cwriter_get_by_name(struct Curl_easy *data, + const char *name) +{ + struct Curl_cwriter *writer; + for(writer = data->req.writer_stack; writer; writer = writer->next) { + if(!strcmp(name, writer->cwt->name)) + return writer; + } + return NULL; +} + +struct Curl_cwriter *Curl_cwriter_get_by_type(struct Curl_easy *data, + const struct Curl_cwtype *cwt) +{ + struct Curl_cwriter *writer; + for(writer = data->req.writer_stack; writer; writer = writer->next) { + if(writer->cwt == cwt) + return writer; + } + return NULL; +} + +bool Curl_cwriter_is_content_decoding(struct Curl_easy *data) +{ + struct Curl_cwriter *writer; + for(writer = data->req.writer_stack; writer; writer = writer->next) { + if(writer->phase == CURL_CW_CONTENT_DECODE) + return TRUE; + } + return FALSE; +} + +bool Curl_cwriter_is_paused(struct Curl_easy *data) +{ + return Curl_cw_out_is_paused(data); +} + +CURLcode Curl_cwriter_unpause(struct Curl_easy *data) +{ + return Curl_cw_out_unpause(data); +} + +CURLcode Curl_creader_read(struct Curl_easy *data, + struct Curl_creader *reader, + char *buf, size_t blen, size_t *nread, bool *eos) +{ + *nread = 0; + *eos = FALSE; + if(!reader) + return CURLE_READ_ERROR; + return reader->crt->do_read(data, reader, buf, blen, nread, eos); +} + +void Curl_creader_clear_eos(struct Curl_easy *data, + struct Curl_creader *reader) +{ + while(reader) { + (void)reader->crt->cntrl(data, reader, CURL_CRCNTRL_CLEAR_EOS); + reader = reader->next; + } +} + +CURLcode Curl_creader_def_init(struct Curl_easy *data, + struct Curl_creader *reader) +{ + (void)data; + (void)reader; + return CURLE_OK; +} + +void Curl_creader_def_close(struct Curl_easy *data, + struct Curl_creader *reader) +{ + (void)data; + (void)reader; +} + +CURLcode Curl_creader_def_read(struct Curl_easy *data, + struct Curl_creader *reader, + char *buf, size_t blen, + size_t *nread, bool *eos) +{ + if(reader->next) + return reader->next->crt->do_read(data, reader->next, buf, blen, + nread, eos); + else { + *nread = 0; + *eos = FALSE; + return CURLE_READ_ERROR; + } +} + +bool Curl_creader_def_needs_rewind(struct Curl_easy *data, + struct Curl_creader *reader) +{ + (void)data; + (void)reader; + return FALSE; +} + +curl_off_t Curl_creader_def_total_length(struct Curl_easy *data, + struct Curl_creader *reader) +{ + return reader->next ? + reader->next->crt->total_length(data, reader->next) : -1; +} + +CURLcode Curl_creader_def_resume_from(struct Curl_easy *data, + struct Curl_creader *reader, + curl_off_t offset) +{ + (void)data; + (void)reader; + (void)offset; + return CURLE_READ_ERROR; +} + +CURLcode Curl_creader_def_cntrl(struct Curl_easy *data, + struct Curl_creader *reader, + Curl_creader_cntrl opcode) +{ + (void)data; + (void)reader; + (void)opcode; + return CURLE_OK; +} + +bool Curl_creader_def_is_paused(struct Curl_easy *data, + struct Curl_creader *reader) +{ + (void)data; + (void)reader; + return FALSE; +} + +void Curl_creader_def_done(struct Curl_easy *data, + struct Curl_creader *reader, int premature) +{ + (void)data; + (void)reader; + (void)premature; +} + +struct cr_in_ctx { + struct Curl_creader super; + curl_read_callback read_cb; + void *cb_user_data; + curl_off_t total_len; + curl_off_t read_len; + CURLcode error_result; + BIT(seen_eos); + BIT(errored); + BIT(has_used_cb); + BIT(is_paused); +}; + +static CURLcode cr_in_init(struct Curl_easy *data, struct Curl_creader *reader) +{ + struct cr_in_ctx *ctx = reader->ctx; + ctx->read_cb = data->state.fread_func; + ctx->cb_user_data = data->state.in; + ctx->total_len = -1; + ctx->read_len = 0; + return CURLE_OK; +} + +/* Real client reader to installed client callbacks. */ +static CURLcode cr_in_read(struct Curl_easy *data, + struct Curl_creader *reader, + char *buf, size_t blen, + size_t *pnread, bool *peos) +{ + struct cr_in_ctx *ctx = reader->ctx; + CURLcode result = CURLE_OK; + size_t nread; + + ctx->is_paused = FALSE; + + /* Once we have errored, we will return the same error forever */ + if(ctx->errored) { + *pnread = 0; + *peos = FALSE; + return ctx->error_result; + } + if(ctx->seen_eos) { + *pnread = 0; + *peos = TRUE; + return CURLE_OK; + } + /* respect length limitations */ + if(ctx->total_len >= 0) { + blen = curlx_sotouz_range(ctx->total_len - ctx->read_len, 0, blen); + } + nread = 0; + if(ctx->read_cb && blen) { + Curl_set_in_callback(data, TRUE); + nread = ctx->read_cb(buf, 1, blen, ctx->cb_user_data); + Curl_set_in_callback(data, FALSE); + ctx->has_used_cb = TRUE; + } + + switch(nread) { + case 0: + if((ctx->total_len >= 0) && (ctx->read_len < ctx->total_len)) { + failf(data, "client read function EOF fail, " + "only %" FMT_OFF_T "/%" FMT_OFF_T " of needed bytes read", + ctx->read_len, ctx->total_len); + result = CURLE_READ_ERROR; + break; + } + *pnread = 0; + *peos = TRUE; + ctx->seen_eos = TRUE; + break; + + case CURL_READFUNC_ABORT: + failf(data, "operation aborted by callback"); + *pnread = 0; + *peos = FALSE; + ctx->errored = TRUE; + ctx->error_result = CURLE_ABORTED_BY_CALLBACK; + result = CURLE_ABORTED_BY_CALLBACK; + break; + + case CURL_READFUNC_PAUSE: + if(data->conn->scheme->flags & PROTOPT_NONETWORK) { + /* protocols that work without network cannot be paused. This is + actually only file:// now, and it cannot pause since the transfer + is not done using the "normal" procedure. */ + failf(data, "Read callback asked for PAUSE when not supported"); + result = CURLE_READ_ERROR; + break; + } + /* CURL_READFUNC_PAUSE pauses read callbacks that feed socket writes */ + CURL_TRC_READ(data, "cr_in_read, callback returned CURL_READFUNC_PAUSE"); + ctx->is_paused = TRUE; + *pnread = 0; + *peos = FALSE; + result = Curl_xfer_pause_send(data, TRUE); + break; /* nothing was read */ + + default: + if(nread > blen) { + /* the read function returned a too large value */ + failf(data, "read function returned funny value"); + *pnread = 0; + *peos = FALSE; + ctx->errored = TRUE; + ctx->error_result = CURLE_READ_ERROR; + result = CURLE_READ_ERROR; + break; + } + ctx->read_len += nread; + if(ctx->total_len >= 0) + ctx->seen_eos = (ctx->read_len >= ctx->total_len); + *pnread = nread; + *peos = (bool)ctx->seen_eos; + break; + } + CURL_TRC_READ(data, "cr_in_read(len=%zu, total=%" FMT_OFF_T + ", read=%" FMT_OFF_T ") -> %d, nread=%zu, eos=%d", + blen, ctx->total_len, ctx->read_len, (int)result, + *pnread, *peos); + return result; +} + +static bool cr_in_needs_rewind(struct Curl_easy *data, + struct Curl_creader *reader) +{ + struct cr_in_ctx *ctx = reader->ctx; + (void)data; + return (bool)ctx->has_used_cb; +} + +static curl_off_t cr_in_total_length(struct Curl_easy *data, + struct Curl_creader *reader) +{ + struct cr_in_ctx *ctx = reader->ctx; + (void)data; + return ctx->total_len; +} + +static CURLcode cr_in_resume_from(struct Curl_easy *data, + struct Curl_creader *reader, + curl_off_t offset) +{ + struct cr_in_ctx *ctx = reader->ctx; + int seekerr = CURL_SEEKFUNC_CANTSEEK; + + DEBUGASSERT(data->conn); + /* already started reading? */ + if(ctx->read_len) + return CURLE_READ_ERROR; + + if(data->set.seek_func) { + Curl_set_in_callback(data, TRUE); + seekerr = data->set.seek_func(data->set.seek_client, offset, SEEK_SET); + Curl_set_in_callback(data, FALSE); + } + + if(seekerr != CURL_SEEKFUNC_OK) { + curl_off_t passed = 0; + + if(seekerr != CURL_SEEKFUNC_CANTSEEK) { + failf(data, "Could not seek stream"); + return CURLE_READ_ERROR; + } + /* when seekerr == CURL_SEEKFUNC_CANTSEEK (cannot seek to offset) */ + do { + char scratch[4 * 1024]; + size_t readthisamountnow = + (offset - passed > (curl_off_t)sizeof(scratch)) ? + sizeof(scratch) : + curlx_sotouz(offset - passed); + size_t actuallyread; + + Curl_set_in_callback(data, TRUE); + actuallyread = ctx->read_cb(scratch, 1, readthisamountnow, + ctx->cb_user_data); + Curl_set_in_callback(data, FALSE); + + passed += actuallyread; + if((actuallyread == 0) || (actuallyread > readthisamountnow)) { + /* this checks for greater-than only to make sure that the + CURL_READFUNC_ABORT return code still aborts */ + failf(data, "Could only read %" FMT_OFF_T " bytes from the input", + passed); + return CURLE_READ_ERROR; + } + } while(passed < offset); + } + + /* now, decrease the size of the read */ + if(ctx->total_len > 0) { + ctx->total_len -= offset; + + if(ctx->total_len <= 0) { + failf(data, "File already completely uploaded"); + return CURLE_PARTIAL_FILE; + } + } + /* we have passed, proceed as normal */ + return CURLE_OK; +} + +static CURLcode cr_in_rewind(struct Curl_easy *data, + struct Curl_creader *reader) +{ + struct cr_in_ctx *ctx = reader->ctx; + + /* If we never invoked the callback, there is noting to rewind */ + if(!ctx->has_used_cb) + return CURLE_OK; + + if(data->set.seek_func) { + int err; + + Curl_set_in_callback(data, TRUE); + err = (data->set.seek_func)(data->set.seek_client, 0, SEEK_SET); + Curl_set_in_callback(data, FALSE); + CURL_TRC_READ(data, "cr_in, rewind via set.seek_func -> %d", err); + if(err) { + failf(data, "seek callback returned error %d", err); + return CURLE_SEND_FAIL_REWIND; + } + } + else if(data->set.ioctl_func) { + curlioerr err; + + Curl_set_in_callback(data, TRUE); + err = (data->set.ioctl_func)(data, CURLIOCMD_RESTARTREAD, + data->set.ioctl_client); + Curl_set_in_callback(data, FALSE); + CURL_TRC_READ(data, "cr_in, rewind via set.ioctl_func -> %d", (int)err); + if(err) { + failf(data, "ioctl callback returned error %d", (int)err); + return CURLE_SEND_FAIL_REWIND; + } + } + else { + /* If no CURLOPT_READFUNCTION is used, we know that we operate on a + given FILE * stream and we can actually attempt to rewind that + ourselves with fseek() */ +#if defined(__clang__) && __clang_major__ >= 16 +#pragma clang diagnostic push +#pragma clang diagnostic ignored "-Wcast-function-type-strict" +#endif + if(data->state.fread_func == (curl_read_callback)fread) { +#if defined(__clang__) && __clang_major__ >= 16 +#pragma clang diagnostic pop +#endif + int err = fseek(data->state.in, 0, SEEK_SET); + CURL_TRC_READ(data, "cr_in, rewind via fseek -> %d(%d)", + (int)err, (int)errno); + if(err != -1) + /* successful rewind */ + return CURLE_OK; + } + + /* no callback set or failure above, makes us fail at once */ + failf(data, "necessary data rewind was not possible"); + return CURLE_SEND_FAIL_REWIND; + } + return CURLE_OK; +} + +static CURLcode cr_in_cntrl(struct Curl_easy *data, + struct Curl_creader *reader, + Curl_creader_cntrl opcode) +{ + struct cr_in_ctx *ctx = reader->ctx; + + switch(opcode) { + case CURL_CRCNTRL_REWIND: + return cr_in_rewind(data, reader); + case CURL_CRCNTRL_UNPAUSE: + ctx->is_paused = FALSE; + break; + case CURL_CRCNTRL_CLEAR_EOS: + ctx->seen_eos = FALSE; + break; + default: + break; + } + return CURLE_OK; +} + +static bool cr_in_is_paused(struct Curl_easy *data, + struct Curl_creader *reader) +{ + struct cr_in_ctx *ctx = reader->ctx; + (void)data; + return (bool)ctx->is_paused; +} + +static const struct Curl_crtype cr_in = { + "cr-in", + cr_in_init, + cr_in_read, + Curl_creader_def_close, + cr_in_needs_rewind, + cr_in_total_length, + cr_in_resume_from, + cr_in_cntrl, + cr_in_is_paused, + Curl_creader_def_done, + sizeof(struct cr_in_ctx) +}; + +CURLcode Curl_creader_create(struct Curl_creader **preader, + struct Curl_easy *data, + const struct Curl_crtype *crt, + Curl_creader_phase phase) +{ + struct Curl_creader *reader = NULL; + CURLcode result = CURLE_OUT_OF_MEMORY; + void *p; + + DEBUGASSERT(crt->creader_size >= sizeof(struct Curl_creader)); + p = curlx_calloc(1, crt->creader_size); + if(!p) + goto out; + + reader = (struct Curl_creader *)p; + reader->crt = crt; + reader->ctx = p; + reader->phase = phase; + result = crt->do_init(data, reader); + +out: + *preader = result ? NULL : reader; + if(result) + curlx_free(reader); + return result; +} + +void Curl_creader_free(struct Curl_easy *data, struct Curl_creader *reader) +{ + if(reader) { + reader->crt->do_close(data, reader); + curlx_free(reader); + } +} + +struct cr_lc_ctx { + struct Curl_creader super; + struct bufq buf; + BIT(read_eos); /* we read an EOS from the next reader */ + BIT(eos); /* we have returned an EOS */ + BIT(prev_cr); /* the last byte was a CR */ +}; + +static CURLcode cr_lc_init(struct Curl_easy *data, struct Curl_creader *reader) +{ + struct cr_lc_ctx *ctx = reader->ctx; + (void)data; + Curl_bufq_init2(&ctx->buf, (16 * 1024), 1, BUFQ_OPT_SOFT_LIMIT); + return CURLE_OK; +} + +static void cr_lc_close(struct Curl_easy *data, struct Curl_creader *reader) +{ + struct cr_lc_ctx *ctx = reader->ctx; + (void)data; + Curl_bufq_free(&ctx->buf); +} + +/* client reader doing line end conversions. */ +static CURLcode cr_lc_read(struct Curl_easy *data, + struct Curl_creader *reader, + char *buf, size_t blen, + size_t *pnread, bool *peos) +{ + struct cr_lc_ctx *ctx = reader->ctx; + CURLcode result; + size_t nread, i, start, n; + bool eos; + + if(ctx->eos) { + *pnread = 0; + *peos = TRUE; + return CURLE_OK; + } + + if(Curl_bufq_is_empty(&ctx->buf)) { + if(ctx->read_eos) { + ctx->eos = TRUE; + *pnread = 0; + *peos = TRUE; + return CURLE_OK; + } + /* Still getting data form the next reader, ctx->buf is empty */ + result = Curl_creader_read(data, reader->next, buf, blen, &nread, &eos); + if(result) + return result; + ctx->read_eos = eos; + + if(!nread || !memchr(buf, '\n', nread)) { + /* nothing to convert, return this right away */ + if(nread) + ctx->prev_cr = (buf[nread - 1] == '\r'); + if(ctx->read_eos) + ctx->eos = TRUE; + *pnread = nread; + *peos = (bool)ctx->eos; + goto out; + } + + /* at least one \n might need conversion to '\r\n', place into ctx->buf */ + for(i = start = 0; i < nread; ++i) { + /* if this byte is not an LF character, or if the preceding character is + a CR (meaning this already is a CRLF pair), go to next */ + if((buf[i] != '\n') || ctx->prev_cr) { + ctx->prev_cr = (buf[i] == '\r'); + continue; + } + ctx->prev_cr = FALSE; + /* on a soft limit bufq, we do not need to check length */ + result = Curl_bufq_cwrite(&ctx->buf, buf + start, i - start, &n); + if(!result) + result = Curl_bufq_cwrite(&ctx->buf, STRCONST("\r\n"), &n); + if(result) + return result; + start = i + 1; + } + + if(start < i) { /* leftover */ + result = Curl_bufq_cwrite(&ctx->buf, buf + start, i - start, &n); + if(result) + return result; + } + } + + DEBUGASSERT(!Curl_bufq_is_empty(&ctx->buf)); + *peos = FALSE; + result = Curl_bufq_cread(&ctx->buf, buf, blen, pnread); + if(!result && ctx->read_eos && Curl_bufq_is_empty(&ctx->buf)) { + /* no more data, read all, done. */ + ctx->eos = TRUE; + *peos = TRUE; + } + +out: + CURL_TRC_READ(data, "cr_lc_read(len=%zu) -> %d, nread=%zu, eos=%d", + blen, (int)result, *pnread, *peos); + return result; +} + +static curl_off_t cr_lc_total_length(struct Curl_easy *data, + struct Curl_creader *reader) +{ + /* this reader changes length depending on input */ + (void)data; + (void)reader; + return -1; +} + +static const struct Curl_crtype cr_lc = { + "cr-lineconv", + cr_lc_init, + cr_lc_read, + cr_lc_close, + Curl_creader_def_needs_rewind, + cr_lc_total_length, + Curl_creader_def_resume_from, + Curl_creader_def_cntrl, + Curl_creader_def_is_paused, + Curl_creader_def_done, + sizeof(struct cr_lc_ctx) +}; + +static CURLcode cr_lc_add(struct Curl_easy *data) +{ + struct Curl_creader *reader = NULL; + CURLcode result; + + result = Curl_creader_create(&reader, data, &cr_lc, CURL_CR_CONTENT_ENCODE); + if(!result) + result = Curl_creader_add(data, reader); + + if(result && reader) + Curl_creader_free(data, reader); + return result; +} + +static CURLcode do_init_reader_stack(struct Curl_easy *data, + struct Curl_creader *r) +{ + CURLcode result = CURLE_OK; + curl_off_t clen; + + DEBUGASSERT(r); + DEBUGASSERT(r->crt); + DEBUGASSERT(r->phase == CURL_CR_CLIENT); + DEBUGASSERT(!data->req.reader_stack); + + data->req.reader_stack = r; + clen = r->crt->total_length(data, r); + /* if we do not have 0 length init, and crlf conversion is wanted, + * add the reader for it */ + if(clen && (data->set.crlf +#ifdef CURL_PREFER_LF_LINEENDS + || data->state.prefer_ascii +#endif + )) { + result = cr_lc_add(data); + if(result) + return result; + } + + return result; +} + +CURLcode Curl_creader_set_fread(struct Curl_easy *data, curl_off_t len) +{ + CURLcode result; + struct Curl_creader *r; + struct cr_in_ctx *ctx; + + result = Curl_creader_create(&r, data, &cr_in, CURL_CR_CLIENT); + if(result || !r) + goto out; + ctx = r->ctx; + ctx->total_len = len; + + cl_reset_reader(data); + result = do_init_reader_stack(data, r); +out: + CURL_TRC_READ(data, "add fread reader, len=%" FMT_OFF_T " -> %d", + len, (int)result); + return result; +} + +CURLcode Curl_creader_add(struct Curl_easy *data, + struct Curl_creader *reader) +{ + CURLcode result; + struct Curl_creader **anchor = &data->req.reader_stack; + + if(!*anchor) { + result = Curl_creader_set_fread(data, data->state.infilesize); + if(result) + return result; + } + + /* Insert the writer as first in its phase. + * Skip existing readers of lower phases. */ + while(*anchor && (*anchor)->phase < reader->phase) + anchor = &((*anchor)->next); + reader->next = *anchor; + *anchor = reader; + return CURLE_OK; +} + +CURLcode Curl_creader_set(struct Curl_easy *data, struct Curl_creader *r) +{ + CURLcode result; + + DEBUGASSERT(r); + DEBUGASSERT(r->crt); + DEBUGASSERT(r->phase == CURL_CR_CLIENT); + + cl_reset_reader(data); + result = do_init_reader_stack(data, r); + if(result) + Curl_creader_free(data, r); + return result; +} + +CURLcode Curl_client_read(struct Curl_easy *data, char *buf, size_t blen, + size_t *nread, bool *eos) +{ + CURLcode result; + + DEBUGASSERT(buf); + DEBUGASSERT(blen); + DEBUGASSERT(nread); + DEBUGASSERT(eos); + *nread = 0; + + if(!data->req.reader_stack) { + result = Curl_creader_set_fread(data, data->state.infilesize); + if(result) + return result; + DEBUGASSERT(data->req.reader_stack); + } + if(!data->req.reader_started) { + Curl_rlimit_start(&data->progress.ul.rlimit, Curl_pgrs_now(data), -1); + data->req.reader_started = TRUE; + } + + if(Curl_rlimit_active(&data->progress.ul.rlimit)) { + curl_off_t ul_avail = Curl_rlimit_avail(&data->progress.ul.rlimit, + Curl_pgrs_now(data)); + if(ul_avail <= 0) { + result = CURLE_OK; + *eos = FALSE; + goto out; + } + if(ul_avail < (curl_off_t)blen) + blen = (size_t)ul_avail; + } + result = Curl_creader_read(data, data->req.reader_stack, buf, blen, + nread, eos); + +out: + CURL_TRC_READ(data, "client_read(len=%zu) -> %d, nread=%zu, eos=%d", + blen, (int)result, *nread, *eos); + return result; +} + +bool Curl_creader_needs_rewind(struct Curl_easy *data) +{ + struct Curl_creader *reader = data->req.reader_stack; + while(reader) { + if(reader->crt->needs_rewind(data, reader)) { + CURL_TRC_READ(data, "client reader needs rewind before next request"); + return TRUE; + } + reader = reader->next; + } + return FALSE; +} + +static CURLcode cr_null_read(struct Curl_easy *data, + struct Curl_creader *reader, + char *buf, size_t blen, + size_t *pnread, bool *peos) +{ + (void)data; + (void)reader; + (void)buf; + (void)blen; + *pnread = 0; + *peos = TRUE; + return CURLE_OK; +} + +static curl_off_t cr_null_total_length(struct Curl_easy *data, + struct Curl_creader *reader) +{ + /* this reader changes length depending on input */ + (void)data; + (void)reader; + return 0; +} + +static const struct Curl_crtype cr_null = { + "cr-null", + Curl_creader_def_init, + cr_null_read, + Curl_creader_def_close, + Curl_creader_def_needs_rewind, + cr_null_total_length, + Curl_creader_def_resume_from, + Curl_creader_def_cntrl, + Curl_creader_def_is_paused, + Curl_creader_def_done, + sizeof(struct Curl_creader) +}; + +CURLcode Curl_creader_set_null(struct Curl_easy *data) +{ + struct Curl_creader *r; + CURLcode result; + + result = Curl_creader_create(&r, data, &cr_null, CURL_CR_CLIENT); + if(result) + return result; + + cl_reset_reader(data); + return do_init_reader_stack(data, r); +} + +struct cr_buf_ctx { + struct Curl_creader super; + const char *buf; + size_t blen; + size_t index; +}; + +static CURLcode cr_buf_read(struct Curl_easy *data, + struct Curl_creader *reader, + char *buf, size_t blen, + size_t *pnread, bool *peos) +{ + struct cr_buf_ctx *ctx = reader->ctx; + size_t nread = ctx->blen - ctx->index; + + if(!nread || !ctx->buf) { + *pnread = 0; + *peos = TRUE; + } + else { + if(nread > blen) + nread = blen; + memcpy(buf, ctx->buf + ctx->index, nread); + *pnread = nread; + ctx->index += nread; + *peos = (ctx->index == ctx->blen); + } + CURL_TRC_READ(data, "cr_buf_read(len=%zu) -> 0, nread=%zu, eos=%d", + blen, *pnread, *peos); + return CURLE_OK; +} + +static bool cr_buf_needs_rewind(struct Curl_easy *data, + struct Curl_creader *reader) +{ + struct cr_buf_ctx *ctx = reader->ctx; + (void)data; + return ctx->index > 0; +} + +static CURLcode cr_buf_cntrl(struct Curl_easy *data, + struct Curl_creader *reader, + Curl_creader_cntrl opcode) +{ + struct cr_buf_ctx *ctx = reader->ctx; + (void)data; + switch(opcode) { + case CURL_CRCNTRL_REWIND: + ctx->index = 0; + break; + default: + break; + } + return CURLE_OK; +} + +static curl_off_t cr_buf_total_length(struct Curl_easy *data, + struct Curl_creader *reader) +{ + struct cr_buf_ctx *ctx = reader->ctx; + (void)data; + return (curl_off_t)ctx->blen; +} + +static CURLcode cr_buf_resume_from(struct Curl_easy *data, + struct Curl_creader *reader, + curl_off_t offset) +{ + struct cr_buf_ctx *ctx = reader->ctx; + size_t boffset; + + (void)data; + DEBUGASSERT(data->conn); + /* already started reading? */ + if(ctx->index) + return CURLE_READ_ERROR; + boffset = curlx_sotouz_range(offset, 0, SIZE_MAX); + if(!boffset) + return CURLE_OK; + if(boffset > ctx->blen) + return CURLE_READ_ERROR; + + ctx->buf += boffset; + ctx->blen -= boffset; + return CURLE_OK; +} + +static const struct Curl_crtype cr_buf = { + "cr-buf", + Curl_creader_def_init, + cr_buf_read, + Curl_creader_def_close, + cr_buf_needs_rewind, + cr_buf_total_length, + cr_buf_resume_from, + cr_buf_cntrl, + Curl_creader_def_is_paused, + Curl_creader_def_done, + sizeof(struct cr_buf_ctx) +}; + +CURLcode Curl_creader_set_buf(struct Curl_easy *data, + const char *buf, size_t blen) +{ + CURLcode result; + struct Curl_creader *r; + struct cr_buf_ctx *ctx; + + result = Curl_creader_create(&r, data, &cr_buf, CURL_CR_CLIENT); + if(result) + goto out; + ctx = r->ctx; + ctx->buf = buf; + ctx->blen = blen; + ctx->index = 0; + + cl_reset_reader(data); + result = do_init_reader_stack(data, r); +out: + CURL_TRC_READ(data, "add buf reader, len=%zu -> %d", blen, (int)result); + return result; +} + +curl_off_t Curl_creader_total_length(struct Curl_easy *data) +{ + struct Curl_creader *r = data->req.reader_stack; + return r ? r->crt->total_length(data, r) : -1; +} + +curl_off_t Curl_creader_client_length(struct Curl_easy *data) +{ + struct Curl_creader *r = data->req.reader_stack; + while(r && r->phase != CURL_CR_CLIENT) + r = r->next; + return r ? r->crt->total_length(data, r) : -1; +} + +CURLcode Curl_creader_resume_from(struct Curl_easy *data, curl_off_t offset) +{ + struct Curl_creader *r = data->req.reader_stack; + while(r && r->phase != CURL_CR_CLIENT) + r = r->next; + return r ? r->crt->resume_from(data, r, offset) : CURLE_READ_ERROR; +} + +CURLcode Curl_creader_unpause(struct Curl_easy *data) +{ + struct Curl_creader *reader = data->req.reader_stack; + CURLcode result = CURLE_OK; + + while(reader) { + result = reader->crt->cntrl(data, reader, CURL_CRCNTRL_UNPAUSE); + CURL_TRC_READ(data, "unpausing %s -> %d", reader->crt->name, (int)result); + if(result) + break; + reader = reader->next; + } + return result; +} + +bool Curl_creader_is_paused(struct Curl_easy *data) +{ + struct Curl_creader *reader = data->req.reader_stack; + + while(reader) { + if(reader->crt->is_paused(data, reader)) + return TRUE; + reader = reader->next; + } + return FALSE; +} + +void Curl_creader_done(struct Curl_easy *data, int premature) +{ + struct Curl_creader *reader = data->req.reader_stack; + while(reader) { + reader->crt->done(data, reader, premature); + reader = reader->next; + } +} + +struct Curl_creader *Curl_creader_get_by_type(struct Curl_easy *data, + const struct Curl_crtype *crt) +{ + struct Curl_creader *r; + for(r = data->req.reader_stack; r; r = r->next) { + if(r->crt == crt) + return r; + } + return NULL; +} diff --git a/3rdparty/curl-8.21.0/lib/sendf.h b/3rdparty/curl-8.21.0/lib/sendf.h new file mode 100644 index 0000000000..787fe7ff69 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/sendf.h @@ -0,0 +1,423 @@ +#ifndef HEADER_CURL_SENDF_H +#define HEADER_CURL_SENDF_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +/** + * Type of data that is being written to the client (application) + * - data written can be either BODY or META data + * - META data is either INFO or HEADER + * - INFO is meta information, e.g. not BODY, that cannot be interpreted + * as headers of a response. Example FTP/IMAP pingpong answers. + * - HEADER can have additional bits set (more than one) + * - STATUS special "header", e.g. response status line in HTTP + * - CONNECT header was received during proxying the connection + * - 1XX header is part of an intermediate response, e.g. HTTP 1xx code + * - TRAILER header is trailing response data, e.g. HTTP trailers + * BODY, INFO and HEADER should not be mixed, as this would lead to + * confusion on how to interpret/format/convert the data. + */ +#define CLIENTWRITE_BODY (1 << 0) /* non-meta information, BODY */ +#define CLIENTWRITE_INFO (1 << 1) /* meta information, not a HEADER */ +#define CLIENTWRITE_HEADER (1 << 2) /* meta information, HEADER */ +#define CLIENTWRITE_STATUS (1 << 3) /* a special status HEADER */ +#define CLIENTWRITE_CONNECT (1 << 4) /* a CONNECT related HEADER */ +#define CLIENTWRITE_1XX (1 << 5) /* a 1xx response related HEADER */ +#define CLIENTWRITE_TRAILER (1 << 6) /* a trailer HEADER */ +#define CLIENTWRITE_EOS (1 << 7) /* End Of transfer download Stream */ +#define CLIENTWRITE_0LEN (1 << 8) /* write even 0-length buffers */ + +/* Forward declarations */ +struct Curl_creader; +struct Curl_cwriter; +struct Curl_easy; + +/** + * Write `len` bytes at `buf` to the client. `type` indicates what + * kind of data is being written. + */ +CURLcode Curl_client_write(struct Curl_easy *data, int type, const char *buf, + size_t len) WARN_UNUSED_RESULT; + +/** + * Free all resources related to client writing. + */ +void Curl_client_cleanup(struct Curl_easy *data); + +/** + * Reset readers and writer chains, keep rewind information + * when necessary. + */ +void Curl_client_reset(struct Curl_easy *data); + +/** + * A new request is starting, perform any ops like rewinding + * previous readers when needed. + */ +CURLcode Curl_client_start(struct Curl_easy *data); + +/** + * Client Writers - a chain passing transfer BODY data to the client. + * Main application: HTTP and related protocols + * Other uses: monitoring of download progress + * + * Writers in the chain are order by their `phase`. First come all + * writers in CURL_CW_RAW, followed by any in CURL_CW_TRANSFER_DECODE, + * followed by any in CURL_CW_PROTOCOL, etc. + * + * When adding a writer, it is inserted as first in its phase. This means + * the order of adding writers of the same phase matters, but writers for + * different phases may be added in any order. + * + * Writers which do modify the BODY data written are expected to be of + * phases TRANSFER_DECODE or CONTENT_DECODE. The other phases are intended + * for monitoring writers. Which do *not* modify the data but gather + * statistics or update progress reporting. + */ + +/* Phase a writer operates at. */ +typedef enum { + CURL_CW_RAW, /* raw data written, before any decoding */ + CURL_CW_TRANSFER_DECODE, /* remove transfer-encodings */ + CURL_CW_PROTOCOL, /* after transfer, but before content decoding */ + CURL_CW_CONTENT_DECODE, /* remove content-encodings */ + CURL_CW_CLIENT /* data written to client */ +} Curl_cwriter_phase; + +/* Client Writer Type, provides the implementation */ +struct Curl_cwtype { + const char *name; /* writer name. */ + const char *alias; /* writer name alias, maybe NULL. */ + CURLcode (*do_init)(struct Curl_easy *data, + struct Curl_cwriter *writer); + CURLcode (*do_write)(struct Curl_easy *data, + struct Curl_cwriter *writer, int type, + const char *buf, size_t nbytes); + void (*do_close)(struct Curl_easy *data, + struct Curl_cwriter *writer); + size_t cwriter_size; /* sizeof() allocated struct Curl_cwriter */ +}; + +/* Client writer instance, allocated on creation. + * `void *ctx` is the pointer from the allocation of + * the `struct Curl_cwriter` itself. This is suitable for "downcasting" + * by the writers implementation. See https://github.com/curl/curl/pull/13054 + * for the alignment problems that arise otherwise. + */ +struct Curl_cwriter { + const struct Curl_cwtype *cwt; /* type implementation */ + struct Curl_cwriter *next; /* Downstream writer. */ + void *ctx; /* allocated instance pointer */ + Curl_cwriter_phase phase; /* phase at which it operates */ +}; + +/** + * Create a new cwriter instance with given type and phase. Is not + * inserted into the writer chain by this call. + * Invokes `writer->do_init()`. + */ +CURLcode Curl_cwriter_create(struct Curl_cwriter **pwriter, + struct Curl_easy *data, + const struct Curl_cwtype *cwt, + Curl_cwriter_phase phase); + +/** + * Free a cwriter instance. + * Invokes `writer->do_close()`. + */ +void Curl_cwriter_free(struct Curl_easy *data, + struct Curl_cwriter *writer); + +/** + * Count the number of writers installed of the given phase. + */ +size_t Curl_cwriter_count(struct Curl_easy *data, Curl_cwriter_phase phase); + +/** + * Adds a writer to the transfer's writer chain. + * The writers `phase` determines where in the chain it is inserted. + */ +CURLcode Curl_cwriter_add(struct Curl_easy *data, + struct Curl_cwriter *writer); + +/** + * Look up an installed client writer on `data` by its type. + * @return first writer with that type or NULL + */ +struct Curl_cwriter *Curl_cwriter_get_by_type(struct Curl_easy *data, + const struct Curl_cwtype *cwt); + +struct Curl_cwriter *Curl_cwriter_get_by_name(struct Curl_easy *data, + const char *name); + +/** + * Convenience method for calling `writer->do_write()` that + * checks for NULL writer. + */ +CURLcode Curl_cwriter_write(struct Curl_easy *data, + struct Curl_cwriter *writer, int type, + const char *buf, size_t nbytes); + +/** + * Return TRUE iff client writer is paused. + */ +bool Curl_cwriter_is_paused(struct Curl_easy *data); + +bool Curl_cwriter_is_content_decoding(struct Curl_easy *data); + +/** + * Unpause client writer and flush any buffered date to the client. + */ +CURLcode Curl_cwriter_unpause(struct Curl_easy *data); + +/** + * Default implementations for do_init, do_write, do_close that + * do nothing and pass the data through. + */ +CURLcode Curl_cwriter_def_init(struct Curl_easy *data, + struct Curl_cwriter *writer); +CURLcode Curl_cwriter_def_write(struct Curl_easy *data, + struct Curl_cwriter *writer, int type, + const char *buf, size_t nbytes); +void Curl_cwriter_def_close(struct Curl_easy *data, + struct Curl_cwriter *writer); + +typedef enum { + CURL_CRCNTRL_REWIND, + CURL_CRCNTRL_UNPAUSE, + CURL_CRCNTRL_CLEAR_EOS +} Curl_creader_cntrl; + +/* Client Reader Type, provides the implementation */ +struct Curl_crtype { + const char *name; /* writer name. */ + CURLcode (*do_init)(struct Curl_easy *data, struct Curl_creader *reader); + CURLcode (*do_read)(struct Curl_easy *data, struct Curl_creader *reader, + char *buf, size_t blen, size_t *nread, bool *eos); + void (*do_close)(struct Curl_easy *data, struct Curl_creader *reader); + bool (*needs_rewind)(struct Curl_easy *data, struct Curl_creader *reader); + curl_off_t (*total_length)(struct Curl_easy *data, + struct Curl_creader *reader); + CURLcode (*resume_from)(struct Curl_easy *data, + struct Curl_creader *reader, curl_off_t offset); + CURLcode (*cntrl)(struct Curl_easy *data, struct Curl_creader *reader, + Curl_creader_cntrl opcode); + bool (*is_paused)(struct Curl_easy *data, struct Curl_creader *reader); + void (*done)(struct Curl_easy *data, + struct Curl_creader *reader, int premature); + size_t creader_size; /* sizeof() allocated struct Curl_creader */ +}; + +/* Phase a reader operates at. */ +typedef enum { + CURL_CR_NET, /* data send to the network (connection filters) */ + CURL_CR_TRANSFER_ENCODE, /* add transfer-encodings */ + CURL_CR_PROTOCOL, /* before transfer, but after content decoding */ + CURL_CR_CONTENT_ENCODE, /* add content-encodings */ + CURL_CR_CLIENT /* data read from client */ +} Curl_creader_phase; + +/* Client reader instance, allocated on creation. + * `void *ctx` is the pointer from the allocation of + * the `struct Curl_cwriter` itself. This is suitable for "downcasting" + * by the writers implementation. See https://github.com/curl/curl/pull/13054 + * for the alignment problems that arise otherwise. + */ +struct Curl_creader { + const struct Curl_crtype *crt; /* type implementation */ + struct Curl_creader *next; /* Downstream reader. */ + void *ctx; + Curl_creader_phase phase; /* phase at which it operates */ +}; + +/** + * Default implementations for do_init, do_write, do_close that + * do nothing and pass the data through. + */ +CURLcode Curl_creader_def_init(struct Curl_easy *data, + struct Curl_creader *reader); +void Curl_creader_def_close(struct Curl_easy *data, + struct Curl_creader *reader); +CURLcode Curl_creader_def_read(struct Curl_easy *data, + struct Curl_creader *reader, + char *buf, size_t blen, + size_t *nread, bool *eos); +bool Curl_creader_def_needs_rewind(struct Curl_easy *data, + struct Curl_creader *reader); +curl_off_t Curl_creader_def_total_length(struct Curl_easy *data, + struct Curl_creader *reader); +CURLcode Curl_creader_def_resume_from(struct Curl_easy *data, + struct Curl_creader *reader, + curl_off_t offset); +CURLcode Curl_creader_def_cntrl(struct Curl_easy *data, + struct Curl_creader *reader, + Curl_creader_cntrl opcode); +bool Curl_creader_def_is_paused(struct Curl_easy *data, + struct Curl_creader *reader); +void Curl_creader_def_done(struct Curl_easy *data, + struct Curl_creader *reader, int premature); + +/** + * Convenience method for calling `reader->do_read()` that + * checks for NULL reader. + */ +CURLcode Curl_creader_read(struct Curl_easy *data, + struct Curl_creader *reader, + char *buf, size_t blen, size_t *nread, bool *eos); + +/* Tell the reader and all below that any EOS state is to be cleared */ +void Curl_creader_clear_eos(struct Curl_easy *data, + struct Curl_creader *reader); + +/** + * Create a new creader instance with given type and phase. Is not + * inserted into the writer chain by this call. + * Invokes `reader->do_init()`. + */ +CURLcode Curl_creader_create(struct Curl_creader **preader, + struct Curl_easy *data, + const struct Curl_crtype *crt, + Curl_creader_phase phase); + +/** + * Free a creader instance. + * Invokes `reader->do_close()`. + */ +void Curl_creader_free(struct Curl_easy *data, struct Curl_creader *reader); + +/** + * Adds a reader to the transfer's reader chain. + * The readers `phase` determines where in the chain it is inserted. + */ +CURLcode Curl_creader_add(struct Curl_easy *data, + struct Curl_creader *reader); + +/** + * Set the given reader, which needs to be of type CURL_CR_CLIENT, + * as the new first reader. Discard any installed readers and init + * the reader chain anew. + * The function takes ownership of `r`. + */ +CURLcode Curl_creader_set(struct Curl_easy *data, struct Curl_creader *r); + +/** + * Read at most `blen` bytes at `buf` from the client. + * @param data the transfer to read client bytes for + * @param buf the memory location to read to + * @param blen the amount of memory at `buf` + * @param nread on return the number of bytes read into `buf` + * @param eos TRUE iff bytes are the end of data from client + * @return CURLE_OK on successful read (even 0 length) or error + */ +CURLcode Curl_client_read(struct Curl_easy *data, char *buf, size_t blen, + size_t *nread, bool *eos) WARN_UNUSED_RESULT; + +/** + * TRUE iff client reader needs rewing before it can be used for + * a retry request. + */ +bool Curl_creader_needs_rewind(struct Curl_easy *data); + +/** + * TRUE iff client reader will rewind at next start + */ +bool Curl_creader_will_rewind(struct Curl_easy *data); + +/** + * En-/disable rewind of client reader at next start. + */ +void Curl_creader_set_rewind(struct Curl_easy *data, bool enable); + +/** + * Get the total length of bytes provided by the installed readers. + * This is independent of the amount already delivered and is calculated + * by all readers in the stack. If a reader like "chunked" or + * "crlf conversion" is installed, the returned length will be -1. + * @return -1 if length is indeterminate + */ +curl_off_t Curl_creader_total_length(struct Curl_easy *data); + +/** + * Get the total length of bytes provided by the reader at phase + * CURL_CR_CLIENT. This may not match the amount of bytes read + * for a request, depending if other, encoding readers are also installed. + * However it allows for rough estimation of the overall length. + * @return -1 if length is indeterminate + */ +curl_off_t Curl_creader_client_length(struct Curl_easy *data); + +/** + * Ask the installed reader at phase CURL_CR_CLIENT to start + * reading from the given offset. On success, this will reduce + * the `total_length()` by the amount. + * @param data the transfer to read client bytes for + * @param offset the offset where to start reads from, negative + * values will be ignored. + * @return CURLE_OK if offset could be set + * CURLE_READ_ERROR if not supported by reader or seek/read failed + * of offset larger than total length + * CURLE_PARTIAL_FILE if offset led to 0 total length + */ +CURLcode Curl_creader_resume_from(struct Curl_easy *data, curl_off_t offset); + +/** + * Unpause all installed readers. + */ +CURLcode Curl_creader_unpause(struct Curl_easy *data); + +/** + * Return TRUE iff any of the installed readers is paused. + */ +bool Curl_creader_is_paused(struct Curl_easy *data); + +/** + * Tell all client readers that they are done. + */ +void Curl_creader_done(struct Curl_easy *data, int premature); + +/** + * Look up an installed client reader on `data` by its type. + * @return first reader with that type or NULL + */ +struct Curl_creader *Curl_creader_get_by_type(struct Curl_easy *data, + const struct Curl_crtype *crt); + +/** + * Set the client reader to provide 0 bytes, immediate EOS. + */ +CURLcode Curl_creader_set_null(struct Curl_easy *data); + +/** + * Set the client reader the reads from fread callback. + */ +CURLcode Curl_creader_set_fread(struct Curl_easy *data, curl_off_t len); + +/** + * Set the client reader the reads from the supplied buf (NOT COPIED). + */ +CURLcode Curl_creader_set_buf(struct Curl_easy *data, + const char *buf, size_t blen); + +#endif /* HEADER_CURL_SENDF_H */ diff --git a/3rdparty/curl-8.21.0/lib/setopt.c b/3rdparty/curl-8.21.0/lib/setopt.c new file mode 100644 index 0000000000..eb9ff2e396 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/setopt.c @@ -0,0 +1,2952 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef HAVE_NETINET_IN_H +#include +#endif + +#ifdef HAVE_LINUX_TCP_H +#include +#elif defined(HAVE_NETINET_TCP_H) +#include +#endif + +#include "urldata.h" +#include "url.h" +#include "progress.h" +#include "content_encoding.h" +#include "strcase.h" +#include "curl_share.h" +#include "vtls/vtls.h" +#include "curl_trc.h" +#include "hostip.h" +#include "setopt.h" +#include "altsvc.h" +#include "hsts.h" +#include "tftp.h" +#include "curlx/strdup.h" +#include "escape.h" +#include "bufref.h" +#include "vauth/vauth.h" + +static CURLcode setopt_set_timeout_sec(timediff_t *ptimeout_ms, long secs) +{ + if(secs < 0) + return CURLE_BAD_FUNCTION_ARGUMENT; +#if LONG_MAX > (TIMEDIFF_T_MAX / 1000) + if(secs > (TIMEDIFF_T_MAX / 1000)) { + *ptimeout_ms = TIMEDIFF_T_MAX; + return CURLE_OK; + } +#endif + *ptimeout_ms = (timediff_t)secs * 1000; + return CURLE_OK; +} + +static CURLcode setopt_set_timeout_ms(timediff_t *ptimeout_ms, long ms) +{ + if(ms < 0) + return CURLE_BAD_FUNCTION_ARGUMENT; +#if LONG_MAX > TIMEDIFF_T_MAX + if(ms > TIMEDIFF_T_MAX) { + *ptimeout_ms = TIMEDIFF_T_MAX; + return CURLE_OK; + } +#endif + *ptimeout_ms = (timediff_t)ms; + return CURLE_OK; +} + +CURLcode Curl_setstropt(char **charp, const char *s) +{ + /* Release the previous storage at `charp' and replace by a dynamic storage + copy of `s'. Return CURLE_OK or CURLE_OUT_OF_MEMORY. */ + + curlx_safefree(*charp); + + if(s) { + if(strlen(s) > CURL_MAX_INPUT_LENGTH) + return CURLE_BAD_FUNCTION_ARGUMENT; + + *charp = curlx_strdup(s); + if(!*charp) + return CURLE_OUT_OF_MEMORY; + } + + return CURLE_OK; +} + +CURLcode Curl_setblobopt(struct curl_blob **blobp, + const struct curl_blob *blob) +{ + /* free the previous storage at `blobp' and replace by a dynamic storage + copy of blob. If CURL_BLOB_COPY is set, the data is copied. */ + + curlx_safefree(*blobp); + + if(blob) { + struct curl_blob *nblob; + if(!blob->data || !blob->len || (blob->len > CURL_MAX_INPUT_LENGTH)) + return CURLE_BAD_FUNCTION_ARGUMENT; + nblob = (struct curl_blob *) + curlx_malloc(sizeof(struct curl_blob) + + ((blob->flags & CURL_BLOB_COPY) ? blob->len : 0)); + if(!nblob) + return CURLE_OUT_OF_MEMORY; + *nblob = *blob; + if(blob->flags & CURL_BLOB_COPY) { + /* put the data after the blob struct in memory */ + nblob->data = (char *)nblob + sizeof(struct curl_blob); + memcpy(nblob->data, blob->data, blob->len); + } + + *blobp = nblob; + return CURLE_OK; + } + + return CURLE_OK; +} + +static CURLcode setstropt_userpwd(const char *option, char **userp, + char **passwdp) +{ + char *user = NULL; + char *passwd = NULL; + + DEBUGASSERT(userp); + DEBUGASSERT(passwdp); + + /* Parse the login details if specified. If not, then we treat NULL as a + hint to clear the existing data */ + if(option) { + size_t len = strlen(option); + CURLcode result; + if(len > CURL_MAX_INPUT_LENGTH) + return CURLE_BAD_FUNCTION_ARGUMENT; + + result = Curl_parse_login_details(option, len, &user, &passwd, NULL); + if(result) + return result; + } + + curlx_free(*userp); + *userp = user; + + curlx_free(*passwdp); + *passwdp = passwd; + + return CURLE_OK; +} + +static CURLcode setstropt_interface(char *option, char **devp, + char **ifacep, char **hostp) +{ + char *dev = NULL; + char *iface = NULL; + char *host = NULL; + CURLcode result; + + DEBUGASSERT(devp); + DEBUGASSERT(ifacep); + DEBUGASSERT(hostp); + + if(option) { + /* Parse the interface details if set, otherwise clear them all */ + result = Curl_parse_interface(option, &dev, &iface, &host); + if(result) + return result; + } + curlx_free(*devp); + *devp = dev; + + curlx_free(*ifacep); + *ifacep = iface; + + curlx_free(*hostp); + *hostp = host; + + return CURLE_OK; +} + +#ifdef USE_SSL +#define C_SSLVERSION_VALUE(x) ((x) & 0xffff) +#define C_SSLVERSION_MAX_VALUE(x) ((unsigned long)(x) & 0xffff0000) +#endif + +static CURLcode protocol2num(const char *str, curl_prot_t *val) +{ + /* + * We are asked to cherry-pick protocols, so play it safe and disallow all + * protocols to start with, and re-add the wanted ones back in. + */ + *val = 0; + + if(!str) + return CURLE_BAD_FUNCTION_ARGUMENT; + + if(curl_strequal(str, "all")) { + *val = ~(curl_prot_t)0; + return CURLE_OK; + } + + do { + const char *token = str; + size_t tlen; + + str = strchr(str, ','); + tlen = str ? (size_t)(str - token) : strlen(token); + if(tlen) { + const struct Curl_scheme *h = Curl_getn_scheme(token, tlen); + + if(!h || !h->run) + return CURLE_UNSUPPORTED_PROTOCOL; + + *val |= h->protocol; + } + } while(str && str++); + + if(!*val) + /* no protocol listed */ + return CURLE_BAD_FUNCTION_ARGUMENT; + return CURLE_OK; +} + +#if !defined(CURL_DISABLE_HTTP) || !defined(CURL_DISABLE_PROXY) +static CURLcode httpauth(struct Curl_easy *data, bool proxy, + unsigned long auth) +{ + if(auth != CURLAUTH_NONE) { + int bitcheck = 0; + bool authbits = FALSE; + if(auth & CURLAUTH_DIGEST_IE) { + auth |= CURLAUTH_DIGEST; /* set standard digest bit */ + auth &= ~CURLAUTH_DIGEST_IE; /* drop the legacy bit */ + } + + /* switch off bits we cannot support */ +#ifndef USE_NTLM + auth &= ~CURLAUTH_NTLM; /* no NTLM support */ +#endif +#ifndef USE_SPNEGO + auth &= ~CURLAUTH_NEGOTIATE; /* no Negotiate (SPNEGO) auth without GSS-API + or SSPI */ +#endif + + /* check if any auth bit lower than CURLAUTH_ONLY is still set */ + while(bitcheck < 31) { + if(auth & (1UL << bitcheck++)) { + authbits = TRUE; + break; + } + } + if(!authbits) + return CURLE_NOT_BUILT_IN; /* no supported types left! */ + } + if(proxy) + data->set.proxyauth = (uint32_t)auth; + else + data->set.httpauth = (uint32_t)auth; + return CURLE_OK; +} +#endif /* !CURL_DISABLE_HTTP || !CURL_DISABLE_PROXY */ + +#ifndef CURL_DISABLE_HTTP +static CURLcode setopt_HTTP_VERSION(struct Curl_easy *data, long arg) +{ + /* + * This sets a requested HTTP version to be used. The value is one of + * the listed enums in curl/curl.h. + */ + switch(arg) { + case CURL_HTTP_VERSION_NONE: + /* accepted */ + break; + case CURL_HTTP_VERSION_1_0: + case CURL_HTTP_VERSION_1_1: + /* accepted */ + break; +#ifdef USE_HTTP2 + case CURL_HTTP_VERSION_2_0: + case CURL_HTTP_VERSION_2TLS: + case CURL_HTTP_VERSION_2_PRIOR_KNOWLEDGE: + /* accepted */ + break; +#endif +#ifdef USE_HTTP3 + case CURL_HTTP_VERSION_3: + case CURL_HTTP_VERSION_3ONLY: + /* accepted */ + break; +#endif + default: + /* not accepted */ + if(arg < CURL_HTTP_VERSION_NONE) + return CURLE_BAD_FUNCTION_ARGUMENT; + return CURLE_UNSUPPORTED_PROTOCOL; + } + data->set.httpwant = (unsigned char)arg; + return CURLE_OK; +} +#endif /* !CURL_DISABLE_HTTP */ + +#ifdef USE_SSL +CURLcode Curl_setopt_SSLVERSION(struct Curl_easy *data, CURLoption option, + long arg) +{ + /* + * Set explicit SSL version to try to connect with, as some SSL + * implementations are lame. + */ + { + long version, version_max; + struct ssl_primary_config *primary = &data->set.ssl.primary; +#ifndef CURL_DISABLE_PROXY + if(option != CURLOPT_SSLVERSION) + primary = &data->set.proxy_ssl.primary; +#else + (void)option; /* unused */ +#endif + version = C_SSLVERSION_VALUE(arg); + version_max = (long)C_SSLVERSION_MAX_VALUE(arg); + + if(version < CURL_SSLVERSION_DEFAULT || + version == CURL_SSLVERSION_SSLv2 || + version == CURL_SSLVERSION_SSLv3 || + version >= CURL_SSLVERSION_LAST || + version_max < CURL_SSLVERSION_MAX_NONE || + version_max >= CURL_SSLVERSION_MAX_LAST) + return CURLE_BAD_FUNCTION_ARGUMENT; + if(version == CURL_SSLVERSION_DEFAULT) + version = CURL_SSLVERSION_TLSv1_2; + + primary->version = (unsigned char)version; + primary->version_max = (unsigned int)version_max; + } + return CURLE_OK; +} +#endif /* !USE_SSL */ + +#ifndef CURL_DISABLE_RTSP +static CURLcode setopt_RTSP_REQUEST(struct Curl_easy *data, long arg) +{ + /* + * Set the RTSP request method (OPTIONS, SETUP, PLAY, etc...) Would this be + * better if the RTSPREQ_* were moved into here? + */ + Curl_RtspReq rtspreq = RTSPREQ_NONE; + switch(arg) { + case CURL_RTSPREQ_OPTIONS: + rtspreq = RTSPREQ_OPTIONS; + break; + case CURL_RTSPREQ_DESCRIBE: + rtspreq = RTSPREQ_DESCRIBE; + break; + case CURL_RTSPREQ_ANNOUNCE: + rtspreq = RTSPREQ_ANNOUNCE; + break; + case CURL_RTSPREQ_SETUP: + rtspreq = RTSPREQ_SETUP; + break; + case CURL_RTSPREQ_PLAY: + rtspreq = RTSPREQ_PLAY; + break; + case CURL_RTSPREQ_PAUSE: + rtspreq = RTSPREQ_PAUSE; + break; + case CURL_RTSPREQ_TEARDOWN: + rtspreq = RTSPREQ_TEARDOWN; + break; + case CURL_RTSPREQ_GET_PARAMETER: + rtspreq = RTSPREQ_GET_PARAMETER; + break; + case CURL_RTSPREQ_SET_PARAMETER: + rtspreq = RTSPREQ_SET_PARAMETER; + break; + case CURL_RTSPREQ_RECORD: + rtspreq = RTSPREQ_RECORD; + break; + case CURL_RTSPREQ_RECEIVE: + rtspreq = RTSPREQ_RECEIVE; + break; + default: + return CURLE_BAD_FUNCTION_ARGUMENT; + } + + data->set.rtspreq = rtspreq; + return CURLE_OK; +} +#endif /* !CURL_DISABLE_RTSP */ + +static CURLcode setopt_long_bool(struct Curl_easy *data, CURLoption option, + long arg) +{ + bool enabled = !!arg; + int ok = 1; + struct UserDefined *s = &data->set; + switch(option) { + case CURLOPT_FORBID_REUSE: + /* + * When this transfer is done, it must not be left to be reused by a + * subsequent transfer but shall be closed immediately. + */ + s->reuse_forbid = enabled; + break; + case CURLOPT_FRESH_CONNECT: + /* + * This transfer shall not use a previously cached connection but + * should be made with a fresh new connect! + */ + s->reuse_fresh = enabled; + break; + case CURLOPT_VERBOSE: + /* + * Verbose means infof() calls that give a lot of information about + * the connection and transfer procedures as well as internal choices. + */ + s->verbose = enabled; + break; + case CURLOPT_HEADER: + /* + * Set to include the header in the general data output stream. + */ + s->include_header = enabled; + break; + case CURLOPT_NOPROGRESS: + /* + * Shut off the internal supported progress meter + */ + data->progress.hide = enabled; + break; + case CURLOPT_NOBODY: + /* + * Do not include the body part in the output data stream. + */ + s->opt_no_body = enabled; +#ifndef CURL_DISABLE_HTTP + if(s->opt_no_body) + /* in HTTP lingo, no body means using the HEAD request... */ + s->method = HTTPREQ_HEAD; + else if(s->method == HTTPREQ_HEAD) + s->method = HTTPREQ_GET; +#endif + break; + case CURLOPT_FAILONERROR: + /* + * Do not output the >=400 error code HTML-page, but instead only + * return error. + */ + s->http_fail_on_error = enabled; + break; + case CURLOPT_KEEP_SENDING_ON_ERROR: + s->http_keep_sending_on_error = enabled; + break; + case CURLOPT_UPLOAD: + case CURLOPT_PUT: + /* + * We want to send data to the remote host. If this is HTTP, that equals + * using the PUT request. + */ + if(enabled) { + /* If this is HTTP, PUT is what's needed to "upload" */ + s->method = HTTPREQ_PUT; + s->opt_no_body = FALSE; /* this is implied */ + } + else + /* In HTTP, the opposite of upload is GET (unless NOBODY is true as + then this can be changed to HEAD later on) */ + s->method = HTTPREQ_GET; + break; + case CURLOPT_FILETIME: + /* + * Try to get the file time of the remote document. The time will + * later (possibly) become available using curl_easy_getinfo(). + */ + s->get_filetime = enabled; + break; +#ifndef CURL_DISABLE_HTTP + case CURLOPT_HTTP09_ALLOWED: + s->http09_allowed = enabled; + break; +#ifndef CURL_DISABLE_COOKIES + case CURLOPT_COOKIESESSION: + /* + * Set this option to TRUE to start a new "cookie session". It will + * prevent the forthcoming read-cookies-from-file actions to accept + * cookies that are marked as being session cookies, as they belong to a + * previous session. + */ + s->cookiesession = enabled; + break; +#endif + case CURLOPT_AUTOREFERER: + /* + * Switch on automatic referer that gets set if curl follows locations. + */ + s->http_auto_referer = enabled; + break; + case CURLOPT_TRANSFER_ENCODING: + s->http_transfer_encoding = enabled; + break; + case CURLOPT_UNRESTRICTED_AUTH: + /* + * Send authentication (user+password) when following locations, even when + * hostname changed. + */ + s->allow_auth_to_other_hosts = enabled; + break; + case CURLOPT_HTTP_TRANSFER_DECODING: + /* + * disable libcurl transfer encoding is used + */ + s->http_te_skip = !enabled; /* reversed */ + break; + case CURLOPT_HTTP_CONTENT_DECODING: + /* + * raw data passed to the application when content encoding is used + */ + s->http_ce_skip = !enabled; /* reversed */ + break; + case CURLOPT_HTTPGET: + /* + * Set to force us do HTTP GET + */ + if(enabled) { + s->method = HTTPREQ_GET; + s->opt_no_body = FALSE; /* this is implied */ + } + break; + case CURLOPT_POST: + /* Does this option serve a purpose anymore? Yes it does, when + CURLOPT_POSTFIELDS is not used and the POST data is read off the + callback! */ + if(enabled) { + s->method = HTTPREQ_POST; + s->opt_no_body = FALSE; /* this is implied */ + } + else + s->method = HTTPREQ_GET; + break; +#endif /* !CURL_DISABLE_HTTP */ +#ifndef CURL_DISABLE_PROXY + case CURLOPT_HTTPPROXYTUNNEL: + /* + * Tunnel operations through the proxy instead of normal proxy use + */ + s->tunnel_thru_httpproxy = enabled; + break; + case CURLOPT_HAPROXYPROTOCOL: + /* + * Set to send the HAProxy Proxy Protocol header + */ + s->haproxyprotocol = enabled; + break; + case CURLOPT_PROXY_SSL_VERIFYPEER: + /* + * Enable peer SSL verifying for proxy. + */ + s->proxy_ssl.primary.verifypeer = enabled; + + /* Update the current connection proxy_ssl_config. */ + Curl_ssl_conn_config_update(data, TRUE); + break; + case CURLOPT_PROXY_SSL_VERIFYHOST: + /* + * Enable verification of the hostname in the peer certificate for proxy + */ + s->proxy_ssl.primary.verifyhost = enabled; + ok = 2; + /* Update the current connection proxy_ssl_config. */ + Curl_ssl_conn_config_update(data, TRUE); + break; + case CURLOPT_PROXY_TRANSFER_MODE: + /* + * set transfer mode (;type=) when doing FTP via an HTTP proxy + */ + s->proxy_transfer_mode = enabled; + break; +#endif /* !CURL_DISABLE_PROXY */ +#if defined(HAVE_GSSAPI) || defined(USE_WINDOWS_SSPI) + case CURLOPT_SOCKS5_GSSAPI_NEC: + /* + * Set flag for NEC SOCKS5 support + */ + s->socks5_gssapi_nec = enabled; + break; +#endif +#ifdef CURL_LIST_ONLY_PROTOCOL + case CURLOPT_DIRLISTONLY: + /* + * An option that changes the command to one that asks for a list only, no + * file info details. Used for FTP, POP3 and SFTP. + */ + s->list_only = enabled; + break; +#endif + case CURLOPT_APPEND: + /* + * We want to upload and append to an existing file. Used for FTP and + * SFTP. + */ + s->remote_append = enabled; + break; +#ifndef CURL_DISABLE_FTP + case CURLOPT_FTP_USE_EPRT: + s->ftp_use_eprt = enabled; + break; + case CURLOPT_FTP_USE_EPSV: + s->ftp_use_epsv = enabled; + break; + case CURLOPT_FTP_USE_PRET: + s->ftp_use_pret = enabled; + break; + case CURLOPT_FTP_SKIP_PASV_IP: + /* + * Enable or disable FTP_SKIP_PASV_IP, which will disable/enable the + * bypass of the IP address in PASV responses. + */ + s->ftp_skip_ip = enabled; + break; + case CURLOPT_WILDCARDMATCH: + s->wildcard_enabled = enabled; + break; +#endif + case CURLOPT_CRLF: + /* + * Kludgy option to enable CRLF conversions. Subject for removal. + */ + s->crlf = enabled; + break; +#ifndef CURL_DISABLE_TFTP + case CURLOPT_TFTP_NO_OPTIONS: + /* + * Option that prevents libcurl from sending TFTP option requests to the + * server. + */ + s->tftp_no_options = enabled; + break; +#endif /* !CURL_DISABLE_TFTP */ + case CURLOPT_TRANSFERTEXT: + /* + * This option was previously named 'FTPASCII'. Renamed to work with + * more protocols than merely FTP. + * + * Transfer using ASCII (instead of BINARY). + */ + s->prefer_ascii = enabled; + break; + case CURLOPT_SSL_VERIFYPEER: + /* + * Enable peer SSL verifying. + */ + s->ssl.primary.verifypeer = enabled; + + /* Update the current connection ssl_config. */ + Curl_ssl_conn_config_update(data, FALSE); + break; +#ifndef CURL_DISABLE_DOH + case CURLOPT_DOH_SSL_VERIFYPEER: + /* + * Enable peer SSL verifying for DoH. + */ + s->doh_verifypeer = enabled; + break; + case CURLOPT_DOH_SSL_VERIFYHOST: + /* + * Enable verification of the hostname in the peer certificate for DoH + */ + s->doh_verifyhost = enabled; + ok = 2; + break; + case CURLOPT_DOH_SSL_VERIFYSTATUS: + /* + * Enable certificate status verifying for DoH. + */ + if(!Curl_ssl_cert_status_request()) + return CURLE_NOT_BUILT_IN; + + s->doh_verifystatus = enabled; + ok = 2; + break; +#endif /* !CURL_DISABLE_DOH */ + case CURLOPT_SSL_VERIFYHOST: + /* + * Enable verification of the hostname in the peer certificate + */ + + /* Obviously people are not reading documentation and too many thought + this argument took a boolean when it was not and misused it. + Treat 1 and 2 the same */ + s->ssl.primary.verifyhost = enabled; + ok = 2; + + /* Update the current connection ssl_config. */ + Curl_ssl_conn_config_update(data, FALSE); + break; + case CURLOPT_SSL_VERIFYSTATUS: + /* + * Enable certificate status verifying. + */ + if(!Curl_ssl_cert_status_request()) + return CURLE_NOT_BUILT_IN; + + s->ssl.primary.verifystatus = enabled; + + /* Update the current connection ssl_config. */ + Curl_ssl_conn_config_update(data, FALSE); + break; + case CURLOPT_CERTINFO: +#ifdef USE_SSL + if(Curl_ssl_supports(data, SSLSUPP_CERTINFO)) + s->ssl.certinfo = enabled; + else +#endif + return CURLE_NOT_BUILT_IN; + break; + case CURLOPT_NOSIGNAL: + /* + * The application asks not to set any signal() or alarm() handlers, + * even when using a timeout. + */ + s->no_signal = enabled; + break; + case CURLOPT_TCP_NODELAY: + /* + * Enable or disable TCP_NODELAY, which will disable/enable the Nagle + * algorithm + */ + s->tcp_nodelay = enabled; + break; + case CURLOPT_IGNORE_CONTENT_LENGTH: + s->ignorecl = enabled; + break; + case CURLOPT_SSL_SESSIONID_CACHE: + s->ssl.primary.cache_session = enabled; +#ifndef CURL_DISABLE_PROXY + s->proxy_ssl.primary.cache_session = s->ssl.primary.cache_session; +#endif + break; +#ifdef USE_SSH + case CURLOPT_SSH_COMPRESSION: + s->ssh_compression = enabled; + break; +#endif /* !USE_SSH */ +#ifndef CURL_DISABLE_SMTP + case CURLOPT_MAIL_RCPT_ALLOWFAILS: + /* allow RCPT TO command to fail for some recipients */ + s->mail_rcpt_allowfails = enabled; + break; +#endif /* !CURL_DISABLE_SMTP */ + case CURLOPT_SASL_IR: + /* Enable/disable SASL initial response */ + s->sasl_ir = enabled; + break; + case CURLOPT_TCP_KEEPALIVE: + s->tcp_keepalive = enabled; + break; + case CURLOPT_TCP_FASTOPEN: +#if defined(CONNECT_DATA_IDEMPOTENT) || defined(MSG_FASTOPEN) || \ + defined(TCP_FASTOPEN_CONNECT) + s->tcp_fastopen = enabled; + break; +#else + return CURLE_NOT_BUILT_IN; +#endif + case CURLOPT_SSL_ENABLE_ALPN: + s->ssl_enable_alpn = enabled; + break; + case CURLOPT_PATH_AS_IS: + s->path_as_is = enabled; + break; + case CURLOPT_PIPEWAIT: + s->pipewait = enabled; + break; + case CURLOPT_SUPPRESS_CONNECT_HEADERS: + s->suppress_connect_headers = enabled; + break; +#ifndef CURL_DISABLE_SHUFFLE_DNS + case CURLOPT_DNS_SHUFFLE_ADDRESSES: + s->dns_shuffle_addresses = enabled; + break; +#endif + case CURLOPT_DISALLOW_USERNAME_IN_URL: + s->disallow_username_in_url = enabled; + break; + case CURLOPT_QUICK_EXIT: + s->quick_exit = enabled; + break; + default: + return CURLE_UNKNOWN_OPTION; + } + if((arg > ok) || (arg < 0)) + /* reserve other values for future use */ + infof(data, "boolean setopt(%d) got unsupported argument %ld," + " treated as %d", (int)option, arg, enabled); + + return CURLE_OK; +} + +static CURLcode value_range(long *value, long below_error, long min, long max) +{ + if(*value < below_error) + return CURLE_BAD_FUNCTION_ARGUMENT; + else if(*value < min) + *value = min; + else if(*value > max) + *value = max; + return CURLE_OK; +} + +static CURLcode setopt_long_net(struct Curl_easy *data, CURLoption option, + long arg) +{ + CURLcode result = CURLE_OK; + struct UserDefined *s = &data->set; + + switch(option) { + case CURLOPT_DNS_CACHE_TIMEOUT: + if(arg != -1) + return setopt_set_timeout_sec(&s->dns_cache_timeout_ms, arg); + s->dns_cache_timeout_ms = -1; + break; + case CURLOPT_MAXCONNECTS: + result = value_range(&arg, 0, 0, INT_MAX); + if(!result) + s->maxconnects = arg ? (uint32_t)arg : DEFAULT_CONNCACHE_SIZE; + break; + case CURLOPT_SERVER_RESPONSE_TIMEOUT: + return setopt_set_timeout_sec(&s->server_response_timeout, arg); + case CURLOPT_SERVER_RESPONSE_TIMEOUT_MS: + return setopt_set_timeout_ms(&s->server_response_timeout, arg); + case CURLOPT_LOW_SPEED_LIMIT: + if(arg < 0) + result = CURLE_BAD_FUNCTION_ARGUMENT; + else + s->low_speed_limit = arg; + break; + case CURLOPT_LOW_SPEED_TIME: + result = value_range(&arg, 0, 0, USHRT_MAX); + if(!result) + s->low_speed_time = (uint16_t)arg; + break; + case CURLOPT_PORT: + if((arg < 0) || (arg > 65535)) + return CURLE_BAD_FUNCTION_ARGUMENT; + s->use_port = (unsigned short)arg; + break; + case CURLOPT_TIMEOUT: + return setopt_set_timeout_sec(&s->timeout, arg); + case CURLOPT_TIMEOUT_MS: + return setopt_set_timeout_ms(&s->timeout, arg); + case CURLOPT_CONNECTTIMEOUT: + return setopt_set_timeout_sec(&s->connecttimeout, arg); + case CURLOPT_CONNECTTIMEOUT_MS: + return setopt_set_timeout_ms(&s->connecttimeout, arg); +#ifndef CURL_DISABLE_BINDLOCAL + case CURLOPT_LOCALPORT: + if((arg < 0) || (arg > 65535)) + return CURLE_BAD_FUNCTION_ARGUMENT; + s->localport = curlx_sltous(arg); + break; + case CURLOPT_LOCALPORTRANGE: + if((arg < 0) || (arg > 65535)) + return CURLE_BAD_FUNCTION_ARGUMENT; + s->localportrange = curlx_sltous(arg); + break; +#endif + case CURLOPT_BUFFERSIZE: + result = value_range(&arg, 0, READBUFFER_MIN, READBUFFER_MAX); + if(!result) + s->buffer_size = (unsigned int)arg; + break; + case CURLOPT_UPLOAD_BUFFERSIZE: + result = value_range(&arg, 0, UPLOADBUFFER_MIN, UPLOADBUFFER_MAX); + if(!result) + s->upload_buffer_size = (unsigned int)arg; + break; + case CURLOPT_MAXFILESIZE: + if(arg < 0) + result = CURLE_BAD_FUNCTION_ARGUMENT; + else + s->max_filesize = arg; + break; + case CURLOPT_IPRESOLVE: + if((arg < CURL_IPRESOLVE_WHATEVER) || (arg > CURL_IPRESOLVE_V6)) + result = CURLE_BAD_FUNCTION_ARGUMENT; + else + s->ipver = (unsigned char)arg; + break; + case CURLOPT_CONNECT_ONLY: + if(arg < 0 || arg > 2) + result = CURLE_BAD_FUNCTION_ARGUMENT; + else { + s->connect_only = !!arg; + s->connect_only_ws = (arg == 2); + } + break; +#ifdef USE_IPV6 + case CURLOPT_ADDRESS_SCOPE: +#if SIZEOF_LONG > 4 + if((unsigned long)arg > UINT_MAX) + result = CURLE_BAD_FUNCTION_ARGUMENT; + else +#endif + s->scope_id = (unsigned int)arg; + break; +#endif + case CURLOPT_TCP_KEEPIDLE: + result = value_range(&arg, 0, 0, INT_MAX); + if(!result) + s->tcp_keepidle = (int)arg; + break; + case CURLOPT_TCP_KEEPINTVL: + result = value_range(&arg, 0, 0, INT_MAX); + if(!result) + s->tcp_keepintvl = (int)arg; + break; + case CURLOPT_TCP_KEEPCNT: + result = value_range(&arg, 0, 0, INT_MAX); + if(!result) + s->tcp_keepcnt = (int)arg; + break; + case CURLOPT_HAPPY_EYEBALLS_TIMEOUT_MS: + return setopt_set_timeout_ms(&s->happy_eyeballs_timeout, arg); + case CURLOPT_UPKEEP_INTERVAL_MS: + return setopt_set_timeout_ms(&s->upkeep_interval_ms, arg); + case CURLOPT_MAXAGE_CONN: + return setopt_set_timeout_sec(&s->conn_max_idle_ms, arg); + case CURLOPT_MAXLIFETIME_CONN: + return setopt_set_timeout_sec(&s->conn_max_age_ms, arg); + case CURLOPT_DNS_USE_GLOBAL_CACHE: + /* deprecated */ + break; + default: + return CURLE_UNKNOWN_OPTION; + } + return result; +} + +static CURLcode setopt_long_ssl(struct Curl_easy *data, CURLoption option, + long arg) +{ +#ifdef USE_SSL + CURLcode result = CURLE_OK; + struct UserDefined *s = &data->set; + switch(option) { + case CURLOPT_CA_CACHE_TIMEOUT: + if(Curl_ssl_supports(data, SSLSUPP_CA_CACHE)) { + result = value_range(&arg, -1, -1, INT_MAX); + if(!result) + s->general_ssl.ca_cache_timeout = (int)arg; + } + else + result = CURLE_NOT_BUILT_IN; + break; + case CURLOPT_SSLVERSION: +#ifndef CURL_DISABLE_PROXY + case CURLOPT_PROXY_SSLVERSION: +#endif + return Curl_setopt_SSLVERSION(data, option, arg); + case CURLOPT_SSL_FALSESTART: + result = CURLE_NOT_BUILT_IN; + break; + case CURLOPT_USE_SSL: + if((arg < CURLUSESSL_NONE) || (arg >= CURLUSESSL_LAST)) + result = CURLE_BAD_FUNCTION_ARGUMENT; + else + s->use_ssl = (unsigned char)arg; + break; + case CURLOPT_SSL_OPTIONS: + s->ssl.primary.ssl_options = (unsigned char)(arg & 0xff); + break; +#ifndef CURL_DISABLE_PROXY + case CURLOPT_PROXY_SSL_OPTIONS: + s->proxy_ssl.primary.ssl_options = (unsigned char)(arg & 0xff); + break; +#endif + case CURLOPT_SSL_ENABLE_NPN: + break; + case CURLOPT_SSLENGINE_DEFAULT: + curlx_safefree(s->str[STRING_SSL_ENGINE]); + result = Curl_ssl_set_engine_default(data); + break; + default: + return CURLE_UNKNOWN_OPTION; + } + return result; +#else /* USE_SSL */ + (void)data; + (void)option; + (void)arg; + return CURLE_UNKNOWN_OPTION; +#endif /* !USE_SSL */ +} + +#ifndef CURL_DISABLE_PROXY +static void changeproxy(struct Curl_easy *data) +{ + Curl_auth_digest_cleanup(&data->state.proxydigest); + memset(&data->state.authproxy, 0, sizeof(data->state.authproxy)); +} + +static CURLcode setopt_long_proxy(struct Curl_easy *data, CURLoption option, + long arg) +{ + struct UserDefined *s = &data->set; + + switch(option) { + case CURLOPT_PROXYPORT: + if((arg < 0) || (arg > UINT16_MAX)) + return CURLE_BAD_FUNCTION_ARGUMENT; + if(arg != s->proxyport) + changeproxy(data); + s->proxyport = (uint16_t)arg; + break; + case CURLOPT_PROXYAUTH: + return httpauth(data, TRUE, (unsigned long)arg); + case CURLOPT_PROXYTYPE: + if((arg < CURLPROXY_HTTP) || (arg > CURLPROXY_HTTPS3)) + return CURLE_BAD_FUNCTION_ARGUMENT; +#ifndef USE_PROXY_HTTP3 + if(arg == CURLPROXY_HTTPS3) + return CURLE_NOT_BUILT_IN; +#endif + s->proxytype = (unsigned char)arg; + break; + case CURLOPT_SOCKS5_AUTH: + if(arg & ~(CURLAUTH_BASIC | CURLAUTH_GSSAPI)) + return CURLE_NOT_BUILT_IN; + s->socks5auth = (unsigned char)arg; + break; + default: + return CURLE_UNKNOWN_OPTION; + } + return CURLE_OK; +} +#else +static CURLcode setopt_long_proxy(struct Curl_easy *data, CURLoption option, + long arg) +{ + (void)data; + (void)option; + (void)arg; + return CURLE_UNKNOWN_OPTION; +} +#endif + +static CURLcode setopt_long_http(struct Curl_easy *data, CURLoption option, + long arg) +{ +#ifndef CURL_DISABLE_HTTP + CURLcode result = CURLE_OK; + struct UserDefined *s = &data->set; + + switch(option) { + case CURLOPT_FOLLOWLOCATION: + if((unsigned long)arg > 3) + result = CURLE_BAD_FUNCTION_ARGUMENT; + else + s->http_follow_mode = (unsigned char)arg; + break; + case CURLOPT_MAXREDIRS: + result = value_range(&arg, -1, -1, 0x7fff); + if(!result) + s->maxredirs = (short)arg; + break; + case CURLOPT_POSTREDIR: + if(arg < CURL_REDIR_GET_ALL) + result = CURLE_BAD_FUNCTION_ARGUMENT; + else { + s->post301 = !!(arg & CURL_REDIR_POST_301); + s->post302 = !!(arg & CURL_REDIR_POST_302); + s->post303 = !!(arg & CURL_REDIR_POST_303); + } + break; + case CURLOPT_HEADEROPT: + s->sep_headers = !!(arg & CURLHEADER_SEPARATE); + break; + case CURLOPT_HTTPAUTH: + return httpauth(data, FALSE, (unsigned long)arg); + case CURLOPT_HTTP_VERSION: + return setopt_HTTP_VERSION(data, arg); + case CURLOPT_EXPECT_100_TIMEOUT_MS: + result = value_range(&arg, 0, 0, 0xffff); + if(!result) + s->expect_100_timeout = (unsigned short)arg; + break; + case CURLOPT_STREAM_WEIGHT: +#if defined(USE_HTTP2) || defined(USE_HTTP3) + if((arg >= 1) && (arg <= 256)) + s->priority.weight = (int)arg; + break; +#else + result = CURLE_NOT_BUILT_IN; + break; +#endif + default: + return CURLE_UNKNOWN_OPTION; + } + return result; +#else + (void)data; + (void)option; + (void)arg; + return CURLE_UNKNOWN_OPTION; +#endif +} + +static CURLcode setopt_long_proto(struct Curl_easy *data, CURLoption option, + long arg) +{ + CURLcode result = CURLE_OK; + struct UserDefined *s = &data->set; + + switch(option) { +#ifndef CURL_DISABLE_TFTP + case CURLOPT_TFTP_BLKSIZE: + result = value_range(&arg, 0, TFTP_BLKSIZE_MIN, TFTP_BLKSIZE_MAX); + if(!result) + s->tftp_blksize = (unsigned short)arg; + break; +#endif +#ifndef CURL_DISABLE_NETRC + case CURLOPT_NETRC: + if((arg < CURL_NETRC_IGNORED) || (arg >= CURL_NETRC_LAST)) + result = CURLE_BAD_FUNCTION_ARGUMENT; + else + s->use_netrc = (unsigned char)arg; + break; +#endif +#ifndef CURL_DISABLE_FTP + case CURLOPT_FTP_FILEMETHOD: + if((arg < CURLFTPMETHOD_DEFAULT) || (arg >= CURLFTPMETHOD_LAST)) + result = CURLE_BAD_FUNCTION_ARGUMENT; + else + s->ftp_filemethod = (unsigned char)arg; + break; + case CURLOPT_FTP_SSL_CCC: + if((arg < CURLFTPSSL_CCC_NONE) || (arg >= CURLFTPSSL_CCC_LAST)) + result = CURLE_BAD_FUNCTION_ARGUMENT; + else + s->ftp_ccc = (unsigned char)arg; + break; + case CURLOPT_FTPSSLAUTH: + if((arg < CURLFTPAUTH_DEFAULT) || (arg >= CURLFTPAUTH_LAST)) + result = CURLE_BAD_FUNCTION_ARGUMENT; + else + s->ftpsslauth = (unsigned char)arg; + break; + case CURLOPT_ACCEPTTIMEOUT_MS: + return setopt_set_timeout_ms(&s->accepttimeout, arg); +#endif +#if !defined(CURL_DISABLE_FTP) || defined(USE_SSH) + case CURLOPT_FTP_CREATE_MISSING_DIRS: + if((arg < CURLFTP_CREATE_DIR_NONE) || (arg > CURLFTP_CREATE_DIR_RETRY)) + result = CURLE_BAD_FUNCTION_ARGUMENT; + else + s->ftp_create_missing_dirs = (unsigned char)arg; + break; + case CURLOPT_NEW_FILE_PERMS: + if((arg < 0) || (arg > 0777)) + result = CURLE_BAD_FUNCTION_ARGUMENT; + else + s->new_file_perms = (unsigned int)arg; + break; +#endif +#ifndef CURL_DISABLE_RTSP + case CURLOPT_RTSP_REQUEST: + return setopt_RTSP_REQUEST(data, arg); + case CURLOPT_RTSP_CLIENT_CSEQ: + result = value_range(&arg, 0, 0, INT_MAX); + if(!result) + data->state.rtsp_next_client_CSeq = (uint32_t)arg; + break; + case CURLOPT_RTSP_SERVER_CSEQ: + result = value_range(&arg, 0, 0, INT_MAX); + if(!result) + data->state.rtsp_next_server_CSeq = (uint32_t)arg; + break; +#endif +#ifdef USE_SSH + case CURLOPT_SSH_AUTH_TYPES: + s->ssh_auth_types = (uint32_t)arg; + break; + case CURLOPT_NEW_DIRECTORY_PERMS: + if((arg < 0) || (arg > 0777)) + result = CURLE_BAD_FUNCTION_ARGUMENT; + else + s->new_directory_perms = (unsigned int)arg; + break; +#endif + case CURLOPT_PROTOCOLS: + s->allowed_protocols = (curl_prot_t)arg; + break; + case CURLOPT_REDIR_PROTOCOLS: + s->redir_protocols = (curl_prot_t)arg; + break; +#ifndef CURL_DISABLE_WEBSOCKETS + case CURLOPT_WS_OPTIONS: + s->ws_raw_mode = (bool)(arg & CURLWS_RAW_MODE); + s->ws_no_auto_pong = (bool)(arg & CURLWS_NOAUTOPONG); + break; +#endif + default: + return CURLE_UNKNOWN_OPTION; + } + return result; +} + +static CURLcode setopt_long_misc(struct Curl_easy *data, CURLoption option, + long arg) +{ + struct UserDefined *s = &data->set; + + switch(option) { + case CURLOPT_TIMECONDITION: + if((arg < CURL_TIMECOND_NONE) || (arg >= CURL_TIMECOND_LAST)) + return CURLE_BAD_FUNCTION_ARGUMENT; + s->timecondition = (unsigned char)arg; + break; + case CURLOPT_TIMEVALUE: + s->timevalue = (time_t)arg; + break; + case CURLOPT_POSTFIELDSIZE: + if(arg < -1) + return CURLE_BAD_FUNCTION_ARGUMENT; + if(s->postfieldsize < arg && + s->postfields == s->str[STRING_COPYPOSTFIELDS]) { + curlx_safefree(s->str[STRING_COPYPOSTFIELDS]); + s->postfields = NULL; + } + s->postfieldsize = arg; + break; + case CURLOPT_INFILESIZE: + if(arg < -1) + return CURLE_BAD_FUNCTION_ARGUMENT; + s->filesize = arg; + break; + case CURLOPT_RESUME_FROM: + if(arg < -1) + return CURLE_BAD_FUNCTION_ARGUMENT; + s->set_resume_from = arg; + break; + case CURLOPT_UPLOAD_FLAGS: + s->upload_flags = (unsigned char)arg; + break; +#ifndef CURL_DISABLE_MIME + case CURLOPT_MIME_OPTIONS: + s->mime_formescape = !!(arg & CURLMIMEOPT_FORMESCAPE); + break; +#endif +#ifndef CURL_DISABLE_HSTS + case CURLOPT_HSTS_CTRL: + if(arg & CURLHSTS_ENABLE) { + if(!data->hsts) { + data->hsts = Curl_hsts_init(); + if(!data->hsts) + return CURLE_OUT_OF_MEMORY; + } + } + else if(!data->share || !data->share->hsts) { + /* throw away the HSTS cache unless shared */ + Curl_hsts_cleanup(&data->hsts); + /* flush all the entries */ + curl_slist_free_all(data->state.hstslist); + data->state.hstslist = NULL; + } + else + /* detach from shared HSTS cache without freeing it */ + data->hsts = NULL; + break; +#endif +#ifndef CURL_DISABLE_ALTSVC + case CURLOPT_ALTSVC_CTRL: + return Curl_altsvc_ctrl(data, arg); +#endif +#if defined(HAVE_GSSAPI) || defined(USE_WINDOWS_SSPI) + case CURLOPT_GSSAPI_DELEGATION: + s->gssapi_delegation = (unsigned char)arg & + (CURLGSSAPI_DELEGATION_POLICY_FLAG | CURLGSSAPI_DELEGATION_FLAG); + break; +#endif + default: + return CURLE_UNKNOWN_OPTION; + } + return CURLE_OK; +} + +static CURLcode setopt_long(struct Curl_easy *data, CURLoption option, + long arg) +{ + typedef CURLcode (*setoptfunc)(struct Curl_easy *data, + CURLoption option, long arg); + static const setoptfunc setopt_call[] = { + setopt_long_bool, + setopt_long_net, + setopt_long_http, + setopt_long_proxy, + setopt_long_ssl, + setopt_long_proto, + setopt_long_misc + }; + size_t i; + + for(i = 0; i < CURL_ARRAYSIZE(setopt_call); i++) { + CURLcode result = setopt_call[i](data, option, arg); + if(result != CURLE_UNKNOWN_OPTION) + return result; + } + return CURLE_UNKNOWN_OPTION; +} + +static CURLcode setopt_slist(struct Curl_easy *data, CURLoption option, + struct curl_slist *slist) +{ + CURLcode result = CURLE_OK; + struct UserDefined *s = &data->set; + switch(option) { +#ifndef CURL_DISABLE_PROXY + case CURLOPT_PROXYHEADER: + /* + * Set a list with proxy headers to use (or replace internals with) + * + * Since CURLOPT_HTTPHEADER was the only way to set HTTP headers for a + * long time we remain doing it this way until CURLOPT_PROXYHEADER is + * used. As soon as this option has been used, if set to anything but + * NULL, custom headers for proxies are only picked from this list. + * + * Set this option to NULL to restore the previous behavior. + */ + s->proxyheaders = slist; + break; +#endif +#ifndef CURL_DISABLE_HTTP + case CURLOPT_HTTP200ALIASES: + /* + * Set a list of aliases for HTTP 200 in response header + */ + s->http200aliases = slist; + break; +#endif +#if !defined(CURL_DISABLE_FTP) || defined(USE_SSH) + case CURLOPT_POSTQUOTE: + /* + * List of RAW FTP commands to use after a transfer + */ + s->postquote = slist; + break; + case CURLOPT_PREQUOTE: + /* + * List of RAW FTP commands to use prior to RETR (Wesley Laxton) + */ + s->prequote = slist; + break; + case CURLOPT_QUOTE: + /* + * List of RAW FTP commands to use before a transfer + */ + s->quote = slist; + break; +#endif + case CURLOPT_RESOLVE: + /* + * List of HOST:PORT:[addresses] strings to populate the DNS cache with + * Entries added this way will remain in the cache until explicitly + * removed or the handle is cleaned up. + * + * Prefix the HOST with plus sign (+) to have the entry expire like + * automatically added entries. + * + * Prefix the HOST with dash (-) to _remove_ the entry from the cache. + * + * This API can remove any entry from the DNS cache, but only entries + * that are not actually in use right now will be pruned immediately. + */ + s->resolve = slist; + data->state.resolve = s->resolve; + break; +#if !defined(CURL_DISABLE_HTTP) || !defined(CURL_DISABLE_MIME) + case CURLOPT_HTTPHEADER: + /* + * Set a list with HTTP headers to use (or replace internals with) + */ + s->headers = slist; + break; +#endif +#ifndef CURL_DISABLE_TELNET + case CURLOPT_TELNETOPTIONS: + /* + * Set a linked list of telnet options + */ + s->telnet_options = slist; + break; +#endif +#ifndef CURL_DISABLE_SMTP + case CURLOPT_MAIL_RCPT: + /* Set the list of mail recipients */ + s->mail_rcpt = slist; + break; +#endif + case CURLOPT_CONNECT_TO: + s->connect_to = slist; + break; + default: + return CURLE_UNKNOWN_OPTION; + } + return result; +} + +#if !defined(CURL_DISABLE_HTTP) || !defined(CURL_DISABLE_SMTP) || \ + !defined(CURL_DISABLE_IMAP) +#ifndef CURL_DISABLE_MIME +static CURLcode setopt_mimepost(struct Curl_easy *data, curl_mime *mimep) +{ + /* + * Set to make us do MIME POST + */ + CURLcode result; + struct UserDefined *s = &data->set; + if(!s->mimepostp) { + s->mimepostp = curlx_malloc(sizeof(*s->mimepostp)); + if(!s->mimepostp) + return CURLE_OUT_OF_MEMORY; + Curl_mime_initpart(s->mimepostp); + } + + result = Curl_mime_set_subparts(s->mimepostp, mimep, FALSE); + if(!result) { + s->method = HTTPREQ_POST_MIME; + s->opt_no_body = FALSE; /* this is implied */ +#ifndef CURL_DISABLE_FORM_API + Curl_mime_cleanpart(data->state.formp); + curlx_safefree(data->state.formp); + data->state.mimepost = NULL; +#endif + } + return result; +} +#endif /* !CURL_DISABLE_MIME */ +#endif /* !CURL_DISABLE_HTTP || !CURL_DISABLE_SMTP || !CURL_DISABLE_IMAP */ + +/* assorted pointer type arguments */ +static CURLcode setopt_pointers(struct Curl_easy *data, CURLoption option, + va_list param) +{ + CURLcode result = CURLE_OK; + struct UserDefined *s = &data->set; + switch(option) { + case CURLOPT_CURLU: + /* + * pass CURLU to set URL + */ + Curl_bufref_free(&data->state.url); + curlx_safefree(s->str[STRING_SET_URL]); + s->uh = va_arg(param, CURLU *); + break; +#ifndef CURL_DISABLE_HTTP +#ifndef CURL_DISABLE_FORM_API + case CURLOPT_HTTPPOST: + /* + * Set to make us do HTTP POST. Legacy API-style. + */ + s->httppost = va_arg(param, struct curl_httppost *); + s->method = HTTPREQ_POST_FORM; + s->opt_no_body = FALSE; /* this is implied */ + Curl_mime_cleanpart(data->state.formp); + curlx_safefree(data->state.formp); + data->state.mimepost = NULL; + break; +#endif /* !CURL_DISABLE_FORM_API */ +#endif /* !CURL_DISABLE_HTTP */ +#if !defined(CURL_DISABLE_HTTP) || !defined(CURL_DISABLE_SMTP) || \ + !defined(CURL_DISABLE_IMAP) +#ifndef CURL_DISABLE_MIME + case CURLOPT_MIMEPOST: + result = setopt_mimepost(data, va_arg(param, curl_mime *)); + break; +#endif /* !CURL_DISABLE_MIME */ +#endif /* !CURL_DISABLE_HTTP || !CURL_DISABLE_SMTP || !CURL_DISABLE_IMAP */ + case CURLOPT_STDERR: + /* + * Set to a FILE * that should receive all error writes. This + * defaults to stderr for normal operations. + */ + s->err = va_arg(param, FILE *); + if(!s->err) + s->err = stderr; + break; + case CURLOPT_SHARE: { + struct Curl_share *set = va_arg(param, struct Curl_share *); + + /* disconnect from old share, if any and possible */ + result = Curl_share_easy_unlink(data); + if(result) + return result; + + /* use new share if it set */ + if(GOOD_SHARE_HANDLE(set)) { + result = Curl_share_easy_link(data, set); + if(result) + return result; + } + break; + } + +#ifdef USE_HTTP2 + case CURLOPT_STREAM_DEPENDS: + case CURLOPT_STREAM_DEPENDS_E: + /* not doing stream dependencies any longer, but accept options + * for backward compatibility */ + break; +#endif + + default: + return CURLE_UNKNOWN_OPTION; + } + return result; +} + +#ifndef CURL_DISABLE_COOKIES +static CURLcode cookielist(struct Curl_easy *data, const char *ptr) +{ + CURLcode result = CURLE_OK; + if(!ptr) + return CURLE_OK; + + if(curl_strequal(ptr, "ALL")) { + /* clear all cookies */ + Curl_share_lock(data, CURL_LOCK_DATA_COOKIE, CURL_LOCK_ACCESS_SINGLE); + Curl_cookie_clearall(data->cookies); + Curl_share_unlock(data, CURL_LOCK_DATA_COOKIE); + } + else if(curl_strequal(ptr, "SESS")) { + /* clear session cookies */ + Curl_share_lock(data, CURL_LOCK_DATA_COOKIE, CURL_LOCK_ACCESS_SINGLE); + Curl_cookie_clearsess(data->cookies); + Curl_share_unlock(data, CURL_LOCK_DATA_COOKIE); + } + else if(curl_strequal(ptr, "FLUSH")) { + /* flush cookies to file, takes care of the locking */ + Curl_flush_cookies(data, FALSE); + } + else if(curl_strequal(ptr, "RELOAD")) { + /* reload cookies from file */ + return Curl_cookie_loadfiles(data); + } + else { + if(!data->cookies) { + /* if cookie engine was not running, activate it */ + data->cookies = Curl_cookie_init(); + if(!data->cookies) + return CURLE_OUT_OF_MEMORY; + data->state.cookie_engine = TRUE; + } + + /* general protection against mistakes and abuse */ + if(strlen(ptr) > CURL_MAX_INPUT_LENGTH) + return CURLE_BAD_FUNCTION_ARGUMENT; + + Curl_share_lock(data, CURL_LOCK_DATA_COOKIE, CURL_LOCK_ACCESS_SINGLE); + if(checkprefix("Set-Cookie:", ptr)) + /* HTTP Header format line */ + result = Curl_cookie_add(data, data->cookies, TRUE, FALSE, ptr + 11, + NULL, NULL, TRUE); + else + /* Netscape format line */ + result = Curl_cookie_add(data, data->cookies, FALSE, FALSE, ptr, NULL, + NULL, TRUE); + Curl_share_unlock(data, CURL_LOCK_DATA_COOKIE); + } + return result; +} + +static CURLcode cookiefile(struct Curl_easy *data, const char *ptr) +{ + /* + * Set cookie file to read and parse. Can be used multiple times. + */ + if(ptr) { + struct curl_slist *cl; + /* general protection against mistakes and abuse */ + if(strlen(ptr) > CURL_MAX_INPUT_LENGTH) + return CURLE_BAD_FUNCTION_ARGUMENT; + /* append the cookie filename to the list of filenames, and deal with + them later */ + cl = curl_slist_append(data->state.cookielist, ptr); + if(!cl) { + curl_slist_free_all(data->state.cookielist); + data->state.cookielist = NULL; + return CURLE_OUT_OF_MEMORY; + } + data->state.cookielist = cl; /* store the list for later use */ + } + else { + /* clear the list of cookie files */ + curl_slist_free_all(data->state.cookielist); + data->state.cookielist = NULL; + + if(!data->share || !data->share->cookies) { + /* throw away all existing cookies if this is not a shared cookie + container */ + Curl_cookie_clearall(data->cookies); + Curl_cookie_cleanup(data->cookies); + } + /* disable the cookie engine */ + data->cookies = NULL; + } + return CURLE_OK; +} +#endif + +#ifndef CURL_DISABLE_PROXY +static CURLcode setproxy(struct Curl_easy *data, const char *proxy) +{ + if((data->set.str[STRING_PROXY] && proxy) && + /* there was one set, is this a new one? */ + !strcmp(data->set.str[STRING_PROXY], proxy)) + return CURLE_OK; /* same one as before */ + + changeproxy(data); + return Curl_setstropt(&data->set.str[STRING_PROXY], proxy); +} + +static CURLcode setopt_cptr_proxy(struct Curl_easy *data, CURLoption option, + char *ptr) +{ + CURLcode result = CURLE_OK; + struct UserDefined *s = &data->set; + switch(option) { + case CURLOPT_PROXYUSERPWD: { + /* + * user:password needed to use the proxy + */ + char *u = NULL; + char *p = NULL; + result = setstropt_userpwd(ptr, &u, &p); + + /* URL decode the components */ + if(!result) { + curlx_safefree(s->str[STRING_PROXYUSERNAME]); + curlx_safefree(s->str[STRING_PROXYPASSWORD]); + if(u) + result = Curl_urldecode(u, 0, &s->str[STRING_PROXYUSERNAME], NULL, + REJECT_ZERO); + } + if(!result && p) + result = Curl_urldecode(p, 0, &s->str[STRING_PROXYPASSWORD], NULL, + REJECT_ZERO); + curlx_free(u); + curlx_free(p); + break; + } + case CURLOPT_PROXYUSERNAME: + /* + * authentication username to use in the operation + */ + return Curl_setstropt(&s->str[STRING_PROXYUSERNAME], ptr); + + case CURLOPT_PROXYPASSWORD: + /* + * authentication password to use in the operation + */ + return Curl_setstropt(&s->str[STRING_PROXYPASSWORD], ptr); + + case CURLOPT_NOPROXY: + /* + * proxy exception list + */ + return Curl_setstropt(&s->str[STRING_NOPROXY], ptr); + case CURLOPT_PROXY_SSLCERT: + /* + * String that holds filename of the SSL certificate to use for proxy + */ + return Curl_setstropt(&s->str[STRING_CERT_PROXY], ptr); + case CURLOPT_PROXY_SSLCERTTYPE: + /* + * String that holds file type of the SSL certificate to use for proxy + */ + return Curl_setstropt(&s->str[STRING_CERT_TYPE_PROXY], ptr); + case CURLOPT_PROXY_SSLKEY: + /* + * String that holds filename of the SSL key to use for proxy + */ + return Curl_setstropt(&s->str[STRING_KEY_PROXY], ptr); + case CURLOPT_PROXY_KEYPASSWD: + /* + * String that holds the SSL private key password for proxy. + */ + return Curl_setstropt(&s->str[STRING_KEY_PASSWD_PROXY], ptr); + case CURLOPT_PROXY_SSLKEYTYPE: + /* + * String that holds file type of the SSL key to use for proxy + */ + return Curl_setstropt(&s->str[STRING_KEY_TYPE_PROXY], ptr); + case CURLOPT_PROXY_SSL_CIPHER_LIST: + if(Curl_ssl_supports(data, SSLSUPP_CIPHER_LIST)) { + /* set a list of cipher we want to use in the SSL connection for proxy */ + return Curl_setstropt(&s->str[STRING_SSL_CIPHER_LIST_PROXY], ptr); + } + else + return CURLE_NOT_BUILT_IN; + case CURLOPT_PROXY_TLS13_CIPHERS: + if(Curl_ssl_supports(data, SSLSUPP_TLS13_CIPHERSUITES)) + /* set preferred list of TLS 1.3 cipher suites for proxy */ + return Curl_setstropt(&s->str[STRING_SSL_CIPHER13_LIST_PROXY], ptr); + else + return CURLE_NOT_BUILT_IN; + case CURLOPT_PROXY: + /* + * Set proxy server:port to use as proxy. + * + * If the proxy is set to "" (and CURLOPT_PRE_PROXY is set to "" or NULL) + * we explicitly say that we do not want to use a proxy (even though there + * might be environment variables saying so). + * + * Setting it to NULL, means no proxy but allows the environment variables + * to decide for us (if CURLOPT_PRE_PROXY setting it to NULL). + */ + return setproxy(data, ptr); + case CURLOPT_PRE_PROXY: + /* + * Set proxy server:port to use as SOCKS proxy. + * + * If the proxy is set to "" or NULL we explicitly say that we do not want + * to use the socks proxy. + */ + return Curl_setstropt(&s->str[STRING_PRE_PROXY], ptr); + case CURLOPT_SOCKS5_GSSAPI_SERVICE: + case CURLOPT_PROXY_SERVICE_NAME: + /* + * Set proxy authentication service name for Kerberos 5 and SPNEGO + */ + return Curl_setstropt(&s->str[STRING_PROXY_SERVICE_NAME], ptr); + case CURLOPT_PROXY_PINNEDPUBLICKEY: + /* + * Set pinned public key for SSL connection. + * Specify filename of the public key in DER format. + */ +#ifdef USE_SSL + if(Curl_ssl_supports(data, SSLSUPP_PINNEDPUBKEY)) + return Curl_setstropt(&s->str[STRING_SSL_PINNEDPUBLICKEY_PROXY], ptr); +#endif + return CURLE_NOT_BUILT_IN; + + case CURLOPT_HAPROXY_CLIENT_IP: + /* + * Set the client IP to send through HAProxy PROXY protocol + */ + result = Curl_setstropt(&s->str[STRING_HAPROXY_CLIENT_IP], ptr); + + /* enable the HAProxy protocol if an IP is provided */ + s->haproxyprotocol = !!s->str[STRING_HAPROXY_CLIENT_IP]; + break; + case CURLOPT_PROXY_CAINFO: + /* + * Set CA info SSL connection for proxy. Specify filename of the + * CA certificate + */ + result = Curl_setstropt(&s->str[STRING_SSL_CAFILE_PROXY], ptr); + s->proxy_ssl.custom_cafile = !!s->str[STRING_SSL_CAFILE_PROXY]; + return result; + case CURLOPT_PROXY_CRLFILE: + /* + * Set CRL file info for SSL connection for proxy. Specify filename of the + * CRL to check certificates revocation + */ + if(Curl_ssl_supports(data, SSLSUPP_CRLFILE)) + return Curl_setstropt(&s->str[STRING_SSL_CRLFILE_PROXY], ptr); + return CURLE_NOT_BUILT_IN; + case CURLOPT_PROXY_ISSUERCERT: + /* + * Set Issuer certificate file to check certificates issuer + */ + if(Curl_ssl_supports(data, SSLSUPP_ISSUERCERT)) + return Curl_setstropt(&s->str[STRING_SSL_ISSUERCERT_PROXY], ptr); + return CURLE_NOT_BUILT_IN; + case CURLOPT_PROXY_CAPATH: + /* + * Set CA path info for SSL connection proxy. Specify directory name of the + * CA certificates which have been prepared using openssl c_rehash utility. + */ +#ifdef USE_SSL + if(Curl_ssl_supports(data, SSLSUPP_CA_PATH)) { + /* This does not work on Windows. */ + result = Curl_setstropt(&s->str[STRING_SSL_CAPATH_PROXY], ptr); + s->proxy_ssl.custom_capath = !!s->str[STRING_SSL_CAPATH_PROXY]; + return result; + } +#endif + return CURLE_NOT_BUILT_IN; + default: + return CURLE_UNKNOWN_OPTION; + } + return result; +} +#endif + +#if !defined(CURL_DISABLE_HTTP) || !defined(CURL_DISABLE_MQTT) +/* + * A string with POST data. Makes curl HTTP POST. Even if it is NULL. If + * needed, CURLOPT_POSTFIELDSIZE must have been set prior to + * CURLOPT_COPYPOSTFIELDS and not altered later. + */ +static CURLcode setopt_copypostfields(const char *ptr, struct UserDefined *s) +{ + CURLcode result = CURLE_OK; + if(s->postfieldsize < -1) + return CURLE_BAD_FUNCTION_ARGUMENT; + if(!ptr || s->postfieldsize == -1) + result = Curl_setstropt(&s->str[STRING_COPYPOSTFIELDS], ptr); + else { + size_t pflen = curlx_sotouz_range(s->postfieldsize, 0, SIZE_MAX); + if(pflen == SIZE_MAX) + return CURLE_OUT_OF_MEMORY; + else { + /* Allocate even when size == 0. This satisfies the need of possible + later address compare to detect the COPYPOSTFIELDS mode, and to mark + that postfields is used rather than read function or form data. + */ + char *p = curlx_memdup0(ptr, pflen); + if(!p) + return CURLE_OUT_OF_MEMORY; + else { + curlx_free(s->str[STRING_COPYPOSTFIELDS]); + s->str[STRING_COPYPOSTFIELDS] = p; + } + } + } + + s->postfields = s->str[STRING_COPYPOSTFIELDS]; + s->method = HTTPREQ_POST; + return result; +} +#endif + +#ifdef USE_ECH +static CURLcode setopt_ech(struct Curl_easy *data, const char *ptr) +{ + struct UserDefined *s = &data->set; + CURLcode result = CURLE_OK; + + if(!ptr || !strcmp(ptr, "false")) + s->tls_ech = CURLECH_DISABLE; + else { + size_t plen = strlen(ptr); + if(plen > CURL_MAX_INPUT_LENGTH) + result = CURLE_BAD_FUNCTION_ARGUMENT; + else { + if(!strcmp(ptr, "grease")) + s->tls_ech = CURLECH_GREASE; + else if(!strcmp(ptr, "true")) + s->tls_ech = CURLECH_ENABLE; + else if(!strcmp(ptr, "hard")) + s->tls_ech = CURLECH_HARD; + else if(plen > 4 && !strncmp(ptr, "ecl:", 4)) { + if(!s->tls_ech) + s->tls_ech = CURLECH_HARD; + result = Curl_setstropt(&s->str[STRING_ECH_CONFIG], ptr + 4); + } + else if(plen > 3 && !strncmp(ptr, "pn:", 3)) { + if(!s->tls_ech) + s->tls_ech = CURLECH_HARD; + result = Curl_setstropt(&s->str[STRING_ECH_PUBLIC], ptr + 3); + } + else + result = CURLE_BAD_FUNCTION_ARGUMENT; + } + } + return result; +} +#else +#define setopt_ech(x,y) CURLE_NOT_BUILT_IN +#endif + +#if defined(USE_SSL) || defined(USE_SSH) +/* One of the options is used for both TLS and SSH */ +static CURLcode setopt_cptr_ssl(struct Curl_easy *data, CURLoption option, + char *ptr) +{ + CURLcode result = CURLE_OK; + struct UserDefined *s = &data->set; + + switch(option) { + case CURLOPT_KEYPASSWD: + /* + * String that holds the SSL or SSH private key password. + */ + result = Curl_setstropt(&s->str[STRING_KEY_PASSWD], ptr); + break; +#ifdef USE_SSL + case CURLOPT_CAINFO: + /* + * Set CA info for SSL connection. Specify filename of the CA certificate + */ + result = Curl_setstropt(&s->str[STRING_SSL_CAFILE], ptr); + s->ssl.custom_cafile = !!s->str[STRING_SSL_CAFILE]; + return result; + case CURLOPT_CAPATH: + /* + * Set CA path info for SSL connection. Specify directory name of the CA + * certificates which have been prepared using openssl c_rehash utility. + */ + if(Curl_ssl_supports(data, SSLSUPP_CA_PATH)) { + /* This does not work on Windows. */ + result = Curl_setstropt(&s->str[STRING_SSL_CAPATH], ptr); + s->ssl.custom_capath = !!s->str[STRING_SSL_CAPATH]; + return result; + } + return CURLE_NOT_BUILT_IN; + case CURLOPT_CRLFILE: + /* + * Set CRL file info for SSL connection. Specify filename of the CRL + * to check certificates revocation + */ + if(Curl_ssl_supports(data, SSLSUPP_CRLFILE)) + return Curl_setstropt(&s->str[STRING_SSL_CRLFILE], ptr); + return CURLE_NOT_BUILT_IN; + case CURLOPT_SSL_CIPHER_LIST: + if(Curl_ssl_supports(data, SSLSUPP_CIPHER_LIST)) + /* set a list of cipher we want to use in the SSL connection */ + return Curl_setstropt(&s->str[STRING_SSL_CIPHER_LIST], ptr); + else + return CURLE_NOT_BUILT_IN; + case CURLOPT_TLS13_CIPHERS: + if(Curl_ssl_supports(data, SSLSUPP_TLS13_CIPHERSUITES)) + /* set preferred list of TLS 1.3 cipher suites */ + return Curl_setstropt(&s->str[STRING_SSL_CIPHER13_LIST], ptr); + else + return CURLE_NOT_BUILT_IN; + case CURLOPT_RANDOM_FILE: + break; + case CURLOPT_EGDSOCKET: + break; + case CURLOPT_SSL_CTX_DATA: + /* + * Set an SSL_CTX callback parameter pointer + */ + if(Curl_ssl_supports(data, SSLSUPP_SSL_CTX)) { + s->ssl.fsslctxp = ptr; + break; + } + else + return CURLE_NOT_BUILT_IN; + case CURLOPT_SSLCERT: + /* + * String that holds filename of the SSL certificate to use + */ + return Curl_setstropt(&s->str[STRING_CERT], ptr); + case CURLOPT_SSLCERTTYPE: + /* + * String that holds file type of the SSL certificate to use + */ + return Curl_setstropt(&s->str[STRING_CERT_TYPE], ptr); + case CURLOPT_SSLKEY: + /* + * String that holds filename of the SSL key to use + */ + return Curl_setstropt(&s->str[STRING_KEY], ptr); + case CURLOPT_SSLKEYTYPE: + /* + * String that holds file type of the SSL key to use + */ + return Curl_setstropt(&s->str[STRING_KEY_TYPE], ptr); + case CURLOPT_SSLENGINE: + /* + * String that holds the SSL crypto engine. + */ + if(ptr && ptr[0]) { + result = Curl_setstropt(&s->str[STRING_SSL_ENGINE], ptr); + if(!result) { + result = Curl_ssl_set_engine(data, ptr); + } + } + break; + case CURLOPT_ISSUERCERT: + /* + * Set Issuer certificate file + * to check certificates issuer + */ + if(Curl_ssl_supports(data, SSLSUPP_ISSUERCERT)) + return Curl_setstropt(&s->str[STRING_SSL_ISSUERCERT], ptr); + return CURLE_NOT_BUILT_IN; + case CURLOPT_SSL_EC_CURVES: + /* + * Set accepted curves in SSL connection setup. + * Specify colon-delimited list of curve algorithm names. + */ + if(Curl_ssl_supports(data, SSLSUPP_SSL_EC_CURVES)) + return Curl_setstropt(&s->str[STRING_SSL_EC_CURVES], ptr); + return CURLE_NOT_BUILT_IN; + case CURLOPT_SSL_SIGNATURE_ALGORITHMS: + /* + * Set accepted signature algorithms. + * Specify colon-delimited list of signature scheme names. + */ + if(Curl_ssl_supports(data, SSLSUPP_SIGNATURE_ALGORITHMS)) + return Curl_setstropt(&s->str[STRING_SSL_SIGNATURE_ALGORITHMS], ptr); + return CURLE_NOT_BUILT_IN; + case CURLOPT_PINNEDPUBLICKEY: + /* + * Set pinned public key for SSL connection. + * Specify filename of the public key in DER format. + */ + if(Curl_ssl_supports(data, SSLSUPP_PINNEDPUBKEY)) + return Curl_setstropt(&s->str[STRING_SSL_PINNEDPUBLICKEY], ptr); + return CURLE_NOT_BUILT_IN; + case CURLOPT_ECH: + return setopt_ech(data, ptr); +#endif + default: + return CURLE_UNKNOWN_OPTION; + } + return result; +} +#endif + +#if !defined(CURL_DISABLE_HTTP) || !defined(CURL_DISABLE_MQTT) +static CURLcode setopt_cptr_http_mqtt(struct Curl_easy *data, + CURLoption option, char *ptr) +{ + CURLcode result = CURLE_OK; + struct UserDefined *s = &data->set; + + switch(option) { + case CURLOPT_COPYPOSTFIELDS: + return setopt_copypostfields(ptr, s); + + case CURLOPT_POSTFIELDS: + /* + * Like above, but use static data instead of copying it. + */ + s->postfields = ptr; + /* Release old copied data. */ + curlx_safefree(s->str[STRING_COPYPOSTFIELDS]); + s->method = HTTPREQ_POST; + break; + +#ifndef CURL_DISABLE_HTTP + case CURLOPT_TRAILERDATA: + s->trailer_data = ptr; + break; + case CURLOPT_ACCEPT_ENCODING: + /* + * String to use at the value of Accept-Encoding header. + * + * If the encoding is set to "" we use an Accept-Encoding header that + * encompasses all the encodings we support. + * If the encoding is set to NULL we do not send an Accept-Encoding header + * and ignore an received Content-Encoding header. + * + */ + if(ptr && !*ptr) { + ptr = Curl_get_content_encodings(); + if(ptr) { + curlx_free(s->str[STRING_ENCODING]); + s->str[STRING_ENCODING] = ptr; + } + else + result = CURLE_OUT_OF_MEMORY; + return result; + } + return Curl_setstropt(&s->str[STRING_ENCODING], ptr); + +#ifndef CURL_DISABLE_AWS + case CURLOPT_AWS_SIGV4: + /* + * String that is merged to some authentication + * parameters are used by the algorithm. + */ + result = Curl_setstropt(&s->str[STRING_AWS_SIGV4], ptr); + /* + * Basic been set by default it need to be unset here + */ + if(s->str[STRING_AWS_SIGV4]) + s->httpauth = CURLAUTH_AWS_SIGV4; + break; +#endif + case CURLOPT_REFERER: + /* + * String to set in the HTTP Referer: field. + */ + Curl_bufref_free(&data->state.referer); + result = Curl_setstropt(&s->str[STRING_SET_REFERER], ptr); + break; + + case CURLOPT_USERAGENT: + /* + * String to use in the HTTP User-Agent field + */ + return Curl_setstropt(&s->str[STRING_USERAGENT], ptr); + +#ifndef CURL_DISABLE_COOKIES + case CURLOPT_COOKIE: + /* + * Cookie string to send to the remote server in the request. + */ + return Curl_setstropt(&s->str[STRING_COOKIE], ptr); + + case CURLOPT_COOKIEFILE: + return cookiefile(data, ptr); + + case CURLOPT_COOKIEJAR: + /* + * Set cookie filename to dump all cookies to when we are done. + */ + result = Curl_setstropt(&s->str[STRING_COOKIEJAR], ptr); + if(!result) { + /* + * Activate the cookie parser. This may or may not already + * have been made. + */ + if(!data->cookies) + data->cookies = Curl_cookie_init(); + if(!data->cookies) + result = CURLE_OUT_OF_MEMORY; + else + data->state.cookie_engine = TRUE; + } + break; + + case CURLOPT_COOKIELIST: + return cookielist(data, ptr); +#endif /* !CURL_DISABLE_COOKIES */ + +#endif /* !CURL_DISABLE_HTTP */ + default: + return CURLE_UNKNOWN_OPTION; + } + return result; +} +#endif /* !CURL_DISABLE_HTTP || !CURL_DISABLE_MQTT */ + +#ifdef USE_SSH +static CURLcode setopt_cptr_ssh(struct Curl_easy *data, CURLoption option, + char *ptr) +{ + struct UserDefined *s = &data->set; + switch(option) { + case CURLOPT_SSH_PUBLIC_KEYFILE: + /* + * Use this file instead of the $HOME/.ssh/id_dsa.pub file + */ + return Curl_setstropt(&s->str[STRING_SSH_PUBLIC_KEY], ptr); + case CURLOPT_SSH_PRIVATE_KEYFILE: + /* + * Use this file instead of the $HOME/.ssh/id_dsa file + */ + return Curl_setstropt(&s->str[STRING_SSH_PRIVATE_KEY], ptr); + case CURLOPT_SSH_KEYDATA: + /* + * Custom client data to pass to the SSH keyfunc callback + */ + s->ssh_keyfunc_userp = ptr; + break; + case CURLOPT_SSH_HOST_PUBLIC_KEY_MD5: + /* + * Option to allow for the MD5 of the host public key to be checked + * for validation purposes. + */ + return Curl_setstropt(&s->str[STRING_SSH_HOST_PUBLIC_KEY_MD5], ptr); + case CURLOPT_SSH_HOST_PUBLIC_KEY_SHA256: + /* + * Option to allow for the SHA256 of the host public key to be checked + * for validation purposes. + */ + return Curl_setstropt(&s->str[STRING_SSH_HOST_PUBLIC_KEY_SHA256], ptr); + case CURLOPT_SSH_KNOWNHOSTS: + /* + * Store the filename to read known hosts from. + */ + return Curl_setstropt(&s->str[STRING_SSH_KNOWNHOSTS], ptr); +#ifdef USE_LIBSSH2 + case CURLOPT_SSH_HOSTKEYDATA: + /* + * Custom client data to pass to the SSH keyfunc callback + */ + s->ssh_hostkeyfunc_userp = ptr; + break; +#endif /* USE_LIBSSH2 */ + default: + return CURLE_UNKNOWN_OPTION; + } + return CURLE_OK; +} +#endif /* USE_SSH */ + +#ifndef CURL_DISABLE_FTP +static CURLcode setopt_cptr_ftp(struct Curl_easy *data, CURLoption option, + char *ptr) +{ + CURLcode result = CURLE_OK; + struct UserDefined *s = &data->set; + switch(option) { + case CURLOPT_FTPPORT: + /* + * Use FTP PORT, this also specifies which IP address to use + */ + result = Curl_setstropt(&s->str[STRING_FTPPORT], ptr); + s->ftp_use_port = !!(s->str[STRING_FTPPORT]); + break; + + case CURLOPT_FTP_ACCOUNT: + return Curl_setstropt(&s->str[STRING_FTP_ACCOUNT], ptr); + + case CURLOPT_FTP_ALTERNATIVE_TO_USER: + return Curl_setstropt(&s->str[STRING_FTP_ALTERNATIVE_TO_USER], ptr); + + case CURLOPT_KRBLEVEL: + return CURLE_NOT_BUILT_IN; /* removed in 8.17.0 */ + case CURLOPT_CHUNK_DATA: + s->wildcardptr = ptr; + break; + case CURLOPT_FNMATCH_DATA: + s->fnmatch_data = ptr; + break; + default: + return CURLE_UNKNOWN_OPTION; + } + return result; +} +#endif /* !CURL_DISABLE_FTP */ + +static CURLcode setopt_cptr_net(struct Curl_easy *data, CURLoption option, + char *ptr) +{ + struct UserDefined *s = &data->set; + switch(option) { + case CURLOPT_INTERFACE: + /* + * Set what interface or address/hostname to bind the socket to when + * performing an operation and thus what from-IP your connection will use. + */ + return setstropt_interface(ptr, + &s->str[STRING_DEVICE], + &s->str[STRING_INTERFACE], + &s->str[STRING_BINDHOST]); +#ifdef USE_RESOLV_ARES + case CURLOPT_DNS_SERVERS: + return Curl_setstropt(&s->str[STRING_DNS_SERVERS], ptr); + + case CURLOPT_DNS_INTERFACE: + return Curl_setstropt(&s->str[STRING_DNS_INTERFACE], ptr); + + case CURLOPT_DNS_LOCAL_IP4: + return Curl_setstropt(&s->str[STRING_DNS_LOCAL_IP4], ptr); + + case CURLOPT_DNS_LOCAL_IP6: + return Curl_setstropt(&s->str[STRING_DNS_LOCAL_IP6], ptr); +#endif +#ifdef USE_UNIX_SOCKETS + case CURLOPT_UNIX_SOCKET_PATH: + s->abstract_unix_socket = FALSE; + return Curl_setstropt(&s->str[STRING_UNIX_SOCKET_PATH], ptr); + + case CURLOPT_ABSTRACT_UNIX_SOCKET: + s->abstract_unix_socket = TRUE; + return Curl_setstropt(&s->str[STRING_UNIX_SOCKET_PATH], ptr); +#endif +#ifndef CURL_DISABLE_DOH + case CURLOPT_DOH_URL: + { + CURLcode result = Curl_setstropt(&s->str[STRING_DOH], ptr); + s->doh = !!(s->str[STRING_DOH]); + return result; + } +#endif + default: + return CURLE_UNKNOWN_OPTION; + } +} + +static CURLcode setopt_cptr_misc(struct Curl_easy *data, CURLoption option, + char *ptr) +{ + CURLcode result = CURLE_OK; + struct UserDefined *s = &data->set; + + switch(option) { + case CURLOPT_REQUEST_TARGET: + return Curl_setstropt(&s->str[STRING_TARGET], ptr); +#ifndef CURL_DISABLE_NETRC + case CURLOPT_NETRC_FILE: + return Curl_setstropt(&s->str[STRING_NETRC_FILE], ptr); +#endif + case CURLOPT_CUSTOMREQUEST: + return Curl_setstropt(&s->str[STRING_CUSTOMREQUEST], ptr); + + /* we do not set s->method = HTTPREQ_CUSTOM; here, we continue as if we + were using the already set type and this changes the actual request + keyword */ + case CURLOPT_SERVICE_NAME: + return Curl_setstropt(&s->str[STRING_SERVICE_NAME], ptr); + + case CURLOPT_HEADERDATA: + s->writeheader = ptr; + break; + case CURLOPT_READDATA: + s->in_set = ptr; + break; + case CURLOPT_WRITEDATA: + s->out = ptr; + break; + case CURLOPT_DEBUGDATA: + s->debugdata = ptr; + break; + case CURLOPT_PROGRESSDATA: + s->progress_client = ptr; + break; + case CURLOPT_SEEKDATA: + s->seek_client = ptr; + break; + case CURLOPT_IOCTLDATA: + s->ioctl_client = ptr; + break; + case CURLOPT_SOCKOPTDATA: + s->sockopt_client = ptr; + break; + case CURLOPT_OPENSOCKETDATA: + s->opensocket_client = ptr; + break; + case CURLOPT_RESOLVER_START_DATA: + s->resolver_start_client = ptr; + break; + case CURLOPT_CLOSESOCKETDATA: + s->closesocket_client = ptr; + break; + case CURLOPT_PREREQDATA: + s->prereq_userp = ptr; + break; + case CURLOPT_ERRORBUFFER: + s->errorbuffer = ptr; + break; + case CURLOPT_URL: + result = Curl_setstropt(&s->str[STRING_SET_URL], ptr); + Curl_bufref_set(&data->state.url, s->str[STRING_SET_URL], 0, NULL); + break; + + case CURLOPT_USERPWD: + return setstropt_userpwd(ptr, &s->str[STRING_USERNAME], + &s->str[STRING_PASSWORD]); + + case CURLOPT_USERNAME: + return Curl_setstropt(&s->str[STRING_USERNAME], ptr); + + case CURLOPT_PASSWORD: + return Curl_setstropt(&s->str[STRING_PASSWORD], ptr); + + case CURLOPT_LOGIN_OPTIONS: + return Curl_setstropt(&s->str[STRING_OPTIONS], ptr); + + case CURLOPT_XOAUTH2_BEARER: + return Curl_setstropt(&s->str[STRING_BEARER], ptr); + case CURLOPT_RANGE: + return Curl_setstropt(&s->str[STRING_SET_RANGE], ptr); + case CURLOPT_PRIVATE: + s->private_data = ptr; + break; + case CURLOPT_PROTOCOLS_STR: + if(ptr) { + curl_prot_t protos; + result = protocol2num(ptr, &protos); + if(!result) + s->allowed_protocols = protos; + } + else + /* make a NULL argument reset to default */ + s->allowed_protocols = (curl_prot_t)CURLPROTO_64ALL; + break; + case CURLOPT_REDIR_PROTOCOLS_STR: + if(ptr) { + curl_prot_t protos; + result = protocol2num(ptr, &protos); + if(!result) + s->redir_protocols = protos; + } + else + /* make a NULL argument reset to default */ + s->redir_protocols = (curl_prot_t)CURLPROTO_REDIR; + break; + case CURLOPT_DEFAULT_PROTOCOL: + /* Set the protocol to use when the URL does not include any protocol */ + return Curl_setstropt(&s->str[STRING_DEFAULT_PROTOCOL], ptr); +#ifndef CURL_DISABLE_SMTP + case CURLOPT_MAIL_FROM: + /* Set the SMTP mail originator */ + return Curl_setstropt(&s->str[STRING_MAIL_FROM], ptr); + case CURLOPT_MAIL_AUTH: + /* Set the SMTP auth originator */ + return Curl_setstropt(&s->str[STRING_MAIL_AUTH], ptr); +#endif + case CURLOPT_SASL_AUTHZID: + /* Authorization identity (identity to act as) */ + return Curl_setstropt(&s->str[STRING_SASL_AUTHZID], ptr); +#ifndef CURL_DISABLE_RTSP + case CURLOPT_RTSP_SESSION_ID: + return Curl_setstropt(&s->str[STRING_RTSP_SESSION_ID], ptr); + case CURLOPT_RTSP_STREAM_URI: + return Curl_setstropt(&s->str[STRING_RTSP_STREAM_URI], ptr); + case CURLOPT_RTSP_TRANSPORT: + return Curl_setstropt(&s->str[STRING_RTSP_TRANSPORT], ptr); + case CURLOPT_INTERLEAVEDATA: + s->rtp_out = ptr; + break; +#endif /* !CURL_DISABLE_RTSP */ +#ifdef USE_TLS_SRP + case CURLOPT_TLSAUTH_USERNAME: + return Curl_setstropt(&s->str[STRING_TLSAUTH_USERNAME], ptr); + case CURLOPT_TLSAUTH_PASSWORD: + return Curl_setstropt(&s->str[STRING_TLSAUTH_PASSWORD], ptr); + case CURLOPT_TLSAUTH_TYPE: + if(ptr && !curl_strequal(ptr, "SRP")) + result = CURLE_BAD_FUNCTION_ARGUMENT; + break; +#ifndef CURL_DISABLE_PROXY + case CURLOPT_PROXY_TLSAUTH_USERNAME: + return Curl_setstropt(&s->str[STRING_TLSAUTH_USERNAME_PROXY], ptr); + case CURLOPT_PROXY_TLSAUTH_PASSWORD: + return Curl_setstropt(&s->str[STRING_TLSAUTH_PASSWORD_PROXY], ptr); + case CURLOPT_PROXY_TLSAUTH_TYPE: + if(ptr && !curl_strequal(ptr, "SRP")) + result = CURLE_BAD_FUNCTION_ARGUMENT; + break; +#endif +#endif +#ifndef CURL_DISABLE_HSTS + case CURLOPT_HSTSREADDATA: + s->hsts_read_userp = ptr; + break; + case CURLOPT_HSTSWRITEDATA: + s->hsts_write_userp = ptr; + break; + case CURLOPT_HSTS: { + struct curl_slist *h; + if(!data->hsts) { + data->hsts = Curl_hsts_init(); + if(!data->hsts) + return CURLE_OUT_OF_MEMORY; + } + if(ptr) { + result = Curl_setstropt(&s->str[STRING_HSTS], ptr); + if(result) + return result; + /* this needs to build a list of filenames to read from, so that it can + read them later, as we might get a shared HSTS handle to load them + into */ + h = curl_slist_append(data->state.hstslist, ptr); + if(!h) { + curl_slist_free_all(data->state.hstslist); + data->state.hstslist = NULL; + return CURLE_OUT_OF_MEMORY; + } + data->state.hstslist = h; /* store the list for later use */ + } + else { + /* clear the list of HSTS files */ + curl_slist_free_all(data->state.hstslist); + data->state.hstslist = NULL; + if(!data->share || !data->share->hsts) + /* throw away the HSTS cache unless shared */ + Curl_hsts_cleanup(&data->hsts); + } + break; + } +#endif /* !CURL_DISABLE_HSTS */ +#ifndef CURL_DISABLE_ALTSVC + case CURLOPT_ALTSVC: + if(!data->asi) { + data->asi = Curl_altsvc_init(); + if(!data->asi) + return CURLE_OUT_OF_MEMORY; + } + result = Curl_setstropt(&s->str[STRING_ALTSVC], ptr); + if(result) + break; + if(ptr) + return Curl_altsvc_load(data->asi, ptr); + break; +#endif /* !CURL_DISABLE_ALTSVC */ + case CURLOPT_ECH: + return setopt_ech(data, ptr); + default: + return CURLE_UNKNOWN_OPTION; + } + return result; +} + +static CURLcode setopt_cptr(struct Curl_easy *data, CURLoption option, + char *ptr) +{ + typedef CURLcode (*ptrfunc)(struct Curl_easy *data, CURLoption option, + char *ptr); + static const ptrfunc setopt_call[] = { +#ifndef CURL_DISABLE_PROXY + setopt_cptr_proxy, +#endif +#if defined(USE_SSL) || defined(USE_SSH) + setopt_cptr_ssl, +#endif +#ifdef USE_SSH + setopt_cptr_ssh, +#endif +#ifndef CURL_DISABLE_FTP + setopt_cptr_ftp, +#endif +#if !defined(CURL_DISABLE_HTTP) || !defined(CURL_DISABLE_MQTT) + setopt_cptr_http_mqtt, +#endif + setopt_cptr_net, + setopt_cptr_misc, + }; + size_t i; + + for(i = 0; i < CURL_ARRAYSIZE(setopt_call); i++) { + CURLcode result = setopt_call[i](data, option, ptr); + if(result != CURLE_UNKNOWN_OPTION) + return result; + } + return CURLE_UNKNOWN_OPTION; +} + +static CURLcode setopt_func(struct Curl_easy *data, CURLoption option, + va_list param) +{ + struct UserDefined *s = &data->set; + switch(option) { + case CURLOPT_PROGRESSFUNCTION: + /* + * Progress callback function + */ + s->fprogress = va_arg(param, curl_progress_callback); + if(s->fprogress) + data->progress.callback = TRUE; /* no longer internal */ + else + data->progress.callback = FALSE; /* NULL enforces internal */ + break; + + case CURLOPT_XFERINFOFUNCTION: + /* + * Transfer info callback function + */ + s->fxferinfo = va_arg(param, curl_xferinfo_callback); + if(s->fxferinfo) + data->progress.callback = TRUE; /* no longer internal */ + else + data->progress.callback = FALSE; /* NULL enforces internal */ + + break; + case CURLOPT_DEBUGFUNCTION: + /* + * stderr write callback. + */ + s->fdebug = va_arg(param, curl_debug_callback); + /* + * if the callback provided is NULL, it will use the default callback + */ + break; + case CURLOPT_HEADERFUNCTION: + /* + * Set header write callback + */ + s->fwrite_header = va_arg(param, curl_write_callback); + break; + case CURLOPT_WRITEFUNCTION: + /* + * Set data write callback + */ + s->fwrite_func = va_arg(param, curl_write_callback); + if(!s->fwrite_func) +#if defined(__clang__) && __clang_major__ >= 16 +#pragma clang diagnostic push +#pragma clang diagnostic ignored "-Wcast-function-type-strict" +#endif + /* When set to NULL, reset to our internal default function */ + s->fwrite_func = (curl_write_callback)fwrite; +#if defined(__clang__) && __clang_major__ >= 16 +#pragma clang diagnostic pop +#endif + break; + case CURLOPT_READFUNCTION: + /* + * Read data callback + */ + s->fread_func_set = va_arg(param, curl_read_callback); + if(!s->fread_func_set) { + s->is_fread_set = 0; +#if defined(__clang__) && __clang_major__ >= 16 +#pragma clang diagnostic push +#pragma clang diagnostic ignored "-Wcast-function-type-strict" +#endif + /* When set to NULL, reset to our internal default function */ + s->fread_func_set = (curl_read_callback)fread; +#if defined(__clang__) && __clang_major__ >= 16 +#pragma clang diagnostic pop +#endif + } + else + s->is_fread_set = 1; + break; + case CURLOPT_SEEKFUNCTION: + /* + * Seek callback. Might be NULL. + */ + s->seek_func = va_arg(param, curl_seek_callback); + break; + case CURLOPT_IOCTLFUNCTION: + /* + * I/O control callback. Might be NULL. + */ + s->ioctl_func = va_arg(param, curl_ioctl_callback); + break; + case CURLOPT_SSL_CTX_FUNCTION: + /* + * Set an SSL_CTX callback + */ +#ifdef USE_SSL + if(Curl_ssl_supports(data, SSLSUPP_SSL_CTX)) { + s->ssl.fsslctx = va_arg(param, curl_ssl_ctx_callback); + break; + } + else +#endif + return CURLE_NOT_BUILT_IN; + + case CURLOPT_SOCKOPTFUNCTION: + /* + * socket callback function: called after socket() but before connect() + */ + s->fsockopt = va_arg(param, curl_sockopt_callback); + break; + + case CURLOPT_OPENSOCKETFUNCTION: + /* + * open/create socket callback function: called instead of socket(), + * before connect() + */ + s->fopensocket = va_arg(param, curl_opensocket_callback); + break; + + case CURLOPT_CLOSESOCKETFUNCTION: + /* + * close socket callback function: called instead of close() + * when shutting down a connection + */ + s->fclosesocket = va_arg(param, curl_closesocket_callback); + break; + + case CURLOPT_RESOLVER_START_FUNCTION: + /* + * resolver start callback function: called before a new resolver request + * is started + */ + s->resolver_start = va_arg(param, curl_resolver_start_callback); + break; + +#ifdef USE_SSH +#ifdef USE_LIBSSH2 + case CURLOPT_SSH_HOSTKEYFUNCTION: + /* the callback to check the hostkey without the knownhost file */ + s->ssh_hostkeyfunc = va_arg(param, curl_sshhostkeycallback); + break; +#endif + + case CURLOPT_SSH_KEYFUNCTION: + /* setting to NULL is fine since the ssh.c functions themselves will + then revert to use the internal default */ + s->ssh_keyfunc = va_arg(param, curl_sshkeycallback); + break; + +#endif /* USE_SSH */ + +#ifndef CURL_DISABLE_RTSP + case CURLOPT_INTERLEAVEFUNCTION: + /* Set the user defined RTP write function */ + s->fwrite_rtp = va_arg(param, curl_write_callback); + break; +#endif +#ifndef CURL_DISABLE_FTP + case CURLOPT_CHUNK_BGN_FUNCTION: + s->chunk_bgn = va_arg(param, curl_chunk_bgn_callback); + break; + case CURLOPT_CHUNK_END_FUNCTION: + s->chunk_end = va_arg(param, curl_chunk_end_callback); + break; + case CURLOPT_FNMATCH_FUNCTION: + s->fnmatch = va_arg(param, curl_fnmatch_callback); + break; +#endif +#ifndef CURL_DISABLE_HTTP + case CURLOPT_TRAILERFUNCTION: + s->trailer_callback = va_arg(param, curl_trailer_callback); + break; +#endif +#ifndef CURL_DISABLE_HSTS + case CURLOPT_HSTSREADFUNCTION: + s->hsts_read = va_arg(param, curl_hstsread_callback); + break; + case CURLOPT_HSTSWRITEFUNCTION: + s->hsts_write = va_arg(param, curl_hstswrite_callback); + break; +#endif + case CURLOPT_PREREQFUNCTION: + s->fprereq = va_arg(param, curl_prereq_callback); + break; + default: + return CURLE_UNKNOWN_OPTION; + } + return CURLE_OK; +} + +static CURLcode setopt_offt(struct Curl_easy *data, CURLoption option, + curl_off_t offt) +{ + struct UserDefined *s = &data->set; + switch(option) { + case CURLOPT_TIMEVALUE_LARGE: + /* + * This is the value to compare with the remote document with the + * method set with CURLOPT_TIMECONDITION + */ + s->timevalue = (time_t)offt; + break; + + /* MQTT "borrows" some of the HTTP options */ + case CURLOPT_POSTFIELDSIZE_LARGE: + /* + * The size of the POSTFIELD data to prevent libcurl to do strlen() to + * figure it out. Enables binary posts. + */ + if(offt < -1) + return CURLE_BAD_FUNCTION_ARGUMENT; + + if(s->postfieldsize < offt && + s->postfields == s->str[STRING_COPYPOSTFIELDS]) { + /* Previous CURLOPT_COPYPOSTFIELDS is no longer valid. */ + curlx_safefree(s->str[STRING_COPYPOSTFIELDS]); + s->postfields = NULL; + } + s->postfieldsize = offt; + break; + case CURLOPT_INFILESIZE_LARGE: + /* + * If known, this should inform curl about the file size of the + * to-be-uploaded file. + */ + if(offt < -1) + return CURLE_BAD_FUNCTION_ARGUMENT; + s->filesize = offt; + break; + case CURLOPT_MAX_SEND_SPEED_LARGE: + /* + * When transfer uploads are faster than CURLOPT_MAX_SEND_SPEED_LARGE + * bytes per second the transfer is throttled.. + */ + if(offt < 0) + return CURLE_BAD_FUNCTION_ARGUMENT; + s->max_send_speed = offt; + /* use minimal burst rate of 32k. some protocol batch IO */ + Curl_rlimit_init(&data->progress.ul.rlimit, offt, + CURLMAX(offt, (32 * 1024)), + Curl_pgrs_now(data)); + break; + case CURLOPT_MAX_RECV_SPEED_LARGE: + /* + * When receiving data faster than CURLOPT_MAX_RECV_SPEED_LARGE bytes per + * second the transfer is throttled.. + */ + if(offt < 0) + return CURLE_BAD_FUNCTION_ARGUMENT; + s->max_recv_speed = offt; + /* use minimal burst rate of 32k. some protocol batch IO */ + Curl_rlimit_init(&data->progress.dl.rlimit, offt, + CURLMAX(offt, (32 * 1024)), + Curl_pgrs_now(data)); + break; + case CURLOPT_RESUME_FROM_LARGE: + /* + * Resume transfer at the given file position + */ + if(offt < -1) + return CURLE_BAD_FUNCTION_ARGUMENT; + s->set_resume_from = offt; + break; + case CURLOPT_MAXFILESIZE_LARGE: + /* + * Set the maximum size of a file to download. + */ + if(offt < 0) + return CURLE_BAD_FUNCTION_ARGUMENT; + s->max_filesize = offt; + break; + + default: + return CURLE_UNKNOWN_OPTION; + } + return CURLE_OK; +} + +static CURLcode setopt_blob(struct Curl_easy *data, CURLoption option, + struct curl_blob *blob) +{ + struct UserDefined *s = &data->set; + switch(option) { + case CURLOPT_SSLCERT_BLOB: + /* + * Blob that holds file content of the SSL certificate to use + */ + return Curl_setblobopt(&s->blobs[BLOB_CERT], blob); +#ifndef CURL_DISABLE_PROXY + case CURLOPT_PROXY_SSLCERT_BLOB: + /* + * Blob that holds file content of the SSL certificate to use for proxy + */ + return Curl_setblobopt(&s->blobs[BLOB_CERT_PROXY], blob); + case CURLOPT_PROXY_SSLKEY_BLOB: + /* + * Blob that holds file content of the SSL key to use for proxy + */ + return Curl_setblobopt(&s->blobs[BLOB_KEY_PROXY], blob); + case CURLOPT_PROXY_CAINFO_BLOB: + /* + * Blob that holds CA info for SSL connection proxy. + * Specify entire PEM of the CA certificate + */ +#ifdef USE_SSL + if(Curl_ssl_supports(data, SSLSUPP_CAINFO_BLOB)) { + CURLcode result = Curl_setblobopt(&s->blobs[BLOB_CAINFO_PROXY], blob); + s->proxy_ssl.custom_cablob = !!s->blobs[BLOB_CAINFO_PROXY]; + return result; + } +#endif + return CURLE_NOT_BUILT_IN; + case CURLOPT_PROXY_ISSUERCERT_BLOB: + /* + * Blob that holds Issuer certificate to check certificates issuer + */ + if(Curl_ssl_supports(data, SSLSUPP_ISSUERCERT_BLOB)) + return Curl_setblobopt(&s->blobs[BLOB_SSL_ISSUERCERT_PROXY], blob); + return CURLE_NOT_BUILT_IN; +#endif + case CURLOPT_SSLKEY_BLOB: + /* + * Blob that holds file content of the SSL key to use + */ + return Curl_setblobopt(&s->blobs[BLOB_KEY], blob); + case CURLOPT_CAINFO_BLOB: + /* + * Blob that holds CA info for SSL connection. + * Specify entire PEM of the CA certificate + */ +#ifdef USE_SSL + if(Curl_ssl_supports(data, SSLSUPP_CAINFO_BLOB)) { + CURLcode result = Curl_setblobopt(&s->blobs[BLOB_CAINFO], blob); + s->ssl.custom_cablob = !!s->blobs[BLOB_CAINFO]; + return result; + } +#endif + return CURLE_NOT_BUILT_IN; + case CURLOPT_ISSUERCERT_BLOB: + /* + * Blob that holds Issuer certificate to check certificates issuer + */ + if(Curl_ssl_supports(data, SSLSUPP_ISSUERCERT_BLOB)) + return Curl_setblobopt(&s->blobs[BLOB_SSL_ISSUERCERT], blob); + return CURLE_NOT_BUILT_IN; + + default: + return CURLE_UNKNOWN_OPTION; + } + /* unreachable */ +} + +/* + * Do not make Curl_vsetopt() static: it is called from + * projects/OS400/ccsidcurl.c. + */ +CURLcode Curl_vsetopt(struct Curl_easy *data, CURLoption option, va_list param) +{ + if(option < CURLOPTTYPE_OBJECTPOINT) + return setopt_long(data, option, va_arg(param, long)); + else if(option < CURLOPTTYPE_FUNCTIONPOINT) { + /* unfortunately, different pointer types cannot be identified any other + way than being listed explicitly */ + switch(option) { + case CURLOPT_HTTPHEADER: + case CURLOPT_QUOTE: + case CURLOPT_POSTQUOTE: + case CURLOPT_TELNETOPTIONS: + case CURLOPT_PREQUOTE: + case CURLOPT_HTTP200ALIASES: + case CURLOPT_MAIL_RCPT: + case CURLOPT_RESOLVE: + case CURLOPT_PROXYHEADER: + case CURLOPT_CONNECT_TO: + return setopt_slist(data, option, va_arg(param, struct curl_slist *)); + case CURLOPT_HTTPPOST: /* curl_httppost * */ + case CURLOPT_MIMEPOST: /* curl_mime * */ + case CURLOPT_STDERR: /* FILE * */ + case CURLOPT_SHARE: /* CURLSH * */ + case CURLOPT_STREAM_DEPENDS: /* CURL * */ + case CURLOPT_STREAM_DEPENDS_E: /* CURL * */ + case CURLOPT_CURLU: /* CURLU * */ + return setopt_pointers(data, option, param); + default: + break; + } + /* the char pointer options */ + return setopt_cptr(data, option, va_arg(param, char *)); + } + else if(option < CURLOPTTYPE_OFF_T) + return setopt_func(data, option, param); + else if(option < CURLOPTTYPE_BLOB) + return setopt_offt(data, option, va_arg(param, curl_off_t)); + return setopt_blob(data, option, va_arg(param, struct curl_blob *)); +} + +/* + * curl_easy_setopt() is the external interface for setting options on an + * easy handle. + * + * NOTE: This is one of few API functions that are allowed to be called from + * within a callback. + */ + +#undef curl_easy_setopt +CURLcode curl_easy_setopt(CURL *curl, CURLoption option, ...) +{ + va_list arg; + CURLcode result; + struct Curl_easy *data = curl; + + if(!data) + return CURLE_BAD_FUNCTION_ARGUMENT; + + va_start(arg, option); + + result = Curl_vsetopt(data, option, arg); + + va_end(arg); + if(result == CURLE_BAD_FUNCTION_ARGUMENT) + failf(data, "setopt 0x%x got bad argument", (unsigned int)option); + return result; +} diff --git a/3rdparty/curl-8.21.0/lib/setopt.h b/3rdparty/curl-8.21.0/lib/setopt.h new file mode 100644 index 0000000000..c421f5c5e5 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/setopt.h @@ -0,0 +1,40 @@ +#ifndef HEADER_CURL_SETOPT_H +#define HEADER_CURL_SETOPT_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +#ifdef USE_SSL +CURLcode Curl_setopt_SSLVERSION(struct Curl_easy *data, CURLoption option, + long arg); +#else +#define Curl_setopt_SSLVERSION(a, b, c) CURLE_NOT_BUILT_IN +#endif + +CURLcode Curl_setstropt(char **charp, const char *s) WARN_UNUSED_RESULT; +CURLcode Curl_setblobopt(struct curl_blob **blobp, + const struct curl_blob *blob) WARN_UNUSED_RESULT; +CURLcode Curl_vsetopt(struct Curl_easy *data, CURLoption option, va_list param) + WARN_UNUSED_RESULT; + +#endif /* HEADER_CURL_SETOPT_H */ diff --git a/3rdparty/curl-8.21.0/lib/setup-os400.h b/3rdparty/curl-8.21.0/lib/setup-os400.h new file mode 100644 index 0000000000..b5bd733672 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/setup-os400.h @@ -0,0 +1,147 @@ +#ifndef HEADER_CURL_SETUP_OS400_H +#define HEADER_CURL_SETUP_OS400_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +/* OS/400 netdb.h does not define NI_MAXHOST. */ +#define NI_MAXHOST 1025 + +/* OS/400 netdb.h does not define NI_MAXSERV. */ +#define NI_MAXSERV 32 + +/* OS/400 has no idea of a tty! */ +#define isatty(fd) 0 + +/* Workaround bug in IBM QADRT runtime library: + * function puts() does not output the implicit trailing newline. + */ + +#include /* Be sure it is loaded. */ +#undef puts +#define puts(s) (fputs(s, stdout) == EOF ? EOF : putchar('\n')) + +/* System API wrapper prototypes & definitions to support ASCII parameters. */ + +#include +#include +#include +#include +#include + +#ifdef BUILDING_LIBCURL + +extern int Curl_getaddrinfo_a(const char *nodename, + const char *servname, + const struct addrinfo *hints, + struct addrinfo **res); +#define getaddrinfo Curl_getaddrinfo_a + +/* Note socklen_t must be used as this is declared before curl_socklen_t */ +extern int Curl_getnameinfo_a(const struct sockaddr *sa, + socklen_t salen, + char *nodename, socklen_t nodenamelen, + char *servname, socklen_t servnamelen, + int flags); +#define getnameinfo Curl_getnameinfo_a + +/* GSSAPI wrappers. */ + +extern OM_uint32 Curl_gss_import_name_a(OM_uint32 *minor_status, + gss_buffer_t in_name, + gss_OID in_name_type, + gss_name_t *out_name); +#define gss_import_name Curl_gss_import_name_a + +extern OM_uint32 Curl_gss_display_status_a(OM_uint32 *minor_status, + OM_uint32 status_value, + int status_type, gss_OID mech_type, + gss_msg_ctx_t *message_context, + gss_buffer_t status_string); +#define gss_display_status Curl_gss_display_status_a + +extern OM_uint32 Curl_gss_init_sec_context_a(OM_uint32 *minor_status, + gss_cred_id_t cred_handle, + gss_ctx_id_t *context_handle, + gss_name_t target_name, + gss_OID mech_type, + gss_flags_t req_flags, + OM_uint32 time_req, + gss_channel_bindings_t + input_chan_bindings, + gss_buffer_t input_token, + gss_OID *actual_mech_type, + gss_buffer_t output_token, + gss_flags_t *ret_flags, + OM_uint32 *time_rec); +#define gss_init_sec_context Curl_gss_init_sec_context_a + +extern OM_uint32 Curl_gss_delete_sec_context_a(OM_uint32 *minor_status, + gss_ctx_id_t *context_handle, + gss_buffer_t output_token); +#define gss_delete_sec_context Curl_gss_delete_sec_context_a + +/* LDAP wrappers. */ + +#define BerValue struct berval + +#define ldap_url_parse ldap_url_parse_utf8 +#define ldap_init Curl_ldap_init_a +#define ldap_simple_bind_s Curl_ldap_simple_bind_s_a +#define ldap_search_s Curl_ldap_search_s_a +#define ldap_get_values_len Curl_ldap_get_values_len_a +#define ldap_err2string Curl_ldap_err2string_a +#define ldap_get_dn Curl_ldap_get_dn_a +#define ldap_first_attribute Curl_ldap_first_attribute_a +#define ldap_next_attribute Curl_ldap_next_attribute_a + +/* Some socket functions must be wrapped to process textual addresses + like AF_UNIX. */ + +extern int Curl_os400_connect(int sd, struct sockaddr *destaddr, int addrlen); +extern int Curl_os400_bind(int sd, struct sockaddr *localaddr, int addrlen); +extern int Curl_os400_sendto(int sd, char *buffer, int buflen, int flags, + const struct sockaddr *dstaddr, int addrlen); +extern int Curl_os400_recvfrom(int sd, char *buffer, int buflen, int flags, + struct sockaddr *fromaddr, int *addrlen); +extern int Curl_os400_getpeername(int sd, struct sockaddr *addr, int *addrlen); +extern int Curl_os400_getsockname(int sd, struct sockaddr *addr, int *addrlen); + +#define connect Curl_os400_connect +#define bind Curl_os400_bind +#define sendto Curl_os400_sendto +#define recvfrom Curl_os400_recvfrom +#define getpeername Curl_os400_getpeername +#define getsockname Curl_os400_getsockname + +#ifdef HAVE_LIBZ +#define zlibVersion Curl_os400_zlibVersion +#define inflateInit_ Curl_os400_inflateInit_ +#define inflateInit2_ Curl_os400_inflateInit2_ +#define inflate Curl_os400_inflate +#define inflateEnd Curl_os400_inflateEnd +#endif + +#endif /* BUILDING_LIBCURL */ + +#endif /* HEADER_CURL_SETUP_OS400_H */ diff --git a/3rdparty/curl-8.21.0/lib/setup-vms.h b/3rdparty/curl-8.21.0/lib/setup-vms.h new file mode 100644 index 0000000000..35d12f0b42 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/setup-vms.h @@ -0,0 +1,396 @@ +#ifndef HEADER_CURL_SETUP_VMS_H +#define HEADER_CURL_SETUP_VMS_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +/* JEM, 2012-12-30, VMS now generates config.h, so only define wrappers for */ +/* getenv(), getpwuid() and provide is_vms_shell() */ +/* Also need upper case symbols for system services, and */ +/* OpenSSL, and some Kerberos image */ + +#ifdef __DECC +#pragma message save +#pragma message disable dollarid +#endif + +/* Hide the stuff we are overriding */ +#define getenv decc_getenv +#ifdef __DECC +# if __INITIAL_POINTER_SIZE != 64 +# define getpwuid decc_getpwuid +# endif +#endif +#include +char *decc$getenv(const char *__name); +#include + +#include +#include + +#undef getenv +#undef getpwuid +#define getenv vms_getenv +#define getpwuid vms_getpwuid + +/* VAX needs these in upper case when compiling exact case */ +#define sys$assign SYS$ASSIGN +#define sys$dassgn SYS$DASSGN +#define sys$qiow SYS$QIOW + +#ifdef __DECC +# if __INITIAL_POINTER_SIZE +# pragma __pointer_size __save +# endif +#endif + +#if __USE_LONG_GID_T +# define decc_getpwuid DECC$__LONG_GID_GETPWUID +#else +# if __INITIAL_POINTER_SIZE +# define decc_getpwuid decc$__32_getpwuid +# else +# define decc_getpwuid decc$getpwuid +# endif +#endif + +struct passwd *decc_getpwuid(uid_t uid); + +#ifdef __DECC +# if __INITIAL_POINTER_SIZE == 32 +/* Translate the path, but only if the path is a VMS file specification */ +/* The translation is usually only needed for older versions of VMS */ +static char *vms_translate_path(const char *path) +{ + char *unix_path; + char *test_str; + + /* See if the result is in VMS format, if not, we are done */ + /* Assume that this is a PATH, not some data */ + test_str = strpbrk(path, ":[<^"); + if(!test_str) { + return (char *)path; + } + + unix_path = decc$translate_vms(path); + + if((int)unix_path <= 0) { + /* We can not translate it, so return the original string */ + return (char *)path; + } +} +# else + /* VMS translate path is actually not needed on the current 64-bit */ + /* VMS platforms, so instead of figuring out the pointer settings */ + /* Change it to a noop */ +# define vms_translate_path(__path) __path +# endif +#endif + +#ifdef __DECC +# if __INITIAL_POINTER_SIZE +# pragma __pointer_size __restore +# endif +#endif + +static char *vms_getenv(const char *envvar) +{ + char *result; + char *vms_path; + + /* first use the DECC getenv() function */ + result = decc$getenv(envvar); + if(!result) { + return result; + } + + vms_path = result; + result = vms_translate_path(vms_path); + + /* note that if you backport this to use VAX C RTL, that the VAX C RTL */ + /* may do a malloc(2048) for each call to getenv(), so you will need */ + /* to add a free(vms_path) */ + /* Do not do a free() for DEC C RTL builds, which should be used for */ + /* VMS 5.5-2 and later, even if using GCC */ + + return result; +} + +static struct passwd vms_passwd_cache; + +static struct passwd *vms_getpwuid(uid_t uid) +{ + struct passwd *my_passwd; + +/* Hack needed to support 64-bit builds, decc_getpwnam is 32-bit only */ +#ifdef __DECC +# if __INITIAL_POINTER_SIZE + __char_ptr32 unix_path; +# else + char *unix_path; +# endif +#else + char *unix_path; +#endif + + my_passwd = decc_getpwuid(uid); + if(!my_passwd) { + return my_passwd; + } + + unix_path = vms_translate_path(my_passwd->pw_dir); + + if((long)unix_path <= 0) { + /* We can not translate it, so return the original string */ + return my_passwd; + } + + /* If no changes needed, return it */ + if(unix_path == my_passwd->pw_dir) { + return my_passwd; + } + + /* Need to copy the structure returned */ + /* Since curl is only using pw_dir, no need to fix up */ + /* the pw_shell when running under Bash */ + vms_passwd_cache.pw_name = my_passwd->pw_name; + vms_passwd_cache.pw_uid = my_passwd->pw_uid; + vms_passwd_cache.pw_gid = my_passwd->pw_uid; + vms_passwd_cache.pw_dir = unix_path; + vms_passwd_cache.pw_shell = my_passwd->pw_shell; + + return &vms_passwd_cache; +} + +#ifdef __DECC +#pragma message restore +#endif + +/* Bug - VMS OpenSSL and Kerberos universal symbols are in uppercase only */ +/* VMS libraries should have universal symbols in exact and uppercase */ + +#define ASN1_INTEGER_get ASN1_INTEGER_GET +#define ASN1_STRING_data ASN1_STRING_DATA +#define ASN1_STRING_length ASN1_STRING_LENGTH +#define ASN1_STRING_print ASN1_STRING_PRINT +#define ASN1_STRING_to_UTF8 ASN1_STRING_TO_UTF8 +#define ASN1_STRING_type ASN1_STRING_TYPE +#define BIO_ctrl BIO_CTRL +#define BIO_free BIO_FREE +#define BIO_new BIO_NEW +#define BIO_s_mem BIO_S_MEM +#define BN_bn2bin BN_BN2BIN +#define BN_num_bits BN_NUM_BITS +#define CRYPTO_cleanup_all_ex_data CRYPTO_CLEANUP_ALL_EX_DATA +#define CRYPTO_free CRYPTO_FREE +#define CRYPTO_malloc CRYPTO_MALLOC +#define CONF_modules_load_file CONF_MODULES_LOAD_FILE +#ifdef __VAX +# ifdef VMS_OLD_SSL + /* Ancient OpenSSL on VAX/VMS missing this constant */ +# define CONF_MFLAGS_IGNORE_MISSING_FILE 0x10 +# undef CONF_modules_load_file +static int CONF_modules_load_file(const char *filename, + const char *appname, + unsigned long flags) { + return 1; +} +# endif +#endif +#define DES_ecb_encrypt DES_ECB_ENCRYPT +#define DES_set_key DES_SET_KEY +#define DES_set_odd_parity DES_SET_ODD_PARITY +#define ENGINE_ctrl ENGINE_CTRL +#define ENGINE_ctrl_cmd ENGINE_CTRL_CMD +#define ENGINE_finish ENGINE_FINISH +#define ENGINE_free ENGINE_FREE +#define ENGINE_get_first ENGINE_GET_FIRST +#define ENGINE_get_id ENGINE_GET_ID +#define ENGINE_get_next ENGINE_GET_NEXT +#define ENGINE_init ENGINE_INIT +#define ENGINE_load_builtin_engines ENGINE_LOAD_BUILTIN_ENGINES +#define ENGINE_load_private_key ENGINE_LOAD_PRIVATE_KEY +#define ENGINE_set_default ENGINE_SET_DEFAULT +#define ERR_clear_error ERR_CLEAR_ERROR +#define ERR_error_string ERR_ERROR_STRING +#define ERR_error_string_n ERR_ERROR_STRING_N +#define ERR_free_strings ERR_FREE_STRINGS +#define ERR_get_error ERR_GET_ERROR +#define ERR_peek_error ERR_PEEK_ERROR +#define ERR_remove_state ERR_REMOVE_STATE +#define EVP_PKEY_copy_parameters EVP_PKEY_COPY_PARAMETERS +#define EVP_PKEY_free EVP_PKEY_FREE +#define EVP_cleanup EVP_CLEANUP +#define GENERAL_NAMES_free GENERAL_NAMES_FREE +#define i2d_X509_PUBKEY I2D_X509_PUBKEY +#define MD4_Final MD4_FINAL +#define MD4_Init MD4_INIT +#define MD4_Update MD4_UPDATE +#define MD5_Final MD5_FINAL +#define MD5_Init MD5_INIT +#define MD5_Update MD5_UPDATE +#define OPENSSL_add_all_algo_noconf OPENSSL_ADD_ALL_ALGO_NOCONF +#ifndef __VAX +#define OPENSSL_load_builtin_modules OPENSSL_LOAD_BUILTIN_MODULES +#endif +#define PEM_read_X509 PEM_READ_X509 +#define PEM_write_bio_X509 PEM_WRITE_BIO_X509 +#define PKCS12_free PKCS12_FREE +#define PKCS12_parse PKCS12_PARSE +#define RAND_add RAND_ADD +#define RAND_bytes RAND_BYTES +#define RAND_file_name RAND_FILE_NAME +#define RAND_load_file RAND_LOAD_FILE +#define RAND_status RAND_STATUS +#define SSL_CIPHER_get_name SSL_CIPHER_GET_NAME +#define SSL_CTX_add_client_CA SSL_CTX_ADD_CLIENT_CA +#define SSL_CTX_callback_ctrl SSL_CTX_CALLBACK_CTRL +#define SSL_CTX_check_private_key SSL_CTX_CHECK_PRIVATE_KEY +#define SSL_CTX_ctrl SSL_CTX_CTRL +#define SSL_CTX_free SSL_CTX_FREE +#define SSL_CTX_get_cert_store SSL_CTX_GET_CERT_STORE +#define SSL_CTX_load_verify_locations SSL_CTX_LOAD_VERIFY_LOCATIONS +#define SSL_CTX_new SSL_CTX_NEW +#define SSL_CTX_set_cipher_list SSL_CTX_SET_CIPHER_LIST +#define SSL_CTX_set_def_passwd_cb_ud SSL_CTX_SET_DEF_PASSWD_CB_UD +#define SSL_CTX_set_default_passwd_cb SSL_CTX_SET_DEFAULT_PASSWD_CB +#define SSL_CTX_set_msg_callback SSL_CTX_SET_MSG_CALLBACK +#define SSL_CTX_set_verify SSL_CTX_SET_VERIFY +#define SSL_CTX_use_PrivateKey SSL_CTX_USE_PRIVATEKEY +#define SSL_CTX_use_PrivateKey_file SSL_CTX_USE_PRIVATEKEY_FILE +#define SSL_CTX_use_cert_chain_file SSL_CTX_USE_CERT_CHAIN_FILE +#define SSL_CTX_use_certificate SSL_CTX_USE_CERTIFICATE +#define SSL_CTX_use_certificate_file SSL_CTX_USE_CERTIFICATE_FILE +#define SSL_SESSION_free SSL_SESSION_FREE +#define SSL_connect SSL_CONNECT +#define SSL_free SSL_FREE +#define SSL_get1_session SSL_GET1_SESSION +#define SSL_get_certificate SSL_GET_CERTIFICATE +#define SSL_get_current_cipher SSL_GET_CURRENT_CIPHER +#define SSL_get_error SSL_GET_ERROR +#define SSL_get_peer_cert_chain SSL_GET_PEER_CERT_CHAIN +#define SSL_get_peer_certificate SSL_GET_PEER_CERTIFICATE +#define SSL_get_privatekey SSL_GET_PRIVATEKEY +#define SSL_get_session SSL_GET_SESSION +#define SSL_get_shutdown SSL_GET_SHUTDOWN +#define SSL_get_verify_result SSL_GET_VERIFY_RESULT +#define SSL_library_init SSL_LIBRARY_INIT +#define SSL_load_error_strings SSL_LOAD_ERROR_STRINGS +#define SSL_new SSL_NEW +#define SSL_peek SSL_PEEK +#define SSL_pending SSL_PENDING +#define SSL_read SSL_READ +#define SSL_set_connect_state SSL_SET_CONNECT_STATE +#define SSL_set_fd SSL_SET_FD +#define SSL_set_session SSL_SET_SESSION +#define SSL_shutdown SSL_SHUTDOWN +#define SSL_version SSL_VERSION +#define SSL_write SSL_WRITE +#define SSLeay SSLEAY +#define SSLv23_client_method SSLV23_CLIENT_METHOD +#define SSLv3_client_method SSLV3_CLIENT_METHOD +#define TLSv1_client_method TLSV1_CLIENT_METHOD +#define UI_create_method UI_CREATE_METHOD +#define UI_destroy_method UI_DESTROY_METHOD +#define UI_get0_user_data UI_GET0_USER_DATA +#define UI_get_input_flags UI_GET_INPUT_FLAGS +#define UI_get_string_type UI_GET_STRING_TYPE +#define UI_create_method UI_CREATE_METHOD +#define UI_destroy_method UI_DESTROY_METHOD +#define UI_method_get_closer UI_METHOD_GET_CLOSER +#define UI_method_get_opener UI_METHOD_GET_OPENER +#define UI_method_get_reader UI_METHOD_GET_READER +#define UI_method_get_writer UI_METHOD_GET_WRITER +#define UI_method_set_closer UI_METHOD_SET_CLOSER +#define UI_method_set_opener UI_METHOD_SET_OPENER +#define UI_method_set_reader UI_METHOD_SET_READER +#define UI_method_set_writer UI_METHOD_SET_WRITER +#define UI_OpenSSL UI_OPENSSL +#define UI_set_result UI_SET_RESULT +#define X509V3_EXT_print X509V3_EXT_PRINT +#define X509_EXTENSION_get_critical X509_EXTENSION_GET_CRITICAL +#define X509_EXTENSION_get_data X509_EXTENSION_GET_DATA +#define X509_EXTENSION_get_object X509_EXTENSION_GET_OBJECT +#define X509_LOOKUP_file X509_LOOKUP_FILE +#define X509_NAME_ENTRY_get_data X509_NAME_ENTRY_GET_DATA +#define X509_NAME_get_entry X509_NAME_GET_ENTRY +#define X509_NAME_get_index_by_NID X509_NAME_GET_INDEX_BY_NID +#define X509_NAME_print_ex X509_NAME_PRINT_EX +#define X509_STORE_CTX_get_current_cert X509_STORE_CTX_GET_CURRENT_CERT +#define X509_STORE_add_lookup X509_STORE_ADD_LOOKUP +#define X509_STORE_set_flags X509_STORE_SET_FLAGS +#define X509_check_issued X509_CHECK_ISSUED +#define X509_free X509_FREE +#define X509_get_ext_d2i X509_GET_EXT_D2I +#define X509_get_issuer_name X509_GET_ISSUER_NAME +#define X509_get_pubkey X509_GET_PUBKEY +#define X509_get_serialNumber X509_GET_SERIALNUMBER +#define X509_get_subject_name X509_GET_SUBJECT_NAME +#define X509_load_crl_file X509_LOAD_CRL_FILE +#define X509_verify_cert_error_string X509_VERIFY_CERT_ERROR_STRING +#define d2i_PKCS12_fp D2I_PKCS12_FP +#define i2t_ASN1_OBJECT I2T_ASN1_OBJECT +#define sk_num SK_NUM +#define sk_pop SK_POP +#define sk_pop_free SK_POP_FREE +#define sk_value SK_VALUE +#define SHA256_Final SHA256_FINAL +#define SHA256_Init SHA256_INIT +#define SHA256_Update SHA256_UPDATE + +#define USE_UPPERCASE_GSSAPI 1 +#define gss_seal GSS_SEAL +#define gss_unseal GSS_UNSEAL + +#define USE_UPPERCASE_KRBAPI 1 + +/* AI_NUMERICHOST needed for IP V6 support in curl */ +#ifdef HAVE_NETDB_H +#include +#ifndef AI_NUMERICHOST +#undef USE_IPV6 +#endif +#endif + +/* VAX symbols are always in uppercase */ +#ifdef __VAX +#define inflate INFLATE +#define inflateEnd INFLATEEND +#define inflateInit2_ INFLATEINIT2_ +#define inflateInit_ INFLATEINIT_ +#define zlibVersion ZLIBVERSION +#endif + +/* Older VAX OpenSSL port defines these as Macros */ +/* Need to include the headers first and then redefine */ +/* that way a newer port will also work if some one has one */ +#ifdef __VAX + +# include +# ifndef OpenSSL_add_all_algorithms +# define OpenSSL_add_all_algorithms OPENSSL_ADD_ALL_ALGORITHMS + void OPENSSL_ADD_ALL_ALGORITHMS(void); +# endif +#endif + +#endif /* HEADER_CURL_SETUP_VMS_H */ diff --git a/3rdparty/curl-8.21.0/lib/setup-win32.h b/3rdparty/curl-8.21.0/lib/setup-win32.h new file mode 100644 index 0000000000..6a89b966de --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/setup-win32.h @@ -0,0 +1,110 @@ +#ifndef HEADER_CURL_SETUP_WIN32_H +#define HEADER_CURL_SETUP_WIN32_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +#undef USE_WINSOCK +/* ---------------------------------------------------------------- */ +/* Watt-32 TCP/IP SPECIFIC */ +/* ---------------------------------------------------------------- */ +#ifdef USE_WATT32 +# include +# include +# undef byte +# undef word +# define HAVE_SYS_IOCTL_H +# define HAVE_NETINET_IN_H +# define HAVE_NETDB_H +# define HAVE_ARPA_INET_H +# define SOCKET int +/* ---------------------------------------------------------------- */ +/* BSD-style lwIP TCP/IP stack SPECIFIC */ +/* ---------------------------------------------------------------- */ +#elif defined(USE_LWIPSOCK) + /* Define to use BSD-style lwIP TCP/IP stack. */ + /* #define USE_LWIPSOCK 1 */ +# undef HAVE_GETHOSTNAME +# define HAVE_GETHOSTBYNAME_R +# define HAVE_GETHOSTBYNAME_R_6 +# undef LWIP_POSIX_SOCKETS_IO_NAMES +# define LWIP_POSIX_SOCKETS_IO_NAMES 0 +# undef RECV_TYPE_ARG1 +# define RECV_TYPE_ARG1 int +# undef RECV_TYPE_ARG3 +# define RECV_TYPE_ARG3 size_t +# undef SEND_TYPE_ARG1 +# define SEND_TYPE_ARG1 int +# undef SEND_TYPE_ARG3 +# define SEND_TYPE_ARG3 size_t +#elif defined(_WIN32) +# define USE_WINSOCK 2 +# include +# include +#endif + +/* + * Include header files for Windows builds before redefining anything. Use + * this preprocessor block only to include or exclude windows.h, winsock2.h or + * ws2tcpip.h. Any other Windows thing belongs to any other further and + * independent block. Under Cygwin things work as under Linux (e.g. + * ) and the Winsock headers should never be included when + * __CYGWIN__ is defined. + */ +#ifdef _WIN32 +# if defined(UNICODE) && !defined(_UNICODE) +# error "UNICODE is defined but _UNICODE is not defined" +# endif +# if defined(_UNICODE) && !defined(UNICODE) +# error "_UNICODE is defined but UNICODE is not defined" +# endif +# include +# include +# include +#endif + +/* + * Define _WIN32_WINNT_[OS] symbols because not all Windows build systems have + * those symbols to compare against, and even those that do may be missing + * newer symbols. + */ +#ifndef _WIN32_WINNT_VISTA +#define _WIN32_WINNT_VISTA 0x0600 /* Windows Vista */ +#endif +#ifndef _WIN32_WINNT_WS08 +#define _WIN32_WINNT_WS08 0x0600 /* Windows Server 2008 */ +#endif +#ifndef _WIN32_WINNT_WIN7 +#define _WIN32_WINNT_WIN7 0x0601 /* Windows 7 */ +#endif +#ifndef _WIN32_WINNT_WIN8 +#define _WIN32_WINNT_WIN8 0x0602 /* Windows 8 */ +#endif +#ifndef _WIN32_WINNT_WINBLUE +#define _WIN32_WINNT_WINBLUE 0x0603 /* Windows 8.1 */ +#endif +#ifndef _WIN32_WINNT_WIN10 +#define _WIN32_WINNT_WIN10 0x0A00 /* Windows 10 */ +#endif + +#endif /* HEADER_CURL_SETUP_WIN32_H */ diff --git a/3rdparty/curl-8.21.0/lib/sha256.c b/3rdparty/curl-8.21.0/lib/sha256.c new file mode 100644 index 0000000000..047119044b --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/sha256.c @@ -0,0 +1,513 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Florin Petriuc, + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_AWS) || !defined(CURL_DISABLE_DIGEST_AUTH) || \ + defined(USE_LIBSSH2) || defined(USE_SSL) + +#include "curl_sha256.h" + +#ifdef USE_MBEDTLS +#include +#if MBEDTLS_VERSION_NUMBER < 0x03020000 +#error "mbedTLS 3.2.0 or later required" +#endif +#include +#endif + +/* Please keep the SSL backend-specific #if branches in this order: + * + * 1. USE_OPENSSL + * 2. USE_WOLFSSL + * 3. USE_GNUTLS + * 4. USE_MBEDTLS + * 5. USE_WIN32_CRYPTO + * 6. USE_COMMON_CRYPTO + * + * This ensures that the same SSL branch gets activated throughout this source + * file even if multiple backends are enabled at the same time. + */ + +#ifdef USE_OPENSSL +#include + +struct ossl_sha256_ctx { + EVP_MD_CTX *openssl_ctx; +}; +typedef struct ossl_sha256_ctx my_sha256_ctx; + +static CURLcode my_sha256_init(void *in) +{ + my_sha256_ctx *ctx = (my_sha256_ctx *)in; + ctx->openssl_ctx = EVP_MD_CTX_create(); + if(!ctx->openssl_ctx) + return CURLE_OUT_OF_MEMORY; + + if(!EVP_DigestInit_ex(ctx->openssl_ctx, EVP_sha256(), NULL)) { + EVP_MD_CTX_destroy(ctx->openssl_ctx); + return CURLE_FAILED_INIT; + } + return CURLE_OK; +} + +static void my_sha256_update(void *in, + const unsigned char *data, + unsigned int length) +{ + my_sha256_ctx *ctx = (my_sha256_ctx *)in; + EVP_DigestUpdate(ctx->openssl_ctx, data, length); +} + +static void my_sha256_final(unsigned char *digest, void *in) +{ + my_sha256_ctx *ctx = (my_sha256_ctx *)in; + EVP_DigestFinal_ex(ctx->openssl_ctx, digest, NULL); + EVP_MD_CTX_destroy(ctx->openssl_ctx); +} + +#elif defined(USE_WOLFSSL) +#include +#include + +typedef struct wc_Sha256 my_sha256_ctx; + +static CURLcode my_sha256_init(void *in) +{ + if(wc_InitSha256(in)) + return CURLE_FAILED_INIT; + return CURLE_OK; +} + +static void my_sha256_update(void *in, + const unsigned char *data, + unsigned int length) +{ + (void)wc_Sha256Update(in, data, (word32)length); +} + +static void my_sha256_final(unsigned char *digest, void *in) +{ + (void)wc_Sha256Final(in, digest); +} + +#elif defined(USE_GNUTLS) +#include +#include + +typedef struct sha256_ctx my_sha256_ctx; + +static CURLcode my_sha256_init(void *ctx) +{ + sha256_init(ctx); + return CURLE_OK; +} + +static void my_sha256_update(void *ctx, + const unsigned char *data, + unsigned int length) +{ + sha256_update(ctx, length, data); +} + +static void my_sha256_final(unsigned char *digest, void *ctx) +{ +#if NETTLE_VERSION_MAJOR >= 4 + sha256_digest(ctx, digest); +#else + sha256_digest(ctx, SHA256_DIGEST_SIZE, digest); +#endif +} + +#elif defined(USE_MBEDTLS) && \ + defined(PSA_WANT_ALG_SHA_256) && PSA_WANT_ALG_SHA_256 +#include + +typedef psa_hash_operation_t my_sha256_ctx; + +static CURLcode my_sha256_init(void *ctx) +{ + memset(ctx, 0, sizeof(my_sha256_ctx)); + if(psa_hash_setup(ctx, PSA_ALG_SHA_256) != PSA_SUCCESS) + return CURLE_OUT_OF_MEMORY; + return CURLE_OK; +} + +static void my_sha256_update(void *ctx, + const unsigned char *data, + unsigned int length) +{ + (void)psa_hash_update(ctx, data, length); +} + +static void my_sha256_final(unsigned char *digest, void *ctx) +{ + size_t actual_length; + (void)psa_hash_finish(ctx, digest, CURL_SHA256_DIGEST_LENGTH, + &actual_length); +} + +#elif (defined(__MAC_OS_X_VERSION_MAX_ALLOWED) && \ + (__MAC_OS_X_VERSION_MAX_ALLOWED >= 1040)) || \ + (defined(__IPHONE_OS_VERSION_MAX_ALLOWED) && \ + (__IPHONE_OS_VERSION_MAX_ALLOWED >= 20000)) +#include + +typedef CC_SHA256_CTX my_sha256_ctx; + +static CURLcode my_sha256_init(void *ctx) +{ + (void)CC_SHA256_Init(ctx); + return CURLE_OK; +} + +static void my_sha256_update(void *ctx, + const unsigned char *data, + unsigned int length) +{ + (void)CC_SHA256_Update(ctx, data, length); +} + +static void my_sha256_final(unsigned char *digest, void *ctx) +{ + (void)CC_SHA256_Final(digest, ctx); +} + +#elif defined(USE_WIN32_CRYPTO) +#include + +struct sha256_ctx { + HCRYPTPROV hCryptProv; + HCRYPTHASH hHash; +}; +typedef struct sha256_ctx my_sha256_ctx; + +static CURLcode my_sha256_init(void *in) +{ + my_sha256_ctx *ctx = (my_sha256_ctx *)in; + if(!CryptAcquireContext(&ctx->hCryptProv, NULL, NULL, PROV_RSA_AES, + CRYPT_VERIFYCONTEXT | CRYPT_SILENT)) + return CURLE_OUT_OF_MEMORY; + + if(!CryptCreateHash(ctx->hCryptProv, CALG_SHA_256, 0, 0, &ctx->hHash)) { + CryptReleaseContext(ctx->hCryptProv, 0); + ctx->hCryptProv = 0; + return CURLE_FAILED_INIT; + } + + return CURLE_OK; +} + +static void my_sha256_update(void *in, + const unsigned char *data, + unsigned int length) +{ + my_sha256_ctx *ctx = (my_sha256_ctx *)in; + CryptHashData(ctx->hHash, (const BYTE *)data, length, 0); +} + +static void my_sha256_final(unsigned char *digest, void *in) +{ + my_sha256_ctx *ctx = (my_sha256_ctx *)in; + unsigned long length = 0; + + CryptGetHashParam(ctx->hHash, HP_HASHVAL, NULL, &length, 0); + if(length == CURL_SHA256_DIGEST_LENGTH) + CryptGetHashParam(ctx->hHash, HP_HASHVAL, digest, &length, 0); + + if(ctx->hHash) + CryptDestroyHash(ctx->hHash); + + if(ctx->hCryptProv) + CryptReleaseContext(ctx->hCryptProv, 0); +} + +#else + +/* When no other crypto library is available we use this code segment */ + +/* This is based on the SHA256 implementation in LibTomCrypt that was released + * into public domain. */ + +#define WPA_GET_BE32(a) \ + ((((unsigned long)(a)[0]) << 24) | \ + (((unsigned long)(a)[1]) << 16) | \ + (((unsigned long)(a)[2]) << 8) | \ + ((unsigned long)(a)[3])) +#define WPA_PUT_BE32(a, val) \ + do { \ + (a)[0] = (unsigned char)((((unsigned long)(val)) >> 24) & 0xff); \ + (a)[1] = (unsigned char)((((unsigned long)(val)) >> 16) & 0xff); \ + (a)[2] = (unsigned char)((((unsigned long)(val)) >> 8) & 0xff); \ + (a)[3] = (unsigned char)(((unsigned long)(val)) & 0xff); \ + } while(0) + +#define WPA_PUT_BE64(a, val) \ + do { \ + (a)[0] = (unsigned char)(((uint64_t)(val)) >> 56); \ + (a)[1] = (unsigned char)(((uint64_t)(val)) >> 48); \ + (a)[2] = (unsigned char)(((uint64_t)(val)) >> 40); \ + (a)[3] = (unsigned char)(((uint64_t)(val)) >> 32); \ + (a)[4] = (unsigned char)(((uint64_t)(val)) >> 24); \ + (a)[5] = (unsigned char)(((uint64_t)(val)) >> 16); \ + (a)[6] = (unsigned char)(((uint64_t)(val)) >> 8); \ + (a)[7] = (unsigned char)(((uint64_t)(val)) & 0xff); \ + } while(0) + +struct sha256_state { + uint64_t length; + unsigned long state[8], curlen; + unsigned char buf[64]; +}; +typedef struct sha256_state my_sha256_ctx; + +/* The K array */ +static const unsigned long K[64] = { + 0x428a2f98UL, 0x71374491UL, 0xb5c0fbcfUL, 0xe9b5dba5UL, 0x3956c25bUL, + 0x59f111f1UL, 0x923f82a4UL, 0xab1c5ed5UL, 0xd807aa98UL, 0x12835b01UL, + 0x243185beUL, 0x550c7dc3UL, 0x72be5d74UL, 0x80deb1feUL, 0x9bdc06a7UL, + 0xc19bf174UL, 0xe49b69c1UL, 0xefbe4786UL, 0x0fc19dc6UL, 0x240ca1ccUL, + 0x2de92c6fUL, 0x4a7484aaUL, 0x5cb0a9dcUL, 0x76f988daUL, 0x983e5152UL, + 0xa831c66dUL, 0xb00327c8UL, 0xbf597fc7UL, 0xc6e00bf3UL, 0xd5a79147UL, + 0x06ca6351UL, 0x14292967UL, 0x27b70a85UL, 0x2e1b2138UL, 0x4d2c6dfcUL, + 0x53380d13UL, 0x650a7354UL, 0x766a0abbUL, 0x81c2c92eUL, 0x92722c85UL, + 0xa2bfe8a1UL, 0xa81a664bUL, 0xc24b8b70UL, 0xc76c51a3UL, 0xd192e819UL, + 0xd6990624UL, 0xf40e3585UL, 0x106aa070UL, 0x19a4c116UL, 0x1e376c08UL, + 0x2748774cUL, 0x34b0bcb5UL, 0x391c0cb3UL, 0x4ed8aa4aUL, 0x5b9cca4fUL, + 0x682e6ff3UL, 0x748f82eeUL, 0x78a5636fUL, 0x84c87814UL, 0x8cc70208UL, + 0x90befffaUL, 0xa4506cebUL, 0xbef9a3f7UL, 0xc67178f2UL +}; + +/* Various logical functions */ +#define RORc(x, y) \ + (((((unsigned long)(x) & 0xFFFFFFFFUL) >> (unsigned long)((y) & 31)) | \ + ((unsigned long)(x) << (unsigned long)(32 - ((y) & 31)))) & 0xFFFFFFFFUL) + +#define Sha256_Ch(x, y, z) (z ^ (x & (y ^ z))) +#define Sha256_Maj(x, y, z) (((x | y) & z) | (x & y)) +#define Sha256_S(x, n) RORc(x, n) +#define Sha256_R(x, n) (((x) & 0xFFFFFFFFUL) >> (n)) + +#define Sigma0(x) (Sha256_S(x, 2) ^ Sha256_S(x, 13) ^ Sha256_S(x, 22)) +#define Sigma1(x) (Sha256_S(x, 6) ^ Sha256_S(x, 11) ^ Sha256_S(x, 25)) +#define Gamma0(x) (Sha256_S(x, 7) ^ Sha256_S(x, 18) ^ Sha256_R(x, 3)) +#define Gamma1(x) (Sha256_S(x, 17) ^ Sha256_S(x, 19) ^ Sha256_R(x, 10)) + +/* Compress 512 bits */ +static int sha256_compress(struct sha256_state *md, const unsigned char *buf) +{ + unsigned long S[8], W[64]; + int i; + + /* Copy state into S */ + for(i = 0; i < 8; i++) { + S[i] = md->state[i]; + } + /* copy the state into 512 bits into W[0..15] */ + for(i = 0; i < 16; i++) + W[i] = WPA_GET_BE32(buf + (4 * i)); + /* fill W[16..63] */ + for(i = 16; i < 64; i++) { + W[i] = Gamma1(W[i - 2]) + W[i - 7] + Gamma0(W[i - 15]) + W[i - 16]; + } + + /* Compress */ +#define RND(a, b, c, d, e, f, g, h, i) \ + do { \ + unsigned long t0 = h + Sigma1(e) + Sha256_Ch(e, f, g) + K[i] + W[i]; \ + unsigned long t1 = Sigma0(a) + Sha256_Maj(a, b, c); \ + d += t0; \ + h = t0 + t1; \ + } while(0) + + for(i = 0; i < 64; ++i) { + unsigned long t; + RND(S[0], S[1], S[2], S[3], S[4], S[5], S[6], S[7], i); + t = S[7]; + S[7] = S[6]; + S[6] = S[5]; + S[5] = S[4]; + S[4] = S[3]; + S[3] = S[2]; + S[2] = S[1]; + S[1] = S[0]; + S[0] = t; + } + + /* Feedback */ + for(i = 0; i < 8; i++) { + md->state[i] = md->state[i] + S[i]; + } + + return 0; +} + +/* Initialize the hash state */ +static CURLcode my_sha256_init(void *in) +{ + struct sha256_state *md = (struct sha256_state *)in; + md->curlen = 0; + md->length = 0; + md->state[0] = 0x6A09E667UL; + md->state[1] = 0xBB67AE85UL; + md->state[2] = 0x3C6EF372UL; + md->state[3] = 0xA54FF53AUL; + md->state[4] = 0x510E527FUL; + md->state[5] = 0x9B05688CUL; + md->state[6] = 0x1F83D9ABUL; + md->state[7] = 0x5BE0CD19UL; + + return CURLE_OK; +} + +/* + Process a block of memory though the hash + @param md The hash state + @param in The data to hash + @param inlen The length of the data (octets) +*/ +static void my_sha256_update(void *ctx, + const unsigned char *in, + unsigned int len) +{ + unsigned long inlen = len; + unsigned long n; + struct sha256_state *md = (struct sha256_state *)ctx; +#define CURL_SHA256_BLOCK_SIZE 64 + if(md->curlen > sizeof(md->buf)) + return; + while(inlen > 0) { + if(md->curlen == 0 && inlen >= CURL_SHA256_BLOCK_SIZE) { + if(sha256_compress(md, in) < 0) + return; + md->length += CURL_SHA256_BLOCK_SIZE * 8; + in += CURL_SHA256_BLOCK_SIZE; + inlen -= CURL_SHA256_BLOCK_SIZE; + } + else { + n = CURLMIN(inlen, (CURL_SHA256_BLOCK_SIZE - md->curlen)); + memcpy(md->buf + md->curlen, in, n); + md->curlen += n; + in += n; + inlen -= n; + if(md->curlen == CURL_SHA256_BLOCK_SIZE) { + if(sha256_compress(md, md->buf) < 0) + return; + md->length += 8 * CURL_SHA256_BLOCK_SIZE; + md->curlen = 0; + } + } + } +} + +/* + Terminate the hash to get the digest + @param md The hash state + @param out [out] The destination of the hash (32 bytes) + @return 0 if successful +*/ +static void my_sha256_final(unsigned char *out, void *ctx) +{ + struct sha256_state *md = ctx; + int i; + + if(md->curlen >= sizeof(md->buf)) + return; + + /* Increase the length of the message */ + md->length += md->curlen * 8; + + /* Append the '1' bit */ + md->buf[md->curlen++] = (unsigned char)0x80; + + /* If the length is currently above 56 bytes we append zeros + * then compress. Then we can fall back to padding zeros and length + * encoding like normal. + */ + if(md->curlen > 56) { + while(md->curlen < 64) { + md->buf[md->curlen++] = 0; + } + sha256_compress(md, md->buf); + md->curlen = 0; + } + + /* Pad up to 56 bytes of zeroes */ + while(md->curlen < 56) { + md->buf[md->curlen++] = 0; + } + + /* Store length */ + WPA_PUT_BE64(md->buf + 56, md->length); + sha256_compress(md, md->buf); + + /* Copy output */ + for(i = 0; i < 8; i++) + WPA_PUT_BE32(out + (4 * i), md->state[i]); +} + +#endif /* CRYPTO LIBS */ + +/* + * Curl_sha256it() + * + * Generates a SHA256 hash for the given input data. + * + * Parameters: + * + * output [in/out] - The output buffer. + * input [in] - The input data. + * length [in] - The input length. + * + * Returns CURLE_OK on success. + */ +CURLcode Curl_sha256it(unsigned char *output, const unsigned char *input, + size_t len) +{ + CURLcode result; + my_sha256_ctx ctx; + + result = my_sha256_init(&ctx); + if(!result) { + do { + unsigned int ilen = (unsigned int)CURLMIN(len, UINT_MAX); + my_sha256_update(&ctx, input, ilen); + len -= ilen; + input += ilen; + } while(len); + my_sha256_final(output, &ctx); + } + return result; +} + +const struct HMAC_params Curl_HMAC_SHA256 = { + my_sha256_init, /* Hash initialization function. */ + my_sha256_update, /* Hash update function. */ + my_sha256_final, /* Hash computation end function. */ + sizeof(my_sha256_ctx), /* Size of hash context structure. */ + 64, /* Maximum key length. */ + 32 /* Result size. */ +}; + +#endif /* AWS, DIGEST, or libssh2 */ diff --git a/3rdparty/curl-8.21.0/lib/sigpipe.h b/3rdparty/curl-8.21.0/lib/sigpipe.h new file mode 100644 index 0000000000..b489796953 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/sigpipe.h @@ -0,0 +1,102 @@ +#ifndef HEADER_CURL_SIGPIPE_H +#define HEADER_CURL_SIGPIPE_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if defined(HAVE_SIGACTION) && !defined(USE_SO_NOSIGPIPE) +#include + +struct Curl_sigpipe_ctx { + struct sigaction old_pipe_act; + BIT(no_signal); +}; + +static CURL_INLINE void sigpipe_init(struct Curl_sigpipe_ctx *ig) +{ + memset(ig, 0, sizeof(*ig)); + ig->no_signal = TRUE; +} + +/* + * sigpipe_ignore() makes sure we ignore SIGPIPE while running libcurl + * internals, and then sigpipe_restore() will restore the situation when we + * return from libcurl again. + */ +static CURL_INLINE void sigpipe_ignore(struct Curl_easy *data, + struct Curl_sigpipe_ctx *ig) +{ + /* get a local copy of no_signal because the Curl_easy might not be + around when we restore */ + ig->no_signal = data->set.no_signal; + if(!data->set.no_signal) { + struct sigaction action; + /* first, extract the existing situation */ + sigaction(SIGPIPE, NULL, &ig->old_pipe_act); + action = ig->old_pipe_act; + /* ignore this signal */ + action.sa_handler = SIG_IGN; +#ifdef SA_SIGINFO + /* clear SA_SIGINFO flag since we are using sa_handler */ + action.sa_flags &= ~SA_SIGINFO; +#endif + sigaction(SIGPIPE, &action, NULL); + } +} + +/* + * sigpipe_restore() puts back the outside world's opinion of signal handler + * and SIGPIPE handling. It MUST only be called after a corresponding + * sigpipe_ignore() was used. + */ +static CURL_INLINE void sigpipe_restore(struct Curl_sigpipe_ctx *ig) +{ + if(!ig->no_signal) + /* restore the outside state */ + sigaction(SIGPIPE, &ig->old_pipe_act, NULL); +} + +static CURL_INLINE void sigpipe_apply(struct Curl_easy *data, + struct Curl_sigpipe_ctx *ig) +{ + if(data && (data->set.no_signal != ig->no_signal)) { + sigpipe_restore(ig); + sigpipe_ignore(data, ig); + } +} + +#else /* !HAVE_SIGACTION || USE_SO_NOSIGPIPE */ +/* for systems without sigaction or where SO_NOSIGPIPE is used. */ +#define sigpipe_ignore(x, y) do { (void)(x); (void)(y); } while(0) +#define sigpipe_apply(x, y) do { (void)(x); (void)(y); } while(0) +#define sigpipe_init(x) do { (void)(x); } while(0) +#define sigpipe_restore(x) do { (void)(x); } while(0) + +struct Curl_sigpipe_ctx { + bool dummy; +}; + +#endif /* else HAVE_SIGACTION && !USE_SO_NOSIGPIPE */ + +#endif /* HEADER_CURL_SIGPIPE_H */ diff --git a/3rdparty/curl-8.21.0/lib/slist.c b/3rdparty/curl-8.21.0/lib/slist.c new file mode 100644 index 0000000000..83fd2918c6 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/slist.c @@ -0,0 +1,139 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "slist.h" + +/* returns last node in linked list */ +static struct curl_slist *slist_get_last(struct curl_slist *list) +{ + struct curl_slist *item; + + /* if caller passed us a NULL, return now */ + if(!list) + return NULL; + + /* loop through to find the last item */ + item = list; + while(item->next) { + item = item->next; + } + return item; +} + +/* + * Curl_slist_append_nodup() appends a string to the linked list. Rather than + * copying the string in dynamic storage, it takes its ownership. The string + * should have been malloc()ated. Curl_slist_append_nodup always returns + * the address of the first record, so that you can use this function as an + * initialization function as well as an append function. + * If an error occurs, NULL is returned and the string argument is NOT + * released. + */ +struct curl_slist *Curl_slist_append_nodup(struct curl_slist *list, + const char *data) +{ + struct curl_slist *last; + struct curl_slist *new_item; + + DEBUGASSERT(data); + + new_item = curlx_malloc(sizeof(struct curl_slist)); + if(!new_item) + return NULL; + + new_item->next = NULL; + new_item->data = CURL_UNCONST(data); + + /* if this is the first item, then new_item *is* the list */ + if(!list) + return new_item; + + last = slist_get_last(list); + last->next = new_item; + return list; +} + +/* + * curl_slist_append() appends a string to the linked list. It always returns + * the address of the first record, so that you can use this function as an + * initialization function as well as an append function. If you find this + * bothersome, then create a separate _init function and call it + * appropriately from within the program. + */ +struct curl_slist *curl_slist_append(struct curl_slist *list, const char *data) +{ + char *dupdata = curlx_strdup(data); + + if(!dupdata) + return NULL; + + list = Curl_slist_append_nodup(list, dupdata); + if(!list) + curlx_free(dupdata); + + return list; +} + +/* + * Curl_slist_duplicate() duplicates a linked list. It always returns the + * address of the first record of the cloned list or NULL in case of an + * error (or if the input list was NULL). + */ +struct curl_slist *Curl_slist_duplicate(struct curl_slist *inlist) +{ + struct curl_slist *outlist = NULL; + struct curl_slist *tmp; + + while(inlist) { + tmp = curl_slist_append(outlist, inlist->data); + + if(!tmp) { + curl_slist_free_all(outlist); + return NULL; + } + + outlist = tmp; + inlist = inlist->next; + } + return outlist; +} + +/* be nice and clean up resources */ +void curl_slist_free_all(struct curl_slist *list) +{ + struct curl_slist *next; + struct curl_slist *item; + + if(!list) + return; + + item = list; + do { + next = item->next; + curlx_safefree(item->data); + curlx_free(item); + item = next; + } while(next); +} diff --git a/3rdparty/curl-8.21.0/lib/slist.h b/3rdparty/curl-8.21.0/lib/slist.h new file mode 100644 index 0000000000..47a30824db --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/slist.h @@ -0,0 +1,41 @@ +#ifndef HEADER_CURL_SLIST_H +#define HEADER_CURL_SLIST_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +/* + * Curl_slist_duplicate() duplicates a linked list. It always returns the + * address of the first record of the cloned list or NULL in case of an + * error (or if the input list was NULL). + */ +struct curl_slist *Curl_slist_duplicate(struct curl_slist *inlist); + +/* + * Curl_slist_append_nodup() takes ownership of the given string and appends + * it to the list. + */ +struct curl_slist *Curl_slist_append_nodup(struct curl_slist *list, + const char *data); + +#endif /* HEADER_CURL_SLIST_H */ diff --git a/3rdparty/curl-8.21.0/lib/smb.c b/3rdparty/curl-8.21.0/lib/smb.c new file mode 100644 index 0000000000..70af8d5970 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/smb.c @@ -0,0 +1,1234 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * Copyright (C) Bill Nagel , Exacq Technologies + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" +#include "urldata.h" + +#if defined(CURL_ENABLE_SMB) && defined(USE_CURL_NTLM_CORE) + +#ifdef HAVE_ARPA_INET_H +#include /* for htons() */ +#endif + +#include "smb.h" +#include "url.h" +#include "sendf.h" +#include "curl_trc.h" +#include "cfilters.h" +#include "connect.h" +#include "progress.h" +#include "transfer.h" +#include "select.h" +#include "curl_ntlm_core.h" +#include "escape.h" +#include "curl_endian.h" +#include "curlx/strcopy.h" + +/* meta key for storing protocol meta at easy handle */ +#define CURL_META_SMB_EASY "meta:proto:smb:easy" +/* meta key for storing protocol meta at connection */ +#define CURL_META_SMB_CONN "meta:proto:smb:conn" + +enum smb_conn_state { + SMB_NOT_CONNECTED = 0, + SMB_CONNECTING, + SMB_NEGOTIATE, + SMB_SETUP, + SMB_CONNECTED +}; + +/* SMB connection data, kept at connection */ +struct smb_conn { + enum smb_conn_state state; + const char *user; + char *domain; + char *share; + unsigned char challenge[8]; + unsigned int session_key; + unsigned short uid; + char *recv_buf; + char *send_buf; + size_t upload_size; + size_t send_size; + size_t sent; + size_t got; +}; + +/* SMB request state */ +enum smb_req_state { + SMB_REQUESTING, + SMB_TREE_CONNECT, + SMB_OPEN, + SMB_DOWNLOAD, + SMB_UPLOAD, + SMB_CLOSE, + SMB_TREE_DISCONNECT, + SMB_DONE +}; + +/* SMB request data, kept at easy handle */ +struct smb_request { + enum smb_req_state state; + char *path; + unsigned short tid; /* Even if we connect to the same tree as another */ + unsigned short fid; /* request, the tid will be different */ + CURLcode result; +}; + +/* + * Definitions for SMB protocol data structures + */ +#if defined(_MSC_VER) || defined(__ILEC400__) +# define PACK +# pragma pack(push) +# pragma pack(1) +#elif defined(__GNUC__) +# define PACK __attribute__((packed)) +#else +# define PACK +#endif + +#define SMB_COM_CLOSE 0x04 +#define SMB_COM_READ_ANDX 0x2e +#define SMB_COM_WRITE_ANDX 0x2f +#define SMB_COM_TREE_DISCONNECT 0x71 +#define SMB_COM_NEGOTIATE 0x72 +#define SMB_COM_SETUP_ANDX 0x73 +#define SMB_COM_TREE_CONNECT_ANDX 0x75 +#define SMB_COM_NT_CREATE_ANDX 0xa2 +#define SMB_COM_NO_ANDX_COMMAND 0xff + +#define SMB_WC_CLOSE 0x03 +#define SMB_WC_READ_ANDX 0x0c +#define SMB_WC_WRITE_ANDX 0x0e +#define SMB_WC_SETUP_ANDX 0x0d +#define SMB_WC_TREE_CONNECT_ANDX 0x04 +#define SMB_WC_NT_CREATE_ANDX 0x18 + +#define SMB_FLAGS_CANONICAL_PATHNAMES 0x10 +#define SMB_FLAGS_CASELESS_PATHNAMES 0x08 +/* #define SMB_FLAGS2_UNICODE_STRINGS 0x8000 */ +#define SMB_FLAGS2_IS_LONG_NAME 0x0040 +#define SMB_FLAGS2_KNOWS_LONG_NAME 0x0001 + +#define SMB_CAP_LARGE_FILES 0x08 +#define SMB_GENERIC_WRITE 0x40000000 +#define SMB_GENERIC_READ 0x80000000 +#define SMB_FILE_SHARE_ALL 0x07 +#define SMB_FILE_OPEN 0x01 +#define SMB_FILE_OVERWRITE_IF 0x05 + +#define SMB_ERR_NOACCESS 0x00050001 + +struct smb_header { + unsigned char nbt_type; + unsigned char nbt_flags; + unsigned short nbt_length; + unsigned char magic[4]; + unsigned char command; + unsigned int status; + unsigned char flags; + unsigned short flags2; + unsigned short pid_high; + unsigned char signature[8]; + unsigned short pad; + unsigned short tid; + unsigned short pid; + unsigned short uid; + unsigned short mid; +} PACK; + +struct smb_negotiate_response { + struct smb_header h; + unsigned char word_count; + unsigned short dialect_index; + unsigned char security_mode; + unsigned short max_mpx_count; + unsigned short max_number_vcs; + unsigned int max_buffer_size; + unsigned int max_raw_size; + unsigned int session_key; + unsigned int capabilities; + unsigned int system_time_low; + unsigned int system_time_high; + unsigned short server_time_zone; + unsigned char encryption_key_length; + unsigned short byte_count; + char bytes[1]; +} PACK; + +struct andx { + unsigned char command; + unsigned char pad; + unsigned short offset; +} PACK; + +struct smb_setup { + unsigned char word_count; + struct andx andx; + unsigned short max_buffer_size; + unsigned short max_mpx_count; + unsigned short vc_number; + unsigned int session_key; + unsigned short lengths[2]; + unsigned int pad; + unsigned int capabilities; + unsigned short byte_count; + char bytes[1024]; +} PACK; + +struct smb_tree_connect { + unsigned char word_count; + struct andx andx; + unsigned short flags; + unsigned short pw_len; + unsigned short byte_count; + char bytes[1024]; +} PACK; + +struct smb_nt_create { + unsigned char word_count; + struct andx andx; + unsigned char pad; + unsigned short name_length; + unsigned int flags; + unsigned int root_fid; + unsigned int access; + curl_off_t allocation_size; + unsigned int ext_file_attributes; + unsigned int share_access; + unsigned int create_disposition; + unsigned int create_options; + unsigned int impersonation_level; + unsigned char security_flags; + unsigned short byte_count; + char bytes[1024]; +} PACK; + +struct smb_nt_create_response { + struct smb_header h; + unsigned char word_count; + struct andx andx; + unsigned char op_lock_level; + unsigned short fid; + unsigned int create_disposition; + + curl_off_t create_time; + curl_off_t last_access_time; + curl_off_t last_write_time; + curl_off_t last_change_time; + unsigned int ext_file_attributes; + curl_off_t allocation_size; + curl_off_t end_of_file; +} PACK; + +struct smb_read { + unsigned char word_count; + struct andx andx; + unsigned short fid; + unsigned int offset; + unsigned short max_bytes; + unsigned short min_bytes; + unsigned int timeout; + unsigned short remaining; + unsigned int offset_high; + unsigned short byte_count; +} PACK; + +struct smb_write { + struct smb_header h; + unsigned char word_count; + struct andx andx; + unsigned short fid; + unsigned int offset; + unsigned int timeout; + unsigned short write_mode; + unsigned short remaining; + unsigned short pad; + unsigned short data_length; + unsigned short data_offset; + unsigned int offset_high; + unsigned short byte_count; + unsigned char pad2; +} PACK; + +struct smb_close { + unsigned char word_count; + unsigned short fid; + unsigned int last_mtime; + unsigned short byte_count; +} PACK; + +struct smb_tree_disconnect { + unsigned char word_count; + unsigned short byte_count; +} PACK; + +#if defined(_MSC_VER) || defined(__ILEC400__) +# pragma pack(pop) +#endif + +#define MAX_PAYLOAD_SIZE 0x8000 +#define MAX_MESSAGE_SIZE (MAX_PAYLOAD_SIZE + 0x1000) +#define CLIENTNAME "curl" +#define SERVICENAME "?????" + +/* SMB is mostly little endian */ +#if (defined(__BYTE_ORDER__) && __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__) || \ + defined(__OS400__) +static unsigned short smb_swap16(unsigned short x) +{ + return (unsigned short)((x << 8) | ((x >> 8) & 0xff)); +} + +static unsigned int smb_swap32(unsigned int x) +{ + return (x << 24) | ((x << 8) & 0xff0000) | ((x >> 8) & 0xff00) | + ((x >> 24) & 0xff); +} + +static curl_off_t smb_swap64(curl_off_t x) +{ + return ((curl_off_t)smb_swap32((unsigned int)x) << 32) | + smb_swap32((unsigned int)(x >> 32)); +} + +#else +# define smb_swap16(x) (x) +# define smb_swap32(x) (x) +# define smb_swap64(x) (x) +#endif + +static void conn_state(struct Curl_easy *data, struct smb_conn *smbc, + enum smb_conn_state newstate) +{ +#if defined(DEBUGBUILD) && defined(CURLVERBOSE) + /* For debug purposes */ + static const char * const names[] = { + "SMB_NOT_CONNECTED", + "SMB_CONNECTING", + "SMB_NEGOTIATE", + "SMB_SETUP", + "SMB_CONNECTED", + /* LAST */ + }; + + if(smbc->state != newstate) + infof(data, "SMB conn %p state change from %s to %s", + (void *)smbc, names[smbc->state], names[newstate]); +#else + (void)data; +#endif + smbc->state = newstate; +} + +static void request_state(struct Curl_easy *data, + enum smb_req_state newstate) +{ + struct smb_request *req = Curl_meta_get(data, CURL_META_SMB_EASY); + if(req) { +#if defined(DEBUGBUILD) && defined(CURLVERBOSE) + /* For debug purposes */ + static const char * const names[] = { + "SMB_REQUESTING", + "SMB_TREE_CONNECT", + "SMB_OPEN", + "SMB_DOWNLOAD", + "SMB_UPLOAD", + "SMB_CLOSE", + "SMB_TREE_DISCONNECT", + "SMB_DONE", + /* LAST */ + }; + + if(req->state != newstate) + infof(data, "SMB request %p state change from %s to %s", + (void *)req, names[req->state], names[newstate]); +#endif + + req->state = newstate; + } +} + +static void smb_easy_dtor(void *key, size_t klen, void *entry) +{ + struct smb_request *req = entry; + (void)key; + (void)klen; + curlx_safefree(req->path); + curlx_free(req); +} + +static void smb_conn_dtor(void *key, size_t klen, void *entry) +{ + struct smb_conn *smbc = entry; + (void)key; + (void)klen; + curlx_safefree(smbc->share); + curlx_safefree(smbc->domain); + curlx_safefree(smbc->recv_buf); + curlx_safefree(smbc->send_buf); + curlx_free(smbc); +} + +static CURLcode smb_parse_url_path(struct Curl_easy *data, + struct smb_conn *smbc, + struct smb_request *req) +{ + char *path; + char *slash, *s; + CURLcode result; + + /* URL decode the path */ + result = Curl_urldecode(data->state.up.path, 0, &path, NULL, REJECT_CTRL); + if(result) + return result; + + /* Parse the path for the share */ + curlx_safefree(smbc->share); + smbc->share = curlx_strdup((*path == '/' || *path == '\\') + ? path + 1 : path); + curlx_free(path); + if(!smbc->share) + return CURLE_OUT_OF_MEMORY; + + slash = strchr(smbc->share, '/'); + if(!slash) + slash = strchr(smbc->share, '\\'); + + /* The share must be present */ + if(!slash) { + curlx_safefree(smbc->share); + failf(data, "missing share in URL path for SMB"); + return CURLE_URL_MALFORMAT; + } + + /* Parse the path for the file path converting any forward slashes into + backslashes */ + *slash++ = 0; + for(s = slash; *s; s++) { + if(*s == '/') + *s = '\\'; + } + /* keep a copy at easy struct to not share this with connection state */ + req->path = curlx_strdup(slash); + if(!req->path) + return CURLE_OUT_OF_MEMORY; + + return CURLE_OK; +} + +/* this should setup things in the connection, not in the easy + handle */ +static CURLcode smb_setup_connection(struct Curl_easy *data, + struct connectdata *conn) +{ + struct smb_conn *smbc; + struct smb_request *req; + + /* Initialize the connection state */ + smbc = curlx_calloc(1, sizeof(*smbc)); + if(!smbc || + Curl_conn_meta_set(conn, CURL_META_SMB_CONN, smbc, smb_conn_dtor)) + return CURLE_OUT_OF_MEMORY; + + /* Initialize the request state */ + req = curlx_calloc(1, sizeof(*req)); + if(!req || + Curl_meta_set(data, CURL_META_SMB_EASY, req, smb_easy_dtor)) + return CURLE_OUT_OF_MEMORY; + + /* Parse the URL path */ + return smb_parse_url_path(data, smbc, req); +} + +static CURLcode smb_connect(struct Curl_easy *data, bool *done) +{ + struct connectdata *conn = data->conn; + struct smb_conn *smbc = Curl_conn_meta_get(conn, CURL_META_SMB_CONN); + const char *slash; + const char *user = Curl_creds_user(conn->creds); + + (void)done; + if(!smbc) + return CURLE_FAILED_INIT; + + /* Check we have a username and password to authenticate with */ + if(!Curl_creds_has_user(data->state.creds)) + return CURLE_LOGIN_DENIED; + + /* Initialize the connection state */ + smbc->state = SMB_CONNECTING; + smbc->recv_buf = curlx_malloc(MAX_MESSAGE_SIZE); + if(!smbc->recv_buf) + return CURLE_OUT_OF_MEMORY; + smbc->send_buf = curlx_malloc(MAX_MESSAGE_SIZE); + if(!smbc->send_buf) + return CURLE_OUT_OF_MEMORY; + + /* Parse the username, domain, and password */ + slash = strchr(user, '/'); + if(!slash) + slash = strchr(user, '\\'); + + if(slash) { + smbc->user = slash + 1; + smbc->domain = curlx_strdup(user); + if(!smbc->domain) + return CURLE_OUT_OF_MEMORY; + smbc->domain[slash - user] = 0; + } + else { + smbc->user = user; + smbc->domain = curlx_strdup(conn->origin->hostname); + if(!smbc->domain) + return CURLE_OUT_OF_MEMORY; + } + + return CURLE_OK; +} + +static CURLcode smb_recv_message(struct Curl_easy *data, + struct smb_conn *smbc, + void **msg) +{ + char *buf = smbc->recv_buf; + size_t bytes_read; + size_t nbt_size; + size_t msg_size = sizeof(struct smb_header); + size_t len = MAX_MESSAGE_SIZE - smbc->got; + CURLcode result; + + result = Curl_xfer_recv(data, buf + smbc->got, len, &bytes_read); + if(result) + return result; + + if(!bytes_read) + return CURLE_OK; + + smbc->got += bytes_read; + + /* Check for a 32-bit nbt header */ + if(smbc->got < sizeof(unsigned int)) + return CURLE_OK; + + nbt_size = Curl_read16_be((const unsigned char *) + (buf + sizeof(unsigned short))) + + sizeof(unsigned int); + if(nbt_size > MAX_MESSAGE_SIZE) { + failf(data, "too large NetBIOS frame size %zu", nbt_size); + return CURLE_RECV_ERROR; + } + else if(nbt_size < msg_size) { + /* Each SMB message must be at least this large, e.g. 32 bytes */ + failf(data, "too small NetBIOS frame size %zu", nbt_size); + return CURLE_RECV_ERROR; + } + + if(smbc->got < nbt_size) + return CURLE_OK; + + if(nbt_size >= msg_size + 1) { + /* Add the word count */ + msg_size += 1 + (((unsigned char)buf[msg_size]) * sizeof(unsigned short)); + if(nbt_size >= msg_size + sizeof(unsigned short)) { + /* Add the byte count */ + msg_size += sizeof(unsigned short) + + Curl_read16_le((const unsigned char *)&buf[msg_size]); + if(nbt_size < msg_size) + return CURLE_RECV_ERROR; + } + } + + *msg = buf; + + return CURLE_OK; +} + +static void smb_pop_message(struct smb_conn *smbc) +{ + smbc->got = 0; +} + +static void smb_format_message(struct smb_conn *smbc, + struct smb_request *req, + struct smb_header *h, + unsigned char cmd, size_t len) +{ + const unsigned int pid = 0xbad71d; /* made up */ + + memset(h, 0, sizeof(*h)); + h->nbt_length = htons((unsigned short)(sizeof(*h) - sizeof(unsigned int) + + len)); + memcpy((char *)h->magic, "\xffSMB", 4); + h->command = cmd; + h->flags = SMB_FLAGS_CANONICAL_PATHNAMES | SMB_FLAGS_CASELESS_PATHNAMES; + h->flags2 = smb_swap16(SMB_FLAGS2_IS_LONG_NAME | SMB_FLAGS2_KNOWS_LONG_NAME); + h->uid = smb_swap16(smbc->uid); + h->tid = smb_swap16(req->tid); + h->pid_high = smb_swap16((unsigned short)(pid >> 16)); + h->pid = smb_swap16((unsigned short)pid); +} + +static CURLcode smb_send(struct Curl_easy *data, struct smb_conn *smbc, + size_t len, size_t upload_size) +{ + size_t bytes_written; + CURLcode result; + + result = Curl_xfer_send(data, smbc->send_buf, len, FALSE, &bytes_written); + if(result) + return result; + + if(bytes_written != len) { + smbc->send_size = len; + smbc->sent = bytes_written; + } + + smbc->upload_size = upload_size; + + return CURLE_OK; +} + +static CURLcode smb_flush(struct Curl_easy *data, struct smb_conn *smbc) +{ + size_t bytes_written; + size_t len = smbc->send_size - smbc->sent; + CURLcode result; + + if(!smbc->send_size) + return CURLE_OK; + + result = Curl_xfer_send(data, smbc->send_buf + smbc->sent, len, FALSE, + &bytes_written); + if(result) + return result; + + if(bytes_written != len) + smbc->sent += bytes_written; + else + smbc->send_size = 0; + + return CURLE_OK; +} + +static CURLcode smb_send_message(struct Curl_easy *data, + struct smb_conn *smbc, + struct smb_request *req, + unsigned char cmd, + const void *msg, size_t msg_len) +{ + if((MAX_MESSAGE_SIZE - sizeof(struct smb_header)) < msg_len) { + DEBUGASSERT(0); + return CURLE_SEND_ERROR; + } + smb_format_message(smbc, req, (struct smb_header *)smbc->send_buf, + cmd, msg_len); + memcpy(smbc->send_buf + sizeof(struct smb_header), msg, msg_len); + + return smb_send(data, smbc, sizeof(struct smb_header) + msg_len, 0); +} + +static CURLcode smb_send_negotiate(struct Curl_easy *data, + struct smb_conn *smbc, + struct smb_request *req) +{ + const char *msg = "\x00\x0c\x00\x02NT LM 0.12"; + + return smb_send_message(data, smbc, req, SMB_COM_NEGOTIATE, msg, 15); +} + +static CURLcode smb_send_setup(struct Curl_easy *data) +{ + struct connectdata *conn = data->conn; + struct smb_conn *smbc = Curl_conn_meta_get(conn, CURL_META_SMB_CONN); + struct smb_request *req = Curl_meta_get(data, CURL_META_SMB_EASY); + struct smb_setup msg; + char *p = msg.bytes; + unsigned char lm_hash[21]; + unsigned char lm[24]; + unsigned char nt_hash[21]; + unsigned char nt[24]; + size_t byte_count; + const char *passwd = Curl_creds_passwd(conn->creds); + + if(!smbc || !req) + return CURLE_FAILED_INIT; + + byte_count = sizeof(lm) + sizeof(nt) + + strlen(smbc->user) + strlen(smbc->domain) + + strlen(CURL_OS) + strlen(CLIENTNAME) + 4; /* 4 null chars */ + if(byte_count > sizeof(msg.bytes)) + return CURLE_FILESIZE_EXCEEDED; + + Curl_ntlm_core_mk_lm_hash(passwd, lm_hash); + Curl_ntlm_core_lm_resp(lm_hash, smbc->challenge, lm); + Curl_ntlm_core_mk_nt_hash(passwd, nt_hash); + Curl_ntlm_core_lm_resp(nt_hash, smbc->challenge, nt); + + memset(&msg, 0, sizeof(msg) - sizeof(msg.bytes)); + msg.word_count = SMB_WC_SETUP_ANDX; + msg.andx.command = SMB_COM_NO_ANDX_COMMAND; + msg.max_buffer_size = smb_swap16(MAX_MESSAGE_SIZE); + msg.max_mpx_count = smb_swap16(1); + msg.vc_number = smb_swap16(1); + msg.session_key = smb_swap32(smbc->session_key); + msg.capabilities = smb_swap32(SMB_CAP_LARGE_FILES); + msg.lengths[0] = smb_swap16(sizeof(lm)); + msg.lengths[1] = smb_swap16(sizeof(nt)); + memcpy(p, lm, sizeof(lm)); + p += sizeof(lm); + memcpy(p, nt, sizeof(nt)); + p += sizeof(nt); + p += curl_msnprintf(p, byte_count - sizeof(nt) - sizeof(lm), + "%s%c" /* user */ + "%s%c" /* domain */ + "%s%c" /* OS */ + "%s", /* client name */ + smbc->user, 0, smbc->domain, 0, CURL_OS, 0, CLIENTNAME); + p++; /* count the final null-termination */ + DEBUGASSERT(byte_count == (size_t)(p - msg.bytes)); + msg.byte_count = smb_swap16((unsigned short)byte_count); + + return smb_send_message(data, smbc, req, SMB_COM_SETUP_ANDX, &msg, + sizeof(msg) - sizeof(msg.bytes) + byte_count); +} + +static CURLcode smb_send_tree_connect(struct Curl_easy *data, + struct smb_conn *smbc, + struct smb_request *req) +{ + struct smb_tree_connect msg; + struct connectdata *conn = data->conn; + char *p = msg.bytes; + const size_t byte_count = strlen(conn->origin->hostname) + + strlen(smbc->share) + + strlen(SERVICENAME) + 5; /* 2 nulls and 3 backslashes */ + + if(byte_count > sizeof(msg.bytes)) + return CURLE_FILESIZE_EXCEEDED; + + memset(&msg, 0, sizeof(msg) - sizeof(msg.bytes)); + msg.word_count = SMB_WC_TREE_CONNECT_ANDX; + msg.andx.command = SMB_COM_NO_ANDX_COMMAND; + msg.pw_len = 0; + + p += curl_msnprintf(p, byte_count, + "\\\\%s\\" /* hostname */ + "%s%c" /* share */ + "%s", /* service */ + conn->origin->hostname, smbc->share, 0, SERVICENAME); + p++; /* count the final null-termination */ + DEBUGASSERT(byte_count == (size_t)(p - msg.bytes)); + msg.byte_count = smb_swap16((unsigned short)byte_count); + + return smb_send_message(data, smbc, req, SMB_COM_TREE_CONNECT_ANDX, &msg, + sizeof(msg) - sizeof(msg.bytes) + byte_count); +} + +static CURLcode smb_send_open(struct Curl_easy *data, + struct smb_conn *smbc, + struct smb_request *req) +{ + struct smb_nt_create msg; + const size_t byte_count = strlen(req->path) + 1; + + if(byte_count > sizeof(msg.bytes)) + return CURLE_FILESIZE_EXCEEDED; + + memset(&msg, 0, sizeof(msg) - sizeof(msg.bytes)); + msg.word_count = SMB_WC_NT_CREATE_ANDX; + msg.andx.command = SMB_COM_NO_ANDX_COMMAND; + msg.name_length = smb_swap16((unsigned short)(byte_count - 1)); + msg.share_access = smb_swap32(SMB_FILE_SHARE_ALL); + if(data->state.upload) { + msg.access = smb_swap32(SMB_GENERIC_READ | SMB_GENERIC_WRITE); + msg.create_disposition = smb_swap32(SMB_FILE_OVERWRITE_IF); + } + else { + msg.access = smb_swap32(SMB_GENERIC_READ); + msg.create_disposition = smb_swap32(SMB_FILE_OPEN); + } + msg.byte_count = smb_swap16((unsigned short)byte_count); + curlx_strcopy(msg.bytes, sizeof(msg.bytes), req->path, byte_count - 1); + + return smb_send_message(data, smbc, req, SMB_COM_NT_CREATE_ANDX, &msg, + sizeof(msg) - sizeof(msg.bytes) + byte_count); +} + +static CURLcode smb_send_close(struct Curl_easy *data, + struct smb_conn *smbc, + struct smb_request *req) +{ + struct smb_close msg; + + memset(&msg, 0, sizeof(msg)); + msg.word_count = SMB_WC_CLOSE; + msg.fid = smb_swap16(req->fid); + + return smb_send_message(data, smbc, req, SMB_COM_CLOSE, &msg, sizeof(msg)); +} + +static CURLcode smb_send_tree_disconnect(struct Curl_easy *data, + struct smb_conn *smbc, + struct smb_request *req) +{ + struct smb_tree_disconnect msg; + memset(&msg, 0, sizeof(msg)); + return smb_send_message(data, smbc, req, SMB_COM_TREE_DISCONNECT, + &msg, sizeof(msg)); +} + +static CURLcode smb_send_read(struct Curl_easy *data, + struct smb_conn *smbc, + struct smb_request *req) +{ + curl_off_t offset = data->req.offset; + struct smb_read msg; + + memset(&msg, 0, sizeof(msg)); + msg.word_count = SMB_WC_READ_ANDX; + msg.andx.command = SMB_COM_NO_ANDX_COMMAND; + msg.fid = smb_swap16(req->fid); + msg.offset = smb_swap32((unsigned int)offset); + msg.offset_high = smb_swap32((unsigned int)(offset >> 32)); + msg.min_bytes = smb_swap16(MAX_PAYLOAD_SIZE); + msg.max_bytes = smb_swap16(MAX_PAYLOAD_SIZE); + + return smb_send_message(data, smbc, req, SMB_COM_READ_ANDX, + &msg, sizeof(msg)); +} + +static CURLcode smb_send_write(struct Curl_easy *data, + struct smb_conn *smbc, + struct smb_request *req) +{ + struct smb_write *msg; + curl_off_t offset = data->req.offset; + curl_off_t upload_size = data->req.size - data->req.bytecount; + + msg = (struct smb_write *)smbc->send_buf; + if(upload_size >= MAX_PAYLOAD_SIZE - 1) /* There is one byte of padding */ + upload_size = MAX_PAYLOAD_SIZE - 1; + + memset(msg, 0, sizeof(*msg)); + msg->word_count = SMB_WC_WRITE_ANDX; + msg->andx.command = SMB_COM_NO_ANDX_COMMAND; + msg->fid = smb_swap16(req->fid); + msg->offset = smb_swap32((unsigned int)offset); + msg->offset_high = smb_swap32((unsigned int)(offset >> 32)); + msg->data_length = smb_swap16((unsigned short)upload_size); + msg->data_offset = smb_swap16(sizeof(*msg) - sizeof(unsigned int)); + msg->byte_count = smb_swap16((unsigned short)(upload_size + 1)); + + smb_format_message(smbc, req, &msg->h, SMB_COM_WRITE_ANDX, + sizeof(*msg) - sizeof(msg->h) + (size_t)upload_size); + + return smb_send(data, smbc, sizeof(*msg), (size_t)upload_size); +} + +static CURLcode smb_send_and_recv(struct Curl_easy *data, + struct smb_conn *smbc, void **msg) +{ + CURLcode result; + *msg = NULL; /* if it returns early */ + + /* Check if there is data in the transfer buffer */ + if(!smbc->send_size && smbc->upload_size) { + size_t nread = smbc->upload_size > (size_t)MAX_MESSAGE_SIZE ? + (size_t)MAX_MESSAGE_SIZE : smbc->upload_size; + bool eos; + + result = Curl_client_read(data, smbc->send_buf, nread, &nread, &eos); + if(result && result != CURLE_AGAIN) + return result; + if(!nread) + return CURLE_OK; + + smbc->upload_size -= nread; + smbc->send_size = nread; + smbc->sent = 0; + } + + /* Check if there is data to send */ + if(smbc->send_size) { + result = smb_flush(data, smbc); + if(result) + return result; + } + + /* Check if there is still data to be sent */ + if(smbc->send_size || smbc->upload_size) + return CURLE_AGAIN; + + return smb_recv_message(data, smbc, msg); +} + +static CURLcode smb_connection_state(struct Curl_easy *data, bool *done) +{ + struct connectdata *conn = data->conn; + struct smb_conn *smbc = Curl_conn_meta_get(conn, CURL_META_SMB_CONN); + struct smb_request *req = Curl_meta_get(data, CURL_META_SMB_EASY); + struct smb_negotiate_response *nrsp; + struct smb_header *h; + CURLcode result; + void *msg = NULL; + + if(!smbc || !req) + return CURLE_FAILED_INIT; + + if(smbc->state == SMB_CONNECTING) { +#ifdef USE_SSL + if(Curl_conn_is_ssl(conn, FIRSTSOCKET)) { + bool ssl_done = FALSE; + result = Curl_conn_connect(data, FIRSTSOCKET, FALSE, &ssl_done); + if(result && result != CURLE_AGAIN) + return result; + if(!ssl_done) + return CURLE_OK; + } +#endif + + result = smb_send_negotiate(data, smbc, req); + if(result) { + connclose(conn, "SMB: failed to send negotiate message"); + return result; + } + + conn_state(data, smbc, SMB_NEGOTIATE); + } + + /* Send the previous message and check for a response */ + result = smb_send_and_recv(data, smbc, &msg); + if(result && result != CURLE_AGAIN) { + connclose(conn, "SMB: failed to communicate"); + return result; + } + + if(!msg) + return CURLE_OK; + + h = msg; + + switch(smbc->state) { + case SMB_NEGOTIATE: + if((smbc->got < sizeof(*nrsp) + sizeof(smbc->challenge) - 1) || + h->status) { + connclose(conn, "SMB: negotiation failed"); + return CURLE_COULDNT_CONNECT; + } + nrsp = msg; +#if defined(__GNUC__) && __GNUC__ >= 13 +#pragma GCC diagnostic push +/* error: 'memcpy' offset [74, 80] from the object at '' is out of + the bounds of referenced subobject 'bytes' with type 'char[1]' */ +#pragma GCC diagnostic ignored "-Warray-bounds" +#endif + memcpy(smbc->challenge, nrsp->bytes, sizeof(smbc->challenge)); +#if defined(__GNUC__) && __GNUC__ >= 13 +#pragma GCC diagnostic pop +#endif + smbc->session_key = smb_swap32(nrsp->session_key); + result = smb_send_setup(data); + if(result) { + connclose(conn, "SMB: failed to send setup message"); + return result; + } + conn_state(data, smbc, SMB_SETUP); + break; + + case SMB_SETUP: + if(h->status) { + connclose(conn, "SMB: authentication failed"); + return CURLE_LOGIN_DENIED; + } + smbc->uid = smb_swap16(h->uid); + conn_state(data, smbc, SMB_CONNECTED); + *done = TRUE; + break; + + default: + smb_pop_message(smbc); + return CURLE_OK; /* ignore */ + } + + smb_pop_message(smbc); + + return CURLE_OK; +} + +/* + * Convert a timestamp from the Windows world (100 nsec units from 1 Jan 1601) + * to POSIX time. Cap the output to fit within a time_t. + */ +static void get_posix_time(time_t *out, curl_off_t timestamp) +{ + if(timestamp >= (curl_off_t)116444736000000000) { + timestamp -= (curl_off_t)116444736000000000; + timestamp /= 10000000; +#if SIZEOF_TIME_T < SIZEOF_CURL_OFF_T + if(timestamp > TIME_T_MAX) + *out = TIME_T_MAX; + else if(timestamp < TIME_T_MIN) + *out = TIME_T_MIN; + else +#endif + *out = (time_t)timestamp; + } + else + *out = 0; +} + +static CURLcode smb_request_state(struct Curl_easy *data, bool *done) +{ + struct connectdata *conn = data->conn; + struct smb_conn *smbc = Curl_conn_meta_get(conn, CURL_META_SMB_CONN); + struct smb_request *req = Curl_meta_get(data, CURL_META_SMB_EASY); + struct smb_header *h; + enum smb_req_state next_state = SMB_DONE; + size_t len; + size_t off; + CURLcode result; + void *msg = NULL; + const struct smb_nt_create_response *smb_m; + + if(!smbc || !req) + return CURLE_FAILED_INIT; + + if(data->state.upload && (data->state.infilesize < 0)) { + failf(data, "SMB upload needs to know the size up front"); + return CURLE_SEND_ERROR; + } + + /* Start the request */ + if(req->state == SMB_REQUESTING) { + result = smb_send_tree_connect(data, smbc, req); + if(result) { + connclose(conn, "SMB: failed to send tree connect message"); + return result; + } + + request_state(data, SMB_TREE_CONNECT); + } + + /* Send the previous message and check for a response */ + result = smb_send_and_recv(data, smbc, &msg); + if(result && result != CURLE_AGAIN) { + connclose(conn, "SMB: failed to communicate"); + return result; + } + + if(!msg) + return CURLE_OK; + + h = msg; + + switch(req->state) { + case SMB_TREE_CONNECT: + if(h->status) { + req->result = CURLE_REMOTE_FILE_NOT_FOUND; + if(h->status == smb_swap32(SMB_ERR_NOACCESS)) + req->result = CURLE_REMOTE_ACCESS_DENIED; + break; + } + req->tid = smb_swap16(h->tid); + next_state = SMB_OPEN; + break; + + case SMB_OPEN: + if(h->status || smbc->got < sizeof(struct smb_nt_create_response)) { + req->result = CURLE_REMOTE_FILE_NOT_FOUND; + if(h->status == smb_swap32(SMB_ERR_NOACCESS)) + req->result = CURLE_REMOTE_ACCESS_DENIED; + next_state = SMB_TREE_DISCONNECT; + break; + } + smb_m = (const struct smb_nt_create_response *)msg; + req->fid = smb_swap16(smb_m->fid); + data->req.offset = 0; + if(data->state.upload) { + data->req.size = data->state.infilesize; + Curl_pgrsSetUploadSize(data, data->req.size); + next_state = SMB_UPLOAD; + } + else { + data->req.size = smb_swap64(smb_m->end_of_file); + if(data->req.size < 0) { + req->result = CURLE_WEIRD_SERVER_REPLY; + next_state = SMB_CLOSE; + } + else { + Curl_pgrsSetDownloadSize(data, data->req.size); + if(data->set.get_filetime) + get_posix_time(&data->info.filetime, smb_m->last_change_time); + next_state = SMB_DOWNLOAD; + } + } + break; + + case SMB_DOWNLOAD: + if(h->status || smbc->got < sizeof(struct smb_header) + 15) { + req->result = CURLE_RECV_ERROR; + next_state = SMB_CLOSE; + break; + } + len = Curl_read16_le((const unsigned char *)msg + + sizeof(struct smb_header) + 11); + off = Curl_read16_le((const unsigned char *)msg + + sizeof(struct smb_header) + 13); + if(len > 0) { + if(off + sizeof(unsigned int) + len > smbc->got) { + failf(data, "Invalid input packet"); + result = CURLE_RECV_ERROR; + } + else + result = Curl_client_write(data, CLIENTWRITE_BODY, + (char *)msg + off + sizeof(unsigned int), + len); + if(result) { + req->result = result; + next_state = SMB_CLOSE; + break; + } + } + data->req.offset += len; + next_state = (len < MAX_PAYLOAD_SIZE) ? SMB_CLOSE : SMB_DOWNLOAD; + break; + + case SMB_UPLOAD: + if(h->status || smbc->got < sizeof(struct smb_header) + 7) { + req->result = CURLE_UPLOAD_FAILED; + next_state = SMB_CLOSE; + break; + } + len = Curl_read16_le((const unsigned char *)msg + + sizeof(struct smb_header) + 5); + data->req.bytecount += len; + data->req.offset += len; + Curl_pgrs_upload_inc(data, len); + if(data->req.bytecount >= data->req.size) + next_state = SMB_CLOSE; + else + next_state = SMB_UPLOAD; + break; + + case SMB_CLOSE: + /* We do not care if the close failed, proceed to tree disconnect anyway */ + next_state = SMB_TREE_DISCONNECT; + break; + + case SMB_TREE_DISCONNECT: + next_state = SMB_DONE; + break; + + default: + smb_pop_message(smbc); + return CURLE_OK; /* ignore */ + } + + smb_pop_message(smbc); + + switch(next_state) { + case SMB_OPEN: + result = smb_send_open(data, smbc, req); + break; + + case SMB_DOWNLOAD: + result = smb_send_read(data, smbc, req); + break; + + case SMB_UPLOAD: + result = smb_send_write(data, smbc, req); + break; + + case SMB_CLOSE: + result = smb_send_close(data, smbc, req); + break; + + case SMB_TREE_DISCONNECT: + result = smb_send_tree_disconnect(data, smbc, req); + break; + + case SMB_DONE: + result = req->result; + *done = TRUE; + break; + + default: + break; + } + + if(result) { + connclose(conn, "SMB: failed to send message"); + return result; + } + + request_state(data, next_state); + + return CURLE_OK; +} + +static CURLcode smb_pollset(struct Curl_easy *data, + struct easy_pollset *ps) +{ + return Curl_pollset_add_inout(data, ps, data->conn->sock[FIRSTSOCKET]); +} + +static CURLcode smb_do(struct Curl_easy *data, bool *done) +{ + struct connectdata *conn = data->conn; + struct smb_conn *smbc = Curl_conn_meta_get(conn, CURL_META_SMB_CONN); + + *done = FALSE; + if(!smbc) + return CURLE_FAILED_INIT; + if(smbc->share) + return CURLE_OK; + return CURLE_URL_MALFORMAT; +} + +/* + * SMB handler interface + */ +const struct Curl_protocol Curl_protocol_smb = { + smb_setup_connection, /* setup_connection */ + smb_do, /* do_it */ + ZERO_NULL, /* done */ + ZERO_NULL, /* do_more */ + smb_connect, /* connect_it */ + smb_connection_state, /* connecting */ + smb_request_state, /* doing */ + smb_pollset, /* proto_pollset */ + smb_pollset, /* doing_pollset */ + ZERO_NULL, /* domore_pollset */ + ZERO_NULL, /* perform_pollset */ + ZERO_NULL, /* disconnect */ + ZERO_NULL, /* write_resp */ + ZERO_NULL, /* write_resp_hd */ + ZERO_NULL, /* connection_is_dead */ + ZERO_NULL, /* attach connection */ + ZERO_NULL, /* follow */ +}; + +#endif /* CURL_ENABLE_SMB && USE_CURL_NTLM_CORE */ diff --git a/3rdparty/curl-8.21.0/lib/smb.h b/3rdparty/curl-8.21.0/lib/smb.h new file mode 100644 index 0000000000..5a92ad13db --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/smb.h @@ -0,0 +1,31 @@ +#ifndef HEADER_CURL_SMB_H +#define HEADER_CURL_SMB_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Bill Nagel , Exacq Technologies + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#if defined(CURL_ENABLE_SMB) && defined(USE_CURL_NTLM_CORE) +extern const struct Curl_protocol Curl_protocol_smb; +#endif + +#endif /* HEADER_CURL_SMB_H */ diff --git a/3rdparty/curl-8.21.0/lib/smtp.c b/3rdparty/curl-8.21.0/lib/smtp.c new file mode 100644 index 0000000000..2283f5e87d --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/smtp.c @@ -0,0 +1,2009 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + * RFC1870 SMTP Service Extension for Message Size + * RFC2195 CRAM-MD5 authentication + * RFC2831 DIGEST-MD5 authentication + * RFC3207 SMTP over TLS + * RFC4422 Simple Authentication and Security Layer (SASL) + * RFC4616 PLAIN authentication + * RFC4752 The Kerberos V5 ("GSSAPI") SASL Mechanism + * RFC4954 SMTP Authentication + * RFC5321 SMTP protocol + * RFC5890 Internationalized Domain Names for Applications (IDNA) + * RFC6531 SMTP Extension for Internationalized Email + * RFC6532 Internationalized Email Headers + * RFC6749 OAuth 2.0 Authorization Framework + * RFC8314 Use of TLS for Email Submission and Access + * Draft SMTP URL Interface + * Draft LOGIN SASL Mechanism + * + ***************************************************************************/ +#include "curl_setup.h" +#include "urldata.h" +#include "smtp.h" + +#ifndef CURL_DISABLE_SMTP + +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_ARPA_INET_H +#include +#endif +#ifdef HAVE_NETDB_H +#include +#endif +#ifdef __VMS +#include +#include +#endif + +#include "sendf.h" +#include "curl_trc.h" +#include "hostip.h" +#include "progress.h" +#include "transfer.h" +#include "escape.h" +#include "pingpong.h" +#include "mime.h" +#include "vtls/vtls.h" +#include "cfilters.h" +#include "connect.h" +#include "select.h" +#include "url.h" +#include "curl_gethostname.h" +#include "bufref.h" +#include "curl_sasl.h" +#include "idn.h" +#include "curlx/strparse.h" + +/* meta key for storing protocol meta at easy handle */ +#define CURL_META_SMTP_EASY "meta:proto:smtp:easy" +/* meta key for storing protocol meta at connection */ +#define CURL_META_SMTP_CONN "meta:proto:smtp:conn" + +/**************************************************************************** + * SMTP unique setup + ***************************************************************************/ +typedef enum { + SMTP_STOP, /* do nothing state, stops the state machine */ + SMTP_SERVERGREET, /* waiting for the initial greeting immediately after + a connect */ + SMTP_EHLO, + SMTP_HELO, + SMTP_STARTTLS, + SMTP_UPGRADETLS, /* asynchronously upgrade the connection to SSL/TLS + (multi mode only) */ + SMTP_AUTH, + SMTP_COMMAND, /* VRFY, EXPN, NOOP, RSET and HELP */ + SMTP_MAIL, /* MAIL FROM */ + SMTP_RCPT, /* RCPT TO */ + SMTP_DATA, + SMTP_POSTDATA, + SMTP_QUIT, + SMTP_LAST /* never used */ +} smtpstate; + +/* smtp_conn is used for struct connection-oriented data in the connectdata + struct */ +struct smtp_conn { + struct pingpong pp; + struct SASL sasl; /* SASL-related storage */ + smtpstate state; /* Always use smtp.c:state() to change state! */ + char *domain; /* Client address/name to send in the EHLO */ + BIT(ssldone); /* Is connect() over SSL done? */ + BIT(tls_supported); /* StartTLS capability supported by server */ + BIT(size_supported); /* If server supports SIZE extension according to + RFC 1870 */ + BIT(utf8_supported); /* If server supports SMTPUTF8 extension according + to RFC 6531 */ + BIT(auth_supported); /* AUTH capability supported by server */ +}; + +/* This SMTP struct is used in the Curl_easy. All SMTP data that is + connection-oriented must be in smtp_conn to properly deal with the fact that + perhaps the Curl_easy is changed between the times the connection is + used. */ +struct SMTP { + curl_pp_transfer transfer; + char *custom; /* Custom Request */ + struct curl_slist *rcpt; /* Recipient list */ + int rcpt_last_error; /* The last error received for RCPT TO command */ + size_t eob; /* Number of bytes of the EOB (End Of Body) that + have been received so far */ + BIT(rcpt_had_ok); /* Whether any of RCPT TO commands (depends on + total number of recipients) succeeded so far */ + BIT(trailing_crlf); /* Specifies if the trailing CRLF is present */ +}; + +/*********************************************************************** + * + * smtp_parse_url_options() + * + * Parse the URL login options. + */ +static CURLcode smtp_parse_url_options(struct connectdata *conn, + struct smtp_conn *smtpc) +{ + CURLcode result = CURLE_OK; + const char *ptr = conn->options; + + while(!result && ptr && *ptr) { + const char *key = ptr; + const char *value; + + while(*ptr && *ptr != '=') + ptr++; + + value = ptr + 1; + + while(*ptr && *ptr != ';') + ptr++; + + if(curl_strnequal(key, "AUTH=", 5)) + result = Curl_sasl_parse_url_auth_option(&smtpc->sasl, + value, ptr - value); + else + result = CURLE_URL_MALFORMAT; + + if(*ptr == ';') + ptr++; + } + + return result; +} + +/*********************************************************************** + * + * smtp_parse_url_path() + * + * Parse the URL path into separate path components. + */ +static CURLcode smtp_parse_url_path(struct Curl_easy *data, + struct smtp_conn *smtpc) +{ + /* The SMTP struct is already initialized in smtp_connect() */ + const char *path = &data->state.up.path[1]; /* skip leading path */ + char localhost[HOSTNAME_MAX + 1]; + + /* Calculate the path if necessary */ + if(!*path) { + if(!Curl_gethostname(localhost, sizeof(localhost))) + path = localhost; + else + path = "localhost"; + } + + /* URL decode the path and use it as the domain in our EHLO */ + return Curl_urldecode(path, 0, &smtpc->domain, NULL, REJECT_CTRL); +} + +/*********************************************************************** + * + * smtp_parse_custom_request() + * + * Parse the custom request. + */ +static CURLcode smtp_parse_custom_request(struct Curl_easy *data, + struct SMTP *smtp) +{ + CURLcode result = CURLE_OK; + const char *custom = data->set.str[STRING_CUSTOMREQUEST]; + + /* URL decode the custom request */ + if(custom) + result = Curl_urldecode(custom, 0, &smtp->custom, NULL, REJECT_CTRL); + + return result; +} + +/*********************************************************************** + * + * smtp_parse_address() + * + * Parse the fully qualified mailbox address into a local address part and the + * hostname, converting the hostname to an IDN A-label, as per RFC-5890, if + * necessary. + * + * Parameters: + * + * fqma [in] - The fully qualified mailbox address (which may or + * may not contain UTF-8 characters). + * address [in/out] - A new allocated buffer which holds the local + * address part of the mailbox. This buffer must be + * free'ed by the caller. + * host [in/out] - The hostname structure that holds the original, + * and optionally encoded, hostname. + * Curl_free_idnconverted_hostname() must be called + * once the caller has finished with the structure. + * + * Returns CURLE_OK on success. + * + * Notes: + * + * Should a UTF-8 hostname require conversion to IDN ACE and we cannot honor + * that conversion then we shall return success. This allow the caller to send + * the data to the server as a U-label (as per RFC-6531 sect. 3.2). + * + * If an mailbox '@' separator cannot be located then the mailbox is considered + * to be either a local mailbox or an invalid mailbox (depending on what the + * calling function deems it to be) then the input will be returned in + * the address part with the hostname being NULL. + */ +static CURLcode smtp_parse_address(const char *fqma, char **address, + struct hostname *host, const char **suffix) +{ + CURLcode result = CURLE_OK; + size_t length; + char *addressend; + + /* Duplicate the fully qualified email address so we can manipulate it, + ensuring it does not contain the delimiters if specified */ + char *dup = curlx_strdup(fqma[0] == '<' ? fqma + 1 : fqma); + if(!dup) + return CURLE_OUT_OF_MEMORY; + + if(fqma[0] != '<') { + length = strlen(dup); + if(length) { + if(dup[length - 1] == '>') + dup[length - 1] = '\0'; + } + } + else { + addressend = strrchr(dup, '>'); + if(addressend) { + *addressend = '\0'; + *suffix = addressend + 1; + } + } + + /* Extract the hostname from the address (if we can) */ + host->name = strpbrk(dup, "@"); + if(host->name) { + *host->name = '\0'; + host->name = host->name + 1; + + /* Attempt to convert the hostname to IDN ACE */ + (void)Curl_idnconvert_hostname(host); + + /* If Curl_idnconvert_hostname() fails then we shall attempt to continue + and send the hostname using UTF-8 rather than as 7-bit ACE (which is + our preference) */ + } + + /* Extract the local address from the mailbox */ + *address = dup; + + return result; +} + +struct cr_eob_ctx { + struct Curl_creader super; + struct bufq buf; + size_t n_eob; /* how many EOB bytes we matched so far */ + size_t eob; /* Number of bytes of the EOB (End Of Body) that + have been received so far */ + BIT(read_eos); /* we read an EOS from the next reader */ + BIT(processed_eos); /* we read and processed an EOS */ + BIT(eos); /* we have returned an EOS */ +}; + +static CURLcode cr_eob_init(struct Curl_easy *data, + struct Curl_creader *reader) +{ + struct cr_eob_ctx *ctx = reader->ctx; + (void)data; + /* The first char we read is the first on a line, as if we had + * read CRLF before */ + ctx->n_eob = 2; + Curl_bufq_init2(&ctx->buf, (16 * 1024), 1, BUFQ_OPT_SOFT_LIMIT); + return CURLE_OK; +} + +static void cr_eob_close(struct Curl_easy *data, struct Curl_creader *reader) +{ + struct cr_eob_ctx *ctx = reader->ctx; + (void)data; + Curl_bufq_free(&ctx->buf); +} + +/* this is the 5-bytes End-Of-Body marker for SMTP */ +#define SMTP_EOB "\r\n.\r\n" +#define SMTP_EOB_FIND_LEN 3 + +/* client reader doing SMTP End-Of-Body escaping. */ +static CURLcode cr_eob_read(struct Curl_easy *data, + struct Curl_creader *reader, + char *buf, size_t blen, + size_t *pnread, bool *peos) +{ + struct cr_eob_ctx *ctx = reader->ctx; + CURLcode result = CURLE_OK; + size_t nread, i, start, n; + bool eos; + + if(!ctx->read_eos && Curl_bufq_is_empty(&ctx->buf)) { + /* Get more and convert it when needed */ + result = Curl_creader_read(data, reader->next, buf, blen, &nread, &eos); + CURL_TRC_SMTP(data, "cr_eob_read, next_read(len=%zu) -> %d, %zu eos=%d", + blen, (int)result, nread, eos); + if(result) + return result; + + ctx->read_eos = eos; + if(nread) { + if(!ctx->n_eob && !memchr(buf, SMTP_EOB[0], nread)) { + /* not in the middle of a match, no EOB start found, pass */ + *pnread = nread; + *peos = FALSE; + return CURLE_OK; + } + /* scan for EOB (continuation) and convert */ + for(i = start = 0; i < nread; ++i) { + if(ctx->n_eob >= SMTP_EOB_FIND_LEN) { + /* matched the EOB prefix and seeing additional char, add '.' */ + result = Curl_bufq_cwrite(&ctx->buf, buf + start, i - start, &n); + if(result) + return result; + result = Curl_bufq_cwrite(&ctx->buf, ".", 1, &n); + if(result) + return result; + ctx->n_eob = 0; + start = i; + if(data->state.infilesize > 0) + data->state.infilesize++; + } + + if(buf[i] != SMTP_EOB[ctx->n_eob]) + ctx->n_eob = 0; + + if(buf[i] == SMTP_EOB[ctx->n_eob]) { + /* matching another char of the EOB */ + ++ctx->n_eob; + } + } + + /* add any remainder to buf */ + if(start < nread) { + result = Curl_bufq_cwrite(&ctx->buf, buf + start, nread - start, &n); + if(result) + return result; + } + } + } + + *peos = FALSE; + + if(ctx->read_eos && !ctx->processed_eos) { + /* if we last matched a CRLF or if the data was empty, add ".\r\n" + * to end the body. If we sent something and it did not end with "\r\n", + * add "\r\n.\r\n" to end the body */ + const char *eob = SMTP_EOB; + CURL_TRC_SMTP(data, "auto-ending mail body with '\\r\\n.\\r\\n'"); + switch(ctx->n_eob) { + case 2: + /* seen a CRLF at the end, add the remainder */ + eob = &SMTP_EOB[2]; + break; + case 3: + /* ended with '\r\n.', we should escape the last '.' */ + eob = "." SMTP_EOB; + break; + default: + break; + } + result = Curl_bufq_cwrite(&ctx->buf, eob, strlen(eob), &n); + if(result) + return result; + ctx->processed_eos = TRUE; + } + + if(!Curl_bufq_is_empty(&ctx->buf)) { + result = Curl_bufq_cread(&ctx->buf, buf, blen, pnread); + } + else + *pnread = 0; + + if(ctx->read_eos && Curl_bufq_is_empty(&ctx->buf)) { + /* no more data, read all, done. */ + CURL_TRC_SMTP(data, "mail body complete, returning EOS"); + ctx->eos = TRUE; + } + *peos = (bool)ctx->eos; + DEBUGF(infof(data, "cr_eob_read(%zu) -> %d, %zu, %d", + blen, (int)result, *pnread, *peos)); + return result; +} + +static curl_off_t cr_eob_total_length(struct Curl_easy *data, + struct Curl_creader *reader) +{ + /* this reader changes length depending on input */ + (void)data; + (void)reader; + return -1; +} + +static const struct Curl_crtype cr_eob = { + "cr-smtp-eob", + cr_eob_init, + cr_eob_read, + cr_eob_close, + Curl_creader_def_needs_rewind, + cr_eob_total_length, + Curl_creader_def_resume_from, + Curl_creader_def_cntrl, + Curl_creader_def_is_paused, + Curl_creader_def_done, + sizeof(struct cr_eob_ctx) +}; + +static CURLcode cr_eob_add(struct Curl_easy *data) +{ + struct Curl_creader *reader = NULL; + CURLcode result; + + result = Curl_creader_create(&reader, data, &cr_eob, CURL_CR_CONTENT_ENCODE); + if(!result) + result = Curl_creader_add(data, reader); + + if(result && reader) + Curl_creader_free(data, reader); + return result; +} + +/*********************************************************************** + * + * smtp_endofresp() + * + * Checks for an ending SMTP status code at the start of the given string, but + * also detects various capabilities from the EHLO response including the + * supported authentication mechanisms. + */ +static bool smtp_endofresp(struct Curl_easy *data, struct connectdata *conn, + const char *line, size_t len, int *resp) +{ + struct smtp_conn *smtpc = Curl_conn_meta_get(conn, CURL_META_SMTP_CONN); + bool end = FALSE; + (void)data; + + DEBUGASSERT(smtpc); + if(!smtpc) + return FALSE; + + /* Nothing for us */ + if(len < 4 || !ISDIGIT(line[0]) || !ISDIGIT(line[1]) || !ISDIGIT(line[2])) + return FALSE; + + /* Do we have a command response? This should be the response code followed + by a space and optionally some text as per RFC-5321 and as outlined in + Section 4. Examples of RFC-4954 but some email servers ignore this and + only send the response code instead as per Section 4.2. */ + if(line[3] == ' ' || len == 5) { + char tmpline[6]; + curl_off_t code; + const char *p = tmpline; + end = TRUE; + memcpy(tmpline, line, (len == 5 ? 5 : 3)); + tmpline[len == 5 ? 5 : 3] = 0; + if(curlx_str_number(&p, &code, len == 5 ? 99999 : 999)) + return FALSE; + *resp = (int)code; + + /* Make sure real server never sends internal value */ + if(*resp == 1) + *resp = 0; + } + /* Do we have a multiline (continuation) response? */ + else if(line[3] == '-' && + (smtpc->state == SMTP_EHLO || smtpc->state == SMTP_COMMAND)) { + end = TRUE; + *resp = 1; /* Internal response code */ + } + + return end; +} + +/*********************************************************************** + * + * smtp_get_message() + * + * Gets the authentication message from the response buffer. + */ +static CURLcode smtp_get_message(struct Curl_easy *data, struct bufref *out) +{ + struct smtp_conn *smtpc = + Curl_conn_meta_get(data->conn, CURL_META_SMTP_CONN); + char *message; + size_t len; + + if(!smtpc) + return CURLE_FAILED_INIT; + + message = curlx_dyn_ptr(&smtpc->pp.recvbuf); + len = smtpc->pp.nfinal; + if(len > 4) { + /* Find the start of the message */ + len -= 4; + for(message += 4; ISBLANK(*message); message++, len--) + ; + + /* Find the end of the message */ + while(len--) + if(!ISNEWLINE(message[len]) && !ISBLANK(message[len])) + break; + + /* Terminate the message */ + message[++len] = '\0'; + Curl_bufref_set(out, message, len, NULL); + } + else + /* junk input => zero length output */ + Curl_bufref_set(out, "", 0, NULL); + + return CURLE_OK; +} + +/*********************************************************************** + * + * smtp_state() + * + * This is the ONLY way to change SMTP state! + */ +static void smtp_state(struct Curl_easy *data, + struct smtp_conn *smtpc, + smtpstate newstate) +{ +#ifdef CURLVERBOSE + /* for debug purposes */ + static const char * const names[] = { + "STOP", + "SERVERGREET", + "EHLO", + "HELO", + "STARTTLS", + "UPGRADETLS", + "AUTH", + "COMMAND", + "MAIL", + "RCPT", + "DATA", + "POSTDATA", + "QUIT", + /* LAST */ + }; + + if(smtpc->state != newstate) + CURL_TRC_SMTP(data, "state change from %s to %s", + names[smtpc->state], names[newstate]); +#else + (void)data; +#endif + + smtpc->state = newstate; +} + +/*********************************************************************** + * + * smtp_perform_ehlo() + * + * Sends the EHLO command to not only initialize communication with the ESMTP + * server but to also obtain a list of server side supported capabilities. + */ +static CURLcode smtp_perform_ehlo(struct Curl_easy *data, + struct smtp_conn *smtpc) +{ + CURLcode result = CURLE_OK; + + smtpc->sasl.authmechs = SASL_AUTH_NONE; /* No known auth. mechanism yet */ + smtpc->sasl.authused = SASL_AUTH_NONE; /* Clear the authentication mechanism + used for esmtp connections */ + smtpc->tls_supported = FALSE; /* Clear the TLS capability */ + smtpc->auth_supported = FALSE; /* Clear the AUTH capability */ + + /* Send the EHLO command */ + result = Curl_pp_sendf(data, &smtpc->pp, "EHLO %s", smtpc->domain); + + if(!result) + smtp_state(data, smtpc, SMTP_EHLO); + + return result; +} + +/*********************************************************************** + * + * smtp_perform_helo() + * + * Sends the HELO command to initialize communication with the SMTP server. + */ +static CURLcode smtp_perform_helo(struct Curl_easy *data, + struct smtp_conn *smtpc) +{ + CURLcode result = CURLE_OK; + + smtpc->sasl.authused = SASL_AUTH_NONE; /* No authentication mechanism used + in smtp connections */ + + /* Send the HELO command */ + result = Curl_pp_sendf(data, &smtpc->pp, "HELO %s", smtpc->domain); + + if(!result) + smtp_state(data, smtpc, SMTP_HELO); + + return result; +} + +/*********************************************************************** + * + * smtp_perform_starttls() + * + * Sends the STLS command to start the upgrade to TLS. + */ +static CURLcode smtp_perform_starttls(struct Curl_easy *data, + struct smtp_conn *smtpc) +{ + /* Send the STARTTLS command */ + CURLcode result = Curl_pp_sendf(data, &smtpc->pp, "%s", "STARTTLS"); + + if(!result) + smtp_state(data, smtpc, SMTP_STARTTLS); + + return result; +} + +/*********************************************************************** + * + * smtp_perform_upgrade_tls() + * + * Performs the upgrade to TLS. + */ +static CURLcode smtp_perform_upgrade_tls(struct Curl_easy *data, + struct smtp_conn *smtpc) +{ +#ifdef USE_SSL + /* Start the SSL connection */ + struct connectdata *conn = data->conn; + CURLcode result; + bool ssldone = FALSE; + + DEBUGASSERT(smtpc->state == SMTP_UPGRADETLS); + if(!Curl_conn_is_ssl(conn, FIRSTSOCKET)) { + result = Curl_ssl_cfilter_add( + data, Curl_conn_get_origin(conn, FIRSTSOCKET), conn, FIRSTSOCKET); + if(result) + goto out; + /* Change the connection handler and SMTP state */ + conn->scheme = &Curl_scheme_smtps; + } + + DEBUGASSERT(!smtpc->ssldone); + result = Curl_conn_connect(data, FIRSTSOCKET, FALSE, &ssldone); + DEBUGF(infof(data, "smtp_perform_upgrade_tls, connect -> %d, %d", + (int)result, ssldone)); + if(!result && ssldone) { + smtpc->ssldone = ssldone; + /* perform EHLO now, changes smtp->state out of SMTP_UPGRADETLS */ + result = smtp_perform_ehlo(data, smtpc); + } +out: + return result; +#else + (void)data; + (void)smtpc; + return CURLE_NOT_BUILT_IN; +#endif +} + +/*********************************************************************** + * + * smtp_perform_auth() + * + * Sends an AUTH command allowing the client to login with the given SASL + * authentication mechanism. + */ +static CURLcode smtp_perform_auth(struct Curl_easy *data, + const char *mech, + const struct bufref *initresp) +{ + CURLcode result = CURLE_OK; + struct smtp_conn *smtpc = + Curl_conn_meta_get(data->conn, CURL_META_SMTP_CONN); + const char *ir = Curl_bufref_ptr(initresp); + + if(!smtpc) + return CURLE_FAILED_INIT; + + if(ir) { /* AUTH ... */ + /* Send the AUTH command with the initial response */ + result = Curl_pp_sendf(data, &smtpc->pp, "AUTH %s %s", mech, ir); + } + else { + /* Send the AUTH command */ + result = Curl_pp_sendf(data, &smtpc->pp, "AUTH %s", mech); + } + + return result; +} + +/*********************************************************************** + * + * smtp_continue_auth() + * + * Sends SASL continuation data. + */ +static CURLcode smtp_continue_auth(struct Curl_easy *data, + const char *mech, + const struct bufref *resp) +{ + struct smtp_conn *smtpc = + Curl_conn_meta_get(data->conn, CURL_META_SMTP_CONN); + + (void)mech; + if(!smtpc) + return CURLE_FAILED_INIT; + return Curl_pp_sendf(data, &smtpc->pp, "%s", Curl_bufref_ptr(resp)); +} + +/*********************************************************************** + * + * smtp_cancel_auth() + * + * Sends SASL cancellation. + */ +static CURLcode smtp_cancel_auth(struct Curl_easy *data, const char *mech) +{ + struct smtp_conn *smtpc = + Curl_conn_meta_get(data->conn, CURL_META_SMTP_CONN); + + (void)mech; + if(!smtpc) + return CURLE_FAILED_INIT; + return Curl_pp_sendf(data, &smtpc->pp, "*"); +} + +/*********************************************************************** + * + * smtp_perform_authentication() + * + * Initiates the authentication sequence, with the appropriate SASL + * authentication mechanism. + */ +static CURLcode smtp_perform_authentication(struct Curl_easy *data, + struct smtp_conn *smtpc) +{ + CURLcode result = CURLE_OK; + saslprogress progress; + + /* Check we have enough data to authenticate with, and the + server supports authentication, and end the connect phase if not */ + if(!smtpc->auth_supported || + !Curl_sasl_can_authenticate(&smtpc->sasl, data)) { + smtp_state(data, smtpc, SMTP_STOP); + return result; + } + + /* Calculate the SASL login details */ + result = Curl_sasl_start(&smtpc->sasl, data, FALSE, &progress); + + if(!result) { + if(progress == SASL_INPROGRESS) + smtp_state(data, smtpc, SMTP_AUTH); + else + result = Curl_sasl_is_blocked(&smtpc->sasl, data); + } + + return result; +} + +/*********************************************************************** + * + * smtp_perform_command() + * + * Sends an SMTP based command. + */ +static CURLcode smtp_perform_command(struct Curl_easy *data, + struct smtp_conn *smtpc, + struct SMTP *smtp) +{ + CURLcode result = CURLE_OK; + + if(smtp->rcpt) { + /* We notify the server we are sending UTF-8 data if a) it supports the + SMTPUTF8 extension and b) The mailbox contains UTF-8 characters, in + either the local address or hostname parts. This is regardless of + whether the hostname is encoded using IDN ACE */ + bool utf8 = FALSE; + + if(!smtp->custom || !smtp->custom[0]) { + char *address = NULL; + struct hostname host = { NULL, NULL, NULL, NULL }; + const char *suffix = ""; + + /* Parse the mailbox to verify into the local address and hostname + parts, converting the hostname to an IDN A-label if necessary */ + result = smtp_parse_address(smtp->rcpt->data, + &address, &host, &suffix); + if(result) + return result; + + /* Establish whether we should report SMTPUTF8 to the server for this + mailbox as per RFC-6531 sect. 3.1 point 6 */ + utf8 = smtpc->utf8_supported && + (host.encalloc || + !Curl_is_ASCII_name(address) || + !Curl_is_ASCII_name(host.name)); + + /* Send the VRFY command (Note: The hostname part may be absent when the + host is a local system) */ + result = Curl_pp_sendf(data, &smtpc->pp, "VRFY %s%s%s%s", + address, + host.name ? "@" : "", + host.name ? host.name : "", + utf8 ? " SMTPUTF8" : ""); + + Curl_free_idnconverted_hostname(&host); + curlx_free(address); + } + else { + /* Establish whether we should report that we support SMTPUTF8 for EXPN + commands to the server as per RFC-6531 sect. 3.1 point 6 */ + utf8 = (smtpc->utf8_supported) && (!strcmp(smtp->custom, "EXPN")); + + /* Send the custom recipient based command such as the EXPN command */ + result = Curl_pp_sendf(data, &smtpc->pp, + "%s %s%s", smtp->custom, + smtp->rcpt->data, + utf8 ? " SMTPUTF8" : ""); + } + } + else + /* Send the non-recipient based command such as HELP */ + result = Curl_pp_sendf(data, &smtpc->pp, "%s", + smtp->custom && smtp->custom[0] != '\0' ? + smtp->custom : "HELP"); + + if(!result) + smtp_state(data, smtpc, SMTP_COMMAND); + + return result; +} + +/*********************************************************************** + * + * smtp_perform_mail() + * + * Sends an MAIL command to initiate the upload of a message. + */ +static CURLcode smtp_perform_mail(struct Curl_easy *data, + struct smtp_conn *smtpc, + struct SMTP *smtp) +{ + char *from = NULL; + char *auth = NULL; + char *size = NULL; + CURLcode result = CURLE_OK; + + /* We notify the server we are sending UTF-8 data if a) it supports the + SMTPUTF8 extension and b) The mailbox contains UTF-8 characters, in + either the local address or hostname parts. This is regardless of + whether the hostname is encoded using IDN ACE */ + bool utf8 = FALSE; + + /* Calculate the FROM parameter */ + if(data->set.str[STRING_MAIL_FROM]) { + char *address = NULL; + struct hostname host = { NULL, NULL, NULL, NULL }; + const char *suffix = ""; + + /* Parse the FROM mailbox into the local address and hostname parts, + converting the hostname to an IDN A-label if necessary */ + result = smtp_parse_address(data->set.str[STRING_MAIL_FROM], + &address, &host, &suffix); + if(result) + goto out; + + /* Establish whether we should report SMTPUTF8 to the server for this + mailbox as per RFC-6531 sect. 3.1 point 4 and sect. 3.4 */ + utf8 = smtpc->utf8_supported && + (host.encalloc || + !Curl_is_ASCII_name(address) || + !Curl_is_ASCII_name(host.name)); + + if(host.name) { + from = curl_maprintf("<%s@%s>%s", address, host.name, suffix); + + Curl_free_idnconverted_hostname(&host); + } + else + /* An invalid mailbox was provided but we let the server worry + about that and reply with a 501 error */ + from = curl_maprintf("<%s>%s", address, suffix); + + curlx_free(address); + } + else + /* Null reverse-path, RFC-5321, sect. 3.6.3 */ + from = curlx_strdup("<>"); + + if(!from) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + /* Calculate the optional AUTH parameter */ + if(data->set.str[STRING_MAIL_AUTH] && smtpc->sasl.authused) { + if(data->set.str[STRING_MAIL_AUTH][0] != '\0') { + char *address = NULL; + struct hostname host = { NULL, NULL, NULL, NULL }; + const char *suffix = ""; + + /* Parse the AUTH mailbox into the local address and hostname parts, + converting the hostname to an IDN A-label if necessary */ + result = smtp_parse_address(data->set.str[STRING_MAIL_AUTH], + &address, &host, &suffix); + if(result) + goto out; + + /* Establish whether we should report SMTPUTF8 to the server for this + mailbox as per RFC-6531 sect. 3.1 point 4 and sect. 3.4 */ + if(!utf8 && smtpc->utf8_supported && + (host.encalloc || + !Curl_is_ASCII_name(address) || + !Curl_is_ASCII_name(host.name))) + utf8 = TRUE; + + if(host.name) { + auth = curl_maprintf("<%s@%s>%s", address, host.name, suffix); + + Curl_free_idnconverted_hostname(&host); + } + else + /* An invalid mailbox was provided but we let the server worry + about it */ + auth = curl_maprintf("<%s>%s", address, suffix); + curlx_free(address); + } + else + /* Empty AUTH, RFC-2554, sect. 5 */ + auth = curlx_strdup("<>"); + + if(!auth) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + } + +#ifndef CURL_DISABLE_MIME + /* Prepare the mime data if some. */ + if(IS_MIME_POST(data)) { + curl_mimepart *postp = data->set.mimepostp; + + /* Use the whole structure as data. */ + postp->flags &= ~(unsigned int)MIME_BODY_ONLY; + + /* Add external headers and mime version. */ + curl_mime_headers(postp, data->set.headers, 0); + result = Curl_mime_prepare_headers(data, postp, NULL, + NULL, MIMESTRATEGY_MAIL); + + if(!result) + if(!Curl_checkheaders(data, STRCONST("Mime-Version"))) + result = Curl_mime_add_header(&postp->curlheaders, + "Mime-Version: 1.0"); + + if(!result) + result = Curl_creader_set_mime(data, postp); + if(result) + goto out; + data->state.infilesize = Curl_creader_total_length(data); + } + else +#endif + { + result = Curl_creader_set_fread(data, data->state.infilesize); + if(result) + goto out; + } + + /* Calculate the optional SIZE parameter */ + if(smtpc->size_supported && data->state.infilesize > 0) { + size = curl_maprintf("%" FMT_OFF_T, data->state.infilesize); + + if(!size) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + } + + /* If the mailboxes in the FROM and AUTH parameters do not include a UTF-8 + based address then quickly scan through the recipient list and check if + any there do, as we need to correctly identify our support for SMTPUTF8 + in the envelope, as per RFC-6531 sect. 3.4 */ + if(smtpc->utf8_supported && !utf8) { + struct curl_slist *rcpt = smtp->rcpt; + + while(rcpt && !utf8) { + /* Does the hostname contain non-ASCII characters? */ + if(!Curl_is_ASCII_name(rcpt->data)) + utf8 = TRUE; + + rcpt = rcpt->next; + } + } + + /* Add the client reader doing STMP EOB escaping */ + result = cr_eob_add(data); + if(result) + goto out; + + /* Send the MAIL command */ + result = Curl_pp_sendf(data, &smtpc->pp, + "MAIL FROM:%s%s%s%s%s%s", + from, /* Mandatory */ + auth ? " AUTH=" : "", /* Optional on AUTH support */ + auth ? auth : "", + size ? " SIZE=" : "", /* Optional on SIZE support */ + size ? size : "", + utf8 ? " SMTPUTF8" /* Internationalised mailbox */ + : ""); /* included in our envelope */ + +out: + curlx_free(from); + curlx_free(auth); + curlx_free(size); + + if(!result) + smtp_state(data, smtpc, SMTP_MAIL); + + return result; +} + +/*********************************************************************** + * + * smtp_perform_rcpt_to() + * + * Sends a RCPT TO command for a given recipient as part of the message upload + * process. + */ +static CURLcode smtp_perform_rcpt_to(struct Curl_easy *data, + struct smtp_conn *smtpc, + struct SMTP *smtp) +{ + CURLcode result = CURLE_OK; + char *address = NULL; + struct hostname host = { NULL, NULL, NULL, NULL }; + const char *suffix = ""; + + /* Parse the recipient mailbox into the local address and hostname parts, + converting the hostname to an IDN A-label if necessary */ + result = smtp_parse_address(smtp->rcpt->data, + &address, &host, &suffix); + if(result) + return result; + + /* Send the RCPT TO command */ + if(host.name) + result = Curl_pp_sendf(data, &smtpc->pp, "RCPT TO:<%s@%s>%s", + address, host.name, suffix); + else + /* An invalid mailbox was provided but we let the server worry about + that and reply with a 501 error */ + result = Curl_pp_sendf(data, &smtpc->pp, "RCPT TO:<%s>%s", + address, suffix); + + Curl_free_idnconverted_hostname(&host); + curlx_free(address); + + if(!result) + smtp_state(data, smtpc, SMTP_RCPT); + + return result; +} + +/*********************************************************************** + * + * smtp_perform_quit() + * + * Performs the quit action prior to sclose() being called. + */ +static CURLcode smtp_perform_quit(struct Curl_easy *data, + struct smtp_conn *smtpc) +{ + /* Send the QUIT command */ + CURLcode result = Curl_pp_sendf(data, &smtpc->pp, "%s", "QUIT"); + + if(!result) + smtp_state(data, smtpc, SMTP_QUIT); + + return result; +} + +/* For the initial server greeting */ +static CURLcode smtp_state_servergreet_resp(struct Curl_easy *data, + struct smtp_conn *smtpc, + int smtpcode, + smtpstate instate) +{ + CURLcode result = CURLE_OK; + (void)instate; + + if(smtpcode / 100 != 2) { + failf(data, "Got unexpected smtp-server response: %d", smtpcode); + result = CURLE_WEIRD_SERVER_REPLY; + } + else + result = smtp_perform_ehlo(data, smtpc); + + return result; +} + +/* For STARTTLS responses */ +static CURLcode smtp_state_starttls_resp(struct Curl_easy *data, + struct smtp_conn *smtpc, + int smtpcode, + smtpstate instate) +{ + CURLcode result = CURLE_OK; + (void)instate; + + /* Pipelining in response is forbidden. */ + if(smtpc->pp.overflow) + return CURLE_WEIRD_SERVER_REPLY; + + if(smtpcode != 220) { + if(data->set.use_ssl != CURLUSESSL_TRY) { + failf(data, "STARTTLS denied, code %d", smtpcode); + result = CURLE_USE_SSL_FAILED; + } + else + result = smtp_perform_authentication(data, smtpc); + } + else + smtp_state(data, smtpc, SMTP_UPGRADETLS); + + return result; +} + +/* For EHLO responses */ +static CURLcode smtp_state_ehlo_resp(struct Curl_easy *data, + struct smtp_conn *smtpc, + int smtpcode, + smtpstate instate) +{ + CURLcode result = CURLE_OK; + const char *line = curlx_dyn_ptr(&smtpc->pp.recvbuf); + size_t len = smtpc->pp.nfinal; + + (void)instate; + + if(smtpcode / 100 != 2 && smtpcode != 1) { + if(data->set.use_ssl <= CURLUSESSL_TRY || + Curl_conn_is_ssl(data->conn, FIRSTSOCKET)) + result = smtp_perform_helo(data, smtpc); + else { + failf(data, "Remote access denied: %d", smtpcode); + result = CURLE_REMOTE_ACCESS_DENIED; + } + } + else if(len >= 4) { + line += 4; + len -= 4; + + /* Does the server support the STARTTLS capability? */ + if(len >= 8 && curl_strnequal(line, "STARTTLS", 8)) + smtpc->tls_supported = TRUE; + + /* Does the server support the SIZE capability? */ + else if(len >= 4 && curl_strnequal(line, "SIZE", 4)) + smtpc->size_supported = TRUE; + + /* Does the server support the UTF-8 capability? */ + else if(len >= 8 && curl_strnequal(line, "SMTPUTF8", 8)) + smtpc->utf8_supported = TRUE; + + /* Does the server support authentication? */ + else if(len >= 5 && curl_strnequal(line, "AUTH ", 5)) { + smtpc->auth_supported = TRUE; + + /* Advance past the AUTH keyword */ + line += 5; + len -= 5; + + /* Loop through the data line */ + for(;;) { + size_t llen; + size_t wordlen; + unsigned short mechbit; + + while(len && (ISBLANK(*line) || ISNEWLINE(*line))) { + line++; + len--; + } + + if(!len) + break; + + /* Extract the word */ + for(wordlen = 0; wordlen < len && !ISBLANK(line[wordlen]) && + !ISNEWLINE(line[wordlen]);) + wordlen++; + + /* Test the word for a matching authentication mechanism */ + mechbit = Curl_sasl_decode_mech(line, wordlen, &llen); + if(mechbit && llen == wordlen) + smtpc->sasl.authmechs |= mechbit; + + line += wordlen; + len -= wordlen; + } + } + + if(smtpcode != 1) { + if(data->set.use_ssl && !Curl_conn_is_ssl(data->conn, FIRSTSOCKET)) { + /* We do not have an SSL/TLS connection yet, but SSL is requested */ + if(smtpc->tls_supported) + /* Switch to TLS connection now */ + result = smtp_perform_starttls(data, smtpc); + else if(data->set.use_ssl == CURLUSESSL_TRY) + /* Fallback and carry on with authentication */ + result = smtp_perform_authentication(data, smtpc); + else { + failf(data, "STARTTLS not supported."); + result = CURLE_USE_SSL_FAILED; + } + } + else + result = smtp_perform_authentication(data, smtpc); + } + } + else { + failf(data, "Unexpectedly short EHLO response"); + result = CURLE_WEIRD_SERVER_REPLY; + } + + return result; +} + +/* For HELO responses */ +static CURLcode smtp_state_helo_resp(struct Curl_easy *data, + struct smtp_conn *smtpc, + int smtpcode, + smtpstate instate) +{ + CURLcode result = CURLE_OK; + (void)instate; + + if(smtpcode / 100 != 2) { + failf(data, "Remote access denied: %d", smtpcode); + result = CURLE_REMOTE_ACCESS_DENIED; + } + else + /* End of connect phase */ + smtp_state(data, smtpc, SMTP_STOP); + + return result; +} + +/* For SASL authentication responses */ +static CURLcode smtp_state_auth_resp(struct Curl_easy *data, + struct smtp_conn *smtpc, + int smtpcode, + smtpstate instate) +{ + CURLcode result = CURLE_OK; + saslprogress progress; + + (void)instate; + + result = Curl_sasl_continue(&smtpc->sasl, data, smtpcode, &progress); + if(!result) + switch(progress) { + case SASL_DONE: + smtp_state(data, smtpc, SMTP_STOP); /* Authenticated */ + break; + case SASL_IDLE: /* No mechanism left after cancellation */ + failf(data, "Authentication cancelled"); + result = CURLE_LOGIN_DENIED; + break; + default: + break; + } + + return result; +} + +/* For command responses */ +static CURLcode smtp_state_command_resp(struct Curl_easy *data, + struct smtp_conn *smtpc, + struct SMTP *smtp, + int smtpcode, + smtpstate instate) +{ + CURLcode result = CURLE_OK; + const char *line = curlx_dyn_ptr(&smtpc->pp.recvbuf); + size_t len = smtpc->pp.nfinal; + + (void)instate; + + if((smtp->rcpt && smtpcode / 100 != 2 && smtpcode != 553 && smtpcode != 1) || + (!smtp->rcpt && smtpcode / 100 != 2 && smtpcode != 1)) { + failf(data, "Command failed: %d", smtpcode); + result = CURLE_WEIRD_SERVER_REPLY; + } + else { + if(!data->req.no_body) + result = Curl_client_write(data, CLIENTWRITE_BODY, line, len); + + if(!result && (smtpcode != 1)) { + if(smtp->rcpt) { + smtp->rcpt = smtp->rcpt->next; + + if(smtp->rcpt) { + /* Send the next command */ + result = smtp_perform_command(data, smtpc, smtp); + } + else + /* End of DO phase */ + smtp_state(data, smtpc, SMTP_STOP); + } + else + /* End of DO phase */ + smtp_state(data, smtpc, SMTP_STOP); + } + } + + return result; +} + +/* For MAIL responses */ +static CURLcode smtp_state_mail_resp(struct Curl_easy *data, + struct smtp_conn *smtpc, + struct SMTP *smtp, + int smtpcode, + smtpstate instate) +{ + CURLcode result = CURLE_OK; + (void)instate; + + if(smtpcode / 100 != 2) { + failf(data, "MAIL failed: %d", smtpcode); + result = CURLE_SEND_ERROR; + } + else + /* Start the RCPT TO command */ + result = smtp_perform_rcpt_to(data, smtpc, smtp); + + return result; +} + +/* For RCPT responses */ +static CURLcode smtp_state_rcpt_resp(struct Curl_easy *data, + struct smtp_conn *smtpc, + struct SMTP *smtp, + int smtpcode, + smtpstate instate) +{ + CURLcode result = CURLE_OK; + bool is_smtp_err = FALSE; + bool is_smtp_blocking_err = FALSE; + + (void)instate; + + is_smtp_err = (smtpcode / 100 != 2); + + /* If there is multiple RCPT TO to be issued, it is possible to ignore errors + and proceed with only the valid addresses. */ + is_smtp_blocking_err = (is_smtp_err && !data->set.mail_rcpt_allowfails); + + if(is_smtp_err) { + /* Remembering the last failure which we can report if all "RCPT TO" have + failed and we cannot proceed. */ + smtp->rcpt_last_error = smtpcode; + + if(is_smtp_blocking_err) { + failf(data, "RCPT failed: %d", smtpcode); + result = CURLE_SEND_ERROR; + } + } + else { + /* Some RCPT TO commands have succeeded. */ + smtp->rcpt_had_ok = TRUE; + } + + if(!is_smtp_blocking_err) { + smtp->rcpt = smtp->rcpt->next; + + if(smtp->rcpt) + /* Send the next RCPT TO command */ + result = smtp_perform_rcpt_to(data, smtpc, smtp); + else { + /* We were not able to issue a successful RCPT TO command while going + over recipients (potentially multiple). Sending back last error. */ + if(!smtp->rcpt_had_ok) { + failf(data, "RCPT failed: %d (last error)", smtp->rcpt_last_error); + result = CURLE_SEND_ERROR; + } + else { + /* Send the DATA command */ + result = Curl_pp_sendf(data, &smtpc->pp, "%s", "DATA"); + + if(!result) + smtp_state(data, smtpc, SMTP_DATA); + } + } + } + + return result; +} + +/* For DATA response */ +static CURLcode smtp_state_data_resp(struct Curl_easy *data, + struct smtp_conn *smtpc, + int smtpcode, + smtpstate instate) +{ + CURLcode result = CURLE_OK; + (void)instate; + + if(smtpcode != 354) { + failf(data, "DATA failed: %d", smtpcode); + result = CURLE_SEND_ERROR; + } + else { + /* Set the progress upload size */ + Curl_pgrsSetUploadSize(data, data->state.infilesize); + + /* SMTP upload */ + Curl_xfer_setup_send(data, FIRSTSOCKET); + + /* End of DO phase */ + smtp_state(data, smtpc, SMTP_STOP); + } + + return result; +} + +/* For POSTDATA responses, which are received after the entire DATA + part has been sent to the server */ +static CURLcode smtp_state_postdata_resp(struct Curl_easy *data, + struct smtp_conn *smtpc, + int smtpcode, + smtpstate instate) +{ + CURLcode result = CURLE_OK; + + (void)instate; + + if(smtpcode != 250) + result = CURLE_WEIRD_SERVER_REPLY; + + /* End of DONE phase */ + smtp_state(data, smtpc, SMTP_STOP); + + return result; +} + +static CURLcode smtp_pp_statemachine(struct Curl_easy *data, + struct connectdata *conn) +{ + CURLcode result = CURLE_OK; + int smtpcode; + struct smtp_conn *smtpc = Curl_conn_meta_get(conn, CURL_META_SMTP_CONN); + struct SMTP *smtp = Curl_meta_get(data, CURL_META_SMTP_EASY); + size_t nread = 0; + + if(!smtpc || !smtp) + return CURLE_FAILED_INIT; + + /* Busy upgrading the connection; right now all I/O is SSL/TLS, not SMTP */ +upgrade_tls: + if(smtpc->state == SMTP_UPGRADETLS) { + result = smtp_perform_upgrade_tls(data, smtpc); + if(result || (smtpc->state == SMTP_UPGRADETLS)) + return result; + } + + /* Flush any data that needs to be sent */ + if(smtpc->pp.sendleft) + return Curl_pp_flushsend(data, &smtpc->pp); + + do { + /* Read the response from the server */ + result = Curl_pp_readresp(data, FIRSTSOCKET, &smtpc->pp, + &smtpcode, &nread); + if(result) + return result; + + /* Store the latest response for later retrieval if necessary */ + if(smtpc->state != SMTP_QUIT && smtpcode != 1) + data->info.httpcode = smtpcode; + + if(!smtpcode) + break; + + /* We have now received a full SMTP server response */ + switch(smtpc->state) { + case SMTP_SERVERGREET: + result = smtp_state_servergreet_resp(data, smtpc, + smtpcode, smtpc->state); + break; + + case SMTP_EHLO: + result = smtp_state_ehlo_resp(data, smtpc, smtpcode, smtpc->state); + break; + + case SMTP_HELO: + result = smtp_state_helo_resp(data, smtpc, smtpcode, smtpc->state); + break; + + case SMTP_STARTTLS: + result = smtp_state_starttls_resp(data, smtpc, smtpcode, smtpc->state); + /* During UPGRADETLS, leave the read loop as we need to connect + * (e.g. TLS handshake) before we continue sending/receiving. */ + if(!result && (smtpc->state == SMTP_UPGRADETLS)) + goto upgrade_tls; + break; + + case SMTP_AUTH: + result = smtp_state_auth_resp(data, smtpc, smtpcode, smtpc->state); + break; + + case SMTP_COMMAND: + result = smtp_state_command_resp(data, smtpc, smtp, + smtpcode, smtpc->state); + break; + + case SMTP_MAIL: + result = smtp_state_mail_resp(data, smtpc, smtp, smtpcode, smtpc->state); + break; + + case SMTP_RCPT: + result = smtp_state_rcpt_resp(data, smtpc, smtp, smtpcode, smtpc->state); + break; + + case SMTP_DATA: + result = smtp_state_data_resp(data, smtpc, smtpcode, smtpc->state); + break; + + case SMTP_POSTDATA: + result = smtp_state_postdata_resp(data, smtpc, smtpcode, smtpc->state); + break; + + case SMTP_QUIT: + default: + /* internal error */ + smtp_state(data, smtpc, SMTP_STOP); + break; + } + } while(!result && smtpc->state != SMTP_STOP && + Curl_pp_moredata(&smtpc->pp)); + + return result; +} + +/* Called repeatedly until done from multi.c */ +static CURLcode smtp_multi_statemach(struct Curl_easy *data, bool *done) +{ + CURLcode result = CURLE_OK; + struct smtp_conn *smtpc = + Curl_conn_meta_get(data->conn, CURL_META_SMTP_CONN); + + *done = FALSE; + if(!smtpc) + return CURLE_FAILED_INIT; + + result = Curl_pp_statemach(data, &smtpc->pp, FALSE, FALSE); + *done = (smtpc->state == SMTP_STOP); + return result; +} + +static CURLcode smtp_block_statemach(struct Curl_easy *data, + struct smtp_conn *smtpc, + bool disconnecting) +{ + CURLcode result = CURLE_OK; + + while(smtpc->state != SMTP_STOP && !result) + result = Curl_pp_statemach(data, &smtpc->pp, TRUE, disconnecting); + + return result; +} + +/* For the SMTP "protocol connect" and "doing" phases only */ +static CURLcode smtp_pollset(struct Curl_easy *data, + struct easy_pollset *ps) +{ + struct smtp_conn *smtpc = + Curl_conn_meta_get(data->conn, CURL_META_SMTP_CONN); + return smtpc ? Curl_pp_pollset(data, &smtpc->pp, ps) : CURLE_OK; +} + +/* SASL parameters for the smtp protocol */ +static const struct SASLproto saslsmtp = { + "smtp", /* The service name */ + smtp_perform_auth, /* Send authentication command */ + smtp_continue_auth, /* Send authentication continuation */ + smtp_cancel_auth, /* Cancel authentication */ + smtp_get_message, /* Get SASL response message */ + 512 - 8, /* Max line len - strlen("AUTH ") - 1 space - crlf */ + 334, /* Code received when continuation is expected */ + 235, /* Code to receive upon authentication success */ + SASL_AUTH_DEFAULT, /* Default mechanisms */ + SASL_FLAG_BASE64 /* Configuration flags */ +}; + +/*********************************************************************** + * + * smtp_connect() + * + * This function should do everything that is to be considered a part of + * the connection phase. + * + * The variable pointed to by 'done' will be TRUE if the protocol-layer + * connect phase is done when this function returns, or FALSE if not. + */ +static CURLcode smtp_connect(struct Curl_easy *data, bool *done) +{ + struct smtp_conn *smtpc = + Curl_conn_meta_get(data->conn, CURL_META_SMTP_CONN); + CURLcode result = CURLE_OK; + + *done = FALSE; /* default to not done yet */ + if(!smtpc) + return CURLE_FAILED_INIT; + + PINGPONG_SETUP(&smtpc->pp, smtp_pp_statemachine, smtp_endofresp); + + /* Initialize the SASL storage */ + Curl_sasl_init(&smtpc->sasl, data, &saslsmtp); + + /* Initialize the pingpong layer */ + Curl_pp_init(&smtpc->pp, Curl_pgrs_now(data)); + + /* Parse the URL options */ + result = smtp_parse_url_options(data->conn, smtpc); + if(result) + return result; + + /* Parse the URL path */ + result = smtp_parse_url_path(data, smtpc); + if(result) + return result; + + /* Start off waiting for the server greeting response */ + smtp_state(data, smtpc, SMTP_SERVERGREET); + + result = smtp_multi_statemach(data, done); + + return result; +} + +/*********************************************************************** + * + * smtp_done() + * + * The DONE function. This does what needs to be done after a single DO has + * performed. + * + * Input argument is already checked for validity. + */ +static CURLcode smtp_done(struct Curl_easy *data, CURLcode status, + bool premature) +{ + struct smtp_conn *smtpc = + Curl_conn_meta_get(data->conn, CURL_META_SMTP_CONN); + CURLcode result = CURLE_OK; + struct connectdata *conn = data->conn; + struct SMTP *smtp = Curl_meta_get(data, CURL_META_SMTP_EASY); + + (void)premature; + + if(!smtpc) + return CURLE_FAILED_INIT; + if(!smtp) + return CURLE_OK; + + /* Cleanup our per-request based variables */ + curlx_safefree(smtp->custom); + + if(status) { + connclose(conn, "SMTP done with bad status"); /* marked for closure */ + result = status; /* use the already set error code */ + } + else if(!data->set.connect_only && data->set.mail_rcpt && + (data->state.upload || IS_MIME_POST(data))) { + + smtp_state(data, smtpc, SMTP_POSTDATA); + + /* Run the state-machine */ + result = smtp_block_statemach(data, smtpc, FALSE); + } + + /* Clear the transfer mode for the next request */ + smtp->transfer = PPTRANSFER_BODY; + CURL_TRC_SMTP(data, "smtp_done(status=%d, premature=%d) -> %d", + (int)status, premature, (int)result); + return result; +} + +/*********************************************************************** + * + * smtp_perform() + * + * This is the actual DO function for SMTP. Transfer a mail, send a command + * or get some data according to the options previously setup. + */ +static CURLcode smtp_perform(struct Curl_easy *data, + struct smtp_conn *smtpc, + struct SMTP *smtp, + bool *connected, + bool *dophase_done) +{ + /* This is SMTP and no proxy */ + CURLcode result = CURLE_OK; + + CURL_TRC_SMTP(data, "smtp_perform(), start"); + + if(data->req.no_body) { + /* Requested no body means no transfer */ + smtp->transfer = PPTRANSFER_INFO; + } + + *dophase_done = FALSE; /* not done yet */ + + /* Store the first recipient (or NULL if not specified) */ + smtp->rcpt = data->set.mail_rcpt; + + /* Track of whether we have successfully sent at least one RCPT TO command */ + smtp->rcpt_had_ok = FALSE; + + /* Track of the last error we have received by sending RCPT TO command */ + smtp->rcpt_last_error = 0; + + /* Initial data character is the first character in line: it is implicitly + preceded by a virtual CRLF. */ + smtp->trailing_crlf = TRUE; + smtp->eob = 2; + + /* Start the first command in the DO phase */ + if((data->state.upload || IS_MIME_POST(data)) && data->set.mail_rcpt) + /* MAIL transfer */ + result = smtp_perform_mail(data, smtpc, smtp); + else + /* SMTP based command (VRFY, EXPN, NOOP, RSET or HELP) */ + result = smtp_perform_command(data, smtpc, smtp); + + if(result) + goto out; + + /* Run the state-machine */ + result = smtp_multi_statemach(data, dophase_done); + + *connected = Curl_conn_is_connected(data->conn, FIRSTSOCKET); + +out: + CURL_TRC_SMTP(data, "smtp_perform() -> %d, connected=%d, done=%d", + (int)result, *connected, *dophase_done); + return result; +} + +/* Call this when the DO phase has completed */ +static CURLcode smtp_dophase_done(struct Curl_easy *data, + struct SMTP *smtp, + bool connected) +{ + (void)connected; + + if(smtp->transfer != PPTRANSFER_BODY) + /* no data to transfer */ + Curl_xfer_setup_nop(data); + + return CURLE_OK; +} + +/*********************************************************************** + * + * smtp_regular_transfer() + * + * The input argument is already checked for validity. + * + * Performs all commands done before a regular transfer between a local and a + * remote host. + */ +static CURLcode smtp_regular_transfer(struct Curl_easy *data, + struct smtp_conn *smtpc, + struct SMTP *smtp, + bool *dophase_done) +{ + CURLcode result = CURLE_OK; + bool connected = FALSE; + + /* Make sure size is unknown at this point */ + data->req.size = -1; + + /* Set the progress data */ + Curl_pgrsReset(data); + + /* Carry out the perform */ + result = smtp_perform(data, smtpc, smtp, &connected, dophase_done); + + /* Perform post DO phase operations if necessary */ + if(!result && *dophase_done) + result = smtp_dophase_done(data, smtp, connected); + + CURL_TRC_SMTP(data, "smtp_regular_transfer() -> %d, done=%d", + (int)result, *dophase_done); + return result; +} + +/*********************************************************************** + * + * smtp_do() + * + * This function is registered as 'curl_do' function. It decodes the path + * parts etc as a wrapper to the actual DO function (smtp_perform). + * + * The input argument is already checked for validity. + */ +static CURLcode smtp_do(struct Curl_easy *data, bool *done) +{ + struct smtp_conn *smtpc = + Curl_conn_meta_get(data->conn, CURL_META_SMTP_CONN); + struct SMTP *smtp = Curl_meta_get(data, CURL_META_SMTP_EASY); + CURLcode result = CURLE_OK; + + DEBUGASSERT(data); + DEBUGASSERT(data->conn); + *done = FALSE; /* default to false */ + if(!smtpc || !smtp) + return CURLE_FAILED_INIT; + + /* Parse the custom request */ + result = smtp_parse_custom_request(data, smtp); + if(result) + return result; + + result = smtp_regular_transfer(data, smtpc, smtp, done); + CURL_TRC_SMTP(data, "smtp_do() -> %d, done=%d", (int)result, *done); + return result; +} + +/*********************************************************************** + * + * smtp_disconnect() + * + * Disconnect from an SMTP server. Cleanup protocol-specific per-connection + * resources. BLOCKING. + */ +static CURLcode smtp_disconnect(struct Curl_easy *data, + struct connectdata *conn, + bool dead_connection) +{ + struct smtp_conn *smtpc = Curl_conn_meta_get(conn, CURL_META_SMTP_CONN); + + if(!smtpc) + return CURLE_FAILED_INIT; + + /* We cannot send quit unconditionally. If this connection is stale or + bad in any way, sending quit and waiting around here will make the + disconnect wait in vain and cause more problems than we need to. */ + + if(!dead_connection && conn->bits.protoconnstart && + !Curl_pp_needs_flush(data, &smtpc->pp)) { + if(!smtp_perform_quit(data, smtpc)) + (void)smtp_block_statemach(data, smtpc, TRUE); /* ignore on QUIT */ + } + + CURL_TRC_SMTP(data, "smtp_disconnect(), finished"); + return CURLE_OK; +} + +/* Called from multi.c while DOing */ +static CURLcode smtp_doing(struct Curl_easy *data, bool *dophase_done) +{ + struct SMTP *smtp = Curl_meta_get(data, CURL_META_SMTP_EASY); + CURLcode result; + + if(!smtp) + return CURLE_FAILED_INIT; + result = smtp_multi_statemach(data, dophase_done); + if(result) + DEBUGF(infof(data, "DO phase failed")); + else if(*dophase_done) { + result = smtp_dophase_done(data, smtp, FALSE /* not connected */); + + DEBUGF(infof(data, "DO phase is complete")); + } + + CURL_TRC_SMTP(data, "smtp_doing() -> %d, done=%d", (int)result, + *dophase_done); + return result; +} + +static void smtp_easy_dtor(void *key, size_t klen, void *entry) +{ + struct SMTP *smtp = entry; + (void)key; + (void)klen; + curlx_free(smtp); +} + +static void smtp_conn_dtor(void *key, size_t klen, void *entry) +{ + struct smtp_conn *smtpc = entry; + (void)key; + (void)klen; + Curl_pp_disconnect(&smtpc->pp); + curlx_safefree(smtpc->domain); + curlx_free(smtpc); +} + +static CURLcode smtp_setup_connection(struct Curl_easy *data, + struct connectdata *conn) +{ + struct smtp_conn *smtpc; + struct SMTP *smtp; + CURLcode result = CURLE_OK; + + smtpc = curlx_calloc(1, sizeof(*smtpc)); + if(!smtpc || + Curl_conn_meta_set(conn, CURL_META_SMTP_CONN, smtpc, smtp_conn_dtor)) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + smtp = curlx_calloc(1, sizeof(*smtp)); + if(!smtp || + Curl_meta_set(data, CURL_META_SMTP_EASY, smtp, smtp_easy_dtor)) + result = CURLE_OUT_OF_MEMORY; + +out: + CURL_TRC_SMTP(data, "smtp_setup_connection() -> %d", (int)result); + return result; +} + +/* + * SMTP protocol handler. + */ +const struct Curl_protocol Curl_protocol_smtp = { + smtp_setup_connection, /* setup_connection */ + smtp_do, /* do_it */ + smtp_done, /* done */ + ZERO_NULL, /* do_more */ + smtp_connect, /* connect_it */ + smtp_multi_statemach, /* connecting */ + smtp_doing, /* doing */ + smtp_pollset, /* proto_pollset */ + smtp_pollset, /* doing_pollset */ + ZERO_NULL, /* domore_pollset */ + ZERO_NULL, /* perform_pollset */ + smtp_disconnect, /* disconnect */ + ZERO_NULL, /* write_resp */ + ZERO_NULL, /* write_resp_hd */ + ZERO_NULL, /* connection_is_dead */ + ZERO_NULL, /* attach connection */ + ZERO_NULL, /* follow */ +}; + +#endif /* CURL_DISABLE_SMTP */ diff --git a/3rdparty/curl-8.21.0/lib/smtp.h b/3rdparty/curl-8.21.0/lib/smtp.h new file mode 100644 index 0000000000..75b81979c2 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/smtp.h @@ -0,0 +1,30 @@ +#ifndef HEADER_CURL_SMTP_H +#define HEADER_CURL_SMTP_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#ifndef CURL_DISABLE_SMTP +extern const struct Curl_protocol Curl_protocol_smtp; +#endif + +#endif /* HEADER_CURL_SMTP_H */ diff --git a/3rdparty/curl-8.21.0/lib/sockaddr.h b/3rdparty/curl-8.21.0/lib/sockaddr.h new file mode 100644 index 0000000000..916360d089 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/sockaddr.h @@ -0,0 +1,61 @@ +#ifndef HEADER_CURL_SOCKADDR_H +#define HEADER_CURL_SOCKADDR_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +struct Curl_sockaddr_storage { + union { + struct sockaddr sa; + struct sockaddr_in sa_in; +#ifdef USE_IPV6 + struct sockaddr_in6 sa_in6; +#endif +#ifdef HAVE_STRUCT_SOCKADDR_STORAGE + struct sockaddr_storage sa_stor; +#else + char cbuf[256]; /* this should be big enough to fit a lot */ +#endif + } buffer; +}; + +/* + * The Curl_sockaddr_ex structure is libcurl's external API curl_sockaddr + * structure with enough space available to directly hold any + * protocol-specific address structures. The variable declared here will be + * used to pass / receive data to/from the fopensocket callback if this has + * been set, before that, it is initialized from parameters. + */ +struct Curl_sockaddr_ex { + int family; + int socktype; + int protocol; + unsigned int addrlen; + union { + struct sockaddr sa; + struct Curl_sockaddr_storage buf; + } addr; +}; + +#endif /* HEADER_CURL_SOCKADDR_H */ diff --git a/3rdparty/curl-8.21.0/lib/socketpair.c b/3rdparty/curl-8.21.0/lib/socketpair.c new file mode 100644 index 0000000000..39a0e319b0 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/socketpair.c @@ -0,0 +1,364 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "socketpair.h" +#include "urldata.h" +#include "rand.h" +#include "curlx/nonblock.h" + +#ifndef CURL_DISABLE_SOCKETPAIR + +/* choose implementation */ +#ifdef USE_EVENTFD + +#include + +static int wakeup_eventfd(curl_socket_t socks[2], bool nonblocking) +{ + int efd = eventfd(0, nonblocking ? EFD_CLOEXEC | EFD_NONBLOCK : EFD_CLOEXEC); + if(efd == -1) { + socks[0] = socks[1] = CURL_SOCKET_BAD; + return -1; + } + socks[0] = socks[1] = efd; + return 0; +} + +#elif defined(HAVE_PIPE) + +#ifdef HAVE_FCNTL +#include +#endif + +static int wakeup_pipe(curl_socket_t socks[2], bool nonblocking) +{ +#ifdef HAVE_PIPE2 + int flags = nonblocking ? O_NONBLOCK | O_CLOEXEC : O_CLOEXEC; + if(pipe2(socks, flags)) + return -1; +#else + if(pipe(socks)) + return -1; +#ifdef HAVE_FCNTL + if(fcntl(socks[0], F_SETFD, FD_CLOEXEC) || + fcntl(socks[1], F_SETFD, FD_CLOEXEC)) { + sclose(socks[0]); + sclose(socks[1]); + socks[0] = socks[1] = CURL_SOCKET_BAD; + return -1; + } +#endif + if(nonblocking) { + if(curlx_nonblock(socks[0], TRUE) < 0 || + curlx_nonblock(socks[1], TRUE) < 0) { + sclose(socks[0]); + sclose(socks[1]); + socks[0] = socks[1] = CURL_SOCKET_BAD; + return -1; + } + } +#endif + + return 0; +} + +#elif defined(HAVE_SOCKETPAIR) /* !USE_EVENTFD && !HAVE_PIPE */ + +#ifndef USE_UNIX_SOCKETS +#error "unsupported Unix domain and socketpair build combo" +#endif + +static int wakeup_socketpair(curl_socket_t socks[2], bool nonblocking) +{ + int type = SOCK_STREAM; +#ifdef SOCK_CLOEXEC + type |= SOCK_CLOEXEC; +#endif +#ifdef SOCK_NONBLOCK + if(nonblocking) + type |= SOCK_NONBLOCK; +#endif + + if(CURL_SOCKETPAIR(AF_UNIX, type, 0, socks)) + return -1; +#ifndef SOCK_NONBLOCK + if(nonblocking) { + if(curlx_nonblock(socks[0], TRUE) < 0 || + curlx_nonblock(socks[1], TRUE) < 0) { + sclose(socks[0]); + sclose(socks[1]); + socks[0] = socks[1] = CURL_SOCKET_BAD; + return -1; + } + } +#endif +#ifdef USE_SO_NOSIGPIPE + if(Curl_sock_nosigpipe(socks[1]) < 0) { + sclose(socks[0]); + sclose(socks[1]); + socks[0] = socks[1] = CURL_SOCKET_BAD; + return -1; + } +#endif /* USE_SO_NOSIGPIPE */ + + return 0; +} + +#else /* !USE_EVENTFD && !HAVE_PIPE && !HAVE_SOCKETPAIR */ + +#ifdef HAVE_NETDB_H +#include +#endif +#ifdef HAVE_NETINET_IN_H +#include /* for IPPROTO_TCP */ +#endif +#ifdef HAVE_ARPA_INET_H +#include +#endif + +#ifndef INADDR_LOOPBACK +#define INADDR_LOOPBACK 0x7f000001 +#endif + +#include "select.h" /* for Curl_poll */ + +static int wakeup_inet(curl_socket_t socks[2], bool nonblocking) +{ + union { + struct sockaddr_in inaddr; + struct sockaddr addr; + } a; + curl_socket_t listener; + curl_socklen_t addrlen = sizeof(a.inaddr); + int reuse = 1; + struct pollfd pfd[1]; + + listener = CURL_SOCKET(AF_INET, SOCK_STREAM, IPPROTO_TCP); + if(listener == CURL_SOCKET_BAD) + return -1; + + memset(&a, 0, sizeof(a)); + a.inaddr.sin_family = AF_INET; + a.inaddr.sin_addr.s_addr = htonl(INADDR_LOOPBACK); + a.inaddr.sin_port = 0; + + socks[0] = socks[1] = CURL_SOCKET_BAD; + +#if defined(_WIN32) || defined(__CYGWIN__) + /* do not set SO_REUSEADDR on Windows */ + (void)reuse; +#ifdef SO_EXCLUSIVEADDRUSE + { + int exclusive = 1; + if(setsockopt(listener, SOL_SOCKET, SO_EXCLUSIVEADDRUSE, + (char *)&exclusive, (curl_socklen_t)sizeof(exclusive)) == -1) + goto error; + } +#endif +#else + if(setsockopt(listener, SOL_SOCKET, SO_REUSEADDR, + (char *)&reuse, (curl_socklen_t)sizeof(reuse)) == -1) + goto error; +#endif + if(bind(listener, &a.addr, sizeof(a.inaddr)) == -1) + goto error; + if(getsockname(listener, &a.addr, &addrlen) == -1 || + addrlen < (int)sizeof(a.inaddr)) + goto error; + if(listen(listener, 1) == -1) + goto error; + socks[0] = CURL_SOCKET(AF_INET, SOCK_STREAM, 0); + if(socks[0] == CURL_SOCKET_BAD) + goto error; + if(connect(socks[0], &a.addr, sizeof(a.inaddr)) == -1) + goto error; + + /* use non-blocking accept to make sure we do not block forever */ + if(curlx_nonblock(listener, TRUE) < 0) + goto error; + pfd[0].fd = listener; + pfd[0].events = POLLIN; + pfd[0].revents = 0; + (void)Curl_poll(pfd, 1, 1000); /* one second */ + socks[1] = CURL_ACCEPT(listener, NULL, NULL); + if(socks[1] == CURL_SOCKET_BAD) + goto error; + else { + struct curltime start = curlx_now(); + char rnd[9]; + char check[sizeof(rnd)]; + char *p = &check[0]; + size_t s = sizeof(check); + + if(Curl_rand(NULL, (unsigned char *)rnd, sizeof(rnd))) + goto error; + + /* write data to the socket */ + swrite(socks[0], rnd, sizeof(rnd)); + /* verify that we read the correct data */ + do { + ssize_t nread; + + pfd[0].fd = socks[1]; + pfd[0].events = POLLIN; + pfd[0].revents = 0; + (void)Curl_poll(pfd, 1, 1000); /* one second */ + + nread = sread(socks[1], p, s); + if(nread == -1) { + int sockerr = SOCKERRNO; + /* Do not block forever */ + if(curlx_timediff_ms(curlx_now(), start) > (60 * 1000)) + goto error; + if(SOCK_EAGAIN(sockerr) +#ifndef USE_WINSOCK + || (sockerr == SOCKEINTR) || (sockerr == SOCKEINPROGRESS) +#endif + ) { + continue; + } + goto error; + } + s -= nread; + if(s) { + p += nread; + continue; + } + if(memcmp(rnd, check, sizeof(check))) + goto error; + break; + } while(1); + } + + if(nonblocking) + if(curlx_nonblock(socks[0], TRUE) < 0 || + curlx_nonblock(socks[1], TRUE) < 0) + goto error; +#ifdef USE_SO_NOSIGPIPE + if(Curl_sock_nosigpipe(socks[1]) < 0) + goto error; +#endif + sclose(listener); + return 0; + +error: + sclose(listener); + sclose(socks[0]); + sclose(socks[1]); + socks[0] = socks[1] = CURL_SOCKET_BAD; + return -1; +} + +#endif /* choose implementation */ + +int Curl_wakeup_init(curl_socket_t socks[2], bool nonblocking) +{ +#ifdef USE_EVENTFD + return wakeup_eventfd(socks, nonblocking); +#elif defined(HAVE_PIPE) + return wakeup_pipe(socks, nonblocking); +#elif defined(HAVE_SOCKETPAIR) + return wakeup_socketpair(socks, nonblocking); +#else + return wakeup_inet(socks, nonblocking); +#endif +} + +#if defined(USE_EVENTFD) || defined(HAVE_PIPE) + +#define wakeup_write write +#define wakeup_read read +#define wakeup_close close + +#else /* !USE_EVENTFD && !HAVE_PIPE */ + +#define wakeup_write swrite +#define wakeup_read sread +#define wakeup_close sclose + +#endif + +int Curl_wakeup_signal(curl_socket_t socks[2]) +{ + int sockerr = 0; +#ifdef USE_EVENTFD + const uint64_t buf[1] = { 1 }; +#else + const char buf[1] = { 1 }; +#endif + + while(1) { + sockerr = 0; + if(wakeup_write(socks[1], buf, sizeof(buf)) < 0) { + sockerr = SOCKERRNO; +#ifndef USE_WINSOCK + if(sockerr == SOCKEINTR) + continue; +#endif + if(SOCK_EAGAIN(sockerr)) + sockerr = 0; /* wakeup is already ongoing */ + } + break; + } + return sockerr; +} + +CURLcode Curl_wakeup_consume(curl_socket_t socks[2], bool all) +{ + char buf[64]; + ssize_t rc; + CURLcode result = CURLE_OK; + + do { + rc = wakeup_read(socks[0], buf, sizeof(buf)); + if(!rc) + break; + else if(rc < 0) { + int sockerr = SOCKERRNO; +#ifndef USE_WINSOCK + if(sockerr == SOCKEINTR) + continue; +#endif + if(SOCK_EAGAIN(sockerr)) + break; + result = CURLE_READ_ERROR; + break; + } + } while(all); + return result; +} + +void Curl_wakeup_destroy(curl_socket_t socks[2]) +{ +#ifndef USE_EVENTFD + if(socks[1] != CURL_SOCKET_BAD) + wakeup_close(socks[1]); +#endif + if(socks[0] != CURL_SOCKET_BAD) + wakeup_close(socks[0]); + socks[0] = socks[1] = CURL_SOCKET_BAD; +} + +#endif /* !CURL_DISABLE_SOCKETPAIR */ diff --git a/3rdparty/curl-8.21.0/lib/socketpair.h b/3rdparty/curl-8.21.0/lib/socketpair.h new file mode 100644 index 0000000000..fd08c879da --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/socketpair.h @@ -0,0 +1,43 @@ +#ifndef HEADER_CURL_SOCKETPAIR_H +#define HEADER_CURL_SOCKETPAIR_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifndef CURL_DISABLE_SOCKETPAIR + +/* return < 0 for failure to initialize */ +int Curl_wakeup_init(curl_socket_t socks[2], bool nonblocking); +void Curl_wakeup_destroy(curl_socket_t socks[2]); + +/* return 0 on success or errno on failure */ +int Curl_wakeup_signal(curl_socket_t socks[2]); + +CURLcode Curl_wakeup_consume(curl_socket_t socks[2], bool all); + +#else +#define Curl_wakeup_destroy(x) Curl_nop_stmt +#endif + +#endif /* HEADER_CURL_SOCKETPAIR_H */ diff --git a/3rdparty/curl-8.21.0/lib/socks.c b/3rdparty/curl-8.21.0/lib/socks.c new file mode 100644 index 0000000000..6c458c505d --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/socks.c @@ -0,0 +1,1391 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifndef CURL_DISABLE_PROXY + +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_ARPA_INET_H +#include +#endif + +#include "urldata.h" +#include "bufq.h" +#include "curl_addrinfo.h" +#include "curl_trc.h" +#include "select.h" +#include "cfilters.h" +#include "cf-dns.h" +#include "connect.h" +#include "socks.h" +#include "curlx/inet_pton.h" + +/* for the (SOCKS) connect state machine */ +enum socks_state_t { + SOCKS_ST_INIT, + /* SOCKS Version 4 states */ + SOCKS4_ST_START, + SOCKS4_ST_RESOLVING, + SOCKS4_ST_SEND, + SOCKS4_ST_RECV, + /* SOCKS Version 5 states */ + SOCKS5_ST_START, + SOCKS5_ST_REQ0_SEND, + SOCKS5_ST_RESP0_RECV, /* set up read */ + SOCKS5_ST_GSSAPI_INIT, + SOCKS5_ST_AUTH_INIT, /* setup outgoing auth buffer */ + SOCKS5_ST_AUTH_SEND, /* send auth */ + SOCKS5_ST_AUTH_RECV, /* read auth response */ + SOCKS5_ST_REQ1_INIT, /* init SOCKS "request" */ + SOCKS5_ST_RESOLVING, + SOCKS5_ST_REQ1_SEND, + SOCKS5_ST_RESP1_RECV, + /* Terminal states, all SOCKS versions */ + SOCKS_ST_SUCCESS, + SOCKS_ST_FAILED +}; + +#if defined(DEBUGBUILD) && defined(CURLVERBOSE) +static const char * const cf_socks_statename[] = { + "SOCKS_INIT", + "SOCKS4_START", + "SOCKS4_RESOLVING", + "SOCKS4_SEND", + "SOCKS4_RECV", + "SOCKS5_START", + "SOCKS5_REQ0_SEND", + "SOCKS5_RESP0_RECV", + "SOCKS5_GSSAPI_INIT", + "SOCKS5_AUTH_INIT", + "SOCKS5_AUTH_SEND", + "SOCKS5_AUTH_RECV", + "SOCKS5_REQ1_INIT", + "SOCKS5_RESOLVING", + "SOCKS5_REQ1_SEND", + "SOCKS5_RESP1_RECV", + "SOCKS_SUCCESS", + "SOCKS_FAILED" +}; +#endif + +#define SOCKS_CHUNK_SIZE 1024 +#define SOCKS_CHUNKS 1 + +struct socks_ctx { + enum socks_state_t state; + struct bufq iobuf; + struct Curl_peer *dest; + struct Curl_creds *creds; + CURLproxycode presult; + uint32_t resolv_id; + uint8_t ip_version; + uint8_t proxy_type; + unsigned char version; + BIT(resolve_local); + BIT(start_resolving); + BIT(socks4a); +}; + +#if defined(HAVE_GSSAPI) || defined(USE_WINDOWS_SSPI) +/* + * Helper read-from-socket functions. Does the same as Curl_read() but it + * blocks until all bytes amount of buffersize will be read. No more, no less. + * + * This is STUPID BLOCKING behavior. Only used by the SOCKS GSSAPI functions. + */ +CURLcode Curl_blockread_all(struct Curl_cfilter *cf, + struct Curl_easy *data, + char *buf, /* store read data here */ + size_t blen, /* space in buf */ + size_t *pnread) /* amount bytes read */ +{ + size_t nread = 0; + CURLcode result; + + *pnread = 0; + for(;;) { + timediff_t timeout_ms = Curl_timeleft_ms(data); + curl_socket_t sock = Curl_conn_cf_get_socket(cf, data); + + if(timeout_ms < 0) { + /* we already got the timeout */ + return CURLE_OPERATION_TIMEDOUT; + } + if(!timeout_ms) + timeout_ms = TIMEDIFF_T_MAX; + if(SOCKET_READABLE(sock, timeout_ms) <= 0) + return CURLE_OPERATION_TIMEDOUT; + result = Curl_conn_cf_recv(cf->next, data, buf, blen, &nread); + if(result == CURLE_AGAIN) + continue; + else if(result) + return result; + + if(blen == nread) { + *pnread += nread; + return CURLE_OK; + } + if(!nread) /* EOF */ + return CURLE_RECV_ERROR; + + buf += nread; + blen -= nread; + *pnread += nread; + } +} +#endif + +#if defined(DEBUGBUILD) && defined(CURLVERBOSE) +#define sxstate(x, c, d, y) socksstate(x, c, d, y, __LINE__) +#else +#define sxstate(x, c, d, y) socksstate(x, c, d, y) +#endif + +/* always use this function to change state, to make debugging easier */ +static void socksstate(struct socks_ctx *sx, + struct Curl_cfilter *cf, + struct Curl_easy *data, + enum socks_state_t state +#if defined(DEBUGBUILD) && defined(CURLVERBOSE) + , int lineno +#endif +) +{ + enum socks_state_t oldstate = sx->state; + + if(oldstate == state) + /* do not bother when the new state is the same as the old state */ + return; + + sx->state = state; + +#if defined(DEBUGBUILD) && defined(CURLVERBOSE) + CURL_TRC_CF(data, cf, "[%s] -> [%s] (line %d)", + cf_socks_statename[oldstate], + cf_socks_statename[sx->state], lineno); +#else + (void)cf; + (void)data; +#endif +} + +static CURLproxycode socks_failed(struct socks_ctx *sx, + struct Curl_cfilter *cf, + struct Curl_easy *data, + CURLproxycode presult) +{ + sxstate(sx, cf, data, SOCKS_ST_FAILED); + sx->presult = presult; + return presult; +} + +static CURLproxycode socks_flush(struct socks_ctx *sx, + struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ + CURLcode result; + size_t nwritten; + + *done = FALSE; + while(!Curl_bufq_is_empty(&sx->iobuf)) { + result = Curl_cf_send_bufq(cf->next, data, &sx->iobuf, NULL, 0, + &nwritten); + if(result == CURLE_AGAIN) + return CURLPX_OK; + else if(result) { + failf(data, "Failed to send SOCKS request: %s", + curl_easy_strerror(result)); + return socks_failed(sx, cf, data, CURLPX_SEND_CONNECT); + } + } + *done = TRUE; + return CURLPX_OK; +} + +static CURLproxycode socks_recv(struct socks_ctx *sx, + struct Curl_cfilter *cf, + struct Curl_easy *data, + size_t min_bytes, + bool *done) +{ + CURLcode result; + size_t nread; + + *done = FALSE; + while(Curl_bufq_len(&sx->iobuf) < min_bytes) { + result = Curl_cf_recv_bufq(cf->next, data, &sx->iobuf, + min_bytes - Curl_bufq_len(&sx->iobuf), + &nread); + if(result == CURLE_AGAIN) + return CURLPX_OK; + else if(result) { + failf(data, "Failed to receive SOCKS response: %s", + curl_easy_strerror(result)); + return CURLPX_RECV_CONNECT; + } + else if(!nread) { /* EOF */ + if(Curl_bufq_len(&sx->iobuf) < min_bytes) { + failf(data, "Failed to receive SOCKS response, " + "proxy closed connection"); + return CURLPX_RECV_CONNECT; + } + break; + } + } + *done = TRUE; + return CURLPX_OK; +} + +static CURLproxycode socks4_req_add_hd(struct socks_ctx *sx, + struct Curl_easy *data) +{ + unsigned char buf[4]; + size_t nwritten; + CURLcode result; + + (void)data; + buf[0] = 4; /* version (SOCKS4) */ + buf[1] = 1; /* connect */ + buf[2] = (unsigned char)((sx->dest->port >> 8) & 0xffU); /* MSB */ + buf[3] = (unsigned char)(sx->dest->port & 0xffU); /* LSB */ + + result = Curl_bufq_write(&sx->iobuf, buf, 4, &nwritten); + if(result || (nwritten != 4)) + return CURLPX_SEND_REQUEST; + return CURLPX_OK; +} + +static CURLproxycode socks4_req_add_user(struct socks_ctx *sx, + struct Curl_easy *data) +{ + CURLcode result; + size_t nwritten; + + if(sx->creds) { + size_t plen = strlen(sx->creds->user); + if(plen > 255) { + /* there is no real size limit to this field in the protocol, but + SOCKS5 limits the proxy user field to 255 bytes and it seems likely + that a longer field is either a mistake or malicious input */ + failf(data, "Too long SOCKS proxy username"); + return CURLPX_LONG_USER; + } + /* add proxy name WITH trailing zero */ + result = Curl_bufq_cwrite(&sx->iobuf, sx->creds->user, plen + 1, + &nwritten); + if(result || (nwritten != (plen + 1))) + return CURLPX_SEND_REQUEST; + } + else { + /* empty username */ + unsigned char b = 0; + result = Curl_bufq_write(&sx->iobuf, &b, 1, &nwritten); + if(result || (nwritten != 1)) + return CURLPX_SEND_REQUEST; + } + return CURLPX_OK; +} + +static CURLproxycode socks4_resolving(struct socks_ctx *sx, + struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ + const struct Curl_addrinfo *ai = NULL; + CURLcode result; + size_t nwritten; + bool dns_done; + + *done = FALSE; + if(sx->start_resolving) { + /* need to resolve hostname to add destination address */ + sx->start_resolving = FALSE; + result = Curl_cf_dns_insert_after( + cf, data, Curl_resolv_dns_queries(data, sx->ip_version), + sx->dest, TRNSPRT_TCP, TRUE); + if(result) { + failf(data, "unable to create DNS filter for socks"); + return CURLPX_UNKNOWN_FAIL; + } + } + + /* resolve the hostname by connecting the DNS filter */ + result = Curl_conn_cf_connect(cf->next, data, &dns_done); + if(result) { + failf(data, "Failed to resolve \"%s\" for SOCKS4 connect.", + sx->dest->hostname); + return CURLPX_RESOLVE_HOST; + } + else if(!dns_done) + return CURLPX_OK; + + ai = Curl_cf_dns_get_ai(cf->next, data, sx->dest, AF_INET, 0); + if(ai) { + struct sockaddr_in *saddr_in; + char ipbuf[64]; + + Curl_printable_address(ai, ipbuf, sizeof(ipbuf)); + CURL_TRC_CF(data, cf, "SOCKS4 connect to IPv4 %s (locally resolved)", + ipbuf); + + saddr_in = (struct sockaddr_in *)(void *)ai->ai_addr; + result = Curl_bufq_write(&sx->iobuf, + (unsigned char *)&saddr_in->sin_addr.s_addr, 4, + &nwritten); + + if(result || (nwritten != 4)) + return CURLPX_SEND_REQUEST; + } + else { + /* No ipv4 address resolved */ + failf(data, "SOCKS4 connection to %s not supported", sx->dest->hostname); + return CURLPX_RESOLVE_HOST; + } + + *done = TRUE; + return CURLPX_OK; +} + +static CURLproxycode socks4_check_resp(struct socks_ctx *sx, + struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + const unsigned char *resp; + size_t rlen; + + if(!Curl_bufq_peek(&sx->iobuf, &resp, &rlen) || rlen < 8) { + failf(data, "SOCKS4 reply is incomplete."); + return CURLPX_RECV_CONNECT; + } + + DEBUGASSERT(rlen == 8); + /* + * Response format + * + * +----+----+----+----+----+----+----+----+ + * | VN | CD | DSTPORT | DSTIP | + * +----+----+----+----+----+----+----+----+ + * # of bytes: 1 1 2 4 + * + * VN is the version of the reply code and should be 0. CD is the result + * code with one of the following values: + * + * 90: request granted + * 91: request rejected or failed + * 92: request rejected because SOCKS server cannot connect to + * identd on the client + * 93: request rejected because the client program and identd + * report different user-ids + */ + + /* wrong version ? */ + if(resp[0]) { + failf(data, "SOCKS4 reply has wrong version, version should be 0."); + return CURLPX_BAD_VERSION; + } + + /* Result */ + switch(resp[1]) { + case 90: + CURL_TRC_CF(data, cf, "SOCKS4%s request granted.", sx->socks4a ? "a" : ""); + Curl_bufq_skip(&sx->iobuf, 8); + return CURLPX_OK; + case 91: + failf(data, + "[SOCKS] cannot complete SOCKS4 connection to %u.%u.%u.%u:%u. (%u)" + ", request rejected or failed.", + resp[4], resp[5], resp[6], resp[7], + (unsigned int)((resp[2] << 8) | resp[3]), resp[1]); + return CURLPX_REQUEST_FAILED; + case 92: + failf(data, + "[SOCKS] cannot complete SOCKS4 connection to %u.%u.%u.%u:%u. (%u)" + ", request rejected because SOCKS server cannot connect to " + "identd on the client.", + resp[4], resp[5], resp[6], resp[7], + (unsigned int)((resp[2] << 8) | resp[3]), resp[1]); + return CURLPX_IDENTD; + case 93: + failf(data, + "[SOCKS] cannot complete SOCKS4 connection to %u.%u.%u.%u:%u. (%u)" + ", request rejected because the client program and identd " + "report different user-ids.", + resp[4], resp[5], resp[6], resp[7], + (unsigned int)((resp[2] << 8) | resp[3]), resp[1]); + return CURLPX_IDENTD_DIFFER; + default: + failf(data, + "[SOCKS] cannot complete SOCKS4 connection to %u.%u.%u.%u:%u. (%u)" + ", Unknown.", + resp[4], resp[5], resp[6], resp[7], + (unsigned int)((resp[2] << 8) | resp[3]), resp[1]); + return CURLPX_UNKNOWN_FAIL; + } +} + +/* + * This function logs in to a SOCKS4 proxy and sends the specifics to the final + * destination server. + * + * Reference : + * https://www.openssh.com/txt/socks4.protocol + * + * Note : + * Set protocol4a=true for "SOCKS 4A (Simple Extension to SOCKS 4 Protocol)" + * Nonsupport "Identification Protocol (RFC1413)" + */ +static CURLproxycode socks4_connect(struct Curl_cfilter *cf, + struct socks_ctx *sx, + struct Curl_easy *data) +{ + size_t nwritten; + CURLproxycode presult; + CURLcode result; + bool done; + +process_state: + switch(sx->state) { + case SOCKS_ST_INIT: + sx->version = 4; + sxstate(sx, cf, data, SOCKS4_ST_START); + FALLTHROUGH(); + + case SOCKS4_ST_START: + Curl_bufq_reset(&sx->iobuf); + sx->start_resolving = FALSE; + sx->socks4a = (sx->proxy_type == CURLPROXY_SOCKS4A); + sx->resolve_local = !sx->socks4a; + sx->presult = CURLPX_OK; + + /* SOCKS4 can only do IPv4, insist! */ + sx->ip_version = CURL_IPRESOLVE_V4; + CURL_TRC_CF(data, cf, "SOCKS4%s connecting to %s:%u", + sx->socks4a ? "a" : "", + sx->dest->hostname, sx->dest->port); + + /* + * Compose socks4 request + * + * Request format + * + * +----+----+----+----+----+----+----+----+----+----+....+----+ + * | VN | CD | DSTPORT | DSTIP | USERID |NULL| + * +----+----+----+----+----+----+----+----+----+----+....+----+ + * # of bytes: 1 1 2 4 variable 1 + */ + presult = socks4_req_add_hd(sx, data); + if(presult) + return socks_failed(sx, cf, data, presult); + + /* DNS resolve only for SOCKS4, not SOCKS4a */ + if(!sx->resolve_local) { + /* socks4a, not resolving locally, sends the hostname. + * add an invalid address + user + hostname */ + unsigned char buf[4] = { 0, 0, 0, 1 }; + size_t hlen = strlen(sx->dest->hostname) + 1; /* including NUL */ + + if(hlen > 255) { + failf(data, "SOCKS4: too long hostname"); + return socks_failed(sx, cf, data, CURLPX_LONG_HOSTNAME); + } + result = Curl_bufq_write(&sx->iobuf, buf, 4, &nwritten); + if(result || (nwritten != 4)) + return socks_failed(sx, cf, data, CURLPX_SEND_REQUEST); + presult = socks4_req_add_user(sx, data); + if(presult) + return socks_failed(sx, cf, data, presult); + result = Curl_bufq_cwrite(&sx->iobuf, sx->dest->hostname, hlen, + &nwritten); + if(result || (nwritten != hlen)) + return socks_failed(sx, cf, data, CURLPX_SEND_REQUEST); + /* request complete */ + sxstate(sx, cf, data, SOCKS4_ST_SEND); + goto process_state; + } + sx->start_resolving = TRUE; + sxstate(sx, cf, data, SOCKS4_ST_RESOLVING); + FALLTHROUGH(); + + case SOCKS4_ST_RESOLVING: + presult = socks4_resolving(sx, cf, data, &done); + if(presult) + return socks_failed(sx, cf, data, presult); + if(!done) + return CURLPX_OK; + /* append user */ + presult = socks4_req_add_user(sx, data); + if(presult) + return socks_failed(sx, cf, data, presult); + sxstate(sx, cf, data, SOCKS4_ST_SEND); + FALLTHROUGH(); + + case SOCKS4_ST_SEND: + presult = socks_flush(sx, cf, data, &done); + if(presult) + return socks_failed(sx, cf, data, presult); + else if(!done) + return CURLPX_OK; + sxstate(sx, cf, data, SOCKS4_ST_RECV); + FALLTHROUGH(); + + case SOCKS4_ST_RECV: + /* Receive 8-byte response */ + presult = socks_recv(sx, cf, data, 8, &done); + if(presult) + return socks_failed(sx, cf, data, presult); + else if(!done) + return CURLPX_OK; + presult = socks4_check_resp(sx, cf, data); + if(presult) + return socks_failed(sx, cf, data, presult); + sxstate(sx, cf, data, SOCKS_ST_SUCCESS); + FALLTHROUGH(); + + case SOCKS_ST_SUCCESS: + return CURLPX_OK; + + case SOCKS_ST_FAILED: + DEBUGASSERT(sx->presult); + return sx->presult; + + default: + DEBUGASSERT(0); + return socks_failed(sx, cf, data, CURLPX_SEND_REQUEST); + } +} + +static CURLproxycode socks5_req0_init(struct Curl_cfilter *cf, + struct socks_ctx *sx, + struct Curl_easy *data) +{ + const unsigned char auth = data->set.socks5auth; + unsigned char req[5]; /* version + len + 3 possible auth methods */ + unsigned char nauths; + size_t req_len, nwritten; + CURLcode result; + + (void)cf; + /* RFC1928 chapter 5 specifies max 255 chars for domain name in packet */ + if(!sx->resolve_local && strlen(sx->dest->hostname) > 255) { + failf(data, "SOCKS5: the destination hostname is too long to be " + "resolved remotely by the proxy."); + return CURLPX_LONG_HOSTNAME; + } + + if(auth & ~(CURLAUTH_BASIC | CURLAUTH_GSSAPI)) + infof(data, "warning: unsupported value passed to " + "CURLOPT_SOCKS5_AUTH: %u", auth); + if(!(auth & CURLAUTH_BASIC)) + /* disable username/password auth */ + Curl_creds_unlink(&sx->creds); + + req[0] = 5; /* version */ + nauths = 1; + req[1 + nauths] = 0; /* 1. no authentication */ +#if defined(HAVE_GSSAPI) || defined(USE_WINDOWS_SSPI) + if(auth & CURLAUTH_GSSAPI) { + ++nauths; + req[1 + nauths] = 1; /* GSS-API */ + } +#endif + if(sx->creds) { + ++nauths; + req[1 + nauths] = 2; /* username/password */ + } + req[1] = nauths; + req_len = 2 + nauths; + + result = Curl_bufq_write(&sx->iobuf, req, req_len, &nwritten); + if(result || (nwritten != req_len)) + return CURLPX_SEND_REQUEST; + return CURLPX_OK; +} + +static CURLproxycode socks5_check_resp0(struct socks_ctx *sx, + struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + const unsigned char *resp; + unsigned char auth_mode; + size_t rlen; + + if(!Curl_bufq_peek(&sx->iobuf, &resp, &rlen) || rlen < 2) { + failf(data, "SOCKS5 initial reply is incomplete."); + return CURLPX_RECV_CONNECT; + } + + if(resp[0] != 5) { + failf(data, "Received invalid version in initial SOCKS5 response."); + return CURLPX_BAD_VERSION; + } + + auth_mode = resp[1]; + Curl_bufq_skip(&sx->iobuf, 2); + + switch(auth_mode) { + case 0: + /* DONE! No authentication needed. Send request. */ + sxstate(sx, cf, data, SOCKS5_ST_REQ1_INIT); + return CURLPX_OK; + case 1: + if(data->set.socks5auth & CURLAUTH_GSSAPI) { + sxstate(sx, cf, data, SOCKS5_ST_GSSAPI_INIT); + return CURLPX_OK; + } + failf(data, "SOCKS5 GSSAPI per-message authentication is not enabled."); + return CURLPX_GSSAPI_PERMSG; + case 2: + /* regular name + password authentication */ + if(data->set.socks5auth & CURLAUTH_BASIC) { + sxstate(sx, cf, data, SOCKS5_ST_AUTH_INIT); + return CURLPX_OK; + } + failf(data, "BASIC authentication proposed but not enabled."); + return CURLPX_NO_AUTH; + case 255: + failf(data, "No authentication method was acceptable."); + return CURLPX_NO_AUTH; + default: + failf(data, "Unknown SOCKS5 mode attempted to be used by server."); + return CURLPX_UNKNOWN_MODE; + } +} + +static CURLproxycode socks5_auth_init(struct Curl_cfilter *cf, + struct socks_ctx *sx, + struct Curl_easy *data) +{ + /* Needs username and password */ + size_t ulen = 0, plen = 0, nwritten; + unsigned char buf[2]; + CURLcode result; + + if(sx->creds) { + ulen = strlen(sx->creds->user); + plen = strlen(sx->creds->passwd); + /* the lengths must fit in a single byte */ + if(ulen > 255) { + failf(data, "Excessive username length for proxy auth"); + return CURLPX_LONG_USER; + } + if(plen > 255) { + failf(data, "Excessive password length for proxy auth"); + return CURLPX_LONG_PASSWD; + } + } + + /* username/password request looks like + * +----+------+----------+------+----------+ + * |VER | ULEN | UNAME | PLEN | PASSWD | + * +----+------+----------+------+----------+ + * | 1 | 1 | 1 to 255 | 1 | 1 to 255 | + * +----+------+----------+------+----------+ + */ + buf[0] = 1; /* username/pw subnegotiation version */ + buf[1] = (unsigned char)ulen; + result = Curl_bufq_write(&sx->iobuf, buf, 2, &nwritten); + if(result || (nwritten != 2)) + return CURLPX_SEND_REQUEST; + if(ulen) { + result = Curl_bufq_cwrite(&sx->iobuf, sx->creds->user, ulen, &nwritten); + if(result || (nwritten != ulen)) + return CURLPX_SEND_REQUEST; + } + buf[0] = (unsigned char)plen; + result = Curl_bufq_write(&sx->iobuf, buf, 1, &nwritten); + if(result || (nwritten != 1)) + return CURLPX_SEND_REQUEST; + if(plen) { + result = Curl_bufq_cwrite(&sx->iobuf, sx->creds->passwd, plen, &nwritten); + if(result || (nwritten != plen)) + return CURLPX_SEND_REQUEST; + } + sxstate(sx, cf, data, SOCKS5_ST_AUTH_SEND); + return CURLPX_OK; +} + +static CURLproxycode socks5_check_auth_resp(struct socks_ctx *sx, + struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + const unsigned char *resp; + unsigned char auth_status; + size_t rlen; + + (void)cf; + if(!Curl_bufq_peek(&sx->iobuf, &resp, &rlen) || rlen < 2) { + failf(data, "SOCKS5 sub-negotiation response incomplete."); + return CURLPX_RECV_CONNECT; + } + + /* ignore the first (VER) byte */ + auth_status = resp[1]; + if(auth_status) { + failf(data, "User was rejected by the SOCKS5 server (%d %d).", + resp[0], resp[1]); + return CURLPX_USER_REJECTED; + } + Curl_bufq_skip(&sx->iobuf, 2); + return CURLPX_OK; +} + +static CURLproxycode socks5_req1_init(struct socks_ctx *sx, + struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + unsigned char req[5]; + unsigned char ipbuf[16]; + const unsigned char *destination; + unsigned char desttype, destlen, hdlen; + size_t nwritten; + CURLcode result; + + req[0] = 5; /* version (SOCKS5) */ + req[1] = 1; /* connect */ + req[2] = 0; /* must be zero */ + if(sx->resolve_local) { + /* rest of request is added after resolving */ + result = Curl_bufq_write(&sx->iobuf, req, 3, &nwritten); + if(result || (nwritten != 3)) + return CURLPX_SEND_REQUEST; + return CURLPX_OK; + } + + /* remote resolving, send what type+addr/string to resolve */ +#ifdef USE_IPV6 + if(strchr(sx->dest->hostname, ':')) { + desttype = 4; + destination = ipbuf; + destlen = 16; + if(curlx_inet_pton(AF_INET6, sx->dest->hostname, ipbuf) != 1) + return CURLPX_BAD_ADDRESS_TYPE; + } + else +#endif + if(curlx_inet_pton(AF_INET, sx->dest->hostname, ipbuf) == 1) { + desttype = 1; + destination = ipbuf; + destlen = 4; + } + else { + const size_t hostname_len = strlen(sx->dest->hostname); + /* socks5_req0_init() already rejects hostnames longer than 255 bytes, so + this cast to unsigned char is safe. Assert to guard against future + refactoring that might remove or reorder that earlier check. */ + DEBUGASSERT(hostname_len <= 255); + desttype = 3; + destination = (const unsigned char *)sx->dest->hostname; + destlen = (unsigned char)hostname_len; /* 1-byte length */ + } + + req[3] = desttype; + req[4] = destlen; + hdlen = (desttype == 3) ? 5 : 4; /* no length byte for ip addresses */ + result = Curl_bufq_write(&sx->iobuf, req, hdlen, &nwritten); + if(result || (nwritten != hdlen)) + return CURLPX_SEND_REQUEST; + result = Curl_bufq_write(&sx->iobuf, destination, destlen, &nwritten); + if(result || (nwritten != destlen)) + return CURLPX_SEND_REQUEST; + /* PORT MSB+LSB */ + req[0] = (unsigned char)((sx->dest->port >> 8) & 0xff); + req[1] = (unsigned char)(sx->dest->port & 0xff); + result = Curl_bufq_write(&sx->iobuf, req, 2, &nwritten); + if(result || (nwritten != 2)) + return CURLPX_SEND_REQUEST; + CURL_TRC_CF(data, cf, "SOCKS5 connect to %s:%u (remotely resolved)", + sx->dest->hostname, sx->dest->port); + return CURLPX_OK; +} + +static CURLproxycode socks5_resolving(struct socks_ctx *sx, + struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ + const struct Curl_addrinfo *ai = NULL; + char dest[MAX_IPADR_LEN]; /* printable address */ + const unsigned char *destination = NULL; + unsigned char desttype = 1, destlen = 4; + unsigned char req[2]; + CURLcode result; + CURLproxycode presult = CURLPX_OK; + size_t nwritten; + bool dns_done; + + *done = FALSE; + if(sx->start_resolving) { + /* need to resolve hostname to add destination address */ + sx->start_resolving = FALSE; + result = Curl_cf_dns_insert_after( + cf, data, Curl_resolv_dns_queries(data, sx->ip_version), + sx->dest, TRNSPRT_TCP, TRUE); + if(result) { + failf(data, "unable to create DNS filter for socks"); + return CURLPX_UNKNOWN_FAIL; + } + } + + /* resolve the hostname by connecting the DNS filter */ + result = Curl_conn_cf_connect(cf->next, data, &dns_done); + if(result) { + failf(data, "Failed to resolve \"%s\" for SOCKS5 connect.", + sx->dest->hostname); + return CURLPX_RESOLVE_HOST; + } + else if(!dns_done) + return CURLPX_OK; + +#ifdef USE_IPV6 + if(data->set.ipver != CURL_IPRESOLVE_V4) + ai = Curl_cf_dns_get_ai(cf->next, data, sx->dest, AF_INET6, 0); +#endif + if(!ai) + ai = Curl_cf_dns_get_ai(cf->next, data, sx->dest, AF_INET, 0); + + if(!ai) { + failf(data, "Failed to resolve \"%s\" for SOCKS5 connect.", + sx->dest->hostname); + presult = CURLPX_RESOLVE_HOST; + goto out; + } + + Curl_printable_address(ai, dest, sizeof(dest)); + + if(ai->ai_family == AF_INET) { + struct sockaddr_in *saddr_in; + desttype = 1; /* ATYP: IPv4 = 1 */ + destlen = 4; + saddr_in = (struct sockaddr_in *)(void *)ai->ai_addr; + destination = (const unsigned char *)&saddr_in->sin_addr.s_addr; + CURL_TRC_CF(data, cf, "SOCKS5 connect to %s:%u (locally resolved)", + dest, sx->dest->port); + } +#ifdef USE_IPV6 + else if(ai->ai_family == AF_INET6) { + struct sockaddr_in6 *saddr_in6; + desttype = 4; /* ATYP: IPv6 = 4 */ + destlen = 16; + saddr_in6 = (struct sockaddr_in6 *)(void *)ai->ai_addr; + destination = (const unsigned char *)&saddr_in6->sin6_addr.s6_addr; + CURL_TRC_CF(data, cf, "SOCKS5 connect to [%s]:%u (locally resolved)", + dest, sx->dest->port); + } +#endif + + if(!destination) { + failf(data, "SOCKS5 connection to %s not supported", dest); + presult = CURLPX_RESOLVE_HOST; + goto out; + } + + req[0] = desttype; + result = Curl_bufq_write(&sx->iobuf, req, 1, &nwritten); + if(result || (nwritten != 1)) { + presult = CURLPX_SEND_REQUEST; + goto out; + } + result = Curl_bufq_write(&sx->iobuf, destination, destlen, &nwritten); + if(result || (nwritten != destlen)) { + presult = CURLPX_SEND_REQUEST; + goto out; + } + /* PORT MSB+LSB */ + req[0] = (unsigned char)((sx->dest->port >> 8) & 0xffU); + req[1] = (unsigned char)(sx->dest->port & 0xffU); + result = Curl_bufq_write(&sx->iobuf, req, 2, &nwritten); + if(result || (nwritten != 2)) { + presult = CURLPX_SEND_REQUEST; + goto out; + } + +out: + *done = (presult == CURLPX_OK); + return presult; +} + +static CURLproxycode socks5_recv_resp1(struct socks_ctx *sx, + struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ + const unsigned char *resp; + size_t rlen, resp_len = 8; /* minimum response length */ + CURLproxycode presult; + + presult = socks_recv(sx, cf, data, resp_len, done); + if(presult) + return presult; + else if(!*done) + return CURLPX_OK; + + if(!Curl_bufq_peek(&sx->iobuf, &resp, &rlen) || rlen < resp_len) { + failf(data, "SOCKS5 response is incomplete."); + return CURLPX_RECV_CONNECT; + } + + /* Response packet includes BND.ADDR is variable length parameter by RFC + 1928, so the response packet MUST be read until the end to avoid errors + at subsequent protocol level. + + +----+-----+-------+------+----------+----------+ + |VER | REP | RSV | ATYP | BND.ADDR | BND.PORT | + +----+-----+-------+------+----------+----------+ + | 1 | 1 | 0x00 | 1 | Variable | 2 | + +----+-----+-------+------+----------+----------+ + + ATYP: + o IPv4 address: 0x01, BND.ADDR = 4-byte + o domain name: 0x03, BND.ADDR = [ 1-byte length, string ] + o IPv6 address: 0x04, BND.ADDR = 16-byte + */ + if(resp[0] != 5) { /* version */ + failf(data, "SOCKS5 reply has wrong version, version should be 5."); + return CURLPX_BAD_VERSION; + } + else if(resp[1]) { /* Anything besides 0 is an error */ + CURLproxycode rc = CURLPX_REPLY_UNASSIGNED; + int code = resp[1]; + failf(data, "cannot complete SOCKS5 connection to %s. (%d)", + sx->dest->hostname, code); + if(code < 9) { + /* RFC 1928 section 6 lists: */ + static const CURLproxycode lookup[] = { + CURLPX_OK, + CURLPX_REPLY_GENERAL_SERVER_FAILURE, + CURLPX_REPLY_NOT_ALLOWED, + CURLPX_REPLY_NETWORK_UNREACHABLE, + CURLPX_REPLY_HOST_UNREACHABLE, + CURLPX_REPLY_CONNECTION_REFUSED, + CURLPX_REPLY_TTL_EXPIRED, + CURLPX_REPLY_COMMAND_NOT_SUPPORTED, + CURLPX_REPLY_ADDRESS_TYPE_NOT_SUPPORTED, + }; + rc = lookup[code]; + } + return rc; + } + + /* Calculate real packet size */ + switch(resp[3]) { + case 1: /* IPv4 */ + resp_len = 4 + 4 + 2; + break; + case 3: /* domain name */ + resp_len = 4 + 1 + resp[4] + 2; /* header, var length, var bytes, port */ + break; + case 4: /* IPv6 */ + resp_len = 4 + 16 + 2; + break; + default: + failf(data, "SOCKS5 reply has wrong address type."); + return CURLPX_BAD_ADDRESS_TYPE; + } + + /* receive the rest of the response */ + presult = socks_recv(sx, cf, data, resp_len, done); + if(presult) + return presult; + else if(!*done) + return CURLPX_OK; + + if(!Curl_bufq_peek(&sx->iobuf, &resp, &rlen) || rlen < resp_len) { + failf(data, "SOCKS5 response is incomplete."); + return CURLPX_RECV_CONNECT; + } + /* got it all */ + *done = TRUE; + return CURLPX_OK; +} + +/* + * This function logs in to a SOCKS5 proxy and sends the specifics to the final + * destination server. + */ +static CURLproxycode socks5_connect(struct Curl_cfilter *cf, + struct socks_ctx *sx, + struct Curl_easy *data) +{ + CURLproxycode presult; + bool done; + +process_state: + switch(sx->state) { + case SOCKS_ST_INIT: + sx->version = 5; + sx->resolve_local = (sx->proxy_type == CURLPROXY_SOCKS5); + sxstate(sx, cf, data, SOCKS5_ST_START); + FALLTHROUGH(); + + case SOCKS5_ST_START: + CURL_TRC_CF(data, cf, "SOCKS5: connecting to %s:%u", + sx->dest->hostname, sx->dest->port); + presult = socks5_req0_init(cf, sx, data); + if(presult) + return socks_failed(sx, cf, data, presult); + sxstate(sx, cf, data, SOCKS5_ST_REQ0_SEND); + FALLTHROUGH(); + + case SOCKS5_ST_REQ0_SEND: + presult = socks_flush(sx, cf, data, &done); + if(presult) + return socks_failed(sx, cf, data, presult); + else if(!done) + return CURLPX_OK; + /* done sending! */ + sxstate(sx, cf, data, SOCKS5_ST_RESP0_RECV); + FALLTHROUGH(); + + case SOCKS5_ST_RESP0_RECV: + presult = socks_recv(sx, cf, data, 2, &done); + if(presult) + return socks_failed(sx, cf, data, presult); + else if(!done) + return CURLPX_OK; + presult = socks5_check_resp0(sx, cf, data); + if(presult) + return socks_failed(sx, cf, data, presult); + /* socks5_check_resp0() sets next socks state */ + goto process_state; + + case SOCKS5_ST_GSSAPI_INIT: { +#if defined(HAVE_GSSAPI) || defined(USE_WINDOWS_SSPI) + /* GSSAPI stuff done non-blocking */ + CURLcode result = Curl_SOCKS5_gssapi_negotiate(cf, data, sx->creds); + if(result) { + failf(data, "Unable to negotiate SOCKS5 GSS-API context."); + return CURLPX_GSSAPI; + } + sxstate(sx, cf, data, SOCKS5_ST_REQ1_INIT); + goto process_state; +#else + failf(data, "SOCKS5 GSSAPI per-message authentication is not supported."); + return socks_failed(sx, cf, data, CURLPX_GSSAPI_PERMSG); +#endif + } + + case SOCKS5_ST_AUTH_INIT: + presult = socks5_auth_init(cf, sx, data); + if(presult) + return socks_failed(sx, cf, data, presult); + sxstate(sx, cf, data, SOCKS5_ST_AUTH_SEND); + FALLTHROUGH(); + + case SOCKS5_ST_AUTH_SEND: + presult = socks_flush(sx, cf, data, &done); + if(presult) + return socks_failed(sx, cf, data, presult); + else if(!done) + return CURLPX_OK; + sxstate(sx, cf, data, SOCKS5_ST_AUTH_RECV); + FALLTHROUGH(); + + case SOCKS5_ST_AUTH_RECV: + presult = socks_recv(sx, cf, data, 2, &done); + if(presult) + return socks_failed(sx, cf, data, presult); + else if(!done) + return CURLPX_OK; + presult = socks5_check_auth_resp(sx, cf, data); + if(presult) + return socks_failed(sx, cf, data, presult); + /* Everything is good so far, user was authenticated! */ + sxstate(sx, cf, data, SOCKS5_ST_REQ1_INIT); + FALLTHROUGH(); + + case SOCKS5_ST_REQ1_INIT: + presult = socks5_req1_init(sx, cf, data); + if(presult) + return socks_failed(sx, cf, data, presult); + if(!sx->resolve_local) { + /* we do not resolve, request is complete */ + sxstate(sx, cf, data, SOCKS5_ST_REQ1_SEND); + goto process_state; + } + sx->start_resolving = TRUE; + sxstate(sx, cf, data, SOCKS5_ST_RESOLVING); + FALLTHROUGH(); + + case SOCKS5_ST_RESOLVING: + presult = socks5_resolving(sx, cf, data, &done); + if(presult) + return socks_failed(sx, cf, data, presult); + if(!done) + return CURLPX_OK; + sxstate(sx, cf, data, SOCKS5_ST_REQ1_SEND); + FALLTHROUGH(); + + case SOCKS5_ST_REQ1_SEND: + presult = socks_flush(sx, cf, data, &done); + if(presult) + return socks_failed(sx, cf, data, presult); + else if(!done) + return CURLPX_OK; +#if defined(HAVE_GSSAPI) || defined(USE_WINDOWS_SSPI) + if(cf->conn->socks5_gssapi_enctype) { + failf(data, "SOCKS5 GSS-API protection not yet implemented."); + return CURLPX_GSSAPI_PROTECTION; + } +#endif + sxstate(sx, cf, data, SOCKS5_ST_RESP1_RECV); + FALLTHROUGH(); + + case SOCKS5_ST_RESP1_RECV: + presult = socks5_recv_resp1(sx, cf, data, &done); + if(presult) + return socks_failed(sx, cf, data, presult); + if(!done) + return CURLPX_OK; + CURL_TRC_CF(data, cf, "SOCKS5 request granted."); + sxstate(sx, cf, data, SOCKS_ST_SUCCESS); + FALLTHROUGH(); + + case SOCKS_ST_SUCCESS: + return CURLPX_OK; + + case SOCKS_ST_FAILED: + DEBUGASSERT(sx->presult); + return sx->presult; + + default: + DEBUGASSERT(0); + return socks_failed(sx, cf, data, CURLPX_SEND_REQUEST); + } +} + +static void socks_proxy_ctx_free(struct socks_ctx *ctx) +{ + if(ctx) { + Curl_peer_unlink(&ctx->dest); + Curl_creds_unlink(&ctx->creds); + Curl_bufq_free(&ctx->iobuf); + curlx_free(ctx); + } +} + +/* After a TCP connection to the proxy has been verified, this function does + the next magic steps. If 'done' is not set TRUE, it is not done yet and + must be called again. + + Note: this function's sub-functions call failf() + +*/ +static CURLcode socks_proxy_cf_connect(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ + struct socks_ctx *ctx = cf->ctx; + CURLproxycode pxresult = CURLPX_OK; + CURLcode result; + + if(cf->connected) { + *done = TRUE; + return CURLE_OK; + } + + result = cf->next->cft->do_connect(cf->next, data, done); + if(result || !*done) + return result; + + switch(ctx->proxy_type) { + case CURLPROXY_SOCKS5: + case CURLPROXY_SOCKS5_HOSTNAME: + pxresult = socks5_connect(cf, ctx, data); + break; + + case CURLPROXY_SOCKS4: + case CURLPROXY_SOCKS4A: + pxresult = socks4_connect(cf, ctx, data); + break; + + default: + DEBUGASSERT(0); /* should not come here, checked it at creation time */ + result = CURLE_COULDNT_CONNECT; + goto out; + } + + if(pxresult) { + result = CURLE_PROXY; + data->info.pxcode = pxresult; + goto out; + } + else if(ctx->state != SOCKS_ST_SUCCESS) + goto out; + +#ifdef CURLVERBOSE + if(Curl_trc_is_verbose(data)) { + struct ip_quadruple ipquad; + bool is_ipv6; + if(!Curl_conn_cf_get_ip_info(cf->next, data, &is_ipv6, &ipquad)) + infof(data, "Opened %sSOCKS connection from %s port %d to %s port %d " + "(via %s port %u)", + (cf->sockindex == SECONDARYSOCKET) ? "2nd " : "", + ipquad.local_ip, ipquad.local_port, + ctx->dest->hostname, ctx->dest->port, + ipquad.remote_ip, ipquad.remote_port); + else + infof(data, "Opened %sSOCKS connection", + (cf->sockindex == SECONDARYSOCKET) ? "2nd " : ""); + } +#endif + cf->connected = TRUE; + +out: + *done = (bool)cf->connected; + if(*done || result) + Curl_creds_unlink(&ctx->creds); + return result; +} + +static CURLcode socks_cf_adjust_pollset(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct easy_pollset *ps) +{ + struct socks_ctx *sx = cf->ctx; + CURLcode result = CURLE_OK; + + if(!cf->connected && sx) { + /* If we are not connected, the filter below is and has nothing + * to wait on, we determine what to wait for. */ + curl_socket_t sock = Curl_conn_cf_get_socket(cf, data); + switch(sx->state) { + case SOCKS4_ST_SEND: + case SOCKS5_ST_REQ0_SEND: + case SOCKS5_ST_AUTH_SEND: + case SOCKS5_ST_REQ1_SEND: + CURL_TRC_CF(data, cf, "adjust pollset out (%d)", (int)sx->state); + result = Curl_pollset_set_out_only(data, ps, sock); + break; + default: + CURL_TRC_CF(data, cf, "adjust pollset in (%d)", (int)sx->state); + result = Curl_pollset_set_in_only(data, ps, sock); + break; + } + } + return result; +} + +static void socks_proxy_cf_destroy(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + (void)data; + socks_proxy_ctx_free(cf->ctx); + cf->ctx = NULL; +} + +static CURLcode socks_cf_query(struct Curl_cfilter *cf, + struct Curl_easy *data, + int query, int *pres1, void *pres2) +{ + struct socks_ctx *sx = cf->ctx; + + switch(query) { + case CF_QUERY_HOST_PORT: + if(sx) { + *pres1 = sx->dest->port; + *((const char **)pres2) = sx->dest->hostname; + return CURLE_OK; + } + break; + case CF_QUERY_ALPN_NEGOTIATED: { + const char **palpn = pres2; + DEBUGASSERT(palpn); + *palpn = NULL; + return CURLE_OK; + } + default: + break; + } + return cf->next ? + cf->next->cft->query(cf->next, data, query, pres1, pres2) : + CURLE_UNKNOWN_OPTION; +} + +struct Curl_cftype Curl_cft_socks_proxy = { + "SOCKS", + CF_TYPE_IP_CONNECT | CF_TYPE_PROXY, + 0, + socks_proxy_cf_destroy, + socks_proxy_cf_connect, + Curl_cf_def_shutdown, + socks_cf_adjust_pollset, + Curl_cf_def_data_pending, + Curl_cf_def_send, + Curl_cf_def_recv, + Curl_cf_def_cntrl, + Curl_cf_def_conn_is_alive, + Curl_cf_def_conn_keep_alive, + socks_cf_query, +}; + +CURLcode Curl_cf_socks_proxy_insert_after(struct Curl_cfilter *cf_at, + struct Curl_easy *data, + struct Curl_peer *dest, + uint8_t ip_version, + uint8_t proxy_type, + struct Curl_creds *creds) +{ + struct Curl_cfilter *cf; + struct socks_ctx *ctx; + CURLcode result; + + if(!dest) + return CURLE_FAILED_INIT; + + switch(proxy_type) { + case CURLPROXY_SOCKS5: + case CURLPROXY_SOCKS5_HOSTNAME: + case CURLPROXY_SOCKS4: + case CURLPROXY_SOCKS4A: + break; /* all supported */ + default: + failf(data, "unknown proxytype %d option given", proxy_type); + return CURLE_COULDNT_CONNECT; + } + + /* NUL byte already part of struct size */ + ctx = curlx_calloc(1, sizeof(*ctx)); + if(!ctx) { + return CURLE_OUT_OF_MEMORY; + } + + Curl_peer_link(&ctx->dest, dest); + ctx->ip_version = ip_version; + ctx->proxy_type = proxy_type; + Curl_creds_link(&ctx->creds, creds); + Curl_bufq_init2(&ctx->iobuf, SOCKS_CHUNK_SIZE, SOCKS_CHUNKS, + BUFQ_OPT_SOFT_LIMIT); + + result = Curl_cf_create(&cf, &Curl_cft_socks_proxy, ctx); + if(!result) + Curl_conn_cf_insert_after(cf_at, cf); + else + socks_proxy_ctx_free(ctx); + return result; +} + +#endif /* CURL_DISABLE_PROXY */ diff --git a/3rdparty/curl-8.21.0/lib/socks.h b/3rdparty/curl-8.21.0/lib/socks.h new file mode 100644 index 0000000000..d8e77c7f13 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/socks.h @@ -0,0 +1,69 @@ +#ifndef HEADER_CURL_SOCKS_H +#define HEADER_CURL_SOCKS_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifndef CURL_DISABLE_PROXY + +struct Curl_peer; +struct Curl_creds; + +/* + * Helper read-from-socket functions. Does the same as Curl_read() but it + * blocks until all bytes amount of buffersize will be read. No more, no less. + * + * This is STUPID BLOCKING behavior + */ +CURLcode Curl_blockread_all(struct Curl_cfilter *cf, + struct Curl_easy *data, + char *buf, + size_t blen, + size_t *pnread); + +#if defined(HAVE_GSSAPI) || defined(USE_WINDOWS_SSPI) +/* + * This function handles the SOCKS5 GSS-API negotiation and initialization + */ +CURLcode Curl_SOCKS5_gssapi_negotiate(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct Curl_creds *creds); +#endif + +/* Insert a SOCKS filter after `cf_at` for connecting to `dest`. + * Credentials are optional and NOT duplicated and are + * expected to exist during connect phase. + */ +CURLcode Curl_cf_socks_proxy_insert_after(struct Curl_cfilter *cf_at, + struct Curl_easy *data, + struct Curl_peer *dest, + uint8_t ip_version, + uint8_t proxy_type, + struct Curl_creds *creds); + +extern struct Curl_cftype Curl_cft_socks_proxy; + +#endif /* !CURL_DISABLE_PROXY */ + +#endif /* HEADER_CURL_SOCKS_H */ diff --git a/3rdparty/curl-8.21.0/lib/socks_gssapi.c b/3rdparty/curl-8.21.0/lib/socks_gssapi.c new file mode 100644 index 0000000000..e10899c7e7 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/socks_gssapi.c @@ -0,0 +1,600 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * Copyright (C) Markus Moeller, + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if defined(HAVE_GSSAPI) && !defined(CURL_DISABLE_PROXY) + +#include "curl_gssapi.h" +#include "urldata.h" +#include "curl_trc.h" +#include "cfilters.h" +#include "connect.h" +#include "curlx/nonblock.h" +#include "socks.h" +#include "curlx/strdup.h" + +#if defined(CURL_HAVE_DIAG) && defined(__APPLE__) +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Wdeprecated-declarations" +#endif + +#define MAX_GSS_LEN 1024 + +/* + * Helper GSS-API error functions. + */ +static int check_gss_err(struct Curl_easy *data, + OM_uint32 major_status, + OM_uint32 minor_status, + const char *function) +{ + if(GSS_ERROR(major_status)) { + OM_uint32 maj_stat, min_stat; + OM_uint32 msg_ctx = 0; + gss_buffer_desc status_string = GSS_C_EMPTY_BUFFER; + struct dynbuf dbuf; + + curlx_dyn_init(&dbuf, MAX_GSS_LEN); + msg_ctx = 0; + while(!msg_ctx) { + /* convert major status code (GSS-API error) to text */ + maj_stat = gss_display_status(&min_stat, major_status, + GSS_C_GSS_CODE, + GSS_C_NULL_OID, + &msg_ctx, &status_string); + if(maj_stat == GSS_S_COMPLETE) { + if(curlx_dyn_addn(&dbuf, status_string.value, status_string.length)) + return 1; /* error */ + gss_release_buffer(&min_stat, &status_string); + break; + } + gss_release_buffer(&min_stat, &status_string); + } + if(curlx_dyn_addn(&dbuf, ".\n", 2)) + return 1; /* error */ + msg_ctx = 0; + while(!msg_ctx) { + /* convert minor status code (underlying routine error) to text */ + maj_stat = gss_display_status(&min_stat, minor_status, + GSS_C_MECH_CODE, + GSS_C_NULL_OID, + &msg_ctx, &status_string); + if(maj_stat == GSS_S_COMPLETE) { + if(curlx_dyn_addn(&dbuf, status_string.value, status_string.length)) + return 1; /* error */ + gss_release_buffer(&min_stat, &status_string); + break; + } + gss_release_buffer(&min_stat, &status_string); + } + failf(data, "GSS-API error: %s failed: %s", function, + curlx_dyn_ptr(&dbuf)); + curlx_dyn_free(&dbuf); + return 1; + } + + return 0; +} + +static CURLcode socks5_gss_create_service_name(struct Curl_easy *data, + struct connectdata *conn, + const char *serviceptr, + gss_name_t *server) +{ + OM_uint32 gss_major_status, gss_minor_status, gss_status; + gss_buffer_desc service = GSS_C_EMPTY_BUFFER; + + /* prepare service name */ + if(strchr(serviceptr, '/')) { + service.length = strlen(serviceptr); + service.value = curlx_memdup(serviceptr, service.length); + if(!service.value) + return CURLE_OUT_OF_MEMORY; + + gss_major_status = gss_import_name(&gss_minor_status, &service, + (gss_OID)GSS_C_NULL_OID, server); + } + else { + service.value = curl_maprintf("%s@%s", serviceptr, + conn->socks_proxy.peer->hostname); + if(!service.value) + return CURLE_OUT_OF_MEMORY; + service.length = strlen(service.value); + + gss_major_status = gss_import_name(&gss_minor_status, &service, + GSS_C_NT_HOSTBASED_SERVICE, server); + } + + curlx_safefree(service.value); + service.length = 0; + + if(check_gss_err(data, gss_major_status, + gss_minor_status, "gss_import_name()")) { + failf(data, "Failed to create service name."); + gss_release_name(&gss_status, server); + return CURLE_COULDNT_CONNECT; + } + + return CURLE_OK; +} + +static CURLcode socks5_gss_auth_loop(struct Curl_cfilter *cf, + struct Curl_easy *data, + gss_name_t *server_ptr, + gss_ctx_id_t *gss_context, + OM_uint32 *gss_ret_flags) +{ + OM_uint32 gss_major_status, gss_minor_status, gss_status; + gss_buffer_desc gss_send_token = GSS_C_EMPTY_BUFFER; + gss_buffer_desc gss_recv_token = GSS_C_EMPTY_BUFFER; + gss_buffer_desc *gss_token = GSS_C_NO_BUFFER; + unsigned short us_length; + unsigned char socksreq[4]; + size_t actualread; + size_t nwritten; + CURLcode result; + + /* GSS-API request looks like + * +----+------+-----+----------------+ + * |VER | MTYP | LEN | TOKEN | + * +----+------+----------------------+ + * | 1 | 1 | 2 | up to 2^16 - 1 | + * +----+------+-----+----------------+ + */ + + /* As long as we need to keep sending some context info, and there is no + * errors, keep sending it... */ + for(;;) { + gss_major_status = Curl_gss_init_sec_context(data, + &gss_minor_status, + gss_context, + *server_ptr, + &Curl_krb5_mech_oid, + NULL, + gss_token, + &gss_send_token, + TRUE, + gss_ret_flags); + + if(gss_token != GSS_C_NO_BUFFER) { + curlx_safefree(gss_recv_token.value); + gss_recv_token.length = 0; + } + if(check_gss_err(data, gss_major_status, + gss_minor_status, "gss_init_sec_context") || + /* the size needs to fit in a 16-bit field */ + (gss_send_token.length > 0xffff)) { + gss_release_name(&gss_status, server_ptr); + gss_release_buffer(&gss_status, &gss_send_token); + Curl_gss_delete_sec_context(&gss_status, gss_context, NULL); + failf(data, "Failed to initialize GSS-API token."); + return CURLE_COULDNT_CONNECT; + } + + if(gss_send_token.length) { + socksreq[0] = 1; /* GSS-API subnegotiation version */ + socksreq[1] = 1; /* authentication message type */ + us_length = htons((unsigned short)gss_send_token.length); + memcpy(socksreq + 2, &us_length, sizeof(short)); + + result = Curl_conn_cf_send(cf->next, data, socksreq, 4, FALSE, + &nwritten); + if(result || (nwritten != 4)) { + failf(data, "Failed to send GSS-API authentication request."); + gss_release_name(&gss_status, server_ptr); + gss_release_buffer(&gss_status, &gss_send_token); + Curl_gss_delete_sec_context(&gss_status, gss_context, NULL); + return CURLE_COULDNT_CONNECT; + } + + result = Curl_conn_cf_send(cf->next, data, + gss_send_token.value, + gss_send_token.length, FALSE, &nwritten); + if(result || (gss_send_token.length != nwritten)) { + failf(data, "Failed to send GSS-API authentication token."); + gss_release_name(&gss_status, server_ptr); + gss_release_buffer(&gss_status, &gss_send_token); + Curl_gss_delete_sec_context(&gss_status, gss_context, NULL); + return CURLE_COULDNT_CONNECT; + } + } + + gss_release_buffer(&gss_status, &gss_send_token); + if(gss_major_status != GSS_S_CONTINUE_NEEDED) + break; + + /* analyze response */ + + /* GSS-API response looks like + * +----+------+-----+----------------+ + * |VER | MTYP | LEN | TOKEN | + * +----+------+----------------------+ + * | 1 | 1 | 2 | up to 2^16 - 1 | + * +----+------+-----+----------------+ + */ + + result = Curl_blockread_all(cf, data, (char *)socksreq, 4, &actualread); + if(result || (actualread != 4)) { + failf(data, "Failed to receive GSS-API authentication response."); + gss_release_name(&gss_status, server_ptr); + Curl_gss_delete_sec_context(&gss_status, gss_context, NULL); + return CURLE_COULDNT_CONNECT; + } + + /* ignore the first (VER) byte */ + if(socksreq[1] == 255) { /* status / message type */ + failf(data, "User was rejected by the SOCKS5 server (%d %d).", + socksreq[0], socksreq[1]); + gss_release_name(&gss_status, server_ptr); + Curl_gss_delete_sec_context(&gss_status, gss_context, NULL); + return CURLE_COULDNT_CONNECT; + } + + if(socksreq[1] != 1) { /* status / message type */ + failf(data, "Invalid GSS-API authentication response type (%d %d).", + socksreq[0], socksreq[1]); + gss_release_name(&gss_status, server_ptr); + Curl_gss_delete_sec_context(&gss_status, gss_context, NULL); + return CURLE_COULDNT_CONNECT; + } + + memcpy(&us_length, socksreq + 2, sizeof(short)); + us_length = ntohs(us_length); + + if(!us_length) { + failf(data, "Invalid zero-length GSS-API authentication token."); + gss_release_name(&gss_status, server_ptr); + Curl_gss_delete_sec_context(&gss_status, gss_context, NULL); + return CURLE_COULDNT_CONNECT; + } + + gss_recv_token.length = us_length; + gss_recv_token.value = curlx_malloc(gss_recv_token.length); + if(!gss_recv_token.value) { + failf(data, + "Could not allocate memory for GSS-API authentication " + "response token."); + gss_release_name(&gss_status, server_ptr); + Curl_gss_delete_sec_context(&gss_status, gss_context, NULL); + return CURLE_OUT_OF_MEMORY; + } + + result = Curl_blockread_all(cf, data, (char *)gss_recv_token.value, + gss_recv_token.length, &actualread); + + if(result || (actualread != us_length)) { + failf(data, "Failed to receive GSS-API authentication token."); + gss_release_name(&gss_status, server_ptr); + curlx_safefree(gss_recv_token.value); + gss_recv_token.length = 0; + Curl_gss_delete_sec_context(&gss_status, gss_context, NULL); + return CURLE_COULDNT_CONNECT; + } + + gss_token = &gss_recv_token; + } + + gss_release_name(&gss_status, server_ptr); + return CURLE_OK; +} + +static CURLcode socks5_gss_auth_verify(struct Curl_easy *data, + gss_ctx_id_t *gss_context) +{ + OM_uint32 gss_major_status, gss_minor_status, gss_status; + gss_name_t gss_client_name = GSS_C_NO_NAME; + gss_buffer_desc gss_send_token = GSS_C_EMPTY_BUFFER; + + /* Everything is good so far, user was authenticated! */ + gss_major_status = gss_inquire_context(&gss_minor_status, *gss_context, + &gss_client_name, NULL, NULL, NULL, + NULL, NULL, NULL); + if(check_gss_err(data, gss_major_status, + gss_minor_status, "gss_inquire_context")) { + Curl_gss_delete_sec_context(&gss_status, gss_context, NULL); + gss_release_name(&gss_status, &gss_client_name); + failf(data, "Failed to determine username."); + return CURLE_COULDNT_CONNECT; + } + gss_major_status = gss_display_name(&gss_minor_status, gss_client_name, + &gss_send_token, NULL); + if(check_gss_err(data, gss_major_status, + gss_minor_status, "gss_display_name")) { + Curl_gss_delete_sec_context(&gss_status, gss_context, NULL); + gss_release_name(&gss_status, &gss_client_name); + gss_release_buffer(&gss_status, &gss_send_token); + failf(data, "Failed to determine username."); + return CURLE_COULDNT_CONNECT; + } + + infof(data, "SOCKS5 server authenticated user %.*s with GSS-API.", + (int)gss_send_token.length, (const char *)gss_send_token.value); + + gss_release_name(&gss_status, &gss_client_name); + gss_release_buffer(&gss_status, &gss_send_token); + + return CURLE_OK; +} + +static CURLcode socks5_gss_negotiate_enc(struct Curl_cfilter *cf, + struct Curl_easy *data, + gss_ctx_id_t *gss_context, + OM_uint32 gss_ret_flags) +{ + struct connectdata *conn = cf->conn; + OM_uint32 gss_major_status, gss_minor_status, gss_status; + gss_buffer_desc gss_send_token = GSS_C_EMPTY_BUFFER; + gss_buffer_desc gss_recv_token = GSS_C_EMPTY_BUFFER; + gss_buffer_desc gss_w_token = GSS_C_EMPTY_BUFFER; + unsigned short us_length; + unsigned char socksreq[4]; + size_t actualread; + size_t nwritten; + CURLcode result; + int gss_enc; + + /* Do encryption */ + socksreq[0] = 1; /* GSS-API subnegotiation version */ + socksreq[1] = 2; /* encryption message type */ + + gss_enc = 0; /* no data protection */ + /* do confidentiality protection if supported */ + if(gss_ret_flags & GSS_C_CONF_FLAG) + gss_enc = 2; + /* else do integrity protection */ + else if(gss_ret_flags & GSS_C_INTEG_FLAG) + gss_enc = 1; + + infof(data, "SOCKS5 server supports GSS-API %s data protection.", + (gss_enc == 0) ? "no" : + ((gss_enc == 1) ? "integrity" : "confidentiality")); + + /* + * Sending the encryption type in clear seems wrong. It should be + * protected with gss_seal()/gss_wrap(). See RFC1961 extract below + * The NEC reference implementations on which this is based is + * therefore at fault + * + * +------+------+------+.......................+ + * + ver | mtyp | len | token | + * +------+------+------+.......................+ + * + 0x01 | 0x02 | 0x02 | up to 2^16 - 1 octets | + * +------+------+------+.......................+ + * + * Where: + * + * - "ver" is the protocol version number, here 1 to represent the + * first version of the SOCKS/GSS-API protocol + * + * - "mtyp" is the message type, here 2 to represent a protection + * -level negotiation message + * + * - "len" is the length of the "token" field in octets + * + * - "token" is the GSS-API encapsulated protection level + * + * The token is produced by encapsulating an octet containing the + * required protection level using gss_seal()/gss_wrap() with conf_req + * set to FALSE. The token is verified using gss_unseal()/ + * gss_unwrap(). + * + */ + if(data->set.socks5_gssapi_nec) { + us_length = htons((short)1); + memcpy(socksreq + 2, &us_length, sizeof(short)); + } + else { + gss_send_token.length = 1; + gss_send_token.value = curlx_memdup(&gss_enc, gss_send_token.length); + if(!gss_send_token.value) { + Curl_gss_delete_sec_context(&gss_status, gss_context, NULL); + return CURLE_OUT_OF_MEMORY; + } + + gss_major_status = gss_wrap(&gss_minor_status, *gss_context, 0, + GSS_C_QOP_DEFAULT, &gss_send_token, + NULL, &gss_w_token); + + if(check_gss_err(data, gss_major_status, gss_minor_status, "gss_wrap")) { + curlx_safefree(gss_send_token.value); + gss_send_token.length = 0; + gss_release_buffer(&gss_status, &gss_w_token); + Curl_gss_delete_sec_context(&gss_status, gss_context, NULL); + failf(data, "Failed to wrap GSS-API encryption value into token."); + return CURLE_COULDNT_CONNECT; + } + curlx_safefree(gss_send_token.value); + gss_send_token.length = 0; + + us_length = htons((unsigned short)gss_w_token.length); + memcpy(socksreq + 2, &us_length, sizeof(short)); + } + + result = Curl_conn_cf_send(cf->next, data, socksreq, 4, FALSE, &nwritten); + if(result || (nwritten != 4)) { + failf(data, "Failed to send GSS-API encryption request."); + gss_release_buffer(&gss_status, &gss_w_token); + Curl_gss_delete_sec_context(&gss_status, gss_context, NULL); + return CURLE_COULDNT_CONNECT; + } + + if(data->set.socks5_gssapi_nec) { + memcpy(socksreq, &gss_enc, 1); + result = Curl_conn_cf_send(cf->next, data, socksreq, 1, FALSE, &nwritten); + if(result || (nwritten != 1)) { + failf(data, "Failed to send GSS-API encryption type."); + Curl_gss_delete_sec_context(&gss_status, gss_context, NULL); + return CURLE_COULDNT_CONNECT; + } + } + else { + result = Curl_conn_cf_send(cf->next, data, gss_w_token.value, + gss_w_token.length, FALSE, &nwritten); + if(result || (gss_w_token.length != nwritten)) { + failf(data, "Failed to send GSS-API encryption type."); + gss_release_buffer(&gss_status, &gss_w_token); + Curl_gss_delete_sec_context(&gss_status, gss_context, NULL); + return CURLE_COULDNT_CONNECT; + } + gss_release_buffer(&gss_status, &gss_w_token); + } + + result = Curl_blockread_all(cf, data, (char *)socksreq, 4, &actualread); + if(result || (actualread != 4)) { + failf(data, "Failed to receive GSS-API encryption response."); + Curl_gss_delete_sec_context(&gss_status, gss_context, NULL); + return CURLE_COULDNT_CONNECT; + } + + /* ignore the first (VER) byte */ + if(socksreq[1] == 255) { /* status / message type */ + failf(data, "User was rejected by the SOCKS5 server (%d %d).", + socksreq[0], socksreq[1]); + Curl_gss_delete_sec_context(&gss_status, gss_context, NULL); + return CURLE_COULDNT_CONNECT; + } + + if(socksreq[1] != 2) { /* status / message type */ + failf(data, "Invalid GSS-API encryption response type (%d %d).", + socksreq[0], socksreq[1]); + Curl_gss_delete_sec_context(&gss_status, gss_context, NULL); + return CURLE_COULDNT_CONNECT; + } + + memcpy(&us_length, socksreq + 2, sizeof(short)); + us_length = ntohs(us_length); + + if(!us_length) { + failf(data, "Invalid zero-length GSS-API encryption token."); + Curl_gss_delete_sec_context(&gss_status, gss_context, NULL); + return CURLE_COULDNT_CONNECT; + } + + gss_recv_token.length = us_length; + gss_recv_token.value = curlx_malloc(gss_recv_token.length); + if(!gss_recv_token.value) { + Curl_gss_delete_sec_context(&gss_status, gss_context, NULL); + return CURLE_OUT_OF_MEMORY; + } + result = Curl_blockread_all(cf, data, (char *)gss_recv_token.value, + gss_recv_token.length, &actualread); + + if(result || (actualread != us_length)) { + failf(data, "Failed to receive GSS-API encryption type."); + curlx_safefree(gss_recv_token.value); + gss_recv_token.length = 0; + Curl_gss_delete_sec_context(&gss_status, gss_context, NULL); + return CURLE_COULDNT_CONNECT; + } + + if(!data->set.socks5_gssapi_nec) { + gss_major_status = gss_unwrap(&gss_minor_status, *gss_context, + &gss_recv_token, &gss_w_token, + NULL, NULL); + + if(check_gss_err(data, gss_major_status, gss_minor_status, "gss_unwrap")) { + curlx_safefree(gss_recv_token.value); + gss_recv_token.length = 0; + gss_release_buffer(&gss_status, &gss_w_token); + Curl_gss_delete_sec_context(&gss_status, gss_context, NULL); + failf(data, "Failed to unwrap GSS-API encryption value into token."); + return CURLE_COULDNT_CONNECT; + } + curlx_safefree(gss_recv_token.value); + gss_recv_token.length = 0; + + if(gss_w_token.length != 1) { + failf(data, "Invalid GSS-API encryption response length (%zu).", + gss_w_token.length); + gss_release_buffer(&gss_status, &gss_w_token); + Curl_gss_delete_sec_context(&gss_status, gss_context, NULL); + return CURLE_COULDNT_CONNECT; + } + + memcpy(socksreq, gss_w_token.value, gss_w_token.length); + gss_release_buffer(&gss_status, &gss_w_token); + } + else { + if(gss_recv_token.length != 1) { + failf(data, "Invalid GSS-API encryption response length (%zu).", + gss_recv_token.length); + curlx_safefree(gss_recv_token.value); + gss_recv_token.length = 0; + Curl_gss_delete_sec_context(&gss_status, gss_context, NULL); + return CURLE_COULDNT_CONNECT; + } + + memcpy(socksreq, gss_recv_token.value, gss_recv_token.length); + curlx_safefree(gss_recv_token.value); + gss_recv_token.length = 0; + } + + infof(data, "SOCKS5 access %s protection granted.", + (socksreq[0] == 0) ? "without GSS-API data" : + ((socksreq[0] == 1) ? "with GSS-API integrity" : + "with GSS-API confidentiality")); + + conn->socks5_gssapi_enctype = socksreq[0]; + if(socksreq[0] == 0) + Curl_gss_delete_sec_context(&gss_status, gss_context, NULL); + + return CURLE_OK; +} + +CURLcode Curl_SOCKS5_gssapi_negotiate(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct Curl_creds *creds) +{ + struct connectdata *conn = cf->conn; + curl_socket_t sock = conn->sock[cf->sockindex]; + CURLcode result; + OM_uint32 gss_ret_flags = 0; + gss_name_t server = GSS_C_NO_NAME; + const char *service = Curl_creds_has_sasl_service(creds) ? + Curl_creds_sasl_service(creds) : "rcmd"; + gss_ctx_id_t gss_context = GSS_C_NO_CONTEXT; + + result = socks5_gss_create_service_name(data, conn, service, &server); + if(!result) { + (void)curlx_nonblock(sock, FALSE); + result = socks5_gss_auth_loop(cf, data, &server, &gss_context, + &gss_ret_flags); + } + if(!result) + result = socks5_gss_auth_verify(data, &gss_context); + if(!result) + result = socks5_gss_negotiate_enc(cf, data, &gss_context, gss_ret_flags); + + /* unconditionally put it back to non-blocking */ + (void)curlx_nonblock(sock, TRUE); + + return result; +} + +#if defined(CURL_HAVE_DIAG) && defined(__APPLE__) +#pragma GCC diagnostic pop +#endif + +#endif /* HAVE_GSSAPI && !CURL_DISABLE_PROXY */ diff --git a/3rdparty/curl-8.21.0/lib/socks_sspi.c b/3rdparty/curl-8.21.0/lib/socks_sspi.c new file mode 100644 index 0000000000..10a8be1773 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/socks_sspi.c @@ -0,0 +1,537 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * Copyright (C) Markus Moeller, + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if defined(USE_WINDOWS_SSPI) && !defined(CURL_DISABLE_PROXY) + +#include "urldata.h" +#include "curl_trc.h" +#include "cfilters.h" +#include "connect.h" +#include "strerror.h" +#include "curlx/nonblock.h" +#include "socks.h" +#include "curl_sspi.h" +#include "curlx/multibyte.h" + +/* + * Helper sspi error functions. + */ +static int check_sspi_err(struct Curl_easy *data, + SECURITY_STATUS status, + const char *function) +{ + if(status != SEC_E_OK && + status != SEC_I_COMPLETE_AND_CONTINUE && + status != SEC_I_COMPLETE_NEEDED && + status != SEC_I_CONTINUE_NEEDED) { + char buffer[STRERROR_LEN]; + failf(data, "SSPI error: %s failed: %s", function, + Curl_sspi_strerror(status, buffer, sizeof(buffer))); + return 1; + } + return 0; +} + +/* This is the SSPI-using version of this function */ +static CURLcode socks5_sspi_setup(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct Curl_creds *creds, + CredHandle *cred_handle, + char **service_namep) +{ + struct connectdata *conn = cf->conn; + const char *service = Curl_creds_has_sasl_service(creds) ? + Curl_creds_sasl_service(creds) : "rcmd"; + SECURITY_STATUS status; + + /* prepare service name */ + if(strchr(service, '/')) + *service_namep = curlx_strdup(service); + else + *service_namep = curl_maprintf("%s/%s", + service, conn->socks_proxy.peer->hostname); + if(!*service_namep) + return CURLE_OUT_OF_MEMORY; + + status = + Curl_pSecFn->AcquireCredentialsHandle(NULL, + (TCHAR *)CURL_UNCONST(TEXT("Kerberos")), + SECPKG_CRED_OUTBOUND, + NULL, NULL, NULL, NULL, + cred_handle, NULL); + + if(check_sspi_err(data, status, "AcquireCredentialsHandle")) { + failf(data, "Failed to acquire credentials."); + return CURLE_COULDNT_CONNECT; + } + + return CURLE_OK; +} + +static CURLcode socks5_free_token(SecBuffer *send_token, + CURLcode result) +{ + if(send_token->pvBuffer) { + Curl_pSecFn->FreeContextBuffer(send_token->pvBuffer); + send_token->pvBuffer = NULL; + } + return result; +} + +static CURLcode socks5_sspi_loop(struct Curl_cfilter *cf, + struct Curl_easy *data, + CredHandle *cred_handle, + CtxtHandle *sspi_context, + char *service_name, + unsigned long *sspi_ret_flagsp) +{ + struct connectdata *conn = cf->conn; + curl_socket_t sock = conn->sock[cf->sockindex]; + CURLcode result = CURLE_OK; + CURLcode code; + SECURITY_STATUS status; + SecBuffer sspi_send_token, sspi_recv_token; + SecBufferDesc input_desc, output_desc; + PCtxtHandle context_handle = NULL; + unsigned short us_length; + size_t actualread; + size_t written; + unsigned char socksreq[4]; + + input_desc.cBuffers = 1; + input_desc.pBuffers = &sspi_recv_token; + input_desc.ulVersion = SECBUFFER_VERSION; + + sspi_recv_token.BufferType = SECBUFFER_TOKEN; + sspi_recv_token.cbBuffer = 0; + sspi_recv_token.pvBuffer = NULL; + + output_desc.cBuffers = 1; + output_desc.pBuffers = &sspi_send_token; + output_desc.ulVersion = SECBUFFER_VERSION; + + sspi_send_token.BufferType = SECBUFFER_TOKEN; + sspi_send_token.cbBuffer = 0; + sspi_send_token.pvBuffer = NULL; + + (void)curlx_nonblock(sock, FALSE); + + for(;;) { + TCHAR *sname = curlx_convert_UTF8_to_tchar(service_name); + if(!sname) { + curlx_free(sspi_recv_token.pvBuffer); + return socks5_free_token(&sspi_send_token, CURLE_OUT_OF_MEMORY); + } + + status = + Curl_pSecFn->InitializeSecurityContext(cred_handle, context_handle, + sname, + ISC_REQ_MUTUAL_AUTH | + ISC_REQ_ALLOCATE_MEMORY | + ISC_REQ_CONFIDENTIALITY | + ISC_REQ_REPLAY_DETECT, + 0, SECURITY_NATIVE_DREP, + &input_desc, 0, + sspi_context, + &output_desc, + sspi_ret_flagsp, NULL); + + curlx_free(sname); + curlx_safefree(sspi_recv_token.pvBuffer); + sspi_recv_token.cbBuffer = 0; + + if(check_sspi_err(data, status, "InitializeSecurityContext")) { + failf(data, "Failed to initialize security context."); + return socks5_free_token(&sspi_send_token, CURLE_COULDNT_CONNECT); + } + + if(sspi_send_token.cbBuffer) { + socksreq[0] = 1; /* GSS-API subnegotiation version */ + socksreq[1] = 1; /* authentication message type */ + if(sspi_send_token.cbBuffer > 0xffff) { + /* needs to fit in an unsigned 16-bit field */ + return socks5_free_token(&sspi_send_token, CURLE_COULDNT_CONNECT); + } + us_length = htons((unsigned short)sspi_send_token.cbBuffer); + memcpy(socksreq + 2, &us_length, sizeof(short)); + + code = Curl_conn_cf_send(cf->next, data, socksreq, 4, FALSE, &written); + if(code || (written != 4)) { + failf(data, "Failed to send SSPI authentication request."); + return socks5_free_token(&sspi_send_token, CURLE_COULDNT_CONNECT); + } + + code = Curl_conn_cf_send(cf->next, data, + sspi_send_token.pvBuffer, + sspi_send_token.cbBuffer, FALSE, &written); + if(code || (sspi_send_token.cbBuffer != written)) { + failf(data, "Failed to send SSPI authentication token."); + return socks5_free_token(&sspi_send_token, CURLE_COULDNT_CONNECT); + } + } + + if(sspi_send_token.pvBuffer) + socks5_free_token(&sspi_send_token, CURLE_OK); + sspi_send_token.cbBuffer = 0; + + curlx_safefree(sspi_recv_token.pvBuffer); + sspi_recv_token.cbBuffer = 0; + + if(status != SEC_I_CONTINUE_NEEDED) + break; + + result = Curl_blockread_all(cf, data, (char *)socksreq, 4, &actualread); + if(result || (actualread != 4)) { + failf(data, "Failed to receive SSPI authentication response."); + return result ? result : CURLE_COULDNT_CONNECT; + } + + if(socksreq[1] == 255) { + failf(data, "User was rejected by the SOCKS5 server (%u %u).", + (unsigned int)socksreq[0], (unsigned int)socksreq[1]); + return CURLE_COULDNT_CONNECT; + } + + if(socksreq[1] != 1) { + failf(data, "Invalid SSPI authentication response type (%u %u).", + (unsigned int)socksreq[0], (unsigned int)socksreq[1]); + return CURLE_COULDNT_CONNECT; + } + + memcpy(&us_length, socksreq + 2, sizeof(short)); + us_length = ntohs(us_length); + + if(!us_length) { + failf(data, "Invalid zero-length SSPI authentication token."); + return CURLE_COULDNT_CONNECT; + } + + sspi_recv_token.cbBuffer = us_length; + sspi_recv_token.pvBuffer = curlx_malloc(us_length); + + if(!sspi_recv_token.pvBuffer) + return CURLE_OUT_OF_MEMORY; + + result = Curl_blockread_all(cf, data, (char *)sspi_recv_token.pvBuffer, + sspi_recv_token.cbBuffer, &actualread); + + if(result || (actualread != us_length)) { + failf(data, "Failed to receive SSPI authentication token."); + curlx_free(sspi_recv_token.pvBuffer); + return result ? result : CURLE_COULDNT_CONNECT; + } + + context_handle = sspi_context; + } + + return CURLE_OK; +} + +static CURLcode socks5_free(SecBuffer *sspi_w_token, + CURLcode result) +{ + curlx_safefree(sspi_w_token[0].pvBuffer); + curlx_safefree(sspi_w_token[1].pvBuffer); + curlx_safefree(sspi_w_token[2].pvBuffer); + return result; +} + +static CURLcode socks5_sspi_encrypt(struct Curl_cfilter *cf, + struct Curl_easy *data, + CtxtHandle *sspi_context, + unsigned long sspi_ret_flags) +{ + CURLcode result = CURLE_OK; + CURLcode code; + SECURITY_STATUS status; + unsigned char gss_enc; + SecBuffer sspi_w_token[3]; + SecBufferDesc wrap_desc; + SecPkgContext_Sizes sspi_sizes; + unsigned short us_length; + unsigned long qop; + unsigned char socksreq[4]; + uint8_t *etbuf = NULL; + size_t etbuf_size = 0; + size_t actualread; + size_t written; + + gss_enc = 0; + if(sspi_ret_flags & ISC_REQ_CONFIDENTIALITY) + gss_enc = 2; + else if(sspi_ret_flags & ISC_REQ_INTEGRITY) + gss_enc = 1; + + infof(data, "SOCKS5 server supports GSS-API %s data protection.", + (gss_enc == 0) ? "no" : + ((gss_enc == 1) ? "integrity" : "confidentiality")); + + sspi_w_token[0].pvBuffer = + sspi_w_token[1].pvBuffer = + sspi_w_token[2].pvBuffer = NULL; + + wrap_desc.cBuffers = 3; + wrap_desc.pBuffers = sspi_w_token; + wrap_desc.ulVersion = SECBUFFER_VERSION; + + socksreq[0] = 1; + socksreq[1] = 2; + + if(data->set.socks5_gssapi_nec) { + us_length = htons((unsigned short)1); + memcpy(socksreq + 2, &us_length, sizeof(short)); + } + else { + status = Curl_pSecFn->QueryContextAttributes(sspi_context, + SECPKG_ATTR_SIZES, + &sspi_sizes); + if(check_sspi_err(data, status, "QueryContextAttributes")) { + failf(data, "Failed to query security context attributes."); + return CURLE_COULDNT_CONNECT; + } + + sspi_w_token[0].cbBuffer = sspi_sizes.cbSecurityTrailer; + sspi_w_token[0].BufferType = SECBUFFER_TOKEN; + sspi_w_token[0].pvBuffer = curlx_malloc(sspi_sizes.cbSecurityTrailer); + + if(!sspi_w_token[0].pvBuffer) + return CURLE_OUT_OF_MEMORY; + + sspi_w_token[1].cbBuffer = 1; + sspi_w_token[1].BufferType = SECBUFFER_DATA; + sspi_w_token[1].pvBuffer = curlx_malloc(1); + if(!sspi_w_token[1].pvBuffer) + return socks5_free(sspi_w_token, CURLE_OUT_OF_MEMORY); + + memcpy(sspi_w_token[1].pvBuffer, &gss_enc, 1); + sspi_w_token[2].BufferType = SECBUFFER_PADDING; + sspi_w_token[2].cbBuffer = sspi_sizes.cbBlockSize; + sspi_w_token[2].pvBuffer = curlx_malloc(sspi_sizes.cbBlockSize); + if(!sspi_w_token[2].pvBuffer) + return socks5_free(sspi_w_token, CURLE_OUT_OF_MEMORY); + + status = Curl_pSecFn->EncryptMessage(sspi_context, + KERB_WRAP_NO_ENCRYPT, + &wrap_desc, 0); + if(check_sspi_err(data, status, "EncryptMessage")) + return socks5_free(sspi_w_token, CURLE_COULDNT_CONNECT); + + etbuf_size = sspi_w_token[0].cbBuffer + sspi_w_token[1].cbBuffer + + sspi_w_token[2].cbBuffer; + if(etbuf_size > 0xffff) + return socks5_free(sspi_w_token, CURLE_COULDNT_CONNECT); + + etbuf = curlx_malloc(etbuf_size); + if(!etbuf) + return socks5_free(sspi_w_token, CURLE_OUT_OF_MEMORY); + + memcpy(etbuf, sspi_w_token[0].pvBuffer, sspi_w_token[0].cbBuffer); + memcpy(etbuf + sspi_w_token[0].cbBuffer, + sspi_w_token[1].pvBuffer, sspi_w_token[1].cbBuffer); + memcpy(etbuf + sspi_w_token[0].cbBuffer + sspi_w_token[1].cbBuffer, + sspi_w_token[2].pvBuffer, sspi_w_token[2].cbBuffer); + + (void)socks5_free(sspi_w_token, CURLE_OK); + + us_length = htons((unsigned short)etbuf_size); + memcpy(socksreq + 2, &us_length, sizeof(short)); + } + + code = Curl_conn_cf_send(cf->next, data, socksreq, 4, FALSE, &written); + if(code || (written != 4)) { + failf(data, "Failed to send SSPI encryption request."); + curlx_free(etbuf); + return CURLE_COULDNT_CONNECT; + } + + if(data->set.socks5_gssapi_nec) { + memcpy(socksreq, &gss_enc, 1); + code = Curl_conn_cf_send(cf->next, data, socksreq, 1, FALSE, &written); + if(code || (written != 1)) { + failf(data, "Failed to send SSPI encryption type."); + return CURLE_COULDNT_CONNECT; + } + } + else { + code = Curl_conn_cf_send(cf->next, data, etbuf, etbuf_size, FALSE, + &written); + curlx_free(etbuf); + if(code || (etbuf_size != written)) { + failf(data, "Failed to send SSPI encryption type."); + return CURLE_COULDNT_CONNECT; + } + } + + result = Curl_blockread_all(cf, data, (char *)socksreq, 4, &actualread); + if(result || (actualread != 4)) { + failf(data, "Failed to receive SSPI encryption response."); + return result ? result : CURLE_COULDNT_CONNECT; + } + + if(socksreq[1] == 255) { + failf(data, "User was rejected by the SOCKS5 server (%u %u).", + (unsigned int)socksreq[0], (unsigned int)socksreq[1]); + return CURLE_COULDNT_CONNECT; + } + + if(socksreq[1] != 2) { + failf(data, "Invalid SSPI encryption response type (%u %u).", + (unsigned int)socksreq[0], (unsigned int)socksreq[1]); + return CURLE_COULDNT_CONNECT; + } + + memcpy(&us_length, socksreq + 2, sizeof(short)); + us_length = ntohs(us_length); + + if(!us_length) { + failf(data, "Invalid zero-length SSPI encryption token."); + return CURLE_COULDNT_CONNECT; + } + + sspi_w_token[0].cbBuffer = us_length; + sspi_w_token[0].pvBuffer = curlx_malloc(us_length); + if(!sspi_w_token[0].pvBuffer) + return CURLE_OUT_OF_MEMORY; + + result = Curl_blockread_all(cf, data, (char *)sspi_w_token[0].pvBuffer, + sspi_w_token[0].cbBuffer, &actualread); + + if(result || (actualread != us_length)) { + failf(data, "Failed to receive SSPI encryption type."); + goto fail; + } + + if(!data->set.socks5_gssapi_nec) { + wrap_desc.cBuffers = 2; + sspi_w_token[0].BufferType = SECBUFFER_STREAM; + sspi_w_token[1].BufferType = SECBUFFER_DATA; + sspi_w_token[1].cbBuffer = 0; + sspi_w_token[1].pvBuffer = NULL; + + /* At least one of the descriptors must be of type SECBUFFER_DATA. The + message is decrypted in place so the SECBUFFER_DATA receives a pointer + to the message in SECBUFFER_STREAM. */ + status = Curl_pSecFn->DecryptMessage(sspi_context, &wrap_desc, 0, &qop); + + if(check_sspi_err(data, status, "DecryptMessage")) + goto fail; + + if(sspi_w_token[1].cbBuffer != 1) { + failf(data, "Invalid SSPI encryption response length (%lu).", + (unsigned long)sspi_w_token[1].cbBuffer); + goto fail; + } + + memcpy(socksreq, sspi_w_token[1].pvBuffer, sspi_w_token[1].cbBuffer); + } + else { + if(sspi_w_token[0].cbBuffer != 1) { + failf(data, "Invalid SSPI encryption response length (%lu).", + (unsigned long)sspi_w_token[0].cbBuffer); + goto fail; + } + memcpy(socksreq, sspi_w_token[0].pvBuffer, sspi_w_token[0].cbBuffer); + } + curlx_free(sspi_w_token[0].pvBuffer); + + infof(data, "SOCKS5 access %s protection granted BUT NOT USED.", + (socksreq[0] == 0) ? "without GSS-API data" : + ((socksreq[0] == 1) ? "with GSS-API integrity" : + "with GSS-API confidentiality")); + + cf->conn->socks5_gssapi_enctype = socksreq[0]; + return CURLE_OK; + +fail: + curlx_free(sspi_w_token[0].pvBuffer); + return CURLE_COULDNT_CONNECT; +} + +CURLcode Curl_SOCKS5_gssapi_negotiate(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct Curl_creds *creds) +{ + struct connectdata *conn = cf->conn; + curl_socket_t sock = conn->sock[cf->sockindex]; + CURLcode result; + SECURITY_STATUS status; + CredHandle cred_handle; + CtxtHandle sspi_context; + SecPkgCredentials_Names names; + char *service_name = NULL; + unsigned long sspi_ret_flags = 0; + + memset(&cred_handle, 0, sizeof(cred_handle)); + memset(&sspi_context, 0, sizeof(sspi_context)); + names.sUserName = NULL; + + result = socks5_sspi_setup(cf, data, creds, &cred_handle, &service_name); + if(result) + goto error; + + result = socks5_sspi_loop(cf, data, &cred_handle, &sspi_context, + service_name, &sspi_ret_flags); + if(result) + goto error; + + curlx_safefree(service_name); + + status = Curl_pSecFn->QueryCredentialsAttributes(&cred_handle, + SECPKG_CRED_ATTR_NAMES, + &names); + if(check_sspi_err(data, status, "QueryCredentialAttributes")) { + failf(data, "Failed to determine username."); + result = CURLE_COULDNT_CONNECT; + goto error; + } + else { + VERBOSE(char *user_utf8 = curlx_convert_tchar_to_UTF8(names.sUserName)); + infof(data, "SOCKS5 server authenticated user %s with GSS-API.", + (user_utf8 ? user_utf8 : "(unknown)")); + VERBOSE(curlx_free(user_utf8)); + Curl_pSecFn->FreeContextBuffer(names.sUserName); + names.sUserName = NULL; + } + + result = socks5_sspi_encrypt(cf, data, &sspi_context, sspi_ret_flags); + if(result) + goto error; + + (void)curlx_nonblock(sock, TRUE); + Curl_pSecFn->DeleteSecurityContext(&sspi_context); + Curl_pSecFn->FreeCredentialsHandle(&cred_handle); + return CURLE_OK; + +error: + (void)curlx_nonblock(sock, TRUE); + curlx_free(service_name); + Curl_pSecFn->DeleteSecurityContext(&sspi_context); + Curl_pSecFn->FreeCredentialsHandle(&cred_handle); + if(names.sUserName) + Curl_pSecFn->FreeContextBuffer(names.sUserName); + return result; +} +#endif diff --git a/3rdparty/curl-8.21.0/lib/splay.c b/3rdparty/curl-8.21.0/lib/splay.c new file mode 100644 index 0000000000..ddab7a4d6e --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/splay.c @@ -0,0 +1,291 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "splay.h" + +/* + * This macro compares two node keys i and j and returns: + * + * negative value: when i is smaller than j + * zero : when i is equal to j + * positive when : when i is larger than j + */ +#define splay_compare(i, j) curlx_ptimediff_us(i, j) + +/* + * Splay using the key i (which may or may not be in the tree.) The starting + * root is t. + */ +struct Curl_tree *Curl_splay(const struct curltime *pkey, + struct Curl_tree *t) +{ + struct Curl_tree N, *l, *r, *y; + + if(!t) + return NULL; + N.smaller = N.larger = NULL; + l = r = &N; + + for(;;) { + timediff_t comp = splay_compare(pkey, &t->key); + if(comp < 0) { + if(!t->smaller) + break; + if(splay_compare(pkey, &t->smaller->key) < 0) { + y = t->smaller; /* rotate smaller */ + t->smaller = y->larger; + y->larger = t; + t = y; + if(!t->smaller) + break; + } + r->smaller = t; /* link smaller */ + r = t; + t = t->smaller; + } + else if(comp > 0) { + if(!t->larger) + break; + if(splay_compare(pkey, &t->larger->key) > 0) { + y = t->larger; /* rotate larger */ + t->larger = y->smaller; + y->smaller = t; + t = y; + if(!t->larger) + break; + } + l->larger = t; /* link larger */ + l = t; + t = t->larger; + } + else + break; + } + + l->larger = t->smaller; /* assemble */ + r->smaller = t->larger; + t->smaller = N.larger; + t->larger = N.smaller; + + return t; +} + +static const struct curltime SPLAY_SUBNODE = { + ~0, -1 +}; + +/* Insert key i into the tree t. Return a pointer to the resulting tree or + * NULL if something went wrong. + * + * @unittest: 1309 + */ +struct Curl_tree *Curl_splayinsert(const struct curltime *pkey, + struct Curl_tree *t, + struct Curl_tree *node) +{ + DEBUGASSERT(node); + + if(t) { + t = Curl_splay(pkey, t); + DEBUGASSERT(t); + if(splay_compare(pkey, &t->key) == 0) { + /* There already exists a node in the tree with the same key. Build a + doubly-linked circular list of nodes. We add the new 'node' struct to + the end of this list. */ + + node->key = SPLAY_SUBNODE; /* identify this node as a subnode */ + node->samen = t; + node->samep = t->samep; + t->samep->samen = node; + t->samep = node; + + return t; /* the root node always stays the same */ + } + } + + if(!t) { + node->smaller = node->larger = NULL; + } + else if(splay_compare(pkey, &t->key) < 0) { + node->smaller = t->smaller; + node->larger = t; + t->smaller = NULL; + } + else { + node->larger = t->larger; + node->smaller = t; + t->larger = NULL; + } + node->key = *pkey; + + /* no identical nodes (yet), we are the only one in the list of nodes */ + node->samen = node; + node->samep = node; + return node; +} + +/* Finds and deletes the best-fit node from the tree. Return a pointer to the + resulting tree. best-fit means the smallest node if it is not larger than + the key */ +struct Curl_tree *Curl_splaygetbest(const struct curltime *pkey, + struct Curl_tree *t, + struct Curl_tree **removed) +{ + static const struct curltime tv_zero = { 0, 0 }; + struct Curl_tree *x; + + if(!t) { + *removed = NULL; /* none removed since there was no root */ + return NULL; + } + + /* find smallest */ + t = Curl_splay(&tv_zero, t); + DEBUGASSERT(t); + if(splay_compare(pkey, &t->key) < 0) { + /* even the smallest is too big */ + *removed = NULL; + return t; + } + + /* FIRST! Check if there is a list with identical keys */ + x = t->samen; + if(x != t) { + /* there is, pick one from the list */ + + /* 'x' is the new root node */ + + x->key = t->key; + x->larger = t->larger; + x->smaller = t->smaller; + x->samep = t->samep; + t->samep->samen = x; + + *removed = t; + return x; /* new root */ + } + + /* we splayed the tree to the smallest element, there is no smaller */ + x = t->larger; + *removed = t; + + return x; +} + +/* Deletes the node we point out from the tree if it is there. Stores a + * pointer to the new resulting tree in 'newroot'. + * + * Returns zero on success and non-zero on errors! + * When returning error, it does not touch the 'newroot' pointer. + * + * NOTE: when the last node of the tree is removed, there is no tree left so + * 'newroot' will be made to point to NULL. + * + * @unittest: 1309 + */ +int Curl_splayremove(struct Curl_tree *t, + struct Curl_tree *removenode, + struct Curl_tree **newroot) +{ + struct Curl_tree *x; + + if(!t) + return 1; + + DEBUGASSERT(removenode); + + if(splay_compare(&SPLAY_SUBNODE, &removenode->key) == 0) { + /* It is a subnode within a 'same' linked list and thus we can unlink it + easily. */ + DEBUGASSERT(removenode->samen != removenode); + if(removenode->samen == removenode) + /* A non-subnode should never be set to SPLAY_SUBNODE */ + return 3; + + removenode->samep->samen = removenode->samen; + removenode->samen->samep = removenode->samep; + + /* Ensures that double-remove gets caught. */ + removenode->samen = removenode; + + *newroot = t; /* return the same root */ + return 0; + } + + t = Curl_splay(&removenode->key, t); + DEBUGASSERT(t); + + /* First make sure that we got the same root node as the one we want + to remove, as otherwise we might be trying to remove a node that + is not actually in the tree. + + We cannot compare the keys here as a double remove in quick + succession of a node with key != SPLAY_SUBNODE && same != NULL + could return the same key but a different node. */ + DEBUGASSERT(t == removenode); + if(t != removenode) + return 2; + + /* Check if there is a list with identical sizes, as then we are trying to + remove the root node of a list of nodes with identical keys. */ + x = t->samen; + if(x != t) { + /* 'x' is the new root node, we make it use the root node's + smaller/larger links */ + + x->key = t->key; + x->larger = t->larger; + x->smaller = t->smaller; + x->samep = t->samep; + t->samep->samen = x; + } + else { + /* Remove the root node */ + if(!t->smaller) + x = t->larger; + else { + x = Curl_splay(&removenode->key, t->smaller); + DEBUGASSERT(x); + x->larger = t->larger; + } + } + + *newroot = x; /* store new root pointer */ + + return 0; +} + +/* set and get the custom payload for this tree node */ +void Curl_splayset(struct Curl_tree *node, void *payload) +{ + DEBUGASSERT(node); + node->ptr = payload; +} + +void *Curl_splayget(struct Curl_tree *node) +{ + DEBUGASSERT(node); + return node->ptr; +} diff --git a/3rdparty/curl-8.21.0/lib/splay.h b/3rdparty/curl-8.21.0/lib/splay.h new file mode 100644 index 0000000000..c6623f2ef0 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/splay.h @@ -0,0 +1,59 @@ +#ifndef HEADER_CURL_SPLAY_H +#define HEADER_CURL_SPLAY_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "curlx/timeval.h" + +/* only use function calls to access this struct */ +struct Curl_tree { + struct Curl_tree *smaller; /* smaller node */ + struct Curl_tree *larger; /* larger node */ + struct Curl_tree *samen; /* points to the next node with identical key */ + struct Curl_tree *samep; /* points to the prev node with identical key */ + struct curltime key; /* this node's "sort" key */ + void *ptr; /* data the splay code does not care about */ +}; + +struct Curl_tree *Curl_splay(const struct curltime *pkey, + struct Curl_tree *t); + +struct Curl_tree *Curl_splayinsert(const struct curltime *pkey, + struct Curl_tree *t, + struct Curl_tree *node); + +struct Curl_tree *Curl_splaygetbest(const struct curltime *pkey, + struct Curl_tree *t, + struct Curl_tree **removed); + +int Curl_splayremove(struct Curl_tree *t, + struct Curl_tree *removenode, + struct Curl_tree **newroot); + +/* set and get the custom payload for this tree node */ +void Curl_splayset(struct Curl_tree *node, void *payload); +void *Curl_splayget(struct Curl_tree *node); + +#endif /* HEADER_CURL_SPLAY_H */ diff --git a/3rdparty/curl-8.21.0/lib/strcase.c b/3rdparty/curl-8.21.0/lib/strcase.c new file mode 100644 index 0000000000..9f70f41bd6 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/strcase.c @@ -0,0 +1,146 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "strcase.h" + +/* Mapping table to go from lowercase to uppercase for plain ASCII.*/ +static const unsigned char touppermap[256] = { + 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, + 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, + 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, + 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, + 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, + 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, + 90, 91, 92, 93, 94, 95, 96, 65, 66, 67, 68, 69, 70, 71, 72, + 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, + 88, 89, 90, 123, 124, 125, 126, 127, 128, 129, 130, 131, 132, 133, 134, + 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, + 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, + 165, 166, 167, 168, 169, 170, 171, 172, 173, 174, 175, 176, 177, 178, 179, + 180, 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, 191, 192, 193, 194, + 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, 209, + 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221, 222, 223, 224, + 225, 226, 227, 228, 229, 230, 231, 232, 233, 234, 235, 236, 237, 238, 239, + 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, + 255 +}; + +/* Mapping table to go from uppercase to lowercase for plain ASCII.*/ +static const unsigned char tolowermap[256] = { + 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, + 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, + 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, + 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, + 60, 61, 62, 63, 64, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, + 107, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, + 122, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, + 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, + 120, 121, 122, 123, 124, 125, 126, 127, 128, 129, 130, 131, 132, 133, 134, + 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, + 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, + 165, 166, 167, 168, 169, 170, 171, 172, 173, 174, 175, 176, 177, 178, 179, + 180, 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, 191, 192, 193, 194, + 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, 209, + 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221, 222, 223, 224, + 225, 226, 227, 228, 229, 230, 231, 232, 233, 234, 235, 236, 237, 238, 239, + 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, + 255 +}; + +/* Portable, consistent toupper. Do not use toupper() because its behavior is + altered by the current locale. */ +char Curl_raw_toupper(char in) +{ + return (char)touppermap[(unsigned char)in]; +} + +/* Portable, consistent tolower. Do not use tolower() because its behavior is + altered by the current locale. */ +char Curl_raw_tolower(char in) +{ + return (char)tolowermap[(unsigned char)in]; +} + +/* Copy an upper case version of the string from src to dest. The + * strings may overlap. No more than n characters of the string are copied + * (including any NUL) and the destination string will NOT be + * null-terminated if that limit is reached. + */ +void Curl_strntoupper(char *dest, const char *src, size_t n) +{ + if(n < 1) + return; + + do { + *dest++ = Curl_raw_toupper(*src); + } while(*src++ && --n); +} + +/* Copy a lower case version of the string from src to dest. The + * strings may overlap. No more than n characters of the string are copied + * (including any NUL) and the destination string will NOT be + * null-terminated if that limit is reached. + */ +void Curl_strntolower(char *dest, const char *src, size_t n) +{ + if(n < 1) + return; + + do { + *dest++ = Curl_raw_tolower(*src); + } while(*src++ && --n); +} + +/* Compare case-sensitive null-terminated strings, taking care of possible + * null pointers. Return true if arguments match. + */ +bool Curl_safecmp(const char *a, const char *b) +{ + if(a && b) + return !strcmp(a, b); + return !a && !b; +} + +/* + * Curl_timestrcmp() returns 0 if the two strings are identical. The time this + * function spends is a function of the shortest string, not of the contents. + */ +int Curl_timestrcmp(const char *a, const char *b) +{ + int match = 0; + int i = 0; + + if(a && b) { + while(1) { + match |= a[i] ^ b[i]; + if(!a[i] || !b[i]) + break; + i++; + } + } + else + return a || b; + return match; +} diff --git a/3rdparty/curl-8.21.0/lib/strcase.h b/3rdparty/curl-8.21.0/lib/strcase.h new file mode 100644 index 0000000000..54299812be --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/strcase.h @@ -0,0 +1,41 @@ +#ifndef HEADER_CURL_STRCASE_H +#define HEADER_CURL_STRCASE_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +char Curl_raw_toupper(char in); +char Curl_raw_tolower(char in); + +/* checkprefix() is a shorter version of the above, used when the first + argument is the string literal */ +#define checkprefix(a, b) curl_strnequal(b, STRCONST(a)) + +void Curl_strntoupper(char *dest, const char *src, size_t n); +void Curl_strntolower(char *dest, const char *src, size_t n); + +bool Curl_safecmp(const char *a, const char *b); +int Curl_timestrcmp(const char *a, const char *b); + +#endif /* HEADER_CURL_STRCASE_H */ diff --git a/3rdparty/curl-8.21.0/lib/strequal.c b/3rdparty/curl-8.21.0/lib/strequal.c new file mode 100644 index 0000000000..a352fda70b --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/strequal.c @@ -0,0 +1,95 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "strcase.h" + +/* + * curl_strequal() is for doing "raw" case insensitive strings. This is meant + * to be locale independent and only compare strings we know are safe for + * this. See https://daniel.haxx.se/blog/2008/10/15/strcasecmp-in-turkish/ for + * further explanations as to why this function is necessary. + */ + +static int casecompare(const char *first, const char *second) +{ + while(*first) { + if(Curl_raw_toupper(*first) != Curl_raw_toupper(*second)) + /* get out of the loop as soon as they do not match */ + return 0; + first++; + second++; + } + /* If we are here either the strings are the same or the length is different. + We can test if the "current" character is non-zero for one and zero + for the other. Note that the characters may not be exactly the same even + if they match, we only want to compare zero-ness. */ + return !*first == !*second; +} + +static int ncasecompare(const char *first, const char *second, size_t max) +{ + while(*first && max) { + if(Curl_raw_toupper(*first) != Curl_raw_toupper(*second)) + return 0; + max--; + first++; + second++; + } + if(max == 0) + return 1; /* they are equal this far */ + + return Curl_raw_toupper(*first) == Curl_raw_toupper(*second); +} + +/* + * Only "raw" case insensitive strings. This is meant to be locale independent + * and only compare strings we know are safe for this. + * + * The function is capable of comparing a-z case insensitively. + * + * Result is 1 if text matches and 0 if not. + */ + +/* --- public function --- */ +int curl_strequal(const char *s1, const char *s2) +{ + if(s1 && s2) + /* both pointers point to something then compare them */ + return casecompare(s1, s2); + + /* if both pointers are NULL then treat them as equal */ + return NULL == s1 && NULL == s2; +} + +/* --- public function --- */ +int curl_strnequal(const char *s1, const char *s2, size_t n) +{ + if(s1 && s2) + /* both pointers point to something then compare them */ + return ncasecompare(s1, s2, n); + + /* if both pointers are NULL then treat them as equal if max is non-zero */ + return NULL == s1 && NULL == s2 && n; +} diff --git a/3rdparty/curl-8.21.0/lib/strerror.c b/3rdparty/curl-8.21.0/lib/strerror.c new file mode 100644 index 0000000000..7b6dc02127 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/strerror.c @@ -0,0 +1,677 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_WINDOWS_SSPI +#include "curl_sspi.h" +#endif + +#include "curlx/winapi.h" +#include "strerror.h" +#include "curlx/strcopy.h" + +const char *curl_easy_strerror(CURLcode error) +{ +#ifdef CURLVERBOSE + switch(error) { + case CURLE_OK: + return "No error"; + + case CURLE_UNSUPPORTED_PROTOCOL: + return "Unsupported protocol"; + + case CURLE_FAILED_INIT: + return "Failed initialization"; + + case CURLE_URL_MALFORMAT: + return "URL using bad/illegal format or missing URL"; + + case CURLE_NOT_BUILT_IN: + return "A requested feature, protocol or option was not found built-in in" + " this libcurl due to a build-time decision."; + + case CURLE_COULDNT_RESOLVE_PROXY: + return "Could not resolve proxy name"; + + case CURLE_COULDNT_RESOLVE_HOST: + return "Could not resolve hostname"; + + case CURLE_COULDNT_CONNECT: + return "Could not connect to server"; + + case CURLE_WEIRD_SERVER_REPLY: + return "Weird server reply"; + + case CURLE_REMOTE_ACCESS_DENIED: + return "Access denied to remote resource"; + + case CURLE_FTP_ACCEPT_FAILED: + return "FTP: The server failed to connect to data port"; + + case CURLE_FTP_ACCEPT_TIMEOUT: + return "FTP: Accepting server connect has timed out"; + + case CURLE_FTP_PRET_FAILED: + return "FTP: The server did not accept the PRET command."; + + case CURLE_FTP_WEIRD_PASS_REPLY: + return "FTP: unknown PASS reply"; + + case CURLE_FTP_WEIRD_PASV_REPLY: + return "FTP: unknown PASV reply"; + + case CURLE_FTP_WEIRD_227_FORMAT: + return "FTP: unknown 227 response format"; + + case CURLE_FTP_CANT_GET_HOST: + return "FTP: cannot figure out the host in the PASV response"; + + case CURLE_HTTP2: + return "Error in the HTTP2 framing layer"; + + case CURLE_FTP_COULDNT_SET_TYPE: + return "FTP: could not set file type"; + + case CURLE_PARTIAL_FILE: + return "Transferred a partial file"; + + case CURLE_FTP_COULDNT_RETR_FILE: + return "FTP: could not retrieve (RETR failed) the specified file"; + + case CURLE_QUOTE_ERROR: + return "Quote command returned error"; + + case CURLE_HTTP_RETURNED_ERROR: + return "HTTP response code said error"; + + case CURLE_WRITE_ERROR: + return "Failed writing received data to disk/application"; + + case CURLE_UPLOAD_FAILED: + return "Upload failed (at start/before it took off)"; + + case CURLE_READ_ERROR: + return "Failed to open/read local data from file/application"; + + case CURLE_OUT_OF_MEMORY: + return "Out of memory"; + + case CURLE_OPERATION_TIMEDOUT: + return "Timeout was reached"; + + case CURLE_FTP_PORT_FAILED: + return "FTP: command PORT failed"; + + case CURLE_FTP_COULDNT_USE_REST: + return "FTP: command REST failed"; + + case CURLE_RANGE_ERROR: + return "Requested range was not delivered by the server"; + + case CURLE_SSL_CONNECT_ERROR: + return "SSL connect error"; + + case CURLE_BAD_DOWNLOAD_RESUME: + return "Could not resume download"; + + case CURLE_FILE_COULDNT_READ_FILE: + return "Could not read a file:// file"; + + case CURLE_LDAP_CANNOT_BIND: + return "LDAP: cannot bind"; + + case CURLE_LDAP_SEARCH_FAILED: + return "LDAP: search failed"; + + case CURLE_ABORTED_BY_CALLBACK: + return "Operation was aborted by an application callback"; + + case CURLE_BAD_FUNCTION_ARGUMENT: + return "A libcurl function was given a bad argument"; + + case CURLE_INTERFACE_FAILED: + return "Failed binding local connection end"; + + case CURLE_TOO_MANY_REDIRECTS: + return "Number of redirects hit maximum amount"; + + case CURLE_UNKNOWN_OPTION: + return "An unknown option was passed in to libcurl"; + + case CURLE_SETOPT_OPTION_SYNTAX: + return "Malformed option provided in a setopt"; + + case CURLE_GOT_NOTHING: + return "Server returned nothing (no headers, no data)"; + + case CURLE_SSL_ENGINE_NOTFOUND: + return "SSL crypto engine not found"; + + case CURLE_SSL_ENGINE_SETFAILED: + return "Can not set SSL crypto engine as default"; + + case CURLE_SSL_ENGINE_INITFAILED: + return "Failed to initialize SSL crypto engine"; + + case CURLE_SEND_ERROR: + return "Failed sending data to the peer"; + + case CURLE_RECV_ERROR: + return "Failure when receiving data from the peer"; + + case CURLE_SSL_CERTPROBLEM: + return "Problem with the local SSL certificate"; + + case CURLE_SSL_CIPHER: + return "Could not use specified SSL cipher"; + + case CURLE_PEER_FAILED_VERIFICATION: + return "SSL peer certificate or SSH remote key was not OK"; + + case CURLE_SSL_CACERT_BADFILE: + return "Problem with the SSL CA cert (path? access rights?)"; + + case CURLE_BAD_CONTENT_ENCODING: + return "Unrecognized or bad HTTP Content or Transfer-Encoding"; + + case CURLE_FILESIZE_EXCEEDED: + return "Maximum file size exceeded"; + + case CURLE_USE_SSL_FAILED: + return "Requested SSL level failed"; + + case CURLE_SSL_SHUTDOWN_FAILED: + return "Failed to shut down the SSL connection"; + + case CURLE_SSL_CRL_BADFILE: + return "Failed to load CRL file (path? access rights?, format?)"; + + case CURLE_SSL_ISSUER_ERROR: + return "Issuer check against peer certificate failed"; + + case CURLE_SEND_FAIL_REWIND: + return "Send failed since rewinding of the data stream failed"; + + case CURLE_LOGIN_DENIED: + return "Login denied"; + + case CURLE_TFTP_NOTFOUND: + return "TFTP: File Not Found"; + + case CURLE_TFTP_PERM: + return "TFTP: Access Violation"; + + case CURLE_REMOTE_DISK_FULL: + return "Disk full or allocation exceeded"; + + case CURLE_TFTP_ILLEGAL: + return "TFTP: Illegal operation"; + + case CURLE_TFTP_UNKNOWNID: + return "TFTP: Unknown transfer ID"; + + case CURLE_REMOTE_FILE_EXISTS: + return "Remote file already exists"; + + case CURLE_TFTP_NOSUCHUSER: + return "TFTP: No such user"; + + case CURLE_REMOTE_FILE_NOT_FOUND: + return "Remote file not found"; + + case CURLE_SSH: + return "Error in the SSH layer"; + + case CURLE_AGAIN: + return "Socket not ready for send/recv"; + + case CURLE_RTSP_CSEQ_ERROR: + return "RTSP CSeq mismatch or invalid CSeq"; + + case CURLE_RTSP_SESSION_ERROR: + return "RTSP session error"; + + case CURLE_FTP_BAD_FILE_LIST: + return "Unable to parse FTP file list"; + + case CURLE_CHUNK_FAILED: + return "Chunk callback failed"; + + case CURLE_NO_CONNECTION_AVAILABLE: + return "The max connection limit is reached"; + + case CURLE_SSL_PINNEDPUBKEYNOTMATCH: + return "SSL public key does not match pinned public key"; + + case CURLE_SSL_INVALIDCERTSTATUS: + return "SSL server certificate status verification FAILED"; + + case CURLE_HTTP2_STREAM: + return "Stream error in the HTTP/2 framing layer"; + + case CURLE_RECURSIVE_API_CALL: + return "API function called from within callback"; + + case CURLE_AUTH_ERROR: + return "An authentication function returned an error"; + + case CURLE_HTTP3: + return "HTTP/3 error"; + + case CURLE_QUIC_CONNECT_ERROR: + return "QUIC connection error"; + + case CURLE_PROXY: + return "proxy handshake error"; + + case CURLE_SSL_CLIENTCERT: + return "SSL Client Certificate required"; + + case CURLE_UNRECOVERABLE_POLL: + return "Unrecoverable error in select/poll"; + + case CURLE_TOO_LARGE: + return "A value or data field grew larger than allowed"; + + case CURLE_ECH_REQUIRED: + return "ECH attempted but failed"; + + /* error codes not used by current libcurl */ + default: + break; + } + /* + * By using a switch, gcc -Wall will complain about enum values + * which do not appear, helping keep this function up-to-date. + * By using gcc -Wall -Werror, you cannot forget. + * + * A table would not have the same benefit. Most compilers will generate + * code similar to a table in any case, so there is little performance gain + * from a table. Something is broken for the user's application, anyways, so + * does it matter how fast it _does not_ work? + * + * The line number for the error will be near this comment, which is why it + * is here, and not at the start of the switch. + */ + return "Unknown error"; +#else + if(!error) + return "No error"; + else + return "Error"; +#endif +} + +const char *curl_multi_strerror(CURLMcode error) +{ +#ifdef CURLVERBOSE + switch(error) { + case CURLM_CALL_MULTI_PERFORM: + return "Please call curl_multi_perform() soon"; + + case CURLM_OK: + return "No error"; + + case CURLM_BAD_HANDLE: + return "Invalid multi handle"; + + case CURLM_BAD_EASY_HANDLE: + return "Invalid easy handle"; + + case CURLM_OUT_OF_MEMORY: + return "Out of memory"; + + case CURLM_INTERNAL_ERROR: + return "Internal error"; + + case CURLM_BAD_SOCKET: + return "Invalid socket argument"; + + case CURLM_UNKNOWN_OPTION: + return "Unknown option"; + + case CURLM_ADDED_ALREADY: + return "The easy handle is already added to a multi handle"; + + case CURLM_RECURSIVE_API_CALL: + return "API function called from within callback"; + + case CURLM_WAKEUP_FAILURE: + return "Wakeup is unavailable or failed"; + + case CURLM_BAD_FUNCTION_ARGUMENT: + return "A libcurl function was given a bad argument"; + + case CURLM_ABORTED_BY_CALLBACK: + return "Operation was aborted by an application callback"; + + case CURLM_UNRECOVERABLE_POLL: + return "Unrecoverable error in select/poll"; + + case CURLM_LAST: + break; + } + + return "Unknown error"; +#else + if(error == CURLM_OK) + return "No error"; + else + return "Error"; +#endif +} + +const char *curl_share_strerror(CURLSHcode error) +{ +#ifdef CURLVERBOSE + switch(error) { + case CURLSHE_OK: + return "No error"; + + case CURLSHE_BAD_OPTION: + return "Unknown share option"; + + case CURLSHE_IN_USE: + return "Share currently in use"; + + case CURLSHE_INVALID: + return "Invalid share handle"; + + case CURLSHE_NOMEM: + return "Out of memory"; + + case CURLSHE_NOT_BUILT_IN: + return "Feature not enabled in this library"; + + case CURLSHE_LAST: + break; + } + + return "CURLSHcode unknown"; +#else + if(error == CURLSHE_OK) + return "No error"; + else + return "Error"; +#endif +} + +const char *curl_url_strerror(CURLUcode error) +{ +#ifdef CURLVERBOSE + switch(error) { + case CURLUE_OK: + return "No error"; + + case CURLUE_BAD_HANDLE: + return "An invalid CURLU pointer was passed as argument"; + + case CURLUE_BAD_PARTPOINTER: + return "An invalid 'part' argument was passed as argument"; + + case CURLUE_MALFORMED_INPUT: + return "Malformed input to a URL function"; + + case CURLUE_BAD_PORT_NUMBER: + return "Port number was not a decimal number between 0 and 65535"; + + case CURLUE_UNSUPPORTED_SCHEME: + return "Unsupported URL scheme"; + + case CURLUE_URLDECODE: + return "URL decode error, most likely because of rubbish in the input"; + + case CURLUE_OUT_OF_MEMORY: + return "A memory function failed"; + + case CURLUE_USER_NOT_ALLOWED: + return "Credentials was passed in the URL when prohibited"; + + case CURLUE_UNKNOWN_PART: + return "An unknown part ID was passed to a URL API function"; + + case CURLUE_NO_SCHEME: + return "No scheme part in the URL"; + + case CURLUE_NO_USER: + return "No user part in the URL"; + + case CURLUE_NO_PASSWORD: + return "No password part in the URL"; + + case CURLUE_NO_OPTIONS: + return "No options part in the URL"; + + case CURLUE_NO_HOST: + return "No host part in the URL"; + + case CURLUE_NO_PORT: + return "No port part in the URL"; + + case CURLUE_NO_QUERY: + return "No query part in the URL"; + + case CURLUE_NO_FRAGMENT: + return "No fragment part in the URL"; + + case CURLUE_NO_ZONEID: + return "No zoneid part in the URL"; + + case CURLUE_BAD_LOGIN: + return "Bad login part"; + + case CURLUE_BAD_IPV6: + return "Bad IPv6 address"; + + case CURLUE_BAD_HOSTNAME: + return "Bad hostname"; + + case CURLUE_BAD_FILE_URL: + return "Bad file:// URL"; + + case CURLUE_BAD_SLASHES: + return "Unsupported number of slashes following scheme"; + + case CURLUE_BAD_SCHEME: + return "Bad scheme"; + + case CURLUE_BAD_PATH: + return "Bad path"; + + case CURLUE_BAD_FRAGMENT: + return "Bad fragment"; + + case CURLUE_BAD_QUERY: + return "Bad query"; + + case CURLUE_BAD_PASSWORD: + return "Bad password"; + + case CURLUE_BAD_USER: + return "Bad user"; + + case CURLUE_LACKS_IDN: + return "libcurl lacks IDN support"; + + case CURLUE_TOO_LARGE: + return "A value or data field is larger than allowed"; + + case CURLUE_LAST: + break; + } + + return "CURLUcode unknown"; +#else + if(error == CURLUE_OK) + return "No error"; + else + return "Error"; +#endif +} + +#ifdef USE_WINDOWS_SSPI +/* + * Curl_sspi_strerror: + * Variant of curlx_strerror if the error code is definitely Windows SSPI. + */ +const char *Curl_sspi_strerror(SECURITY_STATUS err, char *buf, size_t buflen) +{ +#ifdef _WIN32 + DWORD old_win_err = GetLastError(); +#endif + int old_errno = errno; + VERBOSE(const char *txt); + + if(!buflen) + return NULL; + + *buf = '\0'; + +#ifdef CURLVERBOSE + switch(err) { + case SEC_E_OK: + txt = "No error"; + break; +#define SEC2TXT(sec) case sec: txt = #sec; break + SEC2TXT(CRYPT_E_REVOKED); + SEC2TXT(CRYPT_E_NO_REVOCATION_DLL); + SEC2TXT(CRYPT_E_NO_REVOCATION_CHECK); + SEC2TXT(CRYPT_E_REVOCATION_OFFLINE); + SEC2TXT(CRYPT_E_NOT_IN_REVOCATION_DATABASE); + SEC2TXT(SEC_E_ALGORITHM_MISMATCH); + SEC2TXT(SEC_E_BAD_BINDINGS); + SEC2TXT(SEC_E_BAD_PKGID); + SEC2TXT(SEC_E_BUFFER_TOO_SMALL); + SEC2TXT(SEC_E_CANNOT_INSTALL); + SEC2TXT(SEC_E_CANNOT_PACK); + SEC2TXT(SEC_E_CERT_EXPIRED); + SEC2TXT(SEC_E_CERT_UNKNOWN); + SEC2TXT(SEC_E_CERT_WRONG_USAGE); + SEC2TXT(SEC_E_CONTEXT_EXPIRED); + SEC2TXT(SEC_E_CROSSREALM_DELEGATION_FAILURE); + SEC2TXT(SEC_E_CRYPTO_SYSTEM_INVALID); + SEC2TXT(SEC_E_DECRYPT_FAILURE); + SEC2TXT(SEC_E_DELEGATION_POLICY); + SEC2TXT(SEC_E_DELEGATION_REQUIRED); + SEC2TXT(SEC_E_DOWNGRADE_DETECTED); + SEC2TXT(SEC_E_ENCRYPT_FAILURE); + SEC2TXT(SEC_E_ILLEGAL_MESSAGE); + SEC2TXT(SEC_E_INCOMPLETE_CREDENTIALS); + SEC2TXT(SEC_E_INCOMPLETE_MESSAGE); + SEC2TXT(SEC_E_INSUFFICIENT_MEMORY); + SEC2TXT(SEC_E_INTERNAL_ERROR); + SEC2TXT(SEC_E_INVALID_HANDLE); + SEC2TXT(SEC_E_INVALID_PARAMETER); + SEC2TXT(SEC_E_INVALID_TOKEN); + SEC2TXT(SEC_E_ISSUING_CA_UNTRUSTED); + SEC2TXT(SEC_E_ISSUING_CA_UNTRUSTED_KDC); + SEC2TXT(SEC_E_KDC_CERT_EXPIRED); + SEC2TXT(SEC_E_KDC_CERT_REVOKED); + SEC2TXT(SEC_E_KDC_INVALID_REQUEST); + SEC2TXT(SEC_E_KDC_UNABLE_TO_REFER); + SEC2TXT(SEC_E_KDC_UNKNOWN_ETYPE); + SEC2TXT(SEC_E_LOGON_DENIED); + SEC2TXT(SEC_E_MAX_REFERRALS_EXCEEDED); + SEC2TXT(SEC_E_MESSAGE_ALTERED); + SEC2TXT(SEC_E_MULTIPLE_ACCOUNTS); + SEC2TXT(SEC_E_MUST_BE_KDC); + SEC2TXT(SEC_E_NOT_OWNER); + SEC2TXT(SEC_E_NO_AUTHENTICATING_AUTHORITY); + SEC2TXT(SEC_E_NO_CREDENTIALS); + SEC2TXT(SEC_E_NO_IMPERSONATION); + SEC2TXT(SEC_E_NO_IP_ADDRESSES); + SEC2TXT(SEC_E_NO_KERB_KEY); + SEC2TXT(SEC_E_NO_PA_DATA); + SEC2TXT(SEC_E_NO_S4U_PROT_SUPPORT); + SEC2TXT(SEC_E_NO_TGT_REPLY); + SEC2TXT(SEC_E_OUT_OF_SEQUENCE); + SEC2TXT(SEC_E_PKINIT_CLIENT_FAILURE); + SEC2TXT(SEC_E_PKINIT_NAME_MISMATCH); + SEC2TXT(SEC_E_POLICY_NLTM_ONLY); + SEC2TXT(SEC_E_QOP_NOT_SUPPORTED); + SEC2TXT(SEC_E_REVOCATION_OFFLINE_C); + SEC2TXT(SEC_E_REVOCATION_OFFLINE_KDC); + SEC2TXT(SEC_E_SECPKG_NOT_FOUND); + SEC2TXT(SEC_E_SECURITY_QOS_FAILED); + SEC2TXT(SEC_E_SHUTDOWN_IN_PROGRESS); + SEC2TXT(SEC_E_SMARTCARD_CERT_EXPIRED); + SEC2TXT(SEC_E_SMARTCARD_CERT_REVOKED); + SEC2TXT(SEC_E_SMARTCARD_LOGON_REQUIRED); + SEC2TXT(SEC_E_STRONG_CRYPTO_NOT_SUPPORTED); + SEC2TXT(SEC_E_TARGET_UNKNOWN); + SEC2TXT(SEC_E_TIME_SKEW); + SEC2TXT(SEC_E_TOO_MANY_PRINCIPALS); + SEC2TXT(SEC_E_UNFINISHED_CONTEXT_DELETED); + SEC2TXT(SEC_E_UNKNOWN_CREDENTIALS); + SEC2TXT(SEC_E_UNSUPPORTED_FUNCTION); + SEC2TXT(SEC_E_UNSUPPORTED_PREAUTH); + SEC2TXT(SEC_E_UNTRUSTED_ROOT); + SEC2TXT(SEC_E_WRONG_CREDENTIAL_HANDLE); + SEC2TXT(SEC_E_WRONG_PRINCIPAL); + SEC2TXT(SEC_I_COMPLETE_AND_CONTINUE); + SEC2TXT(SEC_I_COMPLETE_NEEDED); + SEC2TXT(SEC_I_CONTEXT_EXPIRED); + SEC2TXT(SEC_I_CONTINUE_NEEDED); + SEC2TXT(SEC_I_INCOMPLETE_CREDENTIALS); + SEC2TXT(SEC_I_LOCAL_LOGON); + SEC2TXT(SEC_I_NO_LSA_CONTEXT); + SEC2TXT(SEC_I_RENEGOTIATE); + SEC2TXT(SEC_I_SIGNATURE_NEEDED); + default: + txt = "Unknown error"; + } + + if(err == SEC_E_ILLEGAL_MESSAGE) { + curl_msnprintf(buf, buflen, + "SEC_E_ILLEGAL_MESSAGE (0x%08lx) - This error usually " + "occurs when a fatal SSL/TLS alert is received (e.g. " + "handshake failed). More detail may be available in " + "the Windows System event log.", (unsigned long)err); + } + else { + char msgbuf[256]; + if(curlx_get_winapi_error((DWORD)err, msgbuf, sizeof(msgbuf))) + curl_msnprintf(buf, buflen, "%s (0x%08lx) - %s", txt, (unsigned long)err, + msgbuf); + else + curl_msnprintf(buf, buflen, "%s (0x%08lx)", txt, (unsigned long)err); + } +#else /* CURLVERBOSE */ + if(err == SEC_E_OK) + curlx_strcopy(buf, buflen, STRCONST("No error")); + else + curlx_strcopy(buf, buflen, STRCONST("Error")); +#endif + + if(errno != old_errno) + errno = old_errno; + +#ifdef _WIN32 + if(old_win_err != GetLastError()) + SetLastError(old_win_err); +#endif + + return buf; +} +#endif /* USE_WINDOWS_SSPI */ diff --git a/3rdparty/curl-8.21.0/lib/strerror.h b/3rdparty/curl-8.21.0/lib/strerror.h new file mode 100644 index 0000000000..4b9779ff2d --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/strerror.h @@ -0,0 +1,32 @@ +#ifndef HEADER_CURL_STRERROR_H +#define HEADER_CURL_STRERROR_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_WINDOWS_SSPI +const char *Curl_sspi_strerror(SECURITY_STATUS err, char *buf, size_t buflen); +#endif + +#endif /* HEADER_CURL_STRERROR_H */ diff --git a/3rdparty/curl-8.21.0/lib/system_win32.c b/3rdparty/curl-8.21.0/lib/system_win32.c new file mode 100644 index 0000000000..1b052357b5 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/system_win32.c @@ -0,0 +1,100 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Steve Holme, . + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef _WIN32 + +#include "system_win32.h" +#include "curl_sspi.h" +#include "curlx/timeval.h" +#include "curlx/version_win32.h" /* for curlx_verify_windows_init() */ + +/* Curl_win32_init() performs Win32 global initialization */ +CURLcode Curl_win32_init(long flags) +{ + /* CURL_GLOBAL_WIN32 controls the *optional* part of the initialization which + is for Winsock at the moment. Any required Win32 initialization + should take place after this block. */ + if(flags & CURL_GLOBAL_WIN32) { +#ifdef USE_WINSOCK + WORD wVersionRequested; + WSADATA wsaData; + int res; + + wVersionRequested = MAKEWORD(2, 2); + res = WSAStartup(wVersionRequested, &wsaData); + + if(res) + /* Tell the user that we could not find a usable */ + /* winsock.dll. */ + return CURLE_FAILED_INIT; + + /* Confirm that the Windows Sockets DLL supports what we need.*/ + /* Note that if the DLL supports versions greater */ + /* than wVersionRequested, it will still return */ + /* wVersionRequested in wVersion. wHighVersion contains the */ + /* highest supported version. */ + + if(LOBYTE(wsaData.wVersion) != LOBYTE(wVersionRequested) || + HIBYTE(wsaData.wVersion) != HIBYTE(wVersionRequested)) { + /* Tell the user that we could not find a usable */ + + /* winsock.dll. */ + WSACleanup(); + return CURLE_FAILED_INIT; + } + /* The Windows Sockets DLL is acceptable. Proceed. */ +#elif defined(USE_LWIPSOCK) + lwip_init(); +#endif + } /* CURL_GLOBAL_WIN32 */ + +#ifdef USE_WINDOWS_SSPI + { + CURLcode result = Curl_sspi_global_init(); + if(result) + return result; + } +#endif + + curlx_verify_windows_init(); + curlx_now_init(); + return CURLE_OK; +} + +/* Curl_win32_cleanup() is the opposite of Curl_win32_init() */ +void Curl_win32_cleanup(long init_flags) +{ +#ifdef USE_WINDOWS_SSPI + Curl_sspi_global_cleanup(); +#endif + + if(init_flags & CURL_GLOBAL_WIN32) { +#ifdef USE_WINSOCK + WSACleanup(); +#endif + } +} + +#endif /* _WIN32 */ diff --git a/3rdparty/curl-8.21.0/lib/system_win32.h b/3rdparty/curl-8.21.0/lib/system_win32.h new file mode 100644 index 0000000000..8a51f09670 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/system_win32.h @@ -0,0 +1,37 @@ +#ifndef HEADER_CURL_SYSTEM_WIN32_H +#define HEADER_CURL_SYSTEM_WIN32_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Steve Holme, . + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef _WIN32 +extern LARGE_INTEGER Curl_freq; + +CURLcode Curl_win32_init(long flags); +void Curl_win32_cleanup(long init_flags); +#else +#define Curl_win32_init(x) CURLE_OK +#endif /* _WIN32 */ + +#endif /* HEADER_CURL_SYSTEM_WIN32_H */ diff --git a/3rdparty/curl-8.21.0/lib/telnet.c b/3rdparty/curl-8.21.0/lib/telnet.c new file mode 100644 index 0000000000..2870d7e2c9 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/telnet.c @@ -0,0 +1,1581 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" +#include "urldata.h" +#include "telnet.h" + +#ifndef CURL_DISABLE_TELNET + +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETDB_H +#include +#endif +#ifdef HAVE_ARPA_INET_H +#include +#endif +#ifdef HAVE_NET_IF_H +#include +#endif +#ifdef HAVE_SYS_IOCTL_H +#include +#endif + +#ifdef HAVE_SYS_PARAM_H +#include +#endif + +#include "url.h" +#include "transfer.h" +#include "sendf.h" +#include "curl_trc.h" +#include "progress.h" +#include "arpa_telnet.h" +#include "connect.h" +#include "select.h" +#include "curlx/strparse.h" + +#define SUBBUFSIZE 512 + +#define CURL_SB_CLEAR(x) x->subpointer = (x)->subbuffer +#define CURL_SB_TERM(x) \ + do { \ + (x)->subend = (x)->subpointer; \ + CURL_SB_CLEAR(x); \ + } while(0) +#define CURL_SB_ACCUM(x, c) \ + do { \ + if((x)->subpointer < ((x)->subbuffer + sizeof((x)->subbuffer))) \ + *(x)->subpointer++ = (c); \ + } while(0) + +#define CURL_SB_GET(x) ((*(x)->subpointer++) & 0xff) +#define CURL_SB_LEN(x) ((x)->subend - (x)->subpointer) + +/* For posterity: +#define CURL_SB_PEEK(x) (*(x)->subpointer & 0xff) +#define CURL_SB_EOF(x) ((x)->subpointer >= (x)->subend) */ + +/* For negotiation compliant to RFC 1143 */ +#define CURL_NO 0 +#define CURL_YES 1 +#define CURL_WANTYES 2 +#define CURL_WANTNO 3 + +#define CURL_EMPTY 0 +#define CURL_OPPOSITE 1 + +/* meta key for storing protocol meta at easy handle */ +#define CURL_META_TELNET_EASY "meta:proto:telnet:easy" + +/* + * Telnet receiver states for fsm + */ +typedef enum { + CURL_TS_DATA = 0, + CURL_TS_IAC, + CURL_TS_WILL, + CURL_TS_WONT, + CURL_TS_DO, + CURL_TS_DONT, + CURL_TS_CR, + CURL_TS_SB, /* sub-option collection */ + CURL_TS_SE /* looking for sub-option end */ +} TelnetReceive; + +struct TELNET { + int please_negotiate; + int already_negotiated; + int us[256]; + int usq[256]; + int us_preferred[256]; + int him[256]; + int himq[256]; + int him_preferred[256]; + int subnegotiation[256]; + const char *subopt_ttype; /* Set with suboption TTYPE */ + const char *subopt_xdisploc; /* Set with suboption XDISPLOC */ + unsigned short subopt_wsx; /* Set with suboption NAWS */ + unsigned short subopt_wsy; /* Set with suboption NAWS */ + TelnetReceive telrcv_state; + struct curl_slist *telnet_vars; /* Environment variables */ + struct dynbuf out; /* output buffer */ + + /* suboptions */ + unsigned char subbuffer[SUBBUFSIZE]; + unsigned char *subpointer, *subend; /* buffer for sub-options */ +}; + +#ifndef CURLVERBOSE +#define printoption(a, b, c, d) Curl_nop_stmt +#else +static void printoption(struct Curl_easy *data, + const char *direction, int cmd, int option) +{ + if(data->set.verbose) { + if(cmd == CURL_IAC) { + if(CURL_TELCMD_OK(option)) + infof(data, "%s IAC %s", direction, CURL_TELCMD(option)); + else + infof(data, "%s IAC %d", direction, option); + } + else { + const char *fmt = (cmd == CURL_WILL) ? "WILL" : + (cmd == CURL_WONT) ? "WONT" : + (cmd == CURL_DO) ? "DO" : + (cmd == CURL_DONT) ? "DONT" : 0; + if(fmt) { + const char *opt; + if(CURL_TELOPT_OK(option)) + opt = CURL_TELOPT(option); + else if(option == CURL_TELOPT_EXOPL) + opt = "EXOPL"; + else + opt = NULL; + + if(opt) + infof(data, "%s %s %s", direction, fmt, opt); + else + infof(data, "%s %s %d", direction, fmt, option); + } + else + infof(data, "%s %d %d", direction, cmd, option); + } + } +} +#endif /* !CURLVERBOSE */ + +static void telnet_easy_dtor(void *key, size_t klen, void *entry) +{ + struct TELNET *tn = entry; + (void)key; + (void)klen; + curl_slist_free_all(tn->telnet_vars); + curlx_dyn_free(&tn->out); + curlx_free(tn); +} + +static CURLcode init_telnet(struct Curl_easy *data) +{ + struct TELNET *tn; + + tn = curlx_calloc(1, sizeof(struct TELNET)); + if(!tn) + return CURLE_OUT_OF_MEMORY; + + curlx_dyn_init(&tn->out, 0xffff); + + tn->telrcv_state = CURL_TS_DATA; + + /* Init suboptions */ + CURL_SB_CLEAR(tn); + + /* Set the options we want by default */ + tn->us_preferred[CURL_TELOPT_SGA] = CURL_YES; + tn->him_preferred[CURL_TELOPT_SGA] = CURL_YES; + + /* To be compliant with previous releases of libcurl we enable this option + by default. This behavior can be changed with the "BINARY" option in + CURLOPT_TELNETOPTIONS */ + tn->us_preferred[CURL_TELOPT_BINARY] = CURL_YES; + tn->him_preferred[CURL_TELOPT_BINARY] = CURL_YES; + + /* We must allow the server to echo what we sent but it is not necessary + to request the server to do so (it might force the server to close + the connection). Hence, we ignore ECHO in the negotiate function */ + tn->him_preferred[CURL_TELOPT_ECHO] = CURL_YES; + + /* Set the subnegotiation fields to send information after negotiation + passed (do/will) + + Default values are (0,0) initialized by calloc. + According to the RFC1013 it is valid: + A value equal to zero is acceptable for the width (or height), and means + that no character width (or height) is being sent. In this case, the width + (or height) that will be assumed by the Telnet server is operating system + specific (it will probably be based upon the terminal type information + that may have been sent using the TERMINAL TYPE Telnet option). */ + tn->subnegotiation[CURL_TELOPT_NAWS] = CURL_YES; + + return Curl_meta_set(data, CURL_META_TELNET_EASY, tn, telnet_easy_dtor); +} + +static void send_negotiation(struct Curl_easy *data, int cmd, int option) +{ + unsigned char buf[3]; + ssize_t bytes_written; + struct connectdata *conn = data->conn; + + buf[0] = CURL_IAC; + buf[1] = (unsigned char)cmd; + buf[2] = (unsigned char)option; + + bytes_written = swrite(conn->sock[FIRSTSOCKET], buf, 3); + if(bytes_written < 0) + failf(data, "Sending data failed (%d)", SOCKERRNO); + + printoption(data, "SENT", cmd, option); +} + +static void set_remote_option(struct Curl_easy *data, struct TELNET *tn, + int option, int newstate) +{ + if(newstate == CURL_YES) { + switch(tn->him[option]) { + case CURL_NO: + tn->him[option] = CURL_WANTYES; + send_negotiation(data, CURL_DO, option); + break; + + case CURL_YES: + /* Already enabled */ + break; + + case CURL_WANTNO: + switch(tn->himq[option]) { + case CURL_EMPTY: + /* Already negotiating for CURL_YES, queue the request */ + tn->himq[option] = CURL_OPPOSITE; + break; + case CURL_OPPOSITE: + /* Error: already queued an enable request */ + break; + } + break; + + case CURL_WANTYES: + switch(tn->himq[option]) { + case CURL_EMPTY: + /* Error: already negotiating for enable */ + break; + case CURL_OPPOSITE: + tn->himq[option] = CURL_EMPTY; + break; + } + break; + } + } + else { /* NO */ + switch(tn->him[option]) { + case CURL_NO: + /* Already disabled */ + break; + + case CURL_YES: + tn->him[option] = CURL_WANTNO; + send_negotiation(data, CURL_DONT, option); + break; + + case CURL_WANTNO: + switch(tn->himq[option]) { + case CURL_EMPTY: + /* Already negotiating for NO */ + break; + case CURL_OPPOSITE: + tn->himq[option] = CURL_EMPTY; + break; + } + break; + + case CURL_WANTYES: + switch(tn->himq[option]) { + case CURL_EMPTY: + tn->himq[option] = CURL_OPPOSITE; + break; + case CURL_OPPOSITE: + break; + } + break; + } + } +} + +static void set_local_option(struct Curl_easy *data, struct TELNET *tn, + int option, int newstate) +{ + if(newstate == CURL_YES) { + switch(tn->us[option]) { + case CURL_NO: + tn->us[option] = CURL_WANTYES; + send_negotiation(data, CURL_WILL, option); + break; + + case CURL_YES: + /* Already enabled */ + break; + + case CURL_WANTNO: + switch(tn->usq[option]) { + case CURL_EMPTY: + /* Already negotiating for CURL_YES, queue the request */ + tn->usq[option] = CURL_OPPOSITE; + break; + case CURL_OPPOSITE: + /* Error: already queued an enable request */ + break; + } + break; + + case CURL_WANTYES: + switch(tn->usq[option]) { + case CURL_EMPTY: + /* Error: already negotiating for enable */ + break; + case CURL_OPPOSITE: + tn->usq[option] = CURL_EMPTY; + break; + } + break; + } + } + else { /* NO */ + switch(tn->us[option]) { + case CURL_NO: + /* Already disabled */ + break; + + case CURL_YES: + tn->us[option] = CURL_WANTNO; + send_negotiation(data, CURL_WONT, option); + break; + + case CURL_WANTNO: + switch(tn->usq[option]) { + case CURL_EMPTY: + /* Already negotiating for NO */ + break; + case CURL_OPPOSITE: + tn->usq[option] = CURL_EMPTY; + break; + } + break; + + case CURL_WANTYES: + switch(tn->usq[option]) { + case CURL_EMPTY: + tn->usq[option] = CURL_OPPOSITE; + break; + case CURL_OPPOSITE: + break; + } + break; + } + } +} + +static void telnet_negotiate(struct Curl_easy *data, struct TELNET *tn) +{ + int i; + + for(i = 0; i < CURL_NTELOPTS; i++) { + if(i == CURL_TELOPT_ECHO) + continue; + + if(tn->us_preferred[i] == CURL_YES) + set_local_option(data, tn, i, CURL_YES); + + if(tn->him_preferred[i] == CURL_YES) + set_remote_option(data, tn, i, CURL_YES); + } +} + +static void rec_will(struct Curl_easy *data, struct TELNET *tn, int option) +{ + switch(tn->him[option]) { + case CURL_NO: + if(tn->him_preferred[option] == CURL_YES) { + tn->him[option] = CURL_YES; + send_negotiation(data, CURL_DO, option); + } + else + send_negotiation(data, CURL_DONT, option); + + break; + + case CURL_YES: + /* Already enabled */ + break; + + case CURL_WANTNO: + switch(tn->himq[option]) { + case CURL_EMPTY: + /* Error: DONT answered by WILL */ + tn->him[option] = CURL_NO; + break; + case CURL_OPPOSITE: + /* Error: DONT answered by WILL */ + tn->him[option] = CURL_YES; + tn->himq[option] = CURL_EMPTY; + break; + } + break; + + case CURL_WANTYES: + switch(tn->himq[option]) { + case CURL_EMPTY: + tn->him[option] = CURL_YES; + break; + case CURL_OPPOSITE: + tn->him[option] = CURL_WANTNO; + tn->himq[option] = CURL_EMPTY; + send_negotiation(data, CURL_DONT, option); + break; + } + break; + } +} + +static void rec_wont(struct Curl_easy *data, struct TELNET *tn, int option) +{ + switch(tn->him[option]) { + case CURL_NO: + /* Already disabled */ + break; + + case CURL_YES: + tn->him[option] = CURL_NO; + send_negotiation(data, CURL_DONT, option); + break; + + case CURL_WANTNO: + switch(tn->himq[option]) { + case CURL_EMPTY: + tn->him[option] = CURL_NO; + break; + + case CURL_OPPOSITE: + tn->him[option] = CURL_WANTYES; + tn->himq[option] = CURL_EMPTY; + send_negotiation(data, CURL_DO, option); + break; + } + break; + + case CURL_WANTYES: + switch(tn->himq[option]) { + case CURL_EMPTY: + tn->him[option] = CURL_NO; + break; + case CURL_OPPOSITE: + tn->him[option] = CURL_NO; + tn->himq[option] = CURL_EMPTY; + break; + } + break; + } +} + +static void printsub(struct Curl_easy *data, + int direction, /* '<' or '>' */ + const unsigned char *pointer, /* ptr to suboption data */ + size_t length) /* suboption data length */ +{ + if(data->set.verbose) { + unsigned int i = 0; + if(direction) { + infof(data, "%s IAC SB ", (direction == '<') ? "RCVD" : "SENT"); + if(length >= 3) { + int j; + + i = pointer[length - 2]; + j = pointer[length - 1]; + + if(i != CURL_IAC || j != CURL_SE) { + infof(data, "(terminated by "); + if(CURL_TELOPT_OK(i)) + infof(data, "%s ", CURL_TELOPT(i)); + else if(CURL_TELCMD_OK(i)) + infof(data, "%s ", CURL_TELCMD(i)); + else + infof(data, "%u ", i); + if(CURL_TELOPT_OK(j)) + infof(data, "%s", CURL_TELOPT(j)); + else if(CURL_TELCMD_OK(j)) + infof(data, "%s", CURL_TELCMD(j)); + else + infof(data, "%d", j); + infof(data, ", not IAC SE) "); + } + } + if(length >= 2) + length -= 2; + else /* bad input */ + return; + } + if(length <= 1) { + infof(data, "(Empty suboption?)"); + return; + } + + if(CURL_TELOPT_OK(pointer[0])) { + switch(pointer[0]) { + case CURL_TELOPT_TTYPE: + case CURL_TELOPT_XDISPLOC: + case CURL_TELOPT_NEW_ENVIRON: + case CURL_TELOPT_NAWS: + infof(data, "%s", CURL_TELOPT(pointer[0])); + break; + default: + infof(data, "%s (unsupported)", CURL_TELOPT(pointer[0])); + break; + } + } + else + infof(data, "%d (unknown)", pointer[0]); + + switch(pointer[0]) { + case CURL_TELOPT_NAWS: + if(length > 4) + infof(data, "Width: %d ; Height: %d", (pointer[1] << 8) | pointer[2], + (pointer[3] << 8) | pointer[4]); + break; + default: + switch(pointer[1]) { + case CURL_TELQUAL_IS: + infof(data, " IS"); + break; + case CURL_TELQUAL_SEND: + infof(data, " SEND"); + break; + case CURL_TELQUAL_INFO: + infof(data, " INFO/REPLY"); + break; + case CURL_TELQUAL_NAME: + infof(data, " NAME"); + break; + } + + switch(pointer[0]) { + case CURL_TELOPT_TTYPE: + case CURL_TELOPT_XDISPLOC: + infof(data, " \"%.*s\"", + (int)((length > 2) ? (length - 2) : 0), &pointer[2]); + break; + case CURL_TELOPT_NEW_ENVIRON: + if(pointer[1] == CURL_TELQUAL_IS) { + infof(data, " "); + for(i = 3; i < length; i++) { + switch(pointer[i]) { + case CURL_NEW_ENV_VAR: + infof(data, ", "); + break; + case CURL_NEW_ENV_VALUE: + infof(data, " = "); + break; + default: + infof(data, "%c", pointer[i]); + break; + } + } + } + break; + default: + for(i = 2; i < length; i++) + infof(data, " %.2x", pointer[i]); + break; + } + } + } +} + +/* Escape and send a telnet data block */ +static CURLcode send_telnet_data(struct Curl_easy *data, + struct TELNET *tn, + const char *buffer, ssize_t nread) +{ + size_t i, outlen; + const unsigned char *outbuf; + CURLcode result = CURLE_OK; + size_t bytes_written; + size_t total_written = 0; + struct connectdata *conn = data->conn; + + DEBUGASSERT(tn); + DEBUGASSERT(nread > 0); + if(nread < 0) + return CURLE_TOO_LARGE; + + if(memchr(buffer, CURL_IAC, nread)) { + /* only use the escape buffer when necessary */ + curlx_dyn_reset(&tn->out); + + for(i = 0; i < (size_t)nread && !result; i++) { + result = curlx_dyn_addn(&tn->out, &buffer[i], 1); + if(!result && ((unsigned char)buffer[i] == CURL_IAC)) + /* IAC is FF in hex */ + result = curlx_dyn_addn(&tn->out, "\xff", 1); + } + + outlen = curlx_dyn_len(&tn->out); + outbuf = curlx_dyn_uptr(&tn->out); + } + else { + outlen = (size_t)nread; + outbuf = (const unsigned char *)buffer; + } + while(!result && total_written < outlen) { + /* Make sure socket is writable to avoid EWOULDBLOCK condition */ + struct pollfd pfd[1]; + timediff_t timeout_ms = Curl_timeleft_ms(data); + pfd[0].fd = conn->sock[FIRSTSOCKET]; + pfd[0].events = POLLOUT; + if(timeout_ms < 0) + return CURLE_OPERATION_TIMEDOUT; + /* 0 means no timeout configured; pass -1 to poll for infinite wait */ + switch(Curl_poll(pfd, 1, timeout_ms ? timeout_ms : -1)) { + case -1: /* error, abort writing */ + result = CURLE_SEND_ERROR; + break; + case 0: /* timeout */ + result = CURLE_OPERATION_TIMEDOUT; + break; + default: /* write! */ + bytes_written = 0; + result = Curl_xfer_send(data, outbuf + total_written, + outlen - total_written, FALSE, &bytes_written); + total_written += bytes_written; + break; + } + } + + return result; +} + +/* + * sendsuboption() + * + * Send suboption information to the server side. + */ +static void sendsuboption(struct Curl_easy *data, + struct TELNET *tn, int option) +{ + ssize_t bytes_written; + unsigned short x, y; + const unsigned char *uc1, *uc2; + struct connectdata *conn = data->conn; + + switch(option) { + case CURL_TELOPT_NAWS: + /* We prepare data to be sent */ + CURL_SB_CLEAR(tn); + CURL_SB_ACCUM(tn, CURL_IAC); + CURL_SB_ACCUM(tn, CURL_SB); + CURL_SB_ACCUM(tn, CURL_TELOPT_NAWS); + /* We must deal either with little or big endian processors */ + /* Window size must be sent according to the 'network order' */ + x = htons(tn->subopt_wsx); + y = htons(tn->subopt_wsy); + uc1 = (const unsigned char *)&x; + uc2 = (const unsigned char *)&y; + CURL_SB_ACCUM(tn, uc1[0]); + CURL_SB_ACCUM(tn, uc1[1]); + CURL_SB_ACCUM(tn, uc2[0]); + CURL_SB_ACCUM(tn, uc2[1]); + + CURL_SB_ACCUM(tn, CURL_IAC); + CURL_SB_ACCUM(tn, CURL_SE); + CURL_SB_TERM(tn); + /* data suboption is now ready */ + + printsub(data, '>', (const unsigned char *)tn->subbuffer + 2, + CURL_SB_LEN(tn) - 2); + + /* we send the header of the suboption... */ + bytes_written = swrite(conn->sock[FIRSTSOCKET], tn->subbuffer, 3); + if(bytes_written < 0) + failf(data, "Sending data failed (%d)", SOCKERRNO); + /* ... then the window size with the send_telnet_data() function + to deal with 0xFF cases ... */ + send_telnet_data(data, tn, (const char *)tn->subbuffer + 3, 4); + /* ... and the footer */ + bytes_written = swrite(conn->sock[FIRSTSOCKET], tn->subbuffer + 7, 2); + if(bytes_written < 0) + failf(data, "Sending data failed (%d)", SOCKERRNO); + break; + } +} + +static void rec_do(struct Curl_easy *data, struct TELNET *tn, int option) +{ + switch(tn->us[option]) { + case CURL_NO: + if(tn->us_preferred[option] == CURL_YES) { + tn->us[option] = CURL_YES; + send_negotiation(data, CURL_WILL, option); + if(tn->subnegotiation[option] == CURL_YES) + /* transmission of data option */ + sendsuboption(data, tn, option); + } + else if(tn->subnegotiation[option] == CURL_YES) { + /* send information to achieve this option */ + tn->us[option] = CURL_YES; + send_negotiation(data, CURL_WILL, option); + sendsuboption(data, tn, option); + } + else + send_negotiation(data, CURL_WONT, option); + break; + + case CURL_YES: + /* Already enabled */ + break; + + case CURL_WANTNO: + switch(tn->usq[option]) { + case CURL_EMPTY: + /* Error: DONT answered by WILL */ + tn->us[option] = CURL_NO; + break; + case CURL_OPPOSITE: + /* Error: DONT answered by WILL */ + tn->us[option] = CURL_YES; + tn->usq[option] = CURL_EMPTY; + break; + } + break; + + case CURL_WANTYES: + switch(tn->usq[option]) { + case CURL_EMPTY: + tn->us[option] = CURL_YES; + if(tn->subnegotiation[option] == CURL_YES) { + /* transmission of data option */ + sendsuboption(data, tn, option); + } + break; + case CURL_OPPOSITE: + tn->us[option] = CURL_WANTNO; + tn->usq[option] = CURL_EMPTY; + send_negotiation(data, CURL_WONT, option); + break; + } + break; + } +} + +static void rec_dont(struct Curl_easy *data, struct TELNET *tn, int option) +{ + switch(tn->us[option]) { + case CURL_NO: + /* Already disabled */ + break; + + case CURL_YES: + tn->us[option] = CURL_NO; + send_negotiation(data, CURL_WONT, option); + break; + + case CURL_WANTNO: + switch(tn->usq[option]) { + case CURL_EMPTY: + tn->us[option] = CURL_NO; + break; + + case CURL_OPPOSITE: + tn->us[option] = CURL_WANTYES; + tn->usq[option] = CURL_EMPTY; + send_negotiation(data, CURL_WILL, option); + break; + } + break; + + case CURL_WANTYES: + switch(tn->usq[option]) { + case CURL_EMPTY: + tn->us[option] = CURL_NO; + break; + case CURL_OPPOSITE: + tn->us[option] = CURL_NO; + tn->usq[option] = CURL_EMPTY; + break; + } + break; + } +} + +static bool str_is_nonascii(const char *str) +{ + char c; + while((c = *str++) != 0) + if(c & 0x80) + return TRUE; + + return FALSE; +} + +static CURLcode check_telnet_options(struct Curl_easy *data, + struct TELNET *tn) +{ + struct curl_slist *head; + struct curl_slist *beg; + CURLcode result = CURLE_OK; + + /* Add the username as an environment variable if it + was given on the command line */ + if(data->state.creds) { + char buffer[256]; + if(str_is_nonascii(Curl_creds_user(data->conn->creds))) { + DEBUGF(infof(data, "set a non ASCII username in telnet")); + return CURLE_BAD_FUNCTION_ARGUMENT; + } + curl_msnprintf(buffer, sizeof(buffer), "USER,%s", + Curl_creds_user(data->conn->creds)); + beg = curl_slist_append(tn->telnet_vars, buffer); + if(!beg) { + curl_slist_free_all(tn->telnet_vars); + tn->telnet_vars = NULL; + return CURLE_OUT_OF_MEMORY; + } + tn->telnet_vars = beg; + tn->us_preferred[CURL_TELOPT_NEW_ENVIRON] = CURL_YES; + } + + for(head = data->set.telnet_options; head && !result; head = head->next) { + size_t olen; + const char *option = head->data; + const char *arg; + const char *sep = strchr(option, '='); + if(sep) { + olen = sep - option; + arg = ++sep; + if(str_is_nonascii(arg)) + continue; + switch(olen) { + case 5: + /* Terminal type */ + if(curl_strnequal(option, "TTYPE", 5)) { + tn->subopt_ttype = arg; + tn->us_preferred[CURL_TELOPT_TTYPE] = CURL_YES; + break; + } + result = CURLE_UNKNOWN_OPTION; + break; + + case 8: + /* Display variable */ + if(curl_strnequal(option, "XDISPLOC", 8)) { + tn->subopt_xdisploc = arg; + tn->us_preferred[CURL_TELOPT_XDISPLOC] = CURL_YES; + break; + } + result = CURLE_UNKNOWN_OPTION; + break; + + case 7: + /* Environment variable */ + if(curl_strnequal(option, "NEW_ENV", 7)) { + beg = curl_slist_append(tn->telnet_vars, arg); + if(!beg) { + result = CURLE_OUT_OF_MEMORY; + break; + } + tn->telnet_vars = beg; + tn->us_preferred[CURL_TELOPT_NEW_ENVIRON] = CURL_YES; + } + else + result = CURLE_UNKNOWN_OPTION; + break; + + case 2: + /* Window Size */ + if(curl_strnequal(option, "WS", 2)) { + const char *p = arg; + curl_off_t x = 0; + curl_off_t y = 0; + if(curlx_str_number(&p, &x, 0xffff) || + curlx_str_single(&p, 'x') || + curlx_str_number(&p, &y, 0xffff)) { + failf(data, "Syntax error in telnet option: %s", head->data); + result = CURLE_SETOPT_OPTION_SYNTAX; + } + else { + tn->subopt_wsx = (unsigned short)x; + tn->subopt_wsy = (unsigned short)y; + tn->us_preferred[CURL_TELOPT_NAWS] = CURL_YES; + } + } + else + result = CURLE_UNKNOWN_OPTION; + break; + + case 6: + /* To take care or not of the 8th bit in data exchange */ + if(curl_strnequal(option, "BINARY", 6)) { + const char *p = arg; + curl_off_t binary_option; + if(!curlx_str_number(&p, &binary_option, 1) && + (binary_option != 1)) { + tn->us_preferred[CURL_TELOPT_BINARY] = CURL_NO; + tn->him_preferred[CURL_TELOPT_BINARY] = CURL_NO; + } + } + else + result = CURLE_UNKNOWN_OPTION; + break; + default: + failf(data, "Unknown telnet option %s", head->data); + result = CURLE_UNKNOWN_OPTION; + break; + } + } + else { + failf(data, "Syntax error in telnet option: %s", head->data); + result = CURLE_SETOPT_OPTION_SYNTAX; + } + } + + if(result) { + curl_slist_free_all(tn->telnet_vars); + tn->telnet_vars = NULL; + } + + return result; +} + +/* if the option contains an IAC code, it should be escaped in the output, but + as we cannot think of any legit way to send that as part of the content we + rather ban its use instead */ +static bool bad_option(const char *data) +{ + return !data || !!strchr(data, CURL_IAC); +} + +/* + * suboption() + * + * Look at the sub-option buffer, and try to be helpful to the other + * side. + */ +static CURLcode suboption(struct Curl_easy *data, struct TELNET *tn) +{ + struct curl_slist *v; + unsigned char temp[2048]; + ssize_t bytes_written; + size_t len; + struct connectdata *conn = data->conn; + + if(!CURL_SB_LEN(tn)) /* ignore empty suboption */ + return CURLE_OK; + + printsub(data, '<', (const unsigned char *)tn->subbuffer, + CURL_SB_LEN(tn) + 2); + switch(CURL_SB_GET(tn)) { + case CURL_TELOPT_TTYPE: + if(bad_option(tn->subopt_ttype)) + return CURLE_BAD_FUNCTION_ARGUMENT; + if(strlen(tn->subopt_ttype) > 1000) { + failf(data, "Too long telnet TTYPE"); + return CURLE_SEND_ERROR; + } + len = curl_msnprintf((char *)temp, sizeof(temp), "%c%c%c%c%s%c%c", + CURL_IAC, CURL_SB, CURL_TELOPT_TTYPE, + CURL_TELQUAL_IS, tn->subopt_ttype, CURL_IAC, + CURL_SE); + bytes_written = swrite(conn->sock[FIRSTSOCKET], temp, len); + + if(bytes_written < 0) { + failf(data, "Sending data failed (%d)", SOCKERRNO); + return CURLE_SEND_ERROR; + } + printsub(data, '>', &temp[2], len-2); + break; + case CURL_TELOPT_XDISPLOC: + if(bad_option(tn->subopt_xdisploc)) + return CURLE_BAD_FUNCTION_ARGUMENT; + if(strlen(tn->subopt_xdisploc) > 1000) { + failf(data, "Too long telnet XDISPLOC"); + return CURLE_SEND_ERROR; + } + len = curl_msnprintf((char *)temp, sizeof(temp), "%c%c%c%c%s%c%c", + CURL_IAC, CURL_SB, CURL_TELOPT_XDISPLOC, + CURL_TELQUAL_IS, tn->subopt_xdisploc, CURL_IAC, + CURL_SE); + bytes_written = swrite(conn->sock[FIRSTSOCKET], temp, len); + if(bytes_written < 0) { + failf(data, "Sending data failed (%d)", SOCKERRNO); + return CURLE_SEND_ERROR; + } + printsub(data, '>', &temp[2], len - 2); + break; + case CURL_TELOPT_NEW_ENVIRON: + len = curl_msnprintf((char *)temp, sizeof(temp), "%c%c%c%c", + CURL_IAC, CURL_SB, CURL_TELOPT_NEW_ENVIRON, + CURL_TELQUAL_IS); + for(v = tn->telnet_vars; v; v = v->next) { + size_t tmplen = (strlen(v->data) + 1); + if(bad_option(v->data)) + return CURLE_BAD_FUNCTION_ARGUMENT; + /* Add the variable if it fits */ + if(len + tmplen < sizeof(temp) - 6) { + const char *s = strchr(v->data, ','); + if(!s) + len += curl_msnprintf((char *)&temp[len], sizeof(temp) - len, + "%c%s", CURL_NEW_ENV_VAR, v->data); + else { + size_t vlen = s - v->data; + len += curl_msnprintf((char *)&temp[len], sizeof(temp) - len, + "%c%.*s%c%s", CURL_NEW_ENV_VAR, + (int)vlen, v->data, CURL_NEW_ENV_VALUE, ++s); + } + } + } + curl_msnprintf((char *)&temp[len], sizeof(temp) - len, + "%c%c", CURL_IAC, CURL_SE); + len += 2; + bytes_written = swrite(conn->sock[FIRSTSOCKET], temp, len); + if(bytes_written < 0) + failf(data, "Sending data failed (%d)", SOCKERRNO); + printsub(data, '>', &temp[2], len - 2); + break; + } + return CURLE_OK; +} + +static CURLcode telrcv(struct Curl_easy *data, + struct TELNET *tn, + const unsigned char *inbuf, /* Data received from + socket */ + ssize_t count) /* Number of bytes + received */ +{ + unsigned char c; + CURLcode result; + int in = 0; + int startwrite = -1; + +#define startskipping() \ + if(startwrite >= 0) { \ + result = Curl_client_write(data, \ + CLIENTWRITE_BODY, \ + (const char *)&inbuf[startwrite], \ + in-startwrite); \ + if(result) \ + return result; \ + } \ + startwrite = -1 + +#define writebyte() \ + if(startwrite < 0) \ + startwrite = in + +#define bufferflush() startskipping() + + while(count--) { + c = inbuf[in]; + + switch(tn->telrcv_state) { + case CURL_TS_CR: + tn->telrcv_state = CURL_TS_DATA; + if(c == '\0') { + startskipping(); + break; /* Ignore \0 after CR */ + } + writebyte(); + break; + + case CURL_TS_DATA: + if(c == CURL_IAC) { + tn->telrcv_state = CURL_TS_IAC; + startskipping(); + break; + } + else if(c == '\r') + tn->telrcv_state = CURL_TS_CR; + writebyte(); + break; + + case CURL_TS_IAC: + DEBUGASSERT(startwrite < 0); + switch(c) { + case CURL_WILL: + tn->telrcv_state = CURL_TS_WILL; + break; + case CURL_WONT: + tn->telrcv_state = CURL_TS_WONT; + break; + case CURL_DO: + tn->telrcv_state = CURL_TS_DO; + break; + case CURL_DONT: + tn->telrcv_state = CURL_TS_DONT; + break; + case CURL_SB: + CURL_SB_CLEAR(tn); + tn->telrcv_state = CURL_TS_SB; + break; + case CURL_IAC: + tn->telrcv_state = CURL_TS_DATA; + writebyte(); + break; + case CURL_DM: + case CURL_NOP: + case CURL_GA: + default: + tn->telrcv_state = CURL_TS_DATA; + printoption(data, "RCVD", CURL_IAC, c); + break; + } + break; + + case CURL_TS_WILL: + printoption(data, "RCVD", CURL_WILL, c); + tn->please_negotiate = 1; + rec_will(data, tn, c); + tn->telrcv_state = CURL_TS_DATA; + break; + + case CURL_TS_WONT: + printoption(data, "RCVD", CURL_WONT, c); + tn->please_negotiate = 1; + rec_wont(data, tn, c); + tn->telrcv_state = CURL_TS_DATA; + break; + + case CURL_TS_DO: + printoption(data, "RCVD", CURL_DO, c); + tn->please_negotiate = 1; + rec_do(data, tn, c); + tn->telrcv_state = CURL_TS_DATA; + break; + + case CURL_TS_DONT: + printoption(data, "RCVD", CURL_DONT, c); + tn->please_negotiate = 1; + rec_dont(data, tn, c); + tn->telrcv_state = CURL_TS_DATA; + break; + + case CURL_TS_SB: + if(c == CURL_IAC) + tn->telrcv_state = CURL_TS_SE; + else + CURL_SB_ACCUM(tn, c); + break; + + case CURL_TS_SE: + if(c != CURL_SE) { + if(c != CURL_IAC) { + /* + * This is an error. We only expect to get "IAC IAC" or "IAC SE". + * Several things may have happened. An IAC was not doubled, the IAC + * SE was left off, or another option got inserted into the + * suboption are all possibilities. + */ + failf(data, "telnet: suboption error"); + return CURLE_RECV_ERROR; + } + CURL_SB_ACCUM(tn, c); + tn->telrcv_state = CURL_TS_SB; + } + else { + CURL_SB_ACCUM(tn, CURL_IAC); + CURL_SB_ACCUM(tn, CURL_SE); + tn->subpointer -= 2; + CURL_SB_TERM(tn); + result = suboption(data, tn); /* handle sub-option */ + if(result) + return result; + tn->telrcv_state = CURL_TS_DATA; + } + break; + } + ++in; + } + bufferflush(); + return CURLE_OK; +} + +static CURLcode telnet_done(struct Curl_easy *data, + CURLcode status, bool premature) +{ + (void)status; + (void)premature; + Curl_meta_remove(data, CURL_META_TELNET_EASY); + return CURLE_OK; +} + +static CURLcode telnet_do(struct Curl_easy *data, bool *done) +{ + CURLcode result; + struct connectdata *conn = data->conn; + curl_socket_t sockfd = conn->sock[FIRSTSOCKET]; +#ifdef USE_WINSOCK + WSAEVENT event_handle; + WSANETWORKEVENTS events; + HANDLE stdin_handle; + HANDLE objs[2]; + DWORD obj_count; + DWORD wait_timeout; + DWORD readfile_read; +#else + timediff_t interval_ms; + struct pollfd pfd[2]; + int poll_cnt; + ssize_t snread; +#endif + bool keepon = TRUE; + char buffer[4 * 1024]; + struct TELNET *tn; + + *done = TRUE; /* unconditionally */ + + result = init_telnet(data); + if(result) + return result; + + tn = Curl_meta_get(data, CURL_META_TELNET_EASY); + if(!tn) + return CURLE_FAILED_INIT; + + result = check_telnet_options(data, tn); + if(result) + return result; + +#ifdef USE_WINSOCK + /* We want to wait for both stdin and the socket. Since + * the select() function in Winsock only works on sockets + * we have to use the WaitForMultipleObjects() call. + */ + + /* First, create a sockets event object */ + event_handle = WSACreateEvent(); + if(event_handle == WSA_INVALID_EVENT) { + failf(data, "WSACreateEvent failed (%d)", SOCKERRNO); + return CURLE_FAILED_INIT; + } + + /* Tell Winsock what events we want to listen to */ + if(WSAEventSelect(sockfd, event_handle, FD_READ | FD_CLOSE) != 0) { + WSACloseEvent(event_handle); + return CURLE_RECV_ERROR; + } + + /* Then get the Windows file handle for stdin */ + stdin_handle = GetStdHandle(STD_INPUT_HANDLE); + + /* Create the list of objects to wait for */ + objs[0] = event_handle; + objs[1] = stdin_handle; + + /* If stdin_handle is a pipe, use PeekNamedPipe() method to check it, + else use the old WaitForMultipleObjects() way */ + if(GetFileType(stdin_handle) == FILE_TYPE_PIPE || data->set.is_fread_set) { + /* Do not wait for stdin_handle, wait for event_handle */ + obj_count = 1; + /* Check stdin_handle per 100 milliseconds */ + wait_timeout = 100; + } + else { + obj_count = 2; + wait_timeout = 1000; + } + + /* Keep on listening and act on events */ + while(keepon) { + const DWORD buf_size = (DWORD)sizeof(buffer); + DWORD waitret = WaitForMultipleObjects(obj_count, objs, + FALSE, wait_timeout); + switch(waitret) { + + case WAIT_TIMEOUT: { + for(;;) { + if(data->set.is_fread_set) { + size_t n; + /* read from user-supplied method */ + n = data->state.fread_func(buffer, 1, buf_size, data->state.in); + if(n == CURL_READFUNC_ABORT) { + keepon = FALSE; + result = CURLE_READ_ERROR; + break; + } + + if(n == CURL_READFUNC_PAUSE) + break; + + if(n == 0) /* no bytes */ + break; + + /* fall through with number of bytes read */ + readfile_read = (DWORD)n; + } + else { + /* read from stdin */ + if(!PeekNamedPipe(stdin_handle, NULL, 0, NULL, + &readfile_read, NULL)) { + keepon = FALSE; + result = CURLE_READ_ERROR; + break; + } + + if(!readfile_read) + break; + + if(!ReadFile(stdin_handle, buffer, buf_size, &readfile_read, NULL)) { + keepon = FALSE; + result = CURLE_READ_ERROR; + break; + } + } + + result = send_telnet_data(data, tn, buffer, readfile_read); + if(result) { + keepon = FALSE; + break; + } + } + } + break; + + case WAIT_OBJECT_0 + 1: { + if(!ReadFile(stdin_handle, buffer, buf_size, &readfile_read, NULL)) { + keepon = FALSE; + result = CURLE_READ_ERROR; + break; + } + + result = send_telnet_data(data, tn, buffer, readfile_read); + if(result) { + keepon = FALSE; + break; + } + } + break; + + case WAIT_OBJECT_0: { + events.lNetworkEvents = 0; + if(WSAEnumNetworkEvents(sockfd, event_handle, &events) != 0) { + int sockerr = SOCKERRNO; + if(sockerr != SOCKEINPROGRESS) { + infof(data, "WSAEnumNetworkEvents failed (%d)", sockerr); + keepon = FALSE; + result = CURLE_READ_ERROR; + } + break; + } + if(events.lNetworkEvents & FD_READ) { + /* read data from network */ + size_t nread; + result = Curl_xfer_recv(data, buffer, sizeof(buffer), &nread); + /* read would have blocked. Loop again */ + if(result == CURLE_AGAIN) + break; + /* returned not-zero, this an error */ + else if(result) { + keepon = FALSE; + break; + } + /* returned zero but actually received 0 or less here, + the server closed the connection and we bail out */ + else if(!nread) { + keepon = FALSE; + break; + } + + result = telrcv(data, tn, (unsigned char *)buffer, nread); + if(result) { + keepon = FALSE; + break; + } + + /* Negotiate if the peer has started negotiating, + otherwise do not. We do not want to speak telnet with + non-telnet servers, like POP or SMTP. */ + if(tn->please_negotiate && !tn->already_negotiated) { + telnet_negotiate(data, tn); + tn->already_negotiated = 1; + } + } + if(events.lNetworkEvents & FD_CLOSE) { + keepon = FALSE; + } + break; + } + } /* switch */ + + if(data->set.timeout) { + if(curlx_ptimediff_ms(Curl_pgrs_now(data), &conn->created) >= + data->set.timeout) { + failf(data, "Time-out"); + result = CURLE_OPERATION_TIMEDOUT; + keepon = FALSE; + } + } + } + + /* We called WSACreateEvent, so call WSACloseEvent */ + if(!WSACloseEvent(event_handle)) { + infof(data, "WSACloseEvent failed (%d)", SOCKERRNO); + } +#else + pfd[0].fd = sockfd; + pfd[0].events = POLLIN; + + if(data->set.is_fread_set) { + poll_cnt = 1; + interval_ms = 100; /* poll user-supplied read function */ + } + else { + /* really using fread, so infile is a FILE* */ + pfd[1].fd = fileno((FILE *)data->state.in); + pfd[1].events = POLLIN; + poll_cnt = 2; + interval_ms = 1 * 1000; + if(pfd[1].fd < 0) { + failf(data, "cannot read input"); + result = CURLE_RECV_ERROR; + keepon = FALSE; + } + } + + while(keepon) { + DEBUGF(infof(data, "telnet_do, poll %d fds", poll_cnt)); + switch(Curl_poll(pfd, (unsigned int)poll_cnt, interval_ms)) { + case -1: /* error, stop reading */ + keepon = FALSE; + continue; + case 0: /* timeout */ + pfd[0].revents = 0; + pfd[1].revents = 0; + FALLTHROUGH(); + default: /* read! */ + if(pfd[0].revents & POLLIN) { + /* read data from network */ + size_t nread; + result = Curl_xfer_recv(data, buffer, sizeof(buffer), &nread); + /* read would have blocked. Loop again */ + if(result == CURLE_AGAIN) + break; + /* returned not-zero, this an error */ + if(result) { + keepon = FALSE; + /* In test 1452, macOS sees a ECONNRESET sometimes? Is this the + * telnet test server not shutting down the socket in a clean way? + * Seems to be timing related, happens more on slow debug build */ + if(data->state.os_errno == SOCKECONNRESET) { + DEBUGF(infof(data, "telnet_do, unexpected ECONNRESET on recv")); + } + break; + } + /* returned zero but actually received 0 or less here, + the server closed the connection and we bail out */ + else if(!nread) { + keepon = FALSE; + break; + } + + Curl_pgrs_download_inc(data, nread); + result = telrcv(data, tn, (unsigned char *)buffer, nread); + if(result) { + keepon = FALSE; + break; + } + + /* Negotiate if the peer has started negotiating, + otherwise do not. We do not want to speak telnet with + non-telnet servers, like POP or SMTP. */ + if(tn->please_negotiate && !tn->already_negotiated) { + telnet_negotiate(data, tn); + tn->already_negotiated = 1; + } + } + + snread = 0; + if(poll_cnt == 2) { + if(pfd[1].revents & POLLIN) { /* read from in file */ + snread = read(pfd[1].fd, buffer, sizeof(buffer)); + } + } + else { + /* read from user-supplied method */ + snread = (int)data->state.fread_func(buffer, 1, sizeof(buffer), + data->state.in); + if(snread == CURL_READFUNC_ABORT) { + keepon = FALSE; + break; + } + if(snread == CURL_READFUNC_PAUSE) + break; + } + + if(snread > 0) { + result = send_telnet_data(data, tn, buffer, snread); + if(result) { + keepon = FALSE; + break; + } + Curl_pgrs_upload_inc(data, (size_t)snread); + } + else if(snread < 0) + keepon = FALSE; + + break; + } /* poll switch statement */ + + if(data->set.timeout) { + if(curlx_ptimediff_ms(Curl_pgrs_now(data), &conn->created) >= + data->set.timeout) { + failf(data, "Time-out"); + result = CURLE_OPERATION_TIMEDOUT; + keepon = FALSE; + } + } + + if(!result) { + result = Curl_pgrsUpdate(data); + if(result) + keepon = FALSE; + } + } +#endif + /* mark this as "no further transfer wanted" */ + Curl_xfer_setup_nop(data); + + return result; +} + +/* + * TELNET protocol handler. + */ +const struct Curl_protocol Curl_protocol_telnet = { + ZERO_NULL, /* setup_connection */ + telnet_do, /* do_it */ + telnet_done, /* done */ + ZERO_NULL, /* do_more */ + ZERO_NULL, /* connect_it */ + ZERO_NULL, /* connecting */ + ZERO_NULL, /* doing */ + ZERO_NULL, /* proto_pollset */ + ZERO_NULL, /* doing_pollset */ + ZERO_NULL, /* domore_pollset */ + ZERO_NULL, /* perform_pollset */ + ZERO_NULL, /* disconnect */ + ZERO_NULL, /* write_resp */ + ZERO_NULL, /* write_resp_hd */ + ZERO_NULL, /* connection_is_dead */ + ZERO_NULL, /* attach connection */ + ZERO_NULL, /* follow */ +}; + +#endif /* !CURL_DISABLE_TELNET */ diff --git a/3rdparty/curl-8.21.0/lib/telnet.h b/3rdparty/curl-8.21.0/lib/telnet.h new file mode 100644 index 0000000000..3848fff3ba --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/telnet.h @@ -0,0 +1,30 @@ +#ifndef HEADER_CURL_TELNET_H +#define HEADER_CURL_TELNET_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#ifndef CURL_DISABLE_TELNET +extern const struct Curl_protocol Curl_protocol_telnet; +#endif + +#endif /* HEADER_CURL_TELNET_H */ diff --git a/3rdparty/curl-8.21.0/lib/tftp.c b/3rdparty/curl-8.21.0/lib/tftp.c new file mode 100644 index 0000000000..00e89752bd --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/tftp.c @@ -0,0 +1,1360 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" +#include "urldata.h" +#include "tftp.h" + +#ifndef CURL_DISABLE_TFTP + +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETDB_H +#include +#endif +#ifdef HAVE_ARPA_INET_H +#include +#endif +#ifdef HAVE_NET_IF_H +#include +#endif +#ifdef HAVE_SYS_IOCTL_H +#include +#endif + +#ifdef HAVE_SYS_PARAM_H +#include +#endif + +#include "cfilters.h" +#include "cf-socket.h" +#include "transfer.h" +#include "sendf.h" +#include "curl_trc.h" +#include "progress.h" +#include "connect.h" +#include "sockaddr.h" /* required for Curl_sockaddr_storage */ +#include "url.h" +#include "strcase.h" +#include "select.h" +#include "escape.h" +#include "curlx/strerr.h" +#include "curlx/strparse.h" +#include "curlx/strcopy.h" + +/* RFC2348 allows the block size to be negotiated */ +#define TFTP_BLKSIZE_DEFAULT 512 +#define TFTP_OPTION_BLKSIZE "blksize" + +/* from RFC2349: */ +#define TFTP_OPTION_TSIZE "tsize" +#define TFTP_OPTION_INTERVAL "timeout" + +typedef enum { + TFTP_MODE_NETASCII = 0, + TFTP_MODE_OCTET +} tftp_mode_t; + +typedef enum { + TFTP_STATE_START = 0, + TFTP_STATE_RX, + TFTP_STATE_TX, + TFTP_STATE_FIN +} tftp_state_t; + +typedef enum { + TFTP_EVENT_NONE = -1, + TFTP_EVENT_INIT = 0, + TFTP_EVENT_RRQ = 1, + TFTP_EVENT_WRQ = 2, + TFTP_EVENT_DATA = 3, + TFTP_EVENT_ACK = 4, + TFTP_EVENT_ERROR = 5, + TFTP_EVENT_OACK = 6, + TFTP_EVENT_TIMEOUT +} tftp_event_t; + +typedef enum { + TFTP_ERR_UNDEF = 0, + TFTP_ERR_NOTFOUND, + TFTP_ERR_PERM, + TFTP_ERR_DISKFULL, + TFTP_ERR_ILLEGAL, + TFTP_ERR_UNKNOWNID, + TFTP_ERR_EXISTS, + TFTP_ERR_NOSUCHUSER, /* This will never be triggered by this code */ + + /* The remaining error codes are internal to curl */ + TFTP_ERR_NONE = -100, + TFTP_ERR_TIMEOUT, + TFTP_ERR_NORESPONSE +} tftp_error_t; + +struct tftp_packet { + unsigned char *data; +}; + +/* meta key for storing protocol meta at connection */ +#define CURL_META_TFTP_CONN "meta:proto:tftp:conn" + +struct tftp_conn { + struct Curl_sockaddr_storage local_addr; + struct Curl_sockaddr_storage remote_addr; + struct tftp_packet rpacket; + struct tftp_packet spacket; + tftp_state_t state; + tftp_mode_t mode; + tftp_error_t error; + tftp_event_t event; + struct Curl_easy *data; + curl_socket_t sockfd; + int retries; + int retry_time; + int retry_max; + time_t rx_time; + curl_socklen_t remote_addrlen; + int rbytes; + size_t sbytes; + unsigned int blksize; + unsigned int requested_blksize; + unsigned short block; + BIT(remote_pinned); +}; + +/********************************************************** + * + * tftp_set_timeouts - + * + * Set timeouts based on state machine state. + * Use user provided connect timeouts until DATA or ACK + * packet is received, then use user-provided transfer timeouts + * + * + **********************************************************/ +static CURLcode tftp_set_timeouts(struct tftp_conn *state) +{ + time_t timeout; + timediff_t timeout_ms; + + /* Compute drop-dead time */ + timeout_ms = Curl_timeleft_ms(state->data); + + if(timeout_ms < 0) { + /* time-out, bail out, go home */ + failf(state->data, "Connection time-out"); + return CURLE_OPERATION_TIMEDOUT; + } + + /* Set per-block timeout to total */ + if((timeout_ms > 0) && (timeout_ms < 3600000)) + /* do the calculation only if the timeout is "reasonable" */ + timeout = (time_t)(timeout_ms + 500) / 1000; + else + timeout = 15; + + /* Average reposting an ACK after 5 seconds */ + state->retry_max = (int)timeout / 5; + + /* Bound the total number */ + if(state->retry_max < 3) + state->retry_max = 3; + + if(state->retry_max > 50) + state->retry_max = 50; + + /* Compute the re-ACK interval to suit the timeout */ + state->retry_time = (int)(timeout / state->retry_max); + if(state->retry_time < 1) + state->retry_time = 1; + + infof(state->data, + "set timeouts for state %d; Total %" FMT_OFF_T ", retry %d maxtry %d", + (int)state->state, timeout_ms, state->retry_time, state->retry_max); + + /* init RX time */ + state->rx_time = time(NULL); + + return CURLE_OK; +} + +/********************************************************** + * + * tftp_set_send_first + * + * Event handler for the START state + * + **********************************************************/ + +static void setpacketevent(struct tftp_packet *packet, unsigned short num) +{ + packet->data[0] = (unsigned char)(num >> 8); + packet->data[1] = (unsigned char)(num & 0xff); +} + +static void setpacketblock(struct tftp_packet *packet, unsigned short num) +{ + packet->data[2] = (unsigned char)(num >> 8); + packet->data[3] = (unsigned char)(num & 0xff); +} + +static unsigned short getrpacketevent(const struct tftp_packet *packet) +{ + return (unsigned short)((packet->data[0] << 8) | packet->data[1]); +} + +static unsigned short getrpacketblock(const struct tftp_packet *packet) +{ + return (unsigned short)((packet->data[2] << 8) | packet->data[3]); +} + +static size_t tftp_strnlen(const char *string, size_t maxlen) +{ + const char *end = memchr(string, '\0', maxlen); + return end ? (size_t)(end - string) : maxlen; +} + +static const char *tftp_option_get(const char *buf, size_t len, + const char **option, const char **value) +{ + size_t loc; + + loc = tftp_strnlen(buf, len); + loc++; /* NULL term */ + + if(loc >= len) + return NULL; + *option = buf; + + loc += tftp_strnlen(buf + loc, len - loc); + loc++; /* NULL term */ + + if(loc > len) + return NULL; + *value = &buf[strlen(*option) + 1]; + + return &buf[loc]; +} + +static CURLcode tftp_parse_option_ack(struct tftp_conn *state, + const char *ptr, int len) +{ + const char *tmp = ptr; + struct Curl_easy *data = state->data; + + /* if OACK does not contain blksize option, the default (512) must be used */ + state->blksize = TFTP_BLKSIZE_DEFAULT; + + while(tmp < ptr + len) { + const char *option, *value; + size_t olen; + + tmp = tftp_option_get(tmp, ptr + len - tmp, &option, &value); + if(!tmp) { + failf(data, "Malformed ACK packet, rejecting"); + return CURLE_TFTP_ILLEGAL; + } + olen = strlen(option); + + infof(data, "got option=(%s) value=(%s)", option, value); + + if((strlen(TFTP_OPTION_BLKSIZE) == olen) && + checkprefix(TFTP_OPTION_BLKSIZE, option)) { + curl_off_t blksize; + if(curlx_str_number(&value, &blksize, TFTP_BLKSIZE_MAX)) { + failf(data, "%s (%d)", "blksize is larger than max supported", + TFTP_BLKSIZE_MAX); + return CURLE_TFTP_ILLEGAL; + } + if(!blksize) { + failf(data, "invalid blocksize value in OACK packet"); + return CURLE_TFTP_ILLEGAL; + } + else if(blksize < TFTP_BLKSIZE_MIN) { + failf(data, "%s (%d)", "blksize is smaller than min supported", + TFTP_BLKSIZE_MIN); + return CURLE_TFTP_ILLEGAL; + } + else if(blksize > state->requested_blksize) { + /* could realloc pkt buffers here, but the spec does not call out + * support for the server requesting a bigger blksize than the client + * requests */ + failf(data, "server requested blksize larger than allocated (%" + CURL_FORMAT_CURL_OFF_T ")", blksize); + return CURLE_TFTP_ILLEGAL; + } + + state->blksize = (unsigned int)blksize; + infof(data, "blksize parsed from OACK (%u) requested (%u)", + state->blksize, state->requested_blksize); + } + else if((strlen(TFTP_OPTION_TSIZE) == olen) && + checkprefix(TFTP_OPTION_TSIZE, option)) { + curl_off_t tsize = 0; + /* tsize should be ignored on upload: Who cares about the size of the + remote file? */ + if(!data->state.upload && + !curlx_str_number(&value, &tsize, CURL_OFF_T_MAX)) { + if(!tsize) { + failf(data, "invalid tsize -:%s:- value in OACK packet", value); + return CURLE_TFTP_ILLEGAL; + } + infof(data, "tsize parsed from OACK (%" CURL_FORMAT_CURL_OFF_T ")", + tsize); + Curl_pgrsSetDownloadSize(data, tsize); + } + } + } + + return CURLE_OK; +} + +static CURLcode tftp_option_add(struct tftp_conn *state, size_t *csize, + size_t index, const char *option) +{ + char *buf = (char *)&state->spacket.data[index]; + size_t oplen = strlen(option); + size_t blen; + if((state->blksize <= index) || + (oplen + 1) > (size_t)(state->blksize - index)) + return CURLE_TFTP_ILLEGAL; + blen = state->blksize - index; + curlx_strcopy(buf, blen, option, oplen); + *csize += oplen + 1; + return CURLE_OK; +} + +/* the next blocknum is x + 1 but it needs to wrap at an unsigned 16-bit + boundary */ +#define NEXT_BLOCKNUM(x) (((x) + 1) & 0xffff) + +/********************************************************** + * + * tftp_tx + * + * Event handler for the TX state + * + **********************************************************/ +static CURLcode tftp_tx(struct tftp_conn *state, tftp_event_t event) +{ + struct Curl_easy *data = state->data; + ssize_t sbytes; + CURLcode result = CURLE_OK; + struct SingleRequest *k = &data->req; + size_t cb; /* Bytes currently read */ + char buffer[STRERROR_LEN]; + char *bufptr; + bool eos; + + switch(event) { + + case TFTP_EVENT_ACK: + case TFTP_EVENT_OACK: + if(event == TFTP_EVENT_ACK) { + /* Ack the packet */ + int rblock = getrpacketblock(&state->rpacket); + + if(rblock != state->block && + /* There is a bug in tftpd-hpa that causes it to send us an ACK for + * 65535 when the block number wraps to 0. To handle it, when we are + * expecting 0, also accept 65535. See + * https://www.syslinux.org/archives/2010-September/015612.html + * */ + !(state->block == 0 && rblock == 65535)) { + /* This is not the expected block. Log it and up the retry counter */ + infof(data, "Received ACK for block %d, expecting %d", + rblock, state->block); + state->retries++; + /* Bail out if over the maximum */ + if(state->retries > state->retry_max) { + failf(data, "tftp_tx: giving up waiting for block %d ack", + state->block); + result = CURLE_SEND_ERROR; + } + else { + /* Re-send the data packet */ + sbytes = sendto(state->sockfd, (void *)state->spacket.data, + 4 + (SEND_TYPE_ARG3)state->sbytes, SEND_4TH_ARG, + (struct sockaddr *)&state->remote_addr, + state->remote_addrlen); + /* Check all sbytes were sent */ + if(sbytes < 0) { + failf(data, "%s", + curlx_strerror(SOCKERRNO, buffer, sizeof(buffer))); + result = CURLE_SEND_ERROR; + } + } + + return result; + } + /* This is the expected packet. Reset the counters and send the next + block */ + state->rx_time = time(NULL); + state->block++; + } + else + state->block = 1; /* first data block is 1 when using OACK */ + + state->retries = 0; + setpacketevent(&state->spacket, TFTP_EVENT_DATA); + setpacketblock(&state->spacket, state->block); + if(state->block > 1 && state->sbytes < state->blksize) { + state->state = TFTP_STATE_FIN; + return CURLE_OK; + } + + /* TFTP considers data block size < 512 bytes as an end of session, so + * in some cases we must wait for additional data to build full (512 bytes) + * data block. + * */ + state->sbytes = 0; + bufptr = (char *)state->spacket.data + 4; + do { + result = Curl_client_read(data, bufptr, state->blksize - state->sbytes, + &cb, &eos); + if(result) + return result; + state->sbytes += cb; + bufptr += cb; + } while(state->sbytes < state->blksize && cb); + + sbytes = sendto(state->sockfd, (void *)state->spacket.data, + 4 + (SEND_TYPE_ARG3)state->sbytes, SEND_4TH_ARG, + (struct sockaddr *)&state->remote_addr, + state->remote_addrlen); + /* Check all sbytes were sent */ + if(sbytes < 0) { + failf(data, "%s", curlx_strerror(SOCKERRNO, buffer, sizeof(buffer))); + return CURLE_SEND_ERROR; + } + /* Update the progress meter */ + k->writebytecount += state->sbytes; + Curl_pgrs_upload_inc(data, state->sbytes); + break; + + case TFTP_EVENT_TIMEOUT: + /* Increment the retry counter and log the timeout */ + state->retries++; + infof(data, "Timeout waiting for block %d ACK. " + "Retries = %d", NEXT_BLOCKNUM(state->block), state->retries); + /* Decide if we have had enough */ + if(state->retries > state->retry_max) { + state->error = TFTP_ERR_TIMEOUT; + state->state = TFTP_STATE_FIN; + } + else { + /* Re-send the data packet */ + sbytes = sendto(state->sockfd, (void *)state->spacket.data, + 4 + (SEND_TYPE_ARG3)state->sbytes, SEND_4TH_ARG, + (struct sockaddr *)&state->remote_addr, + state->remote_addrlen); + /* Check all sbytes were sent */ + if(sbytes < 0) { + failf(data, "%s", curlx_strerror(SOCKERRNO, buffer, sizeof(buffer))); + return CURLE_SEND_ERROR; + } + /* since this was a re-send, we remain at the still byte position */ + Curl_pgrsSetUploadCounter(data, k->writebytecount); + } + break; + + case TFTP_EVENT_ERROR: + state->state = TFTP_STATE_FIN; + setpacketevent(&state->spacket, TFTP_EVENT_ERROR); + setpacketblock(&state->spacket, state->block); + (void)sendto(state->sockfd, (void *)state->spacket.data, 4, SEND_4TH_ARG, + (struct sockaddr *)&state->remote_addr, + state->remote_addrlen); + /* do not bother with the return code, but if the socket is still up we + * should be a good TFTP client and let the server know we are done */ + state->state = TFTP_STATE_FIN; + break; + + default: + failf(data, "tftp_tx: internal error, event: %d", (int)event); + break; + } + + return result; +} + +static CURLcode tftp_connect_for_tx(struct tftp_conn *state, + tftp_event_t event) +{ + CURLcode result; + + infof(state->data, "%s", "Connected for transmit"); + + state->state = TFTP_STATE_TX; + result = tftp_set_timeouts(state); + if(result) + return result; + return tftp_tx(state, event); +} + +/********************************************************** + * + * tftp_rx + * + * Event handler for the RX state + * + **********************************************************/ +static CURLcode tftp_rx(struct tftp_conn *state, tftp_event_t event) +{ + ssize_t sbytes; + int rblock; + struct Curl_easy *data = state->data; + char buffer[STRERROR_LEN]; + + switch(event) { + + case TFTP_EVENT_DATA: + /* Is this the block we expect? */ + rblock = getrpacketblock(&state->rpacket); + if(NEXT_BLOCKNUM(state->block) == rblock) { + /* This is the expected block. Reset counters and ACK it. */ + state->retries = 0; + } + else if(state->block == rblock) { + /* This is the last recently received block again. Log it and ACK it + again. */ + infof(data, "Received last DATA packet block %d again.", rblock); + } + else { + /* totally unexpected, log it */ + infof(data, + "Received unexpected DATA packet block %d, expecting block %d", + rblock, NEXT_BLOCKNUM(state->block)); + break; + } + + /* ACK this block. */ + state->block = (unsigned short)rblock; + setpacketevent(&state->spacket, TFTP_EVENT_ACK); + setpacketblock(&state->spacket, state->block); + sbytes = sendto(state->sockfd, (void *)state->spacket.data, + 4, SEND_4TH_ARG, + (struct sockaddr *)&state->remote_addr, + state->remote_addrlen); + if(sbytes < 0) { + failf(data, "%s", curlx_strerror(SOCKERRNO, buffer, sizeof(buffer))); + return CURLE_SEND_ERROR; + } + + /* Check if completed (That is, a less than full packet is received) */ + if(state->rbytes < (ssize_t)state->blksize + 4) { + state->state = TFTP_STATE_FIN; + } + else { + state->state = TFTP_STATE_RX; + } + state->rx_time = time(NULL); + break; + + case TFTP_EVENT_OACK: + /* ACK option acknowledgement so we can move on to data */ + state->block = 0; + state->retries = 0; + setpacketevent(&state->spacket, TFTP_EVENT_ACK); + setpacketblock(&state->spacket, state->block); + sbytes = sendto(state->sockfd, (void *)state->spacket.data, + 4, SEND_4TH_ARG, + (struct sockaddr *)&state->remote_addr, + state->remote_addrlen); + if(sbytes < 0) { + failf(data, "%s", curlx_strerror(SOCKERRNO, buffer, sizeof(buffer))); + return CURLE_SEND_ERROR; + } + + /* we are ready to RX data */ + state->state = TFTP_STATE_RX; + state->rx_time = time(NULL); + break; + + case TFTP_EVENT_TIMEOUT: + /* Increment the retry count and fail if over the limit */ + state->retries++; + infof(data, + "Timeout waiting for block %d ACK. Retries = %d", + NEXT_BLOCKNUM(state->block), state->retries); + if(state->retries > state->retry_max) { + state->error = TFTP_ERR_TIMEOUT; + state->state = TFTP_STATE_FIN; + } + else { + /* Resend the previous ACK */ + sbytes = sendto(state->sockfd, (void *)state->spacket.data, + 4, SEND_4TH_ARG, + (struct sockaddr *)&state->remote_addr, + state->remote_addrlen); + if(sbytes < 0) { + failf(data, "%s", curlx_strerror(SOCKERRNO, buffer, sizeof(buffer))); + return CURLE_SEND_ERROR; + } + } + break; + + case TFTP_EVENT_ERROR: + setpacketevent(&state->spacket, TFTP_EVENT_ERROR); + setpacketblock(&state->spacket, state->block); + (void)sendto(state->sockfd, (void *)state->spacket.data, + 4, SEND_4TH_ARG, + (struct sockaddr *)&state->remote_addr, + state->remote_addrlen); + /* do not bother with the return code, but if the socket is still up we + * should be a good TFTP client and let the server know we are done */ + state->state = TFTP_STATE_FIN; + break; + + default: + failf(data, "%s", "tftp_rx: internal error"); + return CURLE_TFTP_ILLEGAL; /* not really the perfect return code for + this */ + } + return CURLE_OK; +} + +static CURLcode tftp_connect_for_rx(struct tftp_conn *state, + tftp_event_t event) +{ + CURLcode result; + + infof(state->data, "%s", "Connected for receive"); + + state->state = TFTP_STATE_RX; + result = tftp_set_timeouts(state); + if(result) + return result; + return tftp_rx(state, event); +} + +static CURLcode tftp_send_first(struct tftp_conn *state, + tftp_event_t event) +{ + size_t sbytes; + ssize_t senddata; + const char *mode = "octet"; + char *filename; + struct Curl_easy *data = state->data; + const struct Curl_sockaddr_ex *remote_addr = NULL; + CURLcode result = CURLE_OK; + + /* Set ASCII mode if -B flag was used */ + if(data->state.prefer_ascii) + mode = "netascii"; + + switch(event) { + + case TFTP_EVENT_INIT: /* Send the first packet out */ + case TFTP_EVENT_TIMEOUT: /* Resend the first packet out */ + /* Increment the retry counter, quit if over the limit */ + state->retries++; + if(state->retries > state->retry_max) { + state->error = TFTP_ERR_NORESPONSE; + state->state = TFTP_STATE_FIN; + return result; + } + + if(data->state.upload) { + /* If we are uploading, send a WRQ */ + setpacketevent(&state->spacket, TFTP_EVENT_WRQ); + if(data->state.infilesize != -1) + Curl_pgrsSetUploadSize(data, data->state.infilesize); + } + else { + /* If we are downloading, send an RRQ */ + setpacketevent(&state->spacket, TFTP_EVENT_RRQ); + } + /* As RFC3617 describes the separator slash is not actually part of the + filename so we skip the always-present first letter of the path + string. */ + if(!state->data->state.up.path[1]) { + failf(data, "Missing filename"); + return CURLE_TFTP_ILLEGAL; + } + result = Curl_urldecode(&state->data->state.up.path[1], 0, + &filename, NULL, REJECT_ZERO); + if(result) + return result; + + if(strlen(filename) + strlen(mode) + 4 > state->blksize) { + failf(data, "TFTP filename too long"); + curlx_free(filename); + return CURLE_TFTP_ILLEGAL; /* too long filename field */ + } + + sbytes = 2 + + curl_msnprintf((char *)state->spacket.data + 2, + state->blksize, + "%s%c%s%c", filename, '\0', mode, '\0'); + curlx_free(filename); + + /* optional addition of TFTP options */ + if(!data->set.tftp_no_options) { + char buf[64]; + /* add tsize option */ + curl_msnprintf(buf, sizeof(buf), "%" FMT_OFF_T, + data->state.upload && (data->state.infilesize != -1) ? + data->state.infilesize : 0); + + result = tftp_option_add(state, &sbytes, sbytes, TFTP_OPTION_TSIZE); + if(result == CURLE_OK) + result = tftp_option_add(state, &sbytes, sbytes, buf); + + /* add blksize option */ + curl_msnprintf(buf, sizeof(buf), "%u", state->requested_blksize); + if(result == CURLE_OK) + result = tftp_option_add(state, &sbytes, sbytes, TFTP_OPTION_BLKSIZE); + if(result == CURLE_OK) + result = tftp_option_add(state, &sbytes, sbytes, buf); + + /* add timeout option */ + curl_msnprintf(buf, sizeof(buf), "%d", state->retry_time); + if(result == CURLE_OK) + result = tftp_option_add(state, &sbytes, sbytes, TFTP_OPTION_INTERVAL); + if(result == CURLE_OK) + result = tftp_option_add(state, &sbytes, sbytes, buf); + + if(result != CURLE_OK) { + failf(data, "TFTP buffer too small for options"); + return CURLE_TFTP_ILLEGAL; + } + } + + /* the typecast for the 3rd argument is mostly for systems that do + not have a size_t argument, like older unixes that want an 'int' */ +#ifdef __AMIGA__ +#define CURL_SENDTO_ARG5(x) CURL_UNCONST(x) +#else +#define CURL_SENDTO_ARG5(x) (x) +#endif + remote_addr = Curl_conn_get_remote_addr(data, FIRSTSOCKET); + if(!remote_addr) + return CURLE_FAILED_INIT; + + senddata = sendto(state->sockfd, (void *)state->spacket.data, + (SEND_TYPE_ARG3)sbytes, 0, + CURL_SENDTO_ARG5(&remote_addr->curl_sa_addr), + (curl_socklen_t)remote_addr->addrlen); + if(senddata != (ssize_t)sbytes) { + char buffer[STRERROR_LEN]; + failf(data, "%s", curlx_strerror(SOCKERRNO, buffer, sizeof(buffer))); + return CURLE_SEND_ERROR; + } + break; + + case TFTP_EVENT_OACK: + if(data->state.upload) { + result = tftp_connect_for_tx(state, event); + } + else { + result = tftp_connect_for_rx(state, event); + } + break; + + case TFTP_EVENT_ACK: /* Connected for transmit */ + result = tftp_connect_for_tx(state, event); + break; + + case TFTP_EVENT_DATA: /* Connected for receive */ + result = tftp_connect_for_rx(state, event); + break; + + case TFTP_EVENT_ERROR: + state->state = TFTP_STATE_FIN; + break; + + default: + failf(state->data, "tftp_send_first: internal error"); + return CURLE_TFTP_ILLEGAL; + } + + return result; +} + +/********************************************************** + * + * tftp_translate_code + * + * Translate internal error codes to CURL error codes + * + **********************************************************/ +static CURLcode tftp_translate_code(tftp_error_t error) +{ + CURLcode result = CURLE_OK; + + if(error != TFTP_ERR_NONE) { + switch(error) { + case TFTP_ERR_NOTFOUND: + result = CURLE_TFTP_NOTFOUND; + break; + case TFTP_ERR_PERM: + result = CURLE_TFTP_PERM; + break; + case TFTP_ERR_DISKFULL: + result = CURLE_REMOTE_DISK_FULL; + break; + case TFTP_ERR_UNDEF: + case TFTP_ERR_ILLEGAL: + result = CURLE_TFTP_ILLEGAL; + break; + case TFTP_ERR_UNKNOWNID: + result = CURLE_TFTP_UNKNOWNID; + break; + case TFTP_ERR_EXISTS: + result = CURLE_REMOTE_FILE_EXISTS; + break; + case TFTP_ERR_NOSUCHUSER: + result = CURLE_TFTP_NOSUCHUSER; + break; + case TFTP_ERR_TIMEOUT: + result = CURLE_OPERATION_TIMEDOUT; + break; + case TFTP_ERR_NORESPONSE: + result = CURLE_COULDNT_CONNECT; + break; + default: + result = CURLE_ABORTED_BY_CALLBACK; + break; + } + } + else + result = CURLE_OK; + + return result; +} + +/********************************************************** + * + * tftp_state_machine + * + * The tftp state machine event dispatcher + * + **********************************************************/ +static CURLcode tftp_state_machine(struct tftp_conn *state, + tftp_event_t event) +{ + CURLcode result = CURLE_OK; + struct Curl_easy *data = state->data; + + switch(state->state) { + case TFTP_STATE_START: + DEBUGF(infof(data, "TFTP_STATE_START")); + result = tftp_send_first(state, event); + break; + case TFTP_STATE_RX: + DEBUGF(infof(data, "TFTP_STATE_RX")); + result = tftp_rx(state, event); + break; + case TFTP_STATE_TX: + DEBUGF(infof(data, "TFTP_STATE_TX")); + result = tftp_tx(state, event); + break; + case TFTP_STATE_FIN: + infof(data, "%s", "TFTP finished"); + break; + default: + DEBUGF(infof(data, "STATE: %d", (int)state->state)); + failf(data, "%s", "Internal state machine error"); + result = CURLE_TFTP_ILLEGAL; + break; + } + + return result; +} + +static void tftp_conn_dtor(void *key, size_t klen, void *entry) +{ + struct tftp_conn *state = entry; + (void)key; + (void)klen; + curlx_safefree(state->rpacket.data); + curlx_safefree(state->spacket.data); + curlx_free(state); +} + +/********************************************************** + * + * tftp_connect + * + * The connect callback + * + **********************************************************/ +static CURLcode tftp_connect(struct Curl_easy *data, bool *done) +{ + struct tftp_conn *state; + int blksize; + int need_blksize; + struct connectdata *conn = data->conn; + const struct Curl_sockaddr_ex *remote_addr = NULL; + CURLcode result; + + blksize = TFTP_BLKSIZE_DEFAULT; + + state = curlx_calloc(1, sizeof(*state)); + if(!state || + Curl_conn_meta_set(conn, CURL_META_TFTP_CONN, state, tftp_conn_dtor)) + return CURLE_OUT_OF_MEMORY; + + /* alloc pkt buffers based on specified blksize */ + if(data->set.tftp_blksize) + /* range checked when set */ + blksize = (int)data->set.tftp_blksize; + + need_blksize = blksize; + /* default size is the fallback when no OACK is received */ + if(need_blksize < TFTP_BLKSIZE_DEFAULT) + need_blksize = TFTP_BLKSIZE_DEFAULT; + + if(!state->rpacket.data) { + state->rpacket.data = curlx_calloc(1, need_blksize + 2 + 2); + + if(!state->rpacket.data) + return CURLE_OUT_OF_MEMORY; + } + + if(!state->spacket.data) { + state->spacket.data = curlx_calloc(1, need_blksize + 2 + 2); + + if(!state->spacket.data) + return CURLE_OUT_OF_MEMORY; + } + + /* we do not keep TFTP connections up because there is none or little gain + * for UDP */ + connclose(conn, "TFTP"); + + state->data = data; + state->sockfd = conn->sock[FIRSTSOCKET]; + state->state = TFTP_STATE_START; + state->error = TFTP_ERR_NONE; + state->blksize = TFTP_BLKSIZE_DEFAULT; /* Unless updated by OACK response */ + state->requested_blksize = blksize; + + remote_addr = Curl_conn_get_remote_addr(data, FIRSTSOCKET); + DEBUGASSERT(remote_addr); + if(!remote_addr) + return CURLE_FAILED_INIT; + + ((struct sockaddr *)&state->local_addr)->sa_family = + (CURL_SA_FAMILY_T)(remote_addr->family); + + result = tftp_set_timeouts(state); + if(result) + return result; + + if(!conn->bits.bound) { + /* If not already bound, bind to any interface, random UDP port. If it is + * reused or a custom local port was desired, this has already been done! + * + * We once used the size of the local_addr struct as the third argument + * for bind() to better work with IPv6 or whatever size the struct could + * have, but we learned that at least Tru64, AIX and IRIX *requires* the + * size of that argument to match the exact size of a 'sockaddr_in' struct + * when running IPv4-only. + * + * Therefore we use the size from the address we connected to, which we + * assume uses the same IP version and thus hopefully this works for both + * IPv4 and IPv6... + */ + int rc = bind(state->sockfd, (struct sockaddr *)&state->local_addr, + (curl_socklen_t)remote_addr->addrlen); + if(rc) { + char buffer[STRERROR_LEN]; + failf(data, "bind() failed; %s", + curlx_strerror(SOCKERRNO, buffer, sizeof(buffer))); + return CURLE_COULDNT_CONNECT; + } + conn->bits.bound = TRUE; + } + + Curl_pgrsStartNow(data); + + *done = TRUE; + + return CURLE_OK; +} + +/********************************************************** + * + * tftp_done + * + * The done callback + * + **********************************************************/ +static CURLcode tftp_done(struct Curl_easy *data, CURLcode status, + bool premature) +{ + CURLcode result = CURLE_OK; + struct connectdata *conn = data->conn; + struct tftp_conn *state = Curl_conn_meta_get(conn, CURL_META_TFTP_CONN); + + (void)status; + (void)premature; + + if(Curl_pgrsDone(data)) + return CURLE_ABORTED_BY_CALLBACK; + + /* If we have encountered an error */ + if(state) + result = tftp_translate_code(state->error); + + return result; +} + +static CURLcode tftp_pollset(struct Curl_easy *data, + struct easy_pollset *ps) +{ + return Curl_pollset_add_in(data, ps, data->conn->sock[FIRSTSOCKET]); +} + +/********************************************************** + * + * tftp_receive_packet + * + * Called once select fires and data is ready on the socket + * + **********************************************************/ +static CURLcode tftp_receive_packet(struct Curl_easy *data, + struct tftp_conn *state) +{ + CURLcode result = CURLE_OK; + struct Curl_sockaddr_storage remote_addr; + curl_socklen_t fromlen = sizeof(remote_addr); + + /* Receive the packet */ + state->rbytes = (int)recvfrom(state->sockfd, + (void *)state->rpacket.data, + (RECV_TYPE_ARG3)state->blksize + 4, + 0, + (struct sockaddr *)&remote_addr, + &fromlen); + if((state->rbytes >= 0) && fromlen) { + if(state->remote_pinned) { + /* pinned, verify that it comes from the same address */ + if((state->remote_addrlen != fromlen) || + memcmp(&remote_addr, &state->remote_addr, fromlen)) { + failf(data, "Data received from another address"); + return CURLE_RECV_ERROR; + } + } + else { + /* pin address on first use */ + state->remote_pinned = TRUE; + state->remote_addrlen = fromlen; + memcpy(&state->remote_addr, &remote_addr, fromlen); + } + } + + /* Sanity check packet length */ + if(state->rbytes < 4) { + failf(data, "Received too short packet"); + /* Not a timeout, but how best to handle it? */ + state->event = TFTP_EVENT_TIMEOUT; + } + else { + /* The event is given by the TFTP packet time */ + unsigned short event = getrpacketevent(&state->rpacket); + state->event = (tftp_event_t)event; + + switch(state->event) { + case TFTP_EVENT_DATA: + /* Do not pass to the client empty or retransmitted packets */ + if(state->rbytes > 4 && + (NEXT_BLOCKNUM(state->block) == getrpacketblock(&state->rpacket))) { + result = Curl_client_write(data, CLIENTWRITE_BODY, + (const char *)state->rpacket.data + 4, + state->rbytes - 4); + if(result) { + tftp_state_machine(state, TFTP_EVENT_ERROR); + return result; + } + } + break; + case TFTP_EVENT_ERROR: { + unsigned short error = getrpacketblock(&state->rpacket); + const char *str = (const char *)state->rpacket.data + 4; + size_t strn = state->rbytes - 4; + state->error = (tftp_error_t)error; + if(tftp_strnlen(str, strn) < strn) + infof(data, "TFTP error: %s", str); + break; + } + case TFTP_EVENT_ACK: + break; + case TFTP_EVENT_OACK: + result = tftp_parse_option_ack(state, + (const char *)state->rpacket.data + 2, + state->rbytes-2); + if(result) + return result; + break; + case TFTP_EVENT_RRQ: + case TFTP_EVENT_WRQ: + default: + failf(data, "%s", "Internal error: Unexpected packet"); + break; + } + + /* Update the progress meter */ + result = Curl_pgrsUpdate(data); + if(result) { + tftp_state_machine(state, TFTP_EVENT_ERROR); + return result; + } + } + return result; +} + +/********************************************************** + * + * tftp_state_timeout + * + * Check if timeouts have been reached + * + **********************************************************/ +static timediff_t tftp_state_timeout(struct tftp_conn *state, + tftp_event_t *event) +{ + time_t current; + timediff_t timeout_ms; + + if(event) + *event = TFTP_EVENT_NONE; + + timeout_ms = Curl_timeleft_ms(state->data); + if(timeout_ms < 0) { + state->error = TFTP_ERR_TIMEOUT; + state->state = TFTP_STATE_FIN; + return timeout_ms; + } + current = time(NULL); + if(current > state->rx_time + state->retry_time) { + if(event) + *event = TFTP_EVENT_TIMEOUT; + state->rx_time = time(NULL); /* update even though we received nothing */ + } + + return timeout_ms; +} + +/********************************************************** + * + * tftp_multi_statemach + * + * Handle single RX socket event and return + * + **********************************************************/ +static CURLcode tftp_multi_statemach(struct Curl_easy *data, bool *done) +{ + tftp_event_t event; + CURLcode result = CURLE_OK; + struct connectdata *conn = data->conn; + struct tftp_conn *state = Curl_conn_meta_get(conn, CURL_META_TFTP_CONN); + timediff_t timeout_ms; + + *done = FALSE; + if(!state) + return CURLE_FAILED_INIT; + + timeout_ms = tftp_state_timeout(state, &event); + if(timeout_ms < 0) { + failf(data, "TFTP response timeout"); + return CURLE_OPERATION_TIMEDOUT; + } + if(event != TFTP_EVENT_NONE) { + result = tftp_state_machine(state, event); + if(result) + return result; + *done = (state->state == TFTP_STATE_FIN); + if(*done) + /* Tell curl we are done */ + Curl_xfer_setup_nop(data); + } + else { + /* no timeouts to handle, check our socket */ + int rc = SOCKET_READABLE(state->sockfd, 0); + + if(rc == -1) { + /* bail out */ + int sockerr = SOCKERRNO; + char buffer[STRERROR_LEN]; + failf(data, "%s", curlx_strerror(sockerr, buffer, sizeof(buffer))); + state->event = TFTP_EVENT_ERROR; + } + else if(rc) { + result = tftp_receive_packet(data, state); + if(result) + return result; + result = tftp_state_machine(state, state->event); + if(result) + return result; + *done = (state->state == TFTP_STATE_FIN); + if(*done) + /* Tell curl we are done */ + Curl_xfer_setup_nop(data); + } + /* if rc == 0, then select() timed out */ + } + + return result; +} + +/********************************************************** + * + * tftp_doing + * + * Called from multi.c while DOing + * + **********************************************************/ +static CURLcode tftp_doing(struct Curl_easy *data, bool *dophase_done) +{ + CURLcode result; + result = tftp_multi_statemach(data, dophase_done); + + if(*dophase_done) { + DEBUGF(infof(data, "DO phase is complete")); + } + else if(!result) { + /* The multi code does not have this logic for the DOING state so we + provide it for TFTP since it may do the entire transfer in this + state. */ + result = Curl_pgrsCheck(data); + } + return result; +} + +/********************************************************** + * + * tftp_perform + * + * Entry point for transfer from tftp_do, starts state mach + * + **********************************************************/ +static CURLcode tftp_perform(struct Curl_easy *data, bool *dophase_done) +{ + CURLcode result = CURLE_OK; + struct connectdata *conn = data->conn; + struct tftp_conn *state = Curl_conn_meta_get(conn, CURL_META_TFTP_CONN); + + *dophase_done = FALSE; + if(!state) + return CURLE_FAILED_INIT; + + result = tftp_state_machine(state, TFTP_EVENT_INIT); + + if((state->state == TFTP_STATE_FIN) || result) + return result; + + result = tftp_multi_statemach(data, dophase_done); + + if(*dophase_done) + DEBUGF(infof(data, "DO phase is complete")); + + return result; +} + +/********************************************************** + * + * tftp_do + * + * The do callback + * + * This callback initiates the TFTP transfer + * + **********************************************************/ + +static CURLcode tftp_do(struct Curl_easy *data, bool *done) +{ + struct connectdata *conn = data->conn; + struct tftp_conn *state = Curl_conn_meta_get(conn, CURL_META_TFTP_CONN); + CURLcode result; + + *done = FALSE; + + if(!state) { + result = tftp_connect(data, done); + if(result) + return result; + + state = Curl_conn_meta_get(conn, CURL_META_TFTP_CONN); + if(!state) + return CURLE_TFTP_ILLEGAL; + } + + result = tftp_perform(data, done); + + /* If tftp_perform() returned an error, use that for return code. If it + was OK, see if tftp_translate_code() has an error. */ + if(!result) + /* If we have encountered an internal tftp error, translate it. */ + result = tftp_translate_code(state->error); + + return result; +} + +static CURLcode tftp_setup_connection(struct Curl_easy *data, + struct connectdata *conn) +{ + char *path = data->state.up.path; + size_t len = strlen(path); + + conn->transport_wanted = TRNSPRT_UDP; + + /* TFTP URLs support a trailing ";mode=netascii" or ";mode=octet" */ + if((len >= 14) && !memcmp(&path[len - 14], ";mode=netascii", 14)) { + data->state.prefer_ascii = TRUE; + path[len - 14] = 0; /* cut it there */ + } + else if((len >= 11) && !memcmp(&path[len - 11], ";mode=octet", 11)) { + data->state.prefer_ascii = FALSE; + path[len - 11] = 0; /* cut it there */ + } + + return CURLE_OK; +} + +/* + * TFTP protocol handler. + */ +const struct Curl_protocol Curl_protocol_tftp = { + tftp_setup_connection, /* setup_connection */ + tftp_do, /* do_it */ + tftp_done, /* done */ + ZERO_NULL, /* do_more */ + tftp_connect, /* connect_it */ + tftp_multi_statemach, /* connecting */ + tftp_doing, /* doing */ + tftp_pollset, /* proto_pollset */ + tftp_pollset, /* doing_pollset */ + ZERO_NULL, /* domore_pollset */ + ZERO_NULL, /* perform_pollset */ + ZERO_NULL, /* disconnect */ + ZERO_NULL, /* write_resp */ + ZERO_NULL, /* write_resp_hd */ + ZERO_NULL, /* connection_is_dead */ + ZERO_NULL, /* attach connection */ + ZERO_NULL, /* follow */ +}; + +#endif diff --git a/3rdparty/curl-8.21.0/lib/tftp.h b/3rdparty/curl-8.21.0/lib/tftp.h new file mode 100644 index 0000000000..32310103b0 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/tftp.h @@ -0,0 +1,33 @@ +#ifndef HEADER_CURL_TFTP_H +#define HEADER_CURL_TFTP_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#ifndef CURL_DISABLE_TFTP +extern const struct Curl_protocol Curl_protocol_tftp; +#endif + +#define TFTP_BLKSIZE_MIN 8 +#define TFTP_BLKSIZE_MAX 65464 + +#endif /* HEADER_CURL_TFTP_H */ diff --git a/3rdparty/curl-8.21.0/lib/thrdpool.c b/3rdparty/curl-8.21.0/lib/thrdpool.c new file mode 100644 index 0000000000..e8c7d36435 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/thrdpool.c @@ -0,0 +1,481 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_THREADS + +#include "llist.h" +#include "curl_threads.h" +#include "curlx/timeval.h" +#include "thrdpool.h" +#ifdef CURLVERBOSE +#include "curl_trc.h" +#include "urldata.h" +#endif + + +struct thrdslot { + struct Curl_llist_node node; + struct curl_thrdpool *tpool; + curl_thread_t thread; + curl_cond_t await; + struct curltime starttime; + const char *work_description; + timediff_t work_timeout_ms; + uint32_t id; + BIT(running); + BIT(idle); +}; + +struct curl_thrdpool { + char *name; + uint64_t refcount; + curl_mutex_t lock; + curl_cond_t await; + struct Curl_llist slots; + struct Curl_llist zombies; + Curl_thrdpool_take_item_cb *fn_take; + Curl_thrdpool_process_item_cb *fn_process; + Curl_thrdpool_return_item_cb *fn_return; + void *fn_user_data; + CURLcode fatal_err; + uint32_t min_threads; + uint32_t max_threads; + uint32_t idle_time_ms; + uint32_t next_id; + BIT(aborted); + BIT(detached); +}; + +static void thrdpool_join_zombies(struct curl_thrdpool *tpool); +static bool thrdpool_unlink(struct curl_thrdpool *tpool, bool locked); + +static void thrdslot_destroy(struct thrdslot *tslot) +{ + DEBUGASSERT(tslot->thread == curl_thread_t_null); + DEBUGASSERT(!tslot->running); + Curl_cond_destroy(&tslot->await); + curlx_free(tslot); +} + +static void thrdslot_done(struct thrdslot *tslot) +{ + struct curl_thrdpool *tpool = tslot->tpool; + + DEBUGASSERT(Curl_node_llist(&tslot->node) == &tpool->slots); + Curl_node_remove(&tslot->node); + tslot->running = FALSE; + Curl_llist_append(&tpool->zombies, tslot, &tslot->node); + Curl_cond_signal(&tpool->await); +} + +static CURL_THREAD_RETURN_T CURL_STDCALL thrdslot_run(void *arg) +{ + struct thrdslot *tslot = arg; + struct curl_thrdpool *tpool = tslot->tpool; + void *item; + + Curl_mutex_acquire(&tpool->lock); + DEBUGASSERT(Curl_node_llist(&tslot->node) == &tpool->slots); + for(;;) { + while(!tpool->aborted) { + tslot->work_description = NULL; + tslot->work_timeout_ms = 0; + item = tpool->fn_take(tpool->fn_user_data, &tslot->work_description, + &tslot->work_timeout_ms); + if(!item) + break; + tslot->starttime = curlx_now(); + tslot->idle = FALSE; + Curl_mutex_release(&tpool->lock); + + tpool->fn_process(item); + + Curl_mutex_acquire(&tpool->lock); + tslot->work_description = NULL; + tpool->fn_return(item, tpool->aborted ? NULL : tpool->fn_user_data); + } + + if(tpool->aborted || + (Curl_llist_count(&tpool->slots) > tpool->max_threads)) + goto out; + + tslot->idle = TRUE; + tslot->starttime = curlx_now(); + thrdpool_join_zombies(tpool); + Curl_cond_signal(&tpool->await); + /* Only wait with idle timeout when we are above the minimum + * number of threads. Otherwise short idle timeouts will keep + * on activating threads that have no means to shut down. */ + if((tpool->idle_time_ms > 0) && + (Curl_llist_count(&tpool->slots) > tpool->min_threads)) { + CURLcode result = Curl_cond_timedwait(&tslot->await, &tpool->lock, + tpool->idle_time_ms); + if((result == CURLE_OPERATION_TIMEDOUT) && + (Curl_llist_count(&tpool->slots) > tpool->min_threads)) { + goto out; + } + } + else { + Curl_cond_wait(&tslot->await, &tpool->lock); + } + } + +out: + thrdslot_done(tslot); + if(!thrdpool_unlink(tslot->tpool, TRUE)) { + /* tpool not destroyed */ + Curl_mutex_release(&tpool->lock); + } + return 0; +} + +static CURLcode thrdslot_start(struct curl_thrdpool *tpool) +{ + struct thrdslot *tslot; + CURLcode result = CURLE_OUT_OF_MEMORY; + + tslot = curlx_calloc(1, sizeof(*tslot)); + if(!tslot) + goto out; + tslot->id = tpool->next_id++; + tslot->tpool = tpool; + tslot->thread = curl_thread_t_null; + Curl_cond_init(&tslot->await); + + tpool->refcount++; + tslot->running = TRUE; + tslot->thread = Curl_thread_create(thrdslot_run, tslot); + if(tslot->thread == curl_thread_t_null) { /* never started */ + tslot->running = FALSE; + thrdpool_unlink(tpool, TRUE); + result = CURLE_FAILED_INIT; + goto out; + } + + Curl_llist_append(&tpool->slots, tslot, &tslot->node); + tslot = NULL; + result = CURLE_OK; + +out: + if(tslot) + thrdslot_destroy(tslot); + return result; +} + +static void thrdpool_wake_all(struct curl_thrdpool *tpool) +{ + struct Curl_llist_node *e; + for(e = Curl_llist_head(&tpool->slots); e; e = Curl_node_next(e)) { + struct thrdslot *tslot = Curl_node_elem(e); + Curl_cond_signal(&tslot->await); + } +} + +static void thrdpool_join_zombies(struct curl_thrdpool *tpool) +{ + struct Curl_llist_node *e; + + for(e = Curl_llist_head(&tpool->zombies); e; + e = Curl_llist_head(&tpool->zombies)) { + struct thrdslot *tslot = Curl_node_elem(e); + + Curl_node_remove(&tslot->node); + if(tslot->thread != curl_thread_t_null) { + Curl_mutex_release(&tpool->lock); + Curl_thread_join(&tslot->thread); + Curl_mutex_acquire(&tpool->lock); + tslot->thread = curl_thread_t_null; + } + thrdslot_destroy(tslot); + } +} + +static bool thrdpool_unlink(struct curl_thrdpool *tpool, bool locked) +{ + DEBUGASSERT(tpool->refcount); + if(tpool->refcount) + tpool->refcount--; + if(tpool->refcount) + return FALSE; + + /* no more references, free */ + DEBUGASSERT(tpool->aborted); + thrdpool_join_zombies(tpool); + if(locked) + Curl_mutex_release(&tpool->lock); + curlx_free(tpool->name); + Curl_cond_destroy(&tpool->await); + Curl_mutex_destroy(&tpool->lock); + curlx_free(tpool); + return TRUE; +} + +static CURLcode thrdpool_signal(struct curl_thrdpool *tpool, + uint32_t nthreads) +{ + struct Curl_llist_node *e, *n; + CURLcode result = CURLE_OK; + + DEBUGASSERT(!tpool->aborted); + thrdpool_join_zombies(tpool); + + for(e = Curl_llist_head(&tpool->slots); e && nthreads; e = n) { + struct thrdslot *tslot = Curl_node_elem(e); + n = Curl_node_next(e); + if(tslot->idle) { + Curl_cond_signal(&tslot->await); + --nthreads; + } + else if(!tslot->starttime.tv_sec && !tslot->starttime.tv_usec) { + /* starting thread, queries for work soon. */ + --nthreads; + } + } + + while(nthreads && !result && + Curl_llist_count(&tpool->slots) < tpool->max_threads) { + result = thrdslot_start(tpool); + if(result) + break; + --nthreads; + } + + return result; +} + +CURLcode Curl_thrdpool_set_props(struct curl_thrdpool *tpool, + uint32_t min_threads, + uint32_t max_threads, + uint32_t idle_time_ms) +{ + CURLcode result = CURLE_OK; + size_t running; + + if(!max_threads || (min_threads > max_threads)) + return CURLE_BAD_FUNCTION_ARGUMENT; + + Curl_mutex_acquire(&tpool->lock); + tpool->min_threads = min_threads; + tpool->max_threads = max_threads; + tpool->idle_time_ms = idle_time_ms; + running = Curl_llist_count(&tpool->slots); + if(tpool->min_threads > running) { + result = thrdpool_signal(tpool, tpool->min_threads - (uint32_t)running); + } + Curl_mutex_release(&tpool->lock); + + return result; +} + +CURLcode Curl_thrdpool_create(struct curl_thrdpool **ptpool, + const char *name, + uint32_t min_threads, + uint32_t max_threads, + uint32_t idle_time_ms, + Curl_thrdpool_take_item_cb *fn_take, + Curl_thrdpool_process_item_cb *fn_process, + Curl_thrdpool_return_item_cb *fn_return, + void *user_data) +{ + struct curl_thrdpool *tpool; + CURLcode result = CURLE_OUT_OF_MEMORY; + + tpool = curlx_calloc(1, sizeof(*tpool)); + if(!tpool) + goto out; + tpool->refcount = 1; + + Curl_mutex_init(&tpool->lock); + Curl_cond_init(&tpool->await); + Curl_llist_init(&tpool->slots, NULL); + Curl_llist_init(&tpool->zombies, NULL); + tpool->fn_take = fn_take; + tpool->fn_process = fn_process; + tpool->fn_return = fn_return; + tpool->fn_user_data = user_data; + + tpool->name = curlx_strdup(name); + if(!tpool->name) + goto out; + + result = Curl_thrdpool_set_props(tpool, min_threads, max_threads, + idle_time_ms); + +out: + if(result && tpool) { + tpool->aborted = TRUE; + thrdpool_unlink(tpool, FALSE); + tpool = NULL; + } + *ptpool = tpool; + return result; +} + +void Curl_thrdpool_destroy(struct curl_thrdpool *tpool, bool join) +{ + Curl_mutex_acquire(&tpool->lock); + + tpool->aborted = TRUE; + + while(join && Curl_llist_count(&tpool->slots)) { + thrdpool_wake_all(tpool); + Curl_cond_wait(&tpool->await, &tpool->lock); + } + + thrdpool_join_zombies(tpool); + + /* detach all still running threads */ + if(Curl_llist_count(&tpool->slots)) { + struct Curl_llist_node *e; + for(e = Curl_llist_head(&tpool->slots); e; e = Curl_node_next(e)) { + struct thrdslot *tslot = Curl_node_elem(e); + if(tslot->thread != curl_thread_t_null) + Curl_thread_destroy(&tslot->thread); + } + tpool->detached = TRUE; + } + + if(!thrdpool_unlink(tpool, TRUE)) { + /* tpool not destroyed */ + Curl_mutex_release(&tpool->lock); + } +} + +CURLcode Curl_thrdpool_signal(struct curl_thrdpool *tpool, uint32_t nthreads) +{ + CURLcode result; + + Curl_mutex_acquire(&tpool->lock); + result = thrdpool_signal(tpool, nthreads); + Curl_mutex_release(&tpool->lock); + return result; +} + +static bool thrdpool_all_idle(struct curl_thrdpool *tpool) +{ + struct Curl_llist_node *e; + for(e = Curl_llist_head(&tpool->slots); e; e = Curl_node_next(e)) { + struct thrdslot *tslot = Curl_node_elem(e); + if(!tslot->idle) + return FALSE; + } + return TRUE; +} + +CURLcode Curl_thrdpool_await_idle(struct curl_thrdpool *tpool, + uint32_t timeout_ms) +{ + CURLcode result = CURLE_OK; + struct curltime end = { 0 }; + + Curl_mutex_acquire(&tpool->lock); + DEBUGASSERT(!tpool->aborted); + if(tpool->aborted) { + result = CURLE_FAILED_INIT; + goto out; + } + + while(!thrdpool_all_idle(tpool)) { + if(timeout_ms) { + timediff_t remain_ms; + CURLcode r; + + if(!end.tv_sec && !end.tv_usec) { + end = curlx_now(); + end.tv_sec += (time_t)(timeout_ms / 1000); + end.tv_usec += (int)(timeout_ms % 1000) * 1000; + if(end.tv_usec >= 1000000) { + end.tv_sec++; + end.tv_usec -= 1000000; + } + } + remain_ms = curlx_timediff_ms(curlx_now(), end); + if(remain_ms <= 0) + r = CURLE_OPERATION_TIMEDOUT; + else + r = Curl_cond_timedwait(&tpool->await, &tpool->lock, + (uint32_t)remain_ms); + if(r == CURLE_OPERATION_TIMEDOUT) { + result = r; + break; + } + } + else { + Curl_cond_wait(&tpool->await, &tpool->lock); + } + } + +out: + thrdpool_join_zombies(tpool); + Curl_mutex_release(&tpool->lock); + return result; +} + +#ifdef CURLVERBOSE +void Curl_thrdpool_trace(struct curl_thrdpool *tpool, + struct Curl_easy *data) +{ + struct curl_trc_feat *feat = &Curl_trc_feat_threads; + if(Curl_trc_ft_is_verbose(data, feat)) { + struct Curl_llist_node *e; + struct curltime now = curlx_now(); + + Curl_mutex_acquire(&tpool->lock); + if(!Curl_llist_count(&tpool->slots)) { + Curl_trc_feat_infof(data, feat, "[TPOOL-%s] no threads running", + tpool->name); + } + for(e = Curl_llist_head(&tpool->slots); e; e = Curl_node_next(e)) { + struct thrdslot *tslot = Curl_node_elem(e); + timediff_t elapsed_ms = curlx_ptimediff_ms(&now, &tslot->starttime); + if(!tslot->running) { + Curl_trc_feat_infof(data, feat, "[TPOOL-%s] [%u]: not running", + tpool->name, tslot->id); + } + else if(!tslot->starttime.tv_sec && !tslot->starttime.tv_usec) { + Curl_trc_feat_infof(data, feat, "[TPOOL-%s] [%u]: starting...", + tpool->name, tslot->id); + } + else if(tslot->idle) { + Curl_trc_feat_infof(data, feat, "[TPOOL-%s] [%u]: idle for %" + FMT_TIMEDIFF_T "ms", + tpool->name, tslot->id, elapsed_ms); + } + else { + timediff_t remain_ms = tslot->work_timeout_ms ? + (tslot->work_timeout_ms - elapsed_ms) : 0; + Curl_trc_feat_infof(data, feat, "[TPOOL-%s] [%u]: busy %" + FMT_TIMEDIFF_T "ms, timeout in %" FMT_TIMEDIFF_T + "ms: %s", + tpool->name, tslot->id, elapsed_ms, remain_ms, + tslot->work_description); + } + } + Curl_mutex_release(&tpool->lock); + } +} +#endif + +#endif /* USE_THREADS */ diff --git a/3rdparty/curl-8.21.0/lib/thrdpool.h b/3rdparty/curl-8.21.0/lib/thrdpool.h new file mode 100644 index 0000000000..cc81fb6fcb --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/thrdpool.h @@ -0,0 +1,106 @@ +#ifndef HEADER_CURL_THRDPOOL_H +#define HEADER_CURL_THRDPOOL_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" +#include "curlx/timediff.h" + +#ifdef USE_THREADS + +struct curl_thrdpool; +struct Curl_easy; + +/* Invoked under thread pool lock to get an "item" to work on. Must + * return NULL if there is nothing to do. + * Caller might return a descriptive string about the "item", where + * available. The string needs to have the same lifetime as the + * item itself. */ +typedef void *Curl_thrdpool_take_item_cb(void *user_data, + const char **pdescription, + timediff_t *ptimeout_ms); + +/* Invoked outside thread pool lock to process the item taken. */ +typedef void Curl_thrdpool_process_item_cb(void *item); + +/* Invoked under thread pool lock to return a processed item back + * to the producer. + * If the thread pool has been destroyed, `user_data` will be NULL + * and the callback is responsible to release all `item` resources. */ +typedef void Curl_thrdpool_return_item_cb(void *item, void *user_data); + +/* Create a new thread pool. + * @param name name of pool for tracing purposes + * @param min_threads minimum number of threads to have always running + * @param max_threads maximum number of threads running, ever. + * @param idle_time_ms maximum time a thread should wait for tasks to + * process before shutting down (unless the pool is + * already at minimum thread count), use 0 for + * infinite wait. + * @param fn_take take the next item to process + * @param fn_process process the item taken + * @param fn_return return the processed item + * @param user_data parameter passed to take/return callbacks + */ +CURLcode Curl_thrdpool_create(struct curl_thrdpool **ptpool, + const char *name, + uint32_t min_threads, + uint32_t max_threads, + uint32_t idle_time_ms, + Curl_thrdpool_take_item_cb *fn_take, + Curl_thrdpool_process_item_cb *fn_process, + Curl_thrdpool_return_item_cb *fn_return, + void *user_data); + +/* Destroy the thread pool, release its resources. + * With `join` being TRUE, the call will wait for all threads to finish + * processing before returning. On FALSE, it will detach all threads + * running. Ongoing item processing will continue to run and + * `fn_return` will be invoked with NULL user_data before the thread exits. + */ +void Curl_thrdpool_destroy(struct curl_thrdpool *tpool, bool join); + +/* Signal the pool to wake up `nthreads` idle worker threads, possible + * creating new threads up to the max limit. The number should reflect + * the items that can actually be taken for processing right away, e.g. + * the producers "queue" length of outstanding items. + */ +CURLcode Curl_thrdpool_signal(struct curl_thrdpool *tpool, uint32_t nthreads); + +CURLcode Curl_thrdpool_await_idle(struct curl_thrdpool *tpool, + uint32_t timeout_ms); + +/* Change the properties of a threadpool. */ +CURLcode Curl_thrdpool_set_props(struct curl_thrdpool *tpool, + uint32_t min_threads, + uint32_t max_threads, + uint32_t idle_time_ms); + +#ifdef CURLVERBOSE +void Curl_thrdpool_trace(struct curl_thrdpool *tpool, + struct Curl_easy *data); +#endif + +#endif /* USE_THREADS */ + +#endif /* HEADER_CURL_THRDPOOL_H */ diff --git a/3rdparty/curl-8.21.0/lib/thrdqueue.c b/3rdparty/curl-8.21.0/lib/thrdqueue.c new file mode 100644 index 0000000000..f68f8e1797 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/thrdqueue.c @@ -0,0 +1,416 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_THREADS + +#include "llist.h" +#include "curl_threads.h" +#include "thrdpool.h" +#include "thrdqueue.h" +#include "curlx/timeval.h" +#ifdef CURLVERBOSE +#include "curl_trc.h" +#include "urldata.h" +#endif + + +struct curl_thrdq { + char *name; + curl_mutex_t lock; + curl_cond_t await; + struct Curl_llist sendq; + struct Curl_llist recvq; + struct curl_thrdpool *tpool; + Curl_thrdq_item_free_cb *fn_free; + Curl_thrdq_item_process_cb *fn_process; + Curl_thrdq_ev_cb *fn_event; + void *fn_user_data; + uint32_t send_max_len; + BIT(aborted); +}; + +struct thrdq_item { + struct Curl_llist_node node; + Curl_thrdq_item_free_cb *fn_free; + Curl_thrdq_item_process_cb *fn_process; + void *item; + struct curltime start; + timediff_t timeout_ms; + const char *description; +}; + +static struct thrdq_item *thrdq_item_create(struct curl_thrdq *tqueue, + void *item, + const char *description, + timediff_t timeout_ms) +{ + struct thrdq_item *qitem; + + qitem = curlx_calloc(1, sizeof(*qitem)); + if(!qitem) + return NULL; + qitem->item = item; + qitem->description = description; + qitem->fn_free = tqueue->fn_free; + qitem->fn_process = tqueue->fn_process; + if(timeout_ms) { + qitem->start = curlx_now(); + qitem->timeout_ms = timeout_ms; + } + return qitem; +} + +static void thrdq_item_destroy(struct thrdq_item *qitem) +{ + if(qitem->item) + qitem->fn_free(qitem->item); + curlx_free(qitem); +} + +static void thrdq_item_list_dtor(void *user_data, void *elem) +{ + (void)user_data; + thrdq_item_destroy(elem); +} + +static void *thrdq_tpool_take(void *user_data, const char **pdescription, + timediff_t *ptimeout_ms) +{ + struct curl_thrdq *tqueue = user_data; + struct thrdq_item *qitem = NULL; + struct Curl_llist_node *e; + Curl_thrdq_ev_cb *fn_event = NULL; + void *fn_user_data = NULL; + + Curl_mutex_acquire(&tqueue->lock); + *pdescription = NULL; + *ptimeout_ms = 0; + if(!tqueue->aborted) { + e = Curl_llist_head(&tqueue->sendq); + if(e) { + struct curltime now = curlx_now(); + timediff_t timeout_ms; + while(e) { + qitem = Curl_node_take_elem(e); + timeout_ms = (!qitem->timeout_ms) ? 0 : + (qitem->timeout_ms - curlx_ptimediff_ms(&now, &qitem->start)); + if(timeout_ms < 0) { + /* timed out while queued, place on receive queue */ + Curl_llist_append(&tqueue->recvq, qitem, &qitem->node); + fn_event = tqueue->fn_event; + fn_user_data = tqueue->fn_user_data; + qitem = NULL; + e = Curl_llist_head(&tqueue->sendq); + continue; + } + else { + *pdescription = qitem->description; + *ptimeout_ms = timeout_ms; + break; + } + } + } + } + Curl_mutex_release(&tqueue->lock); + /* avoiding deadlocks */ + if(fn_event) + fn_event(tqueue, CURL_THRDQ_EV_ITEM_DONE, fn_user_data); + return qitem; +} + +static void thrdq_tpool_return(void *item, void *user_data) +{ + struct curl_thrdq *tqueue = user_data; + struct thrdq_item *qitem = item; + Curl_thrdq_ev_cb *fn_event = NULL; + void *fn_user_data = NULL; + + if(!tqueue) { + thrdq_item_destroy(item); + return; + } + + Curl_mutex_acquire(&tqueue->lock); + if(tqueue->aborted) { + thrdq_item_destroy(qitem); + } + else { + DEBUGASSERT(!Curl_node_llist(&qitem->node)); + Curl_llist_append(&tqueue->recvq, qitem, &qitem->node); + fn_event = tqueue->fn_event; + fn_user_data = tqueue->fn_user_data; + } + Curl_mutex_release(&tqueue->lock); + /* avoiding deadlocks */ + if(fn_event) + fn_event(tqueue, CURL_THRDQ_EV_ITEM_DONE, fn_user_data); +} + +static void thrdq_tpool_process(void *item) +{ + struct thrdq_item *qitem = item; + qitem->fn_process(qitem->item); +} + +static void thrdq_unlink(struct curl_thrdq *tqueue, bool locked, bool join) +{ + DEBUGASSERT(tqueue->aborted); + if(tqueue->tpool) { + if(locked) + Curl_mutex_release(&tqueue->lock); + Curl_thrdpool_destroy(tqueue->tpool, join); + tqueue->tpool = NULL; + if(locked) + Curl_mutex_acquire(&tqueue->lock); + } + + Curl_llist_destroy(&tqueue->sendq, NULL); + Curl_llist_destroy(&tqueue->recvq, NULL); + curlx_free(tqueue->name); + Curl_cond_destroy(&tqueue->await); + if(locked) + Curl_mutex_release(&tqueue->lock); + Curl_mutex_destroy(&tqueue->lock); + curlx_free(tqueue); +} + +CURLcode Curl_thrdq_create(struct curl_thrdq **ptqueue, + const char *name, + uint32_t max_len, + uint32_t min_threads, + uint32_t max_threads, + uint32_t idle_time_ms, + Curl_thrdq_item_free_cb *fn_free, + Curl_thrdq_item_process_cb *fn_process, + Curl_thrdq_ev_cb *fn_event, + void *user_data) +{ + struct curl_thrdq *tqueue; + CURLcode result = CURLE_OUT_OF_MEMORY; + + tqueue = curlx_calloc(1, sizeof(*tqueue)); + if(!tqueue) + goto out; + + Curl_mutex_init(&tqueue->lock); + Curl_cond_init(&tqueue->await); + Curl_llist_init(&tqueue->sendq, thrdq_item_list_dtor); + Curl_llist_init(&tqueue->recvq, thrdq_item_list_dtor); + tqueue->fn_free = fn_free; + tqueue->fn_process = fn_process; + tqueue->fn_event = fn_event; + tqueue->fn_user_data = user_data; + tqueue->send_max_len = max_len; + + tqueue->name = curlx_strdup(name); + if(!tqueue->name) + goto out; + + result = Curl_thrdpool_create(&tqueue->tpool, name, + min_threads, max_threads, idle_time_ms, + thrdq_tpool_take, + thrdq_tpool_process, + thrdq_tpool_return, + tqueue); + +out: + if(result && tqueue) { + tqueue->aborted = TRUE; + thrdq_unlink(tqueue, FALSE, TRUE); + tqueue = NULL; + } + *ptqueue = tqueue; + return result; +} + +void Curl_thrdq_destroy(struct curl_thrdq *tqueue, bool join) +{ + Curl_mutex_acquire(&tqueue->lock); + DEBUGASSERT(!tqueue->aborted); + tqueue->aborted = TRUE; + thrdq_unlink(tqueue, TRUE, join); +} + +CURLcode Curl_thrdq_send(struct curl_thrdq *tqueue, void *item, + const char *description, timediff_t timeout_ms) +{ + CURLcode result = CURLE_AGAIN; + size_t signals = 0; + + Curl_mutex_acquire(&tqueue->lock); + if(tqueue->aborted) { + DEBUGASSERT(0); + result = CURLE_SEND_ERROR; + goto out; + } + if(timeout_ms < 0) { + result = CURLE_OPERATION_TIMEDOUT; + goto out; + } + + if(!tqueue->send_max_len || + (Curl_llist_count(&tqueue->sendq) < tqueue->send_max_len)) { + struct thrdq_item *qitem = thrdq_item_create(tqueue, item, description, + timeout_ms); + if(!qitem) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + item = NULL; + Curl_llist_append(&tqueue->sendq, qitem, &qitem->node); + signals = Curl_llist_count(&tqueue->sendq); + result = CURLE_OK; + } + +out: + Curl_mutex_release(&tqueue->lock); + /* Signal thread pool unlocked to avoid deadlocks. Since we added + * item to the queue already, it might have been taken for processing + * already. Any error in signalling the pool cannot be reported to + * the caller since it needs to give up ownership of item. */ + if(!result && signals) + (void)Curl_thrdpool_signal(tqueue->tpool, (uint32_t)signals); + return result; +} + +CURLcode Curl_thrdq_recv(struct curl_thrdq *tqueue, void **pitem) +{ + CURLcode result = CURLE_AGAIN; + struct Curl_llist_node *e; + + *pitem = NULL; + Curl_mutex_acquire(&tqueue->lock); + if(tqueue->aborted) { + DEBUGASSERT(0); + result = CURLE_RECV_ERROR; + goto out; + } + + e = Curl_llist_head(&tqueue->recvq); + if(e) { + struct thrdq_item *qitem = Curl_node_take_elem(e); + *pitem = qitem->item; + qitem->item = NULL; + thrdq_item_destroy(qitem); + result = CURLE_OK; + } +out: + Curl_mutex_release(&tqueue->lock); + return result; +} + +static void thrdq_llist_clean_matches(struct Curl_llist *llist, + Curl_thrdq_item_match_cb *fn_match, + void *match_data) +{ + struct Curl_llist_node *e, *n; + struct thrdq_item *qitem; + + for(e = Curl_llist_head(llist); e; e = n) { + n = Curl_node_next(e); + qitem = Curl_node_elem(e); + if(fn_match(qitem->item, match_data)) + Curl_node_remove(e); + } +} + +void Curl_thrdq_clear(struct curl_thrdq *tqueue, + Curl_thrdq_item_match_cb *fn_match, + void *match_data) +{ + Curl_mutex_acquire(&tqueue->lock); + if(tqueue->aborted) { + DEBUGASSERT(0); + goto out; + } + thrdq_llist_clean_matches(&tqueue->sendq, fn_match, match_data); + thrdq_llist_clean_matches(&tqueue->recvq, fn_match, match_data); +out: + Curl_mutex_release(&tqueue->lock); +} + +#ifdef UNITTESTS +/* @unittest 3301 */ +UNITTEST CURLcode thrdq_await_done(struct curl_thrdq *tqueue, + uint32_t timeout_ms); +UNITTEST CURLcode thrdq_await_done(struct curl_thrdq *tqueue, + uint32_t timeout_ms) +{ + return Curl_thrdpool_await_idle(tqueue->tpool, timeout_ms); +} +#endif + +CURLcode Curl_thrdq_set_props(struct curl_thrdq *tqueue, + uint32_t max_len, + uint32_t min_threads, + uint32_t max_threads, + uint32_t idle_time_ms) +{ + CURLcode result; + size_t signals; + + Curl_mutex_acquire(&tqueue->lock); + tqueue->send_max_len = max_len; + signals = Curl_llist_count(&tqueue->sendq); + Curl_mutex_release(&tqueue->lock); + + result = Curl_thrdpool_set_props(tqueue->tpool, min_threads, + max_threads, idle_time_ms); + if(!result && signals) + result = Curl_thrdpool_signal(tqueue->tpool, (uint32_t)signals); + return result; +} + +#ifdef CURLVERBOSE +void Curl_thrdq_trace(struct curl_thrdq *tqueue, + struct Curl_easy *data) +{ + struct curl_trc_feat *feat = &Curl_trc_feat_threads; + if(Curl_trc_ft_is_verbose(data, feat)) { + struct Curl_llist_node *e; + struct thrdq_item *qitem; + + Curl_thrdpool_trace(tqueue->tpool, data); + Curl_mutex_acquire(&tqueue->lock); + if(!Curl_llist_count(&tqueue->sendq) && + !Curl_llist_count(&tqueue->recvq)) { + Curl_trc_feat_infof(data, feat, "[TQUEUE-%s] empty", tqueue->name); + } + for(e = Curl_llist_head(&tqueue->sendq); e; e = Curl_node_next(e)) { + qitem = Curl_node_elem(e); + Curl_trc_feat_infof(data, feat, "[TQUEUE-%s] in: %s", + tqueue->name, qitem->description); + } + for(e = Curl_llist_head(&tqueue->recvq); e; e = Curl_node_next(e)) { + qitem = Curl_node_elem(e); + Curl_trc_feat_infof(data, feat, "[TQUEUE-%s] out: %s", + tqueue->name, qitem->description); + } + Curl_mutex_release(&tqueue->lock); + } +} +#endif + +#endif /* USE_THREADS */ diff --git a/3rdparty/curl-8.21.0/lib/thrdqueue.h b/3rdparty/curl-8.21.0/lib/thrdqueue.h new file mode 100644 index 0000000000..1144bb4185 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/thrdqueue.h @@ -0,0 +1,119 @@ +#ifndef HEADER_CURL_THRDQUEUE_H +#define HEADER_CURL_THRDQUEUE_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" +#include "curlx/timediff.h" + +struct curl_thrdq; + +#ifdef USE_THREADS + +struct Curl_easy; + +typedef enum { + CURL_THRDQ_EV_ITEM_DONE /* an item has been processed and is ready */ +} Curl_thrdq_event; + +/* Notification callback when "events" happen in the queue. May be called from + * any thread, queue is not locked. */ +typedef void Curl_thrdq_ev_cb(const struct curl_thrdq *tqueue, + Curl_thrdq_event ev, + void *user_data); + +/* Process a queued item. May be called from any thread. Queue is not + * locked. */ +typedef void Curl_thrdq_item_process_cb(void *item); + +/* Free an item. May be called from any thread at any time for an + * item that is in the queue (either before or after processing). */ +typedef void Curl_thrdq_item_free_cb(void *item); + +/* Create a new queue processing "items" by a thread pool. + */ +CURLcode Curl_thrdq_create(struct curl_thrdq **ptqueue, + const char *name, + uint32_t max_len, /* 0 for unlimited */ + uint32_t min_threads, + uint32_t max_threads, + uint32_t idle_time_ms, + Curl_thrdq_item_free_cb *fn_free, + Curl_thrdq_item_process_cb *fn_process, + Curl_thrdq_ev_cb *fn_event, /* optional */ + void *user_data); + +/* Destroy the queue, free all queued items unprocessed and destroy + * the thread pool used. + * @param join TRUE when thread pool shall be joined. FALSE for + * detaching any running threads. + */ +void Curl_thrdq_destroy(struct curl_thrdq *tqueue, bool join); + +/* Send "item" onto the queue. The caller needs to clear any reference + * to "item" on success, e.g. the queue takes ownership. + * `description` is an optional string describing the item for tracing + * purposes. It needs to have the same lifetime as `item`. + * Returns CURLE_AGAIN when the queue has already been full. + * + * With`timeout_ms` != 0, items that get stuck that long in the send + * queue are removed and added to the receive queue right away. + */ +CURLcode Curl_thrdq_send(struct curl_thrdq *tqueue, void *item, + const char *description, timediff_t timeout_ms); + +/* Receive the oldest, processed item from the queue again, if there is one. + * The caller takes ownership of the item received, e.g. the queue + * relinquishes all references to item. + * Returns CURLE_AGAIN when there is no processed item, setting `pitem` + * to NULL. + */ +CURLcode Curl_thrdq_recv(struct curl_thrdq *tqueue, void **pitem); + +/* Return TRUE if the passed "item" matches. */ +typedef bool Curl_thrdq_item_match_cb(void *item, void *match_data); + +/* Clear all scheduled/processed items that match from the queue. This + * will *not* be able to clear items that are being processed. + */ +void Curl_thrdq_clear(struct curl_thrdq *tqueue, + Curl_thrdq_item_match_cb *fn_match, + void *match_data); + +CURLcode Curl_thrdq_await_done(struct curl_thrdq *tqueue, + uint32_t timeout_ms); + +CURLcode Curl_thrdq_set_props(struct curl_thrdq *tqueue, + uint32_t max_len, /* 0 for unlimited */ + uint32_t min_threads, + uint32_t max_threads, + uint32_t idle_time_ms); + +#ifdef CURLVERBOSE +void Curl_thrdq_trace(struct curl_thrdq *tqueue, + struct Curl_easy *data); +#endif + +#endif /* USE_THREADS */ + +#endif /* HEADER_CURL_THRDQUEUE_H */ diff --git a/3rdparty/curl-8.21.0/lib/transfer.c b/3rdparty/curl-8.21.0/lib/transfer.c new file mode 100644 index 0000000000..1a4138f6c1 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/transfer.c @@ -0,0 +1,916 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETDB_H +#include +#endif +#ifdef HAVE_ARPA_INET_H +#include +#endif +#ifdef HAVE_NET_IF_H +#include +#endif +#ifdef HAVE_SYS_IOCTL_H +#include +#endif +#include + +#ifdef HAVE_SYS_PARAM_H +#include +#endif + +#ifdef HAVE_SYS_SELECT_H +#include +#elif defined(HAVE_UNISTD_H) +#include +#endif + +#ifndef HAVE_SOCKET +#error "We cannot compile without socket() support!" +#endif + +#include "urldata.h" + +#include "hostip.h" +#include "cfilters.h" +#include "cw-out.h" +#include "dnscache.h" +#include "transfer.h" +#include "sendf.h" +#include "curl_trc.h" +#include "progress.h" +#include "http.h" +#include "url.h" +#include "getinfo.h" +#include "multiif.h" +#include "connect.h" +#include "hsts.h" +#include "setopt.h" +#include "headers.h" +#include "bufref.h" + +#if !defined(CURL_DISABLE_HTTP) || !defined(CURL_DISABLE_SMTP) || \ + !defined(CURL_DISABLE_IMAP) +/* + * checkheaders() checks the linked list of custom headers for a + * particular header (prefix). Provide the prefix without colon! + * + * Returns a pointer to the first matching header or NULL if none matched. + */ +char *Curl_checkheaders(const struct Curl_easy *data, + const char *thisheader, + const size_t thislen) +{ + struct curl_slist *head; + DEBUGASSERT(thislen); + DEBUGASSERT(thisheader[thislen - 1] != ':'); + + for(head = data->set.headers; head; head = head->next) { + if(curl_strnequal(head->data, thisheader, thislen) && + Curl_headersep(head->data[thislen])) + return head->data; + } + + return NULL; +} +#endif + +static int data_pending(struct Curl_easy *data, bool rcvd_eagain) +{ + struct connectdata *conn = data->conn; + + if(conn->scheme->protocol & PROTO_FAMILY_FTP) + return Curl_conn_data_pending(data, SECONDARYSOCKET); + + /* in the case of libssh2, we can never be really sure that we have emptied + its internal buffers so we MUST always try until we get EAGAIN back */ + return (!rcvd_eagain && + conn->scheme->protocol & (CURLPROTO_SCP | CURLPROTO_SFTP)) || + Curl_conn_data_pending(data, FIRSTSOCKET); +} + +/* + * Check to see if CURLOPT_TIMECONDITION was met by comparing the time of the + * remote document with the time provided by CURLOPT_TIMEVAL + */ +bool Curl_meets_timecondition(struct Curl_easy *data, time_t timeofdoc) +{ + if((timeofdoc == 0) || (data->set.timevalue == 0)) + return TRUE; + + switch(data->set.timecondition) { + case CURL_TIMECOND_IFMODSINCE: + default: + if(timeofdoc <= data->set.timevalue) { + infof(data, "The requested document is not new enough"); + data->info.timecond = TRUE; + return FALSE; + } + break; + case CURL_TIMECOND_IFUNMODSINCE: + if(timeofdoc >= data->set.timevalue) { + infof(data, "The requested document is not old enough"); + data->info.timecond = TRUE; + return FALSE; + } + break; + } + + return TRUE; +} + +static CURLcode xfer_recv_shutdown(struct Curl_easy *data, bool *done) +{ + if(!data || !data->conn) + return CURLE_FAILED_INIT; + return Curl_conn_shutdown(data, data->conn->recv_idx, done); +} + +static bool xfer_recv_shutdown_started(struct Curl_easy *data) +{ + if(!data || !data->conn) + return FALSE; + return Curl_shutdown_started(data, data->conn->recv_idx); +} + +CURLcode Curl_xfer_send_shutdown(struct Curl_easy *data, bool *done) +{ + if(!data || !data->conn) + return CURLE_FAILED_INIT; + return Curl_conn_shutdown(data, data->conn->send_idx, done); +} + +/** + * Receive raw response data for the transfer. + * @param data the transfer + * @param buf buffer to keep response data received + * @param blen length of `buf` + * @param eos_reliable if EOS detection in underlying connection is reliable + * @return number of bytes read or -1 for error + */ +static CURLcode xfer_recv_resp(struct Curl_easy *data, + char *buf, size_t blen, + bool eos_reliable, + size_t *pnread) +{ + CURLcode result; + + DEBUGASSERT(blen > 0); + *pnread = 0; + /* If we are reading BODY data and the connection does NOT handle EOF + * and we know the size of the BODY data, limit the read amount */ + if(!eos_reliable && !data->req.header && data->req.size != -1) { + blen = curlx_sotouz_range(data->req.size - data->req.bytecount, 0, blen); + } + else if(xfer_recv_shutdown_started(data)) { + /* we already received everything. Do not try more. */ + blen = 0; + } + + if(blen) { + result = Curl_xfer_recv(data, buf, blen, pnread); + if(result) + return result; + } + + if(*pnread == 0) { + if(data->req.shutdown) { + bool done; + result = xfer_recv_shutdown(data, &done); + if(result) + return result; + if(!done) { + return CURLE_AGAIN; + } + } + DEBUGF(infof(data, "sendrecv_dl: we are done")); + } + return CURLE_OK; +} + +/* + * Go ahead and do a read if we have a readable socket or if + * the stream was rewound (in which case we have data in a + * buffer) + */ +static CURLcode sendrecv_dl(struct Curl_easy *data, + struct SingleRequest *k) +{ + struct connectdata *conn = data->conn; + CURLcode result = CURLE_OK; + char *buf, *xfer_buf; + size_t blen, xfer_blen; + int maxloops = 10; + bool is_multiplex = FALSE; + bool rcvd_eagain = FALSE; + bool is_eos = FALSE, rate_limited = FALSE; + + result = Curl_multi_xfer_buf_borrow(data, &xfer_buf, &xfer_blen); + if(result) + goto out; + + /* This is where we loop until we have read everything there is to + read or we get a CURLE_AGAIN */ + do { + size_t bytestoread; + + if(!is_multiplex) { + /* Multiplexed connection have inherent handling of EOF and we do not + * have to carefully restrict the amount we try to read. + * Multiplexed changes only in one direction. */ + is_multiplex = Curl_conn_is_multiplex(conn, FIRSTSOCKET); + } + + buf = xfer_buf; + bytestoread = xfer_blen; + + if(bytestoread && Curl_rlimit_active(&data->progress.dl.rlimit)) { + curl_off_t dl_avail = Curl_rlimit_avail(&data->progress.dl.rlimit, + Curl_pgrs_now(data)); +#if 0 + DEBUGF(infof(data, "dl_rlimit, available=%" FMT_OFF_T, dl_avail)); +#endif + /* In case of rate limited downloads: if this loop already got data and + * less than 16k is left in the limit, break out. We want to stutter a + * bit to keep in the limit, but too small receives will cost cpu + * unnecessarily. */ + if(dl_avail <= 0) { + rate_limited = TRUE; + break; + } + if(dl_avail < (curl_off_t)bytestoread) + bytestoread = (size_t)dl_avail; + } + + rcvd_eagain = FALSE; + result = xfer_recv_resp(data, buf, bytestoread, is_multiplex, &blen); + if(result) { + if(result != CURLE_AGAIN) + goto out; /* real error */ + rcvd_eagain = TRUE; + result = CURLE_OK; + if(data->req.download_done && data->req.no_body && + !data->req.resp_trailer) { + DEBUGF(infof(data, "EAGAIN, download done, no trailer announced, " + "not waiting for EOS")); + blen = 0; + /* continue as if we received the EOS */ + } + else + break; /* get out of loop */ + } + + /* We only get a 0-length receive at the end of the response */ + is_eos = (blen == 0); + + if(!blen) { + result = Curl_req_stop_send_recv(data); + if(result) + goto out; + if(k->eos_written) /* already did write this to client, leave */ + break; + } + + result = Curl_xfer_write_resp(data, buf, blen, is_eos); + if(result || data->req.done) + goto out; + + /* if we are done, we stop receiving. On multiplexed connections, + * we should read the EOS. Which may arrive as meta data after + * the bytes. Not taking it in might lead to RST of streams. */ + if((!is_multiplex && data->req.download_done) || is_eos) { + CURL_REQ_CLEAR_RECV(data); + } + /* if we stopped receiving, leave the loop */ + if(!CURL_REQ_WANT_RECV(data)) + break; + + } while(maxloops--); + + if(!is_eos && !rate_limited && CURL_REQ_WANT_RECV(data) && + (!rcvd_eagain || data_pending(data, rcvd_eagain))) { + /* Did not read until EAGAIN/EOS or there is still data pending + * in buffers. Mark as read-again via simulated SELECT results. */ + Curl_multi_mark_dirty(data); + CURL_TRC_M(data, "sendrecv_dl() no EAGAIN/pending data, mark as dirty"); + } + + if(!CURL_REQ_WANT_RECV(data) && CURL_REQ_WANT_SEND(data) && + (conn->bits.close || is_multiplex)) { + /* When we have read the entire thing and the close bit is set, the server + may now close the connection. If there is now any kind of sending going + on from our side, we need to stop that immediately. */ + infof(data, "we are done reading and this is set to close, stop send"); + Curl_req_abort_sending(data); + } + +out: + Curl_multi_xfer_buf_release(data, xfer_buf); + if(result) + DEBUGF(infof(data, "sendrecv_dl() -> %d", (int)result)); + return result; +} + +/* + * Send data to upload to the server, when the socket is writable. + */ +static CURLcode sendrecv_ul(struct Curl_easy *data) +{ + /* We should not get here when the sending is already done. */ + DEBUGASSERT(!Curl_req_done_sending(data)); + + if(!Curl_req_done_sending(data)) + return Curl_req_send_more(data); + return CURLE_OK; +} + +/* + * Curl_sendrecv() is the low-level function to be called when data is to + * be read and written to/from the connection. + */ +CURLcode Curl_sendrecv(struct Curl_easy *data) +{ + struct SingleRequest *k = &data->req; + CURLcode result = CURLE_OK; + + if(Curl_xfer_is_blocked(data)) { + result = CURLE_OK; + goto out; + } + + /* We go ahead and do a read if we have a readable socket or if the stream + was rewound (in which case we have data in a buffer) */ + if(CURL_REQ_WANT_RECV(data)) { + result = sendrecv_dl(data, k); + if(result || data->req.done) + goto out; + } + + /* If we still have writing to do, we check if we have a writable socket. */ + if(Curl_req_want_send(data)) { + result = sendrecv_ul(data); + if(result) + goto out; + } + + result = Curl_pgrsCheck(data); + if(result) + goto out; + + if(CURL_REQ_WANT_IO(data)) { + if(Curl_timeleft_ms(data) < 0) { + if(k->size != -1) { + failf(data, "Operation timed out after %" FMT_TIMEDIFF_T + " milliseconds with %" FMT_OFF_T " out of %" + FMT_OFF_T " bytes received", + curlx_ptimediff_ms(Curl_pgrs_now(data), + &data->progress.t_startsingle), + k->bytecount, k->size); + } + else { + failf(data, "Operation timed out after %" FMT_TIMEDIFF_T + " milliseconds with %" FMT_OFF_T " bytes received", + curlx_ptimediff_ms(Curl_pgrs_now(data), + &data->progress.t_startsingle), + k->bytecount); + } + result = CURLE_OPERATION_TIMEDOUT; + goto out; + } + } + else { + /* + * The transfer has been performed. Make some general checks before + * returning. + */ + if(!(data->req.no_body) && (k->size != -1) && + (k->bytecount != k->size) && !k->newurl) { + failf(data, "transfer closed with %" FMT_OFF_T + " bytes remaining to read", k->size - k->bytecount); + result = CURLE_PARTIAL_FILE; + goto out; + } + } + + /* If there is nothing more to send/recv, the request is done */ + if(!CURL_REQ_WANT_IO(data)) + data->req.done = TRUE; + + result = Curl_pgrsUpdate(data); + +out: + if(result) + DEBUGF(infof(data, "Curl_sendrecv() -> %d", (int)result)); + return result; +} + +/* Curl_init_CONNECT() gets called each time the handle switches to CONNECT + which means this gets called once for each subsequent redirect etc */ +void Curl_init_CONNECT(struct Curl_easy *data) +{ + data->state.fread_func = data->set.fread_func_set; + data->state.in = data->set.in_set; + data->state.upload = (data->state.httpreq == HTTPREQ_PUT); +} + +/* + * Curl_pretransfer() is called immediately before a transfer starts, and only + * once for one transfer no matter if it has redirects or do multi-pass + * authentication etc. + */ +CURLcode Curl_pretransfer(struct Curl_easy *data) +{ + CURLcode result = CURLE_OK; + + /* Reset the retry count at the start of each request. + * If the retry count is not reset, when the connection drops, + * it will not enter the retry mechanism on CONN_MAX_RETRIES + 1 attempts + * and will immediately throw + * "Connection died, tried CONN_MAX_RETRIES times before giving up". + * By resetting it here, we ensure each new request starts fresh. */ + data->state.retrycount = 0; + + if(!data->set.str[STRING_SET_URL] && !data->set.uh) { + /* we cannot do anything without URL */ + failf(data, "No URL set"); + return CURLE_URL_MALFORMAT; + } + + /* CURLOPT_CURLU overrides CURLOPT_URL and the contents of the CURLU handle + is allowed to be changed by the user between transfers */ + if(data->set.uh) { + CURLUcode uc; + curlx_free(data->set.str[STRING_SET_URL]); + uc = curl_url_get(data->set.uh, + CURLUPART_URL, &data->set.str[STRING_SET_URL], 0); + if(uc) { + /* clear the pointer to not point to freed memory anymore */ + Curl_bufref_set(&data->state.url, NULL, 0, NULL); + failf(data, "No URL set"); + return CURLE_URL_MALFORMAT; + } + } + + Curl_bufref_set(&data->state.url, data->set.str[STRING_SET_URL], 0, NULL); + + if(data->set.postfields && data->set.set_resume_from) { + /* we cannot */ + failf(data, "cannot mix POSTFIELDS with RESUME_FROM"); + return CURLE_BAD_FUNCTION_ARGUMENT; + } + + data->state.prefer_ascii = data->set.prefer_ascii; +#ifdef CURL_LIST_ONLY_PROTOCOL + data->state.list_only = data->set.list_only; +#endif + data->state.httpreq = data->set.method; + + /* initial transfer request coming up, forget the initial origin + * from a previous perform() on this handle. */ + Curl_peer_unlink(&data->state.initial_origin); + Curl_peer_unlink(&data->state.origin); + data->state.requests = 0; + data->state.followlocation = 0; /* reset the location-follow counter */ + data->state.this_is_a_follow = FALSE; /* reset this */ + data->state.http_ignorecustom = FALSE; /* use custom HTTP method */ + data->state.errorbuf = FALSE; /* no error has occurred */ +#ifndef CURL_DISABLE_HTTP + Curl_http_neg_init(data, &data->state.http_neg); +#endif + data->state.authproblem = FALSE; + data->state.authhost.want = data->set.httpauth; + data->state.authproxy.want = data->set.proxyauth; + curlx_safefree(data->info.wouldredirect); + Curl_data_priority_clear_state(data); + if(data->set.http_auto_referer) + Curl_bufref_free(&data->state.referer); + if(data->set.str[STRING_SET_REFERER]) + Curl_bufref_set(&data->state.referer, data->set.str[STRING_SET_REFERER], + 0, NULL); + else + Curl_bufref_free(&data->state.referer); + + if(data->state.httpreq == HTTPREQ_PUT) + data->state.infilesize = data->set.filesize; + else if((data->state.httpreq != HTTPREQ_GET) && + (data->state.httpreq != HTTPREQ_HEAD)) { + data->state.infilesize = data->set.postfieldsize; + if(data->set.postfields && (data->state.infilesize == -1)) + data->state.infilesize = (curl_off_t)strlen(data->set.postfields); + } + else + data->state.infilesize = 0; + + /* If there is a list of cookie files to read, do it now! */ + result = Curl_cookie_loadfiles(data); + if(!result) + Curl_cookie_run(data); /* activate */ + + /* If there is a list of host pairs to deal with */ + if(!result && data->state.resolve) + result = Curl_loadhostpairs(data); + + if(!result) + /* If there is a list of hsts files to read */ + result = Curl_hsts_loadfiles(data); + + if(!result) { + /* Allow data->set.use_port to set which port to use. This needs to be + * disabled for example when we follow Location: headers to URLs using + * different ports! */ + data->state.allow_port = TRUE; + +#if defined(HAVE_SIGNAL) && defined(SIGPIPE) && !defined(MSG_NOSIGNAL) + /************************************************************* + * Tell signal handler to ignore SIGPIPE + *************************************************************/ + if(!data->set.no_signal) + data->state.prev_signal = signal(SIGPIPE, SIG_IGN); +#endif + + Curl_initinfo(data); /* reset session-specific information "variables" */ + Curl_pgrsResetTransferSizes(data); + Curl_pgrsStartNow(data); + + /* In case the handle is reused and an authentication method was picked + in the session we need to make sure we only use the one(s) we now + consider to be fine */ + data->state.authhost.picked &= data->state.authhost.want; + data->state.authproxy.picked &= data->state.authproxy.want; + +#ifndef CURL_DISABLE_FTP + data->state.wildcardmatch = data->set.wildcard_enabled; + if(data->state.wildcardmatch) { + struct WildcardData *wc; + if(!data->wildcard) { + data->wildcard = curlx_calloc(1, sizeof(struct WildcardData)); + if(!data->wildcard) + return CURLE_OUT_OF_MEMORY; + } + wc = data->wildcard; + if(wc->state < CURLWC_INIT) { + if(wc->ftpwc) + wc->dtor(wc->ftpwc); + curlx_safefree(wc->pattern); + curlx_safefree(wc->path); + Curl_wildcard_init(wc); /* init wildcard structures */ + } + } +#endif + result = Curl_hsts_loadcb(data, data->hsts); + } + + /* + * Set user-agent. Used for HTTP, but since we can attempt to tunnel + * anything through an HTTP proxy we cannot limit this based on protocol. + */ + if(!result && data->set.str[STRING_USERAGENT]) { + curlx_free(data->state.aptr.uagent); + data->state.aptr.uagent = + curl_maprintf("User-Agent: %s\r\n", data->set.str[STRING_USERAGENT]); + if(!data->state.aptr.uagent) + return CURLE_OUT_OF_MEMORY; + } + + data->req.headerbytecount = 0; + Curl_headers_cleanup(data); + return result; +} + +/* Returns CURLE_OK *and* sets '*url' if a request retry is wanted. + + NOTE: that the *url is curlx_malloc()ed. */ +CURLcode Curl_retry_request(struct Curl_easy *data, char **url) +{ + struct connectdata *conn = data->conn; + bool retry = FALSE; + *url = NULL; + + /* if we are talking upload, we cannot do the checks below, unless the + protocol is HTTP as when uploading over HTTP we will still get a + response */ + if(data->state.upload && + !(conn->scheme->protocol & (PROTO_FAMILY_HTTP | CURLPROTO_RTSP))) + return CURLE_OK; + + if(conn->bits.reuse && + (data->req.bytecount + data->req.headerbytecount == 0) && + ((!data->req.no_body && !data->req.done) || + (conn->scheme->protocol & PROTO_FAMILY_HTTP)) +#ifndef CURL_DISABLE_RTSP + && (data->set.rtspreq != RTSPREQ_RECEIVE) +#endif + ) + /* We got no data, we attempted to reuse a connection. For HTTP this + can be a retry so we try again regardless if we expected a body. + For other protocols we only try again only if we expected a body. + + This might happen if the connection was left alive when we were + done using it before, but that was closed when we wanted to read from + it again. Bad luck. Retry the same request on a fresh connect! */ + retry = TRUE; + else if(data->state.refused_stream && + (data->req.bytecount + data->req.headerbytecount == 0)) { + /* This was sent on a refused stream, safe to rerun. A refused stream + error can typically only happen on HTTP/2 level if the stream is safe + to issue again, but the nghttp2 API can deliver the message to other + streams as well, which is why this adds the check the data counters + too. */ + infof(data, "REFUSED_STREAM, retrying a fresh connect"); + data->state.refused_stream = FALSE; /* clear again */ + retry = TRUE; + } + if(retry) { +#define CONN_MAX_RETRIES 5 + if(data->state.retrycount++ >= CONN_MAX_RETRIES) { + failf(data, "Connection died, tried %d times before giving up", + CONN_MAX_RETRIES); + data->state.retrycount = 0; + return CURLE_SEND_ERROR; + } + infof(data, "Connection died, retrying a fresh connect (retry count: %d)", + data->state.retrycount); + *url = Curl_bufref_dup(&data->state.url); + if(!*url) + return CURLE_OUT_OF_MEMORY; + + connclose(conn, "retry"); /* close this connection */ + conn->bits.retry = TRUE; /* mark this as a connection we are about to + retry. Marking it this way should prevent i.e + HTTP transfers to return error because nothing + has been transferred! */ + Curl_creader_set_rewind(data, TRUE); + } + return CURLE_OK; +} + +static void xfer_setup( + struct Curl_easy *data, /* transfer */ + int send_idx, /* sockindex to send on or -1 */ + int recv_idx, /* sockindex to receive on or -1 */ + curl_off_t recv_size /* how much to receive, -1 if unknown */ + ) +{ + struct SingleRequest *k = &data->req; + struct connectdata *conn = data->conn; + + DEBUGASSERT(conn); + /* indexes are in range */ + DEBUGASSERT((send_idx <= 1) && (send_idx >= -1)); + DEBUGASSERT((recv_idx <= 1) && (recv_idx >= -1)); + /* if request wants to send, switching off the send direction is wrong */ + DEBUGASSERT((send_idx >= 0) || !Curl_req_want_send(data)); + + conn->send_idx = send_idx; + conn->recv_idx = recv_idx; + + /* without receiving, there should be not recv_size */ + DEBUGASSERT((conn->recv_idx >= 0) || (recv_size == -1)); + k->size = recv_size; + k->header = !!conn->scheme->run->write_resp_hd; + /* by default, we do not shutdown at the end of the transfer */ + k->shutdown = FALSE; + k->shutdown_err_ignore = FALSE; + + /* The code sequence below is placed in this function because all necessary + input is not always known in do_complete() as this function may be called + after that */ + if(!k->header && (recv_size > 0)) + Curl_pgrsSetDownloadSize(data, recv_size); + + /* we want header and/or body, if neither then do not do this! */ + if(conn->scheme->run->write_resp_hd || !data->req.no_body) { + if(conn->recv_idx != -1) + CURL_REQ_SET_RECV(data); + if(conn->send_idx != -1) + CURL_REQ_SET_SEND(data); + } + CURL_TRC_M(data, "xfer_setup: recv_idx=%d, send_idx=%d", + conn->recv_idx, conn->send_idx); +} + +void Curl_xfer_setup_nop(struct Curl_easy *data) +{ + xfer_setup(data, -1, -1, -1); +} + +void Curl_xfer_setup_sendrecv(struct Curl_easy *data, + int sockindex, + curl_off_t recv_size) +{ + xfer_setup(data, sockindex, sockindex, recv_size); +} + +void Curl_xfer_setup_send(struct Curl_easy *data, + int sockindex) +{ + xfer_setup(data, sockindex, -1, -1); +} + +void Curl_xfer_setup_recv(struct Curl_easy *data, + int sockindex, + curl_off_t recv_size) +{ + xfer_setup(data, -1, sockindex, recv_size); +} + +void Curl_xfer_set_shutdown(struct Curl_easy *data, + bool shutdown, + bool ignore_errors) +{ + /* Shutdown should only be set when the transfer only sends or receives. */ + DEBUGASSERT(!shutdown || + (data->conn->send_idx < 0) || (data->conn->recv_idx < 0)); + data->req.shutdown = shutdown; + data->req.shutdown_err_ignore = ignore_errors; +} + +CURLcode Curl_xfer_write_resp(struct Curl_easy *data, + const char *buf, size_t blen, + bool is_eos) +{ + CURLcode result = CURLE_OK; + + if(data->conn->scheme->run->write_resp) { + /* protocol handlers offering this function take full responsibility + * for writing all received download data to the client. */ + result = data->conn->scheme->run->write_resp(data, buf, blen, is_eos); + } + else { + /* No special handling by protocol handler, write all received data + * as BODY to the client. */ + if(blen || is_eos) { + int cwtype = CLIENTWRITE_BODY; + if(is_eos) + cwtype |= CLIENTWRITE_EOS; + result = Curl_client_write(data, cwtype, buf, blen); + } + } + + if(!result && is_eos) { + /* If we wrote the EOS, we are definitely done */ + data->req.eos_written = TRUE; + data->req.download_done = TRUE; + } + CURL_TRC_WRITE(data, "xfer_write_resp(len=%zu, eos=%d) -> %d", + blen, is_eos, (int)result); + return result; +} + +bool Curl_xfer_write_is_paused(struct Curl_easy *data) +{ + return Curl_cwriter_is_paused(data); +} + +CURLcode Curl_xfer_write_resp_hd(struct Curl_easy *data, + const char *hd0, size_t hdlen, bool is_eos) +{ + if(data->conn->scheme->run->write_resp_hd) { + DEBUGASSERT(!hd0[hdlen]); /* null-terminated */ + /* protocol handlers offering this function take full responsibility + * for writing all received download data to the client. */ + return data->conn->scheme->run->write_resp_hd(data, hd0, hdlen, is_eos); + } + /* No special handling by protocol handler, write as response bytes */ + return Curl_xfer_write_resp(data, hd0, hdlen, is_eos); +} + +CURLcode Curl_xfer_write_done(struct Curl_easy *data, bool premature) +{ + (void)premature; + return Curl_cw_out_done(data); +} + +bool Curl_xfer_needs_flush(struct Curl_easy *data) +{ + return Curl_conn_needs_flush(data, data->conn->send_idx); +} + +CURLcode Curl_xfer_flush(struct Curl_easy *data) +{ + return Curl_conn_flush(data, data->conn->send_idx); +} + +CURLcode Curl_xfer_send(struct Curl_easy *data, + const void *buf, size_t blen, bool eos, + size_t *pnwritten) +{ + CURLcode result; + + DEBUGASSERT(data); + DEBUGASSERT(data->conn); + + result = Curl_conn_send(data, data->conn->send_idx, + buf, blen, eos, pnwritten); + if(result == CURLE_AGAIN) { + result = CURLE_OK; + *pnwritten = 0; + } + else if(!result && *pnwritten) + data->info.request_size += *pnwritten; + + DEBUGF(infof(data, "Curl_xfer_send(len=%zu, eos=%d) -> %d, %zu", + blen, eos, (int)result, *pnwritten)); + return result; +} + +CURLcode Curl_xfer_recv(struct Curl_easy *data, + char *buf, size_t blen, + size_t *pnrcvd) +{ + DEBUGASSERT(data); + DEBUGASSERT(data->conn); + DEBUGASSERT(data->set.buffer_size > 0); + + if(curlx_uitouz(data->set.buffer_size) < blen) + blen = curlx_uitouz(data->set.buffer_size); + return Curl_conn_recv(data, data->conn->recv_idx, buf, blen, pnrcvd); +} + +CURLcode Curl_xfer_send_close(struct Curl_easy *data) +{ + Curl_conn_ev_data_done_send(data); + return CURLE_OK; +} + +bool Curl_xfer_is_blocked(struct Curl_easy *data) +{ + bool want_send = CURL_REQ_WANT_SEND(data); + bool want_recv = CURL_REQ_WANT_RECV(data); + if(!want_send) + return want_recv && Curl_xfer_recv_is_paused(data); + else if(!want_recv) + return want_send && Curl_xfer_send_is_paused(data); + else + return Curl_xfer_recv_is_paused(data) && Curl_xfer_send_is_paused(data); +} + +bool Curl_xfer_send_is_paused(struct Curl_easy *data) +{ + return Curl_rlimit_is_blocked(&data->progress.ul.rlimit); +} + +bool Curl_xfer_recv_is_paused(struct Curl_easy *data) +{ + return Curl_rlimit_is_blocked(&data->progress.dl.rlimit); +} + +CURLcode Curl_xfer_pause_send(struct Curl_easy *data, bool enable) +{ + CURLcode result = CURLE_OK; + Curl_rlimit_block(&data->progress.ul.rlimit, enable, Curl_pgrs_now(data)); + if(!enable && Curl_creader_is_paused(data)) + result = Curl_creader_unpause(data); + Curl_pgrsSendPause(data, enable); + return result; +} + +CURLcode Curl_xfer_pause_recv(struct Curl_easy *data, bool enable) +{ + CURLcode result = CURLE_OK; + Curl_rlimit_block(&data->progress.dl.rlimit, enable, Curl_pgrs_now(data)); + if(!enable && Curl_cwriter_is_paused(data)) + result = Curl_cwriter_unpause(data); + Curl_conn_ev_data_pause(data, enable); + Curl_pgrsRecvPause(data, enable); + return result; +} + +bool Curl_xfer_is_secure(struct Curl_easy *data) +{ +#ifndef CURL_DISABLE_PROXY + if(data->conn && data->conn->bits.origin_is_proxy) { + /* talking to a forward proxy, not secure. we do not use + * a forward proxy for https: and other 's' URLs. Let's just check that + * this did not fail somewhere. */ + DEBUGASSERT(!(data->state.origin->scheme->flags & PROTOPT_SSL)); + return FALSE; + } +#endif + return (data->state.origin->scheme->flags & PROTOPT_SSL); +} diff --git a/3rdparty/curl-8.21.0/lib/transfer.h b/3rdparty/curl-8.21.0/lib/transfer.h new file mode 100644 index 0000000000..7507ce27bd --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/transfer.h @@ -0,0 +1,150 @@ +#ifndef HEADER_CURL_TRANSFER_H +#define HEADER_CURL_TRANSFER_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#define Curl_headersep(x) ((((x) == ':') || ((x) == ';'))) + +char *Curl_checkheaders(const struct Curl_easy *data, + const char *thisheader, + const size_t thislen); + +void Curl_init_CONNECT(struct Curl_easy *data); + +CURLcode Curl_pretransfer(struct Curl_easy *data); + +CURLcode Curl_sendrecv(struct Curl_easy *data); +CURLcode Curl_retry_request(struct Curl_easy *data, char **url); +bool Curl_meets_timecondition(struct Curl_easy *data, time_t timeofdoc); + +/** + * Write the transfer raw response bytes, as received from the connection. + * Handle all passed bytes or return an error. By default, this writes + * the bytes as BODY to the client. Protocols may provide a + * "write_resp" callback in their handler to add specific treatment. E.g. + * HTTP parses response headers and passes them differently to the client. + * @param data the transfer + * @param buf the raw response bytes + * @param blen the amount of bytes in `buf` + * @param is_eos TRUE iff the connection indicates this to be the last + * bytes of the response + */ +CURLcode Curl_xfer_write_resp(struct Curl_easy *data, + const char *buf, size_t blen, + bool is_eos); + +bool Curl_xfer_write_is_paused(struct Curl_easy *data); + +/** + * Write a single "header" line from a server response. + * @param hd0 the null-terminated, single header line + * @param hdlen the length of the header line + * @param is_eos TRUE iff this is the end of the response + */ +CURLcode Curl_xfer_write_resp_hd(struct Curl_easy *data, + const char *hd0, size_t hdlen, bool is_eos); + +/* The transfer is neither receiving nor sending. */ +void Curl_xfer_setup_nop(struct Curl_easy *data); + +/* The transfer sends data on the given socket index */ +void Curl_xfer_setup_send(struct Curl_easy *data, + int sockindex); + +/* The transfer receives data on the given socket index, the + * amount to receive (or -1 if unknown). */ +void Curl_xfer_setup_recv(struct Curl_easy *data, + int sockindex, + curl_off_t recv_size); + +/* *After* Curl_xfer_setup_xxx(), tell the transfer to shutdown the + * connection at the end. Let the transfer either fail or ignore any + * errors during shutdown. */ +void Curl_xfer_set_shutdown(struct Curl_easy *data, + bool shutdown, + bool ignore_errors); + +/** + * The transfer will use socket 1 to send/recv. `recv_size` is + * the amount to receive or -1 if unknown. + */ +void Curl_xfer_setup_sendrecv(struct Curl_easy *data, + int sockindex, + curl_off_t recv_size); + +/** + * Multi has set transfer to DONE. Last chance to trigger + * missing response things like writing an EOS to the client. + */ +CURLcode Curl_xfer_write_done(struct Curl_easy *data, bool premature); + +/** + * Return TRUE iff transfer has pending data to send. Checks involved + * connection filters. + */ +bool Curl_xfer_needs_flush(struct Curl_easy *data); + +/** + * Flush any pending send data on the transfer connection. + */ +CURLcode Curl_xfer_flush(struct Curl_easy *data); + +/** + * Send data on the socket/connection filter designated + * for transfer's outgoing data. + * Return CURLE_OK on blocking with (*pnwritten == 0). + */ +CURLcode Curl_xfer_send(struct Curl_easy *data, + const void *buf, size_t blen, bool eos, + size_t *pnwritten); + +/** + * Receive data on the socket/connection filter designated + * for transfer's incoming data. + * Return CURLE_AGAIN on blocking with (*pnrcvd == 0). + */ +CURLcode Curl_xfer_recv(struct Curl_easy *data, + char *buf, size_t blen, + size_t *pnrcvd); + +CURLcode Curl_xfer_send_close(struct Curl_easy *data); +CURLcode Curl_xfer_send_shutdown(struct Curl_easy *data, bool *done); + +/* Return TRUE if the transfer is not done, but further progress + * is blocked. For example when it is only receiving and its writer + * is PAUSED. */ +bool Curl_xfer_is_blocked(struct Curl_easy *data); + +/* Query if send/recv for transfer is paused. */ +bool Curl_xfer_send_is_paused(struct Curl_easy *data); +bool Curl_xfer_recv_is_paused(struct Curl_easy *data); + +/* Enable/Disable pausing of send/recv for the transfer. */ +CURLcode Curl_xfer_pause_send(struct Curl_easy *data, bool enable); +CURLcode Curl_xfer_pause_recv(struct Curl_easy *data, bool enable); + +/* TRUE if the transfer is secure, e.g. uses TLS and does not + * use a forward proxy. */ +bool Curl_xfer_is_secure(struct Curl_easy *data); + +#endif /* HEADER_CURL_TRANSFER_H */ diff --git a/3rdparty/curl-8.21.0/lib/uint-bset.c b/3rdparty/curl-8.21.0/lib/uint-bset.c new file mode 100644 index 0000000000..55aedb234b --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/uint-bset.c @@ -0,0 +1,233 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "uint-bset.h" + +#ifdef DEBUGBUILD +#define CURL_UINT32_BSET_MAGIC 0x62757473 +#endif + +void Curl_uint32_bset_init(struct uint32_bset *bset) +{ + memset(bset, 0, sizeof(*bset)); +#ifdef DEBUGBUILD + bset->init = CURL_UINT32_BSET_MAGIC; +#endif +} + +CURLcode Curl_uint32_bset_resize(struct uint32_bset *bset, uint32_t nmax) +{ + uint32_t nslots = (nmax < (UINT32_MAX - 63)) ? + ((nmax + 63) / 64) : (UINT32_MAX / 64); + + DEBUGASSERT(bset->init == CURL_UINT32_BSET_MAGIC); + if(nslots != bset->nslots) { + uint64_t *slots = curlx_calloc(nslots, sizeof(uint64_t)); + if(!slots) + return CURLE_OUT_OF_MEMORY; + + if(bset->slots) { + memcpy(slots, bset->slots, + (CURLMIN(nslots, bset->nslots) * sizeof(uint64_t))); + curlx_free(bset->slots); + } + bset->slots = slots; + bset->nslots = nslots; + bset->first_slot_used = 0; + } + return CURLE_OK; +} + +void Curl_uint32_bset_destroy(struct uint32_bset *bset) +{ + DEBUGASSERT(bset->init == CURL_UINT32_BSET_MAGIC); + curlx_free(bset->slots); + memset(bset, 0, sizeof(*bset)); +} + +#ifdef UNITTESTS +/* @unittest 3211 */ +UNITTEST uint32_t uint32_bset_capacity(struct uint32_bset *bset); +UNITTEST uint32_t uint32_bset_capacity(struct uint32_bset *bset) +{ + return bset->nslots * 64; +} +#endif + +uint32_t Curl_uint32_bset_count(struct uint32_bset *bset) +{ + uint32_t i; + uint32_t n = 0; + for(i = 0; i < bset->nslots; ++i) { + if(bset->slots[i]) + n += CURL_POPCOUNT64(bset->slots[i]); + } + return n; +} + +bool Curl_uint32_bset_empty(struct uint32_bset *bset) +{ + uint32_t i; + for(i = bset->first_slot_used; i < bset->nslots; ++i) { + if(bset->slots[i]) + return FALSE; + } + return TRUE; +} + +void Curl_uint32_bset_clear(struct uint32_bset *bset) +{ + if(bset->nslots) { + memset(bset->slots, 0, bset->nslots * sizeof(uint64_t)); + bset->first_slot_used = UINT32_MAX; + } +} + +bool Curl_uint32_bset_add(struct uint32_bset *bset, uint32_t i) +{ + uint32_t islot = i / 64; + if(islot >= bset->nslots) + return FALSE; + bset->slots[islot] |= ((uint64_t)1 << (i % 64)); + if(islot < bset->first_slot_used) + bset->first_slot_used = islot; + return TRUE; +} + +void Curl_uint32_bset_remove(struct uint32_bset *bset, uint32_t i) +{ + size_t islot = i / 64; + if(islot < bset->nslots) + bset->slots[islot] &= ~((uint64_t)1 << (i % 64)); +} + +bool Curl_uint32_bset_contains(struct uint32_bset *bset, uint32_t i) +{ + uint32_t islot = i / 64; + if(islot >= bset->nslots) + return FALSE; + return (bset->slots[islot] & ((uint64_t)1 << (i % 64))) != 0; +} + +bool Curl_uint32_bset_first(struct uint32_bset *bset, uint32_t *pfirst) +{ + uint32_t i; + for(i = bset->first_slot_used; i < bset->nslots; ++i) { + if(bset->slots[i]) { + *pfirst = (i * 64) + CURL_CTZ64(bset->slots[i]); + bset->first_slot_used = i; + return TRUE; + } + } + bset->first_slot_used = *pfirst = UINT32_MAX; + return FALSE; +} + +bool Curl_uint32_bset_next(struct uint32_bset *bset, uint32_t last, + uint32_t *pnext) +{ + uint32_t islot; + uint64_t x; + + ++last; /* look for number one higher than last */ + islot = last / 64; /* the slot this would be in */ + if(islot < bset->nslots) { + /* shift away the bits we already iterated in this slot */ + x = (bset->slots[islot] >> (last % 64)); + if(x) { + /* more bits set, next is `last` + trailing 0s of the shifted slot */ + *pnext = last + CURL_CTZ64(x); + return TRUE; + } + /* no more bits set in the last slot, scan forward */ + for(islot = islot + 1; islot < bset->nslots; ++islot) { + if(bset->slots[islot]) { + *pnext = (islot * 64) + CURL_CTZ64(bset->slots[islot]); + return TRUE; + } + } + } + *pnext = UINT32_MAX; /* a value we cannot store */ + return FALSE; +} + +#ifdef CURL_POPCOUNT64_IMPLEMENT +uint32_t Curl_popcount64(uint64_t x) +{ + /* Compute the "Hamming Distance" between 'x' and 0, + * which is the number of set bits in 'x'. + * See: https://en.wikipedia.org/wiki/Hamming_weight */ + const uint64_t m1 = 0x5555555555555555LL; /* 0101+ */ + const uint64_t m2 = 0x3333333333333333LL; /* 00110011+ */ + const uint64_t m4 = 0x0f0f0f0f0f0f0f0fLL; /* 00001111+ */ + /* 1 + 256^1 + 256^2 + 256^3 + ... + 256^7 */ + const uint64_t h01 = 0x0101010101010101LL; + x -= (x >> 1) & m1; /* replace every 2 bits with bits present */ + x = (x & m2) + ((x >> 2) & m2); /* replace every nibble with bits present */ + x = (x + (x >> 4)) & m4; /* replace every byte with bits present */ + /* top 8 bits of x + (x << 8) + (x << 16) + (x << 24) + ... which makes the + * top byte the sum of all individual 8 bytes, throw away the rest */ + return (uint32_t)((x * h01) >> 56); +} +#endif /* CURL_POPCOUNT64_IMPLEMENT */ + +#ifdef CURL_CTZ64_IMPLEMENT +uint32_t Curl_ctz64(uint64_t x) +{ + /* count trailing zeros in a uint64_t. + * divide and conquer to find the number of lower 0 bits */ + const uint64_t ml32 = 0xFFFFFFFF; /* lower 32 bits */ + const uint64_t ml16 = 0x0000FFFF; /* lower 16 bits */ + const uint64_t ml8 = 0x000000FF; /* lower 8 bits */ + const uint64_t ml4 = 0x0000000F; /* lower 4 bits */ + const uint64_t ml2 = 0x00000003; /* lower 2 bits */ + uint32_t n; + + if(!x) + return 64; + n = 1; + if(!(x & ml32)) { + n = n + 32; + x = x >> 32; + } + if(!(x & ml16)) { + n = n + 16; + x = x >> 16; + } + if(!(x & ml8)) { + n = n + 8; + x = x >> 8; + } + if(!(x & ml4)) { + n = n + 4; + x = x >> 4; + } + if(!(x & ml2)) { + n = n + 2; + x = x >> 2; + } + return n - (uint32_t)(x & 1); +} +#endif /* CURL_CTZ64_IMPLEMENT */ diff --git a/3rdparty/curl-8.21.0/lib/uint-bset.h b/3rdparty/curl-8.21.0/lib/uint-bset.h new file mode 100644 index 0000000000..ce0450c53c --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/uint-bset.h @@ -0,0 +1,109 @@ +#ifndef HEADER_CURL_UINT_BSET_H +#define HEADER_CURL_UINT_BSET_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +/* A bitset for unsigned int values. + * It can hold the numbers from 0 - (nmax - 1), + * rounded to the next 64 multiple. + * + * Optimized for high efficiency in adding/removing numbers. + * Efficient storage when the set is (often) relatively full. + * + * If the set's cardinality is only expected to be a fraction of nmax, + * uint_spbset offers a "sparse" variant with more memory efficiency at + * the price of slightly slower operations. + */ + +struct uint32_bset { + uint64_t *slots; + uint32_t nslots; + uint32_t first_slot_used; +#ifdef DEBUGBUILD + int init; +#endif +}; + +/* Initialize the bitset with capacity 0. */ +void Curl_uint32_bset_init(struct uint32_bset *bset); + +/* Resize the bitset capacity to hold numbers from 0 to `nmax`, + * which rounds up `nmax` to the next multiple of 64. */ +CURLcode Curl_uint32_bset_resize(struct uint32_bset *bset, uint32_t nmax); + +/* Destroy the bitset, freeing all resources. */ +void Curl_uint32_bset_destroy(struct uint32_bset *bset); + +/* Get the cardinality of the bitset, e.g. numbers present in the set. */ +uint32_t Curl_uint32_bset_count(struct uint32_bset *bset); + +/* TRUE of bitset is empty */ +bool Curl_uint32_bset_empty(struct uint32_bset *bset); + +/* Clear the bitset, making it empty. */ +void Curl_uint32_bset_clear(struct uint32_bset *bset); + +/* Add the number `i` to the bitset. Return FALSE if the number is + * outside the set's capacity. + * Numbers can be added more than once, without making a difference. */ +bool Curl_uint32_bset_add(struct uint32_bset *bset, uint32_t i); + +/* Remove the number `i` from the bitset. */ +void Curl_uint32_bset_remove(struct uint32_bset *bset, uint32_t i); + +/* Return TRUE if the bitset contains number `i`. */ +bool Curl_uint32_bset_contains(struct uint32_bset *bset, uint32_t i); + +/* Get the first number in the bitset, e.g. the smallest. + * Returns FALSE when the bitset is empty. */ +bool Curl_uint32_bset_first(struct uint32_bset *bset, uint32_t *pfirst); + +/* Get the next number in the bitset, following `last` in natural order. + * Put another way, this is the smallest number greater than `last` in + * the bitset. `last` does not have to be present in the set. + * + * Returns FALSE when no such number is in the set. + * + * This allows to iterate the set while being modified: + * - added numbers higher than 'last' will be picked up by the iteration. + * - added numbers lower than 'last' will not show up. + * - removed numbers lower or equal to 'last' will not show up. + * - removed numbers higher than 'last' will not be visited. */ +bool Curl_uint32_bset_next(struct uint32_bset *bset, uint32_t last, + uint32_t *pnext); + +#ifndef CURL_POPCOUNT64 +#define CURL_POPCOUNT64(x) Curl_popcount64(x) +#define CURL_POPCOUNT64_IMPLEMENT +uint32_t Curl_popcount64(uint64_t x); +#endif /* !CURL_POPCOUNT64 */ + +#ifndef CURL_CTZ64 +#define CURL_CTZ64(x) Curl_ctz64(x) +#define CURL_CTZ64_IMPLEMENT +uint32_t Curl_ctz64(uint64_t x); +#endif /* !CURL_CTZ64 */ + +#endif /* HEADER_CURL_UINT_BSET_H */ diff --git a/3rdparty/curl-8.21.0/lib/uint-hash.c b/3rdparty/curl-8.21.0/lib/uint-hash.c new file mode 100644 index 0000000000..c37448fd11 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/uint-hash.c @@ -0,0 +1,235 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "uint-hash.h" + +/* random patterns for API verification */ +#ifdef DEBUGBUILD +#define CURL_UINT32_HASHINIT 0x7117e779 +#endif + +static uint32_t uint32_hash_hash(uint32_t id, uint32_t slots) +{ + return (id % slots); +} + +struct uint_hash_entry { + struct uint_hash_entry *next; + void *value; + uint32_t id; +}; + +void Curl_uint32_hash_init(struct uint_hash *h, + uint32_t slots, + Curl_uint32_hash_dtor *dtor) +{ + DEBUGASSERT(h); + DEBUGASSERT(slots); + + h->table = NULL; + h->dtor = dtor; + h->size = 0; + h->slots = slots; +#ifdef DEBUGBUILD + h->init = CURL_UINT32_HASHINIT; +#endif +} + +static struct uint_hash_entry *uint32_hash_mk_entry(uint32_t id, void *value) +{ + struct uint_hash_entry *e; + + /* allocate the struct for the hash entry */ + e = curlx_malloc(sizeof(*e)); + if(e) { + e->id = id; + e->next = NULL; + e->value = value; + } + return e; +} + +static void uint32_hash_entry_clear(struct uint_hash *h, + struct uint_hash_entry *e) +{ + DEBUGASSERT(h); + DEBUGASSERT(e); + if(e->value) { + if(h->dtor) + h->dtor(e->id, e->value); + e->value = NULL; + } +} + +static void uint32_hash_entry_destroy(struct uint_hash *h, + struct uint_hash_entry *e) +{ + uint32_hash_entry_clear(h, e); + curlx_free(e); +} + +static void uint32_hash_entry_unlink(struct uint_hash *h, + struct uint_hash_entry **he_anchor, + struct uint_hash_entry *he) +{ + *he_anchor = he->next; + --h->size; +} + +static void uint32_hash_elem_link(struct uint_hash *h, + struct uint_hash_entry **he_anchor, + struct uint_hash_entry *he) +{ + he->next = *he_anchor; + *he_anchor = he; + ++h->size; +} + +#define CURL_UINT32_HASH_SLOT(h, id) h->table[uint32_hash_hash(id, (h)->slots)] +#define CURL_UINT32_HASH_SLOT_ADDR(h, id) &CURL_UINT32_HASH_SLOT(h, id) + +bool Curl_uint32_hash_set(struct uint_hash *h, uint32_t id, void *value) +{ + struct uint_hash_entry *he, **slot; + + DEBUGASSERT(h); + DEBUGASSERT(h->slots); + DEBUGASSERT(h->init == CURL_UINT32_HASHINIT); + if(!h->table) { + h->table = curlx_calloc(h->slots, sizeof(*he)); + if(!h->table) + return FALSE; /* OOM */ + } + + slot = CURL_UINT32_HASH_SLOT_ADDR(h, id); + for(he = *slot; he; he = he->next) { + if(he->id == id) { + /* existing key entry, overwrite by clearing old pointer */ + uint32_hash_entry_clear(h, he); + he->value = value; + return TRUE; + } + } + + he = uint32_hash_mk_entry(id, value); + if(!he) + return FALSE; /* OOM */ + + uint32_hash_elem_link(h, slot, he); + return TRUE; +} + +bool Curl_uint32_hash_remove(struct uint_hash *h, uint32_t id) +{ + DEBUGASSERT(h); + DEBUGASSERT(h->slots); + DEBUGASSERT(h->init == CURL_UINT32_HASHINIT); + if(h->table) { + struct uint_hash_entry *he, **he_anchor; + + he_anchor = CURL_UINT32_HASH_SLOT_ADDR(h, id); + while(*he_anchor) { + he = *he_anchor; + if(id == he->id) { + uint32_hash_entry_unlink(h, he_anchor, he); + uint32_hash_entry_destroy(h, he); + return TRUE; + } + he_anchor = &he->next; + } + } + return FALSE; +} + +void *Curl_uint32_hash_get(struct uint_hash *h, uint32_t id) +{ + DEBUGASSERT(h); + DEBUGASSERT(h->init == CURL_UINT32_HASHINIT); + if(h->table) { + struct uint_hash_entry *he; + DEBUGASSERT(h->slots); + he = CURL_UINT32_HASH_SLOT(h, id); + while(he) { + if(id == he->id) { + return he->value; + } + he = he->next; + } + } + return NULL; +} + +/* @unittest 1616 */ +UNITTEST void uint_hash_clear(struct uint_hash *h); +UNITTEST void uint_hash_clear(struct uint_hash *h) +{ + if(h && h->table) { + struct uint_hash_entry *he, **he_anchor; + size_t i; + DEBUGASSERT(h->init == CURL_UINT32_HASHINIT); + for(i = 0; i < h->slots; ++i) { + he_anchor = &h->table[i]; + while(*he_anchor) { + he = *he_anchor; + uint32_hash_entry_unlink(h, he_anchor, he); + uint32_hash_entry_destroy(h, he); + } + } + } +} + +void Curl_uint32_hash_destroy(struct uint_hash *h) +{ + DEBUGASSERT(h->init == CURL_UINT32_HASHINIT); + if(h->table) { + uint_hash_clear(h); + curlx_safefree(h->table); + } + DEBUGASSERT(h->size == 0); + h->slots = 0; +} + +uint32_t Curl_uint32_hash_count(struct uint_hash *h) +{ + DEBUGASSERT(h->init == CURL_UINT32_HASHINIT); + return h->size; +} + +void Curl_uint32_hash_visit(struct uint_hash *h, + Curl_uint32_hash_visit_cb *cb, + void *user_data) +{ + if(h && h->table && cb) { + struct uint_hash_entry *he; + size_t i; + DEBUGASSERT(h->init == CURL_UINT32_HASHINIT); + for(i = 0; i < h->slots; ++i) { + for(he = h->table[i]; he; he = he->next) { + if(!cb(he->id, he->value, user_data)) + return; + } + } + } +} diff --git a/3rdparty/curl-8.21.0/lib/uint-hash.h b/3rdparty/curl-8.21.0/lib/uint-hash.h new file mode 100644 index 0000000000..3cbcf8f8f1 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/uint-hash.h @@ -0,0 +1,59 @@ +#ifndef HEADER_CURL_UINT_HASH_H +#define HEADER_CURL_UINT_HASH_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +/* A version with uint32_t as key */ +typedef void Curl_uint32_hash_dtor(uint32_t id, void *value); +struct uint_hash_entry; + +/* Hash for `uint32_t` as key */ +struct uint_hash { + struct uint_hash_entry **table; + Curl_uint32_hash_dtor *dtor; + uint32_t slots; + uint32_t size; +#ifdef DEBUGBUILD + int init; +#endif +}; + +void Curl_uint32_hash_init(struct uint_hash *h, + uint32_t slots, + Curl_uint32_hash_dtor *dtor); +void Curl_uint32_hash_destroy(struct uint_hash *h); +bool Curl_uint32_hash_set(struct uint_hash *h, uint32_t id, void *value); +bool Curl_uint32_hash_remove(struct uint_hash *h, uint32_t id); +void *Curl_uint32_hash_get(struct uint_hash *h, uint32_t id); +uint32_t Curl_uint32_hash_count(struct uint_hash *h); + +typedef bool Curl_uint32_hash_visit_cb(uint32_t id, void *value, + void *user_data); + +void Curl_uint32_hash_visit(struct uint_hash *h, + Curl_uint32_hash_visit_cb *cb, + void *user_data); + +#endif /* HEADER_CURL_UINT_HASH_H */ diff --git a/3rdparty/curl-8.21.0/lib/uint-spbset.c b/3rdparty/curl-8.21.0/lib/uint-spbset.c new file mode 100644 index 0000000000..d4e6c8e70b --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/uint-spbset.c @@ -0,0 +1,253 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "uint-bset.h" +#include "uint-spbset.h" + +#ifdef DEBUGBUILD +#define CURL_UINT32_SPBSET_MAGIC 0x70737362 +#endif + +void Curl_uint32_spbset_init(struct uint32_spbset *bset) +{ + memset(bset, 0, sizeof(*bset)); +#ifdef DEBUGBUILD + bset->init = CURL_UINT32_SPBSET_MAGIC; +#endif +} + +/* Clear the bitset, making it empty. + + @unittest 3213 + */ +UNITTEST void uint32_spbset_clear(struct uint32_spbset *bset); +UNITTEST void uint32_spbset_clear(struct uint32_spbset *bset) +{ + struct uint32_spbset_chunk *next, *chunk; + + for(chunk = bset->head.next; chunk; chunk = next) { + next = chunk->next; + curlx_free(chunk); + } + memset(&bset->head, 0, sizeof(bset->head)); +} + +void Curl_uint32_spbset_destroy(struct uint32_spbset *bset) +{ + DEBUGASSERT(bset->init == CURL_UINT32_SPBSET_MAGIC); + uint32_spbset_clear(bset); +} + +uint32_t Curl_uint32_spbset_count(struct uint32_spbset *bset) +{ + struct uint32_spbset_chunk *chunk; + uint32_t i, n = 0; + + for(chunk = &bset->head; chunk; chunk = chunk->next) { + for(i = 0; i < CURL_UINT32_SPBSET_CH_SLOTS; ++i) { + if(chunk->slots[i]) + n += CURL_POPCOUNT64(chunk->slots[i]); + } + } + return n; +} + +static struct uint32_spbset_chunk *uint32_spbset_get_chunk( + struct uint32_spbset *bset, uint32_t i, bool grow) +{ + struct uint32_spbset_chunk *chunk, **panchor = NULL; + uint32_t i_offset = (i & ~CURL_UINT32_SPBSET_CH_MASK); + + if(!bset) + return NULL; + + for(chunk = &bset->head; chunk; + panchor = &chunk->next, chunk = chunk->next) { + if(chunk->offset == i_offset) { + return chunk; + } + else if(chunk->offset > i_offset) { + /* need new chunk here */ + chunk = NULL; + break; + } + } + + if(!grow) + return NULL; + + /* need a new one */ + chunk = curlx_calloc(1, sizeof(*chunk)); + if(!chunk) + return NULL; + + if(panchor) { /* insert between panchor and *panchor */ + chunk->next = *panchor; + *panchor = chunk; + } + else { /* prepend to head, switching places */ + memcpy(chunk, &bset->head, sizeof(*chunk)); + memset(&bset->head, 0, sizeof(bset->head)); + bset->head.next = chunk; + } + chunk->offset = i_offset; + return chunk; +} + +bool Curl_uint32_spbset_add(struct uint32_spbset *bset, uint32_t i) +{ + struct uint32_spbset_chunk *chunk; + uint32_t i_chunk; + + chunk = uint32_spbset_get_chunk(bset, i, TRUE); + if(!chunk) + return FALSE; + + DEBUGASSERT(i >= chunk->offset); + i_chunk = (i - chunk->offset); + DEBUGASSERT((i_chunk / 64) < CURL_UINT32_SPBSET_CH_SLOTS); + chunk->slots[(i_chunk / 64)] |= ((uint64_t)1 << (i_chunk % 64)); + return TRUE; +} + +void Curl_uint32_spbset_remove(struct uint32_spbset *bset, uint32_t i) +{ + struct uint32_spbset_chunk *chunk; + uint32_t i_chunk; + + chunk = uint32_spbset_get_chunk(bset, i, FALSE); + if(chunk) { + DEBUGASSERT(i >= chunk->offset); + i_chunk = (i - chunk->offset); + DEBUGASSERT((i_chunk / 64) < CURL_UINT32_SPBSET_CH_SLOTS); + chunk->slots[(i_chunk / 64)] &= ~((uint64_t)1 << (i_chunk % 64)); + } +} + +bool Curl_uint32_spbset_contains(struct uint32_spbset *bset, uint32_t i) +{ + struct uint32_spbset_chunk *chunk; + uint32_t i_chunk; + + chunk = uint32_spbset_get_chunk(bset, i, FALSE); + if(chunk) { + DEBUGASSERT(i >= chunk->offset); + i_chunk = (i - chunk->offset); + DEBUGASSERT((i_chunk / 64) < CURL_UINT32_SPBSET_CH_SLOTS); + return (chunk->slots[i_chunk / 64] & + ((uint64_t)1 << (i_chunk % 64))) != 0; + } + return FALSE; +} + +bool Curl_uint32_spbset_first(struct uint32_spbset *bset, uint32_t *pfirst) +{ + struct uint32_spbset_chunk *chunk; + uint32_t i; + + for(chunk = &bset->head; chunk; chunk = chunk->next) { + for(i = 0; i < CURL_UINT32_SPBSET_CH_SLOTS; ++i) { + if(chunk->slots[i]) { + *pfirst = chunk->offset + ((i * 64) + CURL_CTZ64(chunk->slots[i])); + return TRUE; + } + } + } + *pfirst = 0; /* give it a defined value even if it should not be used */ + return FALSE; +} + +static bool uint32_spbset_chunk_first(struct uint32_spbset_chunk *chunk, + uint32_t *pfirst) +{ + uint32_t i; + for(i = 0; i < CURL_UINT32_SPBSET_CH_SLOTS; ++i) { + if(chunk->slots[i]) { + *pfirst = chunk->offset + ((i * 64) + CURL_CTZ64(chunk->slots[i])); + return TRUE; + } + } + *pfirst = UINT32_MAX; /* a value we cannot store */ + return FALSE; +} + +static bool uint32_spbset_chunk_next(struct uint32_spbset_chunk *chunk, + uint32_t last, + uint32_t *pnext) +{ + if(chunk->offset <= last) { + uint64_t x; + uint32_t i = ((last - chunk->offset) / 64); + if(i < CURL_UINT32_SPBSET_CH_SLOTS) { + x = (chunk->slots[i] >> (last % 64)); + if(x) { + /* more bits set, next is `last` + trailing 0s of the shifted slot */ + *pnext = last + CURL_CTZ64(x); + return TRUE; + } + /* no more bits set in the last slot, scan forward */ + for(i = i + 1; i < CURL_UINT32_SPBSET_CH_SLOTS; ++i) { + if(chunk->slots[i]) { + *pnext = chunk->offset + ((i * 64) + CURL_CTZ64(chunk->slots[i])); + return TRUE; + } + } + } + } + *pnext = UINT32_MAX; + return FALSE; +} + +bool Curl_uint32_spbset_next(struct uint32_spbset *bset, uint32_t last, + uint32_t *pnext) +{ + struct uint32_spbset_chunk *chunk; + uint32_t last_offset; + + ++last; /* look for the next higher number */ + last_offset = (last & ~CURL_UINT32_SPBSET_CH_MASK); + + for(chunk = &bset->head; chunk; chunk = chunk->next) { + if(chunk->offset >= last_offset) { + break; + } + } + + if(chunk && (chunk->offset == last_offset)) { + /* is there a number higher than last in this chunk? */ + if(uint32_spbset_chunk_next(chunk, last, pnext)) + return TRUE; + /* not in this chunk */ + chunk = chunk->next; + } + /* look for the first in the "higher" chunks, if there are any. */ + while(chunk) { + if(uint32_spbset_chunk_first(chunk, pnext)) + return TRUE; + chunk = chunk->next; + } + *pnext = UINT32_MAX; + return FALSE; +} diff --git a/3rdparty/curl-8.21.0/lib/uint-spbset.h b/3rdparty/curl-8.21.0/lib/uint-spbset.h new file mode 100644 index 0000000000..4b105c02ed --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/uint-spbset.h @@ -0,0 +1,91 @@ +#ifndef HEADER_CURL_UINT_SPBSET_H +#define HEADER_CURL_UINT_SPBSET_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +/* A "sparse" bitset for uint32_t values. + * It can hold any uint32_t value. + * + * Optimized for the case where only a small set of numbers need + * to be kept, especially when "close" together. Then storage space + * is most efficient, deteriorating when many number are far apart. + */ + +/* 4 slots = 256 bits, keep this a 2^n value. */ +#define CURL_UINT32_SPBSET_CH_SLOTS 4 +#define CURL_UINT32_SPBSET_CH_MASK ((CURL_UINT32_SPBSET_CH_SLOTS * 64) - 1) + +/* store the uint value from offset to + * (offset + (CURL_UINT32_SPBSET_CHUNK_SLOTS * 64) - 1 */ +struct uint32_spbset_chunk { + struct uint32_spbset_chunk *next; + uint64_t slots[CURL_UINT32_SPBSET_CH_SLOTS]; + uint32_t offset; +}; + +struct uint32_spbset { + struct uint32_spbset_chunk head; +#ifdef DEBUGBUILD + int init; +#endif +}; + +void Curl_uint32_spbset_init(struct uint32_spbset *bset); + +void Curl_uint32_spbset_destroy(struct uint32_spbset *bset); + +/* Get the cardinality of the bitset, e.g. numbers present in the set. */ +uint32_t Curl_uint32_spbset_count(struct uint32_spbset *bset); + +/* Add the number `i` to the bitset. + * Numbers can be added more than once, without making a difference. + * Returns FALSE if allocations failed. */ +bool Curl_uint32_spbset_add(struct uint32_spbset *bset, uint32_t i); + +/* Remove the number `i` from the bitset. */ +void Curl_uint32_spbset_remove(struct uint32_spbset *bset, uint32_t i); + +/* Return TRUE if the bitset contains number `i`. */ +bool Curl_uint32_spbset_contains(struct uint32_spbset *bset, uint32_t i); + +/* Get the first number in the bitset, e.g. the smallest. + * Returns FALSE when the bitset is empty. */ +bool Curl_uint32_spbset_first(struct uint32_spbset *bset, uint32_t *pfirst); + +/* Get the next number in the bitset, following `last` in natural order. + * Put another way, this is the smallest number greater than `last` in + * the bitset. `last` does not have to be present in the set. + * + * Returns FALSE when no such number is in the set. + * + * This allows to iterate the set while being modified: + * - added numbers higher than 'last' will be picked up by the iteration. + * - added numbers lower than 'last' will not show up. + * - removed numbers lower or equal to 'last' will not show up. + * - removed numbers higher than 'last' will not be visited. */ +bool Curl_uint32_spbset_next(struct uint32_spbset *bset, uint32_t last, + uint32_t *pnext); + +#endif /* HEADER_CURL_UINT_SPBSET_H */ diff --git a/3rdparty/curl-8.21.0/lib/uint-table.c b/3rdparty/curl-8.21.0/lib/uint-table.c new file mode 100644 index 0000000000..addd2c9cb2 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/uint-table.c @@ -0,0 +1,202 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "uint-table.h" + +#ifdef DEBUGBUILD +#define CURL_UINT32_TBL_MAGIC 0x62757473 +#endif + +void Curl_uint32_tbl_init(struct uint32_tbl *tbl, + Curl_uint32_tbl_entry_dtor *entry_dtor) +{ + memset(tbl, 0, sizeof(*tbl)); + tbl->entry_dtor = entry_dtor; + tbl->last_key_added = UINT32_MAX; +#ifdef DEBUGBUILD + tbl->init = CURL_UINT32_TBL_MAGIC; +#endif +} + +static void uint32_tbl_clear_rows(struct uint32_tbl *tbl, + uint32_t from, + uint32_t upto_excluding) +{ + uint32_t i, end; + + end = CURLMIN(upto_excluding, tbl->nrows); + for(i = from; i < end; ++i) { + if(tbl->rows[i]) { + if(tbl->entry_dtor) + tbl->entry_dtor(i, tbl->rows[i]); + tbl->rows[i] = NULL; + tbl->nentries--; + } + } +} + +CURLcode Curl_uint32_tbl_resize(struct uint32_tbl *tbl, uint32_t nrows) +{ + /* we use `tbl->nrows + 1` during iteration, want that to work */ + DEBUGASSERT(tbl->init == CURL_UINT32_TBL_MAGIC); + if(!nrows) + return CURLE_BAD_FUNCTION_ARGUMENT; + if(nrows != tbl->nrows) { + void **rows = curlx_calloc(nrows, sizeof(void *)); + if(!rows) + return CURLE_OUT_OF_MEMORY; + if(tbl->rows) { + memcpy(rows, tbl->rows, (CURLMIN(nrows, tbl->nrows) * sizeof(void *))); + if(nrows < tbl->nrows) + uint32_tbl_clear_rows(tbl, nrows, tbl->nrows); + curlx_free(tbl->rows); + } + tbl->rows = rows; + tbl->nrows = nrows; + } + return CURLE_OK; +} + +/* Clear the table, making it empty. + + @unittest 3212 + */ +UNITTEST void uint32_tbl_clear(struct uint32_tbl *tbl); +UNITTEST void uint32_tbl_clear(struct uint32_tbl *tbl) +{ + DEBUGASSERT(tbl->init == CURL_UINT32_TBL_MAGIC); + uint32_tbl_clear_rows(tbl, 0, tbl->nrows); + DEBUGASSERT(!tbl->nentries); + tbl->last_key_added = UINT32_MAX; +} + +void Curl_uint32_tbl_destroy(struct uint32_tbl *tbl) +{ + DEBUGASSERT(tbl->init == CURL_UINT32_TBL_MAGIC); + uint32_tbl_clear(tbl); + curlx_free(tbl->rows); + memset(tbl, 0, sizeof(*tbl)); +} + +uint32_t Curl_uint32_tbl_capacity(struct uint32_tbl *tbl) +{ + return tbl->nrows; +} + +uint32_t Curl_uint32_tbl_count(struct uint32_tbl *tbl) +{ + return tbl->nentries; +} + +void *Curl_uint32_tbl_get(struct uint32_tbl *tbl, uint32_t key) +{ + return (key < tbl->nrows) ? tbl->rows[key] : NULL; +} + +bool Curl_uint32_tbl_add(struct uint32_tbl *tbl, void *entry, uint32_t *pkey) +{ + uint32_t key, start_pos; + + DEBUGASSERT(tbl->init == CURL_UINT32_TBL_MAGIC); + if(!entry || !pkey) + return FALSE; + *pkey = UINT32_MAX; + if(tbl->nentries == tbl->nrows) /* full */ + return FALSE; + + start_pos = CURLMIN(tbl->last_key_added, tbl->nrows) + 1; + for(key = start_pos; key < tbl->nrows; ++key) { + if(!tbl->rows[key]) { + tbl->rows[key] = entry; + tbl->nentries++; + tbl->last_key_added = key; + *pkey = key; + return TRUE; + } + } + /* no free entry at or above tbl->maybe_next_key, wrap around */ + for(key = 0; key < start_pos; ++key) { + if(!tbl->rows[key]) { + tbl->rows[key] = entry; + tbl->nentries++; + tbl->last_key_added = key; + *pkey = key; + return TRUE; + } + } + /* Did not find any free row? Should not happen */ + DEBUGASSERT(0); + return FALSE; +} + +void Curl_uint32_tbl_remove(struct uint32_tbl *tbl, uint32_t key) +{ + uint32_tbl_clear_rows(tbl, key, key + 1); +} + +bool Curl_uint32_tbl_contains(struct uint32_tbl *tbl, uint32_t key) +{ + return (key < tbl->nrows) ? !!tbl->rows[key] : FALSE; +} + +static bool uint32_tbl_next_at(struct uint32_tbl *tbl, uint32_t key, + uint32_t *pkey, void **pentry) +{ + for(; key < tbl->nrows; ++key) { + if(tbl->rows[key]) { + *pkey = key; + *pentry = tbl->rows[key]; + return TRUE; + } + } + *pkey = UINT32_MAX; /* always invalid */ + *pentry = NULL; + return FALSE; +} + +bool Curl_uint32_tbl_first(struct uint32_tbl *tbl, + uint32_t *pkey, void **pentry) +{ + if(!pkey || !pentry) + return FALSE; + if(tbl->nentries && uint32_tbl_next_at(tbl, 0, pkey, pentry)) + return TRUE; + DEBUGASSERT(!tbl->nentries); + *pkey = UINT32_MAX; /* always invalid */ + *pentry = NULL; + return FALSE; +} + +bool Curl_uint32_tbl_next(struct uint32_tbl *tbl, uint32_t last_key, + uint32_t *pkey, void **pentry) +{ + if(!pkey || !pentry) + return FALSE; + if(uint32_tbl_next_at(tbl, last_key + 1, pkey, pentry)) + return TRUE; + *pkey = UINT32_MAX; /* always invalid */ + *pentry = NULL; + return FALSE; +} diff --git a/3rdparty/curl-8.21.0/lib/uint-table.h b/3rdparty/curl-8.21.0/lib/uint-table.h new file mode 100644 index 0000000000..398a26a648 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/uint-table.h @@ -0,0 +1,96 @@ +#ifndef HEADER_CURL_UINT_TABLE_H +#define HEADER_CURL_UINT_TABLE_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +/* Destructor for a single table entry */ +typedef void Curl_uint32_tbl_entry_dtor(uint32_t key, void *entry); + +struct uint32_tbl { + void **rows; /* array of void* holding entries */ + Curl_uint32_tbl_entry_dtor *entry_dtor; + uint32_t nrows; /* length of `rows` array */ + uint32_t nentries; /* entries in table */ + uint32_t last_key_added; /* UINT_MAX or last key added */ +#ifdef DEBUGBUILD + int init; +#endif +}; + +/* Initialize the table with 0 capacity. + * The optional `entry_dtor` is called when a table entry is removed, + * Passing NULL means no action is taken on removal. */ +void Curl_uint32_tbl_init(struct uint32_tbl *tbl, + Curl_uint32_tbl_entry_dtor *entry_dtor); + +/* Resize the table to change capacity `nmax`. When `nmax` is reduced, + * all present entries with key equal or larger to `nmax` are removed. */ +CURLcode Curl_uint32_tbl_resize(struct uint32_tbl *tbl, uint32_t nrows); + +/* Destroy the table, freeing all entries. */ +void Curl_uint32_tbl_destroy(struct uint32_tbl *tbl); + +/* Get the table capacity. */ +uint32_t Curl_uint32_tbl_capacity(struct uint32_tbl *tbl); + +/* Get the number of entries in the table. */ +uint32_t Curl_uint32_tbl_count(struct uint32_tbl *tbl); + +/* Get the entry for key or NULL if not present */ +void *Curl_uint32_tbl_get(struct uint32_tbl *tbl, uint32_t key); + +/* Add a new entry to the table and assign it a free key. + * Returns FALSE if the table is full. + * + * Keys are assigned in a round-robin manner. + * No matter the capacity, UINT_MAX is never assigned. */ +bool Curl_uint32_tbl_add(struct uint32_tbl *tbl, void *entry, uint32_t *pkey); + +/* Remove the entry with `key`. */ +void Curl_uint32_tbl_remove(struct uint32_tbl *tbl, uint32_t key); + +/* Return TRUE if the table contains an tryn with that keys. */ +bool Curl_uint32_tbl_contains(struct uint32_tbl *tbl, uint32_t key); + +/* Get the first entry in the table (with the smallest `key`). + * Returns FALSE if the table is empty. */ +bool Curl_uint32_tbl_first(struct uint32_tbl *tbl, + uint32_t *pkey, void **pentry); + +/* Get the next key in the table, following `last_key` in natural order. + * Put another way, this is the smallest key greater than `last_key` in + * the table. `last_key` does not have to be present in the table. + * + * Returns FALSE when no such entry is in the table. + * + * This allows to iterate the table while being modified: + * - added keys higher than 'last_key' will be picked up by the iteration. + * - added keys lower than 'last_key' will not show up. + * - removed keys lower or equal to 'last_key' will not show up. + * - removed keys higher than 'last_key' will not be visited. */ +bool Curl_uint32_tbl_next(struct uint32_tbl *tbl, uint32_t last_key, + uint32_t *pkey, void **pentry); + +#endif /* HEADER_CURL_UINT_TABLE_H */ diff --git a/3rdparty/curl-8.21.0/lib/url.c b/3rdparty/curl-8.21.0/lib/url.c new file mode 100644 index 0000000000..505e08a7e1 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/url.c @@ -0,0 +1,2656 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETDB_H +#include +#endif +#ifdef HAVE_ARPA_INET_H +#include +#endif +#ifdef HAVE_NET_IF_H +#include +#endif +#ifdef HAVE_IPHLPAPI_H +#include +#endif +#ifdef HAVE_SYS_IOCTL_H +#include +#endif +#ifdef HAVE_SYS_PARAM_H +#include +#endif + +#ifdef __VMS +#include +#include +#endif + +#ifdef HAVE_SYS_UN_H +#include +#endif + +#ifndef HAVE_SOCKET +#error "We cannot compile without socket() support!" +#endif + +#if defined(HAVE_IF_NAMETOINDEX) && defined(USE_WINSOCK) +#if defined(__MINGW32__) && (__MINGW64_VERSION_MAJOR <= 5) +#include /* workaround for old mingw-w64 missing to include it */ +#endif +#include +#endif + +#include "urldata.h" +#include "mime.h" +#include "bufref.h" +#include "vtls/vtls.h" +#include "vssh/vssh.h" +#include "hostip.h" +#include "transfer.h" +#include "curl_addrinfo.h" +#include "curl_trc.h" +#include "progress.h" +#include "cookie.h" +#include "strcase.h" +#include "escape.h" +#include "curl_share.h" +#include "http_digest.h" +#include "multiif.h" +#include "getinfo.h" +#include "pop3.h" +#include "urlapi-int.h" +#include "system_win32.h" +#include "hsts.h" +#include "proxy.h" +#include "cfilters.h" +#include "idn.h" +#include "http_proxy.h" +#include "conncache.h" +#include "multihandle.h" +#include "curlx/strdup.h" +#include "setopt.h" +#include "altsvc.h" +#include "curlx/dynbuf.h" +#include "headers.h" +#include "curlx/strerr.h" +#include "curlx/strparse.h" +#include "peer.h" + +/* Now for the protocols */ +#include "ftp.h" +#include "dict.h" +#include "telnet.h" +#include "tftp.h" +#include "http.h" +#include "vauth/vauth.h" +#include "file.h" +#include "curl_ldap.h" +#include "vssh/ssh.h" +#include "imap.h" +#include "url.h" +#include "connect.h" +#include "gopher.h" +#include "mqtt.h" +#include "rtsp.h" +#include "smtp.h" +#include "ws.h" + +/* Some parts of the code (e.g. chunked encoding) assume this buffer has more + * than a few bytes to play with. Do not let it become too small or bad things + * will happen. + */ +#if READBUFFER_SIZE < READBUFFER_MIN +# error READBUFFER_SIZE is too small +#endif + +/* + * get_protocol_family() + * + * This is used to return the protocol family for a given protocol. + * + * Parameters: + * + * 's' [in] - struct Curl_scheme pointer. + * + * Returns the family as a single bit protocol identifier. + */ +static curl_prot_t get_protocol_family(const struct Curl_scheme *s) +{ + DEBUGASSERT(s); + DEBUGASSERT(s->family); + return s->family; +} + +void Curl_freeset(struct Curl_easy *data) +{ + /* Free all dynamic strings stored in the data->set substructure. */ + enum dupstring i; + enum dupblob j; + + for(i = (enum dupstring)0; i < STRING_LAST; i++) { + curlx_safefree(data->set.str[i]); + } + + for(j = (enum dupblob)0; j < BLOB_LAST; j++) { + curlx_safefree(data->set.blobs[j]); + } + + Curl_bufref_free(&data->state.referer); + Curl_bufref_free(&data->state.url); + +#if !defined(CURL_DISABLE_MIME) || !defined(CURL_DISABLE_FORM_API) + Curl_mime_cleanpart(data->set.mimepostp); + curlx_safefree(data->set.mimepostp); +#endif + +#ifndef CURL_DISABLE_COOKIES + curl_slist_free_all(data->state.cookielist); + data->state.cookielist = NULL; +#endif +} + +/* free the URL pieces */ +static void up_free(struct Curl_easy *data) +{ + struct urlpieces *up = &data->state.up; + curlx_safefree(up->scheme); + curlx_safefree(up->hostname); + curlx_safefree(up->port); + curlx_safefree(up->user); + curlx_safefree(up->password); + curlx_safefree(up->options); + curlx_safefree(up->path); + curlx_safefree(up->query); + curl_url_cleanup(data->state.uh); + data->state.uh = NULL; +} + +/* + * This is the internal function curl_easy_cleanup() calls. This should + * cleanup and free all resources associated with this sessionhandle. + * + * We ignore SIGPIPE when this is called from curl_easy_cleanup. + */ + +CURLcode Curl_close(struct Curl_easy **datap) +{ + struct Curl_easy *data; + + if(!datap || !*datap) + return CURLE_OK; + + data = *datap; + *datap = NULL; + + if(!data->state.internal && data->multi) { + /* This handle is still part of a multi handle, take care of this first + and detach this handle from there. + This detaches the connection. */ + curl_multi_remove_handle(data->multi, data); + } + else { + /* Detach connection if any is left. This should not be normal, but can be + the case for example with CONNECT_ONLY + recv/send (test 556) */ + Curl_detach_connection(data); + if(!data->state.internal && data->multi_easy) { + /* when curl_easy_perform() is used, it creates its own multi handle to + use and this is the one */ + curl_multi_cleanup(data->multi_easy); + data->multi_easy = NULL; + } + } + DEBUGASSERT(!data->conn || data->state.internal); + + Curl_expire_clear(data); /* shut off any timers left */ + + if(data->state.rangestringalloc) + curlx_free(data->state.range); + + /* release any resolve information this transfer kept */ + Curl_resolv_destroy_all(data); + + data->set.verbose = FALSE; /* no more calls to DEBUGFUNCTION */ + data->magic = 0; /* force a clear AFTER the possibly enforced removal from + * the multi handle and async dns shutdown. The multi + * handle might check the magic and so might any + * DEBUGFUNCTION invoked for tracing */ + + /* freed here in case DONE was not called */ + Curl_req_free(&data->req, data); + + /* Close down all open SSL info and sessions */ + Curl_ssl_close_all(data); + Curl_peer_unlink(&data->state.origin); + Curl_peer_unlink(&data->state.initial_origin); + Curl_ssl_free_certinfo(data); + + Curl_bufref_free(&data->state.referer); + + up_free(data); + curlx_dyn_free(&data->state.headerb); + Curl_flush_cookies(data, TRUE); +#ifndef CURL_DISABLE_ALTSVC + Curl_altsvc_save(data, data->asi, data->set.str[STRING_ALTSVC]); + Curl_altsvc_cleanup(&data->asi); +#endif +#ifndef CURL_DISABLE_HSTS + Curl_hsts_save(data, data->hsts, data->set.str[STRING_HSTS]); + if(!data->share || !data->share->hsts) + Curl_hsts_cleanup(&data->hsts); + curl_slist_free_all(data->state.hstslist); /* clean up list */ +#endif +#if !defined(CURL_DISABLE_HTTP) && !defined(CURL_DISABLE_DIGEST_AUTH) + Curl_http_auth_cleanup_digest(data); +#endif + curlx_safefree(data->state.most_recent_ftp_entrypath); + curlx_safefree(data->info.contenttype); + curlx_safefree(data->info.wouldredirect); + + /* No longer a dirty share, if it exists */ + if(Curl_share_easy_unlink(data)) + DEBUGASSERT(0); + + Curl_hash_destroy(&data->meta_hash); + Curl_creds_unlink(&data->state.creds); + curlx_safefree(data->state.aptr.uagent); + curlx_safefree(data->state.aptr.accept_encoding); + curlx_safefree(data->state.aptr.rangeline); + curlx_safefree(data->state.aptr.ref); + curlx_safefree(data->state.aptr.host); +#ifndef CURL_DISABLE_COOKIES + curlx_safefree(data->req.cookiehost); +#endif +#ifndef CURL_DISABLE_RTSP + curlx_safefree(data->state.aptr.rtsp_transport); +#endif + +#if !defined(CURL_DISABLE_HTTP) && !defined(CURL_DISABLE_FORM_API) + Curl_mime_cleanpart(data->state.formp); + curlx_safefree(data->state.formp); +#endif + + /* destruct wildcard structures if it is needed */ + Curl_wildcard_dtor(&data->wildcard); + Curl_freeset(data); + Curl_headers_cleanup(data); + Curl_netrc_cleanup(&data->state.netrc); +#ifndef CURL_DISABLE_DIGEST_AUTH + curlx_free(data->state.envproxy); +#endif + Curl_ssl_config_cleanup(&data->set.ssl.primary); +#ifndef CURL_DISABLE_PROXY + Curl_ssl_config_cleanup(&data->set.proxy_ssl.primary); +#endif + curlx_free(data); + return CURLE_OK; +} + +/* + * Initialize the UserDefined fields within a Curl_easy. + * This may be safely called on a new or existing Curl_easy. + */ +void Curl_init_userdefined(struct Curl_easy *data) +{ + struct UserDefined *set = &data->set; + + set->out = stdout; /* default output to stdout */ + set->in_set = stdin; /* default input from stdin */ + set->err = stderr; /* default stderr to stderr */ + +#if defined(__clang__) && __clang_major__ >= 16 +#pragma clang diagnostic push +#pragma clang diagnostic ignored "-Wcast-function-type-strict" +#endif + /* use fwrite as default function to store output */ + set->fwrite_func = (curl_write_callback)fwrite; + + /* use fread as default function to read input */ + set->fread_func_set = (curl_read_callback)fread; +#if defined(__clang__) && __clang_major__ >= 16 +#pragma clang diagnostic pop +#endif + set->is_fread_set = 0; + + set->seek_client = ZERO_NULL; + + set->filesize = -1; /* we do not know the size */ + set->postfieldsize = -1; /* unknown size */ + set->maxredirs = 30; /* sensible default */ + + set->method = HTTPREQ_GET; /* Default HTTP request */ +#ifndef CURL_DISABLE_RTSP + set->rtspreq = RTSPREQ_OPTIONS; /* Default RTSP request */ +#endif +#ifndef CURL_DISABLE_FTP + set->ftp_use_epsv = TRUE; /* FTP defaults to EPSV operations */ + set->ftp_use_eprt = TRUE; /* FTP defaults to EPRT operations */ + set->ftp_use_pret = FALSE; /* mainly useful for drftpd servers */ + set->ftp_filemethod = FTPFILE_MULTICWD; + set->ftp_skip_ip = TRUE; /* skip PASV IP by default */ +#endif + set->dns_cache_timeout_ms = 60000; /* Timeout every 60 seconds by default */ + + /* Timeout every 24 hours by default */ + set->general_ssl.ca_cache_timeout = 24 * 60 * 60; + + set->httpauth = CURLAUTH_BASIC; /* defaults to basic */ + + Curl_ssl_config_init(&data->set.ssl.primary); +#ifndef CURL_DISABLE_PROXY + Curl_ssl_config_init(&data->set.proxy_ssl.primary); + set->proxyport = 0; + set->proxytype = CURLPROXY_HTTP; /* defaults to HTTP proxy */ + set->proxyauth = CURLAUTH_BASIC; /* defaults to basic */ + /* SOCKS5 proxy auth defaults to username/password + GSS-API */ + set->socks5auth = CURLAUTH_BASIC | CURLAUTH_GSSAPI; +#endif + +#ifndef CURL_DISABLE_DOH + set->doh_verifyhost = TRUE; + set->doh_verifypeer = TRUE; +#endif +#ifdef USE_SSH + /* defaults to any auth type */ + set->ssh_auth_types = CURLSSH_AUTH_DEFAULT; + set->new_directory_perms = 0755; /* Default permissions */ +#endif + + set->new_file_perms = 0644; /* Default permissions */ + set->allowed_protocols = (curl_prot_t)CURLPROTO_64ALL; + set->redir_protocols = CURLPROTO_REDIR; + +#if defined(HAVE_GSSAPI) || defined(USE_WINDOWS_SSPI) + /* + * disallow unprotected protection negotiation NEC reference implementation + * seem not to follow rfc1961 section 4.3/4.4 + */ + set->socks5_gssapi_nec = FALSE; +#endif + + /* set default minimum TLS version */ +#ifdef USE_SSL + Curl_setopt_SSLVERSION(data, CURLOPT_SSLVERSION, CURL_SSLVERSION_DEFAULT); +#ifndef CURL_DISABLE_PROXY + Curl_setopt_SSLVERSION(data, CURLOPT_PROXY_SSLVERSION, + CURL_SSLVERSION_DEFAULT); +#endif +#endif +#ifndef CURL_DISABLE_FTP + set->wildcard_enabled = FALSE; + set->chunk_bgn = ZERO_NULL; + set->chunk_end = ZERO_NULL; + set->fnmatch = ZERO_NULL; +#endif + set->tcp_keepalive = FALSE; + set->tcp_keepintvl = 60; + set->tcp_keepidle = 60; + set->tcp_keepcnt = 9; + set->tcp_fastopen = FALSE; + set->tcp_nodelay = TRUE; + set->ssl_enable_alpn = TRUE; + set->expect_100_timeout = 1000L; /* Wait for a second by default. */ + set->sep_headers = TRUE; /* separated header lists by default */ + set->buffer_size = READBUFFER_SIZE; + set->upload_buffer_size = UPLOADBUFFER_DEFAULT; + set->upload_flags = CURLULFLAG_SEEN; + set->happy_eyeballs_timeout = CURL_HET_DEFAULT; + set->upkeep_interval_ms = CURL_UPKEEP_INTERVAL_DEFAULT; + set->maxconnects = DEFAULT_CONNCACHE_SIZE; /* for easy handles */ + set->conn_max_idle_ms = 118 * 1000; + set->conn_max_age_ms = 24 * 3600 * 1000; + set->http09_allowed = FALSE; + set->httpwant = CURL_HTTP_VERSION_NONE; +#if defined(USE_HTTP2) || defined(USE_HTTP3) + memset(&set->priority, 0, sizeof(set->priority)); +#endif + set->quick_exit = 0L; +#ifndef CURL_DISABLE_WEBSOCKETS + set->ws_raw_mode = FALSE; + set->ws_no_auto_pong = FALSE; +#endif +} + +/* easy->meta_hash destructor. Should never be called as elements + * MUST be added with their own destructor */ +static void easy_meta_freeentry(void *p) +{ + (void)p; + /* Always FALSE. Cannot use a 0 assert here since compilers + * are not in agreement if they then want a NORETURN attribute or + * not. *sigh* */ + DEBUGASSERT(!p); +} + +/** + * Curl_open() + * + * @param curl is a pointer to a sessionhandle pointer that gets set by this + * function. + * @return CURLcode + */ + +CURLcode Curl_open(struct Curl_easy **curl) +{ + struct Curl_easy *data; + + /* simple start-up: alloc the struct, init it with zeroes and return */ + data = curlx_calloc(1, sizeof(struct Curl_easy)); + if(!data) { + /* this is a serious error */ + DEBUGF(curl_mfprintf(stderr, "Error: calloc of Curl_easy failed\n")); + return CURLE_OUT_OF_MEMORY; + } + + data->magic = CURLEASY_MAGIC_NUMBER; + /* most recent connection is not yet defined */ + data->state.lastconnect_id = -1; + data->state.recent_conn_id = -1; + /* and not assigned an id yet */ + data->id = -1; + data->mid = UINT32_MAX; + data->master_mid = UINT32_MAX; + data->progress.hide = TRUE; + data->state.current_speed = -1; /* init to negative == impossible */ + + Curl_hash_init(&data->meta_hash, 23, + Curl_hash_str, curlx_str_key_compare, easy_meta_freeentry); + curlx_dyn_init(&data->state.headerb, CURL_MAX_HTTP_HEADER); + Curl_bufref_init(&data->state.url); + Curl_bufref_init(&data->state.referer); + Curl_req_init(&data->req); + Curl_initinfo(data); +#ifndef CURL_DISABLE_HTTP + Curl_llist_init(&data->state.httphdrs, NULL); +#endif + Curl_netrc_init(&data->state.netrc); + Curl_init_userdefined(data); + + *curl = data; + return CURLE_OK; +} + +void Curl_conn_free(struct Curl_easy *data, struct connectdata *conn) +{ + size_t i; + + DEBUGASSERT(conn); + + if(conn->scheme && conn->scheme->run->disconnect && + !conn->bits.shutdown_handler) + conn->scheme->run->disconnect(data, conn, TRUE); + + for(i = 0; i < CURL_ARRAYSIZE(conn->cfilter); ++i) { + Curl_conn_cf_discard_all(data, conn, (int)i); + } + +#ifndef CURL_DISABLE_PROXY + Curl_peer_unlink(&conn->http_proxy.peer); + Curl_peer_unlink(&conn->socks_proxy.peer); + Curl_creds_unlink(&conn->http_proxy.creds); + Curl_creds_unlink(&conn->socks_proxy.creds); +#endif + Curl_creds_unlink(&conn->creds); + Curl_peer_unlink(&conn->creds_origin); + curlx_safefree(conn->options); + curlx_safefree(conn->localdev); + Curl_ssl_conn_config_cleanup(conn); + + curlx_safefree(conn->destination); + Curl_hash_destroy(&conn->meta_hash); + Curl_peer_unlink(&conn->origin); + Curl_peer_unlink(&conn->via_peer); + Curl_peer_unlink(&conn->origin2); + Curl_peer_unlink(&conn->via_peer2); + + curlx_free(conn); /* free all the connection oriented data */ +} + +/* + * xfer_may_multiplex() + * + * Return a TRUE, iff the transfer can be done over an (appropriate) + * multiplexed connection. + */ +static bool xfer_may_multiplex(const struct Curl_easy *data, + const struct connectdata *conn) +{ +#ifndef CURL_DISABLE_HTTP + /* If an HTTP protocol and multiplexing is enabled */ + if((conn->scheme->protocol & PROTO_FAMILY_HTTP) && + (!conn->bits.protoconnstart || !conn->bits.close)) { + + if(Curl_multiplex_wanted(data->multi) && + (data->state.http_neg.allowed & (CURL_HTTP_V2x | CURL_HTTP_V3x))) + /* allows HTTP/2 or newer */ + return TRUE; + } +#else + (void)data; + (void)conn; +#endif + return FALSE; +} + +#ifndef CURL_DISABLE_PROXY +static bool proxy_info_matches(const struct proxy_info *data, + const struct proxy_info *needle) +{ + if((data->proxytype == needle->proxytype) && + Curl_peer_same_destination(data->peer, needle->peer) && + Curl_creds_same(data->creds, needle->creds)) { + return TRUE; + } + return FALSE; +} +#endif + +/* A connection has to have been idle for less than 'conn_max_idle_ms' + (the success rate is too low after this), or created less than + 'conn_max_age_ms' ago, to be subject for reuse. */ +static bool conn_maxage(struct Curl_easy *data, + struct connectdata *conn, + struct curltime now) +{ + timediff_t age_ms; + + if(data->set.conn_max_idle_ms) { + age_ms = curlx_ptimediff_ms(&now, &conn->lastused); + if(age_ms > data->set.conn_max_idle_ms) { + infof(data, "Too old connection (%" FMT_TIMEDIFF_T + " ms idle, max idle is %" FMT_TIMEDIFF_T " ms), disconnect it", + age_ms, data->set.conn_max_idle_ms); + return TRUE; + } + } + + if(data->set.conn_max_age_ms) { + age_ms = curlx_ptimediff_ms(&now, &conn->created); + if(age_ms > data->set.conn_max_age_ms) { + infof(data, + "Too old connection (created %" FMT_TIMEDIFF_T + " ms ago, max lifetime is %" FMT_TIMEDIFF_T " ms), disconnect it", + age_ms, data->set.conn_max_age_ms); + return TRUE; + } + } + + return FALSE; +} + +/* + * Return TRUE iff the given connection is considered dead. + */ +bool Curl_conn_seems_dead(struct connectdata *conn, + struct Curl_easy *data) +{ + DEBUGASSERT(!data->conn); + if(!CONN_INUSE(conn)) { + /* The check for a dead socket makes sense only if the connection is not in + use */ + bool dead; + + if(conn_maxage(data, conn, *Curl_pgrs_now(data))) { + /* avoid check if already too old */ + dead = TRUE; + } + else if(conn->scheme->run->connection_is_dead) { + /* The protocol has a special method for checking the state of the + connection. Use it to check if the connection is dead. */ + /* briefly attach the connection for the check */ + Curl_attach_connection(data, conn); + dead = conn->scheme->run->connection_is_dead(data, conn); + Curl_detach_connection(data); + } + else { + bool input_pending = FALSE; + + Curl_attach_connection(data, conn); + dead = !Curl_conn_is_alive(data, conn, &input_pending); + if(input_pending) { + /* For reuse, we want a "clean" connection state. This includes + * that we expect - in general - no waiting input data. Input + * waiting might be a TLS Notify Close, for example. We reject + * that. + * For protocols where data from other end may arrive at + * any time (HTTP/2 PING for example), the protocol handler needs + * to install its own `connection_check` callback. + */ + DEBUGF(infof(data, "connection has input pending, not reusable")); + dead = TRUE; + } + Curl_detach_connection(data); + } + + if(dead) { + /* remove connection from cpool */ + infof(data, "Connection %" FMT_OFF_T " seems to be dead", + conn->connection_id); + return TRUE; + } + } + return FALSE; +} + +CURLcode Curl_conn_upkeep(struct Curl_easy *data, + struct connectdata *conn) +{ + CURLcode result = CURLE_OK; + if(curlx_ptimediff_ms(Curl_pgrs_now(data), &conn->keepalive) <= + data->set.upkeep_interval_ms) + return result; + + /* briefly attach for action */ + Curl_attach_connection(data, conn); + result = Curl_conn_keep_alive(data, conn, FIRSTSOCKET); + Curl_detach_connection(data); + + conn->keepalive = *Curl_pgrs_now(data); + return result; +} + +#ifdef USE_SSH +static bool ssh_config_matches(struct connectdata *one, + struct connectdata *two) +{ + struct ssh_conn *sshc1, *sshc2; + + sshc1 = Curl_conn_meta_get(one, CURL_META_SSH_CONN); + sshc2 = Curl_conn_meta_get(two, CURL_META_SSH_CONN); + return sshc1 && sshc2 && Curl_safecmp(sshc1->rsa, sshc2->rsa) && + Curl_safecmp(sshc1->rsa_pub, sshc2->rsa_pub); +} +#endif + +struct url_conn_match { + struct connectdata *found; + struct Curl_easy *data; + struct connectdata *needle; + BIT(may_multiplex); + BIT(want_ntlm_http); + BIT(want_proxy_ntlm_http); + BIT(want_nego_http); + BIT(want_proxy_nego_http); + BIT(may_tls); /* May upgrade clear-text connection to TLS, can only reuse + * connections that have matching TLS configuration. + * Always TRUE if `req_tls` is TRUE. */ + BIT(require_tls); /* Requires TLS use from a clear-text start, can only + * reuse connections that have TLS. */ + BIT(wait_pipe); + BIT(force_reuse); + BIT(seen_pending_conn); + BIT(seen_single_use_conn); + BIT(seen_multiplex_conn); +}; + +static bool url_match_connect_config(struct connectdata *conn, + struct url_conn_match *m) +{ + /* connect-only or to-be-closed connections will not be reused */ + if(conn->bits.connect_only || conn->bits.close || conn->bits.no_reuse) + return FALSE; + + /* ip_version must match */ + if(m->data->set.ipver != CURL_IPRESOLVE_WHATEVER && + m->data->set.ipver != conn->ip_version) + return FALSE; + + if(m->needle->localdev || m->needle->localport) { + /* If we are bound to a specific local end (IP+port), we must not reuse a + random other one, although if we did not ask for a particular one we + can reuse one that was bound. + + This comparison is a bit rough and too strict. Since the input + parameters can be specified in numerous ways and still end up the same + it would take a lot of processing to make it really accurate. Instead, + this matching will assume that reuses of bound connections will most + likely also reuse the exact same binding parameters and missing out a + few edge cases should not hurt anyone much. + */ + if((conn->localport != m->needle->localport) || + (conn->localportrange != m->needle->localportrange) || + (m->needle->localdev && + (!conn->localdev || strcmp(conn->localdev, m->needle->localdev)))) + return FALSE; + } + + if(!m->needle->via_peer != !conn->via_peer) + /* do not mix connections that use the "connect to host" feature and + * connections that do not use this feature */ + return FALSE; + + return TRUE; +} + +static bool url_match_fully_connected(struct connectdata *conn, + struct url_conn_match *m) +{ + if(!Curl_conn_is_connected(conn, FIRSTSOCKET) || + conn->bits.upgrade_in_progress) { + /* Not yet connected, or a protocol upgrade is in progress. The later + * happens for HTTP/2 Upgrade: requests that need a response. */ + if(m->may_multiplex) { + m->seen_pending_conn = TRUE; + /* Do not pick a connection that has not connected yet */ + infof(m->data, "Connection #%" FMT_OFF_T + " is not open enough, cannot reuse", conn->connection_id); + } + /* Do not pick a connection that has not connected yet */ + return FALSE; + } + return TRUE; +} + +static bool url_match_multi(struct connectdata *conn, + struct url_conn_match *m) +{ + if(CONN_INUSE(conn)) { + DEBUGASSERT(conn->attached_multi); + if(conn->attached_multi != m->data->multi) + return FALSE; + } + return TRUE; +} + +static bool url_match_multiplex_needs(struct connectdata *conn, + struct url_conn_match *m) +{ + if(CONN_INUSE(conn)) { + if(!conn->bits.multiplex) { + /* conn busy and conn cannot take more transfers */ + m->seen_single_use_conn = TRUE; + return FALSE; + } + m->seen_multiplex_conn = TRUE; + if(!m->may_multiplex || !url_match_multi(conn, m)) + /* conn busy and transfer cannot be multiplexed */ + return FALSE; + } + return TRUE; +} + +static bool url_match_multiplex_limits(struct connectdata *conn, + struct url_conn_match *m) +{ + if(CONN_INUSE(conn) && m->may_multiplex) { + DEBUGASSERT(conn->bits.multiplex); + /* If multiplexed, make sure we do not go over concurrency limit */ + if(conn->attached_xfers >= + Curl_multi_max_concurrent_streams(m->data->multi)) { + infof(m->data, "client side MAX_CONCURRENT_STREAMS reached" + ", skip (%u)", conn->attached_xfers); + return FALSE; + } + if(conn->attached_xfers >= + Curl_conn_get_max_concurrent(m->data, conn, FIRSTSOCKET)) { + infof(m->data, "MAX_CONCURRENT_STREAMS reached, skip (%u)", + conn->attached_xfers); + return FALSE; + } + /* When not multiplexed, we have a match here! */ + infof(m->data, "Multiplexed connection found"); + } + return TRUE; +} + +static bool url_match_ssl_use(struct connectdata *conn, + struct url_conn_match *m) +{ + if(m->needle->scheme->flags & PROTOPT_SSL) { + /* We are looking for SSL, if `conn` does not do it, not a match. */ + if(!Curl_conn_is_ssl(conn, FIRSTSOCKET)) + return FALSE; + } + else if(Curl_conn_is_ssl(conn, FIRSTSOCKET)) { + /* If the protocol does not allow reuse of SSL connections OR + is of another protocol family, not a match. */ + if(!(m->needle->scheme->flags & PROTOPT_SSL_REUSE) || + (get_protocol_family(conn->scheme) != m->needle->scheme->protocol)) + return FALSE; + } + else if(m->require_tls) + /* a clear-text STARTTLS protocol with required TLS */ + return FALSE; + return TRUE; +} + +#ifndef CURL_DISABLE_PROXY +static bool url_match_proxy_use(struct connectdata *conn, + struct url_conn_match *m) +{ + if(m->needle->bits.origin_is_proxy != conn->bits.origin_is_proxy) + return FALSE; + + if(!proxy_info_matches(&m->needle->socks_proxy, &conn->socks_proxy)) + return FALSE; + + if(!proxy_info_matches(&m->needle->http_proxy, &conn->http_proxy)) + return FALSE; + + if(CURL_PROXY_IS_HTTPS(m->needle->http_proxy.proxytype)) { + /* https proxies come in different types, http/1.1, h2, ... */ + /* match SSL config to proxy */ + if(!Curl_ssl_conn_config_match(m->data, conn, TRUE)) { + DEBUGF(infof(m->data, + "Connection #%" FMT_OFF_T + " has different SSL proxy parameters, cannot reuse", + conn->connection_id)); + return FALSE; + } + /* the SSL config to the server, which may apply here is checked + * further below */ + } + return TRUE; +} +#else +#define url_match_proxy_use(c, m) ((void)(c), (void)(m), TRUE) +#endif + +#ifndef CURL_DISABLE_HTTP +static bool url_match_http_multiplex(struct connectdata *conn, + struct url_conn_match *m) +{ + if(m->may_multiplex && + (m->data->state.http_neg.allowed & (CURL_HTTP_V2x | CURL_HTTP_V3x)) && + (m->needle->scheme->protocol & CURLPROTO_HTTP) && + !conn->httpversion_seen) { + if(m->data->set.pipewait) { + infof(m->data, "Server upgrade does not support multiplex yet, wait"); + m->found = NULL; + m->wait_pipe = TRUE; + return TRUE; /* stop searching, we want to wait */ + } + infof(m->data, "Server upgrade cannot be used"); + return FALSE; + } + return TRUE; +} + +static bool url_match_http_version(struct connectdata *conn, + struct url_conn_match *m) +{ + /* If looking for HTTP and the HTTP versions allowed do not include + * the HTTP version of conn, continue looking. */ + if((m->needle->scheme->protocol & PROTO_FAMILY_HTTP)) { + switch(Curl_conn_http_version(m->data, conn)) { + case 30: + if(!(m->data->state.http_neg.allowed & CURL_HTTP_V3x)) { + DEBUGF(infof(m->data, "not reusing conn #%" CURL_FORMAT_CURL_OFF_T + ", we do not want h3", conn->connection_id)); + return FALSE; + } + break; + case 20: + if(!(m->data->state.http_neg.allowed & CURL_HTTP_V2x)) { + DEBUGF(infof(m->data, "not reusing conn #%" CURL_FORMAT_CURL_OFF_T + ", we do not want h2", conn->connection_id)); + return FALSE; + } + break; + default: + if(!(m->data->state.http_neg.allowed & CURL_HTTP_V1x)) { + DEBUGF(infof(m->data, "not reusing conn #%" CURL_FORMAT_CURL_OFF_T + ", we do not want h1", conn->connection_id)); + return FALSE; + } + break; + } + } + return TRUE; +} +#else +#define url_match_http_multiplex(c, m) ((void)(c), (void)(m), TRUE) +#define url_match_http_version(c, m) ((void)(c), (void)(m), TRUE) +#endif + +static bool url_match_proto_config(struct connectdata *conn, + struct url_conn_match *m) +{ + if(!url_match_http_version(conn, m)) + return FALSE; + +#ifdef USE_SSH + if(get_protocol_family(m->needle->scheme) & PROTO_FAMILY_SSH) { + if(!ssh_config_matches(m->needle, conn)) + return FALSE; + } +#endif +#ifndef CURL_DISABLE_FTP + else if(get_protocol_family(m->needle->scheme) & PROTO_FAMILY_FTP) { + if(!ftp_conns_match(m->needle, conn)) + return FALSE; + } +#endif + return TRUE; +} + +static bool url_match_auth(struct connectdata *conn, + struct url_conn_match *m) +{ + if(!Curl_creds_same(m->needle->creds, conn->creds)) { + if(m->needle->creds) + return FALSE; + if(!Curl_creds_same(m->data->state.creds, conn->creds)) + return FALSE; + } +#if defined(HAVE_GSSAPI) || defined(USE_WINDOWS_SSPI) + /* GSS delegation differences do not actually affect every connection and + auth method, but this check takes precaution before efficiency */ + if(m->needle->gssapi_delegation != conn->gssapi_delegation) + return FALSE; +#endif + + return TRUE; +} + +static bool url_match_destination(struct connectdata *conn, + struct url_conn_match *m) +{ + /* Different connect-to peers never match */ + if(!Curl_peer_same_destination(m->needle->via_peer, conn->via_peer)) + return FALSE; + + if(m->needle->origin->scheme != conn->origin->scheme) { + /* `needle` and `conn` not having the same scheme. + * This is allowed for the same family *if* conn is using TLS. + * - IMAP+STARTTLS works for IMAPS. + * - IMAPS works for IMAP. */ + if(get_protocol_family(conn->origin->scheme) != + m->needle->scheme->protocol) { + return FALSE; + } + } + /* Scheme mismatch is acceptable, compare hostname/port */ + return Curl_peer_same_destination(m->needle->origin, conn->origin); +} + +static bool url_match_ssl_config(struct connectdata *conn, + struct url_conn_match *m) +{ + /* If talking/upgrading to TLS, conn needs to use the same SSL options. */ + if(((m->needle->scheme->flags & PROTOPT_SSL) || m->may_tls) && + !Curl_ssl_conn_config_match(m->data, conn, FALSE)) { + DEBUGF(infof(m->data, "Connection #%" FMT_OFF_T + " has different SSL parameters, cannot reuse", + conn->connection_id)); + return FALSE; + } + return TRUE; +} + +#ifdef USE_NTLM +static bool url_match_auth_ntlm(struct connectdata *conn, + struct url_conn_match *m) +{ + /* If we are looking for an HTTP+NTLM connection, check if this is + already authenticating with the right credentials. If not, keep + looking so that we can reuse NTLM connections if + possible. (Especially we must not reuse the same connection if + partway through a handshake!) */ + if(m->want_ntlm_http) { + if(conn->creds && + (!Curl_creds_same(conn->creds, m->data->state.creds) || + !Curl_peer_equal(conn->creds_origin, m->data->state.origin))) { + /* connection credentials in play and not the same or not for the + * same origin. */ + return FALSE; + } + } + else if(conn->http_ntlm_state != NTLMSTATE_NONE) { + /* Connection is using NTLM auth but we do not want NTLM */ + return FALSE; + } + +#ifndef CURL_DISABLE_PROXY + /* Same for Proxy NTLM authentication */ + if(m->want_proxy_ntlm_http) { + /* Both conn->http_proxy.user and conn->http_proxy.passwd can be + * NULL */ + if(!conn->http_proxy.creds) + return FALSE; + + if(!Curl_creds_same(m->needle->http_proxy.creds, conn->http_proxy.creds)) + return FALSE; + } + else if(conn->proxy_ntlm_state != NTLMSTATE_NONE) { + /* Proxy connection is using NTLM auth but we do not want NTLM */ + return FALSE; + } +#endif + if(m->want_ntlm_http || m->want_proxy_ntlm_http) { + /* Credentials are already checked, we may use this connection. + * With NTLM being weird as it is, we MUST use a + * connection where it has already been fully negotiated. + * If it has not, we keep on looking for a better one. */ + m->found = conn; + + if((m->want_ntlm_http && + (conn->http_ntlm_state != NTLMSTATE_NONE)) || + (m->want_proxy_ntlm_http && + (conn->proxy_ntlm_state != NTLMSTATE_NONE))) { + /* We must use this connection, no other */ + m->force_reuse = TRUE; + return TRUE; + } + /* Continue look up for a better connection */ + return FALSE; + } + return TRUE; +} +#else +#define url_match_auth_ntlm(c, m) ((void)(c), (void)(m), TRUE) +#endif + +#ifdef USE_SPNEGO +static bool url_match_auth_nego(struct connectdata *conn, + struct url_conn_match *m) +{ + /* If we are looking for an HTTP+Negotiate connection, check if this is + already authenticating with the right credentials. If not, keep looking + so that we can reuse Negotiate connections if possible. */ + if(m->want_nego_http) { + if(conn->creds && + (!Curl_creds_same(conn->creds, m->data->state.creds) || + !Curl_peer_equal(conn->creds_origin, m->data->state.origin))) + return FALSE; + } + else if(conn->http_negotiate_state != GSS_AUTHNONE) { + /* Connection is using Negotiate auth but we do not want Negotiate */ + return FALSE; + } + +#ifndef CURL_DISABLE_PROXY + /* Same for Proxy Negotiate authentication */ + if(m->want_proxy_nego_http) { + /* Both conn->http_proxy.user and conn->http_proxy.passwd can be + * NULL */ + if(!conn->http_proxy.creds) + return FALSE; + + if(!Curl_creds_same(m->needle->http_proxy.creds, conn->http_proxy.creds)) + return FALSE; + } + else if(conn->proxy_negotiate_state != GSS_AUTHNONE) { + /* Proxy connection is using Negotiate auth but we do not want Negotiate */ + return FALSE; + } +#endif + if(m->want_nego_http || m->want_proxy_nego_http) { + /* Credentials are already checked, we may use this connection. We MUST + * use a connection where it has already been fully negotiated. If it has + * not, we keep on looking for a better one. */ + m->found = conn; + if((m->want_nego_http && + (conn->http_negotiate_state != GSS_AUTHNONE)) || + (m->want_proxy_nego_http && + (conn->proxy_negotiate_state != GSS_AUTHNONE))) { + /* We must use this connection, no other */ + m->force_reuse = TRUE; + return TRUE; + } + return FALSE; /* get another */ + } + return TRUE; +} +#else +#define url_match_auth_nego(c, m) ((void)(c), (void)(m), TRUE) +#endif + +static bool url_match_conn(struct connectdata *conn, void *userdata) +{ + struct url_conn_match *m = userdata; + /* Check if `conn` can be used for transfer `m->data` */ + + /* general connect config setting match? */ + if(!url_match_connect_config(conn, m)) + return FALSE; + + /* match for destination and protocol? */ + if(!url_match_destination(conn, m)) + return FALSE; + + if(!url_match_fully_connected(conn, m)) + return FALSE; + + if(!url_match_multiplex_needs(conn, m)) + return FALSE; + + if(!url_match_ssl_use(conn, m)) + return FALSE; + + if(!url_match_proxy_use(conn, m)) + return FALSE; + if(!url_match_ssl_config(conn, m)) + return FALSE; + + if(!url_match_http_multiplex(conn, m)) + return FALSE; + else if(m->wait_pipe) + /* we decided to wait on PIPELINING */ + return TRUE; + + if(!url_match_auth(conn, m)) + return FALSE; + + if(!url_match_proto_config(conn, m)) + return FALSE; + + if(!url_match_auth_ntlm(conn, m)) + return FALSE; + else if(m->force_reuse) + return TRUE; + + if(!url_match_auth_nego(conn, m)) + return FALSE; + else if(m->force_reuse) + return TRUE; + + if(!url_match_multiplex_limits(conn, m)) + return FALSE; + + if(!CONN_INUSE(conn) && Curl_conn_seems_dead(conn, m->data)) { + /* remove and disconnect. */ + Curl_conn_terminate(m->data, conn, FALSE); + return FALSE; + } + + /* conn matches our needs. */ + m->found = conn; + return TRUE; +} + +static bool url_match_result(void *userdata) +{ + struct url_conn_match *match = userdata; + if(match->found) { + /* Attach it now while still under lock, so the connection does + * no longer appear idle and can be reaped. */ + Curl_attach_connection(match->data, match->found); + return TRUE; + } + else if(match->seen_single_use_conn && !match->seen_multiplex_conn) { + /* We have seen a single-use, existing connection to the destination and + * no multiplexed one. It seems safe to assume that the server does + * not support multiplexing. */ + match->wait_pipe = FALSE; + } + else if(match->seen_pending_conn && match->data->set.pipewait) { + infof(match->data, + "Found pending candidate for reuse and CURLOPT_PIPEWAIT is set"); + match->wait_pipe = TRUE; + } + match->force_reuse = FALSE; + return FALSE; +} + +/* + * Given a transfer and a prototype connection (needle), + * find and attach an existing connection that matches. + * + * Return TRUE if an existing connection was attached. + * `waitpipe` is TRUE if no existing connection matched, but there + * might be suitable one in the near future (common cause: multiplexing + * capability has not been determined yet, e.g. ALPN handshake). + */ +static bool url_attach_existing(struct Curl_easy *data, + struct connectdata *needle, + bool *waitpipe) +{ + struct url_conn_match match; + bool success; + + DEBUGASSERT(!data->conn); + memset(&match, 0, sizeof(match)); + match.data = data; + match.needle = needle; + match.may_multiplex = xfer_may_multiplex(data, needle); + +#ifdef USE_NTLM + match.want_ntlm_http = + (data->state.authhost.want & CURLAUTH_NTLM) && + (needle->scheme->protocol & PROTO_FAMILY_HTTP); +#ifndef CURL_DISABLE_PROXY + match.want_proxy_ntlm_http = + needle->http_proxy.creds && + (data->state.authproxy.want & CURLAUTH_NTLM) && + (needle->scheme->protocol & PROTO_FAMILY_HTTP); +#endif +#endif + +#if !defined(CURL_DISABLE_HTTP) && defined(USE_SPNEGO) + match.want_nego_http = + (data->state.authhost.want & CURLAUTH_NEGOTIATE) && + (needle->scheme->protocol & PROTO_FAMILY_HTTP); +#ifndef CURL_DISABLE_PROXY + match.want_proxy_nego_http = + needle->http_proxy.creds && + (data->state.authproxy.want & CURLAUTH_NEGOTIATE) && + (needle->scheme->protocol & PROTO_FAMILY_HTTP); +#endif +#endif + match.require_tls = data->set.use_ssl >= CURLUSESSL_CONTROL; + match.may_tls = data->set.use_ssl > CURLUSESSL_NONE; + + /* Find a connection in the pool that matches what "data + needle" + * requires. If a suitable candidate is found, it is attached to "data". */ + success = Curl_cpool_find(data, needle->destination, + url_match_conn, url_match_result, &match); + + /* wait_pipe is TRUE if we encounter a bundle that is undecided. There + * is no matching connection then, yet. */ + *waitpipe = (bool)match.wait_pipe; + return success; +} + +/* + * Allocate and initialize a new connectdata object. + */ +static struct connectdata *allocate_conn(struct Curl_easy *data) +{ + struct connectdata *conn = curlx_calloc(1, sizeof(struct connectdata)); + if(!conn) + return NULL; + + /* and we setup a few fields in case we end up actually using this struct */ + + conn->sock[FIRSTSOCKET] = CURL_SOCKET_BAD; /* no file descriptor */ + conn->sock[SECONDARYSOCKET] = CURL_SOCKET_BAD; /* no file descriptor */ + conn->recv_idx = 0; /* default for receiving transfer data */ + conn->send_idx = 0; /* default for sending transfer data */ + conn->connection_id = -1; /* no ID */ + conn->attached_xfers = 0; + + /* Store creation time to help future close decision making */ + conn->created = *Curl_pgrs_now(data); + + /* Store current time to give a baseline to keepalive connection times. */ + conn->keepalive = conn->created; + +#ifndef CURL_DISABLE_FTP + conn->bits.ftp_use_epsv = data->set.ftp_use_epsv; + conn->bits.ftp_use_eprt = data->set.ftp_use_eprt; +#endif + conn->ip_version = data->set.ipver; + conn->bits.connect_only = (bool)data->set.connect_only; + conn->transport_wanted = TRNSPRT_TCP; /* most of them are TCP streams */ + + /* Store the local bind parameters that will be used for this connection */ + if(data->set.str[STRING_DEVICE]) { + conn->localdev = curlx_strdup(data->set.str[STRING_DEVICE]); + if(!conn->localdev) + goto error; + } +#ifndef CURL_DISABLE_BINDLOCAL + conn->localportrange = data->set.localportrange; + conn->localport = data->set.localport; +#endif + + /* the close socket stuff needs to be copied to the connection struct as + it may live on without (this specific) Curl_easy */ + conn->fclosesocket = data->set.fclosesocket; + conn->closesocket_client = data->set.closesocket_client; + conn->lastused = conn->created; +#if defined(HAVE_GSSAPI) || defined(USE_WINDOWS_SSPI) + conn->gssapi_delegation = data->set.gssapi_delegation; +#endif + return conn; +error: + + curlx_free(conn->localdev); + curlx_free(conn); + return NULL; +} + +static CURLcode url_set_conn_scheme(struct Curl_easy *data, + struct connectdata *conn, + const struct Curl_scheme *scheme) +{ + /* URL scheme is usable for connection when it is + * - allowed + * - not from a redirect or an allowed redirect protocol */ + if(scheme->run && + (data->set.allowed_protocols & scheme->protocol) && + (!data->state.this_is_a_follow || + (data->set.redir_protocols & scheme->protocol))) { + conn->scheme = conn->given = scheme; + return CURLE_OK; + } + if(scheme->flags & PROTOPT_NO_TRANSFER) + failf(data, "Protocol \"%s\" is not for transfers", scheme->name); + else + failf(data, "Protocol \"%s\" is disabled%s", scheme->name, + data->state.this_is_a_follow ? " (in redirect)" : ""); + return CURLE_UNSUPPORTED_PROTOCOL; +} + +CURLcode Curl_uc_to_curlcode(CURLUcode uc) +{ + switch(uc) { + default: + return CURLE_URL_MALFORMAT; + case CURLUE_UNSUPPORTED_SCHEME: + return CURLE_UNSUPPORTED_PROTOCOL; + case CURLUE_OUT_OF_MEMORY: + return CURLE_OUT_OF_MEMORY; + case CURLUE_USER_NOT_ALLOWED: + return CURLE_LOGIN_DENIED; + } +} + +#ifndef CURL_DISABLE_HSTS +static CURLcode hsts_upgrade(struct Curl_easy *data, + CURLU *uh, + uint16_t port_override, + uint32_t scope_id) +{ + /* HSTS upgrade */ + if(data->hsts && (data->state.origin->scheme == &Curl_scheme_http) && + Curl_hsts_applies(data->hsts, data->state.origin)) { + char *url; + CURLUcode uc; + CURLcode result; + + curlx_safefree(data->state.up.scheme); + uc = curl_url_set(uh, CURLUPART_SCHEME, "https", 0); + if(uc) + return Curl_uc_to_curlcode(uc); + Curl_bufref_free(&data->state.url); + /* after update, get the updated version */ + uc = curl_url_get(uh, CURLUPART_URL, &url, 0); + if(uc) + return Curl_uc_to_curlcode(uc); + Curl_bufref_set(&data->state.url, url, 0, curl_free); + + result = Curl_peer_from_url(uh, data, port_override, scope_id, + &data->state.up, &data->state.origin); + if(result) + return result; + infof(data, "Switched from HTTP to HTTPS due to HSTS => %s", url); + } + return CURLE_OK; +} +#else +#define hsts_upgrade(x, y, z, a) CURLE_OK +#endif + +#ifndef CURL_DISABLE_NETRC +static bool str_has_ctrl(const char *input) +{ + if(input) { + const unsigned char *str = (const unsigned char *)input; + while(*str) { + if(*str < 0x20) + return TRUE; + str++; + } + } + return FALSE; +} + +/* + * Override the login details from the URL with that in the CURLOPT_USERPWD + * option or a .netrc file, if applicable. + */ +static CURLcode url_set_data_creds_netrc(struct Curl_easy *data, + struct Curl_creds **pcreds) +{ + struct Curl_creds *ncreds_out = NULL; + CURLcode result = CURLE_OK; + + if(data->set.use_netrc) { /* not CURL_NETRC_IGNORED */ + struct Curl_creds *ncreds_in = NULL; + bool scan_netrc = TRUE; + NETRCcode ret; + CURLUcode uc; + + if(*pcreds) { + switch((*pcreds)->source) { + case CREDS_OPTION: + /* we never override credentials set via CURLOPT_*, leave. */ + scan_netrc = FALSE; + break; + case CREDS_URL: /* only apply when netrc is not required */ + if(data->set.use_netrc == CURL_NETRC_REQUIRED) { + /* We ignore password from URL */ + ncreds_in = *pcreds; + } + else if(!Curl_creds_has_user(*pcreds) || + !Curl_creds_has_passwd(*pcreds)) { + /* We use netrc to complete what is missing */ + ncreds_in = *pcreds; + } + else + scan_netrc = FALSE; + break; + default: /* ignore credentials from other sources */ + break; + } + } + + if(!scan_netrc) + goto out; + + ret = Curl_netrc_scan(data, &data->state.netrc, + data->state.origin->hostname, + Curl_creds_user(ncreds_in), + data->set.str[STRING_NETRC_FILE], + &ncreds_out); + DEBUGASSERT(!ret || !ncreds_out); + if(ret == NETRC_OUT_OF_MEMORY) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + else if(ret && ((ret == NETRC_NO_MATCH) || + (data->set.use_netrc == CURL_NETRC_OPTIONAL))) { + infof(data, "Could not find host %s in the %s file; using defaults", + data->state.origin->hostname, + (data->set.str[STRING_NETRC_FILE] ? + data->set.str[STRING_NETRC_FILE] : ".netrc")); + } + else if(ret) { + const char *m = Curl_netrc_strerror(ret); + failf(data, ".netrc error: %s", m); + result = CURLE_READ_ERROR; + goto out; + } + else if(ncreds_out) { + if(!(data->state.origin->scheme->flags & PROTOPT_USERPWDCTRL)) { + /* if the protocol cannot handle control codes in credentials, make + sure there are none */ + if(str_has_ctrl(ncreds_out->user) || + str_has_ctrl(ncreds_out->passwd)) { + failf(data, "control code detected in .netrc credentials"); + result = CURLE_READ_ERROR; + goto out; + } + } + CURL_TRC_M(data, "netrc: using credentials for %s as %s", + data->state.origin->hostname, ncreds_out->user); + result = Curl_creds_merge(ncreds_out->user, ncreds_out->passwd, + *pcreds, CREDS_NETRC, pcreds); + if(result) + goto out; + /* for updated strings, we update them in the URL */ + uc = curl_url_set(data->state.uh, CURLUPART_USER, + Curl_creds_user(*pcreds), CURLU_URLENCODE); + if(!uc) + uc = curl_url_set(data->state.uh, CURLUPART_PASSWORD, + Curl_creds_passwd(*pcreds), + CURLU_URLENCODE); + if(uc) + result = Curl_uc_to_curlcode(uc); + } + else + DEBUGASSERT(0); + } + +#ifdef CURLVERBOSE + Curl_creds_trace(data, data->state.creds, "transfer credentials"); +#endif + +out: + Curl_creds_unlink(&ncreds_out); + return result; +} +#endif /* CURL_DISABLE_NETRC */ + +static CURLcode url_set_data_creds(struct Curl_easy *data, CURLU *uh) +{ + struct Curl_creds *newcreds = NULL; + CURLcode result = CURLE_OK; + + if((data->set.str[STRING_USERNAME] || + data->set.str[STRING_PASSWORD] || + data->set.str[STRING_BEARER] || + data->set.str[STRING_SASL_AUTHZID] || + data->set.str[STRING_SERVICE_NAME]) && + Curl_auth_allowed_to_origin(data, data->state.origin)) { + result = Curl_creds_create(data->set.str[STRING_USERNAME], + data->set.str[STRING_PASSWORD], + data->set.str[STRING_BEARER], + data->set.str[STRING_SASL_AUTHZID], + data->set.str[STRING_SERVICE_NAME], + CREDS_OPTION, &newcreds); + if(result) + goto out; + } + + /* Extract credentials from the URL only if there are none OR + * if no CURLOPT_USER was set. */ + if(!newcreds || !Curl_creds_has_user(newcreds)) { + char *udecoded = NULL; + char *pdecoded = NULL; + CURLUcode uc; + + uc = curl_url_get(uh, CURLUPART_USER, &data->state.up.user, 0); + if(uc && (uc != CURLUE_NO_USER)) + result = Curl_uc_to_curlcode(uc); + if(!result) { + uc = curl_url_get(uh, CURLUPART_PASSWORD, &data->state.up.password, 0); + if(uc && (uc != CURLUE_NO_PASSWORD)) + result = Curl_uc_to_curlcode(uc); + } + if(!result && data->state.up.user) { + result = Curl_urldecode(data->state.up.user, 0, &udecoded, NULL, + (data->state.origin->scheme->flags & + PROTOPT_USERPWDCTRL) ? + REJECT_ZERO : REJECT_CTRL); + } + if(!result && data->state.up.password) { + result = Curl_urldecode(data->state.up.password, 0, &pdecoded, NULL, + (data->state.origin->scheme->flags & + PROTOPT_USERPWDCTRL) ? + REJECT_ZERO : REJECT_CTRL); + } + if(!result) + result = Curl_creds_merge(udecoded, pdecoded, newcreds, + CREDS_URL, &newcreds); + + curlx_free(udecoded); + curlx_free(pdecoded); + if(result) { + failf(data, "error extracting credentials from URL"); + goto out; + } + } + +#ifndef CURL_DISABLE_NETRC + /* Check for overridden login details and set them accordingly so that + they are known when protocol->setup_connection is called! */ + result = url_set_data_creds_netrc(data, &newcreds); +#endif /* CURL_DISABLE_NETRC */ + +out: + if(!result && !Curl_creds_equal(data->state.creds, newcreds)) { + /* Do we have more things to trigger on credentials change? */ + Curl_creds_link(&data->state.creds, newcreds); + } + Curl_creds_unlink(&newcreds); + return result; +} + +static CURLcode url_set_conn_origin_etc(struct Curl_easy *data, + struct connectdata *conn) +{ + CURLcode result = CURLE_OK; + + Curl_peer_link(&conn->origin, data->state.origin); + + /* set the connection scheme */ + result = url_set_conn_scheme(data, conn, conn->origin->scheme); + if(result) + goto out; + + /* set the connection options */ + if(data->set.str[STRING_OPTIONS]) { + conn->options = curlx_strdup(data->set.str[STRING_OPTIONS]); + if(!conn->options) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + } + else if(data->state.up.options) { + conn->options = curlx_strdup(data->state.up.options); + if(!conn->options) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + } + +#ifdef USE_IPV6 + conn->scope_id = data->set.scope_id ? + data->set.scope_id : data->state.origin->scopeid; +#endif + +out: + return result; +} + +/* + * If we are doing a resumed transfer, we need to setup our stuff + * properly. + */ +static CURLcode setup_range(struct Curl_easy *data) +{ + struct UrlState *s = &data->state; + s->resume_from = data->set.set_resume_from; + if(s->resume_from || data->set.str[STRING_SET_RANGE]) { + if(s->rangestringalloc) + curlx_free(s->range); + + if(s->resume_from) + s->range = curl_maprintf("%" FMT_OFF_T "-", s->resume_from); + else + s->range = curlx_strdup(data->set.str[STRING_SET_RANGE]); + + if(!s->range) + return CURLE_OUT_OF_MEMORY; + + s->rangestringalloc = TRUE; + + /* tell ourselves to fetch this range */ + s->use_range = TRUE; /* enable range download */ + } + else + s->use_range = FALSE; /* disable range download */ + + return CURLE_OK; +} + +/* + * setup_connection_internals() - + * + * Setup connection internals specific to the requested protocol in the + * Curl_easy. This is inited and setup before the connection is made but + * is about the particular protocol that is to be used. + * + * This MUST get called after proxy magic has been figured out. + */ +static CURLcode setup_connection_internals(struct Curl_easy *data, + struct connectdata *conn) +{ + struct Curl_peer *peer = NULL; + CURLcode result; + + if(conn->scheme->run->setup_connection) { + result = conn->scheme->run->setup_connection(data, conn); + if(result) + return result; + } + + /* Now create the destination name */ + peer = Curl_conn_get_destination(conn, FIRSTSOCKET); + if(!peer) + return CURLE_FAILED_INIT; + + /* IPv6 addresses with a scope_id (0 is default == global) have a + * printable representation with a '%' suffix. */ + if(peer->ipv6) + if(peer->scopeid) + conn->destination = curl_maprintf("[%s%%%u]:%u", + peer->hostname, peer->scopeid, peer->port); + else + conn->destination = curl_maprintf("[%s]:%u", + peer->hostname, peer->port); + else + conn->destination = curl_maprintf("%s:%u", peer->hostname, peer->port); + if(!conn->destination) + return CURLE_OUT_OF_MEMORY; + + Curl_strntolower(conn->destination, conn->destination, + strlen(conn->destination)); + + return CURLE_OK; +} + +/* + * Curl_parse_login_details() + * + * This is used to parse a login string for username, password and options in + * the following formats: + * + * user + * user:password + * user:password;options + * user;options + * user;options:password + * :password + * :password;options + * ;options + * ;options:password + * + * Parameters: + * + * login [in] - login string. + * len [in] - length of the login string. + * userp [in/out] - address where a pointer to newly allocated memory + * holding the user will be stored upon completion. + * passwdp [in/out] - address where a pointer to newly allocated memory + * holding the password will be stored upon completion. + * optionsp [in/out] - OPTIONAL address where a pointer to newly allocated + * memory holding the options will be stored upon + * completion. + * + * Returns CURLE_OK on success. + */ +CURLcode Curl_parse_login_details(const char *login, const size_t len, + char **userp, char **passwdp, + char **optionsp) +{ + char *ubuf = NULL; + char *pbuf = NULL; + const char *psep = NULL; + const char *osep = NULL; + size_t ulen; + size_t plen; + size_t olen; + + DEBUGASSERT(userp); + DEBUGASSERT(passwdp); + + /* Attempt to find the password separator */ + psep = memchr(login, ':', len); + + /* Attempt to find the options separator */ + if(optionsp) + osep = memchr(login, ';', len); + + /* Calculate the portion lengths */ + ulen = (psep ? + (size_t)(osep && psep > osep ? osep - login : psep - login) : + (osep ? (size_t)(osep - login) : len)); + plen = (psep ? + (osep && osep > psep ? (size_t)(osep - psep) : + (size_t)(login + len - psep)) - 1 : 0); + olen = (osep ? + (psep && psep > osep ? (size_t)(psep - osep) : + (size_t)(login + len - osep)) - 1 : 0); + + /* Clone the user portion buffer, which can be zero length */ + ubuf = curlx_memdup0(login, ulen); + if(!ubuf) + goto error; + + /* Clone the password portion buffer */ + if(psep) { + pbuf = curlx_memdup0(&psep[1], plen); + if(!pbuf) + goto error; + } + + /* Allocate the options portion buffer */ + if(optionsp) { + char *obuf = NULL; + if(olen) { + obuf = curlx_memdup0(&osep[1], olen); + if(!obuf) + goto error; + } + *optionsp = obuf; + } + *userp = ubuf; + *passwdp = pbuf; + return CURLE_OK; +error: + curlx_free(ubuf); + curlx_free(pbuf); + return CURLE_OUT_OF_MEMORY; +} + +/* + * Set the login details so they are available in the connection + */ +static CURLcode url_set_conn_login(struct Curl_easy *data, + struct connectdata *conn) +{ + /* If our protocol needs a password and we have none, use the defaults */ + if((conn->scheme->flags & PROTOPT_NEEDSPWD) && !conn->creds) { + Curl_peer_link(&conn->creds_origin, data->state.origin); + if(data->state.creds) + Curl_creds_link(&conn->creds, data->state.creds); + else + return Curl_creds_create(CURL_DEFAULT_USER, CURL_DEFAULT_PASSWORD, + NULL, NULL, NULL, CREDS_NONE, &conn->creds); + } + else if(!(conn->scheme->flags & PROTOPT_CREDSPERREQUEST)) { + /* for protocols that do not handle credentials per request, + * the connection credentials are set by the initial transfer. */ + Curl_peer_link(&conn->creds_origin, data->state.origin); + Curl_creds_link(&conn->creds, data->state.creds); + } + + return CURLE_OK; +} + +/* + * Parses one "connect to" string in the form: + * "HOST:PORT:CONNECT-TO-HOST:CONNECT-TO-PORT". + */ +static CURLcode parse_connect_to_string(struct Curl_easy *data, + const struct Curl_peer *dest, + const char *conn_to_line, + struct Curl_peer **pvia_dest) +{ + CURLcode result = CURLE_OK; + const char *ptr = conn_to_line; + bool host_match = FALSE; + bool port_match = FALSE; + + *pvia_dest = NULL; + + if(*ptr == ':') { + /* an empty hostname always matches */ + host_match = TRUE; + ptr++; + } + else { + /* check whether the URL's hostname matches. Use the URL hostname + * when it was an IPv6 address. Otherwise use the connection's hostname + * that has IDN conversion. */ + const char *hostname_to_match = (dest->user_hostname[0] == '[') ? + dest->user_hostname : dest->hostname; + size_t hlen = strlen(hostname_to_match); + host_match = curl_strnequal(ptr, hostname_to_match, hlen); + ptr += hlen; + + host_match = host_match && *ptr == ':'; + ptr++; + } + + if(host_match) { + if(*ptr == ':') { + /* an empty port always matches */ + port_match = TRUE; + ptr++; + } + else { + /* check whether the URL's port matches */ + const char *ptr_next = strchr(ptr, ':'); + if(ptr_next) { + curl_off_t port_to_match; + if(!curlx_str_number(&ptr, &port_to_match, 0xffff) && + ((uint16_t)port_to_match == dest->port)) { + port_match = TRUE; + } + ptr = ptr_next + 1; + } + } + } + + if(host_match && port_match && ptr && *ptr) + result = Curl_peer_from_connect_to(data, dest, ptr, pvia_dest); + + return result; +} + +/* With `conn->origin` known, determine if we should talk to that + * directly or via another peer. This is the result of inspecting + * the "connect to" slist and "alt-svc" settings. */ +static CURLcode url_set_conn_peer(struct Curl_easy *data, + struct connectdata *conn) +{ + CURLcode result = CURLE_OK; + const struct Curl_peer *origin = conn->origin; + struct Curl_peer *via_peer = NULL; + struct curl_slist *conn_to_entry = data->set.connect_to; + + DEBUGASSERT(!conn->via_peer); + Curl_peer_unlink(&conn->via_peer); + + while(conn_to_entry && !via_peer) { + result = parse_connect_to_string(data, origin, conn_to_entry->data, + &via_peer); + if(result) + return result; + conn_to_entry = conn_to_entry->next; + } + +#ifndef CURL_DISABLE_ALTSVC + if(data->asi && !via_peer && + ((conn->scheme->protocol == CURLPROTO_HTTPS) || +#ifdef DEBUGBUILD + /* allow debug builds to circumvent the HTTPS restriction */ + getenv("CURL_ALTSVC_HTTP") +#else + 0 +#endif + )) { + /* no connect_to match, try alt-svc! */ + enum alpnid srcalpnid = ALPN_none; + bool hit = FALSE; + struct altsvc *as = NULL; + int allowed_alpns = ALPN_none; + struct http_negotiation *neg = &data->state.http_neg; + bool same_dest = FALSE; + + DEBUGF(infof(data, "Alt-svc check wanted=%x, allowed=%x", + neg->wanted, neg->allowed)); +#ifdef USE_HTTP3 + if(neg->allowed & CURL_HTTP_V3x) + allowed_alpns |= ALPN_h3; +#endif +#ifdef USE_HTTP2 + if(neg->allowed & CURL_HTTP_V2x) + allowed_alpns |= ALPN_h2; +#endif + if(neg->allowed & CURL_HTTP_V1x) + allowed_alpns |= ALPN_h1; + allowed_alpns &= (int)data->asi->flags; + + DEBUGF(infof(data, "check Alt-Svc for host '%s'", origin->hostname)); +#ifdef USE_HTTP3 + if(!hit && (neg->wanted & CURL_HTTP_V3x)) { + srcalpnid = ALPN_h3; + hit = Curl_altsvc_lookup(data->asi, + ALPN_h3, origin->hostname, + origin->port, /* from */ + &as /* to */, + allowed_alpns, &same_dest); + } +#endif +#ifdef USE_HTTP2 + if(!hit && (neg->wanted & CURL_HTTP_V2x) && + !neg->h2_prior_knowledge) { + srcalpnid = ALPN_h2; + hit = Curl_altsvc_lookup(data->asi, + ALPN_h2, origin->hostname, + origin->port, /* from */ + &as /* to */, + allowed_alpns, &same_dest); + } +#endif + if(!hit && (neg->wanted & CURL_HTTP_V1x) && + !neg->only_10) { + srcalpnid = ALPN_h1; + hit = Curl_altsvc_lookup(data->asi, + ALPN_h1, origin->hostname, + origin->port, /* from */ + &as /* to */, + allowed_alpns, &same_dest); + } + + if(hit && same_dest) { + /* same destination, but more HTTPS version options */ + switch(as->dst.alpnid) { + case ALPN_h1: + neg->wanted |= CURL_HTTP_V1x; + neg->preferred = CURL_HTTP_V1x; + break; + case ALPN_h2: + neg->wanted |= CURL_HTTP_V2x; + neg->preferred = CURL_HTTP_V2x; + break; + case ALPN_h3: + neg->wanted |= CURL_HTTP_V3x; + neg->preferred = CURL_HTTP_V3x; + break; + default: /* should not be possible */ + break; + } + } + else if(hit) { + result = Curl_peer_create(data, conn->origin->scheme, + as->dst.host, as->dst.port, + &via_peer); + if(result) + return result; + infof(data, "Alt-svc connecting from [%s]%s:%u to [%s]%s:%u", + Curl_alpnid2str(srcalpnid), origin->hostname, origin->port, + Curl_alpnid2str(as->dst.alpnid), + via_peer->hostname, via_peer->port); + conn->bits.altused = TRUE; + if(srcalpnid != as->dst.alpnid) { + /* protocol version switch */ + switch(as->dst.alpnid) { + case ALPN_h1: + neg->wanted = neg->allowed = CURL_HTTP_V1x; + neg->only_10 = FALSE; + break; + case ALPN_h2: + neg->wanted = neg->allowed = CURL_HTTP_V2x; + break; + case ALPN_h3: + conn->transport_wanted = TRNSPRT_QUIC; + neg->wanted = neg->allowed = CURL_HTTP_V3x; + break; + default: /* should not be possible */ + break; + } + } + } + } +#endif + + if(via_peer) + conn->via_peer = via_peer; + + return result; +} + +/* + * Adjust reused connection settings to the transfer/needle. + */ +static void url_conn_reuse_adjust(struct Curl_easy *data, + struct connectdata *needle) +{ + struct connectdata *conn = data->conn; + + /* get the user+password information from the needle since it may + * be new for this request even when we reuse conn */ + if(needle->creds) { + /* use the new username and password though */ + Curl_creds_link(&conn->creds, needle->creds); + } + +#ifndef CURL_DISABLE_PROXY + /* use the new proxy username and proxy password though */ + Curl_creds_link(&conn->http_proxy.creds, needle->http_proxy.creds); + Curl_creds_link(&conn->socks_proxy.creds, needle->socks_proxy.creds); +#endif + + /* Finding a connection for reuse in the cpool matches, among other + * things on the "remote-relevant" hostname. This is not necessarily + * the authority of the URL, e.g. conn->origin. For example: + * - we use a proxy (not tunneling). we want to send all requests + * that use the same proxy on this connection. + * - we have a "connect-to" setting that may redirect the hostname of + * a new request to the same remote endpoint of an existing conn. + * We want to reuse an existing conn to the remote endpoint. + * Since connection reuse does not match on conn->origin necessarily, we + * switch conn to needle's host settings. + */ + Curl_peer_link(&conn->origin, needle->origin); + Curl_peer_link(&conn->via_peer, needle->via_peer); + Curl_peer_link(&conn->origin2, needle->origin2); + Curl_peer_link(&conn->via_peer2, needle->via_peer2); +} + +static void conn_meta_freeentry(void *p) +{ + (void)p; + /* Always FALSE. Cannot use a 0 assert here since compilers + * are not in agreement if they then want a NORETURN attribute or + * not. *sigh* */ + DEBUGASSERT(!p); +} + +static CURLcode url_create_needle(struct Curl_easy *data, + struct connectdata **pneedle) +{ + struct connectdata *needle = NULL; + CURLcode result = CURLE_OK; + bool network_scheme = TRUE; /* almost all are */ + + /* First, split up the current URL in parts so that we can use the + parts for checking against the already present connections. In order + to not have to modify everything at once, we allocate a temporary + connection data struct and fill in for comparison purposes. */ + needle = allocate_conn(data); + if(!needle) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + /* Do the unfailable inits first, before checks that may early return */ + Curl_hash_init(&needle->meta_hash, 23, + Curl_hash_str, curlx_str_key_compare, conn_meta_freeentry); + + /************************************************************* + * Determine `conn->origin` and populate `data->state.up` and + * other URL related properties. + *************************************************************/ + result = url_set_conn_origin_etc(data, needle); + if(result) + goto out; + + DEBUGASSERT(needle->origin); + network_scheme = !(needle->origin->scheme->flags & PROTOPT_NONETWORK); + +#ifdef USE_UNIX_SOCKETS + /************************************************************* + * Set UDS first. It overrides "via_peer" and proxy settings. + *************************************************************/ + if(network_scheme && data->set.str[STRING_UNIX_SOCKET_PATH]) { + result = Curl_peer_uds_create(needle->origin->scheme, + data->set.str[STRING_UNIX_SOCKET_PATH], + (bool)data->set.abstract_unix_socket, + &needle->via_peer); + if(result) + goto out; + } +#endif /* USE_UNIX_SOCKETS */ + + if(network_scheme && !needle->via_peer) { + /************************************************************* + * If the `via_peer` is not already set (via UDS above), + * determine if we talk to `conn->origin` directly or use + * `conn->via_peer` using "connect to" and "alt-svc" properties. + *************************************************************/ + result = url_set_conn_peer(data, needle); + if(result) + goto out; + } + + /************************************************************* + * Check whether the host and the "connect to host" are equal. + * Do this after the hostnames have been IDN-converted and + * before initializing the proxy. + *************************************************************/ + if(Curl_peer_equal(needle->origin, needle->via_peer)) { + Curl_peer_unlink(&needle->via_peer); + } + +#ifndef CURL_DISABLE_PROXY + /* Going via a unix socket ignores any proxy settings */ + if(network_scheme && + (!needle->via_peer || !needle->via_peer->unix_socket)) { + result = Curl_proxy_init_conn(data, needle); + if(result) + goto out; + } +#endif /* CURL_DISABLE_PROXY */ + + result = url_set_conn_login(data, needle); /* default credentials */ + if(result) + goto out; + + /************************************************************* + * Setup internals depending on protocol. Needs to be done after + * we figured out what/if proxy to use. + *************************************************************/ + result = setup_connection_internals(data, needle); + if(result) + goto out; + + if(needle->scheme->flags & PROTOPT_ALPN) { + /* The protocol wants it, so set the bits if enabled in the easy handle + (default) */ + if(data->set.ssl_enable_alpn) + needle->bits.tls_enable_alpn = TRUE; + } + + if(network_scheme) { + /* Setup callbacks for network connections */ + needle->recv[FIRSTSOCKET] = Curl_cf_recv; + needle->send[FIRSTSOCKET] = Curl_cf_send; + needle->recv[SECONDARYSOCKET] = Curl_cf_recv; + needle->send[SECONDARYSOCKET] = Curl_cf_send; + needle->bits.tcp_fastopen = data->set.tcp_fastopen; +#ifdef USE_UNIX_SOCKETS + if(Curl_conn_get_first_peer(needle, FIRSTSOCKET)->unix_socket) + needle->transport_wanted = TRNSPRT_UNIX; +#endif + } + +out: + if(!result) { + DEBUGASSERT(needle); + DEBUGASSERT(needle->origin); + *pneedle = needle; + } + else { + *pneedle = NULL; + if(needle) + Curl_conn_free(data, needle); + } + return result; +} + +static CURLcode url_set_data_origin_and_creds(struct Curl_easy *data) +{ + CURLcode result = CURLE_OK; + CURLU *uh; + CURLUcode uc; + bool use_set_uh = (data->set.uh && !data->state.this_is_a_follow); + uint16_t port_override = data->state.allow_port ? data->set.use_port : 0; + uint32_t scope_id = 0; + + /************************************************************* + * Check input data + *************************************************************/ + if(!Curl_bufref_ptr(&data->state.url)) { + result = CURLE_URL_MALFORMAT; + goto out; + } + + up_free(data); /* cleanup previous leftovers first */ + + /* parse the URL */ + if(use_set_uh) + uh = data->state.uh = curl_url_dup(data->set.uh); + else + uh = data->state.uh = curl_url(); + if(!uh) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + /* Calculate the *real* URL this transfer uses, applying defaults + * where information is missing. */ + if(data->set.str[STRING_DEFAULT_PROTOCOL] && + !Curl_is_absolute_url(Curl_bufref_ptr(&data->state.url), NULL, 0, TRUE)) { + char *url = curl_maprintf("%s://%s", + data->set.str[STRING_DEFAULT_PROTOCOL], + Curl_bufref_ptr(&data->state.url)); + if(!url) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + Curl_bufref_set(&data->state.url, url, 0, curl_free); + } + + if(!use_set_uh) { + char *newurl; + uc = curl_url_set(uh, CURLUPART_URL, Curl_bufref_ptr(&data->state.url), + (unsigned int)(CURLU_GUESS_SCHEME | + CURLU_NON_SUPPORT_SCHEME | + (data->set.disallow_username_in_url ? + CURLU_DISALLOW_USER : 0) | + (data->set.path_as_is ? CURLU_PATH_AS_IS : 0))); + if(uc) { + failf(data, "URL rejected: %s", curl_url_strerror(uc)); + result = Curl_uc_to_curlcode(uc); + goto out; + } + + /* after it was parsed, get the generated normalized version */ + uc = curl_url_get(uh, CURLUPART_URL, &newurl, CURLU_GET_EMPTY); + if(uc) { + result = Curl_uc_to_curlcode(uc); + goto out; + } + Curl_bufref_set(&data->state.url, newurl, 0, curl_free); + } + +#ifdef USE_IPV6 + scope_id = data->set.scope_id; +#endif + + /* `uh` is now as the connection should use it, probably. */ + result = Curl_peer_from_url(uh, data, port_override, scope_id, + &data->state.up, &data->state.origin); + if(result) + goto out; + /* The origin might get changed when HSTS applies */ + result = hsts_upgrade(data, uh, port_override, scope_id); + if(result) + goto out; + + /* When the transfers initial_origin is not set, this is the initial + * request. Remember this starting point. */ + if(!data->state.initial_origin) + Curl_peer_link(&data->state.initial_origin, data->state.origin); + + uc = curl_url_get(uh, CURLUPART_PATH, &data->state.up.path, CURLU_URLENCODE); + if(uc) { + result = Curl_uc_to_curlcode(uc); + goto out; + } + uc = curl_url_get(uh, CURLUPART_QUERY, &data->state.up.query, + CURLU_GET_EMPTY); + if(uc && (uc != CURLUE_NO_QUERY)) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + uc = curl_url_get(uh, CURLUPART_OPTIONS, &data->state.up.options, + CURLU_URLDECODE); + if(uc && (uc != CURLUE_NO_OPTIONS)) { + result = Curl_uc_to_curlcode(uc); + goto out; + } + + result = url_set_data_creds(data, uh); + if(result) + goto out; + +out: + return result; +} + +/** + * Find an existing connection for the transfer or create a new one. + * Returns + * - CURLE_OK on success with a connection attached to data + * - CURLE_NO_CONNECTION_AVAILABLE when connection limits apply or when + * a suitable connection has not determined its multiplex capability. + * - a fatal error + */ +static CURLcode url_find_or_create_conn(struct Curl_easy *data) +{ + struct connectdata *needle = NULL; + bool waitpipe = FALSE; + CURLcode result; + + /* create the template connection for transfer data. Use this needle to + * find an existing connection or, if none exists, convert needle + * to a full connection and attach it to data. */ + result = url_create_needle(data, &needle); + if(result) + goto out; + DEBUGASSERT(needle); + + /*********************************************************************** + * file: is a special case in that it does not need a network connection + ***********************************************************************/ +#ifndef CURL_DISABLE_FILE + if(needle->scheme->flags & PROTOPT_NONETWORK) { + bool done; + /* this is supposed to be the connect function so we better at least check + that the file is present here! */ + DEBUGASSERT(needle->scheme->run->connect_it); + data->info.conn_scheme = needle->scheme->name; + /* conn_protocol can only provide "old" protocols */ + data->info.conn_protocol = (needle->scheme->protocol) & CURLPROTO_MASK; + result = needle->scheme->run->connect_it(data, &done); + if(result) + goto out; + + /* Setup a "faked" transfer that will do nothing */ + Curl_attach_connection(data, needle); + needle = NULL; + result = Curl_cpool_add(data, data->conn); + if(!result) { + /* Setup whatever necessary for a resumed transfer */ + result = setup_range(data); + if(!result) { + Curl_xfer_setup_nop(data); + result = Curl_init_do(data, data->conn); + } + } + + if(result) { + DEBUGASSERT(data->conn->scheme->run->done); + /* we ignore the return code for the protocol-specific DONE */ + (void)data->conn->scheme->run->done(data, result, FALSE); + } + goto out; + } +#endif + + /* Complete the easy's SSL configuration for connection cache matching */ + result = Curl_ssl_easy_config_complete(data, needle->origin); + if(result) + goto out; + + /* Get rid of any dead connections so limit are easier kept. */ + Curl_cpool_prune_dead(data); + + /************************************************************* + * Reuse of existing connection is not allowed when + * - connect_only is set or + * - reuse_fresh is set and this is not a follow-up request + * (like with HTTP followlocation) + *************************************************************/ + if((!data->set.reuse_fresh || data->state.followlocation) && + !data->set.connect_only) { + /* Ok, try to find and attach an existing one */ + url_attach_existing(data, needle, &waitpipe); + } + + if(data->conn) { + /* We attached an existing connection for this transfer. Copy + * over transfer specific properties over from needle. */ + struct connectdata *conn = data->conn; + VERBOSE(bool tls_upgraded = (!(needle->given->flags & PROTOPT_SSL) && + Curl_conn_is_ssl(conn, FIRSTSOCKET))); + + conn->bits.reuse = TRUE; + url_conn_reuse_adjust(data, needle); + +#ifndef CURL_DISABLE_PROXY + infof(data, "Reusing existing %s: connection%s with %s %s", + conn->given->name, + tls_upgraded ? " (upgraded to SSL)" : "", + (conn->socks_proxy.peer || conn->http_proxy.peer) ? "proxy" : "host", + conn->socks_proxy.peer ? conn->socks_proxy.peer->user_hostname : + conn->http_proxy.peer ? conn->http_proxy.peer->user_hostname : + conn->origin->hostname); +#else + infof(data, "Reusing existing %s: connection%s with host %s", + conn->given->name, + tls_upgraded ? " (upgraded to SSL)" : "", + conn->origin->hostname); +#endif + } + else { + /* We have decided that we want a new connection. We may not be able to do + that if we have reached the limit of how many connections we are + allowed to open. */ + + if(waitpipe) { + /* There is a connection that *might* become usable for multiplexing + "soon", and we wait for that */ + infof(data, "Waiting on connection to negotiate possible multiplexing."); + result = CURLE_NO_CONNECTION_AVAILABLE; + goto out; + } + else { + switch(Curl_cpool_check_limits(data, needle)) { + case CPOOL_LIMIT_DEST: + infof(data, "No more connections allowed to host"); + result = CURLE_NO_CONNECTION_AVAILABLE; + goto out; + case CPOOL_LIMIT_TOTAL: + if(data->master_mid != UINT32_MAX) + CURL_TRC_M(data, "Allowing sub-requests (like DoH) to override " + "max connection limit"); + else { + infof(data, "No connections available, total of %zu reached.", + data->multi->max_total_connections); + result = CURLE_NO_CONNECTION_AVAILABLE; + goto out; + } + break; + default: + break; + } + } + + /* Convert needle into a full connection by filling in all the + * remaining parts like the cloned SSL configuration. */ + result = Curl_ssl_conn_config_init(data, needle); + if(result) { + DEBUGF(curl_mfprintf(stderr, "Error: init connection SSL config\n")); + goto out; + } + /* attach it and no longer own it */ + Curl_attach_connection(data, needle); + needle = NULL; + + result = Curl_cpool_add(data, data->conn); + if(result) + goto out; + +#ifdef USE_NTLM + /* If NTLM is requested in a part of this connection, make sure we do not + assume the state is fine as this is a fresh connection and NTLM is + connection based. */ + if((data->state.authhost.picked & CURLAUTH_NTLM) && + data->state.authhost.done) { + infof(data, "NTLM picked AND auth done set, clear picked"); + data->state.authhost.picked = CURLAUTH_NONE; + data->state.authhost.done = FALSE; + } + + if((data->state.authproxy.picked & CURLAUTH_NTLM) && + data->state.authproxy.done) { + infof(data, "NTLM-proxy picked AND auth done set, clear picked"); + data->state.authproxy.picked = CURLAUTH_NONE; + data->state.authproxy.done = FALSE; + } +#endif + } + + /* Setup and init stuff before DO starts, in preparing for the transfer. */ + result = Curl_init_do(data, data->conn); + if(result) + goto out; + + /* Setup whatever necessary for a resumed transfer */ + result = setup_range(data); + if(result) + goto out; + + /* persist the scheme and handler the transfer is using */ + data->info.conn_scheme = data->conn->scheme->name; + /* conn_protocol can only provide "old" protocols */ + data->info.conn_protocol = (data->conn->scheme->protocol) & CURLPROTO_MASK; + data->info.used_proxy = +#ifdef CURL_DISABLE_PROXY + 0 +#else + (data->conn->socks_proxy.peer || data->conn->http_proxy.peer) +#endif + ; + + /* Lastly, inform connection filters that a new transfer is attached */ + result = Curl_conn_ev_data_setup(data); + +out: + if(needle) + Curl_conn_free(data, needle); + DEBUGASSERT(result || data->conn); + return result; +} + +CURLcode Curl_connect(struct Curl_easy *data, bool *pconnected) +{ + CURLcode result; + struct connectdata *conn = NULL; + + *pconnected = FALSE; + + /* Set the request to virgin state based on transfer settings */ + Curl_req_hard_reset(&data->req, data); + /* Determine the origin of the transfer and what credentials to use */ + result = url_set_data_origin_and_creds(data); + if(result) + goto out; + if(!data->state.origin) { /* just make really sure */ + DEBUGASSERT(0); + result = CURLE_FAILED_INIT; + goto out; + } + + /* Get or create a connection for the transfer. */ + result = url_find_or_create_conn(data); + conn = data->conn; + if(result) + goto out; + if(!data->conn) { /* just make really sure */ + DEBUGASSERT(0); + result = CURLE_FAILED_INIT; + goto out; + } + + Curl_pgrsTime(data, TIMER_POSTQUEUE); + if(conn->bits.reuse) { + if(conn->attached_xfers > 1) + /* multiplexed */ + *pconnected = TRUE; + } + else if(conn->scheme->flags & PROTOPT_NONETWORK) { + Curl_pgrsTime(data, TIMER_NAMELOOKUP); + *pconnected = TRUE; + } + else { + result = Curl_conn_setup(data, conn, FIRSTSOCKET, CURL_CF_SSL_DEFAULT); + if(!result) + result = Curl_headers_init(data); + CURL_TRC_M(data, "Curl_conn_setup() -> %d", (int)result); + } + +out: + if(result == CURLE_NO_CONNECTION_AVAILABLE) + DEBUGASSERT(!conn); + + if(result && conn) { + /* We are not allowed to return failure with memory left allocated in the + connectdata struct, free those here */ + Curl_detach_connection(data); + Curl_conn_terminate(data, conn, TRUE); + } + + return result; +} + +/* + * Curl_init_do() inits the readwrite session. This is inited each time (in + * the DO function before the protocol-specific DO functions are invoked) for + * a transfer, sometimes multiple times on the same Curl_easy. Make sure + * nothing in here depends on stuff that are setup dynamically for the + * transfer. + * + * Allow this function to get called with 'conn' set to NULL. + */ + +CURLcode Curl_init_do(struct Curl_easy *data, struct connectdata *conn) +{ + CURLcode result; + + if(conn) { + conn->bits.do_more = FALSE; /* by default there is no curl_do_more() to + use */ + /* if the protocol used does not support wildcards, switch it off */ + if(data->state.wildcardmatch && + !(conn->scheme->flags & PROTOPT_WILDCARD)) + data->state.wildcardmatch = FALSE; + } + + data->state.done = FALSE; /* *_done() is not called yet */ + + data->req.no_body = data->set.opt_no_body; + if(data->req.no_body) + /* in HTTP lingo, no body means using the HEAD request... */ + data->state.httpreq = HTTPREQ_HEAD; + + result = Curl_req_start(&data->req, data); + if(!result) { + Curl_pgrsReset(data); + } + return result; +} + +#if defined(USE_HTTP2) || defined(USE_HTTP3) + +void Curl_data_priority_clear_state(struct Curl_easy *data) +{ + memset(&data->state.priority, 0, sizeof(data->state.priority)); +} + +#endif /* USE_HTTP2 || USE_HTTP3 */ + +CURLcode Curl_conn_meta_set(struct connectdata *conn, const char *key, + void *meta_data, Curl_meta_dtor *meta_dtor) +{ + if(!Curl_hash_add2(&conn->meta_hash, CURL_UNCONST(key), strlen(key) + 1, + meta_data, meta_dtor)) { + meta_dtor(CURL_UNCONST(key), strlen(key) + 1, meta_data); + return CURLE_OUT_OF_MEMORY; + } + return CURLE_OK; +} + +void Curl_conn_meta_remove(struct connectdata *conn, const char *key) +{ + Curl_hash_delete(&conn->meta_hash, CURL_UNCONST(key), strlen(key) + 1); +} + +void *Curl_conn_meta_get(struct connectdata *conn, const char *key) +{ + return Curl_hash_pick(&conn->meta_hash, CURL_UNCONST(key), strlen(key) + 1); +} + +CURLcode Curl_1st_fatal(CURLcode r1, CURLcode r2) +{ + if(r1 && (r1 != CURLE_AGAIN)) + return r1; + if(r2 && (r2 != CURLE_AGAIN)) + return r2; + return r1; +} diff --git a/3rdparty/curl-8.21.0/lib/url.h b/3rdparty/curl-8.21.0/lib/url.h new file mode 100644 index 0000000000..ebbe9d53c4 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/url.h @@ -0,0 +1,106 @@ +#ifndef HEADER_CURL_URL_H +#define HEADER_CURL_URL_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +/* Reject URLs exceeding this length */ +#define MAX_URL_LEN 0xffff + +/* + * Prototypes for library-wide functions + */ + +CURLcode Curl_init_do(struct Curl_easy *data, struct connectdata *conn); +CURLcode Curl_open(struct Curl_easy **curl); +void Curl_init_userdefined(struct Curl_easy *data); + +void Curl_freeset(struct Curl_easy *data); +CURLcode Curl_uc_to_curlcode(CURLUcode uc); +CURLcode Curl_close(struct Curl_easy **datap); /* opposite of Curl_open() */ +CURLcode Curl_connect(struct Curl_easy *data, bool *pconnected); +void Curl_conn_free(struct Curl_easy *data, struct connectdata *conn); +CURLcode Curl_parse_login_details(const char *login, const size_t len, + char **userp, char **passwdp, + char **optionsp); + +/* Attach/Clear/Get meta data for an easy handle. Needs to provide + * a destructor, will be automatically called when the easy handle + * is reset or closed. */ +typedef void Curl_meta_dtor(void *key, size_t key_len, void *meta_data); + +/* Set the transfer meta data for the key. Any existing entry for that + * key will be destroyed. + * Takes ownership of `meta_data` and destroys it when the call fails. */ +CURLcode Curl_meta_set(struct Curl_easy *data, const char *key, + void *meta_data, Curl_meta_dtor *meta_dtor); +void Curl_meta_remove(struct Curl_easy *data, const char *key); +void *Curl_meta_get(struct Curl_easy *data, const char *key); +void Curl_meta_reset(struct Curl_easy *data); + +/* Set connection meta data for the key. Any existing entry for that + * key will be destroyed. + * Takes ownership of `meta_data` and destroys it when the call fails. */ +CURLcode Curl_conn_meta_set(struct connectdata *conn, const char *key, + void *meta_data, Curl_meta_dtor *meta_dtor); +void Curl_conn_meta_remove(struct connectdata *conn, const char *key); +void *Curl_conn_meta_get(struct connectdata *conn, const char *key); + +#define CURL_DEFAULT_PROXY_PORT 1080 /* default proxy port unless specified */ +#define CURL_DEFAULT_HTTPS_PROXY_PORT 443 /* default https proxy port unless + specified */ + +/** + * Return TRUE iff the given connection is considered dead. + */ +bool Curl_conn_seems_dead(struct connectdata *conn, + struct Curl_easy *data); + +/** + * Perform upkeep operations on the connection. + */ +CURLcode Curl_conn_upkeep(struct Curl_easy *data, + struct connectdata *conn); + +/** + * Always eval all arguments, return the first + * result != (CURLE_OK | CURLE_AGAIN) or `r1`. + */ +CURLcode Curl_1st_fatal(CURLcode r1, CURLcode r2); + +#if defined(USE_HTTP2) || defined(USE_HTTP3) +void Curl_data_priority_clear_state(struct Curl_easy *data); +#else +#define Curl_data_priority_clear_state(x) +#endif /* USE_HTTP2 || USE_HTTP3 */ + +#ifdef USE_NGHTTP2 +CURLcode Curl_data_priority_add_child(struct Curl_easy *parent, + struct Curl_easy *child, + bool exclusive); +#else +#define Curl_data_priority_add_child(x, y, z) CURLE_NOT_BUILT_IN +#endif + +#endif /* HEADER_CURL_URL_H */ diff --git a/3rdparty/curl-8.21.0/lib/urlapi-int.h b/3rdparty/curl-8.21.0/lib/urlapi-int.h new file mode 100644 index 0000000000..4d8f2c1cb8 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/urlapi-int.h @@ -0,0 +1,68 @@ +#ifndef HEADER_CURL_URLAPI_INT_H +#define HEADER_CURL_URLAPI_INT_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" +#include + +/* Internal representation of CURLU. Point to URL-encoded strings. */ +struct Curl_URL { + char *scheme; + char *user; + char *password; + char *options; /* IMAP only? */ + char *host; + char *zoneid; /* for numerical IPv6 addresses */ + char *port; + char *path; + char *query; + char *fragment; + unsigned short portnum; /* the numerical version (if 'port' is set) */ + BIT(query_present); /* to support blank */ + BIT(fragment_present); /* to support blank */ + BIT(guessed_scheme); /* when a URL without scheme is parsed */ +}; + +#define HOST_ERROR (-1) /* out of memory */ +#define HOST_NAME 1 +#define HOST_IPV4 2 +#define HOST_IPV6 3 + +#define QUERY_NO 2 +#define QUERY_NOT_YET 3 /* allow to change to query */ +#define QUERY_YES 4 + +size_t Curl_is_absolute_url(const char *url, char *buf, size_t buflen, + bool guess_scheme); + +CURLUcode Curl_url_set_authority(CURLU *u, const char *authority); + +CURLUcode Curl_junkscan(const char *url, size_t *urllen, bool allowspace); + +#define U_CURLU_URLDECODE (unsigned int)CURLU_URLDECODE +#define U_CURLU_PATH_AS_IS (unsigned int)CURLU_PATH_AS_IS + +bool Curl_url_same_origin(CURLU *base, CURLU *href); + +#endif /* HEADER_CURL_URLAPI_INT_H */ diff --git a/3rdparty/curl-8.21.0/lib/urlapi.c b/3rdparty/curl-8.21.0/lib/urlapi.c new file mode 100644 index 0000000000..05c79dfb0d --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/urlapi.c @@ -0,0 +1,2102 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "urldata.h" +#include "urlapi-int.h" +#include "strcase.h" +#include "url.h" +#include "escape.h" +#include "curlx/inet_pton.h" +#include "curlx/inet_ntop.h" +#include "curlx/strdup.h" +#include "idn.h" +#include "curlx/strparse.h" +#include "curl_memrchr.h" + +#ifdef _WIN32 +/* MS-DOS/Windows style drive prefix, eg c: in c:foo */ +#define STARTS_WITH_DRIVE_PREFIX(str) \ + ((('a' <= (str)[0] && (str)[0] <= 'z') || \ + ('A' <= (str)[0] && (str)[0] <= 'Z')) && \ + ((str)[1] == ':')) +#endif + +/* MS-DOS/Windows style drive prefix, optionally with + * a '|' instead of ':', followed by a slash or NUL */ +#define STARTS_WITH_URL_DRIVE_PREFIX(str) \ + ((('a' <= (str)[0] && (str)[0] <= 'z') || \ + ('A' <= (str)[0] && (str)[0] <= 'Z')) && \ + ((str)[1] == ':' || (str)[1] == '|') && \ + ((str)[2] == '/' || (str)[2] == '\\' || (str)[2] == 0)) + +/* scheme is not URL encoded, the longest libcurl supported ones are... */ +#define MAX_SCHEME_LEN 40 + +/* + * If USE_IPV6 is disabled, we still want to parse IPv6 addresses, so make + * sure we have _some_ value for AF_INET6 without polluting our fake value + * everywhere. + */ +#if !defined(USE_IPV6) && !defined(AF_INET6) +#define AF_INET6 (AF_INET + 1) +#endif + +#define DEFAULT_SCHEME "https" + +static void free_urlhandle(struct Curl_URL *u) +{ + curlx_free(u->scheme); + curlx_free(u->user); + curlx_free(u->password); + curlx_free(u->options); + curlx_free(u->host); + curlx_free(u->zoneid); + curlx_free(u->port); + curlx_free(u->path); + curlx_free(u->query); + curlx_free(u->fragment); +} + +/* + * Find the separator at the end of the hostname, or the '?' in cases like + * http://www.example.com?id=2380 + */ +static const char *find_host_sep(const char *url) +{ + /* Find the start of the hostname */ + const char *sep = strstr(url, "//"); + if(!sep) + sep = url; + else + sep += 2; + + /* Find first / or ? */ + while(*sep && *sep != '/' && *sep != '?') + sep++; + + return sep; +} + +/* convert CURLcode to CURLUcode */ +#define cc2cu(x) \ + ((x) == CURLE_TOO_LARGE ? CURLUE_TOO_LARGE : CURLUE_OUT_OF_MEMORY) + +/* urlencode_str() writes data into an output dynbuf and URL-encodes the + * spaces in the source URL accordingly. + * + * This function re-encodes the string, meaning that it leaves already encoded + * bytes as-is and works by encoding only what *has* to be encoded - unless it + * has to uppercase the hex to normalize. + * + * Illegal percent-encoding sequences are left as-is. + * + * URL encoding should be skipped for hostnames, otherwise IDN resolution + * will fail. + * + * 'query' tells if it is a query part or not, or if it is allowed to + * "transition" into a query part with a question mark. + * + * @unittest 1675 + */ +UNITTEST CURLUcode urlencode_str(struct dynbuf *o, const char *url, + size_t len, bool relative, + unsigned int query); +UNITTEST CURLUcode urlencode_str(struct dynbuf *o, const char *url, + size_t len, bool relative, + unsigned int query) +{ + /* we must add this with whitespace-replacing */ + const unsigned char *iptr; + const unsigned char *host_sep = (const unsigned char *)url; + CURLcode result = CURLE_OK; + + DEBUGASSERT((query >= QUERY_NO) && (query <= QUERY_YES)); + + if(!relative) { + size_t n; + host_sep = (const unsigned char *)find_host_sep(url); + + /* output the first piece as-is */ + n = (const char *)host_sep - url; + result = curlx_dyn_addn(o, url, n); + len -= n; + } + + for(iptr = host_sep; len && !result; iptr++, len--) { + if(*iptr == ' ') { + if(query != QUERY_YES) + result = curlx_dyn_addn(o, "%20", 3); + else + result = curlx_dyn_addn(o, "+", 1); + } + else if((*iptr < ' ') || (*iptr >= 0x7f)) { + unsigned char out[3] = { '%' }; + Curl_hexbyte(&out[1], *iptr); + result = curlx_dyn_addn(o, out, 3); + } + else if(*iptr == '%' && (len >= 3) && + ISXDIGIT(iptr[1]) && ISXDIGIT(iptr[2]) && + (ISLOWER(iptr[1]) || ISLOWER(iptr[2]))) { + /* uppercase it */ + unsigned char hex = (unsigned char)((curlx_hexval(iptr[1]) << 4) | + curlx_hexval(iptr[2])); + unsigned char out[3] = { '%' }; + Curl_hexbyte(&out[1], hex); + result = curlx_dyn_addn(o, out, 3); + iptr += 2; + len -= 2; + } + else { + result = curlx_dyn_addn(o, iptr, 1); + if(*iptr == '?' && (query == QUERY_NOT_YET)) + query = QUERY_YES; + } + } + + if(result) + return cc2cu(result); + return CURLUE_OK; +} + +/* + * Returns the length of the scheme if the given URL is absolute (as opposed + * to relative). Stores the scheme in the buffer if TRUE and 'buf' is + * non-NULL. The buflen must be larger than MAX_SCHEME_LEN if buf is set. + * + * If 'guess_scheme' is TRUE, it means the URL might be provided without + * scheme. + */ +size_t Curl_is_absolute_url(const char *url, char *buf, size_t buflen, + bool guess_scheme) +{ + size_t i = 0; + DEBUGASSERT(!buf || (buflen > MAX_SCHEME_LEN)); + (void)buflen; /* only used in debug-builds */ + if(buf) + buf[0] = 0; /* always leave a defined value in buf */ +#ifdef _WIN32 + if(guess_scheme && STARTS_WITH_DRIVE_PREFIX(url)) + return 0; +#endif + if(ISALPHA(url[0])) + for(i = 1; i < MAX_SCHEME_LEN; ++i) { + char s = url[i]; + if(s && (ISALNUM(s) || (s == '+') || (s == '-') || (s == '.'))) { + /* RFC 3986 3.1 explains: + scheme = ALPHA *( ALPHA / DIGIT / "+" / "-" / "." ) + */ + } + else { + break; + } + } + if(i && (url[i] == ':') && ((url[i + 1] == '/') || !guess_scheme)) { + /* If this does not guess scheme, the scheme always ends with the colon so + that this also detects data: URLs etc. In guessing mode, data: could + be the hostname "data" with a specified port number. */ + + /* the length of the scheme is the name part only */ + size_t len = i; + if(buf) { + Curl_strntolower(buf, url, i); + buf[i] = 0; + } + return len; + } + return 0; +} + +/* scan for byte values <= 31, 127 and sometimes space */ +CURLUcode Curl_junkscan(const char *url, size_t *urllen, bool allowspace) +{ + size_t n = strlen(url); + size_t i; + unsigned char control; + const unsigned char *p = (const unsigned char *)url; + if(n > CURL_MAX_INPUT_LENGTH) + return CURLUE_MALFORMED_INPUT; + + control = allowspace ? 0x1f : 0x20; + for(i = 0; i < n; i++) { + if(p[i] <= control || p[i] == 127) + return CURLUE_MALFORMED_INPUT; + } + *urllen = n; + return CURLUE_OK; +} + +/* + * parse_hostname_login() + * + * Parse the login details (username, password and options) from the URL and + * strip them out of the hostname + * + * @unittest 1675 + */ +UNITTEST CURLUcode parse_hostname_login(struct Curl_URL *u, + const char *login, + size_t len, + unsigned int flags, + size_t *hostname_offset); +UNITTEST CURLUcode parse_hostname_login(struct Curl_URL *u, + const char *login, + size_t len, + unsigned int flags, + size_t *hostname_offset) +{ + CURLUcode ures = CURLUE_OK; + CURLcode result; + char *userp = NULL; + char *passwdp = NULL; + char *optionsp = NULL; + const struct Curl_scheme *h = NULL; + + /* At this point, we assume all the other special cases have been taken + * care of, so the host is at most + * + * [user[:password][;options]]@]hostname + * + * We need somewhere to put the embedded details, so do that first. + */ + const char *ptr; + + DEBUGASSERT(login); + + *hostname_offset = 0; + ptr = memchr(login, '@', len); + if(!ptr) + goto out; + + /* We will now try to extract the + * possible login information in a string like: + * ftp://user:password@ftp.site.example:8021/README */ + ptr++; + + /* if this is a known scheme, get some details */ + if(u->scheme) + h = Curl_get_scheme(u->scheme); + + /* We could use the login information in the URL so extract it. Only parse + options if the handler says we should. Note that 'h' might be NULL! */ + result = Curl_parse_login_details(login, ptr - login - 1, + &userp, &passwdp, + (h && (h->flags & PROTOPT_URLOPTIONS)) ? + &optionsp : NULL); + if(result) { + /* the only possible error from Curl_parse_login_details is out of + memory: */ + ures = CURLUE_OUT_OF_MEMORY; + goto out; + } + + if(userp) { + if(flags & CURLU_DISALLOW_USER) { + /* Option DISALLOW_USER is set and URL contains username. */ + ures = CURLUE_USER_NOT_ALLOWED; + goto out; + } + curlx_free(u->user); + u->user = userp; + } + + if(passwdp) { + curlx_free(u->password); + u->password = passwdp; + } + + if(optionsp) { + curlx_free(u->options); + u->options = optionsp; + } + + /* the hostname starts at this offset */ + *hostname_offset = ptr - login; + return CURLUE_OK; + +out: + + curlx_free(userp); + curlx_free(passwdp); + curlx_free(optionsp); + curlx_safefree(u->user); + curlx_safefree(u->password); + curlx_safefree(u->options); + + return ures; +} + +/* @unittest 1653 */ +UNITTEST CURLUcode parse_port(struct Curl_URL *u, struct dynbuf *host, + bool has_scheme); +UNITTEST CURLUcode parse_port(struct Curl_URL *u, struct dynbuf *host, + bool has_scheme) +{ + const char *portptr; + const char *hostname = curlx_dyn_ptr(host); + /* + * Find the end of an IPv6 address on the ']' ending bracket. + */ + if(hostname[0] == '[') { + portptr = strchr(hostname, ']'); + if(!portptr) + return CURLUE_BAD_IPV6; + portptr++; + /* this is a RFC2732-style specified IP-address */ + if(*portptr) { + if(*portptr != ':') + return CURLUE_BAD_PORT_NUMBER; + } + else + portptr = NULL; + } + else + portptr = strchr(hostname, ':'); + + if(portptr) { + curl_off_t port; + size_t keep = portptr - hostname; + + /* Browser behavior adaptation. If there is a colon with no digits after, + cut off the name there which makes us ignore the colon and use the + default port. Firefox, Chrome and Safari all do that. + + Do not do it if the URL has no scheme, to make something that looks like + a scheme not work! + */ + curlx_dyn_setlen(host, keep); + portptr++; + if(!*portptr) + return has_scheme ? CURLUE_OK : CURLUE_BAD_PORT_NUMBER; + + if(curlx_str_number(&portptr, &port, 0xffff) || *portptr) + return CURLUE_BAD_PORT_NUMBER; + + u->portnum = (unsigned short)port; + /* generate a new port number string to get rid of leading zeroes etc */ + curlx_free(u->port); + u->port = curl_maprintf("%" CURL_FORMAT_CURL_OFF_T, port); + if(!u->port) + return CURLUE_OUT_OF_MEMORY; + } + + return CURLUE_OK; +} + +/* This function assumes 'hostname' now starts with [. It trims 'hostname' in + * place and it sets u->zoneid if present. + * + * @unittest 1675 + */ +UNITTEST CURLUcode ipv6_parse(struct Curl_URL *u, char *hostname, + size_t hlen); +UNITTEST CURLUcode ipv6_parse(struct Curl_URL *u, char *hostname, + size_t hlen) /* length of hostname */ +{ + size_t len; + DEBUGASSERT(*hostname == '['); + if(hlen < 4) /* '[::]' is the shortest possible valid string */ + return CURLUE_BAD_IPV6; + hostname++; + hlen -= 2; + + /* only valid IPv6 letters are ok */ + len = strspn(hostname, "0123456789abcdefABCDEF:."); + + if(hlen != len) { + hlen = len; + if(hostname[len] == '%') { + /* this could now be '%[zone id]' */ + char zoneid[16]; + int i = 0; + char *h = &hostname[len + 1]; + /* pass '25' if present and is a URL encoded percent sign */ + if(!strncmp(h, "25", 2) && h[2] && (h[2] != ']')) + h += 2; + while(*h && (*h != ']') && (i < 15)) + zoneid[i++] = *h++; + if(!i || (']' != *h)) + return CURLUE_BAD_IPV6; + zoneid[i] = 0; + u->zoneid = curlx_strdup(zoneid); + if(!u->zoneid) + return CURLUE_OUT_OF_MEMORY; + hostname[len] = ']'; /* insert end bracket */ + hostname[len + 1] = 0; /* terminate the hostname */ + } + else + return CURLUE_BAD_IPV6; + /* hostname is fine */ + } + + /* Normalize the IPv6 address */ + { + char dest[16]; /* fits a binary IPv6 address */ + hostname[hlen] = 0; /* end the address there */ + if(curlx_inet_pton(AF_INET6, hostname, dest) != 1) + return CURLUE_BAD_IPV6; + if(curlx_inet_ntop(AF_INET6, dest, hostname, hlen + 1)) { + hlen = strlen(hostname); /* might be shorter now */ + hostname[hlen + 1] = 0; + } + hostname[hlen] = ']'; /* restore ending bracket */ + } + return CURLUE_OK; +} + +static CURLUcode hostname_check(struct Curl_URL *u, char *hostname, + size_t hlen) /* length of hostname */ +{ + size_t len; + DEBUGASSERT(hostname); + + if(!hlen) + return CURLUE_NO_HOST; + else if(hostname[0] == '[') + return ipv6_parse(u, hostname, hlen); + else { + /* letters from the second string are not ok */ + len = strcspn(hostname, " \r\n\t/:#?!@{}[]\\$\'\"^`*<>=;,+&()%|"); + if(hlen != len) + /* hostname with bad content */ + return CURLUE_BAD_HOSTNAME; + else if((hlen >= 2) && + (hostname[hlen - 1] == '.') && (hostname[hlen - 2] == '.')) + /* more than one trailing dot is not allowed */ + return CURLUE_BAD_HOSTNAME; + else if((hlen == 1) && (hostname[0] == '.')) + /* a single dot alone is not allowed */ + return CURLUE_BAD_HOSTNAME; + } + return CURLUE_OK; +} + +/* + * Handle partial IPv4 numerical addresses and different bases, like + * '16843009', '0x7f', '0x7f.1' '0177.1.1.1' etc. + * + * If the given input string is syntactically wrong IPv4 or any part for + * example is too big, this function returns HOST_NAME. + * + * Output the "normalized" version of that input string in plain quad decimal + * integers. + * + * A single dot following the numerical address is accepted and "swallowed" as + * if it was never there. + * + * Returns the host type. + * + * @unittest 1675 + */ +UNITTEST int ipv4_normalize(struct dynbuf *host); +UNITTEST int ipv4_normalize(struct dynbuf *host) +{ + bool done = FALSE; + int n = 0; + const char *c = curlx_dyn_ptr(host); + unsigned int parts[4] = { 0, 0, 0, 0 }; + CURLcode result = CURLE_OK; + + if(*c == '[') + return HOST_IPV6; + + while(!done) { + int rc; + curl_off_t l; + if(*c == '0') { + if(Curl_raw_tolower(c[1]) == 'x') { + c += 2; /* skip the prefix */ + rc = curlx_str_hex(&c, &l, UINT_MAX); + if(rc) + return HOST_NAME; + } + else + rc = curlx_str_octal(&c, &l, UINT_MAX); + } + else + rc = curlx_str_number(&c, &l, UINT_MAX); + + if(rc) { + if(!n || (rc != STRE_NO_NUM) || *c) + return HOST_NAME; + n--; + } + else + parts[n] = (unsigned int)l; + + switch(*c) { + case '.': + if(n == 3) { + if(c[1]) + /* something follows this dot */ + return HOST_NAME; + done = TRUE; + } + else { + n++; + c++; + } + break; + + case '\0': + done = TRUE; + break; + + default: + return HOST_NAME; + } + } + + switch(n) { + case 0: /* a -- 32 bits */ + curlx_dyn_reset(host); + + result = curlx_dyn_addf(host, "%u.%u.%u.%u", + (parts[0] >> 24), + ((parts[0] >> 16) & 0xff), + ((parts[0] >> 8) & 0xff), + (parts[0] & 0xff)); + break; + case 1: /* a.b -- 8.24 bits */ + if((parts[0] > 0xff) || (parts[1] > 0xffffff)) + return HOST_NAME; + curlx_dyn_reset(host); + result = curlx_dyn_addf(host, "%u.%u.%u.%u", + (parts[0]), + ((parts[1] >> 16) & 0xff), + ((parts[1] >> 8) & 0xff), + (parts[1] & 0xff)); + break; + case 2: /* a.b.c -- 8.8.16 bits */ + if((parts[0] > 0xff) || (parts[1] > 0xff) || (parts[2] > 0xffff)) + return HOST_NAME; + curlx_dyn_reset(host); + result = curlx_dyn_addf(host, "%u.%u.%u.%u", + (parts[0]), + (parts[1]), + ((parts[2] >> 8) & 0xff), + (parts[2] & 0xff)); + break; + case 3: /* a.b.c.d -- 8.8.8.8 bits */ + if((parts[0] > 0xff) || (parts[1] > 0xff) || (parts[2] > 0xff) || + (parts[3] > 0xff)) + return HOST_NAME; + curlx_dyn_reset(host); + result = curlx_dyn_addf(host, "%u.%u.%u.%u", + (parts[0]), + (parts[1]), + (parts[2]), + (parts[3])); + break; + } + if(result) + return HOST_ERROR; + return HOST_IPV4; +} + +/* if necessary, replace the host content with a URL decoded version */ +static CURLUcode urldecode_host(struct dynbuf *host) +{ + const char *per; + const char *hostname = curlx_dyn_ptr(host); + per = strchr(hostname, '%'); + if(!per) + /* nothing to decode */ + return CURLUE_OK; + else { + /* encoded */ + size_t dlen; + char *decoded; + CURLcode result = Curl_urldecode(hostname, 0, &decoded, &dlen, + REJECT_CTRL); + if(result) + return CURLUE_BAD_HOSTNAME; + curlx_dyn_reset(host); + result = curlx_dyn_addn(host, decoded, dlen); + curlx_free(decoded); + if(result) + return cc2cu(result); + } + + return CURLUE_OK; +} + +static CURLUcode parse_authority(struct Curl_URL *u, + const char *auth, size_t authlen, + unsigned int flags, + struct dynbuf *host, + bool has_scheme) +{ + size_t offset; + CURLUcode uc; + CURLcode result; + + /* + * Parse the login details and strip them out of the hostname. + */ + uc = parse_hostname_login(u, auth, authlen, flags, &offset); + if(uc) + return uc; + + result = curlx_dyn_addn(host, auth + offset, authlen - offset); + if(result) { + uc = cc2cu(result); + return uc; + } + + uc = parse_port(u, host, has_scheme); + if(uc) + return uc; + + if(!curlx_dyn_len(host)) + uc = CURLUE_NO_HOST; + else + uc = urldecode_host(host); + if(uc) + return uc; + + switch(ipv4_normalize(host)) { + case HOST_IPV4: + break; + case HOST_IPV6: + uc = ipv6_parse(u, curlx_dyn_ptr(host), curlx_dyn_len(host)); + break; + case HOST_NAME: + uc = hostname_check(u, curlx_dyn_ptr(host), curlx_dyn_len(host)); + break; + case HOST_ERROR: + uc = CURLUE_OUT_OF_MEMORY; + break; + default: + uc = CURLUE_BAD_HOSTNAME; /* Bad IPv4 address even */ + break; + } + + return uc; +} + +/* used for HTTP/2 server push */ +CURLUcode Curl_url_set_authority(CURLU *u, const char *authority) +{ + CURLUcode ures; + struct dynbuf host; + + DEBUGASSERT(authority); + curlx_dyn_init(&host, CURL_MAX_INPUT_LENGTH); + + ures = parse_authority(u, authority, strlen(authority), + CURLU_DISALLOW_USER, &host, !!u->scheme); + if(ures) + curlx_dyn_free(&host); + else { + curlx_free(u->host); + u->host = curlx_dyn_ptr(&host); + } + return ures; +} + +/* + * "Remove Dot Segments" + * https://datatracker.ietf.org/doc/html/rfc3986#section-5.2.4 + */ + +static bool is_dot(const char **str, size_t *clen) +{ + const char *p = *str; + if(*p == '.') { + (*str)++; + (*clen)--; + return TRUE; + } + else if((*clen >= 3) && + (p[0] == '%') && (p[1] == '2') && ((p[2] | 0x20) == 'e')) { + *str += 3; + *clen -= 3; + return TRUE; + } + return FALSE; +} + +#define ISSLASH(x) ((x) == '/') + +/* + * dedotdotify() + * + * This function gets a null-terminated path with dot and dotdot sequences + * passed in and strips them off according to the rules in RFC 3986 section + * 5.2.4. + * + * The function handles a path. It should not contain the query nor fragment. + * + * RETURNS + * + * Zero for success and 'out' set to an allocated dedotdotified string. + * + * @unittest 1395 + */ +UNITTEST int dedotdotify(const char *input, size_t clen, char **outp); +UNITTEST int dedotdotify(const char *input, size_t clen, char **outp) +{ + struct dynbuf out; + CURLcode result = CURLE_OK; + + /* variables for leading dot checks */ + const char *dinput = input; + size_t dlen = clen; + + *outp = NULL; + /* a single byte path cannot be cleaned up */ + if(clen < 2) + return 0; + + curlx_dyn_init(&out, clen + 1); + + /* if the input buffer begins with a prefix of "../" or "./", then remove + that prefix from the input buffer; otherwise, */ + if(is_dot(&dinput, &dlen)) { + if(ISSLASH(*dinput)) { + /* one dot followed by a slash */ + input = dinput + 1; + clen = dlen - 1; + } + + /* if the input buffer consists only of "." or "..", then remove + that from the input buffer; otherwise, */ + else if(is_dot(&dinput, &dlen)) { + if(!dlen) + /* .. [end] */ + goto end; + else if(ISSLASH(*dinput)) { + /* ../ */ + input = dinput + 1; + clen = dlen - 1; + } + } + } + + while(clen && !result) { /* until end of path content */ + if(ISSLASH(*input)) { + const char *p = &input[1]; + size_t blen = clen - 1; + /* if the input buffer begins with a prefix of "/./" or "/.", where "." + is a complete path segment, then replace that prefix with "/" in the + input buffer; otherwise, */ + if(is_dot(&p, &blen)) { + if(!blen) { /* /. */ + result = curlx_dyn_addn(&out, "/", 1); + break; + } + else if(ISSLASH(*p)) { /* /./ */ + input = p; + clen = blen; + continue; + } + + /* if the input buffer begins with a prefix of "/../" or "/..", where + ".." is a complete path segment, then replace that prefix with "/" + in the input buffer and remove the last segment and its preceding + "/" (if any) from the output buffer; otherwise, */ + else if(is_dot(&p, &blen) && (ISSLASH(*p) || !blen)) { + /* remove the last segment from the output buffer */ + size_t len = curlx_dyn_len(&out); + if(len) { + const char *ptr = curlx_dyn_ptr(&out); + const char *last = memrchr(ptr, '/', len); + if(last) + /* trim the output at the slash */ + curlx_dyn_setlen(&out, last - ptr); + } + + if(blen) { /* /../ */ + input = p; + clen = blen; + continue; + } + result = curlx_dyn_addn(&out, "/", 1); + break; + } + } + } + + /* move the first path segment in the input buffer to the end of the + output buffer, including the initial "/" character (if any) and any + subsequent characters up to, but not including, the next "/" character + or the end of the input buffer. */ + + result = curlx_dyn_addn(&out, input, 1); + input++; + clen--; + } +end: + if(!result) { + if(curlx_dyn_len(&out)) + *outp = curlx_dyn_ptr(&out); + else { + *outp = curlx_strdup(""); + if(!*outp) + return 1; + } + } + return result ? 1 : 0; /* success */ +} + +/* + * @unittest 1675 + */ +UNITTEST CURLUcode parse_file(const char *url, size_t urllen, CURLU *u, + const char **pathp, size_t *pathlenp); +UNITTEST CURLUcode parse_file(const char *url, size_t urllen, CURLU *u, + const char **pathp, size_t *pathlenp) +{ + const char *path; + size_t pathlen; + + *pathp = NULL; + *pathlenp = 0; + if(urllen <= 6) + /* file:/ is not enough to actually be a complete file: URL */ + return CURLUE_BAD_FILE_URL; + + /* path has been allocated large enough to hold this */ + path = &url[5]; + pathlen = urllen - 5; + + /* RFC 8089: file-hier-part = ( "//" auth-path ) / local-path, where + local-path also starts with a "/". So reject anything that does not + start with at least one "/" */ + if(path[0] != '/') + return CURLUE_BAD_FILE_URL; + + /* Extra handling URLs with an authority component (i.e. that start with + * "file://") + * + * We allow omitted hostname (e.g. file:/) -- valid according to + * RFC 8089, but not the (current) WHAT-WG URL spec. + */ + if(path[1] == '/') { + /* swallow the two slashes */ + const char *ptr = &path[2]; + + /* + * According to RFC 8089, a file: URL can be reliably dereferenced if: + * + * o it has no/blank hostname, or + * + * o the hostname matches "localhost" (case-insensitively), or + * + * o the hostname is a FQDN that resolves to this machine, or + * + * For brevity, we only consider URLs with empty, "localhost", or + * "127.0.0.1" hostnames as local, otherwise as an UNC String. + * + * Additionally, there is an exception for URLs with a Windows drive + * letter in the authority (which was accidentally omitted from RFC 8089 + * Appendix E, but believe me, it was meant to be there. --MK) + */ + if(ptr[0] != '/' && !STARTS_WITH_URL_DRIVE_PREFIX(ptr)) { + /* the URL includes a hostname, it must match "localhost" or + "127.0.0.1" to be valid */ + if(checkprefix("localhost/", ptr) || + checkprefix("127.0.0.1/", ptr)) { + ptr += 9; /* now points to the slash after the host */ + } + else + /* Invalid file://hostname/, expected localhost or 127.0.0.1 or + none */ + return CURLUE_BAD_FILE_URL; + } + + path = ptr; + pathlen = urllen - (ptr - url); + } + +#if !defined(_WIN32) && !defined(MSDOS) && !defined(__CYGWIN__) + /* Do not allow Windows drive letters when not in Windows. + * This catches both "file:/c:" and "file:c:" */ + if(('/' == path[0] && STARTS_WITH_URL_DRIVE_PREFIX(&path[1])) || + STARTS_WITH_URL_DRIVE_PREFIX(path)) { + /* File drive letters are only accepted in MS-DOS/Windows */ + return CURLUE_BAD_FILE_URL; + } +#else + /* If the path starts with a slash and a drive letter, ditch the slash */ + if('/' == path[0] && STARTS_WITH_URL_DRIVE_PREFIX(&path[1])) { + /* This cannot be done with strcpy, as the memory chunks overlap! */ + path++; + pathlen--; + } +#endif + u->scheme = curlx_strdup("file"); + if(!u->scheme) + return CURLUE_OUT_OF_MEMORY; + + *pathp = path; + *pathlenp = pathlen; + return CURLUE_OK; +} + +static CURLUcode parse_scheme(const char *url, CURLU *u, char *schemebuf, + size_t schemelen, unsigned int flags, + const char **hostpp) +{ + /* clear path */ + const char *schemep = NULL; + + if(schemelen) { + int i = 0; + const char *p = &url[schemelen + 1]; + while((*p == '/') && (i < 4)) { + p++; + i++; + } + + schemep = schemebuf; + if(!Curl_get_scheme(schemep) && + !(flags & CURLU_NON_SUPPORT_SCHEME)) + return CURLUE_UNSUPPORTED_SCHEME; + + if((i < 1) || (i > 3)) + /* less than one or more than three slashes */ + return CURLUE_BAD_SLASHES; + + *hostpp = p; /* hostname starts here */ + } + else { + /* no scheme! */ + + if(!(flags & (CURLU_DEFAULT_SCHEME | CURLU_GUESS_SCHEME))) + return CURLUE_BAD_SCHEME; + + if(flags & CURLU_DEFAULT_SCHEME) + schemep = DEFAULT_SCHEME; + + /* + * The URL was badly formatted, let's try without scheme specified. + */ + *hostpp = url; + } + + if(schemep) { + u->scheme = curlx_strdup(schemep); + if(!u->scheme) + return CURLUE_OUT_OF_MEMORY; + } + return CURLUE_OK; +} + +static CURLUcode guess_scheme(CURLU *u, struct dynbuf *host) +{ + const char *hostname = curlx_dyn_ptr(host); + const char *schemep = NULL; + /* legacy curl-style guess based on hostname */ + if(checkprefix("ftp.", hostname)) + schemep = "ftp"; + else if(checkprefix("dict.", hostname)) + schemep = "dict"; + else if(checkprefix("ldap.", hostname)) + schemep = "ldap"; + else if(checkprefix("imap.", hostname)) + schemep = "imap"; + else if(checkprefix("smtp.", hostname)) + schemep = "smtp"; + else if(checkprefix("pop3.", hostname)) + schemep = "pop3"; + else + schemep = "http"; + + u->scheme = curlx_strdup(schemep); + if(!u->scheme) + return CURLUE_OUT_OF_MEMORY; + + u->guessed_scheme = TRUE; + return CURLUE_OK; +} + +static CURLUcode handle_fragment(CURLU *u, const char *fragment, + size_t fraglen, unsigned int flags) +{ + CURLUcode ures; + u->fragment_present = TRUE; + if(fraglen > 1) { + /* skip the leading '#' in the copy but include the null-terminator */ + if(flags & CURLU_URLENCODE) { + struct dynbuf enc; + curlx_dyn_init(&enc, CURL_MAX_INPUT_LENGTH); + ures = urlencode_str(&enc, fragment + 1, fraglen - 1, TRUE, QUERY_NO); + if(ures) + return ures; + u->fragment = curlx_dyn_ptr(&enc); + } + else { + u->fragment = curlx_memdup0(fragment + 1, fraglen - 1); + if(!u->fragment) + return CURLUE_OUT_OF_MEMORY; + } + } + return CURLUE_OK; +} + +static CURLUcode handle_query(CURLU *u, const char *query, + size_t qlen, unsigned int flags) +{ + u->query_present = TRUE; + if(qlen > 1) { + if(flags & CURLU_URLENCODE) { + struct dynbuf enc; + CURLUcode ures; + curlx_dyn_init(&enc, CURL_MAX_INPUT_LENGTH); + /* skip the leading question mark */ + ures = urlencode_str(&enc, query + 1, qlen - 1, TRUE, QUERY_YES); + if(ures) + return ures; + u->query = curlx_dyn_ptr(&enc); + } + else { + u->query = curlx_memdup0(query + 1, qlen - 1); + if(!u->query) + return CURLUE_OUT_OF_MEMORY; + } + } + else { + /* single byte query */ + u->query = curlx_strdup(""); + if(!u->query) + return CURLUE_OUT_OF_MEMORY; + } + return CURLUE_OK; +} + +static CURLUcode handle_path(CURLU *u, const char *path, + size_t pathlen, unsigned int flags, + bool is_file) +{ + CURLUcode ures; + if(pathlen && (flags & CURLU_URLENCODE)) { + struct dynbuf enc; + curlx_dyn_init(&enc, CURL_MAX_INPUT_LENGTH); + ures = urlencode_str(&enc, path, pathlen, TRUE, QUERY_NO); + if(ures) + return ures; + pathlen = curlx_dyn_len(&enc); + path = u->path = curlx_dyn_ptr(&enc); + } + + if(pathlen >= (size_t)(1 + !is_file)) { + /* paths for file:// scheme can be one byte, others need to be two */ + if(!u->path) { + u->path = curlx_memdup0(path, pathlen); + if(!u->path) + return CURLUE_OUT_OF_MEMORY; + path = u->path; + } + else if(flags & CURLU_URLENCODE) + /* it might have encoded more than the path so cut it */ + u->path[pathlen] = 0; + + if(!(flags & CURLU_PATH_AS_IS)) { + /* remove ../ and ./ sequences according to RFC3986 */ + char *dedot; + int err = dedotdotify(path, pathlen, &dedot); + if(err) + return CURLUE_OUT_OF_MEMORY; + if(dedot) { + curlx_free(u->path); + u->path = dedot; + } + } + } + return CURLUE_OK; +} + +static CURLUcode parseurl(const char *url, CURLU *u, unsigned int flags) +{ + const char *path; + size_t pathlen; + char schemebuf[MAX_SCHEME_LEN + 1]; + size_t schemelen = 0; + size_t urllen; + CURLUcode ures = CURLUE_OK; + struct dynbuf host; + bool is_file = FALSE; + + DEBUGASSERT(url); + + curlx_dyn_init(&host, CURL_MAX_INPUT_LENGTH); + + ures = Curl_junkscan(url, &urllen, !!(flags & CURLU_ALLOW_SPACE)); + if(ures) + goto fail; + + schemelen = Curl_is_absolute_url(url, schemebuf, sizeof(schemebuf), + flags & (CURLU_GUESS_SCHEME | + CURLU_DEFAULT_SCHEME)); + + /* handle the file: scheme */ + if(schemelen && !strcmp(schemebuf, "file")) { + is_file = TRUE; + ures = parse_file(url, urllen, u, &path, &pathlen); + } + else { + const char *hostp = NULL; + size_t hostlen; + ures = parse_scheme(url, u, schemebuf, schemelen, flags, &hostp); + if(ures) + goto fail; + + /* find the end of the hostname + port number */ + hostlen = strcspn(hostp, "/?#"); + path = &hostp[hostlen]; + + /* this pathlen also contains the query and the fragment */ + pathlen = urllen - (path - url); + if(hostlen) { + ures = parse_authority(u, hostp, hostlen, flags, &host, !!u->scheme); + if(!ures && (flags & CURLU_GUESS_SCHEME) && !u->scheme) + ures = guess_scheme(u, &host); + } + else if(flags & CURLU_NO_AUTHORITY) { + /* allowed to be empty. */ + if(curlx_dyn_add(&host, "")) + ures = CURLUE_OUT_OF_MEMORY; + } + else + ures = CURLUE_NO_HOST; + } + if(!ures) { + /* The path might at this point contain a fragment and/or a query to + handle */ + const char *fragment = strchr(path, '#'); + if(fragment) { + size_t fraglen = pathlen - (fragment - path); + ures = handle_fragment(u, fragment, fraglen, flags); + /* after this, pathlen still contains the query */ + pathlen -= fraglen; + } + } + if(!ures) { + const char *query = memchr(path, '?', pathlen); + if(query) { + size_t qlen = pathlen - (query - path); + ures = handle_query(u, query, qlen, flags); + pathlen -= qlen; + } + } + if(!ures) + /* the fragment and query parts are trimmed off from the path */ + ures = handle_path(u, path, pathlen, flags, is_file); + if(!ures) { + u->host = curlx_dyn_ptr(&host); + return CURLUE_OK; + } +fail: + curlx_dyn_free(&host); + free_urlhandle(u); + return ures; +} + +/* + * Parse the URL and, if successful, replace everything in the Curl_URL struct. + */ +static CURLUcode parseurl_and_replace(const char *url, CURLU *u, + unsigned int flags) +{ + CURLUcode ures; + CURLU tmpurl; + memset(&tmpurl, 0, sizeof(tmpurl)); + ures = parseurl(url, &tmpurl, flags); + if(!ures) { + free_urlhandle(u); + *u = tmpurl; + } + return ures; +} + +/* + * Concatenate a relative URL onto a base URL making it absolute. + */ +static CURLUcode redirect_url(const char *base, const char *relurl, + CURLU *u, unsigned int flags) +{ + struct dynbuf urlbuf; + bool host_changed = FALSE; + const char *useurl = relurl; + const char *cutoff = NULL; + size_t prelen; + CURLUcode uc; + /* this can get here with a NULL u->scheme only if asked to use the default + scheme, so allow fallback to that */ + const char *scheme = u->scheme ? u->scheme : DEFAULT_SCHEME; + + /* protsep points to the start of the hostname, after [scheme]:// */ + const char *protsep = base + strlen(scheme) + 3; + DEBUGASSERT(base && relurl && u); /* all set here */ + if(!base) + return CURLUE_MALFORMED_INPUT; /* should never happen */ + + /* handle different relative URL types */ + switch(relurl[0]) { + case '/': + if(relurl[1] == '/') { + /* protocol-relative URL: //example.com/path */ + cutoff = protsep; + useurl = &relurl[2]; + host_changed = TRUE; + } + else + /* absolute /path */ + cutoff = strchr(protsep, '/'); + break; + + case '#': + /* fragment-only change */ + if(u->fragment) + cutoff = strchr(protsep, '#'); + break; + + default: + /* path or query-only change */ + if(u->query && u->query[0]) + /* remove existing query */ + cutoff = strchr(protsep, '?'); + else if(u->fragment && u->fragment[0]) + /* Remove existing fragment */ + cutoff = strchr(protsep, '#'); + + if(relurl[0] != '?') { + /* append a relative path after the last slash */ + cutoff = memrchr(protsep, '/', + cutoff ? (size_t)(cutoff - protsep) : strlen(protsep)); + if(cutoff) + cutoff++; /* truncate after last slash */ + } + break; + } + + prelen = cutoff ? (size_t)(cutoff - base) : strlen(base); + + /* build new URL */ + curlx_dyn_init(&urlbuf, CURL_MAX_INPUT_LENGTH); + + if(!curlx_dyn_addn(&urlbuf, base, prelen) && + !urlencode_str(&urlbuf, useurl, strlen(useurl), !host_changed, + QUERY_NOT_YET)) { + uc = parseurl_and_replace(curlx_dyn_ptr(&urlbuf), u, + flags & ~U_CURLU_PATH_AS_IS); + } + else + uc = CURLUE_OUT_OF_MEMORY; + + curlx_dyn_free(&urlbuf); + return uc; +} + +/* + */ +CURLU *curl_url(void) +{ + return curlx_calloc(1, sizeof(struct Curl_URL)); +} + +void curl_url_cleanup(CURLU *u) +{ + if(u) { + free_urlhandle(u); + curlx_free(u); + } +} + +#define DUP(dest, src, name) \ + do { \ + if((src)->name) { \ + (dest)->name = curlx_strdup((src)->name); \ + if(!(dest)->name) \ + goto fail; \ + } \ + } while(0) + +CURLU *curl_url_dup(const CURLU *in) +{ + struct Curl_URL *u = curlx_calloc(1, sizeof(struct Curl_URL)); + if(u) { + DUP(u, in, scheme); + DUP(u, in, user); + DUP(u, in, password); + DUP(u, in, options); + DUP(u, in, host); + DUP(u, in, port); + DUP(u, in, path); + DUP(u, in, query); + DUP(u, in, fragment); + DUP(u, in, zoneid); + u->portnum = in->portnum; + u->fragment_present = in->fragment_present; + u->query_present = in->query_present; + } + return u; +fail: + curl_url_cleanup(u); + return NULL; +} + +#ifndef USE_IDN +#define host_decode(x, y) CURLUE_LACKS_IDN +#define host_encode(x, y) CURLUE_LACKS_IDN +#else +static CURLUcode host_decode(const char *host, char **allochost) +{ + CURLcode result = Curl_idn_decode(host, allochost); + if(result) + return (result == CURLE_OUT_OF_MEMORY) ? + CURLUE_OUT_OF_MEMORY : CURLUE_BAD_HOSTNAME; + return CURLUE_OK; +} + +static CURLUcode host_encode(const char *host, char **allochost) +{ + CURLcode result = Curl_idn_encode(host, allochost); + if(result) + return (result == CURLE_OUT_OF_MEMORY) ? + CURLUE_OUT_OF_MEMORY : CURLUE_BAD_HOSTNAME; + return CURLUE_OK; +} +#endif + +static CURLUcode urlget_format(const CURLU *u, CURLUPart what, + const char *ptr, char **partp, + bool plusdecode, unsigned int flags) +{ + CURLUcode uc = CURLUE_OK; + size_t partlen = strlen(ptr); + bool urldecode = (flags & CURLU_URLDECODE) ? 1 : 0; + bool urlencode = (flags & CURLU_URLENCODE) ? 1 : 0; + bool punycode = (flags & CURLU_PUNYCODE) && (what == CURLUPART_HOST); + bool depunyfy = (flags & CURLU_PUNY2IDN) && (what == CURLUPART_HOST); + char *part = curlx_memdup0(ptr, partlen); + *partp = NULL; + if(!part) + return CURLUE_OUT_OF_MEMORY; + if(plusdecode) { + /* convert + to space */ + char *plus = part; + size_t i = 0; + for(i = 0; i < partlen; ++plus, i++) { + if(*plus == '+') + *plus = ' '; + } + } + if(urldecode) { + char *decoded; + size_t dlen; + /* this unconditional rejection of control bytes is documented API + behavior */ + CURLcode result = Curl_urldecode(part, partlen, &decoded, &dlen, + REJECT_CTRL); + curlx_free(part); + if(result) + return CURLUE_URLDECODE; + part = decoded; + partlen = dlen; + } + if(urlencode) { + struct dynbuf enc; + curlx_dyn_init(&enc, CURL_MAX_INPUT_LENGTH); + uc = urlencode_str(&enc, part, partlen, TRUE, what == CURLUPART_QUERY ? + QUERY_YES : QUERY_NO); + curlx_free(part); + if(uc) + return uc; + part = curlx_dyn_ptr(&enc); + } + else if(punycode) { + if(!Curl_is_ASCII_name(u->host)) { + char *punyversion = NULL; + uc = host_decode(part, &punyversion); + curlx_free(part); + if(uc) + return uc; + part = punyversion; + } + } + else if(depunyfy) { + if(Curl_is_ASCII_name(u->host)) { + char *unpunified = NULL; + uc = host_encode(part, &unpunified); + curlx_free(part); + if(uc) + return uc; + part = unpunified; + } + } + *partp = part; + return CURLUE_OK; +} + +static CURLUcode file_url(const CURLU *u, char **part, + const char *fragmentsep, + const char *querysep) +{ + char *url = curl_maprintf("file://%s%s%s%s%s", + u->path, querysep, u->query ? u->query : "", + fragmentsep, u->fragment ? u->fragment : ""); + if(!url) + return CURLUE_OUT_OF_MEMORY; + + *part = url; + return CURLUE_OK; +} + +static CURLUcode urlget_url(const CURLU *u, char **part, unsigned int flags) +{ + char *url; + char *allochost = NULL; + const char *fragmentsep = + (u->fragment || (u->fragment_present && flags & CURLU_GET_EMPTY)) ? + "#" : ""; + const char *querysep = ((u->query && u->query[0]) || + (u->query_present && flags & CURLU_GET_EMPTY)) ? + "?" : ""; + char portbuf[7]; + if(curl_strequal("file", u->scheme)) + return file_url(u, part, fragmentsep, querysep); + else if(!u->host) + return CURLUE_NO_HOST; + else { + const char *scheme; + char *options = u->options; + char *port = u->port; + const struct Curl_scheme *h = NULL; + char schemebuf[MAX_SCHEME_LEN + 5]; + if(u->scheme) + scheme = u->scheme; + else if(flags & CURLU_DEFAULT_SCHEME) + scheme = DEFAULT_SCHEME; + else + return CURLUE_NO_SCHEME; + + h = Curl_get_scheme(scheme); + if(h) { + if(!port && (flags & CURLU_DEFAULT_PORT)) { + /* there is no stored port number, but asked to deliver a default one + for the scheme */ + curl_msnprintf(portbuf, sizeof(portbuf), "%u", h->defport); + port = portbuf; + } + else if(port && (h->defport == u->portnum) && + (flags & CURLU_NO_DEFAULT_PORT)) + /* there is a stored port number, but asked to inhibit if it matches + the default port for the scheme */ + port = NULL; + if(!(h->flags & PROTOPT_URLOPTIONS)) + options = NULL; + } + + if(u->host[0] == '[') { + if(u->zoneid) { + /* make it '[ host %25 zoneid ]' */ + struct dynbuf enc; + size_t hostlen = strlen(u->host); + curlx_dyn_init(&enc, CURL_MAX_INPUT_LENGTH); + if(curlx_dyn_addf(&enc, "%.*s%%25%s]", (int)hostlen - 1, u->host, + u->zoneid)) + return CURLUE_OUT_OF_MEMORY; + allochost = curlx_dyn_ptr(&enc); + } + } + else if(flags & CURLU_URLENCODE) { + allochost = curl_easy_escape(NULL, u->host, 0); + if(!allochost) + return CURLUE_OUT_OF_MEMORY; + } + else if(flags & CURLU_PUNYCODE) { + if(!Curl_is_ASCII_name(u->host)) { + CURLUcode ret = host_decode(u->host, &allochost); + if(ret) + return ret; + } + } + else if(flags & CURLU_PUNY2IDN) { + if(Curl_is_ASCII_name(u->host)) { + CURLUcode ret = host_encode(u->host, &allochost); + if(ret) + return ret; + } + } + + if(!(flags & CURLU_NO_GUESS_SCHEME) || !u->guessed_scheme) + curl_msnprintf(schemebuf, sizeof(schemebuf), "%s://", scheme); + else + schemebuf[0] = 0; + + url = curl_maprintf("%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s", + schemebuf, + u->user ? u->user : "", + u->password ? ":" : "", + u->password ? u->password : "", + options ? ";" : "", + options ? options : "", + (u->user || u->password || options) ? "@" : "", + allochost ? allochost : u->host, + port ? ":" : "", + port ? port : "", + u->path ? u->path : "/", + querysep, + u->query ? u->query : "", + fragmentsep, + u->fragment ? u->fragment : ""); + curlx_free(allochost); + } + if(!url) + return CURLUE_OUT_OF_MEMORY; + *part = url; + return CURLUE_OK; +} + +CURLUcode curl_url_get(const CURLU *u, CURLUPart what, + char **part, unsigned int flags) +{ + const char *ptr; + CURLUcode ifmissing = CURLUE_UNKNOWN_PART; + char portbuf[7]; + bool plusdecode = FALSE; + if(!u) + return CURLUE_BAD_HANDLE; + if(!part) + return CURLUE_BAD_PARTPOINTER; + *part = NULL; + + switch(what) { + case CURLUPART_SCHEME: + ptr = u->scheme; + ifmissing = CURLUE_NO_SCHEME; + flags &= ~U_CURLU_URLDECODE; /* never for schemes */ + if((flags & CURLU_NO_GUESS_SCHEME) && u->guessed_scheme) + return CURLUE_NO_SCHEME; + break; + case CURLUPART_USER: + ptr = u->user; + ifmissing = CURLUE_NO_USER; + break; + case CURLUPART_PASSWORD: + ptr = u->password; + ifmissing = CURLUE_NO_PASSWORD; + break; + case CURLUPART_OPTIONS: + ptr = u->options; + ifmissing = CURLUE_NO_OPTIONS; + break; + case CURLUPART_HOST: + ptr = u->host; + ifmissing = CURLUE_NO_HOST; + break; + case CURLUPART_ZONEID: + ptr = u->zoneid; + ifmissing = CURLUE_NO_ZONEID; + break; + case CURLUPART_PORT: + ptr = u->port; + ifmissing = CURLUE_NO_PORT; + flags &= ~U_CURLU_URLDECODE; /* never for port */ + if(!ptr && (flags & CURLU_DEFAULT_PORT) && u->scheme) { + /* there is no stored port number, but asked to deliver + a default one for the scheme */ + const struct Curl_scheme *h = Curl_get_scheme(u->scheme); + if(h) { + curl_msnprintf(portbuf, sizeof(portbuf), "%u", h->defport); + ptr = portbuf; + } + } + else if(ptr && u->scheme) { + /* there is a stored port number, but ask to inhibit if + it matches the default one for the scheme */ + const struct Curl_scheme *h = Curl_get_scheme(u->scheme); + if(h && (h->defport == u->portnum) && + (flags & CURLU_NO_DEFAULT_PORT)) + ptr = NULL; + } + break; + case CURLUPART_PATH: + ptr = u->path; + if(!ptr) + ptr = "/"; + break; + case CURLUPART_QUERY: + ptr = u->query; + ifmissing = CURLUE_NO_QUERY; + plusdecode = flags & CURLU_URLDECODE; + if(ptr && !ptr[0] && !(flags & CURLU_GET_EMPTY)) + /* there was a blank query and the user do not ask for it */ + ptr = NULL; + break; + case CURLUPART_FRAGMENT: + ptr = u->fragment; + ifmissing = CURLUE_NO_FRAGMENT; + if(!ptr && u->fragment_present && flags & CURLU_GET_EMPTY) + /* there was a blank fragment and the user asks for it */ + ptr = ""; + break; + case CURLUPART_URL: + return urlget_url(u, part, flags); + default: + ptr = NULL; + break; + } + if(ptr) + return urlget_format(u, what, ptr, part, plusdecode, flags); + + return ifmissing; +} + +static CURLUcode set_url_scheme(CURLU *u, const char *scheme, + unsigned int flags) +{ + size_t plen = strlen(scheme); + const struct Curl_scheme *h = NULL; + if((plen > MAX_SCHEME_LEN) || (plen < 1)) + /* too long or too short */ + return CURLUE_BAD_SCHEME; + /* verify that it is a fine scheme */ + h = Curl_get_scheme(scheme); + if(!(flags & CURLU_NON_SUPPORT_SCHEME) && (!h || !h->run)) + return CURLUE_UNSUPPORTED_SCHEME; + if(!h) { + const char *s = scheme; + if(ISALPHA(*s)) { + /* ALPHA *( ALPHA / DIGIT / "+" / "-" / "." ) */ + s++; + while(--plen) { + if(ISALNUM(*s) || (*s == '+') || (*s == '-') || (*s == '.')) + s++; /* fine */ + else + return CURLUE_BAD_SCHEME; + } + } + else + return CURLUE_BAD_SCHEME; + } + u->guessed_scheme = FALSE; + return CURLUE_OK; +} + +static CURLUcode set_url_port(CURLU *u, const char *provided_port) +{ + char *tmp; + curl_off_t port; + if(!ISDIGIT(provided_port[0])) + /* not a number */ + return CURLUE_BAD_PORT_NUMBER; + if(curlx_str_number(&provided_port, &port, 0xffff) || *provided_port) + /* weirdly provided number, not good! */ + return CURLUE_BAD_PORT_NUMBER; + tmp = curl_maprintf("%" CURL_FORMAT_CURL_OFF_T, port); + if(!tmp) + return CURLUE_OUT_OF_MEMORY; + curlx_free(u->port); + u->port = tmp; + u->portnum = (unsigned short)port; + return CURLUE_OK; +} + +static CURLUcode set_url(CURLU *u, const char *url, size_t part_size, + unsigned int flags) +{ + /* + * Allow a new URL to replace the existing (if any) contents. + * + * If the existing contents is enough for a URL, allow a relative URL to + * replace it. + */ + CURLUcode uc; + char *oldurl = NULL; + + if(!part_size) { + /* a blank URL is not a valid URL unless we already have a complete one + and this is a redirect */ + uc = curl_url_get(u, CURLUPART_URL, &oldurl, flags); + if(!uc) { + /* success, meaning the "" is a fine relative URL, and the new URL + inherits scheme/authority/path/query, but not fragment, from the + existing URL (RFC 3986 section 5.2.2) */ + curlx_safefree(u->fragment); + u->fragment_present = FALSE; + curlx_free(oldurl); + return CURLUE_OK; + } + if(uc == CURLUE_OUT_OF_MEMORY) + return uc; + return CURLUE_MALFORMED_INPUT; + } + + /* if the new URL is absolute replace the existing with the new. */ + if(Curl_is_absolute_url(url, NULL, 0, + flags & (CURLU_GUESS_SCHEME | CURLU_DEFAULT_SCHEME))) + return parseurl_and_replace(url, u, flags); + + /* if the old URL is incomplete (we cannot get an absolute URL in + 'oldurl'), replace the existing with the new. + Always include "scheme://" to make the URL "complete" */ + uc = curl_url_get(u, CURLUPART_URL, &oldurl, flags& ~CURLU_NO_GUESS_SCHEME); + if(uc == CURLUE_OUT_OF_MEMORY) + return uc; + else if(uc) + return parseurl_and_replace(url, u, flags); + + DEBUGASSERT(oldurl); /* it is set here */ + /* apply the relative part to create a new URL */ + uc = redirect_url(oldurl, url, u, flags); + curlx_free(oldurl); + return uc; +} + +static CURLUcode urlset_clear(CURLU *u, CURLUPart what) +{ + switch(what) { + case CURLUPART_URL: + free_urlhandle(u); + memset(u, 0, sizeof(struct Curl_URL)); + break; + case CURLUPART_SCHEME: + curlx_safefree(u->scheme); + u->guessed_scheme = FALSE; + break; + case CURLUPART_USER: + curlx_safefree(u->user); + break; + case CURLUPART_PASSWORD: + curlx_safefree(u->password); + break; + case CURLUPART_OPTIONS: + curlx_safefree(u->options); + break; + case CURLUPART_HOST: + curlx_safefree(u->host); + break; + case CURLUPART_ZONEID: + curlx_safefree(u->zoneid); + break; + case CURLUPART_PORT: + u->portnum = 0; + curlx_safefree(u->port); + break; + case CURLUPART_PATH: + curlx_safefree(u->path); + break; + case CURLUPART_QUERY: + curlx_safefree(u->query); + u->query_present = FALSE; + break; + case CURLUPART_FRAGMENT: + curlx_safefree(u->fragment); + u->fragment_present = FALSE; + break; + default: + return CURLUE_UNKNOWN_PART; + } + return CURLUE_OK; +} + +static bool allowed_in_path(unsigned char x) +{ + switch(x) { + case '!': + case '$': + case '&': + case '\'': + case '(': + case ')': + case '{': + case '}': + case '[': + case ']': + case '*': + case '+': + case ',': + case ';': + case '=': + case ':': + case '@': + case '/': + return TRUE; + } + return FALSE; +} + +static CURLUcode url_encode_part(struct dynbuf *encp, + const char *part, + bool plusencode, + bool pathmode, + bool equalsencode) +{ + const unsigned char *i; + + for(i = (const unsigned char *)part; *i; i++) { + CURLcode result; + if((*i == ' ') && plusencode) + result = curlx_dyn_addn(encp, "+", 1); + else if(ISUNRESERVED(*i) || + (pathmode && allowed_in_path(*i)) || + ((*i == '=') && equalsencode)) { + if((*i == '=') && equalsencode) + /* only skip the first equals sign */ + equalsencode = FALSE; + result = curlx_dyn_addn(encp, i, 1); + } + else { + unsigned char out[3] = { '%' }; + Curl_hexbyte(&out[1], *i); + result = curlx_dyn_addn(encp, out, 3); + } + if(result) + return cc2cu(result); + } + return CURLUE_OK; +} + +static CURLUcode url_uppercasehex_part(struct dynbuf *encp, + const char *part) +{ + char *p; + CURLcode result = curlx_dyn_add(encp, part); + if(result) + return cc2cu(result); + p = curlx_dyn_ptr(encp); + while(*p) { + /* make sure percent encoded are upper case */ + if((*p == '%') && ISXDIGIT(p[1]) && ISXDIGIT(p[2]) && + (ISLOWER(p[1]) || ISLOWER(p[2]))) { + p[1] = Curl_raw_toupper(p[1]); + p[2] = Curl_raw_toupper(p[2]); + p += 3; + } + else + p++; + } + return CURLUE_OK; +} + +static CURLUcode url_append_query(CURLU *u, struct dynbuf *encp) +{ + /* Append the 'encp' string onto the old query. Add a '&' separator if none + is already present at the end of the existing query */ + + size_t querylen = u->query ? strlen(u->query) : 0; + bool addamperand = querylen && (u->query[querylen - 1] != '&'); + if(querylen) { + struct dynbuf qbuf; + CURLcode result; + const char *newp = curlx_dyn_ptr(encp); + curlx_dyn_init(&qbuf, CURL_MAX_INPUT_LENGTH); + + /* add original query */ + result = curlx_dyn_addn(&qbuf, u->query, querylen); + if(!result && addamperand) + /* add ampersand */ + result = curlx_dyn_addn(&qbuf, "&", 1); + if(!result) + /* add new query part */ + result = curlx_dyn_add(&qbuf, newp); + if(result) + goto nomem; + curlx_dyn_free(encp); + curlx_free(u->query); + u->query = curlx_dyn_ptr(&qbuf); + return CURLUE_OK; +nomem: + curlx_dyn_free(encp); + return cc2cu(result); + } + else { + curlx_free(u->query); + u->query = curlx_dyn_ptr(encp); + } + return CURLUE_OK; +} + +static CURLUcode url_sethost(CURLU *u, struct dynbuf *encp, + bool urlencode, + unsigned int flags) +{ + size_t n = curlx_dyn_len(encp); + bool bad = FALSE; + char *newp = curlx_dyn_ptr(encp); + if(!n) + /* an empty hostname is okay if told so */ + bad = (flags & CURLU_NO_AUTHORITY) ? FALSE : TRUE; + else if(!urlencode) { + /* if the hostname part was not URL encoded here, it was set already URL + encoded so we need to decode it to check */ + size_t dlen; + char *decoded = NULL; + CURLcode result = Curl_urldecode(newp, n, &decoded, &dlen, REJECT_CTRL); + if(result || hostname_check(u, decoded, dlen)) + bad = TRUE; + curlx_free(decoded); + } + else if(hostname_check(u, (char *)CURL_UNCONST(newp), n)) + bad = TRUE; + if(bad) { + curlx_dyn_free(encp); + return CURLUE_BAD_HOSTNAME; + } + return CURLUE_OK; +} + +CURLUcode curl_url_set(CURLU *u, CURLUPart what, + const char *part, unsigned int flags) +{ + char **storep = NULL; + bool urlencode = (flags & CURLU_URLENCODE) ? 1 : 0; + bool plusencode = FALSE; + bool pathmode = FALSE; + bool leadingslash = FALSE; + bool appendquery = FALSE; + bool equalsencode = FALSE; + size_t nalloc; + + if(!u) + return CURLUE_BAD_HANDLE; + if(!part) + /* setting a part to NULL clears it */ + return urlset_clear(u, what); + + nalloc = strlen(part); + if(nalloc > CURL_MAX_INPUT_LENGTH) + /* excessive input length */ + return CURLUE_MALFORMED_INPUT; + + switch(what) { + case CURLUPART_SCHEME: { + CURLUcode status = set_url_scheme(u, part, flags); + if(status) + return status; + storep = &u->scheme; + urlencode = FALSE; /* never */ + break; + } + case CURLUPART_USER: + storep = &u->user; + break; + case CURLUPART_PASSWORD: + storep = &u->password; + break; + case CURLUPART_OPTIONS: + storep = &u->options; + break; + case CURLUPART_HOST: + storep = &u->host; + curlx_safefree(u->zoneid); + break; + case CURLUPART_ZONEID: + storep = &u->zoneid; + break; + case CURLUPART_PORT: + return set_url_port(u, part); + case CURLUPART_PATH: + pathmode = TRUE; + leadingslash = TRUE; /* enforce */ + storep = &u->path; + break; + case CURLUPART_QUERY: + plusencode = urlencode; + appendquery = (flags & CURLU_APPENDQUERY) ? 1 : 0; + equalsencode = appendquery; + storep = &u->query; + u->query_present = TRUE; + break; + case CURLUPART_FRAGMENT: + storep = &u->fragment; + u->fragment_present = TRUE; + break; + case CURLUPART_URL: + return set_url(u, part, nalloc, flags); + default: + return CURLUE_UNKNOWN_PART; + } + DEBUGASSERT(storep); + { + const char *newp = NULL; + struct dynbuf enc; + CURLUcode status; + curlx_dyn_init(&enc, (nalloc * 3) + 1 + leadingslash); + + if(leadingslash && (part[0] != '/')) { + CURLcode result = curlx_dyn_addn(&enc, "/", 1); + if(result) + return cc2cu(result); + } + if(urlencode) + status = url_encode_part(&enc, part, plusencode, pathmode, equalsencode); + else + status = url_uppercasehex_part(&enc, part); + if(!status) { + newp = curlx_dyn_ptr(&enc); + + if(appendquery && newp) + return url_append_query(u, &enc); + else if(what == CURLUPART_HOST) + status = url_sethost(u, &enc, urlencode, flags); + } + if(status) + return status; + + curlx_free(*storep); + *storep = (char *)CURL_UNCONST(newp); + } + return CURLUE_OK; +} + +bool Curl_url_same_origin(CURLU *base, CURLU *href) +{ + const struct Curl_scheme *s = NULL; + + /* base must be an absolute URL */ + if(!base->scheme || !base->host) + return FALSE; + if(href->scheme && !curl_strequal(base->scheme, href->scheme)) + return FALSE; + if(href->host) { + if(!curl_strequal(base->host, href->host)) + return FALSE; + if(!curl_strequal(base->zoneid ? base->zoneid : "", + href->zoneid ? href->zoneid : "")) + return FALSE; + if(!curl_strequal(base->port, href->port)) { + /* This may still match if only one has an explicit port + * and it is the default for the scheme. */ + if(base->port && href->port) + return FALSE; + + s = Curl_get_scheme(base->scheme); + if(!s) /* Cannot match default port for unknown scheme */ + return FALSE; + + /* The port which is set must be the default one */ + if((base->port && (base->portnum != s->defport)) || + (href->port && (href->portnum != s->defport))) + return FALSE; + } + } + else if(href->port) /* no host in href, then there must be no port */ + return FALSE; + return TRUE; +} diff --git a/3rdparty/curl-8.21.0/lib/urldata.h b/3rdparty/curl-8.21.0/lib/urldata.h new file mode 100644 index 0000000000..d4d336d8db --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/urldata.h @@ -0,0 +1,1301 @@ +#ifndef HEADER_CURL_URLDATA_H +#define HEADER_CURL_URLDATA_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +/* This file is for lib internal stuff */ +#include "curl_setup.h" + +#define CURL_DEFAULT_USER "anonymous" +#define CURL_DEFAULT_PASSWORD "ftp@example.com" + +#if !defined(_WIN32) && !defined(MSDOS) +/* do FTP line-end CRLF => LF conversions on platforms that prefer LF-only. It + also means: keep CRLF line endings on the CRLF platforms */ +#define CURL_PREFER_LF_LINEENDS +#endif + +#define DEFAULT_CONNCACHE_SIZE 5 + +/* length of longest IPv6 address string including the trailing null */ +#define MAX_IPADR_LEN sizeof("ffff:ffff:ffff:ffff:ffff:ffff:255.255.255.255") + +/* Max string input length is a precaution against abuse and to detect junk + input easier and better. */ +#define CURL_MAX_INPUT_LENGTH 8000000 + +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include +#endif + +#include "curlx/timeval.h" + +#include "asyn.h" +#include "cookie.h" +#include "creds.h" +#include "psl.h" +#include "formdata.h" +#include "http_chunks.h" /* for the structs and enum stuff */ +#include "hostip.h" +#include "hash.h" +#include "peer.h" +#include "proxy.h" +#include "splay.h" +#include "curlx/dynbuf.h" +#include "bufref.h" +#include "dynhds.h" +#include "request.h" +#include "ratelimit.h" +#include "netrc.h" +#include "vtls/vtls_config.h" + +/* On error return, the value of `pnwritten` has no meaning */ +typedef CURLcode (Curl_send)(struct Curl_easy *data, /* transfer */ + int sockindex, /* socketindex */ + const uint8_t *buf, /* data to write */ + size_t len, /* amount to send */ + bool eos, /* last chunk */ + size_t *pnwritten); /* how much sent */ + +/* On error return, the value of `pnread` has no meaning */ +typedef CURLcode (Curl_recv)(struct Curl_easy *data, /* transfer */ + int sockindex, /* socketindex */ + char *buf, /* store data here */ + size_t len, /* max amount to read */ + size_t *pnread); /* how much received */ + +#include "mime.h" +#include "protocol.h" +#include "ftp.h" +#include "http.h" +#include "smb.h" +#include "mqtt.h" +#include "ftplistparser.h" +#include "multihandle.h" +#include "cf-socket.h" + +#ifdef HAVE_GSSAPI +# ifdef HAVE_GSSGNU +# include +# elif defined(HAVE_GSSAPI_H) +# include +# else /* MIT Kerberos */ +# include +# include /* for GSS_C_CHANNEL_BOUND_FLAG in 1.19+ */ +# endif +#endif + +#ifdef USE_LIBSSH2 +#include +#include +#endif /* USE_LIBSSH2 */ + +#define READBUFFER_SIZE CURL_MAX_WRITE_SIZE +#define READBUFFER_MAX CURL_MAX_READ_SIZE +#define READBUFFER_MIN 1024 + +/* The default upload buffer size, should not be smaller than + CURL_MAX_WRITE_SIZE, as it needs to hold a full buffer as could be sent in + a write callback. + + The size was 16KB for many years but was bumped to 64KB because it makes + libcurl able to do significantly faster uploads in some circumstances. Even + larger buffers can help further, but this is deemed a fair memory/speed + compromise. */ +#define UPLOADBUFFER_DEFAULT 65536 +#define UPLOADBUFFER_MAX (2 * 1024 * 1024) +#define UPLOADBUFFER_MIN CURL_MAX_WRITE_SIZE + +#define CURLEASY_MAGIC_NUMBER 0xc0dedbadU +#ifdef DEBUGBUILD +/* On a debug build, we want to fail hard on easy handles that + * are not NULL, but no longer have the MAGIC touch. This gives + * us early warning on things only discovered by valgrind otherwise. */ +#define GOOD_EASY_HANDLE(x) \ + (((x) && ((x)->magic == CURLEASY_MAGIC_NUMBER)) ? TRUE : \ + (DEBUGASSERT(!(x)), FALSE)) +#else +#define GOOD_EASY_HANDLE(x) \ + ((x) && ((x)->magic == CURLEASY_MAGIC_NUMBER)) +#endif + +#ifdef USE_WINDOWS_SSPI +#include "curl_sspi.h" +#endif + +#ifndef CURL_DISABLE_DIGEST_AUTH +/* Struct used for Digest challenge-response authentication */ +struct digestdata { + struct Curl_creds *creds; + struct Curl_peer *origin; +#ifdef USE_WINDOWS_SSPI + BYTE *input_token; + size_t input_token_len; + CtxtHandle *http_context; +#else + char *nonce; + char *cnonce; + char *realm; + char *opaque; + char *qop; + char *algorithm; + int nc; /* nonce count */ + uint8_t algo; + BIT(stale); /* set true for re-negotiation */ + BIT(userhash); +#endif +}; +#endif + +typedef enum { + NTLMSTATE_NONE, + NTLMSTATE_TYPE1, + NTLMSTATE_TYPE2, + NTLMSTATE_TYPE3, + NTLMSTATE_LAST +} curlntlm; + +typedef enum { + GSS_AUTHNONE, + GSS_AUTHRECV, + GSS_AUTHSENT, + GSS_AUTHDONE, + GSS_AUTHSUCC +} curlnegotiate; + +/* + * Boolean values that concerns this connection. + */ +struct ConnectBits { + BIT(connect_only); +#ifndef CURL_DISABLE_PROXY + BIT(origin_is_proxy); /* if set, the connection's origin is a proxy */ +#endif + /* always modify bits.close with the connclose() and connkeep() macros! */ + BIT(close); /* if set, we close the connection after this request */ + BIT(reuse); /* if set, this is a reused connection */ + BIT(altused); /* this is an alt-svc "redirect" */ + BIT(ipv6); /* we communicate with a site using an IPv6 address */ + BIT(do_more); /* this is set TRUE if the ->curl_do_more() function is + supposed to be called, after ->curl_do() */ + BIT(protoconnstart);/* the protocol layer has STARTED its operation after + the TCP layer connect */ + BIT(retry); /* this connection is about to get closed and then + re-attempted at another connection. */ +#ifndef CURL_DISABLE_FTP + BIT(ftp_use_epsv); /* As set with CURLOPT_FTP_USE_EPSV, but if we find out + EPSV does not work we disable it for the forthcoming + requests */ + BIT(ftp_use_eprt); /* As set with CURLOPT_FTP_USE_EPRT, but if we find out + EPRT does not work we disable it for the forthcoming + requests */ + BIT(ftp_use_data_ssl); /* Enabled SSL for the data connection */ +#endif + BIT(bound); /* set true if bind() has already been done on this socket/ + connection */ + BIT(upgrade_in_progress); /* protocol upgrade is in progress */ + BIT(multiplex); /* connection is multiplexed */ + BIT(tcp_fastopen); /* use TCP Fast Open */ + BIT(tls_enable_alpn); /* TLS ALPN extension? */ + BIT(sock_accepted); /* TRUE if the SECONDARYSOCKET was created with + accept() */ + BIT(parallel_connect); /* set TRUE when a parallel connect attempt has + started (happy eyeballs) */ + BIT(aborted); /* connection was aborted, e.g. in unclean state */ + BIT(no_reuse); /* connection should not be reused */ + BIT(shutdown_handler); /* connection shutdown: handler shut down */ + BIT(shutdown_filters); /* connection shutdown: filters shut down */ + BIT(in_cpool); /* connection is kept in a connection pool */ + BIT(dns_resolved); /* DNS records for connection were resolved */ +}; + +struct hostname { + char *rawalloc; /* allocated "raw" version of the name */ + char *encalloc; /* allocated IDN-encoded version of the name */ + char *name; /* name to use internally, might be encoded, might be raw */ + const char *dispname; /* name to display, as 'name' might be encoded */ +}; + +#define FIRSTSOCKET 0 +#define SECONDARYSOCKET 1 + +#define TRNSPRT_NONE 0 +#define TRNSPRT_TCP 3 +#define TRNSPRT_UDP 4 +#define TRNSPRT_QUIC 5 +#define TRNSPRT_UNIX 6 + +#define TRNSPRT_IS_DGRAM(x) (((x) == TRNSPRT_UDP) || ((x) == TRNSPRT_QUIC)) + +struct ip_quadruple { + char remote_ip[MAX_IPADR_LEN]; + char local_ip[MAX_IPADR_LEN]; + uint16_t remote_port; + uint16_t local_port; + uint8_t transport; +}; + +#define CUR_IP_QUAD_HAS_PORTS(x) \ + (((x)->transport == TRNSPRT_TCP) || \ + ((x)->transport == TRNSPRT_UDP) || \ + ((x)->transport == TRNSPRT_QUIC)) + +/* + * The connectdata struct contains all fields and variables that should be + * unique for an entire connection. + */ +struct connectdata { + struct Curl_llist_node cpool_node; /* conncache lists */ + struct Curl_llist_node cshutdn_node; /* cshutdn list */ + + curl_closesocket_callback fclosesocket; /* function closing the socket(s) */ + void *closesocket_client; + + /* This is used by the connection pool logic. If this returns TRUE, this + handle is still used by one or more easy handles and can only used by any + other easy handle without careful consideration (== only for + multiplexing) and it cannot be used by another multi handle! */ +#define CONN_INUSE(c) (!!(c)->attached_xfers) + + /**** Fields set when inited and not modified again */ + curl_off_t connection_id; /* Contains a unique number to make it easier to + track the connections in the log output */ + char *destination; /* string carrying normalized hostname+port+scope */ + + /* `meta_hash` is a general key-value store for implementations + * with the lifetime of the connection. + * Elements need to be added with their own destructor to be invoked when + * the connection is cleaned up (see Curl_hash_add2()).*/ + struct Curl_hash meta_hash; + + /* Who the connection is talking to, ultimately */ + struct Curl_peer *origin; /* connection ultimately talks to this */ + struct Curl_peer *via_peer; /* if set, connection really talks to this */ + struct Curl_peer *origin2; /* origin of SECONDARYSOCKET */ + struct Curl_peer *via_peer2; /* peer of SECONDARYSOCKET */ +#ifndef CURL_DISABLE_PROXY + struct proxy_info socks_proxy; + struct proxy_info http_proxy; +#endif + struct Curl_creds *creds; /* When connection itself is tied to credentials */ + struct Curl_peer *creds_origin; /* origin tied credentials are for */ + char *options; /* options string, allocated */ + struct curltime created; /* creation time */ + struct curltime lastused; /* when returned to the connection pool as idle */ + + /* A connection can have one or two sockets and connection filters. + * The protocol using the 2nd one is FTP for CONTROL+DATA sockets */ + curl_socket_t sock[2]; + struct Curl_cfilter *cfilter[2]; /* connection filters */ + Curl_recv *recv[2]; + Curl_send *send[2]; + int recv_idx; /* on which socket index to receive, default 0 */ + int send_idx; /* on which socket index to send, default 0 */ + +#define CONN_SOCK_IDX_VALID(i) (((i) >= 0) && ((i) < 2)) + + struct { + struct curltime start[2]; /* when filter shutdown started */ + timediff_t timeout_ms; /* 0 means no timeout */ + } shutdown; + + struct ssl_primary_config ssl_config; +#ifndef CURL_DISABLE_PROXY + struct ssl_primary_config proxy_ssl_config; +#endif + struct ConnectBits bits; /* various state-flags for this connection */ + + const struct Curl_scheme *scheme; /* Connection's protocol handler */ + const struct Curl_scheme *given; /* The protocol first given */ + + /* Protocols can use a custom keepalive mechanism to keep connections alive. + This allows those protocols to track the last time the keepalive mechanism + was used on this connection. */ + struct curltime keepalive; + + /* A connection cache from a SHARE might be used in several multi handles. + * We MUST not reuse connections that are running in another multi, + * for concurrency reasons. That multi might run in another thread. + * `attached_multi` is set by the first transfer attached and cleared + * when the last one is detached. + * NEVER call anything on this multi, check for equality. */ + struct Curl_multi *attached_multi; + + /*************** Request - specific items ************/ +#if defined(USE_WINDOWS_SSPI) && defined(SECPKG_ATTR_ENDPOINT_BINDINGS) + CtxtHandle *sslContext; /* mingw-w64 v9+, MS SDK 7.0A/VS2010+ */ +#endif + +#ifdef USE_NTLM + curlntlm http_ntlm_state; + curlntlm proxy_ntlm_state; +#endif + +#ifdef USE_SPNEGO + curlnegotiate http_negotiate_state; + curlnegotiate proxy_negotiate_state; +#endif + + /* When this connection is created, store the conditions for the local end + bind. This is stored before the actual bind and before any connection is + made and will serve the purpose of being used for comparison reasons so + that subsequent bound-requested connections are not accidentally reusing + wrong connections. */ + char *localdev; +#if defined(HAVE_GSSAPI) || defined(USE_WINDOWS_SSPI) + int socks5_gssapi_enctype; +#endif + uint32_t attached_xfers; /* # of attached easy handles */ + +#ifdef USE_IPV6 + uint32_t scope_id; /* Scope id for IPv6 */ +#endif + uint16_t localportrange; + uint16_t localport; + uint8_t transport_wanted; /* one of the TRNSPRT_* defines. Not necessarily + the transport the connection ends using due to Alt-Svc and happy + eyeballing. Use Curl_conn_get_transport() for actual value once the + connection is set up. */ + uint8_t ip_version; /* copied from the Curl_easy at creation time */ + /* HTTP version last responded with by the server or negotiated via ALPN. + * 0 at start, then one of 09, 10, 11, etc. */ + uint8_t httpversion_seen; + uint8_t gssapi_delegation; /* inherited from set.gssapi_delegation */ +}; + +#ifndef CURL_DISABLE_PROXY +#define CURL_CONN_HOST_DISPNAME(c) \ + ((c)->socks_proxy.peer ? (c)->socks_proxy.peer->user_hostname : \ + (c)->http_proxy.peer ? (c)->http_proxy.peer->user_hostname : \ + (c)->via_peer ? (c)->via_peer->user_hostname : \ + (c)->origin->user_hostname) +#else +#define CURL_CONN_HOST_DISPNAME(c) \ + ((c)->via_peer ? (c)->via_peer->user_hostname : (c)->origin->user_hostname) +#endif + +/* The end of connectdata. */ + +/* + * Struct to keep statistical and informational data. + * All variables in this struct must be initialized/reset in Curl_initinfo(). + */ +struct PureInfo { + int httpcode; /* Recent HTTP, FTP, RTSP or SMTP response code */ + int httpproxycode; /* response code from proxy when received separate */ + int httpversion; /* the http version number X.Y = X*10+Y */ + time_t filetime; /* If requested, this is might get set. Set to -1 if the + time was unretrievable. */ + curl_off_t request_size; /* the amount of bytes sent in the request(s) */ + curl_off_t numconnects; /* how many new connections libcurl created */ + uint32_t proxyauthavail; /* what proxy auth types were announced */ + uint32_t httpauthavail; /* what host auth types were announced */ + uint32_t proxyauthpicked; /* selected proxy auth type */ + uint32_t httpauthpicked; /* selected host auth type */ + char *contenttype; /* the content type of the object */ + char *wouldredirect; /* URL this would have been redirected to if asked to */ + curl_off_t retry_after; /* info from Retry-After: header */ + uint32_t header_size; /* size of read header(s) in bytes */ + + /* PureInfo primary ip_quadruple is copied over from the connectdata + struct in order to allow curl_easy_getinfo() to return this information + even when the session handle is no longer associated with a connection, + and also allow curl_easy_reset() to clear this information from the + session handle without disturbing information which is still alive, and + that might be reused, in the connection pool. */ + struct ip_quadruple primary; + const char *conn_scheme; + uint32_t conn_protocol; + struct curl_certinfo certs; /* info about the certs. Asked for with + CURLOPT_CERTINFO / CURLINFO_CERTINFO */ + CURLproxycode pxcode; + BIT(timecond); /* set to TRUE if the time condition did not match, which + thus made the document NOT get fetched */ + BIT(used_proxy); /* the transfer used a proxy */ +}; + +struct pgrs_dir { + curl_off_t total_size; /* total expected bytes */ + curl_off_t cur_size; /* transferred bytes so far */ + curl_off_t speed; /* bytes per second transferred */ + struct Curl_rlimit rlimit; /* speed limiting / pausing */ +}; + +struct Progress { + struct curltime now; /* current time of processing */ + time_t lastshow; /* time() of the last displayed progress meter or NULL to + force redraw at next call */ + struct pgrs_dir ul; + struct pgrs_dir dl; + curl_off_t deliver; /* amount of data delivered to application */ + + curl_off_t current_speed; /* uses the currently fastest transfer */ + curl_off_t earlydata_sent; + + timediff_t timespent; + + timediff_t t_postqueue; + timediff_t t_nslookup; + timediff_t t_connect; + timediff_t t_appconnect; + timediff_t t_pretransfer; + timediff_t t_posttransfer; + timediff_t t_starttransfer; + timediff_t t_redirect; + + struct curltime start; + struct curltime t_startsingle; + struct curltime t_startop; + struct curltime t_startqueue; + struct curltime t_acceptdata; + +#define CURL_SPEED_RECORDS (5 + 1) /* 6 entries for 5 seconds */ + + curl_off_t speed_amount[CURL_SPEED_RECORDS]; + struct curltime speed_time[CURL_SPEED_RECORDS]; + uint32_t speeder_c; + BIT(hide); + BIT(ul_size_known); + BIT(dl_size_known); + BIT(headers_out); /* when the headers have been written */ + BIT(callback); /* set when progress callback is used */ + BIT(is_t_startransfer_set); +}; + +typedef enum { + RTSPREQ_NONE, /* first in list */ + RTSPREQ_OPTIONS, + RTSPREQ_DESCRIBE, + RTSPREQ_ANNOUNCE, + RTSPREQ_SETUP, + RTSPREQ_PLAY, + RTSPREQ_PAUSE, + RTSPREQ_TEARDOWN, + RTSPREQ_GET_PARAMETER, + RTSPREQ_SET_PARAMETER, + RTSPREQ_RECORD, + RTSPREQ_RECEIVE, + RTSPREQ_LAST /* last in list */ +} Curl_RtspReq; + +struct auth { + uint32_t want; /* Bitmask set to the authentication methods wanted by app + (with CURLOPT_HTTPAUTH or CURLOPT_PROXYAUTH). */ + uint32_t picked; + uint32_t avail; /* Bitmask for what the server reports to support for this + resource */ + BIT(done); /* TRUE when the auth phase is done and ready to do the + actual request */ + BIT(multipass); /* TRUE if this is not yet authenticated but within the + auth multipass negotiation */ +}; + +#ifdef USE_NGHTTP2 +struct Curl_data_prio_node { + struct Curl_data_prio_node *next; + struct Curl_easy *data; +}; +#endif + +/** + * Priority information for an easy handle in relation to others + * on the same connection. + */ +struct Curl_data_priority { + int weight; +}; + +/* Timers */ +typedef enum { + EXPIRE_100_TIMEOUT, + EXPIRE_ASYNC_NAME, + EXPIRE_CONNECTTIMEOUT, + EXPIRE_DNS_PER_NAME, /* family1 */ + EXPIRE_DNS_PER_NAME2, /* family2 */ + EXPIRE_HAPPY_EYEBALLS_DNS, /* See asyn-ares.c */ + EXPIRE_HAPPY_EYEBALLS, + EXPIRE_MULTI_PENDING, + EXPIRE_SPEEDCHECK, + EXPIRE_TIMEOUT, + EXPIRE_TOOFAST, + EXPIRE_QUIC, + EXPIRE_FTP_ACCEPT, + EXPIRE_ALPN_EYEBALLS, + EXPIRE_SHUTDOWN, + EXPIRE_LAST /* not an actual timer, used as a marker only */ +} expire_id; + +/* + * One instance for each timeout an easy handle can set. + */ +struct time_node { + struct Curl_llist_node list; + struct curltime time; + expire_id eid; +}; + +/* individual pieces of the URL */ +struct urlpieces { + char *scheme; + char *hostname; + char *port; + char *user; + char *password; + char *options; + char *path; + char *query; +}; + +struct UrlState { + /* buffers to store authentication data in, as parsed from input options */ + struct curltime keeps_speed; /* for the progress meter really */ + + curl_off_t lastconnect_id; /* The last connection, -1 if undefined */ + curl_off_t recent_conn_id; /* The most recent connection used, might no + * longer exist */ + struct dynbuf headerb; /* buffer to store headers in */ +#ifndef CURL_DISABLE_HSTS + struct curl_slist *hstslist; /* list of HSTS files set by + curl_easy_setopt(HSTS) calls */ +#endif + curl_off_t current_speed; /* the ProgressShow() function sets this, + bytes / second */ + + /* Origin of the initial (e.g. not followed) request of a transfer. + Credentials from CURLOPT_* are only valid for this origin. + Always set once a transfer starts searching for connections. */ + struct Curl_peer *initial_origin; + /* Current origin of the transfer, changes to origin of follow + * requests. */ + struct Curl_peer *origin; + + int os_errno; /* filled in with errno whenever an error occurs */ + int requests; /* request counter: redirects + authentication retakes */ +#ifdef HAVE_SIGNAL + /* storage for the previous bag^H^H^HSIGPIPE signal handler :-) */ + void (*prev_signal)(int sig); +#endif +#ifndef CURL_DISABLE_DIGEST_AUTH + char *envproxy; /* last proxy string used for proxy-related state */ + struct digestdata digest; /* state data for host Digest auth */ + struct digestdata proxydigest; /* state data for proxy Digest auth */ +#endif + struct auth authhost; /* auth details for host */ + struct auth authproxy; /* auth details for proxy */ + +#ifdef USE_CURL_ASYNC + struct Curl_resolv_async *async; /* asynchronous name resolver data */ +#endif + +#ifdef USE_OPENSSL + /* void instead of ENGINE to avoid bleeding OpenSSL into this header */ + void *engine; + /* void instead of OSSL_PROVIDER */ + void *provider; + void *baseprov; + void *libctx; + char *propq; /* for a provider */ + + BIT(provider_loaded); +#endif /* USE_OPENSSL */ + struct curltime expiretime; /* set this with Curl_expire() only */ + struct Curl_tree timenode; /* for the splay stuff */ + struct Curl_llist timeoutlist; /* list of pending timeouts */ + struct time_node expires[EXPIRE_LAST]; /* nodes for each expire type */ + + /* a place to store the most recently set (S)FTP entrypath */ + char *most_recent_ftp_entrypath; + char *range; /* range, if used. See README for detailed specification on + this syntax. */ + curl_off_t resume_from; /* continue [ftp] transfer from here */ + +#ifndef CURL_DISABLE_RTSP + /* This RTSP state information survives requests and connections */ + uint32_t rtsp_next_client_CSeq; /* the session's next client CSeq */ + uint32_t rtsp_next_server_CSeq; /* the session's next server CSeq */ + uint32_t rtsp_CSeq_recv; /* most recent CSeq received */ + uint8_t rtp_channel_mask[32]; /* for the correctness checking of the + interleaved data */ +#endif + + curl_off_t infilesize; /* size of file to upload, -1 means unknown. + Copied from set.filesize at start of operation */ +#if defined(USE_HTTP2) || defined(USE_HTTP3) + struct Curl_data_priority priority; /* shallow copy of data->set */ +#endif + + curl_read_callback fread_func; /* read callback/function */ + void *in; /* CURLOPT_READDATA */ + CURLU *uh; /* URL handle for the current parsed URL */ + struct urlpieces up; + struct bufref url; /* work URL, initially copied from UserDefined */ + struct bufref referer; /* referer string */ + struct curl_slist *resolve; /* set to point to the set.resolve list when + this should be dealt with in pretransfer */ +#ifndef CURL_DISABLE_HTTP + curl_mimepart *mimepost; +#ifndef CURL_DISABLE_FORM_API + curl_mimepart *formp; /* storage for old API form-posting, allocated on + demand */ +#endif + size_t trailers_bytes_sent; + struct dynbuf trailers_buf; /* a buffer containing the compiled trailing + headers */ + struct Curl_llist httphdrs; /* received headers */ + struct curl_header headerout[2]; /* for external purposes */ + struct Curl_header_store *prevhead; /* the latest added header */ +#endif +#ifndef CURL_DISABLE_COOKIES + struct curl_slist *cookielist; /* list of cookie files set by + curl_easy_setopt(COOKIEFILE) calls */ +#endif + +#ifdef CURLVERBOSE + struct curl_trc_feat *feat; /* opt. trace feature transfer is part of */ +#endif + +#ifndef CURL_DISABLE_NETRC + struct store_netrc netrc; +#endif + + struct Curl_creds *creds; /* Credentials for the origin only */ + + /* Dynamically allocated strings, MUST be freed before this struct is + killed. */ + struct dynamically_allocated_data { + char *uagent; + char *accept_encoding; + char *rangeline; + char *ref; + char *host; +#ifndef CURL_DISABLE_RTSP + char *rtsp_transport; +#endif + } aptr; +#ifndef CURL_DISABLE_HTTP + struct http_negotiation http_neg; +#endif + uint16_t followlocation; /* redirect counter */ + uint8_t retrycount; /* number of retries on a new connection, up to + CONN_MAX_RETRIES */ + uint8_t httpreq; /* Curl_HttpReq; what kind of HTTP request (if any) + is this */ + + BIT(really_alive); /* transfer is really alive in multi, passed INIT */ + BIT(this_is_a_follow); /* this is a followed Location: request */ + BIT(refused_stream); /* this was refused, try again */ + BIT(errorbuf); /* Set to TRUE if the error buffer is already filled in. + This must be set to FALSE every time _easy_perform() is + called. */ + BIT(allow_port); /* Is set.use_port allowed to take effect or not. This + is always set TRUE when curl_easy_perform() is called. */ + BIT(authproblem); /* TRUE if there is some problem authenticating */ + /* set after initial USER failure, to prevent an authentication loop */ + BIT(wildcardmatch); /* enable wildcard matching */ + BIT(disableexpect); /* TRUE if Expect: is disabled due to a previous + 417 response */ + BIT(use_range); + BIT(rangestringalloc); /* the range string is malloc()'ed */ + BIT(done); /* set to FALSE when Curl_init_do() is called and set to TRUE + when multi_done() is called, to prevent multi_done() to get + invoked twice when the multi interface is used. */ +#ifndef CURL_DISABLE_COOKIES + BIT(cookie_engine); +#endif + BIT(prefer_ascii); /* ASCII rather than binary */ +#ifdef CURL_LIST_ONLY_PROTOCOL + BIT(list_only); /* list directory contents */ +#endif + BIT(wildcard_resolve); /* Set to true if any resolve change is a wildcard */ + BIT(upload); /* upload request */ + BIT(internal); /* internal: true if this easy handle was created for + internal use and the user does not have ownership of the + handle. */ + BIT(http_ignorecustom); /* ignore custom method from now */ +#ifndef CURL_DISABLE_HTTP + BIT(http_hd_te); /* Added HTTP header TE: */ + BIT(http_hd_upgrade); /* Added HTTP header Upgrade: */ + BIT(http_hd_h2_settings); /* Added HTTP header H2Settings: */ + BIT(maybe_folded); + BIT(leading_unfold); /* unfold started, this is the leading bytes */ +#endif +}; + +/* + * This 'UserDefined' struct must only contain data that is set once to go + * for many (perhaps) independent connections. Values that are generated or + * calculated internally for the "session handle" MUST be defined within the + * 'struct UrlState' instead. The only exceptions MUST note the changes in + * the 'DynamicStatic' struct. + * Character pointer fields point to dynamic storage, unless otherwise stated. + */ + +struct Curl_multi; /* declared in multihandle.c */ + +enum dupstring { + STRING_CERT, /* client certificate filename */ + STRING_CERT_TYPE, /* format for certificate (default: PEM)*/ + STRING_KEY, /* private key filename */ + STRING_KEY_PASSWD, /* plain text private key password */ + STRING_KEY_TYPE, /* format for private key (default: PEM) */ + STRING_SSL_CAPATH, /* CA directory name (does not work on Windows) */ + STRING_SSL_CAFILE, /* certificate file to verify peer against */ + STRING_SSL_PINNEDPUBLICKEY, /* public key file to verify peer against */ + STRING_SSL_CIPHER_LIST, /* list of ciphers to use */ + STRING_SSL_CIPHER13_LIST, /* list of TLS 1.3 ciphers to use */ + STRING_SSL_CRLFILE, /* CRL file to check certificate */ + STRING_SSL_ISSUERCERT, /* issuer cert file to check certificate */ + STRING_SERVICE_NAME, /* Service name */ +#ifndef CURL_DISABLE_PROXY + STRING_CERT_PROXY, /* client certificate filename */ + STRING_CERT_TYPE_PROXY, /* format for certificate (default: PEM)*/ + STRING_KEY_PROXY, /* private key filename */ + STRING_KEY_PASSWD_PROXY, /* plain text private key password */ + STRING_KEY_TYPE_PROXY, /* format for private key (default: PEM) */ + STRING_SSL_CAPATH_PROXY, /* CA directory name (does not work on Windows) */ + STRING_SSL_CAFILE_PROXY, /* certificate file to verify peer against */ + STRING_SSL_PINNEDPUBLICKEY_PROXY, /* public key file to verify proxy */ + STRING_SSL_CIPHER_LIST_PROXY, /* list of ciphers to use */ + STRING_SSL_CIPHER13_LIST_PROXY, /* list of TLS 1.3 ciphers to use */ + STRING_SSL_CRLFILE_PROXY, /* CRL file to check certificate */ + STRING_SSL_ISSUERCERT_PROXY, /* issuer cert file to check certificate */ + STRING_PROXY_SERVICE_NAME, /* Proxy service name */ +#endif +#ifndef CURL_DISABLE_COOKIES + STRING_COOKIE, /* HTTP cookie string to send */ + STRING_COOKIEJAR, /* dump all cookies to this file */ +#endif + STRING_CUSTOMREQUEST, /* HTTP/FTP/RTSP request/method to use */ + STRING_DEFAULT_PROTOCOL, /* Protocol to use when the URL does not specify */ + STRING_DEVICE, /* local network interface/address to use */ + STRING_INTERFACE, /* local network interface to use */ + STRING_BINDHOST, /* local address to use */ + STRING_ENCODING, /* Accept-Encoding string */ +#ifndef CURL_DISABLE_FTP + STRING_FTP_ACCOUNT, /* ftp account data */ + STRING_FTP_ALTERNATIVE_TO_USER, /* command to send if USER/PASS fails */ + STRING_FTPPORT, /* port to send with the FTP PORT command */ +#endif +#ifndef CURL_DISABLE_NETRC + STRING_NETRC_FILE, /* if not NULL, use this instead of trying to find + $HOME/.netrc */ +#endif +#ifndef CURL_DISABLE_PROXY + STRING_PROXY, /* proxy to use */ + STRING_PRE_PROXY, /* pre socks proxy to use */ +#endif + STRING_SET_RANGE, /* range, if used */ + STRING_SET_REFERER, /* custom string for the HTTP referer field */ + STRING_SET_URL, /* what original URL to work on */ + STRING_USERAGENT, /* User-Agent string */ + STRING_SSL_ENGINE, /* name of SSL engine */ + STRING_USERNAME, /* , if used */ + STRING_PASSWORD, /* , if used */ + STRING_OPTIONS, /* , if used */ +#ifndef CURL_DISABLE_PROXY + STRING_PROXYUSERNAME, /* Proxy , if used */ + STRING_PROXYPASSWORD, /* Proxy , if used */ + STRING_NOPROXY, /* List of hosts which should not use the proxy, if + used */ +#endif +#ifndef CURL_DISABLE_RTSP + STRING_RTSP_SESSION_ID, /* Session ID to use */ + STRING_RTSP_STREAM_URI, /* Stream URI for this request */ + STRING_RTSP_TRANSPORT, /* Transport for this session */ +#endif +#ifdef USE_SSH + STRING_SSH_PRIVATE_KEY, /* path to the private key file for auth */ + STRING_SSH_PUBLIC_KEY, /* path to the public key file for auth */ + STRING_SSH_HOST_PUBLIC_KEY_MD5, /* md5 of host public key in ASCII hex */ + STRING_SSH_HOST_PUBLIC_KEY_SHA256, /* sha256 of host public key in base64 */ + STRING_SSH_KNOWNHOSTS, /* filename of knownhosts file */ +#endif +#ifndef CURL_DISABLE_SMTP + STRING_MAIL_FROM, + STRING_MAIL_AUTH, +#endif +#ifdef USE_TLS_SRP + STRING_TLSAUTH_USERNAME, /* TLS auth */ + STRING_TLSAUTH_PASSWORD, /* TLS auth */ +#ifndef CURL_DISABLE_PROXY + STRING_TLSAUTH_USERNAME_PROXY, /* TLS auth */ + STRING_TLSAUTH_PASSWORD_PROXY, /* TLS auth */ +#endif +#endif + STRING_BEARER, /* , if used */ +#ifdef USE_UNIX_SOCKETS + STRING_UNIX_SOCKET_PATH, /* path to Unix socket, if used */ +#endif + STRING_TARGET, /* CURLOPT_REQUEST_TARGET */ +#ifndef CURL_DISABLE_DOH + STRING_DOH, /* CURLOPT_DOH_URL */ +#endif +#ifndef CURL_DISABLE_ALTSVC + STRING_ALTSVC, /* CURLOPT_ALTSVC */ +#endif +#ifndef CURL_DISABLE_HSTS + STRING_HSTS, /* CURLOPT_HSTS */ +#endif + STRING_SASL_AUTHZID, /* CURLOPT_SASL_AUTHZID */ +#ifdef USE_ARES + STRING_DNS_SERVERS, + STRING_DNS_INTERFACE, + STRING_DNS_LOCAL_IP4, + STRING_DNS_LOCAL_IP6, +#endif + STRING_SSL_EC_CURVES, +#ifndef CURL_DISABLE_AWS + STRING_AWS_SIGV4, /* Parameters for V4 signature */ +#endif +#ifndef CURL_DISABLE_PROXY + STRING_HAPROXY_CLIENT_IP, /* CURLOPT_HAPROXY_CLIENT_IP */ +#endif + STRING_ECH_CONFIG, /* CURLOPT_ECH_CONFIG */ + STRING_ECH_PUBLIC, /* CURLOPT_ECH_PUBLIC */ + STRING_SSL_SIGNATURE_ALGORITHMS, /* CURLOPT_SSL_SIGNATURE_ALGORITHMS */ + + /* -- end of null-terminated strings -- */ + + STRING_LASTZEROTERMINATED, + + /* -- below this are pointers to binary data that cannot be strdup'ed. --- */ + + STRING_COPYPOSTFIELDS, /* if POST, set the fields' values here */ + + STRING_LAST /* not used, an end-of-list marker */ +}; + +enum dupblob { + BLOB_CERT, + BLOB_KEY, + BLOB_SSL_ISSUERCERT, + BLOB_CAINFO, +#ifndef CURL_DISABLE_PROXY + BLOB_CERT_PROXY, + BLOB_KEY_PROXY, + BLOB_SSL_ISSUERCERT_PROXY, + BLOB_CAINFO_PROXY, +#endif + BLOB_LAST +}; + +struct UserDefined { + FILE *err; /* the stderr user data goes here */ + void *debugdata; /* the data that will be passed to fdebug */ + char *errorbuffer; /* (Static) store failure messages in here */ + void *out; /* CURLOPT_WRITEDATA */ + void *in_set; /* CURLOPT_READDATA */ + void *writeheader; /* write the header to this if non-NULL */ + uint32_t httpauth; /* kind of HTTP authentication to use (bitmask) */ + uint32_t proxyauth; /* kind of proxy authentication to use (bitmask) */ + void *postfields; /* if POST, set the fields' values here */ + curl_seek_callback seek_func; /* function that seeks the input */ + curl_off_t postfieldsize; /* if POST, this might have a size to use instead + of strlen(), and then the data *may* be binary + (contain zero bytes) */ + curl_write_callback fwrite_func; /* function that stores the output */ + curl_write_callback fwrite_header; /* function that stores headers */ + curl_write_callback fwrite_rtp; /* function that stores interleaved RTP */ + curl_read_callback fread_func_set; /* function that reads the input */ + curl_progress_callback fprogress; /* OLD and deprecated progress callback */ + curl_xferinfo_callback fxferinfo; /* progress callback */ + curl_debug_callback fdebug; /* function that write informational data */ + curl_ioctl_callback ioctl_func; /* function for I/O control */ + curl_sockopt_callback fsockopt; /* function for setting socket options */ + void *sockopt_client; /* pointer to pass to the socket options callback */ + curl_opensocket_callback fopensocket; /* function for checking/translating + the address and opening the + socket */ + void *opensocket_client; + curl_closesocket_callback fclosesocket; /* function for closing the + socket */ + void *closesocket_client; + curl_prereq_callback fprereq; /* pre-initial request callback */ + void *prereq_userp; /* pre-initial request user data */ + + void *seek_client; /* pointer to pass to the seek callback */ +#ifndef CURL_DISABLE_HSTS + curl_hstsread_callback hsts_read; + void *hsts_read_userp; + curl_hstswrite_callback hsts_write; + void *hsts_write_userp; +#endif + void *progress_client; /* pointer to pass to the progress callback */ + void *ioctl_client; /* pointer to pass to the ioctl callback */ + timediff_t conn_max_idle_ms; /* max idle time to allow a connection that + is to be reused */ + timediff_t conn_max_age_ms; /* max time since creation to allow a + connection that is to be reused */ + curl_off_t filesize; /* size of file to upload, -1 means unknown */ + curl_off_t low_speed_limit; /* bytes/second */ + curl_off_t max_send_speed; /* high speed limit in bytes/second for upload */ + curl_off_t max_recv_speed; /* high speed limit in bytes/second for + download */ + curl_off_t set_resume_from; /* continue [ftp] transfer from here */ + struct curl_slist *headers; /* linked list of extra headers */ + struct curl_httppost *httppost; /* linked list of old POST data */ +#if !defined(CURL_DISABLE_MIME) || !defined(CURL_DISABLE_FORM_API) + curl_mimepart *mimepostp; /* MIME/POST data. */ +#endif +#ifndef CURL_DISABLE_TELNET + struct curl_slist *telnet_options; /* linked list of telnet options */ +#endif + struct curl_slist *resolve; /* list of names to add/remove from + DNS cache */ + struct curl_slist *connect_to; /* list of host:port mappings to override + the hostname and port to connect to */ + time_t timevalue; /* what time to compare with */ + struct ssl_config_data ssl; /* user defined SSL stuff */ +#ifndef CURL_DISABLE_PROXY + struct ssl_config_data proxy_ssl; /* user defined SSL stuff for proxy */ + struct curl_slist *proxyheaders; /* linked list of extra CONNECT headers */ + uint16_t proxyport; /* If non-zero, use this port number by + default. If the proxy string features a + ":[port]" that one will override this. */ + uint8_t proxytype; /* what kind of proxy */ + uint8_t socks5auth;/* kind of SOCKS5 authentication to use (bitmask) */ +#endif + struct ssl_general_config general_ssl; /* general user defined SSL stuff */ + timediff_t dns_cache_timeout_ms; /* DNS cache timeout (milliseconds) */ + uint32_t buffer_size; /* size of receive buffer to use */ + uint32_t upload_buffer_size; /* size of upload buffer to use, keep it >= + CURL_MAX_WRITE_SIZE */ + void *private_data; /* application-private data */ +#ifndef CURL_DISABLE_HTTP + struct curl_slist *http200aliases; /* linked list of aliases for http200 */ +#endif + curl_off_t max_filesize; /* Maximum file size to download */ +#ifndef CURL_DISABLE_FTP + timediff_t accepttimeout; /* in milliseconds, 0 means no timeout */ + uint8_t ftp_filemethod; /* how to get to a file: curl_ftpfile */ + uint8_t ftpsslauth; /* what AUTH XXX to try: curl_ftpauth */ + uint8_t ftp_ccc; /* FTP CCC options: curl_ftpccc */ +#endif +#if !defined(CURL_DISABLE_FTP) || defined(USE_SSH) + struct curl_slist *quote; /* after connection is established */ + struct curl_slist *postquote; /* after the transfer */ + struct curl_slist *prequote; /* before the transfer, after type */ +#endif +#ifdef USE_LIBSSH2 + curl_sshhostkeycallback ssh_hostkeyfunc; /* hostkey check callback */ + void *ssh_hostkeyfunc_userp; /* custom pointer to callback */ +#endif +#ifdef USE_SSH + curl_sshkeycallback ssh_keyfunc; /* key matching callback */ + void *ssh_keyfunc_userp; /* custom pointer to callback */ + uint32_t ssh_auth_types; /* allowed SSH auth types */ + uint32_t new_directory_perms; /* when creating remote dirs */ +#endif + uint32_t new_file_perms; /* when creating remote files */ + char *str[STRING_LAST]; /* array of strings, pointing to allocated memory */ + struct curl_blob *blobs[BLOB_LAST]; +#ifdef USE_IPV6 + uint32_t scope_id; /* Scope id for IPv6 */ +#endif + curl_prot_t allowed_protocols; + curl_prot_t redir_protocols; +#ifndef CURL_DISABLE_RTSP + void *rtp_out; /* write RTP to this if non-NULL */ + /* Common RTSP header options */ + Curl_RtspReq rtspreq; /* RTSP request type */ +#endif +#ifndef CURL_DISABLE_FTP + curl_chunk_bgn_callback chunk_bgn; /* called before part of transfer + starts */ + curl_chunk_end_callback chunk_end; /* called after part transferring + stopped */ + curl_fnmatch_callback fnmatch; /* callback to decide which file corresponds + to pattern (e.g. if WILDCARDMATCH is on) */ + void *fnmatch_data; + void *wildcardptr; +#endif + + timediff_t timeout; /* ms, 0 means no timeout */ + timediff_t connecttimeout; /* ms, 0 means default timeout */ + timediff_t happy_eyeballs_timeout; /* ms, 0 is a valid value */ + timediff_t server_response_timeout; /* ms, 0 means no timeout */ + timediff_t shutdowntimeout; /* ms, 0 means default timeout */ + int tcp_keepidle; /* seconds in idle before sending keepalive probe */ + int tcp_keepintvl; /* seconds between TCP keepalive probes */ + int tcp_keepcnt; /* maximum number of keepalive probes */ + +#if defined(USE_HTTP2) || defined(USE_HTTP3) + struct Curl_data_priority priority; +#endif + curl_resolver_start_callback resolver_start; /* optional callback called + before resolver start */ + void *resolver_start_client; /* pointer to pass to resolver start callback */ + timediff_t upkeep_interval_ms; /* Time between calls for connection + upkeep. */ + CURLU *uh; /* URL handle for the current parsed URL */ +#ifndef CURL_DISABLE_HTTP + void *trailer_data; /* pointer to pass to trailer data callback */ + curl_trailer_callback trailer_callback; /* trailing data callback */ +#endif +#ifndef CURL_DISABLE_SMTP + struct curl_slist *mail_rcpt; /* linked list of mail recipients */ +#endif + uint32_t maxconnects; /* Max idle connections in the connection cache */ + short maxredirs; /* maximum no. of http(s) redirects to follow, + set to -1 for infinity */ + uint16_t expect_100_timeout; /* in milliseconds */ + uint16_t use_port; /* which port to use (when not using default) */ + uint16_t low_speed_time; /* number of seconds */ +#ifndef CURL_DISABLE_BINDLOCAL + uint16_t localport; /* local port number to bind to */ + uint16_t localportrange; /* number of additional port numbers to test + in case the 'localport' one cannot be + bind()ed */ +#endif +#ifndef CURL_DISABLE_TFTP + uint16_t tftp_blksize; /* in bytes, 0 means use default */ +#endif +#ifdef USE_ECH + uint8_t tls_ech; /* TLS ECH configuration */ +#endif +#ifndef CURL_DISABLE_NETRC + uint8_t use_netrc; /* enum CURL_NETRC_OPTION values */ +#endif +#if !defined(CURL_DISABLE_FTP) || defined(USE_SSH) + /* Despite the name, ftp_create_missing_dirs is for FTP(S) and SFTP + 1 - create directories that do not exist + 2 - the same but also allow MKD to fail once + */ + uint8_t ftp_create_missing_dirs; +#endif + uint8_t use_ssl; /* if AUTH TLS is to be attempted etc, for FTP or IMAP or + POP3 or others! (type: curl_usessl)*/ + uint8_t timecondition; /* kind of time comparison: curl_TimeCond */ + uint8_t method; /* what kind of HTTP request: Curl_HttpReq */ + uint8_t httpwant; /* when non-zero, a specific HTTP version requested + to be used in the library's request(s) */ + uint8_t ipver; /* the CURL_IPRESOLVE_* defines in the public header + file 0 - whatever, 1 - v2, 2 - v6 */ + uint8_t upload_flags; /* flags set by CURLOPT_UPLOAD_FLAGS */ +#if defined(HAVE_GSSAPI) || defined(USE_WINDOWS_SSPI) + /* GSS-API/SSPI credential delegation, see CURLOPT_GSSAPI_DELEGATION */ + uint8_t gssapi_delegation; +#endif + uint8_t http_follow_mode; /* follow HTTP redirects */ + BIT(connect_only); /* make connection/request, then let application use the + socket */ + BIT(connect_only_ws); /* special websocket connect-only level */ +#ifndef CURL_DISABLE_SMTP + BIT(mail_rcpt_allowfails); /* allow RCPT TO command to fail for some + recipients */ +#endif +#ifndef CURL_DISABLE_MIME + BIT(mime_formescape); +#endif + BIT(is_fread_set); /* has read callback been set to non-NULL? */ +#ifndef CURL_DISABLE_TFTP + BIT(tftp_no_options); /* do not send TFTP options requests */ +#endif + BIT(sep_headers); /* handle host and proxy headers separately */ +#ifndef CURL_DISABLE_COOKIES + BIT(cookiesession); /* new cookie session? */ +#endif + BIT(crlf); /* convert crlf on ftp upload(?) */ +#ifdef USE_SSH + BIT(ssh_compression); /* enable SSH compression */ +#endif + +/* Here follows boolean settings that define how to behave during + this session. They are STATIC, set by libcurl users or at least initially + and they do not change during operations. */ + BIT(quick_exit); /* set 1L when it is okay to leak things (like + threads), as we are about to exit() anyway and + do not want lengthy cleanups to delay termination, + e.g. after a DNS timeout */ + BIT(get_filetime); /* get the time and get of the remote file */ +#ifndef CURL_DISABLE_PROXY + BIT(tunnel_thru_httpproxy); /* use CONNECT through an HTTP proxy */ +#endif + BIT(prefer_ascii); /* ASCII rather than binary */ + BIT(remote_append); /* append, not overwrite, on upload */ +#ifdef CURL_LIST_ONLY_PROTOCOL + BIT(list_only); /* list directory */ +#endif +#ifndef CURL_DISABLE_FTP + BIT(ftp_use_port); /* use the FTP PORT command */ + BIT(ftp_use_epsv); /* if EPSV is to be attempted or not */ + BIT(ftp_use_eprt); /* if EPRT is to be attempted or not */ + BIT(ftp_use_pret); /* if PRET is to be used before PASV or not */ + BIT(ftp_skip_ip); /* skip the IP address the FTP server passes on to + us */ + BIT(wildcard_enabled); /* enable wildcard matching */ +#endif + BIT(http_fail_on_error); /* fail on HTTP error codes >= 400 */ + BIT(http_keep_sending_on_error); /* for HTTP status codes >= 300 */ + BIT(http_transfer_encoding); /* request compressed HTTP transfer-encoding */ + BIT(allow_auth_to_other_hosts); + BIT(include_header); /* include received protocol headers in data output */ + BIT(http_set_referer); /* is a custom referer used */ + BIT(http_auto_referer); /* set "correct" referer when following + location: */ + BIT(opt_no_body); /* as set with CURLOPT_NOBODY */ + BIT(verbose); /* output verbosity */ + BIT(reuse_forbid); /* forbidden to be reused, close after use */ + BIT(reuse_fresh); /* do not reuse an existing connection */ + BIT(no_signal); /* do not use any signal/alarm handler */ + BIT(tcp_nodelay); /* whether to enable TCP_NODELAY or not */ + BIT(ignorecl); /* ignore content length */ + BIT(http_te_skip); /* pass the raw body data to the user, even when + transfer-encoded (chunked, compressed) */ + BIT(http_ce_skip); /* pass the raw body data to the user, even when + content-encoded (chunked, compressed) */ + BIT(proxy_transfer_mode); /* set transfer mode (;type=) when doing + FTP via an HTTP proxy */ +#if defined(HAVE_GSSAPI) || defined(USE_WINDOWS_SSPI) + BIT(socks5_gssapi_nec); /* Flag to support NEC SOCKS5 server */ +#endif + BIT(sasl_ir); /* Enable/disable SASL initial response */ + BIT(tcp_keepalive); /* use TCP keepalives */ + BIT(tcp_fastopen); /* use TCP Fast Open */ + BIT(ssl_enable_alpn);/* TLS ALPN extension? */ + BIT(path_as_is); /* allow dotdots? */ + BIT(pipewait); /* wait for multiplex status before starting a new + connection */ + BIT(suppress_connect_headers); /* suppress proxy CONNECT response headers + from user callbacks */ + BIT(dns_shuffle_addresses); /* whether to shuffle addresses before use */ +#ifndef CURL_DISABLE_PROXY + BIT(haproxyprotocol); /* whether to send HAProxy PROXY protocol v1 + header */ +#endif +#ifdef USE_UNIX_SOCKETS + BIT(abstract_unix_socket); +#endif + BIT(disallow_username_in_url); /* disallow username in URL */ +#ifndef CURL_DISABLE_DOH + BIT(doh); /* DNS-over-HTTPS enabled */ + BIT(doh_verifypeer); /* DoH certificate peer verification */ + BIT(doh_verifyhost); /* DoH certificate hostname verification */ + BIT(doh_verifystatus); /* DoH certificate status verification */ +#endif + BIT(http09_allowed); /* allow HTTP/0.9 responses */ +#ifndef CURL_DISABLE_WEBSOCKETS + BIT(ws_raw_mode); + BIT(ws_no_auto_pong); +#endif + BIT(post301); /* keep POSTs as POSTs after a 301 request */ + BIT(post302); /* keep POSTs as POSTs after a 302 request */ + BIT(post303); /* keep POSTs as POSTs after a 303 request */ +}; + +#ifndef CURL_DISABLE_MIME +#define IS_MIME_POST(a) \ + ((a)->set.mimepostp && ((a)->set.mimepostp->kind != MIMEKIND_NONE)) +#else +#define IS_MIME_POST(a) FALSE +#endif + +/* callback that gets called when a sub easy (data->master_mid set) is + DONE. Called on the master easy. */ +typedef void multi_sub_xfer_done_cb(struct Curl_easy *master_easy, + struct Curl_easy *sub_easy, + CURLcode result); + +/* + * The 'connectdata' struct MUST have all the connection oriented stuff as we + * may have several simultaneous connections and connection structs in memory. + * + * The 'struct UserDefined' must only contain data that is set once to go for + * many (perhaps) independent connections. Values that are generated or + * calculated internally for the "session handle" must be defined within the + * 'struct UrlState' instead. + */ + +struct Curl_easy { + /* First a simple identifier to easier detect if a user mix up this easy + handle with a multi handle. Set this to CURLEASY_MAGIC_NUMBER */ + uint32_t magic; + /* once an easy handle is tied to a connection pool a non-negative number to + distinguish this transfer from other using the same pool. For easier + tracking in log output. This may wrap around after LONG_MAX to 0 again, + so it has no uniqueness guarantee for large processings. Note: it has no + uniqueness either IFF more than one connection pool is used by the + libcurl application. */ + curl_off_t id; + /* once an easy handle is added to a multi, either explicitly by the + * libcurl application or implicitly during `curl_easy_perform()`, + * a unique identifier inside this one multi instance. */ + uint32_t mid; + uint32_t master_mid; /* if set, this transfer belongs to a master */ + multi_sub_xfer_done_cb *sub_xfer_done; + + struct connectdata *conn; + + CURLMstate mstate; /* the handle's state */ + CURLcode result; /* previous result */ + + struct Curl_message msg; /* A single posted message. */ + + struct Curl_multi *multi; /* if non-NULL, points to the multi handle + struct to which this "belongs" when used by + the multi interface */ + struct Curl_multi *multi_easy; /* if non-NULL, points to the multi handle + struct to which this "belongs" when used + by the easy interface */ + struct Curl_share *share; /* Share, handles global variable mutexing */ + + /* `meta_hash` is a general key-value store for implementations + * with the lifetime of the easy handle. + * Elements need to be added with their own destructor to be invoked when + * the easy handle is cleaned up (see Curl_hash_add2()).*/ + struct Curl_hash meta_hash; + +#ifdef USE_LIBPSL + struct PslCache *psl; /* The associated PSL cache. */ +#endif + struct SingleRequest req; /* Request-specific data */ + struct UserDefined set; /* values set by the libcurl user */ +#ifndef CURL_DISABLE_COOKIES + struct CookieInfo *cookies; /* the cookies, read from files and servers. + NOTE that the 'cookie' field in the + UserDefined struct defines if the "engine" + is to be used or not. */ +#endif +#ifndef CURL_DISABLE_HSTS + struct hsts *hsts; +#endif +#ifndef CURL_DISABLE_ALTSVC + struct altsvcinfo *asi; /* the alt-svc cache */ +#endif + struct Progress progress; /* for all the progress meter data */ + struct UrlState state; /* struct for fields used for state info and + other dynamic purposes */ +#ifndef CURL_DISABLE_FTP + struct WildcardData *wildcard; /* wildcard download state info */ +#endif + struct PureInfo info; /* stats, reports and info data */ + struct curl_tlssessioninfo tsi; /* Information about the TLS session, only + valid after a client has asked for it */ +}; + +#define LIBCURL_NAME "libcurl" + +#endif /* HEADER_CURL_URLDATA_H */ diff --git a/3rdparty/curl-8.21.0/lib/vauth/cleartext.c b/3rdparty/curl-8.21.0/lib/vauth/cleartext.c new file mode 100644 index 0000000000..ca0c9967ff --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vauth/cleartext.c @@ -0,0 +1,112 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + * RFC4616 PLAIN authentication + * Draft LOGIN SASL Mechanism + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_IMAP) || !defined(CURL_DISABLE_SMTP) || \ + !defined(CURL_DISABLE_POP3) || \ + (!defined(CURL_DISABLE_LDAP) && defined(USE_OPENLDAP)) + +#include "vauth/vauth.h" + +/* + * Curl_auth_create_plain_message() + * + * This is used to generate an already encoded PLAIN message ready + * for sending to the recipient. + * + * Parameters: + * + * creds [in] - The credentials. + * passwd [in] - The password. + * out [out] - The result storage. + * + * Returns CURLE_OK on success. + */ +CURLcode Curl_auth_create_plain_message(struct Curl_creds *creds, + struct bufref *out) +{ + size_t len; + char *auth; + + size_t zlen = strlen(Curl_creds_sasl_authzid(creds)); + size_t clen = strlen(Curl_creds_user(creds)); + size_t plen = strlen(Curl_creds_passwd(creds)); + + if((zlen > CURL_MAX_INPUT_LENGTH) || (clen > CURL_MAX_INPUT_LENGTH) || + (plen > CURL_MAX_INPUT_LENGTH)) + return CURLE_TOO_LARGE; + + len = zlen + clen + plen + 2; + + auth = curl_maprintf("%s%c%s%c%s", + Curl_creds_sasl_authzid(creds), '\0', + Curl_creds_user(creds), '\0', + Curl_creds_passwd(creds)); + if(!auth) + return CURLE_OUT_OF_MEMORY; + Curl_bufref_set(out, auth, len, curl_free); + return CURLE_OK; +} + +/* + * Curl_auth_create_login_message() + * + * This is used to generate an already encoded LOGIN message containing the + * username or password ready for sending to the recipient. + * + * Parameters: + * + * value [in] - The username or user's password. + * out [out] - The result storage. + * + * Returns void. + */ +void Curl_auth_create_login_message(const char *value, struct bufref *out) +{ + Curl_bufref_set(out, value, strlen(value), NULL); +} + +/* + * Curl_auth_create_external_message() + * + * This is used to generate an already encoded EXTERNAL message containing + * the username ready for sending to the recipient. + * + * Parameters: + * + * user [in] - The username. + * out [out] - The result storage. + * + * Returns void. + */ +void Curl_auth_create_external_message(const char *user, struct bufref *out) +{ + /* This is the same formatting as the login message */ + Curl_auth_create_login_message(user, out); +} + +#endif /* if no users */ diff --git a/3rdparty/curl-8.21.0/lib/vauth/cram.c b/3rdparty/curl-8.21.0/lib/vauth/cram.c new file mode 100644 index 0000000000..023c31b58b --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vauth/cram.c @@ -0,0 +1,87 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + * RFC2195 CRAM-MD5 authentication + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifndef CURL_DISABLE_DIGEST_AUTH + +#include "vauth/vauth.h" +#include "curl_hmac.h" +#include "curl_md5.h" + +/* + * Curl_auth_create_cram_md5_message() + * + * This is used to generate a CRAM-MD5 response message ready for sending to + * the recipient. + * + * Parameters: + * + * chlg [in] - The challenge. + * userp [in] - The username. + * passwdp [in] - The user's password. + * out [out] - The result storage. + * + * Returns CURLE_OK on success. + */ +CURLcode Curl_auth_create_cram_md5_message(const struct bufref *chlg, + struct Curl_creds *creds, + struct bufref *out) +{ + struct HMAC_context *ctxt; + unsigned char digest[MD5_DIGEST_LEN]; + char *response; + const char *user = Curl_creds_user(creds); + const char *passwd = Curl_creds_passwd(creds); + + /* Compute the digest using the password as the key */ + ctxt = Curl_HMAC_init(&Curl_HMAC_MD5, + (const unsigned char *)passwd, + curlx_uztoui(strlen(passwd))); + if(!ctxt) + return CURLE_OUT_OF_MEMORY; + + /* Update the digest with the given challenge */ + if(Curl_bufref_len(chlg)) + Curl_HMAC_update(ctxt, Curl_bufref_uptr(chlg), + curlx_uztoui(Curl_bufref_len(chlg))); + + /* Finalise the digest */ + Curl_HMAC_final(ctxt, digest); + + /* Generate the response */ + response = curl_maprintf( + "%s %02x%02x%02x%02x%02x%02x%02x%02x%02x%02x%02x%02x%02x%02x%02x%02x", + user, digest[0], digest[1], digest[2], digest[3], digest[4], + digest[5], digest[6], digest[7], digest[8], digest[9], digest[10], + digest[11], digest[12], digest[13], digest[14], digest[15]); + if(!response) + return CURLE_OUT_OF_MEMORY; + + Curl_bufref_set(out, response, strlen(response), curl_free); + return CURLE_OK; +} + +#endif /* !CURL_DISABLE_DIGEST_AUTH */ diff --git a/3rdparty/curl-8.21.0/lib/vauth/digest.c b/3rdparty/curl-8.21.0/lib/vauth/digest.c new file mode 100644 index 0000000000..1818fc96c7 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vauth/digest.c @@ -0,0 +1,1059 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + * RFC2831 DIGEST-MD5 authentication + * RFC7616 DIGEST-SHA256, DIGEST-SHA512-256 authentication + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifndef CURL_DISABLE_DIGEST_AUTH + +#include "vauth/vauth.h" +#include "vauth/digest.h" +#include "curlx/base64.h" +#include "curl_md5.h" +#include "curl_sha256.h" +#include "curl_sha512_256.h" +#include "curlx/strparse.h" +#include "rand.h" +#include "escape.h" + +#ifndef USE_WINDOWS_SSPI +#define SESSION_ALGO 1 /* for algos with this bit set */ + +#define ALGO_MD5 0 +#define ALGO_MD5SESS (ALGO_MD5 | SESSION_ALGO) +#define ALGO_SHA256 2 +#define ALGO_SHA256SESS (ALGO_SHA256 | SESSION_ALGO) +#define ALGO_SHA512_256 4 +#define ALGO_SHA512_256SESS (ALGO_SHA512_256 | SESSION_ALGO) + +#define DIGEST_QOP_VALUE_AUTH (1 << 0) +#define DIGEST_QOP_VALUE_AUTH_INT (1 << 1) +#define DIGEST_QOP_VALUE_AUTH_CONF (1 << 2) + +#define DIGEST_QOP_VALUE_STRING_AUTH "auth" +#define DIGEST_QOP_VALUE_STRING_AUTH_INT "auth-int" +#define DIGEST_QOP_VALUE_STRING_AUTH_CONF "auth-conf" +#endif + +bool Curl_auth_digest_get_pair(const char *str, char *value, char *content, + const char **endptr) +{ + int c; + bool starts_with_quote = FALSE; + bool escape = FALSE; + + for(c = DIGEST_MAX_VALUE_LENGTH - 1; (*str && (*str != '=') && c--);) + *value++ = *str++; + *value = 0; + + if('=' != *str++) + /* eek, no match */ + return FALSE; + + if('\"' == *str) { + /* This starts with a quote so it must end with one as well! */ + str++; + starts_with_quote = TRUE; + } + + for(c = DIGEST_MAX_CONTENT_LENGTH - 1; *str && c--; str++) { + if(!escape) { + switch(*str) { + case '\\': + if(starts_with_quote) { + /* the start of an escaped quote */ + escape = TRUE; + continue; + } + break; + + case ',': + if(!starts_with_quote) { + /* This signals the end of the content if we did not get a starting + quote and then we do "sloppy" parsing */ + c = 0; /* the end */ + continue; + } + break; + + case '\r': + case '\n': + /* end of string */ + if(starts_with_quote) + return FALSE; /* No closing quote */ + c = 0; + continue; + + case '\"': + if(starts_with_quote) { + /* end of string */ + c = 0; + continue; + } + else + return FALSE; + } + } + + escape = FALSE; + *content++ = *str; + } + if(escape) + return FALSE; /* No character after backslash */ + + *content = 0; + *endptr = str; + + return TRUE; +} + +#ifndef USE_WINDOWS_SSPI +/* Convert MD5 chunk to RFC2617 (section 3.1.3) -suitable ASCII string */ +static void auth_digest_md5_to_ascii( + const unsigned char *source, /* 16 bytes */ + unsigned char *dest) /* 33 bytes */ +{ + int i; + for(i = 0; i < 16; i++) + curl_msnprintf((char *)&dest[i * 2], 3, "%02x", source[i]); +} + +/* Convert sha256 or SHA-512/256 chunk to RFC7616 -suitable ASCII string */ +static void auth_digest_sha256_to_ascii( + const unsigned char *source, /* 32 bytes */ + unsigned char *dest) /* 65 bytes */ +{ + int i; + for(i = 0; i < 32; i++) + curl_msnprintf((char *)&dest[i * 2], 3, "%02x", source[i]); +} + +/* Perform quoted-string escaping as described in RFC2616 and its errata */ +static char *auth_digest_string_quoted(const char *s) +{ + struct dynbuf out; + curlx_dyn_init(&out, 2048); + if(!*s) /* for zero length input, make sure we return an empty string */ + return curlx_strdup(""); + while(*s) { + CURLcode result; + if(*s == '"' || *s == '\\') { + result = curlx_dyn_addn(&out, "\\", 1); + if(!result) + result = curlx_dyn_addn(&out, s, 1); + } + else if((*s < ' ') || (*s > 0x7e)) { + unsigned char buf[3] = { '%' }; + Curl_hexbyte(&buf[1], (unsigned char)*s); + result = curlx_dyn_addn(&out, buf, 3); + } + else + result = curlx_dyn_addn(&out, s, 1); + if(result) + return NULL; + s++; + } + return curlx_dyn_ptr(&out); +} + +/* Retrieves the value for a corresponding key from the challenge string + * returns TRUE if the key could be found, FALSE if it does not exists + */ +static bool auth_digest_get_key_value(const char *chlg, const char *key, + char *buf, size_t buflen) +{ + /* keyword=[value],keyword2=[value] + The values may or may not be quoted. + */ + + do { + struct Curl_str data; + struct Curl_str name; + + curlx_str_passblanks(&chlg); + + if(!curlx_str_until(&chlg, &name, 64, '=') && + !curlx_str_single(&chlg, '=')) { + /* this is the key, get the value, possibly quoted */ + int rc = curlx_str_quotedword(&chlg, &data, 256); + if(rc == STRE_BEGQUOTE) + /* try unquoted until comma */ + rc = curlx_str_until(&chlg, &data, 256, ','); + if(rc) + return FALSE; /* weird */ + + if(curlx_str_cmp(&name, key)) { + /* if this is our key, return the value */ + size_t len = curlx_strlen(&data); + const char *src = curlx_str(&data); + size_t i; + size_t outlen = 0; + + if(len >= buflen) + /* does not fit */ + return FALSE; + + for(i = 0; i < len; i++) { + if(src[i] == '\\' && i + 1 < len) { + i++; /* skip backslash */ + } + buf[outlen++] = src[i]; + } + buf[outlen] = 0; + return TRUE; + } + if(curlx_str_single(&chlg, ',')) + return FALSE; + } + else /* odd syntax */ + break; + } while(1); + + return FALSE; +} + +static void auth_digest_get_qop_values(const char *options, int *value) +{ + struct Curl_str out; + /* Initialize the output */ + *value = 0; + + while(!curlx_str_until(&options, &out, 32, ',')) { + if(curlx_str_casecompare(&out, DIGEST_QOP_VALUE_STRING_AUTH)) + *value |= DIGEST_QOP_VALUE_AUTH; + else if(curlx_str_casecompare(&out, DIGEST_QOP_VALUE_STRING_AUTH_INT)) + *value |= DIGEST_QOP_VALUE_AUTH_INT; + else if(curlx_str_casecompare(&out, DIGEST_QOP_VALUE_STRING_AUTH_CONF)) + *value |= DIGEST_QOP_VALUE_AUTH_CONF; + if(curlx_str_single(&options, ',')) + break; + } +} + +/* + * auth_decode_digest_md5_message() + * + * This is used internally to decode an already encoded DIGEST-MD5 challenge + * message into the separate attributes. + * + * Parameters: + * + * chlgref [in] - The challenge message. + * nonce [in/out] - The buffer where the nonce is stored. + * nlen [in] - The length of the nonce buffer. + * realm [in/out] - The buffer where the realm is stored. + * rlen [in] - The length of the realm buffer. + * alg [in/out] - The buffer where the algorithm is stored. + * alen [in] - The length of the algorithm buffer. + * qop [in/out] - The buffer where the qop-options is stored. + * qlen [in] - The length of the qop buffer. + * + * Returns CURLE_OK on success. + */ +static CURLcode auth_decode_digest_md5_message(const struct bufref *chlgref, + char *nonce, size_t nlen, + char *realm, size_t rlen, + char *alg, size_t alen, + char *qop, size_t qlen) +{ + const char *chlg = Curl_bufref_ptr(chlgref); + + /* Ensure we have a valid challenge message */ + if(!Curl_bufref_len(chlgref)) + return CURLE_BAD_CONTENT_ENCODING; + + /* Retrieve nonce string from the challenge */ + if(!auth_digest_get_key_value(chlg, "nonce", nonce, nlen)) + return CURLE_BAD_CONTENT_ENCODING; + + /* Retrieve realm string from the challenge */ + if(!auth_digest_get_key_value(chlg, "realm", realm, rlen)) { + /* Challenge does not have a realm, set empty string [RFC2831] page 6 */ + *realm = '\0'; + } + + /* Retrieve algorithm string from the challenge */ + if(!auth_digest_get_key_value(chlg, "algorithm", alg, alen)) + return CURLE_BAD_CONTENT_ENCODING; + + /* Retrieve qop-options string from the challenge */ + if(!auth_digest_get_key_value(chlg, "qop", qop, qlen)) + return CURLE_BAD_CONTENT_ENCODING; + + return CURLE_OK; +} + +/* + * Curl_auth_is_digest_supported() + * + * This is used to evaluate if DIGEST is supported. + * + * Parameters: None + * + * Returns TRUE as DIGEST as handled by libcurl. + */ +bool Curl_auth_is_digest_supported(void) +{ + return TRUE; +} + +/* + * Curl_auth_create_digest_md5_message() + * + * This is used to generate an already encoded DIGEST-MD5 response message + * ready for sending to the recipient. + * + * Parameters: + * + * data [in] - The session handle. + * chlg [in] - The challenge message. + * userp [in] - The username. + * passwdp [in] - The user's password. + * service [in] - The service type such as http, smtp, pop or imap. + * out [out] - The result storage. + * + * Returns CURLE_OK on success. + */ +CURLcode Curl_auth_create_digest_md5_message(struct Curl_easy *data, + const struct bufref *chlg, + struct Curl_creds *creds, + const char *default_service, + struct bufref *out) +{ + const char *service = Curl_creds_has_sasl_service(creds) ? + Curl_creds_sasl_service(creds) : default_service; + size_t i; + struct MD5_context *ctxt; + const char *userp = Curl_creds_user(creds); + const char *passwdp = Curl_creds_passwd(creds); + char *response = NULL; + unsigned char digest[MD5_DIGEST_LEN]; + char HA1_hex[(2 * MD5_DIGEST_LEN) + 1]; + char HA2_hex[(2 * MD5_DIGEST_LEN) + 1]; + char resp_hash_hex[(2 * MD5_DIGEST_LEN) + 1]; + char nonce[64]; + char realm[128]; + char algorithm[64]; + char qop_options[64]; + int qop_values; + char cnonce[33]; + char nonceCount[] = "00000001"; + char method[] = "AUTHENTICATE"; + char qop[] = DIGEST_QOP_VALUE_STRING_AUTH; + char *spn = NULL; + char *qrealm; + char *qnonce; + char *quserp; + + /* Decode the challenge message */ + CURLcode result = auth_decode_digest_md5_message(chlg, + nonce, sizeof(nonce), + realm, sizeof(realm), + algorithm, + sizeof(algorithm), + qop_options, + sizeof(qop_options)); + if(result) + return result; + + /* We only support md5 sessions */ + if(strcmp(algorithm, "md5-sess")) + return CURLE_BAD_CONTENT_ENCODING; + + /* Get the qop-values from the qop-options */ + auth_digest_get_qop_values(qop_options, &qop_values); + + /* We only support auth quality-of-protection */ + if(!(qop_values & DIGEST_QOP_VALUE_AUTH)) + return CURLE_BAD_CONTENT_ENCODING; + + /* Generate 32 random hex chars, 32 bytes + 1 null-termination */ + result = Curl_rand_hex(data, (unsigned char *)cnonce, sizeof(cnonce)); + if(result) + return result; + + /* Good so far, now calculate A1 and H(A1) according to RFC 2831 */ + ctxt = Curl_MD5_init(&Curl_DIGEST_MD5); + if(!ctxt) + return CURLE_OUT_OF_MEMORY; + + Curl_MD5_update(ctxt, (const unsigned char *)userp, + curlx_uztoui(strlen(userp))); + Curl_MD5_update(ctxt, (const unsigned char *)":", 1); + Curl_MD5_update(ctxt, (const unsigned char *)realm, + curlx_uztoui(strlen(realm))); + Curl_MD5_update(ctxt, (const unsigned char *)":", 1); + Curl_MD5_update(ctxt, (const unsigned char *)passwdp, + curlx_uztoui(strlen(passwdp))); + Curl_MD5_final(ctxt, digest); + + ctxt = Curl_MD5_init(&Curl_DIGEST_MD5); + if(!ctxt) + return CURLE_OUT_OF_MEMORY; + + Curl_MD5_update(ctxt, (const unsigned char *)digest, MD5_DIGEST_LEN); + Curl_MD5_update(ctxt, (const unsigned char *)":", 1); + Curl_MD5_update(ctxt, (const unsigned char *)nonce, + curlx_uztoui(strlen(nonce))); + Curl_MD5_update(ctxt, (const unsigned char *)":", 1); + Curl_MD5_update(ctxt, (const unsigned char *)cnonce, + curlx_uztoui(strlen(cnonce))); + Curl_MD5_final(ctxt, digest); + + /* Convert calculated 16 octet hex into 32 bytes string */ + for(i = 0; i < MD5_DIGEST_LEN; i++) + curl_msnprintf(&HA1_hex[2 * i], 3, "%02x", digest[i]); + + /* Generate our SPN */ + spn = Curl_auth_build_spn(service, data->state.origin->hostname, NULL); + if(!spn) + return CURLE_OUT_OF_MEMORY; + + /* Calculate H(A2) */ + ctxt = Curl_MD5_init(&Curl_DIGEST_MD5); + if(!ctxt) { + curlx_free(spn); + + return CURLE_OUT_OF_MEMORY; + } + + Curl_MD5_update(ctxt, (const unsigned char *)method, + curlx_uztoui(strlen(method))); + Curl_MD5_update(ctxt, (const unsigned char *)":", 1); + Curl_MD5_update(ctxt, (const unsigned char *)spn, + curlx_uztoui(strlen(spn))); + Curl_MD5_final(ctxt, digest); + + for(i = 0; i < MD5_DIGEST_LEN; i++) + curl_msnprintf(&HA2_hex[2 * i], 3, "%02x", digest[i]); + + /* Now calculate the response hash */ + ctxt = Curl_MD5_init(&Curl_DIGEST_MD5); + if(!ctxt) { + curlx_free(spn); + + return CURLE_OUT_OF_MEMORY; + } + + Curl_MD5_update(ctxt, (const unsigned char *)HA1_hex, 2 * MD5_DIGEST_LEN); + Curl_MD5_update(ctxt, (const unsigned char *)":", 1); + Curl_MD5_update(ctxt, (const unsigned char *)nonce, + curlx_uztoui(strlen(nonce))); + Curl_MD5_update(ctxt, (const unsigned char *)":", 1); + + Curl_MD5_update(ctxt, (const unsigned char *)nonceCount, + curlx_uztoui(strlen(nonceCount))); + Curl_MD5_update(ctxt, (const unsigned char *)":", 1); + Curl_MD5_update(ctxt, (const unsigned char *)cnonce, + curlx_uztoui(strlen(cnonce))); + Curl_MD5_update(ctxt, (const unsigned char *)":", 1); + Curl_MD5_update(ctxt, (const unsigned char *)qop, + curlx_uztoui(strlen(qop))); + Curl_MD5_update(ctxt, (const unsigned char *)":", 1); + + Curl_MD5_update(ctxt, (const unsigned char *)HA2_hex, 2 * MD5_DIGEST_LEN); + Curl_MD5_final(ctxt, digest); + + for(i = 0; i < MD5_DIGEST_LEN; i++) + curl_msnprintf(&resp_hash_hex[2 * i], 3, "%02x", digest[i]); + + /* escape double quotes and backslashes in the username, realm and nonce as + necessary */ + qrealm = auth_digest_string_quoted(realm); + qnonce = auth_digest_string_quoted(nonce); + quserp = auth_digest_string_quoted(userp); + if(qrealm && qnonce && quserp) + /* Generate the response */ + response = curl_maprintf("username=\"%s\",realm=\"%s\",nonce=\"%s\"," + "cnonce=\"%s\",nc=\"%s\",digest-uri=\"%s\"," + "response=%s,qop=%s", + quserp, qrealm, qnonce, + cnonce, nonceCount, spn, resp_hash_hex, qop); + + curlx_free(qrealm); + curlx_free(qnonce); + curlx_free(quserp); + curlx_free(spn); + if(!response) + return CURLE_OUT_OF_MEMORY; + + /* Return the response. */ + Curl_bufref_set(out, response, strlen(response), curl_free); + return result; +} + +/* + * Curl_auth_decode_digest_http_message() + * + * This is used to decode an HTTP DIGEST challenge message into the separate + * attributes. + * + * Parameters: + * + * chlg [in] - The challenge message. + * digest [in/out] - The digest data struct being used and modified. + * + * Returns CURLE_OK on success. + */ +CURLcode Curl_auth_decode_digest_http_message(const char *chlg, + struct digestdata *digest) +{ + bool before = FALSE; /* got a nonce before */ + + /* If we already have received a nonce, keep that in mind */ + if(digest->nonce) + before = TRUE; + + /* Clean up any former leftovers and initialize to defaults */ + Curl_auth_digest_cleanup(digest); + + for(;;) { + char value[DIGEST_MAX_VALUE_LENGTH]; + char content[DIGEST_MAX_CONTENT_LENGTH]; + + /* Pass all additional spaces here */ + while(*chlg && ISBLANK(*chlg)) + chlg++; + + /* Extract a value=content pair */ + if(Curl_auth_digest_get_pair(chlg, value, content, &chlg)) { + if(curl_strequal(value, "nonce")) { + curlx_free(digest->nonce); + digest->nonce = curlx_strdup(content); + if(!digest->nonce) + return CURLE_OUT_OF_MEMORY; + } + else if(curl_strequal(value, "stale")) { + if(curl_strequal(content, "true")) { + digest->stale = TRUE; + digest->nc = 1; /* we make a new nonce now */ + } + } + else if(curl_strequal(value, "realm")) { + curlx_free(digest->realm); + digest->realm = curlx_strdup(content); + if(!digest->realm) + return CURLE_OUT_OF_MEMORY; + } + else if(curl_strequal(value, "opaque")) { + curlx_free(digest->opaque); + digest->opaque = curlx_strdup(content); + if(!digest->opaque) + return CURLE_OUT_OF_MEMORY; + } + else if(curl_strequal(value, "qop")) { + const char *token = content; + struct Curl_str out; + bool foundAuth = FALSE; + bool foundAuthInt = FALSE; + /* Pass leading spaces */ + while(*token && ISBLANK(*token)) + token++; + while(!curlx_str_until(&token, &out, 32, ',')) { + if(curlx_str_casecompare(&out, DIGEST_QOP_VALUE_STRING_AUTH)) + foundAuth = TRUE; + else if(curlx_str_casecompare(&out, + DIGEST_QOP_VALUE_STRING_AUTH_INT)) + foundAuthInt = TRUE; + if(curlx_str_single(&token, ',')) + break; + while(*token && ISBLANK(*token)) + token++; + } + + /* Select only auth or auth-int. Otherwise, ignore */ + if(foundAuth) { + curlx_free(digest->qop); + digest->qop = curlx_strdup(DIGEST_QOP_VALUE_STRING_AUTH); + if(!digest->qop) + return CURLE_OUT_OF_MEMORY; + } + else if(foundAuthInt) { + curlx_free(digest->qop); + digest->qop = curlx_strdup(DIGEST_QOP_VALUE_STRING_AUTH_INT); + if(!digest->qop) + return CURLE_OUT_OF_MEMORY; + } + } + else if(curl_strequal(value, "algorithm")) { + curlx_free(digest->algorithm); + digest->algorithm = curlx_strdup(content); + if(!digest->algorithm) + return CURLE_OUT_OF_MEMORY; + + if(curl_strequal(content, "MD5-sess")) + digest->algo = ALGO_MD5SESS; + else if(curl_strequal(content, "MD5")) + digest->algo = ALGO_MD5; + else if(curl_strequal(content, "SHA-256")) + digest->algo = ALGO_SHA256; + else if(curl_strequal(content, "SHA-256-SESS")) + digest->algo = ALGO_SHA256SESS; + else if(curl_strequal(content, "SHA-512-256")) { +#ifdef CURL_HAVE_SHA512_256 + digest->algo = ALGO_SHA512_256; +#else /* !CURL_HAVE_SHA512_256 */ + return CURLE_NOT_BUILT_IN; +#endif /* CURL_HAVE_SHA512_256 */ + } + else if(curl_strequal(content, "SHA-512-256-SESS")) { +#ifdef CURL_HAVE_SHA512_256 + digest->algo = ALGO_SHA512_256SESS; +#else /* !CURL_HAVE_SHA512_256 */ + return CURLE_NOT_BUILT_IN; +#endif /* CURL_HAVE_SHA512_256 */ + } + else + return CURLE_BAD_CONTENT_ENCODING; + } + else if(curl_strequal(value, "userhash")) { + if(curl_strequal(content, "true")) { + digest->userhash = TRUE; + } + } + else { + /* Unknown specifier, ignore it! */ + } + } + else + break; /* We are done here */ + + /* Pass all additional spaces here */ + while(*chlg && ISBLANK(*chlg)) + chlg++; + + /* Allow the list to be comma-separated */ + if(',' == *chlg) + chlg++; + } + + /* We had a nonce since before, and we got another one now without + 'stale=true'. This means we provided bad credentials in the previous + request */ + if(before && !digest->stale) + return CURLE_BAD_CONTENT_ENCODING; + + /* We got this header without a nonce, that is a bad Digest line! */ + if(!digest->nonce) + return CURLE_BAD_CONTENT_ENCODING; + + /* "-sess" protocol versions require "auth" or "auth-int" qop */ + if(!digest->qop && (digest->algo & SESSION_ALGO)) + return CURLE_BAD_CONTENT_ENCODING; + + return CURLE_OK; +} + +/* + * auth_create_digest_http_message() + * + * This is used to generate an HTTP DIGEST response message ready for sending + * to the recipient. + * + * Parameters: + * + * data [in] - The session handle. + * creds [in] - The credentials + * request [in] - The HTTP request. + * uripath [in] - The path of the HTTP uri. + * digest [in/out] - The digest data struct being used and modified. + * outptr [in/out] - The address where a pointer to newly allocated memory + * holding the result is stored upon completion. + * outlen [out] - The length of the output message. + * + * Returns CURLE_OK on success. + */ +static CURLcode auth_create_digest_http_message( + struct Curl_easy *data, + struct Curl_creds *creds, + const unsigned char *request, + const unsigned char *uripath, + struct digestdata *digest, + char **outptr, size_t *outlen, + void (*convert_to_ascii)(const unsigned char *, unsigned char *), + CURLcode (*hash)(unsigned char *, const unsigned char *, const size_t)) +{ + CURLcode result; + const char *userp = Curl_creds_user(creds); + const char *passwdp = Curl_creds_passwd(creds); + unsigned char hashbuf[32]; /* 32 bytes/256 bits */ + unsigned char request_digest[65]; + unsigned char ha1[65]; /* 64 digits and 1 zero byte */ + unsigned char ha2[65]; /* 64 digits and 1 zero byte */ + char userh[65]; + char *cnonce = NULL; + size_t cnonce_sz = 0; + char *userp_quoted = NULL; + char *realm_quoted = NULL; + char *nonce_quoted = NULL; + char *hashthis = NULL; + char *uri_quoted = NULL; + struct dynbuf response; + *outptr = NULL; + + curlx_dyn_init(&response, 4096); /* arbitrary max */ + + memset(hashbuf, 0, sizeof(hashbuf)); + if(!digest->nc) + digest->nc = 1; + + if(!digest->cnonce) { + char cnoncebuf[12]; + result = Curl_rand_bytes(data, +#ifdef DEBUGBUILD + TRUE, +#endif + (unsigned char *)cnoncebuf, + sizeof(cnoncebuf)); + if(!result) + result = curlx_base64_encode((uint8_t *)cnoncebuf, sizeof(cnoncebuf), + &cnonce, &cnonce_sz); + if(result) + goto oom; + + digest->cnonce = cnonce; + } + + if(digest->userhash) { + char *hasht = curl_maprintf("%s:%s", userp, + digest->realm ? digest->realm : ""); + if(!hasht) { + result = CURLE_OUT_OF_MEMORY; + goto oom; + } + + result = hash(hashbuf, (unsigned char *)hasht, strlen(hasht)); + curlx_free(hasht); + if(result) + goto oom; + convert_to_ascii(hashbuf, (unsigned char *)userh); + } + + /* + If the algorithm is "MD5" or unspecified (which then defaults to MD5): + + A1 = unq(username-value) ":" unq(realm-value) ":" passwd + + If the algorithm is "MD5-sess" then: + + A1 = H(unq(username-value) ":" unq(realm-value) ":" passwd) ":" + unq(nonce-value) ":" unq(cnonce-value) + */ + + hashthis = curl_maprintf("%s:%s:%s", userp, digest->realm ? + digest->realm : "", passwdp); + if(!hashthis) { + result = CURLE_OUT_OF_MEMORY; + goto oom; + } + + result = hash(hashbuf, (unsigned char *)hashthis, strlen(hashthis)); + curlx_free(hashthis); + if(result) + goto oom; + convert_to_ascii(hashbuf, ha1); + + if(digest->algo & SESSION_ALGO) { + /* nonce and cnonce are OUTSIDE the hash */ + char *tmp = curl_maprintf("%s:%s:%s", ha1, digest->nonce, digest->cnonce); + if(!tmp) { + result = CURLE_OUT_OF_MEMORY; + goto oom; + } + + result = hash(hashbuf, (unsigned char *)tmp, strlen(tmp)); + curlx_free(tmp); + if(result) + goto oom; + convert_to_ascii(hashbuf, ha1); + } + + /* + If the "qop" directive's value is "auth" or is unspecified, then A2 is: + + A2 = Method ":" digest-uri-value + + If the "qop" value is "auth-int", then A2 is: + + A2 = Method ":" digest-uri-value ":" H(entity-body) + + (The "Method" value is the HTTP request method as specified in section + 5.1.1 of RFC 2616) + */ + + uri_quoted = auth_digest_string_quoted((const char *)uripath); + if(!uri_quoted) { + result = CURLE_OUT_OF_MEMORY; + goto oom; + } + + hashthis = curl_maprintf("%s:%s", request, uripath); + if(!hashthis) { + result = CURLE_OUT_OF_MEMORY; + goto oom; + } + + if(digest->qop && curl_strequal(digest->qop, "auth-int")) { + /* We do not support auth-int for PUT or POST */ + char hashed[65]; + char *hashthis2; + + result = hash(hashbuf, (const unsigned char *)"", 0); + if(result) { + curlx_free(hashthis); + goto oom; + } + convert_to_ascii(hashbuf, (unsigned char *)hashed); + + hashthis2 = curl_maprintf("%s:%s", hashthis, hashed); + curlx_free(hashthis); + hashthis = hashthis2; + if(!hashthis) { + result = CURLE_OUT_OF_MEMORY; + goto oom; + } + } + + result = hash(hashbuf, (unsigned char *)hashthis, strlen(hashthis)); + curlx_free(hashthis); + if(result) + goto oom; + convert_to_ascii(hashbuf, ha2); + + if(digest->qop) + hashthis = curl_maprintf("%s:%s:%08x:%s:%s:%s", ha1, digest->nonce, + (unsigned int)digest->nc, digest->cnonce, + digest->qop, ha2); + else + hashthis = curl_maprintf("%s:%s:%s", ha1, digest->nonce, ha2); + + if(!hashthis) { + result = CURLE_OUT_OF_MEMORY; + goto oom; + } + + result = hash(hashbuf, (unsigned char *)hashthis, strlen(hashthis)); + curlx_free(hashthis); + if(result) + goto oom; + convert_to_ascii(hashbuf, request_digest); + + /* For test case 64 (snooped from a Mozilla 1.3a request) + + Authorization: Digest username="testuser", realm="testrealm", \ + nonce="1053604145", uri="/64", response="c55f7f30d83d774a3d2dcacf725abaca" + + Digest parameters are all quoted strings. Username which is provided by + the user needs double quotes and backslashes within it escaped. + realm, nonce, and opaque needs backslashes as well as they were + de-escaped when copied from request header. cnonce is generated with + web-safe characters. uri is already percent encoded. nc is 8 hex + characters. algorithm and qop with standard values only contain web-safe + characters. + */ + userp_quoted = auth_digest_string_quoted(digest->userhash ? userh : userp); + if(!userp_quoted) { + result = CURLE_OUT_OF_MEMORY; + goto oom; + } + if(digest->realm) + realm_quoted = auth_digest_string_quoted(digest->realm); + else { + realm_quoted = curlx_malloc(1); + if(realm_quoted) + realm_quoted[0] = 0; + } + if(!realm_quoted) { + result = CURLE_OUT_OF_MEMORY; + goto oom; + } + + nonce_quoted = auth_digest_string_quoted(digest->nonce); + if(!nonce_quoted) { + result = CURLE_OUT_OF_MEMORY; + goto oom; + } + + if(digest->qop) { + result = curlx_dyn_addf(&response, "username=\"%s\", " + "realm=\"%s\", " + "nonce=\"%s\", " + "uri=\"%s\", " + "cnonce=\"%s\", " + "nc=%08x, " + "qop=%s, " + "response=\"%s\"", + userp_quoted, + realm_quoted, + nonce_quoted, + uri_quoted, + digest->cnonce, + (unsigned int)digest->nc, + digest->qop, + request_digest); + + /* Increment nonce-count to use another nc value for the next request */ + digest->nc++; + } + else { + result = curlx_dyn_addf(&response, "username=\"%s\", " + "realm=\"%s\", " + "nonce=\"%s\", " + "uri=\"%s\", " + "response=\"%s\"", + userp_quoted, + realm_quoted, + nonce_quoted, + uri_quoted, + request_digest); + } + if(result) + goto oom; + + /* Add the optional fields */ + if(digest->opaque) { + /* Append the opaque */ + char *opaque_quoted = auth_digest_string_quoted(digest->opaque); + if(!opaque_quoted) { + result = CURLE_OUT_OF_MEMORY; + goto oom; + } + result = curlx_dyn_addf(&response, ", opaque=\"%s\"", opaque_quoted); + curlx_free(opaque_quoted); + if(result) + goto oom; + } + + if(digest->algorithm) { + /* Append the algorithm */ + result = curlx_dyn_addf(&response, ", algorithm=%s", digest->algorithm); + if(result) + goto oom; + } + + if(digest->userhash) { + /* Append the userhash */ + result = curlx_dyn_add(&response, ", userhash=true"); + if(result) + goto oom; + } + + /* Return the output */ + *outptr = curlx_dyn_ptr(&response); + *outlen = curlx_dyn_len(&response); + result = CURLE_OK; + +oom: + curlx_free(nonce_quoted); + curlx_free(realm_quoted); + curlx_free(uri_quoted); + curlx_free(userp_quoted); + if(result) + curlx_dyn_free(&response); + return result; +} + +/* + * Curl_auth_create_digest_http_message() + * + * This is used to generate an HTTP DIGEST response message ready for sending + * to the recipient. + * + * Parameters: + * + * data [in] - The session handle. + * userp [in] - The username. + * passwdp [in] - The user's password. + * request [in] - The HTTP request. + * uripath [in] - The path of the HTTP uri. + * digest [in/out] - The digest data struct being used and modified. + * outptr [in/out] - The address where a pointer to newly allocated memory + * holding the result is stored upon completion. + * outlen [out] - The length of the output message. + * + * Returns CURLE_OK on success. + */ +CURLcode Curl_auth_create_digest_http_message(struct Curl_easy *data, + struct Curl_creds *creds, + const unsigned char *request, + const unsigned char *uripath, + struct digestdata *digest, + char **outptr, size_t *outlen) +{ + if(digest->algo <= ALGO_MD5SESS) + return auth_create_digest_http_message(data, creds, + request, uripath, digest, + outptr, outlen, + auth_digest_md5_to_ascii, + Curl_md5it); + + if(digest->algo <= ALGO_SHA256SESS) + return auth_create_digest_http_message(data, creds, + request, uripath, digest, + outptr, outlen, + auth_digest_sha256_to_ascii, + Curl_sha256it); +#ifdef CURL_HAVE_SHA512_256 + if(digest->algo <= ALGO_SHA512_256SESS) + return auth_create_digest_http_message(data, creds, + request, uripath, digest, + outptr, outlen, + auth_digest_sha256_to_ascii, + Curl_sha512_256it); +#endif /* CURL_HAVE_SHA512_256 */ + + /* Should be unreachable */ + return CURLE_BAD_CONTENT_ENCODING; +} + +/* + * Curl_auth_digest_cleanup() + * + * This is used to clean up the digest specific data. + * + * Parameters: + * + * digest [in/out] - The digest data struct being cleaned up. + * + */ +void Curl_auth_digest_cleanup(struct digestdata *digest) +{ + Curl_peer_unlink(&digest->origin); + Curl_creds_unlink(&digest->creds); + curlx_safefree(digest->nonce); + curlx_safefree(digest->cnonce); + curlx_safefree(digest->realm); + curlx_safefree(digest->opaque); + curlx_safefree(digest->qop); + curlx_safefree(digest->algorithm); + + digest->nc = 0; + digest->algo = ALGO_MD5; /* default algorithm */ + digest->stale = FALSE; /* default means normal, not stale */ + digest->userhash = FALSE; +} +#endif /* !USE_WINDOWS_SSPI */ + +#endif /* !CURL_DISABLE_DIGEST_AUTH */ diff --git a/3rdparty/curl-8.21.0/lib/vauth/digest.h b/3rdparty/curl-8.21.0/lib/vauth/digest.h new file mode 100644 index 0000000000..5b8f3ae767 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vauth/digest.h @@ -0,0 +1,39 @@ +#ifndef HEADER_CURL_DIGEST_H +#define HEADER_CURL_DIGEST_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifndef CURL_DISABLE_DIGEST_AUTH + +#define DIGEST_MAX_VALUE_LENGTH 256 +#define DIGEST_MAX_CONTENT_LENGTH 1024 + +/* This is used to extract the realm from a challenge message */ +bool Curl_auth_digest_get_pair(const char *str, char *value, char *content, + const char **endptr); + +#endif + +#endif /* HEADER_CURL_DIGEST_H */ diff --git a/3rdparty/curl-8.21.0/lib/vauth/digest_sspi.c b/3rdparty/curl-8.21.0/lib/vauth/digest_sspi.c new file mode 100644 index 0000000000..305e367e17 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vauth/digest_sspi.c @@ -0,0 +1,637 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Steve Holme, . + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + * RFC2831 DIGEST-MD5 authentication + * + ***************************************************************************/ +#include "curl_setup.h" + +#if defined(USE_WINDOWS_SSPI) && !defined(CURL_DISABLE_DIGEST_AUTH) + +#include "creds.h" +#include "vauth/vauth.h" +#include "vauth/digest.h" +#include "curlx/multibyte.h" +#include "curl_trc.h" +#include "curlx/strdup.h" +#include "strcase.h" +#include "strerror.h" + +/* + * Curl_auth_is_digest_supported() + * + * This is used to evaluate if DIGEST is supported. + * + * Parameters: None + * + * Returns TRUE if DIGEST is supported by Windows SSPI. + */ +bool Curl_auth_is_digest_supported(void) +{ + PSecPkgInfo SecurityPackage; + SECURITY_STATUS status; + + /* Query the security package for Digest */ + status = + Curl_pSecFn->QuerySecurityPackageInfo( + (TCHAR *)CURL_UNCONST(TEXT(SP_NAME_DIGEST)), + &SecurityPackage); + + /* Release the package buffer as it is not required anymore */ + if(status == SEC_E_OK) { + Curl_pSecFn->FreeContextBuffer(SecurityPackage); + } + + return status == SEC_E_OK; +} + +/* + * Curl_auth_create_digest_md5_message() + * + * This is used to generate an already encoded DIGEST-MD5 response message + * ready for sending to the recipient. + * + * Parameters: + * + * data [in] - The session handle. + * chlg [in] - The challenge message. + * userp [in] - The username in the format User or Domain\User. + * passwdp [in] - The user's password. + * service [in] - The service type such as http, smtp, pop or imap. + * out [out] - The result storage. + * + * Returns CURLE_OK on success. + */ +CURLcode Curl_auth_create_digest_md5_message(struct Curl_easy *data, + const struct bufref *chlg, + struct Curl_creds *creds, + const char *default_service, + struct bufref *out) +{ + CURLcode result = CURLE_OK; + TCHAR *spn = NULL; + size_t token_max = 0; + unsigned char *output_token = NULL; + CredHandle credentials; + CtxtHandle context; + PSecPkgInfo SecurityPackage; + SEC_WINNT_AUTH_IDENTITY identity; + SEC_WINNT_AUTH_IDENTITY *p_identity; + SecBuffer chlg_buf; + SecBuffer resp_buf; + SecBufferDesc chlg_desc; + SecBufferDesc resp_desc; + SECURITY_STATUS status; + unsigned long attrs; + const char *service = Curl_creds_has_sasl_service(creds) ? + Curl_creds_sasl_service(creds) : default_service; + + /* Ensure we have a valid challenge message */ + if(!Curl_bufref_len(chlg)) { + infof(data, "DIGEST-MD5 handshake failure (empty challenge message)"); + return CURLE_BAD_CONTENT_ENCODING; + } + + /* Query the security package for DigestSSP */ + status = + Curl_pSecFn->QuerySecurityPackageInfo( + (TCHAR *)CURL_UNCONST(TEXT(SP_NAME_DIGEST)), + &SecurityPackage); + if(status != SEC_E_OK) { + failf(data, "SSPI: could not get auth info"); + return CURLE_AUTH_ERROR; + } + + token_max = SecurityPackage->cbMaxToken; + + /* Release the package buffer as it is not required anymore */ + Curl_pSecFn->FreeContextBuffer(SecurityPackage); + + /* Allocate our response buffer */ + output_token = curlx_malloc(token_max); + if(!output_token) + return CURLE_OUT_OF_MEMORY; + + /* Generate our SPN */ + spn = Curl_auth_build_spn(service, data->state.origin->hostname, NULL); + if(!spn) { + curlx_free(output_token); + return CURLE_OUT_OF_MEMORY; + } + + if(Curl_creds_has_user(creds)) { + /* Populate our identity structure */ + result = Curl_create_sspi_identity(creds->user, creds->passwd, + &identity); + if(result) { + curlx_free(spn); + curlx_free(output_token); + return result; + } + + /* Allow proper cleanup of the identity structure */ + p_identity = &identity; + } + else + /* Use the current Windows user */ + p_identity = NULL; + + /* Acquire our credentials handle */ + status = Curl_pSecFn->AcquireCredentialsHandle(NULL, + (TCHAR *)CURL_UNCONST(TEXT(SP_NAME_DIGEST)), + SECPKG_CRED_OUTBOUND, NULL, + p_identity, NULL, NULL, + &credentials, NULL); + + if(status != SEC_E_OK) { + Curl_sspi_free_identity(p_identity); + curlx_free(spn); + curlx_free(output_token); + return CURLE_LOGIN_DENIED; + } + + /* Setup the challenge "input" security buffer */ + chlg_desc.ulVersion = SECBUFFER_VERSION; + chlg_desc.cBuffers = 1; + chlg_desc.pBuffers = &chlg_buf; + chlg_buf.BufferType = SECBUFFER_TOKEN; + chlg_buf.pvBuffer = CURL_UNCONST(Curl_bufref_ptr(chlg)); + chlg_buf.cbBuffer = curlx_uztoul(Curl_bufref_len(chlg)); + + /* Setup the response "output" security buffer */ + resp_desc.ulVersion = SECBUFFER_VERSION; + resp_desc.cBuffers = 1; + resp_desc.pBuffers = &resp_buf; + resp_buf.BufferType = SECBUFFER_TOKEN; + resp_buf.pvBuffer = output_token; + resp_buf.cbBuffer = curlx_uztoul(token_max); + + /* Generate our response message */ + status = Curl_pSecFn->InitializeSecurityContext(&credentials, NULL, spn, + 0, 0, 0, &chlg_desc, 0, + &context, &resp_desc, &attrs, + NULL); + + if(status == SEC_I_COMPLETE_NEEDED || + status == SEC_I_COMPLETE_AND_CONTINUE) + Curl_pSecFn->CompleteAuthToken(&credentials, &resp_desc); + else if(status != SEC_E_OK && status != SEC_I_CONTINUE_NEEDED) { + VERBOSE(char buffer[STRERROR_LEN]); + + Curl_pSecFn->FreeCredentialsHandle(&credentials); + Curl_sspi_free_identity(p_identity); + curlx_free(spn); + curlx_free(output_token); + + if(status == SEC_E_INSUFFICIENT_MEMORY) + return CURLE_OUT_OF_MEMORY; + + infof(data, "schannel: InitializeSecurityContext failed: %s", + Curl_sspi_strerror(status, buffer, sizeof(buffer))); + + return CURLE_AUTH_ERROR; + } + + /* Return the response. */ + Curl_bufref_set(out, output_token, resp_buf.cbBuffer, curl_free); + + /* Free our handles */ + Curl_pSecFn->DeleteSecurityContext(&context); + Curl_pSecFn->FreeCredentialsHandle(&credentials); + + /* Free the identity structure */ + Curl_sspi_free_identity(p_identity); + + /* Free the SPN */ + curlx_free(spn); + + return result; +} + +/* + * Curl_override_sspi_http_realm() + * + * This is used to populate the domain in an SSPI identity structure + * The realm is extracted from the challenge message and used as the + * domain if it is not already explicitly set. + * + * Parameters: + * + * chlg [in] - The challenge message. + * identity [in/out] - The identity structure. + * + * Returns CURLE_OK on success. + */ +CURLcode Curl_override_sspi_http_realm(const char *chlg, + SEC_WINNT_AUTH_IDENTITY *identity) +{ + xcharp_u domain, dup_domain; + + /* If domain is blank or unset, check challenge message for realm */ + if(!identity->Domain || !identity->DomainLength) { + for(;;) { + char value[DIGEST_MAX_VALUE_LENGTH]; + char content[DIGEST_MAX_CONTENT_LENGTH]; + + /* Pass all additional spaces here */ + while(*chlg && ISBLANK(*chlg)) + chlg++; + + /* Extract a value=content pair */ + if(Curl_auth_digest_get_pair(chlg, value, content, &chlg)) { + if(curl_strequal(value, "realm")) { + + /* Setup identity's domain and length */ + domain.tchar_ptr = curlx_convert_UTF8_to_tchar(content); + if(!domain.tchar_ptr) + return CURLE_OUT_OF_MEMORY; + + dup_domain.tchar_ptr = curlx_tcsdup(domain.tchar_ptr); + if(!dup_domain.tchar_ptr) { + curlx_free(domain.tchar_ptr); + return CURLE_OUT_OF_MEMORY; + } + + curlx_free(identity->Domain); + identity->Domain = dup_domain.tbyte_ptr; + identity->DomainLength = curlx_uztoul(_tcslen(dup_domain.tchar_ptr)); + dup_domain.tchar_ptr = NULL; + + curlx_free(domain.tchar_ptr); + } + else { + /* Unknown specifier, ignore it! */ + } + } + else + break; /* We are done here */ + + /* Pass all additional spaces here */ + while(*chlg && ISBLANK(*chlg)) + chlg++; + + /* Allow the list to be comma-separated */ + if(',' == *chlg) + chlg++; + } + } + + return CURLE_OK; +} + +/* + * Curl_auth_decode_digest_http_message() + * + * This is used to decode an HTTP DIGEST challenge message into the separate + * attributes. + * + * Parameters: + * + * chlg [in] - The challenge message. + * digest [in/out] - The digest data struct being used and modified. + * + * Returns CURLE_OK on success. + */ +CURLcode Curl_auth_decode_digest_http_message(const char *chlg, + struct digestdata *digest) +{ + size_t chlglen = strlen(chlg); + + /* We had an input token before so if there is another one now that means we + provided bad credentials in the previous request or it is stale. */ + if(digest->input_token) { + bool stale = FALSE; + const char *p = chlg; + + /* Check for the 'stale' directive */ + for(;;) { + char value[DIGEST_MAX_VALUE_LENGTH]; + char content[DIGEST_MAX_CONTENT_LENGTH]; + + while(*p && ISBLANK(*p)) + p++; + + if(!Curl_auth_digest_get_pair(p, value, content, &p)) + break; + + if(curl_strequal(value, "stale") && + curl_strequal(content, "true")) { + stale = TRUE; + break; + } + + while(*p && ISBLANK(*p)) + p++; + + if(',' == *p) + p++; + } + + if(stale) + Curl_auth_digest_cleanup(digest); + else + return CURLE_LOGIN_DENIED; + } + + /* Store the challenge for use later */ + digest->input_token = (BYTE *)curlx_memdup(chlg, chlglen + 1); + if(!digest->input_token) + return CURLE_OUT_OF_MEMORY; + + digest->input_token_len = chlglen; + + return CURLE_OK; +} + +/* + * Curl_auth_create_digest_http_message() + * + * This is used to generate an HTTP DIGEST response message ready for sending + * to the recipient. + * + * Parameters: + * + * data [in] - The session handle. + * userp [in] - The username in the format User or Domain\User. + * passwdp [in] - The user's password. + * request [in] - The HTTP request. + * uripath [in] - The path of the HTTP uri. + * digest [in/out] - The digest data struct being used and modified. + * outptr [in/out] - The address where a pointer to newly allocated memory + * holding the result is stored upon completion. + * outlen [out] - The length of the output message. + * + * Returns CURLE_OK on success. + */ +CURLcode Curl_auth_create_digest_http_message(struct Curl_easy *data, + struct Curl_creds *creds, + const unsigned char *request, + const unsigned char *uripath, + struct digestdata *digest, + char **outptr, size_t *outlen) +{ + size_t token_max; + char *resp; + BYTE *output_token; + size_t output_token_len = 0; + PSecPkgInfo SecurityPackage; + SecBuffer chlg_buf[5]; + SecBufferDesc chlg_desc; + SECURITY_STATUS status; + + /* Query the security package for DigestSSP */ + status = + Curl_pSecFn->QuerySecurityPackageInfo( + (TCHAR *)CURL_UNCONST(TEXT(SP_NAME_DIGEST)), + &SecurityPackage); + if(status != SEC_E_OK) { + failf(data, "SSPI: could not get auth info"); + return CURLE_AUTH_ERROR; + } + + token_max = SecurityPackage->cbMaxToken; + + /* Release the package buffer as it is not required anymore */ + Curl_pSecFn->FreeContextBuffer(SecurityPackage); + + /* Allocate the output buffer according to the max token size as indicated + by the security package */ + output_token = curlx_malloc(token_max); + if(!output_token) { + return CURLE_OUT_OF_MEMORY; + } + + /* If the user/passwd that was used to make the identity for http_context + has changed then delete that context. */ + if(!Curl_creds_same(creds, digest->creds)) { + if(digest->http_context) { + Curl_pSecFn->DeleteSecurityContext(digest->http_context); + curlx_safefree(digest->http_context); + } + Curl_creds_unlink(&digest->creds); + } + + if(digest->http_context) { + chlg_desc.ulVersion = SECBUFFER_VERSION; + chlg_desc.cBuffers = 5; + chlg_desc.pBuffers = chlg_buf; + chlg_buf[0].BufferType = SECBUFFER_TOKEN; + chlg_buf[0].pvBuffer = NULL; + chlg_buf[0].cbBuffer = 0; + chlg_buf[1].BufferType = SECBUFFER_PKG_PARAMS; + chlg_buf[1].pvBuffer = CURL_UNCONST(request); + chlg_buf[1].cbBuffer = curlx_uztoul(strlen((const char *)request)); + chlg_buf[2].BufferType = SECBUFFER_PKG_PARAMS; + chlg_buf[2].pvBuffer = CURL_UNCONST(uripath); + chlg_buf[2].cbBuffer = curlx_uztoul(strlen((const char *)uripath)); + chlg_buf[3].BufferType = SECBUFFER_PKG_PARAMS; + chlg_buf[3].pvBuffer = NULL; + chlg_buf[3].cbBuffer = 0; + chlg_buf[4].BufferType = SECBUFFER_PADDING; + chlg_buf[4].pvBuffer = output_token; + chlg_buf[4].cbBuffer = curlx_uztoul(token_max); + + status = Curl_pSecFn->MakeSignature(digest->http_context, 0, &chlg_desc, + 0); + if(status == SEC_E_OK) + output_token_len = chlg_buf[4].cbBuffer; + else { /* delete the context so a new one can be made */ + infof(data, "digest_sspi: MakeSignature failed, error 0x%08lx", + (unsigned long)status); + Curl_pSecFn->DeleteSecurityContext(digest->http_context); + curlx_safefree(digest->http_context); + } + } + + if(!digest->http_context) { + CredHandle credentials; + SEC_WINNT_AUTH_IDENTITY identity; + SEC_WINNT_AUTH_IDENTITY *p_identity; + SecBuffer resp_buf; + SecBufferDesc resp_desc; + unsigned long attrs; + TCHAR *spn; + + /* free the credentials used to make the previous identity */ + Curl_creds_unlink(&digest->creds); + + if(Curl_creds_has_user(creds)) { + /* Populate our identity structure */ + if(Curl_create_sspi_identity(creds->user, creds->passwd, &identity)) { + curlx_free(output_token); + return CURLE_OUT_OF_MEMORY; + } + + /* Populate our identity domain */ + if(Curl_override_sspi_http_realm((const char *)digest->input_token, + &identity)) { + Curl_sspi_free_identity(&identity); + curlx_free(output_token); + return CURLE_OUT_OF_MEMORY; + } + + /* Allow proper cleanup of the identity structure */ + p_identity = &identity; + } + else + /* Use the current Windows user */ + p_identity = NULL; + + if(creds) + Curl_creds_link(&digest->creds, creds); + + /* Acquire our credentials handle */ + status = Curl_pSecFn->AcquireCredentialsHandle(NULL, + (TCHAR *)CURL_UNCONST(TEXT(SP_NAME_DIGEST)), + SECPKG_CRED_OUTBOUND, NULL, + p_identity, NULL, NULL, + &credentials, NULL); + if(status != SEC_E_OK) { + Curl_sspi_free_identity(p_identity); + curlx_free(output_token); + + return CURLE_LOGIN_DENIED; + } + + /* Setup the challenge "input" security buffer if present */ + chlg_desc.ulVersion = SECBUFFER_VERSION; + chlg_desc.cBuffers = 3; + chlg_desc.pBuffers = chlg_buf; + chlg_buf[0].BufferType = SECBUFFER_TOKEN; + chlg_buf[0].pvBuffer = digest->input_token; + chlg_buf[0].cbBuffer = curlx_uztoul(digest->input_token_len); + chlg_buf[1].BufferType = SECBUFFER_PKG_PARAMS; + chlg_buf[1].pvBuffer = CURL_UNCONST(request); + chlg_buf[1].cbBuffer = curlx_uztoul(strlen((const char *)request)); + chlg_buf[2].BufferType = SECBUFFER_PKG_PARAMS; + chlg_buf[2].pvBuffer = NULL; + chlg_buf[2].cbBuffer = 0; + + /* Setup the response "output" security buffer */ + resp_desc.ulVersion = SECBUFFER_VERSION; + resp_desc.cBuffers = 1; + resp_desc.pBuffers = &resp_buf; + resp_buf.BufferType = SECBUFFER_TOKEN; + resp_buf.pvBuffer = output_token; + resp_buf.cbBuffer = curlx_uztoul(token_max); + + spn = curlx_convert_UTF8_to_tchar((const char *)uripath); + if(!spn) { + Curl_pSecFn->FreeCredentialsHandle(&credentials); + + Curl_sspi_free_identity(p_identity); + curlx_free(output_token); + + return CURLE_OUT_OF_MEMORY; + } + + /* Allocate our new context handle */ + digest->http_context = curlx_calloc(1, sizeof(CtxtHandle)); + if(!digest->http_context) { + Curl_pSecFn->FreeCredentialsHandle(&credentials); + curlx_free(spn); + Curl_sspi_free_identity(p_identity); + curlx_free(output_token); + return CURLE_OUT_OF_MEMORY; + } + + /* Generate our response message */ + status = Curl_pSecFn->InitializeSecurityContext(&credentials, NULL, + spn, + ISC_REQ_USE_HTTP_STYLE, + 0, 0, + &chlg_desc, 0, + digest->http_context, + &resp_desc, &attrs, NULL); + curlx_free(spn); + + if(status == SEC_I_COMPLETE_NEEDED || + status == SEC_I_COMPLETE_AND_CONTINUE) + Curl_pSecFn->CompleteAuthToken(&credentials, &resp_desc); + else if(status != SEC_E_OK && status != SEC_I_CONTINUE_NEEDED) { + VERBOSE(char buffer[STRERROR_LEN]); + + Curl_pSecFn->FreeCredentialsHandle(&credentials); + + Curl_sspi_free_identity(p_identity); + curlx_free(output_token); + + curlx_safefree(digest->http_context); + + if(status == SEC_E_INSUFFICIENT_MEMORY) + return CURLE_OUT_OF_MEMORY; + + infof(data, "schannel: InitializeSecurityContext failed: %s", + Curl_sspi_strerror(status, buffer, sizeof(buffer))); + + return CURLE_AUTH_ERROR; + } + + output_token_len = resp_buf.cbBuffer; + + Curl_pSecFn->FreeCredentialsHandle(&credentials); + Curl_sspi_free_identity(p_identity); + } + + resp = curlx_memdup0((const char *)output_token, output_token_len); + curlx_free(output_token); + if(!resp) { + return CURLE_OUT_OF_MEMORY; + } + + /* Return the response */ + *outptr = resp; + *outlen = output_token_len; + return CURLE_OK; +} + +/* + * Curl_auth_digest_cleanup() + * + * This is used to clean up the digest specific data. + * + * Parameters: + * + * digest [in/out] - The digest data struct being cleaned up. + * + */ +void Curl_auth_digest_cleanup(struct digestdata *digest) +{ + /* Free the input token */ + curlx_safefree(digest->input_token); + + /* Reset any variables */ + digest->input_token_len = 0; + + /* Delete security context */ + if(digest->http_context) { + Curl_pSecFn->DeleteSecurityContext(digest->http_context); + curlx_safefree(digest->http_context); + } + + /* Free the copy of user/passwd used to make the identity for http_context */ + Curl_creds_unlink(&digest->creds); + Curl_peer_unlink(&digest->origin); +} + +#endif /* USE_WINDOWS_SSPI && !CURL_DISABLE_DIGEST_AUTH */ diff --git a/3rdparty/curl-8.21.0/lib/vauth/gsasl.c b/3rdparty/curl-8.21.0/lib/vauth/gsasl.c new file mode 100644 index 0000000000..10a83fdb09 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vauth/gsasl.c @@ -0,0 +1,121 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Simon Josefsson, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + * RFC5802 SCRAM-SHA-1 authentication + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_GSASL + +#include "vauth/vauth.h" +#include "curl_trc.h" + +#include + +#if GSASL_VERSION_NUMBER < 0x010600 +#error "requires libgsasl 1.6.0+" +#endif + +bool Curl_auth_gsasl_is_supported(struct Curl_easy *data, + const char *mech, + struct gsasldata *gsasl) +{ + int res; + + res = gsasl_init(&gsasl->ctx); + if(res != GSASL_OK) { + failf(data, "gsasl init: %s", gsasl_strerror(res)); + return FALSE; + } + + res = gsasl_client_start(gsasl->ctx, mech, &gsasl->client); + if(res != GSASL_OK) { + gsasl_done(gsasl->ctx); + gsasl->ctx = NULL; + return FALSE; + } + + return TRUE; +} + +CURLcode Curl_auth_gsasl_start(struct Curl_easy *data, + struct Curl_creds *creds, + struct gsasldata *gsasl) +{ +#if GSASL_VERSION_NUMBER >= 0x010b00 + int res; + res = +#endif + gsasl_property_set(gsasl->client, GSASL_AUTHID, creds->user); +#if GSASL_VERSION_NUMBER >= 0x010b00 + if(res != GSASL_OK) { + failf(data, "setting AUTHID failed: %s", gsasl_strerror(res)); + return CURLE_OUT_OF_MEMORY; + } +#endif + +#if GSASL_VERSION_NUMBER >= 0x010b00 + res = +#endif + gsasl_property_set(gsasl->client, GSASL_PASSWORD, creds->passwd); +#if GSASL_VERSION_NUMBER >= 0x010b00 + if(res != GSASL_OK) { + failf(data, "setting PASSWORD failed: %s", gsasl_strerror(res)); + return CURLE_OUT_OF_MEMORY; + } +#endif + + (void)data; + + return CURLE_OK; +} + +CURLcode Curl_auth_gsasl_token(struct Curl_easy *data, + const struct bufref *chlg, + struct gsasldata *gsasl, + struct bufref *out) +{ + int res; + char *response; + size_t outlen; + + res = gsasl_step(gsasl->client, Curl_bufref_ptr(chlg), Curl_bufref_len(chlg), + &response, &outlen); + if(res != GSASL_OK && res != GSASL_NEEDS_MORE) { + failf(data, "GSASL step: %s", gsasl_strerror(res)); + return CURLE_BAD_CONTENT_ENCODING; + } + + Curl_bufref_set(out, response, outlen, gsasl_free); + return CURLE_OK; +} + +void Curl_auth_gsasl_cleanup(struct gsasldata *gsasl) +{ + gsasl_finish(gsasl->client); + gsasl->client = NULL; + + gsasl_done(gsasl->ctx); + gsasl->ctx = NULL; +} +#endif diff --git a/3rdparty/curl-8.21.0/lib/vauth/krb5_gssapi.c b/3rdparty/curl-8.21.0/lib/vauth/krb5_gssapi.c new file mode 100644 index 0000000000..738ce9a744 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vauth/krb5_gssapi.c @@ -0,0 +1,325 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Steve Holme, . + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + * RFC4752 The Kerberos V5 ("GSSAPI") SASL Mechanism + * + ***************************************************************************/ +#include "curl_setup.h" + +#if defined(HAVE_GSSAPI) && defined(USE_KERBEROS5) + +#include "vauth/vauth.h" +#include "curl_sasl.h" +#include "curl_gssapi.h" +#include "curl_trc.h" + +#if defined(CURL_HAVE_DIAG) && defined(__APPLE__) +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Wdeprecated-declarations" +#endif + +/* + * Curl_auth_is_gssapi_supported() + * + * This is used to evaluate if GSSAPI (Kerberos V5) is supported. + * + * Parameters: None + * + * Returns TRUE if Kerberos V5 is supported by the GSS-API library. + */ +bool Curl_auth_is_gssapi_supported(void) +{ + return TRUE; +} + +/* + * Curl_auth_create_gssapi_user_message() + * + * This is used to generate an already encoded GSSAPI (Kerberos V5) user token + * message ready for sending to the recipient. + * + * Parameters: + * + * data [in] - The session handle. + * userp [in] - The username. + * passwdp [in] - The user's password. + * service [in] - The service type such as http, smtp, pop or imap. + * host [in[ - The hostname. + * mutual_auth [in] - Flag specifying whether or not mutual authentication + * is enabled. + * chlg [in] - Optional challenge message. + * krb5 [in/out] - The Kerberos 5 data struct being used and modified. + * out [out] - The result storage. + * + * Returns CURLE_OK on success. + */ +CURLcode Curl_auth_create_gssapi_user_message(struct Curl_easy *data, + struct Curl_creds *creds, + const char *default_service, + const char *host, + const bool mutual_auth, + const struct bufref *chlg, + struct kerberos5data *krb5, + struct bufref *out) +{ + CURLcode result = CURLE_OK; + OM_uint32 major_status; + OM_uint32 minor_status; + OM_uint32 unused_status; + gss_buffer_desc input_token = GSS_C_EMPTY_BUFFER; + gss_buffer_desc output_token = GSS_C_EMPTY_BUFFER; + const char *service = Curl_creds_has_sasl_service(creds) ? + Curl_creds_sasl_service(creds) : default_service; + + if(!krb5->spn) { + gss_buffer_desc spn_token = GSS_C_EMPTY_BUFFER; + + /* Generate our SPN */ + char *spn = Curl_auth_build_spn(service, NULL, host); + if(!spn) + return CURLE_OUT_OF_MEMORY; + + /* Populate the SPN structure */ + spn_token.value = spn; + spn_token.length = strlen(spn); + + /* Import the SPN */ + major_status = gss_import_name(&minor_status, &spn_token, + GSS_C_NT_HOSTBASED_SERVICE, &krb5->spn); + if(GSS_ERROR(major_status)) { + Curl_gss_log_error(data, "gss_import_name() failed: ", + major_status, minor_status); + + curlx_free(spn); + + return CURLE_AUTH_ERROR; + } + + curlx_free(spn); + } + + if(chlg) { + if(!Curl_bufref_len(chlg)) { + infof(data, "GSSAPI handshake failure (empty challenge message)"); + return CURLE_BAD_CONTENT_ENCODING; + } + input_token.value = CURL_UNCONST(Curl_bufref_ptr(chlg)); + input_token.length = Curl_bufref_len(chlg); + } + + major_status = Curl_gss_init_sec_context(data, + &minor_status, + &krb5->context, + krb5->spn, + &Curl_krb5_mech_oid, + GSS_C_NO_CHANNEL_BINDINGS, + &input_token, + &output_token, + mutual_auth, + NULL); + + if(GSS_ERROR(major_status)) { + if(output_token.value) + gss_release_buffer(&unused_status, &output_token); + + Curl_gss_log_error(data, "gss_init_sec_context() failed: ", + major_status, minor_status); + + return CURLE_AUTH_ERROR; + } + + if(output_token.value && output_token.length) { + result = Curl_bufref_memdup0(out, output_token.value, output_token.length); + gss_release_buffer(&unused_status, &output_token); + } + else + Curl_bufref_set(out, mutual_auth ? "" : NULL, 0, NULL); + + return result; +} + +/* + * Curl_auth_create_gssapi_security_message() + * + * This is used to generate an already encoded GSSAPI (Kerberos V5) security + * token message ready for sending to the recipient. + * + * Parameters: + * + * data [in] - The session handle. + * authzid [in] - The authorization identity if some. + * chlg [in] - Optional challenge message. + * krb5 [in/out] - The Kerberos 5 data struct being used and modified. + * out [out] - The result storage. + * + * Returns CURLE_OK on success. + */ +CURLcode Curl_auth_create_gssapi_security_message(struct Curl_easy *data, + const char *authzid, + const struct bufref *chlg, + struct kerberos5data *krb5, + struct bufref *out) +{ + CURLcode result = CURLE_OK; + size_t messagelen = 0; + unsigned char *message = NULL; + OM_uint32 major_status; + OM_uint32 minor_status; + OM_uint32 unused_status; + gss_buffer_desc input_token = GSS_C_EMPTY_BUFFER; + gss_buffer_desc output_token = GSS_C_EMPTY_BUFFER; + unsigned char *indata; + gss_qop_t qop = GSS_C_QOP_DEFAULT; + unsigned int sec_layer = 0; + unsigned int max_size = 0; + + /* Ensure we have a valid challenge message */ + if(!Curl_bufref_len(chlg)) { + infof(data, "GSSAPI handshake failure (empty security message)"); + return CURLE_BAD_CONTENT_ENCODING; + } + + /* Setup the challenge "input" security buffer */ + input_token.value = CURL_UNCONST(Curl_bufref_ptr(chlg)); + input_token.length = Curl_bufref_len(chlg); + + /* Decrypt the inbound challenge and obtain the qop */ + major_status = gss_unwrap(&minor_status, krb5->context, &input_token, + &output_token, NULL, &qop); + if(GSS_ERROR(major_status)) { + Curl_gss_log_error(data, "gss_unwrap() failed: ", + major_status, minor_status); + return CURLE_BAD_CONTENT_ENCODING; + } + + /* Not 4 octets long so fail as per RFC4752 Section 3.1 */ + if(output_token.length != 4) { + infof(data, "GSSAPI handshake failure (invalid security data)"); + gss_release_buffer(&unused_status, &output_token); + return CURLE_BAD_CONTENT_ENCODING; + } + + /* Extract the security layer and the maximum message size */ + indata = output_token.value; + sec_layer = indata[0]; + max_size = ((unsigned int)indata[1] << 16) | + ((unsigned int)indata[2] << 8) | indata[3]; + + /* Free the challenge as it is not required anymore */ + gss_release_buffer(&unused_status, &output_token); + + /* Process the security layer */ + if(!(sec_layer & GSSAUTH_P_NONE)) { + infof(data, "GSSAPI handshake failure (invalid security layer)"); + + return CURLE_BAD_CONTENT_ENCODING; + } + sec_layer &= GSSAUTH_P_NONE; /* We do not support a security layer */ + + /* Process the maximum message size the server can receive */ + if(max_size > 0) { + /* The server has told us it supports a maximum receive buffer, but as we + do not require one unless we are encrypting data, we tell the server + our receive buffer is zero. */ + max_size = 0; + } + + /* Allocate our message */ + messagelen = 4; + if(authzid) + messagelen += strlen(authzid); + message = curlx_malloc(messagelen); + if(!message) + return CURLE_OUT_OF_MEMORY; + + /* Populate the message with the security layer and client supported receive + message size. */ + message[0] = sec_layer & 0xFF; + message[1] = (max_size >> 16) & 0xFF; + message[2] = (max_size >> 8) & 0xFF; + message[3] = max_size & 0xFF; + + /* If given, append the authorization identity. */ + + if(authzid && *authzid) + memcpy(message + 4, authzid, messagelen - 4); + + /* Setup the "authentication data" security buffer */ + input_token.value = message; + input_token.length = messagelen; + + /* Encrypt the data */ + major_status = gss_wrap(&minor_status, krb5->context, 0, + GSS_C_QOP_DEFAULT, &input_token, NULL, + &output_token); + if(GSS_ERROR(major_status)) { + Curl_gss_log_error(data, "gss_wrap() failed: ", + major_status, minor_status); + curlx_free(message); + return CURLE_AUTH_ERROR; + } + + /* Return the response. */ + result = Curl_bufref_memdup0(out, output_token.value, output_token.length); + /* Free the output buffer */ + gss_release_buffer(&unused_status, &output_token); + + /* Free the message buffer */ + curlx_free(message); + + return result; +} + +/* + * Curl_auth_cleanup_gssapi() + * + * This is used to clean up the GSSAPI (Kerberos V5) specific data. + * + * Parameters: + * + * krb5 [in/out] - The Kerberos 5 data struct being cleaned up. + * + */ +void Curl_auth_cleanup_gssapi(struct kerberos5data *krb5) +{ + OM_uint32 minor_status; + + /* Free our security context */ + if(krb5->context != GSS_C_NO_CONTEXT) { + Curl_gss_delete_sec_context(&minor_status, &krb5->context, + GSS_C_NO_BUFFER); + krb5->context = GSS_C_NO_CONTEXT; + } + + /* Free the SPN */ + if(krb5->spn != GSS_C_NO_NAME) { + gss_release_name(&minor_status, &krb5->spn); + krb5->spn = GSS_C_NO_NAME; + } +} + +#if defined(CURL_HAVE_DIAG) && defined(__APPLE__) +#pragma GCC diagnostic pop +#endif + +#endif /* HAVE_GSSAPI && USE_KERBEROS5 */ diff --git a/3rdparty/curl-8.21.0/lib/vauth/krb5_sspi.c b/3rdparty/curl-8.21.0/lib/vauth/krb5_sspi.c new file mode 100644 index 0000000000..543a6fe284 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vauth/krb5_sspi.c @@ -0,0 +1,456 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Steve Holme, . + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + * RFC4752 The Kerberos V5 ("GSSAPI") SASL Mechanism + * + ***************************************************************************/ +#include "curl_setup.h" + +#if defined(USE_WINDOWS_SSPI) && defined(USE_KERBEROS5) + +#include "vauth/vauth.h" +#include "curl_trc.h" + +/* + * Curl_auth_is_gssapi_supported() + * + * This is used to evaluate if GSSAPI (Kerberos V5) is supported. + * + * Parameters: None + * + * Returns TRUE if Kerberos V5 is supported by Windows SSPI. + */ +bool Curl_auth_is_gssapi_supported(void) +{ + PSecPkgInfo SecurityPackage; + SECURITY_STATUS status; + + /* Query the security package for Kerberos */ + status = Curl_pSecFn->QuerySecurityPackageInfo( + (TCHAR *)CURL_UNCONST(TEXT(SP_NAME_KERBEROS)), + &SecurityPackage); + + /* Release the package buffer as it is not required anymore */ + if(status == SEC_E_OK) { + Curl_pSecFn->FreeContextBuffer(SecurityPackage); + } + + return status == SEC_E_OK; +} + +/* + * Curl_auth_create_gssapi_user_message() + * + * This is used to generate an already encoded GSSAPI (Kerberos V5) user token + * message ready for sending to the recipient. + * + * Parameters: + * + * data [in] - The session handle. + * userp [in] - The username in the format User or Domain\User. + * passwdp [in] - The user's password. + * service [in] - The service type such as http, smtp, pop or imap. + * host [in] - The hostname. + * mutual_auth [in] - Flag specifying whether or not mutual authentication + * is enabled. + * chlg [in] - Optional challenge message. + * krb5 [in/out] - The Kerberos 5 data struct being used and modified. + * out [out] - The result storage. + * + * Returns CURLE_OK on success. + */ +CURLcode Curl_auth_create_gssapi_user_message(struct Curl_easy *data, + struct Curl_creds *creds, + const char *default_service, + const char *host, + const bool mutual_auth, + const struct bufref *chlg, + struct kerberos5data *krb5, + struct bufref *out) +{ + CURLcode result = CURLE_OK; + CtxtHandle context; + PSecPkgInfo SecurityPackage; + SecBuffer chlg_buf; + SecBuffer resp_buf; + SecBufferDesc chlg_desc; + SecBufferDesc resp_desc; + SECURITY_STATUS status; + unsigned long attrs; + const char *service = Curl_creds_has_sasl_service(creds) ? + Curl_creds_sasl_service(creds) : default_service; + + if(!krb5->spn) { + /* Generate our SPN */ + krb5->spn = Curl_auth_build_spn(service, host, NULL); + if(!krb5->spn) + return CURLE_OUT_OF_MEMORY; + } + + if(!krb5->output_token) { + /* Query the security package for Kerberos */ + status = Curl_pSecFn->QuerySecurityPackageInfo( + (TCHAR *)CURL_UNCONST(TEXT(SP_NAME_KERBEROS)), + &SecurityPackage); + if(status != SEC_E_OK) { + failf(data, "SSPI: could not get auth info"); + return CURLE_AUTH_ERROR; + } + + krb5->token_max = SecurityPackage->cbMaxToken; + + /* Release the package buffer as it is not required anymore */ + Curl_pSecFn->FreeContextBuffer(SecurityPackage); + + /* Allocate our response buffer */ + krb5->output_token = curlx_malloc(krb5->token_max); + if(!krb5->output_token) + return CURLE_OUT_OF_MEMORY; + } + + if(!krb5->credentials) { + /* Do we have credentials to use or are we using single sign-on? */ + if(Curl_creds_has_user(creds)) { + /* Populate our identity structure */ + result = Curl_create_sspi_identity( + creds->user, creds->passwd, &krb5->identity); + if(result) + return result; + + /* Allow proper cleanup of the identity structure */ + krb5->p_identity = &krb5->identity; + } + else + /* Use the current Windows user */ + krb5->p_identity = NULL; + + /* Allocate our credentials handle */ + krb5->credentials = curlx_calloc(1, sizeof(CredHandle)); + if(!krb5->credentials) + return CURLE_OUT_OF_MEMORY; + + /* Acquire our credentials handle */ + status = Curl_pSecFn->AcquireCredentialsHandle(NULL, + (TCHAR *)CURL_UNCONST(TEXT(SP_NAME_KERBEROS)), + SECPKG_CRED_OUTBOUND, NULL, + krb5->p_identity, NULL, NULL, + krb5->credentials, NULL); + if(status != SEC_E_OK) { + curlx_safefree(krb5->credentials); + return CURLE_LOGIN_DENIED; + } + + /* Allocate our new context handle */ + krb5->context = curlx_calloc(1, sizeof(CtxtHandle)); + if(!krb5->context) + return CURLE_OUT_OF_MEMORY; + } + + if(chlg) { + if(!Curl_bufref_len(chlg)) { + infof(data, "GSSAPI handshake failure (empty challenge message)"); + return CURLE_BAD_CONTENT_ENCODING; + } + + /* Setup the challenge "input" security buffer */ + chlg_desc.ulVersion = SECBUFFER_VERSION; + chlg_desc.cBuffers = 1; + chlg_desc.pBuffers = &chlg_buf; + chlg_buf.BufferType = SECBUFFER_TOKEN; + chlg_buf.pvBuffer = CURL_UNCONST(Curl_bufref_ptr(chlg)); + chlg_buf.cbBuffer = curlx_uztoul(Curl_bufref_len(chlg)); + } + + /* Setup the response "output" security buffer */ + resp_desc.ulVersion = SECBUFFER_VERSION; + resp_desc.cBuffers = 1; + resp_desc.pBuffers = &resp_buf; + resp_buf.BufferType = SECBUFFER_TOKEN; + resp_buf.pvBuffer = krb5->output_token; + resp_buf.cbBuffer = curlx_uztoul(krb5->token_max); + + /* Generate our challenge-response message */ + status = Curl_pSecFn->InitializeSecurityContext(krb5->credentials, + chlg ? krb5->context : NULL, + krb5->spn, + (mutual_auth ? + ISC_REQ_MUTUAL_AUTH : 0), + 0, SECURITY_NATIVE_DREP, + chlg ? &chlg_desc : NULL, 0, + &context, + &resp_desc, &attrs, NULL); + + if(status == SEC_E_INSUFFICIENT_MEMORY) + return CURLE_OUT_OF_MEMORY; + + if(status != SEC_E_OK && status != SEC_I_CONTINUE_NEEDED) + return CURLE_AUTH_ERROR; + + if(memcmp(&context, krb5->context, sizeof(context))) { + Curl_pSecFn->DeleteSecurityContext(krb5->context); + + memcpy(krb5->context, &context, sizeof(context)); + } + + if(resp_buf.cbBuffer) { + result = Curl_bufref_memdup0(out, resp_buf.pvBuffer, resp_buf.cbBuffer); + } + else if(mutual_auth) + Curl_bufref_set(out, "", 0, NULL); + else + Curl_bufref_set(out, NULL, 0, NULL); + + return result; +} + +/* + * Curl_auth_create_gssapi_security_message() + * + * This is used to generate an already encoded GSSAPI (Kerberos V5) security + * token message ready for sending to the recipient. + * + * Parameters: + * + * data [in] - The session handle. + * authzid [in] - The authorization identity if some. + * chlg [in] - The challenge message. + * krb5 [in/out] - The Kerberos 5 data struct being used and modified. + * out [out] - The result storage. + * + * Returns CURLE_OK on success. + */ +CURLcode Curl_auth_create_gssapi_security_message(struct Curl_easy *data, + const char *authzid, + const struct bufref *chlg, + struct kerberos5data *krb5, + struct bufref *out) +{ + CURLcode result = CURLE_OK; + size_t offset = 0; + size_t messagelen = 0; + size_t appdatalen = 0; + unsigned char *trailer = NULL; + unsigned char *message = NULL; + unsigned char *padding = NULL; + unsigned char *appdata = NULL; + SecBuffer input_buf[2]; + SecBuffer wrap_buf[3]; + SecBufferDesc input_desc; + SecBufferDesc wrap_desc; + unsigned char *indata; + unsigned long qop = 0; + unsigned long sec_layer = 0; + unsigned long max_size = 0; + SecPkgContext_Sizes sizes; + SECURITY_STATUS status; + + /* Ensure we have a valid challenge message */ + DEBUGASSERT(chlg); + if(!Curl_bufref_len(chlg)) { + infof(data, "GSSAPI handshake failure (empty security message)"); + return CURLE_BAD_CONTENT_ENCODING; + } + + /* Get our response size information */ + status = Curl_pSecFn->QueryContextAttributes(krb5->context, + SECPKG_ATTR_SIZES, &sizes); + + if(status == SEC_E_INSUFFICIENT_MEMORY) + return CURLE_OUT_OF_MEMORY; + + if(status != SEC_E_OK) + return CURLE_AUTH_ERROR; + + /* Setup the "input" security buffer */ + input_desc.ulVersion = SECBUFFER_VERSION; + input_desc.cBuffers = 2; + input_desc.pBuffers = input_buf; + input_buf[0].BufferType = SECBUFFER_STREAM; + input_buf[0].pvBuffer = CURL_UNCONST(Curl_bufref_ptr(chlg)); + input_buf[0].cbBuffer = curlx_uztoul(Curl_bufref_len(chlg)); + input_buf[1].BufferType = SECBUFFER_DATA; + input_buf[1].pvBuffer = NULL; + input_buf[1].cbBuffer = 0; + + /* Decrypt the inbound challenge and obtain the qop. The encrypted message + is decrypted in place, overwriting the original contents of its buffer. + The SECBUFFER_DATA receives a pointer to the message in + SECBUFFER_STREAM. */ + status = Curl_pSecFn->DecryptMessage(krb5->context, &input_desc, 0, &qop); + if(status != SEC_E_OK) { + infof(data, "GSSAPI handshake failure (decryption failed)"); + return CURLE_BAD_CONTENT_ENCODING; + } + + /* Not 4 octets long so fail as per RFC4752 Section 3.1 */ + if(input_buf[1].cbBuffer != 4) { + infof(data, "GSSAPI handshake failure (invalid security data)"); + return CURLE_BAD_CONTENT_ENCODING; + } + + /* Extract the security layer and the maximum message size */ + indata = input_buf[1].pvBuffer; + sec_layer = indata[0]; + max_size = ((unsigned long)indata[1] << 16) | + ((unsigned long)indata[2] << 8) | indata[3]; + + /* Process the security layer */ + if(!(sec_layer & KERB_WRAP_NO_ENCRYPT)) { + infof(data, "GSSAPI handshake failure (invalid security layer)"); + return CURLE_BAD_CONTENT_ENCODING; + } + sec_layer &= KERB_WRAP_NO_ENCRYPT; /* We do not support a security layer */ + + /* Process the maximum message size the server can receive */ + if(max_size > 0) { + /* The server has told us it supports a maximum receive buffer, but as we + do not require one unless we are encrypting data, we tell the server + our receive buffer is zero. */ + max_size = 0; + } + + /* Allocate the trailer */ + trailer = curlx_malloc(sizes.cbSecurityTrailer); + if(!trailer) + return CURLE_OUT_OF_MEMORY; + + /* Allocate our message */ + messagelen = 4; + if(authzid) + messagelen += strlen(authzid); + message = curlx_malloc(messagelen); + if(!message) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + /* Populate the message with the security layer and client supported receive + message size. */ + message[0] = sec_layer & 0xFF; + message[1] = (max_size >> 16) & 0xFF; + message[2] = (max_size >> 8) & 0xFF; + message[3] = max_size & 0xFF; + + /* If given, append the authorization identity. */ + + if(authzid && *authzid) + memcpy(message + 4, authzid, messagelen - 4); + + /* Allocate the padding */ + padding = curlx_malloc(sizes.cbBlockSize); + if(!padding) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + /* Setup the "authentication data" security buffer */ + wrap_desc.ulVersion = SECBUFFER_VERSION; + wrap_desc.cBuffers = 3; + wrap_desc.pBuffers = wrap_buf; + wrap_buf[0].BufferType = SECBUFFER_TOKEN; + wrap_buf[0].pvBuffer = trailer; + wrap_buf[0].cbBuffer = sizes.cbSecurityTrailer; + wrap_buf[1].BufferType = SECBUFFER_DATA; + wrap_buf[1].pvBuffer = message; + wrap_buf[1].cbBuffer = curlx_uztoul(messagelen); + wrap_buf[2].BufferType = SECBUFFER_PADDING; + wrap_buf[2].pvBuffer = padding; + wrap_buf[2].cbBuffer = sizes.cbBlockSize; + + /* Encrypt the data */ + status = Curl_pSecFn->EncryptMessage(krb5->context, KERB_WRAP_NO_ENCRYPT, + &wrap_desc, 0); + if(status != SEC_E_OK) { + if(status == SEC_E_INSUFFICIENT_MEMORY) + result = CURLE_OUT_OF_MEMORY; + else + result = CURLE_AUTH_ERROR; + goto out; + } + + /* Allocate the encryption (wrap) buffer */ + appdatalen = wrap_buf[0].cbBuffer + wrap_buf[1].cbBuffer + + wrap_buf[2].cbBuffer; + appdata = curlx_malloc(appdatalen); + if(!appdata) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + /* Populate the encryption buffer */ + memcpy(appdata, wrap_buf[0].pvBuffer, wrap_buf[0].cbBuffer); + offset += wrap_buf[0].cbBuffer; + memcpy(appdata + offset, wrap_buf[1].pvBuffer, wrap_buf[1].cbBuffer); + offset += wrap_buf[1].cbBuffer; + memcpy(appdata + offset, wrap_buf[2].pvBuffer, wrap_buf[2].cbBuffer); + +out: + /* Free all of our local buffers */ + curlx_free(padding); + curlx_free(message); + curlx_free(trailer); + + if(result) + return result; + + /* Return the response. */ + Curl_bufref_set(out, appdata, appdatalen, curl_free); + return CURLE_OK; +} + +/* + * Curl_auth_cleanup_gssapi() + * + * This is used to clean up the GSSAPI (Kerberos V5) specific data. + * + * Parameters: + * + * krb5 [in/out] - The Kerberos 5 data struct being cleaned up. + * + */ +void Curl_auth_cleanup_gssapi(struct kerberos5data *krb5) +{ + /* Free our security context */ + if(krb5->context) { + Curl_pSecFn->DeleteSecurityContext(krb5->context); + curlx_safefree(krb5->context); + } + + /* Free our credentials handle */ + if(krb5->credentials) { + Curl_pSecFn->FreeCredentialsHandle(krb5->credentials); + curlx_safefree(krb5->credentials); + } + + /* Free our identity */ + Curl_sspi_free_identity(krb5->p_identity); + krb5->p_identity = NULL; + + /* Free the SPN and output token */ + curlx_safefree(krb5->spn); + curlx_safefree(krb5->output_token); + + /* Reset any variables */ + krb5->token_max = 0; +} + +#endif /* USE_WINDOWS_SSPI && USE_KERBEROS5 */ diff --git a/3rdparty/curl-8.21.0/lib/vauth/ntlm.c b/3rdparty/curl-8.21.0/lib/vauth/ntlm.c new file mode 100644 index 0000000000..2803c05d9f --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vauth/ntlm.c @@ -0,0 +1,860 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if defined(USE_NTLM) && !defined(USE_WINDOWS_SSPI) + +/* + * NTLM details: + * + * https://davenport.sourceforge.net/ntlm.html + * https://www.innovation.ch/java/ntlm.html + */ + +#define DEBUG_ME 0 + +#include "vauth/vauth.h" +#include "curl_trc.h" +#include "curl_ntlm_core.h" +#include "rand.h" +#include "curlx/strdup.h" +#include "curl_endian.h" + +/* "NTLMSSP" signature is always in ASCII regardless of the platform */ +#define NTLMSSP_SIGNATURE "\x4e\x54\x4c\x4d\x53\x53\x50" + +/* NTLM buffer fixed size, large enough for long user + host + domain */ +#define NTLM_BUFSIZE 1024 + +/* Flag bits definitions based on + https://davenport.sourceforge.net/ntlm.html */ + +#define NTLMFLAG_NEGOTIATE_UNICODE (1 << 0) +/* Indicates that Unicode strings are supported for use in security buffer + data. */ + +#define NTLMFLAG_NEGOTIATE_OEM (1 << 1) +/* Indicates that OEM strings are supported for use in security buffer data. */ + +#define NTLMFLAG_REQUEST_TARGET (1 << 2) +/* Requests that the server's authentication realm be included in the Type 2 + message. */ + +#if DEBUG_ME +/* unknown (1 << 3) */ +#define NTLMFLAG_NEGOTIATE_SIGN (1 << 4) +/* Specifies that authenticated communication between the client and server + should carry a digital signature (message integrity). */ + +#define NTLMFLAG_NEGOTIATE_SEAL (1 << 5) +/* Specifies that authenticated communication between the client and server + should be encrypted (message confidentiality). */ + +#define NTLMFLAG_NEGOTIATE_DATAGRAM_STYLE (1 << 6) +/* Indicates that datagram authentication is being used. */ + +#define NTLMFLAG_NEGOTIATE_LM_KEY (1 << 7) +/* Indicates that the LAN Manager session key should be used for signing and + sealing authenticated communications. */ +#endif + +#define NTLMFLAG_NEGOTIATE_NTLM_KEY (1 << 9) +/* Indicates that NTLM authentication is being used. */ + +#if DEBUG_ME +/* unknown (1 << 10) */ + +#define NTLMFLAG_NEGOTIATE_ANONYMOUS (1 << 11) +/* Sent by the client in the Type 3 message to indicate that an anonymous + context has been established. This also affects the response fields. */ + +#define NTLMFLAG_NEGOTIATE_DOMAIN_SUPPLIED (1 << 12) +/* Sent by the client in the Type 1 message to indicate that a desired + authentication realm is included in the message. */ + +#define NTLMFLAG_NEGOTIATE_WORKSTATION_SUPPLIED (1 << 13) +/* Sent by the client in the Type 1 message to indicate that the client + workstation's name is included in the message. */ + +#define NTLMFLAG_NEGOTIATE_LOCAL_CALL (1 << 14) +/* Sent by the server to indicate that the server and client are on the same + machine. Implies that the client may use a pre-established local security + context rather than responding to the challenge. */ +#endif + +#define NTLMFLAG_NEGOTIATE_ALWAYS_SIGN (1 << 15) +/* Indicates that authenticated communication between the client and server + should be signed with a "dummy" signature. */ + +#if DEBUG_ME +#define NTLMFLAG_TARGET_TYPE_DOMAIN (1 << 16) +/* Sent by the server in the Type 2 message to indicate that the target + authentication realm is a domain. */ + +#define NTLMFLAG_TARGET_TYPE_SERVER (1 << 17) +/* Sent by the server in the Type 2 message to indicate that the target + authentication realm is a server. */ + +#define NTLMFLAG_TARGET_TYPE_SHARE (1 << 18) +/* Sent by the server in the Type 2 message to indicate that the target + authentication realm is a share. Presumably, this is for share-level + authentication. Usage is unclear. */ +#endif + +#define NTLMFLAG_NEGOTIATE_NTLM2_KEY (1 << 19) +/* Indicates that the NTLM2 signing and sealing scheme should be used for + protecting authenticated communications. */ + +#if DEBUG_ME +#define NTLMFLAG_REQUEST_INIT_RESPONSE (1 << 20) +/* unknown purpose */ + +#define NTLMFLAG_REQUEST_ACCEPT_RESPONSE (1 << 21) +/* unknown purpose */ + +#define NTLMFLAG_REQUEST_NONNT_SESSION_KEY (1 << 22) +/* unknown purpose */ +#endif + +#define NTLMFLAG_NEGOTIATE_TARGET_INFO (1 << 23) +/* Sent by the server in the Type 2 message to indicate that it is including a + Target Information block in the message. */ + +#if DEBUG_ME +/* unknown (1<24) */ +/* unknown (1<25) */ +/* unknown (1<26) */ +/* unknown (1<27) */ +/* unknown (1<28) */ + +#define NTLMFLAG_NEGOTIATE_128 (1 << 29) +/* Indicates that 128-bit encryption is supported. */ + +#define NTLMFLAG_NEGOTIATE_KEY_EXCHANGE (1 << 30) +/* Indicates that the client provides an encrypted master key in + the "Session Key" field of the Type 3 message. */ + +#define NTLMFLAG_NEGOTIATE_56 (1 << 31) +/* Indicates that 56-bit encryption is supported. */ + +#define DEBUG_OUT(x) x +static void ntlm_print_flags(FILE *handle, unsigned long flags) +{ + if(flags & NTLMFLAG_NEGOTIATE_UNICODE) + curl_mfprintf(handle, "NTLMFLAG_NEGOTIATE_UNICODE "); + if(flags & NTLMFLAG_NEGOTIATE_OEM) + curl_mfprintf(handle, "NTLMFLAG_NEGOTIATE_OEM "); + if(flags & NTLMFLAG_REQUEST_TARGET) + curl_mfprintf(handle, "NTLMFLAG_REQUEST_TARGET "); + if(flags & (1 << 3)) + curl_mfprintf(handle, "NTLMFLAG_UNKNOWN_3 "); + if(flags & NTLMFLAG_NEGOTIATE_SIGN) + curl_mfprintf(handle, "NTLMFLAG_NEGOTIATE_SIGN "); + if(flags & NTLMFLAG_NEGOTIATE_SEAL) + curl_mfprintf(handle, "NTLMFLAG_NEGOTIATE_SEAL "); + if(flags & NTLMFLAG_NEGOTIATE_DATAGRAM_STYLE) + curl_mfprintf(handle, "NTLMFLAG_NEGOTIATE_DATAGRAM_STYLE "); + if(flags & NTLMFLAG_NEGOTIATE_LM_KEY) + curl_mfprintf(handle, "NTLMFLAG_NEGOTIATE_LM_KEY "); + if(flags & NTLMFLAG_NEGOTIATE_NTLM_KEY) + curl_mfprintf(handle, "NTLMFLAG_NEGOTIATE_NTLM_KEY "); + if(flags & (1 << 10)) + curl_mfprintf(handle, "NTLMFLAG_UNKNOWN_10 "); + if(flags & NTLMFLAG_NEGOTIATE_ANONYMOUS) + curl_mfprintf(handle, "NTLMFLAG_NEGOTIATE_ANONYMOUS "); + if(flags & NTLMFLAG_NEGOTIATE_DOMAIN_SUPPLIED) + curl_mfprintf(handle, "NTLMFLAG_NEGOTIATE_DOMAIN_SUPPLIED "); + if(flags & NTLMFLAG_NEGOTIATE_WORKSTATION_SUPPLIED) + curl_mfprintf(handle, "NTLMFLAG_NEGOTIATE_WORKSTATION_SUPPLIED "); + if(flags & NTLMFLAG_NEGOTIATE_LOCAL_CALL) + curl_mfprintf(handle, "NTLMFLAG_NEGOTIATE_LOCAL_CALL "); + if(flags & NTLMFLAG_NEGOTIATE_ALWAYS_SIGN) + curl_mfprintf(handle, "NTLMFLAG_NEGOTIATE_ALWAYS_SIGN "); + if(flags & NTLMFLAG_TARGET_TYPE_DOMAIN) + curl_mfprintf(handle, "NTLMFLAG_TARGET_TYPE_DOMAIN "); + if(flags & NTLMFLAG_TARGET_TYPE_SERVER) + curl_mfprintf(handle, "NTLMFLAG_TARGET_TYPE_SERVER "); + if(flags & NTLMFLAG_TARGET_TYPE_SHARE) + curl_mfprintf(handle, "NTLMFLAG_TARGET_TYPE_SHARE "); + if(flags & NTLMFLAG_NEGOTIATE_NTLM2_KEY) + curl_mfprintf(handle, "NTLMFLAG_NEGOTIATE_NTLM2_KEY "); + if(flags & NTLMFLAG_REQUEST_INIT_RESPONSE) + curl_mfprintf(handle, "NTLMFLAG_REQUEST_INIT_RESPONSE "); + if(flags & NTLMFLAG_REQUEST_ACCEPT_RESPONSE) + curl_mfprintf(handle, "NTLMFLAG_REQUEST_ACCEPT_RESPONSE "); + if(flags & NTLMFLAG_REQUEST_NONNT_SESSION_KEY) + curl_mfprintf(handle, "NTLMFLAG_REQUEST_NONNT_SESSION_KEY "); + if(flags & NTLMFLAG_NEGOTIATE_TARGET_INFO) + curl_mfprintf(handle, "NTLMFLAG_NEGOTIATE_TARGET_INFO "); + if(flags & (1 << 24)) + curl_mfprintf(handle, "NTLMFLAG_UNKNOWN_24 "); + if(flags & (1 << 25)) + curl_mfprintf(handle, "NTLMFLAG_UNKNOWN_25 "); + if(flags & (1 << 26)) + curl_mfprintf(handle, "NTLMFLAG_UNKNOWN_26 "); + if(flags & (1 << 27)) + curl_mfprintf(handle, "NTLMFLAG_UNKNOWN_27 "); + if(flags & (1 << 28)) + curl_mfprintf(handle, "NTLMFLAG_UNKNOWN_28 "); + if(flags & NTLMFLAG_NEGOTIATE_128) + curl_mfprintf(handle, "NTLMFLAG_NEGOTIATE_128 "); + if(flags & NTLMFLAG_NEGOTIATE_KEY_EXCHANGE) + curl_mfprintf(handle, "NTLMFLAG_NEGOTIATE_KEY_EXCHANGE "); + if(flags & NTLMFLAG_NEGOTIATE_56) + curl_mfprintf(handle, "NTLMFLAG_NEGOTIATE_56 "); +} + +static void ntlm_print_hex(FILE *handle, const char *buf, size_t len) +{ + const char *p = buf; + + (void)handle; + + curl_mfprintf(stderr, "0x"); + while(len-- > 0) + curl_mfprintf(stderr, "%02.2x", (unsigned int)*p++); +} +#else +#define DEBUG_OUT(x) Curl_nop_stmt +#endif + +/* + * ntlm_decode_type2_target() + * + * This is used to decode the "target info" in the NTLM type-2 message + * received. + * + * Parameters: + * + * data [in] - The session handle. + * type2ref [in] - The type-2 message. + * ntlm [in/out] - The NTLM data struct being used and modified. + * + * Returns CURLE_OK on success. + */ +static CURLcode ntlm_decode_type2_target(struct Curl_easy *data, + const struct bufref *type2ref, + struct ntlmdata *ntlm) +{ + unsigned short target_info_len = 0; + unsigned int target_info_offset = 0; + const unsigned char *type2 = Curl_bufref_uptr(type2ref); + size_t type2len = Curl_bufref_len(type2ref); + + if(type2len >= 48) { + target_info_len = Curl_read16_le(&type2[40]); + target_info_offset = Curl_read32_le(&type2[44]); + if(target_info_len > 0) { + if((target_info_offset > type2len) || + (target_info_offset + target_info_len) > type2len || + target_info_offset < 48) { + infof(data, "NTLM handshake failure (bad type-2 message). " + "Target Info Offset Len is set incorrect by the peer"); + return CURLE_BAD_CONTENT_ENCODING; + } + + curlx_free(ntlm->target_info); /* replace any previous data */ + ntlm->target_info = curlx_memdup(&type2[target_info_offset], + target_info_len); + if(!ntlm->target_info) + return CURLE_OUT_OF_MEMORY; + } + } + + ntlm->target_info_len = target_info_len; + + return CURLE_OK; +} + +/* + NTLM message structure notes: + + A 'short' is a 'network short', a little-endian 16-bit unsigned value. + + A 'long' is a 'network long', a little-endian, 32-bit unsigned value. + + A 'security buffer' represents a triplet used to point to a buffer, + consisting of two shorts and one long: + + 1. A 'short' containing the length of the buffer content in bytes. + 2. A 'short' containing the allocated space for the buffer in bytes. + 3. A 'long' containing the offset to the start of the buffer in bytes, + from the beginning of the NTLM message. +*/ + +/* + * Curl_auth_is_ntlm_supported() + * + * This is used to evaluate if NTLM is supported. + * + * Parameters: None + * + * Returns TRUE as NTLM as handled by libcurl. + */ +bool Curl_auth_is_ntlm_supported(void) +{ + return TRUE; +} + +/* + * Curl_auth_decode_ntlm_type2_message() + * + * This is used to decode an NTLM type-2 message. The raw NTLM message is + * checked * for validity before the appropriate data for creating a type-3 + * message is * written to the given NTLM data structure. + * + * Parameters: + * + * data [in] - The session handle. + * type2ref [in] - The type-2 message. + * ntlm [in/out] - The NTLM data struct being used and modified. + * + * Returns CURLE_OK on success. + */ +CURLcode Curl_auth_decode_ntlm_type2_message(struct Curl_easy *data, + const struct bufref *type2ref, + struct ntlmdata *ntlm) +{ + static const char type2_marker[] = { 0x02, 0x00, 0x00, 0x00 }; + + /* NTLM type-2 message structure: + + Index Description Content + 0 NTLMSSP Signature Null-terminated ASCII "NTLMSSP" + (0x4e544c4d53535000) + 8 NTLM Message Type long (0x02000000) + 12 Target Name security buffer + 20 Flags long + 24 Challenge 8 bytes + (32) Context 8 bytes (two consecutive longs) (*) + (40) Target Information security buffer (*) + (48) OS Version Structure 8 bytes (*) + 32 (48) (56) Start of data block (*) + (*) -> Optional + */ + + CURLcode result = CURLE_OK; + const unsigned char *type2 = Curl_bufref_uptr(type2ref); + size_t type2len = Curl_bufref_len(type2ref); + + ntlm->flags = 0; + + if((type2len < 32) || + memcmp(type2, NTLMSSP_SIGNATURE, 8) || + memcmp(type2 + 8, type2_marker, sizeof(type2_marker))) { + /* This was not a good enough type-2 message */ + infof(data, "NTLM handshake failure (bad type-2 message)"); + return CURLE_BAD_CONTENT_ENCODING; + } + + ntlm->flags = Curl_read32_le(&type2[20]); + memcpy(ntlm->nonce, &type2[24], 8); + + if(ntlm->flags & NTLMFLAG_NEGOTIATE_TARGET_INFO) { + result = ntlm_decode_type2_target(data, type2ref, ntlm); + if(result) { + infof(data, "NTLM handshake failure (bad type-2 message)"); + return result; + } + } + + DEBUG_OUT({ + curl_mfprintf(stderr, "**** TYPE2 header flags=0x%08.8lx ", ntlm->flags); + ntlm_print_flags(stderr, ntlm->flags); + curl_mfprintf(stderr, "\n nonce="); + ntlm_print_hex(stderr, (char *)ntlm->nonce, 8); + curl_mfprintf(stderr, "\n****\n"); + curl_mfprintf(stderr, "**** Header %s\n ", header); + }); + + return result; +} + +/* copy the source to the destination and fill in zeroes in every + other destination byte! */ +static void unicodecpy(unsigned char *dest, const char *src, size_t length) +{ + size_t i; + for(i = 0; i < length; i++) { + dest[2 * i] = (unsigned char)src[i]; + dest[(2 * i) + 1] = '\0'; + } +} + +/* + * Curl_auth_create_ntlm_type1_message() + * + * This is used to generate an NTLM type-1 message ready for sending to the + * recipient using the appropriate compile time crypto API. + * + * Parameters: + * + * data [in] - The session handle. + * userp [in] - The username in the format User or Domain\User. + * passwdp [in] - The user's password. + * service [in] - The service type such as http, smtp, pop or imap. + * host [in] - The hostname. + * ntlm [in/out] - The NTLM data struct being used and modified. + * out [out] - The result storage. + * + * Returns CURLE_OK on success. + */ +CURLcode Curl_auth_create_ntlm_type1_message(struct Curl_easy *data, + struct Curl_creds *creds, + const char *default_service, + const char *host, + struct ntlmdata *ntlm, + struct bufref *out) +{ + /* NTLM type-1 message structure: + + Index Description Content + 0 NTLMSSP Signature Null-terminated ASCII "NTLMSSP" + (0x4e544c4d53535000) + 8 NTLM Message Type long (0x01000000) + 12 Flags long + (16) Supplied Domain security buffer (*) + (24) Supplied Workstation security buffer (*) + (32) OS Version Structure 8 bytes (*) + (32) (40) Start of data block (*) + (*) -> Optional + */ + + const char *service = Curl_creds_has_sasl_service(creds) ? + Curl_creds_sasl_service(creds) : default_service; + size_t size; + + char *ntlmbuf; + const char *hostname = ""; /* empty */ + const char *domain = ""; /* empty */ + size_t hostlen = 0; + size_t domlen = 0; + size_t hostoff = 0; + size_t domoff = hostoff + hostlen; /* This is 0: remember that host and + domain are empty */ + (void)data; + (void)creds; + (void)service; + (void)host; + + /* Clean up any former leftovers and initialize to defaults */ + Curl_auth_cleanup_ntlm(ntlm); + + ntlmbuf = curl_maprintf(NTLMSSP_SIGNATURE "%c" + "\x01%c%c%c" /* 32-bit type = 1 */ + "%c%c%c%c" /* 32-bit NTLM flag field */ + "%c%c" /* domain length */ + "%c%c" /* domain allocated space */ + "%c%c" /* domain name offset */ + "%c%c" /* 2 zeroes */ + "%c%c" /* host length */ + "%c%c" /* host allocated space */ + "%c%c" /* hostname offset */ + "%c%c" /* 2 zeroes */ + "%s" /* hostname */ + "%s", /* domain string */ + 0, /* trailing zero */ + 0, 0, 0, /* part of type-1 long */ + + LONGQUARTET(NTLMFLAG_NEGOTIATE_OEM | + NTLMFLAG_REQUEST_TARGET | + NTLMFLAG_NEGOTIATE_NTLM_KEY | + NTLMFLAG_NEGOTIATE_NTLM2_KEY | + NTLMFLAG_NEGOTIATE_ALWAYS_SIGN), + SHORTPAIR(domlen), + SHORTPAIR(domlen), + SHORTPAIR(domoff), + 0, 0, + SHORTPAIR(hostlen), + SHORTPAIR(hostlen), + SHORTPAIR(hostoff), + 0, 0, + hostname, /* this is empty */ + domain /* this is empty */); + + if(!ntlmbuf) + return CURLE_OUT_OF_MEMORY; + + /* Initial packet length */ + size = 32 + hostlen + domlen; + + DEBUG_OUT({ + curl_mfprintf(stderr, "* TYPE1 header flags=0x%02.2x%02.2x%02.2x%02.2x " + "0x%08.8x ", + LONGQUARTET(NTLMFLAG_NEGOTIATE_OEM | + NTLMFLAG_REQUEST_TARGET | + NTLMFLAG_NEGOTIATE_NTLM_KEY | + NTLMFLAG_NEGOTIATE_NTLM2_KEY | + NTLMFLAG_NEGOTIATE_ALWAYS_SIGN), + NTLMFLAG_NEGOTIATE_OEM | + NTLMFLAG_REQUEST_TARGET | + NTLMFLAG_NEGOTIATE_NTLM_KEY | + NTLMFLAG_NEGOTIATE_NTLM2_KEY | + NTLMFLAG_NEGOTIATE_ALWAYS_SIGN); + ntlm_print_flags(stderr, + NTLMFLAG_NEGOTIATE_OEM | + NTLMFLAG_REQUEST_TARGET | + NTLMFLAG_NEGOTIATE_NTLM_KEY | + NTLMFLAG_NEGOTIATE_NTLM2_KEY | + NTLMFLAG_NEGOTIATE_ALWAYS_SIGN); + curl_mfprintf(stderr, "\n****\n"); + }); + + Curl_bufref_set(out, ntlmbuf, size, curl_free); + return CURLE_OK; +} + +/* + * Curl_auth_create_ntlm_type3_message() + * + * This is used to generate an already encoded NTLM type-3 message ready for + * sending to the recipient using the appropriate compile time crypto API. + * + * Parameters: + * + * data [in] - The session handle. + * userp [in] - The username in the format User or Domain\User. + * passwdp [in] - The user's password. + * ntlm [in/out] - The NTLM data struct being used and modified. + * out [out] - The result storage. + * + * Returns CURLE_OK on success. + */ +CURLcode Curl_auth_create_ntlm_type3_message(struct Curl_easy *data, + struct Curl_creds *creds, + struct ntlmdata *ntlm, + struct bufref *out) +{ + /* NTLM type-3 message structure: + + Index Description Content + 0 NTLMSSP Signature Null-terminated ASCII "NTLMSSP" + (0x4e544c4d53535000) + 8 NTLM Message Type long (0x03000000) + 12 LM/LMv2 Response security buffer + 20 NTLM/NTLMv2 Response security buffer + 28 Target Name security buffer + 36 username security buffer + 44 Workstation Name security buffer + (52) Session Key security buffer (*) + (60) Flags long (*) + (64) OS Version Structure 8 bytes (*) + 52 (64) (72) Start of data block + (*) -> Optional + */ + + CURLcode result = CURLE_OK; + size_t size; + unsigned char ntlmbuf[NTLM_BUFSIZE]; + unsigned int lmrespoff; + unsigned char lmresp[24]; /* fixed-size */ + unsigned int ntrespoff; + unsigned int ntresplen = 24; + unsigned char ntresp[24]; /* fixed-size */ + const unsigned char *ptr_ntresp = &ntresp[0]; + unsigned char *ntlmv2resp = NULL; + bool unicode = (ntlm->flags & NTLMFLAG_NEGOTIATE_UNICODE); + /* The fixed hostname we provide, in order to not leak our real local host + name. Copy the name used by Firefox. */ + static const char host[] = "WORKSTATION"; + const char *userp = Curl_creds_user(creds); + const char *passwdp = Curl_creds_passwd(creds); + const char *user; + const char *domain = ""; + size_t hostoff = 0; + size_t useroff = 0; + size_t domoff = 0; + size_t hostlen = 0; + size_t userlen = 0; + size_t domlen = 0; + + memset(lmresp, 0, sizeof(lmresp)); + memset(ntresp, 0, sizeof(ntresp)); + user = strchr(userp, '\\'); + if(!user) + user = strchr(userp, '/'); + + if(user) { + domain = userp; + domlen = (user - domain); + user++; + } + else + user = userp; + + userlen = strlen(user); + hostlen = sizeof(host) - 1; + + if(ntlm->flags & NTLMFLAG_NEGOTIATE_NTLM2_KEY) { + unsigned char ntbuffer[0x18]; + unsigned char entropy[8]; + unsigned char ntlmv2hash[0x18]; + + /* Full NTLM version 2 + Although this cannot be negotiated, it is used here if available, as + servers featuring extended security are likely supporting also + NTLMv2. */ + result = Curl_rand(data, entropy, 8); + if(result) + return result; + + result = Curl_ntlm_core_mk_nt_hash(passwdp, ntbuffer); + if(result) + return result; + + result = Curl_ntlm_core_mk_ntlmv2_hash(user, userlen, domain, domlen, + ntbuffer, ntlmv2hash); + if(result) + return result; + + /* LMv2 response */ + result = Curl_ntlm_core_mk_lmv2_resp(ntlmv2hash, entropy, + &ntlm->nonce[0], lmresp); + if(result) + return result; + + /* NTLMv2 response */ + result = Curl_ntlm_core_mk_ntlmv2_resp(ntlmv2hash, entropy, + ntlm, &ntlmv2resp, &ntresplen); + if(result) + return result; + + ptr_ntresp = ntlmv2resp; + } + else { + + unsigned char ntbuffer[0x18]; + unsigned char lmbuffer[0x18]; + + /* NTLM version 1 */ + + result = Curl_ntlm_core_mk_nt_hash(passwdp, ntbuffer); + if(result) + return result; + + Curl_ntlm_core_lm_resp(ntbuffer, &ntlm->nonce[0], ntresp); + + result = Curl_ntlm_core_mk_lm_hash(passwdp, lmbuffer); + if(result) + return result; + + Curl_ntlm_core_lm_resp(lmbuffer, &ntlm->nonce[0], lmresp); + ntlm->flags &= ~(unsigned int)NTLMFLAG_NEGOTIATE_NTLM2_KEY; + + /* A safer but less compatible alternative is: + * Curl_ntlm_core_lm_resp(ntbuffer, &ntlm->nonce[0], lmresp); + * See https://davenport.sourceforge.net/ntlm.html#ntlmVersion2 */ + } + + if(unicode) { + domlen = domlen * 2; + userlen = userlen * 2; + hostlen = hostlen * 2; + } + + lmrespoff = 64; /* size of the message header */ + ntrespoff = lmrespoff + 0x18; + domoff = ntrespoff + ntresplen; + useroff = domoff + domlen; + hostoff = useroff + userlen; + + /* Create the big type-3 message binary blob */ + size = curl_msnprintf((char *)ntlmbuf, NTLM_BUFSIZE, + NTLMSSP_SIGNATURE "%c" + "\x03%c%c%c" /* 32-bit type = 3 */ + + "%c%c" /* LanManager length */ + "%c%c" /* LanManager allocated space */ + "%c%c" /* LanManager offset */ + "%c%c" /* 2 zeroes */ + + "%c%c" /* NT-response length */ + "%c%c" /* NT-response allocated space */ + "%c%c" /* NT-response offset */ + "%c%c" /* 2 zeroes */ + + "%c%c" /* domain length */ + "%c%c" /* domain allocated space */ + "%c%c" /* domain name offset */ + "%c%c" /* 2 zeroes */ + + "%c%c" /* user length */ + "%c%c" /* user allocated space */ + "%c%c" /* user offset */ + "%c%c" /* 2 zeroes */ + + "%c%c" /* host length */ + "%c%c" /* host allocated space */ + "%c%c" /* host offset */ + "%c%c" /* 2 zeroes */ + + "%c%c" /* session key length (unknown purpose) */ + "%c%c" /* session key allocated space + (unknown purpose) */ + "%c%c" /* session key offset (unknown purpose) */ + "%c%c" /* 2 zeroes */ + + "%c%c%c%c", /* flags */ + + /* domain string */ + /* user string */ + /* host string */ + /* LanManager response */ + /* NT response */ + + 0, /* null-termination */ + 0, 0, 0, /* type-3 long, the 24 upper bits */ + + SHORTPAIR(0x18), /* LanManager response length, + twice */ + SHORTPAIR(0x18), + SHORTPAIR(lmrespoff), + 0x0, 0x0, + + SHORTPAIR(ntresplen), /* NT-response length, twice */ + SHORTPAIR(ntresplen), + SHORTPAIR(ntrespoff), + 0x0, 0x0, + + SHORTPAIR(domlen), + SHORTPAIR(domlen), + SHORTPAIR(domoff), + 0x0, 0x0, + + SHORTPAIR(userlen), + SHORTPAIR(userlen), + SHORTPAIR(useroff), + 0x0, 0x0, + + SHORTPAIR(hostlen), + SHORTPAIR(hostlen), + SHORTPAIR(hostoff), + 0x0, 0x0, + + 0x0, 0x0, + 0x0, 0x0, + 0x0, 0x0, + 0x0, 0x0, + + LONGQUARTET(ntlm->flags)); + + DEBUGASSERT(size == 64); + DEBUGASSERT(size == (size_t)lmrespoff); + + /* We append the binary hashes */ + if(size < (NTLM_BUFSIZE - 0x18)) { + memcpy(&ntlmbuf[size], lmresp, 0x18); + size += 0x18; + } + + DEBUG_OUT({ + curl_mfprintf(stderr, "**** TYPE3 header lmresp="); + ntlm_print_hex(stderr, (char *)&ntlmbuf[lmrespoff], 0x18); + }); + + /* ntresplen + size should not be risking an integer overflow here */ + if(ntresplen + size > sizeof(ntlmbuf)) { + failf(data, "incoming NTLM message too big"); + result = CURLE_TOO_LARGE; + goto error; + } + DEBUGASSERT(size == (size_t)ntrespoff); + memcpy(&ntlmbuf[size], ptr_ntresp, ntresplen); + size += ntresplen; + + DEBUG_OUT({ + curl_mfprintf(stderr, "\n ntresp="); + ntlm_print_hex(stderr, (char *)&ntlmbuf[ntrespoff], ntresplen); + }); + + DEBUG_OUT({ + curl_mfprintf(stderr, "\n flags=0x%02.2x%02.2x%02.2x%02.2x 0x%08.8x ", + LONGQUARTET(ntlm->flags), ntlm->flags); + ntlm_print_flags(stderr, ntlm->flags); + curl_mfprintf(stderr, "\n****\n"); + }); + + /* Make sure that the domain, user and host strings fit in the + buffer before we copy them there. */ + if(size + userlen + domlen + hostlen >= NTLM_BUFSIZE) { + failf(data, "user + domain + hostname too big for NTLM"); + result = CURLE_TOO_LARGE; + goto error; + } + + DEBUGASSERT(size == domoff); + if(unicode) + unicodecpy(&ntlmbuf[size], domain, domlen / 2); + else + memcpy(&ntlmbuf[size], domain, domlen); + + size += domlen; + + DEBUGASSERT(size == useroff); + if(unicode) + unicodecpy(&ntlmbuf[size], user, userlen / 2); + else + memcpy(&ntlmbuf[size], user, userlen); + + size += userlen; + + DEBUGASSERT(size == hostoff); + if(unicode) + unicodecpy(&ntlmbuf[size], host, hostlen / 2); + else + memcpy(&ntlmbuf[size], host, hostlen); + + size += hostlen; + + /* Return the binary blob. */ + result = Curl_bufref_memdup0(out, ntlmbuf, size); + +error: + curlx_free(ntlmv2resp); /* Free the dynamic buffer allocated for NTLMv2 */ + + Curl_auth_cleanup_ntlm(ntlm); + + return result; +} + +/* + * Curl_auth_cleanup_ntlm() + * + * This is used to clean up the NTLM specific data. + * + * Parameters: + * + * ntlm [in/out] - The NTLM data struct being cleaned up. + * + */ +void Curl_auth_cleanup_ntlm(struct ntlmdata *ntlm) +{ + /* Free the target info */ + curlx_safefree(ntlm->target_info); + + /* Reset any variables */ + ntlm->target_info_len = 0; +} + +#endif /* USE_NTLM && !USE_WINDOWS_SSPI */ diff --git a/3rdparty/curl-8.21.0/lib/vauth/ntlm_sspi.c b/3rdparty/curl-8.21.0/lib/vauth/ntlm_sspi.c new file mode 100644 index 0000000000..2e98e86e5f --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vauth/ntlm_sspi.c @@ -0,0 +1,353 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if defined(USE_WINDOWS_SSPI) && defined(USE_NTLM) + +#include "vauth/vauth.h" +#include "curl_ntlm_core.h" +#include "curl_trc.h" +#include "curlx/strdup.h" + +/* + * Curl_auth_is_ntlm_supported() + * + * This is used to evaluate if NTLM is supported. + * + * Parameters: None + * + * Returns TRUE if NTLM is supported by Windows SSPI. + */ +bool Curl_auth_is_ntlm_supported(void) +{ + PSecPkgInfo SecurityPackage; + SECURITY_STATUS status; + + /* Query the security package for NTLM */ + status = Curl_pSecFn->QuerySecurityPackageInfo( + (TCHAR *)CURL_UNCONST(TEXT(SP_NAME_NTLM)), + &SecurityPackage); + + /* Release the package buffer as it is not required anymore */ + if(status == SEC_E_OK) { + Curl_pSecFn->FreeContextBuffer(SecurityPackage); + } + + return status == SEC_E_OK; +} + +/* + * Curl_auth_create_ntlm_type1_message() + * + * This is used to generate an already encoded NTLM type-1 message ready for + * sending to the recipient. + * + * Parameters: + * + * data [in] - The session handle. + * userp [in] - The username in the format User or Domain\User. + * passwdp [in] - The user's password. + * service [in] - The service type such as http, smtp, pop or imap. + * host [in] - The hostname. + * ntlm [in/out] - The NTLM data struct being used and modified. + * out [out] - The result storage. + * + * Returns CURLE_OK on success. + */ +CURLcode Curl_auth_create_ntlm_type1_message(struct Curl_easy *data, + struct Curl_creds *creds, + const char *default_service, + const char *host, + struct ntlmdata *ntlm, + struct bufref *out) +{ + PSecPkgInfo SecurityPackage; + SecBuffer type_1_buf; + SecBufferDesc type_1_desc; + SECURITY_STATUS status; + unsigned long attrs; + const char *service = Curl_creds_has_sasl_service(creds) ? + Curl_creds_sasl_service(creds) : default_service; + + /* Clean up any former leftovers and initialize to defaults */ + Curl_auth_cleanup_ntlm(ntlm); + + /* Query the security package for NTLM */ + status = Curl_pSecFn->QuerySecurityPackageInfo( + (TCHAR *)CURL_UNCONST(TEXT(SP_NAME_NTLM)), + &SecurityPackage); + if(status != SEC_E_OK) { + failf(data, "SSPI: could not get auth info"); + return CURLE_AUTH_ERROR; + } + + ntlm->token_max = SecurityPackage->cbMaxToken; + + /* Release the package buffer as it is not required anymore */ + Curl_pSecFn->FreeContextBuffer(SecurityPackage); + + /* Allocate our output buffer */ + ntlm->output_token = curlx_malloc(ntlm->token_max); + if(!ntlm->output_token) + return CURLE_OUT_OF_MEMORY; + + if(Curl_creds_has_user(creds)) { + CURLcode result; + + /* Populate our identity structure */ + result = Curl_create_sspi_identity( + creds->user, creds->passwd, &ntlm->identity); + if(result) + return result; + + /* Allow proper cleanup of the identity structure */ + ntlm->p_identity = &ntlm->identity; + } + else + /* Use the current Windows user */ + ntlm->p_identity = NULL; + + /* Allocate our credentials handle */ + ntlm->credentials = curlx_calloc(1, sizeof(CredHandle)); + if(!ntlm->credentials) + return CURLE_OUT_OF_MEMORY; + + /* Acquire our credentials handle */ + status = Curl_pSecFn->AcquireCredentialsHandle(NULL, + (TCHAR *)CURL_UNCONST(TEXT(SP_NAME_NTLM)), + SECPKG_CRED_OUTBOUND, NULL, + ntlm->p_identity, NULL, NULL, + ntlm->credentials, NULL); + if(status != SEC_E_OK) { + curlx_safefree(ntlm->credentials); + return CURLE_LOGIN_DENIED; + } + + /* Allocate our new context handle */ + ntlm->context = curlx_calloc(1, sizeof(CtxtHandle)); + if(!ntlm->context) + return CURLE_OUT_OF_MEMORY; + + ntlm->spn = Curl_auth_build_spn(service, host, NULL); + if(!ntlm->spn) + return CURLE_OUT_OF_MEMORY; + + /* Setup the type-1 "output" security buffer */ + type_1_desc.ulVersion = SECBUFFER_VERSION; + type_1_desc.cBuffers = 1; + type_1_desc.pBuffers = &type_1_buf; + type_1_buf.BufferType = SECBUFFER_TOKEN; + type_1_buf.pvBuffer = ntlm->output_token; + type_1_buf.cbBuffer = curlx_uztoul(ntlm->token_max); + + /* Generate our type-1 message */ + status = Curl_pSecFn->InitializeSecurityContext(ntlm->credentials, NULL, + ntlm->spn, + 0, 0, SECURITY_NETWORK_DREP, + NULL, 0, + ntlm->context, &type_1_desc, + &attrs, NULL); + if(status == SEC_I_COMPLETE_NEEDED || + status == SEC_I_COMPLETE_AND_CONTINUE) + Curl_pSecFn->CompleteAuthToken(ntlm->context, &type_1_desc); + else if(status == SEC_E_INSUFFICIENT_MEMORY) + return CURLE_OUT_OF_MEMORY; + else if(status != SEC_E_OK && status != SEC_I_CONTINUE_NEEDED) + return CURLE_AUTH_ERROR; + + /* Return the response. */ + Curl_bufref_set(out, ntlm->output_token, type_1_buf.cbBuffer, NULL); + return CURLE_OK; +} + +/* + * Curl_auth_decode_ntlm_type2_message() + * + * This is used to decode an already encoded NTLM type-2 message. + * + * Parameters: + * + * data [in] - The session handle. + * type2 [in] - The type-2 message. + * ntlm [in/out] - The NTLM data struct being used and modified. + * + * Returns CURLE_OK on success. + */ +CURLcode Curl_auth_decode_ntlm_type2_message(struct Curl_easy *data, + const struct bufref *type2ref, + struct ntlmdata *ntlm) +{ + /* Ensure we have a valid type-2 message */ + if(!Curl_bufref_len(type2ref)) { + infof(data, "NTLM handshake failure (empty type-2 message)"); + return CURLE_BAD_CONTENT_ENCODING; + } + + /* Store the challenge for later use */ + ntlm->input_token = curlx_memdup0(Curl_bufref_ptr(type2ref), + Curl_bufref_len(type2ref)); + if(!ntlm->input_token) + return CURLE_OUT_OF_MEMORY; + ntlm->input_token_len = Curl_bufref_len(type2ref); + + return CURLE_OK; +} + +/* + * Curl_auth_create_ntlm_type3_message() + * + * This is used to generate an already encoded NTLM type-3 message ready for + * sending to the recipient. + * + * Parameters: + * + * data [in] - The session handle. + * userp [in] - The username in the format User or Domain\User. + * passwdp [in] - The user's password. + * ntlm [in/out] - The NTLM data struct being used and modified. + * out [out] - The result storage. + * + * Returns CURLE_OK on success. + */ +CURLcode Curl_auth_create_ntlm_type3_message(struct Curl_easy *data, + struct Curl_creds *creds, + struct ntlmdata *ntlm, + struct bufref *out) +{ + CURLcode result = CURLE_OK; + SecBuffer type_2_bufs[2]; + SecBuffer type_3_buf; + SecBufferDesc type_2_desc; + SecBufferDesc type_3_desc; + SECURITY_STATUS status; + unsigned long attrs; + + (void)creds; + + /* Setup the type-2 "input" security buffer */ + type_2_desc.ulVersion = SECBUFFER_VERSION; + type_2_desc.cBuffers = 1; + type_2_desc.pBuffers = &type_2_bufs[0]; + type_2_bufs[0].BufferType = SECBUFFER_TOKEN; + type_2_bufs[0].pvBuffer = ntlm->input_token; + type_2_bufs[0].cbBuffer = curlx_uztoul(ntlm->input_token_len); + +#ifdef SECPKG_ATTR_ENDPOINT_BINDINGS + /* SSL context comes from schannel. + * When extended protection is used in IIS server, + * we have to pass a second SecBuffer to the SecBufferDesc + * otherwise IIS does not pass the authentication (401 response). + * Minimum supported version is Windows 7. + * https://learn.microsoft.com/security-updates/SecurityAdvisories/2009/973811 + */ + if(ntlm->sslContext) { + SEC_CHANNEL_BINDINGS channelBindings; + SecPkgContext_Bindings pkgBindings; + pkgBindings.Bindings = &channelBindings; + status = Curl_pSecFn->QueryContextAttributes( + ntlm->sslContext, + SECPKG_ATTR_ENDPOINT_BINDINGS, + &pkgBindings + ); + if(status == SEC_E_OK) { + type_2_desc.cBuffers++; + type_2_bufs[1].BufferType = SECBUFFER_CHANNEL_BINDINGS; + type_2_bufs[1].cbBuffer = pkgBindings.BindingsLength; + type_2_bufs[1].pvBuffer = pkgBindings.Bindings; + } + } +#endif + + /* Setup the type-3 "output" security buffer */ + type_3_desc.ulVersion = SECBUFFER_VERSION; + type_3_desc.cBuffers = 1; + type_3_desc.pBuffers = &type_3_buf; + type_3_buf.BufferType = SECBUFFER_TOKEN; + type_3_buf.pvBuffer = ntlm->output_token; + type_3_buf.cbBuffer = curlx_uztoul(ntlm->token_max); + + /* Generate our type-3 message */ + status = Curl_pSecFn->InitializeSecurityContext(ntlm->credentials, + ntlm->context, + ntlm->spn, + 0, 0, SECURITY_NETWORK_DREP, + &type_2_desc, + 0, ntlm->context, + &type_3_desc, + &attrs, NULL); + if(status != SEC_E_OK) { + infof(data, "NTLM handshake failure (type-3 message): Status=0x%08lx", + (unsigned long)status); + + if(status == SEC_E_INSUFFICIENT_MEMORY) + return CURLE_OUT_OF_MEMORY; + + return CURLE_AUTH_ERROR; + } + + /* Return the response. */ + result = Curl_bufref_memdup0(out, ntlm->output_token, type_3_buf.cbBuffer); + Curl_auth_cleanup_ntlm(ntlm); + return result; +} + +/* + * Curl_auth_cleanup_ntlm() + * + * This is used to clean up the NTLM specific data. + * + * Parameters: + * + * ntlm [in/out] - The NTLM data struct being cleaned up. + * + */ +void Curl_auth_cleanup_ntlm(struct ntlmdata *ntlm) +{ + /* Free our security context */ + if(ntlm->context) { + Curl_pSecFn->DeleteSecurityContext(ntlm->context); + curlx_safefree(ntlm->context); + } + + /* Free our credentials handle */ + if(ntlm->credentials) { + Curl_pSecFn->FreeCredentialsHandle(ntlm->credentials); + curlx_safefree(ntlm->credentials); + } + + /* Free our identity */ + Curl_sspi_free_identity(ntlm->p_identity); + ntlm->p_identity = NULL; + + /* Free the input and output tokens */ + curlx_safefree(ntlm->input_token); + curlx_safefree(ntlm->output_token); + + /* Reset any variables */ + ntlm->token_max = 0; + + curlx_safefree(ntlm->spn); +} + +#endif /* USE_WINDOWS_SSPI && USE_NTLM */ diff --git a/3rdparty/curl-8.21.0/lib/vauth/oauth2.c b/3rdparty/curl-8.21.0/lib/vauth/oauth2.c new file mode 100644 index 0000000000..f597114638 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vauth/oauth2.c @@ -0,0 +1,100 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + * RFC6749 OAuth 2.0 Authorization Framework + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_IMAP) || !defined(CURL_DISABLE_SMTP) || \ + !defined(CURL_DISABLE_POP3) || \ + (!defined(CURL_DISABLE_LDAP) && defined(USE_OPENLDAP)) + +#include "vauth/vauth.h" + +/* + * Curl_auth_create_oauth_bearer_message() + * + * This is used to generate an OAuth 2.0 message ready for sending to the + * recipient. + * + * Parameters: + * + * user[in] - The username. + * host[in] - The hostname. + * port[in] - The port(when not Port 80). + * bearer[in] - The bearer token. + * out[out] - The result storage. + * + * Returns CURLE_OK on success. + */ +CURLcode Curl_auth_create_oauth_bearer_message(struct Curl_creds *creds, + const char *host, + const long port, + struct bufref *out) +{ + char *oauth; + + /* Generate the message */ + if(port == 0 || port == 80) + oauth = curl_maprintf("n,a=%s,\1host=%s\1auth=Bearer %s\1\1", + Curl_creds_user(creds), host, + Curl_creds_oauth_bearer(creds)); + else + oauth = curl_maprintf("n,a=%s,\1host=%s\1port=%ld\1auth=Bearer %s\1\1", + Curl_creds_user(creds), host, port, + Curl_creds_oauth_bearer(creds)); + if(!oauth) + return CURLE_OUT_OF_MEMORY; + + Curl_bufref_set(out, oauth, strlen(oauth), curl_free); + return CURLE_OK; +} + +/* + * Curl_auth_create_xoauth_bearer_message() + * + * This is used to generate a XOAuth 2.0 message ready for * sending to the + * recipient. + * + * Parameters: + * + * user[in] - The username. + * bearer[in] - The bearer token. + * out[out] - The result storage. + * + * Returns CURLE_OK on success. + */ +CURLcode Curl_auth_create_xoauth_bearer_message(struct Curl_creds *creds, + struct bufref *out) +{ + /* Generate the message */ + char *xoauth = curl_maprintf("user=%s\1auth=Bearer %s\1\1", + Curl_creds_user(creds), + Curl_creds_oauth_bearer(creds)); + if(!xoauth) + return CURLE_OUT_OF_MEMORY; + + Curl_bufref_set(out, xoauth, strlen(xoauth), curl_free); + return CURLE_OK; +} +#endif /* disabled, no users */ diff --git a/3rdparty/curl-8.21.0/lib/vauth/spnego_gssapi.c b/3rdparty/curl-8.21.0/lib/vauth/spnego_gssapi.c new file mode 100644 index 0000000000..869a27fdc9 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vauth/spnego_gssapi.c @@ -0,0 +1,295 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + * RFC4178 Simple and Protected GSS-API Negotiation Mechanism + * + ***************************************************************************/ +#include "curl_setup.h" + +#if defined(HAVE_GSSAPI) && defined(USE_SPNEGO) + +#include "vauth/vauth.h" +#include "curlx/base64.h" +#include "curl_gssapi.h" +#include "curl_trc.h" + +#if defined(CURL_HAVE_DIAG) && defined(__APPLE__) +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Wdeprecated-declarations" +#endif + +/* + * Curl_auth_is_spnego_supported() + * + * This is used to evaluate if SPNEGO (Negotiate) is supported. + * + * Parameters: None + * + * Returns TRUE if Negotiate supported by the GSS-API library. + */ +bool Curl_auth_is_spnego_supported(void) +{ + return TRUE; +} + +/* + * Curl_auth_decode_spnego_message() + * + * This is used to decode an already encoded SPNEGO (Negotiate) challenge + * message. + * + * Parameters: + * + * data [in] - The session handle. + * userp [in] - The username in the format User or Domain\User. + * passwdp [in] - The user's password. + * service [in] - The service type such as http, smtp, pop or imap. + * host [in] - The hostname. + * chlg64 [in] - The optional base64 encoded challenge message. + * nego [in/out] - The Negotiate data struct being used and modified. + * + * Returns CURLE_OK on success. + */ +CURLcode Curl_auth_decode_spnego_message(struct Curl_easy *data, + struct Curl_creds *creds, + const char *default_service, + const char *host, + const char *chlg64, + struct negotiatedata *nego) +{ + CURLcode result = CURLE_OK; + size_t chlglen = 0; + unsigned char *chlg = NULL; + OM_uint32 major_status; + OM_uint32 minor_status; + OM_uint32 unused_status; + gss_buffer_desc input_token = GSS_C_EMPTY_BUFFER; + gss_buffer_desc output_token = GSS_C_EMPTY_BUFFER; + gss_channel_bindings_t chan_bindings = GSS_C_NO_CHANNEL_BINDINGS; +#ifdef GSS_C_CHANNEL_BOUND_FLAG + struct gss_channel_bindings_struct chan; +#endif + + (void)creds; + + if(nego->context && nego->status == GSS_S_COMPLETE) { + /* We finished successfully our part of authentication, but server + * rejected it (since we are again here). Exit with an error since we + * cannot invent anything better */ + Curl_auth_cleanup_spnego(nego); + return CURLE_LOGIN_DENIED; + } + + if(!nego->spn) { + gss_buffer_desc spn_token = GSS_C_EMPTY_BUFFER; + + /* Generate our SPN */ + const char *service = Curl_creds_has_sasl_service(creds) ? + Curl_creds_sasl_service(creds) : default_service; + char *spn = Curl_auth_build_spn(service, NULL, host); + if(!spn) + return CURLE_OUT_OF_MEMORY; + + /* Populate the SPN structure */ + spn_token.value = spn; + spn_token.length = strlen(spn); + + /* Import the SPN */ + major_status = gss_import_name(&minor_status, &spn_token, + GSS_C_NT_HOSTBASED_SERVICE, + &nego->spn); + if(GSS_ERROR(major_status)) { + Curl_gss_log_error(data, "gss_import_name() failed: ", + major_status, minor_status); + + curlx_free(spn); + + return CURLE_AUTH_ERROR; + } + + curlx_free(spn); + } + + if(chlg64 && *chlg64) { + /* Decode the base-64 encoded challenge message */ + if(*chlg64 != '=') { + result = curlx_base64_decode(chlg64, &chlg, &chlglen); + if(result) + return result; + } + + /* Ensure we have a valid challenge message */ + if(!chlg) { + infof(data, "SPNEGO handshake failure (empty challenge message)"); + return CURLE_BAD_CONTENT_ENCODING; + } + + /* Setup the challenge "input" security buffer */ + input_token.value = chlg; + input_token.length = chlglen; + } + + /* Set channel binding data if available */ +#ifdef GSS_C_CHANNEL_BOUND_FLAG + if(curlx_dyn_len(&nego->channel_binding_data)) { + memset(&chan, 0, sizeof(struct gss_channel_bindings_struct)); + chan.application_data.length = curlx_dyn_len(&nego->channel_binding_data); + chan.application_data.value = curlx_dyn_ptr(&nego->channel_binding_data); + chan_bindings = &chan; + } +#endif + + /* Generate our challenge-response message */ + major_status = Curl_gss_init_sec_context(data, + &minor_status, + &nego->context, + nego->spn, + &Curl_spnego_mech_oid, + chan_bindings, + &input_token, + &output_token, + TRUE, + NULL); + + /* Free the decoded challenge as it is not required anymore */ + curlx_safefree(input_token.value); + + nego->status = major_status; + if(GSS_ERROR(major_status)) { + if(output_token.value) + gss_release_buffer(&unused_status, &output_token); + + Curl_gss_log_error(data, "gss_init_sec_context() failed: ", + major_status, minor_status); + + return CURLE_AUTH_ERROR; + } + + if(!output_token.value || !output_token.length) { + if(output_token.value) + gss_release_buffer(&unused_status, &output_token); + + return CURLE_AUTH_ERROR; + } + + /* Free previous token */ + if(nego->output_token.length && nego->output_token.value) + gss_release_buffer(&unused_status, &nego->output_token); + + nego->output_token = output_token; + + return CURLE_OK; +} + +/* + * Curl_auth_create_spnego_message() + * + * This is used to generate an already encoded SPNEGO (Negotiate) response + * message ready for sending to the recipient. + * + * Parameters: + * + * data [in] - The session handle. + * nego [in/out] - The Negotiate data struct being used and modified. + * outptr [in/out] - The address where a pointer to newly allocated memory + * holding the result is stored upon completion. + * outlen [out] - The length of the output message. + * + * Returns CURLE_OK on success. + */ +CURLcode Curl_auth_create_spnego_message(struct negotiatedata *nego, + char **outptr, size_t *outlen) +{ + CURLcode result; + OM_uint32 minor_status; + + /* Base64 encode the already generated response */ + result = curlx_base64_encode(nego->output_token.value, + nego->output_token.length, + outptr, outlen); + + if(result) { + gss_release_buffer(&minor_status, &nego->output_token); + nego->output_token.value = NULL; + nego->output_token.length = 0; + + return result; + } + + if(!*outptr || !*outlen) { + gss_release_buffer(&minor_status, &nego->output_token); + nego->output_token.value = NULL; + nego->output_token.length = 0; + + return CURLE_REMOTE_ACCESS_DENIED; + } + + return CURLE_OK; +} + +/* + * Curl_auth_cleanup_spnego() + * + * This is used to clean up the SPNEGO (Negotiate) specific data. + * + * Parameters: + * + * nego [in/out] - The Negotiate data struct being cleaned up. + * + */ +void Curl_auth_cleanup_spnego(struct negotiatedata *nego) +{ + OM_uint32 minor_status; + + /* Free our security context */ + if(nego->context != GSS_C_NO_CONTEXT) { + Curl_gss_delete_sec_context(&minor_status, &nego->context, + GSS_C_NO_BUFFER); + nego->context = GSS_C_NO_CONTEXT; + } + + /* Free the output token */ + if(nego->output_token.value) { + gss_release_buffer(&minor_status, &nego->output_token); + nego->output_token.value = NULL; + nego->output_token.length = 0; + } + + /* Free the SPN */ + if(nego->spn != GSS_C_NO_NAME) { + gss_release_name(&minor_status, &nego->spn); + nego->spn = GSS_C_NO_NAME; + } + + /* Reset any variables */ + nego->status = 0; + nego->noauthpersist = FALSE; + nego->havenoauthpersist = FALSE; + nego->havenegdata = FALSE; + nego->havemultiplerequests = FALSE; +} + +#if defined(CURL_HAVE_DIAG) && defined(__APPLE__) +#pragma GCC diagnostic pop +#endif + +#endif /* HAVE_GSSAPI && USE_SPNEGO */ diff --git a/3rdparty/curl-8.21.0/lib/vauth/spnego_sspi.c b/3rdparty/curl-8.21.0/lib/vauth/spnego_sspi.c new file mode 100644 index 0000000000..b7d82c04dd --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vauth/spnego_sspi.c @@ -0,0 +1,351 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + * RFC4178 Simple and Protected GSS-API Negotiation Mechanism + * + ***************************************************************************/ +#include "curl_setup.h" + +#if defined(USE_WINDOWS_SSPI) && defined(USE_SPNEGO) + +#include "vauth/vauth.h" +#include "curlx/base64.h" +#include "curl_trc.h" +#include "strerror.h" + +/* + * Curl_auth_is_spnego_supported() + * + * This is used to evaluate if SPNEGO (Negotiate) is supported. + * + * Parameters: None + * + * Returns TRUE if Negotiate is supported by Windows SSPI. + */ +bool Curl_auth_is_spnego_supported(void) +{ + PSecPkgInfo SecurityPackage; + SECURITY_STATUS status; + + /* Query the security package for Negotiate */ + status = Curl_pSecFn->QuerySecurityPackageInfo( + (TCHAR *)CURL_UNCONST(TEXT(SP_NAME_NEGOTIATE)), + &SecurityPackage); + + /* Release the package buffer as it is not required anymore */ + if(status == SEC_E_OK) { + Curl_pSecFn->FreeContextBuffer(SecurityPackage); + } + + return status == SEC_E_OK; +} + +/* + * Curl_auth_decode_spnego_message() + * + * This is used to decode an already encoded SPNEGO (Negotiate) challenge + * message. + * + * Parameters: + * + * data [in] - The session handle. + * user [in] - The username in the format User or Domain\User. + * password [in] - The user's password. + * service [in] - The service type such as http, smtp, pop or imap. + * host [in] - The hostname. + * chlg64 [in] - The optional base64 encoded challenge message. + * nego [in/out] - The Negotiate data struct being used and modified. + * + * Returns CURLE_OK on success. + */ +CURLcode Curl_auth_decode_spnego_message(struct Curl_easy *data, + struct Curl_creds *creds, + const char *default_service, + const char *host, + const char *chlg64, + struct negotiatedata *nego) +{ + CURLcode result = CURLE_OK; + size_t chlglen = 0; + unsigned char *chlg = NULL; + PSecPkgInfo SecurityPackage; + SecBuffer chlg_buf[2]; + SecBuffer resp_buf; + SecBufferDesc chlg_desc; + SecBufferDesc resp_desc; + unsigned long attrs; + + if(nego->context && nego->status == SEC_E_OK) { + /* We finished successfully our part of authentication, but server + * rejected it (since we are again here). Exit with an error since we + * cannot invent anything better */ + Curl_auth_cleanup_spnego(nego); + return CURLE_LOGIN_DENIED; + } + + if(!nego->spn) { + /* Generate our SPN */ + const char *service = Curl_creds_has_sasl_service(creds) ? + Curl_creds_sasl_service(creds) : default_service; + nego->spn = Curl_auth_build_spn(service, host, NULL); + if(!nego->spn) + return CURLE_OUT_OF_MEMORY; + } + + if(!nego->output_token) { + /* Query the security package for Negotiate */ + nego->status = Curl_pSecFn->QuerySecurityPackageInfo( + (TCHAR *)CURL_UNCONST(TEXT(SP_NAME_NEGOTIATE)), + &SecurityPackage); + if(nego->status != SEC_E_OK) { + failf(data, "SSPI: could not get auth info"); + return CURLE_AUTH_ERROR; + } + + nego->token_max = SecurityPackage->cbMaxToken; + + /* Release the package buffer as it is not required anymore */ + Curl_pSecFn->FreeContextBuffer(SecurityPackage); + + /* Allocate our output buffer */ + nego->output_token = curlx_malloc(nego->token_max); + if(!nego->output_token) + return CURLE_OUT_OF_MEMORY; + } + + if(!nego->credentials) { + /* Do we have credentials to use or are we using single sign-on? */ + if(Curl_creds_has_user(creds)) { + /* Populate our identity structure */ + result = Curl_create_sspi_identity(creds->user, creds->passwd, + &nego->identity); + if(result) + return result; + + /* Allow proper cleanup of the identity structure */ + nego->p_identity = &nego->identity; + } + else + /* Use the current Windows user */ + nego->p_identity = NULL; + + /* Allocate our credentials handle */ + nego->credentials = curlx_calloc(1, sizeof(CredHandle)); + if(!nego->credentials) + return CURLE_OUT_OF_MEMORY; + + /* Acquire our credentials handle */ + nego->status = Curl_pSecFn->AcquireCredentialsHandle(NULL, + (TCHAR *)CURL_UNCONST(TEXT(SP_NAME_NEGOTIATE)), + SECPKG_CRED_OUTBOUND, NULL, + nego->p_identity, NULL, NULL, + nego->credentials, NULL); + if(nego->status != SEC_E_OK) { + curlx_safefree(nego->credentials); + return CURLE_AUTH_ERROR; + } + + /* Allocate our new context handle */ + nego->context = curlx_calloc(1, sizeof(CtxtHandle)); + if(!nego->context) + return CURLE_OUT_OF_MEMORY; + } + + if(chlg64 && *chlg64) { + /* Decode the base-64 encoded challenge message */ + if(*chlg64 != '=') { + result = curlx_base64_decode(chlg64, &chlg, &chlglen); + if(result) + return result; + } + + /* Ensure we have a valid challenge message */ + if(!chlg) { + infof(data, "SPNEGO handshake failure (empty challenge message)"); + return CURLE_BAD_CONTENT_ENCODING; + } + + /* Setup the challenge "input" security buffer */ + chlg_desc.ulVersion = SECBUFFER_VERSION; + chlg_desc.cBuffers = 1; + chlg_desc.pBuffers = &chlg_buf[0]; + chlg_buf[0].BufferType = SECBUFFER_TOKEN; + chlg_buf[0].pvBuffer = chlg; + chlg_buf[0].cbBuffer = curlx_uztoul(chlglen); + +#ifdef SECPKG_ATTR_ENDPOINT_BINDINGS + /* SSL context comes from Schannel. + * When extended protection is used in IIS server, + * we have to pass a second SecBuffer to the SecBufferDesc + * otherwise IIS does not pass the authentication (401 response). + * Minimum supported version is Windows 7. + * https://learn.microsoft.com/security-updates/SecurityAdvisories/2009/973811 + */ + if(nego->sslContext) { + SEC_CHANNEL_BINDINGS channelBindings; + SecPkgContext_Bindings pkgBindings; + pkgBindings.Bindings = &channelBindings; + nego->status = Curl_pSecFn->QueryContextAttributes( + nego->sslContext, + SECPKG_ATTR_ENDPOINT_BINDINGS, + &pkgBindings); + if(nego->status == SEC_E_OK) { + chlg_desc.cBuffers++; + chlg_buf[1].BufferType = SECBUFFER_CHANNEL_BINDINGS; + chlg_buf[1].cbBuffer = pkgBindings.BindingsLength; + chlg_buf[1].pvBuffer = pkgBindings.Bindings; + } + } +#endif + } + + /* Setup the response "output" security buffer */ + resp_desc.ulVersion = SECBUFFER_VERSION; + resp_desc.cBuffers = 1; + resp_desc.pBuffers = &resp_buf; + resp_buf.BufferType = SECBUFFER_TOKEN; + resp_buf.pvBuffer = nego->output_token; + resp_buf.cbBuffer = curlx_uztoul(nego->token_max); + + /* Generate our challenge-response message */ + { + DWORD sspi_flags = ISC_REQ_CONFIDENTIALITY; + if(data->set.gssapi_delegation & CURLGSSAPI_DELEGATION_FLAG) + sspi_flags |= ISC_REQ_DELEGATE | ISC_REQ_MUTUAL_AUTH; + nego->status = + Curl_pSecFn->InitializeSecurityContext(nego->credentials, + chlg ? nego->context : NULL, + nego->spn, + sspi_flags, + 0, SECURITY_NATIVE_DREP, + chlg ? &chlg_desc : NULL, + 0, nego->context, + &resp_desc, &attrs, NULL); + } + + /* Free the decoded challenge as it is not required anymore */ + curlx_free(chlg); + + if(GSS_ERROR(nego->status)) { + char buffer[STRERROR_LEN]; + failf(data, "InitializeSecurityContext failed: %s", + Curl_sspi_strerror(nego->status, buffer, sizeof(buffer))); + + if(nego->status == SEC_E_INSUFFICIENT_MEMORY) + return CURLE_OUT_OF_MEMORY; + + return CURLE_AUTH_ERROR; + } + + if(nego->status == SEC_I_COMPLETE_NEEDED || + nego->status == SEC_I_COMPLETE_AND_CONTINUE) { + nego->status = Curl_pSecFn->CompleteAuthToken(nego->context, &resp_desc); + if(GSS_ERROR(nego->status)) { + char buffer[STRERROR_LEN]; + failf(data, "CompleteAuthToken failed: %s", + Curl_sspi_strerror(nego->status, buffer, sizeof(buffer))); + + if(nego->status == SEC_E_INSUFFICIENT_MEMORY) + return CURLE_OUT_OF_MEMORY; + + return CURLE_AUTH_ERROR; + } + } + + nego->output_token_length = resp_buf.cbBuffer; + + return result; +} + +/* + * Curl_auth_create_spnego_message() + * + * This is used to generate an already encoded SPNEGO (Negotiate) response + * message ready for sending to the recipient. + * + * Parameters: + * + * data [in] - The session handle. + * nego [in/out] - The Negotiate data struct being used and modified. + * outptr [in/out] - The address where a pointer to newly allocated memory + * holding the result is stored upon completion. + * outlen [out] - The length of the output message. + * + * Returns CURLE_OK on success. + */ +CURLcode Curl_auth_create_spnego_message(struct negotiatedata *nego, + char **outptr, size_t *outlen) +{ + /* Base64 encode the already generated response */ + CURLcode result = curlx_base64_encode(nego->output_token, + nego->output_token_length, outptr, + outlen); + if(!result && (!*outptr || !*outlen)) { + curlx_free(*outptr); + result = CURLE_REMOTE_ACCESS_DENIED; + } + + return result; +} + +/* + * Curl_auth_cleanup_spnego() + * + * This is used to clean up the SPNEGO (Negotiate) specific data. + * + * Parameters: + * + * nego [in/out] - The Negotiate data struct being cleaned up. + * + */ +void Curl_auth_cleanup_spnego(struct negotiatedata *nego) +{ + /* Free our security context */ + if(nego->context) { + Curl_pSecFn->DeleteSecurityContext(nego->context); + curlx_safefree(nego->context); + } + + /* Free our credentials handle */ + if(nego->credentials) { + Curl_pSecFn->FreeCredentialsHandle(nego->credentials); + curlx_safefree(nego->credentials); + } + + /* Free our identity */ + Curl_sspi_free_identity(nego->p_identity); + nego->p_identity = NULL; + + /* Free the SPN and output token */ + curlx_safefree(nego->spn); + curlx_safefree(nego->output_token); + + /* Reset any variables */ + nego->status = 0; + nego->token_max = 0; + nego->noauthpersist = FALSE; + nego->havenoauthpersist = FALSE; + nego->havenegdata = FALSE; + nego->havemultiplerequests = FALSE; +} + +#endif /* USE_WINDOWS_SSPI && USE_SPNEGO */ diff --git a/3rdparty/curl-8.21.0/lib/vauth/vauth.c b/3rdparty/curl-8.21.0/lib/vauth/vauth.c new file mode 100644 index 0000000000..3259556e5f --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vauth/vauth.c @@ -0,0 +1,252 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Steve Holme, . + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "vauth/vauth.h" +#include "creds.h" +#include "curlx/multibyte.h" +#include "url.h" + +/* + * Curl_auth_build_spn() + * + * This is used to build an SPN string in the following formats: + * + * service/host@realm (Not currently used) + * service/host (Not used by GSS-API) + * service@realm (Not used by Windows SSPI) + * + * Parameters: + * + * service [in] - The service type such as http, smtp, pop or imap. + * host [in] - The hostname. + * realm [in] - The realm. + * + * Returns a pointer to the newly allocated SPN. + */ +#ifndef USE_WINDOWS_SSPI +char *Curl_auth_build_spn(const char *service, const char *host, + const char *realm) +{ + char *spn = NULL; + + /* Generate our SPN */ + if(host && realm) + spn = curl_maprintf("%s/%s@%s", service, host, realm); + else if(host) + spn = curl_maprintf("%s/%s", service, host); + else if(realm) + spn = curl_maprintf("%s@%s", service, realm); + + /* Return our newly allocated SPN */ + return spn; +} +#else +TCHAR *Curl_auth_build_spn(const char *service, const char *host, + const char *realm) +{ + char *utf8_spn = NULL; + TCHAR *tchar_spn = NULL; + + (void)realm; + + /* Note: We could use DsMakeSPN() or DsClientMakeSpnForTargetServer() rather + than doing this ourselves but the first is only available in Windows XP + and Windows Server 2003 and the latter is only available in Windows 2000 + but not Windows95/98/ME or Windows NT4.0 unless the Active Directory + Client Extensions are installed. As such it is far simpler for us to + formulate the SPN instead. */ + + /* Generate our UTF8 based SPN */ + utf8_spn = curl_maprintf("%s/%s", service, host); + if(!utf8_spn) + return NULL; + + /* Allocate and return a TCHAR based SPN. */ + tchar_spn = curlx_convert_UTF8_to_tchar(utf8_spn); + curlx_free(utf8_spn); + + return tchar_spn; +} +#endif /* USE_WINDOWS_SSPI */ + +/* + * Curl_auth_user_contains_domain() + * + * This is used to test if the specified user contains a Windows domain name as + * follows: + * + * Domain\User (Down-level Logon Name) + * Domain/User (curl Down-level format - for compatibility with existing code) + * User@Domain (User Principal Name) + * + * Note: The username may be empty when using a GSS-API library or Windows + * SSPI as the user and domain are either obtained from the credentials cache + * when using GSS-API or via the currently logged in user's credentials when + * using Windows SSPI. + * + * Parameters: + * + * user [in] - The username. + * + * Returns TRUE on success; otherwise FALSE. + */ +bool Curl_auth_user_contains_domain(struct Curl_creds *creds) +{ + bool valid = FALSE; + + if(Curl_creds_has_user(creds)) { + /* Check we have a domain name or UPN present */ + const char *p = strpbrk(creds->user, "\\/@"); + + valid = p && (p > creds->user) && + (p < (creds->user + strlen(creds->user) - 1)); + } +#if defined(HAVE_GSSAPI) || defined(USE_WINDOWS_SSPI) + else + /* User and domain are obtained from the GSS-API credentials cache or the + currently logged in user from Windows */ + valid = TRUE; +#endif + + return valid; +} + +/* + * Curl_auth_allowed_to_host() tells if authentication, cookies or other + * "sensitive data" can be sent to the connection's origin. + */ +bool Curl_auth_allowed_to_host(struct Curl_easy *data) +{ + return Curl_auth_allowed_to_origin(data, data->state.origin); +} + +bool Curl_auth_allowed_to_origin(struct Curl_easy *data, + struct Curl_peer *origin) +{ + return data->set.allow_auth_to_other_hosts || + Curl_peer_equal(data->state.initial_origin, origin); +} + +#ifdef USE_NTLM +static void ntlm_conn_dtor(void *key, size_t klen, void *entry) +{ + struct ntlmdata *ntlm = entry; + (void)key; + (void)klen; + DEBUGASSERT(ntlm); + Curl_auth_cleanup_ntlm(ntlm); + curlx_free(ntlm); +} + +struct ntlmdata *Curl_auth_ntlm_get(struct connectdata *conn, bool proxy) +{ + const char *key = proxy ? CURL_META_NTLM_PROXY_CONN : CURL_META_NTLM_CONN; + struct ntlmdata *ntlm = Curl_conn_meta_get(conn, key); + if(!ntlm) { + ntlm = curlx_calloc(1, sizeof(*ntlm)); + if(!ntlm || Curl_conn_meta_set(conn, key, ntlm, ntlm_conn_dtor)) + return NULL; + } + return ntlm; +} + +void Curl_auth_ntlm_remove(struct connectdata *conn, bool proxy) +{ + Curl_conn_meta_remove(conn, proxy ? CURL_META_NTLM_PROXY_CONN + : CURL_META_NTLM_CONN); +} +#endif /* USE_NTLM */ + +#ifdef USE_KERBEROS5 +static void krb5_conn_dtor(void *key, size_t klen, void *entry) +{ + struct kerberos5data *krb5 = entry; + (void)key; + (void)klen; + DEBUGASSERT(krb5); + Curl_auth_cleanup_gssapi(krb5); + curlx_free(krb5); +} + +struct kerberos5data *Curl_auth_krb5_get(struct connectdata *conn) +{ + struct kerberos5data *krb5 = Curl_conn_meta_get(conn, CURL_META_KRB5_CONN); + if(!krb5) { + krb5 = curlx_calloc(1, sizeof(*krb5)); + if(!krb5 || + Curl_conn_meta_set(conn, CURL_META_KRB5_CONN, krb5, krb5_conn_dtor)) + return NULL; + } + return krb5; +} +#endif /* USE_KERBEROS5 */ + +#ifdef USE_GSASL +static void gsasl_conn_dtor(void *key, size_t klen, void *entry) +{ + struct gsasldata *gsasl = entry; + (void)key; + (void)klen; + DEBUGASSERT(gsasl); + Curl_auth_gsasl_cleanup(gsasl); + curlx_free(gsasl); +} + +struct gsasldata *Curl_auth_gsasl_get(struct connectdata *conn) +{ + struct gsasldata *gsasl = Curl_conn_meta_get(conn, CURL_META_GSASL_CONN); + if(!gsasl) { + gsasl = curlx_calloc(1, sizeof(*gsasl)); + if(!gsasl || + Curl_conn_meta_set(conn, CURL_META_GSASL_CONN, gsasl, gsasl_conn_dtor)) + return NULL; + } + return gsasl; +} +#endif /* USE_GSASL */ + +#ifdef USE_SPNEGO +static void nego_conn_dtor(void *key, size_t klen, void *entry) +{ + struct negotiatedata *nego = entry; + (void)key; + (void)klen; + DEBUGASSERT(nego); + Curl_auth_cleanup_spnego(nego); + curlx_free(nego); +} + +struct negotiatedata *Curl_auth_nego_get(struct connectdata *conn, bool proxy) +{ + const char *key = proxy ? CURL_META_NEGO_PROXY_CONN : CURL_META_NEGO_CONN; + struct negotiatedata *nego = Curl_conn_meta_get(conn, key); + if(!nego) { + nego = curlx_calloc(1, sizeof(*nego)); + if(!nego || Curl_conn_meta_set(conn, key, nego, nego_conn_dtor)) + return NULL; + } + return nego; +} +#endif /* USE_SPNEGO */ diff --git a/3rdparty/curl-8.21.0/lib/vauth/vauth.h b/3rdparty/curl-8.21.0/lib/vauth/vauth.h new file mode 100644 index 0000000000..0f82f92945 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vauth/vauth.h @@ -0,0 +1,341 @@ +#ifndef HEADER_CURL_VAUTH_H +#define HEADER_CURL_VAUTH_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Steve Holme, . + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#include "bufref.h" +#include "curlx/dynbuf.h" +#include "urldata.h" + +struct Curl_easy; +struct Curl_creds; +struct connectdata; +struct Curl_peer; + +#ifndef CURL_DISABLE_DIGEST_AUTH +struct digestdata; +#endif + +#ifdef USE_NTLM +struct ntlmdata; +#endif + +#if (defined(HAVE_GSSAPI) || defined(USE_WINDOWS_SSPI)) && defined(USE_SPNEGO) +struct negotiatedata; +#endif + +#ifdef USE_GSASL +struct gsasldata; +#endif + +#ifdef USE_WINDOWS_SSPI +#include "curl_sspi.h" +#define GSS_ERROR(status) ((status) & 0x80000000) +#endif + +/* + * Curl_auth_allowed_to_host() tells if authentication, cookies or other + * "sensitive data" can (still) be sent to this host. + */ +bool Curl_auth_allowed_to_host(struct Curl_easy *data); +bool Curl_auth_allowed_to_origin(struct Curl_easy *data, + struct Curl_peer *origin); + +/* This is used to build an SPN string */ +#ifndef USE_WINDOWS_SSPI +char *Curl_auth_build_spn(const char *service, const char *host, + const char *realm); +#else +TCHAR *Curl_auth_build_spn(const char *service, const char *host, + const char *realm); +#endif + +/* This is used to test if the user contains a Windows domain name */ +bool Curl_auth_user_contains_domain(struct Curl_creds *creds); + +/* This is used to generate a PLAIN cleartext message */ +CURLcode Curl_auth_create_plain_message(struct Curl_creds *creds, + struct bufref *out); + +/* This is used to generate a LOGIN cleartext message */ +void Curl_auth_create_login_message(const char *value, struct bufref *out); + +/* This is used to generate an EXTERNAL cleartext message */ +void Curl_auth_create_external_message(const char *user, struct bufref *out); + +#ifndef CURL_DISABLE_DIGEST_AUTH +/* This is used to generate a CRAM-MD5 response message */ +CURLcode Curl_auth_create_cram_md5_message(const struct bufref *chlg, + struct Curl_creds *creds, + struct bufref *out); + +/* This is used to evaluate if DIGEST is supported */ +bool Curl_auth_is_digest_supported(void); + +/* This is used to generate a base64 encoded DIGEST-MD5 response message */ +CURLcode Curl_auth_create_digest_md5_message(struct Curl_easy *data, + const struct bufref *chlg, + struct Curl_creds *creds, + const char *default_service, + struct bufref *out); + +/* This is used to decode an HTTP DIGEST challenge message */ +CURLcode Curl_auth_decode_digest_http_message(const char *chlg, + struct digestdata *digest); + +/* This is used to generate an HTTP DIGEST response message */ +CURLcode Curl_auth_create_digest_http_message(struct Curl_easy *data, + struct Curl_creds *creds, + const unsigned char *request, + const unsigned char *uripath, + struct digestdata *digest, + char **outptr, size_t *outlen); + +/* This is used to clean up the digest specific data */ +void Curl_auth_digest_cleanup(struct digestdata *digest); +#else +#define Curl_auth_digest_cleanup(x) +#define Curl_auth_is_digest_supported() FALSE +#endif /* !CURL_DISABLE_DIGEST_AUTH */ + +#ifdef USE_GSASL + +/* meta key for storing GSASL meta at connection */ +#define CURL_META_GSASL_CONN "meta:auth:gsasl:conn" + +#include +struct gsasldata { + Gsasl *ctx; + Gsasl_session *client; +}; + +struct gsasldata *Curl_auth_gsasl_get(struct connectdata *conn); + +/* This is used to evaluate if MECH is supported by gsasl */ +bool Curl_auth_gsasl_is_supported(struct Curl_easy *data, + const char *mech, + struct gsasldata *gsasl); +/* This is used to start a gsasl method */ +CURLcode Curl_auth_gsasl_start(struct Curl_easy *data, + struct Curl_creds *creds, + struct gsasldata *gsasl); + +/* This is used to process and generate a new SASL token */ +CURLcode Curl_auth_gsasl_token(struct Curl_easy *data, + const struct bufref *chlg, + struct gsasldata *gsasl, + struct bufref *out); + +/* This is used to clean up the gsasl specific data */ +void Curl_auth_gsasl_cleanup(struct gsasldata *gsasl); +#endif + +#ifdef USE_NTLM + +/* meta key for storing NTML meta at connection */ +#define CURL_META_NTLM_CONN "meta:auth:ntml:conn" +/* meta key for storing NTML-PROXY meta at connection */ +#define CURL_META_NTLM_PROXY_CONN "meta:auth:ntml-proxy:conn" + +struct ntlmdata { +#ifdef USE_WINDOWS_SSPI +/* The sslContext is used for the Schannel bindings. The + * api is available on the Windows 7 SDK and later. + */ +#ifdef SECPKG_ATTR_ENDPOINT_BINDINGS + CtxtHandle *sslContext; +#endif + CredHandle *credentials; + CtxtHandle *context; + SEC_WINNT_AUTH_IDENTITY identity; + SEC_WINNT_AUTH_IDENTITY *p_identity; + size_t token_max; + BYTE *output_token; + BYTE *input_token; + size_t input_token_len; + TCHAR *spn; +#else + unsigned int flags; + unsigned char nonce[8]; + unsigned int target_info_len; + void *target_info; /* TargetInfo received in the NTLM type-2 message */ +#endif +}; + +/* This is used to evaluate if NTLM is supported */ +bool Curl_auth_is_ntlm_supported(void); + +struct ntlmdata *Curl_auth_ntlm_get(struct connectdata *conn, bool proxy); +void Curl_auth_ntlm_remove(struct connectdata *conn, bool proxy); + +/* This is used to clean up the NTLM specific data */ +void Curl_auth_cleanup_ntlm(struct ntlmdata *ntlm); + +/* This is used to generate a base64 encoded NTLM type-1 message */ +CURLcode Curl_auth_create_ntlm_type1_message(struct Curl_easy *data, + struct Curl_creds *creds, + const char *default_service, + const char *host, + struct ntlmdata *ntlm, + struct bufref *out); + +/* This is used to decode a base64 encoded NTLM type-2 message */ +CURLcode Curl_auth_decode_ntlm_type2_message(struct Curl_easy *data, + const struct bufref *type2ref, + struct ntlmdata *ntlm); + +/* This is used to generate a base64 encoded NTLM type-3 message */ +CURLcode Curl_auth_create_ntlm_type3_message(struct Curl_easy *data, + struct Curl_creds *creds, + struct ntlmdata *ntlm, + struct bufref *out); + +#else +#define Curl_auth_is_ntlm_supported() FALSE +#endif /* USE_NTLM */ + +/* This is used to generate a base64 encoded OAuth 2.0 message */ +CURLcode Curl_auth_create_oauth_bearer_message(struct Curl_creds *creds, + const char *host, + const long port, + struct bufref *out); + +/* This is used to generate a base64 encoded XOAuth 2.0 message */ +CURLcode Curl_auth_create_xoauth_bearer_message(struct Curl_creds *creds, + struct bufref *out); + +#ifdef USE_KERBEROS5 + +/* meta key for storing KRB5 meta at connection */ +#define CURL_META_KRB5_CONN "meta:auth:krb5:conn" + +struct kerberos5data { +#ifdef USE_WINDOWS_SSPI + CredHandle *credentials; + CtxtHandle *context; + TCHAR *spn; + SEC_WINNT_AUTH_IDENTITY identity; + SEC_WINNT_AUTH_IDENTITY *p_identity; + size_t token_max; + BYTE *output_token; +#else + gss_ctx_id_t context; + gss_name_t spn; +#endif +}; + +struct kerberos5data *Curl_auth_krb5_get(struct connectdata *conn); + +/* This is used to evaluate if GSSAPI (Kerberos V5) is supported */ +bool Curl_auth_is_gssapi_supported(void); + +/* This is used to generate a base64 encoded GSSAPI (Kerberos V5) user token + message */ +CURLcode Curl_auth_create_gssapi_user_message(struct Curl_easy *data, + struct Curl_creds *creds, + const char *default_service, + const char *host, + const bool mutual_auth, + const struct bufref *chlg, + struct kerberos5data *krb5, + struct bufref *out); + +/* This is used to generate a base64 encoded GSSAPI (Kerberos V5) security + token message */ +CURLcode Curl_auth_create_gssapi_security_message(struct Curl_easy *data, + const char *authzid, + const struct bufref *chlg, + struct kerberos5data *krb5, + struct bufref *out); + +/* This is used to clean up the GSSAPI specific data */ +void Curl_auth_cleanup_gssapi(struct kerberos5data *krb5); +#else +#define Curl_auth_is_gssapi_supported() FALSE +#endif /* USE_KERBEROS5 */ + +#ifdef USE_SPNEGO + +bool Curl_auth_is_spnego_supported(void); + +/* meta key for storing NEGO meta at connection */ +#define CURL_META_NEGO_CONN "meta:auth:nego:conn" +/* meta key for storing NEGO PROXY meta at connection */ +#define CURL_META_NEGO_PROXY_CONN "meta:auth:nego-proxy:conn" + +/* Struct used for Negotiate (SPNEGO) authentication */ +struct negotiatedata { +#ifdef HAVE_GSSAPI + OM_uint32 status; + gss_ctx_id_t context; + gss_name_t spn; + gss_buffer_desc output_token; +#ifdef GSS_C_CHANNEL_BOUND_FLAG + struct dynbuf channel_binding_data; +#endif +#else +#ifdef USE_WINDOWS_SSPI +#ifdef SECPKG_ATTR_ENDPOINT_BINDINGS + CtxtHandle *sslContext; +#endif + SECURITY_STATUS status; + CredHandle *credentials; + CtxtHandle *context; + SEC_WINNT_AUTH_IDENTITY identity; + SEC_WINNT_AUTH_IDENTITY *p_identity; + TCHAR *spn; + size_t token_max; + BYTE *output_token; + size_t output_token_length; +#endif +#endif + BIT(noauthpersist); + BIT(havenoauthpersist); + BIT(havenegdata); + BIT(havemultiplerequests); +}; + +struct negotiatedata *Curl_auth_nego_get(struct connectdata *conn, bool proxy); + +/* This is used to decode a base64 encoded SPNEGO (Negotiate) challenge + message */ +CURLcode Curl_auth_decode_spnego_message(struct Curl_easy *data, + struct Curl_creds *creds, + const char *default_service, + const char *host, + const char *chlg64, + struct negotiatedata *nego); + +/* This is used to generate a base64 encoded SPNEGO (Negotiate) response + message */ +CURLcode Curl_auth_create_spnego_message(struct negotiatedata *nego, + char **outptr, size_t *outlen); + +/* This is used to clean up the SPNEGO specific data */ +void Curl_auth_cleanup_spnego(struct negotiatedata *nego); + +#endif /* USE_SPNEGO */ + +#endif /* HEADER_CURL_VAUTH_H */ diff --git a/3rdparty/curl-8.21.0/lib/version.c b/3rdparty/curl-8.21.0/lib/version.c new file mode 100644 index 0000000000..299caee9fb --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/version.c @@ -0,0 +1,679 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_NGHTTP2 +#include +#endif + +#include "urldata.h" +#include "vtls/vtls.h" +#include "http2.h" +#include "vssh/ssh.h" +#include "vquic/vquic.h" +#include "easy_lock.h" + +#ifdef USE_ARES +# include +#endif + +#ifdef USE_LIBIDN2 +#include +#endif + +#ifdef USE_LIBPSL +#include +#endif + +#ifdef HAVE_LIBZ +#include +#endif + +#ifdef HAVE_BROTLI +#ifdef CURL_HAVE_DIAG +/* Ignore -Wvla warnings in brotli headers */ +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Wvla" +#endif +#include +#ifdef CURL_HAVE_DIAG +#pragma GCC diagnostic pop +#endif +#endif + +#ifdef HAVE_ZSTD +#include +#endif + +#ifdef USE_GSASL +#include +#endif + +#ifndef CURL_DISABLE_LDAP +#include "curl_ldap.h" +#endif + +#ifdef HAVE_BROTLI +static void brotli_version(char *buf, size_t bufsz) +{ + uint32_t brotli_version = BrotliDecoderVersion(); + unsigned int major = brotli_version >> 24; + unsigned int minor = (brotli_version & 0x00FFFFFF) >> 12; + unsigned int patch = brotli_version & 0x00000FFF; + (void)curl_msnprintf(buf, bufsz, "brotli/%u.%u.%u", major, minor, patch); +} +#endif + +#ifdef HAVE_ZSTD +static void zstd_version(char *buf, size_t bufsz) +{ + unsigned int version = ZSTD_versionNumber(); + unsigned int major = version / (100 * 100); + unsigned int minor = (version - (major * 100 * 100)) / 100; + unsigned int patch = version - (major * 100 * 100) - (minor * 100); + (void)curl_msnprintf(buf, bufsz, "zstd/%u.%u.%u", major, minor, patch); +} +#endif + +#ifdef USE_LIBPSL +static void psl_version(char *buf, size_t bufsz) +{ +#if defined(PSL_VERSION_MAJOR) && (PSL_VERSION_MAJOR > 0 || \ + PSL_VERSION_MINOR >= 11) + int num = psl_check_version_number(0); + curl_msnprintf(buf, bufsz, "libpsl/%d.%d.%d", + num >> 16, (num >> 8) & 0xff, num & 0xff); +#else + curl_msnprintf(buf, bufsz, "libpsl/%s", psl_get_version()); +#endif +} +#endif + +#if defined(USE_LIBIDN2) || defined(USE_WIN32_IDN) || defined(USE_APPLE_IDN) +#define USE_IDN +#endif + +#ifdef USE_IDN +static void idn_version(char *buf, size_t bufsz) +{ +#ifdef USE_LIBIDN2 + curl_msnprintf(buf, bufsz, "libidn2/%s", idn2_check_version(NULL)); +#elif defined(USE_WIN32_IDN) + curl_msnprintf(buf, bufsz, "WinIDN"); +#elif defined(USE_APPLE_IDN) + curl_msnprintf(buf, bufsz, "AppleIDN"); +#endif +} +#endif + +/* + * curl_version() returns a pointer to a static buffer. + * + * It is implemented to work multi-threaded by making sure repeated invokes + * generate the exact same string and never write any temporary data like + * zeros in the data. + */ + +#define VERSION_PARTS 16 /* number of substrings we can concatenate */ + +char *curl_version(void) +{ + static char out[300]; + char *outp; + size_t outlen; + const char *src[VERSION_PARTS]; +#ifdef USE_SSL + char ssl_version[200]; +#endif +#ifdef HAVE_LIBZ + char z_version[30]; +#endif +#ifdef HAVE_BROTLI + char br_version[30]; +#endif +#ifdef HAVE_ZSTD + char zstd_ver[30]; +#endif +#ifdef USE_ARES + char cares_version[30]; +#endif +#ifdef USE_IDN + char idn_ver[30]; +#endif +#ifdef USE_LIBPSL + char psl_ver[30]; +#endif +#ifdef USE_SSH + char ssh_version[30]; +#endif +#if !defined(CURL_DISABLE_HTTP) && defined(USE_NGHTTP2) + char h2_version[30]; +#endif +#if !defined(CURL_DISABLE_HTTP) && defined(USE_HTTP3) + char h3_version[30]; +#endif +#ifdef USE_GSASL + char gsasl_buf[30]; +#endif +#ifdef HAVE_GSSAPI + char gss_buf[40]; +#endif +#ifndef CURL_DISABLE_LDAP + char ldap_buf[30]; +#endif + int i = 0; + int j; + +#ifdef DEBUGBUILD + /* Override version string when environment variable CURL_VERSION is set */ + const char *debugversion = getenv("CURL_VERSION"); + if(debugversion) { + curl_msnprintf(out, sizeof(out), "%s", debugversion); + return out; + } +#endif + + src[i++] = LIBCURL_NAME "/" LIBCURL_VERSION; +#ifdef USE_SSL + Curl_ssl_version(ssl_version, sizeof(ssl_version)); + src[i++] = ssl_version; +#endif +#ifdef HAVE_LIBZ + curl_msnprintf(z_version, sizeof(z_version), "zlib/%s", zlibVersion()); + src[i++] = z_version; +#endif +#ifdef HAVE_BROTLI + brotli_version(br_version, sizeof(br_version)); + src[i++] = br_version; +#endif +#ifdef HAVE_ZSTD + zstd_version(zstd_ver, sizeof(zstd_ver)); + src[i++] = zstd_ver; +#endif +#ifdef USE_ARES + curl_msnprintf(cares_version, sizeof(cares_version), + "c-ares/%s", ares_version(NULL)); + src[i++] = cares_version; +#endif +#ifdef USE_IDN + idn_version(idn_ver, sizeof(idn_ver)); + src[i++] = idn_ver; +#endif +#ifdef USE_LIBPSL + psl_version(psl_ver, sizeof(psl_ver)); + src[i++] = psl_ver; +#endif +#ifdef USE_SSH + Curl_ssh_version(ssh_version, sizeof(ssh_version)); + src[i++] = ssh_version; +#endif +#if !defined(CURL_DISABLE_HTTP) && defined(USE_NGHTTP2) + Curl_http2_ver(h2_version, sizeof(h2_version)); + src[i++] = h2_version; +#endif +#if !defined(CURL_DISABLE_HTTP) && defined(USE_HTTP3) + Curl_quic_ver(h3_version, sizeof(h3_version)); + src[i++] = h3_version; +#endif +#ifdef USE_GSASL + curl_msnprintf(gsasl_buf, sizeof(gsasl_buf), "libgsasl/%s", + gsasl_check_version(NULL)); + src[i++] = gsasl_buf; +#endif +#ifdef HAVE_GSSAPI +#ifdef HAVE_GSSGNU + curl_msnprintf(gss_buf, sizeof(gss_buf), "libgss/%s", GSS_VERSION); +#elif defined(CURL_KRB5_VERSION) + curl_msnprintf(gss_buf, sizeof(gss_buf), "mit-krb5/%s", CURL_KRB5_VERSION); +#else + curl_msnprintf(gss_buf, sizeof(gss_buf), "mit-krb5"); +#endif + src[i++] = gss_buf; +#endif /* HAVE_GSSAPI */ +#ifndef CURL_DISABLE_LDAP + Curl_ldap_version(ldap_buf, sizeof(ldap_buf)); + src[i++] = ldap_buf; +#endif + + DEBUGASSERT(i <= VERSION_PARTS); + + outp = &out[0]; + outlen = sizeof(out); + for(j = 0; j < i; j++) { + size_t n = strlen(src[j]); + /* we need room for a space, the string and the final zero */ + if(outlen <= (n + 2)) + break; + if(j) { + /* prepend a space if not the first */ + *outp++ = ' '; + outlen--; + } + memcpy(outp, src[j], n); + outp += n; + outlen -= n; + } + *outp = 0; + + return out; +} + +/* data for curl_version_info + + Keep the list sorted alphabetically. It is also written so that each + protocol line has its own #if line to make things easier on the eye. + */ + +static const char * const supported_protocols[] = { +#ifndef CURL_DISABLE_DICT + "dict", +#endif +#ifndef CURL_DISABLE_FILE + "file", +#endif +#ifndef CURL_DISABLE_FTP + "ftp", +#endif +#if defined(USE_SSL) && !defined(CURL_DISABLE_FTP) + "ftps", +#endif +#ifndef CURL_DISABLE_GOPHER + "gopher", +#endif +#if defined(USE_SSL) && !defined(CURL_DISABLE_GOPHER) + "gophers", +#endif +#ifndef CURL_DISABLE_HTTP + "http", +#endif +#if defined(USE_SSL) && !defined(CURL_DISABLE_HTTP) + "https", +#endif +#ifndef CURL_DISABLE_IMAP + "imap", +#endif +#if defined(USE_SSL) && !defined(CURL_DISABLE_IMAP) + "imaps", +#endif +#ifndef CURL_DISABLE_LDAP + "ldap", +#if !defined(CURL_DISABLE_LDAPS) && \ + ((defined(USE_OPENLDAP) && defined(USE_SSL)) || \ + (!defined(USE_OPENLDAP) && defined(HAVE_LDAP_SSL))) + "ldaps", +#endif +#endif +#ifndef CURL_DISABLE_MQTT + "mqtt", +#endif +#if defined(USE_SSL) && !defined(CURL_DISABLE_MQTT) + "mqtts", +#endif +#ifndef CURL_DISABLE_POP3 + "pop3", +#endif +#if defined(USE_SSL) && !defined(CURL_DISABLE_POP3) + "pop3s", +#endif +#ifndef CURL_DISABLE_RTSP + "rtsp", +#endif +#ifdef USE_SSH + "scp", + "sftp", +#endif +#if defined(CURL_ENABLE_SMB) && defined(USE_CURL_NTLM_CORE) + "smb", +# ifdef USE_SSL + "smbs", +# endif +#endif +#ifndef CURL_DISABLE_SMTP + "smtp", +#endif +#if defined(USE_SSL) && !defined(CURL_DISABLE_SMTP) + "smtps", +#endif +#ifndef CURL_DISABLE_TELNET + "telnet", +#endif +#ifndef CURL_DISABLE_TFTP + "tftp", +#endif +#ifndef CURL_DISABLE_HTTP + /* WebSocket support relies on HTTP */ +#ifndef CURL_DISABLE_WEBSOCKETS + "ws", +#endif +#if defined(USE_SSL) && !defined(CURL_DISABLE_WEBSOCKETS) + "wss", +#endif +#endif + + NULL +}; + +/* + * Feature presence runtime check functions. + * + * Warning: the value returned by these should not change between + * curl_global_init() and curl_global_cleanup() calls. + */ + +#if defined(USE_LIBIDN2) || defined(USE_WIN32_IDN) || defined(USE_APPLE_IDN) +static int idn_present(curl_version_info_data *info) +{ +#if defined(USE_WIN32_IDN) || defined(USE_APPLE_IDN) + (void)info; + return TRUE; +#else + return !!info->libidn; +#endif +} +#endif + +#if defined(USE_SSL) && !defined(CURL_DISABLE_PROXY) && \ + !defined(CURL_DISABLE_HTTP) +static int https_proxy_present(curl_version_info_data *info) +{ + (void)info; + return Curl_ssl_supports(NULL, SSLSUPP_HTTPS_PROXY); +} +#endif + +#if defined(USE_SSL) && defined(USE_ECH) +static int ech_present(curl_version_info_data *info) +{ + (void)info; + return Curl_ssl_supports(NULL, SSLSUPP_ECH); +} +#endif + +/* + * Features table. + * + * Keep the features alphabetically sorted. + * Use FEATURE() macro to define an entry: this allows documentation check. + */ + +#define FEATURE(name, present, bitmask) { (name), (present), (bitmask) } + +struct feat { + const char *name; + int (*present)(curl_version_info_data *info); + int bitmask; +}; + +static const struct feat features_table[] = { +#ifndef CURL_DISABLE_ALTSVC + FEATURE("alt-svc", NULL, CURL_VERSION_ALTSVC), +#endif +#if defined(USE_ARES) && defined(USE_RESOLV_THREADED) && defined(USE_HTTPSRR) + FEATURE("asyn-rr", NULL, 0), +#endif +#ifdef CURLRES_ASYNCH + FEATURE("AsynchDNS", NULL, CURL_VERSION_ASYNCHDNS), +#endif +#ifdef HAVE_BROTLI + FEATURE("brotli", NULL, CURL_VERSION_BROTLI), +#endif +#ifdef DEBUGBUILD + FEATURE("Debug", NULL, CURL_VERSION_DEBUG), +#endif +#if defined(USE_SSL) && defined(USE_ECH) + FEATURE("ECH", ech_present, 0), + +#ifndef USE_HTTPSRR +#error "ECH enabled but not HTTPSRR, must be a config error" +#endif +#endif +#ifdef USE_GSASL + FEATURE("gsasl", NULL, CURL_VERSION_GSASL), +#endif +#ifdef HAVE_GSSAPI + FEATURE("GSS-API", NULL, CURL_VERSION_GSSAPI), +#endif +#ifndef CURL_DISABLE_HSTS + FEATURE("HSTS", NULL, CURL_VERSION_HSTS), +#endif +#if !defined(CURL_DISABLE_HTTP) && defined(USE_NGHTTP2) + FEATURE("HTTP2", NULL, CURL_VERSION_HTTP2), +#endif +#if !defined(CURL_DISABLE_HTTP) && defined(USE_HTTP3) + FEATURE("HTTP3", NULL, CURL_VERSION_HTTP3), +#endif +#if defined(USE_SSL) && !defined(CURL_DISABLE_PROXY) && \ + !defined(CURL_DISABLE_HTTP) + FEATURE("HTTPS-proxy", https_proxy_present, CURL_VERSION_HTTPS_PROXY), +#endif +#ifdef USE_HTTPSRR + FEATURE("HTTPSRR", NULL, 0), +#endif +#if defined(USE_LIBIDN2) || defined(USE_WIN32_IDN) || defined(USE_APPLE_IDN) + FEATURE("IDN", idn_present, CURL_VERSION_IDN), +#endif +#ifdef USE_IPV6 + FEATURE("IPv6", NULL, CURL_VERSION_IPV6), +#endif +#ifdef USE_KERBEROS5 + FEATURE("Kerberos", NULL, CURL_VERSION_KERBEROS5), +#endif +#if (SIZEOF_CURL_OFF_T > 4) && ((SIZEOF_OFF_T > 4) || defined(_WIN32)) + FEATURE("Largefile", NULL, CURL_VERSION_LARGEFILE), +#endif +#ifdef HAVE_LIBZ + FEATURE("libz", NULL, CURL_VERSION_LIBZ), +#endif +#ifdef CURL_WITH_MULTI_SSL + FEATURE("MultiSSL", NULL, CURL_VERSION_MULTI_SSL), +#endif +#ifdef USE_NTLM + FEATURE("NTLM", NULL, CURL_VERSION_NTLM), +#endif +#ifdef USE_PROXY_HTTP3 + FEATURE("proxy-HTTP3", NULL, 0), +#endif +#ifdef USE_LIBPSL + FEATURE("PSL", NULL, CURL_VERSION_PSL), +#endif +#ifdef USE_SSL +#ifdef USE_APPLE_SECTRUST + FEATURE("AppleSecTrust", NULL, 0), +#elif defined(CURL_CA_NATIVE) + FEATURE("NativeCA", NULL, 0), +#endif +#endif /* USE_SSL */ +#ifdef USE_SPNEGO + FEATURE("SPNEGO", NULL, CURL_VERSION_SPNEGO), +#endif +#ifdef USE_SSL + FEATURE("SSL", NULL, CURL_VERSION_SSL), +#endif +#ifdef USE_SSLS_EXPORT + FEATURE("SSLS-EXPORT", NULL, 0), +#endif +#ifdef USE_WINDOWS_SSPI + FEATURE("SSPI", NULL, CURL_VERSION_SSPI), +#endif +#ifdef GLOBAL_INIT_IS_THREADSAFE + FEATURE("threadsafe", NULL, CURL_VERSION_THREADSAFE), +#endif +#ifdef USE_TLS_SRP + FEATURE("TLS-SRP", NULL, CURL_VERSION_TLSAUTH_SRP), +#endif +#if defined(_WIN32) && defined(UNICODE) && defined(_UNICODE) + FEATURE("Unicode", NULL, CURL_VERSION_UNICODE), +#endif +#ifdef USE_UNIX_SOCKETS + FEATURE("UnixSockets", NULL, CURL_VERSION_UNIX_SOCKETS), +#endif +#ifdef HAVE_ZSTD + FEATURE("zstd", NULL, CURL_VERSION_ZSTD), +#endif + {NULL, NULL, 0} +}; + +static const char *feature_names[CURL_ARRAYSIZE(features_table)] = { NULL }; + +static curl_version_info_data version_info = { + CURLVERSION_NOW, + LIBCURL_VERSION, + LIBCURL_VERSION_NUM, + CURL_OS, /* as found by configure or set by hand at build-time */ + 0, /* features bitmask is built at runtime */ + NULL, /* ssl_version */ + 0, /* ssl_version_num, this is kept at zero */ + NULL, /* zlib_version */ + supported_protocols, + NULL, /* c-ares version */ + 0, /* c-ares version numerical */ + NULL, /* libidn version */ + 0, /* iconv version */ + NULL, /* ssh lib version */ + 0, /* brotli_ver_num */ + NULL, /* brotli version */ + 0, /* nghttp2 version number */ + NULL, /* nghttp2 version string */ + NULL, /* quic library string */ +#ifdef CURL_CA_BUNDLE + CURL_CA_BUNDLE, /* cainfo */ +#else + NULL, +#endif +#ifdef CURL_CA_PATH + CURL_CA_PATH, /* capath */ +#else + NULL, +#endif + 0, /* zstd_ver_num */ + NULL, /* zstd version */ + NULL, /* Hyper version */ + NULL, /* gsasl version */ + feature_names, + NULL /* rtmp version */ +}; + +curl_version_info_data *curl_version_info(CURLversion stamp) +{ + size_t n; + const struct feat *p; + int features = 0; + +#ifdef USE_SSH + static char ssh_buf[80]; /* 'ssh_buffer' clashes with libssh/libssh.h */ +#endif +#ifdef USE_SSL +#ifdef CURL_WITH_MULTI_SSL + static char ssl_buffer[200]; +#else + static char ssl_buffer[80]; +#endif +#endif +#ifdef HAVE_BROTLI + static char brotli_buffer[80]; +#endif +#ifdef HAVE_ZSTD + static char zstd_buffer[80]; +#endif + + (void)stamp; + +#ifdef USE_SSL + Curl_ssl_version(ssl_buffer, sizeof(ssl_buffer)); + version_info.ssl_version = ssl_buffer; +#endif + +#ifdef HAVE_LIBZ + version_info.libz_version = zlibVersion(); + /* libz left NULL if non-existing */ +#endif +#ifdef USE_ARES + { + int aresnum; + version_info.ares = ares_version(&aresnum); + version_info.ares_num = aresnum; + } +#endif +#ifdef USE_LIBIDN2 + /* This returns a version string if we use the given version or later, + otherwise it returns NULL */ + version_info.libidn = idn2_check_version(IDN2_VERSION); +#endif + +#ifdef USE_SSH + Curl_ssh_version(ssh_buf, sizeof(ssh_buf)); + version_info.libssh_version = ssh_buf; +#endif + +#ifdef HAVE_BROTLI + version_info.brotli_ver_num = BrotliDecoderVersion(); + brotli_version(brotli_buffer, sizeof(brotli_buffer)); + version_info.brotli_version = brotli_buffer; +#endif + +#ifdef HAVE_ZSTD + version_info.zstd_ver_num = ZSTD_versionNumber(); + zstd_version(zstd_buffer, sizeof(zstd_buffer)); + version_info.zstd_version = zstd_buffer; +#endif + +#ifdef USE_NGHTTP2 + { + nghttp2_info *h2 = nghttp2_version(0); + version_info.nghttp2_ver_num = (unsigned int)h2->version_num; + version_info.nghttp2_version = h2->version_str; + } +#endif + +#if !defined(CURL_DISABLE_HTTP) && defined(USE_HTTP3) + { + static char quicbuffer[80]; + Curl_quic_ver(quicbuffer, sizeof(quicbuffer)); + version_info.quic_version = quicbuffer; + } +#endif + +#ifdef USE_GSASL + { + version_info.gsasl_version = gsasl_check_version(NULL); + } +#endif + + /* Get available features, build bitmask and names array. */ + n = 0; + for(p = features_table; p->name; p++) + if(!p->present || p->present(&version_info)) { + features |= p->bitmask; + feature_names[n++] = p->name; + } + +#ifdef DEBUGBUILD + features |= CURL_VERSION_CURLDEBUG; /* for compatibility */ +#endif + + feature_names[n] = NULL; /* Terminate array. */ + version_info.features = features; + + return &version_info; +} diff --git a/3rdparty/curl-8.21.0/lib/vquic/capsule.c b/3rdparty/curl-8.21.0/lib/vquic/capsule.c new file mode 100644 index 0000000000..4bbdae3ace --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vquic/capsule.c @@ -0,0 +1,301 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_PROXY) && !defined(CURL_DISABLE_HTTP) + +#ifdef HAVE_ARPA_INET_H +#include /* for htons() */ +#endif + +#include +#include "urldata.h" +#include "curlx/dynbuf.h" +#include "cfilters.h" +#include "curl_trc.h" +#include "bufq.h" +#include "vquic/capsule.h" + + +/** + * Convert 64-bit value from network byte order to host byte order + */ +static uint64_t capsule_ntohll(uint64_t value) +{ +#if defined(__BYTE_ORDER__) && (__BYTE_ORDER__ == __ORDER_BIG_ENDIAN__) + return value; +#elif (defined(__GNUC__) || defined(__clang__)) && \ + defined(__BYTE_ORDER__) && (__BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__) + return __builtin_bswap64(value); +#else + union { + uint64_t u64; + uint32_t u32[2]; + } src, dst; + + src.u64 = value; + dst.u32[0] = ntohl(src.u32[1]); + dst.u32[1] = ntohl(src.u32[0]); + return dst.u64; +#endif +} + +/** + * Encode a variable-length integer into a plain buffer. + * @param buf Output buffer (must have at least 8 bytes) + * @param value Value to encode (must be <= 0x3FFFFFFFFFFFFFFF) + * @return Number of bytes written + */ +static size_t capsule_encode_varint_buf(uint8_t *buf, uint64_t value) +{ + DEBUGASSERT(value <= 0x3FFFFFFFFFFFFFFF); + + if(value <= 0x3F) { + buf[0] = (uint8_t)value; + return 1; + } + else if(value <= 0x3FFF) { + uint16_t encoded = (uint16_t)value & 0x3FFF; + encoded = ntohs(encoded | 0x4000); + memcpy(buf, &encoded, 2); + return 2; + } + else if(value <= 0x3FFFFFFF) { + uint32_t encoded = (uint32_t)value & 0x3FFFFFFF; + encoded = ntohl(encoded | 0x80000000); + memcpy(buf, &encoded, 4); + return 4; + } + else { + uint64_t encoded = (uint64_t)value & 0x3FFFFFFFFFFFFFFF; + encoded = capsule_ntohll(encoded | 0xC000000000000000); + memcpy(buf, &encoded, 8); + return 8; + } +} + +static CURLcode capsule_peek_u8(struct bufq *recvbufq, + size_t offset, + uint8_t *pbyte) +{ + const unsigned char *peek = NULL; + size_t peeklen = 0; + + if(!Curl_bufq_peek_at(recvbufq, offset, &peek, &peeklen) || !peeklen) + return CURLE_AGAIN; + *pbyte = peek[0]; + return CURLE_OK; +} + +static CURLcode capsule_decode_varint_at(struct bufq *recvbufq, + size_t offset, + uint64_t *pvalue, + size_t *pconsumed) +{ + uint8_t first_byte, byte; + uint64_t value; + size_t nbytes; + size_t i; + CURLcode result; + + result = capsule_peek_u8(recvbufq, offset, &first_byte); + if(result) + return result; + + nbytes = (size_t)1 << (first_byte >> 6); /* 1, 2, 4 or 8 bytes */ + value = first_byte & 0x3F; + + for(i = 1; i < nbytes; ++i) { + result = capsule_peek_u8(recvbufq, offset + i, &byte); + if(result) + return result; + value = (value << 8) | byte; + } + + *pvalue = value; + *pconsumed = nbytes; + return CURLE_OK; +} + +/** + * Write the capsule header (type + varint length + context ID) into `hdr`. + * @param hdr Output buffer (must be >= HTTP_CAPSULE_HEADER_MAX_SIZE) + * @param hdrlen Size of `hdr` in bytes + * @param payload_len Length of the UDP payload that follows + * @return Number of header bytes written, or 0 on error + * + * @unittest 3400 + */ +UNITTEST size_t capsule_encap_udp_hdr(uint8_t *hdr, size_t hdrlen, + size_t payload_len); +UNITTEST size_t capsule_encap_udp_hdr(uint8_t *hdr, size_t hdrlen, + size_t payload_len) +{ + size_t off = 0; + DEBUGASSERT(hdrlen >= HTTP_CAPSULE_HEADER_MAX_SIZE); + if(hdrlen < HTTP_CAPSULE_HEADER_MAX_SIZE) + return 0; + hdr[off++] = 0; /* capsule type: HTTP Datagram */ + off += capsule_encode_varint_buf(hdr + off, (uint64_t)payload_len + 1); + hdr[off++] = 0; /* context ID */ + return off; +} + +CURLcode Curl_capsule_encap_udp_datagram(struct bufq *q, + const void *buf, size_t blen) +{ + CURLcode result; + uint8_t hdr[HTTP_CAPSULE_HEADER_MAX_SIZE]; + size_t hdr_len, nwritten; + + hdr_len = capsule_encap_udp_hdr(hdr, sizeof(hdr), blen); + DEBUGASSERT(hdr_len); + if(!hdr_len) + return CURLE_FAILED_INIT; + + result = Curl_bufq_write(q, hdr, hdr_len, &nwritten); + if(!result && (nwritten != hdr_len)) + return CURLE_WRITE_ERROR; + if(!result) { + result = Curl_bufq_write(q, buf, blen, &nwritten); + if(!result && (nwritten != blen)) + return CURLE_WRITE_ERROR; + } + if(result == CURLE_AGAIN) + return CURLE_WRITE_ERROR; + return result; +} + +size_t Curl_capsule_process_udp_raw(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct bufq *recvbufq, + unsigned char *buf, size_t len, + CURLcode *err) +{ + const unsigned char *context_id, *capsule_type; + size_t read_size, varint_len; + uint64_t capsule_length; + size_t offset, payload_len; + size_t bytes_read = 0; + CURLcode result = CURLE_OK; + + if(!len) { + *err = CURLE_BAD_FUNCTION_ARGUMENT; + return 0; + } + + if(Curl_bufq_is_empty(recvbufq)) { + *err = CURLE_AGAIN; + return 0; + } + + if(!Curl_bufq_peek(recvbufq, &capsule_type, &read_size) || !read_size) { + *err = CURLE_AGAIN; + return 0; + } + + if(capsule_type[0]) { + infof(data, "Error! Invalid capsule type: %d", capsule_type[0]); + Curl_bufq_skip(recvbufq, 1); + *err = CURLE_RECV_ERROR; + return 0; + } + + offset = 1; + result = capsule_decode_varint_at(recvbufq, offset, &capsule_length, + &varint_len); + if(result == CURLE_AGAIN) { + *err = CURLE_AGAIN; + return 0; + } + else if(result) { + *err = CURLE_RECV_ERROR; + return 0; + } + offset += varint_len; + + if(!Curl_bufq_peek_at(recvbufq, offset, &context_id, &read_size) || + !read_size) { + *err = CURLE_AGAIN; + return 0; + } + + if(*context_id) { + infof(data, "Error! Invalid context ID: %02x", *context_id); + Curl_bufq_skip(recvbufq, offset + 1); + *err = CURLE_RECV_ERROR; + return 0; + } + offset += 1; + + if(!capsule_length) { + infof(data, "Error! Invalid capsule length: 0"); + Curl_bufq_skip(recvbufq, offset); + *err = CURLE_RECV_ERROR; + return 0; + } + if(capsule_length - 1 >= (uint64_t)SIZE_MAX) { + infof(data, "Error! Capsule length too large: %" CURL_FORMAT_CURL_OFF_T, + (curl_off_t)capsule_length); + *err = CURLE_RECV_ERROR; + return 0; + } + payload_len = (size_t)(capsule_length - 1); + + if(Curl_bufq_len(recvbufq) < offset + payload_len) { + *err = CURLE_AGAIN; + return 0; + } + + if(payload_len > len) { + infof(data, "UDP payload does not fit destination buffer: %zu > %zu", + payload_len, len); + Curl_bufq_skip(recvbufq, offset + payload_len); + *err = CURLE_RECV_ERROR; + return 0; + } + + Curl_bufq_skip(recvbufq, offset); + if(!payload_len) { + *err = CURLE_OK; + return 0; + } + result = Curl_bufq_read(recvbufq, buf, payload_len, &bytes_read); + if(result || (bytes_read != payload_len)) { + infof(data, "Error! Read less than expected %zu %zu", + payload_len, bytes_read); + *err = CURLE_RECV_ERROR; + return 0; + } + + if(cf && data) { + CURL_TRC_CF(data, cf, "Processed UDP capsule raw: size=%zu " + "length_left %zu", payload_len, Curl_bufq_len(recvbufq)); + } + *err = CURLE_OK; + return bytes_read; +} + +#endif /* !CURL_DISABLE_PROXY && !CURL_DISABLE_HTTP */ diff --git a/3rdparty/curl-8.21.0/lib/vquic/capsule.h b/3rdparty/curl-8.21.0/lib/vquic/capsule.h new file mode 100644 index 0000000000..7861e6fd73 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vquic/capsule.h @@ -0,0 +1,70 @@ +#ifndef HEADER_CURL_CAPSULE_H +#define HEADER_CURL_CAPSULE_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_PROXY) && !defined(CURL_DISABLE_HTTP) + +#include "curlx/dynbuf.h" +#include "bufq.h" + +/* HTTP Capsule constants */ +#define HTTP_CAPSULE_HEADER_MAX_SIZE 10 + +/* HTTP Capsule function prototypes */ + +/** + * Encapsulate UDP payload into HTTP Datagram capsule format + * @param q the bufq to write the capsule to + * @param buf Payload buffer + * @param blen Payload buffer length + * @return CURLE_OK on success, error code on failure + */ +CURLcode Curl_capsule_encap_udp_datagram(struct bufq *q, + const void *buf, size_t blen); + +struct Curl_easy; +struct Curl_cfilter; + +/** + * Process one UDP capsule from buffer into raw datagram payload bytes. + * @param cf Connection filter + * @param data Easy handle + * @param recvbufq Buffer queue containing capsule data + * @param buf Output buffer for one datagram payload + * @param len Size of output buffer in bytes + * @param err Error code output + * @return Number of payload bytes written. Check `err` for status. + */ +size_t Curl_capsule_process_udp_raw(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct bufq *recvbufq, + unsigned char *buf, size_t len, + CURLcode *err); + +#endif /* !CURL_DISABLE_PROXY && !CURL_DISABLE_HTTP */ + +#endif /* HEADER_CURL_CAPSULE_H */ diff --git a/3rdparty/curl-8.21.0/lib/vquic/cf-capsule.c b/3rdparty/curl-8.21.0/lib/vquic/cf-capsule.c new file mode 100644 index 0000000000..3ff7827bba --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vquic/cf-capsule.c @@ -0,0 +1,306 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_PROXY) && !defined(CURL_DISABLE_HTTP) + +#include "urldata.h" +#include "cfilters.h" +#include "curl_trc.h" +#include "bufq.h" +#include "select.h" +#include "vquic/capsule.h" +#include "vquic/cf-capsule.h" + +/* send/recv buffer: 4 chunks of 16KB = 64KB, enough for large datagrams */ +#define CAPSULE_RECV_CHUNKS 4 +#define CAPSULE_SEND_CHUNKS 4 +#define CAPSULE_CHUNK_SIZE (16 * 1024) + +struct cf_capsule_ctx { + struct bufq recvbuf; + struct bufq sendbuf; +}; + +static void cf_capsule_destroy(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_capsule_ctx *ctx = cf->ctx; + (void)data; + if(ctx) { + Curl_bufq_free(&ctx->recvbuf); + Curl_bufq_free(&ctx->sendbuf); + curlx_safefree(ctx); + } +} + +static CURLcode cf_capsule_connect(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ + if(cf->connected) { + *done = TRUE; + return CURLE_OK; + } + if(cf->next) { + CURLcode result = cf->next->cft->do_connect(cf->next, data, done); + if(!result && *done) + cf->connected = TRUE; + return result; + } + *done = FALSE; + return CURLE_OK; +} + +static CURLcode cf_capsule_flush(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_capsule_ctx *ctx = cf->ctx; + CURLcode result = CURLE_OK; + size_t nwritten; + + if(Curl_bufq_is_empty(&ctx->sendbuf)) + return CURLE_OK; + + result = Curl_cf_send_bufq(cf->next, data, &ctx->sendbuf, NULL, 0, + &nwritten); + if(result) { + if(result == CURLE_AGAIN) { + CURL_TRC_CF(data, cf, "flush send buffer(%zu) -> EAGAIN", + Curl_bufq_len(&ctx->sendbuf)); + } + return result; + } + return Curl_bufq_is_empty(&ctx->sendbuf) ? CURLE_OK : CURLE_AGAIN; +} + +static CURLcode cf_capsule_send(struct Curl_cfilter *cf, + struct Curl_easy *data, + const uint8_t *buf, size_t len, + bool eos, size_t *pnwritten) +{ + struct cf_capsule_ctx *ctx = cf->ctx; + CURLcode result; + + (void)eos; + *pnwritten = 0; + + if(Curl_bufq_is_full(&ctx->sendbuf)) { + result = cf_capsule_flush(cf, data); + if(result) + return result; + } + + /* encapsulate new payload into a capsule */ + result = Curl_capsule_encap_udp_datagram(&ctx->sendbuf, buf, len); + if(result) + return result; + + result = cf_capsule_flush(cf, data); + if(result == CURLE_AGAIN) { + /* Could not send it (or all), report success nevertheless as we + * have the payload buffered now and will flush it later. */ + result = CURLE_OK; + } + + if(!result) + *pnwritten = len; + return result; +} + +static CURLcode cf_capsule_recv(struct Curl_cfilter *cf, + struct Curl_easy *data, + char *buf, size_t len, + size_t *pnread) +{ + struct cf_capsule_ctx *ctx = cf->ctx; + CURLcode result; + size_t nread; + + *pnread = 0; + + /* fill our receive buffer from the filter below */ + while(!Curl_bufq_is_full(&ctx->recvbuf)) { + result = Curl_cf_recv_bufq(cf->next, data, &ctx->recvbuf, 0, &nread); + if(result == CURLE_AGAIN) + break; + if(result) + return result; + if(!nread) + break; + } + + /* try to extract a complete capsule datagram */ + *pnread = Curl_capsule_process_udp_raw(cf, data, &ctx->recvbuf, + (unsigned char *)buf, len, + &result); + return result; +} + +static bool cf_capsule_data_pending(struct Curl_cfilter *cf, + const struct Curl_easy *data) +{ + struct cf_capsule_ctx *ctx = cf->ctx; + + if(ctx && !Curl_bufq_is_empty(&ctx->recvbuf)) + return TRUE; + return cf->next ? cf->next->cft->has_data_pending(cf->next, data) : FALSE; +} + +static CURLcode cf_capsule_cntrl(struct Curl_cfilter *cf, + struct Curl_easy *data, + int event, int arg1, void *arg2) +{ + CURLcode result = CURLE_OK; + + (void)arg1; + (void)arg2; + switch(event) { + case CF_CTRL_FLUSH: + result = cf_capsule_flush(cf, data); + break; + default: + break; + } + return result; +} + +static CURLcode cf_capsule_query(struct Curl_cfilter *cf, + struct Curl_easy *data, + int query, int *pres1, void *pres2) +{ + struct cf_capsule_ctx *ctx = cf->ctx; + + (void)pres2; + switch(query) { + case CF_QUERY_NEED_FLUSH: { + if(!Curl_bufq_is_empty(&ctx->sendbuf)) { + *pres1 = TRUE; + return CURLE_OK; + } + break; + } + default: + break; + } + return cf->next ? + cf->next->cft->query(cf->next, data, query, pres1, pres2) : + CURLE_UNKNOWN_OPTION; +} + +static CURLcode cf_capsule_adjust_pollset(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct easy_pollset *ps) +{ + struct cf_capsule_ctx *ctx = cf->ctx; + + if(!Curl_bufq_is_empty(&ctx->sendbuf)) { + curl_socket_t sock = Curl_conn_cf_get_socket(cf, data); + if(sock != CURL_SOCKET_BAD) + return Curl_pollset_add_out(data, ps, sock); + } + return CURLE_OK; +} + +static CURLcode cf_capsule_shutdown(struct Curl_cfilter *cf, + struct Curl_easy *data, bool *done) +{ + CURLcode result = CURLE_OK; + + if(!cf->connected || cf->shutdown) { + *done = TRUE; + } + else { + result = cf_capsule_flush(cf, data); + *done = !result; + if(result == CURLE_AGAIN) + result = CURLE_OK; + } + return result; +} + +struct Curl_cftype Curl_cft_capsule = { + "CAPSULE", + 0, + 0, + cf_capsule_destroy, + cf_capsule_connect, + cf_capsule_shutdown, + cf_capsule_adjust_pollset, + cf_capsule_data_pending, + cf_capsule_send, + cf_capsule_recv, + cf_capsule_cntrl, + Curl_cf_def_conn_is_alive, + Curl_cf_def_conn_keep_alive, + cf_capsule_query, +}; + +static CURLcode cf_capsule_create(struct Curl_cfilter **pcf, + struct Curl_easy *data, + struct connectdata *conn) +{ + struct Curl_cfilter *cf = NULL; + struct cf_capsule_ctx *ctx; + CURLcode result; + + (void)data; + (void)conn; + *pcf = NULL; + ctx = curlx_calloc(1, sizeof(*ctx)); + if(!ctx) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + Curl_bufq_init2(&ctx->recvbuf, CAPSULE_CHUNK_SIZE, CAPSULE_RECV_CHUNKS, + BUFQ_OPT_SOFT_LIMIT); + Curl_bufq_init2(&ctx->sendbuf, CAPSULE_CHUNK_SIZE, CAPSULE_SEND_CHUNKS, + BUFQ_OPT_SOFT_LIMIT); + + result = Curl_cf_create(&cf, &Curl_cft_capsule, ctx); + +out: + *pcf = (!result) ? cf : NULL; + if(result && ctx) { + Curl_bufq_free(&ctx->recvbuf); + Curl_bufq_free(&ctx->sendbuf); + curlx_free(ctx); + } + return result; +} + +CURLcode Curl_cf_capsule_insert_after(struct Curl_cfilter *cf_at, + struct Curl_easy *data) +{ + struct Curl_cfilter *cf; + CURLcode result; + + result = cf_capsule_create(&cf, data, cf_at->conn); + if(!result) + Curl_conn_cf_insert_after(cf_at, cf); + return result; +} + +#endif /* !CURL_DISABLE_PROXY && !CURL_DISABLE_HTTP */ diff --git a/3rdparty/curl-8.21.0/lib/vquic/cf-capsule.h b/3rdparty/curl-8.21.0/lib/vquic/cf-capsule.h new file mode 100644 index 0000000000..437c9681b6 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vquic/cf-capsule.h @@ -0,0 +1,40 @@ +#ifndef HEADER_CURL_CF_CAPSULE_H +#define HEADER_CURL_CF_CAPSULE_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_PROXY) && !defined(CURL_DISABLE_HTTP) + +/* Insert a capsule protocol filter after `cf_at` in the filter chain. + * The capsule filter encapsulates/decapsulates UDP datagrams using + * the HTTP Datagram capsule format (RFC 9297). */ +CURLcode Curl_cf_capsule_insert_after(struct Curl_cfilter *cf_at, + struct Curl_easy *data); + +extern struct Curl_cftype Curl_cft_capsule; + +#endif /* !CURL_DISABLE_PROXY && !CURL_DISABLE_HTTP */ + +#endif /* HEADER_CURL_CF_CAPSULE_H */ diff --git a/3rdparty/curl-8.21.0/lib/vquic/cf-ngtcp2-cmn.c b/3rdparty/curl-8.21.0/lib/vquic/cf-ngtcp2-cmn.c new file mode 100644 index 0000000000..e1ca18cf69 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vquic/cf-ngtcp2-cmn.c @@ -0,0 +1,1969 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_HTTP) && defined(USE_NGTCP2) && defined(USE_NGHTTP3) + +#include + +#ifdef USE_OPENSSL +#include +#if defined(OPENSSL_IS_AWSLC) || defined(OPENSSL_IS_BORINGSSL) +#include +#elif defined(OPENSSL_QUIC_API2) +#include +#else +#include +#endif +#include "vtls/openssl.h" +#elif defined(USE_GNUTLS) +#include +#include "vtls/gtls.h" +#elif defined(USE_WOLFSSL) +#include +#include "vtls/wolfssl.h" +#endif + +#include + +#include "urldata.h" +#include "url.h" +#include "uint-hash.h" +#include "curl_trc.h" +#include "rand.h" +#include "multiif.h" +#include "cfilters.h" +#include "cf-dns.h" +#include "cf-socket.h" +#include "connect.h" +#include "progress.h" +#include "curlx/fopen.h" +#include "curlx/dynbuf.h" +#include "http1.h" +#include "select.h" +#include "sockaddr.h" +#include "transfer.h" +#include "bufref.h" +#include "vquic/vquic.h" +#include "vquic/vquic_int.h" +#include "vquic/vquic-tls.h" +#include "vtls/vtls.h" +#include "vtls/vtls_scache.h" +#include "vquic/cf-ngtcp2-cmn.h" + +/* + * Store ngtcp2 version info in this buffer. + */ +void Curl_ngtcp2_ver(char *p, size_t len) +{ + const ngtcp2_info *ng2 = ngtcp2_version(0); + const nghttp3_info *ht3 = nghttp3_version(0); + (void)curl_msnprintf(p, len, "ngtcp2/%s nghttp3/%s", + ng2->version_str, ht3->version_str); +} + +void Curl_cf_ngtcp2_h3_stream_ctx_free(struct h3_stream_ctx *stream) +{ + Curl_bufq_free(&stream->sendbuf); + Curl_h1_req_parse_free(&stream->h1); + curlx_free(stream); +} + +static void h3_stream_hash_free(unsigned int id, void *stream) +{ + (void)id; + DEBUGASSERT(stream); + Curl_cf_ngtcp2_h3_stream_ctx_free((struct h3_stream_ctx *)stream); +} + +static bool cf_ngtcp2_h3_err_is_fatal(int code) +{ + return (NGHTTP3_ERR_FATAL >= code) || + (NGHTTP3_ERR_H3_CLOSED_CRITICAL_STREAM == code); +} + +void Curl_cf_ngtcp2_h3_err_set(struct Curl_cfilter *cf, + struct Curl_easy *data, int code) +{ + struct cf_ngtcp2_ctx *ctx = cf->ctx; + if(!ctx->last_error.error_code) { + ngtcp2_ccerr_set_application_error(&ctx->last_error, + nghttp3_err_infer_quic_app_error_code(code), NULL, 0); + } + if(cf_ngtcp2_h3_err_is_fatal(code)) + Curl_cf_ngtcp2_cmn_conn_close(cf, data); +} + +CURLcode Curl_cf_ngtcp2_ctx_init(struct cf_ngtcp2_ctx *ctx, + struct Curl_peer *origin, + struct Curl_peer *peer, + struct ssl_primary_config *sslc, + cf_ngtcp2_init_h3_conn *init_h3_conn_cb) +{ + DEBUGASSERT(!ctx->initialized); + ctx->qlogfd = -1; + ctx->tunnel_inbuf = NULL; + ctx->tunnel_inbuf_len = 0; + ctx->version = NGTCP2_PROTO_VER_MAX; + Curl_bufcp_init(&ctx->stream_bufcp, H3_STREAM_CHUNK_SIZE, + H3_STREAM_POOL_SPARES); + curlx_dyn_init(&ctx->scratch, CURL_MAX_HTTP_HEADER); + Curl_uint32_hash_init(&ctx->streams, 63, h3_stream_hash_free); + ctx->init_h3_conn_cb = init_h3_conn_cb; + ctx->initialized = TRUE; + return Curl_vquic_tls_peer_init(origin, peer, sslc, &ctx->ssl_peer); +} + +void Curl_cf_ngtcp2_ctx_cleanup(struct cf_ngtcp2_ctx *ctx) +{ + if(ctx && ctx->initialized) { + Curl_vquic_tls_cleanup(&ctx->tls); + vquic_ctx_free(&ctx->q); + Curl_bufcp_free(&ctx->stream_bufcp); + curlx_dyn_free(&ctx->scratch); + Curl_uint32_hash_destroy(&ctx->streams); + Curl_ssl_peer_cleanup(&ctx->ssl_peer); + curlx_safefree(ctx->tunnel_inbuf); + ctx->tunnel_inbuf_len = 0; + if(ctx->qlogfd != -1) { + curlx_close(ctx->qlogfd); + ctx->qlogfd = -1; + } + } +} + +static ngtcp2_conn *get_conn(ngtcp2_crypto_conn_ref *conn_ref) +{ + struct Curl_cfilter *cf = conn_ref->user_data; + struct cf_ngtcp2_ctx *ctx = cf->ctx; + return ctx->qconn; +} + +#ifdef DEBUG_NGTCP2 +static void quic_printf(void *user_data, const char *fmt, ...) +{ + va_list ap; + (void)user_data; + va_start(ap, fmt); + curl_mvfprintf(stderr, fmt, ap); + va_end(ap); + curl_mfprintf(stderr, "\n"); +} +#endif + +static void qlog_callback(void *user_data, uint32_t flags, + const void *data, size_t datalen) +{ + struct Curl_cfilter *cf = user_data; + struct cf_ngtcp2_ctx *ctx = cf->ctx; + (void)flags; + if(ctx->qlogfd != -1) { + ssize_t rc = write(ctx->qlogfd, data, datalen); + if(rc == -1) { + /* on write error, stop further write attempts */ + curlx_close(ctx->qlogfd); + ctx->qlogfd = -1; + } + } +} + +static void quic_settings(struct cf_ngtcp2_ctx *ctx, + struct Curl_easy *data, + struct cf_ngtcp2_io_ctx *pktx) +{ + ngtcp2_settings *s = &ctx->settings; + ngtcp2_transport_params *t = &ctx->transport_params; + + ngtcp2_settings_default(s); + ngtcp2_transport_params_default(t); +#ifdef DEBUG_NGTCP2 + s->log_printf = quic_printf; +#else + s->log_printf = NULL; +#endif + + s->initial_ts = pktx->ts; + s->handshake_timeout = (data->set.connecttimeout > 0) ? + data->set.connecttimeout * NGTCP2_MILLISECONDS : QUIC_HANDSHAKE_TIMEOUT; + s->max_window = H3_CONN_WINDOW_SIZE_MAX; + s->max_stream_window = 0; /* disable ngtcp2 auto-tuning of window */ + s->no_pmtud = FALSE; +#ifdef NGTCP2_SETTINGS_V3 + /* try ten times the ngtcp2 defaults here for problems with Caddy */ + s->glitch_ratelim_burst = 1000 * 10; + s->glitch_ratelim_rate = 33 * 10; +#endif + t->initial_max_data = s->max_window; + t->initial_max_stream_data_bidi_local = H3_STREAM_WINDOW_SIZE_INITIAL; + t->initial_max_stream_data_bidi_remote = H3_STREAM_WINDOW_SIZE_INITIAL; + t->initial_max_stream_data_uni = t->initial_max_data; + t->initial_max_streams_bidi = QUIC_MAX_STREAMS; + t->initial_max_streams_uni = QUIC_MAX_STREAMS; + t->max_idle_timeout = 0; /* no idle timeout from our side */ + if(ctx->qlogfd != -1) { + s->qlog_write = qlog_callback; + } +} + +#if defined(_MSC_VER) && defined(_DLL) +#pragma warning(push) +#pragma warning(disable:4232) /* MSVC extension, dllimport identity */ +#endif + +static int cb_ngtcp2_handshake_completed(ngtcp2_conn *tconn, void *user_data) +{ + struct Curl_cfilter *cf = user_data; + struct cf_ngtcp2_ctx *ctx = cf ? cf->ctx : NULL; + struct Curl_easy *data; + + (void)tconn; + DEBUGASSERT(ctx); + data = CF_DATA_CURRENT(cf); + DEBUGASSERT(data); + if(!ctx || !data) + return NGTCP2_ERR_CALLBACK_FAILURE; + + ctx->handshake_at = *Curl_pgrs_now(data); + ctx->tls_handshake_complete = TRUE; + Curl_vquic_report_handshake(&ctx->tls, cf, data); + + ctx->tls_vrfy_result = Curl_vquic_tls_verify_peer(&ctx->tls, cf, + data, &ctx->ssl_peer); + if(ctx->tls_vrfy_result) + return NGTCP2_ERR_CALLBACK_FAILURE; + +#ifdef CURLVERBOSE + if(Curl_trc_is_verbose(data)) { + const ngtcp2_transport_params *rp; + rp = ngtcp2_conn_get_remote_transport_params(ctx->qconn); + CURL_TRC_CF(data, cf, "handshake complete after %" FMT_TIMEDIFF_T + "ms, remote transport[max_udp_payload=%" PRIu64 + ", initial_max_data=%" PRIu64 "]", + curlx_ptimediff_ms(&ctx->handshake_at, &ctx->started_at), + rp->max_udp_payload_size, rp->initial_max_data); + } +#endif + + /* In case of earlydata, where we simulate being connected, update + * the handshake time when we really did connect */ + if(ctx->use_earlydata) + Curl_pgrsTimeWas(data, TIMER_APPCONNECT, ctx->handshake_at); + if(ctx->use_earlydata) { +#if defined(USE_OPENSSL) && defined(HAVE_OPENSSL_EARLYDATA) + ctx->earlydata_accepted = + (SSL_get_early_data_status(ctx->tls.ossl.ssl) != + SSL_EARLY_DATA_REJECTED); +#endif +#ifdef USE_GNUTLS + int flags = gnutls_session_get_flags(ctx->tls.gtls.session); + ctx->earlydata_accepted = !!(flags & GNUTLS_SFLAGS_EARLY_DATA); +#endif +#ifdef USE_WOLFSSL +#ifdef WOLFSSL_EARLY_DATA + ctx->earlydata_accepted = + (wolfSSL_get_early_data_status(ctx->tls.wssl.ssl) != + WOLFSSL_EARLY_DATA_REJECTED); +#else + DEBUGASSERT(0); /* should not come here if ED is disabled. */ + ctx->earlydata_accepted = FALSE; +#endif /* WOLFSSL_EARLY_DATA */ +#endif + CURL_TRC_CF(data, cf, "server did%s accept %zu bytes of early data", + ctx->earlydata_accepted ? "" : " not", ctx->earlydata_skip); + Curl_pgrsEarlyData(data, ctx->earlydata_accepted ? + (curl_off_t)ctx->earlydata_skip : + -(curl_off_t)ctx->earlydata_skip); + } + return 0; +} + +static int cb_recv_stream_data(ngtcp2_conn *tconn, uint32_t flags, + int64_t stream_id, uint64_t offset, + const uint8_t *buf, size_t buflen, + void *user_data, void *stream_user_data) +{ + struct Curl_cfilter *cf = user_data; + struct cf_ngtcp2_ctx *ctx = cf->ctx; + nghttp3_ssize rc; + uint64_t nconsumed; + int fin = (flags & NGTCP2_STREAM_DATA_FLAG_FIN) ? 1 : 0; + struct Curl_easy *data = stream_user_data; + struct h3_stream_ctx *stream = H3_STREAM_CTX(ctx, data); + (void)offset; + + rc = nghttp3_conn_read_stream(ctx->h3conn, stream_id, buf, buflen, fin); + if(rc < 0) { + if(data && stream) { + CURL_TRC_CF(data, cf, "[%" PRId64 "] error on known stream, " + "reset=%d, closed=%d", + stream_id, stream->reset, stream->closed); + } + return NGTCP2_ERR_CALLBACK_FAILURE; + } + nconsumed = (uint64_t)rc; + if(nconsumed) { + /* number of bytes inside buflen which consists of framing overhead + * including QPACK HEADERS. In other words, it does not consume payload of + * DATA frame. */ + ngtcp2_conn_extend_max_stream_offset(tconn, stream_id, nconsumed); + ngtcp2_conn_extend_max_offset(tconn, nconsumed); + if(stream) { + stream->rx_offset += nconsumed; + stream->rx_offset_max += nconsumed; + } + } + return 0; +} + +static int cb_acked_stream_data_offset(ngtcp2_conn *tconn, int64_t stream_id, + uint64_t offset, uint64_t datalen, + void *user_data, void *stream_user_data) +{ + struct Curl_cfilter *cf = user_data; + struct cf_ngtcp2_ctx *ctx = cf->ctx; + int rv; + (void)stream_id; + (void)tconn; + (void)offset; + (void)datalen; + (void)stream_user_data; + + rv = nghttp3_conn_add_ack_offset(ctx->h3conn, stream_id, datalen); + if(rv && rv != NGHTTP3_ERR_STREAM_NOT_FOUND) { + return NGTCP2_ERR_CALLBACK_FAILURE; + } + + return 0; +} + +static int cb_stream_close(ngtcp2_conn *tconn, uint32_t flags, + int64_t stream_id, uint64_t app_error_code, + void *user_data, void *stream_user_data) +{ + struct Curl_cfilter *cf = user_data; + struct cf_ngtcp2_ctx *ctx = cf->ctx; + struct Curl_easy *data = stream_user_data; + int rv; + + (void)tconn; + /* stream is closed... */ + if(!data) + data = CF_DATA_CURRENT(cf); + if(!data) + return NGTCP2_ERR_CALLBACK_FAILURE; + + if(!(flags & NGTCP2_STREAM_CLOSE_FLAG_APP_ERROR_CODE_SET)) { + app_error_code = NGHTTP3_H3_NO_ERROR; + } + + rv = nghttp3_conn_close_stream(ctx->h3conn, stream_id, app_error_code); + CURL_TRC_CF(data, cf, "[%" PRId64 "] quic close(app_error=%" + PRIu64 ") -> %d", stream_id, app_error_code, rv); + if(rv && rv != NGHTTP3_ERR_STREAM_NOT_FOUND) { + Curl_cf_ngtcp2_h3_err_set(cf, data, rv); + return NGTCP2_ERR_CALLBACK_FAILURE; + } + + return 0; +} + +static int cb_stream_reset(ngtcp2_conn *tconn, int64_t stream_id, + uint64_t final_size, uint64_t app_error_code, + void *user_data, void *stream_user_data) +{ + struct Curl_cfilter *cf = user_data; + struct cf_ngtcp2_ctx *ctx = cf->ctx; + struct Curl_easy *data = stream_user_data; + int rv; + (void)tconn; + (void)final_size; + (void)app_error_code; + + rv = nghttp3_conn_shutdown_stream_read(ctx->h3conn, stream_id); + CURL_TRC_CF(data, cf, "[%" PRId64 "] reset -> %d", stream_id, rv); + if(rv && rv != NGHTTP3_ERR_STREAM_NOT_FOUND) { + return NGTCP2_ERR_CALLBACK_FAILURE; + } + + return 0; +} + +static int cb_stream_stop_sending(ngtcp2_conn *tconn, int64_t stream_id, + uint64_t app_error_code, void *user_data, + void *stream_user_data) +{ + struct Curl_cfilter *cf = user_data; + struct cf_ngtcp2_ctx *ctx = cf->ctx; + int rv; + (void)tconn; + (void)app_error_code; + (void)stream_user_data; + + rv = nghttp3_conn_shutdown_stream_read(ctx->h3conn, stream_id); + if(rv && rv != NGHTTP3_ERR_STREAM_NOT_FOUND) { + return NGTCP2_ERR_CALLBACK_FAILURE; + } + + return 0; +} + +static int cb_extend_max_local_streams_bidi(ngtcp2_conn *tconn, + uint64_t max_streams, + void *user_data) +{ + struct Curl_cfilter *cf = user_data; + struct cf_ngtcp2_ctx *ctx = cf->ctx; + struct Curl_easy *data = CF_DATA_CURRENT(cf); + + (void)tconn; + ctx->max_bidi_streams = max_streams; + if(data) + CURL_TRC_CF(data, cf, "max bidi streams now %" PRIu64 ", used %" PRIu64, + ctx->max_bidi_streams, ctx->used_bidi_streams); + return 0; +} + +static int cb_extend_max_stream_data(ngtcp2_conn *tconn, int64_t stream_id, + uint64_t max_data, void *user_data, + void *stream_user_data) +{ + struct Curl_cfilter *cf = user_data; + struct cf_ngtcp2_ctx *ctx = cf->ctx; + struct Curl_easy *s_data = stream_user_data; + struct h3_stream_ctx *stream; + int rv; + (void)tconn; + (void)max_data; + + rv = nghttp3_conn_unblock_stream(ctx->h3conn, stream_id); + if(rv && rv != NGHTTP3_ERR_STREAM_NOT_FOUND) { + return NGTCP2_ERR_CALLBACK_FAILURE; + } + stream = H3_STREAM_CTX(ctx, s_data); + if(stream && stream->quic_flow_blocked) { + CURL_TRC_CF(s_data, cf, "[%" PRId64 "] unblock quic flow", stream_id); + stream->quic_flow_blocked = FALSE; + Curl_multi_mark_dirty(s_data); + } + return 0; +} + +static void cb_rand(uint8_t *dest, size_t destlen, + const ngtcp2_rand_ctx *rand_ctx) +{ + CURLcode result; + (void)rand_ctx; + + result = Curl_rand(NULL, dest, destlen); + if(result) { + /* cb_rand is only used for non-cryptographic context. If Curl_rand + failed, fill 0 and call it *random*. */ + memset(dest, 0, destlen); + } +} + +/* for ngtcp2 data, cidlen); + if(result) + return NGTCP2_ERR_CALLBACK_FAILURE; + cid->datalen = cidlen; + + result = Curl_rand(NULL, token, NGTCP2_STATELESS_RESET_TOKENLEN); + if(result) + return NGTCP2_ERR_CALLBACK_FAILURE; + + return 0; +} + +#ifdef NGTCP2_CALLBACKS_V3 /* ngtcp2 v1.22.0+ */ +static int cb_get_new_connection_id2( + ngtcp2_conn *tconn, ngtcp2_cid *cid, + struct ngtcp2_stateless_reset_token *token, size_t cidlen, void *user_data) +{ + CURLcode result; + (void)tconn; + (void)user_data; + + result = Curl_rand(NULL, cid->data, cidlen); + if(result) + return NGTCP2_ERR_CALLBACK_FAILURE; + cid->datalen = cidlen; + + result = Curl_rand(NULL, token->data, sizeof(token->data)); + if(result) + return NGTCP2_ERR_CALLBACK_FAILURE; + + return 0; +} +#endif + +static int cb_recv_rx_key(ngtcp2_conn *tconn, ngtcp2_encryption_level level, + void *user_data) +{ + struct Curl_cfilter *cf = user_data; + struct cf_ngtcp2_ctx *ctx = cf ? cf->ctx : NULL; + struct Curl_easy *data = CF_DATA_CURRENT(cf); + (void)tconn; + + if(level != NGTCP2_ENCRYPTION_LEVEL_1RTT) + return 0; + + DEBUGASSERT(ctx); + DEBUGASSERT(data); + if(ctx && data && !ctx->h3conn && ctx->init_h3_conn_cb) { + if(ctx->init_h3_conn_cb(cf, data, ctx)) + return NGTCP2_ERR_CALLBACK_FAILURE; + } + return 0; +} + +static ngtcp2_callbacks ng_callbacks = { + ngtcp2_crypto_client_initial_cb, + NULL, /* recv_client_initial */ + ngtcp2_crypto_recv_crypto_data_cb, + cb_ngtcp2_handshake_completed, + NULL, /* recv_version_negotiation */ + ngtcp2_crypto_encrypt_cb, + ngtcp2_crypto_decrypt_cb, + ngtcp2_crypto_hp_mask_cb, + cb_recv_stream_data, + cb_acked_stream_data_offset, + NULL, /* stream_open */ + cb_stream_close, + NULL, /* recv_stateless_reset */ + ngtcp2_crypto_recv_retry_cb, + cb_extend_max_local_streams_bidi, + NULL, /* extend_max_local_streams_uni */ + cb_rand, + cb_get_new_connection_id, /* for ngtcp2 user_data : NULL; + ctx = cf ? cf->ctx : NULL; + data = cf ? CF_DATA_CURRENT(cf) : NULL; + if(cf && data && ctx) { + unsigned char *quic_tp = NULL; + size_t quic_tp_len = 0; +#ifdef HAVE_OPENSSL_EARLYDATA + ngtcp2_ssize tplen; + uint8_t tpbuf[256]; + + tplen = ngtcp2_conn_encode_0rtt_transport_params(ctx->qconn, tpbuf, + sizeof(tpbuf)); + if(tplen < 0) + CURL_TRC_CF(data, cf, "error encoding 0RTT transport data: %s", + ngtcp2_strerror((int)tplen)); + else { + quic_tp = (unsigned char *)tpbuf; + quic_tp_len = (size_t)tplen; + } +#endif + Curl_ossl_add_session(cf, data, ctx->ssl_peer.scache_key, ssl_sessionid, + SSL_version(ssl), "h3", quic_tp, quic_tp_len); + } + return 0; +} +#endif /* USE_OPENSSL */ + +#ifdef USE_GNUTLS + +#ifdef CURLVERBOSE +static const char *gtls_hs_msg_name(int mtype) +{ + switch(mtype) { + case 1: + return "ClientHello"; + case 2: + return "ServerHello"; + case 4: + return "SessionTicket"; + case 8: + return "EncryptedExtensions"; + case 11: + return "Certificate"; + case 13: + return "CertificateRequest"; + case 15: + return "CertificateVerify"; + case 20: + return "Finished"; + case 24: + return "KeyUpdate"; + case 254: + return "MessageHash"; + } + return "Unknown"; +} +#endif + +static int quic_gtls_handshake_cb(gnutls_session_t session, unsigned int htype, + unsigned when, unsigned int incoming, + const gnutls_datum_t *msg) +{ + ngtcp2_crypto_conn_ref *conn_ref = gnutls_session_get_ptr(session); + struct Curl_cfilter *cf = conn_ref ? conn_ref->user_data : NULL; + struct cf_ngtcp2_ctx *ctx = cf ? cf->ctx : NULL; + + (void)msg; + (void)incoming; + if(when && cf && ctx) { /* after message has been processed */ + struct Curl_easy *data = CF_DATA_CURRENT(cf); + DEBUGASSERT(data); + if(!data) + return 0; + CURL_TRC_CF(data, cf, "SSL message: %s %s [%u]", + incoming ? "<-" : "->", gtls_hs_msg_name(htype), htype); + switch(htype) { + case GNUTLS_HANDSHAKE_NEW_SESSION_TICKET: { + ngtcp2_ssize tplen; + uint8_t tpbuf[256]; + unsigned char *quic_tp = NULL; + size_t quic_tp_len = 0; + + tplen = ngtcp2_conn_encode_0rtt_transport_params(ctx->qconn, tpbuf, + sizeof(tpbuf)); + if(tplen < 0) + CURL_TRC_CF(data, cf, "error encoding 0RTT transport data: %s", + ngtcp2_strerror((int)tplen)); + else { + quic_tp = (unsigned char *)tpbuf; + quic_tp_len = (size_t)tplen; + } + (void)Curl_gtls_cache_session(cf, data, ctx->ssl_peer.scache_key, + session, 0, "h3", quic_tp, quic_tp_len); + break; + } + default: + break; + } + } + return 0; +} +#endif /* USE_GNUTLS */ + +#ifdef USE_WOLFSSL +static int wssl_quic_new_session_cb(WOLFSSL *ssl, WOLFSSL_SESSION *session) +{ + ngtcp2_crypto_conn_ref *conn_ref = wolfSSL_get_app_data(ssl); + struct Curl_cfilter *cf = conn_ref ? conn_ref->user_data : NULL; + + DEBUGASSERT(cf); + if(cf && session) { + struct cf_ngtcp2_ctx *ctx = cf->ctx; + struct Curl_easy *data = CF_DATA_CURRENT(cf); + DEBUGASSERT(data); + if(data && ctx) { + ngtcp2_ssize tplen; + uint8_t tpbuf[256]; + unsigned char *quic_tp = NULL; + size_t quic_tp_len = 0; + + tplen = ngtcp2_conn_encode_0rtt_transport_params(ctx->qconn, tpbuf, + sizeof(tpbuf)); + if(tplen < 0) + CURL_TRC_CF(data, cf, "error encoding 0RTT transport data: %s", + ngtcp2_strerror((int)tplen)); + else { + quic_tp = (unsigned char *)tpbuf; + quic_tp_len = (size_t)tplen; + } + (void)Curl_wssl_cache_session(cf, data, ctx->ssl_peer.scache_key, + session, wolfSSL_version(ssl), + "h3", quic_tp, quic_tp_len); + } + } + return 0; +} +#endif /* USE_WOLFSSL */ + +static CURLcode cf_ngtcp2_tls_ctx_setup(struct Curl_cfilter *cf, + struct Curl_easy *data, + void *user_data) +{ + struct curl_tls_ctx *ctx = user_data; + +#ifdef USE_OPENSSL +#if defined(OPENSSL_IS_AWSLC) || defined(OPENSSL_IS_BORINGSSL) + if(ngtcp2_crypto_boringssl_configure_client_context(ctx->ossl.ssl_ctx) + != 0) { + failf(data, "ngtcp2_crypto_boringssl_configure_client_context failed"); + return CURLE_FAILED_INIT; + } +#elif defined(OPENSSL_QUIC_API2) + /* nothing to do */ +#else + if(ngtcp2_crypto_quictls_configure_client_context(ctx->ossl.ssl_ctx) != 0) { + failf(data, "ngtcp2_crypto_quictls_configure_client_context failed"); + return CURLE_FAILED_INIT; + } +#endif /* !OPENSSL_IS_AWSLC && !OPENSSL_IS_BORINGSSL */ + if(Curl_ssl_scache_use(cf, data)) { + /* Enable the session cache because it is a prerequisite for the + * "new session" callback. Use the "external storage" mode to prevent + * OpenSSL from creating an internal session cache. + */ + SSL_CTX_set_session_cache_mode(ctx->ossl.ssl_ctx, + SSL_SESS_CACHE_CLIENT | + SSL_SESS_CACHE_NO_INTERNAL); + SSL_CTX_sess_set_new_cb(ctx->ossl.ssl_ctx, quic_ossl_new_session_cb); + } + +#elif defined(USE_GNUTLS) + if(ngtcp2_crypto_gnutls_configure_client_session(ctx->gtls.session) != 0) { + failf(data, "ngtcp2_crypto_gnutls_configure_client_session failed"); + return CURLE_FAILED_INIT; + } + if(Curl_ssl_scache_use(cf, data)) { + gnutls_handshake_set_hook_function(ctx->gtls.session, + GNUTLS_HANDSHAKE_ANY, GNUTLS_HOOK_POST, + quic_gtls_handshake_cb); + } + +#elif defined(USE_WOLFSSL) + if(ngtcp2_crypto_wolfssl_configure_client_context(ctx->wssl.ssl_ctx) != 0) { + failf(data, "ngtcp2_crypto_wolfssl_configure_client_context failed"); + return CURLE_FAILED_INIT; + } + if(Curl_ssl_scache_use(cf, data)) { + /* Register to get notified when a new session is received */ + wolfSSL_CTX_sess_set_new_cb(ctx->wssl.ssl_ctx, wssl_quic_new_session_cb); + } +#endif + return CURLE_OK; +} + +static CURLcode cf_ngtcp2_on_session_reuse(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct alpn_spec *alpns, + struct Curl_ssl_session *scs, + bool *do_early_data) +{ + struct cf_ngtcp2_ctx *ctx = cf->ctx; + CURLcode result = CURLE_OK; + + *do_early_data = FALSE; +#if defined(USE_OPENSSL) && defined(HAVE_OPENSSL_EARLYDATA) + ctx->earlydata_max = scs->earlydata_max; +#endif +#ifdef USE_GNUTLS + ctx->earlydata_max = + gnutls_record_get_max_early_data_size(ctx->tls.gtls.session); +#endif +#ifdef USE_WOLFSSL +#ifdef WOLFSSL_EARLY_DATA + ctx->earlydata_max = scs->earlydata_max; +#else + ctx->earlydata_max = 0; +#endif /* WOLFSSL_EARLY_DATA */ +#endif +#if defined(USE_GNUTLS) || defined(USE_WOLFSSL) || \ + (defined(USE_OPENSSL) && defined(HAVE_OPENSSL_EARLYDATA)) + if(!ctx->earlydata_max) { + CURL_TRC_CF(data, cf, "SSL session does not allow earlydata"); + } + else if(!Curl_alpn_contains_proto(alpns, scs->alpn)) { + CURL_TRC_CF(data, cf, "SSL session from different ALPN, no early data"); + } + else if(!scs->quic_tp || !scs->quic_tp_len) { + CURL_TRC_CF(data, cf, "no 0RTT transport parameters, no early data"); + } + else { + int rv; + rv = ngtcp2_conn_decode_and_set_0rtt_transport_params( + ctx->qconn, (const uint8_t *)scs->quic_tp, scs->quic_tp_len); + if(rv) + CURL_TRC_CF(data, cf, "no early data, failed to set 0RTT transport " + "parameters: %s", ngtcp2_strerror(rv)); + else if(ctx->init_h3_conn_cb) { + infof(data, "SSL session allows %zu bytes of early data, " + "reusing ALPN '%s'", ctx->earlydata_max, scs->alpn); + result = ctx->init_h3_conn_cb(cf, data, ctx); + if(!result) { + ctx->use_earlydata = TRUE; + cf->connected = TRUE; + *do_early_data = TRUE; + } + } + else { /* h3_conn_init set, assume done */ + ctx->use_earlydata = TRUE; + cf->connected = TRUE; + *do_early_data = TRUE; + } + } +#else /* not supported in the TLS backend */ + (void)data; + (void)ctx; + (void)scs; + (void)alpns; +#endif + return result; +} + +/* + * Might be called twice for happy eyeballs. + */ +static CURLcode cf_connect_start(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct cf_ngtcp2_io_ctx *pktx) +{ + struct cf_ngtcp2_ctx *ctx = cf->ctx; + int rc; + int rv; + CURLcode result; + const struct Curl_sockaddr_ex *sockaddr = NULL; + int qfd; + static const struct alpn_spec ALPN_SPEC_H3 = { { "h3", "h3-29" }, 2 }; + + DEBUGASSERT(ctx->initialized); + ctx->dcid.datalen = NGTCP2_MAX_CIDLEN; + result = Curl_rand(data, ctx->dcid.data, NGTCP2_MAX_CIDLEN); + if(result) + return result; + + ctx->scid.datalen = NGTCP2_MAX_CIDLEN; + result = Curl_rand(data, ctx->scid.data, NGTCP2_MAX_CIDLEN); + if(result) + return result; + + (void)Curl_qlogdir(data, ctx->scid.data, NGTCP2_MAX_CIDLEN, &qfd); + ctx->qlogfd = qfd; /* -1 if failure above */ + quic_settings(ctx, data, pktx); + + result = vquic_ctx_init(data, &ctx->q); + if(result) + return result; + + /* Query socket and remote address from sub-chain */ + if(Curl_cf_socket_peek(cf->next, data, &ctx->q.sockfd, &sockaddr, NULL)) { + /* No direct socket - must be tunneled QUIC (CONNECT-UDP through proxy) */ + ctx->q.sockfd = CURL_SOCKET_BAD; + } + + if(ctx->q.sockfd != CURL_SOCKET_BAD) { + /* Direct UDP socket - get local address for ngtcp2 */ + ctx->q.local_addrlen = sizeof(ctx->q.local_addr); + rv = getsockname(ctx->q.sockfd, (struct sockaddr *)&ctx->q.local_addr, + &ctx->q.local_addrlen); + if(rv == -1) + return CURLE_QUIC_CONNECT_ERROR; + + ngtcp2_addr_init(&ctx->connected_path.local, + (struct sockaddr *)&ctx->q.local_addr, + ctx->q.local_addrlen); + ngtcp2_addr_init(&ctx->connected_path.remote, + &sockaddr->curl_sa_addr, (socklen_t)sockaddr->addrlen); + + rc = ngtcp2_conn_client_new(&ctx->qconn, &ctx->dcid, &ctx->scid, + &ctx->connected_path, + NGTCP2_PROTO_VER_V1, &ng_callbacks, + &ctx->settings, &ctx->transport_params, + Curl_ngtcp2_mem(), cf); + if(rc) + return CURLE_QUIC_CONNECT_ERROR; + + ctx->conn_ref.get_conn = get_conn; + ctx->conn_ref.user_data = cf; + } + else { + /* Tunneled QUIC (e.g. CONNECT-UDP): get remote address + from the connected filter below */ + const struct Curl_sockaddr_ex *remote = NULL; + if(cf->next->cft->query(cf->next, data, CF_QUERY_REMOTE_ADDR, NULL, + CURL_UNCONST(&remote))) + return CURLE_QUIC_CONNECT_ERROR; + if(!remote) + return CURLE_QUIC_CONNECT_ERROR; + + memset(&ctx->q.local_addr, 0, sizeof(ctx->q.local_addr)); + switch(remote->family) { + case AF_INET: + ((struct sockaddr_in *)&ctx->q.local_addr)->sin_family = AF_INET; + ctx->q.local_addrlen = sizeof(struct sockaddr_in); + break; +#ifdef USE_IPV6 + case AF_INET6: + ((struct sockaddr_in6 *)&ctx->q.local_addr)->sin6_family = AF_INET6; + ctx->q.local_addrlen = sizeof(struct sockaddr_in6); + break; +#endif + default: + return CURLE_QUIC_CONNECT_ERROR; + } + + ngtcp2_addr_init(&ctx->connected_path.local, + (struct sockaddr *)&ctx->q.local_addr, + ctx->q.local_addrlen); + ngtcp2_addr_init(&ctx->connected_path.remote, + &remote->curl_sa_addr, + (socklen_t)remote->addrlen); + + rc = ngtcp2_conn_client_new(&ctx->qconn, &ctx->dcid, &ctx->scid, + &ctx->connected_path, + NGTCP2_PROTO_VER_V1, &ng_callbacks, + &ctx->settings, &ctx->transport_params, + Curl_ngtcp2_mem(), cf); + if(rc) + return CURLE_QUIC_CONNECT_ERROR; + + ctx->conn_ref.get_conn = get_conn; + ctx->conn_ref.user_data = cf; + } + + result = Curl_vquic_tls_init(&ctx->tls, cf, data, + &ctx->ssl_peer, &ALPN_SPEC_H3, + cf_ngtcp2_tls_ctx_setup, &ctx->tls, + &ctx->conn_ref, + cf_ngtcp2_on_session_reuse); + if(result) + return result; + +#if defined(USE_OPENSSL) && defined(OPENSSL_QUIC_API2) + if(ngtcp2_crypto_ossl_ctx_new(&ctx->ossl_ctx, ctx->tls.ossl.ssl) != 0) { + failf(data, "ngtcp2_crypto_ossl_ctx_new failed"); + return CURLE_FAILED_INIT; + } + ngtcp2_conn_set_tls_native_handle(ctx->qconn, ctx->ossl_ctx); + if(ngtcp2_crypto_ossl_configure_client_session(ctx->tls.ossl.ssl) != 0) { + failf(data, "ngtcp2_crypto_ossl_configure_client_session failed"); + return CURLE_FAILED_INIT; + } +#elif defined(USE_OPENSSL) + SSL_set_quic_use_legacy_codepoint(ctx->tls.ossl.ssl, 0); + ngtcp2_conn_set_tls_native_handle(ctx->qconn, ctx->tls.ossl.ssl); +#elif defined(USE_GNUTLS) + ngtcp2_conn_set_tls_native_handle(ctx->qconn, ctx->tls.gtls.session); +#elif defined(USE_WOLFSSL) + ngtcp2_conn_set_tls_native_handle(ctx->qconn, ctx->tls.wssl.ssl); +#else +#error "ngtcp2 TLS backend not defined" +#endif + + ngtcp2_ccerr_default(&ctx->last_error); + + return CURLE_OK; +} + +CURLcode Curl_cf_ngtcp2_cmn_connect(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ + struct cf_ngtcp2_ctx *ctx = cf->ctx; + CURLcode result = CURLE_OK; + struct cf_call_data save; + struct cf_ngtcp2_io_ctx pktx; + + if(cf->connected) { + *done = TRUE; + return CURLE_OK; + } + + /* Connect the sub-chain */ + if(cf->next && !cf->next->connected) { + result = Curl_conn_cf_connect(cf->next, data, done); + if(result || !*done) + return result; + } + + *done = FALSE; + + if(cf_ngtcp2_need_httpsrr(data) && + !Curl_conn_dns_resolved_https(data, cf->sockindex, ctx->ssl_peer.peer)) { + CURL_TRC_CF(data, cf, "need HTTPS-RR, delaying connect"); + return CURLE_OK; + } + + Curl_cf_ngtcp2_io_ctx_init(&pktx, cf, data); + CF_DATA_SAVE(save, cf, data); + + if(!ctx->qconn) { + ctx->started_at = *Curl_pgrs_now(data); + result = cf_connect_start(cf, data, &pktx); + if(result) + goto out; + if(cf->connected) { + *done = TRUE; + goto out; + } + result = Curl_cf_ngtcp2_progress_egress(cf, data, &pktx); + /* we do not expect to be able to recv anything yet */ + goto out; + } + + result = Curl_cf_ngtcp2_progress_ingress(cf, data, &pktx); + if(result) + goto out; + + result = Curl_cf_ngtcp2_progress_egress(cf, data, &pktx); + if(result) + goto out; + + if(ngtcp2_conn_get_handshake_completed(ctx->qconn)) { + result = ctx->tls_vrfy_result; + if(!result) { + CURL_TRC_CF(data, cf, "peer verified"); + cf->connected = TRUE; + *done = TRUE; + } + } + +out: + if(ctx->tls_vrfy_result) + result = ctx->tls_vrfy_result; + if(ctx->qconn && + ((result == CURLE_RECV_ERROR) || (result == CURLE_SEND_ERROR)) && + ngtcp2_conn_in_draining_period(ctx->qconn)) { + const ngtcp2_ccerr *cerr = ngtcp2_conn_get_ccerr(ctx->qconn); + + result = CURLE_COULDNT_CONNECT; + if(cerr) { + CURL_TRC_CF(data, cf, "connect error, type=%d, code=%" PRIu64, + (int)cerr->type, cerr->error_code); + switch(cerr->type) { + case NGTCP2_CCERR_TYPE_VERSION_NEGOTIATION: + CURL_TRC_CF(data, cf, "error in version negotiation"); + break; + default: + if(cerr->error_code >= NGTCP2_CRYPTO_ERROR) { + CURL_TRC_CF(data, cf, "crypto error, tls alert=%u", + (unsigned int)(cerr->error_code & 0xffU)); + } + else if(cerr->error_code == NGTCP2_CONNECTION_REFUSED) { + CURL_TRC_CF(data, cf, "connection refused by server"); + /* When a QUIC server instance is shutting down, it may send us a + * CONNECTION_CLOSE with this code right away. We want + * to keep on trying in this case. */ + result = CURLE_WEIRD_SERVER_REPLY; + } + } + } + } + +#ifdef CURLVERBOSE + if(result) { + if(ctx->q.sockfd != CURL_SOCKET_BAD) { + /* Direct UDP socket - get IP info for error reporting */ + struct ip_quadruple ip; + + if(!Curl_cf_socket_peek(cf->next, data, NULL, NULL, &ip)) + infof(data, "QUIC connect to %s port %u failed: %s", + ip.remote_ip, ip.remote_port, curl_easy_strerror(result)); + } + } +#endif + if(!result && ctx->qconn) { + result = Curl_cf_ngtcp2_cmn_set_expiry(cf, data, &pktx); + } + if(result || *done) + CURL_TRC_CF(data, cf, "connect -> %d, done=%d", (int)result, *done); + CF_DATA_RESTORE(cf, save); + return result; +} + +CURLcode Curl_cf_ngtcp2_cmn_shutdown(struct Curl_cfilter *cf, + struct Curl_easy *data, bool *done) +{ + struct cf_ngtcp2_ctx *ctx = cf->ctx; + struct cf_call_data save; + struct cf_ngtcp2_io_ctx pktx; + CURLcode result = CURLE_OK; + + if(cf->shutdown || !ctx->qconn) { + *done = TRUE; + return CURLE_OK; + } + + if(!cf->next) { + Curl_bufq_reset(&ctx->q.sendbuf); + *done = TRUE; + return CURLE_OK; + } + + CF_DATA_SAVE(save, cf, data); + *done = FALSE; + Curl_cf_ngtcp2_io_ctx_init(&pktx, cf, data); + + if(!ctx->shutdown_started) { + char buffer[NGTCP2_MAX_UDP_PAYLOAD_SIZE]; + ngtcp2_ssize nwritten; + + if(!Curl_bufq_is_empty(&ctx->q.sendbuf)) { + CURL_TRC_CF(data, cf, "shutdown, flushing sendbuf"); + result = Curl_cf_ngtcp2_progress_egress(cf, data, &pktx); + if(!Curl_bufq_is_empty(&ctx->q.sendbuf)) { + CURL_TRC_CF(data, cf, "sending shutdown packets blocked"); + result = CURLE_OK; + goto out; + } + else if(result) { + CURL_TRC_CF(data, cf, "shutdown, error %d flushing sendbuf", + (int)result); + *done = TRUE; + goto out; + } + } + + DEBUGASSERT(Curl_bufq_is_empty(&ctx->q.sendbuf)); + ctx->shutdown_started = TRUE; + nwritten = ngtcp2_conn_write_connection_close( + ctx->qconn, NULL, /* path */ + NULL, /* pkt_info */ + (uint8_t *)buffer, sizeof(buffer), + &ctx->last_error, pktx.ts); + CURL_TRC_CF(data, cf, "start shutdown(err_type=%d, err_code=%" + PRIu64 ") -> %zd", (int)ctx->last_error.type, + ctx->last_error.error_code, (ssize_t)nwritten); + /* there are cases listed in ngtcp2 documentation where this call + * may fail. Since we are doing a connection shutdown as graceful + * as we can, such an error is ignored here. */ + if(nwritten > 0) { + /* Ignore amount written. sendbuf was empty and has always room for + * NGTCP2_MAX_UDP_PAYLOAD_SIZE. It can only completely fail, in which + * case `result` is set non zero. */ + size_t n; + result = Curl_bufq_write(&ctx->q.sendbuf, (const unsigned char *)buffer, + (size_t)nwritten, &n); + if(result) { + CURL_TRC_CF(data, cf, "error %d adding shutdown packets to sendbuf, " + "aborting shutdown", (int)result); + goto out; + } + + ctx->q.no_gso = TRUE; + ctx->q.gsolen = (size_t)nwritten; + ctx->q.split_len = 0; + } + } + + if(!Curl_bufq_is_empty(&ctx->q.sendbuf)) { + CURL_TRC_CF(data, cf, "shutdown, flushing egress"); + result = vquic_flush(cf, data, &ctx->q); + if(result == CURLE_AGAIN) { + CURL_TRC_CF(data, cf, "sending shutdown packets blocked"); + result = CURLE_OK; + goto out; + } + else if(result) { + CURL_TRC_CF(data, cf, "shutdown, error %d flushing sendbuf", + (int)result); + *done = TRUE; + goto out; + } + } + + if(Curl_bufq_is_empty(&ctx->q.sendbuf)) { + /* Sent everything off. ngtcp2 seems to have no support for graceful + * shutdowns. We are done. */ + CURL_TRC_CF(data, cf, "shutdown completely sent off, done"); + *done = TRUE; + result = CURLE_OK; + } +out: + CF_DATA_RESTORE(cf, save); + return result; +} + +void Curl_cf_ngtcp2_cmn_conn_close(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + bool done; + Curl_cf_ngtcp2_cmn_shutdown(cf, data, &done); +} + +static bool cf_ngtcp2_err_is_fatal(int code) +{ + return (NGTCP2_ERR_FATAL >= code) || + (NGTCP2_ERR_DROP_CONN == code) || + (NGTCP2_ERR_IDLE_CLOSE == code); +} + +void Curl_cf_ngtcp2_cmn_err_set(struct Curl_cfilter *cf, + struct Curl_easy *data, int code) +{ + struct cf_ngtcp2_ctx *ctx = cf->ctx; + if(!ctx->last_error.error_code) { + if(NGTCP2_ERR_CRYPTO == code) { + ngtcp2_ccerr_set_tls_alert(&ctx->last_error, + ngtcp2_conn_get_tls_alert(ctx->qconn), + NULL, 0); + } + else { + ngtcp2_ccerr_set_liberr(&ctx->last_error, code, NULL, 0); + } + } + if(cf_ngtcp2_err_is_fatal(code)) + Curl_cf_ngtcp2_cmn_conn_close(cf, data); +} + +void Curl_cf_ngtcp2_io_ctx_init(struct cf_ngtcp2_io_ctx *io_ctx, + struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_ngtcp2_ctx *ctx = cf->ctx; + const struct curltime *pnow = Curl_pgrs_now(data); + + io_ctx->cf = cf; + io_ctx->data = data; + ngtcp2_path_storage_zero(&io_ctx->ps); + vquic_ctx_set_time(&ctx->q, pnow); + io_ctx->ts = ((ngtcp2_tstamp)pnow->tv_sec * NGTCP2_SECONDS) + + ((ngtcp2_tstamp)pnow->tv_usec * NGTCP2_MICROSECONDS); +} + +void Curl_cf_ngtcp2_io_ctx_update_time(struct Curl_easy *data, + struct cf_ngtcp2_io_ctx *pktx, + struct Curl_cfilter *cf) +{ + struct cf_ngtcp2_ctx *ctx = cf->ctx; + const struct curltime *pnow = Curl_pgrs_now(data); + + vquic_ctx_update_time(&ctx->q, pnow); + pktx->ts = ((ngtcp2_tstamp)pnow->tv_sec * NGTCP2_SECONDS) + + ((ngtcp2_tstamp)pnow->tv_usec * NGTCP2_MICROSECONDS); +} + +#if NGTCP2_VERSION_NUM < 0x011100 +struct cf_ngtcp2_sfind_ctx { + int64_t stream_id; + struct h3_stream_ctx *stream; + uint32_t mid; +}; + +static bool cf_ngtcp2_sfind(uint32_t mid, void *value, void *user_data) +{ + struct cf_ngtcp2_sfind_ctx *fctx = user_data; + struct h3_stream_ctx *stream = value; + + if(fctx->stream_id == stream->id) { + fctx->mid = mid; + fctx->stream = stream; + return FALSE; + } + return TRUE; /* continue */ +} + +static struct h3_stream_ctx *cf_ngtcp2_get_stream(struct cf_ngtcp2_ctx *ctx, + int64_t stream_id) +{ + struct cf_ngtcp2_sfind_ctx fctx; + fctx.stream_id = stream_id; + fctx.stream = NULL; + Curl_uint32_hash_visit(&ctx->streams, cf_ngtcp2_sfind, &fctx); + return fctx.stream; +} +#else +static struct h3_stream_ctx *cf_ngtcp2_get_stream(struct cf_ngtcp2_ctx *ctx, + int64_t stream_id) +{ + struct Curl_easy *data = + ngtcp2_conn_get_stream_user_data(ctx->qconn, stream_id); + + if(!data) { + return NULL; + } + + return H3_STREAM_CTX(ctx, data); +} +#endif + +/** + * Read a network packet to send from ngtcp2 into `buf`. + * Return number of bytes written or -1 with *err set. + */ +static CURLcode read_pkt_to_send(void *userp, + unsigned char *buf, size_t buflen, + size_t *pnread) +{ + struct cf_ngtcp2_io_ctx *x = userp; + struct cf_ngtcp2_ctx *ctx = x->cf->ctx; + nghttp3_vec vec[16]; + nghttp3_ssize veccnt; + ngtcp2_ssize ndatalen; + uint32_t flags; + int64_t stream_id; + int fin; + ssize_t n; + + *pnread = 0; + veccnt = 0; + stream_id = -1; + fin = 0; + + /* ngtcp2 may want to put several frames from different streams into + * this packet. `NGTCP2_WRITE_STREAM_FLAG_MORE` tells it to do so. + * When `NGTCP2_ERR_WRITE_MORE` is returned, we *need* to make + * another iteration. + * When ngtcp2 is happy (because it has no other frame that would fit + * or it has nothing more to send), it returns the total length + * of the assembled packet. This may be 0 if there was nothing to send. */ + for(;;) { + + if(ctx->h3conn && ngtcp2_conn_get_max_data_left(ctx->qconn)) { + veccnt = nghttp3_conn_writev_stream(ctx->h3conn, &stream_id, &fin, vec, + CURL_ARRAYSIZE(vec)); + if(veccnt < 0) { + failf(x->data, "nghttp3_conn_writev_stream returned error: %s", + nghttp3_strerror((int)veccnt)); + Curl_cf_ngtcp2_h3_err_set(x->cf, x->data, (int)veccnt); + return CURLE_SEND_ERROR; + } + } + + flags = NGTCP2_WRITE_STREAM_FLAG_MORE | + (fin ? NGTCP2_WRITE_STREAM_FLAG_FIN : 0); + n = ngtcp2_conn_writev_stream(ctx->qconn, &x->ps.path, + NULL, buf, buflen, + &ndatalen, flags, stream_id, + (const ngtcp2_vec *)vec, veccnt, x->ts); + if(n == 0) { + /* nothing to send */ + return CURLE_AGAIN; + } + else if(n < 0) { + switch(n) { + case NGTCP2_ERR_STREAM_DATA_BLOCKED: { + struct h3_stream_ctx *stream; + DEBUGASSERT(ndatalen == -1); + nghttp3_conn_block_stream(ctx->h3conn, stream_id); + CURL_TRC_CF(x->data, x->cf, "[%" PRId64 "] block quic flow", + stream_id); + stream = cf_ngtcp2_get_stream(ctx, stream_id); + if(stream) /* it might be not one of our h3 streams? */ + stream->quic_flow_blocked = TRUE; + n = 0; + break; + } + case NGTCP2_ERR_STREAM_SHUT_WR: + DEBUGASSERT(ndatalen == -1); + nghttp3_conn_shutdown_stream_write(ctx->h3conn, stream_id); + n = 0; + break; + case NGTCP2_ERR_WRITE_MORE: + /* ngtcp2 wants to send more. update the flow of the stream whose data + * is in the buffer and continue */ + DEBUGASSERT(ndatalen >= 0); + n = 0; + break; + default: + DEBUGASSERT(ndatalen == -1); + failf(x->data, "ngtcp2_conn_writev_stream returned error: %s", + ngtcp2_strerror((int)n)); + Curl_cf_ngtcp2_cmn_err_set(x->cf, x->data, (int)n); + return CURLE_SEND_ERROR; + } + } + + if(ndatalen >= 0) { + /* we add the amount of data bytes to the flow windows */ + int rv = nghttp3_conn_add_write_offset(ctx->h3conn, stream_id, ndatalen); + if(rv) { + failf(x->data, "nghttp3_conn_add_write_offset returned error: %s", + nghttp3_strerror(rv)); + return CURLE_SEND_ERROR; + } + } + + if(n > 0) { + /* packet assembled, leave */ + *pnread = (size_t)n; + return CURLE_OK; + } + } +} + +CURLcode Curl_cf_ngtcp2_progress_egress(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct cf_ngtcp2_io_ctx *pktx) +{ + struct cf_ngtcp2_ctx *ctx = cf->ctx; + size_t nread; + size_t max_payload_size, path_max_payload_size; + size_t pktcnt = 0; + size_t gsolen = 0; /* this disables gso until we have a clue */ + size_t send_quantum; + CURLcode result; + struct cf_ngtcp2_io_ctx local_pktx; + + if(!pktx) { + Curl_cf_ngtcp2_io_ctx_init(&local_pktx, cf, data); + pktx = &local_pktx; + } + else { + Curl_cf_ngtcp2_io_ctx_update_time(data, pktx, cf); + ngtcp2_path_storage_zero(&pktx->ps); + } + + result = vquic_flush(cf, data, &ctx->q); + if(result) { + if(result == CURLE_AGAIN) { + Curl_expire(data, 1, EXPIRE_QUIC); + return CURLE_OK; + } + return result; + } + + /* In UDP, there is a maximum theoretical packet payload length and + * a minimum payload length that is "guaranteed" to work. + * To detect if this minimum payload can be increased, ngtcp2 sends + * now and then a packet payload larger than the minimum. It that + * is ACKed by the peer, both parties know that it works and + * the subsequent packets can use a larger one. + * This is called PMTUD (Path Maximum Transmission Unit Discovery). + * Since a PMTUD might be rejected right on send, we do not want it + * be followed by other packets of lesser size. Because those would + * also fail then. If we detect a PMTUD while buffering, we flush. + */ + max_payload_size = ngtcp2_conn_get_max_tx_udp_payload_size(ctx->qconn); + path_max_payload_size = + ngtcp2_conn_get_path_max_tx_udp_payload_size(ctx->qconn); + send_quantum = ngtcp2_conn_get_send_quantum(ctx->qconn); + CURL_TRC_CF(data, cf, "egress, collect and send packets, quantum=%zu", + send_quantum); + for(;;) { + /* add the next packet to send, if any, to our buffer */ + result = Curl_bufq_sipn(&ctx->q.sendbuf, max_payload_size, + read_pkt_to_send, pktx, &nread); + if(result == CURLE_AGAIN) + break; + else if(result) + return result; + else { + size_t buflen = Curl_bufq_len(&ctx->q.sendbuf); + if((buflen >= send_quantum) || + ((buflen + gsolen) >= ctx->q.sendbuf.chunk_size)) + break; + DEBUGASSERT(nread > 0); + ++pktcnt; + if(pktcnt == 1) { + /* first packet in buffer. This is either of a known, "good" + * payload size or it is a PMTUD. We shall see. */ + gsolen = nread; + } + else if(nread > gsolen || + (gsolen > path_max_payload_size && nread != gsolen)) { + /* The added packet is a PMTUD *or* the one(s) before the + * added were PMTUD and the last one is smaller. + * Flush the buffer before the last add. */ + result = vquic_send_tail_split(cf, data, &ctx->q, + gsolen, nread, nread); + if(result) { + if(result == CURLE_AGAIN) { + Curl_expire(data, 1, EXPIRE_QUIC); + return CURLE_OK; + } + return result; + } + pktcnt = 0; + } + else if(nread < gsolen) { + /* Reached capacity of our buffer *or* + * last add was shorter than the previous ones, flush */ + break; + } + } + } + + if(!Curl_bufq_is_empty(&ctx->q.sendbuf)) { + /* time to send */ + CURL_TRC_CF(data, cf, "egress, send collected %zu packets in %zu bytes", + pktcnt, Curl_bufq_len(&ctx->q.sendbuf)); + result = vquic_send(cf, data, &ctx->q, gsolen); + if(result) { + if(result == CURLE_AGAIN) { + Curl_expire(data, 1, EXPIRE_QUIC); + return CURLE_OK; + } + return result; + } + Curl_cf_ngtcp2_io_ctx_update_time(data, pktx, cf); + ngtcp2_conn_update_pkt_tx_time(ctx->qconn, pktx->ts); + } + return CURLE_OK; +} + +struct cf_ngtcp2_recv_ctx { + struct cf_ngtcp2_io_ctx *pktx; + size_t pkt_count; +}; + +static CURLcode cf_ngtcp2_recv_pkts(const unsigned char *buf, size_t buflen, + size_t gso_size, + struct sockaddr_storage *remote_addr, + socklen_t remote_addrlen, int ecn, + void *userp) +{ + struct cf_ngtcp2_recv_ctx *rctx = userp; + struct cf_ngtcp2_io_ctx *pktx = rctx->pktx; + struct cf_ngtcp2_ctx *ctx = pktx->cf->ctx; + ngtcp2_pkt_info pi; + ngtcp2_path path; + size_t offset, pktlen; + int rv; + + if(!rctx->pkt_count) { + Curl_cf_ngtcp2_io_ctx_update_time(pktx->data, pktx, pktx->cf); + ngtcp2_path_storage_zero(&pktx->ps); + } + + if(ecn) + CURL_TRC_CF(pktx->data, pktx->cf, "vquic_recv(len=%zu, gso=%zu, ecn=%x)", + buflen, gso_size, (unsigned int)ecn); + ngtcp2_addr_init(&path.local, (struct sockaddr *)&ctx->q.local_addr, + ctx->q.local_addrlen); + ngtcp2_addr_init(&path.remote, (struct sockaddr *)remote_addr, + remote_addrlen); + pi.ecn = (uint8_t)ecn; + + for(offset = 0; offset < buflen; offset += gso_size) { + rctx->pkt_count++; + pktlen = ((offset + gso_size) <= buflen) ? gso_size : (buflen - offset); + rv = ngtcp2_conn_read_pkt(ctx->qconn, &path, &pi, + buf + offset, pktlen, pktx->ts); + if(rv) { + CURL_TRC_CF(pktx->data, pktx->cf, "ingress, read_pkt -> %s (%d)", + ngtcp2_strerror(rv), rv); + Curl_cf_ngtcp2_cmn_err_set(pktx->cf, pktx->data, rv); + + if(rv == NGTCP2_ERR_CRYPTO) + /* this is a "TLS problem", but a failed certificate verification + is a common reason for this */ + return CURLE_PEER_FAILED_VERIFICATION; + return CURLE_RECV_ERROR; + } + } + return CURLE_OK; +} + +CURLcode Curl_cf_ngtcp2_progress_ingress(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct cf_ngtcp2_io_ctx *pktx) +{ + struct cf_ngtcp2_ctx *ctx = cf->ctx; + struct cf_ngtcp2_io_ctx local_pktx; + struct cf_ngtcp2_recv_ctx rctx; + CURLcode result = CURLE_OK; + + if(!pktx) { + Curl_cf_ngtcp2_io_ctx_init(&local_pktx, cf, data); + pktx = &local_pktx; + } + + result = Curl_vquic_tls_before_recv(&ctx->tls, cf, data); + if(result) + return result; + + rctx.pktx = pktx; + rctx.pkt_count = 0; + + if(ctx->q.sockfd != CURL_SOCKET_BAD) { + /* Direct UDP socket (via happy eyeballs) */ + CURL_TRC_CF(data, cf, "progress_ingress(socket)"); + return vquic_recv_packets(cf, data, &ctx->q, 1000, + cf_ngtcp2_recv_pkts, &rctx); + } + else { + /* Tunneled QUIC (CONNECT-UDP through proxy) */ + unsigned char *buf; + size_t max_udp_payload = QUIC_TUNNEL_INBUF_SIZE; + size_t pkt_limit = QUIC_TUNNEL_INGRESS_PKT_LIMIT; + size_t nread; + struct sockaddr_storage remote_addr; + socklen_t remote_addrlen; + + CURL_TRC_CF(data, cf, "progress_ingress(sub-filters)"); + if(ctx->qconn) { + size_t max_path_payload; + max_path_payload = + ngtcp2_conn_get_path_max_tx_udp_payload_size(ctx->qconn); + if(max_path_payload > max_udp_payload) + max_udp_payload = max_path_payload; + } + + if(ctx->tunnel_inbuf_len < max_udp_payload) { + unsigned char *newbuf = curlx_realloc(ctx->tunnel_inbuf, + max_udp_payload); + if(!newbuf) + return CURLE_OUT_OF_MEMORY; + ctx->tunnel_inbuf = newbuf; + ctx->tunnel_inbuf_len = max_udp_payload; + } + buf = ctx->tunnel_inbuf; + + while(pkt_limit--) { + result = Curl_conn_cf_recv(cf->next, data, (char *)buf, + ctx->tunnel_inbuf_len, &nread); + if(result == CURLE_AGAIN) { + /* no more data available at the moment */ + return CURLE_OK; + } + if(result) { + CURL_TRC_CF(data, cf, "ingress, recv from tunnel failed: %d", + (int)result); + return result; + } + if(nread == 0) { + /* tunnel closed */ + return CURLE_OK; + } + + memcpy(&remote_addr, ctx->connected_path.remote.addr, + ctx->connected_path.remote.addrlen); + remote_addrlen = (socklen_t)ctx->connected_path.remote.addrlen; + result = cf_ngtcp2_recv_pkts(buf, nread, nread, &remote_addr, + remote_addrlen, 0, &rctx); + if(result) + return result; + + if(!ctx->q.got_first_byte) { + ctx->q.got_first_byte = TRUE; + ctx->q.first_byte_at = ctx->q.last_op; + } + ctx->q.last_io = ctx->q.last_op; + } + return CURLE_OK; + } +} + +/** + * Connection maintenance like timeouts on packet ACKs etc. are done by us, not + * the OS like for TCP. POLL events on the socket therefore are not + * sufficient. + * ngtcp2 tells us when it wants to be invoked again. We handle that via + * the `Curl_expire()` mechanisms. + */ +CURLcode Curl_cf_ngtcp2_cmn_set_expiry(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct cf_ngtcp2_io_ctx *pktx) +{ + struct cf_ngtcp2_ctx *ctx = cf->ctx; + struct cf_ngtcp2_io_ctx local_pktx; + ngtcp2_tstamp expiry; + + if(!pktx) { + Curl_cf_ngtcp2_io_ctx_init(&local_pktx, cf, data); + pktx = &local_pktx; + } + else { + Curl_cf_ngtcp2_io_ctx_update_time(data, pktx, cf); + } + + expiry = ngtcp2_conn_get_expiry(ctx->qconn); + if(expiry != UINT64_MAX) { + if(expiry <= pktx->ts) { + CURLcode result; + int rv = ngtcp2_conn_handle_expiry(ctx->qconn, pktx->ts); + if(rv) { + failf(data, "ngtcp2_conn_handle_expiry returned error: %s", + ngtcp2_strerror(rv)); + Curl_cf_ngtcp2_cmn_err_set(cf, data, rv); + return CURLE_SEND_ERROR; + } + result = Curl_cf_ngtcp2_progress_ingress(cf, data, pktx); + if(result) + return result; + result = Curl_cf_ngtcp2_progress_egress(cf, data, pktx); + if(result) + return result; + /* ask again, things might have changed */ + expiry = ngtcp2_conn_get_expiry(ctx->qconn); + } + + if(expiry > pktx->ts) { + ngtcp2_duration timeout = expiry - pktx->ts; + if(timeout % NGTCP2_MILLISECONDS) { + timeout += NGTCP2_MILLISECONDS; + } + Curl_expire(data, (timediff_t)(timeout / NGTCP2_MILLISECONDS), + EXPIRE_QUIC); + } + } + return CURLE_OK; +} + +static void cf_ngtcp2_setup_keep_alive(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_ngtcp2_ctx *ctx = cf->ctx; + const ngtcp2_transport_params *rp; + /* Peer should have sent us its transport parameters. If it + * announces a positive `max_idle_timeout` it closes the + * connection when it does not hear from us for that time. + * + * Some servers use this as a keep-alive timer at a rather low + * value. We are doing HTTP/3 here and waiting for the response + * to a request may take a considerable amount of time. We need + * to prevent the peer's QUIC stack from closing in this case. + */ + if(!ctx->qconn) + return; + + rp = ngtcp2_conn_get_remote_transport_params(ctx->qconn); + if(!rp || !rp->max_idle_timeout) { + ngtcp2_conn_set_keep_alive_timeout(ctx->qconn, UINT64_MAX); + CURL_TRC_CF(data, cf, "no peer idle timeout, unset keep-alive"); + } + else if(!Curl_uint32_hash_count(&ctx->streams)) { + ngtcp2_conn_set_keep_alive_timeout(ctx->qconn, UINT64_MAX); + CURL_TRC_CF(data, cf, "no active streams, unset keep-alive"); + } + else { + ngtcp2_duration keep_ns; + keep_ns = (rp->max_idle_timeout > 1) ? (rp->max_idle_timeout / 2) : 1; + ngtcp2_conn_set_keep_alive_timeout(ctx->qconn, keep_ns); + CURL_TRC_CF(data, cf, "peer idle timeout is %" PRIu64 "ms, " + "set keep-alive to %" PRIu64 " ms.", + (rp->max_idle_timeout / NGTCP2_MILLISECONDS), + (keep_ns / NGTCP2_MILLISECONDS)); + } +} + +CURLcode Curl_cf_ngtcp2_h3_stream_setup(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_ngtcp2_ctx *ctx = cf->ctx; + struct h3_stream_ctx *stream = H3_STREAM_CTX(ctx, data); + + if(!data) + return CURLE_FAILED_INIT; + + if(stream) + return CURLE_OK; + + stream = curlx_calloc(1, sizeof(*stream)); + if(!stream) + return CURLE_OUT_OF_MEMORY; + + stream->id = -1; + stream->rx_offset = 0; + stream->rx_offset_max = H3_STREAM_WINDOW_SIZE_INITIAL; + + /* on send, we control how much we put into the buffer */ + Curl_bufq_initp(&stream->sendbuf, &ctx->stream_bufcp, + H3_STREAM_SEND_CHUNKS, BUFQ_OPT_NONE); + stream->sendbuf_len_in_flight = 0; + stream->window_size_max = H3_STREAM_WINDOW_SIZE_INITIAL; + Curl_h1_req_parse_init(&stream->h1, H1_PARSE_DEFAULT_MAX_LINE_LEN); + + if(!Curl_uint32_hash_set(&ctx->streams, data->mid, stream)) { + Curl_cf_ngtcp2_h3_stream_ctx_free(stream); + return CURLE_OUT_OF_MEMORY; + } + + if(Curl_uint32_hash_count(&ctx->streams) == 1) + cf_ngtcp2_setup_keep_alive(cf, data); + + return CURLE_OK; +} + +void Curl_cf_ngtcp2_h3_stream_close(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h3_stream_ctx *stream) +{ + struct cf_ngtcp2_ctx *ctx = cf->ctx; + DEBUGASSERT(data); + DEBUGASSERT(stream); + if(!stream->closed && ctx->qconn && ctx->h3conn) { + CURLcode result; + + nghttp3_conn_set_stream_user_data(ctx->h3conn, stream->id, NULL); + ngtcp2_conn_set_stream_user_data(ctx->qconn, stream->id, NULL); + stream->closed = TRUE; + (void)ngtcp2_conn_shutdown_stream(ctx->qconn, 0, stream->id, + NGHTTP3_H3_REQUEST_CANCELLED); + result = Curl_cf_ngtcp2_progress_egress(cf, data, NULL); + if(result) + CURL_TRC_CF(data, cf, "[%" PRId64 "] cancel stream -> %d", + stream->id, (int)result); + } +} + +void Curl_cf_ngtcp2_h3_stream_done(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_ngtcp2_ctx *ctx = cf->ctx; + struct h3_stream_ctx *stream = H3_STREAM_CTX(ctx, data); + (void)cf; + if(stream) { + CURL_TRC_CF(data, cf, "[%" PRId64 "] easy handle is done", stream->id); + Curl_cf_ngtcp2_h3_stream_close(cf, data, stream); + Curl_uint32_hash_remove(&ctx->streams, data->mid); + if(!Curl_uint32_hash_count(&ctx->streams)) + cf_ngtcp2_setup_keep_alive(cf, data); + } +} + +bool Curl_cf_ngtcp2_cmn_conn_is_alive(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *input_pending) +{ + struct cf_ngtcp2_ctx *ctx = cf->ctx; + bool alive = FALSE; + const ngtcp2_transport_params *rp; + struct cf_call_data save; + + CF_DATA_SAVE(save, cf, data); + *input_pending = FALSE; + if(!ctx->qconn || ctx->shutdown_started) + goto out; + + /* We do not announce a max idle timeout, but when the peer does + * it closes the connection when it expires. */ + rp = ngtcp2_conn_get_remote_transport_params(ctx->qconn); + if(rp && rp->max_idle_timeout) { + timediff_t idletime_ms = + curlx_ptimediff_ms(Curl_pgrs_now(data), &ctx->q.last_io); + if(idletime_ms > 0) { + uint64_t max_idle_ms = + (uint64_t)(rp->max_idle_timeout / NGTCP2_MILLISECONDS); + if((uint64_t)idletime_ms > max_idle_ms) + goto out; + } + } + + if(!cf->next || !cf->next->cft->is_alive(cf->next, data, input_pending)) + goto out; + + alive = TRUE; + if(*input_pending) { + CURLcode result; + /* This happens before we have sent off a request and the connection is + not in use by any other transfer, there should not be any data here, + only "protocol frames" */ + *input_pending = FALSE; + result = Curl_cf_ngtcp2_progress_ingress(cf, data, NULL); + CURL_TRC_CF(data, cf, "is_alive, progress ingress -> %d", (int)result); + alive = result ? FALSE : TRUE; + } + +out: + CF_DATA_RESTORE(cf, save); + return alive; +} + +CURLcode Curl_cf_ngtcp2_h3_init_ctrls(struct cf_ngtcp2_ctx *ctx, + struct Curl_easy *data) +{ + int64_t ctrl_stream_id, qpack_enc_stream_id, qpack_dec_stream_id; + int rc; + + rc = ngtcp2_conn_open_uni_stream(ctx->qconn, &ctrl_stream_id, NULL); + if(rc) { + failf(data, "error creating HTTP/3 control stream: %s", + ngtcp2_strerror(rc)); + return CURLE_QUIC_CONNECT_ERROR; + } + rc = nghttp3_conn_bind_control_stream(ctx->h3conn, ctrl_stream_id); + if(rc) { + failf(data, "error binding HTTP/3 control stream: %s", + ngtcp2_strerror(rc)); + return CURLE_QUIC_CONNECT_ERROR; + } + rc = ngtcp2_conn_open_uni_stream(ctx->qconn, &qpack_enc_stream_id, NULL); + if(rc) { + failf(data, "error creating HTTP/3 qpack encoding stream: %s", + ngtcp2_strerror(rc)); + return CURLE_QUIC_CONNECT_ERROR; + } + rc = ngtcp2_conn_open_uni_stream(ctx->qconn, &qpack_dec_stream_id, NULL); + if(rc) { + failf(data, "error creating HTTP/3 qpack decoding stream: %s", + ngtcp2_strerror(rc)); + return CURLE_QUIC_CONNECT_ERROR; + } + rc = nghttp3_conn_bind_qpack_streams(ctx->h3conn, qpack_enc_stream_id, + qpack_dec_stream_id); + if(rc) { + failf(data, "error binding HTTP/3 qpack streams: %s", ngtcp2_strerror(rc)); + return CURLE_QUIC_CONNECT_ERROR; + } + return CURLE_OK; +} + +#endif /* !CURL_DISABLE_HTTP && USE_NGTCP2 && USE_NGHTTP3 */ diff --git a/3rdparty/curl-8.21.0/lib/vquic/cf-ngtcp2-cmn.h b/3rdparty/curl-8.21.0/lib/vquic/cf-ngtcp2-cmn.h new file mode 100644 index 0000000000..88554edfb6 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vquic/cf-ngtcp2-cmn.h @@ -0,0 +1,239 @@ +#ifndef HEADER_CURL_VQUIC_CF_NGTCP2_CMN_H +#define HEADER_CURL_VQUIC_CF_NGTCP2_CMN_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_HTTP) && defined(USE_NGTCP2) && defined(USE_NGHTTP3) + +#include +#include + +#ifdef USE_OPENSSL +#include +#if defined(OPENSSL_IS_AWSLC) || defined(OPENSSL_IS_BORINGSSL) +#include +#elif defined(OPENSSL_QUIC_API2) +#include +#else +#include +#endif +#include "vtls/openssl.h" +#elif defined(USE_GNUTLS) +#include +#include "vtls/gtls.h" +#elif defined(USE_WOLFSSL) +#include +#include +#include +#include +#include "vtls/wolfssl.h" +#endif + +#ifdef HAVE_NETINET_UDP_H +#include +#endif + +#include + +#include "http1.h" +#include "uint-hash.h" +#include "vtls/vtls.h" +#include "vquic/vquic_int.h" +#include "vquic/vquic-tls.h" + +struct Curl_cfilter; +struct Curl_easy; +struct cf_ngtcp2_ctx; +struct cf_quic_ctx; + +#define QUIC_MAX_STREAMS (256 * 1024) +#define QUIC_HANDSHAKE_TIMEOUT (10 * NGTCP2_SECONDS) +#define QUIC_TUNNEL_INBUF_SIZE (64 * 1024) + +/* We announce a small window size in transport param to the server, + * and grow that immediately to max when no rate limit is in place. + * We need to start small as we are not able to decrease it. */ +#define H3_STREAM_WINDOW_SIZE_INITIAL (32 * 1024) +#define H3_STREAM_WINDOW_SIZE_MAX (10 * 1024 * 1024) +#define H3_CONN_WINDOW_SIZE_MAX (100 * H3_STREAM_WINDOW_SIZE_MAX) + +#define H3_STREAM_CHUNK_SIZE (64 * 1024) +#if H3_STREAM_CHUNK_SIZE < NGTCP2_MAX_UDP_PAYLOAD_SIZE +#error H3_STREAM_CHUNK_SIZE smaller than NGTCP2_MAX_UDP_PAYLOAD_SIZE +#endif +/* The pool keeps spares around and half of a full stream window + * seems good. More does not seem to improve performance. + * The benefit of the pool is that stream buffers do not keep + * spares. Memory consumption goes down when streams run empty, + * have a large upload done, etc. */ +#define H3_STREAM_POOL_SPARES 2 +/* The max amount of un-acked upload data we keep around per stream */ +#define H3_STREAM_SEND_BUFFER_MAX (10 * 1024 * 1024) +#define H3_STREAM_SEND_CHUNKS \ + (H3_STREAM_SEND_BUFFER_MAX / H3_STREAM_CHUNK_SIZE) +#define QUIC_TUNNEL_INGRESS_PKT_LIMIT 1000 + + +void Curl_ngtcp2_ver(char *p, size_t len); + +typedef CURLcode cf_ngtcp2_init_h3_conn(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct cf_ngtcp2_ctx *ctx); + +struct cf_ngtcp2_ctx { + struct cf_quic_ctx q; + struct ssl_peer ssl_peer; + struct curl_tls_ctx tls; +#ifdef OPENSSL_QUIC_API2 + ngtcp2_crypto_ossl_ctx *ossl_ctx; +#endif + ngtcp2_path connected_path; + ngtcp2_conn *qconn; + ngtcp2_cid dcid; + ngtcp2_cid scid; + uint32_t version; + ngtcp2_settings settings; + ngtcp2_transport_params transport_params; + ngtcp2_ccerr last_error; + ngtcp2_crypto_conn_ref conn_ref; + struct cf_call_data call_data; + cf_ngtcp2_init_h3_conn *init_h3_conn_cb; + nghttp3_conn *h3conn; + nghttp3_settings h3settings; + struct curltime started_at; /* time the current attempt started */ + struct curltime handshake_at; /* time connect handshake finished */ + struct bufc_pool stream_bufcp; /* chunk pool for streams */ + struct dynbuf scratch; /* temp buffer for header construction */ + struct uint_hash streams; /* hash data->mid to h3_stream_ctx */ + uint64_t used_bidi_streams; /* bidi streams we have opened */ + uint64_t max_bidi_streams; /* max bidi streams we can open */ + size_t earlydata_max; /* max amount of early data supported by + server on session reuse */ + size_t earlydata_skip; /* sending bytes to skip when earlydata + is accepted by peer */ + CURLcode tls_vrfy_result; /* result of TLS peer verification */ + int qlogfd; + unsigned char *tunnel_inbuf; /* ingress buffer for tunneled packets */ + size_t tunnel_inbuf_len; + BIT(initialized); + BIT(tls_handshake_complete); /* TLS handshake is done */ + BIT(use_earlydata); /* Using 0RTT data */ + BIT(earlydata_accepted); /* 0RTT was accepted by server */ + BIT(shutdown_started); /* queued shutdown packets */ +}; + +/* How to access `call_data` from a cf_ngtcp2 filter */ +#undef CF_CTX_CALL_DATA +#define CF_CTX_CALL_DATA(cf) ((struct cf_ngtcp2_ctx *)(cf)->ctx)->call_data + +CURLcode Curl_cf_ngtcp2_ctx_init(struct cf_ngtcp2_ctx *ctx, + struct Curl_peer *origin, + struct Curl_peer *peer, + struct ssl_primary_config *sslc, + cf_ngtcp2_init_h3_conn *init_h3_conn_cb); +void Curl_cf_ngtcp2_ctx_cleanup(struct cf_ngtcp2_ctx *ctx); +void Curl_cf_ngtcp2_cmn_err_set(struct Curl_cfilter *cf, + struct Curl_easy *data, int code); + +/** + * All about the H3 internals of a stream + */ +struct h3_stream_ctx { + int64_t id; /* HTTP/3 stream identifier */ + struct bufq sendbuf; /* h3 request body */ + struct h1_req_parser h1; /* h1 request parsing */ + size_t sendbuf_len_in_flight; /* sendbuf amount "in flight" */ + uint64_t error3; /* HTTP/3 stream error code */ + curl_off_t upload_left; /* number of request bytes left to upload */ + curl_off_t rx_total; /* total number of bytes received */ + uint64_t rx_offset; /* current receive offset */ + uint64_t rx_offset_max; /* allowed receive offset */ + uint64_t window_size_max; /* max flow control window set for stream */ + int status_code; /* HTTP status code */ + CURLcode xfer_result; /* result from xfer_resp_write(_hd) */ + BIT(resp_hds_complete); /* we have a complete, final response */ + BIT(closed); /* TRUE on stream close */ + BIT(reset); /* TRUE on stream reset */ + BIT(send_closed); /* stream is local closed */ + BIT(quic_flow_blocked); /* stream is blocked by QUIC flow control */ +}; + +void Curl_cf_ngtcp2_h3_stream_ctx_free(struct h3_stream_ctx *stream); +void Curl_cf_ngtcp2_h3_err_set(struct Curl_cfilter *cf, + struct Curl_easy *data, int code); + +CURLcode Curl_cf_ngtcp2_h3_init_ctrls(struct cf_ngtcp2_ctx *ctx, + struct Curl_easy *data); + +CURLcode Curl_cf_ngtcp2_cmn_connect(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done); + +CURLcode Curl_cf_ngtcp2_cmn_shutdown(struct Curl_cfilter *cf, + struct Curl_easy *data, bool *done); +void Curl_cf_ngtcp2_cmn_conn_close(struct Curl_cfilter *cf, + struct Curl_easy *data); + +struct cf_ngtcp2_io_ctx { + struct Curl_cfilter *cf; + struct Curl_easy *data; + ngtcp2_tstamp ts; + ngtcp2_path_storage ps; +}; + +void Curl_cf_ngtcp2_io_ctx_init(struct cf_ngtcp2_io_ctx *io_ctx, + struct Curl_cfilter *cf, + struct Curl_easy *data); +void Curl_cf_ngtcp2_io_ctx_update_time(struct Curl_easy *data, + struct cf_ngtcp2_io_ctx *pktx, + struct Curl_cfilter *cf); + +CURLcode Curl_cf_ngtcp2_progress_egress(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct cf_ngtcp2_io_ctx *pktx); + +CURLcode Curl_cf_ngtcp2_progress_ingress(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct cf_ngtcp2_io_ctx *pktx); + +CURLcode Curl_cf_ngtcp2_cmn_set_expiry(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct cf_ngtcp2_io_ctx *pktx); + +CURLcode Curl_cf_ngtcp2_h3_stream_setup(struct Curl_cfilter *cf, + struct Curl_easy *data); +void Curl_cf_ngtcp2_h3_stream_close(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h3_stream_ctx *stream); +void Curl_cf_ngtcp2_h3_stream_done(struct Curl_cfilter *cf, + struct Curl_easy *data); + +bool Curl_cf_ngtcp2_cmn_conn_is_alive(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *input_pending); + +#endif /* !CURL_DISABLE_HTTP && USE_NGTCP2 && USE_NGHTTP3 */ + +#endif /* HEADER_CURL_VQUIC_CF_NGTCP2_CMN_H */ diff --git a/3rdparty/curl-8.21.0/lib/vquic/cf-ngtcp2-proxy.c b/3rdparty/curl-8.21.0/lib/vquic/cf-ngtcp2-proxy.c new file mode 100644 index 0000000000..fd2840890f --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vquic/cf-ngtcp2-proxy.c @@ -0,0 +1,1316 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_HTTP) && !defined(CURL_DISABLE_PROXY) && \ + defined(USE_PROXY_HTTP3) && defined(USE_NGHTTP3) && \ + defined(USE_NGTCP2) && defined(USE_OPENSSL) + +#include "urldata.h" +#include "url.h" +#include "curl_trc.h" +#include "sendf.h" +#include "multiif.h" +#include "cfilters.h" +#include "connect.h" +#include "progress.h" +#include "curlx/dynbuf.h" +#include "http_proxy.h" +#include "vquic/vquic.h" +#include "vquic/cf-ngtcp2-cmn.h" +#include "vquic/cf-ngtcp2-proxy.h" +#include "capsule.h" + +/* A stream window is the maximum amount we need to buffer for + * each active transfer. We use HTTP/3 flow control and only ACK + * when we take things out of the buffer. + * Chunk size is large enough to take a full DATA frame */ +#define PROXY_H3_STREAM_RECV_CHUNKS ((512 * 1024) / H3_STREAM_CHUNK_SIZE) + +typedef enum { + H3_TUNNEL_INIT, /* init/default/no tunnel state */ + H3_TUNNEL_CONNECT, /* CONNECT request is being sent */ + H3_TUNNEL_RESPONSE, /* CONNECT response received completely */ + H3_TUNNEL_ESTABLISHED, + H3_TUNNEL_FAILED +} h3_tunnel_state; + +struct h3_tunnel_stream { + struct Curl_peer *peer; /* where the tunnel goes to */ + struct http_resp *resp; + struct bufq recvbuf; + char *authority; + struct h3_stream_ctx *stream; + h3_tunnel_state state; + BIT(udp); + BIT(has_final_response); + BIT(closed); +}; + +static CURLcode h3_tunnel_stream_init(struct h3_tunnel_stream *ts, + struct Curl_peer *peer, + bool udp) +{ + ts->state = H3_TUNNEL_INIT; + Curl_peer_link(&ts->peer, peer); + Curl_bufq_init2(&ts->recvbuf, H3_STREAM_CHUNK_SIZE, + PROXY_H3_STREAM_RECV_CHUNKS, BUFQ_OPT_SOFT_LIMIT); + ts->udp = udp; + /* host:port with IPv6 support */ + ts->authority = curl_maprintf("%s%s%s:%u", peer->ipv6 ? "[" : "", + peer->hostname, + peer->ipv6 ? "]" : "", + peer->port); + if(!ts->authority) + return CURLE_OUT_OF_MEMORY; + + return CURLE_OK; +} + +static void h3_tunnel_stream_reset(struct h3_tunnel_stream *ts) +{ + Curl_bufq_reset(&ts->recvbuf); + Curl_http_resp_free(ts->resp); + ts->resp = NULL; + ts->stream = NULL; + ts->has_final_response = FALSE; + ts->closed = FALSE; + ts->state = H3_TUNNEL_INIT; +} + +static void h3_tunnel_stream_cleanup(struct h3_tunnel_stream *ts) +{ + Curl_peer_unlink(&ts->peer); + Curl_bufq_free(&ts->recvbuf); + Curl_http_resp_free(ts->resp); + curlx_safefree(ts->authority); + ts->state = H3_TUNNEL_INIT; +} + +static void h3_tunnel_go_state(struct Curl_cfilter *cf, + struct h3_tunnel_stream *ts, + h3_tunnel_state new_state, + struct Curl_easy *data) +{ + VERBOSE(int64_t stream_id = ts->stream ? ts->stream->id : -1); + (void)cf; + + if(ts->state == new_state) + return; + + /* leaving this one */ + switch(ts->state) { + case H3_TUNNEL_CONNECT: + data->req.ignorebody = FALSE; + break; + default: + break; + } + + /* entering this one */ + switch(new_state) { + case H3_TUNNEL_INIT: + CURL_TRC_CF(data, cf, "[%" PRId64 "] -> [init]", stream_id); + h3_tunnel_stream_reset(ts); + break; + case H3_TUNNEL_CONNECT: + CURL_TRC_CF(data, cf, "[%" PRId64 "] -> [connect]", stream_id); + ts->state = H3_TUNNEL_CONNECT; + break; + case H3_TUNNEL_RESPONSE: + CURL_TRC_CF(data, cf, "[%" PRId64 "] -> [response]", stream_id); + ts->state = H3_TUNNEL_RESPONSE; + break; + case H3_TUNNEL_ESTABLISHED: + CURL_TRC_CF(data, cf, "[%" PRId64 "] -> [established]", stream_id); + infof(data, "CONNECT%s phase completed for HTTP/3 proxy", + ts->udp ? "-UDP" : ""); + data->state.authproxy.done = TRUE; + data->state.authproxy.multipass = FALSE; + ts->state = new_state; + curlx_safefree(data->req.hd_proxy_auth); + break; + case H3_TUNNEL_FAILED: + CURL_TRC_CF(data, cf, "[%" PRId64 "] -> [failed]", stream_id); + ts->state = new_state; + /* If a proxy-authorization header was used for the proxy, then we should + make sure that it is not accidentally used for the document request + after we have connected. So let's free and clear it here. */ + curlx_safefree(data->req.hd_proxy_auth); + break; + } +} + +struct cf_h3_proxy_ctx { + struct cf_ngtcp2_ctx ngtcp2_ctx; + struct h3_tunnel_stream tunnel; /* our tunnel CONNECT stream */ + BIT(connected); +}; + +static CURLcode cf_ngtcp2_proxy_h3_init(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct cf_ngtcp2_ctx *ctx); + +static CURLcode cf_h3_proxy_ctx_init(struct cf_h3_proxy_ctx *ctx, + struct Curl_peer *origin, + struct Curl_peer *peer, + struct ssl_primary_config *sslc, + struct Curl_peer *tunnel_peer, + uint8_t tunnel_transport) +{ + CURLcode result; + result = Curl_cf_ngtcp2_ctx_init(&ctx->ngtcp2_ctx, origin, peer, + sslc, cf_ngtcp2_proxy_h3_init); + if(!result) + result = h3_tunnel_stream_init(&ctx->tunnel, tunnel_peer, + TRNSPRT_IS_DGRAM(tunnel_transport)); + return result; +} + +static void cf_h3_proxy_ctx_free(struct cf_h3_proxy_ctx *ctx) +{ + if(ctx) { + Curl_cf_ngtcp2_ctx_cleanup(&ctx->ngtcp2_ctx); + h3_tunnel_stream_cleanup(&ctx->tunnel); + curlx_free(ctx); + } +} + +static int cb_h3_proxy_acked_req_body(nghttp3_conn *conn, int64_t stream_id, + uint64_t datalen, void *user_data, + void *stream_user_data) +{ + struct Curl_cfilter *cf = user_data; + struct cf_h3_proxy_ctx *pctx = cf->ctx; + struct h3_stream_ctx *stream; + size_t skiplen; + (void)stream_user_data; + + stream = pctx->tunnel.stream; + if(!stream || (stream->id != stream_id)) + return 0; + + /* The server acknowledged `datalen` of bytes from our request body. + * This is a delta. We have kept this data in `sendbuf` for + * re-transmissions and can free it now. */ + if(datalen >= (uint64_t)stream->sendbuf_len_in_flight) + skiplen = stream->sendbuf_len_in_flight; + else + skiplen = (size_t)datalen; + Curl_bufq_skip(&stream->sendbuf, skiplen); + stream->sendbuf_len_in_flight -= skiplen; + + /* Resume upload processing if we have more data to send */ + if(stream->sendbuf_len_in_flight < Curl_bufq_len(&stream->sendbuf)) { + int rv = nghttp3_conn_resume_stream(conn, stream_id); + if(rv && rv != NGHTTP3_ERR_STREAM_NOT_FOUND) { + return NGHTTP3_ERR_CALLBACK_FAILURE; + } + } + return 0; +} + +static int cb_h3_proxy_stream_close(nghttp3_conn *conn, int64_t stream_id, + uint64_t app_error_code, void *user_data, + void *stream_user_data) +{ + struct Curl_cfilter *cf = user_data; + struct cf_h3_proxy_ctx *pctx = cf->ctx; + struct Curl_easy *data = CF_DATA_CURRENT(cf); + struct h3_stream_ctx *stream; + + (void)conn; + (void)stream_user_data; + if(!data) + return NGHTTP3_ERR_CALLBACK_FAILURE; + + stream = pctx->tunnel.stream; + if(!stream || (stream->id != stream_id)) + return 0; + + stream->closed = TRUE; + stream->error3 = app_error_code; + if(stream->error3 != NGHTTP3_H3_NO_ERROR) { + stream->reset = TRUE; + stream->send_closed = TRUE; + CURL_TRC_CF(data, cf, "[%" PRId64 "] RESET: error %" PRIu64, + stream->id, stream->error3); + } + else + CURL_TRC_CF(data, cf, "[%" PRId64 "] CLOSED", stream->id); + pctx->tunnel.stream = NULL; + pctx->tunnel.closed = TRUE; + Curl_multi_mark_dirty(data); + return 0; +} + +static void cf_h3_proxy_upd_rx_win(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h3_stream_ctx *stream) +{ + struct cf_h3_proxy_ctx *pctx = cf->ctx; + struct cf_ngtcp2_ctx *ctx = &pctx->ngtcp2_ctx; + uint64_t cur_win, wanted_win = H3_STREAM_WINDOW_SIZE_MAX; + + /* how much does rate limiting allow us to acknowledge? */ + if(Curl_rlimit_active(&data->progress.dl.rlimit)) { + int64_t avail; + + /* start rate limit updates only after first bytes arrived */ + if(!stream->rx_offset) + return; + + avail = Curl_rlimit_avail(&data->progress.dl.rlimit, Curl_pgrs_now(data)); + if(avail <= 0) { + /* nothing available, do not extend the rx offset */ + CURL_TRC_CF(data, cf, "[%" PRId64 "] dl rate limit exhausted (%" PRId64 + " tokens)", stream->id, avail); + return; + } + wanted_win = CURLMIN((uint64_t)avail, H3_STREAM_WINDOW_SIZE_MAX); + } + + if(stream->rx_offset_max < stream->rx_offset) { + DEBUGASSERT(0); + return; + } + cur_win = stream->rx_offset_max - stream->rx_offset; + if(cur_win < wanted_win) { + /* We have exhausted the credit we gave the QUIC peer for DATA. + * We extend it with the amount we can give (rate limit) */ + uint64_t ext = wanted_win - cur_win; + + ngtcp2_conn_extend_max_stream_offset(ctx->qconn, stream->id, ext); + ngtcp2_conn_extend_max_offset(ctx->qconn, ext); + stream->rx_offset_max += ext; + if(stream->rx_offset_max > stream->window_size_max) { + stream->window_size_max = stream->rx_offset_max; + CURL_TRC_CF(data, cf, "[%" PRId64 "] max window now -> %" PRIu64, + stream->id, stream->window_size_max); + } + CURL_TRC_CF(data, cf, "[%" PRId64 "] rx_offset_max -> %" PRIu64 + " (ext %" PRIu64 ", win %" PRIu64 ")", + stream->id, stream->rx_offset_max, ext, wanted_win); + } +} + +static int cb_h3_proxy_recv_data(nghttp3_conn *conn, int64_t stream3_id, + const uint8_t *buf, size_t buflen, + void *user_data, void *stream_user_data) +{ + struct Curl_cfilter *cf = user_data; + struct cf_h3_proxy_ctx *pctx = cf->ctx; + struct Curl_easy *data = CF_DATA_CURRENT(cf); + struct h3_stream_ctx *stream; + size_t nwritten; + CURLcode result = CURLE_OK; + (void)conn; + (void)stream3_id; + (void)stream_user_data; + + stream = pctx->tunnel.stream; + if(!data || !stream || (stream->id != stream3_id)) { + return NGHTTP3_ERR_CALLBACK_FAILURE; + } + + stream->rx_total += (curl_off_t)buflen; + CURL_TRC_CF(data, cf, "[cb_h3_proxy_recv_data] " + "[%" PRId64 "] DATA len=%zu, total=%" FMT_OFF_T, + stream->id, buflen, stream->rx_total); + + result = Curl_bufq_write(&pctx->tunnel.recvbuf, buf, buflen, &nwritten); + if(result || (nwritten < buflen)) { + return NGHTTP3_ERR_CALLBACK_FAILURE; + } + + /* DATA has been moved into our local recv buffer. Update stream offsets + * and give QUIC read credit back so long transfers over proxy tunnels + * do not stall on stream/connection flow-control limits. */ + stream->rx_offset += buflen; + if(stream->rx_offset_max < stream->rx_offset) + stream->rx_offset_max = stream->rx_offset; + + CURL_TRC_CF(data, cf, "[%" PRId64 "] DATA len=%zu, rx win=%" PRIu64, + stream->id, buflen, stream->rx_offset_max - stream->rx_offset); + cf_h3_proxy_upd_rx_win(cf, data, stream); + + Curl_multi_mark_dirty(data); + return 0; +} + +static int cb_h3_proxy_deferred_consume(nghttp3_conn *conn, int64_t stream_id, + size_t consumed, void *user_data, + void *stream_user_data) +{ + struct Curl_cfilter *cf = user_data; + struct cf_h3_proxy_ctx *pctx = cf->ctx; + struct cf_ngtcp2_ctx *ctx = &pctx->ngtcp2_ctx; + (void)conn; + (void)stream_user_data; + + if(!ctx) + return 0; + + /* nghttp3 has consumed bytes on the QUIC stream and we need to + * tell the QUIC connection to increase its flow control */ + ngtcp2_conn_extend_max_stream_offset(ctx->qconn, stream_id, consumed); + ngtcp2_conn_extend_max_offset(ctx->qconn, consumed); + + return 0; +} + +static int cb_h3_proxy_recv_header(nghttp3_conn *conn, int64_t stream_id, + int32_t token, nghttp3_rcbuf *name, + nghttp3_rcbuf *value, uint8_t flags, + void *user_data, void *stream_user_data) +{ + struct Curl_cfilter *cf = user_data; + struct cf_h3_proxy_ctx *pctx = cf->ctx; + nghttp3_vec h3name = nghttp3_rcbuf_get_buf(name); + nghttp3_vec h3val = nghttp3_rcbuf_get_buf(value); + struct Curl_easy *data = CF_DATA_CURRENT(cf); + struct h3_stream_ctx *stream; + CURLcode result = CURLE_OK; + int http_status; + struct http_resp *resp; + (void)conn; + (void)stream_id; + (void)token; + (void)flags; + (void)stream_user_data; + + /* stream_user_data might be NULL for control streams */ + if(!data) + return NGHTTP3_ERR_CALLBACK_FAILURE; + + stream = pctx->tunnel.stream; + if(!stream || (stream->id != stream_id)) { + CURL_TRC_CF(data, cf, "[%" PRId64 "] recv_header: stream lookup " + "failed for data=%p mid=%u", + stream_id, (void *)data, data ? data->mid : 0); + return 0; + } + + if(pctx->tunnel.has_final_response) { + /* we do not do anything with trailers for tunnel streams */ + return 0; + } + + if(token == NGHTTP3_QPACK_TOKEN__STATUS) { + result = Curl_http_decode_status(&stream->status_code, + (const char *)h3val.base, h3val.len); + if(result) + return NGHTTP3_ERR_CALLBACK_FAILURE; + http_status = stream->status_code; + result = Curl_http_resp_make(&resp, http_status, NULL); + if(result) + return NGHTTP3_ERR_CALLBACK_FAILURE; + if(pctx->tunnel.resp) + Curl_http_resp_free(pctx->tunnel.resp); + pctx->tunnel.resp = resp; + } + else { + /* store as an HTTP1-style header */ + CURL_TRC_CF(data, cf, "[%" PRId64 "] header: %.*s: %.*s", stream_id, + (int)h3name.len, h3name.base, (int)h3val.len, h3val.base); + result = Curl_dynhds_add(&pctx->tunnel.resp->headers, + (const char *)h3name.base, h3name.len, + (const char *)h3val.base, h3val.len); + if(result) { + return NGHTTP3_ERR_CALLBACK_FAILURE; + } + } + return 0; +} + +static int cb_h3_proxy_end_headers(nghttp3_conn *conn, int64_t stream_id, + int fin, void *user_data, + void *stream_user_data) +{ + struct Curl_cfilter *cf = user_data; + struct cf_h3_proxy_ctx *pctx = cf->ctx; + struct Curl_easy *data = CF_DATA_CURRENT(cf); + struct h3_stream_ctx *stream; + (void)conn; + (void)stream_id; + (void)fin; + (void)stream_user_data; + + if(!data) + return NGHTTP3_ERR_CALLBACK_FAILURE; + + stream = pctx->tunnel.stream; + if(!stream || (stream->id != stream_id)) { + CURL_TRC_CF(data, cf, "[%" PRId64 "] end_headers: stream lookup " + "failed for data=%p mid=%u", + stream_id, (void *)data, data ? data->mid : 0); + return 0; + } + + CURL_TRC_CF(data, cf, "[%" PRId64 "] end_headers, status=%d", stream_id, + stream->status_code); + + if(!pctx->tunnel.has_final_response) { + if(stream->status_code / 100 != 1) { + pctx->tunnel.has_final_response = TRUE; + } + } + + if(stream->status_code / 100 != 1) { + stream->resp_hds_complete = TRUE; + } + + Curl_multi_mark_dirty(data); + return 0; +} + +static int cb_h3_proxy_stop_sending(nghttp3_conn *conn, int64_t stream_id, + uint64_t app_error_code, void *user_data, + void *stream_user_data) +{ + struct Curl_cfilter *cf = user_data; + struct cf_h3_proxy_ctx *pctx = cf->ctx; + struct cf_ngtcp2_ctx *ctx = &pctx->ngtcp2_ctx; + (void)conn; + (void)stream_user_data; + + if(ctx) { + int rv = ngtcp2_conn_shutdown_stream_read(ctx->qconn, 0, stream_id, + app_error_code); + + if(rv && rv != NGTCP2_ERR_STREAM_NOT_FOUND) { + return NGHTTP3_ERR_CALLBACK_FAILURE; + } + } + + return 0; +} + +static int cb_h3_proxy_reset_stream(nghttp3_conn *conn, int64_t stream_id, + uint64_t app_error_code, void *user_data, + void *stream_user_data) +{ + struct Curl_cfilter *cf = user_data; + struct cf_h3_proxy_ctx *pctx = cf->ctx; + struct cf_ngtcp2_ctx *ctx = &pctx->ngtcp2_ctx; + struct Curl_easy *data = CF_DATA_CURRENT(cf); + int rv; + + (void)conn; + (void)stream_user_data; + if(!data) + return NGHTTP3_ERR_CALLBACK_FAILURE; + + if(!pctx->tunnel.stream || + (stream_id != pctx->tunnel.stream->id)) + return 0; + + rv = ngtcp2_conn_shutdown_stream_write(ctx->qconn, 0, stream_id, + app_error_code); + CURL_TRC_CF(data, cf, "[%" PRId64 "] reset -> %d", stream_id, rv); + pctx->tunnel.stream = NULL; + pctx->tunnel.closed = TRUE; + if(rv && rv != NGTCP2_ERR_STREAM_NOT_FOUND) { + return NGHTTP3_ERR_CALLBACK_FAILURE; + } + return 0; +} + +static nghttp3_ssize cb_h3_tunnel_read_data(nghttp3_conn *conn, + int64_t stream_id, + nghttp3_vec *vec, + size_t veccnt, + uint32_t *pflags, + void *user_data, + void *stream_user_data) +{ + struct Curl_cfilter *cf = user_data; + struct cf_h3_proxy_ctx *pctx = cf->ctx; + struct Curl_easy *data = CF_DATA_CURRENT(cf); + struct h3_stream_ctx *stream; + size_t nwritten = 0; + size_t nvecs = 0; + const unsigned char *buf_base; + + (void)conn; + (void)stream_id; + (void)veccnt; + (void)stream_user_data; + (void)pflags; + + stream = pctx->tunnel.stream; + if(!data || !stream || (stream->id != stream_id)) + return NGHTTP3_ERR_CALLBACK_FAILURE; + + /* nghttp3 keeps references to the sendbuf data until it is ACKed + * by the server (see `cb_h3_proxy_acked_req_body()` for updates). + * `sendbuf_len_in_flight` is the amount of bytes in `sendbuf` + * that we have already passed to nghttp3, but which have not been + * ACKed yet. + * Any amount beyond `sendbuf_len_in_flight` we need still to pass + * to nghttp3. Do that now, if we can. */ + if(stream->sendbuf_len_in_flight < Curl_bufq_len(&stream->sendbuf)) { + nvecs = 0; + while(nvecs < veccnt) { + if(!Curl_bufq_peek_at(&stream->sendbuf, + stream->sendbuf_len_in_flight, + &buf_base, + &vec[nvecs].len)) + break; + vec[nvecs].base = (uint8_t *)(uintptr_t)buf_base; + stream->sendbuf_len_in_flight += vec[nvecs].len; + nwritten += vec[nvecs].len; + ++nvecs; + } + DEBUGASSERT(nvecs > 0); /* we SHOULD have been able to peek */ + } + + if(!nwritten) { + /* Not EOF, and nothing to give, we signal WOULDBLOCK. */ + CURL_TRC_CF(data, cf, "[%" PRId64 "] read req body -> AGAIN", + stream->id); + return NGHTTP3_ERR_WOULDBLOCK; + } + + CURL_TRC_CF(data, cf, "[%" PRId64 "] read req body -> " + "%zu vecs%s with %zu (buffered=%zu)", + stream->id, nvecs, + *pflags == NGHTTP3_DATA_FLAG_EOF ? " EOF" : "", + nwritten, Curl_bufq_len(&stream->sendbuf)); + return (nghttp3_ssize)nvecs; +} + +static nghttp3_callbacks ngh3_proxy_callbacks = { + cb_h3_proxy_acked_req_body, /* acked_stream_data */ + cb_h3_proxy_stream_close, + cb_h3_proxy_recv_data, + cb_h3_proxy_deferred_consume, + NULL, /* begin_headers */ + cb_h3_proxy_recv_header, + cb_h3_proxy_end_headers, + NULL, /* begin_trailers */ + cb_h3_proxy_recv_header, + NULL, /* end_trailers */ + cb_h3_proxy_stop_sending, + NULL, /* end_stream */ + cb_h3_proxy_reset_stream, + NULL, /* shutdown */ + NULL, /* recv_settings (deprecated) */ +#ifdef NGHTTP3_CALLBACKS_V2 /* nghttp3 v1.11.0+ */ + NULL, /* recv_origin */ + NULL, /* end_origin */ + NULL, /* rand */ +#endif +#ifdef NGHTTP3_CALLBACKS_V3 /* nghttp3 v1.14.0+ */ + NULL, /* recv_settings2 */ +#endif +}; + +static CURLcode cf_ngtcp2_proxy_h3_init(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct cf_ngtcp2_ctx *ctx) +{ + int rc; + + if(ngtcp2_conn_get_streams_uni_left(ctx->qconn) < 3) { + failf(data, "QUIC connection lacks 3 uni streams to run HTTP/3"); + return CURLE_QUIC_CONNECT_ERROR; + } + + nghttp3_settings_default(&ctx->h3settings); + + rc = nghttp3_conn_client_new(&ctx->h3conn, + &ngh3_proxy_callbacks, + &ctx->h3settings, + Curl_nghttp3_mem(), + cf); + if(rc) { + failf(data, "error creating nghttp3 connection instance"); + return CURLE_OUT_OF_MEMORY; + } + + return Curl_cf_ngtcp2_h3_init_ctrls(ctx, data); +} + +static ssize_t cf_h3_proxy_recv_closed_stream(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h3_stream_ctx *stream, + CURLcode *err) +{ + ssize_t nread = -1; + *err = CURLE_OK; + + if(stream->reset) { + if(stream->error3 == CURL_H3_ERR_REQUEST_REJECTED) { + infof(data, "HTTP/3 stream %" PRId64 " refused by server, try again " + "on a new connection", stream->id); + connclose(cf->conn, "REFUSED_STREAM"); + data->state.refused_stream = TRUE; + *err = CURLE_RECV_ERROR; + goto out; + } + else if(stream->resp_hds_complete && data->req.no_body) { + CURL_TRC_CF(data, cf, "[%" PRId64 "] error after response headers, " + "but we did not want a body anyway, ignore error 0x%" + PRIx64 " %s", stream->id, stream->error3, + vquic_h3_err_str(stream->error3)); + nread = 0; + goto out; + } + failf(data, "HTTP/3 stream %" PRId64 " reset by server (error 0x%" PRIx64 + " %s)", stream->id, stream->error3, + vquic_h3_err_str(stream->error3)); + *err = data->req.bytecount ? CURLE_PARTIAL_FILE : CURLE_HTTP3; + goto out; + } + else if(!stream->resp_hds_complete) { + failf(data, + "HTTP/3 stream %" PRId64 " was closed cleanly, but before " + "getting all response header fields, treated as error", + stream->id); + *err = CURLE_HTTP3; + goto out; + } + nread = 0; + +out: + return nread; +} + +static CURLcode cf_h3_proxy_sendbuf_add(struct Curl_easy *data, + struct h3_stream_ctx *stream, + const uint8_t *buf, size_t len, + size_t *pnwritten) +{ + CURLcode result; + *pnwritten = 0; + (void)data; + + result = Curl_bufq_write(&stream->sendbuf, buf, len, pnwritten); + return result; +} + +static CURLcode cf_h3_proxy_send(struct Curl_cfilter *cf, + struct Curl_easy *data, + const uint8_t *buf, size_t len, + bool eos, size_t *pnwritten) +{ + struct cf_h3_proxy_ctx *pctx = cf->ctx; + struct cf_ngtcp2_ctx *ctx = &pctx->ngtcp2_ctx; + struct h3_stream_ctx *stream = NULL; + struct cf_call_data save; + struct cf_ngtcp2_io_ctx pktx; + CURLcode result = CURLE_OK; + + CF_DATA_SAVE(save, cf, data); + DEBUGASSERT(cf->connected); + DEBUGASSERT(ctx->qconn); + DEBUGASSERT(ctx->h3conn); + Curl_cf_ngtcp2_io_ctx_init(&pktx, cf, data); + *pnwritten = 0; + + /* handshake verification failed in callback, do not send anything */ + if(ctx->tls_vrfy_result) { + result = ctx->tls_vrfy_result; + goto denied; + } + + (void)eos; /* use for stream EOF and block handling */ + result = Curl_cf_ngtcp2_progress_ingress(cf, data, &pktx); + if(result) + goto out; + + if(pctx->tunnel.closed) { + result = CURLE_SEND_ERROR; + goto denied; + } + + stream = pctx->tunnel.stream; + if(!stream) { + result = CURLE_SEND_ERROR; + goto denied; + } + + if(stream->closed) { + if(stream->resp_hds_complete) { + /* Server decided to close the stream after having sent us a final + * response. This is valid if it is not interested in the request + * body. This happens on 30x or 40x responses. + * We silently discard the data sent, since this is not a transport + * error situation. */ + CURL_TRC_CF(data, cf, "[%" PRId64 "] discarding data" + "on closed stream with response", stream->id); + result = CURLE_OK; + *pnwritten = len; + goto out; + } + CURL_TRC_CF(data, cf, "[%" PRId64 "] send_body(len=%zu) " + "-> stream closed", stream->id, len); + result = CURLE_HTTP3; + goto out; + } + else { + result = cf_h3_proxy_sendbuf_add(data, stream, buf, len, pnwritten); + CURL_TRC_CF(data, cf, "[%" PRId64 "] cf_send, add to " + "sendbuf(len=%zu) -> %d, %zu", + stream->id, len, (int)result, *pnwritten); + if(result) + goto out; + (void)nghttp3_conn_resume_stream(ctx->h3conn, stream->id); + } + + if(*pnwritten > 0 && !ctx->tls_handshake_complete && ctx->use_earlydata) + ctx->earlydata_skip += *pnwritten; + + DEBUGASSERT(!result); + result = Curl_cf_ngtcp2_progress_egress(cf, data, &pktx); + +out: + result = Curl_1st_fatal(result, + Curl_cf_ngtcp2_cmn_set_expiry(cf, data, &pktx)); +denied: + CURL_TRC_CF(data, cf, "[%" PRId64 "] cf_send(len=%zu) -> %d, %zu", + stream ? stream->id : -1, len, (int)result, *pnwritten); + CF_DATA_RESTORE(cf, save); + return result; +} + +/* incoming data frames on the h3 stream */ +static CURLcode cf_h3_proxy_recv(struct Curl_cfilter *cf, + struct Curl_easy *data, + char *buf, size_t len, size_t *pnread) +{ + struct cf_h3_proxy_ctx *pctx = cf->ctx; + struct cf_ngtcp2_ctx *ctx = &pctx->ngtcp2_ctx; + struct h3_stream_ctx *stream = pctx->tunnel.stream; + struct cf_call_data save; + struct cf_ngtcp2_io_ctx pktx; + CURLcode result = CURLE_OK; + + CF_DATA_SAVE(save, cf, data); + DEBUGASSERT(cf->connected); + DEBUGASSERT(ctx); + DEBUGASSERT(ctx->qconn); + DEBUGASSERT(ctx->h3conn); + *pnread = 0; + + /* handshake verification failed in callback, do not recv anything */ + if(ctx->tls_vrfy_result) { + result = ctx->tls_vrfy_result; + goto denied; + } + + Curl_cf_ngtcp2_io_ctx_init(&pktx, cf, data); + + if(!stream || ctx->shutdown_started) { + result = CURLE_RECV_ERROR; + goto out; + } + + if(!Curl_bufq_is_empty(&pctx->tunnel.recvbuf)) { + result = Curl_bufq_cread(&pctx->tunnel.recvbuf, buf, len, pnread); + if(result) + goto out; + } + + result = Curl_cf_ngtcp2_progress_ingress(cf, data, &pktx); + if(result) + goto out; + + /* inbufq had nothing before, maybe after progressing ingress? */ + if(!*pnread && !Curl_bufq_is_empty(&pctx->tunnel.recvbuf)) { + result = Curl_bufq_cread(&pctx->tunnel.recvbuf, buf, len, pnread); + if(result) { + CURL_TRC_CF(data, cf, "[%" PRId64 "] read inbufq(len=%zu) -> %zu, %d", + stream->id, len, *pnread, (int)result); + goto out; + } + } + + if(*pnread) { + Curl_multi_mark_dirty(data); + } + else { + if(stream->xfer_result) { + CURL_TRC_CF(data, cf, "[%" PRId64 "] xfer write failed", stream->id); + Curl_cf_ngtcp2_h3_stream_close(cf, data, stream); + result = stream->xfer_result; + goto out; + } + else if(stream->closed) { + ssize_t nread = + cf_h3_proxy_recv_closed_stream(cf, data, stream, &result); + if(nread > 0) + *pnread = (size_t)nread; + goto out; + } + result = CURLE_AGAIN; + } + +out: + result = Curl_1st_fatal(result, + Curl_cf_ngtcp2_progress_egress(cf, data, &pktx)); + result = Curl_1st_fatal(result, + Curl_cf_ngtcp2_cmn_set_expiry(cf, data, &pktx)); +denied: + CURL_TRC_CF(data, cf, "[%" PRId64 "] cf_recv(len=%zu) -> %d, %zu", + stream ? stream->id : -1, len, (int)result, *pnread); + CF_DATA_RESTORE(cf, save); + return result; +} + +static CURLcode cf_h3_proxy_submit(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h3_tunnel_stream *ts, + struct httpreq *req) +{ + struct cf_h3_proxy_ctx *pctx = cf->ctx; + struct cf_ngtcp2_ctx *ctx = &pctx->ngtcp2_ctx; + struct h3_stream_ctx *stream = NULL; + struct dynhds h2_headers; + nghttp3_nv *nva = NULL; + size_t nheader; + int rc = 0; + unsigned int i; + nghttp3_data_reader reader; + nghttp3_data_reader *preader = NULL; + CURLcode result; + + Curl_dynhds_init(&h2_headers, 0, DYN_HTTP_REQUEST); + result = Curl_http_req_to_h2(&h2_headers, req, data); + if(result) + goto out; + + result = Curl_cf_ngtcp2_h3_stream_setup(cf, data); + if(result) + goto out; + stream = H3_STREAM_CTX(ctx, data); + DEBUGASSERT(stream); + if(!stream) { + result = CURLE_FAILED_INIT; + goto out; + } + + nheader = Curl_dynhds_count(&h2_headers); + nva = curlx_malloc(sizeof(nghttp3_nv) * nheader); + if(!nva) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + for(i = 0; i < nheader; ++i) { + struct dynhds_entry *e = Curl_dynhds_getn(&h2_headers, i); + nva[i].name = (unsigned char *)e->name; + nva[i].namelen = e->namelen; + nva[i].value = (unsigned char *)e->value; + nva[i].valuelen = e->valuelen; + nva[i].flags = NGHTTP3_NV_FLAG_NONE; + } + + /* Open a bidirectional stream */ + { + int64_t sid; + int rv; + + DEBUGASSERT(stream->id == -1); + /* Do NOT set `data` as stream user data. The transfer `data` may + * get cleaned up long before the tunnel goes down. */ + rv = ngtcp2_conn_open_bidi_stream(ctx->qconn, &sid, NULL); + if(rv) { + failf(data, "cannot get bidi streams: %s", ngtcp2_strerror(rv)); + result = CURLE_SEND_ERROR; + goto out; + } + stream->id = sid; + ts->stream = stream; + ++ctx->used_bidi_streams; + CURL_TRC_CF(data, cf, "[%" PRId64 "] opened bidi stream", sid); + } + + /* CONNECT-UDP request stream remains open for capsules, no fixed EOF. */ + stream->send_closed = 0; + reader.read_data = cb_h3_tunnel_read_data; + preader = &reader; + + rc = nghttp3_conn_submit_request(ctx->h3conn, stream->id, + nva, nheader, preader, data); + + if(rc) { + switch(rc) { + case NGHTTP3_ERR_CONN_CLOSING: + CURL_TRC_CF(data, cf, "h3sid[%" PRId64 "] failed to send, " + "connection is closing", stream->id); + break; + default: + CURL_TRC_CF(data, cf, "h3sid[%" PRId64 "] failed to send -> %d (%s)", + stream->id, rc, nghttp3_strerror(rc)); + break; + } + result = CURLE_SEND_ERROR; + goto out; + } + + if(Curl_trc_is_verbose(data)) { + CURL_TRC_CF(data, cf, "[H3-PROXY] [%" PRId64 "] OPENED stream " + "for %s", stream->id, + Curl_bufref_ptr(&data->state.url)); + } + +out: + curlx_free(nva); + Curl_dynhds_free(&h2_headers); + return result; +} + +static CURLcode cf_h3_proxy_adjust_pollset(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct easy_pollset *ps) +{ + struct cf_h3_proxy_ctx *pctx = cf->ctx; + struct cf_ngtcp2_ctx *ctx = &pctx->ngtcp2_ctx; + bool want_recv, want_send; + CURLcode result = CURLE_OK; + curl_socket_t sock = (ctx->q.sockfd != CURL_SOCKET_BAD) ? + ctx->q.sockfd : Curl_conn_cf_get_socket(cf, data); + + if(!ctx->qconn || !pctx->tunnel.stream || (sock == CURL_SOCKET_BAD)) + return CURLE_OK; + + Curl_pollset_check(data, ps, sock, &want_recv, &want_send); + + if(want_recv || want_send || !Curl_bufq_is_empty(&ctx->q.sendbuf)) { + struct h3_stream_ctx *stream = pctx->tunnel.stream; + bool c_exhaust, s_exhaust; + + c_exhaust = want_send && + (!ngtcp2_conn_get_cwnd_left(ctx->qconn) || + !ngtcp2_conn_get_max_data_left(ctx->qconn)); + s_exhaust = want_send && stream && stream->id >= 0 && + stream->quic_flow_blocked; + want_recv = (want_recv || c_exhaust || s_exhaust); + want_send = (!s_exhaust && want_send) || + !Curl_bufq_is_empty(&ctx->q.sendbuf); + + result = Curl_pollset_set(data, ps, sock, want_recv, want_send); + } + return result; +} + +static bool cf_h3_proxy_data_pending(struct Curl_cfilter *cf, + const struct Curl_easy *data) +{ + struct cf_h3_proxy_ctx *pctx = cf->ctx; + if(!Curl_bufq_is_empty(&pctx->tunnel.recvbuf)) + return TRUE; + return cf->next ? + cf->next->cft->has_data_pending(cf->next, data) : FALSE; +} + +static CURLcode cf_h3_proxy_submit_CONNECT(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h3_tunnel_stream *ts) +{ + CURLcode result; + struct httpreq *req = NULL; + + result = Curl_http_proxy_create_tunnel_request(&req, cf, data, + ts->peer, + PROXY_HTTP_V3, + (bool)ts->udp); + if(!result) + result = Curl_creader_set_null(data); + if(!result) + result = cf_h3_proxy_submit(cf, data, ts, req); + + if(req) + Curl_http_req_free(req); + if(result) + failf(data, "Failed sending CONNECT to proxy"); + return result; +} + +static CURLcode cf_h3_proxy_inspect_response(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h3_tunnel_stream *ts) +{ + struct cf_h3_proxy_ctx *pctx = cf->ctx; + proxy_inspect_result res; + CURLcode result; + + result = Curl_http_proxy_inspect_tunnel_response( + cf, data, ts->resp, (bool)pctx->tunnel.udp, &res); + if(result) + return result; + switch(res) { + case PROXY_INSPECT_OK: + h3_tunnel_go_state(cf, ts, H3_TUNNEL_ESTABLISHED, data); + break; + case PROXY_INSPECT_FAILED: + h3_tunnel_go_state(cf, ts, H3_TUNNEL_FAILED, data); + result = CURLE_COULDNT_CONNECT; + break; + case PROXY_INSPECT_AUTH_RETRY: + h3_tunnel_go_state(cf, ts, H3_TUNNEL_INIT, data); + break; + } + return result; +} + +static CURLcode cf_h3_proxy_tunnel(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h3_tunnel_stream *ts, + bool *pdone) +{ + struct cf_h3_proxy_ctx *ctx = cf->ctx; + CURLcode result = CURLE_OK; + + DEBUGASSERT(ts); + DEBUGASSERT(ts->authority); + *pdone = FALSE; + do { + switch(ts->state) { + case H3_TUNNEL_INIT: + CURL_TRC_CF(data, cf, "[0] CONNECT start for %s", ts->authority); + result = cf_h3_proxy_submit_CONNECT(cf, data, ts); + if(result) + goto out; + h3_tunnel_go_state(cf, ts, H3_TUNNEL_CONNECT, data); + + result = Curl_cf_ngtcp2_progress_egress(cf, data, NULL); + if(result) + goto out; + FALLTHROUGH(); + + case H3_TUNNEL_CONNECT: + /* Non-blocking: call ingress/egress once and return. + * The multi interface will call us again when ready. */ + result = Curl_cf_ngtcp2_progress_ingress(cf, data, NULL); + if(result) + goto out; + result = Curl_cf_ngtcp2_progress_egress(cf, data, NULL); + if(result && result != CURLE_AGAIN) { + h3_tunnel_go_state(cf, ts, H3_TUNNEL_FAILED, data); + goto out; + } + + if(ts->has_final_response) { + h3_tunnel_go_state(cf, ts, H3_TUNNEL_RESPONSE, data); + } + else { + /* Not done yet, return and let multi interface call us again */ + result = CURLE_OK; + goto out; + } + FALLTHROUGH(); + + case H3_TUNNEL_RESPONSE: + DEBUGASSERT(ts->has_final_response); + result = cf_h3_proxy_inspect_response(cf, data, ts); + if(result) + goto out; + ctx->connected = TRUE; + break; + + case H3_TUNNEL_ESTABLISHED: + *pdone = TRUE; + return CURLE_OK; + + case H3_TUNNEL_FAILED: + return CURLE_RECV_ERROR; + + default: + break; + } + + } while(ts->state == H3_TUNNEL_INIT); + +out: + if((result && (result != CURLE_AGAIN)) || ctx->tunnel.closed) + h3_tunnel_go_state(cf, ts, H3_TUNNEL_FAILED, data); + return result; +} + +static CURLcode cf_h3_proxy_connect(struct Curl_cfilter *cf, + struct Curl_easy *data, bool *done) +{ + struct cf_h3_proxy_ctx *pctx = cf->ctx; + struct cf_call_data save = { 0 }; + CURLcode result = CURLE_OK; + struct h3_tunnel_stream *ts = &pctx->tunnel; + bool data_saved = FALSE; + + result = Curl_cf_ngtcp2_cmn_connect(cf, data, done); + if(result || !*done) + goto out; + + CF_DATA_SAVE(save, cf, data); + data_saved = TRUE; + + /* At this point the QUIC is connected, but the proxy is not connected */ + result = cf_h3_proxy_tunnel(cf, data, ts, done); + +out: + if(*done) { + cf->connected = TRUE; + /* The real request will follow the CONNECT, reset request partially */ + Curl_req_soft_reset(&data->req, data); + Curl_client_reset(data); + } + + if(data_saved) + CF_DATA_RESTORE(cf, save); + return result; +} + +static void cf_h3_proxy_destroy(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_h3_proxy_ctx *ctx = cf->ctx; + + (void)data; + if(ctx) { + CURL_TRC_CF(data, cf, "cf_h3_proxy_destroy()"); + cf_h3_proxy_ctx_free(ctx); + cf->ctx = NULL; + } +} + +static CURLcode cf_h3_proxy_shutdown(struct Curl_cfilter *cf, + struct Curl_easy *data, bool *done) +{ + return Curl_cf_ngtcp2_cmn_shutdown(cf, data, done); +} + +struct Curl_cftype Curl_cft_h3_proxy = { + "H3-PROXY", + CF_TYPE_IP_CONNECT | CF_TYPE_PROXY | CF_TYPE_SSL, + CURL_LOG_LVL_NONE, + cf_h3_proxy_destroy, + cf_h3_proxy_connect, + cf_h3_proxy_shutdown, + cf_h3_proxy_adjust_pollset, + cf_h3_proxy_data_pending, + cf_h3_proxy_send, + cf_h3_proxy_recv, + Curl_cf_def_cntrl, + Curl_cf_ngtcp2_cmn_conn_is_alive, + Curl_cf_def_conn_keep_alive, + Curl_cf_def_query, +}; + +CURLcode Curl_cf_ngtcp2_proxy_create(struct Curl_cfilter **pcf, + struct Curl_easy *data, + struct Curl_peer *origin, + struct Curl_peer *peer, + uint8_t transport_peer, + struct connectdata *conn, + struct Curl_sockaddr_ex *addr, + struct Curl_peer *tunnel_peer, + uint8_t tunnel_transport) +{ + struct Curl_cfilter *cf = NULL; + struct cf_h3_proxy_ctx *ctx; + CURLcode result = CURLE_OUT_OF_MEMORY; + + if(!tunnel_peer) + return CURLE_FAILED_INIT; + if((transport_peer != TRNSPRT_QUIC) || (!conn->http_proxy.peer)) + return CURLE_FAILED_INIT; + + ctx = curlx_calloc(1, sizeof(*ctx)); + if(!ctx) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + result = cf_h3_proxy_ctx_init(ctx, origin, peer, &conn->proxy_ssl_config, + tunnel_peer, tunnel_transport); + if(result) + goto out; + + result = Curl_cf_create(&cf, &Curl_cft_h3_proxy, ctx); + if(result) + goto out; + cf->conn = conn; + + result = Curl_cf_udp_create(&cf->next, data, origin, peer, TRNSPRT_QUIC, + conn, addr, NULL, TRNSPRT_QUIC); + if(result) + goto out; + cf->next->conn = cf->conn; + cf->next->sockindex = cf->sockindex; + +out: + *pcf = (!result) ? cf : NULL; + if(result) { + if(cf) + Curl_conn_cf_discard_chain(&cf, data); + else if(ctx) + cf_h3_proxy_ctx_free(ctx); + } + else + CURL_TRC_CF(data, cf, "created, udp_tunnel=%d", ctx->tunnel.udp); + return result; +} + +CURLcode Curl_cf_ngtcp2_proxy_insert_after(struct Curl_cfilter *cf_at, + struct Curl_easy *data, + struct Curl_peer *origin, + struct Curl_peer *peer, + struct Curl_peer *tunnel_peer, + uint8_t tunnel_transport) +{ + struct Curl_cfilter *cf = NULL; + struct cf_h3_proxy_ctx *ctx; + CURLcode result = CURLE_OUT_OF_MEMORY; + (void)data; + + ctx = curlx_calloc(1, sizeof(*ctx)); + if(!ctx) + goto out; + result = cf_h3_proxy_ctx_init(ctx, origin, peer, + &cf_at->conn->proxy_ssl_config, + tunnel_peer, tunnel_transport); + if(result) + goto out; + + result = Curl_cf_create(&cf, &Curl_cft_h3_proxy, ctx); + if(result) + goto out; + + /* H3-PROXY uses the UDP socket created by happy eyeballs below it. + Curl_conn_cf_insert_after chains the existing sub-filters, i.e. + "HAPPY-EYEBALLS -> UDP" as cf->next of H3-PROXY. */ + Curl_conn_cf_insert_after(cf_at, cf); + +out: + if(result) { + if(cf) + Curl_conn_cf_discard_chain(&cf, data); + else if(ctx) + cf_h3_proxy_ctx_free(ctx); + } + return result; +} + +#endif diff --git a/3rdparty/curl-8.21.0/lib/vquic/cf-ngtcp2-proxy.h b/3rdparty/curl-8.21.0/lib/vquic/cf-ngtcp2-proxy.h new file mode 100644 index 0000000000..acdee0e463 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vquic/cf-ngtcp2-proxy.h @@ -0,0 +1,52 @@ +#ifndef HEADER_CURL_VQUIC_CF_NGTCP2_PROXY_H +#define HEADER_CURL_VQUIC_CF_NGTCP2_PROXY_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_HTTP) && !defined(CURL_DISABLE_PROXY) && \ + defined(USE_PROXY_HTTP3) && defined(USE_NGHTTP3) && \ + defined(USE_NGTCP2) && defined(USE_OPENSSL) + +CURLcode Curl_cf_ngtcp2_proxy_insert_after(struct Curl_cfilter *cf_at, + struct Curl_easy *data, + struct Curl_peer *origin, + struct Curl_peer *peer, + struct Curl_peer *tunnel_peer, + uint8_t tunnel_transport); + +CURLcode Curl_cf_ngtcp2_proxy_create(struct Curl_cfilter **pcf, + struct Curl_easy *data, + struct Curl_peer *origin, + struct Curl_peer *peer, + uint8_t transport_peer, + struct connectdata *conn, + struct Curl_sockaddr_ex *addr, + struct Curl_peer *tunnel_peer, + uint8_t tunnel_transport); + +#endif + +#endif /* HEADER_CURL_VQUIC_CF_NGTCP2_PROXY_H */ diff --git a/3rdparty/curl-8.21.0/lib/vquic/cf-ngtcp2.c b/3rdparty/curl-8.21.0/lib/vquic/cf-ngtcp2.c new file mode 100644 index 0000000000..be1a3257c3 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vquic/cf-ngtcp2.c @@ -0,0 +1,1166 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_HTTP) && defined(USE_NGTCP2) && defined(USE_NGHTTP3) + +#include "urldata.h" +#include "url.h" +#include "uint-hash.h" +#include "curl_trc.h" +#include "rand.h" +#include "multiif.h" +#include "cfilters.h" +#include "cf-dns.h" +#include "cf-socket.h" +#include "connect.h" +#include "progress.h" +#include "curlx/fopen.h" +#include "curlx/dynbuf.h" +#include "http1.h" +#include "select.h" +#include "transfer.h" +#include "bufref.h" +#include "vquic/vquic.h" +#include "vquic/vquic_int.h" +#include "vquic/cf-ngtcp2-cmn.h" +#include "vquic/cf-ngtcp2.h" + + +static int cb_h3_acked_req_body(nghttp3_conn *conn, int64_t stream_id, + uint64_t datalen, void *user_data, + void *stream_user_data); + +static CURLcode cf_ngtcp2_adjust_pollset(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct easy_pollset *ps) +{ + struct cf_ngtcp2_ctx *ctx = cf->ctx; + bool want_recv, want_send; + CURLcode result = CURLE_OK; + curl_socket_t sock = (ctx->q.sockfd != CURL_SOCKET_BAD) ? + ctx->q.sockfd : Curl_conn_cf_get_socket(cf, data); + + if(!ctx->qconn || (sock == CURL_SOCKET_BAD)) + return CURLE_OK; + + Curl_pollset_check(data, ps, sock, &want_recv, &want_send); + if(!want_send && !Curl_bufq_is_empty(&ctx->q.sendbuf)) + want_send = TRUE; + + if(want_recv || want_send) { + struct h3_stream_ctx *stream = H3_STREAM_CTX(ctx, data); + struct cf_call_data save; + bool c_exhaust, s_exhaust; + + CF_DATA_SAVE(save, cf, data); + c_exhaust = want_send && (!ngtcp2_conn_get_cwnd_left(ctx->qconn) || + !ngtcp2_conn_get_max_data_left(ctx->qconn)); + s_exhaust = want_send && stream && stream->id >= 0 && + stream->quic_flow_blocked; + want_recv = (want_recv || c_exhaust || s_exhaust); + want_send = (!s_exhaust && want_send) || + !Curl_bufq_is_empty(&ctx->q.sendbuf); + + result = Curl_pollset_set(data, ps, sock, want_recv, want_send); + CF_DATA_RESTORE(cf, save); + } + return result; +} + +static int cb_h3_stream_close(nghttp3_conn *conn, int64_t stream_id, + uint64_t app_error_code, void *user_data, + void *stream_user_data) +{ + struct Curl_cfilter *cf = user_data; + struct cf_ngtcp2_ctx *ctx = cf->ctx; + struct Curl_easy *data = stream_user_data; + struct h3_stream_ctx *stream = H3_STREAM_CTX(ctx, data); + (void)conn; + (void)stream_id; + + /* we might be called by nghttp3 after we already cleaned up */ + if(!stream) + return 0; + + stream->closed = TRUE; + stream->error3 = app_error_code; + if(stream->error3 != NGHTTP3_H3_NO_ERROR) { + stream->reset = TRUE; + stream->send_closed = TRUE; + CURL_TRC_CF(data, cf, "[%" PRId64 "] RESET: error %" PRIu64, + stream->id, stream->error3); + } + else { + CURL_TRC_CF(data, cf, "[%" PRId64 "] CLOSED", stream->id); + } + Curl_multi_mark_dirty(data); + return 0; +} + +static void h3_xfer_write_resp_hd(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h3_stream_ctx *stream, + const char *buf, size_t buflen, bool eos) +{ + /* This function returns no error intentionally, but records + * the result at the stream, skipping further writes once the + * `result` of the transfer is known. + * The stream is subsequently cancelled "higher up" in the filter's + * send/recv callbacks. Closing the stream here leads to SEND/RECV + * errors in other places that then overwrite the transfer's result. */ + if(!stream->xfer_result) { + stream->xfer_result = Curl_xfer_write_resp_hd(data, buf, buflen, eos); + if(stream->xfer_result) + CURL_TRC_CF(data, cf, "[%" PRId64 "] error %d writing %zu " + "bytes of headers", stream->id, (int)stream->xfer_result, + buflen); + } +} + +static void h3_xfer_write_resp(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h3_stream_ctx *stream, + const char *buf, size_t buflen, bool eos) +{ + /* This function returns no error intentionally, but records + * the result at the stream, skipping further writes once the + * `result` of the transfer is known. + * The stream is subsequently cancelled "higher up" in the filter's + * send/recv callbacks. Closing the stream here leads to SEND/RECV + * errors in other places that then overwrite the transfer's result. */ + if(!stream->xfer_result) { + stream->xfer_result = Curl_xfer_write_resp(data, buf, buflen, eos); + /* If the transfer write is errored, we do not want any more data */ + if(stream->xfer_result) { + CURL_TRC_CF(data, cf, "[%" PRId64 "] error %d writing %zu bytes of data", + stream->id, (int)stream->xfer_result, buflen); + } + } +} + +static void cf_ngtcp2_upd_rx_win(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h3_stream_ctx *stream) +{ + struct cf_ngtcp2_ctx *ctx = cf->ctx; + uint64_t cur_win, wanted_win = H3_STREAM_WINDOW_SIZE_MAX; + + /* how much does rate limiting allow us to acknowledge? */ + if(Curl_rlimit_active(&data->progress.dl.rlimit)) { + int64_t avail; + + /* start rate limit updates only after first bytes arrived */ + if(!stream->rx_offset) + return; + + avail = Curl_rlimit_avail(&data->progress.dl.rlimit, Curl_pgrs_now(data)); + if(avail <= 0) { + /* nothing available, do not extend the rx offset */ + CURL_TRC_CF(data, cf, "[%" PRId64 "] dl rate limit exhausted (%" PRId64 + " tokens)", stream->id, avail); + return; + } + wanted_win = CURLMIN((uint64_t)avail, H3_STREAM_WINDOW_SIZE_MAX); + } + + if(stream->rx_offset_max < stream->rx_offset) { + DEBUGASSERT(0); + return; + } + cur_win = stream->rx_offset_max - stream->rx_offset; + + if(wanted_win > cur_win) { + uint64_t delta = wanted_win - cur_win; + + if(UINT64_MAX - delta < stream->rx_offset_max) + delta = UINT64_MAX - stream->rx_offset_max; + if(delta) { + CURL_TRC_CF(data, cf, "[%" PRId64 "] rx window, extend by %" PRIu64 + " bytes", stream->id, delta); + stream->rx_offset_max += delta; + ngtcp2_conn_extend_max_stream_offset(ctx->qconn, stream->id, delta); + } + } +} + +static int cb_h3_recv_data(nghttp3_conn *conn, int64_t stream3_id, + const uint8_t *buf, size_t buflen, + void *user_data, void *stream_user_data) +{ + struct Curl_cfilter *cf = user_data; + struct cf_ngtcp2_ctx *ctx = cf->ctx; + struct Curl_easy *data = stream_user_data; + struct h3_stream_ctx *stream = H3_STREAM_CTX(ctx, data); + + (void)conn; + (void)stream3_id; + + if(!stream) + return NGHTTP3_ERR_CALLBACK_FAILURE; + + h3_xfer_write_resp(cf, data, stream, (const char *)buf, buflen, FALSE); + + ngtcp2_conn_extend_max_offset(ctx->qconn, buflen); + stream->rx_offset += buflen; + if(stream->rx_offset_max < stream->rx_offset) + stream->rx_offset_max = stream->rx_offset; + + CURL_TRC_CF(data, cf, "[%" PRId64 "] DATA len=%zu, rx win=%" PRIu64, + stream->id, buflen, stream->rx_offset_max - stream->rx_offset); + cf_ngtcp2_upd_rx_win(cf, data, stream); + return 0; +} + +static int cb_h3_deferred_consume(nghttp3_conn *conn, int64_t stream3_id, + size_t consumed, void *user_data, + void *stream_user_data) +{ + struct Curl_cfilter *cf = user_data; + struct cf_ngtcp2_ctx *ctx = cf->ctx; + struct Curl_easy *data = stream_user_data; + struct h3_stream_ctx *stream = H3_STREAM_CTX(ctx, data); + (void)conn; + + /* nghttp3 has consumed bytes on the QUIC stream and we need to + * tell the QUIC connection to increase its flow control */ + ngtcp2_conn_extend_max_stream_offset(ctx->qconn, stream3_id, consumed); + ngtcp2_conn_extend_max_offset(ctx->qconn, consumed); + if(stream) { + stream->rx_offset += consumed; + stream->rx_offset_max += consumed; + } + return 0; +} + +static int cb_h3_end_headers(nghttp3_conn *conn, int64_t stream_id, + int fin, void *user_data, void *stream_user_data) +{ + struct Curl_cfilter *cf = user_data; + struct cf_ngtcp2_ctx *ctx = cf->ctx; + struct Curl_easy *data = stream_user_data; + struct h3_stream_ctx *stream = H3_STREAM_CTX(ctx, data); + (void)conn; + (void)stream_id; + (void)fin; + (void)cf; + + if(!stream) + return 0; + /* add a CRLF only if we have received some headers */ + h3_xfer_write_resp_hd(cf, data, stream, STRCONST("\r\n"), + (bool)stream->closed); + + CURL_TRC_CF(data, cf, "[%" PRId64 "] end_headers, status=%d", + stream_id, stream->status_code); + if(stream->status_code / 100 != 1) { + stream->resp_hds_complete = TRUE; + } + Curl_multi_mark_dirty(data); + return 0; +} + +static int cb_h3_recv_header(nghttp3_conn *conn, int64_t stream_id, + int32_t token, nghttp3_rcbuf *name, + nghttp3_rcbuf *value, uint8_t flags, + void *user_data, void *stream_user_data) +{ + struct Curl_cfilter *cf = user_data; + struct cf_ngtcp2_ctx *ctx = cf->ctx; + nghttp3_vec h3name = nghttp3_rcbuf_get_buf(name); + nghttp3_vec h3val = nghttp3_rcbuf_get_buf(value); + struct Curl_easy *data = stream_user_data; + struct h3_stream_ctx *stream = H3_STREAM_CTX(ctx, data); + CURLcode result = CURLE_OK; + (void)conn; + (void)stream_id; + (void)token; + (void)flags; + (void)cf; + + /* we might have cleaned up this transfer already */ + if(!stream) + return 0; + + if(token == NGHTTP3_QPACK_TOKEN__STATUS) { + + result = Curl_http_decode_status(&stream->status_code, + (const char *)h3val.base, h3val.len); + if(result) + return NGHTTP3_ERR_CALLBACK_FAILURE; + curlx_dyn_reset(&ctx->scratch); + result = curlx_dyn_addn(&ctx->scratch, STRCONST("HTTP/3 ")); + if(!result) + result = curlx_dyn_addn(&ctx->scratch, + (const char *)h3val.base, h3val.len); + if(!result) + result = curlx_dyn_addn(&ctx->scratch, STRCONST(" \r\n")); + if(!result) + h3_xfer_write_resp_hd(cf, data, stream, curlx_dyn_ptr(&ctx->scratch), + curlx_dyn_len(&ctx->scratch), FALSE); + CURL_TRC_CF(data, cf, "[%" PRId64 "] status: %s", + stream_id, curlx_dyn_ptr(&ctx->scratch)); + if(result) { + return NGHTTP3_ERR_CALLBACK_FAILURE; + } + } + else { + /* store as an HTTP1-style header */ + CURL_TRC_CF(data, cf, "[%" PRId64 "] header: %.*s: %.*s", + stream_id, (int)h3name.len, h3name.base, + (int)h3val.len, h3val.base); + curlx_dyn_reset(&ctx->scratch); + result = curlx_dyn_addn(&ctx->scratch, + (const char *)h3name.base, h3name.len); + if(!result) + result = curlx_dyn_addn(&ctx->scratch, STRCONST(": ")); + if(!result) + result = curlx_dyn_addn(&ctx->scratch, + (const char *)h3val.base, h3val.len); + if(!result) + result = curlx_dyn_addn(&ctx->scratch, STRCONST("\r\n")); + if(!result) + h3_xfer_write_resp_hd(cf, data, stream, curlx_dyn_ptr(&ctx->scratch), + curlx_dyn_len(&ctx->scratch), FALSE); + } + return 0; +} + +static int cb_h3_stop_sending(nghttp3_conn *conn, int64_t stream_id, + uint64_t app_error_code, void *user_data, + void *stream_user_data) +{ + struct Curl_cfilter *cf = user_data; + struct cf_ngtcp2_ctx *ctx = cf->ctx; + int rv; + (void)conn; + (void)stream_user_data; + + rv = ngtcp2_conn_shutdown_stream_read(ctx->qconn, 0, stream_id, + app_error_code); + if(rv && rv != NGTCP2_ERR_STREAM_NOT_FOUND) { + return NGHTTP3_ERR_CALLBACK_FAILURE; + } + + return 0; +} + +static int cb_h3_reset_stream(nghttp3_conn *conn, int64_t stream_id, + uint64_t app_error_code, void *user_data, + void *stream_user_data) +{ + struct Curl_cfilter *cf = user_data; + struct cf_ngtcp2_ctx *ctx = cf->ctx; + struct Curl_easy *data = stream_user_data; + int rv; + (void)conn; + + rv = ngtcp2_conn_shutdown_stream_write(ctx->qconn, 0, stream_id, + app_error_code); + CURL_TRC_CF(data, cf, "[%" PRId64 "] reset -> %d", stream_id, rv); + if(rv && rv != NGTCP2_ERR_STREAM_NOT_FOUND) { + return NGHTTP3_ERR_CALLBACK_FAILURE; + } + + return 0; +} + +static nghttp3_callbacks ngh3_callbacks = { + cb_h3_acked_req_body, /* acked_stream_data */ + cb_h3_stream_close, + cb_h3_recv_data, + cb_h3_deferred_consume, + NULL, /* begin_headers */ + cb_h3_recv_header, + cb_h3_end_headers, + NULL, /* begin_trailers */ + cb_h3_recv_header, + NULL, /* end_trailers */ + cb_h3_stop_sending, + NULL, /* end_stream */ + cb_h3_reset_stream, + NULL, /* shutdown */ + NULL, /* recv_settings (deprecated) */ +#ifdef NGHTTP3_CALLBACKS_V2 /* nghttp3 v1.11.0+ */ + NULL, /* recv_origin */ + NULL, /* end_origin */ + NULL, /* rand */ +#endif +#ifdef NGHTTP3_CALLBACKS_V3 /* nghttp3 v1.14.0+ */ + NULL, /* recv_settings2 */ +#endif +}; + +static CURLcode init_ngh3_conn(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct cf_ngtcp2_ctx *ctx) +{ + int rc; + + if(ngtcp2_conn_get_streams_uni_left(ctx->qconn) < 3) { + failf(data, "QUIC connection lacks 3 uni streams to run HTTP/3"); + return CURLE_QUIC_CONNECT_ERROR; + } + + nghttp3_settings_default(&ctx->h3settings); + + rc = nghttp3_conn_client_new(&ctx->h3conn, + &ngh3_callbacks, + &ctx->h3settings, + Curl_nghttp3_mem(), + cf); + if(rc) { + failf(data, "error creating nghttp3 connection instance"); + return CURLE_OUT_OF_MEMORY; + } + + return Curl_cf_ngtcp2_h3_init_ctrls(ctx, data); +} + +static CURLcode recv_closed_stream(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h3_stream_ctx *stream, + size_t *pnread) +{ + (void)cf; + *pnread = 0; + if(stream->reset) { + if(stream->error3 == CURL_H3_ERR_REQUEST_REJECTED) { + infof(data, "HTTP/3 stream %" PRId64 " refused by server, try again " + "on a new connection", stream->id); + connclose(cf->conn, "REFUSED_STREAM"); /* do not use this anymore */ + data->state.refused_stream = TRUE; + return CURLE_RECV_ERROR; /* trigger Curl_retry_request() later */ + } + else if(stream->resp_hds_complete && data->req.no_body) { + CURL_TRC_CF(data, cf, "[%" PRId64 "] error after response headers, " + "but we did not want a body anyway, ignore error 0x%" + PRIx64 " %s", stream->id, stream->error3, + vquic_h3_err_str(stream->error3)); + return CURLE_OK; + } + failf(data, "HTTP/3 stream %" PRId64 " reset by server (error 0x%" PRIx64 + " %s)", stream->id, stream->error3, + vquic_h3_err_str(stream->error3)); + return data->req.bytecount ? CURLE_PARTIAL_FILE : CURLE_HTTP3; + } + else if(!stream->resp_hds_complete) { + failf(data, + "HTTP/3 stream %" PRId64 " was closed cleanly, but before " + "getting all response header fields, treated as error", + stream->id); + return CURLE_HTTP3; + } + return CURLE_OK; +} + +/* incoming data frames on the h3 stream */ +static CURLcode cf_ngtcp2_recv(struct Curl_cfilter *cf, struct Curl_easy *data, + char *buf, size_t buflen, size_t *pnread) +{ + struct cf_ngtcp2_ctx *ctx = cf->ctx; + struct h3_stream_ctx *stream = H3_STREAM_CTX(ctx, data); + struct cf_call_data save; + struct cf_ngtcp2_io_ctx pktx; + CURLcode result = CURLE_OK; + int i; + + (void)ctx; + (void)buf; + NOVERBOSE((void)buflen); + + CF_DATA_SAVE(save, cf, data); + DEBUGASSERT(cf->connected); + DEBUGASSERT(ctx); + DEBUGASSERT(ctx->qconn); + DEBUGASSERT(ctx->h3conn); + *pnread = 0; + + /* handshake verification failed in callback, do not recv anything */ + if(ctx->tls_vrfy_result) { + result = ctx->tls_vrfy_result; + goto denied; + } + + Curl_cf_ngtcp2_io_ctx_init(&pktx, cf, data); + + if(!stream || ctx->shutdown_started) { + result = CURLE_RECV_ERROR; + goto out; + } + + cf_ngtcp2_upd_rx_win(cf, data, stream); + + /* first check for results/closed already known without touching + * the connection. For an already failed/closed stream, errors on + * the connection do not count. + * Then handle incoming data and check for failed/closed again. + */ + for(i = 0; i < 2; ++i) { + if(stream->xfer_result) { + CURL_TRC_CF(data, cf, "[%" PRId64 "] xfer write failed", stream->id); + Curl_cf_ngtcp2_h3_stream_close(cf, data, stream); + result = stream->xfer_result; + goto out; + } + else if(stream->closed) { + result = recv_closed_stream(cf, data, stream, pnread); + goto out; + } + + if(!i && Curl_cf_ngtcp2_progress_ingress(cf, data, &pktx)) { + result = CURLE_RECV_ERROR; + goto out; + } + } + + result = CURLE_AGAIN; + +out: + result = Curl_1st_fatal(result, + Curl_cf_ngtcp2_progress_egress(cf, data, &pktx)); + result = Curl_1st_fatal(result, + Curl_cf_ngtcp2_cmn_set_expiry(cf, data, &pktx)); + if(ctx->tls_vrfy_result) + result = ctx->tls_vrfy_result; +denied: + CURL_TRC_CF(data, cf, "[%" PRId64 "] cf_recv(buflen=%zu) -> %d, %zu", + stream ? stream->id : -1, buflen, (int)result, *pnread); + CF_DATA_RESTORE(cf, save); + return result; +} + +static int cb_h3_acked_req_body(nghttp3_conn *conn, int64_t stream_id, + uint64_t datalen, void *user_data, + void *stream_user_data) +{ + struct Curl_cfilter *cf = user_data; + struct cf_ngtcp2_ctx *ctx = cf->ctx; + struct Curl_easy *data = stream_user_data; + struct h3_stream_ctx *stream = H3_STREAM_CTX(ctx, data); + size_t skiplen; + + (void)cf; + if(!stream) + return 0; + /* The server acknowledged `datalen` of bytes from our request body. + * This is a delta. We have kept this data in `sendbuf` for + * re-transmissions and can free it now. */ + if(datalen >= (uint64_t)stream->sendbuf_len_in_flight) + skiplen = stream->sendbuf_len_in_flight; + else + skiplen = (size_t)datalen; + Curl_bufq_skip(&stream->sendbuf, skiplen); + stream->sendbuf_len_in_flight -= skiplen; + + /* Resume upload processing if we have more data to send */ + if(stream->sendbuf_len_in_flight < Curl_bufq_len(&stream->sendbuf)) { + int rv = nghttp3_conn_resume_stream(conn, stream_id); + if(rv && rv != NGHTTP3_ERR_STREAM_NOT_FOUND) { + return NGHTTP3_ERR_CALLBACK_FAILURE; + } + } + return 0; +} + +static nghttp3_ssize cb_h3_read_req_body(nghttp3_conn *conn, int64_t stream_id, + nghttp3_vec *vec, size_t veccnt, + uint32_t *pflags, void *user_data, + void *stream_user_data) +{ + struct Curl_cfilter *cf = user_data; + struct cf_ngtcp2_ctx *ctx = cf->ctx; + struct Curl_easy *data = stream_user_data; + struct h3_stream_ctx *stream = H3_STREAM_CTX(ctx, data); + size_t nwritten = 0; + size_t nvecs = 0; + (void)cf; + (void)conn; + (void)stream_id; + (void)user_data; + (void)veccnt; + + if(!stream) + return NGHTTP3_ERR_CALLBACK_FAILURE; + /* nghttp3 keeps references to the sendbuf data until it is ACKed + * by the server (see `cb_h3_acked_req_body()` for updates). + * `sendbuf_len_in_flight` is the amount of bytes in `sendbuf` + * that we have already passed to nghttp3, but which have not been + * ACKed yet. + * Any amount beyond `sendbuf_len_in_flight` we need still to pass + * to nghttp3. Do that now, if we can. */ + if(stream->sendbuf_len_in_flight < Curl_bufq_len(&stream->sendbuf)) { + nvecs = 0; + while(nvecs < veccnt && + Curl_bufq_peek_at(&stream->sendbuf, + stream->sendbuf_len_in_flight, + CURL_UNCONST(&vec[nvecs].base), + &vec[nvecs].len)) { + stream->sendbuf_len_in_flight += vec[nvecs].len; + nwritten += vec[nvecs].len; + ++nvecs; + } + DEBUGASSERT(nvecs > 0); /* we SHOULD have been be able to peek */ + } + + if(nwritten > 0 && stream->upload_left != -1) + stream->upload_left -= nwritten; + + /* When we stopped sending and everything in `sendbuf` is "in flight", + * we are at the end of the request body. */ + if(stream->upload_left == 0) { + *pflags = NGHTTP3_DATA_FLAG_EOF; + stream->send_closed = TRUE; + } + else if(!nwritten) { + /* Not EOF, and nothing to give, we signal WOULDBLOCK. */ + CURL_TRC_CF(data, cf, "[%" PRId64 "] read req body -> AGAIN", stream->id); + return NGHTTP3_ERR_WOULDBLOCK; + } + + CURL_TRC_CF(data, cf, "[%" PRId64 "] read req body -> " + "%zu vecs%s with %zu (buffered=%zu, left=%" FMT_OFF_T ")", + stream->id, nvecs, + *pflags == NGHTTP3_DATA_FLAG_EOF ? " EOF" : "", + nwritten, Curl_bufq_len(&stream->sendbuf), + stream->upload_left); + return (nghttp3_ssize)nvecs; +} + +static CURLcode h3_stream_open(struct Curl_cfilter *cf, + struct Curl_easy *data, + const uint8_t *buf, size_t len, + size_t *pnwritten) +{ + struct cf_ngtcp2_ctx *ctx = cf->ctx; + struct h3_stream_ctx *stream = NULL; + int64_t sid; + struct dynhds h2_headers; + size_t nheader; + nghttp3_nv *nva = NULL; + int rc = 0; + unsigned int i; + nghttp3_data_reader reader; + nghttp3_data_reader *preader = NULL; + CURLcode result; + + *pnwritten = 0; + Curl_dynhds_init(&h2_headers, 0, DYN_HTTP_REQUEST); + + result = Curl_cf_ngtcp2_h3_stream_setup(cf, data); + if(result) + goto out; + stream = H3_STREAM_CTX(ctx, data); + DEBUGASSERT(stream); + if(!stream) { + result = CURLE_FAILED_INIT; + goto out; + } + + result = Curl_h1_req_parse_read(&stream->h1, buf, len, NULL, + !data->state.http_ignorecustom ? + data->set.str[STRING_CUSTOMREQUEST] : NULL, + 0, pnwritten); + if(result) + goto out; + if(!stream->h1.done) { + /* need more data */ + goto out; + } + DEBUGASSERT(stream->h1.req); + + result = Curl_http_req_to_h2(&h2_headers, stream->h1.req, data); + if(result) + goto out; + + /* no longer needed */ + Curl_h1_req_parse_free(&stream->h1); + + nheader = Curl_dynhds_count(&h2_headers); + nva = curlx_malloc(sizeof(nghttp3_nv) * nheader); + if(!nva) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + for(i = 0; i < nheader; ++i) { + struct dynhds_entry *e = Curl_dynhds_getn(&h2_headers, i); + nva[i].name = (unsigned char *)e->name; + nva[i].namelen = e->namelen; + nva[i].value = (unsigned char *)e->value; + nva[i].valuelen = e->valuelen; + nva[i].flags = NGHTTP3_NV_FLAG_NONE; + } + + rc = ngtcp2_conn_open_bidi_stream(ctx->qconn, &sid, data); + if(rc) { + failf(data, "cannot open bidi streams"); + result = CURLE_SEND_ERROR; + goto out; + } + stream->id = sid; + ++ctx->used_bidi_streams; + + switch(data->state.httpreq) { + case HTTPREQ_POST: + case HTTPREQ_POST_FORM: + case HTTPREQ_POST_MIME: + case HTTPREQ_PUT: + /* known request body size or -1 */ + if(data->state.infilesize != -1) + stream->upload_left = data->state.infilesize; + else + /* data sending without specifying the data amount up front */ + stream->upload_left = -1; /* unknown */ + break; + default: + /* there is no request body */ + stream->upload_left = 0; /* no request body */ + break; + } + + stream->send_closed = (stream->upload_left == 0); + if(!stream->send_closed) { + reader.read_data = cb_h3_read_req_body; + preader = &reader; + } + + rc = nghttp3_conn_submit_request(ctx->h3conn, stream->id, + nva, nheader, preader, data); + if(rc) { + switch(rc) { + case NGHTTP3_ERR_CONN_CLOSING: + CURL_TRC_CF(data, cf, "h3sid[%" PRId64 "] failed to send, " + "connection is closing", stream->id); + break; + default: + CURL_TRC_CF(data, cf, "h3sid[%" PRId64 "] failed to send -> " + "%d (%s)", stream->id, rc, nghttp3_strerror(rc)); + break; + } + Curl_cf_ngtcp2_h3_stream_close(cf, data, stream); + result = CURLE_SEND_ERROR; + goto out; + } + + cf_ngtcp2_upd_rx_win(cf, data, stream); + + if(Curl_trc_is_verbose(data)) { + infof(data, "[HTTP/3] [%" PRId64 "] OPENED stream for %s", + stream->id, Curl_bufref_ptr(&data->state.url)); + for(i = 0; i < nheader; ++i) { + infof(data, "[HTTP/3] [%" PRId64 "] [%.*s: %.*s]", stream->id, + (int)nva[i].namelen, nva[i].name, + (int)nva[i].valuelen, nva[i].value); + } + } + +out: + curlx_free(nva); + Curl_dynhds_free(&h2_headers); + return result; +} + +static CURLcode cf_ngtcp2_send(struct Curl_cfilter *cf, struct Curl_easy *data, + const uint8_t *buf, size_t len, bool eos, + size_t *pnwritten) +{ + struct cf_ngtcp2_ctx *ctx = cf->ctx; + struct h3_stream_ctx *stream = H3_STREAM_CTX(ctx, data); + struct cf_call_data save; + struct cf_ngtcp2_io_ctx pktx; + CURLcode result = CURLE_OK; + + CF_DATA_SAVE(save, cf, data); + DEBUGASSERT(cf->connected); + DEBUGASSERT(ctx->qconn); + DEBUGASSERT(ctx->h3conn); + Curl_cf_ngtcp2_io_ctx_init(&pktx, cf, data); + *pnwritten = 0; + + /* handshake verification failed in callback, do not send anything */ + if(ctx->tls_vrfy_result) { + result = ctx->tls_vrfy_result; + goto denied; + } + + (void)eos; /* use for stream EOF and block handling */ + result = Curl_cf_ngtcp2_progress_ingress(cf, data, &pktx); + if(result) + goto out; + + if(!stream || stream->id < 0) { + if(ctx->shutdown_started) { + CURL_TRC_CF(data, cf, "cannot open stream on closed connection"); + result = CURLE_SEND_ERROR; + goto out; + } + result = h3_stream_open(cf, data, buf, len, pnwritten); + if(result) { + CURL_TRC_CF(data, cf, "failed to open stream -> %d", (int)result); + goto out; + } + VERBOSE(stream = H3_STREAM_CTX(ctx, data)); + } + else if(stream->xfer_result) { + CURL_TRC_CF(data, cf, "[%" PRId64 "] xfer write failed", stream->id); + Curl_cf_ngtcp2_h3_stream_close(cf, data, stream); + result = stream->xfer_result; + goto out; + } + else if(stream->closed) { + if(stream->resp_hds_complete) { + /* Server decided to close the stream after having sent us a final + * response. This is valid if it is not interested in the request + * body. This happens on 30x or 40x responses. + * We silently discard the data sent, since this is not a transport + * error situation. */ + CURL_TRC_CF(data, cf, "[%" PRId64 "] discarding data" + "on closed stream with response", stream->id); + result = CURLE_OK; + *pnwritten = len; + goto out; + } + CURL_TRC_CF(data, cf, "[%" PRId64 "] send_body(len=%zu) " + "-> stream closed", stream->id, len); + result = CURLE_HTTP3; + goto out; + } + else if(ctx->shutdown_started) { + CURL_TRC_CF(data, cf, "cannot send on closed connection"); + result = CURLE_SEND_ERROR; + goto out; + } + else { + result = Curl_bufq_write(&stream->sendbuf, buf, len, pnwritten); + CURL_TRC_CF(data, cf, "[%" PRId64 "] cf_send, add to " + "sendbuf(len=%zu) -> %d, %zu", + stream->id, len, (int)result, *pnwritten); + if(result) + goto out; + (void)nghttp3_conn_resume_stream(ctx->h3conn, stream->id); + } + + if(*pnwritten > 0 && !ctx->tls_handshake_complete && ctx->use_earlydata) + ctx->earlydata_skip += *pnwritten; + + DEBUGASSERT(!result); + result = Curl_cf_ngtcp2_progress_egress(cf, data, &pktx); + +out: + result = Curl_1st_fatal(result, + Curl_cf_ngtcp2_cmn_set_expiry(cf, data, &pktx)); + if(ctx->tls_vrfy_result) + result = ctx->tls_vrfy_result; +denied: + CURL_TRC_CF(data, cf, "[%" PRId64 "] cf_send(len=%zu) -> %d, %zu", + stream ? stream->id : -1, len, (int)result, *pnwritten); + CF_DATA_RESTORE(cf, save); + return result; +} + +static CURLcode h3_data_pause(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool pause) +{ + /* There seems to exist no API in ngtcp2 to shrink/enlarge the streams + * windows. As we do in HTTP/2. */ + (void)cf; + if(!pause) + Curl_multi_mark_dirty(data); + return CURLE_OK; +} + +static CURLcode cf_ngtcp2_cntrl(struct Curl_cfilter *cf, + struct Curl_easy *data, + int event, int arg1, void *arg2) +{ + struct cf_ngtcp2_ctx *ctx = cf->ctx; + CURLcode result = CURLE_OK; + struct cf_call_data save; + + CF_DATA_SAVE(save, cf, data); + (void)arg1; + (void)arg2; + switch(event) { + case CF_CTRL_DATA_SETUP: + break; + case CF_CTRL_DATA_PAUSE: + result = h3_data_pause(cf, data, (arg1 != 0)); + break; + case CF_CTRL_DATA_DONE: + Curl_cf_ngtcp2_h3_stream_done(cf, data); + break; + case CF_CTRL_DATA_DONE_SEND: { + struct h3_stream_ctx *stream = H3_STREAM_CTX(ctx, data); + if(stream && !stream->send_closed) { + stream->send_closed = TRUE; + stream->upload_left = Curl_bufq_len(&stream->sendbuf) - + stream->sendbuf_len_in_flight; + (void)nghttp3_conn_resume_stream(ctx->h3conn, stream->id); + } + break; + } + case CF_CTRL_CONN_INFO_UPDATE: + if(!cf->sockindex && cf->connected) { + cf->conn->httpversion_seen = 30; + Curl_conn_set_multiplex(cf->conn); + } + break; + default: + break; + } + CF_DATA_RESTORE(cf, save); + return result; +} + +static void cf_ngtcp2_ctx_close(struct cf_ngtcp2_ctx *ctx) +{ + struct cf_call_data save = ctx->call_data; + + if(!ctx->initialized) + return; + if(ctx->qlogfd != -1) { + curlx_close(ctx->qlogfd); + } + ctx->qlogfd = -1; + Curl_vquic_tls_cleanup(&ctx->tls); + Curl_ssl_peer_cleanup(&ctx->ssl_peer); + vquic_ctx_free(&ctx->q); + if(ctx->h3conn) { + nghttp3_conn_del(ctx->h3conn); + ctx->h3conn = NULL; + } + if(ctx->qconn) { + ngtcp2_conn_del(ctx->qconn); + ctx->qconn = NULL; + } +#ifdef OPENSSL_QUIC_API2 + if(ctx->ossl_ctx) { + ngtcp2_crypto_ossl_ctx_del(ctx->ossl_ctx); + ctx->ossl_ctx = NULL; + } +#endif + ctx->call_data = save; +} + +static void cf_ngtcp2_destroy(struct Curl_cfilter *cf, struct Curl_easy *data) +{ + struct cf_ngtcp2_ctx *ctx = cf->ctx; + + CURL_TRC_CF(data, cf, "destroy"); + if(ctx) { + if(ctx->qconn) { + struct cf_call_data save; + CF_DATA_SAVE(save, cf, data); + Curl_cf_ngtcp2_cmn_conn_close(cf, data); + cf_ngtcp2_ctx_close(ctx); + CF_DATA_RESTORE(cf, save); + } + Curl_cf_ngtcp2_ctx_cleanup(ctx); + curlx_free(ctx); + cf->ctx = NULL; + } +} + +static CURLcode cf_ngtcp2_connect(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ + return Curl_cf_ngtcp2_cmn_connect(cf, data, done); +} + +static CURLcode cf_ngtcp2_query(struct Curl_cfilter *cf, + struct Curl_easy *data, + int query, int *pres1, void *pres2) +{ + struct cf_ngtcp2_ctx *ctx = cf->ctx; + struct cf_call_data save; + + switch(query) { + case CF_QUERY_MAX_CONCURRENT: { + DEBUGASSERT(pres1); + CF_DATA_SAVE(save, cf, data); + /* Set after transport params arrived and continually updated + * by callback. QUIC counts the number over the lifetime of the + * connection, ever increasing. + * We count the *open* transfers plus the budget for new ones. */ + if(!ctx->qconn || ctx->shutdown_started) { + *pres1 = 0; + } + else if(ctx->max_bidi_streams) { + uint64_t avail_bidi_streams = 0; + uint64_t max_streams = cf->conn->attached_xfers; + if(ctx->max_bidi_streams > ctx->used_bidi_streams) + avail_bidi_streams = ctx->max_bidi_streams - ctx->used_bidi_streams; + max_streams += avail_bidi_streams; + *pres1 = (max_streams > INT_MAX) ? INT_MAX : (int)max_streams; + } + else /* transport params not arrived yet? take our default. */ + *pres1 = (int)Curl_multi_max_concurrent_streams(data->multi); + CURL_TRC_CF(data, cf, "query conn[%" FMT_OFF_T "]: " + "MAX_CONCURRENT -> %d (%u in use)", + cf->conn->connection_id, *pres1, cf->conn->attached_xfers); + CF_DATA_RESTORE(cf, save); + return CURLE_OK; + } + case CF_QUERY_CONNECT_REPLY_MS: + if(ctx->q.got_first_byte) { + timediff_t ms = curlx_ptimediff_ms(&ctx->q.first_byte_at, + &ctx->started_at); + *pres1 = (ms < INT_MAX) ? (int)ms : INT_MAX; + } + else + *pres1 = -1; + return CURLE_OK; + case CF_QUERY_TIMER_CONNECT: { + struct curltime *when = pres2; + if(ctx->q.got_first_byte) + *when = ctx->q.first_byte_at; + return CURLE_OK; + } + case CF_QUERY_TIMER_APPCONNECT: { + struct curltime *when = pres2; + if(cf->connected) + *when = ctx->handshake_at; + return CURLE_OK; + } + case CF_QUERY_HTTP_VERSION: + *pres1 = 30; + return CURLE_OK; + case CF_QUERY_SSL_INFO: + case CF_QUERY_SSL_CTX_INFO: { + struct curl_tlssessioninfo *info = pres2; + if(Curl_vquic_tls_get_ssl_info(&ctx->tls, + (query == CF_QUERY_SSL_CTX_INFO), info)) + return CURLE_OK; + break; + } + case CF_QUERY_ALPN_NEGOTIATED: { + const char **palpn = pres2; + DEBUGASSERT(palpn); + *palpn = cf->connected ? "h3" : NULL; + return CURLE_OK; + } + default: + break; + } + return cf->next ? + cf->next->cft->query(cf->next, data, query, pres1, pres2) : + CURLE_UNKNOWN_OPTION; +} + +struct Curl_cftype Curl_cft_http3 = { + "HTTP/3", + CF_TYPE_IP_CONNECT | CF_TYPE_SSL | CF_TYPE_MULTIPLEX | CF_TYPE_HTTP, + 0, + cf_ngtcp2_destroy, + cf_ngtcp2_connect, + Curl_cf_ngtcp2_cmn_shutdown, + cf_ngtcp2_adjust_pollset, + Curl_cf_def_data_pending, + cf_ngtcp2_send, + cf_ngtcp2_recv, + cf_ngtcp2_cntrl, + Curl_cf_ngtcp2_cmn_conn_is_alive, + Curl_cf_def_conn_keep_alive, + cf_ngtcp2_query, +}; + +CURLcode Curl_cf_ngtcp2_create(struct Curl_cfilter **pcf, + struct Curl_easy *data, + struct Curl_peer *origin, + struct Curl_peer *peer, + struct connectdata *conn, + struct Curl_sockaddr_ex *addr) +{ + struct cf_ngtcp2_ctx *ctx = NULL; + struct Curl_cfilter *cf = NULL; + CURLcode result; + + ctx = curlx_calloc(1, sizeof(*ctx)); + if(!ctx) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + result = Curl_cf_ngtcp2_ctx_init(ctx, origin, peer, + &conn->ssl_config, init_ngh3_conn); + if(!result) + result = Curl_cf_create(&cf, &Curl_cft_http3, ctx); + if(result) + goto out; + cf->conn = conn; + + result = Curl_cf_udp_create(&cf->next, data, origin, peer, TRNSPRT_QUIC, + conn, addr, NULL, TRNSPRT_QUIC); + if(result) + goto out; + cf->next->conn = cf->conn; + cf->next->sockindex = cf->sockindex; + +out: + *pcf = (!result) ? cf : NULL; + if(result) { + if(cf) + Curl_conn_cf_discard_chain(&cf, data); + else if(ctx) { + Curl_cf_ngtcp2_ctx_cleanup(ctx); + curlx_free(ctx); + } + } + return result; +} + +CURLcode Curl_cf_ngtcp2_insert_after(struct Curl_cfilter *cf_at, + struct Curl_peer *origin, + struct Curl_peer *peer) +{ + struct cf_ngtcp2_ctx *ctx = NULL; + struct Curl_cfilter *cf = NULL; + CURLcode result; + + ctx = curlx_calloc(1, sizeof(*ctx)); + if(!ctx) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + result = Curl_cf_ngtcp2_ctx_init(ctx, origin, peer, + &cf_at->conn->ssl_config, init_ngh3_conn); + if(!result) + result = Curl_cf_create(&cf, &Curl_cft_http3, ctx); + if(result) + goto out; + Curl_conn_cf_insert_after(cf_at, cf); +out: + if(result) { + curlx_safefree(cf); + if(ctx) { + Curl_cf_ngtcp2_ctx_cleanup(ctx); + curlx_free(ctx); + } + } + return result; +} + +#endif diff --git a/3rdparty/curl-8.21.0/lib/vquic/cf-ngtcp2.h b/3rdparty/curl-8.21.0/lib/vquic/cf-ngtcp2.h new file mode 100644 index 0000000000..601efc8224 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vquic/cf-ngtcp2.h @@ -0,0 +1,63 @@ +#ifndef HEADER_CURL_VQUIC_CF_NGTCP2_H +#define HEADER_CURL_VQUIC_CF_NGTCP2_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_HTTP) && defined(USE_NGTCP2) && defined(USE_NGHTTP3) + +#ifdef HAVE_NETINET_UDP_H +#include +#endif + +#include +#ifdef OPENSSL_QUIC_API2 +#include +#endif +#include +#ifdef USE_OPENSSL +#include +#elif defined(USE_WOLFSSL) +#include +#include +#include +#endif + +struct Curl_cfilter; + +#include "urldata.h" + +CURLcode Curl_cf_ngtcp2_create(struct Curl_cfilter **pcf, + struct Curl_easy *data, + struct Curl_peer *origin, + struct Curl_peer *peer, + struct connectdata *conn, + struct Curl_sockaddr_ex *addr); + +CURLcode Curl_cf_ngtcp2_insert_after(struct Curl_cfilter *cf_at, + struct Curl_peer *origin, + struct Curl_peer *peer); +#endif + +#endif /* HEADER_CURL_VQUIC_CF_NGTCP2_H */ diff --git a/3rdparty/curl-8.21.0/lib/vquic/cf-quiche.c b/3rdparty/curl-8.21.0/lib/vquic/cf-quiche.c new file mode 100644 index 0000000000..31a3957ec3 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vquic/cf-quiche.c @@ -0,0 +1,1713 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_HTTP) && defined(USE_QUICHE) +#include +#include +#include + +#include "bufq.h" +#include "uint-hash.h" +#include "urldata.h" +#include "cfilters.h" +#include "cf-dns.h" +#include "cf-socket.h" +#include "curl_trc.h" +#include "rand.h" +#include "multiif.h" +#include "connect.h" +#include "progress.h" +#include "select.h" +#include "http1.h" +#include "sockaddr.h" +#include "vquic/vquic.h" +#include "vquic/vquic_int.h" +#include "vquic/vquic-tls.h" +#include "vquic/cf-quiche.h" +#include "transfer.h" +#include "url.h" +#include "bufref.h" +#include "vtls/openssl.h" +#include "vtls/vtls.h" + +/* HTTP/3 error values defined in RFC 9114, ch. 8.1 */ +#define CURL_H3_NO_ERROR 0x0100 + +#define MAX_PKT_BURST 10 + +#define QUIC_MAX_STREAMS 100 + +#define H3_STREAM_WINDOW_SIZE (1024 * 128) +#define H3_STREAM_CHUNK_SIZE (1024 * 16) +/* Receive and Send max number of chunks follows from the + * chunk size and window size */ +#define H3_STREAM_RECV_CHUNKS \ + (H3_STREAM_WINDOW_SIZE / H3_STREAM_CHUNK_SIZE) + +/* + * Store quiche version info in this buffer. + */ +void Curl_quiche_ver(char *p, size_t len) +{ + (void)curl_msnprintf(p, len, "quiche/%s", quiche_version()); +} + +struct cf_quiche_ctx { + struct cf_quic_ctx q; + struct ssl_peer ssl_peer; + struct curl_tls_ctx tls; + quiche_conn *qconn; + quiche_config *cfg; + quiche_h3_conn *h3c; + quiche_h3_config *h3config; + uint8_t scid[QUICHE_MAX_CONN_ID_LEN]; + struct curltime started_at; /* time the current attempt started */ + struct curltime handshake_at; /* time connect handshake finished */ + struct uint_hash streams; /* hash `data->mid` to `stream_ctx` */ + struct dynbuf h1hdr; /* temp buffer for header construction */ + struct bufq writebuf; /* temp buffer for writing bodies */ + curl_off_t data_recvd; + BIT(initialized); + BIT(goaway); /* got GOAWAY from server */ + BIT(x509_store_setup); /* if x509 store has been set up */ + BIT(shutdown_started); /* queued shutdown packets */ +}; + +#ifdef DEBUG_QUICHE +/* initialize debug log callback only once */ +static int debug_log_init = 0; +static void quiche_debug_log(const char *line, void *argp) +{ + (void)argp; + curl_mfprintf(stderr, "%s\n", line); +} +#endif + +static void h3_stream_hash_free(unsigned int id, void *stream); + +static CURLcode cf_quiche_ctx_init(struct cf_quiche_ctx *ctx, + struct Curl_peer *origin, + struct Curl_peer *peer, + struct ssl_primary_config *sslc) +{ + DEBUGASSERT(!ctx->initialized); +#ifdef DEBUG_QUICHE + if(!debug_log_init) { + quiche_enable_debug_logging(quiche_debug_log, NULL); + debug_log_init = 1; + } +#endif + curlx_dyn_init(&ctx->h1hdr, CURL_MAX_HTTP_HEADER); + Curl_uint32_hash_init(&ctx->streams, 63, h3_stream_hash_free); + Curl_bufq_init2(&ctx->writebuf, H3_STREAM_CHUNK_SIZE, H3_STREAM_RECV_CHUNKS, + BUFQ_OPT_SOFT_LIMIT); + ctx->data_recvd = 0; + ctx->initialized = TRUE; + return Curl_vquic_tls_peer_init(origin, peer, sslc, &ctx->ssl_peer); +} + +static void cf_quiche_ctx_free(struct cf_quiche_ctx *ctx) +{ + if(ctx && ctx->initialized) { + /* quiche freed it */ + ctx->tls.ossl.ssl = NULL; + Curl_vquic_tls_cleanup(&ctx->tls); + Curl_ssl_peer_cleanup(&ctx->ssl_peer); + vquic_ctx_free(&ctx->q); + Curl_uint32_hash_destroy(&ctx->streams); + curlx_dyn_free(&ctx->h1hdr); + Curl_bufq_free(&ctx->writebuf); + } + curlx_free(ctx); +} + +static void cf_quiche_ctx_close(struct cf_quiche_ctx *ctx) +{ + if(ctx->h3c) { + quiche_h3_conn_free(ctx->h3c); + ctx->h3c = NULL; + } + if(ctx->h3config) { + quiche_h3_config_free(ctx->h3config); + ctx->h3config = NULL; + } + if(ctx->qconn) { + quiche_conn_free(ctx->qconn); + ctx->qconn = NULL; + } + if(ctx->cfg) { + quiche_config_free(ctx->cfg); + ctx->cfg = NULL; + } + Curl_ssl_peer_cleanup(&ctx->ssl_peer); +} + +static CURLcode cf_flush_egress(struct Curl_cfilter *cf, + struct Curl_easy *data); + +/** + * All about the H3 internals of a stream + */ +struct h3_stream_ctx { + uint64_t id; /* HTTP/3 protocol stream identifier */ + struct h1_req_parser h1; /* h1 request parsing */ + uint64_t error3; /* HTTP/3 stream error code */ + int status_code; /* HTTP status code */ + CURLcode xfer_result; /* result from cf_quiche_write_(hd/body) */ + BIT(opened); /* TRUE after stream has been opened */ + BIT(closed); /* TRUE on stream close */ + BIT(reset); /* TRUE on stream reset */ + BIT(send_closed); /* stream is locally closed */ + BIT(resp_hds_complete); /* final response has been received */ + BIT(resp_got_header); /* TRUE when h3 stream has recvd some HEADER */ + BIT(quic_flow_blocked); /* stream is blocked by QUIC flow control */ +}; + +static void h3_stream_ctx_free(struct h3_stream_ctx *stream) +{ + Curl_h1_req_parse_free(&stream->h1); + curlx_free(stream); +} + +static void h3_stream_hash_free(unsigned int id, void *stream) +{ + (void)id; + DEBUGASSERT(stream); + h3_stream_ctx_free((struct h3_stream_ctx *)stream); +} + +typedef bool cf_quiche_svisit(struct Curl_cfilter *cf, + struct Curl_easy *sdata, + struct h3_stream_ctx *stream, + void *user_data); + +struct cf_quiche_visit_ctx { + struct Curl_cfilter *cf; + struct Curl_multi *multi; + cf_quiche_svisit *cb; + void *user_data; +}; + +static bool cf_quiche_stream_do(uint32_t mid, void *val, void *user_data) +{ + struct cf_quiche_visit_ctx *vctx = user_data; + struct h3_stream_ctx *stream = val; + struct Curl_easy *sdata = Curl_multi_get_easy(vctx->multi, mid); + if(sdata) + return vctx->cb(vctx->cf, sdata, stream, vctx->user_data); + return TRUE; +} + +static void cf_quiche_for_all_streams(struct Curl_cfilter *cf, + struct Curl_multi *multi, + cf_quiche_svisit *do_cb, + void *user_data) +{ + struct cf_quiche_ctx *ctx = cf->ctx; + struct cf_quiche_visit_ctx vctx; + vctx.cf = cf; + vctx.multi = multi; + vctx.cb = do_cb; + vctx.user_data = user_data; + Curl_uint32_hash_visit(&ctx->streams, cf_quiche_stream_do, &vctx); +} + +static bool cf_quiche_do_resume(struct Curl_cfilter *cf, + struct Curl_easy *sdata, + struct h3_stream_ctx *stream, + void *user_data) +{ + (void)user_data; + if(stream->quic_flow_blocked) { + stream->quic_flow_blocked = FALSE; + Curl_multi_mark_dirty(sdata); + CURL_TRC_CF(sdata, cf, "[%" PRIu64 "] unblock", stream->id); + } + return TRUE; +} + +static bool cf_quiche_do_expire(struct Curl_cfilter *cf, + struct Curl_easy *sdata, + struct h3_stream_ctx *stream, + void *user_data) +{ + (void)stream; + (void)user_data; + CURL_TRC_CF(sdata, cf, "conn closed, mark as dirty"); + stream->xfer_result = CURLE_SEND_ERROR; + Curl_multi_mark_dirty(sdata); + return TRUE; +} + +static CURLcode h3_data_setup(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_quiche_ctx *ctx = cf->ctx; + struct h3_stream_ctx *stream = H3_STREAM_CTX(ctx, data); + + if(stream) + return CURLE_OK; + + stream = curlx_calloc(1, sizeof(*stream)); + if(!stream) + return CURLE_OUT_OF_MEMORY; + + stream->id = -1; + Curl_h1_req_parse_init(&stream->h1, H1_PARSE_DEFAULT_MAX_LINE_LEN); + + if(!Curl_uint32_hash_set(&ctx->streams, data->mid, stream)) { + h3_stream_ctx_free(stream); + return CURLE_OUT_OF_MEMORY; + } + + return CURLE_OK; +} + +static void cf_quiche_stream_close(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h3_stream_ctx *stream) +{ + struct cf_quiche_ctx *ctx = cf->ctx; + CURLcode result; + + if(ctx->qconn && !stream->closed) { + quiche_conn_stream_shutdown(ctx->qconn, stream->id, + QUICHE_SHUTDOWN_READ, CURL_H3_NO_ERROR); + if(!stream->send_closed) { + quiche_conn_stream_shutdown(ctx->qconn, stream->id, + QUICHE_SHUTDOWN_WRITE, CURL_H3_NO_ERROR); + stream->send_closed = TRUE; + } + stream->closed = TRUE; + result = cf_flush_egress(cf, data); + if(result) + CURL_TRC_CF(data, cf, "[%" PRIu64 "] stream close, flush egress -> %d", + stream->id, (int)result); + } +} + +static void h3_data_done(struct Curl_cfilter *cf, struct Curl_easy *data) +{ + struct cf_quiche_ctx *ctx = cf->ctx; + struct h3_stream_ctx *stream = H3_STREAM_CTX(ctx, data); + + (void)cf; + if(stream) { + CURL_TRC_CF(data, cf, "[%" PRIu64 "] easy handle is done", stream->id); + cf_quiche_stream_close(cf, data, stream); + Curl_uint32_hash_remove(&ctx->streams, data->mid); + } +} + +static void cf_quiche_expire_conn_closed(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + DEBUGASSERT(data->multi); + CURL_TRC_CF(data, cf, "conn closed, expire all transfers"); + cf_quiche_for_all_streams(cf, data->multi, cf_quiche_do_expire, NULL); +} + +static void cf_quiche_write_hd(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h3_stream_ctx *stream, + const char *buf, size_t blen, bool eos) +{ + /* This function returns no error intentionally, but records + * the result at the stream, skipping further writes once the + * `result` of the transfer is known. + * The stream is subsequently cancelled "higher up" in the filter's + * send/recv callbacks. Closing the stream here leads to SEND/RECV + * errors in other places that then overwrite the transfer's result. */ + if(!stream->xfer_result) { + stream->xfer_result = Curl_xfer_write_resp_hd(data, buf, blen, eos); + if(stream->xfer_result) + CURL_TRC_CF(data, cf, "[%" PRIu64 "] error %d writing %zu " + "bytes of headers", stream->id, (int)stream->xfer_result, + blen); + } +} + +struct cb_ctx { + struct Curl_cfilter *cf; + struct Curl_easy *data; + struct h3_stream_ctx *stream; +}; + +static bool is_valid_h3_header(const uint8_t *hdr, size_t hlen) +{ + while(hlen--) { + switch(*hdr++) { + case '\n': + case '\r': + case '\0': + return FALSE; + } + } + return TRUE; +} + +static int cb_each_header(uint8_t *name, size_t name_len, + uint8_t *value, size_t value_len, + void *argp) +{ + struct cb_ctx *x = argp; + struct Curl_cfilter *cf = x->cf; + struct Curl_easy *data = x->data; + struct h3_stream_ctx *stream = x->stream; + struct cf_quiche_ctx *ctx = cf->ctx; + CURLcode result = CURLE_OK; + + if(!stream || stream->xfer_result) + return 1; /* abort iteration */ + + if((name_len == 7) && !strncmp(HTTP_PSEUDO_STATUS, (char *)name, 7) && + is_valid_h3_header(value, value_len)) { + curlx_dyn_reset(&ctx->h1hdr); + result = Curl_http_decode_status(&stream->status_code, + (const char *)value, value_len); + if(!result) + result = curlx_dyn_addn(&ctx->h1hdr, STRCONST("HTTP/3 ")); + if(!result) + result = curlx_dyn_addn(&ctx->h1hdr, (const char *)value, value_len); + if(!result) + result = curlx_dyn_addn(&ctx->h1hdr, STRCONST(" \r\n")); + if(!result) + cf_quiche_write_hd(cf, data, stream, curlx_dyn_ptr(&ctx->h1hdr), + curlx_dyn_len(&ctx->h1hdr), FALSE); + CURL_TRC_CF(data, cf, "[%" PRIu64 "] status: %s", + stream->id, curlx_dyn_ptr(&ctx->h1hdr)); + } + else { + if(is_valid_h3_header(value, value_len) && + is_valid_h3_header(name, name_len)) { + /* store as an HTTP1-style header */ + CURL_TRC_CF(data, cf, "[%" PRIu64 "] header: %.*s: %.*s", + stream->id, (int)name_len, name, + (int)value_len, value); + curlx_dyn_reset(&ctx->h1hdr); + result = curlx_dyn_addn(&ctx->h1hdr, (const char *)name, name_len); + if(!result) + result = curlx_dyn_addn(&ctx->h1hdr, STRCONST(": ")); + if(!result) + result = curlx_dyn_addn(&ctx->h1hdr, (const char *)value, value_len); + if(!result) + result = curlx_dyn_addn(&ctx->h1hdr, STRCONST("\r\n")); + if(!result) + cf_quiche_write_hd(cf, data, stream, curlx_dyn_ptr(&ctx->h1hdr), + curlx_dyn_len(&ctx->h1hdr), FALSE); + } + else + CURL_TRC_CF(x->data, x->cf, "[%" PRIu64 "] ignore %zu bytes bad header", + stream->id, value_len + name_len); + } + + if(result) { + CURL_TRC_CF(x->data, x->cf, "[%" PRIu64 "] on header error %d", + stream->id, (int)result); + if(!stream->xfer_result) + stream->xfer_result = result; + } + return stream->xfer_result ? 1 : 0; +} + +static CURLcode stream_resp_read(void *reader_ctx, + unsigned char *buf, size_t len, + size_t *pnread) +{ + struct cb_ctx *x = reader_ctx; + struct cf_quiche_ctx *ctx = x->cf->ctx; + struct h3_stream_ctx *stream = H3_STREAM_CTX(ctx, x->data); + ssize_t nread; + + *pnread = 0; + if(!stream) + return CURLE_RECV_ERROR; + + nread = quiche_h3_recv_body(ctx->h3c, ctx->qconn, stream->id, buf, len); + if(!curlx_sztouz(nread, pnread)) + return CURLE_AGAIN; + return CURLE_OK; +} + +static void cf_quiche_flush_body(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h3_stream_ctx *stream) +{ + struct cf_quiche_ctx *ctx = cf->ctx; + const uint8_t *buf; + size_t blen; + + while(stream && !stream->xfer_result) { + if(Curl_bufq_peek(&ctx->writebuf, &buf, &blen)) { + stream->xfer_result = Curl_xfer_write_resp( + data, (const char *)buf, blen, FALSE); + Curl_bufq_skip(&ctx->writebuf, blen); + if(stream->xfer_result) { + CURL_TRC_CF(data, cf, "[%" PRIu64 "] error %d writing %zu bytes" + " of data", stream->id, (int)stream->xfer_result, blen); + } + } + else + break; + } + Curl_bufq_reset(&ctx->writebuf); +} + +static void cf_quiche_recv_body(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h3_stream_ctx *stream) +{ + struct cf_quiche_ctx *ctx = cf->ctx; + size_t nread; + struct cb_ctx cb_ctx; + CURLcode result = CURLE_OK; + + if(!stream) + return; + + /* Even when the transfer has already errored, we need to receive + * the data from quiche, as quiche otherwise gets stuck and + * raise events to receive over and over again. */ + cb_ctx.cf = cf; + cb_ctx.data = data; + cb_ctx.stream = stream; + Curl_bufq_reset(&ctx->writebuf); + while(!result) { + result = Curl_bufq_slurp(&ctx->writebuf, + stream_resp_read, &cb_ctx, &nread); + if(!result) + cf_quiche_flush_body(cf, data, stream); + else if(result == CURLE_AGAIN) + break; + else if(result) { + CURL_TRC_CF(data, cf, "[%" PRIu64 "] recv_body error %d", + stream->id, (int)result); + failf(data, "[%" PRIu64 "] Error %d in HTTP/3 response body for stream", + stream->id, (int)result); + stream->closed = TRUE; + stream->reset = TRUE; + stream->send_closed = TRUE; + if(!stream->xfer_result) + stream->xfer_result = result; + } + } + cf_quiche_flush_body(cf, data, stream); +} + +static void cf_quiche_process_ev(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h3_stream_ctx *stream, + quiche_h3_event *ev) +{ + enum quiche_h3_event_type type; + + if(!stream) + return; + + type = quiche_h3_event_type(ev); + + switch(type) { + case QUICHE_H3_EVENT_HEADERS: { + struct cb_ctx cb_ctx; + stream->resp_got_header = TRUE; + cb_ctx.cf = cf; + cb_ctx.data = data; + cb_ctx.stream = stream; + quiche_h3_event_for_each_header(ev, cb_each_header, &cb_ctx); + CURL_TRC_CF(data, cf, "[%" PRIu64 "] <- [HEADERS]", stream->id); + Curl_multi_mark_dirty(data); + break; + } + case QUICHE_H3_EVENT_DATA: + if(!stream->resp_hds_complete) { + stream->resp_hds_complete = TRUE; + cf_quiche_write_hd(cf, data, stream, "\r\n", 2, FALSE); + } + cf_quiche_recv_body(cf, data, stream); + CURL_TRC_CF(data, cf, "[%" PRIu64 "] <- [DATA]", stream->id); + Curl_multi_mark_dirty(data); + break; + + case QUICHE_H3_EVENT_RESET: + CURL_TRC_CF(data, cf, "[%" PRIu64 "] RESET", stream->id); + stream->closed = TRUE; + stream->reset = TRUE; + stream->send_closed = TRUE; + Curl_multi_mark_dirty(data); + break; + + case QUICHE_H3_EVENT_FINISHED: + CURL_TRC_CF(data, cf, "[%" PRIu64 "] CLOSED", stream->id); + if(!stream->resp_hds_complete) { + stream->resp_hds_complete = TRUE; + cf_quiche_write_hd(cf, data, stream, "\r\n", 2, TRUE); + } + stream->closed = TRUE; + Curl_multi_mark_dirty(data); + break; + + case QUICHE_H3_EVENT_GOAWAY: + CURL_TRC_CF(data, cf, "[%" PRIu64 "] <- [GOAWAY]", stream->id); + break; + + default: + CURL_TRC_CF(data, cf, "[%" PRIu64 "] recv, unhandled event %d", + stream->id, (int)type); + break; + } +} + +struct cf_quich_disp_ctx { + uint64_t stream_id; + struct Curl_cfilter *cf; + struct Curl_multi *multi; + quiche_h3_event *ev; +}; + +static bool cf_quiche_disp_event(uint32_t mid, void *val, void *user_data) +{ + struct cf_quich_disp_ctx *dctx = user_data; + struct h3_stream_ctx *stream = val; + + if(stream->id == dctx->stream_id) { + struct Curl_easy *sdata = Curl_multi_get_easy(dctx->multi, mid); + if(sdata) + cf_quiche_process_ev(dctx->cf, sdata, stream, dctx->ev); + return FALSE; /* stop iterating */ + } + return TRUE; +} + +static CURLcode cf_poll_events(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_quiche_ctx *ctx = cf->ctx; + struct h3_stream_ctx *stream = NULL; + quiche_h3_event *ev; + + /* Take in the events and distribute them to the transfers. */ + while(ctx->h3c) { + int64_t rv = quiche_h3_conn_poll(ctx->h3c, ctx->qconn, &ev); + if(rv == QUICHE_H3_ERR_DONE) { + break; + } + else if(rv < 0) { + CURL_TRC_CF(data, cf, "error poll: %" PRId64, rv); + return CURLE_HTTP3; + } + else { + stream = H3_STREAM_CTX(ctx, data); + if(stream && stream->id == (uint64_t)rv) { + /* event for calling transfer */ + cf_quiche_process_ev(cf, data, stream, ev); + quiche_h3_event_free(ev); + if(stream->xfer_result) + return stream->xfer_result; + } + else { + /* another transfer, do not return errors, as they are not for + * the calling transfer */ + struct cf_quich_disp_ctx dctx; + dctx.stream_id = (uint64_t)rv; + dctx.cf = cf; + dctx.multi = data->multi; + dctx.ev = ev; + Curl_uint32_hash_visit(&ctx->streams, cf_quiche_disp_event, &dctx); + quiche_h3_event_free(ev); + } + } + } + return CURLE_OK; +} + +struct recv_ctx { + struct Curl_cfilter *cf; + struct Curl_easy *data; + int pkts; +}; + +static CURLcode cf_quiche_recv_pkts(const unsigned char *buf, size_t buflen, + size_t gso_size, + struct sockaddr_storage *remote_addr, + socklen_t remote_addrlen, int ecn, + void *userp) +{ + struct recv_ctx *r = userp; + struct cf_quiche_ctx *ctx = r->cf->ctx; + quiche_recv_info recv_info; + size_t pktlen, offset, nread; + ssize_t rv; + + (void)ecn; + + recv_info.to = (struct sockaddr *)&ctx->q.local_addr; + recv_info.to_len = ctx->q.local_addrlen; + recv_info.from = (struct sockaddr *)remote_addr; + recv_info.from_len = remote_addrlen; + + for(offset = 0; offset < buflen; offset += gso_size) { + pktlen = ((offset + gso_size) <= buflen) ? gso_size : (buflen - offset); + rv = quiche_conn_recv(ctx->qconn, + (unsigned char *)CURL_UNCONST(buf + offset), + pktlen, &recv_info); + if(!curlx_sztouz(rv, &nread)) { + if(QUICHE_ERR_DONE == rv) { + if(quiche_conn_is_draining(ctx->qconn)) { + CURL_TRC_CF(r->data, r->cf, "ingress, connection is draining"); + return CURLE_RECV_ERROR; + } + if(quiche_conn_is_closed(ctx->qconn)) { + CURL_TRC_CF(r->data, r->cf, "ingress, connection is closed"); + return CURLE_RECV_ERROR; + } + CURL_TRC_CF(r->data, r->cf, "ingress, quiche is DONE"); + return CURLE_OK; + } + else if(QUICHE_ERR_TLS_FAIL == rv) { + long verify_ok = SSL_get_verify_result(ctx->tls.ossl.ssl); + if(verify_ok != X509_V_OK) { + failf(r->data, "SSL certificate problem: %s", + X509_verify_cert_error_string(verify_ok)); + return CURLE_PEER_FAILED_VERIFICATION; + } + failf(r->data, "ingress, quiche reports TLS fail"); + return CURLE_RECV_ERROR; + } + else { + failf(r->data, "quiche reports error %zd on receive", rv); + return CURLE_RECV_ERROR; + } + } + else if(nread < pktlen) { + CURL_TRC_CF(r->data, r->cf, "ingress, quiche only read %zu/%zu bytes", + nread, pktlen); + } + ++r->pkts; + } + + return CURLE_OK; +} + +static CURLcode cf_process_ingress(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_quiche_ctx *ctx = cf->ctx; + struct recv_ctx rctx; + CURLcode result; + + DEBUGASSERT(ctx->qconn); + result = Curl_vquic_tls_before_recv(&ctx->tls, cf, data); + if(result) + return result; + + rctx.cf = cf; + rctx.data = data; + rctx.pkts = 0; + + result = vquic_recv_packets(cf, data, &ctx->q, 1000, + cf_quiche_recv_pkts, &rctx); + if(result) + return result; + + if(rctx.pkts > 0) { + /* quiche digested ingress packets. It might have opened flow control + * windows again. */ + DEBUGASSERT(data->multi); + cf_quiche_for_all_streams(cf, data->multi, cf_quiche_do_resume, NULL); + } + return cf_poll_events(cf, data); +} + +struct read_ctx { + struct Curl_cfilter *cf; + struct Curl_easy *data; + quiche_send_info send_info; +}; + +static CURLcode read_pkt_to_send(void *userp, + unsigned char *buf, size_t buflen, + size_t *pnread) +{ + struct read_ctx *x = userp; + struct cf_quiche_ctx *ctx = x->cf->ctx; + ssize_t rv; + + *pnread = 0; + rv = quiche_conn_send(ctx->qconn, buf, buflen, &x->send_info); + if(rv == QUICHE_ERR_DONE) + return CURLE_AGAIN; + + if(!curlx_sztouz(rv, pnread)) { + failf(x->data, "quiche_conn_send returned %zd", rv); + return CURLE_SEND_ERROR; + } + return CURLE_OK; +} + +/* + * flush_egress drains the buffers and sends off data. + * Calls failf() on errors. + */ +static CURLcode cf_flush_egress(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_quiche_ctx *ctx = cf->ctx; + size_t nread; + CURLcode result; + int64_t expiry_ns; + int64_t timeout_ns; + struct read_ctx readx; + size_t pkt_count, gsolen; + + expiry_ns = quiche_conn_timeout_as_nanos(ctx->qconn); + if(!expiry_ns) { + quiche_conn_on_timeout(ctx->qconn); + if(quiche_conn_is_closed(ctx->qconn)) { + if(quiche_conn_is_timed_out(ctx->qconn)) + failf(data, "connection closed by idle timeout"); + else + failf(data, "connection closed by server"); + /* Connection timed out, expire all transfers belonging to it + * as it does not get any more POLL events here. */ + cf_quiche_expire_conn_closed(cf, data); + return CURLE_SEND_ERROR; + } + } + + result = vquic_flush(cf, data, &ctx->q); + if(result) { + if(result == CURLE_AGAIN) { + Curl_expire(data, 1, EXPIRE_QUIC); + return CURLE_OK; + } + return result; + } + + readx.cf = cf; + readx.data = data; + memset(&readx.send_info, 0, sizeof(readx.send_info)); + pkt_count = 0; + gsolen = quiche_conn_max_send_udp_payload_size(ctx->qconn); + for(;;) { + /* add the next packet to send, if any, to our buffer */ + result = Curl_bufq_sipn(&ctx->q.sendbuf, 0, + read_pkt_to_send, &readx, &nread); + if(result) { + if(result != CURLE_AGAIN) + return result; + /* Nothing more to add, flush and leave */ + result = vquic_send(cf, data, &ctx->q, gsolen); + if(result) { + if(result == CURLE_AGAIN) { + Curl_expire(data, 1, EXPIRE_QUIC); + return CURLE_OK; + } + return result; + } + goto out; + } + + ++pkt_count; + if(nread < gsolen || pkt_count >= MAX_PKT_BURST) { + result = vquic_send(cf, data, &ctx->q, gsolen); + if(result) { + if(result == CURLE_AGAIN) { + Curl_expire(data, 1, EXPIRE_QUIC); + return CURLE_OK; + } + goto out; + } + pkt_count = 0; + } + } + +out: + timeout_ns = quiche_conn_timeout_as_nanos(ctx->qconn); + if(timeout_ns % 1000000) + timeout_ns += 1000000; + /* expire resolution is milliseconds */ + Curl_expire(data, (timeout_ns / 1000000), EXPIRE_QUIC); + return result; +} + +static CURLcode recv_closed_stream(struct Curl_cfilter *cf, + struct Curl_easy *data, + size_t *pnread) +{ + struct cf_quiche_ctx *ctx = cf->ctx; + struct h3_stream_ctx *stream = H3_STREAM_CTX(ctx, data); + CURLcode result = CURLE_OK; + + DEBUGASSERT(stream); + *pnread = 0; + if(stream->reset) { + if(stream->error3 == CURL_H3_ERR_REQUEST_REJECTED) { + infof(data, "HTTP/3 stream %" PRIu64 " refused by server, try again " + "on a new connection", stream->id); + connclose(cf->conn, "REFUSED_STREAM"); /* do not use this anymore */ + data->state.refused_stream = TRUE; + return CURLE_RECV_ERROR; /* trigger Curl_retry_request() later */ + } + else if(stream->resp_hds_complete && data->req.no_body) { + CURL_TRC_CF(data, cf, "[%" PRIu64 "] error after response headers, " + "but we did not want a body anyway, ignore error 0x%" + PRIx64 " %s", stream->id, stream->error3, + vquic_h3_err_str(stream->error3)); + return CURLE_OK; + } + failf(data, "HTTP/3 stream %" PRIu64 " reset by server (error 0x%" PRIx64 + " %s)", stream->id, stream->error3, + vquic_h3_err_str(stream->error3)); + result = data->req.bytecount ? CURLE_PARTIAL_FILE : CURLE_HTTP3; + CURL_TRC_CF(data, cf, "[%" PRIu64 "] cf_recv, was reset -> %d", + stream->id, (int)result); + } + else if(!stream->resp_got_header) { + failf(data, "HTTP/3 stream %" PRIu64 " was closed cleanly, but before " + "getting all response header fields, treated as error", + stream->id); + result = CURLE_HTTP3; + } + return result; +} + +static CURLcode cf_quiche_recv(struct Curl_cfilter *cf, struct Curl_easy *data, + char *buf, size_t blen, size_t *pnread) +{ + struct cf_quiche_ctx *ctx = cf->ctx; + struct h3_stream_ctx *stream = H3_STREAM_CTX(ctx, data); + CURLcode result = CURLE_OK; + + *pnread = 0; + (void)buf; + (void)blen; + vquic_ctx_update_time(&ctx->q, Curl_pgrs_now(data)); + + if(!stream) + return CURLE_RECV_ERROR; + + result = cf_process_ingress(cf, data); + if(result) { + CURL_TRC_CF(data, cf, "cf_recv, error on ingress"); + goto out; + } + + if(stream->xfer_result) { + cf_quiche_stream_close(cf, data, stream); + result = stream->xfer_result; + goto out; + } + else if(stream->closed) + result = recv_closed_stream(cf, data, pnread); + else if(quiche_conn_is_draining(ctx->qconn)) { + failf(data, "QUIC connection is draining"); + result = CURLE_HTTP3; + } + else + result = CURLE_AGAIN; + +out: + result = Curl_1st_fatal(result, cf_flush_egress(cf, data)); + if(*pnread > 0) + ctx->data_recvd += *pnread; + CURL_TRC_CF(data, cf, "[%" PRIu64 "] cf_recv(len=%zu) -> %d, %zu, total=%" + FMT_OFF_T, stream->id, blen, (int)result, *pnread, + ctx->data_recvd); + return result; +} + +static CURLcode cf_quiche_send_body(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct h3_stream_ctx *stream, + const uint8_t *buf, size_t len, bool eos, + size_t *pnwritten) +{ + struct cf_quiche_ctx *ctx = cf->ctx; + ssize_t rv; + + *pnwritten = 0; + rv = quiche_h3_send_body(ctx->h3c, ctx->qconn, stream->id, + (uint8_t *)CURL_UNCONST(buf), len, eos); + if(rv == QUICHE_H3_ERR_DONE || (rv == 0 && len > 0)) { + /* Blocked on flow control and should HOLD sending. + When do we open again? */ + if(!quiche_conn_stream_writable(ctx->qconn, stream->id, len)) { + CURL_TRC_CF(data, cf, "[%" PRIu64 "] send_body(len=%zu) " + "-> window exhausted", stream->id, len); + stream->quic_flow_blocked = TRUE; + } + return CURLE_AGAIN; + } + else if(rv == QUICHE_H3_TRANSPORT_ERR_INVALID_STREAM_STATE) { + CURL_TRC_CF(data, cf, "[%" PRIu64 "] send_body(len=%zu) " + "-> invalid stream state", stream->id, len); + return CURLE_HTTP3; + } + else if(rv == QUICHE_H3_TRANSPORT_ERR_FINAL_SIZE) { + CURL_TRC_CF(data, cf, "[%" PRIu64 "] send_body(len=%zu) -> exceeds size", + stream->id, len); + return CURLE_SEND_ERROR; + } + else if(!curlx_sztouz(rv, pnwritten)) { + CURL_TRC_CF(data, cf, "[%" PRIu64 "] send_body(len=%zu) -> quiche err %zd", + stream->id, len, rv); + return CURLE_SEND_ERROR; + } + else { + if(eos && (len == *pnwritten)) + stream->send_closed = TRUE; + CURL_TRC_CF(data, cf, "[%" PRIu64 "] send body(len=%zu, eos=%d) -> %zu", + stream->id, len, stream->send_closed, *pnwritten); + return CURLE_OK; + } +} + +static CURLcode h3_open_stream(struct Curl_cfilter *cf, + struct Curl_easy *data, + const uint8_t *buf, size_t blen, bool eos, + size_t *pnwritten) +{ + struct cf_quiche_ctx *ctx = cf->ctx; + struct h3_stream_ctx *stream = H3_STREAM_CTX(ctx, data); + size_t nheader, i; + int64_t rv; + struct dynhds h2_headers; + quiche_h3_header *nva = NULL; + CURLcode result = CURLE_OK; + + *pnwritten = 0; + if(!stream) { + result = h3_data_setup(cf, data); + if(result) + return result; + stream = H3_STREAM_CTX(ctx, data); + DEBUGASSERT(stream); + } + + Curl_dynhds_init(&h2_headers, 0, DYN_HTTP_REQUEST); + + DEBUGASSERT(stream); + + result = Curl_h1_req_parse_read(&stream->h1, buf, blen, NULL, + !data->state.http_ignorecustom ? + data->set.str[STRING_CUSTOMREQUEST] : NULL, + 0, pnwritten); + if(result) + goto out; + if(!stream->h1.done) { + /* need more data */ + goto out; + } + DEBUGASSERT(stream->h1.req); + + result = Curl_http_req_to_h2(&h2_headers, stream->h1.req, data); + if(result) + goto out; + + /* no longer needed */ + Curl_h1_req_parse_free(&stream->h1); + + nheader = Curl_dynhds_count(&h2_headers); + nva = curlx_malloc(sizeof(quiche_h3_header) * nheader); + if(!nva) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + for(i = 0; i < nheader; ++i) { + struct dynhds_entry *e = Curl_dynhds_getn(&h2_headers, i); + nva[i].name = (unsigned char *)e->name; + nva[i].name_len = e->namelen; + nva[i].value = (unsigned char *)e->value; + nva[i].value_len = e->valuelen; + } + + buf += *pnwritten; + blen -= *pnwritten; + + if(eos && !blen) + stream->send_closed = TRUE; + + rv = quiche_h3_send_request(ctx->h3c, ctx->qconn, nva, nheader, + stream->send_closed); + CURL_TRC_CF(data, cf, "quiche_send_request() -> %" PRId64, rv); + if(rv < 0) { + if(QUICHE_H3_ERR_STREAM_BLOCKED == rv) { + /* quiche seems to report this error if the connection window is + * exhausted. Which happens frequently and intermittent. */ + CURL_TRC_CF(data, cf, "[%" PRIu64 "] blocked", stream->id); + stream->quic_flow_blocked = TRUE; + result = CURLE_AGAIN; + goto out; + } + else { + CURL_TRC_CF(data, cf, "send_request(%s) -> %" PRId64, + Curl_bufref_ptr(&data->state.url), rv); + } + result = CURLE_SEND_ERROR; + goto out; + } + + DEBUGASSERT(!stream->opened); + stream->id = (uint64_t)rv; + stream->opened = TRUE; + stream->closed = FALSE; + stream->reset = FALSE; + + if(Curl_trc_is_verbose(data)) { + infof(data, "[HTTP/3] [%" PRIu64 "] OPENED stream for %s", + stream->id, Curl_bufref_ptr(&data->state.url)); + for(i = 0; i < nheader; ++i) { + infof(data, "[HTTP/3] [%" PRIu64 "] [%.*s: %.*s]", stream->id, + (int)nva[i].name_len, nva[i].name, + (int)nva[i].value_len, nva[i].value); + } + } + + if(blen) { /* after the headers, there was request BODY data */ + size_t nwritten; + CURLcode r2 = CURLE_OK; + + r2 = cf_quiche_send_body(cf, data, stream, buf, blen, eos, &nwritten); + if(r2 && (r2 != CURLE_AGAIN)) { /* real error, fail */ + result = r2; + } + else if(nwritten > 0) { + *pnwritten += nwritten; + } + } + +out: + curlx_free(nva); + Curl_dynhds_free(&h2_headers); + return result; +} + +static CURLcode cf_quiche_send(struct Curl_cfilter *cf, struct Curl_easy *data, + const uint8_t *buf, size_t len, bool eos, + size_t *pnwritten) +{ + struct cf_quiche_ctx *ctx = cf->ctx; + struct h3_stream_ctx *stream = H3_STREAM_CTX(ctx, data); + CURLcode result; + + *pnwritten = 0; + vquic_ctx_update_time(&ctx->q, Curl_pgrs_now(data)); + + result = cf_process_ingress(cf, data); + if(result) + goto out; + + if(!stream || !stream->opened) { + result = h3_open_stream(cf, data, buf, len, eos, pnwritten); + if(result) + goto out; + stream = H3_STREAM_CTX(ctx, data); + } + else if(stream->xfer_result) { + cf_quiche_stream_close(cf, data, stream); + result = stream->xfer_result; + } + else if(stream->closed) { + if(stream->resp_hds_complete) { + /* sending request body on a stream that has been closed by the + * server. If the server has send us a final response, we should + * silently discard the send data. + * This happens for example on redirects where the server, instead + * of reading the full request body closed the stream after + * sending the 30x response. + * This is sort of a race: had the transfer loop called recv first, + * it would see the response and stop/discard sending on its own- */ + CURL_TRC_CF(data, cf, "[%" PRIu64 "] discarding data" + "on closed stream with response", stream->id); + result = CURLE_OK; + *pnwritten = len; + goto out; + } + CURL_TRC_CF(data, cf, "[%" PRIu64 "] send_body(len=%zu) " + "-> stream closed", stream->id, len); + result = CURLE_HTTP3; + goto out; + } + else { + result = cf_quiche_send_body(cf, data, stream, buf, len, eos, pnwritten); + } + +out: + result = Curl_1st_fatal(result, cf_flush_egress(cf, data)); + + CURL_TRC_CF(data, cf, "[%" PRIu64 "] cf_send(len=%zu) -> %d, %zu", + stream ? stream->id : (uint64_t)~0, len, + (int)result, *pnwritten); + return result; +} + +static bool stream_is_writable(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_quiche_ctx *ctx = cf->ctx; + struct h3_stream_ctx *stream = H3_STREAM_CTX(ctx, data); + + return stream && (quiche_conn_stream_writable( + ctx->qconn, stream->id, 1) > 0); +} + +static CURLcode cf_quiche_adjust_pollset(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct easy_pollset *ps) +{ + struct cf_quiche_ctx *ctx = cf->ctx; + bool want_recv, want_send; + CURLcode result = CURLE_OK; + + if(!ctx->qconn) + return CURLE_OK; + + Curl_pollset_check(data, ps, ctx->q.sockfd, &want_recv, &want_send); + if(want_recv || want_send) { + struct h3_stream_ctx *stream = H3_STREAM_CTX(ctx, data); + bool c_exhaust, s_exhaust; + + c_exhaust = FALSE; /* Have not found any call in quiche that tells + us if the connection itself is blocked */ + s_exhaust = want_send && stream && stream->opened && + (stream->quic_flow_blocked || !stream_is_writable(cf, data)); + want_recv = (want_recv || c_exhaust || s_exhaust); + want_send = (!s_exhaust && want_send) || + !Curl_bufq_is_empty(&ctx->q.sendbuf); + + result = Curl_pollset_set(data, ps, ctx->q.sockfd, want_recv, want_send); + } + return result; +} + +static CURLcode h3_data_pause(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool pause) +{ + /* There seems to exist no API in quiche to shrink/enlarge the streams + * windows. As we do in HTTP/2. */ + (void)cf; + if(!pause) { + Curl_multi_mark_dirty(data); + } + return CURLE_OK; +} + +static CURLcode cf_quiche_cntrl(struct Curl_cfilter *cf, + struct Curl_easy *data, + int event, int arg1, void *arg2) +{ + struct cf_quiche_ctx *ctx = cf->ctx; + CURLcode result = CURLE_OK; + + (void)arg1; + (void)arg2; + switch(event) { + case CF_CTRL_DATA_SETUP: + break; + case CF_CTRL_DATA_PAUSE: + result = h3_data_pause(cf, data, (arg1 != 0)); + break; + case CF_CTRL_DATA_DONE: + h3_data_done(cf, data); + break; + case CF_CTRL_DATA_DONE_SEND: { + struct h3_stream_ctx *stream = H3_STREAM_CTX(ctx, data); + if(stream && !stream->send_closed) { + unsigned char body[1]; + size_t sent; + + stream->send_closed = TRUE; + body[0] = 'X'; + result = cf_quiche_send(cf, data, body, 0, TRUE, &sent); + CURL_TRC_CF(data, cf, "[%" PRIu64 "] DONE_SEND -> %d, %zu", + stream->id, (int)result, sent); + } + break; + } + case CF_CTRL_CONN_INFO_UPDATE: + if(!cf->sockindex && cf->connected) { + cf->conn->httpversion_seen = 30; + Curl_conn_set_multiplex(cf->conn); + } + break; + default: + break; + } + return result; +} + +static CURLcode cf_quiche_ctx_open(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_quiche_ctx *ctx = cf->ctx; + int rv; + CURLcode result; + const struct Curl_sockaddr_ex *sockaddr; + static const struct alpn_spec ALPN_SPEC_H3 = { { "h3" }, 1 }; + + DEBUGASSERT(ctx->q.sockfd != CURL_SOCKET_BAD); + DEBUGASSERT(ctx->initialized); + + result = vquic_ctx_init(data, &ctx->q); + if(result) + return result; + + ctx->cfg = quiche_config_new(QUICHE_PROTOCOL_VERSION); + if(!ctx->cfg) { + failf(data, "cannot create quiche config"); + return CURLE_FAILED_INIT; + } + quiche_config_enable_pacing(ctx->cfg, FALSE); + quiche_config_set_initial_max_data(ctx->cfg, (1 * 1024 * 1024) + /* (QUIC_MAX_STREAMS/2) * H3_STREAM_WINDOW_SIZE */); + quiche_config_set_initial_max_streams_bidi(ctx->cfg, QUIC_MAX_STREAMS); + quiche_config_set_initial_max_streams_uni(ctx->cfg, QUIC_MAX_STREAMS); + quiche_config_set_initial_max_stream_data_bidi_local(ctx->cfg, + H3_STREAM_WINDOW_SIZE); + quiche_config_set_initial_max_stream_data_bidi_remote(ctx->cfg, + H3_STREAM_WINDOW_SIZE); + quiche_config_set_initial_max_stream_data_uni(ctx->cfg, + H3_STREAM_WINDOW_SIZE); + quiche_config_set_disable_active_migration(ctx->cfg, TRUE); + + quiche_config_set_max_connection_window(ctx->cfg, + 10 * QUIC_MAX_STREAMS * H3_STREAM_WINDOW_SIZE); + quiche_config_set_max_stream_window(ctx->cfg, 10 * H3_STREAM_WINDOW_SIZE); + quiche_config_set_application_protos(ctx->cfg, + (uint8_t *)CURL_UNCONST(QUICHE_H3_APPLICATION_PROTOCOL), + sizeof(QUICHE_H3_APPLICATION_PROTOCOL) + - 1); + + result = Curl_vquic_tls_init(&ctx->tls, cf, data, &ctx->ssl_peer, + &ALPN_SPEC_H3, NULL, NULL, cf, NULL); + if(result) + return result; + + result = Curl_rand(data, ctx->scid, sizeof(ctx->scid)); + if(result) + return result; + + if(Curl_cf_socket_peek(cf->next, data, &ctx->q.sockfd, &sockaddr, NULL)) + return CURLE_QUIC_CONNECT_ERROR; + + ctx->q.local_addrlen = sizeof(ctx->q.local_addr); + rv = getsockname(ctx->q.sockfd, (struct sockaddr *)&ctx->q.local_addr, + &ctx->q.local_addrlen); + if(rv == -1) + return CURLE_QUIC_CONNECT_ERROR; + + ctx->qconn = quiche_conn_new_with_tls((const uint8_t *)ctx->scid, + sizeof(ctx->scid), NULL, 0, + (struct sockaddr *)&ctx->q.local_addr, + ctx->q.local_addrlen, + &sockaddr->curl_sa_addr, + sockaddr->addrlen, + ctx->cfg, ctx->tls.ossl.ssl, FALSE); + if(!ctx->qconn) { + failf(data, "cannot create quiche connection"); + return CURLE_OUT_OF_MEMORY; + } + + /* Known to not work on Windows */ +#if !defined(_WIN32) && defined(HAVE_QUICHE_CONN_SET_QLOG_FD) + { + int qfd; + (void)Curl_qlogdir(data, ctx->scid, sizeof(ctx->scid), &qfd); + if(qfd != -1) + quiche_conn_set_qlog_fd(ctx->qconn, qfd, "qlog title", "curl qlog"); + } +#endif + + result = cf_flush_egress(cf, data); + if(result) + return result; + + { + unsigned char alpn_protocols[] = QUICHE_H3_APPLICATION_PROTOCOL; + unsigned alpn_len, offset = 0; + + /* Replace each ALPN length prefix by a comma. */ + while(offset < sizeof(alpn_protocols) - 1) { + alpn_len = alpn_protocols[offset]; + alpn_protocols[offset] = ','; + offset += 1 + alpn_len; + } + + CURL_TRC_CF(data, cf, "Sent QUIC client Initial, ALPN: %s", + alpn_protocols + 1); + } + + return CURLE_OK; +} + +static CURLcode cf_quiche_verify_peer(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct cf_quiche_ctx *ctx = cf->ctx; + return Curl_vquic_tls_verify_peer(&ctx->tls, cf, data, &ctx->ssl_peer); +} + +static CURLcode cf_quiche_connect(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ + struct cf_quiche_ctx *ctx = cf->ctx; + CURLcode result = CURLE_OK; + + if(cf->connected) { + *done = TRUE; + return CURLE_OK; + } + + /* Connect the UDP filter first */ + if(!cf->next->connected) { + result = Curl_conn_cf_connect(cf->next, data, done); + if(result || !*done) + return result; + } + + *done = FALSE; + if(Curl_ossl_need_httpsrr(data) && + !Curl_conn_dns_resolved_https(data, cf->sockindex, ctx->ssl_peer.peer)) { + CURL_TRC_CF(data, cf, "need HTTPS-RR, delaying connect"); + return CURLE_OK; + } + + vquic_ctx_update_time(&ctx->q, Curl_pgrs_now(data)); + + if(!ctx->qconn) { + result = cf_quiche_ctx_open(cf, data); + if(result) + goto out; + ctx->started_at = ctx->q.last_op; + result = cf_flush_egress(cf, data); + /* we do not expect to be able to recv anything yet */ + goto out; + } + + result = cf_process_ingress(cf, data); + if(result) + goto out; + + result = cf_flush_egress(cf, data); + if(result) + goto out; + + if(quiche_conn_is_established(ctx->qconn)) { + ctx->handshake_at = ctx->q.last_op; + CURL_TRC_CF(data, cf, "handshake complete after %" FMT_TIMEDIFF_T "ms", + curlx_ptimediff_ms(&ctx->handshake_at, &ctx->started_at)); + result = cf_quiche_verify_peer(cf, data); + if(!result) { + CURL_TRC_CF(data, cf, "peer verified"); + ctx->h3config = quiche_h3_config_new(); + if(!ctx->h3config) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + /* Create a new HTTP/3 connection on the QUIC connection. */ + ctx->h3c = quiche_h3_conn_new_with_transport(ctx->qconn, ctx->h3config); + if(!ctx->h3c) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + cf->connected = TRUE; + *done = TRUE; + } + } + else if(quiche_conn_is_draining(ctx->qconn)) { + /* When a QUIC server instance is shutting down, it may send us a + * CONNECTION_CLOSE right away. Our connection then enters the DRAINING + * state. The CONNECT may work in the near future again. Indicate + * that as a "weird" reply. */ + result = CURLE_WEIRD_SERVER_REPLY; + } + +out: +#ifdef CURLVERBOSE + if(result && result != CURLE_AGAIN) { + struct ip_quadruple ip; + + if(!Curl_cf_socket_peek(cf->next, data, NULL, NULL, &ip)) + infof(data, "connect to %s port %u failed: %s", + ip.remote_ip, ip.remote_port, curl_easy_strerror(result)); + else + infof(data, "connect failed: %s", curl_easy_strerror(result)); + } +#endif + return result; +} + +static CURLcode cf_quiche_shutdown(struct Curl_cfilter *cf, + struct Curl_easy *data, bool *done) +{ + struct cf_quiche_ctx *ctx = cf->ctx; + CURLcode result = CURLE_OK; + + if(cf->shutdown || !ctx || !ctx->qconn) { + *done = TRUE; + return CURLE_OK; + } + + *done = FALSE; + if(!ctx->shutdown_started) { + int err; + + ctx->shutdown_started = TRUE; + vquic_ctx_update_time(&ctx->q, Curl_pgrs_now(data)); + err = quiche_conn_close(ctx->qconn, TRUE, 0, NULL, 0); + if(err) { + CURL_TRC_CF(data, cf, "error %d adding shutdown packet, " + "aborting shutdown", err); + result = CURLE_SEND_ERROR; + goto out; + } + } + + if(!Curl_bufq_is_empty(&ctx->q.sendbuf)) { + CURL_TRC_CF(data, cf, "shutdown, flushing sendbuf"); + result = cf_flush_egress(cf, data); + if(result) + goto out; + } + + if(Curl_bufq_is_empty(&ctx->q.sendbuf)) { + /* sent everything, quiche does not seem to support a graceful + * shutdown waiting for a reply, so ware done. */ + CURL_TRC_CF(data, cf, "shutdown completely sent off, done"); + *done = TRUE; + } + else { + CURL_TRC_CF(data, cf, "shutdown sending blocked"); + } + +out: + return result; +} + +static void cf_quiche_destroy(struct Curl_cfilter *cf, struct Curl_easy *data) +{ + (void)data; + if(cf->ctx) { + cf_quiche_ctx_close(cf->ctx); + cf_quiche_ctx_free(cf->ctx); + cf->ctx = NULL; + } +} + +static CURLcode cf_quiche_query(struct Curl_cfilter *cf, + struct Curl_easy *data, + int query, int *pres1, void *pres2) +{ + struct cf_quiche_ctx *ctx = cf->ctx; + + switch(query) { + case CF_QUERY_MAX_CONCURRENT: { + uint64_t max_streams = cf->conn->attached_xfers; + if(!ctx->goaway && ctx->qconn) { + max_streams += quiche_conn_peer_streams_left_bidi(ctx->qconn); + } + *pres1 = (max_streams > INT_MAX) ? INT_MAX : (int)max_streams; + CURL_TRC_CF(data, cf, "query conn[%" FMT_OFF_T "]: " + "MAX_CONCURRENT -> %d (%u in use)", + cf->conn->connection_id, *pres1, cf->conn->attached_xfers); + return CURLE_OK; + } + case CF_QUERY_CONNECT_REPLY_MS: + if(ctx->q.got_first_byte) { + timediff_t ms = curlx_ptimediff_ms(&ctx->q.first_byte_at, + &ctx->started_at); + *pres1 = (ms < INT_MAX) ? (int)ms : INT_MAX; + } + else + *pres1 = -1; + return CURLE_OK; + case CF_QUERY_TIMER_CONNECT: { + struct curltime *when = pres2; + if(ctx->q.got_first_byte) + *when = ctx->q.first_byte_at; + return CURLE_OK; + } + case CF_QUERY_TIMER_APPCONNECT: { + struct curltime *when = pres2; + if(cf->connected) + *when = ctx->handshake_at; + return CURLE_OK; + } + case CF_QUERY_HTTP_VERSION: + *pres1 = 30; + return CURLE_OK; + case CF_QUERY_SSL_INFO: + case CF_QUERY_SSL_CTX_INFO: { + struct curl_tlssessioninfo *info = pres2; + if(Curl_vquic_tls_get_ssl_info(&ctx->tls, + (query == CF_QUERY_SSL_CTX_INFO), info)) + return CURLE_OK; + break; + } + case CF_QUERY_ALPN_NEGOTIATED: { + const char **palpn = pres2; + DEBUGASSERT(palpn); + *palpn = cf->connected ? "h3" : NULL; + return CURLE_OK; + } + default: + break; + } + return cf->next ? + cf->next->cft->query(cf->next, data, query, pres1, pres2) : + CURLE_UNKNOWN_OPTION; +} + +static bool cf_quiche_conn_is_alive(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *input_pending) +{ + struct cf_quiche_ctx *ctx = cf->ctx; + bool alive = TRUE; + + *input_pending = FALSE; + if(!ctx->qconn) + return FALSE; + + if(quiche_conn_is_closed(ctx->qconn)) { + if(quiche_conn_is_timed_out(ctx->qconn)) + CURL_TRC_CF(data, cf, "connection was closed due to idle timeout"); + else + CURL_TRC_CF(data, cf, "connection is closed"); + return FALSE; + } + + if(!cf->next || !cf->next->cft->is_alive(cf->next, data, input_pending)) + return FALSE; + + if(*input_pending) { + /* This happens before we have sent off a request and the connection is + not in use by any other transfer, there should not be any data here, + only "protocol frames" */ + *input_pending = FALSE; + if(cf_process_ingress(cf, data)) + alive = FALSE; + else { + alive = TRUE; + } + } + + return alive; +} + +struct Curl_cftype Curl_cft_http3 = { + "HTTP/3", + CF_TYPE_IP_CONNECT | CF_TYPE_SSL | CF_TYPE_MULTIPLEX | CF_TYPE_HTTP, + 0, + cf_quiche_destroy, + cf_quiche_connect, + cf_quiche_shutdown, + cf_quiche_adjust_pollset, + Curl_cf_def_data_pending, + cf_quiche_send, + cf_quiche_recv, + cf_quiche_cntrl, + cf_quiche_conn_is_alive, + Curl_cf_def_conn_keep_alive, + cf_quiche_query, +}; + +CURLcode Curl_cf_quiche_create(struct Curl_cfilter **pcf, + struct Curl_easy *data, + struct Curl_peer *origin, + struct Curl_peer *peer, + struct connectdata *conn, + struct Curl_sockaddr_ex *addr) +{ + struct cf_quiche_ctx *ctx = NULL; + struct Curl_cfilter *cf = NULL; + CURLcode result; + + ctx = curlx_calloc(1, sizeof(*ctx)); + if(!ctx) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + result = cf_quiche_ctx_init(ctx, origin, peer, &conn->ssl_config); + if(!result) + result = Curl_cf_create(&cf, &Curl_cft_http3, ctx); + if(result) + goto out; + cf->conn = conn; + + result = Curl_cf_udp_create(&cf->next, data, origin, peer, TRNSPRT_QUIC, + conn, addr, NULL, TRNSPRT_QUIC); + if(result) + goto out; + cf->next->conn = cf->conn; + cf->next->sockindex = cf->sockindex; + +out: + *pcf = (!result) ? cf : NULL; + if(result) { + if(cf) + Curl_conn_cf_discard_chain(&cf, data); + else if(ctx) + cf_quiche_ctx_free(ctx); + } + + return result; +} + +CURLcode Curl_cf_quiche_insert_after(struct Curl_cfilter *cf_at, + struct Curl_peer *origin, + struct Curl_peer *peer) +{ + struct cf_quiche_ctx *ctx = NULL; + struct Curl_cfilter *cf = NULL; + CURLcode result; + + ctx = curlx_calloc(1, sizeof(*ctx)); + if(!ctx) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + result = cf_quiche_ctx_init(ctx, origin, peer, &cf_at->conn->ssl_config); + if(!result) + result = Curl_cf_create(&cf, &Curl_cft_http3, ctx); + if(result) + goto out; + Curl_conn_cf_insert_after(cf_at, cf); + +out: + if(result) { + curlx_safefree(cf); + if(ctx) + cf_quiche_ctx_free(ctx); + } + + return result; +} + +#endif diff --git a/3rdparty/curl-8.21.0/lib/vquic/cf-quiche.h b/3rdparty/curl-8.21.0/lib/vquic/cf-quiche.h new file mode 100644 index 0000000000..88d9161dd7 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vquic/cf-quiche.h @@ -0,0 +1,50 @@ +#ifndef HEADER_CURL_VQUIC_CF_QUICHE_H +#define HEADER_CURL_VQUIC_CF_QUICHE_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_HTTP) && defined(USE_QUICHE) + +#include +#include + +struct Curl_cfilter; +struct Curl_easy; + +void Curl_quiche_ver(char *p, size_t len); + +CURLcode Curl_cf_quiche_create(struct Curl_cfilter **pcf, + struct Curl_easy *data, + struct Curl_peer *origin, + struct Curl_peer *peer, + struct connectdata *conn, + struct Curl_sockaddr_ex *addr); +CURLcode Curl_cf_quiche_insert_after(struct Curl_cfilter *cf_at, + struct Curl_peer *origin, + struct Curl_peer *peer); + +#endif + +#endif /* HEADER_CURL_VQUIC_CF_QUICHE_H */ diff --git a/3rdparty/curl-8.21.0/lib/vquic/vquic-tls.c b/3rdparty/curl-8.21.0/lib/vquic/vquic-tls.c new file mode 100644 index 0000000000..58f139306a --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vquic/vquic-tls.c @@ -0,0 +1,241 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if defined(USE_HTTP3) && \ + (defined(USE_OPENSSL) || defined(USE_GNUTLS) || defined(USE_WOLFSSL)) + +#ifdef USE_OPENSSL +#include +#include "vtls/openssl.h" +#elif defined(USE_GNUTLS) +#include +#include +#include +#include +#include +#include "vtls/gtls.h" +#elif defined(USE_WOLFSSL) +#include +#include +#include +#include "vtls/wolfssl.h" +#endif + +#include "urldata.h" +#include "cfilters.h" +#include "vtls/vtls.h" +#include "vtls/vtls_scache.h" +#include "vquic/vquic-tls.h" + +CURLcode Curl_vquic_tls_peer_init(struct Curl_peer *origin, + struct Curl_peer *peer, + struct ssl_primary_config *sslc, + struct ssl_peer *ssl_peer) +{ + char tls_id[80]; + +#ifdef USE_OPENSSL + Curl_ossl_version(tls_id, sizeof(tls_id)); +#elif defined(USE_GNUTLS) + Curl_gtls_version(tls_id, sizeof(tls_id)); +#elif defined(USE_WOLFSSL) + Curl_wssl_version(tls_id, sizeof(tls_id)); +#else +#error "no TLS lib in used, should not happen" + return CURLE_FAILED_INIT; +#endif + if(ssl_peer->origin || ssl_peer->peer) + Curl_ssl_peer_cleanup(ssl_peer); + return Curl_ssl_peer_init(ssl_peer, origin, peer, sslc, + tls_id, TRNSPRT_QUIC); +} + +CURLcode Curl_vquic_tls_init(struct curl_tls_ctx *ctx, + struct Curl_cfilter *cf, + struct Curl_easy *data, + struct ssl_peer *ssl_peer, + const struct alpn_spec *alpns, + Curl_vquic_tls_ctx_setup *cb_setup, + void *cb_user_data, void *ssl_user_data, + Curl_vquic_session_reuse_cb *session_reuse_cb) +{ +#ifdef USE_OPENSSL + return Curl_ossl_ctx_init(&ctx->ossl, cf, data, ssl_peer, alpns, + cb_setup, cb_user_data, NULL, ssl_user_data, + session_reuse_cb); +#elif defined(USE_GNUTLS) + return Curl_gtls_ctx_init(&ctx->gtls, cf, data, ssl_peer, alpns, + cb_setup, cb_user_data, ssl_user_data, + session_reuse_cb); +#elif defined(USE_WOLFSSL) + return Curl_wssl_ctx_init(&ctx->wssl, cf, data, ssl_peer, alpns, + cb_setup, cb_user_data, + ssl_user_data, session_reuse_cb); +#else +#error "no TLS lib in used, should not happen" + return CURLE_FAILED_INIT; +#endif +} + +void Curl_vquic_tls_cleanup(struct curl_tls_ctx *ctx) +{ +#ifdef USE_OPENSSL + if(ctx->ossl.ssl) + SSL_free(ctx->ossl.ssl); + if(ctx->ossl.ssl_ctx) + SSL_CTX_free(ctx->ossl.ssl_ctx); +#elif defined(USE_GNUTLS) + if(ctx->gtls.session) + gnutls_deinit(ctx->gtls.session); + Curl_gtls_shared_creds_free(&ctx->gtls.shared_creds); +#elif defined(USE_WOLFSSL) + if(ctx->wssl.ssl) + wolfSSL_free(ctx->wssl.ssl); + if(ctx->wssl.ssl_ctx) + wolfSSL_CTX_free(ctx->wssl.ssl_ctx); +#endif + memset(ctx, 0, sizeof(*ctx)); +} + +CURLcode Curl_vquic_tls_before_recv(struct curl_tls_ctx *ctx, + struct Curl_cfilter *cf, + struct Curl_easy *data) +{ +#ifdef USE_OPENSSL + if(!ctx->ossl.x509_store_setup) { + CURLcode result = Curl_ssl_setup_x509_store(cf, data, &ctx->ossl); + if(result) + return result; + ctx->ossl.x509_store_setup = TRUE; + } +#elif defined(USE_WOLFSSL) + if(!ctx->wssl.x509_store_setup) { + CURLcode result = Curl_wssl_setup_x509_store(cf, data, &ctx->wssl); + if(result) + return result; + } +#elif defined(USE_GNUTLS) + if(!ctx->gtls.shared_creds->trust_setup) { + CURLcode result = Curl_gtls_client_trust_setup(cf, data, &ctx->gtls); + if(result) + return result; + } +#else + (void)ctx; + (void)cf; + (void)data; +#endif + return CURLE_OK; +} + +CURLcode Curl_vquic_tls_verify_peer(struct curl_tls_ctx *ctx, + struct Curl_cfilter *cf, + struct Curl_easy *data, + struct ssl_peer *peer) +{ + struct ssl_primary_config *conn_config; + CURLcode result = CURLE_OK; + + conn_config = Curl_ssl_cf_get_primary_config(cf); + if(!conn_config) + return CURLE_FAILED_INIT; + +#ifdef USE_OPENSSL + (void)conn_config; + result = Curl_ossl_check_peer_cert(cf, data, &ctx->ossl, peer); +#elif defined(USE_GNUTLS) + result = Curl_gtls_verifyserver(cf, data, ctx->gtls.session, + conn_config, &data->set.ssl, peer, + data->set.str[STRING_SSL_PINNEDPUBLICKEY]); + if(result) + return result; +#elif defined(USE_WOLFSSL) + (void)data; + if(conn_config->verifyhost) { + WOLFSSL_X509 *cert = wolfSSL_get_peer_certificate(ctx->wssl.ssl); + if(!cert) + result = CURLE_OUT_OF_MEMORY; + else if(peer->sni && + (wolfSSL_X509_check_host(cert, peer->sni, strlen(peer->sni), 0, + NULL) == WOLFSSL_FAILURE)) + result = CURLE_PEER_FAILED_VERIFICATION; + else if(!peer->sni && + (wolfSSL_X509_check_ip_asc(cert, peer->origin->hostname, + 0) == WOLFSSL_FAILURE)) + result = CURLE_PEER_FAILED_VERIFICATION; + wolfSSL_X509_free(cert); + } + if(!result) + result = Curl_wssl_verify_pinned(cf, data, &ctx->wssl); +#endif + /* on error, remove any session we might have in the pool */ + if(result) + Curl_ssl_scache_remove_all(cf, data, peer->scache_key); + return result; +} + +bool Curl_vquic_tls_get_ssl_info(struct curl_tls_ctx *ctx, + bool give_ssl_ctx, + struct curl_tlssessioninfo *info) +{ +#ifdef USE_OPENSSL + info->backend = CURLSSLBACKEND_OPENSSL; + info->internals = give_ssl_ctx ? + (void *)ctx->ossl.ssl_ctx : (void *)ctx->ossl.ssl; + return TRUE; +#elif defined(USE_GNUTLS) + (void)give_ssl_ctx; /* gnutls always returns its session */ + info->backend = CURLSSLBACKEND_GNUTLS; + info->internals = ctx->gtls.session; + return TRUE; +#elif defined(USE_WOLFSSL) + info->backend = CURLSSLBACKEND_WOLFSSL; + info->internals = give_ssl_ctx ? + (void *)ctx->wssl.ssl_ctx : (void *)ctx->wssl.ssl; + return TRUE; +#else + return FALSE; +#endif +} + +void Curl_vquic_report_handshake(struct curl_tls_ctx *ctx, + struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + (void)cf; +#ifdef USE_OPENSSL + (void)cf; + Curl_ossl_report_handshake(data, &ctx->ossl); +#elif defined(USE_GNUTLS) + Curl_gtls_report_handshake(data, &ctx->gtls); +#elif defined(USE_WOLFSSL) + Curl_wssl_report_handshake(data, &ctx->wssl); +#else + (void)data; + (void)ctx; +#endif +} + +#endif /* !USE_HTTP3 && (USE_OPENSSL || USE_GNUTLS || USE_WOLFSSL) */ diff --git a/3rdparty/curl-8.21.0/lib/vquic/vquic-tls.h b/3rdparty/curl-8.21.0/lib/vquic/vquic-tls.h new file mode 100644 index 0000000000..e8d2418b06 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vquic/vquic-tls.h @@ -0,0 +1,125 @@ +#ifndef HEADER_CURL_VQUIC_TLS_H +#define HEADER_CURL_VQUIC_TLS_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if defined(USE_HTTP3) && \ + (defined(USE_OPENSSL) || defined(USE_GNUTLS) || defined(USE_WOLFSSL)) + +#include "bufq.h" +#include "vtls/vtls.h" +#include "vtls/vtls_int.h" + +#include "vtls/openssl.h" +#include "vtls/wolfssl.h" + +struct ssl_peer; +struct Curl_ssl_session; +struct curl_tlssessioninfo; + +struct curl_tls_ctx { +#ifdef USE_OPENSSL + struct ossl_ctx ossl; +#elif defined(USE_GNUTLS) + struct gtls_ctx gtls; +#elif defined(USE_WOLFSSL) + struct wssl_ctx wssl; +#endif +}; + +/** + * Callback passed to `Curl_vquic_tls_init()` that can + * do early initializations on the not otherwise configured TLS + * instances created. This varies by TLS backend: + * - openssl/wolfssl: SSL_CTX* has been created + * - gnutls: gtls_client_init() has run + */ +typedef CURLcode Curl_vquic_tls_ctx_setup(struct Curl_cfilter *cf, + struct Curl_easy *data, + void *cb_user_data); + +typedef CURLcode Curl_vquic_session_reuse_cb(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct alpn_spec *alpns, + struct Curl_ssl_session *scs, + bool *do_early_data); + +CURLcode Curl_vquic_tls_peer_init(struct Curl_peer *origin, + struct Curl_peer *peer, + struct ssl_primary_config *sslc, + struct ssl_peer *ssl_peer); + +/** + * Initialize the QUIC TLS instances based of the SSL configurations + * for the connection filter, transfer and peer. + * @param ctx the TLS context to initialize + * @param cf the connection filter involved + * @param data the transfer involved + * @param ssl_peer the SSL peer to be connected to + * @param alpns the ALPN specifications to negotiate, may be NULL + * @param cb_setup optional callback for early TLS config + * @param cb_user_data user_data param for callback + * @param ssl_user_data optional pointer to set in TLS application context + * @param session_reuse_cb callback to handle session reuse, signal early data + */ +CURLcode Curl_vquic_tls_init(struct curl_tls_ctx *ctx, + struct Curl_cfilter *cf, + struct Curl_easy *data, + struct ssl_peer *ssl_peer, + const struct alpn_spec *alpns, + Curl_vquic_tls_ctx_setup *cb_setup, + void *cb_user_data, + void *ssl_user_data, + Curl_vquic_session_reuse_cb *session_reuse_cb); + +/** + * Cleanup all data that has been initialized. + */ +void Curl_vquic_tls_cleanup(struct curl_tls_ctx *ctx); + +CURLcode Curl_vquic_tls_before_recv(struct curl_tls_ctx *ctx, + struct Curl_cfilter *cf, + struct Curl_easy *data); + +/** + * After the QUIC basic handshake has been, verify that the peer + * (and its certificate) fulfill our requirements. + */ +CURLcode Curl_vquic_tls_verify_peer(struct curl_tls_ctx *ctx, + struct Curl_cfilter *cf, + struct Curl_easy *data, + struct ssl_peer *peer); + +bool Curl_vquic_tls_get_ssl_info(struct curl_tls_ctx *ctx, + bool give_ssl_ctx, + struct curl_tlssessioninfo *info); + +void Curl_vquic_report_handshake(struct curl_tls_ctx *ctx, + struct Curl_cfilter *cf, + struct Curl_easy *data); + +#endif /* !USE_HTTP3 && (USE_OPENSSL || USE_GNUTLS || USE_WOLFSSL) */ + +#endif /* HEADER_CURL_VQUIC_TLS_H */ diff --git a/3rdparty/curl-8.21.0/lib/vquic/vquic.c b/3rdparty/curl-8.21.0/lib/vquic/vquic.c new file mode 100644 index 0000000000..dfb8346c1a --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vquic/vquic.c @@ -0,0 +1,1006 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" +#include "urldata.h" +#include "vquic/vquic.h" + +#include "curl_trc.h" + +#if !defined(CURL_DISABLE_HTTP) && defined(USE_HTTP3) + +#ifdef HAVE_NETINET_UDP_H +#include +#endif + +#ifdef USE_NGHTTP3 +#include +#endif + +#include "bufq.h" +#include "curlx/dynbuf.h" +#include "curlx/fopen.h" +#include "cfilters.h" +#include "vquic/cf-ngtcp2.h" +#include "vquic/cf-ngtcp2-cmn.h" +#include "vquic/cf-ngtcp2-proxy.h" +#include "vquic/cf-quiche.h" +#include "multiif.h" +#include "progress.h" +#include "rand.h" +#include "vquic/vquic_int.h" +#include "curlx/strerr.h" +#include "curlx/strparse.h" + + +#define NW_CHUNK_SIZE (64 * 1024) +#define NW_SEND_CHUNKS 1 + +int Curl_vquic_init(void) +{ +#if defined(USE_NGTCP2) && defined(OPENSSL_QUIC_API2) + if(ngtcp2_crypto_ossl_init()) + return 0; +#endif + + return 1; +} + +void Curl_quic_ver(char *p, size_t len) +{ +#if defined(USE_NGTCP2) && defined(USE_NGHTTP3) + Curl_ngtcp2_ver(p, len); +#elif defined(USE_QUICHE) + Curl_quiche_ver(p, len); +#endif +} + +CURLcode vquic_ctx_init(struct Curl_easy *data, + struct cf_quic_ctx *qctx) +{ + Curl_bufq_init2(&qctx->sendbuf, NW_CHUNK_SIZE, NW_SEND_CHUNKS, + BUFQ_OPT_SOFT_LIMIT); +#if defined(__linux__) && defined(UDP_SEGMENT) && defined(HAVE_SENDMSG) + qctx->no_gso = FALSE; +#else + qctx->no_gso = TRUE; +#endif +#ifdef DEBUGBUILD + { + const char *p = getenv("CURL_DBG_QUIC_WBLOCK"); + if(p) { + curl_off_t l; + if(!curlx_str_number(&p, &l, 100)) + qctx->wblock_percent = (int)l; + } + } +#endif + vquic_ctx_set_time(qctx, Curl_pgrs_now(data)); + + return CURLE_OK; +} + +void vquic_ctx_free(struct cf_quic_ctx *qctx) +{ + Curl_bufq_free(&qctx->sendbuf); +} + +void vquic_ctx_set_time(struct cf_quic_ctx *qctx, + const struct curltime *pnow) +{ + qctx->last_op = *pnow; +} + +void vquic_ctx_update_time(struct cf_quic_ctx *qctx, + const struct curltime *pnow) +{ + qctx->last_op = *pnow; +} + +static CURLcode send_packet_no_gso(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct cf_quic_ctx *qctx, + const uint8_t *pkt, size_t pktlen, + size_t gsolen, size_t *psent); + +static CURLcode do_sendmsg(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct cf_quic_ctx *qctx, + const uint8_t *pkt, size_t pktlen, size_t gsolen, + size_t *psent) +{ + CURLcode result = CURLE_OK; +#ifdef HAVE_SENDMSG + struct iovec msg_iov; + struct msghdr msg = { 0 }; + ssize_t rv; +#if defined(__linux__) && defined(UDP_SEGMENT) + uint8_t msg_ctrl[32]; + struct cmsghdr *cm; +#endif + + *psent = 0; + msg_iov.iov_base = (uint8_t *)CURL_UNCONST(pkt); + msg_iov.iov_len = pktlen; + msg.msg_iov = &msg_iov; + msg.msg_iovlen = 1; + +#if defined(__linux__) && defined(UDP_SEGMENT) + if(pktlen > gsolen) { + /* Only set this, when we need it. macOS, for example, + * does not seem to like a msg_control of length 0. */ + memset(msg_ctrl, 0, sizeof(msg_ctrl)); + msg.msg_control = msg_ctrl; + assert(sizeof(msg_ctrl) >= CMSG_SPACE(sizeof(int))); + msg.msg_controllen = CMSG_SPACE(sizeof(int)); + cm = CMSG_FIRSTHDR(&msg); + cm->cmsg_level = SOL_UDP; + cm->cmsg_type = UDP_SEGMENT; + cm->cmsg_len = CMSG_LEN(sizeof(uint16_t)); + *(uint16_t *)(void *)CMSG_DATA(cm) = gsolen & 0xffff; + } +#endif + + while((rv = sendmsg(qctx->sockfd, &msg, 0)) == -1 && SOCKERRNO == SOCKEINTR) + ; + + if(!curlx_sztouz(rv, psent)) { + int sockerr = SOCKERRNO; + if(SOCK_EAGAIN(sockerr)) + return CURLE_AGAIN; + switch(sockerr) { + case SOCKEMSGSIZE: + /* UDP datagram is too large; caused by PMTUD. Let it be lost. */ + *psent = pktlen; + break; + case EIO: + if(pktlen > gsolen) { + /* GSO failure */ + infof(data, "sendmsg() returned %zd (errno %d); disable GSO", rv, + sockerr); + qctx->no_gso = TRUE; + return send_packet_no_gso(cf, data, qctx, pkt, pktlen, gsolen, psent); + } + FALLTHROUGH(); + default: + failf(data, "sendmsg() returned %zd (errno %d)", rv, sockerr); + result = CURLE_SEND_ERROR; + goto out; + } + } + else if(pktlen != *psent) { + failf(data, "sendmsg() sent only %zu/%zu bytes", *psent, pktlen); + result = CURLE_SEND_ERROR; + goto out; + } +#else + ssize_t rv; + (void)gsolen; + + *psent = 0; + + while((rv = swrite(qctx->sockfd, pkt, pktlen)) == -1 && + SOCKERRNO == SOCKEINTR) + ; + + if(!curlx_sztouz(rv, psent)) { + if(SOCK_EAGAIN(SOCKERRNO)) { + result = CURLE_AGAIN; + goto out; + } + else { + if(SOCKERRNO != SOCKEMSGSIZE) { + failf(data, "send() returned %zd (errno %d)", rv, SOCKERRNO); + result = CURLE_SEND_ERROR; + goto out; + } + /* UDP datagram is too large; caused by PMTUD. Let it be lost. */ + *psent = pktlen; + } + } +#endif + (void)cf; + +out: + return result; +} + +#ifdef CURLVERBOSE +#ifdef HAVE_SENDMSG +#define VQUIC_SEND_METHOD "sendmsg" +#else +#define VQUIC_SEND_METHOD "send" +#endif +#endif + +static CURLcode send_packet_no_gso(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct cf_quic_ctx *qctx, + const uint8_t *pkt, size_t pktlen, + size_t gsolen, size_t *psent) +{ + const uint8_t *p, *end = pkt + pktlen; + size_t sent, len; + CURLcode result = CURLE_OK; + VERBOSE(size_t calls = 0); + + *psent = 0; + + for(p = pkt; p < end; p += gsolen) { + len = CURLMIN(gsolen, (size_t)(end - p)); + result = do_sendmsg(cf, data, qctx, p, len, len, &sent); + if(result) + goto out; + *psent += sent; + VERBOSE(++calls); + } +out: + CURL_TRC_CF(data, cf, + "vquic_%s(len=%zu, gso=%zu, calls=%zu) -> %d, sent=%zu", + VQUIC_SEND_METHOD, pktlen, gsolen, calls, (int)result, *psent); + return result; +} + +/* Split QUIC payload by datagram (gso) boundaries when sending over a + * non-UDP lower filter (for example CONNECT-UDP proxy tunnel). */ +static CURLcode send_packet_no_gso_cf(struct Curl_cfilter *cf, + struct Curl_easy *data, + const uint8_t *pkt, size_t pktlen, + size_t gsolen, size_t *psent) +{ + const uint8_t *p, *end = pkt + pktlen; + size_t sent, len; + CURLcode result = CURLE_OK; + VERBOSE(size_t calls = 0); + + *psent = 0; + + /* Send one datagram-sized chunk per call into the lower filter. */ + for(p = pkt; p < end; p += len) { + len = CURLMIN(gsolen, (size_t)(end - p)); + result = Curl_conn_cf_send(cf->next, data, p, len, FALSE, &sent); + /* Report forward progress even if we return CURLE_AGAIN later. */ + VERBOSE(++calls); + /* Preserve lower-filter errors (including CURLE_AGAIN). */ + if(result) + goto out; + + if(sent != len) { + /* We can only send the complete datagram, not parts. */ + result = CURLE_SEND_ERROR; + goto out; + } + *psent += sent; + } + +out: + CURL_TRC_CF(data, cf, + "vquic_cf_send(len=%zu, gso=%zu, calls=%zu) -> %d, sent=%zu", + pktlen, gsolen, calls, (int)result, *psent); + return result; +} + +static CURLcode vquic_send_packets(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct cf_quic_ctx *qctx, + const uint8_t *pkt, size_t pktlen, + size_t gsolen, size_t *psent) +{ + CURLcode result; +#ifdef DEBUGBUILD + /* simulate network blocking/partial writes */ + if(qctx->wblock_percent > 0) { + unsigned char c; + *psent = 0; + Curl_rand(data, &c, 1); + if(c >= ((100 - qctx->wblock_percent) * 256 / 100)) { + CURL_TRC_CF(data, cf, "vquic_flush() simulate EWOULDBLOCK"); + return CURLE_AGAIN; + } + } +#endif + if(qctx->no_gso && pktlen > gsolen) { + result = send_packet_no_gso(cf, data, qctx, pkt, pktlen, gsolen, psent); + } + else { + result = do_sendmsg(cf, data, qctx, pkt, pktlen, gsolen, psent); + CURL_TRC_CF(data, cf, + "vquic_%s(len=%zu, gso=%zu, calls=1) -> %d, sent=%zu", + VQUIC_SEND_METHOD, pktlen, gsolen, (int)result, *psent); + } + if(!result) + qctx->last_io = qctx->last_op; + return result; +} + +CURLcode vquic_flush(struct Curl_cfilter *cf, struct Curl_easy *data, + struct cf_quic_ctx *qctx) +{ + const unsigned char *buf; + size_t blen, sent; + CURLcode result; + size_t gsolen; + + while(Curl_bufq_peek(&qctx->sendbuf, &buf, &blen)) { + gsolen = qctx->gsolen; + if(qctx->split_len) { + gsolen = qctx->split_gsolen; + if(blen > qctx->split_len) + blen = qctx->split_len; + } + + if(qctx->sockfd != CURL_SOCKET_BAD) { + /* Direct UDP socket (via happy eyeballs) */ + result = vquic_send_packets(cf, data, qctx, buf, blen, gsolen, &sent); + } + else { + /* Tunneled QUIC (CONNECT-UDP through proxy) */ + if(gsolen && (blen > gsolen)) { + /* Send one datagram at a time to preserve packet boundaries. */ + result = send_packet_no_gso_cf(cf, data, buf, blen, gsolen, &sent); + } + else { + /* No GSO aggregate to split, regular lower-filter send is enough. */ + result = Curl_conn_cf_send(cf->next, data, buf, blen, FALSE, &sent); + } + } + + if(result) { + if(result == CURLE_AGAIN) { + Curl_bufq_skip(&qctx->sendbuf, sent); + if(qctx->split_len) + qctx->split_len -= sent; + } + return result; + } + Curl_bufq_skip(&qctx->sendbuf, sent); + if(qctx->split_len) + qctx->split_len -= sent; + } + return CURLE_OK; +} + +CURLcode vquic_send(struct Curl_cfilter *cf, struct Curl_easy *data, + struct cf_quic_ctx *qctx, size_t gsolen) +{ + qctx->gsolen = gsolen; + return vquic_flush(cf, data, qctx); +} + +CURLcode vquic_send_tail_split(struct Curl_cfilter *cf, struct Curl_easy *data, + struct cf_quic_ctx *qctx, size_t gsolen, + size_t tail_len, size_t tail_gsolen) +{ + DEBUGASSERT(Curl_bufq_len(&qctx->sendbuf) > tail_len); + qctx->split_len = Curl_bufq_len(&qctx->sendbuf) - tail_len; + qctx->split_gsolen = gsolen; + qctx->gsolen = tail_gsolen; + CURL_TRC_CF(data, cf, "vquic_send_tail_split: [%zu gso=%zu][%zu gso=%zu]", + qctx->split_len, qctx->split_gsolen, tail_len, qctx->gsolen); + return vquic_flush(cf, data, qctx); +} + +#if defined(HAVE_SENDMMSG) || defined(HAVE_SENDMSG) +static size_t vquic_msghdr_get_udp_gro(struct msghdr *msg) +{ + int gso_size = 0; +#if defined(__linux__) && defined(UDP_GRO) + struct cmsghdr *cmsg; + + /* Workaround musl CMSG_NXTHDR issue */ +#if defined(__clang__) && !defined(__GLIBC__) +#pragma clang diagnostic push +#pragma clang diagnostic ignored "-Wsign-compare" +#pragma clang diagnostic ignored "-Wcast-align" +#endif + for(cmsg = CMSG_FIRSTHDR(msg); cmsg; cmsg = CMSG_NXTHDR(msg, cmsg)) { +#if defined(__clang__) && !defined(__GLIBC__) +#pragma clang diagnostic pop +#endif + if(cmsg->cmsg_level == SOL_UDP && cmsg->cmsg_type == UDP_GRO) { + memcpy(&gso_size, CMSG_DATA(cmsg), sizeof(gso_size)); + + break; + } + } +#endif + (void)msg; + + return (size_t)gso_size; +} +#endif + +#ifdef HAVE_SENDMMSG +static CURLcode recvmmsg_packets(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct cf_quic_ctx *qctx, + size_t max_pkts, + vquic_recv_pkts_cb *recv_cb, void *userp) +{ +#if defined(__linux__) && defined(UDP_GRO) +#define MMSG_NUM 16 +#define UDP_GRO_CNT_MAX 64 +#else +#define MMSG_NUM 64 +#define UDP_GRO_CNT_MAX 1 +#endif +#define MSG_BUF_SIZE (UDP_GRO_CNT_MAX * 1500) + struct iovec msg_iov[MMSG_NUM]; + struct mmsghdr mmsg[MMSG_NUM]; + uint8_t msg_ctrl[MMSG_NUM * CMSG_SPACE(sizeof(int))]; + struct sockaddr_storage remote_addr[MMSG_NUM]; + size_t total_nread = 0, pkts = 0; +#ifdef CURLVERBOSE + size_t calls = 0; +#endif + int mcount, i, n; + char errstr[STRERROR_LEN]; + CURLcode result = CURLE_OK; + size_t gso_size; + char *sockbuf = NULL; + uint8_t (*bufs)[MSG_BUF_SIZE] = NULL; + + DEBUGASSERT(max_pkts > 0); + result = Curl_multi_xfer_sockbuf_borrow(data, MMSG_NUM * MSG_BUF_SIZE, + &sockbuf); + if(result) + goto out; + bufs = (uint8_t (*)[MSG_BUF_SIZE])sockbuf; + + total_nread = 0; + while(pkts < max_pkts) { + n = (int)CURLMIN(CURLMIN(MMSG_NUM, IOV_MAX), max_pkts); + memset(&mmsg, 0, sizeof(mmsg)); + for(i = 0; i < n; ++i) { + msg_iov[i].iov_base = bufs[i]; + msg_iov[i].iov_len = sizeof(bufs[i]); + mmsg[i].msg_hdr.msg_iov = &msg_iov[i]; + mmsg[i].msg_hdr.msg_iovlen = 1; + mmsg[i].msg_hdr.msg_name = &remote_addr[i]; + mmsg[i].msg_hdr.msg_namelen = sizeof(remote_addr[i]); + mmsg[i].msg_hdr.msg_control = &msg_ctrl[i * CMSG_SPACE(sizeof(int))]; + mmsg[i].msg_hdr.msg_controllen = CMSG_SPACE(sizeof(int)); + } + + while((mcount = recvmmsg(qctx->sockfd, mmsg, n, 0, NULL)) == -1 && + (SOCKERRNO == SOCKEINTR || SOCKERRNO == SOCKEMSGSIZE)) + ; + if(mcount == -1) { + if(SOCK_EAGAIN(SOCKERRNO)) { + CURL_TRC_CF(data, cf, "ingress, recvmmsg -> EAGAIN"); + goto out; + } + if(!cf->connected && SOCKERRNO == SOCKECONNREFUSED) { + struct ip_quadruple ip; + if(!Curl_cf_socket_peek(cf->next, data, NULL, NULL, &ip)) + failf(data, "QUIC: connection to %s port %u refused", + ip.remote_ip, ip.remote_port); + result = CURLE_COULDNT_CONNECT; + goto out; + } + curlx_strerror(SOCKERRNO, errstr, sizeof(errstr)); + failf(data, "QUIC: recvmmsg() unexpectedly returned %d (errno=%d; %s)", + mcount, SOCKERRNO, errstr); + result = CURLE_RECV_ERROR; + goto out; + } + + VERBOSE(++calls); + for(i = 0; i < mcount; ++i) { + /* A zero-length UDP packet is no QUIC packet. Ignore. */ + if(!mmsg[i].msg_len) { + ++pkts; + continue; + } + total_nread += mmsg[i].msg_len; + + gso_size = vquic_msghdr_get_udp_gro(&mmsg[i].msg_hdr); + if(gso_size == 0) + gso_size = mmsg[i].msg_len; + + result = recv_cb(bufs[i], mmsg[i].msg_len, gso_size, + mmsg[i].msg_hdr.msg_name, + mmsg[i].msg_hdr.msg_namelen, 0, userp); + if(result) + goto out; + pkts += (mmsg[i].msg_len + gso_size - 1) / gso_size; + } + } + +out: + if(total_nread || result) + CURL_TRC_CF(data, cf, + "vquic_recvmmsg(len=%zu, packets=%zu, calls=%zu) -> %d", + total_nread, pkts, calls, (int)result); + Curl_multi_xfer_sockbuf_release(data, sockbuf); + return result; +} + +#elif defined(HAVE_SENDMSG) +static CURLcode recvmsg_packets(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct cf_quic_ctx *qctx, + size_t max_pkts, + vquic_recv_pkts_cb *recv_cb, void *userp) +{ + struct iovec msg_iov; + struct msghdr msg; + uint8_t buf[64 * 1024]; + struct sockaddr_storage remote_addr; + size_t total_nread, pkts, calls; + ssize_t rc; + size_t nread; + char errstr[STRERROR_LEN]; + CURLcode result = CURLE_OK; + uint8_t msg_ctrl[CMSG_SPACE(sizeof(int))]; + size_t gso_size; + + DEBUGASSERT(max_pkts > 0); + for(pkts = 0, total_nread = 0, calls = 0; pkts < max_pkts;) { + /* fully initialize this on each call to `recvmsg()`. There seem to + * operating systems out there that mess with `msg_iov.iov_len`. */ + memset(&msg, 0, sizeof(msg)); + msg_iov.iov_base = buf; + msg_iov.iov_len = sizeof(buf); + msg.msg_iov = &msg_iov; + msg.msg_iovlen = 1; + msg.msg_control = msg_ctrl; + msg.msg_name = &remote_addr; + msg.msg_namelen = sizeof(remote_addr); + msg.msg_controllen = sizeof(msg_ctrl); + + while((rc = recvmsg(qctx->sockfd, &msg, 0)) == -1 && + (SOCKERRNO == SOCKEINTR || SOCKERRNO == SOCKEMSGSIZE)) + ; + if(!curlx_sztouz(rc, &nread)) { + if(SOCK_EAGAIN(SOCKERRNO)) { + goto out; + } + if(!cf->connected && SOCKERRNO == SOCKECONNREFUSED) { + struct ip_quadruple ip; + if(!Curl_cf_socket_peek(cf->next, data, NULL, NULL, &ip)) + failf(data, "QUIC: connection to %s port %u refused", + ip.remote_ip, ip.remote_port); + result = CURLE_COULDNT_CONNECT; + goto out; + } + curlx_strerror(SOCKERRNO, errstr, sizeof(errstr)); + failf(data, "QUIC: recvmsg() unexpectedly returned %zd (errno=%d; %s)", + rc, SOCKERRNO, errstr); + result = CURLE_RECV_ERROR; + goto out; + } + + total_nread += nread; + ++calls; + + /* A 0-length UDP packet is no QUIC packet */ + if(!nread) { + ++pkts; + continue; + } + + gso_size = vquic_msghdr_get_udp_gro(&msg); + if(gso_size == 0) + gso_size = nread; + + result = recv_cb(buf, nread, gso_size, + msg.msg_name, msg.msg_namelen, 0, userp); + if(result) + goto out; + pkts += (nread + gso_size - 1) / gso_size; + } + +out: + if(total_nread || result) + CURL_TRC_CF(data, cf, + "vquic_recvmsg(len=%zu, packets=%zu, calls=%zu) -> %d", + total_nread, pkts, calls, (int)result); + return result; +} + +#else /* HAVE_SENDMMSG || HAVE_SENDMSG */ +static CURLcode recvfrom_packets(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct cf_quic_ctx *qctx, + size_t max_pkts, + vquic_recv_pkts_cb *recv_cb, void *userp) +{ + uint8_t buf[64 * 1024]; + int bufsize = (int)sizeof(buf); + struct sockaddr_storage remote_addr; + socklen_t remote_addrlen = sizeof(remote_addr); + size_t total_nread, pkts, calls = 0, nread; + ssize_t rv; + char errstr[STRERROR_LEN]; + CURLcode result = CURLE_OK; + + DEBUGASSERT(max_pkts > 0); + for(pkts = 0, total_nread = 0; pkts < max_pkts;) { + while((rv = recvfrom(qctx->sockfd, (char *)buf, bufsize, 0, + (struct sockaddr *)&remote_addr, + &remote_addrlen)) == -1 && + (SOCKERRNO == SOCKEINTR || SOCKERRNO == SOCKEMSGSIZE)) + ; + if(!curlx_sztouz(rv, &nread)) { + if(SOCK_EAGAIN(SOCKERRNO)) { + CURL_TRC_CF(data, cf, "ingress, recvfrom -> EAGAIN"); + goto out; + } + if(!cf->connected && SOCKERRNO == SOCKECONNREFUSED) { + struct ip_quadruple ip; + if(!Curl_cf_socket_peek(cf->next, data, NULL, NULL, &ip)) + failf(data, "QUIC: connection to %s port %u refused", + ip.remote_ip, ip.remote_port); + result = CURLE_COULDNT_CONNECT; + goto out; + } + curlx_strerror(SOCKERRNO, errstr, sizeof(errstr)); + failf(data, "QUIC: recvfrom() unexpectedly returned %zd (errno=%d; %s)", + rv, SOCKERRNO, errstr); + result = CURLE_RECV_ERROR; + goto out; + } + + ++pkts; + ++calls; + + /* A 0-length UDP packet is no QUIC packet */ + if(!nread) + continue; + + total_nread += nread; + result = recv_cb(buf, nread, nread, &remote_addr, remote_addrlen, + 0, userp); + if(result) + goto out; + } + +out: + if(total_nread || result) + CURL_TRC_CF(data, cf, + "vquic_recvfrom(len=%zu, packets=%zu, calls=%zu) -> %d", + total_nread, pkts, calls, (int)result); + return result; +} +#endif /* !HAVE_SENDMMSG && !HAVE_SENDMSG */ + +CURLcode vquic_recv_packets(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct cf_quic_ctx *qctx, + size_t max_pkts, + vquic_recv_pkts_cb *recv_cb, void *userp) +{ + CURLcode result; +#ifdef HAVE_SENDMMSG + result = recvmmsg_packets(cf, data, qctx, max_pkts, recv_cb, userp); +#elif defined(HAVE_SENDMSG) + result = recvmsg_packets(cf, data, qctx, max_pkts, recv_cb, userp); +#else + result = recvfrom_packets(cf, data, qctx, max_pkts, recv_cb, userp); +#endif + if(!result) { + if(!qctx->got_first_byte) { + qctx->got_first_byte = TRUE; + qctx->first_byte_at = qctx->last_op; + } + qctx->last_io = qctx->last_op; + } + return result; +} + +/* + * If the QLOGDIR environment variable is set, open and return a file + * descriptor to write the log to. + * + * This function returns error if something failed outside of failing to + * create the file. Open file success is deemed by seeing if the returned fd + * is != -1. + */ +CURLcode Curl_qlogdir(struct Curl_easy *data, + unsigned char *scid, + size_t scidlen, + int *qlogfdp) +{ + char *qlog_dir = curl_getenv("QLOGDIR"); + *qlogfdp = -1; + if(qlog_dir) { + struct dynbuf fname; + CURLcode result; + unsigned int i; + curlx_dyn_init(&fname, DYN_QLOG_NAME); + result = curlx_dyn_add(&fname, qlog_dir); + if(!result) + result = curlx_dyn_add(&fname, "/"); + for(i = 0; (i < scidlen) && !result; i++) { + char hex[3]; + curl_msnprintf(hex, 3, "%02x", scid[i]); + result = curlx_dyn_add(&fname, hex); + } + if(!result) + result = curlx_dyn_add(&fname, ".sqlog"); + + if(!result) { + int qlogfd = curlx_open(curlx_dyn_ptr(&fname), + O_WRONLY | O_CREAT | CURL_O_BINARY, + data->set.new_file_perms +#ifdef _WIN32 + & (_S_IREAD | _S_IWRITE) +#endif + ); + if(qlogfd != -1) + *qlogfdp = qlogfd; + } + curlx_dyn_free(&fname); + curlx_free(qlog_dir); + if(result) + return result; + } + + return CURLE_OK; +} + +CURLcode Curl_cf_quic_insert_after(struct Curl_cfilter *cf_at, + struct Curl_peer *origin, + struct Curl_peer *peer) +{ +#if defined(USE_NGTCP2) && defined(USE_NGHTTP3) + return Curl_cf_ngtcp2_insert_after(cf_at, origin, peer); +#elif defined(USE_QUICHE) + return Curl_cf_quiche_insert_after(cf_at, origin, peer); +#else + (void)cf_at; + (void)origin; + (void)peer; + return CURLE_NOT_BUILT_IN; +#endif +} + +CURLcode Curl_cf_quic_create(struct Curl_cfilter **pcf, + struct Curl_easy *data, + struct Curl_peer *origin, + struct Curl_peer *peer, + uint8_t transport_peer, + struct connectdata *conn, + struct Curl_sockaddr_ex *addr, + struct Curl_peer *tunnel_peer, + uint8_t tunnel_transport) +{ + (void)transport_peer; + (void)tunnel_transport; + (void)tunnel_peer; + DEBUGASSERT(transport_peer == TRNSPRT_QUIC); +#if defined(USE_NGTCP2) && defined(USE_NGHTTP3) + return Curl_cf_ngtcp2_create(pcf, data, origin, peer, conn, addr); +#elif defined(USE_QUICHE) + return Curl_cf_quiche_create(pcf, data, origin, peer, conn, addr); +#else + *pcf = NULL; + (void)data; + (void)origin; + (void)peer; + (void)conn; + (void)addr; + (void)tunnel_peer; + (void)tunnel_transport; + return CURLE_NOT_BUILT_IN; +#endif +} + +#if !defined(CURL_DISABLE_PROXY) && defined(USE_PROXY_HTTP3) + +CURLcode Curl_cf_h3_proxy_insert_after(struct Curl_cfilter *cf_at, + struct Curl_easy *data, + struct Curl_peer *origin, + struct Curl_peer *peer, + struct Curl_peer *tunnel_peer, + uint8_t tunnel_transport) +{ +#if defined(USE_NGTCP2) && defined(USE_NGHTTP3) + return Curl_cf_ngtcp2_proxy_insert_after(cf_at, data, origin, peer, + tunnel_peer, tunnel_transport); +#else + (void)cf_at; + (void)data; + (void)origin; + (void)peer; + (void)tunnel_peer; + (void)tunnel_transport; + return CURLE_NOT_BUILT_IN; +#endif +} + +CURLcode Curl_cf_h3_proxy_create(struct Curl_cfilter **pcf, + struct Curl_easy *data, + struct Curl_peer *origin, + struct Curl_peer *peer, + uint8_t transport_peer, + struct connectdata *conn, + struct Curl_sockaddr_ex *addr, + struct Curl_peer *tunnel_peer, + uint8_t tunnel_transport) +{ + DEBUGASSERT(transport_peer == TRNSPRT_QUIC); +#if defined(USE_NGTCP2) && defined(USE_NGHTTP3) + return Curl_cf_ngtcp2_proxy_create(pcf, data, origin, peer, transport_peer, + conn, addr, + tunnel_peer, tunnel_transport); +#else + *pcf = NULL; + (void)data; + (void)conn; + (void)addr; + (void)peer; + (void)transport_peer; + (void)tunnel_peer; + (void)tunnel_transport; + return CURLE_NOT_BUILT_IN; +#endif +} + +#endif /* !CURL_DISABLE_PROXY && USE_PROXY_HTTP3 */ + +CURLcode Curl_conn_may_http3(struct Curl_easy *data, + const struct connectdata *conn, + unsigned char transport) +{ + if(transport == TRNSPRT_UNIX) { + failf(data, "HTTP/3 cannot be used over UNIX domain sockets"); + return CURLE_QUIC_CONNECT_ERROR; + } + if(!(data->state.origin->scheme->flags & PROTOPT_SSL)) { + failf(data, "HTTP/3 requested for non-HTTPS URL"); + return CURLE_URL_MALFORMAT; + } +#ifndef CURL_DISABLE_PROXY + if(conn->socks_proxy.peer) { + failf(data, "HTTP/3 is not supported over a SOCKS proxy"); + return CURLE_URL_MALFORMAT; + } +#else + (void)conn; +#endif + + return CURLE_OK; +} + +#ifdef CURLVERBOSE +const char *vquic_h3_err_str(uint64_t error_code) +{ + if(error_code <= UINT_MAX) { + switch((unsigned int)error_code) { + case CURL_H3_ERR_NO_ERROR: + return "NO_ERROR"; + case CURL_H3_ERR_GENERAL_PROTOCOL_ERROR: + return "GENERAL_PROTOCOL_ERROR"; + case CURL_H3_ERR_INTERNAL_ERROR: + return "INTERNAL_ERROR"; + case CURL_H3_ERR_STREAM_CREATION_ERROR: + return "STREAM_CREATION_ERROR"; + case CURL_H3_ERR_CLOSED_CRITICAL_STREAM: + return "CLOSED_CRITICAL_STREAM"; + case CURL_H3_ERR_FRAME_UNEXPECTED: + return "FRAME_UNEXPECTED"; + case CURL_H3_ERR_FRAME_ERROR: + return "FRAME_ERROR"; + case CURL_H3_ERR_EXCESSIVE_LOAD: + return "EXCESSIVE_LOAD"; + case CURL_H3_ERR_ID_ERROR: + return "ID_ERROR"; + case CURL_H3_ERR_SETTINGS_ERROR: + return "SETTINGS_ERROR"; + case CURL_H3_ERR_MISSING_SETTINGS: + return "MISSING_SETTINGS"; + case CURL_H3_ERR_REQUEST_REJECTED: + return "REQUEST_REJECTED"; + case CURL_H3_ERR_REQUEST_CANCELLED: + return "REQUEST_CANCELLED"; + case CURL_H3_ERR_REQUEST_INCOMPLETE: + return "REQUEST_INCOMPLETE"; + case CURL_H3_ERR_MESSAGE_ERROR: + return "MESSAGE_ERROR"; + case CURL_H3_ERR_CONNECT_ERROR: + return "CONNECT_ERROR"; + case CURL_H3_ERR_VERSION_FALLBACK: + return "VERSION_FALLBACK"; + default: + break; + } + } + /* RFC 9114 ch. 8.1 + 9, reserved future error codes that are NO_ERROR */ + if((error_code >= 0x21) && !((error_code - 0x21) % 0x1f)) + return "NO_ERROR"; + return "unknown"; +} +#endif /* CURLVERBOSE */ + +#if defined(USE_NGTCP2) || defined(USE_NGHTTP3) + +static void *vquic_ngtcp2_malloc(size_t size, void *user_data) +{ + (void)user_data; + return Curl_cmalloc(size); +} + +static void vquic_ngtcp2_free(void *ptr, void *user_data) +{ + (void)user_data; + Curl_cfree(ptr); +} + +static void *vquic_ngtcp2_calloc(size_t nmemb, size_t size, void *user_data) +{ + (void)user_data; + return Curl_ccalloc(nmemb, size); +} + +static void *vquic_ngtcp2_realloc(void *ptr, size_t size, void *user_data) +{ + (void)user_data; + return Curl_crealloc(ptr, size); +} + +#ifdef USE_NGTCP2 +static struct ngtcp2_mem vquic_ngtcp2_mem = { + NULL, + vquic_ngtcp2_malloc, + vquic_ngtcp2_free, + vquic_ngtcp2_calloc, + vquic_ngtcp2_realloc +}; +struct ngtcp2_mem *Curl_ngtcp2_mem(void) +{ + return &vquic_ngtcp2_mem; +} +#endif + +#ifdef USE_NGHTTP3 +static struct nghttp3_mem vquic_nghttp3_mem = { + NULL, + vquic_ngtcp2_malloc, + vquic_ngtcp2_free, + vquic_ngtcp2_calloc, + vquic_ngtcp2_realloc +}; +struct nghttp3_mem *Curl_nghttp3_mem(void) +{ + return &vquic_nghttp3_mem; +} +#endif + +#endif /* USE_NGTCP2 || USE_NGHTTP3 */ + +#else /* CURL_DISABLE_HTTP || !USE_HTTP3 */ + +CURLcode Curl_conn_may_http3(struct Curl_easy *data, + const struct connectdata *conn, + unsigned char transport) +{ + (void)data; + (void)conn; + (void)transport; + DEBUGF(infof(data, "QUIC is not supported in this build")); + return CURLE_NOT_BUILT_IN; +} + +#endif /* !CURL_DISABLE_HTTP && USE_HTTP3 */ diff --git a/3rdparty/curl-8.21.0/lib/vquic/vquic.h b/3rdparty/curl-8.21.0/lib/vquic/vquic.h new file mode 100644 index 0000000000..5211a9b33a --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vquic/vquic.h @@ -0,0 +1,89 @@ +#ifndef HEADER_CURL_VQUIC_QUIC_H +#define HEADER_CURL_VQUIC_QUIC_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_HTTP) && defined(USE_HTTP3) +struct Curl_cfilter; +struct Curl_easy; +struct connectdata; +struct Curl_addrinfo; + +void Curl_quic_ver(char *p, size_t len); +int Curl_vquic_init(void); + +CURLcode Curl_qlogdir(struct Curl_easy *data, + unsigned char *scid, + size_t scidlen, + int *qlogfdp); + +CURLcode Curl_cf_quic_insert_after(struct Curl_cfilter *cf_at, + struct Curl_peer *origin, + struct Curl_peer *peer); + +CURLcode Curl_cf_quic_create(struct Curl_cfilter **pcf, + struct Curl_easy *data, + struct Curl_peer *origin, + struct Curl_peer *peer, + uint8_t transport_peer, + struct connectdata *conn, + struct Curl_sockaddr_ex *addr, + struct Curl_peer *tunnel_peer, + uint8_t tunnel_transport); + +extern struct Curl_cftype Curl_cft_http3; + +#if !defined(CURL_DISABLE_PROXY) && defined(USE_PROXY_HTTP3) + +CURLcode Curl_cf_h3_proxy_insert_after(struct Curl_cfilter *cf_at, + struct Curl_easy *data, + struct Curl_peer *origin, + struct Curl_peer *peer, + struct Curl_peer *tunnel_peer, + uint8_t tunnel_transport); + +CURLcode Curl_cf_h3_proxy_create(struct Curl_cfilter **pcf, + struct Curl_easy *data, + struct Curl_peer *origin, + struct Curl_peer *peer, + uint8_t transport_peer, + struct connectdata *conn, + struct Curl_sockaddr_ex *addr, + struct Curl_peer *tunnel_peer, + uint8_t tunnel_transport); + +extern struct Curl_cftype Curl_cft_h3_proxy; + +#endif /* !CURL_DISABLE_PROXY && USE_PROXY_HTTP3 */ + +#else +#define Curl_vquic_init() 1 +#endif /* !CURL_DISABLE_HTTP && USE_HTTP3 */ + +CURLcode Curl_conn_may_http3(struct Curl_easy *data, + const struct connectdata *conn, + unsigned char transport); + +#endif /* HEADER_CURL_VQUIC_QUIC_H */ diff --git a/3rdparty/curl-8.21.0/lib/vquic/vquic_int.h b/3rdparty/curl-8.21.0/lib/vquic/vquic_int.h new file mode 100644 index 0000000000..db5183d431 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vquic/vquic_int.h @@ -0,0 +1,126 @@ +#ifndef HEADER_CURL_VQUIC_QUIC_INT_H +#define HEADER_CURL_VQUIC_QUIC_INT_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_HTTP3 + +#include "bufq.h" + +#define MAX_UDP_PAYLOAD_SIZE 1452 + +/* definitions from RFC 9114, ch 8.1 */ +typedef enum { + CURL_H3_ERR_NO_ERROR = 0x0100, + CURL_H3_ERR_GENERAL_PROTOCOL_ERROR = 0x0101, + CURL_H3_ERR_INTERNAL_ERROR = 0x0102, + CURL_H3_ERR_STREAM_CREATION_ERROR = 0x0103, + CURL_H3_ERR_CLOSED_CRITICAL_STREAM = 0x0104, + CURL_H3_ERR_FRAME_UNEXPECTED = 0x0105, + CURL_H3_ERR_FRAME_ERROR = 0x0106, + CURL_H3_ERR_EXCESSIVE_LOAD = 0x0107, + CURL_H3_ERR_ID_ERROR = 0x0108, + CURL_H3_ERR_SETTINGS_ERROR = 0x0109, + CURL_H3_ERR_MISSING_SETTINGS = 0x010a, + CURL_H3_ERR_REQUEST_REJECTED = 0x010b, + CURL_H3_ERR_REQUEST_CANCELLED = 0x010c, + CURL_H3_ERR_REQUEST_INCOMPLETE = 0x010d, + CURL_H3_ERR_MESSAGE_ERROR = 0x010e, + CURL_H3_ERR_CONNECT_ERROR = 0x010f, + CURL_H3_ERR_VERSION_FALLBACK = 0x0110, +} vquic_h3_error; + +#ifdef CURLVERBOSE +const char *vquic_h3_err_str(uint64_t error_code); +#else +#define vquic_h3_err_str(x) "" +#endif /* CURLVERBOSE */ + +struct cf_quic_ctx { + curl_socket_t sockfd; /* connected UDP socket */ + struct sockaddr_storage local_addr; /* address socket is bound to */ + socklen_t local_addrlen; /* length of local address */ + + struct bufq sendbuf; /* buffer for sending one or more packets */ + struct curltime first_byte_at; /* when first byte was recvd */ + struct curltime last_op; /* last (attempted) send/recv operation */ + struct curltime last_io; /* last successful socket IO */ + size_t gsolen; /* length of individual packets in send buf */ + size_t split_len; /* if != 0, buffer length after which GSO differs */ + size_t split_gsolen; /* length of individual packets after split_len */ +#ifdef DEBUGBUILD + int wblock_percent; /* percent of writes doing EAGAIN */ +#endif + BIT(got_first_byte); /* if first byte was received */ + BIT(no_gso); /* do not use gso on sending */ +}; + +#define H3_STREAM_CTX(ctx, data) \ + ((data) ? Curl_uint32_hash_get(&(ctx)->streams, (data)->mid) : NULL) + +CURLcode vquic_ctx_init(struct Curl_easy *data, + struct cf_quic_ctx *qctx); +void vquic_ctx_free(struct cf_quic_ctx *qctx); + +void vquic_ctx_set_time(struct cf_quic_ctx *qctx, + const struct curltime *pnow); + +void vquic_ctx_update_time(struct cf_quic_ctx *qctx, + const struct curltime *pnow); + +CURLcode vquic_send(struct Curl_cfilter *cf, struct Curl_easy *data, + struct cf_quic_ctx *qctx, size_t gsolen); + +CURLcode vquic_send_tail_split(struct Curl_cfilter *cf, struct Curl_easy *data, + struct cf_quic_ctx *qctx, size_t gsolen, + size_t tail_len, size_t tail_gsolen); + +CURLcode vquic_flush(struct Curl_cfilter *cf, struct Curl_easy *data, + struct cf_quic_ctx *qctx); + +typedef CURLcode vquic_recv_pkts_cb(const unsigned char *buf, size_t buflen, + size_t gso_size, + struct sockaddr_storage *remote_addr, + socklen_t remote_addrlen, int ecn, + void *userp); + +CURLcode vquic_recv_packets(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct cf_quic_ctx *qctx, + size_t max_pkts, + vquic_recv_pkts_cb *recv_cb, void *userp); + +#ifdef USE_NGTCP2 +struct ngtcp2_mem; +struct ngtcp2_mem *Curl_ngtcp2_mem(void); +#endif +#ifdef USE_NGHTTP3 +struct nghttp3_mem; +struct nghttp3_mem *Curl_nghttp3_mem(void); +#endif + +#endif /* !USE_HTTP3 */ + +#endif /* HEADER_CURL_VQUIC_QUIC_INT_H */ diff --git a/3rdparty/curl-8.21.0/lib/vssh/libssh.c b/3rdparty/curl-8.21.0/lib/vssh/libssh.c new file mode 100644 index 0000000000..e4071caa46 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vssh/libssh.c @@ -0,0 +1,3206 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Red Hat, Inc. + * + * Authors: Nikos Mavrogiannopoulos, Tomas Mraz, Stanislav Zidek, + * Robert Kolcun, Andreas Schneider + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_LIBSSH + +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_ARPA_INET_H +#include +#endif +#ifdef HAVE_NETDB_H +#include +#endif +#ifdef __VMS +#include +#include +#endif + +#include "urldata.h" +#include "sendf.h" +#include "curl_trc.h" +#include "hostip.h" +#include "progress.h" +#include "transfer.h" +#include "vssh/ssh.h" +#include "url.h" +#include "cfilters.h" +#include "connect.h" +#include "parsedate.h" /* for the week day and month names */ +#include "curlx/strparse.h" +#include "multiif.h" +#include "select.h" +#include "vssh/vssh.h" +#include "curlx/base64.h" /* for curlx_base64_encode() */ + +#ifdef HAVE_UNISTD_H +#include +#endif +#ifdef HAVE_FCNTL_H +#include +#endif + +/* A recent macro provided by libssh. Or make our own. */ +#ifndef SSH_STRING_FREE_CHAR +#define SSH_STRING_FREE_CHAR(x) \ + do { \ + if(x) { \ + ssh_string_free_char(x); \ + x = NULL; \ + } \ + } while(0) +#endif + +/* These stat values may not be the same as the user's S_IFMT / S_IFLNK */ +#ifndef SSH_S_IFMT +#define SSH_S_IFMT 00170000 +#endif +#ifndef SSH_S_IFLNK +#define SSH_S_IFLNK 0120000 +#endif + +static CURLcode sftp_error_to_CURLE(int err) +{ + switch(err) { + case SSH_FX_OK: + return CURLE_OK; + + case SSH_FX_NO_SUCH_FILE: + case SSH_FX_NO_SUCH_PATH: + return CURLE_REMOTE_FILE_NOT_FOUND; + + case SSH_FX_PERMISSION_DENIED: + case SSH_FX_WRITE_PROTECT: + return CURLE_REMOTE_ACCESS_DENIED; + + case SSH_FX_FILE_ALREADY_EXISTS: + return CURLE_REMOTE_FILE_EXISTS; + + default: + break; + } + + return CURLE_SSH; +} + +/* Multiple options: + * 1. data->set.str[STRING_SSH_HOST_PUBLIC_KEY_SHA256] is set with a SHA256 + * hash. + * 2. data->set.str[STRING_SSH_HOST_PUBLIC_KEY_MD5] is set with an MD5 + * hash (90s style auth, not sure we should have it here) + * 3. data->set.ssh_keyfunc callback is set. Then we do trust on first + * use. We even save on knownhosts if CURLKHSTAT_FINE_ADD_TO_FILE + * is returned by it. + * 4. none of the above. We only accept if it is present on known hosts. + * + * Returns SSH_OK or SSH_ERROR. + */ +static int myssh_is_known(struct Curl_easy *data, struct ssh_conn *sshc) +{ + int rc; + ssh_key pubkey; + unsigned char *hash_sha256 = NULL; + size_t hlen_sha256; + unsigned char *hash_md5 = NULL; + size_t hlen_md5; + char *found_base64 = NULL; + char *known_base64 = NULL; + int vstate; + enum curl_khmatch keymatch; + struct curl_khkey foundkey; + struct curl_khkey *knownkeyp = NULL; + curl_sshkeycallback func = data->set.ssh_keyfunc; + struct ssh_knownhosts_entry *knownhostsentry = NULL; + struct curl_khkey knownkey; + + rc = ssh_get_server_publickey(sshc->ssh_session, &pubkey); + + if(rc != SSH_OK) + return rc; + + if(data->set.str[STRING_SSH_HOST_PUBLIC_KEY_SHA256]) { + const char *pubkey_sha256 = + data->set.str[STRING_SSH_HOST_PUBLIC_KEY_SHA256]; + char *fingerprint_b64 = NULL; + size_t fingerprint_b64_len; + size_t pub_pos = 0; + size_t b64_pos = 0; + + rc = ssh_get_publickey_hash(pubkey, SSH_PUBLICKEY_HASH_SHA256, + &hash_sha256, &hlen_sha256); + if(rc != SSH_OK || hlen_sha256 != 32) { + failf(data, "Denied establishing ssh session: " + "SHA256 fingerprint not available"); + goto cleanup; + } + + if(curlx_base64_encode((const uint8_t *)hash_sha256, 32, &fingerprint_b64, + &fingerprint_b64_len) != CURLE_OK) { + rc = SSH_ERROR; + goto cleanup; + } + + infof(data, "SSH SHA256 fingerprint: %s", fingerprint_b64); + + /* Find the position of any = padding characters in the public key */ + while((pubkey_sha256[pub_pos] != '=') && pubkey_sha256[pub_pos]) { + pub_pos++; + } + + /* Find the position of any = padding characters in the base64 coded + * hostkey fingerprint */ + while((fingerprint_b64[b64_pos] != '=') && fingerprint_b64[b64_pos]) { + b64_pos++; + } + + /* Before we authenticate we check the hostkey's SHA256 fingerprint + * against a known fingerprint, if available. + */ + if((pub_pos != b64_pos) || + strncmp(fingerprint_b64, pubkey_sha256, pub_pos)) { + failf(data, + "Denied establishing ssh session: mismatch SHA256 fingerprint. " + "Remote %s is not equal to %s", fingerprint_b64, pubkey_sha256); + curlx_free(fingerprint_b64); + rc = SSH_ERROR; + goto cleanup; + } + + curlx_free(fingerprint_b64); + + rc = SSH_OK; + goto cleanup; + } + + if(data->set.str[STRING_SSH_HOST_PUBLIC_KEY_MD5]) { + const char *pubkey_md5 = data->set.str[STRING_SSH_HOST_PUBLIC_KEY_MD5]; + char md5buffer[33]; + int i; + + rc = ssh_get_publickey_hash(pubkey, SSH_PUBLICKEY_HASH_MD5, + &hash_md5, &hlen_md5); + if(rc != SSH_OK || hlen_md5 != 16) { + failf(data, + "Denied establishing ssh session: MD5 fingerprint not available"); + goto cleanup; + } + + for(i = 0; i < 16; i++) + curl_msnprintf(&md5buffer[i * 2], 3, "%02x", hash_md5[i]); + + infof(data, "SSH MD5 fingerprint: %s", md5buffer); + + if(!curl_strequal(md5buffer, pubkey_md5)) { + failf(data, + "Denied establishing ssh session: mismatch MD5 fingerprint. " + "Remote %s is not equal to %s", md5buffer, pubkey_md5); + rc = SSH_ERROR; + goto cleanup; + } + + rc = SSH_OK; + goto cleanup; + } + + if(data->set.str[STRING_SSH_KNOWNHOSTS]) { + + /* Get the known_key from the known hosts file */ + vstate = ssh_session_get_known_hosts_entry(sshc->ssh_session, + &knownhostsentry); + + /* Case an entry was found in a known hosts file */ + if(knownhostsentry) { + if(knownhostsentry->publickey) { + rc = ssh_pki_export_pubkey_base64(knownhostsentry->publickey, + &known_base64); + if(rc != SSH_OK) { + goto cleanup; + } + knownkey.key = known_base64; + knownkey.len = strlen(known_base64); + + switch(ssh_key_type(knownhostsentry->publickey)) { + case SSH_KEYTYPE_RSA: + knownkey.keytype = CURLKHTYPE_RSA; + break; + case SSH_KEYTYPE_RSA1: + knownkey.keytype = CURLKHTYPE_RSA1; + break; + case SSH_KEYTYPE_ECDSA: + case SSH_KEYTYPE_ECDSA_P256: + case SSH_KEYTYPE_ECDSA_P384: + case SSH_KEYTYPE_ECDSA_P521: + knownkey.keytype = CURLKHTYPE_ECDSA; + break; + case SSH_KEYTYPE_ED25519: + knownkey.keytype = CURLKHTYPE_ED25519; + break; + case SSH_KEYTYPE_DSS: + knownkey.keytype = CURLKHTYPE_DSS; + break; + default: + rc = SSH_ERROR; + goto cleanup; + } + knownkeyp = &knownkey; + } + } + + switch(vstate) { + case SSH_KNOWN_HOSTS_OK: + keymatch = CURLKHMATCH_OK; + break; + case SSH_KNOWN_HOSTS_OTHER: + keymatch = CURLKHMATCH_MISMATCH; + break; + case SSH_KNOWN_HOSTS_NOT_FOUND: + case SSH_KNOWN_HOSTS_UNKNOWN: + case SSH_KNOWN_HOSTS_ERROR: + keymatch = CURLKHMATCH_MISSING; + break; + default: + keymatch = CURLKHMATCH_MISMATCH; + break; + } + + if(func) { /* use callback to determine action */ + rc = ssh_pki_export_pubkey_base64(pubkey, &found_base64); + if(rc != SSH_OK) + goto cleanup; + + foundkey.key = found_base64; + foundkey.len = strlen(found_base64); + + switch(ssh_key_type(pubkey)) { + case SSH_KEYTYPE_RSA: + foundkey.keytype = CURLKHTYPE_RSA; + break; + case SSH_KEYTYPE_RSA1: + foundkey.keytype = CURLKHTYPE_RSA1; + break; + case SSH_KEYTYPE_ECDSA: + case SSH_KEYTYPE_ECDSA_P256: + case SSH_KEYTYPE_ECDSA_P384: + case SSH_KEYTYPE_ECDSA_P521: + foundkey.keytype = CURLKHTYPE_ECDSA; + break; + case SSH_KEYTYPE_ED25519: + foundkey.keytype = CURLKHTYPE_ED25519; + break; + case SSH_KEYTYPE_DSS: + foundkey.keytype = CURLKHTYPE_DSS; + break; + default: + rc = SSH_ERROR; + goto cleanup; + } + + Curl_set_in_callback(data, TRUE); + rc = func(data, knownkeyp, /* from the knownhosts file */ + &foundkey, /* from the remote host */ + keymatch, data->set.ssh_keyfunc_userp); + Curl_set_in_callback(data, FALSE); + + switch(rc) { + case CURLKHSTAT_FINE_ADD_TO_FILE: + rc = ssh_session_update_known_hosts(sshc->ssh_session); + if(rc != SSH_OK) { + goto cleanup; + } + break; + case CURLKHSTAT_FINE: + break; + default: /* REJECT/DEFER */ + rc = SSH_ERROR; + goto cleanup; + } + } + else { + if(keymatch != CURLKHMATCH_OK) { + rc = SSH_ERROR; + goto cleanup; + } + } + } + rc = SSH_OK; + +cleanup: + if(found_base64) { + /* !checksrc! disable BANNEDFUNC 1 */ + free(found_base64); /* allocated by libssh, deallocate with system free */ + } + if(known_base64) { + /* !checksrc! disable BANNEDFUNC 1 */ + free(known_base64); /* allocated by libssh, deallocate with system free */ + } + if(hash_sha256) + ssh_clean_pubkey_hash(&hash_sha256); + if(hash_md5) + ssh_clean_pubkey_hash(&hash_md5); + ssh_key_free(pubkey); + if(knownhostsentry) { + ssh_knownhosts_entry_free(knownhostsentry); + } + return rc; +} + +static int myssh_to_ERROR(struct Curl_easy *data, + struct ssh_conn *sshc, + CURLcode result) +{ + myssh_to(data, sshc, SSH_SESSION_DISCONNECT); + sshc->actualcode = result; + return SSH_ERROR; +} + +static int myssh_to_SFTP_CLOSE(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + myssh_to(data, sshc, SSH_SFTP_CLOSE); + sshc->actualcode = sftp_error_to_CURLE(sftp_get_error(sshc->sftp_session)); + return SSH_ERROR; +} + +static int myssh_to_PASSWD_AUTH(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + if(sshc->auth_methods & SSH_AUTH_METHOD_PASSWORD) { + myssh_to(data, sshc, SSH_AUTH_PASS_INIT); + return SSH_OK; + } + return myssh_to_ERROR(data, sshc, CURLE_LOGIN_DENIED); +} + +static int myssh_to_KEY_AUTH(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + if(sshc->auth_methods & SSH_AUTH_METHOD_INTERACTIVE) { + myssh_to(data, sshc, SSH_AUTH_KEY_INIT); + return SSH_OK; + } + return myssh_to_PASSWD_AUTH(data, sshc); +} + +static int myssh_to_GSSAPI_AUTH(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + if(sshc->auth_methods & SSH_AUTH_METHOD_GSSAPI_MIC) { + myssh_to(data, sshc, SSH_AUTH_GSSAPI); + return SSH_OK; + } + return myssh_to_KEY_AUTH(data, sshc); +} + +static int myssh_in_SFTP_READDIR_INIT(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp) +{ + if(!sshp) + return myssh_to_ERROR(data, sshc, CURLE_FAILED_INIT); + Curl_pgrsSetDownloadSize(data, -1); + if(data->req.no_body) { + myssh_to(data, sshc, SSH_STOP); + return SSH_NO_ERROR; + } + + /* + * This is a directory that we are trying to get, so produce a directory + * listing + */ + sshc->sftp_dir = sftp_opendir(sshc->sftp_session, + sshp->path); + if(!sshc->sftp_dir) { + failf(data, "Could not open directory for reading: %s", + ssh_get_error(sshc->ssh_session)); + return myssh_to_SFTP_CLOSE(data, sshc); + } + myssh_to(data, sshc, SSH_SFTP_READDIR); + return SSH_NO_ERROR; +} + +static int myssh_in_SFTP_READDIR(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp) +{ + CURLcode result = CURLE_OK; + + if(!sshp) + return myssh_to_ERROR(data, sshc, CURLE_FAILED_INIT); + curlx_dyn_reset(&sshc->readdir_buf); + if(sshc->readdir_attrs) + sftp_attributes_free(sshc->readdir_attrs); + + sshc->readdir_attrs = sftp_readdir(sshc->sftp_session, sshc->sftp_dir); + if(sshc->readdir_attrs) { + sshc->readdir_filename = sshc->readdir_attrs->name; + sshc->readdir_longentry = sshc->readdir_attrs->longname; + sshc->readdir_len = strlen(sshc->readdir_filename); + + if(data->set.list_only) { + char *tmpLine; + + tmpLine = curl_maprintf("%s\n", sshc->readdir_filename); + if(!tmpLine) { + myssh_to(data, sshc, SSH_SFTP_CLOSE); + sshc->actualcode = CURLE_OUT_OF_MEMORY; + return SSH_ERROR; + } + result = Curl_client_write(data, CLIENTWRITE_BODY, + tmpLine, sshc->readdir_len + 1); + curlx_free(tmpLine); + + if(result) { + myssh_to(data, sshc, SSH_STOP); + sshc->actualcode = result; + return SSH_NO_ERROR; + } + } + else { + if(curlx_dyn_add(&sshc->readdir_buf, sshc->readdir_longentry)) { + sshc->actualcode = CURLE_OUT_OF_MEMORY; + myssh_to(data, sshc, SSH_STOP); + return SSH_ERROR; + } + + if((sshc->readdir_attrs->flags & SSH_FILEXFER_ATTR_PERMISSIONS) && + ((sshc->readdir_attrs->permissions & SSH_S_IFMT) == + SSH_S_IFLNK)) { + sshc->readdir_linkPath = curl_maprintf("%s%s", sshp->path, + sshc->readdir_filename); + + if(!sshc->readdir_linkPath) { + myssh_to(data, sshc, SSH_SFTP_CLOSE); + sshc->actualcode = CURLE_OUT_OF_MEMORY; + return SSH_ERROR; + } + + myssh_to(data, sshc, SSH_SFTP_READDIR_LINK); + return SSH_NO_ERROR; + } + myssh_to(data, sshc, SSH_SFTP_READDIR_BOTTOM); + return SSH_NO_ERROR; + } + } + else if(sftp_dir_eof(sshc->sftp_dir)) { + myssh_to(data, sshc, SSH_SFTP_READDIR_DONE); + } + else { + failf(data, "Could not open remote directory for reading: %s", + ssh_get_error(sshc->ssh_session)); + return myssh_to_SFTP_CLOSE(data, sshc); + } + return SSH_NO_ERROR; +} + +static int myssh_in_SFTP_READDIR_LINK(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + if(sshc->readdir_link_attrs) + sftp_attributes_free(sshc->readdir_link_attrs); + + sshc->readdir_link_attrs = sftp_lstat(sshc->sftp_session, + sshc->readdir_linkPath); + if(!sshc->readdir_link_attrs) { + failf(data, "Could not read symlink for reading: %s", + ssh_get_error(sshc->ssh_session)); + return myssh_to_SFTP_CLOSE(data, sshc); + } + + if(!sshc->readdir_link_attrs->name) { + sshc->readdir_tmp = sftp_readlink(sshc->sftp_session, + sshc->readdir_linkPath); + if(!sshc->readdir_tmp) + sshc->readdir_len = 0; + else + sshc->readdir_len = strlen(sshc->readdir_tmp); + sshc->readdir_longentry = NULL; + sshc->readdir_filename = sshc->readdir_tmp; + } + else { + sshc->readdir_len = strlen(sshc->readdir_link_attrs->name); + sshc->readdir_filename = sshc->readdir_link_attrs->name; + sshc->readdir_longentry = sshc->readdir_link_attrs->longname; + } + + curlx_safefree(sshc->readdir_linkPath); + + if(curlx_dyn_addf(&sshc->readdir_buf, " -> %s", sshc->readdir_filename)) { + /* Not using: + * return myssh_to_SFTP_CLOSE(data, sshc); + * + * as that assumes an sftp related error while + * assigning sshc->actualcode whereas the current + * error is curlx_dyn_addf() related. + */ + myssh_to(data, sshc, SSH_SFTP_CLOSE); + sshc->actualcode = CURLE_OUT_OF_MEMORY; + return SSH_ERROR; + } + + sftp_attributes_free(sshc->readdir_link_attrs); + sshc->readdir_link_attrs = NULL; + sshc->readdir_filename = NULL; + sshc->readdir_longentry = NULL; + + myssh_to(data, sshc, SSH_SFTP_READDIR_BOTTOM); + return SSH_NO_ERROR; +} + +static int myssh_in_SFTP_READDIR_BOTTOM(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + CURLcode result; + + if(curlx_dyn_addn(&sshc->readdir_buf, "\n", 1)) + result = CURLE_OUT_OF_MEMORY; + else + result = Curl_client_write(data, CLIENTWRITE_BODY, + curlx_dyn_ptr(&sshc->readdir_buf), + curlx_dyn_len(&sshc->readdir_buf)); + + ssh_string_free_char(sshc->readdir_tmp); + sshc->readdir_tmp = NULL; + + if(result) { + myssh_to(data, sshc, SSH_STOP); + sshc->actualcode = result; + } + else + myssh_to(data, sshc, SSH_SFTP_READDIR); + return SSH_NO_ERROR; +} + +static int myssh_in_SFTP_READDIR_DONE(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + sftp_closedir(sshc->sftp_dir); + sshc->sftp_dir = NULL; + + /* no data to transfer */ + Curl_xfer_setup_nop(data); + myssh_to(data, sshc, SSH_STOP); + return SSH_NO_ERROR; +} + +static void myssh_quote_error(struct Curl_easy *data, struct ssh_conn *sshc, + const char *cmd) +{ + if(cmd) + failf(data, "%s command failed: %s", cmd, + ssh_get_error(sshc->ssh_session)); + curlx_safefree(sshc->quote_path1); + curlx_safefree(sshc->quote_path2); + myssh_to(data, sshc, SSH_SFTP_CLOSE); + sshc->nextstate = SSH_NO_STATE; + sshc->actualcode = CURLE_QUOTE_ERROR; +} + +static int myssh_in_SFTP_QUOTE_STATVFS(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + sftp_statvfs_t statvfs; + + statvfs = sftp_statvfs(sshc->sftp_session, sshc->quote_path1); + if(!statvfs && !sshc->acceptfail) { + myssh_quote_error(data, sshc, "statvfs"); + return SSH_OK; + } + else if(statvfs) { +#ifdef _MSC_VER +#define CURL_LIBSSH_VFS_SIZE_MASK "I64u" +#elif defined(__MINGW32__) && (__MINGW64_VERSION_MAJOR <= 6) +#define CURL_LIBSSH_VFS_SIZE_MASK "llu" +#else +#define CURL_LIBSSH_VFS_SIZE_MASK PRIu64 +#endif + CURLcode result = CURLE_OK; + char *tmp = curl_maprintf("statvfs:\n" + "f_bsize: %" CURL_LIBSSH_VFS_SIZE_MASK "\n" + "f_frsize: %" CURL_LIBSSH_VFS_SIZE_MASK "\n" + "f_blocks: %" CURL_LIBSSH_VFS_SIZE_MASK "\n" + "f_bfree: %" CURL_LIBSSH_VFS_SIZE_MASK "\n" + "f_bavail: %" CURL_LIBSSH_VFS_SIZE_MASK "\n" + "f_files: %" CURL_LIBSSH_VFS_SIZE_MASK "\n" + "f_ffree: %" CURL_LIBSSH_VFS_SIZE_MASK "\n" + "f_favail: %" CURL_LIBSSH_VFS_SIZE_MASK "\n" + "f_fsid: %" CURL_LIBSSH_VFS_SIZE_MASK "\n" + "f_flag: %" CURL_LIBSSH_VFS_SIZE_MASK "\n" + "f_namemax: %" CURL_LIBSSH_VFS_SIZE_MASK "\n", + statvfs->f_bsize, statvfs->f_frsize, + statvfs->f_blocks, statvfs->f_bfree, + statvfs->f_bavail, statvfs->f_files, + statvfs->f_ffree, statvfs->f_favail, + statvfs->f_fsid, statvfs->f_flag, + statvfs->f_namemax); + sftp_statvfs_free(statvfs); + + if(!tmp) + result = CURLE_OUT_OF_MEMORY; + + if(!result) { + result = Curl_client_write(data, CLIENTWRITE_HEADER, tmp, strlen(tmp)); + curlx_free(tmp); + } + if(result) { + myssh_to(data, sshc, SSH_SFTP_CLOSE); + sshc->nextstate = SSH_NO_STATE; + sshc->actualcode = result; + } + } + myssh_to(data, sshc, SSH_SFTP_NEXT_QUOTE); + return SSH_OK; +} + +static int myssh_auth_interactive(struct connectdata *conn, + struct ssh_conn *sshc) +{ + int rc; + int nprompts; + +restart: + switch(sshc->kbd_state) { + case 0: + rc = ssh_userauth_kbdint(sshc->ssh_session, NULL, NULL); + if(rc == SSH_AUTH_AGAIN) + return SSH_AGAIN; + + if(rc != SSH_AUTH_INFO) + return SSH_ERROR; + + nprompts = ssh_userauth_kbdint_getnprompts(sshc->ssh_session); + if(nprompts != 1) + return SSH_ERROR; + + rc = ssh_userauth_kbdint_setanswer(sshc->ssh_session, 0, + Curl_creds_passwd(conn->creds)); + if(rc < 0) + return SSH_ERROR; + + FALLTHROUGH(); + case 1: + sshc->kbd_state = 1; + + rc = ssh_userauth_kbdint(sshc->ssh_session, NULL, NULL); + if(rc == SSH_AUTH_AGAIN) + return SSH_AGAIN; + else if(rc == SSH_AUTH_SUCCESS) + rc = SSH_OK; + else if(rc == SSH_AUTH_INFO) { + nprompts = ssh_userauth_kbdint_getnprompts(sshc->ssh_session); + if(nprompts) + return SSH_ERROR; + + sshc->kbd_state = 2; + goto restart; + } + else + rc = SSH_ERROR; + break; + case 2: + sshc->kbd_state = 2; + + rc = ssh_userauth_kbdint(sshc->ssh_session, NULL, NULL); + if(rc == SSH_AUTH_AGAIN) + return SSH_AGAIN; + else if(rc == SSH_AUTH_SUCCESS) + rc = SSH_OK; + else + rc = SSH_ERROR; + + break; + default: + return SSH_ERROR; + } + + sshc->kbd_state = 0; + return rc; +} + +static void myssh_state_init(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + sshc->secondCreateDirs = 0; + sshc->nextstate = SSH_NO_STATE; + sshc->actualcode = CURLE_OK; + +#if 0 + ssh_set_log_level(SSH_LOG_PROTOCOL); +#endif + + /* Set libssh to non-blocking, since everything internally is + non-blocking */ + ssh_set_blocking(sshc->ssh_session, 0); + + myssh_to(data, sshc, SSH_S_STARTUP); +} + +static void myssh_block2waitfor(struct connectdata *conn, + struct ssh_conn *sshc, + bool block) +{ + (void)conn; + if(block) { + int dir = ssh_get_poll_flags(sshc->ssh_session); + /* translate the libssh define bits into our own bit defines */ + sshc->waitfor = + ((dir & SSH_READ_PENDING) ? REQ_IO_RECV : 0) | + ((dir & SSH_WRITE_PENDING) ? REQ_IO_SEND : 0); + } + else + sshc->waitfor = 0; +} + +static int myssh_in_S_STARTUP(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + struct connectdata *conn = data->conn; + int rc = ssh_connect(sshc->ssh_session); + + myssh_block2waitfor(conn, sshc, (rc == SSH_AGAIN)); + if(rc == SSH_AGAIN) { + CURL_TRC_SSH(data, "connect -> EAGAIN"); + } + else if(rc != SSH_OK) { + failf(data, "Failure establishing ssh session"); + rc = myssh_to_ERROR(data, sshc, CURLE_FAILED_INIT); + } + else + myssh_to(data, sshc, SSH_HOSTKEY); + + return rc; +} + +static int myssh_in_AUTHLIST(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + int rc; + sshc->authed = FALSE; + + rc = ssh_userauth_none(sshc->ssh_session, NULL); + if(rc == SSH_AUTH_AGAIN) + return SSH_AGAIN; + + if(rc == SSH_AUTH_SUCCESS) { + sshc->authed = TRUE; + infof(data, "Authenticated with none"); + myssh_to(data, sshc, SSH_AUTH_DONE); + return rc; + } + else if(rc == SSH_AUTH_ERROR) { + rc = myssh_to_ERROR(data, sshc, CURLE_LOGIN_DENIED); + return rc; + } + + sshc->auth_methods = + (unsigned int)ssh_userauth_list(sshc->ssh_session, NULL); + if(sshc->auth_methods) + infof(data, "SSH authentication methods available: %s%s%s%s", + sshc->auth_methods & SSH_AUTH_METHOD_PUBLICKEY ? + "public key, " : "", + sshc->auth_methods & SSH_AUTH_METHOD_GSSAPI_MIC ? + "GSSAPI, " : "", + sshc->auth_methods & SSH_AUTH_METHOD_INTERACTIVE ? + "keyboard-interactive, " : "", + sshc->auth_methods & SSH_AUTH_METHOD_PASSWORD ? + "password" : ""); + /* For public key auth we need either the private key or + CURLSSH_AUTH_AGENT. */ + if((sshc->auth_methods & SSH_AUTH_METHOD_PUBLICKEY) && + (data->set.str[STRING_SSH_PRIVATE_KEY] || + (data->set.ssh_auth_types & CURLSSH_AUTH_AGENT))) { + myssh_to(data, sshc, SSH_AUTH_PKEY_INIT); + infof(data, "Authentication using SSH public key file"); + } + else if(sshc->auth_methods & SSH_AUTH_METHOD_GSSAPI_MIC) { + myssh_to(data, sshc, SSH_AUTH_GSSAPI); + } + else if(sshc->auth_methods & SSH_AUTH_METHOD_INTERACTIVE) { + myssh_to(data, sshc, SSH_AUTH_KEY_INIT); + } + else if(sshc->auth_methods & SSH_AUTH_METHOD_PASSWORD) { + myssh_to(data, sshc, SSH_AUTH_PASS_INIT); + } + else { /* unsupported authentication method */ + rc = myssh_to_ERROR(data, sshc, CURLE_LOGIN_DENIED); + } + return rc; +} + +static int myssh_in_AUTH_PKEY_INIT(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + int rc; + if(!(data->set.ssh_auth_types & CURLSSH_AUTH_PUBLICKEY)) { + rc = myssh_to_GSSAPI_AUTH(data, sshc); + return rc; + } + + /* Two choices, (1) private key was given on CMD, + * (2) use the "default" keys. */ + if(data->set.str[STRING_SSH_PRIVATE_KEY]) { + if(sshc->pubkey && !data->set.ssl.primary.key_passwd) { + rc = ssh_userauth_try_publickey(sshc->ssh_session, NULL, sshc->pubkey); + if(rc == SSH_AUTH_AGAIN) + return SSH_AGAIN; + + if(rc != SSH_OK) { + rc = myssh_to_GSSAPI_AUTH(data, sshc); + return rc; + } + } + + rc = ssh_pki_import_privkey_file(data-> + set.str[STRING_SSH_PRIVATE_KEY], + data->set.ssl.primary.key_passwd, NULL, + NULL, &sshc->privkey); + if(rc != SSH_OK) { + failf(data, "Could not load private key file %s", + data->set.str[STRING_SSH_PRIVATE_KEY]); + rc = myssh_to_ERROR(data, sshc, CURLE_LOGIN_DENIED); + return rc; + } + + myssh_to(data, sshc, SSH_AUTH_PKEY); + } + else { + rc = ssh_userauth_publickey_auto(sshc->ssh_session, NULL, + data->set.ssl.primary.key_passwd); + if(rc == SSH_AUTH_AGAIN) + return SSH_AGAIN; + + if(rc == SSH_AUTH_SUCCESS) { + rc = SSH_OK; + sshc->authed = TRUE; + infof(data, "Completed public key authentication"); + myssh_to(data, sshc, SSH_AUTH_DONE); + return rc; + } + + rc = myssh_to_GSSAPI_AUTH(data, sshc); + } + return rc; +} + +static int myssh_in_AUTH_PKEY(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + int rc = ssh_userauth_publickey(sshc->ssh_session, NULL, sshc->privkey); + if(rc == SSH_AUTH_AGAIN) + return SSH_AGAIN; + else if(rc == SSH_AUTH_SUCCESS) { + sshc->authed = TRUE; + infof(data, "Completed public key authentication"); + myssh_to(data, sshc, SSH_AUTH_DONE); + return SSH_OK; + } + else { + infof(data, "Failed public key authentication (rc: %d)", rc); + return myssh_to_GSSAPI_AUTH(data, sshc); + } +} + +static int myssh_in_AUTH_GSSAPI(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + int rc; + if(!(data->set.ssh_auth_types & CURLSSH_AUTH_GSSAPI)) + return myssh_to_KEY_AUTH(data, sshc); + + rc = ssh_userauth_gssapi(sshc->ssh_session); + if(rc == SSH_AUTH_AGAIN) + return SSH_AGAIN; + + if(rc == SSH_AUTH_SUCCESS) { + sshc->authed = TRUE; + infof(data, "Completed gssapi authentication"); + myssh_to(data, sshc, SSH_AUTH_DONE); + return SSH_OK; + } + + return myssh_to_KEY_AUTH(data, sshc); +} + +static int myssh_in_AUTH_KEY_INIT(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + if(data->set.ssh_auth_types & CURLSSH_AUTH_KEYBOARD) { + myssh_to(data, sshc, SSH_AUTH_KEY); + return SSH_NO_ERROR; + } + return myssh_to_PASSWD_AUTH(data, sshc); +} + +static int myssh_in_AUTH_KEY(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + /* keyboard-interactive authentication */ + int rc = myssh_auth_interactive(data->conn, sshc); + if(rc == SSH_AGAIN) + return rc; + else if(rc == SSH_OK) { + sshc->authed = TRUE; + infof(data, "completed keyboard interactive authentication"); + myssh_to(data, sshc, SSH_AUTH_DONE); + return SSH_NO_ERROR; + } + else + return myssh_to_PASSWD_AUTH(data, sshc); +} + +static int myssh_in_AUTH_PASS_INIT(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + if(!(data->set.ssh_auth_types & CURLSSH_AUTH_PASSWORD)) + return myssh_to_ERROR(data, sshc, CURLE_LOGIN_DENIED); + myssh_to(data, sshc, SSH_AUTH_PASS); + return SSH_NO_ERROR; +} + +static int myssh_in_AUTH_PASS(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + int rc = ssh_userauth_password(sshc->ssh_session, NULL, + Curl_creds_passwd(data->conn->creds)); + if(rc == SSH_AUTH_AGAIN) + return SSH_AGAIN; + else if(rc == SSH_AUTH_SUCCESS) { + sshc->authed = TRUE; + infof(data, "Completed password authentication"); + myssh_to(data, sshc, SSH_AUTH_DONE); + return SSH_NO_ERROR; + } + return myssh_to_ERROR(data, sshc, CURLE_LOGIN_DENIED); +} + +static int myssh_in_AUTH_DONE(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + struct connectdata *conn = data->conn; + if(!sshc->authed) { + failf(data, "Authentication failure"); + return myssh_to_ERROR(data, sshc, CURLE_LOGIN_DENIED); + } + + /* At this point we have an authenticated ssh session. */ + infof(data, "Authentication complete"); + Curl_pgrsTime(data, TIMER_APPCONNECT); /* SSH is connected */ + conn->recv_idx = FIRSTSOCKET; + conn->send_idx = -1; + + if(conn->scheme->protocol == CURLPROTO_SFTP) { + myssh_to(data, sshc, SSH_SFTP_INIT); + return SSH_NO_ERROR; + } + infof(data, "SSH CONNECT phase done"); + myssh_to(data, sshc, SSH_STOP); + return SSH_NO_ERROR; +} + +static int myssh_in_UPLOAD_INIT(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp) +{ + int flags; + int rc = 0; + + if(!sshp) + return myssh_to_ERROR(data, sshc, CURLE_FAILED_INIT); + + if(data->state.resume_from) { + sftp_attributes attrs; + + if(data->state.resume_from < 0) { + attrs = sftp_stat(sshc->sftp_session, sshp->path); + if(attrs) { + curl_off_t size = attrs->size; + sftp_attributes_free(attrs); + if(size < 0) { + failf(data, "Bad file size (%" FMT_OFF_T ")", size); + rc = myssh_to_ERROR(data, sshc, CURLE_BAD_DOWNLOAD_RESUME); + return rc; + } + data->state.resume_from = size; + } + else { + data->state.resume_from = 0; + } + } + } + + if(data->set.remote_append) { + /* True append mode: create if nonexisting */ + flags = O_WRONLY | O_CREAT | O_APPEND; + } + else if(data->state.resume_from > 0) { + /* + * Resume MUST NOT use O_APPEND. Many SFTP servers/impls force all + * writes to EOF when O_APPEND is set, ignoring a prior seek(). + * Open write-only and seek to the resume offset instead. + */ + flags = O_WRONLY; + } + else + /* Clear file before writing (normal behavior) */ + flags = O_WRONLY | O_CREAT | O_TRUNC; + + if(sshc->sftp_file) + sftp_close(sshc->sftp_file); + sshc->sftp_file = + sftp_open(sshc->sftp_session, sshp->path, + flags, (mode_t)data->set.new_file_perms); + if(!sshc->sftp_file) { + int err = sftp_get_error(sshc->sftp_session); + + if((err == SSH_FX_NO_SUCH_FILE || + err == SSH_FX_FAILURE || + err == SSH_FX_NO_SUCH_PATH) && + data->set.ftp_create_missing_dirs && + (strlen(sshp->path) > 1)) { + /* try to create the path remotely */ + rc = 0; + sshc->secondCreateDirs = 1; + myssh_to(data, sshc, SSH_SFTP_CREATE_DIRS_INIT); + return rc; + } + else { + rc = myssh_to_SFTP_CLOSE(data, sshc); + return rc; + } + } + + /* If we have a restart point then we need to seek to the correct + position. Skip if in explicit remote append mode. */ + if(data->state.resume_from > 0 && !data->set.remote_append) { + int seekerr = CURL_SEEKFUNC_OK; + /* Let's read off the proper amount of bytes from the input. */ + if(data->set.seek_func) { + Curl_set_in_callback(data, TRUE); + seekerr = data->set.seek_func(data->set.seek_client, + data->state.resume_from, SEEK_SET); + Curl_set_in_callback(data, FALSE); + } + + if(seekerr != CURL_SEEKFUNC_OK) { + curl_off_t passed = 0; + + if(seekerr != CURL_SEEKFUNC_CANTSEEK) { + failf(data, "Could not seek stream"); + rc = myssh_to_ERROR(data, sshc, CURLE_FTP_COULDNT_USE_REST); + return rc; + } + /* seekerr == CURL_SEEKFUNC_CANTSEEK (cannot seek to offset) */ + do { + char scratch[4 * 1024]; + size_t readthisamountnow = + (data->state.resume_from - passed > + (curl_off_t)sizeof(scratch)) ? + sizeof(scratch) : curlx_sotouz(data->state.resume_from - passed); + + size_t actuallyread = + data->state.fread_func(scratch, 1, + readthisamountnow, data->state.in); + + passed += actuallyread; + if((actuallyread == 0) || (actuallyread > readthisamountnow)) { + /* this checks for greater-than only to make sure that the + CURL_READFUNC_ABORT return code still aborts */ + failf(data, "Failed to read data"); + rc = myssh_to_ERROR(data, sshc, CURLE_FTP_COULDNT_USE_REST); + return rc; + } + } while(passed < data->state.resume_from); + } + + /* now, decrease the size of the read */ + if(data->state.infilesize > 0) { + if(data->state.resume_from > data->state.infilesize) { + failf(data, "Resume point beyond size"); + return myssh_to_ERROR(data, sshc, CURLE_BAD_FUNCTION_ARGUMENT); + } + data->state.infilesize -= data->state.resume_from; + data->req.size = data->state.infilesize; + Curl_pgrsSetUploadSize(data, data->state.infilesize); + } + + rc = sftp_seek64(sshc->sftp_file, data->state.resume_from); + if(rc) { + rc = myssh_to_SFTP_CLOSE(data, sshc); + return rc; + } + } + if(data->state.infilesize > 0) { + data->req.size = data->state.infilesize; + Curl_pgrsSetUploadSize(data, data->state.infilesize); + } + /* upload data */ + Curl_xfer_setup_send(data, FIRSTSOCKET); + + /* not set by Curl_xfer_setup to preserve io_flags */ + data->conn->recv_idx = FIRSTSOCKET; + + /* since we do not really wait for anything at this point, we want the + state machine to move on as soon as possible so we mark this as dirty */ + Curl_multi_mark_dirty(data); +#if LIBSSH_VERSION_INT > SSH_VERSION_INT(0, 11, 0) + sshc->sftp_send_state = 0; +#endif + myssh_to(data, sshc, SSH_STOP); + return rc; +} + +static int myssh_in_SFTP_DOWNLOAD_INIT(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp) +{ + if(!sshp) + return myssh_to_ERROR(data, sshc, CURLE_FAILED_INIT); + /* Work on getting the specified file */ + if(sshc->sftp_file) + sftp_close(sshc->sftp_file); + + sshc->sftp_file = sftp_open(sshc->sftp_session, sshp->path, + O_RDONLY, (mode_t)data->set.new_file_perms); + if(!sshc->sftp_file) { + failf(data, "Could not open remote file for reading: %s", + ssh_get_error(sshc->ssh_session)); + + return myssh_to_SFTP_CLOSE(data, sshc); + } + sftp_file_set_nonblocking(sshc->sftp_file); + myssh_to(data, sshc, SSH_SFTP_DOWNLOAD_STAT); + return SSH_NO_ERROR; +} + +static int myssh_in_SFTP_DOWNLOAD_STAT(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + curl_off_t size; + int rc = 0; + sftp_attributes attrs = sftp_fstat(sshc->sftp_file); + if(!attrs || + !(attrs->flags & SSH_FILEXFER_ATTR_SIZE) || + (attrs->size == 0)) { + /* + * sftp_fstat did not return an error, so maybe the server + * does not support stat() + * OR the server does not return a file size with a stat() + * OR file size is 0 + */ + data->req.size = -1; + data->req.maxdownload = -1; + Curl_pgrsSetDownloadSize(data, -1); + size = 0; + if(attrs) + sftp_attributes_free(attrs); + } + else { + size = attrs->size; + + sftp_attributes_free(attrs); + + if(size < 0) { + failf(data, "Bad file size (%" FMT_OFF_T ")", size); + return myssh_to_ERROR(data, sshc, CURLE_BAD_DOWNLOAD_RESUME); + } + if(data->state.use_range) { + curl_off_t from; + CURLcode result = Curl_ssh_range(data, data->state.range, size, + &from, &size); + if(result) + return myssh_to_ERROR(data, sshc, result); + + rc = sftp_seek64(sshc->sftp_file, from); + if(rc) + return myssh_to_SFTP_CLOSE(data, sshc); + } + data->req.size = size; + data->req.maxdownload = size; + Curl_pgrsSetDownloadSize(data, size); + } + + /* We can resume if we can seek to the resume position */ + if(data->state.resume_from) { + if(data->state.resume_from < 0) { + /* We are supposed to download the last abs(from) bytes */ + if(size < -data->state.resume_from) { + failf(data, "Offset (%" FMT_OFF_T ") was beyond file size (%" + FMT_OFF_T ")", data->state.resume_from, size); + return myssh_to_ERROR(data, sshc, CURLE_BAD_DOWNLOAD_RESUME); + } + /* download from where? */ + data->state.resume_from += size; + } + else { + if(size < data->state.resume_from) { + failf(data, "Offset (%" FMT_OFF_T + ") was beyond file size (%" FMT_OFF_T ")", + data->state.resume_from, size); + return myssh_to_ERROR(data, sshc, CURLE_BAD_DOWNLOAD_RESUME); + } + } + /* Now store the number of bytes we are expected to download */ + data->req.size = size - data->state.resume_from; + data->req.maxdownload = size - data->state.resume_from; + Curl_pgrsSetDownloadSize(data, size - data->state.resume_from); + + rc = sftp_seek64(sshc->sftp_file, data->state.resume_from); + if(rc) + return myssh_to_SFTP_CLOSE(data, sshc); + } + + /* Setup the actual download */ + if(data->req.size == 0) { + /* no data to transfer */ + Curl_xfer_setup_nop(data); + infof(data, "File already completely downloaded"); + myssh_to(data, sshc, SSH_STOP); + return rc; + } + Curl_xfer_setup_recv(data, FIRSTSOCKET, data->req.size); + + /* not set by Curl_xfer_setup to preserve io_flags */ + data->conn->send_idx = 0; + + sshc->sftp_recv_state = 0; + myssh_to(data, sshc, SSH_STOP); + + return rc; +} + +static int myssh_in_SFTP_CLOSE(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp) +{ + if(!sshp) + return myssh_to_ERROR(data, sshc, CURLE_FAILED_INIT); + if(sshc->sftp_file) { + sftp_close(sshc->sftp_file); + sshc->sftp_file = NULL; + } + curlx_safefree(sshp->path); + + CURL_TRC_SSH(data, "SFTP DONE done"); + + /* Check if nextstate is set and move .nextstate could be POSTQUOTE_INIT + After nextstate is executed, the control should come back to + SSH_SFTP_CLOSE to pass the correct result back */ + if(sshc->nextstate != SSH_NO_STATE && + sshc->nextstate != SSH_SFTP_CLOSE) { + myssh_to(data, sshc, sshc->nextstate); + sshc->nextstate = SSH_SFTP_CLOSE; + } + else { + myssh_to(data, sshc, SSH_STOP); + } + return SSH_NO_ERROR; +} + +static int myssh_in_SFTP_SHUTDOWN(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + /* during times we get here due to a broken transfer and then the + sftp_handle might not have been taken down so make sure that is done + before we proceed */ + ssh_set_blocking(sshc->ssh_session, 0); +#if LIBSSH_VERSION_INT > SSH_VERSION_INT(0, 11, 0) + SFTP_AIO_FREE(sshc->sftp_send_aio); + SFTP_AIO_FREE(sshc->sftp_recv_aio); +#endif + + if(sshc->sftp_file) { + sftp_close(sshc->sftp_file); + sshc->sftp_file = NULL; + } + + if(sshc->sftp_session) { + sftp_free(sshc->sftp_session); + sshc->sftp_session = NULL; + } + + SSH_STRING_FREE_CHAR(sshc->homedir); + + myssh_to(data, sshc, SSH_SESSION_DISCONNECT); + return SSH_NO_ERROR; +} + +static int myssh_in_SFTP_INIT(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + int rc; + ssh_set_blocking(sshc->ssh_session, 1); + + sshc->sftp_session = sftp_new(sshc->ssh_session); + if(!sshc->sftp_session) { + failf(data, "Failure initializing sftp session: %s", + ssh_get_error(sshc->ssh_session)); + return myssh_to_ERROR(data, sshc, CURLE_COULDNT_CONNECT); + } + + rc = sftp_init(sshc->sftp_session); + if(rc != SSH_OK) { + failf(data, "Failure initializing sftp session: %s", + ssh_get_error(sshc->ssh_session)); + return myssh_to_ERROR(data, sshc, sftp_error_to_CURLE(SSH_FX_FAILURE)); + } + myssh_to(data, sshc, SSH_SFTP_REALPATH); + return SSH_NO_ERROR; +} + +static int myssh_in_SFTP_REALPATH(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + /* Get the "home" directory */ + sshc->homedir = sftp_canonicalize_path(sshc->sftp_session, "."); + if(!sshc->homedir) + return myssh_to_ERROR(data, sshc, CURLE_COULDNT_CONNECT); + + curlx_free(data->state.most_recent_ftp_entrypath); + data->state.most_recent_ftp_entrypath = curlx_strdup(sshc->homedir); + if(!data->state.most_recent_ftp_entrypath) + return myssh_to_ERROR(data, sshc, CURLE_OUT_OF_MEMORY); + + /* This is the last step in the SFTP connect phase. Do note that while + we get the homedir here, we get the "workingpath" in the DO action + since the homedir remains the same between request but the + working path does not. */ + CURL_TRC_SSH(data, "CONNECT phase done"); + myssh_to(data, sshc, SSH_STOP); + return SSH_NO_ERROR; +} + +static int myssh_in_SFTP_QUOTE_INIT(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp) +{ + CURLcode result; + + if(!sshp) + return myssh_to_ERROR(data, sshc, CURLE_FAILED_INIT); + + result = Curl_getworkingpath(data, sshc->homedir, &sshp->path); + if(result) { + sshc->actualcode = result; + myssh_to(data, sshc, SSH_STOP); + } + else if(data->set.quote) { + infof(data, "Sending quote commands"); + sshc->quote_item = data->set.quote; + myssh_to(data, sshc, SSH_SFTP_QUOTE); + } + else + myssh_to(data, sshc, SSH_SFTP_GETINFO); + return SSH_NO_ERROR; +} + +static int myssh_in_SFTP_POSTQUOTE_INIT(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + if(data->set.postquote) { + infof(data, "Sending quote commands"); + sshc->quote_item = data->set.postquote; + myssh_to(data, sshc, SSH_SFTP_QUOTE); + } + else { + myssh_to(data, sshc, SSH_STOP); + } + return SSH_NO_ERROR; +} + +static int quote_error(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + failf(data, "Suspicious data after the command line"); + curlx_safefree(sshc->quote_path1); + curlx_safefree(sshc->quote_path2); + myssh_to(data, sshc, SSH_SFTP_CLOSE); + sshc->nextstate = SSH_NO_STATE; + sshc->actualcode = CURLE_QUOTE_ERROR; + return SSH_NO_ERROR; +} + +static int myssh_in_SFTP_QUOTE(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp) +{ + const char *cp; + CURLcode result; + + /* + * Support some of the "FTP" commands + */ + const char *cmd = sshc->quote_item->data; + sshc->acceptfail = FALSE; + + if(!sshp) + return myssh_to_ERROR(data, sshc, CURLE_FAILED_INIT); + + /* if a command starts with an asterisk, which a legal SFTP command never + can, the command is allowed to fail without it causing any + aborts or cancels etc. It causes libcurl to act as if the command + is successful, whatever the server responds. */ + + if(cmd[0] == '*') { + cmd++; + sshc->acceptfail = TRUE; + } + + if(curl_strequal("pwd", cmd)) { + /* output debug output if that is requested */ + char *tmp = curl_maprintf("257 \"%s\" is current directory.\n", + sshp->path); + if(!tmp) { + sshc->actualcode = CURLE_OUT_OF_MEMORY; + myssh_to(data, sshc, SSH_SFTP_CLOSE); + sshc->nextstate = SSH_NO_STATE; + return SSH_NO_ERROR; + } + Curl_debug(data, CURLINFO_HEADER_OUT, "PWD\n", 4); + Curl_debug(data, CURLINFO_HEADER_IN, tmp, strlen(tmp)); + + /* this sends an FTP-like "header" to the header callback so that + the current directory can be read similar to how it is read when + using ordinary FTP. */ + result = Curl_client_write(data, CLIENTWRITE_HEADER, tmp, strlen(tmp)); + curlx_free(tmp); + if(result) { + myssh_to(data, sshc, SSH_SFTP_CLOSE); + sshc->nextstate = SSH_NO_STATE; + sshc->actualcode = result; + } + else + myssh_to(data, sshc, SSH_SFTP_NEXT_QUOTE); + return SSH_NO_ERROR; + } + + /* + * the arguments following the command must be separated from the + * command with a space so we can check for it unconditionally + */ + cp = strchr(cmd, ' '); + if(!cp) { + failf(data, "Syntax error in SFTP command. Supply parameter(s)"); + myssh_to(data, sshc, SSH_SFTP_CLOSE); + sshc->nextstate = SSH_NO_STATE; + sshc->actualcode = CURLE_QUOTE_ERROR; + return SSH_NO_ERROR; + } + + /* + * also, every command takes at least one argument so we get that + * first argument right now + */ + result = Curl_get_pathname(&cp, &sshc->quote_path1, sshc->homedir); + if(result) { + if(result == CURLE_OUT_OF_MEMORY) + failf(data, "Out of memory"); + else + failf(data, "Syntax error: Bad first parameter"); + myssh_to(data, sshc, SSH_SFTP_CLOSE); + sshc->nextstate = SSH_NO_STATE; + sshc->actualcode = result; + return SSH_NO_ERROR; + } + + /* + * SFTP is a binary protocol, so we do not send text commands + * to the server. Instead, we scan for commands used by + * OpenSSH's sftp program and call the appropriate libssh + * functions. + */ + if(!strncmp(cmd, "chgrp ", 6) || + !strncmp(cmd, "chmod ", 6) || + !strncmp(cmd, "chown ", 6) || + !strncmp(cmd, "atime ", 6) || + !strncmp(cmd, "mtime ", 6)) { + /* attribute change */ + + /* sshc->quote_path1 contains the mode to set */ + /* get the destination */ + result = Curl_get_pathname(&cp, &sshc->quote_path2, sshc->homedir); + if(result) { + if(result == CURLE_OUT_OF_MEMORY) + failf(data, "Out of memory"); + else + failf(data, "Syntax error in chgrp/chmod/chown/atime/mtime: " + "Bad second parameter"); + curlx_safefree(sshc->quote_path1); + myssh_to(data, sshc, SSH_SFTP_CLOSE); + sshc->nextstate = SSH_NO_STATE; + sshc->actualcode = result; + return SSH_NO_ERROR; + } + if(*cp) + return quote_error(data, sshc); + sshc->quote_attrs = NULL; + myssh_to(data, sshc, SSH_SFTP_QUOTE_STAT); + return SSH_NO_ERROR; + } + if(!strncmp(cmd, "ln ", 3) || + !strncmp(cmd, "symlink ", 8)) { + /* symbolic linking */ + /* sshc->quote_path1 is the source */ + /* get the destination */ + result = Curl_get_pathname(&cp, &sshc->quote_path2, sshc->homedir); + if(result) { + if(result == CURLE_OUT_OF_MEMORY) + failf(data, "Out of memory"); + else + failf(data, "Syntax error in ln/symlink: Bad second parameter"); + curlx_safefree(sshc->quote_path1); + myssh_to(data, sshc, SSH_SFTP_CLOSE); + sshc->nextstate = SSH_NO_STATE; + sshc->actualcode = result; + return SSH_NO_ERROR; + } + if(*cp) + return quote_error(data, sshc); + myssh_to(data, sshc, SSH_SFTP_QUOTE_SYMLINK); + return SSH_NO_ERROR; + } + else if(!strncmp(cmd, "mkdir ", 6)) { + if(*cp) + return quote_error(data, sshc); + /* create directory */ + myssh_to(data, sshc, SSH_SFTP_QUOTE_MKDIR); + return SSH_NO_ERROR; + } + else if(!strncmp(cmd, "rename ", 7)) { + /* rename file */ + /* first param is the source path */ + /* second param is the dest. path */ + result = Curl_get_pathname(&cp, &sshc->quote_path2, sshc->homedir); + if(result) { + if(result == CURLE_OUT_OF_MEMORY) + failf(data, "Out of memory"); + else + failf(data, "Syntax error in rename: Bad second parameter"); + curlx_safefree(sshc->quote_path1); + myssh_to(data, sshc, SSH_SFTP_CLOSE); + sshc->nextstate = SSH_NO_STATE; + sshc->actualcode = result; + return SSH_NO_ERROR; + } + if(*cp) + return quote_error(data, sshc); + myssh_to(data, sshc, SSH_SFTP_QUOTE_RENAME); + return SSH_NO_ERROR; + } + else if(!strncmp(cmd, "rmdir ", 6)) { + /* delete directory */ + if(*cp) + return quote_error(data, sshc); + myssh_to(data, sshc, SSH_SFTP_QUOTE_RMDIR); + return SSH_NO_ERROR; + } + else if(!strncmp(cmd, "rm ", 3)) { + if(*cp) + return quote_error(data, sshc); + myssh_to(data, sshc, SSH_SFTP_QUOTE_UNLINK); + return SSH_NO_ERROR; + } +#ifdef HAS_STATVFS_SUPPORT + else if(!strncmp(cmd, "statvfs ", 8)) { + if(*cp) + return quote_error(data, sshc); + myssh_to(data, sshc, SSH_SFTP_QUOTE_STATVFS); + return SSH_NO_ERROR; + } +#endif + + failf(data, "Unknown SFTP command"); + curlx_safefree(sshc->quote_path1); + curlx_safefree(sshc->quote_path2); + myssh_to(data, sshc, SSH_SFTP_CLOSE); + sshc->nextstate = SSH_NO_STATE; + sshc->actualcode = CURLE_QUOTE_ERROR; + return SSH_NO_ERROR; +} + +static int myssh_in_SFTP_NEXT_QUOTE(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + curlx_safefree(sshc->quote_path1); + curlx_safefree(sshc->quote_path2); + + sshc->quote_item = sshc->quote_item->next; + + if(sshc->quote_item) { + myssh_to(data, sshc, SSH_SFTP_QUOTE); + } + else { + if(sshc->nextstate != SSH_NO_STATE) { + myssh_to(data, sshc, sshc->nextstate); + sshc->nextstate = SSH_NO_STATE; + } + else { + myssh_to(data, sshc, SSH_SFTP_GETINFO); + } + } + return SSH_NO_ERROR; +} + +static int myssh_in_SFTP_QUOTE_STAT(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + const char *cmd = sshc->quote_item->data; + sshc->acceptfail = FALSE; + + /* if a command starts with an asterisk, which a legal SFTP command never + can, the command is allowed to fail without it causing any + aborts or cancels etc. It causes libcurl to act as if the command + is successful, whatever the server responds. */ + + if(cmd[0] == '*') { + cmd++; + sshc->acceptfail = TRUE; + } + + /* We read the file attributes, store them in sshc->quote_attrs + * and modify them accordingly to command. Then we switch to + * QUOTE_SETSTAT state to write new ones. + */ + + if(sshc->quote_attrs) + sftp_attributes_free(sshc->quote_attrs); + sshc->quote_attrs = sftp_stat(sshc->sftp_session, sshc->quote_path2); + if(!sshc->quote_attrs) { + failf(data, "Attempt to get SFTP stats failed: %d", + sftp_get_error(sshc->sftp_session)); + myssh_quote_error(data, sshc, NULL); + return SSH_NO_ERROR; + } + + /* Now set the new attributes... */ + if(!strncmp(cmd, "chgrp", 5)) { + const char *p = sshc->quote_path1; + curl_off_t gid; + if(curlx_str_number(&p, &gid, UINT_MAX)) { + failf(data, "Syntax error: chgrp gid not a number"); + myssh_quote_error(data, sshc, NULL); + return SSH_NO_ERROR; + } + sshc->quote_attrs->gid = (uint32_t)gid; + sshc->quote_attrs->flags |= SSH_FILEXFER_ATTR_UIDGID; + } + else if(!strncmp(cmd, "chmod", 5)) { + curl_off_t perms; + const char *p = sshc->quote_path1; + if(curlx_str_octal(&p, &perms, 07777)) { + failf(data, "Syntax error: chmod permissions not a number"); + myssh_quote_error(data, sshc, NULL); + return SSH_NO_ERROR; + } + sshc->quote_attrs->permissions = (mode_t)perms; + sshc->quote_attrs->flags |= SSH_FILEXFER_ATTR_PERMISSIONS; + } + else if(!strncmp(cmd, "chown", 5)) { + const char *p = sshc->quote_path1; + curl_off_t uid; + if(curlx_str_number(&p, &uid, UINT_MAX)) { + failf(data, "Syntax error: chown uid not a number"); + myssh_quote_error(data, sshc, NULL); + return SSH_NO_ERROR; + } + sshc->quote_attrs->uid = (uint32_t)uid; + sshc->quote_attrs->flags |= SSH_FILEXFER_ATTR_UIDGID; + } + else if(!strncmp(cmd, "atime", 5) || + !strncmp(cmd, "mtime", 5)) { + time_t date; + bool fail = FALSE; + if(Curl_getdate_capped(sshc->quote_path1, &date)) { + failf(data, "incorrect date format for %.*s", 5, cmd); + fail = TRUE; + } +#if SIZEOF_TIME_T > 4 + else if(date > 0xffffffff) { + failf(data, "date overflow"); + fail = TRUE; /* avoid setting a capped time */ + } +#endif + if(fail) { + myssh_quote_error(data, sshc, NULL); + return SSH_NO_ERROR; + } + if(!strncmp(cmd, "atime", 5)) + sshc->quote_attrs->atime = (uint32_t)date; + else /* mtime */ + sshc->quote_attrs->mtime = (uint32_t)date; + + sshc->quote_attrs->flags |= SSH_FILEXFER_ATTR_ACMODTIME; + } + + /* Now send the completed structure... */ + myssh_to(data, sshc, SSH_SFTP_QUOTE_SETSTAT); + return SSH_NO_ERROR; +} + +static void conn_forget_socket(struct Curl_easy *data, int sockindex) +{ + struct connectdata *conn = data->conn; + if(conn && CONN_SOCK_IDX_VALID(sockindex)) { + struct Curl_cfilter *cf = conn->cfilter[sockindex]; + if(cf) + (void)Curl_conn_cf_cntrl(cf, data, TRUE, CF_CTRL_FORGET_SOCKET, 0, NULL); + fake_sclose(conn->sock[sockindex]); + conn->sock[sockindex] = CURL_SOCKET_BAD; + } +} + +static void myssh_SESSION_DISCONNECT(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + /* during weird times when we have been prematurely aborted, the channel + is still alive when we reach this state and we MUST kill the channel + properly first */ + if(sshc->scp_session) { + ssh_scp_free(sshc->scp_session); + sshc->scp_session = NULL; + } + + if(sshc->sftp_file) { + sftp_close(sshc->sftp_file); + sshc->sftp_file = NULL; + } + if(sshc->sftp_session) { + sftp_free(sshc->sftp_session); + sshc->sftp_session = NULL; + } + + ssh_disconnect(sshc->ssh_session); + if(!ssh_version(SSH_VERSION_INT(0, 10, 0))) { + /* conn->sock[FIRSTSOCKET] is closed by ssh_disconnect behind our back, + tell the connection to forget about it. This libssh + bug is fixed in 0.10.0. */ + conn_forget_socket(data, FIRSTSOCKET); + } + + SSH_STRING_FREE_CHAR(sshc->homedir); + + myssh_to(data, sshc, SSH_SESSION_FREE); +} + +static int myssh_SSH_SCP_DOWNLOAD(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + curl_off_t bytecount; + int rc = ssh_scp_pull_request(sshc->scp_session); + if(rc != SSH_SCP_REQUEST_NEWFILE) { + const char *err_msg = ssh_get_error(sshc->ssh_session); + failf(data, "%s", err_msg); + return myssh_to_ERROR(data, sshc, CURLE_REMOTE_FILE_NOT_FOUND); + } + + /* download data */ + bytecount = ssh_scp_request_get_size(sshc->scp_session); + data->req.maxdownload = bytecount; + Curl_xfer_setup_recv(data, FIRSTSOCKET, bytecount); + + /* not set by Curl_xfer_setup to preserve io_flags */ + data->conn->send_idx = 0; + + myssh_to(data, sshc, SSH_STOP); + return 0; +} + +static int myssh_in_TRANS_INIT(struct Curl_easy *data, struct ssh_conn *sshc, + struct SSHPROTO *sshp) +{ + CURLcode result; + int rc = 0; + if(!sshp) + return myssh_to_ERROR(data, sshc, CURLE_FAILED_INIT); + + result = Curl_getworkingpath(data, sshc->homedir, &sshp->path); + if(result) { + sshc->actualcode = result; + myssh_to(data, sshc, SSH_STOP); + return 0; + } + + /* Functions from the SCP subsystem cannot handle/return SSH_AGAIN */ + ssh_set_blocking(sshc->ssh_session, 1); + + if(data->state.upload) { + if(data->state.infilesize < 0) { + failf(data, "SCP requires a known file size for upload"); + return myssh_to_ERROR(data, sshc, CURLE_UPLOAD_FAILED); + } + + sshc->scp_session = + ssh_scp_new(sshc->ssh_session, SSH_SCP_WRITE, sshp->path); + myssh_to(data, sshc, SSH_SCP_UPLOAD_INIT); + } + else { + sshc->scp_session = + ssh_scp_new(sshc->ssh_session, SSH_SCP_READ, sshp->path); + myssh_to(data, sshc, SSH_SCP_DOWNLOAD_INIT); + } + + if(!sshc->scp_session) { + const char *err_msg = ssh_get_error(sshc->ssh_session); + failf(data, "%s", err_msg); + rc = myssh_to_ERROR(data, sshc, CURLE_UPLOAD_FAILED); + } + return rc; +} + +static void sshc_cleanup(struct ssh_conn *sshc) +{ + if(sshc->initialized) { + if(sshc->sftp_file) { + sftp_close(sshc->sftp_file); + sshc->sftp_file = NULL; + } + if(sshc->sftp_session) { + sftp_free(sshc->sftp_session); + sshc->sftp_session = NULL; + } + if(sshc->ssh_session) { + ssh_free(sshc->ssh_session); + sshc->ssh_session = NULL; + } + + /* worst-case scenario cleanup */ + DEBUGASSERT(!sshc->ssh_session); + DEBUGASSERT(!sshc->scp_session); + + if(sshc->readdir_tmp) { + ssh_string_free_char(sshc->readdir_tmp); + sshc->readdir_tmp = NULL; + } + if(sshc->quote_attrs) { + sftp_attributes_free(sshc->quote_attrs); + sshc->quote_attrs = NULL; + } + if(sshc->readdir_attrs) { + sftp_attributes_free(sshc->readdir_attrs); + sshc->readdir_attrs = NULL; + } + if(sshc->readdir_link_attrs) { + sftp_attributes_free(sshc->readdir_link_attrs); + sshc->readdir_link_attrs = NULL; + } + if(sshc->privkey) { + ssh_key_free(sshc->privkey); + sshc->privkey = NULL; + } + if(sshc->pubkey) { + ssh_key_free(sshc->pubkey); + sshc->pubkey = NULL; + } + + curlx_safefree(sshc->rsa_pub); + curlx_safefree(sshc->rsa); + curlx_safefree(sshc->quote_path1); + curlx_safefree(sshc->quote_path2); + curlx_dyn_free(&sshc->readdir_buf); + curlx_safefree(sshc->readdir_linkPath); + SSH_STRING_FREE_CHAR(sshc->homedir); + sshc->initialized = FALSE; + } +} + +static int myssh_in_SFTP_QUOTE_SETSTAT(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + int rc = sftp_setstat(sshc->sftp_session, sshc->quote_path2, + sshc->quote_attrs); + if(rc == SSH_AGAIN) + return rc; + if(rc && !sshc->acceptfail) { + myssh_quote_error(data, sshc, "setstat"); + return rc; + } + myssh_to(data, sshc, SSH_SFTP_NEXT_QUOTE); + return SSH_NO_ERROR; +} + +static int myssh_in_SFTP_QUOTE_SYMLINK(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + int rc = sftp_symlink(sshc->sftp_session, sshc->quote_path2, + sshc->quote_path1); + if(rc == SSH_AGAIN) + return rc; + if(rc && !sshc->acceptfail) { + myssh_quote_error(data, sshc, "symlink"); + return rc; + } + myssh_to(data, sshc, SSH_SFTP_NEXT_QUOTE); + return SSH_NO_ERROR; +} + +static int myssh_in_SFTP_QUOTE_MKDIR(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + int rc = sftp_mkdir(sshc->sftp_session, sshc->quote_path1, + (mode_t)data->set.new_directory_perms); + if(rc == SSH_AGAIN) + return rc; + if(rc && !sshc->acceptfail) { + myssh_quote_error(data, sshc, "mkdir"); + return rc; + } + myssh_to(data, sshc, SSH_SFTP_NEXT_QUOTE); + return SSH_NO_ERROR; +} + +static int myssh_in_SFTP_QUOTE_RENAME(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + int rc = sftp_rename(sshc->sftp_session, sshc->quote_path1, + sshc->quote_path2); + if(rc == SSH_AGAIN) + return rc; + if(rc && !sshc->acceptfail) { + myssh_quote_error(data, sshc, "rename"); + return rc; + } + myssh_to(data, sshc, SSH_SFTP_NEXT_QUOTE); + return SSH_NO_ERROR; +} + +static int myssh_in_SFTP_QUOTE_RMDIR(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + int rc = sftp_rmdir(sshc->sftp_session, sshc->quote_path1); + if(rc == SSH_AGAIN) + return rc; + if(rc && !sshc->acceptfail) { + myssh_quote_error(data, sshc, "rmdir"); + return rc; + } + myssh_to(data, sshc, SSH_SFTP_NEXT_QUOTE); + return SSH_NO_ERROR; +} + +static int myssh_in_SFTP_QUOTE_UNLINK(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + int rc = sftp_unlink(sshc->sftp_session, sshc->quote_path1); + if(rc == SSH_AGAIN) + return rc; + if(rc && !sshc->acceptfail) { + myssh_quote_error(data, sshc, "rm"); + return rc; + } + myssh_to(data, sshc, SSH_SFTP_NEXT_QUOTE); + return SSH_NO_ERROR; +} + +static int myssh_in_SFTP_GETINFO(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + if(data->set.get_filetime) + myssh_to(data, sshc, SSH_SFTP_FILETIME); + else + myssh_to(data, sshc, SSH_SFTP_TRANS_INIT); + return SSH_NO_ERROR; +} + +static int myssh_in_SFTP_FILETIME(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp) +{ + sftp_attributes attrs; + if(!sshp) + return myssh_to_ERROR(data, sshc, CURLE_FAILED_INIT); + + attrs = sftp_stat(sshc->sftp_session, sshp->path); + if(attrs) { + data->info.filetime = attrs->mtime; + sftp_attributes_free(attrs); + } + + myssh_to(data, sshc, SSH_SFTP_TRANS_INIT); + return SSH_NO_ERROR; +} + +static int myssh_in_SFTP_TRANS_INIT(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp) +{ + if(!sshp) + return myssh_to_ERROR(data, sshc, CURLE_FAILED_INIT); + if(data->state.upload) + myssh_to(data, sshc, SSH_SFTP_UPLOAD_INIT); + else { + size_t path_len = strlen(sshp->path); + + if(path_len && sshp->path[path_len - 1] == '/') + myssh_to(data, sshc, SSH_SFTP_READDIR_INIT); + else + myssh_to(data, sshc, SSH_SFTP_DOWNLOAD_INIT); + } + + return SSH_NO_ERROR; +} + +static int myssh_in_SFTP_CREATE_DIRS_INIT(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp) +{ + if(!sshp) + return myssh_to_ERROR(data, sshc, CURLE_FAILED_INIT); + + if(strlen(sshp->path) > 1) { + sshc->slash_pos = sshp->path + 1; /* ignore the leading '/' */ + myssh_to(data, sshc, SSH_SFTP_CREATE_DIRS); + } + else { + myssh_to(data, sshc, SSH_SFTP_UPLOAD_INIT); + } + return SSH_NO_ERROR; +} + +static int myssh_in_SFTP_CREATE_DIRS(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp) +{ + if(!sshp) + return myssh_to_ERROR(data, sshc, CURLE_FAILED_INIT); + + sshc->slash_pos = strchr(sshc->slash_pos, '/'); + if(sshc->slash_pos) { + *sshc->slash_pos = 0; + + infof(data, "Creating directory '%s'", sshp->path); + myssh_to(data, sshc, SSH_SFTP_CREATE_DIRS_MKDIR); + return SSH_NO_ERROR; + } + myssh_to(data, sshc, SSH_SFTP_UPLOAD_INIT); + return SSH_NO_ERROR; +} + +static int myssh_in_SFTP_CREATE_DIRS_MKDIR(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp) +{ + int rc; + int err; + /* 'mode' - parameter is preliminary - default to 0644 */ + if(!sshp) + return myssh_to_ERROR(data, sshc, CURLE_FAILED_INIT); + + rc = sftp_mkdir(sshc->sftp_session, sshp->path, + (mode_t)data->set.new_directory_perms); + if(rc == SSH_AGAIN) + return rc; + *sshc->slash_pos = '/'; + ++sshc->slash_pos; + if(rc < 0) { + /* + * Abort if failure was not that the directory already + * exists or the permission was denied (creation might + * succeed further down the path) - retry on unspecific + * FAILURE also + */ + err = sftp_get_error(sshc->sftp_session); + if((err != SSH_FX_FILE_ALREADY_EXISTS) && + (err != SSH_FX_FAILURE) && + (err != SSH_FX_PERMISSION_DENIED)) { + return myssh_to_SFTP_CLOSE(data, sshc); + } + rc = 0; /* clear rc and continue */ + } + myssh_to(data, sshc, SSH_SFTP_CREATE_DIRS); + return rc; +} + +static int myssh_in_SCP_UPLOAD_INIT(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp) +{ + int rc; + if(!sshp) + return myssh_to_ERROR(data, sshc, CURLE_FAILED_INIT); + + rc = ssh_scp_init(sshc->scp_session); + if(rc != SSH_OK) { + const char *err_msg = ssh_get_error(sshc->ssh_session); + failf(data, "%s", err_msg); + return myssh_to_ERROR(data, sshc, CURLE_UPLOAD_FAILED); + } + + rc = ssh_scp_push_file64(sshc->scp_session, sshp->path, + (uint64_t)data->state.infilesize, + (int)data->set.new_file_perms); + + if(rc != SSH_OK) { + const char *err_msg = ssh_get_error(sshc->ssh_session); + failf(data, "%s", err_msg); + return myssh_to_ERROR(data, sshc, CURLE_UPLOAD_FAILED); + } + + /* upload data */ + Curl_xfer_setup_send(data, FIRSTSOCKET); + + /* not set by Curl_xfer_setup to preserve io_flags */ + data->conn->recv_idx = FIRSTSOCKET; + + myssh_to(data, sshc, SSH_STOP); + return SSH_NO_ERROR; +} + +static int myssh_in_SCP_DOWNLOAD_INIT(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + int rc = ssh_scp_init(sshc->scp_session); + if(rc != SSH_OK) { + const char *err_msg = ssh_get_error(sshc->ssh_session); + failf(data, "%s", err_msg); + return myssh_to_ERROR(data, sshc, + CURLE_COULDNT_CONNECT); + } + myssh_to(data, sshc, SSH_SCP_DOWNLOAD); + return SSH_NO_ERROR; +} + +static int myssh_in_SCP_DONE(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + if(data->state.upload) + myssh_to(data, sshc, SSH_SCP_SEND_EOF); + else + myssh_to(data, sshc, SSH_SCP_CHANNEL_FREE); + return SSH_NO_ERROR; +} + +static int myssh_in_SCP_SEND_EOF(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + if(sshc->scp_session) { + int rc = ssh_scp_close(sshc->scp_session); + if(rc == SSH_AGAIN) { + /* Currently the ssh_scp_close handles waiting for + * EOF in blocking way. + */ + return SSH_AGAIN; + } + if(rc != SSH_OK) { + infof(data, + "Failed to close libssh scp channel: %s", + ssh_get_error(sshc->ssh_session)); + } + } + + myssh_to(data, sshc, SSH_SCP_CHANNEL_FREE); + return SSH_NO_ERROR; +} + +static int myssh_in_SCP_CHANNEL_FREE(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + if(sshc->scp_session) { + ssh_scp_free(sshc->scp_session); + sshc->scp_session = NULL; + } + CURL_TRC_SSH(data, "SCP DONE phase complete"); + + ssh_set_blocking(sshc->ssh_session, 0); + + myssh_to(data, sshc, SSH_SESSION_DISCONNECT); + return SSH_NO_ERROR; +} + +static CURLcode myssh_in_SESSION_FREE(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + CURLcode result; + sshc_cleanup(sshc); + /* the code we are about to return */ + result = sshc->actualcode; + memset(sshc, 0, sizeof(struct ssh_conn)); + connclose(data->conn, "SSH session free"); + sshc->state = SSH_SESSION_FREE; /* current */ + sshc->nextstate = SSH_NO_STATE; + myssh_to(data, sshc, SSH_STOP); + return result; +} + +/* + * myssh_statemachine() runs the SSH state machine as far as it can without + * blocking and without reaching the end. The data the pointer 'block' points + * to is set to TRUE if the libssh function returns SSH_AGAIN + * meaning it wants to be called again when the socket is ready + */ +static CURLcode myssh_statemachine(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp, + bool *block) +{ + CURLcode result = CURLE_OK; + int rc = SSH_NO_ERROR; + + *block = FALSE; /* we are not blocking by default */ + do { + + switch(sshc->state) { + case SSH_INIT: + myssh_state_init(data, sshc); + FALLTHROUGH(); + case SSH_S_STARTUP: + rc = myssh_in_S_STARTUP(data, sshc); + if(rc) + break; + FALLTHROUGH(); + case SSH_HOSTKEY: + rc = myssh_is_known(data, sshc); + if(rc != SSH_OK) { + rc = myssh_to_ERROR(data, sshc, CURLE_PEER_FAILED_VERIFICATION); + break; + } + myssh_to(data, sshc, SSH_AUTHLIST); + FALLTHROUGH(); + case SSH_AUTHLIST: + rc = myssh_in_AUTHLIST(data, sshc); + break; + case SSH_AUTH_PKEY_INIT: + rc = myssh_in_AUTH_PKEY_INIT(data, sshc); + break; + case SSH_AUTH_PKEY: + rc = myssh_in_AUTH_PKEY(data, sshc); + break; + case SSH_AUTH_GSSAPI: + rc = myssh_in_AUTH_GSSAPI(data, sshc); + break; + case SSH_AUTH_KEY_INIT: + rc = myssh_in_AUTH_KEY_INIT(data, sshc); + break; + case SSH_AUTH_KEY: + rc = myssh_in_AUTH_KEY(data, sshc); + break; + case SSH_AUTH_PASS_INIT: + rc = myssh_in_AUTH_PASS_INIT(data, sshc); + break; + case SSH_AUTH_PASS: + rc = myssh_in_AUTH_PASS(data, sshc); + break; + case SSH_AUTH_DONE: + rc = myssh_in_AUTH_DONE(data, sshc); + break; + case SSH_SFTP_INIT: + rc = myssh_in_SFTP_INIT(data, sshc); + break; + case SSH_SFTP_REALPATH: + rc = myssh_in_SFTP_REALPATH(data, sshc); + break; + case SSH_SFTP_QUOTE_INIT: + rc = myssh_in_SFTP_QUOTE_INIT(data, sshc, sshp); + break; + case SSH_SFTP_POSTQUOTE_INIT: + rc = myssh_in_SFTP_POSTQUOTE_INIT(data, sshc); + break; + case SSH_SFTP_QUOTE: + rc = myssh_in_SFTP_QUOTE(data, sshc, sshp); + break; + case SSH_SFTP_NEXT_QUOTE: + rc = myssh_in_SFTP_NEXT_QUOTE(data, sshc); + break; + case SSH_SFTP_QUOTE_STAT: + rc = myssh_in_SFTP_QUOTE_STAT(data, sshc); + break; + case SSH_SFTP_QUOTE_SETSTAT: + rc = myssh_in_SFTP_QUOTE_SETSTAT(data, sshc); + break; + case SSH_SFTP_QUOTE_SYMLINK: + rc = myssh_in_SFTP_QUOTE_SYMLINK(data, sshc); + break; + case SSH_SFTP_QUOTE_MKDIR: + rc = myssh_in_SFTP_QUOTE_MKDIR(data, sshc); + break; + case SSH_SFTP_QUOTE_RENAME: + rc = myssh_in_SFTP_QUOTE_RENAME(data, sshc); + break; + case SSH_SFTP_QUOTE_RMDIR: + rc = myssh_in_SFTP_QUOTE_RMDIR(data, sshc); + break; + case SSH_SFTP_QUOTE_UNLINK: + rc = myssh_in_SFTP_QUOTE_UNLINK(data, sshc); + break; + case SSH_SFTP_QUOTE_STATVFS: + rc = myssh_in_SFTP_QUOTE_STATVFS(data, sshc); + break; + case SSH_SFTP_GETINFO: + rc = myssh_in_SFTP_GETINFO(data, sshc); + break; + case SSH_SFTP_FILETIME: + rc = myssh_in_SFTP_FILETIME(data, sshc, sshp); + break; + case SSH_SFTP_TRANS_INIT: + rc = myssh_in_SFTP_TRANS_INIT(data, sshc, sshp); + break; + case SSH_SFTP_UPLOAD_INIT: + rc = myssh_in_UPLOAD_INIT(data, sshc, sshp); + break; + case SSH_SFTP_CREATE_DIRS_INIT: + rc = myssh_in_SFTP_CREATE_DIRS_INIT(data, sshc, sshp); + break; + case SSH_SFTP_CREATE_DIRS: + rc = myssh_in_SFTP_CREATE_DIRS(data, sshc, sshp); + break; + case SSH_SFTP_CREATE_DIRS_MKDIR: + rc = myssh_in_SFTP_CREATE_DIRS_MKDIR(data, sshc, sshp); + break; + case SSH_SFTP_READDIR_INIT: + rc = myssh_in_SFTP_READDIR_INIT(data, sshc, sshp); + break; + case SSH_SFTP_READDIR: + rc = myssh_in_SFTP_READDIR(data, sshc, sshp); + break; + case SSH_SFTP_READDIR_LINK: + rc = myssh_in_SFTP_READDIR_LINK(data, sshc); + break; + case SSH_SFTP_READDIR_BOTTOM: + rc = myssh_in_SFTP_READDIR_BOTTOM(data, sshc); + break; + case SSH_SFTP_READDIR_DONE: + rc = myssh_in_SFTP_READDIR_DONE(data, sshc); + break; + case SSH_SFTP_DOWNLOAD_INIT: + rc = myssh_in_SFTP_DOWNLOAD_INIT(data, sshc, sshp); + break; + case SSH_SFTP_DOWNLOAD_STAT: + rc = myssh_in_SFTP_DOWNLOAD_STAT(data, sshc); + break; + case SSH_SFTP_CLOSE: + rc = myssh_in_SFTP_CLOSE(data, sshc, sshp); + break; + case SSH_SFTP_SHUTDOWN: + rc = myssh_in_SFTP_SHUTDOWN(data, sshc); + break; + case SSH_SCP_TRANS_INIT: + rc = myssh_in_TRANS_INIT(data, sshc, sshp); + break; + case SSH_SCP_UPLOAD_INIT: + rc = myssh_in_SCP_UPLOAD_INIT(data, sshc, sshp); + break; + case SSH_SCP_DOWNLOAD_INIT: + rc = myssh_in_SCP_DOWNLOAD_INIT(data, sshc); + if(rc) + break; + FALLTHROUGH(); + case SSH_SCP_DOWNLOAD: + rc = myssh_SSH_SCP_DOWNLOAD(data, sshc); + break; + case SSH_SCP_DONE: + rc = myssh_in_SCP_DONE(data, sshc); + break; + case SSH_SCP_SEND_EOF: + rc = myssh_in_SCP_SEND_EOF(data, sshc); + break; + case SSH_SCP_CHANNEL_FREE: + myssh_in_SCP_CHANNEL_FREE(data, sshc); + FALLTHROUGH(); + case SSH_SESSION_DISCONNECT: + myssh_SESSION_DISCONNECT(data, sshc); + FALLTHROUGH(); + case SSH_SESSION_FREE: + result = myssh_in_SESSION_FREE(data, sshc); + break; + case SSH_QUIT: + default: + /* internal error */ + sshc->nextstate = SSH_NO_STATE; + myssh_to(data, sshc, SSH_STOP); + break; + } + /* break the loop only on STOP or SSH_AGAIN. If `rc` is some + * other error code, we will have progressed the state accordingly. */ + } while((rc != SSH_AGAIN) && (sshc->state != SSH_STOP)); + + if(rc == SSH_AGAIN) { + /* we would block, we need to wait for the socket to be ready (in the + right direction too)! */ + *block = TRUE; + } + if(!result && (sshc->state == SSH_STOP)) + result = sshc->actualcode; + CURL_TRC_SSH(data, "[%s] statemachine() -> %d, block=%d", + Curl_ssh_statename(sshc->state), (int)result, *block); + return result; +} + +/* called by the multi interface to figure out what socket(s) to wait for and + for what actions in the DO_DONE, PERFORM and WAITPERFORM states */ +static CURLcode myssh_pollset(struct Curl_easy *data, + struct easy_pollset *ps) +{ + struct connectdata *conn = data->conn; + struct ssh_conn *sshc = Curl_conn_meta_get(conn, CURL_META_SSH_CONN); + curl_socket_t sock = conn->sock[FIRSTSOCKET]; + int waitfor; + + if(!sshc || (sock == CURL_SOCKET_BAD)) + return CURLE_FAILED_INIT; + + waitfor = sshc->waitfor ? sshc->waitfor : data->req.io_flags; + if(waitfor) { + int flags = 0; + if(waitfor & REQ_IO_RECV) + flags |= CURL_POLL_IN; + if(waitfor & REQ_IO_SEND) + flags |= CURL_POLL_OUT; + DEBUGASSERT(flags); + CURL_TRC_SSH(data, "pollset, flags=%x", (unsigned int)flags); + return Curl_pollset_change(data, ps, sock, flags, 0); + } + /* While we still have a session, we listen incoming data. */ + if(sshc->ssh_session) + return Curl_pollset_change(data, ps, sock, CURL_POLL_IN, 0); + return CURLE_OK; +} + +/* called repeatedly until done from multi.c */ +static CURLcode myssh_multi_statemach(struct Curl_easy *data, + bool *done) +{ + struct connectdata *conn = data->conn; + struct ssh_conn *sshc = Curl_conn_meta_get(conn, CURL_META_SSH_CONN); + struct SSHPROTO *sshp = Curl_meta_get(data, CURL_META_SSH_EASY); + bool block; /* we store the status and use that to provide a ssh_pollset() + implementation */ + CURLcode result; + + if(!sshc || !sshp) + return CURLE_FAILED_INIT; + result = myssh_statemachine(data, sshc, sshp, &block); + *done = (sshc->state == SSH_STOP); + myssh_block2waitfor(conn, sshc, block); + + return result; +} + +static CURLcode myssh_block_statemach(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp, + bool disconnect) +{ + struct connectdata *conn = data->conn; + CURLcode result = CURLE_OK; + + while((sshc->state != SSH_STOP) && !result) { + bool block; + timediff_t left_ms = 1000; + + result = myssh_statemachine(data, sshc, sshp, &block); + if(result) + break; + + if(!disconnect) { + result = Curl_pgrsCheck(data); + if(result) + break; + + left_ms = Curl_timeleft_ms(data); + if(left_ms < 0) { + failf(data, "Operation timed out"); + return CURLE_OPERATION_TIMEDOUT; + } + } + + if(block) { + curl_socket_t fd_read = conn->sock[FIRSTSOCKET]; + /* wait for the socket to become ready */ + (void)SOCKET_READABLE(fd_read, left_ms > 1000 ? 1000 : left_ms); + } + } + + return result; +} + +static void myssh_easy_dtor(void *key, size_t klen, void *entry) +{ + struct SSHPROTO *sshp = entry; + (void)key; + (void)klen; + curlx_safefree(sshp->path); + curlx_free(sshp); +} + +static void myssh_conn_dtor(void *key, size_t klen, void *entry) +{ + struct ssh_conn *sshc = entry; + (void)key; + (void)klen; + sshc_cleanup(sshc); + curlx_free(sshc); +} + +/* + * SSH setup connection + */ +static CURLcode myssh_setup_connection(struct Curl_easy *data, + struct connectdata *conn) +{ + struct SSHPROTO *sshp; + struct ssh_conn *sshc; + + sshc = curlx_calloc(1, sizeof(*sshc)); + if(!sshc) + return CURLE_OUT_OF_MEMORY; + + curlx_dyn_init(&sshc->readdir_buf, CURL_PATH_MAX * 2); + sshc->initialized = TRUE; + if(Curl_conn_meta_set(conn, CURL_META_SSH_CONN, sshc, myssh_conn_dtor)) + return CURLE_OUT_OF_MEMORY; + + sshp = curlx_calloc(1, sizeof(*sshp)); + if(!sshp || + Curl_meta_set(data, CURL_META_SSH_EASY, sshp, myssh_easy_dtor)) + return CURLE_OUT_OF_MEMORY; + + return CURLE_OK; +} + +static Curl_recv scp_recv, sftp_recv; +static Curl_send scp_send, sftp_send; + +/* + * Curl_ssh_connect() gets called from Curl_protocol_connect() to allow us to + * do protocol-specific actions at connect-time. + */ +static CURLcode myssh_connect(struct Curl_easy *data, bool *done) +{ + CURLcode result; + struct connectdata *conn = data->conn; + struct ssh_conn *sshc = Curl_conn_meta_get(conn, CURL_META_SSH_CONN); + struct SSHPROTO *ssh = Curl_meta_get(data, CURL_META_SSH_EASY); + curl_socket_t sock = conn->sock[FIRSTSOCKET]; + int rc; + + if(!sshc || !ssh) + return CURLE_FAILED_INIT; + + CURL_TRC_SSH(data, "myssh_connect"); + if(conn->scheme->protocol & CURLPROTO_SCP) { + conn->recv[FIRSTSOCKET] = scp_recv; + conn->send[FIRSTSOCKET] = scp_send; + } + else { + conn->recv[FIRSTSOCKET] = sftp_recv; + conn->send[FIRSTSOCKET] = sftp_send; + } + + sshc->ssh_session = ssh_new(); + if(!sshc->ssh_session) { + failf(data, "Failure initializing ssh session"); + return CURLE_FAILED_INIT; + } + + rc = ssh_options_set(sshc->ssh_session, SSH_OPTIONS_HOST, + (data->state.up.hostname[0] == '[') ? + data->state.up.hostname : conn->origin->hostname); + + if(rc != SSH_OK) { + failf(data, "Could not set remote host"); + return CURLE_FAILED_INIT; + } + + rc = ssh_options_parse_config(sshc->ssh_session, NULL); + if(rc != SSH_OK) { + infof(data, "Could not parse SSH configuration files"); + /* ignore */ + } + + CURL_TRC_SSH(data, "myssh_connect, set socket=%" FMT_SOCKET_T, sock); + rc = ssh_options_set(sshc->ssh_session, SSH_OPTIONS_FD, &sock); + if(rc != SSH_OK) { + failf(data, "Could not set socket"); + return CURLE_FAILED_INIT; + } + + if(Curl_creds_has_user(conn->creds)) { + infof(data, "User: %s", conn->creds->user); + rc = ssh_options_set(sshc->ssh_session, SSH_OPTIONS_USER, + conn->creds->user); + if(rc != SSH_OK) { + failf(data, "Could not set user"); + return CURLE_FAILED_INIT; + } + } + + if(data->set.str[STRING_SSH_KNOWNHOSTS]) { + infof(data, "Known hosts: %s", data->set.str[STRING_SSH_KNOWNHOSTS]); + rc = ssh_options_set(sshc->ssh_session, SSH_OPTIONS_KNOWNHOSTS, + data->set.str[STRING_SSH_KNOWNHOSTS]); + if(rc == SSH_OK) + /* libssh has two separate options for this. Set both to the same file + to avoid surprises */ + rc = ssh_options_set(sshc->ssh_session, SSH_OPTIONS_GLOBAL_KNOWNHOSTS, + data->set.str[STRING_SSH_KNOWNHOSTS]); + if(rc != SSH_OK) { + failf(data, "Could not set known hosts file path"); + return CURLE_FAILED_INIT; + } + } + + if(conn->origin->port) { + rc = ssh_options_set(sshc->ssh_session, SSH_OPTIONS_PORT, + &conn->origin->port); + if(rc != SSH_OK) { + failf(data, "Could not set remote port"); + return CURLE_FAILED_INIT; + } + } + + if(data->set.ssh_compression) { + rc = ssh_options_set(sshc->ssh_session, SSH_OPTIONS_COMPRESSION, + "zlib,zlib@openssh.com,none"); + if(rc != SSH_OK) { + failf(data, "Could not set compression"); + return CURLE_FAILED_INIT; + } + } + + sshc->privkey = NULL; + sshc->pubkey = NULL; + + if(data->set.str[STRING_SSH_PUBLIC_KEY]) { + rc = ssh_pki_import_pubkey_file(data->set.str[STRING_SSH_PUBLIC_KEY], + &sshc->pubkey); + if(rc != SSH_OK) { + failf(data, "Could not load public key file"); + return CURLE_FAILED_INIT; + } + } + + /* we do not verify here, we do it at the state machine, + * after connection */ + + myssh_to(data, sshc, SSH_INIT); + + result = myssh_multi_statemach(data, done); + + return result; +} + +/* called from multi.c while DOing */ +static CURLcode scp_doing(struct Curl_easy *data, bool *dophase_done) +{ + CURLcode result; + + result = myssh_multi_statemach(data, dophase_done); + + if(*dophase_done) { + CURL_TRC_SSH(data, "DO phase is complete"); + } + return result; +} + +/* + *********************************************************************** + * + * scp_perform() + * + * This is the actual DO function for SCP. Get a file according to + * the options previously setup. + */ + +static CURLcode scp_perform(struct Curl_easy *data, + bool *connected, bool *dophase_done) +{ + CURLcode result = CURLE_OK; + struct ssh_conn *sshc = Curl_conn_meta_get(data->conn, CURL_META_SSH_CONN); + + CURL_TRC_SSH(data, "DO phase starts"); + + *dophase_done = FALSE; /* not done yet */ + if(!sshc) + return CURLE_FAILED_INIT; + + /* start the first command in the DO phase */ + myssh_to(data, sshc, SSH_SCP_TRANS_INIT); + + result = myssh_multi_statemach(data, dophase_done); + + *connected = Curl_conn_is_connected(data->conn, FIRSTSOCKET); + + if(*dophase_done) { + CURL_TRC_SSH(data, "DO phase is complete"); + } + + return result; +} + +/* BLOCKING, but the function is using the state machine so the only reason + this is still blocking is that the multi interface code has no support for + disconnecting operations that takes a while */ +static CURLcode scp_disconnect(struct Curl_easy *data, + struct connectdata *conn, + bool dead_connection) +{ + CURLcode result = CURLE_OK; + struct ssh_conn *sshc = Curl_conn_meta_get(conn, CURL_META_SSH_CONN); + struct SSHPROTO *sshp = Curl_meta_get(data, CURL_META_SSH_EASY); + (void)dead_connection; + + if(sshc && sshc->ssh_session) { + /* only if there is a session still around to use! */ + myssh_to(data, sshc, SSH_SESSION_DISCONNECT); + result = myssh_block_statemach(data, sshc, sshp, TRUE); + } + + return result; +} + +/* generic done function for both SCP and SFTP called from their specific + done functions */ +static CURLcode myssh_done(struct Curl_easy *data, + struct ssh_conn *sshc, + CURLcode status) +{ + CURLcode result = CURLE_OK; + struct SSHPROTO *sshp = Curl_meta_get(data, CURL_META_SSH_EASY); + + if(!status && sshp) { + /* run the state-machine */ + result = myssh_block_statemach(data, sshc, sshp, FALSE); + } + else + result = status; + + if(Curl_pgrsDone(data)) + return CURLE_ABORTED_BY_CALLBACK; + + CURL_REQ_CLEAR_IO(data); + return result; +} + +static CURLcode scp_done(struct Curl_easy *data, CURLcode status, + bool premature) +{ + struct ssh_conn *sshc = Curl_conn_meta_get(data->conn, CURL_META_SSH_CONN); + (void)premature; + + if(!sshc) + return CURLE_FAILED_INIT; + if(!status) + myssh_to(data, sshc, SSH_SCP_DONE); + + return myssh_done(data, sshc, status); +} + +static CURLcode scp_send(struct Curl_easy *data, int sockindex, + const uint8_t *mem, size_t len, bool eos, + size_t *pnwritten) +{ + int rc; + struct connectdata *conn = data->conn; + struct ssh_conn *sshc = Curl_conn_meta_get(conn, CURL_META_SSH_CONN); + + (void)sockindex; /* we only support SCP on the fixed known primary socket */ + (void)eos; + *pnwritten = 0; + + if(!sshc) + return CURLE_FAILED_INIT; + + rc = ssh_scp_write(sshc->scp_session, mem, len); + +#if 0 + /* The following code is misleading, mostly added as wishful thinking + * that libssh at some point would implement non-blocking ssh_scp_write/read. + * Currently rc can only be number of bytes read or SSH_ERROR. */ + myssh_block2waitfor(conn, sshc, (rc == SSH_AGAIN)); + + if(rc == SSH_AGAIN) + return CURLE_AGAIN; + else +#endif + if(rc != SSH_OK) + return CURLE_SSH; + + *pnwritten = len; + return CURLE_OK; +} + +static CURLcode scp_recv(struct Curl_easy *data, int sockindex, + char *mem, size_t len, size_t *pnread) +{ + struct connectdata *conn = data->conn; + struct ssh_conn *sshc = Curl_conn_meta_get(conn, CURL_META_SSH_CONN); + int nread; + + (void)sockindex; /* we only support SCP on the fixed known primary socket */ + *pnread = 0; + + if(!sshc) + return CURLE_FAILED_INIT; + + /* libssh returns int */ + nread = ssh_scp_read(sshc->scp_session, mem, len); + if(nread == SSH_ERROR) + return CURLE_SSH; +#if 0 + /* The following code is misleading, mostly added as wishful thinking + * that libssh at some point would implement non-blocking ssh_scp_write/read. + * Currently rc can only be SSH_OK or SSH_ERROR. */ + + myssh_block2waitfor(conn, sshc, (nread == SSH_AGAIN)); + if(nread == SSH_AGAIN) + return CURLE_AGAIN; +#endif + *pnread = (size_t)nread; + return CURLE_OK; +} + +/* + * =============== SFTP =============== + */ + +/* + *********************************************************************** + * + * sftp_perform() + * + * This is the actual DO function for SFTP. Get a file/directory according to + * the options previously setup. + */ + +static CURLcode sftp_perform(struct Curl_easy *data, + bool *connected, + bool *dophase_done) +{ + struct ssh_conn *sshc = Curl_conn_meta_get(data->conn, CURL_META_SSH_CONN); + CURLcode result = CURLE_OK; + + CURL_TRC_SSH(data, "DO phase starts"); + + *dophase_done = FALSE; /* not done yet */ + if(!sshc) + return CURLE_FAILED_INIT; + + /* start the first command in the DO phase */ + myssh_to(data, sshc, SSH_SFTP_QUOTE_INIT); + + /* run the state-machine */ + result = myssh_multi_statemach(data, dophase_done); + + *connected = Curl_conn_is_connected(data->conn, FIRSTSOCKET); + + if(*dophase_done) { + CURL_TRC_SSH(data, "DO phase is complete"); + } + + return result; +} + +/* called from multi.c while DOing */ +static CURLcode sftp_doing(struct Curl_easy *data, + bool *dophase_done) +{ + CURLcode result = myssh_multi_statemach(data, dophase_done); + if(*dophase_done) { + CURL_TRC_SSH(data, "DO phase is complete"); + } + return result; +} + +/* BLOCKING, but the function is using the state machine so the only reason + this is still blocking is that the multi interface code has no support for + disconnecting operations that takes a while */ +static CURLcode sftp_disconnect(struct Curl_easy *data, + struct connectdata *conn, + bool dead_connection) +{ + struct ssh_conn *sshc = Curl_conn_meta_get(conn, CURL_META_SSH_CONN); + struct SSHPROTO *sshp = Curl_meta_get(data, CURL_META_SSH_EASY); + CURLcode result = CURLE_OK; + (void)dead_connection; + + CURL_TRC_SSH(data, "DISCONNECT starts now"); + + if(sshc && sshc->ssh_session) { + /* only if there is a session still around to use! */ + myssh_to(data, sshc, SSH_SFTP_SHUTDOWN); + result = myssh_block_statemach(data, sshc, sshp, TRUE); + } + + CURL_TRC_SSH(data, "DISCONNECT is done"); + return result; +} + +static CURLcode sftp_done(struct Curl_easy *data, CURLcode status, + bool premature) +{ + struct connectdata *conn = data->conn; + struct ssh_conn *sshc = Curl_conn_meta_get(conn, CURL_META_SSH_CONN); + + if(!sshc) + return CURLE_FAILED_INIT; + if(!status) { + /* Post quote commands are executed after the SFTP_CLOSE state to avoid + errors that could happen due to open file handles during POSTQUOTE + operation */ + if(!premature && data->set.postquote && !conn->bits.retry) + sshc->nextstate = SSH_SFTP_POSTQUOTE_INIT; + myssh_to(data, sshc, SSH_SFTP_CLOSE); + } + return myssh_done(data, sshc, status); +} + +/* return number of sent bytes */ +static CURLcode sftp_send(struct Curl_easy *data, int sockindex, + const uint8_t *mem, size_t len, bool eos, + size_t *pnwritten) +{ + struct connectdata *conn = data->conn; + struct ssh_conn *sshc = Curl_conn_meta_get(conn, CURL_META_SSH_CONN); + ssize_t nwrite; + + (void)sockindex; + (void)eos; + *pnwritten = 0; + + if(!sshc) + return CURLE_FAILED_INIT; + +#if LIBSSH_VERSION_INT > SSH_VERSION_INT(0, 11, 0) + switch(sshc->sftp_send_state) { + case 0: + sftp_file_set_nonblocking(sshc->sftp_file); + if(sftp_aio_begin_write(sshc->sftp_file, mem, len, + &sshc->sftp_send_aio) == SSH_ERROR) { + return CURLE_SEND_ERROR; + } + sshc->sftp_send_state = 1; + FALLTHROUGH(); + case 1: + nwrite = sftp_aio_wait_write(&sshc->sftp_send_aio); + myssh_block2waitfor(conn, sshc, (nwrite == SSH_AGAIN) ? TRUE : FALSE); + if(nwrite == SSH_AGAIN) + return CURLE_AGAIN; + else if(nwrite < 0) + return CURLE_SEND_ERROR; + + /* + * sftp_aio_wait_write() would free sftp_send_aio and + * assign it NULL in all cases except when it returns + * SSH_AGAIN. + */ + + sshc->sftp_send_state = 0; + *pnwritten = (size_t)nwrite; + return CURLE_OK; + default: + /* we never reach here */ + return CURLE_SEND_ERROR; + } +#else + /* + * limit the writes to the maximum specified in Section 3 of + * https://datatracker.ietf.org/doc/html/draft-ietf-secsh-filexfer-02 + * + * libssh started applying appropriate read/write length limits + * internally since version 0.11.0, hence such an operation is + * not needed for versions after (and including) 0.11.0. + */ + if(len > 32768) + len = 32768; + + nwrite = sftp_write(sshc->sftp_file, mem, len); + + myssh_block2waitfor(conn, sshc, FALSE); + +#if 0 /* not returned by libssh on write */ + if(nwrite == SSH_AGAIN) { + *err = CURLE_AGAIN; + nwrite = 0; + } + else +#endif + if(nwrite < 0) + return CURLE_SSH; + + *pnwritten = (size_t)nwrite; + return CURLE_OK; +#endif +} + +/* + * Return number of received (decrypted) bytes + * or <0 on error + */ +static CURLcode sftp_recv(struct Curl_easy *data, int sockindex, + char *mem, size_t len, size_t *pnread) +{ + struct connectdata *conn = data->conn; + struct ssh_conn *sshc = Curl_conn_meta_get(conn, CURL_META_SSH_CONN); + ssize_t nread; + + (void)sockindex; + *pnread = 0; + + DEBUGASSERT(len < CURL_MAX_READ_SIZE); + if(!sshc) + return CURLE_FAILED_INIT; + + switch(sshc->sftp_recv_state) { + case 0: +#if LIBSSH_VERSION_INT > SSH_VERSION_INT(0, 11, 0) + if(sftp_aio_begin_read(sshc->sftp_file, len, + &sshc->sftp_recv_aio) == SSH_ERROR) { + return CURLE_RECV_ERROR; + } +#else + sshc->sftp_file_index = + sftp_async_read_begin(sshc->sftp_file, (uint32_t)len); + if(sshc->sftp_file_index < 0) + return CURLE_RECV_ERROR; +#endif + + FALLTHROUGH(); + case 1: + sshc->sftp_recv_state = 1; + +#if LIBSSH_VERSION_INT > SSH_VERSION_INT(0, 11, 0) + nread = sftp_aio_wait_read(&sshc->sftp_recv_aio, mem, len); +#else + nread = sftp_async_read(sshc->sftp_file, mem, (uint32_t)len, + (uint32_t)sshc->sftp_file_index); +#endif + + myssh_block2waitfor(conn, sshc, (nread == SSH_AGAIN)); + + if(nread == SSH_AGAIN) + return CURLE_AGAIN; + else if(nread < 0) + return CURLE_RECV_ERROR; + + /* + * sftp_aio_wait_read() would free sftp_recv_aio and + * assign it NULL in all cases except when it returns + * SSH_AGAIN. + */ + + sshc->sftp_recv_state = 0; + *pnread = (size_t)nread; + return CURLE_OK; + + default: + /* we never reach here */ + return CURLE_RECV_ERROR; + } +} + +static CURLcode myssh_do_it(struct Curl_easy *data, bool *done) +{ + CURLcode result; + bool connected = FALSE; + struct connectdata *conn = data->conn; + struct ssh_conn *sshc = Curl_conn_meta_get(conn, CURL_META_SSH_CONN); + + *done = FALSE; /* default to false */ + if(!sshc) + return CURLE_FAILED_INIT; + + data->req.size = -1; /* make sure this is unknown at this point */ + + sshc->actualcode = CURLE_OK; /* reset error code */ + sshc->secondCreateDirs = 0; /* reset the create directory attempt state + variable */ + + Curl_pgrsReset(data); + + if(conn->scheme->protocol & CURLPROTO_SCP) + result = scp_perform(data, &connected, done); + else + result = sftp_perform(data, &connected, done); + + return result; +} + +CURLcode Curl_ssh_init(void) +{ + if(ssh_init()) { + DEBUGF(curl_mfprintf(stderr, "Error: libssh_init failed\n")); + return CURLE_FAILED_INIT; + } + return CURLE_OK; +} + +void Curl_ssh_cleanup(void) +{ + (void)ssh_finalize(); +} + +void Curl_ssh_version(char *buffer, size_t buflen) +{ + (void)curl_msnprintf(buffer, buflen, "libssh/%s", ssh_version(0)); +} + +/* + * SCP. + */ +const struct Curl_protocol Curl_protocol_scp = { + myssh_setup_connection, /* setup_connection */ + myssh_do_it, /* do_it */ + scp_done, /* done */ + ZERO_NULL, /* do_more */ + myssh_connect, /* connect_it */ + myssh_multi_statemach, /* connecting */ + scp_doing, /* doing */ + myssh_pollset, /* proto_pollset */ + myssh_pollset, /* doing_pollset */ + ZERO_NULL, /* domore_pollset */ + myssh_pollset, /* perform_pollset */ + scp_disconnect, /* disconnect */ + ZERO_NULL, /* write_resp */ + ZERO_NULL, /* write_resp_hd */ + ZERO_NULL, /* connection_is_dead */ + ZERO_NULL, /* attach connection */ + ZERO_NULL, /* follow */ +}; + +/* + * SFTP. + */ +const struct Curl_protocol Curl_protocol_sftp = { + myssh_setup_connection, /* setup_connection */ + myssh_do_it, /* do_it */ + sftp_done, /* done */ + ZERO_NULL, /* do_more */ + myssh_connect, /* connect_it */ + myssh_multi_statemach, /* connecting */ + sftp_doing, /* doing */ + myssh_pollset, /* proto_pollset */ + myssh_pollset, /* doing_pollset */ + ZERO_NULL, /* domore_pollset */ + myssh_pollset, /* perform_pollset */ + sftp_disconnect, /* disconnect */ + ZERO_NULL, /* write_resp */ + ZERO_NULL, /* write_resp_hd */ + ZERO_NULL, /* connection_is_dead */ + ZERO_NULL, /* attach connection */ + ZERO_NULL, /* follow */ +}; + +#endif /* USE_LIBSSH */ diff --git a/3rdparty/curl-8.21.0/lib/vssh/libssh2.c b/3rdparty/curl-8.21.0/lib/vssh/libssh2.c new file mode 100644 index 0000000000..b12d69f317 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vssh/libssh2.c @@ -0,0 +1,4052 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_LIBSSH2 + +/* #define CURL_LIBSSH2_DEBUG */ + +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_ARPA_INET_H +#include +#endif +#ifdef HAVE_NETDB_H +#include +#endif +#ifdef __VMS +#include +#include +#endif + +#include "urldata.h" +#include "sendf.h" +#include "curl_trc.h" +#include "hostip.h" +#include "progress.h" +#include "transfer.h" +#include "vssh/ssh.h" +#include "url.h" +#include "cfilters.h" +#include "connect.h" +#include "parsedate.h" /* for the week day and month names */ +#include "multiif.h" +#include "select.h" +#include "curlx/fopen.h" +#include "vssh/vssh.h" +#include "curlx/strparse.h" +#include "curlx/base64.h" /* for curlx_base64_encode() */ + +static const char *sftp_libssh2_strerror(unsigned long err) +{ + switch(err) { + case LIBSSH2_FX_NO_SUCH_FILE: + return "No such file or directory"; + + case LIBSSH2_FX_PERMISSION_DENIED: + return "Permission denied"; + + case LIBSSH2_FX_FAILURE: + return "Operation failed"; + + case LIBSSH2_FX_BAD_MESSAGE: + return "Bad message from SFTP server"; + + case LIBSSH2_FX_NO_CONNECTION: + return "Not connected to SFTP server"; + + case LIBSSH2_FX_CONNECTION_LOST: + return "Connection to SFTP server lost"; + + case LIBSSH2_FX_OP_UNSUPPORTED: + return "Operation not supported by SFTP server"; + + case LIBSSH2_FX_INVALID_HANDLE: + return "Invalid handle"; + + case LIBSSH2_FX_NO_SUCH_PATH: + return "No such file or directory"; + + case LIBSSH2_FX_FILE_ALREADY_EXISTS: + return "File already exists"; + + case LIBSSH2_FX_WRITE_PROTECT: + return "File is write protected"; + + case LIBSSH2_FX_NO_MEDIA: + return "No media"; + + case LIBSSH2_FX_NO_SPACE_ON_FILESYSTEM: + return "Disk full"; + + case LIBSSH2_FX_QUOTA_EXCEEDED: + return "User quota exceeded"; + + case LIBSSH2_FX_UNKNOWN_PRINCIPAL: + return "Unknown principal"; + + case LIBSSH2_FX_LOCK_CONFLICT: + return "File lock conflict"; + + case LIBSSH2_FX_DIR_NOT_EMPTY: + return "Directory not empty"; + + case LIBSSH2_FX_NOT_A_DIRECTORY: + return "Not a directory"; + + case LIBSSH2_FX_INVALID_FILENAME: + return "Invalid filename"; + + case LIBSSH2_FX_LINK_LOOP: + return "Link points to itself"; + } + return "Unknown error in libssh2"; +} + +static void kbd_callback(const char *name, int name_len, + const char *instruction, int instruction_len, + int num_prompts, + const LIBSSH2_USERAUTH_KBDINT_PROMPT *prompts, + LIBSSH2_USERAUTH_KBDINT_RESPONSE *responses, + void **abstract) +{ + struct Curl_easy *data = (struct Curl_easy *)*abstract; + +#ifdef CURL_LIBSSH2_DEBUG + curl_mfprintf(stderr, "name=%s\n", name); + curl_mfprintf(stderr, "name_len=%d\n", name_len); + curl_mfprintf(stderr, "instruction=%s\n", instruction); + curl_mfprintf(stderr, "instruction_len=%d\n", instruction_len); + curl_mfprintf(stderr, "num_prompts=%d\n", num_prompts); +#else + (void)name; + (void)name_len; + (void)instruction; + (void)instruction_len; +#endif /* CURL_LIBSSH2_DEBUG */ + if(num_prompts == 1) { + struct connectdata *conn = data->conn; + const char *passwd = Curl_creds_passwd(conn->creds); + /* this function must allocate memory that can be freed by libssh2, which + uses the LIBSSH2_FREE_FUNC callback */ + responses[0].text = Curl_cstrdup(passwd); + responses[0].length = responses[0].text ? curlx_uztoui(strlen(passwd)) : 0; + } + (void)prompts; +} /* kbd_callback */ + +static CURLcode sftp_libssh2_error_to_CURLE(unsigned long err) +{ + switch(err) { + case LIBSSH2_FX_OK: + return CURLE_OK; + + case LIBSSH2_FX_NO_SUCH_FILE: + case LIBSSH2_FX_NO_SUCH_PATH: + return CURLE_REMOTE_FILE_NOT_FOUND; + + case LIBSSH2_FX_PERMISSION_DENIED: + case LIBSSH2_FX_WRITE_PROTECT: + case LIBSSH2_FX_LOCK_CONFLICT: + return CURLE_REMOTE_ACCESS_DENIED; + + case LIBSSH2_FX_NO_SPACE_ON_FILESYSTEM: + case LIBSSH2_FX_QUOTA_EXCEEDED: + return CURLE_REMOTE_DISK_FULL; + + case LIBSSH2_FX_FILE_ALREADY_EXISTS: + return CURLE_REMOTE_FILE_EXISTS; + + case LIBSSH2_FX_DIR_NOT_EMPTY: + return CURLE_QUOTE_ERROR; + + default: + break; + } + + return CURLE_SSH; +} + +static CURLcode libssh2_session_error_to_CURLE(int err) +{ + switch(err) { + /* Ordered by order of appearance in libssh2.h */ + case LIBSSH2_ERROR_NONE: + return CURLE_OK; + + /* This is the error returned by libssh2_scp_recv2 + * on unknown file */ + case LIBSSH2_ERROR_SCP_PROTOCOL: + return CURLE_REMOTE_FILE_NOT_FOUND; + + case LIBSSH2_ERROR_SOCKET_NONE: + return CURLE_COULDNT_CONNECT; + + case LIBSSH2_ERROR_ALLOC: + return CURLE_OUT_OF_MEMORY; + + case LIBSSH2_ERROR_SOCKET_SEND: + return CURLE_SEND_ERROR; + + case LIBSSH2_ERROR_HOSTKEY_INIT: + case LIBSSH2_ERROR_HOSTKEY_SIGN: + case LIBSSH2_ERROR_PUBLICKEY_UNRECOGNIZED: + case LIBSSH2_ERROR_PUBLICKEY_UNVERIFIED: + return CURLE_PEER_FAILED_VERIFICATION; + + case LIBSSH2_ERROR_PASSWORD_EXPIRED: + return CURLE_LOGIN_DENIED; + + case LIBSSH2_ERROR_SOCKET_TIMEOUT: + case LIBSSH2_ERROR_TIMEOUT: + return CURLE_OPERATION_TIMEDOUT; + + case LIBSSH2_ERROR_EAGAIN: + return CURLE_AGAIN; + } + + return CURLE_SSH; +} + +/* These functions are made to use the libcurl memory functions - NOT the + debugmem functions, as that leads us to trigger on libssh2 memory leaks + that are not ours to care for */ + +static LIBSSH2_ALLOC_FUNC(my_libssh2_malloc) +{ + (void)abstract; + return Curl_cmalloc(count); +} + +static LIBSSH2_REALLOC_FUNC(my_libssh2_realloc) +{ + (void)abstract; + return Curl_crealloc(ptr, count); +} + +static LIBSSH2_FREE_FUNC(my_libssh2_free) +{ + (void)abstract; + if(ptr) /* ssh2 agent sometimes call free with null ptr */ + Curl_cfree(ptr); +} + +static int sshkeycallback(CURL *easy, + const struct curl_khkey *knownkey, /* known */ + const struct curl_khkey *foundkey, /* found */ + enum curl_khmatch match, + void *clientp) +{ + (void)easy; + (void)knownkey; + (void)foundkey; + (void)clientp; + + /* we only allow perfect matches, and we reject everything else */ + return (match != CURLKHMATCH_OK) ? CURLKHSTAT_REJECT : CURLKHSTAT_FINE; +} + +static enum curl_khtype convert_ssh2_keytype(int sshkeytype) +{ + enum curl_khtype keytype = CURLKHTYPE_UNKNOWN; + switch(sshkeytype) { + case LIBSSH2_HOSTKEY_TYPE_RSA: + keytype = CURLKHTYPE_RSA; + break; +#ifdef LIBSSH2_HOSTKEY_TYPE_DSS + case LIBSSH2_HOSTKEY_TYPE_DSS: /* deprecated upstream */ + keytype = CURLKHTYPE_DSS; + break; +#endif +#ifdef LIBSSH2_HOSTKEY_TYPE_ECDSA_256 + case LIBSSH2_HOSTKEY_TYPE_ECDSA_256: + keytype = CURLKHTYPE_ECDSA; + break; +#endif +#ifdef LIBSSH2_HOSTKEY_TYPE_ECDSA_384 + case LIBSSH2_HOSTKEY_TYPE_ECDSA_384: + keytype = CURLKHTYPE_ECDSA; + break; +#endif +#ifdef LIBSSH2_HOSTKEY_TYPE_ECDSA_521 + case LIBSSH2_HOSTKEY_TYPE_ECDSA_521: + keytype = CURLKHTYPE_ECDSA; + break; +#endif +#ifdef LIBSSH2_HOSTKEY_TYPE_ED25519 + case LIBSSH2_HOSTKEY_TYPE_ED25519: + keytype = CURLKHTYPE_ED25519; + break; +#endif + } + return keytype; +} + +static CURLcode ssh_knownhost(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + struct connectdata *conn = data->conn; + struct libssh2_knownhost *host = NULL; + const char *remotekey = NULL; + int keycheck = LIBSSH2_KNOWNHOST_CHECK_FAILURE; + int keybit = 0; + int sshkeytype = 0; + size_t keylen = 0; + int rc = 0; + CURLcode result = CURLE_OK; + + if(!data->set.str[STRING_SSH_KNOWNHOSTS]) { + infof(data, "SSH: no knownhosts file configured"); + return CURLE_OK; + } + + remotekey = libssh2_session_hostkey(sshc->ssh_session, + &keylen, &sshkeytype); + if(remotekey) { + /* + * A subject to figure out is what hostname we need to pass in here. + * What hostname does OpenSSH store in its file if an IDN name is + * used? + */ + enum curl_khmatch keymatch; + curl_sshkeycallback func = + data->set.ssh_keyfunc ? data->set.ssh_keyfunc : sshkeycallback; + struct curl_khkey knownkey; + struct curl_khkey *knownkeyp = NULL; + struct curl_khkey foundkey; + + switch(sshkeytype) { + case LIBSSH2_HOSTKEY_TYPE_RSA: + keybit = LIBSSH2_KNOWNHOST_KEY_SSHRSA; + break; +#ifdef LIBSSH2_HOSTKEY_TYPE_DSS + case LIBSSH2_HOSTKEY_TYPE_DSS: /* deprecated upstream */ + keybit = LIBSSH2_KNOWNHOST_KEY_SSHDSS; + break; +#endif + case LIBSSH2_HOSTKEY_TYPE_ECDSA_256: + keybit = LIBSSH2_KNOWNHOST_KEY_ECDSA_256; + break; + case LIBSSH2_HOSTKEY_TYPE_ECDSA_384: + keybit = LIBSSH2_KNOWNHOST_KEY_ECDSA_384; + break; + case LIBSSH2_HOSTKEY_TYPE_ECDSA_521: + keybit = LIBSSH2_KNOWNHOST_KEY_ECDSA_521; + break; + case LIBSSH2_HOSTKEY_TYPE_ED25519: + keybit = LIBSSH2_KNOWNHOST_KEY_ED25519; + break; + default: + infof(data, "SSH: unsupported host key type for knownhosts check"); + keybit = 0; + break; + } + if(!keybit) + /* no check means failure! */ + rc = CURLKHSTAT_REJECT; + else { + keycheck = libssh2_knownhost_checkp(sshc->kh, + conn->origin->hostname, + (conn->origin->port != PORT_SSH) ? + conn->origin->port : -1, + remotekey, keylen, + LIBSSH2_KNOWNHOST_TYPE_PLAIN| + LIBSSH2_KNOWNHOST_KEYENC_RAW| + keybit, + &host); + + infof(data, "SSH: host check %d, key: %s", keycheck, + (keycheck <= LIBSSH2_KNOWNHOST_CHECK_MISMATCH) ? + host->key : ""); + + /* setup 'knownkey' */ + if(keycheck <= LIBSSH2_KNOWNHOST_CHECK_MISMATCH) { + knownkey.key = host->key; + knownkey.len = 0; + knownkey.keytype = convert_ssh2_keytype(sshkeytype); + knownkeyp = &knownkey; + } + + /* setup 'foundkey' */ + foundkey.key = remotekey; + foundkey.len = keylen; + foundkey.keytype = convert_ssh2_keytype(sshkeytype); + + /* + * if any of the LIBSSH2_KNOWNHOST_CHECK_* defines and the + * curl_khmatch enum are ever modified, we need to introduce a + * translation table here! + */ + keymatch = (enum curl_khmatch)keycheck; + + /* Ask the callback how to behave */ + Curl_set_in_callback(data, TRUE); + rc = func(data, knownkeyp, /* from the knownhosts file */ + &foundkey, /* from the remote host */ + keymatch, data->set.ssh_keyfunc_userp); + Curl_set_in_callback(data, FALSE); + } + } + else { + /* no remotekey means failure! */ + infof(data, "SSH: host offers no public key"); + rc = CURLKHSTAT_REJECT; + } + + switch(rc) { + default: /* unknown return codes is the same as reject */ + case CURLKHSTAT_REJECT: + infof(data, "SSH: knownhost check failed"); + myssh_to(data, sshc, SSH_SESSION_FREE); + FALLTHROUGH(); + case CURLKHSTAT_DEFER: + /* DEFER means bail out but keep the SSH_HOSTKEY state */ + result = CURLE_PEER_FAILED_VERIFICATION; + break; + case CURLKHSTAT_FINE_REPLACE: + /* remove old host+key that does not match */ + if(host) + libssh2_knownhost_del(sshc->kh, host); + FALLTHROUGH(); + case CURLKHSTAT_FINE: + case CURLKHSTAT_FINE_ADD_TO_FILE: + /* proceed */ + if(keycheck != LIBSSH2_KNOWNHOST_CHECK_MATCH) { + int addrc; + const char *hostbuf; + char *hostport = NULL; + if(conn->origin->port != PORT_SSH) { + hostbuf = hostport = curl_maprintf("[%s]:%u", conn->origin->hostname, + conn->origin->port); + if(!hostbuf) + infof(data, "WARNING: failed allocating buffer for [host]:port"); + } + else + hostbuf = conn->origin->hostname; + if(hostbuf) { + /* the found host+key did not match but has been told to be fine + anyway so we add it in memory */ + addrc = libssh2_knownhost_addc(sshc->kh, hostbuf, NULL, + remotekey, keylen, NULL, 0, + LIBSSH2_KNOWNHOST_TYPE_PLAIN | + LIBSSH2_KNOWNHOST_KEYENC_RAW | + keybit, NULL); + if(addrc) + infof(data, "WARNING: adding the known host %s failed", hostbuf); + else if(rc == CURLKHSTAT_FINE_ADD_TO_FILE || + rc == CURLKHSTAT_FINE_REPLACE) { + /* now we write the entire in-memory list of known hosts to the + known_hosts file */ + int wrc = + libssh2_knownhost_writefile(sshc->kh, + data->set.str[STRING_SSH_KNOWNHOSTS], + LIBSSH2_KNOWNHOST_FILE_OPENSSH); + if(wrc) { + infof(data, "WARNING: writing %s failed", + data->set.str[STRING_SSH_KNOWNHOSTS]); + } + } + } + curlx_free(hostport); + } + else + infof(data, "SSH: knownhost entry matches host key"); + break; + } + return result; +} + +static CURLcode ssh_check_fingerprint(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + const char *pubkey_md5 = data->set.str[STRING_SSH_HOST_PUBLIC_KEY_MD5]; + const char *pubkey_sha256 = data->set.str[STRING_SSH_HOST_PUBLIC_KEY_SHA256]; + + if(pubkey_sha256) { + const char *fingerprint = NULL; + char *fingerprint_b64 = NULL; + size_t fingerprint_b64_len; + size_t pub_pos = 0; + size_t b64_pos = 0; + + infof(data, "SSH: SHA256 public key '%s'", pubkey_sha256); + /* The fingerprint points to static storage (!), do not free() it. */ + fingerprint = libssh2_hostkey_hash(sshc->ssh_session, + LIBSSH2_HOSTKEY_HASH_SHA256); + if(!fingerprint) { + failf(data, + "Denied establishing ssh session: SHA256 fingerprint " + "not available"); + myssh_to(data, sshc, SSH_SESSION_FREE); + return CURLE_PEER_FAILED_VERIFICATION; + } + + /* The length of fingerprint is 32 bytes for SHA256. + * See libssh2_hostkey_hash documentation. */ + if(curlx_base64_encode((const uint8_t *)fingerprint, 32, &fingerprint_b64, + &fingerprint_b64_len) != CURLE_OK) { + myssh_to(data, sshc, SSH_SESSION_FREE); + return CURLE_PEER_FAILED_VERIFICATION; + } + + if(!fingerprint_b64) { + failf(data, "SHA256 fingerprint could not be encoded"); + myssh_to(data, sshc, SSH_SESSION_FREE); + return CURLE_PEER_FAILED_VERIFICATION; + } + + infof(data, "SSH: SHA256 fingerprint '%s'", fingerprint_b64); + + /* Find the position of any = padding characters in the public key */ + while((pubkey_sha256[pub_pos] != '=') && pubkey_sha256[pub_pos]) { + pub_pos++; + } + + /* Find the position of any = padding characters in the base64 coded + * hostkey fingerprint */ + while((fingerprint_b64[b64_pos] != '=') && fingerprint_b64[b64_pos]) { + b64_pos++; + } + + /* Before we authenticate we check the hostkey's SHA256 fingerprint + * against a known fingerprint, if available. + */ + if((pub_pos != b64_pos) || + strncmp(fingerprint_b64, pubkey_sha256, pub_pos)) { + failf(data, + "Denied establishing ssh session: mismatch SHA256 fingerprint. " + "Remote %s is not equal to %s", fingerprint_b64, pubkey_sha256); + curlx_free(fingerprint_b64); + myssh_to(data, sshc, SSH_SESSION_FREE); + return CURLE_PEER_FAILED_VERIFICATION; + } + + curlx_free(fingerprint_b64); + + infof(data, "SSH: SHA256 checksum match"); + } + + if(pubkey_md5) { + char md5buffer[33]; + const char *fingerprint; + + infof(data, "SSH: MD5 public key '%s'", pubkey_md5); + fingerprint = libssh2_hostkey_hash(sshc->ssh_session, + LIBSSH2_HOSTKEY_HASH_MD5); + + if(fingerprint) { + /* The fingerprint points to static storage (!), do not free() it. */ + int i; + for(i = 0; i < 16; i++) { + curl_msnprintf(&md5buffer[i * 2], 3, "%02x", + (unsigned char)fingerprint[i]); + } + + infof(data, "SSH: MD5 fingerprint '%s'", md5buffer); + } + + /* This does NOT verify the length of 'pubkey_md5' separately, which + makes the comparison below fail unless it is exactly 32 characters */ + if(!fingerprint || !curl_strequal(md5buffer, pubkey_md5)) { + if(fingerprint) { + failf(data, + "Denied establishing ssh session: mismatch MD5 fingerprint. " + "Remote %s is not equal to %s", md5buffer, pubkey_md5); + } + else { + failf(data, + "Denied establishing ssh session: MD5 fingerprint " + "not available"); + } + myssh_to(data, sshc, SSH_SESSION_FREE); + return CURLE_PEER_FAILED_VERIFICATION; + } + infof(data, "SSH: MD5 checksum match"); + } + + if(!pubkey_md5 && !pubkey_sha256) { + if(data->set.ssh_hostkeyfunc) { + size_t keylen = 0; + int sshkeytype = 0; + int rc = 0; + /* we handle the process to the callback */ + const char *remotekey = libssh2_session_hostkey(sshc->ssh_session, + &keylen, &sshkeytype); + if(remotekey) { + enum curl_khtype keytype = convert_ssh2_keytype(sshkeytype); + Curl_set_in_callback(data, TRUE); + rc = data->set.ssh_hostkeyfunc(data->set.ssh_hostkeyfunc_userp, + (int)keytype, remotekey, keylen); + Curl_set_in_callback(data, FALSE); + if(rc != CURLKHMATCH_OK) { + myssh_to(data, sshc, SSH_SESSION_FREE); + failf(data, "SSH: callback failed host public key verification"); + return CURLE_PEER_FAILED_VERIFICATION; + } + infof(data, "SSH: verified public key via callback"); + } + else { + myssh_to(data, sshc, SSH_SESSION_FREE); + return CURLE_PEER_FAILED_VERIFICATION; + } + return CURLE_OK; + } + else { + CURL_TRC_SSH(data, "no host key checksum given, checking knownhosts"); + return ssh_knownhost(data, sshc); + } + } + else { + /* as we already matched, we skip the check for known hosts */ + return CURLE_OK; + } +} + +/* + * ssh_force_knownhost_key_type() checks the known hosts file and try to + * force a specific public key type from the server if an entry is found. + */ +static CURLcode ssh_force_knownhost_key_type(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + CURLcode result = CURLE_OK; + + static const char hostkey_method_ssh_ed25519[] = "ssh-ed25519"; + static const char hostkey_method_ssh_ecdsa_521[] = "ecdsa-sha2-nistp521"; + static const char hostkey_method_ssh_ecdsa_384[] = "ecdsa-sha2-nistp384"; + static const char hostkey_method_ssh_ecdsa_256[] = "ecdsa-sha2-nistp256"; + static const char hostkey_method_ssh_rsa_all[] = + "rsa-sha2-256,rsa-sha2-512,ssh-rsa"; +#ifdef LIBSSH2_KNOWNHOST_KEY_SSHDSS + static const char hostkey_method_ssh_dss[] = "ssh-dss"; +#endif + bool found = FALSE; + + if(sshc->kh && + !data->set.str[STRING_SSH_HOST_PUBLIC_KEY_MD5] && + !data->set.str[STRING_SSH_HOST_PUBLIC_KEY_SHA256]) { + struct libssh2_knownhost *store = NULL; + struct connectdata *conn = data->conn; + /* lets try to find our host in the known hosts file */ + while(!libssh2_knownhost_get(sshc->kh, &store, store)) { + /* For non-standard ports, the name is enclosed in */ + /* square brackets, followed by a colon and the port */ + if(store) { + if(store->name) { + if(store->name[0] == '[') { + curl_off_t port; + size_t kh_name_size = 0; + const char *p; + const char *kh_name_end = strstr(store->name, "]:"); + if(!kh_name_end) { + infof(data, "SSH: invalid host pattern %s in %s", + store->name, data->set.str[STRING_SSH_KNOWNHOSTS]); + continue; + } + p = kh_name_end + 2; /* start of port number */ + if(!curlx_str_number(&p, &port, 0xffff) && + (kh_name_end && (port == conn->origin->port))) { + kh_name_size = strlen(store->name) - 1 - strlen(kh_name_end); + if(!strncmp(store->name + 1, conn->origin->hostname, + kh_name_size)) { + found = TRUE; + break; + } + } + } + else if(!strcmp(store->name, conn->origin->hostname)) { + found = TRUE; + break; + } + } + else { + found = TRUE; + break; + } + } + } + + if(found) { + int rc; + const char *hostkey_method = NULL; + infof(data, "SSH: found host '%s' in '%s'", + conn->origin->hostname, data->set.str[STRING_SSH_KNOWNHOSTS]); + + switch(store->typemask & LIBSSH2_KNOWNHOST_KEY_MASK) { + case LIBSSH2_KNOWNHOST_KEY_ED25519: + hostkey_method = hostkey_method_ssh_ed25519; + break; + case LIBSSH2_KNOWNHOST_KEY_ECDSA_521: + hostkey_method = hostkey_method_ssh_ecdsa_521; + break; + case LIBSSH2_KNOWNHOST_KEY_ECDSA_384: + hostkey_method = hostkey_method_ssh_ecdsa_384; + break; + case LIBSSH2_KNOWNHOST_KEY_ECDSA_256: + hostkey_method = hostkey_method_ssh_ecdsa_256; + break; + case LIBSSH2_KNOWNHOST_KEY_SSHRSA: + hostkey_method = hostkey_method_ssh_rsa_all; + break; +#ifdef LIBSSH2_KNOWNHOST_KEY_SSHDSS + case LIBSSH2_KNOWNHOST_KEY_SSHDSS: /* deprecated upstream */ + hostkey_method = hostkey_method_ssh_dss; + break; +#endif + case LIBSSH2_KNOWNHOST_KEY_RSA1: + failf(data, "Found host key type RSA1 which is not supported"); + return CURLE_SSH; + default: + failf(data, "Unknown host key type: %d", + (store->typemask & LIBSSH2_KNOWNHOST_KEY_MASK)); + return CURLE_SSH; + } + + infof(data, "SSH: set '%s' as hostkey type", hostkey_method); + rc = libssh2_session_method_pref(sshc->ssh_session, + LIBSSH2_METHOD_HOSTKEY, hostkey_method); + if(rc) { + char *err_msg = NULL; + int errlen; + libssh2_session_last_error(sshc->ssh_session, &err_msg, &errlen, 0); + failf(data, "libssh2 method '%s' failed: %s", hostkey_method, err_msg); + result = libssh2_session_error_to_CURLE(rc); + } + } + else { + infof(data, "SSH: did not find host '%s' in '%s'", + conn->origin->hostname, data->set.str[STRING_SSH_KNOWNHOSTS]); + } + } + + return result; +} + +static CURLcode quote_error(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + failf(data, "Suspicious data after the command line"); + curlx_safefree(sshc->quote_path1); + curlx_safefree(sshc->quote_path2); + return CURLE_QUOTE_ERROR; +} + +static CURLcode sftp_quote(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp) +{ + const char *cp; + CURLcode result = CURLE_OK; + + /* + * Support some of the "FTP" commands + * + * 'sshc->quote_item' is already verified to be non-NULL before it + * switched to this state. + */ + const char *cmd = sshc->quote_item->data; + sshc->acceptfail = FALSE; + + /* if a command starts with an asterisk, which a legal SFTP command never + can, the command is allowed to fail without it causing any + aborts or cancels etc. It causes libcurl to act as if the command + is successful, whatever the server responds. */ + + if(cmd[0] == '*') { + cmd++; + sshc->acceptfail = TRUE; + } + + if(curl_strequal("pwd", cmd)) { + /* output debug output if that is requested */ + char *tmp = curl_maprintf("257 \"%s\" is current directory.\n", + sshp->path); + if(!tmp) + return CURLE_OUT_OF_MEMORY; + Curl_debug(data, CURLINFO_HEADER_OUT, "PWD\n", 4); + Curl_debug(data, CURLINFO_HEADER_IN, tmp, strlen(tmp)); + + /* this sends an FTP-like "header" to the header callback so that + the current directory can be read similar to how it is read when + using ordinary FTP. */ + result = Curl_client_write(data, CLIENTWRITE_HEADER, tmp, strlen(tmp)); + curlx_free(tmp); + if(!result) + myssh_to(data, sshc, SSH_SFTP_NEXT_QUOTE); + return result; + } + + /* + * the arguments following the command must be separated from the + * command with a space so we can check for it unconditionally + */ + cp = strchr(cmd, ' '); + if(!cp) { + failf(data, "Syntax error command '%s', missing parameter", cmd); + return CURLE_QUOTE_ERROR; + } + + /* + * also, every command takes at least one argument so we get that + * first argument right now + */ + result = Curl_get_pathname(&cp, &sshc->quote_path1, sshc->homedir); + if(result) { + if(result != CURLE_OUT_OF_MEMORY) + failf(data, "Syntax error: Bad first parameter to '%s'", cmd); + return result; + } + + /* + * SFTP is a binary protocol, so we do not send text commands to the server. + * Instead, we scan for commands used by OpenSSH's sftp program and call the + * appropriate libssh2 functions. + */ + if(!strncmp(cmd, "chgrp ", 6) || + !strncmp(cmd, "chmod ", 6) || + !strncmp(cmd, "chown ", 6) || + !strncmp(cmd, "atime ", 6) || + !strncmp(cmd, "mtime ", 6)) { + /* attribute change */ + + /* sshc->quote_path1 contains the mode to set */ + /* get the destination */ + result = Curl_get_pathname(&cp, &sshc->quote_path2, sshc->homedir); + if(result) { + if(result != CURLE_OUT_OF_MEMORY) + failf(data, "Syntax error in %s: Bad second parameter", cmd); + curlx_safefree(sshc->quote_path1); + return result; + } + if(*cp) + return quote_error(data, sshc); + + memset(&sshp->quote_attrs, 0, sizeof(LIBSSH2_SFTP_ATTRIBUTES)); + myssh_to(data, sshc, SSH_SFTP_QUOTE_STAT); + return result; + } + if(!strncmp(cmd, "ln ", 3) || + !strncmp(cmd, "symlink ", 8)) { + /* symbolic linking */ + /* sshc->quote_path1 is the source */ + /* get the destination */ + result = Curl_get_pathname(&cp, &sshc->quote_path2, sshc->homedir); + if(result) { + if(result != CURLE_OUT_OF_MEMORY) + failf(data, "Syntax error in ln/symlink: Bad second parameter"); + curlx_safefree(sshc->quote_path1); + return result; + } + if(*cp) + return quote_error(data, sshc); + myssh_to(data, sshc, SSH_SFTP_QUOTE_SYMLINK); + return result; + } + else if(!strncmp(cmd, "mkdir ", 6)) { + if(*cp) + return quote_error(data, sshc); + /* create directory */ + myssh_to(data, sshc, SSH_SFTP_QUOTE_MKDIR); + return result; + } + else if(!strncmp(cmd, "rename ", 7)) { + /* rename file */ + /* first param is the source path */ + /* second param is the dest. path */ + result = Curl_get_pathname(&cp, &sshc->quote_path2, sshc->homedir); + if(result) { + if(result != CURLE_OUT_OF_MEMORY) + failf(data, "Syntax error in rename: Bad second parameter"); + curlx_safefree(sshc->quote_path1); + return result; + } + if(*cp) + return quote_error(data, sshc); + myssh_to(data, sshc, SSH_SFTP_QUOTE_RENAME); + return result; + } + else if(!strncmp(cmd, "rmdir ", 6)) { + if(*cp) + return quote_error(data, sshc); + /* delete directory */ + myssh_to(data, sshc, SSH_SFTP_QUOTE_RMDIR); + return result; + } + else if(!strncmp(cmd, "rm ", 3)) { + if(*cp) + return quote_error(data, sshc); + myssh_to(data, sshc, SSH_SFTP_QUOTE_UNLINK); + return result; + } + else if(!strncmp(cmd, "statvfs ", 8)) { + if(*cp) + return quote_error(data, sshc); + myssh_to(data, sshc, SSH_SFTP_QUOTE_STATVFS); + return result; + } + + failf(data, "Unknown SFTP command"); + curlx_safefree(sshc->quote_path1); + curlx_safefree(sshc->quote_path2); + return CURLE_QUOTE_ERROR; +} + +static CURLcode sftp_upload_init(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp, + bool *blockp) +{ + unsigned long flags; + + /* + * NOTE!!! libssh2 requires that the destination path is a full path + * that includes the destination file and name OR ends in a "/" + * If this is not done the destination file is named the + * same name as the last directory in the path. + */ + + if(data->state.resume_from) { + LIBSSH2_SFTP_ATTRIBUTES attrs; + if(data->state.resume_from < 0) { + int rc = libssh2_sftp_stat_ex(sshc->sftp_session, sshp->path, + curlx_uztoui(strlen(sshp->path)), + LIBSSH2_SFTP_STAT, &attrs); + if(rc == LIBSSH2_ERROR_EAGAIN) { + *blockp = TRUE; + return CURLE_OK; + } + if(rc) { + data->state.resume_from = 0; + } + else { + curl_off_t size = attrs.filesize; + if(size < 0) { + failf(data, "Bad file size (%" FMT_OFF_T ")", size); + return CURLE_BAD_DOWNLOAD_RESUME; + } + data->state.resume_from = attrs.filesize; + } + } + } + + if(data->set.remote_append) { + /* True append mode: create if nonexisting */ + flags = LIBSSH2_FXF_WRITE | LIBSSH2_FXF_CREAT | LIBSSH2_FXF_APPEND; + } + else if(data->state.resume_from > 0) { + /* + * Resume MUST NOT use APPEND; some servers force writes to EOF when + * APPEND is set, ignoring a prior seek(). + */ + flags = LIBSSH2_FXF_WRITE; + } + else { + /* Clear file before writing (normal behavior) */ + flags = LIBSSH2_FXF_WRITE | LIBSSH2_FXF_CREAT | LIBSSH2_FXF_TRUNC; + } + + sshc->sftp_handle = + libssh2_sftp_open_ex(sshc->sftp_session, sshp->path, + curlx_uztoui(strlen(sshp->path)), + flags, (long)data->set.new_file_perms, + LIBSSH2_SFTP_OPENFILE); + + if(!sshc->sftp_handle) { + CURLcode result; + unsigned long sftperr; + int rc = libssh2_session_last_errno(sshc->ssh_session); + + if(LIBSSH2_ERROR_EAGAIN == rc) { + *blockp = TRUE; + return CURLE_OK; + } + + if(LIBSSH2_ERROR_SFTP_PROTOCOL == rc) + /* only when there was an SFTP protocol error can we extract + the sftp error! */ + sftperr = libssh2_sftp_last_error(sshc->sftp_session); + else + sftperr = LIBSSH2_FX_OK; /* not an sftp error at all */ + + if(sshc->secondCreateDirs) { + myssh_to(data, sshc, SSH_SFTP_CLOSE); + failf(data, "Creating the dir/file failed: %s", + sftp_libssh2_strerror(sftperr)); + return sftp_libssh2_error_to_CURLE(sftperr); + } + if((sftperr == LIBSSH2_FX_NO_SUCH_FILE || + sftperr == LIBSSH2_FX_FAILURE || + sftperr == LIBSSH2_FX_NO_SUCH_PATH) && + data->set.ftp_create_missing_dirs && + (strlen(sshp->path) > 1)) { + /* try to create the path remotely */ + sshc->secondCreateDirs = 1; + myssh_to(data, sshc, SSH_SFTP_CREATE_DIRS_INIT); + return CURLE_OK; + } + myssh_to(data, sshc, SSH_SFTP_CLOSE); + result = sftp_libssh2_error_to_CURLE(sftperr); + if(!result) { + /* Sometimes, for some reason libssh2_sftp_last_error() returns zero + even though libssh2_sftp_open() failed previously! We need to + work around that! */ + result = CURLE_SSH; + sftperr = LIBSSH2_FX_OK; + } + failf(data, "Upload failed: %s (%lu/%d)", + sftperr != LIBSSH2_FX_OK ? + sftp_libssh2_strerror(sftperr) : "ssh error", + sftperr, rc); + return result; + } + + /* If we have a restart point then we need to seek to the correct + Skip if in explicit remote append mode. */ + if(data->state.resume_from > 0 && !data->set.remote_append) { + int seekerr = CURL_SEEKFUNC_OK; + /* Let's read off the proper amount of bytes from the input. */ + if(data->set.seek_func) { + Curl_set_in_callback(data, TRUE); + seekerr = data->set.seek_func(data->set.seek_client, + data->state.resume_from, SEEK_SET); + Curl_set_in_callback(data, FALSE); + } + + if(seekerr != CURL_SEEKFUNC_OK) { + curl_off_t passed = 0; + + if(seekerr != CURL_SEEKFUNC_CANTSEEK) { + failf(data, "Could not seek stream"); + return CURLE_FTP_COULDNT_USE_REST; + } + /* seekerr == CURL_SEEKFUNC_CANTSEEK (cannot seek to offset) */ + do { + char scratch[4 * 1024]; + size_t readthisamountnow = + (data->state.resume_from - passed > + (curl_off_t)sizeof(scratch)) ? + sizeof(scratch) : curlx_sotouz(data->state.resume_from - passed); + + size_t actuallyread; + Curl_set_in_callback(data, TRUE); + actuallyread = data->state.fread_func(scratch, 1, + readthisamountnow, + data->state.in); + Curl_set_in_callback(data, FALSE); + + passed += actuallyread; + if((actuallyread == 0) || (actuallyread > readthisamountnow)) { + /* this checks for greater-than only to make sure that the + CURL_READFUNC_ABORT return code still aborts */ + failf(data, "Failed to read data"); + return CURLE_FTP_COULDNT_USE_REST; + } + } while(passed < data->state.resume_from); + } + + /* now, decrease the size of the read */ + if(data->state.infilesize > 0) { + data->state.infilesize -= data->state.resume_from; + data->req.size = data->state.infilesize; + Curl_pgrsSetUploadSize(data, data->state.infilesize); + } + + libssh2_sftp_seek64(sshc->sftp_handle, + (libssh2_uint64_t)data->state.resume_from); + } + if(data->state.infilesize > 0) { + data->req.size = data->state.infilesize; + Curl_pgrsSetUploadSize(data, data->state.infilesize); + } + /* upload data */ + Curl_xfer_setup_send(data, FIRSTSOCKET); + + /* not set by Curl_xfer_setup to preserve io_flags */ + data->conn->recv_idx = FIRSTSOCKET; + + /* since we do not really wait for anything at this point, we want the + state machine to move on as soon as possible so mark this as dirty */ + Curl_multi_mark_dirty(data); + + myssh_to(data, sshc, SSH_STOP); + return CURLE_OK; +} + +static CURLcode ssh_state_pkey_init(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + /* + * Check the supported auth types in the order I feel is most secure + * with the requested type of authentication + */ + sshc->authed = FALSE; + + if((data->set.ssh_auth_types & CURLSSH_AUTH_PUBLICKEY) && + strstr(sshc->authlist, "publickey")) { + bool out_of_memory = FALSE; + + sshc->rsa_pub = sshc->rsa = NULL; + + if(data->set.str[STRING_SSH_PRIVATE_KEY]) { + sshc->rsa = curlx_strdup(data->set.str[STRING_SSH_PRIVATE_KEY]); + if(!sshc->rsa) + out_of_memory = TRUE; + } + else { + /* To ponder about: should really the lib be messing about with the + HOME environment variable etc? */ + char *home = curl_getenv("HOME"); + curlx_struct_stat sbuf; + + /* If no private key file is specified, try some common paths. */ + if(home) { + /* Try ~/.ssh first. */ + sshc->rsa = curl_maprintf("%s/.ssh/id_rsa", home); + if(!sshc->rsa) + out_of_memory = TRUE; + else if(curlx_stat(sshc->rsa, &sbuf)) { + curlx_free(sshc->rsa); + sshc->rsa = curl_maprintf("%s/.ssh/id_dsa", home); + if(!sshc->rsa) + out_of_memory = TRUE; + else if(curlx_stat(sshc->rsa, &sbuf)) { + curlx_safefree(sshc->rsa); + } + } + curlx_free(home); + } + if(!out_of_memory && !sshc->rsa) { + /* Nothing found; try the current dir. */ + sshc->rsa = curlx_strdup("id_rsa"); + if(sshc->rsa && curlx_stat(sshc->rsa, &sbuf)) { + curlx_free(sshc->rsa); + sshc->rsa = curlx_strdup("id_dsa"); + if(sshc->rsa && curlx_stat(sshc->rsa, &sbuf)) { + curlx_free(sshc->rsa); + /* Out of guesses. Set to the empty string to avoid + * surprising info messages. */ + sshc->rsa = curlx_strdup(""); + } + } + } + } + + /* + * Unless the user explicitly specifies a public key file, let + * libssh2 extract the public key from the private key file. + * This is done by passing sshc->rsa_pub = NULL. + */ + if(!out_of_memory && data->set.str[STRING_SSH_PUBLIC_KEY] && + /* treat empty string the same way as NULL */ + data->set.str[STRING_SSH_PUBLIC_KEY][0]) { + sshc->rsa_pub = curlx_strdup(data->set.str[STRING_SSH_PUBLIC_KEY]); + if(!sshc->rsa_pub) + out_of_memory = TRUE; + } + + if(out_of_memory || !sshc->rsa) { + curlx_safefree(sshc->rsa); + curlx_safefree(sshc->rsa_pub); + myssh_to(data, sshc, SSH_SESSION_FREE); + return CURLE_OUT_OF_MEMORY; + } + + sshc->passphrase = data->set.ssl.primary.key_passwd; + if(!sshc->passphrase) + sshc->passphrase = ""; + + if(sshc->rsa_pub) + infof(data, "SSH: trying public key file '%s'", sshc->rsa_pub); + infof(data, "SSH: trying private key file '%s'", sshc->rsa); + + myssh_to(data, sshc, SSH_AUTH_PKEY); + } + else { + myssh_to(data, sshc, SSH_AUTH_PASS_INIT); + } + return CURLE_OK; +} + +static CURLcode sftp_quote_stat(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp, + bool *blockp) +{ + const char *cmd = sshc->quote_item->data; + sshc->acceptfail = FALSE; + + /* if a command starts with an asterisk, which a legal SFTP command never + can, the command is allowed to fail without it causing any aborts or + cancels etc. It causes libcurl to act as if the command is + successful, whatever the server responds. */ + + if(cmd[0] == '*') { + cmd++; + sshc->acceptfail = TRUE; + } + + if(strncmp(cmd, "chmod", 5)) { + /* Since chown and chgrp only set owner OR group but libssh2 wants to set + * them both at once, we need to obtain the current ownership first. This + * takes an extra protocol round trip. + */ + int rc = libssh2_sftp_stat_ex(sshc->sftp_session, sshc->quote_path2, + curlx_uztoui(strlen(sshc->quote_path2)), + LIBSSH2_SFTP_STAT, + &sshp->quote_attrs); + if(rc == LIBSSH2_ERROR_EAGAIN) { + *blockp = TRUE; + return CURLE_OK; + } + if(rc && !sshc->acceptfail) { /* get those attributes */ + unsigned long sftperr = libssh2_sftp_last_error(sshc->sftp_session); + failf(data, "Attempt to get SFTP stats failed: %s", + sftp_libssh2_strerror(sftperr)); + goto fail; + } + } + + /* Now set the new attributes... */ + if(!strncmp(cmd, "chgrp", 5)) { + const char *p = sshc->quote_path1; + curl_off_t gid; + if(!curlx_str_number(&p, &gid, ULONG_MAX)) { + sshp->quote_attrs.gid = (unsigned long)gid; + sshp->quote_attrs.flags = LIBSSH2_SFTP_ATTR_UIDGID; + } + else if(!sshc->acceptfail) { + failf(data, "Syntax error: chgrp gid not a number"); + goto fail; + } + } + else if(!strncmp(cmd, "chmod", 5)) { + curl_off_t perms; + const char *p = sshc->quote_path1; + /* permissions are octal */ + if(curlx_str_octal(&p, &perms, 07777)) { + failf(data, "Syntax error: chmod permissions not a number"); + goto fail; + } + + sshp->quote_attrs.permissions = (unsigned long)perms; + sshp->quote_attrs.flags = LIBSSH2_SFTP_ATTR_PERMISSIONS; + } + else if(!strncmp(cmd, "chown", 5)) { + const char *p = sshc->quote_path1; + curl_off_t uid; + if(!curlx_str_number(&p, &uid, ULONG_MAX)) { + sshp->quote_attrs.uid = (unsigned long)uid; + sshp->quote_attrs.flags = LIBSSH2_SFTP_ATTR_UIDGID; + } + else if(!sshc->acceptfail) { + failf(data, "Syntax error: chown uid not a number"); + goto fail; + } + } + else if(!strncmp(cmd, "atime", 5) || + !strncmp(cmd, "mtime", 5)) { + time_t date; + bool fail = FALSE; + + if(Curl_getdate_capped(sshc->quote_path1, &date)) { + failf(data, "incorrect date format for %.*s", 5, cmd); + fail = TRUE; + } +#if SIZEOF_TIME_T > SIZEOF_LONG + if(date > 0xffffffff) { + /* if 'long' cannot hold >32-bit, this date cannot be sent */ + failf(data, "date overflow"); + fail = TRUE; + } +#endif + if(fail) + goto fail; + if(!strncmp(cmd, "atime", 5)) + sshp->quote_attrs.atime = (unsigned long)date; + else /* mtime */ + sshp->quote_attrs.mtime = (unsigned long)date; + + sshp->quote_attrs.flags = LIBSSH2_SFTP_ATTR_ACMODTIME; + } + + /* Now send the completed structure... */ + myssh_to(data, sshc, SSH_SFTP_QUOTE_SETSTAT); + return CURLE_OK; +fail: + curlx_safefree(sshc->quote_path1); + curlx_safefree(sshc->quote_path2); + return CURLE_QUOTE_ERROR; +} + +static CURLcode sftp_download_stat(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp, + bool *blockp) +{ + LIBSSH2_SFTP_ATTRIBUTES attrs; + int rc = libssh2_sftp_stat_ex(sshc->sftp_session, sshp->path, + curlx_uztoui(strlen(sshp->path)), + LIBSSH2_SFTP_STAT, &attrs); + if(rc == LIBSSH2_ERROR_EAGAIN) { + *blockp = TRUE; + return CURLE_OK; + } + if(rc || + !(attrs.flags & LIBSSH2_SFTP_ATTR_SIZE) || + (attrs.filesize == 0)) { + /* + * libssh2_sftp_open() did not return an error, so maybe the server + * does not support stat() + * OR the server does not return a file size with a stat() + * OR file size is 0 + */ + data->req.size = -1; + data->req.maxdownload = -1; + Curl_pgrsSetDownloadSize(data, -1); + attrs.filesize = 0; /* might be uninitialized but is read below */ + } + else { + curl_off_t size = attrs.filesize; + + if(size < 0) { + failf(data, "Bad file size (%" FMT_OFF_T ")", size); + return CURLE_BAD_DOWNLOAD_RESUME; + } + if(data->state.use_range) { + curl_off_t from; + CURLcode result = Curl_ssh_range(data, data->state.range, size, + &from, &size); + if(result) + return result; + + libssh2_sftp_seek64(sshc->sftp_handle, (libssh2_uint64_t)from); + } + data->req.size = size; + data->req.maxdownload = size; + Curl_pgrsSetDownloadSize(data, size); + } + + /* We can resume if we can seek to the resume position */ + if(data->state.resume_from) { + if(data->state.resume_from < 0) { + /* We are supposed to download the last abs(from) bytes */ + if((curl_off_t)attrs.filesize < -data->state.resume_from) { + failf(data, "Offset (%" FMT_OFF_T ") was beyond file size (%" + FMT_OFF_T ")", + data->state.resume_from, (curl_off_t)attrs.filesize); + return CURLE_BAD_DOWNLOAD_RESUME; + } + /* download from where? */ + data->state.resume_from += attrs.filesize; + } + else { + if((curl_off_t)attrs.filesize < data->state.resume_from) { + failf(data, "Offset (%" FMT_OFF_T + ") was beyond file size (%" FMT_OFF_T ")", + data->state.resume_from, (curl_off_t)attrs.filesize); + return CURLE_BAD_DOWNLOAD_RESUME; + } + } + /* Now store the number of bytes we are expected to download */ + data->req.size = attrs.filesize - data->state.resume_from; + data->req.maxdownload = attrs.filesize - data->state.resume_from; + Curl_pgrsSetDownloadSize(data, attrs.filesize - data->state.resume_from); + libssh2_sftp_seek64(sshc->sftp_handle, + (libssh2_uint64_t)data->state.resume_from); + } + + /* Setup the actual download */ + if(data->req.size == 0) { + /* no data to transfer */ + Curl_xfer_setup_nop(data); + infof(data, "SSH: file already completely downloaded"); + myssh_to(data, sshc, SSH_STOP); + return CURLE_OK; + } + Curl_xfer_setup_recv(data, FIRSTSOCKET, data->req.size); + + /* not set by Curl_xfer_setup to preserve io_flags */ + data->conn->send_idx = 0; + + myssh_to(data, sshc, SSH_STOP); + + return CURLE_OK; +} + +static CURLcode sftp_readdir(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp, + bool *blockp) +{ + CURLcode result = CURLE_OK; + int rc = libssh2_sftp_readdir_ex(sshc->sftp_handle, + sshp->readdir_filename, CURL_PATH_MAX, + sshp->readdir_longentry, CURL_PATH_MAX, + &sshp->readdir_attrs); + if(rc == LIBSSH2_ERROR_EAGAIN) { + *blockp = TRUE; + return result; + } + if(rc > 0) { + size_t readdir_len = (size_t)rc; + sshp->readdir_filename[readdir_len] = '\0'; + + if(data->set.list_only) { + result = Curl_client_write(data, CLIENTWRITE_BODY, + sshp->readdir_filename, + readdir_len); + if(!result) + result = Curl_client_write(data, CLIENTWRITE_BODY, "\n", 1); + if(result) + return result; + } + else { + result = curlx_dyn_add(&sshp->readdir, sshp->readdir_longentry); + + if(!result) { + if((sshp->readdir_attrs.flags & LIBSSH2_SFTP_ATTR_PERMISSIONS) && + ((sshp->readdir_attrs.permissions & LIBSSH2_SFTP_S_IFMT) == + LIBSSH2_SFTP_S_IFLNK)) { + result = curlx_dyn_addf(&sshp->readdir_link, "%s%s", sshp->path, + sshp->readdir_filename); + myssh_to(data, sshc, SSH_SFTP_READDIR_LINK); + } + else { + myssh_to(data, sshc, SSH_SFTP_READDIR_BOTTOM); + } + } + return result; + } + } + else if(!rc) { + myssh_to(data, sshc, SSH_SFTP_READDIR_DONE); + } + else { + unsigned long sftperr = libssh2_sftp_last_error(sshc->sftp_session); + result = sftperr ? sftp_libssh2_error_to_CURLE(sftperr) : CURLE_SSH; + failf(data, "Could not open remote file for reading: %s :: %d", + sftp_libssh2_strerror(sftperr), + libssh2_session_last_errno(sshc->ssh_session)); + myssh_to(data, sshc, SSH_SFTP_CLOSE); + } + return result; +} + +static CURLcode ssh_state_init(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + CURLcode result; + sshc->secondCreateDirs = 0; + sshc->nextstate = SSH_NO_STATE; + + /* Set libssh2 to non-blocking, since everything internally is + non-blocking */ + libssh2_session_set_blocking(sshc->ssh_session, 0); + + result = ssh_force_knownhost_key_type(data, sshc); + if(result) + myssh_to(data, sshc, SSH_SESSION_FREE); + else + myssh_to(data, sshc, SSH_S_STARTUP); + return result; +} + +static CURLcode ssh_state_startup(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + struct connectdata *conn = data->conn; + int rc = libssh2_session_handshake(sshc->ssh_session, + conn->sock[FIRSTSOCKET]); + if(rc == LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + + if(rc) { + char *err_msg = NULL; + (void)libssh2_session_last_error(sshc->ssh_session, &err_msg, NULL, 0); + failf(data, "Failure establishing ssh session: %d, %s", rc, err_msg); + + myssh_to(data, sshc, SSH_SESSION_FREE); + return CURLE_FAILED_INIT; + } + + myssh_to(data, sshc, SSH_HOSTKEY); + return CURLE_OK; +} + +static CURLcode ssh_state_hostkey(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + /* + * Before we authenticate we should check the hostkey's fingerprint + * against our known hosts. How that is handled (reading from file, + * whatever) is up to us. + */ + CURLcode result = ssh_check_fingerprint(data, sshc); + if(!result) + myssh_to(data, sshc, SSH_AUTHLIST); + return result; +} + +static CURLcode ssh_state_authlist(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + /* + * Figure out authentication methods + * NB: As soon as we have provided a username to an openssh server we + * must never change it later. Thus, always specify the correct username + * here, even though the libssh2 docs kind of indicate that it should be + * possible to get a 'generic' list (not user-specific) of authentication + * methods, presumably with a blank username. That does not work in my + * experience. + * Therefore always specify it here. + */ + struct connectdata *conn = data->conn; + const char *user = Curl_creds_user(conn->creds); + sshc->authlist = libssh2_userauth_list(sshc->ssh_session, + user, curlx_uztoui(strlen(user))); + + if(!sshc->authlist) { + int rc; + if(libssh2_userauth_authenticated(sshc->ssh_session)) { + sshc->authed = TRUE; + infof(data, "SSH: user accepted with no authentication"); + myssh_to(data, sshc, SSH_AUTH_DONE); + return CURLE_OK; + } + rc = libssh2_session_last_errno(sshc->ssh_session); + if(rc == LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + + myssh_to(data, sshc, SSH_SESSION_FREE); + return libssh2_session_error_to_CURLE(rc); + } + infof(data, "SSH: host offers authentication via: %s", sshc->authlist); + + myssh_to(data, sshc, SSH_AUTH_PKEY_INIT); + return CURLE_OK; +} + +static CURLcode ssh_state_auth_pkey(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + /* The function below checks if the files exists, no need to stat() here. + */ + struct connectdata *conn = data->conn; + const char *user = Curl_creds_user(conn->creds); + int rc = + libssh2_userauth_publickey_fromfile_ex(sshc->ssh_session, + user, + curlx_uztoui(strlen(user)), + sshc->rsa_pub, + sshc->rsa, sshc->passphrase); + if(rc == LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + + curlx_safefree(sshc->rsa_pub); + curlx_safefree(sshc->rsa); + + if(rc == 0) { + sshc->authed = TRUE; + infof(data, "SSH: authenticated via publickey"); + myssh_to(data, sshc, SSH_AUTH_DONE); + } + else { + char *err_msg = NULL; + char unknown[] = "Reason unknown (-1)"; + if(rc == -1) { + /* No error message has been set and the last set error message, if + any, is from a previous error so ignore it. #11837 */ + err_msg = unknown; + } + else { + (void)libssh2_session_last_error(sshc->ssh_session, &err_msg, NULL, 0); + } + infof(data, "SSH: publickey authentication denied: %s", err_msg); + myssh_to(data, sshc, SSH_AUTH_PASS_INIT); + } + return CURLE_OK; +} + +static CURLcode ssh_state_auth_pass_init(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + if((data->set.ssh_auth_types & CURLSSH_AUTH_PASSWORD) && + strstr(sshc->authlist, "password")) { + myssh_to(data, sshc, SSH_AUTH_PASS); + } + else { + myssh_to(data, sshc, SSH_AUTH_HOST_INIT); + } + return CURLE_OK; +} + +static CURLcode ssh_state_auth_pass(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + struct connectdata *conn = data->conn; + const char *user = Curl_creds_user(conn->creds); + const char *passwd = Curl_creds_passwd(conn->creds); + int rc = + libssh2_userauth_password_ex(sshc->ssh_session, user, + curlx_uztoui(strlen(user)), + passwd, + curlx_uztoui(strlen(passwd)), + NULL); + if(rc == LIBSSH2_ERROR_EAGAIN) { + return CURLE_AGAIN; + } + if(rc == 0) { + sshc->authed = TRUE; + infof(data, "SSH: initialized password authentication"); + myssh_to(data, sshc, SSH_AUTH_DONE); + } + else { + myssh_to(data, sshc, SSH_AUTH_HOST_INIT); + } + return CURLE_OK; +} + +static CURLcode ssh_state_auth_host_init(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + if((data->set.ssh_auth_types & CURLSSH_AUTH_HOST) && + strstr(sshc->authlist, "hostbased")) { + myssh_to(data, sshc, SSH_AUTH_HOST); + } + else { + myssh_to(data, sshc, SSH_AUTH_AGENT_INIT); + } + return CURLE_OK; +} + +static CURLcode ssh_state_auth_agent_init(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + int rc = 0; + if((data->set.ssh_auth_types & CURLSSH_AUTH_AGENT) && + strstr(sshc->authlist, "publickey")) { + + infof(data, "SSH: trying publickey authentication via agent"); + /* Connect to the ssh-agent */ + /* The agent could be shared by a curl thread i believe + but nothing obvious as keys can be added/removed at any time */ + if(!sshc->ssh_agent) { + sshc->ssh_agent = libssh2_agent_init(sshc->ssh_session); + if(!sshc->ssh_agent) { + infof(data, "SSH: could not create agent object"); + + myssh_to(data, sshc, SSH_AUTH_KEY_INIT); + return CURLE_OK; + } + } + + rc = libssh2_agent_connect(sshc->ssh_agent); + if(rc == LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + if(rc < 0) { + infof(data, "SSH: failure connecting to agent"); + myssh_to(data, sshc, SSH_AUTH_KEY_INIT); + } + else { + myssh_to(data, sshc, SSH_AUTH_AGENT_LIST); + } + } + else + myssh_to(data, sshc, SSH_AUTH_KEY_INIT); + return CURLE_OK; +} + +static CURLcode ssh_state_auth_agent_list(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + int rc = libssh2_agent_list_identities(sshc->ssh_agent); + + if(rc == LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + if(rc < 0) { + infof(data, "SSH: failure requesting identities to agent"); + myssh_to(data, sshc, SSH_AUTH_KEY_INIT); + } + else { + myssh_to(data, sshc, SSH_AUTH_AGENT); + sshc->sshagent_prev_identity = NULL; + } + return CURLE_OK; +} + +static CURLcode ssh_state_auth_agent(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + /* as prev_identity evolves only after an identity user auth finished we + can safely request it again as long as EAGAIN is returned here or by + libssh2_agent_userauth */ + int rc = libssh2_agent_get_identity(sshc->ssh_agent, + &sshc->sshagent_identity, + sshc->sshagent_prev_identity); + if(rc == LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + + if(rc == 0) { + CURL_TRC_SSH(data, "[SSH_AUTH_AGENT_LIST] auth user '%s' for key '%s'", + Curl_creds_user(data->conn->creds), + sshc->sshagent_identity->comment); + rc = libssh2_agent_userauth(sshc->ssh_agent, + Curl_creds_user(data->conn->creds), + sshc->sshagent_identity); + + if(rc < 0) { + if(rc != LIBSSH2_ERROR_EAGAIN) { + /* tried and failed? go to next identity */ + sshc->sshagent_prev_identity = sshc->sshagent_identity; + return CURLE_OK; + } + return CURLE_AGAIN; + } + } + + if(rc < 0) + infof(data, "SSH: failure requesting identities to agent"); + else if(rc == 1) + infof(data, "SSH: no agent identity would match"); + + if(rc == LIBSSH2_ERROR_NONE) { + sshc->authed = TRUE; + infof(data, "SSH: agent authenticated user '%s' with key '%s'", + Curl_creds_user(data->conn->creds), + sshc->sshagent_identity->comment); + myssh_to(data, sshc, SSH_AUTH_DONE); + } + else { + myssh_to(data, sshc, SSH_AUTH_KEY_INIT); + } + return CURLE_OK; +} + +static CURLcode ssh_state_auth_key_init(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + if((data->set.ssh_auth_types & CURLSSH_AUTH_KEYBOARD) && + strstr(sshc->authlist, "keyboard-interactive")) { + myssh_to(data, sshc, SSH_AUTH_KEY); + } + else { + myssh_to(data, sshc, SSH_AUTH_DONE); + } + return CURLE_OK; +} + +static CURLcode ssh_state_auth_key(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + /* Authentication failed. Continue with keyboard-interactive now. */ + struct connectdata *conn = data->conn; + const char *user = Curl_creds_user(conn->creds); + int rc = + libssh2_userauth_keyboard_interactive_ex(sshc->ssh_session, + user, curlx_uztoui(strlen(user)), + &kbd_callback); + if(rc == LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + + if(rc == 0) { + sshc->authed = TRUE; + infof(data, "SSH: initialized keyboard interactive authentication"); + myssh_to(data, sshc, SSH_AUTH_DONE); + return CURLE_OK; + } + return CURLE_LOGIN_DENIED; +} + +static CURLcode ssh_state_auth_done(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + struct connectdata *conn = data->conn; + if(!sshc->authed) { + failf(data, "Authentication failure"); + myssh_to(data, sshc, SSH_SESSION_FREE); + return CURLE_LOGIN_DENIED; + } + + /* + * At this point we have an authenticated ssh session. + */ + infof(data, "SSH: authentication complete"); + + Curl_pgrsTime(data, TIMER_APPCONNECT); /* SSH is connected */ + + data->conn->recv_idx = FIRSTSOCKET; + conn->send_idx = -1; + + if(conn->scheme->protocol == CURLPROTO_SFTP) { + myssh_to(data, sshc, SSH_SFTP_INIT); + return CURLE_OK; + } + infof(data, "SSH: connection established"); + myssh_to(data, sshc, SSH_STOP); + return CURLE_OK; +} + +static CURLcode ssh_state_sftp_init(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + /* + * Start the libssh2 sftp session + */ + sshc->sftp_session = libssh2_sftp_init(sshc->ssh_session); + if(!sshc->sftp_session) { + char *err_msg = NULL; + if(libssh2_session_last_errno(sshc->ssh_session) == + LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + + (void)libssh2_session_last_error(sshc->ssh_session, &err_msg, NULL, 0); + failf(data, "Failure initializing sftp session: %s", err_msg); + myssh_to(data, sshc, SSH_SESSION_FREE); + return CURLE_FAILED_INIT; + } + myssh_to(data, sshc, SSH_SFTP_REALPATH); + return CURLE_OK; +} + +static CURLcode ssh_state_sftp_realpath(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp) +{ + /* + * Get the "home" directory + */ + int rc; + + if(!sshp) + return CURLE_FAILED_INIT; + + rc = libssh2_sftp_symlink_ex(sshc->sftp_session, ".", + curlx_uztoui(strlen(".")), + sshp->readdir_filename, CURL_PATH_MAX, + LIBSSH2_SFTP_REALPATH); + if(rc == LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + + myssh_to(data, sshc, SSH_STOP); + if(rc > 0) { + curlx_free(sshc->homedir); + sshc->homedir = curlx_strdup(sshp->readdir_filename); + if(!sshc->homedir) + return CURLE_OUT_OF_MEMORY; + curlx_free(data->state.most_recent_ftp_entrypath); + data->state.most_recent_ftp_entrypath = curlx_strdup(sshc->homedir); + if(!data->state.most_recent_ftp_entrypath) + return CURLE_OUT_OF_MEMORY; + } + else { + /* Return the error type */ + unsigned long sftperr = libssh2_sftp_last_error(sshc->sftp_session); + CURLcode result; + if(sftperr) + result = sftp_libssh2_error_to_CURLE(sftperr); + else + /* in this case, the error was not in the SFTP level but for example a + time-out or similar */ + result = CURLE_SSH; + CURL_TRC_SSH(data, "error = %lu makes libcurl = %d", sftperr, (int)result); + return result; + } + + /* This is the last step in the SFTP connect phase. Do note that while we + get the homedir here, we get the "workingpath" in the DO action since the + homedir remains the same between request but the working path does not. */ + CURL_TRC_SSH(data, "CONNECT phase done"); + return CURLE_OK; +} + +static CURLcode ssh_state_sftp_quote_init(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp) +{ + CURLcode result; + + if(!sshp) + return CURLE_FAILED_INIT; + + result = Curl_getworkingpath(data, sshc->homedir, &sshp->path); + if(result) { + myssh_to(data, sshc, SSH_STOP); + return result; + } + + if(data->set.quote) { + infof(data, "SSH: sending quote commands"); + sshc->quote_item = data->set.quote; + myssh_to(data, sshc, SSH_SFTP_QUOTE); + } + else { + myssh_to(data, sshc, SSH_SFTP_GETINFO); + } + return CURLE_OK; +} + +static CURLcode ssh_state_sftp_postquote_init(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + if(data->set.postquote) { + infof(data, "SSH: sending quote commands"); + sshc->quote_item = data->set.postquote; + myssh_to(data, sshc, SSH_SFTP_QUOTE); + } + else { + myssh_to(data, sshc, SSH_STOP); + } + return CURLE_OK; +} + +static CURLcode ssh_state_sftp_quote(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp) +{ + /* Send quote commands */ + CURLcode result; + + if(!sshp) + return CURLE_FAILED_INIT; + + result = sftp_quote(data, sshc, sshp); + if(result) { + myssh_to(data, sshc, SSH_SFTP_CLOSE); + sshc->nextstate = SSH_NO_STATE; + } + return result; +} + +static CURLcode ssh_state_sftp_next_quote(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + curlx_safefree(sshc->quote_path1); + curlx_safefree(sshc->quote_path2); + + sshc->quote_item = sshc->quote_item->next; + + if(sshc->quote_item) { + myssh_to(data, sshc, SSH_SFTP_QUOTE); + } + else { + if(sshc->nextstate != SSH_NO_STATE) { + myssh_to(data, sshc, sshc->nextstate); + sshc->nextstate = SSH_NO_STATE; + } + else { + myssh_to(data, sshc, SSH_SFTP_GETINFO); + } + } + return CURLE_OK; +} + +static CURLcode ssh_state_sftp_quote_stat(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp, + bool *blockp) +{ + CURLcode result; + + if(!sshp) + return CURLE_FAILED_INIT; + + result = sftp_quote_stat(data, sshc, sshp, blockp); + if(result) { + myssh_to(data, sshc, SSH_SFTP_CLOSE); + sshc->nextstate = SSH_NO_STATE; + } + return result; +} + +static CURLcode ssh_state_sftp_quote_setstat(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp) +{ + int rc; + + if(!sshp) + return CURLE_FAILED_INIT; + + rc = libssh2_sftp_stat_ex(sshc->sftp_session, sshc->quote_path2, + curlx_uztoui(strlen(sshc->quote_path2)), + LIBSSH2_SFTP_SETSTAT, + &sshp->quote_attrs); + if(rc == LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + + if(rc && !sshc->acceptfail) { + unsigned long sftperr = libssh2_sftp_last_error(sshc->sftp_session); + failf(data, "Attempt to set SFTP stats for \"%s\" failed: %s", + sshc->quote_path2, sftp_libssh2_strerror(sftperr)); + curlx_safefree(sshc->quote_path1); + curlx_safefree(sshc->quote_path2); + myssh_to(data, sshc, SSH_SFTP_CLOSE); + sshc->nextstate = SSH_NO_STATE; + return CURLE_QUOTE_ERROR; + } + myssh_to(data, sshc, SSH_SFTP_NEXT_QUOTE); + return CURLE_OK; +} + +static CURLcode ssh_state_sftp_quote_symlink(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + int rc = + libssh2_sftp_symlink_ex(sshc->sftp_session, sshc->quote_path1, + curlx_uztoui(strlen(sshc->quote_path1)), + sshc->quote_path2, + curlx_uztoui(strlen(sshc->quote_path2)), + LIBSSH2_SFTP_SYMLINK); + if(rc == LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + + if(rc && !sshc->acceptfail) { + unsigned long sftperr = libssh2_sftp_last_error(sshc->sftp_session); + failf(data, "symlink \"%s\" to \"%s\" failed: %s", + sshc->quote_path1, sshc->quote_path2, + sftp_libssh2_strerror(sftperr)); + curlx_safefree(sshc->quote_path1); + curlx_safefree(sshc->quote_path2); + myssh_to(data, sshc, SSH_SFTP_CLOSE); + sshc->nextstate = SSH_NO_STATE; + return CURLE_QUOTE_ERROR; + } + myssh_to(data, sshc, SSH_SFTP_NEXT_QUOTE); + return CURLE_OK; +} + +static CURLcode ssh_state_sftp_quote_mkdir(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + int rc = libssh2_sftp_mkdir_ex(sshc->sftp_session, sshc->quote_path1, + curlx_uztoui(strlen(sshc->quote_path1)), + (long)data->set.new_directory_perms); + if(rc == LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + + if(rc && !sshc->acceptfail) { + unsigned long sftperr = libssh2_sftp_last_error(sshc->sftp_session); + failf(data, "mkdir \"%s\" failed: %s", + sshc->quote_path1, sftp_libssh2_strerror(sftperr)); + curlx_safefree(sshc->quote_path1); + myssh_to(data, sshc, SSH_SFTP_CLOSE); + sshc->nextstate = SSH_NO_STATE; + return CURLE_QUOTE_ERROR; + } + myssh_to(data, sshc, SSH_SFTP_NEXT_QUOTE); + return CURLE_OK; +} + +static CURLcode ssh_state_sftp_quote_rename(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + int rc = + libssh2_sftp_rename_ex(sshc->sftp_session, sshc->quote_path1, + curlx_uztoui(strlen(sshc->quote_path1)), + sshc->quote_path2, + curlx_uztoui(strlen(sshc->quote_path2)), + LIBSSH2_SFTP_RENAME_OVERWRITE | + LIBSSH2_SFTP_RENAME_ATOMIC | + LIBSSH2_SFTP_RENAME_NATIVE); + + if(rc == LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + + if(rc && !sshc->acceptfail) { + unsigned long sftperr = libssh2_sftp_last_error(sshc->sftp_session); + failf(data, "rename \"%s\" to \"%s\" failed: %s", + sshc->quote_path1, sshc->quote_path2, + sftp_libssh2_strerror(sftperr)); + curlx_safefree(sshc->quote_path1); + curlx_safefree(sshc->quote_path2); + myssh_to(data, sshc, SSH_SFTP_CLOSE); + sshc->nextstate = SSH_NO_STATE; + return CURLE_QUOTE_ERROR; + } + myssh_to(data, sshc, SSH_SFTP_NEXT_QUOTE); + return CURLE_OK; +} + +static CURLcode ssh_state_sftp_quote_rmdir(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + int rc = libssh2_sftp_rmdir_ex(sshc->sftp_session, sshc->quote_path1, + curlx_uztoui(strlen(sshc->quote_path1))); + if(rc == LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + + if(rc && !sshc->acceptfail) { + unsigned long sftperr = libssh2_sftp_last_error(sshc->sftp_session); + failf(data, "rmdir \"%s\" failed: %s", + sshc->quote_path1, sftp_libssh2_strerror(sftperr)); + curlx_safefree(sshc->quote_path1); + myssh_to(data, sshc, SSH_SFTP_CLOSE); + sshc->nextstate = SSH_NO_STATE; + return CURLE_QUOTE_ERROR; + } + myssh_to(data, sshc, SSH_SFTP_NEXT_QUOTE); + return CURLE_OK; +} + +static CURLcode ssh_state_sftp_quote_unlink(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + int rc = libssh2_sftp_unlink_ex(sshc->sftp_session, sshc->quote_path1, + curlx_uztoui(strlen(sshc->quote_path1))); + if(rc == LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + + if(rc && !sshc->acceptfail) { + unsigned long sftperr = libssh2_sftp_last_error(sshc->sftp_session); + failf(data, "rm \"%s\" failed: %s", + sshc->quote_path1, sftp_libssh2_strerror(sftperr)); + curlx_safefree(sshc->quote_path1); + myssh_to(data, sshc, SSH_SFTP_CLOSE); + sshc->nextstate = SSH_NO_STATE; + return CURLE_QUOTE_ERROR; + } + myssh_to(data, sshc, SSH_SFTP_NEXT_QUOTE); + return CURLE_OK; +} + +static CURLcode ssh_state_sftp_quote_statvfs(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + LIBSSH2_SFTP_STATVFS statvfs; + int rc = libssh2_sftp_statvfs(sshc->sftp_session, sshc->quote_path1, + curlx_uztoui(strlen(sshc->quote_path1)), + &statvfs); + + if(rc == LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + + if(rc && !sshc->acceptfail) { + unsigned long sftperr = libssh2_sftp_last_error(sshc->sftp_session); + failf(data, "statvfs \"%s\" failed: %s", + sshc->quote_path1, sftp_libssh2_strerror(sftperr)); + curlx_safefree(sshc->quote_path1); + myssh_to(data, sshc, SSH_SFTP_CLOSE); + sshc->nextstate = SSH_NO_STATE; + return CURLE_QUOTE_ERROR; + } + else if(rc == 0) { +#ifdef _MSC_VER +#define CURL_LIBSSH2_VFS_SIZE_MASK "I64u" +#else +#define CURL_LIBSSH2_VFS_SIZE_MASK "llu" +#endif + CURLcode result; + char *tmp = curl_maprintf("statvfs:\n" + "f_bsize: %" CURL_LIBSSH2_VFS_SIZE_MASK "\n" + "f_frsize: %" CURL_LIBSSH2_VFS_SIZE_MASK "\n" + "f_blocks: %" CURL_LIBSSH2_VFS_SIZE_MASK "\n" + "f_bfree: %" CURL_LIBSSH2_VFS_SIZE_MASK "\n" + "f_bavail: %" CURL_LIBSSH2_VFS_SIZE_MASK "\n" + "f_files: %" CURL_LIBSSH2_VFS_SIZE_MASK "\n" + "f_ffree: %" CURL_LIBSSH2_VFS_SIZE_MASK "\n" + "f_favail: %" CURL_LIBSSH2_VFS_SIZE_MASK "\n" + "f_fsid: %" CURL_LIBSSH2_VFS_SIZE_MASK "\n" + "f_flag: %" CURL_LIBSSH2_VFS_SIZE_MASK "\n" + "f_namemax: %" CURL_LIBSSH2_VFS_SIZE_MASK "\n", + statvfs.f_bsize, statvfs.f_frsize, + statvfs.f_blocks, statvfs.f_bfree, + statvfs.f_bavail, statvfs.f_files, + statvfs.f_ffree, statvfs.f_favail, + statvfs.f_fsid, statvfs.f_flag, + statvfs.f_namemax); + if(!tmp) { + myssh_to(data, sshc, SSH_SFTP_CLOSE); + sshc->nextstate = SSH_NO_STATE; + return CURLE_OUT_OF_MEMORY; + } + + result = Curl_client_write(data, CLIENTWRITE_HEADER, tmp, strlen(tmp)); + curlx_free(tmp); + if(result) { + myssh_to(data, sshc, SSH_SFTP_CLOSE); + sshc->nextstate = SSH_NO_STATE; + return result; + } + } + myssh_to(data, sshc, SSH_SFTP_NEXT_QUOTE); + return CURLE_OK; +} + +static CURLcode ssh_state_sftp_create_dirs_mkdir(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp) +{ + /* 'mode' - parameter is preliminary - default to 0644 */ + int rc; + + if(!sshp) + return CURLE_FAILED_INIT; + + rc = libssh2_sftp_mkdir_ex(sshc->sftp_session, sshp->path, + curlx_uztoui(strlen(sshp->path)), + (long)data->set.new_directory_perms); + if(rc == LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + + *sshc->slash_pos = '/'; + ++sshc->slash_pos; + if(rc < 0) { + /* + * Abort if failure was not that the directory already exists or + * the permission was denied (creation might succeed further down + * the path) - retry on unspecific FAILURE also + */ + unsigned long sftperr = libssh2_sftp_last_error(sshc->sftp_session); + if((sftperr != LIBSSH2_FX_FILE_ALREADY_EXISTS) && + (sftperr != LIBSSH2_FX_FAILURE) && + (sftperr != LIBSSH2_FX_PERMISSION_DENIED)) { + myssh_to(data, sshc, SSH_SFTP_CLOSE); + return sftp_libssh2_error_to_CURLE(sftperr); + } + } + myssh_to(data, sshc, SSH_SFTP_CREATE_DIRS); + return CURLE_OK; +} + +static CURLcode ssh_state_sftp_readdir_init(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp) +{ + if(!sshp) + return CURLE_FAILED_INIT; + + Curl_pgrsSetDownloadSize(data, -1); + if(data->req.no_body) { + myssh_to(data, sshc, SSH_STOP); + return CURLE_OK; + } + + /* + * This is a directory that we are trying to get, so produce a directory + * listing + */ + sshc->sftp_handle = + libssh2_sftp_open_ex(sshc->sftp_session, sshp->path, + curlx_uztoui(strlen(sshp->path)), + 0, 0, LIBSSH2_SFTP_OPENDIR); + if(!sshc->sftp_handle) { + unsigned long sftperr; + if(libssh2_session_last_errno(sshc->ssh_session) == LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + + sftperr = libssh2_sftp_last_error(sshc->sftp_session); + failf(data, "Could not open directory for reading: %s", + sftp_libssh2_strerror(sftperr)); + myssh_to(data, sshc, SSH_SFTP_CLOSE); + return sftp_libssh2_error_to_CURLE(sftperr); + } + myssh_to(data, sshc, SSH_SFTP_READDIR); + return CURLE_OK; +} + +static CURLcode ssh_state_sftp_readdir_link(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp) +{ + CURLcode result; + int rc; + if(!sshp) + return CURLE_FAILED_INIT; + + rc = libssh2_sftp_symlink_ex(sshc->sftp_session, + curlx_dyn_ptr(&sshp->readdir_link), + (unsigned int) + curlx_dyn_len(&sshp->readdir_link), + sshp->readdir_filename, + CURL_PATH_MAX, LIBSSH2_SFTP_READLINK); + if(rc == LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + + curlx_dyn_free(&sshp->readdir_link); + + if(rc < 0) + return CURLE_OUT_OF_MEMORY; + + /* append filename and extra output */ + result = curlx_dyn_addf(&sshp->readdir, " -> %s", sshp->readdir_filename); + if(result) + myssh_to(data, sshc, SSH_SFTP_CLOSE); + else + myssh_to(data, sshc, SSH_SFTP_READDIR_BOTTOM); + return result; +} + +static CURLcode ssh_state_scp_download_init(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp) +{ + curl_off_t bytecount; + libssh2_struct_stat sb; + + if(!sshp) + return CURLE_FAILED_INIT; + /* + * We must check the remote file; if it is a directory no values are + * be set in sb + */ + + /* + * If support for >2GB files exists, use it. + */ + + /* get a fresh new channel from the ssh layer */ + memset(&sb, 0, sizeof(libssh2_struct_stat)); + sshc->ssh_channel = libssh2_scp_recv2(sshc->ssh_session, sshp->path, &sb); + if(!sshc->ssh_channel) { + int ssh_err; + char *err_msg = NULL; + + if(libssh2_session_last_errno(sshc->ssh_session) == + LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + + ssh_err = libssh2_session_last_error(sshc->ssh_session, &err_msg, NULL, 0); + failf(data, "%s", err_msg); + myssh_to(data, sshc, SSH_SCP_CHANNEL_FREE); + return libssh2_session_error_to_CURLE(ssh_err); + } + + /* download data */ + bytecount = (curl_off_t)sb.st_size; + data->req.maxdownload = (curl_off_t)sb.st_size; + Curl_xfer_setup_recv(data, FIRSTSOCKET, bytecount); + + /* not set by Curl_xfer_setup to preserve io_flags */ + data->conn->send_idx = 0; + + myssh_to(data, sshc, SSH_STOP); + return CURLE_OK; +} + +static CURLcode ssh_state_sftp_close(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp) +{ + int rc = 0; + if(!sshp) + return CURLE_FAILED_INIT; + if(sshc->sftp_handle) { + rc = libssh2_sftp_close(sshc->sftp_handle); + if(rc == LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + + if(rc < 0) { + char *err_msg = NULL; + (void)libssh2_session_last_error(sshc->ssh_session, &err_msg, NULL, 0); + infof(data, "Failed to close libssh2 file: %d %s", rc, err_msg); + } + sshc->sftp_handle = NULL; + } + + curlx_safefree(sshp->path); + + CURL_TRC_SSH(data, "SFTP DONE done"); + + /* Check if nextstate is set and move .nextstate could be POSTQUOTE_INIT + After nextstate is executed, the control should come back to + SSH_SFTP_CLOSE to pass the correct result back */ + if(sshc->nextstate != SSH_NO_STATE && + sshc->nextstate != SSH_SFTP_CLOSE) { + myssh_to(data, sshc, sshc->nextstate); + sshc->nextstate = SSH_SFTP_CLOSE; + } + else + myssh_to(data, sshc, SSH_STOP); + + return CURLE_OK; +} + +static CURLcode ssh_state_sftp_shutdown(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + /* during times we get here due to a broken transfer and then the + sftp_handle might not have been taken down so make sure that is done + before we proceed */ + int rc = 0; + if(sshc->sftp_handle) { + rc = libssh2_sftp_close(sshc->sftp_handle); + if(rc == LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + + if(rc < 0) { + char *err_msg = NULL; + (void)libssh2_session_last_error(sshc->ssh_session, &err_msg, NULL, 0); + infof(data, "Failed to close libssh2 file: %d %s", rc, err_msg); + } + sshc->sftp_handle = NULL; + } + if(sshc->sftp_session) { + rc = libssh2_sftp_shutdown(sshc->sftp_session); + if(rc == LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + + if(rc < 0) { + infof(data, "Failed to stop libssh2 sftp subsystem"); + } + sshc->sftp_session = NULL; + } + + curlx_safefree(sshc->homedir); + + myssh_to(data, sshc, SSH_SESSION_DISCONNECT); + return CURLE_OK; +} + +static CURLcode ssh_state_sftp_download_init(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp) +{ + if(!sshp) + return CURLE_FAILED_INIT; + /* + * Work on getting the specified file + */ + sshc->sftp_handle = + libssh2_sftp_open_ex(sshc->sftp_session, sshp->path, + curlx_uztoui(strlen(sshp->path)), + LIBSSH2_FXF_READ, (long)data->set.new_file_perms, + LIBSSH2_SFTP_OPENFILE); + if(!sshc->sftp_handle) { + unsigned long sftperr; + if(libssh2_session_last_errno(sshc->ssh_session) == + LIBSSH2_ERROR_EAGAIN) { + return CURLE_AGAIN; + } + sftperr = libssh2_sftp_last_error(sshc->sftp_session); + failf(data, "Could not open remote file for reading: %s", + sftp_libssh2_strerror(sftperr)); + myssh_to(data, sshc, SSH_SFTP_CLOSE); + return sftp_libssh2_error_to_CURLE(sftperr); + } + myssh_to(data, sshc, SSH_SFTP_DOWNLOAD_STAT); + return CURLE_OK; +} + +static CURLcode ssh_state_scp_upload_init(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp) +{ + if(!sshp) + return CURLE_FAILED_INIT; + /* + * libssh2 requires that the destination path is a full path that + * includes the destination file and name OR ends in a "/" . If this is + * not done the destination file is named the same name as the last + * directory in the path. + */ + sshc->ssh_channel = + libssh2_scp_send64(sshc->ssh_session, sshp->path, + (int)data->set.new_file_perms, + (libssh2_int64_t)data->state.infilesize, 0, 0); + if(!sshc->ssh_channel) { + int ssh_err; + char *err_msg = NULL; + CURLcode result; + if(libssh2_session_last_errno(sshc->ssh_session) == + LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + + ssh_err = libssh2_session_last_error(sshc->ssh_session, &err_msg, NULL, 0); + failf(data, "%s", err_msg); + myssh_to(data, sshc, SSH_SCP_CHANNEL_FREE); + result = libssh2_session_error_to_CURLE(ssh_err); + + /* Map generic errors to upload failed */ + if(result == CURLE_SSH || + result == CURLE_REMOTE_FILE_NOT_FOUND) + result = CURLE_UPLOAD_FAILED; + return result; + } + + /* upload data */ + data->req.size = data->state.infilesize; + Curl_pgrsSetUploadSize(data, data->state.infilesize); + Curl_xfer_setup_send(data, FIRSTSOCKET); + + /* not set by Curl_xfer_setup to preserve io_flags */ + data->conn->recv_idx = FIRSTSOCKET; + + myssh_to(data, sshc, SSH_STOP); + + return CURLE_OK; +} + +static CURLcode ssh_state_session_disconnect(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + /* during weird times when we have been prematurely aborted, the channel + is still alive when we reach this state and we MUST kill the channel + properly first */ + int rc = 0; + if(sshc->ssh_channel) { + rc = libssh2_channel_free(sshc->ssh_channel); + if(rc == LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + + if(rc < 0) { + char *err_msg = NULL; + (void)libssh2_session_last_error(sshc->ssh_session, &err_msg, NULL, 0); + infof(data, "Failed to free libssh2 scp subsystem: %d %s", rc, err_msg); + } + sshc->ssh_channel = NULL; + } + + if(sshc->ssh_session) { + rc = libssh2_session_disconnect(sshc->ssh_session, "Shutdown"); + if(rc == LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + + if(rc < 0) { + char *err_msg = NULL; + (void)libssh2_session_last_error(sshc->ssh_session, &err_msg, NULL, 0); + infof(data, "Failed to disconnect libssh2 session: %d %s", rc, err_msg); + } + } + + curlx_safefree(sshc->homedir); + + myssh_to(data, sshc, SSH_SESSION_FREE); + return CURLE_OK; +} + +static CURLcode sshc_cleanup(struct ssh_conn *sshc, struct Curl_easy *data, + bool block) +{ + int rc; + + if(sshc->kh) { + libssh2_knownhost_free(sshc->kh); + sshc->kh = NULL; + } + + if(sshc->ssh_agent) { + rc = libssh2_agent_disconnect(sshc->ssh_agent); + if((rc < 0) && data) { + char *err_msg = NULL; + (void)libssh2_session_last_error(sshc->ssh_session, &err_msg, NULL, 0); + infof(data, "Failed to disconnect from libssh2 agent: %d %s", + rc, err_msg); + } + if(!block && (rc == LIBSSH2_ERROR_EAGAIN)) + return CURLE_AGAIN; + + libssh2_agent_free(sshc->ssh_agent); + sshc->ssh_agent = NULL; + + /* NB: there is no need to free identities, they are part of internal + agent stuff */ + sshc->sshagent_identity = NULL; + sshc->sshagent_prev_identity = NULL; + } + + if(sshc->sftp_handle) { + rc = libssh2_sftp_close(sshc->sftp_handle); + if((rc < 0) && data) { + char *err_msg = NULL; + (void)libssh2_session_last_error(sshc->ssh_session, &err_msg, NULL, 0); + infof(data, "Failed to close libssh2 file: %d %s", rc, err_msg); + } + if(!block && (rc == LIBSSH2_ERROR_EAGAIN)) + return CURLE_AGAIN; + + sshc->sftp_handle = NULL; + } + + if(sshc->ssh_channel) { + rc = libssh2_channel_free(sshc->ssh_channel); + if((rc < 0) && data) { + char *err_msg = NULL; + (void)libssh2_session_last_error(sshc->ssh_session, &err_msg, NULL, 0); + infof(data, "Failed to free libssh2 scp subsystem: %d %s", rc, err_msg); + } + if(!block && (rc == LIBSSH2_ERROR_EAGAIN)) + return CURLE_AGAIN; + + sshc->ssh_channel = NULL; + } + + if(sshc->sftp_session) { + rc = libssh2_sftp_shutdown(sshc->sftp_session); + if((rc < 0) && data) { + char *err_msg = NULL; + (void)libssh2_session_last_error(sshc->ssh_session, &err_msg, NULL, 0); + infof(data, "Failed to stop libssh2 sftp subsystem: %d %s", rc, err_msg); + } + if(!block && (rc == LIBSSH2_ERROR_EAGAIN)) + return CURLE_AGAIN; + + sshc->sftp_session = NULL; + } + + if(sshc->ssh_session) { + rc = libssh2_session_free(sshc->ssh_session); + if((rc < 0) && data) { + char *err_msg = NULL; + (void)libssh2_session_last_error(sshc->ssh_session, &err_msg, NULL, 0); + infof(data, "Failed to free libssh2 session: %d %s", rc, err_msg); + } + if(!block && (rc == LIBSSH2_ERROR_EAGAIN)) + return CURLE_AGAIN; + + sshc->ssh_session = NULL; + } + + /* worst-case scenario cleanup */ + DEBUGASSERT(!sshc->ssh_session); + DEBUGASSERT(!sshc->ssh_channel); + DEBUGASSERT(!sshc->sftp_session); + DEBUGASSERT(!sshc->sftp_handle); + DEBUGASSERT(!sshc->kh); + DEBUGASSERT(!sshc->ssh_agent); + + curlx_safefree(sshc->rsa_pub); + curlx_safefree(sshc->rsa); + curlx_safefree(sshc->quote_path1); + curlx_safefree(sshc->quote_path2); + curlx_safefree(sshc->homedir); + + return CURLE_OK; +} + +static CURLcode ssh_state_sftp_getinfo(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + if(data->set.get_filetime) + myssh_to(data, sshc, SSH_SFTP_FILETIME); + else + myssh_to(data, sshc, SSH_SFTP_TRANS_INIT); + return CURLE_OK; +} + +static CURLcode ssh_state_sftp_filetime(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp) +{ + LIBSSH2_SFTP_ATTRIBUTES attrs; + int rc; + + if(!sshp) + return CURLE_FAILED_INIT; + + rc = libssh2_sftp_stat_ex(sshc->sftp_session, sshp->path, + curlx_uztoui(strlen(sshp->path)), + LIBSSH2_SFTP_STAT, &attrs); + if(rc == LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + + if(rc == 0) + data->info.filetime = (time_t)attrs.mtime; + + myssh_to(data, sshc, SSH_SFTP_TRANS_INIT); + return CURLE_OK; +} + +static CURLcode ssh_state_sftp_trans_init(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp) +{ + if(data->state.upload) + myssh_to(data, sshc, SSH_SFTP_UPLOAD_INIT); + else if(sshp) { + size_t plen = strlen(sshp->path); + if(plen && (sshp->path[plen - 1] == '/')) + myssh_to(data, sshc, SSH_SFTP_READDIR_INIT); + else + myssh_to(data, sshc, SSH_SFTP_DOWNLOAD_INIT); + } + else + return CURLE_FAILED_INIT; + return CURLE_OK; +} + +static CURLcode ssh_state_sftp_upload_init(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp, + bool *block) +{ + CURLcode result; + if(!sshp) + return CURLE_FAILED_INIT; + result = sftp_upload_init(data, sshc, sshp, block); + if(result) { + myssh_to(data, sshc, SSH_SFTP_CLOSE); + sshc->nextstate = SSH_NO_STATE; + } + return result; +} + +static CURLcode ssh_state_sftp_create_dirs_init(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp) +{ + if(!sshp) + return CURLE_FAILED_INIT; + if(strlen(sshp->path) > 1) { + sshc->slash_pos = sshp->path + 1; /* ignore the leading '/' */ + myssh_to(data, sshc, SSH_SFTP_CREATE_DIRS); + } + else + myssh_to(data, sshc, SSH_SFTP_UPLOAD_INIT); + return CURLE_OK; +} + +static CURLcode ssh_state_sftp_create_dirs(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp) +{ + if(!sshp) + return CURLE_FAILED_INIT; + sshc->slash_pos = strchr(sshc->slash_pos, '/'); + if(sshc->slash_pos) { + *sshc->slash_pos = 0; + infof(data, "SFTP: creating directory '%s'", sshp->path); + myssh_to(data, sshc, SSH_SFTP_CREATE_DIRS_MKDIR); + return CURLE_OK; + } + myssh_to(data, sshc, SSH_SFTP_UPLOAD_INIT); + return CURLE_OK; +} + +static CURLcode ssh_state_sftp_readdir(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp, + bool *block) +{ + CURLcode result; + if(!sshp) + return CURLE_FAILED_INIT; + result = sftp_readdir(data, sshc, sshp, block); + if(result) + myssh_to(data, sshc, SSH_SFTP_CLOSE); + return result; +} + +static CURLcode ssh_state_sftp_readdir_bottom(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp) +{ + CURLcode result; + if(!sshp) + return CURLE_FAILED_INIT; + + result = curlx_dyn_addn(&sshp->readdir, "\n", 1); + if(!result) + result = Curl_client_write(data, CLIENTWRITE_BODY, + curlx_dyn_ptr(&sshp->readdir), + curlx_dyn_len(&sshp->readdir)); + if(result) { + curlx_dyn_free(&sshp->readdir); + myssh_to(data, sshc, SSH_STOP); + } + else { + curlx_dyn_reset(&sshp->readdir); + myssh_to(data, sshc, SSH_SFTP_READDIR); + } + return result; +} + +static CURLcode ssh_state_sftp_readdir_done(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + if(libssh2_sftp_closedir(sshc->sftp_handle) == + LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + + sshc->sftp_handle = NULL; + + /* no data to transfer */ + Curl_xfer_setup_nop(data); + myssh_to(data, sshc, SSH_STOP); + return CURLE_OK; +} + +static CURLcode ssh_state_sftp_download_stat(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp, + bool *block) +{ + CURLcode result; + if(!sshp) + return CURLE_FAILED_INIT; + result = sftp_download_stat(data, sshc, sshp, block); + if(result) { + myssh_to(data, sshc, SSH_SFTP_CLOSE); + sshc->nextstate = SSH_NO_STATE; + } + return result; +} + +static CURLcode ssh_state_scp_trans_init(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp) +{ + CURLcode result; + if(!sshp) + return CURLE_FAILED_INIT; + result = Curl_getworkingpath(data, sshc->homedir, + &sshp->path); + if(result) { + myssh_to(data, sshc, SSH_STOP); + return result; + } + + if(data->state.upload) { + if(data->state.infilesize < 0) { + failf(data, "SCP requires a known file size for upload"); + myssh_to(data, sshc, SSH_SCP_CHANNEL_FREE); + return CURLE_UPLOAD_FAILED; + } + myssh_to(data, sshc, SSH_SCP_UPLOAD_INIT); + } + else + myssh_to(data, sshc, SSH_SCP_DOWNLOAD_INIT); + return CURLE_OK; +} + +static CURLcode ssh_state_scp_done(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + if(data->state.upload) + myssh_to(data, sshc, SSH_SCP_SEND_EOF); + else + myssh_to(data, sshc, SSH_SCP_CHANNEL_FREE); + return CURLE_OK; +} + +static CURLcode ssh_state_scp_send_eof(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + if(sshc->ssh_channel) { + int rc = libssh2_channel_send_eof(sshc->ssh_channel); + if(rc == LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + if(rc) { + char *err_msg = NULL; + (void)libssh2_session_last_error(sshc->ssh_session, + &err_msg, NULL, 0); + infof(data, "Failed to send libssh2 channel EOF: %d %s", + rc, err_msg); + } + } + myssh_to(data, sshc, SSH_SCP_WAIT_EOF); + return CURLE_OK; +} + +static CURLcode ssh_state_scp_wait_eof(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + if(sshc->ssh_channel) { + int rc = libssh2_channel_wait_eof(sshc->ssh_channel); + if(rc == LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + if(rc) { + char *err_msg = NULL; + (void)libssh2_session_last_error(sshc->ssh_session, + &err_msg, NULL, 0); + infof(data, "Failed to get channel EOF: %d %s", rc, err_msg); + } + } + myssh_to(data, sshc, SSH_SCP_WAIT_CLOSE); + return CURLE_OK; +} + +static CURLcode ssh_state_scp_wait_close(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + if(sshc->ssh_channel) { + int rc = + libssh2_channel_wait_closed(sshc->ssh_channel); + if(rc == LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + if(rc) { + char *err_msg = NULL; + (void)libssh2_session_last_error(sshc->ssh_session, + &err_msg, NULL, 0); + infof(data, "Channel failed to close: %d %s", rc, err_msg); + } + } + myssh_to(data, sshc, SSH_SCP_CHANNEL_FREE); + return CURLE_OK; +} + +static CURLcode ssh_state_scp_channel_free( + struct Curl_easy *data, + struct ssh_conn *sshc) +{ + if(sshc->ssh_channel) { + int rc = libssh2_channel_free(sshc->ssh_channel); + if(rc == LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + if(rc < 0) { + char *err_msg = NULL; + (void)libssh2_session_last_error(sshc->ssh_session, + &err_msg, NULL, 0); + infof(data, "Failed to free libssh2 scp subsystem: %d %s", rc, err_msg); + } + sshc->ssh_channel = NULL; + } + CURL_TRC_SSH(data, "SCP DONE phase complete"); + myssh_to(data, sshc, SSH_STOP); + return CURLE_OK; +} + +static CURLcode ssh_state_session_free(struct Curl_easy *data, + struct ssh_conn *sshc) +{ + CURLcode result = sshc_cleanup(sshc, data, FALSE); + struct connectdata *conn = data->conn; + if(result) + return result; + memset(sshc, 0, sizeof(struct ssh_conn)); + connclose(conn, "SSH session free"); + sshc->state = SSH_SESSION_FREE; /* current */ + myssh_to(data, sshc, SSH_STOP); + return CURLE_OK; +} + +/* + * ssh_statemachine() runs the SSH state machine as far as it can without + * blocking and without reaching the end. The data the pointer 'block' points + * to is set to TRUE if the libssh2 function returns LIBSSH2_ERROR_EAGAIN + * meaning it wants to be called again when the socket is ready + */ +static CURLcode ssh_statemachine(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp, + bool *block) +{ + CURLcode result = CURLE_OK; + *block = 0; /* we are not blocking by default */ + + do { + switch(sshc->state) { + case SSH_INIT: + result = ssh_state_init(data, sshc); + if(result) + break; + FALLTHROUGH(); + + case SSH_S_STARTUP: + result = ssh_state_startup(data, sshc); + if(result) + break; + FALLTHROUGH(); + + case SSH_HOSTKEY: + result = ssh_state_hostkey(data, sshc); + break; + + case SSH_AUTHLIST: + result = ssh_state_authlist(data, sshc); + break; + + case SSH_AUTH_PKEY_INIT: + result = ssh_state_pkey_init(data, sshc); + break; + + case SSH_AUTH_PKEY: + result = ssh_state_auth_pkey(data, sshc); + break; + + case SSH_AUTH_PASS_INIT: + result = ssh_state_auth_pass_init(data, sshc); + break; + + case SSH_AUTH_PASS: + result = ssh_state_auth_pass(data, sshc); + break; + + case SSH_AUTH_HOST_INIT: + result = ssh_state_auth_host_init(data, sshc); + break; + + case SSH_AUTH_HOST: + myssh_to(data, sshc, SSH_AUTH_AGENT_INIT); + break; + + case SSH_AUTH_AGENT_INIT: + result = ssh_state_auth_agent_init(data, sshc); + break; + + case SSH_AUTH_AGENT_LIST: + result = ssh_state_auth_agent_list(data, sshc); + break; + + case SSH_AUTH_AGENT: + result = ssh_state_auth_agent(data, sshc); + break; + + case SSH_AUTH_KEY_INIT: + result = ssh_state_auth_key_init(data, sshc); + break; + + case SSH_AUTH_KEY: + result = ssh_state_auth_key(data, sshc); + break; + + case SSH_AUTH_DONE: + result = ssh_state_auth_done(data, sshc); + break; + + case SSH_SFTP_INIT: + result = ssh_state_sftp_init(data, sshc); + break; + + case SSH_SFTP_REALPATH: + result = ssh_state_sftp_realpath(data, sshc, sshp); + break; + + case SSH_SFTP_QUOTE_INIT: + result = ssh_state_sftp_quote_init(data, sshc, sshp); + break; + + case SSH_SFTP_POSTQUOTE_INIT: + result = ssh_state_sftp_postquote_init(data, sshc); + break; + + case SSH_SFTP_QUOTE: + result = ssh_state_sftp_quote(data, sshc, sshp); + break; + + case SSH_SFTP_NEXT_QUOTE: + result = ssh_state_sftp_next_quote(data, sshc); + break; + + case SSH_SFTP_QUOTE_STAT: + result = ssh_state_sftp_quote_stat(data, sshc, sshp, block); + break; + + case SSH_SFTP_QUOTE_SETSTAT: + result = ssh_state_sftp_quote_setstat(data, sshc, sshp); + break; + + case SSH_SFTP_QUOTE_SYMLINK: + result = ssh_state_sftp_quote_symlink(data, sshc); + break; + + case SSH_SFTP_QUOTE_MKDIR: + result = ssh_state_sftp_quote_mkdir(data, sshc); + break; + + case SSH_SFTP_QUOTE_RENAME: + result = ssh_state_sftp_quote_rename(data, sshc); + break; + + case SSH_SFTP_QUOTE_RMDIR: + result = ssh_state_sftp_quote_rmdir(data, sshc); + break; + + case SSH_SFTP_QUOTE_UNLINK: + result = ssh_state_sftp_quote_unlink(data, sshc); + break; + + case SSH_SFTP_QUOTE_STATVFS: + result = ssh_state_sftp_quote_statvfs(data, sshc); + break; + + case SSH_SFTP_GETINFO: + result = ssh_state_sftp_getinfo(data, sshc); + break; + + case SSH_SFTP_FILETIME: + result = ssh_state_sftp_filetime(data, sshc, sshp); + break; + + case SSH_SFTP_TRANS_INIT: + result = ssh_state_sftp_trans_init(data, sshc, sshp); + break; + + case SSH_SFTP_UPLOAD_INIT: + result = ssh_state_sftp_upload_init(data, sshc, sshp, block); + break; + + case SSH_SFTP_CREATE_DIRS_INIT: + result = ssh_state_sftp_create_dirs_init(data, sshc, sshp); + break; + + case SSH_SFTP_CREATE_DIRS: + result = ssh_state_sftp_create_dirs(data, sshc, sshp); + break; + + case SSH_SFTP_CREATE_DIRS_MKDIR: + result = ssh_state_sftp_create_dirs_mkdir(data, sshc, sshp); + break; + + case SSH_SFTP_READDIR_INIT: + result = ssh_state_sftp_readdir_init(data, sshc, sshp); + break; + + case SSH_SFTP_READDIR: + result = ssh_state_sftp_readdir(data, sshc, sshp, block); + break; + + case SSH_SFTP_READDIR_LINK: + result = ssh_state_sftp_readdir_link(data, sshc, sshp); + break; + + case SSH_SFTP_READDIR_BOTTOM: + result = ssh_state_sftp_readdir_bottom(data, sshc, sshp); + break; + + case SSH_SFTP_READDIR_DONE: + result = ssh_state_sftp_readdir_done(data, sshc); + break; + + case SSH_SFTP_DOWNLOAD_INIT: + result = ssh_state_sftp_download_init(data, sshc, sshp); + break; + + case SSH_SFTP_DOWNLOAD_STAT: + result = ssh_state_sftp_download_stat(data, sshc, sshp, block); + break; + + case SSH_SFTP_CLOSE: + result = ssh_state_sftp_close(data, sshc, sshp); + break; + + case SSH_SFTP_SHUTDOWN: + result = ssh_state_sftp_shutdown(data, sshc); + break; + + case SSH_SCP_TRANS_INIT: + result = ssh_state_scp_trans_init(data, sshc, sshp); + break; + + case SSH_SCP_UPLOAD_INIT: + result = ssh_state_scp_upload_init(data, sshc, sshp); + break; + + case SSH_SCP_DOWNLOAD_INIT: + result = ssh_state_scp_download_init(data, sshc, sshp); + break; + + case SSH_SCP_DONE: + result = ssh_state_scp_done(data, sshc); + break; + + case SSH_SCP_SEND_EOF: + result = ssh_state_scp_send_eof(data, sshc); + break; + + case SSH_SCP_WAIT_EOF: + result = ssh_state_scp_wait_eof(data, sshc); + break; + + case SSH_SCP_WAIT_CLOSE: + result = ssh_state_scp_wait_close(data, sshc); + break; + + case SSH_SCP_CHANNEL_FREE: + result = ssh_state_scp_channel_free(data, sshc); + break; + + case SSH_SESSION_DISCONNECT: + result = ssh_state_session_disconnect(data, sshc); + break; + + case SSH_SESSION_FREE: + result = ssh_state_session_free(data, sshc); + break; + + case SSH_QUIT: + default: + /* internal error */ + myssh_to(data, sshc, SSH_STOP); + break; + } + + } while(!result && (sshc->state != SSH_STOP) && !*block); + + if(result == CURLE_AGAIN) { + /* we would block, we need to wait for the socket to be ready (in the + right direction too)! */ + *block = TRUE; + result = CURLE_OK; + } + CURL_TRC_SSH(data, "[%s] statemachine() -> %d, block=%d", + Curl_ssh_statename(sshc->state), (int)result, *block); + + return result; +} + +/* called by the multi interface to figure out what socket(s) to wait for and + for what actions in the DO_DONE, PERFORM and WAITPERFORM states */ +static CURLcode ssh_pollset(struct Curl_easy *data, + struct easy_pollset *ps) +{ + struct connectdata *conn = data->conn; + struct ssh_conn *sshc = Curl_conn_meta_get(conn, CURL_META_SSH_CONN); + curl_socket_t sock = conn->sock[FIRSTSOCKET]; + int waitfor; + + if(!sshc || (sock == CURL_SOCKET_BAD)) + return CURLE_FAILED_INIT; + + waitfor = sshc->waitfor ? sshc->waitfor : data->req.io_flags; + if(waitfor) { + int flags = 0; + if(waitfor & REQ_IO_RECV) + flags |= CURL_POLL_IN; + if(waitfor & REQ_IO_SEND) + flags |= CURL_POLL_OUT; + DEBUGASSERT(flags); + CURL_TRC_SSH(data, "pollset, flags=%x", (unsigned int)flags); + return Curl_pollset_change(data, ps, sock, flags, 0); + } + /* While we still have a session, we listen incoming data. */ + if(sshc->ssh_session) + return Curl_pollset_change(data, ps, sock, CURL_POLL_IN, 0); + return CURLE_OK; +} + +/* + * When one of the libssh2 functions has returned LIBSSH2_ERROR_EAGAIN this + * function is used to figure out in what direction and stores this info so + * that the multi interface can take advantage of it. Make sure to call this + * function in all cases so that when it _does not_ return EAGAIN we can + * restore the default wait bits. + */ +static void ssh_block2waitfor(struct Curl_easy *data, + struct ssh_conn *sshc, + bool block) +{ + int dir = 0; + (void)data; + if(block) { + dir = libssh2_session_block_directions(sshc->ssh_session); + if(dir) { + /* translate the libssh2 define bits into our own bit defines */ + sshc->waitfor = + ((dir & LIBSSH2_SESSION_BLOCK_INBOUND) ? REQ_IO_RECV : 0) | + ((dir & LIBSSH2_SESSION_BLOCK_OUTBOUND) ? REQ_IO_SEND : 0); + } + } + if(!dir) + sshc->waitfor = 0; +} + +/* called repeatedly until done from multi.c */ +static CURLcode ssh_multi_statemach(struct Curl_easy *data, bool *done) +{ + struct connectdata *conn = data->conn; + struct ssh_conn *sshc = Curl_conn_meta_get(conn, CURL_META_SSH_CONN); + struct SSHPROTO *sshp = Curl_meta_get(data, CURL_META_SSH_EASY); + CURLcode result = CURLE_OK; + bool block; /* we store the status and use that to provide a ssh_pollset() + implementation */ + if(!sshc || !sshp) + return CURLE_FAILED_INIT; + + do { + result = ssh_statemachine(data, sshc, sshp, &block); + *done = (sshc->state == SSH_STOP); + /* if there is no error, it is not done and it did not EWOULDBLOCK, then + try again */ + } while(!result && !*done && !block); + ssh_block2waitfor(data, sshc, block); + + return result; +} + +static CURLcode ssh_block_statemach(struct Curl_easy *data, + struct ssh_conn *sshc, + struct SSHPROTO *sshp, + bool disconnect) +{ + CURLcode result = CURLE_OK; + struct curltime start = *Curl_pgrs_now(data); + + while((sshc->state != SSH_STOP) && !result) { + bool block; + timediff_t left_ms = 1000; + + result = ssh_statemachine(data, sshc, sshp, &block); + if(result) + break; + + if(!disconnect) { + result = Curl_pgrsCheck(data); + if(result) + break; + + left_ms = Curl_timeleft_ms(data); + if(left_ms < 0) { + failf(data, "Operation timed out"); + return CURLE_OPERATION_TIMEDOUT; + } + } + else if(curlx_ptimediff_ms(Curl_pgrs_now(data), &start) > 1000) { + /* disconnect timeout */ + failf(data, "Disconnect timed out"); + result = CURLE_OK; + break; + } + + if(block) { + int dir = libssh2_session_block_directions(sshc->ssh_session); + curl_socket_t sock = data->conn->sock[FIRSTSOCKET]; + curl_socket_t fd_read = CURL_SOCKET_BAD; + curl_socket_t fd_write = CURL_SOCKET_BAD; + if(LIBSSH2_SESSION_BLOCK_INBOUND & dir) + fd_read = sock; + if(LIBSSH2_SESSION_BLOCK_OUTBOUND & dir) + fd_write = sock; + /* wait for the socket to become ready */ + (void)Curl_socket_check(fd_read, CURL_SOCKET_BAD, fd_write, + left_ms > 1000 ? 1000 : left_ms); + } + } + + return result; +} + +static void myssh_easy_dtor(void *key, size_t klen, void *entry) +{ + struct SSHPROTO *sshp = entry; + (void)key; + (void)klen; + curlx_safefree(sshp->path); + curlx_dyn_free(&sshp->readdir); + curlx_dyn_free(&sshp->readdir_link); + curlx_free(sshp); +} + +static void myssh_conn_dtor(void *key, size_t klen, void *entry) +{ + struct ssh_conn *sshc = entry; + (void)key; + (void)klen; + sshc_cleanup(sshc, NULL, TRUE); + curlx_free(sshc); +} + +/* + * SSH setup and connection + */ +static CURLcode ssh_setup_connection(struct Curl_easy *data, + struct connectdata *conn) +{ + struct ssh_conn *sshc; + struct SSHPROTO *sshp; + (void)conn; + + sshc = curlx_calloc(1, sizeof(*sshc)); + if(!sshc) + return CURLE_OUT_OF_MEMORY; + + if(Curl_conn_meta_set(conn, CURL_META_SSH_CONN, sshc, myssh_conn_dtor)) + return CURLE_OUT_OF_MEMORY; + + sshp = curlx_calloc(1, sizeof(*sshp)); + if(!sshp) + return CURLE_OUT_OF_MEMORY; + + curlx_dyn_init(&sshp->readdir, CURL_PATH_MAX * 2); + curlx_dyn_init(&sshp->readdir_link, CURL_PATH_MAX); + if(Curl_meta_set(data, CURL_META_SSH_EASY, sshp, myssh_easy_dtor)) + return CURLE_OUT_OF_MEMORY; + + return CURLE_OK; +} + +static Curl_recv scp_recv, sftp_recv; +static Curl_send scp_send, sftp_send; + +#ifndef CURL_DISABLE_PROXY +static ssize_t ssh_tls_recv(libssh2_socket_t sock, void *buffer, + size_t length, int flags, void **abstract) +{ + struct Curl_easy *data = (struct Curl_easy *)*abstract; + int sockindex = Curl_conn_sockindex(data, sock); + size_t nread; + CURLcode result; + struct connectdata *conn = data->conn; + Curl_recv *backup = conn->recv[sockindex]; + struct ssh_conn *sshc = Curl_conn_meta_get(conn, CURL_META_SSH_CONN); + (void)flags; + + if(!sshc) + return -1; + + /* swap in the TLS reader function for this call only, and then swap back + the SSH one again */ + conn->recv[sockindex] = sshc->tls_recv; + result = Curl_conn_recv(data, sockindex, buffer, length, &nread); + conn->recv[sockindex] = backup; + if(result == CURLE_AGAIN) + return -EAGAIN; /* magic return code for libssh2 */ + else if(result) + return -1; /* generic error */ + Curl_debug(data, CURLINFO_DATA_IN, (const char *)buffer, nread); + return (ssize_t)nread; +} + +static ssize_t ssh_tls_send(libssh2_socket_t sock, const void *buffer, + size_t length, int flags, void **abstract) +{ + struct Curl_easy *data = (struct Curl_easy *)*abstract; + int sockindex = Curl_conn_sockindex(data, sock); + size_t nwrite; + CURLcode result; + struct connectdata *conn = data->conn; + Curl_send *backup = conn->send[sockindex]; + struct ssh_conn *sshc = Curl_conn_meta_get(conn, CURL_META_SSH_CONN); + (void)flags; + + if(!sshc) + return -1; + + /* swap in the TLS writer function for this call only, and then swap back + the SSH one again */ + conn->send[sockindex] = sshc->tls_send; + result = Curl_conn_send(data, sockindex, buffer, length, FALSE, &nwrite); + conn->send[sockindex] = backup; + if(result == CURLE_AGAIN) + return -EAGAIN; /* magic return code for libssh2 */ + else if(result) + return -1; /* error */ + Curl_debug(data, CURLINFO_DATA_OUT, (const char *)buffer, nwrite); + return (ssize_t)nwrite; +} +#endif + +/* + * Curl_ssh_connect() gets called from Curl_protocol_connect() to allow us to + * do protocol-specific actions at connect-time. + */ +static CURLcode ssh_connect(struct Curl_easy *data, bool *done) +{ +#ifdef CURL_LIBSSH2_DEBUG + curl_socket_t sock; +#endif + struct connectdata *conn = data->conn; + struct ssh_conn *sshc = Curl_conn_meta_get(conn, CURL_META_SSH_CONN); + CURLcode result; + +#if LIBSSH2_VERSION_NUM >= 0x010b00 + { + const char *crypto_str; + switch(libssh2_crypto_engine()) { + case libssh2_gcrypt: + crypto_str = "libgcrypt"; + break; + case libssh2_mbedtls: + crypto_str = "mbedTLS"; + break; + case libssh2_openssl: + crypto_str = "openssl compatible"; + break; + case libssh2_os400qc3: + crypto_str = "OS400QC3"; + break; + case libssh2_wincng: + crypto_str = "WinCNG"; + break; + default: + crypto_str = NULL; + break; + } + if(crypto_str) + infof(data, "SSH: libssh2 cryptography backend: %s", crypto_str); + } +#endif + + if(!sshc) + return CURLE_FAILED_INIT; + + infof(data, "SSH: user '%s'", Curl_creds_user(conn->creds)); +#ifdef CURL_LIBSSH2_DEBUG + infof(data, "SSH: password %s", Curl_creds_passwd(conn->creds)); + sock = conn->sock[FIRSTSOCKET]; +#endif /* CURL_LIBSSH2_DEBUG */ + + /* libcurl MUST to set custom memory functions so that the kbd_callback + function's memory allocations can be properly freed */ + sshc->ssh_session = libssh2_session_init_ex(my_libssh2_malloc, + my_libssh2_free, + my_libssh2_realloc, data); + + if(!sshc->ssh_session) { + failf(data, "Failure initializing ssh session"); + return CURLE_FAILED_INIT; + } + + /* Set the packet read timeout if the libssh2 version supports it */ +#if LIBSSH2_VERSION_NUM >= 0x010B00 + if(data->set.server_response_timeout > 0) { + libssh2_session_set_read_timeout(sshc->ssh_session, + (long)(data->set.server_response_timeout / 1000)); + } +#endif + +#ifndef CURL_DISABLE_PROXY + if(conn->http_proxy.proxytype == CURLPROXY_HTTPS) { + /* + Setup libssh2 callbacks to make it read/write TLS from the socket. + + ssize_t + recvcb(libssh2_socket_t sock, void *buffer, size_t length, + int flags, void **abstract); + + ssize_t + sendcb(libssh2_socket_t sock, const void *buffer, size_t length, + int flags, void **abstract); + + */ +#if LIBSSH2_VERSION_NUM >= 0x010b01 + infof(data, "SSH: using HTTPS proxy"); +#if defined(__clang__) && __clang_major__ >= 16 +#pragma clang diagnostic push +#pragma clang diagnostic ignored "-Wcast-function-type-strict" +#endif + libssh2_session_callback_set2(sshc->ssh_session, + LIBSSH2_CALLBACK_RECV, + (libssh2_cb_generic *)ssh_tls_recv); + libssh2_session_callback_set2(sshc->ssh_session, + LIBSSH2_CALLBACK_SEND, + (libssh2_cb_generic *)ssh_tls_send); +#if defined(__clang__) && __clang_major__ >= 16 +#pragma clang diagnostic pop +#endif +#else + /* + * This crazy union dance is here to avoid assigning a void pointer a + * function pointer as it is invalid C. The problem is of course that + * libssh2 has such an API... + */ + union receive { + void *recvp; + ssize_t (*recvptr)(libssh2_socket_t, void *, size_t, int, void **); + }; + union transfer { + void *sendp; + ssize_t (*sendptr)(libssh2_socket_t, const void *, size_t, int, void **); + }; + union receive sshrecv; + union transfer sshsend; + + sshrecv.recvptr = ssh_tls_recv; + sshsend.sendptr = ssh_tls_send; + + infof(data, "SSH: using HTTPS proxy"); + libssh2_session_callback_set(sshc->ssh_session, + LIBSSH2_CALLBACK_RECV, sshrecv.recvp); + libssh2_session_callback_set(sshc->ssh_session, + LIBSSH2_CALLBACK_SEND, sshsend.sendp); +#endif + + /* Store the underlying TLS recv/send function pointers to be used when + reading from the proxy */ + sshc->tls_recv = conn->recv[FIRSTSOCKET]; + sshc->tls_send = conn->send[FIRSTSOCKET]; + } + +#endif /* CURL_DISABLE_PROXY */ + if(conn->scheme->protocol & CURLPROTO_SCP) { + conn->recv[FIRSTSOCKET] = scp_recv; + conn->send[FIRSTSOCKET] = scp_send; + } + else { + conn->recv[FIRSTSOCKET] = sftp_recv; + conn->send[FIRSTSOCKET] = sftp_send; + } + + if(data->set.ssh_compression && + libssh2_session_flag(sshc->ssh_session, LIBSSH2_FLAG_COMPRESS, 1) < 0) { + infof(data, "SSH: failed to enable compression for session"); + } + + if(data->set.str[STRING_SSH_KNOWNHOSTS]) { + int rc; + sshc->kh = libssh2_knownhost_init(sshc->ssh_session); + if(!sshc->kh) { + libssh2_session_free(sshc->ssh_session); + sshc->ssh_session = NULL; + return CURLE_FAILED_INIT; + } + + /* read all known hosts from there */ + rc = libssh2_knownhost_readfile(sshc->kh, + data->set.str[STRING_SSH_KNOWNHOSTS], + LIBSSH2_KNOWNHOST_FILE_OPENSSH); + if(rc < 0) + infof(data, "SSH: failed to read known hosts from %s", + data->set.str[STRING_SSH_KNOWNHOSTS]); + } + +#ifdef CURL_LIBSSH2_DEBUG + libssh2_trace(sshc->ssh_session, ~0); + infof(data, "SSH: socket %d", (int)sock); +#endif + + myssh_to(data, sshc, SSH_INIT); + + result = ssh_multi_statemach(data, done); + + return result; +} + +/* + *********************************************************************** + * + * scp_perform() + * + * This is the actual DO function for SCP. Get a file according to + * the options previously setup. + */ + +static CURLcode scp_perform(struct Curl_easy *data, + bool *connected, + bool *dophase_done) +{ + struct ssh_conn *sshc = Curl_conn_meta_get(data->conn, CURL_META_SSH_CONN); + CURLcode result = CURLE_OK; + + CURL_TRC_SSH(data, "DO phase starts"); + + *dophase_done = FALSE; /* not done yet */ + if(!sshc) + return CURLE_FAILED_INIT; + + /* start the first command in the DO phase */ + myssh_to(data, sshc, SSH_SCP_TRANS_INIT); + + /* run the state-machine */ + result = ssh_multi_statemach(data, dophase_done); + + *connected = Curl_conn_is_connected(data->conn, FIRSTSOCKET); + + if(*dophase_done) { + CURL_TRC_SSH(data, "DO phase is complete"); + } + + return result; +} + +/* called from multi.c while DOing */ +static CURLcode scp_doing(struct Curl_easy *data, + bool *dophase_done) +{ + CURLcode result; + result = ssh_multi_statemach(data, dophase_done); + + if(*dophase_done) { + CURL_TRC_SSH(data, "DO phase is complete"); + } + return result; +} + +/* BLOCKING, but the function is using the state machine so the only reason + this is still blocking is that the multi interface code has no support for + disconnecting operations that takes a while */ +static CURLcode scp_disconnect(struct Curl_easy *data, + struct connectdata *conn, + bool dead_connection) +{ + CURLcode result = CURLE_OK; + struct ssh_conn *sshc = Curl_conn_meta_get(conn, CURL_META_SSH_CONN); + struct SSHPROTO *sshp = Curl_meta_get(data, CURL_META_SSH_EASY); + (void)dead_connection; + + if(sshc && sshc->ssh_session) { + /* only if there is a session still around to use! */ + myssh_to(data, sshc, SSH_SESSION_DISCONNECT); + result = ssh_block_statemach(data, sshc, sshp, TRUE); + } + + if(sshc) + return sshc_cleanup(sshc, data, TRUE); + return result; +} + +/* generic done function for both SCP and SFTP called from their specific + done functions */ +static CURLcode ssh_done(struct Curl_easy *data, CURLcode status) +{ + struct ssh_conn *sshc = Curl_conn_meta_get(data->conn, CURL_META_SSH_CONN); + struct SSHPROTO *sshp = Curl_meta_get(data, CURL_META_SSH_EASY); + CURLcode result = CURLE_OK; + + if(!sshc || !sshp) + return CURLE_FAILED_INIT; + + if(!status) + /* run the state-machine */ + result = ssh_block_statemach(data, sshc, sshp, FALSE); + else + result = status; + + if(Curl_pgrsDone(data)) + return CURLE_ABORTED_BY_CALLBACK; + + CURL_REQ_CLEAR_IO(data); + return result; +} + +static CURLcode scp_done(struct Curl_easy *data, CURLcode status, + bool premature) +{ + struct ssh_conn *sshc = Curl_conn_meta_get(data->conn, CURL_META_SSH_CONN); + (void)premature; + + if(sshc && !status) + myssh_to(data, sshc, SSH_SCP_DONE); + + return ssh_done(data, status); +} + +static CURLcode scp_send(struct Curl_easy *data, int sockindex, + const uint8_t *mem, size_t len, bool eos, + size_t *pnwritten) +{ + struct connectdata *conn = data->conn; + struct ssh_conn *sshc = Curl_conn_meta_get(conn, CURL_META_SSH_CONN); + CURLcode result = CURLE_OK; + ssize_t nwritten; + + (void)sockindex; /* we only support SCP on the fixed known primary socket */ + (void)eos; + *pnwritten = 0; + + if(!sshc) + return CURLE_FAILED_INIT; + + /* libssh2_channel_write() returns int! */ + nwritten = (ssize_t)libssh2_channel_write(sshc->ssh_channel, + (const char *)mem, len); + + ssh_block2waitfor(data, sshc, (nwritten == LIBSSH2_ERROR_EAGAIN)); + + if(nwritten == LIBSSH2_ERROR_EAGAIN) + result = CURLE_AGAIN; + else if(nwritten < LIBSSH2_ERROR_NONE) + result = libssh2_session_error_to_CURLE((int)nwritten); + else + *pnwritten = (size_t)nwritten; + + return result; +} + +static CURLcode scp_recv(struct Curl_easy *data, int sockindex, + char *mem, size_t len, size_t *pnread) +{ + struct connectdata *conn = data->conn; + struct ssh_conn *sshc = Curl_conn_meta_get(conn, CURL_META_SSH_CONN); + CURLcode result = CURLE_OK; + ssize_t nread; + + (void)sockindex; /* we only support SCP on the fixed known primary socket */ + *pnread = 0; + + if(!sshc) + return CURLE_FAILED_INIT; + + /* libssh2_channel_read() returns int */ + nread = (ssize_t)libssh2_channel_read(sshc->ssh_channel, mem, len); + + ssh_block2waitfor(data, sshc, (nread == LIBSSH2_ERROR_EAGAIN)); + if(nread == LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + else if(nread < LIBSSH2_ERROR_NONE) + result = libssh2_session_error_to_CURLE((int)nread); + else + *pnread = (size_t)nread; + + return result; +} + +/* + * =============== SFTP =============== + */ + +/* + *********************************************************************** + * + * sftp_perform() + * + * This is the actual DO function for SFTP. Get a file/directory according to + * the options previously setup. + */ + +static CURLcode sftp_perform(struct Curl_easy *data, + bool *connected, + bool *dophase_done) +{ + struct ssh_conn *sshc = Curl_conn_meta_get(data->conn, CURL_META_SSH_CONN); + CURLcode result = CURLE_OK; + + CURL_TRC_SSH(data, "DO phase starts"); + + *dophase_done = FALSE; /* not done yet */ + if(!sshc) + return CURLE_FAILED_INIT; + + /* start the first command in the DO phase */ + myssh_to(data, sshc, SSH_SFTP_QUOTE_INIT); + + /* run the state-machine */ + result = ssh_multi_statemach(data, dophase_done); + + *connected = Curl_conn_is_connected(data->conn, FIRSTSOCKET); + + if(*dophase_done) { + CURL_TRC_SSH(data, "DO phase is complete"); + } + + return result; +} + +/* called from multi.c while DOing */ +static CURLcode sftp_doing(struct Curl_easy *data, + bool *dophase_done) +{ + CURLcode result = ssh_multi_statemach(data, dophase_done); + + if(*dophase_done) { + CURL_TRC_SSH(data, "DO phase is complete"); + } + return result; +} + +/* BLOCKING, but the function is using the state machine so the only reason + this is still blocking is that the multi interface code has no support for + disconnecting operations that takes a while */ +static CURLcode sftp_disconnect(struct Curl_easy *data, + struct connectdata *conn, bool dead_connection) +{ + CURLcode result = CURLE_OK; + struct ssh_conn *sshc = Curl_conn_meta_get(conn, CURL_META_SSH_CONN); + struct SSHPROTO *sshp = Curl_meta_get(data, CURL_META_SSH_EASY); + (void)dead_connection; + + if(sshc) { + if(sshc->ssh_session) { + /* only if there is a session still around to use! */ + CURL_TRC_SSH(data, "DISCONNECT starts now"); + myssh_to(data, sshc, SSH_SFTP_SHUTDOWN); + result = ssh_block_statemach(data, sshc, sshp, TRUE); + CURL_TRC_SSH(data, "DISCONNECT is done -> %d", (int)result); + } + sshc_cleanup(sshc, data, TRUE); + } + return result; +} + +static CURLcode sftp_done(struct Curl_easy *data, CURLcode status, + bool premature) +{ + struct connectdata *conn = data->conn; + struct ssh_conn *sshc = Curl_conn_meta_get(conn, CURL_META_SSH_CONN); + + if(!sshc) + return CURLE_FAILED_INIT; + + if(!status) { + /* Post quote commands are executed after the SFTP_CLOSE state to avoid + errors that could happen due to open file handles during POSTQUOTE + operation */ + if(!premature && data->set.postquote && !conn->bits.retry) + sshc->nextstate = SSH_SFTP_POSTQUOTE_INIT; + myssh_to(data, sshc, SSH_SFTP_CLOSE); + } + return ssh_done(data, status); +} + +/* return number of sent bytes */ +static CURLcode sftp_send(struct Curl_easy *data, int sockindex, + const uint8_t *mem, size_t len, bool eos, + size_t *pnwritten) +{ + struct connectdata *conn = data->conn; + struct ssh_conn *sshc = Curl_conn_meta_get(conn, CURL_META_SSH_CONN); + ssize_t nwrite; + + (void)sockindex; + (void)eos; + *pnwritten = 0; + + if(!sshc) + return CURLE_FAILED_INIT; + + nwrite = libssh2_sftp_write(sshc->sftp_handle, (const char *)mem, len); + + ssh_block2waitfor(data, sshc, (nwrite == LIBSSH2_ERROR_EAGAIN)); + + if(nwrite == LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + else if(nwrite < LIBSSH2_ERROR_NONE) + return libssh2_session_error_to_CURLE((int)nwrite); + *pnwritten = (size_t)nwrite; + return CURLE_OK; +} + +/* + * Return number of received (decrypted) bytes + * or <0 on error + */ +static CURLcode sftp_recv(struct Curl_easy *data, int sockindex, + char *mem, size_t len, size_t *pnread) +{ + struct connectdata *conn = data->conn; + struct ssh_conn *sshc = Curl_conn_meta_get(conn, CURL_META_SSH_CONN); + ssize_t nread; + + (void)sockindex; + *pnread = 0; + + if(!sshc) + return CURLE_FAILED_INIT; + + nread = libssh2_sftp_read(sshc->sftp_handle, mem, len); + + ssh_block2waitfor(data, sshc, (nread == LIBSSH2_ERROR_EAGAIN)); + + if(nread == LIBSSH2_ERROR_EAGAIN) + return CURLE_AGAIN; + else if(nread < 0) + return libssh2_session_error_to_CURLE((int)nread); + + *pnread = (size_t)nread; + return CURLE_OK; +} + +/* + * The DO function is generic for both protocols. There was previously two + * separate ones but this way means less duplicated code. + */ +static CURLcode ssh_do(struct Curl_easy *data, bool *done) +{ + CURLcode result; + bool connected = FALSE; + struct connectdata *conn = data->conn; + struct ssh_conn *sshc = Curl_conn_meta_get(conn, CURL_META_SSH_CONN); + + *done = FALSE; /* default to false */ + if(!sshc) + return CURLE_FAILED_INIT; + + data->req.size = -1; /* make sure this is unknown at this point */ + sshc->secondCreateDirs = 0; /* reset the create directory attempt state + variable */ + + Curl_pgrsReset(data); + + if(conn->scheme->protocol & CURLPROTO_SCP) + result = scp_perform(data, &connected, done); + else + result = sftp_perform(data, &connected, done); + + return result; +} + +CURLcode Curl_ssh_init(void) +{ + if(libssh2_init(0)) { + DEBUGF(curl_mfprintf(stderr, "Error: libssh2_init failed\n")); + return CURLE_FAILED_INIT; + } + return CURLE_OK; +} + +void Curl_ssh_cleanup(void) +{ + libssh2_exit(); +} + +void Curl_ssh_version(char *buffer, size_t buflen) +{ + (void)curl_msnprintf(buffer, buflen, "libssh2/%s", libssh2_version(0)); +} + +/* The SSH session is associated with the *CONNECTION* but the callback user + * pointer is an easy handle pointer. This function allows us to reassign the + * user pointer to the *CURRENT* (new) easy handle. + */ +static void ssh_attach(struct Curl_easy *data, struct connectdata *conn) +{ + DEBUGASSERT(data); + DEBUGASSERT(conn); + if(conn->scheme->protocol & PROTO_FAMILY_SSH) { + struct ssh_conn *sshc = Curl_conn_meta_get(conn, CURL_META_SSH_CONN); + if(sshc && sshc->ssh_session) { + /* only re-attach if the session already exists */ + void **abstract = libssh2_session_abstract(sshc->ssh_session); + *abstract = data; + } + } +} + +/* + * SCP protocol handler. + */ +const struct Curl_protocol Curl_protocol_scp = { + ssh_setup_connection, /* setup_connection */ + ssh_do, /* do_it */ + scp_done, /* done */ + ZERO_NULL, /* do_more */ + ssh_connect, /* connect_it */ + ssh_multi_statemach, /* connecting */ + scp_doing, /* doing */ + ssh_pollset, /* proto_pollset */ + ssh_pollset, /* doing_pollset */ + ZERO_NULL, /* domore_pollset */ + ssh_pollset, /* perform_pollset */ + scp_disconnect, /* disconnect */ + ZERO_NULL, /* write_resp */ + ZERO_NULL, /* write_resp_hd */ + ZERO_NULL, /* connection_is_dead */ + ssh_attach, /* attach */ + ZERO_NULL, /* follow */ +}; + +/* + * SFTP protocol handler. + */ +const struct Curl_protocol Curl_protocol_sftp = { + ssh_setup_connection, /* setup_connection */ + ssh_do, /* do_it */ + sftp_done, /* done */ + ZERO_NULL, /* do_more */ + ssh_connect, /* connect_it */ + ssh_multi_statemach, /* connecting */ + sftp_doing, /* doing */ + ssh_pollset, /* proto_pollset */ + ssh_pollset, /* doing_pollset */ + ZERO_NULL, /* domore_pollset */ + ssh_pollset, /* perform_pollset */ + sftp_disconnect, /* disconnect */ + ZERO_NULL, /* write_resp */ + ZERO_NULL, /* write_resp_hd */ + ZERO_NULL, /* connection_is_dead */ + ssh_attach, /* attach */ + ZERO_NULL, /* follow */ +}; + +#endif /* USE_LIBSSH2 */ diff --git a/3rdparty/curl-8.21.0/lib/vssh/ssh.h b/3rdparty/curl-8.21.0/lib/vssh/ssh.h new file mode 100644 index 0000000000..de76c8a253 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vssh/ssh.h @@ -0,0 +1,262 @@ +#ifndef HEADER_CURL_VSSH_SSH_H +#define HEADER_CURL_VSSH_SSH_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" +#include "urldata.h" + +extern const struct Curl_protocol Curl_protocol_sftp; +extern const struct Curl_protocol Curl_protocol_scp; + +#ifdef USE_SSH + +#ifdef USE_LIBSSH2 +#include +#include +#elif defined(USE_LIBSSH) +/* in 0.10.0 or later, ignore deprecated warnings */ +#define SSH_SUPPRESS_DEPRECATED +#include +#include +#endif + +/* meta key for storing protocol meta at easy handle */ +#define CURL_META_SSH_EASY "meta:proto:ssh:easy" +/* meta key for storing protocol meta at connection */ +#define CURL_META_SSH_CONN "meta:proto:ssh:conn" + +/**************************************************************************** + * SSH unique setup + ***************************************************************************/ +typedef enum { + SSH_NO_STATE = -1, /* Used for "nextState" so say there is none */ + SSH_STOP = 0, /* do nothing state, stops the state machine */ + + SSH_INIT, /* First state in SSH-CONNECT */ + SSH_S_STARTUP, /* Session startup */ + SSH_HOSTKEY, /* verify hostkey */ + SSH_AUTHLIST, + SSH_AUTH_PKEY_INIT, + SSH_AUTH_PKEY, + SSH_AUTH_PASS_INIT, + SSH_AUTH_PASS, + SSH_AUTH_AGENT_INIT, /* initialize then wait for connection to agent */ + SSH_AUTH_AGENT_LIST, /* ask for list then wait for entire list to come */ + SSH_AUTH_AGENT, /* attempt one key at a time */ + SSH_AUTH_HOST_INIT, + SSH_AUTH_HOST, + SSH_AUTH_KEY_INIT, + SSH_AUTH_KEY, + SSH_AUTH_GSSAPI, + SSH_AUTH_DONE, + SSH_SFTP_INIT, + SSH_SFTP_REALPATH, /* Last state in SSH-CONNECT */ + + SSH_SFTP_QUOTE_INIT, /* First state in SFTP-DO */ + SSH_SFTP_POSTQUOTE_INIT, /* (Possibly) First state in SFTP-DONE */ + SSH_SFTP_QUOTE, + SSH_SFTP_NEXT_QUOTE, + SSH_SFTP_QUOTE_STAT, + SSH_SFTP_QUOTE_SETSTAT, + SSH_SFTP_QUOTE_SYMLINK, + SSH_SFTP_QUOTE_MKDIR, + SSH_SFTP_QUOTE_RENAME, + SSH_SFTP_QUOTE_RMDIR, + SSH_SFTP_QUOTE_UNLINK, + SSH_SFTP_QUOTE_STATVFS, + SSH_SFTP_GETINFO, + SSH_SFTP_FILETIME, + SSH_SFTP_TRANS_INIT, + SSH_SFTP_UPLOAD_INIT, + SSH_SFTP_CREATE_DIRS_INIT, + SSH_SFTP_CREATE_DIRS, + SSH_SFTP_CREATE_DIRS_MKDIR, + SSH_SFTP_READDIR_INIT, + SSH_SFTP_READDIR, + SSH_SFTP_READDIR_LINK, + SSH_SFTP_READDIR_BOTTOM, + SSH_SFTP_READDIR_DONE, + SSH_SFTP_DOWNLOAD_INIT, + SSH_SFTP_DOWNLOAD_STAT, /* Last state in SFTP-DO */ + SSH_SFTP_CLOSE, /* Last state in SFTP-DONE */ + SSH_SFTP_SHUTDOWN, /* First state in SFTP-DISCONNECT */ + SSH_SCP_TRANS_INIT, /* First state in SCP-DO */ + SSH_SCP_UPLOAD_INIT, + SSH_SCP_DOWNLOAD_INIT, + SSH_SCP_DOWNLOAD, + SSH_SCP_DONE, + SSH_SCP_SEND_EOF, + SSH_SCP_WAIT_EOF, + SSH_SCP_WAIT_CLOSE, + SSH_SCP_CHANNEL_FREE, /* Last state in SCP-DONE */ + SSH_SESSION_DISCONNECT, /* First state in SCP-DISCONNECT */ + SSH_SESSION_FREE, /* Last state in SCP/SFTP-DISCONNECT */ + SSH_QUIT, + SSH_LAST /* never used */ +} sshstate; + +#define CURL_PATH_MAX 1024 + +/* this struct is used in the HandleData struct which is part of the + Curl_easy, which means this is used on a per-easy handle basis. + Everything that is strictly related to a connection is banned from this + struct. */ +struct SSHPROTO { + char *path; /* the path we operate on, at least one byte long */ +#ifdef USE_LIBSSH2 + struct dynbuf readdir_link; + struct dynbuf readdir; + char readdir_filename[CURL_PATH_MAX + 1]; + char readdir_longentry[CURL_PATH_MAX + 1]; + + LIBSSH2_SFTP_ATTRIBUTES quote_attrs; /* used by the SFTP_QUOTE state */ + + /* Here's a set of struct members used by the SFTP_READDIR state */ + LIBSSH2_SFTP_ATTRIBUTES readdir_attrs; +#endif +}; + +/* ssh_conn is used for struct connection-oriented data in the connectdata + struct */ +struct ssh_conn { + const char *authlist; /* List of auth. methods, managed by libssh2 */ + + /* common */ + const char *passphrase; /* pass-phrase to use */ + char *rsa_pub; /* strdup'ed public key file */ + char *rsa; /* strdup'ed private key file */ + sshstate state; /* always use ssh.c:state() to change state! */ + sshstate nextstate; /* the state to goto after stopping */ + struct curl_slist *quote_item; /* for the quote option */ + char *quote_path1; /* two generic pointers for the QUOTE stuff */ + char *quote_path2; + + char *homedir; /* when doing SFTP we figure out home directory + in the connect phase */ + /* end of READDIR stuff */ + + int secondCreateDirs; /* counter use by the code to see if the + second attempt has been made to change + to/create a directory */ + int waitfor; /* REQ_IO_RECV/REQ_IO_SEND bits overriding + pollset given flags */ + char *slash_pos; /* used by the SFTP_CREATE_DIRS state */ + +#ifdef USE_LIBSSH + CURLcode actualcode; /* the actual error code */ + char *readdir_linkPath; + size_t readdir_len; + struct dynbuf readdir_buf; +/* our variables */ + unsigned kbd_state; /* 0 or 1 */ + ssh_key privkey; + ssh_key pubkey; + unsigned int auth_methods; + ssh_session ssh_session; + ssh_scp scp_session; + sftp_session sftp_session; + sftp_file sftp_file; + sftp_dir sftp_dir; + + unsigned sftp_recv_state; /* 0 or 1 */ +#if LIBSSH_VERSION_INT > SSH_VERSION_INT(0, 11, 0) + sftp_aio sftp_recv_aio; + + sftp_aio sftp_send_aio; + unsigned sftp_send_state; /* 0 or 1 */ +#else + int sftp_file_index; /* for async read */ +#endif + sftp_attributes readdir_attrs; /* used by the SFTP readdir actions */ + sftp_attributes readdir_link_attrs; /* used by the SFTP readdir actions */ + sftp_attributes quote_attrs; /* used by the SFTP_QUOTE state */ + + const char *readdir_filename; /* points within readdir_attrs */ + const char *readdir_longentry; + char *readdir_tmp; + BIT(initialized); +#elif defined(USE_LIBSSH2) + LIBSSH2_SESSION *ssh_session; /* Secure Shell session */ + LIBSSH2_CHANNEL *ssh_channel; /* Secure Shell channel handle */ + LIBSSH2_SFTP *sftp_session; /* SFTP handle */ + LIBSSH2_SFTP_HANDLE *sftp_handle; + +#ifndef CURL_DISABLE_PROXY + /* for HTTPS proxy storage */ + Curl_recv *tls_recv; + Curl_send *tls_send; +#endif + + LIBSSH2_AGENT *ssh_agent; /* proxy to ssh-agent/pageant */ + struct libssh2_agent_publickey *sshagent_identity; + struct libssh2_agent_publickey *sshagent_prev_identity; + LIBSSH2_KNOWNHOSTS *kh; +#endif /* USE_LIBSSH */ + BIT(authed); /* the connection has been authenticated fine */ + BIT(acceptfail); /* used by the SFTP_QUOTE (continue if + quote command fails) */ +}; + +#ifdef USE_LIBSSH +#if LIBSSH_VERSION_INT < SSH_VERSION_INT(0, 9, 0) +#error "SCP/SFTP protocols require libssh 0.9.0 or later" +#endif +#endif + +#ifdef USE_LIBSSH2 + +/* Feature detection based on version numbers to better work with + non-configure platforms */ + +#if !defined(LIBSSH2_VERSION_NUM) || (LIBSSH2_VERSION_NUM < 0x010900) +#error "SCP/SFTP protocols require libssh2 1.9.0 or greater" +/* 1.9.0 was released on June 20 2019 */ +#endif + +#endif /* USE_LIBSSH2 */ + +#ifdef CURLVERBOSE +const char *Curl_ssh_statename(sshstate state); +#else +#define Curl_ssh_statename(x) "" +#endif +void Curl_ssh_set_state(struct Curl_easy *data, + struct ssh_conn *sshc, + sshstate nowstate); + +#define myssh_to(x, y, z) Curl_ssh_set_state(x, y, z) + +/* generic SSH backend functions */ +CURLcode Curl_ssh_init(void); +void Curl_ssh_cleanup(void); +void Curl_ssh_version(char *buffer, size_t buflen); +void Curl_ssh_attach(struct Curl_easy *data, + struct connectdata *conn); +#else /* !USE_SSH */ +#define Curl_ssh_cleanup() +#define Curl_ssh_attach(x, y) +#define Curl_ssh_init() 0 +#endif /* USE_SSH */ + +#endif /* HEADER_CURL_SSH_H */ diff --git a/3rdparty/curl-8.21.0/lib/vssh/vssh.c b/3rdparty/curl-8.21.0/lib/vssh/vssh.c new file mode 100644 index 0000000000..0ba4a9e690 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vssh/vssh.c @@ -0,0 +1,333 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl AND ISC + * + ***************************************************************************/ +#include "curl_setup.h" +#include "vssh/ssh.h" + +#ifdef USE_SSH + +#include "vssh/vssh.h" +#include "curlx/strparse.h" +#include "curl_trc.h" +#include "escape.h" + +#ifdef CURLVERBOSE +const char *Curl_ssh_statename(sshstate state) +{ + static const char * const names[] = { + "SSH_STOP", + "SSH_INIT", + "SSH_S_STARTUP", + "SSH_HOSTKEY", + "SSH_AUTHLIST", + "SSH_AUTH_PKEY_INIT", + "SSH_AUTH_PKEY", + "SSH_AUTH_PASS_INIT", + "SSH_AUTH_PASS", + "SSH_AUTH_AGENT_INIT", + "SSH_AUTH_AGENT_LIST", + "SSH_AUTH_AGENT", + "SSH_AUTH_HOST_INIT", + "SSH_AUTH_HOST", + "SSH_AUTH_KEY_INIT", + "SSH_AUTH_KEY", + "SSH_AUTH_GSSAPI", + "SSH_AUTH_DONE", + "SSH_SFTP_INIT", + "SSH_SFTP_REALPATH", + "SSH_SFTP_QUOTE_INIT", + "SSH_SFTP_POSTQUOTE_INIT", + "SSH_SFTP_QUOTE", + "SSH_SFTP_NEXT_QUOTE", + "SSH_SFTP_QUOTE_STAT", + "SSH_SFTP_QUOTE_SETSTAT", + "SSH_SFTP_QUOTE_SYMLINK", + "SSH_SFTP_QUOTE_MKDIR", + "SSH_SFTP_QUOTE_RENAME", + "SSH_SFTP_QUOTE_RMDIR", + "SSH_SFTP_QUOTE_UNLINK", + "SSH_SFTP_QUOTE_STATVFS", + "SSH_SFTP_GETINFO", + "SSH_SFTP_FILETIME", + "SSH_SFTP_TRANS_INIT", + "SSH_SFTP_UPLOAD_INIT", + "SSH_SFTP_CREATE_DIRS_INIT", + "SSH_SFTP_CREATE_DIRS", + "SSH_SFTP_CREATE_DIRS_MKDIR", + "SSH_SFTP_READDIR_INIT", + "SSH_SFTP_READDIR", + "SSH_SFTP_READDIR_LINK", + "SSH_SFTP_READDIR_BOTTOM", + "SSH_SFTP_READDIR_DONE", + "SSH_SFTP_DOWNLOAD_INIT", + "SSH_SFTP_DOWNLOAD_STAT", + "SSH_SFTP_CLOSE", + "SSH_SFTP_SHUTDOWN", + "SSH_SCP_TRANS_INIT", + "SSH_SCP_UPLOAD_INIT", + "SSH_SCP_DOWNLOAD_INIT", + "SSH_SCP_DOWNLOAD", + "SSH_SCP_DONE", + "SSH_SCP_SEND_EOF", + "SSH_SCP_WAIT_EOF", + "SSH_SCP_WAIT_CLOSE", + "SSH_SCP_CHANNEL_FREE", + "SSH_SESSION_DISCONNECT", + "SSH_SESSION_FREE", + "QUIT" + }; + /* a precaution to make sure the lists are in sync */ + DEBUGASSERT(CURL_ARRAYSIZE(names) == SSH_LAST); + return ((size_t)state < CURL_ARRAYSIZE(names)) ? names[state] : ""; +} +#endif /* CURLVERBOSE */ + +/* + * SSH State machine related code + */ +/* This is the ONLY way to change SSH state! */ +void Curl_ssh_set_state(struct Curl_easy *data, + struct ssh_conn *sshc, + sshstate nowstate) +{ +#ifdef CURLVERBOSE + if(sshc->state != nowstate) { + CURL_TRC_SSH(data, "[%s] -> [%s]", + Curl_ssh_statename(sshc->state), + Curl_ssh_statename(nowstate)); + } +#else + (void)data; +#endif + sshc->state = nowstate; +} + +#define MAX_SSHPATH_LEN 100000 /* arbitrary */ + +/* figure out the path to work with in this particular request */ +CURLcode Curl_getworkingpath(struct Curl_easy *data, + const char *homedir, /* when SFTP is used */ + char **path) /* returns the allocated + real path to work with */ +{ + char *working_path; + size_t working_path_len; + struct dynbuf npath; + CURLcode result = + Curl_urldecode(data->state.up.path, 0, &working_path, + &working_path_len, REJECT_ZERO); + if(result) + return result; + + /* new path to switch to in case we need to */ + curlx_dyn_init(&npath, MAX_SSHPATH_LEN); + + /* Check for /~/, indicating relative to the user's home directory */ + if((data->conn->scheme->protocol & CURLPROTO_SCP) && + (working_path_len > 3) && (!memcmp(working_path, "/~/", 3))) { + /* It is referenced to the home directory, so strip the leading '/~/' */ + if(curlx_dyn_addn(&npath, &working_path[3], working_path_len - 3)) { + curlx_free(working_path); + return CURLE_OUT_OF_MEMORY; + } + } + else if((data->conn->scheme->protocol & CURLPROTO_SFTP) && + (!strcmp("/~", working_path) || + ((working_path_len > 2) && !memcmp(working_path, "/~/", 3)))) { + if(curlx_dyn_add(&npath, homedir)) { + curlx_free(working_path); + return CURLE_OUT_OF_MEMORY; + } + if(working_path_len > 2) { + size_t len; + const char *p; + int copyfrom = 3; + /* Copy a separating '/' if homedir does not end with one */ + len = curlx_dyn_len(&npath); + p = curlx_dyn_ptr(&npath); + if(len && (p[len - 1] != '/')) + copyfrom = 2; + + if(curlx_dyn_addn(&npath, &working_path[copyfrom], + working_path_len - copyfrom)) { + curlx_free(working_path); + return CURLE_OUT_OF_MEMORY; + } + } + else { + if(curlx_dyn_add(&npath, "/")) { + curlx_free(working_path); + return CURLE_OUT_OF_MEMORY; + } + } + } + + if(curlx_dyn_len(&npath)) { + curlx_free(working_path); + + /* store the pointer for the caller to receive */ + *path = curlx_dyn_ptr(&npath); + } + else + *path = working_path; + DEBUGASSERT(*path && (*path)[0]); + + return CURLE_OK; +} + +#define MAX_PATHLENGTH 65535 /* arbitrary long */ + +CURLcode Curl_get_pathname(const char **cpp, char **path, const char *homedir) +{ + const char *cp = *cpp; + struct dynbuf out; + CURLcode result; + + DEBUGASSERT(homedir); + *path = NULL; + *cpp = NULL; + if(!*cp || !homedir) + return CURLE_QUOTE_ERROR; + + curlx_dyn_init(&out, MAX_PATHLENGTH); + + /* Ignore leading whitespace */ + curlx_str_passblanks(&cp); + + /* Check for quoted filenames */ + if(*cp == '\"' || *cp == '\'') { + char quot = *cp++; + + /* Search for terminating quote, unescape some chars */ + while(*cp != quot) { + if(!*cp) /* End of string */ + goto fail; + + if(*cp == '\\') { /* Escaped characters */ + cp++; + if(*cp != '\'' && *cp != '\"' && *cp != '\\') + goto fail; + } + result = curlx_dyn_addn(&out, cp, 1); + if(result) + return result; + cp++; + } + cp++; /* pass the end quote */ + + if(!curlx_dyn_len(&out)) + goto fail; + } + else { + struct Curl_str word; + bool content = FALSE; + int rc; + /* Handling for relative path - prepend home directory */ + if(cp[0] == '/' && cp[1] == '~' && cp[2] == '/') { + result = curlx_dyn_add(&out, homedir); + if(!result) + result = curlx_dyn_addn(&out, "/", 1); + if(result) + return result; + cp += 3; + content = TRUE; + } + /* Read to end of filename - either to whitespace or terminator */ + rc = curlx_str_word(&cp, &word, MAX_PATHLENGTH); + if(rc) { + if(rc == STRE_BIG) { + curlx_dyn_free(&out); + return CURLE_TOO_LARGE; + } + else if(!content) + /* no path, no word, this is incorrect */ + goto fail; + } + else { + /* append the word */ + result = curlx_dyn_addn(&out, curlx_str(&word), curlx_strlen(&word)); + if(result) + return result; + } + } + /* skip whitespace */ + curlx_str_passblanks(&cp); + + /* return pointer to second parameter if it exists */ + *cpp = cp; + + *path = curlx_dyn_ptr(&out); + return CURLE_OK; + +fail: + curlx_dyn_free(&out); + return CURLE_QUOTE_ERROR; +} + +CURLcode Curl_ssh_range(struct Curl_easy *data, + const char *range, curl_off_t filesize, + curl_off_t *startp, curl_off_t *sizep) +{ + curl_off_t from, to; + int to_t; + int from_t = curlx_str_number(&range, &from, CURL_OFF_T_MAX); + if(from_t == STRE_OVERFLOW) + return CURLE_RANGE_ERROR; + curlx_str_passblanks(&range); + (void)curlx_str_single(&range, '-'); + + to_t = curlx_str_numblanks(&range, &to); + if((to_t == STRE_OVERFLOW) || (to_t && from_t) || *range) + return CURLE_RANGE_ERROR; + + if(from_t) { + /* no start point given, set from relative to end of file */ + if(!to) + /* "-0" is not a fine range */ + return CURLE_RANGE_ERROR; + else if(to > filesize) + to = filesize; + from = filesize - to; + to = filesize - 1; + } + else if(from > filesize) { + failf(data, "Offset (%" FMT_OFF_T ") was beyond file size (%" + FMT_OFF_T ")", from, filesize); + return CURLE_RANGE_ERROR; + } + else if((to_t == STRE_NO_NUM) || (to >= filesize)) + to = filesize - 1; + + if(from > to) { + failf(data, "Bad range: start offset larger than end offset"); + return CURLE_RANGE_ERROR; + } + if((to - from) == CURL_OFF_T_MAX) + return CURLE_RANGE_ERROR; + + *startp = from; + *sizep = to - from + 1; + return CURLE_OK; +} + +#endif /* USE_SSH */ diff --git a/3rdparty/curl-8.21.0/lib/vssh/vssh.h b/3rdparty/curl-8.21.0/lib/vssh/vssh.h new file mode 100644 index 0000000000..492108fbd7 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vssh/vssh.h @@ -0,0 +1,42 @@ +#ifndef HEADER_CURL_VSSH_VSSH_H +#define HEADER_CURL_VSSH_VSSH_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_SSH + +#include "urldata.h" + +CURLcode Curl_getworkingpath(struct Curl_easy *data, + const char *homedir, + char **path); + +CURLcode Curl_get_pathname(const char **cpp, char **path, const char *homedir); + +CURLcode Curl_ssh_range(struct Curl_easy *data, + const char *range, curl_off_t filesize, + curl_off_t *startp, curl_off_t *sizep); +#endif /* USE_SSH */ +#endif /* HEADER_CURL_VSSH_VSSH_H */ diff --git a/3rdparty/curl-8.21.0/lib/vtls/apple.c b/3rdparty/curl-8.21.0/lib/vtls/apple.c new file mode 100644 index 0000000000..2e132f2977 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vtls/apple.c @@ -0,0 +1,291 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +/* This file is for implementing all "generic" SSL functions that all libcurl + internals should use. It is then responsible for calling the proper + "backend" function. + + SSL-functions in libcurl should call functions in this source file, and not + to any specific SSL-layer. + + Curl_ssl_ - prefix for generic ones + + Note that this source code uses the functions of the configured SSL + backend via the global Curl_ssl instance. + + "SSL/TLS Strong Encryption: An Introduction" + https://httpd.apache.org/docs/2.0/ssl/ssl_intro.html +*/ + +#include "curl_setup.h" + +#ifdef USE_APPLE_SECTRUST + +#include "urldata.h" +#include "cfilters.h" +#include "curl_trc.h" +#include "vtls/vtls.h" +#include "vtls/apple.h" + +#include + +#if (defined(MAC_OS_X_VERSION_MAX_ALLOWED) && \ + MAC_OS_X_VERSION_MAX_ALLOWED >= 101400) || \ + (defined(__IPHONE_OS_VERSION_MAX_ALLOWED) && \ + __IPHONE_OS_VERSION_MAX_ALLOWED >= 120000) +#define SUPPORTS_SecTrustEvaluateWithError 1 +#endif + +#if defined(SUPPORTS_SecTrustEvaluateWithError) && \ + ((defined(MAC_OS_X_VERSION_MIN_REQUIRED) && \ + MAC_OS_X_VERSION_MIN_REQUIRED >= 101400) || \ + (defined(__IPHONE_OS_VERSION_MIN_REQUIRED) && \ + __IPHONE_OS_VERSION_MIN_REQUIRED >= 120000)) +#define REQUIRES_SecTrustEvaluateWithError 1 +#endif + +#if defined(SUPPORTS_SecTrustEvaluateWithError) && \ + !defined(HAVE_BUILTIN_AVAILABLE) && \ + !defined(REQUIRES_SecTrustEvaluateWithError) +#undef SUPPORTS_SecTrustEvaluateWithError +#endif + +#if (defined(MAC_OS_X_VERSION_MAX_ALLOWED) && \ + MAC_OS_X_VERSION_MAX_ALLOWED >= 100900) || \ + (defined(__IPHONE_OS_VERSION_MAX_ALLOWED) && \ + __IPHONE_OS_VERSION_MAX_ALLOWED >= 70000) +#define SUPPORTS_SecOCSP 1 +#endif + +CURLcode Curl_vtls_apple_verify(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct ssl_peer *peer, + size_t num_certs, + Curl_vtls_get_cert_der *der_cb, + void *cb_user_data, + const unsigned char *ocsp_buf, + size_t ocsp_len) +{ + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + CURLcode result = CURLE_OK; + SecTrustRef trust = NULL; + SecPolicyRef policy = NULL; + CFMutableArrayRef policies = NULL; + CFMutableArrayRef cert_array = NULL; + CFStringRef host_str = NULL; + CFErrorRef error = NULL; + OSStatus status = noErr; + CFStringRef error_ref = NULL; + char *err_desc = NULL; + size_t i; + + if(conn_config->verifyhost) { + host_str = CFStringCreateWithCString(NULL, + peer->sni ? peer->sni : peer->origin->hostname, kCFStringEncodingUTF8); + if(!host_str) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + } + + policies = CFArrayCreateMutable(NULL, 2, &kCFTypeArrayCallBacks); + if(!policies) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + policy = SecPolicyCreateSSL(true, host_str); + if(!policy) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + CFArrayAppendValue(policies, policy); + CFRelease(policy); + policy = NULL; + +#if defined(HAVE_BUILTIN_AVAILABLE) && defined(SUPPORTS_SecOCSP) + { + struct ssl_config_data *ssl_config = Curl_ssl_cf_get_config(cf, data); + if(!ssl_config->no_revoke) { + if(__builtin_available(macOS 10.9, iOS 7, tvOS 9, watchOS 2, *)) { + /* Even without this set, validation seemingly-unavoidably fails + * for certificates that trustd already knows to be revoked. + * This policy further allows trustd to consult CRLs and OCSP data + * to determine revocation status (which it may then cache). */ + CFOptionFlags revocation_flags = kSecRevocationUseAnyAvailableMethod; +#if 0 + /* `revoke_best_effort` is off by default in libcurl. When we + * add `kSecRevocationRequirePositiveResponse` to the Apple + * Trust policies, it interprets this as it NEEDs a confirmation + * of a cert being NOT REVOKED. Which not in general available for + * certificates on the Internet. + * It seems that applications using this policy are expected to PIN + * their certificate public keys or verification fails. + * This does not seem to be what we want here. */ + if(!ssl_config->revoke_best_effort) { + revocation_flags |= kSecRevocationRequirePositiveResponse; + } +#endif + policy = SecPolicyCreateRevocation(revocation_flags); + if(!policy) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + CFArrayAppendValue(policies, policy); + } + } + } +#endif + + cert_array = CFArrayCreateMutable(NULL, num_certs, &kCFTypeArrayCallBacks); + if(!cert_array) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + for(i = 0; i < num_certs; i++) { + SecCertificateRef cert; + CFDataRef certdata; + unsigned char *der; + size_t der_len; + + result = der_cb(cf, data, cb_user_data, i, &der, &der_len); + if(result) + goto out; + + certdata = CFDataCreate(NULL, der, (CFIndex)der_len); + if(!certdata) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + cert = SecCertificateCreateWithData(NULL, certdata); + CFRelease(certdata); + if(!cert) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + CFArrayAppendValue(cert_array, cert); + CFRelease(cert); + } + + status = SecTrustCreateWithCertificates(cert_array, policies, &trust); + if(status != noErr || !trust) { + failf(data, "Apple SecTrust: failed to create validation trust"); + result = CURLE_PEER_FAILED_VERIFICATION; + goto out; + } + +#if defined(HAVE_BUILTIN_AVAILABLE) && defined(SUPPORTS_SecOCSP) + if(ocsp_len > 0) { + if(__builtin_available(macOS 10.9, iOS 7, tvOS 9, watchOS 2, *)) { + CFDataRef ocspdata = CFDataCreate(NULL, ocsp_buf, (CFIndex)ocsp_len); + + status = SecTrustSetOCSPResponse(trust, ocspdata); + CFRelease(ocspdata); + if(status != noErr) { + failf(data, "Apple SecTrust: failed to set OCSP response: %d", + (int)status); + result = CURLE_PEER_FAILED_VERIFICATION; + goto out; + } + } + } +#else + (void)ocsp_buf; + (void)ocsp_len; +#endif + +#ifdef SUPPORTS_SecTrustEvaluateWithError +#ifdef HAVE_BUILTIN_AVAILABLE + if(__builtin_available(macOS 10.14, iOS 12, tvOS 12, watchOS 5, *)) { +#else + if(1) { +#endif + result = SecTrustEvaluateWithError(trust, &error) ? + CURLE_OK : CURLE_PEER_FAILED_VERIFICATION; + if(error) { + VERBOSE(CFIndex code = CFErrorGetCode(error)); + error_ref = CFErrorCopyDescription(error); + + if(error_ref) { + CFIndex size = CFStringGetMaximumSizeForEncoding( + CFStringGetLength(error_ref), kCFStringEncodingUTF8); + err_desc = curlx_malloc(size + 1); + if(err_desc) { + if(!CFStringGetCString(error_ref, err_desc, size, + kCFStringEncodingUTF8)) + curlx_safefree(err_desc); + } + } + infof(data, "Apple SecTrust failure %ld%s%s", code, + err_desc ? ": " : "", err_desc ? err_desc : ""); + } + } + else +#endif /* SUPPORTS_SecTrustEvaluateWithError */ + { +#ifndef REQUIRES_SecTrustEvaluateWithError + SecTrustResultType sec_result; + status = SecTrustEvaluate(trust, &sec_result); + + if(status != noErr) { + failf(data, "Apple SecTrust verification failed: error %d", (int)status); + result = CURLE_PEER_FAILED_VERIFICATION; + } + else if((sec_result == kSecTrustResultUnspecified) || + (sec_result == kSecTrustResultProceed)) { + /* "unspecified" means system-trusted with no explicit user setting */ + result = CURLE_OK; + } + else { + /* Any other trust result is a verification failure in this context */ + result = CURLE_PEER_FAILED_VERIFICATION; + } +#endif /* REQUIRES_SecTrustEvaluateWithError */ + } + +out: + curlx_free(err_desc); + if(error_ref) + CFRelease(error_ref); + if(error) + CFRelease(error); + if(host_str) + CFRelease(host_str); + if(policies) + CFRelease(policies); + if(policy) + CFRelease(policy); + if(cert_array) + CFRelease(cert_array); + if(trust) + CFRelease(trust); + return result; +} + +#endif /* USE_APPLE_SECTRUST */ diff --git a/3rdparty/curl-8.21.0/lib/vtls/apple.h b/3rdparty/curl-8.21.0/lib/vtls/apple.h new file mode 100644 index 0000000000..d86a56b1f9 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vtls/apple.h @@ -0,0 +1,54 @@ +#ifndef HEADER_CURL_VTLS_APPLE_H +#define HEADER_CURL_VTLS_APPLE_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Jan Venekamp, + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_APPLE_SECTRUST +struct Curl_cfilter; +struct Curl_easy; +struct ssl_peer; + +/* Get the DER encoded i-th certificate in the server handshake */ +typedef CURLcode Curl_vtls_get_cert_der(struct Curl_cfilter *cf, + struct Curl_easy *data, + void *user_data, + size_t i, + unsigned char **pder, + size_t *pder_len); + +/* Ask Apple's Security framework to verify the certificate chain + * send by the peer. On CURLE_OK it has been verified. + */ +CURLcode Curl_vtls_apple_verify(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct ssl_peer *peer, + size_t num_certs, + Curl_vtls_get_cert_der *der_cb, + void *cb_user_data, + const unsigned char *ocsp_buf, + size_t ocsp_len); +#endif /* USE_APPLE_SECTRUST */ + +#endif /* HEADER_CURL_VTLS_APPLE_H */ diff --git a/3rdparty/curl-8.21.0/lib/vtls/cipher_suite.c b/3rdparty/curl-8.21.0/lib/vtls/cipher_suite.c new file mode 100644 index 0000000000..197055fc0d --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vtls/cipher_suite.c @@ -0,0 +1,702 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Jan Venekamp, + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if defined(USE_MBEDTLS) || defined(USE_RUSTLS) + +#include "vtls/cipher_suite.h" + +/* + * To support the CURLOPT_SSL_CIPHER_LIST option on SSL backends + * that do not support it natively, but do support setting a list of + * IANA ids, we need a list of all supported cipher suite names + * (OpenSSL and IANA) to be able to look up the IANA ids. + * + * To keep the binary size of this list down we compress each entry + * down to 2 + 6 bytes using the C preprocessor. + */ + +/* + * mbedTLS NOTE: mbedTLS has mbedtls_ssl_get_ciphersuite_id() to + * convert a string representation to an IANA id, we do not use that + * because it does not support "standard" OpenSSL cipher suite + * names, nor IANA names. + */ + +/* NOTE: also see tests/unit/unit3205.c */ + +/* Text for cipher suite parts (max 64 entries), + keep indexes below in sync with this! */ +static const char *cs_txt = + "\0" + "TLS" "\0" + "WITH" "\0" + "128" "\0" + "256" "\0" + "3DES" "\0" + "8" "\0" + "AES" "\0" + "AES128" "\0" + "AES256" "\0" + "CBC" "\0" + "CBC3" "\0" + "CCM" "\0" + "CCM8" "\0" + "CHACHA20" "\0" + "DES" "\0" + "DHE" "\0" + "ECDH" "\0" + "ECDHE" "\0" + "ECDSA" "\0" + "EDE" "\0" /* spellchecker:disable-line */ + "GCM" "\0" + "MD5" "\0" + "NULL" "\0" + "POLY1305" "\0" + "PSK" "\0" + "RSA" "\0" + "SHA" "\0" + "SHA256" "\0" + "SHA384" "\0" +#ifdef USE_MBEDTLS + "ARIA" "\0" + "ARIA128" "\0" + "ARIA256" "\0" + "CAMELLIA" "\0" + "CAMELLIA128" "\0" + "CAMELLIA256" "\0" +#endif +; +/* Indexes of above cs_txt */ +enum { + CS_TXT_IDX_, + CS_TXT_IDX_TLS, + CS_TXT_IDX_WITH, + CS_TXT_IDX_128, + CS_TXT_IDX_256, + CS_TXT_IDX_3DES, + CS_TXT_IDX_8, + CS_TXT_IDX_AES, + CS_TXT_IDX_AES128, + CS_TXT_IDX_AES256, + CS_TXT_IDX_CBC, + CS_TXT_IDX_CBC3, + CS_TXT_IDX_CCM, + CS_TXT_IDX_CCM8, + CS_TXT_IDX_CHACHA20, + CS_TXT_IDX_DES, + CS_TXT_IDX_DHE, + CS_TXT_IDX_ECDH, + CS_TXT_IDX_ECDHE, + CS_TXT_IDX_ECDSA, + CS_TXT_IDX_EDE, /* spellchecker:disable-line */ + CS_TXT_IDX_GCM, + CS_TXT_IDX_MD5, + CS_TXT_IDX_NULL, + CS_TXT_IDX_POLY1305, + CS_TXT_IDX_PSK, + CS_TXT_IDX_RSA, + CS_TXT_IDX_SHA, + CS_TXT_IDX_SHA256, + CS_TXT_IDX_SHA384, +#ifdef USE_MBEDTLS + CS_TXT_IDX_ARIA, + CS_TXT_IDX_ARIA128, + CS_TXT_IDX_ARIA256, + CS_TXT_IDX_CAMELLIA, + CS_TXT_IDX_CAMELLIA128, + CS_TXT_IDX_CAMELLIA256, +#endif + CS_TXT_LEN, +}; + +#define CS_ZIP_IDX(a, b, c, d, e, f, g, h) \ +{ \ + (uint8_t)((((a) << 2) & 0xFF) | ((b) & 0x3F) >> 4), \ + (uint8_t)((((b) << 4) & 0xFF) | ((c) & 0x3F) >> 2), \ + (uint8_t)((((c) << 6) & 0xFF) | ((d) & 0x3F)), \ + (uint8_t)((((e) << 2) & 0xFF) | ((f) & 0x3F) >> 4), \ + (uint8_t)((((f) << 4) & 0xFF) | ((g) & 0x3F) >> 2), \ + (uint8_t)((((g) << 6) & 0xFF) | ((h) & 0x3F)) \ +} +#define CS_ENTRY(id, a, b, c, d, e, f, g, h) \ +{ \ + id, \ + CS_ZIP_IDX( \ + CS_TXT_IDX_ ## a, CS_TXT_IDX_ ## b, \ + CS_TXT_IDX_ ## c, CS_TXT_IDX_ ## d, \ + CS_TXT_IDX_ ## e, CS_TXT_IDX_ ## f, \ + CS_TXT_IDX_ ## g, CS_TXT_IDX_ ## h \ + ) \ +} + +struct cs_entry { + uint16_t id; + uint8_t zip[6]; +}; + +/* !checksrc! disable COMMANOSPACE all */ +static const struct cs_entry cs_list[] = { + /* TLS 1.3 ciphers */ + CS_ENTRY(0x1301, TLS,AES,128,GCM,SHA256,,,), + CS_ENTRY(0x1302, TLS,AES,256,GCM,SHA384,,,), + CS_ENTRY(0x1303, TLS,CHACHA20,POLY1305,SHA256,,,,), + CS_ENTRY(0x1304, TLS,AES,128,CCM,SHA256,,,), + CS_ENTRY(0x1305, TLS,AES,128,CCM,8,SHA256,,), + /* TLS 1.2 ciphers */ + CS_ENTRY(0xC02B, TLS,ECDHE,ECDSA,WITH,AES,128,GCM,SHA256), + CS_ENTRY(0xC02B, ECDHE,ECDSA,AES128,GCM,SHA256,,,), + CS_ENTRY(0xC02C, TLS,ECDHE,ECDSA,WITH,AES,256,GCM,SHA384), + CS_ENTRY(0xC02C, ECDHE,ECDSA,AES256,GCM,SHA384,,,), + CS_ENTRY(0xC02F, TLS,ECDHE,RSA,WITH,AES,128,GCM,SHA256), + CS_ENTRY(0xC02F, ECDHE,RSA,AES128,GCM,SHA256,,,), + CS_ENTRY(0xC030, TLS,ECDHE,RSA,WITH,AES,256,GCM,SHA384), + CS_ENTRY(0xC030, ECDHE,RSA,AES256,GCM,SHA384,,,), + CS_ENTRY(0xCCA8, TLS,ECDHE,RSA,WITH,CHACHA20,POLY1305,SHA256,), + CS_ENTRY(0xCCA8, ECDHE,RSA,CHACHA20,POLY1305,,,,), + CS_ENTRY(0xCCA9, TLS,ECDHE,ECDSA,WITH,CHACHA20,POLY1305,SHA256,), + CS_ENTRY(0xCCA9, ECDHE,ECDSA,CHACHA20,POLY1305,,,,), +#ifdef USE_MBEDTLS + CS_ENTRY(0x002F, TLS,RSA,WITH,AES,128,CBC,SHA,), + CS_ENTRY(0x002F, AES128,SHA,,,,,,), + CS_ENTRY(0x0035, TLS,RSA,WITH,AES,256,CBC,SHA,), + CS_ENTRY(0x0035, AES256,SHA,,,,,,), + CS_ENTRY(0x003C, TLS,RSA,WITH,AES,128,CBC,SHA256,), + CS_ENTRY(0x003C, AES128,SHA256,,,,,,), + CS_ENTRY(0x003D, TLS,RSA,WITH,AES,256,CBC,SHA256,), + CS_ENTRY(0x003D, AES256,SHA256,,,,,,), + CS_ENTRY(0x009C, TLS,RSA,WITH,AES,128,GCM,SHA256,), + CS_ENTRY(0x009C, AES128,GCM,SHA256,,,,,), + CS_ENTRY(0x009D, TLS,RSA,WITH,AES,256,GCM,SHA384,), + CS_ENTRY(0x009D, AES256,GCM,SHA384,,,,,), + CS_ENTRY(0xC004, TLS,ECDH,ECDSA,WITH,AES,128,CBC,SHA), + CS_ENTRY(0xC004, ECDH,ECDSA,AES128,SHA,,,,), + CS_ENTRY(0xC005, TLS,ECDH,ECDSA,WITH,AES,256,CBC,SHA), + CS_ENTRY(0xC005, ECDH,ECDSA,AES256,SHA,,,,), + CS_ENTRY(0xC009, TLS,ECDHE,ECDSA,WITH,AES,128,CBC,SHA), + CS_ENTRY(0xC009, ECDHE,ECDSA,AES128,SHA,,,,), + CS_ENTRY(0xC00A, TLS,ECDHE,ECDSA,WITH,AES,256,CBC,SHA), + CS_ENTRY(0xC00A, ECDHE,ECDSA,AES256,SHA,,,,), + CS_ENTRY(0xC00E, TLS,ECDH,RSA,WITH,AES,128,CBC,SHA), + CS_ENTRY(0xC00E, ECDH,RSA,AES128,SHA,,,,), + CS_ENTRY(0xC00F, TLS,ECDH,RSA,WITH,AES,256,CBC,SHA), + CS_ENTRY(0xC00F, ECDH,RSA,AES256,SHA,,,,), + CS_ENTRY(0xC013, TLS,ECDHE,RSA,WITH,AES,128,CBC,SHA), + CS_ENTRY(0xC013, ECDHE,RSA,AES128,SHA,,,,), + CS_ENTRY(0xC014, TLS,ECDHE,RSA,WITH,AES,256,CBC,SHA), + CS_ENTRY(0xC014, ECDHE,RSA,AES256,SHA,,,,), + CS_ENTRY(0xC023, TLS,ECDHE,ECDSA,WITH,AES,128,CBC,SHA256), + CS_ENTRY(0xC023, ECDHE,ECDSA,AES128,SHA256,,,,), + CS_ENTRY(0xC024, TLS,ECDHE,ECDSA,WITH,AES,256,CBC,SHA384), + CS_ENTRY(0xC024, ECDHE,ECDSA,AES256,SHA384,,,,), + CS_ENTRY(0xC025, TLS,ECDH,ECDSA,WITH,AES,128,CBC,SHA256), + CS_ENTRY(0xC025, ECDH,ECDSA,AES128,SHA256,,,,), + CS_ENTRY(0xC026, TLS,ECDH,ECDSA,WITH,AES,256,CBC,SHA384), + CS_ENTRY(0xC026, ECDH,ECDSA,AES256,SHA384,,,,), + CS_ENTRY(0xC027, TLS,ECDHE,RSA,WITH,AES,128,CBC,SHA256), + CS_ENTRY(0xC027, ECDHE,RSA,AES128,SHA256,,,,), + CS_ENTRY(0xC028, TLS,ECDHE,RSA,WITH,AES,256,CBC,SHA384), + CS_ENTRY(0xC028, ECDHE,RSA,AES256,SHA384,,,,), + CS_ENTRY(0xC029, TLS,ECDH,RSA,WITH,AES,128,CBC,SHA256), + CS_ENTRY(0xC029, ECDH,RSA,AES128,SHA256,,,,), + CS_ENTRY(0xC02A, TLS,ECDH,RSA,WITH,AES,256,CBC,SHA384), + CS_ENTRY(0xC02A, ECDH,RSA,AES256,SHA384,,,,), + CS_ENTRY(0xC02D, TLS,ECDH,ECDSA,WITH,AES,128,GCM,SHA256), + CS_ENTRY(0xC02D, ECDH,ECDSA,AES128,GCM,SHA256,,,), + CS_ENTRY(0xC02E, TLS,ECDH,ECDSA,WITH,AES,256,GCM,SHA384), + CS_ENTRY(0xC02E, ECDH,ECDSA,AES256,GCM,SHA384,,,), + CS_ENTRY(0xC031, TLS,ECDH,RSA,WITH,AES,128,GCM,SHA256), + CS_ENTRY(0xC031, ECDH,RSA,AES128,GCM,SHA256,,,), + CS_ENTRY(0xC032, TLS,ECDH,RSA,WITH,AES,256,GCM,SHA384), + CS_ENTRY(0xC032, ECDH,RSA,AES256,GCM,SHA384,,,), + CS_ENTRY(0x0001, TLS,RSA,WITH,NULL,MD5,,,), + CS_ENTRY(0x0001, NULL,MD5,,,,,,), + CS_ENTRY(0x0002, TLS,RSA,WITH,NULL,SHA,,,), + CS_ENTRY(0x0002, NULL,SHA,,,,,,), + CS_ENTRY(0x002C, TLS,PSK,WITH,NULL,SHA,,,), + CS_ENTRY(0x002C, PSK,NULL,SHA,,,,,), + CS_ENTRY(0x002D, TLS,DHE,PSK,WITH,NULL,SHA,,), + CS_ENTRY(0x002D, DHE,PSK,NULL,SHA,,,,), + CS_ENTRY(0x002E, TLS,RSA,PSK,WITH,NULL,SHA,,), + CS_ENTRY(0x002E, RSA,PSK,NULL,SHA,,,,), + CS_ENTRY(0x0033, TLS,DHE,RSA,WITH,AES,128,CBC,SHA), + CS_ENTRY(0x0033, DHE,RSA,AES128,SHA,,,,), + CS_ENTRY(0x0039, TLS,DHE,RSA,WITH,AES,256,CBC,SHA), + CS_ENTRY(0x0039, DHE,RSA,AES256,SHA,,,,), + CS_ENTRY(0x003B, TLS,RSA,WITH,NULL,SHA256,,,), + CS_ENTRY(0x003B, NULL,SHA256,,,,,,), + CS_ENTRY(0x0067, TLS,DHE,RSA,WITH,AES,128,CBC,SHA256), + CS_ENTRY(0x0067, DHE,RSA,AES128,SHA256,,,,), + CS_ENTRY(0x006B, TLS,DHE,RSA,WITH,AES,256,CBC,SHA256), + CS_ENTRY(0x006B, DHE,RSA,AES256,SHA256,,,,), + CS_ENTRY(0x008C, TLS,PSK,WITH,AES,128,CBC,SHA,), + CS_ENTRY(0x008C, PSK,AES128,CBC,SHA,,,,), + CS_ENTRY(0x008D, TLS,PSK,WITH,AES,256,CBC,SHA,), + CS_ENTRY(0x008D, PSK,AES256,CBC,SHA,,,,), + CS_ENTRY(0x0090, TLS,DHE,PSK,WITH,AES,128,CBC,SHA), + CS_ENTRY(0x0090, DHE,PSK,AES128,CBC,SHA,,,), + CS_ENTRY(0x0091, TLS,DHE,PSK,WITH,AES,256,CBC,SHA), + CS_ENTRY(0x0091, DHE,PSK,AES256,CBC,SHA,,,), + CS_ENTRY(0x0094, TLS,RSA,PSK,WITH,AES,128,CBC,SHA), + CS_ENTRY(0x0094, RSA,PSK,AES128,CBC,SHA,,,), + CS_ENTRY(0x0095, TLS,RSA,PSK,WITH,AES,256,CBC,SHA), + CS_ENTRY(0x0095, RSA,PSK,AES256,CBC,SHA,,,), + CS_ENTRY(0x009E, TLS,DHE,RSA,WITH,AES,128,GCM,SHA256), + CS_ENTRY(0x009E, DHE,RSA,AES128,GCM,SHA256,,,), + CS_ENTRY(0x009F, TLS,DHE,RSA,WITH,AES,256,GCM,SHA384), + CS_ENTRY(0x009F, DHE,RSA,AES256,GCM,SHA384,,,), + CS_ENTRY(0x00A8, TLS,PSK,WITH,AES,128,GCM,SHA256,), + CS_ENTRY(0x00A8, PSK,AES128,GCM,SHA256,,,,), + CS_ENTRY(0x00A9, TLS,PSK,WITH,AES,256,GCM,SHA384,), + CS_ENTRY(0x00A9, PSK,AES256,GCM,SHA384,,,,), + CS_ENTRY(0x00AA, TLS,DHE,PSK,WITH,AES,128,GCM,SHA256), + CS_ENTRY(0x00AA, DHE,PSK,AES128,GCM,SHA256,,,), + CS_ENTRY(0x00AB, TLS,DHE,PSK,WITH,AES,256,GCM,SHA384), + CS_ENTRY(0x00AB, DHE,PSK,AES256,GCM,SHA384,,,), + CS_ENTRY(0x00AC, TLS,RSA,PSK,WITH,AES,128,GCM,SHA256), + CS_ENTRY(0x00AC, RSA,PSK,AES128,GCM,SHA256,,,), + CS_ENTRY(0x00AD, TLS,RSA,PSK,WITH,AES,256,GCM,SHA384), + CS_ENTRY(0x00AD, RSA,PSK,AES256,GCM,SHA384,,,), + CS_ENTRY(0x00AE, TLS,PSK,WITH,AES,128,CBC,SHA256,), + CS_ENTRY(0x00AE, PSK,AES128,CBC,SHA256,,,,), + CS_ENTRY(0x00AF, TLS,PSK,WITH,AES,256,CBC,SHA384,), + CS_ENTRY(0x00AF, PSK,AES256,CBC,SHA384,,,,), + CS_ENTRY(0x00B0, TLS,PSK,WITH,NULL,SHA256,,,), + CS_ENTRY(0x00B0, PSK,NULL,SHA256,,,,,), + CS_ENTRY(0x00B1, TLS,PSK,WITH,NULL,SHA384,,,), + CS_ENTRY(0x00B1, PSK,NULL,SHA384,,,,,), + CS_ENTRY(0x00B2, TLS,DHE,PSK,WITH,AES,128,CBC,SHA256), + CS_ENTRY(0x00B2, DHE,PSK,AES128,CBC,SHA256,,,), + CS_ENTRY(0x00B3, TLS,DHE,PSK,WITH,AES,256,CBC,SHA384), + CS_ENTRY(0x00B3, DHE,PSK,AES256,CBC,SHA384,,,), + CS_ENTRY(0x00B4, TLS,DHE,PSK,WITH,NULL,SHA256,,), + CS_ENTRY(0x00B4, DHE,PSK,NULL,SHA256,,,,), + CS_ENTRY(0x00B5, TLS,DHE,PSK,WITH,NULL,SHA384,,), + CS_ENTRY(0x00B5, DHE,PSK,NULL,SHA384,,,,), + CS_ENTRY(0x00B6, TLS,RSA,PSK,WITH,AES,128,CBC,SHA256), + CS_ENTRY(0x00B6, RSA,PSK,AES128,CBC,SHA256,,,), + CS_ENTRY(0x00B7, TLS,RSA,PSK,WITH,AES,256,CBC,SHA384), + CS_ENTRY(0x00B7, RSA,PSK,AES256,CBC,SHA384,,,), + CS_ENTRY(0x00B8, TLS,RSA,PSK,WITH,NULL,SHA256,,), + CS_ENTRY(0x00B8, RSA,PSK,NULL,SHA256,,,,), + CS_ENTRY(0x00B9, TLS,RSA,PSK,WITH,NULL,SHA384,,), + CS_ENTRY(0x00B9, RSA,PSK,NULL,SHA384,,,,), + CS_ENTRY(0xC001, TLS,ECDH,ECDSA,WITH,NULL,SHA,,), + CS_ENTRY(0xC001, ECDH,ECDSA,NULL,SHA,,,,), + CS_ENTRY(0xC006, TLS,ECDHE,ECDSA,WITH,NULL,SHA,,), + CS_ENTRY(0xC006, ECDHE,ECDSA,NULL,SHA,,,,), + CS_ENTRY(0xC00B, TLS,ECDH,RSA,WITH,NULL,SHA,,), + CS_ENTRY(0xC00B, ECDH,RSA,NULL,SHA,,,,), + CS_ENTRY(0xC010, TLS,ECDHE,RSA,WITH,NULL,SHA,,), + CS_ENTRY(0xC010, ECDHE,RSA,NULL,SHA,,,,), + CS_ENTRY(0xC035, TLS,ECDHE,PSK,WITH,AES,128,CBC,SHA), + CS_ENTRY(0xC035, ECDHE,PSK,AES128,CBC,SHA,,,), + CS_ENTRY(0xC036, TLS,ECDHE,PSK,WITH,AES,256,CBC,SHA), + CS_ENTRY(0xC036, ECDHE,PSK,AES256,CBC,SHA,,,), + CS_ENTRY(0xCCAB, TLS,PSK,WITH,CHACHA20,POLY1305,SHA256,,), + CS_ENTRY(0xCCAB, PSK,CHACHA20,POLY1305,,,,,), + CS_ENTRY(0xC09C, TLS,RSA,WITH,AES,128,CCM,,), + CS_ENTRY(0xC09C, AES128,CCM,,,,,,), + CS_ENTRY(0xC09D, TLS,RSA,WITH,AES,256,CCM,,), + CS_ENTRY(0xC09D, AES256,CCM,,,,,,), + CS_ENTRY(0xC0A0, TLS,RSA,WITH,AES,128,CCM,8,), + CS_ENTRY(0xC0A0, AES128,CCM8,,,,,,), + CS_ENTRY(0xC0A1, TLS,RSA,WITH,AES,256,CCM,8,), + CS_ENTRY(0xC0A1, AES256,CCM8,,,,,,), + CS_ENTRY(0xC0AC, TLS,ECDHE,ECDSA,WITH,AES,128,CCM,), + CS_ENTRY(0xC0AC, ECDHE,ECDSA,AES128,CCM,,,,), + CS_ENTRY(0xC0AD, TLS,ECDHE,ECDSA,WITH,AES,256,CCM,), + CS_ENTRY(0xC0AD, ECDHE,ECDSA,AES256,CCM,,,,), + CS_ENTRY(0xC0AE, TLS,ECDHE,ECDSA,WITH,AES,128,CCM,8), + CS_ENTRY(0xC0AE, ECDHE,ECDSA,AES128,CCM8,,,,), + CS_ENTRY(0xC0AF, TLS,ECDHE,ECDSA,WITH,AES,256,CCM,8), + CS_ENTRY(0xC0AF, ECDHE,ECDSA,AES256,CCM8,,,,), + /* entries marked ns are "non-standard", they are not in OpenSSL */ + CS_ENTRY(0x0041, TLS,RSA,WITH,CAMELLIA,128,CBC,SHA,), + CS_ENTRY(0x0041, CAMELLIA128,SHA,,,,,,), + CS_ENTRY(0x0045, TLS,DHE,RSA,WITH,CAMELLIA,128,CBC,SHA), + CS_ENTRY(0x0045, DHE,RSA,CAMELLIA128,SHA,,,,), + CS_ENTRY(0x0084, TLS,RSA,WITH,CAMELLIA,256,CBC,SHA,), + CS_ENTRY(0x0084, CAMELLIA256,SHA,,,,,,), + CS_ENTRY(0x0088, TLS,DHE,RSA,WITH,CAMELLIA,256,CBC,SHA), + CS_ENTRY(0x0088, DHE,RSA,CAMELLIA256,SHA,,,,), + CS_ENTRY(0x00BA, TLS,RSA,WITH,CAMELLIA,128,CBC,SHA256,), + CS_ENTRY(0x00BA, CAMELLIA128,SHA256,,,,,,), + CS_ENTRY(0x00BE, TLS,DHE,RSA,WITH,CAMELLIA,128,CBC,SHA256), + CS_ENTRY(0x00BE, DHE,RSA,CAMELLIA128,SHA256,,,,), + CS_ENTRY(0x00C0, TLS,RSA,WITH,CAMELLIA,256,CBC,SHA256,), + CS_ENTRY(0x00C0, CAMELLIA256,SHA256,,,,,,), + CS_ENTRY(0x00C4, TLS,DHE,RSA,WITH,CAMELLIA,256,CBC,SHA256), + CS_ENTRY(0x00C4, DHE,RSA,CAMELLIA256,SHA256,,,,), + CS_ENTRY(0xC037, TLS,ECDHE,PSK,WITH,AES,128,CBC,SHA256), + CS_ENTRY(0xC037, ECDHE,PSK,AES128,CBC,SHA256,,,), + CS_ENTRY(0xC038, TLS,ECDHE,PSK,WITH,AES,256,CBC,SHA384), + CS_ENTRY(0xC038, ECDHE,PSK,AES256,CBC,SHA384,,,), + CS_ENTRY(0xC039, TLS,ECDHE,PSK,WITH,NULL,SHA,,), + CS_ENTRY(0xC039, ECDHE,PSK,NULL,SHA,,,,), + CS_ENTRY(0xC03A, TLS,ECDHE,PSK,WITH,NULL,SHA256,,), + CS_ENTRY(0xC03A, ECDHE,PSK,NULL,SHA256,,,,), + CS_ENTRY(0xC03B, TLS,ECDHE,PSK,WITH,NULL,SHA384,,), + CS_ENTRY(0xC03B, ECDHE,PSK,NULL,SHA384,,,,), + CS_ENTRY(0xC03C, TLS,RSA,WITH,ARIA,128,CBC,SHA256,), + CS_ENTRY(0xC03C, ARIA128,SHA256,,,,,,), /* ns */ + CS_ENTRY(0xC03D, TLS,RSA,WITH,ARIA,256,CBC,SHA384,), + CS_ENTRY(0xC03D, ARIA256,SHA384,,,,,,), /* ns */ + CS_ENTRY(0xC044, TLS,DHE,RSA,WITH,ARIA,128,CBC,SHA256), + CS_ENTRY(0xC044, DHE,RSA,ARIA128,SHA256,,,,), /* ns */ + CS_ENTRY(0xC045, TLS,DHE,RSA,WITH,ARIA,256,CBC,SHA384), + CS_ENTRY(0xC045, DHE,RSA,ARIA256,SHA384,,,,), /* ns */ + CS_ENTRY(0xC048, TLS,ECDHE,ECDSA,WITH,ARIA,128,CBC,SHA256), + CS_ENTRY(0xC048, ECDHE,ECDSA,ARIA128,SHA256,,,,), /* ns */ + CS_ENTRY(0xC049, TLS,ECDHE,ECDSA,WITH,ARIA,256,CBC,SHA384), + CS_ENTRY(0xC049, ECDHE,ECDSA,ARIA256,SHA384,,,,), /* ns */ + CS_ENTRY(0xC04A, TLS,ECDH,ECDSA,WITH,ARIA,128,CBC,SHA256), + CS_ENTRY(0xC04A, ECDH,ECDSA,ARIA128,SHA256,,,,), /* ns */ + CS_ENTRY(0xC04B, TLS,ECDH,ECDSA,WITH,ARIA,256,CBC,SHA384), + CS_ENTRY(0xC04B, ECDH,ECDSA,ARIA256,SHA384,,,,), /* ns */ + CS_ENTRY(0xC04C, TLS,ECDHE,RSA,WITH,ARIA,128,CBC,SHA256), + CS_ENTRY(0xC04C, ECDHE,ARIA128,SHA256,,,,,), /* ns */ + CS_ENTRY(0xC04D, TLS,ECDHE,RSA,WITH,ARIA,256,CBC,SHA384), + CS_ENTRY(0xC04D, ECDHE,ARIA256,SHA384,,,,,), /* ns */ + CS_ENTRY(0xC04E, TLS,ECDH,RSA,WITH,ARIA,128,CBC,SHA256), + CS_ENTRY(0xC04E, ECDH,ARIA128,SHA256,,,,,), /* ns */ + CS_ENTRY(0xC04F, TLS,ECDH,RSA,WITH,ARIA,256,CBC,SHA384), + CS_ENTRY(0xC04F, ECDH,ARIA256,SHA384,,,,,), /* ns */ + CS_ENTRY(0xC050, TLS,RSA,WITH,ARIA,128,GCM,SHA256,), + CS_ENTRY(0xC050, ARIA128,GCM,SHA256,,,,,), + CS_ENTRY(0xC051, TLS,RSA,WITH,ARIA,256,GCM,SHA384,), + CS_ENTRY(0xC051, ARIA256,GCM,SHA384,,,,,), + CS_ENTRY(0xC052, TLS,DHE,RSA,WITH,ARIA,128,GCM,SHA256), + CS_ENTRY(0xC052, DHE,RSA,ARIA128,GCM,SHA256,,,), + CS_ENTRY(0xC053, TLS,DHE,RSA,WITH,ARIA,256,GCM,SHA384), + CS_ENTRY(0xC053, DHE,RSA,ARIA256,GCM,SHA384,,,), + CS_ENTRY(0xC05C, TLS,ECDHE,ECDSA,WITH,ARIA,128,GCM,SHA256), + CS_ENTRY(0xC05C, ECDHE,ECDSA,ARIA128,GCM,SHA256,,,), + CS_ENTRY(0xC05D, TLS,ECDHE,ECDSA,WITH,ARIA,256,GCM,SHA384), + CS_ENTRY(0xC05D, ECDHE,ECDSA,ARIA256,GCM,SHA384,,,), + CS_ENTRY(0xC05E, TLS,ECDH,ECDSA,WITH,ARIA,128,GCM,SHA256), + CS_ENTRY(0xC05E, ECDH,ECDSA,ARIA128,GCM,SHA256,,,), /* ns */ + CS_ENTRY(0xC05F, TLS,ECDH,ECDSA,WITH,ARIA,256,GCM,SHA384), + CS_ENTRY(0xC05F, ECDH,ECDSA,ARIA256,GCM,SHA384,,,), /* ns */ + CS_ENTRY(0xC060, TLS,ECDHE,RSA,WITH,ARIA,128,GCM,SHA256), + CS_ENTRY(0xC060, ECDHE,ARIA128,GCM,SHA256,,,,), + CS_ENTRY(0xC061, TLS,ECDHE,RSA,WITH,ARIA,256,GCM,SHA384), + CS_ENTRY(0xC061, ECDHE,ARIA256,GCM,SHA384,,,,), + CS_ENTRY(0xC062, TLS,ECDH,RSA,WITH,ARIA,128,GCM,SHA256), + CS_ENTRY(0xC062, ECDH,ARIA128,GCM,SHA256,,,,), /* ns */ + CS_ENTRY(0xC063, TLS,ECDH,RSA,WITH,ARIA,256,GCM,SHA384), + CS_ENTRY(0xC063, ECDH,ARIA256,GCM,SHA384,,,,), /* ns */ + CS_ENTRY(0xC064, TLS,PSK,WITH,ARIA,128,CBC,SHA256,), + CS_ENTRY(0xC064, PSK,ARIA128,SHA256,,,,,), /* ns */ + CS_ENTRY(0xC065, TLS,PSK,WITH,ARIA,256,CBC,SHA384,), + CS_ENTRY(0xC065, PSK,ARIA256,SHA384,,,,,), /* ns */ + CS_ENTRY(0xC066, TLS,DHE,PSK,WITH,ARIA,128,CBC,SHA256), + CS_ENTRY(0xC066, DHE,PSK,ARIA128,SHA256,,,,), /* ns */ + CS_ENTRY(0xC067, TLS,DHE,PSK,WITH,ARIA,256,CBC,SHA384), + CS_ENTRY(0xC067, DHE,PSK,ARIA256,SHA384,,,,), /* ns */ + CS_ENTRY(0xC068, TLS,RSA,PSK,WITH,ARIA,128,CBC,SHA256), + CS_ENTRY(0xC068, RSA,PSK,ARIA128,SHA256,,,,), /* ns */ + CS_ENTRY(0xC069, TLS,RSA,PSK,WITH,ARIA,256,CBC,SHA384), + CS_ENTRY(0xC069, RSA,PSK,ARIA256,SHA384,,,,), /* ns */ + CS_ENTRY(0xC06A, TLS,PSK,WITH,ARIA,128,GCM,SHA256,), + CS_ENTRY(0xC06A, PSK,ARIA128,GCM,SHA256,,,,), + CS_ENTRY(0xC06B, TLS,PSK,WITH,ARIA,256,GCM,SHA384,), + CS_ENTRY(0xC06B, PSK,ARIA256,GCM,SHA384,,,,), + CS_ENTRY(0xC06C, TLS,DHE,PSK,WITH,ARIA,128,GCM,SHA256), + CS_ENTRY(0xC06C, DHE,PSK,ARIA128,GCM,SHA256,,,), + CS_ENTRY(0xC06D, TLS,DHE,PSK,WITH,ARIA,256,GCM,SHA384), + CS_ENTRY(0xC06D, DHE,PSK,ARIA256,GCM,SHA384,,,), + CS_ENTRY(0xC06E, TLS,RSA,PSK,WITH,ARIA,128,GCM,SHA256), + CS_ENTRY(0xC06E, RSA,PSK,ARIA128,GCM,SHA256,,,), + CS_ENTRY(0xC06F, TLS,RSA,PSK,WITH,ARIA,256,GCM,SHA384), + CS_ENTRY(0xC06F, RSA,PSK,ARIA256,GCM,SHA384,,,), + CS_ENTRY(0xC070, TLS,ECDHE,PSK,WITH,ARIA,128,CBC,SHA256), + CS_ENTRY(0xC070, ECDHE,PSK,ARIA128,SHA256,,,,), /* ns */ + CS_ENTRY(0xC071, TLS,ECDHE,PSK,WITH,ARIA,256,CBC,SHA384), + CS_ENTRY(0xC071, ECDHE,PSK,ARIA256,SHA384,,,,), /* ns */ + CS_ENTRY(0xC072, TLS,ECDHE,ECDSA,WITH,CAMELLIA,128,CBC,SHA256), + CS_ENTRY(0xC072, ECDHE,ECDSA,CAMELLIA128,SHA256,,,,), + CS_ENTRY(0xC073, TLS,ECDHE,ECDSA,WITH,CAMELLIA,256,CBC,SHA384), + CS_ENTRY(0xC073, ECDHE,ECDSA,CAMELLIA256,SHA384,,,,), + CS_ENTRY(0xC074, TLS,ECDH,ECDSA,WITH,CAMELLIA,128,CBC,SHA256), + CS_ENTRY(0xC074, ECDH,ECDSA,CAMELLIA128,SHA256,,,,), /* ns */ + CS_ENTRY(0xC075, TLS,ECDH,ECDSA,WITH,CAMELLIA,256,CBC,SHA384), + CS_ENTRY(0xC075, ECDH,ECDSA,CAMELLIA256,SHA384,,,,), /* ns */ + CS_ENTRY(0xC076, TLS,ECDHE,RSA,WITH,CAMELLIA,128,CBC,SHA256), + CS_ENTRY(0xC076, ECDHE,RSA,CAMELLIA128,SHA256,,,,), + CS_ENTRY(0xC077, TLS,ECDHE,RSA,WITH,CAMELLIA,256,CBC,SHA384), + CS_ENTRY(0xC077, ECDHE,RSA,CAMELLIA256,SHA384,,,,), + CS_ENTRY(0xC078, TLS,ECDH,RSA,WITH,CAMELLIA,128,CBC,SHA256), + CS_ENTRY(0xC078, ECDH,CAMELLIA128,SHA256,,,,,), /* ns */ + CS_ENTRY(0xC079, TLS,ECDH,RSA,WITH,CAMELLIA,256,CBC,SHA384), + CS_ENTRY(0xC079, ECDH,CAMELLIA256,SHA384,,,,,), /* ns */ + CS_ENTRY(0xC07A, TLS,RSA,WITH,CAMELLIA,128,GCM,SHA256,), + CS_ENTRY(0xC07A, CAMELLIA128,GCM,SHA256,,,,,), /* ns */ + CS_ENTRY(0xC07B, TLS,RSA,WITH,CAMELLIA,256,GCM,SHA384,), + CS_ENTRY(0xC07B, CAMELLIA256,GCM,SHA384,,,,,), /* ns */ + CS_ENTRY(0xC07C, TLS,DHE,RSA,WITH,CAMELLIA,128,GCM,SHA256), + CS_ENTRY(0xC07C, DHE,RSA,CAMELLIA128,GCM,SHA256,,,), /* ns */ + CS_ENTRY(0xC07D, TLS,DHE,RSA,WITH,CAMELLIA,256,GCM,SHA384), + CS_ENTRY(0xC07D, DHE,RSA,CAMELLIA256,GCM,SHA384,,,), /* ns */ + CS_ENTRY(0xC086, TLS,ECDHE,ECDSA,WITH,CAMELLIA,128,GCM,SHA256), + CS_ENTRY(0xC086, ECDHE,ECDSA,CAMELLIA128,GCM,SHA256,,,), /* ns */ + CS_ENTRY(0xC087, TLS,ECDHE,ECDSA,WITH,CAMELLIA,256,GCM,SHA384), + CS_ENTRY(0xC087, ECDHE,ECDSA,CAMELLIA256,GCM,SHA384,,,), /* ns */ + CS_ENTRY(0xC088, TLS,ECDH,ECDSA,WITH,CAMELLIA,128,GCM,SHA256), + CS_ENTRY(0xC088, ECDH,ECDSA,CAMELLIA128,GCM,SHA256,,,), /* ns */ + CS_ENTRY(0xC089, TLS,ECDH,ECDSA,WITH,CAMELLIA,256,GCM,SHA384), + CS_ENTRY(0xC089, ECDH,ECDSA,CAMELLIA256,GCM,SHA384,,,), /* ns */ + CS_ENTRY(0xC08A, TLS,ECDHE,RSA,WITH,CAMELLIA,128,GCM,SHA256), + CS_ENTRY(0xC08A, ECDHE,CAMELLIA128,GCM,SHA256,,,,), /* ns */ + CS_ENTRY(0xC08B, TLS,ECDHE,RSA,WITH,CAMELLIA,256,GCM,SHA384), + CS_ENTRY(0xC08B, ECDHE,CAMELLIA256,GCM,SHA384,,,,), /* ns */ + CS_ENTRY(0xC08C, TLS,ECDH,RSA,WITH,CAMELLIA,128,GCM,SHA256), + CS_ENTRY(0xC08C, ECDH,CAMELLIA128,GCM,SHA256,,,,), /* ns */ + CS_ENTRY(0xC08D, TLS,ECDH,RSA,WITH,CAMELLIA,256,GCM,SHA384), + CS_ENTRY(0xC08D, ECDH,CAMELLIA256,GCM,SHA384,,,,), /* ns */ + CS_ENTRY(0xC08E, TLS,PSK,WITH,CAMELLIA,128,GCM,SHA256,), + CS_ENTRY(0xC08E, PSK,CAMELLIA128,GCM,SHA256,,,,), /* ns */ + CS_ENTRY(0xC08F, TLS,PSK,WITH,CAMELLIA,256,GCM,SHA384,), + CS_ENTRY(0xC08F, PSK,CAMELLIA256,GCM,SHA384,,,,), /* ns */ + CS_ENTRY(0xC090, TLS,DHE,PSK,WITH,CAMELLIA,128,GCM,SHA256), + CS_ENTRY(0xC090, DHE,PSK,CAMELLIA128,GCM,SHA256,,,), /* ns */ + CS_ENTRY(0xC091, TLS,DHE,PSK,WITH,CAMELLIA,256,GCM,SHA384), + CS_ENTRY(0xC091, DHE,PSK,CAMELLIA256,GCM,SHA384,,,), /* ns */ + CS_ENTRY(0xC092, TLS,RSA,PSK,WITH,CAMELLIA,128,GCM,SHA256), + CS_ENTRY(0xC092, RSA,PSK,CAMELLIA128,GCM,SHA256,,,), /* ns */ + CS_ENTRY(0xC093, TLS,RSA,PSK,WITH,CAMELLIA,256,GCM,SHA384), + CS_ENTRY(0xC093, RSA,PSK,CAMELLIA256,GCM,SHA384,,,), /* ns */ + CS_ENTRY(0xC094, TLS,PSK,WITH,CAMELLIA,128,CBC,SHA256,), + CS_ENTRY(0xC094, PSK,CAMELLIA128,SHA256,,,,,), + CS_ENTRY(0xC095, TLS,PSK,WITH,CAMELLIA,256,CBC,SHA384,), + CS_ENTRY(0xC095, PSK,CAMELLIA256,SHA384,,,,,), + CS_ENTRY(0xC096, TLS,DHE,PSK,WITH,CAMELLIA,128,CBC,SHA256), + CS_ENTRY(0xC096, DHE,PSK,CAMELLIA128,SHA256,,,,), + CS_ENTRY(0xC097, TLS,DHE,PSK,WITH,CAMELLIA,256,CBC,SHA384), + CS_ENTRY(0xC097, DHE,PSK,CAMELLIA256,SHA384,,,,), + CS_ENTRY(0xC098, TLS,RSA,PSK,WITH,CAMELLIA,128,CBC,SHA256), + CS_ENTRY(0xC098, RSA,PSK,CAMELLIA128,SHA256,,,,), + CS_ENTRY(0xC099, TLS,RSA,PSK,WITH,CAMELLIA,256,CBC,SHA384), + CS_ENTRY(0xC099, RSA,PSK,CAMELLIA256,SHA384,,,,), + CS_ENTRY(0xC09A, TLS,ECDHE,PSK,WITH,CAMELLIA,128,CBC,SHA256), + CS_ENTRY(0xC09A, ECDHE,PSK,CAMELLIA128,SHA256,,,,), + CS_ENTRY(0xC09B, TLS,ECDHE,PSK,WITH,CAMELLIA,256,CBC,SHA384), + CS_ENTRY(0xC09B, ECDHE,PSK,CAMELLIA256,SHA384,,,,), + CS_ENTRY(0xC09E, TLS,DHE,RSA,WITH,AES,128,CCM,), + CS_ENTRY(0xC09E, DHE,RSA,AES128,CCM,,,,), + CS_ENTRY(0xC09F, TLS,DHE,RSA,WITH,AES,256,CCM,), + CS_ENTRY(0xC09F, DHE,RSA,AES256,CCM,,,,), + CS_ENTRY(0xC0A2, TLS,DHE,RSA,WITH,AES,128,CCM,8), + CS_ENTRY(0xC0A2, DHE,RSA,AES128,CCM8,,,,), + CS_ENTRY(0xC0A3, TLS,DHE,RSA,WITH,AES,256,CCM,8), + CS_ENTRY(0xC0A3, DHE,RSA,AES256,CCM8,,,,), + CS_ENTRY(0xC0A4, TLS,PSK,WITH,AES,128,CCM,,), + CS_ENTRY(0xC0A4, PSK,AES128,CCM,,,,,), + CS_ENTRY(0xC0A5, TLS,PSK,WITH,AES,256,CCM,,), + CS_ENTRY(0xC0A5, PSK,AES256,CCM,,,,,), + CS_ENTRY(0xC0A6, TLS,DHE,PSK,WITH,AES,128,CCM,), + CS_ENTRY(0xC0A6, DHE,PSK,AES128,CCM,,,,), + CS_ENTRY(0xC0A7, TLS,DHE,PSK,WITH,AES,256,CCM,), + CS_ENTRY(0xC0A7, DHE,PSK,AES256,CCM,,,,), + CS_ENTRY(0xC0A8, TLS,PSK,WITH,AES,128,CCM,8,), + CS_ENTRY(0xC0A8, PSK,AES128,CCM8,,,,,), + CS_ENTRY(0xC0A9, TLS,PSK,WITH,AES,256,CCM,8,), + CS_ENTRY(0xC0A9, PSK,AES256,CCM8,,,,,), + CS_ENTRY(0xC0AA, TLS,PSK,DHE,WITH,AES,128,CCM,8), + CS_ENTRY(0xC0AA, DHE,PSK,AES128,CCM8,,,,), + CS_ENTRY(0xC0AB, TLS,PSK,DHE,WITH,AES,256,CCM,8), + CS_ENTRY(0xC0AB, DHE,PSK,AES256,CCM8,,,,), + CS_ENTRY(0xCCAA, TLS,DHE,RSA,WITH,CHACHA20,POLY1305,SHA256,), + CS_ENTRY(0xCCAA, DHE,RSA,CHACHA20,POLY1305,,,,), + CS_ENTRY(0xCCAC, TLS,ECDHE,PSK,WITH,CHACHA20,POLY1305,SHA256,), + CS_ENTRY(0xCCAC, ECDHE,PSK,CHACHA20,POLY1305,,,,), + CS_ENTRY(0xCCAD, TLS,DHE,PSK,WITH,CHACHA20,POLY1305,SHA256,), + CS_ENTRY(0xCCAD, DHE,PSK,CHACHA20,POLY1305,,,,), + CS_ENTRY(0xCCAE, TLS,RSA,PSK,WITH,CHACHA20,POLY1305,SHA256,), + CS_ENTRY(0xCCAE, RSA,PSK,CHACHA20,POLY1305,,,,), +#endif +}; +#define CS_LIST_LEN CURL_ARRAYSIZE(cs_list) + +static int cs_str_to_zip(const char *cs_str, size_t cs_len, uint8_t zip[6]) +{ + uint8_t indexes[8] = { 0 }; + const char *entry, *cur; + const char *nxt = cs_str; + const char *end = cs_str + cs_len; + char separator = '-'; + int idx, i = 0; + size_t len; + + /* split the cipher string by '-' or '_' */ + if(curl_strnequal(cs_str, "TLS", 3)) + separator = '_'; + + do { + if(i == 8) + return -1; + + /* determine the length of the part */ + cur = nxt; + for(; nxt < end && *nxt != '\0' && *nxt != separator; nxt++) + ; + len = nxt - cur; + + /* lookup index for the part (skip empty string at 0) */ + for(idx = 1, entry = cs_txt + 1; idx < CS_TXT_LEN; idx++) { + size_t elen = strlen(entry); + if(elen == len && curl_strnequal(entry, cur, len)) + break; + entry += elen + 1; + } + if(idx == CS_TXT_LEN) + return -1; + + indexes[i++] = (uint8_t)idx; + } while(nxt < end && *(nxt++) != '\0'); + + /* zip the 8 indexes into 48 bits */ + zip[0] = (uint8_t)(indexes[0] << 2 | (indexes[1] & 0x3F) >> 4); + zip[1] = (uint8_t)(indexes[1] << 4 | (indexes[2] & 0x3F) >> 2); + zip[2] = (uint8_t)(indexes[2] << 6 | (indexes[3] & 0x3F)); + zip[3] = (uint8_t)(indexes[4] << 2 | (indexes[5] & 0x3F) >> 4); + zip[4] = (uint8_t)(indexes[5] << 4 | (indexes[6] & 0x3F) >> 2); + zip[5] = (uint8_t)(indexes[6] << 6 | (indexes[7] & 0x3F)); + + return 0; +} + +static int cs_zip_to_str(const uint8_t zip[6], char *buf, size_t buf_size) +{ + uint8_t indexes[8] = { 0 }; + const char *entry; + char separator = '-'; + int idx, i, r; + size_t len = 0; + + /* unzip the 8 indexes */ + indexes[0] = zip[0] >> 2; + indexes[1] = (uint8_t)(((zip[0] << 4) & 0x3F) | zip[1] >> 4); + indexes[2] = (uint8_t)(((zip[1] << 2) & 0x3F) | zip[2] >> 6); + indexes[3] = ((zip[2] << 0) & 0x3F); + indexes[4] = zip[3] >> 2; + indexes[5] = (uint8_t)(((zip[3] << 4) & 0x3F) | zip[4] >> 4); + indexes[6] = (uint8_t)(((zip[4] << 2) & 0x3F) | zip[5] >> 6); + indexes[7] = ((zip[5] << 0) & 0x3F); + + if(indexes[0] == CS_TXT_IDX_TLS) + separator = '_'; + + for(i = 0; i < 8 && indexes[i] != 0 && len < buf_size; i++) { + if(indexes[i] >= CS_TXT_LEN) + return -1; + + /* lookup the part string for the index (skip empty string at 0) */ + for(idx = 1, entry = cs_txt + 1; idx < indexes[i]; idx++) { + size_t elen = strlen(entry); + entry += elen + 1; + } + + /* append the part string to the buffer */ + if(i > 0) + r = curl_msnprintf(&buf[len], buf_size - len, "%c%s", separator, entry); + else + r = curl_msnprintf(&buf[len], buf_size - len, "%s", entry); + + if(r < 0) + return -1; + len += r; + } + + return 0; +} + +uint16_t Curl_cipher_suite_lookup_id(const char *cs_str, size_t cs_len) +{ + size_t i; + uint8_t zip[6]; + + if(cs_len > 0 && cs_str_to_zip(cs_str, cs_len, zip) == 0) { + for(i = 0; i < CS_LIST_LEN; i++) { + if(!memcmp(cs_list[i].zip, zip, sizeof(zip))) + return cs_list[i].id; + } + } + + return 0; +} + +static bool cs_is_separator(char c) +{ + switch(c) { + case ' ': + case '\t': + case ':': + case ',': + case ';': + return TRUE; + } + return FALSE; +} + +uint16_t Curl_cipher_suite_walk_str(const char **str, const char **end) +{ + /* move string pointer to first non-separator or end of string */ + for(; cs_is_separator(*str[0]); (*str)++) + ; + + /* move end pointer to next separator or end of string */ + for(*end = *str; *end[0] != '\0' && !cs_is_separator(*end[0]); (*end)++) + ; + + return Curl_cipher_suite_lookup_id(*str, *end - *str); +} + +int Curl_cipher_suite_get_str(uint16_t id, char *buf, size_t buf_size, + bool prefer_rfc) +{ + size_t i, j = CS_LIST_LEN; + int r = -1; + + for(i = 0; i < CS_LIST_LEN; i++) { + if(cs_list[i].id != id) + continue; + if((cs_list[i].zip[0] >> 2 != CS_TXT_IDX_TLS) == !prefer_rfc) { + j = i; + break; + } + if(j == CS_LIST_LEN) + j = i; + } + + if(j < CS_LIST_LEN) + r = cs_zip_to_str(cs_list[j].zip, buf, buf_size); + + if(r < 0) + curl_msnprintf(buf, buf_size, "TLS_UNKNOWN_0x%04x", id); + + return r; +} + +#endif /* defined(USE_MBEDTLS) || defined(USE_RUSTLS) */ diff --git a/3rdparty/curl-8.21.0/lib/vtls/cipher_suite.h b/3rdparty/curl-8.21.0/lib/vtls/cipher_suite.h new file mode 100644 index 0000000000..0e185e351e --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vtls/cipher_suite.h @@ -0,0 +1,44 @@ +#ifndef HEADER_CURL_CIPHER_SUITE_H +#define HEADER_CURL_CIPHER_SUITE_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Jan Venekamp, + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if defined(USE_MBEDTLS) || defined(USE_RUSTLS) + +/* Lookup IANA id for cipher suite string, returns 0 if not recognized */ +uint16_t Curl_cipher_suite_lookup_id(const char *cs_str, size_t cs_len); + +/* Walk over cipher suite string, update str and end pointers to next + cipher suite in string, returns IANA id of that suite if recognized */ +uint16_t Curl_cipher_suite_walk_str(const char **str, const char **end); + +/* Copy openssl or RFC name for cipher suite in supplied buffer. + Caller is responsible to supply sufficiently large buffer (size + of 64 should suffice), excess bytes are silently truncated. */ +int Curl_cipher_suite_get_str(uint16_t id, char *buf, size_t buf_size, + bool prefer_rfc); + +#endif /* defined(USE_MBEDTLS) || defined(USE_RUSTLS) */ +#endif /* HEADER_CURL_CIPHER_SUITE_H */ diff --git a/3rdparty/curl-8.21.0/lib/vtls/gtls.c b/3rdparty/curl-8.21.0/lib/vtls/gtls.c new file mode 100644 index 0000000000..1a7a4a1e5b --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vtls/gtls.c @@ -0,0 +1,2365 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +/* + * Source file for all GnuTLS-specific code for the TLS/SSL layer. No code + * but vtls.c should ever call or use these functions. + * + * Note: do not use the GnuTLS' *_t variable type names in this source code, + * since they were not present in 1.0.x. + */ +#include "curl_setup.h" + +#ifdef USE_GNUTLS + +#include +#include +#include +#include +#include +#include + +#include "urldata.h" +#include "curl_trc.h" +#include "vtls/keylog.h" +#include "vtls/gtls.h" +#include "vtls/vtls.h" +#include "vtls/vtls_int.h" +#include "vtls/vtls_scache.h" +#include "vtls/apple.h" +#include "vauth/vauth.h" +#include "parsedate.h" +#include "connect.h" /* for the connect timeout */ +#include "progress.h" +#include "curlx/strdup.h" +#include "curlx/fopen.h" +#include "vtls/x509asn1.h" + +/* Enable GnuTLS debugging by defining GTLSDEBUG */ +#if 0 +#define GTLSDEBUG +#endif + +#ifdef GTLSDEBUG +static void tls_log_func(int level, const char *str) +{ + curl_mfprintf(stderr, "|<%d>| %s", level, str); +} +#endif + +#if !defined(GNUTLS_VERSION_NUMBER) || (GNUTLS_VERSION_NUMBER < 0x030605) +#error "too old GnuTLS version" +#endif + +#undef CURL_GNUTLS_EARLY_DATA +#if GNUTLS_VERSION_NUMBER >= 0x030702 +#define CURL_GNUTLS_EARLY_DATA +#endif + +#include + +struct gtls_ssl_backend_data { + struct gtls_ctx gtls; +}; + +static ssize_t gtls_push(void *s, const void *buf, size_t blen) +{ + struct Curl_cfilter *cf = s; + struct ssl_connect_data *connssl = cf->ctx; + struct gtls_ssl_backend_data *backend = + (struct gtls_ssl_backend_data *)connssl->backend; + struct Curl_easy *data = CF_DATA_CURRENT(cf); + size_t nwritten; + CURLcode result; + + DEBUGASSERT(data); + result = Curl_conn_cf_send(cf->next, data, buf, blen, FALSE, &nwritten); + CURL_TRC_CF(data, cf, "gtls_push(len=%zu) -> %d, %zu", + blen, (int)result, nwritten); + backend->gtls.io_result = result; + if(result) { + /* !checksrc! disable ERRNOVAR 1 */ + gnutls_transport_set_errno(backend->gtls.session, + (result == CURLE_AGAIN) ? EAGAIN : EINVAL); + return -1; + } + return (ssize_t)nwritten; +} + +static ssize_t gtls_pull(void *s, void *buf, size_t blen) +{ + struct Curl_cfilter *cf = s; + struct ssl_connect_data *connssl = cf->ctx; + struct gtls_ssl_backend_data *backend = + (struct gtls_ssl_backend_data *)connssl->backend; + struct Curl_easy *data = CF_DATA_CURRENT(cf); + size_t nread; + CURLcode result; + + DEBUGASSERT(data); + if(!backend->gtls.shared_creds->trust_setup) { + result = Curl_gtls_client_trust_setup(cf, data, &backend->gtls); + if(result) { + /* !checksrc! disable ERRNOVAR 1 */ + gnutls_transport_set_errno(backend->gtls.session, EINVAL); + backend->gtls.io_result = result; + return -1; + } + } + + result = Curl_conn_cf_recv(cf->next, data, buf, blen, &nread); + CURL_TRC_CF(data, cf, "gtls_pull(len=%zu) -> %d, %zu", blen, (int)result, + nread); + backend->gtls.io_result = result; + if(result) { + /* !checksrc! disable ERRNOVAR 1 */ + gnutls_transport_set_errno(backend->gtls.session, + (result == CURLE_AGAIN) ? EAGAIN : EINVAL); + return -1; + } + else if(nread == 0) + connssl->peer_closed = TRUE; + return (ssize_t)nread; +} + +/** + * gtls_init() + * + * Global GnuTLS init, called from Curl_ssl_init(). This calls functions that + * are not thread-safe (It is thread-safe since GnuTLS 3.3.0) and thus this + * function itself is not thread-safe and must only be called from within + * curl_global_init() to keep the thread situation under control! + * + * @retval 0 error initializing SSL + * @retval 1 SSL initialized successfully + */ +static int gtls_init(void) +{ + int ret = 1; + ret = gnutls_global_init() ? 0 : 1; +#ifdef GTLSDEBUG + gnutls_global_set_log_function(tls_log_func); + gnutls_global_set_log_level(2); +#endif + return ret; +} + +static void gtls_cleanup(void) +{ + gnutls_global_deinit(); + Curl_tls_keylog_close(); +} + +#ifdef CURLVERBOSE +static void showtime(struct Curl_easy *data, const char *text, time_t stamp) +{ + struct tm buffer; + const struct tm *tm = &buffer; + char str[96]; + CURLcode result = curlx_gmtime(stamp, &buffer); + if(result) + return; + + curl_msnprintf(str, + sizeof(str), + " %s: %s, %02d %s %4d %02d:%02d:%02d GMT", + text, + Curl_wkday[tm->tm_wday ? tm->tm_wday-1 : 6], + tm->tm_mday, + Curl_month[tm->tm_mon], + tm->tm_year + 1900, + tm->tm_hour, + tm->tm_min, + tm->tm_sec); + infof(data, "%s", str); +} +#endif + +static gnutls_datum_t load_file(const char *file) +{ + FILE *f; + gnutls_datum_t loaded_file = { NULL, 0 }; + long filelen; + void *ptr; + + f = curlx_fopen(file, "rb"); + if(!f) + return loaded_file; + if(fseek(f, 0, SEEK_END)) + goto out; + filelen = ftell(f); + if(filelen < 0 || filelen > CURL_MAX_INPUT_LENGTH) + goto out; + if(fseek(f, 0, SEEK_SET)) + goto out; + ptr = curlx_malloc((size_t)filelen); + if(!ptr) + goto out; + if(fread(ptr, 1, (size_t)filelen, f) < (size_t)filelen) { + curlx_free(ptr); + goto out; + } + + loaded_file.data = ptr; + loaded_file.size = (unsigned int)filelen; +out: + curlx_fclose(f); + return loaded_file; +} + +static void unload_file(gnutls_datum_t data) +{ + curlx_free(data.data); +} + +/* this function does an SSL/TLS (re-)handshake */ +static CURLcode cf_gtls_handshake(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct gtls_ssl_backend_data *backend = + (struct gtls_ssl_backend_data *)connssl->backend; + gnutls_session_t session; + int rc; + + DEBUGASSERT(backend); + session = backend->gtls.session; + + connssl->io_need = CURL_SSL_IO_NEED_NONE; + backend->gtls.io_result = CURLE_OK; + rc = gnutls_handshake(session); + + if(!backend->gtls.shared_creds->trust_setup) { + /* After having send off the ClientHello, we prepare the trust + * store to verify the coming certificate from the server */ + CURLcode result = Curl_gtls_client_trust_setup(cf, data, &backend->gtls); + if(result) + return result; + } + + if((rc == GNUTLS_E_AGAIN) || (rc == GNUTLS_E_INTERRUPTED)) { + connssl->io_need = + gnutls_record_get_direction(session) ? + CURL_SSL_IO_NEED_SEND : CURL_SSL_IO_NEED_RECV; + return CURLE_AGAIN; + } + else if((rc < 0) && !gnutls_error_is_fatal(rc)) { +#ifdef CURLVERBOSE + const char *strerr = NULL; + + if(rc == GNUTLS_E_WARNING_ALERT_RECEIVED) { + gnutls_alert_description_t alert = gnutls_alert_get(session); + strerr = gnutls_alert_get_name(alert); + } + + if(!strerr) + strerr = gnutls_strerror(rc); + + infof(data, "gnutls_handshake() warning: %s", strerr); +#endif + return CURLE_AGAIN; + } + else if((rc < 0) && backend->gtls.io_result) { + return backend->gtls.io_result; + } + else if(rc < 0) { + const char *strerr = NULL; + + if(rc == GNUTLS_E_FATAL_ALERT_RECEIVED) { + gnutls_alert_description_t alert = gnutls_alert_get(session); + strerr = gnutls_alert_get_name(alert); + } + + if(!strerr) + strerr = gnutls_strerror(rc); + + failf(data, "GnuTLS, handshake failed: %s", strerr); + return CURLE_SSL_CONNECT_ERROR; + } + + return CURLE_OK; +} + +static gnutls_x509_crt_fmt_t gnutls_do_file_type(const char *type) +{ + if(!type || !type[0]) + return GNUTLS_X509_FMT_PEM; + if(curl_strequal(type, "PEM")) + return GNUTLS_X509_FMT_PEM; + if(curl_strequal(type, "DER")) + return GNUTLS_X509_FMT_DER; + return GNUTLS_X509_FMT_PEM; /* default to PEM */ +} + +#define GNUTLS_CIPHERS "NORMAL:%PROFILE_MEDIUM:-ARCFOUR-128:" \ + "-CTYPE-ALL:+CTYPE-X509" +/* If GnuTLS was compiled without support for SRP it errors out if SRP is + requested in the priority string, so treat it specially + */ +#define GNUTLS_SRP "+SRP" + +#define QUIC_PRIORITY \ + "NORMAL:%PROFILE_MEDIUM:-VERS-ALL:+VERS-TLS1.3:-CIPHER-ALL:+AES-128-GCM:" \ + "+AES-256-GCM:+CHACHA20-POLY1305:+AES-128-CCM:-GROUP-ALL:" \ + "+GROUP-SECP256R1:+GROUP-X25519:+GROUP-SECP384R1:+GROUP-SECP521R1:" \ + "%DISABLE_TLS13_COMPAT_MODE" + +static CURLcode gnutls_set_ssl_version_min_max( + struct Curl_easy *data, + struct ssl_peer *peer, + struct ssl_primary_config *conn_config, + const char **prioritylist, + bool tls13support) +{ + long ssl_version = conn_config->version; + long ssl_version_max = conn_config->version_max; + + DEBUGASSERT(ssl_version != CURL_SSLVERSION_DEFAULT); + if(ssl_version <= CURL_SSLVERSION_TLSv1) + ssl_version = CURL_SSLVERSION_TLSv1_0; + if((ssl_version_max == CURL_SSLVERSION_MAX_NONE) || + (ssl_version_max == CURL_SSLVERSION_MAX_DEFAULT)) + ssl_version_max = tls13support ? + CURL_SSLVERSION_MAX_TLSv1_3 : CURL_SSLVERSION_MAX_TLSv1_2; + + if(peer->transport == TRNSPRT_QUIC) { + if(ssl_version_max < CURL_SSLVERSION_MAX_TLSv1_3) { + failf(data, "QUIC needs at least TLS version 1.3"); + return CURLE_SSL_CONNECT_ERROR; + } + *prioritylist = QUIC_PRIORITY; + return CURLE_OK; + } + + switch(ssl_version | ssl_version_max) { + case CURL_SSLVERSION_TLSv1_0 | CURL_SSLVERSION_MAX_TLSv1_0: + *prioritylist = GNUTLS_CIPHERS ":-VERS-SSL3.0:-VERS-TLS-ALL:" + "+VERS-TLS1.0"; + return CURLE_OK; + case CURL_SSLVERSION_TLSv1_0 | CURL_SSLVERSION_MAX_TLSv1_1: + *prioritylist = GNUTLS_CIPHERS ":-VERS-SSL3.0:-VERS-TLS-ALL:" + "+VERS-TLS1.1:+VERS-TLS1.0"; + return CURLE_OK; + case CURL_SSLVERSION_TLSv1_0 | CURL_SSLVERSION_MAX_TLSv1_2: + *prioritylist = GNUTLS_CIPHERS ":-VERS-SSL3.0:-VERS-TLS-ALL:" + "+VERS-TLS1.2:+VERS-TLS1.1:+VERS-TLS1.0"; + return CURLE_OK; + case CURL_SSLVERSION_TLSv1_1 | CURL_SSLVERSION_MAX_TLSv1_1: + *prioritylist = GNUTLS_CIPHERS ":-VERS-SSL3.0:-VERS-TLS-ALL:" + "+VERS-TLS1.1"; + return CURLE_OK; + case CURL_SSLVERSION_TLSv1_1 | CURL_SSLVERSION_MAX_TLSv1_2: + *prioritylist = GNUTLS_CIPHERS ":-VERS-SSL3.0:-VERS-TLS-ALL:" + "+VERS-TLS1.2:+VERS-TLS1.1"; + return CURLE_OK; + case CURL_SSLVERSION_TLSv1_2 | CURL_SSLVERSION_MAX_TLSv1_2: + *prioritylist = GNUTLS_CIPHERS ":-VERS-SSL3.0:-VERS-TLS-ALL:" + "+VERS-TLS1.2"; + return CURLE_OK; + case CURL_SSLVERSION_TLSv1_3 | CURL_SSLVERSION_MAX_TLSv1_3: + *prioritylist = GNUTLS_CIPHERS ":-VERS-SSL3.0:-VERS-TLS-ALL:" + "+VERS-TLS1.3"; + return CURLE_OK; + case CURL_SSLVERSION_TLSv1_0 | CURL_SSLVERSION_MAX_TLSv1_3: + *prioritylist = GNUTLS_CIPHERS ":-VERS-SSL3.0"; + return CURLE_OK; + case CURL_SSLVERSION_TLSv1_1 | CURL_SSLVERSION_MAX_TLSv1_3: + *prioritylist = GNUTLS_CIPHERS ":-VERS-SSL3.0:-VERS-TLS-ALL:" + "+VERS-TLS1.3:+VERS-TLS1.2:+VERS-TLS1.1"; + return CURLE_OK; + case CURL_SSLVERSION_TLSv1_2 | CURL_SSLVERSION_MAX_TLSv1_3: + *prioritylist = GNUTLS_CIPHERS ":-VERS-SSL3.0:-VERS-TLS-ALL:" + "+VERS-TLS1.3:+VERS-TLS1.2"; + return CURLE_OK; + } + + failf(data, "GnuTLS: cannot set TLS protocol"); + return CURLE_SSL_CONNECT_ERROR; +} + +CURLcode Curl_gtls_shared_creds_create(struct Curl_easy *data, + struct gtls_shared_creds **pcreds) +{ + struct gtls_shared_creds *shared; + int rc; + + *pcreds = NULL; + shared = curlx_calloc(1, sizeof(*shared)); + if(!shared) + return CURLE_OUT_OF_MEMORY; + + rc = gnutls_certificate_allocate_credentials(&shared->creds); + if(rc != GNUTLS_E_SUCCESS) { + failf(data, "gnutls_certificate_allocate_credentials() failed: %s", + gnutls_strerror(rc)); + curlx_free(shared); + return CURLE_SSL_CONNECT_ERROR; + } + + shared->refcount = 1; + shared->time = *Curl_pgrs_now(data); + *pcreds = shared; + return CURLE_OK; +} + +CURLcode Curl_gtls_shared_creds_up_ref(struct gtls_shared_creds *creds) +{ + DEBUGASSERT(creds); + if(creds->refcount < SIZE_MAX) { + ++creds->refcount; + return CURLE_OK; + } + return CURLE_BAD_FUNCTION_ARGUMENT; +} + +void Curl_gtls_shared_creds_free(struct gtls_shared_creds **pcreds) +{ + struct gtls_shared_creds *shared = *pcreds; + *pcreds = NULL; + if(shared) { + --shared->refcount; + if(!shared->refcount) { + gnutls_certificate_free_credentials(shared->creds); + curlx_free(shared->CAfile); + curlx_free(shared); + } + } +} + +static CURLcode gtls_populate_creds(struct Curl_cfilter *cf, + struct Curl_easy *data, + gnutls_certificate_credentials_t creds) +{ + struct ssl_primary_config *config = Curl_ssl_cf_get_primary_config(cf); + struct ssl_config_data *ssl_config = Curl_ssl_cf_get_config(cf, data); + bool creds_are_empty = TRUE; + int rc; + + if(!config->verifypeer) { + infof(data, "SSL Trust: peer verification disabled"); + return CURLE_OK; + } + + infof(data, "SSL Trust Anchors:"); + if(ssl_config->native_ca_store) { +#ifdef USE_APPLE_SECTRUST + infof(data, " Native: Apple SecTrust"); + creds_are_empty = FALSE; +#else + rc = gnutls_certificate_set_x509_system_trust(creds); + if(rc < 0) + infof(data, "error reading native CA store (%s), continuing anyway", + gnutls_strerror(rc)); + else { + infof(data, " Native: %d certificates from system trust", rc); + if(rc > 0) + creds_are_empty = FALSE; + } +#endif + } + + if(config->ca_info_blob) { + gnutls_datum_t ca_info_datum; + if(config->ca_info_blob->len > (size_t)UINT_MAX) { + failf(data, "certificate blob too long: %zu bytes", + config->ca_info_blob->len); + return CURLE_SSL_CACERT_BADFILE; + } + ca_info_datum.data = config->ca_info_blob->data; + ca_info_datum.size = (unsigned int)config->ca_info_blob->len; + rc = gnutls_certificate_set_x509_trust_mem(creds, &ca_info_datum, + GNUTLS_X509_FMT_PEM); + creds_are_empty = creds_are_empty && (rc <= 0); + if(rc < 0) { + infof(data, "error reading CA cert blob (%s)%s", gnutls_strerror(rc), + (creds_are_empty ? "" : ", continuing anyway")); + if(creds_are_empty) { + ssl_config->certverifyresult = rc; + return CURLE_SSL_CACERT_BADFILE; + } + } + else + infof(data, " CA Blob: %d certificates", rc); + } + /* CURLOPT_CAINFO_BLOB overrides CURLOPT_CAINFO */ + else if(config->CAfile) { + /* set the trusted CA cert bundle file */ + gnutls_certificate_set_verify_flags(creds, + GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT); + + rc = gnutls_certificate_set_x509_trust_file(creds, + config->CAfile, + GNUTLS_X509_FMT_PEM); + creds_are_empty = creds_are_empty && (rc <= 0); + if(rc < 0) { + infof(data, "error reading CA cert file %s (%s)%s", + config->CAfile, gnutls_strerror(rc), + (creds_are_empty ? "" : ", continuing anyway")); + if(creds_are_empty) { + ssl_config->certverifyresult = rc; + return CURLE_SSL_CACERT_BADFILE; + } + } + else + infof(data, " CAfile: %d certificates in %s", rc, config->CAfile); + } + + if(config->CApath) { + /* set the trusted CA cert directory */ + rc = gnutls_certificate_set_x509_trust_dir(creds, config->CApath, + GNUTLS_X509_FMT_PEM); + creds_are_empty = creds_are_empty && (rc <= 0); + if(rc < 0) { + infof(data, "error reading CA cert file %s (%s)%s", + config->CApath, gnutls_strerror(rc), + (creds_are_empty ? "" : ", continuing anyway")); + if(creds_are_empty) { + ssl_config->certverifyresult = rc; + return CURLE_SSL_CACERT_BADFILE; + } + } + else + infof(data, " CApath: %d certificates in %s", rc, config->CApath); + } + + if(creds_are_empty) + infof(data, " no trust anchors configured"); + + if(config->CRLfile) { + /* set the CRL list file */ + rc = gnutls_certificate_set_x509_crl_file(creds, config->CRLfile, + GNUTLS_X509_FMT_PEM); + if(rc < 0) { + failf(data, "error reading CRL file %s (%s)", + config->CRLfile, gnutls_strerror(rc)); + return CURLE_SSL_CRL_BADFILE; + } + else + infof(data, " CRLfile: %d CRL in %s", rc, config->CRLfile); + } + + return CURLE_OK; +} + +/* key to use at `multi->proto_hash` */ +#define MPROTO_GTLS_X509_KEY "tls:gtls:x509:share" + +static bool gtls_shared_creds_expired(struct Curl_easy *data, + const struct gtls_shared_creds *sc) +{ + const struct ssl_general_config *cfg = &data->set.general_ssl; + timediff_t elapsed_ms = curlx_ptimediff_ms(Curl_pgrs_now(data), &sc->time); + timediff_t timeout_ms = cfg->ca_cache_timeout * (timediff_t)1000; + + if(timeout_ms < 0) + return FALSE; + + return elapsed_ms >= timeout_ms; +} + +static bool gtls_shared_creds_different(struct Curl_cfilter *cf, + const struct gtls_shared_creds *sc) +{ + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + if(!sc->CAfile || !conn_config->CAfile) + return sc->CAfile != conn_config->CAfile; + + return strcmp(sc->CAfile, conn_config->CAfile); +} + +static struct gtls_shared_creds *gtls_get_cached_creds(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct gtls_shared_creds *shared_creds; + + if(data->multi) { + shared_creds = Curl_hash_pick(&data->multi->proto_hash, + CURL_UNCONST(MPROTO_GTLS_X509_KEY), + sizeof(MPROTO_GTLS_X509_KEY) - 1); + if(shared_creds && shared_creds->creds && + !gtls_shared_creds_expired(data, shared_creds) && + !gtls_shared_creds_different(cf, shared_creds)) { + return shared_creds; + } + } + return NULL; +} + +static void gtls_shared_creds_hash_free(void *key, size_t key_len, void *p) +{ + struct gtls_shared_creds *sc = p; + DEBUGASSERT(key_len == (sizeof(MPROTO_GTLS_X509_KEY) - 1)); + DEBUGASSERT(!memcmp(MPROTO_GTLS_X509_KEY, key, key_len)); + (void)key; + (void)key_len; + Curl_gtls_shared_creds_free(&sc); /* down reference */ +} + +static void gtls_set_cached_creds(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct gtls_shared_creds *sc) +{ + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + + DEBUGASSERT(sc); + DEBUGASSERT(sc->creds); + DEBUGASSERT(!sc->CAfile); + DEBUGASSERT(sc->refcount == 1); + if(!data->multi) + return; + + if(conn_config->CAfile) { + sc->CAfile = curlx_strdup(conn_config->CAfile); + if(!sc->CAfile) + return; + } + + if(Curl_gtls_shared_creds_up_ref(sc)) + return; + + if(!Curl_hash_add2(&data->multi->proto_hash, + CURL_UNCONST(MPROTO_GTLS_X509_KEY), + sizeof(MPROTO_GTLS_X509_KEY) - 1, + sc, gtls_shared_creds_hash_free)) { + Curl_gtls_shared_creds_free(&sc); /* down reference again */ + return; + } +} + +CURLcode Curl_gtls_client_trust_setup(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct gtls_ctx *gtls) +{ + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + struct ssl_config_data *ssl_config = Curl_ssl_cf_get_config(cf, data); + struct gtls_shared_creds *cached_creds = NULL; + bool cache_criteria_met; + CURLcode result; + int rc; + + /* Consider the X509 store cacheable if it comes exclusively from a CAfile, + or no source is provided and we are falling back to OpenSSL's built-in + default. */ + cache_criteria_met = (data->set.general_ssl.ca_cache_timeout != 0) && + conn_config->verifypeer && + !conn_config->CApath && + !conn_config->ca_info_blob && + !ssl_config->primary.CRLfile && + !ssl_config->native_ca_store && + !conn_config->clientcert; /* GnuTLS adds client cert to its credentials! */ + + if(cache_criteria_met) + cached_creds = gtls_get_cached_creds(cf, data); + + if(cached_creds && !Curl_gtls_shared_creds_up_ref(cached_creds)) { + CURL_TRC_CF(data, cf, "using shared trust anchors and CRLs"); + Curl_gtls_shared_creds_free(>ls->shared_creds); + gtls->shared_creds = cached_creds; + rc = gnutls_credentials_set(gtls->session, GNUTLS_CRD_CERTIFICATE, + gtls->shared_creds->creds); + if(rc != GNUTLS_E_SUCCESS) { + failf(data, "gnutls_credentials_set() failed: %s", gnutls_strerror(rc)); + return CURLE_SSL_CONNECT_ERROR; + } + } + else { + CURL_TRC_CF(data, cf, "loading trust anchors and CRLs"); + result = gtls_populate_creds(cf, data, gtls->shared_creds->creds); + if(result) + return result; + gtls->shared_creds->trust_setup = TRUE; + if(cache_criteria_met) + gtls_set_cached_creds(cf, data, gtls->shared_creds); + } + return CURLE_OK; +} + +#ifdef CURL_GNUTLS_EARLY_DATA +static int gtls_get_ietf_proto(gnutls_session_t session) +{ + switch(gnutls_protocol_get_version(session)) { + case GNUTLS_SSL3: + return CURL_IETF_PROTO_SSL3; + case GNUTLS_TLS1_0: + return CURL_IETF_PROTO_TLS1; + case GNUTLS_TLS1_1: + return CURL_IETF_PROTO_TLS1_1; + case GNUTLS_TLS1_2: + return CURL_IETF_PROTO_TLS1_2; + case GNUTLS_TLS1_3: + return CURL_IETF_PROTO_TLS1_3; + default: + return CURL_IETF_PROTO_UNKNOWN; + } +} + +CURLcode Curl_gtls_cache_session(struct Curl_cfilter *cf, + struct Curl_easy *data, + const char *ssl_peer_key, + gnutls_session_t session, + curl_off_t valid_until, + const char *alpn, + unsigned char *quic_tp, + size_t quic_tp_len) +{ + struct Curl_ssl_session *sc_session; + unsigned char *sdata, *qtp_clone = NULL; + size_t sdata_len = 0; + size_t earlydata_max = 0; + CURLcode result = CURLE_OK; + + if(!Curl_ssl_scache_use(cf, data)) + return CURLE_OK; + + /* we always unconditionally get the session id here, as even if we + already got it from the cache and asked to use it in the connection, it + might have been rejected and then a new one is in use now and we need to + detect that. */ + + /* get the session ID data size */ + gnutls_session_get_data(session, NULL, &sdata_len); + if(!sdata_len) /* GnuTLS does this for some version combinations */ + return CURLE_OK; + + sdata = curlx_malloc(sdata_len); /* get a buffer for it */ + if(!sdata) + return CURLE_OUT_OF_MEMORY; + + /* extract session ID to the allocated buffer */ + gnutls_session_get_data(session, sdata, &sdata_len); + earlydata_max = gnutls_record_get_max_early_data_size(session); + + CURL_TRC_CF(data, cf, "get session id (len=%zu, alpn=%s, earlymax=%zu) " + "and store in cache", sdata_len, alpn ? alpn : "-", + earlydata_max); + if(quic_tp && quic_tp_len) { + qtp_clone = curlx_memdup0((const char *)quic_tp, quic_tp_len); + if(!qtp_clone) { + curlx_free(sdata); + return CURLE_OUT_OF_MEMORY; + } + } + + result = Curl_ssl_session_create2(sdata, sdata_len, + gtls_get_ietf_proto(session), + alpn, valid_until, earlydata_max, + qtp_clone, quic_tp_len, + &sc_session); + /* call took ownership of `sdata` and `qtp_clone` */ + if(!result) { + result = Curl_ssl_scache_put(cf, data, ssl_peer_key, sc_session); + /* took ownership of `sc_session` */ + } + return result; +} +#endif + +#ifdef CURL_GNUTLS_EARLY_DATA +static CURLcode cf_gtls_update_session_id(struct Curl_cfilter *cf, + struct Curl_easy *data, + gnutls_session_t session) +{ + struct ssl_connect_data *connssl = cf->ctx; + return Curl_gtls_cache_session(cf, data, connssl->peer.scache_key, + session, 0, connssl->negotiated.alpn, + NULL, 0); +} + +static int gtls_handshake_cb(gnutls_session_t session, unsigned int htype, + unsigned when, unsigned int incoming, + const gnutls_datum_t *msg) +{ + struct Curl_cfilter *cf = gnutls_session_get_ptr(session); + + (void)msg; + (void)incoming; + if(when) { /* after message has been processed */ + struct Curl_easy *data = CF_DATA_CURRENT(cf); + if(data) { + CURL_TRC_CF(data, cf, "handshake: %s message type %u", + incoming ? "incoming" : "outgoing", htype); + switch(htype) { + case GNUTLS_HANDSHAKE_NEW_SESSION_TICKET: { + cf_gtls_update_session_id(cf, data, session); + break; + } + default: + break; + } + } + } + return 0; +} +#endif + +static CURLcode gtls_set_priority(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct gtls_ctx *gtls, + const char *priority) +{ + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + struct dynbuf buf; + const char *err = NULL; + CURLcode result = CURLE_OK; + int rc; + + curlx_dyn_init(&buf, 4096); + +#ifdef USE_GNUTLS_SRP + if(conn_config->username) { + /* Only add SRP to the cipher list if SRP is requested. Otherwise + * GnuTLS disables TLS 1.3 support. */ + result = curlx_dyn_add(&buf, priority); + if(!result) + result = curlx_dyn_add(&buf, ":" GNUTLS_SRP); + if(result) + goto out; + priority = curlx_dyn_ptr(&buf); + } +#endif + + if(conn_config->cipher_list) { + if((conn_config->cipher_list[0] == '+') || + (conn_config->cipher_list[0] == '-') || + (conn_config->cipher_list[0] == '!')) { + /* add it to our own */ + if(!curlx_dyn_len(&buf)) { /* not added yet */ + result = curlx_dyn_add(&buf, priority); + if(result) + goto out; + } + result = curlx_dyn_addf(&buf, ":%s", conn_config->cipher_list); + if(result) + goto out; + priority = curlx_dyn_ptr(&buf); + } + else /* replace our own completely */ + priority = conn_config->cipher_list; + } + + infof(data, "GnuTLS priority: %s", priority); + rc = gnutls_priority_set_direct(gtls->session, priority, &err); + if(rc != GNUTLS_E_SUCCESS) { + failf(data, "Error %d setting GnuTLS priority: %s", rc, err); + result = CURLE_SSL_CONNECT_ERROR; + } + +out: + curlx_dyn_free(&buf); + return result; +} + +static CURLcode gtls_client_init(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct ssl_peer *peer, + size_t earlydata_max, + struct gtls_ctx *gtls) +{ + struct ssl_primary_config *config = Curl_ssl_cf_get_primary_config(cf); + struct ssl_config_data *ssl_config = Curl_ssl_cf_get_config(cf, data); + unsigned int init_flags; + int rc; + const char *prioritylist; + bool tls13support; + CURLcode result; + + if(config->version == CURL_SSLVERSION_SSLv2 || + config->version == CURL_SSLVERSION_SSLv3) { + failf(data, "GnuTLS does not support SSLv2 or SSLv3"); + return CURLE_SSL_CONNECT_ERROR; + } + + /* allocate a shared creds struct */ + result = Curl_gtls_shared_creds_create(data, >ls->shared_creds); + if(result) + return result; + +#ifdef USE_GNUTLS_SRP + if(config->username && Curl_auth_allowed_to_host(data)) { + infof(data, "Using TLS-SRP username: %s", config->username); + + rc = gnutls_srp_allocate_client_credentials(>ls->srp_client_cred); + if(rc == GNUTLS_E_UNIMPLEMENTED_FEATURE) { + failf(data, "GnuTLS: TLS-SRP support not built in: %s", + gnutls_strerror(rc)); + return CURLE_NOT_BUILT_IN; + } + else if(rc != GNUTLS_E_SUCCESS) { + failf(data, "gnutls_srp_allocate_client_cred() failed: %s", + gnutls_strerror(rc)); + return CURLE_OUT_OF_MEMORY; + } + + rc = gnutls_srp_set_client_credentials(gtls->srp_client_cred, + config->username, + config->password); + if(rc != GNUTLS_E_SUCCESS) { + failf(data, "gnutls_srp_set_client_cred() failed: %s", + gnutls_strerror(rc)); + return CURLE_BAD_FUNCTION_ARGUMENT; + } + } +#endif + + ssl_config->certverifyresult = 0; + + /* Initialize TLS session as a client */ + init_flags = GNUTLS_CLIENT; +#ifdef CURL_GNUTLS_EARLY_DATA + if(peer->transport == TRNSPRT_QUIC && earlydata_max > 0) + init_flags |= GNUTLS_ENABLE_EARLY_DATA | GNUTLS_NO_END_OF_EARLY_DATA; + else if(earlydata_max > 0 && earlydata_max != 0xFFFFFFFFUL) + /* See https://gitlab.com/gnutls/gnutls/-/issues/1619 + * We cannot differentiate between a session announcing no earldata + * and one announcing 0xFFFFFFFFUL. On TCP+TLS, this is unlikely, but + * on QUIC this is common. */ + init_flags |= GNUTLS_ENABLE_EARLY_DATA; +#endif + +#ifdef GNUTLS_FORCE_CLIENT_CERT + init_flags |= GNUTLS_FORCE_CLIENT_CERT; +#endif + +#ifdef GNUTLS_NO_TICKETS_TLS12 + init_flags |= GNUTLS_NO_TICKETS_TLS12; +#endif + +#ifdef GNUTLS_NO_STATUS_REQUEST + if(!config->verifystatus) + /* Disable the "status_request" TLS extension, enabled by default since + GnuTLS 3.8.0. */ + init_flags |= GNUTLS_NO_STATUS_REQUEST; +#endif + + CURL_TRC_CF(data, cf, "gnutls_init(flags=%x), earlydata=%zu", + init_flags, earlydata_max); + rc = gnutls_init(>ls->session, init_flags); + if(rc != GNUTLS_E_SUCCESS) { + failf(data, "gnutls_init() failed: %d", rc); + return CURLE_SSL_CONNECT_ERROR; + } + + if(peer->sni) { + if(gnutls_server_name_set(gtls->session, GNUTLS_NAME_DNS, + peer->sni, strlen(peer->sni)) < 0) { + failf(data, "Failed to set SNI"); + return CURLE_SSL_CONNECT_ERROR; + } + } + + /* Use default priorities */ + rc = gnutls_set_default_priority(gtls->session); + if(rc != GNUTLS_E_SUCCESS) + return CURLE_SSL_CONNECT_ERROR; + + /* "In GnuTLS 3.6.5, TLS 1.3 is enabled by default" */ + tls13support = !!gnutls_check_version("3.6.5"); + + if(config->version == CURL_SSLVERSION_TLSv1_3) { + if(!tls13support) { + failf(data, "This GnuTLS installation does not support TLS 1.3"); + return CURLE_SSL_CONNECT_ERROR; + } + } + + /* At this point we know we have a supported TLS version, so set it */ + result = gnutls_set_ssl_version_min_max(data, peer, + config, &prioritylist, tls13support); + if(result) + return result; + + result = gtls_set_priority(cf, data, gtls, prioritylist); + if(result) + return result; + + if(config->clientcert) { + if(!gtls->shared_creds->trust_setup) { + result = Curl_gtls_client_trust_setup(cf, data, gtls); + if(result) + return result; + } + if(ssl_config->primary.cert_type && + curl_strequal(ssl_config->primary.cert_type, "P12")) { + rc = gnutls_certificate_set_x509_simple_pkcs12_file( + gtls->shared_creds->creds, config->clientcert, GNUTLS_X509_FMT_DER, + ssl_config->primary.key_passwd ? ssl_config->primary.key_passwd : ""); + if(rc != GNUTLS_E_SUCCESS) { + failf(data, + "error reading X.509 potentially-encrypted key or certificate " + "file: %s", + gnutls_strerror(rc)); + return CURLE_SSL_CONNECT_ERROR; + } + } + else { + const unsigned int supported_key_encryption_algorithms = + GNUTLS_PKCS_USE_PKCS12_3DES | GNUTLS_PKCS_USE_PKCS12_ARCFOUR | + GNUTLS_PKCS_USE_PKCS12_RC2_40 | GNUTLS_PKCS_USE_PBES2_3DES | + GNUTLS_PKCS_USE_PBES2_AES_128 | GNUTLS_PKCS_USE_PBES2_AES_192 | + GNUTLS_PKCS_USE_PBES2_AES_256; + rc = gnutls_certificate_set_x509_key_file2( + gtls->shared_creds->creds, + config->clientcert, + ssl_config->primary.key ? ssl_config->primary.key : + config->clientcert, + gnutls_do_file_type(ssl_config->primary.cert_type), + ssl_config->primary.key_passwd, + supported_key_encryption_algorithms); + if(rc != GNUTLS_E_SUCCESS) { + failf(data, + "error reading X.509 %skey file: %s", + ssl_config->primary.key_passwd ? "potentially-encrypted " : "", + gnutls_strerror(rc)); + return CURLE_SSL_CONNECT_ERROR; + } + } + } + +#ifdef USE_GNUTLS_SRP + /* put the credentials to the current session */ + if(config->username) { + rc = gnutls_credentials_set(gtls->session, GNUTLS_CRD_SRP, + gtls->srp_client_cred); + if(rc != GNUTLS_E_SUCCESS) { + failf(data, "gnutls_credentials_set() failed: %s", gnutls_strerror(rc)); + return CURLE_SSL_CONNECT_ERROR; + } + } + else +#endif + { + rc = gnutls_credentials_set(gtls->session, GNUTLS_CRD_CERTIFICATE, + gtls->shared_creds->creds); + if(rc != GNUTLS_E_SUCCESS) { + failf(data, "gnutls_credentials_set() failed: %s", gnutls_strerror(rc)); + return CURLE_SSL_CONNECT_ERROR; + } + } + + if(config->verifystatus) { + rc = gnutls_ocsp_status_request_enable_client(gtls->session, + NULL, 0, NULL); + if(rc != GNUTLS_E_SUCCESS) { + failf(data, "gnutls_ocsp_status_request_enable_client() failed: %d", rc); + return CURLE_SSL_CONNECT_ERROR; + } + } + + return CURLE_OK; +} + +#ifdef CURL_GNUTLS_EARLY_DATA +static int keylog_callback(gnutls_session_t session, const char *label, + const gnutls_datum_t *secret) +{ + gnutls_datum_t crandom; + gnutls_datum_t srandom; + + gnutls_session_get_random(session, &crandom, &srandom); + if(crandom.size != 32) { + return -1; + } + + Curl_tls_keylog_write(label, crandom.data, secret->data, secret->size); + return 0; +} + +static CURLcode gtls_on_session_reuse(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct alpn_spec *alpns, + struct Curl_ssl_session *scs, + bool *do_early_data) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct gtls_ssl_backend_data *backend = + (struct gtls_ssl_backend_data *)connssl->backend; + + connssl->earlydata_max = + gnutls_record_get_max_early_data_size(backend->gtls.session); + + /* Seems to be no GnuTLS way to signal no EarlyData in session */ + return Curl_on_session_reuse(cf, data, alpns, scs, do_early_data, + connssl->earlydata_max && + connssl->earlydata_max != 0xFFFFFFFFUL); +} +#endif + +CURLcode Curl_gtls_ctx_init(struct gtls_ctx *gctx, + struct Curl_cfilter *cf, + struct Curl_easy *data, + struct ssl_peer *peer, + const struct alpn_spec *alpns_requested, + Curl_gtls_ctx_setup_cb *cb_setup, + void *cb_user_data, + void *ssl_user_data, + Curl_gtls_init_session_reuse_cb *sess_reuse_cb) +{ + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + struct ssl_config_data *ssl_config = Curl_ssl_cf_get_config(cf, data); + struct Curl_ssl_session *scs = NULL; + gnutls_datum_t gtls_alpns[ALPN_ENTRIES_MAX]; + size_t gtls_alpns_count = 0; + bool gtls_session_setup = FALSE; + struct alpn_spec alpns; + CURLcode result = CURLE_OK; + int rc; + + DEBUGASSERT(gctx); + Curl_alpn_copy(&alpns, alpns_requested); + + /* This might be a reconnect, so we check for a session ID in the cache + to speed up things. We need to do this before constructing the GnuTLS + session since we need to set flags depending on the kind of reuse. */ + if(conn_config->cache_session && !conn_config->verifystatus) { + result = Curl_ssl_scache_take(cf, data, peer->scache_key, &scs); + if(result) + goto out; + + if(scs && scs->sdata && scs->sdata_len && + (!scs->alpn || Curl_alpn_contains_proto(&alpns, scs->alpn))) { + /* we got a cached session, use it! */ + + result = gtls_client_init(cf, data, peer, scs->earlydata_max, gctx); + if(result) + goto out; + gtls_session_setup = TRUE; + + rc = gnutls_session_set_data(gctx->session, scs->sdata, scs->sdata_len); + if(rc < 0) + infof(data, "SSL session not accepted by GnuTLS, continuing without"); + else { + infof(data, "SSL reusing session with ALPN '%s'", + scs->alpn ? scs->alpn : "-"); + if(ssl_config->earlydata && scs->alpn && + !cf->conn->bits.connect_only) { + bool do_early_data = FALSE; + if(sess_reuse_cb) { + result = sess_reuse_cb(cf, data, &alpns, scs, &do_early_data); + if(result) + goto out; + } + if(do_early_data) { + /* We only try the ALPN protocol the session used before, + * otherwise we might send early data for the wrong protocol */ + Curl_alpn_restrict_to(&alpns, scs->alpn); + } + } + } + } + } + + if(!gtls_session_setup) { + result = gtls_client_init(cf, data, peer, 0, gctx); + if(result) + goto out; + } + + gnutls_session_set_ptr(gctx->session, ssl_user_data); + + if(cb_setup) { + result = cb_setup(cf, data, cb_user_data); + if(result) + goto out; + } + +#ifdef CURL_GNUTLS_EARLY_DATA + /* Open the file if a TLS or QUIC backend has not done this before. */ + Curl_tls_keylog_open(); + if(Curl_tls_keylog_enabled()) { + gnutls_session_set_keylog_function(gctx->session, keylog_callback); + } +#endif + + /* convert the ALPN string from our arguments to a list of strings that + * GnuTLS wants and does convert internally back to this string for sending + * to the server. nice. */ + if(!gtls_alpns_count && alpns.count) { + size_t i; + DEBUGASSERT(CURL_ARRAYSIZE(gtls_alpns) >= alpns.count); + for(i = 0; i < alpns.count; ++i) { + gtls_alpns[i].data = (unsigned char *)alpns.entries[i]; + gtls_alpns[i].size = (unsigned int)strlen(alpns.entries[i]); + } + gtls_alpns_count = alpns.count; + } + + if(gtls_alpns_count && + gnutls_alpn_set_protocols(gctx->session, + gtls_alpns, (unsigned int)gtls_alpns_count, + GNUTLS_ALPN_MANDATORY)) { + failf(data, "failed setting ALPN"); + result = CURLE_SSL_CONNECT_ERROR; + } + +out: + Curl_ssl_scache_return(cf, data, peer->scache_key, scs); + return result; +} + +static CURLcode gtls_connect_step1(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct gtls_ssl_backend_data *backend = + (struct gtls_ssl_backend_data *)connssl->backend; + CURLcode result; + + DEBUGASSERT(backend); + + if(connssl->state == ssl_connection_complete) + /* to make us tolerant against being called more than once for the + same connection */ + return CURLE_OK; + + result = Curl_gtls_ctx_init(&backend->gtls, cf, data, &connssl->peer, + connssl->alpn, NULL, NULL, cf, +#ifdef CURL_GNUTLS_EARLY_DATA + gtls_on_session_reuse +#else + NULL +#endif + ); + + if(result) + return result; + + if(connssl->alpn && (connssl->state != ssl_connection_deferred)) { + struct alpn_proto_buf proto; + memset(&proto, 0, sizeof(proto)); + Curl_alpn_to_proto_str(&proto, connssl->alpn); + infof(data, VTLS_INFOF_ALPN_OFFER_1STR, proto.data); + } + +#ifdef CURL_GNUTLS_EARLY_DATA + gnutls_handshake_set_hook_function(backend->gtls.session, + GNUTLS_HANDSHAKE_ANY, GNUTLS_HOOK_POST, + gtls_handshake_cb); +#endif + + /* register callback functions and handle to send and receive data. */ + gnutls_transport_set_ptr(backend->gtls.session, cf); + gnutls_transport_set_push_function(backend->gtls.session, gtls_push); + gnutls_transport_set_pull_function(backend->gtls.session, gtls_pull); + + return CURLE_OK; +} + +static CURLcode pkp_pin_peer_pubkey(struct Curl_easy *data, + gnutls_x509_crt_t cert, + const char *pinnedpubkey) +{ + /* Scratch */ + size_t len1 = 0, len2 = 0; + unsigned char *buff1 = NULL; + + gnutls_pubkey_t key = NULL; + + /* Result is returned to caller */ + CURLcode result = CURLE_SSL_PINNEDPUBKEYNOTMATCH; + + /* if a path was not specified, do not pin */ + if(!pinnedpubkey) + return CURLE_OK; + + if(!cert) + return result; + + do { + int ret; + + /* Begin Gyrations to get the public key */ + ret = gnutls_pubkey_init(&key); + if(ret < 0) + break; /* failed */ + + ret = gnutls_pubkey_import_x509(key, cert, 0); + if(ret < 0) + break; /* failed */ + + ret = gnutls_pubkey_export(key, GNUTLS_X509_FMT_DER, NULL, &len1); + if(ret != GNUTLS_E_SHORT_MEMORY_BUFFER || len1 == 0) + break; /* failed */ + + buff1 = curlx_malloc(len1); + if(!buff1) + break; /* failed */ + + len2 = len1; + + ret = gnutls_pubkey_export(key, GNUTLS_X509_FMT_DER, buff1, &len2); + if(ret < 0 || len1 != len2) + break; /* failed */ + + /* End Gyrations */ + + /* The one good exit point */ + result = Curl_pin_peer_pubkey(data, pinnedpubkey, buff1, len1); + } while(0); + + if(key) + gnutls_pubkey_deinit(key); + + curlx_safefree(buff1); + + return result; +} + +void Curl_gtls_report_handshake(struct Curl_easy *data, struct gtls_ctx *gctx) +{ +#ifdef CURLVERBOSE + if(Curl_trc_is_verbose(data)) { + const char *ptr; + gnutls_protocol_t version = gnutls_protocol_get_version(gctx->session); + + /* the name of the cipher suite used, e.g. ECDHE_RSA_AES_256_GCM_SHA384. */ + ptr = gnutls_cipher_suite_get_name(gnutls_kx_get(gctx->session), + gnutls_cipher_get(gctx->session), + gnutls_mac_get(gctx->session)); + + infof(data, "SSL connection using %s / %s", + gnutls_protocol_get_name(version), ptr); + } +#else + (void)data; + (void)gctx; +#endif +} + +static void gtls_msg_verify_result(struct Curl_easy *data, + struct ssl_peer *peer, + gnutls_x509_crt_t x509_cert, + bool was_verified, + bool needs_verified) +{ + char certname[65] = ""; /* limited to 64 chars by ASN.1 */ + size_t size = sizeof(certname); + int rc; + + rc = gnutls_x509_crt_get_dn_by_oid(x509_cert, GNUTLS_OID_X520_COMMON_NAME, + 0, /* the first and only one */ + FALSE, certname, &size); + if(rc) { + infof(data, "error fetching CN from cert:%s", gnutls_strerror(rc)); + certname[0] = 0; + } + + if(!was_verified) { + if(needs_verified) { + failf(data, "SSL: certificate subject name (%s) does not match " + "target hostname '%s'", certname, + peer->origin->user_hostname); + } + else + infof(data, " common name: %s (does not match '%s')", + certname, peer->origin->user_hostname); + } + else + infof(data, " common name: %s (matched)", certname); +} + +static void gtls_infof_cert(struct Curl_easy *data, + gnutls_x509_crt_t x509_cert) +{ +#ifdef CURLVERBOSE + if(Curl_trc_is_verbose(data)) { + gnutls_datum_t certfields; + int rc, algo; + time_t tstamp; + unsigned int bits; + + /* public key algorithm's parameters */ + algo = gnutls_x509_crt_get_pk_algorithm(x509_cert, &bits); + infof(data, " certificate public key: %s", + gnutls_pk_algorithm_get_name((gnutls_pk_algorithm_t)algo)); + + /* version of the X.509 certificate. */ + infof(data, " certificate version: #%d", + gnutls_x509_crt_get_version(x509_cert)); + + rc = gnutls_x509_crt_get_dn2(x509_cert, &certfields); + if(rc) + infof(data, "Failed to get certificate name"); + else { + infof(data, " subject: %s", certfields.data); + + tstamp = gnutls_x509_crt_get_activation_time(x509_cert); + showtime(data, "start date", tstamp); + + tstamp = gnutls_x509_crt_get_expiration_time(x509_cert); + showtime(data, "expire date", tstamp); + + gnutls_free(certfields.data); + } + + rc = gnutls_x509_crt_get_issuer_dn2(x509_cert, &certfields); + if(rc) + infof(data, "Failed to get certificate issuer"); + else { + infof(data, " issuer: %s", certfields.data); + + gnutls_free(certfields.data); + } + } +#else + (void)data; + (void)x509_cert; +#endif +} + +static CURLcode gtls_verify_ocsp_status(struct Curl_easy *data, + gnutls_session_t session) +{ + gnutls_ocsp_resp_t ocsp_resp = NULL; + gnutls_datum_t status_request; + gnutls_certificate_credentials_t creds = NULL; + gnutls_x509_trust_list_t tlist = NULL; + unsigned int verify_status = 0; + gnutls_ocsp_cert_status_t status = GNUTLS_OCSP_CERT_UNKNOWN; + gnutls_x509_crl_reason_t reason; + CURLcode result = CURLE_OK; + int rc; + + rc = gnutls_ocsp_status_request_get(session, &status_request); + + if(rc == GNUTLS_E_REQUESTED_DATA_NOT_AVAILABLE) { + failf(data, "No OCSP response received"); + result = CURLE_SSL_INVALIDCERTSTATUS; + goto out; + } + else if(rc < 0) { + failf(data, "Invalid OCSP response received"); + result = CURLE_SSL_INVALIDCERTSTATUS; + goto out; + } + + rc = gnutls_ocsp_resp_init(&ocsp_resp); + if(rc < 0) { + failf(data, "Failed to initialize OCSP response object"); + result = CURLE_SSL_INVALIDCERTSTATUS; + goto out; + } + + rc = gnutls_ocsp_resp_import(ocsp_resp, &status_request); + if(rc < 0) { + failf(data, "Invalid OCSP response received"); + result = CURLE_SSL_INVALIDCERTSTATUS; + goto out; + } + + if(!gnutls_credentials_get(session, GNUTLS_CRD_CERTIFICATE, (void **)&creds)) + gnutls_certificate_get_trust_list(creds, &tlist); + if(!tlist) { + failf(data, "OCSP response signature verification failed"); + result = CURLE_SSL_INVALIDCERTSTATUS; + goto out; + } + rc = gnutls_ocsp_resp_verify(ocsp_resp, tlist, &verify_status, 0); + if(rc < 0 || verify_status) { + failf(data, "OCSP response signature verification failed"); + result = CURLE_SSL_INVALIDCERTSTATUS; + goto out; + } + + (void)gnutls_ocsp_resp_get_single(ocsp_resp, 0, NULL, NULL, NULL, NULL, + &status, NULL, NULL, NULL, &reason); + + switch(status) { + case GNUTLS_OCSP_CERT_GOOD: + break; + + case GNUTLS_OCSP_CERT_REVOKED: { + const char *crl_reason; + + switch(reason) { + default: + case GNUTLS_X509_CRLREASON_UNSPECIFIED: + crl_reason = "unspecified reason"; + break; + + case GNUTLS_X509_CRLREASON_KEYCOMPROMISE: + crl_reason = "private key compromised"; + break; + + case GNUTLS_X509_CRLREASON_CACOMPROMISE: + crl_reason = "CA compromised"; + break; + + case GNUTLS_X509_CRLREASON_AFFILIATIONCHANGED: + crl_reason = "affiliation has changed"; + break; + + case GNUTLS_X509_CRLREASON_SUPERSEDED: + crl_reason = "certificate superseded"; + break; + + case GNUTLS_X509_CRLREASON_CESSATIONOFOPERATION: + crl_reason = "operation has ceased"; + break; + + case GNUTLS_X509_CRLREASON_CERTIFICATEHOLD: + crl_reason = "certificate is on hold"; + break; + + case GNUTLS_X509_CRLREASON_REMOVEFROMCRL: + crl_reason = "will be removed from delta CRL"; + break; + + case GNUTLS_X509_CRLREASON_PRIVILEGEWITHDRAWN: + crl_reason = "privilege withdrawn"; + break; + + case GNUTLS_X509_CRLREASON_AACOMPROMISE: + crl_reason = "AA compromised"; + break; + } + + failf(data, "Server certificate was revoked: %s", crl_reason); + break; + } + + default: + case GNUTLS_OCSP_CERT_UNKNOWN: + failf(data, "Server certificate status is unknown"); + break; + } + + result = (status != GNUTLS_OCSP_CERT_GOOD) ? + CURLE_SSL_INVALIDCERTSTATUS : CURLE_OK; + +out: + if(ocsp_resp) + gnutls_ocsp_resp_deinit(ocsp_resp); + return result; +} + +struct gtls_cert_chain { + const gnutls_datum_t *certs; + unsigned int num_certs; +}; + +#ifdef USE_APPLE_SECTRUST +static CURLcode gtls_chain_get_der(struct Curl_cfilter *cf, + struct Curl_easy *data, + void *user_data, + size_t i, + unsigned char **pder, + size_t *pder_len) +{ + struct gtls_cert_chain *chain = user_data; + + (void)cf; + (void)data; + *pder_len = 0; + *pder = NULL; + + if(i >= chain->num_certs) + return CURLE_TOO_LARGE; + *pder = chain->certs[i].data; + *pder_len = (size_t)chain->certs[i].size; + return CURLE_OK; +} +#endif /* USE_APPLE_SECTRUST */ + +/* This function verifies the peer's certificate and returns CURLE_OK on + success or an appropriate CURLcode on error. The certificate verification + status bitmask (trusted, invalid etc.) is stored in + ssl_config->certverifyresult as one or more gnutls_certificate_status_t + enumerated elements bitwise or'd. */ +static CURLcode gtls_verify_cert(struct Curl_easy *data, + struct ssl_primary_config *config, + struct ssl_config_data *ssl_config, + gnutls_session_t session, + struct Curl_cfilter *cf, + struct ssl_peer *peer, + struct gtls_cert_chain *chain) +{ + bool verified = FALSE; + unsigned int verify_status = 0; + long * const certverifyresult = &ssl_config->certverifyresult; + int rc = gnutls_certificate_verify_peers2(session, &verify_status); + if(rc < 0) { + failf(data, "server cert verify failed: %d", rc); + *certverifyresult = rc; + return CURLE_SSL_CONNECT_ERROR; + } + *certverifyresult = verify_status; + verified = !(verify_status & GNUTLS_CERT_INVALID); + if(verified) + infof(data, " SSL certificate verified by GnuTLS"); + +#ifdef USE_APPLE_SECTRUST + if(!verified && ssl_config->native_ca_store) { + CURLcode result = + Curl_vtls_apple_verify(cf, data, peer, chain->num_certs, + gtls_chain_get_der, chain, NULL, 0); + if(result && (result != CURLE_PEER_FAILED_VERIFICATION)) + return result; /* unexpected error */ + verified = !result; + if(verified) { + infof(data, "SSL certificate verified via Apple SecTrust."); + *certverifyresult = 0; + } + } +#else + (void)cf; + (void)peer; + (void)chain; +#endif + + if(!verified) { + /* verify_status is a bitmask of gnutls_certificate_status bits */ + const char *cause = "certificate error, no details available"; + if(verify_status & GNUTLS_CERT_EXPIRED) + cause = "certificate has expired"; + else if(verify_status & GNUTLS_CERT_SIGNER_NOT_FOUND) + cause = "certificate signer not trusted"; + else if(verify_status & GNUTLS_CERT_INSECURE_ALGORITHM) + cause = "certificate uses insecure algorithm"; + else if(verify_status & GNUTLS_CERT_INVALID_OCSP_STATUS) + cause = "attached OCSP status response is invalid"; + failf(data, "SSL certificate verification failed: %s. (CAfile: %s " + "CRLfile: %s)", cause, + config->CAfile ? config->CAfile : "none", + ssl_config->primary.CRLfile ? + ssl_config->primary.CRLfile : "none"); + + return CURLE_PEER_FAILED_VERIFICATION; + } + return CURLE_OK; +} + +CURLcode Curl_gtls_verifyserver(struct Curl_cfilter *cf, + struct Curl_easy *data, + gnutls_session_t session, + struct ssl_primary_config *config, + struct ssl_config_data *ssl_config, + struct ssl_peer *peer, + const char *pinned_key) +{ + struct gtls_cert_chain chain; + gnutls_x509_crt_t x509_cert = NULL, x509_issuer = NULL; + time_t certclock; + int rc; + CURLcode result = CURLE_OK; + long * const certverifyresult = &ssl_config->certverifyresult; + + (void)cf; + /* This function returns the peer's raw certificate (chain) as sent by + the peer. These certificates are in raw format (DER encoded for + X.509). In case of a X.509 then a certificate list may be present. The + first certificate in the list is the peer's certificate, following the + issuer's certificate, then the issuer's issuer etc. */ + + chain.certs = gnutls_certificate_get_peers(session, &chain.num_certs); + if(!chain.certs) { + if(config->verifypeer || + config->verifyhost || + config->issuercert) { +#ifdef USE_GNUTLS_SRP + if(ssl_config->primary.username && !config->verifypeer && + gnutls_cipher_get(session)) { + /* no peer cert, but auth is ok if we have SRP user and cipher and no + peer verify */ + } + else { +#endif + failf(data, "failed to get server cert"); + *certverifyresult = GNUTLS_E_NO_CERTIFICATE_FOUND; + result = CURLE_PEER_FAILED_VERIFICATION; + goto out; +#ifdef USE_GNUTLS_SRP + } +#endif + } + infof(data, " common name: WARNING could not obtain"); + } + + if(data->set.ssl.certinfo && chain.certs) { + if(chain.num_certs > MAX_ALLOWED_CERT_AMOUNT) { + failf(data, "%u certificates is more than allowed (%d)", + chain.num_certs, MAX_ALLOWED_CERT_AMOUNT); + result = CURLE_SSL_CONNECT_ERROR; + goto out; + } + else { + unsigned int i; + + result = Curl_ssl_init_certinfo(data, (int)chain.num_certs); + if(result) + goto out; + + for(i = 0; i < chain.num_certs; i++) { + const char *beg = (const char *)chain.certs[i].data; + const char *end = beg + chain.certs[i].size; + + result = Curl_extract_certinfo(data, (int)i, beg, end); + if(result) + goto out; + } + } + } + + if(config->verifypeer) { + result = gtls_verify_cert(data, config, ssl_config, session, + cf, peer, &chain); + if(result) + goto out; + } + else + infof(data, " SSL certificate verification SKIPPED"); + + /* initialize an X.509 certificate structure. */ + if(gnutls_x509_crt_init(&x509_cert)) { + failf(data, "failed to init GnuTLS x509_crt"); + *certverifyresult = GNUTLS_E_NO_CERTIFICATE_FOUND; + result = CURLE_SSL_CONNECT_ERROR; + goto out; + } + + if(chain.certs) { + /* convert the given DER or PEM encoded Certificate to the native + gnutls_x509_crt_t format */ + rc = gnutls_x509_crt_import(x509_cert, chain.certs, GNUTLS_X509_FMT_DER); + if(rc) { + failf(data, "error parsing server's certificate chain"); + *certverifyresult = GNUTLS_E_NO_CERTIFICATE_FOUND; + result = CURLE_SSL_CONNECT_ERROR; + goto out; + } + } + + /* Check for time-based validity */ + certclock = gnutls_x509_crt_get_expiration_time(x509_cert); + + if(certclock == (time_t)-1) { + if(config->verifypeer) { + failf(data, "server cert expiration date verify failed"); + *certverifyresult = GNUTLS_CERT_EXPIRED; + result = CURLE_SSL_CONNECT_ERROR; + goto out; + } + else + infof(data, " SSL certificate expiration date verify FAILED"); + } + else { + if(certclock < time(NULL)) { + if(config->verifypeer) { + failf(data, "server certificate expiration date has passed."); + *certverifyresult = GNUTLS_CERT_EXPIRED; + result = CURLE_PEER_FAILED_VERIFICATION; + goto out; + } + else + infof(data, " SSL certificate expiration date FAILED"); + } + else + infof(data, " SSL certificate expiration date OK"); + } + + certclock = gnutls_x509_crt_get_activation_time(x509_cert); + + if(certclock == (time_t)-1) { + if(config->verifypeer) { + failf(data, "server cert activation date verify failed"); + *certverifyresult = GNUTLS_CERT_NOT_ACTIVATED; + result = CURLE_SSL_CONNECT_ERROR; + goto out; + } + else + infof(data, " SSL certificate activation date verify FAILED"); + } + else { + if(certclock > time(NULL)) { + if(config->verifypeer) { + failf(data, "server certificate not activated yet."); + *certverifyresult = GNUTLS_CERT_NOT_ACTIVATED; + result = CURLE_PEER_FAILED_VERIFICATION; + goto out; + } + else + infof(data, " SSL certificate activation date FAILED"); + } + else + infof(data, " SSL certificate activation date OK"); + } + + if(config->verifystatus) { + result = gtls_verify_ocsp_status(data, session); + if(result) + goto out; + } + else + infof(data, " SSL certificate status verification SKIPPED"); + + if(config->issuercert) { + gnutls_datum_t issuerp; + if(gnutls_x509_crt_init(&x509_issuer)) { + failf(data, "failed to init GnuTLS x509_crt for issuer"); + result = CURLE_SSL_ISSUER_ERROR; + goto out; + } + issuerp = load_file(config->issuercert); + rc = gnutls_x509_crt_import(x509_issuer, &issuerp, GNUTLS_X509_FMT_PEM); + unload_file(issuerp); + if(rc) { + failf(data, "failed to import issuer certificate (%s) (Issuer Cert: %s)", + gnutls_strerror(rc), config->issuercert); + result = CURLE_SSL_ISSUER_ERROR; + goto out; + } + rc = (int)gnutls_x509_crt_check_issuer(x509_cert, x509_issuer); + if(rc <= 0) { + failf(data, "server certificate issuer check failed (Issuer Cert: %s)", + config->issuercert); + result = CURLE_SSL_ISSUER_ERROR; + goto out; + } + infof(data, " SSL certificate issuer check OK (Issuer Cert: %s)", + config->issuercert); + } + + /* This function checks if the given certificate's subject matches the + given hostname. This is a basic implementation of the matching described + in RFC2818 (HTTPS), which takes into account wildcards, and the subject + alternative name PKIX extension. Returns non zero on success, and zero on + failure. */ + + /* This function does not handle trailing dots, so if we have an SNI name + use that and fallback to the hostname only if there is no SNI (like for + IP addresses) */ + rc = (int)gnutls_x509_crt_check_hostname(x509_cert, + peer->sni ? peer->sni : + peer->origin->hostname); + result = (!rc && config->verifyhost) ? + CURLE_PEER_FAILED_VERIFICATION : CURLE_OK; + gtls_msg_verify_result(data, peer, x509_cert, rc, config->verifyhost); + if(result) + goto out; + + if(pinned_key) { + result = pkp_pin_peer_pubkey(data, x509_cert, pinned_key); + if(result != CURLE_OK) { + failf(data, "SSL: public key does not match pinned public key"); + goto out; + } + } + + gtls_infof_cert(data, x509_cert); + +out: + if(x509_issuer) + gnutls_x509_crt_deinit(x509_issuer); + if(x509_cert) + gnutls_x509_crt_deinit(x509_cert); + return result; +} + +static CURLcode gtls_verifyserver(struct Curl_cfilter *cf, + struct Curl_easy *data, + gnutls_session_t session) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + struct ssl_config_data *ssl_config = Curl_ssl_cf_get_config(cf, data); +#ifndef CURL_DISABLE_PROXY + const char *pinned_key = Curl_ssl_cf_is_proxy(cf) ? + data->set.str[STRING_SSL_PINNEDPUBLICKEY_PROXY] : + data->set.str[STRING_SSL_PINNEDPUBLICKEY]; +#else + const char *pinned_key = data->set.str[STRING_SSL_PINNEDPUBLICKEY]; +#endif + CURLcode result; + + result = Curl_gtls_verifyserver(cf, data, session, conn_config, ssl_config, + &connssl->peer, pinned_key); + if(result) + goto out; + +#ifdef CURL_GNUTLS_EARLY_DATA + /* Only on TLSv1.2 or lower do we have the session id now. For + * TLSv1.3 we get it via a SESSION_TICKET message that arrives later. */ + if(gnutls_protocol_get_version(session) < GNUTLS_TLS1_3) + result = cf_gtls_update_session_id(cf, data, session); +#endif + +out: + return result; +} + +#ifdef CURL_GNUTLS_EARLY_DATA +static CURLcode gtls_send_earlydata(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct gtls_ssl_backend_data *backend = + (struct gtls_ssl_backend_data *)connssl->backend; + CURLcode result = CURLE_OK; + const unsigned char *buf; + size_t blen; + ssize_t n; + + DEBUGASSERT(connssl->earlydata_state == ssl_earlydata_sending); + backend->gtls.io_result = CURLE_OK; + while(Curl_bufq_peek(&connssl->earlydata, &buf, &blen)) { + n = gnutls_record_send_early_data(backend->gtls.session, buf, blen); + CURL_TRC_CF(data, cf, "gtls_send_earlydata(len=%zu) -> %zd", blen, n); + if(n < 0) { + if(n == GNUTLS_E_AGAIN) + result = CURLE_AGAIN; + else + result = backend->gtls.io_result ? + backend->gtls.io_result : CURLE_SEND_ERROR; + goto out; + } + else if(!n) { + /* GnuTLS is buggy, it *SHOULD* return the amount of bytes it took in. + * Instead it returns 0 if everything was written. */ + n = (ssize_t)blen; + } + + Curl_bufq_skip(&connssl->earlydata, (size_t)n); + } + /* sent everything there was */ + infof(data, "SSL sending %zu bytes of early data", connssl->earlydata_skip); +out: + return result; +} +#endif + +/* + * This function is called after the TCP connect has completed. Setup the TLS + * layer and do all necessary magic. + */ +/* We use connssl->connecting_state to keep track of the connection status; + there are three states: 'ssl_connect_1' (not started yet or complete), + 'ssl_connect_2' (doing handshake with the server), and + 'ssl_connect_3' (verifying and getting stats). + */ +static CURLcode gtls_connect_common(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct gtls_ssl_backend_data *backend = + (struct gtls_ssl_backend_data *)connssl->backend; + CURLcode result = CURLE_OK; + + DEBUGASSERT(backend); + /* check if the connection has already been established */ + if(ssl_connection_complete == connssl->state) { + *done = TRUE; + return CURLE_OK; + } + + *done = FALSE; + + /* Initiate the connection, if not already done */ + if(connssl->connecting_state == ssl_connect_1) { + result = gtls_connect_step1(cf, data); + if(result) + goto out; + connssl->connecting_state = ssl_connect_2; + } + + if(connssl->connecting_state == ssl_connect_2) { +#ifdef CURL_GNUTLS_EARLY_DATA + if(connssl->earlydata_state == ssl_earlydata_await) { + goto out; + } + else if(connssl->earlydata_state == ssl_earlydata_sending) { + result = gtls_send_earlydata(cf, data); + if(result) + goto out; + connssl->earlydata_state = ssl_earlydata_sent; + } + DEBUGASSERT((connssl->earlydata_state == ssl_earlydata_none) || + (connssl->earlydata_state == ssl_earlydata_sent)); +#endif + result = cf_gtls_handshake(cf, data); + if(result) + goto out; + connssl->connecting_state = ssl_connect_3; + } + + /* Finish connecting once the handshake is done */ + if(connssl->connecting_state == ssl_connect_3) { + gnutls_datum_t proto; + int rc; + + Curl_gtls_report_handshake(data, &backend->gtls); + + result = gtls_verifyserver(cf, data, backend->gtls.session); + if(result) + goto out; + + connssl->state = ssl_connection_complete; + + rc = gnutls_alpn_get_selected_protocol(backend->gtls.session, &proto); + if(rc) { /* No ALPN from server */ + proto.data = NULL; + proto.size = 0; + } + + result = Curl_alpn_set_negotiated(cf, data, connssl, + proto.data, proto.size); + if(result) + goto out; + +#ifdef CURL_GNUTLS_EARLY_DATA + if(connssl->earlydata_state > ssl_earlydata_none) { + /* We should be in this state by now */ + DEBUGASSERT(connssl->earlydata_state == ssl_earlydata_sent); + connssl->earlydata_state = + (gnutls_session_get_flags(backend->gtls.session) & + GNUTLS_SFLAGS_EARLY_DATA) ? + ssl_earlydata_accepted : ssl_earlydata_rejected; + } +#endif + connssl->connecting_state = ssl_connect_done; + } + + if(connssl->connecting_state == ssl_connect_done) + DEBUGASSERT(connssl->state == ssl_connection_complete); + +out: + if(result == CURLE_AGAIN) { + *done = FALSE; + return CURLE_OK; + } + *done = ((connssl->state == ssl_connection_complete) || + (connssl->state == ssl_connection_deferred)); + CURL_TRC_CF(data, cf, "gtls_connect_common() -> %d, done=%d", (int)result, + *done); + return result; +} + +static CURLcode gtls_connect(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ +#ifdef CURL_GNUTLS_EARLY_DATA + struct ssl_connect_data *connssl = cf->ctx; + if((connssl->state == ssl_connection_deferred) && + (connssl->earlydata_state == ssl_earlydata_await)) { + /* We refuse to be pushed, we are waiting for someone to send/recv. */ + *done = TRUE; + return CURLE_OK; + } +#endif + return gtls_connect_common(cf, data, done); +} + +static bool gtls_data_pending(struct Curl_cfilter *cf, + const struct Curl_easy *data) +{ + struct ssl_connect_data *ctx = cf->ctx; + struct gtls_ssl_backend_data *backend; + + (void)data; + DEBUGASSERT(ctx && ctx->backend); + backend = (struct gtls_ssl_backend_data *)ctx->backend; + if(backend->gtls.session && + gnutls_record_check_pending(backend->gtls.session) != 0) + return TRUE; + return FALSE; +} + +static CURLcode gtls_send(struct Curl_cfilter *cf, + struct Curl_easy *data, + const void *buf, + size_t blen, + size_t *pnwritten) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct gtls_ssl_backend_data *backend = + (struct gtls_ssl_backend_data *)connssl->backend; + CURLcode result = CURLE_OK; + ssize_t nwritten; + size_t remain = blen; + + DEBUGASSERT(backend); + *pnwritten = 0; + + while(remain) { + backend->gtls.io_result = CURLE_OK; + nwritten = gnutls_record_send(backend->gtls.session, buf, remain); + + if(nwritten >= 0) { + *pnwritten += (size_t)nwritten; + DEBUGASSERT((size_t)nwritten <= remain); + buf = (char *)CURL_UNCONST(buf) + (size_t)nwritten; + remain -= (size_t)nwritten; + } + else { + if(*pnwritten && (nwritten == GNUTLS_E_AGAIN)) { + result = CURLE_OK; + goto out; + } + result = (nwritten == GNUTLS_E_AGAIN) ? + CURLE_AGAIN : + (backend->gtls.io_result ? backend->gtls.io_result : CURLE_SEND_ERROR); + goto out; + } + } + +out: + CURL_TRC_CF(data, cf, "gtls_send(len=%zu) -> %d, %zu", + blen, (int)result, *pnwritten); + return result; +} + +/* + * This function is called to shut down the SSL layer but keep the + * socket open (CCC - Clear Command Channel) + */ +static CURLcode gtls_shutdown(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool send_shutdown, bool *done) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct gtls_ssl_backend_data *backend = + (struct gtls_ssl_backend_data *)connssl->backend; + char buf[1024]; + CURLcode result = CURLE_OK; + ssize_t nread = 0; + size_t i; + + DEBUGASSERT(backend); + /* If we have no handshaked connection or already shut down */ + if(!backend->gtls.session || cf->shutdown || + connssl->state != ssl_connection_complete) { + *done = TRUE; + goto out; + } + + connssl->io_need = CURL_SSL_IO_NEED_NONE; + *done = FALSE; + + if(!backend->gtls.sent_shutdown) { + /* do this only once */ + backend->gtls.sent_shutdown = TRUE; + if(send_shutdown) { + int ret = gnutls_bye(backend->gtls.session, GNUTLS_SHUT_RDWR); + if((ret == GNUTLS_E_AGAIN) || (ret == GNUTLS_E_INTERRUPTED)) { + CURL_TRC_CF(data, cf, "SSL shutdown, gnutls_bye EAGAIN"); + connssl->io_need = gnutls_record_get_direction(backend->gtls.session) ? + CURL_SSL_IO_NEED_SEND : CURL_SSL_IO_NEED_RECV; + backend->gtls.sent_shutdown = FALSE; + result = CURLE_OK; + goto out; + } + if(ret != GNUTLS_E_SUCCESS) { + CURL_TRC_CF(data, cf, "SSL shutdown, gnutls_bye error: '%s'(%d)", + gnutls_strerror((int)ret), (int)ret); + result = CURLE_RECV_ERROR; + goto out; + } + } + } + + /* SSL should now have started the shutdown from our side. Since it + * was not complete, we are lacking the close notify from the server. */ + for(i = 0; i < 10; ++i) { + nread = gnutls_record_recv(backend->gtls.session, buf, sizeof(buf)); + if(nread <= 0) + break; + } + if(nread > 0) { + /* still data coming in? */ + } + else if(nread == 0) { + /* We got the close notify alert and are done. */ + *done = TRUE; + } + else if((nread == GNUTLS_E_AGAIN) || (nread == GNUTLS_E_INTERRUPTED)) { + connssl->io_need = gnutls_record_get_direction(backend->gtls.session) ? + CURL_SSL_IO_NEED_SEND : CURL_SSL_IO_NEED_RECV; + } + else { + CURL_TRC_CF(data, cf, "SSL shutdown, error: '%s'(%d)", + gnutls_strerror((int)nread), (int)nread); + result = CURLE_RECV_ERROR; + } + +out: + cf->shutdown = (result || *done); + return result; +} + +static void gtls_close(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct gtls_ssl_backend_data *backend = + (struct gtls_ssl_backend_data *)connssl->backend; + + DEBUGASSERT(backend); + CURL_TRC_CF(data, cf, "close"); + if(backend->gtls.session) { + gnutls_deinit(backend->gtls.session); + backend->gtls.session = NULL; + } + if(backend->gtls.shared_creds) { + Curl_gtls_shared_creds_free(&backend->gtls.shared_creds); + } +#ifdef USE_GNUTLS_SRP + if(backend->gtls.srp_client_cred) { + gnutls_srp_free_client_credentials(backend->gtls.srp_client_cred); + backend->gtls.srp_client_cred = NULL; + } +#endif +} + +static CURLcode gtls_recv(struct Curl_cfilter *cf, + struct Curl_easy *data, + char *buf, size_t blen, + size_t *pnread) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct gtls_ssl_backend_data *backend = + (struct gtls_ssl_backend_data *)connssl->backend; + CURLcode result = CURLE_OK; + ssize_t nread; + + DEBUGASSERT(backend); + + nread = gnutls_record_recv(backend->gtls.session, buf, blen); + + if(nread >= 0) + *pnread = (size_t)nread; + else { + if((nread == GNUTLS_E_AGAIN) || (nread == GNUTLS_E_INTERRUPTED)) { + result = CURLE_AGAIN; + goto out; + } + else if(nread == GNUTLS_E_REHANDSHAKE) { + /* Either TLSv1.2 renegotiate or a TLSv1.3 session key update. */ + result = cf_gtls_handshake(cf, data); + if(!result) + result = CURLE_AGAIN; /* make us get called again. */ + goto out; + } + else { + failf(data, "GnuTLS recv error (%d): %s", + (int)nread, gnutls_strerror((int)nread)); + result = backend->gtls.io_result ? + backend->gtls.io_result : CURLE_RECV_ERROR; + goto out; + } + } + +out: + CURL_TRC_CF(data, cf, "gtls_recv(len=%zu) -> %d, %zd", blen, + (int)result, nread); + return result; +} + +size_t Curl_gtls_version(char *buffer, size_t size) +{ + return curl_msnprintf(buffer, size, "GnuTLS/%s", gnutls_check_version(NULL)); +} + +/* data might be NULL! */ +static CURLcode gtls_random(struct Curl_easy *data, + unsigned char *entropy, size_t length) +{ + int rc; + (void)data; + rc = gnutls_rnd(GNUTLS_RND_RANDOM, entropy, length); + return rc ? CURLE_FAILED_INIT : CURLE_OK; +} + +static CURLcode gtls_sha256sum(const unsigned char *input, + size_t len, + unsigned char *sha256sum, /* output */ + size_t sha256len) +{ + struct sha256_ctx SHA256pw; + sha256_init(&SHA256pw); + do { + unsigned int ilen = (unsigned int)CURLMIN(len, UINT_MAX); + sha256_update(&SHA256pw, ilen, input); + len -= ilen; + input += ilen; + } while(len); +#if NETTLE_VERSION_MAJOR >= 4 + (void)sha256len; + sha256_digest(&SHA256pw, sha256sum); +#else + sha256_digest(&SHA256pw, (unsigned int)sha256len, sha256sum); +#endif + return CURLE_OK; +} + +static bool gtls_cert_status_request(void) +{ + return TRUE; +} + +static void *gtls_get_internals(struct ssl_connect_data *connssl, + CURLINFO info) +{ + struct gtls_ssl_backend_data *backend = + (struct gtls_ssl_backend_data *)connssl->backend; + (void)info; + DEBUGASSERT(backend); + return backend->gtls.session; +} + +const struct Curl_ssl Curl_ssl_gnutls = { + { CURLSSLBACKEND_GNUTLS, "gnutls" }, /* info */ + + SSLSUPP_CA_PATH | + SSLSUPP_CERTINFO | + SSLSUPP_PINNEDPUBKEY | + SSLSUPP_HTTPS_PROXY | + SSLSUPP_CAINFO_BLOB | + SSLSUPP_CIPHER_LIST | + SSLSUPP_CA_CACHE | + SSLSUPP_ISSUERCERT | + SSLSUPP_CRLFILE, + + sizeof(struct gtls_ssl_backend_data), + + gtls_init, /* init */ + gtls_cleanup, /* cleanup */ + Curl_gtls_version, /* version */ + gtls_shutdown, /* shutdown */ + gtls_data_pending, /* data_pending */ + gtls_random, /* random */ + gtls_cert_status_request, /* cert_status_request */ + gtls_connect, /* connect */ + Curl_ssl_adjust_pollset, /* adjust_pollset */ + gtls_get_internals, /* get_internals */ + gtls_close, /* close_one */ + NULL, /* close_all */ + NULL, /* set_engine */ + NULL, /* set_engine_default */ + NULL, /* engines_list */ + gtls_sha256sum, /* sha256sum */ + gtls_recv, /* recv decrypted data */ + gtls_send, /* send data to encrypt */ + NULL, /* get_channel_binding */ +}; + +#endif /* USE_GNUTLS */ diff --git a/3rdparty/curl-8.21.0/lib/vtls/gtls.h b/3rdparty/curl-8.21.0/lib/vtls/gtls.h new file mode 100644 index 0000000000..4c662003eb --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vtls/gtls.h @@ -0,0 +1,124 @@ +#ifndef HEADER_CURL_GTLS_H +#define HEADER_CURL_GTLS_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_GNUTLS + +#include + +#include "curlx/timeval.h" + +#ifdef HAVE_GNUTLS_SRP +/* the function exists */ +#ifdef USE_TLS_SRP +/* the functionality is not disabled */ +#define USE_GNUTLS_SRP +#endif +#endif + +struct Curl_easy; +struct Curl_cfilter; +struct alpn_spec; +struct ssl_primary_config; +struct ssl_config_data; +struct ssl_peer; +struct ssl_connect_data; +struct Curl_ssl_session; + +struct gtls_shared_creds { + gnutls_certificate_credentials_t creds; + char *CAfile; /* CAfile path used to generate X509 store */ + struct curltime time; /* when the shared creds was created */ + size_t refcount; + BIT(trust_setup); /* x509 anchors + CRLs have been set up */ +}; + +CURLcode Curl_gtls_shared_creds_create(struct Curl_easy *data, + struct gtls_shared_creds **pcreds); +CURLcode Curl_gtls_shared_creds_up_ref(struct gtls_shared_creds *creds); +void Curl_gtls_shared_creds_free(struct gtls_shared_creds **pcreds); + +struct gtls_ctx { + gnutls_session_t session; + struct gtls_shared_creds *shared_creds; +#ifdef USE_GNUTLS_SRP + gnutls_srp_client_credentials_t srp_client_cred; +#endif + CURLcode io_result; /* result of last IO cfilter operation */ + BIT(sent_shutdown); +}; + +size_t Curl_gtls_version(char *buffer, size_t size); + +typedef CURLcode Curl_gtls_ctx_setup_cb(struct Curl_cfilter *cf, + struct Curl_easy *data, + void *user_data); + +typedef CURLcode Curl_gtls_init_session_reuse_cb(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct alpn_spec *alpns, + struct Curl_ssl_session *scs, + bool *do_early_data); + +CURLcode Curl_gtls_ctx_init(struct gtls_ctx *gctx, + struct Curl_cfilter *cf, + struct Curl_easy *data, + struct ssl_peer *peer, + const struct alpn_spec *alpns_requested, + Curl_gtls_ctx_setup_cb *cb_setup, + void *cb_user_data, + void *ssl_user_data, + Curl_gtls_init_session_reuse_cb *sess_reuse_cb); + +CURLcode Curl_gtls_client_trust_setup(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct gtls_ctx *gtls); + +CURLcode Curl_gtls_verifyserver(struct Curl_cfilter *cf, + struct Curl_easy *data, + gnutls_session_t session, + struct ssl_primary_config *config, + struct ssl_config_data *ssl_config, + struct ssl_peer *peer, + const char *pinned_key); + +/* Extract TLS session and place in cache, if configured. */ +CURLcode Curl_gtls_cache_session(struct Curl_cfilter *cf, + struct Curl_easy *data, + const char *ssl_peer_key, + gnutls_session_t session, + curl_off_t valid_until, + const char *alpn, + unsigned char *quic_tp, + size_t quic_tp_len); + +/* Report properties of a successful handshake */ +void Curl_gtls_report_handshake(struct Curl_easy *data, struct gtls_ctx *gctx); + +extern const struct Curl_ssl Curl_ssl_gnutls; + +#endif /* USE_GNUTLS */ +#endif /* HEADER_CURL_GTLS_H */ diff --git a/3rdparty/curl-8.21.0/lib/vtls/hostcheck.c b/3rdparty/curl-8.21.0/lib/vtls/hostcheck.c new file mode 100644 index 0000000000..ad09b83194 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vtls/hostcheck.c @@ -0,0 +1,128 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if defined(USE_OPENSSL) || defined(USE_SCHANNEL) +/* these backends use functions from this file */ + +#ifdef HAVE_NETINET_IN_H +#include +#endif +#ifdef HAVE_NETINET_IN6_H +#include +#endif + +#include "curl_memrchr.h" +#include "vtls/hostcheck.h" +#include "hostip.h" + +/* check the two input strings with given length, but do not + assume they end in nul-bytes */ +static bool pmatch(const char *hostname, size_t hostlen, + const char *pattern, size_t patternlen) +{ + if(hostlen != patternlen) + return FALSE; + return curl_strnequal(hostname, pattern, hostlen); +} + +/* + * Match a hostname against a wildcard pattern. + * E.g. + * "foo.host.com" matches "*.host.com". + * + * We use the matching rule described in RFC6125, section 6.4.3. + * https://datatracker.ietf.org/doc/html/rfc6125#section-6.4.3 + * + * In addition: ignore trailing dots in the hostnames and wildcards, so that + * the names are used normalized. This is what the browsers do. + * + * Do not allow wildcard matching on IP numbers. There are apparently + * certificates being used with an IP address in the CN field, thus making no + * apparent distinction between a name and an IP. We need to detect the use of + * an IP address and not wildcard match on such names. + * + * Only match on "*" being used for the leftmost label, not "a*", "a*b" nor + * "*b". + * + * Return TRUE on a match. FALSE if not. + * + * @unittest: 1397 + */ + +static bool hostmatch(const char *hostname, + size_t hostlen, + const char *pattern, + size_t patternlen) +{ + const char *pattern_label_end; + + DEBUGASSERT(pattern); + DEBUGASSERT(patternlen); + DEBUGASSERT(hostname); + DEBUGASSERT(hostlen); + + /* normalize pattern and hostname by stripping off trailing dots */ + if(hostname[hostlen - 1] == '.') + hostlen--; + if(pattern[patternlen - 1] == '.') + patternlen--; + + if(strncmp(pattern, "*.", 2)) + return pmatch(hostname, hostlen, pattern, patternlen); + + /* detect host as IP address or starting with a dot and fail if so */ + else if(Curl_host_is_ipnum(hostname) || (hostname[0] == '.')) + return FALSE; + + /* We require at least 2 dots in the pattern to avoid too wide wildcard + match. */ + pattern_label_end = memchr(pattern, '.', patternlen); + if(!pattern_label_end || + (memrchr(pattern, '.', patternlen) == pattern_label_end)) + return pmatch(hostname, hostlen, pattern, patternlen); + else { + const char *hostname_label_end = memchr(hostname, '.', hostlen); + if(hostname_label_end) { + size_t skiphost = hostname_label_end - hostname; + size_t skiplen = pattern_label_end - pattern; + return pmatch(hostname_label_end, hostlen - skiphost, + pattern_label_end, patternlen - skiplen); + } + } + return FALSE; +} + +/* + * Curl_cert_hostcheck() returns TRUE if a match and FALSE if not. + */ +bool Curl_cert_hostcheck(const char *match, size_t matchlen, + const char *hostname, size_t hostlen) +{ + if(match && *match && hostname && *hostname) + return hostmatch(hostname, hostlen, match, matchlen); + return FALSE; +} + +#endif /* USE_OPENSSL || USE_SCHANNEL */ diff --git a/3rdparty/curl-8.21.0/lib/vtls/hostcheck.h b/3rdparty/curl-8.21.0/lib/vtls/hostcheck.h new file mode 100644 index 0000000000..d8e1a52377 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vtls/hostcheck.h @@ -0,0 +1,36 @@ +#ifndef HEADER_CURL_HOSTCHECK_H +#define HEADER_CURL_HOSTCHECK_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if defined(USE_OPENSSL) || defined(USE_SCHANNEL) + +/* returns TRUE if there is a match */ +bool Curl_cert_hostcheck(const char *match, size_t matchlen, + const char *hostname, size_t hostlen); + +#endif + +#endif /* HEADER_CURL_HOSTCHECK_H */ diff --git a/3rdparty/curl-8.21.0/lib/vtls/keylog.c b/3rdparty/curl-8.21.0/lib/vtls/keylog.c new file mode 100644 index 0000000000..094bf69db7 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vtls/keylog.c @@ -0,0 +1,161 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" +#include "vtls/keylog.h" + +#if defined(USE_OPENSSL) || defined(USE_GNUTLS) || defined(USE_WOLFSSL) || \ + defined(USE_RUSTLS) + +#include "escape.h" +#include "curlx/fopen.h" + +/* The fp for the open SSLKEYLOGFILE, or NULL if not open */ +static FILE *keylog_file_fp; +/* Used for verbose logging */ +static char *keylog_file_name; + +void Curl_tls_keylog_open(void) +{ + if(!keylog_file_fp) { + keylog_file_name = getenv("SSLKEYLOGFILE"); + if(keylog_file_name) { + keylog_file_fp = curlx_fopen(keylog_file_name, FOPEN_APPENDTEXT); + if(keylog_file_fp) { +#ifdef _WIN32 + if(setvbuf(keylog_file_fp, NULL, _IONBF, 0)) +#else + if(setvbuf(keylog_file_fp, NULL, _IOLBF, 4096)) +#endif + { + curlx_fclose(keylog_file_fp); + keylog_file_fp = NULL; + } + } + } + } +} + +void Curl_tls_keylog_close(void) +{ + if(keylog_file_fp) { + curlx_fclose(keylog_file_fp); + keylog_file_fp = NULL; + } +} + +bool Curl_tls_keylog_enabled(void) +{ + return !!keylog_file_fp; +} + +const char *Curl_tls_keylog_file_name(void) +{ + return keylog_file_name; +} + +bool Curl_tls_keylog_write_line(const char *line) +{ + /* The current maximum valid keylog line length LF and NUL is 195. */ + size_t linelen; + char buf[256]; + + if(!keylog_file_fp || !line) { + return FALSE; + } + + linelen = strlen(line); + if(linelen == 0 || linelen > sizeof(buf) - 2) { + /* Empty line or too big to fit in an LF and NUL. */ + return FALSE; + } + + memcpy(buf, line, linelen); + if(line[linelen - 1] != '\n') { + buf[linelen++] = '\n'; + } + buf[linelen] = '\0'; + + /* Using fputs here instead of fprintf since libcurl's fprintf replacement + may not be thread-safe. */ + fputs(buf, keylog_file_fp); + return TRUE; +} + +bool Curl_tls_keylog_write( + const char *label, + const unsigned char client_random[CLIENT_RANDOM_SIZE], + const unsigned char *secret, size_t secretlen) +{ + size_t pos, i; + unsigned char line[KEYLOG_LABEL_MAXLEN + 1 + + (2 * CLIENT_RANDOM_SIZE) + 1 + + (2 * SECRET_MAXLEN) + 1 + 1]; + + if(!keylog_file_fp) { + return FALSE; + } + + pos = strlen(label); + if(pos > KEYLOG_LABEL_MAXLEN || !secretlen || secretlen > SECRET_MAXLEN) { + /* Should never happen - sanity check anyway. */ + return FALSE; + } + + memcpy(line, label, pos); + line[pos++] = ' '; + + /* Client Random */ + for(i = 0; i < CLIENT_RANDOM_SIZE; i++) { + Curl_hexbyte(&line[pos], client_random[i]); + pos += 2; + } + line[pos++] = ' '; + + /* Secret */ + for(i = 0; i < secretlen; i++) { + Curl_hexbyte(&line[pos], secret[i]); + pos += 2; + } + line[pos++] = '\n'; + line[pos] = '\0'; + + /* Using fputs here instead of fprintf since libcurl's fprintf replacement + may not be thread-safe. */ + fputs((char *)line, keylog_file_fp); + return TRUE; +} + +#else /* TLS backend */ + +bool Curl_tls_keylog_enabled(void) +{ + return FALSE; +} + +const char *Curl_tls_keylog_file_name(void) +{ + return NULL; +} + +#endif /* TLS backend */ diff --git a/3rdparty/curl-8.21.0/lib/vtls/keylog.h b/3rdparty/curl-8.21.0/lib/vtls/keylog.h new file mode 100644 index 0000000000..b09fcc6f4d --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vtls/keylog.h @@ -0,0 +1,75 @@ +#ifndef HEADER_CURL_KEYLOG_H +#define HEADER_CURL_KEYLOG_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#define KEYLOG_LABEL_MAXLEN (sizeof("CLIENT_HANDSHAKE_TRAFFIC_SECRET") - 1) + +#define CLIENT_RANDOM_SIZE 32 + +/* + * The master secret in TLS 1.2 and before is always 48 bytes. In TLS 1.3, the + * secret size depends on the cipher suite's hash function which is 32 bytes + * for SHA-256 and 48 bytes for SHA-384. + */ +#define SECRET_MAXLEN 48 + +/* + * Opens the TLS key log file if requested by the user. The SSLKEYLOGFILE + * environment variable specifies the output file. + */ +void Curl_tls_keylog_open(void); + +/* + * Closes the TLS key log file if not already. + */ +void Curl_tls_keylog_close(void); + +/* + * Returns true if the user successfully enabled the TLS key log file. + */ +bool Curl_tls_keylog_enabled(void); + +/* + * Returns a pointer to the filename keys are being written to, if enabled. + */ +const char *Curl_tls_keylog_file_name(void); + +/* + * Appends a key log file entry. + * Returns true iff the key log file is open and a valid entry was provided. + */ +bool Curl_tls_keylog_write( + const char *label, + const unsigned char client_random[CLIENT_RANDOM_SIZE], + const unsigned char *secret, size_t secretlen); + +/* + * Appends a line to the key log file, ensure it is terminated by an LF. + * Returns true iff the key log file is open and a valid line was provided. + */ +bool Curl_tls_keylog_write_line(const char *line); + +#endif /* HEADER_CURL_KEYLOG_H */ diff --git a/3rdparty/curl-8.21.0/lib/vtls/mbedtls.c b/3rdparty/curl-8.21.0/lib/vtls/mbedtls.c new file mode 100644 index 0000000000..57727613ae --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vtls/mbedtls.c @@ -0,0 +1,1638 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * Copyright (C) Hoi-Ho Chan, + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +/* + * Source file for all mbedTLS-specific code for the TLS/SSL layer. No code + * but vtls.c should ever call or use these functions. + * + */ +#include "curl_setup.h" + +#ifdef USE_MBEDTLS + +/* Define this to enable lots of debugging for mbedTLS */ +/* #define MBEDTLS_DEBUG */ + +#include +#if MBEDTLS_VERSION_NUMBER < 0x03020000 +#error "mbedTLS 3.2.0 or later required" +#endif +#include +#include +#include +#include +#include + +#if MBEDTLS_VERSION_NUMBER < 0x04000000 && !defined(MBEDTLS_CTR_DRBG_C) +#error "MBEDTLS_CTR_DRBG_C is required for mbedTLS 3.x." +#endif + +#include +#if MBEDTLS_VERSION_NUMBER < 0x04000000 +#include +#include +#endif +#ifdef MBEDTLS_DEBUG +#include +#endif + +#include "vtls/cipher_suite.h" +#include "urldata.h" +#include "curl_trc.h" +#include "vtls/mbedtls.h" +#include "vtls/vtls.h" +#include "vtls/vtls_int.h" +#include "vtls/vtls_scache.h" +#include "vtls/x509asn1.h" +#include "connect.h" /* for the connect timeout */ +#include "curlx/strdup.h" +#include "curl_sha256.h" + +/* ALPN for http2 */ +#if defined(USE_HTTP2) && defined(MBEDTLS_SSL_ALPN) +#define HAS_ALPN_MBEDTLS +#endif + +struct mbed_ssl_backend_data { + mbedtls_ssl_context ssl; + mbedtls_x509_crt cacert; + mbedtls_x509_crt clicert; +#ifdef MBEDTLS_X509_CRL_PARSE_C + mbedtls_x509_crl crl; +#endif + mbedtls_pk_context pk; + mbedtls_ssl_config config; +#ifdef HAS_ALPN_MBEDTLS + const char *protocols[3]; +#endif + int *ciphersuites; + size_t send_blocked_len; + BIT(initialized); /* mbedtls_ssl_context is initialized */ + BIT(sent_shutdown); + BIT(send_blocked); +}; + +/** A context for random number generation (RNG). + */ +#if MBEDTLS_VERSION_NUMBER < 0x04000000 +struct rng_context_t { + mbedtls_entropy_context entropy; + mbedtls_ctr_drbg_context drbg; +}; + +static struct rng_context_t rng; +#endif + +#ifndef MBEDTLS_ERROR_C +#define mbedtls_strerror(a, b, c) b[0] = 0 +#endif + +#ifdef MBEDTLS_DEBUG +static void mbed_debug(void *context, int level, const char *f_name, + int line_nb, const char *line) +{ + struct Curl_easy *data = (struct Curl_easy *)context; + (void)level; + (void)line_nb; + (void)f_name; + + if(data) { + size_t len = strlen(line); + if(len && (line[len - 1] == '\n')) + /* discount any trailing newline */ + len--; + infof(data, "%.*s", (int)len, line); + } +} +#endif + +static int mbedtls_bio_cf_write(void *bio, + const unsigned char *buf, size_t blen) +{ + struct Curl_cfilter *cf = bio; + struct Curl_easy *data = CF_DATA_CURRENT(cf); + size_t nwritten; + CURLcode result; + + DEBUGASSERT(data); + if(!data) + return 0; + + result = Curl_conn_cf_send(cf->next, data, buf, blen, FALSE, &nwritten); + CURL_TRC_CF(data, cf, "mbedtls_bio_cf_out_write(len=%zu) -> %d, %zu", + blen, (int)result, nwritten); + if(result == CURLE_AGAIN) + return MBEDTLS_ERR_SSL_WANT_WRITE; + return result ? -1 : (int)nwritten; +} + +static int mbedtls_bio_cf_read(void *bio, unsigned char *buf, size_t blen) +{ + struct Curl_cfilter *cf = bio; + struct Curl_easy *data = CF_DATA_CURRENT(cf); + size_t nread = 0; + CURLcode result; + + DEBUGASSERT(data); + if(!data) + return 0; + /* OpenSSL catches this case, so should we. */ + if(!buf) + return 0; + + result = Curl_conn_cf_recv(cf->next, data, (char *)buf, blen, &nread); + CURL_TRC_CF(data, cf, "mbedtls_bio_cf_in_read(len=%zu) -> %d, %zu", + blen, (int)result, nread); + if(result == CURLE_AGAIN) + return MBEDTLS_ERR_SSL_WANT_READ; + /* nread is never larger than int here */ + return result ? -1 : (int)nread; +} + +/* See: + * https://web.archive.org/web/20200921194007/tls.mbed.org/discussions/generic/howto-determine-exact-buffer-len-for-mbedtls_pk_write_pubkey_der + */ +#define RSA_PUB_DER_MAX_BYTES (38 + (2 * MBEDTLS_MPI_MAX_SIZE)) +#define ECP_PUB_DER_MAX_BYTES (30 + (2 * MBEDTLS_ECP_MAX_BYTES)) + +#define PUB_DER_MAX_BYTES (RSA_PUB_DER_MAX_BYTES > ECP_PUB_DER_MAX_BYTES ? \ + RSA_PUB_DER_MAX_BYTES : ECP_PUB_DER_MAX_BYTES) + +static CURLcode mbed_set_ssl_version_min_max( + struct Curl_easy *data, + struct mbed_ssl_backend_data *backend, + struct ssl_primary_config *conn_config) +{ + mbedtls_ssl_protocol_version ver_min = +#ifdef MBEDTLS_SSL_PROTO_TLS1_2 + MBEDTLS_SSL_VERSION_TLS1_2 +#else + MBEDTLS_SSL_VERSION_TLS1_3 +#endif + ; + mbedtls_ssl_protocol_version ver_max = +#ifdef MBEDTLS_SSL_PROTO_TLS1_3 + MBEDTLS_SSL_VERSION_TLS1_3 +#else + MBEDTLS_SSL_VERSION_TLS1_2 +#endif + ; + + DEBUGASSERT(conn_config->version != CURL_SSLVERSION_DEFAULT); + switch(conn_config->version) { + case CURL_SSLVERSION_TLSv1: + case CURL_SSLVERSION_TLSv1_0: + case CURL_SSLVERSION_TLSv1_1: + case CURL_SSLVERSION_TLSv1_2: +#ifdef MBEDTLS_SSL_PROTO_TLS1_2 + ver_min = MBEDTLS_SSL_VERSION_TLS1_2; + break; +#endif + case CURL_SSLVERSION_TLSv1_3: +#ifdef MBEDTLS_SSL_PROTO_TLS1_3 + ver_min = MBEDTLS_SSL_VERSION_TLS1_3; + break; +#endif + default: + failf(data, "mbedTLS: unsupported minimum TLS version value: %x", + conn_config->version); + return CURLE_SSL_CONNECT_ERROR; + } + + switch(conn_config->version_max) { + case CURL_SSLVERSION_MAX_DEFAULT: + case CURL_SSLVERSION_MAX_NONE: + case CURL_SSLVERSION_MAX_TLSv1_3: +#ifdef MBEDTLS_SSL_PROTO_TLS1_3 + ver_max = MBEDTLS_SSL_VERSION_TLS1_3; + break; +#endif +#ifdef MBEDTLS_SSL_PROTO_TLS1_2 + case CURL_SSLVERSION_MAX_TLSv1_2: + ver_max = MBEDTLS_SSL_VERSION_TLS1_2; + break; +#endif + case CURL_SSLVERSION_MAX_TLSv1_1: + case CURL_SSLVERSION_MAX_TLSv1_0: + default: + failf(data, "mbedTLS: unsupported maximum TLS version value"); + return CURLE_SSL_CONNECT_ERROR; + } + + mbedtls_ssl_conf_min_tls_version(&backend->config, ver_min); + mbedtls_ssl_conf_max_tls_version(&backend->config, ver_max); + + return CURLE_OK; +} + +/* TLS_ECJPAKE_WITH_AES_128_CCM_8 (0xC0FF) is marked experimental in mbedTLS. + The number is not reserved by IANA nor is the cipher suite present in other + SSL implementations. Provide provisional support for specifying the cipher + suite here. */ +#ifdef MBEDTLS_TLS_ECJPAKE_WITH_AES_128_CCM_8 +static int mbed_cipher_suite_get_str(uint16_t id, char *buf, size_t buf_size, + bool prefer_rfc) +{ + if(id == MBEDTLS_TLS_ECJPAKE_WITH_AES_128_CCM_8) + curl_msnprintf(buf, buf_size, "%s", "TLS_ECJPAKE_WITH_AES_128_CCM_8"); + else + return Curl_cipher_suite_get_str(id, buf, buf_size, prefer_rfc); + return 0; +} + +static uint16_t mbed_cipher_suite_walk_str(const char **str, const char **end) +{ + uint16_t id = Curl_cipher_suite_walk_str(str, end); + size_t len = *end - *str; + static const char ecjpake_suite[] = "TLS_ECJPAKE_WITH_AES_128_CCM_8"; + + if(!id) { + if((len == sizeof(ecjpake_suite) - 1) && + curl_strnequal(ecjpake_suite, *str, len)) + id = MBEDTLS_TLS_ECJPAKE_WITH_AES_128_CCM_8; + } + return id; +} +#else +#define mbed_cipher_suite_get_str Curl_cipher_suite_get_str +#define mbed_cipher_suite_walk_str Curl_cipher_suite_walk_str +#endif + +static CURLcode mbed_set_selected_ciphers( + struct Curl_easy *data, + struct mbed_ssl_backend_data *backend, + const char *ciphers12, + const char *ciphers13) +{ + const char *ciphers = ciphers12; + const int *supported; + int *selected; + size_t supported_len, count = 0, default13_count = 0, i, j; + const char *ptr, *end; + + supported = mbedtls_ssl_list_ciphersuites(); + for(i = 0; supported[i] != 0; i++) + ; + supported_len = i; + + selected = curlx_malloc(sizeof(int) * (supported_len + 1)); + if(!selected) + return CURLE_OUT_OF_MEMORY; + +#ifndef MBEDTLS_SSL_PROTO_TLS1_3 + (void)ciphers13, (void)j; +#else + if(!ciphers13) { + /* Add default TLSv1.3 ciphers to selection */ + for(j = 0; j < supported_len; j++) { + uint16_t id = (uint16_t)supported[j]; + if(strncmp(mbedtls_ssl_get_ciphersuite_name(id), "TLS1-3", 6)) + continue; + + selected[count++] = id; + } + + default13_count = count; + } + else + ciphers = ciphers13; + +add_ciphers: +#endif + for(ptr = ciphers; ptr[0] != '\0' && count < supported_len; ptr = end) { + uint16_t id = mbed_cipher_suite_walk_str(&ptr, &end); + + /* Check if cipher is supported */ + if(id) { + for(i = 0; i < supported_len && supported[i] != id; i++) + ; + if(i == supported_len) + id = 0; + } + if(!id) { + if(ptr[0] != '\0') + infof(data, "mbedTLS: unknown cipher in list: \"%.*s\"", + (int)(end - ptr), ptr); + continue; + } + + /* No duplicates allowed (so selected cannot overflow) */ + for(i = 0; i < count && selected[i] != id; i++) + ; + if(i < count) { + if(i >= default13_count) + infof(data, "mbedTLS: duplicate cipher in list: \"%.*s\"", + (int)(end - ptr), ptr); + continue; + } + + selected[count++] = id; + } + +#ifdef MBEDTLS_SSL_PROTO_TLS1_3 + if(ciphers == ciphers13 && ciphers12) { + ciphers = ciphers12; + goto add_ciphers; + } + + if(!ciphers12) { + /* Add default TLSv1.2 ciphers to selection */ + for(j = 0; j < supported_len; j++) { + uint16_t id = (uint16_t)supported[j]; + if(!strncmp(mbedtls_ssl_get_ciphersuite_name(id), "TLS1-3", 6)) + continue; + + /* No duplicates allowed (so selected cannot overflow) */ + for(i = 0; i < count && selected[i] != id; i++) + ; + if(i < count) + continue; + + selected[count++] = id; + } + } +#endif + + selected[count] = 0; + + if(count == 0) { + curlx_free(selected); + failf(data, "mbedTLS: no supported cipher in list"); + return CURLE_SSL_CIPHER; + } + + /* mbedtls_ssl_conf_ciphersuites(): The ciphersuites array is not copied. + It must remain valid for the lifetime of the SSL configuration */ + backend->ciphersuites = selected; + mbedtls_ssl_conf_ciphersuites(&backend->config, backend->ciphersuites); + return CURLE_OK; +} + +static void mbed_dump_cert_info(struct Curl_easy *data, + const mbedtls_x509_crt *crt) +{ +#if !defined(CURLVERBOSE) || defined(MBEDTLS_X509_REMOVE_INFO) + (void)data, (void)crt; +#else + const size_t bufsize = 16384; + char *p, *buffer = curlx_malloc(bufsize); + + if(buffer && mbedtls_x509_crt_info(buffer, bufsize, " ", crt) > 0) { + infof(data, "Server certificate:"); + for(p = buffer; *p; p += *p != '\0') { + size_t s = strcspn(p, "\n"); + infof(data, "%.*s", (int)s, p); + p += s; + } + } + else + infof(data, "Unable to dump certificate information"); + + curlx_free(buffer); +#endif +} + +static void mbed_extract_certinfo(struct Curl_easy *data, + const mbedtls_x509_crt *crt) +{ + CURLcode result; + const mbedtls_x509_crt *cur; + int cert_count = 0; + int i; + + for(cur = crt; cur && cert_count <= MAX_ALLOWED_CERT_AMOUNT; cur = cur->next) + cert_count++; + + if(cert_count > MAX_ALLOWED_CERT_AMOUNT) { + infof(data, "More certificates than allowed (%d), skipping certinfo", + MAX_ALLOWED_CERT_AMOUNT); + return; + } + + result = Curl_ssl_init_certinfo(data, cert_count); + + for(i = 0, cur = crt; result == CURLE_OK && cur; ++i, cur = cur->next) { + const char *beg = (const char *)cur->raw.p; + const char *end = beg + cur->raw.len; + result = Curl_extract_certinfo(data, i, beg, end); + } +} + +static int mbed_verify_cb(void *ptr, mbedtls_x509_crt *crt, + int depth, uint32_t *flags) +{ + struct Curl_cfilter *cf = (struct Curl_cfilter *)ptr; + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + struct Curl_easy *data = CF_DATA_CURRENT(cf); + + if(depth == 0) { + if(data->set.verbose) + mbed_dump_cert_info(data, crt); + if(data->set.ssl.certinfo) + mbed_extract_certinfo(data, crt); + } + + if(!conn_config->verifypeer) + *flags = 0; + else if(!conn_config->verifyhost) + *flags &= ~MBEDTLS_X509_BADCERT_CN_MISMATCH; + + if(*flags) { +#ifndef MBEDTLS_X509_REMOVE_INFO + char buf[128]; + mbedtls_x509_crt_verify_info(buf, sizeof(buf), "", *flags); + failf(data, "mbedTLS: %s", buf); +#else + failf(data, "mbedTLS: certificate verification error 0x%08x", + (unsigned int)*flags); +#endif + } + + return 0; +} + +static CURLcode mbed_load_cacert(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct mbed_ssl_backend_data *backend = + (struct mbed_ssl_backend_data *)connssl->backend; + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + const struct curl_blob *ca_info_blob = conn_config->ca_info_blob; + const char * const ssl_cafile = + /* CURLOPT_CAINFO_BLOB overrides CURLOPT_CAINFO */ + (ca_info_blob ? NULL : conn_config->CAfile); + const bool verifypeer = conn_config->verifypeer; + const char * const ssl_capath = conn_config->CApath; +#ifdef MBEDTLS_PEM_PARSE_C + struct ssl_config_data *ssl_config = Curl_ssl_cf_get_config(cf, data); + const char * const ssl_cert_type = ssl_config->primary.cert_type; +#endif + int ret = -1; + char errorbuf[128]; + + mbedtls_x509_crt_init(&backend->cacert); + + if(ca_info_blob && verifypeer) { +#ifdef MBEDTLS_PEM_PARSE_C + /* if DER or a null-terminated PEM process using + mbedtls_x509_crt_parse(). */ + if((ssl_cert_type && curl_strequal(ssl_cert_type, "DER")) || + ((char *)(ca_info_blob->data))[ca_info_blob->len - 1] == '\0') { + ret = mbedtls_x509_crt_parse(&backend->cacert, ca_info_blob->data, + ca_info_blob->len); + } + else { /* they say it is PEM and it is not null-terminated */ + + /* Unfortunately, mbedtls_x509_crt_parse() requires the data to be + null-terminated if the data is PEM encoded (even when provided the + exact length). The function accepts PEM or DER formats, but we cannot + assume if the user passed in a PEM format cert that it is + null-terminated. */ + unsigned char *newblob = curlx_memdup0(ca_info_blob->data, + ca_info_blob->len); + if(!newblob) + return CURLE_OUT_OF_MEMORY; + + ret = mbedtls_x509_crt_parse(&backend->cacert, newblob, + ca_info_blob->len + 1); + curlx_free(newblob); + } +#else + /* DER encoded certs do not need to be null-terminated because it is a + binary format. Thus, if we are not compiling with PEM_PARSE we can avoid + the extra memory copies altogether. */ + ret = mbedtls_x509_crt_parse_der(&backend->cacert, ca_info_blob->data, + ca_info_blob->len); +#endif + + if(ret < 0) { + mbedtls_strerror(ret, errorbuf, sizeof(errorbuf)); + failf(data, "mbedTLS: error importing CA cert blob: (-0x%04X) %s", + (unsigned int)-ret, errorbuf); + return CURLE_SSL_CERTPROBLEM; + } + } + + if(ssl_cafile && verifypeer) { +#ifdef MBEDTLS_FS_IO + ret = mbedtls_x509_crt_parse_file(&backend->cacert, ssl_cafile); + + if(ret < 0) { + mbedtls_strerror(ret, errorbuf, sizeof(errorbuf)); + failf(data, "mbedTLS: error reading CA cert file %s: (-0x%04X) %s", + ssl_cafile, (unsigned int)-ret, errorbuf); + return CURLE_SSL_CACERT_BADFILE; + } +#else + failf(data, "mbedTLS: functions that use the file system not built in"); + return CURLE_NOT_BUILT_IN; +#endif + } + + if(ssl_capath) { +#ifdef MBEDTLS_FS_IO + ret = mbedtls_x509_crt_parse_path(&backend->cacert, ssl_capath); + + if(ret < 0) { + mbedtls_strerror(ret, errorbuf, sizeof(errorbuf)); + failf(data, "mbedTLS: error reading CA cert path %s: (-0x%04X) %s", + ssl_capath, (unsigned int)-ret, errorbuf); + + if(verifypeer) + return CURLE_SSL_CACERT_BADFILE; + } +#else + failf(data, "mbedTLS: functions that use the file system not built in"); + return CURLE_NOT_BUILT_IN; +#endif + } + + return CURLE_OK; +} + +static CURLcode mbed_load_clicert(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct mbed_ssl_backend_data *backend = + (struct mbed_ssl_backend_data *)connssl->backend; + struct ssl_config_data *ssl_config = Curl_ssl_cf_get_config(cf, data); + char * const ssl_cert = ssl_config->primary.clientcert; + const struct curl_blob *ssl_cert_blob = ssl_config->primary.cert_blob; +#ifdef MBEDTLS_PEM_PARSE_C + const char * const ssl_cert_type = ssl_config->primary.cert_type; +#endif + int ret = -1; + char errorbuf[128]; + + mbedtls_x509_crt_init(&backend->clicert); + + if(ssl_cert) { +#ifdef MBEDTLS_FS_IO + ret = mbedtls_x509_crt_parse_file(&backend->clicert, ssl_cert); + + if(ret) { + mbedtls_strerror(ret, errorbuf, sizeof(errorbuf)); + failf(data, "mbedTLS: error reading client cert file %s: (-0x%04X) %s", + ssl_cert, (unsigned int)-ret, errorbuf); + + return CURLE_SSL_CERTPROBLEM; + } +#else + failf(data, "mbedTLS: functions that use the file system not built in"); + return CURLE_NOT_BUILT_IN; +#endif + } + + if(ssl_cert_blob) { +#ifdef MBEDTLS_PEM_PARSE_C + /* if DER or a null-terminated PEM process using + mbedtls_x509_crt_parse(). */ + if((ssl_cert_type && curl_strequal(ssl_cert_type, "DER")) || + ((char *)(ssl_cert_blob->data))[ssl_cert_blob->len - 1] == '\0') { + + ret = mbedtls_x509_crt_parse(&backend->clicert, + ssl_cert_blob->data, + ssl_cert_blob->len); + } + else { /* they say it is PEM and it is not null-terminated */ + + /* Unfortunately, mbedtls_x509_crt_parse() requires the data to be + null-terminated if the data is PEM encoded (even when provided the + exact length). The function accepts PEM or DER formats, but we cannot + assume if the user passed in a PEM format cert that it is + null-terminated. */ + unsigned char *newblob = curlx_memdup0(ssl_cert_blob->data, + ssl_cert_blob->len); + if(!newblob) + return CURLE_OUT_OF_MEMORY; + ret = mbedtls_x509_crt_parse(&backend->clicert, newblob, + ssl_cert_blob->len + 1); + curlx_free(newblob); + } +#else + /* DER encoded certs do not need to be null-terminated because it is a + binary format. Thus, if we are not compiling with PEM_PARSE we can avoid + the extra memory copies altogether. */ + ret = mbedtls_x509_crt_parse_der(&backend->clicert, ssl_cert_blob->data, + ssl_cert_blob->len); +#endif + + if(ret) { + mbedtls_strerror(ret, errorbuf, sizeof(errorbuf)); + failf(data, "mbedTLS: error reading client cert blob: (-0x%04X) %s", + (unsigned int)-ret, errorbuf); + return CURLE_SSL_CERTPROBLEM; + } + } + + return CURLE_OK; +} + +static CURLcode mbed_load_privkey(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct mbed_ssl_backend_data *backend = + (struct mbed_ssl_backend_data *)connssl->backend; + struct ssl_config_data *ssl_config = Curl_ssl_cf_get_config(cf, data); + int ret = -1; + char errorbuf[128]; + + mbedtls_pk_init(&backend->pk); + + if(ssl_config->primary.key || ssl_config->primary.key_blob) { + if(ssl_config->primary.key) { +#ifdef MBEDTLS_FS_IO +#if MBEDTLS_VERSION_NUMBER >= 0x04000000 + ret = mbedtls_pk_parse_keyfile(&backend->pk, ssl_config->primary.key, + ssl_config->primary.key_passwd); + if(ret == 0 && + !(mbedtls_pk_can_do_psa(&backend->pk, + PSA_ALG_RSA_PKCS1V15_SIGN(PSA_ALG_ANY_HASH), + PSA_KEY_USAGE_SIGN_HASH) || + mbedtls_pk_can_do_psa(&backend->pk, + MBEDTLS_PK_ALG_ECDSA(PSA_ALG_ANY_HASH), + PSA_KEY_USAGE_SIGN_HASH))) + ret = MBEDTLS_ERR_PK_TYPE_MISMATCH; +#else + ret = mbedtls_pk_parse_keyfile(&backend->pk, ssl_config->primary.key, + ssl_config->primary.key_passwd, + mbedtls_ctr_drbg_random, + &rng.drbg); + if(ret == 0 && !(mbedtls_pk_can_do(&backend->pk, MBEDTLS_PK_RSA) || + mbedtls_pk_can_do(&backend->pk, MBEDTLS_PK_ECKEY))) + ret = MBEDTLS_ERR_PK_TYPE_MISMATCH; +#endif + + if(ret) { + mbedtls_strerror(ret, errorbuf, sizeof(errorbuf)); + failf(data, "mbedTLS: error reading private key %s: (-0x%04X) %s", + ssl_config->primary.key, (unsigned int)-ret, errorbuf); + return CURLE_SSL_CERTPROBLEM; + } +#else + failf(data, "mbedTLS: functions that use the file system not built in"); + return CURLE_NOT_BUILT_IN; +#endif + } + else { + const struct curl_blob *ssl_key_blob = ssl_config->primary.key_blob; + const char *passwd = ssl_config->primary.key_passwd; + /* Unfortunately, mbedtls_pk_parse_key() requires the data to be + null-terminated if the data is PEM encoded (even when provided the + exact length). */ + unsigned char *newblob = curlx_memdup0(ssl_key_blob->data, + ssl_key_blob->len); + if(!newblob) + return CURLE_OUT_OF_MEMORY; + +#if MBEDTLS_VERSION_NUMBER >= 0x04000000 + ret = mbedtls_pk_parse_key(&backend->pk, newblob, ssl_key_blob->len, + (const unsigned char *)passwd, + passwd ? strlen(passwd) : 0); + if(ret == 0 && + !(mbedtls_pk_can_do_psa(&backend->pk, + PSA_ALG_RSA_PKCS1V15_SIGN(PSA_ALG_ANY_HASH), + PSA_KEY_USAGE_SIGN_HASH) || + mbedtls_pk_can_do_psa(&backend->pk, + MBEDTLS_PK_ALG_ECDSA(PSA_ALG_ANY_HASH), + PSA_KEY_USAGE_SIGN_HASH))) + ret = MBEDTLS_ERR_PK_TYPE_MISMATCH; +#else + ret = mbedtls_pk_parse_key(&backend->pk, newblob, ssl_key_blob->len, + (const unsigned char *)passwd, + passwd ? strlen(passwd) : 0, + mbedtls_ctr_drbg_random, + &rng.drbg); + if(ret == 0 && !(mbedtls_pk_can_do(&backend->pk, MBEDTLS_PK_RSA) || + mbedtls_pk_can_do(&backend->pk, MBEDTLS_PK_ECKEY))) + ret = MBEDTLS_ERR_PK_TYPE_MISMATCH; +#endif + curlx_free(newblob); + + if(ret) { + mbedtls_strerror(ret, errorbuf, sizeof(errorbuf)); + failf(data, "mbedTLS: error parsing private key: (-0x%04X) %s", + (unsigned int)-ret, errorbuf); + return CURLE_SSL_CERTPROBLEM; + } + } + } + + return CURLE_OK; +} + +static CURLcode mbed_load_crl(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct mbed_ssl_backend_data *backend = + (struct mbed_ssl_backend_data *)connssl->backend; + struct ssl_config_data *ssl_config = Curl_ssl_cf_get_config(cf, data); + const char * const ssl_crlfile = ssl_config->primary.CRLfile; + +#ifdef MBEDTLS_X509_CRL_PARSE_C + mbedtls_x509_crl_init(&backend->crl); + + if(ssl_crlfile) { + char errorbuf[128]; +#ifdef MBEDTLS_FS_IO + int ret = mbedtls_x509_crl_parse_file(&backend->crl, ssl_crlfile); + + if(ret) { + mbedtls_strerror(ret, errorbuf, sizeof(errorbuf)); + failf(data, "mbedTLS: error reading CRL file %s: (-0x%04X) %s", + ssl_crlfile, (unsigned int)-ret, errorbuf); + + return CURLE_SSL_CRL_BADFILE; + } +#else + (void)errorbuf; + failf(data, "mbedTLS: functions that use the file system not built in"); + return CURLE_NOT_BUILT_IN; +#endif + } +#else + (void)backend; + if(ssl_crlfile) { + failf(data, "mbedTLS: CRL support not built in"); + return CURLE_NOT_BUILT_IN; + } +#endif + + return CURLE_OK; +} + +static CURLcode mbed_configure_ssl(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct mbed_ssl_backend_data *backend = + (struct mbed_ssl_backend_data *)connssl->backend; + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + struct ssl_config_data *ssl_config = Curl_ssl_cf_get_config(cf, data); + int ret; + CURLcode result; + char errorbuf[128]; + + infof(data, "mbedTLS: Connecting to %s:%d", + connssl->peer.origin->hostname, connssl->peer.origin->port); + + mbedtls_ssl_config_init(&backend->config); + ret = mbedtls_ssl_config_defaults(&backend->config, + MBEDTLS_SSL_IS_CLIENT, + MBEDTLS_SSL_TRANSPORT_STREAM, + MBEDTLS_SSL_PRESET_DEFAULT); + if(ret) { + failf(data, "mbedTLS: ssl_config failed"); + return CURLE_SSL_CONNECT_ERROR; + } + +#ifdef MBEDTLS_DEBUG + /* In order to make that work in mbedtls MBEDTLS_DEBUG_C must be defined. */ + mbedtls_ssl_conf_dbg(&backend->config, mbed_debug, data); + /* - 0 No debug + * - 1 Error + * - 2 State change + * - 3 Informational + * - 4 Verbose + */ + mbedtls_debug_set_threshold(4); +#endif + +#if defined(MBEDTLS_SSL_SESSION_TICKETS) && \ + defined(MBEDTLS_SSL_PROTO_TLS1_3) && \ + MBEDTLS_VERSION_NUMBER >= 0x03060100 && \ + MBEDTLS_VERSION_NUMBER < 0x04000000 + /* New in mbedTLS 3.6.1, need to enable, default is now disabled. 4.0.0 + enabled it by default for TLSv1.3. */ + mbedtls_ssl_conf_tls13_enable_signal_new_session_tickets( + &backend->config, MBEDTLS_SSL_TLS1_3_SIGNAL_NEW_SESSION_TICKETS_ENABLED); +#endif + + /* Always let mbedTLS verify certificates, if verifypeer or verifyhost are + * disabled we clear the corresponding error flags in the verify callback + * function. That is also where we log verification errors. */ + mbedtls_ssl_conf_verify(&backend->config, mbed_verify_cb, cf); + mbedtls_ssl_conf_authmode(&backend->config, MBEDTLS_SSL_VERIFY_REQUIRED); + + mbedtls_ssl_init(&backend->ssl); + backend->initialized = TRUE; + + /* use the default secure profile baked into mbedTLS */ + mbedtls_ssl_conf_cert_profile(&backend->config, + &mbedtls_x509_crt_profile_next); + + result = mbed_set_ssl_version_min_max(data, backend, conn_config); + if(result) + return result; + +#if MBEDTLS_VERSION_NUMBER < 0x04000000 + mbedtls_ssl_conf_rng(&backend->config, mbedtls_ctr_drbg_random, + &rng.drbg); +#endif + + ret = mbedtls_ssl_setup(&backend->ssl, + &backend->config); + if(ret) { + mbedtls_strerror(ret, errorbuf, sizeof(errorbuf)); + failf(data, "mbedTLS: ssl_setup failed: " + "(-0x%04X) %s", (unsigned int)-ret, errorbuf); + return CURLE_SSL_CONNECT_ERROR; + } + + mbedtls_ssl_set_bio(&backend->ssl, cf, + mbedtls_bio_cf_write, + mbedtls_bio_cf_read, + NULL /* rev_timeout() */); + +#ifndef MBEDTLS_SSL_PROTO_TLS1_3 + if(conn_config->cipher_list) { + result = mbed_set_selected_ciphers(data, backend, + conn_config->cipher_list, NULL); +#else + if(conn_config->cipher_list || conn_config->cipher_list13) { + result = mbed_set_selected_ciphers(data, backend, + conn_config->cipher_list, + conn_config->cipher_list13); +#endif + if(result) { + failf(data, "mbedTLS: failed to set cipher suites"); + return result; + } + } + else { + mbedtls_ssl_conf_ciphersuites(&backend->config, + mbedtls_ssl_list_ciphersuites()); + } + +#ifdef MBEDTLS_SSL_RENEGOTIATION + mbedtls_ssl_conf_renegotiation(&backend->config, + MBEDTLS_SSL_RENEGOTIATION_ENABLED); +#endif + +#ifdef MBEDTLS_SSL_SESSION_TICKETS + mbedtls_ssl_conf_session_tickets(&backend->config, + MBEDTLS_SSL_SESSION_TICKETS_DISABLED); +#endif + + /* Check if there is a cached ID we can/should use here! */ + if(Curl_ssl_scache_use(cf, data)) { + struct Curl_ssl_session *sc_session = NULL; + CURLcode sresult = Curl_ssl_scache_take(cf, data, connssl->peer.scache_key, + &sc_session); + if(!sresult && sc_session && sc_session->sdata && sc_session->sdata_len) { + mbedtls_ssl_session session; + + mbedtls_ssl_session_init(&session); + ret = mbedtls_ssl_session_load(&session, sc_session->sdata, + sc_session->sdata_len); + if(ret) { + failf(data, "SSL session error loading: -0x%x", (unsigned int)-ret); + } + else { + ret = mbedtls_ssl_set_session(&backend->ssl, &session); + if(ret) + failf(data, "SSL session error setting: -0x%x", (unsigned int)-ret); + else + infof(data, "SSL reusing session ID"); + } + mbedtls_ssl_session_free(&session); + } + Curl_ssl_scache_return(cf, data, connssl->peer.scache_key, + sc_session); + } + + mbedtls_ssl_conf_ca_chain(&backend->config, &backend->cacert, +#ifdef MBEDTLS_X509_CRL_PARSE_C + &backend->crl +#else + NULL +#endif + ); + + if(ssl_config->primary.key || ssl_config->primary.key_blob) { + mbedtls_ssl_conf_own_cert(&backend->config, &backend->clicert, + &backend->pk); + } + + if(mbedtls_ssl_set_hostname(&backend->ssl, connssl->peer.sni ? + connssl->peer.sni : + connssl->peer.origin->hostname)) { + /* mbedtls_ssl_set_hostname() sets the name to use in CN/SAN checks and + the name to set in the SNI extension. Thus even if curl connects to + a host specified as an IP address, this function must be used. */ + failf(data, "Failed to set SNI"); + return CURLE_SSL_CONNECT_ERROR; + } + +#ifdef HAS_ALPN_MBEDTLS + if(connssl->alpn) { + struct alpn_proto_buf proto; + size_t i; + + for(i = 0; i < connssl->alpn->count; ++i) { + backend->protocols[i] = connssl->alpn->entries[i]; + } + /* this function does not clone the protocols array, which is why we need + to keep it around */ + if(mbedtls_ssl_conf_alpn_protocols(&backend->config, + &backend->protocols[0])) { + failf(data, "Failed setting ALPN protocols"); + return CURLE_SSL_CONNECT_ERROR; + } + Curl_alpn_to_proto_str(&proto, connssl->alpn); + infof(data, VTLS_INFOF_ALPN_OFFER_1STR, proto.data); + } +#endif + + /* give application a chance to interfere with mbedTLS set up. */ + if(data->set.ssl.fsslctx) { + result = (*data->set.ssl.fsslctx)(data, &backend->config, + data->set.ssl.fsslctxp); + if(result) + failf(data, "error signaled by SSL ctx callback"); + } + + return result; +} + +static CURLcode mbed_connect_step1(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + CURLcode result; + + if((conn_config->version == CURL_SSLVERSION_SSLv2) || + (conn_config->version == CURL_SSLVERSION_SSLv3)) { + failf(data, "Not supported SSL version"); + return CURLE_NOT_BUILT_IN; + } + + result = mbed_load_cacert(cf, data); + if(!result) + result = mbed_load_clicert(cf, data); + if(!result) + result = mbed_load_privkey(cf, data); + if(!result) + result = mbed_load_crl(cf, data); + if(!result) + result = mbed_configure_ssl(cf, data); + if(result) + return result; + + connssl->connecting_state = ssl_connect_2; + return CURLE_OK; +} + +#if defined(MBEDTLS_PK_WRITE_C) && defined(MBEDTLS_SSL_KEEP_PEER_CERTIFICATE) +#define HAVE_PINNED_PUBKEY +#endif + +static CURLcode mbed_connect_step2(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ +#if defined(HAVE_PINNED_PUBKEY) || defined(HAS_ALPN_MBEDTLS) + CURLcode result; +#endif + int ret; + struct ssl_connect_data *connssl = cf->ctx; + struct mbed_ssl_backend_data *backend = + (struct mbed_ssl_backend_data *)connssl->backend; +#ifdef HAVE_PINNED_PUBKEY +#ifndef CURL_DISABLE_PROXY + const char * const pinnedpubkey = Curl_ssl_cf_is_proxy(cf) ? + data->set.str[STRING_SSL_PINNEDPUBLICKEY_PROXY] : + data->set.str[STRING_SSL_PINNEDPUBLICKEY]; +#else + const char * const pinnedpubkey = data->set.str[STRING_SSL_PINNEDPUBLICKEY]; +#endif +#endif + + DEBUGASSERT(backend); + + ret = mbedtls_ssl_handshake(&backend->ssl); + + if(ret == MBEDTLS_ERR_SSL_WANT_READ) { + connssl->io_need = CURL_SSL_IO_NEED_RECV; + return CURLE_OK; + } + else if(ret == MBEDTLS_ERR_SSL_WANT_WRITE) { + connssl->io_need = CURL_SSL_IO_NEED_SEND; + return CURLE_OK; + } + else if(ret == MBEDTLS_ERR_X509_CERT_VERIFY_FAILED) { + failf(data, "peer certificate could not be verified"); + return CURLE_PEER_FAILED_VERIFICATION; + } + else if(ret) { + char errorbuf[128]; + CURL_TRC_CF(data, cf, "TLS version %04X", + mbedtls_ssl_get_version_number(&backend->ssl)); + mbedtls_strerror(ret, errorbuf, sizeof(errorbuf)); + failf(data, "ssl_handshake returned: (-0x%04X) %s", + (unsigned int)-ret, errorbuf); + return CURLE_SSL_CONNECT_ERROR; + } + + { + char cipher_str[64]; + uint16_t cipher_id; + cipher_id = + (uint16_t)mbedtls_ssl_get_ciphersuite_id_from_ssl(&backend->ssl); + mbed_cipher_suite_get_str(cipher_id, cipher_str, sizeof(cipher_str), TRUE); + infof(data, "mbedTLS: %s Handshake complete, cipher is %s", + mbedtls_ssl_get_version(&backend->ssl), cipher_str); + } + +#ifdef HAVE_PINNED_PUBKEY + if(pinnedpubkey) { + int size; + const mbedtls_x509_crt *peercert; + mbedtls_x509_crt *p = NULL; + unsigned char *pubkey = NULL; + + peercert = mbedtls_ssl_get_peer_cert(&backend->ssl); + if(!peercert || !peercert->raw.p || !peercert->raw.len) { + failf(data, "Failed due to missing peer certificate"); + return CURLE_SSL_PINNEDPUBKEYNOTMATCH; + } + + p = curlx_calloc(1, sizeof(*p)); + + if(!p) + return CURLE_OUT_OF_MEMORY; + + pubkey = curlx_malloc(PUB_DER_MAX_BYTES); + + if(!pubkey) { + result = CURLE_OUT_OF_MEMORY; + goto pinnedpubkey_error; + } + + mbedtls_x509_crt_init(p); + + /* Make a copy of our const peercert because mbedtls_pk_write_pubkey_der + needs a non-const key, for now. + https://github.com/Mbed-TLS/mbedtls/issues/396 */ + if(mbedtls_x509_crt_parse_der(p, peercert->raw.p, peercert->raw.len)) { + failf(data, "Failed copying peer certificate"); + result = CURLE_SSL_PINNEDPUBKEYNOTMATCH; + goto pinnedpubkey_error; + } + + size = mbedtls_pk_write_pubkey_der(&p->pk, pubkey, PUB_DER_MAX_BYTES); + + if(size <= 0) { + failf(data, "Failed copying public key from peer certificate"); + result = CURLE_SSL_PINNEDPUBKEYNOTMATCH; + goto pinnedpubkey_error; + } + + /* mbedtls_pk_write_pubkey_der writes data at the end of the buffer. */ + result = Curl_pin_peer_pubkey(data, + pinnedpubkey, + &pubkey[PUB_DER_MAX_BYTES - size], size); +pinnedpubkey_error: + mbedtls_x509_crt_free(p); + curlx_free(p); + curlx_free(pubkey); + if(result) + return result; + } +#endif + +#ifdef HAS_ALPN_MBEDTLS + if(connssl->alpn) { + const char *proto = mbedtls_ssl_get_alpn_protocol(&backend->ssl); + + result = Curl_alpn_set_negotiated(cf, data, connssl, + (const unsigned char *)proto, + proto ? strlen(proto) : 0); + if(result) + return result; + } +#endif + + connssl->connecting_state = ssl_connect_3; + infof(data, "SSL connected"); + + return CURLE_OK; +} + +static CURLcode mbed_new_session(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct mbed_ssl_backend_data *backend = + (struct mbed_ssl_backend_data *)connssl->backend; + mbedtls_ssl_session session; + bool msession_alloced = FALSE; + struct Curl_ssl_session *sc_session = NULL; + unsigned char *sdata = NULL; + size_t slen = 0; + int ietf_tls_id; + CURLcode result = CURLE_OK; + int ret; + + DEBUGASSERT(backend); + if(!Curl_ssl_scache_use(cf, data)) + return CURLE_OK; + + mbedtls_ssl_session_init(&session); + ret = mbedtls_ssl_get_session(&backend->ssl, &session); + msession_alloced = (ret != MBEDTLS_ERR_SSL_ALLOC_FAILED); + if(ret) { + failf(data, "mbedtls_ssl_get_session returned -0x%x", (unsigned int)-ret); + result = CURLE_SSL_CONNECT_ERROR; + goto out; + } + + mbedtls_ssl_session_save(&session, NULL, 0, &slen); + if(!slen) { + failf(data, "failed to serialize session: length is 0"); + goto out; + } + + sdata = curlx_malloc(slen); + if(!sdata) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + ret = mbedtls_ssl_session_save(&session, sdata, slen, &slen); + if(ret) { + failf(data, "failed to serialize session: -0x%x", (unsigned int)-ret); + goto out; + } + + ietf_tls_id = mbedtls_ssl_get_version_number(&backend->ssl); + result = Curl_ssl_session_create(sdata, slen, + ietf_tls_id, + connssl->negotiated.alpn, 0, 0, + &sc_session); + sdata = NULL; /* call took ownership */ + if(!result) + result = Curl_ssl_scache_put(cf, data, connssl->peer.scache_key, + sc_session); + +out: + if(msession_alloced) + mbedtls_ssl_session_free(&session); + curlx_free(sdata); + return result; +} + +static CURLcode mbed_send(struct Curl_cfilter *cf, struct Curl_easy *data, + const void *mem, size_t len, size_t *pnwritten) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct mbed_ssl_backend_data *backend = + (struct mbed_ssl_backend_data *)connssl->backend; + CURLcode result = CURLE_OK; + int nwritten; + + DEBUGASSERT(backend); + *pnwritten = 0; + connssl->io_need = CURL_SSL_IO_NEED_NONE; + /* mbedTLS is picky when a mbedtls_ssl_write() was previously blocked. + * It requires to be called with the same amount of bytes again, or it + * loses bytes, e.g. reporting all was sent but they were not. + * Remember the blocked length and use that when set. */ + if(backend->send_blocked) { + DEBUGASSERT(backend->send_blocked_len <= len); + CURL_TRC_CF(data, cf, "mbedtls_ssl_write(len=%zu) -> previously blocked " + "on %zu bytes", len, backend->send_blocked_len); + len = backend->send_blocked_len; + } + + nwritten = mbedtls_ssl_write(&backend->ssl, (const unsigned char *)mem, len); + + if(nwritten >= 0) { + *pnwritten = (size_t)nwritten; + backend->send_blocked = FALSE; + } + else { + CURL_TRC_CF(data, cf, "mbedtls_ssl_write(len=%zu) -> -0x%04X", + len, (unsigned int)-nwritten); + switch(nwritten) { +#ifdef MBEDTLS_SSL_PROTO_TLS1_3 + case MBEDTLS_ERR_SSL_RECEIVED_NEW_SESSION_TICKET: +#endif + case MBEDTLS_ERR_SSL_WANT_READ: + connssl->io_need = CURL_SSL_IO_NEED_RECV; + result = CURLE_AGAIN; + break; + case MBEDTLS_ERR_SSL_WANT_WRITE: + connssl->io_need = CURL_SSL_IO_NEED_SEND; + result = CURLE_AGAIN; + break; + default: + result = CURLE_SEND_ERROR; + break; + } + if((result == CURLE_AGAIN) && !backend->send_blocked) { + backend->send_blocked = TRUE; + backend->send_blocked_len = len; + } + } + + CURL_TRC_CF(data, cf, "mbedtls_ssl_write(len=%zu) -> %d, %zu", + len, (int)result, *pnwritten); + return result; +} + +static CURLcode mbedtls_shutdown(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool send_shutdown, bool *done) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct mbed_ssl_backend_data *backend = + (struct mbed_ssl_backend_data *)connssl->backend; + unsigned char buf[1024]; + CURLcode result = CURLE_OK; + int ret = 0; + size_t i; + + DEBUGASSERT(backend); + + if(!backend->initialized || cf->shutdown) { + *done = TRUE; + return CURLE_OK; + } + + connssl->io_need = CURL_SSL_IO_NEED_NONE; + *done = FALSE; + + if(!backend->sent_shutdown) { + /* do this only once */ + backend->sent_shutdown = TRUE; + if(send_shutdown) { + ret = mbedtls_ssl_close_notify(&backend->ssl); + switch(ret) { + case 0: /* we sent it, receive from the server */ + break; + case MBEDTLS_ERR_SSL_PEER_CLOSE_NOTIFY: /* server also closed */ + *done = TRUE; + goto out; + case MBEDTLS_ERR_SSL_WANT_READ: + connssl->io_need = CURL_SSL_IO_NEED_RECV; + goto out; + case MBEDTLS_ERR_SSL_WANT_WRITE: + connssl->io_need = CURL_SSL_IO_NEED_SEND; + goto out; + default: + CURL_TRC_CF(data, cf, "mbedtls_shutdown error -0x%04X", + (unsigned int)-ret); + result = CURLE_RECV_ERROR; + goto out; + } + } + } + + /* SSL should now have started the shutdown from our side. Since it + * was not complete, we are lacking the close notify from the server. */ + for(i = 0; i < 10; ++i) { + ret = mbedtls_ssl_read(&backend->ssl, buf, sizeof(buf)); + /* This seems to be a bug in mbedTLS TLSv1.3 where it reports + * WANT_READ, but has not encountered an EAGAIN. */ + if(ret == MBEDTLS_ERR_SSL_WANT_READ) + ret = mbedtls_ssl_read(&backend->ssl, buf, sizeof(buf)); +#ifdef MBEDTLS_SSL_PROTO_TLS1_3 + if(ret == MBEDTLS_ERR_SSL_RECEIVED_NEW_SESSION_TICKET) + continue; +#endif + if(ret <= 0) + break; + } + + if(ret > 0) { + /* still data coming in? */ + CURL_TRC_CF(data, cf, "mbedtls_shutdown, still getting data"); + } + else if(ret == 0 || (ret == MBEDTLS_ERR_SSL_PEER_CLOSE_NOTIFY)) { + /* We got the close notify alert and are done. */ + CURL_TRC_CF(data, cf, "mbedtls_shutdown done"); + *done = TRUE; + } + else if(ret == MBEDTLS_ERR_SSL_WANT_READ) { + CURL_TRC_CF(data, cf, "mbedtls_shutdown, need RECV"); + connssl->io_need = CURL_SSL_IO_NEED_RECV; + } + else if(ret == MBEDTLS_ERR_SSL_WANT_WRITE) { + CURL_TRC_CF(data, cf, "mbedtls_shutdown, need SEND"); + connssl->io_need = CURL_SSL_IO_NEED_SEND; + } + else { + CURL_TRC_CF(data, cf, "mbedtls_shutdown error -0x%04X", + (unsigned int)-ret); + result = CURLE_RECV_ERROR; + } + +out: + cf->shutdown = (result || *done); + return result; +} + +static void mbedtls_close(struct Curl_cfilter *cf, struct Curl_easy *data) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct mbed_ssl_backend_data *backend = + (struct mbed_ssl_backend_data *)connssl->backend; + + (void)data; + DEBUGASSERT(backend); + mbedtls_pk_free(&backend->pk); + mbedtls_x509_crt_free(&backend->clicert); + mbedtls_x509_crt_free(&backend->cacert); +#ifdef MBEDTLS_X509_CRL_PARSE_C + mbedtls_x509_crl_free(&backend->crl); +#endif + curlx_safefree(backend->ciphersuites); + mbedtls_ssl_config_free(&backend->config); + if(backend->initialized) { + mbedtls_ssl_free(&backend->ssl); + backend->initialized = FALSE; + } +} + +static CURLcode mbed_recv(struct Curl_cfilter *cf, struct Curl_easy *data, + char *buf, size_t buffersize, size_t *pnread) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct mbed_ssl_backend_data *backend = + (struct mbed_ssl_backend_data *)connssl->backend; + CURLcode result = CURLE_OK; + int nread; + + DEBUGASSERT(backend); + *pnread = 0; + connssl->io_need = CURL_SSL_IO_NEED_NONE; + + nread = mbedtls_ssl_read(&backend->ssl, (unsigned char *)buf, buffersize); + if(nread > 0) + *pnread = (size_t)nread; + else { + char errorbuf[128]; + CURL_TRC_CF(data, cf, "mbedtls_ssl_read(len=%zu) -> -0x%04X", + buffersize, (unsigned int)-nread); + switch(nread) { +#ifdef MBEDTLS_SSL_SESSION_TICKETS + case MBEDTLS_ERR_SSL_RECEIVED_NEW_SESSION_TICKET: + mbed_new_session(cf, data); + FALLTHROUGH(); +#endif + case MBEDTLS_ERR_SSL_WANT_READ: + connssl->io_need = CURL_SSL_IO_NEED_RECV; + result = CURLE_AGAIN; + break; + case MBEDTLS_ERR_SSL_WANT_WRITE: + connssl->io_need = CURL_SSL_IO_NEED_SEND; + result = CURLE_AGAIN; + break; + case MBEDTLS_ERR_SSL_PEER_CLOSE_NOTIFY: + result = CURLE_OK; + break; + default: + mbedtls_strerror(nread, errorbuf, sizeof(errorbuf)); + failf(data, "ssl_read returned: (-0x%04X) %s", (unsigned int)-nread, + errorbuf); + result = CURLE_RECV_ERROR; + break; + } + } + return result; +} + +static size_t mbedtls_version(char *buffer, size_t size) +{ +#ifdef MBEDTLS_VERSION_C + /* if mbedtls_version_get_number() is available it is better */ + unsigned int version = mbedtls_version_get_number(); + return curl_msnprintf(buffer, size, "mbedTLS/%u.%u.%u", version >> 24, + (version >> 16) & 0xff, (version >> 8) & 0xff); +#else + return curl_msnprintf(buffer, size, "mbedTLS/%s", MBEDTLS_VERSION_STRING); +#endif +} + +/* 'data' might be NULL */ +static CURLcode mbedtls_random(struct Curl_easy *data, + unsigned char *entropy, size_t length) +{ + psa_status_t status; + (void)data; + + status = psa_generate_random(entropy, length); + + return status == PSA_SUCCESS ? CURLE_OK : CURLE_FAILED_INIT; +} + +static CURLcode mbedtls_connect(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ + CURLcode result; + struct ssl_connect_data *connssl = cf->ctx; + + /* check if the connection has already been established */ + if(ssl_connection_complete == connssl->state) { + *done = TRUE; + return CURLE_OK; + } + + *done = FALSE; + connssl->io_need = CURL_SSL_IO_NEED_NONE; + + if(ssl_connect_1 == connssl->connecting_state) { + result = mbed_connect_step1(cf, data); + if(result) + return result; + } + + if(ssl_connect_2 == connssl->connecting_state) { + result = mbed_connect_step2(cf, data); + if(result) + return result; + } + + if(ssl_connect_3 == connssl->connecting_state) { + /* For tls1.3 we get notified about new sessions */ + struct ssl_connect_data *ctx = cf->ctx; + struct mbed_ssl_backend_data *backend = + (struct mbed_ssl_backend_data *)ctx->backend; + + if(mbedtls_ssl_get_version_number(&backend->ssl) <= + MBEDTLS_SSL_VERSION_TLS1_2) { + result = mbed_new_session(cf, data); + if(result) + return result; + } + connssl->connecting_state = ssl_connect_done; + } + + if(ssl_connect_done == connssl->connecting_state) { + connssl->state = ssl_connection_complete; + *done = TRUE; + } + + return CURLE_OK; +} + +/* + * return 0 error initializing SSL + * return 1 SSL initialized successfully + */ +static int mbedtls_init(void) +{ +#if MBEDTLS_VERSION_NUMBER < 0x04000000 + int ret = 0; +#endif + psa_status_t status; + status = psa_crypto_init(); + + if(status != PSA_SUCCESS) + return 0; + +#if MBEDTLS_VERSION_NUMBER < 0x04000000 + mbedtls_ctr_drbg_init(&rng.drbg); + mbedtls_entropy_init(&rng.entropy); + + ret = mbedtls_ctr_drbg_seed(&rng.drbg, mbedtls_entropy_func, &rng.entropy, + NULL, 0); + + if(ret) + /* mbedtls_ctr_drbg_seed returned error */ + return 0; + + /* To prevent an adversary from reading your random data, + you can enable prediction resistance. + + Entropy is gathered before each mbedtls_ctr_drbg_random() call. + Only use this if you have ample supply of good entropy.*/ + mbedtls_ctr_drbg_set_prediction_resistance(&rng.drbg, + MBEDTLS_CTR_DRBG_PR_ON); +#endif + return 1; +} + +static void mbedtls_cleanup(void) +{ + mbedtls_psa_crypto_free(); + +#if MBEDTLS_VERSION_NUMBER < 0x04000000 + mbedtls_ctr_drbg_free(&rng.drbg); + mbedtls_entropy_free(&rng.entropy); +#endif +} + +static bool mbedtls_data_pending(struct Curl_cfilter *cf, + const struct Curl_easy *data) +{ + struct ssl_connect_data *ctx = cf->ctx; + struct mbed_ssl_backend_data *backend; + + (void)data; + DEBUGASSERT(ctx && ctx->backend); + backend = (struct mbed_ssl_backend_data *)ctx->backend; + return mbedtls_ssl_get_bytes_avail(&backend->ssl) != 0; +} + +static CURLcode mbedtls_sha256sum(const unsigned char *input, + size_t inputlen, + unsigned char *sha256sum, + size_t sha256len) +{ +#if defined(PSA_WANT_ALG_SHA_256) && PSA_WANT_ALG_SHA_256 + psa_status_t status; + size_t sha256len_actual; + status = psa_hash_compute(PSA_ALG_SHA_256, input, inputlen, + sha256sum, sha256len, + &sha256len_actual); + if(status != PSA_SUCCESS) + return CURLE_BAD_FUNCTION_ARGUMENT; + return CURLE_OK; +#else + (void)sha256len; + return Curl_sha256it(sha256sum, input, inputlen); +#endif +} + +static void *mbedtls_get_internals(struct ssl_connect_data *connssl, + CURLINFO info) +{ + struct mbed_ssl_backend_data *backend = + (struct mbed_ssl_backend_data *)connssl->backend; + (void)info; + DEBUGASSERT(backend); + return &backend->ssl; +} + +const struct Curl_ssl Curl_ssl_mbedtls = { + { CURLSSLBACKEND_MBEDTLS, "mbedtls" }, /* info */ + + SSLSUPP_CA_PATH | + SSLSUPP_CAINFO_BLOB | + SSLSUPP_CERTINFO | +#ifdef HAVE_PINNED_PUBKEY + SSLSUPP_PINNEDPUBKEY | +#endif + SSLSUPP_SSL_CTX | +#ifdef MBEDTLS_SSL_PROTO_TLS1_3 /* requires mbedTLS 3.6.0+ */ + SSLSUPP_TLS13_CIPHERSUITES | +#endif + SSLSUPP_HTTPS_PROXY | + SSLSUPP_CIPHER_LIST | +#ifdef MBEDTLS_X509_CRL_PARSE_C + SSLSUPP_CRLFILE | +#endif + 0, + + sizeof(struct mbed_ssl_backend_data), + + mbedtls_init, /* init */ + mbedtls_cleanup, /* cleanup */ + mbedtls_version, /* version */ + mbedtls_shutdown, /* shutdown */ + mbedtls_data_pending, /* data_pending */ + mbedtls_random, /* random */ + NULL, /* cert_status_request */ + mbedtls_connect, /* connect */ + Curl_ssl_adjust_pollset, /* adjust_pollset */ + mbedtls_get_internals, /* get_internals */ + mbedtls_close, /* close_one */ + NULL, /* close_all */ + NULL, /* set_engine */ + NULL, /* set_engine_default */ + NULL, /* engines_list */ + mbedtls_sha256sum, /* sha256sum */ + mbed_recv, /* recv decrypted data */ + mbed_send, /* send data to encrypt */ + NULL, /* get_channel_binding */ +}; + +#endif /* USE_MBEDTLS */ diff --git a/3rdparty/curl-8.21.0/lib/vtls/mbedtls.h b/3rdparty/curl-8.21.0/lib/vtls/mbedtls.h new file mode 100644 index 0000000000..d8a0a06eb6 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vtls/mbedtls.h @@ -0,0 +1,34 @@ +#ifndef HEADER_CURL_MBEDTLS_H +#define HEADER_CURL_MBEDTLS_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * Copyright (C) Hoi-Ho Chan, + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_MBEDTLS + +extern const struct Curl_ssl Curl_ssl_mbedtls; + +#endif /* USE_MBEDTLS */ +#endif /* HEADER_CURL_MBEDTLS_H */ diff --git a/3rdparty/curl-8.21.0/lib/vtls/openssl.c b/3rdparty/curl-8.21.0/lib/vtls/openssl.c new file mode 100644 index 0000000000..010bbb9825 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vtls/openssl.c @@ -0,0 +1,5543 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +/* + * Source file for all OpenSSL-specific code for the TLS/SSL layer. No code + * but vtls.c should ever call or use these functions. + */ +#include "curl_setup.h" + +#ifdef USE_OPENSSL + +#include "urldata.h" +#include "curl_trc.h" +#include "httpsrr.h" +#include "formdata.h" /* for the boundary function */ +#include "url.h" /* for the SSL config check function */ +#include "curlx/inet_pton.h" +#include "vtls/openssl.h" +#include "connect.h" +#include "cf-dns.h" +#include "progress.h" +#include "vtls/vtls.h" +#include "vtls/vtls_int.h" +#include "vtls/vtls_scache.h" +#include "vauth/vauth.h" +#include "vtls/keylog.h" +#include "vtls/hostcheck.h" +#include "transfer.h" +#include "multiif.h" +#include "curlx/strerr.h" +#include "curlx/strparse.h" +#include "curlx/strcopy.h" +#include "curlx/strdup.h" +#include "vtls/apple.h" +#ifdef USE_ECH +#include "curlx/base64.h" +#endif + +#include +#include +#ifndef OPENSSL_NO_DSA +#include +#endif +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#if defined(HAVE_SSL_SET1_ECH_CONFIG_LIST) && !defined(HAVE_BORINGSSL_LIKE) +#include +#endif + +#ifndef OPENSSL_NO_OCSP +#include +#endif + +#if !defined(OPENSSL_NO_ENGINE) && !defined(OPENSSL_NO_UI_CONSOLE) +#define USE_OPENSSL_ENGINE +#include +#endif + +#ifdef LIBRESSL_VERSION_NUMBER +/* As of LibreSSL 2.0.0-4.0.0: OPENSSL_VERSION_NUMBER == 0x20000000L */ +# if LIBRESSL_VERSION_NUMBER < 0x2090100fL /* 2019-04-13 */ +# error "LibreSSL 2.9.1 or later required" +# endif +#elif !defined(HAVE_BORINGSSL_LIKE) +# ifndef HAVE_OPENSSL3 /* 2021-09-07 */ +# error "OpenSSL 3.0.0 or later required" +# endif +#endif + +#if defined(HAVE_OPENSSL3) && !defined(OPENSSL_NO_UI_CONSOLE) +#include +#include +/* this is used in the following conditions to make them easier to read */ +#define OPENSSL_HAS_PROVIDERS +#endif + +/* AWS-LC fixed a bug with large buffers in v1.61.0 which also introduced + * X509_V_ERR_EC_KEY_EXPLICIT_PARAMS. */ +#if !defined(LIBRESSL_VERSION_NUMBER) && !defined(OPENSSL_IS_BORINGSSL) && \ + (!defined(OPENSSL_IS_AWSLC) || defined(X509_V_ERR_EC_KEY_EXPLICIT_PARAMS)) +#define HAVE_SSL_CTX_SET_DEFAULT_READ_BUFFER_LEN 1 +#endif + +#if defined(USE_OPENSSL_ENGINE) || defined(OPENSSL_HAS_PROVIDERS) +#include +#endif + +#ifdef HAVE_OPENSSL3 +#define HAVE_EVP_PKEY_GET_PARAMS 1 +#endif + +#ifdef HAVE_EVP_PKEY_GET_PARAMS +#include +#define DECLARE_PKEY_PARAM_BIGNUM(name) BIGNUM *name = NULL +#define FREE_PKEY_PARAM_BIGNUM(name) BN_clear_free(name) +#else +#define DECLARE_PKEY_PARAM_BIGNUM(name) const BIGNUM *name +#define FREE_PKEY_PARAM_BIGNUM(name) +#endif + +/* Whether SSL_CTX_set_ciphersuites is available. + * BoringSSL: no + * LibreSSL: supported since 3.4.1 (released 2021-10-14) + * OpenSSL: supported since 1.1.1 (commit a53b5be6a05) + */ +#if (!defined(LIBRESSL_VERSION_NUMBER) || \ + (defined(LIBRESSL_VERSION_NUMBER) && \ + LIBRESSL_VERSION_NUMBER >= 0x3040100fL)) && \ + !defined(OPENSSL_IS_BORINGSSL) +# define HAVE_SSL_CTX_SET_CIPHERSUITES +# ifndef OPENSSL_IS_AWSLC +# define HAVE_SSL_CTX_SET_POST_HANDSHAKE_AUTH +# endif +#endif + +/* Whether SSL_CTX_set1_sigalgs_list is available + * BoringSSL: supported since 0.20240913.0 (commit 826ce15) + * LibreSSL: no + * OpenSSL: supported since 1.0.2 (commit 0b362de5f575) + */ +#ifndef LIBRESSL_VERSION_NUMBER +#define HAVE_SSL_CTX_SET1_SIGALGS +#endif + +#ifdef LIBRESSL_VERSION_NUMBER +#define OSSL_PACKAGE "LibreSSL" +#elif defined(OPENSSL_IS_AWSLC) +#define OSSL_PACKAGE "AWS-LC" +#elif defined(OPENSSL_IS_BORINGSSL) +#define OSSL_PACKAGE "BoringSSL" +#elif defined(USE_NGTCP2) && defined(USE_NGHTTP3) && \ + !defined(OPENSSL_QUIC_API2) +#define OSSL_PACKAGE "quictls" +#else +#define OSSL_PACKAGE "OpenSSL" +#endif + +#ifdef HAVE_BORINGSSL_LIKE +typedef size_t numcert_t; +typedef uint32_t sslerr_t; +#else +typedef int numcert_t; +typedef unsigned long sslerr_t; +#endif +#define ossl_valsize_t numcert_t + +static CURLcode push_certinfo(struct Curl_easy *data, + BIO *mem, const char *label, int num) + WARN_UNUSED_RESULT; + +static CURLcode push_certinfo(struct Curl_easy *data, + BIO *mem, const char *label, int num) +{ + char *ptr; + long len = BIO_get_mem_data(mem, &ptr); + CURLcode result = Curl_ssl_push_certinfo_len(data, num, label, ptr, len); + (void)BIO_reset(mem); + return result; +} + +static CURLcode pubkey_show(struct Curl_easy *data, + BIO *mem, + int num, + const char *type, + const char *name, + const BIGNUM *bn) WARN_UNUSED_RESULT; + +static CURLcode pubkey_show(struct Curl_easy *data, + BIO *mem, + int num, + const char *type, + const char *name, + const BIGNUM *bn) +{ + char namebuf[32]; + + curl_msnprintf(namebuf, sizeof(namebuf), "%s(%s)", type, name); + + if(bn) + BN_print(mem, bn); + return push_certinfo(data, mem, namebuf, num); +} + +#define print_pubkey_BN(_type, _name, _num) \ + pubkey_show(data, mem, _num, #_type, #_name, _name) + +static int asn1_object_dump(const ASN1_OBJECT *a, char *buf, size_t len) +{ + int i = i2t_ASN1_OBJECT(buf, (int)len, a); + return (i >= (int)len); /* buffer too small */ +} + +static CURLcode X509V3_ext(struct Curl_easy *data, + int certnum, + const STACK_OF(X509_EXTENSION) *extsarg) +{ + int i; + CURLcode result = CURLE_OK; +#ifdef LIBRESSL_VERSION_NUMBER + STACK_OF(X509_EXTENSION) *exts = CURL_UNCONST(extsarg); +#else + const STACK_OF(X509_EXTENSION) *exts = extsarg; +#endif + + if((int)sk_X509_EXTENSION_num(exts) <= 0) + /* no extensions, bail out */ + return result; + + for(i = 0; i < (int)sk_X509_EXTENSION_num(exts); i++) { + const ASN1_OBJECT *obj; + X509_EXTENSION *ext = sk_X509_EXTENSION_value(exts, (ossl_valsize_t)i); + BUF_MEM *biomem; + char namebuf[128]; + BIO *bio_out = BIO_new(BIO_s_mem()); + + if(!bio_out) + return result; + + obj = X509_EXTENSION_get_object(ext); + + if(asn1_object_dump(obj, namebuf, sizeof(namebuf))) + /* make sure the name is null-terminated */ + namebuf[sizeof(namebuf) - 1] = 0; + + if(!X509V3_EXT_print(bio_out, ext, 0, 0)) + ASN1_STRING_print(bio_out, + (const ASN1_STRING *)X509_EXTENSION_get_data(ext)); + + BIO_get_mem_ptr(bio_out, &biomem); + result = Curl_ssl_push_certinfo_len(data, certnum, namebuf, biomem->data, + biomem->length); + BIO_free(bio_out); + if(result) + break; + } + return result; +} + +static CURLcode get_pkey_rsa(struct Curl_easy *data, + EVP_PKEY *pubkey, BIO *mem, int i) +{ + CURLcode result = CURLE_OK; +#ifndef HAVE_EVP_PKEY_GET_PARAMS + RSA *rsa = EVP_PKEY_get0_RSA(pubkey); +#endif /* !HAVE_EVP_PKEY_GET_PARAMS */ + DECLARE_PKEY_PARAM_BIGNUM(n); + DECLARE_PKEY_PARAM_BIGNUM(e); +#ifdef HAVE_EVP_PKEY_GET_PARAMS + EVP_PKEY_get_bn_param(pubkey, OSSL_PKEY_PARAM_RSA_N, &n); + EVP_PKEY_get_bn_param(pubkey, OSSL_PKEY_PARAM_RSA_E, &e); +#else + RSA_get0_key(rsa, &n, &e, NULL); +#endif /* HAVE_EVP_PKEY_GET_PARAMS */ + BIO_printf(mem, "%d", (int)(n ? BN_num_bits(n) : 0)); + result = push_certinfo(data, mem, "RSA Public Key", i); + if(!result) { + result = print_pubkey_BN(rsa, n, i); + if(!result) + result = print_pubkey_BN(rsa, e, i); + } + FREE_PKEY_PARAM_BIGNUM(n); + FREE_PKEY_PARAM_BIGNUM(e); + return result; +} + +#ifndef OPENSSL_NO_DSA +static CURLcode get_pkey_dsa(struct Curl_easy *data, + EVP_PKEY *pubkey, BIO *mem, int i) +{ + CURLcode result = CURLE_OK; +#ifndef HAVE_EVP_PKEY_GET_PARAMS + DSA *dsa = EVP_PKEY_get0_DSA(pubkey); +#endif /* !HAVE_EVP_PKEY_GET_PARAMS */ + DECLARE_PKEY_PARAM_BIGNUM(p); + DECLARE_PKEY_PARAM_BIGNUM(q); + DECLARE_PKEY_PARAM_BIGNUM(g); + DECLARE_PKEY_PARAM_BIGNUM(pub_key); +#ifdef HAVE_EVP_PKEY_GET_PARAMS + EVP_PKEY_get_bn_param(pubkey, OSSL_PKEY_PARAM_FFC_P, &p); + EVP_PKEY_get_bn_param(pubkey, OSSL_PKEY_PARAM_FFC_Q, &q); + EVP_PKEY_get_bn_param(pubkey, OSSL_PKEY_PARAM_FFC_G, &g); + EVP_PKEY_get_bn_param(pubkey, OSSL_PKEY_PARAM_PUB_KEY, &pub_key); +#else + DSA_get0_pqg(dsa, &p, &q, &g); + DSA_get0_key(dsa, &pub_key, NULL); +#endif /* HAVE_EVP_PKEY_GET_PARAMS */ + result = print_pubkey_BN(dsa, p, i); + if(!result) + result = print_pubkey_BN(dsa, q, i); + if(!result) + result = print_pubkey_BN(dsa, g, i); + if(!result) + result = print_pubkey_BN(dsa, pub_key, i); + FREE_PKEY_PARAM_BIGNUM(p); + FREE_PKEY_PARAM_BIGNUM(q); + FREE_PKEY_PARAM_BIGNUM(g); + FREE_PKEY_PARAM_BIGNUM(pub_key); + return result; +} +#endif /* !OPENSSL_NO_DSA */ + +static CURLcode get_pkey_dh(struct Curl_easy *data, + EVP_PKEY *pubkey, BIO *mem, int i) +{ + CURLcode result; +#ifndef HAVE_EVP_PKEY_GET_PARAMS + DH *dh = EVP_PKEY_get0_DH(pubkey); +#endif /* !HAVE_EVP_PKEY_GET_PARAMS */ + DECLARE_PKEY_PARAM_BIGNUM(p); + DECLARE_PKEY_PARAM_BIGNUM(q); + DECLARE_PKEY_PARAM_BIGNUM(g); + DECLARE_PKEY_PARAM_BIGNUM(pub_key); +#ifdef HAVE_EVP_PKEY_GET_PARAMS + EVP_PKEY_get_bn_param(pubkey, OSSL_PKEY_PARAM_FFC_P, &p); + EVP_PKEY_get_bn_param(pubkey, OSSL_PKEY_PARAM_FFC_Q, &q); + EVP_PKEY_get_bn_param(pubkey, OSSL_PKEY_PARAM_FFC_G, &g); + EVP_PKEY_get_bn_param(pubkey, OSSL_PKEY_PARAM_PUB_KEY, &pub_key); +#else + DH_get0_pqg(dh, &p, &q, &g); + DH_get0_key(dh, &pub_key, NULL); +#endif /* HAVE_EVP_PKEY_GET_PARAMS */ + result = print_pubkey_BN(dh, p, i); + if(!result) + result = print_pubkey_BN(dh, q, i); + if(!result) + result = print_pubkey_BN(dh, g, i); + if(!result) + result = print_pubkey_BN(dh, pub_key, i); + FREE_PKEY_PARAM_BIGNUM(p); + FREE_PKEY_PARAM_BIGNUM(q); + FREE_PKEY_PARAM_BIGNUM(g); + FREE_PKEY_PARAM_BIGNUM(pub_key); + return result; +} + +#ifdef HAVE_OPENSSL3 +/* from OpenSSL commit fc756e594ed5a27af378 */ +typedef const X509_PUBKEY pubkeytype_t; +#else +typedef X509_PUBKEY pubkeytype_t; +#endif + +static CURLcode ossl_certchain(struct Curl_easy *data, SSL *ssl) +{ + CURLcode result; + STACK_OF(X509) *sk; + int i; + numcert_t numcerts; + BIO *mem; + + DEBUGASSERT(ssl); + + sk = SSL_get_peer_cert_chain(ssl); + if(!sk) + return CURLE_SSL_CONNECT_ERROR; + + numcerts = sk_X509_num(sk); + if(numcerts > MAX_ALLOWED_CERT_AMOUNT) { + failf(data, "%d certificates is more than allowed (%d)", (int)numcerts, + MAX_ALLOWED_CERT_AMOUNT); + return CURLE_SSL_CONNECT_ERROR; + } + + result = Curl_ssl_init_certinfo(data, (int)numcerts); + if(result) + return result; + + mem = BIO_new(BIO_s_mem()); + if(!mem) + result = CURLE_OUT_OF_MEMORY; + + for(i = 0; !result && (i < (int)numcerts); i++) { + ASN1_INTEGER *num; + const unsigned char *numdata; + X509 *x = sk_X509_value(sk, (ossl_valsize_t)i); + EVP_PKEY *pubkey = NULL; + int j; + const ASN1_BIT_STRING *psig = NULL; + + X509_NAME_print_ex(mem, X509_get_subject_name(x), 0, XN_FLAG_ONELINE); + result = push_certinfo(data, mem, "Subject", i); + if(result) + break; + + X509_NAME_print_ex(mem, X509_get_issuer_name(x), 0, XN_FLAG_ONELINE); + result = push_certinfo(data, mem, "Issuer", i); + if(result) + break; + + BIO_printf(mem, "%lx", (unsigned long)X509_get_version(x)); + result = push_certinfo(data, mem, "Version", i); + if(result) + break; + + num = X509_get_serialNumber(x); + if(ASN1_STRING_type(num) == V_ASN1_NEG_INTEGER) + BIO_puts(mem, "-"); + numdata = ASN1_STRING_get0_data(num); + for(j = 0; j < ASN1_STRING_length(num); j++) + BIO_printf(mem, "%02x", numdata[j]); + result = push_certinfo(data, mem, "Serial Number", i); + if(result) + break; + + { + const X509_ALGOR *sigalg = NULL; + pubkeytype_t *xpubkey = NULL; + ASN1_OBJECT *pubkeyoid = NULL; + + X509_get0_signature(&psig, &sigalg, x); + if(sigalg) { + const ASN1_OBJECT *sigalgoid = NULL; + X509_ALGOR_get0(&sigalgoid, NULL, NULL, sigalg); + i2a_ASN1_OBJECT(mem, sigalgoid); + result = push_certinfo(data, mem, "Signature Algorithm", i); + if(result) + break; + } + + xpubkey = X509_get_X509_PUBKEY(x); + if(xpubkey) { + X509_PUBKEY_get0_param(&pubkeyoid, NULL, NULL, NULL, xpubkey); + if(pubkeyoid) { + i2a_ASN1_OBJECT(mem, pubkeyoid); + result = push_certinfo(data, mem, "Public Key Algorithm", i); + if(result) + break; + } + } + + result = X509V3_ext(data, i, X509_get0_extensions(x)); + if(result) + break; + } + + ASN1_TIME_print(mem, X509_get0_notBefore(x)); + result = push_certinfo(data, mem, "Start date", i); + if(result) + break; + + ASN1_TIME_print(mem, X509_get0_notAfter(x)); + result = push_certinfo(data, mem, "Expire date", i); + if(result) + break; + + pubkey = X509_get_pubkey(x); + if(!pubkey) + infof(data, " Unable to load public key"); + else { + switch(EVP_PKEY_id(pubkey)) { + case EVP_PKEY_RSA: + result = get_pkey_rsa(data, pubkey, mem, i); + break; + +#ifndef OPENSSL_NO_DSA + case EVP_PKEY_DSA: + result = get_pkey_dsa(data, pubkey, mem, i); + break; +#endif + + case EVP_PKEY_DH: + result = get_pkey_dh(data, pubkey, mem, i); + break; + } + EVP_PKEY_free(pubkey); + } + + if(!result && psig) { + const unsigned char *psigdata = ASN1_STRING_get0_data(psig); + for(j = 0; j < ASN1_STRING_length(psig); j++) + BIO_printf(mem, "%02x:", psigdata[j]); + result = push_certinfo(data, mem, "Signature", i); + } + + if(!result) { + PEM_write_bio_X509(mem, x); + result = push_certinfo(data, mem, "Cert", i); + } + } + + BIO_free(mem); + + if(result) + /* cleanup all leftovers */ + Curl_ssl_free_certinfo(data); + + return result; +} + +static int ossl_bio_cf_create(BIO *bio) +{ + BIO_set_shutdown(bio, 1); + BIO_set_init(bio, 1); + BIO_set_data(bio, NULL); + return 1; +} + +static int ossl_bio_cf_destroy(BIO *bio) +{ + if(!bio) + return 0; + return 1; +} + +static long ossl_bio_cf_ctrl(BIO *bio, int cmd, long num, void *ptr) +{ + struct Curl_cfilter *cf = BIO_get_data(bio); + long ret = 1; + + (void)cf; + (void)ptr; + switch(cmd) { + case BIO_CTRL_GET_CLOSE: + ret = (long)BIO_get_shutdown(bio); + break; + case BIO_CTRL_SET_CLOSE: + BIO_set_shutdown(bio, (int)num); + break; + case BIO_CTRL_FLUSH: + /* we do no delayed writes, but if we ever would, this + * needs to trigger it. */ + ret = 1; + break; + case BIO_CTRL_DUP: + ret = 1; + break; + case BIO_CTRL_EOF: { + /* EOF has been reached on input? */ + struct ssl_connect_data *connssl = cf->ctx; + return connssl->peer_closed; + } + default: + ret = 0; + break; + } + return ret; +} + +static int ossl_bio_cf_out_write(BIO *bio, const char *buf, int blen) +{ + struct Curl_cfilter *cf = BIO_get_data(bio); + struct ssl_connect_data *connssl = cf->ctx; + struct ossl_ctx *octx = (struct ossl_ctx *)connssl->backend; + struct Curl_easy *data = CF_DATA_CURRENT(cf); + size_t nwritten; + CURLcode result; + + DEBUGASSERT(data); + if(blen < 0) + return 0; + + result = Curl_conn_cf_send(cf->next, data, + (const uint8_t *)buf, (size_t)blen, FALSE, + &nwritten); + CURL_TRC_CF(data, cf, "ossl_bio_cf_out_write(len=%d) -> %d, %zu", + blen, (int)result, nwritten); + BIO_clear_retry_flags(bio); + octx->io_result = result; + if(result) { + if(result == CURLE_AGAIN) + BIO_set_retry_write(bio); + return -1; + } + return (int)nwritten; +} + +static int ossl_bio_cf_in_read(BIO *bio, char *buf, int blen) +{ + struct Curl_cfilter *cf = BIO_get_data(bio); + struct ssl_connect_data *connssl = cf->ctx; + struct ossl_ctx *octx = (struct ossl_ctx *)connssl->backend; + struct Curl_easy *data = CF_DATA_CURRENT(cf); + size_t nread; + CURLcode result, r2; + + DEBUGASSERT(data); + /* OpenSSL catches this case, so should we. */ + if(!buf) + return 0; + if(blen < 0) + return 0; + + result = Curl_conn_cf_recv(cf->next, data, buf, (size_t)blen, &nread); + CURL_TRC_CF(data, cf, "ossl_bio_cf_in_read(len=%d) -> %d, %zu", + blen, (int)result, nread); + BIO_clear_retry_flags(bio); + octx->io_result = result; + if(result) { + if(result == CURLE_AGAIN) + BIO_set_retry_read(bio); + } + else { + /* feeding data to OpenSSL means SSL_read() might succeed */ + connssl->input_pending = TRUE; + if(nread == 0) + connssl->peer_closed = TRUE; + } + + /* Before returning server replies to the SSL instance, we need + * to have setup the x509 store or verification fails. */ + if(!octx->x509_store_setup) { + r2 = Curl_ssl_setup_x509_store(cf, data, octx); + if(r2) { + BIO_clear_retry_flags(bio); + octx->io_result = r2; + return -1; + } + octx->x509_store_setup = TRUE; + } + return result ? -1 : (int)nread; +} + +static BIO_METHOD *ossl_bio_cf_method_create(void) +{ + BIO_METHOD *m = BIO_meth_new(BIO_TYPE_MEM, "OpenSSL CF BIO"); + if(m) { + BIO_meth_set_write(m, &ossl_bio_cf_out_write); + BIO_meth_set_read(m, &ossl_bio_cf_in_read); + BIO_meth_set_ctrl(m, &ossl_bio_cf_ctrl); + BIO_meth_set_create(m, &ossl_bio_cf_create); + BIO_meth_set_destroy(m, &ossl_bio_cf_destroy); + } + return m; +} + +static void ossl_bio_cf_method_free(BIO_METHOD *m) +{ + if(m) + BIO_meth_free(m); +} + +#ifndef HAVE_KEYLOG_UPSTREAM +#ifdef HAVE_KEYLOG_CALLBACK +static void ossl_keylog_callback(const SSL *ssl, const char *line) +{ + (void)ssl; + + Curl_tls_keylog_write_line(line); +} +#else +/* + * ossl_log_tls12_secret is called by libcurl to make the CLIENT_RANDOMs if the + * OpenSSL being used does not have native support for doing that. + */ +static void ossl_log_tls12_secret(const SSL *ssl, bool *keylog_done) +{ + const SSL_SESSION *session; + unsigned char client_random[SSL3_RANDOM_SIZE]; + unsigned char master_key[SSL_MAX_MASTER_KEY_LENGTH]; + int master_key_length = 0; + + ERR_set_mark(); + + session = SSL_get_session(ssl); + + if(!session || *keylog_done) { + ERR_pop_to_mark(); + return; + } + + SSL_get_client_random(ssl, client_random, SSL3_RANDOM_SIZE); + master_key_length = (int) + SSL_SESSION_get_master_key(session, master_key, SSL_MAX_MASTER_KEY_LENGTH); + + ERR_pop_to_mark(); + + /* The handshake has not progressed sufficiently yet, or this is a TLS 1.3 + * session (when curl was built with older OpenSSL headers and running with + * newer OpenSSL runtime libraries). */ + if(master_key_length <= 0) + return; + + *keylog_done = TRUE; + Curl_tls_keylog_write("CLIENT_RANDOM", client_random, + master_key, master_key_length); +} +#endif /* !HAVE_KEYLOG_CALLBACK */ +#endif /* HAVE_KEYLOG_UPSTREAM */ + +static const char *SSL_ERROR_to_str(int err) +{ + switch(err) { + case SSL_ERROR_NONE: + return "SSL_ERROR_NONE"; + case SSL_ERROR_SSL: + return "SSL_ERROR_SSL"; + case SSL_ERROR_WANT_READ: + return "SSL_ERROR_WANT_READ"; + case SSL_ERROR_WANT_WRITE: + return "SSL_ERROR_WANT_WRITE"; + case SSL_ERROR_WANT_X509_LOOKUP: + return "SSL_ERROR_WANT_X509_LOOKUP"; + case SSL_ERROR_SYSCALL: + return "SSL_ERROR_SYSCALL"; + case SSL_ERROR_ZERO_RETURN: + return "SSL_ERROR_ZERO_RETURN"; + case SSL_ERROR_WANT_CONNECT: + return "SSL_ERROR_WANT_CONNECT"; + case SSL_ERROR_WANT_ACCEPT: + return "SSL_ERROR_WANT_ACCEPT"; +#ifdef SSL_ERROR_WANT_ASYNC /* OpenSSL 1.1.0+, LibreSSL 3.6.0+ */ + case SSL_ERROR_WANT_ASYNC: + return "SSL_ERROR_WANT_ASYNC"; +#endif +#ifdef SSL_ERROR_WANT_ASYNC_JOB /* OpenSSL 1.1.0+, LibreSSL 3.6.0+ */ + case SSL_ERROR_WANT_ASYNC_JOB: + return "SSL_ERROR_WANT_ASYNC_JOB"; +#endif +#ifdef SSL_ERROR_WANT_CLIENT_HELLO_CB /* OpenSSL 1.1.1, LibreSSL 3.6.0+ */ + case SSL_ERROR_WANT_CLIENT_HELLO_CB: + return "SSL_ERROR_WANT_CLIENT_HELLO_CB"; +#endif + default: + return "SSL_ERROR unknown"; + } +} + +/* Return error string for last OpenSSL error + */ +static char *ossl_strerror(unsigned long error, char *buf, size_t size) +{ + size_t len; + DEBUGASSERT(size); + *buf = '\0'; + + len = Curl_ossl_version(buf, size); + DEBUGASSERT(len < (size - 2)); + if(len < (size - 2)) { + buf += len; + size -= (len + 2); + *buf++ = ':'; + *buf++ = ' '; + *buf = '\0'; + } + +#ifdef HAVE_BORINGSSL_LIKE + ERR_error_string_n((uint32_t)error, buf, size); +#else + ERR_error_string_n(error, buf, size); +#endif + + if(!*buf) { + const char *msg = error ? "Unknown error" : "No error"; + curlx_strcopy(buf, size, msg, strlen(msg)); + } + + return buf; +} + +static int passwd_callback(char *buf, int num, int encrypting, void *password) +{ + DEBUGASSERT(encrypting == 0); + + if(!encrypting && num >= 0 && password) { + int klen = curlx_uztosi(strlen((char *)password)); + if(num > klen) { + memcpy(buf, password, klen + 1); + return klen; + } + } + return 0; +} + +/* + * rand_enough() returns TRUE if we have seeded the random engine properly. + */ +static bool rand_enough(void) +{ + return RAND_status() != 0; +} + +static CURLcode ossl_seed(struct Curl_easy *data) +{ + /* This might get called before it has been added to a multi handle */ + if(data->multi && data->multi->ssl_seeded) + return CURLE_OK; + + if(rand_enough()) { + /* OpenSSL 1.1.0+ should return here */ + if(data->multi) + data->multi->ssl_seeded = TRUE; + return CURLE_OK; + } + failf(data, "Insufficient randomness"); + return CURLE_SSL_CONNECT_ERROR; +} + +#ifndef SSL_FILETYPE_ENGINE +#define SSL_FILETYPE_ENGINE 42 +#endif +#ifndef SSL_FILETYPE_PKCS12 +#define SSL_FILETYPE_PKCS12 43 +#endif +#ifndef SSL_FILETYPE_PROVIDER +#define SSL_FILETYPE_PROVIDER 44 +#endif +static int ossl_do_file_type(const char *type) +{ + if(!type || !type[0]) + return SSL_FILETYPE_PEM; + if(curl_strequal(type, "PEM")) + return SSL_FILETYPE_PEM; + if(curl_strequal(type, "DER")) + return SSL_FILETYPE_ASN1; + if(curl_strequal(type, "PROV")) + return SSL_FILETYPE_PROVIDER; + if(curl_strequal(type, "ENG")) + return SSL_FILETYPE_ENGINE; + if(curl_strequal(type, "P12")) + return SSL_FILETYPE_PKCS12; + return -1; +} + +#if defined(USE_OPENSSL_ENGINE) || defined(OPENSSL_HAS_PROVIDERS) +/* + * Supply default password to the engine user interface conversation. + * The password is passed by OpenSSL engine from ENGINE_load_private_key() + * last argument to the ui and can be obtained by UI_get0_user_data(ui) here. + */ +static int ssl_ui_reader(UI *ui, UI_STRING *uis) +{ + const char *password; + switch(UI_get_string_type(uis)) { + case UIT_PROMPT: + case UIT_VERIFY: + password = (const char *)UI_get0_user_data(ui); + if(password && (UI_get_input_flags(uis) & UI_INPUT_FLAG_DEFAULT_PWD)) { + UI_set_result(ui, uis, password); + return 1; + } + FALLTHROUGH(); + default: + break; + } + return (UI_method_get_reader(UI_OpenSSL()))(ui, uis); +} + +/* + * Suppress interactive request for a default password if available. + */ +static int ssl_ui_writer(UI *ui, UI_STRING *uis) +{ + switch(UI_get_string_type(uis)) { + case UIT_PROMPT: + case UIT_VERIFY: + if(UI_get0_user_data(ui) && + (UI_get_input_flags(uis) & UI_INPUT_FLAG_DEFAULT_PWD)) { + return 1; + } + FALLTHROUGH(); + default: + break; + } + return (UI_method_get_writer(UI_OpenSSL()))(ui, uis); +} + +/* + * Check if a given string is a PKCS#11 URI + */ +static bool is_pkcs11_uri(const char *string) +{ + return string && curl_strnequal(string, "pkcs11:", 7); +} + +#endif + +static CURLcode ossl_set_engine(struct Curl_easy *data, const char *name); +#ifdef OPENSSL_HAS_PROVIDERS +static CURLcode ossl_set_provider(struct Curl_easy *data, const char *iname); +#endif + +static int use_certificate_blob(SSL_CTX *ctx, const struct curl_blob *blob, + int type, const char *key_passwd) +{ + int ret = 0; + X509 *x = NULL; + /* the typecast of blob->len is fine since it is guaranteed to never be + larger than CURL_MAX_INPUT_LENGTH */ + BIO *in = BIO_new_mem_buf(blob->data, (int)(blob->len)); + if(!in) + return CURLE_OUT_OF_MEMORY; + + if(type == SSL_FILETYPE_ASN1) { + /* j = ERR_R_ASN1_LIB; */ + x = d2i_X509_bio(in, NULL); + } + else if(type == SSL_FILETYPE_PEM) { + /* ERR_R_PEM_LIB; */ + x = PEM_read_bio_X509(in, NULL, passwd_callback, CURL_UNCONST(key_passwd)); + } + else { + ret = 0; + goto end; + } + + if(!x) { + ret = 0; + goto end; + } + + ret = SSL_CTX_use_certificate(ctx, x); +end: + X509_free(x); + BIO_free(in); + return ret; +} + +static int use_privatekey_blob(SSL_CTX *ctx, const struct curl_blob *blob, + int type, const char *key_passwd) +{ + int ret = 0; + EVP_PKEY *pkey = NULL; + BIO *in = BIO_new_mem_buf(blob->data, (int)(blob->len)); + if(!in) + return CURLE_OUT_OF_MEMORY; + + if(type == SSL_FILETYPE_PEM) + pkey = PEM_read_bio_PrivateKey(in, NULL, passwd_callback, + CURL_UNCONST(key_passwd)); + else if(type == SSL_FILETYPE_ASN1) + pkey = d2i_PrivateKey_bio(in, NULL); + else + goto end; + + if(!pkey) + goto end; + + ret = SSL_CTX_use_PrivateKey(ctx, pkey); + EVP_PKEY_free(pkey); +end: + BIO_free(in); + return ret; +} + +static int use_certificate_chain_blob(SSL_CTX *ctx, + const struct curl_blob *blob, + const char *key_passwd) +{ + int ret = 0; + X509 *x = NULL; + BIO *in = BIO_new_mem_buf(blob->data, (int)(blob->len)); + if(!in) + return CURLE_OUT_OF_MEMORY; + + ERR_clear_error(); + + x = PEM_read_bio_X509_AUX(in, NULL, + passwd_callback, CURL_UNCONST(key_passwd)); + if(!x) + goto end; + + ret = SSL_CTX_use_certificate(ctx, x); + + if(ERR_peek_error() != 0) + ret = 0; + + if(ret) { + X509 *ca; + sslerr_t err; + + if(!SSL_CTX_clear_chain_certs(ctx)) { + ret = 0; + goto end; + } + + while((ca = PEM_read_bio_X509(in, NULL, passwd_callback, + CURL_UNCONST(key_passwd))) != NULL) { + + if(!SSL_CTX_add0_chain_cert(ctx, ca)) { + X509_free(ca); + ret = 0; + goto end; + } + } + + err = ERR_peek_last_error(); + if((ERR_GET_LIB(err) == ERR_LIB_PEM) && + (ERR_GET_REASON(err) == PEM_R_NO_START_LINE)) + ERR_clear_error(); + else + ret = 0; + } + +end: + X509_free(x); + BIO_free(in); + return ret; +} + +static int enginecheck(struct Curl_easy *data, + SSL_CTX* ctx, + const char *key_file, + const char *key_passwd) +{ +#ifdef USE_OPENSSL_ENGINE + EVP_PKEY *priv_key = NULL; + + /* Implicitly use pkcs11 engine if none was provided and the + * key_file is a PKCS#11 URI */ + if(!data->state.engine) { + if(is_pkcs11_uri(key_file)) { + if(ossl_set_engine(data, "pkcs11") != CURLE_OK) { + return 0; + } + } + } + + if(data->state.engine) { + UI_METHOD *ui_method = UI_create_method("curl user interface"); + if(!ui_method) { + failf(data, "unable to create " OSSL_PACKAGE " user-interface method"); + return 0; + } + UI_method_set_opener(ui_method, UI_method_get_opener(UI_OpenSSL())); + UI_method_set_closer(ui_method, UI_method_get_closer(UI_OpenSSL())); + UI_method_set_reader(ui_method, ssl_ui_reader); + UI_method_set_writer(ui_method, ssl_ui_writer); + priv_key = ENGINE_load_private_key(data->state.engine, key_file, + ui_method, + CURL_UNCONST(key_passwd)); + UI_destroy_method(ui_method); + if(!priv_key) { + failf(data, "failed to load private key from crypto engine"); + return 0; + } + if(SSL_CTX_use_PrivateKey(ctx, priv_key) != 1) { + failf(data, "unable to set private key"); + EVP_PKEY_free(priv_key); + return 0; + } + EVP_PKEY_free(priv_key); /* we do not need the handle any more... */ + } + else { + failf(data, "crypto engine not set, cannot load private key"); + return 0; + } + return 1; +#else + (void)ctx; + (void)key_file; + (void)key_passwd; + failf(data, "SSL_FILETYPE_ENGINE not supported for private key"); + return 0; +#endif +} + +static int providercheck(struct Curl_easy *data, + SSL_CTX* ctx, + const char *key_file) +{ +#ifdef OPENSSL_HAS_PROVIDERS + char error_buffer[256]; + /* Implicitly use pkcs11 provider if none was provided and the + * key_file is a PKCS#11 URI */ + if(!data->state.provider_loaded) { + if(is_pkcs11_uri(key_file)) { + if(ossl_set_provider(data, "pkcs11") != CURLE_OK) { + return 0; + } + } + } + + if(data->state.provider_loaded) { + /* Load the private key from the provider */ + EVP_PKEY *priv_key = NULL; + OSSL_STORE_CTX *store = NULL; + OSSL_STORE_INFO *info = NULL; + UI_METHOD *ui_method = UI_create_method("curl user interface"); + if(!ui_method) { + failf(data, "unable to create " OSSL_PACKAGE " user-interface method"); + return 0; + } + UI_method_set_opener(ui_method, UI_method_get_opener(UI_OpenSSL())); + UI_method_set_closer(ui_method, UI_method_get_closer(UI_OpenSSL())); + UI_method_set_reader(ui_method, ssl_ui_reader); + UI_method_set_writer(ui_method, ssl_ui_writer); + + store = OSSL_STORE_open_ex(key_file, data->state.libctx, + data->state.propq, ui_method, NULL, NULL, + NULL, NULL); + if(!store) { + failf(data, "Failed to open OpenSSL store: %s", + ossl_strerror(ERR_get_error(), error_buffer, + sizeof(error_buffer))); + UI_destroy_method(ui_method); + return 0; + } + if(OSSL_STORE_expect(store, OSSL_STORE_INFO_PKEY) != 1) { + failf(data, "Failed to set store preference. Ignoring the error: %s", + ossl_strerror(ERR_get_error(), error_buffer, + sizeof(error_buffer))); + } + + info = OSSL_STORE_load(store); + if(info) { + int ossl_type = OSSL_STORE_INFO_get_type(info); + + if(ossl_type == OSSL_STORE_INFO_PKEY) + priv_key = OSSL_STORE_INFO_get1_PKEY(info); + OSSL_STORE_INFO_free(info); + } + OSSL_STORE_close(store); + UI_destroy_method(ui_method); + if(!priv_key) { + failf(data, "No private key found in the openssl store: %s", + ossl_strerror(ERR_get_error(), error_buffer, + sizeof(error_buffer))); + return 0; + } + + if(SSL_CTX_use_PrivateKey(ctx, priv_key) != 1) { + failf(data, "unable to set private key [%s]", + ossl_strerror(ERR_get_error(), error_buffer, + sizeof(error_buffer))); + EVP_PKEY_free(priv_key); + return 0; + } + EVP_PKEY_free(priv_key); /* we do not need the handle any more... */ + } + else { + failf(data, "crypto provider not set, cannot load private key"); + return 0; + } + return 1; +#else + (void)ctx; + (void)key_file; + failf(data, "SSL_FILETYPE_PROVIDER not supported for private key"); + return 0; +#endif +} + +static int engineload(struct Curl_easy *data, + SSL_CTX* ctx, + const char *cert_file) +{ +/* ENGINE_CTRL_GET_CMD_FROM_NAME supported by OpenSSL, LibreSSL <=3.8.3 */ +#if defined(USE_OPENSSL_ENGINE) && defined(ENGINE_CTRL_GET_CMD_FROM_NAME) + char error_buffer[256]; + /* Implicitly use pkcs11 engine if none was provided and the + * cert_file is a PKCS#11 URI */ + if(!data->state.engine) { + if(is_pkcs11_uri(cert_file)) { + if(ossl_set_engine(data, "pkcs11") != CURLE_OK) { + return 0; + } + } + } + + if(data->state.engine) { + const char *cmd_name = "LOAD_CERT_CTRL"; + struct { + const char *cert_id; + X509 *cert; + } params; + + params.cert_id = cert_file; + params.cert = NULL; + + /* Does the engine supports LOAD_CERT_CTRL ? */ + if(!ENGINE_ctrl(data->state.engine, ENGINE_CTRL_GET_CMD_FROM_NAME, + 0, CURL_UNCONST(cmd_name), NULL)) { + failf(data, "SSL engine does not support loading certificates"); + return 0; + } + + /* Load the certificate from the engine */ + if(!ENGINE_ctrl_cmd(data->state.engine, cmd_name, 0, ¶ms, NULL, 1)) { + failf(data, "SSL engine cannot load client cert with id '%s' [%s]", + cert_file, + ossl_strerror(ERR_get_error(), error_buffer, + sizeof(error_buffer))); + return 0; + } + + if(!params.cert) { + failf(data, "SSL engine did not initialized the certificate properly."); + return 0; + } + + if(SSL_CTX_use_certificate(ctx, params.cert) != 1) { + failf(data, "unable to set client certificate [%s]", + ossl_strerror(ERR_get_error(), error_buffer, + sizeof(error_buffer))); + X509_free(params.cert); + return 0; + } + X509_free(params.cert); /* we do not need the handle any more... */ + } + else { + failf(data, "crypto engine not set, cannot load certificate"); + return 0; + } + return 1; +#else + (void)ctx; + (void)cert_file; + failf(data, "SSL_FILETYPE_ENGINE not supported for certificate"); + return 0; +#endif +} + +static int providerload(struct Curl_easy *data, + SSL_CTX* ctx, + const char *cert_file) +{ +#ifdef OPENSSL_HAS_PROVIDERS + char error_buffer[256]; + /* Implicitly use pkcs11 provider if none was provided and the + * cert_file is a PKCS#11 URI */ + if(!data->state.provider_loaded) { + if(is_pkcs11_uri(cert_file)) { + if(ossl_set_provider(data, "pkcs11") != CURLE_OK) { + return 0; + } + } + } + + if(data->state.provider_loaded) { + /* Load the certificate from the provider */ + OSSL_STORE_INFO *info = NULL; + X509 *cert = NULL; + OSSL_STORE_CTX *store = + OSSL_STORE_open_ex(cert_file, data->state.libctx, + NULL, NULL, NULL, NULL, NULL, NULL); + int rc; + + if(!store) { + failf(data, "Failed to open OpenSSL store: %s", + ossl_strerror(ERR_get_error(), error_buffer, + sizeof(error_buffer))); + return 0; + } + if(OSSL_STORE_expect(store, OSSL_STORE_INFO_CERT) != 1) { + failf(data, "Failed to set store preference. Ignoring the error: %s", + ossl_strerror(ERR_get_error(), error_buffer, + sizeof(error_buffer))); + } + + info = OSSL_STORE_load(store); + if(info) { + int ossl_type = OSSL_STORE_INFO_get_type(info); + + if(ossl_type == OSSL_STORE_INFO_CERT) + cert = OSSL_STORE_INFO_get1_CERT(info); + OSSL_STORE_INFO_free(info); + } + OSSL_STORE_close(store); + if(!cert) { + failf(data, "No cert found in the openssl store: %s", + ossl_strerror(ERR_get_error(), error_buffer, + sizeof(error_buffer))); + return 0; + } + + rc = SSL_CTX_use_certificate(ctx, cert); + X509_free(cert); /* we do not need the handle any more... */ + + if(rc != 1) { + failf(data, "unable to set client certificate [%s]", + ossl_strerror(ERR_get_error(), error_buffer, + sizeof(error_buffer))); + return 0; + } + } + else { + failf(data, "crypto provider not set, cannot load certificate"); + return 0; + } + return 1; +#else + (void)ctx; + (void)cert_file; + failf(data, "SSL_FILETYPE_PROVIDER not supported for certificate"); + return 0; +#endif +} + +static int pkcs12load(struct Curl_easy *data, + SSL_CTX* ctx, + const struct curl_blob *cert_blob, + const char *cert_file, + const char *key_passwd) +{ + char error_buffer[256]; + BIO *cert_bio = NULL; + PKCS12 *p12 = NULL; + EVP_PKEY *pri; + X509 *x509; + int cert_done = 0; + STACK_OF(X509) *ca = NULL; + if(cert_blob) { + cert_bio = BIO_new_mem_buf(cert_blob->data, (int)(cert_blob->len)); + if(!cert_bio) { + failf(data, "BIO_new_mem_buf NULL, " OSSL_PACKAGE " error %s", + ossl_strerror(ERR_get_error(), error_buffer, + sizeof(error_buffer))); + return 0; + } + } + else { + cert_bio = BIO_new(BIO_s_file()); + if(!cert_bio) { + failf(data, "BIO_new return NULL, " OSSL_PACKAGE " error %s", + ossl_strerror(ERR_get_error(), error_buffer, + sizeof(error_buffer))); + return 0; + } + + if(BIO_read_filename(cert_bio, CURL_UNCONST(cert_file)) <= 0) { + failf(data, "could not open PKCS12 file '%s'", cert_file); + BIO_free(cert_bio); + return 0; + } + } + + p12 = d2i_PKCS12_bio(cert_bio, NULL); + BIO_free(cert_bio); + + if(!p12) { + failf(data, "error reading PKCS12 file '%s'", + cert_blob ? "(memory blob)" : cert_file); + return 0; + } + + if(!PKCS12_parse(p12, key_passwd, &pri, &x509, &ca)) { + failf(data, "could not parse PKCS12 file, check password, " OSSL_PACKAGE + " error %s", + ossl_strerror(ERR_get_error(), error_buffer, sizeof(error_buffer))); + PKCS12_free(p12); + return 0; + } + + PKCS12_free(p12); + + if(SSL_CTX_use_certificate(ctx, x509) != 1) { + failf(data, "could not load PKCS12 client certificate, " OSSL_PACKAGE + " error %s", + ossl_strerror(ERR_get_error(), error_buffer, sizeof(error_buffer))); + goto fail; + } + + if(SSL_CTX_use_PrivateKey(ctx, pri) != 1) { + failf(data, "unable to use private key from PKCS12 file '%s'", cert_file); + goto fail; + } + + if(!SSL_CTX_check_private_key(ctx)) { + failf(data, "private key from PKCS12 file '%s' " + "does not match certificate in same file", cert_file); + goto fail; + } + /* Set Certificate Verification chain */ + if(ca) { + while(sk_X509_num(ca)) { + /* + * Note that sk_X509_pop() is used below to make sure the cert is + * removed from the stack properly before getting passed to + * SSL_CTX_add_extra_chain_cert(), which takes ownership. Previously + * we used sk_X509_value() instead, but then we would clean it in the + * subsequent sk_X509_pop_free() call. + */ + X509 *x = sk_X509_pop(ca); + if(!SSL_CTX_add_client_CA(ctx, x)) { + X509_free(x); + failf(data, "cannot add certificate to client CA list"); + goto fail; + } + if(!SSL_CTX_add_extra_chain_cert(ctx, x)) { + X509_free(x); + failf(data, "cannot add certificate to certificate chain"); + goto fail; + } + } + } + + cert_done = 1; +fail: + EVP_PKEY_free(pri); + X509_free(x509); +#if defined(__clang__) && __clang_major__ >= 16 +#pragma clang diagnostic push +#pragma clang diagnostic ignored "-Wcast-function-type-strict" +#endif + sk_X509_pop_free(ca, X509_free); +#if defined(__clang__) && __clang_major__ >= 16 +#pragma clang diagnostic pop +#endif + if(!cert_done) + return 0; /* failure! */ + return 1; +} + +static CURLcode client_cert(struct Curl_easy *data, + SSL_CTX* ctx, + char *cert_file, + const struct curl_blob *cert_blob, + const char *cert_type, + char *key_file, + const struct curl_blob *key_blob, + const char *key_type, + char *key_passwd) +{ + char error_buffer[256]; + bool check_privkey = TRUE; + int file_type = ossl_do_file_type(cert_type); + + if(cert_file || cert_blob || (file_type == SSL_FILETYPE_ENGINE) || + (file_type == SSL_FILETYPE_PROVIDER)) { + SSL *ssl; + X509 *x509; + bool pcks12_done = FALSE; + int cert_use_result; + + if(key_passwd) { + /* set the password in the callback userdata */ + SSL_CTX_set_default_passwd_cb_userdata(ctx, key_passwd); + /* Set passwd callback: */ + SSL_CTX_set_default_passwd_cb(ctx, passwd_callback); + } + + switch(file_type) { + case SSL_FILETYPE_PEM: + /* SSL_CTX_use_certificate_chain_file() only works on PEM files */ + cert_use_result = cert_blob ? + use_certificate_chain_blob(ctx, cert_blob, key_passwd) : + SSL_CTX_use_certificate_chain_file(ctx, cert_file); + if(cert_use_result != 1) { + failf(data, + "could not load PEM client certificate from %s, " OSSL_PACKAGE + " error %s, " + "(no key found, wrong passphrase, or wrong file format?)", + (cert_blob ? "CURLOPT_SSLCERT_BLOB" : cert_file), + ossl_strerror(ERR_get_error(), error_buffer, + sizeof(error_buffer))); + return CURLE_SSL_CERTPROBLEM; + } + break; + + case SSL_FILETYPE_ASN1: + /* SSL_CTX_use_certificate_file() works with either PEM or ASN1, but + we use the case above for PEM so this can only be performed with + ASN1 files. */ + + cert_use_result = cert_blob ? + use_certificate_blob(ctx, cert_blob, file_type, key_passwd) : + SSL_CTX_use_certificate_file(ctx, cert_file, file_type); + if(cert_use_result != 1) { + failf(data, + "could not load ASN1 client certificate from %s, " OSSL_PACKAGE + " error %s, " + "(no key found, wrong passphrase, or wrong file format?)", + (cert_blob ? "CURLOPT_SSLCERT_BLOB" : cert_file), + ossl_strerror(ERR_get_error(), error_buffer, + sizeof(error_buffer))); + return CURLE_SSL_CERTPROBLEM; + } + break; + + case SSL_FILETYPE_ENGINE: + if(!cert_file || !engineload(data, ctx, cert_file)) + return CURLE_SSL_CERTPROBLEM; + break; + + case SSL_FILETYPE_PROVIDER: + if(!cert_file || !providerload(data, ctx, cert_file)) + return CURLE_SSL_CERTPROBLEM; + break; + + case SSL_FILETYPE_PKCS12: + if(!pkcs12load(data, ctx, cert_blob, cert_file, key_passwd)) + return CURLE_SSL_CERTPROBLEM; + pcks12_done = TRUE; + break; + + default: + failf(data, "not supported file type '%s' for certificate", cert_type); + return CURLE_BAD_FUNCTION_ARGUMENT; + } + + if(!key_file && !key_blob) { + key_file = cert_file; + key_blob = cert_blob; + } + else + file_type = ossl_do_file_type(key_type); + + switch(file_type) { + case SSL_FILETYPE_PEM: + case SSL_FILETYPE_ASN1: + cert_use_result = key_blob ? + use_privatekey_blob(ctx, key_blob, file_type, key_passwd) : + SSL_CTX_use_PrivateKey_file(ctx, key_file, file_type); + if(cert_use_result != 1) { + failf(data, "unable to set private key file: '%s' type %s", + key_file ? key_file : "(memory blob)", + key_type ? key_type : "PEM"); + return CURLE_BAD_FUNCTION_ARGUMENT; + } + break; + case SSL_FILETYPE_ENGINE: + if(!enginecheck(data, ctx, key_file, key_passwd)) + return CURLE_SSL_CERTPROBLEM; + break; + + case SSL_FILETYPE_PROVIDER: + if(!providercheck(data, ctx, key_file)) + return CURLE_SSL_CERTPROBLEM; + break; + + case SSL_FILETYPE_PKCS12: + if(!pcks12_done) { + failf(data, "file type P12 for private key not supported"); + return CURLE_SSL_CERTPROBLEM; + } + break; + default: + failf(data, "not supported file type for private key"); + return CURLE_BAD_FUNCTION_ARGUMENT; + } + + ssl = SSL_new(ctx); + if(!ssl) { + failf(data, "unable to create an SSL structure"); + return CURLE_OUT_OF_MEMORY; + } + + x509 = SSL_get_certificate(ssl); + + if(x509) { + EVP_PKEY *pktmp = X509_get_pubkey(x509); + EVP_PKEY_copy_parameters(pktmp, SSL_get_privatekey(ssl)); + EVP_PKEY_free(pktmp); + } + +#if !defined(OPENSSL_NO_RSA) && !defined(OPENSSL_NO_DEPRECATED_3_0) + { + /* If RSA is used, do not check the private key if its flags indicate + * it does not support it. */ + EVP_PKEY *priv_key = SSL_get_privatekey(ssl); + if(EVP_PKEY_id(priv_key) == EVP_PKEY_RSA) { + RSA *rsa = EVP_PKEY_get1_RSA(priv_key); + if(RSA_flags(rsa) & RSA_METHOD_FLAG_NO_CHECK) + check_privkey = FALSE; + RSA_free(rsa); /* Decrement reference count */ + } + } +#endif + + SSL_free(ssl); + + /* If we are using DSA, we can copy the parameters from + * the private key */ + + if(check_privkey == TRUE) { + /* Now we know that a key and cert have been set against + * the SSL context */ + if(!SSL_CTX_check_private_key(ctx)) { + failf(data, "Private key does not match the certificate public key"); + return CURLE_SSL_CERTPROBLEM; + } + } + } + return CURLE_OK; +} + +#ifdef CURLVERBOSE +/* returns non-zero on failure */ +static CURLcode x509_name_oneline(const X509_NAME *a, struct dynbuf *d) +{ + BIO *bio_out = BIO_new(BIO_s_mem()); + BUF_MEM *biomem; + int rc; + CURLcode result = CURLE_OUT_OF_MEMORY; + + if(bio_out) { + unsigned long flags = XN_FLAG_SEP_SPLUS_SPC | + (XN_FLAG_ONELINE & ~ASN1_STRFLGS_ESC_MSB & ~XN_FLAG_SPC_EQ); + curlx_dyn_reset(d); + rc = X509_NAME_print_ex(bio_out, a, 0, flags); + if(rc != -1) { + BIO_get_mem_ptr(bio_out, &biomem); + result = curlx_dyn_addn(d, biomem->data, biomem->length); + } + BIO_free(bio_out); + } + return result; +} +#endif + +/** + * Global SSL init + * + * @retval 0 error initializing SSL + * @retval 1 SSL initialized successfully + */ +static int ossl_init(void) +{ + const uint64_t flags = +#ifdef OPENSSL_INIT_ENGINE_ALL_BUILTIN + /* not present in BoringSSL */ + OPENSSL_INIT_ENGINE_ALL_BUILTIN | +#endif +#ifdef CURL_DISABLE_OPENSSL_AUTO_LOAD_CONFIG + OPENSSL_INIT_NO_LOAD_CONFIG | +#else + OPENSSL_INIT_LOAD_CONFIG | +#endif + 0; + OPENSSL_init_ssl(flags, NULL); + +#ifndef HAVE_KEYLOG_UPSTREAM + Curl_tls_keylog_open(); +#endif + + return 1; +} + +/* Global cleanup */ +static void ossl_cleanup(void) +{ +#ifndef HAVE_KEYLOG_UPSTREAM + Curl_tls_keylog_close(); +#endif +} + +/* Selects an OpenSSL crypto engine or provider. + */ +static CURLcode ossl_set_engine(struct Curl_easy *data, const char *name) +{ +#ifdef USE_OPENSSL_ENGINE + CURLcode result = CURLE_SSL_ENGINE_NOTFOUND; + ENGINE *e = ENGINE_by_id(name); + + if(e) { + + if(data->state.engine) { + ENGINE_finish(data->state.engine); + ENGINE_free(data->state.engine); + data->state.engine = NULL; + } + if(!ENGINE_init(e)) { + char buf[256]; + + ENGINE_free(e); + failf(data, "Failed to initialize SSL Engine '%s': %s", + name, ossl_strerror(ERR_get_error(), buf, sizeof(buf))); + result = CURLE_SSL_ENGINE_INITFAILED; + e = NULL; + } + else { + result = CURLE_OK; + } + data->state.engine = e; + return result; + } +#endif +#ifdef OPENSSL_HAS_PROVIDERS + return ossl_set_provider(data, name); +#else + (void)name; + failf(data, "OpenSSL engine not found"); + return CURLE_SSL_ENGINE_NOTFOUND; +#endif +} + +/* Sets engine as default for all SSL operations + */ +static CURLcode ossl_set_engine_default(struct Curl_easy *data) +{ +#ifdef USE_OPENSSL_ENGINE + if(data->state.engine) { + if(ENGINE_set_default(data->state.engine, ENGINE_METHOD_ALL) > 0) { + infof(data, "set default crypto engine '%s'", + ENGINE_get_id(data->state.engine)); + } + else { + failf(data, "set default crypto engine '%s' failed", + ENGINE_get_id(data->state.engine)); + return CURLE_SSL_ENGINE_SETFAILED; + } + } +#else + (void)data; +#endif + return CURLE_OK; +} + +/* Return list of OpenSSL crypto engine names. + */ +static struct curl_slist *ossl_engines_list(struct Curl_easy *data) +{ + struct curl_slist *list = NULL; +#ifdef USE_OPENSSL_ENGINE + struct curl_slist *beg; + ENGINE *e; + + for(e = ENGINE_get_first(); e; e = ENGINE_get_next(e)) { + beg = curl_slist_append(list, ENGINE_get_id(e)); + if(!beg) { + curl_slist_free_all(list); + return NULL; + } + list = beg; + } +#endif + (void)data; + return list; +} + +#ifdef OPENSSL_HAS_PROVIDERS + +static void ossl_provider_cleanup(struct Curl_easy *data) +{ + if(data->state.baseprov) { + OSSL_PROVIDER_unload(data->state.baseprov); + data->state.baseprov = NULL; + } + if(data->state.provider) { + OSSL_PROVIDER_unload(data->state.provider); + data->state.provider = NULL; + } + OSSL_LIB_CTX_free(data->state.libctx); + data->state.libctx = NULL; + curlx_safefree(data->state.propq); + data->state.provider_loaded = FALSE; +} + +#define MAX_PROVIDER_LEN 128 /* reasonable */ + +/* Selects an OpenSSL crypto provider. + * + * A provider might need an associated property, a string passed on to + * OpenSSL. Specify this as [PROVIDER][:PROPERTY]: separate the name and the + * property with a colon. No colon means no property is set. + * + * An example provider + property looks like "tpm2:?provider=tpm2". + */ +static CURLcode ossl_set_provider(struct Curl_easy *data, const char *iname) +{ + char name[MAX_PROVIDER_LEN + 1]; + struct Curl_str prov; + const char *propq = NULL; + + if(!iname) { + /* clear and cleanup provider use */ + ossl_provider_cleanup(data); + return CURLE_OK; + } + if(curlx_str_until(&iname, &prov, MAX_PROVIDER_LEN, ':')) + return CURLE_BAD_FUNCTION_ARGUMENT; + + if(!curlx_str_single(&iname, ':')) + /* there was a colon, get the propq until the end of string */ + propq = iname; + + /* we need the name in a buffer, null-terminated */ + memcpy(name, curlx_str(&prov), curlx_strlen(&prov)); + name[curlx_strlen(&prov)] = 0; + + if(!data->state.libctx) { + OSSL_LIB_CTX *libctx = OSSL_LIB_CTX_new(); + if(!libctx) + return CURLE_OUT_OF_MEMORY; + if(propq) { + data->state.propq = curlx_strdup(propq); + if(!data->state.propq) { + OSSL_LIB_CTX_free(libctx); + return CURLE_OUT_OF_MEMORY; + } + } + data->state.libctx = libctx; + } + +#ifndef CURL_DISABLE_OPENSSL_AUTO_LOAD_CONFIG + /* load the configuration file into the library context before checking the + * provider availability */ + if(!OSSL_LIB_CTX_load_config(data->state.libctx, NULL)) { + infof(data, "Failed to load default openssl config. Proceeding."); + } +#endif + + if(OSSL_PROVIDER_available(data->state.libctx, name)) { + /* already loaded through the configuration - no action needed */ + data->state.provider_loaded = TRUE; + return CURLE_OK; + } + + data->state.provider = OSSL_PROVIDER_try_load(data->state.libctx, name, 1); + if(!data->state.provider) { + char error_buffer[256]; + failf(data, "Failed to initialize provider: %s", + ossl_strerror(ERR_get_error(), error_buffer, sizeof(error_buffer))); + ossl_provider_cleanup(data); + return CURLE_SSL_ENGINE_NOTFOUND; + } + + /* load the base provider as well */ + data->state.baseprov = OSSL_PROVIDER_try_load(data->state.libctx, "base", 1); + if(!data->state.baseprov) { + ossl_provider_cleanup(data); + failf(data, "Failed to load base"); + return CURLE_SSL_ENGINE_NOTFOUND; + } + else + data->state.provider_loaded = TRUE; + return CURLE_OK; +} +#endif + +static CURLcode ossl_shutdown(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool send_shutdown, bool *done) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct ossl_ctx *octx = (struct ossl_ctx *)connssl->backend; + CURLcode result = CURLE_OK; + char buf[1024]; + int nread = -1, err; + size_t i; + + DEBUGASSERT(octx); + if(!octx->ssl || cf->shutdown) { + *done = TRUE; + goto out; + } + + connssl->io_need = CURL_SSL_IO_NEED_NONE; + *done = FALSE; + if(!(SSL_get_shutdown(octx->ssl) & SSL_SENT_SHUTDOWN)) { + /* We have not started the shutdown from our side yet. Check + * if the server already sent us one. */ + ERR_clear_error(); + for(i = 0; i < 10; ++i) { + nread = SSL_read(octx->ssl, buf, (int)sizeof(buf)); + CURL_TRC_CF(data, cf, "SSL shutdown not sent, read -> %d", nread); + if(nread <= 0) + break; + } + err = SSL_get_error(octx->ssl, nread); + if(!nread && err == SSL_ERROR_ZERO_RETURN) { + bool input_pending; + /* Yes, it did. */ + if(!send_shutdown) { + CURL_TRC_CF(data, cf, "SSL shutdown received, not sending"); + *done = TRUE; + goto out; + } + else if(!cf->next->cft->is_alive(cf->next, data, &input_pending)) { + /* Server closed the connection after its closy notify. It + * seems not interested to see our close notify, so do not + * send it. We are done. */ + connssl->peer_closed = TRUE; + CURL_TRC_CF(data, cf, "peer closed connection"); + *done = TRUE; + goto out; + } + } + } + + /* SSL should now have started the shutdown from our side. Since it + * was not complete, we are lacking the close notify from the server. */ + if(send_shutdown && !(SSL_get_shutdown(octx->ssl) & SSL_SENT_SHUTDOWN)) { + int rc; + ERR_clear_error(); + CURL_TRC_CF(data, cf, "send SSL close notify"); + rc = SSL_shutdown(octx->ssl); + if(rc == 1) { + CURL_TRC_CF(data, cf, "SSL shutdown finished"); + *done = TRUE; + goto out; + } + if(SSL_ERROR_WANT_WRITE == SSL_get_error(octx->ssl, rc)) { + CURL_TRC_CF(data, cf, "SSL shutdown still wants to send"); + connssl->io_need = CURL_SSL_IO_NEED_SEND; + goto out; + } + /* Having sent the close notify, we use SSL_read() to get the + * missing close notify from the server. */ + } + + for(i = 0; i < 10; ++i) { + ERR_clear_error(); + nread = SSL_read(octx->ssl, buf, (int)sizeof(buf)); + CURL_TRC_CF(data, cf, "SSL shutdown read -> %d", nread); + if(nread <= 0) + break; + } + err = SSL_get_error(octx->ssl, nread); + switch(err) { + case SSL_ERROR_ZERO_RETURN: /* no more data */ + if(SSL_shutdown(octx->ssl) == 1) + CURL_TRC_CF(data, cf, "SSL shutdown finished"); + else + CURL_TRC_CF(data, cf, "SSL shutdown not received, but closed"); + *done = TRUE; + break; + case SSL_ERROR_NONE: /* did not get anything */ + case SSL_ERROR_WANT_READ: + /* SSL has send its notify and now wants to read the reply + * from the server. We are not really interested in that. */ + CURL_TRC_CF(data, cf, "SSL shutdown sent, want receive"); + connssl->io_need = CURL_SSL_IO_NEED_RECV; + break; + case SSL_ERROR_WANT_WRITE: + CURL_TRC_CF(data, cf, "SSL shutdown send blocked"); + connssl->io_need = CURL_SSL_IO_NEED_SEND; + break; + default: + /* Server seems to have closed the connection without sending us + * a close notify. */ + { + VERBOSE(unsigned long sslerr = ERR_get_error()); + CURL_TRC_CF(data, cf, "SSL shutdown, ignore recv error: '%s', errno %d", + (sslerr ? + ossl_strerror(sslerr, buf, sizeof(buf)) : + SSL_ERROR_to_str(err)), + SOCKERRNO); + } + *done = TRUE; + result = CURLE_OK; + break; + } + +out: + cf->shutdown = (result || *done); + if(cf->shutdown || (connssl->io_need != CURL_SSL_IO_NEED_NONE)) + connssl->input_pending = FALSE; + return result; +} + +static void ossl_close(struct Curl_cfilter *cf, struct Curl_easy *data) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct ossl_ctx *octx = (struct ossl_ctx *)connssl->backend; + + (void)data; + DEBUGASSERT(octx); + + connssl->input_pending = FALSE; + if(octx->ssl) { + SSL_free(octx->ssl); + octx->ssl = NULL; + } + if(octx->ssl_ctx) { + SSL_CTX_free(octx->ssl_ctx); + octx->ssl_ctx = NULL; + octx->x509_store_setup = FALSE; + } + if(octx->bio_method) { + ossl_bio_cf_method_free(octx->bio_method); + octx->bio_method = NULL; + } +} + +/* + * This function is called when the 'data' struct is going away. Close + * down everything and free all resources! + */ +static void ossl_close_all(struct Curl_easy *data) +{ +#ifdef USE_OPENSSL_ENGINE + if(data->state.engine) { + ENGINE_finish(data->state.engine); + ENGINE_free(data->state.engine); + data->state.engine = NULL; + } +#else + (void)data; +#endif +#ifdef OPENSSL_HAS_PROVIDERS + ossl_provider_cleanup(data); +#endif +} + +/* ====================================================== */ + +/* Quote from RFC2818 section 3.1 "Server Identity" + + If a subjectAltName extension of type dNSName is present, that MUST + be used as the identity. Otherwise, the (most specific) Common Name + field in the Subject field of the certificate MUST be used. Although + the use of the Common Name is existing practice, it is deprecated and + Certification Authorities are encouraged to use the dNSName instead. + + Matching is performed using the matching rules specified by + [RFC2459]. If more than one identity of a given type is present in + the certificate (e.g., more than one dNSName name, a match in any one + of the set is considered acceptable.) Names may contain the wildcard + character * which is considered to match any single domain name + component or component fragment. E.g., *.a.com matches foo.a.com but + not bar.foo.a.com. f*.com matches foo.com but not bar.com. + + In some cases, the URI is specified as an IP address rather than a + hostname. In this case, the iPAddress subjectAltName must be present + in the certificate and must exactly match the IP in the URI. + + This function is now used from ngtcp2 (QUIC) as well. +*/ +static CURLcode ossl_verifyhost(struct Curl_easy *data, + struct connectdata *conn, + struct ssl_peer *peer, + X509 *server_cert) +{ + bool matched = FALSE; + int target; /* target type, GEN_DNS or GEN_IPADD */ + size_t addrlen = 0; + STACK_OF(GENERAL_NAME) *altnames; +#ifdef USE_IPV6 + struct in6_addr addr; +#else + struct in_addr addr; +#endif + CURLcode result = CURLE_OK; + bool dNSName = FALSE; /* if a dNSName field exists in the cert */ + bool iPAddress = FALSE; /* if an iPAddress field exists in the cert */ + size_t hostlen = strlen(peer->origin->hostname); + + (void)conn; + switch(peer->type) { + case CURL_SSL_PEER_IPV4: + if(!curlx_inet_pton(AF_INET, peer->origin->hostname, &addr)) + return CURLE_PEER_FAILED_VERIFICATION; + target = GEN_IPADD; + addrlen = sizeof(struct in_addr); + break; +#ifdef USE_IPV6 + case CURL_SSL_PEER_IPV6: + if(!curlx_inet_pton(AF_INET6, peer->origin->hostname, &addr)) + return CURLE_PEER_FAILED_VERIFICATION; + target = GEN_IPADD; + addrlen = sizeof(struct in6_addr); + break; +#endif + case CURL_SSL_PEER_DNS: + target = GEN_DNS; + break; + default: + DEBUGASSERT(0); + failf(data, "unexpected SSL peer type: %d", (int)peer->type); + return CURLE_PEER_FAILED_VERIFICATION; + } + + /* get a "list" of alternative names */ + altnames = X509_get_ext_d2i(server_cert, NID_subject_alt_name, NULL, NULL); + + if(altnames) { +#ifdef HAVE_BORINGSSL_LIKE + size_t numalts; + size_t i; +#else + int numalts; + int i; +#endif + + /* get amount of alternatives, RFC2459 claims there MUST be at least + one, but we do not depend on it... */ + numalts = sk_GENERAL_NAME_num(altnames); + + /* loop through all alternatives - until a dnsmatch */ + for(i = 0; (i < numalts) && !matched; i++) { + /* get a handle to alternative name number i */ + const GENERAL_NAME *check = sk_GENERAL_NAME_value(altnames, i); + + if(check->type == GEN_DNS) + dNSName = TRUE; + else if(check->type == GEN_IPADD) + iPAddress = TRUE; + + /* only check alternatives of the same type the target is */ + if(check->type == target) { + /* get data and length */ + const char *altptr = (const char *)ASN1_STRING_get0_data(check->d.ia5); + size_t altlen = (size_t)ASN1_STRING_length(check->d.ia5); + + switch(target) { + case GEN_DNS: /* name/pattern comparison */ + /* The OpenSSL man page explicitly says: "In general it cannot be + assumed that the data returned by ASN1_STRING_data() is null + terminated or does not contain embedded nulls.", but also that + "The actual format of the data depends on the actual string + type itself: for example for an IA5String the data is ASCII" + + It has been however verified that in 0.9.6 and 0.9.7, IA5String + is always null-terminated. + */ + if((altlen == strlen(altptr)) && + /* if this is not true, there was an embedded zero in the name + string and we cannot match it. */ + Curl_cert_hostcheck(altptr, altlen, + peer->origin->hostname, hostlen)) { + matched = TRUE; + infof(data, " subjectAltName: \"%s\" matches cert's \"%.*s\"", + peer->origin->user_hostname, (int)altlen, altptr); + } + break; + + case GEN_IPADD: /* IP address comparison */ + /* compare alternative IP address if the data chunk is the same size + our server IP address is */ + if((altlen == addrlen) && !memcmp(altptr, &addr, altlen)) { + matched = TRUE; + infof(data, " subjectAltName: \"%s\" matches cert's IP address!", + peer->origin->user_hostname); + } + break; + } + } + } + GENERAL_NAMES_free(altnames); + } + + if(matched) + /* an alternative name matched */ + ; + else if(dNSName || iPAddress) { + const char *tname = (peer->type == CURL_SSL_PEER_DNS) ? "hostname" : + (peer->type == CURL_SSL_PEER_IPV4) ? + "ipv4 address" : "ipv6 address"; + infof(data, " subjectAltName does not match %s %s", tname, + peer->origin->user_hostname); + failf(data, "SSL: no alternative certificate subject name matches " + "target %s '%s'", tname, peer->origin->user_hostname); + result = CURLE_PEER_FAILED_VERIFICATION; + } + else { + /* we have to look to the last occurrence of a commonName in the + distinguished one to get the most significant one. */ + int i = -1; + unsigned char *cn = NULL; + int cnlen = 0; + bool free_cn = FALSE; + + /* The following is done because of a bug in 0.9.6b */ + const X509_NAME *name = X509_get_subject_name(server_cert); + if(name) { + int j; + while((j = X509_NAME_get_index_by_NID(name, NID_commonName, i)) >= 0) + i = j; + } + + /* we have the name entry and we now convert this to a string + that we can use for comparison. Doing this we support BMPstring, + UTF8, etc. */ + + if(i >= 0) { + const ASN1_STRING *tmp = + X509_NAME_ENTRY_get_data(X509_NAME_get_entry(name, i)); + + /* In OpenSSL 0.9.7d and earlier, ASN1_STRING_to_UTF8 fails if the input + is already UTF-8 encoded. We check for this case and copy the raw + string manually to avoid the problem. This code can be made + conditional in the future when OpenSSL has been fixed. */ + if(tmp) { + if(ASN1_STRING_type(tmp) == V_ASN1_UTF8STRING) { + cnlen = ASN1_STRING_length(tmp); + cn = (unsigned char *)CURL_UNCONST(ASN1_STRING_get0_data(tmp)); + } + else { /* not a UTF8 name */ + cnlen = ASN1_STRING_to_UTF8(&cn, tmp); + free_cn = TRUE; + } + + if((cnlen <= 0) || !cn) + result = CURLE_OUT_OF_MEMORY; + else if((size_t)cnlen != strlen((char *)cn)) { + /* there was a null-terminator before the end of string, this + cannot match and we return failure! */ + failf(data, "SSL: illegal cert name field"); + result = CURLE_PEER_FAILED_VERIFICATION; + } + } + } + + if(result) + /* error already detected, pass through */ + ; + else if(!cn) { + failf(data, "SSL: unable to obtain common name from peer certificate"); + result = CURLE_PEER_FAILED_VERIFICATION; + } + else if(!Curl_cert_hostcheck((const char *)cn, cnlen, + peer->origin->hostname, hostlen)) { + failf(data, "SSL: certificate subject name '%s' does not match " + "target hostname '%s'", cn, peer->origin->user_hostname); + result = CURLE_PEER_FAILED_VERIFICATION; + } + else { + infof(data, " common name: %s (matched)", cn); + } + if(free_cn) + OPENSSL_free(cn); + } + + return result; +} + +#ifndef OPENSSL_NO_OCSP +static CURLcode verifystatus(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct ossl_ctx *octx) +{ + int i, ocsp_status; +#ifdef HAVE_BORINGSSL_LIKE + const uint8_t *status; +#else + unsigned char *status; +#endif + const unsigned char *p; + CURLcode result = CURLE_OK; + OCSP_RESPONSE *rsp = NULL; + OCSP_BASICRESP *br = NULL; + X509_STORE *st = NULL; + STACK_OF(X509) *ch = NULL; + X509 *cert; + OCSP_CERTID *id = NULL; + int cert_status, crl_reason; + ASN1_GENERALIZEDTIME *rev, *thisupd, *nextupd; + int ret; + long len; + + (void)cf; + DEBUGASSERT(octx); + + len = (long)SSL_get_tlsext_status_ocsp_resp(octx->ssl, &status); + + if(!status) { + failf(data, "No OCSP response received"); + result = CURLE_SSL_INVALIDCERTSTATUS; + goto end; + } + p = status; + rsp = d2i_OCSP_RESPONSE(NULL, &p, len); + if(!rsp) { + failf(data, "Invalid OCSP response"); + result = CURLE_SSL_INVALIDCERTSTATUS; + goto end; + } + + ocsp_status = OCSP_response_status(rsp); + if(ocsp_status != OCSP_RESPONSE_STATUS_SUCCESSFUL) { + failf(data, "Invalid OCSP response status: %s (%d)", + OCSP_response_status_str(ocsp_status), ocsp_status); + result = CURLE_SSL_INVALIDCERTSTATUS; + goto end; + } + + br = OCSP_response_get1_basic(rsp); + if(!br) { + failf(data, "Invalid OCSP response"); + result = CURLE_SSL_INVALIDCERTSTATUS; + goto end; + } + + ch = SSL_get_peer_cert_chain(octx->ssl); + if(!ch) { + failf(data, "Could not get peer certificate chain"); + result = CURLE_SSL_INVALIDCERTSTATUS; + goto end; + } + st = SSL_CTX_get_cert_store(octx->ssl_ctx); + + if(OCSP_basic_verify(br, ch, st, 0) <= 0) { + failf(data, "OCSP response verification failed"); + result = CURLE_SSL_INVALIDCERTSTATUS; + goto end; + } + + /* Compute the certificate's ID */ + cert = SSL_get1_peer_certificate(octx->ssl); + if(!cert) { + failf(data, "Error getting peer certificate"); + result = CURLE_SSL_INVALIDCERTSTATUS; + goto end; + } + + for(i = 0; i < (int)sk_X509_num(ch); i++) { + X509 *issuer = sk_X509_value(ch, (ossl_valsize_t)i); + if(X509_check_issued(issuer, cert) == X509_V_OK) { + /* Note to analysis tools: using SHA1 here is fine. The `id` + * generated is used as a hash lookup key, not as a verifier + * of the OCSP data itself. This all according to RFC 5019. */ + id = OCSP_cert_to_id(EVP_sha1(), cert, issuer); + break; + } + } + X509_free(cert); + + if(!id) { + failf(data, "Error computing OCSP ID"); + result = CURLE_SSL_INVALIDCERTSTATUS; + goto end; + } + + /* Find the single OCSP response corresponding to the certificate ID */ + ret = OCSP_resp_find_status(br, id, &cert_status, &crl_reason, &rev, + &thisupd, &nextupd); + OCSP_CERTID_free(id); + if(ret != 1) { + failf(data, "Could not find certificate ID in OCSP response"); + result = CURLE_SSL_INVALIDCERTSTATUS; + goto end; + } + + /* Validate the OCSP response issuing and update times. + * - `thisupd` is the time the OCSP response was issued + * - `nextupd` is the time the OCSP response should be updated + * (valid life time assigned by the OCSP responder) + * - 3rd param: how many seconds of clock skew we allow between + * our clock and the instance that issued the OCSP response + * - 4th param: how many seconds in the past `thisupd` may be, with + * -1 meaning there is no limit. */ + if(!OCSP_check_validity(thisupd, nextupd, 300L, -1L)) { + failf(data, "OCSP response has expired"); + result = CURLE_SSL_INVALIDCERTSTATUS; + goto end; + } + + infof(data, "SSL certificate status: %s (%d)", + OCSP_cert_status_str(cert_status), cert_status); + + switch(cert_status) { + case V_OCSP_CERTSTATUS_GOOD: + break; + + case V_OCSP_CERTSTATUS_REVOKED: + result = CURLE_SSL_INVALIDCERTSTATUS; + failf(data, "SSL certificate revocation reason: %s (%d)", + OCSP_crl_reason_str(crl_reason), crl_reason); + goto end; + + case V_OCSP_CERTSTATUS_UNKNOWN: + default: + result = CURLE_SSL_INVALIDCERTSTATUS; + goto end; + } + +end: + if(br) + OCSP_BASICRESP_free(br); + OCSP_RESPONSE_free(rsp); + + return result; +} +#endif + +static const char *ssl_msg_type(int ssl_ver, int msg) +{ + if(ssl_ver == SSL3_VERSION_MAJOR) { + switch(msg) { + case SSL3_MT_HELLO_REQUEST: + return "Hello request"; + case SSL3_MT_CLIENT_HELLO: + return "Client hello"; + case SSL3_MT_SERVER_HELLO: + return "Server hello"; +#ifdef SSL3_MT_NEWSESSION_TICKET + case SSL3_MT_NEWSESSION_TICKET: + return "Newsession Ticket"; +#endif + case SSL3_MT_CERTIFICATE: + return "Certificate"; + case SSL3_MT_SERVER_KEY_EXCHANGE: + return "Server key exchange"; + case SSL3_MT_CLIENT_KEY_EXCHANGE: + return "Client key exchange"; + case SSL3_MT_CERTIFICATE_REQUEST: + return "Request CERT"; + case SSL3_MT_SERVER_DONE: + return "Server finished"; + case SSL3_MT_CERTIFICATE_VERIFY: + return "CERT verify"; + case SSL3_MT_FINISHED: + return "Finished"; +#ifdef SSL3_MT_CERTIFICATE_STATUS + case SSL3_MT_CERTIFICATE_STATUS: + return "Certificate Status"; +#endif +#ifdef SSL3_MT_ENCRYPTED_EXTENSIONS + case SSL3_MT_ENCRYPTED_EXTENSIONS: + return "Encrypted Extensions"; +#endif +#ifdef SSL3_MT_SUPPLEMENTAL_DATA + case SSL3_MT_SUPPLEMENTAL_DATA: + return "Supplemental data"; +#endif +#ifdef SSL3_MT_END_OF_EARLY_DATA + case SSL3_MT_END_OF_EARLY_DATA: + return "End of early data"; +#endif +#ifdef SSL3_MT_KEY_UPDATE + case SSL3_MT_KEY_UPDATE: + return "Key update"; +#endif +#ifdef SSL3_MT_NEXT_PROTO + case SSL3_MT_NEXT_PROTO: + return "Next protocol"; +#endif +#ifdef SSL3_MT_MESSAGE_HASH + case SSL3_MT_MESSAGE_HASH: + return "Message hash"; +#endif + } + } + return "Unknown"; +} + +static const char *tls_rt_type(int type) +{ + switch(type) { +#ifdef SSL3_RT_HEADER + case SSL3_RT_HEADER: + return "TLS header"; +#endif + case SSL3_RT_CHANGE_CIPHER_SPEC: + return "TLS change cipher"; + case SSL3_RT_ALERT: + return "TLS alert"; + case SSL3_RT_HANDSHAKE: + return "TLS handshake"; + case SSL3_RT_APPLICATION_DATA: + return "TLS app data"; + default: + return "TLS Unknown"; + } +} + +/* + * Our callback from the SSL/TLS layers. + */ +static void ossl_trace(int direction, int ssl_ver, int content_type, + const void *buf, size_t len, SSL *ssl, + void *userp) +{ + const char *verstr; + struct Curl_cfilter *cf = userp; + struct Curl_easy *data = NULL; + char unknown[32]; + + if(!cf) + return; + data = CF_DATA_CURRENT(cf); + if(!data || !data->set.fdebug || (direction && direction != 1)) + return; + + switch(ssl_ver) { +#ifdef SSL3_VERSION + case SSL3_VERSION: + verstr = "SSLv3"; + break; +#endif + case TLS1_VERSION: + verstr = "TLSv1.0"; + break; +#ifdef TLS1_1_VERSION + case TLS1_1_VERSION: + verstr = "TLSv1.1"; + break; +#endif +#ifdef TLS1_2_VERSION + case TLS1_2_VERSION: + verstr = "TLSv1.2"; + break; +#endif + case TLS1_3_VERSION: + verstr = "TLSv1.3"; + break; + default: + curl_msnprintf(unknown, sizeof(unknown), "(%x)", (unsigned int)ssl_ver); + verstr = unknown; + break; + } + + /* Log progress for interesting records only (like Handshake or Alert), skip + * all raw record headers (content_type == SSL3_RT_HEADER or ssl_ver == 0). + * For TLS 1.3, skip notification of the decrypted inner Content-Type. + */ + if(ssl_ver +#ifdef SSL3_RT_HEADER + && content_type != SSL3_RT_HEADER +#endif +#ifdef SSL3_RT_INNER_CONTENT_TYPE + && content_type != SSL3_RT_INNER_CONTENT_TYPE +#endif + ) { + const char *msg_name = "Truncated message"; + const char *tls_rt_name; + char ssl_buf[1024]; + int msg_type = 0; + int txt_len; + + /* the info given when the version is zero is not that useful for us */ + + ssl_ver >>= 8; /* check the upper 8 bits only below */ + + /* SSLv2 does not seem to have TLS record-type headers, so OpenSSL + * always pass-up content-type as 0, but the interesting message-type + * is at 'buf[0]'. + */ + if(ssl_ver == SSL3_VERSION_MAJOR && content_type) + tls_rt_name = tls_rt_type(content_type); + else + tls_rt_name = ""; + + if(content_type == SSL3_RT_CHANGE_CIPHER_SPEC) { + if(len) { + msg_type = *(const unsigned char *)buf; + msg_name = "Change cipher spec"; + } + } + else if(content_type == SSL3_RT_ALERT) { + if(len >= 2) { + msg_type = + (((const unsigned char *)buf)[0] << 8) + + ((const unsigned char *)buf)[1]; + msg_name = SSL_alert_desc_string_long(msg_type); + } + } + else if(len) { + msg_type = *(const unsigned char *)buf; + msg_name = ssl_msg_type(ssl_ver, msg_type); + } + + txt_len = curl_msnprintf(ssl_buf, sizeof(ssl_buf), + "%s (%s), %s, %s (%d):\n", + verstr, direction ? "OUT" : "IN", + tls_rt_name, msg_name, msg_type); + Curl_debug(data, CURLINFO_TEXT, ssl_buf, (size_t)txt_len); + } + + Curl_debug(data, (direction == 1) ? CURLINFO_SSL_DATA_OUT : + CURLINFO_SSL_DATA_IN, (const char *)buf, len); + (void)ssl; +} + +static CURLcode ossl_set_ssl_version_min_max(struct Curl_cfilter *cf, + SSL_CTX *ctx, + unsigned int ssl_version_min) +{ + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + /* first, TLS min version... */ + long curl_ssl_version_min = (long)ssl_version_min; + long curl_ssl_version_max; + + /* convert curl min SSL version option to OpenSSL constant */ +#if defined(HAVE_BORINGSSL_LIKE) || defined(LIBRESSL_VERSION_NUMBER) + uint16_t ossl_ssl_version_min = 0; + uint16_t ossl_ssl_version_max = 0; +#else + long ossl_ssl_version_min = 0; + long ossl_ssl_version_max = 0; +#endif + /* it cannot be default here */ + DEBUGASSERT(curl_ssl_version_min != CURL_SSLVERSION_DEFAULT); + switch(curl_ssl_version_min) { + case CURL_SSLVERSION_TLSv1: /* TLS 1.x */ + case CURL_SSLVERSION_TLSv1_0: + ossl_ssl_version_min = TLS1_VERSION; + break; + case CURL_SSLVERSION_TLSv1_1: + ossl_ssl_version_min = TLS1_1_VERSION; + break; + case CURL_SSLVERSION_TLSv1_2: + ossl_ssl_version_min = TLS1_2_VERSION; + break; + case CURL_SSLVERSION_TLSv1_3: + ossl_ssl_version_min = TLS1_3_VERSION; + break; + } + + /* ... then, TLS max version */ + curl_ssl_version_max = (long)conn_config->version_max; + + /* convert curl max SSL version option to OpenSSL constant */ + switch(curl_ssl_version_max) { + case CURL_SSLVERSION_MAX_TLSv1_0: + ossl_ssl_version_max = TLS1_VERSION; + break; + case CURL_SSLVERSION_MAX_TLSv1_1: + ossl_ssl_version_max = TLS1_1_VERSION; + break; + case CURL_SSLVERSION_MAX_TLSv1_2: + ossl_ssl_version_max = TLS1_2_VERSION; + break; + case CURL_SSLVERSION_MAX_TLSv1_3: + ossl_ssl_version_max = TLS1_3_VERSION; + break; + case CURL_SSLVERSION_MAX_NONE: /* none selected */ + case CURL_SSLVERSION_MAX_DEFAULT: /* max selected */ + default: + /* SSL_CTX_set_max_proto_version states that: setting the maximum to 0 + enables protocol versions up to the highest version supported by + the library */ + ossl_ssl_version_max = 0; + break; + } + + if(!SSL_CTX_set_min_proto_version(ctx, ossl_ssl_version_min) || + !SSL_CTX_set_max_proto_version(ctx, ossl_ssl_version_max)) + return CURLE_SSL_CONNECT_ERROR; + + return CURLE_OK; +} + +#ifdef HAVE_BORINGSSL_LIKE +typedef uint32_t ctx_option_t; +#elif defined(HAVE_OPENSSL3) +typedef uint64_t ctx_option_t; +#elif defined(LIBRESSL_VERSION_NUMBER) +typedef long ctx_option_t; +#else +typedef unsigned long ctx_option_t; +#endif + +CURLcode Curl_ossl_add_session(struct Curl_cfilter *cf, + struct Curl_easy *data, + const char *ssl_peer_key, + SSL_SESSION *session, + int ietf_tls_id, + const char *alpn, + unsigned char *quic_tp, + size_t quic_tp_len) +{ + unsigned char *der_session_buf = NULL; + unsigned char *qtp_clone = NULL; + CURLcode result = CURLE_OK; + + if(!cf || !data) + goto out; + + if(Curl_ssl_scache_use(cf, data)) { + struct Curl_ssl_session *sc_session = NULL; + size_t der_session_size; + unsigned char *der_session_ptr; + size_t earlydata_max = 0; + + der_session_size = i2d_SSL_SESSION(session, NULL); + if(der_session_size == 0) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + der_session_buf = der_session_ptr = curlx_malloc(der_session_size); + if(!der_session_buf) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + der_session_size = i2d_SSL_SESSION(session, &der_session_ptr); + if(der_session_size == 0) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + +#ifdef HAVE_OPENSSL_EARLYDATA + earlydata_max = SSL_SESSION_get_max_early_data(session); +#endif + if(quic_tp && quic_tp_len) { + qtp_clone = curlx_memdup0((const char *)quic_tp, quic_tp_len); + if(!qtp_clone) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + } + + result = Curl_ssl_session_create2(der_session_buf, der_session_size, + ietf_tls_id, alpn, + (curl_off_t)time(NULL) + + SSL_SESSION_get_timeout(session), + earlydata_max, qtp_clone, quic_tp_len, + &sc_session); + der_session_buf = NULL; /* took ownership of sdata */ + if(!result) { + result = Curl_ssl_scache_put(cf, data, ssl_peer_key, sc_session); + /* took ownership of `sc_session` */ + } + } + +out: + curlx_free(der_session_buf); + return result; +} + +/* The "new session" callback must return zero if the session can be removed + * or non-zero if the session has been put into the session cache. + */ +static int ossl_new_session_cb(SSL *ssl, SSL_SESSION *ssl_sessionid) +{ + struct Curl_cfilter *cf = (struct Curl_cfilter *)SSL_get_app_data(ssl); + if(cf) { + struct Curl_easy *data = CF_DATA_CURRENT(cf); + struct ssl_connect_data *connssl = cf->ctx; + Curl_ossl_add_session(cf, data, connssl->peer.scache_key, ssl_sessionid, + SSL_version(ssl), connssl->negotiated.alpn, NULL, 0); + } + return 0; +} + +static CURLcode load_cacert_from_memory(X509_STORE *store, + const struct curl_blob *ca_info_blob) +{ + /* these need to be freed at the end */ + BIO *cbio = NULL; + STACK_OF(X509_INFO) *inf = NULL; + + /* everything else is a reference */ + int i, count = 0; + X509_INFO *itmp = NULL; + + if(ca_info_blob->len > (size_t)INT_MAX) + return CURLE_SSL_CACERT_BADFILE; + + cbio = BIO_new_mem_buf(ca_info_blob->data, (int)ca_info_blob->len); + if(!cbio) + return CURLE_OUT_OF_MEMORY; + + inf = PEM_X509_INFO_read_bio(cbio, NULL, NULL, NULL); + if(!inf) { + BIO_free(cbio); + return CURLE_SSL_CACERT_BADFILE; + } + + /* add each entry from PEM file to x509_store */ + for(i = 0; i < (int)sk_X509_INFO_num(inf); ++i) { + itmp = sk_X509_INFO_value(inf, (ossl_valsize_t)i); + if(itmp->x509) { + if(X509_STORE_add_cert(store, itmp->x509)) { + ++count; + } + else { + /* set count to 0 to return an error */ + count = 0; + break; + } + } + if(itmp->crl) { + if(X509_STORE_add_crl(store, itmp->crl)) { + ++count; + } + else { + /* set count to 0 to return an error */ + count = 0; + break; + } + } + } + +#if defined(__clang__) && __clang_major__ >= 16 +#pragma clang diagnostic push +#pragma clang diagnostic ignored "-Wcast-function-type-strict" +#endif + sk_X509_INFO_pop_free(inf, X509_INFO_free); +#if defined(__clang__) && __clang_major__ >= 16 +#pragma clang diagnostic pop +#endif + BIO_free(cbio); + + /* if we did not end up importing anything, treat that as an error */ + return (count > 0) ? CURLE_OK : CURLE_SSL_CACERT_BADFILE; +} + +#ifdef USE_WIN32_CRYPTO +static CURLcode ossl_win_load_store(struct Curl_easy *data, + struct Curl_cfilter *cf, + const char *win_store, + X509_STORE *store, + bool *padded) +{ + CURLcode result = CURLE_OK; + HCERTSTORE hStore; + + *padded = FALSE; + + hStore = CertOpenSystemStoreA(0, win_store); + if(hStore) { + PCCERT_CONTEXT pContext = NULL; + /* The array of enhanced key usage OIDs varies per certificate and + is declared outside of the loop so that rather than malloc/free each + iteration we can grow it with realloc, when necessary. */ + CERT_ENHKEY_USAGE *enhkey_usage = NULL; + DWORD enhkey_usage_size = 0; + VERBOSE(size_t total = 0); + VERBOSE(size_t imported = 0); + + /* This loop makes a best effort to import all valid certificates from + the MS root store. If a certificate cannot be imported it is + skipped. 'result' is used to store only hard-fail conditions (such + as out of memory) that cause an early break. */ + result = CURLE_OK; + for(;;) { + X509 *x509; + FILETIME now; + BYTE key_usage[2]; + DWORD req_size; + const unsigned char *encoded_cert; + pContext = CertEnumCertificatesInStore(hStore, pContext); + if(!pContext) + break; + + VERBOSE(++total); + +#if defined(DEBUGBUILD) && defined(CURLVERBOSE) + { + char cert_name[256]; + if(!CertGetNameStringA(pContext, CERT_NAME_SIMPLE_DISPLAY_TYPE, 0, + NULL, cert_name, sizeof(cert_name))) + infof(data, "SSL: unknown cert name"); + else + infof(data, "SSL: Checking cert \"%s\"", cert_name); + } +#endif + encoded_cert = (const unsigned char *)pContext->pbCertEncoded; + if(!encoded_cert) + continue; + + GetSystemTimeAsFileTime(&now); + if(CompareFileTime(&pContext->pCertInfo->NotBefore, &now) > 0 || + CompareFileTime(&now, &pContext->pCertInfo->NotAfter) > 0) + continue; + + /* If key usage exists check for signing attribute */ + if(CertGetIntendedKeyUsage(pContext->dwCertEncodingType, + pContext->pCertInfo, + key_usage, sizeof(key_usage))) { + if(!(key_usage[0] & CERT_KEY_CERT_SIGN_KEY_USAGE)) + continue; + } + else if(GetLastError()) + continue; + + /* If enhanced key usage exists check for server auth attribute. + * + * Note "In a Microsoft environment, a certificate might also have + * EKU extended properties that specify valid uses for the + * certificate." The call below checks both, and behavior varies + * depending on what is found. For more details see + * CertGetEnhancedKeyUsage doc. + */ + if(CertGetEnhancedKeyUsage(pContext, 0, NULL, &req_size) && req_size) { + if(req_size > enhkey_usage_size) { + void *tmp = curlx_realloc(enhkey_usage, req_size); + + if(!tmp) { + failf(data, "SSL: Out of memory allocating for OID list"); + result = CURLE_OUT_OF_MEMORY; + break; + } + + enhkey_usage = (CERT_ENHKEY_USAGE *)tmp; + enhkey_usage_size = req_size; + } + + if(CertGetEnhancedKeyUsage(pContext, 0, enhkey_usage, &req_size)) { + if(!enhkey_usage->cUsageIdentifier) { + /* "If GetLastError returns CRYPT_E_NOT_FOUND, the certificate + is good for all uses. If it returns zero, the certificate + has no valid uses." */ + if((HRESULT)GetLastError() != CRYPT_E_NOT_FOUND) + continue; + } + else { + DWORD i; + bool found = FALSE; + + for(i = 0; i < enhkey_usage->cUsageIdentifier; ++i) { + if(!strcmp("1.3.6.1.5.5.7.3.1" /* OID server auth */, + enhkey_usage->rgpszUsageIdentifier[i])) { + found = TRUE; + break; + } + } + + if(!found) + continue; + } + } + else + continue; + } + else + continue; + + x509 = d2i_X509(NULL, &encoded_cert, (long)pContext->cbCertEncoded); + if(!x509) + continue; + + /* Try to import the certificate. This may fail for legitimate reasons + such as duplicate certificate, which is allowed by MS but not + OpenSSL. */ + if(X509_STORE_add_cert(store, x509) == 1) { + VERBOSE(++imported); +#ifdef DEBUGBUILD + infof(data, "SSL: Imported cert"); +#endif + *padded = TRUE; + } + X509_free(x509); + } + + curlx_free(enhkey_usage); + CertFreeCertificateContext(pContext); + CertCloseStore(hStore, 0); + + CURL_TRC_CF(data, cf, + "ossl_win_load_store() found: %zu imported: %zu certs in %s.", + total, imported, win_store); + + if(result) + return result; + } + + return result; +} + +static CURLcode ossl_windows_load_anchors(struct Curl_cfilter *cf, + struct Curl_easy *data, + X509_STORE *store, + bool *padded) +{ + /* Import certificates from the Windows root certificate store if + requested. + https://stackoverflow.com/questions/9507184/ + https://github.com/d3x0r/SACK/blob/ff15424d3c581b86d40f818532e5a400c516d39d/src/netlib/ssl_layer.c#L1410 + https://datatracker.ietf.org/doc/html/rfc5280 */ + const char *win_stores[] = { + "ROOT", /* Trusted Root Certification Authorities */ + "CA" /* Intermediate Certification Authorities */ + }; + size_t i; + CURLcode result = CURLE_OK; + + *padded = FALSE; + for(i = 0; i < CURL_ARRAYSIZE(win_stores); ++i) { + bool store_added = FALSE; + result = ossl_win_load_store(data, cf, win_stores[i], store, &store_added); + if(result) + return result; + if(store_added) { + CURL_TRC_CF(data, cf, "added trust anchors from Windows %s store", + win_stores[i]); + *padded = TRUE; + } + else + infof(data, "error importing Windows %s store, continuing anyway", + win_stores[i]); + } + return result; +} + +#endif /* USE_WIN32_CRYPTO */ + +static CURLcode ossl_load_trust_anchors(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct ossl_ctx *octx, + X509_STORE *store) +{ + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + struct ssl_config_data *ssl_config = Curl_ssl_cf_get_config(cf, data); + CURLcode result = CURLE_OK; + const char * const ssl_cafile = + /* CURLOPT_CAINFO_BLOB overrides CURLOPT_CAINFO */ + (conn_config->ca_info_blob ? NULL : conn_config->CAfile); + const char * const ssl_capath = conn_config->CApath; + bool have_native_check = FALSE; + + octx->store_is_empty = TRUE; + if(ssl_config->native_ca_store) { +#ifdef USE_WIN32_CRYPTO + bool added = FALSE; + result = ossl_windows_load_anchors(cf, data, store, &added); + if(result) + return result; + if(added) { + infof(data, " Native: Windows System Stores ROOT+CA"); + octx->store_is_empty = FALSE; + } +#elif defined(USE_APPLE_SECTRUST) + infof(data, " Native: Apple SecTrust"); + have_native_check = TRUE; +#endif + } + + if(conn_config->ca_info_blob) { + result = load_cacert_from_memory(store, conn_config->ca_info_blob); + if(result) { + failf(data, "error adding trust anchors from certificate blob: %d", + (int)result); + return result; + } + infof(data, " CA Blob from configuration"); + octx->store_is_empty = FALSE; + } + + if(ssl_cafile || ssl_capath) { +#ifdef HAVE_OPENSSL3 + /* OpenSSL 3.0.0 has deprecated SSL_CTX_load_verify_locations */ + if(ssl_cafile) { + if(!X509_STORE_load_file(store, ssl_cafile)) { + if(octx->store_is_empty && !have_native_check) { + /* Fail if we insist on successfully verifying the server. */ + failf(data, "error adding trust anchors from file: %s", ssl_cafile); + return CURLE_SSL_CACERT_BADFILE; + } + else + infof(data, "error setting certificate file, continuing anyway"); + } + infof(data, " CAfile: %s", ssl_cafile); + octx->store_is_empty = FALSE; + } + if(ssl_capath) { + if(!X509_STORE_load_path(store, ssl_capath)) { + if(octx->store_is_empty && !have_native_check) { + /* Fail if we insist on successfully verifying the server. */ + failf(data, "error adding trust anchors from path: %s", ssl_capath); + return CURLE_SSL_CACERT_BADFILE; + } + else + infof(data, "error setting certificate path, continuing anyway"); + } + infof(data, " CApath: %s", ssl_capath); + octx->store_is_empty = FALSE; + } +#else + /* tell OpenSSL where to find CA certificates that are used to verify the + server's certificate. */ + if(!X509_STORE_load_locations(store, ssl_cafile, ssl_capath)) { + if(octx->store_is_empty && !have_native_check) { + /* Fail if we insist on successfully verifying the server. */ + failf(data, "error adding trust anchors from locations:" + " CAfile: %s CApath: %s", + ssl_cafile ? ssl_cafile : "none", + ssl_capath ? ssl_capath : "none"); + return CURLE_SSL_CACERT_BADFILE; + } + else { + infof(data, "error setting certificate verify locations," + " continuing anyway"); + } + } + if(ssl_cafile) + infof(data, " CAfile: %s", ssl_cafile); + if(ssl_capath) + infof(data, " CApath: %s", ssl_capath); + octx->store_is_empty = FALSE; +#endif + } + +#ifdef CURL_CA_FALLBACK + if(octx->store_is_empty) { + /* verifying the peer without any CA certificates does not + work so use OpenSSL's built-in default as fallback */ + X509_STORE_set_default_paths(store); + infof(data, " OpenSSL default paths (fallback)"); + octx->store_is_empty = FALSE; + } +#endif + if(octx->store_is_empty && !have_native_check) + infof(data, " no trust anchors configured"); + + return result; +} + +static CURLcode ossl_populate_x509_store(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct ossl_ctx *octx, + X509_STORE *store) +{ + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + struct ssl_config_data *ssl_config = Curl_ssl_cf_get_config(cf, data); + CURLcode result = CURLE_OK; + X509_LOOKUP *lookup = NULL; + const char * const ssl_crlfile = ssl_config->primary.CRLfile; + unsigned long x509flags = 0; + + CURL_TRC_CF(data, cf, "configuring OpenSSL's x509 trust store"); + if(!store) + return CURLE_OUT_OF_MEMORY; + + if(!conn_config->verifypeer) { + infof(data, "SSL Trust: peer verification disabled"); + return CURLE_OK; + } + + infof(data, "SSL Trust Anchors:"); + result = ossl_load_trust_anchors(cf, data, octx, store); + if(result) + return result; + + /* Does not make sense to load a CRL file without peer verification */ + if(ssl_crlfile) { + /* tell OpenSSL where to find CRL file that is used to check certificate + * revocation */ + lookup = X509_STORE_add_lookup(store, X509_LOOKUP_file()); + if(!lookup || + (!X509_load_crl_file(lookup, ssl_crlfile, X509_FILETYPE_PEM))) { + failf(data, "error loading CRL file: %s", ssl_crlfile); + return CURLE_SSL_CRL_BADFILE; + } + x509flags = X509_V_FLAG_CRL_CHECK | X509_V_FLAG_CRL_CHECK_ALL; + infof(data, " CRLfile: %s", ssl_crlfile); + } + + /* Try building a chain using issuers in the trusted store first to avoid + problems with server-sent legacy intermediates. Newer versions of + OpenSSL do alternate chain checking by default but we do not know how to + determine that in a reliable manner. + https://web.archive.org/web/20190422050538/rt.openssl.org/Ticket/Display.html?id=3621 + */ + x509flags |= X509_V_FLAG_TRUSTED_FIRST; + + if(!ssl_config->no_partialchain && !ssl_crlfile) { + /* Have intermediate certificates in the trust store be treated as + trust-anchors, in the same way as self-signed root CA certificates are. + This allows users to verify servers using the intermediate cert only, + instead of needing the whole chain. + + Due to OpenSSL bug https://github.com/openssl/openssl/issues/5081 we + cannot do partial chains with a CRL check. + */ + x509flags |= X509_V_FLAG_PARTIAL_CHAIN; + } + (void)X509_STORE_set_flags(store, x509flags); + + return result; +} + +/* key to use at `multi->proto_hash` */ +#define MPROTO_OSSL_X509_KEY "tls:ossl:x509:share" + +struct ossl_x509_share { + char *CAfile; /* CAfile path used to generate X509 store */ + X509_STORE *store; /* cached X509 store or NULL if none */ + struct curltime time; /* when the cached store was created */ + BIT(store_is_empty); /* no certs/paths/blobs are in the store */ + BIT(no_partialchain); /* keep partial chain state */ +}; + +static void oss_x509_share_free(void *key, size_t key_len, void *p) +{ + struct ossl_x509_share *share = p; + DEBUGASSERT(key_len == (sizeof(MPROTO_OSSL_X509_KEY) - 1)); + DEBUGASSERT(!memcmp(MPROTO_OSSL_X509_KEY, key, key_len)); + (void)key; + (void)key_len; + if(share->store) { + X509_STORE_free(share->store); + } + curlx_free(share->CAfile); + curlx_free(share); +} + +static bool ossl_cached_x509_store_expired(struct Curl_easy *data, + const struct ossl_x509_share *mb) +{ + const struct ssl_general_config *cfg = &data->set.general_ssl; + if(cfg->ca_cache_timeout < 0) + return FALSE; + else { + timediff_t elapsed_ms = curlx_ptimediff_ms(Curl_pgrs_now(data), &mb->time); + timediff_t timeout_ms = cfg->ca_cache_timeout * (timediff_t)1000; + + return elapsed_ms >= timeout_ms; + } +} + +static bool ossl_cached_x509_store_different(struct Curl_cfilter *cf, + const struct Curl_easy *data, + const struct ossl_x509_share *mb) +{ + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + struct ssl_config_data *ssl_config = + Curl_ssl_cf_get_config(cf, CURL_UNCONST(data)); + if(mb->no_partialchain != ssl_config->no_partialchain) + return TRUE; + if(!mb->CAfile || !conn_config->CAfile) + return mb->CAfile != conn_config->CAfile; + return strcmp(mb->CAfile, conn_config->CAfile); +} + +static X509_STORE *ossl_get_cached_x509_store(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *pempty) +{ + struct Curl_multi *multi = data->multi; + struct ossl_x509_share *share; + X509_STORE *store = NULL; + + DEBUGASSERT(multi); + *pempty = TRUE; + share = multi ? Curl_hash_pick(&multi->proto_hash, + CURL_UNCONST(MPROTO_OSSL_X509_KEY), + sizeof(MPROTO_OSSL_X509_KEY) - 1) : NULL; + if(share && share->store && + !ossl_cached_x509_store_expired(data, share) && + !ossl_cached_x509_store_different(cf, data, share)) { + store = share->store; + *pempty = (bool)share->store_is_empty; + } + + return store; +} + +static void ossl_set_cached_x509_store(struct Curl_cfilter *cf, + struct Curl_easy *data, + X509_STORE *store, + bool is_empty) +{ + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + struct Curl_multi *multi = data->multi; + struct ossl_x509_share *share; + + DEBUGASSERT(multi); + if(!multi) + return; + share = Curl_hash_pick(&multi->proto_hash, + CURL_UNCONST(MPROTO_OSSL_X509_KEY), + sizeof(MPROTO_OSSL_X509_KEY) - 1); + + if(!share) { + share = curlx_calloc(1, sizeof(*share)); + if(!share) + return; + if(!Curl_hash_add2(&multi->proto_hash, + CURL_UNCONST(MPROTO_OSSL_X509_KEY), + sizeof(MPROTO_OSSL_X509_KEY) - 1, + share, oss_x509_share_free)) { + curlx_free(share); + return; + } + } + + if(X509_STORE_up_ref(store)) { + char *CAfile = NULL; + struct ssl_config_data *ssl_config = + Curl_ssl_cf_get_config(cf, CURL_UNCONST(data)); + + if(conn_config->CAfile) { + CAfile = curlx_strdup(conn_config->CAfile); + if(!CAfile) { + X509_STORE_free(store); + return; + } + } + + if(share->store) { + X509_STORE_free(share->store); + curlx_free(share->CAfile); + } + + share->time = *Curl_pgrs_now(data); + share->store = store; + share->store_is_empty = is_empty; + share->CAfile = CAfile; + share->no_partialchain = ssl_config->no_partialchain; + } +} + +CURLcode Curl_ssl_setup_x509_store(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct ossl_ctx *octx) +{ + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + struct ssl_config_data *ssl_config = Curl_ssl_cf_get_config(cf, data); + CURLcode result = CURLE_OK; + X509_STORE *cached_store; + bool cache_criteria_met, is_empty; + + /* Consider the X509 store cacheable if it comes exclusively from a CAfile, + or no source is provided and we are falling back to OpenSSL's built-in + default. */ + cache_criteria_met = (data->set.general_ssl.ca_cache_timeout != 0) && + conn_config->verifypeer && + !conn_config->CApath && + !conn_config->ca_info_blob && + !ssl_config->primary.CRLfile && + !ssl_config->native_ca_store; + + ERR_set_mark(); + + cached_store = ossl_get_cached_x509_store(cf, data, &is_empty); + if(cached_store && cache_criteria_met && X509_STORE_up_ref(cached_store)) { + SSL_CTX_set_cert_store(octx->ssl_ctx, cached_store); + octx->store_is_empty = is_empty; + } + else { + X509_STORE *store = SSL_CTX_get_cert_store(octx->ssl_ctx); + + result = ossl_populate_x509_store(cf, data, octx, store); + if(result == CURLE_OK && cache_criteria_met) { + ossl_set_cached_x509_store(cf, data, store, (bool)octx->store_is_empty); + } + } + + ERR_pop_to_mark(); + + return result; +} + +static CURLcode ossl_init_session_and_alpns( + struct ossl_ctx *octx, + struct Curl_cfilter *cf, + struct Curl_easy *data, + struct ssl_peer *peer, + const struct alpn_spec *alpns_requested, + Curl_ossl_init_session_reuse_cb *sess_reuse_cb) +{ + struct ssl_config_data *ssl_config = Curl_ssl_cf_get_config(cf, data); + struct ssl_primary_config *conn_cfg = Curl_ssl_cf_get_primary_config(cf); + struct alpn_spec alpns; + CURLcode result; + + Curl_alpn_copy(&alpns, alpns_requested); + + octx->reused_session = FALSE; + if(Curl_ssl_scache_use(cf, data) && !conn_cfg->verifystatus) { + struct Curl_ssl_session *scs = NULL; + + result = Curl_ssl_scache_take(cf, data, peer->scache_key, &scs); + if(!result && scs && scs->sdata && scs->sdata_len) { + const unsigned char *der_sessionid = scs->sdata; + size_t der_sessionid_size = scs->sdata_len; + SSL_SESSION *ssl_session = NULL; + + /* If OpenSSL does not accept the session from the cache, this + * is not an error. We continue without it. */ + ssl_session = d2i_SSL_SESSION(NULL, &der_sessionid, + (long)der_sessionid_size); + if(ssl_session) { + if(!SSL_set_session(octx->ssl, ssl_session)) { + VERBOSE(char error_buffer[256]); + infof(data, "SSL: SSL_set_session not accepted, " + "continuing without: %s", + ossl_strerror(ERR_get_error(), error_buffer, + sizeof(error_buffer))); + } + else { + if(conn_cfg->verifypeer && + (SSL_get_verify_result(octx->ssl) != X509_V_OK)) { + /* Session was from unverified connection, cannot reuse here */ + SSL_set_session(octx->ssl, NULL); + infof(data, "SSL session not peer verified, not reusing"); + } + else { + infof(data, "SSL reusing session with ALPN '%s'", + scs->alpn ? scs->alpn : "-"); + octx->reused_session = TRUE; + infof(data, "SSL verify result: %lx", + (unsigned long)SSL_get_verify_result(octx->ssl)); +#ifdef HAVE_OPENSSL_EARLYDATA + if(ssl_config->earlydata && scs->alpn && + SSL_SESSION_get_max_early_data(ssl_session) && + !cf->conn->bits.connect_only && + (SSL_version(octx->ssl) == TLS1_3_VERSION)) { + bool do_early_data = FALSE; + if(sess_reuse_cb) { + result = sess_reuse_cb(cf, data, &alpns, scs, &do_early_data); + if(result) { + SSL_SESSION_free(ssl_session); + return result; + } + } + if(do_early_data) { + /* We only try the ALPN protocol the session used before, + * otherwise we might send early data for the wrong protocol */ + Curl_alpn_restrict_to(&alpns, scs->alpn); + } + } +#else + (void)ssl_config; + (void)sess_reuse_cb; +#endif + } + } + SSL_SESSION_free(ssl_session); + } + else { + infof(data, "SSL session not accepted by OpenSSL, continuing without"); + } + } + Curl_ssl_scache_return(cf, data, peer->scache_key, scs); + } + + if(alpns.count) { + struct alpn_proto_buf proto; + memset(&proto, 0, sizeof(proto)); + result = Curl_alpn_to_proto_buf(&proto, &alpns); + if(result) { + failf(data, "Error determining ALPN"); + return CURLE_SSL_CONNECT_ERROR; + } + if(SSL_set_alpn_protos(octx->ssl, proto.data, proto.len)) { + failf(data, "Error setting ALPN"); + return CURLE_SSL_CONNECT_ERROR; + } + } + + return CURLE_OK; +} + +#ifdef HAVE_SSL_SET1_ECH_CONFIG_LIST +bool Curl_ossl_need_httpsrr(struct Curl_easy *data) +{ + if(!CURLECH_ENABLED(data)) + return FALSE; + if((data->set.tls_ech == CURLECH_GREASE) || + data->set.str[STRING_ECH_CONFIG]) + return FALSE; + return TRUE; +} + +static CURLcode ossl_init_ech(struct ossl_ctx *octx, + struct Curl_cfilter *cf, + struct Curl_easy *data, + struct ssl_peer *peer) +{ + unsigned char *ech_config = NULL; + size_t ech_config_len = 0; + char *outername = data->set.str[STRING_ECH_PUBLIC]; + int trying_ech_now = 0; + + if(!CURLECH_ENABLED(data)) + return CURLE_OK; + + if(data->set.tls_ech == CURLECH_GREASE) { + infof(data, "ECH: will GREASE ClientHello"); +#ifdef HAVE_BORINGSSL_LIKE + SSL_set_enable_ech_grease(octx->ssl, 1); +#else + SSL_set_options(octx->ssl, SSL_OP_ECH_GREASE); +#endif + } + else if(data->set.tls_ech && data->set.str[STRING_ECH_CONFIG]) { +#ifdef HAVE_BORINGSSL_LIKE + /* have to do base64 decode here for BoringSSL */ + const char *b64 = data->set.str[STRING_ECH_CONFIG]; + CURLcode result; + + if(!b64) { + infof(data, "ECH: ECHConfig from command line empty"); + return CURLE_SSL_CONNECT_ERROR; + } + ech_config_len = 2 * strlen(b64); + result = curlx_base64_decode(b64, &ech_config, &ech_config_len); + if(result || !ech_config) { + infof(data, "ECH: cannot base64 decode ECHConfig from command line"); + if(data->set.tls_ech == CURLECH_HARD) + return result; + } + if(SSL_set1_ech_config_list(octx->ssl, ech_config, ech_config_len) != 1) { + infof(data, "ECH: SSL_ECH_set1_ech_config_list failed"); + if(data->set.tls_ech == CURLECH_HARD) { + curlx_free(ech_config); + return CURLE_SSL_CONNECT_ERROR; + } + } + curlx_free(ech_config); + trying_ech_now = 1; +#else + ech_config = (unsigned char *)data->set.str[STRING_ECH_CONFIG]; + if(!ech_config) { + infof(data, "ECH: ECHConfig from command line empty"); + return CURLE_SSL_CONNECT_ERROR; + } + ech_config_len = strlen(data->set.str[STRING_ECH_CONFIG]); + if(SSL_set1_ech_config_list(octx->ssl, ech_config, ech_config_len) != 1) { + infof(data, "ECH: SSL_ECH_set1_ech_config_list failed"); + if(data->set.tls_ech == CURLECH_HARD) + return CURLE_SSL_CONNECT_ERROR; + } + else + trying_ech_now = 1; +#endif /* HAVE_BORINGSSL_LIKE */ + infof(data, "ECH: ECHConfig from command line"); + } + else { + const struct Curl_https_rrinfo *rinfo = + Curl_conn_dns_get_https(data, cf->sockindex, peer->origin); + + if(rinfo && rinfo->echconfiglist) { + const unsigned char *ecl = rinfo->echconfiglist; + size_t elen = rinfo->echconfiglist_len; + + infof(data, "ECH: ECHConfig from HTTPS RR"); + if(SSL_set1_ech_config_list(octx->ssl, ecl, elen) != 1) { + infof(data, "ECH: SSL_set1_ech_config_list failed"); + if(data->set.tls_ech == CURLECH_HARD) + return CURLE_SSL_CONNECT_ERROR; + } + else { + trying_ech_now = 1; + infof(data, "ECH: imported ECHConfigList of length %zu", elen); + } + } + else { + infof(data, "ECH: requested but no ECHConfig available"); + if(data->set.tls_ech == CURLECH_HARD) + return CURLE_SSL_CONNECT_ERROR; + } + } +#ifdef HAVE_BORINGSSL_LIKE + (void)peer; + if(trying_ech_now && outername) { + infof(data, "ECH: setting public_name not supported with BoringSSL"); + return CURLE_SSL_CONNECT_ERROR; + } +#else + if(trying_ech_now && outername) { + int ret; + infof(data, "ECH: inner: '%s', outer: '%s'", + peer->origin->hostname ? peer->origin->hostname : "NULL", outername); + ret = SSL_ech_set1_server_names(octx->ssl, + peer->origin->hostname, outername, + 0 /* do send outer */); + if(ret != 1) { + infof(data, "ECH: rv failed to set server name(s) %d [ERROR]", ret); + return CURLE_SSL_CONNECT_ERROR; + } + } +#endif /* HAVE_BORINGSSL_LIKE */ + if(trying_ech_now && + SSL_set_min_proto_version(octx->ssl, TLS1_3_VERSION) != 1) { + infof(data, "ECH: cannot force TLSv1.3 [ERROR]"); + return CURLE_SSL_CONNECT_ERROR; + } + + return CURLE_OK; +} +#else /* HAVE_SSL_SET1_ECH_CONFIG_LIST */ +bool Curl_ossl_need_httpsrr(struct Curl_easy *data) +{ + (void)data; + return FALSE; +} +#endif /* else HAVE_SSL_SET1_ECH_CONFIG_LIST */ + +static CURLcode ossl_init_ssl(struct ossl_ctx *octx, + struct Curl_cfilter *cf, + struct Curl_easy *data, + struct ssl_peer *peer, + const struct alpn_spec *alpns_requested, + void *ssl_user_data, + Curl_ossl_init_session_reuse_cb *sess_reuse_cb) +{ + /* Let's make an SSL structure */ + if(octx->ssl) + SSL_free(octx->ssl); + octx->ssl = SSL_new(octx->ssl_ctx); + if(!octx->ssl) { + failf(data, "SSL: could not create a context (handle)"); + return CURLE_OUT_OF_MEMORY; + } + + SSL_set_app_data(octx->ssl, ssl_user_data); + +#ifndef OPENSSL_NO_OCSP + if(Curl_ssl_cf_get_primary_config(cf)->verifystatus) + SSL_set_tlsext_status_type(octx->ssl, TLSEXT_STATUSTYPE_ocsp); +#endif + + SSL_set_connect_state(octx->ssl); + + if(peer->sni) { + if(!SSL_set_tlsext_host_name(octx->ssl, peer->sni)) { + failf(data, "Failed set SNI"); + return CURLE_SSL_CONNECT_ERROR; + } + } + +#ifdef HAVE_SSL_SET1_ECH_CONFIG_LIST + { + CURLcode result = ossl_init_ech(octx, cf, data, peer); + if(result) + return result; + } +#endif /* HAVE_SSL_SET1_ECH_CONFIG_LIST */ + + return ossl_init_session_and_alpns(octx, cf, data, peer, + alpns_requested, sess_reuse_cb); +} + +static CURLcode ossl_init_method(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct ssl_peer *peer, + const SSL_METHOD **pmethod, + unsigned int *pssl_version_min) +{ + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + + *pmethod = NULL; + *pssl_version_min = conn_config->version; + DEBUGASSERT(conn_config->version != CURL_SSLVERSION_DEFAULT); + switch(peer->transport) { + case TRNSPRT_TCP: + /* check to see if we have been told to use an explicit SSL/TLS version */ + switch(*pssl_version_min) { + case CURL_SSLVERSION_TLSv1: + case CURL_SSLVERSION_TLSv1_0: + case CURL_SSLVERSION_TLSv1_1: + case CURL_SSLVERSION_TLSv1_2: + case CURL_SSLVERSION_TLSv1_3: + /* it is handled later with the context options */ + *pmethod = TLS_client_method(); + break; + case CURL_SSLVERSION_SSLv2: + failf(data, "No SSLv2 support"); + return CURLE_NOT_BUILT_IN; + case CURL_SSLVERSION_SSLv3: + failf(data, "No SSLv3 support"); + return CURLE_NOT_BUILT_IN; + default: + failf(data, "Unrecognized parameter passed via CURLOPT_SSLVERSION"); + return CURLE_SSL_CONNECT_ERROR; + } + break; + case TRNSPRT_QUIC: + *pssl_version_min = CURL_SSLVERSION_TLSv1_3; + if(conn_config->version_max && + (conn_config->version_max != CURL_SSLVERSION_MAX_DEFAULT) && + (conn_config->version_max != CURL_SSLVERSION_MAX_TLSv1_3)) { + failf(data, "QUIC needs at least TLS version 1.3"); + return CURLE_SSL_CONNECT_ERROR; + } + + *pmethod = TLS_method(); + break; + default: + failf(data, "unsupported transport %d in SSL init", peer->transport); + return CURLE_SSL_CONNECT_ERROR; + } + + return *pmethod ? CURLE_OK : CURLE_SSL_CONNECT_ERROR; +} + +CURLcode Curl_ossl_ctx_init(struct ossl_ctx *octx, + struct Curl_cfilter *cf, + struct Curl_easy *data, + struct ssl_peer *peer, + const struct alpn_spec *alpns_requested, + Curl_ossl_ctx_setup_cb *cb_setup, + void *cb_user_data, + Curl_ossl_new_session_cb *cb_new_session, + void *ssl_user_data, + Curl_ossl_init_session_reuse_cb *sess_reuse_cb) +{ + CURLcode result = CURLE_OK; + const char *ciphers; + const SSL_METHOD *req_method = NULL; + ctx_option_t ctx_options = 0; + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + struct ssl_config_data *ssl_config = Curl_ssl_cf_get_config(cf, data); + char * const ssl_cert = ssl_config->primary.clientcert; + const struct curl_blob *ssl_cert_blob = ssl_config->primary.cert_blob; + const char * const ssl_cert_type = ssl_config->primary.cert_type; + unsigned int ssl_version_min; + char error_buffer[256]; + + /* Make funny stuff to get random input */ + result = ossl_seed(data); + if(result) + return result; + + ssl_config->certverifyresult = !X509_V_OK; + + result = ossl_init_method(cf, data, peer, &req_method, &ssl_version_min); + if(result) + return result; + DEBUGASSERT(req_method); + + DEBUGASSERT(!octx->ssl_ctx); + octx->ssl_ctx = +#ifdef OPENSSL_HAS_PROVIDERS + data->state.libctx ? + SSL_CTX_new_ex(data->state.libctx, data->state.propq, req_method): +#endif + SSL_CTX_new(req_method); + + if(!octx->ssl_ctx) { + failf(data, "SSL: could not create a context: %s", + ossl_strerror(ERR_peek_error(), error_buffer, sizeof(error_buffer))); + return CURLE_OUT_OF_MEMORY; + } + + if(cb_setup) { + result = cb_setup(cf, data, cb_user_data); + if(result) + return result; + } + + if(data->set.fdebug && data->set.verbose && + (peer->transport != TRNSPRT_QUIC)) { + /* the SSL trace callback is only used for verbose logging; + * QUIC connections use a different TLS record format that + * ossl_trace cannot handle */ + SSL_CTX_set_msg_callback(octx->ssl_ctx, ossl_trace); + SSL_CTX_set_msg_callback_arg(octx->ssl_ctx, cf); + } + + /* OpenSSL contains code to work around lots of bugs and flaws in various + SSL-implementations. SSL_CTX_set_options() is used to enabled those + workarounds. The man page for this option states that SSL_OP_ALL enables + all the workarounds and that "It is usually safe to use SSL_OP_ALL to + enable the bug workaround options if compatibility with somewhat broken + implementations is desired." + + The "-no_ticket" option was introduced in OpenSSL 0.9.8j. it is a flag to + disable "rfc4507bis session ticket support". rfc4507bis was later turned + into the proper RFC5077: https://datatracker.ietf.org/doc/html/rfc5077 + + The enabled extension concerns the session management. I wonder how often + libcurl stops a connection and then resumes a TLS session. Also, sending + the session data is some overhead. I suggest that you use your proposed + patch (which explicitly disables TICKET). + + If someone writes an application with libcurl and OpenSSL who wants to + enable the feature, one can do this in the SSL callback. + + SSL_OP_NETSCAPE_REUSE_CIPHER_CHANGE_BUG option enabling allowed proper + interoperability with web server Netscape Enterprise Server 2.0.1 which + was released back in 1996. + + Due to CVE-2010-4180, option SSL_OP_NETSCAPE_REUSE_CIPHER_CHANGE_BUG has + become ineffective as of OpenSSL 0.9.8q and 1.0.0c. In order to mitigate + CVE-2010-4180 when using previous OpenSSL versions we no longer enable + this option regardless of OpenSSL version and SSL_OP_ALL definition. + + OpenSSL added a workaround for an SSL 3.0/TLS 1.0 CBC vulnerability: + https://web.archive.org/web/20240114184648/openssl.org/~bodo/tls-cbc.txt. + In 0.9.6e they added a bit to SSL_OP_ALL that _disables_ that workaround + despite the fact that SSL_OP_ALL is documented to do "rather harmless" + workarounds. In order to keep the secure workaround, the + SSL_OP_DONT_INSERT_EMPTY_FRAGMENTS bit must not be set. + */ + + ctx_options = SSL_OP_ALL | SSL_OP_NO_TICKET | SSL_OP_NO_COMPRESSION; + + /* mitigate CVE-2010-4180 */ + ctx_options &= ~(ctx_option_t)SSL_OP_NETSCAPE_REUSE_CIPHER_CHANGE_BUG; + + /* unless the user explicitly asks to allow the protocol vulnerability we + use the workaround */ + if(!ssl_config->enable_beast) + ctx_options &= ~(ctx_option_t)SSL_OP_DONT_INSERT_EMPTY_FRAGMENTS; + + DEBUGASSERT(ssl_version_min != CURL_SSLVERSION_DEFAULT); + switch(ssl_version_min) { + case CURL_SSLVERSION_SSLv2: + case CURL_SSLVERSION_SSLv3: + return CURLE_NOT_BUILT_IN; + + /* "--tlsv" options mean TLS >= version */ + case CURL_SSLVERSION_TLSv1: /* TLS >= version 1.0 */ + case CURL_SSLVERSION_TLSv1_0: /* TLS >= version 1.0 */ + case CURL_SSLVERSION_TLSv1_1: /* TLS >= version 1.1 */ + case CURL_SSLVERSION_TLSv1_2: /* TLS >= version 1.2 */ + case CURL_SSLVERSION_TLSv1_3: /* TLS >= version 1.3 */ + /* asking for any TLS version as the minimum, means no SSL versions + allowed */ + ctx_options |= SSL_OP_NO_SSLv2; + ctx_options |= SSL_OP_NO_SSLv3; + + result = ossl_set_ssl_version_min_max(cf, octx->ssl_ctx, ssl_version_min); + if(result) + return result; + break; + + default: + failf(data, "Unrecognized parameter passed via CURLOPT_SSLVERSION"); + return CURLE_SSL_CONNECT_ERROR; + } + + SSL_CTX_set_options(octx->ssl_ctx, ctx_options); + SSL_CTX_set_read_ahead(octx->ssl_ctx, 1); + + /* Max TLS1.2 record size 0x4000 + 0x800. + OpenSSL supports processing "jumbo TLS record" (8 TLS records) in one go + for some algorithms, so match that here. + Experimentation shows that a slightly larger buffer is needed + to avoid short reads. + + However using a large buffer (8 packets) actually decreases performance. + 4 packets is better. + */ +#ifdef HAVE_SSL_CTX_SET_DEFAULT_READ_BUFFER_LEN + SSL_CTX_set_default_read_buffer_len(octx->ssl_ctx, 0x401e * 4); +#endif + + /* We do retry writes sometimes from another buffer address */ + SSL_CTX_set_mode(octx->ssl_ctx, SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER); + + ciphers = conn_config->cipher_list; + if(!ciphers && (peer->transport != TRNSPRT_QUIC)) + ciphers = NULL; + if(ciphers && (ssl_version_min < CURL_SSLVERSION_TLSv1_3)) { + if(!SSL_CTX_set_cipher_list(octx->ssl_ctx, ciphers)) { + failf(data, "failed setting cipher list: %s", ciphers); + return CURLE_SSL_CIPHER; + } + infof(data, "Cipher selection: %s", ciphers); + } + +#ifdef HAVE_SSL_CTX_SET_CIPHERSUITES + { + const char *ciphers13 = conn_config->cipher_list13; + if(ciphers13 && + (!conn_config->version_max || + (conn_config->version_max == CURL_SSLVERSION_MAX_DEFAULT) || + (conn_config->version_max >= CURL_SSLVERSION_MAX_TLSv1_3))) { + if(!SSL_CTX_set_ciphersuites(octx->ssl_ctx, ciphers13)) { + failf(data, "failed setting TLS 1.3 cipher suite: %s", ciphers13); + return CURLE_SSL_CIPHER; + } + infof(data, "TLS 1.3 cipher selection: %s", ciphers13); + } + } +#endif + + if(ssl_cert || ssl_cert_blob || ssl_cert_type) { + result = client_cert(data, octx->ssl_ctx, + ssl_cert, ssl_cert_blob, ssl_cert_type, + ssl_config->primary.key, ssl_config->primary.key_blob, + ssl_config->primary.key_type, + ssl_config->primary.key_passwd); + if(result) + /* failf() is already done in client_cert() */ + return result; + } + +#ifdef HAVE_SSL_CTX_SET_POST_HANDSHAKE_AUTH + /* OpenSSL 1.1.1 requires clients to opt-in for PHA */ + SSL_CTX_set_post_handshake_auth(octx->ssl_ctx, 1); +#endif + + { + const char *curves = conn_config->curves; + if(curves) { +#ifdef HAVE_BORINGSSL_LIKE +#define OSSL_CURVE_CAST(x) (x) +#else +#define OSSL_CURVE_CAST(x) (char *)CURL_UNCONST(x) +#endif + if(!SSL_CTX_set1_curves_list(octx->ssl_ctx, OSSL_CURVE_CAST(curves))) { + failf(data, "failed setting curves list: '%s'", curves); + return CURLE_SSL_CIPHER; + } + } + } + +#ifdef HAVE_SSL_CTX_SET1_SIGALGS +#define OSSL_SIGALG_CAST(x) OSSL_CURVE_CAST(x) + { + const char *signature_algorithms = conn_config->signature_algorithms; + if(signature_algorithms) { + if(!SSL_CTX_set1_sigalgs_list(octx->ssl_ctx, + OSSL_SIGALG_CAST(signature_algorithms))) { + failf(data, "failed setting signature algorithms: '%s'", + signature_algorithms); + return CURLE_SSL_CIPHER; + } + } + } +#endif + +#if defined(HAVE_OPENSSL_SRP) && defined(USE_TLS_SRP) + if(ssl_config->primary.username && Curl_auth_allowed_to_host(data)) { + char * const ssl_username = ssl_config->primary.username; + char * const ssl_password = ssl_config->primary.password; + infof(data, "Using TLS-SRP username: %s", ssl_username); + + if(!SSL_CTX_set_srp_username(octx->ssl_ctx, ssl_username)) { + failf(data, "Unable to set SRP username"); + return CURLE_BAD_FUNCTION_ARGUMENT; + } + if(!SSL_CTX_set_srp_password(octx->ssl_ctx, ssl_password)) { + failf(data, "failed setting SRP password"); + return CURLE_BAD_FUNCTION_ARGUMENT; + } + if(!conn_config->cipher_list) { + infof(data, "Setting cipher list SRP"); + + if(!SSL_CTX_set_cipher_list(octx->ssl_ctx, "SRP")) { + failf(data, "failed setting SRP cipher list"); + return CURLE_SSL_CIPHER; + } + } + } +#endif /* HAVE_OPENSSL_SRP && USE_TLS_SRP */ + + /* OpenSSL always tries to verify the peer. By setting the failure mode + * to NONE, we allow the connect to complete, regardless of the outcome. + * We then explicitly check the result and may try alternatives like + * Apple's SecTrust for verification. */ + SSL_CTX_set_verify(octx->ssl_ctx, SSL_VERIFY_NONE, NULL); + + /* Enable logging of secrets to the file specified in env SSLKEYLOGFILE. */ +#if !defined(HAVE_KEYLOG_UPSTREAM) && defined(HAVE_KEYLOG_CALLBACK) + if(Curl_tls_keylog_enabled()) { + SSL_CTX_set_keylog_callback(octx->ssl_ctx, ossl_keylog_callback); + } +#endif + + if(cb_new_session) { + /* Enable the session cache because it is a prerequisite for the + * "new session" callback. Use the "external storage" mode to prevent + * OpenSSL from creating an internal session cache. + */ + SSL_CTX_set_session_cache_mode(octx->ssl_ctx, + SSL_SESS_CACHE_CLIENT | + SSL_SESS_CACHE_NO_INTERNAL); + SSL_CTX_sess_set_new_cb(octx->ssl_ctx, cb_new_session); + } + + /* give application a chance to interfere with SSL set up. */ + if(data->set.ssl.fsslctx) { + /* When a user callback is installed to modify the SSL_CTX, + * we need to do the full initialization before calling it. + * See: #11800 */ + if(!octx->x509_store_setup) { + result = Curl_ssl_setup_x509_store(cf, data, octx); + if(result) + return result; + octx->x509_store_setup = TRUE; + } + Curl_set_in_callback(data, TRUE); + result = (*data->set.ssl.fsslctx)(data, octx->ssl_ctx, + data->set.ssl.fsslctxp); + Curl_set_in_callback(data, FALSE); + if(result) { + failf(data, "error signaled by SSL ctx callback"); + return result; + } + } + + return ossl_init_ssl(octx, cf, data, peer, alpns_requested, + ssl_user_data, sess_reuse_cb); +} + +static CURLcode ossl_on_session_reuse(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct alpn_spec *alpns, + struct Curl_ssl_session *scs, + bool *do_early_data) +{ + struct ssl_connect_data *connssl = cf->ctx; + + connssl->earlydata_max = scs->earlydata_max; + + return Curl_on_session_reuse(cf, data, alpns, scs, do_early_data, + connssl->earlydata_max); +} + +void Curl_ossl_report_handshake(struct Curl_easy *data, struct ossl_ctx *octx) +{ +#ifdef CURLVERBOSE + if(Curl_trc_is_verbose(data)) { + int psigtype_nid = NID_undef; + const char *negotiated_group_name = NULL; + +#ifdef HAVE_OPENSSL3 + SSL_get_peer_signature_type_nid(octx->ssl, &psigtype_nid); +#if OPENSSL_VERSION_NUMBER >= 0x30200000L + negotiated_group_name = SSL_get0_group_name(octx->ssl); +#else + negotiated_group_name = + OBJ_nid2sn(SSL_get_negotiated_group(octx->ssl) & 0x0000FFFF); +#endif +#endif + + /* Informational message */ + infof(data, "SSL connection using %s / %s / %s / %s", + SSL_get_version(octx->ssl), + SSL_get_cipher(octx->ssl), + negotiated_group_name ? negotiated_group_name : "[blank]", + OBJ_nid2sn(psigtype_nid)); + } +#else + (void)data; + (void)octx; +#endif /* CURLVERBOSE */ +} + +static CURLcode ossl_connect_step1(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct ossl_ctx *octx = (struct ossl_ctx *)connssl->backend; + BIO *bio; + CURLcode result; + + DEBUGASSERT(ssl_connect_1 == connssl->connecting_state); + DEBUGASSERT(octx); + DEBUGASSERT(connssl->peer.origin); + + result = Curl_ossl_ctx_init(octx, cf, data, &connssl->peer, + connssl->alpn, NULL, NULL, + ossl_new_session_cb, cf, + ossl_on_session_reuse); + if(result) + return result; + + octx->bio_method = ossl_bio_cf_method_create(); + if(!octx->bio_method) + return CURLE_OUT_OF_MEMORY; + bio = BIO_new(octx->bio_method); + if(!bio) + return CURLE_OUT_OF_MEMORY; + + BIO_set_data(bio, cf); +#ifdef HAVE_SSL_SET0_WBIO + /* with OpenSSL v1.1.1 we get an alternative to SSL_set_bio() that works + * without backward compat quirks. Every call takes one reference, so we + * up it and pass. SSL* then owns and frees it. + * We check on the function in configure, since LibreSSL and friends + * each have their own versions to add support for this. */ + BIO_up_ref(bio); + SSL_set0_rbio(octx->ssl, bio); + SSL_set0_wbio(octx->ssl, bio); +#else + SSL_set_bio(octx->ssl, bio, bio); +#endif + + if(connssl->alpn && (connssl->state != ssl_connection_deferred)) { + struct alpn_proto_buf proto; + memset(&proto, 0, sizeof(proto)); + Curl_alpn_to_proto_str(&proto, connssl->alpn); + infof(data, VTLS_INFOF_ALPN_OFFER_1STR, proto.data); + } + + connssl->connecting_state = ssl_connect_2; + return CURLE_OK; +} + +#ifdef HAVE_SSL_SET1_ECH_CONFIG_LIST +/* If we have retry configs, then trace those out */ +static int ossl_trace_ech_retry_configs(struct Curl_easy *data, SSL *ssl, + int reason) +{ + CURLcode result = CURLE_OK; + size_t rcl = 0; + int rv = 1; +#ifndef HAVE_BORINGSSL_LIKE + char *inner = NULL; + uint8_t *rcs = NULL; + char *outer = NULL; +#else + const char *inner = NULL; + const uint8_t *rcs = NULL; + const char *outer = NULL; + size_t out_name_len = 0; + int servername_type = 0; +#endif + NOVERBOSE((void)reason); + + /* nothing to trace if not doing ECH */ + if(!CURLECH_ENABLED(data)) + return rv; +#ifndef HAVE_BORINGSSL_LIKE + rv = SSL_ech_get1_retry_config(ssl, &rcs, &rcl); +#else + SSL_get0_ech_retry_configs(ssl, &rcs, &rcl); + rv = (int)rcl; +#endif + + if(rv && rcs) { + char *b64str = NULL; + size_t blen = 0; + + result = curlx_base64_encode(rcs, rcl, &b64str, &blen); + if(!result && b64str) { + infof(data, "ECH: retry_configs %s", b64str); + curlx_free(b64str); +#ifndef HAVE_BORINGSSL_LIKE + rv = SSL_ech_get1_status(ssl, &inner, &outer); + infof(data, "ECH: retry_configs for %s from %s, %d %d", + inner ? inner : "NULL", outer ? outer : "NULL", reason, rv); +#else + rv = SSL_ech_accepted(ssl); + servername_type = SSL_get_servername_type(ssl); + inner = SSL_get_servername(ssl, servername_type); + SSL_get0_ech_name_override(ssl, &outer, &out_name_len); + infof(data, "ECH: retry_configs for %s from %s, %d %d", + inner ? inner : "NULL", outer ? outer : "NULL", reason, rv); +#endif + } + } + else + infof(data, "ECH: no retry_configs (rv = %d)", rv); +#ifndef HAVE_BORINGSSL_LIKE + OPENSSL_free(inner); + OPENSSL_free(rcs); + OPENSSL_free(outer); +#endif + return rv; +} + +#endif + +static CURLcode ossl_connect_step2(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + int err; + struct ssl_connect_data *connssl = cf->ctx; + struct ossl_ctx *octx = (struct ossl_ctx *)connssl->backend; + struct ssl_config_data *ssl_config = Curl_ssl_cf_get_config(cf, data); + DEBUGASSERT(ssl_connect_2 == connssl->connecting_state); + DEBUGASSERT(octx); + + connssl->io_need = CURL_SSL_IO_NEED_NONE; + ERR_clear_error(); + + err = SSL_connect(octx->ssl); + + if(!octx->x509_store_setup) { + /* After having send off the ClientHello, we prepare the x509 + * store to verify the coming certificate from the server */ + CURLcode result = Curl_ssl_setup_x509_store(cf, data, octx); + if(result) + return result; + octx->x509_store_setup = TRUE; + } + +#if !defined(HAVE_KEYLOG_UPSTREAM) && !defined(HAVE_KEYLOG_CALLBACK) + /* If key logging is enabled, wait for the handshake to complete and then + * proceed with logging secrets (for TLS 1.2 or older). + */ + if(Curl_tls_keylog_enabled() && !octx->keylog_done) + ossl_log_tls12_secret(octx->ssl, &octx->keylog_done); +#endif + + /* 1 is fine + 0 is "not successful but was shut down controlled" + <0 is "handshake was not successful, because a fatal error occurred" */ + if(err != 1) { + int detail = SSL_get_error(octx->ssl, err); + CURL_TRC_CF(data, cf, "SSL_connect() -> err=%d, detail=%d", err, detail); + + if(SSL_ERROR_WANT_READ == detail) { + CURL_TRC_CF(data, cf, "SSL_connect() -> want recv"); + connssl->io_need = CURL_SSL_IO_NEED_RECV; + return CURLE_AGAIN; + } + if(SSL_ERROR_WANT_WRITE == detail) { + CURL_TRC_CF(data, cf, "SSL_connect() -> want send"); + connssl->io_need = CURL_SSL_IO_NEED_SEND; + return CURLE_AGAIN; + } +#ifdef SSL_ERROR_WANT_ASYNC + if(SSL_ERROR_WANT_ASYNC == detail) { + CURL_TRC_CF(data, cf, "SSL_connect() -> want async"); + connssl->io_need = CURL_SSL_IO_NEED_RECV; + return CURLE_AGAIN; + } +#endif +#ifdef SSL_ERROR_WANT_RETRY_VERIFY + if(SSL_ERROR_WANT_RETRY_VERIFY == detail) { + CURL_TRC_CF(data, cf, "SSL_connect() -> want retry_verify"); + Curl_xfer_pause_recv(data, TRUE); + return CURLE_AGAIN; + } +#endif + else { + /* untreated error */ + sslerr_t errdetail; + char error_buffer[256] = ""; + CURLcode result; + long lerr; + int lib; + int reason; + + /* the connection failed, we are not waiting for anything else. */ + connssl->connecting_state = ssl_connect_2; + + /* Get the earliest error code from the thread's error queue and remove + the entry. */ + errdetail = ERR_get_error(); + + /* Extract which lib and reason */ + lib = ERR_GET_LIB(errdetail); + reason = ERR_GET_REASON(errdetail); + + if((lib == ERR_LIB_SSL) && + ((reason == SSL_R_CERTIFICATE_VERIFY_FAILED) +/* Missing from OpenSSL 4+ OPENSSL_NO_DEPRECATED_3_0 builds */ +#ifdef SSL_R_SSLV3_ALERT_CERTIFICATE_EXPIRED + || (reason == SSL_R_SSLV3_ALERT_CERTIFICATE_EXPIRED) +#endif + )) { + result = CURLE_PEER_FAILED_VERIFICATION; + + lerr = SSL_get_verify_result(octx->ssl); + if(lerr != X509_V_OK) { + ssl_config->certverifyresult = lerr; + failf(data, "SSL certificate problem: %s", + X509_verify_cert_error_string(lerr)); + } + else + failf(data, "%s", "SSL certificate verification failed"); + } +#ifdef SSL_R_TLSV13_ALERT_CERTIFICATE_REQUIRED + /* SSL_R_TLSV13_ALERT_CERTIFICATE_REQUIRED is only available on + OpenSSL version above v1.1.1, not AWS-LC, BoringSSL, or LibreSSL */ + else if((lib == ERR_LIB_SSL) && + (reason == SSL_R_TLSV13_ALERT_CERTIFICATE_REQUIRED)) { + /* If client certificate is required, communicate the + error to client */ + result = CURLE_SSL_CLIENTCERT; + failf(data, "TLS cert problem: %s", + ossl_strerror(errdetail, error_buffer, sizeof(error_buffer))); + } +#endif +#ifdef HAVE_SSL_SET1_ECH_CONFIG_LIST + else if((lib == ERR_LIB_SSL) && +#ifndef HAVE_BORINGSSL_LIKE + (reason == SSL_R_ECH_REQUIRED)) { +#else + (reason == SSL_R_ECH_REJECTED)) { +#endif /* HAVE_BORINGSSL_LIKE */ + + /* trace retry_configs if we got some */ + ossl_trace_ech_retry_configs(data, octx->ssl, reason); + + result = CURLE_ECH_REQUIRED; + failf(data, "ECH required: %s", + ossl_strerror(errdetail, error_buffer, sizeof(error_buffer))); + } +#endif + else { + result = CURLE_SSL_CONNECT_ERROR; + failf(data, "TLS connect error: %s", + ossl_strerror(errdetail, error_buffer, sizeof(error_buffer))); + } + + /* detail is already set to the SSL error above */ + + /* If we e.g. use SSLv2 request-method and the server does not like us + * (RST connection, etc.), OpenSSL gives no explanation whatsoever and + * the SO_ERROR is also lost. + */ + if(result == CURLE_SSL_CONNECT_ERROR && errdetail == 0) { + char extramsg[80] = ""; + int sockerr = SOCKERRNO; + + if(sockerr && detail == SSL_ERROR_SYSCALL) + curlx_strerror(sockerr, extramsg, sizeof(extramsg)); + failf(data, OSSL_PACKAGE " SSL_connect: %s in connection to %s:%d ", + extramsg[0] ? extramsg : SSL_ERROR_to_str(detail), + connssl->peer.origin->hostname, connssl->peer.origin->port); + } + + return result; + } + } + else { + /* we connected fine, we are not waiting for anything else. */ + connssl->connecting_state = ssl_connect_3; + Curl_ossl_report_handshake(data, octx); + +#if defined(HAVE_SSL_SET1_ECH_CONFIG_LIST) && !defined(HAVE_BORINGSSL_LIKE) + if(CURLECH_ENABLED(data)) { + char *inner = NULL, *outer = NULL; + int rv; + VERBOSE(const char *status); + + rv = SSL_ech_get1_status(octx->ssl, &inner, &outer); + switch(rv) { + case SSL_ECH_STATUS_SUCCESS: + VERBOSE(status = "succeeded"); + break; + case SSL_ECH_STATUS_GREASE_ECH: + VERBOSE(status = "sent GREASE, got retry-configs"); + break; + case SSL_ECH_STATUS_GREASE: + VERBOSE(status = "sent GREASE"); + break; + case SSL_ECH_STATUS_NOT_TRIED: + VERBOSE(status = "not attempted"); + break; + case SSL_ECH_STATUS_NOT_CONFIGURED: + VERBOSE(status = "not configured"); + break; + case SSL_ECH_STATUS_BACKEND: + VERBOSE(status = "backend (unexpected)"); + break; + case SSL_ECH_STATUS_FAILED: + VERBOSE(status = "failed"); + break; + case SSL_ECH_STATUS_BAD_CALL: + VERBOSE(status = "bad call (unexpected)"); + break; + case SSL_ECH_STATUS_BAD_NAME: { + struct ssl_primary_config *conn_config = + Curl_ssl_cf_get_primary_config(cf); + if(!conn_config->verifypeer && !conn_config->verifyhost && + inner && !strcmp(inner, connssl->peer.origin->hostname)) { + VERBOSE(status = "bad name (tolerated without peer verification)"); + rv = SSL_ECH_STATUS_SUCCESS; + } + else { + VERBOSE(status = "bad name (unexpected)"); + } + break; + } + default: + VERBOSE(status = "unexpected status"); + infof(data, "ECH: unexpected status %d", rv); + } + infof(data, "ECH: result: status is %s, inner is %s, outer is %s", + (status ? status : "NULL"), + (inner ? inner : "NULL"), + (outer ? outer : "NULL")); + OPENSSL_free(inner); + OPENSSL_free(outer); + if(rv == SSL_ECH_STATUS_GREASE_ECH) { + /* trace retry_configs if we got some */ + ossl_trace_ech_retry_configs(data, octx->ssl, 0); + } + if(rv != SSL_ECH_STATUS_SUCCESS && (data->set.tls_ech == CURLECH_HARD)) { + infof(data, "ECH: ech-hard failed"); + return CURLE_SSL_CONNECT_ERROR; + } + } + else { + infof(data, "ECH: result: status is not attempted"); + } +#endif /* HAVE_SSL_SET1_ECH_CONFIG_LIST && !HAVE_BORINGSSL_LIKE */ + + /* Sets data and len to negotiated protocol, len is 0 if no protocol was + * negotiated + */ + if(connssl->alpn) { + const unsigned char *neg_protocol; + unsigned int len; + SSL_get0_alpn_selected(octx->ssl, &neg_protocol, &len); + + return Curl_alpn_set_negotiated(cf, data, connssl, neg_protocol, len); + } + + return CURLE_OK; + } +} + +/* + * Heavily modified from: + * https://www.owasp.org/index.php/Certificate_and_Public_Key_Pinning#OpenSSL + */ +static CURLcode ossl_pkp_pin_peer_pubkey(struct Curl_easy *data, X509 *cert, + const char *pinnedpubkey) +{ + /* Scratch */ + int len1 = 0, len2 = 0; + unsigned char *buff1 = NULL, *temp = NULL; + + /* Result is returned to caller */ + CURLcode result = CURLE_SSL_PINNEDPUBKEYNOTMATCH; + + /* if a path was not specified, do not pin */ + if(!pinnedpubkey) + return CURLE_OK; + + if(!cert) + return result; + + do { + /* Get the subjectPublicKeyInfo */ + /* https://groups.google.com/group/mailing.openssl.users/browse_thread/thread/d61858dae102c6c7 */ + len1 = i2d_X509_PUBKEY(X509_get_X509_PUBKEY(cert), NULL); + if(len1 < 1) + break; /* failed */ + + buff1 = temp = curlx_malloc(len1); + if(!buff1) + break; /* failed */ + + /* https://docs.openssl.org/master/man3/d2i_X509/ */ + len2 = i2d_X509_PUBKEY(X509_get_X509_PUBKEY(cert), &temp); + + /* + * These checks are verifying we got back the same values as when we + * sized the buffer. it is pretty weak since they should always be the + * same, but it gives us something to test. + */ + if((len1 != len2) || !temp || ((temp - buff1) != len1)) + break; /* failed */ + + /* End Gyrations */ + + /* The one good exit point */ + result = Curl_pin_peer_pubkey(data, pinnedpubkey, buff1, len1); + } while(0); + + if(buff1) + curlx_free(buff1); + + return result; +} + +#ifdef CURLVERBOSE +#if !defined(HAVE_BORINGSSL_LIKE) && \ + !(defined(LIBRESSL_VERSION_NUMBER) && LIBRESSL_VERSION_NUMBER < 0x3060000fL) +static void infof_certstack(struct Curl_easy *data, const SSL *ssl) +{ + STACK_OF(X509) *certstack; + long verify_result; + int num_cert_levels; + int cert_level; + + if(!Curl_trc_is_verbose(data)) + return; + + verify_result = SSL_get_verify_result(ssl); + if(verify_result != X509_V_OK) + certstack = SSL_get_peer_cert_chain(ssl); + else + certstack = SSL_get0_verified_chain(ssl); + if(!certstack) + return; + num_cert_levels = sk_X509_num(certstack); + + for(cert_level = 0; cert_level < num_cert_levels; cert_level++) { + char cert_algorithm[80] = ""; + char group_name_final[80] = ""; + const X509_ALGOR *palg_cert = NULL; + const ASN1_OBJECT *paobj_cert = NULL; + X509 *current_cert; + EVP_PKEY *current_pkey; + int key_bits; + int key_sec_bits; + int get_group_name; + const char *type_name; + + current_cert = sk_X509_value(certstack, cert_level); + if(!current_cert) + continue; + + current_pkey = X509_get0_pubkey(current_cert); + if(!current_pkey) + continue; + + X509_get0_signature(NULL, &palg_cert, current_cert); + X509_ALGOR_get0(&paobj_cert, NULL, NULL, palg_cert); + OBJ_obj2txt(cert_algorithm, sizeof(cert_algorithm), paobj_cert, 0); + + key_bits = EVP_PKEY_bits(current_pkey); +#ifndef HAVE_OPENSSL3 +#define EVP_PKEY_get_security_bits EVP_PKEY_security_bits +#endif + key_sec_bits = EVP_PKEY_get_security_bits(current_pkey); +#ifdef HAVE_OPENSSL3 + { + char group_name[80] = ""; + get_group_name = EVP_PKEY_get_group_name(current_pkey, group_name, + sizeof(group_name), NULL); + curl_msnprintf(group_name_final, sizeof(group_name_final), "/%s", + group_name); + } + type_name = EVP_PKEY_get0_type_name(current_pkey); +#else + get_group_name = 0; + type_name = NULL; +#endif + + infof(data, " Certificate level %d: " + "Public key type %s%s (%d/%d Bits/secBits), signed using %s", + cert_level, type_name ? type_name : "?", + get_group_name == 0 ? "" : group_name_final, + key_bits, key_sec_bits, cert_algorithm); + } +} +#else +#define infof_certstack(data, ssl) +#endif +#endif /* CURLVERBOSE */ + +static CURLcode ossl_check_issuer(struct Curl_cfilter *cf, + struct Curl_easy *data, + X509 *server_cert) +{ + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + X509 *issuer = NULL; + BIO *fp = NULL; + char err_buf[256] = ""; + bool verify_enabled = (conn_config->verifypeer || conn_config->verifyhost); + CURLcode result = CURLE_OK; + + /* e.g. match issuer name with provided issuer certificate */ + if(conn_config->issuercert_blob) { + fp = BIO_new_mem_buf(conn_config->issuercert_blob->data, + (int)conn_config->issuercert_blob->len); + if(!fp) { + failf(data, "BIO_new_mem_buf NULL, " OSSL_PACKAGE " error %s", + ossl_strerror(ERR_get_error(), err_buf, sizeof(err_buf))); + result = CURLE_OUT_OF_MEMORY; + goto out; + } + } + else if(conn_config->issuercert) { + fp = BIO_new(BIO_s_file()); + if(!fp) { + failf(data, "BIO_new return NULL, " OSSL_PACKAGE " error %s", + ossl_strerror(ERR_get_error(), err_buf, sizeof(err_buf))); + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + if(BIO_read_filename(fp, conn_config->issuercert) <= 0) { + if(verify_enabled) + failf(data, "SSL: Unable to open issuer cert (%s)", + conn_config->issuercert); + result = CURLE_SSL_ISSUER_ERROR; + goto out; + } + } + + if(fp) { + issuer = PEM_read_bio_X509(fp, NULL, ZERO_NULL, NULL); + if(!issuer) { + if(verify_enabled) + failf(data, "SSL: Unable to read issuer cert (%s)", + conn_config->issuercert); + result = CURLE_SSL_ISSUER_ERROR; + goto out; + } + + if(X509_check_issued(issuer, server_cert) != X509_V_OK) { + if(verify_enabled) + failf(data, "SSL: Certificate issuer check failed (%s)", + conn_config->issuercert); + result = CURLE_SSL_ISSUER_ERROR; + goto out; + } + + infof(data, " SSL certificate issuer check ok (%s)", + conn_config->issuercert); + } + +out: + if(fp) + BIO_free(fp); + if(issuer) + X509_free(issuer); + return result; +} + +static CURLcode ossl_check_pinned_key(struct Curl_cfilter *cf, + struct Curl_easy *data, + X509 *server_cert) +{ + const char *ptr; + CURLcode result = CURLE_OK; + + (void)cf; +#ifndef CURL_DISABLE_PROXY + ptr = Curl_ssl_cf_is_proxy(cf) ? + data->set.str[STRING_SSL_PINNEDPUBLICKEY_PROXY] : + data->set.str[STRING_SSL_PINNEDPUBLICKEY]; +#else + ptr = data->set.str[STRING_SSL_PINNEDPUBLICKEY]; +#endif + if(ptr) { + result = ossl_pkp_pin_peer_pubkey(data, server_cert, ptr); + if(result) + failf(data, "SSL: public key does not match pinned public key"); + } + return result; +} + +#ifdef CURLVERBOSE +#define MAX_CERT_NAME_LENGTH 2048 +static CURLcode ossl_infof_cert(struct Curl_cfilter *cf, + struct Curl_easy *data, + X509 *server_cert) +{ + BIO *mem = NULL; + struct dynbuf dname; + char err_buf[256] = ""; + char *buf; + long len; + CURLcode result = CURLE_OK; + + if(!Curl_trc_is_verbose(data)) + return CURLE_OK; + + curlx_dyn_init(&dname, MAX_CERT_NAME_LENGTH); + mem = BIO_new(BIO_s_mem()); + if(!mem) { + failf(data, "BIO_new return NULL, " OSSL_PACKAGE " error %s", + ossl_strerror(ERR_get_error(), err_buf, sizeof(err_buf))); + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + infof(data, "%s certificate:", Curl_ssl_cf_is_proxy(cf) ? + "Proxy" : "Server"); + + result = x509_name_oneline(X509_get_subject_name(server_cert), &dname); + infof(data, " subject: %s", result ? "[NONE]" : curlx_dyn_ptr(&dname)); + + ASN1_TIME_print(mem, X509_get0_notBefore(server_cert)); + len = BIO_get_mem_data(mem, (char **)&buf); + infof(data, " start date: %.*s", (int)len, buf); + (void)BIO_reset(mem); + + ASN1_TIME_print(mem, X509_get0_notAfter(server_cert)); + len = BIO_get_mem_data(mem, (char **)&buf); + infof(data, " expire date: %.*s", (int)len, buf); + (void)BIO_reset(mem); + + result = x509_name_oneline(X509_get_issuer_name(server_cert), &dname); + if(result) /* should be only fatal stuff like OOM */ + goto out; + infof(data, " issuer: %s", curlx_dyn_ptr(&dname)); + +out: + BIO_free(mem); + curlx_dyn_free(&dname); + return result; +} +#endif /* CURLVERBOSE */ + +#ifdef USE_APPLE_SECTRUST +struct ossl_certs_ctx { + STACK_OF(X509) *sk; + size_t num_certs; +}; + +static CURLcode ossl_chain_get_der(struct Curl_cfilter *cf, + struct Curl_easy *data, + void *user_data, + size_t i, + unsigned char **pder, + size_t *pder_len) +{ + struct ossl_certs_ctx *chain = user_data; + X509 *cert; + int der_len; + + (void)cf; + (void)data; + *pder_len = 0; + *pder = NULL; + + if(i >= chain->num_certs) + return CURLE_TOO_LARGE; + cert = sk_X509_value(chain->sk, (int)i); + if(!cert) + return CURLE_FAILED_INIT; + der_len = i2d_X509(cert, pder); + if(der_len < 0) + return CURLE_FAILED_INIT; + *pder_len = (size_t)der_len; + return CURLE_OK; +} + +static CURLcode ossl_apple_verify(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct ossl_ctx *octx, + struct ssl_peer *peer, + bool *pverified) +{ + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + struct ossl_certs_ctx chain; + CURLcode result; + + memset(&chain, 0, sizeof(chain)); + chain.sk = SSL_get_peer_cert_chain(octx->ssl); + chain.num_certs = chain.sk ? sk_X509_num(chain.sk) : 0; + + if(!chain.num_certs && + (conn_config->verifypeer || conn_config->verifyhost)) { + if(!octx->reused_session) { + failf(data, "SSL: could not get peer certificate chain"); + result = CURLE_PEER_FAILED_VERIFICATION; + } + else { + /* when session was reused, there is no peer cert chain */ + *pverified = FALSE; + return CURLE_OK; + } + } + else { +#ifdef HAVE_BORINGSSL_LIKE + const uint8_t *ocsp_data = NULL; +#else + unsigned char *ocsp_data = NULL; +#endif + long ocsp_len = 0; + bool ocsp_missing = FALSE; + if(conn_config->verifystatus && !octx->reused_session) + ocsp_len = (long)SSL_get_tlsext_status_ocsp_resp(octx->ssl, &ocsp_data); + + /* SSL_get_tlsext_status_ocsp_resp() returns the length of the OCSP + response data or -1 if there is no OCSP response data. */ + if(ocsp_len < 0) { + ocsp_len = 0; /* no data available */ + ocsp_missing = TRUE; + } + result = Curl_vtls_apple_verify(cf, data, peer, chain.num_certs, + ossl_chain_get_der, &chain, + ocsp_data, ocsp_len); + if(!result && ocsp_missing && conn_config->verifystatus && + !octx->reused_session) { + /* verified, but OCSP stapling is required and server sent none */ + *pverified = TRUE; + failf(data, "No OCSP response received"); + return CURLE_SSL_INVALIDCERTSTATUS; + } + } + *pverified = !result; + return result; +} +#endif /* USE_APPLE_SECTRUST */ + +CURLcode Curl_ossl_check_peer_cert(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct ossl_ctx *octx, + struct ssl_peer *peer) +{ + struct connectdata *conn = cf->conn; + struct ssl_config_data *ssl_config = Curl_ssl_cf_get_config(cf, data); + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + CURLcode result = CURLE_OK; + long ossl_verify; + X509 *server_cert; + bool verified = FALSE; +#if !defined(OPENSSL_NO_OCSP) && defined(USE_APPLE_SECTRUST) + bool sectrust_verified = FALSE; +#endif + + if(data->set.ssl.certinfo && !octx->reused_session) { + /* asked to gather certificate info. Reused sessions do not have cert + chains */ + result = ossl_certchain(data, octx->ssl); + if(result) + return result; + } + + server_cert = SSL_get1_peer_certificate(octx->ssl); + if(!server_cert) { + /* no verification at all, this maybe acceptable */ + if(!(conn_config->verifypeer || conn_config->verifyhost)) + goto out; + + failf(data, "SSL: could not get peer certificate"); + result = CURLE_PEER_FAILED_VERIFICATION; + goto out; + } + +#ifdef CURLVERBOSE + result = ossl_infof_cert(cf, data, server_cert); + if(result) + goto out; + infof_certstack(data, octx->ssl); +#endif + + if(conn_config->verifyhost) { + result = ossl_verifyhost(data, conn, peer, server_cert); + if(result) + goto out; + } + /* `verifyhost` is either OK or not requested from here on */ + + ossl_verify = SSL_get_verify_result(octx->ssl); + ssl_config->certverifyresult = ossl_verify; + infof(data, "OpenSSL verify result: %lx", (unsigned long)ossl_verify); + + verified = (ossl_verify == X509_V_OK); + if(verified) + infof(data, "SSL certificate verified via OpenSSL."); + +#ifdef USE_APPLE_SECTRUST + if(!verified && conn_config->verifypeer && ssl_config->native_ca_store) { + /* we verify using Apple SecTrust *unless* OpenSSL already verified. + * This may happen if the application intercepted the OpenSSL callback + * and installed its own. */ + result = ossl_apple_verify(cf, data, octx, peer, &verified); + if(result && (result != CURLE_PEER_FAILED_VERIFICATION)) + goto out; /* unexpected error */ + if(verified) { + infof(data, "SSL certificate verified via Apple SecTrust."); + ssl_config->certverifyresult = X509_V_OK; +#ifndef OPENSSL_NO_OCSP + sectrust_verified = TRUE; +#endif + } + } +#endif + + if(!verified) { + /* no trust established, report the OpenSSL status */ + if(conn_config->verifypeer) { + failf(data, "SSL certificate OpenSSL verify result: %s (%ld)", + X509_verify_cert_error_string(ossl_verify), ossl_verify); + result = CURLE_PEER_FAILED_VERIFICATION; + goto out; + } + infof(data, " SSL certificate verification failed, continuing anyway!"); + } + +#ifndef OPENSSL_NO_OCSP + if(conn_config->verifystatus && +#ifdef USE_APPLE_SECTRUST + !sectrust_verified && /* already verified via apple sectrust, cannot + * verifystate via OpenSSL in that case as it + * does not have the trust anchors */ +#endif + !octx->reused_session) { + /* do not do this after Session ID reuse */ + result = verifystatus(cf, data, octx); + if(result) + goto out; + } +#endif + + result = ossl_check_issuer(cf, data, server_cert); + if(result) + goto out; + + result = ossl_check_pinned_key(cf, data, server_cert); + +out: + X509_free(server_cert); + return result; +} + +static CURLcode ossl_connect_step3(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + CURLcode result = CURLE_OK; + struct ssl_connect_data *connssl = cf->ctx; + struct ossl_ctx *octx = (struct ossl_ctx *)connssl->backend; + + DEBUGASSERT(ssl_connect_3 == connssl->connecting_state); + + /* + * We check certificates to authenticate the server; otherwise we risk + * man-in-the-middle attack; NEVERTHELESS, if we are told explicitly not to + * verify the peer, ignore faults and failures from the server cert + * operations. + */ + + result = Curl_ossl_check_peer_cert(cf, data, octx, &connssl->peer); + if(result) + /* on error, remove sessions we might have in the pool */ + Curl_ssl_scache_remove_all(cf, data, connssl->peer.scache_key); + + return result; +} + +#ifdef HAVE_OPENSSL_EARLYDATA +static CURLcode ossl_send_earlydata(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct ossl_ctx *octx = (struct ossl_ctx *)connssl->backend; + CURLcode result = CURLE_OK; + const unsigned char *buf; + size_t blen, nwritten; + int rc; + + DEBUGASSERT(connssl->earlydata_state == ssl_earlydata_sending); + octx->io_result = CURLE_OK; + while(Curl_bufq_peek(&connssl->earlydata, &buf, &blen)) { + nwritten = 0; + rc = SSL_write_early_data(octx->ssl, buf, blen, &nwritten); + CURL_TRC_CF(data, cf, "SSL_write_early_data(len=%zu) -> %d, %zu", + blen, rc, nwritten); + if(rc <= 0) { + long sslerror; + char error_buffer[256]; + int err = SSL_get_error(octx->ssl, rc); + + switch(err) { + case SSL_ERROR_WANT_READ: + connssl->io_need = CURL_SSL_IO_NEED_RECV; + result = CURLE_AGAIN; + goto out; + case SSL_ERROR_WANT_WRITE: + connssl->io_need = CURL_SSL_IO_NEED_SEND; + result = CURLE_AGAIN; + goto out; + case SSL_ERROR_SYSCALL: { + int sockerr = SOCKERRNO; + + if(octx->io_result == CURLE_AGAIN) { + result = CURLE_AGAIN; + goto out; + } + sslerror = ERR_get_error(); + if(sslerror) + ossl_strerror(sslerror, error_buffer, sizeof(error_buffer)); + else if(sockerr) + curlx_strerror(sockerr, error_buffer, sizeof(error_buffer)); + else + curl_msnprintf(error_buffer, sizeof(error_buffer), "%s", + SSL_ERROR_to_str(err)); + + failf(data, OSSL_PACKAGE " SSL_write:early_data: %s, errno %d", + error_buffer, sockerr); + result = CURLE_SEND_ERROR; + goto out; + } + case SSL_ERROR_SSL: { + /* A failure in the SSL library occurred, usually a protocol error. + The OpenSSL error queue contains more information on the error. */ + sslerror = ERR_get_error(); + failf(data, "SSL_write_early_data() error: %s", + ossl_strerror(sslerror, error_buffer, sizeof(error_buffer))); + result = CURLE_SEND_ERROR; + goto out; + } + default: + /* a true error */ + failf(data, OSSL_PACKAGE " SSL_write_early_data: %s, errno %d", + SSL_ERROR_to_str(err), SOCKERRNO); + result = CURLE_SEND_ERROR; + goto out; + } + } + Curl_bufq_skip(&connssl->earlydata, nwritten); + } + /* sent everything there was */ + infof(data, "SSL sending %zu bytes of early data", connssl->earlydata_skip); +out: + return result; +} +#endif /* HAVE_OPENSSL_EARLYDATA */ + +static CURLcode ossl_connect(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ + CURLcode result = CURLE_OK; + struct ssl_connect_data *connssl = cf->ctx; + + /* check if the connection has already been established */ + if(ssl_connection_complete == connssl->state) { + *done = TRUE; + return CURLE_OK; + } + + *done = FALSE; + connssl->io_need = CURL_SSL_IO_NEED_NONE; + + if(ssl_connect_1 == connssl->connecting_state) { + if(Curl_ossl_need_httpsrr(data) && + !Curl_conn_dns_resolved_https(data, cf->sockindex, + connssl->peer.peer)) { + CURL_TRC_CF(data, cf, "need HTTPS-RR, delaying connect"); + return CURLE_OK; + } + CURL_TRC_CF(data, cf, "ossl_connect, step1"); + result = ossl_connect_step1(cf, data); + if(result) + goto out; + } + + if(ssl_connect_2 == connssl->connecting_state) { + CURL_TRC_CF(data, cf, "ossl_connect, step2"); +#ifdef HAVE_OPENSSL_EARLYDATA + if(connssl->earlydata_state == ssl_earlydata_await) { + goto out; + } + else if(connssl->earlydata_state == ssl_earlydata_sending) { + result = ossl_send_earlydata(cf, data); + if(result) + goto out; + connssl->earlydata_state = ssl_earlydata_sent; + } +#endif + DEBUGASSERT((connssl->earlydata_state == ssl_earlydata_none) || + (connssl->earlydata_state == ssl_earlydata_sent)); + + result = ossl_connect_step2(cf, data); + if(result) + goto out; + } + + if(ssl_connect_3 == connssl->connecting_state) { + CURL_TRC_CF(data, cf, "ossl_connect, step3"); + result = ossl_connect_step3(cf, data); + if(result) + goto out; + connssl->connecting_state = ssl_connect_done; +#ifdef HAVE_OPENSSL_EARLYDATA + if(connssl->earlydata_state > ssl_earlydata_none) { + struct ossl_ctx *octx = (struct ossl_ctx *)connssl->backend; + /* We should be in this state by now */ + DEBUGASSERT(connssl->earlydata_state == ssl_earlydata_sent); + connssl->earlydata_state = + (SSL_get_early_data_status(octx->ssl) == SSL_EARLY_DATA_ACCEPTED) ? + ssl_earlydata_accepted : ssl_earlydata_rejected; + } +#endif + } + + if(ssl_connect_done == connssl->connecting_state) { + CURL_TRC_CF(data, cf, "ossl_connect, done"); + connssl->state = ssl_connection_complete; + } + +out: + if(result == CURLE_AGAIN) { + *done = FALSE; + return CURLE_OK; + } + *done = ((connssl->state == ssl_connection_complete) || + (connssl->state == ssl_connection_deferred)); + return result; +} + +static bool ossl_data_pending(struct Curl_cfilter *cf, + const struct Curl_easy *data) +{ + struct ssl_connect_data *connssl = cf->ctx; + (void)data; + return (bool)connssl->input_pending; +} + +static CURLcode ossl_send(struct Curl_cfilter *cf, + struct Curl_easy *data, + const void *mem, + size_t len, + size_t *pnwritten) +{ + /* SSL_write() is said to return 'int' while write() and send() returns + 'size_t' */ + int err; + char error_buffer[256]; + sslerr_t sslerror; + int memlen; + struct ssl_connect_data *connssl = cf->ctx; + struct ossl_ctx *octx = (struct ossl_ctx *)connssl->backend; + CURLcode result = CURLE_OK; + int nwritten; + + DEBUGASSERT(octx); + *pnwritten = 0; + ERR_clear_error(); + + connssl->io_need = CURL_SSL_IO_NEED_NONE; + memlen = (len > (size_t)INT_MAX) ? INT_MAX : (int)len; + if(octx->blocked_ssl_write_len && (octx->blocked_ssl_write_len != memlen)) { + /* The previous SSL_write() call was blocked, using that length. + * We need to use that again or OpenSSL freaks out. A shorter + * length should not happen and is a bug in libcurl. */ + if(octx->blocked_ssl_write_len > memlen) { + DEBUGASSERT(0); + return CURLE_BAD_FUNCTION_ARGUMENT; + } + memlen = octx->blocked_ssl_write_len; + } + octx->blocked_ssl_write_len = 0; + nwritten = SSL_write(octx->ssl, mem, memlen); + + if(nwritten > 0) + *pnwritten = (size_t)nwritten; + else { + err = SSL_get_error(octx->ssl, nwritten); + + switch(err) { + case SSL_ERROR_WANT_READ: + connssl->io_need = CURL_SSL_IO_NEED_RECV; + octx->blocked_ssl_write_len = memlen; + result = CURLE_AGAIN; + goto out; + case SSL_ERROR_WANT_WRITE: + result = CURLE_AGAIN; + octx->blocked_ssl_write_len = memlen; + goto out; + case SSL_ERROR_SYSCALL: { + int sockerr = SOCKERRNO; + + if(octx->io_result == CURLE_AGAIN) { + octx->blocked_ssl_write_len = memlen; + result = CURLE_AGAIN; + goto out; + } + sslerror = ERR_get_error(); + if(sslerror) + ossl_strerror(sslerror, error_buffer, sizeof(error_buffer)); + else if(sockerr) + curlx_strerror(sockerr, error_buffer, sizeof(error_buffer)); + else + curl_msnprintf(error_buffer, sizeof(error_buffer), "%s", + SSL_ERROR_to_str(err)); + + failf(data, OSSL_PACKAGE " SSL_write: %s, errno %d", + error_buffer, sockerr); + result = CURLE_SEND_ERROR; + goto out; + } + case SSL_ERROR_SSL: { + /* A failure in the SSL library occurred, usually a protocol error. + The OpenSSL error queue contains more information on the error. */ + sslerror = ERR_get_error(); + failf(data, "SSL_write() error: %s", + ossl_strerror(sslerror, error_buffer, sizeof(error_buffer))); + result = CURLE_SEND_ERROR; + goto out; + } + default: + /* a true error */ + failf(data, OSSL_PACKAGE " SSL_write: %s, errno %d", + SSL_ERROR_to_str(err), SOCKERRNO); + result = CURLE_SEND_ERROR; + goto out; + } + } + +out: + return result; +} + +static CURLcode ossl_recv(struct Curl_cfilter *cf, + struct Curl_easy *data, /* transfer */ + char *buf, /* store read data here */ + size_t buffersize, /* max amount to read */ + size_t *pnread) +{ + char error_buffer[256]; + unsigned long sslerror; + int buffsize; + struct ssl_connect_data *connssl = cf->ctx; + struct ossl_ctx *octx = (struct ossl_ctx *)connssl->backend; + CURLcode result = CURLE_OK; + int nread; + + DEBUGASSERT(octx); + + *pnread = 0; + ERR_clear_error(); + + connssl->io_need = CURL_SSL_IO_NEED_NONE; + buffsize = (buffersize > (size_t)INT_MAX) ? INT_MAX : (int)buffersize; + nread = SSL_read(octx->ssl, buf, buffsize); + + if(nread > 0) + *pnread = (size_t)nread; + else { + /* failed SSL_read */ + int err = SSL_get_error(octx->ssl, nread); + + switch(err) { + case SSL_ERROR_NONE: /* this is not an error */ + break; + case SSL_ERROR_ZERO_RETURN: /* no more data */ + /* close_notify alert */ + if(cf->sockindex == FIRSTSOCKET) + /* mark the connection for close if it is indeed the control + connection */ + CURL_TRC_CF(data, cf, "TLS close_notify"); + break; + case SSL_ERROR_WANT_READ: + connssl->io_need = CURL_SSL_IO_NEED_RECV; + result = CURLE_AGAIN; + goto out; + case SSL_ERROR_WANT_WRITE: + connssl->io_need = CURL_SSL_IO_NEED_SEND; + result = CURLE_AGAIN; + goto out; + default: + /* openssl/ssl.h for SSL_ERROR_SYSCALL says "look at error stack/return + value/errno" */ + /* https://docs.openssl.org/master/man3/ERR_get_error/ */ + if(octx->io_result == CURLE_AGAIN) { + result = CURLE_AGAIN; + goto out; + } + sslerror = ERR_get_error(); + if((nread < 0) || sslerror) { + /* If the return code was negative or there actually is an error in the + queue */ + int sockerr = SOCKERRNO; + if(sslerror) + ossl_strerror(sslerror, error_buffer, sizeof(error_buffer)); + else if(sockerr && err == SSL_ERROR_SYSCALL) + curlx_strerror(sockerr, error_buffer, sizeof(error_buffer)); + else + curl_msnprintf(error_buffer, sizeof(error_buffer), "%s", + SSL_ERROR_to_str(err)); + failf(data, OSSL_PACKAGE " SSL_read: %s, errno %d", + error_buffer, sockerr); + result = CURLE_RECV_ERROR; + goto out; + } + else if(err == SSL_ERROR_SYSCALL) { + if(octx->io_result) { + /* logging handling in underlying filter already */ + result = octx->io_result; + } + else if(connssl->peer_closed) { + failf(data, "Connection closed abruptly"); + result = CURLE_RECV_ERROR; + } + else { + /* We should no longer get here nowadays, but handle + * the error in case of some weirdness in the OSSL stack */ + int sockerr = SOCKERRNO; + if(sockerr) + curlx_strerror(sockerr, error_buffer, sizeof(error_buffer)); + else { + curl_msnprintf(error_buffer, sizeof(error_buffer), + "Connection closed abruptly"); + } + failf(data, OSSL_PACKAGE " SSL_read: %s, errno %d", + error_buffer, sockerr); + result = CURLE_RECV_ERROR; + } + goto out; + } + } + } + +out: + if((!result && !*pnread) || (result == CURLE_AGAIN)) { + /* This happens when: + * - we read an EOF + * - OpenSSLs buffers are empty, there is no more data + * - OpenSSL read is blocked on writing something first + * - an incomplete TLS packet is buffered that cannot be read + * until more data arrives */ + connssl->input_pending = FALSE; + } + CURL_TRC_CF(data, cf, "ossl_recv(len=%zu) -> %d, %zu (in_pending=%d)", + buffersize, (int)result, *pnread, connssl->input_pending); + return result; +} + +static CURLcode ossl_get_channel_binding(struct Curl_easy *data, + int sockindex, + struct dynbuf *binding) +{ + X509 *cert; + int mdnid; + bool no_digest_acceptable = FALSE; + const EVP_MD *algo_type = NULL; + const char *algo_name = NULL; + unsigned int length; + unsigned char buf[EVP_MAX_MD_SIZE]; + + const char prefix[] = "tls-server-end-point:"; + struct connectdata *conn = data->conn; + struct Curl_cfilter *cf = conn->cfilter[sockindex]; + struct ossl_ctx *octx = NULL; + CURLcode result = CURLE_OK; + + do { + const struct Curl_cftype *cft = cf->cft; + struct ssl_connect_data *connssl = cf->ctx; + + if(cft->name && !strcmp(cft->name, "SSL")) { + octx = (struct ossl_ctx *)connssl->backend; + break; + } + + cf = cf->next; + } while(cf); + + if(!octx) { + failf(data, "Failed to find the SSL filter"); + return CURLE_BAD_FUNCTION_ARGUMENT; + } + + cert = SSL_get1_peer_certificate(octx->ssl); + if(!cert) + /* No server certificate, do not do channel binding */ + return CURLE_OK; + +#ifdef HAVE_OPENSSL3 + { + int pknid, secbits; + uint32_t flags; + EVP_PKEY *pkey = X509_get0_pubkey(cert); + + if(!X509_get_signature_info(cert, &mdnid, &pknid, &secbits, &flags)) { + failf(data, "certificate signature algorithm not recognized"); + result = CURLE_SSL_INVALIDCERTSTATUS; + goto out; + } + + if(mdnid != NID_undef) { + if(mdnid == NID_md5 || mdnid == NID_sha1) { + algo_type = EVP_sha256(); + } + else + algo_type = EVP_get_digestbynid(mdnid); + } + else if(pkey && !EVP_PKEY_is_a(pkey, OBJ_nid2sn(pknid))) { + /* The cert's pkey is different from the algorithm used to sign + * the certificate. Since the reported `mdnid` is undefined, there + * is no digest algorithm available here. This happens in PQC + * and is accepted, resulting in no addition to the binding. */ + no_digest_acceptable = TRUE; + } + else if(pkey) { + /* cert's pkey type is the same as the cert signer (or same family). + * Ask for the mandatory/advisory digest algorithm for the pkey. + */ + char mdname[128] = ""; + int rc = EVP_PKEY_get_default_digest_name(pkey, mdname, sizeof(mdname)); + bool md_is_undef = !strcmp(mdname, "UNDEF"); + + if(rc == 2 && md_is_undef) { + /* OpenSSL declares "undef" the *mandatory* digest for this key. + * This is some PQC shit, accept it, no addition to binding. */ + no_digest_acceptable = TRUE; + } + else if(rc > 0 && mdname[0] != '\0' && !md_is_undef) { + infof(data, "Digest algorithm : %s%s (derived from public key)" + ", but unavailable", + mdname, rc == 2 ? " [mandatory]" : " [advisory]"); + } + } + } +#else /* HAVE_OPENSSL3 */ + + if(!OBJ_find_sigid_algs(X509_get_signature_nid(cert), &mdnid, NULL)) { + failf(data, + "Unable to find digest NID for certificate signature algorithm"); + result = CURLE_SSL_INVALIDCERTSTATUS; + goto out; + } + + /* https://datatracker.ietf.org/doc/html/rfc5929#section-4.1 */ + if(mdnid == NID_md5 || mdnid == NID_sha1) { + algo_type = EVP_sha256(); + } + else { + algo_type = EVP_get_digestbynid(mdnid); + if(!algo_type) { + algo_name = OBJ_nid2sn(mdnid); + failf(data, "Could not find digest algorithm %s (NID %d)", + algo_name ? algo_name : "(null)", mdnid); + result = CURLE_SSL_INVALIDCERTSTATUS; + goto out; + } + } + +#endif /* HAVE_OPENSSL3, else */ + + if(!algo_type) { + if(no_digest_acceptable) { + infof(data, "certificate exposes no signing digest algorithm, " + "nothing to add to channel binding"); + result = CURLE_OK; + goto out; + } + /* unacceptable, something is wrong, fail */ + algo_name = OBJ_nid2sn(mdnid); + failf(data, "Unable to find digest algorithm %s (NID %d) " + "for channel binding", algo_name ? algo_name : "(null)", mdnid); + result = CURLE_SSL_INVALIDCERTSTATUS; + goto out; + } + + if(!X509_digest(cert, algo_type, buf, &length)) { + failf(data, "X509_digest() failed for channel binding"); + result = CURLE_SSL_INVALIDCERTSTATUS; + goto out; + } + + /* Append "tls-server-end-point:" */ + result = curlx_dyn_addn(binding, prefix, sizeof(prefix) - 1); + if(result) + goto out; + + /* Append digest */ + result = curlx_dyn_addn(binding, buf, length); + +out: + X509_free(cert); + return result; +} + +size_t Curl_ossl_version(char *buffer, size_t size) +{ +#ifdef LIBRESSL_VERSION_NUMBER + char *p; + size_t count; + const char *ver = OpenSSL_version(OPENSSL_VERSION); + const char expected[] = OSSL_PACKAGE " "; /* ie "LibreSSL " */ + if(curl_strnequal(ver, expected, sizeof(expected) - 1)) { + ver += sizeof(expected) - 1; + } + count = curl_msnprintf(buffer, size, "%s/%s", OSSL_PACKAGE, ver); + for(p = buffer; *p; ++p) { + if(ISBLANK(*p)) + *p = '_'; + } + return count; +#elif defined(OPENSSL_IS_AWSLC) + return curl_msnprintf(buffer, size, "%s/%s", + OSSL_PACKAGE, AWSLC_VERSION_NUMBER_STRING); +#elif defined(OPENSSL_IS_BORINGSSL) +#ifdef CURL_BORINGSSL_VERSION + return curl_msnprintf(buffer, size, "%s/%s", + OSSL_PACKAGE, CURL_BORINGSSL_VERSION); +#else + return curl_msnprintf(buffer, size, OSSL_PACKAGE); +#endif +#else /* OpenSSL 3+ */ + return curl_msnprintf(buffer, size, "%s/%s", + OSSL_PACKAGE, OpenSSL_version(OPENSSL_VERSION_STRING)); +#endif +} + +/* can be called with data == NULL */ +static CURLcode ossl_random(struct Curl_easy *data, + unsigned char *entropy, size_t length) +{ + int rc; + if(data) { + if(ossl_seed(data)) /* Initiate the seed if not already done */ + return CURLE_FAILED_INIT; /* could not seed for some reason */ + } + else { + if(!rand_enough()) + return CURLE_FAILED_INIT; + } + /* RAND_bytes() returns 1 on success, 0 otherwise. */ + rc = RAND_bytes(entropy, (ossl_valsize_t)curlx_uztosi(length)); + return rc == 1 ? CURLE_OK : CURLE_FAILED_INIT; +} + +static CURLcode ossl_sha256sum(const unsigned char *input, + size_t len, + unsigned char *sha256sum /* output */, + size_t unused) +{ + CURLcode result = CURLE_OK; + EVP_MD_CTX *mdctx; + (void)unused; + + mdctx = EVP_MD_CTX_create(); + if(!mdctx) + return CURLE_OUT_OF_MEMORY; + if(!EVP_DigestInit(mdctx, EVP_sha256())) { + result = CURLE_FAILED_INIT; + goto out; + } + if(!EVP_DigestUpdate(mdctx, input, len) || + !EVP_DigestFinal_ex(mdctx, sha256sum, NULL)) + result = CURLE_BAD_FUNCTION_ARGUMENT; +out: + EVP_MD_CTX_destroy(mdctx); + return result; +} + +static bool ossl_cert_status_request(void) +{ +#ifndef OPENSSL_NO_OCSP + return TRUE; +#else + return FALSE; +#endif +} + +static void *ossl_get_internals(struct ssl_connect_data *connssl, + CURLINFO info) +{ + /* Legacy: CURLINFO_TLS_SESSION must return an SSL_CTX pointer. */ + struct ossl_ctx *octx = (struct ossl_ctx *)connssl->backend; + DEBUGASSERT(octx); + return info == CURLINFO_TLS_SESSION ? + (void *)octx->ssl_ctx : (void *)octx->ssl; +} + +const struct Curl_ssl Curl_ssl_openssl = { + { CURLSSLBACKEND_OPENSSL, "openssl" }, /* info */ + + SSLSUPP_CA_PATH | + SSLSUPP_CAINFO_BLOB | + SSLSUPP_CERTINFO | + SSLSUPP_PINNEDPUBKEY | + SSLSUPP_SSL_CTX | +#ifdef HAVE_SSL_CTX_SET_CIPHERSUITES + SSLSUPP_TLS13_CIPHERSUITES | +#endif +#ifdef HAVE_SSL_CTX_SET1_SIGALGS + SSLSUPP_SIGNATURE_ALGORITHMS | +#endif +#ifdef HAVE_SSL_SET1_ECH_CONFIG_LIST + SSLSUPP_ECH | +#endif + SSLSUPP_CA_CACHE | + SSLSUPP_HTTPS_PROXY | + SSLSUPP_CIPHER_LIST | + SSLSUPP_ISSUERCERT | + SSLSUPP_ISSUERCERT_BLOB | + SSLSUPP_SSL_EC_CURVES | + SSLSUPP_CRLFILE, + + sizeof(struct ossl_ctx), + + ossl_init, /* init */ + ossl_cleanup, /* cleanup */ + Curl_ossl_version, /* version */ + ossl_shutdown, /* shutdown */ + ossl_data_pending, /* data_pending */ + ossl_random, /* random */ + ossl_cert_status_request, /* cert_status_request */ + ossl_connect, /* connect */ + Curl_ssl_adjust_pollset, /* adjust_pollset */ + ossl_get_internals, /* get_internals */ + ossl_close, /* close_one */ + ossl_close_all, /* close_all */ + ossl_set_engine, /* set_engine or provider */ + ossl_set_engine_default, /* set_engine_default */ + ossl_engines_list, /* engines_list */ + ossl_sha256sum, /* sha256sum */ + ossl_recv, /* recv decrypted data */ + ossl_send, /* send data to encrypt */ + ossl_get_channel_binding /* get_channel_binding */ +}; + +#endif /* USE_OPENSSL */ diff --git a/3rdparty/curl-8.21.0/lib/vtls/openssl.h b/3rdparty/curl-8.21.0/lib/vtls/openssl.h new file mode 100644 index 0000000000..4fa466b367 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vtls/openssl.h @@ -0,0 +1,198 @@ +#ifndef HEADER_CURL_SSLUSE_H +#define HEADER_CURL_SSLUSE_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_OPENSSL + +#ifdef USE_WIN32_CRYPTO +#include +/* If is included directly, or indirectly via , + * , , or something else, does this: + * #define X509_NAME ((LPCSTR)7) + * + * In AWC-LC/BoringSSL's there is: + * typedef struct X509_name_st X509_NAME; + * etc. + * + * The redefined symbols break these OpenSSL headers when included after + * . + * The workaround is to undefine those defines here (and only here). + * + * For unity builds it may need to be repeated elsewhere too, e.g. in ldap.c, + * to apply to other sources using OpenSSL includes. Each compilation unit + * needs undefine them between the first include and the first + * OpenSSL include. + * + * OpenSSL does this in and , but it + * also does the #undef by including . <3.1.0 only does + * it on the first include. + * + * LibreSSL automatically undefines these symbols before using them. + */ +#undef X509_NAME +#undef X509_EXTENSIONS +#undef PKCS7_ISSUER_AND_SERIAL +#undef PKCS7_SIGNER_INFO +#undef OCSP_REQUEST +#undef OCSP_RESPONSE +#endif /* USE_WIN32_CRYPTO */ + +/* + * This header should only be needed to get included by vtls.c, openssl.c + * and ngtcp2.c + */ +#include +#include +#include + +#include "urldata.h" + +#if OPENSSL_VERSION_NUMBER >= 0x30000000L +#define HAVE_OPENSSL3 /* non-fork OpenSSL 3.x or later */ +#endif + +#if defined(OPENSSL_IS_AWSLC) || defined(OPENSSL_IS_BORINGSSL) +#define HAVE_BORINGSSL_LIKE +#endif + +/* OpenSSL 3.5.0+ has built-in 'SSLKEYLOGFILE' support if built with + 'enable-sslkeylog' */ +#if OPENSSL_VERSION_NUMBER >= 0x30500000L && !defined(OPENSSL_NO_SSLKEYLOG) +#define HAVE_KEYLOG_UPSTREAM +#endif + +/* + * Whether SSL_CTX_set_keylog_callback is available. + * BoringSSL: supported since d28f59c27bac (committed 2015-11-19) + * LibreSSL: not supported. 3.5.0+ has a stub function that does nothing. + * OpenSSL: supported since 1.1.1 https://github.com/openssl/openssl/pull/2287 + */ +#ifndef LIBRESSL_VERSION_NUMBER +#define HAVE_KEYLOG_CALLBACK +#endif + +/* Check for OpenSSL 1.1.1 which has early data support. */ +#undef HAVE_OPENSSL_EARLYDATA +#if defined(TLS1_3_VERSION) && !defined(HAVE_BORINGSSL_LIKE) +#define HAVE_OPENSSL_EARLYDATA +#endif + +struct alpn_spec; +struct ssl_peer; +struct Curl_ssl_session; + +/* Struct to hold a curl OpenSSL instance */ +struct ossl_ctx { + /* these ones requires specific SSL-types */ + SSL_CTX *ssl_ctx; + SSL *ssl; + BIO_METHOD *bio_method; + CURLcode io_result; /* result of last BIO cfilter operation */ + /* blocked writes need to retry with same length, remember it */ + int blocked_ssl_write_len; +#if !defined(HAVE_KEYLOG_UPSTREAM) && !defined(HAVE_KEYLOG_CALLBACK) + /* Set to true once a valid keylog entry has been created to avoid dupes. + This is a bool and not a bitfield because it is passed by address. */ + bool keylog_done; +#endif + BIT(x509_store_setup); /* x509 store has been set up */ + BIT(store_is_empty); /* no certs/paths/blobs in x509 store */ + BIT(reused_session); /* session-ID was reused for this */ +}; + +size_t Curl_ossl_version(char *buffer, size_t size); + +typedef CURLcode Curl_ossl_ctx_setup_cb(struct Curl_cfilter *cf, + struct Curl_easy *data, + void *user_data); + +typedef int Curl_ossl_new_session_cb(SSL *ssl, SSL_SESSION *ssl_sessionid); +typedef CURLcode Curl_ossl_init_session_reuse_cb(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct alpn_spec *alpns, + struct Curl_ssl_session *scs, + bool *do_early_data); + +CURLcode Curl_ossl_ctx_init(struct ossl_ctx *octx, + struct Curl_cfilter *cf, + struct Curl_easy *data, + struct ssl_peer *peer, + const struct alpn_spec *alpns_requested, + Curl_ossl_ctx_setup_cb *cb_setup, + void *cb_user_data, + Curl_ossl_new_session_cb *cb_new_session, + void *ssl_user_data, + Curl_ossl_init_session_reuse_cb *sess_reuse_cb); + +/* Is a resolved HTTPS-RR needed for initializing OpenSSL? */ +bool Curl_ossl_need_httpsrr(struct Curl_easy *data); + +#ifndef HAVE_OPENSSL3 +#define SSL_get1_peer_certificate SSL_get_peer_certificate +#endif + +extern const struct Curl_ssl Curl_ssl_openssl; + +/** + * Setup the OpenSSL X509_STORE in `ssl_ctx` for the cfilter `cf` and + * easy handle `data`. Allows reuse of a shared cache if suitable + * and configured. + */ +CURLcode Curl_ssl_setup_x509_store(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct ossl_ctx *octx); + +CURLcode Curl_ossl_ctx_configure(struct Curl_cfilter *cf, + struct Curl_easy *data, + SSL_CTX *ssl_ctx); + +/* + * Add a new session to the cache. Takes ownership of the session. + */ +CURLcode Curl_ossl_add_session(struct Curl_cfilter *cf, + struct Curl_easy *data, + const char *ssl_peer_key, + SSL_SESSION *session, + int ietf_tls_id, + const char *alpn, + unsigned char *quic_tp, + size_t quic_tp_len); + +/* + * Get the server cert, verify it and show it, etc., only call failf() if + * SSL config verifypeer or -host is set. Otherwise all this is for + * informational purposes only! + */ +CURLcode Curl_ossl_check_peer_cert(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct ossl_ctx *octx, + struct ssl_peer *peer); + +/* Report properties of a successful handshake */ +void Curl_ossl_report_handshake(struct Curl_easy *data, struct ossl_ctx *octx); + +#endif /* USE_OPENSSL */ +#endif /* HEADER_CURL_SSLUSE_H */ diff --git a/3rdparty/curl-8.21.0/lib/vtls/rustls.c b/3rdparty/curl-8.21.0/lib/vtls/rustls.c new file mode 100644 index 0000000000..950f170212 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vtls/rustls.c @@ -0,0 +1,1468 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Jacob Hoffman-Andrews, + * Copyright (C) kpcyrd, + * Copyright (C) Daniel McCarney, + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_RUSTLS + +#include + +#include "curlx/fopen.h" +#include "curlx/strerr.h" +#include "urldata.h" +#include "cf-dns.h" +#include "curl_trc.h" +#include "httpsrr.h" +#include "vtls/vtls.h" +#include "vtls/vtls_int.h" +#include "vtls/rustls.h" +#include "vtls/keylog.h" +#include "vtls/cipher_suite.h" +#include "vtls/x509asn1.h" +#ifdef USE_ECH +#include "curlx/base64.h" +#endif + +#if EAGAIN != EWOULDBLOCK +#define RAW_EAGAIN(e) ((e) == EWOULDBLOCK || (e) == EAGAIN) +#else +#define RAW_EAGAIN(e) ((e) == EWOULDBLOCK) +#endif + +struct rustls_ssl_backend_data { + const struct rustls_client_config *config; + struct rustls_connection *conn; + size_t plain_out_buffered; + BIT(data_in_pending); + BIT(sent_shutdown); +}; + +/* For a given rustls_result error code, return the best-matching CURLcode. */ +static CURLcode map_error(const rustls_result r) +{ + if(rustls_result_is_cert_error(r)) { + return CURLE_PEER_FAILED_VERIFICATION; + } + switch(r) { + case RUSTLS_RESULT_OK: + return CURLE_OK; + case RUSTLS_RESULT_NULL_PARAMETER: + return CURLE_BAD_FUNCTION_ARGUMENT; + default: + return CURLE_RECV_ERROR; + } +} + +static void rustls_failf(struct Curl_easy *data, const rustls_result rr, + const char *msg) +{ + char errorbuf[STRERROR_LEN]; + size_t errorlen; + rustls_error(rr, errorbuf, sizeof(errorbuf), &errorlen); + failf(data, "%s: %.*s", msg, (int)errorlen, errorbuf); +} + +static bool cr_data_pending(struct Curl_cfilter *cf, + const struct Curl_easy *data) +{ + const struct ssl_connect_data *ctx = cf->ctx; + struct rustls_ssl_backend_data *backend; + + (void)data; + DEBUGASSERT(ctx && ctx->backend); + backend = (struct rustls_ssl_backend_data *)ctx->backend; + return (bool)backend->data_in_pending; +} + +struct io_ctx { + struct Curl_cfilter *cf; + struct Curl_easy *data; +}; + +static int read_cb(void *userdata, uint8_t *buf, uintptr_t len, + uintptr_t *out_n) +{ + const struct io_ctx *io_ctx = userdata; + struct ssl_connect_data * const connssl = io_ctx->cf->ctx; + CURLcode result; + int ret = 0; + size_t nread; + + result = Curl_conn_cf_recv(io_ctx->cf->next, io_ctx->data, + (char *)buf, len, &nread); + if(result) { + nread = 0; + /* !checksrc! disable ERRNOVAR 4 */ + if(result == CURLE_AGAIN) + ret = EAGAIN; + else + ret = EINVAL; + } + else if(nread == 0) + connssl->peer_closed = TRUE; + *out_n = (uintptr_t)nread; + CURL_TRC_CF(io_ctx->data, io_ctx->cf, "cf->next recv(len=%zu) -> %d, %zu", + (size_t)len, (int)result, nread); + return ret; +} + +static int write_cb(void *userdata, const uint8_t *buf, uintptr_t len, + uintptr_t *out_n) +{ + const struct io_ctx *io_ctx = userdata; + CURLcode result; + int ret = 0; + size_t nwritten; + + result = Curl_conn_cf_send(io_ctx->cf->next, io_ctx->data, + buf, len, FALSE, &nwritten); + if(result) { + nwritten = 0; + if(result == CURLE_AGAIN) + ret = EAGAIN; + else + ret = EINVAL; + } + *out_n = (uintptr_t)nwritten; + CURL_TRC_CF(io_ctx->data, io_ctx->cf, "cf->next send(len=%zu) -> %d, %zu", + len, (int)result, nwritten); + return ret; +} + +static ssize_t tls_recv_more(struct Curl_cfilter *cf, + struct Curl_easy *data, CURLcode *err) +{ + const struct ssl_connect_data * const connssl = cf->ctx; + struct rustls_ssl_backend_data * const backend = + (struct rustls_ssl_backend_data *)connssl->backend; + struct io_ctx io_ctx; + size_t tls_bytes_read = 0; + rustls_io_result io_error; + rustls_result rresult = 0; + + io_ctx.cf = cf; + io_ctx.data = data; + io_error = rustls_connection_read_tls(backend->conn, read_cb, &io_ctx, + &tls_bytes_read); + if(RAW_EAGAIN(io_error)) { + *err = CURLE_AGAIN; + return -1; + } + else if(io_error) { + char buffer[STRERROR_LEN]; + failf(data, "reading from socket: %s", + curlx_strerror(io_error, buffer, sizeof(buffer))); + *err = CURLE_RECV_ERROR; + return -1; + } + + rresult = rustls_connection_process_new_packets(backend->conn); + if(rresult != RUSTLS_RESULT_OK) { + rustls_failf(data, rresult, "rustls_connection_process_new_packets"); + *err = map_error(rresult); + return -1; + } + + backend->data_in_pending = TRUE; + *err = CURLE_OK; + return (ssize_t)tls_bytes_read; +} + +/* + * Filter receive method implementation. `plainbuf` and `plainlen` + * are always not NULL/0. + */ +static CURLcode cr_recv(struct Curl_cfilter *cf, struct Curl_easy *data, + char *plainbuf, size_t plainlen, size_t *pnread) +{ + const struct ssl_connect_data * const connssl = cf->ctx; + struct rustls_ssl_backend_data * const backend = + (struct rustls_ssl_backend_data *)connssl->backend; + struct rustls_connection *rconn = NULL; + CURLcode result = CURLE_OK; + size_t n = 0; + rustls_result rresult = 0; + bool eof = FALSE; + + DEBUGASSERT(backend); + *pnread = 0; + rconn = backend->conn; + + while(*pnread < plainlen) { + if(!backend->data_in_pending) { + if(tls_recv_more(cf, data, &result) < 0) { + if(result != CURLE_AGAIN) { + goto out; + } + result = CURLE_OK; + break; + } + } + + rresult = rustls_connection_read(rconn, + (uint8_t *)plainbuf + *pnread, + plainlen - *pnread, + &n); + if(rresult == RUSTLS_RESULT_PLAINTEXT_EMPTY) { + backend->data_in_pending = FALSE; + } + else if(rresult == RUSTLS_RESULT_UNEXPECTED_EOF) { + failf(data, "rustls: peer closed TCP connection " + "without first closing TLS connection"); + result = CURLE_RECV_ERROR; + goto out; + } + else if(rresult != RUSTLS_RESULT_OK) { + /* n always equals 0 in this case, do not need to check it */ + rustls_failf(data, rresult, "rustls_connection_read"); + result = CURLE_RECV_ERROR; + goto out; + } + else if(n == 0) { + /* n == 0 indicates clean EOF, but we may have read some other + plaintext bytes before we reached this. Break out of the loop + so we can figure out whether to return success or EOF. */ + eof = TRUE; + break; + } + else { + *pnread += n; + } + } + + if(!eof && !*pnread) { + result = CURLE_AGAIN; + } + +out: + CURL_TRC_CF(data, cf, "rustls_recv(len=%zu) -> %d, %zu", + plainlen, (int)result, *pnread); + return result; +} + +static CURLcode cr_flush_out(struct Curl_cfilter *cf, struct Curl_easy *data, + struct rustls_connection *rconn) +{ + struct io_ctx io_ctx; + rustls_io_result io_error; + size_t tlswritten = 0; + size_t tlswritten_total = 0; + + io_ctx.cf = cf; + io_ctx.data = data; + + while(rustls_connection_wants_write(rconn)) { + io_error = rustls_connection_write_tls(rconn, write_cb, &io_ctx, + &tlswritten); + if(RAW_EAGAIN(io_error)) { + CURL_TRC_CF(data, cf, "cf_send: EAGAIN after %zu bytes", + tlswritten_total); + return CURLE_AGAIN; + } + else if(io_error) { + char buffer[STRERROR_LEN]; + failf(data, "writing to socket: %s", + curlx_strerror(io_error, buffer, sizeof(buffer))); + return CURLE_SEND_ERROR; + } + if(tlswritten == 0) { + failf(data, "EOF in swrite"); + return CURLE_SEND_ERROR; + } + CURL_TRC_CF(data, cf, "cf_send: wrote %zu TLS bytes", tlswritten); + tlswritten_total += tlswritten; + } + return CURLE_OK; +} + +/* + * On each call: + * - Copy `plainlen` bytes into Rustls' plaintext input buffer (if > 0). + * - Fully drain Rustls' plaintext output buffer into the socket until + * we get either an error or EAGAIN/EWOULDBLOCK. + * + * it is okay to call this function with plainbuf == NULL and plainlen == 0. + * In that case, it does not read anything into Rustls' plaintext input buffer. + * It only drains Rustls' plaintext output buffer into the socket. + */ +static CURLcode cr_send(struct Curl_cfilter *cf, struct Curl_easy *data, + const void *plainbuf, size_t plainlen, + size_t *pnwritten) +{ + const struct ssl_connect_data * const connssl = cf->ctx; + struct rustls_ssl_backend_data * const backend = + (struct rustls_ssl_backend_data *)connssl->backend; + struct rustls_connection *rconn = NULL; + size_t plainwritten = 0; + const unsigned char *buf = plainbuf; + CURLcode result = CURLE_OK; + size_t blen = plainlen; + + DEBUGASSERT(backend); + *pnwritten = 0; + rconn = backend->conn; + DEBUGASSERT(rconn); + + CURL_TRC_CF(data, cf, "cf_send(len=%zu)", plainlen); + + /* If a previous send blocked, we already added its plain bytes + * to rustsls and must not do that again. Flush the TLS bytes and, + * if successful, deduct the previous plain bytes from the current + * send. */ + if(backend->plain_out_buffered) { + result = cr_flush_out(cf, data, rconn); + CURL_TRC_CF(data, cf, "cf_send: flushing %zu previously added bytes -> %d", + backend->plain_out_buffered, (int)result); + if(result) + return result; + if(blen > backend->plain_out_buffered) { + blen -= backend->plain_out_buffered; + buf += backend->plain_out_buffered; + } + else + blen = 0; + *pnwritten += backend->plain_out_buffered; + backend->plain_out_buffered = 0; + } + + if(blen > 0) { + rustls_result rresult; + CURL_TRC_CF(data, cf, "cf_send: adding %zu plain bytes to Rustls", blen); + rresult = rustls_connection_write(rconn, buf, blen, &plainwritten); + if(rresult != RUSTLS_RESULT_OK) { + rustls_failf(data, rresult, "rustls_connection_write"); + result = CURLE_WRITE_ERROR; + goto out; + } + else if(plainwritten == 0) { + failf(data, "rustls_connection_write: EOF"); + result = CURLE_WRITE_ERROR; + goto out; + } + } + + result = cr_flush_out(cf, data, rconn); + if(result) { + if(result == CURLE_AGAIN) { + /* The TLS bytes may have been partially written, but we fail the + * complete send() and remember how much we already added to Rustls. */ + backend->plain_out_buffered = plainwritten; + if(*pnwritten) { + result = CURLE_OK; + } + } + goto out; + } + else + *pnwritten += plainwritten; + +out: + CURL_TRC_CF(data, cf, "rustls_send(len=%zu) -> %d, %zu", + plainlen, (int)result, *pnwritten); + return result; +} + +/* A server certificate verify callback for Rustls that always returns + RUSTLS_RESULT_OK, or in other words disable certificate verification. */ +static uint32_t cr_verify_none(void *userdata, + const rustls_verify_server_cert_params *params) +{ + (void)userdata; + (void)params; + return RUSTLS_RESULT_OK; +} + +static int read_file_into(const char *filename, struct dynbuf *out) +{ + FILE *f = curlx_fopen(filename, FOPEN_READTEXT); + if(!f) { + return 0; + } + + for(;;) { + uint8_t buf[256]; + const size_t rr = fread(buf, 1, sizeof(buf), f); + if((!rr && !feof(f)) || + curlx_dyn_addn(out, buf, rr)) { + curlx_fclose(f); + return 0; + } + if(rr < sizeof(buf)) + break; + } + + return curlx_fclose(f) == 0; +} + +static void +cr_get_selected_ciphers(struct Curl_easy *data, + const char *ciphers12, + const char *ciphers13, + const struct rustls_supported_ciphersuite **selected, + size_t *selected_size) +{ + const size_t supported_len = *selected_size; + const size_t default_len = rustls_default_crypto_provider_ciphersuites_len(); + const struct rustls_supported_ciphersuite *entry = NULL; + const char *ciphers = ciphers12; + size_t count = 0, default13_count = 0, i, j; + const char *ptr, *end; + + DEBUGASSERT(default_len <= supported_len); + + if(!ciphers13) { + /* Add default TLSv1.3 ciphers to selection */ + for(j = 0; j < default_len; j++) { + entry = rustls_default_crypto_provider_ciphersuites_get(j); + if(rustls_supported_ciphersuite_protocol_version(entry) != + RUSTLS_TLS_VERSION_TLSV1_3) + continue; + + selected[count++] = entry; + } + + default13_count = count; + + if(!ciphers) + ciphers = ""; + } + else + ciphers = ciphers13; + +add_ciphers: + for(ptr = ciphers; ptr[0] != '\0' && count < supported_len; ptr = end) { + uint16_t id = Curl_cipher_suite_walk_str(&ptr, &end); + + /* Check if cipher is supported */ + if(id) { + for(i = 0; i < supported_len; i++) { + entry = rustls_default_crypto_provider_ciphersuites_get(i); + if(rustls_supported_ciphersuite_get_suite(entry) == id) + break; + } + if(i == supported_len) + id = 0; + } + if(!id) { + if(ptr[0] != '\0') + infof(data, "rustls: unknown cipher in list: \"%.*s\"", + (int)(end - ptr), ptr); + continue; + } + + /* No duplicates allowed (so selected cannot overflow) */ + for(i = 0; i < count && selected[i] != entry; i++) + ; + if(i < count) { + if(i >= default13_count) + infof(data, "rustls: duplicate cipher in list: \"%.*s\"", + (int)(end - ptr), ptr); + continue; + } + + selected[count++] = entry; + } + + if(ciphers == ciphers13 && ciphers12) { + ciphers = ciphers12; + goto add_ciphers; + } + + if(!ciphers12) { + /* Add default TLSv1.2 ciphers to selection */ + for(j = 0; j < default_len; j++) { + entry = rustls_default_crypto_provider_ciphersuites_get(j); + if(rustls_supported_ciphersuite_protocol_version(entry) == + RUSTLS_TLS_VERSION_TLSV1_3) + continue; + + /* No duplicates allowed (so selected cannot overflow) */ + for(i = 0; i < count && selected[i] != entry; i++) + ; + if(i < count) + continue; + + selected[count++] = entry; + } + } + + *selected_size = count; +} + +static void cr_keylog_log_cb(struct rustls_str label, + const uint8_t *client_random, + size_t client_random_len, const uint8_t *secret, + size_t secret_len) +{ + char clabel[KEYLOG_LABEL_MAXLEN]; + (void)client_random_len; + DEBUGASSERT(client_random_len == CLIENT_RANDOM_SIZE); + /* Turning a "rustls_str" into a null delimited "c" string */ + curl_msnprintf(clabel, sizeof(clabel), "%.*s", (int)label.len, label.data); + Curl_tls_keylog_write(clabel, client_random, secret, secret_len); +} + +static CURLcode +init_config_builder(struct Curl_easy *data, + const struct ssl_primary_config *conn_config, + struct rustls_client_config_builder **config_builder) +{ + const struct rustls_supported_ciphersuite **cipher_suites = NULL; + struct rustls_crypto_provider_builder *custom_provider_builder = NULL; + const struct rustls_crypto_provider *custom_provider = NULL; + + uint16_t tls_versions[2] = { + RUSTLS_TLS_VERSION_TLSV1_2, + RUSTLS_TLS_VERSION_TLSV1_3, + }; + size_t tls_versions_len = 2; + size_t cipher_suites_len = rustls_default_crypto_provider_ciphersuites_len(); + + CURLcode result = CURLE_OK; + rustls_result rr; + + DEBUGASSERT(conn_config->version != CURL_SSLVERSION_DEFAULT); + switch(conn_config->version) { + case CURL_SSLVERSION_TLSv1: + case CURL_SSLVERSION_TLSv1_0: + case CURL_SSLVERSION_TLSv1_1: + case CURL_SSLVERSION_TLSv1_2: + break; + case CURL_SSLVERSION_TLSv1_3: + tls_versions[0] = RUSTLS_TLS_VERSION_TLSV1_3; + tls_versions_len = 1; + break; + default: + failf(data, "rustls: unsupported minimum TLS version value"); + result = CURLE_BAD_FUNCTION_ARGUMENT; + goto cleanup; + } + + switch(conn_config->version_max) { + case CURL_SSLVERSION_MAX_DEFAULT: + case CURL_SSLVERSION_MAX_NONE: + case CURL_SSLVERSION_MAX_TLSv1_3: + break; + case CURL_SSLVERSION_MAX_TLSv1_2: + if(tls_versions[0] == RUSTLS_TLS_VERSION_TLSV1_2) { + tls_versions_len = 1; + break; + } + FALLTHROUGH(); + case CURL_SSLVERSION_MAX_TLSv1_1: + case CURL_SSLVERSION_MAX_TLSv1_0: + default: + failf(data, "rustls: unsupported maximum TLS version value"); + result = CURLE_BAD_FUNCTION_ARGUMENT; + goto cleanup; + } + +#ifdef USE_ECH + if(CURLECH_ENABLED(data)) { + tls_versions[0] = RUSTLS_TLS_VERSION_TLSV1_3; + tls_versions_len = 1; + infof(data, "rustls: ECH enabled, forcing TLSv1.3"); + } +#endif /* USE_ECH */ + + cipher_suites = curlx_malloc(sizeof(*cipher_suites) * cipher_suites_len); + if(!cipher_suites) { + result = CURLE_OUT_OF_MEMORY; + goto cleanup; + } + + cr_get_selected_ciphers(data, + conn_config->cipher_list, + conn_config->cipher_list13, + cipher_suites, &cipher_suites_len); + if(cipher_suites_len == 0) { + failf(data, "rustls: no supported cipher in list"); + result = CURLE_SSL_CIPHER; + goto cleanup; + } + + rr = rustls_crypto_provider_builder_new_from_default( + &custom_provider_builder); + if(rr != RUSTLS_RESULT_OK) { + rustls_failf(data, rr, + "failed to create crypto provider builder from default"); + result = CURLE_SSL_CIPHER; + goto cleanup; + } + + rr = + rustls_crypto_provider_builder_set_cipher_suites( + custom_provider_builder, + cipher_suites, + cipher_suites_len); + if(rr != RUSTLS_RESULT_OK) { + rustls_failf(data, rr, + "failed to set ciphersuites for crypto provider builder"); + result = CURLE_SSL_CIPHER; + goto cleanup; + } + + rr = rustls_crypto_provider_builder_build(custom_provider_builder, + &custom_provider); + if(rr != RUSTLS_RESULT_OK) { + rustls_failf(data, rr, "failed to build custom crypto provider"); + result = CURLE_SSL_CIPHER; + goto cleanup; + } + + rr = rustls_client_config_builder_new_custom(custom_provider, + tls_versions, + tls_versions_len, + config_builder); + if(rr != RUSTLS_RESULT_OK) { + rustls_failf(data, rr, "failed to create client config builder"); + result = CURLE_SSL_CIPHER; + goto cleanup; + } + +cleanup: + if(cipher_suites) { + curlx_free(cipher_suites); + } + if(custom_provider_builder) { + rustls_crypto_provider_builder_free(custom_provider_builder); + } + if(custom_provider) { + rustls_crypto_provider_free(custom_provider); + } + return result; +} + +static void +init_config_builder_alpn(struct Curl_easy *data, + const struct ssl_connect_data *connssl, + struct rustls_client_config_builder *config_builder) +{ + struct alpn_proto_buf proto; + rustls_slice_bytes alpn[ALPN_ENTRIES_MAX]; + size_t i; + + for(i = 0; i < connssl->alpn->count; ++i) { + alpn[i].data = (const uint8_t *)connssl->alpn->entries[i]; + alpn[i].len = strlen(connssl->alpn->entries[i]); + } + rustls_client_config_builder_set_alpn_protocols(config_builder, alpn, + connssl->alpn->count); + Curl_alpn_to_proto_str(&proto, connssl->alpn); + infof(data, VTLS_INFOF_ALPN_OFFER_1STR, proto.data); +} + +static CURLcode init_config_builder_verifier_crl( + struct Curl_easy *data, + const struct ssl_primary_config *conn_config, + struct rustls_web_pki_server_cert_verifier_builder *builder) +{ + CURLcode result = CURLE_OK; + struct dynbuf crl_contents; + rustls_result rr; + + curlx_dyn_init(&crl_contents, DYN_CRLFILE_SIZE); + if(!read_file_into(conn_config->CRLfile, &crl_contents)) { + failf(data, "rustls: failed to read revocation list file"); + result = CURLE_SSL_CRL_BADFILE; + goto cleanup; + } + + rr = rustls_web_pki_server_cert_verifier_builder_add_crl( + builder, + curlx_dyn_uptr(&crl_contents), + curlx_dyn_len(&crl_contents)); + if(rr != RUSTLS_RESULT_OK) { + rustls_failf(data, rr, "failed to parse revocation list"); + result = CURLE_SSL_CRL_BADFILE; + goto cleanup; + } + +cleanup: + curlx_dyn_free(&crl_contents); + return result; +} + +static CURLcode +init_config_builder_verifier(struct Curl_easy *data, + struct rustls_client_config_builder *builder, + const struct ssl_primary_config *conn_config, + const struct curl_blob *ca_info_blob, + const char * const ssl_cafile) +{ + const struct rustls_root_cert_store *roots = NULL; + struct rustls_root_cert_store_builder *roots_builder = NULL; + struct rustls_web_pki_server_cert_verifier_builder *verifier_builder = NULL; + struct rustls_server_cert_verifier *server_cert_verifier = NULL; + rustls_result rr = RUSTLS_RESULT_OK; + CURLcode result = CURLE_OK; + + roots_builder = rustls_root_cert_store_builder_new(); + if(ca_info_blob) { + rr = rustls_root_cert_store_builder_add_pem(roots_builder, + ca_info_blob->data, + ca_info_blob->len, + 1); + if(rr != RUSTLS_RESULT_OK) { + rustls_failf(data, rr, "failed to parse trusted certificates from blob"); + result = CURLE_SSL_CACERT_BADFILE; + goto cleanup; + } + } + else if(ssl_cafile) { + rr = rustls_root_cert_store_builder_load_roots_from_file(roots_builder, + ssl_cafile, + 1); + if(rr != RUSTLS_RESULT_OK) { + rustls_failf(data, rr, "failed to load trusted certificates"); + result = CURLE_SSL_CACERT_BADFILE; + goto cleanup; + } + } + + rr = rustls_root_cert_store_builder_build(roots_builder, &roots); + if(rr != RUSTLS_RESULT_OK) { + rustls_failf(data, rr, "failed to build trusted root certificate store"); + result = CURLE_SSL_CACERT_BADFILE; + goto cleanup; + } + + verifier_builder = rustls_web_pki_server_cert_verifier_builder_new(roots); + if(!verifier_builder) { + result = CURLE_OUT_OF_MEMORY; + goto cleanup; + } + + if(conn_config->CRLfile) { + result = init_config_builder_verifier_crl(data, + conn_config, + verifier_builder); + if(result) { + goto cleanup; + } + } + + rr = rustls_web_pki_server_cert_verifier_builder_build( + verifier_builder, &server_cert_verifier); + if(rr != RUSTLS_RESULT_OK) { + rustls_failf(data, rr, "failed to build certificate verifier"); + result = CURLE_SSL_CACERT_BADFILE; + goto cleanup; + } + + rustls_client_config_builder_set_server_verifier(builder, + server_cert_verifier); +cleanup: + if(roots_builder) { + rustls_root_cert_store_builder_free(roots_builder); + } + if(roots) { + rustls_root_cert_store_free(roots); + } + if(verifier_builder) { + rustls_web_pki_server_cert_verifier_builder_free(verifier_builder); + } + if(server_cert_verifier) { + rustls_server_cert_verifier_free(server_cert_verifier); + } + + return result; +} + +static CURLcode init_config_builder_platform_verifier( + struct Curl_easy *data, + struct rustls_client_config_builder *builder) +{ + struct rustls_server_cert_verifier *server_cert_verifier = NULL; + CURLcode result = CURLE_OK; + rustls_result rr; + + rr = rustls_platform_server_cert_verifier(&server_cert_verifier); + if(rr != RUSTLS_RESULT_OK) { + rustls_failf(data, rr, "failed to create platform certificate verifier"); + result = CURLE_SSL_CACERT_BADFILE; + goto cleanup; + } + + rustls_client_config_builder_set_server_verifier(builder, + server_cert_verifier); + +cleanup: + if(server_cert_verifier) { + rustls_server_cert_verifier_free(server_cert_verifier); + } + return result; +} + +static CURLcode +init_config_builder_keylog(struct Curl_easy *data, + struct rustls_client_config_builder *builder) +{ + rustls_result rr; + + Curl_tls_keylog_open(); + if(!Curl_tls_keylog_enabled()) { + return CURLE_OK; + } + + rr = rustls_client_config_builder_set_key_log(builder, + cr_keylog_log_cb, + NULL); + if(rr != RUSTLS_RESULT_OK) { + rustls_failf(data, rr, "rustls_client_config_builder_set_key_log"); + Curl_tls_keylog_close(); + return map_error(rr); + } + + return CURLE_OK; +} + +static CURLcode +init_config_builder_client_auth(struct Curl_easy *data, + const struct ssl_primary_config *conn_config, + const struct ssl_config_data *ssl_config, + struct rustls_client_config_builder *builder) +{ + struct dynbuf cert_contents; + struct dynbuf key_contents; + rustls_result rr; + const struct rustls_certified_key *certified_key = NULL; + CURLcode result = CURLE_OK; + + if(conn_config->clientcert && !ssl_config->primary.key) { + failf(data, "rustls: must provide key with certificate '%s'", + conn_config->clientcert); + return CURLE_SSL_CERTPROBLEM; + } + else if(!conn_config->clientcert && ssl_config->primary.key) { + failf(data, "rustls: must provide certificate with key '%s'", + ssl_config->primary.key); + return CURLE_SSL_CERTPROBLEM; + } + + curlx_dyn_init(&cert_contents, DYN_CERTFILE_SIZE); + curlx_dyn_init(&key_contents, DYN_KEYFILE_SIZE); + + if(!read_file_into(conn_config->clientcert, &cert_contents)) { + failf(data, "rustls: failed to read client certificate file: '%s'", + conn_config->clientcert); + result = CURLE_SSL_CERTPROBLEM; + goto cleanup; + } + + if(!read_file_into(ssl_config->primary.key, &key_contents)) { + failf(data, "rustls: failed to read key file: '%s'", + ssl_config->primary.key); + result = CURLE_SSL_CERTPROBLEM; + goto cleanup; + } + + rr = rustls_certified_key_build(curlx_dyn_uptr(&cert_contents), + curlx_dyn_len(&cert_contents), + curlx_dyn_uptr(&key_contents), + curlx_dyn_len(&key_contents), + &certified_key); + if(rr != RUSTLS_RESULT_OK) { + rustls_failf(data, rr, "rustls: failed to build certified key"); + result = CURLE_SSL_CERTPROBLEM; + goto cleanup; + } + + rr = rustls_certified_key_keys_match(certified_key); + if(rr != RUSTLS_RESULT_OK) { + rustls_failf(data, rr, + "rustls: client certificate and keypair files do not match:"); + result = CURLE_SSL_CERTPROBLEM; + goto cleanup; + } + + rr = rustls_client_config_builder_set_certified_key(builder, + &certified_key, + 1); + if(rr != RUSTLS_RESULT_OK) { + rustls_failf(data, rr, "rustls: failed to set certified key"); + result = CURLE_SSL_CERTPROBLEM; + goto cleanup; + } + +cleanup: + curlx_dyn_free(&cert_contents); + curlx_dyn_free(&key_contents); + if(certified_key) { + rustls_certified_key_free(certified_key); + } + return result; +} + +#ifdef USE_ECH + +static bool cr_ech_need_httpsrr(struct Curl_easy *data) +{ + if(!CURLECH_ENABLED(data)) + return FALSE; + if((data->set.tls_ech == CURLECH_GREASE) || + data->set.str[STRING_ECH_CONFIG]) + return FALSE; + return TRUE; +} + +static CURLcode +init_config_builder_ech(struct Curl_easy *data, + struct Curl_cfilter *cf, + struct rustls_client_config_builder *builder) +{ + const rustls_hpke *hpke = rustls_supported_hpke(); + unsigned char *ech_config = NULL; + size_t ech_config_len = 0; + struct Curl_dns_entry *dns = NULL; + CURLcode result = CURLE_OK; + rustls_result rr; + + if(!hpke) { + failf(data, + "rustls: ECH unavailable, rustls-ffi built without " + "HPKE compatible crypto provider"); + result = CURLE_SSL_CONNECT_ERROR; + goto cleanup; + } + + if(data->set.str[STRING_ECH_PUBLIC]) { + failf(data, "rustls: ECH outername not supported"); + result = CURLE_SSL_CONNECT_ERROR; + goto cleanup; + } + + if(data->set.tls_ech == CURLECH_GREASE) { + rr = rustls_client_config_builder_enable_ech_grease(builder, hpke); + if(rr != RUSTLS_RESULT_OK) { + rustls_failf(data, rr, "rustls: failed to configure ECH GREASE"); + result = CURLE_SSL_CONNECT_ERROR; + goto cleanup; + } + return CURLE_OK; + } + + if(data->set.tls_ech && data->set.str[STRING_ECH_CONFIG]) { + const char *b64 = data->set.str[STRING_ECH_CONFIG]; + size_t decode_result; + if(!b64) { + infof(data, "rustls: ECHConfig from command line empty"); + result = CURLE_SSL_CONNECT_ERROR; + goto cleanup; + } + /* rustls-ffi expects the raw TLS encoded ECHConfigList bytes */ + decode_result = curlx_base64_decode(b64, &ech_config, &ech_config_len); + if(decode_result || !ech_config) { + infof(data, "rustls: cannot base64 decode ECHConfig from command line"); + result = CURLE_SSL_CONNECT_ERROR; + goto cleanup; + } + } + else { + const struct ssl_connect_data *connssl = cf->ctx; + const struct Curl_https_rrinfo *rinfo = + Curl_conn_dns_get_https(data, cf->sockindex, connssl->peer.origin); + + if(!rinfo || !rinfo->echconfiglist) { + failf(data, "rustls: ECH requested but no ECHConfig available"); + result = CURLE_SSL_CONNECT_ERROR; + goto cleanup; + } + ech_config = rinfo->echconfiglist; + ech_config_len = rinfo->echconfiglist_len; + } + + rr = rustls_client_config_builder_enable_ech(builder, + ech_config, + ech_config_len, + hpke); + if(rr != RUSTLS_RESULT_OK) { + rustls_failf(data, rr, "rustls: failed to configure ECH"); + result = CURLE_SSL_CONNECT_ERROR; + goto cleanup; + } +cleanup: + /* if we base64 decoded, we can free now */ + if(data->set.tls_ech && data->set.str[STRING_ECH_CONFIG]) { + curlx_free(ech_config); + } + if(dns) { + Curl_dns_entry_unlink(data, &dns); + } + return result; +} +#endif /* USE_ECH */ + +static CURLcode cr_init_backend(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct rustls_ssl_backend_data * const backend) +{ + const struct ssl_connect_data *connssl = cf->ctx; + const struct ssl_primary_config *conn_config = + Curl_ssl_cf_get_primary_config(cf); + struct ssl_config_data *ssl_config = Curl_ssl_cf_get_config(cf, data); + struct rustls_connection *rconn = NULL; + struct rustls_client_config_builder *config_builder = NULL; + + const struct curl_blob *ca_info_blob = conn_config->ca_info_blob; + const char * const ssl_cafile = + /* CURLOPT_CAINFO_BLOB overrides CURLOPT_CAINFO */ + (ca_info_blob ? NULL : conn_config->CAfile); + CURLcode result = CURLE_OK; + rustls_result rr; + + DEBUGASSERT(backend); + rconn = backend->conn; + + result = init_config_builder(data, conn_config, &config_builder); + if(result != CURLE_OK) { + return result; + } + + if(connssl->alpn) { + init_config_builder_alpn(data, connssl, config_builder); + } + + if(!conn_config->verifypeer) { + rustls_client_config_builder_dangerous_set_certificate_verifier( + config_builder, cr_verify_none); + } + else if(ssl_config->native_ca_store) { + if(conn_config->CRLfile) { + failf(data, "rustls: CRL file not supported with native CA store; " + "the platform verifier has no CRL attachment API"); + rustls_client_config_builder_free(config_builder); + return CURLE_NOT_BUILT_IN; + } + result = init_config_builder_platform_verifier(data, config_builder); + if(result != CURLE_OK) { + rustls_client_config_builder_free(config_builder); + return result; + } + } + else if(ca_info_blob || ssl_cafile) { + result = init_config_builder_verifier(data, + config_builder, + conn_config, + ca_info_blob, + ssl_cafile); + if(result != CURLE_OK) { + rustls_client_config_builder_free(config_builder); + return result; + } + } + + if(conn_config->clientcert || ssl_config->primary.key) { + result = init_config_builder_client_auth(data, + conn_config, + ssl_config, + config_builder); + if(result != CURLE_OK) { + rustls_client_config_builder_free(config_builder); + return result; + } + } + +#ifdef USE_ECH + if(CURLECH_ENABLED(data)) { + result = init_config_builder_ech(data, cf, config_builder); + if((result != CURLE_OK) && (data->set.tls_ech == CURLECH_HARD)) { + rustls_client_config_builder_free(config_builder); + return result; + } + } +#endif /* USE_ECH */ + + result = init_config_builder_keylog(data, config_builder); + if(result != CURLE_OK) { + rustls_client_config_builder_free(config_builder); + return result; + } + + rr = rustls_client_config_builder_build(config_builder, &backend->config); + if(rr != RUSTLS_RESULT_OK) { + rustls_failf(data, rr, "failed to build client config"); + return CURLE_SSL_CONNECT_ERROR; + } + + DEBUGASSERT(!rconn); + rr = rustls_client_connection_new(backend->config, + connssl->peer.origin->hostname, + &rconn); + if(rr != RUSTLS_RESULT_OK) { + rustls_failf(data, rr, "rustls_client_connection_new"); + rustls_client_config_free(backend->config); + backend->config = NULL; + return CURLE_COULDNT_CONNECT; + } + DEBUGASSERT(rconn); + rustls_connection_set_userdata(rconn, backend); + backend->conn = rconn; + + return result; +} + +static void cr_set_negotiated_alpn(struct Curl_cfilter *cf, + struct Curl_easy *data, + const struct rustls_connection *rconn) +{ + struct ssl_connect_data * const connssl = cf->ctx; + const uint8_t *protocol = NULL; + size_t len = 0; + + rustls_connection_get_alpn_protocol(rconn, &protocol, &len); + Curl_alpn_set_negotiated(cf, data, connssl, protocol, len); +} + +/* Given an established network connection, do a TLS handshake. + * + * This function sets `*done` to true once the handshake is complete. + * This function never reads the value of `*done*`. + */ +static CURLcode cr_connect(struct Curl_cfilter *cf, struct Curl_easy *data, + bool *done) +{ + struct ssl_connect_data * const connssl = cf->ctx; + const struct rustls_ssl_backend_data * const backend = + (struct rustls_ssl_backend_data *)connssl->backend; + const struct rustls_connection *rconn = NULL; + CURLcode tmperr = CURLE_OK; + CURLcode result; + bool wants_read; + bool wants_write; + ssize_t nread; + + DEBUGASSERT(backend); + + CURL_TRC_CF(data, cf, "cr_connect, state=%d", (int)connssl->state); + *done = FALSE; + +#ifdef USE_ECH + /* if we do ECH and need the HTTPS-RR information for it, + * we delay the connect until it arrives or DNS resolve fails. */ + if(cr_ech_need_httpsrr(data) && + !Curl_conn_dns_resolved_https(data, cf->sockindex, + connssl->peer.peer)) { + CURL_TRC_CF(data, cf, "need HTTPS-RR for ECH, delaying connect"); + return CURLE_OK; + } +#endif /* USE_ECH */ + + if(!backend->conn) { + result = + cr_init_backend(cf, data, + (struct rustls_ssl_backend_data *)connssl->backend); + CURL_TRC_CF(data, cf, "cr_connect, init backend -> %d", (int)result); + if(result) + return result; + connssl->state = ssl_connection_negotiating; + } + rconn = backend->conn; + + /* Read/write data until the handshake is done or the socket would block. */ + for(;;) { + /* + * Connection has been established according to Rustls. Set send/recv + * handlers, and update the state machine. + */ + connssl->io_need = CURL_SSL_IO_NEED_NONE; + if(!rustls_connection_is_handshaking(rconn)) { + /* Rustls claims it is no longer handshaking *before* it has + * send its FINISHED message off. We attempt to let it write + * one more time. Oh my. + */ + size_t nwritten; + cr_set_negotiated_alpn(cf, data, rconn); + tmperr = cr_send(cf, data, NULL, 0, &nwritten); + if(tmperr == CURLE_AGAIN) { + connssl->io_need = CURL_SSL_IO_NEED_SEND; + return CURLE_OK; + } + else if(tmperr != CURLE_OK) { + return tmperr; + } + /* REALLY Done with the handshake. */ + { +#ifdef CURLVERBOSE + const uint16_t proto = rustls_connection_get_protocol_version(rconn); + const rustls_str ciphersuite_name = + rustls_connection_get_negotiated_ciphersuite_name(rconn); + const rustls_str kex_group_name = + rustls_connection_get_negotiated_key_exchange_group_name(rconn); + const char *ver = "TLS version unknown"; + if(proto == RUSTLS_TLS_VERSION_TLSV1_3) + ver = "TLSv1.3"; + if(proto == RUSTLS_TLS_VERSION_TLSV1_2) + ver = "TLSv1.2"; +#endif + infof(data, + "rustls: handshake complete, %s, ciphersuite: %.*s, " + "key exchange group: %.*s", + ver, + (int) ciphersuite_name.len, + ciphersuite_name.data, + (int) kex_group_name.len, + kex_group_name.data); + } + if(data->set.ssl.certinfo) { + size_t num_certs = 0; + size_t i; + while(rustls_connection_get_peer_certificate(rconn, num_certs)) { + num_certs++; + if(num_certs > MAX_ALLOWED_CERT_AMOUNT) { + failf(data, "%zu certificates is more than allowed (%d)", + num_certs, MAX_ALLOWED_CERT_AMOUNT); + return CURLE_SSL_CONNECT_ERROR; + } + } + result = Curl_ssl_init_certinfo(data, (int)num_certs); + if(result) + return result; + for(i = 0; i < num_certs; i++) { + const rustls_certificate *cert; + const unsigned char *der_data; + size_t der_len; + rustls_result rresult = RUSTLS_RESULT_OK; + cert = rustls_connection_get_peer_certificate(rconn, i); + DEBUGASSERT(cert); /* Should exist since we counted already */ + rresult = rustls_certificate_get_der(cert, &der_data, &der_len); + if(rresult != RUSTLS_RESULT_OK) { + char errorbuf[255]; + size_t errorlen; + rustls_error(rresult, errorbuf, sizeof(errorbuf), &errorlen); + failf(data, + "Failed getting DER of server certificate #%zu: %.*s", i, + (int)errorlen, errorbuf); + return map_error(rresult); + } + { + const char *beg; + const char *end; + beg = (const char *)der_data; + end = (const char *)(der_data + der_len); + result = Curl_extract_certinfo(data, (int)i, beg, end); + if(result) + return result; + } + } + } + + connssl->state = ssl_connection_complete; + *done = TRUE; + return CURLE_OK; + } + + connssl->connecting_state = ssl_connect_2; + wants_read = rustls_connection_wants_read(rconn); + wants_write = rustls_connection_wants_write(rconn) || + backend->plain_out_buffered; + DEBUGASSERT(wants_read || wants_write); + + if(wants_write) { + size_t nwritten; + CURL_TRC_CF(data, cf, "rustls_connection wants us to write_tls."); + tmperr = cr_send(cf, data, NULL, 0, &nwritten); + if(tmperr == CURLE_AGAIN) { + CURL_TRC_CF(data, cf, "writing would block"); + connssl->io_need = CURL_SSL_IO_NEED_SEND; + return CURLE_OK; + } + else if(tmperr != CURLE_OK) { + return tmperr; + } + } + + if(wants_read) { + CURL_TRC_CF(data, cf, "rustls_connection wants us to read_tls."); + nread = tls_recv_more(cf, data, &tmperr); + if(nread == 0) { + connssl->peer_closed = TRUE; + failf(data, "TLS connect error: Connection closed abruptly"); + return CURLE_SSL_CONNECT_ERROR; + } + if(nread < 0) { + if(tmperr == CURLE_AGAIN) { + CURL_TRC_CF(data, cf, "reading would block"); + connssl->io_need = CURL_SSL_IO_NEED_RECV; + return CURLE_OK; + } + else if(tmperr == CURLE_RECV_ERROR) { + return CURLE_SSL_CONNECT_ERROR; + } + else { + return tmperr; + } + } + } + } + + /* We should never fall through the loop. We should return either because + the handshake is done or because we cannot read/write without blocking. */ + DEBUGASSERT(FALSE); +} + +static void *cr_get_internals(struct ssl_connect_data *connssl, CURLINFO info) +{ + struct rustls_ssl_backend_data *backend = + (struct rustls_ssl_backend_data *)connssl->backend; + (void)info; + DEBUGASSERT(backend); + return backend->conn; +} + +static CURLcode cr_shutdown(struct Curl_cfilter *cf, struct Curl_easy *data, + const bool send_shutdown, bool *done) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct rustls_ssl_backend_data *backend = + (struct rustls_ssl_backend_data *)connssl->backend; + CURLcode result = CURLE_OK; + size_t i, nread = 0, nwritten; + + DEBUGASSERT(backend); + if(!backend->conn || cf->shutdown) { + *done = TRUE; + goto out; + } + + connssl->io_need = CURL_SSL_IO_NEED_NONE; + *done = FALSE; + + if(!backend->sent_shutdown) { + /* do this only once */ + backend->sent_shutdown = TRUE; + if(send_shutdown) { + rustls_connection_send_close_notify(backend->conn); + } + } + + result = cr_send(cf, data, NULL, 0, &nwritten); + if(result) { + if(result == CURLE_AGAIN) { + connssl->io_need = CURL_SSL_IO_NEED_SEND; + result = CURLE_OK; + goto out; + } + DEBUGASSERT(result); + CURL_TRC_CF(data, cf, "shutdown send failed: %d", (int)result); + goto out; + } + + for(i = 0; i < 10; ++i) { + char buf[1024]; + result = cr_recv(cf, data, buf, (int)sizeof(buf), &nread); + if(result) + break; + } + + if(result == CURLE_AGAIN) { + connssl->io_need = CURL_SSL_IO_NEED_RECV; + result = CURLE_OK; + } + else if(result) { + DEBUGASSERT(result); + CURL_TRC_CF(data, cf, "shutdown, error: %d", (int)result); + } + else if(nread == 0) { + /* We got the close notify alert and are done. */ + *done = TRUE; + } + +out: + cf->shutdown = (result || *done); + return result; +} + +static void cr_close(struct Curl_cfilter *cf, struct Curl_easy *data) +{ + const struct ssl_connect_data *connssl = cf->ctx; + struct rustls_ssl_backend_data *backend = + (struct rustls_ssl_backend_data *)connssl->backend; + + (void)data; + DEBUGASSERT(backend); + if(backend->conn) { + rustls_connection_free(backend->conn); + backend->conn = NULL; + } + if(backend->config) { + rustls_client_config_free(backend->config); + backend->config = NULL; + } +} + +static size_t cr_version(char *buffer, size_t size) +{ + const struct rustls_str ver = rustls_version(); + return curl_msnprintf(buffer, size, "%.*s", (int)ver.len, ver.data); +} + +static CURLcode cr_random(struct Curl_easy *data, unsigned char *entropy, + size_t length) +{ + rustls_result rresult = 0; + (void)data; + rresult = rustls_default_crypto_provider_random(entropy, length); + return map_error(rresult); +} + +static void cr_cleanup(void) +{ + Curl_tls_keylog_close(); +} + +const struct Curl_ssl Curl_ssl_rustls = { + { CURLSSLBACKEND_RUSTLS, "rustls" }, + SSLSUPP_CAINFO_BLOB | /* supports */ + SSLSUPP_HTTPS_PROXY | + SSLSUPP_CIPHER_LIST | + SSLSUPP_TLS13_CIPHERSUITES | + SSLSUPP_CERTINFO | + SSLSUPP_ECH | + SSLSUPP_CRLFILE, + sizeof(struct rustls_ssl_backend_data), + + NULL, /* init */ + cr_cleanup, /* cleanup */ + cr_version, /* version */ + cr_shutdown, /* shutdown */ + cr_data_pending, /* data_pending */ + cr_random, /* random */ + NULL, /* cert_status_request */ + cr_connect, /* connect */ + Curl_ssl_adjust_pollset, /* adjust_pollset */ + cr_get_internals, /* get_internals */ + cr_close, /* close_one */ + NULL, /* close_all */ + NULL, /* set_engine */ + NULL, /* set_engine_default */ + NULL, /* engines_list */ + NULL, /* sha256sum */ + cr_recv, /* recv decrypted data */ + cr_send, /* send data to encrypt */ + NULL, /* get_channel_binding */ +}; + +#endif /* USE_RUSTLS */ diff --git a/3rdparty/curl-8.21.0/lib/vtls/rustls.h b/3rdparty/curl-8.21.0/lib/vtls/rustls.h new file mode 100644 index 0000000000..b6ddbd1b7e --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vtls/rustls.h @@ -0,0 +1,33 @@ +#ifndef HEADER_CURL_RUSTLS_H +#define HEADER_CURL_RUSTLS_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Jacob Hoffman-Andrews, + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_RUSTLS + +extern const struct Curl_ssl Curl_ssl_rustls; + +#endif /* USE_RUSTLS */ +#endif /* HEADER_CURL_RUSTLS_H */ diff --git a/3rdparty/curl-8.21.0/lib/vtls/schannel.c b/3rdparty/curl-8.21.0/lib/vtls/schannel.c new file mode 100644 index 0000000000..3e871227aa --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vtls/schannel.c @@ -0,0 +1,2911 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * Copyright (C) Marc Hoersken, + * Copyright (C) Mark Salisbury, + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +/* + * Source file for all Schannel-specific code for the TLS/SSL layer. No code + * but vtls.c should ever call or use these functions. + */ +#include "curl_setup.h" + +#ifdef USE_SCHANNEL + +#ifndef USE_WINDOWS_SSPI +#error "cannot compile Schannel support without SSPI." +#endif + +#include "vtls/schannel.h" +#include "vtls/schannel_int.h" +#include "vtls/vtls.h" +#include "vtls/vtls_int.h" +#include "vtls/vtls_scache.h" +#include "curl_trc.h" +#include "connect.h" /* for the connect timeout */ +#include "curlx/strdup.h" +#include "strerror.h" +#include "select.h" /* for the socket readiness */ +#include "curlx/fopen.h" +#include "curlx/multibyte.h" +#include "vtls/x509asn1.h" +#include "system_win32.h" +#include "curlx/version_win32.h" +#include "rand.h" +#include "curlx/strparse.h" +#include "progress.h" +#include "curl_sha256.h" + +/* Some verbose debug messages are wrapped by SCH_DEV() instead of DEBUGF() + * and only shown if CURL_SCHANNEL_DEV_DEBUG was defined at build time. These + * messages are extra verbose and intended for curl developers debugging + * Schannel recv decryption and renegotiation. + */ +#ifdef CURL_SCHANNEL_DEV_DEBUG +#define SCH_DEV(x) x +#define SCH_DEV_SHOWBOOL(x) \ + infof(data, "schannel: " #x " %s", (x) ? "TRUE" : "FALSE"); +#else +#define SCH_DEV(x) do {} while(0) +#define SCH_DEV_SHOWBOOL(x) do {} while(0) +#endif + +/* Offered by mingw-w64 v8+, MS SDK 7.0A/VS2010+ */ +#ifndef SP_PROT_TLS1_0_CLIENT +#define SP_PROT_TLS1_0_CLIENT SP_PROT_TLS1_CLIENT +#endif +#ifndef SP_PROT_TLS1_1_CLIENT +#define SP_PROT_TLS1_1_CLIENT 0x00000200 +#endif +#ifndef SP_PROT_TLS1_2_CLIENT +#define SP_PROT_TLS1_2_CLIENT 0x00000800 +#endif + +/* Offered by mingw-w64 v8+, MS SDK 10.0.15063.0/VS2017 15.1+ */ +#ifndef SP_PROT_TLS1_3_CLIENT +#define SP_PROT_TLS1_3_CLIENT 0x00002000 +#endif +/* Offered by mingw-w64 v8+, MS SDK 8.1/~VS2013+ */ +#ifndef SCH_USE_STRONG_CRYPTO +#define SCH_USE_STRONG_CRYPTO 0x00400000 +#endif + +/* Offered by mingw-w64 v10+, MS SDK 7.0A/VS2010+ */ +#ifndef SECBUFFER_ALERT +#define SECBUFFER_ALERT 17 +#endif + +/* Both schannel buffer sizes must be > 0 */ +#define CURL_SCHANNEL_BUFFER_INIT_SIZE 4096 +#define CURL_SCHANNEL_BUFFER_FREE_SIZE 1024 + +#define CERT_THUMBPRINT_STR_LEN 40 +#define CERT_THUMBPRINT_DATA_LEN 20 + +/* Uncomment to force verbose output + * #define infof(x, y, ...) curl_mprintf(y, __VA_ARGS__) + * #define failf(x, y, ...) curl_mprintf(y, __VA_ARGS__) + */ + +/* Offered by mingw-w64 v4+, MS SDK 6.0A/VS2008+ */ +#ifndef PKCS12_NO_PERSIST_KEY +#define PKCS12_NO_PERSIST_KEY 0x00008000 +#endif + +/* Offered by mingw-w64 v4+, MS SDK 8.0/~VS2012+ */ +#ifndef CERT_FIND_HAS_PRIVATE_KEY +#define CERT_FIND_HAS_PRIVATE_KEY (21 << CERT_COMPARE_SHIFT) +#endif + +/* key to use at `multi->proto_hash` */ +#define MPROTO_SCHANNEL_CERT_SHARE_KEY "tls:schannel:cert:share" + +/* ALPN requires version 8.1 of the Windows SDK, which was + shipped with Visual Studio 2013, aka _MSC_VER 1800: + https://learn.microsoft.com/previous-versions/windows/it-pro/windows-server-2012-R2-and-2012/hh831771 + Or mingw-w64 9.0 or upper. +*/ +#if (defined(__MINGW64_VERSION_MAJOR) && __MINGW64_VERSION_MAJOR >= 9) || \ + (defined(_MSC_VER) && (_MSC_VER >= 1800) && !defined(_USING_V110_SDK71_)) +#define HAS_ALPN_SCHANNEL +static bool s_win_has_alpn; +#endif + +static void InitSecBuffer(SecBuffer *buffer, unsigned long BufType, + void *BufDataPtr, unsigned long BufByteSize) +{ + buffer->cbBuffer = BufByteSize; + buffer->BufferType = BufType; + buffer->pvBuffer = BufDataPtr; +} + +static void InitSecBufferDesc(SecBufferDesc *desc, SecBuffer *BufArr, + unsigned long NumArrElem) +{ + desc->ulVersion = SECBUFFER_VERSION; + desc->pBuffers = BufArr; + desc->cBuffers = NumArrElem; +} + +static CURLcode schannel_set_ssl_version_min_max(DWORD *enabled_protocols, + struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + long ssl_version = conn_config->version; + long ssl_version_max = (long)conn_config->version_max; + long i = ssl_version; + + switch(ssl_version_max) { + case CURL_SSLVERSION_MAX_NONE: + case CURL_SSLVERSION_MAX_DEFAULT: + + /* Windows Server 2022 and newer (including Windows 11) support TLS 1.3 + built-in. Previous builds of Windows 10 had broken TLS 1.3 + implementations that could be enabled via registry. + */ + if(curlx_verify_windows_version(10, 0, 20348, PLATFORM_WINNT, + VERSION_GREATER_THAN_EQUAL)) { + ssl_version_max = CURL_SSLVERSION_MAX_TLSv1_3; + } + else /* Windows 10 or older */ + ssl_version_max = CURL_SSLVERSION_MAX_TLSv1_2; + + break; + } + + for(; i <= (ssl_version_max >> 16); ++i) { + switch(i) { + case CURL_SSLVERSION_TLSv1_0: + *enabled_protocols |= SP_PROT_TLS1_0_CLIENT; + break; + case CURL_SSLVERSION_TLSv1_1: + *enabled_protocols |= SP_PROT_TLS1_1_CLIENT; + break; + case CURL_SSLVERSION_TLSv1_2: + *enabled_protocols |= SP_PROT_TLS1_2_CLIENT; + break; + case CURL_SSLVERSION_TLSv1_3: + + /* Windows Server 2022 and newer */ + if(curlx_verify_windows_version(10, 0, 20348, PLATFORM_WINNT, + VERSION_GREATER_THAN_EQUAL)) { + *enabled_protocols |= SP_PROT_TLS1_3_CLIENT; + break; + } + else { /* Windows 10 or older */ + failf(data, "schannel: TLS 1.3 not supported on Windows 10 or older"); + return CURLE_SSL_CONNECT_ERROR; + } + } + } + return CURLE_OK; +} + +#define CIPHEROPTION(x) { #x, x } + +struct algo { + const char *name; + int id; +}; + +static const struct algo algs[] = { + CIPHEROPTION(CALG_MD2), + CIPHEROPTION(CALG_MD4), + CIPHEROPTION(CALG_MD5), + CIPHEROPTION(CALG_SHA), + CIPHEROPTION(CALG_SHA1), + CIPHEROPTION(CALG_MAC), + CIPHEROPTION(CALG_RSA_SIGN), + CIPHEROPTION(CALG_DSS_SIGN), + CIPHEROPTION(CALG_NO_SIGN), + CIPHEROPTION(CALG_RSA_KEYX), + CIPHEROPTION(CALG_DES), + CIPHEROPTION(CALG_3DES_112), + CIPHEROPTION(CALG_3DES), + CIPHEROPTION(CALG_DESX), + CIPHEROPTION(CALG_RC2), + CIPHEROPTION(CALG_RC4), + CIPHEROPTION(CALG_SEAL), + CIPHEROPTION(CALG_DH_SF), + CIPHEROPTION(CALG_DH_EPHEM), + CIPHEROPTION(CALG_AGREEDKEY_ANY), + CIPHEROPTION(CALG_HUGHES_MD5), + CIPHEROPTION(CALG_SKIPJACK), + CIPHEROPTION(CALG_TEK), + CIPHEROPTION(CALG_CYLINK_MEK), /* spellchecker:disable-line */ + CIPHEROPTION(CALG_SSL3_SHAMD5), + CIPHEROPTION(CALG_SSL3_MASTER), + CIPHEROPTION(CALG_SCHANNEL_MASTER_HASH), + CIPHEROPTION(CALG_SCHANNEL_MAC_KEY), + CIPHEROPTION(CALG_SCHANNEL_ENC_KEY), + CIPHEROPTION(CALG_PCT1_MASTER), + CIPHEROPTION(CALG_SSL2_MASTER), + CIPHEROPTION(CALG_TLS1_MASTER), + CIPHEROPTION(CALG_RC5), + CIPHEROPTION(CALG_HMAC), + CIPHEROPTION(CALG_TLS1PRF), + CIPHEROPTION(CALG_HASH_REPLACE_OWF), + CIPHEROPTION(CALG_AES_128), + CIPHEROPTION(CALG_AES_192), + CIPHEROPTION(CALG_AES_256), + CIPHEROPTION(CALG_AES), + CIPHEROPTION(CALG_SHA_256), + CIPHEROPTION(CALG_SHA_384), + CIPHEROPTION(CALG_SHA_512), + CIPHEROPTION(CALG_ECDH), +/* Offered by mingw-w64 v4+, MS SDK 6.0A/VS2008+ */ +#ifdef CALG_ECMQV + CIPHEROPTION(CALG_ECMQV), +#endif + CIPHEROPTION(CALG_ECDSA), +/* Offered by mingw-w64 v7+, MS SDK 7.0A/VS2010+ */ +#ifdef CALG_ECDH_EPHEM + CIPHEROPTION(CALG_ECDH_EPHEM), +#endif + { NULL, 0 }, +}; + +static int get_alg_id_by_name(const char *name) +{ + const char *nameEnd = strchr(name, ':'); + size_t n = nameEnd ? (size_t)(nameEnd - name) : strlen(name); + int i; + + for(i = 0; algs[i].name; i++) { + if((n == strlen(algs[i].name) && !strncmp(algs[i].name, name, n))) + return algs[i].id; + } + return 0; /* not found */ +} + +#define NUM_CIPHERS 47 /* There are a maximum of 47 options listed above */ + +static CURLcode set_ssl_ciphers(SCHANNEL_CRED *schannel_cred, char *ciphers, + ALG_ID *algIds) +{ + const char *startCur = ciphers; + int algCount = 0; + while(startCur && *startCur && (algCount < NUM_CIPHERS)) { + curl_off_t alg; + if(curlx_str_number(&startCur, &alg, INT_MAX) || !alg) + alg = get_alg_id_by_name(startCur); + + if(alg) + algIds[algCount++] = (ALG_ID)alg; + else if(!strncmp(startCur, "USE_STRONG_CRYPTO", + sizeof("USE_STRONG_CRYPTO") - 1) || + !strncmp(startCur, "SCH_USE_STRONG_CRYPTO", + sizeof("SCH_USE_STRONG_CRYPTO") - 1)) + schannel_cred->dwFlags |= SCH_USE_STRONG_CRYPTO; + else + return CURLE_SSL_CIPHER; + startCur = strchr(startCur, ':'); + if(startCur) + startCur++; + } + schannel_cred->palgSupportedAlgs = algIds; + schannel_cred->cSupportedAlgs = (DWORD)algCount; + return CURLE_OK; +} + +/* Function allocates memory for store_path only if CURLE_OK is returned */ +static CURLcode get_cert_location(TCHAR *path, DWORD *store_name, + TCHAR **store_path, TCHAR **thumbprint) +{ + TCHAR *sep; + TCHAR *store_path_start; + size_t store_name_len; + + sep = _tcschr(path, TEXT('\\')); + if(!sep) + return CURLE_SSL_CERTPROBLEM; + + store_name_len = sep - path; + + if(_tcsncmp(path, TEXT("CurrentUser"), store_name_len) == 0) + *store_name = CERT_SYSTEM_STORE_CURRENT_USER; + else if(_tcsncmp(path, TEXT("LocalMachine"), store_name_len) == 0) + *store_name = CERT_SYSTEM_STORE_LOCAL_MACHINE; + else if(_tcsncmp(path, TEXT("CurrentService"), store_name_len) == 0) + *store_name = CERT_SYSTEM_STORE_CURRENT_SERVICE; + else if(_tcsncmp(path, TEXT("Services"), store_name_len) == 0) + *store_name = CERT_SYSTEM_STORE_SERVICES; + else if(_tcsncmp(path, TEXT("Users"), store_name_len) == 0) + *store_name = CERT_SYSTEM_STORE_USERS; + else if(_tcsncmp(path, TEXT("CurrentUserGroupPolicy"), store_name_len) == 0) + *store_name = CERT_SYSTEM_STORE_CURRENT_USER_GROUP_POLICY; + else if(_tcsncmp(path, TEXT("LocalMachineGroupPolicy"), store_name_len) == 0) + *store_name = CERT_SYSTEM_STORE_LOCAL_MACHINE_GROUP_POLICY; + else if(_tcsncmp(path, TEXT("LocalMachineEnterprise"), store_name_len) == 0) + *store_name = CERT_SYSTEM_STORE_LOCAL_MACHINE_ENTERPRISE; + else + return CURLE_SSL_CERTPROBLEM; + + store_path_start = sep + 1; + + sep = _tcschr(store_path_start, TEXT('\\')); + if(!sep) + return CURLE_SSL_CERTPROBLEM; + + *thumbprint = sep + 1; + if(_tcslen(*thumbprint) != CERT_THUMBPRINT_STR_LEN) + return CURLE_SSL_CERTPROBLEM; + + *sep = TEXT('\0'); + *store_path = curlx_tcsdup(store_path_start); + *sep = TEXT('\\'); + if(!*store_path) + return CURLE_OUT_OF_MEMORY; + + return CURLE_OK; +} + +static CURLcode get_client_cert(struct Curl_cfilter *cf, + struct Curl_easy *data, + HCERTSTORE *out_cert_store, + PCCERT_CONTEXT *out_cert_context) +{ + struct ssl_primary_config *sslc = Curl_ssl_cf_get_primary_config(cf); + PCCERT_CONTEXT client_cert = NULL; + HCERTSTORE client_cert_store = NULL; + CURLcode result = CURLE_OK; + + if(sslc->clientcert || sslc->cert_blob) { + DWORD cert_store_name = 0; + TCHAR *cert_store_path = NULL; + TCHAR *cert_thumbprint_str = NULL; + TCHAR cert_thumbprint_buf[CERT_THUMBPRINT_STR_LEN + 1]; + CRYPT_HASH_BLOB cert_thumbprint; + BYTE cert_thumbprint_data[CERT_THUMBPRINT_DATA_LEN]; + HCERTSTORE cert_store = NULL; + FILE *fInCert = NULL; + void *certdata = NULL; + size_t certsize = 0; + bool blob = !!sslc->cert_blob; + + if(blob) { + certdata = sslc->cert_blob->data; + certsize = sslc->cert_blob->len; + } + else { + TCHAR *cert_path = + curlx_convert_UTF8_to_tchar(sslc->clientcert); + if(!cert_path) + return CURLE_OUT_OF_MEMORY; + + result = get_cert_location(cert_path, &cert_store_name, + &cert_store_path, &cert_thumbprint_str); + + /* 'cert_thumbprint_str' points in to the allocated 'cert_path', copy + the data. The string is verified to be CERT_THUMBPRINT_STR_LEN bytes + long within the get_cert_location() function. */ + if(!result && cert_thumbprint_str) { + memcpy(cert_thumbprint_buf, cert_thumbprint_str, + sizeof(cert_thumbprint_buf)); + cert_thumbprint_str = cert_thumbprint_buf; + } + + curlx_free(cert_path); + if(result && (sslc->clientcert[0] != '\0')) + fInCert = curlx_fopen(sslc->clientcert, "rb"); + + if(result && !fInCert) { + failf(data, "schannel: Failed to get certificate location" + " or file for %s", + sslc->clientcert); + return result; + } + } + + if((fInCert || blob) && sslc->cert_type && + !curl_strequal(sslc->cert_type, "P12")) { + failf(data, "schannel: certificate format compatibility error " + "for %s", + blob ? "(memory blob)" : sslc->clientcert); + curlx_free(cert_store_path); + if(fInCert) + curlx_fclose(fInCert); + return CURLE_SSL_CERTPROBLEM; + } + + if(fInCert || blob) { + /* Reading a .p12 or .pfx file, like the example at bottom of + https://learn.microsoft.com/archive/msdn-technet-forums/3e7bc95f-b21a-4bcd-bd2c-7f996718cae5 + */ + CRYPT_DATA_BLOB datablob; + WCHAR *pszPassword; + size_t pwd_len = 0; + int cert_find_flags; + const char *cert_showfilename_error = blob ? + "(memory blob)" : sslc->clientcert; + curlx_free(cert_store_path); + if(fInCert) { + long cert_tell = 0; + bool continue_reading = fseek(fInCert, 0, SEEK_END) == 0; + if(continue_reading) + cert_tell = ftell(fInCert); + if(cert_tell < 0) + continue_reading = FALSE; + else + certsize = (size_t)cert_tell; + if(continue_reading) + continue_reading = fseek(fInCert, 0, SEEK_SET) == 0; + if(continue_reading && (certsize < CURL_MAX_INPUT_LENGTH)) + certdata = curlx_malloc(certsize + 1); + if((!certdata) || + ((int) fread(certdata, certsize, 1, fInCert) != 1)) + continue_reading = FALSE; + curlx_fclose(fInCert); + if(!continue_reading) { + failf(data, "schannel: Failed to read cert file %s", + sslc->clientcert); + curlx_free(certdata); + return CURLE_SSL_CERTPROBLEM; + } + } + + /* Convert key-pair data to the in-memory certificate store */ + datablob.pbData = (BYTE *)certdata; + datablob.cbData = (DWORD)certsize; + + if(sslc->key_passwd) + pwd_len = strlen(sslc->key_passwd); + pszPassword = curlx_malloc(sizeof(WCHAR) * (pwd_len + 1)); + if(pszPassword) { + int str_w_len = 0; + if(pwd_len > 0) + str_w_len = MultiByteToWideChar(CP_UTF8, + MB_ERR_INVALID_CHARS, + sslc->key_passwd, + (int)pwd_len, + pszPassword, (int)(pwd_len + 1)); + + if((str_w_len >= 0) && (str_w_len <= (int)pwd_len)) + pszPassword[str_w_len] = 0; + else + pszPassword[0] = 0; + + cert_store = PFXImportCertStore(&datablob, pszPassword, + PKCS12_NO_PERSIST_KEY); + curlx_free(pszPassword); + } + if(!blob) + curlx_free(certdata); + if(!cert_store) { + DWORD errorcode = GetLastError(); + if(errorcode == ERROR_INVALID_PASSWORD) + failf(data, "schannel: Failed to import cert file %s, " + "password is bad", + cert_showfilename_error); + else + failf(data, "schannel: Failed to import cert file %s, " + "last error is 0x%08lx", + cert_showfilename_error, errorcode); + return CURLE_SSL_CERTPROBLEM; + } + + /* CERT_FIND_HAS_PRIVATE_KEY is only available in Windows 8 / Server + 2012, (NT v6.2). For earlier versions we use CURL_FIND_ANY. */ + if(curlx_verify_windows_version(6, 2, 0, PLATFORM_WINNT, + VERSION_GREATER_THAN_EQUAL)) + cert_find_flags = CERT_FIND_HAS_PRIVATE_KEY; + else + cert_find_flags = CERT_FIND_ANY; + + client_cert = + CertFindCertificateInStore(cert_store, + X509_ASN_ENCODING | PKCS_7_ASN_ENCODING, 0, + cert_find_flags, NULL, NULL); + + if(!client_cert) { + failf(data, "schannel: Failed to get certificate from file %s" + ", last error is 0x%08lx", + cert_showfilename_error, GetLastError()); + CertCloseStore(cert_store, 0); + return CURLE_SSL_CERTPROBLEM; + } + } + else { + cert_store = + CertOpenStore( +#ifdef UNICODE + CERT_STORE_PROV_SYSTEM_W, +#else + CERT_STORE_PROV_SYSTEM_A, +#endif + 0, + (HCRYPTPROV)NULL, + CERT_STORE_OPEN_EXISTING_FLAG | cert_store_name, + cert_store_path); + if(!cert_store) { + char *path_utf8 = + curlx_convert_tchar_to_UTF8(cert_store_path); + failf(data, "schannel: Failed to open cert store %lx %s, " + "last error is 0x%08lx", + cert_store_name, (path_utf8 ? path_utf8 : "(unknown)"), + GetLastError()); + curlx_free(cert_store_path); + curlx_free(path_utf8); + return CURLE_SSL_CERTPROBLEM; + } + curlx_free(cert_store_path); + + cert_thumbprint.pbData = cert_thumbprint_data; + cert_thumbprint.cbData = CERT_THUMBPRINT_DATA_LEN; + + if(!CryptStringToBinary(cert_thumbprint_str, + CERT_THUMBPRINT_STR_LEN, + CRYPT_STRING_HEX, + cert_thumbprint_data, + &cert_thumbprint.cbData, + NULL, NULL)) { + CertCloseStore(cert_store, 0); + return CURLE_SSL_CERTPROBLEM; + } + + client_cert = + CertFindCertificateInStore(cert_store, + X509_ASN_ENCODING | PKCS_7_ASN_ENCODING, 0, + CERT_FIND_HASH, &cert_thumbprint, NULL); + if(!client_cert) { + /* CRYPT_E_NOT_FOUND / E_INVALIDARG */ + CertCloseStore(cert_store, 0); + failf(data, "schannel: client cert not found in cert store"); + return CURLE_SSL_CERTPROBLEM; + } + } + client_cert_store = cert_store; + } + + *out_cert_store = client_cert_store; + *out_cert_context = client_cert; + + return CURLE_OK; +} + +static CURLcode acquire_sspi_handle(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct schannel_ssl_backend_data *backend, + PCCERT_CONTEXT client_cert, + DWORD flags, + DWORD enabled_protocols) +{ + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + SECURITY_STATUS sspi_status = SEC_E_OK; + CURLcode result; + + /* We support TLS 1.3 starting in Windows 10 version 1809 (OS build 17763) as + long as the user did not set a legacy algorithm list + (CURLOPT_SSL_CIPHER_LIST). */ + if(!conn_config->cipher_list && + curlx_verify_windows_version(10, 0, 17763, PLATFORM_WINNT, + VERSION_GREATER_THAN_EQUAL)) { + + SCH_CREDENTIALS credentials = { 0 }; + TLS_PARAMETERS tls_parameters = { 0 }; + CRYPTO_SETTINGS crypto_settings[1]; + PCCERT_CONTEXT client_certs[1]; + + if(client_cert) + client_certs[0] = client_cert; + else + client_certs[0] = NULL; + + memset(crypto_settings, 0, sizeof(crypto_settings)); + + tls_parameters.pDisabledCrypto = crypto_settings; + + /* The number of blocked suites */ + tls_parameters.cDisabledCrypto = (DWORD)0; + credentials.pTlsParameters = &tls_parameters; + credentials.cTlsParameters = 1; + + credentials.dwVersion = SCH_CREDENTIALS_VERSION; + credentials.dwFlags = flags | SCH_USE_STRONG_CRYPTO; + + credentials.pTlsParameters->grbitDisabledProtocols = ~enabled_protocols; + + if(client_certs[0]) { + credentials.cCreds = 1; + credentials.paCred = client_certs; + } + + sspi_status = + Curl_pSecFn->AcquireCredentialsHandle(NULL, + (TCHAR *)CURL_UNCONST(UNISP_NAME), + SECPKG_CRED_OUTBOUND, NULL, + &credentials, NULL, NULL, + &backend->cred->cred_handle, NULL); + } + else { + /* Pre-Windows 10 1809 or the user set a legacy algorithm list. + Schannel does not negotiate TLS 1.3 when SCHANNEL_CRED is used. */ + ALG_ID algIds[NUM_CIPHERS]; + char *ciphers = conn_config->cipher_list; + SCHANNEL_CRED schannel_cred = { 0 }; + PCCERT_CONTEXT client_certs[1]; + + if(client_cert) + client_certs[0] = client_cert; + else + client_certs[0] = NULL; + + schannel_cred.dwVersion = SCHANNEL_CRED_VERSION; + schannel_cred.dwFlags = flags; + schannel_cred.grbitEnabledProtocols = enabled_protocols; + + if(ciphers) { + if((enabled_protocols & SP_PROT_TLS1_3_CLIENT)) { + if(!(enabled_protocols & ~SP_PROT_TLS1_3_CLIENT)) { + failf(data, "schannel: TLS 1.3 is not supported with a cipher list; " + "remove the cipher list or allow a lower TLS version"); + return CURLE_SSL_CONNECT_ERROR; + } + infof(data, "schannel: WARNING: This version of Schannel " + "negotiates a less-secure TLS version than TLS 1.3 because the " + "user set an algorithm cipher list."); + } + result = set_ssl_ciphers(&schannel_cred, ciphers, algIds); + if(result) { + failf(data, "schannel: Failed setting algorithm cipher list"); + return result; + } + } + else { + schannel_cred.dwFlags = flags | SCH_USE_STRONG_CRYPTO; + } + + if(client_certs[0]) { + schannel_cred.cCreds = 1; + schannel_cred.paCred = client_certs; + } + + sspi_status = + Curl_pSecFn->AcquireCredentialsHandle(NULL, + (TCHAR *)CURL_UNCONST(UNISP_NAME), + SECPKG_CRED_OUTBOUND, NULL, + &schannel_cred, NULL, NULL, + &backend->cred->cred_handle, NULL); + } + + if(sspi_status != SEC_E_OK) { + char buffer[STRERROR_LEN]; + failf(data, "schannel: AcquireCredentialsHandle failed: %s", + Curl_sspi_strerror(sspi_status, buffer, sizeof(buffer))); + switch(sspi_status) { + case SEC_E_INSUFFICIENT_MEMORY: + return CURLE_OUT_OF_MEMORY; + case SEC_E_NO_CREDENTIALS: + case SEC_E_SECPKG_NOT_FOUND: + case SEC_E_NOT_OWNER: + case SEC_E_UNKNOWN_CREDENTIALS: + case SEC_E_INTERNAL_ERROR: + default: + return CURLE_SSL_CONNECT_ERROR; + } + } + + return CURLE_OK; +} + +static CURLcode schannel_acquire_credential_handle(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + struct ssl_config_data *ssl_config = Curl_ssl_cf_get_config(cf, data); + + PCCERT_CONTEXT client_cert = NULL; + HCERTSTORE client_cert_store = NULL; + CURLcode result; + + /* setup Schannel API options */ + DWORD flags = 0; + DWORD enabled_protocols = 0; + + struct schannel_ssl_backend_data *backend = + (struct schannel_ssl_backend_data *)(connssl->backend); + + DEBUGASSERT(backend); + + if(conn_config->verifypeer) { + if(backend->use_manual_cred_validation) + flags = SCH_CRED_MANUAL_CRED_VALIDATION; + else + flags = SCH_CRED_AUTO_CRED_VALIDATION; + + if(ssl_config->no_revoke) { + flags |= SCH_CRED_IGNORE_NO_REVOCATION_CHECK | + SCH_CRED_IGNORE_REVOCATION_OFFLINE; + + DEBUGF(infof(data, "schannel: disabled server certificate revocation " + "checks")); + } + else if(ssl_config->revoke_best_effort) { + flags |= SCH_CRED_IGNORE_NO_REVOCATION_CHECK | + SCH_CRED_IGNORE_REVOCATION_OFFLINE | + SCH_CRED_REVOCATION_CHECK_CHAIN; + + DEBUGF(infof(data, "schannel: ignore revocation offline errors")); + } + else { + flags |= SCH_CRED_REVOCATION_CHECK_CHAIN; + + DEBUGF(infof(data, "schannel: checking server certificate revocation")); + } + } + else { + flags = SCH_CRED_MANUAL_CRED_VALIDATION | + SCH_CRED_IGNORE_NO_REVOCATION_CHECK | + SCH_CRED_IGNORE_REVOCATION_OFFLINE; + DEBUGF(infof(data, "schannel: disabled server cert revocation checks")); + } + + if(!conn_config->verifyhost) { + flags |= SCH_CRED_NO_SERVERNAME_CHECK; + DEBUGF(infof(data, "schannel: verifyhost setting prevents Schannel from " + "comparing the supplied target name with the subject " + "names in server certificates.")); + } + + if(!ssl_config->auto_client_cert) { + flags &= ~(DWORD)SCH_CRED_USE_DEFAULT_CREDS; + flags |= SCH_CRED_NO_DEFAULT_CREDS; + infof(data, "schannel: disabled automatic use of client certificate"); + } + else + infof(data, "schannel: enabled automatic use of client certificate"); + + DEBUGASSERT(conn_config->version != CURL_SSLVERSION_DEFAULT); + switch(conn_config->version) { + case CURL_SSLVERSION_TLSv1: + case CURL_SSLVERSION_TLSv1_0: + case CURL_SSLVERSION_TLSv1_1: + case CURL_SSLVERSION_TLSv1_2: + case CURL_SSLVERSION_TLSv1_3: { + result = schannel_set_ssl_version_min_max(&enabled_protocols, cf, data); + if(result) + return result; + break; + } + case CURL_SSLVERSION_SSLv3: + case CURL_SSLVERSION_SSLv2: + failf(data, "SSL versions not supported"); + return CURLE_NOT_BUILT_IN; + default: + failf(data, "Unrecognized parameter passed via CURLOPT_SSLVERSION"); + return CURLE_SSL_CONNECT_ERROR; + } + + result = get_client_cert(cf, data, &client_cert_store, &client_cert); + if(result) + return result; + + /* allocate memory for the reusable credential handle */ + backend->cred = (struct Curl_schannel_cred *) + curlx_calloc(1, sizeof(struct Curl_schannel_cred)); + if(!backend->cred) { + failf(data, "schannel: unable to allocate memory"); + + if(client_cert) + CertFreeCertificateContext(client_cert); + if(client_cert_store) + CertCloseStore(client_cert_store, 0); + + return CURLE_OUT_OF_MEMORY; + } + backend->cred->refcount = 1; + + /* Since we did not persist the key, we need to extend the store's + * lifetime until the end of the connection + */ + backend->cred->client_cert_store = client_cert_store; + + result = acquire_sspi_handle(cf, data, backend, client_cert, + flags, enabled_protocols); + + if(client_cert) + CertFreeCertificateContext(client_cert); + + return result; +} + +static CURLcode schannel_connect_step1(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + size_t written = 0; + struct ssl_connect_data *connssl = cf->ctx; + struct schannel_ssl_backend_data *backend = + (struct schannel_ssl_backend_data *)connssl->backend; + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + struct ssl_config_data *ssl_config = Curl_ssl_cf_get_config(cf, data); + SecBuffer outbuf; + SecBufferDesc outbuf_desc; + SecBuffer inbuf; + SecBufferDesc inbuf_desc; +#ifdef HAS_ALPN_SCHANNEL + unsigned char alpn_buffer[128]; +#endif + SECURITY_STATUS sspi_status = SEC_E_OK; + CURLcode result; + + DEBUGASSERT(backend); + DEBUGF(infof(data, "schannel: SSL/TLS connection with %s port %d (step 1/3)", + connssl->peer.origin->hostname, connssl->peer.origin->port)); + +#ifdef HAS_ALPN_SCHANNEL + backend->use_alpn = connssl->alpn && s_win_has_alpn; +#else + backend->use_alpn = FALSE; +#endif + + if(conn_config->CAfile || conn_config->ca_info_blob) { + if(curlx_verify_windows_version(6, 1, 0, PLATFORM_WINNT, + VERSION_GREATER_THAN_EQUAL)) { + backend->use_manual_cred_validation = TRUE; + } + else { + failf(data, "schannel: this version of Windows is too old to support " + "certificate verification via CA bundle file."); + return CURLE_SSL_CACERT_BADFILE; + } + } + else + backend->use_manual_cred_validation = FALSE; + + backend->cred = NULL; + + /* check for an existing reusable credential handle */ + if(Curl_ssl_scache_use(cf, data)) { + struct Curl_schannel_cred *old_cred; + Curl_ssl_scache_lock(data); + old_cred = Curl_ssl_scache_get_obj(cf, data, connssl->peer.scache_key); + if(old_cred) { + backend->cred = old_cred; + DEBUGF(infof(data, "schannel: reusing existing credential handle")); + + /* increment the reference counter of the credential/session handle */ + backend->cred->refcount++; + DEBUGF(infof(data, + "schannel: incremented credential handle refcount = %d", + backend->cred->refcount)); + } + Curl_ssl_scache_unlock(data); + } + + if(!backend->cred) { + char *snihost; + result = schannel_acquire_credential_handle(cf, data); + if(result || !backend->cred) + return result; + /* schannel_acquire_credential_handle() sets backend->cred accordingly or + it returns error otherwise. */ + + /* A hostname associated with the credential is needed by + InitializeSecurityContext for SNI and other reasons. */ + snihost = connssl->peer.sni ? + connssl->peer.sni : connssl->peer.origin->hostname; + backend->cred->sni_hostname = curlx_convert_UTF8_to_tchar(snihost); + if(!backend->cred->sni_hostname) + return CURLE_OUT_OF_MEMORY; + } + + /* Warn if SNI is disabled due to use of an IP address */ + if(connssl->peer.type != CURL_SSL_PEER_DNS) { + infof(data, "schannel: using IP address, SNI is not supported by OS."); + } + +#ifdef HAS_ALPN_SCHANNEL + if(backend->use_alpn) { + int cur = 0; + int list_start_index = 0; + unsigned int *extension_len = NULL; + unsigned short *list_len = NULL; + struct alpn_proto_buf proto; + + /* The first four bytes is an unsigned int indicating number + of bytes of data in the rest of the buffer. */ + extension_len = (unsigned int *)(void *)(&alpn_buffer[cur]); + cur += (int)sizeof(unsigned int); + + /* The next four bytes are an indicator that this buffer contains + ALPN data, as opposed to NPN, for example. */ + *(unsigned int *)(void *)&alpn_buffer[cur] = + SecApplicationProtocolNegotiationExt_ALPN; + cur += (int)sizeof(unsigned int); + + /* The next two bytes is an unsigned short indicating the number + of bytes used to list the preferred protocols. */ + list_len = (unsigned short *)(void *)(&alpn_buffer[cur]); + cur += (int)sizeof(unsigned short); + + list_start_index = cur; + + result = Curl_alpn_to_proto_buf(&proto, connssl->alpn); + if(result) { + failf(data, "Error setting ALPN"); + return CURLE_SSL_CONNECT_ERROR; + } + memcpy(&alpn_buffer[cur], proto.data, proto.len); + cur += proto.len; + + *list_len = curlx_uitous(cur - list_start_index); + *extension_len = (unsigned int)(*list_len + + sizeof(unsigned int) + sizeof(unsigned short)); + + InitSecBuffer(&inbuf, SECBUFFER_APPLICATION_PROTOCOLS, alpn_buffer, cur); + InitSecBufferDesc(&inbuf_desc, &inbuf, 1); + + Curl_alpn_to_proto_str(&proto, connssl->alpn); + infof(data, VTLS_INFOF_ALPN_OFFER_1STR, proto.data); + } + else { + InitSecBuffer(&inbuf, SECBUFFER_EMPTY, NULL, 0); + InitSecBufferDesc(&inbuf_desc, &inbuf, 1); + } +#else /* HAS_ALPN_SCHANNEL */ + InitSecBuffer(&inbuf, SECBUFFER_EMPTY, NULL, 0); + InitSecBufferDesc(&inbuf_desc, &inbuf, 1); +#endif + + /* setup output buffer */ + InitSecBuffer(&outbuf, SECBUFFER_EMPTY, NULL, 0); + InitSecBufferDesc(&outbuf_desc, &outbuf, 1); + + /* security request flags */ + backend->req_flags = + ISC_REQ_SEQUENCE_DETECT | ISC_REQ_REPLAY_DETECT | + ISC_REQ_CONFIDENTIALITY | ISC_REQ_ALLOCATE_MEMORY | + ISC_REQ_STREAM | + (!ssl_config->auto_client_cert ? ISC_REQ_USE_SUPPLIED_CREDS : 0); + + /* allocate memory for the security context handle */ + backend->ctxt = (struct Curl_schannel_ctxt *) + curlx_calloc(1, sizeof(struct Curl_schannel_ctxt)); + if(!backend->ctxt) { + failf(data, "schannel: unable to allocate memory"); + return CURLE_OUT_OF_MEMORY; + } + + /* Schannel InitializeSecurityContext: + https://learn.microsoft.com/windows/win32/api/sspi/nf-sspi-initializesecuritycontextw + + At the moment we do not pass inbuf unless we are using ALPN since we only + use it for that, and WINE (for which we currently disable ALPN) is giving + us problems with inbuf regardless. https://github.com/curl/curl/issues/983 + */ + sspi_status = Curl_pSecFn->InitializeSecurityContext( + &backend->cred->cred_handle, NULL, backend->cred->sni_hostname, + backend->req_flags, 0, 0, + (backend->use_alpn ? &inbuf_desc : NULL), + 0, &backend->ctxt->ctxt_handle, + &outbuf_desc, &backend->ret_flags, NULL); + + if(sspi_status != SEC_I_CONTINUE_NEEDED) { + char buffer[STRERROR_LEN]; + curlx_safefree(backend->ctxt); + switch(sspi_status) { + case SEC_E_INSUFFICIENT_MEMORY: + failf(data, "schannel: initial InitializeSecurityContext failed: %s", + Curl_sspi_strerror(sspi_status, buffer, sizeof(buffer))); + return CURLE_OUT_OF_MEMORY; + case SEC_E_WRONG_PRINCIPAL: + failf(data, "schannel: SNI or certificate check failed: %s", + Curl_sspi_strerror(sspi_status, buffer, sizeof(buffer))); + return CURLE_PEER_FAILED_VERIFICATION; +#if 0 + case SEC_E_INVALID_HANDLE: + case SEC_E_INVALID_TOKEN: + case SEC_E_LOGON_DENIED: + case SEC_E_TARGET_UNKNOWN: + case SEC_E_NO_AUTHENTICATING_AUTHORITY: + case SEC_E_INTERNAL_ERROR: + case SEC_E_NO_CREDENTIALS: + case SEC_E_UNSUPPORTED_FUNCTION: + case SEC_E_APPLICATION_PROTOCOL_MISMATCH: +#endif + default: + failf(data, "schannel: initial InitializeSecurityContext failed: %s", + Curl_sspi_strerror(sspi_status, buffer, sizeof(buffer))); + return CURLE_SSL_CONNECT_ERROR; + } + } + + DEBUGF(infof(data, "schannel: sending initial handshake data: " + "sending %lu bytes.", outbuf.cbBuffer)); + + /* send initial handshake data which is now stored in output buffer */ + result = Curl_conn_cf_send(cf->next, data, + (const uint8_t *)outbuf.pvBuffer, + outbuf.cbBuffer, FALSE, + &written); + Curl_pSecFn->FreeContextBuffer(outbuf.pvBuffer); + if(result || (outbuf.cbBuffer != written)) { + failf(data, "schannel: failed to send initial handshake data: " + "sent %zu of %lu bytes", written, outbuf.cbBuffer); + return CURLE_SSL_CONNECT_ERROR; + } + + DEBUGF(infof(data, "schannel: sent initial handshake data: " + "sent %zu bytes", written)); + + backend->recv_unrecoverable_err = CURLE_OK; + backend->recv_sspi_close_notify = FALSE; + backend->recv_connection_closed = FALSE; + backend->recv_renegotiating = FALSE; + backend->renegotiate_state.started = FALSE; + backend->encdata_is_incomplete = FALSE; + + /* continue to second handshake step */ + connssl->connecting_state = ssl_connect_2; + + return CURLE_OK; +} + +static CURLcode schannel_error(struct Curl_easy *data, + SECURITY_STATUS sspi_status) +{ + char buffer[STRERROR_LEN]; + switch(sspi_status) { + case SEC_E_INSUFFICIENT_MEMORY: + failf(data, "schannel: next InitializeSecurityContext failed: %s", + Curl_sspi_strerror(sspi_status, buffer, sizeof(buffer))); + return CURLE_OUT_OF_MEMORY; + case SEC_E_WRONG_PRINCIPAL: + failf(data, "schannel: SNI or certificate check failed: %s", + Curl_sspi_strerror(sspi_status, buffer, sizeof(buffer))); + return CURLE_PEER_FAILED_VERIFICATION; + case SEC_E_UNTRUSTED_ROOT: + failf(data, "schannel: %s", + Curl_sspi_strerror(sspi_status, buffer, sizeof(buffer))); + return CURLE_PEER_FAILED_VERIFICATION; +#if 0 + case SEC_E_INVALID_HANDLE: + case SEC_E_INVALID_TOKEN: + case SEC_E_LOGON_DENIED: + case SEC_E_TARGET_UNKNOWN: + case SEC_E_NO_AUTHENTICATING_AUTHORITY: + case SEC_E_INTERNAL_ERROR: + case SEC_E_NO_CREDENTIALS: + case SEC_E_UNSUPPORTED_FUNCTION: + case SEC_E_APPLICATION_PROTOCOL_MISMATCH: +#endif + default: + failf(data, "schannel: next InitializeSecurityContext failed: %s", + Curl_sspi_strerror(sspi_status, buffer, sizeof(buffer))); + return CURLE_SSL_CONNECT_ERROR; + } +} + +static CURLcode schannel_pkp_pin_peer_pubkey(struct Curl_cfilter *cf, + struct Curl_easy *data, + const char *pinnedpubkey) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct schannel_ssl_backend_data *backend = + (struct schannel_ssl_backend_data *)connssl->backend; + CERT_CONTEXT *pCertContextServer = NULL; + + /* Result is returned to caller */ + CURLcode result = CURLE_SSL_PINNEDPUBKEYNOTMATCH; + + DEBUGASSERT(backend); + + /* if a path was not specified, do not pin */ + if(!pinnedpubkey) + return CURLE_OK; + + do { + SECURITY_STATUS sspi_status; + const char *x509_der; + DWORD x509_der_len; + struct Curl_X509certificate x509_parsed; + struct Curl_asn1Element *pubkey; + + sspi_status = + Curl_pSecFn->QueryContextAttributes(&backend->ctxt->ctxt_handle, + SECPKG_ATTR_REMOTE_CERT_CONTEXT, + &pCertContextServer); + + if((sspi_status != SEC_E_OK) || !pCertContextServer) { + char buffer[STRERROR_LEN]; + failf(data, "schannel: Failed to read remote certificate context: %s", + Curl_sspi_strerror(sspi_status, buffer, sizeof(buffer))); + break; /* failed */ + } + + if(!(((pCertContextServer->dwCertEncodingType & X509_ASN_ENCODING) != 0) && + (pCertContextServer->cbCertEncoded > 0))) + break; + + x509_der = (const char *)pCertContextServer->pbCertEncoded; + x509_der_len = pCertContextServer->cbCertEncoded; + memset(&x509_parsed, 0, sizeof(x509_parsed)); + if(Curl_parseX509(&x509_parsed, x509_der, x509_der + x509_der_len)) + break; + + pubkey = &x509_parsed.subjectPublicKeyInfo; + if(!pubkey->header || pubkey->end <= pubkey->header) { + failf(data, "SSL: failed retrieving public key from server certificate"); + break; + } + + result = Curl_pin_peer_pubkey(data, + pinnedpubkey, + (const unsigned char *)pubkey->header, + (size_t)(pubkey->end - pubkey->header)); + if(result) { + failf(data, "SSL: public key does not match pinned public key"); + } + } while(0); + + if(pCertContextServer) + CertFreeCertificateContext(pCertContextServer); + + return result; +} + +static CURLcode ensure_encoding_size(struct Curl_easy *data, + struct sbuffer *encdata, + size_t min_length) +{ + size_t size; + DEBUGASSERT(encdata->length >= encdata->offset); + if(encdata->length < encdata->offset) + return CURLE_FAILED_INIT; + size = encdata->length - encdata->offset; + if(size < CURL_SCHANNEL_BUFFER_FREE_SIZE || encdata->length < min_length) { + unsigned char *buffer; + size_t length = encdata->offset + CURL_SCHANNEL_BUFFER_FREE_SIZE; + if(length < min_length) + length = min_length; + buffer = curlx_realloc(encdata->buffer, length); + if(!buffer) { + failf(data, "schannel: unable to re-allocate memory"); + return CURLE_OUT_OF_MEMORY; + } + + encdata->buffer = buffer; + encdata->length = length; + SCH_DEV(infof(data, "schannel: encdata.buffer resized %zu", + encdata->length)); + } + return CURLE_OK; +} + +static CURLcode ensure_decoding_size(struct Curl_easy *data, + struct sbuffer *decdata, + size_t nowsize, + size_t len) +{ + size_t size = nowsize > CURL_SCHANNEL_BUFFER_FREE_SIZE ? + nowsize : CURL_SCHANNEL_BUFFER_FREE_SIZE; + DEBUGASSERT(decdata->length >= decdata->offset); + if(decdata->length < decdata->offset) + return CURLE_FAILED_INIT; + else if(decdata->length - decdata->offset < size || + decdata->length < len) { + /* increase internal decrypted data buffer */ + size_t length = decdata->offset + size; + unsigned char *buffer; + /* make sure that the requested amount of data fits */ + if(length < len) + length = len; + + buffer = curlx_realloc(decdata->buffer, length); + if(!buffer) { + failf(data, "schannel: unable to re-allocate memory"); + return CURLE_OUT_OF_MEMORY; + } + decdata->buffer = buffer; + decdata->length = length; + } + return CURLE_OK; +} + +static CURLcode schannel_connect_step2(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct schannel_ssl_backend_data *backend = + (struct schannel_ssl_backend_data *)connssl->backend; + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + int i; + size_t nread = 0; + SecBuffer outbuf[3]; + SecBufferDesc outbuf_desc; + SecBuffer inbuf[2]; + SecBufferDesc inbuf_desc; + SECURITY_STATUS sspi_status = SEC_E_OK; + CURLcode result; + bool doread; + const char *pubkey_ptr; + + DEBUGASSERT(backend); + + doread = (connssl->io_need & CURL_SSL_IO_NEED_SEND) ? FALSE : TRUE; + connssl->io_need = CURL_SSL_IO_NEED_NONE; + + DEBUGF(infof(data, "schannel: SSL/TLS connection with %s port %d (step 2/3)", + connssl->peer.origin->hostname, connssl->peer.origin->port)); + + if(!backend->cred || !backend->ctxt) + return CURLE_SSL_CONNECT_ERROR; + + /* buffer to store previously received and decrypted data */ + if(!backend->decdata.buffer) { + backend->decdata.offset = 0; + backend->decdata.length = CURL_SCHANNEL_BUFFER_INIT_SIZE; + backend->decdata.buffer = curlx_malloc(backend->decdata.length); + if(!backend->decdata.buffer) { + failf(data, "schannel: unable to allocate memory"); + return CURLE_OUT_OF_MEMORY; + } + } + + /* buffer to store previously received and encrypted data */ + if(!backend->encdata.buffer) { + backend->encdata_is_incomplete = FALSE; + backend->encdata.offset = 0; + backend->encdata.length = CURL_SCHANNEL_BUFFER_INIT_SIZE; + backend->encdata.buffer = curlx_malloc(backend->encdata.length); + if(!backend->encdata.buffer) { + failf(data, "schannel: unable to allocate memory"); + return CURLE_OUT_OF_MEMORY; + } + } + + result = ensure_encoding_size(data, &backend->encdata, 0); + if(result) + return result; + + for(;;) { + if(doread) { + /* read encrypted handshake data from socket */ + result = Curl_conn_cf_recv(cf->next, data, + (char *)(backend->encdata.buffer + + backend->encdata.offset), + backend->encdata.length - + backend->encdata.offset, + &nread); + if(result == CURLE_AGAIN) { + if(!backend->encdata.offset || backend->encdata_is_incomplete) { + connssl->io_need = CURL_SSL_IO_NEED_RECV; + DEBUGF(infof(data, "schannel: failed to receive handshake, " + "need more data")); + return CURLE_OK; + } + else { + DEBUGF(infof(data, "schannel: no new handshake data received, " + "continuing to process existing handshake data")); + } + } + else if(result || (nread == 0)) { + failf(data, "schannel: failed to receive handshake, " + "SSL/TLS connection failed"); + return CURLE_SSL_CONNECT_ERROR; + } + else { + /* increase encrypted data buffer offset */ + backend->encdata.offset += nread; + backend->encdata_is_incomplete = FALSE; + SCH_DEV(infof(data, "schannel: encrypted data got %zu", nread)); + } + } + + SCH_DEV(infof(data, + "schannel: encrypted data buffer: offset %zu length %zu", + backend->encdata.offset, backend->encdata.length)); + + /* setup input buffers */ + InitSecBuffer(&inbuf[0], SECBUFFER_TOKEN, + curlx_malloc(backend->encdata.offset), + curlx_uztoul(backend->encdata.offset)); + InitSecBuffer(&inbuf[1], SECBUFFER_EMPTY, NULL, 0); + InitSecBufferDesc(&inbuf_desc, inbuf, 2); + + /* setup output buffers */ + InitSecBuffer(&outbuf[0], SECBUFFER_TOKEN, NULL, 0); + InitSecBuffer(&outbuf[1], SECBUFFER_ALERT, NULL, 0); + InitSecBuffer(&outbuf[2], SECBUFFER_EMPTY, NULL, 0); + InitSecBufferDesc(&outbuf_desc, outbuf, 3); + + if(!inbuf[0].pvBuffer) { + failf(data, "schannel: unable to allocate memory"); + return CURLE_OUT_OF_MEMORY; + } + + /* copy received handshake data into input buffer */ + memcpy(inbuf[0].pvBuffer, backend->encdata.buffer, + backend->encdata.offset); + + /* The socket must be writable (or a poll error occurred) before we call + InitializeSecurityContext to continue processing the received TLS + records. This is because that function is not idempotent and we do not + support partial save/resume sending replies of handshake tokens. */ + if(!SOCKET_WRITABLE(Curl_conn_cf_get_socket(cf, data), 0)) { + SCH_DEV(infof(data, "schannel: handshake waiting for writable socket")); + connssl->io_need = CURL_SSL_IO_NEED_SEND; + curlx_free(inbuf[0].pvBuffer); + return CURLE_OK; + } + + sspi_status = Curl_pSecFn->InitializeSecurityContext( + &backend->cred->cred_handle, &backend->ctxt->ctxt_handle, + backend->cred->sni_hostname, backend->req_flags, + 0, 0, &inbuf_desc, 0, NULL, + &outbuf_desc, &backend->ret_flags, NULL); + + /* free buffer for received handshake data */ + curlx_safefree(inbuf[0].pvBuffer); + + /* check if the handshake was incomplete */ + switch(sspi_status) { + case SEC_E_INCOMPLETE_MESSAGE: + backend->encdata_is_incomplete = TRUE; + connssl->io_need = CURL_SSL_IO_NEED_RECV; + DEBUGF(infof(data, + "schannel: received incomplete message, need more data")); + return CURLE_OK; + + case SEC_I_CONTINUE_NEEDED: + case SEC_E_OK: + /* check if the handshake needs to be continued */ + result = CURLE_OK; + for(i = 0; i < 3; i++) { + /* search for handshake tokens that need to be send */ + if(outbuf[i].BufferType == SECBUFFER_TOKEN && outbuf[i].cbBuffer > 0) { + size_t written = 0; + DEBUGF(infof(data, "schannel: sending next handshake data: " + "sending %lu bytes.", outbuf[i].cbBuffer)); + + /* send handshake token to server */ + result = Curl_conn_cf_send(cf->next, data, + (const uint8_t *)outbuf[i].pvBuffer, + outbuf[i].cbBuffer, + FALSE, &written); + if(result || (outbuf[i].cbBuffer != written)) { + failf(data, "schannel: failed to send next handshake data: " + "sent %zu of %lu bytes", written, outbuf[i].cbBuffer); + result = CURLE_SSL_CONNECT_ERROR; + } + } + } + for(i = 0; i < 3; i++) { + /* free obsolete buffer */ + if(outbuf[i].pvBuffer) + Curl_pSecFn->FreeContextBuffer(outbuf[i].pvBuffer); + } + if(result) + return result; + break; + + case SEC_I_INCOMPLETE_CREDENTIALS: + if(!(backend->req_flags & ISC_REQ_USE_SUPPLIED_CREDS)) { + /* If the server has requested a client certificate, attempt to + continue the handshake without one. This allows connections to + servers which request a client certificate but do not require + it. */ + backend->req_flags |= ISC_REQ_USE_SUPPLIED_CREDS; + connssl->io_need = CURL_SSL_IO_NEED_SEND; + DEBUGF(infof(data, + "schannel: a client certificate has been requested")); + return CURLE_OK; + } + FALLTHROUGH(); + + default: + return schannel_error(data, sspi_status); + } + + /* check if there was additional remaining encrypted data */ + if(inbuf[1].BufferType == SECBUFFER_EXTRA && inbuf[1].cbBuffer > 0) { + SCH_DEV(infof(data, "schannel: encrypted data length: %lu", + inbuf[1].cbBuffer)); + /* + There are two cases where we could be getting extra data here: + 1. If we are renegotiating a connection and the handshake is already + complete (from the server perspective), it can encrypted app data + (not handshake data) in an extra buffer at this point. + 2. (sspi_status == SEC_I_CONTINUE_NEEDED) We are negotiating a + connection and this extra data is part of the handshake. + We should process the data immediately; waiting for the socket to + be ready may fail since the server is done sending handshake data. + */ + /* check if the remaining data is less than the total amount + and therefore begins after the already processed data */ + if(backend->encdata.offset > inbuf[1].cbBuffer) { + memmove(backend->encdata.buffer, + (backend->encdata.buffer + backend->encdata.offset) - + inbuf[1].cbBuffer, inbuf[1].cbBuffer); + backend->encdata.offset = inbuf[1].cbBuffer; + if(sspi_status == SEC_I_CONTINUE_NEEDED) { + doread = FALSE; + continue; + } + } + } + else { + backend->encdata.offset = 0; + } + break; + } + + /* check if the handshake needs to be continued */ + if(sspi_status == SEC_I_CONTINUE_NEEDED) { + connssl->io_need = CURL_SSL_IO_NEED_RECV; + return CURLE_OK; + } + + /* check if the handshake is complete */ + if(sspi_status == SEC_E_OK) { + connssl->connecting_state = ssl_connect_3; + DEBUGF(infof(data, "schannel: SSL/TLS handshake complete")); + } + +#ifndef CURL_DISABLE_PROXY + pubkey_ptr = Curl_ssl_cf_is_proxy(cf) ? + data->set.str[STRING_SSL_PINNEDPUBLICKEY_PROXY] : + data->set.str[STRING_SSL_PINNEDPUBLICKEY]; +#else + pubkey_ptr = data->set.str[STRING_SSL_PINNEDPUBLICKEY]; +#endif + if(pubkey_ptr) { + result = schannel_pkp_pin_peer_pubkey(cf, data, pubkey_ptr); + if(result) { + failf(data, "SSL: public key does not match pinned public key"); + return result; + } + } + + if(conn_config->verifypeer && backend->use_manual_cred_validation) { + /* Certificate verification also verifies the hostname if verifyhost */ + return Curl_verify_certificate(cf, data); + } + + /* Verify the hostname manually when certificate verification is disabled, + because in that case Schannel does not verify it. */ + if(!conn_config->verifypeer && conn_config->verifyhost) + return Curl_verify_host(cf, data); + + return CURLE_OK; +} + +static bool valid_cert_encoding(const CERT_CONTEXT *cert_context) +{ + return cert_context && + ((cert_context->dwCertEncodingType & X509_ASN_ENCODING) != 0) && + cert_context->pbCertEncoded && + (cert_context->cbCertEncoded > 0); +} + +typedef bool (*Read_crt_func)(const CERT_CONTEXT *ccert_context, + bool reverse_order, void *arg); + +static void traverse_cert_store(const CERT_CONTEXT *context, + Read_crt_func func, void *arg) +{ + const CERT_CONTEXT *current_context = NULL; + bool should_continue = TRUE; + bool first = TRUE; + bool reverse_order = FALSE; + while(should_continue && + (current_context = CertEnumCertificatesInStore( + context->hCertStore, + current_context)) != NULL) { + /* Windows 11 22H2 OS Build 22621.674 or higher enumerates certificates in + leaf-to-root order while all previous versions of Windows enumerate + certificates in root-to-leaf order. Determine the order of enumeration + by comparing SECPKG_ATTR_REMOTE_CERT_CONTEXT's pbCertContext with the + first certificate's pbCertContext. */ + if(first && context->pbCertEncoded != current_context->pbCertEncoded) + reverse_order = TRUE; + should_continue = func(current_context, reverse_order, arg); + first = FALSE; + } + + if(current_context) + CertFreeCertificateContext(current_context); +} + +static bool cert_counter_callback(const CERT_CONTEXT *ccert_context, + bool reverse_order, void *certs_count) +{ + (void)reverse_order; + if(valid_cert_encoding(ccert_context)) + (*(int *)certs_count)++; + if(*(int *)certs_count > MAX_ALLOWED_CERT_AMOUNT) + return FALSE; + return TRUE; +} + +struct Adder_args { + struct Curl_easy *data; + CURLcode result; + int idx; + int certs_count; +}; + +static bool add_cert_to_certinfo(const CERT_CONTEXT *ccert_context, + bool reverse_order, void *raw_arg) +{ + struct Adder_args *args = (struct Adder_args *)raw_arg; + args->result = CURLE_OK; + if(valid_cert_encoding(ccert_context)) { + const char *beg = (const char *)ccert_context->pbCertEncoded; + const char *end = beg + ccert_context->cbCertEncoded; + int insert_index = reverse_order ? (args->certs_count - 1) - args->idx : + args->idx; + args->result = Curl_extract_certinfo(args->data, insert_index, + beg, end); + args->idx++; + } + return args->result == CURLE_OK; +} + +static void schannel_session_free(void *sessionid) +{ + /* this is expected to be called under sessionid lock */ + struct Curl_schannel_cred *cred = sessionid; + + if(cred) { + cred->refcount--; + if(cred->refcount == 0) { + Curl_pSecFn->FreeCredentialsHandle(&cred->cred_handle); + curlx_free(cred->sni_hostname); + if(cred->client_cert_store) { + CertCloseStore(cred->client_cert_store, 0); + cred->client_cert_store = NULL; + } + curlx_safefree(cred); + } + } +} + +static CURLcode schannel_connect_step3(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct schannel_ssl_backend_data *backend = + (struct schannel_ssl_backend_data *)connssl->backend; + struct ssl_config_data *ssl_config = Curl_ssl_cf_get_config(cf, data); + CURLcode result = CURLE_OK; + SECURITY_STATUS sspi_status = SEC_E_OK; + CERT_CONTEXT *ccert_context = NULL; +#ifdef HAS_ALPN_SCHANNEL + SecPkgContext_ApplicationProtocol alpn_result; +#endif + + DEBUGASSERT(ssl_connect_3 == connssl->connecting_state); + DEBUGASSERT(backend); + + DEBUGF(infof(data, "schannel: SSL/TLS connection with %s port %d (step 3/3)", + connssl->peer.origin->hostname, connssl->peer.origin->port)); + + if(!backend->cred) + return CURLE_SSL_CONNECT_ERROR; + + /* check if the required context attributes are met */ + if(backend->ret_flags != backend->req_flags) { + if(!(backend->ret_flags & ISC_RET_SEQUENCE_DETECT)) + failf(data, "schannel: failed to setup sequence detection"); + if(!(backend->ret_flags & ISC_RET_REPLAY_DETECT)) + failf(data, "schannel: failed to setup replay detection"); + if(!(backend->ret_flags & ISC_RET_CONFIDENTIALITY)) + failf(data, "schannel: failed to setup confidentiality"); + if(!(backend->ret_flags & ISC_RET_ALLOCATED_MEMORY)) + failf(data, "schannel: failed to setup memory allocation"); + if(!(backend->ret_flags & ISC_RET_STREAM)) + failf(data, "schannel: failed to setup stream orientation"); + return CURLE_SSL_CONNECT_ERROR; + } + +#ifdef HAS_ALPN_SCHANNEL + if(backend->use_alpn) { + sspi_status = + Curl_pSecFn->QueryContextAttributes(&backend->ctxt->ctxt_handle, + SECPKG_ATTR_APPLICATION_PROTOCOL, + &alpn_result); + + if(sspi_status != SEC_E_OK) { + failf(data, "schannel: failed to retrieve ALPN result"); + return CURLE_SSL_CONNECT_ERROR; + } + + if(alpn_result.ProtoNegoStatus == + SecApplicationProtocolNegotiationStatus_Success) { + if(backend->recv_renegotiating && + connssl->negotiated.alpn && + strncmp(connssl->negotiated.alpn, + (const char *)alpn_result.ProtocolId, + alpn_result.ProtocolIdSize)) { + /* Renegotiation selected a different protocol now, we cannot + * deal with this */ + failf(data, "schannel: server selected an ALPN protocol too late"); + return CURLE_SSL_CONNECT_ERROR; + } + Curl_alpn_set_negotiated(cf, data, connssl, alpn_result.ProtocolId, + alpn_result.ProtocolIdSize); + } + else { + if(!backend->recv_renegotiating) + Curl_alpn_set_negotiated(cf, data, connssl, NULL, 0); + } + } +#endif + + /* save the current session data for possible reuse */ + if(Curl_ssl_scache_use(cf, data)) { + Curl_ssl_scache_lock(data); + /* Up ref count since call takes ownership */ + backend->cred->refcount++; + result = Curl_ssl_scache_add_obj(cf, data, connssl->peer.scache_key, + backend->cred, schannel_session_free); + Curl_ssl_scache_unlock(data); + if(result) + return result; + } + + if(ssl_config->certinfo) { + int certs_count = 0; + sspi_status = + Curl_pSecFn->QueryContextAttributes(&backend->ctxt->ctxt_handle, + SECPKG_ATTR_REMOTE_CERT_CONTEXT, + &ccert_context); + + if((sspi_status != SEC_E_OK) || !ccert_context) { + failf(data, "schannel: failed to retrieve remote cert context"); + return CURLE_PEER_FAILED_VERIFICATION; + } + + traverse_cert_store(ccert_context, cert_counter_callback, &certs_count); + if(certs_count > MAX_ALLOWED_CERT_AMOUNT) { + failf(data, "%d certificates is more than allowed (%d)", + certs_count, MAX_ALLOWED_CERT_AMOUNT); + CertFreeCertificateContext(ccert_context); + return CURLE_SSL_CONNECT_ERROR; + } + + result = Curl_ssl_init_certinfo(data, certs_count); + if(!result) { + struct Adder_args args; + args.data = data; + args.idx = 0; + args.certs_count = certs_count; + args.result = CURLE_OK; + traverse_cert_store(ccert_context, add_cert_to_certinfo, &args); + result = args.result; + } + CertFreeCertificateContext(ccert_context); + if(result) + return result; + } + + connssl->connecting_state = ssl_connect_done; + + return CURLE_OK; +} + +static CURLcode schannel_connect(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ + struct ssl_connect_data *connssl = cf->ctx; + CURLcode result; + + /* check if the connection has already been established */ + if(ssl_connection_complete == connssl->state) { + *done = TRUE; + return CURLE_OK; + } + + *done = FALSE; + + if(ssl_connect_1 == connssl->connecting_state) { + result = schannel_connect_step1(cf, data); + if(result) + return result; + } + + if(ssl_connect_2 == connssl->connecting_state) { + result = schannel_connect_step2(cf, data); + if(result) + return result; + } + + if(ssl_connect_3 == connssl->connecting_state) { + result = schannel_connect_step3(cf, data); + if(result) + return result; + } + + if(ssl_connect_done == connssl->connecting_state) { + connssl->state = ssl_connection_complete; + +#ifdef SECPKG_ATTR_ENDPOINT_BINDINGS /* mingw-w64 v9+, MS SDK 7.0A/VS2010+ */ + /* When SSPI is used in combination with Schannel + * we need the Schannel context to create the Schannel + * binding to pass the IIS extended protection checks. + * Available on Windows 7 or later. + */ + { + struct schannel_ssl_backend_data *backend = + (struct schannel_ssl_backend_data *)connssl->backend; + DEBUGASSERT(backend); + cf->conn->sslContext = &backend->ctxt->ctxt_handle; + } +#endif + + *done = TRUE; + } + + return CURLE_OK; +} + +enum schannel_renegotiate_caller_t { + SCH_RENEG_CALLER_IS_RECV, + SCH_RENEG_CALLER_IS_SEND +}; + +/* The maximum time we allow for Schannel renegotiation which may in some + rare cases block either due to libcurl (waiting on the socket) or Windows + (waiting on an interactive security prompt). Note Schannel "renegotiation" + is not necessarily literal TLS renegotiation, but means DecryptMessage + returned SEC_I_RENEGOTIATE which means at least the security context needs + to be re-established. */ +#define MAX_RENEG_BLOCK_TIME (60 * 1000) /* 60 seconds in milliseconds */ + +/* This function renegotiates the connection due to a server request received + by schannel_recv. This function returns CURLE_AGAIN if the renegotiation is + incomplete. In that case, we remain in the renegotiation (connecting) stage + and future calls to schannel_recv and schannel_send must call this function + first to complete the renegotiation. */ +static CURLcode schannel_recv_renegotiate( + struct Curl_cfilter *cf, struct Curl_easy *data, + enum schannel_renegotiate_caller_t caller) +{ + CURLcode result; + curl_socket_t sockfd; + struct ssl_connect_data *connssl = cf->ctx; + struct schannel_ssl_backend_data *backend = + (struct schannel_ssl_backend_data *)connssl->backend; + struct schannel_renegotiate_state *rs = &backend->renegotiate_state; + + if(!backend || !backend->recv_renegotiating) { + failf(data, "schannel: unexpected call to schannel_recv_renegotiate"); + return CURLE_SSL_CONNECT_ERROR; + } + DEBUGASSERT(caller <= SCH_RENEG_CALLER_IS_SEND); + if(caller == SCH_RENEG_CALLER_IS_RECV) + SCH_DEV(infof(data, "schannel: renegotiation caller is schannel_recv")); + else + SCH_DEV(infof(data, "schannel: renegotiation caller is schannel_send")); + + sockfd = Curl_conn_cf_get_socket(cf, data); + + if(sockfd == CURL_SOCKET_BAD) { + failf(data, "schannel: renegotiation missing socket"); + return CURLE_SSL_CONNECT_ERROR; + } + + if(!rs->started) { /* new renegotiation */ + infof(data, "schannel: renegotiating SSL/TLS connection"); + DEBUGASSERT(connssl->state == ssl_connection_complete); + DEBUGASSERT(connssl->connecting_state == ssl_connect_done); + connssl->state = ssl_connection_negotiating; + connssl->connecting_state = ssl_connect_2; + memset(rs, 0, sizeof(*rs)); + rs->io_need = CURL_SSL_IO_NEED_SEND; + rs->start_time = *Curl_pgrs_now(data); + rs->started = TRUE; + } + + for(;;) { + bool block_read, block_write, blocking, done; + curl_socket_t readfd, writefd; + timediff_t elapsed; + + elapsed = curlx_ptimediff_ms(Curl_pgrs_now(data), &rs->start_time); + if(elapsed >= MAX_RENEG_BLOCK_TIME) { + failf(data, "schannel: renegotiation timeout"); + result = CURLE_SSL_CONNECT_ERROR; + break; + } + + /* the current io_need state may have been overwritten since the last time + this function was called. restore the io_need state needed to continue + the renegotiation. */ + + connssl->io_need = rs->io_need; + + result = schannel_connect(cf, data, &done); + + rs->io_need = connssl->io_need; + + if(!result && !done) + result = CURLE_AGAIN; + + if(result != CURLE_AGAIN) + break; + + readfd = (rs->io_need & CURL_SSL_IO_NEED_RECV) ? sockfd : CURL_SOCKET_BAD; + writefd = (rs->io_need & CURL_SSL_IO_NEED_SEND) ? sockfd : CURL_SOCKET_BAD; + + if(readfd == CURL_SOCKET_BAD && writefd == CURL_SOCKET_BAD) + continue; + + /* connect should not have requested io read and write together */ + DEBUGASSERT(readfd == CURL_SOCKET_BAD || writefd == CURL_SOCKET_BAD); + + /* This function is partially blocking to avoid a stoppage that would + * occur if the user is waiting on the socket only in one direction. + * + * For example, if the user has called recv then they may not be waiting + * for a writable socket and vice versa, so we block to avoid that. + * + * In practice a wait is unlikely to occur. For caller recv if handshake + * data needs to be sent then we block for a writable socket that should + * be writable immediately except for OS resource constraints. For caller + * send if handshake data needs to be received then we block for a readable + * socket, which could take some time, but it is more likely the user has + * called recv since they had called it prior (only recv can start + * renegotiation and probably the user is going to call it again to get + * more of their data before calling send). + */ + + block_read = (caller == SCH_RENEG_CALLER_IS_SEND) ? TRUE : FALSE; + block_write = (caller == SCH_RENEG_CALLER_IS_RECV) ? TRUE : FALSE; + + blocking = (block_read && (readfd != CURL_SOCKET_BAD)) || + (block_write && (writefd != CURL_SOCKET_BAD)); + + SCH_DEV_SHOWBOOL(block_read); + SCH_DEV_SHOWBOOL(block_write); + SCH_DEV_SHOWBOOL(blocking); + + for(;;) { + int what; + timediff_t timeout_ms, remaining; + + result = Curl_pgrsUpdate(data); + if(result) + break; + + elapsed = curlx_ptimediff_ms(Curl_pgrs_now(data), &rs->start_time); + if(elapsed >= MAX_RENEG_BLOCK_TIME) { + failf(data, "schannel: renegotiation timeout"); + result = CURLE_SSL_CONNECT_ERROR; + break; + } + remaining = MAX_RENEG_BLOCK_TIME - elapsed; + + if(blocking) { + timeout_ms = Curl_timeleft_ms(data); + + if(timeout_ms < 0) { + result = CURLE_OPERATION_TIMEDOUT; + break; + } + + /* the blocking is in intervals so that the progress function can be + called every second */ + if(!timeout_ms || timeout_ms > 1000) + timeout_ms = 1000; + + if(timeout_ms > remaining) + timeout_ms = remaining; + } + else + timeout_ms = 0; + + SCH_DEV(infof(data, "schannel: renegotiation wait until socket is" + "%s%s for up to %" FMT_TIMEDIFF_T " ms", + ((readfd != CURL_SOCKET_BAD) ? " readable" : ""), + ((writefd != CURL_SOCKET_BAD) ? " writable" : ""), + timeout_ms)); + + what = Curl_socket_check(readfd, CURL_SOCKET_BAD, writefd, timeout_ms); + + if(what > 0 && (what & (CURL_CSELECT_IN | CURL_CSELECT_OUT))) { + SCH_DEV(infof(data, "schannel: renegotiation socket %s%s", + ((what & CURL_CSELECT_IN) ? "CURL_CSELECT_IN " : ""), + ((what & CURL_CSELECT_OUT) ? "CURL_CSELECT_OUT " : ""))); + result = CURLE_AGAIN; + break; + } + else if(!what) { + SCH_DEV(infof(data, "schannel: renegotiation socket timeout")); + if(blocking) + continue; + else + return CURLE_AGAIN; + } + + failf(data, "schannel: socket error during renegotiation"); + result = CURLE_SSL_CONNECT_ERROR; + break; + } + if(result != CURLE_AGAIN) + break; + } + + DEBUGASSERT(result != CURLE_AGAIN); + + rs->started = FALSE; + backend->recv_renegotiating = FALSE; + connssl->io_need = CURL_SSL_IO_NEED_NONE; + + if(result) + failf(data, "schannel: renegotiation failed"); + else + infof(data, "schannel: SSL/TLS connection renegotiated"); + + return result; +} + +static CURLcode schannel_send(struct Curl_cfilter *cf, struct Curl_easy *data, + const void *buf, size_t len, size_t *pnwritten) +{ + size_t data_len = 0; + unsigned char *ptr = NULL; + struct ssl_connect_data *connssl = cf->ctx; + SecBuffer outbuf[4]; + SecBufferDesc outbuf_desc; + SECURITY_STATUS sspi_status = SEC_E_OK; + CURLcode result = CURLE_OK; + struct schannel_ssl_backend_data *backend = + (struct schannel_ssl_backend_data *)connssl->backend; + + DEBUGASSERT(backend); + *pnwritten = 0; + + if(backend->recv_renegotiating) { + result = schannel_recv_renegotiate(cf, data, SCH_RENEG_CALLER_IS_SEND); + if(result) + return result; + } + + /* check if the maximum stream sizes were queried */ + if(backend->stream_sizes.cbMaximumMessage == 0) { + sspi_status = Curl_pSecFn->QueryContextAttributes( + &backend->ctxt->ctxt_handle, + SECPKG_ATTR_STREAM_SIZES, + &backend->stream_sizes); + if(sspi_status != SEC_E_OK) { + return CURLE_SEND_ERROR; + } + } + + /* check if the buffer is longer than the maximum message length */ + if(len > backend->stream_sizes.cbMaximumMessage) { + len = backend->stream_sizes.cbMaximumMessage; + } + + /* calculate the complete message length and allocate a buffer for it */ + data_len = backend->stream_sizes.cbHeader + len + + backend->stream_sizes.cbTrailer; + ptr = curlx_malloc(data_len); + if(!ptr) { + return CURLE_OUT_OF_MEMORY; + } + + /* setup output buffers (header, data, trailer, empty) */ + InitSecBuffer(&outbuf[0], SECBUFFER_STREAM_HEADER, + ptr, backend->stream_sizes.cbHeader); + InitSecBuffer(&outbuf[1], SECBUFFER_DATA, + ptr + backend->stream_sizes.cbHeader, curlx_uztoul(len)); + InitSecBuffer(&outbuf[2], SECBUFFER_STREAM_TRAILER, + ptr + backend->stream_sizes.cbHeader + len, + backend->stream_sizes.cbTrailer); + InitSecBuffer(&outbuf[3], SECBUFFER_EMPTY, NULL, 0); + InitSecBufferDesc(&outbuf_desc, outbuf, 4); + + /* copy data into output buffer */ + memcpy(outbuf[1].pvBuffer, buf, len); + + /* https://learn.microsoft.com/windows/win32/api/sspi/nf-sspi-encryptmessage */ + sspi_status = Curl_pSecFn->EncryptMessage(&backend->ctxt->ctxt_handle, 0, + &outbuf_desc, 0); + + /* check if the message was encrypted */ + if(sspi_status == SEC_E_OK) { + + /* send the encrypted message including header, data and trailer */ + len = outbuf[0].cbBuffer + outbuf[1].cbBuffer + outbuf[2].cbBuffer; + + /* + it is important to send the full message which includes the header, + encrypted payload, and trailer. Until the client receives all the + data a coherent message has not been delivered and the client + cannot read any of it. + + If we wanted to buffer the unwritten encrypted bytes, we would + tell the client that all data it has requested to be sent has been + sent. The unwritten encrypted bytes would be the first bytes to + send on the next invocation. + Here's the catch with this - if we tell the client that all the + bytes have been sent, does the client call this method again to + send the buffered data? Looking at who calls this function, it + seems the answer is NO. + */ + + /* send entire message or fail */ + while(len > *pnwritten) { + size_t this_write = 0; + int what; + timediff_t timeout_ms = Curl_timeleft_ms(data); + if(timeout_ms < 0) { + /* we already got the timeout */ + failf(data, "schannel: timed out sending data (bytes sent: %zu)", + *pnwritten); + result = CURLE_OPERATION_TIMEDOUT; + break; + } + else if(!timeout_ms) + timeout_ms = TIMEDIFF_T_MAX; + what = SOCKET_WRITABLE(Curl_conn_cf_get_socket(cf, data), timeout_ms); + if(what < 0) { + /* fatal error */ + failf(data, "select/poll on SSL socket, errno: %d", SOCKERRNO); + result = CURLE_SEND_ERROR; + break; + } + else if(what == 0) { + failf(data, "schannel: timed out sending data (bytes sent: %zu)", + *pnwritten); + result = CURLE_OPERATION_TIMEDOUT; + break; + } + /* socket is writable */ + + result = Curl_conn_cf_send(cf->next, data, + (const uint8_t *)ptr + *pnwritten, + len - *pnwritten, + FALSE, &this_write); + if(result == CURLE_AGAIN) + continue; + else if(result) { + break; + } + + *pnwritten += this_write; + } + } + else if(sspi_status == SEC_E_INSUFFICIENT_MEMORY) { + result = CURLE_OUT_OF_MEMORY; + } + else { + result = CURLE_SEND_ERROR; + } + + curlx_safefree(ptr); + + if(len == *pnwritten) + /* Encrypted message including header, data and trailer entirely sent. + The return value is the number of unencrypted bytes that were sent. */ + *pnwritten = outbuf[1].cbBuffer; + + return result; +} + +static CURLcode schannel_recv(struct Curl_cfilter *cf, struct Curl_easy *data, + char *buf, size_t len, size_t *pnread) +{ + size_t size = 0; + size_t nread = 0; + struct ssl_connect_data *connssl = cf->ctx; + SecBuffer inbuf[4]; + SecBufferDesc inbuf_desc; + SECURITY_STATUS sspi_status = SEC_E_OK; + struct schannel_ssl_backend_data *backend = + (struct schannel_ssl_backend_data *)connssl->backend; + CURLcode result = CURLE_OK; + + DEBUGASSERT(backend); + *pnread = 0; + + if(backend->recv_renegotiating) { + result = schannel_recv_renegotiate(cf, data, SCH_RENEG_CALLER_IS_RECV); + if(result) + return result; + } + + /**************************************************************************** + * Do not return or set backend->recv_unrecoverable_err unless in the + * cleanup. The pattern for return error is set *err, optional infof, goto + * cleanup. + * + * Some verbose debug messages are wrapped by SCH_DEV() instead of DEBUGF() + * and only shown if CURL_SCHANNEL_DEV_DEBUG was defined at build time. These + * messages are extra verbose and intended for curl developers debugging + * Schannel recv decryption. + * + * Our priority is to always return as much decrypted data to the caller as + * possible, even if an error occurs. The state of the decrypted buffer must + * always be valid. Transfer of decrypted data to the caller's buffer is + * handled in the cleanup. + */ + + SCH_DEV(infof(data, "schannel: client wants to read %zu bytes", len)); + + if(len && len <= backend->decdata.offset) { + SCH_DEV(infof(data, + "schannel: enough decrypted data is already available")); + goto cleanup; + } + else if(backend->recv_unrecoverable_err) { + result = backend->recv_unrecoverable_err; + infof(data, "schannel: an unrecoverable error occurred in a prior call"); + goto cleanup; + } + else if(backend->recv_sspi_close_notify) { + /* once a server has indicated shutdown there is no more encrypted data */ + infof(data, "schannel: server indicated shutdown in a prior call"); + goto cleanup; + } + /* it is debatable what to return when !len. Regardless we cannot return + immediately because there may be data to decrypt (in the case we want to + decrypt all encrypted cached data) so handle !len later in cleanup. + */ + else if(len && !backend->recv_connection_closed) { + /* the encrypted buffer must be large enough to hold all the bytes + requested and some TLS record overhead. 'len' is a buffer size, so this + integer math cannot overflow. */ + const size_t min_encdata_length = len + CURL_SCHANNEL_BUFFER_FREE_SIZE; + + /* make sure encrypt buffer fits the requested amount of data */ + result = ensure_encoding_size(data, &backend->encdata, min_encdata_length); + if(result) + goto cleanup; + + SCH_DEV(infof(data, + "schannel: encrypted data buffer: offset %zu length %zu", + backend->encdata.offset, backend->encdata.length)); + + /* read encrypted data from socket */ + result = Curl_conn_cf_recv(cf->next, data, + (char *)(backend->encdata.buffer + + backend->encdata.offset), + backend->encdata.length - + backend->encdata.offset, + &nread); + if(result) { + if(result == CURLE_AGAIN) + SCH_DEV(infof(data, "schannel: recv returned CURLE_AGAIN")); + else { + infof(data, "schannel: recv returned error %d", (int)result); + backend->recv_unrecoverable_err = result; + } + } + else if(nread == 0) { + backend->recv_connection_closed = TRUE; + DEBUGF(infof(data, "schannel: server closed the connection")); + } + else { + backend->encdata.offset += nread; + backend->encdata_is_incomplete = FALSE; + SCH_DEV(infof(data, "schannel: encrypted data got %zu", nread)); + } + } + + SCH_DEV(infof(data, "schannel: encrypted data buffer: offset %zu length %zu", + backend->encdata.offset, backend->encdata.length)); + + /* decrypt loop */ + while(backend->encdata.offset > 0 && sspi_status == SEC_E_OK && + (!len || backend->decdata.offset < len || + backend->recv_connection_closed)) { + /* prepare data buffer for DecryptMessage call */ + InitSecBuffer(&inbuf[0], SECBUFFER_DATA, backend->encdata.buffer, + curlx_uztoul(backend->encdata.offset)); + + /* we need 3 more empty input buffers for possible output */ + InitSecBuffer(&inbuf[1], SECBUFFER_EMPTY, NULL, 0); + InitSecBuffer(&inbuf[2], SECBUFFER_EMPTY, NULL, 0); + InitSecBuffer(&inbuf[3], SECBUFFER_EMPTY, NULL, 0); + InitSecBufferDesc(&inbuf_desc, inbuf, 4); + + /* https://learn.microsoft.com/windows/win32/api/sspi/nf-sspi-decryptmessage + */ + sspi_status = Curl_pSecFn->DecryptMessage(&backend->ctxt->ctxt_handle, + &inbuf_desc, 0, NULL); + + /* check if everything went fine (server may want to renegotiate + or shutdown the connection context) */ + if(sspi_status == SEC_E_OK || sspi_status == SEC_I_RENEGOTIATE || + sspi_status == SEC_I_CONTEXT_EXPIRED) { + /* check for successfully decrypted data, even before actual + renegotiation or shutdown of the connection context */ + if(inbuf[1].BufferType == SECBUFFER_DATA) { + SCH_DEV(infof(data, "schannel: decrypted data length: %lu", + inbuf[1].cbBuffer)); + + /* ensure the decode buffer fits the received amount of data */ + result = ensure_decoding_size(data, &backend->decdata, + inbuf[1].cbBuffer, len); + if(result) + goto cleanup; + + /* copy decrypted data to internal buffer */ + size = inbuf[1].cbBuffer; + if(size) { + memcpy(backend->decdata.buffer + backend->decdata.offset, + inbuf[1].pvBuffer, size); + backend->decdata.offset += size; + } + + SCH_DEV(infof(data, "schannel: decrypted data added: %zu", size)); + SCH_DEV(infof(data, + "schannel: decrypted cached: offset %zu length %zu", + backend->decdata.offset, backend->decdata.length)); + } + + /* check for remaining encrypted data */ + if(inbuf[3].BufferType == SECBUFFER_EXTRA && inbuf[3].cbBuffer > 0) { + SCH_DEV(infof(data, "schannel: encrypted data length: %lu", + inbuf[3].cbBuffer)); + + /* check if the remaining data is less than the total amount + * and therefore begins after the already processed data + */ + if(backend->encdata.offset > inbuf[3].cbBuffer) { + /* move remaining encrypted data forward to the beginning of + buffer */ + memmove(backend->encdata.buffer, + (backend->encdata.buffer + backend->encdata.offset) - + inbuf[3].cbBuffer, inbuf[3].cbBuffer); + backend->encdata.offset = inbuf[3].cbBuffer; + } + + SCH_DEV(infof(data, + "schannel: encrypted cached: offset %zu length %zu", + backend->encdata.offset, backend->encdata.length)); + } + else { + /* reset encrypted buffer offset, because there is no data remaining */ + backend->encdata.offset = 0; + } + + /* check if server wants to renegotiate the connection context */ + if(sspi_status == SEC_I_RENEGOTIATE) { + infof(data, "schannel: remote party requests renegotiation"); + if(result && result != CURLE_AGAIN) { + infof(data, "schannel: cannot renegotiate, an error is pending"); + goto cleanup; + } + + backend->recv_renegotiating = TRUE; + result = schannel_recv_renegotiate(cf, data, SCH_RENEG_CALLER_IS_RECV); + if(result) + goto cleanup; + + /* now retry receiving data */ + sspi_status = SEC_E_OK; + continue; + } + /* check if the server closed the connection */ + else if(sspi_status == SEC_I_CONTEXT_EXPIRED) { + /* In Windows 2000 SEC_I_CONTEXT_EXPIRED (close_notify) is not + returned so we have to work around that in cleanup. */ + backend->recv_sspi_close_notify = TRUE; + if(!backend->recv_connection_closed) + backend->recv_connection_closed = TRUE; + /* We received the close notify fine, any error we got + * from the lower filters afterwards (e.g. the socket), is not + * an error on the TLS data stream. That one ended here. */ + if(result == CURLE_RECV_ERROR) + result = CURLE_OK; + infof(data, + "schannel: server close notification received (close_notify)"); + goto cleanup; + } + } + else if(sspi_status == SEC_E_INCOMPLETE_MESSAGE) { + backend->encdata_is_incomplete = TRUE; + if(!result) + result = CURLE_AGAIN; + SCH_DEV(infof(data, "schannel: failed to decrypt data, need more data")); + goto cleanup; + } + else { + char buffer[STRERROR_LEN]; + failf(data, "schannel: failed to read data from server: %s", + Curl_sspi_strerror(sspi_status, buffer, sizeof(buffer))); + result = CURLE_RECV_ERROR; + goto cleanup; + } + } + + SCH_DEV(infof(data, "schannel: encrypted data buffer: offset %zu length %zu", + backend->encdata.offset, backend->encdata.length)); + + SCH_DEV(infof(data, "schannel: decrypted data buffer: offset %zu length %zu", + backend->decdata.offset, backend->decdata.length)); + +cleanup: + /* Warning- there is no guarantee the encdata state is valid at this point */ + SCH_DEV(infof(data, "schannel: schannel_recv cleanup")); + + /* Error if the connection has closed without a close_notify. + + The behavior here is a matter of debate. We do not want to be vulnerable + to a truncation attack however there is some browser precedent for + ignoring the close_notify for compatibility reasons. + */ + if(len && !backend->decdata.offset && backend->recv_connection_closed && + !backend->recv_sspi_close_notify) { + result = CURLE_RECV_ERROR; + failf(data, "schannel: server closed abruptly (missing close_notify)"); + } + + /* Any error other than CURLE_AGAIN is an unrecoverable error. */ + if(result && result != CURLE_AGAIN) + backend->recv_unrecoverable_err = result; + + size = len < backend->decdata.offset ? len : backend->decdata.offset; + if(size) { + memcpy(buf, backend->decdata.buffer, size); + memmove(backend->decdata.buffer, backend->decdata.buffer + size, + backend->decdata.offset - size); + backend->decdata.offset -= size; + SCH_DEV(infof(data, "schannel: decrypted data returned %zu", size)); + SCH_DEV(infof(data, + "schannel: decrypted data buffer: offset %zu length %zu", + backend->decdata.offset, backend->decdata.length)); + *pnread = size; + return CURLE_OK; + } + + if(!result && !backend->recv_connection_closed) + result = CURLE_AGAIN; + + /* it is debatable what to return when !len. We could return whatever error + we got from decryption but instead we override here so the return is + consistent. + */ + if(!len) + return CURLE_OK; + + return result; +} + +static bool schannel_data_pending(struct Curl_cfilter *cf, + const struct Curl_easy *data) +{ + const struct ssl_connect_data *connssl = cf->ctx; + struct schannel_ssl_backend_data *backend = + (struct schannel_ssl_backend_data *)connssl->backend; + + (void)data; + DEBUGASSERT(backend); + + if(backend->ctxt) /* SSL/TLS is in use */ + return backend->decdata.offset > 0 || + (backend->encdata.offset > 0 && !backend->encdata_is_incomplete) || + backend->recv_connection_closed || + backend->recv_sspi_close_notify || + backend->recv_unrecoverable_err; + else + return FALSE; +} + +/* shut down the SSL connection and clean up related memory. + this function can be called multiple times on the same connection including + if the SSL connection failed (eg connection made but failed handshake). */ +static CURLcode schannel_shutdown(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool send_shutdown, bool *done) +{ + /* See https://learn.microsoft.com/windows/win32/secauthn/shutting-down-an-schannel-connection + * Shutting Down an Schannel Connection + */ + struct ssl_connect_data *connssl = cf->ctx; + struct schannel_ssl_backend_data *backend = + (struct schannel_ssl_backend_data *)connssl->backend; + CURLcode result = CURLE_OK; + + if(cf->shutdown) { + *done = TRUE; + return CURLE_OK; + } + + DEBUGASSERT(data); + DEBUGASSERT(backend); + + /* Not supported in schannel */ + (void)send_shutdown; + + *done = FALSE; + if(backend->ctxt) { + infof(data, "schannel: shutting down SSL/TLS connection with %s port %d", + connssl->peer.origin->hostname, connssl->peer.origin->port); + } + + if(!backend->ctxt || cf->shutdown) { + *done = TRUE; + goto out; + } + + if(backend->cred && backend->ctxt && !backend->sent_shutdown) { + SecBufferDesc BuffDesc; + SecBuffer Buffer; + SECURITY_STATUS sspi_status; + SecBuffer outbuf; + SecBufferDesc outbuf_desc; + DWORD dwshut = SCHANNEL_SHUTDOWN; + + InitSecBuffer(&Buffer, SECBUFFER_TOKEN, &dwshut, sizeof(dwshut)); + InitSecBufferDesc(&BuffDesc, &Buffer, 1); + + sspi_status = Curl_pSecFn->ApplyControlToken(&backend->ctxt->ctxt_handle, + &BuffDesc); + + if(sspi_status != SEC_E_OK) { + char buffer[STRERROR_LEN]; + failf(data, "schannel: ApplyControlToken failure: %s", + Curl_sspi_strerror(sspi_status, buffer, sizeof(buffer))); + result = CURLE_SEND_ERROR; + goto out; + } + + /* setup output buffer */ + InitSecBuffer(&outbuf, SECBUFFER_EMPTY, NULL, 0); + InitSecBufferDesc(&outbuf_desc, &outbuf, 1); + + sspi_status = Curl_pSecFn->InitializeSecurityContext( + &backend->cred->cred_handle, + &backend->ctxt->ctxt_handle, + backend->cred->sni_hostname, + backend->req_flags, + 0, + 0, + NULL, + 0, + &backend->ctxt->ctxt_handle, + &outbuf_desc, + &backend->ret_flags, NULL); + + if((sspi_status == SEC_E_OK) || (sspi_status == SEC_I_CONTEXT_EXPIRED)) { + /* send close message which is in output buffer */ + size_t written; + + result = Curl_conn_cf_send(cf->next, data, + (const uint8_t *)outbuf.pvBuffer, + outbuf.cbBuffer, + FALSE, &written); + Curl_pSecFn->FreeContextBuffer(outbuf.pvBuffer); + if(!result) { + if(written < outbuf.cbBuffer) { + result = CURLE_SEND_ERROR; + failf(data, "schannel: failed to send close msg: %s" + " (bytes written: %zu)", curl_easy_strerror(result), written); + goto out; + } + backend->sent_shutdown = TRUE; + *done = TRUE; + } + else if(result == CURLE_AGAIN) { + connssl->io_need = CURL_SSL_IO_NEED_SEND; + result = CURLE_OK; + goto out; + } + else { + if(!backend->recv_connection_closed) { + result = CURLE_SEND_ERROR; + failf(data, "schannel: error sending close msg: %d", (int)result); + goto out; + } + /* Looks like server already closed the connection. + * An error to send our close notify is not a failure. */ + *done = TRUE; + result = CURLE_OK; + } + } + } + + /* If the connection seems open and we have not seen the close notify + * from the server yet, try to receive it. */ + if(backend->cred && backend->ctxt && + !backend->recv_sspi_close_notify && !backend->recv_connection_closed) { + char buffer[1024]; + size_t nread; + + result = schannel_recv(cf, data, buffer, sizeof(buffer), &nread); + if(result == CURLE_AGAIN) { + connssl->io_need = CURL_SSL_IO_NEED_RECV; + } + else if(result) { + CURL_TRC_CF(data, cf, "SSL shutdown, error %d", (int)result); + result = CURLE_RECV_ERROR; + } + else if(nread == 0) { + /* We got the close notify alert and are done. */ + backend->recv_connection_closed = TRUE; + *done = TRUE; + } + else { + /* still data coming in? */ + } + } + +out: + cf->shutdown = (result || *done); + return result; +} + +static void schannel_close(struct Curl_cfilter *cf, struct Curl_easy *data) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct schannel_ssl_backend_data *backend = + (struct schannel_ssl_backend_data *)connssl->backend; + + DEBUGASSERT(data); + DEBUGASSERT(backend); + + /* free SSPI Schannel API security context handle */ + if(backend->ctxt) { + DEBUGF(infof(data, "schannel: clear security context handle")); + Curl_pSecFn->DeleteSecurityContext(&backend->ctxt->ctxt_handle); + curlx_safefree(backend->ctxt); + } + + /* free SSPI Schannel API credential handle */ + if(backend->cred) { + Curl_ssl_scache_lock(data); + schannel_session_free(backend->cred); + Curl_ssl_scache_unlock(data); + backend->cred = NULL; + } + + /* free internal buffer for received encrypted data */ + if(backend->encdata.buffer) { + curlx_safefree(backend->encdata.buffer); + backend->encdata.length = 0; + backend->encdata.offset = 0; + backend->encdata_is_incomplete = FALSE; + } + + /* free internal buffer for received decrypted data */ + if(backend->decdata.buffer) { + curlx_safefree(backend->decdata.buffer); + backend->decdata.length = 0; + backend->decdata.offset = 0; + } +} + +static int schannel_init(void) +{ +#ifdef HAS_ALPN_SCHANNEL + typedef const char *(APIENTRY *WINE_GET_VERSION_FN)(void); +#if defined(__clang__) && __clang_major__ >= 16 +#pragma clang diagnostic push +#pragma clang diagnostic ignored "-Wcast-function-type-strict" +#endif + WINE_GET_VERSION_FN p_wine_get_version = + CURLX_FUNCTION_CAST(WINE_GET_VERSION_FN, + GetProcAddress(GetModuleHandle(TEXT("ntdll")), "wine_get_version")); +#if defined(__clang__) && __clang_major__ >= 16 +#pragma clang diagnostic pop +#endif + if(p_wine_get_version) { /* WINE detected */ + curl_off_t ver = 0; + const char *wine_version = p_wine_get_version(); /* e.g. "6.0.2" */ + /* Assume ALPN support with WINE 6.0 or upper */ + if(wine_version) + curlx_str_number(&wine_version, &ver, 20); + s_win_has_alpn = (ver >= 6); + } + else { + /* ALPN is supported on Windows 8.1 / Server 2012 R2 and above. */ + s_win_has_alpn = curlx_verify_windows_version(6, 3, 0, PLATFORM_WINNT, + VERSION_GREATER_THAN_EQUAL); + } +#endif /* HAS_ALPN_SCHANNEL */ + + return Curl_sspi_global_init() == CURLE_OK ? 1 : 0; +} + +static void schannel_cleanup(void) +{ + Curl_sspi_global_cleanup(); +} + +static size_t schannel_version(char *buffer, size_t size) +{ + return curl_msnprintf(buffer, size, "Schannel"); +} + +static CURLcode schannel_random(struct Curl_easy *data, + unsigned char *entropy, size_t length) +{ + (void)data; + + return Curl_win32_random(entropy, length); +} + +static CURLcode schannel_checksum(const unsigned char *input, + size_t inputlen, + unsigned char *checksum, + size_t checksumlen, + DWORD provType, + const unsigned int algId) +{ + CURLcode result = CURLE_FAILED_INIT; + + HCRYPTPROV hProv = 0; + HCRYPTHASH hHash = 0; + + size_t off; + + DWORD cbHashSize; + DWORD dwHashSizeLen; + DWORD dwChecksumLen; + + /* since this can fail in multiple ways, zero memory first so we never + * return old data + */ + memset(checksum, 0, checksumlen); + + if(!CryptAcquireContext(&hProv, NULL, NULL, provType, + CRYPT_VERIFYCONTEXT | CRYPT_SILENT)) + goto out; + + if(!CryptCreateHash(hProv, algId, 0, 0, &hHash)) + goto out; + + result = CURLE_BAD_FUNCTION_ARGUMENT; + + off = 0; + while(off < inputlen) { + DWORD chunk = (DWORD)CURLMIN(inputlen - off, 0xffffffffUL); + if(!CryptHashData(hHash, input + off, chunk, 0)) + goto out; + off += chunk; + } + + /* get hash size */ + cbHashSize = 0; + dwHashSizeLen = (DWORD)sizeof(cbHashSize); + if(!CryptGetHashParam(hHash, HP_HASHSIZE, (BYTE *)&cbHashSize, + &dwHashSizeLen, 0)) + goto out; + + /* check if hash fits into the return buffer */ + if(checksumlen < cbHashSize) + goto out; + + dwChecksumLen = (DWORD)checksumlen; + if(CryptGetHashParam(hHash, HP_HASHVAL, checksum, &dwChecksumLen, 0) && + dwChecksumLen == cbHashSize) + result = CURLE_OK; + +out: + if(hHash) + CryptDestroyHash(hHash); + + if(hProv) + CryptReleaseContext(hProv, 0); + + return result; +} + +static CURLcode schannel_sha256sum(const unsigned char *input, + size_t inputlen, + unsigned char *sha256sum, + size_t sha256len) +{ + return schannel_checksum(input, inputlen, sha256sum, sha256len, + PROV_RSA_AES, CALG_SHA_256); +} + +static void *schannel_get_internals(struct ssl_connect_data *connssl, + CURLINFO info) +{ + struct schannel_ssl_backend_data *backend = + (struct schannel_ssl_backend_data *)connssl->backend; + (void)info; + DEBUGASSERT(backend); + return &backend->ctxt->ctxt_handle; +} + +HCERTSTORE Curl_schannel_get_cached_cert_store(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + struct Curl_multi *multi = data->multi; + const struct curl_blob *ca_info_blob = conn_config->ca_info_blob; + struct schannel_cert_share *share; + const struct ssl_general_config *cfg = &data->set.general_ssl; + timediff_t timeout_ms; + unsigned char info_blob_digest[CURL_SHA256_DIGEST_LENGTH]; + + DEBUGASSERT(multi); + + if(!multi) { + return NULL; + } + + share = Curl_hash_pick(&multi->proto_hash, + CURL_UNCONST(MPROTO_SCHANNEL_CERT_SHARE_KEY), + sizeof(MPROTO_SCHANNEL_CERT_SHARE_KEY) - 1); + if(!share || !share->cert_store) { + return NULL; + } + + /* zero ca_cache_timeout completely disables caching */ + if(!cfg->ca_cache_timeout) { + return NULL; + } + + /* check for cache timeout by using the cached_x509_store_expired timediff + calculation pattern from openssl.c. + negative timeout means retain forever. */ + timeout_ms = cfg->ca_cache_timeout * (timediff_t)1000; + if(timeout_ms >= 0) { + timediff_t elapsed_ms = + curlx_ptimediff_ms(Curl_pgrs_now(data), &share->time); + if(elapsed_ms >= timeout_ms) { + return NULL; + } + } + + if(ca_info_blob) { + if(share->CAinfo_blob_size != ca_info_blob->len) { + return NULL; + } + if(schannel_sha256sum((const unsigned char *)ca_info_blob->data, + ca_info_blob->len, + info_blob_digest, + CURL_SHA256_DIGEST_LENGTH)) + return NULL; + if(memcmp(share->CAinfo_blob_digest, info_blob_digest, + CURL_SHA256_DIGEST_LENGTH)) { + return NULL; + } + } + else { + if(!conn_config->CAfile || !share->CAfile || + strcmp(share->CAfile, conn_config->CAfile)) { + return NULL; + } + } + + return share->cert_store; +} + +static void schannel_cert_share_free(void *key, size_t key_len, void *p) +{ + struct schannel_cert_share *share = p; + DEBUGASSERT(key_len == (sizeof(MPROTO_SCHANNEL_CERT_SHARE_KEY) - 1)); + DEBUGASSERT(!memcmp(MPROTO_SCHANNEL_CERT_SHARE_KEY, key, key_len)); + (void)key; + (void)key_len; + if(share->cert_store) { + CertCloseStore(share->cert_store, 0); + } + curlx_free(share->CAfile); + curlx_free(share); +} + +bool Curl_schannel_set_cached_cert_store(struct Curl_cfilter *cf, + struct Curl_easy *data, + HCERTSTORE cert_store) +{ + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + struct Curl_multi *multi = data->multi; + const struct curl_blob *ca_info_blob = conn_config->ca_info_blob; + struct schannel_cert_share *share; + unsigned char digest[CURL_SHA256_DIGEST_LENGTH]; + char *CAfile = NULL; + + DEBUGASSERT(multi); + + if(!multi) { + return FALSE; + } + + if(ca_info_blob) { + if(schannel_sha256sum((const unsigned char *)ca_info_blob->data, + ca_info_blob->len, digest, sizeof(digest))) { + return FALSE; + } + } + else if(conn_config->CAfile) { + CAfile = curlx_strdup(conn_config->CAfile); + if(!CAfile) { + return FALSE; + } + } + + share = Curl_hash_pick(&multi->proto_hash, + CURL_UNCONST(MPROTO_SCHANNEL_CERT_SHARE_KEY), + sizeof(MPROTO_SCHANNEL_CERT_SHARE_KEY) - 1); + if(!share) { + share = curlx_calloc(1, sizeof(*share)); + if(!share) { + curlx_free(CAfile); + return FALSE; + } + if(!Curl_hash_add2(&multi->proto_hash, + CURL_UNCONST(MPROTO_SCHANNEL_CERT_SHARE_KEY), + sizeof(MPROTO_SCHANNEL_CERT_SHARE_KEY) - 1, + share, schannel_cert_share_free)) { + curlx_free(share); + curlx_free(CAfile); + return FALSE; + } + } + + /* free old cache data */ + if(share->cert_store) { + CertCloseStore(share->cert_store, 0); + } + curlx_free(share->CAfile); + + if(ca_info_blob) { + memcpy(share->CAinfo_blob_digest, digest, sizeof(digest)); + share->CAinfo_blob_size = ca_info_blob->len; + } + else + share->CAinfo_blob_size = 0; + + share->time = curlx_now(); + share->cert_store = cert_store; + share->CAfile = CAfile; + return TRUE; +} + +const struct Curl_ssl Curl_ssl_schannel = { + { CURLSSLBACKEND_SCHANNEL, "schannel" }, /* info */ + + SSLSUPP_CERTINFO | + SSLSUPP_CAINFO_BLOB | + SSLSUPP_PINNEDPUBKEY | + SSLSUPP_CA_CACHE | + SSLSUPP_HTTPS_PROXY | + SSLSUPP_CIPHER_LIST, + + sizeof(struct schannel_ssl_backend_data), + + schannel_init, /* init */ + schannel_cleanup, /* cleanup */ + schannel_version, /* version */ + schannel_shutdown, /* shutdown */ + schannel_data_pending, /* data_pending */ + schannel_random, /* random */ + NULL, /* cert_status_request */ + schannel_connect, /* connect */ + Curl_ssl_adjust_pollset, /* adjust_pollset */ + schannel_get_internals, /* get_internals */ + schannel_close, /* close_one */ + NULL, /* close_all */ + NULL, /* set_engine */ + NULL, /* set_engine_default */ + NULL, /* engines_list */ + schannel_sha256sum, /* sha256sum */ + schannel_recv, /* recv decrypted data */ + schannel_send, /* send data to encrypt */ + NULL, /* get_channel_binding */ +}; + +#endif /* USE_SCHANNEL */ diff --git a/3rdparty/curl-8.21.0/lib/vtls/schannel.h b/3rdparty/curl-8.21.0/lib/vtls/schannel.h new file mode 100644 index 0000000000..fe49e9a9d0 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vtls/schannel.h @@ -0,0 +1,45 @@ +#ifndef HEADER_CURL_SCHANNEL_H +#define HEADER_CURL_SCHANNEL_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Marc Hoersken, , et al. + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_SCHANNEL + +#include + +#include "curl_sspi.h" +#include "cfilters.h" +#include "urldata.h" + +extern const struct Curl_ssl Curl_ssl_schannel; + +CURLcode Curl_verify_host(struct Curl_cfilter *cf, struct Curl_easy *data); + +CURLcode Curl_verify_certificate(struct Curl_cfilter *cf, + struct Curl_easy *data); + +#endif /* USE_SCHANNEL */ +#endif /* HEADER_CURL_SCHANNEL_H */ diff --git a/3rdparty/curl-8.21.0/lib/vtls/schannel_int.h b/3rdparty/curl-8.21.0/lib/vtls/schannel_int.h new file mode 100644 index 0000000000..b65ff79926 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vtls/schannel_int.h @@ -0,0 +1,169 @@ +#ifndef HEADER_CURL_SCHANNEL_INT_H +#define HEADER_CURL_SCHANNEL_INT_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Marc Hoersken, , et al. + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_SCHANNEL + +#include "vtls/vtls.h" +#include "curl_sha256.h" + +#if defined(_MSC_VER) && (_MSC_VER < 1700) +/* Workaround for warning: + 'type cast' : conversion from 'int' to 'LPCSTR' of greater size */ +#undef CERT_STORE_PROV_MEMORY +#undef CERT_STORE_PROV_SYSTEM_A +#undef CERT_STORE_PROV_SYSTEM_W +#define CERT_STORE_PROV_MEMORY ((LPCSTR)(size_t)2) +#define CERT_STORE_PROV_SYSTEM_A ((LPCSTR)(size_t)9) +#define CERT_STORE_PROV_SYSTEM_W ((LPCSTR)(size_t)10) +#endif + +/* Offered by mingw-w64 v8+, MS SDK 10.0.17763.0/VS2017 15.8+ */ +#ifndef SCH_CREDENTIALS_VERSION +#define SCH_CREDENTIALS_VERSION 0x00000005 + +typedef enum _eTlsAlgorithmUsage { + TlsParametersCngAlgUsageKeyExchange, + TlsParametersCngAlgUsageSignature, + TlsParametersCngAlgUsageCipher, + TlsParametersCngAlgUsageDigest, + TlsParametersCngAlgUsageCertSig +} eTlsAlgorithmUsage; + +/* !checksrc! disable TYPEDEFSTRUCT 1 */ +typedef struct _CRYPTO_SETTINGS { + eTlsAlgorithmUsage eAlgorithmUsage; + UNICODE_STRING strCngAlgId; + DWORD cChainingModes; + PUNICODE_STRING rgstrChainingModes; /* spellchecker:disable-line */ + DWORD dwMinBitLength; + DWORD dwMaxBitLength; +} CRYPTO_SETTINGS, *PCRYPTO_SETTINGS; + +/* !checksrc! disable TYPEDEFSTRUCT 1 */ +typedef struct _TLS_PARAMETERS { + DWORD cAlpnIds; + PUNICODE_STRING rgstrAlpnIds; /* spellchecker:disable-line */ + DWORD grbitDisabledProtocols; + DWORD cDisabledCrypto; + PCRYPTO_SETTINGS pDisabledCrypto; + DWORD dwFlags; +} TLS_PARAMETERS, *PTLS_PARAMETERS; + +/* !checksrc! disable TYPEDEFSTRUCT 1 */ +typedef struct _SCH_CREDENTIALS { + DWORD dwVersion; + DWORD dwCredFormat; + DWORD cCreds; + PCCERT_CONTEXT *paCred; + HCERTSTORE hRootStore; + + DWORD cMappers; + struct _HMAPPER **aphMappers; + + DWORD dwSessionLifespan; + DWORD dwFlags; + DWORD cTlsParameters; + PTLS_PARAMETERS pTlsParameters; +} SCH_CREDENTIALS, *PSCH_CREDENTIALS; + +#endif /* !SCH_CREDENTIALS_VERSION */ + +struct Curl_schannel_cred { + CredHandle cred_handle; + TCHAR *sni_hostname; + HCERTSTORE client_cert_store; + int refcount; +}; + +struct Curl_schannel_ctxt { + CtxtHandle ctxt_handle; +}; + +/* handle encoding/decoding buffers */ +struct sbuffer { + size_t length; + size_t offset; + unsigned char *buffer; +}; + +struct schannel_ssl_backend_data { + struct sbuffer encdata; + struct sbuffer decdata; + struct Curl_schannel_cred *cred; + struct Curl_schannel_ctxt *ctxt; + SecPkgContext_StreamSizes stream_sizes; + unsigned long req_flags, ret_flags; + CURLcode recv_unrecoverable_err; /* schannel_recv had an unrecoverable err */ + struct schannel_renegotiate_state { + bool started; + struct curltime start_time; + int io_need; + } renegotiate_state; + BIT(recv_sspi_close_notify); /* true if connection closed by close_notify */ + BIT(recv_connection_closed); /* true if connection closed, regardless how */ + BIT(recv_renegotiating); /* true if recv is doing renegotiation */ + BIT(use_alpn); /* true if ALPN is used for this connection */ + BIT(use_manual_cred_validation); /* true if manual cred validation is used */ + BIT(sent_shutdown); + /* encdata_is_incomplete: if encdata contains only a partial record that + cannot be decrypted without another recv() (that is, status is + SEC_E_INCOMPLETE_MESSAGE) then set this true. after recv() adds more + bytes into encdata then set this back to false. */ + BIT(encdata_is_incomplete); +}; + +struct schannel_cert_share { + unsigned char CAinfo_blob_digest[CURL_SHA256_DIGEST_LENGTH]; + size_t CAinfo_blob_size; /* CA info blob size */ + char *CAfile; /* CAfile path used to generate + certificate store */ + HCERTSTORE cert_store; /* cached certificate store or + NULL if none */ + struct curltime time; /* when the cached store was created */ +}; + +/* +* size of the structure: 20 bytes. +*/ +struct num_ip_data { + DWORD size; /* 04 bytes */ + union { + struct in_addr ia; /* 04 bytes */ + struct in6_addr ia6; /* 16 bytes */ + } bData; +}; + +HCERTSTORE Curl_schannel_get_cached_cert_store(struct Curl_cfilter *cf, + struct Curl_easy *data); + +bool Curl_schannel_set_cached_cert_store(struct Curl_cfilter *cf, + struct Curl_easy *data, + HCERTSTORE cert_store); + +#endif /* USE_SCHANNEL */ +#endif /* HEADER_CURL_SCHANNEL_INT_H */ diff --git a/3rdparty/curl-8.21.0/lib/vtls/schannel_verify.c b/3rdparty/curl-8.21.0/lib/vtls/schannel_verify.c new file mode 100644 index 0000000000..e5fe2249a6 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vtls/schannel_verify.c @@ -0,0 +1,835 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Marc Hoersken, + * Copyright (C) Mark Salisbury, + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +/* + * Source file for Schannel-specific certificate verification. This code should + * only be invoked by code in schannel.c. + */ +#include "curl_setup.h" + +#ifdef USE_SCHANNEL + +#ifndef USE_WINDOWS_SSPI +#error "cannot compile Schannel support without SSPI." +#endif + +#include "vtls/schannel.h" +#include "vtls/schannel_int.h" + +#include "vtls/hostcheck.h" +#include "vtls/vtls.h" +#include "vtls/vtls_int.h" +#include "curl_trc.h" +#include "strerror.h" +#include "curlx/fopen.h" +#include "curlx/inet_pton.h" +#include "curlx/multibyte.h" +#include "curlx/version_win32.h" +#include "curlx/winapi.h" + +#define BACKEND ((struct schannel_ssl_backend_data *)connssl->backend) + +#define MAX_CAFILE_SIZE (1024 * 1024) /* 1 MiB */ +#define BEGIN_CERT "-----BEGIN CERTIFICATE-----" +#define END_CERT "\n-----END CERTIFICATE-----" + +struct cert_chain_engine_config_win8 { + DWORD cbSize; + HCERTSTORE hRestrictedRoot; + HCERTSTORE hRestrictedTrust; + HCERTSTORE hRestrictedOther; + DWORD cAdditionalStore; + HCERTSTORE *rghAdditionalStore; + DWORD dwFlags; + DWORD dwUrlRetrievalTimeout; + DWORD MaximumCachedCertificates; + DWORD CycleDetectionModulus; + HCERTSTORE hExclusiveRoot; + HCERTSTORE hExclusiveTrustedPeople; + DWORD dwExclusiveFlags; +}; + +/* Offered by mingw-w64 v4+, MS SDK 8.0/~VS2012+ */ +#ifndef CERT_CHAIN_EXCLUSIVE_ENABLE_CA_FLAG +#define CERT_CHAIN_EXCLUSIVE_ENABLE_CA_FLAG 0x00000001 +#endif + +/* Legacy structure to supply size to Win7 clients */ +struct cert_chain_engine_config_win7 { + DWORD cbSize; + HCERTSTORE hRestrictedRoot; + HCERTSTORE hRestrictedTrust; + HCERTSTORE hRestrictedOther; + DWORD cAdditionalStore; + HCERTSTORE *rghAdditionalStore; + DWORD dwFlags; + DWORD dwUrlRetrievalTimeout; + DWORD MaximumCachedCertificates; + DWORD CycleDetectionModulus; + HCERTSTORE hExclusiveRoot; + HCERTSTORE hExclusiveTrustedPeople; +}; + +/* Search the substring needle,needlelen into string haystack,haystacklen + * Strings do not need to be terminated by a '\0'. + * Similar of macOS/Linux memmem (not available on Visual Studio). + * Return position of beginning of first occurrence or NULL if not found + */ +static const char *c_memmem(const void *haystack, size_t haystacklen, + const void *needle, size_t needlelen) +{ + const char *p; + char first; + const char *str_limit = (const char *)haystack + haystacklen; + if(!needlelen || needlelen > haystacklen) + return NULL; + first = *(const char *)needle; + for(p = (const char *)haystack; p <= (str_limit - needlelen); p++) + if((*p == first) && !memcmp(p, needle, needlelen)) + return p; + + return NULL; +} + +static CURLcode add_certs_data_to_store(HCERTSTORE trust_store, + const char *ca_buffer, + size_t ca_buffer_size, + const char *ca_file_text, + struct Curl_easy *data) +{ + const size_t begin_cert_len = strlen(BEGIN_CERT); + const size_t end_cert_len = strlen(END_CERT); + CURLcode result = CURLE_OK; + int num_certs = 0; + bool more_certs = 1; + const char *current_ca_file_ptr = ca_buffer; + const char *ca_buffer_limit = ca_buffer + ca_buffer_size; + + while(more_certs && (current_ca_file_ptr < ca_buffer_limit)) { + const char *begin_cert_ptr = c_memmem(current_ca_file_ptr, + ca_buffer_limit - + current_ca_file_ptr - 1, + BEGIN_CERT, + begin_cert_len); + if(!begin_cert_ptr || !ISNEWLINE(begin_cert_ptr[begin_cert_len])) { + more_certs = 0; + } + else { + const char *end_cert_ptr = c_memmem(begin_cert_ptr, + ca_buffer_limit-begin_cert_ptr, + END_CERT, + end_cert_len); + if(!end_cert_ptr) { + failf(data, + "schannel: CA file '%s' is not correctly formatted", + ca_file_text); + result = CURLE_SSL_CACERT_BADFILE; + more_certs = 0; + } + else { + CERT_BLOB cert_blob; + const CERT_CONTEXT *cert_context = NULL; + BOOL add_cert_result = FALSE; + DWORD cert_size = + (DWORD)((end_cert_ptr + end_cert_len) - begin_cert_ptr); + + cert_blob.pbData = (BYTE *)CURL_UNCONST(begin_cert_ptr); + cert_blob.cbData = cert_size; + /* Caution: CryptQueryObject() is deprecated */ + if(!CryptQueryObject(CERT_QUERY_OBJECT_BLOB, + &cert_blob, + CERT_QUERY_CONTENT_FLAG_CERT, + CERT_QUERY_FORMAT_FLAG_BASE64_ENCODED, + 0, + NULL, + NULL, + NULL, + NULL, + NULL, + (const void **)&cert_context)) { + char buffer[WINAPI_ERROR_LEN]; + failf(data, + "schannel: failed to extract certificate from CA file " + "'%s': %s", + ca_file_text, + curlx_winapi_strerror(GetLastError(), buffer, sizeof(buffer))); + result = CURLE_SSL_CACERT_BADFILE; + more_certs = 0; + } + else { + current_ca_file_ptr = begin_cert_ptr + cert_size; + + add_cert_result = + CertAddCertificateContextToStore(trust_store, + cert_context, + CERT_STORE_ADD_ALWAYS, + NULL); + if(!add_cert_result) { + char buffer[WINAPI_ERROR_LEN]; + failf(data, + "schannel: failed to add certificate from CA file '%s' " + "to certificate store: %s", + ca_file_text, + curlx_winapi_strerror(GetLastError(), buffer, + sizeof(buffer))); + result = CURLE_SSL_CACERT_BADFILE; + more_certs = 0; + } + else { + num_certs++; + } + + CertFreeCertificateContext(cert_context); + } + } + } + } + + if(result == CURLE_OK) { + if(!num_certs) { + infof(data, "schannel: did not add any certificates from CA file '%s'", + ca_file_text); + } + else { + infof(data, "schannel: added %d certificate(s) from CA file '%s'", + num_certs, ca_file_text); + } + } + return result; +} + +static CURLcode add_certs_file_to_store(HCERTSTORE trust_store, + const char *ca_file, + struct Curl_easy *data) +{ + CURLcode result; + FILE *ca_file_handle; + char *ca_file_buffer = NULL; + long ca_file_bufsize = 0; + long total_bytes_read = 0; + + /* + * Read the CA file completely into memory before parsing it. This + * optimizes for the common case where the CA file is relatively + * small ( < 1 MiB ). + */ + ca_file_handle = curlx_fopen(ca_file, "rb"); + if(!ca_file_handle) { + failf(data, "schannel: failed to open CA file '%s'", ca_file); + result = CURLE_SSL_CACERT_BADFILE; + goto cleanup; + } + + if(curlx_fseek(ca_file_handle, 0, SEEK_END)) { + failf(data, "schannel: failed seeking to end of CA file '%s'", ca_file); + result = CURLE_SSL_CACERT_BADFILE; + goto cleanup; + } + + ca_file_bufsize = ftell(ca_file_handle); + + if(curlx_fseek(ca_file_handle, 0, SEEK_SET)) { + failf(data, "schannel: failed seeking to beginning of CA file '%s'", + ca_file); + result = CURLE_SSL_CACERT_BADFILE; + goto cleanup; + } + + if(ca_file_bufsize < 0) { + failf(data, "schannel: failed to get length of CA file '%s'", ca_file); + result = CURLE_SSL_CACERT_BADFILE; + goto cleanup; + } + + if(ca_file_bufsize > MAX_CAFILE_SIZE) { + failf(data, "schannel: CA file exceeds max size of %d bytes", + MAX_CAFILE_SIZE); + result = CURLE_SSL_CACERT_BADFILE; + goto cleanup; + } + + ca_file_buffer = curlx_malloc(ca_file_bufsize + 1); + if(!ca_file_buffer) { + result = CURLE_OUT_OF_MEMORY; + goto cleanup; + } + + while(total_bytes_read < ca_file_bufsize) { + size_t nread = fread(ca_file_buffer + total_bytes_read, 1, + ca_file_bufsize - total_bytes_read, ca_file_handle); + + if(ferror(ca_file_handle)) { + failf(data, "schannel: failed to read from CA file '%s'", ca_file); + result = CURLE_SSL_CACERT_BADFILE; + goto cleanup; + } + + if(nread == 0) { + /* Premature EOF -- adjust the bufsize to the new value */ + ca_file_bufsize = total_bytes_read; + } + else { + total_bytes_read += (long)nread; + } + } + + /* null-terminate the buffer */ + ca_file_buffer[ca_file_bufsize] = '\0'; + + result = add_certs_data_to_store(trust_store, + ca_file_buffer, ca_file_bufsize, + ca_file, + data); + +cleanup: + if(ca_file_handle) { + curlx_fclose(ca_file_handle); + } + curlx_safefree(ca_file_buffer); + + return result; +} + +/* + * Returns the number of characters necessary to populate all the host_names. + * If host_names is not NULL, populate it with all the hostnames. Each string + * in the host_names is null-terminated and the last string is double + * null-terminated. If no DNS names are found, a single null-terminated empty + * string is returned. + */ +static DWORD cert_get_name_string(struct Curl_easy *data, + CERT_CONTEXT *cert_context, + LPTSTR host_names, + DWORD length, + PCERT_ALT_NAME_INFO alt_name_info, + BOOL Win8_compat) +{ + DWORD actual_length = 0; + BOOL compute_content = FALSE; + LPTSTR current_pos = NULL; + DWORD i; + + /* CERT_NAME_SEARCH_ALL_NAMES_FLAG is available from Windows 8 onwards. */ + if(Win8_compat) { +/* Offered by mingw-w64 v4+, MS SDK 8.0/~VS2012+ */ +#ifndef CERT_NAME_SEARCH_ALL_NAMES_FLAG +#define CERT_NAME_SEARCH_ALL_NAMES_FLAG 0x2 +#endif + /* CertGetNameString provides the 8-bit character string without + * any decoding */ + DWORD name_flags = + CERT_NAME_DISABLE_IE4_UTF8_FLAG | CERT_NAME_SEARCH_ALL_NAMES_FLAG; + actual_length = CertGetNameString(cert_context, + CERT_NAME_DNS_TYPE, + name_flags, + NULL, + host_names, + length); + return actual_length; + } + + if(!alt_name_info) + return 0; + + compute_content = host_names && length != 0; + + /* Initialize default return values. */ + actual_length = 1; + if(compute_content) { + *host_names = '\0'; + } + + current_pos = host_names; + + /* Iterate over the alternate names and populate host_names. */ + for(i = 0; i < alt_name_info->cAltEntry; i++) { + const CERT_ALT_NAME_ENTRY *entry = &alt_name_info->rgAltEntry[i]; + wchar_t *dns_w = NULL; + size_t current_length = 0; + + if(entry->dwAltNameChoice != CERT_ALT_NAME_DNS_NAME) { + continue; + } + if(!entry->pwszDNSName) { + infof(data, "schannel: Empty DNS name."); + continue; + } + current_length = wcslen(entry->pwszDNSName) + 1; + if(!compute_content) { + actual_length += (DWORD)current_length; + continue; + } + /* Sanity check to prevent buffer overrun. */ + if((actual_length + current_length) > length) { + failf(data, "schannel: Not enough memory to list all hostnames."); + break; + } + dns_w = entry->pwszDNSName; + /* pwszDNSName is in ia5 string format and hence does not contain any + * non-ASCII characters. */ + while(*dns_w != '\0') { + *current_pos++ = (TCHAR)(*dns_w++); + } + *current_pos++ = '\0'; + actual_length += (DWORD)current_length; + } + if(compute_content) { + /* Last string has double null-terminator. */ + *current_pos = '\0'; + } + return actual_length; +} + +/* + * Returns TRUE if the hostname is a numeric IPv4/IPv6 Address, + * and populates the buffer with IPv4/IPv6 info. + */ + +static bool get_num_host_info(struct num_ip_data *ip_blob, LPCSTR hostname) +{ + struct in_addr ia; + int res = curlx_inet_pton(AF_INET, hostname, &ia); + if(res) { + ip_blob->size = sizeof(struct in_addr); + memcpy(&ip_blob->bData.ia, &ia, sizeof(struct in_addr)); + return TRUE; + } + else { + struct in6_addr ia6; + res = curlx_inet_pton(AF_INET6, hostname, &ia6); + if(res) { + ip_blob->size = sizeof(struct in6_addr); + memcpy(&ip_blob->bData.ia6, &ia6, sizeof(struct in6_addr)); + return TRUE; + } + } + return FALSE; +} + +static bool get_alt_name_info(struct Curl_easy *data, + PCCERT_CONTEXT ctx, + PCERT_ALT_NAME_INFO *alt_name_info, + LPDWORD alt_name_info_size) +{ + PCERT_INFO cert_info = NULL; + PCERT_EXTENSION extension = NULL; + CRYPT_DECODE_PARA decode_para = { sizeof(CRYPT_DECODE_PARA), NULL, NULL }; + + if(!ctx) { + failf(data, "schannel: Null certificate context."); + return FALSE; + } + + cert_info = ctx->pCertInfo; + if(!cert_info) { + failf(data, "schannel: Null certificate info."); + return FALSE; + } + + extension = CertFindExtension(szOID_SUBJECT_ALT_NAME2, + cert_info->cExtension, + cert_info->rgExtension); + if(!extension) { + failf(data, "schannel: CertFindExtension() returned no extension."); + return FALSE; + } + + if(!CryptDecodeObjectEx(X509_ASN_ENCODING | PKCS_7_ASN_ENCODING, + szOID_SUBJECT_ALT_NAME2, + extension->Value.pbData, + extension->Value.cbData, + CRYPT_DECODE_ALLOC_FLAG | CRYPT_DECODE_NOCOPY_FLAG, + &decode_para, + alt_name_info, + alt_name_info_size)) { + failf(data, "schannel: CryptDecodeObjectEx() returned no alternate name " + "information."); + return FALSE; + } + return TRUE; +} + +/* Verify the server's hostname */ +CURLcode Curl_verify_host(struct Curl_cfilter *cf, struct Curl_easy *data) +{ + CURLcode result = CURLE_PEER_FAILED_VERIFICATION; + struct ssl_connect_data *connssl = cf->ctx; + CERT_CONTEXT *pCertContextServer = NULL; + SECURITY_STATUS sspi_status; + TCHAR *cert_hostname_buff = NULL; + size_t cert_hostname_buff_index = 0; + const char *conn_hostname = connssl->peer.origin->hostname; + size_t hostlen = strlen(conn_hostname); + DWORD len = 0; + DWORD actual_len = 0; + PCERT_ALT_NAME_INFO alt_name_info = NULL; + DWORD alt_name_info_size = 0; + struct num_ip_data ip_blob = { 0 }; + bool Win8_compat; + struct num_ip_data *p = &ip_blob; + DWORD i; + + sspi_status = + Curl_pSecFn->QueryContextAttributes(&BACKEND->ctxt->ctxt_handle, + SECPKG_ATTR_REMOTE_CERT_CONTEXT, + &pCertContextServer); + + if((sspi_status != SEC_E_OK) || !pCertContextServer) { + char buffer[WINAPI_ERROR_LEN]; + failf(data, "schannel: Failed to read remote certificate context: %s", + Curl_sspi_strerror(sspi_status, buffer, sizeof(buffer))); + goto cleanup; + } + + Win8_compat = curlx_verify_windows_version(6, 2, 0, PLATFORM_WINNT, + VERSION_GREATER_THAN_EQUAL); + if(get_num_host_info(p, conn_hostname) || !Win8_compat) { + if(!get_alt_name_info(data, pCertContextServer, + &alt_name_info, &alt_name_info_size)) { + goto cleanup; + } + } + + if(p->size && alt_name_info) { + for(i = 0; i < alt_name_info->cAltEntry; ++i) { + PCERT_ALT_NAME_ENTRY entry = &alt_name_info->rgAltEntry[i]; + if(entry->dwAltNameChoice == CERT_ALT_NAME_IP_ADDRESS) { + if(entry->IPAddress.cbData == p->size) { + if(!memcmp(entry->IPAddress.pbData, &p->bData, + entry->IPAddress.cbData)) { + result = CURLE_OK; + infof(data, + "schannel: connection hostname (%s) matched cert's IP address!", + conn_hostname); + break; + } + } + } + } + } + else { + /* Determine the size of the string needed for the cert hostname */ + len = cert_get_name_string(data, pCertContextServer, + NULL, 0, alt_name_info, Win8_compat); + if(len == 0) { + failf(data, + "schannel: CertGetNameString() returned no " + "certificate name information"); + goto cleanup; + } + + /* CertGetNameString guarantees that the returned name does not contain + * embedded null bytes. This appears to be undocumented behavior. + */ + cert_hostname_buff = curlx_malloc(len * sizeof(TCHAR)); + if(!cert_hostname_buff) { + result = CURLE_OUT_OF_MEMORY; + goto cleanup; + } + actual_len = cert_get_name_string(data, pCertContextServer, + (LPTSTR)cert_hostname_buff, len, + alt_name_info, Win8_compat); + + /* Sanity check */ + if(actual_len != len) { + failf(data, + "schannel: CertGetNameString() returned certificate " + "name information of unexpected size"); + goto cleanup; + } + + /* cert_hostname_buff contains all DNS names, where each name is + * null-terminated and the last DNS name is double null-terminated. Due to + * this encoding, use the length of the buffer to iterate over all names. + */ + while(cert_hostname_buff_index < len && + cert_hostname_buff[cert_hostname_buff_index] != TEXT('\0') && + result == CURLE_PEER_FAILED_VERIFICATION) { + char *cert_hostname; + + /* Comparing the cert name and the connection hostname encoded as UTF-8 + * is acceptable since both values are assumed to use ASCII + * (or some equivalent) encoding + */ + cert_hostname = curlx_convert_tchar_to_UTF8( + &cert_hostname_buff[cert_hostname_buff_index]); + if(!cert_hostname) { + result = CURLE_OUT_OF_MEMORY; + } + else { + if(Curl_cert_hostcheck(cert_hostname, strlen(cert_hostname), + conn_hostname, hostlen)) { + infof(data, "schannel: connection hostname (%s) validated " + "against certificate name (%s)", + conn_hostname, cert_hostname); + result = CURLE_OK; + } + else { + size_t cert_hostname_len; + + infof(data, + "schannel: connection hostname (%s) did not match " + "against certificate name (%s)", + conn_hostname, cert_hostname); + + cert_hostname_len = + _tcslen(&cert_hostname_buff[cert_hostname_buff_index]); + + /* Move on to next cert name */ + cert_hostname_buff_index += cert_hostname_len + 1; + + result = CURLE_PEER_FAILED_VERIFICATION; + } + curlx_free(cert_hostname); + } + } + + if(result == CURLE_PEER_FAILED_VERIFICATION) { + failf(data, + "schannel: CertGetNameString() failed to match " + "connection hostname (%s) against server certificate names", + conn_hostname); + } + else if(result != CURLE_OK) + failf(data, "schannel: server certificate name verification failed"); + } + +cleanup: + LocalFree(alt_name_info); + curlx_safefree(cert_hostname_buff); + + if(pCertContextServer) + CertFreeCertificateContext(pCertContextServer); + + return result; +} + +/* Verify the server's certificate and hostname */ +CURLcode Curl_verify_certificate(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + struct ssl_config_data *ssl_config = Curl_ssl_cf_get_config(cf, data); + SECURITY_STATUS sspi_status; + CURLcode result = CURLE_OK; + CERT_CONTEXT *pCertContextServer = NULL; + const CERT_CHAIN_CONTEXT *pChainContext = NULL; + HCERTCHAINENGINE cert_chain_engine = NULL; + HCERTSTORE trust_store = NULL; + HCERTSTORE own_trust_store = NULL; + + DEBUGASSERT(BACKEND); + + sspi_status = + Curl_pSecFn->QueryContextAttributes(&BACKEND->ctxt->ctxt_handle, + SECPKG_ATTR_REMOTE_CERT_CONTEXT, + &pCertContextServer); + + if((sspi_status != SEC_E_OK) || !pCertContextServer) { + char buffer[WINAPI_ERROR_LEN]; + failf(data, "schannel: Failed to read remote certificate context: %s", + Curl_sspi_strerror(sspi_status, buffer, sizeof(buffer))); + result = CURLE_PEER_FAILED_VERIFICATION; + } + + if(result == CURLE_OK && + (conn_config->CAfile || conn_config->ca_info_blob) && + BACKEND->use_manual_cred_validation) { + /* + * Create a chain engine that uses the certificates in the CA file as + * trusted certificates. This is only supported on Windows 7+. + */ + + if(curlx_verify_windows_version(6, 1, 0, PLATFORM_WINNT, + VERSION_LESS_THAN)) { + failf(data, "schannel: this version of Windows is too old to support " + "certificate verification via CA bundle file."); + result = CURLE_SSL_CACERT_BADFILE; + } + else { + /* try cache */ + trust_store = Curl_schannel_get_cached_cert_store(cf, data); + + if(trust_store) { + infof(data, "schannel: reusing certificate store from cache"); + } + else { + /* Open the certificate store */ + trust_store = CertOpenStore(CERT_STORE_PROV_MEMORY, + 0, + (HCRYPTPROV)NULL, + CERT_STORE_CREATE_NEW_FLAG, + NULL); + if(!trust_store) { + char buffer[WINAPI_ERROR_LEN]; + failf(data, "schannel: failed to create certificate store: %s", + curlx_winapi_strerror(GetLastError(), buffer, sizeof(buffer))); + result = CURLE_SSL_CACERT_BADFILE; + } + else { + const struct curl_blob *ca_info_blob = conn_config->ca_info_blob; + own_trust_store = trust_store; + + if(ca_info_blob) { + result = add_certs_data_to_store(trust_store, + (const char *)ca_info_blob->data, + ca_info_blob->len, + "(memory blob)", + data); + } + else { + result = add_certs_file_to_store(trust_store, + conn_config->CAfile, + data); + } + if(result == CURLE_OK) { + if(Curl_schannel_set_cached_cert_store(cf, data, trust_store)) { + own_trust_store = NULL; + } + } + } + } + } + + if(result == CURLE_OK) { + struct cert_chain_engine_config_win8 engine_config; + BOOL create_engine_result; + + memset(&engine_config, 0, sizeof(engine_config)); + engine_config.hExclusiveRoot = trust_store; + + /* Win8/Server2012 allows us to match partial chains */ + if(curlx_verify_windows_version(6, 2, 0, PLATFORM_WINNT, + VERSION_GREATER_THAN_EQUAL) && + !ssl_config->no_partialchain) { + engine_config.cbSize = sizeof(engine_config); + engine_config.dwExclusiveFlags = CERT_CHAIN_EXCLUSIVE_ENABLE_CA_FLAG; + } + else + engine_config.cbSize = sizeof(struct cert_chain_engine_config_win7); + + /* CertCreateCertificateChainEngine checks the expected size of the + * CERT_CHAIN_ENGINE_CONFIG structure and fail if the specified size + * does not match the expected size. When this occurs, it indicates that + * CAINFO is not supported on the version of Windows in use. + */ + create_engine_result = + CertCreateCertificateChainEngine( + (CERT_CHAIN_ENGINE_CONFIG *)&engine_config, &cert_chain_engine); + if(!create_engine_result) { + char buffer[WINAPI_ERROR_LEN]; + failf(data, + "schannel: failed to create certificate chain engine: %s", + curlx_winapi_strerror(GetLastError(), buffer, sizeof(buffer))); + result = CURLE_SSL_CACERT_BADFILE; + } + } + } + + if(result == CURLE_OK) { + CERT_CHAIN_PARA ChainPara; + LPSTR serverAuthOID = CURL_UNCONST(szOID_PKIX_KP_SERVER_AUTH); + + memset(&ChainPara, 0, sizeof(ChainPara)); + ChainPara.cbSize = sizeof(ChainPara); + ChainPara.RequestedUsage.dwType = USAGE_MATCH_TYPE_AND; + ChainPara.RequestedUsage.Usage.cUsageIdentifier = 1; + ChainPara.RequestedUsage.Usage.rgpszUsageIdentifier = &serverAuthOID; + + if(!CertGetCertificateChain(cert_chain_engine, + pCertContextServer, + NULL, + pCertContextServer->hCertStore, + &ChainPara, + (ssl_config->no_revoke ? 0 : + CERT_CHAIN_REVOCATION_CHECK_CHAIN), + NULL, + &pChainContext)) { + char buffer[WINAPI_ERROR_LEN]; + failf(data, "schannel: failed to get the certificate chain: %s", + curlx_winapi_strerror(GetLastError(), buffer, sizeof(buffer))); + pChainContext = NULL; + result = CURLE_PEER_FAILED_VERIFICATION; + } + + if(result == CURLE_OK) { + CERT_SIMPLE_CHAIN *pSimpleChain = pChainContext->rgpChain[0]; + DWORD dwTrustErrorMask = ~(DWORD)(CERT_TRUST_IS_NOT_TIME_NESTED); + dwTrustErrorMask &= pSimpleChain->TrustStatus.dwErrorStatus; + + if(ssl_config->revoke_best_effort) { + /* Ignore errors when root certificates are missing the revocation + * list URL, or when the list could not be downloaded because the + * server is currently unreachable. */ + dwTrustErrorMask &= ~(DWORD)(CERT_TRUST_REVOCATION_STATUS_UNKNOWN | + CERT_TRUST_IS_OFFLINE_REVOCATION); + } + + if(dwTrustErrorMask) { + if(dwTrustErrorMask & CERT_TRUST_IS_REVOKED) + failf(data, "schannel: trust for this certificate or one of " + "the certificates in the certificate chain has been revoked"); + else if(dwTrustErrorMask & CERT_TRUST_IS_PARTIAL_CHAIN) + failf(data, "schannel: the certificate chain is incomplete"); + else if(dwTrustErrorMask & CERT_TRUST_IS_UNTRUSTED_ROOT) + failf(data, "schannel: the certificate or certificate chain is " + "based on an untrusted root"); + else if(dwTrustErrorMask & CERT_TRUST_IS_NOT_TIME_VALID) + failf(data, "schannel: this certificate or one of the certificates " + "in the certificate chain is not time valid"); + else if(dwTrustErrorMask & CERT_TRUST_REVOCATION_STATUS_UNKNOWN) + failf(data, "schannel: the revocation status is unknown"); + else + failf(data, "schannel: error 0x%08lx", dwTrustErrorMask); + result = CURLE_PEER_FAILED_VERIFICATION; + } + } + } + + if(result == CURLE_OK) { + if(conn_config->verifyhost) { + result = Curl_verify_host(cf, data); + } + } + + if(cert_chain_engine) { + CertFreeCertificateChainEngine(cert_chain_engine); + } + + if(own_trust_store) { + CertCloseStore(own_trust_store, 0); + } + + if(pChainContext) + CertFreeCertificateChain(pChainContext); + + if(pCertContextServer) + CertFreeCertificateContext(pCertContextServer); + + return result; +} + +#endif /* USE_SCHANNEL */ diff --git a/3rdparty/curl-8.21.0/lib/vtls/vtls.c b/3rdparty/curl-8.21.0/lib/vtls/vtls.c new file mode 100644 index 0000000000..82ce007b3d --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vtls/vtls.c @@ -0,0 +1,1779 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +/* This file is for implementing all "generic" SSL functions that all libcurl + internals should use. It is then responsible for calling the proper + "backend" function. + + SSL-functions in libcurl should call functions in this source file, and not + to any specific SSL-layer. + + Curl_ssl_ - prefix for generic ones + + Note that this source code uses the functions of the configured SSL + backend via the global Curl_ssl instance. + + "SSL/TLS Strong Encryption: An Introduction" + https://httpd.apache.org/docs/2.0/ssl/ssl_intro.html +*/ + +#include "curl_setup.h" + +#ifdef HAVE_SYS_TYPES_H +#include +#endif + +#include "urldata.h" +#include "cfilters.h" + +#include "vtls/vtls.h" /* generic SSL protos etc */ +#include "vtls/vtls_int.h" +#include "vtls/vtls_scache.h" +#include "vtls/keylog.h" + +#include "vtls/openssl.h" /* OpenSSL versions */ +#include "vtls/gtls.h" /* GnuTLS versions */ +#include "vtls/wolfssl.h" /* wolfSSL versions */ +#include "vtls/schannel.h" /* Schannel SSPI version */ +#include "vtls/mbedtls.h" /* mbedTLS versions */ +#include "vtls/rustls.h" /* Rustls versions */ + +#include "slist.h" +#include "curl_trc.h" +#include "strcase.h" +#include "url.h" +#include "progress.h" +#include "curlx/fopen.h" +#include "curl_sha256.h" +#include "curlx/base64.h" +#include "curlx/inet_pton.h" +#include "connect.h" +#include "select.h" +#include "setopt.h" +#include "curlx/strdup.h" +#include "curlx/strcopy.h" + +#ifdef USE_APPLE_SECTRUST +#include +#endif + +#ifdef USE_SSL +#if !defined(CURL_DISABLE_HTTP) || !defined(CURL_DISABLE_PROXY) +static const struct alpn_spec ALPN_SPEC_H11 = { + { ALPN_HTTP_1_1 }, 1 +}; +static const struct alpn_spec ALPN_SPEC_H10_H11 = { + { ALPN_HTTP_1_0, ALPN_HTTP_1_1 }, 2 +}; +#ifdef USE_HTTP2 +static const struct alpn_spec ALPN_SPEC_H2 = { + { ALPN_H2 }, 1 +}; +static const struct alpn_spec ALPN_SPEC_H2_H11 = { + { ALPN_H2, ALPN_HTTP_1_1 }, 2 +}; +static const struct alpn_spec ALPN_SPEC_H11_H2 = { + { ALPN_HTTP_1_1, ALPN_H2 }, 2 +}; +#endif /* USE_HTTP2 */ + +static const struct alpn_spec *alpn_get_spec(http_majors wanted, + http_majors preferred, + bool only_http_10, + bool use_alpn) +{ + if(!use_alpn) + return NULL; + /* If HTTP/1.0 is the wanted protocol then use ALPN http/1.0 and http/1.1. + This is for compatibility reasons since some HTTP/1.0 servers with old + ALPN implementations understand ALPN http/1.1 but not http/1.0. */ + if(only_http_10 && (wanted & CURL_HTTP_V1x)) + return &ALPN_SPEC_H10_H11; +#ifdef USE_HTTP2 + if(wanted & CURL_HTTP_V2x) { + if(wanted & CURL_HTTP_V1x) + return (preferred == CURL_HTTP_V1x) ? + &ALPN_SPEC_H11_H2 : &ALPN_SPEC_H2_H11; + return &ALPN_SPEC_H2; + } +#else + (void)wanted; + (void)preferred; +#endif + return &ALPN_SPEC_H11; +} +#endif /* !CURL_DISABLE_HTTP || !CURL_DISABLE_PROXY */ +#endif /* USE_SSL */ + +#ifdef USE_SSL +static int multissl_setup(const struct Curl_ssl *backend); +#endif + +curl_sslbackend Curl_ssl_backend(void) +{ +#ifdef USE_SSL + multissl_setup(NULL); + return Curl_ssl->info.id; +#else + return CURLSSLBACKEND_NONE; +#endif +} + +#ifdef USE_SSL + +/* "global" init done? */ +static bool init_ssl = FALSE; + +/** + * Global SSL init + * + * @retval 0 error initializing SSL + * @retval 1 SSL initialized successfully + */ +int Curl_ssl_init(void) +{ + /* make sure this is only done once */ + if(init_ssl) + return 1; + init_ssl = TRUE; /* never again */ + + if(Curl_ssl->init) + return Curl_ssl->init(); + return 1; +} + +static bool ssl_prefs_check(struct Curl_easy *data) +{ + /* check for CURLOPT_SSLVERSION invalid parameter value */ + const unsigned char sslver = data->set.ssl.primary.version; + if(sslver >= CURL_SSLVERSION_LAST) { + failf(data, "Unrecognized parameter value passed via CURLOPT_SSLVERSION"); + return FALSE; + } + + switch(data->set.ssl.primary.version_max) { + case CURL_SSLVERSION_MAX_NONE: + case CURL_SSLVERSION_MAX_DEFAULT: + break; + + default: + if((data->set.ssl.primary.version_max >> 16) < sslver) { + failf(data, "CURL_SSLVERSION_MAX incompatible with CURL_SSLVERSION"); + return FALSE; + } + } + + return TRUE; +} + +static struct ssl_connect_data *cf_ctx_new(struct Curl_easy *data, + const struct alpn_spec *alpn) +{ + struct ssl_connect_data *ctx; + + (void)data; + ctx = curlx_calloc(1, sizeof(*ctx)); + if(!ctx) + return NULL; + + ctx->ssl_impl = Curl_ssl; + ctx->alpn = alpn; + Curl_bufq_init2(&ctx->earlydata, CURL_SSL_EARLY_MAX, 1, BUFQ_OPT_NO_SPARES); + ctx->backend = curlx_calloc(1, ctx->ssl_impl->sizeof_ssl_backend_data); + if(!ctx->backend) { + curlx_free(ctx); + return NULL; + } + return ctx; +} + +static void cf_ctx_free(struct ssl_connect_data *ctx) +{ + if(ctx) { + curlx_safefree(ctx->negotiated.alpn); + Curl_bufq_free(&ctx->earlydata); + curlx_free(ctx->backend); + curlx_free(ctx); + } +} + +CURLcode Curl_ssl_get_channel_binding(struct Curl_easy *data, int sockindex, + struct dynbuf *binding) +{ + if(Curl_ssl->get_channel_binding) + return Curl_ssl->get_channel_binding(data, sockindex, binding); + return CURLE_OK; +} + +void Curl_ssl_close_all(struct Curl_easy *data) +{ + if(Curl_ssl->close_all) + Curl_ssl->close_all(data); +} + +CURLcode Curl_ssl_adjust_pollset(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct easy_pollset *ps) +{ + struct ssl_connect_data *connssl = cf->ctx; + + if(connssl->io_need) { + curl_socket_t sock = Curl_conn_cf_get_socket(cf->next, data); + CURLcode result = CURLE_OK; + if(sock != CURL_SOCKET_BAD) { + if(connssl->io_need & CURL_SSL_IO_NEED_SEND) { + result = Curl_pollset_set_out_only(data, ps, sock); + CURL_TRC_CF(data, cf, "adjust_pollset, POLLOUT fd=%" FMT_SOCKET_T, + sock); + } + else { + result = Curl_pollset_set_in_only(data, ps, sock); + CURL_TRC_CF(data, cf, "adjust_pollset, POLLIN fd=%" FMT_SOCKET_T, + sock); + } + } + return result; + } + return CURLE_OK; +} + +/* Selects an SSL crypto engine + */ +CURLcode Curl_ssl_set_engine(struct Curl_easy *data, const char *engine) +{ + if(Curl_ssl->set_engine) + return Curl_ssl->set_engine(data, engine); + return CURLE_NOT_BUILT_IN; +} + +/* Selects the default SSL crypto engine + */ +CURLcode Curl_ssl_set_engine_default(struct Curl_easy *data) +{ + if(Curl_ssl->set_engine_default) + return Curl_ssl->set_engine_default(data); + return CURLE_NOT_BUILT_IN; +} + +/* Return list of OpenSSL crypto engine names. */ +struct curl_slist *Curl_ssl_engines_list(struct Curl_easy *data) +{ + if(Curl_ssl->engines_list) + return Curl_ssl->engines_list(data); + return NULL; +} + +static size_t multissl_version(char *buffer, size_t size); + +void Curl_ssl_version(char *buffer, size_t size) +{ +#ifdef CURL_WITH_MULTI_SSL + (void)multissl_version(buffer, size); +#else + (void)Curl_ssl->version(buffer, size); +#endif +} + +void Curl_ssl_free_certinfo(struct Curl_easy *data) +{ + struct curl_certinfo *ci = &data->info.certs; + + if(ci->num_of_certs) { + /* free all individual lists used */ + int i; + for(i = 0; i < ci->num_of_certs; i++) { + curl_slist_free_all(ci->certinfo[i]); + ci->certinfo[i] = NULL; + } + + curlx_safefree(ci->certinfo); /* free the actual array too */ + ci->num_of_certs = 0; + } +} + +CURLcode Curl_ssl_init_certinfo(struct Curl_easy *data, int num) +{ + struct curl_certinfo *ci = &data->info.certs; + struct curl_slist **table; + + /* Free any previous certificate information structures */ + Curl_ssl_free_certinfo(data); + + /* Allocate the required certificate information structures */ + table = curlx_calloc((size_t)num, sizeof(struct curl_slist *)); + if(!table) + return CURLE_OUT_OF_MEMORY; + + ci->num_of_certs = num; + ci->certinfo = table; + + return CURLE_OK; +} + +/* + * 'value' is NOT a null-terminated string + */ +CURLcode Curl_ssl_push_certinfo_len(struct Curl_easy *data, + int certnum, + const char *label, + const char *value, + size_t valuelen) +{ + struct curl_certinfo *ci = &data->info.certs; + struct curl_slist *nl; + CURLcode result = CURLE_OK; + struct dynbuf build; + + DEBUGASSERT(certnum < ci->num_of_certs); + + curlx_dyn_init(&build, CURL_X509_STR_MAX); + + if(curlx_dyn_add(&build, label) || + curlx_dyn_addn(&build, ":", 1) || + curlx_dyn_addn(&build, value, valuelen)) + return CURLE_OUT_OF_MEMORY; + + nl = Curl_slist_append_nodup(ci->certinfo[certnum], curlx_dyn_ptr(&build)); + if(!nl) { + curlx_dyn_free(&build); + curl_slist_free_all(ci->certinfo[certnum]); + result = CURLE_OUT_OF_MEMORY; + } + + ci->certinfo[certnum] = nl; + return result; +} + +/* get length bytes of randomness */ +CURLcode Curl_ssl_random(struct Curl_easy *data, + unsigned char *buffer, size_t length) +{ + DEBUGASSERT(length == sizeof(int)); + if(Curl_ssl->random) + return Curl_ssl->random(data, buffer, length); + else + return CURLE_NOT_BUILT_IN; +} + +/* + * Public key pem to der conversion + */ + +static CURLcode pubkey_pem_to_der(const char *pem, + unsigned char **der, size_t *der_len) +{ + const char *begin_pos, *end_pos; + size_t pem_count, pem_len; + CURLcode result; + struct dynbuf pbuf; + + /* if no pem, exit. */ + if(!pem) + return CURLE_BAD_CONTENT_ENCODING; + + curlx_dyn_init(&pbuf, MAX_PINNED_PUBKEY_SIZE); + + begin_pos = strstr(pem, "-----BEGIN PUBLIC KEY-----"); + if(!begin_pos) + return CURLE_BAD_CONTENT_ENCODING; + + pem_count = begin_pos - pem; + /* Invalid if not at beginning AND not directly following \n */ + if(pem_count && '\n' != pem[pem_count - 1]) + return CURLE_BAD_CONTENT_ENCODING; + + /* 26 is length of "-----BEGIN PUBLIC KEY-----" */ + pem_count += 26; + + /* Invalid if not directly following \n */ + end_pos = strstr(pem + pem_count, "\n-----END PUBLIC KEY-----"); + if(!end_pos) + return CURLE_BAD_CONTENT_ENCODING; + + pem_len = end_pos - pem; + + /* + * Here we loop through the pem array one character at a time between the + * correct indices, and place each character that is not '\n' or '\r' + * into the stripped_pem array, which should represent the raw base64 string + */ + while(pem_count < pem_len) { + if('\n' != pem[pem_count] && '\r' != pem[pem_count]) { + result = curlx_dyn_addn(&pbuf, &pem[pem_count], 1); + if(result) + return result; + } + ++pem_count; + } + + if(curlx_dyn_len(&pbuf)) { + result = curlx_base64_decode(curlx_dyn_ptr(&pbuf), der, der_len); + curlx_dyn_free(&pbuf); + } + else + result = CURLE_BAD_CONTENT_ENCODING; + + return result; +} + +/* + * Generic pinned public key check. + */ + +CURLcode Curl_pin_peer_pubkey(struct Curl_easy *data, + const char *pinnedpubkey, + const unsigned char *pubkey, size_t pubkeylen) +{ + CURLcode result = CURLE_SSL_PINNEDPUBKEYNOTMATCH; + + /* if a path was not specified, do not pin */ + if(!pinnedpubkey) + return CURLE_OK; + if(!pubkey || !pubkeylen) + return result; + + /* only do this if pinnedpubkey starts with "sha256//", length 8 */ + if(!strncmp(pinnedpubkey, "sha256//", 8)) { + CURLcode encode; + char *cert_hash = NULL; + const char *pinned_hash, *end_pos; + size_t cert_hash_len = 0, pinned_hash_len; + unsigned char *sha256sumdigest; + + if(!Curl_ssl->sha256sum) { + /* without sha256 support, this cannot match */ + return result; + } + + /* compute sha256sum of public key */ + sha256sumdigest = curlx_malloc(CURL_SHA256_DIGEST_LENGTH); + if(!sha256sumdigest) + return CURLE_OUT_OF_MEMORY; + encode = Curl_ssl->sha256sum(pubkey, pubkeylen, + sha256sumdigest, CURL_SHA256_DIGEST_LENGTH); + + if(!encode) + encode = curlx_base64_encode(sha256sumdigest, + CURL_SHA256_DIGEST_LENGTH, + &cert_hash, &cert_hash_len); + curlx_safefree(sha256sumdigest); + + if(encode) + return encode; + + infof(data, " public key hash: sha256//%s", cert_hash); + + pinned_hash = pinnedpubkey; + while(pinned_hash && + !strncmp(pinned_hash, "sha256//", (sizeof("sha256//") - 1))) { + pinned_hash = pinned_hash + (sizeof("sha256//") - 1); + end_pos = strchr(pinned_hash, ';'); + pinned_hash_len = end_pos ? + (size_t)(end_pos - pinned_hash) : strlen(pinned_hash); + + /* compare base64 sha256 digests */ + if(cert_hash_len == pinned_hash_len && + !memcmp(cert_hash, pinned_hash, cert_hash_len)) { + DEBUGF(infof(data, "public key hash matches pinned value")); + result = CURLE_OK; + break; + } + + DEBUGF(infof(data, "public key hash does not match 'sha256//%.*s'", + (int)pinned_hash_len, pinned_hash)); + /* next one or we are at the end */ + pinned_hash = end_pos ? (end_pos + 1) : NULL; + } + curlx_safefree(cert_hash); + } + else { + long filesize; + size_t size, pem_len; + CURLcode pem_read; + struct dynbuf buf; + unsigned char *pem_ptr = NULL; + size_t left; + FILE *fp = curlx_fopen(pinnedpubkey, "rb"); + if(!fp) + return result; + + curlx_dyn_init(&buf, MAX_PINNED_PUBKEY_SIZE); + + /* Determine the file's size */ + if(fseek(fp, 0, SEEK_END)) + goto end; + filesize = ftell(fp); + if(fseek(fp, 0, SEEK_SET)) + goto end; + if(filesize < 0 || filesize > MAX_PINNED_PUBKEY_SIZE) + goto end; + + /* + * if the size of our certificate is bigger than the file + * size then it cannot match + */ + size = curlx_sotouz((curl_off_t)filesize); + if(pubkeylen > size) + goto end; + + /* + * Read the file into the dynbuf + */ + left = size; + do { + char buffer[1024]; + size_t want = left > sizeof(buffer) ? sizeof(buffer) : left; + if(want != fread(buffer, 1, want, fp)) + goto end; + if(curlx_dyn_addn(&buf, buffer, want)) + goto end; + left -= want; + } while(left); + + /* If the sizes are the same, it cannot be base64 encoded, must be der */ + if(pubkeylen == size) { + if(!memcmp(pubkey, curlx_dyn_ptr(&buf), pubkeylen)) + result = CURLE_OK; + goto end; + } + + /* + * Otherwise we assume it is PEM and try to decode it after placing + * null-terminator + */ + pem_read = pubkey_pem_to_der(curlx_dyn_ptr(&buf), &pem_ptr, &pem_len); + /* if it was not read successfully, exit */ + if(pem_read) + goto end; + + /* + * if the size of our certificate does not match the size of + * the decoded file, they cannot be the same, otherwise compare + */ + if(pubkeylen == pem_len && !memcmp(pubkey, pem_ptr, pubkeylen)) + result = CURLE_OK; +end: + curlx_dyn_free(&buf); + curlx_safefree(pem_ptr); + curlx_fclose(fp); + } + + return result; +} + +/* + * Check whether the SSL backend supports the status_request extension. + */ +bool Curl_ssl_cert_status_request(void) +{ + if(Curl_ssl->cert_status_request) + return Curl_ssl->cert_status_request(); + return FALSE; +} + +static int multissl_init(void) +{ + if(multissl_setup(NULL)) + return 1; + if(Curl_ssl->init) + return Curl_ssl->init(); + return 1; +} + +static CURLcode multissl_random(struct Curl_easy *data, + unsigned char *entropy, size_t length) +{ + if(multissl_setup(NULL)) + return CURLE_FAILED_INIT; + return Curl_ssl->random(data, entropy, length); +} + +static CURLcode multissl_connect(struct Curl_cfilter *cf, + struct Curl_easy *data, bool *done) +{ + if(multissl_setup(NULL)) + return CURLE_FAILED_INIT; + return Curl_ssl->do_connect(cf, data, done); +} + +static CURLcode multissl_adjust_pollset(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct easy_pollset *ps) +{ + if(multissl_setup(NULL)) + return CURLE_OK; + return Curl_ssl->adjust_pollset(cf, data, ps); +} + +static void *multissl_get_internals(struct ssl_connect_data *connssl, + CURLINFO info) +{ + if(multissl_setup(NULL)) + return NULL; + return Curl_ssl->get_internals(connssl, info); +} + +static void multissl_close(struct Curl_cfilter *cf, struct Curl_easy *data) +{ + if(multissl_setup(NULL)) + return; + Curl_ssl->close(cf, data); +} + +static CURLcode multissl_recv_plain(struct Curl_cfilter *cf, + struct Curl_easy *data, + char *buf, size_t len, size_t *pnread) +{ + if(multissl_setup(NULL)) + return CURLE_FAILED_INIT; + return Curl_ssl->recv_plain(cf, data, buf, len, pnread); +} + +static CURLcode multissl_send_plain(struct Curl_cfilter *cf, + struct Curl_easy *data, + const void *mem, size_t len, + size_t *pnwritten) +{ + if(multissl_setup(NULL)) + return CURLE_FAILED_INIT; + return Curl_ssl->send_plain(cf, data, mem, len, pnwritten); +} + +static const struct Curl_ssl Curl_ssl_multi = { + { CURLSSLBACKEND_NONE, "multi" }, /* info */ + 0, /* supports nothing */ + (size_t)-1, /* something insanely large to be on the safe side */ + + multissl_init, /* init */ + NULL, /* cleanup */ + multissl_version, /* version */ + NULL, /* shutdown */ + NULL, /* data_pending */ + multissl_random, /* random */ + NULL, /* cert_status_request */ + multissl_connect, /* connect */ + multissl_adjust_pollset, /* adjust_pollset */ + multissl_get_internals, /* get_internals */ + multissl_close, /* close_one */ + NULL, /* close_all */ + NULL, /* set_engine */ + NULL, /* set_engine_default */ + NULL, /* engines_list */ + NULL, /* sha256sum */ + multissl_recv_plain, /* recv decrypted data */ + multissl_send_plain, /* send data to encrypt */ + NULL, /* get_channel_binding */ +}; + +const struct Curl_ssl *Curl_ssl = +#ifdef CURL_WITH_MULTI_SSL + &Curl_ssl_multi; +#elif defined(USE_WOLFSSL) + &Curl_ssl_wolfssl; +#elif defined(USE_GNUTLS) + &Curl_ssl_gnutls; +#elif defined(USE_MBEDTLS) + &Curl_ssl_mbedtls; +#elif defined(USE_RUSTLS) + &Curl_ssl_rustls; +#elif defined(USE_OPENSSL) + &Curl_ssl_openssl; +#elif defined(USE_SCHANNEL) + &Curl_ssl_schannel; +#else +#error "Missing struct Curl_ssl for selected SSL backend" +#endif + +static const struct Curl_ssl *available_backends[] = { +#ifdef USE_WOLFSSL + &Curl_ssl_wolfssl, +#endif +#ifdef USE_GNUTLS + &Curl_ssl_gnutls, +#endif +#ifdef USE_MBEDTLS + &Curl_ssl_mbedtls, +#endif +#ifdef USE_OPENSSL + &Curl_ssl_openssl, +#endif +#ifdef USE_SCHANNEL + &Curl_ssl_schannel, +#endif +#ifdef USE_RUSTLS + &Curl_ssl_rustls, +#endif + NULL +}; + +/* Global cleanup */ +void Curl_ssl_cleanup(void) +{ + if(init_ssl) { + /* only cleanup if we did a previous init */ + if(Curl_ssl->cleanup) + Curl_ssl->cleanup(); +#ifdef CURL_WITH_MULTI_SSL + Curl_ssl = &Curl_ssl_multi; +#endif + init_ssl = FALSE; + } +} + +static size_t multissl_version(char *buffer, size_t size) +{ + static const struct Curl_ssl *selected; + static char backends[200]; + static size_t backends_len; + const struct Curl_ssl *current; + + current = Curl_ssl == &Curl_ssl_multi ? available_backends[0] : Curl_ssl; + + if(current != selected) { + char *p = backends; + const char *end = backends + sizeof(backends); + int i; + + selected = current; + + backends[0] = '\0'; + + for(i = 0; available_backends[i]; ++i) { + char vb[200]; + bool paren = (selected != available_backends[i]); + + if(available_backends[i]->version(vb, sizeof(vb))) { + p += curl_msnprintf(p, end - p, "%s%s%s%s", (p != backends ? " " : ""), + (paren ? "(" : ""), vb, (paren ? ")" : "")); + } + } + + backends_len = p - backends; + } + + if(size) { + curlx_strcopy(buffer, size, backends, backends_len); + } + return 0; +} + +static int multissl_setup(const struct Curl_ssl *backend) +{ + int i; + char *env; + + if(Curl_ssl != &Curl_ssl_multi) + return 1; + + if(backend) { + Curl_ssl = backend; + return 0; + } + + if(!available_backends[0]) + return 1; + + env = curl_getenv("CURL_SSL_BACKEND"); + if(env) { + for(i = 0; available_backends[i]; i++) { + if(curl_strequal(env, available_backends[i]->info.name)) { + Curl_ssl = available_backends[i]; + curlx_free(env); + return 0; + } + } + } + +#ifdef CURL_DEFAULT_SSL_BACKEND + for(i = 0; available_backends[i]; i++) { + if(curl_strequal(CURL_DEFAULT_SSL_BACKEND, + available_backends[i]->info.name)) { + Curl_ssl = available_backends[i]; + curlx_free(env); + return 0; + } + } +#endif + + /* Fall back to first available backend */ + Curl_ssl = available_backends[0]; + curlx_free(env); + return 0; +} + +/* This function is used to select the SSL backend to use. It is called by + curl_global_sslset (easy.c) which uses the global init lock. */ +CURLsslset Curl_init_sslset_nolock(curl_sslbackend id, const char *name, + const curl_ssl_backend ***avail) +{ + int i; + + if(avail) + *avail = (const curl_ssl_backend **)&available_backends; + + if(Curl_ssl != &Curl_ssl_multi) + return id == Curl_ssl->info.id || + (name && curl_strequal(name, Curl_ssl->info.name)) ? + CURLSSLSET_OK : +#ifdef CURL_WITH_MULTI_SSL + CURLSSLSET_TOO_LATE; +#else + CURLSSLSET_UNKNOWN_BACKEND; +#endif + + for(i = 0; available_backends[i]; i++) { + if(available_backends[i]->info.id == id || + (name && curl_strequal(available_backends[i]->info.name, name))) { + multissl_setup(available_backends[i]); + return CURLSSLSET_OK; + } + } + + return CURLSSLSET_UNKNOWN_BACKEND; +} + +#else /* USE_SSL */ +CURLsslset Curl_init_sslset_nolock(curl_sslbackend id, const char *name, + const curl_ssl_backend ***avail) +{ + (void)id; + (void)name; + (void)avail; + return CURLSSLSET_NO_BACKENDS; +} + +#endif /* !USE_SSL */ + +#ifdef USE_SSL + +void Curl_ssl_peer_cleanup(struct ssl_peer *peer) +{ + Curl_peer_unlink(&peer->origin); + Curl_peer_unlink(&peer->peer); + curlx_safefree(peer->sni); + curlx_safefree(peer->scache_key); + peer->transport = TRNSPRT_NONE; + peer->type = CURL_SSL_PEER_DNS; +} + +static void cf_close(struct Curl_cfilter *cf, struct Curl_easy *data) +{ + struct ssl_connect_data *connssl = cf->ctx; + if(connssl) { + connssl->ssl_impl->close(cf, data); + connssl->state = ssl_connection_none; + connssl->connecting_state = ssl_connect_1; + connssl->prefs_checked = FALSE; + Curl_ssl_peer_cleanup(&connssl->peer); + } + cf->connected = FALSE; +} + +static ssl_peer_type get_peer_type(const char *hostname) +{ + if(hostname && hostname[0]) { +#ifdef USE_IPV6 + struct in6_addr addr; +#else + struct in_addr addr; +#endif + if(curlx_inet_pton(AF_INET, hostname, &addr)) + return CURL_SSL_PEER_IPV4; +#ifdef USE_IPV6 + else if(curlx_inet_pton(AF_INET6, hostname, &addr)) { + return CURL_SSL_PEER_IPV6; + } +#endif + } + return CURL_SSL_PEER_DNS; +} + +CURLcode Curl_ssl_peer_init(struct ssl_peer *ssl_peer, + struct Curl_peer *origin, + struct Curl_peer *peer, + struct ssl_primary_config *sslc, + const char *tls_id, + uint8_t transport) +{ + CURLcode result = CURLE_OUT_OF_MEMORY; + + /* We expect a clean struct, e.g. called only ONCE */ + if(!ssl_peer || !origin) { + DEBUGASSERT(0); + return CURLE_FAILED_INIT; + } + DEBUGASSERT(!ssl_peer->origin); + DEBUGASSERT(!ssl_peer->peer); + DEBUGASSERT(!ssl_peer->sni); + ssl_peer->transport = transport; + + Curl_peer_link(&ssl_peer->origin, origin); + Curl_peer_link(&ssl_peer->peer, peer); + ssl_peer->type = get_peer_type(origin->hostname); + if(ssl_peer->type == CURL_SSL_PEER_DNS) { + /* not an IP address, normalize according to RCC 6066 ch. 3, + * max len of SNI is 2^16-1, no trailing dot */ + size_t len = strlen(origin->hostname); + if(len && (origin->hostname[len - 1] == '.')) + len--; + if(len < USHRT_MAX) { + ssl_peer->sni = curlx_calloc(1, len + 1); + if(!ssl_peer->sni) + goto out; + Curl_strntolower(ssl_peer->sni, origin->hostname, len); + ssl_peer->sni[len] = 0; + } + } + + result = Curl_ssl_peer_key_make(ssl_peer, sslc, tls_id, + &ssl_peer->scache_key); + +out: + if(result) + Curl_ssl_peer_cleanup(ssl_peer); + return result; +} + +static void ssl_cf_destroy(struct Curl_cfilter *cf, struct Curl_easy *data) +{ + struct cf_call_data save; + + CF_DATA_SAVE(save, cf, data); + cf_close(cf, data); + CF_DATA_RESTORE(cf, save); + cf_ctx_free(cf->ctx); + cf->ctx = NULL; +} + +static CURLcode ssl_cf_connect(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct cf_call_data save; + CURLcode result; + + if(cf->connected && (connssl->state != ssl_connection_deferred)) { + *done = TRUE; + return CURLE_OK; + } + + if(!cf->next || !connssl->peer.origin) { + *done = FALSE; + return CURLE_FAILED_INIT; + } + + if(!cf->next->connected) { + result = cf->next->cft->do_connect(cf->next, data, done); + if(result || !*done) + return result; + } + + CF_DATA_SAVE(save, cf, data); + CURL_TRC_CF(data, cf, "cf_connect()"); + DEBUGASSERT(connssl); + + *done = FALSE; + + if(!connssl->prefs_checked) { + if(!ssl_prefs_check(data)) { + result = CURLE_SSL_CONNECT_ERROR; + goto out; + } + connssl->prefs_checked = TRUE; + } + + result = connssl->ssl_impl->do_connect(cf, data, done); + + if(!result && *done) { + cf->connected = TRUE; + if(connssl->state == ssl_connection_complete) { + connssl->handshake_done = *Curl_pgrs_now(data); + } + if(Curl_tls_keylog_enabled()) { + infof(data, "SSLKEYLOGFILE set, all TLS secrets are logged to '%s'", + Curl_tls_keylog_file_name()); +#ifdef LIBRESSL_VERSION_NUMBER + infof(data, "Note LibreSSL only supports SSLKEYLOGFILE for TLS <= 1.2"); +#endif + } + /* Connection can be deferred when sending early data */ + DEBUGASSERT(connssl->state == ssl_connection_complete || + connssl->state == ssl_connection_deferred); + DEBUGASSERT(connssl->state != ssl_connection_deferred || + connssl->earlydata_state > ssl_earlydata_none); + } +out: + CURL_TRC_CF(data, cf, "cf_connect() -> %d, done=%d", (int)result, *done); + CF_DATA_RESTORE(cf, save); + return result; +} + +static CURLcode ssl_cf_set_earlydata(struct Curl_cfilter *cf, + struct Curl_easy *data, + const void *buf, size_t blen) +{ + struct ssl_connect_data *connssl = cf->ctx; + size_t nwritten = 0; + CURLcode result = CURLE_OK; + + DEBUGASSERT(connssl->earlydata_state == ssl_earlydata_await); + DEBUGASSERT(Curl_bufq_is_empty(&connssl->earlydata)); + if(blen) { + if(blen > connssl->earlydata_max) + blen = connssl->earlydata_max; + result = Curl_bufq_write(&connssl->earlydata, buf, blen, &nwritten); + CURL_TRC_CF(data, cf, "ssl_cf_set_earlydata(len=%zu) -> %zu", + blen, nwritten); + if(result) + return result; + } + return CURLE_OK; +} + +static CURLcode ssl_cf_connect_deferred(struct Curl_cfilter *cf, + struct Curl_easy *data, + const void *buf, size_t blen, + bool *done) +{ + struct ssl_connect_data *connssl = cf->ctx; + CURLcode result = CURLE_OK; + + DEBUGASSERT(connssl->state == ssl_connection_deferred); + *done = FALSE; + if(connssl->earlydata_state == ssl_earlydata_await) { + result = ssl_cf_set_earlydata(cf, data, buf, blen); + if(result) + return result; + /* we buffered any early data we would like to send. Actually + * do the connect now which sends it and performs the handshake. */ + connssl->earlydata_state = ssl_earlydata_sending; + connssl->earlydata_skip = Curl_bufq_len(&connssl->earlydata); + } + + result = ssl_cf_connect(cf, data, done); + + if(!result && *done) { + Curl_pgrsTimeWas(data, TIMER_APPCONNECT, connssl->handshake_done); + switch(connssl->earlydata_state) { + case ssl_earlydata_none: + break; + case ssl_earlydata_accepted: + if(!Curl_ssl_cf_is_proxy(cf)) + Curl_pgrsEarlyData(data, (curl_off_t)connssl->earlydata_skip); + infof(data, "Server accepted %zu bytes of TLS early data.", + connssl->earlydata_skip); + break; + case ssl_earlydata_rejected: + if(!Curl_ssl_cf_is_proxy(cf)) + Curl_pgrsEarlyData(data, -(curl_off_t)connssl->earlydata_skip); + infof(data, "Server rejected TLS early data."); + connssl->earlydata_skip = 0; + break; + default: + /* This should not happen. Either we do not use early data or we + * should know if it was accepted or not. */ + DEBUGASSERT(NULL); + break; + } + } + return result; +} + +static bool ssl_cf_data_pending(struct Curl_cfilter *cf, + const struct Curl_easy *data) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct cf_call_data save; + bool pending; + + CF_DATA_SAVE(save, cf, data); + if(connssl->ssl_impl->data_pending && + connssl->ssl_impl->data_pending(cf, data)) + pending = TRUE; + else + pending = cf->next->cft->has_data_pending(cf->next, data); + CF_DATA_RESTORE(cf, save); + return pending; +} + +static CURLcode ssl_cf_send(struct Curl_cfilter *cf, + struct Curl_easy *data, + const uint8_t *buf, size_t blen, + bool eos, size_t *pnwritten) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct cf_call_data save; + CURLcode result = CURLE_OK; + + (void)eos; + *pnwritten = 0; + CF_DATA_SAVE(save, cf, data); + + if(connssl->state == ssl_connection_deferred) { + bool done = FALSE; + result = ssl_cf_connect_deferred(cf, data, buf, blen, &done); + if(result) + goto out; + else if(!done) { + result = CURLE_AGAIN; + goto out; + } + DEBUGASSERT(connssl->state == ssl_connection_complete); + } + + if(connssl->earlydata_skip) { + if(connssl->earlydata_skip >= blen) { + connssl->earlydata_skip -= blen; + result = CURLE_OK; + *pnwritten = blen; + goto out; + } + else { + *pnwritten = connssl->earlydata_skip; + buf = buf + connssl->earlydata_skip; + blen -= connssl->earlydata_skip; + connssl->earlydata_skip = 0; + } + } + + /* OpenSSL and maybe other TLS libs do not like 0-length writes. Skip. */ + if(blen > 0) { + size_t nwritten; + result = connssl->ssl_impl->send_plain(cf, data, buf, blen, &nwritten); + if(!result) + *pnwritten += nwritten; + } + +out: + CF_DATA_RESTORE(cf, save); + return result; +} + +static CURLcode ssl_cf_recv(struct Curl_cfilter *cf, + struct Curl_easy *data, char *buf, size_t len, + size_t *pnread) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct cf_call_data save; + CURLcode result = CURLE_OK; + + CF_DATA_SAVE(save, cf, data); + *pnread = 0; + if(connssl->state == ssl_connection_deferred) { + bool done = FALSE; + result = ssl_cf_connect_deferred(cf, data, NULL, 0, &done); + if(result) + goto out; + else if(!done) { + result = CURLE_AGAIN; + goto out; + } + DEBUGASSERT(connssl->state == ssl_connection_complete); + } + + result = connssl->ssl_impl->recv_plain(cf, data, buf, len, pnread); + +out: + CF_DATA_RESTORE(cf, save); + return result; +} + +static CURLcode ssl_cf_shutdown(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ + struct ssl_connect_data *connssl = cf->ctx; + CURLcode result = CURLE_OK; + + *done = TRUE; + /* If we have done the SSL handshake, shut down the connection cleanly */ + if(cf->connected && (connssl->state == ssl_connection_complete) && + !cf->shutdown && Curl_ssl->shut_down) { + struct cf_call_data save; + + CF_DATA_SAVE(save, cf, data); + result = connssl->ssl_impl->shut_down(cf, data, TRUE, done); + CURL_TRC_CF(data, cf, "cf_shutdown -> %d, done=%d", (int)result, *done); + CF_DATA_RESTORE(cf, save); + cf->shutdown = (result || *done); + } + return result; +} + +static CURLcode ssl_cf_adjust_pollset(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct easy_pollset *ps) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct cf_call_data save; + CURLcode result; + + CF_DATA_SAVE(save, cf, data); + result = connssl->ssl_impl->adjust_pollset(cf, data, ps); + CF_DATA_RESTORE(cf, save); + return result; +} + +static CURLcode ssl_cf_query(struct Curl_cfilter *cf, + struct Curl_easy *data, + int query, int *pres1, void *pres2) +{ + struct ssl_connect_data *connssl = cf->ctx; + + switch(query) { + case CF_QUERY_TIMER_APPCONNECT: { + struct curltime *when = pres2; + if(cf->connected && !Curl_ssl_cf_is_proxy(cf)) + *when = connssl->handshake_done; + return CURLE_OK; + } + case CF_QUERY_SSL_INFO: + case CF_QUERY_SSL_CTX_INFO: + if(!Curl_ssl_cf_is_proxy(cf)) { + struct curl_tlssessioninfo *info = pres2; + struct cf_call_data save; + CF_DATA_SAVE(save, cf, data); + info->backend = Curl_ssl_backend(); + info->internals = connssl->ssl_impl->get_internals( + cf->ctx, (query == CF_QUERY_SSL_INFO) ? + CURLINFO_TLS_SSL_PTR : CURLINFO_TLS_SESSION); + CF_DATA_RESTORE(cf, save); + return CURLE_OK; + } + break; + case CF_QUERY_ALPN_NEGOTIATED: { + const char **palpn = pres2; + DEBUGASSERT(palpn); + *palpn = connssl->negotiated.alpn; + CURL_TRC_CF(data, cf, "query ALPN: returning '%s'", *palpn); + return CURLE_OK; + } + default: + break; + } + return cf->next ? + cf->next->cft->query(cf->next, data, query, pres1, pres2) : + CURLE_UNKNOWN_OPTION; +} + +static CURLcode ssl_cf_cntrl(struct Curl_cfilter *cf, + struct Curl_easy *data, + int event, int arg1, void *arg2) +{ + struct ssl_connect_data *connssl = cf->ctx; + + (void)arg1; + (void)arg2; + (void)data; + switch(event) { + case CF_CTRL_CONN_INFO_UPDATE: + if(connssl->negotiated.alpn && !cf->sockindex) { + if(!strcmp("http/1.1", connssl->negotiated.alpn)) + cf->conn->httpversion_seen = 11; + else if(!strcmp("h2", connssl->negotiated.alpn)) + cf->conn->httpversion_seen = 20; + else if(!strcmp("h3", connssl->negotiated.alpn)) + cf->conn->httpversion_seen = 30; + } + break; + } + return CURLE_OK; +} + +static bool cf_ssl_is_alive(struct Curl_cfilter *cf, struct Curl_easy *data, + bool *input_pending) +{ + /* + * This function tries to determine connection status. + */ + return cf->next ? + cf->next->cft->is_alive(cf->next, data, input_pending) : + FALSE; /* pessimistic in absence of data */ +} + +struct Curl_cftype Curl_cft_ssl = { + "SSL", + CF_TYPE_SSL, + CURL_LOG_LVL_NONE, + ssl_cf_destroy, + ssl_cf_connect, + ssl_cf_shutdown, + ssl_cf_adjust_pollset, + ssl_cf_data_pending, + ssl_cf_send, + ssl_cf_recv, + ssl_cf_cntrl, + cf_ssl_is_alive, + Curl_cf_def_conn_keep_alive, + ssl_cf_query, +}; + +#ifndef CURL_DISABLE_PROXY + +struct Curl_cftype Curl_cft_ssl_proxy = { + "SSL-PROXY", + CF_TYPE_SSL | CF_TYPE_PROXY, + CURL_LOG_LVL_NONE, + ssl_cf_destroy, + ssl_cf_connect, + ssl_cf_shutdown, + ssl_cf_adjust_pollset, + ssl_cf_data_pending, + ssl_cf_send, + ssl_cf_recv, + Curl_cf_def_cntrl, + cf_ssl_is_alive, + Curl_cf_def_conn_keep_alive, + ssl_cf_query, +}; + +#endif /* !CURL_DISABLE_PROXY */ + +static CURLcode cf_ssl_create(struct Curl_cfilter **pcf, + struct Curl_easy *data, + struct connectdata *conn) +{ + struct Curl_cfilter *cf = NULL; + struct ssl_connect_data *ctx; + CURLcode result; + + DEBUGASSERT(data->conn); + +#ifdef CURL_DISABLE_HTTP + (void)conn; + /* We only support ALPN for HTTP so far. */ + DEBUGASSERT(!conn->bits.tls_enable_alpn); + ctx = cf_ctx_new(data, NULL); +#else + ctx = cf_ctx_new(data, alpn_get_spec(data->state.http_neg.wanted, + data->state.http_neg.preferred, + (bool)data->state.http_neg.only_10, + (bool)conn->bits.tls_enable_alpn)); +#endif + if(!ctx) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + result = Curl_cf_create(&cf, &Curl_cft_ssl, ctx); + +out: + if(result) + cf_ctx_free(ctx); + *pcf = result ? NULL : cf; + return result; +} + +static CURLcode cf_ssl_peer_init(struct Curl_cfilter *cf, + struct Curl_peer *origin, + struct Curl_peer *peer, + struct ssl_primary_config *sslc) +{ + struct ssl_connect_data *connssl = cf->ctx; + char tls_id[80]; + connssl->ssl_impl->version(tls_id, sizeof(tls_id) - 1); + return Curl_ssl_peer_init(&connssl->peer, origin, peer, sslc, + tls_id, TRNSPRT_TCP); +} + +CURLcode Curl_ssl_cfilter_add(struct Curl_easy *data, + struct Curl_peer *origin, + struct connectdata *conn, + int sockindex) +{ + struct Curl_cfilter *cf; + struct Curl_peer *peer = (sockindex == SECONDARYSOCKET) ? + conn->via_peer2 : conn->via_peer; + CURLcode result; + + result = cf_ssl_create(&cf, data, conn); + if(!result) + result = cf_ssl_peer_init(cf, origin, peer, &conn->ssl_config); + if(!result) + Curl_conn_cf_add(data, conn, sockindex, cf); + else if(cf) + Curl_conn_cf_discard_chain(&cf, data); + return result; +} + +CURLcode Curl_cf_ssl_insert_after(struct Curl_cfilter *cf_at, + struct Curl_easy *data, + struct Curl_peer *origin, + struct Curl_peer *peer) +{ + struct Curl_cfilter *cf; + CURLcode result; + + result = cf_ssl_create(&cf, data, cf_at->conn); + if(!result) + result = cf_ssl_peer_init(cf, origin, peer, &cf_at->conn->ssl_config); + if(!result) + Curl_conn_cf_insert_after(cf_at, cf); + else if(cf) + Curl_conn_cf_discard_chain(&cf, data); + return result; +} + +#ifndef CURL_DISABLE_PROXY + +static CURLcode cf_ssl_proxy_create(struct Curl_cfilter **pcf, + struct Curl_easy *data, + struct connectdata *conn) +{ + struct Curl_cfilter *cf = NULL; + struct ssl_connect_data *ctx; + CURLcode result; + /* ALPN is default, but if user explicitly disables it, obey */ + bool use_alpn = (bool)data->set.ssl_enable_alpn; + http_majors wanted = CURL_HTTP_V1x; + + (void)conn; +#ifdef USE_HTTP2 + if(conn->http_proxy.proxytype == CURLPROXY_HTTPS2) { + use_alpn = TRUE; + wanted = (CURL_HTTP_V1x | CURL_HTTP_V2x); + } +#endif + + ctx = cf_ctx_new(data, alpn_get_spec(wanted, 0, FALSE, use_alpn)); + if(!ctx) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + result = Curl_cf_create(&cf, &Curl_cft_ssl_proxy, ctx); + +out: + if(result) + cf_ctx_free(ctx); + *pcf = result ? NULL : cf; + return result; +} + +CURLcode Curl_cf_ssl_proxy_insert_after(struct Curl_cfilter *cf_at, + struct Curl_easy *data, + struct Curl_peer *peer) +{ + struct Curl_cfilter *cf; + CURLcode result; + + result = cf_ssl_proxy_create(&cf, data, cf_at->conn); + if(!result) + result = cf_ssl_peer_init(cf, peer, NULL, &cf_at->conn->proxy_ssl_config); + if(!result) + Curl_conn_cf_insert_after(cf_at, cf); + else if(cf) + Curl_conn_cf_discard_chain(&cf, data); + return result; +} + +#endif /* !CURL_DISABLE_PROXY */ + +bool Curl_ssl_supports(struct Curl_easy *data, unsigned int ssl_option) +{ + (void)data; + return (Curl_ssl->supports & ssl_option); +} + +static CURLcode vtls_shutdown_blocking(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool send_shutdown, bool *done) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct cf_call_data save; + CURLcode result = CURLE_OK; + timediff_t timeout_ms; + int what, loop = 10; + + if(cf->shutdown) { + *done = TRUE; + return CURLE_OK; + } + CF_DATA_SAVE(save, cf, data); + + *done = FALSE; + while(!result && !*done && loop--) { + timeout_ms = Curl_shutdown_timeleft(data, cf->conn, cf->sockindex); + + if(timeout_ms < 0) { + /* no need to continue if time is already up */ + failf(data, "SSL shutdown timeout"); + result = CURLE_OPERATION_TIMEDOUT; + goto out; + } + + result = connssl->ssl_impl->shut_down(cf, data, send_shutdown, done); + if(result || *done) + goto out; + + if(connssl->io_need) { + what = Curl_conn_cf_poll(cf, data, timeout_ms); + if(what < 0) { + /* fatal error */ + failf(data, "select/poll on SSL socket, errno: %d", SOCKERRNO); + result = CURLE_RECV_ERROR; + goto out; + } + else if(what == 0) { + /* timeout */ + failf(data, "SSL shutdown timeout"); + result = CURLE_OPERATION_TIMEDOUT; + goto out; + } + /* socket is readable or writable */ + } + } +out: + CF_DATA_RESTORE(cf, save); + cf->shutdown = (result || *done); + return result; +} + +CURLcode Curl_ssl_cfilter_remove(struct Curl_easy *data, + int sockindex, bool send_shutdown) +{ + struct Curl_cfilter *cf, *head; + CURLcode result = CURLE_OK; + + head = data->conn ? data->conn->cfilter[sockindex] : NULL; + for(cf = head; cf; cf = cf->next) { + if(cf->cft == &Curl_cft_ssl) { + bool done; + CURL_TRC_CF(data, cf, "shutdown and remove SSL, start"); + Curl_shutdown_start(data, sockindex, 0); + result = vtls_shutdown_blocking(cf, data, send_shutdown, &done); + Curl_shutdown_clear(data, sockindex); + if(!result && !done) /* blocking failed? */ + result = CURLE_SSL_SHUTDOWN_FAILED; + Curl_conn_cf_discard(&cf, data); + CURL_TRC_CF(data, cf, "shutdown and remove SSL, done -> %d", + (int)result); + break; + } + } + return result; +} + +bool Curl_ssl_cf_is_proxy(struct Curl_cfilter *cf) +{ + return (cf->cft->flags & CF_TYPE_SSL) && (cf->cft->flags & CF_TYPE_PROXY); +} + +struct ssl_config_data *Curl_ssl_cf_get_config(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ +#ifdef CURL_DISABLE_PROXY + (void)cf; + return &data->set.ssl; +#else + return Curl_ssl_cf_is_proxy(cf) ? &data->set.proxy_ssl : &data->set.ssl; +#endif +} + +struct ssl_primary_config *Curl_ssl_cf_get_primary_config( + struct Curl_cfilter *cf) +{ +#ifdef CURL_DISABLE_PROXY + return &cf->conn->ssl_config; +#else + return Curl_ssl_cf_is_proxy(cf) ? + &cf->conn->proxy_ssl_config : &cf->conn->ssl_config; +#endif +} + +CURLcode Curl_alpn_to_proto_buf(struct alpn_proto_buf *buf, + const struct alpn_spec *spec) +{ + size_t i, len; + int off = 0; + unsigned char blen; + + memset(buf, 0, sizeof(*buf)); + for(i = 0; spec && i < spec->count; ++i) { + len = strlen(spec->entries[i]); + if(len >= ALPN_NAME_MAX) + return CURLE_FAILED_INIT; + blen = (unsigned char)len; + if(off + blen + 1 >= (int)sizeof(buf->data)) + return CURLE_FAILED_INIT; + buf->data[off++] = blen; + memcpy(buf->data + off, spec->entries[i], blen); + off += blen; + } + buf->len = off; + return CURLE_OK; +} + +CURLcode Curl_alpn_to_proto_str(struct alpn_proto_buf *buf, + const struct alpn_spec *spec) +{ + size_t i, len; + size_t off = 0; + + memset(buf, 0, sizeof(*buf)); + for(i = 0; spec && i < spec->count; ++i) { + len = strlen(spec->entries[i]); + if(len >= ALPN_NAME_MAX) + return CURLE_FAILED_INIT; + if(off + len + 2 >= sizeof(buf->data)) + return CURLE_FAILED_INIT; + if(off) + buf->data[off++] = ','; + memcpy(buf->data + off, spec->entries[i], len); + off += len; + } + buf->data[off] = '\0'; + buf->len = (int)off; + return CURLE_OK; +} + +bool Curl_alpn_contains_proto(const struct alpn_spec *spec, + const char *proto) +{ + size_t i, plen = proto ? strlen(proto) : 0; + for(i = 0; spec && plen && i < spec->count; ++i) { + size_t slen = strlen(spec->entries[i]); + if((slen == plen) && !memcmp(proto, spec->entries[i], plen)) + return TRUE; + } + return FALSE; +} + +void Curl_alpn_restrict_to(struct alpn_spec *spec, const char *proto) +{ + size_t plen = strlen(proto); + DEBUGASSERT(plen < sizeof(spec->entries[0])); + if(plen < sizeof(spec->entries[0])) { + memcpy(spec->entries[0], proto, plen + 1); + spec->count = 1; + } +} + +void Curl_alpn_copy(struct alpn_spec *dest, const struct alpn_spec *src) +{ + if(src) + memcpy(dest, src, sizeof(*dest)); + else + memset(dest, 0, sizeof(*dest)); +} + +CURLcode Curl_alpn_set_negotiated(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct ssl_connect_data *connssl, + const unsigned char *proto, + size_t proto_len) +{ + CURLcode result = CURLE_OK; + (void)cf; + + if(connssl->negotiated.alpn) { + /* When we ask for a specific ALPN protocol, we need the confirmation + * of it by the server, as we have installed protocol handler and + * connection filter chain for exactly this protocol. */ + if(!proto_len) { + failf(data, "ALPN: asked for '%s' from previous session, " + "but server did not confirm it. Refusing to continue.", + connssl->negotiated.alpn); + result = CURLE_SSL_CONNECT_ERROR; + goto out; + } + else if(!proto) { + DEBUGASSERT(0); /* with length, we need a pointer */ + result = CURLE_SSL_CONNECT_ERROR; + goto out; + } + else if((strlen(connssl->negotiated.alpn) != proto_len) || + memcmp(connssl->negotiated.alpn, proto, proto_len)) { + failf(data, "ALPN: asked for '%s' from previous session, but server " + "selected '%.*s'. Refusing to continue.", + connssl->negotiated.alpn, (int)proto_len, proto); + result = CURLE_SSL_CONNECT_ERROR; + goto out; + } + /* ALPN is exactly what we asked for, done. */ + infof(data, "ALPN: server confirmed to use '%s'", + connssl->negotiated.alpn); + goto out; + } + + if(proto && proto_len) { + if(memchr(proto, '\0', proto_len)) { + failf(data, "ALPN: server selected protocol contains NUL. " + "Refusing to continue."); + result = CURLE_SSL_CONNECT_ERROR; + goto out; + } + connssl->negotiated.alpn = curlx_memdup0((const char *)proto, proto_len); + if(!connssl->negotiated.alpn) + return CURLE_OUT_OF_MEMORY; + } + + if(proto && proto_len) { + if(connssl->state == ssl_connection_deferred) + infof(data, VTLS_INFOF_ALPN_DEFERRED, (int)proto_len, proto); + else + infof(data, VTLS_INFOF_ALPN_ACCEPTED, (int)proto_len, proto); + } + else { + if(connssl->state == ssl_connection_deferred) + infof(data, VTLS_INFOF_NO_ALPN_DEFERRED); + else + infof(data, VTLS_INFOF_NO_ALPN); + } + +out: + return result; +} + +CURLcode Curl_on_session_reuse(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct alpn_spec *alpns, + struct Curl_ssl_session *scs, + bool *do_early_data, bool early_data_allowed) +{ + struct ssl_connect_data *connssl = cf->ctx; + CURLcode result = CURLE_OK; + + *do_early_data = FALSE; + + if(!early_data_allowed) { + CURL_TRC_CF(data, cf, "SSL session does not allow earlydata"); + } + else if(!Curl_alpn_contains_proto(alpns, scs->alpn)) { + CURL_TRC_CF(data, cf, "SSL session has different ALPN, no early data"); + } + else { + infof(data, "SSL session allows %zu bytes of early data, " + "reusing ALPN '%s'", connssl->earlydata_max, scs->alpn); + connssl->earlydata_state = ssl_earlydata_await; + connssl->state = ssl_connection_deferred; + result = Curl_alpn_set_negotiated(cf, data, connssl, + (const unsigned char *)scs->alpn, + scs->alpn ? strlen(scs->alpn) : 0); + *do_early_data = !result; + } + return result; +} + +#endif /* USE_SSL */ diff --git a/3rdparty/curl-8.21.0/lib/vtls/vtls.h b/3rdparty/curl-8.21.0/lib/vtls/vtls.h new file mode 100644 index 0000000000..96cb7d15ed --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vtls/vtls.h @@ -0,0 +1,241 @@ +#ifndef HEADER_CURL_VTLS_H +#define HEADER_CURL_VTLS_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +struct connectdata; +struct ssl_config_data; +struct ssl_primary_config; +struct Curl_cfilter; +struct Curl_easy; +struct dynbuf; + +#define SSLSUPP_CA_PATH (1 << 0) /* supports CAPATH */ +#define SSLSUPP_CERTINFO (1 << 1) /* supports CURLOPT_CERTINFO */ +#define SSLSUPP_PINNEDPUBKEY (1 << 2) /* supports CURLOPT_PINNEDPUBLICKEY */ +#define SSLSUPP_SSL_CTX (1 << 3) /* supports CURLOPT_SSL_CTX */ +#define SSLSUPP_HTTPS_PROXY (1 << 4) /* supports access via HTTPS proxies */ +#define SSLSUPP_TLS13_CIPHERSUITES (1 << 5) /* supports TLS 1.3 ciphersuites */ +#define SSLSUPP_CAINFO_BLOB (1 << 6) +#define SSLSUPP_ECH (1 << 7) +#define SSLSUPP_CA_CACHE (1 << 8) +#define SSLSUPP_CIPHER_LIST (1 << 9) /* supports TLS 1.0-1.2 ciphersuites */ +#define SSLSUPP_SIGNATURE_ALGORITHMS (1 << 10) /* supports TLS sigalgs */ +#define SSLSUPP_ISSUERCERT (1 << 11) /* supports CURLOPT_ISSUERCERT */ +#define SSLSUPP_SSL_EC_CURVES (1 << 12) /* supports CURLOPT_SSL_EC_CURVES */ +#define SSLSUPP_CRLFILE (1 << 13) /* supports CURLOPT_CRLFILE */ +#define SSLSUPP_ISSUERCERT_BLOB (1 << 14) /* CURLOPT_ISSUERCERT_BLOB */ + +#ifdef USE_ECH +/* CURLECH_ values for the tls_ech option */ +#define CURLECH_DISABLE 0 +#define CURLECH_GREASE 1 +#define CURLECH_ENABLE 2 +#define CURLECH_HARD 3 + +#define CURLECH_ENABLED(data) ((data)->set.tls_ech) +#endif /* USE_ECH */ + +#define ALPN_ACCEPTED "ALPN: server accepted " + +#define VTLS_INFOF_NO_ALPN \ + "ALPN: server did not agree on a protocol. Uses default." +#define VTLS_INFOF_ALPN_OFFER_1STR \ + "ALPN: curl offers %s" +#define VTLS_INFOF_ALPN_ACCEPTED \ + ALPN_ACCEPTED "%.*s" + +#define VTLS_INFOF_NO_ALPN_DEFERRED \ + "ALPN: deferred handshake for early data without specific protocol." +#define VTLS_INFOF_ALPN_DEFERRED \ + "ALPN: deferred handshake for early data using '%.*s'." + +/* IETF defined version numbers used in TLS protocol negotiation */ +#define CURL_IETF_PROTO_UNKNOWN 0x0 +#define CURL_IETF_PROTO_SSL3 0x0300 +#define CURL_IETF_PROTO_TLS1 0x0301 +#define CURL_IETF_PROTO_TLS1_1 0x0302 +#define CURL_IETF_PROTO_TLS1_2 0x0303 +#define CURL_IETF_PROTO_TLS1_3 0x0304 +#define CURL_IETF_PROTO_DTLS1 0xFEFF +#define CURL_IETF_PROTO_DTLS1_2 0xFEFD + +typedef enum { + CURL_SSL_PEER_DNS, + CURL_SSL_PEER_IPV4, + CURL_SSL_PEER_IPV6 +} ssl_peer_type; + +struct ssl_peer { + struct Curl_peer *origin; /* the authority we talk to */ + struct Curl_peer *peer; /* the machine we are connected to */ + char *sni; /* SNI version of hostname or NULL if not usable */ + char *scache_key; /* for lookups in session cache */ + ssl_peer_type type; /* type of the peer information */ + uint8_t transport; /* one of TRNSPRT_* defines */ +}; + +CURLsslset Curl_init_sslset_nolock(curl_sslbackend id, const char *name, + const curl_ssl_backend ***avail); + +#define MAX_PINNED_PUBKEY_SIZE (1024 * 1024) /* 1 MiB */ + +curl_sslbackend Curl_ssl_backend(void); + +/** + * Init SSL peer information for filter. Can be called repeatedly. + */ +CURLcode Curl_ssl_peer_init(struct ssl_peer *ssl_peer, + struct Curl_peer *origin, + struct Curl_peer *peer, + struct ssl_primary_config *sslc, + const char *tls_id, + uint8_t transport); +/** + * Free all allocated data and reset peer information. + */ +void Curl_ssl_peer_cleanup(struct ssl_peer *peer); + +#ifdef USE_SSL +int Curl_ssl_init(void); +void Curl_ssl_cleanup(void); +/* tell the SSL stuff to close down all open information regarding + connections (and thus session ID caching etc) */ +void Curl_ssl_close_all(struct Curl_easy *data); +CURLcode Curl_ssl_set_engine(struct Curl_easy *data, const char *engine); +/* Sets engine as default for all SSL operations */ +CURLcode Curl_ssl_set_engine_default(struct Curl_easy *data); +struct curl_slist *Curl_ssl_engines_list(struct Curl_easy *data); + +void Curl_ssl_version(char *buffer, size_t size); + +/* Certificate information list handling. */ +#define CURL_X509_STR_MAX 100000 +#define MAX_ALLOWED_CERT_AMOUNT 100 + +void Curl_ssl_free_certinfo(struct Curl_easy *data); +CURLcode Curl_ssl_init_certinfo(struct Curl_easy *data, int num); +CURLcode Curl_ssl_push_certinfo_len(struct Curl_easy *data, int certnum, + const char *label, const char *value, + size_t valuelen); +CURLcode Curl_ssl_push_certinfo(struct Curl_easy *data, int certnum, + const char *label, const char *value); + +/* Functions to be used by SSL library adaptation functions */ + +/* get N random bytes into the buffer */ +CURLcode Curl_ssl_random(struct Curl_easy *data, + unsigned char *buffer, size_t length); +/* Check pinned public key. */ +CURLcode Curl_pin_peer_pubkey(struct Curl_easy *data, + const char *pinnedpubkey, + const unsigned char *pubkey, size_t pubkeylen); + +bool Curl_ssl_cert_status_request(void); + +/* The maximum size of the SSL channel binding is 85 bytes, as defined in + * RFC 5929, Section 4.1. The 'tls-server-end-point:' prefix is 21 bytes, + * and SHA-512 is the longest supported hash algorithm, with a digest length of + * 64 bytes. + * The maximum size of the channel binding is therefore 21 + 64 = 85 bytes. + */ +#define SSL_CB_MAX_SIZE 85 + +/* Return the tls-server-end-point channel binding, including the + * 'tls-server-end-point:' prefix. + * If successful, the data is written to the dynbuf, and CURLE_OK is returned. + * The dynbuf MUST HAVE a minimum toobig size of SSL_CB_MAX_SIZE. + * If the dynbuf is too small, CURLE_OUT_OF_MEMORY is returned. + * If channel binding is not supported, binding stays empty and CURLE_OK is + * returned. + */ +CURLcode Curl_ssl_get_channel_binding(struct Curl_easy *data, int sockindex, + struct dynbuf *binding); + +#define SSL_SHUTDOWN_TIMEOUT 10000 /* ms */ + +CURLcode Curl_ssl_cfilter_add(struct Curl_easy *data, + struct Curl_peer *origin, + struct connectdata *conn, + int sockindex); + +CURLcode Curl_cf_ssl_insert_after(struct Curl_cfilter *cf_at, + struct Curl_easy *data, + struct Curl_peer *origin, + struct Curl_peer *peer); + +CURLcode Curl_ssl_cfilter_remove(struct Curl_easy *data, + int sockindex, bool send_shutdown); + +#ifndef CURL_DISABLE_PROXY +CURLcode Curl_cf_ssl_proxy_insert_after(struct Curl_cfilter *cf_at, + struct Curl_easy *data, + struct Curl_peer *peer); +#endif /* !CURL_DISABLE_PROXY */ + +/** + * True iff the underlying SSL implementation supports the option. + * Option is one of the defined SSLSUPP_* values. + * `data` maybe NULL for the features of the default implementation. + */ +bool Curl_ssl_supports(struct Curl_easy *data, unsigned int ssl_option); + +/** + * Get the ssl_config_data in `data` that is relevant for cfilter `cf`. + */ +struct ssl_config_data *Curl_ssl_cf_get_config(struct Curl_cfilter *cf, + struct Curl_easy *data); + +/** + * Get the primary config relevant for the filter from its connection. + */ +struct ssl_primary_config *Curl_ssl_cf_get_primary_config( + struct Curl_cfilter *cf); + +extern struct Curl_cftype Curl_cft_ssl; +#ifndef CURL_DISABLE_PROXY +extern struct Curl_cftype Curl_cft_ssl_proxy; +#endif + +#else /* if not USE_SSL */ + +/* When SSL support is not present, define away these function calls */ +#define Curl_ssl_init() 1 +#define Curl_ssl_cleanup() Curl_nop_stmt +#define Curl_ssl_close_all(x) Curl_nop_stmt +#define Curl_ssl_set_engine(x, y) CURLE_NOT_BUILT_IN +#define Curl_ssl_set_engine_default(x) CURLE_NOT_BUILT_IN +#define Curl_ssl_engines_list(x) NULL +#define Curl_ssl_free_certinfo(x) Curl_nop_stmt +#define Curl_ssl_random(x, y, z) ((void)(x), CURLE_NOT_BUILT_IN) +#define Curl_ssl_cert_status_request() FALSE +#define Curl_ssl_supports(a, b) FALSE +#define Curl_ssl_cfilter_add(a, b, c, d) CURLE_NOT_BUILT_IN +#define Curl_ssl_cfilter_remove(a, b, c) CURLE_OK +#define Curl_ssl_cf_get_config(a, b) NULL +#define Curl_ssl_cf_get_primary_config(a) NULL +#endif + +#endif /* HEADER_CURL_VTLS_H */ diff --git a/3rdparty/curl-8.21.0/lib/vtls/vtls_config.c b/3rdparty/curl-8.21.0/lib/vtls/vtls_config.c new file mode 100644 index 0000000000..4a9b69654b --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vtls/vtls_config.c @@ -0,0 +1,423 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +/* This file is for implementing all "generic" SSL functions that all libcurl + internals should use. It is then responsible for calling the proper + "backend" function. + + SSL-functions in libcurl should call functions in this source file, and not + to any specific SSL-layer. + + Curl_ssl_ - prefix for generic ones + + Note that this source code uses the functions of the configured SSL + backend via the global Curl_ssl instance. + + "SSL/TLS Strong Encryption: An Introduction" + https://httpd.apache.org/docs/2.0/ssl/ssl_intro.html +*/ + +#include "curl_setup.h" + +#ifdef HAVE_SYS_TYPES_H +#include +#endif + +#include "urldata.h" +#include "setopt.h" +#include "strcase.h" +#include "vtls/vtls.h" +#include "vtls/vtls_config.h" + + +#define CLONE_STRING(var) \ + do { \ + if(source->var) { \ + dest->var = curlx_strdup(source->var); \ + if(!dest->var) \ + return FALSE; \ + } \ + else \ + dest->var = NULL; \ + } while(0) + +#define CLONE_BLOB(var) \ + do { \ + if(blobdup(&dest->var, source->var)) \ + return FALSE; \ + } while(0) + +static CURLcode blobdup(struct curl_blob **dest, struct curl_blob *src) +{ + DEBUGASSERT(dest); + DEBUGASSERT(!*dest); + if(src) { + /* only if there is data to dupe! */ + struct curl_blob *d; + d = curlx_malloc(sizeof(struct curl_blob) + src->len); + if(!d) + return CURLE_OUT_OF_MEMORY; + d->len = src->len; + /* Always duplicate because the connection may survive longer than the + handle that passed in the blob. */ + d->flags = CURL_BLOB_COPY; + d->data = (void *)((char *)d + sizeof(struct curl_blob)); + memcpy(d->data, src->data, src->len); + *dest = d; + } + return CURLE_OK; +} + +/* returns TRUE if the blobs are identical */ +static bool blobcmp(struct curl_blob *first, struct curl_blob *second) +{ + if(!first && !second) /* both are NULL */ + return TRUE; + if(!first || !second) /* one is NULL */ + return FALSE; + if(first->len != second->len) /* different sizes */ + return FALSE; + return !memcmp(first->data, second->data, first->len); /* same data */ +} + +void Curl_ssl_config_init(struct ssl_primary_config *sslc) +{ + /* + * libcurl 7.10 introduced SSL verification *by default*! This needs to be + * switched off unless wanted. + */ + sslc->verifypeer = TRUE; + sslc->verifyhost = TRUE; + sslc->cache_session = TRUE; /* caching by default */ +} + +void Curl_ssl_config_cleanup(struct ssl_primary_config *sslc) +{ + if(sslc->deep_copy) { + curlx_safefree(sslc->CApath); + curlx_safefree(sslc->CAfile); + curlx_safefree(sslc->issuercert); + curlx_safefree(sslc->clientcert); + curlx_safefree(sslc->cipher_list); + curlx_safefree(sslc->cipher_list13); + curlx_safefree(sslc->pinned_key); + curlx_safefree(sslc->cert_blob); + curlx_safefree(sslc->ca_info_blob); + curlx_safefree(sslc->issuercert_blob); + curlx_safefree(sslc->key_blob); + curlx_safefree(sslc->curves); + curlx_safefree(sslc->signature_algorithms); + curlx_safefree(sslc->CRLfile); + curlx_safefree(sslc->cert_type); + curlx_safefree(sslc->key); + curlx_safefree(sslc->key_type); + curlx_safefree(sslc->key_passwd); +#ifdef USE_TLS_SRP + curlx_safefree(sslc->username); + curlx_safefree(sslc->password); +#endif + sslc->deep_copy = FALSE; + } +} + +static bool match_ssl_primary_config(struct Curl_easy *data, + struct ssl_primary_config *c1, + struct ssl_primary_config *c2) +{ + (void)data; + if((c1->version == c2->version) && + (c1->version_max == c2->version_max) && + (c1->ssl_options == c2->ssl_options) && + (c1->verifypeer == c2->verifypeer) && + (c1->verifyhost == c2->verifyhost) && + (c1->verifystatus == c2->verifystatus) && + blobcmp(c1->cert_blob, c2->cert_blob) && + blobcmp(c1->ca_info_blob, c2->ca_info_blob) && + blobcmp(c1->issuercert_blob, c2->issuercert_blob) && + blobcmp(c1->key_blob, c2->key_blob) && + Curl_safecmp(c1->CApath, c2->CApath) && + Curl_safecmp(c1->CAfile, c2->CAfile) && + Curl_safecmp(c1->issuercert, c2->issuercert) && + Curl_safecmp(c1->clientcert, c2->clientcert) && +#ifdef USE_TLS_SRP + !Curl_timestrcmp(c1->username, c2->username) && + !Curl_timestrcmp(c1->password, c2->password) && +#endif + curl_strequal(c1->cipher_list, c2->cipher_list) && + curl_strequal(c1->cipher_list13, c2->cipher_list13) && + curl_strequal(c1->curves, c2->curves) && + curl_strequal(c1->signature_algorithms, c2->signature_algorithms) && + Curl_safecmp(c1->CRLfile, c2->CRLfile) && + Curl_safecmp(c1->pinned_key, c2->pinned_key) && + curl_strequal(c1->cert_type, c2->cert_type) && + Curl_safecmp(c1->key, c2->key) && + curl_strequal(c1->key_type, c2->key_type) && + !Curl_timestrcmp(c1->key_passwd, c2->key_passwd)) + return TRUE; + + return FALSE; +} + +bool Curl_ssl_conn_config_match(struct Curl_easy *data, + struct connectdata *candidate, + bool proxy) +{ +#ifndef CURL_DISABLE_PROXY + if(proxy) + return match_ssl_primary_config(data, &data->set.proxy_ssl.primary, + &candidate->proxy_ssl_config); +#else + (void)proxy; +#endif + return match_ssl_primary_config(data, &data->set.ssl.primary, + &candidate->ssl_config); +} + +static bool clone_ssl_primary_config(struct ssl_primary_config *source, + struct ssl_primary_config *dest) +{ + DEBUGASSERT(!dest->deep_copy); + dest->deep_copy = TRUE; + dest->version = source->version; + dest->version_max = source->version_max; + dest->verifypeer = source->verifypeer; + dest->verifyhost = source->verifyhost; + dest->verifystatus = source->verifystatus; + dest->cache_session = source->cache_session; + dest->ssl_options = source->ssl_options; + + CLONE_BLOB(cert_blob); + CLONE_BLOB(ca_info_blob); + CLONE_BLOB(issuercert_blob); + CLONE_STRING(CApath); + CLONE_STRING(CAfile); + CLONE_STRING(issuercert); + CLONE_STRING(cipher_list); + CLONE_STRING(cipher_list13); + CLONE_STRING(pinned_key); + CLONE_STRING(curves); + CLONE_STRING(signature_algorithms); + CLONE_STRING(CRLfile); + /* SSL credentials: client certificate, SRP auth */ + CLONE_STRING(clientcert); + CLONE_STRING(cert_type); + CLONE_STRING(key); + CLONE_STRING(key_type); + CLONE_STRING(key_passwd); + CLONE_BLOB(key_blob); +#ifdef USE_TLS_SRP + CLONE_STRING(username); + CLONE_STRING(password); +#endif + + return TRUE; +} + +static void ssl_easy_config_compl_options(struct Curl_peer *origin, + struct Curl_peer *initial_origin, + struct ssl_config_data *sslc) +{ + uint8_t options = sslc->primary.ssl_options; + /* If set via CURLOPT_(PROXY_)SSL_OPTIONS, we definitely use it. + * If not, we switch it on for supported backends if no custom + * CA settings exist. */ + sslc->native_ca_store = !!(options & CURLSSLOPT_NATIVE_CA); + sslc->enable_beast = !!(options & CURLSSLOPT_ALLOW_BEAST); + sslc->no_partialchain = !!(options & CURLSSLOPT_NO_PARTIALCHAIN); + sslc->no_revoke = !!(options & CURLSSLOPT_NO_REVOKE); + sslc->revoke_best_effort = !!(options & CURLSSLOPT_REVOKE_BEST_EFFORT); + sslc->earlydata = !!(options & CURLSSLOPT_EARLYDATA); + + sslc->auto_client_cert = Curl_peer_equal(origin, initial_origin) && + !!(options & CURLSSLOPT_AUTO_CLIENT_CERT); +} + +CURLcode Curl_ssl_easy_config_complete(struct Curl_easy *data, + struct Curl_peer *origin) +{ + struct ssl_config_data *sslc = &data->set.ssl; +#if defined(CURL_CA_PATH) || defined(CURL_CA_BUNDLE) + struct UserDefined *set = &data->set; + CURLcode result; +#endif + + ssl_easy_config_compl_options(origin, data->state.initial_origin, sslc); + + if(Curl_ssl_backend() != CURLSSLBACKEND_SCHANNEL) { +#if defined(USE_APPLE_SECTRUST) || defined(CURL_CA_NATIVE) + if(!sslc->custom_capath && !sslc->custom_cafile && !sslc->custom_cablob) + sslc->native_ca_store = TRUE; +#endif +#ifdef CURL_CA_PATH + if(!sslc->custom_capath && !set->str[STRING_SSL_CAPATH]) { + result = Curl_setstropt(&set->str[STRING_SSL_CAPATH], CURL_CA_PATH); + if(result) + return result; + } +#endif +#ifdef CURL_CA_BUNDLE + if(!sslc->custom_cafile && !set->str[STRING_SSL_CAFILE]) { + result = Curl_setstropt(&set->str[STRING_SSL_CAFILE], CURL_CA_BUNDLE); + if(result) + return result; + } +#endif + } + sslc->primary.CAfile = data->set.str[STRING_SSL_CAFILE]; + sslc->primary.CRLfile = data->set.str[STRING_SSL_CRLFILE]; + sslc->primary.CApath = data->set.str[STRING_SSL_CAPATH]; + sslc->primary.cipher_list = data->set.str[STRING_SSL_CIPHER_LIST]; + sslc->primary.cipher_list13 = data->set.str[STRING_SSL_CIPHER13_LIST]; + sslc->primary.signature_algorithms = + data->set.str[STRING_SSL_SIGNATURE_ALGORITHMS]; + sslc->primary.ca_info_blob = data->set.blobs[BLOB_CAINFO]; + sslc->primary.curves = data->set.str[STRING_SSL_EC_CURVES]; + /* Maybe these should not be used for another origin. But for + * backwards compatibility, keep them in. */ + sslc->primary.issuercert = data->set.str[STRING_SSL_ISSUERCERT]; + sslc->primary.issuercert_blob = data->set.blobs[BLOB_SSL_ISSUERCERT]; + + if(Curl_peer_equal(data->state.initial_origin, origin)) { + sslc->primary.pinned_key = data->set.str[STRING_SSL_PINNEDPUBLICKEY]; + sslc->primary.cert_blob = data->set.blobs[BLOB_CERT]; + sslc->primary.cert_type = data->set.str[STRING_CERT_TYPE]; + sslc->primary.key = data->set.str[STRING_KEY]; + sslc->primary.key_type = data->set.str[STRING_KEY_TYPE]; + sslc->primary.key_passwd = data->set.str[STRING_KEY_PASSWD]; + sslc->primary.clientcert = data->set.str[STRING_CERT]; + sslc->primary.key_blob = data->set.blobs[BLOB_KEY]; +#ifdef USE_TLS_SRP + sslc->primary.username = data->set.str[STRING_TLSAUTH_USERNAME]; + sslc->primary.password = data->set.str[STRING_TLSAUTH_PASSWORD]; +#endif + } + else { + sslc->primary.pinned_key = NULL; + sslc->primary.cert_blob = NULL; + sslc->primary.cert_type = NULL; + sslc->primary.key = NULL; + sslc->primary.key_type = NULL; + sslc->primary.key_passwd = NULL; + sslc->primary.clientcert = NULL; + sslc->primary.key_blob = NULL; +#ifdef USE_TLS_SRP + sslc->primary.username = NULL; + sslc->primary.password = NULL; +#endif + } + +#ifndef CURL_DISABLE_PROXY + sslc = &data->set.proxy_ssl; + /* no initial origin for proxy, it is not changed for redirects */ + ssl_easy_config_compl_options(NULL, NULL, sslc); + + if(Curl_ssl_backend() != CURLSSLBACKEND_SCHANNEL) { +#if defined(USE_APPLE_SECTRUST) || defined(CURL_CA_NATIVE) + if(!sslc->custom_capath && !sslc->custom_cafile && !sslc->custom_cablob) + sslc->native_ca_store = TRUE; +#endif +#ifdef CURL_CA_PATH + if(!sslc->custom_capath && !set->str[STRING_SSL_CAPATH_PROXY]) { + result = Curl_setstropt(&set->str[STRING_SSL_CAPATH_PROXY], + CURL_CA_PATH); + if(result) + return result; + } +#endif +#ifdef CURL_CA_BUNDLE + if(!sslc->custom_cafile && !set->str[STRING_SSL_CAFILE_PROXY]) { + result = Curl_setstropt(&set->str[STRING_SSL_CAFILE_PROXY], + CURL_CA_BUNDLE); + if(result) + return result; + } +#endif + } + sslc->primary.CAfile = data->set.str[STRING_SSL_CAFILE_PROXY]; + sslc->primary.CApath = data->set.str[STRING_SSL_CAPATH_PROXY]; + sslc->primary.cipher_list = data->set.str[STRING_SSL_CIPHER_LIST_PROXY]; + sslc->primary.cipher_list13 = data->set.str[STRING_SSL_CIPHER13_LIST_PROXY]; + sslc->primary.pinned_key = data->set.str[STRING_SSL_PINNEDPUBLICKEY_PROXY]; + sslc->primary.cert_blob = data->set.blobs[BLOB_CERT_PROXY]; + sslc->primary.ca_info_blob = data->set.blobs[BLOB_CAINFO_PROXY]; + sslc->primary.issuercert = data->set.str[STRING_SSL_ISSUERCERT_PROXY]; + sslc->primary.issuercert_blob = data->set.blobs[BLOB_SSL_ISSUERCERT_PROXY]; + sslc->primary.CRLfile = data->set.str[STRING_SSL_CRLFILE_PROXY]; + sslc->primary.cert_type = data->set.str[STRING_CERT_TYPE_PROXY]; + sslc->primary.key = data->set.str[STRING_KEY_PROXY]; + sslc->primary.key_type = data->set.str[STRING_KEY_TYPE_PROXY]; + sslc->primary.key_passwd = data->set.str[STRING_KEY_PASSWD_PROXY]; + sslc->primary.clientcert = data->set.str[STRING_CERT_PROXY]; + sslc->primary.key_blob = data->set.blobs[BLOB_KEY_PROXY]; +#ifdef USE_TLS_SRP + sslc->primary.username = data->set.str[STRING_TLSAUTH_USERNAME_PROXY]; + sslc->primary.password = data->set.str[STRING_TLSAUTH_PASSWORD_PROXY]; +#endif +#endif /* CURL_DISABLE_PROXY */ + + return CURLE_OK; +} + +CURLcode Curl_ssl_conn_config_init(struct Curl_easy *data, + struct connectdata *conn) +{ + /* Clone "primary" SSL configurations from the easy handle to + * the connection. They are used for connection cache matching and + * probably outlive the easy handle */ + if(!clone_ssl_primary_config(&data->set.ssl.primary, &conn->ssl_config)) + return CURLE_OUT_OF_MEMORY; +#ifndef CURL_DISABLE_PROXY + if(!clone_ssl_primary_config(&data->set.proxy_ssl.primary, + &conn->proxy_ssl_config)) + return CURLE_OUT_OF_MEMORY; +#endif + return CURLE_OK; +} + +void Curl_ssl_conn_config_cleanup(struct connectdata *conn) +{ + Curl_ssl_config_cleanup(&conn->ssl_config); +#ifndef CURL_DISABLE_PROXY + Curl_ssl_config_cleanup(&conn->proxy_ssl_config); +#endif +} + +void Curl_ssl_conn_config_update(struct Curl_easy *data, bool for_proxy) +{ + /* May be called on an easy that has no connection yet */ + if(data->conn) { + struct ssl_primary_config *src, *dest; +#ifndef CURL_DISABLE_PROXY + src = for_proxy ? &data->set.proxy_ssl.primary : &data->set.ssl.primary; + dest = for_proxy ? &data->conn->proxy_ssl_config : &data->conn->ssl_config; +#else + (void)for_proxy; + src = &data->set.ssl.primary; + dest = &data->conn->ssl_config; +#endif + dest->verifyhost = src->verifyhost; + dest->verifypeer = src->verifypeer; + dest->verifystatus = src->verifystatus; + } +} diff --git a/3rdparty/curl-8.21.0/lib/vtls/vtls_config.h b/3rdparty/curl-8.21.0/lib/vtls/vtls_config.h new file mode 100644 index 0000000000..44e691dd26 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vtls/vtls_config.h @@ -0,0 +1,125 @@ +#ifndef HEADER_CURL_VTLS_CONFIG_H +#define HEADER_CURL_VTLS_CONFIG_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +struct Curl_easy; +struct connectdata; +struct Curl_peer; + +struct ssl_primary_config { + char *CApath; /* certificate directory (does not work on Windows) */ + char *CAfile; /* certificate to verify peer against */ + char *issuercert; /* optional issuer certificate filename */ + char *clientcert; + char *cipher_list; /* list of ciphers to use */ + char *cipher_list13; /* list of TLS 1.3 cipher suites to use */ + char *signature_algorithms; /* list of signature algorithms to use */ + char *pinned_key; + char *CRLfile; /* CRL to check certificate revocation */ + char *cert_type; /* format for certificate (default: PEM) */ + char *key; /* private key filename */ + char *key_type; /* format for private key (default: PEM) */ + char *key_passwd; /* plain text private key password */ + struct curl_blob *cert_blob; + struct curl_blob *ca_info_blob; + struct curl_blob *issuercert_blob; + struct curl_blob *key_blob; +#ifdef USE_TLS_SRP + char *username; /* TLS username (for, e.g., SRP) */ + char *password; /* TLS password (for, e.g., SRP) */ +#endif + char *curves; /* list of curves to use */ + uint32_t version_max; /* max supported version the client wants to use */ + uint8_t ssl_options; /* the CURLOPT_SSL_OPTIONS bitmask */ + uint8_t version; /* what version the client wants to use */ + BIT(verifypeer); /* set TRUE if this is desired */ + BIT(verifyhost); /* set TRUE if CN/SAN must match hostname */ + BIT(verifystatus); /* set TRUE if certificate status must be checked */ + BIT(cache_session); /* cache session or not */ + BIT(deep_copy); /* members are deep copies, eg. owned here */ +}; + +struct ssl_config_data { + struct ssl_primary_config primary; + long certverifyresult; /* result from the certificate verification */ + curl_ssl_ctx_callback fsslctx; /* function to initialize SSL ctx */ + void *fsslctxp; /* parameter for call back */ + BIT(certinfo); /* gather lots of certificate info */ + BIT(earlydata); /* use TLS 1.3 early data */ + BIT(enable_beast); /* allow this flaw for interoperability's sake */ + BIT(no_revoke); /* disable SSL certificate revocation checks */ + BIT(no_partialchain); /* do not accept partial certificate chains */ + BIT(revoke_best_effort); /* ignore SSL revocation offline/missing revocation + list errors */ + BIT(native_ca_store); /* use the native CA store of operating system */ + BIT(auto_client_cert); /* automatically locate and use a client + certificate for authentication (Schannel) */ + BIT(custom_cafile); /* application has set custom CA file */ + BIT(custom_capath); /* application has set custom CA path */ + BIT(custom_cablob); /* application has set custom CA blob */ +}; + +struct ssl_general_config { + int ca_cache_timeout; /* Certificate store cache timeout (seconds) */ +}; + +void Curl_ssl_config_init(struct ssl_primary_config *sslc); +void Curl_ssl_config_cleanup(struct ssl_primary_config *sslc); + +/** + * Init the `data->set.ssl` and `data->set.proxy_ssl` for + * connection matching use. + */ +CURLcode Curl_ssl_easy_config_complete(struct Curl_easy *data, + struct Curl_peer *origin); + +/** + * Init SSL configs (main + proxy) for a new connection from the easy handle. + */ +CURLcode Curl_ssl_conn_config_init(struct Curl_easy *data, + struct connectdata *conn); + +/** + * Free allocated resources in SSL configs (main + proxy) for + * the given connection. + */ +void Curl_ssl_conn_config_cleanup(struct connectdata *conn); + +/** + * Return TRUE iff SSL configuration from `data` is functionally the + * same as the one on `candidate`. + * @param proxy match the proxy SSL config or the main one + */ +bool Curl_ssl_conn_config_match(struct Curl_easy *data, + struct connectdata *candidate, + bool proxy); + +/* Update certain connection SSL config flags after they have + * been changed on the easy handle. Works for `verifypeer`, + * `verifyhost` and `verifystatus`. */ +void Curl_ssl_conn_config_update(struct Curl_easy *data, bool for_proxy); + +#endif /* HEADER_CURL_VTLS_CONFIG_H */ diff --git a/3rdparty/curl-8.21.0/lib/vtls/vtls_int.h b/3rdparty/curl-8.21.0/lib/vtls/vtls_int.h new file mode 100644 index 0000000000..fa5da6e4d5 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vtls/vtls_int.h @@ -0,0 +1,214 @@ +#ifndef HEADER_CURL_VTLS_INT_H +#define HEADER_CURL_VTLS_INT_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_SSL + +#include "cfilters.h" +#include "select.h" +#include "urldata.h" +#include "vtls/vtls.h" + +struct Curl_ssl; +struct ssl_connect_data; +struct Curl_ssl_session; + +/* see https://www.iana.org/assignments/tls-extensiontype-values/ */ +#define ALPN_HTTP_1_0_LENGTH 8 +#define ALPN_HTTP_1_0 "http/1.0" +#define ALPN_HTTP_1_1_LENGTH 8 +#define ALPN_HTTP_1_1 "http/1.1" +#define ALPN_H2_LENGTH 2 +#define ALPN_H2 "h2" +#define ALPN_H3_LENGTH 2 +#define ALPN_H3 "h3" + +/* conservative sizes on the ALPN entries and count we are handling, + * we can increase these if we ever feel the need or have to accommodate + * ALPN strings from the "outside". */ +#define ALPN_NAME_MAX 10 +#define ALPN_ENTRIES_MAX 3 +#define ALPN_PROTO_BUF_MAX (ALPN_ENTRIES_MAX * (ALPN_NAME_MAX + 1)) + +struct alpn_spec { + char entries[ALPN_ENTRIES_MAX][ALPN_NAME_MAX]; + size_t count; /* number of entries */ +}; + +struct alpn_proto_buf { + unsigned char data[ALPN_PROTO_BUF_MAX]; + int len; +}; + +CURLcode Curl_alpn_to_proto_buf(struct alpn_proto_buf *buf, + const struct alpn_spec *spec); +CURLcode Curl_alpn_to_proto_str(struct alpn_proto_buf *buf, + const struct alpn_spec *spec); +void Curl_alpn_restrict_to(struct alpn_spec *spec, const char *proto); +void Curl_alpn_copy(struct alpn_spec *dest, const struct alpn_spec *src); + +CURLcode Curl_alpn_set_negotiated(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct ssl_connect_data *connssl, + const unsigned char *proto, + size_t proto_len); + +bool Curl_alpn_contains_proto(const struct alpn_spec *spec, const char *proto); + +/* enum for the nonblocking SSL connection state machine */ +typedef enum { + ssl_connect_1, + ssl_connect_2, + ssl_connect_3, + ssl_connect_done +} ssl_connect_state; + +typedef enum { + ssl_connection_none, + ssl_connection_deferred, + ssl_connection_negotiating, + ssl_connection_complete +} ssl_connection_state; + +typedef enum { + ssl_earlydata_none, + ssl_earlydata_await, + ssl_earlydata_sending, + ssl_earlydata_sent, + ssl_earlydata_accepted, + ssl_earlydata_rejected +} ssl_earlydata_state; + +#define CURL_SSL_IO_NEED_NONE 0 +#define CURL_SSL_IO_NEED_RECV (1 << 0) +#define CURL_SSL_IO_NEED_SEND (1 << 1) + +/* Max earlydata payload we want to send */ +#define CURL_SSL_EARLY_MAX (64 * 1024) + +/* Information in each SSL cfilter context: cf->ctx */ +struct ssl_connect_data { + const struct Curl_ssl *ssl_impl; /* TLS backend for this filter */ + struct ssl_peer peer; /* peer the filter talks to */ + const struct alpn_spec *alpn; /* ALPN to use or NULL for none */ + void *backend; /* vtls backend specific props */ + struct cf_call_data call_data; /* data handle used in current call */ + struct curltime handshake_done; /* time when handshake finished */ + struct { + char *alpn; /* ALPN value or NULL */ + } negotiated; + struct bufq earlydata; /* earlydata to be send to peer */ + size_t earlydata_max; /* max earlydata allowed by peer */ + size_t earlydata_skip; /* sending bytes to skip when earlydata + * is accepted by peer */ + ssl_connection_state state; + ssl_connect_state connecting_state; + ssl_earlydata_state earlydata_state; + int io_need; /* TLS signals special SEND/RECV needs */ + BIT(peer_closed); /* peer has closed connection */ + BIT(prefs_checked); /* SSL preferences have been checked */ + BIT(input_pending); /* data for SSL_read() may be available */ +}; + +/* Definitions for SSL Implementations */ + +struct Curl_ssl { + /* + * This *must* be the first entry to allow returning the list of available + * backends in curl_global_sslset(). + */ + curl_ssl_backend info; + unsigned int supports; /* bitfield, see above */ + size_t sizeof_ssl_backend_data; + + int (*init)(void); + void (*cleanup)(void); + + size_t (*version)(char *buffer, size_t size); + CURLcode (*shut_down)(struct Curl_cfilter *cf, struct Curl_easy *data, + bool send_shutdown, bool *done); + + /* data_pending() shall return TRUE when it wants to get called again to + drain internal buffers and deliver data instead of waiting for the socket + to get readable */ + bool (*data_pending)(struct Curl_cfilter *cf, const struct Curl_easy *data); + + /* return 0 if a find random is filled in */ + CURLcode (*random)(struct Curl_easy *data, unsigned char *entropy, + size_t length); + bool (*cert_status_request)(void); + + CURLcode (*do_connect)(struct Curl_cfilter *cf, struct Curl_easy *data, + bool *done); + + /* During handshake/shutdown, adjust the pollset to include the socket + * for POLLOUT or POLLIN as needed. Mandatory. */ + CURLcode (*adjust_pollset)(struct Curl_cfilter *cf, struct Curl_easy *data, + struct easy_pollset *ps); + void *(*get_internals)(struct ssl_connect_data *connssl, CURLINFO info); + void (*close)(struct Curl_cfilter *cf, struct Curl_easy *data); + void (*close_all)(struct Curl_easy *data); + + CURLcode (*set_engine)(struct Curl_easy *data, const char *engine); + CURLcode (*set_engine_default)(struct Curl_easy *data); + struct curl_slist *(*engines_list)(struct Curl_easy *data); + + CURLcode (*sha256sum)(const unsigned char *input, size_t inputlen, + unsigned char *sha256sum, size_t sha256sumlen); + CURLcode (*recv_plain)(struct Curl_cfilter *cf, struct Curl_easy *data, + char *buf, size_t len, size_t *pnread); + CURLcode (*send_plain)(struct Curl_cfilter *cf, struct Curl_easy *data, + const void *mem, size_t len, size_t *pnwritten); + + CURLcode (*get_channel_binding)(struct Curl_easy *data, int sockindex, + struct dynbuf *binding); +}; + +extern const struct Curl_ssl *Curl_ssl; + +CURLcode Curl_ssl_adjust_pollset(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct easy_pollset *ps); + +/** + * Get the SSL filter below the given one or NULL if there is none. + */ +bool Curl_ssl_cf_is_proxy(struct Curl_cfilter *cf); + +CURLcode Curl_on_session_reuse(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct alpn_spec *alpns, + struct Curl_ssl_session *scs, + bool *do_early_data, bool early_data_allowed); +#endif /* USE_SSL */ + +#endif /* HEADER_CURL_VTLS_INT_H */ + +#ifdef USE_SSL +/* Restore the default SSL filter call_data accessor for unity builds. */ +#undef CF_CTX_CALL_DATA +#define CF_CTX_CALL_DATA(cf) ((struct ssl_connect_data *)(cf)->ctx)->call_data +#endif diff --git a/3rdparty/curl-8.21.0/lib/vtls/vtls_scache.c b/3rdparty/curl-8.21.0/lib/vtls/vtls_scache.c new file mode 100644 index 0000000000..98beeac036 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vtls/vtls_scache.c @@ -0,0 +1,1316 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_SSL + +#ifdef HAVE_SYS_TYPES_H +#include +#endif + +#include "urldata.h" +#include "cfilters.h" + +#include "vtls/vtls.h" /* generic SSL protos etc */ +#include "vtls/vtls_int.h" +#include "vtls/vtls_scache.h" +#include "vtls/vtls_spack.h" + +#include "strcase.h" +#include "url.h" +#include "llist.h" +#include "curl_share.h" +#include "curl_trc.h" +#include "curl_sha256.h" +#include "rand.h" + + +/* a peer+tls-config we cache sessions for */ +struct Curl_ssl_scache_peer { + char *ssl_peer_key; /* id for peer + relevant TLS configuration */ + char *clientcert; + char *key_passwd; + char *srp_username; + char *srp_password; + struct Curl_llist sessions; + void *sobj; /* object instance or NULL */ + Curl_ssl_scache_obj_dtor *sobj_free; /* free `sobj` callback */ + unsigned char key_salt[CURL_SHA256_DIGEST_LENGTH]; /* for entry export */ + unsigned char key_hmac[CURL_SHA256_DIGEST_LENGTH]; /* for entry export */ + size_t max_sessions; + long age; /* a number, the higher the more recent */ + BIT(hmac_set); /* if key_salt and key_hmac are present */ + BIT(exportable); /* sessions for this peer can be exported */ +}; + +#define CURL_SCACHE_MAGIC 0x000e1551 + +#define GOOD_SCACHE(x) ((x) && (x)->magic == CURL_SCACHE_MAGIC) + +static CURLcode cf_ssl_peer_key_add_path(struct dynbuf *buf, + const char *name, + const char *path, + bool *is_local) +{ + if(path && path[0]) { + /* We try to add absolute paths, so that the session key can stay valid + * when used in another process with different CWD. When a path does not + * exist, this does not work. Then, we add the path as is. */ +#ifdef _WIN32 + char abspath[_MAX_PATH]; + if(_fullpath(abspath, path, _MAX_PATH)) + return curlx_dyn_addf(buf, ":%s-%s", name, abspath); + *is_local = TRUE; +#elif defined(HAVE_REALPATH) + if(path[0] != '/') { + char *abspath = realpath(path, NULL); + if(abspath) { + CURLcode result = curlx_dyn_addf(buf, ":%s-%s", name, abspath); + /* !checksrc! disable BANNEDFUNC 1 */ + free(abspath); /* allocated by libc, free without memdebug */ + return result; + } + *is_local = TRUE; + } +#endif + return curlx_dyn_addf(buf, ":%s-%s", name, path); + } + return CURLE_OK; +} + +static CURLcode cf_ssl_peer_key_add_hash(struct dynbuf *buf, + const char *name, + struct curl_blob *blob) +{ + CURLcode result = CURLE_OK; + if(blob && blob->len) { + unsigned char hash[CURL_SHA256_DIGEST_LENGTH]; + size_t i; + + result = curlx_dyn_addf(buf, ":%s-", name); + if(result) + goto out; + result = Curl_sha256it(hash, blob->data, blob->len); + if(result) + goto out; + for(i = 0; i < CURL_SHA256_DIGEST_LENGTH; ++i) { + result = curlx_dyn_addf(buf, "%02x", hash[i]); + if(result) + goto out; + } + } +out: + return result; +} + +static CURLcode cf_ssl_peer_key_add_mtls(struct dynbuf *buf, + struct ssl_primary_config *ssl, + bool *is_local) +{ + CURLcode result = CURLE_OK; + if(ssl->clientcert && ssl->clientcert[0]) { + result = cf_ssl_peer_key_add_path(buf, "CCERT", ssl->clientcert, is_local); + if(result) + goto out; + } + if(ssl->key && ssl->key[0]) { + result = cf_ssl_peer_key_add_path(buf, "KEY", ssl->key, is_local); + if(result) + goto out; + } + if(ssl->key_blob) { + result = cf_ssl_peer_key_add_hash(buf, "KEYBlob", ssl->key_blob); + if(result) + goto out; + } + if(ssl->cert_type && ssl->cert_type[0]) { + size_t i; + result = curlx_dyn_add(buf, ":CT-"); + for(i = 0; !result && ssl->cert_type[i]; i++) { + char c = Curl_raw_toupper(ssl->cert_type[i]); + result = curlx_dyn_addn(buf, &c, 1); + } + if(result) + goto out; + } + if(ssl->key_type && ssl->key_type[0]) { + size_t i; + result = curlx_dyn_add(buf, ":KT-"); + for(i = 0; !result && ssl->key_type[i]; i++) { + char c = Curl_raw_toupper(ssl->key_type[i]); + result = curlx_dyn_addn(buf, &c, 1); + } + } +out: + return result; +} + +#define CURL_SSLS_LOCAL_SUFFIX ":L" +#define CURL_SSLS_GLOBAL_SUFFIX ":G" + +static bool cf_ssl_peer_key_is_global(const char *peer_key) +{ + size_t len = peer_key ? strlen(peer_key) : 0; + return (len > 2) && + (peer_key[len - 1] == 'G') && + (peer_key[len - 2] == ':'); +} + +static CURLcode ssl_peer_key_add_transport(struct dynbuf *buf, + uint8_t transport) +{ + switch(transport) { + case TRNSPRT_TCP: + return CURLE_OK; + case TRNSPRT_UDP: + return curlx_dyn_add(buf, ":UDP"); + case TRNSPRT_QUIC: + return curlx_dyn_add(buf, ":QUIC"); + case TRNSPRT_UNIX: + return curlx_dyn_add(buf, ":UNIX"); + default: + return curlx_dyn_addf(buf, ":TRNSPRT-%d", transport); + } +} + +static CURLcode ssl_peer_key_add_vrfy(struct dynbuf *buf, + struct ssl_primary_config *ssl, + const struct ssl_peer *peer) +{ + CURLcode result; + + if(!ssl->verifypeer) { + result = curlx_dyn_add(buf, ":NO-VRFY-PEER"); + if(result) + return result; + } + if(!ssl->verifyhost) { + result = curlx_dyn_add(buf, ":NO-VRFY-HOST"); + if(result) + return result; + } + if(ssl->verifystatus) { + result = curlx_dyn_add(buf, ":VRFY-STATUS"); + if(result) + return result; + } + if((!ssl->verifypeer || !ssl->verifyhost) && + peer->peer && !Curl_peer_equal(peer->origin, peer->peer)) { + result = curlx_dyn_addf(buf, ":CHOST-%s:CPORT-%u", + peer->peer->hostname, + peer->peer->port); + if(result) + return result; + } + return CURLE_OK; +} + +static CURLcode ssl_peer_key_build(struct ssl_primary_config *ssl, + const struct ssl_peer *peer, + const char *tls_id, + char **ppeer_key) +{ + struct dynbuf buf; + size_t key_len; + bool is_local = FALSE; + CURLcode result; + + *ppeer_key = NULL; + curlx_dyn_init(&buf, 10 * 1024); + + result = curlx_dyn_addf(&buf, "%s:%d", + peer->origin->hostname, peer->origin->port); + if(result) + goto out; + result = ssl_peer_key_add_transport(&buf, peer->transport); + if(result) + goto out; + result = ssl_peer_key_add_vrfy(&buf, ssl, peer); + if(result) + goto out; + if(ssl->version || ssl->version_max) { + result = curlx_dyn_addf(&buf, ":TLSVER-%d-%u", ssl->version, + (ssl->version_max >> 16)); + if(result) + goto out; + } + if(ssl->ssl_options) { + result = curlx_dyn_addf(&buf, ":TLSOPT-%x", ssl->ssl_options); + if(result) + goto out; + } + if(ssl->cipher_list) { + result = curlx_dyn_addf(&buf, ":CIPHER-%s", ssl->cipher_list); + if(result) + goto out; + } + if(ssl->cipher_list13) { + result = curlx_dyn_addf(&buf, ":CIPHER13-%s", ssl->cipher_list13); + if(result) + goto out; + } + if(ssl->curves) { + result = curlx_dyn_addf(&buf, ":CURVES-%s", ssl->curves); + if(result) + goto out; + } + if(ssl->signature_algorithms) { + result = curlx_dyn_addf(&buf, ":SIGALGS-%s", + ssl->signature_algorithms); + if(result) + goto out; + } + if(ssl->verifypeer) { + result = cf_ssl_peer_key_add_path(&buf, "CA", ssl->CAfile, &is_local); + if(result) + goto out; + result = cf_ssl_peer_key_add_path(&buf, "CApath", ssl->CApath, &is_local); + if(result) + goto out; + result = cf_ssl_peer_key_add_path(&buf, "CRL", ssl->CRLfile, &is_local); + if(result) + goto out; + result = cf_ssl_peer_key_add_path(&buf, "Issuer", ssl->issuercert, + &is_local); + if(result) + goto out; + if(ssl->ca_info_blob) { + result = cf_ssl_peer_key_add_hash(&buf, "CAInfoBlob", ssl->ca_info_blob); + if(result) + goto out; + } + if(ssl->issuercert_blob) { + result = cf_ssl_peer_key_add_hash(&buf, "IssuerBlob", + ssl->issuercert_blob); + if(result) + goto out; + } + } + if(ssl->cert_blob) { + result = cf_ssl_peer_key_add_hash(&buf, "CertBlob", ssl->cert_blob); + if(result) + goto out; + } + if(ssl->pinned_key && ssl->pinned_key[0]) { + result = curlx_dyn_addf(&buf, ":Pinned-%s", ssl->pinned_key); + if(result) + goto out; + } + + result = cf_ssl_peer_key_add_mtls(&buf, ssl, &is_local); + if(result) + goto out; +#ifdef USE_TLS_SRP + if(ssl->username || ssl->password) { + result = curlx_dyn_add(&buf, ":SRP-AUTH"); + if(result) + goto out; + } +#endif + + if(!tls_id || !tls_id[0]) { + result = CURLE_FAILED_INIT; + goto out; + } + result = curlx_dyn_addf(&buf, ":IMPL-%s", tls_id); + if(result) + goto out; + + result = curlx_dyn_addf(&buf, is_local ? + CURL_SSLS_LOCAL_SUFFIX : CURL_SSLS_GLOBAL_SUFFIX); + if(result) + goto out; + + *ppeer_key = curlx_dyn_take(&buf, &key_len); + /* we added printable char, and dynbuf always null-terminates, no need + * to track length */ + +out: + curlx_dyn_free(&buf); + return result; +} + +CURLcode Curl_ssl_peer_key_make(const struct ssl_peer *peer, + struct ssl_primary_config *sslc, + const char *tls_id, + char **ppeer_key) +{ + return ssl_peer_key_build(sslc, peer, tls_id, ppeer_key); +} + +struct Curl_ssl_scache { + unsigned int magic; + struct Curl_ssl_scache_peer *peers; + size_t peer_count; + int default_lifetime_secs; + long age; + BIT(is_locked); +}; + +static struct Curl_ssl_scache *cf_ssl_scache_get(struct Curl_easy *data) +{ + struct Curl_ssl_scache *scache = NULL; + /* If a share is present, its ssl_scache has preference over the multi */ + if(data->share && data->share->ssl_scache) + scache = data->share->ssl_scache; + else if(data->multi && data->multi->ssl_scache) + scache = data->multi->ssl_scache; + if(scache && !GOOD_SCACHE(scache)) { + failf(data, "transfer would use an invalid scache at %p, denied", + (void *)scache); + DEBUGASSERT(0); + return NULL; + } + return scache; +} + +static void cf_ssl_scache_session_ldestroy(void *udata, void *obj) +{ + struct Curl_ssl_session *s = obj; + (void)udata; + curlx_free(CURL_UNCONST(s->sdata)); + curlx_free(CURL_UNCONST(s->quic_tp)); + curlx_free((void *)s->alpn); + curlx_free(s); +} + +CURLcode Curl_ssl_session_create(void *sdata, size_t sdata_len, + int ietf_tls_id, const char *alpn, + curl_off_t valid_until, size_t earlydata_max, + struct Curl_ssl_session **psession) +{ + return Curl_ssl_session_create2(sdata, sdata_len, ietf_tls_id, alpn, + valid_until, earlydata_max, + NULL, 0, psession); +} + +CURLcode Curl_ssl_session_create2(void *sdata, size_t sdata_len, + int ietf_tls_id, const char *alpn, + curl_off_t valid_until, size_t earlydata_max, + unsigned char *quic_tp, size_t quic_tp_len, + struct Curl_ssl_session **psession) +{ + struct Curl_ssl_session *s; + + if(!sdata || !sdata_len) { + curlx_free(sdata); + return CURLE_BAD_FUNCTION_ARGUMENT; + } + + *psession = NULL; + s = curlx_calloc(1, sizeof(*s)); + if(!s) { + curlx_free(sdata); + curlx_free(quic_tp); + return CURLE_OUT_OF_MEMORY; + } + + s->ietf_tls_id = ietf_tls_id; + s->valid_until = valid_until; + s->earlydata_max = earlydata_max; + s->sdata = sdata; + s->sdata_len = sdata_len; + s->quic_tp = quic_tp; + s->quic_tp_len = quic_tp_len; + if(alpn) { + s->alpn = curlx_strdup(alpn); + if(!s->alpn) { + cf_ssl_scache_session_ldestroy(NULL, s); + return CURLE_OUT_OF_MEMORY; + } + } + *psession = s; + return CURLE_OK; +} + +void Curl_ssl_session_destroy(struct Curl_ssl_session *s) +{ + if(s) { + /* if in the list, the list destructor takes care of it */ + if(Curl_node_llist(&s->list)) + Curl_node_remove(&s->list); + else { + cf_ssl_scache_session_ldestroy(NULL, s); + } + } +} + +static void cf_ssl_scache_clear_peer(struct Curl_ssl_scache_peer *peer) +{ + Curl_llist_destroy(&peer->sessions, NULL); + if(peer->sobj) { + DEBUGASSERT(peer->sobj_free); + if(peer->sobj_free) + peer->sobj_free(peer->sobj); + peer->sobj = NULL; + } + peer->sobj_free = NULL; + curlx_safefree(peer->clientcert); + curlx_safefree(peer->key_passwd); +#ifdef USE_TLS_SRP + curlx_safefree(peer->srp_username); + curlx_safefree(peer->srp_password); +#endif + curlx_safefree(peer->ssl_peer_key); + peer->age = 0; + peer->hmac_set = FALSE; +} + +static void cf_ssl_scache_peer_set_obj(struct Curl_ssl_scache_peer *peer, + void *sobj, + Curl_ssl_scache_obj_dtor *sobj_free) +{ + DEBUGASSERT(peer); + if(peer->sobj_free) { + peer->sobj_free(peer->sobj); + } + peer->sobj = sobj; + peer->sobj_free = sobj_free; +} + +static void cf_ssl_cache_peer_update(struct Curl_ssl_scache_peer *peer) +{ + /* The sessions of this peer are exportable if + * - it has no confidential information + * - its peer key is not yet known, because sessions were + * imported using only the salt+hmac + * - the peer key is global, e.g. carrying no relative paths */ + peer->exportable = (!peer->clientcert && !peer->key_passwd && + !peer->srp_username && !peer->srp_password && + (!peer->ssl_peer_key || + cf_ssl_peer_key_is_global(peer->ssl_peer_key))); +} + +static CURLcode cf_ssl_scache_peer_init(struct Curl_ssl_scache_peer *peer, + const char *ssl_peer_key, + const char *clientcert, + const char *key_passwd, + const char *srp_username, + const char *srp_password, + const unsigned char *salt, + const unsigned char *hmac) +{ + CURLcode result = CURLE_OUT_OF_MEMORY; + + DEBUGASSERT(!peer->ssl_peer_key); + if(ssl_peer_key) { + peer->ssl_peer_key = curlx_strdup(ssl_peer_key); + if(!peer->ssl_peer_key) + goto out; + peer->hmac_set = FALSE; + } + else if(salt && hmac) { + memcpy(peer->key_salt, salt, sizeof(peer->key_salt)); + memcpy(peer->key_hmac, hmac, sizeof(peer->key_hmac)); + peer->hmac_set = TRUE; + } + else { + result = CURLE_BAD_FUNCTION_ARGUMENT; + goto out; + } + if(clientcert) { + peer->clientcert = curlx_strdup(clientcert); + if(!peer->clientcert) + goto out; + } + if(key_passwd) { + peer->key_passwd = curlx_strdup(key_passwd); + if(!peer->key_passwd) + goto out; + } + if(srp_username) { + peer->srp_username = curlx_strdup(srp_username); + if(!peer->srp_username) + goto out; + } + if(srp_password) { + peer->srp_password = curlx_strdup(srp_password); + if(!peer->srp_password) + goto out; + } + + cf_ssl_cache_peer_update(peer); + result = CURLE_OK; +out: + if(result) + cf_ssl_scache_clear_peer(peer); + return result; +} + +static void cf_scache_session_remove(struct Curl_ssl_scache_peer *peer, + struct Curl_ssl_session *s) +{ + (void)peer; + DEBUGASSERT(Curl_node_llist(&s->list) == &peer->sessions); + Curl_ssl_session_destroy(s); +} + +static bool cf_scache_session_expired(struct Curl_ssl_session *s, + curl_off_t now) +{ + return (s->valid_until > 0) && (s->valid_until < now); +} + +static void cf_scache_peer_remove_expired(struct Curl_ssl_scache_peer *peer, + curl_off_t now) +{ + struct Curl_llist_node *n = Curl_llist_head(&peer->sessions); + while(n) { + struct Curl_ssl_session *s = Curl_node_elem(n); + n = Curl_node_next(n); + if(cf_scache_session_expired(s, now)) + cf_scache_session_remove(peer, s); + } +} + +static void cf_scache_peer_remove_non13(struct Curl_ssl_scache_peer *peer) +{ + struct Curl_llist_node *n = Curl_llist_head(&peer->sessions); + while(n) { + struct Curl_ssl_session *s = Curl_node_elem(n); + n = Curl_node_next(n); + if(s->ietf_tls_id != CURL_IETF_PROTO_TLS1_3) + cf_scache_session_remove(peer, s); + } +} + +CURLcode Curl_ssl_scache_create(size_t max_peers, + size_t max_sessions_per_peer, + struct Curl_ssl_scache **pscache) +{ + struct Curl_ssl_scache *scache; + struct Curl_ssl_scache_peer *peers; + size_t i; + + *pscache = NULL; + peers = curlx_calloc(max_peers, sizeof(*peers)); + if(!peers) + return CURLE_OUT_OF_MEMORY; + + scache = curlx_calloc(1, sizeof(*scache)); + if(!scache) { + curlx_free(peers); + return CURLE_OUT_OF_MEMORY; + } + + scache->magic = CURL_SCACHE_MAGIC; + scache->default_lifetime_secs = (24 * 60 * 60); /* 1 day */ + scache->peer_count = max_peers; + scache->peers = peers; + scache->age = 1; + for(i = 0; i < scache->peer_count; ++i) { + scache->peers[i].max_sessions = max_sessions_per_peer; + Curl_llist_init(&scache->peers[i].sessions, + cf_ssl_scache_session_ldestroy); + } + + *pscache = scache; + return CURLE_OK; +} + +void Curl_ssl_scache_destroy(struct Curl_ssl_scache *scache) +{ + if(GOOD_SCACHE(scache)) { + size_t i; + scache->magic = 0; + for(i = 0; i < scache->peer_count; ++i) { + cf_ssl_scache_clear_peer(&scache->peers[i]); + } + curlx_free(scache->peers); + curlx_free(scache); + } +} + +bool Curl_ssl_scache_use(struct Curl_cfilter *cf, struct Curl_easy *data) +{ + if(cf_ssl_scache_get(data)) { + struct ssl_config_data *ssl_config = Curl_ssl_cf_get_config(cf, data); + return ssl_config ? ssl_config->primary.cache_session : FALSE; + } + return FALSE; +} + +/* Lock shared SSL session data */ +void Curl_ssl_scache_lock(struct Curl_easy *data) +{ + struct Curl_ssl_scache *scache = cf_ssl_scache_get(data); + if(scache) { + if(CURL_SHARE_ssl_scache(data)) + Curl_share_lock(data, CURL_LOCK_DATA_SSL_SESSION, + CURL_LOCK_ACCESS_SINGLE); + DEBUGASSERT(!scache->is_locked); + scache->is_locked = TRUE; + } +} + +/* Unlock shared SSL session data */ +void Curl_ssl_scache_unlock(struct Curl_easy *data) +{ + struct Curl_ssl_scache *scache = cf_ssl_scache_get(data); + if(scache) { + DEBUGASSERT(scache->is_locked); + scache->is_locked = FALSE; + if(CURL_SHARE_ssl_scache(data)) + Curl_share_unlock(data, CURL_LOCK_DATA_SSL_SESSION); + } +} + +static bool cf_ssl_scache_match_auth(struct Curl_ssl_scache_peer *peer, + struct ssl_primary_config *conn_config) +{ + if(!conn_config) { + if(peer->clientcert || peer->key_passwd) + return FALSE; +#ifdef USE_TLS_SRP + if(peer->srp_username || peer->srp_password) + return FALSE; +#endif + return TRUE; + } + else if(!Curl_safecmp(peer->clientcert, conn_config->clientcert)) + return FALSE; + if(Curl_timestrcmp(peer->key_passwd, conn_config->key_passwd)) + return FALSE; +#ifdef USE_TLS_SRP + if(Curl_timestrcmp(peer->srp_username, conn_config->username) || + Curl_timestrcmp(peer->srp_password, conn_config->password)) + return FALSE; +#endif + return TRUE; +} + +static CURLcode cf_ssl_find_peer_by_key(struct Curl_easy *data, + struct Curl_ssl_scache *scache, + const char *ssl_peer_key, + struct ssl_primary_config *conn_config, + struct Curl_ssl_scache_peer **ppeer) +{ + size_t i, peer_key_len = 0; + CURLcode result = CURLE_OK; + + *ppeer = NULL; + if(!GOOD_SCACHE(scache)) { + return CURLE_BAD_FUNCTION_ARGUMENT; + } + + CURL_TRC_SSLS(data, "find peer slot for %s among %zu slots", + ssl_peer_key, scache->peer_count); + + /* check for entries with known peer_key */ + for(i = 0; scache && i < scache->peer_count; i++) { + if(scache->peers[i].ssl_peer_key && + curl_strequal(ssl_peer_key, scache->peers[i].ssl_peer_key) && + cf_ssl_scache_match_auth(&scache->peers[i], conn_config)) { + /* yes, we have a cached session for this! */ + *ppeer = &scache->peers[i]; + goto out; + } + } + /* check for entries with HMAC set but no known peer_key */ + for(i = 0; scache && i < scache->peer_count; i++) { + if(!scache->peers[i].ssl_peer_key && + scache->peers[i].hmac_set && + cf_ssl_scache_match_auth(&scache->peers[i], conn_config)) { + /* possible entry with unknown peer_key, check hmac */ + unsigned char my_hmac[CURL_SHA256_DIGEST_LENGTH]; + if(!peer_key_len) /* we are lazy */ + peer_key_len = strlen(ssl_peer_key); + result = Curl_hmacit(&Curl_HMAC_SHA256, + scache->peers[i].key_salt, + sizeof(scache->peers[i].key_salt), + (const unsigned char *)ssl_peer_key, + peer_key_len, + my_hmac); + if(result) + goto out; + if(!memcmp(scache->peers[i].key_hmac, my_hmac, sizeof(my_hmac))) { + /* remember peer_key for future lookups */ + CURL_TRC_SSLS(data, "peer entry %zu key recovered: %s", + i, ssl_peer_key); + scache->peers[i].ssl_peer_key = curlx_strdup(ssl_peer_key); + if(!scache->peers[i].ssl_peer_key) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + cf_ssl_cache_peer_update(&scache->peers[i]); + *ppeer = &scache->peers[i]; + goto out; + } + } + } + CURL_TRC_SSLS(data, "peer not found for %s", ssl_peer_key); +out: + return result; +} + +static struct Curl_ssl_scache_peer *cf_ssl_get_free_peer( + struct Curl_ssl_scache *scache) +{ + struct Curl_ssl_scache_peer *peer = NULL; + size_t i; + + /* find empty or oldest peer */ + for(i = 0; i < scache->peer_count; ++i) { + /* free peer entry? */ + if(!scache->peers[i].ssl_peer_key && !scache->peers[i].hmac_set) { + peer = &scache->peers[i]; + break; + } + /* peer without sessions and obj */ + if(!scache->peers[i].sobj && + !Curl_llist_count(&scache->peers[i].sessions)) { + peer = &scache->peers[i]; + break; + } + /* remember "oldest" peer */ + if(!peer || (scache->peers[i].age < peer->age)) { + peer = &scache->peers[i]; + } + } + DEBUGASSERT(peer); + if(peer) + cf_ssl_scache_clear_peer(peer); + return peer; +} + +static CURLcode cf_ssl_add_peer(struct Curl_easy *data, + struct Curl_ssl_scache *scache, + const char *ssl_peer_key, + struct ssl_primary_config *conn_config, + struct Curl_ssl_scache_peer **ppeer) +{ + struct Curl_ssl_scache_peer *peer = NULL; + CURLcode result = CURLE_OK; + + *ppeer = NULL; + if(ssl_peer_key) { + result = cf_ssl_find_peer_by_key(data, scache, ssl_peer_key, conn_config, + &peer); + if(result || !scache->peer_count) + return result; + } + + if(peer) { + *ppeer = peer; + return CURLE_OK; + } + + peer = cf_ssl_get_free_peer(scache); + if(peer) { + char buffer[64]; + const char *ccert = conn_config ? conn_config->clientcert : NULL; + const char *kpasswd = conn_config ? conn_config->key_passwd : NULL; + const char *username = NULL, *password = NULL; +#ifdef USE_TLS_SRP + username = conn_config ? conn_config->username : NULL; + password = conn_config ? conn_config->password : NULL; +#endif + if(!ccert && conn_config && conn_config->cert_blob) { + /* when using a client cert blob, create a name for it */ + curl_msnprintf(buffer, sizeof(buffer), + "cert-%p", conn_config->cert_blob->data); + ccert = buffer; /* data is strduped by cf_ssl_scache_peer_init */ + } + result = cf_ssl_scache_peer_init(peer, ssl_peer_key, ccert, kpasswd, + username, password, NULL, NULL); + if(result) + goto out; + /* all ready */ + *ppeer = peer; + result = CURLE_OK; + } + +out: + if(result) { + cf_ssl_scache_clear_peer(peer); + } + return result; +} + +static void cf_scache_peer_add_session(struct Curl_ssl_scache_peer *peer, + struct Curl_ssl_session *s, + curl_off_t now) +{ + /* A session not from TLSv1.3 replaces all other. */ + if(s->ietf_tls_id != CURL_IETF_PROTO_TLS1_3) { + Curl_llist_destroy(&peer->sessions, NULL); + Curl_llist_append(&peer->sessions, s, &s->list); + } + else { + /* Expire existing, append, trim from head to obey max_sessions */ + cf_scache_peer_remove_expired(peer, now); + cf_scache_peer_remove_non13(peer); + Curl_llist_append(&peer->sessions, s, &s->list); + while(Curl_llist_count(&peer->sessions) > peer->max_sessions) { + Curl_node_remove(Curl_llist_head(&peer->sessions)); + } + } +} + +static CURLcode cf_scache_add_session(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct Curl_ssl_scache *scache, + const char *ssl_peer_key, + struct Curl_ssl_session *s) +{ + struct Curl_ssl_scache_peer *peer = NULL; + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + CURLcode result = CURLE_OUT_OF_MEMORY; + curl_off_t now = (curl_off_t)time(NULL); + curl_off_t max_lifetime; + + if(!scache || !scache->peer_count) { + Curl_ssl_session_destroy(s); + return CURLE_OK; + } + + if(s->valid_until <= 0) + s->valid_until = now + scache->default_lifetime_secs; + + max_lifetime = (s->ietf_tls_id == CURL_IETF_PROTO_TLS1_3) ? + CURL_SCACHE_MAX_13_LIFETIME_SEC : + CURL_SCACHE_MAX_12_LIFETIME_SEC; + if(s->valid_until > (now + max_lifetime)) + s->valid_until = now + max_lifetime; + + if(cf_scache_session_expired(s, now)) { + CURL_TRC_SSLS(data, "add, session already expired"); + Curl_ssl_session_destroy(s); + return CURLE_OK; + } + + result = cf_ssl_add_peer(data, scache, ssl_peer_key, conn_config, &peer); + if(result || !peer) { + CURL_TRC_SSLS(data, "unable to add scache peer: %d", (int)result); + Curl_ssl_session_destroy(s); + goto out; + } + + cf_scache_peer_add_session(peer, s, now); + +out: + if(result) { + failf(data, "[SCACHE] failed to add session for %s, error=%d", + ssl_peer_key, (int)result); + } + else + CURL_TRC_SSLS(data, "added session for %s [proto=0x%x, " + "valid_secs=%" FMT_OFF_T ", alpn=%s, earlydata=%zu, " + "quic_tp=%s], peer has %zu sessions now", ssl_peer_key, + (unsigned int)s->ietf_tls_id, s->valid_until - now, + s->alpn, s->earlydata_max, s->quic_tp ? "yes" : "no", + peer ? Curl_llist_count(&peer->sessions) : 0); + return result; +} + +CURLcode Curl_ssl_scache_put(struct Curl_cfilter *cf, + struct Curl_easy *data, + const char *ssl_peer_key, + struct Curl_ssl_session *s) +{ + struct Curl_ssl_scache *scache = cf_ssl_scache_get(data); + struct ssl_config_data *ssl_config = Curl_ssl_cf_get_config(cf, data); + CURLcode result; + DEBUGASSERT(ssl_config); + + if(!scache || !ssl_config->primary.cache_session) { + Curl_ssl_session_destroy(s); + return CURLE_OK; + } + + Curl_ssl_scache_lock(data); + result = cf_scache_add_session(cf, data, scache, ssl_peer_key, s); + Curl_ssl_scache_unlock(data); + return result; +} + +void Curl_ssl_scache_return(struct Curl_cfilter *cf, + struct Curl_easy *data, + const char *ssl_peer_key, + struct Curl_ssl_session *s) +{ + /* See RFC 8446 C.4: + * "Clients SHOULD NOT reuse a ticket for multiple connections." */ + if(s && s->ietf_tls_id < 0x304) + (void)Curl_ssl_scache_put(cf, data, ssl_peer_key, s); + else + Curl_ssl_session_destroy(s); +} + +CURLcode Curl_ssl_scache_take(struct Curl_cfilter *cf, + struct Curl_easy *data, + const char *ssl_peer_key, + struct Curl_ssl_session **ps) +{ + struct Curl_ssl_scache *scache = cf_ssl_scache_get(data); + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + struct Curl_ssl_scache_peer *peer = NULL; + struct Curl_llist_node *n; + struct Curl_ssl_session *s = NULL; + CURLcode result; + + *ps = NULL; + if(!scache) + return CURLE_OK; + + Curl_ssl_scache_lock(data); + result = cf_ssl_find_peer_by_key(data, scache, ssl_peer_key, conn_config, + &peer); + if(!result && peer) { + cf_scache_peer_remove_expired(peer, (curl_off_t)time(NULL)); + n = Curl_llist_head(&peer->sessions); + if(n) { + s = Curl_node_take_elem(n); + (scache->age)++; /* increase general age */ + peer->age = scache->age; /* set this as used in this age */ + } + } + if(s) { + *ps = s; + CURL_TRC_SSLS(data, "took session for %s [proto=0x%x, " + "alpn=%s, earlydata=%zu, quic_tp=%s], %zu sessions remain", + ssl_peer_key, (unsigned int)s->ietf_tls_id, s->alpn, + s->earlydata_max, s->quic_tp ? "yes" : "no", + Curl_llist_count(&peer->sessions)); + } + else { + CURL_TRC_SSLS(data, "no cached session for %s", ssl_peer_key); + } + Curl_ssl_scache_unlock(data); + return result; +} + +CURLcode Curl_ssl_scache_add_obj(struct Curl_cfilter *cf, + struct Curl_easy *data, + const char *ssl_peer_key, + void *sobj, + Curl_ssl_scache_obj_dtor *sobj_dtor_cb) +{ + struct Curl_ssl_scache *scache = cf_ssl_scache_get(data); + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + struct Curl_ssl_scache_peer *peer = NULL; + CURLcode result; + + DEBUGASSERT(sobj); + DEBUGASSERT(sobj_dtor_cb); + + if(!scache) { + result = CURLE_BAD_FUNCTION_ARGUMENT; + goto out; + } + + result = cf_ssl_add_peer(data, scache, ssl_peer_key, conn_config, &peer); + if(result || !peer) { + CURL_TRC_SSLS(data, "unable to add scache peer: %d", (int)result); + goto out; + } + + cf_ssl_scache_peer_set_obj(peer, sobj, sobj_dtor_cb); + sobj = NULL; /* peer took ownership */ + +out: + if(sobj && sobj_dtor_cb) + sobj_dtor_cb(sobj); + return result; +} + +void *Curl_ssl_scache_get_obj(struct Curl_cfilter *cf, + struct Curl_easy *data, + const char *ssl_peer_key) +{ + struct Curl_ssl_scache *scache = cf_ssl_scache_get(data); + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + struct Curl_ssl_scache_peer *peer = NULL; + CURLcode result; + void *sobj; + + if(!scache) + return NULL; + + result = cf_ssl_find_peer_by_key(data, scache, ssl_peer_key, conn_config, + &peer); + if(result) + return NULL; + + sobj = peer ? peer->sobj : NULL; + + CURL_TRC_SSLS(data, "%s cached session for '%s'", + sobj ? "Found" : "No", ssl_peer_key); + return sobj; +} + +void Curl_ssl_scache_remove_all(struct Curl_cfilter *cf, + struct Curl_easy *data, + const char *ssl_peer_key) +{ + struct Curl_ssl_scache *scache = cf_ssl_scache_get(data); + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + struct Curl_ssl_scache_peer *peer = NULL; + CURLcode result; + + (void)cf; + if(!scache) + return; + + Curl_ssl_scache_lock(data); + result = cf_ssl_find_peer_by_key(data, scache, ssl_peer_key, conn_config, + &peer); + if(!result && peer) + cf_ssl_scache_clear_peer(peer); + Curl_ssl_scache_unlock(data); +} + +#ifdef USE_SSLS_EXPORT + +#define CURL_SSL_TICKET_MAX (16 * 1024) + +bool Curl_ssl_scache_is_locked(struct Curl_easy *data) +{ + struct Curl_ssl_scache *scache = cf_ssl_scache_get(data); + return scache && scache->is_locked; +} + +static CURLcode cf_ssl_scache_peer_set_hmac(struct Curl_ssl_scache_peer *peer) +{ + CURLcode result; + + DEBUGASSERT(peer); + if(!peer->ssl_peer_key) + return CURLE_BAD_FUNCTION_ARGUMENT; + + result = Curl_rand(NULL, peer->key_salt, sizeof(peer->key_salt)); + if(result) + return result; + + result = Curl_hmacit(&Curl_HMAC_SHA256, + peer->key_salt, sizeof(peer->key_salt), + (const unsigned char *)peer->ssl_peer_key, + strlen(peer->ssl_peer_key), + peer->key_hmac); + if(!result) + peer->hmac_set = TRUE; + return result; +} + +static CURLcode cf_ssl_find_peer_by_hmac(struct Curl_ssl_scache *scache, + const unsigned char *salt, + const unsigned char *hmac, + struct Curl_ssl_scache_peer **ppeer) +{ + size_t i; + CURLcode result = CURLE_OK; + + *ppeer = NULL; + if(!GOOD_SCACHE(scache)) + return CURLE_BAD_FUNCTION_ARGUMENT; + + /* look for an entry that matches salt+hmac exactly or has a known + * ssl_peer_key which salt+hmac's to the same. */ + for(i = 0; scache && i < scache->peer_count; i++) { + struct Curl_ssl_scache_peer *peer = &scache->peers[i]; + if(!cf_ssl_scache_match_auth(peer, NULL)) + continue; + if(scache->peers[i].hmac_set && + !memcmp(peer->key_salt, salt, sizeof(peer->key_salt)) && + !memcmp(peer->key_hmac, hmac, sizeof(peer->key_hmac))) { + /* found exact match, return */ + *ppeer = peer; + goto out; + } + else if(peer->ssl_peer_key) { + unsigned char my_hmac[CURL_SHA256_DIGEST_LENGTH]; + /* compute hmac for the passed salt */ + result = Curl_hmacit(&Curl_HMAC_SHA256, + salt, sizeof(peer->key_salt), + (const unsigned char *)peer->ssl_peer_key, + strlen(peer->ssl_peer_key), + my_hmac); + if(result) + goto out; + if(!memcmp(my_hmac, hmac, sizeof(my_hmac))) { + /* cryptohash match, take over salt+hmac if no set and return */ + if(!peer->hmac_set) { + memcpy(peer->key_salt, salt, sizeof(peer->key_salt)); + memcpy(peer->key_hmac, hmac, sizeof(peer->key_hmac)); + peer->hmac_set = TRUE; + } + *ppeer = peer; + goto out; + } + } + } +out: + return result; +} + +CURLcode Curl_ssl_session_import(struct Curl_easy *data, + const char *ssl_peer_key, + const unsigned char *shmac, size_t shmac_len, + const void *sdata, size_t sdata_len) +{ + struct Curl_ssl_scache *scache = cf_ssl_scache_get(data); + struct Curl_ssl_scache_peer *peer = NULL; + struct Curl_ssl_session *s = NULL; + CURLcode result; + + if(!scache) { + result = CURLE_BAD_FUNCTION_ARGUMENT; + goto out; + } + if(!ssl_peer_key && (!shmac || !shmac_len)) { + result = CURLE_BAD_FUNCTION_ARGUMENT; + goto out; + } + + result = Curl_ssl_session_unpack(data, sdata, sdata_len, &s); + if(result) + goto out; + + Curl_ssl_scache_lock(data); + + if(ssl_peer_key) { + result = cf_ssl_add_peer(data, scache, ssl_peer_key, NULL, &peer); + if(result) + goto out; + } + else if(shmac_len != (sizeof(peer->key_salt) + sizeof(peer->key_hmac))) { + /* Either salt+hmac was garbled by caller or is from a curl version + * that does things differently */ + result = CURLE_BAD_FUNCTION_ARGUMENT; + goto out; + } + else { + const unsigned char *salt = shmac; + const unsigned char *hmac = shmac + sizeof(peer->key_salt); + + result = cf_ssl_find_peer_by_hmac(scache, salt, hmac, &peer); + if(result) + goto out; + if(!peer) { + peer = cf_ssl_get_free_peer(scache); + if(peer) { + result = cf_ssl_scache_peer_init(peer, ssl_peer_key, NULL, NULL, + NULL, NULL, salt, hmac); + if(result) + goto out; + } + } + } + + if(peer) { + cf_scache_peer_add_session(peer, s, time(NULL)); + s = NULL; /* peer is now owner */ + CURL_TRC_SSLS(data, "successfully imported ticket for peer %s, now " + "with %zu tickets", + peer->ssl_peer_key ? peer->ssl_peer_key : "without key", + Curl_llist_count(&peer->sessions)); + } + +out: + if(scache && scache->is_locked) + Curl_ssl_scache_unlock(data); + Curl_ssl_session_destroy(s); + return result; +} + +CURLcode Curl_ssl_session_export(struct Curl_easy *data, + curl_ssls_export_cb *export_fn, + void *userptr) +{ + struct Curl_ssl_scache *scache = cf_ssl_scache_get(data); + struct Curl_ssl_scache_peer *peer; + struct dynbuf sbuf, hbuf; + struct Curl_llist_node *n; + size_t i; + curl_off_t now = time(NULL); + CURLcode result = CURLE_OK; +#ifdef CURLVERBOSE + size_t npeers = 0, ntickets = 0; +#endif + + if(!export_fn) + return CURLE_BAD_FUNCTION_ARGUMENT; + + Curl_ssl_scache_lock(data); + + curlx_dyn_init(&hbuf, (CURL_SHA256_DIGEST_LENGTH * 2) + 1); + curlx_dyn_init(&sbuf, CURL_SSL_TICKET_MAX); + + for(i = 0; scache && i < scache->peer_count; i++) { + peer = &scache->peers[i]; + if(!peer->ssl_peer_key && !peer->hmac_set) + continue; /* skip free entry */ + if(!peer->exportable) + continue; + + curlx_dyn_reset(&hbuf); + cf_scache_peer_remove_expired(peer, now); + n = Curl_llist_head(&peer->sessions); + if(n) + VERBOSE(++npeers); + while(n) { + struct Curl_ssl_session *s = Curl_node_elem(n); + if(!peer->hmac_set) { + result = cf_ssl_scache_peer_set_hmac(peer); + if(result) + goto out; + } + if(!curlx_dyn_len(&hbuf)) { + result = curlx_dyn_addn(&hbuf, peer->key_salt, sizeof(peer->key_salt)); + if(result) + goto out; + result = curlx_dyn_addn(&hbuf, peer->key_hmac, sizeof(peer->key_hmac)); + if(result) + goto out; + } + curlx_dyn_reset(&sbuf); + result = Curl_ssl_session_pack(data, s, &sbuf); + if(result) + goto out; + + result = export_fn(data, userptr, peer->ssl_peer_key, + curlx_dyn_uptr(&hbuf), curlx_dyn_len(&hbuf), + curlx_dyn_uptr(&sbuf), curlx_dyn_len(&sbuf), + s->valid_until, s->ietf_tls_id, + s->alpn, s->earlydata_max); + if(result) + goto out; + VERBOSE(++ntickets); + n = Curl_node_next(n); + } + } + result = CURLE_OK; + CURL_TRC_SSLS(data, "exported %zu session tickets for %zu peers", + ntickets, npeers); + +out: + Curl_ssl_scache_unlock(data); + curlx_dyn_free(&hbuf); + curlx_dyn_free(&sbuf); + return result; +} + +#endif /* USE_SSLS_EXPORT */ + +#endif /* USE_SSL */ diff --git a/3rdparty/curl-8.21.0/lib/vtls/vtls_scache.h b/3rdparty/curl-8.21.0/lib/vtls/vtls_scache.h new file mode 100644 index 0000000000..effb1d8f96 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vtls/vtls_scache.h @@ -0,0 +1,216 @@ +#ifndef HEADER_CURL_VTLS_SCACHE_H +#define HEADER_CURL_VTLS_SCACHE_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_SSL + +#include "cfilters.h" +#include "urldata.h" + +struct Curl_cfilter; +struct Curl_easy; +struct Curl_ssl_scache; +struct Curl_ssl_session; +struct ssl_peer; + +/* RFC 8446 (TLSv1.3) restrict lifetime to one week max, for + * other, less secure versions, we restrict it to a day */ +#define CURL_SCACHE_MAX_13_LIFETIME_SEC (60 * 60 * 24 * 7) +#define CURL_SCACHE_MAX_12_LIFETIME_SEC (60 * 60 * 24) + +/* Create a session cache for up to max_peers endpoints with a total + * of up to max_sessions SSL sessions per peer */ +CURLcode Curl_ssl_scache_create(size_t max_peers, + size_t max_sessions_per_peer, + struct Curl_ssl_scache **pscache); + +void Curl_ssl_scache_destroy(struct Curl_ssl_scache *scache); + +/* Create a key from peer and TLS configuration information that is + * unique for how the connection filter wants to establish a TLS + * connection to the peer. + * If the filter is a TLS proxy filter, it uses the proxy relevant + * information. + * @param peer the peer the filter wants to talk to + * @param sslc the relevant ssl configuration + * @param tls_id identifier of TLS implementation for sessions. Should + * include full version if session data from other versions + * is to be avoided. + * @param ppeer_key on successful return, the key generated + */ +CURLcode Curl_ssl_peer_key_make(const struct ssl_peer *peer, + struct ssl_primary_config *sslc, + const char *tls_id, + char **ppeer_key); + +/* Return if there is a session cache shall be used. + * An SSL session might not be configured or not available for + * "connect-only" transfers. + */ +bool Curl_ssl_scache_use(struct Curl_cfilter *cf, struct Curl_easy *data); + +/* Lock session cache mutex. + * Call this before calling other Curl_ssl_*session* functions + * Caller should unlock this mutex as soon as possible, as it may block + * other SSL connection from making progress. + * The purpose of explicitly locking SSL session cache data is to allow + * individual SSL engines to manage session lifetime in their specific way. + */ +void Curl_ssl_scache_lock(struct Curl_easy *data); + +/* Unlock session cache mutex */ +void Curl_ssl_scache_unlock(struct Curl_easy *data); + +/* Get TLS session object from the cache for the ssl_peer_key. + * scache mutex must be locked (see Curl_ssl_scache_lock). + * Caller must make sure that the ownership of returned session object + * is properly taken (e.g. its refcount is incremented + * under scache mutex). + * @param cf the connection filter wanting to use it + * @param data the transfer involved + * @param ssl_peer_key the key for lookup + * @retval sobj the object for the peer key or NULL + */ +void *Curl_ssl_scache_get_obj(struct Curl_cfilter *cf, + struct Curl_easy *data, + const char *ssl_peer_key); + +typedef void Curl_ssl_scache_obj_dtor(void *sobj); + +/* Add a TLS session related object to the cache. + * Replaces an existing object with the same peer_key. + * scache mutex must be locked (see Curl_ssl_scache_lock). + * Call takes ownership of `sobj`, using `sobj_dtor_cb` + * to deallocate it. Is called in all outcomes, either right away or + * later when the session cache is cleaned up. + * Caller must ensure that it has properly shared ownership of `sobj` + * with cache (e.g. incrementing refcount on success) + * @param cf the connection filter wanting to use it + * @param data the transfer involved + * @param ssl_peer_key the key for lookup + * @param sobj the TLS session object + * @param sobj_free_cb callback to free the session object + */ +CURLcode Curl_ssl_scache_add_obj(struct Curl_cfilter *cf, + struct Curl_easy *data, + const char *ssl_peer_key, + void *sobj, + Curl_ssl_scache_obj_dtor *sobj_dtor_cb); + +/* All about an SSL session ticket */ +struct Curl_ssl_session { + const void *sdata; /* session ticket data, plain bytes */ + size_t sdata_len; /* number of bytes in sdata */ + curl_off_t valid_until; /* seconds since EPOCH until ticket expires */ + int ietf_tls_id; /* TLS protocol identifier negotiated */ + char *alpn; /* APLN TLS negotiated protocol string */ + size_t earlydata_max; /* max 0-RTT data supported by peer */ + const unsigned char *quic_tp; /* Optional QUIC transport param bytes */ + size_t quic_tp_len; /* number of bytes in quic_tp */ + struct Curl_llist_node list; /* internal storage handling */ +}; + +/* Create a `session` instance. Does NOT need locking. + * Takes ownership of `sdata` and `sobj` regardless of return code. + * @param sdata bytes of SSL session data or NULL (sobj then required) + * @param sdata_len amount of session data bytes + * @param ietf_tls_id IETF protocol version, e.g. 0x304 for TLSv1.3 + * @param alpn ALPN protocol selected or NULL + * @param valid_until seconds since EPOCH when session expires, pass 0 + * in case this is not known. + * @param psession on return the scached session instance created + */ +CURLcode Curl_ssl_session_create(void *sdata, size_t sdata_len, + int ietf_tls_id, const char *alpn, + curl_off_t valid_until, size_t earlydata_max, + struct Curl_ssl_session **psession); + +/* Variation of session creation with quic transport parameter bytes, + * Takes ownership of `quic_tp` regardless of return code. */ +CURLcode Curl_ssl_session_create2(void *sdata, size_t sdata_len, + int ietf_tls_id, const char *alpn, + curl_off_t valid_until, size_t earlydata_max, + unsigned char *quic_tp, size_t quic_tp_len, + struct Curl_ssl_session **psession); + +/* Destroy a `session` instance. Can be called with NULL. + * Does NOT need locking. */ +void Curl_ssl_session_destroy(struct Curl_ssl_session *s); + +/* Put the scache session into the cache. Does NOT need locking. + * Call takes ownership of `s` in all outcomes. + * @param cf the connection filter wanting to use it + * @param data the transfer involved + * @param ssl_peer_key the key for lookup + * @param s the scache session object + */ +CURLcode Curl_ssl_scache_put(struct Curl_cfilter *cf, + struct Curl_easy *data, + const char *ssl_peer_key, + struct Curl_ssl_session *s); + +/* Take a matching scache session from the cache. Does NOT need locking. + * @param cf the connection filter wanting to use it + * @param data the transfer involved + * @param ssl_peer_key the key for lookup + * @param s on return, the scache session object or NULL + */ +CURLcode Curl_ssl_scache_take(struct Curl_cfilter *cf, + struct Curl_easy *data, + const char *ssl_peer_key, + struct Curl_ssl_session **ps); + +/* Return a taken scache session to the cache. Does NOT need locking. + * Depending on TLS version and other criteria, it may cache it again + * or destroy it. Maybe called with a NULL session. + */ +void Curl_ssl_scache_return(struct Curl_cfilter *cf, + struct Curl_easy *data, + const char *ssl_peer_key, + struct Curl_ssl_session *s); + +/* Remove all sessions and obj for the peer_key. Does NOT need locking. */ +void Curl_ssl_scache_remove_all(struct Curl_cfilter *cf, + struct Curl_easy *data, + const char *ssl_peer_key); + +#ifdef USE_SSLS_EXPORT + +bool Curl_ssl_scache_is_locked(struct Curl_easy *data); + +CURLcode Curl_ssl_session_import(struct Curl_easy *data, + const char *ssl_peer_key, + const unsigned char *shmac, size_t shmac_len, + const void *sdata, size_t sdata_len); + +CURLcode Curl_ssl_session_export(struct Curl_easy *data, + curl_ssls_export_cb *export_fn, + void *userptr); + +#endif /* USE_SSLS_EXPORT */ +#endif /* USE_SSL */ + +#endif /* HEADER_CURL_VTLS_SCACHE_H */ diff --git a/3rdparty/curl-8.21.0/lib/vtls/vtls_spack.c b/3rdparty/curl-8.21.0/lib/vtls/vtls_spack.c new file mode 100644 index 0000000000..9cbdecc901 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vtls/vtls_spack.c @@ -0,0 +1,322 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if defined(USE_SSL) && defined(USE_SSLS_EXPORT) + +#include "urldata.h" +#include "curl_trc.h" +#include "vtls/vtls_scache.h" +#include "vtls/vtls_spack.h" +#include "curlx/strdup.h" + +#define CURL_SPACK_VERSION 0x01 +#define CURL_SPACK_IETF_ID 0x02 +#define CURL_SPACK_VALID_UNTIL 0x03 +#define CURL_SPACK_TICKET 0x04 +#define CURL_SPACK_ALPN 0x05 +#define CURL_SPACK_EARLYDATA 0x06 +#define CURL_SPACK_QUICTP 0x07 + +static CURLcode spack_enc8(struct dynbuf *buf, uint8_t b) +{ + return curlx_dyn_addn(buf, &b, 1); +} + +static CURLcode spack_dec8(uint8_t *val, const uint8_t **src, + const uint8_t *end) +{ + if(end - *src < 1) + return CURLE_READ_ERROR; + *val = **src; + *src += 1; + return CURLE_OK; +} + +static CURLcode spack_enc16(struct dynbuf *buf, uint16_t val) +{ + uint8_t nval[2]; + nval[0] = (uint8_t)(val >> 8); + nval[1] = (uint8_t)val; + return curlx_dyn_addn(buf, nval, sizeof(nval)); +} + +static CURLcode spack_dec16(uint16_t *val, const uint8_t **src, + const uint8_t *end) +{ + if(end - *src < 2) + return CURLE_READ_ERROR; + *val = (uint16_t)((*src)[0] << 8 | (*src)[1]); + *src += 2; + return CURLE_OK; +} + +static CURLcode spack_enc32(struct dynbuf *buf, uint32_t val) +{ + uint8_t nval[4]; + nval[0] = (uint8_t)(val >> 24); + nval[1] = (uint8_t)(val >> 16); + nval[2] = (uint8_t)(val >> 8); + nval[3] = (uint8_t)val; + return curlx_dyn_addn(buf, nval, sizeof(nval)); +} + +static CURLcode spack_dec32(uint32_t *val, const uint8_t **src, + const uint8_t *end) +{ + if(end - *src < 4) + return CURLE_READ_ERROR; + *val = (uint32_t)(*src)[0] << 24 | (uint32_t)(*src)[1] << 16 | + (uint32_t)(*src)[2] << 8 | (*src)[3]; + *src += 4; + return CURLE_OK; +} + +static CURLcode spack_enc64(struct dynbuf *buf, uint64_t val) +{ + uint8_t nval[8]; + nval[0] = (uint8_t)(val >> 56); + nval[1] = (uint8_t)(val >> 48); + nval[2] = (uint8_t)(val >> 40); + nval[3] = (uint8_t)(val >> 32); + nval[4] = (uint8_t)(val >> 24); + nval[5] = (uint8_t)(val >> 16); + nval[6] = (uint8_t)(val >> 8); + nval[7] = (uint8_t)val; + return curlx_dyn_addn(buf, nval, sizeof(nval)); +} + +static CURLcode spack_dec64(uint64_t *val, const uint8_t **src, + const uint8_t *end) +{ + if(end - *src < 8) + return CURLE_READ_ERROR; + *val = (uint64_t)(*src)[0] << 56 | (uint64_t)(*src)[1] << 48 | + (uint64_t)(*src)[2] << 40 | (uint64_t)(*src)[3] << 32 | + (uint64_t)(*src)[4] << 24 | (uint64_t)(*src)[5] << 16 | + (uint64_t)(*src)[6] << 8 | (*src)[7]; + *src += 8; + return CURLE_OK; +} + +static CURLcode spack_encstr16(struct dynbuf *buf, const char *s) +{ + size_t slen = strlen(s); + CURLcode result; + if(slen > UINT16_MAX) + return CURLE_BAD_FUNCTION_ARGUMENT; + result = spack_enc16(buf, (uint16_t)slen); + if(!result) { + result = curlx_dyn_addn(buf, s, slen); + } + return result; +} + +static CURLcode spack_decstr16(char **val, const uint8_t **src, + const uint8_t *end) +{ + uint16_t slen; + CURLcode result; + + *val = NULL; + result = spack_dec16(&slen, src, end); + if(result) + return result; + if(end - *src < slen) + return CURLE_READ_ERROR; + *val = curlx_memdup0((const char *)(*src), slen); + *src += slen; + return *val ? CURLE_OK : CURLE_OUT_OF_MEMORY; +} + +static CURLcode spack_encdata16(struct dynbuf *buf, const uint8_t *data, + size_t data_len) +{ + CURLcode result; + if(data_len > UINT16_MAX) + return CURLE_BAD_FUNCTION_ARGUMENT; + result = spack_enc16(buf, (uint16_t)data_len); + if(!result) { + result = curlx_dyn_addn(buf, data, data_len); + } + return result; +} + +static CURLcode spack_decdata16(uint8_t **val, size_t *val_len, + const uint8_t **src, const uint8_t *end) +{ + uint16_t data_len; + CURLcode result; + + *val = NULL; + result = spack_dec16(&data_len, src, end); + if(result) + return result; + if(end - *src < data_len) + return CURLE_READ_ERROR; + *val = curlx_memdup0((const char *)(*src), data_len); + *val_len = data_len; + *src += data_len; + return *val ? CURLE_OK : CURLE_OUT_OF_MEMORY; +} + +CURLcode Curl_ssl_session_pack(struct Curl_easy *data, + struct Curl_ssl_session *s, + struct dynbuf *buf) +{ + CURLcode result; + DEBUGASSERT(s->sdata); + DEBUGASSERT(s->sdata_len); + + if(s->valid_until < 0) + return CURLE_BAD_FUNCTION_ARGUMENT; + + result = spack_enc8(buf, CURL_SPACK_VERSION); + if(!result) + result = spack_enc8(buf, CURL_SPACK_TICKET); + if(!result) + result = spack_encdata16(buf, s->sdata, s->sdata_len); + if(!result) + result = spack_enc8(buf, CURL_SPACK_IETF_ID); + if(!result) + result = spack_enc16(buf, (uint16_t)s->ietf_tls_id); + if(!result) + result = spack_enc8(buf, CURL_SPACK_VALID_UNTIL); + if(!result) + result = spack_enc64(buf, (uint64_t)s->valid_until); + if(!result && s->alpn) { + result = spack_enc8(buf, CURL_SPACK_ALPN); + if(!result) + result = spack_encstr16(buf, s->alpn); + } + if(!result && s->earlydata_max) { + if(s->earlydata_max > UINT32_MAX) + result = CURLE_BAD_FUNCTION_ARGUMENT; + if(!result) + result = spack_enc8(buf, CURL_SPACK_EARLYDATA); + if(!result) + result = spack_enc32(buf, (uint32_t)s->earlydata_max); + } + if(!result && s->quic_tp && s->quic_tp_len) { + result = spack_enc8(buf, CURL_SPACK_QUICTP); + if(!result) + result = spack_encdata16(buf, s->quic_tp, s->quic_tp_len); + } + + if(result) + CURL_TRC_SSLS(data, "error packing data: %d", (int)result); + return result; +} + +CURLcode Curl_ssl_session_unpack(struct Curl_easy *data, + const void *bufv, size_t buflen, + struct Curl_ssl_session **ps) +{ + struct Curl_ssl_session *s = NULL; + const unsigned char *buf = (const unsigned char *)bufv; + const unsigned char *end = buf + buflen; + uint8_t val8, *pval8; + uint16_t val16; + uint32_t val32; + uint64_t val64; + CURLcode result; + + DEBUGASSERT(buf); + DEBUGASSERT(buflen); + *ps = NULL; + + result = spack_dec8(&val8, &buf, end); + if(result) + goto out; + if(val8 != CURL_SPACK_VERSION) { + result = CURLE_READ_ERROR; + goto out; + } + + s = curlx_calloc(1, sizeof(*s)); + if(!s) { + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + while(buf < end) { + result = spack_dec8(&val8, &buf, end); + if(result) + goto out; + + switch(val8) { + case CURL_SPACK_ALPN: + result = spack_decstr16(&s->alpn, &buf, end); + if(result) + goto out; + break; + case CURL_SPACK_EARLYDATA: + result = spack_dec32(&val32, &buf, end); + if(result) + goto out; + s->earlydata_max = val32; + break; + case CURL_SPACK_IETF_ID: + result = spack_dec16(&val16, &buf, end); + if(result) + goto out; + s->ietf_tls_id = val16; + break; + case CURL_SPACK_QUICTP: { + result = spack_decdata16(&pval8, &s->quic_tp_len, &buf, end); + if(result) + goto out; + s->quic_tp = pval8; + break; + } + case CURL_SPACK_TICKET: { + result = spack_decdata16(&pval8, &s->sdata_len, &buf, end); + if(result) + goto out; + s->sdata = pval8; + break; + } + case CURL_SPACK_VALID_UNTIL: + result = spack_dec64(&val64, &buf, end); + if(result) + goto out; + s->valid_until = (curl_off_t)val64; + break; + default: /* unknown tag */ + result = CURLE_READ_ERROR; + goto out; + } + } + +out: + if(result) { + CURL_TRC_SSLS(data, "error unpacking data: %d", (int)result); + Curl_ssl_session_destroy(s); + } + else + *ps = s; + return result; +} + +#endif /* USE_SSL && USE_SSLS_EXPORT */ diff --git a/3rdparty/curl-8.21.0/lib/vtls/vtls_spack.h b/3rdparty/curl-8.21.0/lib/vtls/vtls_spack.h new file mode 100644 index 0000000000..4479384de9 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vtls/vtls_spack.h @@ -0,0 +1,43 @@ +#ifndef HEADER_CURL_VTLS_SPACK_H +#define HEADER_CURL_VTLS_SPACK_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if defined(USE_SSL) && defined(USE_SSLS_EXPORT) + +struct dynbuf; +struct Curl_ssl_session; + +CURLcode Curl_ssl_session_pack(struct Curl_easy *data, + struct Curl_ssl_session *s, + struct dynbuf *buf); + +CURLcode Curl_ssl_session_unpack(struct Curl_easy *data, + const void *bufv, size_t buflen, + struct Curl_ssl_session **ps); + +#endif /* USE_SSL && USE_SSLS_EXPORT */ + +#endif /* HEADER_CURL_VTLS_SPACK_H */ diff --git a/3rdparty/curl-8.21.0/lib/vtls/wolfssl.c b/3rdparty/curl-8.21.0/lib/vtls/wolfssl.c new file mode 100644 index 0000000000..92eaa7a751 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vtls/wolfssl.c @@ -0,0 +1,2310 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +/* + * Source file for all wolfSSL specific code for the TLS/SSL layer. No code + * but vtls.c should ever call or use these functions. + * + */ +#include "curl_setup.h" + +#ifdef USE_WOLFSSL + +#include +#include + +#if LIBWOLFSSL_VERSION_HEX < 0x05000000 /* wolfSSL 5.0.0 (2021-11-01) */ +#error "wolfSSL version should be at least 5.0.0" +#endif +#if defined(OPENSSL_COEXIST) && LIBWOLFSSL_VERSION_HEX < 0x05007006 +#error "wolfSSL 5.7.6 or newer is required to coexist with OpenSSL" +#endif + +/* To determine what functions are available we rely on one or both of: + - the user's options.h generated by wolfSSL + - the symbols detected by curl's configure + Since they are markedly different from one another, and one or the other may + not be available, we do some checking below to bring things in sync. */ + +/* HAVE_ALPN is wolfSSL's build time symbol for enabling ALPN in options.h. */ +#ifndef HAVE_ALPN +#ifdef HAVE_WOLFSSL_USEALPN +#define HAVE_ALPN +#endif +#endif + +#include "urldata.h" +#include "curl_trc.h" +#include "httpsrr.h" +#include "cf-dns.h" +#include "vtls/vtls.h" +#include "vtls/vtls_int.h" +#include "vtls/vtls_scache.h" +#include "vtls/keylog.h" +#include "connect.h" /* for the connect timeout */ +#include "progress.h" +#include "curlx/strdup.h" +#include "curlx/strcopy.h" +#include "vtls/x509asn1.h" +#ifdef USE_ECH +#include "curlx/base64.h" +#endif + +#include +#include + +#include "vtls/wolfssl.h" + +/* KEEP_PEER_CERT is a product of the presence of build time symbol + OPENSSL_EXTRA without NO_CERTS, depending on the version. KEEP_PEER_CERT is + in wolfSSL's settings.h, and the latter two are build time symbols in + options.h. */ +#ifndef KEEP_PEER_CERT +#if defined(HAVE_WOLFSSL_GET_PEER_CERTIFICATE) || \ + (defined(OPENSSL_EXTRA) && !defined(NO_CERTS)) +#define KEEP_PEER_CERT +#endif +#endif + +#ifdef HAVE_WOLFSSL_BIO_NEW +#define USE_BIO_CHAIN +#ifdef HAVE_WOLFSSL_BIO_SET_SHUTDOWN +#define USE_FULL_BIO +#else /* HAVE_WOLFSSL_BIO_SET_SHUTDOWN */ +#undef USE_FULL_BIO +#endif +/* wolfSSL 5.7.4 and older do not have these symbols, but only the + * OpenSSL ones. */ +#ifndef WOLFSSL_BIO_CTRL_GET_CLOSE +#define WOLFSSL_BIO_CTRL_GET_CLOSE BIO_CTRL_GET_CLOSE +#define WOLFSSL_BIO_CTRL_SET_CLOSE BIO_CTRL_SET_CLOSE +#define WOLFSSL_BIO_CTRL_FLUSH BIO_CTRL_FLUSH +#define WOLFSSL_BIO_CTRL_DUP BIO_CTRL_DUP +#define wolfSSL_BIO_set_retry_write BIO_set_retry_write +#define wolfSSL_BIO_set_retry_read BIO_set_retry_read +#endif /* !WOLFSSL_BIO_CTRL_GET_CLOSE */ + +#else /* HAVE_WOLFSSL_BIO_NEW */ +#undef USE_BIO_CHAIN +#endif + +#ifdef OPENSSL_EXTRA +/* + * Availability note: + * The TLS 1.3 secret callback (wolfSSL_set_tls13_secret_cb) was added in + * wolfSSL 4.4.0, but requires the -DHAVE_SECRET_CALLBACK build option. If that + * option is not set, then TLS 1.3 is not logged. + * For TLS 1.2 and before, we use wolfSSL_get_keys(). + * wolfSSL_get_client_random and wolfSSL_get_keys require OPENSSL_EXTRA + * (--enable-opensslextra or --enable-all). + */ +#if defined(HAVE_SECRET_CALLBACK) && defined(WOLFSSL_TLS13) +static int wssl_tls13_secret_callback(SSL *ssl, int id, + const unsigned char *secret, + int secretSz, void *ctx) +{ + const char *label; + unsigned char client_random[SSL3_RANDOM_SIZE]; + (void)ctx; + + if(!ssl || !Curl_tls_keylog_enabled()) { + return 0; + } + + switch(id) { + case CLIENT_EARLY_TRAFFIC_SECRET: + label = "CLIENT_EARLY_TRAFFIC_SECRET"; + break; + case CLIENT_HANDSHAKE_TRAFFIC_SECRET: + label = "CLIENT_HANDSHAKE_TRAFFIC_SECRET"; + break; + case SERVER_HANDSHAKE_TRAFFIC_SECRET: + label = "SERVER_HANDSHAKE_TRAFFIC_SECRET"; + break; + case CLIENT_TRAFFIC_SECRET: + label = "CLIENT_TRAFFIC_SECRET_0"; + break; + case SERVER_TRAFFIC_SECRET: + label = "SERVER_TRAFFIC_SECRET_0"; + break; + case EARLY_EXPORTER_SECRET: + label = "EARLY_EXPORTER_SECRET"; + break; + case EXPORTER_SECRET: + label = "EXPORTER_SECRET"; + break; + default: + return 0; + } + + if(wolfSSL_get_client_random(ssl, client_random, SSL3_RANDOM_SIZE) == 0) { + /* Should never happen as wolfSSL_KeepArrays() was called before. */ + return 0; + } + + Curl_tls_keylog_write(label, client_random, secret, secretSz); + return 0; +} +#endif /* HAVE_SECRET_CALLBACK && WOLFSSL_TLS13 */ + +static void wssl_log_tls12_secret(WOLFSSL *ssl) +{ + unsigned char *ms, *sr, *cr; + unsigned int msLen, srLen, crLen, i, x = 0; + + /* wolfSSL_GetVersion is available since 3.13, we use it instead of + * SSL_version since the latter relies on OPENSSL_ALL (--enable-opensslall or + * --enable-all). Failing to perform this check could result in an unusable + * key log line when TLS 1.3 is actually negotiated. */ + switch(wolfSSL_GetVersion(ssl)) { + case WOLFSSL_SSLV3: + case WOLFSSL_TLSV1: + case WOLFSSL_TLSV1_1: + case WOLFSSL_TLSV1_2: + break; + default: + /* TLS 1.3 does not use this mechanism, the "master secret" returned below + * is not directly usable. */ + return; + } + + if(wolfSSL_get_keys(ssl, &ms, &msLen, &sr, &srLen, &cr, &crLen) != + WOLFSSL_SUCCESS) { + return; + } + + /* Check for a missing master secret and skip logging. That can happen if + * curl rejects the server certificate and aborts the handshake. + */ + for(i = 0; i < msLen; i++) { + x |= ms[i]; + } + if(x == 0) { + return; + } + + Curl_tls_keylog_write("CLIENT_RANDOM", cr, ms, msLen); +} +#endif /* OPENSSL_EXTRA */ + +static int wssl_do_file_type(const char *type) +{ + if(!type || !type[0]) + return WOLFSSL_FILETYPE_PEM; + if(curl_strequal(type, "PEM")) + return WOLFSSL_FILETYPE_PEM; + if(curl_strequal(type, "DER")) + return WOLFSSL_FILETYPE_ASN1; + return -1; +} + +#ifdef USE_BIO_CHAIN + +static int wssl_bio_cf_create(WOLFSSL_BIO *bio) +{ +#ifdef USE_FULL_BIO + wolfSSL_BIO_set_shutdown(bio, 1); +#endif + wolfSSL_BIO_set_data(bio, NULL); + return 1; +} + +static int wssl_bio_cf_destroy(WOLFSSL_BIO *bio) +{ + if(!bio) + return 0; + return 1; +} + +static long wssl_bio_cf_ctrl(WOLFSSL_BIO *bio, int cmd, long num, void *ptr) +{ + struct Curl_cfilter *cf = wolfSSL_BIO_get_data(bio); + long ret = 1; + + (void)cf; + (void)ptr; + (void)num; + switch(cmd) { + case WOLFSSL_BIO_CTRL_GET_CLOSE: +#ifdef USE_FULL_BIO + ret = (long)wolfSSL_BIO_get_shutdown(bio); +#else + ret = 0; +#endif + break; + case WOLFSSL_BIO_CTRL_SET_CLOSE: +#ifdef USE_FULL_BIO + wolfSSL_BIO_set_shutdown(bio, (int)num); +#endif + break; + case WOLFSSL_BIO_CTRL_FLUSH: + /* we do no delayed writes, but if we ever would, this + * needs to trigger it. */ + ret = 1; + break; + case WOLFSSL_BIO_CTRL_DUP: + ret = 1; + break; +#ifdef WOLFSSL_BIO_CTRL_EOF + case WOLFSSL_BIO_CTRL_EOF: { + /* EOF has been reached on input? */ + struct ssl_connect_data *connssl = cf->ctx; + return connssl->peer_closed; + } +#endif + default: + ret = 0; + break; + } + return ret; +} + +static int wssl_bio_cf_out_write(WOLFSSL_BIO *bio, const char *buf, int blen) +{ + struct Curl_cfilter *cf = wolfSSL_BIO_get_data(bio); + struct ssl_connect_data *connssl = cf->ctx; + struct wssl_ctx *wssl = (struct wssl_ctx *)connssl->backend; + struct Curl_easy *data = CF_DATA_CURRENT(cf); + size_t nwritten, skiplen = 0; + CURLcode result = CURLE_OK; + + DEBUGASSERT(data); + if(wssl->shutting_down && wssl->io_send_blocked_len && + (wssl->io_send_blocked_len < blen)) { + /* bug in wolfSSL: + * It adds the close notify message again every time we retry + * sending during shutdown. */ + CURL_TRC_CF(data, cf, "bio_write, shutdown restrict send of %d" + " to %d bytes", blen, wssl->io_send_blocked_len); + skiplen = (size_t)(blen - wssl->io_send_blocked_len); + blen = wssl->io_send_blocked_len; + } + result = Curl_conn_cf_send(cf->next, data, + (const uint8_t *)buf, blen, FALSE, &nwritten); + wssl->io_result = result; + CURL_TRC_CF(data, cf, "bio_write(len=%d) -> %d, %zu", + blen, (int)result, nwritten); +#ifdef USE_FULL_BIO + wolfSSL_BIO_clear_retry_flags(bio); +#endif + if(result == CURLE_AGAIN) { + wolfSSL_BIO_set_retry_write(bio); + if(wssl->shutting_down && !wssl->io_send_blocked_len) + wssl->io_send_blocked_len = blen; + } + else if(!result && skiplen) + nwritten += skiplen; + return result ? -1 : (int)nwritten; +} + +static int wssl_bio_cf_in_read(WOLFSSL_BIO *bio, char *buf, int blen) +{ + struct Curl_cfilter *cf = wolfSSL_BIO_get_data(bio); + struct ssl_connect_data *connssl = cf->ctx; + struct wssl_ctx *wssl = (struct wssl_ctx *)connssl->backend; + struct Curl_easy *data = CF_DATA_CURRENT(cf); + size_t nread = 0; + CURLcode result = CURLE_OK; + + DEBUGASSERT(data); + if(!data || (blen < 0)) { + wssl->io_result = CURLE_FAILED_INIT; + return -1; + } + if(!buf || !blen) + return 0; + + if((connssl->connecting_state == ssl_connect_2) && + !wssl->x509_store_setup) { + /* During handshake, init the x509 store before receiving the + * server response. This allows sending of ClientHello without delay. */ + result = Curl_wssl_setup_x509_store(cf, data, wssl); + if(result) { + CURL_TRC_CF(data, cf, "Curl_wssl_setup_x509_store() -> %d", (int)result); + wssl->io_result = result; + return -1; + } + } + + result = Curl_conn_cf_recv(cf->next, data, buf, blen, &nread); + wssl->io_result = result; + CURL_TRC_CF(data, cf, "bio_read(len=%d) -> %d, %zu", blen, (int)result, + nread); +#ifdef USE_FULL_BIO + wolfSSL_BIO_clear_retry_flags(bio); +#endif + if(result == CURLE_AGAIN) + wolfSSL_BIO_set_retry_read(bio); + else if(nread == 0) + connssl->peer_closed = TRUE; + return result ? -1 : (int)nread; +} + +static WOLFSSL_BIO_METHOD *wssl_bio_cf_method = NULL; + +static int wssl_bio_cf_init_methods(void) +{ + wssl_bio_cf_method = wolfSSL_BIO_meth_new(WOLFSSL_BIO_MEMORY, + "wolfSSL CF BIO"); + if(!wssl_bio_cf_method) + return FALSE; /* error */ + wolfSSL_BIO_meth_set_write(wssl_bio_cf_method, &wssl_bio_cf_out_write); + wolfSSL_BIO_meth_set_read(wssl_bio_cf_method, &wssl_bio_cf_in_read); + wolfSSL_BIO_meth_set_ctrl(wssl_bio_cf_method, &wssl_bio_cf_ctrl); + wolfSSL_BIO_meth_set_create(wssl_bio_cf_method, &wssl_bio_cf_create); + wolfSSL_BIO_meth_set_destroy(wssl_bio_cf_method, &wssl_bio_cf_destroy); + return TRUE; /* fine */ +} + +static void wssl_bio_cf_free_methods(void) +{ + wolfSSL_BIO_meth_free(wssl_bio_cf_method); + wssl_bio_cf_method = NULL; +} + +#else /* USE_BIO_CHAIN */ + +#define wssl_bio_cf_init_methods() TRUE +#define wssl_bio_cf_free_methods() Curl_nop_stmt + +#endif /* !USE_BIO_CHAIN */ + +#ifdef HAVE_EX_DATA +CURLcode Curl_wssl_cache_session(struct Curl_cfilter *cf, + struct Curl_easy *data, + const char *ssl_peer_key, + WOLFSSL_SESSION *session, + int ietf_tls_id, + const char *alpn, + unsigned char *quic_tp, + size_t quic_tp_len) +{ + CURLcode result = CURLE_OK; + struct Curl_ssl_session *sc_session = NULL; + unsigned char *sdata = NULL, *sdata_ptr, *qtp_clone = NULL; + unsigned int sdata_len; + unsigned int earlydata_max = 0; + + if(!session) + goto out; + + sdata_len = wolfSSL_i2d_SSL_SESSION(session, NULL); + if(sdata_len <= 0) { + CURL_TRC_CF(data, cf, "fail to assess session length: %u", sdata_len); + result = CURLE_FAILED_INIT; + goto out; + } + sdata = sdata_ptr = curlx_calloc(1, sdata_len); + if(!sdata) { + failf(data, "unable to allocate session buffer of %u bytes", sdata_len); + result = CURLE_OUT_OF_MEMORY; + goto out; + } + /* wolfSSL right now does not change the last parameter here, but it + * might one day decide to do so for OpenSSL compatibility. */ + sdata_len = wolfSSL_i2d_SSL_SESSION(session, &sdata_ptr); + if(sdata_len <= 0) { + CURL_TRC_CF(data, cf, "fail to serialize session: %u", sdata_len); + result = CURLE_FAILED_INIT; + goto out; + } + if(quic_tp && quic_tp_len) { + qtp_clone = curlx_memdup0((const char *)quic_tp, quic_tp_len); + if(!qtp_clone) { + curlx_free(sdata); + return CURLE_OUT_OF_MEMORY; + } + } +#ifdef WOLFSSL_EARLY_DATA + earlydata_max = wolfSSL_SESSION_get_max_early_data(session); +#endif + + result = Curl_ssl_session_create2(sdata, sdata_len, + ietf_tls_id, alpn, + (curl_off_t)time(NULL) + + wolfSSL_SESSION_get_timeout(session), + earlydata_max, qtp_clone, quic_tp_len, + &sc_session); + sdata = NULL; /* took ownership of sdata */ + if(!result) { + result = Curl_ssl_scache_put(cf, data, ssl_peer_key, sc_session); + /* took ownership of `sc_session` */ + } + +out: + curlx_free(sdata); + return result; +} + +static int wssl_vtls_new_session_cb(WOLFSSL *ssl, WOLFSSL_SESSION *session) +{ + struct Curl_cfilter *cf; + + cf = (struct Curl_cfilter *)wolfSSL_get_app_data(ssl); + DEBUGASSERT(cf); + if(cf && session) { + struct ssl_connect_data *connssl = cf->ctx; + struct Curl_easy *data = CF_DATA_CURRENT(cf); + DEBUGASSERT(connssl); + DEBUGASSERT(data); + if(connssl && data) { + (void)Curl_wssl_cache_session(cf, data, connssl->peer.scache_key, + session, wolfSSL_version(ssl), + connssl->negotiated.alpn, NULL, 0); + } + } + return 0; +} +#endif + +static CURLcode wssl_on_session_reuse(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct alpn_spec *alpns, + struct Curl_ssl_session *scs, + bool *do_early_data) +{ + struct ssl_connect_data *connssl = cf->ctx; +#ifdef WOLFSSL_EARLY_DATA + struct wssl_ctx *wssl = (struct wssl_ctx *)connssl->backend; + + connssl->earlydata_max = wolfSSL_SESSION_get_max_early_data( + wolfSSL_get_session(wssl->ssl)); +#else + connssl->earlydata_max = 0; +#endif + + /* Seems to be no wolfSSL way to signal no EarlyData in session */ + return Curl_on_session_reuse(cf, data, alpns, scs, do_early_data, + connssl->earlydata_max); +} + +static CURLcode wssl_setup_session( + struct Curl_cfilter *cf, + struct Curl_easy *data, + struct wssl_ctx *wss, + struct alpn_spec *alpns, + const char *ssl_peer_key, + Curl_wssl_init_session_reuse_cb *sess_reuse_cb) +{ + struct ssl_config_data *ssl_config = Curl_ssl_cf_get_config(cf, data); + struct Curl_ssl_session *scs = NULL; + CURLcode result; + + result = Curl_ssl_scache_take(cf, data, ssl_peer_key, &scs); + if(!result && scs && scs->sdata && scs->sdata_len && + (!scs->alpn || Curl_alpn_contains_proto(alpns, scs->alpn))) { + WOLFSSL_SESSION *session; + /* wolfSSL changes the passed pointer for whatever reasons, yikes */ + const unsigned char *sdata = scs->sdata; + session = wolfSSL_d2i_SSL_SESSION(NULL, &sdata, (long)scs->sdata_len); + if(session) { + int ret = wolfSSL_set_session(wss->ssl, session); + if(ret != WOLFSSL_SUCCESS) { + Curl_ssl_session_destroy(scs); + scs = NULL; + infof(data, "cached session not accepted (%d), " + "removing from cache", ret); + } + else { + infof(data, "SSL reusing session with ALPN '%s'", + scs->alpn ? scs->alpn : "-"); + if(ssl_config->earlydata && + !cf->conn->bits.connect_only && + !strcmp("TLSv1.3", wolfSSL_get_version(wss->ssl))) { + bool do_early_data = FALSE; + if(sess_reuse_cb) { + result = sess_reuse_cb(cf, data, alpns, scs, &do_early_data); + if(result) { + wolfSSL_SESSION_free(session); + goto out; + } + } +#ifdef WOLFSSL_EARLY_DATA + if(do_early_data) { + unsigned int edmax = (scs->earlydata_max < UINT_MAX) ? + (unsigned int)scs->earlydata_max : UINT_MAX; + /* We only try the ALPN protocol the session used before, + * otherwise we might send early data for the wrong protocol */ + Curl_alpn_restrict_to(alpns, scs->alpn); + wolfSSL_set_max_early_data(wss->ssl, edmax); + } +#else + /* Should never enable when not supported */ + DEBUGASSERT(!do_early_data); +#endif + } + } + wolfSSL_SESSION_free(session); + } + else { + failf(data, "could not decode previous session"); + } + } +out: + Curl_ssl_scache_return(cf, data, ssl_peer_key, scs); + return result; +} + +static CURLcode wssl_populate_x509_store(struct Curl_cfilter *cf, + struct Curl_easy *data, + WOLFSSL_X509_STORE *store, + struct wssl_ctx *wssl) +{ + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + const struct curl_blob *ca_info_blob = conn_config->ca_info_blob; + const char * const ssl_cafile = + /* CURLOPT_CAINFO_BLOB overrides CURLOPT_CAINFO */ + (ca_info_blob ? NULL : conn_config->CAfile); + const char * const ssl_capath = conn_config->CApath; + struct ssl_config_data *ssl_config = Curl_ssl_cf_get_config(cf, data); + bool imported_native_ca = FALSE; + bool imported_ca_info_blob = FALSE; + + /* We do not want to do this again, no matter the outcome */ + wssl->x509_store_setup = TRUE; + +#ifndef NO_FILESYSTEM + /* load native CA certificates */ + if(ssl_config->native_ca_store) { +#ifdef WOLFSSL_SYS_CA_CERTS + if(wolfSSL_CTX_load_system_CA_certs(wssl->ssl_ctx) != WOLFSSL_SUCCESS) { + infof(data, "error importing native CA store, continuing anyway"); + } + else { + imported_native_ca = TRUE; + infof(data, "successfully imported native CA store"); + } +#else + infof(data, "ignoring native CA option because wolfSSL was built without " + "native CA support"); +#endif + } +#endif /* !NO_FILESYSTEM */ + + /* load certificate blob */ + if(ca_info_blob) { + if(wolfSSL_CTX_load_verify_buffer(wssl->ssl_ctx, ca_info_blob->data, + (long)ca_info_blob->len, + WOLFSSL_FILETYPE_PEM) != + WOLFSSL_SUCCESS) { + failf(data, "error importing CA certificate blob"); + return CURLE_SSL_CACERT_BADFILE; + } + else { + imported_ca_info_blob = TRUE; + infof(data, "successfully imported CA certificate blob"); + } + } + +#ifndef NO_FILESYSTEM + /* load trusted cacert from file if not blob */ + + CURL_TRC_CF(data, cf, "wssl_populate_x509_store, path=%s, blob=%d", + ssl_cafile ? ssl_cafile : "none", !!ca_info_blob); + if(!store) + return CURLE_OUT_OF_MEMORY; + + if(ssl_cafile || ssl_capath) { + int rc = + wolfSSL_CTX_load_verify_locations_ex(wssl->ssl_ctx, + ssl_cafile, + ssl_capath, + WOLFSSL_LOAD_FLAG_IGNORE_ERR); + if(WOLFSSL_SUCCESS != rc) { + if(conn_config->verifypeer && + !imported_native_ca && !imported_ca_info_blob) { + /* Fail if we insist on successfully verifying the server. */ + failf(data, "error setting certificate verify locations:" + " CAfile: %s CApath: %s", + ssl_cafile ? ssl_cafile : "none", + ssl_capath ? ssl_capath : "none"); + return CURLE_SSL_CACERT_BADFILE; + } + else { + /* continue with a warning if no strict certificate + verification is required. */ + infof(data, "error setting certificate verify locations," + " continuing anyway:"); + } + } + else { + /* Everything is fine. */ + infof(data, "successfully set certificate verify locations:"); + } + infof(data, " CAfile: %s", ssl_cafile ? ssl_cafile : "none"); + infof(data, " CApath: %s", ssl_capath ? ssl_capath : "none"); + } +#endif + (void)store; + return CURLE_OK; +} + +/* key to use at `multi->proto_hash` */ +#define MPROTO_WSSL_X509_KEY "tls:wssl:x509:share" + +struct wssl_x509_share { + char *CAfile; /* CAfile path used to generate X509 store */ + WOLFSSL_X509_STORE *store; /* cached X509 store or NULL if none */ + struct curltime time; /* when the cached store was created */ +}; + +static void wssl_x509_share_free(void *key, size_t key_len, void *p) +{ + struct wssl_x509_share *share = p; + DEBUGASSERT(key_len == (sizeof(MPROTO_WSSL_X509_KEY) - 1)); + DEBUGASSERT(!memcmp(MPROTO_WSSL_X509_KEY, key, key_len)); + (void)key; + (void)key_len; + if(share->store) { + wolfSSL_X509_STORE_free(share->store); + } + curlx_free(share->CAfile); + curlx_free(share); +} + +static bool wssl_cached_x509_store_expired(struct Curl_easy *data, + const struct wssl_x509_share *mb) +{ + const struct ssl_general_config *cfg = &data->set.general_ssl; + timediff_t elapsed_ms = curlx_ptimediff_ms(Curl_pgrs_now(data), &mb->time); + timediff_t timeout_ms = cfg->ca_cache_timeout * (timediff_t)1000; + + if(timeout_ms < 0) + return FALSE; + + return elapsed_ms >= timeout_ms; +} + +static bool wssl_cached_x509_store_different(struct Curl_cfilter *cf, + const struct wssl_x509_share *mb) +{ + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + if(!mb->CAfile || !conn_config->CAfile) + return mb->CAfile != conn_config->CAfile; + + return strcmp(mb->CAfile, conn_config->CAfile); +} + +static WOLFSSL_X509_STORE *wssl_get_cached_x509_store(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct Curl_multi *multi = data->multi; + struct wssl_x509_share *share; + WOLFSSL_X509_STORE *store = NULL; + + DEBUGASSERT(multi); + share = multi ? Curl_hash_pick(&multi->proto_hash, + CURL_UNCONST(MPROTO_WSSL_X509_KEY), + sizeof(MPROTO_WSSL_X509_KEY) - 1) : NULL; + if(share && share->store && + !wssl_cached_x509_store_expired(data, share) && + !wssl_cached_x509_store_different(cf, share)) { + store = share->store; + } + + return store; +} + +static void wssl_set_cached_x509_store(struct Curl_cfilter *cf, + struct Curl_easy *data, + WOLFSSL_X509_STORE *store) +{ + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + struct Curl_multi *multi = data->multi; + struct wssl_x509_share *share; + + DEBUGASSERT(multi); + if(!multi) + return; + share = Curl_hash_pick(&multi->proto_hash, + CURL_UNCONST(MPROTO_WSSL_X509_KEY), + sizeof(MPROTO_WSSL_X509_KEY) - 1); + + if(!share) { + share = curlx_calloc(1, sizeof(*share)); + if(!share) + return; + if(!Curl_hash_add2(&multi->proto_hash, + CURL_UNCONST(MPROTO_WSSL_X509_KEY), + sizeof(MPROTO_WSSL_X509_KEY) - 1, + share, wssl_x509_share_free)) { + curlx_free(share); + return; + } + } + + if(wolfSSL_X509_STORE_up_ref(store)) { + char *CAfile = NULL; + + if(conn_config->CAfile) { + CAfile = curlx_strdup(conn_config->CAfile); + if(!CAfile) { + wolfSSL_X509_STORE_free(store); + return; + } + } + + if(share->store) { + wolfSSL_X509_STORE_free(share->store); + curlx_free(share->CAfile); + } + + share->time = *Curl_pgrs_now(data); + share->store = store; + share->CAfile = CAfile; + } +} + +CURLcode Curl_wssl_setup_x509_store(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct wssl_ctx *wssl) +{ + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + struct ssl_config_data *ssl_config = Curl_ssl_cf_get_config(cf, data); + CURLcode result = CURLE_OK; + WOLFSSL_X509_STORE *cached_store; + bool cache_criteria_met; + + /* Consider the X509 store cacheable if it comes exclusively from a CAfile, + or no source is provided and we are falling back to wolfSSL's built-in + default. */ + cache_criteria_met = (data->set.general_ssl.ca_cache_timeout != 0) && + conn_config->verifypeer && + !conn_config->CApath && + !conn_config->ca_info_blob && + !ssl_config->primary.CRLfile && + !ssl_config->native_ca_store; + + cached_store = cache_criteria_met ? wssl_get_cached_x509_store(cf, data) + : NULL; + if(cached_store && + wolfSSL_CTX_get_cert_store(wssl->ssl_ctx) == cached_store) { + /* The cached store is already in use, do nothing. */ + } + else if(cached_store && wolfSSL_X509_STORE_up_ref(cached_store)) { + wolfSSL_CTX_set_cert_store(wssl->ssl_ctx, cached_store); + } + else if(cache_criteria_met) { + /* wolfSSL's initial store in CTX is not shareable by default. + * Make a new one, suitable for adding to the cache. See #14278 */ + WOLFSSL_X509_STORE *store = wolfSSL_X509_STORE_new(); + if(!store) { + failf(data, "SSL: could not create a X509 store"); + return CURLE_OUT_OF_MEMORY; + } + wolfSSL_CTX_set_cert_store(wssl->ssl_ctx, store); + + result = wssl_populate_x509_store(cf, data, store, wssl); + if(!result) { + wssl_set_cached_x509_store(cf, data, store); + } + } + else { + /* We never share the CTX's store, use it. */ + WOLFSSL_X509_STORE *store = wolfSSL_CTX_get_cert_store(wssl->ssl_ctx); + result = wssl_populate_x509_store(cf, data, store, wssl); + } + + return result; +} + +#ifdef WOLFSSL_TLS13 +static CURLcode wssl_add_default_ciphers(bool tls13, struct dynbuf *buf) +{ + int i; + char *str; + + for(i = 0; (str = wolfSSL_get_cipher_list(i)) != NULL; i++) { + size_t n; + if((!strncmp(str, "TLS13", 5)) != tls13) + continue; + + /* if there already is data in the string, add colon separator */ + if(curlx_dyn_len(buf)) { + CURLcode result = curlx_dyn_addn(buf, ":", 1); + if(result) + return result; + } + + n = strlen(str); + if(curlx_dyn_addn(buf, str, n)) + return CURLE_OUT_OF_MEMORY; + } + + return CURLE_OK; +} +#endif + +#ifndef OPENSSL_EXTRA +static int wssl_legacy_CTX_set_min_proto_version(WOLFSSL_CTX *ctx, int version) +{ + int res; + switch(version) { + default: + case TLS1_VERSION: + res = wolfSSL_CTX_SetMinVersion(ctx, WOLFSSL_TLSV1); + if(res == WOLFSSL_SUCCESS) + return res; + FALLTHROUGH(); + case TLS1_1_VERSION: + res = wolfSSL_CTX_SetMinVersion(ctx, WOLFSSL_TLSV1_1); + if(res == WOLFSSL_SUCCESS) + return res; + FALLTHROUGH(); + case TLS1_2_VERSION: + res = wolfSSL_CTX_SetMinVersion(ctx, WOLFSSL_TLSV1_2); +#ifdef WOLFSSL_TLS13 + if(res == WOLFSSL_SUCCESS) + return res; + FALLTHROUGH(); + case TLS1_3_VERSION: + res = wolfSSL_CTX_SetMinVersion(ctx, WOLFSSL_TLSV1_3); +#endif + } + return res; +} + +static int wssl_legacy_CTX_set_max_proto_version(WOLFSSL_CTX *ctx, int version) +{ + (void)ctx, (void)version; + return WOLFSSL_NOT_IMPLEMENTED; +} +#define wolfSSL_CTX_set_min_proto_version wssl_legacy_CTX_set_min_proto_version +#define wolfSSL_CTX_set_max_proto_version wssl_legacy_CTX_set_max_proto_version +#endif /* OPENSSL_EXTRA */ + +static CURLcode wssl_client_cert(struct Curl_easy *data, + struct ssl_config_data *ssl_config, + struct wssl_ctx *wctx) +{ + /* Load the client certificate, and private key */ +#ifndef NO_FILESYSTEM + if(ssl_config->primary.cert_blob || ssl_config->primary.clientcert) { + const char *cert_file = ssl_config->primary.clientcert; + const char *key_file = ssl_config->primary.key; + const struct curl_blob *cert_blob = ssl_config->primary.cert_blob; + const struct curl_blob *key_blob = ssl_config->primary.key_blob; + int file_type = wssl_do_file_type(ssl_config->primary.cert_type); + int rc; + + switch(file_type) { + case WOLFSSL_FILETYPE_PEM: + rc = cert_blob ? + wolfSSL_CTX_use_certificate_chain_buffer(wctx->ssl_ctx, + cert_blob->data, + (long)cert_blob->len) : + wolfSSL_CTX_use_certificate_chain_file(wctx->ssl_ctx, cert_file); + break; + case WOLFSSL_FILETYPE_ASN1: + rc = cert_blob ? + wolfSSL_CTX_use_certificate_buffer(wctx->ssl_ctx, cert_blob->data, + (long)cert_blob->len, file_type) : + wolfSSL_CTX_use_certificate_file(wctx->ssl_ctx, cert_file, file_type); + break; + default: + failf(data, "unknown cert type"); + return CURLE_BAD_FUNCTION_ARGUMENT; + } + if(rc != 1) { + failf(data, "unable to use client certificate"); + return CURLE_SSL_CONNECT_ERROR; + } + + if(!key_blob && !key_file) { + key_blob = cert_blob; + key_file = cert_file; + } + else + file_type = wssl_do_file_type(ssl_config->primary.key_type); + + rc = key_blob ? + wolfSSL_CTX_use_PrivateKey_buffer(wctx->ssl_ctx, key_blob->data, + (long)key_blob->len, file_type) : + wolfSSL_CTX_use_PrivateKey_file(wctx->ssl_ctx, key_file, file_type); + if(rc != 1) { + failf(data, "unable to set private key"); + return CURLE_SSL_CONNECT_ERROR; + } + } +#else /* NO_FILESYSTEM */ + if(ssl_config->primary.cert_blob) { + const struct curl_blob *cert_blob = ssl_config->primary.cert_blob; + const struct curl_blob *key_blob = ssl_config->primary.key_blob; + int file_type = wssl_do_file_type(ssl_config->primary.cert_type); + int rc; + + switch(file_type) { + case WOLFSSL_FILETYPE_PEM: + rc = wolfSSL_CTX_use_certificate_chain_buffer(wctx->ssl_ctx, + cert_blob->data, + (long)cert_blob->len); + break; + case WOLFSSL_FILETYPE_ASN1: + rc = wolfSSL_CTX_use_certificate_buffer(wctx->ssl_ctx, cert_blob->data, + (long)cert_blob->len, file_type); + break; + default: + failf(data, "unknown cert type"); + return CURLE_BAD_FUNCTION_ARGUMENT; + } + if(rc != 1) { + failf(data, "unable to use client certificate"); + return CURLE_SSL_CONNECT_ERROR; + } + + if(!key_blob) + key_blob = cert_blob; + else + file_type = wssl_do_file_type(ssl_config->primary.key_type); + + if(wolfSSL_CTX_use_PrivateKey_buffer(wctx->ssl_ctx, key_blob->data, + (long)key_blob->len, + file_type) != 1) { + failf(data, "unable to set private key"); + return CURLE_SSL_CONNECT_ERROR; + } + } +#endif /* !NO_FILESYSTEM */ + return CURLE_OK; +} + +static CURLcode ssl_version(struct Curl_easy *data, + struct ssl_primary_config *conn_config, + struct wssl_ctx *wctx, + int *min_version, int *max_version) +{ + int res; + *min_version = *max_version = 0; + DEBUGASSERT(conn_config->version != CURL_SSLVERSION_DEFAULT); + + switch(conn_config->version) { + case CURL_SSLVERSION_TLSv1: + case CURL_SSLVERSION_TLSv1_0: + *min_version = TLS1_VERSION; + break; + case CURL_SSLVERSION_TLSv1_1: + *min_version = TLS1_1_VERSION; + break; + case CURL_SSLVERSION_TLSv1_2: + *min_version = TLS1_2_VERSION; + break; +#ifdef WOLFSSL_TLS13 + case CURL_SSLVERSION_TLSv1_3: + *min_version = TLS1_3_VERSION; + break; +#endif + default: + failf(data, "wolfSSL: unsupported minimum TLS version value"); + return CURLE_SSL_CONNECT_ERROR; + } + + switch(conn_config->version_max) { +#ifdef WOLFSSL_TLS13 + case CURL_SSLVERSION_MAX_TLSv1_3: + *max_version = TLS1_3_VERSION; + break; +#endif + case CURL_SSLVERSION_MAX_TLSv1_2: + *max_version = TLS1_2_VERSION; + break; + case CURL_SSLVERSION_MAX_TLSv1_1: + *max_version = TLS1_1_VERSION; + break; + case CURL_SSLVERSION_MAX_TLSv1_0: + *max_version = TLS1_VERSION; + break; + case CURL_SSLVERSION_MAX_DEFAULT: + case CURL_SSLVERSION_MAX_NONE: + break; + default: + failf(data, "wolfSSL: unsupported maximum TLS version value"); + return CURLE_SSL_CONNECT_ERROR; + } + + res = wolfSSL_CTX_set_min_proto_version(wctx->ssl_ctx, *min_version); + if(res != WOLFSSL_SUCCESS) { + failf(data, "wolfSSL: failed set the minimum TLS version"); + return CURLE_SSL_CONNECT_ERROR; + } + + if(*max_version) { + res = wolfSSL_CTX_set_max_proto_version(wctx->ssl_ctx, *max_version); + if(res != WOLFSSL_SUCCESS) { + failf(data, "wolfSSL: failed set the maximum TLS version"); + return CURLE_SSL_CONNECT_ERROR; + } + } + return CURLE_OK; +} + +#ifdef WOLFSSL_TLS13 +#define MAX_CIPHER_LEN 4096 +#endif + +static CURLcode wssl_init_ciphers(struct Curl_easy *data, + struct wssl_ctx *wctx, + struct ssl_primary_config *conn_config, + int tls_min, int tls_max) +{ +#ifndef WOLFSSL_TLS13 + const char *ciphers = conn_config->cipher_list; + (void)tls_min; + (void)tls_max; + if(ciphers) { + if(!SSL_CTX_set_cipher_list(wctx->ssl_ctx, ciphers)) { + failf(data, "failed setting cipher list: %s", ciphers); + return CURLE_SSL_CIPHER; + } + infof(data, "Cipher selection: %s", ciphers); + } + return CURLE_OK; +#else + CURLcode result = CURLE_OK; + if(conn_config->cipher_list || conn_config->cipher_list13) { + const char *ciphers12 = conn_config->cipher_list; + const char *ciphers13 = conn_config->cipher_list13; + struct dynbuf c; + curlx_dyn_init(&c, MAX_CIPHER_LEN); + + if(!tls_max || (tls_max >= TLS1_3_VERSION)) { + if(ciphers13) + result = curlx_dyn_add(&c, ciphers13); + else + result = wssl_add_default_ciphers(TRUE, &c); + } + + if(!result && (tls_min < TLS1_3_VERSION)) { + if(ciphers12) { + if(curlx_dyn_len(&c)) + result = curlx_dyn_addn(&c, ":", 1); + if(!result) + result = curlx_dyn_add(&c, ciphers12); + } + else + result = wssl_add_default_ciphers(FALSE, &c); + } + if(!result) { + if(!wolfSSL_CTX_set_cipher_list(wctx->ssl_ctx, curlx_dyn_ptr(&c))) { + failf(data, "failed setting cipher list: %s", curlx_dyn_ptr(&c)); + result = CURLE_SSL_CIPHER; + } + else + infof(data, "Cipher selection: %s", curlx_dyn_ptr(&c)); + } + curlx_dyn_free(&c); + } + return result; +#endif +} + +/* wolfSSL_CTX_set1_groups_list() accepts PQC/hybrid groups (e.g. + X25519MLKEM768) that wolfSSL_CTX_set1_curves_list() rejects. It needs + OPENSSL_EXTRA, which wolfSSL's --enable-curl sets but --enable-curl=tiny + does not. */ +#ifdef OPENSSL_EXTRA +#define wssl_CTX_set1_groups_list wolfSSL_CTX_set1_groups_list +#else +#define wssl_CTX_set1_groups_list wolfSSL_CTX_set1_curves_list +#endif + +static CURLcode wssl_init_curves(struct Curl_easy *data, + struct wssl_ctx *wctx, + struct ssl_primary_config *conn_config) +{ + char *curves = conn_config->curves; + /* Without an explicit list, leave the key share group selection to + wolfSSL's own default. */ + if(curves && !wssl_CTX_set1_groups_list(wctx->ssl_ctx, curves)) { + failf(data, "failed setting curves list: '%s'", curves); + return CURLE_SSL_CIPHER; + } + return CURLE_OK; +} + +static CURLcode wssl_init_ssl_handle( + struct wssl_ctx *wctx, + struct Curl_cfilter *cf, + struct Curl_easy *data, + struct ssl_peer *peer, + struct alpn_spec *alpns, + void *ssl_user_data, + unsigned char transport, + Curl_wssl_init_session_reuse_cb *sess_reuse_cb) +{ + /* Let's make an SSL structure */ + wctx->ssl = wolfSSL_new(wctx->ssl_ctx); + if(!wctx->ssl) { + failf(data, "SSL: could not create a handle"); + return CURLE_OUT_OF_MEMORY; + } + +#ifdef HAVE_EX_DATA + wolfSSL_set_app_data(wctx->ssl, ssl_user_data); +#else + (void)ssl_user_data; +#endif +#ifdef WOLFSSL_QUIC + if(transport == TRNSPRT_QUIC) + wolfSSL_set_quic_use_legacy_codepoint(wctx->ssl, 0); +#else + (void)transport; +#endif + + /* Check if there is a cached ID we can/should use here! */ + if(Curl_ssl_scache_use(cf, data)) { + /* Set session from cache if there is one */ + (void)wssl_setup_session(cf, data, wctx, alpns, peer->scache_key, + sess_reuse_cb); + } + +#ifdef HAVE_ALPN + if(alpns->count) { + struct alpn_proto_buf proto; + memset(&proto, 0, sizeof(proto)); + Curl_alpn_to_proto_str(&proto, alpns); + + if(wolfSSL_UseALPN(wctx->ssl, (char *)proto.data, + (unsigned int)proto.len, + WOLFSSL_ALPN_CONTINUE_ON_MISMATCH) + != WOLFSSL_SUCCESS) { + failf(data, "SSL: failed setting ALPN protocols"); + return CURLE_SSL_CONNECT_ERROR; + } + CURL_TRC_CF(data, cf, "set ALPN: %s", proto.data); + } +#endif /* HAVE_ALPN */ + +#ifdef OPENSSL_EXTRA + if(Curl_tls_keylog_enabled()) { + /* Ensure the Client Random is preserved. */ + wolfSSL_KeepArrays(wctx->ssl); +#if defined(HAVE_SECRET_CALLBACK) && defined(WOLFSSL_TLS13) + wolfSSL_set_tls13_secret_cb(wctx->ssl, wssl_tls13_secret_callback, NULL); +#endif + } +#endif /* OPENSSL_EXTRA */ + +#ifdef HAVE_SECURE_RENEGOTIATION + if(wolfSSL_UseSecureRenegotiation(wctx->ssl) != SSL_SUCCESS) { + failf(data, "SSL: failed setting secure renegotiation"); + return CURLE_SSL_CONNECT_ERROR; + } +#endif /* HAVE_SECURE_RENEGOTIATION */ + + return CURLE_OK; +} + +#ifdef HAVE_WOLFSSL_CTX_GENERATEECHCONFIG +static CURLcode wssl_init_ech(struct wssl_ctx *wctx, + struct Curl_cfilter *cf, + struct Curl_easy *data, + struct ssl_peer *peer) +{ + int trying_ech_now = 0; + + if(data->set.str[STRING_ECH_PUBLIC]) { + infof(data, "ECH: outername not (yet) supported" + " with wolfSSL"); + return CURLE_SSL_CONNECT_ERROR; + } + if(data->set.tls_ech == CURLECH_GREASE) { + infof(data, "ECH: GREASE is done by default by" + " wolfSSL: no need to ask"); + } + if(data->set.tls_ech && data->set.str[STRING_ECH_CONFIG]) { + char *b64val = data->set.str[STRING_ECH_CONFIG]; + word32 b64len = 0; + + b64len = (word32)strlen(b64val); + if(b64len && wolfSSL_SetEchConfigsBase64(wctx->ssl, b64val, + b64len) != WOLFSSL_SUCCESS) { + if(data->set.tls_ech == CURLECH_HARD) + return CURLE_SSL_CONNECT_ERROR; + } + else { + trying_ech_now = 1; + infof(data, "ECH: ECHConfig from command line"); + } + } + else { + const struct Curl_https_rrinfo *rinfo = + Curl_conn_dns_get_https(data, cf->sockindex, peer->origin); + + if(rinfo && rinfo->echconfiglist) { + const unsigned char *ecl = rinfo->echconfiglist; + size_t elen = rinfo->echconfiglist_len; + + infof(data, "ECH: ECHConfig from HTTPS RR"); + if(wolfSSL_SetEchConfigs(wctx->ssl, ecl, (word32)elen) != + WOLFSSL_SUCCESS) { + infof(data, "ECH: wolfSSL_SetEchConfigs failed"); + if(data->set.tls_ech == CURLECH_HARD) { + return CURLE_SSL_CONNECT_ERROR; + } + } + else { + trying_ech_now = 1; + infof(data, "ECH: imported ECHConfigList of length %zu", elen); + } + } + else { + infof(data, "ECH: requested but no ECHConfig available"); + if(data->set.tls_ech == CURLECH_HARD) { + return CURLE_SSL_CONNECT_ERROR; + } + } + } + + if(trying_ech_now && + wolfSSL_set_min_proto_version(wctx->ssl, TLS1_3_VERSION) != 1) { + infof(data, "ECH: cannot force TLSv1.3 [ERROR]"); + return CURLE_SSL_CONNECT_ERROR; + } + return CURLE_OK; +} +#endif /* HAVE_WOLFSSL_CTX_GENERATEECHCONFIG */ + +CURLcode Curl_wssl_ctx_init(struct wssl_ctx *wctx, + struct Curl_cfilter *cf, + struct Curl_easy *data, + struct ssl_peer *peer, + const struct alpn_spec *alpns_requested, + Curl_wssl_ctx_setup_cb *cb_setup, + void *cb_user_data, + void *ssl_user_data, + Curl_wssl_init_session_reuse_cb *sess_reuse_cb) +{ + struct ssl_config_data *ssl_config = Curl_ssl_cf_get_config(cf, data); + struct ssl_primary_config *conn_config; + WOLFSSL_METHOD *req_method = NULL; + struct alpn_spec alpns; + CURLcode result = CURLE_FAILED_INIT; + unsigned char transport; + int tls_min, tls_max; + + DEBUGASSERT(!wctx->ssl_ctx); + DEBUGASSERT(!wctx->ssl); + conn_config = Curl_ssl_cf_get_primary_config(cf); + if(!conn_config) { + result = CURLE_FAILED_INIT; + goto out; + } + Curl_alpn_copy(&alpns, alpns_requested); + DEBUGASSERT(cf->next); + transport = Curl_conn_cf_get_transport(cf->next, data); + + req_method = wolfTLS_client_method(); + if(!req_method) { + failf(data, "wolfSSL: could not create a client method"); + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + if(wctx->ssl_ctx) + wolfSSL_CTX_free(wctx->ssl_ctx); + + wctx->ssl_ctx = wolfSSL_CTX_new(req_method); + if(!wctx->ssl_ctx) { + failf(data, "wolfSSL: could not create a context"); + result = CURLE_OUT_OF_MEMORY; + goto out; + } + + result = ssl_version(data, conn_config, wctx, &tls_min, &tls_max); + if(result) + goto out; + + result = wssl_init_ciphers(data, wctx, conn_config, tls_min, tls_max); + if(result) + goto out; + + result = wssl_init_curves(data, wctx, conn_config); + if(result) + goto out; + + result = wssl_client_cert(data, ssl_config, wctx); + if(result) + goto out; + + /* SSL always tries to verify the peer, this only says whether it should + * fail to connect if the verification fails, or if it should continue + * anyway. In the latter case the result of the verification is checked with + * SSL_get_verify_result() below. */ + wolfSSL_CTX_set_verify(wctx->ssl_ctx, conn_config->verifypeer ? + WOLFSSL_VERIFY_PEER : WOLFSSL_VERIFY_NONE, NULL); + +#ifdef HAVE_SNI + if(peer->sni) { + size_t sni_len = strlen(peer->sni); + if((sni_len < USHRT_MAX)) { + if(wolfSSL_CTX_UseSNI(wctx->ssl_ctx, WOLFSSL_SNI_HOST_NAME, + peer->sni, (unsigned short)sni_len) != 1) { + failf(data, "Failed to set SNI"); + result = CURLE_SSL_CONNECT_ERROR; + goto out; + } + CURL_TRC_CF(data, cf, "set SNI '%s'", peer->sni); + } + } +#endif + +#ifdef HAVE_EX_DATA + if(Curl_ssl_scache_use(cf, data) && (transport != TRNSPRT_QUIC)) { + /* Register to get notified when a new session is received */ + wolfSSL_CTX_sess_set_new_cb(wctx->ssl_ctx, wssl_vtls_new_session_cb); + } +#endif + + if(cb_setup) { + result = cb_setup(cf, data, cb_user_data); + if(result) + goto out; + } + + /* give application a chance to interfere with SSL set up. */ + if(data->set.ssl.fsslctx) { + if(!wctx->x509_store_setup) { + result = Curl_wssl_setup_x509_store(cf, data, wctx); + if(result) + goto out; + } + result = (*data->set.ssl.fsslctx)(data, wctx->ssl_ctx, + data->set.ssl.fsslctxp); + if(result) { + failf(data, "error signaled by SSL ctx callback"); + goto out; + } + } +#ifdef NO_FILESYSTEM + else if(conn_config->verifypeer) { + failf(data, "SSL: Certificates cannot be loaded because wolfSSL was built" + " with no file system. Either disable peer verification" + " (insecure) or if you are building an application with libcurl you" + " can load certificates via CURLOPT_SSL_CTX_FUNCTION."); + result = CURLE_SSL_CONNECT_ERROR; + goto out; + } +#endif + + result = wssl_init_ssl_handle(wctx, cf, data, peer, &alpns, ssl_user_data, + transport, sess_reuse_cb); + if(result) + goto out; + +#ifdef HAVE_WOLFSSL_CTX_GENERATEECHCONFIG + if(CURLECH_ENABLED(data)) { + result = wssl_init_ech(wctx, cf, data, peer); + if(result) + goto out; + } +#endif /* HAVE_WOLFSSL_CTX_GENERATEECHCONFIG */ + + result = CURLE_OK; + +out: + if(result && wctx->ssl) { + wolfSSL_free(wctx->ssl); + wctx->ssl = NULL; + } + if(result && wctx->ssl_ctx) { + wolfSSL_CTX_free(wctx->ssl_ctx); + wctx->ssl_ctx = NULL; + } + return result; +} + +bool Curl_wssl_need_httpsrr(struct Curl_easy *data) +{ +#ifdef HAVE_WOLFSSL_CTX_GENERATEECHCONFIG + if(!CURLECH_ENABLED(data)) + return FALSE; + if((data->set.tls_ech == CURLECH_GREASE) || + data->set.str[STRING_ECH_CONFIG]) + return FALSE; + return TRUE; +#else + (void)data; + return FALSE; +#endif +} + +/* + * This function loads all the client/CA certificates and CRLs. Setup the TLS + * layer and do all necessary magic. + */ +static CURLcode wssl_connect_step1(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct wssl_ctx *wssl = (struct wssl_ctx *)connssl->backend; + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + CURLcode result; + + DEBUGASSERT(wssl); + + if(connssl->state == ssl_connection_complete) + return CURLE_OK; + + result = Curl_wssl_ctx_init(wssl, cf, data, &connssl->peer, connssl->alpn, + NULL, NULL, cf, wssl_on_session_reuse); + if(result) + return result; + +#ifdef HAVE_ALPN + if(connssl->alpn && (connssl->state != ssl_connection_deferred)) { + struct alpn_proto_buf proto; + memset(&proto, 0, sizeof(proto)); + Curl_alpn_to_proto_str(&proto, connssl->alpn); + infof(data, VTLS_INFOF_ALPN_OFFER_1STR, proto.data); + } +#endif + + /* Enable RFC2818 checks on domain names. This cannot check + * IP addresses which we need to do extra after the handshake. */ + if(conn_config->verifyhost && connssl->peer.sni) { + if(wolfSSL_check_domain_name(wssl->ssl, connssl->peer.sni) != + WOLFSSL_SUCCESS) { + return CURLE_SSL_CONNECT_ERROR; + } + } + +#ifdef USE_BIO_CHAIN + { + WOLFSSL_BIO *bio; + + if(!wssl_bio_cf_method) + return CURLE_FAILED_INIT; + bio = wolfSSL_BIO_new(wssl_bio_cf_method); + if(!bio) + return CURLE_OUT_OF_MEMORY; + + wolfSSL_BIO_set_data(bio, cf); + wolfSSL_set_bio(wssl->ssl, bio, bio); + } +#else /* !USE_BIO_CHAIN */ + curl_socket_t sockfd = Curl_conn_cf_get_socket(cf, data); + if(sockfd > INT_MAX) { + failf(data, "SSL: socket value too large"); + return CURLE_SSL_CONNECT_ERROR; + } + /* pass the raw socket into the SSL layer */ + if(!wolfSSL_set_fd(wssl->ssl, (int)sockfd)) { + failf(data, "SSL: wolfSSL_set_fd failed"); + return CURLE_SSL_CONNECT_ERROR; + } +#endif /* USE_BIO_CHAIN */ + + return CURLE_OK; +} + +static char *wssl_strerror(unsigned long error, char *buf, unsigned long size) +{ + DEBUGASSERT(size > 40); + *buf = '\0'; + + wolfSSL_ERR_error_string_n(error, buf, size); + + if(!*buf) { + const char *msg = error ? "Unknown error" : "No error"; + curlx_strcopy(buf, size, msg, strlen(msg)); + } + + return buf; +} + +CURLcode Curl_wssl_verify_pinned(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct wssl_ctx *wssl) +{ + WOLFSSL_X509 *x509 = NULL; + CURLcode result = CURLE_OK; +#ifndef CURL_DISABLE_PROXY + const char * const pinnedpubkey = Curl_ssl_cf_is_proxy(cf) ? + data->set.str[STRING_SSL_PINNEDPUBLICKEY_PROXY] : + data->set.str[STRING_SSL_PINNEDPUBLICKEY]; +#else + const char * const pinnedpubkey = data->set.str[STRING_SSL_PINNEDPUBLICKEY]; + (void)cf; +#endif + + if(pinnedpubkey) { +#ifdef KEEP_PEER_CERT + const char *x509_der; + int x509_der_len; + struct Curl_X509certificate x509_parsed; + struct Curl_asn1Element *pubkey; + + result = CURLE_SSL_PINNEDPUBKEYNOTMATCH; + + x509 = wolfSSL_get_peer_certificate(wssl->ssl); + if(!x509) { + failf(data, "SSL: failed retrieving server certificate"); + goto end; + } + + x509_der = (const char *)wolfSSL_X509_get_der(x509, &x509_der_len); + if(!x509_der) { + failf(data, "SSL: failed retrieving ASN.1 server certificate"); + goto end; + } + + memset(&x509_parsed, 0, sizeof(x509_parsed)); + if(Curl_parseX509(&x509_parsed, x509_der, x509_der + x509_der_len)) + goto end; + + pubkey = &x509_parsed.subjectPublicKeyInfo; + if(!pubkey->header || pubkey->end <= pubkey->header) { + failf(data, "SSL: failed retrieving public key from server certificate"); + goto end; + } + + result = Curl_pin_peer_pubkey(data, pinnedpubkey, + (const unsigned char *)pubkey->header, + (size_t)(pubkey->end - pubkey->header)); + if(result) + failf(data, "SSL: public key does not match pinned public key"); +#else + failf(data, "Library lacks pinning support built-in"); + return CURLE_NOT_BUILT_IN; +#endif + } +end: + wolfSSL_FreeX509(x509); + return result; +} + +#ifdef WOLFSSL_EARLY_DATA +static CURLcode wssl_send_earlydata(struct Curl_cfilter *cf, + struct Curl_easy *data) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct wssl_ctx *wssl = (struct wssl_ctx *)connssl->backend; + const unsigned char *buf; + size_t blen; + + DEBUGASSERT(connssl->earlydata_state == ssl_earlydata_sending); + wssl->io_result = CURLE_OK; + while(Curl_bufq_peek(&connssl->earlydata, &buf, &blen)) { + int nwritten = 0, rc; + + wolfSSL_ERR_clear_error(); + rc = wolfSSL_write_early_data(wssl->ssl, buf, (int)blen, &nwritten); + CURL_TRC_CF(data, cf, "wolfSSL_write_early_data(len=%zu) -> %d, %d", + blen, rc, nwritten); + if(rc < 0) { + int err = wolfSSL_get_error(wssl->ssl, rc); + char error_buffer[256]; + switch(err) { + case WOLFSSL_ERROR_NONE: /* did not get anything */ + case WOLFSSL_ERROR_WANT_READ: + case WOLFSSL_ERROR_WANT_WRITE: + return CURLE_AGAIN; + } + CURL_TRC_CF(data, cf, "SSL send early data, error: '%s'(%d)", + wssl_strerror((unsigned long)err, error_buffer, + sizeof(error_buffer)), err); + return CURLE_SEND_ERROR; + } + + Curl_bufq_skip(&connssl->earlydata, (size_t)nwritten); + } + /* sent everything there was */ + connssl->earlydata_state = ssl_earlydata_sent; + if(!Curl_ssl_cf_is_proxy(cf)) + Curl_pgrsEarlyData(data, (curl_off_t)connssl->earlydata_skip); + infof(data, "SSL sending %zu bytes of early data", connssl->earlydata_skip); + return CURLE_OK; +} +#endif /* WOLFSSL_EARLY_DATA */ + +static CURLcode wssl_handshake(struct Curl_cfilter *cf, struct Curl_easy *data) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct wssl_ctx *wssl = (struct wssl_ctx *)connssl->backend; + struct ssl_primary_config *conn_config = Curl_ssl_cf_get_primary_config(cf); + int ret = -1, detail; + CURLcode result; + + DEBUGASSERT(wssl); + connssl->io_need = CURL_SSL_IO_NEED_NONE; + +#ifdef WOLFSSL_EARLY_DATA + if(connssl->earlydata_state == ssl_earlydata_sending) { + result = wssl_send_earlydata(cf, data); + if(result) + return result; + } + DEBUGASSERT((connssl->earlydata_state == ssl_earlydata_none) || + (connssl->earlydata_state == ssl_earlydata_sent)); +#else + DEBUGASSERT(connssl->earlydata_state == ssl_earlydata_none); +#endif /* WOLFSSL_EARLY_DATA */ + + wolfSSL_ERR_clear_error(); + ret = wolfSSL_connect(wssl->ssl); + + if(!wssl->x509_store_setup) { + /* After having send off the ClientHello, we prepare the x509 + * store to verify the coming certificate from the server */ + result = Curl_wssl_setup_x509_store(cf, data, wssl); + if(result) { + CURL_TRC_CF(data, cf, "Curl_wssl_setup_x509_store() -> %d", (int)result); + return result; + } + } + +#ifdef OPENSSL_EXTRA + if(Curl_tls_keylog_enabled()) { + /* If key logging is enabled, wait for the handshake to complete and then + * proceed with logging secrets (for TLS 1.2 or older). + * + * During the handshake (ret==-1), wolfSSL_want_read() is true as it waits + * for the server response. At that point the master secret is not yet + * available, so we must not try to read it. + * To log the secret on completion with a handshake failure, detect + * completion via the observation that there is nothing to read or write. + * Note that OpenSSL SSL_want_read() is always true here. If wolfSSL ever + * changes, the worst case is that no key is logged on error. + */ + if(ret == WOLFSSL_SUCCESS || + (!wolfSSL_want_read(wssl->ssl) && + !wolfSSL_want_write(wssl->ssl))) { + wssl_log_tls12_secret(wssl->ssl); + /* Client Random and master secrets are no longer needed, erase these. + * Ignored while the handshake is still in progress. */ + wolfSSL_FreeArrays(wssl->ssl); + } + } +#endif /* OPENSSL_EXTRA */ + + detail = wolfSSL_get_error(wssl->ssl, ret); + CURL_TRC_CF(data, cf, "wolfSSL_connect() -> %d, detail=%d", ret, detail); + + /* On a successful handshake with an IP address, do an extra check + * on the peer certificate */ + if(ret == WOLFSSL_SUCCESS && + conn_config->verifyhost && + !connssl->peer.sni) { + /* we have an IP address as hostname. */ + WOLFSSL_X509 *cert = wolfSSL_get_peer_certificate(wssl->ssl); + if(!cert) { + failf(data, "unable to get peer certificate"); + return CURLE_PEER_FAILED_VERIFICATION; + } + ret = wolfSSL_X509_check_ip_asc(cert, connssl->peer.origin->hostname, 0); + CURL_TRC_CF(data, cf, "check peer certificate for IP match on %s -> %d", + connssl->peer.origin->hostname, ret); + if(ret != WOLFSSL_SUCCESS) + detail = DOMAIN_NAME_MISMATCH; + wolfSSL_X509_free(cert); + } + + if(ret == WOLFSSL_SUCCESS) { + return CURLE_OK; + } + else { + if(WOLFSSL_ERROR_WANT_READ == detail) { + connssl->io_need = CURL_SSL_IO_NEED_RECV; + return CURLE_AGAIN; + } + else if(WOLFSSL_ERROR_WANT_WRITE == detail) { + connssl->io_need = CURL_SSL_IO_NEED_SEND; + return CURLE_AGAIN; + } + else if(DOMAIN_NAME_MISMATCH == detail) { + /* There is no easy way to override only the CN matching. + * This enables the override of both mismatching SubjectAltNames + * as also mismatching CN fields */ + failf(data, " subject alt name(s) or common name do not match \"%s\"", + connssl->peer.origin->hostname); + return CURLE_PEER_FAILED_VERIFICATION; + } + else if(ASN_NO_SIGNER_E == detail) { + if(conn_config->verifypeer) { + failf(data, " CA signer not available for verification"); + return CURLE_SSL_CACERT_BADFILE; + } + /* Continue with a warning if no strict certificate + verification is required. */ + infof(data, "CA signer not available for verification, " + "continuing anyway"); + return CURLE_OK; + } + else if(ASN_AFTER_DATE_E == detail) { + failf(data, "server verification failed: certificate has expired."); + return CURLE_PEER_FAILED_VERIFICATION; + } + else if(ASN_BEFORE_DATE_E == detail) { + failf(data, "server verification failed: certificate not valid yet."); + return CURLE_PEER_FAILED_VERIFICATION; + } + else if(wssl->io_result) { + switch(wssl->io_result) { + case CURLE_SEND_ERROR: + case CURLE_RECV_ERROR: + return CURLE_SSL_CONNECT_ERROR; + default: + return wssl->io_result; + } + } +#ifdef HAVE_WOLFSSL_CTX_GENERATEECHCONFIG + else if(detail == -1) { + /* try access a retry_config ECHConfigList for tracing */ + byte echConfigs[1000]; + word32 echConfigsLen = 1000; + int rv = 0; + + /* this currently does not produce the retry_configs */ + rv = wolfSSL_GetEchConfigs(wssl->ssl, echConfigs, &echConfigsLen); + if(rv != WOLFSSL_SUCCESS) { + infof(data, "Failed to get ECHConfigs"); + } + else { + char *b64str = NULL; + size_t blen = 0; + + result = curlx_base64_encode(echConfigs, echConfigsLen, + &b64str, &blen); + if(!result && b64str) + infof(data, "ECH: (not yet) retry_configs %s", b64str); + curlx_free(b64str); + } + return CURLE_SSL_CONNECT_ERROR; + } +#endif + else { + char error_buffer[256]; + failf(data, "SSL_connect failed with error %d: %s", detail, + wssl_strerror((unsigned long)detail, error_buffer, + sizeof(error_buffer))); + return CURLE_SSL_CONNECT_ERROR; + } + } +} + +static CURLcode wssl_send(struct Curl_cfilter *cf, + struct Curl_easy *data, + const void *buf, size_t blen, + size_t *pnwritten) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct wssl_ctx *wssl = (struct wssl_ctx *)connssl->backend; + CURLcode result = CURLE_OK; + int nwritten; + + DEBUGASSERT(wssl); + *pnwritten = 0; + wolfSSL_ERR_clear_error(); + + if(blen) { + int memlen = (blen > (size_t)INT_MAX) ? INT_MAX : (int)blen; + + nwritten = wolfSSL_write(wssl->ssl, buf, memlen); + + if(nwritten > 0) + *pnwritten += (size_t)nwritten; + else { + int err = wolfSSL_get_error(wssl->ssl, nwritten); + + switch(err) { + case WOLFSSL_ERROR_WANT_READ: + case WOLFSSL_ERROR_WANT_WRITE: + /* there is data pending, re-invoke wolfSSL_write() */ + if(*pnwritten) { + result = CURLE_OK; + goto out; + } + result = CURLE_AGAIN; + goto out; + + default: + if(wssl->io_result == CURLE_AGAIN) { + if(*pnwritten) { + result = CURLE_OK; + goto out; + } + result = CURLE_AGAIN; + goto out; + } + { + char error_buffer[256]; + failf(data, "SSL write: %s, errno %d", + wssl_strerror((unsigned long)err, error_buffer, + sizeof(error_buffer)), + SOCKERRNO); + } + result = CURLE_SEND_ERROR; + goto out; + } + } + } + +out: + CURL_TRC_CF(data, cf, "wssl_send(len=%zu) -> %d, %zu", + blen, (int)result, *pnwritten); + return result; +} + +static CURLcode wssl_shutdown(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool send_shutdown, bool *done) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct wssl_ctx *wctx = (struct wssl_ctx *)connssl->backend; + CURLcode result = CURLE_OK; + char buf[1024]; + int nread = -1, err; + size_t i; + VERBOSE(char error_buffer[256]); + + DEBUGASSERT(wctx); + if(!wctx->ssl || cf->shutdown) { + *done = TRUE; + goto out; + } + + wctx->shutting_down = TRUE; + connssl->io_need = CURL_SSL_IO_NEED_NONE; + *done = FALSE; + if(!(wolfSSL_get_shutdown(wctx->ssl) & WOLFSSL_SENT_SHUTDOWN)) { + /* We have not started the shutdown from our side yet. Check + * if the server already sent us one. */ + wolfSSL_ERR_clear_error(); + nread = wolfSSL_read(wctx->ssl, buf, (int)sizeof(buf)); + err = wolfSSL_get_error(wctx->ssl, nread); + CURL_TRC_CF(data, cf, "wolfSSL_read, nread=%d, err=%d", nread, err); + if(!nread && err == WOLFSSL_ERROR_ZERO_RETURN) { + bool input_pending; + /* Yes, it did. */ + if(!send_shutdown) { + CURL_TRC_CF(data, cf, "SSL shutdown received, not sending"); + *done = TRUE; + goto out; + } + else if(!cf->next->cft->is_alive(cf->next, data, &input_pending)) { + /* Server closed the connection after its closy notify. It + * seems not interested to see our close notify, so do not + * send it. We are done. */ + CURL_TRC_CF(data, cf, "peer closed connection"); + connssl->peer_closed = TRUE; + *done = TRUE; + goto out; + } + } + } + + /* wolfSSL should now have started the shutdown from our side. Since it + * was not complete, we are lacking the close notify from the server. */ + if(send_shutdown) { + wolfSSL_ERR_clear_error(); + nread = wolfSSL_shutdown(wctx->ssl); + if(nread == 1) { + CURL_TRC_CF(data, cf, "SSL shutdown finished"); + *done = TRUE; + goto out; + } + if(WOLFSSL_ERROR_WANT_WRITE == wolfSSL_get_error(wctx->ssl, nread)) { + CURL_TRC_CF(data, cf, "SSL shutdown still wants to send"); + connssl->io_need = CURL_SSL_IO_NEED_SEND; + goto out; + } + /* Having sent the close notify, we use wolfSSL_read() to get the + * missing close notify from the server. */ + } + + for(i = 0; i < 10; ++i) { + wolfSSL_ERR_clear_error(); + nread = wolfSSL_read(wctx->ssl, buf, (int)sizeof(buf)); + if(nread <= 0) + break; + } + err = wolfSSL_get_error(wctx->ssl, nread); + switch(err) { + case WOLFSSL_ERROR_ZERO_RETURN: /* no more data */ + CURL_TRC_CF(data, cf, "SSL shutdown received"); + *done = TRUE; + break; + case WOLFSSL_ERROR_NONE: /* did not get anything */ + case WOLFSSL_ERROR_WANT_READ: + /* wolfSSL has send its notify and now wants to read the reply + * from the server. We are not really interested in that. */ + CURL_TRC_CF(data, cf, "SSL shutdown sent, want receive"); + connssl->io_need = CURL_SSL_IO_NEED_RECV; + break; + case WOLFSSL_ERROR_WANT_WRITE: + CURL_TRC_CF(data, cf, "SSL shutdown send blocked"); + connssl->io_need = CURL_SSL_IO_NEED_SEND; + break; + default: + CURL_TRC_CF(data, cf, "SSL shutdown, error: '%s'(%d)", + wssl_strerror((unsigned long)err, error_buffer, + sizeof(error_buffer)), + err); + result = CURLE_RECV_ERROR; + break; + } + +out: + cf->shutdown = (result || *done); + return result; +} + +static void wssl_close(struct Curl_cfilter *cf, struct Curl_easy *data) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct wssl_ctx *wssl = (struct wssl_ctx *)connssl->backend; + + (void)data; + + DEBUGASSERT(wssl); + + if(wssl->ssl) { + wolfSSL_free(wssl->ssl); + wssl->ssl = NULL; + } + if(wssl->ssl_ctx) { + wolfSSL_CTX_free(wssl->ssl_ctx); + wssl->ssl_ctx = NULL; + } +} + +static CURLcode wssl_recv(struct Curl_cfilter *cf, + struct Curl_easy *data, + char *buf, size_t blen, + size_t *pnread) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct wssl_ctx *wssl = (struct wssl_ctx *)connssl->backend; + int buffsize = (blen > (size_t)INT_MAX) ? INT_MAX : (int)blen; + int nread; + + DEBUGASSERT(wssl); + + *pnread = 0; + wolfSSL_ERR_clear_error(); + + nread = wolfSSL_read(wssl->ssl, buf, buffsize); + + if(nread > 0) + *pnread = (size_t)nread; + else { + int err = wolfSSL_get_error(wssl->ssl, nread); + + switch(err) { + case WOLFSSL_ERROR_ZERO_RETURN: /* no more data */ + CURL_TRC_CF(data, cf, "wssl_recv(len=%zu) -> CLOSED", blen); + return CURLE_OK; + case WOLFSSL_ERROR_NONE: + case WOLFSSL_ERROR_WANT_READ: + case WOLFSSL_ERROR_WANT_WRITE: + if(!wssl->io_result && !connssl->peer_closed) { + /* there is data pending, re-invoke wolfSSL_read() */ + CURL_TRC_CF(data, cf, "wssl_recv(len=%zu) -> AGAIN", blen); + return CURLE_AGAIN; + } + /* fall through to default error handling below */ + FALLTHROUGH(); + default: + if(wssl->io_result == CURLE_AGAIN) { + CURL_TRC_CF(data, cf, "wssl_recv(len=%zu) -> AGAIN", blen); + return CURLE_AGAIN; + } + else if(!wssl->io_result && connssl->peer_closed) { + CURL_TRC_CF(data, cf, "wssl_recv(len=%zu) -> CLOSED", blen); + failf(data, "Connection closed abruptly"); + } + else { + char error_buffer[256]; + failf(data, "SSL read: %s, errno %d", + wssl_strerror((unsigned long)err, error_buffer, + sizeof(error_buffer)), + SOCKERRNO); + } + return CURLE_RECV_ERROR; + } + } + + CURL_TRC_CF(data, cf, "wssl_recv(len=%zu) -> 0, %zu", blen, *pnread); + return CURLE_OK; +} + +size_t Curl_wssl_version(char *buffer, size_t size) +{ + return curl_msnprintf(buffer, size, "wolfSSL/%s", wolfSSL_lib_version()); +} + +static int wssl_init(void) +{ + int ret; + +#ifdef OPENSSL_EXTRA + Curl_tls_keylog_open(); +#endif + ret = (wolfSSL_Init() == WOLFSSL_SUCCESS); + if(ret) + ret = wssl_bio_cf_init_methods(); + return ret; +} + +static void wssl_cleanup(void) +{ + wssl_bio_cf_free_methods(); + wolfSSL_Cleanup(); +#ifdef OPENSSL_EXTRA + Curl_tls_keylog_close(); +#endif +} + +static bool wssl_data_pending(struct Curl_cfilter *cf, + const struct Curl_easy *data) +{ + struct ssl_connect_data *ctx = cf->ctx; + struct wssl_ctx *wssl; + + (void)data; + DEBUGASSERT(ctx && ctx->backend); + + wssl = (struct wssl_ctx *)ctx->backend; + if(wssl->ssl) /* wolfSSL is in use */ + return wolfSSL_pending(wssl->ssl); + else + return FALSE; +} + +void Curl_wssl_report_handshake(struct Curl_easy *data, struct wssl_ctx *wssl) +{ + (void)wssl; + infof(data, "SSL connection using %s / %s", + wolfSSL_get_version(wssl->ssl), + wolfSSL_get_cipher_name(wssl->ssl)); +} + +static CURLcode wssl_connect(struct Curl_cfilter *cf, + struct Curl_easy *data, + bool *done) +{ + struct ssl_connect_data *connssl = cf->ctx; + struct wssl_ctx *wssl = (struct wssl_ctx *)connssl->backend; + CURLcode result = CURLE_OK; + + /* check if the connection has already been established */ + if(ssl_connection_complete == connssl->state) { + *done = TRUE; + return CURLE_OK; + } + + *done = FALSE; + connssl->io_need = CURL_SSL_IO_NEED_NONE; + + if(ssl_connect_1 == connssl->connecting_state) { +#ifdef HAVE_WOLFSSL_CTX_GENERATEECHCONFIG + /* if we do ECH and need the HTTPS-RR information for it, + * we delay the connect until it arrives or DNS resolve fails. */ + if(Curl_wssl_need_httpsrr(data) && + !Curl_conn_dns_resolved_https(data, cf->sockindex, + connssl->peer.peer)) { + CURL_TRC_CF(data, cf, "need HTTPS-RR for ECH, delaying connect"); + return CURLE_OK; + } +#endif /* HAVE_WOLFSSL_CTX_GENERATEECHCONFIG */ + result = wssl_connect_step1(cf, data); + if(result) + return result; + connssl->connecting_state = ssl_connect_2; + } + + if(ssl_connect_2 == connssl->connecting_state) { + if(connssl->earlydata_state == ssl_earlydata_await) { + /* We defer the handshake until request data arrives. */ + DEBUGASSERT(connssl->state == ssl_connection_deferred); + goto out; + } + result = wssl_handshake(cf, data); + if(result == CURLE_AGAIN) + goto out; + wssl->hs_result = result; + connssl->connecting_state = ssl_connect_3; + } + + if(ssl_connect_3 == connssl->connecting_state) { + /* Once the handshake has errored, it stays in that state and + * errors again on every call. */ + if(wssl->hs_result) { + result = wssl->hs_result; + goto out; + } + result = Curl_wssl_verify_pinned(cf, data, wssl); + if(result) { + wssl->hs_result = result; + goto out; + } + /* handshake was done without errors */ +#ifdef HAVE_ALPN + if(connssl->alpn) { + int rc; + char *protocol = NULL; + unsigned short protocol_len = 0; + + rc = wolfSSL_ALPN_GetProtocol(wssl->ssl, &protocol, &protocol_len); + + if(rc == WOLFSSL_SUCCESS) { + Curl_alpn_set_negotiated(cf, data, connssl, + (const unsigned char *)protocol, + protocol_len); + } + else if(rc == WOLFSSL_ALPN_NOT_FOUND) + Curl_alpn_set_negotiated(cf, data, connssl, NULL, 0); + else { + failf(data, "ALPN, failure getting protocol, error %d", rc); + wssl->hs_result = result = CURLE_SSL_CONNECT_ERROR; + goto out; + } + } +#endif /* HAVE_ALPN */ + + connssl->connecting_state = ssl_connect_done; + connssl->state = ssl_connection_complete; + Curl_wssl_report_handshake(data, wssl); + +#ifdef WOLFSSL_EARLY_DATA + if(connssl->earlydata_state > ssl_earlydata_none) { + /* We should be in this state by now */ + DEBUGASSERT(connssl->earlydata_state == ssl_earlydata_sent); + connssl->earlydata_state = + (wolfSSL_get_early_data_status(wssl->ssl) == + WOLFSSL_EARLY_DATA_REJECTED) ? + ssl_earlydata_rejected : ssl_earlydata_accepted; + } +#endif /* WOLFSSL_EARLY_DATA */ + } + + if((connssl->connecting_state == ssl_connect_done) || + (connssl->state == ssl_connection_deferred)) { + *done = TRUE; + } + +out: + if(result) { + *done = FALSE; + if(result == CURLE_AGAIN) + return CURLE_OK; + } + else if((connssl->connecting_state == ssl_connect_done) || + (connssl->state == ssl_connection_deferred)) { + *done = TRUE; + } + return result; +} + +static CURLcode wssl_random(struct Curl_easy *data, + unsigned char *entropy, size_t length) +{ + WC_RNG rng; + (void)data; + if(wc_InitRng(&rng)) + return CURLE_FAILED_INIT; + if(length > UINT_MAX) + return CURLE_FAILED_INIT; + if(wc_RNG_GenerateBlock(&rng, entropy, (unsigned)length)) + return CURLE_FAILED_INIT; + if(wc_FreeRng(&rng)) + return CURLE_FAILED_INIT; + return CURLE_OK; +} + +static CURLcode wssl_sha256sum(const unsigned char *input, + size_t len, + unsigned char *sha256sum /* output */, + size_t unused) +{ + wc_Sha256 SHA256pw; + (void)unused; + if(wc_InitSha256(&SHA256pw)) + return CURLE_FAILED_INIT; + do { + word32 ilen = (word32)CURLMIN(len, UINT32_MAX); + if(wc_Sha256Update(&SHA256pw, input, ilen)) + return CURLE_BAD_FUNCTION_ARGUMENT; + len -= ilen; + input += ilen; + } while(len); + if(wc_Sha256Final(&SHA256pw, sha256sum)) + return CURLE_BAD_FUNCTION_ARGUMENT; + return CURLE_OK; +} + +static void *wssl_get_internals(struct ssl_connect_data *connssl, + CURLINFO info) +{ + struct wssl_ctx *wssl = (struct wssl_ctx *)connssl->backend; + DEBUGASSERT(wssl); + return info == CURLINFO_TLS_SESSION ? + (void *)wssl->ssl_ctx : (void *)wssl->ssl; +} + +const struct Curl_ssl Curl_ssl_wolfssl = { + { CURLSSLBACKEND_WOLFSSL, "wolfssl" }, /* info */ + +#ifdef KEEP_PEER_CERT + SSLSUPP_PINNEDPUBKEY | +#endif +#ifdef USE_BIO_CHAIN + SSLSUPP_HTTPS_PROXY | +#endif + SSLSUPP_CA_PATH | + SSLSUPP_CAINFO_BLOB | +#ifdef HAVE_WOLFSSL_CTX_GENERATEECHCONFIG + SSLSUPP_ECH | +#endif + SSLSUPP_SSL_CTX | +#ifdef WOLFSSL_TLS13 + SSLSUPP_TLS13_CIPHERSUITES | +#endif + SSLSUPP_CA_CACHE | + SSLSUPP_CIPHER_LIST | + SSLSUPP_SSL_EC_CURVES, + + sizeof(struct wssl_ctx), + + wssl_init, /* init */ + wssl_cleanup, /* cleanup */ + Curl_wssl_version, /* version */ + wssl_shutdown, /* shutdown */ + wssl_data_pending, /* data_pending */ + wssl_random, /* random */ + NULL, /* cert_status_request */ + wssl_connect, /* connect */ + Curl_ssl_adjust_pollset, /* adjust_pollset */ + wssl_get_internals, /* get_internals */ + wssl_close, /* close_one */ + NULL, /* close_all */ + NULL, /* set_engine */ + NULL, /* set_engine_default */ + NULL, /* engines_list */ + wssl_sha256sum, /* sha256sum */ + wssl_recv, /* recv decrypted data */ + wssl_send, /* send data to encrypt */ + NULL, /* get_channel_binding */ +}; + +#endif diff --git a/3rdparty/curl-8.21.0/lib/vtls/wolfssl.h b/3rdparty/curl-8.21.0/lib/vtls/wolfssl.h new file mode 100644 index 0000000000..2490bf3e9c --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vtls/wolfssl.h @@ -0,0 +1,101 @@ +#ifndef HEADER_CURL_WOLFSSL_H +#define HEADER_CURL_WOLFSSL_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#ifdef USE_WOLFSSL + +#include "urldata.h" + +#include + +struct alpn_spec; +struct ssl_peer; +struct Curl_ssl_session; + +struct WOLFSSL; +struct WOLFSSL_CTX; +struct WOLFSSL_SESSION; + +extern const struct Curl_ssl Curl_ssl_wolfssl; + +struct wssl_ctx { + struct WOLFSSL_CTX *ssl_ctx; + struct WOLFSSL *ssl; + CURLcode io_result; /* result of last BIO cfilter operation */ + CURLcode hs_result; /* result of handshake */ + int io_send_blocked_len; /* length of last BIO write that EAGAIN-ed */ + BIT(x509_store_setup); /* x509 store has been set up */ + BIT(shutting_down); /* TLS is being shut down */ +}; + +size_t Curl_wssl_version(char *buffer, size_t size); + +typedef CURLcode Curl_wssl_ctx_setup_cb(struct Curl_cfilter *cf, + struct Curl_easy *data, + void *user_data); + +typedef CURLcode Curl_wssl_init_session_reuse_cb(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct alpn_spec *alpns, + struct Curl_ssl_session *scs, + bool *do_early_data); + +CURLcode Curl_wssl_ctx_init(struct wssl_ctx *wctx, + struct Curl_cfilter *cf, + struct Curl_easy *data, + struct ssl_peer *peer, + const struct alpn_spec *alpns_requested, + Curl_wssl_ctx_setup_cb *cb_setup, + void *cb_user_data, + void *ssl_user_data, + Curl_wssl_init_session_reuse_cb *sess_reuse_cb); + +/* Is a resolved HTTPS-RR needed for initializing wolfSSL? */ +bool Curl_wssl_need_httpsrr(struct Curl_easy *data); + +CURLcode Curl_wssl_setup_x509_store(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct wssl_ctx *wssl); + +#ifdef HAVE_EX_DATA +CURLcode Curl_wssl_cache_session(struct Curl_cfilter *cf, + struct Curl_easy *data, + const char *ssl_peer_key, + struct WOLFSSL_SESSION *session, + int ietf_tls_id, + const char *alpn, + unsigned char *quic_tp, + size_t quic_tp_len); +#endif + +CURLcode Curl_wssl_verify_pinned(struct Curl_cfilter *cf, + struct Curl_easy *data, + struct wssl_ctx *wssl); + +void Curl_wssl_report_handshake(struct Curl_easy *data, struct wssl_ctx *wssl); + +#endif /* USE_WOLFSSL */ +#endif /* HEADER_CURL_WOLFSSL_H */ diff --git a/3rdparty/curl-8.21.0/lib/vtls/x509asn1.c b/3rdparty/curl-8.21.0/lib/vtls/x509asn1.c new file mode 100644 index 0000000000..4c5dac3e8b --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vtls/x509asn1.c @@ -0,0 +1,1271 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if defined(USE_GNUTLS) || defined(USE_WOLFSSL) || defined(USE_SCHANNEL) || \ + defined(USE_MBEDTLS) || defined(USE_RUSTLS) + +#if defined(USE_GNUTLS) || defined(USE_SCHANNEL) || defined(USE_MBEDTLS) || \ + defined(USE_WOLFSSL) || defined(USE_RUSTLS) +#define WANT_PARSEX509 /* uses Curl_parseX509() */ +#endif + +#if defined(USE_GNUTLS) || defined(USE_SCHANNEL) || defined(USE_MBEDTLS) || \ + defined(USE_RUSTLS) +#define WANT_EXTRACT_CERTINFO /* uses Curl_extract_certinfo() */ +#endif + +#include "urldata.h" +#include "vtls/vtls.h" +#include "curl_trc.h" +#include "curlx/base64.h" +#include "vtls/x509asn1.h" +#include "curlx/dynbuf.h" + +/* + * Constants. + */ + +/* Largest supported ASN.1 structure. */ +#define CURL_ASN1_MAX ((size_t)0x40000) /* 256K */ + +#ifdef WANT_EXTRACT_CERTINFO + +/* ASN.1 OID table entry. */ +struct Curl_OID { + const char *numoid; /* Dotted-numeric OID. */ + const char *textoid; /* OID name. */ +}; + +/* ASN.1 OIDs. */ +static const struct Curl_OID OIDtable[] = { + { "1.2.840.10040.4.1", "dsa" }, + { "1.2.840.10040.4.3", "dsa-with-sha1" }, + { "1.2.840.10045.2.1", "ecPublicKey" }, + { "1.2.840.10045.3.0.1", "c2pnb163v1" }, + { "1.2.840.10045.4.1", "ecdsa-with-SHA1" }, + { "1.2.840.10045.4.3.1", "ecdsa-with-SHA224" }, + { "1.2.840.10045.4.3.2", "ecdsa-with-SHA256" }, + { "1.2.840.10045.4.3.3", "ecdsa-with-SHA384" }, + { "1.2.840.10045.4.3.4", "ecdsa-with-SHA512" }, + { "1.2.840.10046.2.1", "dhpublicnumber" }, + { "1.2.840.113549.1.1.1", "rsaEncryption" }, + { "1.2.840.113549.1.1.2", "md2WithRSAEncryption" }, + { "1.2.840.113549.1.1.4", "md5WithRSAEncryption" }, + { "1.2.840.113549.1.1.5", "sha1WithRSAEncryption" }, + { "1.2.840.113549.1.1.10", "RSASSA-PSS" }, + { "1.2.840.113549.1.1.14", "sha224WithRSAEncryption" }, + { "1.2.840.113549.1.1.11", "sha256WithRSAEncryption" }, + { "1.2.840.113549.1.1.12", "sha384WithRSAEncryption" }, + { "1.2.840.113549.1.1.13", "sha512WithRSAEncryption" }, + { "1.2.840.113549.2.2", "md2" }, + { "1.2.840.113549.2.5", "md5" }, + { "1.3.14.3.2.26", "sha1" }, + { "2.5.4.3", "CN" }, + { "2.5.4.4", "SN" }, + { "2.5.4.5", "serialNumber" }, + { "2.5.4.6", "C" }, + { "2.5.4.7", "L" }, + { "2.5.4.8", "ST" }, + { "2.5.4.9", "streetAddress" }, + { "2.5.4.10", "O" }, + { "2.5.4.11", "OU" }, + { "2.5.4.12", "title" }, + { "2.5.4.13", "description" }, + { "2.5.4.17", "postalCode" }, + { "2.5.4.41", "name" }, + { "2.5.4.42", "givenName" }, + { "2.5.4.43", "initials" }, + { "2.5.4.44", "generationQualifier" }, + { "2.5.4.45", "X500UniqueIdentifier" }, + { "2.5.4.46", "dnQualifier" }, + { "2.5.4.65", "pseudonym" }, + { "1.2.840.113549.1.9.1", "emailAddress" }, + { "2.5.4.72", "role" }, + { "2.5.29.17", "subjectAltName" }, + { "2.5.29.18", "issuerAltName" }, + { "2.5.29.19", "basicConstraints" }, + { "2.16.840.1.101.3.4.2.4", "sha224" }, + { "2.16.840.1.101.3.4.2.1", "sha256" }, + { "2.16.840.1.101.3.4.2.2", "sha384" }, + { "2.16.840.1.101.3.4.2.3", "sha512" }, + { "1.2.840.113549.1.9.2", "unstructuredName" }, + { NULL, NULL } +}; + +#endif /* WANT_EXTRACT_CERTINFO */ + +/* + * Lightweight ASN.1 parser. + * In particular, it does not check for syntactic/lexical errors. + * It is intended to support certificate information gathering for SSL backends + * that offer a mean to get certificates as a whole, but do not supply + * entry points to get particular certificate sub-fields. + * Please note there is no pretension here to rewrite a full SSL library. + */ + +#define CURL_ASN1_MAX_RECURSIONS 16 + +static const char *getASN1Element_(struct Curl_asn1Element *elem, + const char *beg, const char *end, + size_t lvl) +{ + unsigned char b; + size_t len; + struct Curl_asn1Element lelem; + + /* Get a single ASN.1 element into `elem', parse ASN.1 string at `beg' + ending at `end'. + Returns a pointer in source string after the parsed element, or NULL + if an error occurs. */ + if(!beg || !end || beg >= end || !*beg || + ((size_t)(end - beg) > CURL_ASN1_MAX) || + lvl >= CURL_ASN1_MAX_RECURSIONS) + return NULL; + + /* Process header byte. */ + elem->header = beg; + b = (unsigned char)*beg++; + elem->constructed = (b & 0x20) != 0; + elem->eclass = (b >> 6) & 3; + b &= 0x1F; + if(b == 0x1F) + return NULL; /* Long tag values not supported here. */ + elem->tag = b; + + /* Process length. */ + if(beg >= end) + return NULL; + b = (unsigned char)*beg++; + if(!(b & 0x80)) + len = b; + else { + b &= 0x7F; + if(!b) { + /* Unspecified length. Since we have all the data, we can determine the + effective length by skipping element until an end element is found. */ + if(!elem->constructed) + return NULL; + elem->beg = beg; + while(beg < end && *beg) { + beg = getASN1Element_(&lelem, beg, end, lvl + 1); + if(!beg) + return NULL; + } + if(beg >= end) + return NULL; + elem->end = beg; + return beg + 1; + } + else if((unsigned)b > (size_t)(end - beg)) + return NULL; /* Does not fit in source. */ + else { + /* Get long length. */ + len = 0; + do { + if(len & 0xFF000000L) + return NULL; /* Lengths > 32 bits are not supported. */ + len = (len << 8) | (unsigned char) *beg++; + } while(--b); + } + } + if(len > (size_t)(end - beg)) + return NULL; /* Element data does not fit in source. */ + elem->beg = beg; + elem->end = beg + len; + return elem->end; +} + +/* + * @unittest 1657 + */ +UNITTEST const char *getASN1Element(struct Curl_asn1Element *elem, + const char *beg, const char *end); +UNITTEST const char *getASN1Element(struct Curl_asn1Element *elem, + const char *beg, const char *end) +{ + return getASN1Element_(elem, beg, end, 0); +} + +#ifdef WANT_EXTRACT_CERTINFO + +/* + * Search the null-terminated OID or OID identifier in local table. + * Return the table entry pointer or NULL if not found. + */ +static const struct Curl_OID *searchOID(const char *oid) +{ + const struct Curl_OID *op; + for(op = OIDtable; op->numoid; op++) + if(!strcmp(op->numoid, oid) || curl_strequal(op->textoid, oid)) + return op; + + return NULL; +} + +/* + * Convert an ASN.1 Boolean value into its string representation. + * + * Return error code. + */ + +static CURLcode bool2str(struct dynbuf *store, + const char *beg, const char *end) +{ + uint8_t val; + if(end - beg != 1) + return CURLE_BAD_FUNCTION_ARGUMENT; + val = (uint8_t)*beg; + if((val != 0xff) && (val != 0x00)) + return CURLE_BAD_FUNCTION_ARGUMENT; + return curlx_dyn_add(store, val ? "TRUE" : "FALSE"); +} + +/* + * Convert an ASN.1 octet string to a printable string. + * + * Return error code. + */ +static CURLcode octet2str(struct dynbuf *store, + const char *beg, const char *end) +{ + CURLcode result = CURLE_OK; + + while(!result && beg < end) + result = curlx_dyn_addf(store, "%02x:", (unsigned char)*beg++); + + return result; +} + +static CURLcode bit2str(struct dynbuf *store, const char *beg, const char *end) +{ + /* Convert an ASN.1 bit string to a printable string. */ + + if(beg < end) { + uint8_t unused_bits = (uint8_t)*beg++; + if(unused_bits > 7) + return CURLE_BAD_FUNCTION_ARGUMENT; + } + else + return CURLE_BAD_FUNCTION_ARGUMENT; + return octet2str(store, beg, end); +} + +/* + * Convert an ASN.1 integer value into its string representation. + * + * Returns error. + */ +static CURLcode int2str(struct dynbuf *store, const char *beg, const char *end) +{ + uint32_t uval = 0; + int32_t sval = 0; + size_t n = end - beg; + size_t i; + const unsigned char *p = (const unsigned char *)beg; + + if(!n) + return CURLE_BAD_FUNCTION_ARGUMENT; + + if(n > 4) + return octet2str(store, beg, end); + + if(p[0] & 0x80) + uval = ~0U; + + for(i = 0; i < n; i++) + uval = (uval << 8) | p[i]; + + sval = (int32_t)uval; + + /* small values are easier to read as decimals */ + if(sval > -10000 && sval < 10000) + return curlx_dyn_addf(store, "%d", sval); + + /* represent larger values as hex */ + return curlx_dyn_addf(store, "0x%x", uval); +} + +/* + * Convert from an ASN.1 typed string to UTF8. + * + * The result is stored in a dynbuf that is inited by the user of this + * function. + * + * Returns error. + */ +static CURLcode utf8asn1str(struct dynbuf *to, int type, const char *from, + const char *end) +{ + size_t inlength = end - from; + int size = 1; + CURLcode result = CURLE_OK; + + switch(type) { + case CURL_ASN1_BMP_STRING: + size = 2; + break; + case CURL_ASN1_UNIVERSAL_STRING: + size = 4; + break; + case CURL_ASN1_NUMERIC_STRING: + case CURL_ASN1_PRINTABLE_STRING: + case CURL_ASN1_TELETEX_STRING: + case CURL_ASN1_IA5_STRING: + case CURL_ASN1_VISIBLE_STRING: + case CURL_ASN1_UTF8_STRING: + break; + default: + return CURLE_BAD_FUNCTION_ARGUMENT; /* Conversion not supported. */ + } + + if(inlength % size) + /* Length inconsistent with character size. */ + return CURLE_BAD_FUNCTION_ARGUMENT; + + if(type == CURL_ASN1_UTF8_STRING) { + /* copy. */ + if(inlength) + result = curlx_dyn_addn(to, from, inlength); + } + else { + while(!result && (from < end)) { + char buf[4]; /* decode buffer */ + size_t charsize = 1; + unsigned int wc = 0; + + switch(size) { + case 4: + wc = (wc << 8) | *(const unsigned char *)from++; + wc = (wc << 8) | *(const unsigned char *)from++; + FALLTHROUGH(); + case 2: + wc = (wc << 8) | *(const unsigned char *)from++; + FALLTHROUGH(); + default: /* case 1: */ + wc = (wc << 8) | *(const unsigned char *)from++; + } + if(wc >= 0x00000080) { + if(wc >= 0x00000800) { + if(wc >= 0x00010000) { + if(wc >= 0x00200000) { + /* Invalid char. size for target encoding. */ + return CURLE_WEIRD_SERVER_REPLY; + } + buf[3] = (char)(0x80 | (wc & 0x3F)); + wc = (wc >> 6) | 0x00010000; + charsize++; + } + buf[2] = (char)(0x80 | (wc & 0x3F)); + wc = (wc >> 6) | 0x00000800; + charsize++; + } + buf[1] = (char)(0x80 | (wc & 0x3F)); + wc = (wc >> 6) | 0x000000C0; + charsize++; + } + buf[0] = (char)wc; + result = curlx_dyn_addn(to, buf, charsize); + } + } + return result; +} + +/* + * Convert an ASN.1 OID into its dotted string representation. Each field is + * limited to unsigned 32-bit values. + * + * A minor limitation is in the second number, which can be no larger than 32 + * bits - 80 == 4294967215. + * + * Return error code. + * + * @unittest 1666 + */ +UNITTEST CURLcode encodeOID(struct dynbuf *store, + const char *beg, const char *end); +UNITTEST CURLcode encodeOID(struct dynbuf *store, + const char *beg, const char *end) +{ + uint32_t x; + uint32_t y; + CURLcode result = CURLE_OK; + + if(end <= beg) + return CURLE_BAD_FUNCTION_ARGUMENT; + + /* Process the first two numbers. The initial digit cannot be larger than + 2 */ + y = *(const unsigned char *)beg++; + if(y <= 80) + x = y / 40; + else + x = 2; + result = curlx_dyn_addf(store, "%u", x); + if(result) + return result; + + if(y & 0x80) { + uint32_t t = (y & 0x7f); /* the second number */ + if(!t) + /* reject leading 0x80 padding */ + return CURLE_BAD_FUNCTION_ARGUMENT; + do { + if((t & 0xFE000000) || (beg >= end)) + return CURLE_BAD_FUNCTION_ARGUMENT; + y = *(const unsigned char *)beg++; + t = (t << 7) | (y & 0x7F); + } while(y & 0x80); + y = t; + } + + result = curlx_dyn_addf(store, ".%u", y - (x * 40)); + if(result) + return result; + + /* Process the trailing numbers. */ + while((beg < end) && !result) { + x = 0; + y = 0; + do { + /* 0x80 as the first value is invalid since it only adds padding */ + if((y & 0x80) && !x) + return CURLE_BAD_FUNCTION_ARGUMENT; + else if((x & 0xFE000000) || (beg == end)) + return CURLE_BAD_FUNCTION_ARGUMENT; + y = *(const unsigned char *)beg++; + x = (x << 7) | (y & 0x7F); + } while(y & 0x80); + result = curlx_dyn_addf(store, ".%u", x); + } + return result; +} + +/* + * Convert an ASN.1 OID into its dotted or symbolic string representation. + * + * Return error code. + */ + +static CURLcode OID2str(struct dynbuf *store, + const char *beg, const char *end) +{ + CURLcode result = CURLE_OK; + if(beg < end) { + struct dynbuf buf; + curlx_dyn_init(&buf, CURL_X509_STR_MAX); + result = encodeOID(&buf, beg, end); + + if(!result) { + const struct Curl_OID *op = searchOID(curlx_dyn_ptr(&buf)); + if(op) + result = curlx_dyn_add(store, op->textoid); + else + result = curlx_dyn_add(store, curlx_dyn_ptr(&buf)); + } + curlx_dyn_free(&buf); + } + return result; +} + +/* + * @unittest 1656 + */ +UNITTEST CURLcode GTime2str(struct dynbuf *store, + const char *beg, const char *end); +UNITTEST CURLcode GTime2str(struct dynbuf *store, + const char *beg, const char *end) +{ + const char *tzp; + const char *fracp; + char sec1, sec2; + size_t fracl; + size_t tzl; + const char *sep = ""; + + /* Convert an ASN.1 Generalized time to a printable string. + Return the dynamically allocated string, or NULL if an error occurs. */ + + for(fracp = beg; fracp < end && ISDIGIT(*fracp); fracp++) + ; + + /* Get seconds digits. */ + sec1 = '0'; + switch(fracp - beg - 12) { + case 0: + sec2 = '0'; + break; + case 2: + sec1 = fracp[-2]; + FALLTHROUGH(); + case 1: + sec2 = fracp[-1]; + break; + default: + return CURLE_BAD_FUNCTION_ARGUMENT; + } + + /* timezone follows optional fractional seconds. */ + tzp = fracp; + fracl = 0; /* no fractional seconds detected so far */ + if(fracp < end && (*fracp == '.' || *fracp == ',')) { + /* Have fractional seconds, e.g. "[.,]\d+". How many? */ + fracp++; /* should be a digit char or BAD ARGUMENT */ + tzp = fracp; + while(tzp < end && ISDIGIT(*tzp)) + tzp++; + if(tzp == fracp) /* never looped, no digit after [.,] */ + return CURLE_BAD_FUNCTION_ARGUMENT; + fracl = tzp - fracp; /* number of fractional sec digits */ + DEBUGASSERT(fracl > 0); + /* Strip trailing zeroes in fractional seconds. + * May reduce fracl to 0 if only '0's are present. */ + while(fracl && fracp[fracl - 1] == '0') + fracl--; + } + + /* Process timezone. */ + if(tzp >= end) { + tzp = ""; + tzl = 0; + } + else if(*tzp == 'Z') { + sep = " "; + tzp = "GMT"; + tzl = 3; + } + else if((*tzp == '+') || (*tzp == '-')) { + sep = " UTC"; + tzl = end - tzp; + } + else { + sep = " "; + tzl = end - tzp; + } + + return curlx_dyn_addf(store, + "%.4s-%.2s-%.2s %.2s:%.2s:%c%c%s%.*s%s%.*s", + beg, beg + 4, beg + 6, + beg + 8, beg + 10, sec1, sec2, + fracl ? "." : "", (int)fracl, fracp, + sep, (int)tzl, tzp); +} + +/* + * Convert an ASN.1 UTC time to a printable string. + * + * Return error code. + */ +static CURLcode UTime2str(struct dynbuf *store, + const char *beg, const char *end) +{ + const char *tzp; + size_t tzl; + const char *sec; + + for(tzp = beg; tzp < end && *tzp >= '0' && *tzp <= '9'; tzp++) + ; + /* Get the seconds. */ + sec = beg + 10; + switch(tzp - sec) { + case 0: + sec = "00"; + FALLTHROUGH(); + case 2: + break; + default: + return CURLE_BAD_FUNCTION_ARGUMENT; + } + + /* Process timezone. */ + if(tzp >= end) + return CURLE_BAD_FUNCTION_ARGUMENT; + if(*tzp == 'Z') { + tzp = "GMT"; + end = tzp + 3; + } + + tzl = end - tzp; + return curlx_dyn_addf(store, "%d%.2s-%.2s-%.2s %.2s:%.2s:%.2s %.*s", + 20 - (*beg >= '5'), beg, beg + 2, beg + 4, + beg + 6, beg + 8, sec, + (int)tzl, tzp); +} + +/* + * Convert an ASN.1 element to a printable string. + * + * Return error + * + * @unittest 1667 + */ +UNITTEST CURLcode ASN1tostr(struct dynbuf *store, + struct Curl_asn1Element *elem); +UNITTEST CURLcode ASN1tostr(struct dynbuf *store, + struct Curl_asn1Element *elem) +{ + CURLcode result = CURLE_BAD_FUNCTION_ARGUMENT; + int type = elem->tag; + if(elem->constructed) + return result; /* No conversion of structured elements. */ + + switch(type) { + case CURL_ASN1_BOOLEAN: + result = bool2str(store, elem->beg, elem->end); + break; + case CURL_ASN1_INTEGER: + case CURL_ASN1_ENUMERATED: + result = int2str(store, elem->beg, elem->end); + break; + case CURL_ASN1_BIT_STRING: + result = bit2str(store, elem->beg, elem->end); + break; + case CURL_ASN1_OCTET_STRING: + result = octet2str(store, elem->beg, elem->end); + break; + case CURL_ASN1_NULL: + result = curlx_dyn_addn(store, "", 1); + break; + case CURL_ASN1_OBJECT_IDENTIFIER: + result = OID2str(store, elem->beg, elem->end); + break; + case CURL_ASN1_UTC_TIME: + result = UTime2str(store, elem->beg, elem->end); + break; + case CURL_ASN1_GENERALIZED_TIME: + result = GTime2str(store, elem->beg, elem->end); + break; + case CURL_ASN1_UTF8_STRING: + case CURL_ASN1_NUMERIC_STRING: + case CURL_ASN1_PRINTABLE_STRING: + case CURL_ASN1_TELETEX_STRING: + case CURL_ASN1_IA5_STRING: + case CURL_ASN1_VISIBLE_STRING: + case CURL_ASN1_UNIVERSAL_STRING: + case CURL_ASN1_BMP_STRING: + result = utf8asn1str(store, type, elem->beg, elem->end); + break; + } + + return result; +} + +/* + * ASCII encode distinguished name at `dn' into the store dynbuf. + * + * Returns error. + */ +static CURLcode encodeDN(struct dynbuf *store, struct Curl_asn1Element *dn) +{ + struct Curl_asn1Element rdn; + struct Curl_asn1Element atv; + struct Curl_asn1Element oid; + struct Curl_asn1Element value; + const char *p1; + const char *p2; + const char *p3; + const char *str; + CURLcode result = CURLE_OK; + bool added = FALSE; + struct dynbuf temp; + curlx_dyn_init(&temp, CURL_X509_STR_MAX); + + for(p1 = dn->beg; p1 < dn->end;) { + p1 = getASN1Element(&rdn, p1, dn->end); + if(!p1) { + result = CURLE_BAD_FUNCTION_ARGUMENT; + goto error; + } + for(p2 = rdn.beg; p2 < rdn.end;) { + p2 = getASN1Element(&atv, p2, rdn.end); + if(!p2) { + result = CURLE_BAD_FUNCTION_ARGUMENT; + goto error; + } + p3 = getASN1Element(&oid, atv.beg, atv.end); + if(!p3) { + result = CURLE_BAD_FUNCTION_ARGUMENT; + goto error; + } + if(!getASN1Element(&value, p3, atv.end)) { + result = CURLE_BAD_FUNCTION_ARGUMENT; + goto error; + } + curlx_dyn_reset(&temp); + result = ASN1tostr(&temp, &oid); + if(result) + goto error; + + str = curlx_dyn_ptr(&temp); + + if(!str) { + result = CURLE_BAD_FUNCTION_ARGUMENT; + goto error; + } + + /* Encode delimiter. + If attribute has a short uppercase name, delimiter is ", ". */ + for(p3 = str; ISUPPER(*p3); p3++) + ; + if(added) { + if(p3 - str > 2) + result = curlx_dyn_addn(store, "/", 1); + else + result = curlx_dyn_addn(store, ", ", 2); + if(result) + goto error; + } + + /* Encode attribute name. */ + result = curlx_dyn_add(store, str); + if(result) + goto error; + + /* Generate equal sign. */ + result = curlx_dyn_addn(store, "=", 1); + if(result) + goto error; + + /* Generate value. */ + result = ASN1tostr(store, &value); + if(result) + goto error; + curlx_dyn_reset(&temp); + added = TRUE; /* use separator for next */ + } + } +error: + curlx_dyn_free(&temp); + + return result; +} + +#endif /* WANT_EXTRACT_CERTINFO */ + +#ifdef WANT_PARSEX509 +/* + * ASN.1 parse an X509 certificate into structure subfields. + * Syntax is assumed to have already been checked by the SSL backend. + * See RFC 5280. + */ +int Curl_parseX509(struct Curl_X509certificate *cert, + const char *beg, const char *end) +{ + struct Curl_asn1Element elem; + struct Curl_asn1Element tbsCertificate; + const char *ccp; + static const char defaultVersion = 0; /* v1. */ + + cert->certificate.header = NULL; + cert->certificate.beg = beg; + cert->certificate.end = end; + + /* Get the sequence content. */ + if(!getASN1Element(&elem, beg, end)) + return -1; /* Invalid bounds/size. */ + beg = elem.beg; + end = elem.end; + + /* Get tbsCertificate. */ + beg = getASN1Element(&tbsCertificate, beg, end); + if(!beg) + return -1; + /* Skip the signatureAlgorithm. */ + beg = getASN1Element(&cert->signatureAlgorithm, beg, end); + if(!beg) + return -1; + /* Get the signatureValue. */ + if(!getASN1Element(&cert->signature, beg, end)) + return -1; + + /* Parse TBSCertificate. */ + beg = tbsCertificate.beg; + end = tbsCertificate.end; + /* Get optional version, get serialNumber. */ + cert->version.header = NULL; + cert->version.beg = &defaultVersion; + cert->version.end = &defaultVersion + sizeof(defaultVersion); + beg = getASN1Element(&elem, beg, end); + if(!beg) + return -1; + if(elem.tag == 0) { + if(!getASN1Element(&cert->version, elem.beg, elem.end)) + return -1; + beg = getASN1Element(&elem, beg, end); + if(!beg) + return -1; + } + cert->serialNumber = elem; + /* Get signature algorithm. */ + beg = getASN1Element(&cert->signatureAlgorithm, beg, end); + /* Get issuer. */ + beg = getASN1Element(&cert->issuer, beg, end); + if(!beg) + return -1; + /* Get notBefore and notAfter. */ + beg = getASN1Element(&elem, beg, end); + if(!beg) + return -1; + ccp = getASN1Element(&cert->notBefore, elem.beg, elem.end); + if(!ccp) + return -1; + if(!getASN1Element(&cert->notAfter, ccp, elem.end)) + return -1; + /* Get subject. */ + beg = getASN1Element(&cert->subject, beg, end); + if(!beg) + return -1; + /* Get subjectPublicKeyAlgorithm and subjectPublicKey. */ + beg = getASN1Element(&cert->subjectPublicKeyInfo, beg, end); + if(!beg) + return -1; + ccp = getASN1Element(&cert->subjectPublicKeyAlgorithm, + cert->subjectPublicKeyInfo.beg, + cert->subjectPublicKeyInfo.end); + if(!ccp) + return -1; + if(!getASN1Element(&cert->subjectPublicKey, ccp, + cert->subjectPublicKeyInfo.end)) + return -1; + /* Get optional issuerUniqueID, subjectUniqueID and extensions. */ + cert->issuerUniqueID.tag = cert->subjectUniqueID.tag = 0; + cert->extensions.tag = elem.tag = 0; + cert->issuerUniqueID.header = cert->subjectUniqueID.header = NULL; + cert->issuerUniqueID.beg = cert->issuerUniqueID.end = ""; + cert->subjectUniqueID.beg = cert->subjectUniqueID.end = ""; + cert->extensions.header = NULL; + cert->extensions.beg = cert->extensions.end = ""; + if(beg < end) { + beg = getASN1Element(&elem, beg, end); + if(!beg) + return -1; + } + if(elem.tag == 1) { + cert->issuerUniqueID = elem; + if(beg < end) { + beg = getASN1Element(&elem, beg, end); + if(!beg) + return -1; + } + } + if(elem.tag == 2) { + cert->subjectUniqueID = elem; + if(beg < end) { + beg = getASN1Element(&elem, beg, end); + if(!beg) + return -1; + } + } + if(elem.tag == 3) + if(!getASN1Element(&cert->extensions, elem.beg, elem.end)) + return -1; + return 0; +} + +#endif /* WANT_PARSEX509 */ + +#ifdef WANT_EXTRACT_CERTINFO + +static CURLcode dumpAlgo(struct dynbuf *store, + struct Curl_asn1Element *param, + const char *beg, const char *end) +{ + struct Curl_asn1Element oid; + + /* Get algorithm parameters and return algorithm name. */ + + beg = getASN1Element(&oid, beg, end); + if(!beg) + return CURLE_BAD_FUNCTION_ARGUMENT; + param->header = NULL; + param->tag = 0; + param->beg = param->end = end; + if(beg < end) { + const char *p = getASN1Element(param, beg, end); + if(!p) + return CURLE_BAD_FUNCTION_ARGUMENT; + } + return OID2str(store, oid.beg, oid.end); +} + +/* + * This is a convenience function for push_certinfo_len that takes a zero + * terminated value. + */ +static CURLcode ssl_push_certinfo(struct Curl_easy *data, + int certnum, + const char *label, + const char *value) +{ + size_t valuelen = strlen(value); + + return Curl_ssl_push_certinfo_len(data, certnum, label, value, valuelen); +} + +/* + * This is a convenience function for push_certinfo_len that takes a + * dynbuf value. + * + * It also does the verbose output if !certnum. + */ +static CURLcode ssl_push_certinfo_dyn(struct Curl_easy *data, + int certnum, + const char *label, + struct dynbuf *ptr) +{ + size_t valuelen = curlx_dyn_len(ptr); + const char *value = curlx_dyn_ptr(ptr); + + CURLcode result = Curl_ssl_push_certinfo_len(data, certnum, label, + value, valuelen); + + if(!certnum && !result) + infof(data, " %s: %s", label, value); + + return result; +} + +static CURLcode do_pubkey_field(struct Curl_easy *data, int certnum, + const char *label, + struct Curl_asn1Element *elem) +{ + CURLcode result; + struct dynbuf out; + + curlx_dyn_init(&out, CURL_X509_STR_MAX); + + /* Generate a certificate information record for the public key. */ + + result = ASN1tostr(&out, elem); + if(!result) { + if(data->set.ssl.certinfo) + result = ssl_push_certinfo_dyn(data, certnum, label, &out); + curlx_dyn_free(&out); + } + return result; +} + +/* return 0 on success, 1 on error */ +static int do_pubkey(struct Curl_easy *data, int certnum, const char *algo, + struct Curl_asn1Element *param, + struct Curl_asn1Element *pubkey) +{ + struct Curl_asn1Element elem; + struct Curl_asn1Element pk; + const char *p; + + /* Generate all information records for the public key. */ + + if(curl_strequal(algo, "ecPublicKey")) { + /* + * ECC public key is all the data, a value of type BIT STRING mapped to + * OCTET STRING and should not be parsed as an ASN.1 value. + */ + const size_t dlen = pubkey->end - pubkey->beg; + size_t len; + if(dlen < 2) + /* too small */ + return 1; + len = (dlen - 2) * 4; + if(!certnum) + infof(data, " ECC Public Key (%zu bits)", len); + if(data->set.ssl.certinfo) { + char q[(sizeof(len) * 8 / 3) + 1]; + (void)curl_msnprintf(q, sizeof(q), "%zu", len); + if(ssl_push_certinfo(data, certnum, "ECC Public Key", q)) + return 1; + } + return do_pubkey_field(data, certnum, "ecPublicKey", pubkey) == CURLE_OK + ? 0 : 1; + } + + /* Get the public key (single element). */ + if(!getASN1Element(&pk, pubkey->beg + 1, pubkey->end)) + return 1; + + if(curl_strequal(algo, "rsaEncryption")) { + const char *q; + size_t len; + + p = getASN1Element(&elem, pk.beg, pk.end); + if(!p) + return 1; + + /* Compute key length. */ + for(q = elem.beg; q < elem.end && !*q; q++) + ; + len = ((elem.end - q) * 8); + if(len) { + unsigned int i; + for(i = *(const unsigned char *)q; !(i & 0x80); i <<= 1) + len--; + } + if(len > 32) + elem.beg = q; /* Strip leading zero bytes. */ + if(!certnum) + infof(data, " RSA Public Key (%zu bits)", len); + if(data->set.ssl.certinfo) { + char r[(sizeof(len) * 8 / 3) + 1]; + curl_msnprintf(r, sizeof(r), "%zu", len); + if(ssl_push_certinfo(data, certnum, "RSA Public Key", r)) + return 1; + } + /* Generate coefficients. */ + if(do_pubkey_field(data, certnum, "rsa(n)", &elem)) + return 1; + if(!getASN1Element(&elem, p, pk.end)) + return 1; + if(do_pubkey_field(data, certnum, "rsa(e)", &elem)) + return 1; + } + else if(curl_strequal(algo, "dsa")) { + p = getASN1Element(&elem, param->beg, param->end); + if(p) { + if(do_pubkey_field(data, certnum, "dsa(p)", &elem)) + return 1; + p = getASN1Element(&elem, p, param->end); + if(p) { + if(do_pubkey_field(data, certnum, "dsa(q)", &elem)) + return 1; + if(getASN1Element(&elem, p, param->end)) { + if(do_pubkey_field(data, certnum, "dsa(g)", &elem)) + return 1; + if(do_pubkey_field(data, certnum, "dsa(pub_key)", &pk)) + return 1; + } + } + } + } + else if(curl_strequal(algo, "dhpublicnumber")) { + p = getASN1Element(&elem, param->beg, param->end); + if(p) { + if(do_pubkey_field(data, certnum, "dh(p)", &elem)) + return 1; + if(getASN1Element(&elem, p, param->end)) { + if(do_pubkey_field(data, certnum, "dh(g)", &elem)) + return 1; + if(do_pubkey_field(data, certnum, "dh(pub_key)", &pk)) + return 1; + } + } + } + return 0; +} + +/* + * Convert an ASN.1 distinguished name into a printable string. + * Return error. + */ +static CURLcode DNtostr(struct dynbuf *store, struct Curl_asn1Element *dn) +{ + return encodeDN(store, dn); +} + +CURLcode Curl_extract_certinfo(struct Curl_easy *data, + int certnum, + const char *beg, + const char *end) +{ + struct Curl_X509certificate cert; + struct Curl_asn1Element param; + char *certptr; + size_t clen; + struct dynbuf out; + CURLcode result = CURLE_OK; + unsigned int version; + const char *ptr; + int rc; + + if(!data->set.ssl.certinfo) + if(certnum) + return CURLE_OK; + + curlx_dyn_init(&out, CURL_X509_STR_MAX); + /* Prepare the certificate information for curl_easy_getinfo(). */ + + /* Extract the certificate ASN.1 elements. */ + if(Curl_parseX509(&cert, beg, end)) + return CURLE_PEER_FAILED_VERIFICATION; + + /* Subject. */ + result = DNtostr(&out, &cert.subject); + if(result) + goto done; + if(data->set.ssl.certinfo) { + result = ssl_push_certinfo_dyn(data, certnum, "Subject", &out); + if(result) + goto done; + } + curlx_dyn_reset(&out); + + /* Issuer. */ + result = DNtostr(&out, &cert.issuer); + if(result) + goto done; + if(data->set.ssl.certinfo) { + result = ssl_push_certinfo_dyn(data, certnum, "Issuer", &out); + if(result) + goto done; + } + curlx_dyn_reset(&out); + + /* Version (always fits in less than 32 bits). */ + version = 0; + for(ptr = cert.version.beg; ptr < cert.version.end; ptr++) + version = (version << 8) | *(const unsigned char *)ptr; + if(data->set.ssl.certinfo) { + result = curlx_dyn_addf(&out, "%x", version); + if(result) + goto done; + result = ssl_push_certinfo_dyn(data, certnum, "Version", &out); + if(result) + goto done; + curlx_dyn_reset(&out); + } + + /* Serial number. */ + result = ASN1tostr(&out, &cert.serialNumber); + if(result) + goto done; + if(data->set.ssl.certinfo) { + result = ssl_push_certinfo_dyn(data, certnum, "Serial Number", &out); + if(result) + goto done; + } + curlx_dyn_reset(&out); + + /* Signature algorithm .*/ + result = dumpAlgo(&out, ¶m, cert.signatureAlgorithm.beg, + cert.signatureAlgorithm.end); + if(result) + goto done; + if(data->set.ssl.certinfo) { + result = ssl_push_certinfo_dyn(data, certnum, "Signature Algorithm", &out); + if(result) + goto done; + } + curlx_dyn_reset(&out); + + /* Start Date. */ + result = ASN1tostr(&out, &cert.notBefore); + if(result) + goto done; + if(data->set.ssl.certinfo) { + result = ssl_push_certinfo_dyn(data, certnum, "Start Date", &out); + if(result) + goto done; + } + curlx_dyn_reset(&out); + + /* Expire Date. */ + result = ASN1tostr(&out, &cert.notAfter); + if(result) + goto done; + if(data->set.ssl.certinfo) { + result = ssl_push_certinfo_dyn(data, certnum, "Expire Date", &out); + if(result) + goto done; + } + curlx_dyn_reset(&out); + + /* Public Key Algorithm. */ + result = dumpAlgo(&out, ¶m, cert.subjectPublicKeyAlgorithm.beg, + cert.subjectPublicKeyAlgorithm.end); + if(result) + goto done; + if(data->set.ssl.certinfo) { + result = ssl_push_certinfo_dyn(data, certnum, "Public Key Algorithm", + &out); + if(result) + goto done; + } + + rc = do_pubkey(data, certnum, curlx_dyn_ptr(&out), + ¶m, &cert.subjectPublicKey); + if(rc) { + result = CURLE_OUT_OF_MEMORY; /* the most likely error */ + goto done; + } + curlx_dyn_reset(&out); + + /* Signature. */ + result = ASN1tostr(&out, &cert.signature); + if(result) + goto done; + if(data->set.ssl.certinfo) { + result = ssl_push_certinfo_dyn(data, certnum, "Signature", &out); + if(result) + goto done; + } + curlx_dyn_reset(&out); + + /* Generate PEM certificate. */ + result = curlx_base64_encode((const uint8_t *)cert.certificate.beg, + cert.certificate.end - cert.certificate.beg, + &certptr, &clen); + if(result) + goto done; + + /* Generate the final output certificate string. Format is: + -----BEGIN CERTIFICATE-----\n + \n + . + . + . + -----END CERTIFICATE-----\n + */ + + curlx_dyn_reset(&out); + + /* Build the certificate string. */ + result = curlx_dyn_add(&out, "-----BEGIN CERTIFICATE-----\n"); + if(!result) { + size_t j = 0; + + while(!result && (j < clen)) { + size_t chunksize = (clen - j) > 64 ? 64 : (clen - j); + result = curlx_dyn_addn(&out, &certptr[j], chunksize); + if(!result) + result = curlx_dyn_addn(&out, "\n", 1); + j += chunksize; + } + if(!result) + result = curlx_dyn_add(&out, "-----END CERTIFICATE-----\n"); + } + curlx_free(certptr); + if(!result) + if(data->set.ssl.certinfo) + result = ssl_push_certinfo_dyn(data, certnum, "Cert", &out); + +done: + if(result) + failf(data, "Failed extracting certificate chain"); + curlx_dyn_free(&out); + return result; +} + +#endif /* WANT_EXTRACT_CERTINFO */ + +#endif /* USE_GNUTLS || USE_WOLFSSL || USE_SCHANNEL || USE_MBEDTLS || + USE_RUSTLS */ diff --git a/3rdparty/curl-8.21.0/lib/vtls/x509asn1.h b/3rdparty/curl-8.21.0/lib/vtls/x509asn1.h new file mode 100644 index 0000000000..dda55ac77f --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/vtls/x509asn1.h @@ -0,0 +1,119 @@ +#ifndef HEADER_CURL_X509ASN1_H +#define HEADER_CURL_X509ASN1_H + +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +/* forward-declare to make it visible in all builds */ +struct Curl_asn1Element; + +#if defined(USE_GNUTLS) || defined(USE_WOLFSSL) || defined(USE_SCHANNEL) || \ + defined(USE_MBEDTLS) || defined(USE_RUSTLS) + +#include "cfilters.h" +#include "urldata.h" + +/* ASN.1 classes. */ +/* #define CURL_ASN1_UNIVERSAL 0 */ +/* #define CURL_ASN1_APPLICATION 1 */ +/* #define CURL_ASN1_CONTEXT_SPECIFIC 2 */ +/* #define CURL_ASN1_PRIVATE 3 */ + +/* ASN.1 types. */ +#define CURL_ASN1_BOOLEAN 1 +#define CURL_ASN1_INTEGER 2 +#define CURL_ASN1_BIT_STRING 3 +#define CURL_ASN1_OCTET_STRING 4 +#define CURL_ASN1_NULL 5 +#define CURL_ASN1_OBJECT_IDENTIFIER 6 +/* #define CURL_ASN1_OBJECT_DESCRIPTOR 7 */ +/* #define CURL_ASN1_INSTANCE_OF 8 */ +/* #define CURL_ASN1_REAL 9 */ +#define CURL_ASN1_ENUMERATED 10 +/* #define CURL_ASN1_EMBEDDED 11 */ +#define CURL_ASN1_UTF8_STRING 12 +/* #define CURL_ASN1_RELATIVE_OID 13 */ +/* #define CURL_ASN1_SEQUENCE 16 */ +/* #define CURL_ASN1_SET 17 */ +#define CURL_ASN1_NUMERIC_STRING 18 +#define CURL_ASN1_PRINTABLE_STRING 19 +#define CURL_ASN1_TELETEX_STRING 20 +/* #define CURL_ASN1_VIDEOTEX_STRING 21 */ +#define CURL_ASN1_IA5_STRING 22 +#define CURL_ASN1_UTC_TIME 23 +#define CURL_ASN1_GENERALIZED_TIME 24 +/* #define CURL_ASN1_GRAPHIC_STRING 25 */ +#define CURL_ASN1_VISIBLE_STRING 26 +/* #define CURL_ASN1_GENERAL_STRING 27 */ +#define CURL_ASN1_UNIVERSAL_STRING 28 +/* #define CURL_ASN1_CHARACTER_STRING 29 */ +#define CURL_ASN1_BMP_STRING 30 + +/* + * Types. + */ + +/* ASN.1 parsed element. */ +struct Curl_asn1Element { + const char *header; /* Pointer to header byte. */ + const char *beg; /* Pointer to element data. */ + const char *end; /* Pointer to 1st byte after element. */ + unsigned char eclass; /* ASN.1 element class. */ + unsigned char tag; /* ASN.1 element tag. */ + BIT(constructed); /* Element is constructed. */ +}; + +/* X509 certificate: RFC 5280. */ +struct Curl_X509certificate { + struct Curl_asn1Element certificate; + struct Curl_asn1Element version; + struct Curl_asn1Element serialNumber; + struct Curl_asn1Element signatureAlgorithm; + struct Curl_asn1Element signature; + struct Curl_asn1Element issuer; + struct Curl_asn1Element notBefore; + struct Curl_asn1Element notAfter; + struct Curl_asn1Element subject; + struct Curl_asn1Element subjectPublicKeyInfo; + struct Curl_asn1Element subjectPublicKeyAlgorithm; + struct Curl_asn1Element subjectPublicKey; + struct Curl_asn1Element issuerUniqueID; + struct Curl_asn1Element subjectUniqueID; + struct Curl_asn1Element extensions; +}; + +/* + * Prototypes. + */ + +int Curl_parseX509(struct Curl_X509certificate *cert, + const char *beg, const char *end); +CURLcode Curl_extract_certinfo(struct Curl_easy *data, int certnum, + const char *beg, const char *end); +CURLcode Curl_verifyhost(struct Curl_cfilter *cf, struct Curl_easy *data, + const char *beg, const char *end); +#endif /* USE_GNUTLS || USE_WOLFSSL || USE_SCHANNEL || USE_MBEDTLS || + USE_RUSTLS */ +#endif /* HEADER_CURL_X509ASN1_H */ diff --git a/3rdparty/curl-8.21.0/lib/ws.c b/3rdparty/curl-8.21.0/lib/ws.c new file mode 100644 index 0000000000..9820c3e4bd --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/ws.c @@ -0,0 +1,1995 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" +#include "urldata.h" +#include "ws.h" + +#ifndef CURL_DISABLE_WEBSOCKETS + +#include "url.h" +#include "bufq.h" +#include "curlx/dynbuf.h" +#include "rand.h" +#include "curlx/base64.h" +#include "cf-recvbuf.h" +#include "connect.h" +#include "sendf.h" +#include "curl_trc.h" +#include "multiif.h" +#include "easyif.h" +#include "transfer.h" +#include "select.h" +#include "curlx/strparse.h" +#include "curlx/strcopy.h" + +/*** + RFC 6455 Section 5.2 + + 0 1 2 3 4 5 6 7 + +-+-+-+-+-------+ + |F|R|R|R| opcode| + |I|S|S|S| (4) | + |N|V|V|V| | + | |1|2|3| | +*/ +#define WSBIT_FIN 0x80 +#define WSBIT_RSV1 0x40 +#define WSBIT_RSV2 0x20 +#define WSBIT_RSV3 0x10 +#define WSBIT_RSV_MASK (WSBIT_RSV1 | WSBIT_RSV2 | WSBIT_RSV3) +#define WSBIT_OPCODE_CONT 0x0 +#define WSBIT_OPCODE_TEXT 0x1 +#define WSBIT_OPCODE_BIN 0x2 +#define WSBIT_OPCODE_CLOSE 0x8 +#define WSBIT_OPCODE_PING 0x9 +#define WSBIT_OPCODE_PONG 0xa +#ifdef CURLVERBOSE +#define WSBIT_OPCODE_MASK 0xf +#endif + +#define WSBIT_MASK 0x80 + +/* buffer dimensioning */ +#define WS_CHUNK_SIZE 65535 +#define WS_CHUNK_COUNT 2 + +/* a client-side WS frame decoder, parsing frame headers and + * payload, keeping track of current position and stats */ +enum ws_dec_state { + WS_DEC_INIT, + WS_DEC_HEAD, + WS_DEC_PAYLOAD +}; + +struct ws_decoder { + int frame_age; /* zero */ + int frame_flags; /* See the CURLWS_* defines */ + curl_off_t payload_offset; /* the offset parsing is at */ + curl_off_t payload_len; + uint8_t head[10]; + int head_len, head_total; + enum ws_dec_state state; + int cont_flags; +}; + +/* a client-side WS frame encoder, generating frame headers and + * converting payloads, tracking remaining data in current frame */ +struct ws_encoder { + curl_off_t payload_len; /* payload length of current frame */ + curl_off_t payload_remain; /* remaining payload of current */ + unsigned int xori; /* xor index */ + uint8_t mask[4]; /* 32-bit mask for this connection */ + uint8_t firstbyte; /* first byte of frame we encode */ + BIT(contfragment); /* set TRUE if the previous fragment sent was not final */ +}; + +/* Control frames are allowed up to 125 characters, rfc6455, ch. 5.5 */ +#define WS_MAX_CNTRL_LEN 125 + +struct ws_cntrl_frame { + unsigned int type; + size_t payload_len; + uint8_t payload[WS_MAX_CNTRL_LEN]; +}; + +/* A websocket connection with en- and decoder that treat frames + * and keep track of boundaries. */ +struct websocket { + struct Curl_easy *data; /* used for write callback handling */ + struct ws_decoder dec; /* decode of ws frames */ + struct ws_encoder enc; /* encode of ws frames */ + struct bufq recvbuf; /* raw data from the server */ + struct bufq sendbuf; /* raw data to be sent to the server */ + struct curl_ws_frame recvframe; /* the current WS FRAME received */ + struct ws_cntrl_frame pending; /* a control frame pending to be sent */ + size_t sendbuf_payload; /* number of payload bytes in sendbuf */ +}; + +#ifdef CURLVERBOSE +static const char *ws_frame_name_of_op(uint8_t firstbyte) +{ + switch(firstbyte & WSBIT_OPCODE_MASK) { + case WSBIT_OPCODE_CONT: + return "CONT"; + case WSBIT_OPCODE_TEXT: + return "TEXT"; + case WSBIT_OPCODE_BIN: + return "BIN"; + case WSBIT_OPCODE_CLOSE: + return "CLOSE"; + case WSBIT_OPCODE_PING: + return "PING"; + case WSBIT_OPCODE_PONG: + return "PONG"; + default: + return "???"; + } +} +#endif + +static int ws_frame_firstbyte2flags(struct Curl_easy *data, + uint8_t firstbyte, int cont_flags) +{ + switch(firstbyte) { + /* 0x00 - intermediate TEXT/BINARY fragment */ + case WSBIT_OPCODE_CONT: + if(!(cont_flags & CURLWS_CONT)) { + failf(data, "[WS] no ongoing fragmented message to resume"); + return 0; + } + return cont_flags | CURLWS_CONT; + /* 0x80 - final TEXT/BIN fragment */ + case (WSBIT_OPCODE_CONT | WSBIT_FIN): + if(!(cont_flags & CURLWS_CONT)) { + failf(data, "[WS] no ongoing fragmented message to resume"); + return 0; + } + return cont_flags & ~CURLWS_CONT; + /* 0x01 - first TEXT fragment */ + case WSBIT_OPCODE_TEXT: + if(cont_flags & CURLWS_CONT) { + failf(data, "[WS] fragmented message interrupted by new TEXT msg"); + return 0; + } + return CURLWS_TEXT | CURLWS_CONT; + /* 0x81 - unfragmented TEXT msg */ + case (WSBIT_OPCODE_TEXT | WSBIT_FIN): + if(cont_flags & CURLWS_CONT) { + failf(data, "[WS] fragmented message interrupted by new TEXT msg"); + return 0; + } + return CURLWS_TEXT; + /* 0x02 - first BINARY fragment */ + case WSBIT_OPCODE_BIN: + if(cont_flags & CURLWS_CONT) { + failf(data, "[WS] fragmented message interrupted by new BINARY msg"); + return 0; + } + return CURLWS_BINARY | CURLWS_CONT; + /* 0x82 - unfragmented BINARY msg */ + case (WSBIT_OPCODE_BIN | WSBIT_FIN): + if(cont_flags & CURLWS_CONT) { + failf(data, "[WS] fragmented message interrupted by new BINARY msg"); + return 0; + } + return CURLWS_BINARY; + /* 0x08 - first CLOSE fragment */ + case WSBIT_OPCODE_CLOSE: + failf(data, "[WS] invalid fragmented CLOSE frame"); + return 0; + /* 0x88 - unfragmented CLOSE */ + case (WSBIT_OPCODE_CLOSE | WSBIT_FIN): + return CURLWS_CLOSE; + /* 0x09 - first PING fragment */ + case WSBIT_OPCODE_PING: + failf(data, "[WS] invalid fragmented PING frame"); + return 0; + /* 0x89 - unfragmented PING */ + case (WSBIT_OPCODE_PING | WSBIT_FIN): + return CURLWS_PING; + /* 0x0a - first PONG fragment */ + case WSBIT_OPCODE_PONG: + failf(data, "[WS] invalid fragmented PONG frame"); + return 0; + /* 0x8a - unfragmented PONG */ + case (WSBIT_OPCODE_PONG | WSBIT_FIN): + return CURLWS_PONG; + /* invalid first byte */ + default: + if(firstbyte & WSBIT_RSV_MASK) + /* any of the reserved bits 0x40/0x20/0x10 are set */ + failf(data, "[WS] invalid reserved bits: %02x", firstbyte); + else + /* any of the reserved opcodes 0x3-0x7 or 0xb-0xf is used */ + failf(data, "[WS] invalid opcode: %02x", firstbyte); + return 0; + } +} + +static CURLcode ws_frame_flags2firstbyte(struct Curl_easy *data, + unsigned int flags, + bool contfragment, + uint8_t *pfirstbyte) +{ + *pfirstbyte = 0; + switch(flags & ~CURLWS_OFFSET) { + case 0: + if(contfragment) { + CURL_TRC_WS(data, "no flags given; interpreting as continuation " + "fragment for compatibility"); + *pfirstbyte = (WSBIT_OPCODE_CONT | WSBIT_FIN); + return CURLE_OK; + } + failf(data, "[WS] no flags given"); + return CURLE_BAD_FUNCTION_ARGUMENT; + case CURLWS_CONT: + if(contfragment) { + infof(data, "[WS] setting CURLWS_CONT flag without message type is " + "supported for compatibility but highly discouraged"); + *pfirstbyte = WSBIT_OPCODE_CONT; + return CURLE_OK; + } + failf(data, "[WS] No ongoing fragmented message to continue"); + return CURLE_BAD_FUNCTION_ARGUMENT; + case CURLWS_TEXT: + *pfirstbyte = contfragment ? (WSBIT_OPCODE_CONT | WSBIT_FIN) + : (WSBIT_OPCODE_TEXT | WSBIT_FIN); + return CURLE_OK; + case (CURLWS_TEXT | CURLWS_CONT): + *pfirstbyte = contfragment ? WSBIT_OPCODE_CONT : WSBIT_OPCODE_TEXT; + return CURLE_OK; + case CURLWS_BINARY: + *pfirstbyte = contfragment ? (WSBIT_OPCODE_CONT | WSBIT_FIN) + : (WSBIT_OPCODE_BIN | WSBIT_FIN); + return CURLE_OK; + case (CURLWS_BINARY | CURLWS_CONT): + *pfirstbyte = contfragment ? WSBIT_OPCODE_CONT : WSBIT_OPCODE_BIN; + return CURLE_OK; + case CURLWS_CLOSE: + *pfirstbyte = WSBIT_OPCODE_CLOSE | WSBIT_FIN; + return CURLE_OK; + case (CURLWS_CLOSE | CURLWS_CONT): + failf(data, "[WS] CLOSE frame must not be fragmented"); + return CURLE_BAD_FUNCTION_ARGUMENT; + case CURLWS_PING: + *pfirstbyte = WSBIT_OPCODE_PING | WSBIT_FIN; + return CURLE_OK; + case (CURLWS_PING | CURLWS_CONT): + failf(data, "[WS] PING frame must not be fragmented"); + return CURLE_BAD_FUNCTION_ARGUMENT; + case CURLWS_PONG: + *pfirstbyte = WSBIT_OPCODE_PONG | WSBIT_FIN; + return CURLE_OK; + case (CURLWS_PONG | CURLWS_CONT): + failf(data, "[WS] PONG frame must not be fragmented"); + return CURLE_BAD_FUNCTION_ARGUMENT; + default: + failf(data, "[WS] unknown flags: %x", flags); + return CURLE_BAD_FUNCTION_ARGUMENT; + } +} + +static void ws_dec_info(struct ws_decoder *dec, struct Curl_easy *data, + const char *msg) +{ + NOVERBOSE((void)msg); + switch(dec->head_len) { + case 0: + break; + case 1: + CURL_TRC_WS(data, "decoded %s [%s%s]", msg, + ws_frame_name_of_op(dec->head[0]), + (dec->head[0] & WSBIT_FIN) ? "" : " NON-FINAL"); + break; + default: + if(dec->head_len < dec->head_total) { + CURL_TRC_WS(data, "decoded %s [%s%s](%d/%d)", msg, + ws_frame_name_of_op(dec->head[0]), + (dec->head[0] & WSBIT_FIN) ? "" : " NON-FINAL", + dec->head_len, dec->head_total); + } + else { + CURL_TRC_WS(data, "decoded %s [%s%s payload=%" + FMT_OFF_T "/%" FMT_OFF_T "]", + msg, ws_frame_name_of_op(dec->head[0]), + (dec->head[0] & WSBIT_FIN) ? "" : " NON-FINAL", + dec->payload_offset, dec->payload_len); + } + break; + } +} + +static CURLcode ws_send_raw_blocking(struct Curl_easy *data, + struct websocket *ws, + const char *buffer, size_t buflen); + +typedef CURLcode ws_write_payload(const uint8_t *buf, size_t buflen, + int frame_age, int frame_flags, + curl_off_t payload_offset, + curl_off_t payload_len, + void *userp, + size_t *pnwritten); + +static void ws_dec_next_frame(struct ws_decoder *dec) +{ + dec->frame_age = 0; + dec->frame_flags = 0; + dec->payload_offset = 0; + dec->payload_len = 0; + dec->head_len = dec->head_total = 0; + dec->state = WS_DEC_INIT; + /* dec->cont_flags must be carried over to next frame */ +} + +static void ws_dec_reset(struct ws_decoder *dec) +{ + dec->frame_age = 0; + dec->frame_flags = 0; + dec->payload_offset = 0; + dec->payload_len = 0; + dec->head_len = dec->head_total = 0; + dec->state = WS_DEC_INIT; + dec->cont_flags = 0; +} + +static void ws_dec_init(struct ws_decoder *dec) +{ + ws_dec_reset(dec); +} + +static CURLcode ws_dec_read_head(struct ws_decoder *dec, + struct Curl_easy *data, + struct bufq *inraw) +{ + const uint8_t *inbuf; + size_t inlen; + + while(Curl_bufq_peek(inraw, &inbuf, &inlen)) { + if(dec->head_len == 0) { + dec->head[0] = *inbuf; + Curl_bufq_skip(inraw, 1); + + dec->frame_flags = ws_frame_firstbyte2flags(data, dec->head[0], + dec->cont_flags); + if(!dec->frame_flags) { + ws_dec_reset(dec); + return CURLE_RECV_ERROR; + } + + /* fragmentation only applies to data frames (text/binary); + * control frames (close/ping/pong) do not affect the CONT status */ + if(dec->frame_flags & (CURLWS_TEXT | CURLWS_BINARY)) { + dec->cont_flags = dec->frame_flags; + } + + dec->head_len = 1; +#if 0 + ws_dec_info(dec, data, "seeing opcode"); +#endif + continue; + } + else if(dec->head_len == 1) { + dec->head[1] = *inbuf; + Curl_bufq_skip(inraw, 1); + dec->head_len = 2; + + if(dec->head[1] & WSBIT_MASK) { + /* A client MUST close a connection if it detects a masked frame. */ + failf(data, "[WS] masked input frame"); + ws_dec_reset(dec); + return CURLE_RECV_ERROR; + } + if(dec->frame_flags & CURLWS_PING && dec->head[1] > WS_MAX_CNTRL_LEN) { + /* The maximum valid size of PING frames is 125 bytes. + Accepting overlong pings would mean sending equivalent pongs! */ + failf(data, "[WS] received PING frame is too big"); + ws_dec_reset(dec); + return CURLE_RECV_ERROR; + } + if(dec->frame_flags & CURLWS_PONG && dec->head[1] > WS_MAX_CNTRL_LEN) { + /* The maximum valid size of PONG frames is 125 bytes. */ + failf(data, "[WS] received PONG frame is too big"); + ws_dec_reset(dec); + return CURLE_RECV_ERROR; + } + if(dec->frame_flags & CURLWS_CLOSE && dec->head[1] > WS_MAX_CNTRL_LEN) { + failf(data, "[WS] received CLOSE frame is too big"); + ws_dec_reset(dec); + return CURLE_RECV_ERROR; + } + + /* How long is the frame head? */ + if(dec->head[1] == 126) { + dec->head_total = 4; + continue; + } + else if(dec->head[1] == 127) { + dec->head_total = 10; + continue; + } + else { + dec->head_total = 2; + } + } + + if(dec->head_len < dec->head_total) { + dec->head[dec->head_len] = *inbuf; + Curl_bufq_skip(inraw, 1); + ++dec->head_len; + if(dec->head_len < dec->head_total) { +#if 0 + ws_dec_info(dec, data, "decoding head"); +#endif + continue; + } + } + /* got the complete frame head */ + DEBUGASSERT(dec->head_len == dec->head_total); + switch(dec->head_total) { + case 2: + dec->payload_len = dec->head[1]; + break; + case 4: + dec->payload_len = (dec->head[2] << 8) | dec->head[3]; + break; + case 10: + if(dec->head[2] > 127) { + failf(data, "[WS] frame length longer than 63 bits not supported"); + return CURLE_RECV_ERROR; + } + dec->payload_len = + (curl_off_t)dec->head[2] << 56 | + (curl_off_t)dec->head[3] << 48 | + (curl_off_t)dec->head[4] << 40 | + (curl_off_t)dec->head[5] << 32 | + (curl_off_t)dec->head[6] << 24 | + (curl_off_t)dec->head[7] << 16 | + (curl_off_t)dec->head[8] << 8 | + dec->head[9]; + break; + default: + /* this should never happen */ + DEBUGASSERT(0); + failf(data, "[WS] unexpected frame header length"); + return CURLE_RECV_ERROR; + } + + dec->frame_age = 0; + dec->payload_offset = 0; + ws_dec_info(dec, data, "decoded"); + return CURLE_OK; + } + return CURLE_AGAIN; +} + +static CURLcode ws_dec_pass_payload(struct ws_decoder *dec, + struct Curl_easy *data, + struct bufq *inraw, + ws_write_payload *write_cb, + void *write_ctx) +{ + const uint8_t *inbuf; + size_t inlen; + size_t nwritten; + CURLcode result; + size_t remain = curlx_sotouz_range(dec->payload_len - dec->payload_offset, + 0, SIZE_MAX); + + while(remain && Curl_bufq_peek(inraw, &inbuf, &inlen)) { + if(inlen > remain) + inlen = remain; + result = write_cb(inbuf, inlen, dec->frame_age, dec->frame_flags, + dec->payload_offset, dec->payload_len, + write_ctx, &nwritten); + if(result) + return result; + Curl_bufq_skip(inraw, nwritten); + dec->payload_offset += nwritten; + remain = curlx_sotouz_range(dec->payload_len - dec->payload_offset, + 0, SIZE_MAX); + CURL_TRC_WS(data, "passed %zu bytes payload, %zu remain", + nwritten, remain); + } + + return remain ? CURLE_AGAIN : CURLE_OK; +} + +static CURLcode ws_dec_pass(struct ws_decoder *dec, + struct Curl_easy *data, + struct bufq *inraw, + ws_write_payload *write_cb, + void *write_ctx) +{ + CURLcode result; + + if(Curl_bufq_is_empty(inraw)) + return CURLE_AGAIN; + + switch(dec->state) { + case WS_DEC_INIT: + ws_dec_next_frame(dec); + dec->state = WS_DEC_HEAD; + FALLTHROUGH(); + case WS_DEC_HEAD: + result = ws_dec_read_head(dec, data, inraw); + if(result) { + if(result != CURLE_AGAIN) { + failf(data, "[WS] decode frame error %d", (int)result); + break; /* real error */ + } + /* incomplete ws frame head */ + DEBUGASSERT(Curl_bufq_is_empty(inraw)); + break; + } + /* head parsing done */ + dec->state = WS_DEC_PAYLOAD; + if(dec->payload_len == 0) { + size_t nwritten; + const uint8_t tmp = '\0'; + /* special case of a 0 length frame, need to write once */ + result = write_cb(&tmp, 0, dec->frame_age, dec->frame_flags, + 0, 0, write_ctx, &nwritten); + if(result) + return result; + dec->state = WS_DEC_INIT; + break; + } + FALLTHROUGH(); + case WS_DEC_PAYLOAD: + result = ws_dec_pass_payload(dec, data, inraw, write_cb, write_ctx); + ws_dec_info(dec, data, "passing"); + if(result) + return result; + /* payload parsing done */ + dec->state = WS_DEC_INIT; + break; + default: + /* we covered all enums above, but some code analyzers are wimps */ + result = CURLE_FAILED_INIT; + } + return result; +} + +static void update_meta(struct websocket *ws, + int frame_age, int frame_flags, + curl_off_t payload_offset, + curl_off_t payload_len, + size_t cur_len) +{ + curl_off_t bytesleft = (payload_len - payload_offset - cur_len); + + ws->recvframe.age = frame_age; + ws->recvframe.flags = frame_flags; + ws->recvframe.offset = payload_offset; + ws->recvframe.len = cur_len; + ws->recvframe.bytesleft = bytesleft; +} + +/* WebSocket decoding client writer */ +struct ws_cw_ctx { + struct Curl_cwriter super; + struct bufq buf; +}; + +static CURLcode ws_cw_init(struct Curl_easy *data, + struct Curl_cwriter *writer) +{ + struct ws_cw_ctx *ctx = writer->ctx; + (void)data; + Curl_bufq_init2(&ctx->buf, WS_CHUNK_SIZE, 1, BUFQ_OPT_SOFT_LIMIT); + return CURLE_OK; +} + +static void ws_cw_close(struct Curl_easy *data, struct Curl_cwriter *writer) +{ + struct ws_cw_ctx *ctx = writer->ctx; + (void)data; + Curl_bufq_free(&ctx->buf); +} + +struct ws_cw_dec_ctx { + struct Curl_easy *data; + struct websocket *ws; + struct Curl_cwriter *next_writer; + int cw_type; +}; + +static CURLcode ws_flush(struct Curl_easy *data, struct websocket *ws, + bool blocking); +static CURLcode ws_enc_send(struct Curl_easy *data, + struct websocket *ws, + const uint8_t *buffer, + size_t buflen, + curl_off_t fragsize, + unsigned int flags, + size_t *pnsent); +static CURLcode ws_enc_add_pending(struct Curl_easy *data, + struct websocket *ws); + +static CURLcode ws_enc_add_cntrl(struct Curl_easy *data, + struct websocket *ws, + const uint8_t *payload, + size_t plen, + unsigned int frame_type) +{ + (void)data; + DEBUGASSERT(plen <= WS_MAX_CNTRL_LEN); + if(plen > WS_MAX_CNTRL_LEN) + return CURLE_BAD_FUNCTION_ARGUMENT; + + /* Overwrite any pending frame with the new one, we keep + * only one. */ + ws->pending.type = frame_type; + ws->pending.payload_len = plen; + memcpy(ws->pending.payload, payload, plen); + return CURLE_OK; +} + +static curl_off_t ws_payload_remain(curl_off_t payload_total, + curl_off_t payload_offset, + size_t payload_buffered) +{ + curl_off_t buffered, remain = payload_total - payload_offset; + if((payload_total < 0) || (payload_offset < 0) || (remain < 0)) + return -1; + buffered = curlx_uztoso(payload_buffered); + if(remain < buffered) + return -1; + return remain - buffered; +} + +static CURLcode ws_cw_dec_next(const uint8_t *buf, size_t buflen, + int frame_age, int frame_flags, + curl_off_t payload_offset, + curl_off_t payload_len, + void *user_data, + size_t *pnwritten) +{ + struct ws_cw_dec_ctx *ctx = user_data; + struct Curl_easy *data = ctx->data; + struct websocket *ws = ctx->ws; + bool auto_pong = !data->set.ws_no_auto_pong; + curl_off_t remain; + CURLcode result; + + (void)frame_age; + *pnwritten = 0; + remain = ws_payload_remain(payload_len, payload_offset, buflen); + if(remain < 0) { + DEBUGASSERT(0); /* parameter mismatch */ + return CURLE_BAD_FUNCTION_ARGUMENT; + } + + if(auto_pong && (frame_flags & CURLWS_PING) && !remain) { + /* auto-respond to PINGs, only works for single-frame payloads atm */ + CURL_TRC_WS(data, "auto PONG to [PING payload=%" FMT_OFF_T + "/%" FMT_OFF_T "]", payload_offset, payload_len); + /* send back the exact same content as a PONG */ + result = ws_enc_add_cntrl(data, ws, buf, buflen, CURLWS_PONG); + if(result) + return result; + } + else if(buflen || !remain) { + /* forward the decoded frame to the next client writer. */ + update_meta(ws, frame_age, frame_flags, payload_offset, + payload_len, buflen); + + result = Curl_cwriter_write(data, ctx->next_writer, + (ctx->cw_type | CLIENTWRITE_0LEN), + (const char *)buf, buflen); + if(result) + return result; + } + *pnwritten = buflen; + return CURLE_OK; +} + +static CURLcode ws_cw_write(struct Curl_easy *data, + struct Curl_cwriter *writer, int type, + const char *buf, size_t nbytes) +{ + struct ws_cw_ctx *ctx = writer->ctx; + struct websocket *ws; + CURLcode result = CURLE_OK; + + CURL_TRC_WRITE(data, "ws_cw_write(len=%zu, type=%d)", nbytes, type); + if(!(type & CLIENTWRITE_BODY) || data->set.ws_raw_mode) + return Curl_cwriter_write(data, writer->next, type, buf, nbytes); + + ws = Curl_conn_meta_get(data->conn, CURL_META_PROTO_WS_CONN); + if(!ws) { + failf(data, "[WS] not a websocket transfer"); + return CURLE_FAILED_INIT; + } + + if(nbytes) { + size_t nwritten; + result = Curl_bufq_write(&ctx->buf, (const uint8_t *)buf, + nbytes, &nwritten); + if(result) { + infof(data, "[WS] error adding data to buffer %d", (int)result); + return result; + } + } + + while(!Curl_bufq_is_empty(&ctx->buf)) { + struct ws_cw_dec_ctx pass_ctx; + pass_ctx.data = data; + pass_ctx.ws = ws; + pass_ctx.next_writer = writer->next; + pass_ctx.cw_type = type; + result = ws_dec_pass(&ws->dec, data, &ctx->buf, + ws_cw_dec_next, &pass_ctx); + if(result == CURLE_AGAIN) { + /* insufficient amount of data, keep it for later. + * we pretend to have written all since we have a copy */ + result = CURLE_OK; + goto out; + } + else if(result) { + failf(data, "[WS] decode payload error %d", (int)result); + return result; + } + } + + if((type & CLIENTWRITE_EOS) && !Curl_bufq_is_empty(&ctx->buf)) { + failf(data, "[WS] decode ending with %zu frame bytes remaining", + Curl_bufq_len(&ctx->buf)); + result = CURLE_RECV_ERROR; + } + +out: + if(!result) { + result = ws_flush(data, ws, Curl_is_in_callback(data)); + if(result == CURLE_AGAIN) + result = CURLE_OK; + } + return result; +} + +/* WebSocket payload decoding client writer. */ +static const struct Curl_cwtype ws_cw_decode = { + "ws-decode", + NULL, + ws_cw_init, + ws_cw_write, + ws_cw_close, + sizeof(struct ws_cw_ctx) +}; + +static void ws_enc_info(struct ws_encoder *enc, struct Curl_easy *data, + const char *msg) +{ + NOVERBOSE((void)enc); + NOVERBOSE((void)msg); + CURL_TRC_WS(data, "WS-ENC: %s [%s%s payload=%" + FMT_OFF_T "/%" FMT_OFF_T "]", + msg, ws_frame_name_of_op(enc->firstbyte), + (enc->firstbyte & WSBIT_FIN) ? "" : " NON-FIN", + enc->payload_len - enc->payload_remain, enc->payload_len); +} + +static void ws_enc_reset(struct ws_encoder *enc) +{ + enc->payload_remain = 0; + enc->xori = 0; + enc->contfragment = FALSE; +} + +static void ws_enc_init(struct ws_encoder *enc) +{ + ws_enc_reset(enc); +} + +/*** + RFC 6455 Section 5.2 + + 0 1 2 3 + 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 + +-+-+-+-+-------+-+-------------+-------------------------------+ + |F|R|R|R| opcode|M| Payload len | Extended payload length | + |I|S|S|S| (4) |A| (7) | (16/64) | + |N|V|V|V| |S| | (if payload len==126/127) | + | |1|2|3| |K| | | + +-+-+-+-+-------+-+-------------+ - - - - - - - - - - - - - - - + + | Extended payload length continued, if payload len == 127 | + + - - - - - - - - - - - - - - - +-------------------------------+ + | |Masking-key, if MASK set to 1 | + +-------------------------------+-------------------------------+ + | Masking-key (continued) | Payload Data | + +-------------------------------- - - - - - - - - - - - - - - - + + : Payload Data continued ... : + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + | Payload Data continued ... | + +---------------------------------------------------------------+ +*/ + +static CURLcode ws_enc_add_frame(struct Curl_easy *data, + struct ws_encoder *enc, + unsigned int flags, + curl_off_t payload_len, + struct bufq *out) +{ + uint8_t firstb = 0; + uint8_t head[14]; + CURLcode result; + size_t hlen, nwritten; + + if(payload_len < 0) { + failf(data, "[WS] starting new frame with negative payload length %" + FMT_OFF_T, payload_len); + return CURLE_SEND_ERROR; + } + + if(enc->payload_remain > 0) { + /* trying to write a new frame before the previous one is finished */ + failf(data, "[WS] starting new frame with %" FMT_OFF_T " bytes " + "from last one remaining to be sent", enc->payload_remain); + return CURLE_SEND_ERROR; + } + + result = ws_frame_flags2firstbyte(data, flags, (bool)enc->contfragment, + &firstb); + if(result) + return result; + + /* fragmentation only applies to data frames (text/binary); + * control frames (close/ping/pong) do not affect the CONT status */ + if(flags & (CURLWS_TEXT | CURLWS_BINARY)) { + enc->contfragment = (curl_bit)((flags & CURLWS_CONT) ? TRUE : FALSE); + } + + if(flags & CURLWS_PING && payload_len > WS_MAX_CNTRL_LEN) { + failf(data, "[WS] given PING frame is too big"); + return CURLE_TOO_LARGE; + } + if(flags & CURLWS_PONG && payload_len > WS_MAX_CNTRL_LEN) { + failf(data, "[WS] given PONG frame is too big"); + return CURLE_TOO_LARGE; + } + if(flags & CURLWS_CLOSE && payload_len > WS_MAX_CNTRL_LEN) { + failf(data, "[WS] given CLOSE frame is too big"); + return CURLE_TOO_LARGE; + } + + head[0] = enc->firstbyte = firstb; + if(payload_len > 65535) { + head[1] = 127 | WSBIT_MASK; + head[2] = (uint8_t)((payload_len >> 56) & 0xff); + head[3] = (uint8_t)((payload_len >> 48) & 0xff); + head[4] = (uint8_t)((payload_len >> 40) & 0xff); + head[5] = (uint8_t)((payload_len >> 32) & 0xff); + head[6] = (uint8_t)((payload_len >> 24) & 0xff); + head[7] = (uint8_t)((payload_len >> 16) & 0xff); + head[8] = (uint8_t)((payload_len >> 8) & 0xff); + head[9] = (uint8_t)(payload_len & 0xff); + hlen = 10; + } + else if(payload_len >= 126) { + head[1] = 126 | WSBIT_MASK; + head[2] = (uint8_t)((payload_len >> 8) & 0xff); + head[3] = (uint8_t)(payload_len & 0xff); + hlen = 4; + } + else { + head[1] = (uint8_t)payload_len | WSBIT_MASK; + hlen = 2; + } + + enc->payload_remain = enc->payload_len = payload_len; + ws_enc_info(enc, data, "sending"); + + /* 4 bytes random */ + + result = Curl_rand(data, (uint8_t *)&enc->mask, sizeof(enc->mask)); + if(result) + return result; + +#ifdef DEBUGBUILD + if(getenv("CURL_WS_FORCE_ZERO_MASK")) + /* force the bit mask to 0x00000000, effectively disabling masking */ + memset(&enc->mask, 0, sizeof(enc->mask)); +#endif + + /* add 4 bytes mask */ + memcpy(&head[hlen], &enc->mask, 4); + hlen += 4; + /* reset for payload to come */ + enc->xori = 0; + + result = Curl_bufq_write(out, head, hlen, &nwritten); + if(result) + return result; + if(nwritten != hlen) { + /* We use a bufq with SOFT_LIMIT, writing should always succeed */ + DEBUGASSERT(0); + return CURLE_SEND_ERROR; + } + return CURLE_OK; +} + +static CURLcode ws_enc_write_head(struct Curl_easy *data, + struct websocket *ws, + struct ws_encoder *enc, + unsigned int flags, + curl_off_t payload_len, + struct bufq *out) +{ + /* starting a new frame, we want a clean sendbuf. + * Any pending control frame we can add now as part of the flush. */ + if(ws->pending.type) { + CURLcode result = ws_enc_add_pending(data, ws); + if(result) + return result; + } + return ws_enc_add_frame(data, enc, flags, payload_len, out); +} + +static CURLcode ws_enc_write_payload(struct ws_encoder *enc, + struct Curl_easy *data, + const uint8_t *buf, size_t buflen, + struct bufq *out, size_t *pnwritten) +{ + CURLcode result; + size_t i, len, n, remain; + + *pnwritten = 0; + if(Curl_bufq_is_full(out)) + return CURLE_AGAIN; + + /* not the most performant way to do this */ + len = buflen; + remain = curlx_sotouz_range(enc->payload_remain, 0, SIZE_MAX); + if(remain < len) + len = remain; + + for(i = 0; i < len; ++i) { + uint8_t c = buf[i] ^ enc->mask[enc->xori]; + result = Curl_bufq_write(out, &c, 1, &n); + if(result) { + if((result != CURLE_AGAIN) || !i) + return result; + break; + } + enc->xori++; + enc->xori &= 3; + } + *pnwritten = i; + enc->payload_remain -= (curl_off_t)i; + ws_enc_info(enc, data, "buffered"); + return CURLE_OK; +} + +static CURLcode ws_enc_add_pending(struct Curl_easy *data, + struct websocket *ws) +{ + CURLcode result; + size_t n; + + if(!ws->pending.type) /* no pending frame here */ + return CURLE_OK; + if(ws->enc.payload_remain) /* in the middle of another frame */ + return CURLE_AGAIN; + + result = ws_enc_add_frame(data, &ws->enc, ws->pending.type, + (curl_off_t)ws->pending.payload_len, + &ws->sendbuf); + if(result) { + CURL_TRC_WS(data, "ws_enc_cntrl(), error adding head: %d", + (int)result); + goto out; + } + result = ws_enc_write_payload(&ws->enc, data, ws->pending.payload, + ws->pending.payload_len, + &ws->sendbuf, &n); + if(result) { + CURL_TRC_WS(data, "ws_enc_cntrl(), error adding payload: %d", + (int)result); + goto out; + } + if(n != ws->pending.payload_len) { + DEBUGASSERT(0); /* buffer should always be able to take all */ + CURL_TRC_WS(data, "ws_enc_cntrl(), error added only %zu/%zu payload,", + n, ws->pending.payload_len); + result = CURLE_SEND_ERROR; + goto out; + } + /* the frame should be complete now */ + DEBUGASSERT(!ws->enc.payload_remain); + memset(&ws->pending, 0, sizeof(ws->pending)); + +out: + return result; +} + +static CURLcode ws_enc_send(struct Curl_easy *data, + struct websocket *ws, + const uint8_t *buffer, + size_t buflen, + curl_off_t fragsize, + unsigned int flags, + size_t *pnsent) +{ + size_t n; + CURLcode result = CURLE_OK; + + DEBUGASSERT(!data->set.ws_raw_mode); + *pnsent = 0; + + if(ws->enc.payload_remain || !Curl_bufq_is_empty(&ws->sendbuf)) { + /* a frame is ongoing with payload buffered or more payload + * that needs to be encoded into the buffer */ + if(buflen < ws->sendbuf_payload) { + /* We have been called with LESS buffer data than before. This + * is not how it is supposed too work. */ + failf(data, "[WS] curl_ws_send() called with smaller 'buflen' than " + "bytes already buffered in previous call, %zu vs %zu", + buflen, ws->sendbuf_payload); + return CURLE_BAD_FUNCTION_ARGUMENT; + } + if((curl_off_t)buflen > + (ws->enc.payload_remain + (curl_off_t)ws->sendbuf_payload)) { + /* too large buflen beyond payload length of frame */ + failf(data, "[WS] unaligned frame size (sending %zu instead of " + "%" FMT_OFF_T ")", buflen, + (curl_off_t)(ws->enc.payload_remain + ws->sendbuf_payload)); + return CURLE_BAD_FUNCTION_ARGUMENT; + } + } + else { + result = ws_flush(data, ws, Curl_is_in_callback(data)); + if(result) + return result; + + result = ws_enc_write_head(data, ws, &ws->enc, flags, + (flags & CURLWS_OFFSET) ? + fragsize : (curl_off_t)buflen, + &ws->sendbuf); + if(result) { + CURL_TRC_WS(data, "curl_ws_send(), error writing frame head %d", + (int)result); + return result; + } + } + + /* While there is either sendbuf to flush OR more payload to encode... */ + while(!Curl_bufq_is_empty(&ws->sendbuf) || (buflen > ws->sendbuf_payload)) { + /* Try to add more payload to sendbuf */ + if(buflen > ws->sendbuf_payload) { + size_t prev_len = Curl_bufq_len(&ws->sendbuf); + result = ws_enc_write_payload(&ws->enc, data, + buffer + ws->sendbuf_payload, + buflen - ws->sendbuf_payload, + &ws->sendbuf, &n); + if(result && (result != CURLE_AGAIN)) + return result; + ws->sendbuf_payload += Curl_bufq_len(&ws->sendbuf) - prev_len; + if(!ws->sendbuf_payload) { + return CURLE_AGAIN; + } + } + + /* flush, blocking when in callback */ + result = ws_flush(data, ws, Curl_is_in_callback(data)); + if(!result && ws->sendbuf_payload > 0) { + *pnsent += ws->sendbuf_payload; + buffer += ws->sendbuf_payload; + buflen -= ws->sendbuf_payload; + ws->sendbuf_payload = 0; + } + else if(result == CURLE_AGAIN) { + if(ws->sendbuf_payload > Curl_bufq_len(&ws->sendbuf)) { + /* blocked, part of payload bytes remain, report length + * that we managed to send. */ + size_t flushed = (ws->sendbuf_payload - Curl_bufq_len(&ws->sendbuf)); + *pnsent += flushed; + ws->sendbuf_payload -= flushed; + return CURLE_OK; + } + else { + /* blocked before sending headers or 1st payload byte. We cannot report + * OK on 0-length send (caller counts only payload) and EAGAIN */ + CURL_TRC_WS(data, "EAGAIN flushing sendbuf, payload_encoded: %zu/%zu", + ws->sendbuf_payload, buflen); + DEBUGASSERT(*pnsent == 0); + return CURLE_AGAIN; + } + } + else + return result; /* real error sending the data */ + } + return CURLE_OK; +} + +struct cr_ws_ctx { + struct Curl_creader super; + BIT(read_eos); /* we read an EOS from the next reader */ + BIT(eos); /* we have returned an EOS */ +}; + +static CURLcode cr_ws_init(struct Curl_easy *data, struct Curl_creader *reader) +{ + (void)data; + (void)reader; + return CURLE_OK; +} + +static void cr_ws_close(struct Curl_easy *data, struct Curl_creader *reader) +{ + (void)data; + (void)reader; +} + +static CURLcode cr_ws_read(struct Curl_easy *data, + struct Curl_creader *reader, + char *buf, size_t blen, + size_t *pnread, bool *peos) +{ + struct cr_ws_ctx *ctx = reader->ctx; + CURLcode result = CURLE_OK; + size_t nread, n; + struct websocket *ws; + bool eos; + + *pnread = 0; + if(ctx->eos) { + *peos = TRUE; + return CURLE_OK; + } + + ws = Curl_conn_meta_get(data->conn, CURL_META_PROTO_WS_CONN); + if(!ws) { + failf(data, "[WS] not a websocket transfer"); + return CURLE_FAILED_INIT; + } + + if(Curl_bufq_is_empty(&ws->sendbuf)) { + if(ctx->read_eos) { + ctx->eos = TRUE; + *peos = TRUE; + return CURLE_OK; + } + + if(ws->enc.payload_remain) { + CURL_TRC_WS(data, "current frame, %" FMT_OFF_T " remaining", + ws->enc.payload_remain); + blen = curlx_sotouz_range(ws->enc.payload_remain, 0, blen); + } + + result = Curl_creader_read(data, reader->next, buf, blen, &nread, &eos); + if(result) + return result; + ctx->read_eos = eos; + + if(!Curl_bufq_is_empty(&ws->sendbuf)) { + /* client_read started a new frame, we disregard any eos reported */ + ctx->read_eos = FALSE; + Curl_creader_clear_eos(data, reader->next); + } + else if(!nread) { + /* nothing to convert, return this right away */ + if(ctx->read_eos) + ctx->eos = TRUE; + *pnread = nread; + *peos = (bool)ctx->eos; + goto out; + } + + if(!ws->enc.payload_remain && Curl_bufq_is_empty(&ws->sendbuf)) { + /* encode the data as a new BINARY frame */ + result = ws_enc_write_head(data, ws, &ws->enc, CURLWS_BINARY, nread, + &ws->sendbuf); + if(result) + goto out; + } + + result = ws_enc_write_payload(&ws->enc, data, (uint8_t *)buf, + nread, &ws->sendbuf, &n); + if(result) + goto out; + CURL_TRC_READ(data, "cr_ws_read, added %zu payload, len=%zu", nread, n); + } + + DEBUGASSERT(!Curl_bufq_is_empty(&ws->sendbuf)); + *peos = FALSE; + result = Curl_bufq_cread(&ws->sendbuf, buf, blen, pnread); + if(!result && ctx->read_eos && Curl_bufq_is_empty(&ws->sendbuf)) { + /* no more data, read all, done. */ + ctx->eos = TRUE; + *peos = TRUE; + } + +out: + CURL_TRC_READ(data, "cr_ws_read(len=%zu) -> %d, nread=%zu, eos=%d", + blen, (int)result, *pnread, *peos); + return result; +} + +static const struct Curl_crtype ws_cr_encode = { + "ws-encode", + cr_ws_init, + cr_ws_read, + cr_ws_close, + Curl_creader_def_needs_rewind, + Curl_creader_def_total_length, + Curl_creader_def_resume_from, + Curl_creader_def_cntrl, + Curl_creader_def_is_paused, + Curl_creader_def_done, + sizeof(struct cr_ws_ctx) +}; + +struct wsfield { + const char *name; + const char *val; +}; + +CURLcode Curl_ws_request(struct Curl_easy *data, struct dynbuf *req) +{ + unsigned int i; + CURLcode result = CURLE_OK; + uint8_t rand[16]; + char *randstr; + size_t randlen; + char keyval[40]; + struct SingleRequest *k = &data->req; + struct wsfield heads[] = { + { + /* The request MUST contain an |Upgrade| header field whose value + MUST include the "websocket" keyword. */ + "Upgrade", "websocket" + }, + { + /* The request MUST include a header field with the name + |Sec-WebSocket-Version|. The value of this header field MUST be + 13. */ + "Sec-WebSocket-Version", "13", + }, + { + /* The request MUST include a header field with the name + |Sec-WebSocket-Key|. The value of this header field MUST be a nonce + consisting of a randomly selected 16-byte value that has been + base64-encoded (see Section 4 of [RFC4648]). The nonce MUST be + selected randomly for each connection. */ + "Sec-WebSocket-Key", NULL, + } + }; + heads[2].val = &keyval[0]; + + /* 16 bytes random */ + result = Curl_rand(data, rand, sizeof(rand)); + if(result) + return result; + result = curlx_base64_encode(rand, sizeof(rand), &randstr, &randlen); + if(result) + return result; + DEBUGASSERT(randlen < sizeof(keyval)); + if(randlen >= sizeof(keyval)) { + curlx_free(randstr); + return CURLE_FAILED_INIT; + } + curlx_strcopy(keyval, sizeof(keyval), randstr, randlen); + curlx_free(randstr); + for(i = 0; !result && (i < CURL_ARRAYSIZE(heads)); i++) { + if(!Curl_checkheaders(data, heads[i].name, strlen(heads[i].name))) { + result = curlx_dyn_addf(req, "%s: %s\r\n", heads[i].name, heads[i].val); + } + } + data->state.http_hd_upgrade = TRUE; + k->upgr101 = UPGR101_WS; + data->conn->bits.upgrade_in_progress = TRUE; + return result; +} + +static void ws_conn_dtor(void *key, size_t klen, void *entry) +{ + struct websocket *ws = entry; + (void)key; + (void)klen; + Curl_bufq_free(&ws->recvbuf); + Curl_bufq_free(&ws->sendbuf); + curlx_free(ws); +} + +/* + * 'nread' is number of bytes of websocket data already in the buffer at + * 'mem'. + */ +CURLcode Curl_ws_accept(struct Curl_easy *data, + const char *mem, size_t nread) +{ + struct SingleRequest *k = &data->req; + struct websocket *ws; + struct Curl_cwriter *ws_dec_writer = NULL; + struct Curl_creader *ws_enc_reader = NULL; + CURLcode result; + + DEBUGASSERT(data->conn); + ws = Curl_conn_meta_get(data->conn, CURL_META_PROTO_WS_CONN); + if(!ws) { + size_t chunk_size = WS_CHUNK_SIZE; + ws = curlx_calloc(1, sizeof(*ws)); + if(!ws) + return CURLE_OUT_OF_MEMORY; +#ifdef DEBUGBUILD + { + const char *p = getenv("CURL_WS_CHUNK_SIZE"); + if(p) { + curl_off_t l; + if(!curlx_str_number(&p, &l, 1 * 1024 * 1024)) + chunk_size = (size_t)l; + } + } +#endif + CURL_TRC_WS(data, "WS, using chunk size %zu", chunk_size); + Curl_bufq_init2(&ws->recvbuf, chunk_size, WS_CHUNK_COUNT, + BUFQ_OPT_SOFT_LIMIT); + Curl_bufq_init2(&ws->sendbuf, chunk_size, WS_CHUNK_COUNT, + BUFQ_OPT_SOFT_LIMIT); + ws_dec_init(&ws->dec); + ws_enc_init(&ws->enc); + result = Curl_conn_meta_set(data->conn, CURL_META_PROTO_WS_CONN, + ws, ws_conn_dtor); + if(result) + return result; + } + else { + Curl_bufq_reset(&ws->recvbuf); + ws_dec_reset(&ws->dec); + ws_enc_reset(&ws->enc); + } + /* Verify the Sec-WebSocket-Accept response. + + The sent value is the base64 encoded version of a SHA-1 hash done on the + |Sec-WebSocket-Key| header field concatenated with + the string "258EAFA5-E914-47DA-95CA-C5AB0DC85B11". + */ + + /* If the response includes a |Sec-WebSocket-Extensions| header field and + this header field indicates the use of an extension that was not present + in the client's handshake (the server has indicated an extension not + requested by the client), the client MUST Fail the WebSocket Connection. + */ + + /* If the response includes a |Sec-WebSocket-Protocol| header field + and this header field indicates the use of a subprotocol that was + not present in the client's handshake (the server has indicated a + subprotocol not requested by the client), the client MUST Fail + the WebSocket Connection. */ + + infof(data, "[WS] Received 101, switch to WebSocket"); + + /* Install our client writer that decodes WS frames payload */ + result = Curl_cwriter_create(&ws_dec_writer, data, &ws_cw_decode, + CURL_CW_CONTENT_DECODE); + if(result) + goto out; + result = Curl_cwriter_add(data, ws_dec_writer); + if(result) + goto out; + ws_dec_writer = NULL; /* owned by transfer now */ + + k->header = FALSE; /* we will not get more response headers */ + + if(data->set.connect_only) { + /* In CONNECT_ONLY setup, the payloads from `mem` need to be received + * when using `curl_ws_recv/curl_easy_recv` later on, after this transfer + * is already marked as DONE. + * Since `curl_easy_recv()` is also supposed to work, we need + * to buffer the data at connection level. See #22107 */ + if(nread) { + result = Curl_cf_recvbuf_add(data, data->conn, FIRSTSOCKET, + (const uint8_t *)mem, nread); + if(result) + goto out; + } + CURL_REQ_CLEAR_RECV(data); /* read no more content */ + } + else { /* !connect_only */ + if(data->set.method == HTTPREQ_PUT) { + CURL_TRC_WS(data, "UPLOAD set, add ws-encode reader"); + result = Curl_creader_set_fread(data, -1); + if(result) + goto out; + + if(!data->set.ws_raw_mode) { + /* Add our client reader encoding WS BINARY frames */ + result = Curl_creader_create(&ws_enc_reader, data, &ws_cr_encode, + CURL_CR_CONTENT_ENCODE); + if(result) + goto out; + result = Curl_creader_add(data, ws_enc_reader); + if(result) + goto out; + ws_enc_reader = NULL; /* owned by transfer now */ + } + + /* start over with sending */ + data->req.eos_read = FALSE; + data->req.upload_done = FALSE; + CURL_REQ_SET_SEND(data); + } + + /* Then pass any additional data to the writers */ + if(nread) { + result = Curl_client_write(data, CLIENTWRITE_BODY, mem, nread); + if(result) + goto out; + } + } + + k->upgr101 = UPGR101_RECEIVED; + k->header = FALSE; /* we will not get more responses */ + +out: + if(ws_dec_writer) + Curl_cwriter_free(data, ws_dec_writer); + if(ws_enc_reader) + Curl_creader_free(data, ws_enc_reader); + if(result) + CURL_TRC_WS(data, "Curl_ws_accept() failed -> %d", (int)result); + else + CURL_TRC_WS(data, "websocket established, %s mode", + data->set.connect_only ? "connect-only" : "callback"); + return result; +} + +struct ws_collect { + struct Curl_easy *data; + struct websocket *ws; + uint8_t *buffer; + size_t buflen; + size_t bufidx; + int frame_age; + int frame_flags; + curl_off_t payload_offset; + curl_off_t payload_len; + bool written; +}; + +static CURLcode ws_client_collect(const uint8_t *buf, size_t buflen, + int frame_age, int frame_flags, + curl_off_t payload_offset, + curl_off_t payload_len, + void *userp, + size_t *pnwritten) +{ + struct ws_collect *ctx = userp; + struct Curl_easy *data = ctx->data; + bool auto_pong = !data->set.ws_no_auto_pong; + curl_off_t remain; + CURLcode result = CURLE_OK; + + *pnwritten = 0; + remain = ws_payload_remain(payload_len, payload_offset, buflen); + if(remain < 0) { + DEBUGASSERT(0); /* parameter mismatch */ + return CURLE_BAD_FUNCTION_ARGUMENT; + } + + if(!ctx->bufidx) { + /* first write */ + ctx->frame_age = frame_age; + ctx->frame_flags = frame_flags; + ctx->payload_offset = payload_offset; + ctx->payload_len = payload_len; + } + + if(auto_pong && (frame_flags & CURLWS_PING) && !remain) { + /* auto-respond to PINGs, only works for single-frame payloads atm */ + CURL_TRC_WS(data, "auto PONG to [PING payload=%" FMT_OFF_T + "/%" FMT_OFF_T "]", payload_offset, payload_len); + /* send back the exact same content as a PONG */ + result = ws_enc_add_cntrl(ctx->data, ctx->ws, buf, buflen, CURLWS_PONG); + if(result) + return result; + *pnwritten = buflen; + } + else { + size_t write_len; + + ctx->written = TRUE; + DEBUGASSERT(ctx->buflen >= ctx->bufidx); + write_len = CURLMIN(buflen, ctx->buflen - ctx->bufidx); + if(!write_len) { + if(!buflen) /* 0 length write, we accept that */ + return CURLE_OK; + return CURLE_AGAIN; /* no more space */ + } + memcpy(ctx->buffer + ctx->bufidx, buf, write_len); + ctx->bufidx += write_len; + *pnwritten = write_len; + } + return result; +} + +static CURLcode nw_in_recv(void *reader_ctx, + uint8_t *buf, size_t buflen, + size_t *pnread) +{ + struct Curl_easy *data = reader_ctx; + return curl_easy_recv(data, buf, buflen, pnread); +} + +CURLcode curl_ws_recv(CURL *curl, void *buffer, + size_t buflen, size_t *recv, + const struct curl_ws_frame **metap) +{ + struct Curl_easy *data = curl; + struct connectdata *conn; + struct websocket *ws; + struct ws_collect ctx; + + *recv = 0; + *metap = NULL; + if(!GOOD_EASY_HANDLE(data) || (buflen && !buffer)) + return CURLE_BAD_FUNCTION_ARGUMENT; + + conn = data->conn; + if(!conn) { + /* Unhappy hack with lifetimes of transfers and connection */ + if(!data->set.connect_only) { + failf(data, "[WS] CONNECT_ONLY is required"); + return CURLE_UNSUPPORTED_PROTOCOL; + } + + Curl_getconnectinfo(data, &conn); + if(!conn) { + failf(data, "[WS] connection not found"); + return CURLE_BAD_FUNCTION_ARGUMENT; + } + } + ws = Curl_conn_meta_get(conn, CURL_META_PROTO_WS_CONN); + if(!ws) { + failf(data, "[WS] connection is not setup for websocket"); + return CURLE_BAD_FUNCTION_ARGUMENT; + } + + memset(&ctx, 0, sizeof(ctx)); + ctx.data = data; + ctx.ws = ws; + ctx.buffer = buffer; + ctx.buflen = buflen; + + while(1) { + CURLcode result; + + /* receive more when our buffer is empty */ + if(Curl_bufq_is_empty(&ws->recvbuf)) { + size_t n; + result = Curl_bufq_slurp(&ws->recvbuf, nw_in_recv, data, &n); + if(result) + return result; + else if(n == 0) { + /* connection closed */ + infof(data, "[WS] connection expectedly closed?"); + return CURLE_GOT_NOTHING; + } + CURL_TRC_WS(data, "curl_ws_recv, added %zu bytes from network", + Curl_bufq_len(&ws->recvbuf)); + } + + result = ws_dec_pass(&ws->dec, data, &ws->recvbuf, + ws_client_collect, &ctx); + if(result == CURLE_AGAIN) { + if(!ctx.written) { + ws_dec_info(&ws->dec, data, "need more input"); + continue; /* nothing written, try more input */ + } + break; + } + else if(result) { + return result; + } + else if(ctx.written) { + /* The decoded frame is passed back to our caller. + * There are frames like PING were we auto-respond to and + * that we do not return. For these `ctx.written` is not set. */ + break; + } + } + + /* update frame information to be passed back */ + update_meta(ws, ctx.frame_age, ctx.frame_flags, ctx.payload_offset, + ctx.payload_len, ctx.bufidx); + *metap = &ws->recvframe; + *recv = ws->recvframe.len; + CURL_TRC_WS(data, "curl_ws_recv(len=%zu) -> %zu bytes (frame at %" + FMT_OFF_T ", %" FMT_OFF_T " left)", + buflen, *recv, ws->recvframe.offset, + ws->recvframe.bytesleft); + /* all's well, try to send any pending control. we do not know + * when the application will call `curl_ws_send()` again. */ + if(!data->set.ws_raw_mode && ws->pending.type) { + CURLcode r2 = ws_enc_add_pending(data, ws); + if(!r2) + (void)ws_flush(data, ws, Curl_is_in_callback(data)); + } + return CURLE_OK; +} + +static CURLcode ws_flush(struct Curl_easy *data, struct websocket *ws, + bool blocking) +{ + CURLcode result; + + /* If there is space, add any pending control frame */ + if(Curl_bufq_len(&ws->sendbuf) < ws->sendbuf.chunk_size) { + result = ws_enc_add_pending(data, ws); + if(result && (result != CURLE_AGAIN)) + return result; + } + + if(!Curl_bufq_is_empty(&ws->sendbuf)) { + const uint8_t *out; + size_t outlen, n; +#ifdef DEBUGBUILD + /* Simulate a blocking send after this chunk has been sent */ + bool eagain_next = FALSE; + size_t chunk_egain = 0; + const char *p = getenv("CURL_WS_CHUNK_EAGAIN"); + if(p) { + curl_off_t l; + if(!curlx_str_number(&p, &l, 1 * 1024 * 1024)) + chunk_egain = (size_t)l; + } +#endif + + while(Curl_bufq_peek(&ws->sendbuf, &out, &outlen)) { +#ifdef DEBUGBUILD + if(eagain_next) + return CURLE_AGAIN; + if(chunk_egain && (outlen > chunk_egain)) { + outlen = chunk_egain; + eagain_next = TRUE; + } +#endif + if(blocking) { + result = ws_send_raw_blocking(data, ws, (const char *)out, outlen); + n = result ? 0 : outlen; + } + else if(data->set.connect_only || Curl_is_in_callback(data)) + result = Curl_senddata(data, out, outlen, &n); + else { + result = Curl_xfer_send(data, out, outlen, FALSE, &n); + if(!result && !n && outlen) + result = CURLE_AGAIN; + } + + if(result == CURLE_AGAIN) { + CURL_TRC_WS(data, "flush EAGAIN, %zu bytes remain in buffer", + Curl_bufq_len(&ws->sendbuf)); + return result; + } + else if(result) { + failf(data, "[WS] flush, write error %d", (int)result); + return result; + } + else { + CURL_TRC_WS(data, "flushed %zu bytes", n); + Curl_bufq_skip(&ws->sendbuf, n); + } + } + } + return CURLE_OK; +} + +static CURLcode ws_send_raw_blocking(struct Curl_easy *data, + struct websocket *ws, + const char *buffer, size_t buflen) +{ + CURLcode result = CURLE_OK; + size_t nwritten; + + if(!data) + return result; + + (void)ws; + while(buflen) { + result = Curl_xfer_send(data, buffer, buflen, FALSE, &nwritten); + if(result) + return result; + DEBUGASSERT(nwritten <= buflen); + buffer += nwritten; + buflen -= nwritten; + if(buflen) { + curl_socket_t sock = data->conn->sock[FIRSTSOCKET]; + timediff_t left_ms; + int ev; + + CURL_TRC_WS(data, "ws_send_raw_blocking() partial, %zu left to send", + buflen); + left_ms = Curl_timeleft_ms(data); + if(left_ms < 0) { + failf(data, "[WS] Timeout waiting for socket becoming writable"); + return CURLE_SEND_ERROR; + } + + /* POLLOUT socket */ + if(sock == CURL_SOCKET_BAD) + return CURLE_SEND_ERROR; + ev = SOCKET_WRITABLE(sock, left_ms ? left_ms : 500); + if(ev < 0) { + failf(data, "[WS] Error while waiting for socket becoming writable"); + return CURLE_SEND_ERROR; + } + } + } + return result; +} + +static CURLcode ws_send_raw(struct Curl_easy *data, const void *buffer, + size_t buflen, size_t *pnwritten) +{ + struct websocket *ws; + CURLcode result; + + ws = Curl_conn_meta_get(data->conn, CURL_META_PROTO_WS_CONN); + if(!ws) { + failf(data, "[WS] Not a websocket transfer"); + return CURLE_SEND_ERROR; + } + if(!buflen) + return CURLE_OK; + + if(Curl_is_in_callback(data)) { + /* When invoked from inside callbacks, we do a blocking send as the + * callback will probably not implement partial writes that may then + * mess up the ws framing subsequently. + * We need any pending data to be flushed before sending. */ + result = ws_flush(data, ws, TRUE); + if(result) + return result; + result = ws_send_raw_blocking(data, ws, buffer, buflen); + if(!result) + *pnwritten = buflen; + } + else { + /* We need any pending data to be sent or EAGAIN this call. */ + result = ws_flush(data, ws, FALSE); + if(result) + return result; + result = Curl_senddata(data, buffer, buflen, pnwritten); + } + + CURL_TRC_WS(data, "ws_send_raw(len=%zu) -> %d, %zu", + buflen, (int)result, *pnwritten); + return result; +} + +CURLcode curl_ws_send(CURL *curl, const void *buffer_arg, + size_t buflen, size_t *sent, + curl_off_t fragsize, + unsigned int flags) +{ + struct websocket *ws; + const uint8_t *buffer = buffer_arg; + CURLcode result = CURLE_OK; + struct Curl_easy *data = curl; + size_t ndummy; + size_t *pnsent = sent ? sent : &ndummy; + + if(!GOOD_EASY_HANDLE(data)) + return CURLE_BAD_FUNCTION_ARGUMENT; + CURL_TRC_WS(data, "curl_ws_send(len=%zu, fragsize=%" FMT_OFF_T + ", flags=%x), raw=%d", + buflen, fragsize, flags, data->set.ws_raw_mode); + + *pnsent = 0; + + if(!buffer && buflen) { + failf(data, "[WS] buffer is NULL when buflen is not"); + result = CURLE_BAD_FUNCTION_ARGUMENT; + goto out; + } + + if(!data->conn && data->set.connect_only) { + result = Curl_connect_only_attach(data); + if(result) + goto out; + } + if(!data->conn) { + failf(data, "[WS] No associated connection"); + result = CURLE_SEND_ERROR; + goto out; + } + ws = Curl_conn_meta_get(data->conn, CURL_META_PROTO_WS_CONN); + if(!ws) { + failf(data, "[WS] Not a websocket transfer"); + result = CURLE_SEND_ERROR; + goto out; + } + + if(data->set.ws_raw_mode) { + /* In raw mode, we write directly to the connection */ + /* try flushing any content still waiting to be sent. */ + result = ws_flush(data, ws, FALSE); + if(result) + goto out; + + if(!buffer) { + failf(data, "[WS] buffer is NULL in raw mode"); + return CURLE_BAD_FUNCTION_ARGUMENT; + } + if(!sent) { + failf(data, "[WS] sent is NULL in raw mode"); + return CURLE_BAD_FUNCTION_ARGUMENT; + } + if(fragsize || flags) { + failf(data, "[WS] fragsize and flags must be zero in raw mode"); + return CURLE_BAD_FUNCTION_ARGUMENT; + } + result = ws_send_raw(data, buffer, buflen, pnsent); + goto out; + } + + /* Not RAW mode, we do the frame encoding */ + result = ws_enc_send(data, ws, buffer, buflen, fragsize, flags, pnsent); + +out: + CURL_TRC_WS(data, "curl_ws_send(len=%zu, fragsize=%" FMT_OFF_T + ", flags=%x, raw=%d) -> %d, %zu", + buflen, fragsize, flags, data->set.ws_raw_mode, (int)result, + *pnsent); + return result; +} + +static CURLcode ws_setup_conn(struct Curl_easy *data, + struct connectdata *conn) +{ + /* WebSocket is 1.1 only (for now) */ + data->state.http_neg.accept_09 = FALSE; + data->state.http_neg.only_10 = FALSE; + data->state.http_neg.wanted = CURL_HTTP_V1x; + data->state.http_neg.allowed = CURL_HTTP_V1x; + return Curl_http_setup_conn(data, conn); +} + +const struct curl_ws_frame *curl_ws_meta(CURL *curl) +{ + /* we only return something for websocket, called from within the callback + when not using raw mode */ + struct Curl_easy *data = curl; + if(GOOD_EASY_HANDLE(data) && Curl_is_in_callback(data) && + data->conn && !data->set.ws_raw_mode) { + struct websocket *ws; + ws = Curl_conn_meta_get(data->conn, CURL_META_PROTO_WS_CONN); + if(ws) + return &ws->recvframe; + } + return NULL; +} + +CURL_EXTERN CURLcode curl_ws_start_frame(CURL *curl, + unsigned int flags, + curl_off_t frame_len) +{ + struct websocket *ws; + CURLcode result = CURLE_OK; + struct Curl_easy *data = curl; + + if(!GOOD_EASY_HANDLE(data)) + return CURLE_BAD_FUNCTION_ARGUMENT; + + if(data->set.ws_raw_mode) { + failf(data, "cannot curl_ws_start_frame() with CURLWS_RAW_MODE enabled"); + return CURLE_FAILED_INIT; + } + + CURL_TRC_WS(data, "curl_ws_start_frame(flags=%x, frame_len=%" FMT_OFF_T, + flags, frame_len); + + if(!data->conn) { + failf(data, "[WS] No associated connection"); + result = CURLE_SEND_ERROR; + goto out; + } + ws = Curl_conn_meta_get(data->conn, CURL_META_PROTO_WS_CONN); + if(!ws) { + failf(data, "[WS] Not a websocket transfer"); + result = CURLE_SEND_ERROR; + goto out; + } + + if(ws->enc.payload_remain) { + failf(data, "[WS] previous frame not finished"); + result = CURLE_SEND_ERROR; + goto out; + } + + result = ws_enc_write_head(data, ws, &ws->enc, flags, frame_len, + &ws->sendbuf); + if(result) + CURL_TRC_WS(data, "curl_start_frame(), error adding frame head %d", + (int)result); + +out: + return result; +} + +const struct Curl_protocol Curl_protocol_ws = { + ws_setup_conn, /* setup_connection */ + Curl_http, /* do_it */ + Curl_http_done, /* done */ + ZERO_NULL, /* do_more */ + ZERO_NULL, /* connect_it */ + ZERO_NULL, /* connecting */ + ZERO_NULL, /* doing */ + ZERO_NULL, /* proto_pollset */ + Curl_http_doing_pollset, /* doing_pollset */ + ZERO_NULL, /* domore_pollset */ + Curl_http_perform_pollset, /* perform_pollset */ + ZERO_NULL, /* disconnect */ + Curl_http_write_resp, /* write_resp */ + Curl_http_write_resp_hd, /* write_resp_hd */ + ZERO_NULL, /* connection_is_dead */ + ZERO_NULL, /* attach connection */ + Curl_http_follow, /* follow */ +}; + +#else + +CURLcode curl_ws_recv(CURL *curl, void *buffer, size_t buflen, + size_t *recv, + const struct curl_ws_frame **metap) +{ + (void)curl; + (void)buffer; + (void)buflen; + (void)recv; + (void)metap; + return CURLE_NOT_BUILT_IN; +} + +CURLcode curl_ws_send(CURL *curl, const void *buffer, + size_t buflen, size_t *sent, + curl_off_t fragsize, + unsigned int flags) +{ + (void)curl; + (void)buffer; + (void)buflen; + (void)sent; + (void)fragsize; + (void)flags; + return CURLE_NOT_BUILT_IN; +} + +const struct curl_ws_frame *curl_ws_meta(CURL *data) +{ + (void)data; + return NULL; +} + +CURL_EXTERN CURLcode curl_ws_start_frame(CURL *curl, + unsigned int flags, + curl_off_t frame_len) +{ + (void)curl; + (void)flags; + (void)frame_len; + return CURLE_NOT_BUILT_IN; +} + +#endif /* !CURL_DISABLE_WEBSOCKETS */ diff --git a/3rdparty/curl-8.21.0/lib/ws.h b/3rdparty/curl-8.21.0/lib/ws.h new file mode 100644 index 0000000000..71b5b3fff0 --- /dev/null +++ b/3rdparty/curl-8.21.0/lib/ws.h @@ -0,0 +1,44 @@ +#ifndef HEADER_CURL_WS_H +#define HEADER_CURL_WS_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +#include "curl_setup.h" + +#if !defined(CURL_DISABLE_WEBSOCKETS) && !defined(CURL_DISABLE_HTTP) + +extern const struct Curl_protocol Curl_protocol_ws; + +/* meta key for storing protocol meta at connection */ +#define CURL_META_PROTO_WS_CONN "meta:proto:ws:conn" + +CURLcode Curl_ws_request(struct Curl_easy *data, struct dynbuf *req); +CURLcode Curl_ws_accept(struct Curl_easy *data, + const char *mem, size_t nread); + +#else +#define Curl_ws_request(x, y) CURLE_OK +#define Curl_ws_free(x) Curl_nop_stmt +#endif + +#endif /* HEADER_CURL_WS_H */ diff --git a/3rdparty/curl-8.21.0/libcurl.pc.in b/3rdparty/curl-8.21.0/libcurl.pc.in new file mode 100644 index 0000000000..c0ba5244a8 --- /dev/null +++ b/3rdparty/curl-8.21.0/libcurl.pc.in @@ -0,0 +1,41 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### + +prefix=@prefix@ +exec_prefix=@exec_prefix@ +libdir=@libdir@ +includedir=@includedir@ +supported_protocols="@SUPPORT_PROTOCOLS@" +supported_features="@SUPPORT_FEATURES@" + +Name: libcurl +URL: https://curl.se/ +Description: Library to transfer files with HTTP, FTP, etc. +Version: @CURLVERSION@ +Requires: @LIBCURL_PC_REQUIRES@ +Requires.private: @LIBCURL_PC_REQUIRES_PRIVATE@ +Libs: -L${libdir} -lcurl @LIBCURL_PC_LIBS@ +Libs.private: @LIBCURL_PC_LDFLAGS_PRIVATE@ @LIBCURL_PC_LIBS_PRIVATE@ +Cflags: -I${includedir} @LIBCURL_PC_CFLAGS@ +Cflags.private: @LIBCURL_PC_CFLAGS_PRIVATE@ diff --git a/3rdparty/curl-8.21.0/ltmain.sh b/3rdparty/curl-8.21.0/ltmain.sh new file mode 100755 index 0000000000..3846a5068c --- /dev/null +++ b/3rdparty/curl-8.21.0/ltmain.sh @@ -0,0 +1,11436 @@ +#! /usr/bin/env sh +## DO NOT EDIT - This file generated from ./build-aux/ltmain.in +## by inline-source v2019-02-19.15 + +# libtool (GNU libtool) 2.4.7 +# Provide generalized library-building support services. +# Written by Gordon Matzigkeit , 1996 + +# Copyright (C) 1996-2019, 2021-2022 Free Software Foundation, Inc. +# This is free software; see the source for copying conditions. There is NO +# warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +# GNU Libtool is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# As a special exception to the GNU General Public License, +# if you distribute this file as part of a program or library that +# is built using GNU Libtool, you may include this file under the +# same distribution terms that you use for the rest of that program. +# +# GNU Libtool is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . + + +PROGRAM=libtool +PACKAGE=libtool +VERSION="2.4.7 Debian-2.4.7-7~deb12u1" +package_revision=2.4.7 + + +## ------ ## +## Usage. ## +## ------ ## + +# Run './libtool --help' for help with using this script from the +# command line. + + +## ------------------------------- ## +## User overridable command paths. ## +## ------------------------------- ## + +# After configure completes, it has a better idea of some of the +# shell tools we need than the defaults used by the functions shared +# with bootstrap, so set those here where they can still be over- +# ridden by the user, but otherwise take precedence. + +: ${AUTOCONF="autoconf"} +: ${AUTOMAKE="automake"} + + +## -------------------------- ## +## Source external libraries. ## +## -------------------------- ## + +# Much of our low-level functionality needs to be sourced from external +# libraries, which are installed to $pkgauxdir. + +# Set a version string for this script. +scriptversion=2019-02-19.15; # UTC + +# General shell script boiler plate, and helper functions. +# Written by Gary V. Vaughan, 2004 + +# This is free software. There is NO warranty; not even for +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +# +# Copyright (C) 2004-2019, 2021 Bootstrap Authors +# +# This file is dual licensed under the terms of the MIT license +# , and GPL version 2 or later +# . You must apply one of +# these licenses when using or redistributing this software or any of +# the files within it. See the URLs above, or the file `LICENSE` +# included in the Bootstrap distribution for the full license texts. + +# Please report bugs or propose patches to: +# + + +## ------ ## +## Usage. ## +## ------ ## + +# Evaluate this file near the top of your script to gain access to +# the functions and variables defined here: +# +# . `echo "$0" | ${SED-sed} 's|[^/]*$||'`/build-aux/funclib.sh +# +# If you need to override any of the default environment variable +# settings, do that before evaluating this file. + + +## -------------------- ## +## Shell normalisation. ## +## -------------------- ## + +# Some shells need a little help to be as Bourne compatible as possible. +# Before doing anything else, make sure all that help has been provided! + +DUALCASE=1; export DUALCASE # for MKS sh +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : + emulate sh + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which + # is contrary to our usage. Disable this feature. + alias -g '${1+"$@"}'='"$@"' + setopt NO_GLOB_SUBST +else + case `(set -o) 2>/dev/null` in *posix*) set -o posix ;; esac +fi + +# NLS nuisances: We save the old values in case they are required later. +_G_user_locale= +_G_safe_locale= +for _G_var in LANG LANGUAGE LC_ALL LC_CTYPE LC_COLLATE LC_MESSAGES +do + eval "if test set = \"\${$_G_var+set}\"; then + save_$_G_var=\$$_G_var + $_G_var=C + export $_G_var + _G_user_locale=\"$_G_var=\\\$save_\$_G_var; \$_G_user_locale\" + _G_safe_locale=\"$_G_var=C; \$_G_safe_locale\" + fi" +done +# These NLS vars are set unconditionally (bootstrap issue #24). Unset those +# in case the environment reset is needed later and the $save_* variant is not +# defined (see the code above). +LC_ALL=C +LANGUAGE=C +export LANGUAGE LC_ALL + +# Make sure IFS has a sensible default +sp=' ' +nl=' +' +IFS="$sp $nl" + +# There are apparently some retarded systems that use ';' as a PATH separator! +if test "${PATH_SEPARATOR+set}" != set; then + PATH_SEPARATOR=: + (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { + (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || + PATH_SEPARATOR=';' + } +fi + + +# func_unset VAR +# -------------- +# Portably unset VAR. +# In some shells, an 'unset VAR' statement leaves a non-zero return +# status if VAR is already unset, which might be problematic if the +# statement is used at the end of a function (thus poisoning its return +# value) or when 'set -e' is active (causing even a spurious abort of +# the script in this case). +func_unset () +{ + { eval $1=; (eval unset $1) >/dev/null 2>&1 && eval unset $1 || : ; } +} + + +# Make sure CDPATH doesn't cause `cd` commands to output the target dir. +func_unset CDPATH + +# Make sure ${,E,F}GREP behave sanely. +func_unset GREP_OPTIONS + + +## ------------------------- ## +## Locate command utilities. ## +## ------------------------- ## + + +# func_executable_p FILE +# ---------------------- +# Check that FILE is an executable regular file. +func_executable_p () +{ + test -f "$1" && test -x "$1" +} + + +# func_path_progs PROGS_LIST CHECK_FUNC [PATH] +# -------------------------------------------- +# Search for either a program that responds to --version with output +# containing "GNU", or else returned by CHECK_FUNC otherwise, by +# trying all the directories in PATH with each of the elements of +# PROGS_LIST. +# +# CHECK_FUNC should accept the path to a candidate program, and +# set $func_check_prog_result if it truncates its output less than +# $_G_path_prog_max characters. +func_path_progs () +{ + _G_progs_list=$1 + _G_check_func=$2 + _G_PATH=${3-"$PATH"} + + _G_path_prog_max=0 + _G_path_prog_found=false + _G_save_IFS=$IFS; IFS=${PATH_SEPARATOR-:} + for _G_dir in $_G_PATH; do + IFS=$_G_save_IFS + test -z "$_G_dir" && _G_dir=. + for _G_prog_name in $_G_progs_list; do + for _exeext in '' .EXE; do + _G_path_prog=$_G_dir/$_G_prog_name$_exeext + func_executable_p "$_G_path_prog" || continue + case `"$_G_path_prog" --version 2>&1` in + *GNU*) func_path_progs_result=$_G_path_prog _G_path_prog_found=: ;; + *) $_G_check_func $_G_path_prog + func_path_progs_result=$func_check_prog_result + ;; + esac + $_G_path_prog_found && break 3 + done + done + done + IFS=$_G_save_IFS + test -z "$func_path_progs_result" && { + echo "no acceptable sed could be found in \$PATH" >&2 + exit 1 + } +} + + +# We want to be able to use the functions in this file before configure +# has figured out where the best binaries are kept, which means we have +# to search for them ourselves - except when the results are already set +# where we skip the searches. + +# Unless the user overrides by setting SED, search the path for either GNU +# sed, or the sed that truncates its output the least. +test -z "$SED" && { + _G_sed_script=s/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa/bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb/ + for _G_i in 1 2 3 4 5 6 7; do + _G_sed_script=$_G_sed_script$nl$_G_sed_script + done + echo "$_G_sed_script" 2>/dev/null | sed 99q >conftest.sed + _G_sed_script= + + func_check_prog_sed () + { + _G_path_prog=$1 + + _G_count=0 + printf 0123456789 >conftest.in + while : + do + cat conftest.in conftest.in >conftest.tmp + mv conftest.tmp conftest.in + cp conftest.in conftest.nl + echo '' >> conftest.nl + "$_G_path_prog" -f conftest.sed conftest.out 2>/dev/null || break + diff conftest.out conftest.nl >/dev/null 2>&1 || break + _G_count=`expr $_G_count + 1` + if test "$_G_count" -gt "$_G_path_prog_max"; then + # Best one so far, save it but keep looking for a better one + func_check_prog_result=$_G_path_prog + _G_path_prog_max=$_G_count + fi + # 10*(2^10) chars as input seems more than enough + test 10 -lt "$_G_count" && break + done + rm -f conftest.in conftest.tmp conftest.nl conftest.out + } + + func_path_progs "sed gsed" func_check_prog_sed "$PATH:/usr/xpg4/bin" + rm -f conftest.sed + SED=$func_path_progs_result +} + + +# Unless the user overrides by setting GREP, search the path for either GNU +# grep, or the grep that truncates its output the least. +test -z "$GREP" && { + func_check_prog_grep () + { + _G_path_prog=$1 + + _G_count=0 + _G_path_prog_max=0 + printf 0123456789 >conftest.in + while : + do + cat conftest.in conftest.in >conftest.tmp + mv conftest.tmp conftest.in + cp conftest.in conftest.nl + echo 'GREP' >> conftest.nl + "$_G_path_prog" -e 'GREP$' -e '-(cannot match)-' conftest.out 2>/dev/null || break + diff conftest.out conftest.nl >/dev/null 2>&1 || break + _G_count=`expr $_G_count + 1` + if test "$_G_count" -gt "$_G_path_prog_max"; then + # Best one so far, save it but keep looking for a better one + func_check_prog_result=$_G_path_prog + _G_path_prog_max=$_G_count + fi + # 10*(2^10) chars as input seems more than enough + test 10 -lt "$_G_count" && break + done + rm -f conftest.in conftest.tmp conftest.nl conftest.out + } + + func_path_progs "grep ggrep" func_check_prog_grep "$PATH:/usr/xpg4/bin" + GREP=$func_path_progs_result +} + + +## ------------------------------- ## +## User overridable command paths. ## +## ------------------------------- ## + +# All uppercase variable names are used for environment variables. These +# variables can be overridden by the user before calling a script that +# uses them if a suitable command of that name is not already available +# in the command search PATH. + +: ${CP="cp -f"} +: ${ECHO="printf %s\n"} +: ${EGREP="$GREP -E"} +: ${FGREP="$GREP -F"} +: ${LN_S="ln -s"} +: ${MAKE="make"} +: ${MKDIR="mkdir"} +: ${MV="mv -f"} +: ${RM="rm -f"} +: ${SHELL="${CONFIG_SHELL-/bin/sh}"} + + +## -------------------- ## +## Useful sed snippets. ## +## -------------------- ## + +sed_dirname='s|/[^/]*$||' +sed_basename='s|^.*/||' + +# Sed substitution that helps us do robust quoting. It backslashifies +# metacharacters that are still active within double-quoted strings. +sed_quote_subst='s|\([`"$\\]\)|\\\1|g' + +# Same as above, but do not quote variable references. +sed_double_quote_subst='s/\(["`\\]\)/\\\1/g' + +# Sed substitution that turns a string into a regex matching for the +# string literally. +sed_make_literal_regex='s|[].[^$\\*\/]|\\&|g' + +# Sed substitution that converts a w32 file name or path +# that contains forward slashes, into one that contains +# (escaped) backslashes. A very naive implementation. +sed_naive_backslashify='s|\\\\*|\\|g;s|/|\\|g;s|\\|\\\\|g' + +# Re-'\' parameter expansions in output of sed_double_quote_subst that +# were '\'-ed in input to the same. If an odd number of '\' preceded a +# '$' in input to sed_double_quote_subst, that '$' was protected from +# expansion. Since each input '\' is now two '\'s, look for any number +# of runs of four '\'s followed by two '\'s and then a '$'. '\' that '$'. +_G_bs='\\' +_G_bs2='\\\\' +_G_bs4='\\\\\\\\' +_G_dollar='\$' +sed_double_backslash="\ + s/$_G_bs4/&\\ +/g + s/^$_G_bs2$_G_dollar/$_G_bs&/ + s/\\([^$_G_bs]\\)$_G_bs2$_G_dollar/\\1$_G_bs2$_G_bs$_G_dollar/g + s/\n//g" + +# require_check_ifs_backslash +# --------------------------- +# Check if we can use backslash as IFS='\' separator, and set +# $check_ifs_backshlash_broken to ':' or 'false'. +require_check_ifs_backslash=func_require_check_ifs_backslash +func_require_check_ifs_backslash () +{ + _G_save_IFS=$IFS + IFS='\' + _G_check_ifs_backshlash='a\\b' + for _G_i in $_G_check_ifs_backshlash + do + case $_G_i in + a) + check_ifs_backshlash_broken=false + ;; + '') + break + ;; + *) + check_ifs_backshlash_broken=: + break + ;; + esac + done + IFS=$_G_save_IFS + require_check_ifs_backslash=: +} + + +## ----------------- ## +## Global variables. ## +## ----------------- ## + +# Except for the global variables explicitly listed below, the following +# functions in the '^func_' namespace, and the '^require_' namespace +# variables initialised in the 'Resource management' section, sourcing +# this file will not pollute your global namespace with anything +# else. There's no portable way to scope variables in Bourne shell +# though, so actually running these functions will sometimes place +# results into a variable named after the function, and often use +# temporary variables in the '^_G_' namespace. If you are careful to +# avoid using those namespaces casually in your sourcing script, things +# should continue to work as you expect. And, of course, you can freely +# overwrite any of the functions or variables defined here before +# calling anything to customize them. + +EXIT_SUCCESS=0 +EXIT_FAILURE=1 +EXIT_MISMATCH=63 # $? = 63 is used to indicate version mismatch to missing. +EXIT_SKIP=77 # $? = 77 is used to indicate a skipped test to automake. + +# Allow overriding, eg assuming that you follow the convention of +# putting '$debug_cmd' at the start of all your functions, you can get +# bash to show function call trace with: +# +# debug_cmd='echo "${FUNCNAME[0]} $*" >&2' bash your-script-name +debug_cmd=${debug_cmd-":"} +exit_cmd=: + +# By convention, finish your script with: +# +# exit $exit_status +# +# so that you can set exit_status to non-zero if you want to indicate +# something went wrong during execution without actually bailing out at +# the point of failure. +exit_status=$EXIT_SUCCESS + +# Work around backward compatibility issue on IRIX 6.5. On IRIX 6.4+, sh +# is ksh but when the shell is invoked as "sh" and the current value of +# the _XPG environment variable is not equal to 1 (one), the special +# positional parameter $0, within a function call, is the name of the +# function. +progpath=$0 + +# The name of this program. +progname=`$ECHO "$progpath" |$SED "$sed_basename"` + +# Make sure we have an absolute progpath for reexecution: +case $progpath in + [\\/]*|[A-Za-z]:\\*) ;; + *[\\/]*) + progdir=`$ECHO "$progpath" |$SED "$sed_dirname"` + progdir=`cd "$progdir" && pwd` + progpath=$progdir/$progname + ;; + *) + _G_IFS=$IFS + IFS=${PATH_SEPARATOR-:} + for progdir in $PATH; do + IFS=$_G_IFS + test -x "$progdir/$progname" && break + done + IFS=$_G_IFS + test -n "$progdir" || progdir=`pwd` + progpath=$progdir/$progname + ;; +esac + + +## ----------------- ## +## Standard options. ## +## ----------------- ## + +# The following options affect the operation of the functions defined +# below, and should be set appropriately depending on run-time para- +# meters passed on the command line. + +opt_dry_run=false +opt_quiet=false +opt_verbose=false + +# Categories 'all' and 'none' are always available. Append any others +# you will pass as the first argument to func_warning from your own +# code. +warning_categories= + +# By default, display warnings according to 'opt_warning_types'. Set +# 'warning_func' to ':' to elide all warnings, or func_fatal_error to +# treat the next displayed warning as a fatal error. +warning_func=func_warn_and_continue + +# Set to 'all' to display all warnings, 'none' to suppress all +# warnings, or a space delimited list of some subset of +# 'warning_categories' to display only the listed warnings. +opt_warning_types=all + + +## -------------------- ## +## Resource management. ## +## -------------------- ## + +# This section contains definitions for functions that each ensure a +# particular resource (a file, or a non-empty configuration variable for +# example) is available, and if appropriate to extract default values +# from pertinent package files. Call them using their associated +# 'require_*' variable to ensure that they are executed, at most, once. +# +# It's entirely deliberate that calling these functions can set +# variables that don't obey the namespace limitations obeyed by the rest +# of this file, in order that that they be as useful as possible to +# callers. + + +# require_term_colors +# ------------------- +# Allow display of bold text on terminals that support it. +require_term_colors=func_require_term_colors +func_require_term_colors () +{ + $debug_cmd + + test -t 1 && { + # COLORTERM and USE_ANSI_COLORS environment variables take + # precedence, because most terminfo databases neglect to describe + # whether color sequences are supported. + test -n "${COLORTERM+set}" && : ${USE_ANSI_COLORS="1"} + + if test 1 = "$USE_ANSI_COLORS"; then + # Standard ANSI escape sequences + tc_reset='' + tc_bold=''; tc_standout='' + tc_red=''; tc_green='' + tc_blue=''; tc_cyan='' + else + # Otherwise trust the terminfo database after all. + test -n "`tput sgr0 2>/dev/null`" && { + tc_reset=`tput sgr0` + test -n "`tput bold 2>/dev/null`" && tc_bold=`tput bold` + tc_standout=$tc_bold + test -n "`tput smso 2>/dev/null`" && tc_standout=`tput smso` + test -n "`tput setaf 1 2>/dev/null`" && tc_red=`tput setaf 1` + test -n "`tput setaf 2 2>/dev/null`" && tc_green=`tput setaf 2` + test -n "`tput setaf 4 2>/dev/null`" && tc_blue=`tput setaf 4` + test -n "`tput setaf 5 2>/dev/null`" && tc_cyan=`tput setaf 5` + } + fi + } + + require_term_colors=: +} + + +## ----------------- ## +## Function library. ## +## ----------------- ## + +# This section contains a variety of useful functions to call in your +# scripts. Take note of the portable wrappers for features provided by +# some modern shells, which will fall back to slower equivalents on +# less featureful shells. + + +# func_append VAR VALUE +# --------------------- +# Append VALUE onto the existing contents of VAR. + + # _G_HAVE_PLUSEQ_OP + # Can be empty, in which case the shell is probed, "yes" if += is + # useable or anything else if it does not work. + if test -z "$_G_HAVE_PLUSEQ_OP" && \ + __PLUSEQ_TEST="a" && \ + __PLUSEQ_TEST+=" b" 2>/dev/null && \ + test "a b" = "$__PLUSEQ_TEST"; then + _G_HAVE_PLUSEQ_OP=yes + fi + +if test yes = "$_G_HAVE_PLUSEQ_OP" +then + # This is an XSI compatible shell, allowing a faster implementation... + eval 'func_append () + { + $debug_cmd + + eval "$1+=\$2" + }' +else + # ...otherwise fall back to using expr, which is often a shell builtin. + func_append () + { + $debug_cmd + + eval "$1=\$$1\$2" + } +fi + + +# func_append_quoted VAR VALUE +# ---------------------------- +# Quote VALUE and append to the end of shell variable VAR, separated +# by a space. +if test yes = "$_G_HAVE_PLUSEQ_OP"; then + eval 'func_append_quoted () + { + $debug_cmd + + func_quote_arg pretty "$2" + eval "$1+=\\ \$func_quote_arg_result" + }' +else + func_append_quoted () + { + $debug_cmd + + func_quote_arg pretty "$2" + eval "$1=\$$1\\ \$func_quote_arg_result" + } +fi + + +# func_append_uniq VAR VALUE +# -------------------------- +# Append unique VALUE onto the existing contents of VAR, assuming +# entries are delimited by the first character of VALUE. For example: +# +# func_append_uniq options " --another-option option-argument" +# +# will only append to $options if " --another-option option-argument " +# is not already present somewhere in $options already (note spaces at +# each end implied by leading space in second argument). +func_append_uniq () +{ + $debug_cmd + + eval _G_current_value='`$ECHO $'$1'`' + _G_delim=`expr "$2" : '\(.\)'` + + case $_G_delim$_G_current_value$_G_delim in + *"$2$_G_delim"*) ;; + *) func_append "$@" ;; + esac +} + + +# func_arith TERM... +# ------------------ +# Set func_arith_result to the result of evaluating TERMs. + test -z "$_G_HAVE_ARITH_OP" \ + && (eval 'test 2 = $(( 1 + 1 ))') 2>/dev/null \ + && _G_HAVE_ARITH_OP=yes + +if test yes = "$_G_HAVE_ARITH_OP"; then + eval 'func_arith () + { + $debug_cmd + + func_arith_result=$(( $* )) + }' +else + func_arith () + { + $debug_cmd + + func_arith_result=`expr "$@"` + } +fi + + +# func_basename FILE +# ------------------ +# Set func_basename_result to FILE with everything up to and including +# the last / stripped. +if test yes = "$_G_HAVE_XSI_OPS"; then + # If this shell supports suffix pattern removal, then use it to avoid + # forking. Hide the definitions single quotes in case the shell chokes + # on unsupported syntax... + _b='func_basename_result=${1##*/}' + _d='case $1 in + */*) func_dirname_result=${1%/*}$2 ;; + * ) func_dirname_result=$3 ;; + esac' + +else + # ...otherwise fall back to using sed. + _b='func_basename_result=`$ECHO "$1" |$SED "$sed_basename"`' + _d='func_dirname_result=`$ECHO "$1" |$SED "$sed_dirname"` + if test "X$func_dirname_result" = "X$1"; then + func_dirname_result=$3 + else + func_append func_dirname_result "$2" + fi' +fi + +eval 'func_basename () +{ + $debug_cmd + + '"$_b"' +}' + + +# func_dirname FILE APPEND NONDIR_REPLACEMENT +# ------------------------------------------- +# Compute the dirname of FILE. If nonempty, add APPEND to the result, +# otherwise set result to NONDIR_REPLACEMENT. +eval 'func_dirname () +{ + $debug_cmd + + '"$_d"' +}' + + +# func_dirname_and_basename FILE APPEND NONDIR_REPLACEMENT +# -------------------------------------------------------- +# Perform func_basename and func_dirname in a single function +# call: +# dirname: Compute the dirname of FILE. If nonempty, +# add APPEND to the result, otherwise set result +# to NONDIR_REPLACEMENT. +# value returned in "$func_dirname_result" +# basename: Compute filename of FILE. +# value retuned in "$func_basename_result" +# For efficiency, we do not delegate to the functions above but instead +# duplicate the functionality here. +eval 'func_dirname_and_basename () +{ + $debug_cmd + + '"$_b"' + '"$_d"' +}' + + +# func_echo ARG... +# ---------------- +# Echo program name prefixed message. +func_echo () +{ + $debug_cmd + + _G_message=$* + + func_echo_IFS=$IFS + IFS=$nl + for _G_line in $_G_message; do + IFS=$func_echo_IFS + $ECHO "$progname: $_G_line" + done + IFS=$func_echo_IFS +} + + +# func_echo_all ARG... +# -------------------- +# Invoke $ECHO with all args, space-separated. +func_echo_all () +{ + $ECHO "$*" +} + + +# func_echo_infix_1 INFIX ARG... +# ------------------------------ +# Echo program name, followed by INFIX on the first line, with any +# additional lines not showing INFIX. +func_echo_infix_1 () +{ + $debug_cmd + + $require_term_colors + + _G_infix=$1; shift + _G_indent=$_G_infix + _G_prefix="$progname: $_G_infix: " + _G_message=$* + + # Strip color escape sequences before counting printable length + for _G_tc in "$tc_reset" "$tc_bold" "$tc_standout" "$tc_red" "$tc_green" "$tc_blue" "$tc_cyan" + do + test -n "$_G_tc" && { + _G_esc_tc=`$ECHO "$_G_tc" | $SED "$sed_make_literal_regex"` + _G_indent=`$ECHO "$_G_indent" | $SED "s|$_G_esc_tc||g"` + } + done + _G_indent="$progname: "`echo "$_G_indent" | $SED 's|.| |g'`" " ## exclude from sc_prohibit_nested_quotes + + func_echo_infix_1_IFS=$IFS + IFS=$nl + for _G_line in $_G_message; do + IFS=$func_echo_infix_1_IFS + $ECHO "$_G_prefix$tc_bold$_G_line$tc_reset" >&2 + _G_prefix=$_G_indent + done + IFS=$func_echo_infix_1_IFS +} + + +# func_error ARG... +# ----------------- +# Echo program name prefixed message to standard error. +func_error () +{ + $debug_cmd + + $require_term_colors + + func_echo_infix_1 " $tc_standout${tc_red}error$tc_reset" "$*" >&2 +} + + +# func_fatal_error ARG... +# ----------------------- +# Echo program name prefixed message to standard error, and exit. +func_fatal_error () +{ + $debug_cmd + + func_error "$*" + exit $EXIT_FAILURE +} + + +# func_grep EXPRESSION FILENAME +# ----------------------------- +# Check whether EXPRESSION matches any line of FILENAME, without output. +func_grep () +{ + $debug_cmd + + $GREP "$1" "$2" >/dev/null 2>&1 +} + + +# func_len STRING +# --------------- +# Set func_len_result to the length of STRING. STRING may not +# start with a hyphen. + test -z "$_G_HAVE_XSI_OPS" \ + && (eval 'x=a/b/c; + test 5aa/bb/cc = "${#x}${x%%/*}${x%/*}${x#*/}${x##*/}"') 2>/dev/null \ + && _G_HAVE_XSI_OPS=yes + +if test yes = "$_G_HAVE_XSI_OPS"; then + eval 'func_len () + { + $debug_cmd + + func_len_result=${#1} + }' +else + func_len () + { + $debug_cmd + + func_len_result=`expr "$1" : ".*" 2>/dev/null || echo $max_cmd_len` + } +fi + + +# func_mkdir_p DIRECTORY-PATH +# --------------------------- +# Make sure the entire path to DIRECTORY-PATH is available. +func_mkdir_p () +{ + $debug_cmd + + _G_directory_path=$1 + _G_dir_list= + + if test -n "$_G_directory_path" && test : != "$opt_dry_run"; then + + # Protect directory names starting with '-' + case $_G_directory_path in + -*) _G_directory_path=./$_G_directory_path ;; + esac + + # While some portion of DIR does not yet exist... + while test ! -d "$_G_directory_path"; do + # ...make a list in topmost first order. Use a colon delimited + # list incase some portion of path contains whitespace. + _G_dir_list=$_G_directory_path:$_G_dir_list + + # If the last portion added has no slash in it, the list is done + case $_G_directory_path in */*) ;; *) break ;; esac + + # ...otherwise throw away the child directory and loop + _G_directory_path=`$ECHO "$_G_directory_path" | $SED -e "$sed_dirname"` + done + _G_dir_list=`$ECHO "$_G_dir_list" | $SED 's|:*$||'` + + func_mkdir_p_IFS=$IFS; IFS=: + for _G_dir in $_G_dir_list; do + IFS=$func_mkdir_p_IFS + # mkdir can fail with a 'File exist' error if two processes + # try to create one of the directories concurrently. Don't + # stop in that case! + $MKDIR "$_G_dir" 2>/dev/null || : + done + IFS=$func_mkdir_p_IFS + + # Bail out if we (or some other process) failed to create a directory. + test -d "$_G_directory_path" || \ + func_fatal_error "Failed to create '$1'" + fi +} + + +# func_mktempdir [BASENAME] +# ------------------------- +# Make a temporary directory that won't clash with other running +# libtool processes, and avoids race conditions if possible. If +# given, BASENAME is the basename for that directory. +func_mktempdir () +{ + $debug_cmd + + _G_template=${TMPDIR-/tmp}/${1-$progname} + + if test : = "$opt_dry_run"; then + # Return a directory name, but don't create it in dry-run mode + _G_tmpdir=$_G_template-$$ + else + + # If mktemp works, use that first and foremost + _G_tmpdir=`mktemp -d "$_G_template-XXXXXXXX" 2>/dev/null` + + if test ! -d "$_G_tmpdir"; then + # Failing that, at least try and use $RANDOM to avoid a race + _G_tmpdir=$_G_template-${RANDOM-0}$$ + + func_mktempdir_umask=`umask` + umask 0077 + $MKDIR "$_G_tmpdir" + umask $func_mktempdir_umask + fi + + # If we're not in dry-run mode, bomb out on failure + test -d "$_G_tmpdir" || \ + func_fatal_error "cannot create temporary directory '$_G_tmpdir'" + fi + + $ECHO "$_G_tmpdir" +} + + +# func_normal_abspath PATH +# ------------------------ +# Remove doubled-up and trailing slashes, "." path components, +# and cancel out any ".." path components in PATH after making +# it an absolute path. +func_normal_abspath () +{ + $debug_cmd + + # These SED scripts presuppose an absolute path with a trailing slash. + _G_pathcar='s|^/\([^/]*\).*$|\1|' + _G_pathcdr='s|^/[^/]*||' + _G_removedotparts=':dotsl + s|/\./|/|g + t dotsl + s|/\.$|/|' + _G_collapseslashes='s|/\{1,\}|/|g' + _G_finalslash='s|/*$|/|' + + # Start from root dir and reassemble the path. + func_normal_abspath_result= + func_normal_abspath_tpath=$1 + func_normal_abspath_altnamespace= + case $func_normal_abspath_tpath in + "") + # Empty path, that just means $cwd. + func_stripname '' '/' "`pwd`" + func_normal_abspath_result=$func_stripname_result + return + ;; + # The next three entries are used to spot a run of precisely + # two leading slashes without using negated character classes; + # we take advantage of case's first-match behaviour. + ///*) + # Unusual form of absolute path, do nothing. + ;; + //*) + # Not necessarily an ordinary path; POSIX reserves leading '//' + # and for example Cygwin uses it to access remote file shares + # over CIFS/SMB, so we conserve a leading double slash if found. + func_normal_abspath_altnamespace=/ + ;; + /*) + # Absolute path, do nothing. + ;; + *) + # Relative path, prepend $cwd. + func_normal_abspath_tpath=`pwd`/$func_normal_abspath_tpath + ;; + esac + + # Cancel out all the simple stuff to save iterations. We also want + # the path to end with a slash for ease of parsing, so make sure + # there is one (and only one) here. + func_normal_abspath_tpath=`$ECHO "$func_normal_abspath_tpath" | $SED \ + -e "$_G_removedotparts" -e "$_G_collapseslashes" -e "$_G_finalslash"` + while :; do + # Processed it all yet? + if test / = "$func_normal_abspath_tpath"; then + # If we ascended to the root using ".." the result may be empty now. + if test -z "$func_normal_abspath_result"; then + func_normal_abspath_result=/ + fi + break + fi + func_normal_abspath_tcomponent=`$ECHO "$func_normal_abspath_tpath" | $SED \ + -e "$_G_pathcar"` + func_normal_abspath_tpath=`$ECHO "$func_normal_abspath_tpath" | $SED \ + -e "$_G_pathcdr"` + # Figure out what to do with it + case $func_normal_abspath_tcomponent in + "") + # Trailing empty path component, ignore it. + ;; + ..) + # Parent dir; strip last assembled component from result. + func_dirname "$func_normal_abspath_result" + func_normal_abspath_result=$func_dirname_result + ;; + *) + # Actual path component, append it. + func_append func_normal_abspath_result "/$func_normal_abspath_tcomponent" + ;; + esac + done + # Restore leading double-slash if one was found on entry. + func_normal_abspath_result=$func_normal_abspath_altnamespace$func_normal_abspath_result +} + + +# func_notquiet ARG... +# -------------------- +# Echo program name prefixed message only when not in quiet mode. +func_notquiet () +{ + $debug_cmd + + $opt_quiet || func_echo ${1+"$@"} + + # A bug in bash halts the script if the last line of a function + # fails when set -e is in force, so we need another command to + # work around that: + : +} + + +# func_relative_path SRCDIR DSTDIR +# -------------------------------- +# Set func_relative_path_result to the relative path from SRCDIR to DSTDIR. +func_relative_path () +{ + $debug_cmd + + func_relative_path_result= + func_normal_abspath "$1" + func_relative_path_tlibdir=$func_normal_abspath_result + func_normal_abspath "$2" + func_relative_path_tbindir=$func_normal_abspath_result + + # Ascend the tree starting from libdir + while :; do + # check if we have found a prefix of bindir + case $func_relative_path_tbindir in + $func_relative_path_tlibdir) + # found an exact match + func_relative_path_tcancelled= + break + ;; + $func_relative_path_tlibdir*) + # found a matching prefix + func_stripname "$func_relative_path_tlibdir" '' "$func_relative_path_tbindir" + func_relative_path_tcancelled=$func_stripname_result + if test -z "$func_relative_path_result"; then + func_relative_path_result=. + fi + break + ;; + *) + func_dirname $func_relative_path_tlibdir + func_relative_path_tlibdir=$func_dirname_result + if test -z "$func_relative_path_tlibdir"; then + # Have to descend all the way to the root! + func_relative_path_result=../$func_relative_path_result + func_relative_path_tcancelled=$func_relative_path_tbindir + break + fi + func_relative_path_result=../$func_relative_path_result + ;; + esac + done + + # Now calculate path; take care to avoid doubling-up slashes. + func_stripname '' '/' "$func_relative_path_result" + func_relative_path_result=$func_stripname_result + func_stripname '/' '/' "$func_relative_path_tcancelled" + if test -n "$func_stripname_result"; then + func_append func_relative_path_result "/$func_stripname_result" + fi + + # Normalisation. If bindir is libdir, return '.' else relative path. + if test -n "$func_relative_path_result"; then + func_stripname './' '' "$func_relative_path_result" + func_relative_path_result=$func_stripname_result + fi + + test -n "$func_relative_path_result" || func_relative_path_result=. + + : +} + + +# func_quote_portable EVAL ARG +# ---------------------------- +# Internal function to portably implement func_quote_arg. Note that we still +# keep attention to performance here so we as much as possible try to avoid +# calling sed binary (so far O(N) complexity as long as func_append is O(1)). +func_quote_portable () +{ + $debug_cmd + + $require_check_ifs_backslash + + func_quote_portable_result=$2 + + # one-time-loop (easy break) + while true + do + if $1; then + func_quote_portable_result=`$ECHO "$2" | $SED \ + -e "$sed_double_quote_subst" -e "$sed_double_backslash"` + break + fi + + # Quote for eval. + case $func_quote_portable_result in + *[\\\`\"\$]*) + # Fallback to sed for $func_check_bs_ifs_broken=:, or when the string + # contains the shell wildcard characters. + case $check_ifs_backshlash_broken$func_quote_portable_result in + :*|*[\[\*\?]*) + func_quote_portable_result=`$ECHO "$func_quote_portable_result" \ + | $SED "$sed_quote_subst"` + break + ;; + esac + + func_quote_portable_old_IFS=$IFS + for _G_char in '\' '`' '"' '$' + do + # STATE($1) PREV($2) SEPARATOR($3) + set start "" "" + func_quote_portable_result=dummy"$_G_char$func_quote_portable_result$_G_char"dummy + IFS=$_G_char + for _G_part in $func_quote_portable_result + do + case $1 in + quote) + func_append func_quote_portable_result "$3$2" + set quote "$_G_part" "\\$_G_char" + ;; + start) + set first "" "" + func_quote_portable_result= + ;; + first) + set quote "$_G_part" "" + ;; + esac + done + done + IFS=$func_quote_portable_old_IFS + ;; + *) ;; + esac + break + done + + func_quote_portable_unquoted_result=$func_quote_portable_result + case $func_quote_portable_result in + # double-quote args containing shell metacharacters to delay + # word splitting, command substitution and variable expansion + # for a subsequent eval. + # many bourne shells cannot handle close brackets correctly + # in scan sets, so we specify it separately. + *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*|"") + func_quote_portable_result=\"$func_quote_portable_result\" + ;; + esac +} + + +# func_quotefast_eval ARG +# ----------------------- +# Quote one ARG (internal). This is equivalent to 'func_quote_arg eval ARG', +# but optimized for speed. Result is stored in $func_quotefast_eval. +if test xyes = `(x=; printf -v x %q yes; echo x"$x") 2>/dev/null`; then + printf -v _GL_test_printf_tilde %q '~' + if test '\~' = "$_GL_test_printf_tilde"; then + func_quotefast_eval () + { + printf -v func_quotefast_eval_result %q "$1" + } + else + # Broken older Bash implementations. Make those faster too if possible. + func_quotefast_eval () + { + case $1 in + '~'*) + func_quote_portable false "$1" + func_quotefast_eval_result=$func_quote_portable_result + ;; + *) + printf -v func_quotefast_eval_result %q "$1" + ;; + esac + } + fi +else + func_quotefast_eval () + { + func_quote_portable false "$1" + func_quotefast_eval_result=$func_quote_portable_result + } +fi + + +# func_quote_arg MODEs ARG +# ------------------------ +# Quote one ARG to be evaled later. MODEs argument may contain zero or more +# specifiers listed below separated by ',' character. This function returns two +# values: +# i) func_quote_arg_result +# double-quoted (when needed), suitable for a subsequent eval +# ii) func_quote_arg_unquoted_result +# has all characters that are still active within double +# quotes backslashified. Available only if 'unquoted' is specified. +# +# Available modes: +# ---------------- +# 'eval' (default) +# - escape shell special characters +# 'expand' +# - the same as 'eval'; but do not quote variable references +# 'pretty' +# - request aesthetic output, i.e. '"a b"' instead of 'a\ b'. This might +# be used later in func_quote to get output like: 'echo "a b"' instead +# of 'echo a\ b'. This is slower than default on some shells. +# 'unquoted' +# - produce also $func_quote_arg_unquoted_result which does not contain +# wrapping double-quotes. +# +# Examples for 'func_quote_arg pretty,unquoted string': +# +# string | *_result | *_unquoted_result +# ------------+-----------------------+------------------- +# " | \" | \" +# a b | "a b" | a b +# "a b" | "\"a b\"" | \"a b\" +# * | "*" | * +# z="${x-$y}" | "z=\"\${x-\$y}\"" | z=\"\${x-\$y}\" +# +# Examples for 'func_quote_arg pretty,unquoted,expand string': +# +# string | *_result | *_unquoted_result +# --------------+---------------------+-------------------- +# z="${x-$y}" | "z=\"${x-$y}\"" | z=\"${x-$y}\" +func_quote_arg () +{ + _G_quote_expand=false + case ,$1, in + *,expand,*) + _G_quote_expand=: + ;; + esac + + case ,$1, in + *,pretty,*|*,expand,*|*,unquoted,*) + func_quote_portable $_G_quote_expand "$2" + func_quote_arg_result=$func_quote_portable_result + func_quote_arg_unquoted_result=$func_quote_portable_unquoted_result + ;; + *) + # Faster quote-for-eval for some shells. + func_quotefast_eval "$2" + func_quote_arg_result=$func_quotefast_eval_result + ;; + esac +} + + +# func_quote MODEs ARGs... +# ------------------------ +# Quote all ARGs to be evaled later and join them into single command. See +# func_quote_arg's description for more info. +func_quote () +{ + $debug_cmd + _G_func_quote_mode=$1 ; shift + func_quote_result= + while test 0 -lt $#; do + func_quote_arg "$_G_func_quote_mode" "$1" + if test -n "$func_quote_result"; then + func_append func_quote_result " $func_quote_arg_result" + else + func_append func_quote_result "$func_quote_arg_result" + fi + shift + done +} + + +# func_stripname PREFIX SUFFIX NAME +# --------------------------------- +# strip PREFIX and SUFFIX from NAME, and store in func_stripname_result. +# PREFIX and SUFFIX must not contain globbing or regex special +# characters, hashes, percent signs, but SUFFIX may contain a leading +# dot (in which case that matches only a dot). +if test yes = "$_G_HAVE_XSI_OPS"; then + eval 'func_stripname () + { + $debug_cmd + + # pdksh 5.2.14 does not do ${X%$Y} correctly if both X and Y are + # positional parameters, so assign one to ordinary variable first. + func_stripname_result=$3 + func_stripname_result=${func_stripname_result#"$1"} + func_stripname_result=${func_stripname_result%"$2"} + }' +else + func_stripname () + { + $debug_cmd + + case $2 in + .*) func_stripname_result=`$ECHO "$3" | $SED -e "s%^$1%%" -e "s%\\\\$2\$%%"`;; + *) func_stripname_result=`$ECHO "$3" | $SED -e "s%^$1%%" -e "s%$2\$%%"`;; + esac + } +fi + + +# func_show_eval CMD [FAIL_EXP] +# ----------------------------- +# Unless opt_quiet is true, then output CMD. Then, if opt_dryrun is +# not true, evaluate CMD. If the evaluation of CMD fails, and FAIL_EXP +# is given, then evaluate it. +func_show_eval () +{ + $debug_cmd + + _G_cmd=$1 + _G_fail_exp=${2-':'} + + func_quote_arg pretty,expand "$_G_cmd" + eval "func_notquiet $func_quote_arg_result" + + $opt_dry_run || { + eval "$_G_cmd" + _G_status=$? + if test 0 -ne "$_G_status"; then + eval "(exit $_G_status); $_G_fail_exp" + fi + } +} + + +# func_show_eval_locale CMD [FAIL_EXP] +# ------------------------------------ +# Unless opt_quiet is true, then output CMD. Then, if opt_dryrun is +# not true, evaluate CMD. If the evaluation of CMD fails, and FAIL_EXP +# is given, then evaluate it. Use the saved locale for evaluation. +func_show_eval_locale () +{ + $debug_cmd + + _G_cmd=$1 + _G_fail_exp=${2-':'} + + $opt_quiet || { + func_quote_arg expand,pretty "$_G_cmd" + eval "func_echo $func_quote_arg_result" + } + + $opt_dry_run || { + eval "$_G_user_locale + $_G_cmd" + _G_status=$? + eval "$_G_safe_locale" + if test 0 -ne "$_G_status"; then + eval "(exit $_G_status); $_G_fail_exp" + fi + } +} + + +# func_tr_sh +# ---------- +# Turn $1 into a string suitable for a shell variable name. +# Result is stored in $func_tr_sh_result. All characters +# not in the set a-zA-Z0-9_ are replaced with '_'. Further, +# if $1 begins with a digit, a '_' is prepended as well. +func_tr_sh () +{ + $debug_cmd + + case $1 in + [0-9]* | *[!a-zA-Z0-9_]*) + func_tr_sh_result=`$ECHO "$1" | $SED -e 's/^\([0-9]\)/_\1/' -e 's/[^a-zA-Z0-9_]/_/g'` + ;; + * ) + func_tr_sh_result=$1 + ;; + esac +} + + +# func_verbose ARG... +# ------------------- +# Echo program name prefixed message in verbose mode only. +func_verbose () +{ + $debug_cmd + + $opt_verbose && func_echo "$*" + + : +} + + +# func_warn_and_continue ARG... +# ----------------------------- +# Echo program name prefixed warning message to standard error. +func_warn_and_continue () +{ + $debug_cmd + + $require_term_colors + + func_echo_infix_1 "${tc_red}warning$tc_reset" "$*" >&2 +} + + +# func_warning CATEGORY ARG... +# ---------------------------- +# Echo program name prefixed warning message to standard error. Warning +# messages can be filtered according to CATEGORY, where this function +# elides messages where CATEGORY is not listed in the global variable +# 'opt_warning_types'. +func_warning () +{ + $debug_cmd + + # CATEGORY must be in the warning_categories list! + case " $warning_categories " in + *" $1 "*) ;; + *) func_internal_error "invalid warning category '$1'" ;; + esac + + _G_category=$1 + shift + + case " $opt_warning_types " in + *" $_G_category "*) $warning_func ${1+"$@"} ;; + esac +} + + +# func_sort_ver VER1 VER2 +# ----------------------- +# 'sort -V' is not generally available. +# Note this deviates from the version comparison in automake +# in that it treats 1.5 < 1.5.0, and treats 1.4.4a < 1.4-p3a +# but this should suffice as we won't be specifying old +# version formats or redundant trailing .0 in bootstrap.conf. +# If we did want full compatibility then we should probably +# use m4_version_compare from autoconf. +func_sort_ver () +{ + $debug_cmd + + printf '%s\n%s\n' "$1" "$2" \ + | sort -t. -k 1,1n -k 2,2n -k 3,3n -k 4,4n -k 5,5n -k 6,6n -k 7,7n -k 8,8n -k 9,9n +} + +# func_lt_ver PREV CURR +# --------------------- +# Return true if PREV and CURR are in the correct order according to +# func_sort_ver, otherwise false. Use it like this: +# +# func_lt_ver "$prev_ver" "$proposed_ver" || func_fatal_error "..." +func_lt_ver () +{ + $debug_cmd + + test "x$1" = x`func_sort_ver "$1" "$2" | $SED 1q` +} + + +# Local variables: +# mode: shell-script +# sh-indentation: 2 +# eval: (add-hook 'before-save-hook 'time-stamp) +# time-stamp-pattern: "10/scriptversion=%:y-%02m-%02d.%02H; # UTC" +# time-stamp-time-zone: "UTC" +# End: +#! /bin/sh + +# A portable, pluggable option parser for Bourne shell. +# Written by Gary V. Vaughan, 2010 + +# This is free software. There is NO warranty; not even for +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +# +# Copyright (C) 2010-2019, 2021 Bootstrap Authors +# +# This file is dual licensed under the terms of the MIT license +# , and GPL version 2 or later +# . You must apply one of +# these licenses when using or redistributing this software or any of +# the files within it. See the URLs above, or the file `LICENSE` +# included in the Bootstrap distribution for the full license texts. + +# Please report bugs or propose patches to: +# + +# Set a version string for this script. +scriptversion=2019-02-19.15; # UTC + + +## ------ ## +## Usage. ## +## ------ ## + +# This file is a library for parsing options in your shell scripts along +# with assorted other useful supporting features that you can make use +# of too. +# +# For the simplest scripts you might need only: +# +# #!/bin/sh +# . relative/path/to/funclib.sh +# . relative/path/to/options-parser +# scriptversion=1.0 +# func_options ${1+"$@"} +# eval set dummy "$func_options_result"; shift +# ...rest of your script... +# +# In order for the '--version' option to work, you will need to have a +# suitably formatted comment like the one at the top of this file +# starting with '# Written by ' and ending with '# Copyright'. +# +# For '-h' and '--help' to work, you will also need a one line +# description of your script's purpose in a comment directly above the +# '# Written by ' line, like the one at the top of this file. +# +# The default options also support '--debug', which will turn on shell +# execution tracing (see the comment above debug_cmd below for another +# use), and '--verbose' and the func_verbose function to allow your script +# to display verbose messages only when your user has specified +# '--verbose'. +# +# After sourcing this file, you can plug in processing for additional +# options by amending the variables from the 'Configuration' section +# below, and following the instructions in the 'Option parsing' +# section further down. + +## -------------- ## +## Configuration. ## +## -------------- ## + +# You should override these variables in your script after sourcing this +# file so that they reflect the customisations you have added to the +# option parser. + +# The usage line for option parsing errors and the start of '-h' and +# '--help' output messages. You can embed shell variables for delayed +# expansion at the time the message is displayed, but you will need to +# quote other shell meta-characters carefully to prevent them being +# expanded when the contents are evaled. +usage='$progpath [OPTION]...' + +# Short help message in response to '-h' and '--help'. Add to this or +# override it after sourcing this library to reflect the full set of +# options your script accepts. +usage_message="\ + --debug enable verbose shell tracing + -W, --warnings=CATEGORY + report the warnings falling in CATEGORY [all] + -v, --verbose verbosely report processing + --version print version information and exit + -h, --help print short or long help message and exit +" + +# Additional text appended to 'usage_message' in response to '--help'. +long_help_message=" +Warning categories include: + 'all' show all warnings + 'none' turn off all the warnings + 'error' warnings are treated as fatal errors" + +# Help message printed before fatal option parsing errors. +fatal_help="Try '\$progname --help' for more information." + + + +## ------------------------- ## +## Hook function management. ## +## ------------------------- ## + +# This section contains functions for adding, removing, and running hooks +# in the main code. A hook is just a list of function names that can be +# run in order later on. + +# func_hookable FUNC_NAME +# ----------------------- +# Declare that FUNC_NAME will run hooks added with +# 'func_add_hook FUNC_NAME ...'. +func_hookable () +{ + $debug_cmd + + func_append hookable_fns " $1" +} + + +# func_add_hook FUNC_NAME HOOK_FUNC +# --------------------------------- +# Request that FUNC_NAME call HOOK_FUNC before it returns. FUNC_NAME must +# first have been declared "hookable" by a call to 'func_hookable'. +func_add_hook () +{ + $debug_cmd + + case " $hookable_fns " in + *" $1 "*) ;; + *) func_fatal_error "'$1' does not accept hook functions." ;; + esac + + eval func_append ${1}_hooks '" $2"' +} + + +# func_remove_hook FUNC_NAME HOOK_FUNC +# ------------------------------------ +# Remove HOOK_FUNC from the list of hook functions to be called by +# FUNC_NAME. +func_remove_hook () +{ + $debug_cmd + + eval ${1}_hooks='`$ECHO "\$'$1'_hooks" |$SED "s| '$2'||"`' +} + + +# func_propagate_result FUNC_NAME_A FUNC_NAME_B +# --------------------------------------------- +# If the *_result variable of FUNC_NAME_A _is set_, assign its value to +# *_result variable of FUNC_NAME_B. +func_propagate_result () +{ + $debug_cmd + + func_propagate_result_result=: + if eval "test \"\${${1}_result+set}\" = set" + then + eval "${2}_result=\$${1}_result" + else + func_propagate_result_result=false + fi +} + + +# func_run_hooks FUNC_NAME [ARG]... +# --------------------------------- +# Run all hook functions registered to FUNC_NAME. +# It's assumed that the list of hook functions contains nothing more +# than a whitespace-delimited list of legal shell function names, and +# no effort is wasted trying to catch shell meta-characters or preserve +# whitespace. +func_run_hooks () +{ + $debug_cmd + + _G_rc_run_hooks=false + + case " $hookable_fns " in + *" $1 "*) ;; + *) func_fatal_error "'$1' does not support hook functions." ;; + esac + + eval _G_hook_fns=\$$1_hooks; shift + + for _G_hook in $_G_hook_fns; do + func_unset "${_G_hook}_result" + eval $_G_hook '${1+"$@"}' + func_propagate_result $_G_hook func_run_hooks + if $func_propagate_result_result; then + eval set dummy "$func_run_hooks_result"; shift + fi + done +} + + + +## --------------- ## +## Option parsing. ## +## --------------- ## + +# In order to add your own option parsing hooks, you must accept the +# full positional parameter list from your hook function. You may remove +# or edit any options that you action, and then pass back the remaining +# unprocessed options in '_result', escaped +# suitably for 'eval'. +# +# The '_result' variable is automatically unset +# before your hook gets called; for best performance, only set the +# *_result variable when necessary (i.e. don't call the 'func_quote' +# function unnecessarily because it can be an expensive operation on some +# machines). +# +# Like this: +# +# my_options_prep () +# { +# $debug_cmd +# +# # Extend the existing usage message. +# usage_message=$usage_message' +# -s, --silent don'\''t print informational messages +# ' +# # No change in '$@' (ignored completely by this hook). Leave +# # my_options_prep_result variable intact. +# } +# func_add_hook func_options_prep my_options_prep +# +# +# my_silent_option () +# { +# $debug_cmd +# +# args_changed=false +# +# # Note that, for efficiency, we parse as many options as we can +# # recognise in a loop before passing the remainder back to the +# # caller on the first unrecognised argument we encounter. +# while test $# -gt 0; do +# opt=$1; shift +# case $opt in +# --silent|-s) opt_silent=: +# args_changed=: +# ;; +# # Separate non-argument short options: +# -s*) func_split_short_opt "$_G_opt" +# set dummy "$func_split_short_opt_name" \ +# "-$func_split_short_opt_arg" ${1+"$@"} +# shift +# args_changed=: +# ;; +# *) # Make sure the first unrecognised option "$_G_opt" +# # is added back to "$@" in case we need it later, +# # if $args_changed was set to 'true'. +# set dummy "$_G_opt" ${1+"$@"}; shift; break ;; +# esac +# done +# +# # Only call 'func_quote' here if we processed at least one argument. +# if $args_changed; then +# func_quote eval ${1+"$@"} +# my_silent_option_result=$func_quote_result +# fi +# } +# func_add_hook func_parse_options my_silent_option +# +# +# my_option_validation () +# { +# $debug_cmd +# +# $opt_silent && $opt_verbose && func_fatal_help "\ +# '--silent' and '--verbose' options are mutually exclusive." +# } +# func_add_hook func_validate_options my_option_validation +# +# You'll also need to manually amend $usage_message to reflect the extra +# options you parse. It's preferable to append if you can, so that +# multiple option parsing hooks can be added safely. + + +# func_options_finish [ARG]... +# ---------------------------- +# Finishing the option parse loop (call 'func_options' hooks ATM). +func_options_finish () +{ + $debug_cmd + + func_run_hooks func_options ${1+"$@"} + func_propagate_result func_run_hooks func_options_finish +} + + +# func_options [ARG]... +# --------------------- +# All the functions called inside func_options are hookable. See the +# individual implementations for details. +func_hookable func_options +func_options () +{ + $debug_cmd + + _G_options_quoted=false + + for my_func in options_prep parse_options validate_options options_finish + do + func_unset func_${my_func}_result + func_unset func_run_hooks_result + eval func_$my_func '${1+"$@"}' + func_propagate_result func_$my_func func_options + if $func_propagate_result_result; then + eval set dummy "$func_options_result"; shift + _G_options_quoted=: + fi + done + + $_G_options_quoted || { + # As we (func_options) are top-level options-parser function and + # nobody quoted "$@" for us yet, we need to do it explicitly for + # caller. + func_quote eval ${1+"$@"} + func_options_result=$func_quote_result + } +} + + +# func_options_prep [ARG]... +# -------------------------- +# All initialisations required before starting the option parse loop. +# Note that when calling hook functions, we pass through the list of +# positional parameters. If a hook function modifies that list, and +# needs to propagate that back to rest of this script, then the complete +# modified list must be put in 'func_run_hooks_result' before returning. +func_hookable func_options_prep +func_options_prep () +{ + $debug_cmd + + # Option defaults: + opt_verbose=false + opt_warning_types= + + func_run_hooks func_options_prep ${1+"$@"} + func_propagate_result func_run_hooks func_options_prep +} + + +# func_parse_options [ARG]... +# --------------------------- +# The main option parsing loop. +func_hookable func_parse_options +func_parse_options () +{ + $debug_cmd + + _G_parse_options_requote=false + # this just eases exit handling + while test $# -gt 0; do + # Defer to hook functions for initial option parsing, so they + # get priority in the event of reusing an option name. + func_run_hooks func_parse_options ${1+"$@"} + func_propagate_result func_run_hooks func_parse_options + if $func_propagate_result_result; then + eval set dummy "$func_parse_options_result"; shift + # Even though we may have changed "$@", we passed the "$@" array + # down into the hook and it quoted it for us (because we are in + # this if-branch). No need to quote it again. + _G_parse_options_requote=false + fi + + # Break out of the loop if we already parsed every option. + test $# -gt 0 || break + + # We expect that one of the options parsed in this function matches + # and thus we remove _G_opt from "$@" and need to re-quote. + _G_match_parse_options=: + _G_opt=$1 + shift + case $_G_opt in + --debug|-x) debug_cmd='set -x' + func_echo "enabling shell trace mode" >&2 + $debug_cmd + ;; + + --no-warnings|--no-warning|--no-warn) + set dummy --warnings none ${1+"$@"} + shift + ;; + + --warnings|--warning|-W) + if test $# = 0 && func_missing_arg $_G_opt; then + _G_parse_options_requote=: + break + fi + case " $warning_categories $1" in + *" $1 "*) + # trailing space prevents matching last $1 above + func_append_uniq opt_warning_types " $1" + ;; + *all) + opt_warning_types=$warning_categories + ;; + *none) + opt_warning_types=none + warning_func=: + ;; + *error) + opt_warning_types=$warning_categories + warning_func=func_fatal_error + ;; + *) + func_fatal_error \ + "unsupported warning category: '$1'" + ;; + esac + shift + ;; + + --verbose|-v) opt_verbose=: ;; + --version) func_version ;; + -\?|-h) func_usage ;; + --help) func_help ;; + + # Separate optargs to long options (plugins may need this): + --*=*) func_split_equals "$_G_opt" + set dummy "$func_split_equals_lhs" \ + "$func_split_equals_rhs" ${1+"$@"} + shift + ;; + + # Separate optargs to short options: + -W*) + func_split_short_opt "$_G_opt" + set dummy "$func_split_short_opt_name" \ + "$func_split_short_opt_arg" ${1+"$@"} + shift + ;; + + # Separate non-argument short options: + -\?*|-h*|-v*|-x*) + func_split_short_opt "$_G_opt" + set dummy "$func_split_short_opt_name" \ + "-$func_split_short_opt_arg" ${1+"$@"} + shift + ;; + + --) _G_parse_options_requote=: ; break ;; + -*) func_fatal_help "unrecognised option: '$_G_opt'" ;; + *) set dummy "$_G_opt" ${1+"$@"}; shift + _G_match_parse_options=false + break + ;; + esac + + if $_G_match_parse_options; then + _G_parse_options_requote=: + fi + done + + if $_G_parse_options_requote; then + # save modified positional parameters for caller + func_quote eval ${1+"$@"} + func_parse_options_result=$func_quote_result + fi +} + + +# func_validate_options [ARG]... +# ------------------------------ +# Perform any sanity checks on option settings and/or unconsumed +# arguments. +func_hookable func_validate_options +func_validate_options () +{ + $debug_cmd + + # Display all warnings if -W was not given. + test -n "$opt_warning_types" || opt_warning_types=" $warning_categories" + + func_run_hooks func_validate_options ${1+"$@"} + func_propagate_result func_run_hooks func_validate_options + + # Bail if the options were screwed! + $exit_cmd $EXIT_FAILURE +} + + + +## ----------------- ## +## Helper functions. ## +## ----------------- ## + +# This section contains the helper functions used by the rest of the +# hookable option parser framework in ascii-betical order. + + +# func_fatal_help ARG... +# ---------------------- +# Echo program name prefixed message to standard error, followed by +# a help hint, and exit. +func_fatal_help () +{ + $debug_cmd + + eval \$ECHO \""Usage: $usage"\" + eval \$ECHO \""$fatal_help"\" + func_error ${1+"$@"} + exit $EXIT_FAILURE +} + + +# func_help +# --------- +# Echo long help message to standard output and exit. +func_help () +{ + $debug_cmd + + func_usage_message + $ECHO "$long_help_message" + exit 0 +} + + +# func_missing_arg ARGNAME +# ------------------------ +# Echo program name prefixed message to standard error and set global +# exit_cmd. +func_missing_arg () +{ + $debug_cmd + + func_error "Missing argument for '$1'." + exit_cmd=exit +} + + +# func_split_equals STRING +# ------------------------ +# Set func_split_equals_lhs and func_split_equals_rhs shell variables +# after splitting STRING at the '=' sign. +test -z "$_G_HAVE_XSI_OPS" \ + && (eval 'x=a/b/c; + test 5aa/bb/cc = "${#x}${x%%/*}${x%/*}${x#*/}${x##*/}"') 2>/dev/null \ + && _G_HAVE_XSI_OPS=yes + +if test yes = "$_G_HAVE_XSI_OPS" +then + # This is an XSI compatible shell, allowing a faster implementation... + eval 'func_split_equals () + { + $debug_cmd + + func_split_equals_lhs=${1%%=*} + func_split_equals_rhs=${1#*=} + if test "x$func_split_equals_lhs" = "x$1"; then + func_split_equals_rhs= + fi + }' +else + # ...otherwise fall back to using expr, which is often a shell builtin. + func_split_equals () + { + $debug_cmd + + func_split_equals_lhs=`expr "x$1" : 'x\([^=]*\)'` + func_split_equals_rhs= + test "x$func_split_equals_lhs=" = "x$1" \ + || func_split_equals_rhs=`expr "x$1" : 'x[^=]*=\(.*\)$'` + } +fi #func_split_equals + + +# func_split_short_opt SHORTOPT +# ----------------------------- +# Set func_split_short_opt_name and func_split_short_opt_arg shell +# variables after splitting SHORTOPT after the 2nd character. +if test yes = "$_G_HAVE_XSI_OPS" +then + # This is an XSI compatible shell, allowing a faster implementation... + eval 'func_split_short_opt () + { + $debug_cmd + + func_split_short_opt_arg=${1#??} + func_split_short_opt_name=${1%"$func_split_short_opt_arg"} + }' +else + # ...otherwise fall back to using expr, which is often a shell builtin. + func_split_short_opt () + { + $debug_cmd + + func_split_short_opt_name=`expr "x$1" : 'x\(-.\)'` + func_split_short_opt_arg=`expr "x$1" : 'x-.\(.*\)$'` + } +fi #func_split_short_opt + + +# func_usage +# ---------- +# Echo short help message to standard output and exit. +func_usage () +{ + $debug_cmd + + func_usage_message + $ECHO "Run '$progname --help |${PAGER-more}' for full usage" + exit 0 +} + + +# func_usage_message +# ------------------ +# Echo short help message to standard output. +func_usage_message () +{ + $debug_cmd + + eval \$ECHO \""Usage: $usage"\" + echo + $SED -n 's|^# || + /^Written by/{ + x;p;x + } + h + /^Written by/q' < "$progpath" + echo + eval \$ECHO \""$usage_message"\" +} + + +# func_version +# ------------ +# Echo version message to standard output and exit. +# The version message is extracted from the calling file's header +# comments, with leading '# ' stripped: +# 1. First display the progname and version +# 2. Followed by the header comment line matching /^# Written by / +# 3. Then a blank line followed by the first following line matching +# /^# Copyright / +# 4. Immediately followed by any lines between the previous matches, +# except lines preceding the intervening completely blank line. +# For example, see the header comments of this file. +func_version () +{ + $debug_cmd + + printf '%s\n' "$progname $scriptversion" + $SED -n ' + /^# Written by /!b + s|^# ||; p; n + + :fwd2blnk + /./ { + n + b fwd2blnk + } + p; n + + :holdwrnt + s|^# || + s|^# *$|| + /^Copyright /!{ + /./H + n + b holdwrnt + } + + s|\((C)\)[ 0-9,-]*[ ,-]\([1-9][0-9]* \)|\1 \2| + G + s|\(\n\)\n*|\1|g + p; q' < "$progpath" + + exit $? +} + + +# Local variables: +# mode: shell-script +# sh-indentation: 2 +# eval: (add-hook 'before-save-hook 'time-stamp) +# time-stamp-pattern: "30/scriptversion=%:y-%02m-%02d.%02H; # UTC" +# time-stamp-time-zone: "UTC" +# End: + +# Set a version string. +scriptversion='(GNU libtool) 2.4.7' + + +# func_echo ARG... +# ---------------- +# Libtool also displays the current mode in messages, so override +# funclib.sh func_echo with this custom definition. +func_echo () +{ + $debug_cmd + + _G_message=$* + + func_echo_IFS=$IFS + IFS=$nl + for _G_line in $_G_message; do + IFS=$func_echo_IFS + $ECHO "$progname${opt_mode+: $opt_mode}: $_G_line" + done + IFS=$func_echo_IFS +} + + +# func_warning ARG... +# ------------------- +# Libtool warnings are not categorized, so override funclib.sh +# func_warning with this simpler definition. +func_warning () +{ + $debug_cmd + + $warning_func ${1+"$@"} +} + + +## ---------------- ## +## Options parsing. ## +## ---------------- ## + +# Hook in the functions to make sure our own options are parsed during +# the option parsing loop. + +usage='$progpath [OPTION]... [MODE-ARG]...' + +# Short help message in response to '-h'. +usage_message="Options: + --config show all configuration variables + --debug enable verbose shell tracing + -n, --dry-run display commands without modifying any files + --features display basic configuration information and exit + --mode=MODE use operation mode MODE + --no-warnings equivalent to '-Wnone' + --preserve-dup-deps don't remove duplicate dependency libraries + --quiet, --silent don't print informational messages + --tag=TAG use configuration variables from tag TAG + -v, --verbose print more informational messages than default + --version print version information + -W, --warnings=CATEGORY report the warnings falling in CATEGORY [all] + -h, --help, --help-all print short, long, or detailed help message +" + +# Additional text appended to 'usage_message' in response to '--help'. +func_help () +{ + $debug_cmd + + func_usage_message + $ECHO "$long_help_message + +MODE must be one of the following: + + clean remove files from the build directory + compile compile a source file into a libtool object + execute automatically set library path, then run a program + finish complete the installation of libtool libraries + install install libraries or executables + link create a library or an executable + uninstall remove libraries from an installed directory + +MODE-ARGS vary depending on the MODE. When passed as first option, +'--mode=MODE' may be abbreviated as 'MODE' or a unique abbreviation of that. +Try '$progname --help --mode=MODE' for a more detailed description of MODE. + +When reporting a bug, please describe a test case to reproduce it and +include the following information: + + host-triplet: $host + shell: $SHELL + compiler: $LTCC + compiler flags: $LTCFLAGS + linker: $LD (gnu? $with_gnu_ld) + version: $progname $scriptversion Debian-2.4.7-7~deb12u1 + automake: `($AUTOMAKE --version) 2>/dev/null |$SED 1q` + autoconf: `($AUTOCONF --version) 2>/dev/null |$SED 1q` + +Report bugs to . +GNU libtool home page: . +General help using GNU software: ." + exit 0 +} + + +# func_lo2o OBJECT-NAME +# --------------------- +# Transform OBJECT-NAME from a '.lo' suffix to the platform specific +# object suffix. + +lo2o=s/\\.lo\$/.$objext/ +o2lo=s/\\.$objext\$/.lo/ + +if test yes = "$_G_HAVE_XSI_OPS"; then + eval 'func_lo2o () + { + case $1 in + *.lo) func_lo2o_result=${1%.lo}.$objext ;; + * ) func_lo2o_result=$1 ;; + esac + }' + + # func_xform LIBOBJ-OR-SOURCE + # --------------------------- + # Transform LIBOBJ-OR-SOURCE from a '.o' or '.c' (or otherwise) + # suffix to a '.lo' libtool-object suffix. + eval 'func_xform () + { + func_xform_result=${1%.*}.lo + }' +else + # ...otherwise fall back to using sed. + func_lo2o () + { + func_lo2o_result=`$ECHO "$1" | $SED "$lo2o"` + } + + func_xform () + { + func_xform_result=`$ECHO "$1" | $SED 's|\.[^.]*$|.lo|'` + } +fi + + +# func_fatal_configuration ARG... +# ------------------------------- +# Echo program name prefixed message to standard error, followed by +# a configuration failure hint, and exit. +func_fatal_configuration () +{ + func_fatal_error ${1+"$@"} \ + "See the $PACKAGE documentation for more information." \ + "Fatal configuration error." +} + + +# func_config +# ----------- +# Display the configuration for all the tags in this script. +func_config () +{ + re_begincf='^# ### BEGIN LIBTOOL' + re_endcf='^# ### END LIBTOOL' + + # Default configuration. + $SED "1,/$re_begincf CONFIG/d;/$re_endcf CONFIG/,\$d" < "$progpath" + + # Now print the configurations for the tags. + for tagname in $taglist; do + $SED -n "/$re_begincf TAG CONFIG: $tagname\$/,/$re_endcf TAG CONFIG: $tagname\$/p" < "$progpath" + done + + exit $? +} + + +# func_features +# ------------- +# Display the features supported by this script. +func_features () +{ + echo "host: $host" + if test yes = "$build_libtool_libs"; then + echo "enable shared libraries" + else + echo "disable shared libraries" + fi + if test yes = "$build_old_libs"; then + echo "enable static libraries" + else + echo "disable static libraries" + fi + + exit $? +} + + +# func_enable_tag TAGNAME +# ----------------------- +# Verify that TAGNAME is valid, and either flag an error and exit, or +# enable the TAGNAME tag. We also add TAGNAME to the global $taglist +# variable here. +func_enable_tag () +{ + # Global variable: + tagname=$1 + + re_begincf="^# ### BEGIN LIBTOOL TAG CONFIG: $tagname\$" + re_endcf="^# ### END LIBTOOL TAG CONFIG: $tagname\$" + sed_extractcf=/$re_begincf/,/$re_endcf/p + + # Validate tagname. + case $tagname in + *[!-_A-Za-z0-9,/]*) + func_fatal_error "invalid tag name: $tagname" + ;; + esac + + # Don't test for the "default" C tag, as we know it's + # there but not specially marked. + case $tagname in + CC) ;; + *) + if $GREP "$re_begincf" "$progpath" >/dev/null 2>&1; then + taglist="$taglist $tagname" + + # Evaluate the configuration. Be careful to quote the path + # and the sed script, to avoid splitting on whitespace, but + # also don't use non-portable quotes within backquotes within + # quotes we have to do it in 2 steps: + extractedcf=`$SED -n -e "$sed_extractcf" < "$progpath"` + eval "$extractedcf" + else + func_error "ignoring unknown tag $tagname" + fi + ;; + esac +} + + +# func_check_version_match +# ------------------------ +# Ensure that we are using m4 macros, and libtool script from the same +# release of libtool. +func_check_version_match () +{ + if test "$package_revision" != "$macro_revision"; then + if test "$VERSION" != "$macro_version"; then + if test -z "$macro_version"; then + cat >&2 <<_LT_EOF +$progname: Version mismatch error. This is $PACKAGE $VERSION, but the +$progname: definition of this LT_INIT comes from an older release. +$progname: You should recreate aclocal.m4 with macros from $PACKAGE $VERSION +$progname: and run autoconf again. +_LT_EOF + else + cat >&2 <<_LT_EOF +$progname: Version mismatch error. This is $PACKAGE $VERSION, but the +$progname: definition of this LT_INIT comes from $PACKAGE $macro_version. +$progname: You should recreate aclocal.m4 with macros from $PACKAGE $VERSION +$progname: and run autoconf again. +_LT_EOF + fi + else + cat >&2 <<_LT_EOF +$progname: Version mismatch error. This is $PACKAGE $VERSION, revision $package_revision, +$progname: but the definition of this LT_INIT comes from revision $macro_revision. +$progname: You should recreate aclocal.m4 with macros from revision $package_revision +$progname: of $PACKAGE $VERSION and run autoconf again. +_LT_EOF + fi + + exit $EXIT_MISMATCH + fi +} + + +# libtool_options_prep [ARG]... +# ----------------------------- +# Preparation for options parsed by libtool. +libtool_options_prep () +{ + $debug_mode + + # Option defaults: + opt_config=false + opt_dlopen= + opt_dry_run=false + opt_help=false + opt_mode= + opt_preserve_dup_deps=false + opt_quiet=false + + nonopt= + preserve_args= + + _G_rc_lt_options_prep=: + + _G_rc_lt_options_prep=: + + # Shorthand for --mode=foo, only valid as the first argument + case $1 in + clean|clea|cle|cl) + shift; set dummy --mode clean ${1+"$@"}; shift + ;; + compile|compil|compi|comp|com|co|c) + shift; set dummy --mode compile ${1+"$@"}; shift + ;; + execute|execut|execu|exec|exe|ex|e) + shift; set dummy --mode execute ${1+"$@"}; shift + ;; + finish|finis|fini|fin|fi|f) + shift; set dummy --mode finish ${1+"$@"}; shift + ;; + install|instal|insta|inst|ins|in|i) + shift; set dummy --mode install ${1+"$@"}; shift + ;; + link|lin|li|l) + shift; set dummy --mode link ${1+"$@"}; shift + ;; + uninstall|uninstal|uninsta|uninst|unins|unin|uni|un|u) + shift; set dummy --mode uninstall ${1+"$@"}; shift + ;; + *) + _G_rc_lt_options_prep=false + ;; + esac + + if $_G_rc_lt_options_prep; then + # Pass back the list of options. + func_quote eval ${1+"$@"} + libtool_options_prep_result=$func_quote_result + fi +} +func_add_hook func_options_prep libtool_options_prep + + +# libtool_parse_options [ARG]... +# --------------------------------- +# Provide handling for libtool specific options. +libtool_parse_options () +{ + $debug_cmd + + _G_rc_lt_parse_options=false + + # Perform our own loop to consume as many options as possible in + # each iteration. + while test $# -gt 0; do + _G_match_lt_parse_options=: + _G_opt=$1 + shift + case $_G_opt in + --dry-run|--dryrun|-n) + opt_dry_run=: + ;; + + --config) func_config ;; + + --dlopen|-dlopen) + opt_dlopen="${opt_dlopen+$opt_dlopen +}$1" + shift + ;; + + --preserve-dup-deps) + opt_preserve_dup_deps=: ;; + + --features) func_features ;; + + --finish) set dummy --mode finish ${1+"$@"}; shift ;; + + --help) opt_help=: ;; + + --help-all) opt_help=': help-all' ;; + + --mode) test $# = 0 && func_missing_arg $_G_opt && break + opt_mode=$1 + case $1 in + # Valid mode arguments: + clean|compile|execute|finish|install|link|relink|uninstall) ;; + + # Catch anything else as an error + *) func_error "invalid argument for $_G_opt" + exit_cmd=exit + break + ;; + esac + shift + ;; + + --no-silent|--no-quiet) + opt_quiet=false + func_append preserve_args " $_G_opt" + ;; + + --no-warnings|--no-warning|--no-warn) + opt_warning=false + func_append preserve_args " $_G_opt" + ;; + + --no-verbose) + opt_verbose=false + func_append preserve_args " $_G_opt" + ;; + + --silent|--quiet) + opt_quiet=: + opt_verbose=false + func_append preserve_args " $_G_opt" + ;; + + --tag) test $# = 0 && func_missing_arg $_G_opt && break + opt_tag=$1 + func_append preserve_args " $_G_opt $1" + func_enable_tag "$1" + shift + ;; + + --verbose|-v) opt_quiet=false + opt_verbose=: + func_append preserve_args " $_G_opt" + ;; + + # An option not handled by this hook function: + *) set dummy "$_G_opt" ${1+"$@"} ; shift + _G_match_lt_parse_options=false + break + ;; + esac + $_G_match_lt_parse_options && _G_rc_lt_parse_options=: + done + + if $_G_rc_lt_parse_options; then + # save modified positional parameters for caller + func_quote eval ${1+"$@"} + libtool_parse_options_result=$func_quote_result + fi +} +func_add_hook func_parse_options libtool_parse_options + + + +# libtool_validate_options [ARG]... +# --------------------------------- +# Perform any sanity checks on option settings and/or unconsumed +# arguments. +libtool_validate_options () +{ + # save first non-option argument + if test 0 -lt $#; then + nonopt=$1 + shift + fi + + # preserve --debug + test : = "$debug_cmd" || func_append preserve_args " --debug" + + case $host in + # Solaris2 added to fix http://debbugs.gnu.org/cgi/bugreport.cgi?bug=16452 + # see also: http://gcc.gnu.org/bugzilla/show_bug.cgi?id=59788 + *cygwin* | *mingw* | *pw32* | *cegcc* | *solaris2* | *os2*) + # don't eliminate duplications in $postdeps and $predeps + opt_duplicate_compiler_generated_deps=: + ;; + *) + opt_duplicate_compiler_generated_deps=$opt_preserve_dup_deps + ;; + esac + + $opt_help || { + # Sanity checks first: + func_check_version_match + + test yes != "$build_libtool_libs" \ + && test yes != "$build_old_libs" \ + && func_fatal_configuration "not configured to build any kind of library" + + # Darwin sucks + eval std_shrext=\"$shrext_cmds\" + + # Only execute mode is allowed to have -dlopen flags. + if test -n "$opt_dlopen" && test execute != "$opt_mode"; then + func_error "unrecognized option '-dlopen'" + $ECHO "$help" 1>&2 + exit $EXIT_FAILURE + fi + + # Change the help message to a mode-specific one. + generic_help=$help + help="Try '$progname --help --mode=$opt_mode' for more information." + } + + # Pass back the unparsed argument list + func_quote eval ${1+"$@"} + libtool_validate_options_result=$func_quote_result +} +func_add_hook func_validate_options libtool_validate_options + + +# Process options as early as possible so that --help and --version +# can return quickly. +func_options ${1+"$@"} +eval set dummy "$func_options_result"; shift + + + +## ----------- ## +## Main. ## +## ----------- ## + +magic='%%%MAGIC variable%%%' +magic_exe='%%%MAGIC EXE variable%%%' + +# Global variables. +extracted_archives= +extracted_serial=0 + +# If this variable is set in any of the actions, the command in it +# will be execed at the end. This prevents here-documents from being +# left over by shells. +exec_cmd= + + +# A function that is used when there is no print builtin or printf. +func_fallback_echo () +{ + eval 'cat <<_LTECHO_EOF +$1 +_LTECHO_EOF' +} + +# func_generated_by_libtool +# True iff stdin has been generated by Libtool. This function is only +# a basic sanity check; it will hardly flush out determined imposters. +func_generated_by_libtool_p () +{ + $GREP "^# Generated by .*$PACKAGE" > /dev/null 2>&1 +} + +# func_lalib_p file +# True iff FILE is a libtool '.la' library or '.lo' object file. +# This function is only a basic sanity check; it will hardly flush out +# determined imposters. +func_lalib_p () +{ + test -f "$1" && + $SED -e 4q "$1" 2>/dev/null | func_generated_by_libtool_p +} + +# func_lalib_unsafe_p file +# True iff FILE is a libtool '.la' library or '.lo' object file. +# This function implements the same check as func_lalib_p without +# resorting to external programs. To this end, it redirects stdin and +# closes it afterwards, without saving the original file descriptor. +# As a safety measure, use it only where a negative result would be +# fatal anyway. Works if 'file' does not exist. +func_lalib_unsafe_p () +{ + lalib_p=no + if test -f "$1" && test -r "$1" && exec 5<&0 <"$1"; then + for lalib_p_l in 1 2 3 4 + do + read lalib_p_line + case $lalib_p_line in + \#\ Generated\ by\ *$PACKAGE* ) lalib_p=yes; break;; + esac + done + exec 0<&5 5<&- + fi + test yes = "$lalib_p" +} + +# func_ltwrapper_script_p file +# True iff FILE is a libtool wrapper script +# This function is only a basic sanity check; it will hardly flush out +# determined imposters. +func_ltwrapper_script_p () +{ + test -f "$1" && + $lt_truncate_bin < "$1" 2>/dev/null | func_generated_by_libtool_p +} + +# func_ltwrapper_executable_p file +# True iff FILE is a libtool wrapper executable +# This function is only a basic sanity check; it will hardly flush out +# determined imposters. +func_ltwrapper_executable_p () +{ + func_ltwrapper_exec_suffix= + case $1 in + *.exe) ;; + *) func_ltwrapper_exec_suffix=.exe ;; + esac + $GREP "$magic_exe" "$1$func_ltwrapper_exec_suffix" >/dev/null 2>&1 +} + +# func_ltwrapper_scriptname file +# Assumes file is an ltwrapper_executable +# uses $file to determine the appropriate filename for a +# temporary ltwrapper_script. +func_ltwrapper_scriptname () +{ + func_dirname_and_basename "$1" "" "." + func_stripname '' '.exe' "$func_basename_result" + func_ltwrapper_scriptname_result=$func_dirname_result/$objdir/${func_stripname_result}_ltshwrapper +} + +# func_ltwrapper_p file +# True iff FILE is a libtool wrapper script or wrapper executable +# This function is only a basic sanity check; it will hardly flush out +# determined imposters. +func_ltwrapper_p () +{ + func_ltwrapper_script_p "$1" || func_ltwrapper_executable_p "$1" +} + + +# func_execute_cmds commands fail_cmd +# Execute tilde-delimited COMMANDS. +# If FAIL_CMD is given, eval that upon failure. +# FAIL_CMD may read-access the current command in variable CMD! +func_execute_cmds () +{ + $debug_cmd + + save_ifs=$IFS; IFS='~' + for cmd in $1; do + IFS=$sp$nl + eval cmd=\"$cmd\" + IFS=$save_ifs + func_show_eval "$cmd" "${2-:}" + done + IFS=$save_ifs +} + + +# func_source file +# Source FILE, adding directory component if necessary. +# Note that it is not necessary on cygwin/mingw to append a dot to +# FILE even if both FILE and FILE.exe exist: automatic-append-.exe +# behavior happens only for exec(3), not for open(2)! Also, sourcing +# 'FILE.' does not work on cygwin managed mounts. +func_source () +{ + $debug_cmd + + case $1 in + */* | *\\*) . "$1" ;; + *) . "./$1" ;; + esac +} + + +# func_resolve_sysroot PATH +# Replace a leading = in PATH with a sysroot. Store the result into +# func_resolve_sysroot_result +func_resolve_sysroot () +{ + func_resolve_sysroot_result=$1 + case $func_resolve_sysroot_result in + =*) + func_stripname '=' '' "$func_resolve_sysroot_result" + func_resolve_sysroot_result=$lt_sysroot$func_stripname_result + ;; + esac +} + +# func_replace_sysroot PATH +# If PATH begins with the sysroot, replace it with = and +# store the result into func_replace_sysroot_result. +func_replace_sysroot () +{ + case $lt_sysroot:$1 in + ?*:"$lt_sysroot"*) + func_stripname "$lt_sysroot" '' "$1" + func_replace_sysroot_result='='$func_stripname_result + ;; + *) + # Including no sysroot. + func_replace_sysroot_result=$1 + ;; + esac +} + +# func_infer_tag arg +# Infer tagged configuration to use if any are available and +# if one wasn't chosen via the "--tag" command line option. +# Only attempt this if the compiler in the base compile +# command doesn't match the default compiler. +# arg is usually of the form 'gcc ...' +func_infer_tag () +{ + $debug_cmd + + if test -n "$available_tags" && test -z "$tagname"; then + CC_quoted= + for arg in $CC; do + func_append_quoted CC_quoted "$arg" + done + CC_expanded=`func_echo_all $CC` + CC_quoted_expanded=`func_echo_all $CC_quoted` + case $@ in + # Blanks in the command may have been stripped by the calling shell, + # but not from the CC environment variable when configure was run. + " $CC "* | "$CC "* | " $CC_expanded "* | "$CC_expanded "* | \ + " $CC_quoted"* | "$CC_quoted "* | " $CC_quoted_expanded "* | "$CC_quoted_expanded "*) ;; + # Blanks at the start of $base_compile will cause this to fail + # if we don't check for them as well. + *) + for z in $available_tags; do + if $GREP "^# ### BEGIN LIBTOOL TAG CONFIG: $z$" < "$progpath" > /dev/null; then + # Evaluate the configuration. + eval "`$SED -n -e '/^# ### BEGIN LIBTOOL TAG CONFIG: '$z'$/,/^# ### END LIBTOOL TAG CONFIG: '$z'$/p' < $progpath`" + CC_quoted= + for arg in $CC; do + # Double-quote args containing other shell metacharacters. + func_append_quoted CC_quoted "$arg" + done + CC_expanded=`func_echo_all $CC` + CC_quoted_expanded=`func_echo_all $CC_quoted` + case "$@ " in + " $CC "* | "$CC "* | " $CC_expanded "* | "$CC_expanded "* | \ + " $CC_quoted"* | "$CC_quoted "* | " $CC_quoted_expanded "* | "$CC_quoted_expanded "*) + # The compiler in the base compile command matches + # the one in the tagged configuration. + # Assume this is the tagged configuration we want. + tagname=$z + break + ;; + esac + fi + done + # If $tagname still isn't set, then no tagged configuration + # was found and let the user know that the "--tag" command + # line option must be used. + if test -z "$tagname"; then + func_echo "unable to infer tagged configuration" + func_fatal_error "specify a tag with '--tag'" +# else +# func_verbose "using $tagname tagged configuration" + fi + ;; + esac + fi +} + + + +# func_write_libtool_object output_name pic_name nonpic_name +# Create a libtool object file (analogous to a ".la" file), +# but don't create it if we're doing a dry run. +func_write_libtool_object () +{ + write_libobj=$1 + if test yes = "$build_libtool_libs"; then + write_lobj=\'$2\' + else + write_lobj=none + fi + + if test yes = "$build_old_libs"; then + write_oldobj=\'$3\' + else + write_oldobj=none + fi + + $opt_dry_run || { + cat >${write_libobj}T </dev/null` + if test "$?" -eq 0 && test -n "$func_convert_core_file_wine_to_w32_tmp"; then + func_convert_core_file_wine_to_w32_result=`$ECHO "$func_convert_core_file_wine_to_w32_tmp" | + $SED -e "$sed_naive_backslashify"` + else + func_convert_core_file_wine_to_w32_result= + fi + fi +} +# end: func_convert_core_file_wine_to_w32 + + +# func_convert_core_path_wine_to_w32 ARG +# Helper function used by path conversion functions when $build is *nix, and +# $host is mingw, cygwin, or some other w32 environment. Relies on a correctly +# configured wine environment available, with the winepath program in $build's +# $PATH. Assumes ARG has no leading or trailing path separator characters. +# +# ARG is path to be converted from $build format to win32. +# Result is available in $func_convert_core_path_wine_to_w32_result. +# Unconvertible file (directory) names in ARG are skipped; if no directory names +# are convertible, then the result may be empty. +func_convert_core_path_wine_to_w32 () +{ + $debug_cmd + + # unfortunately, winepath doesn't convert paths, only file names + func_convert_core_path_wine_to_w32_result= + if test -n "$1"; then + oldIFS=$IFS + IFS=: + for func_convert_core_path_wine_to_w32_f in $1; do + IFS=$oldIFS + func_convert_core_file_wine_to_w32 "$func_convert_core_path_wine_to_w32_f" + if test -n "$func_convert_core_file_wine_to_w32_result"; then + if test -z "$func_convert_core_path_wine_to_w32_result"; then + func_convert_core_path_wine_to_w32_result=$func_convert_core_file_wine_to_w32_result + else + func_append func_convert_core_path_wine_to_w32_result ";$func_convert_core_file_wine_to_w32_result" + fi + fi + done + IFS=$oldIFS + fi +} +# end: func_convert_core_path_wine_to_w32 + + +# func_cygpath ARGS... +# Wrapper around calling the cygpath program via LT_CYGPATH. This is used when +# when (1) $build is *nix and Cygwin is hosted via a wine environment; or (2) +# $build is MSYS and $host is Cygwin, or (3) $build is Cygwin. In case (1) or +# (2), returns the Cygwin file name or path in func_cygpath_result (input +# file name or path is assumed to be in w32 format, as previously converted +# from $build's *nix or MSYS format). In case (3), returns the w32 file name +# or path in func_cygpath_result (input file name or path is assumed to be in +# Cygwin format). Returns an empty string on error. +# +# ARGS are passed to cygpath, with the last one being the file name or path to +# be converted. +# +# Specify the absolute *nix (or w32) name to cygpath in the LT_CYGPATH +# environment variable; do not put it in $PATH. +func_cygpath () +{ + $debug_cmd + + if test -n "$LT_CYGPATH" && test -f "$LT_CYGPATH"; then + func_cygpath_result=`$LT_CYGPATH "$@" 2>/dev/null` + if test "$?" -ne 0; then + # on failure, ensure result is empty + func_cygpath_result= + fi + else + func_cygpath_result= + func_error "LT_CYGPATH is empty or specifies non-existent file: '$LT_CYGPATH'" + fi +} +#end: func_cygpath + + +# func_convert_core_msys_to_w32 ARG +# Convert file name or path ARG from MSYS format to w32 format. Return +# result in func_convert_core_msys_to_w32_result. +func_convert_core_msys_to_w32 () +{ + $debug_cmd + + # awkward: cmd appends spaces to result + func_convert_core_msys_to_w32_result=`( cmd //c echo "$1" ) 2>/dev/null | + $SED -e 's/[ ]*$//' -e "$sed_naive_backslashify"` +} +#end: func_convert_core_msys_to_w32 + + +# func_convert_file_check ARG1 ARG2 +# Verify that ARG1 (a file name in $build format) was converted to $host +# format in ARG2. Otherwise, emit an error message, but continue (resetting +# func_to_host_file_result to ARG1). +func_convert_file_check () +{ + $debug_cmd + + if test -z "$2" && test -n "$1"; then + func_error "Could not determine host file name corresponding to" + func_error " '$1'" + func_error "Continuing, but uninstalled executables may not work." + # Fallback: + func_to_host_file_result=$1 + fi +} +# end func_convert_file_check + + +# func_convert_path_check FROM_PATHSEP TO_PATHSEP FROM_PATH TO_PATH +# Verify that FROM_PATH (a path in $build format) was converted to $host +# format in TO_PATH. Otherwise, emit an error message, but continue, resetting +# func_to_host_file_result to a simplistic fallback value (see below). +func_convert_path_check () +{ + $debug_cmd + + if test -z "$4" && test -n "$3"; then + func_error "Could not determine the host path corresponding to" + func_error " '$3'" + func_error "Continuing, but uninstalled executables may not work." + # Fallback. This is a deliberately simplistic "conversion" and + # should not be "improved". See libtool.info. + if test "x$1" != "x$2"; then + lt_replace_pathsep_chars="s|$1|$2|g" + func_to_host_path_result=`echo "$3" | + $SED -e "$lt_replace_pathsep_chars"` + else + func_to_host_path_result=$3 + fi + fi +} +# end func_convert_path_check + + +# func_convert_path_front_back_pathsep FRONTPAT BACKPAT REPL ORIG +# Modifies func_to_host_path_result by prepending REPL if ORIG matches FRONTPAT +# and appending REPL if ORIG matches BACKPAT. +func_convert_path_front_back_pathsep () +{ + $debug_cmd + + case $4 in + $1 ) func_to_host_path_result=$3$func_to_host_path_result + ;; + esac + case $4 in + $2 ) func_append func_to_host_path_result "$3" + ;; + esac +} +# end func_convert_path_front_back_pathsep + + +################################################## +# $build to $host FILE NAME CONVERSION FUNCTIONS # +################################################## +# invoked via '$to_host_file_cmd ARG' +# +# In each case, ARG is the path to be converted from $build to $host format. +# Result will be available in $func_to_host_file_result. + + +# func_to_host_file ARG +# Converts the file name ARG from $build format to $host format. Return result +# in func_to_host_file_result. +func_to_host_file () +{ + $debug_cmd + + $to_host_file_cmd "$1" +} +# end func_to_host_file + + +# func_to_tool_file ARG LAZY +# converts the file name ARG from $build format to toolchain format. Return +# result in func_to_tool_file_result. If the conversion in use is listed +# in (the comma separated) LAZY, no conversion takes place. +func_to_tool_file () +{ + $debug_cmd + + case ,$2, in + *,"$to_tool_file_cmd",*) + func_to_tool_file_result=$1 + ;; + *) + $to_tool_file_cmd "$1" + func_to_tool_file_result=$func_to_host_file_result + ;; + esac +} +# end func_to_tool_file + + +# func_convert_file_noop ARG +# Copy ARG to func_to_host_file_result. +func_convert_file_noop () +{ + func_to_host_file_result=$1 +} +# end func_convert_file_noop + + +# func_convert_file_msys_to_w32 ARG +# Convert file name ARG from (mingw) MSYS to (mingw) w32 format; automatic +# conversion to w32 is not available inside the cwrapper. Returns result in +# func_to_host_file_result. +func_convert_file_msys_to_w32 () +{ + $debug_cmd + + func_to_host_file_result=$1 + if test -n "$1"; then + func_convert_core_msys_to_w32 "$1" + func_to_host_file_result=$func_convert_core_msys_to_w32_result + fi + func_convert_file_check "$1" "$func_to_host_file_result" +} +# end func_convert_file_msys_to_w32 + + +# func_convert_file_cygwin_to_w32 ARG +# Convert file name ARG from Cygwin to w32 format. Returns result in +# func_to_host_file_result. +func_convert_file_cygwin_to_w32 () +{ + $debug_cmd + + func_to_host_file_result=$1 + if test -n "$1"; then + # because $build is cygwin, we call "the" cygpath in $PATH; no need to use + # LT_CYGPATH in this case. + func_to_host_file_result=`cygpath -m "$1"` + fi + func_convert_file_check "$1" "$func_to_host_file_result" +} +# end func_convert_file_cygwin_to_w32 + + +# func_convert_file_nix_to_w32 ARG +# Convert file name ARG from *nix to w32 format. Requires a wine environment +# and a working winepath. Returns result in func_to_host_file_result. +func_convert_file_nix_to_w32 () +{ + $debug_cmd + + func_to_host_file_result=$1 + if test -n "$1"; then + func_convert_core_file_wine_to_w32 "$1" + func_to_host_file_result=$func_convert_core_file_wine_to_w32_result + fi + func_convert_file_check "$1" "$func_to_host_file_result" +} +# end func_convert_file_nix_to_w32 + + +# func_convert_file_msys_to_cygwin ARG +# Convert file name ARG from MSYS to Cygwin format. Requires LT_CYGPATH set. +# Returns result in func_to_host_file_result. +func_convert_file_msys_to_cygwin () +{ + $debug_cmd + + func_to_host_file_result=$1 + if test -n "$1"; then + func_convert_core_msys_to_w32 "$1" + func_cygpath -u "$func_convert_core_msys_to_w32_result" + func_to_host_file_result=$func_cygpath_result + fi + func_convert_file_check "$1" "$func_to_host_file_result" +} +# end func_convert_file_msys_to_cygwin + + +# func_convert_file_nix_to_cygwin ARG +# Convert file name ARG from *nix to Cygwin format. Requires Cygwin installed +# in a wine environment, working winepath, and LT_CYGPATH set. Returns result +# in func_to_host_file_result. +func_convert_file_nix_to_cygwin () +{ + $debug_cmd + + func_to_host_file_result=$1 + if test -n "$1"; then + # convert from *nix to w32, then use cygpath to convert from w32 to cygwin. + func_convert_core_file_wine_to_w32 "$1" + func_cygpath -u "$func_convert_core_file_wine_to_w32_result" + func_to_host_file_result=$func_cygpath_result + fi + func_convert_file_check "$1" "$func_to_host_file_result" +} +# end func_convert_file_nix_to_cygwin + + +############################################# +# $build to $host PATH CONVERSION FUNCTIONS # +############################################# +# invoked via '$to_host_path_cmd ARG' +# +# In each case, ARG is the path to be converted from $build to $host format. +# The result will be available in $func_to_host_path_result. +# +# Path separators are also converted from $build format to $host format. If +# ARG begins or ends with a path separator character, it is preserved (but +# converted to $host format) on output. +# +# All path conversion functions are named using the following convention: +# file name conversion function : func_convert_file_X_to_Y () +# path conversion function : func_convert_path_X_to_Y () +# where, for any given $build/$host combination the 'X_to_Y' value is the +# same. If conversion functions are added for new $build/$host combinations, +# the two new functions must follow this pattern, or func_init_to_host_path_cmd +# will break. + + +# func_init_to_host_path_cmd +# Ensures that function "pointer" variable $to_host_path_cmd is set to the +# appropriate value, based on the value of $to_host_file_cmd. +to_host_path_cmd= +func_init_to_host_path_cmd () +{ + $debug_cmd + + if test -z "$to_host_path_cmd"; then + func_stripname 'func_convert_file_' '' "$to_host_file_cmd" + to_host_path_cmd=func_convert_path_$func_stripname_result + fi +} + + +# func_to_host_path ARG +# Converts the path ARG from $build format to $host format. Return result +# in func_to_host_path_result. +func_to_host_path () +{ + $debug_cmd + + func_init_to_host_path_cmd + $to_host_path_cmd "$1" +} +# end func_to_host_path + + +# func_convert_path_noop ARG +# Copy ARG to func_to_host_path_result. +func_convert_path_noop () +{ + func_to_host_path_result=$1 +} +# end func_convert_path_noop + + +# func_convert_path_msys_to_w32 ARG +# Convert path ARG from (mingw) MSYS to (mingw) w32 format; automatic +# conversion to w32 is not available inside the cwrapper. Returns result in +# func_to_host_path_result. +func_convert_path_msys_to_w32 () +{ + $debug_cmd + + func_to_host_path_result=$1 + if test -n "$1"; then + # Remove leading and trailing path separator characters from ARG. MSYS + # behavior is inconsistent here; cygpath turns them into '.;' and ';.'; + # and winepath ignores them completely. + func_stripname : : "$1" + func_to_host_path_tmp1=$func_stripname_result + func_convert_core_msys_to_w32 "$func_to_host_path_tmp1" + func_to_host_path_result=$func_convert_core_msys_to_w32_result + func_convert_path_check : ";" \ + "$func_to_host_path_tmp1" "$func_to_host_path_result" + func_convert_path_front_back_pathsep ":*" "*:" ";" "$1" + fi +} +# end func_convert_path_msys_to_w32 + + +# func_convert_path_cygwin_to_w32 ARG +# Convert path ARG from Cygwin to w32 format. Returns result in +# func_to_host_file_result. +func_convert_path_cygwin_to_w32 () +{ + $debug_cmd + + func_to_host_path_result=$1 + if test -n "$1"; then + # See func_convert_path_msys_to_w32: + func_stripname : : "$1" + func_to_host_path_tmp1=$func_stripname_result + func_to_host_path_result=`cygpath -m -p "$func_to_host_path_tmp1"` + func_convert_path_check : ";" \ + "$func_to_host_path_tmp1" "$func_to_host_path_result" + func_convert_path_front_back_pathsep ":*" "*:" ";" "$1" + fi +} +# end func_convert_path_cygwin_to_w32 + + +# func_convert_path_nix_to_w32 ARG +# Convert path ARG from *nix to w32 format. Requires a wine environment and +# a working winepath. Returns result in func_to_host_file_result. +func_convert_path_nix_to_w32 () +{ + $debug_cmd + + func_to_host_path_result=$1 + if test -n "$1"; then + # See func_convert_path_msys_to_w32: + func_stripname : : "$1" + func_to_host_path_tmp1=$func_stripname_result + func_convert_core_path_wine_to_w32 "$func_to_host_path_tmp1" + func_to_host_path_result=$func_convert_core_path_wine_to_w32_result + func_convert_path_check : ";" \ + "$func_to_host_path_tmp1" "$func_to_host_path_result" + func_convert_path_front_back_pathsep ":*" "*:" ";" "$1" + fi +} +# end func_convert_path_nix_to_w32 + + +# func_convert_path_msys_to_cygwin ARG +# Convert path ARG from MSYS to Cygwin format. Requires LT_CYGPATH set. +# Returns result in func_to_host_file_result. +func_convert_path_msys_to_cygwin () +{ + $debug_cmd + + func_to_host_path_result=$1 + if test -n "$1"; then + # See func_convert_path_msys_to_w32: + func_stripname : : "$1" + func_to_host_path_tmp1=$func_stripname_result + func_convert_core_msys_to_w32 "$func_to_host_path_tmp1" + func_cygpath -u -p "$func_convert_core_msys_to_w32_result" + func_to_host_path_result=$func_cygpath_result + func_convert_path_check : : \ + "$func_to_host_path_tmp1" "$func_to_host_path_result" + func_convert_path_front_back_pathsep ":*" "*:" : "$1" + fi +} +# end func_convert_path_msys_to_cygwin + + +# func_convert_path_nix_to_cygwin ARG +# Convert path ARG from *nix to Cygwin format. Requires Cygwin installed in a +# a wine environment, working winepath, and LT_CYGPATH set. Returns result in +# func_to_host_file_result. +func_convert_path_nix_to_cygwin () +{ + $debug_cmd + + func_to_host_path_result=$1 + if test -n "$1"; then + # Remove leading and trailing path separator characters from + # ARG. msys behavior is inconsistent here, cygpath turns them + # into '.;' and ';.', and winepath ignores them completely. + func_stripname : : "$1" + func_to_host_path_tmp1=$func_stripname_result + func_convert_core_path_wine_to_w32 "$func_to_host_path_tmp1" + func_cygpath -u -p "$func_convert_core_path_wine_to_w32_result" + func_to_host_path_result=$func_cygpath_result + func_convert_path_check : : \ + "$func_to_host_path_tmp1" "$func_to_host_path_result" + func_convert_path_front_back_pathsep ":*" "*:" : "$1" + fi +} +# end func_convert_path_nix_to_cygwin + + +# func_dll_def_p FILE +# True iff FILE is a Windows DLL '.def' file. +# Keep in sync with _LT_DLL_DEF_P in libtool.m4 +func_dll_def_p () +{ + $debug_cmd + + func_dll_def_p_tmp=`$SED -n \ + -e 's/^[ ]*//' \ + -e '/^\(;.*\)*$/d' \ + -e 's/^\(EXPORTS\|LIBRARY\)\([ ].*\)*$/DEF/p' \ + -e q \ + "$1"` + test DEF = "$func_dll_def_p_tmp" +} + + +# func_mode_compile arg... +func_mode_compile () +{ + $debug_cmd + + # Get the compilation command and the source file. + base_compile= + srcfile=$nonopt # always keep a non-empty value in "srcfile" + suppress_opt=yes + suppress_output= + arg_mode=normal + libobj= + later= + pie_flag= + + for arg + do + case $arg_mode in + arg ) + # do not "continue". Instead, add this to base_compile + lastarg=$arg + arg_mode=normal + ;; + + target ) + libobj=$arg + arg_mode=normal + continue + ;; + + normal ) + # Accept any command-line options. + case $arg in + -o) + test -n "$libobj" && \ + func_fatal_error "you cannot specify '-o' more than once" + arg_mode=target + continue + ;; + + -pie | -fpie | -fPIE) + func_append pie_flag " $arg" + continue + ;; + + -shared | -static | -prefer-pic | -prefer-non-pic) + func_append later " $arg" + continue + ;; + + -no-suppress) + suppress_opt=no + continue + ;; + + -Xcompiler) + arg_mode=arg # the next one goes into the "base_compile" arg list + continue # The current "srcfile" will either be retained or + ;; # replaced later. I would guess that would be a bug. + + -Wc,*) + func_stripname '-Wc,' '' "$arg" + args=$func_stripname_result + lastarg= + save_ifs=$IFS; IFS=, + for arg in $args; do + IFS=$save_ifs + func_append_quoted lastarg "$arg" + done + IFS=$save_ifs + func_stripname ' ' '' "$lastarg" + lastarg=$func_stripname_result + + # Add the arguments to base_compile. + func_append base_compile " $lastarg" + continue + ;; + + *) + # Accept the current argument as the source file. + # The previous "srcfile" becomes the current argument. + # + lastarg=$srcfile + srcfile=$arg + ;; + esac # case $arg + ;; + esac # case $arg_mode + + # Aesthetically quote the previous argument. + func_append_quoted base_compile "$lastarg" + done # for arg + + case $arg_mode in + arg) + func_fatal_error "you must specify an argument for -Xcompile" + ;; + target) + func_fatal_error "you must specify a target with '-o'" + ;; + *) + # Get the name of the library object. + test -z "$libobj" && { + func_basename "$srcfile" + libobj=$func_basename_result + } + ;; + esac + + # Recognize several different file suffixes. + # If the user specifies -o file.o, it is replaced with file.lo + case $libobj in + *.[cCFSifmso] | \ + *.ada | *.adb | *.ads | *.asm | \ + *.c++ | *.cc | *.ii | *.class | *.cpp | *.cxx | \ + *.[fF][09]? | *.for | *.java | *.go | *.obj | *.sx | *.cu | *.cup) + func_xform "$libobj" + libobj=$func_xform_result + ;; + esac + + case $libobj in + *.lo) func_lo2o "$libobj"; obj=$func_lo2o_result ;; + *) + func_fatal_error "cannot determine name of library object from '$libobj'" + ;; + esac + + func_infer_tag $base_compile + + for arg in $later; do + case $arg in + -shared) + test yes = "$build_libtool_libs" \ + || func_fatal_configuration "cannot build a shared library" + build_old_libs=no + continue + ;; + + -static) + build_libtool_libs=no + build_old_libs=yes + continue + ;; + + -prefer-pic) + pic_mode=yes + continue + ;; + + -prefer-non-pic) + pic_mode=no + continue + ;; + esac + done + + func_quote_arg pretty "$libobj" + test "X$libobj" != "X$func_quote_arg_result" \ + && $ECHO "X$libobj" | $GREP '[]~#^*{};<>?"'"'"' &()|`$[]' \ + && func_warning "libobj name '$libobj' may not contain shell special characters." + func_dirname_and_basename "$obj" "/" "" + objname=$func_basename_result + xdir=$func_dirname_result + lobj=$xdir$objdir/$objname + + test -z "$base_compile" && \ + func_fatal_help "you must specify a compilation command" + + # Delete any leftover library objects. + if test yes = "$build_old_libs"; then + removelist="$obj $lobj $libobj ${libobj}T" + else + removelist="$lobj $libobj ${libobj}T" + fi + + # On Cygwin there's no "real" PIC flag so we must build both object types + case $host_os in + cygwin* | mingw* | pw32* | os2* | cegcc*) + pic_mode=default + ;; + esac + if test no = "$pic_mode" && test pass_all != "$deplibs_check_method"; then + # non-PIC code in shared libraries is not supported + pic_mode=default + fi + + # Calculate the filename of the output object if compiler does + # not support -o with -c + if test no = "$compiler_c_o"; then + output_obj=`$ECHO "$srcfile" | $SED 's%^.*/%%; s%\.[^.]*$%%'`.$objext + lockfile=$output_obj.lock + else + output_obj= + need_locks=no + lockfile= + fi + + # Lock this critical section if it is needed + # We use this script file to make the link, it avoids creating a new file + if test yes = "$need_locks"; then + until $opt_dry_run || ln "$progpath" "$lockfile" 2>/dev/null; do + func_echo "Waiting for $lockfile to be removed" + sleep 2 + done + elif test warn = "$need_locks"; then + if test -f "$lockfile"; then + $ECHO "\ +*** ERROR, $lockfile exists and contains: +`cat $lockfile 2>/dev/null` + +This indicates that another process is trying to use the same +temporary object file, and libtool could not work around it because +your compiler does not support '-c' and '-o' together. If you +repeat this compilation, it may succeed, by chance, but you had better +avoid parallel builds (make -j) in this platform, or get a better +compiler." + + $opt_dry_run || $RM $removelist + exit $EXIT_FAILURE + fi + func_append removelist " $output_obj" + $ECHO "$srcfile" > "$lockfile" + fi + + $opt_dry_run || $RM $removelist + func_append removelist " $lockfile" + trap '$opt_dry_run || $RM $removelist; exit $EXIT_FAILURE' 1 2 15 + + func_to_tool_file "$srcfile" func_convert_file_msys_to_w32 + srcfile=$func_to_tool_file_result + func_quote_arg pretty "$srcfile" + qsrcfile=$func_quote_arg_result + + # Only build a PIC object if we are building libtool libraries. + if test yes = "$build_libtool_libs"; then + # Without this assignment, base_compile gets emptied. + fbsd_hideous_sh_bug=$base_compile + + if test no != "$pic_mode"; then + command="$base_compile $qsrcfile $pic_flag" + else + # Don't build PIC code + command="$base_compile $qsrcfile" + fi + + func_mkdir_p "$xdir$objdir" + + if test -z "$output_obj"; then + # Place PIC objects in $objdir + func_append command " -o $lobj" + fi + + func_show_eval_locale "$command" \ + 'test -n "$output_obj" && $RM $removelist; exit $EXIT_FAILURE' + + if test warn = "$need_locks" && + test "X`cat $lockfile 2>/dev/null`" != "X$srcfile"; then + $ECHO "\ +*** ERROR, $lockfile contains: +`cat $lockfile 2>/dev/null` + +but it should contain: +$srcfile + +This indicates that another process is trying to use the same +temporary object file, and libtool could not work around it because +your compiler does not support '-c' and '-o' together. If you +repeat this compilation, it may succeed, by chance, but you had better +avoid parallel builds (make -j) in this platform, or get a better +compiler." + + $opt_dry_run || $RM $removelist + exit $EXIT_FAILURE + fi + + # Just move the object if needed, then go on to compile the next one + if test -n "$output_obj" && test "X$output_obj" != "X$lobj"; then + func_show_eval '$MV "$output_obj" "$lobj"' \ + 'error=$?; $opt_dry_run || $RM $removelist; exit $error' + fi + + # Allow error messages only from the first compilation. + if test yes = "$suppress_opt"; then + suppress_output=' >/dev/null 2>&1' + fi + fi + + # Only build a position-dependent object if we build old libraries. + if test yes = "$build_old_libs"; then + if test yes != "$pic_mode"; then + # Don't build PIC code + command="$base_compile $qsrcfile$pie_flag" + else + command="$base_compile $qsrcfile $pic_flag" + fi + if test yes = "$compiler_c_o"; then + func_append command " -o $obj" + fi + + # Suppress compiler output if we already did a PIC compilation. + func_append command "$suppress_output" + func_show_eval_locale "$command" \ + '$opt_dry_run || $RM $removelist; exit $EXIT_FAILURE' + + if test warn = "$need_locks" && + test "X`cat $lockfile 2>/dev/null`" != "X$srcfile"; then + $ECHO "\ +*** ERROR, $lockfile contains: +`cat $lockfile 2>/dev/null` + +but it should contain: +$srcfile + +This indicates that another process is trying to use the same +temporary object file, and libtool could not work around it because +your compiler does not support '-c' and '-o' together. If you +repeat this compilation, it may succeed, by chance, but you had better +avoid parallel builds (make -j) in this platform, or get a better +compiler." + + $opt_dry_run || $RM $removelist + exit $EXIT_FAILURE + fi + + # Just move the object if needed + if test -n "$output_obj" && test "X$output_obj" != "X$obj"; then + func_show_eval '$MV "$output_obj" "$obj"' \ + 'error=$?; $opt_dry_run || $RM $removelist; exit $error' + fi + fi + + $opt_dry_run || { + func_write_libtool_object "$libobj" "$objdir/$objname" "$objname" + + # Unlock the critical section if it was locked + if test no != "$need_locks"; then + removelist=$lockfile + $RM "$lockfile" + fi + } + + exit $EXIT_SUCCESS +} + +$opt_help || { + test compile = "$opt_mode" && func_mode_compile ${1+"$@"} +} + +func_mode_help () +{ + # We need to display help for each of the modes. + case $opt_mode in + "") + # Generic help is extracted from the usage comments + # at the start of this file. + func_help + ;; + + clean) + $ECHO \ +"Usage: $progname [OPTION]... --mode=clean RM [RM-OPTION]... FILE... + +Remove files from the build directory. + +RM is the name of the program to use to delete files associated with each FILE +(typically '/bin/rm'). RM-OPTIONS are options (such as '-f') to be passed +to RM. + +If FILE is a libtool library, object or program, all the files associated +with it are deleted. Otherwise, only FILE itself is deleted using RM." + ;; + + compile) + $ECHO \ +"Usage: $progname [OPTION]... --mode=compile COMPILE-COMMAND... SOURCEFILE + +Compile a source file into a libtool library object. + +This mode accepts the following additional options: + + -o OUTPUT-FILE set the output file name to OUTPUT-FILE + -no-suppress do not suppress compiler output for multiple passes + -prefer-pic try to build PIC objects only + -prefer-non-pic try to build non-PIC objects only + -shared do not build a '.o' file suitable for static linking + -static only build a '.o' file suitable for static linking + -Wc,FLAG + -Xcompiler FLAG pass FLAG directly to the compiler + +COMPILE-COMMAND is a command to be used in creating a 'standard' object file +from the given SOURCEFILE. + +The output file name is determined by removing the directory component from +SOURCEFILE, then substituting the C source code suffix '.c' with the +library object suffix, '.lo'." + ;; + + execute) + $ECHO \ +"Usage: $progname [OPTION]... --mode=execute COMMAND [ARGS]... + +Automatically set library path, then run a program. + +This mode accepts the following additional options: + + -dlopen FILE add the directory containing FILE to the library path + +This mode sets the library path environment variable according to '-dlopen' +flags. + +If any of the ARGS are libtool executable wrappers, then they are translated +into their corresponding uninstalled binary, and any of their required library +directories are added to the library path. + +Then, COMMAND is executed, with ARGS as arguments." + ;; + + finish) + $ECHO \ +"Usage: $progname [OPTION]... --mode=finish [LIBDIR]... + +Complete the installation of libtool libraries. + +Each LIBDIR is a directory that contains libtool libraries. + +The commands that this mode executes may require superuser privileges. Use +the '--dry-run' option if you just want to see what would be executed." + ;; + + install) + $ECHO \ +"Usage: $progname [OPTION]... --mode=install INSTALL-COMMAND... + +Install executables or libraries. + +INSTALL-COMMAND is the installation command. The first component should be +either the 'install' or 'cp' program. + +The following components of INSTALL-COMMAND are treated specially: + + -inst-prefix-dir PREFIX-DIR Use PREFIX-DIR as a staging area for installation + +The rest of the components are interpreted as arguments to that command (only +BSD-compatible install options are recognized)." + ;; + + link) + $ECHO \ +"Usage: $progname [OPTION]... --mode=link LINK-COMMAND... + +Link object files or libraries together to form another library, or to +create an executable program. + +LINK-COMMAND is a command using the C compiler that you would use to create +a program from several object files. + +The following components of LINK-COMMAND are treated specially: + + -all-static do not do any dynamic linking at all + -avoid-version do not add a version suffix if possible + -bindir BINDIR specify path to binaries directory (for systems where + libraries must be found in the PATH setting at runtime) + -dlopen FILE '-dlpreopen' FILE if it cannot be dlopened at runtime + -dlpreopen FILE link in FILE and add its symbols to lt_preloaded_symbols + -export-dynamic allow symbols from OUTPUT-FILE to be resolved with dlsym(3) + -export-symbols SYMFILE + try to export only the symbols listed in SYMFILE + -export-symbols-regex REGEX + try to export only the symbols matching REGEX + -LLIBDIR search LIBDIR for required installed libraries + -lNAME OUTPUT-FILE requires the installed library libNAME + -module build a library that can dlopened + -no-fast-install disable the fast-install mode + -no-install link a not-installable executable + -no-undefined declare that a library does not refer to external symbols + -o OUTPUT-FILE create OUTPUT-FILE from the specified objects + -objectlist FILE use a list of object files found in FILE to specify objects + -os2dllname NAME force a short DLL name on OS/2 (no effect on other OSes) + -precious-files-regex REGEX + don't remove output files matching REGEX + -release RELEASE specify package release information + -rpath LIBDIR the created library will eventually be installed in LIBDIR + -R[ ]LIBDIR add LIBDIR to the runtime path of programs and libraries + -shared only do dynamic linking of libtool libraries + -shrext SUFFIX override the standard shared library file extension + -static do not do any dynamic linking of uninstalled libtool libraries + -static-libtool-libs + do not do any dynamic linking of libtool libraries + -version-info CURRENT[:REVISION[:AGE]] + specify library version info [each variable defaults to 0] + -weak LIBNAME declare that the target provides the LIBNAME interface + -Wc,FLAG + -Xcompiler FLAG pass linker-specific FLAG directly to the compiler + -Wa,FLAG + -Xassembler FLAG pass linker-specific FLAG directly to the assembler + -Wl,FLAG + -Xlinker FLAG pass linker-specific FLAG directly to the linker + -XCClinker FLAG pass link-specific FLAG to the compiler driver (CC) + +All other options (arguments beginning with '-') are ignored. + +Every other argument is treated as a filename. Files ending in '.la' are +treated as uninstalled libtool libraries, other files are standard or library +object files. + +If the OUTPUT-FILE ends in '.la', then a libtool library is created, +only library objects ('.lo' files) may be specified, and '-rpath' is +required, except when creating a convenience library. + +If OUTPUT-FILE ends in '.a' or '.lib', then a standard library is created +using 'ar' and 'ranlib', or on Windows using 'lib'. + +If OUTPUT-FILE ends in '.lo' or '.$objext', then a reloadable object file +is created, otherwise an executable program is created." + ;; + + uninstall) + $ECHO \ +"Usage: $progname [OPTION]... --mode=uninstall RM [RM-OPTION]... FILE... + +Remove libraries from an installation directory. + +RM is the name of the program to use to delete files associated with each FILE +(typically '/bin/rm'). RM-OPTIONS are options (such as '-f') to be passed +to RM. + +If FILE is a libtool library, all the files associated with it are deleted. +Otherwise, only FILE itself is deleted using RM." + ;; + + *) + func_fatal_help "invalid operation mode '$opt_mode'" + ;; + esac + + echo + $ECHO "Try '$progname --help' for more information about other modes." +} + +# Now that we've collected a possible --mode arg, show help if necessary +if $opt_help; then + if test : = "$opt_help"; then + func_mode_help + else + { + func_help noexit + for opt_mode in compile link execute install finish uninstall clean; do + func_mode_help + done + } | $SED -n '1p; 2,$s/^Usage:/ or: /p' + { + func_help noexit + for opt_mode in compile link execute install finish uninstall clean; do + echo + func_mode_help + done + } | + $SED '1d + /^When reporting/,/^Report/{ + H + d + } + $x + /information about other modes/d + /more detailed .*MODE/d + s/^Usage:.*--mode=\([^ ]*\) .*/Description of \1 mode:/' + fi + exit $? +fi + + +# func_mode_execute arg... +func_mode_execute () +{ + $debug_cmd + + # The first argument is the command name. + cmd=$nonopt + test -z "$cmd" && \ + func_fatal_help "you must specify a COMMAND" + + # Handle -dlopen flags immediately. + for file in $opt_dlopen; do + test -f "$file" \ + || func_fatal_help "'$file' is not a file" + + dir= + case $file in + *.la) + func_resolve_sysroot "$file" + file=$func_resolve_sysroot_result + + # Check to see that this really is a libtool archive. + func_lalib_unsafe_p "$file" \ + || func_fatal_help "'$lib' is not a valid libtool archive" + + # Read the libtool library. + dlname= + library_names= + func_source "$file" + + # Skip this library if it cannot be dlopened. + if test -z "$dlname"; then + # Warn if it was a shared library. + test -n "$library_names" && \ + func_warning "'$file' was not linked with '-export-dynamic'" + continue + fi + + func_dirname "$file" "" "." + dir=$func_dirname_result + + if test -f "$dir/$objdir/$dlname"; then + func_append dir "/$objdir" + else + if test ! -f "$dir/$dlname"; then + func_fatal_error "cannot find '$dlname' in '$dir' or '$dir/$objdir'" + fi + fi + ;; + + *.lo) + # Just add the directory containing the .lo file. + func_dirname "$file" "" "." + dir=$func_dirname_result + ;; + + *) + func_warning "'-dlopen' is ignored for non-libtool libraries and objects" + continue + ;; + esac + + # Get the absolute pathname. + absdir=`cd "$dir" && pwd` + test -n "$absdir" && dir=$absdir + + # Now add the directory to shlibpath_var. + if eval "test -z \"\$$shlibpath_var\""; then + eval "$shlibpath_var=\"\$dir\"" + else + eval "$shlibpath_var=\"\$dir:\$$shlibpath_var\"" + fi + done + + # This variable tells wrapper scripts just to set shlibpath_var + # rather than running their programs. + libtool_execute_magic=$magic + + # Check if any of the arguments is a wrapper script. + args= + for file + do + case $file in + -* | *.la | *.lo ) ;; + *) + # Do a test to see if this is really a libtool program. + if func_ltwrapper_script_p "$file"; then + func_source "$file" + # Transform arg to wrapped name. + file=$progdir/$program + elif func_ltwrapper_executable_p "$file"; then + func_ltwrapper_scriptname "$file" + func_source "$func_ltwrapper_scriptname_result" + # Transform arg to wrapped name. + file=$progdir/$program + fi + ;; + esac + # Quote arguments (to preserve shell metacharacters). + func_append_quoted args "$file" + done + + if $opt_dry_run; then + # Display what would be done. + if test -n "$shlibpath_var"; then + eval "\$ECHO \"\$shlibpath_var=\$$shlibpath_var\"" + echo "export $shlibpath_var" + fi + $ECHO "$cmd$args" + exit $EXIT_SUCCESS + else + if test -n "$shlibpath_var"; then + # Export the shlibpath_var. + eval "export $shlibpath_var" + fi + + # Restore saved environment variables + for lt_var in LANG LANGUAGE LC_ALL LC_CTYPE LC_COLLATE LC_MESSAGES + do + eval "if test \"\${save_$lt_var+set}\" = set; then + $lt_var=\$save_$lt_var; export $lt_var + else + $lt_unset $lt_var + fi" + done + + # Now prepare to actually exec the command. + exec_cmd=\$cmd$args + fi +} + +test execute = "$opt_mode" && func_mode_execute ${1+"$@"} + + +# func_mode_finish arg... +func_mode_finish () +{ + $debug_cmd + + libs= + libdirs= + admincmds= + + for opt in "$nonopt" ${1+"$@"} + do + if test -d "$opt"; then + func_append libdirs " $opt" + + elif test -f "$opt"; then + if func_lalib_unsafe_p "$opt"; then + func_append libs " $opt" + else + func_warning "'$opt' is not a valid libtool archive" + fi + + else + func_fatal_error "invalid argument '$opt'" + fi + done + + if test -n "$libs"; then + if test -n "$lt_sysroot"; then + sysroot_regex=`$ECHO "$lt_sysroot" | $SED "$sed_make_literal_regex"` + sysroot_cmd="s/\([ ']\)$sysroot_regex/\1/g;" + else + sysroot_cmd= + fi + + # Remove sysroot references + if $opt_dry_run; then + for lib in $libs; do + echo "removing references to $lt_sysroot and '=' prefixes from $lib" + done + else + tmpdir=`func_mktempdir` + for lib in $libs; do + $SED -e "$sysroot_cmd s/\([ ']-[LR]\)=/\1/g; s/\([ ']\)=/\1/g" $lib \ + > $tmpdir/tmp-la + mv -f $tmpdir/tmp-la $lib + done + ${RM}r "$tmpdir" + fi + fi + + if test -n "$finish_cmds$finish_eval" && test -n "$libdirs"; then + for libdir in $libdirs; do + if test -n "$finish_cmds"; then + # Do each command in the finish commands. + func_execute_cmds "$finish_cmds" 'admincmds="$admincmds +'"$cmd"'"' + fi + if test -n "$finish_eval"; then + # Do the single finish_eval. + eval cmds=\"$finish_eval\" + $opt_dry_run || eval "$cmds" || func_append admincmds " + $cmds" + fi + done + fi + + # Exit here if they wanted silent mode. + $opt_quiet && exit $EXIT_SUCCESS + + if test -n "$finish_cmds$finish_eval" && test -n "$libdirs"; then + echo "----------------------------------------------------------------------" + echo "Libraries have been installed in:" + for libdir in $libdirs; do + $ECHO " $libdir" + done + echo + echo "If you ever happen to want to link against installed libraries" + echo "in a given directory, LIBDIR, you must either use libtool, and" + echo "specify the full pathname of the library, or use the '-LLIBDIR'" + echo "flag during linking and do at least one of the following:" + if test -n "$shlibpath_var"; then + echo " - add LIBDIR to the '$shlibpath_var' environment variable" + echo " during execution" + fi + if test -n "$runpath_var"; then + echo " - add LIBDIR to the '$runpath_var' environment variable" + echo " during linking" + fi + if test -n "$hardcode_libdir_flag_spec"; then + libdir=LIBDIR + eval flag=\"$hardcode_libdir_flag_spec\" + + $ECHO " - use the '$flag' linker flag" + fi + if test -n "$admincmds"; then + $ECHO " - have your system administrator run these commands:$admincmds" + fi + if test -f /etc/ld.so.conf; then + echo " - have your system administrator add LIBDIR to '/etc/ld.so.conf'" + fi + echo + + echo "See any operating system documentation about shared libraries for" + case $host in + solaris2.[6789]|solaris2.1[0-9]) + echo "more information, such as the ld(1), crle(1) and ld.so(8) manual" + echo "pages." + ;; + *) + echo "more information, such as the ld(1) and ld.so(8) manual pages." + ;; + esac + echo "----------------------------------------------------------------------" + fi + exit $EXIT_SUCCESS +} + +test finish = "$opt_mode" && func_mode_finish ${1+"$@"} + + +# func_mode_install arg... +func_mode_install () +{ + $debug_cmd + + # There may be an optional sh(1) argument at the beginning of + # install_prog (especially on Windows NT). + if test "$SHELL" = "$nonopt" || test /bin/sh = "$nonopt" || + # Allow the use of GNU shtool's install command. + case $nonopt in *shtool*) :;; *) false;; esac + then + # Aesthetically quote it. + func_quote_arg pretty "$nonopt" + install_prog="$func_quote_arg_result " + arg=$1 + shift + else + install_prog= + arg=$nonopt + fi + + # The real first argument should be the name of the installation program. + # Aesthetically quote it. + func_quote_arg pretty "$arg" + func_append install_prog "$func_quote_arg_result" + install_shared_prog=$install_prog + case " $install_prog " in + *[\\\ /]cp\ *) install_cp=: ;; + *) install_cp=false ;; + esac + + # We need to accept at least all the BSD install flags. + dest= + files= + opts= + prev= + install_type= + isdir=false + stripme= + no_mode=: + for arg + do + arg2= + if test -n "$dest"; then + func_append files " $dest" + dest=$arg + continue + fi + + case $arg in + -d) isdir=: ;; + -f) + if $install_cp; then :; else + prev=$arg + fi + ;; + -g | -m | -o) + prev=$arg + ;; + -s) + stripme=" -s" + continue + ;; + -*) + ;; + *) + # If the previous option needed an argument, then skip it. + if test -n "$prev"; then + if test X-m = "X$prev" && test -n "$install_override_mode"; then + arg2=$install_override_mode + no_mode=false + fi + prev= + else + dest=$arg + continue + fi + ;; + esac + + # Aesthetically quote the argument. + func_quote_arg pretty "$arg" + func_append install_prog " $func_quote_arg_result" + if test -n "$arg2"; then + func_quote_arg pretty "$arg2" + fi + func_append install_shared_prog " $func_quote_arg_result" + done + + test -z "$install_prog" && \ + func_fatal_help "you must specify an install program" + + test -n "$prev" && \ + func_fatal_help "the '$prev' option requires an argument" + + if test -n "$install_override_mode" && $no_mode; then + if $install_cp; then :; else + func_quote_arg pretty "$install_override_mode" + func_append install_shared_prog " -m $func_quote_arg_result" + fi + fi + + if test -z "$files"; then + if test -z "$dest"; then + func_fatal_help "no file or destination specified" + else + func_fatal_help "you must specify a destination" + fi + fi + + # Strip any trailing slash from the destination. + func_stripname '' '/' "$dest" + dest=$func_stripname_result + + # Check to see that the destination is a directory. + test -d "$dest" && isdir=: + if $isdir; then + destdir=$dest + destname= + else + func_dirname_and_basename "$dest" "" "." + destdir=$func_dirname_result + destname=$func_basename_result + + # Not a directory, so check to see that there is only one file specified. + set dummy $files; shift + test "$#" -gt 1 && \ + func_fatal_help "'$dest' is not a directory" + fi + case $destdir in + [\\/]* | [A-Za-z]:[\\/]*) ;; + *) + for file in $files; do + case $file in + *.lo) ;; + *) + func_fatal_help "'$destdir' must be an absolute directory name" + ;; + esac + done + ;; + esac + + # This variable tells wrapper scripts just to set variables rather + # than running their programs. + libtool_install_magic=$magic + + staticlibs= + future_libdirs= + current_libdirs= + for file in $files; do + + # Do each installation. + case $file in + *.$libext) + # Do the static libraries later. + func_append staticlibs " $file" + ;; + + *.la) + func_resolve_sysroot "$file" + file=$func_resolve_sysroot_result + + # Check to see that this really is a libtool archive. + func_lalib_unsafe_p "$file" \ + || func_fatal_help "'$file' is not a valid libtool archive" + + library_names= + old_library= + relink_command= + func_source "$file" + + # Add the libdir to current_libdirs if it is the destination. + if test "X$destdir" = "X$libdir"; then + case "$current_libdirs " in + *" $libdir "*) ;; + *) func_append current_libdirs " $libdir" ;; + esac + else + # Note the libdir as a future libdir. + case "$future_libdirs " in + *" $libdir "*) ;; + *) func_append future_libdirs " $libdir" ;; + esac + fi + + func_dirname "$file" "/" "" + dir=$func_dirname_result + func_append dir "$objdir" + + if test -n "$relink_command"; then + # Determine the prefix the user has applied to our future dir. + inst_prefix_dir=`$ECHO "$destdir" | $SED -e "s%$libdir\$%%"` + + # Don't allow the user to place us outside of our expected + # location b/c this prevents finding dependent libraries that + # are installed to the same prefix. + # At present, this check doesn't affect windows .dll's that + # are installed into $libdir/../bin (currently, that works fine) + # but it's something to keep an eye on. + test "$inst_prefix_dir" = "$destdir" && \ + func_fatal_error "error: cannot install '$file' to a directory not ending in $libdir" + + if test -n "$inst_prefix_dir"; then + # Stick the inst_prefix_dir data into the link command. + relink_command=`$ECHO "$relink_command" | $SED "s%@inst_prefix_dir@%-inst-prefix-dir $inst_prefix_dir%"` + else + relink_command=`$ECHO "$relink_command" | $SED "s%@inst_prefix_dir@%%"` + fi + + func_warning "relinking '$file'" + func_show_eval "$relink_command" \ + 'func_fatal_error "error: relink '\''$file'\'' with the above command before installing it"' + fi + + # See the names of the shared library. + set dummy $library_names; shift + if test -n "$1"; then + realname=$1 + shift + + srcname=$realname + test -n "$relink_command" && srcname=${realname}T + + # Install the shared library and build the symlinks. + func_show_eval "$install_shared_prog $dir/$srcname $destdir/$realname" \ + 'exit $?' + tstripme=$stripme + case $host_os in + cygwin* | mingw* | pw32* | cegcc*) + case $realname in + *.dll.a) + tstripme= + ;; + esac + ;; + os2*) + case $realname in + *_dll.a) + tstripme= + ;; + esac + ;; + esac + if test -n "$tstripme" && test -n "$striplib"; then + func_show_eval "$striplib $destdir/$realname" 'exit $?' + fi + + if test "$#" -gt 0; then + # Delete the old symlinks, and create new ones. + # Try 'ln -sf' first, because the 'ln' binary might depend on + # the symlink we replace! Solaris /bin/ln does not understand -f, + # so we also need to try rm && ln -s. + for linkname + do + test "$linkname" != "$realname" \ + && func_show_eval "(cd $destdir && { $LN_S -f $realname $linkname || { $RM $linkname && $LN_S $realname $linkname; }; })" + done + fi + + # Do each command in the postinstall commands. + lib=$destdir/$realname + func_execute_cmds "$postinstall_cmds" 'exit $?' + fi + + # Install the pseudo-library for information purposes. + func_basename "$file" + name=$func_basename_result + instname=$dir/${name}i + func_show_eval "$install_prog $instname $destdir/$name" 'exit $?' + + # Maybe install the static library, too. + test -n "$old_library" && func_append staticlibs " $dir/$old_library" + ;; + + *.lo) + # Install (i.e. copy) a libtool object. + + # Figure out destination file name, if it wasn't already specified. + if test -n "$destname"; then + destfile=$destdir/$destname + else + func_basename "$file" + destfile=$func_basename_result + destfile=$destdir/$destfile + fi + + # Deduce the name of the destination old-style object file. + case $destfile in + *.lo) + func_lo2o "$destfile" + staticdest=$func_lo2o_result + ;; + *.$objext) + staticdest=$destfile + destfile= + ;; + *) + func_fatal_help "cannot copy a libtool object to '$destfile'" + ;; + esac + + # Install the libtool object if requested. + test -n "$destfile" && \ + func_show_eval "$install_prog $file $destfile" 'exit $?' + + # Install the old object if enabled. + if test yes = "$build_old_libs"; then + # Deduce the name of the old-style object file. + func_lo2o "$file" + staticobj=$func_lo2o_result + func_show_eval "$install_prog \$staticobj \$staticdest" 'exit $?' + fi + exit $EXIT_SUCCESS + ;; + + *) + # Figure out destination file name, if it wasn't already specified. + if test -n "$destname"; then + destfile=$destdir/$destname + else + func_basename "$file" + destfile=$func_basename_result + destfile=$destdir/$destfile + fi + + # If the file is missing, and there is a .exe on the end, strip it + # because it is most likely a libtool script we actually want to + # install + stripped_ext= + case $file in + *.exe) + if test ! -f "$file"; then + func_stripname '' '.exe' "$file" + file=$func_stripname_result + stripped_ext=.exe + fi + ;; + esac + + # Do a test to see if this is really a libtool program. + case $host in + *cygwin* | *mingw*) + if func_ltwrapper_executable_p "$file"; then + func_ltwrapper_scriptname "$file" + wrapper=$func_ltwrapper_scriptname_result + else + func_stripname '' '.exe' "$file" + wrapper=$func_stripname_result + fi + ;; + *) + wrapper=$file + ;; + esac + if func_ltwrapper_script_p "$wrapper"; then + notinst_deplibs= + relink_command= + + func_source "$wrapper" + + # Check the variables that should have been set. + test -z "$generated_by_libtool_version" && \ + func_fatal_error "invalid libtool wrapper script '$wrapper'" + + finalize=: + for lib in $notinst_deplibs; do + # Check to see that each library is installed. + libdir= + if test -f "$lib"; then + func_source "$lib" + fi + libfile=$libdir/`$ECHO "$lib" | $SED 's%^.*/%%g'` + if test -n "$libdir" && test ! -f "$libfile"; then + func_warning "'$lib' has not been installed in '$libdir'" + finalize=false + fi + done + + relink_command= + func_source "$wrapper" + + outputname= + if test no = "$fast_install" && test -n "$relink_command"; then + $opt_dry_run || { + if $finalize; then + tmpdir=`func_mktempdir` + func_basename "$file$stripped_ext" + file=$func_basename_result + outputname=$tmpdir/$file + # Replace the output file specification. + relink_command=`$ECHO "$relink_command" | $SED 's%@OUTPUT@%'"$outputname"'%g'` + + $opt_quiet || { + func_quote_arg expand,pretty "$relink_command" + eval "func_echo $func_quote_arg_result" + } + if eval "$relink_command"; then : + else + func_error "error: relink '$file' with the above command before installing it" + $opt_dry_run || ${RM}r "$tmpdir" + continue + fi + file=$outputname + else + func_warning "cannot relink '$file'" + fi + } + else + # Install the binary that we compiled earlier. + file=`$ECHO "$file$stripped_ext" | $SED "s%\([^/]*\)$%$objdir/\1%"` + fi + fi + + # remove .exe since cygwin /usr/bin/install will append another + # one anyway + case $install_prog,$host in + */usr/bin/install*,*cygwin*) + case $file:$destfile in + *.exe:*.exe) + # this is ok + ;; + *.exe:*) + destfile=$destfile.exe + ;; + *:*.exe) + func_stripname '' '.exe' "$destfile" + destfile=$func_stripname_result + ;; + esac + ;; + esac + func_show_eval "$install_prog\$stripme \$file \$destfile" 'exit $?' + $opt_dry_run || if test -n "$outputname"; then + ${RM}r "$tmpdir" + fi + ;; + esac + done + + for file in $staticlibs; do + func_basename "$file" + name=$func_basename_result + + # Set up the ranlib parameters. + oldlib=$destdir/$name + func_to_tool_file "$oldlib" func_convert_file_msys_to_w32 + tool_oldlib=$func_to_tool_file_result + + func_show_eval "$install_prog \$file \$oldlib" 'exit $?' + + if test -n "$stripme" && test -n "$old_striplib"; then + func_show_eval "$old_striplib $tool_oldlib" 'exit $?' + fi + + # Do each command in the postinstall commands. + func_execute_cmds "$old_postinstall_cmds" 'exit $?' + done + + test -n "$future_libdirs" && \ + func_warning "remember to run '$progname --finish$future_libdirs'" + + if test -n "$current_libdirs"; then + # Maybe just do a dry run. + $opt_dry_run && current_libdirs=" -n$current_libdirs" + exec_cmd='$SHELL "$progpath" $preserve_args --finish$current_libdirs' + else + exit $EXIT_SUCCESS + fi +} + +test install = "$opt_mode" && func_mode_install ${1+"$@"} + + +# func_generate_dlsyms outputname originator pic_p +# Extract symbols from dlprefiles and create ${outputname}S.o with +# a dlpreopen symbol table. +func_generate_dlsyms () +{ + $debug_cmd + + my_outputname=$1 + my_originator=$2 + my_pic_p=${3-false} + my_prefix=`$ECHO "$my_originator" | $SED 's%[^a-zA-Z0-9]%_%g'` + my_dlsyms= + + if test -n "$dlfiles$dlprefiles" || test no != "$dlself"; then + if test -n "$NM" && test -n "$global_symbol_pipe"; then + my_dlsyms=${my_outputname}S.c + else + func_error "not configured to extract global symbols from dlpreopened files" + fi + fi + + if test -n "$my_dlsyms"; then + case $my_dlsyms in + "") ;; + *.c) + # Discover the nlist of each of the dlfiles. + nlist=$output_objdir/$my_outputname.nm + + func_show_eval "$RM $nlist ${nlist}S ${nlist}T" + + # Parse the name list into a source file. + func_verbose "creating $output_objdir/$my_dlsyms" + + $opt_dry_run || $ECHO > "$output_objdir/$my_dlsyms" "\ +/* $my_dlsyms - symbol resolution table for '$my_outputname' dlsym emulation. */ +/* Generated by $PROGRAM (GNU $PACKAGE) $VERSION */ + +#ifdef __cplusplus +extern \"C\" { +#endif + +#if defined __GNUC__ && (((__GNUC__ == 4) && (__GNUC_MINOR__ >= 4)) || (__GNUC__ > 4)) +#pragma GCC diagnostic ignored \"-Wstrict-prototypes\" +#endif + +/* Keep this code in sync between libtool.m4, ltmain, lt_system.h, and tests. */ +#if defined _WIN32 || defined __CYGWIN__ || defined _WIN32_WCE +/* DATA imports from DLLs on WIN32 can't be const, because runtime + relocations are performed -- see ld's documentation on pseudo-relocs. */ +# define LT_DLSYM_CONST +#elif defined __osf__ +/* This system does not cope well with relocations in const data. */ +# define LT_DLSYM_CONST +#else +# define LT_DLSYM_CONST const +#endif + +#define STREQ(s1, s2) (strcmp ((s1), (s2)) == 0) + +/* External symbol declarations for the compiler. */\ +" + + if test yes = "$dlself"; then + func_verbose "generating symbol list for '$output'" + + $opt_dry_run || echo ': @PROGRAM@ ' > "$nlist" + + # Add our own program objects to the symbol list. + progfiles=`$ECHO "$objs$old_deplibs" | $SP2NL | $SED "$lo2o" | $NL2SP` + for progfile in $progfiles; do + func_to_tool_file "$progfile" func_convert_file_msys_to_w32 + func_verbose "extracting global C symbols from '$func_to_tool_file_result'" + $opt_dry_run || eval "$NM $func_to_tool_file_result | $global_symbol_pipe >> '$nlist'" + done + + if test -n "$exclude_expsyms"; then + $opt_dry_run || { + eval '$EGREP -v " ($exclude_expsyms)$" "$nlist" > "$nlist"T' + eval '$MV "$nlist"T "$nlist"' + } + fi + + if test -n "$export_symbols_regex"; then + $opt_dry_run || { + eval '$EGREP -e "$export_symbols_regex" "$nlist" > "$nlist"T' + eval '$MV "$nlist"T "$nlist"' + } + fi + + # Prepare the list of exported symbols + if test -z "$export_symbols"; then + export_symbols=$output_objdir/$outputname.exp + $opt_dry_run || { + $RM $export_symbols + eval "$SED -n -e '/^: @PROGRAM@ $/d' -e 's/^.* \(.*\)$/\1/p' "'< "$nlist" > "$export_symbols"' + case $host in + *cygwin* | *mingw* | *cegcc* ) + eval "echo EXPORTS "'> "$output_objdir/$outputname.def"' + eval 'cat "$export_symbols" >> "$output_objdir/$outputname.def"' + ;; + esac + } + else + $opt_dry_run || { + eval "$SED -e 's/\([].[*^$]\)/\\\\\1/g' -e 's/^/ /' -e 's/$/$/'"' < "$export_symbols" > "$output_objdir/$outputname.exp"' + eval '$GREP -f "$output_objdir/$outputname.exp" < "$nlist" > "$nlist"T' + eval '$MV "$nlist"T "$nlist"' + case $host in + *cygwin* | *mingw* | *cegcc* ) + eval "echo EXPORTS "'> "$output_objdir/$outputname.def"' + eval 'cat "$nlist" >> "$output_objdir/$outputname.def"' + ;; + esac + } + fi + fi + + for dlprefile in $dlprefiles; do + func_verbose "extracting global C symbols from '$dlprefile'" + func_basename "$dlprefile" + name=$func_basename_result + case $host in + *cygwin* | *mingw* | *cegcc* ) + # if an import library, we need to obtain dlname + if func_win32_import_lib_p "$dlprefile"; then + func_tr_sh "$dlprefile" + eval "curr_lafile=\$libfile_$func_tr_sh_result" + dlprefile_dlbasename= + if test -n "$curr_lafile" && func_lalib_p "$curr_lafile"; then + # Use subshell, to avoid clobbering current variable values + dlprefile_dlname=`source "$curr_lafile" && echo "$dlname"` + if test -n "$dlprefile_dlname"; then + func_basename "$dlprefile_dlname" + dlprefile_dlbasename=$func_basename_result + else + # no lafile. user explicitly requested -dlpreopen . + $sharedlib_from_linklib_cmd "$dlprefile" + dlprefile_dlbasename=$sharedlib_from_linklib_result + fi + fi + $opt_dry_run || { + if test -n "$dlprefile_dlbasename"; then + eval '$ECHO ": $dlprefile_dlbasename" >> "$nlist"' + else + func_warning "Could not compute DLL name from $name" + eval '$ECHO ": $name " >> "$nlist"' + fi + func_to_tool_file "$dlprefile" func_convert_file_msys_to_w32 + eval "$NM \"$func_to_tool_file_result\" 2>/dev/null | $global_symbol_pipe | + $SED -e '/I __imp/d' -e 's/I __nm_/D /;s/_nm__//' >> '$nlist'" + } + else # not an import lib + $opt_dry_run || { + eval '$ECHO ": $name " >> "$nlist"' + func_to_tool_file "$dlprefile" func_convert_file_msys_to_w32 + eval "$NM \"$func_to_tool_file_result\" 2>/dev/null | $global_symbol_pipe >> '$nlist'" + } + fi + ;; + *) + $opt_dry_run || { + eval '$ECHO ": $name " >> "$nlist"' + func_to_tool_file "$dlprefile" func_convert_file_msys_to_w32 + eval "$NM \"$func_to_tool_file_result\" 2>/dev/null | $global_symbol_pipe >> '$nlist'" + } + ;; + esac + done + + $opt_dry_run || { + # Make sure we have at least an empty file. + test -f "$nlist" || : > "$nlist" + + if test -n "$exclude_expsyms"; then + $EGREP -v " ($exclude_expsyms)$" "$nlist" > "$nlist"T + $MV "$nlist"T "$nlist" + fi + + # Try sorting and uniquifying the output. + if $GREP -v "^: " < "$nlist" | + if sort -k 3 /dev/null 2>&1; then + sort -k 3 + else + sort +2 + fi | + uniq > "$nlist"S; then + : + else + $GREP -v "^: " < "$nlist" > "$nlist"S + fi + + if test -f "$nlist"S; then + eval "$global_symbol_to_cdecl"' < "$nlist"S >> "$output_objdir/$my_dlsyms"' + else + echo '/* NONE */' >> "$output_objdir/$my_dlsyms" + fi + + func_show_eval '$RM "${nlist}I"' + if test -n "$global_symbol_to_import"; then + eval "$global_symbol_to_import"' < "$nlist"S > "$nlist"I' + fi + + echo >> "$output_objdir/$my_dlsyms" "\ + +/* The mapping between symbol names and symbols. */ +typedef struct { + const char *name; + void *address; +} lt_dlsymlist; +extern LT_DLSYM_CONST lt_dlsymlist +lt_${my_prefix}_LTX_preloaded_symbols[];\ +" + + if test -s "$nlist"I; then + echo >> "$output_objdir/$my_dlsyms" "\ +static void lt_syminit(void) +{ + LT_DLSYM_CONST lt_dlsymlist *symbol = lt_${my_prefix}_LTX_preloaded_symbols; + for (; symbol->name; ++symbol) + {" + $SED 's/.*/ if (STREQ (symbol->name, \"&\")) symbol->address = (void *) \&&;/' < "$nlist"I >> "$output_objdir/$my_dlsyms" + echo >> "$output_objdir/$my_dlsyms" "\ + } +}" + fi + echo >> "$output_objdir/$my_dlsyms" "\ +LT_DLSYM_CONST lt_dlsymlist +lt_${my_prefix}_LTX_preloaded_symbols[] = +{ {\"$my_originator\", (void *) 0}," + + if test -s "$nlist"I; then + echo >> "$output_objdir/$my_dlsyms" "\ + {\"@INIT@\", (void *) <_syminit}," + fi + + case $need_lib_prefix in + no) + eval "$global_symbol_to_c_name_address" < "$nlist" >> "$output_objdir/$my_dlsyms" + ;; + *) + eval "$global_symbol_to_c_name_address_lib_prefix" < "$nlist" >> "$output_objdir/$my_dlsyms" + ;; + esac + echo >> "$output_objdir/$my_dlsyms" "\ + {0, (void *) 0} +}; + +/* This works around a problem in FreeBSD linker */ +#ifdef FREEBSD_WORKAROUND +static const void *lt_preloaded_setup() { + return lt_${my_prefix}_LTX_preloaded_symbols; +} +#endif + +#ifdef __cplusplus +} +#endif\ +" + } # !$opt_dry_run + + pic_flag_for_symtable= + case "$compile_command " in + *" -static "*) ;; + *) + case $host in + # compiling the symbol table file with pic_flag works around + # a FreeBSD bug that causes programs to crash when -lm is + # linked before any other PIC object. But we must not use + # pic_flag when linking with -static. The problem exists in + # FreeBSD 2.2.6 and is fixed in FreeBSD 3.1. + *-*-freebsd2.*|*-*-freebsd3.0*|*-*-freebsdelf3.0*) + pic_flag_for_symtable=" $pic_flag -DFREEBSD_WORKAROUND" ;; + *-*-hpux*) + pic_flag_for_symtable=" $pic_flag" ;; + *) + $my_pic_p && pic_flag_for_symtable=" $pic_flag" + ;; + esac + ;; + esac + symtab_cflags= + for arg in $LTCFLAGS; do + case $arg in + -pie | -fpie | -fPIE) ;; + *) func_append symtab_cflags " $arg" ;; + esac + done + + # Now compile the dynamic symbol file. + func_show_eval '(cd $output_objdir && $LTCC$symtab_cflags -c$no_builtin_flag$pic_flag_for_symtable "$my_dlsyms")' 'exit $?' + + # Clean up the generated files. + func_show_eval '$RM "$output_objdir/$my_dlsyms" "$nlist" "${nlist}S" "${nlist}T" "${nlist}I"' + + # Transform the symbol file into the correct name. + symfileobj=$output_objdir/${my_outputname}S.$objext + case $host in + *cygwin* | *mingw* | *cegcc* ) + if test -f "$output_objdir/$my_outputname.def"; then + compile_command=`$ECHO "$compile_command" | $SED "s%@SYMFILE@%$output_objdir/$my_outputname.def $symfileobj%"` + finalize_command=`$ECHO "$finalize_command" | $SED "s%@SYMFILE@%$output_objdir/$my_outputname.def $symfileobj%"` + else + compile_command=`$ECHO "$compile_command" | $SED "s%@SYMFILE@%$symfileobj%"` + finalize_command=`$ECHO "$finalize_command" | $SED "s%@SYMFILE@%$symfileobj%"` + fi + ;; + *) + compile_command=`$ECHO "$compile_command" | $SED "s%@SYMFILE@%$symfileobj%"` + finalize_command=`$ECHO "$finalize_command" | $SED "s%@SYMFILE@%$symfileobj%"` + ;; + esac + ;; + *) + func_fatal_error "unknown suffix for '$my_dlsyms'" + ;; + esac + else + # We keep going just in case the user didn't refer to + # lt_preloaded_symbols. The linker will fail if global_symbol_pipe + # really was required. + + # Nullify the symbol file. + compile_command=`$ECHO "$compile_command" | $SED "s% @SYMFILE@%%"` + finalize_command=`$ECHO "$finalize_command" | $SED "s% @SYMFILE@%%"` + fi +} + +# func_cygming_gnu_implib_p ARG +# This predicate returns with zero status (TRUE) if +# ARG is a GNU/binutils-style import library. Returns +# with nonzero status (FALSE) otherwise. +func_cygming_gnu_implib_p () +{ + $debug_cmd + + func_to_tool_file "$1" func_convert_file_msys_to_w32 + func_cygming_gnu_implib_tmp=`$NM "$func_to_tool_file_result" | eval "$global_symbol_pipe" | $EGREP ' (_head_[A-Za-z0-9_]+_[ad]l*|[A-Za-z0-9_]+_[ad]l*_iname)$'` + test -n "$func_cygming_gnu_implib_tmp" +} + +# func_cygming_ms_implib_p ARG +# This predicate returns with zero status (TRUE) if +# ARG is an MS-style import library. Returns +# with nonzero status (FALSE) otherwise. +func_cygming_ms_implib_p () +{ + $debug_cmd + + func_to_tool_file "$1" func_convert_file_msys_to_w32 + func_cygming_ms_implib_tmp=`$NM "$func_to_tool_file_result" | eval "$global_symbol_pipe" | $GREP '_NULL_IMPORT_DESCRIPTOR'` + test -n "$func_cygming_ms_implib_tmp" +} + +# func_win32_libid arg +# return the library type of file 'arg' +# +# Need a lot of goo to handle *both* DLLs and import libs +# Has to be a shell function in order to 'eat' the argument +# that is supplied when $file_magic_command is called. +# Despite the name, also deal with 64 bit binaries. +func_win32_libid () +{ + $debug_cmd + + win32_libid_type=unknown + win32_fileres=`file -L $1 2>/dev/null` + case $win32_fileres in + *ar\ archive\ import\ library*) # definitely import + win32_libid_type="x86 archive import" + ;; + *ar\ archive*) # could be an import, or static + # Keep the egrep pattern in sync with the one in _LT_CHECK_MAGIC_METHOD. + if eval $OBJDUMP -f $1 | $SED -e '10q' 2>/dev/null | + $EGREP 'file format (pei*-i386(.*architecture: i386)?|pe-arm-wince|pe-x86-64)' >/dev/null; then + case $nm_interface in + "MS dumpbin") + if func_cygming_ms_implib_p "$1" || + func_cygming_gnu_implib_p "$1" + then + win32_nmres=import + else + win32_nmres= + fi + ;; + *) + func_to_tool_file "$1" func_convert_file_msys_to_w32 + win32_nmres=`eval $NM -f posix -A \"$func_to_tool_file_result\" | + $SED -n -e ' + 1,100{ + / I /{ + s|.*|import| + p + q + } + }'` + ;; + esac + case $win32_nmres in + import*) win32_libid_type="x86 archive import";; + *) win32_libid_type="x86 archive static";; + esac + fi + ;; + *DLL*) + win32_libid_type="x86 DLL" + ;; + *executable*) # but shell scripts are "executable" too... + case $win32_fileres in + *MS\ Windows\ PE\ Intel*) + win32_libid_type="x86 DLL" + ;; + esac + ;; + esac + $ECHO "$win32_libid_type" +} + +# func_cygming_dll_for_implib ARG +# +# Platform-specific function to extract the +# name of the DLL associated with the specified +# import library ARG. +# Invoked by eval'ing the libtool variable +# $sharedlib_from_linklib_cmd +# Result is available in the variable +# $sharedlib_from_linklib_result +func_cygming_dll_for_implib () +{ + $debug_cmd + + sharedlib_from_linklib_result=`$DLLTOOL --identify-strict --identify "$1"` +} + +# func_cygming_dll_for_implib_fallback_core SECTION_NAME LIBNAMEs +# +# The is the core of a fallback implementation of a +# platform-specific function to extract the name of the +# DLL associated with the specified import library LIBNAME. +# +# SECTION_NAME is either .idata$6 or .idata$7, depending +# on the platform and compiler that created the implib. +# +# Echos the name of the DLL associated with the +# specified import library. +func_cygming_dll_for_implib_fallback_core () +{ + $debug_cmd + + match_literal=`$ECHO "$1" | $SED "$sed_make_literal_regex"` + $OBJDUMP -s --section "$1" "$2" 2>/dev/null | + $SED '/^Contents of section '"$match_literal"':/{ + # Place marker at beginning of archive member dllname section + s/.*/====MARK====/ + p + d + } + # These lines can sometimes be longer than 43 characters, but + # are always uninteresting + /:[ ]*file format pe[i]\{,1\}-/d + /^In archive [^:]*:/d + # Ensure marker is printed + /^====MARK====/p + # Remove all lines with less than 43 characters + /^.\{43\}/!d + # From remaining lines, remove first 43 characters + s/^.\{43\}//' | + $SED -n ' + # Join marker and all lines until next marker into a single line + /^====MARK====/ b para + H + $ b para + b + :para + x + s/\n//g + # Remove the marker + s/^====MARK====// + # Remove trailing dots and whitespace + s/[\. \t]*$// + # Print + /./p' | + # we now have a list, one entry per line, of the stringified + # contents of the appropriate section of all members of the + # archive that possess that section. Heuristic: eliminate + # all those that have a first or second character that is + # a '.' (that is, objdump's representation of an unprintable + # character.) This should work for all archives with less than + # 0x302f exports -- but will fail for DLLs whose name actually + # begins with a literal '.' or a single character followed by + # a '.'. + # + # Of those that remain, print the first one. + $SED -e '/^\./d;/^.\./d;q' +} + +# func_cygming_dll_for_implib_fallback ARG +# Platform-specific function to extract the +# name of the DLL associated with the specified +# import library ARG. +# +# This fallback implementation is for use when $DLLTOOL +# does not support the --identify-strict option. +# Invoked by eval'ing the libtool variable +# $sharedlib_from_linklib_cmd +# Result is available in the variable +# $sharedlib_from_linklib_result +func_cygming_dll_for_implib_fallback () +{ + $debug_cmd + + if func_cygming_gnu_implib_p "$1"; then + # binutils import library + sharedlib_from_linklib_result=`func_cygming_dll_for_implib_fallback_core '.idata$7' "$1"` + elif func_cygming_ms_implib_p "$1"; then + # ms-generated import library + sharedlib_from_linklib_result=`func_cygming_dll_for_implib_fallback_core '.idata$6' "$1"` + else + # unknown + sharedlib_from_linklib_result= + fi +} + + +# func_extract_an_archive dir oldlib +func_extract_an_archive () +{ + $debug_cmd + + f_ex_an_ar_dir=$1; shift + f_ex_an_ar_oldlib=$1 + if test yes = "$lock_old_archive_extraction"; then + lockfile=$f_ex_an_ar_oldlib.lock + until $opt_dry_run || ln "$progpath" "$lockfile" 2>/dev/null; do + func_echo "Waiting for $lockfile to be removed" + sleep 2 + done + fi + func_show_eval "(cd \$f_ex_an_ar_dir && $AR x \"\$f_ex_an_ar_oldlib\")" \ + 'stat=$?; rm -f "$lockfile"; exit $stat' + if test yes = "$lock_old_archive_extraction"; then + $opt_dry_run || rm -f "$lockfile" + fi + if ($AR t "$f_ex_an_ar_oldlib" | sort | sort -uc >/dev/null 2>&1); then + : + else + func_fatal_error "object name conflicts in archive: $f_ex_an_ar_dir/$f_ex_an_ar_oldlib" + fi +} + + +# func_extract_archives gentop oldlib ... +func_extract_archives () +{ + $debug_cmd + + my_gentop=$1; shift + my_oldlibs=${1+"$@"} + my_oldobjs= + my_xlib= + my_xabs= + my_xdir= + + for my_xlib in $my_oldlibs; do + # Extract the objects. + case $my_xlib in + [\\/]* | [A-Za-z]:[\\/]*) my_xabs=$my_xlib ;; + *) my_xabs=`pwd`"/$my_xlib" ;; + esac + func_basename "$my_xlib" + my_xlib=$func_basename_result + my_xlib_u=$my_xlib + while :; do + case " $extracted_archives " in + *" $my_xlib_u "*) + func_arith $extracted_serial + 1 + extracted_serial=$func_arith_result + my_xlib_u=lt$extracted_serial-$my_xlib ;; + *) break ;; + esac + done + extracted_archives="$extracted_archives $my_xlib_u" + my_xdir=$my_gentop/$my_xlib_u + + func_mkdir_p "$my_xdir" + + case $host in + *-darwin*) + func_verbose "Extracting $my_xabs" + # Do not bother doing anything if just a dry run + $opt_dry_run || { + darwin_orig_dir=`pwd` + cd $my_xdir || exit $? + darwin_archive=$my_xabs + darwin_curdir=`pwd` + func_basename "$darwin_archive" + darwin_base_archive=$func_basename_result + darwin_arches=`$LIPO -info "$darwin_archive" 2>/dev/null | $GREP Architectures 2>/dev/null || true` + if test -n "$darwin_arches"; then + darwin_arches=`$ECHO "$darwin_arches" | $SED -e 's/.*are://'` + darwin_arch= + func_verbose "$darwin_base_archive has multiple architectures $darwin_arches" + for darwin_arch in $darwin_arches; do + func_mkdir_p "unfat-$$/$darwin_base_archive-$darwin_arch" + $LIPO -thin $darwin_arch -output "unfat-$$/$darwin_base_archive-$darwin_arch/$darwin_base_archive" "$darwin_archive" + cd "unfat-$$/$darwin_base_archive-$darwin_arch" + func_extract_an_archive "`pwd`" "$darwin_base_archive" + cd "$darwin_curdir" + $RM "unfat-$$/$darwin_base_archive-$darwin_arch/$darwin_base_archive" + done # $darwin_arches + ## Okay now we've a bunch of thin objects, gotta fatten them up :) + darwin_filelist=`find unfat-$$ -type f -name \*.o -print -o -name \*.lo -print | $SED -e "$sed_basename" | sort -u` + darwin_file= + darwin_files= + for darwin_file in $darwin_filelist; do + darwin_files=`find unfat-$$ -name $darwin_file -print | sort | $NL2SP` + $LIPO -create -output "$darwin_file" $darwin_files + done # $darwin_filelist + $RM -rf unfat-$$ + cd "$darwin_orig_dir" + else + cd $darwin_orig_dir + func_extract_an_archive "$my_xdir" "$my_xabs" + fi # $darwin_arches + } # !$opt_dry_run + ;; + *) + func_extract_an_archive "$my_xdir" "$my_xabs" + ;; + esac + my_oldobjs="$my_oldobjs "`find $my_xdir -name \*.$objext -print -o -name \*.lo -print | sort | $NL2SP` + done + + func_extract_archives_result=$my_oldobjs +} + + +# func_emit_wrapper [arg=no] +# +# Emit a libtool wrapper script on stdout. +# Don't directly open a file because we may want to +# incorporate the script contents within a cygwin/mingw +# wrapper executable. Must ONLY be called from within +# func_mode_link because it depends on a number of variables +# set therein. +# +# ARG is the value that the WRAPPER_SCRIPT_BELONGS_IN_OBJDIR +# variable will take. If 'yes', then the emitted script +# will assume that the directory where it is stored is +# the $objdir directory. This is a cygwin/mingw-specific +# behavior. +func_emit_wrapper () +{ + func_emit_wrapper_arg1=${1-no} + + $ECHO "\ +#! $SHELL + +# $output - temporary wrapper script for $objdir/$outputname +# Generated by $PROGRAM (GNU $PACKAGE) $VERSION +# +# The $output program cannot be directly executed until all the libtool +# libraries that it depends on are installed. +# +# This wrapper script should never be moved out of the build directory. +# If it is, it will not operate correctly. + +# Sed substitution that helps us do robust quoting. It backslashifies +# metacharacters that are still active within double-quoted strings. +sed_quote_subst='$sed_quote_subst' + +# Be Bourne compatible +if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then + emulate sh + NULLCMD=: + # Zsh 3.x and 4.x performs word splitting on \${1+\"\$@\"}, which + # is contrary to our usage. Disable this feature. + alias -g '\${1+\"\$@\"}'='\"\$@\"' + setopt NO_GLOB_SUBST +else + case \`(set -o) 2>/dev/null\` in *posix*) set -o posix;; esac +fi +BIN_SH=xpg4; export BIN_SH # for Tru64 +DUALCASE=1; export DUALCASE # for MKS sh + +# The HP-UX ksh and POSIX shell print the target directory to stdout +# if CDPATH is set. +(unset CDPATH) >/dev/null 2>&1 && unset CDPATH + +relink_command=\"$relink_command\" + +# This environment variable determines our operation mode. +if test \"\$libtool_install_magic\" = \"$magic\"; then + # install mode needs the following variables: + generated_by_libtool_version='$macro_version' + notinst_deplibs='$notinst_deplibs' +else + # When we are sourced in execute mode, \$file and \$ECHO are already set. + if test \"\$libtool_execute_magic\" != \"$magic\"; then + file=\"\$0\"" + + func_quote_arg pretty "$ECHO" + qECHO=$func_quote_arg_result + $ECHO "\ + +# A function that is used when there is no print builtin or printf. +func_fallback_echo () +{ + eval 'cat <<_LTECHO_EOF +\$1 +_LTECHO_EOF' +} + ECHO=$qECHO + fi + +# Very basic option parsing. These options are (a) specific to +# the libtool wrapper, (b) are identical between the wrapper +# /script/ and the wrapper /executable/ that is used only on +# windows platforms, and (c) all begin with the string "--lt-" +# (application programs are unlikely to have options that match +# this pattern). +# +# There are only two supported options: --lt-debug and +# --lt-dump-script. There is, deliberately, no --lt-help. +# +# The first argument to this parsing function should be the +# script's $0 value, followed by "$@". +lt_option_debug= +func_parse_lt_options () +{ + lt_script_arg0=\$0 + shift + for lt_opt + do + case \"\$lt_opt\" in + --lt-debug) lt_option_debug=1 ;; + --lt-dump-script) + lt_dump_D=\`\$ECHO \"X\$lt_script_arg0\" | $SED -e 's/^X//' -e 's%/[^/]*$%%'\` + test \"X\$lt_dump_D\" = \"X\$lt_script_arg0\" && lt_dump_D=. + lt_dump_F=\`\$ECHO \"X\$lt_script_arg0\" | $SED -e 's/^X//' -e 's%^.*/%%'\` + cat \"\$lt_dump_D/\$lt_dump_F\" + exit 0 + ;; + --lt-*) + \$ECHO \"Unrecognized --lt- option: '\$lt_opt'\" 1>&2 + exit 1 + ;; + esac + done + + # Print the debug banner immediately: + if test -n \"\$lt_option_debug\"; then + echo \"$outputname:$output:\$LINENO: libtool wrapper (GNU $PACKAGE) $VERSION\" 1>&2 + fi +} + +# Used when --lt-debug. Prints its arguments to stdout +# (redirection is the responsibility of the caller) +func_lt_dump_args () +{ + lt_dump_args_N=1; + for lt_arg + do + \$ECHO \"$outputname:$output:\$LINENO: newargv[\$lt_dump_args_N]: \$lt_arg\" + lt_dump_args_N=\`expr \$lt_dump_args_N + 1\` + done +} + +# Core function for launching the target application +func_exec_program_core () +{ +" + case $host in + # Backslashes separate directories on plain windows + *-*-mingw | *-*-os2* | *-cegcc*) + $ECHO "\ + if test -n \"\$lt_option_debug\"; then + \$ECHO \"$outputname:$output:\$LINENO: newargv[0]: \$progdir\\\\\$program\" 1>&2 + func_lt_dump_args \${1+\"\$@\"} 1>&2 + fi + exec \"\$progdir\\\\\$program\" \${1+\"\$@\"} +" + ;; + + *) + $ECHO "\ + if test -n \"\$lt_option_debug\"; then + \$ECHO \"$outputname:$output:\$LINENO: newargv[0]: \$progdir/\$program\" 1>&2 + func_lt_dump_args \${1+\"\$@\"} 1>&2 + fi + exec \"\$progdir/\$program\" \${1+\"\$@\"} +" + ;; + esac + $ECHO "\ + \$ECHO \"\$0: cannot exec \$program \$*\" 1>&2 + exit 1 +} + +# A function to encapsulate launching the target application +# Strips options in the --lt-* namespace from \$@ and +# launches target application with the remaining arguments. +func_exec_program () +{ + case \" \$* \" in + *\\ --lt-*) + for lt_wr_arg + do + case \$lt_wr_arg in + --lt-*) ;; + *) set x \"\$@\" \"\$lt_wr_arg\"; shift;; + esac + shift + done ;; + esac + func_exec_program_core \${1+\"\$@\"} +} + + # Parse options + func_parse_lt_options \"\$0\" \${1+\"\$@\"} + + # Find the directory that this script lives in. + thisdir=\`\$ECHO \"\$file\" | $SED 's%/[^/]*$%%'\` + test \"x\$thisdir\" = \"x\$file\" && thisdir=. + + # Follow symbolic links until we get to the real thisdir. + file=\`ls -ld \"\$file\" | $SED -n 's/.*-> //p'\` + while test -n \"\$file\"; do + destdir=\`\$ECHO \"\$file\" | $SED 's%/[^/]*\$%%'\` + + # If there was a directory component, then change thisdir. + if test \"x\$destdir\" != \"x\$file\"; then + case \"\$destdir\" in + [\\\\/]* | [A-Za-z]:[\\\\/]*) thisdir=\"\$destdir\" ;; + *) thisdir=\"\$thisdir/\$destdir\" ;; + esac + fi + + file=\`\$ECHO \"\$file\" | $SED 's%^.*/%%'\` + file=\`ls -ld \"\$thisdir/\$file\" | $SED -n 's/.*-> //p'\` + done + + # Usually 'no', except on cygwin/mingw when embedded into + # the cwrapper. + WRAPPER_SCRIPT_BELONGS_IN_OBJDIR=$func_emit_wrapper_arg1 + if test \"\$WRAPPER_SCRIPT_BELONGS_IN_OBJDIR\" = \"yes\"; then + # special case for '.' + if test \"\$thisdir\" = \".\"; then + thisdir=\`pwd\` + fi + # remove .libs from thisdir + case \"\$thisdir\" in + *[\\\\/]$objdir ) thisdir=\`\$ECHO \"\$thisdir\" | $SED 's%[\\\\/][^\\\\/]*$%%'\` ;; + $objdir ) thisdir=. ;; + esac + fi + + # Try to get the absolute directory name. + absdir=\`cd \"\$thisdir\" && pwd\` + test -n \"\$absdir\" && thisdir=\"\$absdir\" +" + + if test yes = "$fast_install"; then + $ECHO "\ + program=lt-'$outputname'$exeext + progdir=\"\$thisdir/$objdir\" + + if test ! -f \"\$progdir/\$program\" || + { file=\`ls -1dt \"\$progdir/\$program\" \"\$progdir/../\$program\" 2>/dev/null | $SED 1q\`; \\ + test \"X\$file\" != \"X\$progdir/\$program\"; }; then + + file=\"\$\$-\$program\" + + if test ! -d \"\$progdir\"; then + $MKDIR \"\$progdir\" + else + $RM \"\$progdir/\$file\" + fi" + + $ECHO "\ + + # relink executable if necessary + if test -n \"\$relink_command\"; then + if relink_command_output=\`eval \$relink_command 2>&1\`; then : + else + \$ECHO \"\$relink_command_output\" >&2 + $RM \"\$progdir/\$file\" + exit 1 + fi + fi + + $MV \"\$progdir/\$file\" \"\$progdir/\$program\" 2>/dev/null || + { $RM \"\$progdir/\$program\"; + $MV \"\$progdir/\$file\" \"\$progdir/\$program\"; } + $RM \"\$progdir/\$file\" + fi" + else + $ECHO "\ + program='$outputname' + progdir=\"\$thisdir/$objdir\" +" + fi + + $ECHO "\ + + if test -f \"\$progdir/\$program\"; then" + + # fixup the dll searchpath if we need to. + # + # Fix the DLL searchpath if we need to. Do this before prepending + # to shlibpath, because on Windows, both are PATH and uninstalled + # libraries must come first. + if test -n "$dllsearchpath"; then + $ECHO "\ + # Add the dll search path components to the executable PATH + PATH=$dllsearchpath:\$PATH +" + fi + + # Export our shlibpath_var if we have one. + if test yes = "$shlibpath_overrides_runpath" && test -n "$shlibpath_var" && test -n "$temp_rpath"; then + $ECHO "\ + # Add our own library path to $shlibpath_var + $shlibpath_var=\"$temp_rpath\$$shlibpath_var\" + + # Some systems cannot cope with colon-terminated $shlibpath_var + # The second colon is a workaround for a bug in BeOS R4 sed + $shlibpath_var=\`\$ECHO \"\$$shlibpath_var\" | $SED 's/::*\$//'\` + + export $shlibpath_var +" + fi + + $ECHO "\ + if test \"\$libtool_execute_magic\" != \"$magic\"; then + # Run the actual program with our arguments. + func_exec_program \${1+\"\$@\"} + fi + else + # The program doesn't exist. + \$ECHO \"\$0: error: '\$progdir/\$program' does not exist\" 1>&2 + \$ECHO \"This script is just a wrapper for \$program.\" 1>&2 + \$ECHO \"See the $PACKAGE documentation for more information.\" 1>&2 + exit 1 + fi +fi\ +" +} + + +# func_emit_cwrapperexe_src +# emit the source code for a wrapper executable on stdout +# Must ONLY be called from within func_mode_link because +# it depends on a number of variable set therein. +func_emit_cwrapperexe_src () +{ + cat < +#include +#ifdef _MSC_VER +# include +# include +# include +#else +# include +# include +# ifdef __CYGWIN__ +# include +# endif +#endif +#include +#include +#include +#include +#include +#include +#include +#include + +#define STREQ(s1, s2) (strcmp ((s1), (s2)) == 0) + +/* declarations of non-ANSI functions */ +#if defined __MINGW32__ +# ifdef __STRICT_ANSI__ +int _putenv (const char *); +# endif +#elif defined __CYGWIN__ +# ifdef __STRICT_ANSI__ +char *realpath (const char *, char *); +int putenv (char *); +int setenv (const char *, const char *, int); +# endif +/* #elif defined other_platform || defined ... */ +#endif + +/* portability defines, excluding path handling macros */ +#if defined _MSC_VER +# define setmode _setmode +# define stat _stat +# define chmod _chmod +# define getcwd _getcwd +# define putenv _putenv +# define S_IXUSR _S_IEXEC +#elif defined __MINGW32__ +# define setmode _setmode +# define stat _stat +# define chmod _chmod +# define getcwd _getcwd +# define putenv _putenv +#elif defined __CYGWIN__ +# define HAVE_SETENV +# define FOPEN_WB "wb" +/* #elif defined other platforms ... */ +#endif + +#if defined PATH_MAX +# define LT_PATHMAX PATH_MAX +#elif defined MAXPATHLEN +# define LT_PATHMAX MAXPATHLEN +#else +# define LT_PATHMAX 1024 +#endif + +#ifndef S_IXOTH +# define S_IXOTH 0 +#endif +#ifndef S_IXGRP +# define S_IXGRP 0 +#endif + +/* path handling portability macros */ +#ifndef DIR_SEPARATOR +# define DIR_SEPARATOR '/' +# define PATH_SEPARATOR ':' +#endif + +#if defined _WIN32 || defined __MSDOS__ || defined __DJGPP__ || \ + defined __OS2__ +# define HAVE_DOS_BASED_FILE_SYSTEM +# define FOPEN_WB "wb" +# ifndef DIR_SEPARATOR_2 +# define DIR_SEPARATOR_2 '\\' +# endif +# ifndef PATH_SEPARATOR_2 +# define PATH_SEPARATOR_2 ';' +# endif +#endif + +#ifndef DIR_SEPARATOR_2 +# define IS_DIR_SEPARATOR(ch) ((ch) == DIR_SEPARATOR) +#else /* DIR_SEPARATOR_2 */ +# define IS_DIR_SEPARATOR(ch) \ + (((ch) == DIR_SEPARATOR) || ((ch) == DIR_SEPARATOR_2)) +#endif /* DIR_SEPARATOR_2 */ + +#ifndef PATH_SEPARATOR_2 +# define IS_PATH_SEPARATOR(ch) ((ch) == PATH_SEPARATOR) +#else /* PATH_SEPARATOR_2 */ +# define IS_PATH_SEPARATOR(ch) ((ch) == PATH_SEPARATOR_2) +#endif /* PATH_SEPARATOR_2 */ + +#ifndef FOPEN_WB +# define FOPEN_WB "w" +#endif +#ifndef _O_BINARY +# define _O_BINARY 0 +#endif + +#define XMALLOC(type, num) ((type *) xmalloc ((num) * sizeof(type))) +#define XFREE(stale) do { \ + if (stale) { free (stale); stale = 0; } \ +} while (0) + +#if defined LT_DEBUGWRAPPER +static int lt_debug = 1; +#else +static int lt_debug = 0; +#endif + +const char *program_name = "libtool-wrapper"; /* in case xstrdup fails */ + +void *xmalloc (size_t num); +char *xstrdup (const char *string); +const char *base_name (const char *name); +char *find_executable (const char *wrapper); +char *chase_symlinks (const char *pathspec); +int make_executable (const char *path); +int check_executable (const char *path); +char *strendzap (char *str, const char *pat); +void lt_debugprintf (const char *file, int line, const char *fmt, ...); +void lt_fatal (const char *file, int line, const char *message, ...); +static const char *nonnull (const char *s); +static const char *nonempty (const char *s); +void lt_setenv (const char *name, const char *value); +char *lt_extend_str (const char *orig_value, const char *add, int to_end); +void lt_update_exe_path (const char *name, const char *value); +void lt_update_lib_path (const char *name, const char *value); +char **prepare_spawn (char **argv); +void lt_dump_script (FILE *f); +EOF + + cat <= 0) + && (st.st_mode & (S_IXUSR | S_IXGRP | S_IXOTH))) + return 1; + else + return 0; +} + +int +make_executable (const char *path) +{ + int rval = 0; + struct stat st; + + lt_debugprintf (__FILE__, __LINE__, "(make_executable): %s\n", + nonempty (path)); + if ((!path) || (!*path)) + return 0; + + if (stat (path, &st) >= 0) + { + rval = chmod (path, st.st_mode | S_IXOTH | S_IXGRP | S_IXUSR); + } + return rval; +} + +/* Searches for the full path of the wrapper. Returns + newly allocated full path name if found, NULL otherwise + Does not chase symlinks, even on platforms that support them. +*/ +char * +find_executable (const char *wrapper) +{ + int has_slash = 0; + const char *p; + const char *p_next; + /* static buffer for getcwd */ + char tmp[LT_PATHMAX + 1]; + size_t tmp_len; + char *concat_name; + + lt_debugprintf (__FILE__, __LINE__, "(find_executable): %s\n", + nonempty (wrapper)); + + if ((wrapper == NULL) || (*wrapper == '\0')) + return NULL; + + /* Absolute path? */ +#if defined HAVE_DOS_BASED_FILE_SYSTEM + if (isalpha ((unsigned char) wrapper[0]) && wrapper[1] == ':') + { + concat_name = xstrdup (wrapper); + if (check_executable (concat_name)) + return concat_name; + XFREE (concat_name); + } + else + { +#endif + if (IS_DIR_SEPARATOR (wrapper[0])) + { + concat_name = xstrdup (wrapper); + if (check_executable (concat_name)) + return concat_name; + XFREE (concat_name); + } +#if defined HAVE_DOS_BASED_FILE_SYSTEM + } +#endif + + for (p = wrapper; *p; p++) + if (*p == '/') + { + has_slash = 1; + break; + } + if (!has_slash) + { + /* no slashes; search PATH */ + const char *path = getenv ("PATH"); + if (path != NULL) + { + for (p = path; *p; p = p_next) + { + const char *q; + size_t p_len; + for (q = p; *q; q++) + if (IS_PATH_SEPARATOR (*q)) + break; + p_len = (size_t) (q - p); + p_next = (*q == '\0' ? q : q + 1); + if (p_len == 0) + { + /* empty path: current directory */ + if (getcwd (tmp, LT_PATHMAX) == NULL) + lt_fatal (__FILE__, __LINE__, "getcwd failed: %s", + nonnull (strerror (errno))); + tmp_len = strlen (tmp); + concat_name = + XMALLOC (char, tmp_len + 1 + strlen (wrapper) + 1); + memcpy (concat_name, tmp, tmp_len); + concat_name[tmp_len] = '/'; + strcpy (concat_name + tmp_len + 1, wrapper); + } + else + { + concat_name = + XMALLOC (char, p_len + 1 + strlen (wrapper) + 1); + memcpy (concat_name, p, p_len); + concat_name[p_len] = '/'; + strcpy (concat_name + p_len + 1, wrapper); + } + if (check_executable (concat_name)) + return concat_name; + XFREE (concat_name); + } + } + /* not found in PATH; assume curdir */ + } + /* Relative path | not found in path: prepend cwd */ + if (getcwd (tmp, LT_PATHMAX) == NULL) + lt_fatal (__FILE__, __LINE__, "getcwd failed: %s", + nonnull (strerror (errno))); + tmp_len = strlen (tmp); + concat_name = XMALLOC (char, tmp_len + 1 + strlen (wrapper) + 1); + memcpy (concat_name, tmp, tmp_len); + concat_name[tmp_len] = '/'; + strcpy (concat_name + tmp_len + 1, wrapper); + + if (check_executable (concat_name)) + return concat_name; + XFREE (concat_name); + return NULL; +} + +char * +chase_symlinks (const char *pathspec) +{ +#ifndef S_ISLNK + return xstrdup (pathspec); +#else + char buf[LT_PATHMAX]; + struct stat s; + char *tmp_pathspec = xstrdup (pathspec); + char *p; + int has_symlinks = 0; + while (strlen (tmp_pathspec) && !has_symlinks) + { + lt_debugprintf (__FILE__, __LINE__, + "checking path component for symlinks: %s\n", + tmp_pathspec); + if (lstat (tmp_pathspec, &s) == 0) + { + if (S_ISLNK (s.st_mode) != 0) + { + has_symlinks = 1; + break; + } + + /* search backwards for last DIR_SEPARATOR */ + p = tmp_pathspec + strlen (tmp_pathspec) - 1; + while ((p > tmp_pathspec) && (!IS_DIR_SEPARATOR (*p))) + p--; + if ((p == tmp_pathspec) && (!IS_DIR_SEPARATOR (*p))) + { + /* no more DIR_SEPARATORS left */ + break; + } + *p = '\0'; + } + else + { + lt_fatal (__FILE__, __LINE__, + "error accessing file \"%s\": %s", + tmp_pathspec, nonnull (strerror (errno))); + } + } + XFREE (tmp_pathspec); + + if (!has_symlinks) + { + return xstrdup (pathspec); + } + + tmp_pathspec = realpath (pathspec, buf); + if (tmp_pathspec == 0) + { + lt_fatal (__FILE__, __LINE__, + "could not follow symlinks for %s", pathspec); + } + return xstrdup (tmp_pathspec); +#endif +} + +char * +strendzap (char *str, const char *pat) +{ + size_t len, patlen; + + assert (str != NULL); + assert (pat != NULL); + + len = strlen (str); + patlen = strlen (pat); + + if (patlen <= len) + { + str += len - patlen; + if (STREQ (str, pat)) + *str = '\0'; + } + return str; +} + +void +lt_debugprintf (const char *file, int line, const char *fmt, ...) +{ + va_list args; + if (lt_debug) + { + (void) fprintf (stderr, "%s:%s:%d: ", program_name, file, line); + va_start (args, fmt); + (void) vfprintf (stderr, fmt, args); + va_end (args); + } +} + +static void +lt_error_core (int exit_status, const char *file, + int line, const char *mode, + const char *message, va_list ap) +{ + fprintf (stderr, "%s:%s:%d: %s: ", program_name, file, line, mode); + vfprintf (stderr, message, ap); + fprintf (stderr, ".\n"); + + if (exit_status >= 0) + exit (exit_status); +} + +void +lt_fatal (const char *file, int line, const char *message, ...) +{ + va_list ap; + va_start (ap, message); + lt_error_core (EXIT_FAILURE, file, line, "FATAL", message, ap); + va_end (ap); +} + +static const char * +nonnull (const char *s) +{ + return s ? s : "(null)"; +} + +static const char * +nonempty (const char *s) +{ + return (s && !*s) ? "(empty)" : nonnull (s); +} + +void +lt_setenv (const char *name, const char *value) +{ + lt_debugprintf (__FILE__, __LINE__, + "(lt_setenv) setting '%s' to '%s'\n", + nonnull (name), nonnull (value)); + { +#ifdef HAVE_SETENV + /* always make a copy, for consistency with !HAVE_SETENV */ + char *str = xstrdup (value); + setenv (name, str, 1); +#else + size_t len = strlen (name) + 1 + strlen (value) + 1; + char *str = XMALLOC (char, len); + sprintf (str, "%s=%s", name, value); + if (putenv (str) != EXIT_SUCCESS) + { + XFREE (str); + } +#endif + } +} + +char * +lt_extend_str (const char *orig_value, const char *add, int to_end) +{ + char *new_value; + if (orig_value && *orig_value) + { + size_t orig_value_len = strlen (orig_value); + size_t add_len = strlen (add); + new_value = XMALLOC (char, add_len + orig_value_len + 1); + if (to_end) + { + strcpy (new_value, orig_value); + strcpy (new_value + orig_value_len, add); + } + else + { + strcpy (new_value, add); + strcpy (new_value + add_len, orig_value); + } + } + else + { + new_value = xstrdup (add); + } + return new_value; +} + +void +lt_update_exe_path (const char *name, const char *value) +{ + lt_debugprintf (__FILE__, __LINE__, + "(lt_update_exe_path) modifying '%s' by prepending '%s'\n", + nonnull (name), nonnull (value)); + + if (name && *name && value && *value) + { + char *new_value = lt_extend_str (getenv (name), value, 0); + /* some systems can't cope with a ':'-terminated path #' */ + size_t len = strlen (new_value); + while ((len > 0) && IS_PATH_SEPARATOR (new_value[len-1])) + { + new_value[--len] = '\0'; + } + lt_setenv (name, new_value); + XFREE (new_value); + } +} + +void +lt_update_lib_path (const char *name, const char *value) +{ + lt_debugprintf (__FILE__, __LINE__, + "(lt_update_lib_path) modifying '%s' by prepending '%s'\n", + nonnull (name), nonnull (value)); + + if (name && *name && value && *value) + { + char *new_value = lt_extend_str (getenv (name), value, 0); + lt_setenv (name, new_value); + XFREE (new_value); + } +} + +EOF + case $host_os in + mingw*) + cat <<"EOF" + +/* Prepares an argument vector before calling spawn(). + Note that spawn() does not by itself call the command interpreter + (getenv ("COMSPEC") != NULL ? getenv ("COMSPEC") : + ({ OSVERSIONINFO v; v.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); + GetVersionEx(&v); + v.dwPlatformId == VER_PLATFORM_WIN32_NT; + }) ? "cmd.exe" : "command.com"). + Instead it simply concatenates the arguments, separated by ' ', and calls + CreateProcess(). We must quote the arguments since Win32 CreateProcess() + interprets characters like ' ', '\t', '\\', '"' (but not '<' and '>') in a + special way: + - Space and tab are interpreted as delimiters. They are not treated as + delimiters if they are surrounded by double quotes: "...". + - Unescaped double quotes are removed from the input. Their only effect is + that within double quotes, space and tab are treated like normal + characters. + - Backslashes not followed by double quotes are not special. + - But 2*n+1 backslashes followed by a double quote become + n backslashes followed by a double quote (n >= 0): + \" -> " + \\\" -> \" + \\\\\" -> \\" + */ +#define SHELL_SPECIAL_CHARS "\"\\ \001\002\003\004\005\006\007\010\011\012\013\014\015\016\017\020\021\022\023\024\025\026\027\030\031\032\033\034\035\036\037" +#define SHELL_SPACE_CHARS " \001\002\003\004\005\006\007\010\011\012\013\014\015\016\017\020\021\022\023\024\025\026\027\030\031\032\033\034\035\036\037" +char ** +prepare_spawn (char **argv) +{ + size_t argc; + char **new_argv; + size_t i; + + /* Count number of arguments. */ + for (argc = 0; argv[argc] != NULL; argc++) + ; + + /* Allocate new argument vector. */ + new_argv = XMALLOC (char *, argc + 1); + + /* Put quoted arguments into the new argument vector. */ + for (i = 0; i < argc; i++) + { + const char *string = argv[i]; + + if (string[0] == '\0') + new_argv[i] = xstrdup ("\"\""); + else if (strpbrk (string, SHELL_SPECIAL_CHARS) != NULL) + { + int quote_around = (strpbrk (string, SHELL_SPACE_CHARS) != NULL); + size_t length; + unsigned int backslashes; + const char *s; + char *quoted_string; + char *p; + + length = 0; + backslashes = 0; + if (quote_around) + length++; + for (s = string; *s != '\0'; s++) + { + char c = *s; + if (c == '"') + length += backslashes + 1; + length++; + if (c == '\\') + backslashes++; + else + backslashes = 0; + } + if (quote_around) + length += backslashes + 1; + + quoted_string = XMALLOC (char, length + 1); + + p = quoted_string; + backslashes = 0; + if (quote_around) + *p++ = '"'; + for (s = string; *s != '\0'; s++) + { + char c = *s; + if (c == '"') + { + unsigned int j; + for (j = backslashes + 1; j > 0; j--) + *p++ = '\\'; + } + *p++ = c; + if (c == '\\') + backslashes++; + else + backslashes = 0; + } + if (quote_around) + { + unsigned int j; + for (j = backslashes; j > 0; j--) + *p++ = '\\'; + *p++ = '"'; + } + *p = '\0'; + + new_argv[i] = quoted_string; + } + else + new_argv[i] = (char *) string; + } + new_argv[argc] = NULL; + + return new_argv; +} +EOF + ;; + esac + + cat <<"EOF" +void lt_dump_script (FILE* f) +{ +EOF + func_emit_wrapper yes | + $SED -n -e ' +s/^\(.\{79\}\)\(..*\)/\1\ +\2/ +h +s/\([\\"]\)/\\\1/g +s/$/\\n/ +s/\([^\n]*\).*/ fputs ("\1", f);/p +g +D' + cat <<"EOF" +} +EOF +} +# end: func_emit_cwrapperexe_src + +# func_win32_import_lib_p ARG +# True if ARG is an import lib, as indicated by $file_magic_cmd +func_win32_import_lib_p () +{ + $debug_cmd + + case `eval $file_magic_cmd \"\$1\" 2>/dev/null | $SED -e 10q` in + *import*) : ;; + *) false ;; + esac +} + +# func_suncc_cstd_abi +# !!ONLY CALL THIS FOR SUN CC AFTER $compile_command IS FULLY EXPANDED!! +# Several compiler flags select an ABI that is incompatible with the +# Cstd library. Avoid specifying it if any are in CXXFLAGS. +func_suncc_cstd_abi () +{ + $debug_cmd + + case " $compile_command " in + *" -compat=g "*|*\ -std=c++[0-9][0-9]\ *|*" -library=stdcxx4 "*|*" -library=stlport4 "*) + suncc_use_cstd_abi=no + ;; + *) + suncc_use_cstd_abi=yes + ;; + esac +} + +# func_mode_link arg... +func_mode_link () +{ + $debug_cmd + + case $host in + *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-os2* | *-cegcc*) + # It is impossible to link a dll without this setting, and + # we shouldn't force the makefile maintainer to figure out + # what system we are compiling for in order to pass an extra + # flag for every libtool invocation. + # allow_undefined=no + + # FIXME: Unfortunately, there are problems with the above when trying + # to make a dll that has undefined symbols, in which case not + # even a static library is built. For now, we need to specify + # -no-undefined on the libtool link line when we can be certain + # that all symbols are satisfied, otherwise we get a static library. + allow_undefined=yes + ;; + *) + allow_undefined=yes + ;; + esac + libtool_args=$nonopt + base_compile="$nonopt $@" + compile_command=$nonopt + finalize_command=$nonopt + + compile_rpath= + finalize_rpath= + compile_shlibpath= + finalize_shlibpath= + convenience= + old_convenience= + deplibs= + old_deplibs= + compiler_flags= + linker_flags= + dllsearchpath= + lib_search_path=`pwd` + inst_prefix_dir= + new_inherited_linker_flags= + + avoid_version=no + bindir= + dlfiles= + dlprefiles= + dlself=no + export_dynamic=no + export_symbols= + export_symbols_regex= + generated= + libobjs= + ltlibs= + module=no + no_install=no + objs= + os2dllname= + non_pic_objects= + precious_files_regex= + prefer_static_libs=no + preload=false + prev= + prevarg= + release= + rpath= + xrpath= + perm_rpath= + temp_rpath= + thread_safe=no + vinfo= + vinfo_number=no + weak_libs= + single_module=$wl-single_module + func_infer_tag $base_compile + + # We need to know -static, to get the right output filenames. + for arg + do + case $arg in + -shared) + test yes != "$build_libtool_libs" \ + && func_fatal_configuration "cannot build a shared library" + build_old_libs=no + break + ;; + -all-static | -static | -static-libtool-libs) + case $arg in + -all-static) + if test yes = "$build_libtool_libs" && test -z "$link_static_flag"; then + func_warning "complete static linking is impossible in this configuration" + fi + if test -n "$link_static_flag"; then + dlopen_self=$dlopen_self_static + fi + prefer_static_libs=yes + ;; + -static) + if test -z "$pic_flag" && test -n "$link_static_flag"; then + dlopen_self=$dlopen_self_static + fi + prefer_static_libs=built + ;; + -static-libtool-libs) + if test -z "$pic_flag" && test -n "$link_static_flag"; then + dlopen_self=$dlopen_self_static + fi + prefer_static_libs=yes + ;; + esac + build_libtool_libs=no + build_old_libs=yes + break + ;; + esac + done + + # See if our shared archives depend on static archives. + test -n "$old_archive_from_new_cmds" && build_old_libs=yes + + # Go through the arguments, transforming them on the way. + while test "$#" -gt 0; do + arg=$1 + shift + func_quote_arg pretty,unquoted "$arg" + qarg=$func_quote_arg_unquoted_result + func_append libtool_args " $func_quote_arg_result" + + # If the previous option needs an argument, assign it. + if test -n "$prev"; then + case $prev in + output) + func_append compile_command " @OUTPUT@" + func_append finalize_command " @OUTPUT@" + ;; + esac + + case $prev in + bindir) + bindir=$arg + prev= + continue + ;; + dlfiles|dlprefiles) + $preload || { + # Add the symbol object into the linking commands. + func_append compile_command " @SYMFILE@" + func_append finalize_command " @SYMFILE@" + preload=: + } + case $arg in + *.la | *.lo) ;; # We handle these cases below. + force) + if test no = "$dlself"; then + dlself=needless + export_dynamic=yes + fi + prev= + continue + ;; + self) + if test dlprefiles = "$prev"; then + dlself=yes + elif test dlfiles = "$prev" && test yes != "$dlopen_self"; then + dlself=yes + else + dlself=needless + export_dynamic=yes + fi + prev= + continue + ;; + *) + if test dlfiles = "$prev"; then + func_append dlfiles " $arg" + else + func_append dlprefiles " $arg" + fi + prev= + continue + ;; + esac + ;; + expsyms) + export_symbols=$arg + test -f "$arg" \ + || func_fatal_error "symbol file '$arg' does not exist" + prev= + continue + ;; + expsyms_regex) + export_symbols_regex=$arg + prev= + continue + ;; + framework) + case $host in + *-*-darwin*) + case "$deplibs " in + *" $qarg.ltframework "*) ;; + *) func_append deplibs " $qarg.ltframework" # this is fixed later + ;; + esac + ;; + esac + prev= + continue + ;; + inst_prefix) + inst_prefix_dir=$arg + prev= + continue + ;; + mllvm) + # Clang does not use LLVM to link, so we can simply discard any + # '-mllvm $arg' options when doing the link step. + prev= + continue + ;; + objectlist) + if test -f "$arg"; then + save_arg=$arg + moreargs= + for fil in `cat "$save_arg"` + do +# func_append moreargs " $fil" + arg=$fil + # A libtool-controlled object. + + # Check to see that this really is a libtool object. + if func_lalib_unsafe_p "$arg"; then + pic_object= + non_pic_object= + + # Read the .lo file + func_source "$arg" + + if test -z "$pic_object" || + test -z "$non_pic_object" || + test none = "$pic_object" && + test none = "$non_pic_object"; then + func_fatal_error "cannot find name of object for '$arg'" + fi + + # Extract subdirectory from the argument. + func_dirname "$arg" "/" "" + xdir=$func_dirname_result + + if test none != "$pic_object"; then + # Prepend the subdirectory the object is found in. + pic_object=$xdir$pic_object + + if test dlfiles = "$prev"; then + if test yes = "$build_libtool_libs" && test yes = "$dlopen_support"; then + func_append dlfiles " $pic_object" + prev= + continue + else + # If libtool objects are unsupported, then we need to preload. + prev=dlprefiles + fi + fi + + # CHECK ME: I think I busted this. -Ossama + if test dlprefiles = "$prev"; then + # Preload the old-style object. + func_append dlprefiles " $pic_object" + prev= + fi + + # A PIC object. + func_append libobjs " $pic_object" + arg=$pic_object + fi + + # Non-PIC object. + if test none != "$non_pic_object"; then + # Prepend the subdirectory the object is found in. + non_pic_object=$xdir$non_pic_object + + # A standard non-PIC object + func_append non_pic_objects " $non_pic_object" + if test -z "$pic_object" || test none = "$pic_object"; then + arg=$non_pic_object + fi + else + # If the PIC object exists, use it instead. + # $xdir was prepended to $pic_object above. + non_pic_object=$pic_object + func_append non_pic_objects " $non_pic_object" + fi + else + # Only an error if not doing a dry-run. + if $opt_dry_run; then + # Extract subdirectory from the argument. + func_dirname "$arg" "/" "" + xdir=$func_dirname_result + + func_lo2o "$arg" + pic_object=$xdir$objdir/$func_lo2o_result + non_pic_object=$xdir$func_lo2o_result + func_append libobjs " $pic_object" + func_append non_pic_objects " $non_pic_object" + else + func_fatal_error "'$arg' is not a valid libtool object" + fi + fi + done + else + func_fatal_error "link input file '$arg' does not exist" + fi + arg=$save_arg + prev= + continue + ;; + os2dllname) + os2dllname=$arg + prev= + continue + ;; + precious_regex) + precious_files_regex=$arg + prev= + continue + ;; + release) + release=-$arg + prev= + continue + ;; + rpath | xrpath) + # We need an absolute path. + case $arg in + [\\/]* | [A-Za-z]:[\\/]*) ;; + *) + func_fatal_error "only absolute run-paths are allowed" + ;; + esac + if test rpath = "$prev"; then + case "$rpath " in + *" $arg "*) ;; + *) func_append rpath " $arg" ;; + esac + else + case "$xrpath " in + *" $arg "*) ;; + *) func_append xrpath " $arg" ;; + esac + fi + prev= + continue + ;; + shrext) + shrext_cmds=$arg + prev= + continue + ;; + weak) + func_append weak_libs " $arg" + prev= + continue + ;; + xassembler) + func_append compiler_flags " -Xassembler $qarg" + prev= + func_append compile_command " -Xassembler $qarg" + func_append finalize_command " -Xassembler $qarg" + continue + ;; + xcclinker) + func_append linker_flags " $qarg" + func_append compiler_flags " $qarg" + prev= + func_append compile_command " $qarg" + func_append finalize_command " $qarg" + continue + ;; + xcompiler) + func_append compiler_flags " $qarg" + prev= + func_append compile_command " $qarg" + func_append finalize_command " $qarg" + continue + ;; + xlinker) + func_append linker_flags " $qarg" + func_append compiler_flags " $wl$qarg" + prev= + func_append compile_command " $wl$qarg" + func_append finalize_command " $wl$qarg" + continue + ;; + *) + eval "$prev=\"\$arg\"" + prev= + continue + ;; + esac + fi # test -n "$prev" + + prevarg=$arg + + case $arg in + -all-static) + if test -n "$link_static_flag"; then + # See comment for -static flag below, for more details. + func_append compile_command " $link_static_flag" + func_append finalize_command " $link_static_flag" + fi + continue + ;; + + -allow-undefined) + # FIXME: remove this flag sometime in the future. + func_fatal_error "'-allow-undefined' must not be used because it is the default" + ;; + + -avoid-version) + avoid_version=yes + continue + ;; + + -bindir) + prev=bindir + continue + ;; + + -dlopen) + prev=dlfiles + continue + ;; + + -dlpreopen) + prev=dlprefiles + continue + ;; + + -export-dynamic) + export_dynamic=yes + continue + ;; + + -export-symbols | -export-symbols-regex) + if test -n "$export_symbols" || test -n "$export_symbols_regex"; then + func_fatal_error "more than one -exported-symbols argument is not allowed" + fi + if test X-export-symbols = "X$arg"; then + prev=expsyms + else + prev=expsyms_regex + fi + continue + ;; + + -framework) + prev=framework + continue + ;; + + -inst-prefix-dir) + prev=inst_prefix + continue + ;; + + # The native IRIX linker understands -LANG:*, -LIST:* and -LNO:* + # so, if we see these flags be careful not to treat them like -L + -L[A-Z][A-Z]*:*) + case $with_gcc/$host in + no/*-*-irix* | /*-*-irix*) + func_append compile_command " $arg" + func_append finalize_command " $arg" + ;; + esac + continue + ;; + + -L*) + func_stripname "-L" '' "$arg" + if test -z "$func_stripname_result"; then + if test "$#" -gt 0; then + func_fatal_error "require no space between '-L' and '$1'" + else + func_fatal_error "need path for '-L' option" + fi + fi + func_resolve_sysroot "$func_stripname_result" + dir=$func_resolve_sysroot_result + # We need an absolute path. + case $dir in + [\\/]* | [A-Za-z]:[\\/]*) ;; + *) + absdir=`cd "$dir" && pwd` + test -z "$absdir" && \ + func_fatal_error "cannot determine absolute directory name of '$dir'" + dir=$absdir + ;; + esac + case "$deplibs " in + *" -L$dir "* | *" $arg "*) + # Will only happen for absolute or sysroot arguments + ;; + *) + # Preserve sysroot, but never include relative directories + case $dir in + [\\/]* | [A-Za-z]:[\\/]* | =*) func_append deplibs " $arg" ;; + *) func_append deplibs " -L$dir" ;; + esac + func_append lib_search_path " $dir" + ;; + esac + case $host in + *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-os2* | *-cegcc*) + testbindir=`$ECHO "$dir" | $SED 's*/lib$*/bin*'` + case :$dllsearchpath: in + *":$dir:"*) ;; + ::) dllsearchpath=$dir;; + *) func_append dllsearchpath ":$dir";; + esac + case :$dllsearchpath: in + *":$testbindir:"*) ;; + ::) dllsearchpath=$testbindir;; + *) func_append dllsearchpath ":$testbindir";; + esac + ;; + esac + continue + ;; + + -l*) + if test X-lc = "X$arg" || test X-lm = "X$arg"; then + case $host in + *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-beos* | *-cegcc* | *-*-haiku*) + # These systems don't actually have a C or math library (as such) + continue + ;; + *-*-os2*) + # These systems don't actually have a C library (as such) + test X-lc = "X$arg" && continue + ;; + *-*-openbsd* | *-*-freebsd* | *-*-dragonfly* | *-*-bitrig* | *-*-midnightbsd*) + # Do not include libc due to us having libc/libc_r. + test X-lc = "X$arg" && continue + ;; + *-*-rhapsody* | *-*-darwin1.[012]) + # Rhapsody C and math libraries are in the System framework + func_append deplibs " System.ltframework" + continue + ;; + *-*-sco3.2v5* | *-*-sco5v6*) + # Causes problems with __ctype + test X-lc = "X$arg" && continue + ;; + *-*-sysv4.2uw2* | *-*-sysv5* | *-*-unixware* | *-*-OpenUNIX*) + # Compiler inserts libc in the correct place for threads to work + test X-lc = "X$arg" && continue + ;; + esac + elif test X-lc_r = "X$arg"; then + case $host in + *-*-openbsd* | *-*-freebsd* | *-*-dragonfly* | *-*-bitrig* | *-*-midnightbsd*) + # Do not include libc_r directly, use -pthread flag. + continue + ;; + esac + fi + func_append deplibs " $arg" + continue + ;; + + -mllvm) + prev=mllvm + continue + ;; + + -module) + module=yes + continue + ;; + + # Tru64 UNIX uses -model [arg] to determine the layout of C++ + # classes, name mangling, and exception handling. + # Darwin uses the -arch flag to determine output architecture. + -model|-arch|-isysroot|--sysroot) + func_append compiler_flags " $arg" + func_append compile_command " $arg" + func_append finalize_command " $arg" + prev=xcompiler + continue + ;; + # Solaris ld rejects as of 11.4. Refer to Oracle bug 22985199. + -pthread) + case $host in + *solaris2*) ;; + *) + case "$new_inherited_linker_flags " in + *" $arg "*) ;; + * ) func_append new_inherited_linker_flags " $arg" ;; + esac + ;; + esac + continue + ;; + -mt|-mthreads|-kthread|-Kthread|-pthreads|--thread-safe \ + |-threads|-fopenmp|-openmp|-mp|-xopenmp|-omp|-qsmp=*) + func_append compiler_flags " $arg" + func_append compile_command " $arg" + func_append finalize_command " $arg" + case "$new_inherited_linker_flags " in + *" $arg "*) ;; + * ) func_append new_inherited_linker_flags " $arg" ;; + esac + continue + ;; + + -multi_module) + single_module=$wl-multi_module + continue + ;; + + -no-fast-install) + fast_install=no + continue + ;; + + -no-install) + case $host in + *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-os2* | *-*-darwin* | *-cegcc*) + # The PATH hackery in wrapper scripts is required on Windows + # and Darwin in order for the loader to find any dlls it needs. + func_warning "'-no-install' is ignored for $host" + func_warning "assuming '-no-fast-install' instead" + fast_install=no + ;; + *) no_install=yes ;; + esac + continue + ;; + + -no-undefined) + allow_undefined=no + continue + ;; + + -objectlist) + prev=objectlist + continue + ;; + + -os2dllname) + prev=os2dllname + continue + ;; + + -o) prev=output ;; + + -precious-files-regex) + prev=precious_regex + continue + ;; + + -release) + prev=release + continue + ;; + + -rpath) + prev=rpath + continue + ;; + + -R) + prev=xrpath + continue + ;; + + -R*) + func_stripname '-R' '' "$arg" + dir=$func_stripname_result + # We need an absolute path. + case $dir in + [\\/]* | [A-Za-z]:[\\/]*) ;; + =*) + func_stripname '=' '' "$dir" + dir=$lt_sysroot$func_stripname_result + ;; + *) + func_fatal_error "only absolute run-paths are allowed" + ;; + esac + case "$xrpath " in + *" $dir "*) ;; + *) func_append xrpath " $dir" ;; + esac + continue + ;; + + -shared) + # The effects of -shared are defined in a previous loop. + continue + ;; + + -shrext) + prev=shrext + continue + ;; + + -static | -static-libtool-libs) + # The effects of -static are defined in a previous loop. + # We used to do the same as -all-static on platforms that + # didn't have a PIC flag, but the assumption that the effects + # would be equivalent was wrong. It would break on at least + # Digital Unix and AIX. + continue + ;; + + -thread-safe) + thread_safe=yes + continue + ;; + + -version-info) + prev=vinfo + continue + ;; + + -version-number) + prev=vinfo + vinfo_number=yes + continue + ;; + + -weak) + prev=weak + continue + ;; + + -Wc,*) + func_stripname '-Wc,' '' "$arg" + args=$func_stripname_result + arg= + save_ifs=$IFS; IFS=, + for flag in $args; do + IFS=$save_ifs + func_quote_arg pretty "$flag" + func_append arg " $func_quote_arg_result" + func_append compiler_flags " $func_quote_arg_result" + done + IFS=$save_ifs + func_stripname ' ' '' "$arg" + arg=$func_stripname_result + ;; + + -Wl,*) + func_stripname '-Wl,' '' "$arg" + args=$func_stripname_result + arg= + save_ifs=$IFS; IFS=, + for flag in $args; do + IFS=$save_ifs + func_quote_arg pretty "$flag" + func_append arg " $wl$func_quote_arg_result" + func_append compiler_flags " $wl$func_quote_arg_result" + func_append linker_flags " $func_quote_arg_result" + done + IFS=$save_ifs + func_stripname ' ' '' "$arg" + arg=$func_stripname_result + ;; + + -Xassembler) + prev=xassembler + continue + ;; + + -Xcompiler) + prev=xcompiler + continue + ;; + + -Xlinker) + prev=xlinker + continue + ;; + + -XCClinker) + prev=xcclinker + continue + ;; + + # -msg_* for osf cc + -msg_*) + func_quote_arg pretty "$arg" + arg=$func_quote_arg_result + ;; + + # Flags to be passed through unchanged, with rationale: + # -64, -mips[0-9] enable 64-bit mode for the SGI compiler + # -r[0-9][0-9]* specify processor for the SGI compiler + # -xarch=*, -xtarget=* enable 64-bit mode for the Sun compiler + # +DA*, +DD* enable 64-bit mode for the HP compiler + # -q* compiler args for the IBM compiler + # -m*, -t[45]*, -txscale* architecture-specific flags for GCC + # -F/path path to uninstalled frameworks, gcc on darwin + # -p, -pg, --coverage, -fprofile-* profiling flags for GCC + # -fstack-protector* stack protector flags for GCC + # @file GCC response files + # -tp=* Portland pgcc target processor selection + # --sysroot=* for sysroot support + # -O*, -g*, -flto*, -fwhopr*, -fuse-linker-plugin GCC link-time optimization + # -specs=* GCC specs files + # -stdlib=* select c++ std lib with clang + # -fsanitize=* Clang/GCC memory and address sanitizer + # -fuse-ld=* Linker select flags for GCC + # -static-* direct GCC to link specific libraries statically + # -fcilkplus Cilk Plus language extension features for C/C++ + # -Wa,* Pass flags directly to the assembler + -64|-mips[0-9]|-r[0-9][0-9]*|-xarch=*|-xtarget=*|+DA*|+DD*|-q*|-m*| \ + -t[45]*|-txscale*|-p|-pg|--coverage|-fprofile-*|-F*|@*|-tp=*|--sysroot=*| \ + -O*|-g*|-flto*|-fwhopr*|-fuse-linker-plugin|-fstack-protector*|-stdlib=*| \ + -specs=*|-fsanitize=*|-fuse-ld=*|-static-*|-fcilkplus|-Wa,*) + func_quote_arg pretty "$arg" + arg=$func_quote_arg_result + func_append compile_command " $arg" + func_append finalize_command " $arg" + func_append compiler_flags " $arg" + continue + ;; + + -Z*) + if test os2 = "`expr $host : '.*\(os2\)'`"; then + # OS/2 uses -Zxxx to specify OS/2-specific options + compiler_flags="$compiler_flags $arg" + func_append compile_command " $arg" + func_append finalize_command " $arg" + case $arg in + -Zlinker | -Zstack) + prev=xcompiler + ;; + esac + continue + else + # Otherwise treat like 'Some other compiler flag' below + func_quote_arg pretty "$arg" + arg=$func_quote_arg_result + fi + ;; + + # Some other compiler flag. + -* | +*) + func_quote_arg pretty "$arg" + arg=$func_quote_arg_result + ;; + + *.$objext) + # A standard object. + func_append objs " $arg" + ;; + + *.lo) + # A libtool-controlled object. + + # Check to see that this really is a libtool object. + if func_lalib_unsafe_p "$arg"; then + pic_object= + non_pic_object= + + # Read the .lo file + func_source "$arg" + + if test -z "$pic_object" || + test -z "$non_pic_object" || + test none = "$pic_object" && + test none = "$non_pic_object"; then + func_fatal_error "cannot find name of object for '$arg'" + fi + + # Extract subdirectory from the argument. + func_dirname "$arg" "/" "" + xdir=$func_dirname_result + + test none = "$pic_object" || { + # Prepend the subdirectory the object is found in. + pic_object=$xdir$pic_object + + if test dlfiles = "$prev"; then + if test yes = "$build_libtool_libs" && test yes = "$dlopen_support"; then + func_append dlfiles " $pic_object" + prev= + continue + else + # If libtool objects are unsupported, then we need to preload. + prev=dlprefiles + fi + fi + + # CHECK ME: I think I busted this. -Ossama + if test dlprefiles = "$prev"; then + # Preload the old-style object. + func_append dlprefiles " $pic_object" + prev= + fi + + # A PIC object. + func_append libobjs " $pic_object" + arg=$pic_object + } + + # Non-PIC object. + if test none != "$non_pic_object"; then + # Prepend the subdirectory the object is found in. + non_pic_object=$xdir$non_pic_object + + # A standard non-PIC object + func_append non_pic_objects " $non_pic_object" + if test -z "$pic_object" || test none = "$pic_object"; then + arg=$non_pic_object + fi + else + # If the PIC object exists, use it instead. + # $xdir was prepended to $pic_object above. + non_pic_object=$pic_object + func_append non_pic_objects " $non_pic_object" + fi + else + # Only an error if not doing a dry-run. + if $opt_dry_run; then + # Extract subdirectory from the argument. + func_dirname "$arg" "/" "" + xdir=$func_dirname_result + + func_lo2o "$arg" + pic_object=$xdir$objdir/$func_lo2o_result + non_pic_object=$xdir$func_lo2o_result + func_append libobjs " $pic_object" + func_append non_pic_objects " $non_pic_object" + else + func_fatal_error "'$arg' is not a valid libtool object" + fi + fi + ;; + + *.$libext) + # An archive. + func_append deplibs " $arg" + func_append old_deplibs " $arg" + continue + ;; + + *.la) + # A libtool-controlled library. + + func_resolve_sysroot "$arg" + if test dlfiles = "$prev"; then + # This library was specified with -dlopen. + func_append dlfiles " $func_resolve_sysroot_result" + prev= + elif test dlprefiles = "$prev"; then + # The library was specified with -dlpreopen. + func_append dlprefiles " $func_resolve_sysroot_result" + prev= + else + func_append deplibs " $func_resolve_sysroot_result" + fi + continue + ;; + + # Some other compiler argument. + *) + # Unknown arguments in both finalize_command and compile_command need + # to be aesthetically quoted because they are evaled later. + func_quote_arg pretty "$arg" + arg=$func_quote_arg_result + ;; + esac # arg + + # Now actually substitute the argument into the commands. + if test -n "$arg"; then + func_append compile_command " $arg" + func_append finalize_command " $arg" + fi + done # argument parsing loop + + test -n "$prev" && \ + func_fatal_help "the '$prevarg' option requires an argument" + + if test yes = "$export_dynamic" && test -n "$export_dynamic_flag_spec"; then + eval arg=\"$export_dynamic_flag_spec\" + func_append compile_command " $arg" + func_append finalize_command " $arg" + fi + + oldlibs= + # calculate the name of the file, without its directory + func_basename "$output" + outputname=$func_basename_result + libobjs_save=$libobjs + + if test -n "$shlibpath_var"; then + # get the directories listed in $shlibpath_var + eval shlib_search_path=\`\$ECHO \"\$$shlibpath_var\" \| \$SED \'s/:/ /g\'\` + else + shlib_search_path= + fi + eval sys_lib_search_path=\"$sys_lib_search_path_spec\" + eval sys_lib_dlsearch_path=\"$sys_lib_dlsearch_path_spec\" + + # Definition is injected by LT_CONFIG during libtool generation. + func_munge_path_list sys_lib_dlsearch_path "$LT_SYS_LIBRARY_PATH" + + func_dirname "$output" "/" "" + output_objdir=$func_dirname_result$objdir + func_to_tool_file "$output_objdir/" + tool_output_objdir=$func_to_tool_file_result + # Create the object directory. + func_mkdir_p "$output_objdir" + + # Determine the type of output + case $output in + "") + func_fatal_help "you must specify an output file" + ;; + *.$libext) linkmode=oldlib ;; + *.lo | *.$objext) linkmode=obj ;; + *.la) linkmode=lib ;; + *) linkmode=prog ;; # Anything else should be a program. + esac + + specialdeplibs= + + libs= + # Find all interdependent deplibs by searching for libraries + # that are linked more than once (e.g. -la -lb -la) + for deplib in $deplibs; do + if $opt_preserve_dup_deps; then + case "$libs " in + *" $deplib "*) func_append specialdeplibs " $deplib" ;; + esac + fi + func_append libs " $deplib" + done + + if test lib = "$linkmode"; then + libs="$predeps $libs $compiler_lib_search_path $postdeps" + + # Compute libraries that are listed more than once in $predeps + # $postdeps and mark them as special (i.e., whose duplicates are + # not to be eliminated). + pre_post_deps= + if $opt_duplicate_compiler_generated_deps; then + for pre_post_dep in $predeps $postdeps; do + case "$pre_post_deps " in + *" $pre_post_dep "*) func_append specialdeplibs " $pre_post_deps" ;; + esac + func_append pre_post_deps " $pre_post_dep" + done + fi + pre_post_deps= + fi + + deplibs= + newdependency_libs= + newlib_search_path= + need_relink=no # whether we're linking any uninstalled libtool libraries + notinst_deplibs= # not-installed libtool libraries + notinst_path= # paths that contain not-installed libtool libraries + + case $linkmode in + lib) + passes="conv dlpreopen link" + for file in $dlfiles $dlprefiles; do + case $file in + *.la) ;; + *) + func_fatal_help "libraries can '-dlopen' only libtool libraries: $file" + ;; + esac + done + ;; + prog) + compile_deplibs= + finalize_deplibs= + alldeplibs=false + newdlfiles= + newdlprefiles= + passes="conv scan dlopen dlpreopen link" + ;; + *) passes="conv" + ;; + esac + + for pass in $passes; do + # The preopen pass in lib mode reverses $deplibs; put it back here + # so that -L comes before libs that need it for instance... + if test lib,link = "$linkmode,$pass"; then + ## FIXME: Find the place where the list is rebuilt in the wrong + ## order, and fix it there properly + tmp_deplibs= + for deplib in $deplibs; do + tmp_deplibs="$deplib $tmp_deplibs" + done + deplibs=$tmp_deplibs + fi + + if test lib,link = "$linkmode,$pass" || + test prog,scan = "$linkmode,$pass"; then + libs=$deplibs + deplibs= + fi + if test prog = "$linkmode"; then + case $pass in + dlopen) libs=$dlfiles ;; + dlpreopen) libs=$dlprefiles ;; + link) + libs="$deplibs %DEPLIBS%" + test "X$link_all_deplibs" != Xno && libs="$libs $dependency_libs" + ;; + esac + fi + if test lib,dlpreopen = "$linkmode,$pass"; then + # Collect and forward deplibs of preopened libtool libs + for lib in $dlprefiles; do + # Ignore non-libtool-libs + dependency_libs= + func_resolve_sysroot "$lib" + case $lib in + *.la) func_source "$func_resolve_sysroot_result" ;; + esac + + # Collect preopened libtool deplibs, except any this library + # has declared as weak libs + for deplib in $dependency_libs; do + func_basename "$deplib" + deplib_base=$func_basename_result + case " $weak_libs " in + *" $deplib_base "*) ;; + *) func_append deplibs " $deplib" ;; + esac + done + done + libs=$dlprefiles + fi + if test dlopen = "$pass"; then + # Collect dlpreopened libraries + save_deplibs=$deplibs + deplibs= + fi + + for deplib in $libs; do + lib= + found=false + case $deplib in + -mt|-mthreads|-kthread|-Kthread|-pthread|-pthreads|--thread-safe \ + |-threads|-fopenmp|-openmp|-mp|-xopenmp|-omp|-qsmp=*) + if test prog,link = "$linkmode,$pass"; then + compile_deplibs="$deplib $compile_deplibs" + finalize_deplibs="$deplib $finalize_deplibs" + else + func_append compiler_flags " $deplib" + if test lib = "$linkmode"; then + case "$new_inherited_linker_flags " in + *" $deplib "*) ;; + * ) func_append new_inherited_linker_flags " $deplib" ;; + esac + fi + fi + continue + ;; + -l*) + if test lib != "$linkmode" && test prog != "$linkmode"; then + func_warning "'-l' is ignored for archives/objects" + continue + fi + func_stripname '-l' '' "$deplib" + name=$func_stripname_result + if test lib = "$linkmode"; then + searchdirs="$newlib_search_path $lib_search_path $compiler_lib_search_dirs $sys_lib_search_path $shlib_search_path" + else + searchdirs="$newlib_search_path $lib_search_path $sys_lib_search_path $shlib_search_path" + fi + for searchdir in $searchdirs; do + for search_ext in .la $std_shrext .so .a; do + # Search the libtool library + lib=$searchdir/lib$name$search_ext + if test -f "$lib"; then + if test .la = "$search_ext"; then + found=: + else + found=false + fi + break 2 + fi + done + done + if $found; then + # deplib is a libtool library + # If $allow_libtool_libs_with_static_runtimes && $deplib is a stdlib, + # We need to do some special things here, and not later. + if test yes = "$allow_libtool_libs_with_static_runtimes"; then + case " $predeps $postdeps " in + *" $deplib "*) + if func_lalib_p "$lib"; then + library_names= + old_library= + func_source "$lib" + for l in $old_library $library_names; do + ll=$l + done + if test "X$ll" = "X$old_library"; then # only static version available + found=false + func_dirname "$lib" "" "." + ladir=$func_dirname_result + lib=$ladir/$old_library + if test prog,link = "$linkmode,$pass"; then + compile_deplibs="$deplib $compile_deplibs" + finalize_deplibs="$deplib $finalize_deplibs" + else + deplibs="$deplib $deplibs" + test lib = "$linkmode" && newdependency_libs="$deplib $newdependency_libs" + fi + continue + fi + fi + ;; + *) ;; + esac + fi + else + # deplib doesn't seem to be a libtool library + if test prog,link = "$linkmode,$pass"; then + compile_deplibs="$deplib $compile_deplibs" + finalize_deplibs="$deplib $finalize_deplibs" + else + deplibs="$deplib $deplibs" + test lib = "$linkmode" && newdependency_libs="$deplib $newdependency_libs" + fi + continue + fi + ;; # -l + *.ltframework) + if test prog,link = "$linkmode,$pass"; then + compile_deplibs="$deplib $compile_deplibs" + finalize_deplibs="$deplib $finalize_deplibs" + else + deplibs="$deplib $deplibs" + if test lib = "$linkmode"; then + case "$new_inherited_linker_flags " in + *" $deplib "*) ;; + * ) func_append new_inherited_linker_flags " $deplib" ;; + esac + fi + fi + continue + ;; + -L*) + case $linkmode in + lib) + deplibs="$deplib $deplibs" + test conv = "$pass" && continue + newdependency_libs="$deplib $newdependency_libs" + func_stripname '-L' '' "$deplib" + func_resolve_sysroot "$func_stripname_result" + func_append newlib_search_path " $func_resolve_sysroot_result" + ;; + prog) + if test conv = "$pass"; then + deplibs="$deplib $deplibs" + continue + fi + if test scan = "$pass"; then + deplibs="$deplib $deplibs" + else + compile_deplibs="$deplib $compile_deplibs" + finalize_deplibs="$deplib $finalize_deplibs" + fi + func_stripname '-L' '' "$deplib" + func_resolve_sysroot "$func_stripname_result" + func_append newlib_search_path " $func_resolve_sysroot_result" + ;; + *) + func_warning "'-L' is ignored for archives/objects" + ;; + esac # linkmode + continue + ;; # -L + -R*) + if test link = "$pass"; then + func_stripname '-R' '' "$deplib" + func_resolve_sysroot "$func_stripname_result" + dir=$func_resolve_sysroot_result + # Make sure the xrpath contains only unique directories. + case "$xrpath " in + *" $dir "*) ;; + *) func_append xrpath " $dir" ;; + esac + fi + deplibs="$deplib $deplibs" + continue + ;; + *.la) + func_resolve_sysroot "$deplib" + lib=$func_resolve_sysroot_result + ;; + *.$libext) + if test conv = "$pass"; then + deplibs="$deplib $deplibs" + continue + fi + case $linkmode in + lib) + # Linking convenience modules into shared libraries is allowed, + # but linking other static libraries is non-portable. + case " $dlpreconveniencelibs " in + *" $deplib "*) ;; + *) + valid_a_lib=false + case $deplibs_check_method in + match_pattern*) + set dummy $deplibs_check_method; shift + match_pattern_regex=`expr "$deplibs_check_method" : "$1 \(.*\)"` + if eval "\$ECHO \"$deplib\"" 2>/dev/null | $SED 10q \ + | $EGREP "$match_pattern_regex" > /dev/null; then + valid_a_lib=: + fi + ;; + pass_all) + valid_a_lib=: + ;; + esac + if $valid_a_lib; then + echo + $ECHO "*** Warning: Linking the shared library $output against the" + $ECHO "*** static library $deplib is not portable!" + deplibs="$deplib $deplibs" + else + echo + $ECHO "*** Warning: Trying to link with static lib archive $deplib." + echo "*** I have the capability to make that library automatically link in when" + echo "*** you link to this library. But I can only do this if you have a" + echo "*** shared version of the library, which you do not appear to have" + echo "*** because the file extensions .$libext of this argument makes me believe" + echo "*** that it is just a static archive that I should not use here." + fi + ;; + esac + continue + ;; + prog) + if test link != "$pass"; then + deplibs="$deplib $deplibs" + else + compile_deplibs="$deplib $compile_deplibs" + finalize_deplibs="$deplib $finalize_deplibs" + fi + continue + ;; + esac # linkmode + ;; # *.$libext + *.lo | *.$objext) + if test conv = "$pass"; then + deplibs="$deplib $deplibs" + elif test prog = "$linkmode"; then + if test dlpreopen = "$pass" || test yes != "$dlopen_support" || test no = "$build_libtool_libs"; then + # If there is no dlopen support or we're linking statically, + # we need to preload. + func_append newdlprefiles " $deplib" + compile_deplibs="$deplib $compile_deplibs" + finalize_deplibs="$deplib $finalize_deplibs" + else + func_append newdlfiles " $deplib" + fi + fi + continue + ;; + %DEPLIBS%) + alldeplibs=: + continue + ;; + esac # case $deplib + + $found || test -f "$lib" \ + || func_fatal_error "cannot find the library '$lib' or unhandled argument '$deplib'" + + # Check to see that this really is a libtool archive. + func_lalib_unsafe_p "$lib" \ + || func_fatal_error "'$lib' is not a valid libtool archive" + + func_dirname "$lib" "" "." + ladir=$func_dirname_result + + dlname= + dlopen= + dlpreopen= + libdir= + library_names= + old_library= + inherited_linker_flags= + # If the library was installed with an old release of libtool, + # it will not redefine variables installed, or shouldnotlink + installed=yes + shouldnotlink=no + avoidtemprpath= + + + # Read the .la file + func_source "$lib" + + # Convert "-framework foo" to "foo.ltframework" + if test -n "$inherited_linker_flags"; then + tmp_inherited_linker_flags=`$ECHO "$inherited_linker_flags" | $SED 's/-framework \([^ $]*\)/\1.ltframework/g'` + for tmp_inherited_linker_flag in $tmp_inherited_linker_flags; do + case " $new_inherited_linker_flags " in + *" $tmp_inherited_linker_flag "*) ;; + *) func_append new_inherited_linker_flags " $tmp_inherited_linker_flag";; + esac + done + fi + dependency_libs=`$ECHO " $dependency_libs" | $SED 's% \([^ $]*\).ltframework% -framework \1%g'` + if test lib,link = "$linkmode,$pass" || + test prog,scan = "$linkmode,$pass" || + { test prog != "$linkmode" && test lib != "$linkmode"; }; then + test -n "$dlopen" && func_append dlfiles " $dlopen" + test -n "$dlpreopen" && func_append dlprefiles " $dlpreopen" + fi + + if test conv = "$pass"; then + # Only check for convenience libraries + deplibs="$lib $deplibs" + if test -z "$libdir"; then + if test -z "$old_library"; then + func_fatal_error "cannot find name of link library for '$lib'" + fi + # It is a libtool convenience library, so add in its objects. + func_append convenience " $ladir/$objdir/$old_library" + func_append old_convenience " $ladir/$objdir/$old_library" + tmp_libs= + for deplib in $dependency_libs; do + deplibs="$deplib $deplibs" + if $opt_preserve_dup_deps; then + case "$tmp_libs " in + *" $deplib "*) func_append specialdeplibs " $deplib" ;; + esac + fi + func_append tmp_libs " $deplib" + done + elif test prog != "$linkmode" && test lib != "$linkmode"; then + func_fatal_error "'$lib' is not a convenience library" + fi + continue + fi # $pass = conv + + + # Get the name of the library we link against. + linklib= + if test -n "$old_library" && + { test yes = "$prefer_static_libs" || + test built,no = "$prefer_static_libs,$installed"; }; then + linklib=$old_library + else + for l in $old_library $library_names; do + linklib=$l + done + fi + if test -z "$linklib"; then + func_fatal_error "cannot find name of link library for '$lib'" + fi + + # This library was specified with -dlopen. + if test dlopen = "$pass"; then + test -z "$libdir" \ + && func_fatal_error "cannot -dlopen a convenience library: '$lib'" + if test -z "$dlname" || + test yes != "$dlopen_support" || + test no = "$build_libtool_libs" + then + # If there is no dlname, no dlopen support or we're linking + # statically, we need to preload. We also need to preload any + # dependent libraries so libltdl's deplib preloader doesn't + # bomb out in the load deplibs phase. + func_append dlprefiles " $lib $dependency_libs" + else + func_append newdlfiles " $lib" + fi + continue + fi # $pass = dlopen + + # We need an absolute path. + case $ladir in + [\\/]* | [A-Za-z]:[\\/]*) abs_ladir=$ladir ;; + *) + abs_ladir=`cd "$ladir" && pwd` + if test -z "$abs_ladir"; then + func_warning "cannot determine absolute directory name of '$ladir'" + func_warning "passing it literally to the linker, although it might fail" + abs_ladir=$ladir + fi + ;; + esac + func_basename "$lib" + laname=$func_basename_result + + # Find the relevant object directory and library name. + if test yes = "$installed"; then + if test ! -f "$lt_sysroot$libdir/$linklib" && test -f "$abs_ladir/$linklib"; then + func_warning "library '$lib' was moved." + dir=$ladir + absdir=$abs_ladir + libdir=$abs_ladir + else + dir=$lt_sysroot$libdir + absdir=$lt_sysroot$libdir + fi + test yes = "$hardcode_automatic" && avoidtemprpath=yes + else + if test ! -f "$ladir/$objdir/$linklib" && test -f "$abs_ladir/$linklib"; then + dir=$ladir + absdir=$abs_ladir + # Remove this search path later + func_append notinst_path " $abs_ladir" + else + dir=$ladir/$objdir + absdir=$abs_ladir/$objdir + # Remove this search path later + func_append notinst_path " $abs_ladir" + fi + fi # $installed = yes + func_stripname 'lib' '.la' "$laname" + name=$func_stripname_result + + # This library was specified with -dlpreopen. + if test dlpreopen = "$pass"; then + if test -z "$libdir" && test prog = "$linkmode"; then + func_fatal_error "only libraries may -dlpreopen a convenience library: '$lib'" + fi + case $host in + # special handling for platforms with PE-DLLs. + *cygwin* | *mingw* | *cegcc* ) + # Linker will automatically link against shared library if both + # static and shared are present. Therefore, ensure we extract + # symbols from the import library if a shared library is present + # (otherwise, the dlopen module name will be incorrect). We do + # this by putting the import library name into $newdlprefiles. + # We recover the dlopen module name by 'saving' the la file + # name in a special purpose variable, and (later) extracting the + # dlname from the la file. + if test -n "$dlname"; then + func_tr_sh "$dir/$linklib" + eval "libfile_$func_tr_sh_result=\$abs_ladir/\$laname" + func_append newdlprefiles " $dir/$linklib" + else + func_append newdlprefiles " $dir/$old_library" + # Keep a list of preopened convenience libraries to check + # that they are being used correctly in the link pass. + test -z "$libdir" && \ + func_append dlpreconveniencelibs " $dir/$old_library" + fi + ;; + * ) + # Prefer using a static library (so that no silly _DYNAMIC symbols + # are required to link). + if test -n "$old_library"; then + func_append newdlprefiles " $dir/$old_library" + # Keep a list of preopened convenience libraries to check + # that they are being used correctly in the link pass. + test -z "$libdir" && \ + func_append dlpreconveniencelibs " $dir/$old_library" + # Otherwise, use the dlname, so that lt_dlopen finds it. + elif test -n "$dlname"; then + func_append newdlprefiles " $dir/$dlname" + else + func_append newdlprefiles " $dir/$linklib" + fi + ;; + esac + fi # $pass = dlpreopen + + if test -z "$libdir"; then + # Link the convenience library + if test lib = "$linkmode"; then + deplibs="$dir/$old_library $deplibs" + elif test prog,link = "$linkmode,$pass"; then + compile_deplibs="$dir/$old_library $compile_deplibs" + finalize_deplibs="$dir/$old_library $finalize_deplibs" + else + deplibs="$lib $deplibs" # used for prog,scan pass + fi + continue + fi + + + if test prog = "$linkmode" && test link != "$pass"; then + func_append newlib_search_path " $ladir" + deplibs="$lib $deplibs" + + linkalldeplibs=false + if test no != "$link_all_deplibs" || test -z "$library_names" || + test no = "$build_libtool_libs"; then + linkalldeplibs=: + fi + + tmp_libs= + for deplib in $dependency_libs; do + case $deplib in + -L*) func_stripname '-L' '' "$deplib" + func_resolve_sysroot "$func_stripname_result" + func_append newlib_search_path " $func_resolve_sysroot_result" + ;; + esac + # Need to link against all dependency_libs? + if $linkalldeplibs; then + deplibs="$deplib $deplibs" + else + # Need to hardcode shared library paths + # or/and link against static libraries + newdependency_libs="$deplib $newdependency_libs" + fi + if $opt_preserve_dup_deps; then + case "$tmp_libs " in + *" $deplib "*) func_append specialdeplibs " $deplib" ;; + esac + fi + func_append tmp_libs " $deplib" + done # for deplib + continue + fi # $linkmode = prog... + + if test prog,link = "$linkmode,$pass"; then + if test -n "$library_names" && + { { test no = "$prefer_static_libs" || + test built,yes = "$prefer_static_libs,$installed"; } || + test -z "$old_library"; }; then + # We need to hardcode the library path + if test -n "$shlibpath_var" && test -z "$avoidtemprpath"; then + # Make sure the rpath contains only unique directories. + case $temp_rpath: in + *"$absdir:"*) ;; + *) func_append temp_rpath "$absdir:" ;; + esac + fi + + # Hardcode the library path. + # Skip directories that are in the system default run-time + # search path. + case " $sys_lib_dlsearch_path " in + *" $absdir "*) ;; + *) + case "$compile_rpath " in + *" $absdir "*) ;; + *) func_append compile_rpath " $absdir" ;; + esac + ;; + esac + case " $sys_lib_dlsearch_path " in + *" $libdir "*) ;; + *) + case "$finalize_rpath " in + *" $libdir "*) ;; + *) func_append finalize_rpath " $libdir" ;; + esac + ;; + esac + fi # $linkmode,$pass = prog,link... + + if $alldeplibs && + { test pass_all = "$deplibs_check_method" || + { test yes = "$build_libtool_libs" && + test -n "$library_names"; }; }; then + # We only need to search for static libraries + continue + fi + fi + + link_static=no # Whether the deplib will be linked statically + use_static_libs=$prefer_static_libs + if test built = "$use_static_libs" && test yes = "$installed"; then + use_static_libs=no + fi + if test -n "$library_names" && + { test no = "$use_static_libs" || test -z "$old_library"; }; then + case $host in + *cygwin* | *mingw* | *cegcc* | *os2*) + # No point in relinking DLLs because paths are not encoded + func_append notinst_deplibs " $lib" + need_relink=no + ;; + *) + if test no = "$installed"; then + func_append notinst_deplibs " $lib" + need_relink=yes + fi + ;; + esac + # This is a shared library + + # Warn about portability, can't link against -module's on some + # systems (darwin). Don't bleat about dlopened modules though! + dlopenmodule= + for dlpremoduletest in $dlprefiles; do + if test "X$dlpremoduletest" = "X$lib"; then + dlopenmodule=$dlpremoduletest + break + fi + done + if test -z "$dlopenmodule" && test yes = "$shouldnotlink" && test link = "$pass"; then + echo + if test prog = "$linkmode"; then + $ECHO "*** Warning: Linking the executable $output against the loadable module" + else + $ECHO "*** Warning: Linking the shared library $output against the loadable module" + fi + $ECHO "*** $linklib is not portable!" + fi + if test lib = "$linkmode" && + test yes = "$hardcode_into_libs"; then + # Hardcode the library path. + # Skip directories that are in the system default run-time + # search path. + case " $sys_lib_dlsearch_path " in + *" $absdir "*) ;; + *) + case "$compile_rpath " in + *" $absdir "*) ;; + *) func_append compile_rpath " $absdir" ;; + esac + ;; + esac + case " $sys_lib_dlsearch_path " in + *" $libdir "*) ;; + *) + case "$finalize_rpath " in + *" $libdir "*) ;; + *) func_append finalize_rpath " $libdir" ;; + esac + ;; + esac + fi + + if test -n "$old_archive_from_expsyms_cmds"; then + # figure out the soname + set dummy $library_names + shift + realname=$1 + shift + libname=`eval "\\$ECHO \"$libname_spec\""` + # use dlname if we got it. it's perfectly good, no? + if test -n "$dlname"; then + soname=$dlname + elif test -n "$soname_spec"; then + # bleh windows + case $host in + *cygwin* | mingw* | *cegcc* | *os2*) + func_arith $current - $age + major=$func_arith_result + versuffix=-$major + ;; + esac + eval soname=\"$soname_spec\" + else + soname=$realname + fi + + # Make a new name for the extract_expsyms_cmds to use + soroot=$soname + func_basename "$soroot" + soname=$func_basename_result + func_stripname 'lib' '.dll' "$soname" + newlib=libimp-$func_stripname_result.a + + # If the library has no export list, then create one now + if test -f "$output_objdir/$soname-def"; then : + else + func_verbose "extracting exported symbol list from '$soname'" + func_execute_cmds "$extract_expsyms_cmds" 'exit $?' + fi + + # Create $newlib + if test -f "$output_objdir/$newlib"; then :; else + func_verbose "generating import library for '$soname'" + func_execute_cmds "$old_archive_from_expsyms_cmds" 'exit $?' + fi + # make sure the library variables are pointing to the new library + dir=$output_objdir + linklib=$newlib + fi # test -n "$old_archive_from_expsyms_cmds" + + if test prog = "$linkmode" || test relink != "$opt_mode"; then + add_shlibpath= + add_dir= + add= + lib_linked=yes + case $hardcode_action in + immediate | unsupported) + if test no = "$hardcode_direct"; then + add=$dir/$linklib + case $host in + *-*-sco3.2v5.0.[024]*) add_dir=-L$dir ;; + *-*-sysv4*uw2*) add_dir=-L$dir ;; + *-*-sysv5OpenUNIX* | *-*-sysv5UnixWare7.[01].[10]* | \ + *-*-unixware7*) add_dir=-L$dir ;; + *-*-darwin* ) + # if the lib is a (non-dlopened) module then we cannot + # link against it, someone is ignoring the earlier warnings + if /usr/bin/file -L $add 2> /dev/null | + $GREP ": [^:]* bundle" >/dev/null; then + if test "X$dlopenmodule" != "X$lib"; then + $ECHO "*** Warning: lib $linklib is a module, not a shared library" + if test -z "$old_library"; then + echo + echo "*** And there doesn't seem to be a static archive available" + echo "*** The link will probably fail, sorry" + else + add=$dir/$old_library + fi + elif test -n "$old_library"; then + add=$dir/$old_library + fi + fi + esac + elif test no = "$hardcode_minus_L"; then + case $host in + *-*-sunos*) add_shlibpath=$dir ;; + esac + add_dir=-L$dir + add=-l$name + elif test no = "$hardcode_shlibpath_var"; then + add_shlibpath=$dir + add=-l$name + else + lib_linked=no + fi + ;; + relink) + if test yes = "$hardcode_direct" && + test no = "$hardcode_direct_absolute"; then + add=$dir/$linklib + elif test yes = "$hardcode_minus_L"; then + add_dir=-L$absdir + # Try looking first in the location we're being installed to. + if test -n "$inst_prefix_dir"; then + case $libdir in + [\\/]*) + func_append add_dir " -L$inst_prefix_dir$libdir" + ;; + esac + fi + add=-l$name + elif test yes = "$hardcode_shlibpath_var"; then + add_shlibpath=$dir + add=-l$name + else + lib_linked=no + fi + ;; + *) lib_linked=no ;; + esac + + if test yes != "$lib_linked"; then + func_fatal_configuration "unsupported hardcode properties" + fi + + if test -n "$add_shlibpath"; then + case :$compile_shlibpath: in + *":$add_shlibpath:"*) ;; + *) func_append compile_shlibpath "$add_shlibpath:" ;; + esac + fi + if test prog = "$linkmode"; then + test -n "$add_dir" && compile_deplibs="$add_dir $compile_deplibs" + test -n "$add" && compile_deplibs="$add $compile_deplibs" + else + test -n "$add_dir" && deplibs="$add_dir $deplibs" + test -n "$add" && deplibs="$add $deplibs" + if test yes != "$hardcode_direct" && + test yes != "$hardcode_minus_L" && + test yes = "$hardcode_shlibpath_var"; then + case :$finalize_shlibpath: in + *":$libdir:"*) ;; + *) func_append finalize_shlibpath "$libdir:" ;; + esac + fi + fi + fi + + if test prog = "$linkmode" || test relink = "$opt_mode"; then + add_shlibpath= + add_dir= + add= + # Finalize command for both is simple: just hardcode it. + if test yes = "$hardcode_direct" && + test no = "$hardcode_direct_absolute"; then + add=$libdir/$linklib + elif test yes = "$hardcode_minus_L"; then + add_dir=-L$libdir + add=-l$name + elif test yes = "$hardcode_shlibpath_var"; then + case :$finalize_shlibpath: in + *":$libdir:"*) ;; + *) func_append finalize_shlibpath "$libdir:" ;; + esac + add=-l$name + elif test yes = "$hardcode_automatic"; then + if test -n "$inst_prefix_dir" && + test -f "$inst_prefix_dir$libdir/$linklib"; then + add=$inst_prefix_dir$libdir/$linklib + else + add=$libdir/$linklib + fi + else + # We cannot seem to hardcode it, guess we'll fake it. + add_dir=-L$libdir + # Try looking first in the location we're being installed to. + if test -n "$inst_prefix_dir"; then + case $libdir in + [\\/]*) + func_append add_dir " -L$inst_prefix_dir$libdir" + ;; + esac + fi + add=-l$name + fi + + if test prog = "$linkmode"; then + test -n "$add_dir" && finalize_deplibs="$add_dir $finalize_deplibs" + test -n "$add" && finalize_deplibs="$add $finalize_deplibs" + else + test -n "$add_dir" && deplibs="$add_dir $deplibs" + test -n "$add" && deplibs="$add $deplibs" + fi + fi + elif test prog = "$linkmode"; then + # Here we assume that one of hardcode_direct or hardcode_minus_L + # is not unsupported. This is valid on all known static and + # shared platforms. + if test unsupported != "$hardcode_direct"; then + test -n "$old_library" && linklib=$old_library + compile_deplibs="$dir/$linklib $compile_deplibs" + finalize_deplibs="$dir/$linklib $finalize_deplibs" + else + compile_deplibs="-l$name -L$dir $compile_deplibs" + finalize_deplibs="-l$name -L$dir $finalize_deplibs" + fi + elif test yes = "$build_libtool_libs"; then + # Not a shared library + if test pass_all != "$deplibs_check_method"; then + # We're trying link a shared library against a static one + # but the system doesn't support it. + + # Just print a warning and add the library to dependency_libs so + # that the program can be linked against the static library. + echo + $ECHO "*** Warning: This system cannot link to static lib archive $lib." + echo "*** I have the capability to make that library automatically link in when" + echo "*** you link to this library. But I can only do this if you have a" + echo "*** shared version of the library, which you do not appear to have." + if test yes = "$module"; then + echo "*** But as you try to build a module library, libtool will still create " + echo "*** a static module, that should work as long as the dlopening application" + echo "*** is linked with the -dlopen flag to resolve symbols at runtime." + if test -z "$global_symbol_pipe"; then + echo + echo "*** However, this would only work if libtool was able to extract symbol" + echo "*** lists from a program, using 'nm' or equivalent, but libtool could" + echo "*** not find such a program. So, this module is probably useless." + echo "*** 'nm' from GNU binutils and a full rebuild may help." + fi + if test no = "$build_old_libs"; then + build_libtool_libs=module + build_old_libs=yes + else + build_libtool_libs=no + fi + fi + else + deplibs="$dir/$old_library $deplibs" + link_static=yes + fi + fi # link shared/static library? + + if test lib = "$linkmode"; then + if test -n "$dependency_libs" && + { test yes != "$hardcode_into_libs" || + test yes = "$build_old_libs" || + test yes = "$link_static"; }; then + # Extract -R from dependency_libs + temp_deplibs= + for libdir in $dependency_libs; do + case $libdir in + -R*) func_stripname '-R' '' "$libdir" + temp_xrpath=$func_stripname_result + case " $xrpath " in + *" $temp_xrpath "*) ;; + *) func_append xrpath " $temp_xrpath";; + esac;; + *) func_append temp_deplibs " $libdir";; + esac + done + dependency_libs=$temp_deplibs + fi + + func_append newlib_search_path " $absdir" + # Link against this library + test no = "$link_static" && newdependency_libs="$abs_ladir/$laname $newdependency_libs" + # ... and its dependency_libs + tmp_libs= + for deplib in $dependency_libs; do + newdependency_libs="$deplib $newdependency_libs" + case $deplib in + -L*) func_stripname '-L' '' "$deplib" + func_resolve_sysroot "$func_stripname_result";; + *) func_resolve_sysroot "$deplib" ;; + esac + if $opt_preserve_dup_deps; then + case "$tmp_libs " in + *" $func_resolve_sysroot_result "*) + func_append specialdeplibs " $func_resolve_sysroot_result" ;; + esac + fi + func_append tmp_libs " $func_resolve_sysroot_result" + done + + if test no != "$link_all_deplibs"; then + # Add the search paths of all dependency libraries + for deplib in $dependency_libs; do + path= + case $deplib in + -L*) path=$deplib ;; + *.la) + func_resolve_sysroot "$deplib" + deplib=$func_resolve_sysroot_result + func_dirname "$deplib" "" "." + dir=$func_dirname_result + # We need an absolute path. + case $dir in + [\\/]* | [A-Za-z]:[\\/]*) absdir=$dir ;; + *) + absdir=`cd "$dir" && pwd` + if test -z "$absdir"; then + func_warning "cannot determine absolute directory name of '$dir'" + absdir=$dir + fi + ;; + esac + if $GREP "^installed=no" $deplib > /dev/null; then + case $host in + *-*-darwin*) + depdepl= + eval deplibrary_names=`$SED -n -e 's/^library_names=\(.*\)$/\1/p' $deplib` + if test -n "$deplibrary_names"; then + for tmp in $deplibrary_names; do + depdepl=$tmp + done + if test -f "$absdir/$objdir/$depdepl"; then + depdepl=$absdir/$objdir/$depdepl + darwin_install_name=`$OTOOL -L $depdepl | awk '{if (NR == 2) {print $1;exit}}'` + if test -z "$darwin_install_name"; then + darwin_install_name=`$OTOOL64 -L $depdepl | awk '{if (NR == 2) {print $1;exit}}'` + fi + func_append compiler_flags " $wl-dylib_file $wl$darwin_install_name:$depdepl" + func_append linker_flags " -dylib_file $darwin_install_name:$depdepl" + path= + fi + fi + ;; + *) + path=-L$absdir/$objdir + ;; + esac + else + eval libdir=`$SED -n -e 's/^libdir=\(.*\)$/\1/p' $deplib` + test -z "$libdir" && \ + func_fatal_error "'$deplib' is not a valid libtool archive" + test "$absdir" != "$libdir" && \ + func_warning "'$deplib' seems to be moved" + + path=-L$absdir + fi + ;; + esac + case " $deplibs " in + *" $path "*) ;; + *) deplibs="$path $deplibs" ;; + esac + done + fi # link_all_deplibs != no + fi # linkmode = lib + done # for deplib in $libs + if test link = "$pass"; then + if test prog = "$linkmode"; then + compile_deplibs="$new_inherited_linker_flags $compile_deplibs" + finalize_deplibs="$new_inherited_linker_flags $finalize_deplibs" + else + compiler_flags="$compiler_flags "`$ECHO " $new_inherited_linker_flags" | $SED 's% \([^ $]*\).ltframework% -framework \1%g'` + fi + fi + dependency_libs=$newdependency_libs + if test dlpreopen = "$pass"; then + # Link the dlpreopened libraries before other libraries + for deplib in $save_deplibs; do + deplibs="$deplib $deplibs" + done + fi + if test dlopen != "$pass"; then + test conv = "$pass" || { + # Make sure lib_search_path contains only unique directories. + lib_search_path= + for dir in $newlib_search_path; do + case "$lib_search_path " in + *" $dir "*) ;; + *) func_append lib_search_path " $dir" ;; + esac + done + newlib_search_path= + } + + if test prog,link = "$linkmode,$pass"; then + vars="compile_deplibs finalize_deplibs" + else + vars=deplibs + fi + for var in $vars dependency_libs; do + # Add libraries to $var in reverse order + eval tmp_libs=\"\$$var\" + new_libs= + for deplib in $tmp_libs; do + # FIXME: Pedantically, this is the right thing to do, so + # that some nasty dependency loop isn't accidentally + # broken: + #new_libs="$deplib $new_libs" + # Pragmatically, this seems to cause very few problems in + # practice: + case $deplib in + -L*) new_libs="$deplib $new_libs" ;; + -R*) ;; + *) + # And here is the reason: when a library appears more + # than once as an explicit dependence of a library, or + # is implicitly linked in more than once by the + # compiler, it is considered special, and multiple + # occurrences thereof are not removed. Compare this + # with having the same library being listed as a + # dependency of multiple other libraries: in this case, + # we know (pedantically, we assume) the library does not + # need to be listed more than once, so we keep only the + # last copy. This is not always right, but it is rare + # enough that we require users that really mean to play + # such unportable linking tricks to link the library + # using -Wl,-lname, so that libtool does not consider it + # for duplicate removal. + case " $specialdeplibs " in + *" $deplib "*) new_libs="$deplib $new_libs" ;; + *) + case " $new_libs " in + *" $deplib "*) ;; + *) new_libs="$deplib $new_libs" ;; + esac + ;; + esac + ;; + esac + done + tmp_libs= + for deplib in $new_libs; do + case $deplib in + -L*) + case " $tmp_libs " in + *" $deplib "*) ;; + *) func_append tmp_libs " $deplib" ;; + esac + ;; + *) func_append tmp_libs " $deplib" ;; + esac + done + eval $var=\"$tmp_libs\" + done # for var + fi + + # Add Sun CC postdeps if required: + test CXX = "$tagname" && { + case $host_os in + linux*) + case `$CC -V 2>&1 | $SED 5q` in + *Sun\ C*) # Sun C++ 5.9 + func_suncc_cstd_abi + + if test no != "$suncc_use_cstd_abi"; then + func_append postdeps ' -library=Cstd -library=Crun' + fi + ;; + esac + ;; + + solaris*) + func_cc_basename "$CC" + case $func_cc_basename_result in + CC* | sunCC*) + func_suncc_cstd_abi + + if test no != "$suncc_use_cstd_abi"; then + func_append postdeps ' -library=Cstd -library=Crun' + fi + ;; + esac + ;; + esac + } + + # Last step: remove runtime libs from dependency_libs + # (they stay in deplibs) + tmp_libs= + for i in $dependency_libs; do + case " $predeps $postdeps $compiler_lib_search_path " in + *" $i "*) + i= + ;; + esac + if test -n "$i"; then + func_append tmp_libs " $i" + fi + done + dependency_libs=$tmp_libs + done # for pass + if test prog = "$linkmode"; then + dlfiles=$newdlfiles + fi + if test prog = "$linkmode" || test lib = "$linkmode"; then + dlprefiles=$newdlprefiles + fi + + case $linkmode in + oldlib) + if test -n "$dlfiles$dlprefiles" || test no != "$dlself"; then + func_warning "'-dlopen' is ignored for archives" + fi + + case " $deplibs" in + *\ -l* | *\ -L*) + func_warning "'-l' and '-L' are ignored for archives" ;; + esac + + test -n "$rpath" && \ + func_warning "'-rpath' is ignored for archives" + + test -n "$xrpath" && \ + func_warning "'-R' is ignored for archives" + + test -n "$vinfo" && \ + func_warning "'-version-info/-version-number' is ignored for archives" + + test -n "$release" && \ + func_warning "'-release' is ignored for archives" + + test -n "$export_symbols$export_symbols_regex" && \ + func_warning "'-export-symbols' is ignored for archives" + + # Now set the variables for building old libraries. + build_libtool_libs=no + oldlibs=$output + func_append objs "$old_deplibs" + ;; + + lib) + # Make sure we only generate libraries of the form 'libNAME.la'. + case $outputname in + lib*) + func_stripname 'lib' '.la' "$outputname" + name=$func_stripname_result + eval shared_ext=\"$shrext_cmds\" + eval libname=\"$libname_spec\" + ;; + *) + test no = "$module" \ + && func_fatal_help "libtool library '$output' must begin with 'lib'" + + if test no != "$need_lib_prefix"; then + # Add the "lib" prefix for modules if required + func_stripname '' '.la' "$outputname" + name=$func_stripname_result + eval shared_ext=\"$shrext_cmds\" + eval libname=\"$libname_spec\" + else + func_stripname '' '.la' "$outputname" + libname=$func_stripname_result + fi + ;; + esac + + if test -n "$objs"; then + if test pass_all != "$deplibs_check_method"; then + func_fatal_error "cannot build libtool library '$output' from non-libtool objects on this host:$objs" + else + echo + $ECHO "*** Warning: Linking the shared library $output against the non-libtool" + $ECHO "*** objects $objs is not portable!" + func_append libobjs " $objs" + fi + fi + + test no = "$dlself" \ + || func_warning "'-dlopen self' is ignored for libtool libraries" + + set dummy $rpath + shift + test 1 -lt "$#" \ + && func_warning "ignoring multiple '-rpath's for a libtool library" + + install_libdir=$1 + + oldlibs= + if test -z "$rpath"; then + if test yes = "$build_libtool_libs"; then + # Building a libtool convenience library. + # Some compilers have problems with a '.al' extension so + # convenience libraries should have the same extension an + # archive normally would. + oldlibs="$output_objdir/$libname.$libext $oldlibs" + build_libtool_libs=convenience + build_old_libs=yes + fi + + test -n "$vinfo" && \ + func_warning "'-version-info/-version-number' is ignored for convenience libraries" + + test -n "$release" && \ + func_warning "'-release' is ignored for convenience libraries" + else + + # Parse the version information argument. + save_ifs=$IFS; IFS=: + set dummy $vinfo 0 0 0 + shift + IFS=$save_ifs + + test -n "$7" && \ + func_fatal_help "too many parameters to '-version-info'" + + # convert absolute version numbers to libtool ages + # this retains compatibility with .la files and attempts + # to make the code below a bit more comprehensible + + case $vinfo_number in + yes) + number_major=$1 + number_minor=$2 + number_revision=$3 + # + # There are really only two kinds -- those that + # use the current revision as the major version + # and those that subtract age and use age as + # a minor version. But, then there is irix + # that has an extra 1 added just for fun + # + case $version_type in + # correct linux to gnu/linux during the next big refactor + darwin|freebsd-elf|linux|midnightbsd-elf|osf|windows|none) + func_arith $number_major + $number_minor + current=$func_arith_result + age=$number_minor + revision=$number_revision + ;; + freebsd-aout|qnx|sunos) + current=$number_major + revision=$number_minor + age=0 + ;; + irix|nonstopux) + func_arith $number_major + $number_minor + current=$func_arith_result + age=$number_minor + revision=$number_minor + lt_irix_increment=no + ;; + *) + func_fatal_configuration "$modename: unknown library version type '$version_type'" + ;; + esac + ;; + no) + current=$1 + revision=$2 + age=$3 + ;; + esac + + # Check that each of the things are valid numbers. + case $current in + 0|[1-9]|[1-9][0-9]|[1-9][0-9][0-9]|[1-9][0-9][0-9][0-9]|[1-9][0-9][0-9][0-9][0-9]) ;; + *) + func_error "CURRENT '$current' must be a nonnegative integer" + func_fatal_error "'$vinfo' is not valid version information" + ;; + esac + + case $revision in + 0|[1-9]|[1-9][0-9]|[1-9][0-9][0-9]|[1-9][0-9][0-9][0-9]|[1-9][0-9][0-9][0-9][0-9]) ;; + *) + func_error "REVISION '$revision' must be a nonnegative integer" + func_fatal_error "'$vinfo' is not valid version information" + ;; + esac + + case $age in + 0|[1-9]|[1-9][0-9]|[1-9][0-9][0-9]|[1-9][0-9][0-9][0-9]|[1-9][0-9][0-9][0-9][0-9]) ;; + *) + func_error "AGE '$age' must be a nonnegative integer" + func_fatal_error "'$vinfo' is not valid version information" + ;; + esac + + if test "$age" -gt "$current"; then + func_error "AGE '$age' is greater than the current interface number '$current'" + func_fatal_error "'$vinfo' is not valid version information" + fi + + # Calculate the version variables. + major= + versuffix= + verstring= + case $version_type in + none) ;; + + darwin) + # Like Linux, but with the current version available in + # verstring for coding it into the library header + func_arith $current - $age + major=.$func_arith_result + versuffix=$major.$age.$revision + # Darwin ld doesn't like 0 for these options... + func_arith $current + 1 + minor_current=$func_arith_result + xlcverstring="$wl-compatibility_version $wl$minor_current $wl-current_version $wl$minor_current.$revision" + verstring="-compatibility_version $minor_current -current_version $minor_current.$revision" + # On Darwin other compilers + case $CC in + nagfor*) + verstring="$wl-compatibility_version $wl$minor_current $wl-current_version $wl$minor_current.$revision" + ;; + *) + verstring="-compatibility_version $minor_current -current_version $minor_current.$revision" + ;; + esac + ;; + + freebsd-aout) + major=.$current + versuffix=.$current.$revision + ;; + + freebsd-elf | midnightbsd-elf) + func_arith $current - $age + major=.$func_arith_result + versuffix=$major.$age.$revision + ;; + + irix | nonstopux) + if test no = "$lt_irix_increment"; then + func_arith $current - $age + else + func_arith $current - $age + 1 + fi + major=$func_arith_result + + case $version_type in + nonstopux) verstring_prefix=nonstopux ;; + *) verstring_prefix=sgi ;; + esac + verstring=$verstring_prefix$major.$revision + + # Add in all the interfaces that we are compatible with. + loop=$revision + while test 0 -ne "$loop"; do + func_arith $revision - $loop + iface=$func_arith_result + func_arith $loop - 1 + loop=$func_arith_result + verstring=$verstring_prefix$major.$iface:$verstring + done + + # Before this point, $major must not contain '.'. + major=.$major + versuffix=$major.$revision + ;; + + linux) # correct to gnu/linux during the next big refactor + func_arith $current - $age + major=.$func_arith_result + versuffix=$major.$age.$revision + ;; + + osf) + func_arith $current - $age + major=.$func_arith_result + versuffix=.$current.$age.$revision + verstring=$current.$age.$revision + + # Add in all the interfaces that we are compatible with. + loop=$age + while test 0 -ne "$loop"; do + func_arith $current - $loop + iface=$func_arith_result + func_arith $loop - 1 + loop=$func_arith_result + verstring=$verstring:$iface.0 + done + + # Make executables depend on our current version. + func_append verstring ":$current.0" + ;; + + qnx) + major=.$current + versuffix=.$current + ;; + + sco) + major=.$current + versuffix=.$current + ;; + + sunos) + major=.$current + versuffix=.$current.$revision + ;; + + windows) + # Use '-' rather than '.', since we only want one + # extension on DOS 8.3 file systems. + func_arith $current - $age + major=$func_arith_result + versuffix=-$major + ;; + + *) + func_fatal_configuration "unknown library version type '$version_type'" + ;; + esac + + # Clear the version info if we defaulted, and they specified a release. + if test -z "$vinfo" && test -n "$release"; then + major= + case $version_type in + darwin) + # we can't check for "0.0" in archive_cmds due to quoting + # problems, so we reset it completely + verstring= + ;; + *) + verstring=0.0 + ;; + esac + if test no = "$need_version"; then + versuffix= + else + versuffix=.0.0 + fi + fi + + # Remove version info from name if versioning should be avoided + if test yes,no = "$avoid_version,$need_version"; then + major= + versuffix= + verstring= + fi + + # Check to see if the archive will have undefined symbols. + if test yes = "$allow_undefined"; then + if test unsupported = "$allow_undefined_flag"; then + if test yes = "$build_old_libs"; then + func_warning "undefined symbols not allowed in $host shared libraries; building static only" + build_libtool_libs=no + else + func_fatal_error "can't build $host shared library unless -no-undefined is specified" + fi + fi + else + # Don't allow undefined symbols. + allow_undefined_flag=$no_undefined_flag + fi + + fi + + func_generate_dlsyms "$libname" "$libname" : + func_append libobjs " $symfileobj" + test " " = "$libobjs" && libobjs= + + if test relink != "$opt_mode"; then + # Remove our outputs, but don't remove object files since they + # may have been created when compiling PIC objects. + removelist= + tempremovelist=`$ECHO "$output_objdir/*"` + for p in $tempremovelist; do + case $p in + *.$objext | *.gcno) + ;; + $output_objdir/$outputname | $output_objdir/$libname.* | $output_objdir/$libname$release.*) + if test -n "$precious_files_regex"; then + if $ECHO "$p" | $EGREP -e "$precious_files_regex" >/dev/null 2>&1 + then + continue + fi + fi + func_append removelist " $p" + ;; + *) ;; + esac + done + test -n "$removelist" && \ + func_show_eval "${RM}r \$removelist" + fi + + # Now set the variables for building old libraries. + if test yes = "$build_old_libs" && test convenience != "$build_libtool_libs"; then + func_append oldlibs " $output_objdir/$libname.$libext" + + # Transform .lo files to .o files. + oldobjs="$objs "`$ECHO "$libobjs" | $SP2NL | $SED "/\.$libext$/d; $lo2o" | $NL2SP` + fi + + # Eliminate all temporary directories. + #for path in $notinst_path; do + # lib_search_path=`$ECHO "$lib_search_path " | $SED "s% $path % %g"` + # deplibs=`$ECHO "$deplibs " | $SED "s% -L$path % %g"` + # dependency_libs=`$ECHO "$dependency_libs " | $SED "s% -L$path % %g"` + #done + + if test -n "$xrpath"; then + # If the user specified any rpath flags, then add them. + temp_xrpath= + for libdir in $xrpath; do + func_replace_sysroot "$libdir" + func_append temp_xrpath " -R$func_replace_sysroot_result" + case "$finalize_rpath " in + *" $libdir "*) ;; + *) func_append finalize_rpath " $libdir" ;; + esac + done + if test yes != "$hardcode_into_libs" || test yes = "$build_old_libs"; then + dependency_libs="$temp_xrpath $dependency_libs" + fi + fi + + # Make sure dlfiles contains only unique files that won't be dlpreopened + old_dlfiles=$dlfiles + dlfiles= + for lib in $old_dlfiles; do + case " $dlprefiles $dlfiles " in + *" $lib "*) ;; + *) func_append dlfiles " $lib" ;; + esac + done + + # Make sure dlprefiles contains only unique files + old_dlprefiles=$dlprefiles + dlprefiles= + for lib in $old_dlprefiles; do + case "$dlprefiles " in + *" $lib "*) ;; + *) func_append dlprefiles " $lib" ;; + esac + done + + if test yes = "$build_libtool_libs"; then + if test -n "$rpath"; then + case $host in + *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-os2* | *-*-beos* | *-cegcc* | *-*-haiku*) + # these systems don't actually have a c library (as such)! + ;; + *-*-rhapsody* | *-*-darwin1.[012]) + # Rhapsody C library is in the System framework + func_append deplibs " System.ltframework" + ;; + *-*-netbsd*) + # Don't link with libc until the a.out ld.so is fixed. + ;; + *-*-openbsd* | *-*-freebsd* | *-*-dragonfly* | *-*-midnightbsd*) + # Do not include libc due to us having libc/libc_r. + ;; + *-*-sco3.2v5* | *-*-sco5v6*) + # Causes problems with __ctype + ;; + *-*-sysv4.2uw2* | *-*-sysv5* | *-*-unixware* | *-*-OpenUNIX*) + # Compiler inserts libc in the correct place for threads to work + ;; + *) + # Add libc to deplibs on all other systems if necessary. + if test yes = "$build_libtool_need_lc"; then + func_append deplibs " -lc" + fi + ;; + esac + fi + + # Transform deplibs into only deplibs that can be linked in shared. + name_save=$name + libname_save=$libname + release_save=$release + versuffix_save=$versuffix + major_save=$major + # I'm not sure if I'm treating the release correctly. I think + # release should show up in the -l (ie -lgmp5) so we don't want to + # add it in twice. Is that correct? + release= + versuffix= + major= + newdeplibs= + droppeddeps=no + case $deplibs_check_method in + pass_all) + # Don't check for shared/static. Everything works. + # This might be a little naive. We might want to check + # whether the library exists or not. But this is on + # osf3 & osf4 and I'm not really sure... Just + # implementing what was already the behavior. + newdeplibs=$deplibs + ;; + test_compile) + # This code stresses the "libraries are programs" paradigm to its + # limits. Maybe even breaks it. We compile a program, linking it + # against the deplibs as a proxy for the library. Then we can check + # whether they linked in statically or dynamically with ldd. + $opt_dry_run || $RM conftest.c + cat > conftest.c </dev/null` + $nocaseglob + else + potential_libs=`ls $i/$libnameglob[.-]* 2>/dev/null` + fi + for potent_lib in $potential_libs; do + # Follow soft links. + if ls -lLd "$potent_lib" 2>/dev/null | + $GREP " -> " >/dev/null; then + continue + fi + # The statement above tries to avoid entering an + # endless loop below, in case of cyclic links. + # We might still enter an endless loop, since a link + # loop can be closed while we follow links, + # but so what? + potlib=$potent_lib + while test -h "$potlib" 2>/dev/null; do + potliblink=`ls -ld $potlib | $SED 's/.* -> //'` + case $potliblink in + [\\/]* | [A-Za-z]:[\\/]*) potlib=$potliblink;; + *) potlib=`$ECHO "$potlib" | $SED 's|[^/]*$||'`"$potliblink";; + esac + done + if eval $file_magic_cmd \"\$potlib\" 2>/dev/null | + $SED -e 10q | + $EGREP "$file_magic_regex" > /dev/null; then + func_append newdeplibs " $a_deplib" + a_deplib= + break 2 + fi + done + done + fi + if test -n "$a_deplib"; then + droppeddeps=yes + echo + $ECHO "*** Warning: linker path does not have real file for library $a_deplib." + echo "*** I have the capability to make that library automatically link in when" + echo "*** you link to this library. But I can only do this if you have a" + echo "*** shared version of the library, which you do not appear to have" + echo "*** because I did check the linker path looking for a file starting" + if test -z "$potlib"; then + $ECHO "*** with $libname but no candidates were found. (...for file magic test)" + else + $ECHO "*** with $libname and none of the candidates passed a file format test" + $ECHO "*** using a file magic. Last file checked: $potlib" + fi + fi + ;; + *) + # Add a -L argument. + func_append newdeplibs " $a_deplib" + ;; + esac + done # Gone through all deplibs. + ;; + match_pattern*) + set dummy $deplibs_check_method; shift + match_pattern_regex=`expr "$deplibs_check_method" : "$1 \(.*\)"` + for a_deplib in $deplibs; do + case $a_deplib in + -l*) + func_stripname -l '' "$a_deplib" + name=$func_stripname_result + if test yes = "$allow_libtool_libs_with_static_runtimes"; then + case " $predeps $postdeps " in + *" $a_deplib "*) + func_append newdeplibs " $a_deplib" + a_deplib= + ;; + esac + fi + if test -n "$a_deplib"; then + libname=`eval "\\$ECHO \"$libname_spec\""` + for i in $lib_search_path $sys_lib_search_path $shlib_search_path; do + potential_libs=`ls $i/$libname[.-]* 2>/dev/null` + for potent_lib in $potential_libs; do + potlib=$potent_lib # see symlink-check above in file_magic test + if eval "\$ECHO \"$potent_lib\"" 2>/dev/null | $SED 10q | \ + $EGREP "$match_pattern_regex" > /dev/null; then + func_append newdeplibs " $a_deplib" + a_deplib= + break 2 + fi + done + done + fi + if test -n "$a_deplib"; then + droppeddeps=yes + echo + $ECHO "*** Warning: linker path does not have real file for library $a_deplib." + echo "*** I have the capability to make that library automatically link in when" + echo "*** you link to this library. But I can only do this if you have a" + echo "*** shared version of the library, which you do not appear to have" + echo "*** because I did check the linker path looking for a file starting" + if test -z "$potlib"; then + $ECHO "*** with $libname but no candidates were found. (...for regex pattern test)" + else + $ECHO "*** with $libname and none of the candidates passed a file format test" + $ECHO "*** using a regex pattern. Last file checked: $potlib" + fi + fi + ;; + *) + # Add a -L argument. + func_append newdeplibs " $a_deplib" + ;; + esac + done # Gone through all deplibs. + ;; + none | unknown | *) + newdeplibs= + tmp_deplibs=`$ECHO " $deplibs" | $SED 's/ -lc$//; s/ -[LR][^ ]*//g'` + if test yes = "$allow_libtool_libs_with_static_runtimes"; then + for i in $predeps $postdeps; do + # can't use Xsed below, because $i might contain '/' + tmp_deplibs=`$ECHO " $tmp_deplibs" | $SED "s|$i||"` + done + fi + case $tmp_deplibs in + *[!\ \ ]*) + echo + if test none = "$deplibs_check_method"; then + echo "*** Warning: inter-library dependencies are not supported in this platform." + else + echo "*** Warning: inter-library dependencies are not known to be supported." + fi + echo "*** All declared inter-library dependencies are being dropped." + droppeddeps=yes + ;; + esac + ;; + esac + versuffix=$versuffix_save + major=$major_save + release=$release_save + libname=$libname_save + name=$name_save + + case $host in + *-*-rhapsody* | *-*-darwin1.[012]) + # On Rhapsody replace the C library with the System framework + newdeplibs=`$ECHO " $newdeplibs" | $SED 's/ -lc / System.ltframework /'` + ;; + esac + + if test yes = "$droppeddeps"; then + if test yes = "$module"; then + echo + echo "*** Warning: libtool could not satisfy all declared inter-library" + $ECHO "*** dependencies of module $libname. Therefore, libtool will create" + echo "*** a static module, that should work as long as the dlopening" + echo "*** application is linked with the -dlopen flag." + if test -z "$global_symbol_pipe"; then + echo + echo "*** However, this would only work if libtool was able to extract symbol" + echo "*** lists from a program, using 'nm' or equivalent, but libtool could" + echo "*** not find such a program. So, this module is probably useless." + echo "*** 'nm' from GNU binutils and a full rebuild may help." + fi + if test no = "$build_old_libs"; then + oldlibs=$output_objdir/$libname.$libext + build_libtool_libs=module + build_old_libs=yes + else + build_libtool_libs=no + fi + else + echo "*** The inter-library dependencies that have been dropped here will be" + echo "*** automatically added whenever a program is linked with this library" + echo "*** or is declared to -dlopen it." + + if test no = "$allow_undefined"; then + echo + echo "*** Since this library must not contain undefined symbols," + echo "*** because either the platform does not support them or" + echo "*** it was explicitly requested with -no-undefined," + echo "*** libtool will only create a static version of it." + if test no = "$build_old_libs"; then + oldlibs=$output_objdir/$libname.$libext + build_libtool_libs=module + build_old_libs=yes + else + build_libtool_libs=no + fi + fi + fi + fi + # Done checking deplibs! + deplibs=$newdeplibs + fi + # Time to change all our "foo.ltframework" stuff back to "-framework foo" + case $host in + *-*-darwin*) + newdeplibs=`$ECHO " $newdeplibs" | $SED 's% \([^ $]*\).ltframework% -framework \1%g'` + new_inherited_linker_flags=`$ECHO " $new_inherited_linker_flags" | $SED 's% \([^ $]*\).ltframework% -framework \1%g'` + deplibs=`$ECHO " $deplibs" | $SED 's% \([^ $]*\).ltframework% -framework \1%g'` + ;; + esac + + # move library search paths that coincide with paths to not yet + # installed libraries to the beginning of the library search list + new_libs= + for path in $notinst_path; do + case " $new_libs " in + *" -L$path/$objdir "*) ;; + *) + case " $deplibs " in + *" -L$path/$objdir "*) + func_append new_libs " -L$path/$objdir" ;; + esac + ;; + esac + done + for deplib in $deplibs; do + case $deplib in + -L*) + case " $new_libs " in + *" $deplib "*) ;; + *) func_append new_libs " $deplib" ;; + esac + ;; + *) func_append new_libs " $deplib" ;; + esac + done + deplibs=$new_libs + + # All the library-specific variables (install_libdir is set above). + library_names= + old_library= + dlname= + + # Test again, we may have decided not to build it any more + if test yes = "$build_libtool_libs"; then + # Remove $wl instances when linking with ld. + # FIXME: should test the right _cmds variable. + case $archive_cmds in + *\$LD\ *) wl= ;; + esac + if test yes = "$hardcode_into_libs"; then + # Hardcode the library paths + hardcode_libdirs= + dep_rpath= + rpath=$finalize_rpath + test relink = "$opt_mode" || rpath=$compile_rpath$rpath + for libdir in $rpath; do + if test -n "$hardcode_libdir_flag_spec"; then + if test -n "$hardcode_libdir_separator"; then + func_replace_sysroot "$libdir" + libdir=$func_replace_sysroot_result + if test -z "$hardcode_libdirs"; then + hardcode_libdirs=$libdir + else + # Just accumulate the unique libdirs. + case $hardcode_libdir_separator$hardcode_libdirs$hardcode_libdir_separator in + *"$hardcode_libdir_separator$libdir$hardcode_libdir_separator"*) + ;; + *) + func_append hardcode_libdirs "$hardcode_libdir_separator$libdir" + ;; + esac + fi + else + eval flag=\"$hardcode_libdir_flag_spec\" + func_append dep_rpath " $flag" + fi + elif test -n "$runpath_var"; then + case "$perm_rpath " in + *" $libdir "*) ;; + *) func_append perm_rpath " $libdir" ;; + esac + fi + done + # Substitute the hardcoded libdirs into the rpath. + if test -n "$hardcode_libdir_separator" && + test -n "$hardcode_libdirs"; then + libdir=$hardcode_libdirs + eval "dep_rpath=\"$hardcode_libdir_flag_spec\"" + fi + if test -n "$runpath_var" && test -n "$perm_rpath"; then + # We should set the runpath_var. + rpath= + for dir in $perm_rpath; do + func_append rpath "$dir:" + done + eval "$runpath_var='$rpath\$$runpath_var'; export $runpath_var" + fi + test -n "$dep_rpath" && deplibs="$dep_rpath $deplibs" + fi + + shlibpath=$finalize_shlibpath + test relink = "$opt_mode" || shlibpath=$compile_shlibpath$shlibpath + if test -n "$shlibpath"; then + eval "$shlibpath_var='$shlibpath\$$shlibpath_var'; export $shlibpath_var" + fi + + # Get the real and link names of the library. + eval shared_ext=\"$shrext_cmds\" + eval library_names=\"$library_names_spec\" + set dummy $library_names + shift + realname=$1 + shift + + if test -n "$soname_spec"; then + eval soname=\"$soname_spec\" + else + soname=$realname + fi + if test -z "$dlname"; then + dlname=$soname + fi + + lib=$output_objdir/$realname + linknames= + for link + do + func_append linknames " $link" + done + + # Use standard objects if they are pic + test -z "$pic_flag" && libobjs=`$ECHO "$libobjs" | $SP2NL | $SED "$lo2o" | $NL2SP` + test "X$libobjs" = "X " && libobjs= + + delfiles= + if test -n "$export_symbols" && test -n "$include_expsyms"; then + $opt_dry_run || cp "$export_symbols" "$output_objdir/$libname.uexp" + export_symbols=$output_objdir/$libname.uexp + func_append delfiles " $export_symbols" + fi + + orig_export_symbols= + case $host_os in + cygwin* | mingw* | cegcc*) + if test -n "$export_symbols" && test -z "$export_symbols_regex"; then + # exporting using user supplied symfile + func_dll_def_p "$export_symbols" || { + # and it's NOT already a .def file. Must figure out + # which of the given symbols are data symbols and tag + # them as such. So, trigger use of export_symbols_cmds. + # export_symbols gets reassigned inside the "prepare + # the list of exported symbols" if statement, so the + # include_expsyms logic still works. + orig_export_symbols=$export_symbols + export_symbols= + always_export_symbols=yes + } + fi + ;; + esac + + # Prepare the list of exported symbols + if test -z "$export_symbols"; then + if test yes = "$always_export_symbols" || test -n "$export_symbols_regex"; then + func_verbose "generating symbol list for '$libname.la'" + export_symbols=$output_objdir/$libname.exp + $opt_dry_run || $RM $export_symbols + cmds=$export_symbols_cmds + save_ifs=$IFS; IFS='~' + for cmd1 in $cmds; do + IFS=$save_ifs + # Take the normal branch if the nm_file_list_spec branch + # doesn't work or if tool conversion is not needed. + case $nm_file_list_spec~$to_tool_file_cmd in + *~func_convert_file_noop | *~func_convert_file_msys_to_w32 | ~*) + try_normal_branch=yes + eval cmd=\"$cmd1\" + func_len " $cmd" + len=$func_len_result + ;; + *) + try_normal_branch=no + ;; + esac + if test yes = "$try_normal_branch" \ + && { test "$len" -lt "$max_cmd_len" \ + || test "$max_cmd_len" -le -1; } + then + func_show_eval "$cmd" 'exit $?' + skipped_export=false + elif test -n "$nm_file_list_spec"; then + func_basename "$output" + output_la=$func_basename_result + save_libobjs=$libobjs + save_output=$output + output=$output_objdir/$output_la.nm + func_to_tool_file "$output" + libobjs=$nm_file_list_spec$func_to_tool_file_result + func_append delfiles " $output" + func_verbose "creating $NM input file list: $output" + for obj in $save_libobjs; do + func_to_tool_file "$obj" + $ECHO "$func_to_tool_file_result" + done > "$output" + eval cmd=\"$cmd1\" + func_show_eval "$cmd" 'exit $?' + output=$save_output + libobjs=$save_libobjs + skipped_export=false + else + # The command line is too long to execute in one step. + func_verbose "using reloadable object file for export list..." + skipped_export=: + # Break out early, otherwise skipped_export may be + # set to false by a later but shorter cmd. + break + fi + done + IFS=$save_ifs + if test -n "$export_symbols_regex" && test : != "$skipped_export"; then + func_show_eval '$EGREP -e "$export_symbols_regex" "$export_symbols" > "${export_symbols}T"' + func_show_eval '$MV "${export_symbols}T" "$export_symbols"' + fi + fi + fi + + if test -n "$export_symbols" && test -n "$include_expsyms"; then + tmp_export_symbols=$export_symbols + test -n "$orig_export_symbols" && tmp_export_symbols=$orig_export_symbols + $opt_dry_run || eval '$ECHO "$include_expsyms" | $SP2NL >> "$tmp_export_symbols"' + fi + + if test : != "$skipped_export" && test -n "$orig_export_symbols"; then + # The given exports_symbols file has to be filtered, so filter it. + func_verbose "filter symbol list for '$libname.la' to tag DATA exports" + # FIXME: $output_objdir/$libname.filter potentially contains lots of + # 's' commands, which not all seds can handle. GNU sed should be fine + # though. Also, the filter scales superlinearly with the number of + # global variables. join(1) would be nice here, but unfortunately + # isn't a blessed tool. + $opt_dry_run || $SED -e '/[ ,]DATA/!d;s,\(.*\)\([ \,].*\),s|^\1$|\1\2|,' < $export_symbols > $output_objdir/$libname.filter + func_append delfiles " $export_symbols $output_objdir/$libname.filter" + export_symbols=$output_objdir/$libname.def + $opt_dry_run || $SED -f $output_objdir/$libname.filter < $orig_export_symbols > $export_symbols + fi + + tmp_deplibs= + for test_deplib in $deplibs; do + case " $convenience " in + *" $test_deplib "*) ;; + *) + func_append tmp_deplibs " $test_deplib" + ;; + esac + done + deplibs=$tmp_deplibs + + if test -n "$convenience"; then + if test -n "$whole_archive_flag_spec" && + test yes = "$compiler_needs_object" && + test -z "$libobjs"; then + # extract the archives, so we have objects to list. + # TODO: could optimize this to just extract one archive. + whole_archive_flag_spec= + fi + if test -n "$whole_archive_flag_spec"; then + save_libobjs=$libobjs + eval libobjs=\"\$libobjs $whole_archive_flag_spec\" + test "X$libobjs" = "X " && libobjs= + else + gentop=$output_objdir/${outputname}x + func_append generated " $gentop" + + func_extract_archives $gentop $convenience + func_append libobjs " $func_extract_archives_result" + test "X$libobjs" = "X " && libobjs= + fi + fi + + if test yes = "$thread_safe" && test -n "$thread_safe_flag_spec"; then + eval flag=\"$thread_safe_flag_spec\" + func_append linker_flags " $flag" + fi + + # Make a backup of the uninstalled library when relinking + if test relink = "$opt_mode"; then + $opt_dry_run || eval '(cd $output_objdir && $RM ${realname}U && $MV $realname ${realname}U)' || exit $? + fi + + # Do each of the archive commands. + if test yes = "$module" && test -n "$module_cmds"; then + if test -n "$export_symbols" && test -n "$module_expsym_cmds"; then + eval test_cmds=\"$module_expsym_cmds\" + cmds=$module_expsym_cmds + else + eval test_cmds=\"$module_cmds\" + cmds=$module_cmds + fi + else + if test -n "$export_symbols" && test -n "$archive_expsym_cmds"; then + eval test_cmds=\"$archive_expsym_cmds\" + cmds=$archive_expsym_cmds + else + eval test_cmds=\"$archive_cmds\" + cmds=$archive_cmds + fi + fi + + if test : != "$skipped_export" && + func_len " $test_cmds" && + len=$func_len_result && + test "$len" -lt "$max_cmd_len" || test "$max_cmd_len" -le -1; then + : + else + # The command line is too long to link in one step, link piecewise + # or, if using GNU ld and skipped_export is not :, use a linker + # script. + + # Save the value of $output and $libobjs because we want to + # use them later. If we have whole_archive_flag_spec, we + # want to use save_libobjs as it was before + # whole_archive_flag_spec was expanded, because we can't + # assume the linker understands whole_archive_flag_spec. + # This may have to be revisited, in case too many + # convenience libraries get linked in and end up exceeding + # the spec. + if test -z "$convenience" || test -z "$whole_archive_flag_spec"; then + save_libobjs=$libobjs + fi + save_output=$output + func_basename "$output" + output_la=$func_basename_result + + # Clear the reloadable object creation command queue and + # initialize k to one. + test_cmds= + concat_cmds= + objlist= + last_robj= + k=1 + + if test -n "$save_libobjs" && test : != "$skipped_export" && test yes = "$with_gnu_ld"; then + output=$output_objdir/$output_la.lnkscript + func_verbose "creating GNU ld script: $output" + echo 'INPUT (' > $output + for obj in $save_libobjs + do + func_to_tool_file "$obj" + $ECHO "$func_to_tool_file_result" >> $output + done + echo ')' >> $output + func_append delfiles " $output" + func_to_tool_file "$output" + output=$func_to_tool_file_result + elif test -n "$save_libobjs" && test : != "$skipped_export" && test -n "$file_list_spec"; then + output=$output_objdir/$output_la.lnk + func_verbose "creating linker input file list: $output" + : > $output + set x $save_libobjs + shift + firstobj= + if test yes = "$compiler_needs_object"; then + firstobj="$1 " + shift + fi + for obj + do + func_to_tool_file "$obj" + $ECHO "$func_to_tool_file_result" >> $output + done + func_append delfiles " $output" + func_to_tool_file "$output" + output=$firstobj\"$file_list_spec$func_to_tool_file_result\" + else + if test -n "$save_libobjs"; then + func_verbose "creating reloadable object files..." + output=$output_objdir/$output_la-$k.$objext + eval test_cmds=\"$reload_cmds\" + func_len " $test_cmds" + len0=$func_len_result + len=$len0 + + # Loop over the list of objects to be linked. + for obj in $save_libobjs + do + func_len " $obj" + func_arith $len + $func_len_result + len=$func_arith_result + if test -z "$objlist" || + test "$len" -lt "$max_cmd_len"; then + func_append objlist " $obj" + else + # The command $test_cmds is almost too long, add a + # command to the queue. + if test 1 -eq "$k"; then + # The first file doesn't have a previous command to add. + reload_objs=$objlist + eval concat_cmds=\"$reload_cmds\" + else + # All subsequent reloadable object files will link in + # the last one created. + reload_objs="$objlist $last_robj" + eval concat_cmds=\"\$concat_cmds~$reload_cmds~\$RM $last_robj\" + fi + last_robj=$output_objdir/$output_la-$k.$objext + func_arith $k + 1 + k=$func_arith_result + output=$output_objdir/$output_la-$k.$objext + objlist=" $obj" + func_len " $last_robj" + func_arith $len0 + $func_len_result + len=$func_arith_result + fi + done + # Handle the remaining objects by creating one last + # reloadable object file. All subsequent reloadable object + # files will link in the last one created. + test -z "$concat_cmds" || concat_cmds=$concat_cmds~ + reload_objs="$objlist $last_robj" + eval concat_cmds=\"\$concat_cmds$reload_cmds\" + if test -n "$last_robj"; then + eval concat_cmds=\"\$concat_cmds~\$RM $last_robj\" + fi + func_append delfiles " $output" + + else + output= + fi + + ${skipped_export-false} && { + func_verbose "generating symbol list for '$libname.la'" + export_symbols=$output_objdir/$libname.exp + $opt_dry_run || $RM $export_symbols + libobjs=$output + # Append the command to create the export file. + test -z "$concat_cmds" || concat_cmds=$concat_cmds~ + eval concat_cmds=\"\$concat_cmds$export_symbols_cmds\" + if test -n "$last_robj"; then + eval concat_cmds=\"\$concat_cmds~\$RM $last_robj\" + fi + } + + test -n "$save_libobjs" && + func_verbose "creating a temporary reloadable object file: $output" + + # Loop through the commands generated above and execute them. + save_ifs=$IFS; IFS='~' + for cmd in $concat_cmds; do + IFS=$save_ifs + $opt_quiet || { + func_quote_arg expand,pretty "$cmd" + eval "func_echo $func_quote_arg_result" + } + $opt_dry_run || eval "$cmd" || { + lt_exit=$? + + # Restore the uninstalled library and exit + if test relink = "$opt_mode"; then + ( cd "$output_objdir" && \ + $RM "${realname}T" && \ + $MV "${realname}U" "$realname" ) + fi + + exit $lt_exit + } + done + IFS=$save_ifs + + if test -n "$export_symbols_regex" && ${skipped_export-false}; then + func_show_eval '$EGREP -e "$export_symbols_regex" "$export_symbols" > "${export_symbols}T"' + func_show_eval '$MV "${export_symbols}T" "$export_symbols"' + fi + fi + + ${skipped_export-false} && { + if test -n "$export_symbols" && test -n "$include_expsyms"; then + tmp_export_symbols=$export_symbols + test -n "$orig_export_symbols" && tmp_export_symbols=$orig_export_symbols + $opt_dry_run || eval '$ECHO "$include_expsyms" | $SP2NL >> "$tmp_export_symbols"' + fi + + if test -n "$orig_export_symbols"; then + # The given exports_symbols file has to be filtered, so filter it. + func_verbose "filter symbol list for '$libname.la' to tag DATA exports" + # FIXME: $output_objdir/$libname.filter potentially contains lots of + # 's' commands, which not all seds can handle. GNU sed should be fine + # though. Also, the filter scales superlinearly with the number of + # global variables. join(1) would be nice here, but unfortunately + # isn't a blessed tool. + $opt_dry_run || $SED -e '/[ ,]DATA/!d;s,\(.*\)\([ \,].*\),s|^\1$|\1\2|,' < $export_symbols > $output_objdir/$libname.filter + func_append delfiles " $export_symbols $output_objdir/$libname.filter" + export_symbols=$output_objdir/$libname.def + $opt_dry_run || $SED -f $output_objdir/$libname.filter < $orig_export_symbols > $export_symbols + fi + } + + libobjs=$output + # Restore the value of output. + output=$save_output + + if test -n "$convenience" && test -n "$whole_archive_flag_spec"; then + eval libobjs=\"\$libobjs $whole_archive_flag_spec\" + test "X$libobjs" = "X " && libobjs= + fi + # Expand the library linking commands again to reset the + # value of $libobjs for piecewise linking. + + # Do each of the archive commands. + if test yes = "$module" && test -n "$module_cmds"; then + if test -n "$export_symbols" && test -n "$module_expsym_cmds"; then + cmds=$module_expsym_cmds + else + cmds=$module_cmds + fi + else + if test -n "$export_symbols" && test -n "$archive_expsym_cmds"; then + cmds=$archive_expsym_cmds + else + cmds=$archive_cmds + fi + fi + fi + + if test -n "$delfiles"; then + # Append the command to remove temporary files to $cmds. + eval cmds=\"\$cmds~\$RM $delfiles\" + fi + + # Add any objects from preloaded convenience libraries + if test -n "$dlprefiles"; then + gentop=$output_objdir/${outputname}x + func_append generated " $gentop" + + func_extract_archives $gentop $dlprefiles + func_append libobjs " $func_extract_archives_result" + test "X$libobjs" = "X " && libobjs= + fi + + save_ifs=$IFS; IFS='~' + for cmd in $cmds; do + IFS=$sp$nl + eval cmd=\"$cmd\" + IFS=$save_ifs + $opt_quiet || { + func_quote_arg expand,pretty "$cmd" + eval "func_echo $func_quote_arg_result" + } + $opt_dry_run || eval "$cmd" || { + lt_exit=$? + + # Restore the uninstalled library and exit + if test relink = "$opt_mode"; then + ( cd "$output_objdir" && \ + $RM "${realname}T" && \ + $MV "${realname}U" "$realname" ) + fi + + exit $lt_exit + } + done + IFS=$save_ifs + + # Restore the uninstalled library and exit + if test relink = "$opt_mode"; then + $opt_dry_run || eval '(cd $output_objdir && $RM ${realname}T && $MV $realname ${realname}T && $MV ${realname}U $realname)' || exit $? + + if test -n "$convenience"; then + if test -z "$whole_archive_flag_spec"; then + func_show_eval '${RM}r "$gentop"' + fi + fi + + exit $EXIT_SUCCESS + fi + + # Create links to the real library. + for linkname in $linknames; do + if test "$realname" != "$linkname"; then + func_show_eval '(cd "$output_objdir" && $RM "$linkname" && $LN_S "$realname" "$linkname")' 'exit $?' + fi + done + + # If -module or -export-dynamic was specified, set the dlname. + if test yes = "$module" || test yes = "$export_dynamic"; then + # On all known operating systems, these are identical. + dlname=$soname + fi + fi + ;; + + obj) + if test -n "$dlfiles$dlprefiles" || test no != "$dlself"; then + func_warning "'-dlopen' is ignored for objects" + fi + + case " $deplibs" in + *\ -l* | *\ -L*) + func_warning "'-l' and '-L' are ignored for objects" ;; + esac + + test -n "$rpath" && \ + func_warning "'-rpath' is ignored for objects" + + test -n "$xrpath" && \ + func_warning "'-R' is ignored for objects" + + test -n "$vinfo" && \ + func_warning "'-version-info' is ignored for objects" + + test -n "$release" && \ + func_warning "'-release' is ignored for objects" + + case $output in + *.lo) + test -n "$objs$old_deplibs" && \ + func_fatal_error "cannot build library object '$output' from non-libtool objects" + + libobj=$output + func_lo2o "$libobj" + obj=$func_lo2o_result + ;; + *) + libobj= + obj=$output + ;; + esac + + # Delete the old objects. + $opt_dry_run || $RM $obj $libobj + + # Objects from convenience libraries. This assumes + # single-version convenience libraries. Whenever we create + # different ones for PIC/non-PIC, this we'll have to duplicate + # the extraction. + reload_conv_objs= + gentop= + # if reload_cmds runs $LD directly, get rid of -Wl from + # whole_archive_flag_spec and hope we can get by with turning comma + # into space. + case $reload_cmds in + *\$LD[\ \$]*) wl= ;; + esac + if test -n "$convenience"; then + if test -n "$whole_archive_flag_spec"; then + eval tmp_whole_archive_flags=\"$whole_archive_flag_spec\" + test -n "$wl" || tmp_whole_archive_flags=`$ECHO "$tmp_whole_archive_flags" | $SED 's|,| |g'` + reload_conv_objs=$reload_objs\ $tmp_whole_archive_flags + else + gentop=$output_objdir/${obj}x + func_append generated " $gentop" + + func_extract_archives $gentop $convenience + reload_conv_objs="$reload_objs $func_extract_archives_result" + fi + fi + + # If we're not building shared, we need to use non_pic_objs + test yes = "$build_libtool_libs" || libobjs=$non_pic_objects + + # Create the old-style object. + reload_objs=$objs$old_deplibs' '`$ECHO "$libobjs" | $SP2NL | $SED "/\.$libext$/d; /\.lib$/d; $lo2o" | $NL2SP`' '$reload_conv_objs + + output=$obj + func_execute_cmds "$reload_cmds" 'exit $?' + + # Exit if we aren't doing a library object file. + if test -z "$libobj"; then + if test -n "$gentop"; then + func_show_eval '${RM}r "$gentop"' + fi + + exit $EXIT_SUCCESS + fi + + test yes = "$build_libtool_libs" || { + if test -n "$gentop"; then + func_show_eval '${RM}r "$gentop"' + fi + + # Create an invalid libtool object if no PIC, so that we don't + # accidentally link it into a program. + # $show "echo timestamp > $libobj" + # $opt_dry_run || eval "echo timestamp > $libobj" || exit $? + exit $EXIT_SUCCESS + } + + if test -n "$pic_flag" || test default != "$pic_mode"; then + # Only do commands if we really have different PIC objects. + reload_objs="$libobjs $reload_conv_objs" + output=$libobj + func_execute_cmds "$reload_cmds" 'exit $?' + fi + + if test -n "$gentop"; then + func_show_eval '${RM}r "$gentop"' + fi + + exit $EXIT_SUCCESS + ;; + + prog) + case $host in + *cygwin*) func_stripname '' '.exe' "$output" + output=$func_stripname_result.exe;; + esac + test -n "$vinfo" && \ + func_warning "'-version-info' is ignored for programs" + + test -n "$release" && \ + func_warning "'-release' is ignored for programs" + + $preload \ + && test unknown,unknown,unknown = "$dlopen_support,$dlopen_self,$dlopen_self_static" \ + && func_warning "'LT_INIT([dlopen])' not used. Assuming no dlopen support." + + case $host in + *-*-rhapsody* | *-*-darwin1.[012]) + # On Rhapsody replace the C library is the System framework + compile_deplibs=`$ECHO " $compile_deplibs" | $SED 's/ -lc / System.ltframework /'` + finalize_deplibs=`$ECHO " $finalize_deplibs" | $SED 's/ -lc / System.ltframework /'` + ;; + esac + + case $host in + *-*-darwin*) + # Don't allow lazy linking, it breaks C++ global constructors + # But is supposedly fixed on 10.4 or later (yay!). + if test CXX = "$tagname"; then + case ${MACOSX_DEPLOYMENT_TARGET-10.0} in + 10.[0123]) + func_append compile_command " $wl-bind_at_load" + func_append finalize_command " $wl-bind_at_load" + ;; + esac + fi + # Time to change all our "foo.ltframework" stuff back to "-framework foo" + compile_deplibs=`$ECHO " $compile_deplibs" | $SED 's% \([^ $]*\).ltframework% -framework \1%g'` + finalize_deplibs=`$ECHO " $finalize_deplibs" | $SED 's% \([^ $]*\).ltframework% -framework \1%g'` + ;; + esac + + + # move library search paths that coincide with paths to not yet + # installed libraries to the beginning of the library search list + new_libs= + for path in $notinst_path; do + case " $new_libs " in + *" -L$path/$objdir "*) ;; + *) + case " $compile_deplibs " in + *" -L$path/$objdir "*) + func_append new_libs " -L$path/$objdir" ;; + esac + ;; + esac + done + for deplib in $compile_deplibs; do + case $deplib in + -L*) + case " $new_libs " in + *" $deplib "*) ;; + *) func_append new_libs " $deplib" ;; + esac + ;; + *) func_append new_libs " $deplib" ;; + esac + done + compile_deplibs=$new_libs + + + func_append compile_command " $compile_deplibs" + func_append finalize_command " $finalize_deplibs" + + if test -n "$rpath$xrpath"; then + # If the user specified any rpath flags, then add them. + for libdir in $rpath $xrpath; do + # This is the magic to use -rpath. + case "$finalize_rpath " in + *" $libdir "*) ;; + *) func_append finalize_rpath " $libdir" ;; + esac + done + fi + + # Now hardcode the library paths + rpath= + hardcode_libdirs= + for libdir in $compile_rpath $finalize_rpath; do + if test -n "$hardcode_libdir_flag_spec"; then + if test -n "$hardcode_libdir_separator"; then + if test -z "$hardcode_libdirs"; then + hardcode_libdirs=$libdir + else + # Just accumulate the unique libdirs. + case $hardcode_libdir_separator$hardcode_libdirs$hardcode_libdir_separator in + *"$hardcode_libdir_separator$libdir$hardcode_libdir_separator"*) + ;; + *) + func_append hardcode_libdirs "$hardcode_libdir_separator$libdir" + ;; + esac + fi + else + eval flag=\"$hardcode_libdir_flag_spec\" + func_append rpath " $flag" + fi + elif test -n "$runpath_var"; then + case "$perm_rpath " in + *" $libdir "*) ;; + *) func_append perm_rpath " $libdir" ;; + esac + fi + case $host in + *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-os2* | *-cegcc*) + testbindir=`$ECHO "$libdir" | $SED -e 's*/lib$*/bin*'` + case :$dllsearchpath: in + *":$libdir:"*) ;; + ::) dllsearchpath=$libdir;; + *) func_append dllsearchpath ":$libdir";; + esac + case :$dllsearchpath: in + *":$testbindir:"*) ;; + ::) dllsearchpath=$testbindir;; + *) func_append dllsearchpath ":$testbindir";; + esac + ;; + esac + done + # Substitute the hardcoded libdirs into the rpath. + if test -n "$hardcode_libdir_separator" && + test -n "$hardcode_libdirs"; then + libdir=$hardcode_libdirs + eval rpath=\" $hardcode_libdir_flag_spec\" + fi + compile_rpath=$rpath + + rpath= + hardcode_libdirs= + for libdir in $finalize_rpath; do + if test -n "$hardcode_libdir_flag_spec"; then + if test -n "$hardcode_libdir_separator"; then + if test -z "$hardcode_libdirs"; then + hardcode_libdirs=$libdir + else + # Just accumulate the unique libdirs. + case $hardcode_libdir_separator$hardcode_libdirs$hardcode_libdir_separator in + *"$hardcode_libdir_separator$libdir$hardcode_libdir_separator"*) + ;; + *) + func_append hardcode_libdirs "$hardcode_libdir_separator$libdir" + ;; + esac + fi + else + eval flag=\"$hardcode_libdir_flag_spec\" + func_append rpath " $flag" + fi + elif test -n "$runpath_var"; then + case "$finalize_perm_rpath " in + *" $libdir "*) ;; + *) func_append finalize_perm_rpath " $libdir" ;; + esac + fi + done + # Substitute the hardcoded libdirs into the rpath. + if test -n "$hardcode_libdir_separator" && + test -n "$hardcode_libdirs"; then + libdir=$hardcode_libdirs + eval rpath=\" $hardcode_libdir_flag_spec\" + fi + finalize_rpath=$rpath + + if test -n "$libobjs" && test yes = "$build_old_libs"; then + # Transform all the library objects into standard objects. + compile_command=`$ECHO "$compile_command" | $SP2NL | $SED "$lo2o" | $NL2SP` + finalize_command=`$ECHO "$finalize_command" | $SP2NL | $SED "$lo2o" | $NL2SP` + fi + + func_generate_dlsyms "$outputname" "@PROGRAM@" false + + # template prelinking step + if test -n "$prelink_cmds"; then + func_execute_cmds "$prelink_cmds" 'exit $?' + fi + + wrappers_required=: + case $host in + *cegcc* | *mingw32ce*) + # Disable wrappers for cegcc and mingw32ce hosts, we are cross compiling anyway. + wrappers_required=false + ;; + *cygwin* | *mingw* ) + test yes = "$build_libtool_libs" || wrappers_required=false + ;; + *) + if test no = "$need_relink" || test yes != "$build_libtool_libs"; then + wrappers_required=false + fi + ;; + esac + $wrappers_required || { + # Replace the output file specification. + compile_command=`$ECHO "$compile_command" | $SED 's%@OUTPUT@%'"$output"'%g'` + link_command=$compile_command$compile_rpath + + # We have no uninstalled library dependencies, so finalize right now. + exit_status=0 + func_show_eval "$link_command" 'exit_status=$?' + + if test -n "$postlink_cmds"; then + func_to_tool_file "$output" + postlink_cmds=`func_echo_all "$postlink_cmds" | $SED -e 's%@OUTPUT@%'"$output"'%g' -e 's%@TOOL_OUTPUT@%'"$func_to_tool_file_result"'%g'` + func_execute_cmds "$postlink_cmds" 'exit $?' + fi + + # Delete the generated files. + if test -f "$output_objdir/${outputname}S.$objext"; then + func_show_eval '$RM "$output_objdir/${outputname}S.$objext"' + fi + + exit $exit_status + } + + if test -n "$compile_shlibpath$finalize_shlibpath"; then + compile_command="$shlibpath_var=\"$compile_shlibpath$finalize_shlibpath\$$shlibpath_var\" $compile_command" + fi + if test -n "$finalize_shlibpath"; then + finalize_command="$shlibpath_var=\"$finalize_shlibpath\$$shlibpath_var\" $finalize_command" + fi + + compile_var= + finalize_var= + if test -n "$runpath_var"; then + if test -n "$perm_rpath"; then + # We should set the runpath_var. + rpath= + for dir in $perm_rpath; do + func_append rpath "$dir:" + done + compile_var="$runpath_var=\"$rpath\$$runpath_var\" " + fi + if test -n "$finalize_perm_rpath"; then + # We should set the runpath_var. + rpath= + for dir in $finalize_perm_rpath; do + func_append rpath "$dir:" + done + finalize_var="$runpath_var=\"$rpath\$$runpath_var\" " + fi + fi + + if test yes = "$no_install"; then + # We don't need to create a wrapper script. + link_command=$compile_var$compile_command$compile_rpath + # Replace the output file specification. + link_command=`$ECHO "$link_command" | $SED 's%@OUTPUT@%'"$output"'%g'` + # Delete the old output file. + $opt_dry_run || $RM $output + # Link the executable and exit + func_show_eval "$link_command" 'exit $?' + + if test -n "$postlink_cmds"; then + func_to_tool_file "$output" + postlink_cmds=`func_echo_all "$postlink_cmds" | $SED -e 's%@OUTPUT@%'"$output"'%g' -e 's%@TOOL_OUTPUT@%'"$func_to_tool_file_result"'%g'` + func_execute_cmds "$postlink_cmds" 'exit $?' + fi + + exit $EXIT_SUCCESS + fi + + case $hardcode_action,$fast_install in + relink,*) + # Fast installation is not supported + link_command=$compile_var$compile_command$compile_rpath + relink_command=$finalize_var$finalize_command$finalize_rpath + + func_warning "this platform does not like uninstalled shared libraries" + func_warning "'$output' will be relinked during installation" + ;; + *,yes) + link_command=$finalize_var$compile_command$finalize_rpath + relink_command=`$ECHO "$compile_var$compile_command$compile_rpath" | $SED 's%@OUTPUT@%\$progdir/\$file%g'` + ;; + *,no) + link_command=$compile_var$compile_command$compile_rpath + relink_command=$finalize_var$finalize_command$finalize_rpath + ;; + *,needless) + link_command=$finalize_var$compile_command$finalize_rpath + relink_command= + ;; + esac + + # Replace the output file specification. + link_command=`$ECHO "$link_command" | $SED 's%@OUTPUT@%'"$output_objdir/$outputname"'%g'` + + # Delete the old output files. + $opt_dry_run || $RM $output $output_objdir/$outputname $output_objdir/lt-$outputname + + func_show_eval "$link_command" 'exit $?' + + if test -n "$postlink_cmds"; then + func_to_tool_file "$output_objdir/$outputname" + postlink_cmds=`func_echo_all "$postlink_cmds" | $SED -e 's%@OUTPUT@%'"$output_objdir/$outputname"'%g' -e 's%@TOOL_OUTPUT@%'"$func_to_tool_file_result"'%g'` + func_execute_cmds "$postlink_cmds" 'exit $?' + fi + + # Now create the wrapper script. + func_verbose "creating $output" + + # Quote the relink command for shipping. + if test -n "$relink_command"; then + # Preserve any variables that may affect compiler behavior + for var in $variables_saved_for_relink; do + if eval test -z \"\${$var+set}\"; then + relink_command="{ test -z \"\${$var+set}\" || $lt_unset $var || { $var=; export $var; }; }; $relink_command" + elif eval var_value=\$$var; test -z "$var_value"; then + relink_command="$var=; export $var; $relink_command" + else + func_quote_arg pretty "$var_value" + relink_command="$var=$func_quote_arg_result; export $var; $relink_command" + fi + done + func_quote eval cd "`pwd`" + func_quote_arg pretty,unquoted "($func_quote_result; $relink_command)" + relink_command=$func_quote_arg_unquoted_result + fi + + # Only actually do things if not in dry run mode. + $opt_dry_run || { + # win32 will think the script is a binary if it has + # a .exe suffix, so we strip it off here. + case $output in + *.exe) func_stripname '' '.exe' "$output" + output=$func_stripname_result ;; + esac + # test for cygwin because mv fails w/o .exe extensions + case $host in + *cygwin*) + exeext=.exe + func_stripname '' '.exe' "$outputname" + outputname=$func_stripname_result ;; + *) exeext= ;; + esac + case $host in + *cygwin* | *mingw* ) + func_dirname_and_basename "$output" "" "." + output_name=$func_basename_result + output_path=$func_dirname_result + cwrappersource=$output_path/$objdir/lt-$output_name.c + cwrapper=$output_path/$output_name.exe + $RM $cwrappersource $cwrapper + trap "$RM $cwrappersource $cwrapper; exit $EXIT_FAILURE" 1 2 15 + + func_emit_cwrapperexe_src > $cwrappersource + + # The wrapper executable is built using the $host compiler, + # because it contains $host paths and files. If cross- + # compiling, it, like the target executable, must be + # executed on the $host or under an emulation environment. + $opt_dry_run || { + $LTCC $LTCFLAGS -o $cwrapper $cwrappersource + $STRIP $cwrapper + } + + # Now, create the wrapper script for func_source use: + func_ltwrapper_scriptname $cwrapper + $RM $func_ltwrapper_scriptname_result + trap "$RM $func_ltwrapper_scriptname_result; exit $EXIT_FAILURE" 1 2 15 + $opt_dry_run || { + # note: this script will not be executed, so do not chmod. + if test "x$build" = "x$host"; then + $cwrapper --lt-dump-script > $func_ltwrapper_scriptname_result + else + func_emit_wrapper no > $func_ltwrapper_scriptname_result + fi + } + ;; + * ) + $RM $output + trap "$RM $output; exit $EXIT_FAILURE" 1 2 15 + + func_emit_wrapper no > $output + chmod +x $output + ;; + esac + } + exit $EXIT_SUCCESS + ;; + esac + + # See if we need to build an old-fashioned archive. + for oldlib in $oldlibs; do + + case $build_libtool_libs in + convenience) + oldobjs="$libobjs_save $symfileobj" + addlibs=$convenience + build_libtool_libs=no + ;; + module) + oldobjs=$libobjs_save + addlibs=$old_convenience + build_libtool_libs=no + ;; + *) + oldobjs="$old_deplibs $non_pic_objects" + $preload && test -f "$symfileobj" \ + && func_append oldobjs " $symfileobj" + addlibs=$old_convenience + ;; + esac + + if test -n "$addlibs"; then + gentop=$output_objdir/${outputname}x + func_append generated " $gentop" + + func_extract_archives $gentop $addlibs + func_append oldobjs " $func_extract_archives_result" + fi + + # Do each command in the archive commands. + if test -n "$old_archive_from_new_cmds" && test yes = "$build_libtool_libs"; then + cmds=$old_archive_from_new_cmds + else + + # Add any objects from preloaded convenience libraries + if test -n "$dlprefiles"; then + gentop=$output_objdir/${outputname}x + func_append generated " $gentop" + + func_extract_archives $gentop $dlprefiles + func_append oldobjs " $func_extract_archives_result" + fi + + # POSIX demands no paths to be encoded in archives. We have + # to avoid creating archives with duplicate basenames if we + # might have to extract them afterwards, e.g., when creating a + # static archive out of a convenience library, or when linking + # the entirety of a libtool archive into another (currently + # not supported by libtool). + if (for obj in $oldobjs + do + func_basename "$obj" + $ECHO "$func_basename_result" + done | sort | sort -uc >/dev/null 2>&1); then + : + else + echo "copying selected object files to avoid basename conflicts..." + gentop=$output_objdir/${outputname}x + func_append generated " $gentop" + func_mkdir_p "$gentop" + save_oldobjs=$oldobjs + oldobjs= + counter=1 + for obj in $save_oldobjs + do + func_basename "$obj" + objbase=$func_basename_result + case " $oldobjs " in + " ") oldobjs=$obj ;; + *[\ /]"$objbase "*) + while :; do + # Make sure we don't pick an alternate name that also + # overlaps. + newobj=lt$counter-$objbase + func_arith $counter + 1 + counter=$func_arith_result + case " $oldobjs " in + *[\ /]"$newobj "*) ;; + *) if test ! -f "$gentop/$newobj"; then break; fi ;; + esac + done + func_show_eval "ln $obj $gentop/$newobj || cp $obj $gentop/$newobj" + func_append oldobjs " $gentop/$newobj" + ;; + *) func_append oldobjs " $obj" ;; + esac + done + fi + func_to_tool_file "$oldlib" func_convert_file_msys_to_w32 + tool_oldlib=$func_to_tool_file_result + eval cmds=\"$old_archive_cmds\" + + func_len " $cmds" + len=$func_len_result + if test "$len" -lt "$max_cmd_len" || test "$max_cmd_len" -le -1; then + cmds=$old_archive_cmds + elif test -n "$archiver_list_spec"; then + func_verbose "using command file archive linking..." + for obj in $oldobjs + do + func_to_tool_file "$obj" + $ECHO "$func_to_tool_file_result" + done > $output_objdir/$libname.libcmd + func_to_tool_file "$output_objdir/$libname.libcmd" + oldobjs=" $archiver_list_spec$func_to_tool_file_result" + cmds=$old_archive_cmds + else + # the command line is too long to link in one step, link in parts + func_verbose "using piecewise archive linking..." + save_RANLIB=$RANLIB + RANLIB=: + objlist= + concat_cmds= + save_oldobjs=$oldobjs + oldobjs= + # Is there a better way of finding the last object in the list? + for obj in $save_oldobjs + do + last_oldobj=$obj + done + eval test_cmds=\"$old_archive_cmds\" + func_len " $test_cmds" + len0=$func_len_result + len=$len0 + for obj in $save_oldobjs + do + func_len " $obj" + func_arith $len + $func_len_result + len=$func_arith_result + func_append objlist " $obj" + if test "$len" -lt "$max_cmd_len"; then + : + else + # the above command should be used before it gets too long + oldobjs=$objlist + if test "$obj" = "$last_oldobj"; then + RANLIB=$save_RANLIB + fi + test -z "$concat_cmds" || concat_cmds=$concat_cmds~ + eval concat_cmds=\"\$concat_cmds$old_archive_cmds\" + objlist= + len=$len0 + fi + done + RANLIB=$save_RANLIB + oldobjs=$objlist + if test -z "$oldobjs"; then + eval cmds=\"\$concat_cmds\" + else + eval cmds=\"\$concat_cmds~\$old_archive_cmds\" + fi + fi + fi + func_execute_cmds "$cmds" 'exit $?' + done + + test -n "$generated" && \ + func_show_eval "${RM}r$generated" + + # Now create the libtool archive. + case $output in + *.la) + old_library= + test yes = "$build_old_libs" && old_library=$libname.$libext + func_verbose "creating $output" + + # Preserve any variables that may affect compiler behavior + for var in $variables_saved_for_relink; do + if eval test -z \"\${$var+set}\"; then + relink_command="{ test -z \"\${$var+set}\" || $lt_unset $var || { $var=; export $var; }; }; $relink_command" + elif eval var_value=\$$var; test -z "$var_value"; then + relink_command="$var=; export $var; $relink_command" + else + func_quote_arg pretty,unquoted "$var_value" + relink_command="$var=$func_quote_arg_unquoted_result; export $var; $relink_command" + fi + done + # Quote the link command for shipping. + func_quote eval cd "`pwd`" + relink_command="($func_quote_result; $SHELL \"$progpath\" $preserve_args --mode=relink $libtool_args @inst_prefix_dir@)" + func_quote_arg pretty,unquoted "$relink_command" + relink_command=$func_quote_arg_unquoted_result + if test yes = "$hardcode_automatic"; then + relink_command= + fi + + # Only create the output if not a dry run. + $opt_dry_run || { + for installed in no yes; do + if test yes = "$installed"; then + if test -z "$install_libdir"; then + break + fi + output=$output_objdir/${outputname}i + # Replace all uninstalled libtool libraries with the installed ones + newdependency_libs= + for deplib in $dependency_libs; do + case $deplib in + *.la) + func_basename "$deplib" + name=$func_basename_result + func_resolve_sysroot "$deplib" + eval libdir=`$SED -n -e 's/^libdir=\(.*\)$/\1/p' $func_resolve_sysroot_result` + test -z "$libdir" && \ + func_fatal_error "'$deplib' is not a valid libtool archive" + func_append newdependency_libs " ${lt_sysroot:+=}$libdir/$name" + ;; + -L*) + func_stripname -L '' "$deplib" + func_replace_sysroot "$func_stripname_result" + func_append newdependency_libs " -L$func_replace_sysroot_result" + ;; + -R*) + func_stripname -R '' "$deplib" + func_replace_sysroot "$func_stripname_result" + func_append newdependency_libs " -R$func_replace_sysroot_result" + ;; + *) func_append newdependency_libs " $deplib" ;; + esac + done + dependency_libs=$newdependency_libs + newdlfiles= + + for lib in $dlfiles; do + case $lib in + *.la) + func_basename "$lib" + name=$func_basename_result + eval libdir=`$SED -n -e 's/^libdir=\(.*\)$/\1/p' $lib` + test -z "$libdir" && \ + func_fatal_error "'$lib' is not a valid libtool archive" + func_append newdlfiles " ${lt_sysroot:+=}$libdir/$name" + ;; + *) func_append newdlfiles " $lib" ;; + esac + done + dlfiles=$newdlfiles + newdlprefiles= + for lib in $dlprefiles; do + case $lib in + *.la) + # Only pass preopened files to the pseudo-archive (for + # eventual linking with the app. that links it) if we + # didn't already link the preopened objects directly into + # the library: + func_basename "$lib" + name=$func_basename_result + eval libdir=`$SED -n -e 's/^libdir=\(.*\)$/\1/p' $lib` + test -z "$libdir" && \ + func_fatal_error "'$lib' is not a valid libtool archive" + func_append newdlprefiles " ${lt_sysroot:+=}$libdir/$name" + ;; + esac + done + dlprefiles=$newdlprefiles + else + newdlfiles= + for lib in $dlfiles; do + case $lib in + [\\/]* | [A-Za-z]:[\\/]*) abs=$lib ;; + *) abs=`pwd`"/$lib" ;; + esac + func_append newdlfiles " $abs" + done + dlfiles=$newdlfiles + newdlprefiles= + for lib in $dlprefiles; do + case $lib in + [\\/]* | [A-Za-z]:[\\/]*) abs=$lib ;; + *) abs=`pwd`"/$lib" ;; + esac + func_append newdlprefiles " $abs" + done + dlprefiles=$newdlprefiles + fi + $RM $output + # place dlname in correct position for cygwin + # In fact, it would be nice if we could use this code for all target + # systems that can't hard-code library paths into their executables + # and that have no shared library path variable independent of PATH, + # but it turns out we can't easily determine that from inspecting + # libtool variables, so we have to hard-code the OSs to which it + # applies here; at the moment, that means platforms that use the PE + # object format with DLL files. See the long comment at the top of + # tests/bindir.at for full details. + tdlname=$dlname + case $host,$output,$installed,$module,$dlname in + *cygwin*,*lai,yes,no,*.dll | *mingw*,*lai,yes,no,*.dll | *cegcc*,*lai,yes,no,*.dll) + # If a -bindir argument was supplied, place the dll there. + if test -n "$bindir"; then + func_relative_path "$install_libdir" "$bindir" + tdlname=$func_relative_path_result/$dlname + else + # Otherwise fall back on heuristic. + tdlname=../bin/$dlname + fi + ;; + esac + $ECHO > $output "\ +# $outputname - a libtool library file +# Generated by $PROGRAM (GNU $PACKAGE) $VERSION +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# The name that we can dlopen(3). +dlname='$tdlname' + +# Names of this library. +library_names='$library_names' + +# The name of the static archive. +old_library='$old_library' + +# Linker flags that cannot go in dependency_libs. +inherited_linker_flags='$new_inherited_linker_flags' + +# Libraries that this one depends upon. +dependency_libs='$dependency_libs' + +# Names of additional weak libraries provided by this library +weak_library_names='$weak_libs' + +# Version information for $libname. +current=$current +age=$age +revision=$revision + +# Is this an already installed library? +installed=$installed + +# Should we warn about portability when linking against -modules? +shouldnotlink=$module + +# Files to dlopen/dlpreopen +dlopen='$dlfiles' +dlpreopen='$dlprefiles' + +# Directory that this library needs to be installed in: +libdir='$install_libdir'" + if test no,yes = "$installed,$need_relink"; then + $ECHO >> $output "\ +relink_command=\"$relink_command\"" + fi + done + } + + # Do a symbolic link so that the libtool archive can be found in + # LD_LIBRARY_PATH before the program is installed. + func_show_eval '( cd "$output_objdir" && $RM "$outputname" && $LN_S "../$outputname" "$outputname" )' 'exit $?' + ;; + esac + exit $EXIT_SUCCESS +} + +if test link = "$opt_mode" || test relink = "$opt_mode"; then + func_mode_link ${1+"$@"} +fi + + +# func_mode_uninstall arg... +func_mode_uninstall () +{ + $debug_cmd + + RM=$nonopt + files= + rmforce=false + exit_status=0 + + # This variable tells wrapper scripts just to set variables rather + # than running their programs. + libtool_install_magic=$magic + + for arg + do + case $arg in + -f) func_append RM " $arg"; rmforce=: ;; + -*) func_append RM " $arg" ;; + *) func_append files " $arg" ;; + esac + done + + test -z "$RM" && \ + func_fatal_help "you must specify an RM program" + + rmdirs= + + for file in $files; do + func_dirname "$file" "" "." + dir=$func_dirname_result + if test . = "$dir"; then + odir=$objdir + else + odir=$dir/$objdir + fi + func_basename "$file" + name=$func_basename_result + test uninstall = "$opt_mode" && odir=$dir + + # Remember odir for removal later, being careful to avoid duplicates + if test clean = "$opt_mode"; then + case " $rmdirs " in + *" $odir "*) ;; + *) func_append rmdirs " $odir" ;; + esac + fi + + # Don't error if the file doesn't exist and rm -f was used. + if { test -L "$file"; } >/dev/null 2>&1 || + { test -h "$file"; } >/dev/null 2>&1 || + test -f "$file"; then + : + elif test -d "$file"; then + exit_status=1 + continue + elif $rmforce; then + continue + fi + + rmfiles=$file + + case $name in + *.la) + # Possibly a libtool archive, so verify it. + if func_lalib_p "$file"; then + func_source $dir/$name + + # Delete the libtool libraries and symlinks. + for n in $library_names; do + func_append rmfiles " $odir/$n" + done + test -n "$old_library" && func_append rmfiles " $odir/$old_library" + + case $opt_mode in + clean) + case " $library_names " in + *" $dlname "*) ;; + *) test -n "$dlname" && func_append rmfiles " $odir/$dlname" ;; + esac + test -n "$libdir" && func_append rmfiles " $odir/$name $odir/${name}i" + ;; + uninstall) + if test -n "$library_names"; then + # Do each command in the postuninstall commands. + func_execute_cmds "$postuninstall_cmds" '$rmforce || exit_status=1' + fi + + if test -n "$old_library"; then + # Do each command in the old_postuninstall commands. + func_execute_cmds "$old_postuninstall_cmds" '$rmforce || exit_status=1' + fi + # FIXME: should reinstall the best remaining shared library. + ;; + esac + fi + ;; + + *.lo) + # Possibly a libtool object, so verify it. + if func_lalib_p "$file"; then + + # Read the .lo file + func_source $dir/$name + + # Add PIC object to the list of files to remove. + if test -n "$pic_object" && test none != "$pic_object"; then + func_append rmfiles " $dir/$pic_object" + fi + + # Add non-PIC object to the list of files to remove. + if test -n "$non_pic_object" && test none != "$non_pic_object"; then + func_append rmfiles " $dir/$non_pic_object" + fi + fi + ;; + + *) + if test clean = "$opt_mode"; then + noexename=$name + case $file in + *.exe) + func_stripname '' '.exe' "$file" + file=$func_stripname_result + func_stripname '' '.exe' "$name" + noexename=$func_stripname_result + # $file with .exe has already been added to rmfiles, + # add $file without .exe + func_append rmfiles " $file" + ;; + esac + # Do a test to see if this is a libtool program. + if func_ltwrapper_p "$file"; then + if func_ltwrapper_executable_p "$file"; then + func_ltwrapper_scriptname "$file" + relink_command= + func_source $func_ltwrapper_scriptname_result + func_append rmfiles " $func_ltwrapper_scriptname_result" + else + relink_command= + func_source $dir/$noexename + fi + + # note $name still contains .exe if it was in $file originally + # as does the version of $file that was added into $rmfiles + func_append rmfiles " $odir/$name $odir/${name}S.$objext" + if test yes = "$fast_install" && test -n "$relink_command"; then + func_append rmfiles " $odir/lt-$name" + fi + if test "X$noexename" != "X$name"; then + func_append rmfiles " $odir/lt-$noexename.c" + fi + fi + fi + ;; + esac + func_show_eval "$RM $rmfiles" 'exit_status=1' + done + + # Try to remove the $objdir's in the directories where we deleted files + for dir in $rmdirs; do + if test -d "$dir"; then + func_show_eval "rmdir $dir >/dev/null 2>&1" + fi + done + + exit $exit_status +} + +if test uninstall = "$opt_mode" || test clean = "$opt_mode"; then + func_mode_uninstall ${1+"$@"} +fi + +test -z "$opt_mode" && { + help=$generic_help + func_fatal_help "you must specify a MODE" +} + +test -z "$exec_cmd" && \ + func_fatal_help "invalid operation mode '$opt_mode'" + +if test -n "$exec_cmd"; then + eval exec "$exec_cmd" + exit $EXIT_FAILURE +fi + +exit $exit_status + + +# The TAGs below are defined such that we never get into a situation +# where we disable both kinds of libraries. Given conflicting +# choices, we go for a static library, that is the most portable, +# since we can't tell whether shared libraries were disabled because +# the user asked for that or because the platform doesn't support +# them. This is particularly important on AIX, because we don't +# support having both static and shared libraries enabled at the same +# time on that platform, so we default to a shared-only configuration. +# If a disable-shared tag is given, we'll fallback to a static-only +# configuration. But we'll never go from static-only to shared-only. + +# ### BEGIN LIBTOOL TAG CONFIG: disable-shared +build_libtool_libs=no +build_old_libs=yes +# ### END LIBTOOL TAG CONFIG: disable-shared + +# ### BEGIN LIBTOOL TAG CONFIG: disable-static +build_old_libs=`case $build_libtool_libs in yes) echo no;; *) echo yes;; esac` +# ### END LIBTOOL TAG CONFIG: disable-static + +# Local Variables: +# mode:shell-script +# sh-indentation:2 +# End: diff --git a/3rdparty/curl-8.21.0/m4/curl-amissl.m4 b/3rdparty/curl-8.21.0/m4/curl-amissl.m4 new file mode 100644 index 0000000000..e32861e9ef --- /dev/null +++ b/3rdparty/curl-8.21.0/m4/curl-amissl.m4 @@ -0,0 +1,66 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +#*************************************************************************** + +AC_DEFUN([CURL_WITH_AMISSL], [ +AC_MSG_CHECKING([whether to enable Amiga native SSL/TLS (AmiSSL v5)]) +if test "$HAVE_PROTO_BSDSOCKET_H" = "1"; then + if test "x$OPT_AMISSL" != "xno"; then + ssl_msg= + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + #include + #include + ]],[[ + #if defined(AMISSL_CURRENT_VERSION) && defined(AMISSL_V3xx) && \ + (OPENSSL_VERSION_NUMBER >= 0x30000000L) && defined(PROTO_AMISSL_H) + return 0; + #else + #error not AmiSSL v5 / OpenSSL 3 + #endif + ]]) + ],[ + AC_MSG_RESULT([yes]) + ssl_msg="AmiSSL" + test "amissl" != "$DEFAULT_SSL_BACKEND" || VALID_DEFAULT_SSL_BACKEND=yes + AMISSL_ENABLED=1 + OPENSSL_ENABLED=1 + dnl Use AmiSSL's built-in CA bundle + check_for_ca_bundle=1 + with_ca_fallback=yes + LIBS="-lamisslstubs -lamisslauto $LIBS" + CURL_NETWORK_AND_TIME_LIBS="-lamisslstubs -lamisslauto $CURL_NETWORK_AND_TIME_LIBS" + AC_DEFINE(USE_AMISSL, 1, [if AmiSSL is in use]) + AC_DEFINE(USE_OPENSSL, 1, [if OpenSSL is in use]) + AC_CHECK_HEADERS(openssl/rsa.h openssl/crypto.h openssl/pem.h openssl/ssl.h openssl/err.h) + ],[ + AC_MSG_RESULT([no]) + ]) + test -z "$ssl_msg" || ssl_backends="${ssl_backends:+$ssl_backends, }$ssl_msg" + else + AC_MSG_RESULT(no) + fi +else + AC_MSG_RESULT(no) +fi +]) diff --git a/3rdparty/curl-8.21.0/m4/curl-apple-sectrust.m4 b/3rdparty/curl-8.21.0/m4/curl-apple-sectrust.m4 new file mode 100644 index 0000000000..c70b7ac8cd --- /dev/null +++ b/3rdparty/curl-8.21.0/m4/curl-apple-sectrust.m4 @@ -0,0 +1,61 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +#*************************************************************************** + +AC_DEFUN([CURL_WITH_APPLE_SECTRUST], [ +AC_MSG_CHECKING([whether to enable Apple OS native certificate validation]) +if test "x$OPT_APPLE_SECTRUST" = "xyes"; then + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + #include + #include + ]],[[ + #if TARGET_OS_MAC + return 0; + #else + #error Not macOS + #endif + ]]) + ],[ + build_for_apple="yes" + ],[ + build_for_apple="no" + ]) + if test "$build_for_apple" = "no"; then + AC_MSG_ERROR([Apple SecTrust can only be enabled for Apple OS targets]) + fi + if test "$OPENSSL_ENABLED" = "1" || test "$GNUTLS_ENABLED" = "1"; then + AC_MSG_RESULT(yes) + AC_DEFINE(USE_APPLE_SECTRUST, 1, [enable Apple OS certificate validation]) + APPLE_SECTRUST_ENABLED=1 + APPLE_SECTRUST_LDFLAGS='-framework CoreFoundation -framework CoreServices -framework Security' + LDFLAGS="$LDFLAGS $APPLE_SECTRUST_LDFLAGS" + LDFLAGSPC="$LDFLAGSPC $APPLE_SECTRUST_LDFLAGS" + else + AC_MSG_ERROR([Apple SecTrust is only supported for OpenSSL/GnuTLS builds]) + fi +else + AC_MSG_RESULT(no) +fi + +]) diff --git a/3rdparty/curl-8.21.0/m4/curl-compilers.m4 b/3rdparty/curl-8.21.0/m4/curl-compilers.m4 new file mode 100644 index 0000000000..8b7da20caa --- /dev/null +++ b/3rdparty/curl-8.21.0/m4/curl-compilers.m4 @@ -0,0 +1,1713 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +#*************************************************************************** + +dnl File version for 'aclocal' use. Keep it a single number. +dnl serial 67 + +dnl CURL_CHECK_COMPILER +dnl ------------------------------------------------- +dnl Verify if the C compiler being used is known. + +AC_DEFUN([CURL_CHECK_COMPILER], [ + + compiler_id="unknown" + compiler_ver="" + compiler_num="0" + + flags_dbg_yes="unknown" + flags_opt_all="unknown" + flags_opt_yes="unknown" + flags_opt_off="unknown" + + flags_prefer_cppflags="no" + + CURL_CHECK_COMPILER_DEC_C + CURL_CHECK_COMPILER_HPUX_C + CURL_CHECK_COMPILER_IBM_C + CURL_CHECK_COMPILER_INTEL_C + CURL_CHECK_COMPILER_CLANG + CURL_CHECK_COMPILER_GNU_C + case $host in + mips-sgi-irix*) + CURL_CHECK_COMPILER_SGI_MIPSPRO_C + CURL_CHECK_COMPILER_SGI_MIPS_C + ;; + esac + CURL_CHECK_COMPILER_SUNPRO_C + CURL_CHECK_COMPILER_TINY_C + + if test "$compiler_id" = "unknown"; then + cat <<_EOF 1>&2 +*** +*** Warning: This configure script does not have information about the +*** compiler you are using, relative to the flags required to enable or +*** disable generation of debug info, optimization options or warnings. +*** +*** Whatever settings are present in CFLAGS are used for this run. +*** +*** If you wish to help the curl project to better support your compiler +*** you can report this and the required info on the libcurl development +*** mailing list: https://lists.haxx.se/listinfo/curl-library/ +*** +_EOF + fi +]) + + +dnl CURL_CHECK_COMPILER_CLANG +dnl ------------------------------------------------- +dnl Verify if compiler being used is clang. + +AC_DEFUN([CURL_CHECK_COMPILER_CLANG], [ + AC_BEFORE([$0],[CURL_CHECK_COMPILER_GNU_C]) + AC_MSG_CHECKING([if compiler is clang]) + CURL_CHECK_DEF([__clang__], [], [silent]) + if test "$curl_cv_have_def___clang__" = "yes"; then + AC_MSG_RESULT([yes]) + AC_MSG_CHECKING([if compiler is xlclang]) + CURL_CHECK_DEF([__ibmxl__], [], [silent]) + if test "$curl_cv_have_def___ibmxl__" = "yes"; then + dnl IBM's almost-compatible clang version + AC_MSG_RESULT([yes]) + compiler_id="XLCLANG" + else + AC_MSG_RESULT([no]) + compiler_id="CLANG" + fi + AC_MSG_CHECKING([if compiler is Apple clang]) + fullclangver=`$CC -v 2>&1 | grep version` + if echo $fullclangver | grep 'Apple' >/dev/null; then + AC_MSG_RESULT([yes]) + appleclang=1 + compiler_id="APPLECLANG" + else + AC_MSG_RESULT([no]) + appleclang=0 + fi + AC_MSG_CHECKING([compiler version]) + clangver=`echo $fullclangver | grep "based on LLVM " | "$SED" 's/.*(based on LLVM \(@<:@0-9@:>@*\.@<:@0-9@:>@*\).*)/\1/'` + if test -z "$clangver"; then + clangver=`echo $fullclangver | "$SED" 's/.*version \(@<:@0-9@:>@*\.@<:@0-9@:>@*\).*/\1/'` + oldapple=0 + else + oldapple=1 + fi + clangvhi=`echo $clangver | cut -d . -f1` + clangvlo=`echo $clangver | cut -d . -f2` + compiler_ver="$clangver" + compiler_num=`(expr $clangvhi "*" 100 + $clangvlo) 2>/dev/null` + if test "$appleclang" = "1" && test "$oldapple" = "0"; then + dnl Starting with Xcode 7 / clang 3.7, Apple clang does not tell its upstream version + if test "$compiler_num" -ge '2604'; then compiler_num='2101' + elif test "$compiler_num" -ge '1700'; then compiler_num='1901' + elif test "$compiler_num" -ge '1600'; then compiler_num='1700' + elif test "$compiler_num" -ge '1500'; then compiler_num='1600' + elif test "$compiler_num" -ge '1400'; then compiler_num='1400' + elif test "$compiler_num" -ge '1301'; then compiler_num='1300' + elif test "$compiler_num" -ge '1300'; then compiler_num='1200' + elif test "$compiler_num" -ge '1200'; then compiler_num='1000' + elif test "$compiler_num" -ge '1100'; then compiler_num='800' + elif test "$compiler_num" -ge '1000'; then compiler_num='600' + elif test "$compiler_num" -ge '901'; then compiler_num='500' + elif test "$compiler_num" -ge '900'; then compiler_num='400' + elif test "$compiler_num" -ge '801'; then compiler_num='309' + elif test "$compiler_num" -ge '703'; then compiler_num='308' + else compiler_num='307' + fi + fi + AC_MSG_RESULT([clang '$compiler_num' (raw: '$fullclangver' / '$clangver')]) + flags_dbg_yes="-g" + flags_opt_all="-O -O0 -O1 -O2 -Os -O3 -O4" + flags_opt_yes="-O2" + flags_opt_off="-O0" + else + AC_MSG_RESULT([no]) + fi +]) + + +dnl CURL_CHECK_COMPILER_DEC_C +dnl ------------------------------------------------- +dnl Verify if compiler being used is DEC C. + +AC_DEFUN([CURL_CHECK_COMPILER_DEC_C], [ + AC_MSG_CHECKING([if compiler is DEC/Compaq/HP C]) + CURL_CHECK_DEF([__DECC], [], [silent]) + CURL_CHECK_DEF([__DECC_VER], [], [silent]) + if test "$curl_cv_have_def___DECC" = "yes" && + test "$curl_cv_have_def___DECC_VER" = "yes"; then + AC_MSG_RESULT([yes]) + compiler_id="DEC_C" + flags_dbg_yes="-g2" + flags_opt_all="-O -O0 -O1 -O2 -O3 -O4" + flags_opt_yes="-O1" + flags_opt_off="-O0" + else + AC_MSG_RESULT([no]) + fi +]) + + +dnl CURL_CHECK_COMPILER_GNU_C +dnl ------------------------------------------------- +dnl Verify if compiler being used is GNU C +dnl +dnl $compiler_num is set to MAJOR * 100 + MINOR for gcc less than version +dnl 7 and $MAJOR * 100 for gcc version 7 and later. +dnl +dnl Examples: +dnl Version 1.2.3 => 102 +dnl Version 2.95 => 295 +dnl Version 4.7 => 407 +dnl Version 9.2.1 => 900 +dnl +AC_DEFUN([CURL_CHECK_COMPILER_GNU_C], [ + AC_REQUIRE([CURL_CHECK_COMPILER_INTEL_C]) + AC_REQUIRE([CURL_CHECK_COMPILER_CLANG]) + AC_MSG_CHECKING([if compiler is GNU C]) + CURL_CHECK_DEF([__GNUC__], [], [silent]) + if test "$curl_cv_have_def___GNUC__" = "yes" && + test "$compiler_id" = "unknown"; then + AC_MSG_RESULT([yes]) + compiler_id="GNU_C" + AC_MSG_CHECKING([compiler version]) + dnl strip '-suffix' parts, e.g. Ubuntu Windows cross-gcc returns '10-win32' + gccver=`$CC -dumpversion | "$SED" 's/-.\{1,\}$//'` + gccvhi=`echo $gccver | cut -d . -f1` + if echo $gccver | grep -F '.' >/dev/null; then + gccvlo=`echo $gccver | cut -d . -f2` + else + gccvlo="0" + fi + compiler_ver="$gccver" + compiler_num=`(expr $gccvhi "*" 100 + $gccvlo) 2>/dev/null` + AC_MSG_RESULT([gcc '$compiler_num' (raw: '$gccver')]) + flags_dbg_yes="-g" + flags_opt_all="-O -O0 -O1 -O2 -O3 -Os -Og -Ofast" + flags_opt_yes="-O2" + flags_opt_off="-O0" + else + AC_MSG_RESULT([no]) + fi +]) + + +dnl CURL_CHECK_COMPILER_HPUX_C +dnl ------------------------------------------------- +dnl Verify if compiler being used is HP-UX C. + +AC_DEFUN([CURL_CHECK_COMPILER_HPUX_C], [ + AC_MSG_CHECKING([if compiler is HP-UX C]) + CURL_CHECK_DEF([__HP_cc], [], [silent]) + if test "$curl_cv_have_def___HP_cc" = "yes"; then + AC_MSG_RESULT([yes]) + compiler_id="HP_UX_C" + flags_dbg_yes="-g" + flags_opt_all="-O +O0 +O1 +O2 +O3 +O4" + flags_opt_yes="+O2" + flags_opt_off="+O0" + else + AC_MSG_RESULT([no]) + fi +]) + + +dnl CURL_CHECK_COMPILER_IBM_C +dnl ------------------------------------------------- +dnl Verify if compiler being used is IBM C. + +AC_DEFUN([CURL_CHECK_COMPILER_IBM_C], [ + AC_MSG_CHECKING([if compiler is IBM C]) + CURL_CHECK_DEF([__IBMC__], [], [silent]) + if test "$curl_cv_have_def___IBMC__" = "yes"; then + AC_MSG_RESULT([yes]) + compiler_id="IBM_C" + flags_dbg_yes="-g" + flags_opt_all="-O -O0 -O1 -O2 -O3 -O4 -O5" + flags_opt_all="$flags_opt_all -qnooptimize" + flags_opt_all="$flags_opt_all -qoptimize=0" + flags_opt_all="$flags_opt_all -qoptimize=1" + flags_opt_all="$flags_opt_all -qoptimize=2" + flags_opt_all="$flags_opt_all -qoptimize=3" + flags_opt_all="$flags_opt_all -qoptimize=4" + flags_opt_all="$flags_opt_all -qoptimize=5" + flags_opt_yes="-O2" + flags_opt_off="-qnooptimize" + flags_prefer_cppflags="yes" + else + AC_MSG_RESULT([no]) + fi +]) + + +dnl CURL_CHECK_COMPILER_INTEL_C +dnl ------------------------------------------------- +dnl Verify if compiler being used is Intel C. + +AC_DEFUN([CURL_CHECK_COMPILER_INTEL_C], [ + AC_BEFORE([$0],[CURL_CHECK_COMPILER_GNU_C]) + AC_MSG_CHECKING([if compiler is Intel C]) + CURL_CHECK_DEF([__INTEL_COMPILER], [], [silent]) + if test "$curl_cv_have_def___INTEL_COMPILER" = "yes"; then + AC_MSG_RESULT([yes]) + AC_MSG_CHECKING([compiler version]) + compiler_num="$curl_cv_def___INTEL_COMPILER" + compiler_ver=`echo "$compiler_num" | cut -c -2 | $SED 's/^0//'`.`echo "$compiler_num" | cut -c 3-4 | $SED 's/^0//'` + AC_MSG_RESULT([Intel C '$compiler_num']) + CURL_CHECK_DEF([__unix__], [], [silent]) + if test "$curl_cv_have_def___unix__" = "yes"; then + compiler_id="INTEL_UNIX_C" + flags_dbg_yes="-g" + flags_opt_all="-O -O0 -O1 -O2 -O3 -Os" + flags_opt_yes="-O2" + flags_opt_off="-O0" + else + compiler_id="INTEL_WINDOWS_C" + flags_dbg_yes="/Zi /Oy-" + flags_opt_all="/O /O0 /O1 /O2 /O3 /Od /Og /Og- /Oi /Oi-" + flags_opt_yes="/O2" + flags_opt_off="/Od" + fi + else + AC_MSG_RESULT([no]) + fi +]) + + +dnl CURL_CHECK_COMPILER_SGI_MIPS_C +dnl ------------------------------------------------- +dnl Verify if compiler being used is SGI MIPS C. + +AC_DEFUN([CURL_CHECK_COMPILER_SGI_MIPS_C], [ + AC_REQUIRE([CURL_CHECK_COMPILER_SGI_MIPSPRO_C]) + AC_MSG_CHECKING([if compiler is SGI MIPS C]) + CURL_CHECK_DEF([__GNUC__], [], [silent]) + CURL_CHECK_DEF([__sgi], [], [silent]) + if test "$curl_cv_have_def___GNUC__" = "no" && + test "$curl_cv_have_def___sgi" = "yes" && + test "$compiler_id" = "unknown"; then + AC_MSG_RESULT([yes]) + compiler_id="SGI_MIPS_C" + flags_dbg_yes="-g" + flags_opt_all="-O -O0 -O1 -O2 -O3 -Ofast" + flags_opt_yes="-O2" + flags_opt_off="-O0" + else + AC_MSG_RESULT([no]) + fi +]) + + +dnl CURL_CHECK_COMPILER_SGI_MIPSPRO_C +dnl ------------------------------------------------- +dnl Verify if compiler being used is SGI MIPSpro C. + +AC_DEFUN([CURL_CHECK_COMPILER_SGI_MIPSPRO_C], [ + AC_BEFORE([$0],[CURL_CHECK_COMPILER_SGI_MIPS_C]) + AC_MSG_CHECKING([if compiler is SGI MIPSpro C]) + CURL_CHECK_DEF([__GNUC__], [], [silent]) + CURL_CHECK_DEF([_COMPILER_VERSION], [], [silent]) + CURL_CHECK_DEF([_SGI_COMPILER_VERSION], [], [silent]) + if test "$curl_cv_have_def___GNUC__" = "no" && + (test "$curl_cv_have_def__SGI_COMPILER_VERSION" = "yes" || + test "$curl_cv_have_def__COMPILER_VERSION" = "yes"); then + AC_MSG_RESULT([yes]) + compiler_id="SGI_MIPSPRO_C" + flags_dbg_yes="-g" + flags_opt_all="-O -O0 -O1 -O2 -O3 -Ofast" + flags_opt_yes="-O2" + flags_opt_off="-O0" + else + AC_MSG_RESULT([no]) + fi +]) + + +dnl CURL_CHECK_COMPILER_SUNPRO_C +dnl ------------------------------------------------- +dnl Verify if compiler being used is SunPro C. + +AC_DEFUN([CURL_CHECK_COMPILER_SUNPRO_C], [ + AC_MSG_CHECKING([if compiler is SunPro C]) + CURL_CHECK_DEF([__SUNPRO_C], [], [silent]) + if test "$curl_cv_have_def___SUNPRO_C" = "yes"; then + AC_MSG_RESULT([yes]) + compiler_id="SUNPRO_C" + flags_dbg_yes="-g" + flags_opt_all="-O -xO -xO1 -xO2 -xO3 -xO4 -xO5" + flags_opt_yes="-xO2" + flags_opt_off="" + else + AC_MSG_RESULT([no]) + fi +]) + + +dnl CURL_CHECK_COMPILER_TINY_C +dnl ------------------------------------------------- +dnl Verify if compiler being used is Tiny C. + +AC_DEFUN([CURL_CHECK_COMPILER_TINY_C], [ + AC_MSG_CHECKING([if compiler is Tiny C]) + CURL_CHECK_DEF([__TINYC__], [], [silent]) + if test "$curl_cv_have_def___TINYC__" = "yes"; then + AC_MSG_RESULT([yes]) + compiler_id="TINY_C" + flags_dbg_yes="-g" + flags_opt_all="" + flags_opt_yes="" + flags_opt_off="" + else + AC_MSG_RESULT([no]) + fi +]) + +dnl CURL_CONVERT_INCLUDE_TO_ISYSTEM +dnl ------------------------------------------------- +dnl Changes standard include paths present in CFLAGS +dnl and CPPFLAGS into isystem include paths. This is +dnl done to prevent GNUC from generating warnings on +dnl headers from these locations, although on ancient +dnl GNUC versions these warnings are not silenced. + +AC_DEFUN([CURL_CONVERT_INCLUDE_TO_ISYSTEM], [ + AC_REQUIRE([CURL_SHFUNC_SQUEEZE]) + AC_REQUIRE([CURL_CHECK_COMPILER]) + AC_MSG_CHECKING([convert -I options to -isystem]) + if test "$compiler_id" = "GNU_C" || + test "$compiler_id" = "CLANG" || + test "$compiler_id" = "APPLECLANG"; then + AC_MSG_RESULT([yes]) + tmp_has_include="no" + tmp_chg_FLAGS="$CFLAGS" + for word1 in $tmp_chg_FLAGS; do + case "$word1" in + -I*) + tmp_has_include="yes" + ;; + esac + done + if test "$tmp_has_include" = "yes"; then + tmp_chg_FLAGS=`echo "$tmp_chg_FLAGS" | "$SED" 's/^-I/ -isystem /g'` + tmp_chg_FLAGS=`echo "$tmp_chg_FLAGS" | "$SED" 's/ -I/ -isystem /g'` + CFLAGS="$tmp_chg_FLAGS" + squeeze CFLAGS + fi + tmp_has_include="no" + tmp_chg_FLAGS="$CPPFLAGS" + for word1 in $tmp_chg_FLAGS; do + case "$word1" in + -I*) + tmp_has_include="yes" + ;; + esac + done + if test "$tmp_has_include" = "yes"; then + tmp_chg_FLAGS=`echo "$tmp_chg_FLAGS" | "$SED" 's/^-I/ -isystem /g'` + tmp_chg_FLAGS=`echo "$tmp_chg_FLAGS" | "$SED" 's/ -I/ -isystem /g'` + CPPFLAGS="$tmp_chg_FLAGS" + squeeze CPPFLAGS + fi + else + AC_MSG_RESULT([no]) + fi +]) + + +dnl CURL_COMPILER_WORKS_IFELSE ([ACTION-IF-WORKS], [ACTION-IF-NOT-WORKS]) +dnl ------------------------------------------------- +dnl Verify if the C compiler seems to work with the +dnl settings that are 'active' at the time the test +dnl is performed. + +AC_DEFUN([CURL_COMPILER_WORKS_IFELSE], [ + dnl compilation capability verification + tmp_compiler_works="unknown" + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + ]],[[ + int i = 1; + return i; + ]]) + ],[ + tmp_compiler_works="yes" + ],[ + tmp_compiler_works="no" + echo " " >&6 + sed 's/^/cc-fail: /' conftest.err >&6 + echo " " >&6 + ]) + dnl linking capability verification + if test "$tmp_compiler_works" = "yes"; then + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([[ + ]],[[ + int i = 1; + return i; + ]]) + ],[ + tmp_compiler_works="yes" + ],[ + tmp_compiler_works="no" + echo " " >&6 + sed 's/^/link-fail: /' conftest.err >&6 + echo " " >&6 + ]) + fi + dnl only do runtime verification when not cross-compiling + if test "$cross_compiling" != "yes" && + test "$tmp_compiler_works" = "yes"; then + CURL_RUN_IFELSE([ + AC_LANG_PROGRAM([[ + #ifdef __STDC__ + # include + #endif + ]],[[ + int i = 0; + return i; + ]]) + ],[ + tmp_compiler_works="yes" + ],[ + tmp_compiler_works="no" + echo " " >&6 + echo "run-fail: test program exited with status $ac_status" >&6 + echo " " >&6 + ]) + fi + dnl branch upon test result + if test "$tmp_compiler_works" = "yes"; then + ifelse($1,,:,[$1]) + ifelse($2,,,[else + $2]) + fi +]) + + +dnl CURL_SET_COMPILER_BASIC_OPTS +dnl ------------------------------------------------- +dnl Sets compiler specific options/flags which do not +dnl depend on configure's debug, optimize or warnings +dnl options. + +AC_DEFUN([CURL_SET_COMPILER_BASIC_OPTS], [ + AC_REQUIRE([CURL_CHECK_COMPILER]) + AC_REQUIRE([CURL_SHFUNC_SQUEEZE]) + + if test "$compiler_id" != "unknown"; then + + tmp_save_CPPFLAGS="$CPPFLAGS" + tmp_save_CFLAGS="$CFLAGS" + tmp_CPPFLAGS="" + tmp_CFLAGS="" + + case "$compiler_id" in + + CLANG|APPLECLANG) + + dnl Disable warnings for unused arguments, otherwise clang warns + dnl about compile-time arguments used during link-time, like + dnl -O and -g and -pedantic. + tmp_CFLAGS="$tmp_CFLAGS -Qunused-arguments" + tmp_CFLAGS="$tmp_CFLAGS -Werror-implicit-function-declaration" + ;; + + DEC_C) + + dnl Select strict ANSI C compiler mode + tmp_CFLAGS="$tmp_CFLAGS -std1" + dnl Turn off optimizer ANSI C aliasing rules + tmp_CFLAGS="$tmp_CFLAGS -noansi_alias" + dnl Generate warnings for missing function prototypes + tmp_CFLAGS="$tmp_CFLAGS -warnprotos" + dnl Change some warnings into fatal errors + tmp_CFLAGS="$tmp_CFLAGS -msg_fatal toofewargs,toomanyargs" + ;; + + GNU_C) + + dnl turn implicit-function-declaration warning into error, + dnl at least gcc 2.95 and later support this + if test "$compiler_num" -ge "295"; then + tmp_CFLAGS="$tmp_CFLAGS -Werror-implicit-function-declaration" + fi + ;; + + HP_UX_C) + + dnl Disallow runtime dereferencing of null pointers + tmp_CFLAGS="$tmp_CFLAGS -z" + dnl Disable some remarks + dnl #4227: padding struct with n bytes to align member + dnl #4255: padding size of struct with n bytes to alignment boundary + tmp_CFLAGS="$tmp_CFLAGS +W 4227,4255" + ;; + + IBM_C) + + dnl Ensure that compiler optimizations are always thread-safe. + tmp_CPPFLAGS="$tmp_CPPFLAGS -qthreaded" + dnl Disable type based strict aliasing optimizations, using worst + dnl case aliasing assumptions when compiling. Type based aliasing + dnl would restrict the lvalues that could be safely used to access + dnl a data object. + tmp_CPPFLAGS="$tmp_CPPFLAGS -qnoansialias" + dnl Force compiler to stop after the compilation phase, without + dnl generating an object code file when compilation has errors. + tmp_CPPFLAGS="$tmp_CPPFLAGS -qhalt=e" + ;; + + INTEL_UNIX_C) + + dnl On Unix this compiler uses gcc's header files, so + dnl we select ANSI C89 dialect plus GNU extensions. + tmp_CFLAGS="$tmp_CFLAGS -std=gnu89" + dnl Change some warnings into errors + dnl #140: too many arguments in function call + dnl #147: declaration is incompatible with 'previous one' + dnl #165: too few arguments in function call + dnl #266: function declared implicitly + tmp_CPPFLAGS="$tmp_CPPFLAGS -diag-error 140,147,165,266" + dnl Disable some remarks + dnl #279: controlling expression is constant + dnl #981: operands are evaluated in unspecified order + dnl #1025: zero extending result of unary operation + dnl #1469: "cc" clobber ignored + dnl #2259: non-pointer conversion from X to Y may lose significant bits + tmp_CPPFLAGS="$tmp_CPPFLAGS -diag-disable 279,981,1025,1469,2259" + ;; + + INTEL_WINDOWS_C) + + dnl Placeholder + tmp_CFLAGS="$tmp_CFLAGS" + ;; + + SGI_MIPS_C) + + dnl Placeholder + tmp_CFLAGS="$tmp_CFLAGS" + ;; + + SGI_MIPSPRO_C) + + dnl Placeholder + tmp_CFLAGS="$tmp_CFLAGS" + ;; + + SUNPRO_C) + + dnl Placeholder + tmp_CFLAGS="$tmp_CFLAGS" + ;; + + TINY_C) + + dnl Placeholder + tmp_CFLAGS="$tmp_CFLAGS" + ;; + + esac + + squeeze tmp_CPPFLAGS + squeeze tmp_CFLAGS + + if test -n "$tmp_CFLAGS" || test -n "$tmp_CPPFLAGS"; then + AC_MSG_CHECKING([if compiler accepts some basic options]) + CPPFLAGS="$tmp_save_CPPFLAGS $tmp_CPPFLAGS" + CFLAGS="$tmp_save_CFLAGS $tmp_CFLAGS" + squeeze CPPFLAGS + squeeze CFLAGS + CURL_COMPILER_WORKS_IFELSE([ + AC_MSG_RESULT([yes]) + AC_MSG_NOTICE([compiler options added: $tmp_CFLAGS $tmp_CPPFLAGS]) + ],[ + AC_MSG_RESULT([no]) + AC_MSG_WARN([compiler options rejected: $tmp_CFLAGS $tmp_CPPFLAGS]) + dnl restore initial settings + CPPFLAGS="$tmp_save_CPPFLAGS" + CFLAGS="$tmp_save_CFLAGS" + ]) + fi + fi +]) + + +dnl CURL_SET_COMPILER_DEBUG_OPTS +dnl ------------------------------------------------- +dnl Sets compiler specific options/flags which depend +dnl on configure's debug option. + +AC_DEFUN([CURL_SET_COMPILER_DEBUG_OPTS], [ + AC_REQUIRE([CURL_CHECK_OPTION_DEBUG]) + AC_REQUIRE([CURL_CHECK_COMPILER]) + AC_REQUIRE([CURL_SHFUNC_SQUEEZE]) + + if test "$compiler_id" != "unknown"; then + + tmp_save_CFLAGS="$CFLAGS" + tmp_save_CPPFLAGS="$CPPFLAGS" + + tmp_options="" + tmp_CFLAGS="$CFLAGS" + tmp_CPPFLAGS="$CPPFLAGS" + + if test "$want_debug" = "yes"; then + AC_MSG_CHECKING([if compiler accepts debug enabling options]) + tmp_options="$flags_dbg_yes" + fi + + if test "$flags_prefer_cppflags" = "yes"; then + CPPFLAGS="$tmp_CPPFLAGS $tmp_options" + CFLAGS="$tmp_CFLAGS" + else + CPPFLAGS="$tmp_CPPFLAGS" + CFLAGS="$tmp_CFLAGS $tmp_options" + fi + squeeze CPPFLAGS + squeeze CFLAGS + fi +]) + + +dnl CURL_SET_COMPILER_OPTIMIZE_OPTS +dnl ------------------------------------------------- +dnl Sets compiler specific options/flags which depend +dnl on configure's optimize option. + +AC_DEFUN([CURL_SET_COMPILER_OPTIMIZE_OPTS], [ + AC_REQUIRE([CURL_CHECK_OPTION_OPTIMIZE]) + AC_REQUIRE([CURL_CHECK_COMPILER]) + AC_REQUIRE([CURL_SHFUNC_SQUEEZE]) + + if test "$compiler_id" != "unknown"; then + + tmp_save_CFLAGS="$CFLAGS" + tmp_save_CPPFLAGS="$CPPFLAGS" + + tmp_options="" + tmp_CFLAGS="$CFLAGS" + tmp_CPPFLAGS="$CPPFLAGS" + honor_optimize_option="yes" + + dnl If optimization request setting has not been explicitly specified, + dnl it has been derived from the debug setting and initially assumed. + dnl This initially assumed optimizer setting are finally ignored + dnl if CFLAGS or CPPFLAGS already hold optimizer flags. This implies + dnl that an initially assumed optimizer setting might not be honored. + + if test "$want_optimize" = "assume_no" || + test "$want_optimize" = "assume_yes"; then + AC_MSG_CHECKING([if compiler optimizer assumed setting might be used]) + CURL_VAR_MATCH_IFELSE([tmp_CFLAGS],[$flags_opt_all],[ + honor_optimize_option="no" + ]) + CURL_VAR_MATCH_IFELSE([tmp_CPPFLAGS],[$flags_opt_all],[ + honor_optimize_option="no" + ]) + AC_MSG_RESULT([$honor_optimize_option]) + if test "$honor_optimize_option" = "yes"; then + if test "$want_optimize" = "assume_yes"; then + want_optimize="yes" + fi + if test "$want_optimize" = "assume_no"; then + want_optimize="no" + fi + fi + fi + + if test "$honor_optimize_option" = "yes"; then + CURL_VAR_STRIP([tmp_CFLAGS],[$flags_opt_all]) + CURL_VAR_STRIP([tmp_CPPFLAGS],[$flags_opt_all]) + if test "$want_optimize" = "yes"; then + AC_MSG_CHECKING([if compiler accepts optimizer enabling options]) + tmp_options="$flags_opt_yes" + fi + if test "$want_optimize" = "no"; then + AC_MSG_CHECKING([if compiler accepts optimizer disabling options]) + tmp_options="$flags_opt_off" + fi + if test "$flags_prefer_cppflags" = "yes"; then + CPPFLAGS="$tmp_CPPFLAGS $tmp_options" + CFLAGS="$tmp_CFLAGS" + else + CPPFLAGS="$tmp_CPPFLAGS" + CFLAGS="$tmp_CFLAGS $tmp_options" + fi + squeeze CPPFLAGS + squeeze CFLAGS + CURL_COMPILER_WORKS_IFELSE([ + AC_MSG_RESULT([yes]) + AC_MSG_NOTICE([compiler options added: $tmp_options]) + ],[ + AC_MSG_RESULT([no]) + AC_MSG_WARN([compiler options rejected: $tmp_options]) + dnl restore initial settings + CPPFLAGS="$tmp_save_CPPFLAGS" + CFLAGS="$tmp_save_CFLAGS" + ]) + fi + fi +]) + + +dnl CURL_SET_COMPILER_WARNING_OPTS +dnl ------------------------------------------------- +dnl Sets compiler options/flags which depend on +dnl configure's warnings given option. + +AC_DEFUN([CURL_SET_COMPILER_WARNING_OPTS], [ + AC_REQUIRE([CURL_CHECK_OPTION_WARNINGS]) + AC_REQUIRE([CURL_CHECK_COMPILER]) + AC_REQUIRE([CURL_SHFUNC_SQUEEZE]) + + if test "$compiler_id" != "unknown"; then + + tmp_save_CPPFLAGS="$CPPFLAGS" + tmp_save_CFLAGS="$CFLAGS" + tmp_CPPFLAGS="" + tmp_CFLAGS="" + + case "$compiler_id" in + + CLANG|APPLECLANG) + + if test "$want_warnings" = "yes"; then + if test "$compiler_num" -ge "302"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [pedantic]) + else + tmp_CFLAGS="$tmp_CFLAGS -pedantic" + fi + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [all extra]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [pointer-arith write-strings]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [shadow]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [nested-externs]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [missing-declarations]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [missing-prototypes]) + tmp_CFLAGS="$tmp_CFLAGS -Wno-long-long" + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [float-equal]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [sign-compare]) + tmp_CFLAGS="$tmp_CFLAGS -Wno-multichar" + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [undef]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [endif-labels strict-prototypes]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [declaration-after-statement]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [cast-align]) + tmp_CFLAGS="$tmp_CFLAGS -Wno-system-headers" + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [shorten-64-to-32]) + + dnl Only clang 1.1 or later + if test "$compiler_num" -ge "101"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [unused]) + fi + + dnl Only clang 2.7 or later + if test "$compiler_num" -ge "207"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [address]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [attributes]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [bad-function-cast]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [cast-qual]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [conversion]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [div-by-zero format-security]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [empty-body]) + tmp_CFLAGS="$tmp_CFLAGS -Wformat=2" + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [missing-field-initializers]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [missing-noreturn]) + tmp_CFLAGS="$tmp_CFLAGS -Wno-switch-default" + tmp_CFLAGS="$tmp_CFLAGS -Wno-switch-enum" # Not used because this basically disallows default case + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [old-style-definition]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [redundant-decls]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [type-limits]) + # CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [unused-macros]) # Not practical + # tmp_CFLAGS="$tmp_CFLAGS -Wno-error=unused-macros" + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [unreachable-code unused-parameter]) + fi + + dnl Only clang 2.8 or later + if test "$compiler_num" -ge "208"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [ignored-qualifiers]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [vla]) + fi + + dnl Only clang 2.9 or later + if test "$compiler_num" -ge "209"; then + tmp_CFLAGS="$tmp_CFLAGS -Wno-sign-conversion" + tmp_CFLAGS="$tmp_CFLAGS -Wno-padded" # Not used because we cannot change public structs + tmp_CFLAGS="$tmp_CFLAGS -Wno-used-but-marked-unused" # for typecheck-gcc.h with clang 14+, dependency headers + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [shift-sign-overflow]) + fi + + dnl Only clang 3.0 or later + if test "$compiler_num" -ge "300"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [conditional-uninitialized]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [language-extension-token]) + fi + + dnl Only clang 3.1 or later + if test "$compiler_num" -ge "301"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [format-non-iso]) + tmp_CFLAGS="$tmp_CFLAGS -Wno-covered-switch-default" # Annoying to fix or silence + tmp_CFLAGS="$tmp_CFLAGS -Wno-disabled-macro-expansion" # for std headers, and curl/curl.h (rare combos) + fi + + dnl Only clang 3.2 or later + if test "$compiler_num" -ge "302"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [enum-conversion]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [sometimes-uninitialized]) + case $host_os in + cygwin* | mingw*) + dnl skip missing-variable-declarations warnings for Cygwin and + dnl MinGW because the libtool wrapper executable causes them + ;; + *) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [missing-variable-declarations]) + ;; + esac + fi + + dnl Only clang 3.3 or later + if test "$compiler_num" -ge "303"; then + tmp_CFLAGS="$tmp_CFLAGS -Wno-documentation-unknown-command" + fi + + dnl Only clang 3.4 or later + if test "$compiler_num" -ge "304"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [header-guard]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [unused-const-variable]) + fi + + dnl Only clang 3.5 or later + if test "$compiler_num" -ge "305"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [pragmas]) + # CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [unreachable-code-break]) # Not used: Silent in "unity" builds + fi + + dnl Only clang 3.6 or later + if test "$compiler_num" -ge "306"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [double-promotion]) + fi + + dnl Only clang 3.9 or later + if test "$compiler_num" -ge "309"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [comma]) + dnl avoid the varargs warning, fixed in 4.0 + dnl https://bugs.llvm.org/show_bug.cgi?id=29140 + if test "$compiler_num" -lt "400"; then + tmp_CFLAGS="$tmp_CFLAGS -Wno-varargs" + fi + fi + + dnl clang 7 or later + if test "$compiler_num" -ge "700"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [assign-enum]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [extra-semi-stmt]) + fi + + dnl clang 10 or later + if test "$compiler_num" -ge "1000"; then + tmp_CFLAGS="$tmp_CFLAGS -Wimplicit-fallthrough" # we have silencing markup for clang 10.0 and above only + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [xor-used-as-pow]) + fi + + dnl clang 13 or later + if test "$compiler_num" -ge "1300"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [cast-function-type]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [reserved-identifier]) # Keep it before -Wno-reserved-macro-identifier + tmp_CFLAGS="$tmp_CFLAGS -Wno-reserved-macro-identifier" # Sometimes such external macros need to be set + fi + + dnl clang 16 or later + if test "$compiler_num" -ge "1600"; then + tmp_CFLAGS="$tmp_CFLAGS -Wno-unsafe-buffer-usage" + fi + + dnl clang 17 or later + if test "$compiler_num" -ge "1700"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [cast-function-type-strict]) # with Apple clang it requires 16.0 or above + fi + + dnl clang 19 or later + if test "$compiler_num" -ge "1901"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [format-signedness]) + fi + + dnl clang 20 or later + if test "$compiler_num" -ge "2001"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [array-compare]) + fi + + dnl clang 21 or later + if test "$compiler_num" -ge "2101"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [c++-hidden-decl]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [implicit-int-enum-cast]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [jump-misses-init]) + tmp_CFLAGS="$tmp_CFLAGS -Wno-implicit-void-ptr-cast" + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [tentative-definition-compat]) + if test "$curl_cv_native_windows" = "yes"; then + tmp_CFLAGS="$tmp_CFLAGS -Wno-c++-keyword" # `wchar_t` triggers it on Windows + else + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [c++-keyword]) + fi + fi + + case "$CFLAGS" in + *-std=c89*|*-std=c90*|*-std=gnu89*|*-std=gnu90*) + if test "$compiler_num" -ge "300"; then + tmp_CFLAGS="$tmp_CFLAGS -Wno-c99-extensions" # Avoid: warning: '_Bool' is a C99 extension + fi + if test "$compiler_num" -ge "309"; then + tmp_CFLAGS="$tmp_CFLAGS -Wno-comma" # Silly + fi + ;; + esac + fi + ;; + + DEC_C) + + if test "$want_warnings" = "yes"; then + dnl Select a higher warning level than default level2 + tmp_CFLAGS="$tmp_CFLAGS -msg_enable level3" + fi + ;; + + GNU_C) + + dnl Leave disabled for GCC <4.6, because they lack #pragma features to silence locally. + if test "$want_warnings" = "yes" && test "$compiler_num" -ge "406"; then + + dnl Do not enable -pedantic when cross-compiling with a gcc older + dnl than 3.0, to avoid warnings from third party system headers. + if test "$cross_compiling" != "yes" || + test "$compiler_num" -ge "300"; then + if test "$compiler_num" -ge "408"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [pedantic]) + else + tmp_CFLAGS="$tmp_CFLAGS -pedantic" + fi + fi + + dnl Set of options we believe *ALL* gcc versions support: + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [all]) + tmp_CFLAGS="$tmp_CFLAGS -W" + + dnl Only gcc 1.4 or later + if test "$compiler_num" -ge "104"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [pointer-arith write-strings]) + dnl If not cross-compiling with a gcc older than 3.0 + if test "$cross_compiling" != "yes" || + test "$compiler_num" -ge "300"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [unused shadow]) + fi + fi + + dnl Only gcc 2.7 or later + if test "$compiler_num" -ge "207"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [nested-externs]) + dnl If not cross-compiling with a gcc older than 3.0 + if test "$cross_compiling" != "yes" || + test "$compiler_num" -ge "300"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [missing-declarations]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [missing-prototypes]) + fi + fi + + dnl Only gcc 2.95 or later + if test "$compiler_num" -ge "295"; then + tmp_CFLAGS="$tmp_CFLAGS -Wno-long-long" + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [bad-function-cast]) + fi + + dnl Only gcc 2.96 or later + if test "$compiler_num" -ge "296"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [float-equal]) + tmp_CFLAGS="$tmp_CFLAGS -Wno-multichar" + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [sign-compare]) + dnl -Wundef used only if gcc is 2.96 or later since we get + dnl lots of "`_POSIX_C_SOURCE' is not defined" in system + dnl headers with gcc 2.95.4 on FreeBSD 4.9 + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [undef]) + fi + + dnl Only gcc 3.0 or later + if test "$compiler_num" -ge "300"; then + dnl -Wunreachable-code seems totally unreliable on my gcc 3.3.2 on + dnl on i686-Linux as it gives us heaps with false positives. + dnl Also, on gcc 4.0.X it is totally unbearable and complains all + dnl over making it unusable for generic purposes. Let's not use it. + tmp_CFLAGS="$tmp_CFLAGS" + fi + + dnl Only gcc 3.3 or later + if test "$compiler_num" -ge "303"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [endif-labels strict-prototypes]) + fi + + dnl Only gcc 3.4 or later + if test "$compiler_num" -ge "304"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [declaration-after-statement]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [old-style-definition]) + fi + + dnl Only gcc 4.0 or later + if test "$compiler_num" -ge "400"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [cast-qual]) + tmp_CFLAGS="$tmp_CFLAGS -Wstrict-aliasing=3" + fi + + dnl Only gcc 4.1 or later + if test "$compiler_num" -ge "401"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [attributes]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [div-by-zero format-security]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [missing-field-initializers]) + case $host in + *-*-msys*) + ;; + *) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [missing-noreturn]) # Seen to clash with libtool-generated stub code + ;; + esac + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [unreachable-code unused-parameter]) + tmp_CFLAGS="$tmp_CFLAGS -Wno-padded" # Not used because we cannot change public structs + tmp_CFLAGS="$tmp_CFLAGS -Wno-switch-default" + tmp_CFLAGS="$tmp_CFLAGS -Wno-switch-enum" # Not used because this basically disallows default case + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [pragmas]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [redundant-decls]) + # CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [unused-macros]) # Not practical + # tmp_CFLAGS="$tmp_CFLAGS -Wno-error=unused-macros" + fi + + dnl Only gcc 4.2 or later + if test "$compiler_num" -ge "402"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [cast-align]) + fi + + dnl Only gcc 4.3 or later + if test "$compiler_num" -ge "403"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [address]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [type-limits old-style-declaration]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [missing-parameter-type empty-body]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [clobbered ignored-qualifiers]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [conversion]) + tmp_CFLAGS="$tmp_CFLAGS -Wno-sign-conversion" + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [vla]) + dnl required for -Warray-bounds, included in -Wall + tmp_CFLAGS="$tmp_CFLAGS -ftree-vrp" + fi + + dnl Only gcc 4.4 or later + if test "$compiler_num" -ge "404"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [logical-op]) + fi + + dnl Only gcc 4.5 or later + if test "$compiler_num" -ge "405"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [jump-misses-init]) + dnl Only Windows targets + if test "$curl_cv_native_windows" = "yes"; then + tmp_CFLAGS="$tmp_CFLAGS -Wno-pedantic-ms-format" + fi + case $host_os in + cygwin*) + dnl Silence warning in 'lt_fatal' libtool function + tmp_CFLAGS="$tmp_CFLAGS -Wno-suggest-attribute=noreturn" + ;; + esac + fi + + dnl Only gcc 4.6 or later + if test "$compiler_num" -ge "406"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [double-promotion]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [trampolines]) + fi + + dnl only gcc 4.8 or later + if test "$compiler_num" -ge "408"; then + tmp_CFLAGS="$tmp_CFLAGS -Wformat=2" + fi + + dnl Only gcc 5 or later + if test "$compiler_num" -ge "500"; then + tmp_CFLAGS="$tmp_CFLAGS -Warray-bounds=2" + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [format-signedness]) + fi + + dnl Only gcc 6 or later + if test "$compiler_num" -ge "600"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [shift-negative-value]) + tmp_CFLAGS="$tmp_CFLAGS -Wshift-overflow=2" + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [null-dereference]) + tmp_CFLAGS="$tmp_CFLAGS -fdelete-null-pointer-checks" + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [duplicated-cond]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [unused-const-variable]) + fi + + dnl Only gcc 7 or later + if test "$compiler_num" -ge "700"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [duplicated-branches]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [restrict]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [alloc-zero]) + tmp_CFLAGS="$tmp_CFLAGS -Wformat-truncation=2" + tmp_CFLAGS="$tmp_CFLAGS -Wimplicit-fallthrough" + fi + + dnl Only gcc 10 or later + if test "$compiler_num" -ge "1000"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [arith-conversion]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [enum-conversion]) + fi + + dnl Only gcc 12 or later + if test "$compiler_num" -ge "1200"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [array-compare]) + fi + + dnl Only gcc 13 or later + if test "$compiler_num" -ge "1300"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [enum-int-mismatch]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [xor-used-as-pow]) + fi + + dnl Only gcc 15 or later + if test "$compiler_num" -ge "1500"; then + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [leading-whitespace=spaces]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [trailing-whitespace=any]) + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [unterminated-string-initialization]) + fi + fi + + dnl Do not issue warnings for code in system include paths. + if test "$compiler_num" -ge "300"; then + tmp_CFLAGS="$tmp_CFLAGS -Wno-system-headers" + else + dnl When cross-compiling with a gcc older than 3.0, disable + dnl some warnings triggered on third party system headers. + if test "$cross_compiling" = "yes"; then + if test "$compiler_num" -ge "104"; then + dnl gcc 1.4 or later + tmp_CFLAGS="$tmp_CFLAGS -Wno-unused -Wno-shadow" + fi + if test "$compiler_num" -ge "207"; then + dnl gcc 2.7 or later + tmp_CFLAGS="$tmp_CFLAGS -Wno-missing-declarations" + tmp_CFLAGS="$tmp_CFLAGS -Wno-missing-prototypes" + fi + fi + fi + if test "$compiler_num" -ge "400" && test "$compiler_num" -lt "407"; then + dnl https://gcc.gnu.org/bugzilla/show_bug.cgi?id=84685 + tmp_CFLAGS="$tmp_CFLAGS -Wno-missing-field-initializers" + fi + if test "$compiler_num" -ge "403" && test "$compiler_num" -lt "408"; then + dnl Avoid false positives + tmp_CFLAGS="$tmp_CFLAGS -Wno-type-limits" + fi + if test "$compiler_num" -ge "501" && test "$compiler_num" -lt "505"; then + dnl Avoid false positives + tmp_CFLAGS="$tmp_CFLAGS -Wno-conversion" + fi + ;; + + HP_UX_C) + + if test "$want_warnings" = "yes"; then + dnl Issue all warnings + tmp_CFLAGS="$tmp_CFLAGS +w1" + fi + ;; + + IBM_C) + + dnl Placeholder + tmp_CFLAGS="$tmp_CFLAGS" + ;; + + INTEL_UNIX_C) + + if test "$want_warnings" = "yes"; then + if test "$compiler_num" -gt "600"; then + dnl Show errors, warnings, and remarks + tmp_CPPFLAGS="$tmp_CPPFLAGS -Wall -w2" + dnl Perform extra compile-time code checking + tmp_CPPFLAGS="$tmp_CPPFLAGS -Wcheck" + dnl Warn on nested comments + tmp_CPPFLAGS="$tmp_CPPFLAGS -Wcomment" + dnl Show warnings relative to deprecated features + tmp_CPPFLAGS="$tmp_CPPFLAGS -Wdeprecated" + dnl Enable warnings for missing prototypes + tmp_CPPFLAGS="$tmp_CPPFLAGS -Wmissing-prototypes" + dnl Enable warnings for 64-bit portability issues + tmp_CPPFLAGS="$tmp_CPPFLAGS -Wp64" + dnl Enable warnings for questionable pointer arithmetic + tmp_CPPFLAGS="$tmp_CPPFLAGS -Wpointer-arith" + dnl Check for function return type issues + tmp_CPPFLAGS="$tmp_CPPFLAGS -Wreturn-type" + dnl Warn on variable declarations hiding a previous one + tmp_CPPFLAGS="$tmp_CPPFLAGS -Wshadow" + dnl Warn when a variable is used before initialized + tmp_CPPFLAGS="$tmp_CPPFLAGS -Wuninitialized" + dnl Warn if a declared function is not used + tmp_CPPFLAGS="$tmp_CPPFLAGS -Wunused-function" + fi + fi + dnl Disable using EBP register in optimizations + tmp_CFLAGS="$tmp_CFLAGS -fno-omit-frame-pointer" + dnl Disable use of ANSI C aliasing rules in optimizations + tmp_CFLAGS="$tmp_CFLAGS -fno-strict-aliasing" + dnl Value-safe optimizations on floating-point data + tmp_CFLAGS="$tmp_CFLAGS -fp-model precise" + ;; + + INTEL_WINDOWS_C) + + dnl Placeholder + tmp_CFLAGS="$tmp_CFLAGS" + ;; + + SGI_MIPS_C) + + if test "$want_warnings" = "yes"; then + dnl Perform stricter semantic and lint-like checks + tmp_CFLAGS="$tmp_CFLAGS -fullwarn" + fi + ;; + + SGI_MIPSPRO_C) + + if test "$want_warnings" = "yes"; then + dnl Perform stricter semantic and lint-like checks + tmp_CFLAGS="$tmp_CFLAGS -fullwarn" + dnl Disable some remarks + dnl #1209: controlling expression is constant + tmp_CFLAGS="$tmp_CFLAGS -woff 1209" + fi + ;; + + SUNPRO_C) + + if test "$want_warnings" = "yes"; then + dnl Perform stricter semantic and lint-like checks + tmp_CFLAGS="$tmp_CFLAGS -v" + fi + ;; + + TINY_C) + + if test "$want_warnings" = "yes"; then + dnl Activate all warnings + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [all]) + dnl Make string constants be of type const char * + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [write-strings]) + dnl Warn use of unsupported GCC features ignored by TCC + CURL_ADD_COMPILER_WARNINGS([tmp_CFLAGS], [unsupported]) + fi + ;; + + esac + + squeeze tmp_CPPFLAGS + squeeze tmp_CFLAGS + + if test -n "$tmp_CFLAGS" || test -n "$tmp_CPPFLAGS"; then + AC_MSG_CHECKING([if compiler accepts strict warning options]) + CPPFLAGS="$tmp_save_CPPFLAGS $tmp_CPPFLAGS" + CFLAGS="$tmp_save_CFLAGS $tmp_CFLAGS" + squeeze CPPFLAGS + squeeze CFLAGS + CURL_COMPILER_WORKS_IFELSE([ + AC_MSG_RESULT([yes]) + AC_MSG_NOTICE([compiler options added: $tmp_CFLAGS $tmp_CPPFLAGS]) + ],[ + AC_MSG_RESULT([no]) + AC_MSG_WARN([compiler options rejected: $tmp_CFLAGS $tmp_CPPFLAGS]) + dnl restore initial settings + CPPFLAGS="$tmp_save_CPPFLAGS" + CFLAGS="$tmp_save_CFLAGS" + ]) + fi + fi +]) + + +dnl CURL_SHFUNC_SQUEEZE +dnl ------------------------------------------------- +dnl Declares a shell function squeeze() which removes +dnl redundant whitespace out of a shell variable. + +AC_DEFUN([CURL_SHFUNC_SQUEEZE], [ +squeeze() { + _sqz_result="" + eval _sqz_input=\[$][$]1 + for _sqz_token in $_sqz_input; do + if test -z "$_sqz_result"; then + _sqz_result="$_sqz_token" + else + _sqz_result="$_sqz_result $_sqz_token" + fi + done + eval [$]1=\$_sqz_result + return 0 +} +]) + + +dnl CURL_CHECK_COMPILER_HALT_ON_ERROR +dnl ------------------------------------------------- +dnl Verifies if the compiler actually halts after the +dnl compilation phase without generating any object +dnl code file, when the source compiles with errors. + +AC_DEFUN([CURL_CHECK_COMPILER_HALT_ON_ERROR], [ + AC_MSG_CHECKING([if compiler halts on compilation errors]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + ]],[[ + #error force compilation error + ]]) + ],[ + AC_MSG_RESULT([no]) + AC_MSG_ERROR([compiler does not halt on compilation errors.]) + ],[ + AC_MSG_RESULT([yes]) + ]) +]) + + +dnl CURL_CHECK_COMPILER_ARRAY_SIZE_NEGATIVE +dnl ------------------------------------------------- +dnl Verifies if the compiler actually halts after the +dnl compilation phase without generating any object +dnl code file, when the source code tries to define a +dnl type for a constant array with negative dimension. + +AC_DEFUN([CURL_CHECK_COMPILER_ARRAY_SIZE_NEGATIVE], [ + AC_REQUIRE([CURL_CHECK_COMPILER_HALT_ON_ERROR]) + AC_MSG_CHECKING([if compiler halts on negative sized arrays]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + typedef char bad_t[sizeof(char) == sizeof(int) ? -1 : -1]; + ]],[[ + bad_t dummy; + (void)dummy; + ]]) + ],[ + AC_MSG_RESULT([no]) + AC_MSG_ERROR([compiler does not halt on negative sized arrays.]) + ],[ + AC_MSG_RESULT([yes]) + ]) +]) + + +dnl CURL_CHECK_COMPILER_STRUCT_MEMBER_SIZE +dnl ------------------------------------------------- +dnl Verifies if the compiler is capable of handling the +dnl size of a struct member, struct which is a function +dnl result, as a compilation-time condition inside the +dnl type definition of a constant array. + +AC_DEFUN([CURL_CHECK_COMPILER_STRUCT_MEMBER_SIZE], [ + AC_REQUIRE([CURL_CHECK_COMPILER_ARRAY_SIZE_NEGATIVE]) + AC_MSG_CHECKING([if compiler struct member size checking works]) + tst_compiler_check_one_works="unknown" + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + struct mystruct { + int mi; + char mc; + struct mystruct *next; + }; + struct mystruct myfunc(); + typedef char good_t1[sizeof(myfunc().mi) == sizeof(int) ? 1 : -1]; + typedef char good_t2[sizeof(myfunc().mc) == sizeof(char) ? 1 : -1]; + ]],[[ + good_t1 dummy1; + good_t2 dummy2; + (void)dummy1; + (void)dummy2; + ]]) + ],[ + tst_compiler_check_one_works="yes" + ],[ + tst_compiler_check_one_works="no" + sed 's/^/cc-src: /' conftest.$ac_ext >&6 + sed 's/^/cc-err: /' conftest.err >&6 + ]) + tst_compiler_check_two_works="unknown" + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + struct mystruct { + int mi; + char mc; + struct mystruct *next; + }; + struct mystruct myfunc(); + typedef char bad_t1[sizeof(myfunc().mi) != sizeof(int) ? 1 : -1]; + typedef char bad_t2[sizeof(myfunc().mc) != sizeof(char) ? 1 : -1]; + ]],[[ + bad_t1 dummy1; + bad_t2 dummy2; + (void)dummy1; + (void)dummy2; + ]]) + ],[ + tst_compiler_check_two_works="no" + ],[ + tst_compiler_check_two_works="yes" + ]) + if test "$tst_compiler_check_one_works" = "yes" && + test "$tst_compiler_check_two_works" = "yes"; then + AC_MSG_RESULT([yes]) + else + AC_MSG_RESULT([no]) + AC_MSG_ERROR([compiler fails struct member size checking.]) + fi +]) + + +dnl CURL_CHECK_COMPILER_SYMBOL_HIDING +dnl ------------------------------------------------- +dnl Verify if compiler supports hiding library internal symbols, setting +dnl shell variable supports_symbol_hiding value as appropriate, as well as +dnl variables symbol_hiding_CFLAGS and symbol_hiding_EXTERN when supported. + +AC_DEFUN([CURL_CHECK_COMPILER_SYMBOL_HIDING], [ + AC_REQUIRE([CURL_CHECK_COMPILER]) + AC_BEFORE([$0],[CURL_CONFIGURE_SYMBOL_HIDING]) + AC_MSG_CHECKING([if compiler supports hiding library internal symbols]) + supports_symbol_hiding="no" + symbol_hiding_CFLAGS="" + symbol_hiding_EXTERN="" + tmp_CFLAGS="" + tmp_EXTERN="" + case "$compiler_id" in + CLANG|APPLECLANG) + dnl All versions of clang support -fvisibility= + tmp_EXTERN="__attribute__((__visibility__(\"default\")))" + tmp_CFLAGS="-fvisibility=hidden" + supports_symbol_hiding="yes" + ;; + GNU_C) + dnl Only gcc 3.4 or later + if test "$compiler_num" -ge "304"; then + if $CC --help --verbose 2>/dev/null | grep fvisibility= >/dev/null; then + tmp_EXTERN="__attribute__((__visibility__(\"default\")))" + tmp_CFLAGS="-fvisibility=hidden" + supports_symbol_hiding="yes" + fi + fi + ;; + INTEL_UNIX_C) + dnl Only icc 9.0 or later + if test "$compiler_num" -ge "900"; then + if $CC --help --verbose 2>&1 | grep fvisibility= > /dev/null; then + tmp_save_CFLAGS="$CFLAGS" + CFLAGS="$CFLAGS -fvisibility=hidden" + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([[ + #include + ]],[[ + printf("icc fvisibility bug test"); + ]]) + ],[ + tmp_EXTERN="__attribute__((__visibility__(\"default\")))" + tmp_CFLAGS="-fvisibility=hidden" + supports_symbol_hiding="yes" + ]) + CFLAGS="$tmp_save_CFLAGS" + fi + fi + ;; + SUNPRO_C) + if $CC 2>&1 | grep flags >/dev/null && $CC -flags | grep xldscope= >/dev/null; then + tmp_EXTERN="__global" + tmp_CFLAGS="-xldscope=hidden" + supports_symbol_hiding="yes" + fi + ;; + esac + if test "$supports_symbol_hiding" = "yes"; then + tmp_save_CFLAGS="$CFLAGS" + CFLAGS="$tmp_save_CFLAGS $tmp_CFLAGS" + squeeze CFLAGS + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $tmp_EXTERN const char *dummy(const char *buff); + const char *dummy(const char *buff) + { + if(buff) + return ++buff; + else + return buff; + } + ]],[[ + const char *b = "example"; + const char *r = dummy(&b[0]); + if(r) + return (int)*r; + ]]) + ],[ + supports_symbol_hiding="yes" + if test -f conftest.err; then + grep 'visibility' conftest.err >/dev/null + if test "$?" -eq "0"; then + supports_symbol_hiding="no" + fi + fi + ],[ + supports_symbol_hiding="no" + echo " " >&6 + sed 's/^/cc-src: /' conftest.$ac_ext >&6 + sed 's/^/cc-err: /' conftest.err >&6 + echo " " >&6 + ]) + CFLAGS="$tmp_save_CFLAGS" + fi + if test "$supports_symbol_hiding" = "yes"; then + AC_MSG_RESULT([yes]) + symbol_hiding_CFLAGS="$tmp_CFLAGS" + symbol_hiding_EXTERN="$tmp_EXTERN" + else + AC_MSG_RESULT([no]) + fi +]) + + +dnl CURL_CHECK_COMPILER_PROTOTYPE_MISMATCH +dnl ------------------------------------------------- +dnl Verifies if the compiler actually halts after the +dnl compilation phase without generating any object +dnl code file, when the source code tries to redefine +dnl a prototype which does not match previous one. + +AC_DEFUN([CURL_CHECK_COMPILER_PROTOTYPE_MISMATCH], [ + AC_REQUIRE([CURL_CHECK_COMPILER_HALT_ON_ERROR]) + AC_MSG_CHECKING([if compiler halts on function prototype mismatch]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + #include + int rand(int n); + int rand(int n) + { + if(n) + return ++n; + else + return n; + } + ]],[[ + int i[2] ={ 0, 0 }; + int j = rand(i[0]); + if(j) + return j; + ]]) + ],[ + AC_MSG_RESULT([no]) + AC_MSG_ERROR([compiler does not halt on function prototype mismatch.]) + ],[ + AC_MSG_RESULT([yes]) + ]) +]) + + +dnl CURL_VAR_MATCH (VARNAME, VALUE) +dnl ------------------------------------------------- +dnl Verifies if shell variable VARNAME contains VALUE. +dnl Contents of variable VARNAME and VALUE are handled +dnl as whitespace separated lists of words. If at least +dnl one word of VALUE is present in VARNAME the match +dnl is considered positive, otherwise false. + +AC_DEFUN([CURL_VAR_MATCH], [ + ac_var_match_word="no" + for word1 in $[$1]; do + for word2 in [$2]; do + if test "$word1" = "$word2"; then + ac_var_match_word="yes" + fi + done + done +]) + + +dnl CURL_VAR_MATCH_IFELSE (VARNAME, VALUE, +dnl [ACTION-IF-MATCH], [ACTION-IF-NOT-MATCH]) +dnl ------------------------------------------------- +dnl This performs a CURL_VAR_MATCH check and executes +dnl first branch if the match is positive, otherwise +dnl the second branch is executed. + +AC_DEFUN([CURL_VAR_MATCH_IFELSE], [ + CURL_VAR_MATCH([$1],[$2]) + if test "$ac_var_match_word" = "yes"; then + ifelse($3,,:,[$3]) + ifelse($4,,,[else + $4]) + fi +]) + + +dnl CURL_VAR_STRIP (VARNAME, VALUE) +dnl ------------------------------------------------- +dnl Contents of variable VARNAME and VALUE are handled +dnl as whitespace separated lists of words. Each word +dnl from VALUE is removed from VARNAME when present. + +AC_DEFUN([CURL_VAR_STRIP], [ + AC_REQUIRE([CURL_SHFUNC_SQUEEZE]) + ac_var_stripped="" + for word1 in $[$1]; do + ac_var_strip_word="no" + for word2 in [$2]; do + if test "$word1" = "$word2"; then + ac_var_strip_word="yes" + fi + done + if test "$ac_var_strip_word" = "no"; then + ac_var_stripped="$ac_var_stripped $word1" + fi + done + dnl squeeze whitespace out of result + [$1]="$ac_var_stripped" + squeeze [$1] +]) + +dnl CURL_ADD_COMPILER_WARNINGS (WARNING-LIST, NEW-WARNINGS) +dnl ------------------------------------------------------- +dnl Contents of variable WARNING-LIST and NEW-WARNINGS are +dnl handled as whitespace separated lists of words. +dnl Add each compiler warning from NEW-WARNINGS that has not +dnl been disabled via CFLAGS to WARNING-LIST. + +AC_DEFUN([CURL_ADD_COMPILER_WARNINGS], [ + AC_REQUIRE([CURL_SHFUNC_SQUEEZE]) + ac_var_added_warnings="" + for warning in [$2]; do + CURL_VAR_MATCH(CFLAGS, [-Wno-$warning -W$warning]) + if test "$ac_var_match_word" = "no"; then + ac_var_added_warnings="$ac_var_added_warnings -W$warning" + fi + done + dnl squeeze whitespace out of result + [$1]="$[$1] $ac_var_added_warnings" + squeeze [$1] +]) diff --git a/3rdparty/curl-8.21.0/m4/curl-confopts.m4 b/3rdparty/curl-8.21.0/m4/curl-confopts.m4 new file mode 100644 index 0000000000..d3e1a33b6b --- /dev/null +++ b/3rdparty/curl-8.21.0/m4/curl-confopts.m4 @@ -0,0 +1,575 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +#*************************************************************************** + +dnl File version for 'aclocal' use. Keep it a single number. +dnl serial 19 + +dnl CURL_CHECK_OPTION_THREADED_RESOLVER +dnl ------------------------------------------------- +dnl Verify if configure has been invoked with option +dnl --enable-threaded-resolver or --disable-threaded-resolver, and +dnl set shell variable want_threaded_resolver as appropriate. + +AC_DEFUN([CURL_CHECK_OPTION_THREADED_RESOLVER], [ + AC_MSG_CHECKING([whether to enable the threaded resolver]) + OPT_THRES="default" + AC_ARG_ENABLE(threaded_resolver, +AS_HELP_STRING([--enable-threaded-resolver],[Enable threaded resolver]) +AS_HELP_STRING([--disable-threaded-resolver],[Disable threaded resolver]), + OPT_THRES=$enableval) + case "$OPT_THRES" in + no) + dnl --disable-threaded-resolver option used + want_threaded_resolver="no" + ;; + yes) + dnl --enable-threaded-resolver option used + want_threaded_resolver="yes" + ;; + *) + dnl configure option not specified + case $host_os in + msdos* | amiga*) + want_threaded_resolver="no" + ;; + *) + if test "$want_ares" = "yes"; then + want_threaded_resolver="no" + else + want_threaded_resolver="yes" + fi + ;; + esac + ;; + esac + AC_MSG_RESULT([$want_threaded_resolver]) +]) + +dnl CURL_CHECK_OPTION_ARES +dnl ------------------------------------------------- +dnl Verify if configure has been invoked with option +dnl --enable-ares or --disable-ares, and +dnl set shell variable want_ares as appropriate. + +AC_DEFUN([CURL_CHECK_OPTION_ARES], [ + AC_BEFORE([$0],[CURL_CHECK_LIB_ARES]) + AC_MSG_CHECKING([whether to enable c-ares for DNS lookups]) + OPT_ARES="default" + AC_ARG_ENABLE(ares, +AS_HELP_STRING([--enable-ares@<:@=PATH@:>@],[Enable c-ares for DNS lookups]) +AS_HELP_STRING([--disable-ares],[Disable c-ares for DNS lookups]), + OPT_ARES=$enableval) + case "$OPT_ARES" in + no) + dnl --disable-ares option used + want_ares="no" + ;; + default) + dnl configure option not specified + want_ares="no" + ;; + *) + dnl --enable-ares option used + want_ares="yes" + if test -n "$enableval" && test "x$enableval" != "xyes"; then + want_ares_path="$enableval" + fi + ;; + esac + AC_MSG_RESULT([$want_ares]) +]) + + +dnl CURL_CHECK_OPTION_DEBUG +dnl ------------------------------------------------- +dnl Verify if configure has been invoked with option +dnl --enable-debug or --disable-debug, and set shell +dnl variable want_debug value as appropriate. + +AC_DEFUN([CURL_CHECK_OPTION_DEBUG], [ + AC_BEFORE([$0],[CURL_CHECK_OPTION_WARNINGS]) + AC_BEFORE([$0],[XC_CHECK_PROG_CC]) + AC_MSG_CHECKING([whether to enable debug build options]) + OPT_DEBUG_BUILD="default" + AC_ARG_ENABLE(debug, +AS_HELP_STRING([--enable-debug],[Enable debug build options]) +AS_HELP_STRING([--disable-debug],[Disable debug build options]), + OPT_DEBUG_BUILD=$enableval) + case "$OPT_DEBUG_BUILD" in + no) + dnl --disable-debug option used + want_debug="no" + ;; + default) + dnl configure option not specified + want_debug="no" + ;; + *) + dnl --enable-debug option used + want_debug="yes" + ;; + esac + AC_MSG_RESULT([$want_debug]) +]) + +dnl CURL_CHECK_OPTION_OPTIMIZE +dnl ------------------------------------------------- +dnl Verify if configure has been invoked with option +dnl --enable-optimize or --disable-optimize, and set +dnl shell variable want_optimize value as appropriate. + +AC_DEFUN([CURL_CHECK_OPTION_OPTIMIZE], [ + AC_REQUIRE([CURL_CHECK_OPTION_DEBUG]) + AC_BEFORE([$0],[XC_CHECK_PROG_CC]) + AC_MSG_CHECKING([whether to enable compiler optimizer]) + OPT_COMPILER_OPTIMIZE="default" + AC_ARG_ENABLE(optimize, +AS_HELP_STRING([--enable-optimize],[Enable compiler optimizations]) +AS_HELP_STRING([--disable-optimize],[Disable compiler optimizations]), + OPT_COMPILER_OPTIMIZE=$enableval) + case "$OPT_COMPILER_OPTIMIZE" in + no) + dnl --disable-optimize option used. We handle this as a request + dnl to disable compiler optimizations if possible. If the compiler + dnl is known CFLAGS and CPPFLAGS are overridden, otherwise this + dnl can not be honored. + want_optimize="no" + AC_MSG_RESULT([no]) + ;; + default) + dnl configure's optimize option not specified. Initially we handle + dnl this as a request contrary to configure's setting for + dnl --enable-debug. IOW, initially, for debug-enabled builds this + dnl is handled as a request to disable optimizations if possible, + dnl and for debug-disabled builds this is handled initially as + dnl a request to enable optimizations if possible. Finally, if the + dnl compiler is known and CFLAGS and CPPFLAGS do not have any + dnl optimizer flag the request is honored, in any other case the + dnl request can not be honored. + dnl IOW, existing optimizer flags defined in CFLAGS or CPPFLAGS + dnl always take precedence over any initial assumption. + if test "$want_debug" = "yes"; then + want_optimize="assume_no" + AC_MSG_RESULT([(assumed) no]) + else + want_optimize="assume_yes" + AC_MSG_RESULT([(assumed) yes]) + fi + ;; + *) + dnl --enable-optimize option used. We handle this as a request + dnl to enable compiler optimizations if possible. If the compiler + dnl is known CFLAGS and CPPFLAGS are overridden, otherwise this + dnl can not be honored. + want_optimize="yes" + AC_MSG_RESULT([yes]) + ;; + esac +]) + + +dnl CURL_CHECK_OPTION_SYMBOL_HIDING +dnl ------------------------------------------------- +dnl Verify if configure has been invoked with option +dnl --enable-symbol-hiding or --disable-symbol-hiding, +dnl setting shell variable want_symbol_hiding value. + +AC_DEFUN([CURL_CHECK_OPTION_SYMBOL_HIDING], [ + AC_BEFORE([$0],[CURL_CHECK_COMPILER_SYMBOL_HIDING]) + AC_MSG_CHECKING([whether to enable hiding of library internal symbols]) + OPT_SYMBOL_HIDING="default" + AC_ARG_ENABLE(symbol-hiding, +AS_HELP_STRING([--enable-symbol-hiding],[Enable hiding of library internal symbols]) +AS_HELP_STRING([--disable-symbol-hiding],[Disable hiding of library internal symbols]), + OPT_SYMBOL_HIDING=$enableval) + case "$OPT_SYMBOL_HIDING" in + no) + dnl --disable-symbol-hiding option used. + dnl This is an indication to not attempt hiding of library internal + dnl symbols. Default symbol visibility is used, which normally + dnl exposes all library internal symbols. + want_symbol_hiding="no" + AC_MSG_RESULT([no]) + ;; + default) + dnl configure's symbol-hiding option not specified. + dnl Handle this as if --enable-symbol-hiding option was given. + want_symbol_hiding="yes" + AC_MSG_RESULT([yes]) + ;; + *) + dnl --enable-symbol-hiding option used. + dnl This is an indication to attempt hiding of library internal + dnl symbols. This is only supported on some compilers/linkers. + want_symbol_hiding="yes" + AC_MSG_RESULT([yes]) + ;; + esac +]) + + +dnl CURL_CHECK_OPTION_RT +dnl ------------------------------------------------- +dnl Verify if configure has been invoked with option +dnl --disable-rt and set shell variable dontwant_rt +dnl as appropriate. + +AC_DEFUN([CURL_CHECK_OPTION_RT], [ + AC_BEFORE([$0], [CURL_CHECK_LIB_THREADS]) + AC_MSG_CHECKING([whether to disable dependency on -lrt]) + OPT_RT="default" + AC_ARG_ENABLE(rt, +AS_HELP_STRING([--disable-rt],[disable dependency on -lrt]), + OPT_RT=$enableval) + case "$OPT_RT" in + no) + dnl --disable-rt used (reverse logic) + dontwant_rt="yes" + AC_MSG_RESULT([yes]) + ;; + default) + dnl configure option not specified (so not disabled) + dontwant_rt="no" + AC_MSG_RESULT([(assumed no)]) + ;; + *) + dnl --enable-rt option used (reverse logic) + dontwant_rt="no" + AC_MSG_RESULT([no]) + ;; + esac +]) + +dnl CURL_CHECK_OPTION_WARNINGS +dnl ------------------------------------------------- +dnl Verify if configure has been invoked with option +dnl --enable-warnings or --disable-warnings, and set +dnl shell variable want_warnings as appropriate. + +AC_DEFUN([CURL_CHECK_OPTION_WARNINGS], [ + AC_REQUIRE([CURL_CHECK_OPTION_DEBUG]) + AC_BEFORE([$0],[CURL_CHECK_OPTION_WERROR]) + AC_BEFORE([$0],[XC_CHECK_PROG_CC]) + AC_MSG_CHECKING([whether to enable strict compiler warnings]) + OPT_COMPILER_WARNINGS="default" + AC_ARG_ENABLE(warnings, +AS_HELP_STRING([--enable-warnings],[Enable strict compiler warnings]) +AS_HELP_STRING([--disable-warnings],[Disable strict compiler warnings]), + OPT_COMPILER_WARNINGS=$enableval) + case "$OPT_COMPILER_WARNINGS" in + no) + dnl --disable-warnings option used + want_warnings="no" + ;; + default) + dnl configure option not specified, so + dnl use same setting as --enable-debug + want_warnings="$want_debug" + ;; + *) + dnl --enable-warnings option used + want_warnings="yes" + ;; + esac + AC_MSG_RESULT([$want_warnings]) +]) + +dnl CURL_CHECK_OPTION_WERROR +dnl ------------------------------------------------- +dnl Verify if configure has been invoked with option +dnl --enable-werror or --disable-werror, and set +dnl shell variable want_werror as appropriate. + +AC_DEFUN([CURL_CHECK_OPTION_WERROR], [ + AC_BEFORE([$0],[CURL_CHECK_COMPILER]) + AC_MSG_CHECKING([whether to enable compiler warnings as errors]) + OPT_COMPILER_WERROR="default" + AC_ARG_ENABLE(werror, +AS_HELP_STRING([--enable-werror],[Enable compiler warnings as errors]) +AS_HELP_STRING([--disable-werror],[Disable compiler warnings as errors]), + OPT_COMPILER_WERROR=$enableval) + case "$OPT_COMPILER_WERROR" in + no) + dnl --disable-werror option used + want_werror="no" + ;; + default) + dnl configure option not specified + want_werror="no" + ;; + *) + dnl --enable-werror option used + want_werror="yes" + ;; + esac + AC_MSG_RESULT([$want_werror]) +]) + + +dnl CURL_CHECK_NONBLOCKING_SOCKET +dnl ------------------------------------------------- +dnl Check for how to set a socket into non-blocking state. + +AC_DEFUN([CURL_CHECK_NONBLOCKING_SOCKET], [ + AC_REQUIRE([CURL_CHECK_FUNC_FCNTL]) + AC_REQUIRE([CURL_CHECK_FUNC_IOCTLSOCKET]) + AC_REQUIRE([CURL_CHECK_FUNC_IOCTLSOCKET_CAMEL]) + + tst_method="unknown" + + AC_MSG_CHECKING([how to set a socket into non-blocking mode]) + if test "$curl_cv_func_fcntl_o_nonblock" = "yes"; then + tst_method="fcntl O_NONBLOCK" + elif test "$curl_cv_func_ioctl_fionbio" = "yes"; then + tst_method="ioctl FIONBIO" + elif test "$curl_cv_func_ioctlsocket_fionbio" = "yes"; then + tst_method="ioctlsocket FIONBIO" + elif test "$curl_cv_func_ioctlsocket_camel_fionbio" = "yes"; then + tst_method="IoctlSocket FIONBIO" + elif test "$curl_cv_func_setsockopt_so_nonblock" = "yes"; then + tst_method="setsockopt SO_NONBLOCK" + fi + AC_MSG_RESULT([$tst_method]) + if test "$tst_method" = "unknown"; then + AC_MSG_WARN([cannot determine non-blocking socket method.]) + fi +]) + + +dnl CURL_CONFIGURE_SYMBOL_HIDING +dnl ------------------------------------------------- +dnl Depending on --enable-symbol-hiding or --disable-symbol-hiding +dnl configure option, and compiler capability to actually honor such +dnl option, this modifies compiler flags as appropriate and also +dnl provides needed definitions for configuration and Makefile.am files. +dnl This macro should not be used until all compilation tests have +dnl been done to prevent interferences on other tests. + +AC_DEFUN([CURL_CONFIGURE_SYMBOL_HIDING], [ + AC_MSG_CHECKING([whether hiding of library internal symbols does actually happen]) + CFLAG_CURL_SYMBOL_HIDING="" + doing_symbol_hiding="no" + if test "$want_symbol_hiding" = "yes" && + test "$supports_symbol_hiding" = "yes"; then + doing_symbol_hiding="yes" + CFLAG_CURL_SYMBOL_HIDING="$symbol_hiding_CFLAGS" + AC_DEFINE_UNQUOTED(CURL_EXTERN_SYMBOL, $symbol_hiding_EXTERN, + [Definition to make a library symbol externally visible.]) + AC_MSG_RESULT([yes]) + else + AC_MSG_RESULT([no]) + fi + AM_CONDITIONAL(DOING_CURL_SYMBOL_HIDING, test "$doing_symbol_hiding" = "yes") + AC_SUBST(CFLAG_CURL_SYMBOL_HIDING) +]) + + +dnl CURL_CHECK_LIB_ARES +dnl ------------------------------------------------- +dnl When c-ares library support has been requested, performs necessary checks +dnl and adjustments needed to enable support of this library. + +AC_DEFUN([CURL_CHECK_LIB_ARES], [ + + if test "$want_ares" = "yes"; then + dnl c-ares library support has been requested + clean_CPPFLAGS="$CPPFLAGS" + clean_LDFLAGS="$LDFLAGS" + clean_LDFLAGSPC="$LDFLAGSPC" + clean_LIBS="$LIBS" + configure_runpath=`pwd` + if test -n "$want_ares_path"; then + dnl c-ares library path has been specified + ARES_PCDIR="$want_ares_path/lib/pkgconfig" + CURL_CHECK_PKGCONFIG(libcares, [$ARES_PCDIR]) + if test "$PKGCONFIG" != "no"; then + ares_LIBS=`CURL_EXPORT_PCDIR([$ARES_PCDIR]) + $PKGCONFIG --libs-only-l libcares` + ares_LDFLAGS=`CURL_EXPORT_PCDIR([$ARES_PCDIR]) + $PKGCONFIG --libs-only-L libcares` + ares_CPPFLAGS=`CURL_EXPORT_PCDIR([$ARES_PCDIR]) + $PKGCONFIG --cflags-only-I libcares` + AC_MSG_NOTICE([pkg-config: ares LIBS: "$ares_LIBS"]) + AC_MSG_NOTICE([pkg-config: ares LDFLAGS: "$ares_LDFLAGS"]) + AC_MSG_NOTICE([pkg-config: ares CPPFLAGS: "$ares_CPPFLAGS"]) + else + dnl ... path without pkg-config + ares_CPPFLAGS="-I$want_ares_path/include" + ares_LDFLAGS="-L$want_ares_path/lib" + ares_LIBS="-lcares" + fi + else + dnl c-ares path not specified, use defaults + CURL_CHECK_PKGCONFIG(libcares) + if test "$PKGCONFIG" != "no"; then + ares_LIBS=`$PKGCONFIG --libs-only-l libcares` + ares_LDFLAGS=`$PKGCONFIG --libs-only-L libcares` + ares_CPPFLAGS=`$PKGCONFIG --cflags-only-I libcares` + AC_MSG_NOTICE([pkg-config: ares_LIBS: "$ares_LIBS"]) + AC_MSG_NOTICE([pkg-config: ares_LDFLAGS: "$ares_LDFLAGS"]) + AC_MSG_NOTICE([pkg-config: ares_CPPFLAGS: "$ares_CPPFLAGS"]) + else + ares_CPPFLAGS="" + ares_LDFLAGS="" + ares_LIBS="-lcares" + fi + fi + + CPPFLAGS="$clean_CPPFLAGS $ares_CPPFLAGS" + LDFLAGS="$clean_LDFLAGS $ares_LDFLAGS" + LDFLAGSPC="$clean_LDFLAGSPC $ares_LDFLAGS" + LIBS="$ares_LIBS $clean_LIBS" + + dnl check if c-ares new enough, 1.16.0 or newer + AC_CHECK_FUNC([ares_getaddrinfo], + [ + ],[ + AC_MSG_ERROR([c-ares library is defective or too old]) + dnl restore initial settings + CPPFLAGS="$clean_CPPFLAGS" + LDFLAGS="$clean_LDFLAGS" + LDFLAGSPC="$clean_LDFLAGSPC" + LIBS="$clean_LIBS" + dnl prevent usage + want_ares="no" + ]) + + if test "$want_ares" = "yes"; then + dnl finally c-ares is used + AC_DEFINE(USE_ARES, 1, [Define to enable c-ares support]) + USE_ARES=1 + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE libcares" + curl_res_msg="c-ares" + fi + fi +]) + +dnl CURL_CHECK_OPTION_HTTPSRR +dnl ----------------------------------------------------- +dnl Verify whether configure has been invoked with option +dnl --enable-httpsrr or --disable-httpsrr, and set +dnl shell variable want_httpsrr as appropriate. + +AC_DEFUN([CURL_CHECK_OPTION_HTTPSRR], [ + AC_MSG_CHECKING([whether to enable HTTPSRR support]) + OPT_HTTPSRR="default" + AC_ARG_ENABLE(httpsrr, +AS_HELP_STRING([--enable-httpsrr],[Enable HTTPSRR support (experimental)]) +AS_HELP_STRING([--disable-httpsrr],[Disable HTTPSRR support (experimental)]), + OPT_HTTPSRR=$enableval) + case "$OPT_HTTPSRR" in + no) + dnl --disable-httpsrr option used + want_httpsrr="no" + curl_httpsrr_msg="no (--enable-httpsrr)" + AC_MSG_RESULT([no]) + ;; + default) + dnl configure option not specified + want_httpsrr="no" + curl_httpsrr_msg="no (--enable-httpsrr)" + AC_MSG_RESULT([no]) + ;; + *) + dnl --enable-httpsrr option used + want_httpsrr="yes" + curl_httpsrr_msg="enabled" + AC_MSG_RESULT([yes]) + ;; + esac +]) + +dnl CURL_CHECK_OPTION_ECH +dnl ----------------------------------------------------- +dnl Verify whether configure has been invoked with option +dnl --enable-ech or --disable-ech, and set +dnl shell variable want_ech as appropriate. + +AC_DEFUN([CURL_CHECK_OPTION_ECH], [ + AC_MSG_CHECKING([whether to enable ECH support]) + OPT_ECH="default" + AC_ARG_ENABLE(ech, +AS_HELP_STRING([--enable-ech],[Enable ECH support (experimental)]) +AS_HELP_STRING([--disable-ech],[Disable ECH support (experimental)]), + OPT_ECH=$enableval) + case "$OPT_ECH" in + no) + dnl --disable-ech option used + want_ech="no" + curl_ech_msg="no (--enable-ech)" + AC_MSG_RESULT([no]) + ;; + default) + dnl configure option not specified + want_ech="no" + curl_ech_msg="no (--enable-ech)" + AC_MSG_RESULT([no]) + ;; + *) + dnl --enable-ech option used + want_ech="yes" + curl_ech_msg="enabled (--disable-ech)" + AC_MSG_RESULT([yes]) + ;; + esac +]) +]) + +dnl CURL_CHECK_OPTION_SSLS_EXPORT +dnl ----------------------------------------------------- +dnl Verify whether configure has been invoked with option +dnl --enable-ssl-session-export or --disable-ssl-session-export, and set +dnl shell variable want_ech as appropriate. + +AC_DEFUN([CURL_CHECK_OPTION_SSLS_EXPORT], [ + AC_MSG_CHECKING([whether to enable SSL session export support]) + OPT_SSLS_EXPORT="default" + AC_ARG_ENABLE(ssls-export, +AS_HELP_STRING([--enable-ssls-export], + [Enable SSL session export support (experimental)]) +AS_HELP_STRING([--disable-ssls-export], + [Disable SSL session export support (experimental)]), + OPT_SSLS_EXPORT=$enableval) + case "$OPT_SSLS_EXPORT" in + no) + dnl --disable-ssls-export option used + want_ssls_export="no" + curl_ssls_export_msg="no (--enable-ssls-export)" + AC_MSG_RESULT([no]) + ;; + default) + dnl configure option not specified + want_ssls_export="no" + curl_ssls_export_msg="no (--enable-ssls-export)" + AC_MSG_RESULT([no]) + ;; + *) + dnl --enable-ssls-export option used + want_ssls_export="yes" + curl_ssls_export_msg="enabled (--disable-ssls-export)" + AC_MSG_RESULT([yes]) + ;; + esac +]) +]) diff --git a/3rdparty/curl-8.21.0/m4/curl-functions.m4 b/3rdparty/curl-8.21.0/m4/curl-functions.m4 new file mode 100644 index 0000000000..3a27377016 --- /dev/null +++ b/3rdparty/curl-8.21.0/m4/curl-functions.m4 @@ -0,0 +1,4441 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +#*************************************************************************** + +dnl File version for 'aclocal' use. Keep it a single number. +dnl serial 73 + +dnl CURL_INCLUDES_ARPA_INET +dnl ------------------------------------------------- +dnl Set up variable with list of headers that must be +dnl included when arpa/inet.h is to be included. + +AC_DEFUN([CURL_INCLUDES_ARPA_INET], [ +curl_includes_arpa_inet="\ +/* includes start */ +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifdef HAVE_NETINET_IN_H +# include +#endif +#ifdef HAVE_ARPA_INET_H +# include +#endif +#ifdef _WIN32 +#include +#include +#else +#include +#endif +/* includes end */" + AC_CHECK_HEADERS( + sys/types.h netinet/in.h arpa/inet.h, + [], [], [$curl_includes_arpa_inet]) +]) + + +dnl CURL_INCLUDES_FCNTL +dnl ------------------------------------------------- +dnl Set up variable with list of headers that must be +dnl included when fcntl.h is to be included. + +AC_DEFUN([CURL_INCLUDES_FCNTL], [ +curl_includes_fcntl="\ +/* includes start */ +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifdef HAVE_UNISTD_H +# include +#endif +#ifdef HAVE_FCNTL_H +# include +#endif +/* includes end */" + AC_CHECK_HEADERS( + sys/types.h unistd.h fcntl.h, + [], [], [$curl_includes_fcntl]) +]) + + +dnl CURL_INCLUDES_IFADDRS +dnl ------------------------------------------------- +dnl Set up variable with list of headers that must be +dnl included when ifaddrs.h is to be included. + +AC_DEFUN([CURL_INCLUDES_IFADDRS], [ +curl_includes_ifaddrs="\ +/* includes start */ +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifndef _WIN32 +# include +#endif +#ifdef HAVE_NETINET_IN_H +# include +#endif +#ifdef HAVE_IFADDRS_H +# include +#endif +/* includes end */" + AC_CHECK_HEADERS( + sys/types.h netinet/in.h ifaddrs.h, + [], [], [$curl_includes_ifaddrs]) +]) + + +dnl CURL_INCLUDES_LIBGEN +dnl ------------------------------------------------- +dnl Set up variable with list of headers that must be +dnl included when libgen.h is to be included. + +AC_DEFUN([CURL_INCLUDES_LIBGEN], [ +curl_includes_libgen="\ +/* includes start */ +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifdef HAVE_LIBGEN_H +# include +#endif +/* includes end */" + AC_CHECK_HEADERS( + sys/types.h libgen.h, + [], [], [$curl_includes_libgen]) +]) + + +dnl CURL_INCLUDES_NETDB +dnl ------------------------------------------------- +dnl Set up variable with list of headers that must be +dnl included when netdb.h is to be included. + +AC_DEFUN([CURL_INCLUDES_NETDB], [ +curl_includes_netdb="\ +/* includes start */ +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifdef HAVE_NETDB_H +# include +#endif +/* includes end */" + AC_CHECK_HEADERS( + sys/types.h netdb.h, + [], [], [$curl_includes_netdb]) +]) + + +dnl CURL_INCLUDES_SETJMP +dnl ------------------------------------------------- +dnl Set up variable with list of headers that must be +dnl included when setjmp.h is to be included. + +AC_DEFUN([CURL_INCLUDES_SETJMP], [ +curl_includes_setjmp="\ +/* includes start */ +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#include +/* includes end */" + AC_CHECK_HEADERS( + sys/types.h, + [], [], [$curl_includes_setjmp]) +]) + + +dnl CURL_INCLUDES_SIGNAL +dnl ------------------------------------------------- +dnl Set up variable with list of headers that must be +dnl included when signal.h is to be included. + +AC_DEFUN([CURL_INCLUDES_SIGNAL], [ +curl_includes_signal="\ +/* includes start */ +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#include +/* includes end */" + AC_CHECK_HEADERS( + sys/types.h, + [], [], [$curl_includes_signal]) +]) + + +dnl CURL_INCLUDES_STDLIB +dnl ------------------------------------------------- +dnl Set up variable with list of headers that must be +dnl included when stdlib.h is to be included. + +AC_DEFUN([CURL_INCLUDES_STDLIB], [ +curl_includes_stdlib="\ +/* includes start */ +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#include +/* includes end */" + AC_CHECK_HEADERS( + sys/types.h, + [], [], [$curl_includes_stdlib]) +]) + + +dnl CURL_INCLUDES_STRING +dnl ------------------------------------------------- +dnl Set up variable with list of headers that must be +dnl included when string(s).h is to be included. + +AC_DEFUN([CURL_INCLUDES_STRING], [ +curl_includes_string="\ +/* includes start */ +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#include +#ifdef HAVE_STRINGS_H +# include +#endif +/* includes end */" + AC_CHECK_HEADERS( + sys/types.h strings.h, + [], [], [$curl_includes_string]) +]) + + +dnl CURL_INCLUDES_STROPTS +dnl ------------------------------------------------- +dnl Set up variable with list of headers that must be +dnl included when stropts.h is to be included. + +AC_DEFUN([CURL_INCLUDES_STROPTS], [ +curl_includes_stropts="\ +/* includes start */ +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifdef HAVE_UNISTD_H +# include +#endif +#ifndef _WIN32 +# include +#endif +#ifdef HAVE_SYS_IOCTL_H +# include +#endif +#ifdef HAVE_STROPTS_H +# include +#endif +/* includes end */" + AC_CHECK_HEADERS( + sys/types.h unistd.h sys/ioctl.h stropts.h, + [], [], [$curl_includes_stropts]) +]) + + +dnl CURL_INCLUDES_SYS_SOCKET +dnl ------------------------------------------------- +dnl Set up variable with list of headers that must be +dnl included when sys/socket.h is to be included. + +AC_DEFUN([CURL_INCLUDES_SYS_SOCKET], [ +curl_includes_sys_socket="\ +/* includes start */ +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifndef _WIN32 +# include +#endif +/* includes end */" + AC_CHECK_HEADERS( + sys/types.h, + [], [], [$curl_includes_sys_socket]) +]) + + +dnl CURL_INCLUDES_SYS_TYPES +dnl ------------------------------------------------- +dnl Set up variable with list of headers that must be +dnl included when sys/types.h is to be included. + +AC_DEFUN([CURL_INCLUDES_SYS_TYPES], [ +curl_includes_sys_types="\ +/* includes start */ +#ifdef HAVE_SYS_TYPES_H +# include +#endif +/* includes end */" + AC_CHECK_HEADERS( + sys/types.h, + [], [], [$curl_includes_sys_types]) +]) + + +dnl CURL_INCLUDES_SYS_XATTR +dnl ------------------------------------------------- +dnl Set up variable with list of headers that must be +dnl included when sys/xattr.h is to be included. + +AC_DEFUN([CURL_INCLUDES_SYS_XATTR], [ +curl_includes_sys_xattr="\ +/* includes start */ +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifdef HAVE_SYS_XATTR_H +# include +#endif +/* includes end */" + AC_CHECK_HEADERS( + sys/types.h sys/xattr.h, + [], [], [$curl_includes_sys_xattr]) +]) + +dnl CURL_INCLUDES_TIME +dnl ------------------------------------------------- +dnl Set up variable with list of headers that must be +dnl included when time.h is to be included. + +AC_DEFUN([CURL_INCLUDES_TIME], [ +curl_includes_time="\ +/* includes start */ +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#if !defined(_WIN32) || defined(__MINGW32__) +# include +#endif +#include +/* includes end */" + AC_CHECK_HEADERS( + sys/types.h, + [], [], [$curl_includes_time]) +]) + + +dnl CURL_INCLUDES_UNISTD +dnl ------------------------------------------------- +dnl Set up variable with list of headers that must be +dnl included when unistd.h is to be included. + +AC_DEFUN([CURL_INCLUDES_UNISTD], [ +curl_includes_unistd="\ +/* includes start */ +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifdef HAVE_UNISTD_H +# include +#endif +/* includes end */" + AC_CHECK_HEADERS( + sys/types.h unistd.h, + [], [], [$curl_includes_unistd]) +]) + + +dnl CURL_INCLUDES_WINSOCK2 +dnl ------------------------------------------------- +dnl Set up variable with list of headers that must be +dnl included when winsock2.h is to be included. + +AC_DEFUN([CURL_INCLUDES_WINSOCK2], [ +curl_includes_winsock2="\ +/* includes start */ +#ifdef _WIN32 +# ifndef WIN32_LEAN_AND_MEAN +# define WIN32_LEAN_AND_MEAN +# endif +# include +#endif +/* includes end */" + CURL_CHECK_NATIVE_WINDOWS +]) + + +dnl CURL_INCLUDES_WS2TCPIP +dnl ------------------------------------------------- +dnl Set up variable with list of headers that must be +dnl included when ws2tcpip.h is to be included. + +AC_DEFUN([CURL_INCLUDES_WS2TCPIP], [ +curl_includes_ws2tcpip="\ +/* includes start */ +#ifdef _WIN32 +# ifndef WIN32_LEAN_AND_MEAN +# define WIN32_LEAN_AND_MEAN +# endif +# include +# include +#endif +/* includes end */" + CURL_CHECK_NATIVE_WINDOWS +]) + + +dnl CURL_INCLUDES_BSDSOCKET +dnl ------------------------------------------------- +dnl Set up variable with list of headers that must be +dnl included when bsdsocket.h is to be included. + +AC_DEFUN([CURL_INCLUDES_BSDSOCKET], [ +curl_includes_bsdsocket="\ +/* includes start */ +#ifdef HAVE_PROTO_BSDSOCKET_H +# define __NO_NET_API +# define __USE_INLINE__ +# include +# ifdef HAVE_SYS_IOCTL_H +# include +# endif +# ifdef __amigaos4__ +struct SocketIFace *ISocket = NULL; +# else +struct Library *SocketBase = NULL; +# endif +# define select(a, b, c, d, e) WaitSelect(a, b, c, d, e, 0) +#endif +/* includes end */" + AC_CHECK_HEADERS( + proto/bsdsocket.h, + [], [], [$curl_includes_bsdsocket]) +]) + +dnl CURL_INCLUDES_NETIF +dnl ------------------------------------------------- +dnl Set up variable with list of headers that must be +dnl included when net/if.h is to be included. + +AC_DEFUN([CURL_INCLUDES_NETIF], [ +curl_includes_netif="\ +/* includes start */ +#ifdef HAVE_NET_IF_H +# include +#endif +/* includes end */" + AC_CHECK_HEADERS( + net/if.h, + [], [], [$curl_includes_netif]) +]) + + +dnl CURL_PREPROCESS_CALLCONV +dnl ------------------------------------------------- +dnl Set up variable with a preprocessor block which +dnl defines function calling convention. + +AC_DEFUN([CURL_PREPROCESS_CALLCONV], [ +curl_preprocess_callconv="\ +/* preprocess start */ +#ifdef _WIN32 +# define FUNCALLCONV __stdcall +#else +# define FUNCALLCONV +#endif +/* preprocess end */" +]) + + +dnl CURL_CHECK_FUNC_ALARM +dnl ------------------------------------------------- +dnl Verify if alarm is available, prototyped, and +dnl can be compiled. If all of these are true, and +dnl usage has not been previously disallowed with +dnl shell variable curl_disallow_alarm, then +dnl HAVE_ALARM is defined. + +AC_DEFUN([CURL_CHECK_FUNC_ALARM], [ + AC_REQUIRE([CURL_INCLUDES_UNISTD]) + + tst_links_alarm="unknown" + tst_proto_alarm="unknown" + tst_compi_alarm="unknown" + tst_allow_alarm="unknown" + + AC_MSG_CHECKING([if alarm can be linked]) + AC_LINK_IFELSE([ + AC_LANG_FUNC_LINK_TRY([alarm]) + ],[ + AC_MSG_RESULT([yes]) + tst_links_alarm="yes" + ],[ + AC_MSG_RESULT([no]) + tst_links_alarm="no" + ]) + + if test "$tst_links_alarm" = "yes"; then + AC_MSG_CHECKING([if alarm is prototyped]) + AC_EGREP_CPP([alarm],[ + $curl_includes_unistd + ],[ + AC_MSG_RESULT([yes]) + tst_proto_alarm="yes" + ],[ + AC_MSG_RESULT([no]) + tst_proto_alarm="no" + ]) + fi + + if test "$tst_proto_alarm" = "yes"; then + AC_MSG_CHECKING([if alarm is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_unistd + ]],[[ + if(alarm(0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_alarm="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_alarm="no" + ]) + fi + + if test "$tst_compi_alarm" = "yes"; then + AC_MSG_CHECKING([if alarm usage allowed]) + if test "x$curl_disallow_alarm" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_alarm="yes" + else + AC_MSG_RESULT([no]) + tst_allow_alarm="no" + fi + fi + + AC_MSG_CHECKING([if alarm might be used]) + if test "$tst_links_alarm" = "yes" && + test "$tst_proto_alarm" = "yes" && + test "$tst_compi_alarm" = "yes" && + test "$tst_allow_alarm" = "yes"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_ALARM, 1, + [Define to 1 if you have the alarm function.]) + curl_cv_func_alarm="yes" + else + AC_MSG_RESULT([no]) + curl_cv_func_alarm="no" + fi +]) + + +dnl CURL_CHECK_FUNC_BASENAME +dnl ------------------------------------------------- +dnl Verify if basename is available, prototyped, and +dnl can be compiled. If all of these are true, and +dnl usage has not been previously disallowed with +dnl shell variable curl_disallow_basename, then +dnl HAVE_BASENAME is defined. + +AC_DEFUN([CURL_CHECK_FUNC_BASENAME], [ + AC_REQUIRE([CURL_INCLUDES_STRING]) + AC_REQUIRE([CURL_INCLUDES_LIBGEN]) + AC_REQUIRE([CURL_INCLUDES_UNISTD]) + + tst_links_basename="unknown" + tst_proto_basename="unknown" + tst_compi_basename="unknown" + tst_allow_basename="unknown" + + AC_MSG_CHECKING([if basename can be linked]) + AC_LINK_IFELSE([ + AC_LANG_FUNC_LINK_TRY([basename]) + ],[ + AC_MSG_RESULT([yes]) + tst_links_basename="yes" + ],[ + AC_MSG_RESULT([no]) + tst_links_basename="no" + ]) + + if test "$tst_links_basename" = "yes"; then + AC_MSG_CHECKING([if basename is prototyped]) + AC_EGREP_CPP([basename],[ + $curl_includes_string + $curl_includes_libgen + $curl_includes_unistd + ],[ + AC_MSG_RESULT([yes]) + tst_proto_basename="yes" + ],[ + AC_MSG_RESULT([no]) + tst_proto_basename="no" + ]) + fi + + if test "$tst_proto_basename" = "yes"; then + AC_MSG_CHECKING([if basename is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_string + $curl_includes_libgen + $curl_includes_unistd + ]],[[ + if(basename(0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_basename="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_basename="no" + ]) + fi + + if test "$tst_compi_basename" = "yes"; then + AC_MSG_CHECKING([if basename usage allowed]) + if test "x$curl_disallow_basename" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_basename="yes" + else + AC_MSG_RESULT([no]) + tst_allow_basename="no" + fi + fi + + AC_MSG_CHECKING([if basename might be used]) + if test "$tst_links_basename" = "yes" && + test "$tst_proto_basename" = "yes" && + test "$tst_compi_basename" = "yes" && + test "$tst_allow_basename" = "yes"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_BASENAME, 1, + [Define to 1 if you have the basename function.]) + curl_cv_func_basename="yes" + else + AC_MSG_RESULT([no]) + curl_cv_func_basename="no" + fi +]) + + +dnl CURL_CHECK_FUNC_CLOSESOCKET +dnl ------------------------------------------------- +dnl Verify if closesocket is available, prototyped, and +dnl can be compiled. If all of these are true, and +dnl usage has not been previously disallowed with +dnl shell variable curl_disallow_closesocket, then +dnl HAVE_CLOSESOCKET is defined. + +AC_DEFUN([CURL_CHECK_FUNC_CLOSESOCKET], [ + AC_REQUIRE([CURL_INCLUDES_WINSOCK2]) + + tst_links_closesocket="unknown" + tst_proto_closesocket="unknown" + tst_compi_closesocket="unknown" + tst_allow_closesocket="unknown" + + AC_MSG_CHECKING([if closesocket can be linked]) + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_winsock2 + ]],[[ + if(closesocket(0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_links_closesocket="yes" + ],[ + AC_MSG_RESULT([no]) + tst_links_closesocket="no" + ]) + + if test "$tst_links_closesocket" = "yes"; then + AC_MSG_CHECKING([if closesocket is prototyped]) + AC_EGREP_CPP([closesocket],[ + $curl_includes_winsock2 + ],[ + AC_MSG_RESULT([yes]) + tst_proto_closesocket="yes" + ],[ + AC_MSG_RESULT([no]) + tst_proto_closesocket="no" + ]) + fi + + if test "$tst_proto_closesocket" = "yes"; then + AC_MSG_CHECKING([if closesocket is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_winsock2 + ]],[[ + if(closesocket(0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_closesocket="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_closesocket="no" + ]) + fi + + if test "$tst_compi_closesocket" = "yes"; then + AC_MSG_CHECKING([if closesocket usage allowed]) + if test "x$curl_disallow_closesocket" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_closesocket="yes" + else + AC_MSG_RESULT([no]) + tst_allow_closesocket="no" + fi + fi + + AC_MSG_CHECKING([if closesocket might be used]) + if test "$tst_links_closesocket" = "yes" && + test "$tst_proto_closesocket" = "yes" && + test "$tst_compi_closesocket" = "yes" && + test "$tst_allow_closesocket" = "yes"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_CLOSESOCKET, 1, + [Define to 1 if you have the closesocket function.]) + curl_cv_func_closesocket="yes" + else + AC_MSG_RESULT([no]) + curl_cv_func_closesocket="no" + fi +]) + + +dnl CURL_CHECK_FUNC_CLOSESOCKET_CAMEL +dnl ------------------------------------------------- +dnl Verify if CloseSocket is available, prototyped, and +dnl can be compiled. If all of these are true, and +dnl usage has not been previously disallowed with +dnl shell variable curl_disallow_closesocket_camel, +dnl then HAVE_CLOSESOCKET_CAMEL is defined. + +AC_DEFUN([CURL_CHECK_FUNC_CLOSESOCKET_CAMEL], [ + AC_REQUIRE([CURL_INCLUDES_SYS_SOCKET]) + AC_REQUIRE([CURL_INCLUDES_BSDSOCKET]) + + tst_links_closesocket_camel="unknown" + tst_compi_closesocket_camel="unknown" + tst_allow_closesocket_camel="unknown" + + AC_MSG_CHECKING([if CloseSocket can be linked]) + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_bsdsocket + $curl_includes_sys_socket + ]],[[ + if(CloseSocket(0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_links_closesocket_camel="yes" + ],[ + AC_MSG_RESULT([no]) + tst_links_closesocket_camel="no" + ]) + + if test "$tst_links_closesocket_camel" = "yes"; then + AC_MSG_CHECKING([if CloseSocket is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_bsdsocket + $curl_includes_sys_socket + ]],[[ + if(CloseSocket(0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_closesocket_camel="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_closesocket_camel="no" + ]) + fi + + if test "$tst_compi_closesocket_camel" = "yes"; then + AC_MSG_CHECKING([if CloseSocket usage allowed]) + if test "x$curl_disallow_closesocket_camel" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_closesocket_camel="yes" + else + AC_MSG_RESULT([no]) + tst_allow_closesocket_camel="no" + fi + fi + + AC_MSG_CHECKING([if CloseSocket might be used]) + if test "$tst_links_closesocket_camel" = "yes" && + test "$tst_compi_closesocket_camel" = "yes" && + test "$tst_allow_closesocket_camel" = "yes"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_CLOSESOCKET_CAMEL, 1, + [Define to 1 if you have the CloseSocket camel case function.]) + curl_cv_func_closesocket_camel="yes" + else + AC_MSG_RESULT([no]) + curl_cv_func_closesocket_camel="no" + fi +]) + +dnl CURL_CHECK_FUNC_FCNTL +dnl ------------------------------------------------- +dnl Verify if fcntl is available, prototyped, and +dnl can be compiled. If all of these are true, and +dnl usage has not been previously disallowed with +dnl shell variable curl_disallow_fcntl, then +dnl HAVE_FCNTL is defined. + +AC_DEFUN([CURL_CHECK_FUNC_FCNTL], [ + AC_REQUIRE([CURL_INCLUDES_FCNTL]) + + tst_links_fcntl="unknown" + tst_proto_fcntl="unknown" + tst_compi_fcntl="unknown" + tst_allow_fcntl="unknown" + + AC_MSG_CHECKING([if fcntl can be linked]) + AC_LINK_IFELSE([ + AC_LANG_FUNC_LINK_TRY([fcntl]) + ],[ + AC_MSG_RESULT([yes]) + tst_links_fcntl="yes" + ],[ + AC_MSG_RESULT([no]) + tst_links_fcntl="no" + ]) + + if test "$tst_links_fcntl" = "yes"; then + AC_MSG_CHECKING([if fcntl is prototyped]) + AC_EGREP_CPP([fcntl],[ + $curl_includes_fcntl + ],[ + AC_MSG_RESULT([yes]) + tst_proto_fcntl="yes" + ],[ + AC_MSG_RESULT([no]) + tst_proto_fcntl="no" + ]) + fi + + if test "$tst_proto_fcntl" = "yes"; then + AC_MSG_CHECKING([if fcntl is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_fcntl + ]],[[ + if(fcntl(0, 0, 0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_fcntl="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_fcntl="no" + ]) + fi + + if test "$tst_compi_fcntl" = "yes"; then + AC_MSG_CHECKING([if fcntl usage allowed]) + if test "x$curl_disallow_fcntl" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_fcntl="yes" + else + AC_MSG_RESULT([no]) + tst_allow_fcntl="no" + fi + fi + + AC_MSG_CHECKING([if fcntl might be used]) + if test "$tst_links_fcntl" = "yes" && + test "$tst_proto_fcntl" = "yes" && + test "$tst_compi_fcntl" = "yes" && + test "$tst_allow_fcntl" = "yes"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_FCNTL, 1, + [Define to 1 if you have the fcntl function.]) + curl_cv_func_fcntl="yes" + CURL_CHECK_FUNC_FCNTL_O_NONBLOCK + else + AC_MSG_RESULT([no]) + curl_cv_func_fcntl="no" + fi +]) + + +dnl CURL_CHECK_FUNC_FCNTL_O_NONBLOCK +dnl ------------------------------------------------- +dnl Verify if fcntl with status flag O_NONBLOCK is +dnl available, can be compiled, and seems to work. If +dnl all of these are true, then HAVE_FCNTL_O_NONBLOCK +dnl is defined. + +AC_DEFUN([CURL_CHECK_FUNC_FCNTL_O_NONBLOCK], [ + + tst_compi_fcntl_o_nonblock="unknown" + tst_allow_fcntl_o_nonblock="unknown" + + case $host_os in + sunos4* | aix3*) + dnl O_NONBLOCK does not work on these platforms + curl_disallow_fcntl_o_nonblock="yes" + ;; + esac + + if test "$curl_cv_func_fcntl" = "yes"; then + AC_MSG_CHECKING([if fcntl O_NONBLOCK is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_fcntl + ]],[[ + int flags = 0; + if(fcntl(0, F_SETFL, flags | O_NONBLOCK)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_fcntl_o_nonblock="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_fcntl_o_nonblock="no" + ]) + fi + + if test "$tst_compi_fcntl_o_nonblock" = "yes"; then + AC_MSG_CHECKING([if fcntl O_NONBLOCK usage allowed]) + if test "x$curl_disallow_fcntl_o_nonblock" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_fcntl_o_nonblock="yes" + else + AC_MSG_RESULT([no]) + tst_allow_fcntl_o_nonblock="no" + fi + fi + + AC_MSG_CHECKING([if fcntl O_NONBLOCK might be used]) + if test "$tst_compi_fcntl_o_nonblock" = "yes" && + test "$tst_allow_fcntl_o_nonblock" = "yes"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_FCNTL_O_NONBLOCK, 1, + [Define to 1 if you have a working fcntl O_NONBLOCK function.]) + curl_cv_func_fcntl_o_nonblock="yes" + else + AC_MSG_RESULT([no]) + curl_cv_func_fcntl_o_nonblock="no" + fi +]) + + +dnl CURL_CHECK_FUNC_FREEADDRINFO +dnl ------------------------------------------------- +dnl Verify if freeaddrinfo is available, prototyped, +dnl and can be compiled. If all of these are true, +dnl and usage has not been previously disallowed with +dnl shell variable curl_disallow_freeaddrinfo, then +dnl HAVE_FREEADDRINFO is defined. + +AC_DEFUN([CURL_CHECK_FUNC_FREEADDRINFO], [ + AC_REQUIRE([CURL_INCLUDES_WS2TCPIP]) + AC_REQUIRE([CURL_INCLUDES_SYS_SOCKET]) + AC_REQUIRE([CURL_INCLUDES_NETDB]) + + tst_links_freeaddrinfo="unknown" + tst_proto_freeaddrinfo="unknown" + tst_compi_freeaddrinfo="unknown" + tst_allow_freeaddrinfo="unknown" + + AC_MSG_CHECKING([if freeaddrinfo can be linked]) + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_ws2tcpip + $curl_includes_sys_socket + $curl_includes_netdb + ]],[[ + freeaddrinfo(0); + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_links_freeaddrinfo="yes" + ],[ + AC_MSG_RESULT([no]) + tst_links_freeaddrinfo="no" + ]) + + if test "$tst_links_freeaddrinfo" = "yes"; then + AC_MSG_CHECKING([if freeaddrinfo is prototyped]) + AC_EGREP_CPP([freeaddrinfo],[ + $curl_includes_ws2tcpip + $curl_includes_sys_socket + $curl_includes_netdb + ],[ + AC_MSG_RESULT([yes]) + tst_proto_freeaddrinfo="yes" + ],[ + AC_MSG_RESULT([no]) + tst_proto_freeaddrinfo="no" + ]) + fi + + if test "$tst_proto_freeaddrinfo" = "yes"; then + AC_MSG_CHECKING([if freeaddrinfo is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_ws2tcpip + $curl_includes_sys_socket + $curl_includes_netdb + ]],[[ + freeaddrinfo(0); + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_freeaddrinfo="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_freeaddrinfo="no" + ]) + fi + + if test "$tst_compi_freeaddrinfo" = "yes"; then + AC_MSG_CHECKING([if freeaddrinfo usage allowed]) + if test "x$curl_disallow_freeaddrinfo" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_freeaddrinfo="yes" + else + AC_MSG_RESULT([no]) + tst_allow_freeaddrinfo="no" + fi + fi + + AC_MSG_CHECKING([if freeaddrinfo might be used]) + if test "$tst_links_freeaddrinfo" = "yes" && + test "$tst_proto_freeaddrinfo" = "yes" && + test "$tst_compi_freeaddrinfo" = "yes" && + test "$tst_allow_freeaddrinfo" = "yes"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_FREEADDRINFO, 1, + [Define to 1 if you have the freeaddrinfo function.]) + curl_cv_func_freeaddrinfo="yes" + else + AC_MSG_RESULT([no]) + curl_cv_func_freeaddrinfo="no" + fi +]) + + +dnl CURL_CHECK_FUNC_FSETXATTR +dnl ------------------------------------------------- +dnl Verify if fsetxattr is available, prototyped, and +dnl can be compiled. If all of these are true, and +dnl usage has not been previously disallowed with +dnl shell variable curl_disallow_fsetxattr, then +dnl HAVE_FSETXATTR is defined. + +AC_DEFUN([CURL_CHECK_FUNC_FSETXATTR], [ + AC_REQUIRE([CURL_INCLUDES_SYS_XATTR]) + + tst_links_fsetxattr="unknown" + tst_proto_fsetxattr="unknown" + tst_compi_fsetxattr="unknown" + tst_allow_fsetxattr="unknown" + tst_nargs_fsetxattr="unknown" + + AC_MSG_CHECKING([if fsetxattr can be linked]) + AC_LINK_IFELSE([ + AC_LANG_FUNC_LINK_TRY([fsetxattr]) + ],[ + AC_MSG_RESULT([yes]) + tst_links_fsetxattr="yes" + ],[ + AC_MSG_RESULT([no]) + tst_links_fsetxattr="no" + ]) + + if test "$tst_links_fsetxattr" = "yes"; then + AC_MSG_CHECKING([if fsetxattr is prototyped]) + AC_EGREP_CPP([fsetxattr],[ + $curl_includes_sys_xattr + ],[ + AC_MSG_RESULT([yes]) + tst_proto_fsetxattr="yes" + ],[ + AC_MSG_RESULT([no]) + tst_proto_fsetxattr="no" + ]) + fi + + if test "$tst_proto_fsetxattr" = "yes"; then + if test "$tst_nargs_fsetxattr" = "unknown"; then + AC_MSG_CHECKING([if fsetxattr takes 5 args.]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_sys_xattr + ]],[[ + if(fsetxattr(0, "", 0, 0, 0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_fsetxattr="yes" + tst_nargs_fsetxattr="5" + ],[ + AC_MSG_RESULT([no]) + tst_compi_fsetxattr="no" + ]) + fi + if test "$tst_nargs_fsetxattr" = "unknown"; then + AC_MSG_CHECKING([if fsetxattr takes 6 args.]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_sys_xattr + ]],[[ + if(fsetxattr(0, 0, 0, 0, 0, 0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_fsetxattr="yes" + tst_nargs_fsetxattr="6" + ],[ + AC_MSG_RESULT([no]) + tst_compi_fsetxattr="no" + ]) + fi + AC_MSG_CHECKING([if fsetxattr is compilable]) + if test "$tst_compi_fsetxattr" = "yes"; then + AC_MSG_RESULT([yes]) + else + AC_MSG_RESULT([no]) + fi + fi + + if test "$tst_compi_fsetxattr" = "yes"; then + AC_MSG_CHECKING([if fsetxattr usage allowed]) + if test "x$curl_disallow_fsetxattr" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_fsetxattr="yes" + else + AC_MSG_RESULT([no]) + tst_allow_fsetxattr="no" + fi + fi + + AC_MSG_CHECKING([if fsetxattr might be used]) + if test "$tst_links_fsetxattr" = "yes" && + test "$tst_proto_fsetxattr" = "yes" && + test "$tst_compi_fsetxattr" = "yes" && + test "$tst_allow_fsetxattr" = "yes"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_FSETXATTR, 1, + [Define to 1 if you have the fsetxattr function.]) + dnl AC_DEFINE_UNQUOTED(FSETXATTR_ARGS, $tst_nargs_fsetxattr, + dnl [Specifies the number of arguments to fsetxattr]) + + if test "$tst_nargs_fsetxattr" -eq "5"; then + AC_DEFINE(HAVE_FSETXATTR_5, 1, [fsetxattr() takes 5 args]) + elif test "$tst_nargs_fsetxattr" -eq "6"; then + AC_DEFINE(HAVE_FSETXATTR_6, 1, [fsetxattr() takes 6 args]) + fi + + curl_cv_func_fsetxattr="yes" + else + AC_MSG_RESULT([no]) + curl_cv_func_fsetxattr="no" + fi +]) + + +dnl CURL_CHECK_FUNC_GETADDRINFO +dnl ------------------------------------------------- +dnl Verify if getaddrinfo is available, prototyped, can +dnl be compiled and seems to work. If all of these are +dnl true, and usage has not been previously disallowed +dnl with shell variable curl_disallow_getaddrinfo, then +dnl HAVE_GETADDRINFO is defined. Additionally when +dnl HAVE_GETADDRINFO gets defined this also attempts +dnl to find out if getaddrinfo happens to be thread-safe, +dnl defining HAVE_GETADDRINFO_THREADSAFE when true. + +AC_DEFUN([CURL_CHECK_FUNC_GETADDRINFO], [ + AC_REQUIRE([CURL_INCLUDES_WS2TCPIP]) + AC_REQUIRE([CURL_INCLUDES_STDLIB]) + AC_REQUIRE([CURL_INCLUDES_STRING]) + AC_REQUIRE([CURL_INCLUDES_SYS_SOCKET]) + AC_REQUIRE([CURL_INCLUDES_NETDB]) + AC_REQUIRE([CURL_CHECK_NATIVE_WINDOWS]) + + tst_links_getaddrinfo="unknown" + tst_proto_getaddrinfo="unknown" + tst_compi_getaddrinfo="unknown" + tst_works_getaddrinfo="unknown" + tst_allow_getaddrinfo="unknown" + tst_tsafe_getaddrinfo="unknown" + + AC_MSG_CHECKING([if getaddrinfo can be linked]) + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_ws2tcpip + $curl_includes_sys_socket + $curl_includes_netdb + ]],[[ + struct addrinfo *ai = 0; + if(getaddrinfo(0, 0, 0, &ai)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_links_getaddrinfo="yes" + ],[ + AC_MSG_RESULT([no]) + tst_links_getaddrinfo="no" + ]) + + if test "$tst_links_getaddrinfo" = "yes"; then + AC_MSG_CHECKING([if getaddrinfo is prototyped]) + AC_EGREP_CPP([getaddrinfo],[ + $curl_includes_ws2tcpip + $curl_includes_sys_socket + $curl_includes_netdb + ],[ + AC_MSG_RESULT([yes]) + tst_proto_getaddrinfo="yes" + ],[ + AC_MSG_RESULT([no]) + tst_proto_getaddrinfo="no" + ]) + fi + + if test "$tst_proto_getaddrinfo" = "yes"; then + AC_MSG_CHECKING([if getaddrinfo is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_ws2tcpip + $curl_includes_sys_socket + $curl_includes_netdb + ]],[[ + struct addrinfo *ai = 0; + if(getaddrinfo(0, 0, 0, &ai)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_getaddrinfo="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_getaddrinfo="no" + ]) + fi + + dnl only do runtime verification when not cross-compiling + if test "$cross_compiling" != "yes" && + test "$tst_compi_getaddrinfo" = "yes"; then + AC_MSG_CHECKING([if getaddrinfo seems to work]) + CURL_RUN_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_ws2tcpip + $curl_includes_stdlib + $curl_includes_string + $curl_includes_sys_socket + $curl_includes_netdb + ]],[[ + struct addrinfo hints; + struct addrinfo *ai = 0; + int error; + int exitcode; + + #ifdef _WIN32 + WSADATA wsa; + if(WSAStartup(MAKEWORD(2, 2), &wsa)) + return 2; + #endif + + memset(&hints, 0, sizeof(hints)); + hints.ai_flags = AI_NUMERICHOST; + hints.ai_family = AF_UNSPEC; + hints.ai_socktype = SOCK_STREAM; + error = getaddrinfo("127.0.0.1", 0, &hints, &ai); + if(error || !ai) + exitcode = 1; /* fail */ + else { + freeaddrinfo(ai); + exitcode = 0; + } + #ifdef _WIN32 + WSACleanup(); + #endif + return exitcode; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_works_getaddrinfo="yes" + ],[ + AC_MSG_RESULT([no]) + tst_works_getaddrinfo="no" + ]) + fi + + if test "$tst_compi_getaddrinfo" = "yes" && + test "$tst_works_getaddrinfo" != "no"; then + AC_MSG_CHECKING([if getaddrinfo usage allowed]) + if test "x$curl_disallow_getaddrinfo" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_getaddrinfo="yes" + else + AC_MSG_RESULT([no]) + tst_allow_getaddrinfo="no" + fi + fi + + AC_MSG_CHECKING([if getaddrinfo might be used]) + if test "$tst_proto_getaddrinfo" = "yes" && + test "$tst_compi_getaddrinfo" = "yes" && + test "$tst_allow_getaddrinfo" = "yes" && + test "$tst_works_getaddrinfo" != "no"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_GETADDRINFO, 1, + [Define to 1 if you have a working getaddrinfo function.]) + curl_cv_func_getaddrinfo="yes" + else + AC_MSG_RESULT([no]) + curl_cv_func_getaddrinfo="no" + curl_cv_func_getaddrinfo_threadsafe="no" + fi + + if test "$curl_cv_func_getaddrinfo" = "yes"; then + AC_MSG_CHECKING([if getaddrinfo is thread-safe]) + if test "$curl_cv_apple" = "yes"; then + dnl Darwin 6.0 and macOS 10.2.X and newer + tst_tsafe_getaddrinfo="yes" + fi + case $host_os in + aix[[1234]].* | aix5.[[01]].*) + dnl AIX 5.1 and older + tst_tsafe_getaddrinfo="no" + ;; + aix*) + dnl AIX 5.2 and newer + tst_tsafe_getaddrinfo="yes" + ;; + darwin[[12345]].*) + dnl Darwin 5.0 and macOS 10.1.X and older + tst_tsafe_getaddrinfo="no" + ;; + freebsd[[1234]].* | freebsd5.[[1234]]*) + dnl FreeBSD 5.4 and older + tst_tsafe_getaddrinfo="no" + ;; + freebsd*) + dnl FreeBSD 5.5 and newer + tst_tsafe_getaddrinfo="yes" + ;; + hpux[[123456789]].* | hpux10.* | hpux11.0* | hpux11.10*) + dnl HP-UX 11.10 and older + tst_tsafe_getaddrinfo="no" + ;; + hpux*) + dnl HP-UX 11.11 and newer + tst_tsafe_getaddrinfo="yes" + ;; + midnightbsd*) + dnl all MidnightBSD versions + tst_tsafe_getaddrinfo="yes" + ;; + netbsd[[123]].*) + dnl NetBSD 3.X and older + tst_tsafe_getaddrinfo="no" + ;; + netbsd*) + dnl NetBSD 4.X and newer + tst_tsafe_getaddrinfo="yes" + ;; + *bsd*) + dnl All other BSD's + tst_tsafe_getaddrinfo="no" + ;; + solaris2*) + dnl Solaris which have it + tst_tsafe_getaddrinfo="yes" + ;; + esac + if test "$tst_tsafe_getaddrinfo" = "unknown" && + test "$curl_cv_native_windows" = "yes"; then + tst_tsafe_getaddrinfo="yes" + fi + if test "$tst_tsafe_getaddrinfo" = "unknown"; then + tst_tsafe_getaddrinfo="yes" + fi + AC_MSG_RESULT([$tst_tsafe_getaddrinfo]) + if test "$tst_tsafe_getaddrinfo" = "yes"; then + AC_DEFINE_UNQUOTED(HAVE_GETADDRINFO_THREADSAFE, 1, + [Define to 1 if the getaddrinfo function is thread-safe.]) + curl_cv_func_getaddrinfo_threadsafe="yes" + else + curl_cv_func_getaddrinfo_threadsafe="no" + fi + fi +]) + + +dnl CURL_CHECK_FUNC_GETHOSTBYNAME_R +dnl ------------------------------------------------- +dnl Verify if gethostbyname_r is available, prototyped, +dnl and can be compiled. If all of these are true, and +dnl usage has not been previously disallowed with +dnl shell variable curl_disallow_gethostbyname_r, then +dnl HAVE_GETHOSTBYNAME_R is defined. + +AC_DEFUN([CURL_CHECK_FUNC_GETHOSTBYNAME_R], [ + AC_REQUIRE([CURL_INCLUDES_NETDB]) + + tst_links_gethostbyname_r="unknown" + tst_proto_gethostbyname_r="unknown" + tst_compi_gethostbyname_r="unknown" + tst_allow_gethostbyname_r="unknown" + tst_nargs_gethostbyname_r="unknown" + + AC_MSG_CHECKING([if gethostbyname_r can be linked]) + AC_LINK_IFELSE([ + AC_LANG_FUNC_LINK_TRY([gethostbyname_r]) + ],[ + AC_MSG_RESULT([yes]) + tst_links_gethostbyname_r="yes" + ],[ + AC_MSG_RESULT([no]) + tst_links_gethostbyname_r="no" + ]) + + if test "$tst_links_gethostbyname_r" = "yes"; then + AC_MSG_CHECKING([if gethostbyname_r is prototyped]) + AC_EGREP_CPP([gethostbyname_r],[ + $curl_includes_netdb + ],[ + AC_MSG_RESULT([yes]) + tst_proto_gethostbyname_r="yes" + ],[ + AC_MSG_RESULT([no]) + tst_proto_gethostbyname_r="no" + ]) + fi + + if test "$tst_proto_gethostbyname_r" = "yes"; then + if test "$tst_nargs_gethostbyname_r" = "unknown"; then + AC_MSG_CHECKING([if gethostbyname_r takes 3 args.]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_netdb + $curl_includes_bsdsocket + ]],[[ + if(gethostbyname_r(0, 0, 0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_gethostbyname_r="yes" + tst_nargs_gethostbyname_r="3" + ],[ + AC_MSG_RESULT([no]) + tst_compi_gethostbyname_r="no" + ]) + fi + if test "$tst_nargs_gethostbyname_r" = "unknown"; then + AC_MSG_CHECKING([if gethostbyname_r takes 5 args.]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_netdb + $curl_includes_bsdsocket + ]],[[ + if(gethostbyname_r(0, 0, 0, 0, 0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_gethostbyname_r="yes" + tst_nargs_gethostbyname_r="5" + ],[ + AC_MSG_RESULT([no]) + tst_compi_gethostbyname_r="no" + ]) + fi + if test "$tst_nargs_gethostbyname_r" = "unknown"; then + AC_MSG_CHECKING([if gethostbyname_r takes 6 args.]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_netdb + $curl_includes_bsdsocket + ]],[[ + if(gethostbyname_r(0, 0, 0, 0, 0, 0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_gethostbyname_r="yes" + tst_nargs_gethostbyname_r="6" + ],[ + AC_MSG_RESULT([no]) + tst_compi_gethostbyname_r="no" + ]) + fi + AC_MSG_CHECKING([if gethostbyname_r is compilable]) + if test "$tst_compi_gethostbyname_r" = "yes"; then + AC_MSG_RESULT([yes]) + else + AC_MSG_RESULT([no]) + fi + fi + + if test "$tst_compi_gethostbyname_r" = "yes"; then + AC_MSG_CHECKING([if gethostbyname_r usage allowed]) + if test "x$curl_disallow_gethostbyname_r" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_gethostbyname_r="yes" + else + AC_MSG_RESULT([no]) + tst_allow_gethostbyname_r="no" + fi + fi + + AC_MSG_CHECKING([if gethostbyname_r might be used]) + if test "$tst_links_gethostbyname_r" = "yes" && + test "$tst_proto_gethostbyname_r" = "yes" && + test "$tst_compi_gethostbyname_r" = "yes" && + test "$tst_allow_gethostbyname_r" = "yes"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_GETHOSTBYNAME_R, 1, + [Define to 1 if you have the gethostbyname_r function.]) + dnl AC_DEFINE_UNQUOTED(GETHOSTBYNAME_R_ARGS, $tst_nargs_gethostbyname_r, + dnl [Specifies the number of arguments to gethostbyname_r]) + + if test "$tst_nargs_gethostbyname_r" -eq "3"; then + AC_DEFINE(HAVE_GETHOSTBYNAME_R_3, 1, [gethostbyname_r() takes 3 args]) + elif test "$tst_nargs_gethostbyname_r" -eq "5"; then + AC_DEFINE(HAVE_GETHOSTBYNAME_R_5, 1, [gethostbyname_r() takes 5 args]) + elif test "$tst_nargs_gethostbyname_r" -eq "6"; then + AC_DEFINE(HAVE_GETHOSTBYNAME_R_6, 1, [gethostbyname_r() takes 6 args]) + fi + + curl_cv_func_gethostbyname_r="yes" + else + AC_MSG_RESULT([no]) + curl_cv_func_gethostbyname_r="no" + fi +]) + + +dnl CURL_CHECK_FUNC_GETHOSTNAME +dnl ------------------------------------------------- +dnl Verify if gethostname is available, prototyped, and +dnl can be compiled. If all of these are true, and +dnl usage has not been previously disallowed with +dnl shell variable curl_disallow_gethostname, then +dnl HAVE_GETHOSTNAME is defined. + +AC_DEFUN([CURL_CHECK_FUNC_GETHOSTNAME], [ + AC_REQUIRE([CURL_INCLUDES_WINSOCK2]) + AC_REQUIRE([CURL_INCLUDES_BSDSOCKET]) + AC_REQUIRE([CURL_INCLUDES_UNISTD]) + AC_REQUIRE([CURL_PREPROCESS_CALLCONV]) + + tst_links_gethostname="unknown" + tst_proto_gethostname="unknown" + tst_compi_gethostname="unknown" + tst_allow_gethostname="unknown" + + AC_MSG_CHECKING([if gethostname can be linked]) + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_winsock2 + $curl_includes_unistd + $curl_includes_bsdsocket + ]],[[ + char s[1]; + if(gethostname((void *)s, 0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_links_gethostname="yes" + ],[ + AC_MSG_RESULT([no]) + tst_links_gethostname="no" + ]) + + if test "$tst_links_gethostname" = "yes"; then + AC_MSG_CHECKING([if gethostname is prototyped]) + AC_EGREP_CPP([gethostname],[ + $curl_includes_winsock2 + $curl_includes_unistd + $curl_includes_bsdsocket + ],[ + AC_MSG_RESULT([yes]) + tst_proto_gethostname="yes" + ],[ + AC_MSG_RESULT([no]) + tst_proto_gethostname="no" + ]) + fi + + if test "$tst_proto_gethostname" = "yes"; then + AC_MSG_CHECKING([if gethostname is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_winsock2 + $curl_includes_unistd + $curl_includes_bsdsocket + ]],[[ + char s[1]; + if(gethostname((void *)s, 0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_gethostname="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_gethostname="no" + ]) + fi + + if test "$tst_compi_gethostname" = "yes"; then + AC_MSG_CHECKING([for gethostname arg 2 data type]) + tst_gethostname_type_arg2="unknown" + for tst_arg1 in 'char *' 'unsigned char *' 'void *'; do + for tst_arg2 in 'int' 'unsigned int' 'size_t'; do + if test "$tst_gethostname_type_arg2" = "unknown"; then + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_winsock2 + $curl_includes_unistd + $curl_includes_bsdsocket + $curl_preprocess_callconv + #if defined(_WIN32) && defined(WINSOCK_API_LINKAGE) + WINSOCK_API_LINKAGE + #else + extern + #endif + int FUNCALLCONV gethostname($tst_arg1, $tst_arg2); + ]],[[ + char s[1]; + if(gethostname(($tst_arg1)s, 0)) + return 1; + ]]) + ],[ + tst_gethostname_type_arg2="$tst_arg2" + ]) + fi + done + done + AC_MSG_RESULT([$tst_gethostname_type_arg2]) + if test "$tst_gethostname_type_arg2" != "unknown"; then + AC_DEFINE_UNQUOTED(GETHOSTNAME_TYPE_ARG2, $tst_gethostname_type_arg2, + [Define to the type of arg 2 for gethostname.]) + fi + fi + + if test "$tst_compi_gethostname" = "yes"; then + AC_MSG_CHECKING([if gethostname usage allowed]) + if test "x$curl_disallow_gethostname" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_gethostname="yes" + else + AC_MSG_RESULT([no]) + tst_allow_gethostname="no" + fi + fi + + AC_MSG_CHECKING([if gethostname might be used]) + if test "$tst_links_gethostname" = "yes" && + test "$tst_proto_gethostname" = "yes" && + test "$tst_compi_gethostname" = "yes" && + test "$tst_allow_gethostname" = "yes"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_GETHOSTNAME, 1, + [Define to 1 if you have the gethostname function.]) + curl_cv_func_gethostname="yes" + else + AC_MSG_RESULT([no]) + curl_cv_func_gethostname="no" + fi +]) + +dnl CURL_CHECK_FUNC_GETPEERNAME +dnl ------------------------------------------------- +dnl Verify if getpeername is available, prototyped, and +dnl can be compiled. If all of these are true, and +dnl usage has not been previously disallowed with +dnl shell variable curl_disallow_getpeername, then +dnl HAVE_GETPEERNAME is defined. + +AC_DEFUN([CURL_CHECK_FUNC_GETPEERNAME], [ + AC_REQUIRE([CURL_INCLUDES_WINSOCK2]) + AC_REQUIRE([CURL_INCLUDES_UNISTD]) + AC_REQUIRE([CURL_PREPROCESS_CALLCONV]) + AC_REQUIRE([CURL_INCLUDES_BSDSOCKET]) + + tst_links_getpeername="unknown" + tst_proto_getpeername="unknown" + tst_compi_getpeername="unknown" + tst_allow_getpeername="unknown" + + AC_MSG_CHECKING([if getpeername can be linked]) + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_winsock2 + $curl_includes_bsdsocket + $curl_includes_sys_socket + ]],[[ + if(getpeername(0, (void *)0, (void *)0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_links_getpeername="yes" + ],[ + AC_MSG_RESULT([no]) + tst_links_getpeername="no" + ]) + + if test "$tst_links_getpeername" = "yes"; then + AC_MSG_CHECKING([if getpeername is prototyped]) + AC_EGREP_CPP([getpeername],[ + $curl_includes_winsock2 + $curl_includes_bsdsocket + $curl_includes_sys_socket + ],[ + AC_MSG_RESULT([yes]) + tst_proto_getpeername="yes" + ],[ + AC_MSG_RESULT([no]) + tst_proto_getpeername="no" + ]) + fi + + if test "$tst_proto_getpeername" = "yes"; then + AC_MSG_CHECKING([if getpeername is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_winsock2 + $curl_includes_bsdsocket + $curl_includes_sys_socket + ]],[[ + if(getpeername(0, (void *)0, (void *)0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_getpeername="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_getpeername="no" + ]) + fi + + if test "$tst_compi_getpeername" = "yes"; then + AC_MSG_CHECKING([if getpeername usage allowed]) + if test "x$curl_disallow_getpeername" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_getpeername="yes" + else + AC_MSG_RESULT([no]) + tst_allow_getpeername="no" + fi + fi + + AC_MSG_CHECKING([if getpeername might be used]) + if test "$tst_links_getpeername" = "yes" && + test "$tst_proto_getpeername" = "yes" && + test "$tst_compi_getpeername" = "yes" && + test "$tst_allow_getpeername" = "yes"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_GETPEERNAME, 1, + [Define to 1 if you have the getpeername function.]) + curl_cv_func_getpeername="yes" + else + AC_MSG_RESULT([no]) + curl_cv_func_getpeername="no" + fi +]) + +dnl CURL_CHECK_FUNC_GETSOCKNAME +dnl ------------------------------------------------- +dnl Verify if getsockname is available, prototyped, and +dnl can be compiled. If all of these are true, and +dnl usage has not been previously disallowed with +dnl shell variable curl_disallow_getsockname, then +dnl HAVE_GETSOCKNAME is defined. + +AC_DEFUN([CURL_CHECK_FUNC_GETSOCKNAME], [ + AC_REQUIRE([CURL_INCLUDES_WINSOCK2]) + AC_REQUIRE([CURL_INCLUDES_UNISTD]) + AC_REQUIRE([CURL_PREPROCESS_CALLCONV]) + AC_REQUIRE([CURL_INCLUDES_BSDSOCKET]) + + tst_links_getsockname="unknown" + tst_proto_getsockname="unknown" + tst_compi_getsockname="unknown" + tst_allow_getsockname="unknown" + + AC_MSG_CHECKING([if getsockname can be linked]) + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_winsock2 + $curl_includes_bsdsocket + $curl_includes_sys_socket + ]],[[ + if(getsockname(0, (void *)0, (void *)0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_links_getsockname="yes" + ],[ + AC_MSG_RESULT([no]) + tst_links_getsockname="no" + ]) + + if test "$tst_links_getsockname" = "yes"; then + AC_MSG_CHECKING([if getsockname is prototyped]) + AC_EGREP_CPP([getsockname],[ + $curl_includes_winsock2 + $curl_includes_bsdsocket + $curl_includes_sys_socket + ],[ + AC_MSG_RESULT([yes]) + tst_proto_getsockname="yes" + ],[ + AC_MSG_RESULT([no]) + tst_proto_getsockname="no" + ]) + fi + + if test "$tst_proto_getsockname" = "yes"; then + AC_MSG_CHECKING([if getsockname is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_winsock2 + $curl_includes_bsdsocket + $curl_includes_sys_socket + ]],[[ + if(getsockname(0, (void *)0, (void *)0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_getsockname="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_getsockname="no" + ]) + fi + + if test "$tst_compi_getsockname" = "yes"; then + AC_MSG_CHECKING([if getsockname usage allowed]) + if test "x$curl_disallow_getsockname" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_getsockname="yes" + else + AC_MSG_RESULT([no]) + tst_allow_getsockname="no" + fi + fi + + AC_MSG_CHECKING([if getsockname might be used]) + if test "$tst_links_getsockname" = "yes" && + test "$tst_proto_getsockname" = "yes" && + test "$tst_compi_getsockname" = "yes" && + test "$tst_allow_getsockname" = "yes"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_GETSOCKNAME, 1, + [Define to 1 if you have the getsockname function.]) + curl_cv_func_getsockname="yes" + else + AC_MSG_RESULT([no]) + curl_cv_func_getsockname="no" + fi +]) + + +dnl CURL_CHECK_FUNC_GETIFADDRS +dnl ------------------------------------------------- +dnl Verify if getifaddrs is available, prototyped, can +dnl be compiled and seems to work. If all of these are +dnl true, and usage has not been previously disallowed +dnl with shell variable curl_disallow_getifaddrs, then +dnl HAVE_GETIFADDRS is defined. + +AC_DEFUN([CURL_CHECK_FUNC_GETIFADDRS], [ + AC_REQUIRE([CURL_INCLUDES_STDLIB]) + AC_REQUIRE([CURL_INCLUDES_IFADDRS]) + + tst_links_getifaddrs="unknown" + tst_proto_getifaddrs="unknown" + tst_compi_getifaddrs="unknown" + tst_works_getifaddrs="unknown" + tst_allow_getifaddrs="unknown" + + AC_MSG_CHECKING([if getifaddrs can be linked]) + AC_LINK_IFELSE([ + AC_LANG_FUNC_LINK_TRY([getifaddrs]) + ],[ + AC_MSG_RESULT([yes]) + tst_links_getifaddrs="yes" + ],[ + AC_MSG_RESULT([no]) + tst_links_getifaddrs="no" + ]) + + if test "$tst_links_getifaddrs" = "yes"; then + AC_MSG_CHECKING([if getifaddrs is prototyped]) + AC_EGREP_CPP([getifaddrs],[ + $curl_includes_ifaddrs + ],[ + AC_MSG_RESULT([yes]) + tst_proto_getifaddrs="yes" + ],[ + AC_MSG_RESULT([no]) + tst_proto_getifaddrs="no" + ]) + fi + + if test "$tst_proto_getifaddrs" = "yes"; then + AC_MSG_CHECKING([if getifaddrs is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_ifaddrs + ]],[[ + if(getifaddrs(0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_getifaddrs="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_getifaddrs="no" + ]) + fi + + dnl only do runtime verification when not cross-compiling + if test "$cross_compiling" != "yes" && + test "$tst_compi_getifaddrs" = "yes"; then + AC_MSG_CHECKING([if getifaddrs seems to work]) + CURL_RUN_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_stdlib + $curl_includes_ifaddrs + ]],[[ + struct ifaddrs *ifa = 0; + int error; + + error = getifaddrs(&ifa); + if(error || !ifa) + return 1; /* fail */ + else { + freeifaddrs(ifa); + return 0; + } + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_works_getifaddrs="yes" + ],[ + AC_MSG_RESULT([no]) + tst_works_getifaddrs="no" + ]) + fi + + if test "$tst_compi_getifaddrs" = "yes" && + test "$tst_works_getifaddrs" != "no"; then + AC_MSG_CHECKING([if getifaddrs usage allowed]) + if test "x$curl_disallow_getifaddrs" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_getifaddrs="yes" + else + AC_MSG_RESULT([no]) + tst_allow_getifaddrs="no" + fi + fi + + AC_MSG_CHECKING([if getifaddrs might be used]) + if test "$tst_links_getifaddrs" = "yes" && + test "$tst_proto_getifaddrs" = "yes" && + test "$tst_compi_getifaddrs" = "yes" && + test "$tst_allow_getifaddrs" = "yes" && + test "$tst_works_getifaddrs" != "no"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_GETIFADDRS, 1, + [Define to 1 if you have a working getifaddrs function.]) + curl_cv_func_getifaddrs="yes" + else + AC_MSG_RESULT([no]) + curl_cv_func_getifaddrs="no" + fi +]) + + +dnl CURL_CHECK_FUNC_GMTIME_R +dnl ------------------------------------------------- +dnl Verify if gmtime_r is available, prototyped, can +dnl be compiled and seems to work. If all of these are +dnl true, and usage has not been previously disallowed +dnl with shell variable curl_disallow_gmtime_r, then +dnl HAVE_GMTIME_R is defined. + +AC_DEFUN([CURL_CHECK_FUNC_GMTIME_R], [ + AC_REQUIRE([CURL_INCLUDES_STDLIB]) + AC_REQUIRE([CURL_INCLUDES_TIME]) + + tst_links_gmtime_r="unknown" + tst_proto_gmtime_r="unknown" + tst_compi_gmtime_r="unknown" + tst_works_gmtime_r="unknown" + tst_allow_gmtime_r="unknown" + + AC_MSG_CHECKING([if gmtime_r can be linked]) + AC_LINK_IFELSE([ + AC_LANG_FUNC_LINK_TRY([gmtime_r]) + ],[ + AC_MSG_RESULT([yes]) + tst_links_gmtime_r="yes" + ],[ + AC_MSG_RESULT([no]) + tst_links_gmtime_r="no" + ]) + + if test "$tst_links_gmtime_r" = "yes"; then + AC_MSG_CHECKING([if gmtime_r is prototyped]) + AC_EGREP_CPP([gmtime_r],[ + $curl_includes_time + ],[ + AC_MSG_RESULT([yes]) + tst_proto_gmtime_r="yes" + ],[ + AC_MSG_RESULT([no]) + tst_proto_gmtime_r="no" + ]) + fi + + if test "$tst_proto_gmtime_r" = "yes"; then + AC_MSG_CHECKING([if gmtime_r is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_time + ]],[[ + time_t tm = 1170352587; + struct tm result; + if(gmtime_r(&tm, &result) == 0) + return 1; + (void)result; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_gmtime_r="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_gmtime_r="no" + ]) + fi + + dnl only do runtime verification when not cross-compiling + if test "$cross_compiling" != "yes" && + test "$tst_compi_gmtime_r" = "yes"; then + AC_MSG_CHECKING([if gmtime_r seems to work]) + CURL_RUN_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_stdlib + $curl_includes_time + ]],[[ + time_t local = 1170352587; + struct tm *gmt = 0; + struct tm result; + gmt = gmtime_r(&local, &result); + (void)result; + if(gmt) + return 0; + else + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_works_gmtime_r="yes" + ],[ + AC_MSG_RESULT([no]) + tst_works_gmtime_r="no" + ]) + fi + + if test "$tst_compi_gmtime_r" = "yes" && + test "$tst_works_gmtime_r" != "no"; then + AC_MSG_CHECKING([if gmtime_r usage allowed]) + if test "x$curl_disallow_gmtime_r" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_gmtime_r="yes" + else + AC_MSG_RESULT([no]) + tst_allow_gmtime_r="no" + fi + fi + + AC_MSG_CHECKING([if gmtime_r might be used]) + if test "$tst_links_gmtime_r" = "yes" && + test "$tst_proto_gmtime_r" = "yes" && + test "$tst_compi_gmtime_r" = "yes" && + test "$tst_allow_gmtime_r" = "yes" && + test "$tst_works_gmtime_r" != "no"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_GMTIME_R, 1, + [Define to 1 if you have a working gmtime_r function.]) + curl_cv_func_gmtime_r="yes" + else + AC_MSG_RESULT([no]) + curl_cv_func_gmtime_r="no" + fi +]) + + +dnl CURL_CHECK_FUNC_LOCALTIME_R +dnl ------------------------------------------------- +dnl Verify if localtime_r is available, prototyped, can +dnl be compiled and seems to work. If all of these are +dnl true, and usage has not been previously disallowed +dnl with shell variable curl_disallow_localtime_r, then +dnl HAVE_LOCALTIME_R is defined. + +AC_DEFUN([CURL_CHECK_FUNC_LOCALTIME_R], [ + AC_REQUIRE([CURL_INCLUDES_STDLIB]) + AC_REQUIRE([CURL_INCLUDES_TIME]) + + tst_links_localtime_r="unknown" + tst_proto_localtime_r="unknown" + tst_compi_localtime_r="unknown" + tst_works_localtime_r="unknown" + tst_allow_localtime_r="unknown" + + AC_MSG_CHECKING([if localtime_r can be linked]) + AC_LINK_IFELSE([ + AC_LANG_FUNC_LINK_TRY([localtime_r]) + ],[ + AC_MSG_RESULT([yes]) + tst_links_localtime_r="yes" + ],[ + AC_MSG_RESULT([no]) + tst_links_localtime_r="no" + ]) + + if test "$tst_links_localtime_r" = "yes"; then + AC_MSG_CHECKING([if localtime_r is prototyped]) + AC_EGREP_CPP([localtime_r],[ + $curl_includes_time + ],[ + AC_MSG_RESULT([yes]) + tst_proto_localtime_r="yes" + ],[ + AC_MSG_RESULT([no]) + tst_proto_localtime_r="no" + ]) + fi + + if test "$tst_proto_localtime_r" = "yes"; then + AC_MSG_CHECKING([if localtime_r is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_time + ]],[[ + time_t clock = 1170352587; + struct tm result; + if(localtime_r(&clock, &result)) + return 1; + (void)result; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_localtime_r="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_localtime_r="no" + ]) + fi + + dnl only do runtime verification when not cross-compiling + if test "$cross_compiling" != "yes" && + test "$tst_compi_localtime_r" = "yes"; then + AC_MSG_CHECKING([if localtime_r seems to work]) + CURL_RUN_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_stdlib + $curl_includes_time + ]],[[ + time_t clock = 1170352587; + struct tm *tmp = 0; + struct tm result; + tmp = localtime_r(&clock, &result); + (void)result; + if(tmp) + return 0; + else + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_works_localtime_r="yes" + ],[ + AC_MSG_RESULT([no]) + tst_works_localtime_r="no" + ]) + fi + + if test "$tst_compi_localtime_r" = "yes" && + test "$tst_works_localtime_r" != "no"; then + AC_MSG_CHECKING([if localtime_r usage allowed]) + if test "x$curl_disallow_localtime_r" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_localtime_r="yes" + else + AC_MSG_RESULT([no]) + tst_allow_localtime_r="no" + fi + fi + + AC_MSG_CHECKING([if localtime_r might be used]) + if test "$tst_links_localtime_r" = "yes" && + test "$tst_proto_localtime_r" = "yes" && + test "$tst_compi_localtime_r" = "yes" && + test "$tst_allow_localtime_r" = "yes" && + test "$tst_works_localtime_r" != "no"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_LOCALTIME_R, 1, + [Define to 1 if you have a working localtime_r function.]) + curl_cv_func_localtime_r="yes" + else + AC_MSG_RESULT([no]) + curl_cv_func_localtime_r="no" + fi +]) + + +dnl CURL_CHECK_FUNC_INET_NTOP +dnl ------------------------------------------------- +dnl Verify if inet_ntop is available, prototyped, can +dnl be compiled and seems to work. If all of these are +dnl true, and usage has not been previously disallowed +dnl with shell variable curl_disallow_inet_ntop, then +dnl HAVE_INET_NTOP is defined. + +AC_DEFUN([CURL_CHECK_FUNC_INET_NTOP], [ + AC_REQUIRE([CURL_INCLUDES_STDLIB]) + AC_REQUIRE([CURL_INCLUDES_ARPA_INET]) + AC_REQUIRE([CURL_INCLUDES_STRING]) + + tst_links_inet_ntop="unknown" + tst_proto_inet_ntop="unknown" + tst_compi_inet_ntop="unknown" + tst_works_inet_ntop="unknown" + tst_allow_inet_ntop="unknown" + + AC_MSG_CHECKING([if inet_ntop can be linked]) + AC_LINK_IFELSE([ + AC_LANG_FUNC_LINK_TRY([inet_ntop]) + ],[ + AC_MSG_RESULT([yes]) + tst_links_inet_ntop="yes" + ],[ + AC_MSG_RESULT([no]) + tst_links_inet_ntop="no" + ]) + + if test "$tst_links_inet_ntop" = "yes"; then + AC_MSG_CHECKING([if inet_ntop is prototyped]) + AC_EGREP_CPP([inet_ntop],[ + $curl_includes_arpa_inet + ],[ + AC_MSG_RESULT([yes]) + tst_proto_inet_ntop="yes" + ],[ + AC_MSG_RESULT([no]) + tst_proto_inet_ntop="no" + ]) + fi + + if test "$tst_proto_inet_ntop" = "yes"; then + AC_MSG_CHECKING([if inet_ntop is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_arpa_inet + ]],[[ + char ipv4res[sizeof("255.255.255.255")]; + unsigned char ipv4a[5] = ""; + if(inet_ntop(0, ipv4a, ipv4res, 0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_inet_ntop="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_inet_ntop="no" + ]) + fi + + dnl only do runtime verification when not cross-compiling + if test "$cross_compiling" != "yes" && + test "$tst_compi_inet_ntop" = "yes"; then + AC_MSG_CHECKING([if inet_ntop seems to work]) + CURL_RUN_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_stdlib + $curl_includes_arpa_inet + $curl_includes_string + ]],[[ + char ipv6res[sizeof("ffff:ffff:ffff:ffff:ffff:ffff:255.255.255.255")]; + char ipv4res[sizeof("255.255.255.255")]; + unsigned char ipv6a[26]; + unsigned char ipv4a[5]; + const char *ipv6ptr = 0; + const char *ipv4ptr = 0; + /* - */ + ipv4res[0] = '\0'; + ipv4a[0] = 0xc0; + ipv4a[1] = 0xa8; + ipv4a[2] = 0x64; + ipv4a[3] = 0x01; + ipv4a[4] = 0x01; + /* - */ + ipv4ptr = inet_ntop(AF_INET, ipv4a, ipv4res, sizeof(ipv4res)); + if(!ipv4ptr) + return 1; /* fail */ + if(ipv4ptr != ipv4res) + return 1; /* fail */ + if(!ipv4ptr[0]) + return 1; /* fail */ + if(memcmp(ipv4res, "192.168.100.1", 13)) + return 1; /* fail */ + /* - */ + ipv6res[0] = '\0'; + memset(ipv6a, 0, sizeof(ipv6a)); + ipv6a[0] = 0xfe; + ipv6a[1] = 0x80; + ipv6a[8] = 0x02; + ipv6a[9] = 0x14; + ipv6a[10] = 0x4f; + ipv6a[11] = 0xff; + ipv6a[12] = 0xfe; + ipv6a[13] = 0x0b; + ipv6a[14] = 0x76; + ipv6a[15] = 0xc8; + ipv6a[25] = 0x01; + /* - */ + ipv6ptr = inet_ntop(AF_INET6, ipv6a, ipv6res, sizeof(ipv6res)); + if(!ipv6ptr) + return 1; /* fail */ + if(ipv6ptr != ipv6res) + return 1; /* fail */ + if(!ipv6ptr[0]) + return 1; /* fail */ + if(memcmp(ipv6res, "fe80::214:4fff:fe0b:76c8", 24)) + return 1; /* fail */ + /* - */ + return 0; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_works_inet_ntop="yes" + ],[ + AC_MSG_RESULT([no]) + tst_works_inet_ntop="no" + ]) + fi + + if test "$tst_compi_inet_ntop" = "yes" && + test "$tst_works_inet_ntop" != "no"; then + AC_MSG_CHECKING([if inet_ntop usage allowed]) + if test "x$curl_disallow_inet_ntop" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_inet_ntop="yes" + else + AC_MSG_RESULT([no]) + tst_allow_inet_ntop="no" + fi + fi + + AC_MSG_CHECKING([if inet_ntop might be used]) + if test "$tst_links_inet_ntop" = "yes" && + test "$tst_proto_inet_ntop" = "yes" && + test "$tst_compi_inet_ntop" = "yes" && + test "$tst_allow_inet_ntop" = "yes" && + test "$tst_works_inet_ntop" != "no"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_INET_NTOP, 1, + [Define to 1 if you have an IPv6 capable working inet_ntop function.]) + curl_cv_func_inet_ntop="yes" + else + AC_MSG_RESULT([no]) + curl_cv_func_inet_ntop="no" + fi +]) + + +dnl CURL_CHECK_FUNC_INET_PTON +dnl ------------------------------------------------- +dnl Verify if inet_pton is available, prototyped, can +dnl be compiled and seems to work. If all of these are +dnl true, and usage has not been previously disallowed +dnl with shell variable curl_disallow_inet_pton, then +dnl HAVE_INET_PTON is defined. + +AC_DEFUN([CURL_CHECK_FUNC_INET_PTON], [ + AC_REQUIRE([CURL_INCLUDES_STDLIB]) + AC_REQUIRE([CURL_INCLUDES_ARPA_INET]) + AC_REQUIRE([CURL_INCLUDES_STRING]) + + tst_links_inet_pton="unknown" + tst_proto_inet_pton="unknown" + tst_compi_inet_pton="unknown" + tst_works_inet_pton="unknown" + tst_allow_inet_pton="unknown" + + AC_MSG_CHECKING([if inet_pton can be linked]) + AC_LINK_IFELSE([ + AC_LANG_FUNC_LINK_TRY([inet_pton]) + ],[ + AC_MSG_RESULT([yes]) + tst_links_inet_pton="yes" + ],[ + AC_MSG_RESULT([no]) + tst_links_inet_pton="no" + ]) + + if test "$tst_links_inet_pton" = "yes"; then + AC_MSG_CHECKING([if inet_pton is prototyped]) + AC_EGREP_CPP([inet_pton],[ + $curl_includes_arpa_inet + ],[ + AC_MSG_RESULT([yes]) + tst_proto_inet_pton="yes" + ],[ + AC_MSG_RESULT([no]) + tst_proto_inet_pton="no" + ]) + fi + + if test "$tst_proto_inet_pton" = "yes"; then + AC_MSG_CHECKING([if inet_pton is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_arpa_inet + ]],[[ + unsigned char ipv4a[4 + 1] = ""; + const char *ipv4src = "192.168.100.1"; + if(inet_pton(0, ipv4src, ipv4a)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_inet_pton="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_inet_pton="no" + ]) + fi + + dnl only do runtime verification when not cross-compiling + if test "$cross_compiling" != "yes" && + test "$tst_compi_inet_pton" = "yes"; then + AC_MSG_CHECKING([if inet_pton seems to work]) + CURL_RUN_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_stdlib + $curl_includes_arpa_inet + $curl_includes_string + ]],[[ + unsigned char ipv6a[16 + 1]; + unsigned char ipv4a[4 + 1]; + const char *ipv6src = "fe80::214:4fff:fe0b:76c8"; + const char *ipv4src = "192.168.100.1"; + /* - */ + memset(ipv4a, 1, sizeof(ipv4a)); + if(inet_pton(AF_INET, ipv4src, ipv4a) != 1) + return 1; /* fail */ + /* - */ + if((ipv4a[0] != 0xc0) || + (ipv4a[1] != 0xa8) || + (ipv4a[2] != 0x64) || + (ipv4a[3] != 0x01) || + (ipv4a[4] != 0x01)) + return 1; /* fail */ + /* - */ + memset(ipv6a, 1, sizeof(ipv6a)); + if(inet_pton(AF_INET6, ipv6src, ipv6a) != 1) + return 1; /* fail */ + /* - */ + if((ipv6a[0] != 0xfe) || + (ipv6a[1] != 0x80) || + (ipv6a[8] != 0x02) || + (ipv6a[9] != 0x14) || + (ipv6a[10] != 0x4f) || + (ipv6a[11] != 0xff) || + (ipv6a[12] != 0xfe) || + (ipv6a[13] != 0x0b) || + (ipv6a[14] != 0x76) || + (ipv6a[15] != 0xc8) || + (ipv6a[16] != 0x01)) + return 1; /* fail */ + /* - */ + if((ipv6a[2] != 0x0) || + (ipv6a[3] != 0x0) || + (ipv6a[4] != 0x0) || + (ipv6a[5] != 0x0) || + (ipv6a[6] != 0x0) || + (ipv6a[7] != 0x0)) + return 1; /* fail */ + /* - */ + return 0; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_works_inet_pton="yes" + ],[ + AC_MSG_RESULT([no]) + tst_works_inet_pton="no" + ]) + fi + + if test "$tst_compi_inet_pton" = "yes" && + test "$tst_works_inet_pton" != "no"; then + AC_MSG_CHECKING([if inet_pton usage allowed]) + if test "x$curl_disallow_inet_pton" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_inet_pton="yes" + else + AC_MSG_RESULT([no]) + tst_allow_inet_pton="no" + fi + fi + + AC_MSG_CHECKING([if inet_pton might be used]) + if test "$tst_links_inet_pton" = "yes" && + test "$tst_proto_inet_pton" = "yes" && + test "$tst_compi_inet_pton" = "yes" && + test "$tst_allow_inet_pton" = "yes" && + test "$tst_works_inet_pton" != "no"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_INET_PTON, 1, + [Define to 1 if you have an IPv6 capable working inet_pton function.]) + curl_cv_func_inet_pton="yes" + else + AC_MSG_RESULT([no]) + curl_cv_func_inet_pton="no" + fi +]) + + +dnl CURL_CHECK_FUNC_IOCTL +dnl ------------------------------------------------- +dnl Verify if ioctl is available, prototyped, and +dnl can be compiled. If all of these are true, and +dnl usage has not been previously disallowed with +dnl shell variable curl_disallow_ioctl, then +dnl curl_cv_func_ioctl is set to "yes". + +AC_DEFUN([CURL_CHECK_FUNC_IOCTL], [ + AC_REQUIRE([CURL_INCLUDES_STROPTS]) + + tst_links_ioctl="unknown" + tst_proto_ioctl="unknown" + tst_compi_ioctl="unknown" + tst_allow_ioctl="unknown" + + AC_MSG_CHECKING([if ioctl can be linked]) + AC_LINK_IFELSE([ + AC_LANG_FUNC_LINK_TRY([ioctl]) + ],[ + AC_MSG_RESULT([yes]) + tst_links_ioctl="yes" + ],[ + AC_MSG_RESULT([no]) + tst_links_ioctl="no" + ]) + + if test "$tst_links_ioctl" = "yes"; then + AC_MSG_CHECKING([if ioctl is prototyped]) + AC_EGREP_CPP([ioctl],[ + $curl_includes_stropts + ],[ + AC_MSG_RESULT([yes]) + tst_proto_ioctl="yes" + ],[ + AC_MSG_RESULT([no]) + tst_proto_ioctl="no" + ]) + fi + + if test "$tst_proto_ioctl" = "yes"; then + AC_MSG_CHECKING([if ioctl is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_stropts + ]],[[ + if(ioctl(0, 0, 0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_ioctl="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_ioctl="no" + ]) + fi + + if test "$tst_compi_ioctl" = "yes"; then + AC_MSG_CHECKING([if ioctl usage allowed]) + if test "x$curl_disallow_ioctl" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_ioctl="yes" + else + AC_MSG_RESULT([no]) + tst_allow_ioctl="no" + fi + fi + + AC_MSG_CHECKING([if ioctl might be used]) + if test "$tst_links_ioctl" = "yes" && + test "$tst_proto_ioctl" = "yes" && + test "$tst_compi_ioctl" = "yes" && + test "$tst_allow_ioctl" = "yes"; then + AC_MSG_RESULT([yes]) + curl_cv_func_ioctl="yes" + CURL_CHECK_FUNC_IOCTL_FIONBIO + CURL_CHECK_FUNC_IOCTL_SIOCGIFADDR + else + AC_MSG_RESULT([no]) + curl_cv_func_ioctl="no" + fi +]) + + +dnl CURL_CHECK_FUNC_IOCTL_FIONBIO +dnl ------------------------------------------------- +dnl Verify if ioctl with the FIONBIO command is +dnl available, can be compiled, and seems to work. If +dnl all of these are true, then HAVE_IOCTL_FIONBIO +dnl is defined. + +AC_DEFUN([CURL_CHECK_FUNC_IOCTL_FIONBIO], [ + + tst_compi_ioctl_fionbio="unknown" + tst_allow_ioctl_fionbio="unknown" + + if test "$curl_cv_func_ioctl" = "yes"; then + AC_MSG_CHECKING([if ioctl FIONBIO is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_stropts + ]],[[ + int flags = 0; + if(ioctl(0, FIONBIO, &flags)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_ioctl_fionbio="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_ioctl_fionbio="no" + ]) + fi + + if test "$tst_compi_ioctl_fionbio" = "yes"; then + AC_MSG_CHECKING([if ioctl FIONBIO usage allowed]) + if test "x$curl_disallow_ioctl_fionbio" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_ioctl_fionbio="yes" + else + AC_MSG_RESULT([no]) + tst_allow_ioctl_fionbio="no" + fi + fi + + AC_MSG_CHECKING([if ioctl FIONBIO might be used]) + if test "$tst_compi_ioctl_fionbio" = "yes" && + test "$tst_allow_ioctl_fionbio" = "yes"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_IOCTL_FIONBIO, 1, + [Define to 1 if you have a working ioctl FIONBIO function.]) + curl_cv_func_ioctl_fionbio="yes" + else + AC_MSG_RESULT([no]) + curl_cv_func_ioctl_fionbio="no" + fi +]) + + +dnl CURL_CHECK_FUNC_IOCTL_SIOCGIFADDR +dnl ------------------------------------------------- +dnl Verify if ioctl with the SIOCGIFADDR command is available, +dnl struct ifreq is defined, they can be compiled, and seem to +dnl work. If all of these are true, then HAVE_IOCTL_SIOCGIFADDR +dnl is defined. + +AC_DEFUN([CURL_CHECK_FUNC_IOCTL_SIOCGIFADDR], [ + + tst_compi_ioctl_siocgifaddr="unknown" + tst_allow_ioctl_siocgifaddr="unknown" + + if test "$curl_cv_func_ioctl" = "yes"; then + AC_MSG_CHECKING([if ioctl SIOCGIFADDR is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_stropts + #include + ]],[[ + struct ifreq ifr; + if(ioctl(0, SIOCGIFADDR, &ifr)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_ioctl_siocgifaddr="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_ioctl_siocgifaddr="no" + ]) + fi + + if test "$tst_compi_ioctl_siocgifaddr" = "yes"; then + AC_MSG_CHECKING([if ioctl SIOCGIFADDR usage allowed]) + if test "x$curl_disallow_ioctl_siocgifaddr" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_ioctl_siocgifaddr="yes" + else + AC_MSG_RESULT([no]) + tst_allow_ioctl_siocgifaddr="no" + fi + fi + + AC_MSG_CHECKING([if ioctl SIOCGIFADDR might be used]) + if test "$tst_compi_ioctl_siocgifaddr" = "yes" && + test "$tst_allow_ioctl_siocgifaddr" = "yes"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_IOCTL_SIOCGIFADDR, 1, + [Define to 1 if you have a working ioctl SIOCGIFADDR function.]) + curl_cv_func_ioctl_siocgifaddr="yes" + else + AC_MSG_RESULT([no]) + curl_cv_func_ioctl_siocgifaddr="no" + fi +]) + + +dnl CURL_CHECK_FUNC_IOCTLSOCKET +dnl ------------------------------------------------- +dnl Verify if ioctlsocket is available, prototyped, and +dnl can be compiled. If all of these are true, and +dnl usage has not been previously disallowed with +dnl shell variable curl_disallow_ioctlsocket, then +dnl HAVE_IOCTLSOCKET is defined. + +AC_DEFUN([CURL_CHECK_FUNC_IOCTLSOCKET], [ + AC_REQUIRE([CURL_INCLUDES_WINSOCK2]) + + tst_links_ioctlsocket="unknown" + tst_proto_ioctlsocket="unknown" + tst_compi_ioctlsocket="unknown" + tst_allow_ioctlsocket="unknown" + + AC_MSG_CHECKING([if ioctlsocket can be linked]) + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_winsock2 + ]],[[ + if(ioctlsocket(0, 0, 0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_links_ioctlsocket="yes" + ],[ + AC_MSG_RESULT([no]) + tst_links_ioctlsocket="no" + ]) + + if test "$tst_links_ioctlsocket" = "yes"; then + AC_MSG_CHECKING([if ioctlsocket is prototyped]) + AC_EGREP_CPP([ioctlsocket],[ + $curl_includes_winsock2 + ],[ + AC_MSG_RESULT([yes]) + tst_proto_ioctlsocket="yes" + ],[ + AC_MSG_RESULT([no]) + tst_proto_ioctlsocket="no" + ]) + fi + + if test "$tst_proto_ioctlsocket" = "yes"; then + AC_MSG_CHECKING([if ioctlsocket is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_winsock2 + ]],[[ + if(ioctlsocket(0, 0, 0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_ioctlsocket="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_ioctlsocket="no" + ]) + fi + + if test "$tst_compi_ioctlsocket" = "yes"; then + AC_MSG_CHECKING([if ioctlsocket usage allowed]) + if test "x$curl_disallow_ioctlsocket" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_ioctlsocket="yes" + else + AC_MSG_RESULT([no]) + tst_allow_ioctlsocket="no" + fi + fi + + AC_MSG_CHECKING([if ioctlsocket might be used]) + if test "$tst_links_ioctlsocket" = "yes" && + test "$tst_proto_ioctlsocket" = "yes" && + test "$tst_compi_ioctlsocket" = "yes" && + test "$tst_allow_ioctlsocket" = "yes"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_IOCTLSOCKET, 1, + [Define to 1 if you have the ioctlsocket function.]) + curl_cv_func_ioctlsocket="yes" + CURL_CHECK_FUNC_IOCTLSOCKET_FIONBIO + else + AC_MSG_RESULT([no]) + curl_cv_func_ioctlsocket="no" + fi +]) + + +dnl CURL_CHECK_FUNC_IOCTLSOCKET_FIONBIO +dnl ------------------------------------------------- +dnl Verify if ioctlsocket with the FIONBIO command is +dnl available, can be compiled, and seems to work. If +dnl all of these are true, then HAVE_IOCTLSOCKET_FIONBIO +dnl is defined. + +AC_DEFUN([CURL_CHECK_FUNC_IOCTLSOCKET_FIONBIO], [ + + tst_compi_ioctlsocket_fionbio="unknown" + tst_allow_ioctlsocket_fionbio="unknown" + + if test "$curl_cv_func_ioctlsocket" = "yes"; then + AC_MSG_CHECKING([if ioctlsocket FIONBIO is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_winsock2 + ]],[[ + unsigned long flags = 0; + if(ioctlsocket(0, FIONBIO, &flags)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_ioctlsocket_fionbio="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_ioctlsocket_fionbio="no" + ]) + fi + + if test "$tst_compi_ioctlsocket_fionbio" = "yes"; then + AC_MSG_CHECKING([if ioctlsocket FIONBIO usage allowed]) + if test "x$curl_disallow_ioctlsocket_fionbio" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_ioctlsocket_fionbio="yes" + else + AC_MSG_RESULT([no]) + tst_allow_ioctlsocket_fionbio="no" + fi + fi + + AC_MSG_CHECKING([if ioctlsocket FIONBIO might be used]) + if test "$tst_compi_ioctlsocket_fionbio" = "yes" && + test "$tst_allow_ioctlsocket_fionbio" = "yes"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_IOCTLSOCKET_FIONBIO, 1, + [Define to 1 if you have a working ioctlsocket FIONBIO function.]) + curl_cv_func_ioctlsocket_fionbio="yes" + else + AC_MSG_RESULT([no]) + curl_cv_func_ioctlsocket_fionbio="no" + fi +]) + + +dnl CURL_CHECK_FUNC_IOCTLSOCKET_CAMEL +dnl ------------------------------------------------- +dnl Verify if IoctlSocket is available, prototyped, and +dnl can be compiled. If all of these are true, and +dnl usage has not been previously disallowed with +dnl shell variable curl_disallow_ioctlsocket_camel, +dnl then HAVE_IOCTLSOCKET_CAMEL is defined. + +AC_DEFUN([CURL_CHECK_FUNC_IOCTLSOCKET_CAMEL], [ + AC_REQUIRE([CURL_INCLUDES_BSDSOCKET]) + + tst_links_ioctlsocket_camel="unknown" + tst_compi_ioctlsocket_camel="unknown" + tst_allow_ioctlsocket_camel="unknown" + + AC_MSG_CHECKING([if IoctlSocket can be linked]) + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_bsdsocket + ]],[[ + if(IoctlSocket(0, 0, 0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_links_ioctlsocket_camel="yes" + ],[ + AC_MSG_RESULT([no]) + tst_links_ioctlsocket_camel="no" + ]) + + if test "$tst_links_ioctlsocket_camel" = "yes"; then + AC_MSG_CHECKING([if IoctlSocket is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_bsdsocket + ]],[[ + if(IoctlSocket(0, 0, 0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_ioctlsocket_camel="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_ioctlsocket_camel="no" + ]) + fi + + if test "$tst_compi_ioctlsocket_camel" = "yes"; then + AC_MSG_CHECKING([if IoctlSocket usage allowed]) + if test "x$curl_disallow_ioctlsocket_camel" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_ioctlsocket_camel="yes" + else + AC_MSG_RESULT([no]) + tst_allow_ioctlsocket_camel="no" + fi + fi + + AC_MSG_CHECKING([if IoctlSocket might be used]) + if test "$tst_links_ioctlsocket_camel" = "yes" && + test "$tst_compi_ioctlsocket_camel" = "yes" && + test "$tst_allow_ioctlsocket_camel" = "yes"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_IOCTLSOCKET_CAMEL, 1, + [Define to 1 if you have the IoctlSocket camel case function.]) + curl_cv_func_ioctlsocket_camel="yes" + CURL_CHECK_FUNC_IOCTLSOCKET_CAMEL_FIONBIO + else + AC_MSG_RESULT([no]) + curl_cv_func_ioctlsocket_camel="no" + fi +]) + + +dnl CURL_CHECK_FUNC_IOCTLSOCKET_CAMEL_FIONBIO +dnl ------------------------------------------------- +dnl Verify if IoctlSocket with FIONBIO command is available, +dnl can be compiled, and seems to work. If all of these are +dnl true, then HAVE_IOCTLSOCKET_CAMEL_FIONBIO is defined. + +AC_DEFUN([CURL_CHECK_FUNC_IOCTLSOCKET_CAMEL_FIONBIO], [ + AC_REQUIRE([CURL_INCLUDES_BSDSOCKET]) + + tst_compi_ioctlsocket_camel_fionbio="unknown" + tst_allow_ioctlsocket_camel_fionbio="unknown" + + if test "$curl_cv_func_ioctlsocket_camel" = "yes"; then + AC_MSG_CHECKING([if IoctlSocket FIONBIO is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_bsdsocket + ]],[[ + long flags = 0; + if(IoctlSocket(0, FIONBIO, &flags)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_ioctlsocket_camel_fionbio="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_ioctlsocket_camel_fionbio="no" + ]) + fi + + if test "$tst_compi_ioctlsocket_camel_fionbio" = "yes"; then + AC_MSG_CHECKING([if IoctlSocket FIONBIO usage allowed]) + if test "x$curl_disallow_ioctlsocket_camel_fionbio" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_ioctlsocket_camel_fionbio="yes" + else + AC_MSG_RESULT([no]) + tst_allow_ioctlsocket_camel_fionbio="no" + fi + fi + + AC_MSG_CHECKING([if IoctlSocket FIONBIO might be used]) + if test "$tst_compi_ioctlsocket_camel_fionbio" = "yes" && + test "$tst_allow_ioctlsocket_camel_fionbio" = "yes"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_IOCTLSOCKET_CAMEL_FIONBIO, 1, + [Define to 1 if you have a working IoctlSocket camel case FIONBIO function.]) + curl_cv_func_ioctlsocket_camel_fionbio="yes" + else + AC_MSG_RESULT([no]) + curl_cv_func_ioctlsocket_camel_fionbio="no" + fi +]) + + +dnl CURL_CHECK_FUNC_MEMRCHR +dnl ------------------------------------------------- +dnl Verify if memrchr is available, prototyped, and +dnl can be compiled. If all of these are true, and +dnl usage has not been previously disallowed with +dnl shell variable curl_disallow_memrchr, then +dnl HAVE_MEMRCHR is defined. + +AC_DEFUN([CURL_CHECK_FUNC_MEMRCHR], [ + AC_REQUIRE([CURL_INCLUDES_STRING]) + + tst_links_memrchr="unknown" + tst_macro_memrchr="unknown" + tst_proto_memrchr="unknown" + tst_compi_memrchr="unknown" + tst_allow_memrchr="unknown" + + AC_MSG_CHECKING([if memrchr can be linked]) + AC_LINK_IFELSE([ + AC_LANG_FUNC_LINK_TRY([memrchr]) + ],[ + AC_MSG_RESULT([yes]) + tst_links_memrchr="yes" + ],[ + AC_MSG_RESULT([no]) + tst_links_memrchr="no" + ]) + + if test "$tst_links_memrchr" = "no"; then + AC_MSG_CHECKING([if memrchr seems a macro]) + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_string + ]],[[ + if(memrchr("", 0, 0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_macro_memrchr="yes" + ],[ + AC_MSG_RESULT([no]) + tst_macro_memrchr="no" + ]) + fi + + if test "$tst_links_memrchr" = "yes"; then + AC_MSG_CHECKING([if memrchr is prototyped]) + AC_EGREP_CPP([memrchr],[ + $curl_includes_string + ],[ + AC_MSG_RESULT([yes]) + tst_proto_memrchr="yes" + ],[ + AC_MSG_RESULT([no]) + tst_proto_memrchr="no" + ]) + fi + + if test "$tst_proto_memrchr" = "yes" || + test "$tst_macro_memrchr" = "yes"; then + AC_MSG_CHECKING([if memrchr is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_string + ]],[[ + if(memrchr("", 0, 0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_memrchr="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_memrchr="no" + ]) + fi + + if test "$tst_compi_memrchr" = "yes"; then + AC_MSG_CHECKING([if memrchr usage allowed]) + if test "x$curl_disallow_memrchr" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_memrchr="yes" + else + AC_MSG_RESULT([no]) + tst_allow_memrchr="no" + fi + fi + + AC_MSG_CHECKING([if memrchr might be used]) + if (test "$tst_proto_memrchr" = "yes" || + test "$tst_macro_memrchr" = "yes") && + test "$tst_compi_memrchr" = "yes" && + test "$tst_allow_memrchr" = "yes"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_MEMRCHR, 1, + [Define to 1 if you have the memrchr function or macro.]) + curl_cv_func_memrchr="yes" + else + AC_MSG_RESULT([no]) + curl_cv_func_memrchr="no" + fi +]) + + +dnl CURL_CHECK_FUNC_SIGACTION +dnl ------------------------------------------------- +dnl Verify if sigaction is available, prototyped, and +dnl can be compiled. If all of these are true, and +dnl usage has not been previously disallowed with +dnl shell variable curl_disallow_sigaction, then +dnl HAVE_SIGACTION is defined. + +AC_DEFUN([CURL_CHECK_FUNC_SIGACTION], [ + AC_REQUIRE([CURL_INCLUDES_SIGNAL]) + + tst_links_sigaction="unknown" + tst_proto_sigaction="unknown" + tst_compi_sigaction="unknown" + tst_allow_sigaction="unknown" + + AC_MSG_CHECKING([if sigaction can be linked]) + AC_LINK_IFELSE([ + AC_LANG_FUNC_LINK_TRY([sigaction]) + ],[ + AC_MSG_RESULT([yes]) + tst_links_sigaction="yes" + ],[ + AC_MSG_RESULT([no]) + tst_links_sigaction="no" + ]) + + if test "$tst_links_sigaction" = "yes"; then + AC_MSG_CHECKING([if sigaction is prototyped]) + AC_EGREP_CPP([sigaction],[ + $curl_includes_signal + ],[ + AC_MSG_RESULT([yes]) + tst_proto_sigaction="yes" + ],[ + AC_MSG_RESULT([no]) + tst_proto_sigaction="no" + ]) + fi + + if test "$tst_proto_sigaction" = "yes"; then + AC_MSG_CHECKING([if sigaction is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_signal + ]],[[ + if(sigaction(0, 0, 0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_sigaction="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_sigaction="no" + ]) + fi + + if test "$tst_compi_sigaction" = "yes"; then + AC_MSG_CHECKING([if sigaction usage allowed]) + if test "x$curl_disallow_sigaction" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_sigaction="yes" + else + AC_MSG_RESULT([no]) + tst_allow_sigaction="no" + fi + fi + + AC_MSG_CHECKING([if sigaction might be used]) + if test "$tst_links_sigaction" = "yes" && + test "$tst_proto_sigaction" = "yes" && + test "$tst_compi_sigaction" = "yes" && + test "$tst_allow_sigaction" = "yes"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_SIGACTION, 1, + [Define to 1 if you have the sigaction function.]) + curl_cv_func_sigaction="yes" + else + AC_MSG_RESULT([no]) + curl_cv_func_sigaction="no" + fi +]) + + +dnl CURL_CHECK_FUNC_SIGINTERRUPT +dnl ------------------------------------------------- +dnl Verify if siginterrupt is available, prototyped, and +dnl can be compiled. If all of these are true, and +dnl usage has not been previously disallowed with +dnl shell variable curl_disallow_siginterrupt, then +dnl HAVE_SIGINTERRUPT is defined. + +AC_DEFUN([CURL_CHECK_FUNC_SIGINTERRUPT], [ + AC_REQUIRE([CURL_INCLUDES_SIGNAL]) + + tst_links_siginterrupt="unknown" + tst_proto_siginterrupt="unknown" + tst_compi_siginterrupt="unknown" + tst_allow_siginterrupt="unknown" + + AC_MSG_CHECKING([if siginterrupt can be linked]) + AC_LINK_IFELSE([ + AC_LANG_FUNC_LINK_TRY([siginterrupt]) + ],[ + AC_MSG_RESULT([yes]) + tst_links_siginterrupt="yes" + ],[ + AC_MSG_RESULT([no]) + tst_links_siginterrupt="no" + ]) + + if test "$tst_links_siginterrupt" = "yes"; then + AC_MSG_CHECKING([if siginterrupt is prototyped]) + AC_EGREP_CPP([siginterrupt],[ + $curl_includes_signal + ],[ + AC_MSG_RESULT([yes]) + tst_proto_siginterrupt="yes" + ],[ + AC_MSG_RESULT([no]) + tst_proto_siginterrupt="no" + ]) + fi + + if test "$tst_proto_siginterrupt" = "yes"; then + AC_MSG_CHECKING([if siginterrupt is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_signal + ]],[[ + if(siginterrupt(0, 0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_siginterrupt="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_siginterrupt="no" + ]) + fi + + if test "$tst_compi_siginterrupt" = "yes"; then + AC_MSG_CHECKING([if siginterrupt usage allowed]) + if test "x$curl_disallow_siginterrupt" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_siginterrupt="yes" + else + AC_MSG_RESULT([no]) + tst_allow_siginterrupt="no" + fi + fi + + AC_MSG_CHECKING([if siginterrupt might be used]) + if test "$tst_links_siginterrupt" = "yes" && + test "$tst_proto_siginterrupt" = "yes" && + test "$tst_compi_siginterrupt" = "yes" && + test "$tst_allow_siginterrupt" = "yes"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_SIGINTERRUPT, 1, + [Define to 1 if you have the siginterrupt function.]) + curl_cv_func_siginterrupt="yes" + else + AC_MSG_RESULT([no]) + curl_cv_func_siginterrupt="no" + fi +]) + + +dnl CURL_CHECK_FUNC_SIGNAL +dnl ------------------------------------------------- +dnl Verify if signal is available, prototyped, and +dnl can be compiled. If all of these are true, and +dnl usage has not been previously disallowed with +dnl shell variable curl_disallow_signal, then +dnl HAVE_SIGNAL is defined. + +AC_DEFUN([CURL_CHECK_FUNC_SIGNAL], [ + AC_REQUIRE([CURL_INCLUDES_SIGNAL]) + + tst_links_signal="unknown" + tst_proto_signal="unknown" + tst_compi_signal="unknown" + tst_allow_signal="unknown" + + AC_MSG_CHECKING([if signal can be linked]) + AC_LINK_IFELSE([ + AC_LANG_FUNC_LINK_TRY([signal]) + ],[ + AC_MSG_RESULT([yes]) + tst_links_signal="yes" + ],[ + AC_MSG_RESULT([no]) + tst_links_signal="no" + ]) + + if test "$tst_links_signal" = "yes"; then + AC_MSG_CHECKING([if signal is prototyped]) + AC_EGREP_CPP([signal],[ + $curl_includes_signal + ],[ + AC_MSG_RESULT([yes]) + tst_proto_signal="yes" + ],[ + AC_MSG_RESULT([no]) + tst_proto_signal="no" + ]) + fi + + if test "$tst_proto_signal" = "yes"; then + AC_MSG_CHECKING([if signal is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_signal + ]],[[ + if(signal(0, 0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_signal="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_signal="no" + ]) + fi + + if test "$tst_compi_signal" = "yes"; then + AC_MSG_CHECKING([if signal usage allowed]) + if test "x$curl_disallow_signal" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_signal="yes" + else + AC_MSG_RESULT([no]) + tst_allow_signal="no" + fi + fi + + AC_MSG_CHECKING([if signal might be used]) + if test "$tst_links_signal" = "yes" && + test "$tst_proto_signal" = "yes" && + test "$tst_compi_signal" = "yes" && + test "$tst_allow_signal" = "yes"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_SIGNAL, 1, + [Define to 1 if you have the signal function.]) + curl_cv_func_signal="yes" + else + AC_MSG_RESULT([no]) + curl_cv_func_signal="no" + fi +]) + + +dnl CURL_CHECK_FUNC_SIGSETJMP +dnl ------------------------------------------------- +dnl Verify if sigsetjmp is available, prototyped, and +dnl can be compiled. If all of these are true, and +dnl usage has not been previously disallowed with +dnl shell variable curl_disallow_sigsetjmp, then +dnl HAVE_SIGSETJMP is defined. + +AC_DEFUN([CURL_CHECK_FUNC_SIGSETJMP], [ + AC_REQUIRE([CURL_INCLUDES_SETJMP]) + + tst_links_sigsetjmp="unknown" + tst_macro_sigsetjmp="unknown" + tst_proto_sigsetjmp="unknown" + tst_compi_sigsetjmp="unknown" + tst_allow_sigsetjmp="unknown" + + AC_MSG_CHECKING([if sigsetjmp can be linked]) + AC_LINK_IFELSE([ + AC_LANG_FUNC_LINK_TRY([sigsetjmp]) + ],[ + AC_MSG_RESULT([yes]) + tst_links_sigsetjmp="yes" + ],[ + AC_MSG_RESULT([no]) + tst_links_sigsetjmp="no" + ]) + + if test "$tst_links_sigsetjmp" = "no"; then + AC_MSG_CHECKING([if sigsetjmp seems a macro]) + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_setjmp + ]],[[ + sigjmp_buf env; + if(sigsetjmp(env, 0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_macro_sigsetjmp="yes" + ],[ + AC_MSG_RESULT([no]) + tst_macro_sigsetjmp="no" + ]) + fi + + if test "$tst_links_sigsetjmp" = "yes"; then + AC_MSG_CHECKING([if sigsetjmp is prototyped]) + AC_EGREP_CPP([sigsetjmp],[ + $curl_includes_setjmp + ],[ + AC_MSG_RESULT([yes]) + tst_proto_sigsetjmp="yes" + ],[ + AC_MSG_RESULT([no]) + tst_proto_sigsetjmp="no" + ]) + fi + + if test "$tst_proto_sigsetjmp" = "yes" || + test "$tst_macro_sigsetjmp" = "yes"; then + AC_MSG_CHECKING([if sigsetjmp is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_setjmp + ]],[[ + sigjmp_buf env; + if(sigsetjmp(env, 0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_sigsetjmp="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_sigsetjmp="no" + ]) + fi + + if test "$tst_compi_sigsetjmp" = "yes"; then + AC_MSG_CHECKING([if sigsetjmp usage allowed]) + if test "x$curl_disallow_sigsetjmp" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_sigsetjmp="yes" + else + AC_MSG_RESULT([no]) + tst_allow_sigsetjmp="no" + fi + fi + + AC_MSG_CHECKING([if sigsetjmp might be used]) + if (test "$tst_proto_sigsetjmp" = "yes" || + test "$tst_macro_sigsetjmp" = "yes") && + test "$tst_compi_sigsetjmp" = "yes" && + test "$tst_allow_sigsetjmp" = "yes"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_SIGSETJMP, 1, + [Define to 1 if you have the sigsetjmp function or macro.]) + curl_cv_func_sigsetjmp="yes" + else + AC_MSG_RESULT([no]) + curl_cv_func_sigsetjmp="no" + fi +]) + + +dnl CURL_CHECK_FUNC_SOCKET +dnl ------------------------------------------------- +dnl Verify if socket is available, prototyped, and +dnl can be compiled. If all of these are true, and +dnl usage has not been previously disallowed with +dnl shell variable curl_disallow_socket, then +dnl HAVE_SOCKET is defined. + +AC_DEFUN([CURL_CHECK_FUNC_SOCKET], [ + AC_REQUIRE([CURL_INCLUDES_WINSOCK2]) + AC_REQUIRE([CURL_INCLUDES_SYS_SOCKET]) + + tst_links_socket="unknown" + tst_proto_socket="unknown" + tst_compi_socket="unknown" + tst_allow_socket="unknown" + + AC_MSG_CHECKING([if socket can be linked]) + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_winsock2 + $curl_includes_bsdsocket + $curl_includes_sys_socket + ]],[[ + if(socket(0, 0, 0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_links_socket="yes" + ],[ + AC_MSG_RESULT([no]) + tst_links_socket="no" + ]) + + if test "$tst_links_socket" = "yes"; then + AC_MSG_CHECKING([if socket is prototyped]) + AC_EGREP_CPP([socket],[ + $curl_includes_winsock2 + $curl_includes_bsdsocket + $curl_includes_sys_socket + ],[ + AC_MSG_RESULT([yes]) + tst_proto_socket="yes" + ],[ + AC_MSG_RESULT([no]) + tst_proto_socket="no" + ]) + fi + + if test "$tst_proto_socket" = "yes"; then + AC_MSG_CHECKING([if socket is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_winsock2 + $curl_includes_bsdsocket + $curl_includes_sys_socket + ]],[[ + if(socket(0, 0, 0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_socket="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_socket="no" + ]) + fi + + if test "$tst_compi_socket" = "yes"; then + AC_MSG_CHECKING([if socket usage allowed]) + if test "x$curl_disallow_socket" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_socket="yes" + else + AC_MSG_RESULT([no]) + tst_allow_socket="no" + fi + fi + + AC_MSG_CHECKING([if socket might be used]) + if test "$tst_links_socket" = "yes" && + test "$tst_proto_socket" = "yes" && + test "$tst_compi_socket" = "yes" && + test "$tst_allow_socket" = "yes"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_SOCKET, 1, + [Define to 1 if you have the socket function.]) + curl_cv_func_socket="yes" + else + AC_MSG_RESULT([no]) + curl_cv_func_socket="no" + fi +]) + + +dnl CURL_CHECK_FUNC_SOCKETPAIR +dnl ------------------------------------------------- +dnl Verify if socketpair is available, prototyped, and +dnl can be compiled. If all of these are true, and +dnl usage has not been previously disallowed with +dnl shell variable curl_disallow_socketpair, then +dnl HAVE_SOCKETPAIR is defined. + +AC_DEFUN([CURL_CHECK_FUNC_SOCKETPAIR], [ + AC_REQUIRE([CURL_INCLUDES_SYS_SOCKET]) + + tst_links_socketpair="unknown" + tst_proto_socketpair="unknown" + tst_compi_socketpair="unknown" + tst_allow_socketpair="unknown" + + AC_MSG_CHECKING([if socketpair can be linked]) + AC_LINK_IFELSE([ + AC_LANG_FUNC_LINK_TRY([socketpair]) + ],[ + AC_MSG_RESULT([yes]) + tst_links_socketpair="yes" + ],[ + AC_MSG_RESULT([no]) + tst_links_socketpair="no" + ]) + + if test "$tst_links_socketpair" = "yes"; then + AC_MSG_CHECKING([if socketpair is prototyped]) + AC_EGREP_CPP([socketpair],[ + $curl_includes_sys_socket + ],[ + AC_MSG_RESULT([yes]) + tst_proto_socketpair="yes" + ],[ + AC_MSG_RESULT([no]) + tst_proto_socketpair="no" + ]) + fi + + if test "$tst_proto_socketpair" = "yes"; then + AC_MSG_CHECKING([if socketpair is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_sys_socket + ]],[[ + int sv[2]; + if(socketpair(0, 0, 0, sv)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_socketpair="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_socketpair="no" + ]) + fi + + if test "$tst_compi_socketpair" = "yes"; then + AC_MSG_CHECKING([if socketpair usage allowed]) + if test "x$curl_disallow_socketpair" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_socketpair="yes" + else + AC_MSG_RESULT([no]) + tst_allow_socketpair="no" + fi + fi + + AC_MSG_CHECKING([if socketpair might be used]) + if test "$tst_links_socketpair" = "yes" && + test "$tst_proto_socketpair" = "yes" && + test "$tst_compi_socketpair" = "yes" && + test "$tst_allow_socketpair" = "yes"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_SOCKETPAIR, 1, + [Define to 1 if you have the socketpair function.]) + curl_cv_func_socketpair="yes" + else + AC_MSG_RESULT([no]) + curl_cv_func_socketpair="no" + fi +]) + + +dnl CURL_CHECK_FUNC_STRCASECMP +dnl ------------------------------------------------- +dnl Verify if strcasecmp is available, prototyped, and +dnl can be compiled. If all of these are true, and +dnl usage has not been previously disallowed with +dnl shell variable curl_disallow_strcasecmp, then +dnl HAVE_STRCASECMP is defined. + +AC_DEFUN([CURL_CHECK_FUNC_STRCASECMP], [ + AC_REQUIRE([CURL_INCLUDES_STRING]) + + tst_links_strcasecmp="unknown" + tst_proto_strcasecmp="unknown" + tst_compi_strcasecmp="unknown" + tst_allow_strcasecmp="unknown" + + AC_MSG_CHECKING([if strcasecmp can be linked]) + AC_LINK_IFELSE([ + AC_LANG_FUNC_LINK_TRY([strcasecmp]) + ],[ + AC_MSG_RESULT([yes]) + tst_links_strcasecmp="yes" + ],[ + AC_MSG_RESULT([no]) + tst_links_strcasecmp="no" + ]) + + if test "$tst_links_strcasecmp" = "yes"; then + AC_MSG_CHECKING([if strcasecmp is prototyped]) + AC_EGREP_CPP([strcasecmp],[ + $curl_includes_string + ],[ + AC_MSG_RESULT([yes]) + tst_proto_strcasecmp="yes" + ],[ + AC_MSG_RESULT([no]) + tst_proto_strcasecmp="no" + ]) + fi + + if test "$tst_proto_strcasecmp" = "yes"; then + AC_MSG_CHECKING([if strcasecmp is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_string + ]],[[ + if(strcasecmp("", "")) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_strcasecmp="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_strcasecmp="no" + ]) + fi + + if test "$tst_compi_strcasecmp" = "yes"; then + AC_MSG_CHECKING([if strcasecmp usage allowed]) + if test "x$curl_disallow_strcasecmp" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_strcasecmp="yes" + else + AC_MSG_RESULT([no]) + tst_allow_strcasecmp="no" + fi + fi + + AC_MSG_CHECKING([if strcasecmp might be used]) + if test "$tst_links_strcasecmp" = "yes" && + test "$tst_proto_strcasecmp" = "yes" && + test "$tst_compi_strcasecmp" = "yes" && + test "$tst_allow_strcasecmp" = "yes"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_STRCASECMP, 1, + [Define to 1 if you have the strcasecmp function.]) + curl_cv_func_strcasecmp="yes" + else + AC_MSG_RESULT([no]) + curl_cv_func_strcasecmp="no" + fi +]) + +dnl CURL_CHECK_FUNC_STRCMPI +dnl ------------------------------------------------- +dnl Verify if strcmpi is available, prototyped, and +dnl can be compiled. If all of these are true, and +dnl usage has not been previously disallowed with +dnl shell variable curl_disallow_strcmpi, then +dnl HAVE_STRCMPI is defined. + +AC_DEFUN([CURL_CHECK_FUNC_STRCMPI], [ + AC_REQUIRE([CURL_INCLUDES_STRING]) + + tst_links_strcmpi="unknown" + tst_proto_strcmpi="unknown" + tst_compi_strcmpi="unknown" + tst_allow_strcmpi="unknown" + + AC_MSG_CHECKING([if strcmpi can be linked]) + AC_LINK_IFELSE([ + AC_LANG_FUNC_LINK_TRY([strcmpi]) + ],[ + AC_MSG_RESULT([yes]) + tst_links_strcmpi="yes" + ],[ + AC_MSG_RESULT([no]) + tst_links_strcmpi="no" + ]) + + if test "$tst_links_strcmpi" = "yes"; then + AC_MSG_CHECKING([if strcmpi is prototyped]) + AC_EGREP_CPP([strcmpi],[ + $curl_includes_string + ],[ + AC_MSG_RESULT([yes]) + tst_proto_strcmpi="yes" + ],[ + AC_MSG_RESULT([no]) + tst_proto_strcmpi="no" + ]) + fi + + if test "$tst_proto_strcmpi" = "yes"; then + AC_MSG_CHECKING([if strcmpi is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_string + ]],[[ + if(strcmpi(0, 0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_strcmpi="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_strcmpi="no" + ]) + fi + + if test "$tst_compi_strcmpi" = "yes"; then + AC_MSG_CHECKING([if strcmpi usage allowed]) + if test "x$curl_disallow_strcmpi" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_strcmpi="yes" + else + AC_MSG_RESULT([no]) + tst_allow_strcmpi="no" + fi + fi + + AC_MSG_CHECKING([if strcmpi might be used]) + if test "$tst_links_strcmpi" = "yes" && + test "$tst_proto_strcmpi" = "yes" && + test "$tst_compi_strcmpi" = "yes" && + test "$tst_allow_strcmpi" = "yes"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_STRCMPI, 1, + [Define to 1 if you have the strcmpi function.]) + curl_cv_func_strcmpi="yes" + else + AC_MSG_RESULT([no]) + curl_cv_func_strcmpi="no" + fi +]) + + +dnl CURL_CHECK_FUNC_STRERROR_R +dnl ------------------------------------------------- +dnl Verify if strerror_r is available, prototyped, can be compiled and +dnl seems to work. If all of these are true, and usage has not been +dnl previously disallowed with shell variable curl_disallow_strerror_r, +dnl then HAVE_STRERROR_R is defined, as well as one of +dnl HAVE_GLIBC_STRERROR_R or HAVE_POSIX_STRERROR_R. +dnl +dnl glibc-style strerror_r: +dnl +dnl char *strerror_r(int errnum, char *workbuf, size_t bufsize); +dnl +dnl glibc-style strerror_r returns a pointer to the error string, +dnl and might use the provided workbuf as a scratch area if needed. A +dnl quick test on a few systems shows that it is usually not used at all. +dnl +dnl POSIX-style strerror_r: +dnl +dnl int strerror_r(int errnum, char *resultbuf, size_t bufsize); +dnl +dnl POSIX-style strerror_r returns 0 upon successful completion and the +dnl error string in the provided resultbuf. +dnl + +AC_DEFUN([CURL_CHECK_FUNC_STRERROR_R], [ + AC_REQUIRE([CURL_INCLUDES_STDLIB]) + AC_REQUIRE([CURL_INCLUDES_STRING]) + + tst_links_strerror_r="unknown" + tst_proto_strerror_r="unknown" + tst_compi_strerror_r="unknown" + tst_glibc_strerror_r="unknown" + tst_posix_strerror_r="unknown" + tst_allow_strerror_r="unknown" + tst_works_glibc_strerror_r="unknown" + tst_works_posix_strerror_r="unknown" + tst_glibc_strerror_r_type_arg3="unknown" + tst_posix_strerror_r_type_arg3="unknown" + + AC_MSG_CHECKING([if strerror_r can be linked]) + AC_LINK_IFELSE([ + AC_LANG_FUNC_LINK_TRY([strerror_r]) + ],[ + AC_MSG_RESULT([yes]) + tst_links_strerror_r="yes" + ],[ + AC_MSG_RESULT([no]) + tst_links_strerror_r="no" + ]) + + if test "$tst_links_strerror_r" = "yes"; then + AC_MSG_CHECKING([if strerror_r is prototyped]) + AC_EGREP_CPP([strerror_r],[ + $curl_includes_string + ],[ + AC_MSG_RESULT([yes]) + tst_proto_strerror_r="yes" + ],[ + AC_MSG_RESULT([no]) + tst_proto_strerror_r="no" + ]) + fi + + if test "$tst_proto_strerror_r" = "yes"; then + AC_MSG_CHECKING([if strerror_r is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_string + ]],[[ + char s[1]; + if(strerror_r(0, s, 0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_strerror_r="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_strerror_r="no" + ]) + fi + + if test "$tst_compi_strerror_r" = "yes"; then + AC_MSG_CHECKING([if strerror_r is glibc like]) + tst_glibc_strerror_r_type_arg3="unknown" + for arg3 in 'size_t' 'int' 'unsigned int'; do + if test "$tst_glibc_strerror_r_type_arg3" = "unknown"; then + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_string + char *strerror_r(int errnum, char *workbuf, $arg3 bufsize); + ]],[[ + char s[1]; + if(strerror_r(0, s, 0)) + return 1; + (void)s; + ]]) + ],[ + tst_glibc_strerror_r_type_arg3="$arg3" + ]) + fi + done + case "$tst_glibc_strerror_r_type_arg3" in + unknown) + AC_MSG_RESULT([no]) + tst_glibc_strerror_r="no" + ;; + *) + AC_MSG_RESULT([yes]) + tst_glibc_strerror_r="yes" + ;; + esac + fi + + dnl only do runtime verification when not cross-compiling + if test "$cross_compiling" != "yes" && + test "$tst_glibc_strerror_r" = "yes"; then + AC_MSG_CHECKING([if strerror_r seems to work]) + CURL_RUN_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_stdlib + $curl_includes_string + #include + ]],[[ + char buffer[1024]; + char *string = 0; + buffer[0] = '\0'; + string = strerror_r(EACCES, buffer, sizeof(buffer)); + if(!string) + return 1; /* fail */ + if(!string[0]) + return 1; /* fail */ + else + return 0; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_works_glibc_strerror_r="yes" + ],[ + AC_MSG_RESULT([no]) + tst_works_glibc_strerror_r="no" + ]) + fi + + if test "$tst_compi_strerror_r" = "yes" && + test "$tst_works_glibc_strerror_r" != "yes"; then + AC_MSG_CHECKING([if strerror_r is POSIX like]) + tst_posix_strerror_r_type_arg3="unknown" + for arg3 in 'size_t' 'int' 'unsigned int'; do + if test "$tst_posix_strerror_r_type_arg3" = "unknown"; then + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_string + int strerror_r(int errnum, char *resultbuf, $arg3 bufsize); + ]],[[ + char s[1]; + if(strerror_r(0, s, 0)) + return 1; + (void)s; + ]]) + ],[ + tst_posix_strerror_r_type_arg3="$arg3" + ]) + fi + done + case "$tst_posix_strerror_r_type_arg3" in + unknown) + AC_MSG_RESULT([no]) + tst_posix_strerror_r="no" + ;; + *) + AC_MSG_RESULT([yes]) + tst_posix_strerror_r="yes" + ;; + esac + fi + + dnl only do runtime verification when not cross-compiling + if test "$cross_compiling" != "yes" && + test "$tst_posix_strerror_r" = "yes"; then + AC_MSG_CHECKING([if strerror_r seems to work]) + CURL_RUN_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_stdlib + $curl_includes_string + #include + ]],[[ + char buffer[1024]; + int error = 1; + buffer[0] = '\0'; + error = strerror_r(EACCES, buffer, sizeof(buffer)); + if(error) + return 1; /* fail */ + if(buffer[0] == '\0') + return 1; /* fail */ + else + return 0; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_works_posix_strerror_r="yes" + ],[ + AC_MSG_RESULT([no]) + tst_works_posix_strerror_r="no" + ]) + fi + + if test "$tst_works_glibc_strerror_r" = "yes"; then + tst_posix_strerror_r="no" + fi + if test "$tst_works_posix_strerror_r" = "yes"; then + tst_glibc_strerror_r="no" + fi + if test "$tst_glibc_strerror_r" = "yes" && + test "$tst_works_glibc_strerror_r" != "no" && + test "$tst_posix_strerror_r" != "yes"; then + tst_allow_strerror_r="check" + fi + if test "$tst_posix_strerror_r" = "yes" && + test "$tst_works_posix_strerror_r" != "no" && + test "$tst_glibc_strerror_r" != "yes"; then + tst_allow_strerror_r="check" + fi + if test "$tst_allow_strerror_r" = "check"; then + AC_MSG_CHECKING([if strerror_r usage allowed]) + if test "x$curl_disallow_strerror_r" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_strerror_r="yes" + else + AC_MSG_RESULT([no]) + tst_allow_strerror_r="no" + fi + fi + + AC_MSG_CHECKING([if strerror_r might be used]) + if test "$tst_links_strerror_r" = "yes" && + test "$tst_proto_strerror_r" = "yes" && + test "$tst_compi_strerror_r" = "yes" && + test "$tst_allow_strerror_r" = "yes"; then + AC_MSG_RESULT([yes]) + if test "$tst_glibc_strerror_r" = "yes"; then + AC_DEFINE_UNQUOTED(HAVE_STRERROR_R, 1, + [Define to 1 if you have the strerror_r function.]) + AC_DEFINE_UNQUOTED(HAVE_GLIBC_STRERROR_R, 1, + [Define to 1 if you have a working glibc-style strerror_r function.]) + fi + if test "$tst_posix_strerror_r" = "yes"; then + AC_DEFINE_UNQUOTED(HAVE_STRERROR_R, 1, + [Define to 1 if you have the strerror_r function.]) + AC_DEFINE_UNQUOTED(HAVE_POSIX_STRERROR_R, 1, + [Define to 1 if you have a working POSIX-style strerror_r function.]) + fi + curl_cv_func_strerror_r="yes" + else + AC_MSG_RESULT([no]) + curl_cv_func_strerror_r="no" + fi + + if test "$tst_compi_strerror_r" = "yes" && + test "$tst_allow_strerror_r" = "unknown"; then + AC_MSG_WARN([cannot determine strerror_r() style: edit lib/curl_config.h manually.]) + fi +]) + + +dnl CURL_CHECK_FUNC_STRICMP +dnl ------------------------------------------------- +dnl Verify if stricmp is available, prototyped, and +dnl can be compiled. If all of these are true, and +dnl usage has not been previously disallowed with +dnl shell variable curl_disallow_stricmp, then +dnl HAVE_STRICMP is defined. + +AC_DEFUN([CURL_CHECK_FUNC_STRICMP], [ + AC_REQUIRE([CURL_INCLUDES_STRING]) + + tst_links_stricmp="unknown" + tst_proto_stricmp="unknown" + tst_compi_stricmp="unknown" + tst_allow_stricmp="unknown" + + AC_MSG_CHECKING([if stricmp can be linked]) + AC_LINK_IFELSE([ + AC_LANG_FUNC_LINK_TRY([stricmp]) + ],[ + AC_MSG_RESULT([yes]) + tst_links_stricmp="yes" + ],[ + AC_MSG_RESULT([no]) + tst_links_stricmp="no" + ]) + + if test "$tst_links_stricmp" = "yes"; then + AC_MSG_CHECKING([if stricmp is prototyped]) + AC_EGREP_CPP([stricmp],[ + $curl_includes_string + ],[ + AC_MSG_RESULT([yes]) + tst_proto_stricmp="yes" + ],[ + AC_MSG_RESULT([no]) + tst_proto_stricmp="no" + ]) + fi + + if test "$tst_proto_stricmp" = "yes"; then + AC_MSG_CHECKING([if stricmp is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_string + ]],[[ + if(stricmp(0, 0)) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_stricmp="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_stricmp="no" + ]) + fi + + if test "$tst_compi_stricmp" = "yes"; then + AC_MSG_CHECKING([if stricmp usage allowed]) + if test "x$curl_disallow_stricmp" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_stricmp="yes" + else + AC_MSG_RESULT([no]) + tst_allow_stricmp="no" + fi + fi + + AC_MSG_CHECKING([if stricmp might be used]) + if test "$tst_links_stricmp" = "yes" && + test "$tst_proto_stricmp" = "yes" && + test "$tst_compi_stricmp" = "yes" && + test "$tst_allow_stricmp" = "yes"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_STRICMP, 1, + [Define to 1 if you have the stricmp function.]) + curl_cv_func_stricmp="yes" + else + AC_MSG_RESULT([no]) + curl_cv_func_stricmp="no" + fi +]) + + +dnl CURL_CHECK_FUNC_MEMSET_S +dnl ------------------------------------------------- +dnl Verify if memset_s is available, prototyped, and +dnl can be compiled. If all of these are true, and +dnl usage has not been previously disallowed with +dnl shell variable curl_disallow_memset_s, then +dnl HAVE_MEMSET_S is defined. + +AC_DEFUN([CURL_CHECK_FUNC_MEMSET_S], [ + AC_REQUIRE([CURL_INCLUDES_STRING]) + + tst_links_memset_s="unknown" + tst_proto_memset_s="unknown" + tst_compi_memset_s="unknown" + tst_allow_memset_s="unknown" + + AC_MSG_CHECKING([if memset_s can be linked]) + AC_LINK_IFELSE([ + AC_LANG_FUNC_LINK_TRY([memset_s]) + ],[ + AC_MSG_RESULT([yes]) + tst_links_memset_s="yes" + ],[ + AC_MSG_RESULT([no]) + tst_links_memset_s="no" + ]) + + if test "$tst_links_memset_s" = "yes"; then + AC_MSG_CHECKING([if memset_s is prototyped]) + AC_EGREP_CPP([memset_s],[ + $curl_includes_string + ],[ + AC_MSG_RESULT([yes]) + tst_proto_memset_s="yes" + ],[ + AC_MSG_RESULT([no]) + tst_proto_memset_s="no" + ]) + fi + + if test "$tst_proto_memset_s" = "yes"; then + AC_MSG_CHECKING([if memset_s is compilable]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_string + ]],[[ + char buf[2]; + if(memset_s(buf, sizeof(buf), 0, sizeof(buf))) + return 1; + ]]) + ],[ + AC_MSG_RESULT([yes]) + tst_compi_memset_s="yes" + ],[ + AC_MSG_RESULT([no]) + tst_compi_memset_s="no" + ]) + fi + + if test "$tst_compi_memset_s" = "yes"; then + AC_MSG_CHECKING([if memset_s usage allowed]) + if test "x$curl_disallow_memset_s" != "xyes"; then + AC_MSG_RESULT([yes]) + tst_allow_memset_s="yes" + else + AC_MSG_RESULT([no]) + tst_allow_memset_s="no" + fi + fi + + AC_MSG_CHECKING([if memset_s might be used]) + if test "$tst_links_memset_s" = "yes" && + test "$tst_proto_memset_s" = "yes" && + test "$tst_compi_memset_s" = "yes" && + test "$tst_allow_memset_s" = "yes"; then + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_MEMSET_S, 1, + [Define to 1 if you have the memset_s function.]) + curl_cv_func_memset_s="yes" + else + AC_MSG_RESULT([no]) + curl_cv_func_memset_s="no" + fi +]) + +dnl CURL_RUN_IFELSE +dnl ------------------------------------------------- +dnl Wrapper macro to use instead of AC_RUN_IFELSE. It +dnl sets LD_LIBRARY_PATH locally for this run only, from the +dnl CURL_LIBRARY_PATH variable. It keeps the LD_LIBRARY_PATH +dnl changes contained within this macro. + +AC_DEFUN([CURL_RUN_IFELSE], [ + if test "$curl_cv_apple" = "yes"; then + AC_RUN_IFELSE([AC_LANG_SOURCE([$1])], $2, $3, $4) + else + oldcc=$CC + old=$LD_LIBRARY_PATH + CC="sh ./run-compiler" + LD_LIBRARY_PATH=$CURL_LIBRARY_PATH:$old + export LD_LIBRARY_PATH + AC_RUN_IFELSE([AC_LANG_SOURCE([$1])], $2, $3, $4) + # restore + LD_LIBRARY_PATH=$old + CC=$oldcc + fi +]) + +dnl CURL_COVERAGE +dnl -------------------------------------------------- +dnl Switch on options and libs to build with gcc's code coverage. +dnl + +AC_DEFUN([CURL_COVERAGE],[ + AC_REQUIRE([AC_PROG_SED]) + AC_REQUIRE([AC_ARG_ENABLE]) + AC_MSG_CHECKING([for code coverage support]) + coverage="no" + curl_coverage_msg="disabled" + + dnl check if enabled by argument + AC_ARG_ENABLE(code-coverage, + AS_HELP_STRING([--enable-code-coverage], [Provide code coverage]), + coverage="$enableval") + + dnl if not gcc or clang switch off again + AS_IF([test "$compiler_id" != "GNU_C" && test "$compiler_id" != "CLANG" && test "$compiler_id" != "APPLECLANG"], coverage="no" ) + AC_MSG_RESULT($coverage) + + if test "x$coverage" = "xyes"; then + curl_coverage_msg="enabled" + + CPPFLAGS="$CPPFLAGS -DNDEBUG" + CFLAGS="$CFLAGS -O0 -g" + + if test "$compiler_id" = "GNU_C"; then + AC_CHECK_TOOL([GCOV], [gcov], [gcov]) + if test -z "$GCOV"; then + AC_MSG_ERROR([needs gcov for code coverage]) + fi + AC_CHECK_PROG([LCOV], [lcov], [lcov]) + if test -z "$LCOV"; then + AC_MSG_ERROR([needs lcov for code coverage]) + fi + CFLAGS="$CFLAGS -ftest-coverage -fprofile-arcs" + LIBS="$LIBS -lgcov" + else + CFLAGS="$CFLAGS -fprofile-instr-generate -fcoverage-mapping" + LDFLAGS="$LDFLAGS -fprofile-instr-generate -fcoverage-mapping" + fi + fi +]) + +dnl CURL_ATOMIC +dnl ------------------------------------------------------------- +dnl Check if _Atomic works. But only check if stdatomic.h exists. +dnl + +AC_DEFUN([CURL_ATOMIC],[ + AC_CHECK_HEADERS(stdatomic.h, [ + AC_MSG_CHECKING([if _Atomic is available]) + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([[ + $curl_includes_unistd + ]],[[ + _Atomic int i = 0; + i = 4; // Force an atomic-write operation. + (void)i; + ]]) + ],[ + AC_MSG_RESULT([yes]) + AC_DEFINE_UNQUOTED(HAVE_ATOMIC, 1, + [Define to 1 if you have _Atomic support.]) + tst_atomic="yes" + ],[ + AC_MSG_RESULT([no]) + tst_atomic="no" + ]) + ]) +]) + +dnl Rewrite inspired by the functionality once provided by +dnl AX_COMPILE_CHECK_SIZEOF. Uses the switch() "trick" to find the size of the +dnl given type. +dnl +dnl This code fails to compile: +dnl +dnl switch() { case 0: case 0: } +dnl +dnl By making the second case number a boolean check, it fails to compile the +dnl test code when the boolean is false and thus creating a zero, making it a +dnl duplicated case label. If the boolean equals true, it becomes a one, the +dnl code compiles and we know it was a match. +dnl +dnl The check iterates over all possible sizes and stops as soon it compiles +dnl error-free. +dnl +dnl Usage: +dnl +dnl CURL_SIZEOF(TYPE, [HEADERS]) +dnl + +AC_DEFUN([CURL_SIZEOF], [ + dnl The #define name to make autoheader put the name in curl_config.h.in + define(TYPE, translit(sizeof_$1, [a-z *], [A-Z_P])) + + AC_MSG_CHECKING(size of $1) + r=0 + dnl Check the sizes in a reasonable order + for typesize in 8 4 2 16 1; do + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + #include + $2 + ]],[ + switch(0) { + case 0: + case (sizeof($1) == $typesize):; + } + ]) + ],[ + r=$typesize + ],[ + r=0 + ]) + dnl get out of the loop once matched + if test "$r" -gt 0; then + break; + fi + done + if test "$r" -eq 0; then + AC_MSG_ERROR([Failed to find size of $1]) + fi + AC_MSG_RESULT($r) + dnl lowercase and underscore instead of space + tname=`echo "ac_cv_sizeof_$1" | tr A-Z a-z | tr " " "_"` + eval "$tname=$r" + + AC_DEFINE_UNQUOTED(TYPE, [$r], [Size of $1 in number of bytes]) +]) diff --git a/3rdparty/curl-8.21.0/m4/curl-gnutls.m4 b/3rdparty/curl-8.21.0/m4/curl-gnutls.m4 new file mode 100644 index 0000000000..3eab1c5d31 --- /dev/null +++ b/3rdparty/curl-8.21.0/m4/curl-gnutls.m4 @@ -0,0 +1,215 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +#*************************************************************************** + +dnl ---------------------------------------------------- +dnl check for GnuTLS +dnl ---------------------------------------------------- + +AC_DEFUN([CURL_WITH_GNUTLS], [ +if test "x$OPT_GNUTLS" != "xno"; then + ssl_msg= + + addld="" + addlib="" + gtlslib="" + version="" + addcflags="" + + if test "x$OPT_GNUTLS" = "xyes"; then + dnl this is with no particular path given + CURL_CHECK_PKGCONFIG(gnutls) + + if test "$PKGCONFIG" != "no"; then + addlib=`$PKGCONFIG --libs-only-l gnutls` + addld=`$PKGCONFIG --libs-only-L gnutls` + addcflags=`$PKGCONFIG --cflags-only-I gnutls` + version=`$PKGCONFIG --modversion gnutls` + gtlslib=`echo $addld | $SED -e 's/^-L//'` + else + dnl without pkg-config, we try libgnutls-config as that was how it + dnl used to be done + check=`libgnutls-config --version 2>/dev/null` + if test -n "$check"; then + addlib=`libgnutls-config --libs` + addcflags=`libgnutls-config --cflags` + version=`libgnutls-config --version` + gtlslib=`libgnutls-config --prefix`/lib$libsuff + fi + fi + else + dnl this is with a given path, first check if there is a libgnutls-config + dnl there and if not, make an educated guess + cfg=$OPT_GNUTLS/bin/libgnutls-config + check=`$cfg --version 2>/dev/null` + if test -n "$check"; then + addlib=`$cfg --libs` + addcflags=`$cfg --cflags` + version=`$cfg --version` + gtlslib=`$cfg --prefix`/lib$libsuff + else + dnl without pkg-config and libgnutls-config, we guess a lot! + addlib=-lgnutls + addld=-L$OPT_GNUTLS/lib$libsuff + addcflags=-I$OPT_GNUTLS/include + dnl we do not know + version="" + gtlslib=$OPT_GNUTLS/lib$libsuff + fi + fi + + if test -z "$version"; then + dnl lots of efforts, still no go + version="unknown" + fi + + if test -n "$addlib"; then + + CLEANLIBS="$LIBS" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + + LIBS="$addlib $LIBS" + LDFLAGS="$LDFLAGS $addld" + LDFLAGSPC="$LDFLAGSPC $addld" + if test "$addcflags" != "-I/usr/include"; then + CPPFLAGS="$CPPFLAGS $addcflags" + fi + + dnl this function is selected since it was introduced in 3.1.10 + AC_CHECK_LIB(gnutls, gnutls_x509_crt_get_dn2, + [ + AC_DEFINE(USE_GNUTLS, 1, [if GnuTLS is enabled]) + GNUTLS_ENABLED=1 + USE_GNUTLS="yes" + ssl_msg="GnuTLS" + QUIC_ENABLED=yes + test "gnutls" != "$DEFAULT_SSL_BACKEND" || VALID_DEFAULT_SSL_BACKEND=yes + ], + [ + LIBS="$CLEANLIBS" + CPPFLAGS="$CLEANCPPFLAGS" + LDFLAGS="$CLEANLDFLAGS" + LDFLAGSPC="$CLEANLDFLAGSPC" + ]) + + if test "$USE_GNUTLS" = "yes"; then + AC_MSG_NOTICE([detected GnuTLS version $version]) + check_for_ca_bundle=1 + if test -n "$gtlslib"; then + dnl when shared libs were found in a path that the runtime + dnl linker does not search through, we need to add it to + dnl CURL_LIBRARY_PATH to prevent further configure tests to fail + dnl due to this + if test "$cross_compiling" != "yes"; then + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$gtlslib" + export CURL_LIBRARY_PATH + AC_MSG_NOTICE([Added $gtlslib to CURL_LIBRARY_PATH]) + fi + fi + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE gnutls" + fi + fi + + test -z "$ssl_msg" || ssl_backends="${ssl_backends:+$ssl_backends, }$ssl_msg" +fi dnl GnuTLS not disabled + +dnl +dnl Check which crypto backend GnuTLS uses +dnl +if test "$GNUTLS_ENABLED" = "1"; then + USE_GNUTLS_NETTLE= + dnl First check if we can detect either crypto library via transitive linking + AC_CHECK_LIB(gnutls, nettle_md5_init, [ USE_GNUTLS_NETTLE=1 ]) + + dnl If not, try linking directly to both of them to see if they are available + if test -z "$USE_GNUTLS_NETTLE"; then + + dnl this is with no particular path given + CURL_CHECK_PKGCONFIG(nettle) + + if test "$PKGCONFIG" != "no"; then + addlib=`$PKGCONFIG --libs-only-l nettle` + addld=`$PKGCONFIG --libs-only-L nettle` + addcflags=`$PKGCONFIG --cflags-only-I nettle` + version=`$PKGCONFIG --modversion nettle` + gtlslib=`echo $addld | $SED -e 's/^-L//'` + + if test -n "$addlib"; then + + CLEANLIBS="$LIBS" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + + LIBS="$addlib $LIBS" + LDFLAGS="$LDFLAGS $addld" + LDFLAGSPC="$LDFLAGSPC $addld" + if test "$addcflags" != "-I/usr/include"; then + CPPFLAGS="$CPPFLAGS $addcflags" + fi + + AC_CHECK_LIB(nettle, nettle_md5_init, + [ + USE_GNUTLS_NETTLE=1 + ], + [ + LIBS="$CLEANLIBS" + CPPFLAGS="$CLEANCPPFLAGS" + LDFLAGS="$CLEANLDFLAGS" + LDFLAGSPC="$CLEANLDFLAGSPC" + ]) + + if test "$USE_GNUTLS_NETTLE" = "1"; then + if test -z "$version"; then + version="unknown" + fi + AC_MSG_NOTICE([detected nettle version $version]) + fi + fi + fi + if test -z "$USE_GNUTLS_NETTLE"; then + AC_MSG_ERROR([GnuTLS found, but nettle was not found]) + fi + else + LIBS="-lnettle $LIBS" + fi + + if test "$USE_GNUTLS_NETTLE" = "1"; then + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE nettle" + fi + + dnl --- + dnl We require GnuTLS with SRP support. + dnl + dnl In GnuTLS 3.8.0 (2023-02-10) and upper, this check always succeeds. + dnl Detecting actual TLS-SRP support needs poking the API at runtime. + dnl --- + AC_CHECK_LIB(gnutls, gnutls_srp_verifier, + [ + AC_DEFINE(HAVE_GNUTLS_SRP, 1, [if you have the function gnutls_srp_verifier]) + HAVE_GNUTLS_SRP=1 + ]) +fi +]) diff --git a/3rdparty/curl-8.21.0/m4/curl-mbedtls.m4 b/3rdparty/curl-8.21.0/m4/curl-mbedtls.m4 new file mode 100644 index 0000000000..0c19f07237 --- /dev/null +++ b/3rdparty/curl-8.21.0/m4/curl-mbedtls.m4 @@ -0,0 +1,117 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +#*************************************************************************** + +dnl ---------------------------------------------------- +dnl check for mbedTLS +dnl ---------------------------------------------------- +AC_DEFUN([CURL_WITH_MBEDTLS], [ + +if test "x$OPT_MBEDTLS" != "xno"; then + _cppflags=$CPPFLAGS + _ldflags=$LDFLAGS + _ldflagspc=$LDFLAGSPC + ssl_msg= + + if test "x$OPT_MBEDTLS" = "xyes"; then + OPT_MBEDTLS="" + fi + + if test -z "$OPT_MBEDTLS"; then + dnl check for lib first without setting any new path + + AC_CHECK_LIB(mbedtls, mbedtls_ssl_init, + dnl libmbedtls found, set the variable + [ + AC_DEFINE(USE_MBEDTLS, 1, [if mbedTLS is enabled]) + MBEDTLS_ENABLED=1 + USE_MBEDTLS="yes" + ssl_msg="mbedTLS" + test "mbedtls" != "$DEFAULT_SSL_BACKEND" || VALID_DEFAULT_SSL_BACKEND=yes + ], [], -lmbedx509 -lmbedcrypto) + fi + + addld="" + addlib="" + addcflags="" + mbedtlslib="" + + if test "$USE_MBEDTLS" != "yes" && test -n "$OPT_MBEDTLS"; then + dnl add the path and test again + addld=-L$OPT_MBEDTLS/lib$libsuff + addcflags=-I$OPT_MBEDTLS/include + mbedtlslib=$OPT_MBEDTLS/lib$libsuff + + LDFLAGS="$LDFLAGS $addld" + LDFLAGSPC="$LDFLAGSPC $addld" + if test "$addcflags" != "-I/usr/include"; then + CPPFLAGS="$CPPFLAGS $addcflags" + fi + + AC_CHECK_LIB(mbedtls, mbedtls_ssl_init, + [ + AC_DEFINE(USE_MBEDTLS, 1, [if mbedTLS is enabled]) + MBEDTLS_ENABLED=1 + USE_MBEDTLS="yes" + ssl_msg="mbedTLS" + test "mbedtls" != "$DEFAULT_SSL_BACKEND" || VALID_DEFAULT_SSL_BACKEND=yes + ], + [ + CPPFLAGS=$_cppflags + LDFLAGS=$_ldflags + LDFLAGSPC=$_ldflagspc + ], -lmbedx509 -lmbedcrypto) + fi + + if test "$USE_MBEDTLS" = "yes"; then + AC_MSG_NOTICE([detected mbedTLS]) + check_for_ca_bundle=1 + + LIBS="-lmbedtls -lmbedx509 -lmbedcrypto $LIBS" + + if test -n "$mbedtlslib"; then + dnl when shared libs were found in a path that the runtime + dnl linker does not search through, we need to add it to + dnl CURL_LIBRARY_PATH to prevent further configure tests to fail + dnl due to this + if test "$cross_compiling" != "yes"; then + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$mbedtlslib" + export CURL_LIBRARY_PATH + AC_MSG_NOTICE([Added $mbedtlslib to CURL_LIBRARY_PATH]) + fi + fi + dnl FIXME: Enable when mbedTLS was detected via pkg-config + if false; then + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE mbedtls mbedx509 mbedcrypto" + fi + + dnl Check DES support in mbedTLS <4. + AC_CHECK_FUNCS(mbedtls_des_crypt_ecb) + if test "$ac_cv_func_mbedtls_des_crypt_ecb" = 'yes'; then + HAVE_MBEDTLS_DES_CRYPT_ECB=1 + fi + fi + + test -z "$ssl_msg" || ssl_backends="${ssl_backends:+$ssl_backends, }$ssl_msg" +fi dnl mbedTLS not disabled +]) diff --git a/3rdparty/curl-8.21.0/m4/curl-openssl.m4 b/3rdparty/curl-8.21.0/m4/curl-openssl.m4 new file mode 100644 index 0000000000..816e7631fa --- /dev/null +++ b/3rdparty/curl-8.21.0/m4/curl-openssl.m4 @@ -0,0 +1,394 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +#*************************************************************************** + +dnl File version for 'aclocal' use. Keep it a single number. +dnl serial 5 + +dnl ********************************************************************** +dnl Check for OpenSSL libraries and headers +dnl ********************************************************************** + +AC_DEFUN([CURL_WITH_OPENSSL], [ +if test "x$OPT_OPENSSL" != "xno"; then + ssl_msg= + + dnl backup the pre-detection variables + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + CLEANLIBS="$LIBS" + + dnl This is for MSYS/MinGW + case $host in + *-*-msys* | *-*-mingw*) + AC_MSG_CHECKING([for gdi32]) + my_ac_save_LIBS=$LIBS + LIBS="-lgdi32 $LIBS" + AC_LINK_IFELSE([ AC_LANG_PROGRAM([[ + #ifndef WIN32_LEAN_AND_MEAN + #define WIN32_LEAN_AND_MEAN + #endif + #include + #include + ]], + [[ + GdiFlush(); + ]])], + [ dnl worked! + AC_MSG_RESULT([yes])], + [ dnl failed, restore LIBS + LIBS=$my_ac_save_LIBS + AC_MSG_RESULT(no)] + ) + ;; + esac + + case "$OPT_OPENSSL" in + yes) + dnl --with-openssl (without path) used + PKGTEST="yes" + PREFIX_OPENSSL= + ;; + *) + dnl check the given --with-openssl spot + PKGTEST="no" + PREFIX_OPENSSL=$OPT_OPENSSL + + dnl Try pkg-config even when cross-compiling. Since we + dnl specify PKG_CONFIG_LIBDIR we are only looking where + dnl the user told us to look + OPENSSL_PCDIR="$OPT_OPENSSL/lib/pkgconfig" + if test -f "$OPENSSL_PCDIR/openssl.pc"; then + AC_MSG_NOTICE([PKG_CONFIG_LIBDIR is set to "$OPENSSL_PCDIR"]) + PKGTEST="yes" + fi + + if test "$PKGTEST" != "yes"; then + dnl try lib64 instead + OPENSSL_PCDIR="$OPT_OPENSSL/lib64/pkgconfig" + if test -f "$OPENSSL_PCDIR/openssl.pc"; then + AC_MSG_NOTICE([PKG_CONFIG_LIBDIR is set to "$OPENSSL_PCDIR"]) + PKGTEST="yes" + fi + fi + + if test "$PKGTEST" != "yes"; then + if test ! -f "$PREFIX_OPENSSL/include/openssl/ssl.h"; then + AC_MSG_ERROR([$PREFIX_OPENSSL is a bad --with-openssl prefix!]) + fi + fi + + dnl in case pkg-config comes up empty, use what we got + dnl via --with-openssl + LIB_OPENSSL="$PREFIX_OPENSSL/lib$libsuff" + if test "$PREFIX_OPENSSL" != "/usr"; then + SSL_LDFLAGS="-L$LIB_OPENSSL" + SSL_CPPFLAGS="-I$PREFIX_OPENSSL/include" + fi + ;; + esac + + if test "$PKGTEST" = "yes"; then + + CURL_CHECK_PKGCONFIG(openssl, [$OPENSSL_PCDIR]) + + if test "$PKGCONFIG" != "no"; then + SSL_LIBS=`CURL_EXPORT_PCDIR([$OPENSSL_PCDIR]) + $PKGCONFIG --libs-only-l --libs-only-other openssl 2>/dev/null` + + SSL_LDFLAGS=`CURL_EXPORT_PCDIR([$OPENSSL_PCDIR]) + $PKGCONFIG --libs-only-L openssl 2>/dev/null` + + SSL_CPPFLAGS=`CURL_EXPORT_PCDIR([$OPENSSL_PCDIR]) + $PKGCONFIG --cflags-only-I openssl 2>/dev/null` + + AC_MSG_NOTICE([pkg-config: SSL_LIBS: "$SSL_LIBS"]) + AC_MSG_NOTICE([pkg-config: SSL_LDFLAGS: "$SSL_LDFLAGS"]) + AC_MSG_NOTICE([pkg-config: SSL_CPPFLAGS: "$SSL_CPPFLAGS"]) + + LIB_OPENSSL=`echo $SSL_LDFLAGS | sed -e 's/^-L//'` + + dnl use the values pkg-config reported. This is here + dnl instead of below with CPPFLAGS and LDFLAGS because we only + dnl learn about this via pkg-config. If we only have + dnl the argument to --with-openssl we do not know what + dnl additional libs may be necessary. Hope that we + dnl do not need any. + LIBS="$SSL_LIBS $LIBS" + fi + fi + + dnl finally, set flags to use SSL + CPPFLAGS="$CPPFLAGS $SSL_CPPFLAGS" + LDFLAGS="$LDFLAGS $SSL_LDFLAGS" + LDFLAGSPC="$LDFLAGSPC $SSL_LDFLAGS" + + AC_CHECK_LIB(crypto, HMAC_Update,[ + HAVECRYPTO="yes" + LIBS="-lcrypto $LIBS" + ],[ + if test -n "$LIB_OPENSSL"; then + LDFLAGS="$CLEANLDFLAGS -L$LIB_OPENSSL" + LDFLAGSPC="$CLEANLDFLAGSPC -L$LIB_OPENSSL" + fi + if test "$PKGCONFIG" = "no" && test -n "$PREFIX_OPENSSL"; then + dnl only set this if pkg-config was not used + CPPFLAGS="$CLEANCPPFLAGS -I$PREFIX_OPENSSL/include" + fi + dnl Linking previously failed, try extra paths from --with-openssl or + dnl pkg-config. Use a different function name to avoid reusing the earlier + dnl cached result. + AC_CHECK_LIB(crypto, HMAC_Init_ex,[ + HAVECRYPTO="yes" + LIBS="-lcrypto $LIBS"], [ + + dnl still no, but what about with -ldl? + AC_MSG_CHECKING([OpenSSL linking with -ldl]) + LIBS="-lcrypto $CLEANLIBS -ldl" + AC_LINK_IFELSE([ AC_LANG_PROGRAM([[ + #include + ]], [[ + ERR_clear_error(); + ]]) ], + [ + AC_MSG_RESULT(yes) + HAVECRYPTO="yes" + ], + [ + AC_MSG_RESULT(no) + dnl ok, so what about both -ldl and -lpthread? + dnl This may be necessary for static libraries. + + AC_MSG_CHECKING([OpenSSL linking with -ldl and -lpthread]) + LIBS="-lcrypto $CLEANLIBS -ldl -lpthread" + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([[ + #include + ]], [[ + ERR_clear_error(); + ]])], + [ + AC_MSG_RESULT(yes) + HAVECRYPTO="yes" + ], + [ + AC_MSG_RESULT(no) + LDFLAGS="$CLEANLDFLAGS" + LDFLAGSPC="$CLEANLDFLAGSPC" + CPPFLAGS="$CLEANCPPFLAGS" + LIBS="$CLEANLIBS" + ]) + ]) + ]) + ]) + + if test "$HAVECRYPTO" = "yes"; then + dnl This is only reasonable to do if crypto actually is there: check for + dnl SSL libs NOTE: it is important to do this AFTER the crypto lib + + AC_CHECK_LIB(ssl, SSL_connect) + + if test "$ac_cv_lib_ssl_SSL_connect" = "yes"; then + dnl Have the libraries--check for OpenSSL headers + AC_CHECK_HEADERS(openssl/rsa.h openssl/crypto.h openssl/pem.h openssl/ssl.h openssl/err.h, + ssl_msg="OpenSSL" + test "openssl" != "$DEFAULT_SSL_BACKEND" || VALID_DEFAULT_SSL_BACKEND=yes + OPENSSL_ENABLED=1 + AC_DEFINE(USE_OPENSSL, 1, [if OpenSSL is in use])) + fi + + if test "$OPENSSL_ENABLED" != "1"; then + LIBS="$CLEANLIBS" + AC_MSG_ERROR([OpenSSL libs and/or directories were not found where specified!]) + fi + fi + + if test "$OPENSSL_ENABLED" = "1"; then + dnl These can only exist if OpenSSL exists + + AC_MSG_CHECKING([for AWS-LC]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + #include + ]],[[ + #ifndef OPENSSL_IS_AWSLC + #error not AWS-LC + #endif + ]]) + ],[ + AC_MSG_RESULT([yes]) + ssl_msg="AWS-LC" + OPENSSL_IS_AWSLC=1 + ],[ + AC_MSG_RESULT([no]) + ]) + + AC_MSG_CHECKING([for BoringSSL]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + #include + ]],[[ + #ifndef OPENSSL_IS_BORINGSSL + #error not BoringSSL + #endif + ]]) + ],[ + AC_MSG_RESULT([yes]) + ssl_msg="BoringSSL" + OPENSSL_IS_BORINGSSL=1 + ],[ + AC_MSG_RESULT([no]) + ]) + + AC_MSG_CHECKING([for LibreSSL]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + #include + ]],[[ + int dummy = LIBRESSL_VERSION_NUMBER; + (void)dummy; + ]]) + ],[ + AC_MSG_RESULT([yes]) + ssl_msg="LibreSSL" + HAVE_LIBRESSL=1 + ],[ + AC_MSG_RESULT([no]) + ]) + + if test "$ssl_msg" = 'OpenSSL'; then + AC_MSG_CHECKING([for OpenSSL >= v3]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + #include + ]],[[ + #if (OPENSSL_VERSION_NUMBER >= 0x30000000L) + return 0; + #else + #error older than 3 + #endif + ]]) + ],[],[ + AC_MSG_ERROR([OpenSSL 3.0.0 or upper required.]) + ]) + fi + fi + + dnl is this OpenSSL (fork) providing the original QUIC API? + AC_CHECK_FUNCS([SSL_set_quic_use_legacy_codepoint], [QUIC_ENABLED=yes]) + if test "$QUIC_ENABLED" = "yes"; then + AC_MSG_NOTICE([OpenSSL fork speaks QUIC API]) + else + AC_CHECK_FUNCS([SSL_set_quic_tls_cbs], [QUIC_ENABLED=yes]) + if test "$QUIC_ENABLED" = "yes"; then + AC_MSG_NOTICE([OpenSSL with QUIC APIv2]) + OPENSSL_QUIC_API2=1 + else + AC_MSG_NOTICE([OpenSSL version does not speak any known QUIC API]) + fi + fi + + if test "$OPENSSL_ENABLED" = "1"; then + if test -n "$LIB_OPENSSL"; then + dnl when the SSL shared libs were found in a path that the runtime + dnl linker does not search through, we need to add it to CURL_LIBRARY_PATH + dnl to prevent further configure tests to fail due to this + if test "$cross_compiling" != "yes"; then + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$LIB_OPENSSL" + export CURL_LIBRARY_PATH + AC_MSG_NOTICE([Added $LIB_OPENSSL to CURL_LIBRARY_PATH]) + fi + fi + check_for_ca_bundle=1 + if test "$OPENSSL_IS_BORINGSSL" != "1"; then dnl BoringSSL does not provide openssl.pc + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE openssl" + fi + fi + + if test "$OPENSSL_ENABLED" != "1"; then + AC_MSG_NOTICE([OPT_OPENSSL: $OPT_OPENSSL]) + AC_MSG_NOTICE([OPENSSL_ENABLED: $OPENSSL_ENABLED]) + AC_MSG_ERROR([--with-openssl was given but OpenSSL could not be detected]) + fi + + test -z "$ssl_msg" || ssl_backends="${ssl_backends:+$ssl_backends, }$ssl_msg" +fi dnl OpenSSL not disabled + +if test "$OPENSSL_ENABLED" = "1"; then + dnl --- + dnl We check OpenSSL for DES support. + dnl --- + AC_MSG_CHECKING([for DES support in OpenSSL]) + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([[ + #ifndef OPENSSL_SUPPRESS_DEPRECATED + #define OPENSSL_SUPPRESS_DEPRECATED + #endif + #include + ]],[[ + DES_ecb_encrypt(0, 0, 0, DES_ENCRYPT); + ]]) + ],[ + AC_MSG_RESULT([yes]) + AC_DEFINE(HAVE_DES_ECB_ENCRYPT, 1, [if you have the function DES_ecb_encrypt]) + HAVE_DES_ECB_ENCRYPT=1 + ],[ + AC_MSG_RESULT([no]) + ]) + + dnl --- + dnl We require OpenSSL with SRP support. + dnl --- + AC_MSG_CHECKING([for SRP support in OpenSSL]) + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([[ + #ifndef OPENSSL_SUPPRESS_DEPRECATED + #define OPENSSL_SUPPRESS_DEPRECATED + #endif + #include + ]],[[ + SSL_CTX_set_srp_username(NULL, NULL); + SSL_CTX_set_srp_password(NULL, NULL); + ]]) + ],[ + AC_MSG_RESULT([yes]) + AC_DEFINE(HAVE_OPENSSL_SRP, 1, [if you have the functions SSL_CTX_set_srp_username and SSL_CTX_set_srp_password]) + HAVE_OPENSSL_SRP=1 + ],[ + AC_MSG_RESULT([no]) + ]) + + dnl --- + dnl Whether the OpenSSL configuration is loaded automatically + dnl --- + AC_ARG_ENABLE(openssl-auto-load-config, +AS_HELP_STRING([--enable-openssl-auto-load-config],[Enable automatic loading of OpenSSL configuration]) +AS_HELP_STRING([--disable-openssl-auto-load-config],[Disable automatic loading of OpenSSL configuration]), + [ if test "x$enableval" = "xno"; then + AC_MSG_NOTICE([automatic loading of OpenSSL configuration disabled]) + AC_DEFINE(CURL_DISABLE_OPENSSL_AUTO_LOAD_CONFIG, 1, [if the OpenSSL configuration is not loaded automatically]) + fi + ]) +fi +]) diff --git a/3rdparty/curl-8.21.0/m4/curl-override.m4 b/3rdparty/curl-8.21.0/m4/curl-override.m4 new file mode 100644 index 0000000000..59e6548dbd --- /dev/null +++ b/3rdparty/curl-8.21.0/m4/curl-override.m4 @@ -0,0 +1,95 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +#*************************************************************************** + +dnl File version for 'aclocal' use. Keep it a single number. +dnl serial 7 + +dnl CURL_OVERRIDE_AUTOCONF +dnl ------------------------------------------------- +dnl Placing a call to this macro in configure.ac after +dnl the one to AC_INIT makes macros in this file +dnl visible to the rest of the compilation overriding +dnl those from Autoconf. + +AC_DEFUN([CURL_OVERRIDE_AUTOCONF], [ +AC_BEFORE([$0],[AC_PROG_LIBTOOL]) +# using curl-override.m4 +]) + +dnl Override Autoconf's AC_LANG_PROGRAM (C) +dnl ------------------------------------------------- +dnl This is done to prevent compiler warning +dnl 'function declaration is not a prototype' +dnl in function main. This requires at least +dnl a C89 compiler and does not support K&R. + +m4_define([AC_LANG_PROGRAM(C)], +[$1 +int main(void) +{ +$2 + return 0; +}]) + +dnl Override Autoconf's AC_LANG_CALL (C) +dnl ------------------------------------------------- +dnl This is a backport of Autoconf's 2.60 with the +dnl embedded comments that hit the resulting script +dnl removed. This is done to reduce configure size +dnl and use fixed macro across Autoconf versions. + +m4_define([AC_LANG_CALL(C)], +[AC_LANG_PROGRAM([$1 +m4_if([$2], [main], , +[ +#ifdef __cplusplus +extern "C" +#endif +char $2 ();])], [return $2 ();])]) + +dnl Override Autoconf's AC_LANG_FUNC_LINK_TRY (C) +dnl ------------------------------------------------- +dnl This is a backport of Autoconf's 2.60 with the +dnl embedded comments that hit the resulting script +dnl removed. This is done to reduce configure size +dnl and use fixed macro across Autoconf versions. + +m4_define([AC_LANG_FUNC_LINK_TRY(C)], +[AC_LANG_PROGRAM( +[ +#define $1 innocuous_$1 +#ifdef __STDC__ +# include +#else +# include +#endif +#undef $1 +#ifdef __cplusplus +extern "C" +#endif +char $1 (); +#if defined __stub_$1 || defined __stub___$1 +#error force compilation error +#endif +], [return $1 ();])]) diff --git a/3rdparty/curl-8.21.0/m4/curl-reentrant.m4 b/3rdparty/curl-8.21.0/m4/curl-reentrant.m4 new file mode 100644 index 0000000000..eb585ad64d --- /dev/null +++ b/3rdparty/curl-8.21.0/m4/curl-reentrant.m4 @@ -0,0 +1,472 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +#*************************************************************************** + +dnl File version for 'aclocal' use. Keep it a single number. +dnl serial 10 + +dnl Note 1 +dnl ------ +dnl None of the CURL_CHECK_NEED_REENTRANT_* macros shall use HAVE_FOO_H to +dnl conditionally include header files. These macros are used early in the +dnl configure process much before header file availability is known. + + +dnl CURL_CHECK_NEED_REENTRANT_ERRNO +dnl ------------------------------------------------- +dnl Checks if the preprocessor _REENTRANT definition +dnl makes errno available as a preprocessor macro. + +AC_DEFUN([CURL_CHECK_NEED_REENTRANT_ERRNO], [ + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + #include + ]],[[ + if(0 != errno) + return 1; + ]]) + ],[ + tmp_errno="yes" + ],[ + tmp_errno="no" + ]) + if test "$tmp_errno" = "yes"; then + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + #include + ]],[[ + #ifdef errno + int dummy = 1; + (void)dummy; + #else + #error force compilation error + #endif + ]]) + ],[ + tmp_errno="errno_macro_defined" + ],[ + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + #define _REENTRANT + #include + ]],[[ + #ifdef errno + int dummy = 1; + (void)dummy; + #else + #error force compilation error + #endif + ]]) + ],[ + tmp_errno="errno_macro_needs_reentrant" + tmp_need_reentrant="yes" + ]) + ]) + fi +]) + + +dnl CURL_CHECK_NEED_REENTRANT_GMTIME_R +dnl ------------------------------------------------- +dnl Checks if the preprocessor _REENTRANT definition +dnl makes function gmtime_r compiler visible. + +AC_DEFUN([CURL_CHECK_NEED_REENTRANT_GMTIME_R], [ + AC_LINK_IFELSE([ + AC_LANG_FUNC_LINK_TRY([gmtime_r]) + ],[ + tmp_gmtime_r="yes" + ],[ + tmp_gmtime_r="no" + ]) + if test "$tmp_gmtime_r" = "yes"; then + AC_EGREP_CPP([gmtime_r],[ + #include + #include + ],[ + tmp_gmtime_r="proto_declared" + ],[ + AC_EGREP_CPP([gmtime_r],[ + #define _REENTRANT + #include + #include + ],[ + tmp_gmtime_r="proto_needs_reentrant" + tmp_need_reentrant="yes" + ]) + ]) + fi +]) + + +dnl CURL_CHECK_NEED_REENTRANT_LOCALTIME_R +dnl ------------------------------------------------- +dnl Checks if the preprocessor _REENTRANT definition +dnl makes function localtime_r compiler visible. + +AC_DEFUN([CURL_CHECK_NEED_REENTRANT_LOCALTIME_R], [ + AC_LINK_IFELSE([ + AC_LANG_FUNC_LINK_TRY([localtime_r]) + ],[ + tmp_localtime_r="yes" + ],[ + tmp_localtime_r="no" + ]) + if test "$tmp_localtime_r" = "yes"; then + AC_EGREP_CPP([localtime_r],[ + #include + #include + ],[ + tmp_localtime_r="proto_declared" + ],[ + AC_EGREP_CPP([localtime_r],[ + #define _REENTRANT + #include + #include + ],[ + tmp_localtime_r="proto_needs_reentrant" + tmp_need_reentrant="yes" + ]) + ]) + fi +]) + + +dnl CURL_CHECK_NEED_REENTRANT_STRERROR_R +dnl ------------------------------------------------- +dnl Checks if the preprocessor _REENTRANT definition +dnl makes function strerror_r compiler visible. + +AC_DEFUN([CURL_CHECK_NEED_REENTRANT_STRERROR_R], [ + AC_LINK_IFELSE([ + AC_LANG_FUNC_LINK_TRY([strerror_r]) + ],[ + tmp_strerror_r="yes" + ],[ + tmp_strerror_r="no" + ]) + if test "$tmp_strerror_r" = "yes"; then + AC_EGREP_CPP([strerror_r],[ + #include + #include + ],[ + tmp_strerror_r="proto_declared" + ],[ + AC_EGREP_CPP([strerror_r],[ + #define _REENTRANT + #include + #include + ],[ + tmp_strerror_r="proto_needs_reentrant" + tmp_need_reentrant="yes" + ]) + ]) + fi +]) + + +dnl CURL_CHECK_NEED_REENTRANT_GETHOSTBYNAME_R +dnl ------------------------------------------------- +dnl Checks if the preprocessor _REENTRANT definition +dnl makes function gethostbyname_r compiler visible. + +AC_DEFUN([CURL_CHECK_NEED_REENTRANT_GETHOSTBYNAME_R], [ + AC_LINK_IFELSE([ + AC_LANG_FUNC_LINK_TRY([gethostbyname_r]) + ],[ + tmp_gethostbyname_r="yes" + ],[ + tmp_gethostbyname_r="no" + ]) + if test "$tmp_gethostbyname_r" = "yes"; then + AC_EGREP_CPP([gethostbyname_r],[ + #include + #include + ],[ + tmp_gethostbyname_r="proto_declared" + ],[ + AC_EGREP_CPP([gethostbyname_r],[ + #define _REENTRANT + #include + #include + ],[ + tmp_gethostbyname_r="proto_needs_reentrant" + tmp_need_reentrant="yes" + ]) + ]) + fi +]) + + +dnl CURL_CHECK_NEED_REENTRANT_GETPROTOBYNAME_R +dnl ------------------------------------------------- +dnl Checks if the preprocessor _REENTRANT definition +dnl makes function getprotobyname_r compiler visible. + +AC_DEFUN([CURL_CHECK_NEED_REENTRANT_GETPROTOBYNAME_R], [ + AC_LINK_IFELSE([ + AC_LANG_FUNC_LINK_TRY([getprotobyname_r]) + ],[ + tmp_getprotobyname_r="yes" + ],[ + tmp_getprotobyname_r="no" + ]) + if test "$tmp_getprotobyname_r" = "yes"; then + AC_EGREP_CPP([getprotobyname_r],[ + #include + #include + ],[ + tmp_getprotobyname_r="proto_declared" + ],[ + AC_EGREP_CPP([getprotobyname_r],[ + #define _REENTRANT + #include + #include + ],[ + tmp_getprotobyname_r="proto_needs_reentrant" + tmp_need_reentrant="yes" + ]) + ]) + fi +]) + + +dnl CURL_CHECK_NEED_REENTRANT_FUNCTIONS_R +dnl ------------------------------------------------- +dnl Checks if the preprocessor _REENTRANT definition +dnl makes several _r functions compiler visible. +dnl Internal macro for CURL_CONFIGURE_REENTRANT. + +AC_DEFUN([CURL_CHECK_NEED_REENTRANT_FUNCTIONS_R], [ + if test "$tmp_need_reentrant" = "no"; then + CURL_CHECK_NEED_REENTRANT_GMTIME_R + fi + if test "$tmp_need_reentrant" = "no"; then + CURL_CHECK_NEED_REENTRANT_LOCALTIME_R + fi + if test "$tmp_need_reentrant" = "no"; then + CURL_CHECK_NEED_REENTRANT_STRERROR_R + fi + if test "$tmp_need_reentrant" = "no"; then + CURL_CHECK_NEED_REENTRANT_GETHOSTBYNAME_R + fi + if test "$tmp_need_reentrant" = "no"; then + CURL_CHECK_NEED_REENTRANT_GETPROTOBYNAME_R + fi +]) + + +dnl CURL_CHECK_NEED_REENTRANT_SYSTEM +dnl ------------------------------------------------- +dnl Checks if the preprocessor _REENTRANT definition +dnl must be unconditionally done for this platform. +dnl Internal macro for CURL_CONFIGURE_REENTRANT. + +AC_DEFUN([CURL_CHECK_NEED_REENTRANT_SYSTEM], [ + case $host_os in + solaris*) + tmp_need_reentrant="yes" + ;; + *) + tmp_need_reentrant="no" + ;; + esac +]) + + +dnl CURL_CHECK_NEED_THREAD_SAFE_SYSTEM +dnl ------------------------------------------------- +dnl Checks if the preprocessor _THREAD_SAFE definition +dnl must be unconditionally done for this platform. +dnl Internal macro for CURL_CONFIGURE_THREAD_SAFE. + +AC_DEFUN([CURL_CHECK_NEED_THREAD_SAFE_SYSTEM], [ + case $host_os in + aix[[123]].* | aix4.[[012]].*) + dnl aix 4.2 and older + tmp_need_thread_safe="no" + ;; + aix*) + dnl AIX 4.3 and newer + tmp_need_thread_safe="yes" + ;; + *) + tmp_need_thread_safe="no" + ;; + esac +]) + + +dnl CURL_CONFIGURE_FROM_NOW_ON_WITH_REENTRANT +dnl ------------------------------------------------- +dnl This macro ensures that configuration tests done +dnl after this execute with preprocessor symbol _REENTRANT +dnl defined. This macro also ensures that the generated +dnl config file defines NEED_REENTRANT and that in turn +dnl curl_setup.h defines _REENTRANT. +dnl Internal macro for CURL_CONFIGURE_REENTRANT. + +AC_DEFUN([CURL_CONFIGURE_FROM_NOW_ON_WITH_REENTRANT], [ +AC_DEFINE(NEED_REENTRANT, 1, + [Define to 1 if _REENTRANT preprocessor symbol must be defined.]) +cat >>confdefs.h <<_EOF +#ifndef _REENTRANT +# define _REENTRANT +#endif +_EOF +]) + + +dnl CURL_CONFIGURE_FROM_NOW_ON_WITH_THREAD_SAFE +dnl ------------------------------------------------- +dnl This macro ensures that configuration tests done +dnl after this execute with preprocessor symbol_THREAD_SAFE +dnl defined. This macro also ensures that the generated +dnl config file defines NEED_THREAD_SAFE and that in turn +dnl curl_setup.h defines _THREAD_SAFE. +dnl Internal macro for CURL_CONFIGURE_THREAD_SAFE. + +AC_DEFUN([CURL_CONFIGURE_FROM_NOW_ON_WITH_THREAD_SAFE], [ +AC_DEFINE(NEED_THREAD_SAFE, 1, + [Define to 1 if _THREAD_SAFE preprocessor symbol must be defined.]) +cat >>confdefs.h <<_EOF +#ifndef _THREAD_SAFE +# define _THREAD_SAFE +#endif +_EOF +]) + + +dnl CURL_CONFIGURE_REENTRANT +dnl ------------------------------------------------- +dnl This first checks if the preprocessor _REENTRANT +dnl symbol is already defined. If it is not currently +dnl defined a set of checks are performed to verify +dnl if its definition is required to make visible to +dnl the compiler a set of *_r functions. Finally, if +dnl _REENTRANT is already defined or needed it takes +dnl care of making adjustments necessary to ensure +dnl that it is defined equally for further configure +dnl tests and generated config file. + +AC_DEFUN([CURL_CONFIGURE_REENTRANT], [ + AC_PREREQ([2.50]) + + AC_MSG_CHECKING([if _REENTRANT is already defined]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + ]],[[ + #ifdef _REENTRANT + int dummy = 1; + (void)dummy; + #else + #error force compilation error + #endif + ]]) + ],[ + AC_MSG_RESULT([yes]) + tmp_reentrant_initially_defined="yes" + ],[ + AC_MSG_RESULT([no]) + tmp_reentrant_initially_defined="no" + ]) + + if test "$tmp_reentrant_initially_defined" = "no"; then + AC_MSG_CHECKING([if _REENTRANT is actually needed]) + CURL_CHECK_NEED_REENTRANT_SYSTEM + if test "$tmp_need_reentrant" = "no"; then + CURL_CHECK_NEED_REENTRANT_ERRNO + fi + if test "$tmp_need_reentrant" = "no"; then + CURL_CHECK_NEED_REENTRANT_FUNCTIONS_R + fi + if test "$tmp_need_reentrant" = "yes"; then + AC_MSG_RESULT([yes]) + else + AC_MSG_RESULT([no]) + fi + fi + + AC_MSG_CHECKING([if _REENTRANT is onwards defined]) + if test "$tmp_reentrant_initially_defined" = "yes" || + test "$tmp_need_reentrant" = "yes"; then + CURL_CONFIGURE_FROM_NOW_ON_WITH_REENTRANT + AC_MSG_RESULT([yes]) + else + AC_MSG_RESULT([no]) + fi +]) + + +dnl CURL_CONFIGURE_THREAD_SAFE +dnl ------------------------------------------------- +dnl This first checks if the preprocessor _THREAD_SAFE +dnl symbol is already defined. If it is not currently +dnl defined a set of checks are performed to verify +dnl if its definition is required. Finally, if +dnl _THREAD_SAFE is already defined or needed it takes +dnl care of making adjustments necessary to ensure +dnl that it is defined equally for further configure +dnl tests and generated config file. + +AC_DEFUN([CURL_CONFIGURE_THREAD_SAFE], [ + AC_PREREQ([2.50]) + + AC_MSG_CHECKING([if _THREAD_SAFE is already defined]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + ]],[[ + #ifdef _THREAD_SAFE + int dummy = 1; + (void)dummy; + #else + #error force compilation error + #endif + ]]) + ],[ + AC_MSG_RESULT([yes]) + tmp_thread_safe_initially_defined="yes" + ],[ + AC_MSG_RESULT([no]) + tmp_thread_safe_initially_defined="no" + ]) + + if test "$tmp_thread_safe_initially_defined" = "no"; then + AC_MSG_CHECKING([if _THREAD_SAFE is actually needed]) + CURL_CHECK_NEED_THREAD_SAFE_SYSTEM + if test "$tmp_need_thread_safe" = "yes"; then + AC_MSG_RESULT([yes]) + else + AC_MSG_RESULT([no]) + fi + fi + + AC_MSG_CHECKING([if _THREAD_SAFE is onwards defined]) + if test "$tmp_thread_safe_initially_defined" = "yes" || + test "$tmp_need_thread_safe" = "yes"; then + CURL_CONFIGURE_FROM_NOW_ON_WITH_THREAD_SAFE + AC_MSG_RESULT([yes]) + else + AC_MSG_RESULT([no]) + fi +]) diff --git a/3rdparty/curl-8.21.0/m4/curl-rustls.m4 b/3rdparty/curl-8.21.0/m4/curl-rustls.m4 new file mode 100644 index 0000000000..86bed3c323 --- /dev/null +++ b/3rdparty/curl-8.21.0/m4/curl-rustls.m4 @@ -0,0 +1,194 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +#*************************************************************************** + +AC_DEFUN([CURL_WITH_RUSTLS], [ +dnl ---------------------------------------------------- +dnl check for Rustls +dnl ---------------------------------------------------- + +if test "x$OPT_RUSTLS" != "xno"; then + ssl_msg= + + dnl backup the pre-detection variables + CLEANLDFLAGS="$LDFLAGS" + CLEANLDFLAGSPC="$LDFLAGSPC" + CLEANCPPFLAGS="$CPPFLAGS" + + dnl NEW CODE + + dnl use pkg-config unless we have been given a path + dnl even then, try pkg-config first + + case "$OPT_RUSTLS" in + yes) + dnl --with-rustls (without path) used + PKGTEST="yes" + PREFIX_RUSTLS= + ;; + *) + dnl check the provided --with-rustls path + PKGTEST="no" + PREFIX_RUSTLS=$OPT_RUSTLS + + dnl Try pkg-config even when cross-compiling. Since we + dnl specify PKG_CONFIG_LIBDIR we are only looking where + dnl the user told us to look + + RUSTLS_PCDIR="$PREFIX_RUSTLS/lib/pkgconfig" + if test -f "$RUSTLS_PCDIR/rustls.pc"; then + AC_MSG_NOTICE([PKG_CONFIG_LIBDIR is set to "$RUSTLS_PCDIR"]) + PKGTEST="yes" + fi + + if test "$PKGTEST" != "yes"; then + dnl try lib64 instead + RUSTLS_PCDIR="$PREFIX_RUSTLS/lib64/pkgconfig" + if test -f "$RUSTLS_PCDIR/rustls.pc"; then + AC_MSG_NOTICE([PKG_CONFIG_LIBDIR is set to "$RUSTLS_PCDIR"]) + PKGTEST="yes" + fi + fi + + if test "$PKGTEST" != "yes"; then + dnl pkg-config came up empty, use what we got + dnl via --with-rustls + + addld=-L$PREFIX_RUSTLS/lib$libsuff + addcflags=-I$PREFIX_RUSTLS/include + + LDFLAGS="$LDFLAGS $addld" + LDFLAGSPC="$LDFLAGSPC $addld" + if test "$addcflags" != "-I/usr/include"; then + CPPFLAGS="$CPPFLAGS $addcflags" + fi + + if test "$curl_cv_apple" = "yes"; then + RUSTLS_LDFLAGS="-framework Security -framework Foundation" + else + RUSTLS_LDFLAGS="-lpthread -ldl -lm" + fi + + LIB_RUSTLS="$PREFIX_RUSTLS/lib$libsuff" + if test "$PREFIX_RUSTLS" != "/usr"; then + SSL_LDFLAGS="-L$LIB_RUSTLS $RUSTLS_LDFLAGS" + SSL_CPPFLAGS="-I$PREFIX_RUSTLS/include" + fi + + dnl we verify AC_CHECK_LIB later on + AC_DEFINE(USE_RUSTLS, 1, [if Rustls is enabled]) + USE_RUSTLS="yes" + fi + ;; + esac + + link_pkgconfig='' + + if test "$PKGTEST" = "yes"; then + + CURL_CHECK_PKGCONFIG(rustls, [$RUSTLS_PCDIR]) + + if test "$PKGCONFIG" != "no"; then + SSL_LIBS=`CURL_EXPORT_PCDIR([$RUSTLS_PCDIR]) + $PKGCONFIG --libs-only-l --libs-only-other rustls 2>/dev/null` + + SSL_LDFLAGS=`CURL_EXPORT_PCDIR([$RUSTLS_PCDIR]) + $PKGCONFIG --libs-only-L rustls 2>/dev/null` + + SSL_CPPFLAGS=`CURL_EXPORT_PCDIR([$RUSTLS_PCDIR]) + $PKGCONFIG --cflags-only-I rustls 2>/dev/null` + + AC_MSG_NOTICE([pkg-config: SSL_LIBS: "$SSL_LIBS"]) + AC_MSG_NOTICE([pkg-config: SSL_LDFLAGS: "$SSL_LDFLAGS"]) + AC_MSG_NOTICE([pkg-config: SSL_CPPFLAGS: "$SSL_CPPFLAGS"]) + + LIB_RUSTLS=`echo $SSL_LDFLAGS | sed -e 's/^-L//'` + + dnl use the values pkg-config reported. This is here + dnl instead of below with CPPFLAGS and LDFLAGS because we only + dnl learn about this via pkg-config. If we only have + dnl the argument to --with-rustls we do not know what + dnl additional libs may be necessary. Hope that we + dnl do not need any. + LIBS="$SSL_LIBS $LIBS" + link_pkgconfig=1 + ssl_msg="Rustls" + AC_DEFINE(USE_RUSTLS, 1, [if Rustls is enabled]) + USE_RUSTLS="yes" + RUSTLS_ENABLED=1 + test "rustls" != "$DEFAULT_SSL_BACKEND" || VALID_DEFAULT_SSL_BACKEND=yes + else + AC_MSG_ERROR([pkg-config: Could not find Rustls]) + fi + + else + dnl we did not use pkg-config, so we need to add the + dnl Rustls lib to LIBS + LIBS="-lrustls -lpthread -ldl -lm $LIBS" + fi + + dnl finally, set flags to use this TLS backend + CPPFLAGS="$CLEANCPPFLAGS $SSL_CPPFLAGS" + LDFLAGS="$CLEANLDFLAGS $SSL_LDFLAGS" + LDFLAGSPC="$CLEANLDFLAGSPC $SSL_LDFLAGS" + + if test "$USE_RUSTLS" = "yes"; then + AC_MSG_NOTICE([detected Rustls]) + check_for_ca_bundle=1 + + if test -n "$LIB_RUSTLS"; then + dnl when shared libs were found in a path that the runtime + dnl linker does not search through, we need to add it to + dnl CURL_LIBRARY_PATH so that further configure tests do not + dnl fail due to this + if test "$cross_compiling" != "yes"; then + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$LIB_RUSTLS" + export CURL_LIBRARY_PATH + AC_MSG_NOTICE([Added $LIB_RUSTLS to CURL_LIBRARY_PATH]) + fi + fi + if test -n "$link_pkgconfig"; then + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE rustls" + fi + + AC_CHECK_LIB(rustls, rustls_supported_hpke, + [ + AC_DEFINE(USE_RUSTLS, 1, [if Rustls is enabled]) + RUSTLS_ENABLED=1 + USE_RUSTLS="yes" + ssl_msg="Rustls" + test "rustls" != "$DEFAULT_SSL_BACKEND" || VALID_DEFAULT_SSL_BACKEND=yes + ], + AC_MSG_ERROR([--with-rustls was specified but could not find compatible Rustls.]), + $RUSTLS_LDFLAGS) + fi + + test -z "$ssl_msg" || ssl_backends="${ssl_backends:+$ssl_backends, }$ssl_msg" + + if test "$RUSTLS_ENABLED" != "1"; then + AC_MSG_NOTICE([OPT_RUSTLS: $OPT_RUSTLS]) + AC_MSG_NOTICE([RUSTLS_ENABLED: $RUSTLS_ENABLED]) + AC_MSG_ERROR([--with-rustls was given but Rustls could not be detected]) + fi +fi +]) diff --git a/3rdparty/curl-8.21.0/m4/curl-schannel.m4 b/3rdparty/curl-8.21.0/m4/curl-schannel.m4 new file mode 100644 index 0000000000..e7358fbf62 --- /dev/null +++ b/3rdparty/curl-8.21.0/m4/curl-schannel.m4 @@ -0,0 +1,49 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +#*************************************************************************** + +AC_DEFUN([CURL_WITH_SCHANNEL], [ +AC_MSG_CHECKING([whether to enable Windows native SSL/TLS]) +if test "x$OPT_SCHANNEL" != "xno"; then + ssl_msg= + if test "$curl_cv_native_windows" = "yes"; then + if test "$curl_cv_winuwp" = "yes"; then + AC_MSG_ERROR([UWP does not support Schannel.]) + fi + AC_MSG_RESULT(yes) + AC_DEFINE(USE_SCHANNEL, 1, [to enable Windows native SSL/TLS support]) + ssl_msg="Schannel" + test "schannel" != "$DEFAULT_SSL_BACKEND" || VALID_DEFAULT_SSL_BACKEND=yes + SCHANNEL_ENABLED=1 + dnl --with-schannel implies --enable-sspi + AC_DEFINE(USE_WINDOWS_SSPI, 1, [to enable SSPI support]) + USE_WINDOWS_SSPI=1 + curl_sspi_msg="enabled" + else + AC_MSG_RESULT(no) + fi + test -z "$ssl_msg" || ssl_backends="${ssl_backends:+$ssl_backends, }$ssl_msg" +else + AC_MSG_RESULT(no) +fi +]) diff --git a/3rdparty/curl-8.21.0/m4/curl-sysconfig.m4 b/3rdparty/curl-8.21.0/m4/curl-sysconfig.m4 new file mode 100644 index 0000000000..7ad1285ef2 --- /dev/null +++ b/3rdparty/curl-8.21.0/m4/curl-sysconfig.m4 @@ -0,0 +1,51 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +#*************************************************************************** + +AC_DEFUN([CURL_DARWIN_SYSTEMCONFIGURATION], [ +AC_MSG_CHECKING([whether to link macOS CoreFoundation, CoreServices, and SystemConfiguration frameworks]) + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ + #include + #include + ]],[[ + #if TARGET_OS_MAC && !(defined(TARGET_OS_IPHONE) && TARGET_OS_IPHONE) + return 0; + #else + #error Not macOS + #endif + ]]) + ],[ + build_for_macos="yes" + ],[ + build_for_macos="no" + ]) + if test "$build_for_macos" != "no"; then + AC_MSG_RESULT(yes) + SYSCONFIG_LDFLAGS='-framework CoreFoundation -framework CoreServices -framework SystemConfiguration' + LDFLAGS="$LDFLAGS $SYSCONFIG_LDFLAGS" + LDFLAGSPC="$LDFLAGSPC $SYSCONFIG_LDFLAGS" + else + AC_MSG_RESULT(no) + fi +]) diff --git a/3rdparty/curl-8.21.0/m4/curl-wolfssl.m4 b/3rdparty/curl-8.21.0/m4/curl-wolfssl.m4 new file mode 100644 index 0000000000..a18659605e --- /dev/null +++ b/3rdparty/curl-8.21.0/m4/curl-wolfssl.m4 @@ -0,0 +1,171 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +#*************************************************************************** + +AC_DEFUN([CURL_WITH_WOLFSSL], [ +dnl ---------------------------------------------------- +dnl check for wolfSSL +dnl ---------------------------------------------------- + +case "$OPT_WOLFSSL" in + yes|no) + wolfpkg="" + ;; + *) + wolfpkg="$OPT_WOLFSSL/lib/pkgconfig" + ;; +esac + +if test "$OPT_WOLFSSL" != "no"; then + _cppflags=$CPPFLAGS + _ldflags=$LDFLAGS + _ldflagspc=$LDFLAGSPC + + ssl_msg= + + if test "$OPT_WOLFSSL" = "yes"; then + OPT_WOLFSSL="" + fi + + dnl try pkg-config magic + CURL_CHECK_PKGCONFIG(wolfssl, [$wolfpkg]) + AC_MSG_NOTICE([Check directory $wolfpkg]) + + addld="" + addlib="" + addcflags="" + if test "$PKGCONFIG" != "no"; then + addlib=`CURL_EXPORT_PCDIR([$wolfpkg]) + $PKGCONFIG --libs-only-l wolfssl` + addld=`CURL_EXPORT_PCDIR([$wolfpkg]) + $PKGCONFIG --libs-only-L wolfssl` + addcflags=`CURL_EXPORT_PCDIR([$wolfpkg]) + $PKGCONFIG --cflags-only-I wolfssl` + version=`CURL_EXPORT_PCDIR([$wolfpkg]) + $PKGCONFIG --modversion wolfssl` + wolfssllibpath=`echo $addld | $SED -e 's/^-L//'` + else + addlib=-lwolfssl + dnl use system defaults if user does not supply a path + if test -n "$OPT_WOLFSSL"; then + addld=-L$OPT_WOLFSSL/lib$libsuff + addcflags=-I$OPT_WOLFSSL/include + wolfssllibpath=$OPT_WOLFSSL/lib$libsuff + fi + fi + + if test "$curl_cv_apple" = "yes"; then + addlib="$addlib -framework Security -framework CoreFoundation" + else + addlib="$addlib -lm" + fi + + if test "$USE_WOLFSSL" != "yes"; then + CPPFLAGS="$CPPFLAGS -DWOLFSSL_OPTIONS_IGNORE_SYS" + + LDFLAGS="$LDFLAGS $addld" + LDFLAGSPC="$LDFLAGSPC $addld" + AC_MSG_NOTICE([Add $addld to LDFLAGS]) + if test "$addcflags" != "-I/usr/include"; then + CPPFLAGS="$CPPFLAGS $addcflags" + AC_MSG_NOTICE([Add $addcflags to CPPFLAGS]) + fi + + my_ac_save_LIBS="$LIBS" + LIBS="$addlib $LIBS" + AC_MSG_NOTICE([Add $addlib to LIBS]) + + AC_MSG_CHECKING([for wolfSSL_Init in -lwolfssl]) + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([[ + #include + #include + ]],[[ + return wolfSSL_Init(); + ]]) + ],[ + AC_MSG_RESULT(yes) + AC_DEFINE(USE_WOLFSSL, 1, [if wolfSSL is enabled]) + WOLFSSL_ENABLED=1 + USE_WOLFSSL="yes" + ssl_msg="wolfSSL" + test "wolfssl" != "$DEFAULT_SSL_BACKEND" || VALID_DEFAULT_SSL_BACKEND=yes + ], + [ + AC_MSG_RESULT(no) + CPPFLAGS=$_cppflags + LDFLAGS=$_ldflags + LDFLAGSPC=$_ldflagspc + wolfssllibpath="" + ]) + LIBS="$my_ac_save_LIBS" + fi + + if test "$USE_WOLFSSL" = "yes"; then + AC_MSG_NOTICE([detected wolfSSL]) + check_for_ca_bundle=1 + + LIBS="$addlib $LIBS" + + dnl is this wolfSSL providing the original QUIC API? + AC_CHECK_FUNCS([wolfSSL_set_quic_use_legacy_codepoint], [QUIC_ENABLED=yes]) + + dnl wolfSSL needs configure --enable-opensslextra to have *get_peer* + dnl wc_Des_EcbEncrypt is needed for NTLM support. + dnl if wolfSSL_BIO_set_shutdown is present, we have the full BIO feature set + AC_CHECK_FUNCS(wolfSSL_get_peer_certificate \ + wolfSSL_UseALPN \ + wolfSSL_BIO_new \ + wolfSSL_BIO_set_shutdown \ + wc_Des_EcbEncrypt) + + dnl if this symbol is present, we want the include path to include the + dnl OpenSSL API root as well + if test "$ac_cv_func_wc_Des_EcbEncrypt" = "yes"; then + HAVE_WC_DES_ECBENCRYPT=1 + fi + + dnl if this symbol is present, we can make use of BIO filter chains + if test "$ac_cv_func_wolfSSL_BIO_new" = "yes"; then + HAVE_WOLFSSL_BIO_NEW=1 + fi + + if test -n "$wolfssllibpath"; then + dnl when shared libs were found in a path that the runtime + dnl linker does not search through, we need to add it to + dnl CURL_LIBRARY_PATH to prevent further configure tests to fail + dnl due to this + if test "$cross_compiling" != "yes"; then + CURL_LIBRARY_PATH="$CURL_LIBRARY_PATH:$wolfssllibpath" + export CURL_LIBRARY_PATH + AC_MSG_NOTICE([Added $wolfssllibpath to CURL_LIBRARY_PATH]) + fi + fi + LIBCURL_PC_REQUIRES_PRIVATE="$LIBCURL_PC_REQUIRES_PRIVATE wolfssl" + else + AC_MSG_ERROR([--with-wolfssl but wolfSSL was not found or does not work]) + fi + + test -z "$ssl_msg" || ssl_backends="${ssl_backends:+$ssl_backends, }$ssl_msg" +fi dnl wolfSSL not disabled +]) diff --git a/3rdparty/curl-8.21.0/m4/libtool.m4 b/3rdparty/curl-8.21.0/m4/libtool.m4 new file mode 100644 index 0000000000..e7b6833455 --- /dev/null +++ b/3rdparty/curl-8.21.0/m4/libtool.m4 @@ -0,0 +1,8427 @@ +# libtool.m4 - Configure libtool for the host system. -*-Autoconf-*- +# +# Copyright (C) 1996-2001, 2003-2019, 2021-2022 Free Software +# Foundation, Inc. +# Written by Gordon Matzigkeit, 1996 +# +# This file is free software; the Free Software Foundation gives +# unlimited permission to copy and/or distribute it, with or without +# modifications, as long as this notice is preserved. + +m4_define([_LT_COPYING], [dnl +# Copyright (C) 2014 Free Software Foundation, Inc. +# This is free software; see the source for copying conditions. There is NO +# warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +# GNU Libtool is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of of the License, or +# (at your option) any later version. +# +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program or library that is built +# using GNU Libtool, you may include this file under the same +# distribution terms that you use for the rest of that program. +# +# GNU Libtool is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +]) + +# serial 59 LT_INIT + + +# LT_PREREQ(VERSION) +# ------------------ +# Complain and exit if this libtool version is less that VERSION. +m4_defun([LT_PREREQ], +[m4_if(m4_version_compare(m4_defn([LT_PACKAGE_VERSION]), [$1]), -1, + [m4_default([$3], + [m4_fatal([Libtool version $1 or higher is required], + 63)])], + [$2])]) + + +# _LT_CHECK_BUILDDIR +# ------------------ +# Complain if the absolute build directory name contains unusual characters +m4_defun([_LT_CHECK_BUILDDIR], +[case `pwd` in + *\ * | *\ *) + AC_MSG_WARN([Libtool does not cope well with whitespace in `pwd`]) ;; +esac +]) + + +# LT_INIT([OPTIONS]) +# ------------------ +AC_DEFUN([LT_INIT], +[AC_PREREQ([2.62])dnl We use AC_PATH_PROGS_FEATURE_CHECK +AC_REQUIRE([AC_CONFIG_AUX_DIR_DEFAULT])dnl +AC_BEFORE([$0], [LT_LANG])dnl +AC_BEFORE([$0], [LT_OUTPUT])dnl +AC_BEFORE([$0], [LTDL_INIT])dnl +m4_require([_LT_CHECK_BUILDDIR])dnl + +dnl Autoconf doesn't catch unexpanded LT_ macros by default: +m4_pattern_forbid([^_?LT_[A-Z_]+$])dnl +m4_pattern_allow([^(_LT_EOF|LT_DLGLOBAL|LT_DLLAZY_OR_NOW|LT_MULTI_MODULE)$])dnl +dnl aclocal doesn't pull ltoptions.m4, ltsugar.m4, or ltversion.m4 +dnl unless we require an AC_DEFUNed macro: +AC_REQUIRE([LTOPTIONS_VERSION])dnl +AC_REQUIRE([LTSUGAR_VERSION])dnl +AC_REQUIRE([LTVERSION_VERSION])dnl +AC_REQUIRE([LTOBSOLETE_VERSION])dnl +m4_require([_LT_PROG_LTMAIN])dnl + +_LT_SHELL_INIT([SHELL=${CONFIG_SHELL-/bin/sh}]) + +dnl Parse OPTIONS +_LT_SET_OPTIONS([$0], [$1]) + +# This can be used to rebuild libtool when needed +LIBTOOL_DEPS=$ltmain + +# Always use our own libtool. +LIBTOOL='$(SHELL) $(top_builddir)/libtool' +AC_SUBST(LIBTOOL)dnl + +_LT_SETUP + +# Only expand once: +m4_define([LT_INIT]) +])# LT_INIT + +# Old names: +AU_ALIAS([AC_PROG_LIBTOOL], [LT_INIT]) +AU_ALIAS([AM_PROG_LIBTOOL], [LT_INIT]) +dnl aclocal-1.4 backwards compatibility: +dnl AC_DEFUN([AC_PROG_LIBTOOL], []) +dnl AC_DEFUN([AM_PROG_LIBTOOL], []) + + +# _LT_PREPARE_CC_BASENAME +# ----------------------- +m4_defun([_LT_PREPARE_CC_BASENAME], [ +# Calculate cc_basename. Skip known compiler wrappers and cross-prefix. +func_cc_basename () +{ + for cc_temp in @S|@*""; do + case $cc_temp in + compile | *[[\\/]]compile | ccache | *[[\\/]]ccache ) ;; + distcc | *[[\\/]]distcc | purify | *[[\\/]]purify ) ;; + \-*) ;; + *) break;; + esac + done + func_cc_basename_result=`$ECHO "$cc_temp" | $SED "s%.*/%%; s%^$host_alias-%%"` +} +])# _LT_PREPARE_CC_BASENAME + + +# _LT_CC_BASENAME(CC) +# ------------------- +# It would be clearer to call AC_REQUIREs from _LT_PREPARE_CC_BASENAME, +# but that macro is also expanded into generated libtool script, which +# arranges for $SED and $ECHO to be set by different means. +m4_defun([_LT_CC_BASENAME], +[m4_require([_LT_PREPARE_CC_BASENAME])dnl +AC_REQUIRE([_LT_DECL_SED])dnl +AC_REQUIRE([_LT_PROG_ECHO_BACKSLASH])dnl +func_cc_basename $1 +cc_basename=$func_cc_basename_result +]) + + +# _LT_FILEUTILS_DEFAULTS +# ---------------------- +# It is okay to use these file commands and assume they have been set +# sensibly after 'm4_require([_LT_FILEUTILS_DEFAULTS])'. +m4_defun([_LT_FILEUTILS_DEFAULTS], +[: ${CP="cp -f"} +: ${MV="mv -f"} +: ${RM="rm -f"} +])# _LT_FILEUTILS_DEFAULTS + + +# _LT_SETUP +# --------- +m4_defun([_LT_SETUP], +[AC_REQUIRE([AC_CANONICAL_HOST])dnl +AC_REQUIRE([AC_CANONICAL_BUILD])dnl +AC_REQUIRE([_LT_PREPARE_SED_QUOTE_VARS])dnl +AC_REQUIRE([_LT_PROG_ECHO_BACKSLASH])dnl + +_LT_DECL([], [PATH_SEPARATOR], [1], [The PATH separator for the build system])dnl +dnl +_LT_DECL([], [host_alias], [0], [The host system])dnl +_LT_DECL([], [host], [0])dnl +_LT_DECL([], [host_os], [0])dnl +dnl +_LT_DECL([], [build_alias], [0], [The build system])dnl +_LT_DECL([], [build], [0])dnl +_LT_DECL([], [build_os], [0])dnl +dnl +AC_REQUIRE([AC_PROG_CC])dnl +AC_REQUIRE([LT_PATH_LD])dnl +AC_REQUIRE([LT_PATH_NM])dnl +dnl +AC_REQUIRE([AC_PROG_LN_S])dnl +test -z "$LN_S" && LN_S="ln -s" +_LT_DECL([], [LN_S], [1], [Whether we need soft or hard links])dnl +dnl +AC_REQUIRE([LT_CMD_MAX_LEN])dnl +_LT_DECL([objext], [ac_objext], [0], [Object file suffix (normally "o")])dnl +_LT_DECL([], [exeext], [0], [Executable file suffix (normally "")])dnl +dnl +m4_require([_LT_FILEUTILS_DEFAULTS])dnl +m4_require([_LT_CHECK_SHELL_FEATURES])dnl +m4_require([_LT_PATH_CONVERSION_FUNCTIONS])dnl +m4_require([_LT_CMD_RELOAD])dnl +m4_require([_LT_DECL_FILECMD])dnl +m4_require([_LT_CHECK_MAGIC_METHOD])dnl +m4_require([_LT_CHECK_SHAREDLIB_FROM_LINKLIB])dnl +m4_require([_LT_CMD_OLD_ARCHIVE])dnl +m4_require([_LT_CMD_GLOBAL_SYMBOLS])dnl +m4_require([_LT_WITH_SYSROOT])dnl +m4_require([_LT_CMD_TRUNCATE])dnl + +_LT_CONFIG_LIBTOOL_INIT([ +# See if we are running on zsh, and set the options that allow our +# commands through without removal of \ escapes INIT. +if test -n "\${ZSH_VERSION+set}"; then + setopt NO_GLOB_SUBST +fi +]) +if test -n "${ZSH_VERSION+set}"; then + setopt NO_GLOB_SUBST +fi + +_LT_CHECK_OBJDIR + +m4_require([_LT_TAG_COMPILER])dnl + +case $host_os in +aix3*) + # AIX sometimes has problems with the GCC collect2 program. For some + # reason, if we set the COLLECT_NAMES environment variable, the problems + # vanish in a puff of smoke. + if test set != "${COLLECT_NAMES+set}"; then + COLLECT_NAMES= + export COLLECT_NAMES + fi + ;; +esac + +# Global variables: +ofile=libtool +can_build_shared=yes + +# All known linkers require a '.a' archive for static linking (except MSVC and +# ICC, which need '.lib'). +libext=a + +with_gnu_ld=$lt_cv_prog_gnu_ld + +old_CC=$CC +old_CFLAGS=$CFLAGS + +# Set sane defaults for various variables +test -z "$CC" && CC=cc +test -z "$LTCC" && LTCC=$CC +test -z "$LTCFLAGS" && LTCFLAGS=$CFLAGS +test -z "$LD" && LD=ld +test -z "$ac_objext" && ac_objext=o + +_LT_CC_BASENAME([$compiler]) + +# Only perform the check for file, if the check method requires it +test -z "$MAGIC_CMD" && MAGIC_CMD=file +case $deplibs_check_method in +file_magic*) + if test "$file_magic_cmd" = '$MAGIC_CMD'; then + _LT_PATH_MAGIC + fi + ;; +esac + +# Use C for the default configuration in the libtool script +LT_SUPPORTED_TAG([CC]) +_LT_LANG_C_CONFIG +_LT_LANG_DEFAULT_CONFIG +_LT_CONFIG_COMMANDS +])# _LT_SETUP + + +# _LT_PREPARE_SED_QUOTE_VARS +# -------------------------- +# Define a few sed substitution that help us do robust quoting. +m4_defun([_LT_PREPARE_SED_QUOTE_VARS], +[# Backslashify metacharacters that are still active within +# double-quoted strings. +sed_quote_subst='s/\([["`$\\]]\)/\\\1/g' + +# Same as above, but do not quote variable references. +double_quote_subst='s/\([["`\\]]\)/\\\1/g' + +# Sed substitution to delay expansion of an escaped shell variable in a +# double_quote_subst'ed string. +delay_variable_subst='s/\\\\\\\\\\\$/\\\\\\$/g' + +# Sed substitution to delay expansion of an escaped single quote. +delay_single_quote_subst='s/'\''/'\'\\\\\\\'\''/g' + +# Sed substitution to avoid accidental globbing in evaled expressions +no_glob_subst='s/\*/\\\*/g' +]) + +# _LT_PROG_LTMAIN +# --------------- +# Note that this code is called both from 'configure', and 'config.status' +# now that we use AC_CONFIG_COMMANDS to generate libtool. Notably, +# 'config.status' has no value for ac_aux_dir unless we are using Automake, +# so we pass a copy along to make sure it has a sensible value anyway. +m4_defun([_LT_PROG_LTMAIN], +[m4_ifdef([AC_REQUIRE_AUX_FILE], [AC_REQUIRE_AUX_FILE([ltmain.sh])])dnl +_LT_CONFIG_LIBTOOL_INIT([ac_aux_dir='$ac_aux_dir']) +ltmain=$ac_aux_dir/ltmain.sh +])# _LT_PROG_LTMAIN + + +## ------------------------------------- ## +## Accumulate code for creating libtool. ## +## ------------------------------------- ## + +# So that we can recreate a full libtool script including additional +# tags, we accumulate the chunks of code to send to AC_CONFIG_COMMANDS +# in macros and then make a single call at the end using the 'libtool' +# label. + + +# _LT_CONFIG_LIBTOOL_INIT([INIT-COMMANDS]) +# ---------------------------------------- +# Register INIT-COMMANDS to be passed to AC_CONFIG_COMMANDS later. +m4_define([_LT_CONFIG_LIBTOOL_INIT], +[m4_ifval([$1], + [m4_append([_LT_OUTPUT_LIBTOOL_INIT], + [$1 +])])]) + +# Initialize. +m4_define([_LT_OUTPUT_LIBTOOL_INIT]) + + +# _LT_CONFIG_LIBTOOL([COMMANDS]) +# ------------------------------ +# Register COMMANDS to be passed to AC_CONFIG_COMMANDS later. +m4_define([_LT_CONFIG_LIBTOOL], +[m4_ifval([$1], + [m4_append([_LT_OUTPUT_LIBTOOL_COMMANDS], + [$1 +])])]) + +# Initialize. +m4_define([_LT_OUTPUT_LIBTOOL_COMMANDS]) + + +# _LT_CONFIG_SAVE_COMMANDS([COMMANDS], [INIT_COMMANDS]) +# ----------------------------------------------------- +m4_defun([_LT_CONFIG_SAVE_COMMANDS], +[_LT_CONFIG_LIBTOOL([$1]) +_LT_CONFIG_LIBTOOL_INIT([$2]) +]) + + +# _LT_FORMAT_COMMENT([COMMENT]) +# ----------------------------- +# Add leading comment marks to the start of each line, and a trailing +# full-stop to the whole comment if one is not present already. +m4_define([_LT_FORMAT_COMMENT], +[m4_ifval([$1], [ +m4_bpatsubst([m4_bpatsubst([$1], [^ *], [# ])], + [['`$\]], [\\\&])]m4_bmatch([$1], [[!?.]$], [], [.]) +)]) + + + +## ------------------------ ## +## FIXME: Eliminate VARNAME ## +## ------------------------ ## + + +# _LT_DECL([CONFIGNAME], VARNAME, VALUE, [DESCRIPTION], [IS-TAGGED?]) +# ------------------------------------------------------------------- +# CONFIGNAME is the name given to the value in the libtool script. +# VARNAME is the (base) name used in the configure script. +# VALUE may be 0, 1 or 2 for a computed quote escaped value based on +# VARNAME. Any other value will be used directly. +m4_define([_LT_DECL], +[lt_if_append_uniq([lt_decl_varnames], [$2], [, ], + [lt_dict_add_subkey([lt_decl_dict], [$2], [libtool_name], + [m4_ifval([$1], [$1], [$2])]) + lt_dict_add_subkey([lt_decl_dict], [$2], [value], [$3]) + m4_ifval([$4], + [lt_dict_add_subkey([lt_decl_dict], [$2], [description], [$4])]) + lt_dict_add_subkey([lt_decl_dict], [$2], + [tagged?], [m4_ifval([$5], [yes], [no])])]) +]) + + +# _LT_TAGDECL([CONFIGNAME], VARNAME, VALUE, [DESCRIPTION]) +# -------------------------------------------------------- +m4_define([_LT_TAGDECL], [_LT_DECL([$1], [$2], [$3], [$4], [yes])]) + + +# lt_decl_tag_varnames([SEPARATOR], [VARNAME1...]) +# ------------------------------------------------ +m4_define([lt_decl_tag_varnames], +[_lt_decl_filter([tagged?], [yes], $@)]) + + +# _lt_decl_filter(SUBKEY, VALUE, [SEPARATOR], [VARNAME1..]) +# --------------------------------------------------------- +m4_define([_lt_decl_filter], +[m4_case([$#], + [0], [m4_fatal([$0: too few arguments: $#])], + [1], [m4_fatal([$0: too few arguments: $#: $1])], + [2], [lt_dict_filter([lt_decl_dict], [$1], [$2], [], lt_decl_varnames)], + [3], [lt_dict_filter([lt_decl_dict], [$1], [$2], [$3], lt_decl_varnames)], + [lt_dict_filter([lt_decl_dict], $@)])[]dnl +]) + + +# lt_decl_quote_varnames([SEPARATOR], [VARNAME1...]) +# -------------------------------------------------- +m4_define([lt_decl_quote_varnames], +[_lt_decl_filter([value], [1], $@)]) + + +# lt_decl_dquote_varnames([SEPARATOR], [VARNAME1...]) +# --------------------------------------------------- +m4_define([lt_decl_dquote_varnames], +[_lt_decl_filter([value], [2], $@)]) + + +# lt_decl_varnames_tagged([SEPARATOR], [VARNAME1...]) +# --------------------------------------------------- +m4_define([lt_decl_varnames_tagged], +[m4_assert([$# <= 2])dnl +_$0(m4_quote(m4_default([$1], [[, ]])), + m4_ifval([$2], [[$2]], [m4_dquote(lt_decl_tag_varnames)]), + m4_split(m4_normalize(m4_quote(_LT_TAGS)), [ ]))]) +m4_define([_lt_decl_varnames_tagged], +[m4_ifval([$3], [lt_combine([$1], [$2], [_], $3)])]) + + +# lt_decl_all_varnames([SEPARATOR], [VARNAME1...]) +# ------------------------------------------------ +m4_define([lt_decl_all_varnames], +[_$0(m4_quote(m4_default([$1], [[, ]])), + m4_if([$2], [], + m4_quote(lt_decl_varnames), + m4_quote(m4_shift($@))))[]dnl +]) +m4_define([_lt_decl_all_varnames], +[lt_join($@, lt_decl_varnames_tagged([$1], + lt_decl_tag_varnames([[, ]], m4_shift($@))))dnl +]) + + +# _LT_CONFIG_STATUS_DECLARE([VARNAME]) +# ------------------------------------ +# Quote a variable value, and forward it to 'config.status' so that its +# declaration there will have the same value as in 'configure'. VARNAME +# must have a single quote delimited value for this to work. +m4_define([_LT_CONFIG_STATUS_DECLARE], +[$1='`$ECHO "$][$1" | $SED "$delay_single_quote_subst"`']) + + +# _LT_CONFIG_STATUS_DECLARATIONS +# ------------------------------ +# We delimit libtool config variables with single quotes, so when +# we write them to config.status, we have to be sure to quote all +# embedded single quotes properly. In configure, this macro expands +# each variable declared with _LT_DECL (and _LT_TAGDECL) into: +# +# ='`$ECHO "$" | $SED "$delay_single_quote_subst"`' +m4_defun([_LT_CONFIG_STATUS_DECLARATIONS], +[m4_foreach([_lt_var], m4_quote(lt_decl_all_varnames), + [m4_n([_LT_CONFIG_STATUS_DECLARE(_lt_var)])])]) + + +# _LT_LIBTOOL_TAGS +# ---------------- +# Output comment and list of tags supported by the script +m4_defun([_LT_LIBTOOL_TAGS], +[_LT_FORMAT_COMMENT([The names of the tagged configurations supported by this script])dnl +available_tags='_LT_TAGS'dnl +]) + + +# _LT_LIBTOOL_DECLARE(VARNAME, [TAG]) +# ----------------------------------- +# Extract the dictionary values for VARNAME (optionally with TAG) and +# expand to a commented shell variable setting: +# +# # Some comment about what VAR is for. +# visible_name=$lt_internal_name +m4_define([_LT_LIBTOOL_DECLARE], +[_LT_FORMAT_COMMENT(m4_quote(lt_dict_fetch([lt_decl_dict], [$1], + [description])))[]dnl +m4_pushdef([_libtool_name], + m4_quote(lt_dict_fetch([lt_decl_dict], [$1], [libtool_name])))[]dnl +m4_case(m4_quote(lt_dict_fetch([lt_decl_dict], [$1], [value])), + [0], [_libtool_name=[$]$1], + [1], [_libtool_name=$lt_[]$1], + [2], [_libtool_name=$lt_[]$1], + [_libtool_name=lt_dict_fetch([lt_decl_dict], [$1], [value])])[]dnl +m4_ifval([$2], [_$2])[]m4_popdef([_libtool_name])[]dnl +]) + + +# _LT_LIBTOOL_CONFIG_VARS +# ----------------------- +# Produce commented declarations of non-tagged libtool config variables +# suitable for insertion in the LIBTOOL CONFIG section of the 'libtool' +# script. Tagged libtool config variables (even for the LIBTOOL CONFIG +# section) are produced by _LT_LIBTOOL_TAG_VARS. +m4_defun([_LT_LIBTOOL_CONFIG_VARS], +[m4_foreach([_lt_var], + m4_quote(_lt_decl_filter([tagged?], [no], [], lt_decl_varnames)), + [m4_n([_LT_LIBTOOL_DECLARE(_lt_var)])])]) + + +# _LT_LIBTOOL_TAG_VARS(TAG) +# ------------------------- +m4_define([_LT_LIBTOOL_TAG_VARS], +[m4_foreach([_lt_var], m4_quote(lt_decl_tag_varnames), + [m4_n([_LT_LIBTOOL_DECLARE(_lt_var, [$1])])])]) + + +# _LT_TAGVAR(VARNAME, [TAGNAME]) +# ------------------------------ +m4_define([_LT_TAGVAR], [m4_ifval([$2], [$1_$2], [$1])]) + + +# _LT_CONFIG_COMMANDS +# ------------------- +# Send accumulated output to $CONFIG_STATUS. Thanks to the lists of +# variables for single and double quote escaping we saved from calls +# to _LT_DECL, we can put quote escaped variables declarations +# into 'config.status', and then the shell code to quote escape them in +# for loops in 'config.status'. Finally, any additional code accumulated +# from calls to _LT_CONFIG_LIBTOOL_INIT is expanded. +m4_defun([_LT_CONFIG_COMMANDS], +[AC_PROVIDE_IFELSE([LT_OUTPUT], + dnl If the libtool generation code has been placed in $CONFIG_LT, + dnl instead of duplicating it all over again into config.status, + dnl then we will have config.status run $CONFIG_LT later, so it + dnl needs to know what name is stored there: + [AC_CONFIG_COMMANDS([libtool], + [$SHELL $CONFIG_LT || AS_EXIT(1)], [CONFIG_LT='$CONFIG_LT'])], + dnl If the libtool generation code is destined for config.status, + dnl expand the accumulated commands and init code now: + [AC_CONFIG_COMMANDS([libtool], + [_LT_OUTPUT_LIBTOOL_COMMANDS], [_LT_OUTPUT_LIBTOOL_COMMANDS_INIT])]) +])#_LT_CONFIG_COMMANDS + + +# Initialize. +m4_define([_LT_OUTPUT_LIBTOOL_COMMANDS_INIT], +[ + +# The HP-UX ksh and POSIX shell print the target directory to stdout +# if CDPATH is set. +(unset CDPATH) >/dev/null 2>&1 && unset CDPATH + +sed_quote_subst='$sed_quote_subst' +double_quote_subst='$double_quote_subst' +delay_variable_subst='$delay_variable_subst' +_LT_CONFIG_STATUS_DECLARATIONS +LTCC='$LTCC' +LTCFLAGS='$LTCFLAGS' +compiler='$compiler_DEFAULT' + +# A function that is used when there is no print builtin or printf. +func_fallback_echo () +{ + eval 'cat <<_LTECHO_EOF +\$[]1 +_LTECHO_EOF' +} + +# Quote evaled strings. +for var in lt_decl_all_varnames([[ \ +]], lt_decl_quote_varnames); do + case \`eval \\\\\$ECHO \\\\""\\\\\$\$var"\\\\"\` in + *[[\\\\\\\`\\"\\\$]]*) + eval "lt_\$var=\\\\\\"\\\`\\\$ECHO \\"\\\$\$var\\" | \\\$SED \\"\\\$sed_quote_subst\\"\\\`\\\\\\"" ## exclude from sc_prohibit_nested_quotes + ;; + *) + eval "lt_\$var=\\\\\\"\\\$\$var\\\\\\"" + ;; + esac +done + +# Double-quote double-evaled strings. +for var in lt_decl_all_varnames([[ \ +]], lt_decl_dquote_varnames); do + case \`eval \\\\\$ECHO \\\\""\\\\\$\$var"\\\\"\` in + *[[\\\\\\\`\\"\\\$]]*) + eval "lt_\$var=\\\\\\"\\\`\\\$ECHO \\"\\\$\$var\\" | \\\$SED -e \\"\\\$double_quote_subst\\" -e \\"\\\$sed_quote_subst\\" -e \\"\\\$delay_variable_subst\\"\\\`\\\\\\"" ## exclude from sc_prohibit_nested_quotes + ;; + *) + eval "lt_\$var=\\\\\\"\\\$\$var\\\\\\"" + ;; + esac +done + +_LT_OUTPUT_LIBTOOL_INIT +]) + +# _LT_GENERATED_FILE_INIT(FILE, [COMMENT]) +# ------------------------------------ +# Generate a child script FILE with all initialization necessary to +# reuse the environment learned by the parent script, and make the +# file executable. If COMMENT is supplied, it is inserted after the +# '#!' sequence but before initialization text begins. After this +# macro, additional text can be appended to FILE to form the body of +# the child script. The macro ends with non-zero status if the +# file could not be fully written (such as if the disk is full). +m4_ifdef([AS_INIT_GENERATED], +[m4_defun([_LT_GENERATED_FILE_INIT],[AS_INIT_GENERATED($@)])], +[m4_defun([_LT_GENERATED_FILE_INIT], +[m4_require([AS_PREPARE])]dnl +[m4_pushdef([AS_MESSAGE_LOG_FD])]dnl +[lt_write_fail=0 +cat >$1 <<_ASEOF || lt_write_fail=1 +#! $SHELL +# Generated by $as_me. +$2 +SHELL=\${CONFIG_SHELL-$SHELL} +export SHELL +_ASEOF +cat >>$1 <<\_ASEOF || lt_write_fail=1 +AS_SHELL_SANITIZE +_AS_PREPARE +exec AS_MESSAGE_FD>&1 +_ASEOF +test 0 = "$lt_write_fail" && chmod +x $1[]dnl +m4_popdef([AS_MESSAGE_LOG_FD])])])# _LT_GENERATED_FILE_INIT + +# LT_OUTPUT +# --------- +# This macro allows early generation of the libtool script (before +# AC_OUTPUT is called), incase it is used in configure for compilation +# tests. +AC_DEFUN([LT_OUTPUT], +[: ${CONFIG_LT=./config.lt} +AC_MSG_NOTICE([creating $CONFIG_LT]) +_LT_GENERATED_FILE_INIT(["$CONFIG_LT"], +[# Run this file to recreate a libtool stub with the current configuration.]) + +cat >>"$CONFIG_LT" <<\_LTEOF +lt_cl_silent=false +exec AS_MESSAGE_LOG_FD>>config.log +{ + echo + AS_BOX([Running $as_me.]) +} >&AS_MESSAGE_LOG_FD + +lt_cl_help="\ +'$as_me' creates a local libtool stub from the current configuration, +for use in further configure time tests before the real libtool is +generated. + +Usage: $[0] [[OPTIONS]] + + -h, --help print this help, then exit + -V, --version print version number, then exit + -q, --quiet do not print progress messages + -d, --debug don't remove temporary files + +Report bugs to ." + +lt_cl_version="\ +m4_ifset([AC_PACKAGE_NAME], [AC_PACKAGE_NAME ])config.lt[]dnl +m4_ifset([AC_PACKAGE_VERSION], [ AC_PACKAGE_VERSION]) +configured by $[0], generated by m4_PACKAGE_STRING. + +Copyright (C) 2011 Free Software Foundation, Inc. +This config.lt script is free software; the Free Software Foundation +gives unlimited permision to copy, distribute and modify it." + +while test 0 != $[#] +do + case $[1] in + --version | --v* | -V ) + echo "$lt_cl_version"; exit 0 ;; + --help | --h* | -h ) + echo "$lt_cl_help"; exit 0 ;; + --debug | --d* | -d ) + debug=: ;; + --quiet | --q* | --silent | --s* | -q ) + lt_cl_silent=: ;; + + -*) AC_MSG_ERROR([unrecognized option: $[1] +Try '$[0] --help' for more information.]) ;; + + *) AC_MSG_ERROR([unrecognized argument: $[1] +Try '$[0] --help' for more information.]) ;; + esac + shift +done + +if $lt_cl_silent; then + exec AS_MESSAGE_FD>/dev/null +fi +_LTEOF + +cat >>"$CONFIG_LT" <<_LTEOF +_LT_OUTPUT_LIBTOOL_COMMANDS_INIT +_LTEOF + +cat >>"$CONFIG_LT" <<\_LTEOF +AC_MSG_NOTICE([creating $ofile]) +_LT_OUTPUT_LIBTOOL_COMMANDS +AS_EXIT(0) +_LTEOF +chmod +x "$CONFIG_LT" + +# configure is writing to config.log, but config.lt does its own redirection, +# appending to config.log, which fails on DOS, as config.log is still kept +# open by configure. Here we exec the FD to /dev/null, effectively closing +# config.log, so it can be properly (re)opened and appended to by config.lt. +lt_cl_success=: +test yes = "$silent" && + lt_config_lt_args="$lt_config_lt_args --quiet" +exec AS_MESSAGE_LOG_FD>/dev/null +$SHELL "$CONFIG_LT" $lt_config_lt_args || lt_cl_success=false +exec AS_MESSAGE_LOG_FD>>config.log +$lt_cl_success || AS_EXIT(1) +])# LT_OUTPUT + + +# _LT_CONFIG(TAG) +# --------------- +# If TAG is the built-in tag, create an initial libtool script with a +# default configuration from the untagged config vars. Otherwise add code +# to config.status for appending the configuration named by TAG from the +# matching tagged config vars. +m4_defun([_LT_CONFIG], +[m4_require([_LT_FILEUTILS_DEFAULTS])dnl +_LT_CONFIG_SAVE_COMMANDS([ + m4_define([_LT_TAG], m4_if([$1], [], [C], [$1]))dnl + m4_if(_LT_TAG, [C], [ + # See if we are running on zsh, and set the options that allow our + # commands through without removal of \ escapes. + if test -n "${ZSH_VERSION+set}"; then + setopt NO_GLOB_SUBST + fi + + cfgfile=${ofile}T + trap "$RM \"$cfgfile\"; exit 1" 1 2 15 + $RM "$cfgfile" + + cat <<_LT_EOF >> "$cfgfile" +#! $SHELL +# Generated automatically by $as_me ($PACKAGE) $VERSION +# NOTE: Changes made to this file will be lost: look at ltmain.sh. + +# Provide generalized library-building support services. +# Written by Gordon Matzigkeit, 1996 + +_LT_COPYING +_LT_LIBTOOL_TAGS + +# Configured defaults for sys_lib_dlsearch_path munging. +: \${LT_SYS_LIBRARY_PATH="$configure_time_lt_sys_library_path"} + +# ### BEGIN LIBTOOL CONFIG +_LT_LIBTOOL_CONFIG_VARS +_LT_LIBTOOL_TAG_VARS +# ### END LIBTOOL CONFIG + +_LT_EOF + + cat <<'_LT_EOF' >> "$cfgfile" + +# ### BEGIN FUNCTIONS SHARED WITH CONFIGURE + +_LT_PREPARE_MUNGE_PATH_LIST +_LT_PREPARE_CC_BASENAME + +# ### END FUNCTIONS SHARED WITH CONFIGURE + +_LT_EOF + + case $host_os in + aix3*) + cat <<\_LT_EOF >> "$cfgfile" +# AIX sometimes has problems with the GCC collect2 program. For some +# reason, if we set the COLLECT_NAMES environment variable, the problems +# vanish in a puff of smoke. +if test set != "${COLLECT_NAMES+set}"; then + COLLECT_NAMES= + export COLLECT_NAMES +fi +_LT_EOF + ;; + esac + + _LT_PROG_LTMAIN + + # We use sed instead of cat because bash on DJGPP gets confused if + # if finds mixed CR/LF and LF-only lines. Since sed operates in + # text mode, it properly converts lines to CR/LF. This bash problem + # is reportedly fixed, but why not run on old versions too? + $SED '$q' "$ltmain" >> "$cfgfile" \ + || (rm -f "$cfgfile"; exit 1) + + mv -f "$cfgfile" "$ofile" || + (rm -f "$ofile" && cp "$cfgfile" "$ofile" && rm -f "$cfgfile") + chmod +x "$ofile" +], +[cat <<_LT_EOF >> "$ofile" + +dnl Unfortunately we have to use $1 here, since _LT_TAG is not expanded +dnl in a comment (ie after a #). +# ### BEGIN LIBTOOL TAG CONFIG: $1 +_LT_LIBTOOL_TAG_VARS(_LT_TAG) +# ### END LIBTOOL TAG CONFIG: $1 +_LT_EOF +])dnl /m4_if +], +[m4_if([$1], [], [ + PACKAGE='$PACKAGE' + VERSION='$VERSION' + RM='$RM' + ofile='$ofile'], []) +])dnl /_LT_CONFIG_SAVE_COMMANDS +])# _LT_CONFIG + + +# LT_SUPPORTED_TAG(TAG) +# --------------------- +# Trace this macro to discover what tags are supported by the libtool +# --tag option, using: +# autoconf --trace 'LT_SUPPORTED_TAG:$1' +AC_DEFUN([LT_SUPPORTED_TAG], []) + + +# C support is built-in for now +m4_define([_LT_LANG_C_enabled], []) +m4_define([_LT_TAGS], []) + + +# LT_LANG(LANG) +# ------------- +# Enable libtool support for the given language if not already enabled. +AC_DEFUN([LT_LANG], +[AC_BEFORE([$0], [LT_OUTPUT])dnl +m4_case([$1], + [C], [_LT_LANG(C)], + [C++], [_LT_LANG(CXX)], + [Go], [_LT_LANG(GO)], + [Java], [_LT_LANG(GCJ)], + [Fortran 77], [_LT_LANG(F77)], + [Fortran], [_LT_LANG(FC)], + [Windows Resource], [_LT_LANG(RC)], + [m4_ifdef([_LT_LANG_]$1[_CONFIG], + [_LT_LANG($1)], + [m4_fatal([$0: unsupported language: "$1"])])])dnl +])# LT_LANG + + +# _LT_LANG(LANGNAME) +# ------------------ +m4_defun([_LT_LANG], +[m4_ifdef([_LT_LANG_]$1[_enabled], [], + [LT_SUPPORTED_TAG([$1])dnl + m4_append([_LT_TAGS], [$1 ])dnl + m4_define([_LT_LANG_]$1[_enabled], [])dnl + _LT_LANG_$1_CONFIG($1)])dnl +])# _LT_LANG + + +m4_ifndef([AC_PROG_GO], [ +############################################################ +# NOTE: This macro has been submitted for inclusion into # +# GNU Autoconf as AC_PROG_GO. When it is available in # +# a released version of Autoconf we should remove this # +# macro and use it instead. # +############################################################ +m4_defun([AC_PROG_GO], +[AC_LANG_PUSH(Go)dnl +AC_ARG_VAR([GOC], [Go compiler command])dnl +AC_ARG_VAR([GOFLAGS], [Go compiler flags])dnl +_AC_ARG_VAR_LDFLAGS()dnl +AC_CHECK_TOOL(GOC, gccgo) +if test -z "$GOC"; then + if test -n "$ac_tool_prefix"; then + AC_CHECK_PROG(GOC, [${ac_tool_prefix}gccgo], [${ac_tool_prefix}gccgo]) + fi +fi +if test -z "$GOC"; then + AC_CHECK_PROG(GOC, gccgo, gccgo, false) +fi +])#m4_defun +])#m4_ifndef + + +# _LT_LANG_DEFAULT_CONFIG +# ----------------------- +m4_defun([_LT_LANG_DEFAULT_CONFIG], +[AC_PROVIDE_IFELSE([AC_PROG_CXX], + [LT_LANG(CXX)], + [m4_define([AC_PROG_CXX], defn([AC_PROG_CXX])[LT_LANG(CXX)])]) + +AC_PROVIDE_IFELSE([AC_PROG_F77], + [LT_LANG(F77)], + [m4_define([AC_PROG_F77], defn([AC_PROG_F77])[LT_LANG(F77)])]) + +AC_PROVIDE_IFELSE([AC_PROG_FC], + [LT_LANG(FC)], + [m4_define([AC_PROG_FC], defn([AC_PROG_FC])[LT_LANG(FC)])]) + +dnl The call to [A][M_PROG_GCJ] is quoted like that to stop aclocal +dnl pulling things in needlessly. +AC_PROVIDE_IFELSE([AC_PROG_GCJ], + [LT_LANG(GCJ)], + [AC_PROVIDE_IFELSE([A][M_PROG_GCJ], + [LT_LANG(GCJ)], + [AC_PROVIDE_IFELSE([LT_PROG_GCJ], + [LT_LANG(GCJ)], + [m4_ifdef([AC_PROG_GCJ], + [m4_define([AC_PROG_GCJ], defn([AC_PROG_GCJ])[LT_LANG(GCJ)])]) + m4_ifdef([A][M_PROG_GCJ], + [m4_define([A][M_PROG_GCJ], defn([A][M_PROG_GCJ])[LT_LANG(GCJ)])]) + m4_ifdef([LT_PROG_GCJ], + [m4_define([LT_PROG_GCJ], defn([LT_PROG_GCJ])[LT_LANG(GCJ)])])])])]) + +AC_PROVIDE_IFELSE([AC_PROG_GO], + [LT_LANG(GO)], + [m4_define([AC_PROG_GO], defn([AC_PROG_GO])[LT_LANG(GO)])]) + +AC_PROVIDE_IFELSE([LT_PROG_RC], + [LT_LANG(RC)], + [m4_define([LT_PROG_RC], defn([LT_PROG_RC])[LT_LANG(RC)])]) +])# _LT_LANG_DEFAULT_CONFIG + +# Obsolete macros: +AU_DEFUN([AC_LIBTOOL_CXX], [LT_LANG(C++)]) +AU_DEFUN([AC_LIBTOOL_F77], [LT_LANG(Fortran 77)]) +AU_DEFUN([AC_LIBTOOL_FC], [LT_LANG(Fortran)]) +AU_DEFUN([AC_LIBTOOL_GCJ], [LT_LANG(Java)]) +AU_DEFUN([AC_LIBTOOL_RC], [LT_LANG(Windows Resource)]) +dnl aclocal-1.4 backwards compatibility: +dnl AC_DEFUN([AC_LIBTOOL_CXX], []) +dnl AC_DEFUN([AC_LIBTOOL_F77], []) +dnl AC_DEFUN([AC_LIBTOOL_FC], []) +dnl AC_DEFUN([AC_LIBTOOL_GCJ], []) +dnl AC_DEFUN([AC_LIBTOOL_RC], []) + + +# _LT_TAG_COMPILER +# ---------------- +m4_defun([_LT_TAG_COMPILER], +[AC_REQUIRE([AC_PROG_CC])dnl + +_LT_DECL([LTCC], [CC], [1], [A C compiler])dnl +_LT_DECL([LTCFLAGS], [CFLAGS], [1], [LTCC compiler flags])dnl +_LT_TAGDECL([CC], [compiler], [1], [A language specific compiler])dnl +_LT_TAGDECL([with_gcc], [GCC], [0], [Is the compiler the GNU compiler?])dnl + +# If no C compiler was specified, use CC. +LTCC=${LTCC-"$CC"} + +# If no C compiler flags were specified, use CFLAGS. +LTCFLAGS=${LTCFLAGS-"$CFLAGS"} + +# Allow CC to be a program name with arguments. +compiler=$CC +])# _LT_TAG_COMPILER + + +# _LT_COMPILER_BOILERPLATE +# ------------------------ +# Check for compiler boilerplate output or warnings with +# the simple compiler test code. +m4_defun([_LT_COMPILER_BOILERPLATE], +[m4_require([_LT_DECL_SED])dnl +ac_outfile=conftest.$ac_objext +echo "$lt_simple_compile_test_code" >conftest.$ac_ext +eval "$ac_compile" 2>&1 >/dev/null | $SED '/^$/d; /^ *+/d' >conftest.err +_lt_compiler_boilerplate=`cat conftest.err` +$RM conftest* +])# _LT_COMPILER_BOILERPLATE + + +# _LT_LINKER_BOILERPLATE +# ---------------------- +# Check for linker boilerplate output or warnings with +# the simple link test code. +m4_defun([_LT_LINKER_BOILERPLATE], +[m4_require([_LT_DECL_SED])dnl +ac_outfile=conftest.$ac_objext +echo "$lt_simple_link_test_code" >conftest.$ac_ext +eval "$ac_link" 2>&1 >/dev/null | $SED '/^$/d; /^ *+/d' >conftest.err +_lt_linker_boilerplate=`cat conftest.err` +$RM -r conftest* +])# _LT_LINKER_BOILERPLATE + +# _LT_REQUIRED_DARWIN_CHECKS +# ------------------------- +m4_defun_once([_LT_REQUIRED_DARWIN_CHECKS],[ + case $host_os in + rhapsody* | darwin*) + AC_CHECK_TOOL([DSYMUTIL], [dsymutil], [:]) + AC_CHECK_TOOL([NMEDIT], [nmedit], [:]) + AC_CHECK_TOOL([LIPO], [lipo], [:]) + AC_CHECK_TOOL([OTOOL], [otool], [:]) + AC_CHECK_TOOL([OTOOL64], [otool64], [:]) + _LT_DECL([], [DSYMUTIL], [1], + [Tool to manipulate archived DWARF debug symbol files on Mac OS X]) + _LT_DECL([], [NMEDIT], [1], + [Tool to change global to local symbols on Mac OS X]) + _LT_DECL([], [LIPO], [1], + [Tool to manipulate fat objects and archives on Mac OS X]) + _LT_DECL([], [OTOOL], [1], + [ldd/readelf like tool for Mach-O binaries on Mac OS X]) + _LT_DECL([], [OTOOL64], [1], + [ldd/readelf like tool for 64 bit Mach-O binaries on Mac OS X 10.4]) + + AC_CACHE_CHECK([for -single_module linker flag],[lt_cv_apple_cc_single_mod], + [lt_cv_apple_cc_single_mod=no + if test -z "$LT_MULTI_MODULE"; then + # By default we will add the -single_module flag. You can override + # by either setting the environment variable LT_MULTI_MODULE + # non-empty at configure time, or by adding -multi_module to the + # link flags. + rm -rf libconftest.dylib* + echo "int foo(void){return 1;}" > conftest.c + echo "$LTCC $LTCFLAGS $LDFLAGS -o libconftest.dylib \ +-dynamiclib -Wl,-single_module conftest.c" >&AS_MESSAGE_LOG_FD + $LTCC $LTCFLAGS $LDFLAGS -o libconftest.dylib \ + -dynamiclib -Wl,-single_module conftest.c 2>conftest.err + _lt_result=$? + # If there is a non-empty error log, and "single_module" + # appears in it, assume the flag caused a linker warning + if test -s conftest.err && $GREP single_module conftest.err; then + cat conftest.err >&AS_MESSAGE_LOG_FD + # Otherwise, if the output was created with a 0 exit code from + # the compiler, it worked. + elif test -f libconftest.dylib && test 0 = "$_lt_result"; then + lt_cv_apple_cc_single_mod=yes + else + cat conftest.err >&AS_MESSAGE_LOG_FD + fi + rm -rf libconftest.dylib* + rm -f conftest.* + fi]) + + AC_CACHE_CHECK([for -exported_symbols_list linker flag], + [lt_cv_ld_exported_symbols_list], + [lt_cv_ld_exported_symbols_list=no + save_LDFLAGS=$LDFLAGS + echo "_main" > conftest.sym + LDFLAGS="$LDFLAGS -Wl,-exported_symbols_list,conftest.sym" + AC_LINK_IFELSE([AC_LANG_PROGRAM([],[])], + [lt_cv_ld_exported_symbols_list=yes], + [lt_cv_ld_exported_symbols_list=no]) + LDFLAGS=$save_LDFLAGS + ]) + + AC_CACHE_CHECK([for -force_load linker flag],[lt_cv_ld_force_load], + [lt_cv_ld_force_load=no + cat > conftest.c << _LT_EOF +int forced_loaded() { return 2;} +_LT_EOF + echo "$LTCC $LTCFLAGS -c -o conftest.o conftest.c" >&AS_MESSAGE_LOG_FD + $LTCC $LTCFLAGS -c -o conftest.o conftest.c 2>&AS_MESSAGE_LOG_FD + echo "$AR $AR_FLAGS libconftest.a conftest.o" >&AS_MESSAGE_LOG_FD + $AR $AR_FLAGS libconftest.a conftest.o 2>&AS_MESSAGE_LOG_FD + echo "$RANLIB libconftest.a" >&AS_MESSAGE_LOG_FD + $RANLIB libconftest.a 2>&AS_MESSAGE_LOG_FD + cat > conftest.c << _LT_EOF +int main() { return 0;} +_LT_EOF + echo "$LTCC $LTCFLAGS $LDFLAGS -o conftest conftest.c -Wl,-force_load,./libconftest.a" >&AS_MESSAGE_LOG_FD + $LTCC $LTCFLAGS $LDFLAGS -o conftest conftest.c -Wl,-force_load,./libconftest.a 2>conftest.err + _lt_result=$? + if test -s conftest.err && $GREP force_load conftest.err; then + cat conftest.err >&AS_MESSAGE_LOG_FD + elif test -f conftest && test 0 = "$_lt_result" && $GREP forced_load conftest >/dev/null 2>&1; then + lt_cv_ld_force_load=yes + else + cat conftest.err >&AS_MESSAGE_LOG_FD + fi + rm -f conftest.err libconftest.a conftest conftest.c + rm -rf conftest.dSYM + ]) + case $host_os in + rhapsody* | darwin1.[[012]]) + _lt_dar_allow_undefined='$wl-undefined ${wl}suppress' ;; + darwin1.*) + _lt_dar_allow_undefined='$wl-flat_namespace $wl-undefined ${wl}suppress' ;; + darwin*) + case $MACOSX_DEPLOYMENT_TARGET,$host in + 10.[[012]],*|,*powerpc*-darwin[[5-8]]*) + _lt_dar_allow_undefined='$wl-flat_namespace $wl-undefined ${wl}suppress' ;; + *) + _lt_dar_allow_undefined='$wl-undefined ${wl}dynamic_lookup' ;; + esac + ;; + esac + if test yes = "$lt_cv_apple_cc_single_mod"; then + _lt_dar_single_mod='$single_module' + fi + if test yes = "$lt_cv_ld_exported_symbols_list"; then + _lt_dar_export_syms=' $wl-exported_symbols_list,$output_objdir/$libname-symbols.expsym' + else + _lt_dar_export_syms='~$NMEDIT -s $output_objdir/$libname-symbols.expsym $lib' + fi + if test : != "$DSYMUTIL" && test no = "$lt_cv_ld_force_load"; then + _lt_dsymutil='~$DSYMUTIL $lib || :' + else + _lt_dsymutil= + fi + ;; + esac +]) + + +# _LT_DARWIN_LINKER_FEATURES([TAG]) +# --------------------------------- +# Checks for linker and compiler features on darwin +m4_defun([_LT_DARWIN_LINKER_FEATURES], +[ + m4_require([_LT_REQUIRED_DARWIN_CHECKS]) + _LT_TAGVAR(archive_cmds_need_lc, $1)=no + _LT_TAGVAR(hardcode_direct, $1)=no + _LT_TAGVAR(hardcode_automatic, $1)=yes + _LT_TAGVAR(hardcode_shlibpath_var, $1)=unsupported + if test yes = "$lt_cv_ld_force_load"; then + _LT_TAGVAR(whole_archive_flag_spec, $1)='`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience $wl-force_load,$conv\"; done; func_echo_all \"$new_convenience\"`' + m4_case([$1], [F77], [_LT_TAGVAR(compiler_needs_object, $1)=yes], + [FC], [_LT_TAGVAR(compiler_needs_object, $1)=yes]) + else + _LT_TAGVAR(whole_archive_flag_spec, $1)='' + fi + _LT_TAGVAR(link_all_deplibs, $1)=yes + _LT_TAGVAR(allow_undefined_flag, $1)=$_lt_dar_allow_undefined + case $cc_basename in + ifort*|nagfor*) _lt_dar_can_shared=yes ;; + *) _lt_dar_can_shared=$GCC ;; + esac + if test yes = "$_lt_dar_can_shared"; then + output_verbose_link_cmd=func_echo_all + _LT_TAGVAR(archive_cmds, $1)="\$CC -dynamiclib \$allow_undefined_flag -o \$lib \$libobjs \$deplibs \$compiler_flags -install_name \$rpath/\$soname \$verstring $_lt_dar_single_mod$_lt_dsymutil" + _LT_TAGVAR(module_cmds, $1)="\$CC \$allow_undefined_flag -o \$lib -bundle \$libobjs \$deplibs \$compiler_flags$_lt_dsymutil" + _LT_TAGVAR(archive_expsym_cmds, $1)="$SED 's|^|_|' < \$export_symbols > \$output_objdir/\$libname-symbols.expsym~\$CC -dynamiclib \$allow_undefined_flag -o \$lib \$libobjs \$deplibs \$compiler_flags -install_name \$rpath/\$soname \$verstring $_lt_dar_single_mod$_lt_dar_export_syms$_lt_dsymutil" + _LT_TAGVAR(module_expsym_cmds, $1)="$SED -e 's|^|_|' < \$export_symbols > \$output_objdir/\$libname-symbols.expsym~\$CC \$allow_undefined_flag -o \$lib -bundle \$libobjs \$deplibs \$compiler_flags$_lt_dar_export_syms$_lt_dsymutil" + m4_if([$1], [CXX], +[ if test yes != "$lt_cv_apple_cc_single_mod"; then + _LT_TAGVAR(archive_cmds, $1)="\$CC -r -keep_private_externs -nostdlib -o \$lib-master.o \$libobjs~\$CC -dynamiclib \$allow_undefined_flag -o \$lib \$lib-master.o \$deplibs \$compiler_flags -install_name \$rpath/\$soname \$verstring$_lt_dsymutil" + _LT_TAGVAR(archive_expsym_cmds, $1)="$SED 's|^|_|' < \$export_symbols > \$output_objdir/\$libname-symbols.expsym~\$CC -r -keep_private_externs -nostdlib -o \$lib-master.o \$libobjs~\$CC -dynamiclib \$allow_undefined_flag -o \$lib \$lib-master.o \$deplibs \$compiler_flags -install_name \$rpath/\$soname \$verstring$_lt_dar_export_syms$_lt_dsymutil" + fi +],[]) + else + _LT_TAGVAR(ld_shlibs, $1)=no + fi +]) + +# _LT_SYS_MODULE_PATH_AIX([TAGNAME]) +# ---------------------------------- +# Links a minimal program and checks the executable +# for the system default hardcoded library path. In most cases, +# this is /usr/lib:/lib, but when the MPI compilers are used +# the location of the communication and MPI libs are included too. +# If we don't find anything, use the default library path according +# to the aix ld manual. +# Store the results from the different compilers for each TAGNAME. +# Allow to override them for all tags through lt_cv_aix_libpath. +m4_defun([_LT_SYS_MODULE_PATH_AIX], +[m4_require([_LT_DECL_SED])dnl +if test set = "${lt_cv_aix_libpath+set}"; then + aix_libpath=$lt_cv_aix_libpath +else + AC_CACHE_VAL([_LT_TAGVAR([lt_cv_aix_libpath_], [$1])], + [AC_LINK_IFELSE([AC_LANG_PROGRAM],[ + lt_aix_libpath_sed='[ + /Import File Strings/,/^$/ { + /^0/ { + s/^0 *\([^ ]*\) *$/\1/ + p + } + }]' + _LT_TAGVAR([lt_cv_aix_libpath_], [$1])=`dump -H conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"` + # Check for a 64-bit object if we didn't find anything. + if test -z "$_LT_TAGVAR([lt_cv_aix_libpath_], [$1])"; then + _LT_TAGVAR([lt_cv_aix_libpath_], [$1])=`dump -HX64 conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"` + fi],[]) + if test -z "$_LT_TAGVAR([lt_cv_aix_libpath_], [$1])"; then + _LT_TAGVAR([lt_cv_aix_libpath_], [$1])=/usr/lib:/lib + fi + ]) + aix_libpath=$_LT_TAGVAR([lt_cv_aix_libpath_], [$1]) +fi +])# _LT_SYS_MODULE_PATH_AIX + + +# _LT_SHELL_INIT(ARG) +# ------------------- +m4_define([_LT_SHELL_INIT], +[m4_divert_text([M4SH-INIT], [$1 +])])# _LT_SHELL_INIT + + + +# _LT_PROG_ECHO_BACKSLASH +# ----------------------- +# Find how we can fake an echo command that does not interpret backslash. +# In particular, with Autoconf 2.60 or later we add some code to the start +# of the generated configure script that will find a shell with a builtin +# printf (that we can use as an echo command). +m4_defun([_LT_PROG_ECHO_BACKSLASH], +[ECHO='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' +ECHO=$ECHO$ECHO$ECHO$ECHO$ECHO +ECHO=$ECHO$ECHO$ECHO$ECHO$ECHO$ECHO + +AC_MSG_CHECKING([how to print strings]) +# Test print first, because it will be a builtin if present. +if test "X`( print -r -- -n ) 2>/dev/null`" = X-n && \ + test "X`print -r -- $ECHO 2>/dev/null`" = "X$ECHO"; then + ECHO='print -r --' +elif test "X`printf %s $ECHO 2>/dev/null`" = "X$ECHO"; then + ECHO='printf %s\n' +else + # Use this function as a fallback that always works. + func_fallback_echo () + { + eval 'cat <<_LTECHO_EOF +$[]1 +_LTECHO_EOF' + } + ECHO='func_fallback_echo' +fi + +# func_echo_all arg... +# Invoke $ECHO with all args, space-separated. +func_echo_all () +{ + $ECHO "$*" +} + +case $ECHO in + printf*) AC_MSG_RESULT([printf]) ;; + print*) AC_MSG_RESULT([print -r]) ;; + *) AC_MSG_RESULT([cat]) ;; +esac + +m4_ifdef([_AS_DETECT_SUGGESTED], +[_AS_DETECT_SUGGESTED([ + test -n "${ZSH_VERSION+set}${BASH_VERSION+set}" || ( + ECHO='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' + ECHO=$ECHO$ECHO$ECHO$ECHO$ECHO + ECHO=$ECHO$ECHO$ECHO$ECHO$ECHO$ECHO + PATH=/empty FPATH=/empty; export PATH FPATH + test "X`printf %s $ECHO`" = "X$ECHO" \ + || test "X`print -r -- $ECHO`" = "X$ECHO" )])]) + +_LT_DECL([], [SHELL], [1], [Shell to use when invoking shell scripts]) +_LT_DECL([], [ECHO], [1], [An echo program that protects backslashes]) +])# _LT_PROG_ECHO_BACKSLASH + + +# _LT_WITH_SYSROOT +# ---------------- +AC_DEFUN([_LT_WITH_SYSROOT], +[m4_require([_LT_DECL_SED])dnl +AC_MSG_CHECKING([for sysroot]) +AC_ARG_WITH([sysroot], +[AS_HELP_STRING([--with-sysroot@<:@=DIR@:>@], + [Search for dependent libraries within DIR (or the compiler's sysroot + if not specified).])], +[], [with_sysroot=no]) + +dnl lt_sysroot will always be passed unquoted. We quote it here +dnl in case the user passed a directory name. +lt_sysroot= +case $with_sysroot in #( + yes) + if test yes = "$GCC"; then + lt_sysroot=`$CC --print-sysroot 2>/dev/null` + fi + ;; #( + /*) + lt_sysroot=`echo "$with_sysroot" | $SED -e "$sed_quote_subst"` + ;; #( + no|'') + ;; #( + *) + AC_MSG_RESULT([$with_sysroot]) + AC_MSG_ERROR([The sysroot must be an absolute path.]) + ;; +esac + + AC_MSG_RESULT([${lt_sysroot:-no}]) +_LT_DECL([], [lt_sysroot], [0], [The root where to search for ]dnl +[dependent libraries, and where our libraries should be installed.])]) + +# _LT_ENABLE_LOCK +# --------------- +m4_defun([_LT_ENABLE_LOCK], +[AC_ARG_ENABLE([libtool-lock], + [AS_HELP_STRING([--disable-libtool-lock], + [avoid locking (might break parallel builds)])]) +test no = "$enable_libtool_lock" || enable_libtool_lock=yes + +# Some flags need to be propagated to the compiler or linker for good +# libtool support. +case $host in +ia64-*-hpux*) + # Find out what ABI is being produced by ac_compile, and set mode + # options accordingly. + echo 'int i;' > conftest.$ac_ext + if AC_TRY_EVAL(ac_compile); then + case `$FILECMD conftest.$ac_objext` in + *ELF-32*) + HPUX_IA64_MODE=32 + ;; + *ELF-64*) + HPUX_IA64_MODE=64 + ;; + esac + fi + rm -rf conftest* + ;; +*-*-irix6*) + # Find out what ABI is being produced by ac_compile, and set linker + # options accordingly. + echo '[#]line '$LINENO' "configure"' > conftest.$ac_ext + if AC_TRY_EVAL(ac_compile); then + if test yes = "$lt_cv_prog_gnu_ld"; then + case `$FILECMD conftest.$ac_objext` in + *32-bit*) + LD="${LD-ld} -melf32bsmip" + ;; + *N32*) + LD="${LD-ld} -melf32bmipn32" + ;; + *64-bit*) + LD="${LD-ld} -melf64bmip" + ;; + esac + else + case `$FILECMD conftest.$ac_objext` in + *32-bit*) + LD="${LD-ld} -32" + ;; + *N32*) + LD="${LD-ld} -n32" + ;; + *64-bit*) + LD="${LD-ld} -64" + ;; + esac + fi + fi + rm -rf conftest* + ;; + +mips64*-*linux*) + # Find out what ABI is being produced by ac_compile, and set linker + # options accordingly. + echo '[#]line '$LINENO' "configure"' > conftest.$ac_ext + if AC_TRY_EVAL(ac_compile); then + emul=elf + case `$FILECMD conftest.$ac_objext` in + *32-bit*) + emul="${emul}32" + ;; + *64-bit*) + emul="${emul}64" + ;; + esac + case `$FILECMD conftest.$ac_objext` in + *MSB*) + emul="${emul}btsmip" + ;; + *LSB*) + emul="${emul}ltsmip" + ;; + esac + case `$FILECMD conftest.$ac_objext` in + *N32*) + emul="${emul}n32" + ;; + esac + LD="${LD-ld} -m $emul" + fi + rm -rf conftest* + ;; + +x86_64-*kfreebsd*-gnu|x86_64-*linux*|powerpc*-*linux*| \ +s390*-*linux*|s390*-*tpf*|sparc*-*linux*) + # Find out what ABI is being produced by ac_compile, and set linker + # options accordingly. Note that the listed cases only cover the + # situations where additional linker options are needed (such as when + # doing 32-bit compilation for a host where ld defaults to 64-bit, or + # vice versa); the common cases where no linker options are needed do + # not appear in the list. + echo 'int i;' > conftest.$ac_ext + if AC_TRY_EVAL(ac_compile); then + case `$FILECMD conftest.o` in + *32-bit*) + case $host in + x86_64-*kfreebsd*-gnu) + LD="${LD-ld} -m elf_i386_fbsd" + ;; + x86_64-*linux*) + case `$FILECMD conftest.o` in + *x86-64*) + LD="${LD-ld} -m elf32_x86_64" + ;; + *) + LD="${LD-ld} -m elf_i386" + ;; + esac + ;; + powerpc64le-*linux*) + LD="${LD-ld} -m elf32lppclinux" + ;; + powerpc64-*linux*) + LD="${LD-ld} -m elf32ppclinux" + ;; + s390x-*linux*) + LD="${LD-ld} -m elf_s390" + ;; + sparc64-*linux*) + LD="${LD-ld} -m elf32_sparc" + ;; + esac + ;; + *64-bit*) + case $host in + x86_64-*kfreebsd*-gnu) + LD="${LD-ld} -m elf_x86_64_fbsd" + ;; + x86_64-*linux*) + LD="${LD-ld} -m elf_x86_64" + ;; + powerpcle-*linux*) + LD="${LD-ld} -m elf64lppc" + ;; + powerpc-*linux*) + LD="${LD-ld} -m elf64ppc" + ;; + s390*-*linux*|s390*-*tpf*) + LD="${LD-ld} -m elf64_s390" + ;; + sparc*-*linux*) + LD="${LD-ld} -m elf64_sparc" + ;; + esac + ;; + esac + fi + rm -rf conftest* + ;; + +*-*-sco3.2v5*) + # On SCO OpenServer 5, we need -belf to get full-featured binaries. + SAVE_CFLAGS=$CFLAGS + CFLAGS="$CFLAGS -belf" + AC_CACHE_CHECK([whether the C compiler needs -belf], lt_cv_cc_needs_belf, + [AC_LANG_PUSH(C) + AC_LINK_IFELSE([AC_LANG_PROGRAM([[]],[[]])],[lt_cv_cc_needs_belf=yes],[lt_cv_cc_needs_belf=no]) + AC_LANG_POP]) + if test yes != "$lt_cv_cc_needs_belf"; then + # this is probably gcc 2.8.0, egcs 1.0 or newer; no need for -belf + CFLAGS=$SAVE_CFLAGS + fi + ;; +*-*solaris*) + # Find out what ABI is being produced by ac_compile, and set linker + # options accordingly. + echo 'int i;' > conftest.$ac_ext + if AC_TRY_EVAL(ac_compile); then + case `$FILECMD conftest.o` in + *64-bit*) + case $lt_cv_prog_gnu_ld in + yes*) + case $host in + i?86-*-solaris*|x86_64-*-solaris*) + LD="${LD-ld} -m elf_x86_64" + ;; + sparc*-*-solaris*) + LD="${LD-ld} -m elf64_sparc" + ;; + esac + # GNU ld 2.21 introduced _sol2 emulations. Use them if available. + if ${LD-ld} -V | grep _sol2 >/dev/null 2>&1; then + LD=${LD-ld}_sol2 + fi + ;; + *) + if ${LD-ld} -64 -r -o conftest2.o conftest.o >/dev/null 2>&1; then + LD="${LD-ld} -64" + fi + ;; + esac + ;; + esac + fi + rm -rf conftest* + ;; +esac + +need_locks=$enable_libtool_lock +])# _LT_ENABLE_LOCK + + +# _LT_PROG_AR +# ----------- +m4_defun([_LT_PROG_AR], +[AC_CHECK_TOOLS(AR, [ar], false) +: ${AR=ar} +_LT_DECL([], [AR], [1], [The archiver]) + +# Use ARFLAGS variable as AR's operation code to sync the variable naming with +# Automake. If both AR_FLAGS and ARFLAGS are specified, AR_FLAGS should have +# higher priority because thats what people were doing historically (setting +# ARFLAGS for automake and AR_FLAGS for libtool). FIXME: Make the AR_FLAGS +# variable obsoleted/removed. + +test ${AR_FLAGS+y} || AR_FLAGS=${ARFLAGS-cr} +lt_ar_flags=$AR_FLAGS +_LT_DECL([], [lt_ar_flags], [0], [Flags to create an archive (by configure)]) + +# Make AR_FLAGS overridable by 'make ARFLAGS='. Don't try to run-time override +# by AR_FLAGS because that was never working and AR_FLAGS is about to die. +_LT_DECL([], [AR_FLAGS], [\@S|@{ARFLAGS-"\@S|@lt_ar_flags"}], + [Flags to create an archive]) + +AC_CACHE_CHECK([for archiver @FILE support], [lt_cv_ar_at_file], + [lt_cv_ar_at_file=no + AC_COMPILE_IFELSE([AC_LANG_PROGRAM], + [echo conftest.$ac_objext > conftest.lst + lt_ar_try='$AR $AR_FLAGS libconftest.a @conftest.lst >&AS_MESSAGE_LOG_FD' + AC_TRY_EVAL([lt_ar_try]) + if test 0 -eq "$ac_status"; then + # Ensure the archiver fails upon bogus file names. + rm -f conftest.$ac_objext libconftest.a + AC_TRY_EVAL([lt_ar_try]) + if test 0 -ne "$ac_status"; then + lt_cv_ar_at_file=@ + fi + fi + rm -f conftest.* libconftest.a + ]) + ]) + +if test no = "$lt_cv_ar_at_file"; then + archiver_list_spec= +else + archiver_list_spec=$lt_cv_ar_at_file +fi +_LT_DECL([], [archiver_list_spec], [1], + [How to feed a file listing to the archiver]) +])# _LT_PROG_AR + + +# _LT_CMD_OLD_ARCHIVE +# ------------------- +m4_defun([_LT_CMD_OLD_ARCHIVE], +[_LT_PROG_AR + +AC_CHECK_TOOL(STRIP, strip, :) +test -z "$STRIP" && STRIP=: +_LT_DECL([], [STRIP], [1], [A symbol stripping program]) + +AC_CHECK_TOOL(RANLIB, ranlib, :) +test -z "$RANLIB" && RANLIB=: +_LT_DECL([], [RANLIB], [1], + [Commands used to install an old-style archive]) + +# Determine commands to create old-style static archives. +old_archive_cmds='$AR $AR_FLAGS $oldlib$oldobjs' +old_postinstall_cmds='chmod 644 $oldlib' +old_postuninstall_cmds= + +if test -n "$RANLIB"; then + case $host_os in + bitrig* | openbsd*) + old_postinstall_cmds="$old_postinstall_cmds~\$RANLIB -t \$tool_oldlib" + ;; + *) + old_postinstall_cmds="$old_postinstall_cmds~\$RANLIB \$tool_oldlib" + ;; + esac + old_archive_cmds="$old_archive_cmds~\$RANLIB \$tool_oldlib" +fi + +case $host_os in + darwin*) + lock_old_archive_extraction=yes ;; + *) + lock_old_archive_extraction=no ;; +esac +_LT_DECL([], [old_postinstall_cmds], [2]) +_LT_DECL([], [old_postuninstall_cmds], [2]) +_LT_TAGDECL([], [old_archive_cmds], [2], + [Commands used to build an old-style archive]) +_LT_DECL([], [lock_old_archive_extraction], [0], + [Whether to use a lock for old archive extraction]) +])# _LT_CMD_OLD_ARCHIVE + + +# _LT_COMPILER_OPTION(MESSAGE, VARIABLE-NAME, FLAGS, +# [OUTPUT-FILE], [ACTION-SUCCESS], [ACTION-FAILURE]) +# ---------------------------------------------------------------- +# Check whether the given compiler option works +AC_DEFUN([_LT_COMPILER_OPTION], +[m4_require([_LT_FILEUTILS_DEFAULTS])dnl +m4_require([_LT_DECL_SED])dnl +AC_CACHE_CHECK([$1], [$2], + [$2=no + m4_if([$4], , [ac_outfile=conftest.$ac_objext], [ac_outfile=$4]) + echo "$lt_simple_compile_test_code" > conftest.$ac_ext + lt_compiler_flag="$3" ## exclude from sc_useless_quotes_in_assignment + # Insert the option either (1) after the last *FLAGS variable, or + # (2) before a word containing "conftest.", or (3) at the end. + # Note that $ac_compile itself does not contain backslashes and begins + # with a dollar sign (not a hyphen), so the echo should work correctly. + # The option is referenced via a variable to avoid confusing sed. + lt_compile=`echo "$ac_compile" | $SED \ + -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ + -e 's: [[^ ]]*conftest\.: $lt_compiler_flag&:; t' \ + -e 's:$: $lt_compiler_flag:'` + (eval echo "\"\$as_me:$LINENO: $lt_compile\"" >&AS_MESSAGE_LOG_FD) + (eval "$lt_compile" 2>conftest.err) + ac_status=$? + cat conftest.err >&AS_MESSAGE_LOG_FD + echo "$as_me:$LINENO: \$? = $ac_status" >&AS_MESSAGE_LOG_FD + if (exit $ac_status) && test -s "$ac_outfile"; then + # The compiler can only warn and ignore the option if not recognized + # So say no if there are warnings other than the usual output. + $ECHO "$_lt_compiler_boilerplate" | $SED '/^$/d' >conftest.exp + $SED '/^$/d; /^ *+/d' conftest.err >conftest.er2 + if test ! -s conftest.er2 || diff conftest.exp conftest.er2 >/dev/null; then + $2=yes + fi + fi + $RM conftest* +]) + +if test yes = "[$]$2"; then + m4_if([$5], , :, [$5]) +else + m4_if([$6], , :, [$6]) +fi +])# _LT_COMPILER_OPTION + +# Old name: +AU_ALIAS([AC_LIBTOOL_COMPILER_OPTION], [_LT_COMPILER_OPTION]) +dnl aclocal-1.4 backwards compatibility: +dnl AC_DEFUN([AC_LIBTOOL_COMPILER_OPTION], []) + + +# _LT_LINKER_OPTION(MESSAGE, VARIABLE-NAME, FLAGS, +# [ACTION-SUCCESS], [ACTION-FAILURE]) +# ---------------------------------------------------- +# Check whether the given linker option works +AC_DEFUN([_LT_LINKER_OPTION], +[m4_require([_LT_FILEUTILS_DEFAULTS])dnl +m4_require([_LT_DECL_SED])dnl +AC_CACHE_CHECK([$1], [$2], + [$2=no + save_LDFLAGS=$LDFLAGS + LDFLAGS="$LDFLAGS $3" + echo "$lt_simple_link_test_code" > conftest.$ac_ext + if (eval $ac_link 2>conftest.err) && test -s conftest$ac_exeext; then + # The linker can only warn and ignore the option if not recognized + # So say no if there are warnings + if test -s conftest.err; then + # Append any errors to the config.log. + cat conftest.err 1>&AS_MESSAGE_LOG_FD + $ECHO "$_lt_linker_boilerplate" | $SED '/^$/d' > conftest.exp + $SED '/^$/d; /^ *+/d' conftest.err >conftest.er2 + if diff conftest.exp conftest.er2 >/dev/null; then + $2=yes + fi + else + $2=yes + fi + fi + $RM -r conftest* + LDFLAGS=$save_LDFLAGS +]) + +if test yes = "[$]$2"; then + m4_if([$4], , :, [$4]) +else + m4_if([$5], , :, [$5]) +fi +])# _LT_LINKER_OPTION + +# Old name: +AU_ALIAS([AC_LIBTOOL_LINKER_OPTION], [_LT_LINKER_OPTION]) +dnl aclocal-1.4 backwards compatibility: +dnl AC_DEFUN([AC_LIBTOOL_LINKER_OPTION], []) + + +# LT_CMD_MAX_LEN +#--------------- +AC_DEFUN([LT_CMD_MAX_LEN], +[AC_REQUIRE([AC_CANONICAL_HOST])dnl +# find the maximum length of command line arguments +AC_MSG_CHECKING([the maximum length of command line arguments]) +AC_CACHE_VAL([lt_cv_sys_max_cmd_len], [dnl + i=0 + teststring=ABCD + + case $build_os in + msdosdjgpp*) + # On DJGPP, this test can blow up pretty badly due to problems in libc + # (any single argument exceeding 2000 bytes causes a buffer overrun + # during glob expansion). Even if it were fixed, the result of this + # check would be larger than it should be. + lt_cv_sys_max_cmd_len=12288; # 12K is about right + ;; + + gnu*) + # Under GNU Hurd, this test is not required because there is + # no limit to the length of command line arguments. + # Libtool will interpret -1 as no limit whatsoever + lt_cv_sys_max_cmd_len=-1; + ;; + + cygwin* | mingw* | cegcc*) + # On Win9x/ME, this test blows up -- it succeeds, but takes + # about 5 minutes as the teststring grows exponentially. + # Worse, since 9x/ME are not pre-emptively multitasking, + # you end up with a "frozen" computer, even though with patience + # the test eventually succeeds (with a max line length of 256k). + # Instead, let's just punt: use the minimum linelength reported by + # all of the supported platforms: 8192 (on NT/2K/XP). + lt_cv_sys_max_cmd_len=8192; + ;; + + mint*) + # On MiNT this can take a long time and run out of memory. + lt_cv_sys_max_cmd_len=8192; + ;; + + amigaos*) + # On AmigaOS with pdksh, this test takes hours, literally. + # So we just punt and use a minimum line length of 8192. + lt_cv_sys_max_cmd_len=8192; + ;; + + bitrig* | darwin* | dragonfly* | freebsd* | midnightbsd* | netbsd* | openbsd*) + # This has been around since 386BSD, at least. Likely further. + if test -x /sbin/sysctl; then + lt_cv_sys_max_cmd_len=`/sbin/sysctl -n kern.argmax` + elif test -x /usr/sbin/sysctl; then + lt_cv_sys_max_cmd_len=`/usr/sbin/sysctl -n kern.argmax` + else + lt_cv_sys_max_cmd_len=65536 # usable default for all BSDs + fi + # And add a safety zone + lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \/ 4` + lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \* 3` + ;; + + interix*) + # We know the value 262144 and hardcode it with a safety zone (like BSD) + lt_cv_sys_max_cmd_len=196608 + ;; + + os2*) + # The test takes a long time on OS/2. + lt_cv_sys_max_cmd_len=8192 + ;; + + osf*) + # Dr. Hans Ekkehard Plesser reports seeing a kernel panic running configure + # due to this test when exec_disable_arg_limit is 1 on Tru64. It is not + # nice to cause kernel panics so lets avoid the loop below. + # First set a reasonable default. + lt_cv_sys_max_cmd_len=16384 + # + if test -x /sbin/sysconfig; then + case `/sbin/sysconfig -q proc exec_disable_arg_limit` in + *1*) lt_cv_sys_max_cmd_len=-1 ;; + esac + fi + ;; + sco3.2v5*) + lt_cv_sys_max_cmd_len=102400 + ;; + sysv5* | sco5v6* | sysv4.2uw2*) + kargmax=`grep ARG_MAX /etc/conf/cf.d/stune 2>/dev/null` + if test -n "$kargmax"; then + lt_cv_sys_max_cmd_len=`echo $kargmax | $SED 's/.*[[ ]]//'` + else + lt_cv_sys_max_cmd_len=32768 + fi + ;; + *) + lt_cv_sys_max_cmd_len=`(getconf ARG_MAX) 2> /dev/null` + if test -n "$lt_cv_sys_max_cmd_len" && \ + test undefined != "$lt_cv_sys_max_cmd_len"; then + lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \/ 4` + lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \* 3` + else + # Make teststring a little bigger before we do anything with it. + # a 1K string should be a reasonable start. + for i in 1 2 3 4 5 6 7 8; do + teststring=$teststring$teststring + done + SHELL=${SHELL-${CONFIG_SHELL-/bin/sh}} + # If test is not a shell built-in, we'll probably end up computing a + # maximum length that is only half of the actual maximum length, but + # we can't tell. + while { test X`env echo "$teststring$teststring" 2>/dev/null` \ + = "X$teststring$teststring"; } >/dev/null 2>&1 && + test 17 != "$i" # 1/2 MB should be enough + do + i=`expr $i + 1` + teststring=$teststring$teststring + done + # Only check the string length outside the loop. + lt_cv_sys_max_cmd_len=`expr "X$teststring" : ".*" 2>&1` + teststring= + # Add a significant safety factor because C++ compilers can tack on + # massive amounts of additional arguments before passing them to the + # linker. It appears as though 1/2 is a usable value. + lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \/ 2` + fi + ;; + esac +]) +if test -n "$lt_cv_sys_max_cmd_len"; then + AC_MSG_RESULT($lt_cv_sys_max_cmd_len) +else + AC_MSG_RESULT(none) +fi +max_cmd_len=$lt_cv_sys_max_cmd_len +_LT_DECL([], [max_cmd_len], [0], + [What is the maximum length of a command?]) +])# LT_CMD_MAX_LEN + +# Old name: +AU_ALIAS([AC_LIBTOOL_SYS_MAX_CMD_LEN], [LT_CMD_MAX_LEN]) +dnl aclocal-1.4 backwards compatibility: +dnl AC_DEFUN([AC_LIBTOOL_SYS_MAX_CMD_LEN], []) + + +# _LT_HEADER_DLFCN +# ---------------- +m4_defun([_LT_HEADER_DLFCN], +[AC_CHECK_HEADERS([dlfcn.h], [], [], [AC_INCLUDES_DEFAULT])dnl +])# _LT_HEADER_DLFCN + + +# _LT_TRY_DLOPEN_SELF (ACTION-IF-TRUE, ACTION-IF-TRUE-W-USCORE, +# ACTION-IF-FALSE, ACTION-IF-CROSS-COMPILING) +# ---------------------------------------------------------------- +m4_defun([_LT_TRY_DLOPEN_SELF], +[m4_require([_LT_HEADER_DLFCN])dnl +if test yes = "$cross_compiling"; then : + [$4] +else + lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2 + lt_status=$lt_dlunknown + cat > conftest.$ac_ext <<_LT_EOF +[#line $LINENO "configure" +#include "confdefs.h" + +#if HAVE_DLFCN_H +#include +#endif + +#include + +#ifdef RTLD_GLOBAL +# define LT_DLGLOBAL RTLD_GLOBAL +#else +# ifdef DL_GLOBAL +# define LT_DLGLOBAL DL_GLOBAL +# else +# define LT_DLGLOBAL 0 +# endif +#endif + +/* We may have to define LT_DLLAZY_OR_NOW in the command line if we + find out it does not work in some platform. */ +#ifndef LT_DLLAZY_OR_NOW +# ifdef RTLD_LAZY +# define LT_DLLAZY_OR_NOW RTLD_LAZY +# else +# ifdef DL_LAZY +# define LT_DLLAZY_OR_NOW DL_LAZY +# else +# ifdef RTLD_NOW +# define LT_DLLAZY_OR_NOW RTLD_NOW +# else +# ifdef DL_NOW +# define LT_DLLAZY_OR_NOW DL_NOW +# else +# define LT_DLLAZY_OR_NOW 0 +# endif +# endif +# endif +# endif +#endif + +/* When -fvisibility=hidden is used, assume the code has been annotated + correspondingly for the symbols needed. */ +#if defined __GNUC__ && (((__GNUC__ == 3) && (__GNUC_MINOR__ >= 3)) || (__GNUC__ > 3)) +int fnord () __attribute__((visibility("default"))); +#endif + +int fnord () { return 42; } +int main () +{ + void *self = dlopen (0, LT_DLGLOBAL|LT_DLLAZY_OR_NOW); + int status = $lt_dlunknown; + + if (self) + { + if (dlsym (self,"fnord")) status = $lt_dlno_uscore; + else + { + if (dlsym( self,"_fnord")) status = $lt_dlneed_uscore; + else puts (dlerror ()); + } + /* dlclose (self); */ + } + else + puts (dlerror ()); + + return status; +}] +_LT_EOF + if AC_TRY_EVAL(ac_link) && test -s "conftest$ac_exeext" 2>/dev/null; then + (./conftest; exit; ) >&AS_MESSAGE_LOG_FD 2>/dev/null + lt_status=$? + case x$lt_status in + x$lt_dlno_uscore) $1 ;; + x$lt_dlneed_uscore) $2 ;; + x$lt_dlunknown|x*) $3 ;; + esac + else : + # compilation failed + $3 + fi +fi +rm -fr conftest* +])# _LT_TRY_DLOPEN_SELF + + +# LT_SYS_DLOPEN_SELF +# ------------------ +AC_DEFUN([LT_SYS_DLOPEN_SELF], +[m4_require([_LT_HEADER_DLFCN])dnl +if test yes != "$enable_dlopen"; then + enable_dlopen=unknown + enable_dlopen_self=unknown + enable_dlopen_self_static=unknown +else + lt_cv_dlopen=no + lt_cv_dlopen_libs= + + case $host_os in + beos*) + lt_cv_dlopen=load_add_on + lt_cv_dlopen_libs= + lt_cv_dlopen_self=yes + ;; + + mingw* | pw32* | cegcc*) + lt_cv_dlopen=LoadLibrary + lt_cv_dlopen_libs= + ;; + + cygwin*) + lt_cv_dlopen=dlopen + lt_cv_dlopen_libs= + ;; + + darwin*) + # if libdl is installed we need to link against it + AC_CHECK_LIB([dl], [dlopen], + [lt_cv_dlopen=dlopen lt_cv_dlopen_libs=-ldl],[ + lt_cv_dlopen=dyld + lt_cv_dlopen_libs= + lt_cv_dlopen_self=yes + ]) + ;; + + tpf*) + # Don't try to run any link tests for TPF. We know it's impossible + # because TPF is a cross-compiler, and we know how we open DSOs. + lt_cv_dlopen=dlopen + lt_cv_dlopen_libs= + lt_cv_dlopen_self=no + ;; + + *) + AC_CHECK_FUNC([shl_load], + [lt_cv_dlopen=shl_load], + [AC_CHECK_LIB([dld], [shl_load], + [lt_cv_dlopen=shl_load lt_cv_dlopen_libs=-ldld], + [AC_CHECK_FUNC([dlopen], + [lt_cv_dlopen=dlopen], + [AC_CHECK_LIB([dl], [dlopen], + [lt_cv_dlopen=dlopen lt_cv_dlopen_libs=-ldl], + [AC_CHECK_LIB([svld], [dlopen], + [lt_cv_dlopen=dlopen lt_cv_dlopen_libs=-lsvld], + [AC_CHECK_LIB([dld], [dld_link], + [lt_cv_dlopen=dld_link lt_cv_dlopen_libs=-ldld]) + ]) + ]) + ]) + ]) + ]) + ;; + esac + + if test no = "$lt_cv_dlopen"; then + enable_dlopen=no + else + enable_dlopen=yes + fi + + case $lt_cv_dlopen in + dlopen) + save_CPPFLAGS=$CPPFLAGS + test yes = "$ac_cv_header_dlfcn_h" && CPPFLAGS="$CPPFLAGS -DHAVE_DLFCN_H" + + save_LDFLAGS=$LDFLAGS + wl=$lt_prog_compiler_wl eval LDFLAGS=\"\$LDFLAGS $export_dynamic_flag_spec\" + + save_LIBS=$LIBS + LIBS="$lt_cv_dlopen_libs $LIBS" + + AC_CACHE_CHECK([whether a program can dlopen itself], + lt_cv_dlopen_self, [dnl + _LT_TRY_DLOPEN_SELF( + lt_cv_dlopen_self=yes, lt_cv_dlopen_self=yes, + lt_cv_dlopen_self=no, lt_cv_dlopen_self=cross) + ]) + + if test yes = "$lt_cv_dlopen_self"; then + wl=$lt_prog_compiler_wl eval LDFLAGS=\"\$LDFLAGS $lt_prog_compiler_static\" + AC_CACHE_CHECK([whether a statically linked program can dlopen itself], + lt_cv_dlopen_self_static, [dnl + _LT_TRY_DLOPEN_SELF( + lt_cv_dlopen_self_static=yes, lt_cv_dlopen_self_static=yes, + lt_cv_dlopen_self_static=no, lt_cv_dlopen_self_static=cross) + ]) + fi + + CPPFLAGS=$save_CPPFLAGS + LDFLAGS=$save_LDFLAGS + LIBS=$save_LIBS + ;; + esac + + case $lt_cv_dlopen_self in + yes|no) enable_dlopen_self=$lt_cv_dlopen_self ;; + *) enable_dlopen_self=unknown ;; + esac + + case $lt_cv_dlopen_self_static in + yes|no) enable_dlopen_self_static=$lt_cv_dlopen_self_static ;; + *) enable_dlopen_self_static=unknown ;; + esac +fi +_LT_DECL([dlopen_support], [enable_dlopen], [0], + [Whether dlopen is supported]) +_LT_DECL([dlopen_self], [enable_dlopen_self], [0], + [Whether dlopen of programs is supported]) +_LT_DECL([dlopen_self_static], [enable_dlopen_self_static], [0], + [Whether dlopen of statically linked programs is supported]) +])# LT_SYS_DLOPEN_SELF + +# Old name: +AU_ALIAS([AC_LIBTOOL_DLOPEN_SELF], [LT_SYS_DLOPEN_SELF]) +dnl aclocal-1.4 backwards compatibility: +dnl AC_DEFUN([AC_LIBTOOL_DLOPEN_SELF], []) + + +# _LT_COMPILER_C_O([TAGNAME]) +# --------------------------- +# Check to see if options -c and -o are simultaneously supported by compiler. +# This macro does not hard code the compiler like AC_PROG_CC_C_O. +m4_defun([_LT_COMPILER_C_O], +[m4_require([_LT_DECL_SED])dnl +m4_require([_LT_FILEUTILS_DEFAULTS])dnl +m4_require([_LT_TAG_COMPILER])dnl +AC_CACHE_CHECK([if $compiler supports -c -o file.$ac_objext], + [_LT_TAGVAR(lt_cv_prog_compiler_c_o, $1)], + [_LT_TAGVAR(lt_cv_prog_compiler_c_o, $1)=no + $RM -r conftest 2>/dev/null + mkdir conftest + cd conftest + mkdir out + echo "$lt_simple_compile_test_code" > conftest.$ac_ext + + lt_compiler_flag="-o out/conftest2.$ac_objext" + # Insert the option either (1) after the last *FLAGS variable, or + # (2) before a word containing "conftest.", or (3) at the end. + # Note that $ac_compile itself does not contain backslashes and begins + # with a dollar sign (not a hyphen), so the echo should work correctly. + lt_compile=`echo "$ac_compile" | $SED \ + -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ + -e 's: [[^ ]]*conftest\.: $lt_compiler_flag&:; t' \ + -e 's:$: $lt_compiler_flag:'` + (eval echo "\"\$as_me:$LINENO: $lt_compile\"" >&AS_MESSAGE_LOG_FD) + (eval "$lt_compile" 2>out/conftest.err) + ac_status=$? + cat out/conftest.err >&AS_MESSAGE_LOG_FD + echo "$as_me:$LINENO: \$? = $ac_status" >&AS_MESSAGE_LOG_FD + if (exit $ac_status) && test -s out/conftest2.$ac_objext + then + # The compiler can only warn and ignore the option if not recognized + # So say no if there are warnings + $ECHO "$_lt_compiler_boilerplate" | $SED '/^$/d' > out/conftest.exp + $SED '/^$/d; /^ *+/d' out/conftest.err >out/conftest.er2 + if test ! -s out/conftest.er2 || diff out/conftest.exp out/conftest.er2 >/dev/null; then + _LT_TAGVAR(lt_cv_prog_compiler_c_o, $1)=yes + fi + fi + chmod u+w . 2>&AS_MESSAGE_LOG_FD + $RM conftest* + # SGI C++ compiler will create directory out/ii_files/ for + # template instantiation + test -d out/ii_files && $RM out/ii_files/* && rmdir out/ii_files + $RM out/* && rmdir out + cd .. + $RM -r conftest + $RM conftest* +]) +_LT_TAGDECL([compiler_c_o], [lt_cv_prog_compiler_c_o], [1], + [Does compiler simultaneously support -c and -o options?]) +])# _LT_COMPILER_C_O + + +# _LT_COMPILER_FILE_LOCKS([TAGNAME]) +# ---------------------------------- +# Check to see if we can do hard links to lock some files if needed +m4_defun([_LT_COMPILER_FILE_LOCKS], +[m4_require([_LT_ENABLE_LOCK])dnl +m4_require([_LT_FILEUTILS_DEFAULTS])dnl +_LT_COMPILER_C_O([$1]) + +hard_links=nottested +if test no = "$_LT_TAGVAR(lt_cv_prog_compiler_c_o, $1)" && test no != "$need_locks"; then + # do not overwrite the value of need_locks provided by the user + AC_MSG_CHECKING([if we can lock with hard links]) + hard_links=yes + $RM conftest* + ln conftest.a conftest.b 2>/dev/null && hard_links=no + touch conftest.a + ln conftest.a conftest.b 2>&5 || hard_links=no + ln conftest.a conftest.b 2>/dev/null && hard_links=no + AC_MSG_RESULT([$hard_links]) + if test no = "$hard_links"; then + AC_MSG_WARN(['$CC' does not support '-c -o', so 'make -j' may be unsafe]) + need_locks=warn + fi +else + need_locks=no +fi +_LT_DECL([], [need_locks], [1], [Must we lock files when doing compilation?]) +])# _LT_COMPILER_FILE_LOCKS + + +# _LT_CHECK_OBJDIR +# ---------------- +m4_defun([_LT_CHECK_OBJDIR], +[AC_CACHE_CHECK([for objdir], [lt_cv_objdir], +[rm -f .libs 2>/dev/null +mkdir .libs 2>/dev/null +if test -d .libs; then + lt_cv_objdir=.libs +else + # MS-DOS does not allow filenames that begin with a dot. + lt_cv_objdir=_libs +fi +rmdir .libs 2>/dev/null]) +objdir=$lt_cv_objdir +_LT_DECL([], [objdir], [0], + [The name of the directory that contains temporary libtool files])dnl +m4_pattern_allow([LT_OBJDIR])dnl +AC_DEFINE_UNQUOTED([LT_OBJDIR], "$lt_cv_objdir/", + [Define to the sub-directory where libtool stores uninstalled libraries.]) +])# _LT_CHECK_OBJDIR + + +# _LT_LINKER_HARDCODE_LIBPATH([TAGNAME]) +# -------------------------------------- +# Check hardcoding attributes. +m4_defun([_LT_LINKER_HARDCODE_LIBPATH], +[AC_MSG_CHECKING([how to hardcode library paths into programs]) +_LT_TAGVAR(hardcode_action, $1)= +if test -n "$_LT_TAGVAR(hardcode_libdir_flag_spec, $1)" || + test -n "$_LT_TAGVAR(runpath_var, $1)" || + test yes = "$_LT_TAGVAR(hardcode_automatic, $1)"; then + + # We can hardcode non-existent directories. + if test no != "$_LT_TAGVAR(hardcode_direct, $1)" && + # If the only mechanism to avoid hardcoding is shlibpath_var, we + # have to relink, otherwise we might link with an installed library + # when we should be linking with a yet-to-be-installed one + ## test no != "$_LT_TAGVAR(hardcode_shlibpath_var, $1)" && + test no != "$_LT_TAGVAR(hardcode_minus_L, $1)"; then + # Linking always hardcodes the temporary library directory. + _LT_TAGVAR(hardcode_action, $1)=relink + else + # We can link without hardcoding, and we can hardcode nonexisting dirs. + _LT_TAGVAR(hardcode_action, $1)=immediate + fi +else + # We cannot hardcode anything, or else we can only hardcode existing + # directories. + _LT_TAGVAR(hardcode_action, $1)=unsupported +fi +AC_MSG_RESULT([$_LT_TAGVAR(hardcode_action, $1)]) + +if test relink = "$_LT_TAGVAR(hardcode_action, $1)" || + test yes = "$_LT_TAGVAR(inherit_rpath, $1)"; then + # Fast installation is not supported + enable_fast_install=no +elif test yes = "$shlibpath_overrides_runpath" || + test no = "$enable_shared"; then + # Fast installation is not necessary + enable_fast_install=needless +fi +_LT_TAGDECL([], [hardcode_action], [0], + [How to hardcode a shared library path into an executable]) +])# _LT_LINKER_HARDCODE_LIBPATH + + +# _LT_CMD_STRIPLIB +# ---------------- +m4_defun([_LT_CMD_STRIPLIB], +[m4_require([_LT_DECL_EGREP]) +striplib= +old_striplib= +AC_MSG_CHECKING([whether stripping libraries is possible]) +if test -z "$STRIP"; then + AC_MSG_RESULT([no]) +else + if $STRIP -V 2>&1 | $GREP "GNU strip" >/dev/null; then + old_striplib="$STRIP --strip-debug" + striplib="$STRIP --strip-unneeded" + AC_MSG_RESULT([yes]) + else + case $host_os in + darwin*) + # FIXME - insert some real tests, host_os isn't really good enough + striplib="$STRIP -x" + old_striplib="$STRIP -S" + AC_MSG_RESULT([yes]) + ;; + freebsd*) + if $STRIP -V 2>&1 | $GREP "elftoolchain" >/dev/null; then + old_striplib="$STRIP --strip-debug" + striplib="$STRIP --strip-unneeded" + AC_MSG_RESULT([yes]) + else + AC_MSG_RESULT([no]) + fi + ;; + *) + AC_MSG_RESULT([no]) + ;; + esac + fi +fi +_LT_DECL([], [old_striplib], [1], [Commands to strip libraries]) +_LT_DECL([], [striplib], [1]) +])# _LT_CMD_STRIPLIB + + +# _LT_PREPARE_MUNGE_PATH_LIST +# --------------------------- +# Make sure func_munge_path_list() is defined correctly. +m4_defun([_LT_PREPARE_MUNGE_PATH_LIST], +[[# func_munge_path_list VARIABLE PATH +# ----------------------------------- +# VARIABLE is name of variable containing _space_ separated list of +# directories to be munged by the contents of PATH, which is string +# having a format: +# "DIR[:DIR]:" +# string "DIR[ DIR]" will be prepended to VARIABLE +# ":DIR[:DIR]" +# string "DIR[ DIR]" will be appended to VARIABLE +# "DIRP[:DIRP]::[DIRA:]DIRA" +# string "DIRP[ DIRP]" will be prepended to VARIABLE and string +# "DIRA[ DIRA]" will be appended to VARIABLE +# "DIR[:DIR]" +# VARIABLE will be replaced by "DIR[ DIR]" +func_munge_path_list () +{ + case x@S|@2 in + x) + ;; + *:) + eval @S|@1=\"`$ECHO @S|@2 | $SED 's/:/ /g'` \@S|@@S|@1\" + ;; + x:*) + eval @S|@1=\"\@S|@@S|@1 `$ECHO @S|@2 | $SED 's/:/ /g'`\" + ;; + *::*) + eval @S|@1=\"\@S|@@S|@1\ `$ECHO @S|@2 | $SED -e 's/.*:://' -e 's/:/ /g'`\" + eval @S|@1=\"`$ECHO @S|@2 | $SED -e 's/::.*//' -e 's/:/ /g'`\ \@S|@@S|@1\" + ;; + *) + eval @S|@1=\"`$ECHO @S|@2 | $SED 's/:/ /g'`\" + ;; + esac +} +]])# _LT_PREPARE_PATH_LIST + + +# _LT_SYS_DYNAMIC_LINKER([TAG]) +# ----------------------------- +# PORTME Fill in your ld.so characteristics +m4_defun([_LT_SYS_DYNAMIC_LINKER], +[AC_REQUIRE([AC_CANONICAL_HOST])dnl +m4_require([_LT_DECL_EGREP])dnl +m4_require([_LT_FILEUTILS_DEFAULTS])dnl +m4_require([_LT_DECL_OBJDUMP])dnl +m4_require([_LT_DECL_SED])dnl +m4_require([_LT_CHECK_SHELL_FEATURES])dnl +m4_require([_LT_PREPARE_MUNGE_PATH_LIST])dnl +AC_MSG_CHECKING([dynamic linker characteristics]) +m4_if([$1], + [], [ +if test yes = "$GCC"; then + case $host_os in + darwin*) lt_awk_arg='/^libraries:/,/LR/' ;; + *) lt_awk_arg='/^libraries:/' ;; + esac + case $host_os in + mingw* | cegcc*) lt_sed_strip_eq='s|=\([[A-Za-z]]:\)|\1|g' ;; + *) lt_sed_strip_eq='s|=/|/|g' ;; + esac + lt_search_path_spec=`$CC -print-search-dirs | awk $lt_awk_arg | $SED -e "s/^libraries://" -e $lt_sed_strip_eq` + case $lt_search_path_spec in + *\;*) + # if the path contains ";" then we assume it to be the separator + # otherwise default to the standard path separator (i.e. ":") - it is + # assumed that no part of a normal pathname contains ";" but that should + # okay in the real world where ";" in dirpaths is itself problematic. + lt_search_path_spec=`$ECHO "$lt_search_path_spec" | $SED 's/;/ /g'` + ;; + *) + lt_search_path_spec=`$ECHO "$lt_search_path_spec" | $SED "s/$PATH_SEPARATOR/ /g"` + ;; + esac + # Ok, now we have the path, separated by spaces, we can step through it + # and add multilib dir if necessary... + lt_tmp_lt_search_path_spec= + lt_multi_os_dir=/`$CC $CPPFLAGS $CFLAGS $LDFLAGS -print-multi-os-directory 2>/dev/null` + # ...but if some path component already ends with the multilib dir we assume + # that all is fine and trust -print-search-dirs as is (GCC 4.2? or newer). + case "$lt_multi_os_dir; $lt_search_path_spec " in + "/; "* | "/.; "* | "/./; "* | *"$lt_multi_os_dir "* | *"$lt_multi_os_dir/ "*) + lt_multi_os_dir= + ;; + esac + for lt_sys_path in $lt_search_path_spec; do + if test -d "$lt_sys_path$lt_multi_os_dir"; then + lt_tmp_lt_search_path_spec="$lt_tmp_lt_search_path_spec $lt_sys_path$lt_multi_os_dir" + elif test -n "$lt_multi_os_dir"; then + test -d "$lt_sys_path" && \ + lt_tmp_lt_search_path_spec="$lt_tmp_lt_search_path_spec $lt_sys_path" + fi + done + lt_search_path_spec=`$ECHO "$lt_tmp_lt_search_path_spec" | awk ' +BEGIN {RS = " "; FS = "/|\n";} { + lt_foo = ""; + lt_count = 0; + for (lt_i = NF; lt_i > 0; lt_i--) { + if ($lt_i != "" && $lt_i != ".") { + if ($lt_i == "..") { + lt_count++; + } else { + if (lt_count == 0) { + lt_foo = "/" $lt_i lt_foo; + } else { + lt_count--; + } + } + } + } + if (lt_foo != "") { lt_freq[[lt_foo]]++; } + if (lt_freq[[lt_foo]] == 1) { print lt_foo; } +}'` + # AWK program above erroneously prepends '/' to C:/dos/paths + # for these hosts. + case $host_os in + mingw* | cegcc*) lt_search_path_spec=`$ECHO "$lt_search_path_spec" |\ + $SED 's|/\([[A-Za-z]]:\)|\1|g'` ;; + esac + sys_lib_search_path_spec=`$ECHO "$lt_search_path_spec" | $lt_NL2SP` +else + sys_lib_search_path_spec="/lib /usr/lib /usr/local/lib" +fi]) +library_names_spec= +libname_spec='lib$name' +soname_spec= +shrext_cmds=.so +postinstall_cmds= +postuninstall_cmds= +finish_cmds= +finish_eval= +shlibpath_var= +shlibpath_overrides_runpath=unknown +version_type=none +dynamic_linker="$host_os ld.so" +sys_lib_dlsearch_path_spec="/lib /usr/lib" +need_lib_prefix=unknown +hardcode_into_libs=no + +# when you set need_version to no, make sure it does not cause -set_version +# flags to be left without arguments +need_version=unknown + +AC_ARG_VAR([LT_SYS_LIBRARY_PATH], +[User-defined run-time library search path.]) + +case $host_os in +aix3*) + version_type=linux # correct to gnu/linux during the next big refactor + library_names_spec='$libname$release$shared_ext$versuffix $libname.a' + shlibpath_var=LIBPATH + + # AIX 3 has no versioning support, so we append a major version to the name. + soname_spec='$libname$release$shared_ext$major' + ;; + +aix[[4-9]]*) + version_type=linux # correct to gnu/linux during the next big refactor + need_lib_prefix=no + need_version=no + hardcode_into_libs=yes + if test ia64 = "$host_cpu"; then + # AIX 5 supports IA64 + library_names_spec='$libname$release$shared_ext$major $libname$release$shared_ext$versuffix $libname$shared_ext' + shlibpath_var=LD_LIBRARY_PATH + else + # With GCC up to 2.95.x, collect2 would create an import file + # for dependence libraries. The import file would start with + # the line '#! .'. This would cause the generated library to + # depend on '.', always an invalid library. This was fixed in + # development snapshots of GCC prior to 3.0. + case $host_os in + aix4 | aix4.[[01]] | aix4.[[01]].*) + if { echo '#if __GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 97)' + echo ' yes ' + echo '#endif'; } | $CC -E - | $GREP yes > /dev/null; then + : + else + can_build_shared=no + fi + ;; + esac + # Using Import Files as archive members, it is possible to support + # filename-based versioning of shared library archives on AIX. While + # this would work for both with and without runtime linking, it will + # prevent static linking of such archives. So we do filename-based + # shared library versioning with .so extension only, which is used + # when both runtime linking and shared linking is enabled. + # Unfortunately, runtime linking may impact performance, so we do + # not want this to be the default eventually. Also, we use the + # versioned .so libs for executables only if there is the -brtl + # linker flag in LDFLAGS as well, or --with-aix-soname=svr4 only. + # To allow for filename-based versioning support, we need to create + # libNAME.so.V as an archive file, containing: + # *) an Import File, referring to the versioned filename of the + # archive as well as the shared archive member, telling the + # bitwidth (32 or 64) of that shared object, and providing the + # list of exported symbols of that shared object, eventually + # decorated with the 'weak' keyword + # *) the shared object with the F_LOADONLY flag set, to really avoid + # it being seen by the linker. + # At run time we better use the real file rather than another symlink, + # but for link time we create the symlink libNAME.so -> libNAME.so.V + + case $with_aix_soname,$aix_use_runtimelinking in + # AIX (on Power*) has no versioning support, so currently we cannot hardcode correct + # soname into executable. Probably we can add versioning support to + # collect2, so additional links can be useful in future. + aix,yes) # traditional libtool + dynamic_linker='AIX unversionable lib.so' + # If using run time linking (on AIX 4.2 or later) use lib.so + # instead of lib.a to let people know that these are not + # typical AIX shared libraries. + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + ;; + aix,no) # traditional AIX only + dynamic_linker='AIX lib.a[(]lib.so.V[)]' + # We preserve .a as extension for shared libraries through AIX4.2 + # and later when we are not doing run time linking. + library_names_spec='$libname$release.a $libname.a' + soname_spec='$libname$release$shared_ext$major' + ;; + svr4,*) # full svr4 only + dynamic_linker="AIX lib.so.V[(]$shared_archive_member_spec.o[)]" + library_names_spec='$libname$release$shared_ext$major $libname$shared_ext' + # We do not specify a path in Import Files, so LIBPATH fires. + shlibpath_overrides_runpath=yes + ;; + *,yes) # both, prefer svr4 + dynamic_linker="AIX lib.so.V[(]$shared_archive_member_spec.o[)], lib.a[(]lib.so.V[)]" + library_names_spec='$libname$release$shared_ext$major $libname$shared_ext' + # unpreferred sharedlib libNAME.a needs extra handling + postinstall_cmds='test -n "$linkname" || linkname="$realname"~func_stripname "" ".so" "$linkname"~$install_shared_prog "$dir/$func_stripname_result.$libext" "$destdir/$func_stripname_result.$libext"~test -z "$tstripme" || test -z "$striplib" || $striplib "$destdir/$func_stripname_result.$libext"' + postuninstall_cmds='for n in $library_names $old_library; do :; done~func_stripname "" ".so" "$n"~test "$func_stripname_result" = "$n" || func_append rmfiles " $odir/$func_stripname_result.$libext"' + # We do not specify a path in Import Files, so LIBPATH fires. + shlibpath_overrides_runpath=yes + ;; + *,no) # both, prefer aix + dynamic_linker="AIX lib.a[(]lib.so.V[)], lib.so.V[(]$shared_archive_member_spec.o[)]" + library_names_spec='$libname$release.a $libname.a' + soname_spec='$libname$release$shared_ext$major' + # unpreferred sharedlib libNAME.so.V and symlink libNAME.so need extra handling + postinstall_cmds='test -z "$dlname" || $install_shared_prog $dir/$dlname $destdir/$dlname~test -z "$tstripme" || test -z "$striplib" || $striplib $destdir/$dlname~test -n "$linkname" || linkname=$realname~func_stripname "" ".a" "$linkname"~(cd "$destdir" && $LN_S -f $dlname $func_stripname_result.so)' + postuninstall_cmds='test -z "$dlname" || func_append rmfiles " $odir/$dlname"~for n in $old_library $library_names; do :; done~func_stripname "" ".a" "$n"~func_append rmfiles " $odir/$func_stripname_result.so"' + ;; + esac + shlibpath_var=LIBPATH + fi + ;; + +amigaos*) + case $host_cpu in + powerpc) + # Since July 2007 AmigaOS4 officially supports .so libraries. + # When compiling the executable, add -use-dynld -Lsobjs: to the compileline. + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + ;; + m68k) + library_names_spec='$libname.ixlibrary $libname.a' + # Create ${libname}_ixlibrary.a entries in /sys/libs. + finish_eval='for lib in `ls $libdir/*.ixlibrary 2>/dev/null`; do libname=`func_echo_all "$lib" | $SED '\''s%^.*/\([[^/]]*\)\.ixlibrary$%\1%'\''`; $RM /sys/libs/${libname}_ixlibrary.a; $show "cd /sys/libs && $LN_S $lib ${libname}_ixlibrary.a"; cd /sys/libs && $LN_S $lib ${libname}_ixlibrary.a || exit 1; done' + ;; + esac + ;; + +beos*) + library_names_spec='$libname$shared_ext' + dynamic_linker="$host_os ld.so" + shlibpath_var=LIBRARY_PATH + ;; + +bsdi[[45]]*) + version_type=linux # correct to gnu/linux during the next big refactor + need_version=no + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + soname_spec='$libname$release$shared_ext$major' + finish_cmds='PATH="\$PATH:/sbin" ldconfig $libdir' + shlibpath_var=LD_LIBRARY_PATH + sys_lib_search_path_spec="/shlib /usr/lib /usr/X11/lib /usr/contrib/lib /lib /usr/local/lib" + sys_lib_dlsearch_path_spec="/shlib /usr/lib /usr/local/lib" + # the default ld.so.conf also contains /usr/contrib/lib and + # /usr/X11R6/lib (/usr/X11 is a link to /usr/X11R6), but let us allow + # libtool to hard-code these into programs + ;; + +cygwin* | mingw* | pw32* | cegcc*) + version_type=windows + shrext_cmds=.dll + need_version=no + need_lib_prefix=no + + case $GCC,$cc_basename in + yes,*) + # gcc + library_names_spec='$libname.dll.a' + # DLL is installed to $(libdir)/../bin by postinstall_cmds + postinstall_cmds='base_file=`basename \$file`~ + dlpath=`$SHELL 2>&1 -c '\''. $dir/'\''\$base_file'\''i; echo \$dlname'\''`~ + dldir=$destdir/`dirname \$dlpath`~ + test -d \$dldir || mkdir -p \$dldir~ + $install_prog $dir/$dlname \$dldir/$dlname~ + chmod a+x \$dldir/$dlname~ + if test -n '\''$stripme'\'' && test -n '\''$striplib'\''; then + eval '\''$striplib \$dldir/$dlname'\'' || exit \$?; + fi' + postuninstall_cmds='dldll=`$SHELL 2>&1 -c '\''. $file; echo \$dlname'\''`~ + dlpath=$dir/\$dldll~ + $RM \$dlpath' + shlibpath_overrides_runpath=yes + + case $host_os in + cygwin*) + # Cygwin DLLs use 'cyg' prefix rather than 'lib' + soname_spec='`echo $libname | $SED -e 's/^lib/cyg/'``echo $release | $SED -e 's/[[.]]/-/g'`$versuffix$shared_ext' +m4_if([$1], [],[ + sys_lib_search_path_spec="$sys_lib_search_path_spec /usr/lib/w32api"]) + ;; + mingw* | cegcc*) + # MinGW DLLs use traditional 'lib' prefix + soname_spec='$libname`echo $release | $SED -e 's/[[.]]/-/g'`$versuffix$shared_ext' + ;; + pw32*) + # pw32 DLLs use 'pw' prefix rather than 'lib' + library_names_spec='`echo $libname | $SED -e 's/^lib/pw/'``echo $release | $SED -e 's/[[.]]/-/g'`$versuffix$shared_ext' + ;; + esac + dynamic_linker='Win32 ld.exe' + ;; + + *,cl* | *,icl*) + # Native MSVC or ICC + libname_spec='$name' + soname_spec='$libname`echo $release | $SED -e 's/[[.]]/-/g'`$versuffix$shared_ext' + library_names_spec='$libname.dll.lib' + + case $build_os in + mingw*) + sys_lib_search_path_spec= + lt_save_ifs=$IFS + IFS=';' + for lt_path in $LIB + do + IFS=$lt_save_ifs + # Let DOS variable expansion print the short 8.3 style file name. + lt_path=`cd "$lt_path" 2>/dev/null && cmd //C "for %i in (".") do @echo %~si"` + sys_lib_search_path_spec="$sys_lib_search_path_spec $lt_path" + done + IFS=$lt_save_ifs + # Convert to MSYS style. + sys_lib_search_path_spec=`$ECHO "$sys_lib_search_path_spec" | $SED -e 's|\\\\|/|g' -e 's| \\([[a-zA-Z]]\\):| /\\1|g' -e 's|^ ||'` + ;; + cygwin*) + # Convert to unix form, then to dos form, then back to unix form + # but this time dos style (no spaces!) so that the unix form looks + # like /cygdrive/c/PROGRA~1:/cygdr... + sys_lib_search_path_spec=`cygpath --path --unix "$LIB"` + sys_lib_search_path_spec=`cygpath --path --dos "$sys_lib_search_path_spec" 2>/dev/null` + sys_lib_search_path_spec=`cygpath --path --unix "$sys_lib_search_path_spec" | $SED -e "s/$PATH_SEPARATOR/ /g"` + ;; + *) + sys_lib_search_path_spec=$LIB + if $ECHO "$sys_lib_search_path_spec" | [$GREP ';[c-zC-Z]:/' >/dev/null]; then + # It is most probably a Windows format PATH. + sys_lib_search_path_spec=`$ECHO "$sys_lib_search_path_spec" | $SED -e 's/;/ /g'` + else + sys_lib_search_path_spec=`$ECHO "$sys_lib_search_path_spec" | $SED -e "s/$PATH_SEPARATOR/ /g"` + fi + # FIXME: find the short name or the path components, as spaces are + # common. (e.g. "Program Files" -> "PROGRA~1") + ;; + esac + + # DLL is installed to $(libdir)/../bin by postinstall_cmds + postinstall_cmds='base_file=`basename \$file`~ + dlpath=`$SHELL 2>&1 -c '\''. $dir/'\''\$base_file'\''i; echo \$dlname'\''`~ + dldir=$destdir/`dirname \$dlpath`~ + test -d \$dldir || mkdir -p \$dldir~ + $install_prog $dir/$dlname \$dldir/$dlname' + postuninstall_cmds='dldll=`$SHELL 2>&1 -c '\''. $file; echo \$dlname'\''`~ + dlpath=$dir/\$dldll~ + $RM \$dlpath' + shlibpath_overrides_runpath=yes + dynamic_linker='Win32 link.exe' + ;; + + *) + # Assume MSVC and ICC wrapper + library_names_spec='$libname`echo $release | $SED -e 's/[[.]]/-/g'`$versuffix$shared_ext $libname.lib' + dynamic_linker='Win32 ld.exe' + ;; + esac + # FIXME: first we should search . and the directory the executable is in + shlibpath_var=PATH + ;; + +darwin* | rhapsody*) + dynamic_linker="$host_os dyld" + version_type=darwin + need_lib_prefix=no + need_version=no + library_names_spec='$libname$release$major$shared_ext $libname$shared_ext' + soname_spec='$libname$release$major$shared_ext' + shlibpath_overrides_runpath=yes + shlibpath_var=DYLD_LIBRARY_PATH + shrext_cmds='`test .$module = .yes && echo .so || echo .dylib`' +m4_if([$1], [],[ + sys_lib_search_path_spec="$sys_lib_search_path_spec /usr/local/lib"]) + sys_lib_dlsearch_path_spec='/usr/local/lib /lib /usr/lib' + ;; + +dgux*) + version_type=linux # correct to gnu/linux during the next big refactor + need_lib_prefix=no + need_version=no + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + soname_spec='$libname$release$shared_ext$major' + shlibpath_var=LD_LIBRARY_PATH + ;; + +freebsd* | dragonfly* | midnightbsd*) + # DragonFly does not have aout. When/if they implement a new + # versioning mechanism, adjust this. + if test -x /usr/bin/objformat; then + objformat=`/usr/bin/objformat` + else + case $host_os in + freebsd[[23]].*) objformat=aout ;; + *) objformat=elf ;; + esac + fi + version_type=freebsd-$objformat + case $version_type in + freebsd-elf*) + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + soname_spec='$libname$release$shared_ext$major' + need_version=no + need_lib_prefix=no + ;; + freebsd-*) + library_names_spec='$libname$release$shared_ext$versuffix $libname$shared_ext$versuffix' + need_version=yes + ;; + esac + shlibpath_var=LD_LIBRARY_PATH + case $host_os in + freebsd2.*) + shlibpath_overrides_runpath=yes + ;; + freebsd3.[[01]]* | freebsdelf3.[[01]]*) + shlibpath_overrides_runpath=yes + hardcode_into_libs=yes + ;; + freebsd3.[[2-9]]* | freebsdelf3.[[2-9]]* | \ + freebsd4.[[0-5]] | freebsdelf4.[[0-5]] | freebsd4.1.1 | freebsdelf4.1.1) + shlibpath_overrides_runpath=no + hardcode_into_libs=yes + ;; + *) # from 4.6 on, and DragonFly + shlibpath_overrides_runpath=yes + hardcode_into_libs=yes + ;; + esac + ;; + +haiku*) + version_type=linux # correct to gnu/linux during the next big refactor + need_lib_prefix=no + need_version=no + dynamic_linker="$host_os runtime_loader" + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + soname_spec='$libname$release$shared_ext$major' + shlibpath_var=LIBRARY_PATH + shlibpath_overrides_runpath=no + sys_lib_dlsearch_path_spec='/boot/home/config/lib /boot/common/lib /boot/system/lib' + hardcode_into_libs=yes + ;; + +hpux9* | hpux10* | hpux11*) + # Give a soname corresponding to the major version so that dld.sl refuses to + # link against other versions. + version_type=sunos + need_lib_prefix=no + need_version=no + case $host_cpu in + ia64*) + shrext_cmds='.so' + hardcode_into_libs=yes + dynamic_linker="$host_os dld.so" + shlibpath_var=LD_LIBRARY_PATH + shlibpath_overrides_runpath=yes # Unless +noenvvar is specified. + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + soname_spec='$libname$release$shared_ext$major' + if test 32 = "$HPUX_IA64_MODE"; then + sys_lib_search_path_spec="/usr/lib/hpux32 /usr/local/lib/hpux32 /usr/local/lib" + sys_lib_dlsearch_path_spec=/usr/lib/hpux32 + else + sys_lib_search_path_spec="/usr/lib/hpux64 /usr/local/lib/hpux64" + sys_lib_dlsearch_path_spec=/usr/lib/hpux64 + fi + ;; + hppa*64*) + shrext_cmds='.sl' + hardcode_into_libs=yes + dynamic_linker="$host_os dld.sl" + shlibpath_var=LD_LIBRARY_PATH # How should we handle SHLIB_PATH + shlibpath_overrides_runpath=yes # Unless +noenvvar is specified. + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + soname_spec='$libname$release$shared_ext$major' + sys_lib_search_path_spec="/usr/lib/pa20_64 /usr/ccs/lib/pa20_64" + sys_lib_dlsearch_path_spec=$sys_lib_search_path_spec + ;; + *) + shrext_cmds='.sl' + dynamic_linker="$host_os dld.sl" + shlibpath_var=SHLIB_PATH + shlibpath_overrides_runpath=no # +s is required to enable SHLIB_PATH + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + soname_spec='$libname$release$shared_ext$major' + ;; + esac + # HP-UX runs *really* slowly unless shared libraries are mode 555, ... + postinstall_cmds='chmod 555 $lib' + # or fails outright, so override atomically: + install_override_mode=555 + ;; + +interix[[3-9]]*) + version_type=linux # correct to gnu/linux during the next big refactor + need_lib_prefix=no + need_version=no + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + soname_spec='$libname$release$shared_ext$major' + dynamic_linker='Interix 3.x ld.so.1 (PE, like ELF)' + shlibpath_var=LD_LIBRARY_PATH + shlibpath_overrides_runpath=no + hardcode_into_libs=yes + ;; + +irix5* | irix6* | nonstopux*) + case $host_os in + nonstopux*) version_type=nonstopux ;; + *) + if test yes = "$lt_cv_prog_gnu_ld"; then + version_type=linux # correct to gnu/linux during the next big refactor + else + version_type=irix + fi ;; + esac + need_lib_prefix=no + need_version=no + soname_spec='$libname$release$shared_ext$major' + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$release$shared_ext $libname$shared_ext' + case $host_os in + irix5* | nonstopux*) + libsuff= shlibsuff= + ;; + *) + case $LD in # libtool.m4 will add one of these switches to LD + *-32|*"-32 "|*-melf32bsmip|*"-melf32bsmip ") + libsuff= shlibsuff= libmagic=32-bit;; + *-n32|*"-n32 "|*-melf32bmipn32|*"-melf32bmipn32 ") + libsuff=32 shlibsuff=N32 libmagic=N32;; + *-64|*"-64 "|*-melf64bmip|*"-melf64bmip ") + libsuff=64 shlibsuff=64 libmagic=64-bit;; + *) libsuff= shlibsuff= libmagic=never-match;; + esac + ;; + esac + shlibpath_var=LD_LIBRARY${shlibsuff}_PATH + shlibpath_overrides_runpath=no + sys_lib_search_path_spec="/usr/lib$libsuff /lib$libsuff /usr/local/lib$libsuff" + sys_lib_dlsearch_path_spec="/usr/lib$libsuff /lib$libsuff" + hardcode_into_libs=yes + ;; + +# No shared lib support for Linux oldld, aout, or coff. +linux*oldld* | linux*aout* | linux*coff*) + dynamic_linker=no + ;; + +linux*android*) + version_type=none # Android doesn't support versioned libraries. + need_lib_prefix=no + need_version=no + library_names_spec='$libname$release$shared_ext' + soname_spec='$libname$release$shared_ext' + finish_cmds= + shlibpath_var=LD_LIBRARY_PATH + shlibpath_overrides_runpath=yes + + # This implies no fast_install, which is unacceptable. + # Some rework will be needed to allow for fast_install + # before this can be enabled. + hardcode_into_libs=yes + + dynamic_linker='Android linker' + # Don't embed -rpath directories since the linker doesn't support them. + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir' + ;; + +# This must be glibc/ELF. +linux* | k*bsd*-gnu | kopensolaris*-gnu | gnu*) + version_type=linux # correct to gnu/linux during the next big refactor + need_lib_prefix=no + need_version=no + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + soname_spec='$libname$release$shared_ext$major' + finish_cmds='PATH="\$PATH:/sbin" ldconfig -n $libdir' + shlibpath_var=LD_LIBRARY_PATH + shlibpath_overrides_runpath=no + + # Some binutils ld are patched to set DT_RUNPATH + AC_CACHE_VAL([lt_cv_shlibpath_overrides_runpath], + [lt_cv_shlibpath_overrides_runpath=no + save_LDFLAGS=$LDFLAGS + save_libdir=$libdir + eval "libdir=/foo; wl=\"$_LT_TAGVAR(lt_prog_compiler_wl, $1)\"; \ + LDFLAGS=\"\$LDFLAGS $_LT_TAGVAR(hardcode_libdir_flag_spec, $1)\"" + AC_LINK_IFELSE([AC_LANG_PROGRAM([],[])], + [AS_IF([ ($OBJDUMP -p conftest$ac_exeext) 2>/dev/null | grep "RUNPATH.*$libdir" >/dev/null], + [lt_cv_shlibpath_overrides_runpath=yes])]) + LDFLAGS=$save_LDFLAGS + libdir=$save_libdir + ]) + shlibpath_overrides_runpath=$lt_cv_shlibpath_overrides_runpath + + # This implies no fast_install, which is unacceptable. + # Some rework will be needed to allow for fast_install + # before this can be enabled. + hardcode_into_libs=yes + + # Ideally, we could use ldconfig to report *all* directores which are + # searched for libraries, however this is still not possible. Aside from not + # being certain /sbin/ldconfig is available, command + # 'ldconfig -N -X -v | grep ^/' on 64bit Fedora does not report /usr/lib64, + # even though it is searched at run-time. Try to do the best guess by + # appending ld.so.conf contents (and includes) to the search path. + if test -f /etc/ld.so.conf; then + lt_ld_extra=`awk '/^include / { system(sprintf("cd /etc; cat %s 2>/dev/null", \[$]2)); skip = 1; } { if (!skip) print \[$]0; skip = 0; }' < /etc/ld.so.conf | $SED -e 's/#.*//;/^[ ]*hwcap[ ]/d;s/[:, ]/ /g;s/=[^=]*$//;s/=[^= ]* / /g;s/"//g;/^$/d' | tr '\n' ' '` + sys_lib_dlsearch_path_spec="/lib /usr/lib $lt_ld_extra" + fi + + # We used to test for /lib/ld.so.1 and disable shared libraries on + # powerpc, because MkLinux only supported shared libraries with the + # GNU dynamic linker. Since this was broken with cross compilers, + # most powerpc-linux boxes support dynamic linking these days and + # people can always --disable-shared, the test was removed, and we + # assume the GNU/Linux dynamic linker is in use. + dynamic_linker='GNU/Linux ld.so' + ;; + +netbsdelf*-gnu) + version_type=linux + need_lib_prefix=no + need_version=no + library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major ${libname}${shared_ext}' + soname_spec='${libname}${release}${shared_ext}$major' + shlibpath_var=LD_LIBRARY_PATH + shlibpath_overrides_runpath=no + hardcode_into_libs=yes + dynamic_linker='NetBSD ld.elf_so' + ;; + +netbsd*) + version_type=sunos + need_lib_prefix=no + need_version=no + if echo __ELF__ | $CC -E - | $GREP __ELF__ >/dev/null; then + library_names_spec='$libname$release$shared_ext$versuffix $libname$shared_ext$versuffix' + finish_cmds='PATH="\$PATH:/sbin" ldconfig -m $libdir' + dynamic_linker='NetBSD (a.out) ld.so' + else + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + soname_spec='$libname$release$shared_ext$major' + dynamic_linker='NetBSD ld.elf_so' + fi + shlibpath_var=LD_LIBRARY_PATH + shlibpath_overrides_runpath=yes + hardcode_into_libs=yes + ;; + +newsos6) + version_type=linux # correct to gnu/linux during the next big refactor + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + shlibpath_var=LD_LIBRARY_PATH + shlibpath_overrides_runpath=yes + ;; + +*nto* | *qnx*) + version_type=qnx + need_lib_prefix=no + need_version=no + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + soname_spec='$libname$release$shared_ext$major' + shlibpath_var=LD_LIBRARY_PATH + shlibpath_overrides_runpath=no + hardcode_into_libs=yes + dynamic_linker='ldqnx.so' + ;; + +openbsd* | bitrig*) + version_type=sunos + sys_lib_dlsearch_path_spec=/usr/lib + need_lib_prefix=no + if test -z "`echo __ELF__ | $CC -E - | $GREP __ELF__`"; then + need_version=no + else + need_version=yes + fi + library_names_spec='$libname$release$shared_ext$versuffix $libname$shared_ext$versuffix' + finish_cmds='PATH="\$PATH:/sbin" ldconfig -m $libdir' + shlibpath_var=LD_LIBRARY_PATH + shlibpath_overrides_runpath=yes + ;; + +os2*) + libname_spec='$name' + version_type=windows + shrext_cmds=.dll + need_version=no + need_lib_prefix=no + # OS/2 can only load a DLL with a base name of 8 characters or less. + soname_spec='`test -n "$os2dllname" && libname="$os2dllname"; + v=$($ECHO $release$versuffix | tr -d .-); + n=$($ECHO $libname | cut -b -$((8 - ${#v})) | tr . _); + $ECHO $n$v`$shared_ext' + library_names_spec='${libname}_dll.$libext' + dynamic_linker='OS/2 ld.exe' + shlibpath_var=BEGINLIBPATH + sys_lib_search_path_spec="/lib /usr/lib /usr/local/lib" + sys_lib_dlsearch_path_spec=$sys_lib_search_path_spec + postinstall_cmds='base_file=`basename \$file`~ + dlpath=`$SHELL 2>&1 -c '\''. $dir/'\''\$base_file'\''i; $ECHO \$dlname'\''`~ + dldir=$destdir/`dirname \$dlpath`~ + test -d \$dldir || mkdir -p \$dldir~ + $install_prog $dir/$dlname \$dldir/$dlname~ + chmod a+x \$dldir/$dlname~ + if test -n '\''$stripme'\'' && test -n '\''$striplib'\''; then + eval '\''$striplib \$dldir/$dlname'\'' || exit \$?; + fi' + postuninstall_cmds='dldll=`$SHELL 2>&1 -c '\''. $file; $ECHO \$dlname'\''`~ + dlpath=$dir/\$dldll~ + $RM \$dlpath' + ;; + +osf3* | osf4* | osf5*) + version_type=osf + need_lib_prefix=no + need_version=no + soname_spec='$libname$release$shared_ext$major' + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + shlibpath_var=LD_LIBRARY_PATH + sys_lib_search_path_spec="/usr/shlib /usr/ccs/lib /usr/lib/cmplrs/cc /usr/lib /usr/local/lib /var/shlib" + sys_lib_dlsearch_path_spec=$sys_lib_search_path_spec + ;; + +rdos*) + dynamic_linker=no + ;; + +solaris*) + version_type=linux # correct to gnu/linux during the next big refactor + need_lib_prefix=no + need_version=no + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + soname_spec='$libname$release$shared_ext$major' + shlibpath_var=LD_LIBRARY_PATH + shlibpath_overrides_runpath=yes + hardcode_into_libs=yes + # ldd complains unless libraries are executable + postinstall_cmds='chmod +x $lib' + ;; + +sunos4*) + version_type=sunos + library_names_spec='$libname$release$shared_ext$versuffix $libname$shared_ext$versuffix' + finish_cmds='PATH="\$PATH:/usr/etc" ldconfig $libdir' + shlibpath_var=LD_LIBRARY_PATH + shlibpath_overrides_runpath=yes + if test yes = "$with_gnu_ld"; then + need_lib_prefix=no + fi + need_version=yes + ;; + +sysv4 | sysv4.3*) + version_type=linux # correct to gnu/linux during the next big refactor + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + soname_spec='$libname$release$shared_ext$major' + shlibpath_var=LD_LIBRARY_PATH + case $host_vendor in + sni) + shlibpath_overrides_runpath=no + need_lib_prefix=no + runpath_var=LD_RUN_PATH + ;; + siemens) + need_lib_prefix=no + ;; + motorola) + need_lib_prefix=no + need_version=no + shlibpath_overrides_runpath=no + sys_lib_search_path_spec='/lib /usr/lib /usr/ccs/lib' + ;; + esac + ;; + +sysv4*MP*) + if test -d /usr/nec; then + version_type=linux # correct to gnu/linux during the next big refactor + library_names_spec='$libname$shared_ext.$versuffix $libname$shared_ext.$major $libname$shared_ext' + soname_spec='$libname$shared_ext.$major' + shlibpath_var=LD_LIBRARY_PATH + fi + ;; + +sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX* | sysv4*uw2*) + version_type=sco + need_lib_prefix=no + need_version=no + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext $libname$shared_ext' + soname_spec='$libname$release$shared_ext$major' + shlibpath_var=LD_LIBRARY_PATH + shlibpath_overrides_runpath=yes + hardcode_into_libs=yes + if test yes = "$with_gnu_ld"; then + sys_lib_search_path_spec='/usr/local/lib /usr/gnu/lib /usr/ccs/lib /usr/lib /lib' + else + sys_lib_search_path_spec='/usr/ccs/lib /usr/lib' + case $host_os in + sco3.2v5*) + sys_lib_search_path_spec="$sys_lib_search_path_spec /lib" + ;; + esac + fi + sys_lib_dlsearch_path_spec='/usr/lib' + ;; + +tpf*) + # TPF is a cross-target only. Preferred cross-host = GNU/Linux. + version_type=linux # correct to gnu/linux during the next big refactor + need_lib_prefix=no + need_version=no + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + shlibpath_var=LD_LIBRARY_PATH + shlibpath_overrides_runpath=no + hardcode_into_libs=yes + ;; + +uts4*) + version_type=linux # correct to gnu/linux during the next big refactor + library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' + soname_spec='$libname$release$shared_ext$major' + shlibpath_var=LD_LIBRARY_PATH + ;; + +*) + dynamic_linker=no + ;; +esac +AC_MSG_RESULT([$dynamic_linker]) +test no = "$dynamic_linker" && can_build_shared=no + +variables_saved_for_relink="PATH $shlibpath_var $runpath_var" +if test yes = "$GCC"; then + variables_saved_for_relink="$variables_saved_for_relink GCC_EXEC_PREFIX COMPILER_PATH LIBRARY_PATH" +fi + +if test set = "${lt_cv_sys_lib_search_path_spec+set}"; then + sys_lib_search_path_spec=$lt_cv_sys_lib_search_path_spec +fi + +if test set = "${lt_cv_sys_lib_dlsearch_path_spec+set}"; then + sys_lib_dlsearch_path_spec=$lt_cv_sys_lib_dlsearch_path_spec +fi + +# remember unaugmented sys_lib_dlsearch_path content for libtool script decls... +configure_time_dlsearch_path=$sys_lib_dlsearch_path_spec + +# ... but it needs LT_SYS_LIBRARY_PATH munging for other configure-time code +func_munge_path_list sys_lib_dlsearch_path_spec "$LT_SYS_LIBRARY_PATH" + +# to be used as default LT_SYS_LIBRARY_PATH value in generated libtool +configure_time_lt_sys_library_path=$LT_SYS_LIBRARY_PATH + +_LT_DECL([], [variables_saved_for_relink], [1], + [Variables whose values should be saved in libtool wrapper scripts and + restored at link time]) +_LT_DECL([], [need_lib_prefix], [0], + [Do we need the "lib" prefix for modules?]) +_LT_DECL([], [need_version], [0], [Do we need a version for libraries?]) +_LT_DECL([], [version_type], [0], [Library versioning type]) +_LT_DECL([], [runpath_var], [0], [Shared library runtime path variable]) +_LT_DECL([], [shlibpath_var], [0],[Shared library path variable]) +_LT_DECL([], [shlibpath_overrides_runpath], [0], + [Is shlibpath searched before the hard-coded library search path?]) +_LT_DECL([], [libname_spec], [1], [Format of library name prefix]) +_LT_DECL([], [library_names_spec], [1], + [[List of archive names. First name is the real one, the rest are links. + The last name is the one that the linker finds with -lNAME]]) +_LT_DECL([], [soname_spec], [1], + [[The coded name of the library, if different from the real name]]) +_LT_DECL([], [install_override_mode], [1], + [Permission mode override for installation of shared libraries]) +_LT_DECL([], [postinstall_cmds], [2], + [Command to use after installation of a shared archive]) +_LT_DECL([], [postuninstall_cmds], [2], + [Command to use after uninstallation of a shared archive]) +_LT_DECL([], [finish_cmds], [2], + [Commands used to finish a libtool library installation in a directory]) +_LT_DECL([], [finish_eval], [1], + [[As "finish_cmds", except a single script fragment to be evaled but + not shown]]) +_LT_DECL([], [hardcode_into_libs], [0], + [Whether we should hardcode library paths into libraries]) +_LT_DECL([], [sys_lib_search_path_spec], [2], + [Compile-time system search path for libraries]) +_LT_DECL([sys_lib_dlsearch_path_spec], [configure_time_dlsearch_path], [2], + [Detected run-time system search path for libraries]) +_LT_DECL([], [configure_time_lt_sys_library_path], [2], + [Explicit LT_SYS_LIBRARY_PATH set during ./configure time]) +])# _LT_SYS_DYNAMIC_LINKER + + +# _LT_PATH_TOOL_PREFIX(TOOL) +# -------------------------- +# find a file program that can recognize shared library +AC_DEFUN([_LT_PATH_TOOL_PREFIX], +[m4_require([_LT_DECL_EGREP])dnl +AC_MSG_CHECKING([for $1]) +AC_CACHE_VAL(lt_cv_path_MAGIC_CMD, +[case $MAGIC_CMD in +[[\\/*] | ?:[\\/]*]) + lt_cv_path_MAGIC_CMD=$MAGIC_CMD # Let the user override the test with a path. + ;; +*) + lt_save_MAGIC_CMD=$MAGIC_CMD + lt_save_ifs=$IFS; IFS=$PATH_SEPARATOR +dnl $ac_dummy forces splitting on constant user-supplied paths. +dnl POSIX.2 word splitting is done only on the output of word expansions, +dnl not every word. This closes a longstanding sh security hole. + ac_dummy="m4_if([$2], , $PATH, [$2])" + for ac_dir in $ac_dummy; do + IFS=$lt_save_ifs + test -z "$ac_dir" && ac_dir=. + if test -f "$ac_dir/$1"; then + lt_cv_path_MAGIC_CMD=$ac_dir/"$1" + if test -n "$file_magic_test_file"; then + case $deplibs_check_method in + "file_magic "*) + file_magic_regex=`expr "$deplibs_check_method" : "file_magic \(.*\)"` + MAGIC_CMD=$lt_cv_path_MAGIC_CMD + if eval $file_magic_cmd \$file_magic_test_file 2> /dev/null | + $EGREP "$file_magic_regex" > /dev/null; then + : + else + cat <<_LT_EOF 1>&2 + +*** Warning: the command libtool uses to detect shared libraries, +*** $file_magic_cmd, produces output that libtool cannot recognize. +*** The result is that libtool may fail to recognize shared libraries +*** as such. This will affect the creation of libtool libraries that +*** depend on shared libraries, but programs linked with such libtool +*** libraries will work regardless of this problem. Nevertheless, you +*** may want to report the problem to your system manager and/or to +*** bug-libtool@gnu.org + +_LT_EOF + fi ;; + esac + fi + break + fi + done + IFS=$lt_save_ifs + MAGIC_CMD=$lt_save_MAGIC_CMD + ;; +esac]) +MAGIC_CMD=$lt_cv_path_MAGIC_CMD +if test -n "$MAGIC_CMD"; then + AC_MSG_RESULT($MAGIC_CMD) +else + AC_MSG_RESULT(no) +fi +_LT_DECL([], [MAGIC_CMD], [0], + [Used to examine libraries when file_magic_cmd begins with "file"])dnl +])# _LT_PATH_TOOL_PREFIX + +# Old name: +AU_ALIAS([AC_PATH_TOOL_PREFIX], [_LT_PATH_TOOL_PREFIX]) +dnl aclocal-1.4 backwards compatibility: +dnl AC_DEFUN([AC_PATH_TOOL_PREFIX], []) + + +# _LT_PATH_MAGIC +# -------------- +# find a file program that can recognize a shared library +m4_defun([_LT_PATH_MAGIC], +[_LT_PATH_TOOL_PREFIX(${ac_tool_prefix}file, /usr/bin$PATH_SEPARATOR$PATH) +if test -z "$lt_cv_path_MAGIC_CMD"; then + if test -n "$ac_tool_prefix"; then + _LT_PATH_TOOL_PREFIX(file, /usr/bin$PATH_SEPARATOR$PATH) + else + MAGIC_CMD=: + fi +fi +])# _LT_PATH_MAGIC + + +# LT_PATH_LD +# ---------- +# find the pathname to the GNU or non-GNU linker +AC_DEFUN([LT_PATH_LD], +[AC_REQUIRE([AC_PROG_CC])dnl +AC_REQUIRE([AC_CANONICAL_HOST])dnl +AC_REQUIRE([AC_CANONICAL_BUILD])dnl +m4_require([_LT_DECL_SED])dnl +m4_require([_LT_DECL_EGREP])dnl +m4_require([_LT_PROG_ECHO_BACKSLASH])dnl + +AC_ARG_WITH([gnu-ld], + [AS_HELP_STRING([--with-gnu-ld], + [assume the C compiler uses GNU ld @<:@default=no@:>@])], + [test no = "$withval" || with_gnu_ld=yes], + [with_gnu_ld=no])dnl + +ac_prog=ld +if test yes = "$GCC"; then + # Check if gcc -print-prog-name=ld gives a path. + AC_MSG_CHECKING([for ld used by $CC]) + case $host in + *-*-mingw*) + # gcc leaves a trailing carriage return, which upsets mingw + ac_prog=`($CC -print-prog-name=ld) 2>&5 | tr -d '\015'` ;; + *) + ac_prog=`($CC -print-prog-name=ld) 2>&5` ;; + esac + case $ac_prog in + # Accept absolute paths. + [[\\/]]* | ?:[[\\/]]*) + re_direlt='/[[^/]][[^/]]*/\.\./' + # Canonicalize the pathname of ld + ac_prog=`$ECHO "$ac_prog"| $SED 's%\\\\%/%g'` + while $ECHO "$ac_prog" | $GREP "$re_direlt" > /dev/null 2>&1; do + ac_prog=`$ECHO $ac_prog| $SED "s%$re_direlt%/%"` + done + test -z "$LD" && LD=$ac_prog + ;; + "") + # If it fails, then pretend we aren't using GCC. + ac_prog=ld + ;; + *) + # If it is relative, then search for the first ld in PATH. + with_gnu_ld=unknown + ;; + esac +elif test yes = "$with_gnu_ld"; then + AC_MSG_CHECKING([for GNU ld]) +else + AC_MSG_CHECKING([for non-GNU ld]) +fi +AC_CACHE_VAL(lt_cv_path_LD, +[if test -z "$LD"; then + lt_save_ifs=$IFS; IFS=$PATH_SEPARATOR + for ac_dir in $PATH; do + IFS=$lt_save_ifs + test -z "$ac_dir" && ac_dir=. + if test -f "$ac_dir/$ac_prog" || test -f "$ac_dir/$ac_prog$ac_exeext"; then + lt_cv_path_LD=$ac_dir/$ac_prog + # Check to see if the program is GNU ld. I'd rather use --version, + # but apparently some variants of GNU ld only accept -v. + # Break only if it was the GNU/non-GNU ld that we prefer. + case `"$lt_cv_path_LD" -v 2>&1 &1 conftest.i +cat conftest.i conftest.i >conftest2.i +: ${lt_DD:=$DD} +AC_PATH_PROGS_FEATURE_CHECK([lt_DD], [dd], +[if "$ac_path_lt_DD" bs=32 count=1 conftest.out 2>/dev/null; then + cmp -s conftest.i conftest.out \ + && ac_cv_path_lt_DD="$ac_path_lt_DD" ac_path_lt_DD_found=: +fi]) +rm -f conftest.i conftest2.i conftest.out]) +])# _LT_PATH_DD + + +# _LT_CMD_TRUNCATE +# ---------------- +# find command to truncate a binary pipe +m4_defun([_LT_CMD_TRUNCATE], +[m4_require([_LT_PATH_DD]) +AC_CACHE_CHECK([how to truncate binary pipes], [lt_cv_truncate_bin], +[printf 0123456789abcdef0123456789abcdef >conftest.i +cat conftest.i conftest.i >conftest2.i +lt_cv_truncate_bin= +if "$ac_cv_path_lt_DD" bs=32 count=1 conftest.out 2>/dev/null; then + cmp -s conftest.i conftest.out \ + && lt_cv_truncate_bin="$ac_cv_path_lt_DD bs=4096 count=1" +fi +rm -f conftest.i conftest2.i conftest.out +test -z "$lt_cv_truncate_bin" && lt_cv_truncate_bin="$SED -e 4q"]) +_LT_DECL([lt_truncate_bin], [lt_cv_truncate_bin], [1], + [Command to truncate a binary pipe]) +])# _LT_CMD_TRUNCATE + + +# _LT_CHECK_MAGIC_METHOD +# ---------------------- +# how to check for library dependencies +# -- PORTME fill in with the dynamic library characteristics +m4_defun([_LT_CHECK_MAGIC_METHOD], +[m4_require([_LT_DECL_EGREP]) +m4_require([_LT_DECL_OBJDUMP]) +AC_CACHE_CHECK([how to recognize dependent libraries], +lt_cv_deplibs_check_method, +[lt_cv_file_magic_cmd='$MAGIC_CMD' +lt_cv_file_magic_test_file= +lt_cv_deplibs_check_method='unknown' +# Need to set the preceding variable on all platforms that support +# interlibrary dependencies. +# 'none' -- dependencies not supported. +# 'unknown' -- same as none, but documents that we really don't know. +# 'pass_all' -- all dependencies passed with no checks. +# 'test_compile' -- check by making test program. +# 'file_magic [[regex]]' -- check by looking for files in library path +# that responds to the $file_magic_cmd with a given extended regex. +# If you have 'file' or equivalent on your system and you're not sure +# whether 'pass_all' will *always* work, you probably want this one. + +case $host_os in +aix[[4-9]]*) + lt_cv_deplibs_check_method=pass_all + ;; + +beos*) + lt_cv_deplibs_check_method=pass_all + ;; + +bsdi[[45]]*) + lt_cv_deplibs_check_method='file_magic ELF [[0-9]][[0-9]]*-bit [[ML]]SB (shared object|dynamic lib)' + lt_cv_file_magic_cmd='$FILECMD -L' + lt_cv_file_magic_test_file=/shlib/libc.so + ;; + +cygwin*) + # func_win32_libid is a shell function defined in ltmain.sh + lt_cv_deplibs_check_method='file_magic ^x86 archive import|^x86 DLL' + lt_cv_file_magic_cmd='func_win32_libid' + ;; + +mingw* | pw32*) + # Base MSYS/MinGW do not provide the 'file' command needed by + # func_win32_libid shell function, so use a weaker test based on 'objdump', + # unless we find 'file', for example because we are cross-compiling. + if ( file / ) >/dev/null 2>&1; then + lt_cv_deplibs_check_method='file_magic ^x86 archive import|^x86 DLL' + lt_cv_file_magic_cmd='func_win32_libid' + else + # Keep this pattern in sync with the one in func_win32_libid. + lt_cv_deplibs_check_method='file_magic file format (pei*-i386(.*architecture: i386)?|pe-arm-wince|pe-x86-64)' + lt_cv_file_magic_cmd='$OBJDUMP -f' + fi + ;; + +cegcc*) + # use the weaker test based on 'objdump'. See mingw*. + lt_cv_deplibs_check_method='file_magic file format pe-arm-.*little(.*architecture: arm)?' + lt_cv_file_magic_cmd='$OBJDUMP -f' + ;; + +darwin* | rhapsody*) + lt_cv_deplibs_check_method=pass_all + ;; + +freebsd* | dragonfly* | midnightbsd*) + if echo __ELF__ | $CC -E - | $GREP __ELF__ > /dev/null; then + case $host_cpu in + i*86 ) + # Not sure whether the presence of OpenBSD here was a mistake. + # Let's accept both of them until this is cleared up. + lt_cv_deplibs_check_method='file_magic (FreeBSD|OpenBSD|DragonFly)/i[[3-9]]86 (compact )?demand paged shared library' + lt_cv_file_magic_cmd=$FILECMD + lt_cv_file_magic_test_file=`echo /usr/lib/libc.so.*` + ;; + esac + else + lt_cv_deplibs_check_method=pass_all + fi + ;; + +haiku*) + lt_cv_deplibs_check_method=pass_all + ;; + +hpux10.20* | hpux11*) + lt_cv_file_magic_cmd=$FILECMD + case $host_cpu in + ia64*) + lt_cv_deplibs_check_method='file_magic (s[[0-9]][[0-9]][[0-9]]|ELF-[[0-9]][[0-9]]) shared object file - IA64' + lt_cv_file_magic_test_file=/usr/lib/hpux32/libc.so + ;; + hppa*64*) + [lt_cv_deplibs_check_method='file_magic (s[0-9][0-9][0-9]|ELF[ -][0-9][0-9])(-bit)?( [LM]SB)? shared object( file)?[, -]* PA-RISC [0-9]\.[0-9]'] + lt_cv_file_magic_test_file=/usr/lib/pa20_64/libc.sl + ;; + *) + lt_cv_deplibs_check_method='file_magic (s[[0-9]][[0-9]][[0-9]]|PA-RISC[[0-9]]\.[[0-9]]) shared library' + lt_cv_file_magic_test_file=/usr/lib/libc.sl + ;; + esac + ;; + +interix[[3-9]]*) + # PIC code is broken on Interix 3.x, that's why |\.a not |_pic\.a here + lt_cv_deplibs_check_method='match_pattern /lib[[^/]]+(\.so|\.a)$' + ;; + +irix5* | irix6* | nonstopux*) + case $LD in + *-32|*"-32 ") libmagic=32-bit;; + *-n32|*"-n32 ") libmagic=N32;; + *-64|*"-64 ") libmagic=64-bit;; + *) libmagic=never-match;; + esac + lt_cv_deplibs_check_method=pass_all + ;; + +# This must be glibc/ELF. +linux* | k*bsd*-gnu | kopensolaris*-gnu | gnu*) + lt_cv_deplibs_check_method=pass_all + ;; + +netbsd* | netbsdelf*-gnu) + if echo __ELF__ | $CC -E - | $GREP __ELF__ > /dev/null; then + lt_cv_deplibs_check_method='match_pattern /lib[[^/]]+(\.so\.[[0-9]]+\.[[0-9]]+|_pic\.a)$' + else + lt_cv_deplibs_check_method='match_pattern /lib[[^/]]+(\.so|_pic\.a)$' + fi + ;; + +newos6*) + lt_cv_deplibs_check_method='file_magic ELF [[0-9]][[0-9]]*-bit [[ML]]SB (executable|dynamic lib)' + lt_cv_file_magic_cmd=$FILECMD + lt_cv_file_magic_test_file=/usr/lib/libnls.so + ;; + +*nto* | *qnx*) + lt_cv_deplibs_check_method=pass_all + ;; + +openbsd* | bitrig*) + if test -z "`echo __ELF__ | $CC -E - | $GREP __ELF__`"; then + lt_cv_deplibs_check_method='match_pattern /lib[[^/]]+(\.so\.[[0-9]]+\.[[0-9]]+|\.so|_pic\.a)$' + else + lt_cv_deplibs_check_method='match_pattern /lib[[^/]]+(\.so\.[[0-9]]+\.[[0-9]]+|_pic\.a)$' + fi + ;; + +osf3* | osf4* | osf5*) + lt_cv_deplibs_check_method=pass_all + ;; + +rdos*) + lt_cv_deplibs_check_method=pass_all + ;; + +solaris*) + lt_cv_deplibs_check_method=pass_all + ;; + +sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX* | sysv4*uw2*) + lt_cv_deplibs_check_method=pass_all + ;; + +sysv4 | sysv4.3*) + case $host_vendor in + motorola) + lt_cv_deplibs_check_method='file_magic ELF [[0-9]][[0-9]]*-bit [[ML]]SB (shared object|dynamic lib) M[[0-9]][[0-9]]* Version [[0-9]]' + lt_cv_file_magic_test_file=`echo /usr/lib/libc.so*` + ;; + ncr) + lt_cv_deplibs_check_method=pass_all + ;; + sequent) + lt_cv_file_magic_cmd='/bin/file' + lt_cv_deplibs_check_method='file_magic ELF [[0-9]][[0-9]]*-bit [[LM]]SB (shared object|dynamic lib )' + ;; + sni) + lt_cv_file_magic_cmd='/bin/file' + lt_cv_deplibs_check_method="file_magic ELF [[0-9]][[0-9]]*-bit [[LM]]SB dynamic lib" + lt_cv_file_magic_test_file=/lib/libc.so + ;; + siemens) + lt_cv_deplibs_check_method=pass_all + ;; + pc) + lt_cv_deplibs_check_method=pass_all + ;; + esac + ;; + +tpf*) + lt_cv_deplibs_check_method=pass_all + ;; +os2*) + lt_cv_deplibs_check_method=pass_all + ;; +esac +]) + +file_magic_glob= +want_nocaseglob=no +if test "$build" = "$host"; then + case $host_os in + mingw* | pw32*) + if ( shopt | grep nocaseglob ) >/dev/null 2>&1; then + want_nocaseglob=yes + else + file_magic_glob=`echo aAbBcCdDeEfFgGhHiIjJkKlLmMnNoOpPqQrRsStTuUvVwWxXyYzZ | $SED -e "s/\(..\)/s\/[[\1]]\/[[\1]]\/g;/g"` + fi + ;; + esac +fi + +file_magic_cmd=$lt_cv_file_magic_cmd +deplibs_check_method=$lt_cv_deplibs_check_method +test -z "$deplibs_check_method" && deplibs_check_method=unknown + +_LT_DECL([], [deplibs_check_method], [1], + [Method to check whether dependent libraries are shared objects]) +_LT_DECL([], [file_magic_cmd], [1], + [Command to use when deplibs_check_method = "file_magic"]) +_LT_DECL([], [file_magic_glob], [1], + [How to find potential files when deplibs_check_method = "file_magic"]) +_LT_DECL([], [want_nocaseglob], [1], + [Find potential files using nocaseglob when deplibs_check_method = "file_magic"]) +])# _LT_CHECK_MAGIC_METHOD + + +# LT_PATH_NM +# ---------- +# find the pathname to a BSD- or MS-compatible name lister +AC_DEFUN([LT_PATH_NM], +[AC_REQUIRE([AC_PROG_CC])dnl +AC_CACHE_CHECK([for BSD- or MS-compatible name lister (nm)], lt_cv_path_NM, +[if test -n "$NM"; then + # Let the user override the test. + lt_cv_path_NM=$NM +else + lt_nm_to_check=${ac_tool_prefix}nm + if test -n "$ac_tool_prefix" && test "$build" = "$host"; then + lt_nm_to_check="$lt_nm_to_check nm" + fi + for lt_tmp_nm in $lt_nm_to_check; do + lt_save_ifs=$IFS; IFS=$PATH_SEPARATOR + for ac_dir in $PATH /usr/ccs/bin/elf /usr/ccs/bin /usr/ucb /bin; do + IFS=$lt_save_ifs + test -z "$ac_dir" && ac_dir=. + tmp_nm=$ac_dir/$lt_tmp_nm + if test -f "$tmp_nm" || test -f "$tmp_nm$ac_exeext"; then + # Check to see if the nm accepts a BSD-compat flag. + # Adding the 'sed 1q' prevents false positives on HP-UX, which says: + # nm: unknown option "B" ignored + # Tru64's nm complains that /dev/null is an invalid object file + # MSYS converts /dev/null to NUL, MinGW nm treats NUL as empty + case $build_os in + mingw*) lt_bad_file=conftest.nm/nofile ;; + *) lt_bad_file=/dev/null ;; + esac + case `"$tmp_nm" -B $lt_bad_file 2>&1 | $SED '1q'` in + *$lt_bad_file* | *'Invalid file or object type'*) + lt_cv_path_NM="$tmp_nm -B" + break 2 + ;; + *) + case `"$tmp_nm" -p /dev/null 2>&1 | $SED '1q'` in + */dev/null*) + lt_cv_path_NM="$tmp_nm -p" + break 2 + ;; + *) + lt_cv_path_NM=${lt_cv_path_NM="$tmp_nm"} # keep the first match, but + continue # so that we can try to find one that supports BSD flags + ;; + esac + ;; + esac + fi + done + IFS=$lt_save_ifs + done + : ${lt_cv_path_NM=no} +fi]) +if test no != "$lt_cv_path_NM"; then + NM=$lt_cv_path_NM +else + # Didn't find any BSD compatible name lister, look for dumpbin. + if test -n "$DUMPBIN"; then : + # Let the user override the test. + else + AC_CHECK_TOOLS(DUMPBIN, [dumpbin "link -dump"], :) + case `$DUMPBIN -symbols -headers /dev/null 2>&1 | $SED '1q'` in + *COFF*) + DUMPBIN="$DUMPBIN -symbols -headers" + ;; + *) + DUMPBIN=: + ;; + esac + fi + AC_SUBST([DUMPBIN]) + if test : != "$DUMPBIN"; then + NM=$DUMPBIN + fi +fi +test -z "$NM" && NM=nm +AC_SUBST([NM]) +_LT_DECL([], [NM], [1], [A BSD- or MS-compatible name lister])dnl + +AC_CACHE_CHECK([the name lister ($NM) interface], [lt_cv_nm_interface], + [lt_cv_nm_interface="BSD nm" + echo "int some_variable = 0;" > conftest.$ac_ext + (eval echo "\"\$as_me:$LINENO: $ac_compile\"" >&AS_MESSAGE_LOG_FD) + (eval "$ac_compile" 2>conftest.err) + cat conftest.err >&AS_MESSAGE_LOG_FD + (eval echo "\"\$as_me:$LINENO: $NM \\\"conftest.$ac_objext\\\"\"" >&AS_MESSAGE_LOG_FD) + (eval "$NM \"conftest.$ac_objext\"" 2>conftest.err > conftest.out) + cat conftest.err >&AS_MESSAGE_LOG_FD + (eval echo "\"\$as_me:$LINENO: output\"" >&AS_MESSAGE_LOG_FD) + cat conftest.out >&AS_MESSAGE_LOG_FD + if $GREP 'External.*some_variable' conftest.out > /dev/null; then + lt_cv_nm_interface="MS dumpbin" + fi + rm -f conftest*]) +])# LT_PATH_NM + +# Old names: +AU_ALIAS([AM_PROG_NM], [LT_PATH_NM]) +AU_ALIAS([AC_PROG_NM], [LT_PATH_NM]) +dnl aclocal-1.4 backwards compatibility: +dnl AC_DEFUN([AM_PROG_NM], []) +dnl AC_DEFUN([AC_PROG_NM], []) + +# _LT_CHECK_SHAREDLIB_FROM_LINKLIB +# -------------------------------- +# how to determine the name of the shared library +# associated with a specific link library. +# -- PORTME fill in with the dynamic library characteristics +m4_defun([_LT_CHECK_SHAREDLIB_FROM_LINKLIB], +[m4_require([_LT_DECL_EGREP]) +m4_require([_LT_DECL_OBJDUMP]) +m4_require([_LT_DECL_DLLTOOL]) +AC_CACHE_CHECK([how to associate runtime and link libraries], +lt_cv_sharedlib_from_linklib_cmd, +[lt_cv_sharedlib_from_linklib_cmd='unknown' + +case $host_os in +cygwin* | mingw* | pw32* | cegcc*) + # two different shell functions defined in ltmain.sh; + # decide which one to use based on capabilities of $DLLTOOL + case `$DLLTOOL --help 2>&1` in + *--identify-strict*) + lt_cv_sharedlib_from_linklib_cmd=func_cygming_dll_for_implib + ;; + *) + lt_cv_sharedlib_from_linklib_cmd=func_cygming_dll_for_implib_fallback + ;; + esac + ;; +*) + # fallback: assume linklib IS sharedlib + lt_cv_sharedlib_from_linklib_cmd=$ECHO + ;; +esac +]) +sharedlib_from_linklib_cmd=$lt_cv_sharedlib_from_linklib_cmd +test -z "$sharedlib_from_linklib_cmd" && sharedlib_from_linklib_cmd=$ECHO + +_LT_DECL([], [sharedlib_from_linklib_cmd], [1], + [Command to associate shared and link libraries]) +])# _LT_CHECK_SHAREDLIB_FROM_LINKLIB + + +# _LT_PATH_MANIFEST_TOOL +# ---------------------- +# locate the manifest tool +m4_defun([_LT_PATH_MANIFEST_TOOL], +[AC_CHECK_TOOL(MANIFEST_TOOL, mt, :) +test -z "$MANIFEST_TOOL" && MANIFEST_TOOL=mt +AC_CACHE_CHECK([if $MANIFEST_TOOL is a manifest tool], [lt_cv_path_mainfest_tool], + [lt_cv_path_mainfest_tool=no + echo "$as_me:$LINENO: $MANIFEST_TOOL '-?'" >&AS_MESSAGE_LOG_FD + $MANIFEST_TOOL '-?' 2>conftest.err > conftest.out + cat conftest.err >&AS_MESSAGE_LOG_FD + if $GREP 'Manifest Tool' conftest.out > /dev/null; then + lt_cv_path_mainfest_tool=yes + fi + rm -f conftest*]) +if test yes != "$lt_cv_path_mainfest_tool"; then + MANIFEST_TOOL=: +fi +_LT_DECL([], [MANIFEST_TOOL], [1], [Manifest tool])dnl +])# _LT_PATH_MANIFEST_TOOL + + +# _LT_DLL_DEF_P([FILE]) +# --------------------- +# True iff FILE is a Windows DLL '.def' file. +# Keep in sync with func_dll_def_p in the libtool script +AC_DEFUN([_LT_DLL_DEF_P], +[dnl + test DEF = "`$SED -n dnl + -e '\''s/^[[ ]]*//'\'' dnl Strip leading whitespace + -e '\''/^\(;.*\)*$/d'\'' dnl Delete empty lines and comments + -e '\''s/^\(EXPORTS\|LIBRARY\)\([[ ]].*\)*$/DEF/p'\'' dnl + -e q dnl Only consider the first "real" line + $1`" dnl +])# _LT_DLL_DEF_P + + +# LT_LIB_M +# -------- +# check for math library +AC_DEFUN([LT_LIB_M], +[AC_REQUIRE([AC_CANONICAL_HOST])dnl +LIBM= +case $host in +*-*-beos* | *-*-cegcc* | *-*-cygwin* | *-*-haiku* | *-*-pw32* | *-*-darwin*) + # These system don't have libm, or don't need it + ;; +*-ncr-sysv4.3*) + AC_CHECK_LIB(mw, _mwvalidcheckl, LIBM=-lmw) + AC_CHECK_LIB(m, cos, LIBM="$LIBM -lm") + ;; +*) + AC_CHECK_LIB(m, cos, LIBM=-lm) + ;; +esac +AC_SUBST([LIBM]) +])# LT_LIB_M + +# Old name: +AU_ALIAS([AC_CHECK_LIBM], [LT_LIB_M]) +dnl aclocal-1.4 backwards compatibility: +dnl AC_DEFUN([AC_CHECK_LIBM], []) + + +# _LT_COMPILER_NO_RTTI([TAGNAME]) +# ------------------------------- +m4_defun([_LT_COMPILER_NO_RTTI], +[m4_require([_LT_TAG_COMPILER])dnl + +_LT_TAGVAR(lt_prog_compiler_no_builtin_flag, $1)= + +if test yes = "$GCC"; then + case $cc_basename in + nvcc*) + _LT_TAGVAR(lt_prog_compiler_no_builtin_flag, $1)=' -Xcompiler -fno-builtin' ;; + *) + _LT_TAGVAR(lt_prog_compiler_no_builtin_flag, $1)=' -fno-builtin' ;; + esac + + _LT_COMPILER_OPTION([if $compiler supports -fno-rtti -fno-exceptions], + lt_cv_prog_compiler_rtti_exceptions, + [-fno-rtti -fno-exceptions], [], + [_LT_TAGVAR(lt_prog_compiler_no_builtin_flag, $1)="$_LT_TAGVAR(lt_prog_compiler_no_builtin_flag, $1) -fno-rtti -fno-exceptions"]) +fi +_LT_TAGDECL([no_builtin_flag], [lt_prog_compiler_no_builtin_flag], [1], + [Compiler flag to turn off builtin functions]) +])# _LT_COMPILER_NO_RTTI + + +# _LT_CMD_GLOBAL_SYMBOLS +# ---------------------- +m4_defun([_LT_CMD_GLOBAL_SYMBOLS], +[AC_REQUIRE([AC_CANONICAL_HOST])dnl +AC_REQUIRE([AC_PROG_CC])dnl +AC_REQUIRE([AC_PROG_AWK])dnl +AC_REQUIRE([LT_PATH_NM])dnl +AC_REQUIRE([LT_PATH_LD])dnl +m4_require([_LT_DECL_SED])dnl +m4_require([_LT_DECL_EGREP])dnl +m4_require([_LT_TAG_COMPILER])dnl + +# Check for command to grab the raw symbol name followed by C symbol from nm. +AC_MSG_CHECKING([command to parse $NM output from $compiler object]) +AC_CACHE_VAL([lt_cv_sys_global_symbol_pipe], +[ +# These are sane defaults that work on at least a few old systems. +# [They come from Ultrix. What could be older than Ultrix?!! ;)] + +# Character class describing NM global symbol codes. +symcode='[[BCDEGRST]]' + +# Regexp to match symbols that can be accessed directly from C. +sympat='\([[_A-Za-z]][[_A-Za-z0-9]]*\)' + +# Define system-specific variables. +case $host_os in +aix*) + symcode='[[BCDT]]' + ;; +cygwin* | mingw* | pw32* | cegcc*) + symcode='[[ABCDGISTW]]' + ;; +hpux*) + if test ia64 = "$host_cpu"; then + symcode='[[ABCDEGRST]]' + fi + ;; +irix* | nonstopux*) + symcode='[[BCDEGRST]]' + ;; +osf*) + symcode='[[BCDEGQRST]]' + ;; +solaris*) + symcode='[[BDRT]]' + ;; +sco3.2v5*) + symcode='[[DT]]' + ;; +sysv4.2uw2*) + symcode='[[DT]]' + ;; +sysv5* | sco5v6* | unixware* | OpenUNIX*) + symcode='[[ABDT]]' + ;; +sysv4) + symcode='[[DFNSTU]]' + ;; +esac + +# If we're using GNU nm, then use its standard symbol codes. +case `$NM -V 2>&1` in +*GNU* | *'with BFD'*) + symcode='[[ABCDGIRSTW]]' ;; +esac + +if test "$lt_cv_nm_interface" = "MS dumpbin"; then + # Gets list of data symbols to import. + lt_cv_sys_global_symbol_to_import="$SED -n -e 's/^I .* \(.*\)$/\1/p'" + # Adjust the below global symbol transforms to fixup imported variables. + lt_cdecl_hook=" -e 's/^I .* \(.*\)$/extern __declspec(dllimport) char \1;/p'" + lt_c_name_hook=" -e 's/^I .* \(.*\)$/ {\"\1\", (void *) 0},/p'" + lt_c_name_lib_hook="\ + -e 's/^I .* \(lib.*\)$/ {\"\1\", (void *) 0},/p'\ + -e 's/^I .* \(.*\)$/ {\"lib\1\", (void *) 0},/p'" +else + # Disable hooks by default. + lt_cv_sys_global_symbol_to_import= + lt_cdecl_hook= + lt_c_name_hook= + lt_c_name_lib_hook= +fi + +# Transform an extracted symbol line into a proper C declaration. +# Some systems (esp. on ia64) link data and code symbols differently, +# so use this general approach. +lt_cv_sys_global_symbol_to_cdecl="$SED -n"\ +$lt_cdecl_hook\ +" -e 's/^T .* \(.*\)$/extern int \1();/p'"\ +" -e 's/^$symcode$symcode* .* \(.*\)$/extern char \1;/p'" + +# Transform an extracted symbol line into symbol name and symbol address +lt_cv_sys_global_symbol_to_c_name_address="$SED -n"\ +$lt_c_name_hook\ +" -e 's/^: \(.*\) .*$/ {\"\1\", (void *) 0},/p'"\ +" -e 's/^$symcode$symcode* .* \(.*\)$/ {\"\1\", (void *) \&\1},/p'" + +# Transform an extracted symbol line into symbol name with lib prefix and +# symbol address. +lt_cv_sys_global_symbol_to_c_name_address_lib_prefix="$SED -n"\ +$lt_c_name_lib_hook\ +" -e 's/^: \(.*\) .*$/ {\"\1\", (void *) 0},/p'"\ +" -e 's/^$symcode$symcode* .* \(lib.*\)$/ {\"\1\", (void *) \&\1},/p'"\ +" -e 's/^$symcode$symcode* .* \(.*\)$/ {\"lib\1\", (void *) \&\1},/p'" + +# Handle CRLF in mingw tool chain +opt_cr= +case $build_os in +mingw*) + opt_cr=`$ECHO 'x\{0,1\}' | tr x '\015'` # option cr in regexp + ;; +esac + +# Try without a prefix underscore, then with it. +for ac_symprfx in "" "_"; do + + # Transform symcode, sympat, and symprfx into a raw symbol and a C symbol. + symxfrm="\\1 $ac_symprfx\\2 \\2" + + # Write the raw and C identifiers. + if test "$lt_cv_nm_interface" = "MS dumpbin"; then + # Fake it for dumpbin and say T for any non-static function, + # D for any global variable and I for any imported variable. + # Also find C++ and __fastcall symbols from MSVC++ or ICC, + # which start with @ or ?. + lt_cv_sys_global_symbol_pipe="$AWK ['"\ +" {last_section=section; section=\$ 3};"\ +" /^COFF SYMBOL TABLE/{for(i in hide) delete hide[i]};"\ +" /Section length .*#relocs.*(pick any)/{hide[last_section]=1};"\ +" /^ *Symbol name *: /{split(\$ 0,sn,\":\"); si=substr(sn[2],2)};"\ +" /^ *Type *: code/{print \"T\",si,substr(si,length(prfx))};"\ +" /^ *Type *: data/{print \"I\",si,substr(si,length(prfx))};"\ +" \$ 0!~/External *\|/{next};"\ +" / 0+ UNDEF /{next}; / UNDEF \([^|]\)*()/{next};"\ +" {if(hide[section]) next};"\ +" {f=\"D\"}; \$ 0~/\(\).*\|/{f=\"T\"};"\ +" {split(\$ 0,a,/\||\r/); split(a[2],s)};"\ +" s[1]~/^[@?]/{print f,s[1],s[1]; next};"\ +" s[1]~prfx {split(s[1],t,\"@\"); print f,t[1],substr(t[1],length(prfx))}"\ +" ' prfx=^$ac_symprfx]" + else + lt_cv_sys_global_symbol_pipe="$SED -n -e 's/^.*[[ ]]\($symcode$symcode*\)[[ ]][[ ]]*$ac_symprfx$sympat$opt_cr$/$symxfrm/p'" + fi + lt_cv_sys_global_symbol_pipe="$lt_cv_sys_global_symbol_pipe | $SED '/ __gnu_lto/d'" + + # Check to see that the pipe works correctly. + pipe_works=no + + rm -f conftest* + cat > conftest.$ac_ext <<_LT_EOF +#ifdef __cplusplus +extern "C" { +#endif +char nm_test_var; +void nm_test_func(void); +void nm_test_func(void){} +#ifdef __cplusplus +} +#endif +int main(){nm_test_var='a';nm_test_func();return(0);} +_LT_EOF + + if AC_TRY_EVAL(ac_compile); then + # Now try to grab the symbols. + nlist=conftest.nm + $ECHO "$as_me:$LINENO: $NM conftest.$ac_objext | $lt_cv_sys_global_symbol_pipe > $nlist" >&AS_MESSAGE_LOG_FD + if eval "$NM" conftest.$ac_objext \| "$lt_cv_sys_global_symbol_pipe" \> $nlist 2>&AS_MESSAGE_LOG_FD && test -s "$nlist"; then + # Try sorting and uniquifying the output. + if sort "$nlist" | uniq > "$nlist"T; then + mv -f "$nlist"T "$nlist" + else + rm -f "$nlist"T + fi + + # Make sure that we snagged all the symbols we need. + if $GREP ' nm_test_var$' "$nlist" >/dev/null; then + if $GREP ' nm_test_func$' "$nlist" >/dev/null; then + cat <<_LT_EOF > conftest.$ac_ext +/* Keep this code in sync between libtool.m4, ltmain, lt_system.h, and tests. */ +#if defined _WIN32 || defined __CYGWIN__ || defined _WIN32_WCE +/* DATA imports from DLLs on WIN32 can't be const, because runtime + relocations are performed -- see ld's documentation on pseudo-relocs. */ +# define LT@&t@_DLSYM_CONST +#elif defined __osf__ +/* This system does not cope well with relocations in const data. */ +# define LT@&t@_DLSYM_CONST +#else +# define LT@&t@_DLSYM_CONST const +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +_LT_EOF + # Now generate the symbol file. + eval "$lt_cv_sys_global_symbol_to_cdecl"' < "$nlist" | $GREP -v main >> conftest.$ac_ext' + + cat <<_LT_EOF >> conftest.$ac_ext + +/* The mapping between symbol names and symbols. */ +LT@&t@_DLSYM_CONST struct { + const char *name; + void *address; +} +lt__PROGRAM__LTX_preloaded_symbols[[]] = +{ + { "@PROGRAM@", (void *) 0 }, +_LT_EOF + $SED "s/^$symcode$symcode* .* \(.*\)$/ {\"\1\", (void *) \&\1},/" < "$nlist" | $GREP -v main >> conftest.$ac_ext + cat <<\_LT_EOF >> conftest.$ac_ext + {0, (void *) 0} +}; + +/* This works around a problem in FreeBSD linker */ +#ifdef FREEBSD_WORKAROUND +static const void *lt_preloaded_setup() { + return lt__PROGRAM__LTX_preloaded_symbols; +} +#endif + +#ifdef __cplusplus +} +#endif +_LT_EOF + # Now try linking the two files. + mv conftest.$ac_objext conftstm.$ac_objext + lt_globsym_save_LIBS=$LIBS + lt_globsym_save_CFLAGS=$CFLAGS + LIBS=conftstm.$ac_objext + CFLAGS="$CFLAGS$_LT_TAGVAR(lt_prog_compiler_no_builtin_flag, $1)" + if AC_TRY_EVAL(ac_link) && test -s conftest$ac_exeext; then + pipe_works=yes + fi + LIBS=$lt_globsym_save_LIBS + CFLAGS=$lt_globsym_save_CFLAGS + else + echo "cannot find nm_test_func in $nlist" >&AS_MESSAGE_LOG_FD + fi + else + echo "cannot find nm_test_var in $nlist" >&AS_MESSAGE_LOG_FD + fi + else + echo "cannot run $lt_cv_sys_global_symbol_pipe" >&AS_MESSAGE_LOG_FD + fi + else + echo "$progname: failed program was:" >&AS_MESSAGE_LOG_FD + cat conftest.$ac_ext >&5 + fi + rm -rf conftest* conftst* + + # Do not use the global_symbol_pipe unless it works. + if test yes = "$pipe_works"; then + break + else + lt_cv_sys_global_symbol_pipe= + fi +done +]) +if test -z "$lt_cv_sys_global_symbol_pipe"; then + lt_cv_sys_global_symbol_to_cdecl= +fi +if test -z "$lt_cv_sys_global_symbol_pipe$lt_cv_sys_global_symbol_to_cdecl"; then + AC_MSG_RESULT(failed) +else + AC_MSG_RESULT(ok) +fi + +# Response file support. +if test "$lt_cv_nm_interface" = "MS dumpbin"; then + nm_file_list_spec='@' +elif $NM --help 2>/dev/null | grep '[[@]]FILE' >/dev/null; then + nm_file_list_spec='@' +fi + +_LT_DECL([global_symbol_pipe], [lt_cv_sys_global_symbol_pipe], [1], + [Take the output of nm and produce a listing of raw symbols and C names]) +_LT_DECL([global_symbol_to_cdecl], [lt_cv_sys_global_symbol_to_cdecl], [1], + [Transform the output of nm in a proper C declaration]) +_LT_DECL([global_symbol_to_import], [lt_cv_sys_global_symbol_to_import], [1], + [Transform the output of nm into a list of symbols to manually relocate]) +_LT_DECL([global_symbol_to_c_name_address], + [lt_cv_sys_global_symbol_to_c_name_address], [1], + [Transform the output of nm in a C name address pair]) +_LT_DECL([global_symbol_to_c_name_address_lib_prefix], + [lt_cv_sys_global_symbol_to_c_name_address_lib_prefix], [1], + [Transform the output of nm in a C name address pair when lib prefix is needed]) +_LT_DECL([nm_interface], [lt_cv_nm_interface], [1], + [The name lister interface]) +_LT_DECL([], [nm_file_list_spec], [1], + [Specify filename containing input files for $NM]) +]) # _LT_CMD_GLOBAL_SYMBOLS + + +# _LT_COMPILER_PIC([TAGNAME]) +# --------------------------- +m4_defun([_LT_COMPILER_PIC], +[m4_require([_LT_TAG_COMPILER])dnl +_LT_TAGVAR(lt_prog_compiler_wl, $1)= +_LT_TAGVAR(lt_prog_compiler_pic, $1)= +_LT_TAGVAR(lt_prog_compiler_static, $1)= + +m4_if([$1], [CXX], [ + # C++ specific cases for pic, static, wl, etc. + if test yes = "$GXX"; then + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' + _LT_TAGVAR(lt_prog_compiler_static, $1)='-static' + + case $host_os in + aix*) + # All AIX code is PIC. + if test ia64 = "$host_cpu"; then + # AIX 5 now supports IA64 processor + _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' + fi + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC' + ;; + + amigaos*) + case $host_cpu in + powerpc) + # see comment about AmigaOS4 .so support + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC' + ;; + m68k) + # FIXME: we need at least 68020 code to build shared libraries, but + # adding the '-m68020' flag to GCC prevents building anything better, + # like '-m68040'. + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-m68020 -resident32 -malways-restore-a4' + ;; + esac + ;; + + beos* | irix5* | irix6* | nonstopux* | osf3* | osf4* | osf5*) + # PIC is the default for these OSes. + ;; + mingw* | cygwin* | os2* | pw32* | cegcc*) + # This hack is so that the source file can tell whether it is being + # built for inclusion in a dll (and should export symbols for example). + # Although the cygwin gcc ignores -fPIC, still need this for old-style + # (--disable-auto-import) libraries + m4_if([$1], [GCJ], [], + [_LT_TAGVAR(lt_prog_compiler_pic, $1)='-DDLL_EXPORT']) + case $host_os in + os2*) + _LT_TAGVAR(lt_prog_compiler_static, $1)='$wl-static' + ;; + esac + ;; + darwin* | rhapsody*) + # PIC is the default on this platform + # Common symbols not allowed in MH_DYLIB files + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fno-common' + ;; + *djgpp*) + # DJGPP does not support shared libraries at all + _LT_TAGVAR(lt_prog_compiler_pic, $1)= + ;; + haiku*) + # PIC is the default for Haiku. + # The "-static" flag exists, but is broken. + _LT_TAGVAR(lt_prog_compiler_static, $1)= + ;; + interix[[3-9]]*) + # Interix 3.x gcc -fpic/-fPIC options generate broken code. + # Instead, we relocate shared libraries at runtime. + ;; + sysv4*MP*) + if test -d /usr/nec; then + _LT_TAGVAR(lt_prog_compiler_pic, $1)=-Kconform_pic + fi + ;; + hpux*) + # PIC is the default for 64-bit PA HP-UX, but not for 32-bit + # PA HP-UX. On IA64 HP-UX, PIC is the default but the pic flag + # sets the default TLS model and affects inlining. + case $host_cpu in + hppa*64*) + ;; + *) + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC' + ;; + esac + ;; + *qnx* | *nto*) + # QNX uses GNU C++, but need to define -shared option too, otherwise + # it will coredump. + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC -shared' + ;; + *) + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC' + ;; + esac + else + case $host_os in + aix[[4-9]]*) + # All AIX code is PIC. + if test ia64 = "$host_cpu"; then + # AIX 5 now supports IA64 processor + _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' + else + _LT_TAGVAR(lt_prog_compiler_static, $1)='-bnso -bI:/lib/syscalls.exp' + fi + ;; + chorus*) + case $cc_basename in + cxch68*) + # Green Hills C++ Compiler + # _LT_TAGVAR(lt_prog_compiler_static, $1)="--no_auto_instantiation -u __main -u __premain -u _abort -r $COOL_DIR/lib/libOrb.a $MVME_DIR/lib/CC/libC.a $MVME_DIR/lib/classix/libcx.s.a" + ;; + esac + ;; + mingw* | cygwin* | os2* | pw32* | cegcc*) + # This hack is so that the source file can tell whether it is being + # built for inclusion in a dll (and should export symbols for example). + m4_if([$1], [GCJ], [], + [_LT_TAGVAR(lt_prog_compiler_pic, $1)='-DDLL_EXPORT']) + ;; + dgux*) + case $cc_basename in + ec++*) + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC' + ;; + ghcx*) + # Green Hills C++ Compiler + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-pic' + ;; + *) + ;; + esac + ;; + freebsd* | dragonfly* | midnightbsd*) + # FreeBSD uses GNU C++ + ;; + hpux9* | hpux10* | hpux11*) + case $cc_basename in + CC*) + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' + _LT_TAGVAR(lt_prog_compiler_static, $1)='$wl-a ${wl}archive' + if test ia64 != "$host_cpu"; then + _LT_TAGVAR(lt_prog_compiler_pic, $1)='+Z' + fi + ;; + aCC*) + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' + _LT_TAGVAR(lt_prog_compiler_static, $1)='$wl-a ${wl}archive' + case $host_cpu in + hppa*64*|ia64*) + # +Z the default + ;; + *) + _LT_TAGVAR(lt_prog_compiler_pic, $1)='+Z' + ;; + esac + ;; + *) + ;; + esac + ;; + interix*) + # This is c89, which is MS Visual C++ (no shared libs) + # Anyone wants to do a port? + ;; + irix5* | irix6* | nonstopux*) + case $cc_basename in + CC*) + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' + _LT_TAGVAR(lt_prog_compiler_static, $1)='-non_shared' + # CC pic flag -KPIC is the default. + ;; + *) + ;; + esac + ;; + linux* | k*bsd*-gnu | kopensolaris*-gnu | gnu*) + case $cc_basename in + KCC*) + # KAI C++ Compiler + _LT_TAGVAR(lt_prog_compiler_wl, $1)='--backend -Wl,' + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC' + ;; + ecpc* ) + # old Intel C++ for x86_64, which still supported -KPIC. + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC' + _LT_TAGVAR(lt_prog_compiler_static, $1)='-static' + ;; + icpc* ) + # Intel C++, used to be incompatible with GCC. + # ICC 10 doesn't accept -KPIC any more. + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC' + _LT_TAGVAR(lt_prog_compiler_static, $1)='-static' + ;; + pgCC* | pgcpp*) + # Portland Group C++ compiler + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fpic' + _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' + ;; + cxx*) + # Compaq C++ + # Make sure the PIC flag is empty. It appears that all Alpha + # Linux and Compaq Tru64 Unix objects are PIC. + _LT_TAGVAR(lt_prog_compiler_pic, $1)= + _LT_TAGVAR(lt_prog_compiler_static, $1)='-non_shared' + ;; + xlc* | xlC* | bgxl[[cC]]* | mpixl[[cC]]*) + # IBM XL 8.0, 9.0 on PPC and BlueGene + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-qpic' + _LT_TAGVAR(lt_prog_compiler_static, $1)='-qstaticlink' + ;; + *) + case `$CC -V 2>&1 | $SED 5q` in + *Sun\ C*) + # Sun C++ 5.9 + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC' + _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Qoption ld ' + ;; + esac + ;; + esac + ;; + lynxos*) + ;; + m88k*) + ;; + mvs*) + case $cc_basename in + cxx*) + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-W c,exportall' + ;; + *) + ;; + esac + ;; + netbsd* | netbsdelf*-gnu) + ;; + *qnx* | *nto*) + # QNX uses GNU C++, but need to define -shared option too, otherwise + # it will coredump. + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC -shared' + ;; + osf3* | osf4* | osf5*) + case $cc_basename in + KCC*) + _LT_TAGVAR(lt_prog_compiler_wl, $1)='--backend -Wl,' + ;; + RCC*) + # Rational C++ 2.4.1 + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-pic' + ;; + cxx*) + # Digital/Compaq C++ + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' + # Make sure the PIC flag is empty. It appears that all Alpha + # Linux and Compaq Tru64 Unix objects are PIC. + _LT_TAGVAR(lt_prog_compiler_pic, $1)= + _LT_TAGVAR(lt_prog_compiler_static, $1)='-non_shared' + ;; + *) + ;; + esac + ;; + psos*) + ;; + solaris*) + case $cc_basename in + CC* | sunCC*) + # Sun C++ 4.2, 5.x and Centerline C++ + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC' + _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Qoption ld ' + ;; + gcx*) + # Green Hills C++ Compiler + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-PIC' + ;; + *) + ;; + esac + ;; + sunos4*) + case $cc_basename in + CC*) + # Sun C++ 4.x + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-pic' + _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' + ;; + lcc*) + # Lucid + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-pic' + ;; + *) + ;; + esac + ;; + sysv5* | unixware* | sco3.2v5* | sco5v6* | OpenUNIX*) + case $cc_basename in + CC*) + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC' + _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' + ;; + esac + ;; + tandem*) + case $cc_basename in + NCC*) + # NonStop-UX NCC 3.20 + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC' + ;; + *) + ;; + esac + ;; + vxworks*) + ;; + *) + _LT_TAGVAR(lt_prog_compiler_can_build_shared, $1)=no + ;; + esac + fi +], +[ + if test yes = "$GCC"; then + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' + _LT_TAGVAR(lt_prog_compiler_static, $1)='-static' + + case $host_os in + aix*) + # All AIX code is PIC. + if test ia64 = "$host_cpu"; then + # AIX 5 now supports IA64 processor + _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' + fi + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC' + ;; + + amigaos*) + case $host_cpu in + powerpc) + # see comment about AmigaOS4 .so support + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC' + ;; + m68k) + # FIXME: we need at least 68020 code to build shared libraries, but + # adding the '-m68020' flag to GCC prevents building anything better, + # like '-m68040'. + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-m68020 -resident32 -malways-restore-a4' + ;; + esac + ;; + + beos* | irix5* | irix6* | nonstopux* | osf3* | osf4* | osf5*) + # PIC is the default for these OSes. + ;; + + mingw* | cygwin* | pw32* | os2* | cegcc*) + # This hack is so that the source file can tell whether it is being + # built for inclusion in a dll (and should export symbols for example). + # Although the cygwin gcc ignores -fPIC, still need this for old-style + # (--disable-auto-import) libraries + m4_if([$1], [GCJ], [], + [_LT_TAGVAR(lt_prog_compiler_pic, $1)='-DDLL_EXPORT']) + case $host_os in + os2*) + _LT_TAGVAR(lt_prog_compiler_static, $1)='$wl-static' + ;; + esac + ;; + + darwin* | rhapsody*) + # PIC is the default on this platform + # Common symbols not allowed in MH_DYLIB files + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fno-common' + ;; + + haiku*) + # PIC is the default for Haiku. + # The "-static" flag exists, but is broken. + _LT_TAGVAR(lt_prog_compiler_static, $1)= + ;; + + hpux*) + # PIC is the default for 64-bit PA HP-UX, but not for 32-bit + # PA HP-UX. On IA64 HP-UX, PIC is the default but the pic flag + # sets the default TLS model and affects inlining. + case $host_cpu in + hppa*64*) + # +Z the default + ;; + *) + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC' + ;; + esac + ;; + + interix[[3-9]]*) + # Interix 3.x gcc -fpic/-fPIC options generate broken code. + # Instead, we relocate shared libraries at runtime. + ;; + + msdosdjgpp*) + # Just because we use GCC doesn't mean we suddenly get shared libraries + # on systems that don't support them. + _LT_TAGVAR(lt_prog_compiler_can_build_shared, $1)=no + enable_shared=no + ;; + + *nto* | *qnx*) + # QNX uses GNU C++, but need to define -shared option too, otherwise + # it will coredump. + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC -shared' + ;; + + sysv4*MP*) + if test -d /usr/nec; then + _LT_TAGVAR(lt_prog_compiler_pic, $1)=-Kconform_pic + fi + ;; + + *) + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC' + ;; + esac + + case $cc_basename in + nvcc*) # Cuda Compiler Driver 2.2 + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Xlinker ' + if test -n "$_LT_TAGVAR(lt_prog_compiler_pic, $1)"; then + _LT_TAGVAR(lt_prog_compiler_pic, $1)="-Xcompiler $_LT_TAGVAR(lt_prog_compiler_pic, $1)" + fi + ;; + esac + else + # PORTME Check for flag to pass linker flags through the system compiler. + case $host_os in + aix*) + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' + if test ia64 = "$host_cpu"; then + # AIX 5 now supports IA64 processor + _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' + else + _LT_TAGVAR(lt_prog_compiler_static, $1)='-bnso -bI:/lib/syscalls.exp' + fi + ;; + + darwin* | rhapsody*) + # PIC is the default on this platform + # Common symbols not allowed in MH_DYLIB files + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fno-common' + case $cc_basename in + nagfor*) + # NAG Fortran compiler + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,-Wl,,' + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-PIC' + _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' + ;; + esac + ;; + + mingw* | cygwin* | pw32* | os2* | cegcc*) + # This hack is so that the source file can tell whether it is being + # built for inclusion in a dll (and should export symbols for example). + m4_if([$1], [GCJ], [], + [_LT_TAGVAR(lt_prog_compiler_pic, $1)='-DDLL_EXPORT']) + case $host_os in + os2*) + _LT_TAGVAR(lt_prog_compiler_static, $1)='$wl-static' + ;; + esac + ;; + + hpux9* | hpux10* | hpux11*) + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' + # PIC is the default for IA64 HP-UX and 64-bit HP-UX, but + # not for PA HP-UX. + case $host_cpu in + hppa*64*|ia64*) + # +Z the default + ;; + *) + _LT_TAGVAR(lt_prog_compiler_pic, $1)='+Z' + ;; + esac + # Is there a better lt_prog_compiler_static that works with the bundled CC? + _LT_TAGVAR(lt_prog_compiler_static, $1)='$wl-a ${wl}archive' + ;; + + irix5* | irix6* | nonstopux*) + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' + # PIC (with -KPIC) is the default. + _LT_TAGVAR(lt_prog_compiler_static, $1)='-non_shared' + ;; + + linux* | k*bsd*-gnu | kopensolaris*-gnu | gnu*) + case $cc_basename in + # old Intel for x86_64, which still supported -KPIC. + ecc*) + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC' + _LT_TAGVAR(lt_prog_compiler_static, $1)='-static' + ;; + # flang / f18. f95 an alias for gfortran or flang on Debian + flang* | f18* | f95*) + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC' + _LT_TAGVAR(lt_prog_compiler_static, $1)='-static' + ;; + # icc used to be incompatible with GCC. + # ICC 10 doesn't accept -KPIC any more. + icc* | ifort*) + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC' + _LT_TAGVAR(lt_prog_compiler_static, $1)='-static' + ;; + # Lahey Fortran 8.1. + lf95*) + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' + _LT_TAGVAR(lt_prog_compiler_pic, $1)='--shared' + _LT_TAGVAR(lt_prog_compiler_static, $1)='--static' + ;; + nagfor*) + # NAG Fortran compiler + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,-Wl,,' + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-PIC' + _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' + ;; + tcc*) + # Fabrice Bellard et al's Tiny C Compiler + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC' + _LT_TAGVAR(lt_prog_compiler_static, $1)='-static' + ;; + pgcc* | pgf77* | pgf90* | pgf95* | pgfortran*) + # Portland Group compilers (*not* the Pentium gcc compiler, + # which looks to be a dead project) + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fpic' + _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' + ;; + ccc*) + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' + # All Alpha code is PIC. + _LT_TAGVAR(lt_prog_compiler_static, $1)='-non_shared' + ;; + xl* | bgxl* | bgf* | mpixl*) + # IBM XL C 8.0/Fortran 10.1, 11.1 on PPC and BlueGene + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-qpic' + _LT_TAGVAR(lt_prog_compiler_static, $1)='-qstaticlink' + ;; + *) + case `$CC -V 2>&1 | $SED 5q` in + *Sun\ Ceres\ Fortran* | *Sun*Fortran*\ [[1-7]].* | *Sun*Fortran*\ 8.[[0-3]]*) + # Sun Fortran 8.3 passes all unrecognized flags to the linker + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC' + _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' + _LT_TAGVAR(lt_prog_compiler_wl, $1)='' + ;; + *Sun\ F* | *Sun*Fortran*) + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC' + _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Qoption ld ' + ;; + *Sun\ C*) + # Sun C 5.9 + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC' + _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' + ;; + *Intel*\ [[CF]]*Compiler*) + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC' + _LT_TAGVAR(lt_prog_compiler_static, $1)='-static' + ;; + *Portland\ Group*) + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fpic' + _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' + ;; + esac + ;; + esac + ;; + + newsos6) + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC' + _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' + ;; + + *nto* | *qnx*) + # QNX uses GNU C++, but need to define -shared option too, otherwise + # it will coredump. + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC -shared' + ;; + + osf3* | osf4* | osf5*) + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' + # All OSF/1 code is PIC. + _LT_TAGVAR(lt_prog_compiler_static, $1)='-non_shared' + ;; + + rdos*) + _LT_TAGVAR(lt_prog_compiler_static, $1)='-non_shared' + ;; + + solaris*) + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC' + _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' + case $cc_basename in + f77* | f90* | f95* | sunf77* | sunf90* | sunf95*) + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Qoption ld ';; + *) + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,';; + esac + ;; + + sunos4*) + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Qoption ld ' + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-PIC' + _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' + ;; + + sysv4 | sysv4.2uw2* | sysv4.3*) + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC' + _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' + ;; + + sysv4*MP*) + if test -d /usr/nec; then + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-Kconform_pic' + _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' + fi + ;; + + sysv5* | unixware* | sco3.2v5* | sco5v6* | OpenUNIX*) + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC' + _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' + ;; + + unicos*) + _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' + _LT_TAGVAR(lt_prog_compiler_can_build_shared, $1)=no + ;; + + uts4*) + _LT_TAGVAR(lt_prog_compiler_pic, $1)='-pic' + _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' + ;; + + *) + _LT_TAGVAR(lt_prog_compiler_can_build_shared, $1)=no + ;; + esac + fi +]) +case $host_os in + # For platforms that do not support PIC, -DPIC is meaningless: + *djgpp*) + _LT_TAGVAR(lt_prog_compiler_pic, $1)= + ;; + *) + _LT_TAGVAR(lt_prog_compiler_pic, $1)="$_LT_TAGVAR(lt_prog_compiler_pic, $1)@&t@m4_if([$1],[],[ -DPIC],[m4_if([$1],[CXX],[ -DPIC],[])])" + ;; +esac + +AC_CACHE_CHECK([for $compiler option to produce PIC], + [_LT_TAGVAR(lt_cv_prog_compiler_pic, $1)], + [_LT_TAGVAR(lt_cv_prog_compiler_pic, $1)=$_LT_TAGVAR(lt_prog_compiler_pic, $1)]) +_LT_TAGVAR(lt_prog_compiler_pic, $1)=$_LT_TAGVAR(lt_cv_prog_compiler_pic, $1) + +# +# Check to make sure the PIC flag actually works. +# +if test -n "$_LT_TAGVAR(lt_prog_compiler_pic, $1)"; then + _LT_COMPILER_OPTION([if $compiler PIC flag $_LT_TAGVAR(lt_prog_compiler_pic, $1) works], + [_LT_TAGVAR(lt_cv_prog_compiler_pic_works, $1)], + [$_LT_TAGVAR(lt_prog_compiler_pic, $1)@&t@m4_if([$1],[],[ -DPIC],[m4_if([$1],[CXX],[ -DPIC],[])])], [], + [case $_LT_TAGVAR(lt_prog_compiler_pic, $1) in + "" | " "*) ;; + *) _LT_TAGVAR(lt_prog_compiler_pic, $1)=" $_LT_TAGVAR(lt_prog_compiler_pic, $1)" ;; + esac], + [_LT_TAGVAR(lt_prog_compiler_pic, $1)= + _LT_TAGVAR(lt_prog_compiler_can_build_shared, $1)=no]) +fi +_LT_TAGDECL([pic_flag], [lt_prog_compiler_pic], [1], + [Additional compiler flags for building library objects]) + +_LT_TAGDECL([wl], [lt_prog_compiler_wl], [1], + [How to pass a linker flag through the compiler]) +# +# Check to make sure the static flag actually works. +# +wl=$_LT_TAGVAR(lt_prog_compiler_wl, $1) eval lt_tmp_static_flag=\"$_LT_TAGVAR(lt_prog_compiler_static, $1)\" +_LT_LINKER_OPTION([if $compiler static flag $lt_tmp_static_flag works], + _LT_TAGVAR(lt_cv_prog_compiler_static_works, $1), + $lt_tmp_static_flag, + [], + [_LT_TAGVAR(lt_prog_compiler_static, $1)=]) +_LT_TAGDECL([link_static_flag], [lt_prog_compiler_static], [1], + [Compiler flag to prevent dynamic linking]) +])# _LT_COMPILER_PIC + + +# _LT_LINKER_SHLIBS([TAGNAME]) +# ---------------------------- +# See if the linker supports building shared libraries. +m4_defun([_LT_LINKER_SHLIBS], +[AC_REQUIRE([LT_PATH_LD])dnl +AC_REQUIRE([LT_PATH_NM])dnl +m4_require([_LT_PATH_MANIFEST_TOOL])dnl +m4_require([_LT_FILEUTILS_DEFAULTS])dnl +m4_require([_LT_DECL_EGREP])dnl +m4_require([_LT_DECL_SED])dnl +m4_require([_LT_CMD_GLOBAL_SYMBOLS])dnl +m4_require([_LT_TAG_COMPILER])dnl +AC_MSG_CHECKING([whether the $compiler linker ($LD) supports shared libraries]) +m4_if([$1], [CXX], [ + _LT_TAGVAR(export_symbols_cmds, $1)='$NM $libobjs $convenience | $global_symbol_pipe | $SED '\''s/.* //'\'' | sort | uniq > $export_symbols' + _LT_TAGVAR(exclude_expsyms, $1)=['_GLOBAL_OFFSET_TABLE_|_GLOBAL__F[ID]_.*'] + case $host_os in + aix[[4-9]]*) + # If we're using GNU nm, then we don't want the "-C" option. + # -C means demangle to GNU nm, but means don't demangle to AIX nm. + # Without the "-l" option, or with the "-B" option, AIX nm treats + # weak defined symbols like other global defined symbols, whereas + # GNU nm marks them as "W". + # While the 'weak' keyword is ignored in the Export File, we need + # it in the Import File for the 'aix-soname' feature, so we have + # to replace the "-B" option with "-P" for AIX nm. + if $NM -V 2>&1 | $GREP 'GNU' > /dev/null; then + _LT_TAGVAR(export_symbols_cmds, $1)='$NM -Bpg $libobjs $convenience | awk '\''{ if (((\$ 2 == "T") || (\$ 2 == "D") || (\$ 2 == "B") || (\$ 2 == "W")) && ([substr](\$ 3,1,1) != ".")) { if (\$ 2 == "W") { print \$ 3 " weak" } else { print \$ 3 } } }'\'' | sort -u > $export_symbols' + else + _LT_TAGVAR(export_symbols_cmds, $1)='`func_echo_all $NM | $SED -e '\''s/B\([[^B]]*\)$/P\1/'\''` -PCpgl $libobjs $convenience | awk '\''{ if (((\$ 2 == "T") || (\$ 2 == "D") || (\$ 2 == "B") || (\$ 2 == "L") || (\$ 2 == "W") || (\$ 2 == "V") || (\$ 2 == "Z")) && ([substr](\$ 1,1,1) != ".")) { if ((\$ 2 == "W") || (\$ 2 == "V") || (\$ 2 == "Z")) { print \$ 1 " weak" } else { print \$ 1 } } }'\'' | sort -u > $export_symbols' + fi + ;; + pw32*) + _LT_TAGVAR(export_symbols_cmds, $1)=$ltdll_cmds + ;; + cygwin* | mingw* | cegcc*) + case $cc_basename in + cl* | icl*) + _LT_TAGVAR(exclude_expsyms, $1)='_NULL_IMPORT_DESCRIPTOR|_IMPORT_DESCRIPTOR_.*' + ;; + *) + _LT_TAGVAR(export_symbols_cmds, $1)='$NM $libobjs $convenience | $global_symbol_pipe | $SED -e '\''/^[[BCDGRS]][[ ]]/s/.*[[ ]]\([[^ ]]*\)/\1 DATA/;s/^.*[[ ]]__nm__\([[^ ]]*\)[[ ]][[^ ]]*/\1 DATA/;/^I[[ ]]/d;/^[[AITW]][[ ]]/s/.* //'\'' | sort | uniq > $export_symbols' + _LT_TAGVAR(exclude_expsyms, $1)=['[_]+GLOBAL_OFFSET_TABLE_|[_]+GLOBAL__[FID]_.*|[_]+head_[A-Za-z0-9_]+_dll|[A-Za-z0-9_]+_dll_iname'] + ;; + esac + ;; + linux* | k*bsd*-gnu | gnu*) + _LT_TAGVAR(link_all_deplibs, $1)=no + ;; + *) + _LT_TAGVAR(export_symbols_cmds, $1)='$NM $libobjs $convenience | $global_symbol_pipe | $SED '\''s/.* //'\'' | sort | uniq > $export_symbols' + ;; + esac +], [ + runpath_var= + _LT_TAGVAR(allow_undefined_flag, $1)= + _LT_TAGVAR(always_export_symbols, $1)=no + _LT_TAGVAR(archive_cmds, $1)= + _LT_TAGVAR(archive_expsym_cmds, $1)= + _LT_TAGVAR(compiler_needs_object, $1)=no + _LT_TAGVAR(enable_shared_with_static_runtimes, $1)=no + _LT_TAGVAR(export_dynamic_flag_spec, $1)= + _LT_TAGVAR(export_symbols_cmds, $1)='$NM $libobjs $convenience | $global_symbol_pipe | $SED '\''s/.* //'\'' | sort | uniq > $export_symbols' + _LT_TAGVAR(hardcode_automatic, $1)=no + _LT_TAGVAR(hardcode_direct, $1)=no + _LT_TAGVAR(hardcode_direct_absolute, $1)=no + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)= + _LT_TAGVAR(hardcode_libdir_separator, $1)= + _LT_TAGVAR(hardcode_minus_L, $1)=no + _LT_TAGVAR(hardcode_shlibpath_var, $1)=unsupported + _LT_TAGVAR(inherit_rpath, $1)=no + _LT_TAGVAR(link_all_deplibs, $1)=unknown + _LT_TAGVAR(module_cmds, $1)= + _LT_TAGVAR(module_expsym_cmds, $1)= + _LT_TAGVAR(old_archive_from_new_cmds, $1)= + _LT_TAGVAR(old_archive_from_expsyms_cmds, $1)= + _LT_TAGVAR(thread_safe_flag_spec, $1)= + _LT_TAGVAR(whole_archive_flag_spec, $1)= + # include_expsyms should be a list of space-separated symbols to be *always* + # included in the symbol list + _LT_TAGVAR(include_expsyms, $1)= + # exclude_expsyms can be an extended regexp of symbols to exclude + # it will be wrapped by ' (' and ')$', so one must not match beginning or + # end of line. Example: 'a|bc|.*d.*' will exclude the symbols 'a' and 'bc', + # as well as any symbol that contains 'd'. + _LT_TAGVAR(exclude_expsyms, $1)=['_GLOBAL_OFFSET_TABLE_|_GLOBAL__F[ID]_.*'] + # Although _GLOBAL_OFFSET_TABLE_ is a valid symbol C name, most a.out + # platforms (ab)use it in PIC code, but their linkers get confused if + # the symbol is explicitly referenced. Since portable code cannot + # rely on this symbol name, it's probably fine to never include it in + # preloaded symbol tables. + # Exclude shared library initialization/finalization symbols. +dnl Note also adjust exclude_expsyms for C++ above. + extract_expsyms_cmds= + + case $host_os in + cygwin* | mingw* | pw32* | cegcc*) + # FIXME: the MSVC++ and ICC port hasn't been tested in a loooong time + # When not using gcc, we currently assume that we are using + # Microsoft Visual C++ or Intel C++ Compiler. + if test yes != "$GCC"; then + with_gnu_ld=no + fi + ;; + interix*) + # we just hope/assume this is gcc and not c89 (= MSVC++ or ICC) + with_gnu_ld=yes + ;; + openbsd* | bitrig*) + with_gnu_ld=no + ;; + linux* | k*bsd*-gnu | gnu*) + _LT_TAGVAR(link_all_deplibs, $1)=no + ;; + esac + + _LT_TAGVAR(ld_shlibs, $1)=yes + + # On some targets, GNU ld is compatible enough with the native linker + # that we're better off using the native interface for both. + lt_use_gnu_ld_interface=no + if test yes = "$with_gnu_ld"; then + case $host_os in + aix*) + # The AIX port of GNU ld has always aspired to compatibility + # with the native linker. However, as the warning in the GNU ld + # block says, versions before 2.19.5* couldn't really create working + # shared libraries, regardless of the interface used. + case `$LD -v 2>&1` in + *\ \(GNU\ Binutils\)\ 2.19.5*) ;; + *\ \(GNU\ Binutils\)\ 2.[[2-9]]*) ;; + *\ \(GNU\ Binutils\)\ [[3-9]]*) ;; + *) + lt_use_gnu_ld_interface=yes + ;; + esac + ;; + *) + lt_use_gnu_ld_interface=yes + ;; + esac + fi + + if test yes = "$lt_use_gnu_ld_interface"; then + # If archive_cmds runs LD, not CC, wlarc should be empty + wlarc='$wl' + + # Set some defaults for GNU ld with shared library support. These + # are reset later if shared libraries are not supported. Putting them + # here allows them to be overridden if necessary. + runpath_var=LD_RUN_PATH + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl-rpath $wl$libdir' + _LT_TAGVAR(export_dynamic_flag_spec, $1)='$wl--export-dynamic' + # ancient GNU ld didn't support --whole-archive et. al. + if $LD --help 2>&1 | $GREP 'no-whole-archive' > /dev/null; then + _LT_TAGVAR(whole_archive_flag_spec, $1)=$wlarc'--whole-archive$convenience '$wlarc'--no-whole-archive' + else + _LT_TAGVAR(whole_archive_flag_spec, $1)= + fi + supports_anon_versioning=no + case `$LD -v | $SED -e 's/([[^)]]\+)\s\+//' 2>&1` in + *GNU\ gold*) supports_anon_versioning=yes ;; + *\ [[01]].* | *\ 2.[[0-9]].* | *\ 2.10.*) ;; # catch versions < 2.11 + *\ 2.11.93.0.2\ *) supports_anon_versioning=yes ;; # RH7.3 ... + *\ 2.11.92.0.12\ *) supports_anon_versioning=yes ;; # Mandrake 8.2 ... + *\ 2.11.*) ;; # other 2.11 versions + *) supports_anon_versioning=yes ;; + esac + + # See if GNU ld supports shared libraries. + case $host_os in + aix[[3-9]]*) + # On AIX/PPC, the GNU linker is very broken + if test ia64 != "$host_cpu"; then + _LT_TAGVAR(ld_shlibs, $1)=no + cat <<_LT_EOF 1>&2 + +*** Warning: the GNU linker, at least up to release 2.19, is reported +*** to be unable to reliably create shared libraries on AIX. +*** Therefore, libtool is disabling shared libraries support. If you +*** really care for shared libraries, you may want to install binutils +*** 2.20 or above, or modify your PATH so that a non-GNU linker is found. +*** You will then need to restart the configuration process. + +_LT_EOF + fi + ;; + + amigaos*) + case $host_cpu in + powerpc) + # see comment about AmigaOS4 .so support + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' + _LT_TAGVAR(archive_expsym_cmds, $1)='' + ;; + m68k) + _LT_TAGVAR(archive_cmds, $1)='$RM $output_objdir/a2ixlibrary.data~$ECHO "#define NAME $libname" > $output_objdir/a2ixlibrary.data~$ECHO "#define LIBRARY_ID 1" >> $output_objdir/a2ixlibrary.data~$ECHO "#define VERSION $major" >> $output_objdir/a2ixlibrary.data~$ECHO "#define REVISION $revision" >> $output_objdir/a2ixlibrary.data~$AR $AR_FLAGS $lib $libobjs~$RANLIB $lib~(cd $output_objdir && a2ixlibrary -32)' + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir' + _LT_TAGVAR(hardcode_minus_L, $1)=yes + ;; + esac + ;; + + beos*) + if $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then + _LT_TAGVAR(allow_undefined_flag, $1)=unsupported + # Joseph Beckenbach says some releases of gcc + # support --undefined. This deserves some investigation. FIXME + _LT_TAGVAR(archive_cmds, $1)='$CC -nostart $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' + else + _LT_TAGVAR(ld_shlibs, $1)=no + fi + ;; + + cygwin* | mingw* | pw32* | cegcc*) + # _LT_TAGVAR(hardcode_libdir_flag_spec, $1) is actually meaningless, + # as there is no search path for DLLs. + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir' + _LT_TAGVAR(export_dynamic_flag_spec, $1)='$wl--export-all-symbols' + _LT_TAGVAR(allow_undefined_flag, $1)=unsupported + _LT_TAGVAR(always_export_symbols, $1)=no + _LT_TAGVAR(enable_shared_with_static_runtimes, $1)=yes + _LT_TAGVAR(export_symbols_cmds, $1)='$NM $libobjs $convenience | $global_symbol_pipe | $SED -e '\''/^[[BCDGRS]][[ ]]/s/.*[[ ]]\([[^ ]]*\)/\1 DATA/;s/^.*[[ ]]__nm__\([[^ ]]*\)[[ ]][[^ ]]*/\1 DATA/;/^I[[ ]]/d;/^[[AITW]][[ ]]/s/.* //'\'' | sort | uniq > $export_symbols' + _LT_TAGVAR(exclude_expsyms, $1)=['[_]+GLOBAL_OFFSET_TABLE_|[_]+GLOBAL__[FID]_.*|[_]+head_[A-Za-z0-9_]+_dll|[A-Za-z0-9_]+_dll_iname'] + + if $LD --help 2>&1 | $GREP 'auto-import' > /dev/null; then + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags -o $output_objdir/$soname $wl--enable-auto-image-base -Xlinker --out-implib -Xlinker $lib' + # If the export-symbols file already is a .def file, use it as + # is; otherwise, prepend EXPORTS... + _LT_TAGVAR(archive_expsym_cmds, $1)='if _LT_DLL_DEF_P([$export_symbols]); then + cp $export_symbols $output_objdir/$soname.def; + else + echo EXPORTS > $output_objdir/$soname.def; + cat $export_symbols >> $output_objdir/$soname.def; + fi~ + $CC -shared $output_objdir/$soname.def $libobjs $deplibs $compiler_flags -o $output_objdir/$soname $wl--enable-auto-image-base -Xlinker --out-implib -Xlinker $lib' + else + _LT_TAGVAR(ld_shlibs, $1)=no + fi + ;; + + haiku*) + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' + _LT_TAGVAR(link_all_deplibs, $1)=yes + ;; + + os2*) + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir' + _LT_TAGVAR(hardcode_minus_L, $1)=yes + _LT_TAGVAR(allow_undefined_flag, $1)=unsupported + shrext_cmds=.dll + _LT_TAGVAR(archive_cmds, $1)='$ECHO "LIBRARY ${soname%$shared_ext} INITINSTANCE TERMINSTANCE" > $output_objdir/$libname.def~ + $ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~ + $ECHO "DATA MULTIPLE NONSHARED" >> $output_objdir/$libname.def~ + $ECHO EXPORTS >> $output_objdir/$libname.def~ + emxexp $libobjs | $SED /"_DLL_InitTerm"/d >> $output_objdir/$libname.def~ + $CC -Zdll -Zcrtdll -o $output_objdir/$soname $libobjs $deplibs $compiler_flags $output_objdir/$libname.def~ + emximp -o $lib $output_objdir/$libname.def' + _LT_TAGVAR(archive_expsym_cmds, $1)='$ECHO "LIBRARY ${soname%$shared_ext} INITINSTANCE TERMINSTANCE" > $output_objdir/$libname.def~ + $ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~ + $ECHO "DATA MULTIPLE NONSHARED" >> $output_objdir/$libname.def~ + $ECHO EXPORTS >> $output_objdir/$libname.def~ + prefix_cmds="$SED"~ + if test EXPORTS = "`$SED 1q $export_symbols`"; then + prefix_cmds="$prefix_cmds -e 1d"; + fi~ + prefix_cmds="$prefix_cmds -e \"s/^\(.*\)$/_\1/g\""~ + cat $export_symbols | $prefix_cmds >> $output_objdir/$libname.def~ + $CC -Zdll -Zcrtdll -o $output_objdir/$soname $libobjs $deplibs $compiler_flags $output_objdir/$libname.def~ + emximp -o $lib $output_objdir/$libname.def' + _LT_TAGVAR(old_archive_From_new_cmds, $1)='emximp -o $output_objdir/${libname}_dll.a $output_objdir/$libname.def' + _LT_TAGVAR(enable_shared_with_static_runtimes, $1)=yes + _LT_TAGVAR(file_list_spec, $1)='@' + ;; + + interix[[3-9]]*) + _LT_TAGVAR(hardcode_direct, $1)=no + _LT_TAGVAR(hardcode_shlibpath_var, $1)=no + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl-rpath,$libdir' + _LT_TAGVAR(export_dynamic_flag_spec, $1)='$wl-E' + # Hack: On Interix 3.x, we cannot compile PIC because of a broken gcc. + # Instead, shared libraries are loaded at an image base (0x10000000 by + # default) and relocated if they conflict, which is a slow very memory + # consuming and fragmenting process. To avoid this, we pick a random, + # 256 KiB-aligned image base between 0x50000000 and 0x6FFC0000 at link + # time. Moving up from 0x10000000 also allows more sbrk(2) space. + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-h,$soname $wl--image-base,`expr ${RANDOM-$$} % 4096 / 2 \* 262144 + 1342177280` -o $lib' + _LT_TAGVAR(archive_expsym_cmds, $1)='$SED "s|^|_|" $export_symbols >$output_objdir/$soname.expsym~$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-h,$soname $wl--retain-symbols-file,$output_objdir/$soname.expsym $wl--image-base,`expr ${RANDOM-$$} % 4096 / 2 \* 262144 + 1342177280` -o $lib' + ;; + + gnu* | linux* | tpf* | k*bsd*-gnu | kopensolaris*-gnu) + tmp_diet=no + if test linux-dietlibc = "$host_os"; then + case $cc_basename in + diet\ *) tmp_diet=yes;; # linux-dietlibc with static linking (!diet-dyn) + esac + fi + if $LD --help 2>&1 | $EGREP ': supported targets:.* elf' > /dev/null \ + && test no = "$tmp_diet" + then + tmp_addflag=' $pic_flag' + tmp_sharedflag='-shared' + case $cc_basename,$host_cpu in + pgcc*) # Portland Group C compiler + _LT_TAGVAR(whole_archive_flag_spec, $1)='$wl--whole-archive`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` $wl--no-whole-archive' + tmp_addflag=' $pic_flag' + ;; + pgf77* | pgf90* | pgf95* | pgfortran*) + # Portland Group f77 and f90 compilers + _LT_TAGVAR(whole_archive_flag_spec, $1)='$wl--whole-archive`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` $wl--no-whole-archive' + tmp_addflag=' $pic_flag -Mnomain' ;; + ecc*,ia64* | icc*,ia64*) # Intel C compiler on ia64 + tmp_addflag=' -i_dynamic' ;; + efc*,ia64* | ifort*,ia64*) # Intel Fortran compiler on ia64 + tmp_addflag=' -i_dynamic -nofor_main' ;; + ifc* | ifort*) # Intel Fortran compiler + tmp_addflag=' -nofor_main' ;; + lf95*) # Lahey Fortran 8.1 + _LT_TAGVAR(whole_archive_flag_spec, $1)= + tmp_sharedflag='--shared' ;; + nagfor*) # NAGFOR 5.3 + tmp_sharedflag='-Wl,-shared' ;; + xl[[cC]]* | bgxl[[cC]]* | mpixl[[cC]]*) # IBM XL C 8.0 on PPC (deal with xlf below) + tmp_sharedflag='-qmkshrobj' + tmp_addflag= ;; + nvcc*) # Cuda Compiler Driver 2.2 + _LT_TAGVAR(whole_archive_flag_spec, $1)='$wl--whole-archive`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` $wl--no-whole-archive' + _LT_TAGVAR(compiler_needs_object, $1)=yes + ;; + esac + case `$CC -V 2>&1 | $SED 5q` in + *Sun\ C*) # Sun C 5.9 + _LT_TAGVAR(whole_archive_flag_spec, $1)='$wl--whole-archive`new_convenience=; for conv in $convenience\"\"; do test -z \"$conv\" || new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` $wl--no-whole-archive' + _LT_TAGVAR(compiler_needs_object, $1)=yes + tmp_sharedflag='-G' ;; + *Sun\ F*) # Sun Fortran 8.3 + tmp_sharedflag='-G' ;; + esac + _LT_TAGVAR(archive_cmds, $1)='$CC '"$tmp_sharedflag""$tmp_addflag"' $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' + + if test yes = "$supports_anon_versioning"; then + _LT_TAGVAR(archive_expsym_cmds, $1)='echo "{ global:" > $output_objdir/$libname.ver~ + cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $output_objdir/$libname.ver~ + echo "local: *; };" >> $output_objdir/$libname.ver~ + $CC '"$tmp_sharedflag""$tmp_addflag"' $libobjs $deplibs $compiler_flags $wl-soname $wl$soname $wl-version-script $wl$output_objdir/$libname.ver -o $lib' + fi + + case $cc_basename in + tcc*) + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl-rpath $wl$libdir' + _LT_TAGVAR(export_dynamic_flag_spec, $1)='-rdynamic' + ;; + xlf* | bgf* | bgxlf* | mpixlf*) + # IBM XL Fortran 10.1 on PPC cannot create shared libs itself + _LT_TAGVAR(whole_archive_flag_spec, $1)='--whole-archive$convenience --no-whole-archive' + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl-rpath $wl$libdir' + _LT_TAGVAR(archive_cmds, $1)='$LD -shared $libobjs $deplibs $linker_flags -soname $soname -o $lib' + if test yes = "$supports_anon_versioning"; then + _LT_TAGVAR(archive_expsym_cmds, $1)='echo "{ global:" > $output_objdir/$libname.ver~ + cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $output_objdir/$libname.ver~ + echo "local: *; };" >> $output_objdir/$libname.ver~ + $LD -shared $libobjs $deplibs $linker_flags -soname $soname -version-script $output_objdir/$libname.ver -o $lib' + fi + ;; + esac + else + _LT_TAGVAR(ld_shlibs, $1)=no + fi + ;; + + netbsd* | netbsdelf*-gnu) + if echo __ELF__ | $CC -E - | $GREP __ELF__ >/dev/null; then + _LT_TAGVAR(archive_cmds, $1)='$LD -Bshareable $libobjs $deplibs $linker_flags -o $lib' + wlarc= + else + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' + _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname $wl-retain-symbols-file $wl$export_symbols -o $lib' + fi + ;; + + solaris*) + if $LD -v 2>&1 | $GREP 'BFD 2\.8' > /dev/null; then + _LT_TAGVAR(ld_shlibs, $1)=no + cat <<_LT_EOF 1>&2 + +*** Warning: The releases 2.8.* of the GNU linker cannot reliably +*** create shared libraries on Solaris systems. Therefore, libtool +*** is disabling shared libraries support. We urge you to upgrade GNU +*** binutils to release 2.9.1 or newer. Another option is to modify +*** your PATH or compiler configuration so that the native linker is +*** used, and then restart. + +_LT_EOF + elif $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' + _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname $wl-retain-symbols-file $wl$export_symbols -o $lib' + else + _LT_TAGVAR(ld_shlibs, $1)=no + fi + ;; + + sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX*) + case `$LD -v 2>&1` in + *\ [[01]].* | *\ 2.[[0-9]].* | *\ 2.1[[0-5]].*) + _LT_TAGVAR(ld_shlibs, $1)=no + cat <<_LT_EOF 1>&2 + +*** Warning: Releases of the GNU linker prior to 2.16.91.0.3 cannot +*** reliably create shared libraries on SCO systems. Therefore, libtool +*** is disabling shared libraries support. We urge you to upgrade GNU +*** binutils to release 2.16.91.0.3 or newer. Another option is to modify +*** your PATH or compiler configuration so that the native linker is +*** used, and then restart. + +_LT_EOF + ;; + *) + # For security reasons, it is highly recommended that you always + # use absolute paths for naming shared libraries, and exclude the + # DT_RUNPATH tag from executables and libraries. But doing so + # requires that you compile everything twice, which is a pain. + if $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl-rpath $wl$libdir' + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' + _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags $wl-soname $wl$soname $wl-retain-symbols-file $wl$export_symbols -o $lib' + else + _LT_TAGVAR(ld_shlibs, $1)=no + fi + ;; + esac + ;; + + sunos4*) + _LT_TAGVAR(archive_cmds, $1)='$LD -assert pure-text -Bshareable -o $lib $libobjs $deplibs $linker_flags' + wlarc= + _LT_TAGVAR(hardcode_direct, $1)=yes + _LT_TAGVAR(hardcode_shlibpath_var, $1)=no + ;; + + *) + if $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' + _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname $wl-retain-symbols-file $wl$export_symbols -o $lib' + else + _LT_TAGVAR(ld_shlibs, $1)=no + fi + ;; + esac + + if test no = "$_LT_TAGVAR(ld_shlibs, $1)"; then + runpath_var= + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)= + _LT_TAGVAR(export_dynamic_flag_spec, $1)= + _LT_TAGVAR(whole_archive_flag_spec, $1)= + fi + else + # PORTME fill in a description of your system's linker (not GNU ld) + case $host_os in + aix3*) + _LT_TAGVAR(allow_undefined_flag, $1)=unsupported + _LT_TAGVAR(always_export_symbols, $1)=yes + _LT_TAGVAR(archive_expsym_cmds, $1)='$LD -o $output_objdir/$soname $libobjs $deplibs $linker_flags -bE:$export_symbols -T512 -H512 -bM:SRE~$AR $AR_FLAGS $lib $output_objdir/$soname' + # Note: this linker hardcodes the directories in LIBPATH if there + # are no directories specified by -L. + _LT_TAGVAR(hardcode_minus_L, $1)=yes + if test yes = "$GCC" && test -z "$lt_prog_compiler_static"; then + # Neither direct hardcoding nor static linking is supported with a + # broken collect2. + _LT_TAGVAR(hardcode_direct, $1)=unsupported + fi + ;; + + aix[[4-9]]*) + if test ia64 = "$host_cpu"; then + # On IA64, the linker does run time linking by default, so we don't + # have to do anything special. + aix_use_runtimelinking=no + exp_sym_flag='-Bexport' + no_entry_flag= + else + # If we're using GNU nm, then we don't want the "-C" option. + # -C means demangle to GNU nm, but means don't demangle to AIX nm. + # Without the "-l" option, or with the "-B" option, AIX nm treats + # weak defined symbols like other global defined symbols, whereas + # GNU nm marks them as "W". + # While the 'weak' keyword is ignored in the Export File, we need + # it in the Import File for the 'aix-soname' feature, so we have + # to replace the "-B" option with "-P" for AIX nm. + if $NM -V 2>&1 | $GREP 'GNU' > /dev/null; then + _LT_TAGVAR(export_symbols_cmds, $1)='$NM -Bpg $libobjs $convenience | awk '\''{ if (((\$ 2 == "T") || (\$ 2 == "D") || (\$ 2 == "B") || (\$ 2 == "W")) && ([substr](\$ 3,1,1) != ".")) { if (\$ 2 == "W") { print \$ 3 " weak" } else { print \$ 3 } } }'\'' | sort -u > $export_symbols' + else + _LT_TAGVAR(export_symbols_cmds, $1)='`func_echo_all $NM | $SED -e '\''s/B\([[^B]]*\)$/P\1/'\''` -PCpgl $libobjs $convenience | awk '\''{ if (((\$ 2 == "T") || (\$ 2 == "D") || (\$ 2 == "B") || (\$ 2 == "L") || (\$ 2 == "W") || (\$ 2 == "V") || (\$ 2 == "Z")) && ([substr](\$ 1,1,1) != ".")) { if ((\$ 2 == "W") || (\$ 2 == "V") || (\$ 2 == "Z")) { print \$ 1 " weak" } else { print \$ 1 } } }'\'' | sort -u > $export_symbols' + fi + aix_use_runtimelinking=no + + # Test if we are trying to use run time linking or normal + # AIX style linking. If -brtl is somewhere in LDFLAGS, we + # have runtime linking enabled, and use it for executables. + # For shared libraries, we enable/disable runtime linking + # depending on the kind of the shared library created - + # when "with_aix_soname,aix_use_runtimelinking" is: + # "aix,no" lib.a(lib.so.V) shared, rtl:no, for executables + # "aix,yes" lib.so shared, rtl:yes, for executables + # lib.a static archive + # "both,no" lib.so.V(shr.o) shared, rtl:yes + # lib.a(lib.so.V) shared, rtl:no, for executables + # "both,yes" lib.so.V(shr.o) shared, rtl:yes, for executables + # lib.a(lib.so.V) shared, rtl:no + # "svr4,*" lib.so.V(shr.o) shared, rtl:yes, for executables + # lib.a static archive + case $host_os in aix4.[[23]]|aix4.[[23]].*|aix[[5-9]]*) + for ld_flag in $LDFLAGS; do + if (test x-brtl = "x$ld_flag" || test x-Wl,-brtl = "x$ld_flag"); then + aix_use_runtimelinking=yes + break + fi + done + if test svr4,no = "$with_aix_soname,$aix_use_runtimelinking"; then + # With aix-soname=svr4, we create the lib.so.V shared archives only, + # so we don't have lib.a shared libs to link our executables. + # We have to force runtime linking in this case. + aix_use_runtimelinking=yes + LDFLAGS="$LDFLAGS -Wl,-brtl" + fi + ;; + esac + + exp_sym_flag='-bexport' + no_entry_flag='-bnoentry' + fi + + # When large executables or shared objects are built, AIX ld can + # have problems creating the table of contents. If linking a library + # or program results in "error TOC overflow" add -mminimal-toc to + # CXXFLAGS/CFLAGS for g++/gcc. In the cases where that is not + # enough to fix the problem, add -Wl,-bbigtoc to LDFLAGS. + + _LT_TAGVAR(archive_cmds, $1)='' + _LT_TAGVAR(hardcode_direct, $1)=yes + _LT_TAGVAR(hardcode_direct_absolute, $1)=yes + _LT_TAGVAR(hardcode_libdir_separator, $1)=':' + _LT_TAGVAR(link_all_deplibs, $1)=yes + _LT_TAGVAR(file_list_spec, $1)='$wl-f,' + case $with_aix_soname,$aix_use_runtimelinking in + aix,*) ;; # traditional, no import file + svr4,* | *,yes) # use import file + # The Import File defines what to hardcode. + _LT_TAGVAR(hardcode_direct, $1)=no + _LT_TAGVAR(hardcode_direct_absolute, $1)=no + ;; + esac + + if test yes = "$GCC"; then + case $host_os in aix4.[[012]]|aix4.[[012]].*) + # We only want to do this on AIX 4.2 and lower, the check + # below for broken collect2 doesn't work under 4.3+ + collect2name=`$CC -print-prog-name=collect2` + if test -f "$collect2name" && + strings "$collect2name" | $GREP resolve_lib_name >/dev/null + then + # We have reworked collect2 + : + else + # We have old collect2 + _LT_TAGVAR(hardcode_direct, $1)=unsupported + # It fails to find uninstalled libraries when the uninstalled + # path is not listed in the libpath. Setting hardcode_minus_L + # to unsupported forces relinking + _LT_TAGVAR(hardcode_minus_L, $1)=yes + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir' + _LT_TAGVAR(hardcode_libdir_separator, $1)= + fi + ;; + esac + shared_flag='-shared' + if test yes = "$aix_use_runtimelinking"; then + shared_flag="$shared_flag "'$wl-G' + fi + # Need to ensure runtime linking is disabled for the traditional + # shared library, or the linker may eventually find shared libraries + # /with/ Import File - we do not want to mix them. + shared_flag_aix='-shared' + shared_flag_svr4='-shared $wl-G' + else + # not using gcc + if test ia64 = "$host_cpu"; then + # VisualAge C++, Version 5.5 for AIX 5L for IA-64, Beta 3 Release + # chokes on -Wl,-G. The following line is correct: + shared_flag='-G' + else + if test yes = "$aix_use_runtimelinking"; then + shared_flag='$wl-G' + else + shared_flag='$wl-bM:SRE' + fi + shared_flag_aix='$wl-bM:SRE' + shared_flag_svr4='$wl-G' + fi + fi + + _LT_TAGVAR(export_dynamic_flag_spec, $1)='$wl-bexpall' + # It seems that -bexpall does not export symbols beginning with + # underscore (_), so it is better to generate a list of symbols to export. + _LT_TAGVAR(always_export_symbols, $1)=yes + if test aix,yes = "$with_aix_soname,$aix_use_runtimelinking"; then + # Warning - without using the other runtime loading flags (-brtl), + # -berok will link without error, but may produce a broken library. + _LT_TAGVAR(allow_undefined_flag, $1)='-berok' + # Determine the default libpath from the value encoded in an + # empty executable. + _LT_SYS_MODULE_PATH_AIX([$1]) + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl-blibpath:$libdir:'"$aix_libpath" + _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -o $output_objdir/$soname $libobjs $deplibs $wl'$no_entry_flag' $compiler_flags `if test -n "$allow_undefined_flag"; then func_echo_all "$wl$allow_undefined_flag"; else :; fi` $wl'$exp_sym_flag:\$export_symbols' '$shared_flag + else + if test ia64 = "$host_cpu"; then + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl-R $libdir:/usr/lib:/lib' + _LT_TAGVAR(allow_undefined_flag, $1)="-z nodefs" + _LT_TAGVAR(archive_expsym_cmds, $1)="\$CC $shared_flag"' -o $output_objdir/$soname $libobjs $deplibs '"\$wl$no_entry_flag"' $compiler_flags $wl$allow_undefined_flag '"\$wl$exp_sym_flag:\$export_symbols" + else + # Determine the default libpath from the value encoded in an + # empty executable. + _LT_SYS_MODULE_PATH_AIX([$1]) + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl-blibpath:$libdir:'"$aix_libpath" + # Warning - without using the other run time loading flags, + # -berok will link without error, but may produce a broken library. + _LT_TAGVAR(no_undefined_flag, $1)=' $wl-bernotok' + _LT_TAGVAR(allow_undefined_flag, $1)=' $wl-berok' + if test yes = "$with_gnu_ld"; then + # We only use this code for GNU lds that support --whole-archive. + _LT_TAGVAR(whole_archive_flag_spec, $1)='$wl--whole-archive$convenience $wl--no-whole-archive' + else + # Exported symbols can be pulled into shared objects from archives + _LT_TAGVAR(whole_archive_flag_spec, $1)='$convenience' + fi + _LT_TAGVAR(archive_cmds_need_lc, $1)=yes + _LT_TAGVAR(archive_expsym_cmds, $1)='$RM -r $output_objdir/$realname.d~$MKDIR $output_objdir/$realname.d' + # -brtl affects multiple linker settings, -berok does not and is overridden later + compiler_flags_filtered='`func_echo_all "$compiler_flags " | $SED -e "s%-brtl\\([[, ]]\\)%-berok\\1%g"`' + if test svr4 != "$with_aix_soname"; then + # This is similar to how AIX traditionally builds its shared libraries. + _LT_TAGVAR(archive_expsym_cmds, $1)="$_LT_TAGVAR(archive_expsym_cmds, $1)"'~$CC '$shared_flag_aix' -o $output_objdir/$realname.d/$soname $libobjs $deplibs $wl-bnoentry '$compiler_flags_filtered'$wl-bE:$export_symbols$allow_undefined_flag~$AR $AR_FLAGS $output_objdir/$libname$release.a $output_objdir/$realname.d/$soname' + fi + if test aix != "$with_aix_soname"; then + _LT_TAGVAR(archive_expsym_cmds, $1)="$_LT_TAGVAR(archive_expsym_cmds, $1)"'~$CC '$shared_flag_svr4' -o $output_objdir/$realname.d/$shared_archive_member_spec.o $libobjs $deplibs $wl-bnoentry '$compiler_flags_filtered'$wl-bE:$export_symbols$allow_undefined_flag~$STRIP -e $output_objdir/$realname.d/$shared_archive_member_spec.o~( func_echo_all "#! $soname($shared_archive_member_spec.o)"; if test shr_64 = "$shared_archive_member_spec"; then func_echo_all "# 64"; else func_echo_all "# 32"; fi; cat $export_symbols ) > $output_objdir/$realname.d/$shared_archive_member_spec.imp~$AR $AR_FLAGS $output_objdir/$soname $output_objdir/$realname.d/$shared_archive_member_spec.o $output_objdir/$realname.d/$shared_archive_member_spec.imp' + else + # used by -dlpreopen to get the symbols + _LT_TAGVAR(archive_expsym_cmds, $1)="$_LT_TAGVAR(archive_expsym_cmds, $1)"'~$MV $output_objdir/$realname.d/$soname $output_objdir' + fi + _LT_TAGVAR(archive_expsym_cmds, $1)="$_LT_TAGVAR(archive_expsym_cmds, $1)"'~$RM -r $output_objdir/$realname.d' + fi + fi + ;; + + amigaos*) + case $host_cpu in + powerpc) + # see comment about AmigaOS4 .so support + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' + _LT_TAGVAR(archive_expsym_cmds, $1)='' + ;; + m68k) + _LT_TAGVAR(archive_cmds, $1)='$RM $output_objdir/a2ixlibrary.data~$ECHO "#define NAME $libname" > $output_objdir/a2ixlibrary.data~$ECHO "#define LIBRARY_ID 1" >> $output_objdir/a2ixlibrary.data~$ECHO "#define VERSION $major" >> $output_objdir/a2ixlibrary.data~$ECHO "#define REVISION $revision" >> $output_objdir/a2ixlibrary.data~$AR $AR_FLAGS $lib $libobjs~$RANLIB $lib~(cd $output_objdir && a2ixlibrary -32)' + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir' + _LT_TAGVAR(hardcode_minus_L, $1)=yes + ;; + esac + ;; + + bsdi[[45]]*) + _LT_TAGVAR(export_dynamic_flag_spec, $1)=-rdynamic + ;; + + cygwin* | mingw* | pw32* | cegcc*) + # When not using gcc, we currently assume that we are using + # Microsoft Visual C++ or Intel C++ Compiler. + # hardcode_libdir_flag_spec is actually meaningless, as there is + # no search path for DLLs. + case $cc_basename in + cl* | icl*) + # Native MSVC or ICC + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)=' ' + _LT_TAGVAR(allow_undefined_flag, $1)=unsupported + _LT_TAGVAR(always_export_symbols, $1)=yes + _LT_TAGVAR(file_list_spec, $1)='@' + # Tell ltmain to make .lib files, not .a files. + libext=lib + # Tell ltmain to make .dll files, not .so files. + shrext_cmds=.dll + # FIXME: Setting linknames here is a bad hack. + _LT_TAGVAR(archive_cmds, $1)='$CC -o $output_objdir/$soname $libobjs $compiler_flags $deplibs -Wl,-DLL,-IMPLIB:"$tool_output_objdir$libname.dll.lib"~linknames=' + _LT_TAGVAR(archive_expsym_cmds, $1)='if _LT_DLL_DEF_P([$export_symbols]); then + cp "$export_symbols" "$output_objdir/$soname.def"; + echo "$tool_output_objdir$soname.def" > "$output_objdir/$soname.exp"; + else + $SED -e '\''s/^/-link -EXPORT:/'\'' < $export_symbols > $output_objdir/$soname.exp; + fi~ + $CC -o $tool_output_objdir$soname $libobjs $compiler_flags $deplibs "@$tool_output_objdir$soname.exp" -Wl,-DLL,-IMPLIB:"$tool_output_objdir$libname.dll.lib"~ + linknames=' + # The linker will not automatically build a static lib if we build a DLL. + # _LT_TAGVAR(old_archive_from_new_cmds, $1)='true' + _LT_TAGVAR(enable_shared_with_static_runtimes, $1)=yes + _LT_TAGVAR(exclude_expsyms, $1)='_NULL_IMPORT_DESCRIPTOR|_IMPORT_DESCRIPTOR_.*' + _LT_TAGVAR(export_symbols_cmds, $1)='$NM $libobjs $convenience | $global_symbol_pipe | $SED -e '\''/^[[BCDGRS]][[ ]]/s/.*[[ ]]\([[^ ]]*\)/\1,DATA/'\'' | $SED -e '\''/^[[AITW]][[ ]]/s/.*[[ ]]//'\'' | sort | uniq > $export_symbols' + # Don't use ranlib + _LT_TAGVAR(old_postinstall_cmds, $1)='chmod 644 $oldlib' + _LT_TAGVAR(postlink_cmds, $1)='lt_outputfile="@OUTPUT@"~ + lt_tool_outputfile="@TOOL_OUTPUT@"~ + case $lt_outputfile in + *.exe|*.EXE) ;; + *) + lt_outputfile=$lt_outputfile.exe + lt_tool_outputfile=$lt_tool_outputfile.exe + ;; + esac~ + if test : != "$MANIFEST_TOOL" && test -f "$lt_outputfile.manifest"; then + $MANIFEST_TOOL -manifest "$lt_tool_outputfile.manifest" -outputresource:"$lt_tool_outputfile" || exit 1; + $RM "$lt_outputfile.manifest"; + fi' + ;; + *) + # Assume MSVC and ICC wrapper + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)=' ' + _LT_TAGVAR(allow_undefined_flag, $1)=unsupported + # Tell ltmain to make .lib files, not .a files. + libext=lib + # Tell ltmain to make .dll files, not .so files. + shrext_cmds=.dll + # FIXME: Setting linknames here is a bad hack. + _LT_TAGVAR(archive_cmds, $1)='$CC -o $lib $libobjs $compiler_flags `func_echo_all "$deplibs" | $SED '\''s/ -lc$//'\''` -link -dll~linknames=' + # The linker will automatically build a .lib file if we build a DLL. + _LT_TAGVAR(old_archive_from_new_cmds, $1)='true' + # FIXME: Should let the user specify the lib program. + _LT_TAGVAR(old_archive_cmds, $1)='lib -OUT:$oldlib$oldobjs$old_deplibs' + _LT_TAGVAR(enable_shared_with_static_runtimes, $1)=yes + ;; + esac + ;; + + darwin* | rhapsody*) + _LT_DARWIN_LINKER_FEATURES($1) + ;; + + dgux*) + _LT_TAGVAR(archive_cmds, $1)='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir' + _LT_TAGVAR(hardcode_shlibpath_var, $1)=no + ;; + + # FreeBSD 2.2.[012] allows us to include c++rt0.o to get C++ constructor + # support. Future versions do this automatically, but an explicit c++rt0.o + # does not break anything, and helps significantly (at the cost of a little + # extra space). + freebsd2.2*) + _LT_TAGVAR(archive_cmds, $1)='$LD -Bshareable -o $lib $libobjs $deplibs $linker_flags /usr/lib/c++rt0.o' + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-R$libdir' + _LT_TAGVAR(hardcode_direct, $1)=yes + _LT_TAGVAR(hardcode_shlibpath_var, $1)=no + ;; + + # Unfortunately, older versions of FreeBSD 2 do not have this feature. + freebsd2.*) + _LT_TAGVAR(archive_cmds, $1)='$LD -Bshareable -o $lib $libobjs $deplibs $linker_flags' + _LT_TAGVAR(hardcode_direct, $1)=yes + _LT_TAGVAR(hardcode_minus_L, $1)=yes + _LT_TAGVAR(hardcode_shlibpath_var, $1)=no + ;; + + # FreeBSD 3 and greater uses gcc -shared to do shared libraries. + freebsd* | dragonfly* | midnightbsd*) + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags' + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-R$libdir' + _LT_TAGVAR(hardcode_direct, $1)=yes + _LT_TAGVAR(hardcode_shlibpath_var, $1)=no + ;; + + hpux9*) + if test yes = "$GCC"; then + _LT_TAGVAR(archive_cmds, $1)='$RM $output_objdir/$soname~$CC -shared $pic_flag $wl+b $wl$install_libdir -o $output_objdir/$soname $libobjs $deplibs $compiler_flags~test "x$output_objdir/$soname" = "x$lib" || mv $output_objdir/$soname $lib' + else + _LT_TAGVAR(archive_cmds, $1)='$RM $output_objdir/$soname~$LD -b +b $install_libdir -o $output_objdir/$soname $libobjs $deplibs $linker_flags~test "x$output_objdir/$soname" = "x$lib" || mv $output_objdir/$soname $lib' + fi + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl+b $wl$libdir' + _LT_TAGVAR(hardcode_libdir_separator, $1)=: + _LT_TAGVAR(hardcode_direct, $1)=yes + + # hardcode_minus_L: Not really in the search PATH, + # but as the default location of the library. + _LT_TAGVAR(hardcode_minus_L, $1)=yes + _LT_TAGVAR(export_dynamic_flag_spec, $1)='$wl-E' + ;; + + hpux10*) + if test yes,no = "$GCC,$with_gnu_ld"; then + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag $wl+h $wl$soname $wl+b $wl$install_libdir -o $lib $libobjs $deplibs $compiler_flags' + else + _LT_TAGVAR(archive_cmds, $1)='$LD -b +h $soname +b $install_libdir -o $lib $libobjs $deplibs $linker_flags' + fi + if test no = "$with_gnu_ld"; then + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl+b $wl$libdir' + _LT_TAGVAR(hardcode_libdir_separator, $1)=: + _LT_TAGVAR(hardcode_direct, $1)=yes + _LT_TAGVAR(hardcode_direct_absolute, $1)=yes + _LT_TAGVAR(export_dynamic_flag_spec, $1)='$wl-E' + # hardcode_minus_L: Not really in the search PATH, + # but as the default location of the library. + _LT_TAGVAR(hardcode_minus_L, $1)=yes + fi + ;; + + hpux11*) + if test yes,no = "$GCC,$with_gnu_ld"; then + case $host_cpu in + hppa*64*) + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $wl+h $wl$soname -o $lib $libobjs $deplibs $compiler_flags' + ;; + ia64*) + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag $wl+h $wl$soname $wl+nodefaultrpath -o $lib $libobjs $deplibs $compiler_flags' + ;; + *) + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag $wl+h $wl$soname $wl+b $wl$install_libdir -o $lib $libobjs $deplibs $compiler_flags' + ;; + esac + else + case $host_cpu in + hppa*64*) + _LT_TAGVAR(archive_cmds, $1)='$CC -b $wl+h $wl$soname -o $lib $libobjs $deplibs $compiler_flags' + ;; + ia64*) + _LT_TAGVAR(archive_cmds, $1)='$CC -b $wl+h $wl$soname $wl+nodefaultrpath -o $lib $libobjs $deplibs $compiler_flags' + ;; + *) + m4_if($1, [], [ + # Older versions of the 11.00 compiler do not understand -b yet + # (HP92453-01 A.11.01.20 doesn't, HP92453-01 B.11.X.35175-35176.GP does) + _LT_LINKER_OPTION([if $CC understands -b], + _LT_TAGVAR(lt_cv_prog_compiler__b, $1), [-b], + [_LT_TAGVAR(archive_cmds, $1)='$CC -b $wl+h $wl$soname $wl+b $wl$install_libdir -o $lib $libobjs $deplibs $compiler_flags'], + [_LT_TAGVAR(archive_cmds, $1)='$LD -b +h $soname +b $install_libdir -o $lib $libobjs $deplibs $linker_flags'])], + [_LT_TAGVAR(archive_cmds, $1)='$CC -b $wl+h $wl$soname $wl+b $wl$install_libdir -o $lib $libobjs $deplibs $compiler_flags']) + ;; + esac + fi + if test no = "$with_gnu_ld"; then + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl+b $wl$libdir' + _LT_TAGVAR(hardcode_libdir_separator, $1)=: + + case $host_cpu in + hppa*64*|ia64*) + _LT_TAGVAR(hardcode_direct, $1)=no + _LT_TAGVAR(hardcode_shlibpath_var, $1)=no + ;; + *) + _LT_TAGVAR(hardcode_direct, $1)=yes + _LT_TAGVAR(hardcode_direct_absolute, $1)=yes + _LT_TAGVAR(export_dynamic_flag_spec, $1)='$wl-E' + + # hardcode_minus_L: Not really in the search PATH, + # but as the default location of the library. + _LT_TAGVAR(hardcode_minus_L, $1)=yes + ;; + esac + fi + ;; + + irix5* | irix6* | nonstopux*) + if test yes = "$GCC"; then + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` $wl-update_registry $wl$output_objdir/so_locations -o $lib' + # Try to use the -exported_symbol ld option, if it does not + # work, assume that -exports_file does not work either and + # implicitly export all symbols. + # This should be the same for all languages, so no per-tag cache variable. + AC_CACHE_CHECK([whether the $host_os linker accepts -exported_symbol], + [lt_cv_irix_exported_symbol], + [save_LDFLAGS=$LDFLAGS + LDFLAGS="$LDFLAGS -shared $wl-exported_symbol ${wl}foo $wl-update_registry $wl/dev/null" + AC_LINK_IFELSE( + [AC_LANG_SOURCE( + [AC_LANG_CASE([C], [[int foo (void) { return 0; }]], + [C++], [[int foo (void) { return 0; }]], + [Fortran 77], [[ + subroutine foo + end]], + [Fortran], [[ + subroutine foo + end]])])], + [lt_cv_irix_exported_symbol=yes], + [lt_cv_irix_exported_symbol=no]) + LDFLAGS=$save_LDFLAGS]) + if test yes = "$lt_cv_irix_exported_symbol"; then + _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` $wl-update_registry $wl$output_objdir/so_locations $wl-exports_file $wl$export_symbols -o $lib' + fi + _LT_TAGVAR(link_all_deplibs, $1)=no + else + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry $output_objdir/so_locations -o $lib' + _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry $output_objdir/so_locations -exports_file $export_symbols -o $lib' + fi + _LT_TAGVAR(archive_cmds_need_lc, $1)='no' + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl-rpath $wl$libdir' + _LT_TAGVAR(hardcode_libdir_separator, $1)=: + _LT_TAGVAR(inherit_rpath, $1)=yes + _LT_TAGVAR(link_all_deplibs, $1)=yes + ;; + + linux*) + case $cc_basename in + tcc*) + # Fabrice Bellard et al's Tiny C Compiler + _LT_TAGVAR(ld_shlibs, $1)=yes + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags' + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl-rpath $wl$libdir' + ;; + esac + ;; + + netbsd* | netbsdelf*-gnu) + if echo __ELF__ | $CC -E - | $GREP __ELF__ >/dev/null; then + _LT_TAGVAR(archive_cmds, $1)='$LD -Bshareable -o $lib $libobjs $deplibs $linker_flags' # a.out + else + _LT_TAGVAR(archive_cmds, $1)='$LD -shared -o $lib $libobjs $deplibs $linker_flags' # ELF + fi + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-R$libdir' + _LT_TAGVAR(hardcode_direct, $1)=yes + _LT_TAGVAR(hardcode_shlibpath_var, $1)=no + ;; + + newsos6) + _LT_TAGVAR(archive_cmds, $1)='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' + _LT_TAGVAR(hardcode_direct, $1)=yes + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl-rpath $wl$libdir' + _LT_TAGVAR(hardcode_libdir_separator, $1)=: + _LT_TAGVAR(hardcode_shlibpath_var, $1)=no + ;; + + *nto* | *qnx*) + ;; + + openbsd* | bitrig*) + if test -f /usr/libexec/ld.so; then + _LT_TAGVAR(hardcode_direct, $1)=yes + _LT_TAGVAR(hardcode_shlibpath_var, $1)=no + _LT_TAGVAR(hardcode_direct_absolute, $1)=yes + if test -z "`echo __ELF__ | $CC -E - | $GREP __ELF__`"; then + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags' + _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags $wl-retain-symbols-file,$export_symbols' + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl-rpath,$libdir' + _LT_TAGVAR(export_dynamic_flag_spec, $1)='$wl-E' + else + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags' + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl-rpath,$libdir' + fi + else + _LT_TAGVAR(ld_shlibs, $1)=no + fi + ;; + + os2*) + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir' + _LT_TAGVAR(hardcode_minus_L, $1)=yes + _LT_TAGVAR(allow_undefined_flag, $1)=unsupported + shrext_cmds=.dll + _LT_TAGVAR(archive_cmds, $1)='$ECHO "LIBRARY ${soname%$shared_ext} INITINSTANCE TERMINSTANCE" > $output_objdir/$libname.def~ + $ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~ + $ECHO "DATA MULTIPLE NONSHARED" >> $output_objdir/$libname.def~ + $ECHO EXPORTS >> $output_objdir/$libname.def~ + emxexp $libobjs | $SED /"_DLL_InitTerm"/d >> $output_objdir/$libname.def~ + $CC -Zdll -Zcrtdll -o $output_objdir/$soname $libobjs $deplibs $compiler_flags $output_objdir/$libname.def~ + emximp -o $lib $output_objdir/$libname.def' + _LT_TAGVAR(archive_expsym_cmds, $1)='$ECHO "LIBRARY ${soname%$shared_ext} INITINSTANCE TERMINSTANCE" > $output_objdir/$libname.def~ + $ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~ + $ECHO "DATA MULTIPLE NONSHARED" >> $output_objdir/$libname.def~ + $ECHO EXPORTS >> $output_objdir/$libname.def~ + prefix_cmds="$SED"~ + if test EXPORTS = "`$SED 1q $export_symbols`"; then + prefix_cmds="$prefix_cmds -e 1d"; + fi~ + prefix_cmds="$prefix_cmds -e \"s/^\(.*\)$/_\1/g\""~ + cat $export_symbols | $prefix_cmds >> $output_objdir/$libname.def~ + $CC -Zdll -Zcrtdll -o $output_objdir/$soname $libobjs $deplibs $compiler_flags $output_objdir/$libname.def~ + emximp -o $lib $output_objdir/$libname.def' + _LT_TAGVAR(old_archive_From_new_cmds, $1)='emximp -o $output_objdir/${libname}_dll.a $output_objdir/$libname.def' + _LT_TAGVAR(enable_shared_with_static_runtimes, $1)=yes + _LT_TAGVAR(file_list_spec, $1)='@' + ;; + + osf3*) + if test yes = "$GCC"; then + _LT_TAGVAR(allow_undefined_flag, $1)=' $wl-expect_unresolved $wl\*' + _LT_TAGVAR(archive_cmds, $1)='$CC -shared$allow_undefined_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` $wl-update_registry $wl$output_objdir/so_locations -o $lib' + else + _LT_TAGVAR(allow_undefined_flag, $1)=' -expect_unresolved \*' + _LT_TAGVAR(archive_cmds, $1)='$CC -shared$allow_undefined_flag $libobjs $deplibs $compiler_flags -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry $output_objdir/so_locations -o $lib' + fi + _LT_TAGVAR(archive_cmds_need_lc, $1)='no' + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl-rpath $wl$libdir' + _LT_TAGVAR(hardcode_libdir_separator, $1)=: + ;; + + osf4* | osf5*) # as osf3* with the addition of -msym flag + if test yes = "$GCC"; then + _LT_TAGVAR(allow_undefined_flag, $1)=' $wl-expect_unresolved $wl\*' + _LT_TAGVAR(archive_cmds, $1)='$CC -shared$allow_undefined_flag $pic_flag $libobjs $deplibs $compiler_flags $wl-msym $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` $wl-update_registry $wl$output_objdir/so_locations -o $lib' + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl-rpath $wl$libdir' + else + _LT_TAGVAR(allow_undefined_flag, $1)=' -expect_unresolved \*' + _LT_TAGVAR(archive_cmds, $1)='$CC -shared$allow_undefined_flag $libobjs $deplibs $compiler_flags -msym -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry $output_objdir/so_locations -o $lib' + _LT_TAGVAR(archive_expsym_cmds, $1)='for i in `cat $export_symbols`; do printf "%s %s\\n" -exported_symbol "\$i" >> $lib.exp; done; printf "%s\\n" "-hidden">> $lib.exp~ + $CC -shared$allow_undefined_flag $wl-input $wl$lib.exp $compiler_flags $libobjs $deplibs -soname $soname `test -n "$verstring" && $ECHO "-set_version $verstring"` -update_registry $output_objdir/so_locations -o $lib~$RM $lib.exp' + + # Both c and cxx compiler support -rpath directly + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-rpath $libdir' + fi + _LT_TAGVAR(archive_cmds_need_lc, $1)='no' + _LT_TAGVAR(hardcode_libdir_separator, $1)=: + ;; + + solaris*) + _LT_TAGVAR(no_undefined_flag, $1)=' -z defs' + if test yes = "$GCC"; then + wlarc='$wl' + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag $wl-z ${wl}text $wl-h $wl$soname -o $lib $libobjs $deplibs $compiler_flags' + _LT_TAGVAR(archive_expsym_cmds, $1)='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~ + $CC -shared $pic_flag $wl-z ${wl}text $wl-M $wl$lib.exp $wl-h $wl$soname -o $lib $libobjs $deplibs $compiler_flags~$RM $lib.exp' + else + case `$CC -V 2>&1` in + *"Compilers 5.0"*) + wlarc='' + _LT_TAGVAR(archive_cmds, $1)='$LD -G$allow_undefined_flag -h $soname -o $lib $libobjs $deplibs $linker_flags' + _LT_TAGVAR(archive_expsym_cmds, $1)='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~ + $LD -G$allow_undefined_flag -M $lib.exp -h $soname -o $lib $libobjs $deplibs $linker_flags~$RM $lib.exp' + ;; + *) + wlarc='$wl' + _LT_TAGVAR(archive_cmds, $1)='$CC -G$allow_undefined_flag -h $soname -o $lib $libobjs $deplibs $compiler_flags' + _LT_TAGVAR(archive_expsym_cmds, $1)='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~ + $CC -G$allow_undefined_flag -M $lib.exp -h $soname -o $lib $libobjs $deplibs $compiler_flags~$RM $lib.exp' + ;; + esac + fi + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-R$libdir' + _LT_TAGVAR(hardcode_shlibpath_var, $1)=no + case $host_os in + solaris2.[[0-5]] | solaris2.[[0-5]].*) ;; + *) + # The compiler driver will combine and reorder linker options, + # but understands '-z linker_flag'. GCC discards it without '$wl', + # but is careful enough not to reorder. + # Supported since Solaris 2.6 (maybe 2.5.1?) + if test yes = "$GCC"; then + _LT_TAGVAR(whole_archive_flag_spec, $1)='$wl-z ${wl}allextract$convenience $wl-z ${wl}defaultextract' + else + _LT_TAGVAR(whole_archive_flag_spec, $1)='-z allextract$convenience -z defaultextract' + fi + ;; + esac + _LT_TAGVAR(link_all_deplibs, $1)=yes + ;; + + sunos4*) + if test sequent = "$host_vendor"; then + # Use $CC to link under sequent, because it throws in some extra .o + # files that make .init and .fini sections work. + _LT_TAGVAR(archive_cmds, $1)='$CC -G $wl-h $soname -o $lib $libobjs $deplibs $compiler_flags' + else + _LT_TAGVAR(archive_cmds, $1)='$LD -assert pure-text -Bstatic -o $lib $libobjs $deplibs $linker_flags' + fi + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir' + _LT_TAGVAR(hardcode_direct, $1)=yes + _LT_TAGVAR(hardcode_minus_L, $1)=yes + _LT_TAGVAR(hardcode_shlibpath_var, $1)=no + ;; + + sysv4) + case $host_vendor in + sni) + _LT_TAGVAR(archive_cmds, $1)='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' + _LT_TAGVAR(hardcode_direct, $1)=yes # is this really true??? + ;; + siemens) + ## LD is ld it makes a PLAMLIB + ## CC just makes a GrossModule. + _LT_TAGVAR(archive_cmds, $1)='$LD -G -o $lib $libobjs $deplibs $linker_flags' + _LT_TAGVAR(reload_cmds, $1)='$CC -r -o $output$reload_objs' + _LT_TAGVAR(hardcode_direct, $1)=no + ;; + motorola) + _LT_TAGVAR(archive_cmds, $1)='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' + _LT_TAGVAR(hardcode_direct, $1)=no #Motorola manual says yes, but my tests say they lie + ;; + esac + runpath_var='LD_RUN_PATH' + _LT_TAGVAR(hardcode_shlibpath_var, $1)=no + ;; + + sysv4.3*) + _LT_TAGVAR(archive_cmds, $1)='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' + _LT_TAGVAR(hardcode_shlibpath_var, $1)=no + _LT_TAGVAR(export_dynamic_flag_spec, $1)='-Bexport' + ;; + + sysv4*MP*) + if test -d /usr/nec; then + _LT_TAGVAR(archive_cmds, $1)='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' + _LT_TAGVAR(hardcode_shlibpath_var, $1)=no + runpath_var=LD_RUN_PATH + hardcode_runpath_var=yes + _LT_TAGVAR(ld_shlibs, $1)=yes + fi + ;; + + sysv4*uw2* | sysv5OpenUNIX* | sysv5UnixWare7.[[01]].[[10]]* | unixware7* | sco3.2v5.0.[[024]]*) + _LT_TAGVAR(no_undefined_flag, $1)='$wl-z,text' + _LT_TAGVAR(archive_cmds_need_lc, $1)=no + _LT_TAGVAR(hardcode_shlibpath_var, $1)=no + runpath_var='LD_RUN_PATH' + + if test yes = "$GCC"; then + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' + _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $wl-Bexport:$export_symbols $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' + else + _LT_TAGVAR(archive_cmds, $1)='$CC -G $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' + _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -G $wl-Bexport:$export_symbols $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' + fi + ;; + + sysv5* | sco3.2v5* | sco5v6*) + # Note: We CANNOT use -z defs as we might desire, because we do not + # link with -lc, and that would cause any symbols used from libc to + # always be unresolved, which means just about no library would + # ever link correctly. If we're not using GNU ld we use -z text + # though, which does catch some bad symbols but isn't as heavy-handed + # as -z defs. + _LT_TAGVAR(no_undefined_flag, $1)='$wl-z,text' + _LT_TAGVAR(allow_undefined_flag, $1)='$wl-z,nodefs' + _LT_TAGVAR(archive_cmds_need_lc, $1)=no + _LT_TAGVAR(hardcode_shlibpath_var, $1)=no + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl-R,$libdir' + _LT_TAGVAR(hardcode_libdir_separator, $1)=':' + _LT_TAGVAR(link_all_deplibs, $1)=yes + _LT_TAGVAR(export_dynamic_flag_spec, $1)='$wl-Bexport' + runpath_var='LD_RUN_PATH' + + if test yes = "$GCC"; then + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' + _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $wl-Bexport:$export_symbols $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' + else + _LT_TAGVAR(archive_cmds, $1)='$CC -G $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' + _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -G $wl-Bexport:$export_symbols $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' + fi + ;; + + uts4*) + _LT_TAGVAR(archive_cmds, $1)='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir' + _LT_TAGVAR(hardcode_shlibpath_var, $1)=no + ;; + + *) + _LT_TAGVAR(ld_shlibs, $1)=no + ;; + esac + + if test sni = "$host_vendor"; then + case $host in + sysv4 | sysv4.2uw2* | sysv4.3* | sysv5*) + _LT_TAGVAR(export_dynamic_flag_spec, $1)='$wl-Blargedynsym' + ;; + esac + fi + fi +]) +AC_MSG_RESULT([$_LT_TAGVAR(ld_shlibs, $1)]) +test no = "$_LT_TAGVAR(ld_shlibs, $1)" && can_build_shared=no + +_LT_TAGVAR(with_gnu_ld, $1)=$with_gnu_ld + +_LT_DECL([], [libext], [0], [Old archive suffix (normally "a")])dnl +_LT_DECL([], [shrext_cmds], [1], [Shared library suffix (normally ".so")])dnl +_LT_DECL([], [extract_expsyms_cmds], [2], + [The commands to extract the exported symbol list from a shared archive]) + +# +# Do we need to explicitly link libc? +# +case "x$_LT_TAGVAR(archive_cmds_need_lc, $1)" in +x|xyes) + # Assume -lc should be added + _LT_TAGVAR(archive_cmds_need_lc, $1)=yes + + if test yes,yes = "$GCC,$enable_shared"; then + case $_LT_TAGVAR(archive_cmds, $1) in + *'~'*) + # FIXME: we may have to deal with multi-command sequences. + ;; + '$CC '*) + # Test whether the compiler implicitly links with -lc since on some + # systems, -lgcc has to come before -lc. If gcc already passes -lc + # to ld, don't add -lc before -lgcc. + AC_CACHE_CHECK([whether -lc should be explicitly linked in], + [lt_cv_]_LT_TAGVAR(archive_cmds_need_lc, $1), + [$RM conftest* + echo "$lt_simple_compile_test_code" > conftest.$ac_ext + + if AC_TRY_EVAL(ac_compile) 2>conftest.err; then + soname=conftest + lib=conftest + libobjs=conftest.$ac_objext + deplibs= + wl=$_LT_TAGVAR(lt_prog_compiler_wl, $1) + pic_flag=$_LT_TAGVAR(lt_prog_compiler_pic, $1) + compiler_flags=-v + linker_flags=-v + verstring= + output_objdir=. + libname=conftest + lt_save_allow_undefined_flag=$_LT_TAGVAR(allow_undefined_flag, $1) + _LT_TAGVAR(allow_undefined_flag, $1)= + if AC_TRY_EVAL(_LT_TAGVAR(archive_cmds, $1) 2\>\&1 \| $GREP \" -lc \" \>/dev/null 2\>\&1) + then + lt_cv_[]_LT_TAGVAR(archive_cmds_need_lc, $1)=no + else + lt_cv_[]_LT_TAGVAR(archive_cmds_need_lc, $1)=yes + fi + _LT_TAGVAR(allow_undefined_flag, $1)=$lt_save_allow_undefined_flag + else + cat conftest.err 1>&5 + fi + $RM conftest* + ]) + _LT_TAGVAR(archive_cmds_need_lc, $1)=$lt_cv_[]_LT_TAGVAR(archive_cmds_need_lc, $1) + ;; + esac + fi + ;; +esac + +_LT_TAGDECL([build_libtool_need_lc], [archive_cmds_need_lc], [0], + [Whether or not to add -lc for building shared libraries]) +_LT_TAGDECL([allow_libtool_libs_with_static_runtimes], + [enable_shared_with_static_runtimes], [0], + [Whether or not to disallow shared libs when runtime libs are static]) +_LT_TAGDECL([], [export_dynamic_flag_spec], [1], + [Compiler flag to allow reflexive dlopens]) +_LT_TAGDECL([], [whole_archive_flag_spec], [1], + [Compiler flag to generate shared objects directly from archives]) +_LT_TAGDECL([], [compiler_needs_object], [1], + [Whether the compiler copes with passing no objects directly]) +_LT_TAGDECL([], [old_archive_from_new_cmds], [2], + [Create an old-style archive from a shared archive]) +_LT_TAGDECL([], [old_archive_from_expsyms_cmds], [2], + [Create a temporary old-style archive to link instead of a shared archive]) +_LT_TAGDECL([], [archive_cmds], [2], [Commands used to build a shared archive]) +_LT_TAGDECL([], [archive_expsym_cmds], [2]) +_LT_TAGDECL([], [module_cmds], [2], + [Commands used to build a loadable module if different from building + a shared archive.]) +_LT_TAGDECL([], [module_expsym_cmds], [2]) +_LT_TAGDECL([], [with_gnu_ld], [1], + [Whether we are building with GNU ld or not]) +_LT_TAGDECL([], [allow_undefined_flag], [1], + [Flag that allows shared libraries with undefined symbols to be built]) +_LT_TAGDECL([], [no_undefined_flag], [1], + [Flag that enforces no undefined symbols]) +_LT_TAGDECL([], [hardcode_libdir_flag_spec], [1], + [Flag to hardcode $libdir into a binary during linking. + This must work even if $libdir does not exist]) +_LT_TAGDECL([], [hardcode_libdir_separator], [1], + [Whether we need a single "-rpath" flag with a separated argument]) +_LT_TAGDECL([], [hardcode_direct], [0], + [Set to "yes" if using DIR/libNAME$shared_ext during linking hardcodes + DIR into the resulting binary]) +_LT_TAGDECL([], [hardcode_direct_absolute], [0], + [Set to "yes" if using DIR/libNAME$shared_ext during linking hardcodes + DIR into the resulting binary and the resulting library dependency is + "absolute", i.e impossible to change by setting $shlibpath_var if the + library is relocated]) +_LT_TAGDECL([], [hardcode_minus_L], [0], + [Set to "yes" if using the -LDIR flag during linking hardcodes DIR + into the resulting binary]) +_LT_TAGDECL([], [hardcode_shlibpath_var], [0], + [Set to "yes" if using SHLIBPATH_VAR=DIR during linking hardcodes DIR + into the resulting binary]) +_LT_TAGDECL([], [hardcode_automatic], [0], + [Set to "yes" if building a shared library automatically hardcodes DIR + into the library and all subsequent libraries and executables linked + against it]) +_LT_TAGDECL([], [inherit_rpath], [0], + [Set to yes if linker adds runtime paths of dependent libraries + to runtime path list]) +_LT_TAGDECL([], [link_all_deplibs], [0], + [Whether libtool must link a program against all its dependency libraries]) +_LT_TAGDECL([], [always_export_symbols], [0], + [Set to "yes" if exported symbols are required]) +_LT_TAGDECL([], [export_symbols_cmds], [2], + [The commands to list exported symbols]) +_LT_TAGDECL([], [exclude_expsyms], [1], + [Symbols that should not be listed in the preloaded symbols]) +_LT_TAGDECL([], [include_expsyms], [1], + [Symbols that must always be exported]) +_LT_TAGDECL([], [prelink_cmds], [2], + [Commands necessary for linking programs (against libraries) with templates]) +_LT_TAGDECL([], [postlink_cmds], [2], + [Commands necessary for finishing linking programs]) +_LT_TAGDECL([], [file_list_spec], [1], + [Specify filename containing input files]) +dnl FIXME: Not yet implemented +dnl _LT_TAGDECL([], [thread_safe_flag_spec], [1], +dnl [Compiler flag to generate thread safe objects]) +])# _LT_LINKER_SHLIBS + + +# _LT_LANG_C_CONFIG([TAG]) +# ------------------------ +# Ensure that the configuration variables for a C compiler are suitably +# defined. These variables are subsequently used by _LT_CONFIG to write +# the compiler configuration to 'libtool'. +m4_defun([_LT_LANG_C_CONFIG], +[m4_require([_LT_DECL_EGREP])dnl +lt_save_CC=$CC +AC_LANG_PUSH(C) + +# Source file extension for C test sources. +ac_ext=c + +# Object file extension for compiled C test sources. +objext=o +_LT_TAGVAR(objext, $1)=$objext + +# Code to be used in simple compile tests +lt_simple_compile_test_code="int some_variable = 0;" + +# Code to be used in simple link tests +lt_simple_link_test_code='int main(){return(0);}' + +_LT_TAG_COMPILER +# Save the default compiler, since it gets overwritten when the other +# tags are being tested, and _LT_TAGVAR(compiler, []) is a NOP. +compiler_DEFAULT=$CC + +# save warnings/boilerplate of simple test code +_LT_COMPILER_BOILERPLATE +_LT_LINKER_BOILERPLATE + +## CAVEAT EMPTOR: +## There is no encapsulation within the following macros, do not change +## the running order or otherwise move them around unless you know exactly +## what you are doing... +if test -n "$compiler"; then + _LT_COMPILER_NO_RTTI($1) + _LT_COMPILER_PIC($1) + _LT_COMPILER_C_O($1) + _LT_COMPILER_FILE_LOCKS($1) + _LT_LINKER_SHLIBS($1) + _LT_SYS_DYNAMIC_LINKER($1) + _LT_LINKER_HARDCODE_LIBPATH($1) + LT_SYS_DLOPEN_SELF + _LT_CMD_STRIPLIB + + # Report what library types will actually be built + AC_MSG_CHECKING([if libtool supports shared libraries]) + AC_MSG_RESULT([$can_build_shared]) + + AC_MSG_CHECKING([whether to build shared libraries]) + test no = "$can_build_shared" && enable_shared=no + + # On AIX, shared libraries and static libraries use the same namespace, and + # are all built from PIC. + case $host_os in + aix3*) + test yes = "$enable_shared" && enable_static=no + if test -n "$RANLIB"; then + archive_cmds="$archive_cmds~\$RANLIB \$lib" + postinstall_cmds='$RANLIB $lib' + fi + ;; + + aix[[4-9]]*) + if test ia64 != "$host_cpu"; then + case $enable_shared,$with_aix_soname,$aix_use_runtimelinking in + yes,aix,yes) ;; # shared object as lib.so file only + yes,svr4,*) ;; # shared object as lib.so archive member only + yes,*) enable_static=no ;; # shared object in lib.a archive as well + esac + fi + ;; + esac + AC_MSG_RESULT([$enable_shared]) + + AC_MSG_CHECKING([whether to build static libraries]) + # Make sure either enable_shared or enable_static is yes. + test yes = "$enable_shared" || enable_static=yes + AC_MSG_RESULT([$enable_static]) + + _LT_CONFIG($1) +fi +AC_LANG_POP +CC=$lt_save_CC +])# _LT_LANG_C_CONFIG + + +# _LT_LANG_CXX_CONFIG([TAG]) +# -------------------------- +# Ensure that the configuration variables for a C++ compiler are suitably +# defined. These variables are subsequently used by _LT_CONFIG to write +# the compiler configuration to 'libtool'. +m4_defun([_LT_LANG_CXX_CONFIG], +[m4_require([_LT_FILEUTILS_DEFAULTS])dnl +m4_require([_LT_DECL_EGREP])dnl +m4_require([_LT_PATH_MANIFEST_TOOL])dnl +if test -n "$CXX" && ( test no != "$CXX" && + ( (test g++ = "$CXX" && `g++ -v >/dev/null 2>&1` ) || + (test g++ != "$CXX"))); then + AC_PROG_CXXCPP +else + _lt_caught_CXX_error=yes +fi + +AC_LANG_PUSH(C++) +_LT_TAGVAR(archive_cmds_need_lc, $1)=no +_LT_TAGVAR(allow_undefined_flag, $1)= +_LT_TAGVAR(always_export_symbols, $1)=no +_LT_TAGVAR(archive_expsym_cmds, $1)= +_LT_TAGVAR(compiler_needs_object, $1)=no +_LT_TAGVAR(export_dynamic_flag_spec, $1)= +_LT_TAGVAR(hardcode_direct, $1)=no +_LT_TAGVAR(hardcode_direct_absolute, $1)=no +_LT_TAGVAR(hardcode_libdir_flag_spec, $1)= +_LT_TAGVAR(hardcode_libdir_separator, $1)= +_LT_TAGVAR(hardcode_minus_L, $1)=no +_LT_TAGVAR(hardcode_shlibpath_var, $1)=unsupported +_LT_TAGVAR(hardcode_automatic, $1)=no +_LT_TAGVAR(inherit_rpath, $1)=no +_LT_TAGVAR(module_cmds, $1)= +_LT_TAGVAR(module_expsym_cmds, $1)= +_LT_TAGVAR(link_all_deplibs, $1)=unknown +_LT_TAGVAR(old_archive_cmds, $1)=$old_archive_cmds +_LT_TAGVAR(reload_flag, $1)=$reload_flag +_LT_TAGVAR(reload_cmds, $1)=$reload_cmds +_LT_TAGVAR(no_undefined_flag, $1)= +_LT_TAGVAR(whole_archive_flag_spec, $1)= +_LT_TAGVAR(enable_shared_with_static_runtimes, $1)=no + +# Source file extension for C++ test sources. +ac_ext=cpp + +# Object file extension for compiled C++ test sources. +objext=o +_LT_TAGVAR(objext, $1)=$objext + +# No sense in running all these tests if we already determined that +# the CXX compiler isn't working. Some variables (like enable_shared) +# are currently assumed to apply to all compilers on this platform, +# and will be corrupted by setting them based on a non-working compiler. +if test yes != "$_lt_caught_CXX_error"; then + # Code to be used in simple compile tests + lt_simple_compile_test_code="int some_variable = 0;" + + # Code to be used in simple link tests + lt_simple_link_test_code='int main(int, char *[[]]) { return(0); }' + + # ltmain only uses $CC for tagged configurations so make sure $CC is set. + _LT_TAG_COMPILER + + # save warnings/boilerplate of simple test code + _LT_COMPILER_BOILERPLATE + _LT_LINKER_BOILERPLATE + + # Allow CC to be a program name with arguments. + lt_save_CC=$CC + lt_save_CFLAGS=$CFLAGS + lt_save_LD=$LD + lt_save_GCC=$GCC + GCC=$GXX + lt_save_with_gnu_ld=$with_gnu_ld + lt_save_path_LD=$lt_cv_path_LD + if test -n "${lt_cv_prog_gnu_ldcxx+set}"; then + lt_cv_prog_gnu_ld=$lt_cv_prog_gnu_ldcxx + else + $as_unset lt_cv_prog_gnu_ld + fi + if test -n "${lt_cv_path_LDCXX+set}"; then + lt_cv_path_LD=$lt_cv_path_LDCXX + else + $as_unset lt_cv_path_LD + fi + test -z "${LDCXX+set}" || LD=$LDCXX + CC=${CXX-"c++"} + CFLAGS=$CXXFLAGS + compiler=$CC + _LT_TAGVAR(compiler, $1)=$CC + _LT_CC_BASENAME([$compiler]) + + if test -n "$compiler"; then + # We don't want -fno-exception when compiling C++ code, so set the + # no_builtin_flag separately + if test yes = "$GXX"; then + _LT_TAGVAR(lt_prog_compiler_no_builtin_flag, $1)=' -fno-builtin' + else + _LT_TAGVAR(lt_prog_compiler_no_builtin_flag, $1)= + fi + + if test yes = "$GXX"; then + # Set up default GNU C++ configuration + + LT_PATH_LD + + # Check if GNU C++ uses GNU ld as the underlying linker, since the + # archiving commands below assume that GNU ld is being used. + if test yes = "$with_gnu_ld"; then + _LT_TAGVAR(archive_cmds, $1)='$CC $pic_flag -shared -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $wl$soname -o $lib' + _LT_TAGVAR(archive_expsym_cmds, $1)='$CC $pic_flag -shared -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $wl$soname $wl-retain-symbols-file $wl$export_symbols -o $lib' + + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl-rpath $wl$libdir' + _LT_TAGVAR(export_dynamic_flag_spec, $1)='$wl--export-dynamic' + + # If archive_cmds runs LD, not CC, wlarc should be empty + # XXX I think wlarc can be eliminated in ltcf-cxx, but I need to + # investigate it a little bit more. (MM) + wlarc='$wl' + + # ancient GNU ld didn't support --whole-archive et. al. + if eval "`$CC -print-prog-name=ld` --help 2>&1" | + $GREP 'no-whole-archive' > /dev/null; then + _LT_TAGVAR(whole_archive_flag_spec, $1)=$wlarc'--whole-archive$convenience '$wlarc'--no-whole-archive' + else + _LT_TAGVAR(whole_archive_flag_spec, $1)= + fi + else + with_gnu_ld=no + wlarc= + + # A generic and very simple default shared library creation + # command for GNU C++ for the case where it uses the native + # linker, instead of GNU ld. If possible, this setting should + # overridden to take advantage of the native linker features on + # the platform it is being used on. + _LT_TAGVAR(archive_cmds, $1)='$CC -shared -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags -o $lib' + fi + + # Commands to make compiler produce verbose output that lists + # what "hidden" libraries, object files and flags are used when + # linking a shared library. + output_verbose_link_cmd='$CC -shared $CFLAGS -v conftest.$objext 2>&1 | $GREP -v "^Configured with:" | $GREP " \-L"' + + else + GXX=no + with_gnu_ld=no + wlarc= + fi + + # PORTME: fill in a description of your system's C++ link characteristics + AC_MSG_CHECKING([whether the $compiler linker ($LD) supports shared libraries]) + _LT_TAGVAR(ld_shlibs, $1)=yes + case $host_os in + aix3*) + # FIXME: insert proper C++ library support + _LT_TAGVAR(ld_shlibs, $1)=no + ;; + aix[[4-9]]*) + if test ia64 = "$host_cpu"; then + # On IA64, the linker does run time linking by default, so we don't + # have to do anything special. + aix_use_runtimelinking=no + exp_sym_flag='-Bexport' + no_entry_flag= + else + aix_use_runtimelinking=no + + # Test if we are trying to use run time linking or normal + # AIX style linking. If -brtl is somewhere in LDFLAGS, we + # have runtime linking enabled, and use it for executables. + # For shared libraries, we enable/disable runtime linking + # depending on the kind of the shared library created - + # when "with_aix_soname,aix_use_runtimelinking" is: + # "aix,no" lib.a(lib.so.V) shared, rtl:no, for executables + # "aix,yes" lib.so shared, rtl:yes, for executables + # lib.a static archive + # "both,no" lib.so.V(shr.o) shared, rtl:yes + # lib.a(lib.so.V) shared, rtl:no, for executables + # "both,yes" lib.so.V(shr.o) shared, rtl:yes, for executables + # lib.a(lib.so.V) shared, rtl:no + # "svr4,*" lib.so.V(shr.o) shared, rtl:yes, for executables + # lib.a static archive + case $host_os in aix4.[[23]]|aix4.[[23]].*|aix[[5-9]]*) + for ld_flag in $LDFLAGS; do + case $ld_flag in + *-brtl*) + aix_use_runtimelinking=yes + break + ;; + esac + done + if test svr4,no = "$with_aix_soname,$aix_use_runtimelinking"; then + # With aix-soname=svr4, we create the lib.so.V shared archives only, + # so we don't have lib.a shared libs to link our executables. + # We have to force runtime linking in this case. + aix_use_runtimelinking=yes + LDFLAGS="$LDFLAGS -Wl,-brtl" + fi + ;; + esac + + exp_sym_flag='-bexport' + no_entry_flag='-bnoentry' + fi + + # When large executables or shared objects are built, AIX ld can + # have problems creating the table of contents. If linking a library + # or program results in "error TOC overflow" add -mminimal-toc to + # CXXFLAGS/CFLAGS for g++/gcc. In the cases where that is not + # enough to fix the problem, add -Wl,-bbigtoc to LDFLAGS. + + _LT_TAGVAR(archive_cmds, $1)='' + _LT_TAGVAR(hardcode_direct, $1)=yes + _LT_TAGVAR(hardcode_direct_absolute, $1)=yes + _LT_TAGVAR(hardcode_libdir_separator, $1)=':' + _LT_TAGVAR(link_all_deplibs, $1)=yes + _LT_TAGVAR(file_list_spec, $1)='$wl-f,' + case $with_aix_soname,$aix_use_runtimelinking in + aix,*) ;; # no import file + svr4,* | *,yes) # use import file + # The Import File defines what to hardcode. + _LT_TAGVAR(hardcode_direct, $1)=no + _LT_TAGVAR(hardcode_direct_absolute, $1)=no + ;; + esac + + if test yes = "$GXX"; then + case $host_os in aix4.[[012]]|aix4.[[012]].*) + # We only want to do this on AIX 4.2 and lower, the check + # below for broken collect2 doesn't work under 4.3+ + collect2name=`$CC -print-prog-name=collect2` + if test -f "$collect2name" && + strings "$collect2name" | $GREP resolve_lib_name >/dev/null + then + # We have reworked collect2 + : + else + # We have old collect2 + _LT_TAGVAR(hardcode_direct, $1)=unsupported + # It fails to find uninstalled libraries when the uninstalled + # path is not listed in the libpath. Setting hardcode_minus_L + # to unsupported forces relinking + _LT_TAGVAR(hardcode_minus_L, $1)=yes + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir' + _LT_TAGVAR(hardcode_libdir_separator, $1)= + fi + esac + shared_flag='-shared' + if test yes = "$aix_use_runtimelinking"; then + shared_flag=$shared_flag' $wl-G' + fi + # Need to ensure runtime linking is disabled for the traditional + # shared library, or the linker may eventually find shared libraries + # /with/ Import File - we do not want to mix them. + shared_flag_aix='-shared' + shared_flag_svr4='-shared $wl-G' + else + # not using gcc + if test ia64 = "$host_cpu"; then + # VisualAge C++, Version 5.5 for AIX 5L for IA-64, Beta 3 Release + # chokes on -Wl,-G. The following line is correct: + shared_flag='-G' + else + if test yes = "$aix_use_runtimelinking"; then + shared_flag='$wl-G' + else + shared_flag='$wl-bM:SRE' + fi + shared_flag_aix='$wl-bM:SRE' + shared_flag_svr4='$wl-G' + fi + fi + + _LT_TAGVAR(export_dynamic_flag_spec, $1)='$wl-bexpall' + # It seems that -bexpall does not export symbols beginning with + # underscore (_), so it is better to generate a list of symbols to + # export. + _LT_TAGVAR(always_export_symbols, $1)=yes + if test aix,yes = "$with_aix_soname,$aix_use_runtimelinking"; then + # Warning - without using the other runtime loading flags (-brtl), + # -berok will link without error, but may produce a broken library. + # The "-G" linker flag allows undefined symbols. + _LT_TAGVAR(no_undefined_flag, $1)='-bernotok' + # Determine the default libpath from the value encoded in an empty + # executable. + _LT_SYS_MODULE_PATH_AIX([$1]) + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl-blibpath:$libdir:'"$aix_libpath" + + _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -o $output_objdir/$soname $libobjs $deplibs $wl'$no_entry_flag' $compiler_flags `if test -n "$allow_undefined_flag"; then func_echo_all "$wl$allow_undefined_flag"; else :; fi` $wl'$exp_sym_flag:\$export_symbols' '$shared_flag + else + if test ia64 = "$host_cpu"; then + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl-R $libdir:/usr/lib:/lib' + _LT_TAGVAR(allow_undefined_flag, $1)="-z nodefs" + _LT_TAGVAR(archive_expsym_cmds, $1)="\$CC $shared_flag"' -o $output_objdir/$soname $libobjs $deplibs '"\$wl$no_entry_flag"' $compiler_flags $wl$allow_undefined_flag '"\$wl$exp_sym_flag:\$export_symbols" + else + # Determine the default libpath from the value encoded in an + # empty executable. + _LT_SYS_MODULE_PATH_AIX([$1]) + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl-blibpath:$libdir:'"$aix_libpath" + # Warning - without using the other run time loading flags, + # -berok will link without error, but may produce a broken library. + _LT_TAGVAR(no_undefined_flag, $1)=' $wl-bernotok' + _LT_TAGVAR(allow_undefined_flag, $1)=' $wl-berok' + if test yes = "$with_gnu_ld"; then + # We only use this code for GNU lds that support --whole-archive. + _LT_TAGVAR(whole_archive_flag_spec, $1)='$wl--whole-archive$convenience $wl--no-whole-archive' + else + # Exported symbols can be pulled into shared objects from archives + _LT_TAGVAR(whole_archive_flag_spec, $1)='$convenience' + fi + _LT_TAGVAR(archive_cmds_need_lc, $1)=yes + _LT_TAGVAR(archive_expsym_cmds, $1)='$RM -r $output_objdir/$realname.d~$MKDIR $output_objdir/$realname.d' + # -brtl affects multiple linker settings, -berok does not and is overridden later + compiler_flags_filtered='`func_echo_all "$compiler_flags " | $SED -e "s%-brtl\\([[, ]]\\)%-berok\\1%g"`' + if test svr4 != "$with_aix_soname"; then + # This is similar to how AIX traditionally builds its shared + # libraries. Need -bnortl late, we may have -brtl in LDFLAGS. + _LT_TAGVAR(archive_expsym_cmds, $1)="$_LT_TAGVAR(archive_expsym_cmds, $1)"'~$CC '$shared_flag_aix' -o $output_objdir/$realname.d/$soname $libobjs $deplibs $wl-bnoentry '$compiler_flags_filtered'$wl-bE:$export_symbols$allow_undefined_flag~$AR $AR_FLAGS $output_objdir/$libname$release.a $output_objdir/$realname.d/$soname' + fi + if test aix != "$with_aix_soname"; then + _LT_TAGVAR(archive_expsym_cmds, $1)="$_LT_TAGVAR(archive_expsym_cmds, $1)"'~$CC '$shared_flag_svr4' -o $output_objdir/$realname.d/$shared_archive_member_spec.o $libobjs $deplibs $wl-bnoentry '$compiler_flags_filtered'$wl-bE:$export_symbols$allow_undefined_flag~$STRIP -e $output_objdir/$realname.d/$shared_archive_member_spec.o~( func_echo_all "#! $soname($shared_archive_member_spec.o)"; if test shr_64 = "$shared_archive_member_spec"; then func_echo_all "# 64"; else func_echo_all "# 32"; fi; cat $export_symbols ) > $output_objdir/$realname.d/$shared_archive_member_spec.imp~$AR $AR_FLAGS $output_objdir/$soname $output_objdir/$realname.d/$shared_archive_member_spec.o $output_objdir/$realname.d/$shared_archive_member_spec.imp' + else + # used by -dlpreopen to get the symbols + _LT_TAGVAR(archive_expsym_cmds, $1)="$_LT_TAGVAR(archive_expsym_cmds, $1)"'~$MV $output_objdir/$realname.d/$soname $output_objdir' + fi + _LT_TAGVAR(archive_expsym_cmds, $1)="$_LT_TAGVAR(archive_expsym_cmds, $1)"'~$RM -r $output_objdir/$realname.d' + fi + fi + ;; + + beos*) + if $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then + _LT_TAGVAR(allow_undefined_flag, $1)=unsupported + # Joseph Beckenbach says some releases of gcc + # support --undefined. This deserves some investigation. FIXME + _LT_TAGVAR(archive_cmds, $1)='$CC -nostart $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' + else + _LT_TAGVAR(ld_shlibs, $1)=no + fi + ;; + + chorus*) + case $cc_basename in + *) + # FIXME: insert proper C++ library support + _LT_TAGVAR(ld_shlibs, $1)=no + ;; + esac + ;; + + cygwin* | mingw* | pw32* | cegcc*) + case $GXX,$cc_basename in + ,cl* | no,cl* | ,icl* | no,icl*) + # Native MSVC or ICC + # hardcode_libdir_flag_spec is actually meaningless, as there is + # no search path for DLLs. + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)=' ' + _LT_TAGVAR(allow_undefined_flag, $1)=unsupported + _LT_TAGVAR(always_export_symbols, $1)=yes + _LT_TAGVAR(file_list_spec, $1)='@' + # Tell ltmain to make .lib files, not .a files. + libext=lib + # Tell ltmain to make .dll files, not .so files. + shrext_cmds=.dll + # FIXME: Setting linknames here is a bad hack. + _LT_TAGVAR(archive_cmds, $1)='$CC -o $output_objdir/$soname $libobjs $compiler_flags $deplibs -Wl,-DLL,-IMPLIB:"$tool_output_objdir$libname.dll.lib"~linknames=' + _LT_TAGVAR(archive_expsym_cmds, $1)='if _LT_DLL_DEF_P([$export_symbols]); then + cp "$export_symbols" "$output_objdir/$soname.def"; + echo "$tool_output_objdir$soname.def" > "$output_objdir/$soname.exp"; + else + $SED -e '\''s/^/-link -EXPORT:/'\'' < $export_symbols > $output_objdir/$soname.exp; + fi~ + $CC -o $tool_output_objdir$soname $libobjs $compiler_flags $deplibs "@$tool_output_objdir$soname.exp" -Wl,-DLL,-IMPLIB:"$tool_output_objdir$libname.dll.lib"~ + linknames=' + # The linker will not automatically build a static lib if we build a DLL. + # _LT_TAGVAR(old_archive_from_new_cmds, $1)='true' + _LT_TAGVAR(enable_shared_with_static_runtimes, $1)=yes + # Don't use ranlib + _LT_TAGVAR(old_postinstall_cmds, $1)='chmod 644 $oldlib' + _LT_TAGVAR(postlink_cmds, $1)='lt_outputfile="@OUTPUT@"~ + lt_tool_outputfile="@TOOL_OUTPUT@"~ + case $lt_outputfile in + *.exe|*.EXE) ;; + *) + lt_outputfile=$lt_outputfile.exe + lt_tool_outputfile=$lt_tool_outputfile.exe + ;; + esac~ + func_to_tool_file "$lt_outputfile"~ + if test : != "$MANIFEST_TOOL" && test -f "$lt_outputfile.manifest"; then + $MANIFEST_TOOL -manifest "$lt_tool_outputfile.manifest" -outputresource:"$lt_tool_outputfile" || exit 1; + $RM "$lt_outputfile.manifest"; + fi' + ;; + *) + # g++ + # _LT_TAGVAR(hardcode_libdir_flag_spec, $1) is actually meaningless, + # as there is no search path for DLLs. + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir' + _LT_TAGVAR(export_dynamic_flag_spec, $1)='$wl--export-all-symbols' + _LT_TAGVAR(allow_undefined_flag, $1)=unsupported + _LT_TAGVAR(always_export_symbols, $1)=no + _LT_TAGVAR(enable_shared_with_static_runtimes, $1)=yes + + if $LD --help 2>&1 | $GREP 'auto-import' > /dev/null; then + _LT_TAGVAR(archive_cmds, $1)='$CC -shared -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags -o $output_objdir/$soname $wl--enable-auto-image-base -Xlinker --out-implib -Xlinker $lib' + # If the export-symbols file already is a .def file, use it as + # is; otherwise, prepend EXPORTS... + _LT_TAGVAR(archive_expsym_cmds, $1)='if _LT_DLL_DEF_P([$export_symbols]); then + cp $export_symbols $output_objdir/$soname.def; + else + echo EXPORTS > $output_objdir/$soname.def; + cat $export_symbols >> $output_objdir/$soname.def; + fi~ + $CC -shared -nostdlib $output_objdir/$soname.def $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags -o $output_objdir/$soname $wl--enable-auto-image-base -Xlinker --out-implib -Xlinker $lib' + else + _LT_TAGVAR(ld_shlibs, $1)=no + fi + ;; + esac + ;; + darwin* | rhapsody*) + _LT_DARWIN_LINKER_FEATURES($1) + ;; + + os2*) + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir' + _LT_TAGVAR(hardcode_minus_L, $1)=yes + _LT_TAGVAR(allow_undefined_flag, $1)=unsupported + shrext_cmds=.dll + _LT_TAGVAR(archive_cmds, $1)='$ECHO "LIBRARY ${soname%$shared_ext} INITINSTANCE TERMINSTANCE" > $output_objdir/$libname.def~ + $ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~ + $ECHO "DATA MULTIPLE NONSHARED" >> $output_objdir/$libname.def~ + $ECHO EXPORTS >> $output_objdir/$libname.def~ + emxexp $libobjs | $SED /"_DLL_InitTerm"/d >> $output_objdir/$libname.def~ + $CC -Zdll -Zcrtdll -o $output_objdir/$soname $libobjs $deplibs $compiler_flags $output_objdir/$libname.def~ + emximp -o $lib $output_objdir/$libname.def' + _LT_TAGVAR(archive_expsym_cmds, $1)='$ECHO "LIBRARY ${soname%$shared_ext} INITINSTANCE TERMINSTANCE" > $output_objdir/$libname.def~ + $ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~ + $ECHO "DATA MULTIPLE NONSHARED" >> $output_objdir/$libname.def~ + $ECHO EXPORTS >> $output_objdir/$libname.def~ + prefix_cmds="$SED"~ + if test EXPORTS = "`$SED 1q $export_symbols`"; then + prefix_cmds="$prefix_cmds -e 1d"; + fi~ + prefix_cmds="$prefix_cmds -e \"s/^\(.*\)$/_\1/g\""~ + cat $export_symbols | $prefix_cmds >> $output_objdir/$libname.def~ + $CC -Zdll -Zcrtdll -o $output_objdir/$soname $libobjs $deplibs $compiler_flags $output_objdir/$libname.def~ + emximp -o $lib $output_objdir/$libname.def' + _LT_TAGVAR(old_archive_From_new_cmds, $1)='emximp -o $output_objdir/${libname}_dll.a $output_objdir/$libname.def' + _LT_TAGVAR(enable_shared_with_static_runtimes, $1)=yes + _LT_TAGVAR(file_list_spec, $1)='@' + ;; + + dgux*) + case $cc_basename in + ec++*) + # FIXME: insert proper C++ library support + _LT_TAGVAR(ld_shlibs, $1)=no + ;; + ghcx*) + # Green Hills C++ Compiler + # FIXME: insert proper C++ library support + _LT_TAGVAR(ld_shlibs, $1)=no + ;; + *) + # FIXME: insert proper C++ library support + _LT_TAGVAR(ld_shlibs, $1)=no + ;; + esac + ;; + + freebsd2.*) + # C++ shared libraries reported to be fairly broken before + # switch to ELF + _LT_TAGVAR(ld_shlibs, $1)=no + ;; + + freebsd-elf*) + _LT_TAGVAR(archive_cmds_need_lc, $1)=no + ;; + + freebsd* | dragonfly* | midnightbsd*) + # FreeBSD 3 and later use GNU C++ and GNU ld with standard ELF + # conventions + _LT_TAGVAR(ld_shlibs, $1)=yes + ;; + + haiku*) + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' + _LT_TAGVAR(link_all_deplibs, $1)=yes + ;; + + hpux9*) + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl+b $wl$libdir' + _LT_TAGVAR(hardcode_libdir_separator, $1)=: + _LT_TAGVAR(export_dynamic_flag_spec, $1)='$wl-E' + _LT_TAGVAR(hardcode_direct, $1)=yes + _LT_TAGVAR(hardcode_minus_L, $1)=yes # Not in the search PATH, + # but as the default + # location of the library. + + case $cc_basename in + CC*) + # FIXME: insert proper C++ library support + _LT_TAGVAR(ld_shlibs, $1)=no + ;; + aCC*) + _LT_TAGVAR(archive_cmds, $1)='$RM $output_objdir/$soname~$CC -b $wl+b $wl$install_libdir -o $output_objdir/$soname $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags~test "x$output_objdir/$soname" = "x$lib" || mv $output_objdir/$soname $lib' + # Commands to make compiler produce verbose output that lists + # what "hidden" libraries, object files and flags are used when + # linking a shared library. + # + # There doesn't appear to be a way to prevent this compiler from + # explicitly linking system object files so we need to strip them + # from the output so that they don't get included in the library + # dependencies. + output_verbose_link_cmd='templist=`($CC -b $CFLAGS -v conftest.$objext 2>&1) | $EGREP " \-L"`; list= ; for z in $templist; do case $z in conftest.$objext) list="$list $z";; *.$objext);; *) list="$list $z";;esac; done; func_echo_all "$list"' + ;; + *) + if test yes = "$GXX"; then + _LT_TAGVAR(archive_cmds, $1)='$RM $output_objdir/$soname~$CC -shared -nostdlib $pic_flag $wl+b $wl$install_libdir -o $output_objdir/$soname $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags~test "x$output_objdir/$soname" = "x$lib" || mv $output_objdir/$soname $lib' + else + # FIXME: insert proper C++ library support + _LT_TAGVAR(ld_shlibs, $1)=no + fi + ;; + esac + ;; + + hpux10*|hpux11*) + if test no = "$with_gnu_ld"; then + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl+b $wl$libdir' + _LT_TAGVAR(hardcode_libdir_separator, $1)=: + + case $host_cpu in + hppa*64*|ia64*) + ;; + *) + _LT_TAGVAR(export_dynamic_flag_spec, $1)='$wl-E' + ;; + esac + fi + case $host_cpu in + hppa*64*|ia64*) + _LT_TAGVAR(hardcode_direct, $1)=no + _LT_TAGVAR(hardcode_shlibpath_var, $1)=no + ;; + *) + _LT_TAGVAR(hardcode_direct, $1)=yes + _LT_TAGVAR(hardcode_direct_absolute, $1)=yes + _LT_TAGVAR(hardcode_minus_L, $1)=yes # Not in the search PATH, + # but as the default + # location of the library. + ;; + esac + + case $cc_basename in + CC*) + # FIXME: insert proper C++ library support + _LT_TAGVAR(ld_shlibs, $1)=no + ;; + aCC*) + case $host_cpu in + hppa*64*) + _LT_TAGVAR(archive_cmds, $1)='$CC -b $wl+h $wl$soname -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags' + ;; + ia64*) + _LT_TAGVAR(archive_cmds, $1)='$CC -b $wl+h $wl$soname $wl+nodefaultrpath -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags' + ;; + *) + _LT_TAGVAR(archive_cmds, $1)='$CC -b $wl+h $wl$soname $wl+b $wl$install_libdir -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags' + ;; + esac + # Commands to make compiler produce verbose output that lists + # what "hidden" libraries, object files and flags are used when + # linking a shared library. + # + # There doesn't appear to be a way to prevent this compiler from + # explicitly linking system object files so we need to strip them + # from the output so that they don't get included in the library + # dependencies. + output_verbose_link_cmd='templist=`($CC -b $CFLAGS -v conftest.$objext 2>&1) | $GREP " \-L"`; list= ; for z in $templist; do case $z in conftest.$objext) list="$list $z";; *.$objext);; *) list="$list $z";;esac; done; func_echo_all "$list"' + ;; + *) + if test yes = "$GXX"; then + if test no = "$with_gnu_ld"; then + case $host_cpu in + hppa*64*) + _LT_TAGVAR(archive_cmds, $1)='$CC -shared -nostdlib -fPIC $wl+h $wl$soname -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags' + ;; + ia64*) + _LT_TAGVAR(archive_cmds, $1)='$CC -shared -nostdlib $pic_flag $wl+h $wl$soname $wl+nodefaultrpath -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags' + ;; + *) + _LT_TAGVAR(archive_cmds, $1)='$CC -shared -nostdlib $pic_flag $wl+h $wl$soname $wl+b $wl$install_libdir -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags' + ;; + esac + fi + else + # FIXME: insert proper C++ library support + _LT_TAGVAR(ld_shlibs, $1)=no + fi + ;; + esac + ;; + + interix[[3-9]]*) + _LT_TAGVAR(hardcode_direct, $1)=no + _LT_TAGVAR(hardcode_shlibpath_var, $1)=no + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl-rpath,$libdir' + _LT_TAGVAR(export_dynamic_flag_spec, $1)='$wl-E' + # Hack: On Interix 3.x, we cannot compile PIC because of a broken gcc. + # Instead, shared libraries are loaded at an image base (0x10000000 by + # default) and relocated if they conflict, which is a slow very memory + # consuming and fragmenting process. To avoid this, we pick a random, + # 256 KiB-aligned image base between 0x50000000 and 0x6FFC0000 at link + # time. Moving up from 0x10000000 also allows more sbrk(2) space. + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-h,$soname $wl--image-base,`expr ${RANDOM-$$} % 4096 / 2 \* 262144 + 1342177280` -o $lib' + _LT_TAGVAR(archive_expsym_cmds, $1)='$SED "s|^|_|" $export_symbols >$output_objdir/$soname.expsym~$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-h,$soname $wl--retain-symbols-file,$output_objdir/$soname.expsym $wl--image-base,`expr ${RANDOM-$$} % 4096 / 2 \* 262144 + 1342177280` -o $lib' + ;; + irix5* | irix6*) + case $cc_basename in + CC*) + # SGI C++ + _LT_TAGVAR(archive_cmds, $1)='$CC -shared -all -multigot $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry $output_objdir/so_locations -o $lib' + + # Archives containing C++ object files must be created using + # "CC -ar", where "CC" is the IRIX C++ compiler. This is + # necessary to make sure instantiated templates are included + # in the archive. + _LT_TAGVAR(old_archive_cmds, $1)='$CC -ar -WR,-u -o $oldlib $oldobjs' + ;; + *) + if test yes = "$GXX"; then + if test no = "$with_gnu_ld"; then + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` $wl-update_registry $wl$output_objdir/so_locations -o $lib' + else + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` -o $lib' + fi + fi + _LT_TAGVAR(link_all_deplibs, $1)=yes + ;; + esac + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl-rpath $wl$libdir' + _LT_TAGVAR(hardcode_libdir_separator, $1)=: + _LT_TAGVAR(inherit_rpath, $1)=yes + ;; + + linux* | k*bsd*-gnu | kopensolaris*-gnu | gnu*) + case $cc_basename in + KCC*) + # Kuck and Associates, Inc. (KAI) C++ Compiler + + # KCC will only create a shared library if the output file + # ends with ".so" (or ".sl" for HP-UX), so rename the library + # to its proper name (with version) after linking. + _LT_TAGVAR(archive_cmds, $1)='tempext=`echo $shared_ext | $SED -e '\''s/\([[^()0-9A-Za-z{}]]\)/\\\\\1/g'\''`; templib=`echo $lib | $SED -e "s/\$tempext\..*/.so/"`; $CC $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags --soname $soname -o \$templib; mv \$templib $lib' + _LT_TAGVAR(archive_expsym_cmds, $1)='tempext=`echo $shared_ext | $SED -e '\''s/\([[^()0-9A-Za-z{}]]\)/\\\\\1/g'\''`; templib=`echo $lib | $SED -e "s/\$tempext\..*/.so/"`; $CC $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags --soname $soname -o \$templib $wl-retain-symbols-file,$export_symbols; mv \$templib $lib' + # Commands to make compiler produce verbose output that lists + # what "hidden" libraries, object files and flags are used when + # linking a shared library. + # + # There doesn't appear to be a way to prevent this compiler from + # explicitly linking system object files so we need to strip them + # from the output so that they don't get included in the library + # dependencies. + output_verbose_link_cmd='templist=`$CC $CFLAGS -v conftest.$objext -o libconftest$shared_ext 2>&1 | $GREP "ld"`; rm -f libconftest$shared_ext; list= ; for z in $templist; do case $z in conftest.$objext) list="$list $z";; *.$objext);; *) list="$list $z";;esac; done; func_echo_all "$list"' + + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl-rpath,$libdir' + _LT_TAGVAR(export_dynamic_flag_spec, $1)='$wl--export-dynamic' + + # Archives containing C++ object files must be created using + # "CC -Bstatic", where "CC" is the KAI C++ compiler. + _LT_TAGVAR(old_archive_cmds, $1)='$CC -Bstatic -o $oldlib $oldobjs' + ;; + icpc* | ecpc* ) + # Intel C++ + with_gnu_ld=yes + # version 8.0 and above of icpc choke on multiply defined symbols + # if we add $predep_objects and $postdep_objects, however 7.1 and + # earlier do not add the objects themselves. + case `$CC -V 2>&1` in + *"Version 7."*) + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $wl$soname -o $lib' + _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $wl$soname $wl-retain-symbols-file $wl$export_symbols -o $lib' + ;; + *) # Version 8.0 or newer + tmp_idyn= + case $host_cpu in + ia64*) tmp_idyn=' -i_dynamic';; + esac + _LT_TAGVAR(archive_cmds, $1)='$CC -shared'"$tmp_idyn"' $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' + _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared'"$tmp_idyn"' $libobjs $deplibs $compiler_flags $wl-soname $wl$soname $wl-retain-symbols-file $wl$export_symbols -o $lib' + ;; + esac + _LT_TAGVAR(archive_cmds_need_lc, $1)=no + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl-rpath,$libdir' + _LT_TAGVAR(export_dynamic_flag_spec, $1)='$wl--export-dynamic' + _LT_TAGVAR(whole_archive_flag_spec, $1)='$wl--whole-archive$convenience $wl--no-whole-archive' + ;; + pgCC* | pgcpp*) + # Portland Group C++ compiler + case `$CC -V` in + *pgCC\ [[1-5]].* | *pgcpp\ [[1-5]].*) + _LT_TAGVAR(prelink_cmds, $1)='tpldir=Template.dir~ + rm -rf $tpldir~ + $CC --prelink_objects --instantiation_dir $tpldir $objs $libobjs $compile_deplibs~ + compile_command="$compile_command `find $tpldir -name \*.o | sort | $NL2SP`"' + _LT_TAGVAR(old_archive_cmds, $1)='tpldir=Template.dir~ + rm -rf $tpldir~ + $CC --prelink_objects --instantiation_dir $tpldir $oldobjs$old_deplibs~ + $AR $AR_FLAGS $oldlib$oldobjs$old_deplibs `find $tpldir -name \*.o | sort | $NL2SP`~ + $RANLIB $oldlib' + _LT_TAGVAR(archive_cmds, $1)='tpldir=Template.dir~ + rm -rf $tpldir~ + $CC --prelink_objects --instantiation_dir $tpldir $predep_objects $libobjs $deplibs $convenience $postdep_objects~ + $CC -shared $pic_flag $predep_objects $libobjs $deplibs `find $tpldir -name \*.o | sort | $NL2SP` $postdep_objects $compiler_flags $wl-soname $wl$soname -o $lib' + _LT_TAGVAR(archive_expsym_cmds, $1)='tpldir=Template.dir~ + rm -rf $tpldir~ + $CC --prelink_objects --instantiation_dir $tpldir $predep_objects $libobjs $deplibs $convenience $postdep_objects~ + $CC -shared $pic_flag $predep_objects $libobjs $deplibs `find $tpldir -name \*.o | sort | $NL2SP` $postdep_objects $compiler_flags $wl-soname $wl$soname $wl-retain-symbols-file $wl$export_symbols -o $lib' + ;; + *) # Version 6 and above use weak symbols + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $wl$soname -o $lib' + _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $pic_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $wl$soname $wl-retain-symbols-file $wl$export_symbols -o $lib' + ;; + esac + + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl--rpath $wl$libdir' + _LT_TAGVAR(export_dynamic_flag_spec, $1)='$wl--export-dynamic' + _LT_TAGVAR(whole_archive_flag_spec, $1)='$wl--whole-archive`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` $wl--no-whole-archive' + ;; + cxx*) + # Compaq C++ + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $wl$soname -o $lib' + _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $wl$soname -o $lib $wl-retain-symbols-file $wl$export_symbols' + + runpath_var=LD_RUN_PATH + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-rpath $libdir' + _LT_TAGVAR(hardcode_libdir_separator, $1)=: + + # Commands to make compiler produce verbose output that lists + # what "hidden" libraries, object files and flags are used when + # linking a shared library. + # + # There doesn't appear to be a way to prevent this compiler from + # explicitly linking system object files so we need to strip them + # from the output so that they don't get included in the library + # dependencies. + output_verbose_link_cmd='templist=`$CC -shared $CFLAGS -v conftest.$objext 2>&1 | $GREP "ld"`; templist=`func_echo_all "$templist" | $SED "s/\(^.*ld.*\)\( .*ld .*$\)/\1/"`; list= ; for z in $templist; do case $z in conftest.$objext) list="$list $z";; *.$objext);; *) list="$list $z";;esac; done; func_echo_all "X$list" | $Xsed' + ;; + xl* | mpixl* | bgxl*) + # IBM XL 8.0 on PPC, with GNU ld + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl-rpath $wl$libdir' + _LT_TAGVAR(export_dynamic_flag_spec, $1)='$wl--export-dynamic' + _LT_TAGVAR(archive_cmds, $1)='$CC -qmkshrobj $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' + if test yes = "$supports_anon_versioning"; then + _LT_TAGVAR(archive_expsym_cmds, $1)='echo "{ global:" > $output_objdir/$libname.ver~ + cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $output_objdir/$libname.ver~ + echo "local: *; };" >> $output_objdir/$libname.ver~ + $CC -qmkshrobj $libobjs $deplibs $compiler_flags $wl-soname $wl$soname $wl-version-script $wl$output_objdir/$libname.ver -o $lib' + fi + ;; + *) + case `$CC -V 2>&1 | $SED 5q` in + *Sun\ C*) + # Sun C++ 5.9 + _LT_TAGVAR(no_undefined_flag, $1)=' -zdefs' + _LT_TAGVAR(archive_cmds, $1)='$CC -G$allow_undefined_flag -h$soname -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags' + _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -G$allow_undefined_flag -h$soname -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-retain-symbols-file $wl$export_symbols' + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-R$libdir' + _LT_TAGVAR(whole_archive_flag_spec, $1)='$wl--whole-archive`new_convenience=; for conv in $convenience\"\"; do test -z \"$conv\" || new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` $wl--no-whole-archive' + _LT_TAGVAR(compiler_needs_object, $1)=yes + + # Not sure whether something based on + # $CC $CFLAGS -v conftest.$objext -o libconftest$shared_ext 2>&1 + # would be better. + output_verbose_link_cmd='func_echo_all' + + # Archives containing C++ object files must be created using + # "CC -xar", where "CC" is the Sun C++ compiler. This is + # necessary to make sure instantiated templates are included + # in the archive. + _LT_TAGVAR(old_archive_cmds, $1)='$CC -xar -o $oldlib $oldobjs' + ;; + esac + ;; + esac + ;; + + lynxos*) + # FIXME: insert proper C++ library support + _LT_TAGVAR(ld_shlibs, $1)=no + ;; + + m88k*) + # FIXME: insert proper C++ library support + _LT_TAGVAR(ld_shlibs, $1)=no + ;; + + mvs*) + case $cc_basename in + cxx*) + # FIXME: insert proper C++ library support + _LT_TAGVAR(ld_shlibs, $1)=no + ;; + *) + # FIXME: insert proper C++ library support + _LT_TAGVAR(ld_shlibs, $1)=no + ;; + esac + ;; + + netbsd*) + if echo __ELF__ | $CC -E - | $GREP __ELF__ >/dev/null; then + _LT_TAGVAR(archive_cmds, $1)='$LD -Bshareable -o $lib $predep_objects $libobjs $deplibs $postdep_objects $linker_flags' + wlarc= + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-R$libdir' + _LT_TAGVAR(hardcode_direct, $1)=yes + _LT_TAGVAR(hardcode_shlibpath_var, $1)=no + fi + # Workaround some broken pre-1.5 toolchains + output_verbose_link_cmd='$CC -shared $CFLAGS -v conftest.$objext 2>&1 | $GREP conftest.$objext | $SED -e "s:-lgcc -lc -lgcc::"' + ;; + + *nto* | *qnx*) + _LT_TAGVAR(ld_shlibs, $1)=yes + ;; + + openbsd* | bitrig*) + if test -f /usr/libexec/ld.so; then + _LT_TAGVAR(hardcode_direct, $1)=yes + _LT_TAGVAR(hardcode_shlibpath_var, $1)=no + _LT_TAGVAR(hardcode_direct_absolute, $1)=yes + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags -o $lib' + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl-rpath,$libdir' + if test -z "`echo __ELF__ | $CC -E - | grep __ELF__`"; then + _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $pic_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-retain-symbols-file,$export_symbols -o $lib' + _LT_TAGVAR(export_dynamic_flag_spec, $1)='$wl-E' + _LT_TAGVAR(whole_archive_flag_spec, $1)=$wlarc'--whole-archive$convenience '$wlarc'--no-whole-archive' + fi + output_verbose_link_cmd=func_echo_all + else + _LT_TAGVAR(ld_shlibs, $1)=no + fi + ;; + + osf3* | osf4* | osf5*) + case $cc_basename in + KCC*) + # Kuck and Associates, Inc. (KAI) C++ Compiler + + # KCC will only create a shared library if the output file + # ends with ".so" (or ".sl" for HP-UX), so rename the library + # to its proper name (with version) after linking. + _LT_TAGVAR(archive_cmds, $1)='tempext=`echo $shared_ext | $SED -e '\''s/\([[^()0-9A-Za-z{}]]\)/\\\\\1/g'\''`; templib=`echo "$lib" | $SED -e "s/\$tempext\..*/.so/"`; $CC $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags --soname $soname -o \$templib; mv \$templib $lib' + + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl-rpath,$libdir' + _LT_TAGVAR(hardcode_libdir_separator, $1)=: + + # Archives containing C++ object files must be created using + # the KAI C++ compiler. + case $host in + osf3*) _LT_TAGVAR(old_archive_cmds, $1)='$CC -Bstatic -o $oldlib $oldobjs' ;; + *) _LT_TAGVAR(old_archive_cmds, $1)='$CC -o $oldlib $oldobjs' ;; + esac + ;; + RCC*) + # Rational C++ 2.4.1 + # FIXME: insert proper C++ library support + _LT_TAGVAR(ld_shlibs, $1)=no + ;; + cxx*) + case $host in + osf3*) + _LT_TAGVAR(allow_undefined_flag, $1)=' $wl-expect_unresolved $wl\*' + _LT_TAGVAR(archive_cmds, $1)='$CC -shared$allow_undefined_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $soname `test -n "$verstring" && func_echo_all "$wl-set_version $verstring"` -update_registry $output_objdir/so_locations -o $lib' + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl-rpath $wl$libdir' + ;; + *) + _LT_TAGVAR(allow_undefined_flag, $1)=' -expect_unresolved \*' + _LT_TAGVAR(archive_cmds, $1)='$CC -shared$allow_undefined_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags -msym -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry $output_objdir/so_locations -o $lib' + _LT_TAGVAR(archive_expsym_cmds, $1)='for i in `cat $export_symbols`; do printf "%s %s\\n" -exported_symbol "\$i" >> $lib.exp; done~ + echo "-hidden">> $lib.exp~ + $CC -shared$allow_undefined_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags -msym -soname $soname $wl-input $wl$lib.exp `test -n "$verstring" && $ECHO "-set_version $verstring"` -update_registry $output_objdir/so_locations -o $lib~ + $RM $lib.exp' + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-rpath $libdir' + ;; + esac + + _LT_TAGVAR(hardcode_libdir_separator, $1)=: + + # Commands to make compiler produce verbose output that lists + # what "hidden" libraries, object files and flags are used when + # linking a shared library. + # + # There doesn't appear to be a way to prevent this compiler from + # explicitly linking system object files so we need to strip them + # from the output so that they don't get included in the library + # dependencies. + output_verbose_link_cmd='templist=`$CC -shared $CFLAGS -v conftest.$objext 2>&1 | $GREP "ld" | $GREP -v "ld:"`; templist=`func_echo_all "$templist" | $SED "s/\(^.*ld.*\)\( .*ld.*$\)/\1/"`; list= ; for z in $templist; do case $z in conftest.$objext) list="$list $z";; *.$objext);; *) list="$list $z";;esac; done; func_echo_all "$list"' + ;; + *) + if test yes,no = "$GXX,$with_gnu_ld"; then + _LT_TAGVAR(allow_undefined_flag, $1)=' $wl-expect_unresolved $wl\*' + case $host in + osf3*) + _LT_TAGVAR(archive_cmds, $1)='$CC -shared -nostdlib $allow_undefined_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` $wl-update_registry $wl$output_objdir/so_locations -o $lib' + ;; + *) + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag -nostdlib $allow_undefined_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-msym $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` $wl-update_registry $wl$output_objdir/so_locations -o $lib' + ;; + esac + + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl-rpath $wl$libdir' + _LT_TAGVAR(hardcode_libdir_separator, $1)=: + + # Commands to make compiler produce verbose output that lists + # what "hidden" libraries, object files and flags are used when + # linking a shared library. + output_verbose_link_cmd='$CC -shared $CFLAGS -v conftest.$objext 2>&1 | $GREP -v "^Configured with:" | $GREP " \-L"' + + else + # FIXME: insert proper C++ library support + _LT_TAGVAR(ld_shlibs, $1)=no + fi + ;; + esac + ;; + + psos*) + # FIXME: insert proper C++ library support + _LT_TAGVAR(ld_shlibs, $1)=no + ;; + + sunos4*) + case $cc_basename in + CC*) + # Sun C++ 4.x + # FIXME: insert proper C++ library support + _LT_TAGVAR(ld_shlibs, $1)=no + ;; + lcc*) + # Lucid + # FIXME: insert proper C++ library support + _LT_TAGVAR(ld_shlibs, $1)=no + ;; + *) + # FIXME: insert proper C++ library support + _LT_TAGVAR(ld_shlibs, $1)=no + ;; + esac + ;; + + solaris*) + case $cc_basename in + CC* | sunCC*) + # Sun C++ 4.2, 5.x and Centerline C++ + _LT_TAGVAR(archive_cmds_need_lc,$1)=yes + _LT_TAGVAR(no_undefined_flag, $1)=' -zdefs' + _LT_TAGVAR(archive_cmds, $1)='$CC -G$allow_undefined_flag -h$soname -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags' + _LT_TAGVAR(archive_expsym_cmds, $1)='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~ + $CC -G$allow_undefined_flag $wl-M $wl$lib.exp -h$soname -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags~$RM $lib.exp' + + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-R$libdir' + _LT_TAGVAR(hardcode_shlibpath_var, $1)=no + case $host_os in + solaris2.[[0-5]] | solaris2.[[0-5]].*) ;; + *) + # The compiler driver will combine and reorder linker options, + # but understands '-z linker_flag'. + # Supported since Solaris 2.6 (maybe 2.5.1?) + _LT_TAGVAR(whole_archive_flag_spec, $1)='-z allextract$convenience -z defaultextract' + ;; + esac + _LT_TAGVAR(link_all_deplibs, $1)=yes + + output_verbose_link_cmd='func_echo_all' + + # Archives containing C++ object files must be created using + # "CC -xar", where "CC" is the Sun C++ compiler. This is + # necessary to make sure instantiated templates are included + # in the archive. + _LT_TAGVAR(old_archive_cmds, $1)='$CC -xar -o $oldlib $oldobjs' + ;; + gcx*) + # Green Hills C++ Compiler + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-h $wl$soname -o $lib' + + # The C++ compiler must be used to create the archive. + _LT_TAGVAR(old_archive_cmds, $1)='$CC $LDFLAGS -archive -o $oldlib $oldobjs' + ;; + *) + # GNU C++ compiler with Solaris linker + if test yes,no = "$GXX,$with_gnu_ld"; then + _LT_TAGVAR(no_undefined_flag, $1)=' $wl-z ${wl}defs' + if $CC --version | $GREP -v '^2\.7' > /dev/null; then + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-h $wl$soname -o $lib' + _LT_TAGVAR(archive_expsym_cmds, $1)='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~ + $CC -shared $pic_flag -nostdlib $wl-M $wl$lib.exp $wl-h $wl$soname -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags~$RM $lib.exp' + + # Commands to make compiler produce verbose output that lists + # what "hidden" libraries, object files and flags are used when + # linking a shared library. + output_verbose_link_cmd='$CC -shared $CFLAGS -v conftest.$objext 2>&1 | $GREP -v "^Configured with:" | $GREP " \-L"' + else + # g++ 2.7 appears to require '-G' NOT '-shared' on this + # platform. + _LT_TAGVAR(archive_cmds, $1)='$CC -G -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-h $wl$soname -o $lib' + _LT_TAGVAR(archive_expsym_cmds, $1)='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~ + $CC -G -nostdlib $wl-M $wl$lib.exp $wl-h $wl$soname -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags~$RM $lib.exp' + + # Commands to make compiler produce verbose output that lists + # what "hidden" libraries, object files and flags are used when + # linking a shared library. + output_verbose_link_cmd='$CC -G $CFLAGS -v conftest.$objext 2>&1 | $GREP -v "^Configured with:" | $GREP " \-L"' + fi + + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl-R $wl$libdir' + case $host_os in + solaris2.[[0-5]] | solaris2.[[0-5]].*) ;; + *) + _LT_TAGVAR(whole_archive_flag_spec, $1)='$wl-z ${wl}allextract$convenience $wl-z ${wl}defaultextract' + ;; + esac + fi + ;; + esac + ;; + + sysv4*uw2* | sysv5OpenUNIX* | sysv5UnixWare7.[[01]].[[10]]* | unixware7* | sco3.2v5.0.[[024]]*) + _LT_TAGVAR(no_undefined_flag, $1)='$wl-z,text' + _LT_TAGVAR(archive_cmds_need_lc, $1)=no + _LT_TAGVAR(hardcode_shlibpath_var, $1)=no + runpath_var='LD_RUN_PATH' + + case $cc_basename in + CC*) + _LT_TAGVAR(archive_cmds, $1)='$CC -G $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' + _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -G $wl-Bexport:$export_symbols $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' + ;; + *) + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' + _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $wl-Bexport:$export_symbols $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' + ;; + esac + ;; + + sysv5* | sco3.2v5* | sco5v6*) + # Note: We CANNOT use -z defs as we might desire, because we do not + # link with -lc, and that would cause any symbols used from libc to + # always be unresolved, which means just about no library would + # ever link correctly. If we're not using GNU ld we use -z text + # though, which does catch some bad symbols but isn't as heavy-handed + # as -z defs. + _LT_TAGVAR(no_undefined_flag, $1)='$wl-z,text' + _LT_TAGVAR(allow_undefined_flag, $1)='$wl-z,nodefs' + _LT_TAGVAR(archive_cmds_need_lc, $1)=no + _LT_TAGVAR(hardcode_shlibpath_var, $1)=no + _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl-R,$libdir' + _LT_TAGVAR(hardcode_libdir_separator, $1)=':' + _LT_TAGVAR(link_all_deplibs, $1)=yes + _LT_TAGVAR(export_dynamic_flag_spec, $1)='$wl-Bexport' + runpath_var='LD_RUN_PATH' + + case $cc_basename in + CC*) + _LT_TAGVAR(archive_cmds, $1)='$CC -G $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' + _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -G $wl-Bexport:$export_symbols $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' + _LT_TAGVAR(old_archive_cmds, $1)='$CC -Tprelink_objects $oldobjs~ + '"$_LT_TAGVAR(old_archive_cmds, $1)" + _LT_TAGVAR(reload_cmds, $1)='$CC -Tprelink_objects $reload_objs~ + '"$_LT_TAGVAR(reload_cmds, $1)" + ;; + *) + _LT_TAGVAR(archive_cmds, $1)='$CC -shared $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' + _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $wl-Bexport:$export_symbols $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' + ;; + esac + ;; + + tandem*) + case $cc_basename in + NCC*) + # NonStop-UX NCC 3.20 + # FIXME: insert proper C++ library support + _LT_TAGVAR(ld_shlibs, $1)=no + ;; + *) + # FIXME: insert proper C++ library support + _LT_TAGVAR(ld_shlibs, $1)=no + ;; + esac + ;; + + vxworks*) + # FIXME: insert proper C++ library support + _LT_TAGVAR(ld_shlibs, $1)=no + ;; + + *) + # FIXME: insert proper C++ library support + _LT_TAGVAR(ld_shlibs, $1)=no + ;; + esac + + AC_MSG_RESULT([$_LT_TAGVAR(ld_shlibs, $1)]) + test no = "$_LT_TAGVAR(ld_shlibs, $1)" && can_build_shared=no + + _LT_TAGVAR(GCC, $1)=$GXX + _LT_TAGVAR(LD, $1)=$LD + + ## CAVEAT EMPTOR: + ## There is no encapsulation within the following macros, do not change + ## the running order or otherwise move them around unless you know exactly + ## what you are doing... + _LT_SYS_HIDDEN_LIBDEPS($1) + _LT_COMPILER_PIC($1) + _LT_COMPILER_C_O($1) + _LT_COMPILER_FILE_LOCKS($1) + _LT_LINKER_SHLIBS($1) + _LT_SYS_DYNAMIC_LINKER($1) + _LT_LINKER_HARDCODE_LIBPATH($1) + + _LT_CONFIG($1) + fi # test -n "$compiler" + + CC=$lt_save_CC + CFLAGS=$lt_save_CFLAGS + LDCXX=$LD + LD=$lt_save_LD + GCC=$lt_save_GCC + with_gnu_ld=$lt_save_with_gnu_ld + lt_cv_path_LDCXX=$lt_cv_path_LD + lt_cv_path_LD=$lt_save_path_LD + lt_cv_prog_gnu_ldcxx=$lt_cv_prog_gnu_ld + lt_cv_prog_gnu_ld=$lt_save_with_gnu_ld +fi # test yes != "$_lt_caught_CXX_error" + +AC_LANG_POP +])# _LT_LANG_CXX_CONFIG + + +# _LT_FUNC_STRIPNAME_CNF +# ---------------------- +# func_stripname_cnf prefix suffix name +# strip PREFIX and SUFFIX off of NAME. +# PREFIX and SUFFIX must not contain globbing or regex special +# characters, hashes, percent signs, but SUFFIX may contain a leading +# dot (in which case that matches only a dot). +# +# This function is identical to the (non-XSI) version of func_stripname, +# except this one can be used by m4 code that may be executed by configure, +# rather than the libtool script. +m4_defun([_LT_FUNC_STRIPNAME_CNF],[dnl +AC_REQUIRE([_LT_DECL_SED]) +AC_REQUIRE([_LT_PROG_ECHO_BACKSLASH]) +func_stripname_cnf () +{ + case @S|@2 in + .*) func_stripname_result=`$ECHO "@S|@3" | $SED "s%^@S|@1%%; s%\\\\@S|@2\$%%"`;; + *) func_stripname_result=`$ECHO "@S|@3" | $SED "s%^@S|@1%%; s%@S|@2\$%%"`;; + esac +} # func_stripname_cnf +])# _LT_FUNC_STRIPNAME_CNF + + +# _LT_SYS_HIDDEN_LIBDEPS([TAGNAME]) +# --------------------------------- +# Figure out "hidden" library dependencies from verbose +# compiler output when linking a shared library. +# Parse the compiler output and extract the necessary +# objects, libraries and library flags. +m4_defun([_LT_SYS_HIDDEN_LIBDEPS], +[m4_require([_LT_FILEUTILS_DEFAULTS])dnl +AC_REQUIRE([_LT_FUNC_STRIPNAME_CNF])dnl +# Dependencies to place before and after the object being linked: +_LT_TAGVAR(predep_objects, $1)= +_LT_TAGVAR(postdep_objects, $1)= +_LT_TAGVAR(predeps, $1)= +_LT_TAGVAR(postdeps, $1)= +_LT_TAGVAR(compiler_lib_search_path, $1)= + +dnl we can't use the lt_simple_compile_test_code here, +dnl because it contains code intended for an executable, +dnl not a library. It's possible we should let each +dnl tag define a new lt_????_link_test_code variable, +dnl but it's only used here... +m4_if([$1], [], [cat > conftest.$ac_ext <<_LT_EOF +int a; +void foo (void) { a = 0; } +_LT_EOF +], [$1], [CXX], [cat > conftest.$ac_ext <<_LT_EOF +class Foo +{ +public: + Foo (void) { a = 0; } +private: + int a; +}; +_LT_EOF +], [$1], [F77], [cat > conftest.$ac_ext <<_LT_EOF + subroutine foo + implicit none + integer*4 a + a=0 + return + end +_LT_EOF +], [$1], [FC], [cat > conftest.$ac_ext <<_LT_EOF + subroutine foo + implicit none + integer a + a=0 + return + end +_LT_EOF +], [$1], [GCJ], [cat > conftest.$ac_ext <<_LT_EOF +public class foo { + private int a; + public void bar (void) { + a = 0; + } +}; +_LT_EOF +], [$1], [GO], [cat > conftest.$ac_ext <<_LT_EOF +package foo +func foo() { +} +_LT_EOF +]) + +_lt_libdeps_save_CFLAGS=$CFLAGS +case "$CC $CFLAGS " in #( +*\ -flto*\ *) CFLAGS="$CFLAGS -fno-lto" ;; +*\ -fwhopr*\ *) CFLAGS="$CFLAGS -fno-whopr" ;; +*\ -fuse-linker-plugin*\ *) CFLAGS="$CFLAGS -fno-use-linker-plugin" ;; +esac + +dnl Parse the compiler output and extract the necessary +dnl objects, libraries and library flags. +if AC_TRY_EVAL(ac_compile); then + # Parse the compiler output and extract the necessary + # objects, libraries and library flags. + + # Sentinel used to keep track of whether or not we are before + # the conftest object file. + pre_test_object_deps_done=no + + for p in `eval "$output_verbose_link_cmd"`; do + case $prev$p in + + -L* | -R* | -l*) + # Some compilers place space between "-{L,R}" and the path. + # Remove the space. + if test x-L = "$p" || + test x-R = "$p"; then + prev=$p + continue + fi + + # Expand the sysroot to ease extracting the directories later. + if test -z "$prev"; then + case $p in + -L*) func_stripname_cnf '-L' '' "$p"; prev=-L; p=$func_stripname_result ;; + -R*) func_stripname_cnf '-R' '' "$p"; prev=-R; p=$func_stripname_result ;; + -l*) func_stripname_cnf '-l' '' "$p"; prev=-l; p=$func_stripname_result ;; + esac + fi + case $p in + =*) func_stripname_cnf '=' '' "$p"; p=$lt_sysroot$func_stripname_result ;; + esac + if test no = "$pre_test_object_deps_done"; then + case $prev in + -L | -R) + # Internal compiler library paths should come after those + # provided the user. The postdeps already come after the + # user supplied libs so there is no need to process them. + if test -z "$_LT_TAGVAR(compiler_lib_search_path, $1)"; then + _LT_TAGVAR(compiler_lib_search_path, $1)=$prev$p + else + _LT_TAGVAR(compiler_lib_search_path, $1)="${_LT_TAGVAR(compiler_lib_search_path, $1)} $prev$p" + fi + ;; + # The "-l" case would never come before the object being + # linked, so don't bother handling this case. + esac + else + if test -z "$_LT_TAGVAR(postdeps, $1)"; then + _LT_TAGVAR(postdeps, $1)=$prev$p + else + _LT_TAGVAR(postdeps, $1)="${_LT_TAGVAR(postdeps, $1)} $prev$p" + fi + fi + prev= + ;; + + *.lto.$objext) ;; # Ignore GCC LTO objects + *.$objext) + # This assumes that the test object file only shows up + # once in the compiler output. + if test "$p" = "conftest.$objext"; then + pre_test_object_deps_done=yes + continue + fi + + if test no = "$pre_test_object_deps_done"; then + if test -z "$_LT_TAGVAR(predep_objects, $1)"; then + _LT_TAGVAR(predep_objects, $1)=$p + else + _LT_TAGVAR(predep_objects, $1)="$_LT_TAGVAR(predep_objects, $1) $p" + fi + else + if test -z "$_LT_TAGVAR(postdep_objects, $1)"; then + _LT_TAGVAR(postdep_objects, $1)=$p + else + _LT_TAGVAR(postdep_objects, $1)="$_LT_TAGVAR(postdep_objects, $1) $p" + fi + fi + ;; + + *) ;; # Ignore the rest. + + esac + done + + # Clean up. + rm -f a.out a.exe +else + echo "libtool.m4: error: problem compiling $1 test program" +fi + +$RM -f confest.$objext +CFLAGS=$_lt_libdeps_save_CFLAGS + +# PORTME: override above test on systems where it is broken +m4_if([$1], [CXX], +[case $host_os in +interix[[3-9]]*) + # Interix 3.5 installs completely hosed .la files for C++, so rather than + # hack all around it, let's just trust "g++" to DTRT. + _LT_TAGVAR(predep_objects,$1)= + _LT_TAGVAR(postdep_objects,$1)= + _LT_TAGVAR(postdeps,$1)= + ;; +esac +]) + +case " $_LT_TAGVAR(postdeps, $1) " in +*" -lc "*) _LT_TAGVAR(archive_cmds_need_lc, $1)=no ;; +esac + _LT_TAGVAR(compiler_lib_search_dirs, $1)= +if test -n "${_LT_TAGVAR(compiler_lib_search_path, $1)}"; then + _LT_TAGVAR(compiler_lib_search_dirs, $1)=`echo " ${_LT_TAGVAR(compiler_lib_search_path, $1)}" | $SED -e 's! -L! !g' -e 's!^ !!'` +fi +_LT_TAGDECL([], [compiler_lib_search_dirs], [1], + [The directories searched by this compiler when creating a shared library]) +_LT_TAGDECL([], [predep_objects], [1], + [Dependencies to place before and after the objects being linked to + create a shared library]) +_LT_TAGDECL([], [postdep_objects], [1]) +_LT_TAGDECL([], [predeps], [1]) +_LT_TAGDECL([], [postdeps], [1]) +_LT_TAGDECL([], [compiler_lib_search_path], [1], + [The library search path used internally by the compiler when linking + a shared library]) +])# _LT_SYS_HIDDEN_LIBDEPS + + +# _LT_LANG_F77_CONFIG([TAG]) +# -------------------------- +# Ensure that the configuration variables for a Fortran 77 compiler are +# suitably defined. These variables are subsequently used by _LT_CONFIG +# to write the compiler configuration to 'libtool'. +m4_defun([_LT_LANG_F77_CONFIG], +[AC_LANG_PUSH(Fortran 77) +if test -z "$F77" || test no = "$F77"; then + _lt_disable_F77=yes +fi + +_LT_TAGVAR(archive_cmds_need_lc, $1)=no +_LT_TAGVAR(allow_undefined_flag, $1)= +_LT_TAGVAR(always_export_symbols, $1)=no +_LT_TAGVAR(archive_expsym_cmds, $1)= +_LT_TAGVAR(export_dynamic_flag_spec, $1)= +_LT_TAGVAR(hardcode_direct, $1)=no +_LT_TAGVAR(hardcode_direct_absolute, $1)=no +_LT_TAGVAR(hardcode_libdir_flag_spec, $1)= +_LT_TAGVAR(hardcode_libdir_separator, $1)= +_LT_TAGVAR(hardcode_minus_L, $1)=no +_LT_TAGVAR(hardcode_automatic, $1)=no +_LT_TAGVAR(inherit_rpath, $1)=no +_LT_TAGVAR(module_cmds, $1)= +_LT_TAGVAR(module_expsym_cmds, $1)= +_LT_TAGVAR(link_all_deplibs, $1)=unknown +_LT_TAGVAR(old_archive_cmds, $1)=$old_archive_cmds +_LT_TAGVAR(reload_flag, $1)=$reload_flag +_LT_TAGVAR(reload_cmds, $1)=$reload_cmds +_LT_TAGVAR(no_undefined_flag, $1)= +_LT_TAGVAR(whole_archive_flag_spec, $1)= +_LT_TAGVAR(enable_shared_with_static_runtimes, $1)=no + +# Source file extension for f77 test sources. +ac_ext=f + +# Object file extension for compiled f77 test sources. +objext=o +_LT_TAGVAR(objext, $1)=$objext + +# No sense in running all these tests if we already determined that +# the F77 compiler isn't working. Some variables (like enable_shared) +# are currently assumed to apply to all compilers on this platform, +# and will be corrupted by setting them based on a non-working compiler. +if test yes != "$_lt_disable_F77"; then + # Code to be used in simple compile tests + lt_simple_compile_test_code="\ + subroutine t + return + end +" + + # Code to be used in simple link tests + lt_simple_link_test_code="\ + program t + end +" + + # ltmain only uses $CC for tagged configurations so make sure $CC is set. + _LT_TAG_COMPILER + + # save warnings/boilerplate of simple test code + _LT_COMPILER_BOILERPLATE + _LT_LINKER_BOILERPLATE + + # Allow CC to be a program name with arguments. + lt_save_CC=$CC + lt_save_GCC=$GCC + lt_save_CFLAGS=$CFLAGS + CC=${F77-"f77"} + CFLAGS=$FFLAGS + compiler=$CC + _LT_TAGVAR(compiler, $1)=$CC + _LT_CC_BASENAME([$compiler]) + GCC=$G77 + if test -n "$compiler"; then + AC_MSG_CHECKING([if libtool supports shared libraries]) + AC_MSG_RESULT([$can_build_shared]) + + AC_MSG_CHECKING([whether to build shared libraries]) + test no = "$can_build_shared" && enable_shared=no + + # On AIX, shared libraries and static libraries use the same namespace, and + # are all built from PIC. + case $host_os in + aix3*) + test yes = "$enable_shared" && enable_static=no + if test -n "$RANLIB"; then + archive_cmds="$archive_cmds~\$RANLIB \$lib" + postinstall_cmds='$RANLIB $lib' + fi + ;; + aix[[4-9]]*) + if test ia64 != "$host_cpu"; then + case $enable_shared,$with_aix_soname,$aix_use_runtimelinking in + yes,aix,yes) ;; # shared object as lib.so file only + yes,svr4,*) ;; # shared object as lib.so archive member only + yes,*) enable_static=no ;; # shared object in lib.a archive as well + esac + fi + ;; + esac + AC_MSG_RESULT([$enable_shared]) + + AC_MSG_CHECKING([whether to build static libraries]) + # Make sure either enable_shared or enable_static is yes. + test yes = "$enable_shared" || enable_static=yes + AC_MSG_RESULT([$enable_static]) + + _LT_TAGVAR(GCC, $1)=$G77 + _LT_TAGVAR(LD, $1)=$LD + + ## CAVEAT EMPTOR: + ## There is no encapsulation within the following macros, do not change + ## the running order or otherwise move them around unless you know exactly + ## what you are doing... + _LT_COMPILER_PIC($1) + _LT_COMPILER_C_O($1) + _LT_COMPILER_FILE_LOCKS($1) + _LT_LINKER_SHLIBS($1) + _LT_SYS_DYNAMIC_LINKER($1) + _LT_LINKER_HARDCODE_LIBPATH($1) + + _LT_CONFIG($1) + fi # test -n "$compiler" + + GCC=$lt_save_GCC + CC=$lt_save_CC + CFLAGS=$lt_save_CFLAGS +fi # test yes != "$_lt_disable_F77" + +AC_LANG_POP +])# _LT_LANG_F77_CONFIG + + +# _LT_LANG_FC_CONFIG([TAG]) +# ------------------------- +# Ensure that the configuration variables for a Fortran compiler are +# suitably defined. These variables are subsequently used by _LT_CONFIG +# to write the compiler configuration to 'libtool'. +m4_defun([_LT_LANG_FC_CONFIG], +[AC_LANG_PUSH(Fortran) + +if test -z "$FC" || test no = "$FC"; then + _lt_disable_FC=yes +fi + +_LT_TAGVAR(archive_cmds_need_lc, $1)=no +_LT_TAGVAR(allow_undefined_flag, $1)= +_LT_TAGVAR(always_export_symbols, $1)=no +_LT_TAGVAR(archive_expsym_cmds, $1)= +_LT_TAGVAR(export_dynamic_flag_spec, $1)= +_LT_TAGVAR(hardcode_direct, $1)=no +_LT_TAGVAR(hardcode_direct_absolute, $1)=no +_LT_TAGVAR(hardcode_libdir_flag_spec, $1)= +_LT_TAGVAR(hardcode_libdir_separator, $1)= +_LT_TAGVAR(hardcode_minus_L, $1)=no +_LT_TAGVAR(hardcode_automatic, $1)=no +_LT_TAGVAR(inherit_rpath, $1)=no +_LT_TAGVAR(module_cmds, $1)= +_LT_TAGVAR(module_expsym_cmds, $1)= +_LT_TAGVAR(link_all_deplibs, $1)=unknown +_LT_TAGVAR(old_archive_cmds, $1)=$old_archive_cmds +_LT_TAGVAR(reload_flag, $1)=$reload_flag +_LT_TAGVAR(reload_cmds, $1)=$reload_cmds +_LT_TAGVAR(no_undefined_flag, $1)= +_LT_TAGVAR(whole_archive_flag_spec, $1)= +_LT_TAGVAR(enable_shared_with_static_runtimes, $1)=no + +# Source file extension for fc test sources. +ac_ext=${ac_fc_srcext-f} + +# Object file extension for compiled fc test sources. +objext=o +_LT_TAGVAR(objext, $1)=$objext + +# No sense in running all these tests if we already determined that +# the FC compiler isn't working. Some variables (like enable_shared) +# are currently assumed to apply to all compilers on this platform, +# and will be corrupted by setting them based on a non-working compiler. +if test yes != "$_lt_disable_FC"; then + # Code to be used in simple compile tests + lt_simple_compile_test_code="\ + subroutine t + return + end +" + + # Code to be used in simple link tests + lt_simple_link_test_code="\ + program t + end +" + + # ltmain only uses $CC for tagged configurations so make sure $CC is set. + _LT_TAG_COMPILER + + # save warnings/boilerplate of simple test code + _LT_COMPILER_BOILERPLATE + _LT_LINKER_BOILERPLATE + + # Allow CC to be a program name with arguments. + lt_save_CC=$CC + lt_save_GCC=$GCC + lt_save_CFLAGS=$CFLAGS + CC=${FC-"f95"} + CFLAGS=$FCFLAGS + compiler=$CC + GCC=$ac_cv_fc_compiler_gnu + + _LT_TAGVAR(compiler, $1)=$CC + _LT_CC_BASENAME([$compiler]) + + if test -n "$compiler"; then + AC_MSG_CHECKING([if libtool supports shared libraries]) + AC_MSG_RESULT([$can_build_shared]) + + AC_MSG_CHECKING([whether to build shared libraries]) + test no = "$can_build_shared" && enable_shared=no + + # On AIX, shared libraries and static libraries use the same namespace, and + # are all built from PIC. + case $host_os in + aix3*) + test yes = "$enable_shared" && enable_static=no + if test -n "$RANLIB"; then + archive_cmds="$archive_cmds~\$RANLIB \$lib" + postinstall_cmds='$RANLIB $lib' + fi + ;; + aix[[4-9]]*) + if test ia64 != "$host_cpu"; then + case $enable_shared,$with_aix_soname,$aix_use_runtimelinking in + yes,aix,yes) ;; # shared object as lib.so file only + yes,svr4,*) ;; # shared object as lib.so archive member only + yes,*) enable_static=no ;; # shared object in lib.a archive as well + esac + fi + ;; + esac + AC_MSG_RESULT([$enable_shared]) + + AC_MSG_CHECKING([whether to build static libraries]) + # Make sure either enable_shared or enable_static is yes. + test yes = "$enable_shared" || enable_static=yes + AC_MSG_RESULT([$enable_static]) + + _LT_TAGVAR(GCC, $1)=$ac_cv_fc_compiler_gnu + _LT_TAGVAR(LD, $1)=$LD + + ## CAVEAT EMPTOR: + ## There is no encapsulation within the following macros, do not change + ## the running order or otherwise move them around unless you know exactly + ## what you are doing... + _LT_SYS_HIDDEN_LIBDEPS($1) + _LT_COMPILER_PIC($1) + _LT_COMPILER_C_O($1) + _LT_COMPILER_FILE_LOCKS($1) + _LT_LINKER_SHLIBS($1) + _LT_SYS_DYNAMIC_LINKER($1) + _LT_LINKER_HARDCODE_LIBPATH($1) + + _LT_CONFIG($1) + fi # test -n "$compiler" + + GCC=$lt_save_GCC + CC=$lt_save_CC + CFLAGS=$lt_save_CFLAGS +fi # test yes != "$_lt_disable_FC" + +AC_LANG_POP +])# _LT_LANG_FC_CONFIG + + +# _LT_LANG_GCJ_CONFIG([TAG]) +# -------------------------- +# Ensure that the configuration variables for the GNU Java Compiler compiler +# are suitably defined. These variables are subsequently used by _LT_CONFIG +# to write the compiler configuration to 'libtool'. +m4_defun([_LT_LANG_GCJ_CONFIG], +[AC_REQUIRE([LT_PROG_GCJ])dnl +AC_LANG_SAVE + +# Source file extension for Java test sources. +ac_ext=java + +# Object file extension for compiled Java test sources. +objext=o +_LT_TAGVAR(objext, $1)=$objext + +# Code to be used in simple compile tests +lt_simple_compile_test_code="class foo {}" + +# Code to be used in simple link tests +lt_simple_link_test_code='public class conftest { public static void main(String[[]] argv) {}; }' + +# ltmain only uses $CC for tagged configurations so make sure $CC is set. +_LT_TAG_COMPILER + +# save warnings/boilerplate of simple test code +_LT_COMPILER_BOILERPLATE +_LT_LINKER_BOILERPLATE + +# Allow CC to be a program name with arguments. +lt_save_CC=$CC +lt_save_CFLAGS=$CFLAGS +lt_save_GCC=$GCC +GCC=yes +CC=${GCJ-"gcj"} +CFLAGS=$GCJFLAGS +compiler=$CC +_LT_TAGVAR(compiler, $1)=$CC +_LT_TAGVAR(LD, $1)=$LD +_LT_CC_BASENAME([$compiler]) + +# GCJ did not exist at the time GCC didn't implicitly link libc in. +_LT_TAGVAR(archive_cmds_need_lc, $1)=no + +_LT_TAGVAR(old_archive_cmds, $1)=$old_archive_cmds +_LT_TAGVAR(reload_flag, $1)=$reload_flag +_LT_TAGVAR(reload_cmds, $1)=$reload_cmds + +## CAVEAT EMPTOR: +## There is no encapsulation within the following macros, do not change +## the running order or otherwise move them around unless you know exactly +## what you are doing... +if test -n "$compiler"; then + _LT_COMPILER_NO_RTTI($1) + _LT_COMPILER_PIC($1) + _LT_COMPILER_C_O($1) + _LT_COMPILER_FILE_LOCKS($1) + _LT_LINKER_SHLIBS($1) + _LT_LINKER_HARDCODE_LIBPATH($1) + + _LT_CONFIG($1) +fi + +AC_LANG_RESTORE + +GCC=$lt_save_GCC +CC=$lt_save_CC +CFLAGS=$lt_save_CFLAGS +])# _LT_LANG_GCJ_CONFIG + + +# _LT_LANG_GO_CONFIG([TAG]) +# -------------------------- +# Ensure that the configuration variables for the GNU Go compiler +# are suitably defined. These variables are subsequently used by _LT_CONFIG +# to write the compiler configuration to 'libtool'. +m4_defun([_LT_LANG_GO_CONFIG], +[AC_REQUIRE([LT_PROG_GO])dnl +AC_LANG_SAVE + +# Source file extension for Go test sources. +ac_ext=go + +# Object file extension for compiled Go test sources. +objext=o +_LT_TAGVAR(objext, $1)=$objext + +# Code to be used in simple compile tests +lt_simple_compile_test_code="package main; func main() { }" + +# Code to be used in simple link tests +lt_simple_link_test_code='package main; func main() { }' + +# ltmain only uses $CC for tagged configurations so make sure $CC is set. +_LT_TAG_COMPILER + +# save warnings/boilerplate of simple test code +_LT_COMPILER_BOILERPLATE +_LT_LINKER_BOILERPLATE + +# Allow CC to be a program name with arguments. +lt_save_CC=$CC +lt_save_CFLAGS=$CFLAGS +lt_save_GCC=$GCC +GCC=yes +CC=${GOC-"gccgo"} +CFLAGS=$GOFLAGS +compiler=$CC +_LT_TAGVAR(compiler, $1)=$CC +_LT_TAGVAR(LD, $1)=$LD +_LT_CC_BASENAME([$compiler]) + +# Go did not exist at the time GCC didn't implicitly link libc in. +_LT_TAGVAR(archive_cmds_need_lc, $1)=no + +_LT_TAGVAR(old_archive_cmds, $1)=$old_archive_cmds +_LT_TAGVAR(reload_flag, $1)=$reload_flag +_LT_TAGVAR(reload_cmds, $1)=$reload_cmds + +## CAVEAT EMPTOR: +## There is no encapsulation within the following macros, do not change +## the running order or otherwise move them around unless you know exactly +## what you are doing... +if test -n "$compiler"; then + _LT_COMPILER_NO_RTTI($1) + _LT_COMPILER_PIC($1) + _LT_COMPILER_C_O($1) + _LT_COMPILER_FILE_LOCKS($1) + _LT_LINKER_SHLIBS($1) + _LT_LINKER_HARDCODE_LIBPATH($1) + + _LT_CONFIG($1) +fi + +AC_LANG_RESTORE + +GCC=$lt_save_GCC +CC=$lt_save_CC +CFLAGS=$lt_save_CFLAGS +])# _LT_LANG_GO_CONFIG + + +# _LT_LANG_RC_CONFIG([TAG]) +# ------------------------- +# Ensure that the configuration variables for the Windows resource compiler +# are suitably defined. These variables are subsequently used by _LT_CONFIG +# to write the compiler configuration to 'libtool'. +m4_defun([_LT_LANG_RC_CONFIG], +[AC_REQUIRE([LT_PROG_RC])dnl +AC_LANG_SAVE + +# Source file extension for RC test sources. +ac_ext=rc + +# Object file extension for compiled RC test sources. +objext=o +_LT_TAGVAR(objext, $1)=$objext + +# Code to be used in simple compile tests +lt_simple_compile_test_code='sample MENU { MENUITEM "&Soup", 100, CHECKED }' + +# Code to be used in simple link tests +lt_simple_link_test_code=$lt_simple_compile_test_code + +# ltmain only uses $CC for tagged configurations so make sure $CC is set. +_LT_TAG_COMPILER + +# save warnings/boilerplate of simple test code +_LT_COMPILER_BOILERPLATE +_LT_LINKER_BOILERPLATE + +# Allow CC to be a program name with arguments. +lt_save_CC=$CC +lt_save_CFLAGS=$CFLAGS +lt_save_GCC=$GCC +GCC= +CC=${RC-"windres"} +CFLAGS= +compiler=$CC +_LT_TAGVAR(compiler, $1)=$CC +_LT_CC_BASENAME([$compiler]) +_LT_TAGVAR(lt_cv_prog_compiler_c_o, $1)=yes + +if test -n "$compiler"; then + : + _LT_CONFIG($1) +fi + +GCC=$lt_save_GCC +AC_LANG_RESTORE +CC=$lt_save_CC +CFLAGS=$lt_save_CFLAGS +])# _LT_LANG_RC_CONFIG + + +# LT_PROG_GCJ +# ----------- +AC_DEFUN([LT_PROG_GCJ], +[m4_ifdef([AC_PROG_GCJ], [AC_PROG_GCJ], + [m4_ifdef([A][M_PROG_GCJ], [A][M_PROG_GCJ], + [AC_CHECK_TOOL(GCJ, gcj,) + test set = "${GCJFLAGS+set}" || GCJFLAGS="-g -O2" + AC_SUBST(GCJFLAGS)])])[]dnl +]) + +# Old name: +AU_ALIAS([LT_AC_PROG_GCJ], [LT_PROG_GCJ]) +dnl aclocal-1.4 backwards compatibility: +dnl AC_DEFUN([LT_AC_PROG_GCJ], []) + + +# LT_PROG_GO +# ---------- +AC_DEFUN([LT_PROG_GO], +[AC_CHECK_TOOL(GOC, gccgo,) +]) + + +# LT_PROG_RC +# ---------- +AC_DEFUN([LT_PROG_RC], +[AC_CHECK_TOOL(RC, windres,) +]) + +# Old name: +AU_ALIAS([LT_AC_PROG_RC], [LT_PROG_RC]) +dnl aclocal-1.4 backwards compatibility: +dnl AC_DEFUN([LT_AC_PROG_RC], []) + + +# _LT_DECL_EGREP +# -------------- +# If we don't have a new enough Autoconf to choose the best grep +# available, choose the one first in the user's PATH. +m4_defun([_LT_DECL_EGREP], +[AC_REQUIRE([AC_PROG_EGREP])dnl +AC_REQUIRE([AC_PROG_FGREP])dnl +test -z "$GREP" && GREP=grep +_LT_DECL([], [GREP], [1], [A grep program that handles long lines]) +_LT_DECL([], [EGREP], [1], [An ERE matcher]) +_LT_DECL([], [FGREP], [1], [A literal string matcher]) +dnl Non-bleeding-edge autoconf doesn't subst GREP, so do it here too +AC_SUBST([GREP]) +]) + + +# _LT_DECL_OBJDUMP +# -------------- +# If we don't have a new enough Autoconf to choose the best objdump +# available, choose the one first in the user's PATH. +m4_defun([_LT_DECL_OBJDUMP], +[AC_CHECK_TOOL(OBJDUMP, objdump, false) +test -z "$OBJDUMP" && OBJDUMP=objdump +_LT_DECL([], [OBJDUMP], [1], [An object symbol dumper]) +AC_SUBST([OBJDUMP]) +]) + +# _LT_DECL_DLLTOOL +# ---------------- +# Ensure DLLTOOL variable is set. +m4_defun([_LT_DECL_DLLTOOL], +[AC_CHECK_TOOL(DLLTOOL, dlltool, false) +test -z "$DLLTOOL" && DLLTOOL=dlltool +_LT_DECL([], [DLLTOOL], [1], [DLL creation program]) +AC_SUBST([DLLTOOL]) +]) + +# _LT_DECL_FILECMD +# ---------------- +# Check for a file(cmd) program that can be used to detect file type and magic +m4_defun([_LT_DECL_FILECMD], +[AC_CHECK_TOOL([FILECMD], [file], [:]) +_LT_DECL([], [FILECMD], [1], [A file(cmd) program that detects file types]) +])# _LD_DECL_FILECMD + +# _LT_DECL_SED +# ------------ +# Check for a fully-functional sed program, that truncates +# as few characters as possible. Prefer GNU sed if found. +m4_defun([_LT_DECL_SED], +[AC_PROG_SED +test -z "$SED" && SED=sed +Xsed="$SED -e 1s/^X//" +_LT_DECL([], [SED], [1], [A sed program that does not truncate output]) +_LT_DECL([], [Xsed], ["\$SED -e 1s/^X//"], + [Sed that helps us avoid accidentally triggering echo(1) options like -n]) +])# _LT_DECL_SED + +m4_ifndef([AC_PROG_SED], [ +############################################################ +# NOTE: This macro has been submitted for inclusion into # +# GNU Autoconf as AC_PROG_SED. When it is available in # +# a released version of Autoconf we should remove this # +# macro and use it instead. # +############################################################ + +m4_defun([AC_PROG_SED], +[AC_MSG_CHECKING([for a sed that does not truncate output]) +AC_CACHE_VAL(lt_cv_path_SED, +[# Loop through the user's path and test for sed and gsed. +# Then use that list of sed's as ones to test for truncation. +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for lt_ac_prog in sed gsed; do + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$lt_ac_prog$ac_exec_ext"; then + lt_ac_sed_list="$lt_ac_sed_list $as_dir/$lt_ac_prog$ac_exec_ext" + fi + done + done +done +IFS=$as_save_IFS +lt_ac_max=0 +lt_ac_count=0 +# Add /usr/xpg4/bin/sed as it is typically found on Solaris +# along with /bin/sed that truncates output. +for lt_ac_sed in $lt_ac_sed_list /usr/xpg4/bin/sed; do + test ! -f "$lt_ac_sed" && continue + cat /dev/null > conftest.in + lt_ac_count=0 + echo $ECHO_N "0123456789$ECHO_C" >conftest.in + # Check for GNU sed and select it if it is found. + if "$lt_ac_sed" --version 2>&1 < /dev/null | grep 'GNU' > /dev/null; then + lt_cv_path_SED=$lt_ac_sed + break + fi + while true; do + cat conftest.in conftest.in >conftest.tmp + mv conftest.tmp conftest.in + cp conftest.in conftest.nl + echo >>conftest.nl + $lt_ac_sed -e 's/a$//' < conftest.nl >conftest.out || break + cmp -s conftest.out conftest.nl || break + # 10000 chars as input seems more than enough + test 10 -lt "$lt_ac_count" && break + lt_ac_count=`expr $lt_ac_count + 1` + if test "$lt_ac_count" -gt "$lt_ac_max"; then + lt_ac_max=$lt_ac_count + lt_cv_path_SED=$lt_ac_sed + fi + done +done +]) +SED=$lt_cv_path_SED +AC_SUBST([SED]) +AC_MSG_RESULT([$SED]) +])#AC_PROG_SED +])#m4_ifndef + +# Old name: +AU_ALIAS([LT_AC_PROG_SED], [AC_PROG_SED]) +dnl aclocal-1.4 backwards compatibility: +dnl AC_DEFUN([LT_AC_PROG_SED], []) + + +# _LT_CHECK_SHELL_FEATURES +# ------------------------ +# Find out whether the shell is Bourne or XSI compatible, +# or has some other useful features. +m4_defun([_LT_CHECK_SHELL_FEATURES], +[if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then + lt_unset=unset +else + lt_unset=false +fi +_LT_DECL([], [lt_unset], [0], [whether the shell understands "unset"])dnl + +# test EBCDIC or ASCII +case `echo X|tr X '\101'` in + A) # ASCII based system + # \n is not interpreted correctly by Solaris 8 /usr/ucb/tr + lt_SP2NL='tr \040 \012' + lt_NL2SP='tr \015\012 \040\040' + ;; + *) # EBCDIC based system + lt_SP2NL='tr \100 \n' + lt_NL2SP='tr \r\n \100\100' + ;; +esac +_LT_DECL([SP2NL], [lt_SP2NL], [1], [turn spaces into newlines])dnl +_LT_DECL([NL2SP], [lt_NL2SP], [1], [turn newlines into spaces])dnl +])# _LT_CHECK_SHELL_FEATURES + + +# _LT_PATH_CONVERSION_FUNCTIONS +# ----------------------------- +# Determine what file name conversion functions should be used by +# func_to_host_file (and, implicitly, by func_to_host_path). These are needed +# for certain cross-compile configurations and native mingw. +m4_defun([_LT_PATH_CONVERSION_FUNCTIONS], +[AC_REQUIRE([AC_CANONICAL_HOST])dnl +AC_REQUIRE([AC_CANONICAL_BUILD])dnl +AC_MSG_CHECKING([how to convert $build file names to $host format]) +AC_CACHE_VAL(lt_cv_to_host_file_cmd, +[case $host in + *-*-mingw* ) + case $build in + *-*-mingw* ) # actually msys + lt_cv_to_host_file_cmd=func_convert_file_msys_to_w32 + ;; + *-*-cygwin* ) + lt_cv_to_host_file_cmd=func_convert_file_cygwin_to_w32 + ;; + * ) # otherwise, assume *nix + lt_cv_to_host_file_cmd=func_convert_file_nix_to_w32 + ;; + esac + ;; + *-*-cygwin* ) + case $build in + *-*-mingw* ) # actually msys + lt_cv_to_host_file_cmd=func_convert_file_msys_to_cygwin + ;; + *-*-cygwin* ) + lt_cv_to_host_file_cmd=func_convert_file_noop + ;; + * ) # otherwise, assume *nix + lt_cv_to_host_file_cmd=func_convert_file_nix_to_cygwin + ;; + esac + ;; + * ) # unhandled hosts (and "normal" native builds) + lt_cv_to_host_file_cmd=func_convert_file_noop + ;; +esac +]) +to_host_file_cmd=$lt_cv_to_host_file_cmd +AC_MSG_RESULT([$lt_cv_to_host_file_cmd]) +_LT_DECL([to_host_file_cmd], [lt_cv_to_host_file_cmd], + [0], [convert $build file names to $host format])dnl + +AC_MSG_CHECKING([how to convert $build file names to toolchain format]) +AC_CACHE_VAL(lt_cv_to_tool_file_cmd, +[#assume ordinary cross tools, or native build. +lt_cv_to_tool_file_cmd=func_convert_file_noop +case $host in + *-*-mingw* ) + case $build in + *-*-mingw* ) # actually msys + lt_cv_to_tool_file_cmd=func_convert_file_msys_to_w32 + ;; + esac + ;; +esac +]) +to_tool_file_cmd=$lt_cv_to_tool_file_cmd +AC_MSG_RESULT([$lt_cv_to_tool_file_cmd]) +_LT_DECL([to_tool_file_cmd], [lt_cv_to_tool_file_cmd], + [0], [convert $build files to toolchain format])dnl +])# _LT_PATH_CONVERSION_FUNCTIONS diff --git a/3rdparty/curl-8.21.0/m4/ltoptions.m4 b/3rdparty/curl-8.21.0/m4/ltoptions.m4 new file mode 100644 index 0000000000..b0b5e9c212 --- /dev/null +++ b/3rdparty/curl-8.21.0/m4/ltoptions.m4 @@ -0,0 +1,437 @@ +# Helper functions for option handling. -*- Autoconf -*- +# +# Copyright (C) 2004-2005, 2007-2009, 2011-2019, 2021-2022 Free +# Software Foundation, Inc. +# Written by Gary V. Vaughan, 2004 +# +# This file is free software; the Free Software Foundation gives +# unlimited permission to copy and/or distribute it, with or without +# modifications, as long as this notice is preserved. + +# serial 8 ltoptions.m4 + +# This is to help aclocal find these macros, as it can't see m4_define. +AC_DEFUN([LTOPTIONS_VERSION], [m4_if([1])]) + + +# _LT_MANGLE_OPTION(MACRO-NAME, OPTION-NAME) +# ------------------------------------------ +m4_define([_LT_MANGLE_OPTION], +[[_LT_OPTION_]m4_bpatsubst($1__$2, [[^a-zA-Z0-9_]], [_])]) + + +# _LT_SET_OPTION(MACRO-NAME, OPTION-NAME) +# --------------------------------------- +# Set option OPTION-NAME for macro MACRO-NAME, and if there is a +# matching handler defined, dispatch to it. Other OPTION-NAMEs are +# saved as a flag. +m4_define([_LT_SET_OPTION], +[m4_define(_LT_MANGLE_OPTION([$1], [$2]))dnl +m4_ifdef(_LT_MANGLE_DEFUN([$1], [$2]), + _LT_MANGLE_DEFUN([$1], [$2]), + [m4_warning([Unknown $1 option '$2'])])[]dnl +]) + + +# _LT_IF_OPTION(MACRO-NAME, OPTION-NAME, IF-SET, [IF-NOT-SET]) +# ------------------------------------------------------------ +# Execute IF-SET if OPTION is set, IF-NOT-SET otherwise. +m4_define([_LT_IF_OPTION], +[m4_ifdef(_LT_MANGLE_OPTION([$1], [$2]), [$3], [$4])]) + + +# _LT_UNLESS_OPTIONS(MACRO-NAME, OPTION-LIST, IF-NOT-SET) +# ------------------------------------------------------- +# Execute IF-NOT-SET unless all options in OPTION-LIST for MACRO-NAME +# are set. +m4_define([_LT_UNLESS_OPTIONS], +[m4_foreach([_LT_Option], m4_split(m4_normalize([$2])), + [m4_ifdef(_LT_MANGLE_OPTION([$1], _LT_Option), + [m4_define([$0_found])])])[]dnl +m4_ifdef([$0_found], [m4_undefine([$0_found])], [$3 +])[]dnl +]) + + +# _LT_SET_OPTIONS(MACRO-NAME, OPTION-LIST) +# ---------------------------------------- +# OPTION-LIST is a space-separated list of Libtool options associated +# with MACRO-NAME. If any OPTION has a matching handler declared with +# LT_OPTION_DEFINE, dispatch to that macro; otherwise complain about +# the unknown option and exit. +m4_defun([_LT_SET_OPTIONS], +[# Set options +m4_foreach([_LT_Option], m4_split(m4_normalize([$2])), + [_LT_SET_OPTION([$1], _LT_Option)]) + +m4_if([$1],[LT_INIT],[ + dnl + dnl Simply set some default values (i.e off) if boolean options were not + dnl specified: + _LT_UNLESS_OPTIONS([LT_INIT], [dlopen], [enable_dlopen=no + ]) + _LT_UNLESS_OPTIONS([LT_INIT], [win32-dll], [enable_win32_dll=no + ]) + dnl + dnl If no reference was made to various pairs of opposing options, then + dnl we run the default mode handler for the pair. For example, if neither + dnl 'shared' nor 'disable-shared' was passed, we enable building of shared + dnl archives by default: + _LT_UNLESS_OPTIONS([LT_INIT], [shared disable-shared], [_LT_ENABLE_SHARED]) + _LT_UNLESS_OPTIONS([LT_INIT], [static disable-static], [_LT_ENABLE_STATIC]) + _LT_UNLESS_OPTIONS([LT_INIT], [pic-only no-pic], [_LT_WITH_PIC]) + _LT_UNLESS_OPTIONS([LT_INIT], [fast-install disable-fast-install], + [_LT_ENABLE_FAST_INSTALL]) + _LT_UNLESS_OPTIONS([LT_INIT], [aix-soname=aix aix-soname=both aix-soname=svr4], + [_LT_WITH_AIX_SONAME([aix])]) + ]) +])# _LT_SET_OPTIONS + + +## --------------------------------- ## +## Macros to handle LT_INIT options. ## +## --------------------------------- ## + +# _LT_MANGLE_DEFUN(MACRO-NAME, OPTION-NAME) +# ----------------------------------------- +m4_define([_LT_MANGLE_DEFUN], +[[_LT_OPTION_DEFUN_]m4_bpatsubst(m4_toupper([$1__$2]), [[^A-Z0-9_]], [_])]) + + +# LT_OPTION_DEFINE(MACRO-NAME, OPTION-NAME, CODE) +# ----------------------------------------------- +m4_define([LT_OPTION_DEFINE], +[m4_define(_LT_MANGLE_DEFUN([$1], [$2]), [$3])[]dnl +])# LT_OPTION_DEFINE + + +# dlopen +# ------ +LT_OPTION_DEFINE([LT_INIT], [dlopen], [enable_dlopen=yes +]) + +AU_DEFUN([AC_LIBTOOL_DLOPEN], +[_LT_SET_OPTION([LT_INIT], [dlopen]) +AC_DIAGNOSE([obsolete], +[$0: Remove this warning and the call to _LT_SET_OPTION when you +put the 'dlopen' option into LT_INIT's first parameter.]) +]) + +dnl aclocal-1.4 backwards compatibility: +dnl AC_DEFUN([AC_LIBTOOL_DLOPEN], []) + + +# win32-dll +# --------- +# Declare package support for building win32 dll's. +LT_OPTION_DEFINE([LT_INIT], [win32-dll], +[enable_win32_dll=yes + +case $host in +*-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-cegcc*) + AC_CHECK_TOOL(AS, as, false) + AC_CHECK_TOOL(DLLTOOL, dlltool, false) + AC_CHECK_TOOL(OBJDUMP, objdump, false) + ;; +esac + +test -z "$AS" && AS=as +_LT_DECL([], [AS], [1], [Assembler program])dnl + +test -z "$DLLTOOL" && DLLTOOL=dlltool +_LT_DECL([], [DLLTOOL], [1], [DLL creation program])dnl + +test -z "$OBJDUMP" && OBJDUMP=objdump +_LT_DECL([], [OBJDUMP], [1], [Object dumper program])dnl +])# win32-dll + +AU_DEFUN([AC_LIBTOOL_WIN32_DLL], +[AC_REQUIRE([AC_CANONICAL_HOST])dnl +_LT_SET_OPTION([LT_INIT], [win32-dll]) +AC_DIAGNOSE([obsolete], +[$0: Remove this warning and the call to _LT_SET_OPTION when you +put the 'win32-dll' option into LT_INIT's first parameter.]) +]) + +dnl aclocal-1.4 backwards compatibility: +dnl AC_DEFUN([AC_LIBTOOL_WIN32_DLL], []) + + +# _LT_ENABLE_SHARED([DEFAULT]) +# ---------------------------- +# implement the --enable-shared flag, and supports the 'shared' and +# 'disable-shared' LT_INIT options. +# DEFAULT is either 'yes' or 'no'. If omitted, it defaults to 'yes'. +m4_define([_LT_ENABLE_SHARED], +[m4_define([_LT_ENABLE_SHARED_DEFAULT], [m4_if($1, no, no, yes)])dnl +AC_ARG_ENABLE([shared], + [AS_HELP_STRING([--enable-shared@<:@=PKGS@:>@], + [build shared libraries @<:@default=]_LT_ENABLE_SHARED_DEFAULT[@:>@])], + [p=${PACKAGE-default} + case $enableval in + yes) enable_shared=yes ;; + no) enable_shared=no ;; + *) + enable_shared=no + # Look at the argument we got. We use all the common list separators. + lt_save_ifs=$IFS; IFS=$IFS$PATH_SEPARATOR, + for pkg in $enableval; do + IFS=$lt_save_ifs + if test "X$pkg" = "X$p"; then + enable_shared=yes + fi + done + IFS=$lt_save_ifs + ;; + esac], + [enable_shared=]_LT_ENABLE_SHARED_DEFAULT) + + _LT_DECL([build_libtool_libs], [enable_shared], [0], + [Whether or not to build shared libraries]) +])# _LT_ENABLE_SHARED + +LT_OPTION_DEFINE([LT_INIT], [shared], [_LT_ENABLE_SHARED([yes])]) +LT_OPTION_DEFINE([LT_INIT], [disable-shared], [_LT_ENABLE_SHARED([no])]) + +# Old names: +AC_DEFUN([AC_ENABLE_SHARED], +[_LT_SET_OPTION([LT_INIT], m4_if([$1], [no], [disable-])[shared]) +]) + +AC_DEFUN([AC_DISABLE_SHARED], +[_LT_SET_OPTION([LT_INIT], [disable-shared]) +]) + +AU_DEFUN([AM_ENABLE_SHARED], [AC_ENABLE_SHARED($@)]) +AU_DEFUN([AM_DISABLE_SHARED], [AC_DISABLE_SHARED($@)]) + +dnl aclocal-1.4 backwards compatibility: +dnl AC_DEFUN([AM_ENABLE_SHARED], []) +dnl AC_DEFUN([AM_DISABLE_SHARED], []) + + + +# _LT_ENABLE_STATIC([DEFAULT]) +# ---------------------------- +# implement the --enable-static flag, and support the 'static' and +# 'disable-static' LT_INIT options. +# DEFAULT is either 'yes' or 'no'. If omitted, it defaults to 'yes'. +m4_define([_LT_ENABLE_STATIC], +[m4_define([_LT_ENABLE_STATIC_DEFAULT], [m4_if($1, no, no, yes)])dnl +AC_ARG_ENABLE([static], + [AS_HELP_STRING([--enable-static@<:@=PKGS@:>@], + [build static libraries @<:@default=]_LT_ENABLE_STATIC_DEFAULT[@:>@])], + [p=${PACKAGE-default} + case $enableval in + yes) enable_static=yes ;; + no) enable_static=no ;; + *) + enable_static=no + # Look at the argument we got. We use all the common list separators. + lt_save_ifs=$IFS; IFS=$IFS$PATH_SEPARATOR, + for pkg in $enableval; do + IFS=$lt_save_ifs + if test "X$pkg" = "X$p"; then + enable_static=yes + fi + done + IFS=$lt_save_ifs + ;; + esac], + [enable_static=]_LT_ENABLE_STATIC_DEFAULT) + + _LT_DECL([build_old_libs], [enable_static], [0], + [Whether or not to build static libraries]) +])# _LT_ENABLE_STATIC + +LT_OPTION_DEFINE([LT_INIT], [static], [_LT_ENABLE_STATIC([yes])]) +LT_OPTION_DEFINE([LT_INIT], [disable-static], [_LT_ENABLE_STATIC([no])]) + +# Old names: +AC_DEFUN([AC_ENABLE_STATIC], +[_LT_SET_OPTION([LT_INIT], m4_if([$1], [no], [disable-])[static]) +]) + +AC_DEFUN([AC_DISABLE_STATIC], +[_LT_SET_OPTION([LT_INIT], [disable-static]) +]) + +AU_DEFUN([AM_ENABLE_STATIC], [AC_ENABLE_STATIC($@)]) +AU_DEFUN([AM_DISABLE_STATIC], [AC_DISABLE_STATIC($@)]) + +dnl aclocal-1.4 backwards compatibility: +dnl AC_DEFUN([AM_ENABLE_STATIC], []) +dnl AC_DEFUN([AM_DISABLE_STATIC], []) + + + +# _LT_ENABLE_FAST_INSTALL([DEFAULT]) +# ---------------------------------- +# implement the --enable-fast-install flag, and support the 'fast-install' +# and 'disable-fast-install' LT_INIT options. +# DEFAULT is either 'yes' or 'no'. If omitted, it defaults to 'yes'. +m4_define([_LT_ENABLE_FAST_INSTALL], +[m4_define([_LT_ENABLE_FAST_INSTALL_DEFAULT], [m4_if($1, no, no, yes)])dnl +AC_ARG_ENABLE([fast-install], + [AS_HELP_STRING([--enable-fast-install@<:@=PKGS@:>@], + [optimize for fast installation @<:@default=]_LT_ENABLE_FAST_INSTALL_DEFAULT[@:>@])], + [p=${PACKAGE-default} + case $enableval in + yes) enable_fast_install=yes ;; + no) enable_fast_install=no ;; + *) + enable_fast_install=no + # Look at the argument we got. We use all the common list separators. + lt_save_ifs=$IFS; IFS=$IFS$PATH_SEPARATOR, + for pkg in $enableval; do + IFS=$lt_save_ifs + if test "X$pkg" = "X$p"; then + enable_fast_install=yes + fi + done + IFS=$lt_save_ifs + ;; + esac], + [enable_fast_install=]_LT_ENABLE_FAST_INSTALL_DEFAULT) + +_LT_DECL([fast_install], [enable_fast_install], [0], + [Whether or not to optimize for fast installation])dnl +])# _LT_ENABLE_FAST_INSTALL + +LT_OPTION_DEFINE([LT_INIT], [fast-install], [_LT_ENABLE_FAST_INSTALL([yes])]) +LT_OPTION_DEFINE([LT_INIT], [disable-fast-install], [_LT_ENABLE_FAST_INSTALL([no])]) + +# Old names: +AU_DEFUN([AC_ENABLE_FAST_INSTALL], +[_LT_SET_OPTION([LT_INIT], m4_if([$1], [no], [disable-])[fast-install]) +AC_DIAGNOSE([obsolete], +[$0: Remove this warning and the call to _LT_SET_OPTION when you put +the 'fast-install' option into LT_INIT's first parameter.]) +]) + +AU_DEFUN([AC_DISABLE_FAST_INSTALL], +[_LT_SET_OPTION([LT_INIT], [disable-fast-install]) +AC_DIAGNOSE([obsolete], +[$0: Remove this warning and the call to _LT_SET_OPTION when you put +the 'disable-fast-install' option into LT_INIT's first parameter.]) +]) + +dnl aclocal-1.4 backwards compatibility: +dnl AC_DEFUN([AC_ENABLE_FAST_INSTALL], []) +dnl AC_DEFUN([AM_DISABLE_FAST_INSTALL], []) + + +# _LT_WITH_AIX_SONAME([DEFAULT]) +# ---------------------------------- +# implement the --with-aix-soname flag, and support the `aix-soname=aix' +# and `aix-soname=both' and `aix-soname=svr4' LT_INIT options. DEFAULT +# is either `aix', `both' or `svr4'. If omitted, it defaults to `aix'. +m4_define([_LT_WITH_AIX_SONAME], +[m4_define([_LT_WITH_AIX_SONAME_DEFAULT], [m4_if($1, svr4, svr4, m4_if($1, both, both, aix))])dnl +shared_archive_member_spec= +case $host,$enable_shared in +power*-*-aix[[5-9]]*,yes) + AC_MSG_CHECKING([which variant of shared library versioning to provide]) + AC_ARG_WITH([aix-soname], + [AS_HELP_STRING([--with-aix-soname=aix|svr4|both], + [shared library versioning (aka "SONAME") variant to provide on AIX, @<:@default=]_LT_WITH_AIX_SONAME_DEFAULT[@:>@.])], + [case $withval in + aix|svr4|both) + ;; + *) + AC_MSG_ERROR([Unknown argument to --with-aix-soname]) + ;; + esac + lt_cv_with_aix_soname=$with_aix_soname], + [AC_CACHE_VAL([lt_cv_with_aix_soname], + [lt_cv_with_aix_soname=]_LT_WITH_AIX_SONAME_DEFAULT) + with_aix_soname=$lt_cv_with_aix_soname]) + AC_MSG_RESULT([$with_aix_soname]) + if test aix != "$with_aix_soname"; then + # For the AIX way of multilib, we name the shared archive member + # based on the bitwidth used, traditionally 'shr.o' or 'shr_64.o', + # and 'shr.imp' or 'shr_64.imp', respectively, for the Import File. + # Even when GNU compilers ignore OBJECT_MODE but need '-maix64' flag, + # the AIX toolchain works better with OBJECT_MODE set (default 32). + if test 64 = "${OBJECT_MODE-32}"; then + shared_archive_member_spec=shr_64 + else + shared_archive_member_spec=shr + fi + fi + ;; +*) + with_aix_soname=aix + ;; +esac + +_LT_DECL([], [shared_archive_member_spec], [0], + [Shared archive member basename, for filename based shared library versioning on AIX])dnl +])# _LT_WITH_AIX_SONAME + +LT_OPTION_DEFINE([LT_INIT], [aix-soname=aix], [_LT_WITH_AIX_SONAME([aix])]) +LT_OPTION_DEFINE([LT_INIT], [aix-soname=both], [_LT_WITH_AIX_SONAME([both])]) +LT_OPTION_DEFINE([LT_INIT], [aix-soname=svr4], [_LT_WITH_AIX_SONAME([svr4])]) + + +# _LT_WITH_PIC([MODE]) +# -------------------- +# implement the --with-pic flag, and support the 'pic-only' and 'no-pic' +# LT_INIT options. +# MODE is either 'yes' or 'no'. If omitted, it defaults to 'both'. +m4_define([_LT_WITH_PIC], +[AC_ARG_WITH([pic], + [AS_HELP_STRING([--with-pic@<:@=PKGS@:>@], + [try to use only PIC/non-PIC objects @<:@default=use both@:>@])], + [lt_p=${PACKAGE-default} + case $withval in + yes|no) pic_mode=$withval ;; + *) + pic_mode=default + # Look at the argument we got. We use all the common list separators. + lt_save_ifs=$IFS; IFS=$IFS$PATH_SEPARATOR, + for lt_pkg in $withval; do + IFS=$lt_save_ifs + if test "X$lt_pkg" = "X$lt_p"; then + pic_mode=yes + fi + done + IFS=$lt_save_ifs + ;; + esac], + [pic_mode=m4_default([$1], [default])]) + +_LT_DECL([], [pic_mode], [0], [What type of objects to build])dnl +])# _LT_WITH_PIC + +LT_OPTION_DEFINE([LT_INIT], [pic-only], [_LT_WITH_PIC([yes])]) +LT_OPTION_DEFINE([LT_INIT], [no-pic], [_LT_WITH_PIC([no])]) + +# Old name: +AU_DEFUN([AC_LIBTOOL_PICMODE], +[_LT_SET_OPTION([LT_INIT], [pic-only]) +AC_DIAGNOSE([obsolete], +[$0: Remove this warning and the call to _LT_SET_OPTION when you +put the 'pic-only' option into LT_INIT's first parameter.]) +]) + +dnl aclocal-1.4 backwards compatibility: +dnl AC_DEFUN([AC_LIBTOOL_PICMODE], []) + +## ----------------- ## +## LTDL_INIT Options ## +## ----------------- ## + +m4_define([_LTDL_MODE], []) +LT_OPTION_DEFINE([LTDL_INIT], [nonrecursive], + [m4_define([_LTDL_MODE], [nonrecursive])]) +LT_OPTION_DEFINE([LTDL_INIT], [recursive], + [m4_define([_LTDL_MODE], [recursive])]) +LT_OPTION_DEFINE([LTDL_INIT], [subproject], + [m4_define([_LTDL_MODE], [subproject])]) + +m4_define([_LTDL_TYPE], []) +LT_OPTION_DEFINE([LTDL_INIT], [installable], + [m4_define([_LTDL_TYPE], [installable])]) +LT_OPTION_DEFINE([LTDL_INIT], [convenience], + [m4_define([_LTDL_TYPE], [convenience])]) diff --git a/3rdparty/curl-8.21.0/m4/ltsugar.m4 b/3rdparty/curl-8.21.0/m4/ltsugar.m4 new file mode 100644 index 0000000000..902508bd93 --- /dev/null +++ b/3rdparty/curl-8.21.0/m4/ltsugar.m4 @@ -0,0 +1,124 @@ +# ltsugar.m4 -- libtool m4 base layer. -*-Autoconf-*- +# +# Copyright (C) 2004-2005, 2007-2008, 2011-2019, 2021-2022 Free Software +# Foundation, Inc. +# Written by Gary V. Vaughan, 2004 +# +# This file is free software; the Free Software Foundation gives +# unlimited permission to copy and/or distribute it, with or without +# modifications, as long as this notice is preserved. + +# serial 6 ltsugar.m4 + +# This is to help aclocal find these macros, as it can't see m4_define. +AC_DEFUN([LTSUGAR_VERSION], [m4_if([0.1])]) + + +# lt_join(SEP, ARG1, [ARG2...]) +# ----------------------------- +# Produce ARG1SEPARG2...SEPARGn, omitting [] arguments and their +# associated separator. +# Needed until we can rely on m4_join from Autoconf 2.62, since all earlier +# versions in m4sugar had bugs. +m4_define([lt_join], +[m4_if([$#], [1], [], + [$#], [2], [[$2]], + [m4_if([$2], [], [], [[$2]_])$0([$1], m4_shift(m4_shift($@)))])]) +m4_define([_lt_join], +[m4_if([$#$2], [2], [], + [m4_if([$2], [], [], [[$1$2]])$0([$1], m4_shift(m4_shift($@)))])]) + + +# lt_car(LIST) +# lt_cdr(LIST) +# ------------ +# Manipulate m4 lists. +# These macros are necessary as long as will still need to support +# Autoconf-2.59, which quotes differently. +m4_define([lt_car], [[$1]]) +m4_define([lt_cdr], +[m4_if([$#], 0, [m4_fatal([$0: cannot be called without arguments])], + [$#], 1, [], + [m4_dquote(m4_shift($@))])]) +m4_define([lt_unquote], $1) + + +# lt_append(MACRO-NAME, STRING, [SEPARATOR]) +# ------------------------------------------ +# Redefine MACRO-NAME to hold its former content plus 'SEPARATOR''STRING'. +# Note that neither SEPARATOR nor STRING are expanded; they are appended +# to MACRO-NAME as is (leaving the expansion for when MACRO-NAME is invoked). +# No SEPARATOR is output if MACRO-NAME was previously undefined (different +# than defined and empty). +# +# This macro is needed until we can rely on Autoconf 2.62, since earlier +# versions of m4sugar mistakenly expanded SEPARATOR but not STRING. +m4_define([lt_append], +[m4_define([$1], + m4_ifdef([$1], [m4_defn([$1])[$3]])[$2])]) + + + +# lt_combine(SEP, PREFIX-LIST, INFIX, SUFFIX1, [SUFFIX2...]) +# ---------------------------------------------------------- +# Produce a SEP delimited list of all paired combinations of elements of +# PREFIX-LIST with SUFFIX1 through SUFFIXn. Each element of the list +# has the form PREFIXmINFIXSUFFIXn. +# Needed until we can rely on m4_combine added in Autoconf 2.62. +m4_define([lt_combine], +[m4_if(m4_eval([$# > 3]), [1], + [m4_pushdef([_Lt_sep], [m4_define([_Lt_sep], m4_defn([lt_car]))])]]dnl +[[m4_foreach([_Lt_prefix], [$2], + [m4_foreach([_Lt_suffix], + ]m4_dquote(m4_dquote(m4_shift(m4_shift(m4_shift($@)))))[, + [_Lt_sep([$1])[]m4_defn([_Lt_prefix])[$3]m4_defn([_Lt_suffix])])])])]) + + +# lt_if_append_uniq(MACRO-NAME, VARNAME, [SEPARATOR], [UNIQ], [NOT-UNIQ]) +# ----------------------------------------------------------------------- +# Iff MACRO-NAME does not yet contain VARNAME, then append it (delimited +# by SEPARATOR if supplied) and expand UNIQ, else NOT-UNIQ. +m4_define([lt_if_append_uniq], +[m4_ifdef([$1], + [m4_if(m4_index([$3]m4_defn([$1])[$3], [$3$2$3]), [-1], + [lt_append([$1], [$2], [$3])$4], + [$5])], + [lt_append([$1], [$2], [$3])$4])]) + + +# lt_dict_add(DICT, KEY, VALUE) +# ----------------------------- +m4_define([lt_dict_add], +[m4_define([$1($2)], [$3])]) + + +# lt_dict_add_subkey(DICT, KEY, SUBKEY, VALUE) +# -------------------------------------------- +m4_define([lt_dict_add_subkey], +[m4_define([$1($2:$3)], [$4])]) + + +# lt_dict_fetch(DICT, KEY, [SUBKEY]) +# ---------------------------------- +m4_define([lt_dict_fetch], +[m4_ifval([$3], + m4_ifdef([$1($2:$3)], [m4_defn([$1($2:$3)])]), + m4_ifdef([$1($2)], [m4_defn([$1($2)])]))]) + + +# lt_if_dict_fetch(DICT, KEY, [SUBKEY], VALUE, IF-TRUE, [IF-FALSE]) +# ----------------------------------------------------------------- +m4_define([lt_if_dict_fetch], +[m4_if(lt_dict_fetch([$1], [$2], [$3]), [$4], + [$5], + [$6])]) + + +# lt_dict_filter(DICT, [SUBKEY], VALUE, [SEPARATOR], KEY, [...]) +# -------------------------------------------------------------- +m4_define([lt_dict_filter], +[m4_if([$5], [], [], + [lt_join(m4_quote(m4_default([$4], [[, ]])), + lt_unquote(m4_split(m4_normalize(m4_foreach(_Lt_key, lt_car([m4_shiftn(4, $@)]), + [lt_if_dict_fetch([$1], _Lt_key, [$2], [$3], [_Lt_key ])])))))])[]dnl +]) diff --git a/3rdparty/curl-8.21.0/m4/ltversion.m4 b/3rdparty/curl-8.21.0/m4/ltversion.m4 new file mode 100644 index 0000000000..b155d0acec --- /dev/null +++ b/3rdparty/curl-8.21.0/m4/ltversion.m4 @@ -0,0 +1,24 @@ +# ltversion.m4 -- version numbers -*- Autoconf -*- +# +# Copyright (C) 2004, 2011-2019, 2021-2022 Free Software Foundation, +# Inc. +# Written by Scott James Remnant, 2004 +# +# This file is free software; the Free Software Foundation gives +# unlimited permission to copy and/or distribute it, with or without +# modifications, as long as this notice is preserved. + +# @configure_input@ + +# serial 4245 ltversion.m4 +# This file is part of GNU Libtool + +m4_define([LT_PACKAGE_VERSION], [2.4.7]) +m4_define([LT_PACKAGE_REVISION], [2.4.7]) + +AC_DEFUN([LTVERSION_VERSION], +[macro_version='2.4.7' +macro_revision='2.4.7' +_LT_DECL(, macro_version, 0, [Which release of libtool.m4 was used?]) +_LT_DECL(, macro_revision, 0) +]) diff --git a/3rdparty/curl-8.21.0/m4/lt~obsolete.m4 b/3rdparty/curl-8.21.0/m4/lt~obsolete.m4 new file mode 100644 index 0000000000..0f7a8759da --- /dev/null +++ b/3rdparty/curl-8.21.0/m4/lt~obsolete.m4 @@ -0,0 +1,99 @@ +# lt~obsolete.m4 -- aclocal satisfying obsolete definitions. -*-Autoconf-*- +# +# Copyright (C) 2004-2005, 2007, 2009, 2011-2019, 2021-2022 Free +# Software Foundation, Inc. +# Written by Scott James Remnant, 2004. +# +# This file is free software; the Free Software Foundation gives +# unlimited permission to copy and/or distribute it, with or without +# modifications, as long as this notice is preserved. + +# serial 5 lt~obsolete.m4 + +# These exist entirely to fool aclocal when bootstrapping libtool. +# +# In the past libtool.m4 has provided macros via AC_DEFUN (or AU_DEFUN), +# which have later been changed to m4_define as they aren't part of the +# exported API, or moved to Autoconf or Automake where they belong. +# +# The trouble is, aclocal is a bit thick. It'll see the old AC_DEFUN +# in /usr/share/aclocal/libtool.m4 and remember it, then when it sees us +# using a macro with the same name in our local m4/libtool.m4 it'll +# pull the old libtool.m4 in (it doesn't see our shiny new m4_define +# and doesn't know about Autoconf macros at all.) +# +# So we provide this file, which has a silly filename so it's always +# included after everything else. This provides aclocal with the +# AC_DEFUNs it wants, but when m4 processes it, it doesn't do anything +# because those macros already exist, or will be overwritten later. +# We use AC_DEFUN over AU_DEFUN for compatibility with aclocal-1.6. +# +# Anytime we withdraw an AC_DEFUN or AU_DEFUN, remember to add it here. +# Yes, that means every name once taken will need to remain here until +# we give up compatibility with versions before 1.7, at which point +# we need to keep only those names which we still refer to. + +# This is to help aclocal find these macros, as it can't see m4_define. +AC_DEFUN([LTOBSOLETE_VERSION], [m4_if([1])]) + +m4_ifndef([AC_LIBTOOL_LINKER_OPTION], [AC_DEFUN([AC_LIBTOOL_LINKER_OPTION])]) +m4_ifndef([AC_PROG_EGREP], [AC_DEFUN([AC_PROG_EGREP])]) +m4_ifndef([_LT_AC_PROG_ECHO_BACKSLASH], [AC_DEFUN([_LT_AC_PROG_ECHO_BACKSLASH])]) +m4_ifndef([_LT_AC_SHELL_INIT], [AC_DEFUN([_LT_AC_SHELL_INIT])]) +m4_ifndef([_LT_AC_SYS_LIBPATH_AIX], [AC_DEFUN([_LT_AC_SYS_LIBPATH_AIX])]) +m4_ifndef([_LT_PROG_LTMAIN], [AC_DEFUN([_LT_PROG_LTMAIN])]) +m4_ifndef([_LT_AC_TAGVAR], [AC_DEFUN([_LT_AC_TAGVAR])]) +m4_ifndef([AC_LTDL_ENABLE_INSTALL], [AC_DEFUN([AC_LTDL_ENABLE_INSTALL])]) +m4_ifndef([AC_LTDL_PREOPEN], [AC_DEFUN([AC_LTDL_PREOPEN])]) +m4_ifndef([_LT_AC_SYS_COMPILER], [AC_DEFUN([_LT_AC_SYS_COMPILER])]) +m4_ifndef([_LT_AC_LOCK], [AC_DEFUN([_LT_AC_LOCK])]) +m4_ifndef([AC_LIBTOOL_SYS_OLD_ARCHIVE], [AC_DEFUN([AC_LIBTOOL_SYS_OLD_ARCHIVE])]) +m4_ifndef([_LT_AC_TRY_DLOPEN_SELF], [AC_DEFUN([_LT_AC_TRY_DLOPEN_SELF])]) +m4_ifndef([AC_LIBTOOL_PROG_CC_C_O], [AC_DEFUN([AC_LIBTOOL_PROG_CC_C_O])]) +m4_ifndef([AC_LIBTOOL_SYS_HARD_LINK_LOCKS], [AC_DEFUN([AC_LIBTOOL_SYS_HARD_LINK_LOCKS])]) +m4_ifndef([AC_LIBTOOL_OBJDIR], [AC_DEFUN([AC_LIBTOOL_OBJDIR])]) +m4_ifndef([AC_LTDL_OBJDIR], [AC_DEFUN([AC_LTDL_OBJDIR])]) +m4_ifndef([AC_LIBTOOL_PROG_LD_HARDCODE_LIBPATH], [AC_DEFUN([AC_LIBTOOL_PROG_LD_HARDCODE_LIBPATH])]) +m4_ifndef([AC_LIBTOOL_SYS_LIB_STRIP], [AC_DEFUN([AC_LIBTOOL_SYS_LIB_STRIP])]) +m4_ifndef([AC_PATH_MAGIC], [AC_DEFUN([AC_PATH_MAGIC])]) +m4_ifndef([AC_PROG_LD_GNU], [AC_DEFUN([AC_PROG_LD_GNU])]) +m4_ifndef([AC_PROG_LD_RELOAD_FLAG], [AC_DEFUN([AC_PROG_LD_RELOAD_FLAG])]) +m4_ifndef([AC_DEPLIBS_CHECK_METHOD], [AC_DEFUN([AC_DEPLIBS_CHECK_METHOD])]) +m4_ifndef([AC_LIBTOOL_PROG_COMPILER_NO_RTTI], [AC_DEFUN([AC_LIBTOOL_PROG_COMPILER_NO_RTTI])]) +m4_ifndef([AC_LIBTOOL_SYS_GLOBAL_SYMBOL_PIPE], [AC_DEFUN([AC_LIBTOOL_SYS_GLOBAL_SYMBOL_PIPE])]) +m4_ifndef([AC_LIBTOOL_PROG_COMPILER_PIC], [AC_DEFUN([AC_LIBTOOL_PROG_COMPILER_PIC])]) +m4_ifndef([AC_LIBTOOL_PROG_LD_SHLIBS], [AC_DEFUN([AC_LIBTOOL_PROG_LD_SHLIBS])]) +m4_ifndef([AC_LIBTOOL_POSTDEP_PREDEP], [AC_DEFUN([AC_LIBTOOL_POSTDEP_PREDEP])]) +m4_ifndef([LT_AC_PROG_EGREP], [AC_DEFUN([LT_AC_PROG_EGREP])]) +m4_ifndef([LT_AC_PROG_SED], [AC_DEFUN([LT_AC_PROG_SED])]) +m4_ifndef([_LT_CC_BASENAME], [AC_DEFUN([_LT_CC_BASENAME])]) +m4_ifndef([_LT_COMPILER_BOILERPLATE], [AC_DEFUN([_LT_COMPILER_BOILERPLATE])]) +m4_ifndef([_LT_LINKER_BOILERPLATE], [AC_DEFUN([_LT_LINKER_BOILERPLATE])]) +m4_ifndef([_AC_PROG_LIBTOOL], [AC_DEFUN([_AC_PROG_LIBTOOL])]) +m4_ifndef([AC_LIBTOOL_SETUP], [AC_DEFUN([AC_LIBTOOL_SETUP])]) +m4_ifndef([_LT_AC_CHECK_DLFCN], [AC_DEFUN([_LT_AC_CHECK_DLFCN])]) +m4_ifndef([AC_LIBTOOL_SYS_DYNAMIC_LINKER], [AC_DEFUN([AC_LIBTOOL_SYS_DYNAMIC_LINKER])]) +m4_ifndef([_LT_AC_TAGCONFIG], [AC_DEFUN([_LT_AC_TAGCONFIG])]) +m4_ifndef([AC_DISABLE_FAST_INSTALL], [AC_DEFUN([AC_DISABLE_FAST_INSTALL])]) +m4_ifndef([_LT_AC_LANG_CXX], [AC_DEFUN([_LT_AC_LANG_CXX])]) +m4_ifndef([_LT_AC_LANG_F77], [AC_DEFUN([_LT_AC_LANG_F77])]) +m4_ifndef([_LT_AC_LANG_GCJ], [AC_DEFUN([_LT_AC_LANG_GCJ])]) +m4_ifndef([AC_LIBTOOL_LANG_C_CONFIG], [AC_DEFUN([AC_LIBTOOL_LANG_C_CONFIG])]) +m4_ifndef([_LT_AC_LANG_C_CONFIG], [AC_DEFUN([_LT_AC_LANG_C_CONFIG])]) +m4_ifndef([AC_LIBTOOL_LANG_CXX_CONFIG], [AC_DEFUN([AC_LIBTOOL_LANG_CXX_CONFIG])]) +m4_ifndef([_LT_AC_LANG_CXX_CONFIG], [AC_DEFUN([_LT_AC_LANG_CXX_CONFIG])]) +m4_ifndef([AC_LIBTOOL_LANG_F77_CONFIG], [AC_DEFUN([AC_LIBTOOL_LANG_F77_CONFIG])]) +m4_ifndef([_LT_AC_LANG_F77_CONFIG], [AC_DEFUN([_LT_AC_LANG_F77_CONFIG])]) +m4_ifndef([AC_LIBTOOL_LANG_GCJ_CONFIG], [AC_DEFUN([AC_LIBTOOL_LANG_GCJ_CONFIG])]) +m4_ifndef([_LT_AC_LANG_GCJ_CONFIG], [AC_DEFUN([_LT_AC_LANG_GCJ_CONFIG])]) +m4_ifndef([AC_LIBTOOL_LANG_RC_CONFIG], [AC_DEFUN([AC_LIBTOOL_LANG_RC_CONFIG])]) +m4_ifndef([_LT_AC_LANG_RC_CONFIG], [AC_DEFUN([_LT_AC_LANG_RC_CONFIG])]) +m4_ifndef([AC_LIBTOOL_CONFIG], [AC_DEFUN([AC_LIBTOOL_CONFIG])]) +m4_ifndef([_LT_AC_FILE_LTDLL_C], [AC_DEFUN([_LT_AC_FILE_LTDLL_C])]) +m4_ifndef([_LT_REQUIRED_DARWIN_CHECKS], [AC_DEFUN([_LT_REQUIRED_DARWIN_CHECKS])]) +m4_ifndef([_LT_AC_PROG_CXXCPP], [AC_DEFUN([_LT_AC_PROG_CXXCPP])]) +m4_ifndef([_LT_PREPARE_SED_QUOTE_VARS], [AC_DEFUN([_LT_PREPARE_SED_QUOTE_VARS])]) +m4_ifndef([_LT_PROG_ECHO_BACKSLASH], [AC_DEFUN([_LT_PROG_ECHO_BACKSLASH])]) +m4_ifndef([_LT_PROG_F77], [AC_DEFUN([_LT_PROG_F77])]) +m4_ifndef([_LT_PROG_FC], [AC_DEFUN([_LT_PROG_FC])]) +m4_ifndef([_LT_PROG_CXX], [AC_DEFUN([_LT_PROG_CXX])]) diff --git a/3rdparty/curl-8.21.0/m4/xc-am-iface.m4 b/3rdparty/curl-8.21.0/m4/xc-am-iface.m4 new file mode 100644 index 0000000000..069490159b --- /dev/null +++ b/3rdparty/curl-8.21.0/m4/xc-am-iface.m4 @@ -0,0 +1,84 @@ +#--------------------------------------------------------------------------- +# +# xc-am-iface.m4 +# +# Copyright (C) Daniel Stenberg, +# +# Permission to use, copy, modify, and distribute this software for any +# purpose with or without fee is hereby granted, provided that the above +# copyright notice and this permission notice appear in all copies. +# +# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF +# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +# +# SPDX-License-Identifier: ISC +# +#--------------------------------------------------------------------------- + +dnl serial 1 + + +dnl _XC_AUTOMAKE_BODY +dnl ------------------------------------------------- +dnl Private macro. +dnl +dnl This macro performs embedding of automake initialization +dnl code into configure script. When automake version 1.14 or +dnl newer is used at configure script generation time, this +dnl results in 'subdir-objects' automake option being used. +dnl When using automake versions older than 1.14 this option +dnl is not used when generating configure script. +dnl +dnl Existence of automake _AM_PROG_CC_C_O m4 private macro +dnl is used to differentiate automake version 1.14 from older +dnl ones which lack this macro. + +m4_define([_XC_AUTOMAKE_BODY], +[ +dnl --------------------------------------- +dnl Start of automake initialization code +dnl --------------------------------------- +m4_ifdef([_AM_PROG_CC_C_O], +[ +AM_INIT_AUTOMAKE([subdir-objects]) +],[ +AM_INIT_AUTOMAKE +]) +dnl ------------------------------------- +dnl End of automake initialization code +dnl ------------------------------------- +m4_define([$0], [])[] +]) + + +dnl XC_AUTOMAKE +dnl ------------------------------------------------- +dnl Public macro. +dnl +dnl This macro embeds automake machinery into configure +dnl script regardless of automake version used in order +dnl to generate configure script. +dnl +dnl When using automake version 1.14 or newer, automake +dnl initialization option 'subdir-objects' is used to +dnl generate the configure script, otherwise this option +dnl is not used. + +AC_DEFUN([XC_AUTOMAKE], +[ +AC_PREREQ([2.50]) + +AC_BEFORE([$0],[AM_INIT_AUTOMAKE]) + +_XC_AUTOMAKE_BODY + +m4_ifdef([AM_INIT_AUTOMAKE], + [m4_undefine([AM_INIT_AUTOMAKE])]) + +m4_define([$0], [])[] +]) diff --git a/3rdparty/curl-8.21.0/m4/xc-cc-check.m4 b/3rdparty/curl-8.21.0/m4/xc-cc-check.m4 new file mode 100644 index 0000000000..c3294e87f6 --- /dev/null +++ b/3rdparty/curl-8.21.0/m4/xc-cc-check.m4 @@ -0,0 +1,97 @@ +#--------------------------------------------------------------------------- +# +# xc-cc-check.m4 +# +# Copyright (C) Daniel Stenberg, +# +# Permission to use, copy, modify, and distribute this software for any +# purpose with or without fee is hereby granted, provided that the above +# copyright notice and this permission notice appear in all copies. +# +# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF +# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +# +# SPDX-License-Identifier: ISC +# +#--------------------------------------------------------------------------- + +dnl serial 1 + + +dnl _XC_PROG_CC_PREAMBLE +dnl ------------------------------------------------- +dnl Private macro. + +AC_DEFUN([_XC_PROG_CC_PREAMBLE], [ + xc_prog_cc_prev_IFS=$IFS + xc_prog_cc_prev_LIBS=$LIBS + xc_prog_cc_prev_CFLAGS=$CFLAGS + xc_prog_cc_prev_LDFLAGS=$LDFLAGS + xc_prog_cc_prev_CPPFLAGS=$CPPFLAGS +]) + + +dnl _XC_PROG_CC_POSTLUDE +dnl ------------------------------------------------- +dnl Private macro. + +AC_DEFUN([_XC_PROG_CC_POSTLUDE], [ + IFS=$xc_prog_cc_prev_IFS + LIBS=$xc_prog_cc_prev_LIBS + CFLAGS=$xc_prog_cc_prev_CFLAGS + LDFLAGS=$xc_prog_cc_prev_LDFLAGS + CPPFLAGS=$xc_prog_cc_prev_CPPFLAGS + AC_SUBST([CC]) + AC_SUBST([CPP]) + AC_SUBST([LIBS]) + AC_SUBST([CFLAGS]) + AC_SUBST([LDFLAGS]) + AC_SUBST([CPPFLAGS]) +]) + + +dnl _XC_PROG_CC +dnl ------------------------------------------------- +dnl Private macro. + +AC_DEFUN([_XC_PROG_CC], [ + AC_REQUIRE([_XC_PROG_CC_PREAMBLE]) + AC_REQUIRE([XC_CHECK_BUILD_FLAGS]) + AC_REQUIRE([AC_PROG_INSTALL]) + AC_REQUIRE([AC_PROG_CC]) + AC_REQUIRE([AM_PROG_CC_C_O]) + AC_REQUIRE([AC_PROG_CPP]) + AC_REQUIRE([_XC_PROG_CC_POSTLUDE]) +]) + + +dnl XC_CHECK_PROG_CC +dnl ------------------------------------------------- +dnl Public macro. +dnl +dnl Checks for C compiler and C preprocessor programs, +dnl while doing some previous sanity validation on user +dnl provided LIBS, LDFLAGS, CPPFLAGS and CFLAGS values +dnl that must succeed in order to continue execution. +dnl +dnl This sets variables CC and CPP, while preventing +dnl LIBS, LDFLAGS, CFLAGS, CPPFLAGS and IFS from being +dnl unexpectedly changed by underlying macros. + +AC_DEFUN([XC_CHECK_PROG_CC], [ + AC_PREREQ([2.50]) + AC_BEFORE([$0],[_XC_PROG_CC_PREAMBLE]) + AC_BEFORE([$0],[AC_PROG_INSTALL]) + AC_BEFORE([$0],[AC_PROG_CC]) + AC_BEFORE([$0],[AM_PROG_CC_C_O]) + AC_BEFORE([$0],[AC_PROG_CPP]) + AC_BEFORE([$0],[AC_PROG_LIBTOOL]) + AC_BEFORE([$0],[AM_INIT_AUTOMAKE]) + AC_BEFORE([$0],[_XC_PROG_CC_POSTLUDE]) + AC_REQUIRE([_XC_PROG_CC]) +]) diff --git a/3rdparty/curl-8.21.0/m4/xc-lt-iface.m4 b/3rdparty/curl-8.21.0/m4/xc-lt-iface.m4 new file mode 100644 index 0000000000..9f79fdb952 --- /dev/null +++ b/3rdparty/curl-8.21.0/m4/xc-lt-iface.m4 @@ -0,0 +1,464 @@ +#--------------------------------------------------------------------------- +# +# xc-lt-iface.m4 +# +# Copyright (C) Daniel Stenberg, +# +# Permission to use, copy, modify, and distribute this software for any +# purpose with or without fee is hereby granted, provided that the above +# copyright notice and this permission notice appear in all copies. +# +# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF +# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +# +# SPDX-License-Identifier: ISC +# +#--------------------------------------------------------------------------- + +dnl serial 1 + + +dnl _XC_LIBTOOL_PREAMBLE +dnl ------------------------------------------------- +dnl Private macro. +dnl +dnl Checks some configure script options related with +dnl libtool and customizes its default behavior before +dnl libtool code is actually used in script. + +m4_define([_XC_LIBTOOL_PREAMBLE], +[ +dnl ------------------------------------ +dnl Determine libtool default behavior +dnl ------------------------------------ + +dnl +dnl Default behavior is to enable shared and static libraries on systems +dnl where libtool knows how to build both library versions, and does not +dnl require separate configuration and build runs for each flavor. +dnl + +xc_lt_want_enable_shared='yes' +xc_lt_want_enable_static='yes' + +dnl +dnl User may have disabled shared or static libraries. +dnl +case "x$enable_shared" in @%:@ ( + xno) + xc_lt_want_enable_shared='no' + ;; +esac +case "x$enable_static" in @%:@ ( + xno) + xc_lt_want_enable_static='no' + ;; +esac +if test "$xc_lt_want_enable_shared" = "no" && + test "$xc_lt_want_enable_static" = "no"; then + AC_MSG_ERROR([can not disable shared and static libraries simultaneously]) +fi + +dnl +dnl Default behavior on systems that require independent configuration +dnl and build runs for shared and static is to enable shared libraries +dnl and disable static ones. On these systems option '--disable-shared' +dnl must be used in order to build a proper static library. +dnl + +if test "$xc_lt_want_enable_shared" = "yes" && + test "$xc_lt_want_enable_static" = "yes"; then + case $host_os in @%:@ ( + os2* | aix*) + xc_lt_want_enable_static='no' + ;; + esac +fi + +dnl +dnl Make libtool aware of current shared and static library preferences +dnl taking in account that, depending on host characteristics, libtool +dnl may modify these option preferences later in this configure script. +dnl + +enable_shared=$xc_lt_want_enable_shared +enable_static=$xc_lt_want_enable_static + +dnl +dnl Default behavior is to build PIC objects for shared libraries and +dnl non-PIC objects for static libraries. +dnl + +xc_lt_want_with_pic='default' + +dnl +dnl User may have specified PIC preference. +dnl + +case "x$with_pic" in @%:@ (( + xno) + xc_lt_want_with_pic='no' + ;; + xyes) + xc_lt_want_with_pic='yes' + ;; +esac + +dnl +dnl Default behavior on some systems where building a shared library out +dnl of non-PIC compiled objects fails with following linker error +dnl "relocation R_X86_64_32 can not be used when making a shared object" +dnl is to build PIC objects even for static libraries. This behavior may +dnl be overridden using 'configure --disable-shared --without-pic'. +dnl + +if test "$xc_lt_want_with_pic" = "default"; then + case $host_cpu in @%:@ ( + x86_64 | amd64 | ia64) + case $host_os in @%:@ ( + linux* | freebsd* | midnightbsd*) + xc_lt_want_with_pic='yes' + ;; + esac + ;; + esac +fi + +# +# Make libtool aware of current PIC preference taking in account that, +# depending on host characteristics, libtool may modify PIC default +# behavior to fit host system idiosyncrasies later in this script. +# + +with_pic=$xc_lt_want_with_pic + +m4_define([$0],[]) +]) + + +dnl _XC_LIBTOOL_BODY +dnl ------------------------------------------------- +dnl Private macro. +dnl +dnl This macro performs embedding of libtool code into +dnl configure script, regardless of libtool version in +dnl use when generating configure script. + +m4_define([_XC_LIBTOOL_BODY], +[ +dnl ----------------------- +dnl Start of libtool code +dnl ----------------------- +m4_ifdef([LT_INIT], +[ +LT_INIT([win32-dll]) +],[ +AC_LIBTOOL_WIN32_DLL +AC_PROG_LIBTOOL +]) +dnl --------------------- +dnl End of libtool code +dnl --------------------- +dnl +m4_define([$0], [])[] +]) + + +dnl _XC_CHECK_LT_BUILD_LIBRARIES +dnl ------------------------------------------------- +dnl Private macro. +dnl +dnl Checks whether libtool shared and static libraries +dnl are finally built depending on user input, default +dnl behavior and knowledge that libtool has about host +dnl characteristics. +dnl Results stored in following shell variables: +dnl xc_lt_build_shared +dnl xc_lt_build_static + +m4_define([_XC_CHECK_LT_BUILD_LIBRARIES], +[ + +# +# Verify if finally libtool shared libraries are built +# +case "x$enable_shared" in @%:@ (( + xyes | xno) + xc_lt_build_shared=$enable_shared + ;; + *) + AC_MSG_ERROR([unexpected libtool enable_shared value: $enable_shared]) + ;; +esac + +# +# Verify if finally libtool static libraries are built +# +case "x$enable_static" in @%:@ (( + xyes | xno) + xc_lt_build_static=$enable_static + ;; + *) + AC_MSG_ERROR([unexpected libtool enable_static value: $enable_static]) + ;; +esac + +m4_define([$0],[]) +]) + + +dnl _XC_CHECK_LT_SHLIB_USE_VERSION_INFO +dnl ------------------------------------------------- +dnl Private macro. +dnl +dnl Checks if the -version-info linker flag must be +dnl provided when building libtool shared libraries. +dnl Result stored in xc_lt_shlib_use_version_info. + +m4_define([_XC_CHECK_LT_SHLIB_USE_VERSION_INFO], +[ +# +# Verify if libtool shared libraries should be linked using flag -version-info +# + +AC_MSG_CHECKING([whether to build shared libraries with -version-info]) +xc_lt_shlib_use_version_info='yes' +if test "$version_type" = "none"; then + xc_lt_shlib_use_version_info='no' +fi +case $host_os in @%:@ ( + amigaos*) + xc_lt_shlib_use_version_info='yes' + ;; +esac +AC_MSG_RESULT([$xc_lt_shlib_use_version_info]) + +m4_define([$0], [])[] +]) + + +dnl _XC_CHECK_LT_SHLIB_USE_NO_UNDEFINED +dnl ------------------------------------------------- +dnl Private macro. +dnl +dnl Checks if the -no-undefined linker flag must be +dnl provided when building libtool shared libraries. +dnl Result stored in xc_lt_shlib_use_no_undefined. + +m4_define([_XC_CHECK_LT_SHLIB_USE_NO_UNDEFINED], +[ +# +# Verify if libtool shared libraries should be linked using flag -no-undefined +# + +AC_MSG_CHECKING([whether to build shared libraries with -no-undefined]) +xc_lt_shlib_use_no_undefined='no' +if test "x$allow_undefined" = "xno"; then + xc_lt_shlib_use_no_undefined='yes' +elif test "x$allow_undefined_flag" = "xunsupported"; then + xc_lt_shlib_use_no_undefined='yes' +fi +case $host_os in @%:@ ( + cygwin* | mingw* | os2* | aix*) + xc_lt_shlib_use_no_undefined='yes' + ;; +esac +AC_MSG_RESULT([$xc_lt_shlib_use_no_undefined]) + +m4_define([$0], [])[] +]) + + +dnl _XC_CHECK_LT_SHLIB_USE_MIMPURE_TEXT +dnl ------------------------------------------------- +dnl Private macro. +dnl +dnl Checks if the -mimpure-text linker flag must be +dnl provided when building libtool shared libraries. +dnl Result stored in xc_lt_shlib_use_mimpure_text. + +m4_define([_XC_CHECK_LT_SHLIB_USE_MIMPURE_TEXT], +[ +# +# Verify if libtool shared libraries should be linked using flag -mimpure-text +# + +AC_MSG_CHECKING([whether to build shared libraries with -mimpure-text]) +xc_lt_shlib_use_mimpure_text='no' +case $host_os in @%:@ ( + solaris2*) + if test "x$GCC" = "xyes"; then + xc_lt_shlib_use_mimpure_text='yes' + fi + ;; +esac +AC_MSG_RESULT([$xc_lt_shlib_use_mimpure_text]) + +m4_define([$0], [])[] +]) + + +dnl _XC_CHECK_LT_BUILD_WITH_PIC +dnl ------------------------------------------------- +dnl Private macro. +dnl +dnl Checks whether libtool shared and static libraries +dnl would be built with PIC depending on user input, +dnl default behavior and knowledge that libtool has +dnl about host characteristics. +dnl Results stored in following shell variables: +dnl xc_lt_build_shared_with_pic +dnl xc_lt_build_static_with_pic + +m4_define([_XC_CHECK_LT_BUILD_WITH_PIC], +[ +# +# Find out whether libtool libraries would be built with PIC +# + +case "x$pic_mode" in @%:@ (((( + xdefault) + xc_lt_build_shared_with_pic='yes' + xc_lt_build_static_with_pic='no' + ;; + xyes) + xc_lt_build_shared_with_pic='yes' + xc_lt_build_static_with_pic='yes' + ;; + xno) + xc_lt_build_shared_with_pic='no' + xc_lt_build_static_with_pic='no' + ;; + *) + xc_lt_build_shared_with_pic='unknown' + xc_lt_build_static_with_pic='unknown' + AC_MSG_WARN([unexpected libtool pic_mode value: $pic_mode]) + ;; +esac +AC_MSG_CHECKING([whether to build shared libraries with PIC]) +AC_MSG_RESULT([$xc_lt_build_shared_with_pic]) +AC_MSG_CHECKING([whether to build static libraries with PIC]) +AC_MSG_RESULT([$xc_lt_build_static_with_pic]) + +m4_define([$0],[]) +]) + + +dnl _XC_CHECK_LT_BUILD_SINGLE_VERSION +dnl ------------------------------------------------- +dnl Private macro. +dnl +dnl Checks whether a libtool shared or static library +dnl is finally built exclusively without the other. +dnl Results stored in following shell variables: +dnl xc_lt_build_shared_only +dnl xc_lt_build_static_only + +m4_define([_XC_CHECK_LT_BUILD_SINGLE_VERSION], +[ + +# +# Verify if libtool shared libraries are built while static not built +# +AC_MSG_CHECKING([whether to build shared libraries only]) +if test "$xc_lt_build_shared" = "yes" && + test "$xc_lt_build_static" = "no"; then + xc_lt_build_shared_only='yes' +else + xc_lt_build_shared_only='no' +fi +AC_MSG_RESULT([$xc_lt_build_shared_only]) + +# +# Verify if libtool static libraries are built while shared not built +# +AC_MSG_CHECKING([whether to build static libraries only]) +if test "$xc_lt_build_static" = "yes" && + test "$xc_lt_build_shared" = "no"; then + xc_lt_build_static_only='yes' +else + xc_lt_build_static_only='no' +fi +AC_MSG_RESULT([$xc_lt_build_static_only]) + +m4_define([$0],[]) +]) + + +dnl _XC_LIBTOOL_POSTLUDE +dnl ------------------------------------------------- +dnl Private macro. +dnl +dnl Performs several checks related with libtool that +dnl can not be done unless libtool code has already +dnl been executed. See individual check descriptions +dnl for further info. + +m4_define([_XC_LIBTOOL_POSTLUDE], +[ +_XC_CHECK_LT_BUILD_LIBRARIES +_XC_CHECK_LT_SHLIB_USE_VERSION_INFO +_XC_CHECK_LT_SHLIB_USE_NO_UNDEFINED +_XC_CHECK_LT_SHLIB_USE_MIMPURE_TEXT +_XC_CHECK_LT_BUILD_WITH_PIC +_XC_CHECK_LT_BUILD_SINGLE_VERSION + +m4_define([$0],[]) +]) + + +dnl XC_LIBTOOL +dnl ------------------------------------------------- +dnl Public macro. +dnl +dnl This macro embeds libtool machinery into configure +dnl script, regardless of libtool version, and performs +dnl several additional checks whose results can be used +dnl later on. +dnl +dnl Usage of this macro ensures that generated configure +dnl script uses equivalent logic irrespective of autoconf +dnl or libtool version being used to generate configure +dnl script. +dnl +dnl Results stored in following shell variables: +dnl xc_lt_build_shared +dnl xc_lt_build_static +dnl xc_lt_shlib_use_version_info +dnl xc_lt_shlib_use_no_undefined +dnl xc_lt_shlib_use_mimpure_text +dnl xc_lt_build_shared_with_pic +dnl xc_lt_build_static_with_pic +dnl xc_lt_build_shared_only +dnl xc_lt_build_static_only + +AC_DEFUN([XC_LIBTOOL], +[ +AC_PREREQ([2.50]) + +AC_BEFORE([$0],[LT_INIT]) +AC_BEFORE([$0],[AC_PROG_LIBTOOL]) +AC_BEFORE([$0],[AC_LIBTOOL_WIN32_DLL]) + +AC_REQUIRE([XC_CHECK_PATH_SEPARATOR]) +AC_REQUIRE([AC_CANONICAL_HOST]) +AC_REQUIRE([AC_PROG_CC]) + +_XC_LIBTOOL_PREAMBLE +_XC_LIBTOOL_BODY +_XC_LIBTOOL_POSTLUDE + +m4_ifdef([AC_LIBTOOL_WIN32_DLL], + [m4_undefine([AC_LIBTOOL_WIN32_DLL])]) +m4_ifdef([AC_PROG_LIBTOOL], + [m4_undefine([AC_PROG_LIBTOOL])]) +m4_ifdef([LT_INIT], + [m4_undefine([LT_INIT])]) + +m4_define([$0],[]) +]) diff --git a/3rdparty/curl-8.21.0/m4/xc-val-flgs.m4 b/3rdparty/curl-8.21.0/m4/xc-val-flgs.m4 new file mode 100644 index 0000000000..7d3322b512 --- /dev/null +++ b/3rdparty/curl-8.21.0/m4/xc-val-flgs.m4 @@ -0,0 +1,244 @@ +#--------------------------------------------------------------------------- +# +# xc-val-flgs.m4 +# +# Copyright (C) Daniel Stenberg, +# +# Permission to use, copy, modify, and distribute this software for any +# purpose with or without fee is hereby granted, provided that the above +# copyright notice and this permission notice appear in all copies. +# +# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF +# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +# +# SPDX-License-Identifier: ISC +# +#--------------------------------------------------------------------------- + +dnl serial 1 + + +dnl _XC_CHECK_VAR_LIBS +dnl ------------------------------------------------- +dnl Private macro. + +AC_DEFUN([_XC_CHECK_VAR_LIBS], [ + xc_bad_var_libs=no + for xc_word in $LIBS; do + case "$xc_word" in + -l* | --library=*) + : + ;; + *) + xc_bad_var_libs=yes + ;; + esac + done + if test "$xc_bad_var_libs" = "yes"; then + AC_MSG_NOTICE([using LIBS: $LIBS]) + AC_MSG_NOTICE([LIBS note: LIBS should only be used to specify libraries (-lname).]) + fi +]) + + +dnl _XC_CHECK_VAR_LDFLAGS +dnl ------------------------------------------------- +dnl Private macro. + +AC_DEFUN([_XC_CHECK_VAR_LDFLAGS], [ + xc_bad_var_ldflags=no + for xc_word in $LDFLAGS; do + case "$xc_word" in + -D*) + xc_bad_var_ldflags=yes + ;; + -U*) + xc_bad_var_ldflags=yes + ;; + -I*) + xc_bad_var_ldflags=yes + ;; + -l* | --library=*) + xc_bad_var_ldflags=yes + ;; + esac + done + if test "$xc_bad_var_ldflags" = "yes"; then + AC_MSG_NOTICE([using LDFLAGS: $LDFLAGS]) + xc_bad_var_msg="LDFLAGS note: LDFLAGS should only be used to specify linker flags, not" + for xc_word in $LDFLAGS; do + case "$xc_word" in + -D*) + AC_MSG_NOTICE([$xc_bad_var_msg macro definitions. Use CPPFLAGS for: $xc_word]) + ;; + -U*) + AC_MSG_NOTICE([$xc_bad_var_msg macro suppressions. Use CPPFLAGS for: $xc_word]) + ;; + -I*) + AC_MSG_NOTICE([$xc_bad_var_msg include directories. Use CPPFLAGS for: $xc_word]) + ;; + -l* | --library=*) + AC_MSG_NOTICE([$xc_bad_var_msg libraries. Use LIBS for: $xc_word]) + ;; + esac + done + fi +]) + + +dnl _XC_CHECK_VAR_CPPFLAGS +dnl ------------------------------------------------- +dnl Private macro. + +AC_DEFUN([_XC_CHECK_VAR_CPPFLAGS], [ + xc_bad_var_cppflags=no + for xc_word in $CPPFLAGS; do + case "$xc_word" in + -rpath*) + xc_bad_var_cppflags=yes + ;; + -L* | --library-path=*) + xc_bad_var_cppflags=yes + ;; + -l* | --library=*) + xc_bad_var_cppflags=yes + ;; + esac + done + if test "$xc_bad_var_cppflags" = "yes"; then + AC_MSG_NOTICE([using CPPFLAGS: $CPPFLAGS]) + xc_bad_var_msg="CPPFLAGS note: CPPFLAGS should only be used to specify C preprocessor flags, not" + for xc_word in $CPPFLAGS; do + case "$xc_word" in + -rpath*) + AC_MSG_NOTICE([$xc_bad_var_msg library runtime directories. Use LDFLAGS for: $xc_word]) + ;; + -L* | --library-path=*) + AC_MSG_NOTICE([$xc_bad_var_msg library directories. Use LDFLAGS for: $xc_word]) + ;; + -l* | --library=*) + AC_MSG_NOTICE([$xc_bad_var_msg libraries. Use LIBS for: $xc_word]) + ;; + esac + done + fi +]) + + +dnl _XC_CHECK_VAR_CFLAGS +dnl ------------------------------------------------- +dnl Private macro. + +AC_DEFUN([_XC_CHECK_VAR_CFLAGS], [ + xc_bad_var_cflags=no + for xc_word in $CFLAGS; do + case "$xc_word" in + -D*) + xc_bad_var_cflags=yes + ;; + -U*) + xc_bad_var_cflags=yes + ;; + -I*) + xc_bad_var_cflags=yes + ;; + -rpath*) + xc_bad_var_cflags=yes + ;; + -L* | --library-path=*) + xc_bad_var_cflags=yes + ;; + -l* | --library=*) + xc_bad_var_cflags=yes + ;; + esac + done + if test "$xc_bad_var_cflags" = "yes"; then + AC_MSG_NOTICE([using CFLAGS: $CFLAGS]) + xc_bad_var_msg="CFLAGS note: CFLAGS should only be used to specify C compiler flags, not" + for xc_word in $CFLAGS; do + case "$xc_word" in + -D*) + AC_MSG_NOTICE([$xc_bad_var_msg macro definitions. Use CPPFLAGS for: $xc_word]) + ;; + -U*) + AC_MSG_NOTICE([$xc_bad_var_msg macro suppressions. Use CPPFLAGS for: $xc_word]) + ;; + -I*) + AC_MSG_NOTICE([$xc_bad_var_msg include directories. Use CPPFLAGS for: $xc_word]) + ;; + -rpath*) + AC_MSG_NOTICE([$xc_bad_var_msg library runtime directories. Use LDFLAGS for: $xc_word]) + ;; + -L* | --library-path=*) + AC_MSG_NOTICE([$xc_bad_var_msg library directories. Use LDFLAGS for: $xc_word]) + ;; + -l* | --library=*) + AC_MSG_NOTICE([$xc_bad_var_msg libraries. Use LIBS for: $xc_word]) + ;; + esac + done + fi +]) + + +dnl XC_CHECK_USER_FLAGS +dnl ------------------------------------------------- +dnl Public macro. +dnl +dnl Performs some sanity checks for LIBS, LDFLAGS, +dnl CPPFLAGS and CFLAGS values that the user might +dnl have set. When checks fails, user is noticed +dnl about errors detected in all of them and script +dnl execution is halted. +dnl +dnl Intended to be used early in configure script. + +AC_DEFUN([XC_CHECK_USER_FLAGS], [ + AC_PREREQ([2.50]) + AC_BEFORE([$0],[XC_CHECK_PROG_CC]) + dnl check order below matters + _XC_CHECK_VAR_LIBS + _XC_CHECK_VAR_LDFLAGS + _XC_CHECK_VAR_CPPFLAGS + _XC_CHECK_VAR_CFLAGS + if test "$xc_bad_var_libs" = "yes" || + test "$xc_bad_var_cflags" = "yes" || + test "$xc_bad_var_ldflags" = "yes" || + test "$xc_bad_var_cppflags" = "yes"; then + AC_MSG_ERROR([Can not continue. Fix errors mentioned immediately above this line.]) + fi +]) + + +dnl XC_CHECK_BUILD_FLAGS +dnl ------------------------------------------------- +dnl Public macro. +dnl +dnl Performs some sanity checks for LIBS, LDFLAGS, +dnl CPPFLAGS and CFLAGS values that the configure +dnl script might have set. When checks fails, user +dnl is noticed about errors detected in all of them +dnl but script continues execution. +dnl +dnl Intended to be used late in configure script. + +AC_DEFUN([XC_CHECK_BUILD_FLAGS], [ + AC_PREREQ([2.50]) + dnl check order below matters + _XC_CHECK_VAR_LIBS + _XC_CHECK_VAR_LDFLAGS + _XC_CHECK_VAR_CPPFLAGS + _XC_CHECK_VAR_CFLAGS + if test "$xc_bad_var_libs" = "yes" || + test "$xc_bad_var_cflags" = "yes" || + test "$xc_bad_var_ldflags" = "yes" || + test "$xc_bad_var_cppflags" = "yes"; then + AC_MSG_WARN([Continuing even with errors mentioned immediately above this line.]) + fi +]) diff --git a/3rdparty/curl-8.21.0/m4/zz40-xc-ovr.m4 b/3rdparty/curl-8.21.0/m4/zz40-xc-ovr.m4 new file mode 100644 index 0000000000..2713dcc8cb --- /dev/null +++ b/3rdparty/curl-8.21.0/m4/zz40-xc-ovr.m4 @@ -0,0 +1,667 @@ +#--------------------------------------------------------------------------- +# +# zz40-xc-ovr.m4 +# +# Copyright (C) Daniel Stenberg, +# +# Permission to use, copy, modify, and distribute this software for any +# purpose with or without fee is hereby granted, provided that the above +# copyright notice and this permission notice appear in all copies. +# +# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF +# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +# +# SPDX-License-Identifier: ISC +# +#--------------------------------------------------------------------------- + +dnl The funny name of this file is intentional in order to make it +dnl sort alphabetically after any libtool, autoconf or automake +dnl provided .m4 macro file that might get copied into this same +dnl subdirectory. This allows that macro (re)definitions from this +dnl file may override those provided in other files. + + +dnl Version macros +dnl ------------------------------------------------- +dnl Public macros. + +m4_define([XC_CONFIGURE_PREAMBLE_VER_MAJOR],[1]) +m4_define([XC_CONFIGURE_PREAMBLE_VER_MINOR],[0]) + + +dnl _XC_CFG_PRE_PREAMBLE +dnl ------------------------------------------------- +dnl Private macro. + +AC_DEFUN([_XC_CFG_PRE_PREAMBLE], +[ +## -------------------------------- ## +@%:@@%:@ [XC_CONFIGURE_PREAMBLE] ver: []dnl +XC_CONFIGURE_PREAMBLE_VER_MAJOR.[]dnl +XC_CONFIGURE_PREAMBLE_VER_MINOR ## +## -------------------------------- ## + +xc_configure_preamble_ver_major='XC_CONFIGURE_PREAMBLE_VER_MAJOR' +xc_configure_preamble_ver_minor='XC_CONFIGURE_PREAMBLE_VER_MINOR' + +dnl +dnl Set IFS to space, tab and newline. +dnl + +xc_space=' ' +xc_tab=' ' +xc_newline=' +' +IFS="$xc_space$xc_tab$xc_newline" + +dnl +dnl Set internationalization behavior variables. +dnl + +LANG='C' +LC_ALL='C' +LANGUAGE='C' +export LANG +export LC_ALL +export LANGUAGE + +dnl +dnl Some useful variables. +dnl + +xc_msg_warn='configure: WARNING:' +xc_msg_abrt='Can not continue.' +xc_msg_err='configure: error:' +]) + + +dnl _XC_CFG_PRE_BASIC_CHK_CMD_ECHO +dnl ------------------------------------------------- +dnl Private macro. +dnl +dnl Emits shell code that verifies that 'echo' command +dnl is available, otherwise aborts execution. + +AC_DEFUN([_XC_CFG_PRE_BASIC_CHK_CMD_ECHO], +[ +AC_REQUIRE([_XC_CFG_PRE_PREAMBLE]) +dnl +dnl Verify that 'echo' command is available, otherwise abort. +dnl + +xc_tst_str='unknown' +(`echo "$xc_tst_str" >/dev/null 2>&1`) && xc_tst_str='success' +case "x$xc_tst_str" in @%:@ (( + xsuccess) + : + ;; + *) + dnl Try built-in echo, and fail. + echo "$xc_msg_err 'echo' command not found. $xc_msg_abrt" >&2 + exit 1 + ;; +esac +]) + + +dnl _XC_CFG_PRE_BASIC_CHK_CMD_TEST +dnl ------------------------------------------------- +dnl Private macro. +dnl +dnl Emits shell code that verifies that 'test' command +dnl is available, otherwise aborts execution. + +AC_DEFUN([_XC_CFG_PRE_BASIC_CHK_CMD_TEST], +[ +AC_REQUIRE([_XC_CFG_PRE_BASIC_CHK_CMD_ECHO]) +dnl +dnl Verify that 'test' command is available, otherwise abort. +dnl + +xc_tst_str='unknown' +(`test -n "$xc_tst_str" >/dev/null 2>&1`) && xc_tst_str='success' +case "x$xc_tst_str" in @%:@ (( + xsuccess) + : + ;; + *) + echo "$xc_msg_err 'test' command not found. $xc_msg_abrt" >&2 + exit 1 + ;; +esac +]) + + +dnl _XC_CFG_PRE_BASIC_CHK_VAR_PATH +dnl ------------------------------------------------- +dnl Private macro. +dnl +dnl Emits shell code that verifies that 'PATH' variable +dnl is set, otherwise aborts execution. + +AC_DEFUN([_XC_CFG_PRE_BASIC_CHK_VAR_PATH], +[ +AC_REQUIRE([_XC_CFG_PRE_BASIC_CHK_CMD_TEST]) +dnl +dnl Verify that 'PATH' variable is set, otherwise abort. +dnl + +xc_tst_str='unknown' +(`test -n "$PATH" >/dev/null 2>&1`) && xc_tst_str='success' +case "x$xc_tst_str" in @%:@ (( + xsuccess) + : + ;; + *) + echo "$xc_msg_err 'PATH' variable not set. $xc_msg_abrt" >&2 + exit 1 + ;; +esac +]) + + +dnl _XC_CFG_PRE_BASIC_CHK_CMD_EXPR +dnl ------------------------------------------------- +dnl Private macro. +dnl +dnl Emits shell code that verifies that 'expr' command +dnl is available, otherwise aborts execution. + +AC_DEFUN([_XC_CFG_PRE_BASIC_CHK_CMD_EXPR], +[ +AC_REQUIRE([_XC_CFG_PRE_BASIC_CHK_VAR_PATH]) +dnl +dnl Verify that 'expr' command is available, otherwise abort. +dnl + +xc_tst_str='unknown' +xc_tst_str=`expr "$xc_tst_str" : '.*' 2>/dev/null` +case "x$xc_tst_str" in @%:@ (( + x7) + : + ;; + *) + echo "$xc_msg_err 'expr' command not found. $xc_msg_abrt" >&2 + exit 1 + ;; +esac +]) + + +dnl _XC_CFG_PRE_BASIC_CHK_UTIL_SED +dnl ------------------------------------------------- +dnl Private macro. +dnl +dnl Emits shell code that verifies that 'sed' utility +dnl is found within 'PATH', otherwise aborts execution. +dnl +dnl This 'sed' is required in order to allow configure +dnl script bootstrapping itself. No fancy testing for a +dnl proper 'sed' this early, that should be done later. + +AC_DEFUN([_XC_CFG_PRE_BASIC_CHK_UTIL_SED], +[ +AC_REQUIRE([_XC_CFG_PRE_BASIC_CHK_VAR_PATH]) +dnl +dnl Verify that 'sed' utility is found within 'PATH', otherwise abort. +dnl + +xc_tst_str='unknown' +xc_tst_str=`echo "$xc_tst_str" 2>/dev/null \ + | sed -e 's:unknown:success:' 2>/dev/null` +case "x$xc_tst_str" in @%:@ (( + xsuccess) + : + ;; + *) + echo "$xc_msg_err 'sed' utility not found in 'PATH'. $xc_msg_abrt" >&2 + exit 1 + ;; +esac +]) + + +dnl _XC_CFG_PRE_BASIC_CHK_UTIL_GREP +dnl ------------------------------------------------- +dnl Private macro. +dnl +dnl Emits shell code that verifies that 'grep' utility +dnl is found within 'PATH', otherwise aborts execution. +dnl +dnl This 'grep' is required in order to allow configure +dnl script bootstrapping itself. No fancy testing for a +dnl proper 'grep' this early, that should be done later. + +AC_DEFUN([_XC_CFG_PRE_BASIC_CHK_UTIL_GREP], +[ +AC_REQUIRE([_XC_CFG_PRE_BASIC_CHK_VAR_PATH]) +dnl +dnl Verify that 'grep' utility is found within 'PATH', otherwise abort. +dnl + +xc_tst_str='unknown' +(`echo "$xc_tst_str" 2>/dev/null \ + | grep 'unknown' >/dev/null 2>&1`) && xc_tst_str='success' +case "x$xc_tst_str" in @%:@ (( + xsuccess) + : + ;; + *) + echo "$xc_msg_err 'grep' utility not found in 'PATH'. $xc_msg_abrt" >&2 + exit 1 + ;; +esac +]) + + +dnl _XC_CFG_PRE_BASIC_CHK_UTIL_TR +dnl ------------------------------------------------- +dnl Private macro. +dnl +dnl Emits shell code that verifies that 'tr' utility +dnl is found within 'PATH', otherwise aborts execution. + +AC_DEFUN([_XC_CFG_PRE_BASIC_CHK_UTIL_TR], +[ +AC_REQUIRE([_XC_CFG_PRE_BASIC_CHK_VAR_PATH]) +dnl +dnl Verify that 'tr' utility is found within 'PATH', otherwise abort. +dnl + +xc_tst_str="${xc_tab}98s7u6c5c4e3s2s10" +xc_tst_str=`echo "$xc_tst_str" 2>/dev/null \ + | tr -d "0123456789$xc_tab" 2>/dev/null` +case "x$xc_tst_str" in @%:@ (( + xsuccess) + : + ;; + *) + echo "$xc_msg_err 'tr' utility not found in 'PATH'. $xc_msg_abrt" >&2 + exit 1 + ;; +esac +]) + + +dnl _XC_CFG_PRE_BASIC_CHK_UTIL_WC +dnl ------------------------------------------------- +dnl Private macro. +dnl +dnl Emits shell code that verifies that 'wc' utility +dnl is found within 'PATH', otherwise aborts execution. + +AC_DEFUN([_XC_CFG_PRE_BASIC_CHK_UTIL_WC], +[ +AC_REQUIRE([_XC_CFG_PRE_BASIC_CHK_UTIL_TR]) +dnl +dnl Verify that 'wc' utility is found within 'PATH', otherwise abort. +dnl + +xc_tst_str='unknown unknown unknown unknown' +xc_tst_str=`echo "$xc_tst_str" 2>/dev/null \ + | wc -w 2>/dev/null | tr -d "$xc_space$xc_tab" 2>/dev/null` +case "x$xc_tst_str" in @%:@ (( + x4) + : + ;; + *) + echo "$xc_msg_err 'wc' utility not found in 'PATH'. $xc_msg_abrt" >&2 + exit 1 + ;; +esac +]) + + +dnl _XC_CFG_PRE_BASIC_CHK_UTIL_CAT +dnl ------------------------------------------------- +dnl Private macro. +dnl +dnl Emits shell code that verifies that 'cat' utility +dnl is found within 'PATH', otherwise aborts execution. + +AC_DEFUN([_XC_CFG_PRE_BASIC_CHK_UTIL_CAT], +[ +AC_REQUIRE([_XC_CFG_PRE_BASIC_CHK_UTIL_WC]) +dnl +dnl Verify that 'cat' utility is found within 'PATH', otherwise abort. +dnl + +xc_tst_str='unknown' +xc_tst_str=`cat <<_EOT 2>/dev/null \ + | wc -l 2>/dev/null | tr -d "$xc_space$xc_tab" 2>/dev/null +unknown +unknown +unknown +_EOT` +case "x$xc_tst_str" in @%:@ (( + x3) + : + ;; + *) + echo "$xc_msg_err 'cat' utility not found in 'PATH'. $xc_msg_abrt" >&2 + exit 1 + ;; +esac +]) + + +dnl _XC_CFG_PRE_CHECK_PATH_SEPARATOR +dnl ------------------------------------------------- +dnl Private macro. +dnl +dnl Emits shell code that computes the path separator +dnl and stores the result in 'PATH_SEPARATOR', unless +dnl the user has already set it with a non-empty value. +dnl +dnl This path separator is the symbol used to separate +dnl or differentiate paths inside the 'PATH' environment +dnl variable. +dnl +dnl Non-empty user provided 'PATH_SEPARATOR' always +dnl overrides the auto-detected one. + +AC_DEFUN([_XC_CFG_PRE_CHECK_PATH_SEPARATOR], +[ +AC_REQUIRE([_XC_CFG_PRE_BASIC_CHK_CMD_EXPR]) +dnl +dnl Auto-detect and set 'PATH_SEPARATOR', unless it is already non-empty set. +dnl + +dnl Directory count in 'PATH' when using a colon separator. +xc_tst_dirs_col='x' +xc_tst_prev_IFS=$IFS; IFS=':' +for xc_tst_dir in $PATH; do + IFS=$xc_tst_prev_IFS + xc_tst_dirs_col="x$xc_tst_dirs_col" +done +IFS=$xc_tst_prev_IFS +xc_tst_dirs_col=`expr "$xc_tst_dirs_col" : '.*'` + +dnl Directory count in 'PATH' when using a semicolon separator. +xc_tst_dirs_sem='x' +xc_tst_prev_IFS=$IFS; IFS=';' +for xc_tst_dir in $PATH; do + IFS=$xc_tst_prev_IFS + xc_tst_dirs_sem="x$xc_tst_dirs_sem" +done +IFS=$xc_tst_prev_IFS +xc_tst_dirs_sem=`expr "$xc_tst_dirs_sem" : '.*'` + +if test "$xc_tst_dirs_sem" -eq "$xc_tst_dirs_col"; then + dnl When both counting methods give the same result we do not want to + dnl chose one over the other, and consider auto-detection not possible. + if test -z "$PATH_SEPARATOR"; then + dnl User should provide the correct 'PATH_SEPARATOR' definition. + dnl Until then, guess that it is colon! + echo "$xc_msg_warn path separator not determined, guessing colon" >&2 + PATH_SEPARATOR=':' + fi +else + dnl Separator with the greater directory count is the auto-detected one. + if test "$xc_tst_dirs_sem" -gt "$xc_tst_dirs_col"; then + xc_tst_auto_separator=';' + else + xc_tst_auto_separator=':' + fi + if test -z "$PATH_SEPARATOR"; then + dnl Use the auto-detected one when not already set. + PATH_SEPARATOR=$xc_tst_auto_separator + elif test "x$PATH_SEPARATOR" != "x$xc_tst_auto_separator"; then + echo "$xc_msg_warn 'PATH_SEPARATOR' does not match auto-detected one." >&2 + fi +fi +xc_PATH_SEPARATOR=$PATH_SEPARATOR +AC_SUBST([PATH_SEPARATOR]) +]) + + +dnl _XC_CFG_PRE_POSTLUDE +dnl ------------------------------------------------- +dnl Private macro. + +AC_DEFUN([_XC_CFG_PRE_POSTLUDE], +[ +AC_REQUIRE([_XC_CFG_PRE_PREAMBLE]) +AC_REQUIRE([_XC_CFG_PRE_BASIC_CHK_CMD_ECHO]) +AC_REQUIRE([_XC_CFG_PRE_BASIC_CHK_CMD_TEST]) +AC_REQUIRE([_XC_CFG_PRE_BASIC_CHK_VAR_PATH]) +AC_REQUIRE([_XC_CFG_PRE_BASIC_CHK_CMD_EXPR]) +AC_REQUIRE([_XC_CFG_PRE_BASIC_CHK_UTIL_SED]) +AC_REQUIRE([_XC_CFG_PRE_BASIC_CHK_UTIL_GREP]) +AC_REQUIRE([_XC_CFG_PRE_BASIC_CHK_UTIL_TR]) +AC_REQUIRE([_XC_CFG_PRE_BASIC_CHK_UTIL_WC]) +AC_REQUIRE([_XC_CFG_PRE_BASIC_CHK_UTIL_CAT]) +AC_REQUIRE([_XC_CFG_PRE_CHECK_PATH_SEPARATOR]) + +xc_configure_preamble_result='yes' +]) + + +dnl XC_CONFIGURE_PREAMBLE +dnl ------------------------------------------------- +dnl Public macro. +dnl +dnl This macro emits shell code which does some +dnl basic checks related with the availability +dnl of some commands and utilities needed to allow +dnl configure script bootstrapping itself when using +dnl these to figure out other settings. Also emits +dnl code that performs PATH_SEPARATOR auto-detection +dnl and sets its value unless it is already set with +dnl a non-empty value. +dnl +dnl These basic checks are intended to be placed and +dnl executed as early as possible in the resulting +dnl configure script, and as such these must be pure +dnl and portable shell code. +dnl +dnl This macro may be used directly, or indirectly +dnl when using other macros that AC_REQUIRE it such +dnl as XC_CHECK_PATH_SEPARATOR. +dnl +dnl Currently the mechanism used to ensure that this +dnl macro expands early enough in generated configure +dnl script is making it override autoconf and libtool +dnl PATH_SEPARATOR check. + +AC_DEFUN([XC_CONFIGURE_PREAMBLE], +[ +AC_PREREQ([2.50]) + +AC_BEFORE([$0],[_XC_CFG_PRE_PREAMBLE]) +AC_BEFORE([$0],[_XC_CFG_PRE_BASIC_CHK_CMD_ECHO]) +AC_BEFORE([$0],[_XC_CFG_PRE_BASIC_CHK_CMD_TEST]) +AC_BEFORE([$0],[_XC_CFG_PRE_BASIC_CHK_VAR_PATH]) +AC_BEFORE([$0],[_XC_CFG_PRE_BASIC_CHK_CMD_EXPR]) +AC_BEFORE([$0],[_XC_CFG_PRE_BASIC_CHK_UTIL_SED]) +AC_BEFORE([$0],[_XC_CFG_PRE_BASIC_CHK_UTIL_GREP]) +AC_BEFORE([$0],[_XC_CFG_PRE_BASIC_CHK_UTIL_TR]) +AC_BEFORE([$0],[_XC_CFG_PRE_BASIC_CHK_UTIL_WC]) +AC_BEFORE([$0],[_XC_CFG_PRE_BASIC_CHK_UTIL_CAT]) +AC_BEFORE([$0],[_XC_CFG_PRE_CHECK_PATH_SEPARATOR]) +AC_BEFORE([$0],[_XC_CFG_PRE_POSTLUDE]) + +AC_BEFORE([$0],[AC_CHECK_TOOL]) +AC_BEFORE([$0],[AC_CHECK_PROG]) +AC_BEFORE([$0],[AC_CHECK_TOOLS]) +AC_BEFORE([$0],[AC_CHECK_PROGS]) + +AC_BEFORE([$0],[AC_PATH_TOOL]) +AC_BEFORE([$0],[AC_PATH_PROG]) +AC_BEFORE([$0],[AC_PATH_PROGS]) + +AC_BEFORE([$0],[AC_PROG_SED]) +AC_BEFORE([$0],[AC_PROG_GREP]) +AC_BEFORE([$0],[AC_PROG_LN_S]) +AC_BEFORE([$0],[AC_PROG_MKDIR_P]) +AC_BEFORE([$0],[AC_PROG_INSTALL]) +AC_BEFORE([$0],[AC_PROG_MAKE_SET]) +AC_BEFORE([$0],[AC_PROG_LIBTOOL]) + +AC_BEFORE([$0],[LT_INIT]) +AC_BEFORE([$0],[AM_INIT_AUTOMAKE]) +AC_BEFORE([$0],[AC_LIBTOOL_WIN32_DLL]) + +AC_REQUIRE([_XC_CFG_PRE_PREAMBLE]) +AC_REQUIRE([_XC_CFG_PRE_BASIC_CHK_CMD_ECHO]) +AC_REQUIRE([_XC_CFG_PRE_BASIC_CHK_CMD_TEST]) +AC_REQUIRE([_XC_CFG_PRE_BASIC_CHK_VAR_PATH]) +AC_REQUIRE([_XC_CFG_PRE_BASIC_CHK_CMD_EXPR]) +AC_REQUIRE([_XC_CFG_PRE_BASIC_CHK_UTIL_SED]) +AC_REQUIRE([_XC_CFG_PRE_BASIC_CHK_UTIL_GREP]) +AC_REQUIRE([_XC_CFG_PRE_BASIC_CHK_UTIL_TR]) +AC_REQUIRE([_XC_CFG_PRE_BASIC_CHK_UTIL_WC]) +AC_REQUIRE([_XC_CFG_PRE_BASIC_CHK_UTIL_CAT]) +AC_REQUIRE([_XC_CFG_PRE_CHECK_PATH_SEPARATOR]) +AC_REQUIRE([_XC_CFG_PRE_POSTLUDE]) + +m4_pattern_forbid([^_*XC]) +m4_define([$0],[]) +]) + + +dnl Override autoconf and libtool PATH_SEPARATOR check +dnl ------------------------------------------------- +dnl Macros overriding. +dnl +dnl This is done to ensure that the same check is +dnl used across different autoconf versions and to +dnl allow expansion of XC_CONFIGURE_PREAMBLE macro +dnl early enough in the generated configure script. + +dnl +dnl Override when using autoconf 2.53 and newer. +dnl + +m4_ifdef([_AS_PATH_SEPARATOR_PREPARE], +[ +m4_undefine([_AS_PATH_SEPARATOR_PREPARE]) +m4_defun([_AS_PATH_SEPARATOR_PREPARE], +[ +AC_REQUIRE([XC_CONFIGURE_PREAMBLE]) +m4_define([$0],[]) +]) +]) + +dnl +dnl Override when using autoconf 2.50 to 2.52 +dnl + +m4_ifdef([_AC_INIT_PREPARE_FS_SEPARATORS], +[ +m4_undefine([_AC_INIT_PREPARE_FS_SEPARATORS]) +m4_defun([_AC_INIT_PREPARE_FS_SEPARATORS], +[ +AC_REQUIRE([XC_CONFIGURE_PREAMBLE]) +ac_path_separator=$PATH_SEPARATOR +m4_define([$0],[]) +]) +]) + +dnl +dnl Override when using libtool 1.4.2 +dnl + +m4_ifdef([_LT_AC_LIBTOOL_SYS_PATH_SEPARATOR], +[ +m4_undefine([_LT_AC_LIBTOOL_SYS_PATH_SEPARATOR]) +m4_defun([_LT_AC_LIBTOOL_SYS_PATH_SEPARATOR], +[ +AC_REQUIRE([XC_CONFIGURE_PREAMBLE]) +lt_cv_sys_path_separator=$PATH_SEPARATOR +m4_define([$0],[]) +]) +]) + + +dnl XC_CHECK_PATH_SEPARATOR +dnl ------------------------------------------------- +dnl Public macro. +dnl +dnl Usage of this macro ensures that generated configure +dnl script uses the same PATH_SEPARATOR check irrespective +dnl of autoconf or libtool version being used to generate +dnl configure script. +dnl +dnl Emits shell code that computes the path separator +dnl and stores the result in 'PATH_SEPARATOR', unless +dnl the user has already set it with a non-empty value. +dnl +dnl This path separator is the symbol used to separate +dnl or differentiate paths inside the 'PATH' environment +dnl variable. +dnl +dnl Non-empty user provided 'PATH_SEPARATOR' always +dnl overrides the auto-detected one. +dnl +dnl Strictly speaking the check is done in two steps. The +dnl first, which does the actual check, takes place in +dnl XC_CONFIGURE_PREAMBLE macro and happens early in +dnl generated configure script. The second one shows and +dnl logs the result of the check into config.log at a later +dnl configure stage. Placement of this second stage in +dnl generated configure script is done where first +dnl direct or indirect usage of this macro happens. + +AC_DEFUN([XC_CHECK_PATH_SEPARATOR], +[ +AC_PREREQ([2.50]) + +AC_BEFORE([$0],[AC_CHECK_TOOL]) +AC_BEFORE([$0],[AC_CHECK_PROG]) +AC_BEFORE([$0],[AC_CHECK_TOOLS]) +AC_BEFORE([$0],[AC_CHECK_PROGS]) + +AC_BEFORE([$0],[AC_PATH_TOOL]) +AC_BEFORE([$0],[AC_PATH_PROG]) +AC_BEFORE([$0],[AC_PATH_PROGS]) + +AC_BEFORE([$0],[AC_PROG_SED]) +AC_BEFORE([$0],[AC_PROG_GREP]) +AC_BEFORE([$0],[AC_PROG_LN_S]) +AC_BEFORE([$0],[AC_PROG_MKDIR_P]) +AC_BEFORE([$0],[AC_PROG_INSTALL]) +AC_BEFORE([$0],[AC_PROG_MAKE_SET]) +AC_BEFORE([$0],[AC_PROG_LIBTOOL]) + +AC_BEFORE([$0],[LT_INIT]) +AC_BEFORE([$0],[AM_INIT_AUTOMAKE]) +AC_BEFORE([$0],[AC_LIBTOOL_WIN32_DLL]) + +AC_REQUIRE([XC_CONFIGURE_PREAMBLE]) + +dnl +dnl Check that 'XC_CONFIGURE_PREAMBLE' has already run. +dnl + +if test -z "$xc_configure_preamble_result"; then + AC_MSG_ERROR([xc_configure_preamble_result not set (internal problem)]) +fi + +dnl +dnl Check that 'PATH_SEPARATOR' has already been set. +dnl + +if test -z "$xc_PATH_SEPARATOR"; then + AC_MSG_ERROR([xc_PATH_SEPARATOR not set (internal problem)]) +fi +if test -z "$PATH_SEPARATOR"; then + AC_MSG_ERROR([PATH_SEPARATOR not set (internal or config.site problem)]) +fi +AC_MSG_CHECKING([for path separator]) +AC_MSG_RESULT([$PATH_SEPARATOR]) +if test "x$PATH_SEPARATOR" != "x$xc_PATH_SEPARATOR"; then + AC_MSG_CHECKING([for initial path separator]) + AC_MSG_RESULT([$xc_PATH_SEPARATOR]) + AC_MSG_ERROR([path separator mismatch (internal or config.site problem)]) +fi + +m4_pattern_forbid([^_*XC]) +m4_define([$0],[]) +]) diff --git a/3rdparty/curl-8.21.0/m4/zz50-xc-ovr.m4 b/3rdparty/curl-8.21.0/m4/zz50-xc-ovr.m4 new file mode 100644 index 0000000000..563c5ab25a --- /dev/null +++ b/3rdparty/curl-8.21.0/m4/zz50-xc-ovr.m4 @@ -0,0 +1,61 @@ +#--------------------------------------------------------------------------- +# +# zz50-xc-ovr.m4 +# +# Copyright (C) Daniel Stenberg, +# +# Permission to use, copy, modify, and distribute this software for any +# purpose with or without fee is hereby granted, provided that the above +# copyright notice and this permission notice appear in all copies. +# +# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF +# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +# +# SPDX-License-Identifier: ISC +# +#--------------------------------------------------------------------------- + +dnl serial 1 + + +dnl The funny name of this file is intentional in order to make it +dnl sort alphabetically after any libtool, autoconf or automake +dnl provided .m4 macro file that might get copied into this same +dnl subdirectory. This allows that macro (re)definitions from this +dnl file may override those provided in other files. + + +dnl Override some language related macros +dnl ------------------------------------------------- +dnl This is done to prevent Libtool 1.5.X from doing +dnl unnecessary C++, Fortran and Java tests when only +dnl using C language and reduce resulting configure +dnl script by nearly 300 KB. + +m4_ifdef([AC_LIBTOOL_LANG_CXX_CONFIG], + [m4_undefine([AC_LIBTOOL_LANG_CXX_CONFIG])]) +m4_define([AC_LIBTOOL_LANG_CXX_CONFIG],[:]) + +m4_ifdef([AC_LIBTOOL_LANG_F77_CONFIG], + [m4_undefine([AC_LIBTOOL_LANG_F77_CONFIG])]) +m4_define([AC_LIBTOOL_LANG_F77_CONFIG],[:]) + +m4_ifdef([AC_LIBTOOL_LANG_GCJ_CONFIG], + [m4_undefine([AC_LIBTOOL_LANG_GCJ_CONFIG])]) +m4_define([AC_LIBTOOL_LANG_GCJ_CONFIG],[:]) + + +dnl XC_OVR_ZZ50 +dnl ------------------------------------------------- +dnl Placing a call to this macro in configure.ac +dnl makes macros in this file visible to other macros +dnl used for same configure script, overriding those +dnl provided elsewhere. + +AC_DEFUN([XC_OVR_ZZ50], + [AC_BEFORE([$0],[AC_PROG_LIBTOOL])]) diff --git a/3rdparty/curl-8.21.0/missing b/3rdparty/curl-8.21.0/missing new file mode 100755 index 0000000000..1fe1611f18 --- /dev/null +++ b/3rdparty/curl-8.21.0/missing @@ -0,0 +1,215 @@ +#! /bin/sh +# Common wrapper for a few potentially missing GNU programs. + +scriptversion=2018-03-07.03; # UTC + +# Copyright (C) 1996-2021 Free Software Foundation, Inc. +# Originally written by Fran,cois Pinard , 1996. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2, or (at your option) +# any later version. + +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. + +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . + +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program that contains a +# configuration script generated by Autoconf, you may include it under +# the same distribution terms that you use for the rest of that program. + +if test $# -eq 0; then + echo 1>&2 "Try '$0 --help' for more information" + exit 1 +fi + +case $1 in + + --is-lightweight) + # Used by our autoconf macros to check whether the available missing + # script is modern enough. + exit 0 + ;; + + --run) + # Back-compat with the calling convention used by older automake. + shift + ;; + + -h|--h|--he|--hel|--help) + echo "\ +$0 [OPTION]... PROGRAM [ARGUMENT]... + +Run 'PROGRAM [ARGUMENT]...', returning a proper advice when this fails due +to PROGRAM being missing or too old. + +Options: + -h, --help display this help and exit + -v, --version output version information and exit + +Supported PROGRAM values: + aclocal autoconf autoheader autom4te automake makeinfo + bison yacc flex lex help2man + +Version suffixes to PROGRAM as well as the prefixes 'gnu-', 'gnu', and +'g' are ignored when checking the name. + +Send bug reports to ." + exit $? + ;; + + -v|--v|--ve|--ver|--vers|--versi|--versio|--version) + echo "missing $scriptversion (GNU Automake)" + exit $? + ;; + + -*) + echo 1>&2 "$0: unknown '$1' option" + echo 1>&2 "Try '$0 --help' for more information" + exit 1 + ;; + +esac + +# Run the given program, remember its exit status. +"$@"; st=$? + +# If it succeeded, we are done. +test $st -eq 0 && exit 0 + +# Also exit now if we it failed (or wasn't found), and '--version' was +# passed; such an option is passed most likely to detect whether the +# program is present and works. +case $2 in --version|--help) exit $st;; esac + +# Exit code 63 means version mismatch. This often happens when the user +# tries to use an ancient version of a tool on a file that requires a +# minimum version. +if test $st -eq 63; then + msg="probably too old" +elif test $st -eq 127; then + # Program was missing. + msg="missing on your system" +else + # Program was found and executed, but failed. Give up. + exit $st +fi + +perl_URL=https://www.perl.org/ +flex_URL=https://github.com/westes/flex +gnu_software_URL=https://www.gnu.org/software + +program_details () +{ + case $1 in + aclocal|automake) + echo "The '$1' program is part of the GNU Automake package:" + echo "<$gnu_software_URL/automake>" + echo "It also requires GNU Autoconf, GNU m4 and Perl in order to run:" + echo "<$gnu_software_URL/autoconf>" + echo "<$gnu_software_URL/m4/>" + echo "<$perl_URL>" + ;; + autoconf|autom4te|autoheader) + echo "The '$1' program is part of the GNU Autoconf package:" + echo "<$gnu_software_URL/autoconf/>" + echo "It also requires GNU m4 and Perl in order to run:" + echo "<$gnu_software_URL/m4/>" + echo "<$perl_URL>" + ;; + esac +} + +give_advice () +{ + # Normalize program name to check for. + normalized_program=`echo "$1" | sed ' + s/^gnu-//; t + s/^gnu//; t + s/^g//; t'` + + printf '%s\n' "'$1' is $msg." + + configure_deps="'configure.ac' or m4 files included by 'configure.ac'" + case $normalized_program in + autoconf*) + echo "You should only need it if you modified 'configure.ac'," + echo "or m4 files included by it." + program_details 'autoconf' + ;; + autoheader*) + echo "You should only need it if you modified 'acconfig.h' or" + echo "$configure_deps." + program_details 'autoheader' + ;; + automake*) + echo "You should only need it if you modified 'Makefile.am' or" + echo "$configure_deps." + program_details 'automake' + ;; + aclocal*) + echo "You should only need it if you modified 'acinclude.m4' or" + echo "$configure_deps." + program_details 'aclocal' + ;; + autom4te*) + echo "You might have modified some maintainer files that require" + echo "the 'autom4te' program to be rebuilt." + program_details 'autom4te' + ;; + bison*|yacc*) + echo "You should only need it if you modified a '.y' file." + echo "You may want to install the GNU Bison package:" + echo "<$gnu_software_URL/bison/>" + ;; + lex*|flex*) + echo "You should only need it if you modified a '.l' file." + echo "You may want to install the Fast Lexical Analyzer package:" + echo "<$flex_URL>" + ;; + help2man*) + echo "You should only need it if you modified a dependency" \ + "of a man page." + echo "You may want to install the GNU Help2man package:" + echo "<$gnu_software_URL/help2man/>" + ;; + makeinfo*) + echo "You should only need it if you modified a '.texi' file, or" + echo "any other file indirectly affecting the aspect of the manual." + echo "You might want to install the Texinfo package:" + echo "<$gnu_software_URL/texinfo/>" + echo "The spurious makeinfo call might also be the consequence of" + echo "using a buggy 'make' (AIX, DU, IRIX), in which case you might" + echo "want to install GNU make:" + echo "<$gnu_software_URL/make/>" + ;; + *) + echo "You might have modified some files without having the proper" + echo "tools for further handling them. Check the 'README' file, it" + echo "often tells you about the needed prerequisites for installing" + echo "this package. You may also peek at any GNU archive site, in" + echo "case some other package contains this missing '$1' program." + ;; + esac +} + +give_advice "$1" | sed -e '1s/^/WARNING: /' \ + -e '2,$s/^/ /' >&2 + +# Propagate the correct exit status (expected to be 127 for a program +# not found, 63 for a program that failed due to version mismatch). +exit $st + +# Local variables: +# eval: (add-hook 'before-save-hook 'time-stamp) +# time-stamp-start: "scriptversion=" +# time-stamp-format: "%:y-%02m-%02d.%02H" +# time-stamp-time-zone: "UTC0" +# time-stamp-end: "; # UTC" +# End: diff --git a/3rdparty/curl-8.21.0/projects/Makefile.am b/3rdparty/curl-8.21.0/projects/Makefile.am new file mode 100644 index 0000000000..bf7f3a05ab --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/Makefile.am @@ -0,0 +1,60 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +SUBDIRS = vms + +EXTRA_DIST = README.md \ + OS400/.checksrc \ + OS400/README.OS400 \ + OS400/rpg-examples \ + OS400/ccsidcurl.c \ + OS400/ccsidcurl.h \ + OS400/curlcl.c \ + OS400/curlmain.c \ + OS400/curl.inc.in \ + OS400/initscript.sh \ + OS400/config400.default \ + OS400/make-docs.sh \ + OS400/make-include.sh \ + OS400/make-lib.sh \ + OS400/make-src.sh \ + OS400/make-tests.sh \ + OS400/makefile.sh \ + OS400/os400sys.c \ + OS400/os400sys.h \ + OS400/curl.cmd + +CHECKSRC = $(CS_$(V)) +CS_0 = @echo " RUN " $@; +CS_1 = +CS_ = $(CS_0) + +checksrc: + $(CHECKSRC)(@PERL@ $(top_srcdir)/scripts/checksrc.pl -D$(srcdir)/OS400 $(srcdir)/OS400/*.[ch]) + +if NOT_CURL_CI +if DEBUGBUILD +# for debug builds, we scan the sources on all regular make invokes +all-local: checksrc +endif +endif diff --git a/3rdparty/curl-8.21.0/projects/Makefile.in b/3rdparty/curl-8.21.0/projects/Makefile.in new file mode 100644 index 0000000000..0cc6817238 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/Makefile.in @@ -0,0 +1,744 @@ +# Makefile.in generated by automake 1.16.5 from Makefile.am. +# @configure_input@ + +# Copyright (C) 1994-2021 Free Software Foundation, Inc. + +# This Makefile.in is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY, to the extent permitted by law; without +# even the implied warranty of MERCHANTABILITY or FITNESS FOR A +# PARTICULAR PURPOSE. + +@SET_MAKE@ +VPATH = @srcdir@ +am__is_gnu_make = { \ + if test -z '$(MAKELEVEL)'; then \ + false; \ + elif test -n '$(MAKE_HOST)'; then \ + true; \ + elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \ + true; \ + else \ + false; \ + fi; \ +} +am__make_running_with_option = \ + case $${target_option-} in \ + ?) ;; \ + *) echo "am__make_running_with_option: internal error: invalid" \ + "target option '$${target_option-}' specified" >&2; \ + exit 1;; \ + esac; \ + has_opt=no; \ + sane_makeflags=$$MAKEFLAGS; \ + if $(am__is_gnu_make); then \ + sane_makeflags=$$MFLAGS; \ + else \ + case $$MAKEFLAGS in \ + *\\[\ \ ]*) \ + bs=\\; \ + sane_makeflags=`printf '%s\n' "$$MAKEFLAGS" \ + | sed "s/$$bs$$bs[$$bs $$bs ]*//g"`;; \ + esac; \ + fi; \ + skip_next=no; \ + strip_trailopt () \ + { \ + flg=`printf '%s\n' "$$flg" | sed "s/$$1.*$$//"`; \ + }; \ + for flg in $$sane_makeflags; do \ + test $$skip_next = yes && { skip_next=no; continue; }; \ + case $$flg in \ + *=*|--*) continue;; \ + -*I) strip_trailopt 'I'; skip_next=yes;; \ + -*I?*) strip_trailopt 'I';; \ + -*O) strip_trailopt 'O'; skip_next=yes;; \ + -*O?*) strip_trailopt 'O';; \ + -*l) strip_trailopt 'l'; skip_next=yes;; \ + -*l?*) strip_trailopt 'l';; \ + -[dEDm]) skip_next=yes;; \ + -[JT]) skip_next=yes;; \ + esac; \ + case $$flg in \ + *$$target_option*) has_opt=yes; break;; \ + esac; \ + done; \ + test $$has_opt = yes +am__make_dryrun = (target_option=n; $(am__make_running_with_option)) +am__make_keepgoing = (target_option=k; $(am__make_running_with_option)) +pkgdatadir = $(datadir)/@PACKAGE@ +pkgincludedir = $(includedir)/@PACKAGE@ +pkglibdir = $(libdir)/@PACKAGE@ +pkglibexecdir = $(libexecdir)/@PACKAGE@ +am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd +install_sh_DATA = $(install_sh) -c -m 644 +install_sh_PROGRAM = $(install_sh) -c +install_sh_SCRIPT = $(install_sh) -c +INSTALL_HEADER = $(INSTALL_DATA) +transform = $(program_transform_name) +NORMAL_INSTALL = : +PRE_INSTALL = : +POST_INSTALL = : +NORMAL_UNINSTALL = : +PRE_UNINSTALL = : +POST_UNINSTALL = : +build_triplet = @build@ +host_triplet = @host@ +subdir = projects +ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 +am__aclocal_m4_deps = $(top_srcdir)/m4/curl-amissl.m4 \ + $(top_srcdir)/m4/curl-apple-sectrust.m4 \ + $(top_srcdir)/m4/curl-compilers.m4 \ + $(top_srcdir)/m4/curl-confopts.m4 \ + $(top_srcdir)/m4/curl-functions.m4 \ + $(top_srcdir)/m4/curl-gnutls.m4 \ + $(top_srcdir)/m4/curl-mbedtls.m4 \ + $(top_srcdir)/m4/curl-openssl.m4 \ + $(top_srcdir)/m4/curl-override.m4 \ + $(top_srcdir)/m4/curl-reentrant.m4 \ + $(top_srcdir)/m4/curl-rustls.m4 \ + $(top_srcdir)/m4/curl-schannel.m4 \ + $(top_srcdir)/m4/curl-sysconfig.m4 \ + $(top_srcdir)/m4/curl-wolfssl.m4 $(top_srcdir)/m4/libtool.m4 \ + $(top_srcdir)/m4/ltoptions.m4 $(top_srcdir)/m4/ltsugar.m4 \ + $(top_srcdir)/m4/ltversion.m4 $(top_srcdir)/m4/lt~obsolete.m4 \ + $(top_srcdir)/m4/xc-am-iface.m4 \ + $(top_srcdir)/m4/xc-cc-check.m4 \ + $(top_srcdir)/m4/xc-lt-iface.m4 \ + $(top_srcdir)/m4/xc-val-flgs.m4 \ + $(top_srcdir)/m4/zz40-xc-ovr.m4 \ + $(top_srcdir)/m4/zz50-xc-ovr.m4 $(top_srcdir)/acinclude.m4 \ + $(top_srcdir)/configure.ac +am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ + $(ACLOCAL_M4) +DIST_COMMON = $(srcdir)/Makefile.am $(am__DIST_COMMON) +mkinstalldirs = $(install_sh) -d +CONFIG_HEADER = $(top_builddir)/lib/curl_config.h +CONFIG_CLEAN_FILES = +CONFIG_CLEAN_VPATH_FILES = +AM_V_P = $(am__v_P_@AM_V@) +am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) +am__v_P_0 = false +am__v_P_1 = : +AM_V_GEN = $(am__v_GEN_@AM_V@) +am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@) +am__v_GEN_0 = @echo " GEN " $@; +am__v_GEN_1 = +AM_V_at = $(am__v_at_@AM_V@) +am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) +am__v_at_0 = @ +am__v_at_1 = +SOURCES = +DIST_SOURCES = +RECURSIVE_TARGETS = all-recursive check-recursive cscopelist-recursive \ + ctags-recursive dvi-recursive html-recursive info-recursive \ + install-data-recursive install-dvi-recursive \ + install-exec-recursive install-html-recursive \ + install-info-recursive install-pdf-recursive \ + install-ps-recursive install-recursive installcheck-recursive \ + installdirs-recursive pdf-recursive ps-recursive \ + tags-recursive uninstall-recursive +am__can_run_installinfo = \ + case $$AM_UPDATE_INFO_DIR in \ + n|no|NO) false;; \ + *) (install-info --version) >/dev/null 2>&1;; \ + esac +RECURSIVE_CLEAN_TARGETS = mostlyclean-recursive clean-recursive \ + distclean-recursive maintainer-clean-recursive +am__recursive_targets = \ + $(RECURSIVE_TARGETS) \ + $(RECURSIVE_CLEAN_TARGETS) \ + $(am__extra_recursive_targets) +AM_RECURSIVE_TARGETS = $(am__recursive_targets:-recursive=) TAGS CTAGS \ + distdir distdir-am +am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) $(LISP) +# Read a list of newline-separated strings from the standard input, +# and print each of them once, without duplicates. Input order is +# *not* preserved. +am__uniquify_input = $(AWK) '\ + BEGIN { nonempty = 0; } \ + { items[$$0] = 1; nonempty = 1; } \ + END { if (nonempty) { for (i in items) print i; }; } \ +' +# Make sure the list of sources is unique. This is necessary because, +# e.g., the same source file might be shared among _SOURCES variables +# for different programs/libraries. +am__define_uniq_tagged_files = \ + list='$(am__tagged_files)'; \ + unique=`for i in $$list; do \ + if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ + done | $(am__uniquify_input)` +DIST_SUBDIRS = $(SUBDIRS) +am__DIST_COMMON = $(srcdir)/Makefile.in README.md +DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) +am__relativize = \ + dir0=`pwd`; \ + sed_first='s,^\([^/]*\)/.*$$,\1,'; \ + sed_rest='s,^[^/]*/*,,'; \ + sed_last='s,^.*/\([^/]*\)$$,\1,'; \ + sed_butlast='s,/*[^/]*$$,,'; \ + while test -n "$$dir1"; do \ + first=`echo "$$dir1" | sed -e "$$sed_first"`; \ + if test "$$first" != "."; then \ + if test "$$first" = ".."; then \ + dir2=`echo "$$dir0" | sed -e "$$sed_last"`/"$$dir2"; \ + dir0=`echo "$$dir0" | sed -e "$$sed_butlast"`; \ + else \ + first2=`echo "$$dir2" | sed -e "$$sed_first"`; \ + if test "$$first2" = "$$first"; then \ + dir2=`echo "$$dir2" | sed -e "$$sed_rest"`; \ + else \ + dir2="../$$dir2"; \ + fi; \ + dir0="$$dir0"/"$$first"; \ + fi; \ + fi; \ + dir1=`echo "$$dir1" | sed -e "$$sed_rest"`; \ + done; \ + reldir="$$dir2" +ACLOCAL = @ACLOCAL@ +AMTAR = @AMTAR@ +AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ +APXS = @APXS@ +AR = @AR@ +AR_FLAGS = @AR_FLAGS@ +AS = @AS@ +AUTOCONF = @AUTOCONF@ +AUTOHEADER = @AUTOHEADER@ +AUTOMAKE = @AUTOMAKE@ +AWK = @AWK@ +BLANK_AT_MAKETIME = @BLANK_AT_MAKETIME@ +CADDY = @CADDY@ +CC = @CC@ +CCDEPMODE = @CCDEPMODE@ +CFLAGS = @CFLAGS@ +CFLAG_CURL_SYMBOL_HIDING = @CFLAG_CURL_SYMBOL_HIDING@ +CLANG_TIDY = @CLANG_TIDY@ +CONFIGURE_OPTIONS = @CONFIGURE_OPTIONS@ +CPP = @CPP@ +CPPFLAGS = @CPPFLAGS@ +CSCOPE = @CSCOPE@ +CTAGS = @CTAGS@ +CURLVERSION = @CURLVERSION@ +CURL_CA_BUNDLE = @CURL_CA_BUNDLE@ +CURL_CA_EMBED = @CURL_CA_EMBED@ +CURL_CFLAG_EXTRAS = @CURL_CFLAG_EXTRAS@ +CURL_CPP = @CURL_CPP@ +CURL_LIBCURL_VERSIONED_SYMBOLS_PREFIX = @CURL_LIBCURL_VERSIONED_SYMBOLS_PREFIX@ +CURL_LIBCURL_VERSIONED_SYMBOLS_SONAME = @CURL_LIBCURL_VERSIONED_SYMBOLS_SONAME@ +CURL_NETWORK_AND_TIME_LIBS = @CURL_NETWORK_AND_TIME_LIBS@ +CYGPATH_W = @CYGPATH_W@ +DANTED = @DANTED@ +DEFS = @DEFS@ +DEPDIR = @DEPDIR@ +DLLTOOL = @DLLTOOL@ +DSYMUTIL = @DSYMUTIL@ +DUMPBIN = @DUMPBIN@ +ECHO_C = @ECHO_C@ +ECHO_N = @ECHO_N@ +ECHO_T = @ECHO_T@ +EGREP = @EGREP@ +ENABLE_SHARED = @ENABLE_SHARED@ +ENABLE_STATIC = @ENABLE_STATIC@ +ETAGS = @ETAGS@ +EXEEXT = @EXEEXT@ +FGREP = @FGREP@ +FILECMD = @FILECMD@ +FISH_FUNCTIONS_DIR = @FISH_FUNCTIONS_DIR@ +GCOV = @GCOV@ +GREP = @GREP@ +H2O = @H2O@ +HAVE_LIBZ = @HAVE_LIBZ@ +HTTPD = @HTTPD@ +HTTPD_NGHTTPX = @HTTPD_NGHTTPX@ +INSTALL = @INSTALL@ +INSTALL_DATA = @INSTALL_DATA@ +INSTALL_PROGRAM = @INSTALL_PROGRAM@ +INSTALL_SCRIPT = @INSTALL_SCRIPT@ +INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ +LCOV = @LCOV@ +LD = @LD@ +LDFLAGS = @LDFLAGS@ +LIBCURL_PC_CFLAGS = @LIBCURL_PC_CFLAGS@ +LIBCURL_PC_CFLAGS_PRIVATE = @LIBCURL_PC_CFLAGS_PRIVATE@ +LIBCURL_PC_LDFLAGS_PRIVATE = @LIBCURL_PC_LDFLAGS_PRIVATE@ +LIBCURL_PC_LIBS = @LIBCURL_PC_LIBS@ +LIBCURL_PC_LIBS_PRIVATE = @LIBCURL_PC_LIBS_PRIVATE@ +LIBCURL_PC_REQUIRES = @LIBCURL_PC_REQUIRES@ +LIBCURL_PC_REQUIRES_PRIVATE = @LIBCURL_PC_REQUIRES_PRIVATE@ +LIBOBJS = @LIBOBJS@ +LIBS = @LIBS@ +LIBTOOL = @LIBTOOL@ +LIPO = @LIPO@ +LN_S = @LN_S@ +LTLIBOBJS = @LTLIBOBJS@ +LT_SYS_LIBRARY_PATH = @LT_SYS_LIBRARY_PATH@ +MAINT = @MAINT@ +MAKEINFO = @MAKEINFO@ +MANIFEST_TOOL = @MANIFEST_TOOL@ +MKDIR_P = @MKDIR_P@ +NM = @NM@ +NMEDIT = @NMEDIT@ +OBJDUMP = @OBJDUMP@ +OBJEXT = @OBJEXT@ +OTOOL = @OTOOL@ +OTOOL64 = @OTOOL64@ +PACKAGE = @PACKAGE@ +PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ +PACKAGE_NAME = @PACKAGE_NAME@ +PACKAGE_STRING = @PACKAGE_STRING@ +PACKAGE_TARNAME = @PACKAGE_TARNAME@ +PACKAGE_URL = @PACKAGE_URL@ +PACKAGE_VERSION = @PACKAGE_VERSION@ +PATH_SEPARATOR = @PATH_SEPARATOR@ +PERL = @PERL@ +PKGCONFIG = @PKGCONFIG@ +RANLIB = @RANLIB@ +RC = @RC@ +SED = @SED@ +SET_MAKE = @SET_MAKE@ +SFTPD = @SFTPD@ +SHELL = @SHELL@ +SSHD = @SSHD@ +SSL_BACKENDS = @SSL_BACKENDS@ +STRIP = @STRIP@ +SUPPORT_FEATURES = @SUPPORT_FEATURES@ +SUPPORT_PROTOCOLS = @SUPPORT_PROTOCOLS@ +TEST_NGHTTPX = @TEST_NGHTTPX@ +VERSION = @VERSION@ +VERSIONNUM = @VERSIONNUM@ +VSFTPD = @VSFTPD@ +ZLIB_LIBS = @ZLIB_LIBS@ +ZSH_FUNCTIONS_DIR = @ZSH_FUNCTIONS_DIR@ +abs_builddir = @abs_builddir@ +abs_srcdir = @abs_srcdir@ +abs_top_builddir = @abs_top_builddir@ +abs_top_srcdir = @abs_top_srcdir@ +ac_ct_AR = @ac_ct_AR@ +ac_ct_CC = @ac_ct_CC@ +ac_ct_DUMPBIN = @ac_ct_DUMPBIN@ +am__include = @am__include@ +am__leading_dot = @am__leading_dot@ +am__quote = @am__quote@ +am__tar = @am__tar@ +am__untar = @am__untar@ +bindir = @bindir@ +build = @build@ +build_alias = @build_alias@ +build_cpu = @build_cpu@ +build_os = @build_os@ +build_vendor = @build_vendor@ +builddir = @builddir@ +datadir = @datadir@ +datarootdir = @datarootdir@ +docdir = @docdir@ +dvidir = @dvidir@ +exec_prefix = @exec_prefix@ +host = @host@ +host_alias = @host_alias@ +host_cpu = @host_cpu@ +host_os = @host_os@ +host_vendor = @host_vendor@ +htmldir = @htmldir@ +includedir = @includedir@ +infodir = @infodir@ +install_sh = @install_sh@ +libdir = @libdir@ +libexecdir = @libexecdir@ +libext = @libext@ +localedir = @localedir@ +localstatedir = @localstatedir@ +mandir = @mandir@ +mkdir_p = @mkdir_p@ +oldincludedir = @oldincludedir@ +pdfdir = @pdfdir@ +prefix = @prefix@ +program_transform_name = @program_transform_name@ +psdir = @psdir@ +runstatedir = @runstatedir@ +sbindir = @sbindir@ +sharedstatedir = @sharedstatedir@ +srcdir = @srcdir@ +sysconfdir = @sysconfdir@ +target_alias = @target_alias@ +top_build_prefix = @top_build_prefix@ +top_builddir = @top_builddir@ +top_srcdir = @top_srcdir@ + +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +SUBDIRS = vms +EXTRA_DIST = README.md \ + OS400/.checksrc \ + OS400/README.OS400 \ + OS400/rpg-examples \ + OS400/ccsidcurl.c \ + OS400/ccsidcurl.h \ + OS400/curlcl.c \ + OS400/curlmain.c \ + OS400/curl.inc.in \ + OS400/initscript.sh \ + OS400/config400.default \ + OS400/make-docs.sh \ + OS400/make-include.sh \ + OS400/make-lib.sh \ + OS400/make-src.sh \ + OS400/make-tests.sh \ + OS400/makefile.sh \ + OS400/os400sys.c \ + OS400/os400sys.h \ + OS400/curl.cmd + +CHECKSRC = $(CS_$(V)) +CS_0 = @echo " RUN " $@; +CS_1 = +CS_ = $(CS_0) +all: all-recursive + +.SUFFIXES: +$(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps) + @for dep in $?; do \ + case '$(am__configure_deps)' in \ + *$$dep*) \ + ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \ + && { if test -f $@; then exit 0; else break; fi; }; \ + exit 1;; \ + esac; \ + done; \ + echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu projects/Makefile'; \ + $(am__cd) $(top_srcdir) && \ + $(AUTOMAKE) --gnu projects/Makefile +Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status + @case '$?' in \ + *config.status*) \ + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ + *) \ + echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__maybe_remake_depfiles)'; \ + cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__maybe_remake_depfiles);; \ + esac; + +$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh + +$(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh +$(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh +$(am__aclocal_m4_deps): + +mostlyclean-libtool: + -rm -f *.lo + +clean-libtool: + -rm -rf .libs _libs + +# This directory's subdirectories are mostly independent; you can cd +# into them and run 'make' without going through this Makefile. +# To change the values of 'make' variables: instead of editing Makefiles, +# (1) if the variable is set in 'config.status', edit 'config.status' +# (which will cause the Makefiles to be regenerated when you run 'make'); +# (2) otherwise, pass the desired values on the 'make' command line. +$(am__recursive_targets): + @fail=; \ + if $(am__make_keepgoing); then \ + failcom='fail=yes'; \ + else \ + failcom='exit 1'; \ + fi; \ + dot_seen=no; \ + target=`echo $@ | sed s/-recursive//`; \ + case "$@" in \ + distclean-* | maintainer-clean-*) list='$(DIST_SUBDIRS)' ;; \ + *) list='$(SUBDIRS)' ;; \ + esac; \ + for subdir in $$list; do \ + echo "Making $$target in $$subdir"; \ + if test "$$subdir" = "."; then \ + dot_seen=yes; \ + local_target="$$target-am"; \ + else \ + local_target="$$target"; \ + fi; \ + ($(am__cd) $$subdir && $(MAKE) $(AM_MAKEFLAGS) $$local_target) \ + || eval $$failcom; \ + done; \ + if test "$$dot_seen" = "no"; then \ + $(MAKE) $(AM_MAKEFLAGS) "$$target-am" || exit 1; \ + fi; test -z "$$fail" + +ID: $(am__tagged_files) + $(am__define_uniq_tagged_files); mkid -fID $$unique +tags: tags-recursive +TAGS: tags + +tags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) + set x; \ + here=`pwd`; \ + if ($(ETAGS) --etags-include --version) >/dev/null 2>&1; then \ + include_option=--etags-include; \ + empty_fix=.; \ + else \ + include_option=--include; \ + empty_fix=; \ + fi; \ + list='$(SUBDIRS)'; for subdir in $$list; do \ + if test "$$subdir" = .; then :; else \ + test ! -f $$subdir/TAGS || \ + set "$$@" "$$include_option=$$here/$$subdir/TAGS"; \ + fi; \ + done; \ + $(am__define_uniq_tagged_files); \ + shift; \ + if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \ + test -n "$$unique" || unique=$$empty_fix; \ + if test $$# -gt 0; then \ + $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ + "$$@" $$unique; \ + else \ + $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ + $$unique; \ + fi; \ + fi +ctags: ctags-recursive + +CTAGS: ctags +ctags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) + $(am__define_uniq_tagged_files); \ + test -z "$(CTAGS_ARGS)$$unique" \ + || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ + $$unique + +GTAGS: + here=`$(am__cd) $(top_builddir) && pwd` \ + && $(am__cd) $(top_srcdir) \ + && gtags -i $(GTAGS_ARGS) "$$here" +cscopelist: cscopelist-recursive + +cscopelist-am: $(am__tagged_files) + list='$(am__tagged_files)'; \ + case "$(srcdir)" in \ + [\\/]* | ?:[\\/]*) sdir="$(srcdir)" ;; \ + *) sdir=$(subdir)/$(srcdir) ;; \ + esac; \ + for i in $$list; do \ + if test -f "$$i"; then \ + echo "$(subdir)/$$i"; \ + else \ + echo "$$sdir/$$i"; \ + fi; \ + done >> $(top_builddir)/cscope.files + +distclean-tags: + -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags +distdir: $(BUILT_SOURCES) + $(MAKE) $(AM_MAKEFLAGS) distdir-am + +distdir-am: $(DISTFILES) + @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ + topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ + list='$(DISTFILES)'; \ + dist_files=`for file in $$list; do echo $$file; done | \ + sed -e "s|^$$srcdirstrip/||;t" \ + -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ + case $$dist_files in \ + */*) $(MKDIR_P) `echo "$$dist_files" | \ + sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ + sort -u` ;; \ + esac; \ + for file in $$dist_files; do \ + if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ + if test -d $$d/$$file; then \ + dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ + if test -d "$(distdir)/$$file"; then \ + find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ + fi; \ + if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ + cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ + find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ + fi; \ + cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ + else \ + test -f "$(distdir)/$$file" \ + || cp -p $$d/$$file "$(distdir)/$$file" \ + || exit 1; \ + fi; \ + done + @list='$(DIST_SUBDIRS)'; for subdir in $$list; do \ + if test "$$subdir" = .; then :; else \ + $(am__make_dryrun) \ + || test -d "$(distdir)/$$subdir" \ + || $(MKDIR_P) "$(distdir)/$$subdir" \ + || exit 1; \ + dir1=$$subdir; dir2="$(distdir)/$$subdir"; \ + $(am__relativize); \ + new_distdir=$$reldir; \ + dir1=$$subdir; dir2="$(top_distdir)"; \ + $(am__relativize); \ + new_top_distdir=$$reldir; \ + echo " (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) top_distdir="$$new_top_distdir" distdir="$$new_distdir" \\"; \ + echo " am__remove_distdir=: am__skip_length_check=: am__skip_mode_fix=: distdir)"; \ + ($(am__cd) $$subdir && \ + $(MAKE) $(AM_MAKEFLAGS) \ + top_distdir="$$new_top_distdir" \ + distdir="$$new_distdir" \ + am__remove_distdir=: \ + am__skip_length_check=: \ + am__skip_mode_fix=: \ + distdir) \ + || exit 1; \ + fi; \ + done +check-am: all-am +check: check-recursive +@DEBUGBUILD_FALSE@all-local: +@NOT_CURL_CI_FALSE@all-local: +all-am: Makefile all-local +installdirs: installdirs-recursive +installdirs-am: +install: install-recursive +install-exec: install-exec-recursive +install-data: install-data-recursive +uninstall: uninstall-recursive + +install-am: all-am + @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am + +installcheck: installcheck-recursive +install-strip: + if test -z '$(STRIP)'; then \ + $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ + install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ + install; \ + else \ + $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ + install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ + "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \ + fi +mostlyclean-generic: + +clean-generic: + +distclean-generic: + -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) + -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) + +maintainer-clean-generic: + @echo "This command is intended for maintainers to use" + @echo "it deletes files that may require special tools to rebuild." +clean: clean-recursive + +clean-am: clean-generic clean-libtool mostlyclean-am + +distclean: distclean-recursive + -rm -f Makefile +distclean-am: clean-am distclean-generic distclean-tags + +dvi: dvi-recursive + +dvi-am: + +html: html-recursive + +html-am: + +info: info-recursive + +info-am: + +install-data-am: + +install-dvi: install-dvi-recursive + +install-dvi-am: + +install-exec-am: + +install-html: install-html-recursive + +install-html-am: + +install-info: install-info-recursive + +install-info-am: + +install-man: + +install-pdf: install-pdf-recursive + +install-pdf-am: + +install-ps: install-ps-recursive + +install-ps-am: + +installcheck-am: + +maintainer-clean: maintainer-clean-recursive + -rm -f Makefile +maintainer-clean-am: distclean-am maintainer-clean-generic + +mostlyclean: mostlyclean-recursive + +mostlyclean-am: mostlyclean-generic mostlyclean-libtool + +pdf: pdf-recursive + +pdf-am: + +ps: ps-recursive + +ps-am: + +uninstall-am: + +.MAKE: $(am__recursive_targets) install-am install-strip + +.PHONY: $(am__recursive_targets) CTAGS GTAGS TAGS all all-am all-local \ + check check-am clean clean-generic clean-libtool cscopelist-am \ + ctags ctags-am distclean distclean-generic distclean-libtool \ + distclean-tags distdir dvi dvi-am html html-am info info-am \ + install install-am install-data install-data-am install-dvi \ + install-dvi-am install-exec install-exec-am install-html \ + install-html-am install-info install-info-am install-man \ + install-pdf install-pdf-am install-ps install-ps-am \ + install-strip installcheck installcheck-am installdirs \ + installdirs-am maintainer-clean maintainer-clean-generic \ + mostlyclean mostlyclean-generic mostlyclean-libtool pdf pdf-am \ + ps ps-am tags tags-am uninstall uninstall-am + +.PRECIOUS: Makefile + + +checksrc: + $(CHECKSRC)(@PERL@ $(top_srcdir)/scripts/checksrc.pl -D$(srcdir)/OS400 $(srcdir)/OS400/*.[ch]) + +# for debug builds, we scan the sources on all regular make invokes +@DEBUGBUILD_TRUE@@NOT_CURL_CI_TRUE@all-local: checksrc + +# Tell versions [3.59,3.63) of GNU make to not export all variables. +# Otherwise a system limit (for SysV at least) may be exceeded. +.NOEXPORT: diff --git a/3rdparty/curl-8.21.0/projects/OS400/.checksrc b/3rdparty/curl-8.21.0/projects/OS400/.checksrc new file mode 100644 index 0000000000..e27d5729de --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/OS400/.checksrc @@ -0,0 +1,9 @@ +# Copyright (C) Daniel Stenberg, , et al. +# +# SPDX-License-Identifier: curl + +# Possibly not what we want, but cannot test, thus silence the warnings +allowfunc calloc +allowfunc free +allowfunc malloc +allowfunc realloc diff --git a/3rdparty/curl-8.21.0/projects/OS400/README.OS400 b/3rdparty/curl-8.21.0/projects/OS400/README.OS400 new file mode 100644 index 0000000000..5d4b643a5e --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/OS400/README.OS400 @@ -0,0 +1,383 @@ + +Implementation notes: + + This is a true OS/400 ILE implementation, not a PASE implementation (for +PASE, use AIX implementation). + + The biggest problem with OS/400 is EBCDIC. libcurl implements an internal +conversion mechanism, but it has been designed for computers that have a +single native character set. OS/400 default native character set varies +depending on the country for which it has been localized. Further, a job +may dynamically alter its "native" character set. + Several characters that do not have fixed code in EBCDIC variants are +used in libcurl strings. As a consequence, using the existing conversion +mechanism would have lead in a localized binary library - not portable across +countries. + For this reason, and because libcurl was originally designed for ASCII based +operating systems, the current OS/400 implementation uses ASCII as internal +character set. This has been accomplished using the QADRT library and +include files, a C and system procedures ASCII wrapper library. See IBM QADRT +description for more information. + This then results in libcurl being an ASCII library: any function string +argument is taken/returned in ASCII and a C/C++ calling program built around +QADRT may use libcurl functions as on any other platform. + QADRT does not define ASCII wrappers for all C/system procedures: the +OS/400 configuration header file and an additional module (os400sys.c) define +some more of them, that are used by libcurl and that QADRT left out. + To support all the different variants of EBCDIC, non-standard wrapper +procedures have been added to libcurl on OS/400: they provide an additional +CCSID (numeric Coded Character Set ID specific to OS/400) parameter for each +string argument. Callback procedures arguments giving access to strings are +NOT converted, so text gathered this way is (probably !) ASCII. + + Another OS/400 problem comes from the fact that the last fixed argument of a +vararg procedure may not be of type char, unsigned char, short or unsigned +short. Enums that are internally implemented by the C compiler as one of these +types are also forbidden. libcurl uses enums as vararg procedure tagfields... +Happily, there is a pragma forcing enums to type "int". The original libcurl +header files are thus altered during build process to use this pragma, in +order to force libcurl enums of being type int (the pragma disposition in use +before inclusion is restored before resuming the including unit compilation). + + Non-standard EBCDIC wrapper prototypes are defined in an additional header +file: ccsidcurl.h. These should be self-explanatory to an OS/400-aware +designer. CCSID 0 can be used to select the current job's CCSID. + Wrapper procedures with variable arguments are described below: + +_ curl_easy_setopt_ccsid() + Variable arguments are a string pointer and a CCSID (unsigned int) for +options: + CURLOPT_ABSTRACT_UNIX_SOCKET + CURLOPT_ACCEPT_ENCODING + CURLOPT_ALTSVC + CURLOPT_AWS_SIGV4 + CURLOPT_CAINFO + CURLOPT_CAPATH + CURLOPT_COOKIE + CURLOPT_COOKIEFILE + CURLOPT_COOKIEJAR + CURLOPT_COOKIELIST + CURLOPT_CRLFILE + CURLOPT_CUSTOMREQUEST + CURLOPT_DEFAULT_PROTOCOL + CURLOPT_DNS_INTERFACE + CURLOPT_DNS_LOCAL_IP4 + CURLOPT_DNS_LOCAL_IP6 + CURLOPT_DNS_SERVERS + CURLOPT_DOH_URL + CURLOPT_EGDSOCKET + CURLOPT_FTPPORT + CURLOPT_FTP_ACCOUNT + CURLOPT_FTP_ALTERNATIVE_TO_USER + CURLOPT_HAPROXY_CLIENT_IP + CURLOPT_HSTS + CURLOPT_INTERFACE + CURLOPT_ISSUERCERT + CURLOPT_KEYPASSWD + CURLOPT_KRBLEVEL + CURLOPT_LOGIN_OPTIONS + CURLOPT_MAIL_AUTH + CURLOPT_MAIL_FROM + CURLOPT_NETRC_FILE + CURLOPT_NOPROXY + CURLOPT_PASSWORD + CURLOPT_PINNEDPUBLICKEY + CURLOPT_PRE_PROXY + CURLOPT_PROTOCOLS_STR + CURLOPT_PROXY + CURLOPT_PROXYPASSWORD + CURLOPT_PROXYUSERNAME + CURLOPT_PROXYUSERPWD + CURLOPT_PROXY_CAINFO + CURLOPT_PROXY_CAPATH + CURLOPT_PROXY_CRLFILE + CURLOPT_PROXY_ISSUERCERT + CURLOPT_PROXY_KEYPASSWD + CURLOPT_PROXY_PINNEDPUBLICKEY + CURLOPT_PROXY_SERVICE_NAME + CURLOPT_PROXY_SSLCERT + CURLOPT_PROXY_SSLCERTTYPE + CURLOPT_PROXY_SSLKEY + CURLOPT_PROXY_SSLKEYTYPE + CURLOPT_PROXY_SSL_CIPHER_LIST + CURLOPT_PROXY_TLS13_CIPHERS + CURLOPT_PROXY_TLSAUTH_PASSWORD + CURLOPT_PROXY_TLSAUTH_TYPE + CURLOPT_PROXY_TLSAUTH_USERNAME + CURLOPT_RANDOM_FILE + CURLOPT_RANGE + CURLOPT_REDIR_PROTOCOLS_STR + CURLOPT_REFERER + CURLOPT_REQUEST_TARGET + CURLOPT_RTSP_SESSION_ID + CURLOPT_RTSP_STREAM_URI + CURLOPT_RTSP_TRANSPORT + CURLOPT_SASL_AUTHZID + CURLOPT_SERVICE_NAME + CURLOPT_SOCKS5_GSSAPI_SERVICE + CURLOPT_SSH_HOST_PUBLIC_KEY_MD5 + CURLOPT_SSH_HOST_PUBLIC_KEY_SHA256 + CURLOPT_SSH_KNOWNHOSTS + CURLOPT_SSH_PRIVATE_KEYFILE + CURLOPT_SSH_PUBLIC_KEYFILE + CURLOPT_SSLCERT + CURLOPT_SSLCERTTYPE + CURLOPT_SSLENGINE + CURLOPT_SSLKEY + CURLOPT_SSLKEYTYPE + CURLOPT_SSL_CIPHER_LIST + CURLOPT_SSL_EC_CURVES + CURLOPT_SSL_SIGNATURE_ALGORITHMS + CURLOPT_TLS13_CIPHERS + CURLOPT_TLSAUTH_PASSWORD + CURLOPT_TLSAUTH_TYPE + CURLOPT_TLSAUTH_USERNAME + CURLOPT_UNIX_SOCKET_PATH + CURLOPT_URL + CURLOPT_USERAGENT + CURLOPT_USERNAME + CURLOPT_USERPWD + CURLOPT_XOAUTH2_BEARER + All blob options are also supported. + In all other cases, it ignores the ccsid parameter and behaves as +curl_easy_setopt(). + Note that CURLOPT_ERRORBUFFER is not in the list above, since it gives the +address of an (empty) character buffer, not the address of a string. +CURLOPT_POSTFIELDS stores the address of static binary data (of type void *) +and thus is not converted. If CURLOPT_COPYPOSTFIELDS is issued after +CURLOPT_POSTFIELDSIZE != -1, the data size is adjusted according to the +CCSID conversion result length. + +_ curl_formadd_ccsid() + In the variable argument list, string pointers should be followed by a (long) +CCSID for the following options: + CURLFORM_BUFFER + CURLFORM_CONTENTTYPE + CURLFORM_COPYCONTENTS + CURLFORM_COPYNAME + CURLFORM_FILE + CURLFORM_FILECONTENT + CURLFORM_FILENAME + CURLFORM_PTRNAME + If taken from an argument array, an additional array entry must follow each +entry containing one of the above option. This additional entry holds the CCSID +in its value field, and the option field is meaningless. + It is not possible to have a string pointer and its CCSID across a function +parameter/array boundary. + Please note that CURLFORM_PTRCONTENTS and CURLFORM_BUFFERPTR are considered +unconvertible strings and thus are NOT followed by a CCSID. + +_ curl_easy_getinfo_ccsid() + The following options are followed by a 'char * *' and a CCSID. Unlike +curl_easy_getinfo(), the value returned in the pointer should be released with +curl_free() after use: + CURLINFO_CONTENT_TYPE + CURLINFO_EFFECTIVE_URL + CURLINFO_FTP_ENTRY_PATH + CURLINFO_LOCAL_IP + CURLINFO_PRIMARY_IP + CURLINFO_REDIRECT_URL + CURLINFO_REFERER + CURLINFO_RTSP_SESSION_ID + CURLINFO_SCHEME + Likewise, the following options are followed by a struct curl_slist * * and a +CCSID. + CURLINFO_COOKIELIST + CURLINFO_SSL_ENGINES +Lists returned should be released with curl_slist_free_all() after use. + Option CURLINFO_CERTINFO is followed by a struct curl_certinfo * * and a +CCSID. Returned structures should be freed with curl_certinfo_free_all() +after use. + Other options are processed like in curl_easy_getinfo(). + +_ curl_easy_strerror_ccsid(), curl_multi_strerror_ccsid(), +curl_share_strerror_ccsid() and curl_url_strerror_ccsid() work as their +non-ccsid version and return a string encoded in the additional ccsid +parameter. These strings belong to libcurl and may not be freed by the caller. +A subsequent call to the same procedure in the same thread invalidates the +previous result. + +_ curl_pushheader_bynum_cssid() and curl_pushheader_byname_ccsid() + Although the prototypes are self-explanatory, the returned string pointer +should be released with curl_free() after use, as opposite to the non-ccsid +versions of these procedures. + Please note that HTTP2 is not (yet) implemented on OS/400, thus these +functions always return NULL. + +_ curl_easy_option_by_name_ccsid() returns a pointer to an untranslated option +metadata structure. As each curl_easyoption structure holds the option name in +ASCII, the curl_easy_option_get_name_ccsid() function allows getting it in any +supported ccsid. However the caller should release the returned pointer with +curl_free() after use. + +_ curl_easy_header_ccsid() works as its non-CCSID counterpart but requires an +additional ccsid parameter specifying the name parameter encoding. The output +hout parameter is kept in libcurl's encoding and should not be altered. + +_ curl_from_ccsid() and curl_to_ccsid() are string encoding conversion +functions between ASCII (latin1) and the given CCSID. The first parameter is +the source string, the second is the CCSID and the returned value is a pointer +to the dynamically allocated string. These functions do not impact on curl's +behavior and are only provided for user convenience. After use, returned values +must be released with curl_free(). + + + Standard compilation environment does support neither autotools nor make; in +fact, few common utilities are available. As a consequence, the config-os400.h +has been coded manually and the compilation scripts are a set of shell scripts +stored in subdirectory projects/OS400. + + The test environment is currently not supported on OS/400. + + +Protocols currently implemented on OS/400: +_ DICT +_ FILE +_ FTP +_ GOPHER +_ HTTP +_ IMAP +_ LDAP +_ MQTT +_ POP3 +_ RTSP +_ SCP if libssh2 is enabled +_ SFTP if libssh2 is enabled +_ SMB +_ SMTP +_ TELNET +_ TFTP +_ WS + + +Compiling on OS/400: + + These instructions targets people who knows about OS/400, compiling, IFS and +archive extraction. Do not ask questions about these subjects if you are not +familiar with. + +_ As a prerequisite, QADRT development environment must be installed. + For more information on downloading and installing the QADRT development kit, + please see https://www.ibm.com/support/pages/node/6258183 +_ If data compression has to be supported, ZLIB development environment must + be installed. +_ Likewise, if SCP and SFTP protocols have to be compiled in, LIBSSH2 + development environment must be installed. +_ Install the curl source directory in IFS. Do NOT install it in the + installation target directory (which defaults to /curl). +_ Enter Qshell (QSH, not PASE) +_ Change current directory to the curl installation directory +_ Change current directory to ./projects/OS400 +- If you want to change the default configuration parameters like debug info + generation, optimization level, listing option, target library, ZLIB/LIBSSH2 + availability and location, etc., copy file config400.default to + config400.override and edit the latter. Do not edit the original default file + as it might be overwritten by a subsequent source installation. +_ Copy any file in the current directory to makelog (i.e.: + cp initscript.sh makelog): this is intended to create the makelog file with + an ASCII CCSID! +_ Enter the command "sh makefile.sh > makelog 2>&1" +_ Examine the makelog file to check for compilation errors. CZM0383 warnings on + C or system standard API come from QADRT inlining and can safely be ignored. + + Without configuration parameters override, this produces the following +OS/400 objects: +_ libcurl. All other objects are stored in this library. +_ Modules for all libcurl units. +_ Binding directory CURL_A, to be used at calling program link time for + statically binding the modules (specify BNDSRVPGM(QADRTTS QGLDCLNT QGLDBRDR) + when creating a program using CURL_A). +_ Service program CURL., where is extracted from the + lib/Makefile.am VERSION variable. To be used at calling program runtime + when this program has dynamically bound curl at link time. +_ Binding directory CURL. To be used to dynamically bind libcurl when linking a + calling program. +- CLI tool bound program curl. +- CLI command curl. +_ Source file H. It contains all the include members needed to compile a C/C++ + module using libcurl, and an ILE/RPG /copy member for support in this + language. +_ Standard C/C++ libcurl include members in file H. +_ CCSIDCURL member in file H. This defines the non-standard EBCDIC wrappers for + C and C++. +_ CURL.INC member in file H. This defines everything needed by an ILE/RPG + program using libcurl. +_ IFS directory /curl/include/curl containing the C header files for IFS source + C/C++ compilation and curl.inc.rpgle for IFS source ILE/RPG compilation. +- IFS link /curl/bin/curl to CLI tool program. + + +Special programming consideration: + +QADRT being used, the following points must be considered: +_ If static binding is used, service program QADRTTS must be linked too. +_ The EBCDIC CCSID used by QADRT is 37 by default, NOT THE JOB'S CCSID. If + another EBCDIC CCSID is required, it must be set via a locale through a call + to setlocale_a (QADRT's setlocale() ASCII wrapper) with category LC_ALL or + LC_CTYPE, or by setting environment variable QADRT_ENV_LOCALE to the locale + object path before executing the program. +_ Do not use original source include files unless you know what you are doing. + Use the installed members instead (in /QSYS.LIB/CURL.LIB/H.FILE and + /curl/include/curl). + + +ILE/RPG support: + + Since most of the ILE OS/400 programmers use ILE/RPG exclusively, a +definition /INCLUDE member is provided for this language. To include all +libcurl definitions in an ILE/RPG module, line + + h bnddir('CURL/CURL') + +must figure in the program header, and line + + d/include curl/h,curl.inc + +in the global data section of the module's source code. + + No vararg procedure support exists in ILE/RPG: for this reason, the following +considerations apply: +_ Procedures curl_easy_setopt_long(), curl_easy_setopt_object(), + curl_easy_setopt_function(), curl_easy_setopt_offset() and + curl_easy_setopt_blob() are all alias prototypes to curl_easy_setopt(), but + with different parameter lists. +_ Procedures curl_easy_getinfo_string(), curl_easy_getinfo_long(), + curl_easy_getinfo_double(), curl_easy_getinfo_slist(), + curl_easy_getinfo_ptr(), curl_easy_getinfo_socket() and + curl_easy_getinfo_off_t() are all alias prototypes to curl_easy_getinfo(), + but with different parameter lists. +_ Procedures curl_multi_setopt_long(), curl_multi_setopt_object(), + curl_multi_setopt_function() and curl_multi_setopt_offset() are all alias + prototypes to curl_multi_setopt(), but with different parameter lists. +_ Procedures curl_share_setopt_int(), curl_share_setopt_ptr() and + curl_share_setopt_proc() are all alias prototypes to curl_share_setopt, + but with different parameter lists. +_ Procedure curl_easy_setopt_blob_ccsid() is an alias of + curl_easy_setopt_ccsid() supporting blob encoding conversion. +_ The prototype of procedure curl_formadd() allows specifying a pointer option + and the CURLFORM_END option. This makes possible to use an option array + without any additional definition. If some specific incompatible argument + list is used in the ILE/RPG program, the latter must define a specialised + alias. The same applies to curl_formadd_ccsid() too. +_ Since V7R4M0, procedure overloading is used to emulate limited "vararg-like" + definitions of curl_easy_setopt(), curl_multi_setopt(), curl_share_setopt() + and curl_easy_getinfo(). Blob and CCSID alternatives are NOT included in + overloading. + + Since RPG cannot cast a long to a pointer, procedure curl_form_long_value() +is provided for that purpose: this allows storing a long value in the +curl_forms array. Please note the form API is deprecated and the MIME API +should be used instead. + + +CLI tool: + + The build system provides it as a bound program, an IFS link to it and a +simple CL command. The latter however is not able to provide a different +parameter for each option since there are too many of those; instead, +parameters are entered in a single field subject to quoting and escaping, in +the same form as expected by the standard CLI program. + Care must be taken about the program output encoding: by default, it is sent +to the standard output and is thus subject to transcoding. It is therefore +recommended to use option "--output" to redirect output to a specific IFS file. +Similar problems may occur about the standard input encoding. diff --git a/3rdparty/curl-8.21.0/projects/OS400/ccsidcurl.c b/3rdparty/curl-8.21.0/projects/OS400/ccsidcurl.c new file mode 100644 index 0000000000..cba89f8642 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/OS400/ccsidcurl.c @@ -0,0 +1,1471 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + * + ***************************************************************************/ + +/* CCSID API wrappers for OS/400. */ + +#include +#include +#include +#include +#include +#include + +#pragma enum(int) + +#include "curl.h" +#include "mprintf.h" +#include "slist.h" +#include "urldata.h" +#include "url.h" +#include "setopt.h" +#include "getinfo.h" +#include "ccsidcurl.h" + +#include "os400sys.h" + +#ifndef SIZE_MAX +#define SIZE_MAX ((size_t)~0) /* Is unsigned on OS/400. */ +#endif + +#define ASCII_CCSID 819 /* Use ISO-8859-1 as ASCII. */ +#define NOCONV_CCSID 65535 /* No conversion. */ +#define ICONV_ID_SIZE 32 /* Size of iconv_open() code identifier. */ +#define ICONV_OPEN_ERROR(t) ((t).return_value == -1) + +#define ALLOC_GRANULE 8 /* Alloc. granule for curl_formadd_ccsid(). */ + +static void makeOS400IconvCode(char buf[ICONV_ID_SIZE], unsigned int ccsid) +{ + /** + *** Convert a CCSID to the corresponding IBM iconv_open() character + *** code identifier. + *** This code is specific to the OS400 implementation of the iconv library. + *** CCSID 65535 (no conversion) is replaced by the ASCII CCSID. + *** CCSID 0 is interpreted by the OS400 as the job's CCSID. + **/ + + ccsid &= 0xFFFF; + + if(ccsid == NOCONV_CCSID) + ccsid = ASCII_CCSID; + + memset(buf, 0, ICONV_ID_SIZE); + curl_msprintf(buf, "IBMCCSID%05u0000000", ccsid); +} + +static iconv_t iconv_open_CCSID(unsigned int ccsidout, unsigned int ccsidin, + unsigned int cstr) +{ + char fromcode[ICONV_ID_SIZE]; + char tocode[ICONV_ID_SIZE]; + + /** + *** Like iconv_open(), but character codes are given as CCSIDs. + *** If `cstr' is non-zero, conversion is set up to stop whenever a + *** null character is encountered. + *** See iconv_open() IBM description in "National Language Support API". + **/ + + makeOS400IconvCode(fromcode, ccsidin); + makeOS400IconvCode(tocode, ccsidout); + memset(tocode + 13, 0, sizeof(tocode) - 13); /* Dest. code id format. */ + + if(cstr) + fromcode[18] = '1'; /* Set null-terminator flag. */ + + return iconv_open(tocode, fromcode); +} + +static int convert(char *d, size_t dlen, int dccsid, const char *s, int slen, + int sccsid) +{ + int i; + iconv_t cd; + size_t lslen; + + /** + *** Convert `sccsid'-coded `slen'-data bytes at `s' into `dccsid'-coded + *** data stored in the `dlen'-byte buffer at `d'. + *** If `slen' < 0, source string is null-terminated. + *** CCSID 65535 (no conversion) is replaced by the ASCII CCSID. + *** Return the converted destination byte count, or -1 if error. + **/ + + if(sccsid == 65535) + sccsid = ASCII_CCSID; + + if(dccsid == 65535) + dccsid = ASCII_CCSID; + + if(sccsid == dccsid) { + lslen = slen >= 0 ? slen : strlen(s) + 1; + i = lslen < dlen ? lslen : dlen; + + if(s != d && i > 0) + memcpy(d, s, i); + + return i; + } + + if(slen < 0) { + lslen = 0; + cd = iconv_open_CCSID(dccsid, sccsid, 1); + } + else { + lslen = (size_t)slen; + cd = iconv_open_CCSID(dccsid, sccsid, 0); + } + + if(ICONV_OPEN_ERROR(cd)) + return -1; + + i = dlen; + + if((int)iconv(cd, (char **)&s, &lslen, &d, &dlen) < 0) + i = -1; + else + i -= dlen; + + iconv_close(cd); + return i; +} + +static char *dynconvert(int dccsid, const char *s, int slen, int sccsid, + int *olen) +{ + char *d; + char *cp; + size_t dlen; + int l; + static const char nullbyte = 0; + + /* Like convert, but the destination is allocated and returned. */ + + dlen = (size_t)(slen < 0 ? strlen(s) : slen) + 1; + dlen *= MAX_CONV_EXPANSION; /* Allow some expansion. */ + d = malloc(dlen); + + if(!d) + return (char *)NULL; + + l = convert(d, dlen, dccsid, s, slen, sccsid); + + if(l < 0) { + free(d); + return (char *)NULL; + } + + if(slen < 0) { + /* Need to null-terminate even when source length is given. + Since destination code size is unknown, use a conversion to generate + terminator. */ + + int l2 = convert(d + l, dlen - l, dccsid, &nullbyte, -1, ASCII_CCSID); + + if(l2 < 0) { + free(d); + return (char *)NULL; + } + + l += l2; + } + + if((size_t)l < dlen) { + cp = realloc(d, l); /* Shorten to minimum needed. */ + + if(cp) + d = cp; + } + if(olen) + *olen = l; + + return d; +} + +static struct curl_slist *slist_convert(int dccsid, struct curl_slist *from, + int sccsid) +{ + struct curl_slist *to = (struct curl_slist *)NULL; + + for(; from; from = from->next) { + struct curl_slist *nl; + char *cp = dynconvert(dccsid, from->data, -1, sccsid, NULL); + + if(!cp) { + curl_slist_free_all(to); + return (struct curl_slist *)NULL; + } + nl = Curl_slist_append_nodup(to, cp); + if(!nl) { + curl_slist_free_all(to); + free(cp); + return NULL; + } + to = nl; + } + return to; +} + +static char *keyed_string(localkey_t key, const char *ascii, + unsigned int ccsid) +{ + int i; + char *ebcdic; + + if(!ascii) + return (char *)NULL; + + i = MAX_CONV_EXPANSION * (strlen(ascii) + 1); + + ebcdic = Curl_thread_buffer(key, i); + if(!ebcdic) + return ebcdic; + + if(convert(ebcdic, i, ccsid, ascii, -1, ASCII_CCSID) < 0) + return (char *)NULL; + + return ebcdic; +} + +const char *curl_to_ccsid(const char *s, unsigned int ccsid) +{ + if(s) + s = dynconvert(ccsid, s, -1, ASCII_CCSID, NULL); + return s; +} + +const char *curl_from_ccsid(const char *s, unsigned int ccsid) +{ + if(s) + s = dynconvert(ASCII_CCSID, s, -1, ccsid, NULL); + return s; +} + +char *curl_version_ccsid(unsigned int ccsid) +{ + return keyed_string(LK_CURL_VERSION, curl_version(), ccsid); +} + +char *curl_easy_escape_ccsid(CURL *handle, const char *string, int length, + unsigned int sccsid, unsigned int dccsid) +{ + char *s; + char *d; + + if(!string) { + /* !checksrc! disable ERRNOVAR 1 */ + errno = EINVAL; + return (char *)NULL; + } + + s = dynconvert(ASCII_CCSID, string, length ? length : -1, sccsid, NULL); + + if(!s) + return (char *)NULL; + + d = curl_easy_escape(handle, s, 0); + free(s); + + if(!d) + return (char *)NULL; + + s = dynconvert(dccsid, d, -1, ASCII_CCSID, NULL); + free(d); + return s; +} + +char *curl_easy_unescape_ccsid(CURL *handle, const char *string, int length, + int *outlength, unsigned int sccsid, + unsigned int dccsid) +{ + char *s; + char *d; + + if(!string) { + /* !checksrc! disable ERRNOVAR 1 */ + errno = EINVAL; + return (char *)NULL; + } + + s = dynconvert(ASCII_CCSID, string, length ? length : -1, sccsid, NULL); + + if(!s) + return (char *)NULL; + + d = curl_easy_unescape(handle, s, 0, outlength); + free(s); + + if(!d) + return (char *)NULL; + + s = dynconvert(dccsid, d, -1, ASCII_CCSID, NULL); + free(d); + + if(s && outlength) + *outlength = strlen(s); + + return s; +} + +struct curl_slist *curl_slist_append_ccsid(struct curl_slist *list, + const char *data, + unsigned int ccsid) +{ + char *s; + + s = (char *)NULL; + + if(!data) + return curl_slist_append(list, data); + + s = dynconvert(ASCII_CCSID, data, -1, ccsid, NULL); + + if(!s) + return (struct curl_slist *)NULL; + + list = curl_slist_append(list, s); + free(s); + return list; +} + +time_t curl_getdate_ccsid(const char *p, const time_t *unused, + unsigned int ccsid) +{ + char *s; + time_t t; + + if(!p) + return curl_getdate(p, unused); + + s = dynconvert(ASCII_CCSID, p, -1, ccsid, NULL); + + if(!s) + return (time_t)-1; + + t = curl_getdate(s, unused); + free(s); + return t; +} + +static int convert_version_info_string(const char **stringp, char **bufp, + int *left, unsigned int ccsid) +{ + /* Helper for curl_version_info_ccsid(): convert a string if defined. + Result is stored in the `*left'-byte buffer at `*bufp'. + `*bufp' and `*left' are updated accordingly. + Return 0 if ok, else -1. */ + + if(*stringp) { + int l = convert(*bufp, *left, ccsid, *stringp, -1, ASCII_CCSID); + + if(l <= 0) + return -1; + + *stringp = *bufp; + *bufp += l; + *left -= l; + } + + return 0; +} + +curl_version_info_data *curl_version_info_ccsid(CURLversion stamp, + unsigned int ccsid) +{ + curl_version_info_data *p; + char *cp; + int n; + int nproto; + curl_version_info_data *id; + int i; + const char **cpp; + static const size_t charfields[] = { + offsetof(curl_version_info_data, version), + offsetof(curl_version_info_data, host), + offsetof(curl_version_info_data, ssl_version), + offsetof(curl_version_info_data, libz_version), + offsetof(curl_version_info_data, ares), + offsetof(curl_version_info_data, libidn), + offsetof(curl_version_info_data, libssh_version), + offsetof(curl_version_info_data, brotli_version), + offsetof(curl_version_info_data, nghttp2_version), + offsetof(curl_version_info_data, quic_version), + offsetof(curl_version_info_data, cainfo), + offsetof(curl_version_info_data, capath), + offsetof(curl_version_info_data, zstd_version), + offsetof(curl_version_info_data, hyper_version), + offsetof(curl_version_info_data, gsasl_version), + offsetof(curl_version_info_data, feature_names), + offsetof(curl_version_info_data, rtmp_version) + }; + + /* The assertion below is possible, because although the second operand + is an enum member, the first is a #define. In that case, the OS/400 C + compiler seems to compare string values after substitution. */ + +#if CURLVERSION_NOW != CURLVERSION_ELEVENTH +#error curl_version_info_data structure has changed: upgrade this procedure. +#endif + + /* If caller has been compiled with a newer version, error. */ + + if(stamp > CURLVERSION_NOW) + return (curl_version_info_data *)NULL; + + p = curl_version_info(stamp); + + if(!p) + return p; + + /* Measure thread space needed. */ + + n = 0; + nproto = 0; + + if(p->protocols) { + while(p->protocols[nproto]) + n += strlen(p->protocols[nproto++]); + + n += nproto++; + } + + for(i = 0; i < sizeof(charfields) / sizeof(charfields[0]); i++) { + cpp = (const char **)((char *)p + charfields[i]); + if(*cpp) + n += strlen(*cpp) + 1; + } + + /* Allocate thread space. */ + + n *= MAX_CONV_EXPANSION; + + if(nproto) + n += nproto * sizeof(const char *); + + cp = Curl_thread_buffer(LK_VERSION_INFO_DATA, n); + id = (curl_version_info_data *)Curl_thread_buffer(LK_VERSION_INFO, + sizeof(*id)); + + if(!id || !cp) + return (curl_version_info_data *)NULL; + + /* Copy data and convert strings. */ + + memcpy((char *)id, (char *)p, sizeof(*p)); + + if(id->protocols) { + i = nproto * sizeof(id->protocols[0]); + + id->protocols = (const char * const *)cp; + memcpy(cp, (char *)p->protocols, i); + cp += i; + n -= i; + + for(i = 0; id->protocols[i]; i++) + if(convert_version_info_string(((const char **)id->protocols) + i, + &cp, &n, ccsid)) + return (curl_version_info_data *)NULL; + } + + for(i = 0; i < sizeof(charfields) / sizeof(charfields[0]); i++) { + cpp = (const char **)((char *)p + charfields[i]); + if(*cpp && convert_version_info_string(cpp, &cp, &n, ccsid)) + return (curl_version_info_data *)NULL; + } + + return id; +} + +const char *curl_easy_strerror_ccsid(CURLcode error, unsigned int ccsid) +{ + return keyed_string(LK_EASY_STRERROR, curl_easy_strerror(error), ccsid); +} + +const char *curl_share_strerror_ccsid(CURLSHcode error, unsigned int ccsid) +{ + return keyed_string(LK_SHARE_STRERROR, curl_share_strerror(error), ccsid); +} + +const char *curl_multi_strerror_ccsid(CURLMcode error, unsigned int ccsid) +{ + return keyed_string(LK_MULTI_STRERROR, curl_multi_strerror(error), ccsid); +} + +const char *curl_url_strerror_ccsid(CURLUcode error, unsigned int ccsid) +{ + return keyed_string(LK_URL_STRERROR, curl_url_strerror(error), ccsid); +} + +void curl_certinfo_free_all(struct curl_certinfo *info) +{ + /* Free all memory used by certificate info. */ + if(info) { + if(info->certinfo) { + int i; + + for(i = 0; i < info->num_of_certs; i++) + curl_slist_free_all(info->certinfo[i]); + free((char *)info->certinfo); + } + free((char *)info); + } +} + +CURLcode curl_easy_getinfo_ccsid(CURL *curl, CURLINFO info, ...) +{ + va_list arg; + void *paramp; + CURLcode result; + struct Curl_easy *data; + + /* WARNING: unlike curl_easy_getinfo(), the strings returned by this + procedure have to be free'ed. */ + + data = (struct Curl_easy *)curl; + va_start(arg, info); + paramp = va_arg(arg, void *); + result = Curl_getinfo(data, info, paramp); + + if(result == CURLE_OK) { + unsigned int ccsid; + char **cpp; + struct curl_slist **slp; + struct curl_certinfo *cipf; + struct curl_certinfo *cipt; + + switch((int)info & CURLINFO_TYPEMASK) { + + case CURLINFO_STRING: + ccsid = va_arg(arg, unsigned int); + cpp = (char **)paramp; + + if(*cpp) { + *cpp = dynconvert(ccsid, *cpp, -1, ASCII_CCSID, NULL); + + if(!*cpp) + result = CURLE_OUT_OF_MEMORY; + } + + break; + + case CURLINFO_SLIST: + ccsid = va_arg(arg, unsigned int); + switch(info) { + case CURLINFO_CERTINFO: + cipf = *(struct curl_certinfo **)paramp; + if(cipf) { + cipt = malloc(sizeof(*cipt)); + if(!cipt) + result = CURLE_OUT_OF_MEMORY; + else { + cipt->certinfo = calloc(cipf->num_of_certs + 1, + sizeof(struct curl_slist *)); + if(!cipt->certinfo) + result = CURLE_OUT_OF_MEMORY; + else { + int i; + + cipt->num_of_certs = cipf->num_of_certs; + for(i = 0; i < cipf->num_of_certs; i++) + if(cipf->certinfo[i]) + if(!(cipt->certinfo[i] = slist_convert(ccsid, + cipf->certinfo[i], + ASCII_CCSID))) { + result = CURLE_OUT_OF_MEMORY; + break; + } + } + } + + if(result != CURLE_OK) { + curl_certinfo_free_all(cipt); + cipt = (struct curl_certinfo *)NULL; + } + + *(struct curl_certinfo **)paramp = cipt; + } + + break; + + case CURLINFO_TLS_SESSION: + case CURLINFO_TLS_SSL_PTR: + case CURLINFO_SOCKET: + break; + + default: + slp = (struct curl_slist **)paramp; + if(*slp) { + *slp = slist_convert(ccsid, *slp, ASCII_CCSID); + if(!*slp) + result = CURLE_OUT_OF_MEMORY; + } + break; + } + } + } + + va_end(arg); + return result; +} + +static int Curl_is_formadd_string(CURLformoption option) +{ + switch(option) { + + case CURLFORM_FILENAME: + case CURLFORM_CONTENTTYPE: + case CURLFORM_BUFFER: + case CURLFORM_FILE: + case CURLFORM_FILECONTENT: + case CURLFORM_COPYCONTENTS: + case CURLFORM_COPYNAME: + return 1; + } + + return 0; +} + +static void Curl_formadd_release_local(struct curl_forms *forms, int nargs, + int skip) +{ + while(nargs--) + if(nargs != skip) + if(Curl_is_formadd_string(forms[nargs].option)) + if(forms[nargs].value) + free((char *)forms[nargs].value); + + free((char *)forms); +} + +static int Curl_formadd_convert(struct curl_forms *forms, int formx, + int lengthx, unsigned int ccsid) +{ + int l; + char *cp; + char *cp2; + + if(formx < 0 || !forms[formx].value) + return 0; + + if(lengthx >= 0) + l = (int)forms[lengthx].value; + else + l = strlen(forms[formx].value) + 1; + + cp = malloc(MAX_CONV_EXPANSION * l); + + if(!cp) + return -1; + + l = convert(cp, MAX_CONV_EXPANSION * l, ASCII_CCSID, forms[formx].value, l, + ccsid); + + if(l < 0) { + free(cp); + return -1; + } + + cp2 = realloc(cp, l); /* Shorten buffer to the string size. */ + + if(cp2) + cp = cp2; + + forms[formx].value = cp; + + if(lengthx >= 0) + forms[lengthx].value = (char *)l; /* Update length after conversion. */ + + return l; +} + +CURLFORMcode curl_formadd_ccsid(struct curl_httppost **httppost, + struct curl_httppost **last_post, ...) +{ + va_list arg; + CURLformoption option; + CURLFORMcode result; + struct curl_forms *forms; + struct curl_forms *lforms; + struct curl_forms *tforms; + unsigned int lformlen; + const char *value; + unsigned int ccsid; + int nargs; + int namex; + int namelengthx; + int contentx; + int lengthx; + unsigned int contentccsid; + unsigned int nameccsid; + + /* A single curl_formadd() call cannot be split in several calls to deal + with all parameters: the original parameters are thus copied to a local + curl_forms array and converted to ASCII when needed. + CURLFORM_PTRNAME is processed as if it were CURLFORM_COPYNAME. + CURLFORM_COPYNAME and CURLFORM_NAMELENGTH occurrence order in + parameters is not defined; for this reason, the actual conversion is + delayed to the end of parameter processing. The same applies to + CURLFORM_COPYCONTENTS/CURLFORM_CONTENTSLENGTH, but these may appear + several times in the parameter list; the problem resides here in knowing + which CURLFORM_CONTENTSLENGTH applies to which CURLFORM_COPYCONTENTS and + when we can be sure to have both info for conversion: end of parameter + list is such a point, but CURLFORM_CONTENTTYPE is also used here as a + natural separator between content data definitions; this seems to be + in accordance with FormAdd() behavior. */ + + /* Allocate the local curl_forms array. */ + + lformlen = ALLOC_GRANULE; + lforms = malloc(lformlen * sizeof(*lforms)); + + if(!lforms) + return CURL_FORMADD_MEMORY; + + /* Process the arguments, copying them into local array, latching conversion + indexes and converting when needed. */ + + result = CURL_FORMADD_OK; + nargs = 0; + contentx = -1; + lengthx = -1; + namex = -1; + namelengthx = -1; + forms = (struct curl_forms *)NULL; + va_start(arg, last_post); + + for(;;) { + /* Make sure there is still room for an item in local array. */ + + if(nargs >= lformlen) { + lformlen += ALLOC_GRANULE; + tforms = realloc(lforms, lformlen * sizeof(*lforms)); + + if(!tforms) { + result = CURL_FORMADD_MEMORY; + break; + } + + lforms = tforms; + } + + /* Get next option. */ + + if(forms) { + /* Get option from array. */ + + option = forms->option; + value = forms->value; + forms++; + } + else { + /* Get option from arguments. */ + + option = va_arg(arg, CURLformoption); + + if(option == CURLFORM_END) + break; + } + + /* Dispatch by option. */ + + switch(option) { + + case CURLFORM_END: + forms = (struct curl_forms *)NULL; /* Leave array mode. */ + continue; + + case CURLFORM_ARRAY: + if(!forms) { + forms = va_arg(arg, struct curl_forms *); + continue; + } + + result = CURL_FORMADD_ILLEGAL_ARRAY; + break; + + case CURLFORM_COPYNAME: + option = CURLFORM_PTRNAME; /* Static for now. */ + + case CURLFORM_PTRNAME: + if(namex >= 0) + result = CURL_FORMADD_OPTION_TWICE; + + namex = nargs; + + if(!forms) { + value = va_arg(arg, char *); + nameccsid = (unsigned int)va_arg(arg, long); + } + else { + nameccsid = (unsigned int)forms->value; + forms++; + } + + break; + + case CURLFORM_COPYCONTENTS: + if(contentx >= 0) + result = CURL_FORMADD_OPTION_TWICE; + + contentx = nargs; + + if(!forms) { + value = va_arg(arg, char *); + contentccsid = (unsigned int)va_arg(arg, long); + } + else { + contentccsid = (unsigned int)forms->value; + forms++; + } + + break; + + case CURLFORM_PTRCONTENTS: + case CURLFORM_BUFFERPTR: + if(!forms) + value = va_arg(arg, char *); /* No conversion. */ + + break; + + case CURLFORM_CONTENTSLENGTH: + lengthx = nargs; + + if(!forms) + value = (char *)va_arg(arg, long); + + break; + + case CURLFORM_CONTENTLEN: + lengthx = nargs; + + if(!forms) + value = (char *)va_arg(arg, curl_off_t); + + break; + + case CURLFORM_NAMELENGTH: + namelengthx = nargs; + + if(!forms) + value = (char *)va_arg(arg, long); + + break; + + case CURLFORM_BUFFERLENGTH: + if(!forms) + value = (char *)va_arg(arg, long); + + break; + + case CURLFORM_CONTENTHEADER: + if(!forms) + value = (char *)va_arg(arg, struct curl_slist *); + + break; + + case CURLFORM_STREAM: + if(!forms) + value = (char *)va_arg(arg, void *); + + break; + + case CURLFORM_CONTENTTYPE: + /* If a previous content has been encountered, convert it now. */ + + if(Curl_formadd_convert(lforms, contentx, lengthx, contentccsid) < 0) { + result = CURL_FORMADD_MEMORY; + break; + } + + contentx = -1; + lengthx = -1; + /* Fall into default. */ + + default: + /* Must be a convertible string. */ + + if(!Curl_is_formadd_string(option)) { + result = CURL_FORMADD_UNKNOWN_OPTION; + break; + } + + if(!forms) { + value = va_arg(arg, char *); + ccsid = (unsigned int)va_arg(arg, long); + } + else { + ccsid = (unsigned int)forms->value; + forms++; + } + + /* Do the conversion. */ + + lforms[nargs].value = value; + + if(Curl_formadd_convert(lforms, nargs, -1, ccsid) < 0) { + result = CURL_FORMADD_MEMORY; + break; + } + + value = lforms[nargs].value; + } + + if(result != CURL_FORMADD_OK) + break; + + lforms[nargs].value = value; + lforms[nargs++].option = option; + } + + va_end(arg); + + /* Convert the name and the last content, now that we know their lengths. */ + + if(result == CURL_FORMADD_OK && namex >= 0) { + if(Curl_formadd_convert(lforms, namex, namelengthx, nameccsid) < 0) + result = CURL_FORMADD_MEMORY; + else + lforms[namex].option = CURLFORM_COPYNAME; /* Force copy. */ + } + + if(result == CURL_FORMADD_OK) { + if(Curl_formadd_convert(lforms, contentx, lengthx, contentccsid) < 0) + result = CURL_FORMADD_MEMORY; + else + contentx = -1; + } + + /* Do the formadd with our converted parameters. */ + + if(result == CURL_FORMADD_OK) { + lforms[nargs].option = CURLFORM_END; + result = curl_formadd(httppost, last_post, + CURLFORM_ARRAY, lforms, CURLFORM_END); + } + + /* Terminate. */ + + Curl_formadd_release_local(lforms, nargs, contentx); + return result; +} + +struct cfcdata { + curl_formget_callback append; + void * arg; + unsigned int ccsid; +}; + +static size_t Curl_formget_callback_ccsid(void *arg, const char *buf, + size_t len) +{ + struct cfcdata *p; + char *b; + int l; + size_t ret; + + p = (struct cfcdata *)arg; + + if((long)len <= 0) + return (*p->append)(p->arg, buf, len); + + b = malloc(MAX_CONV_EXPANSION * len); + + if(!b) + return (size_t)-1; + + l = convert(b, MAX_CONV_EXPANSION * len, p->ccsid, buf, len, ASCII_CCSID); + + if(l < 0) { + free(b); + return (size_t)-1; + } + + ret = (*p->append)(p->arg, b, l); + free(b); + return ret == l ? len : -1; +} + +int curl_formget_ccsid(struct curl_httppost *form, void *arg, + curl_formget_callback append, unsigned int ccsid) +{ + struct cfcdata lcfc; + + lcfc.append = append; + lcfc.arg = arg; + lcfc.ccsid = ccsid; + return curl_formget(form, (void *)&lcfc, Curl_formget_callback_ccsid); +} + +CURLcode curl_easy_setopt_ccsid(CURL *easy, CURLoption tag, ...) +{ + CURLcode result; + va_list arg; + char *s; + char *cp = NULL; + unsigned int ccsid; + curl_off_t pfsize; + struct Curl_easy *data = easy; + + va_start(arg, tag); + + switch(tag) { + + /* BEGIN TRANSLATABLE STRING OPTIONS */ + /* Keep option symbols in alphanumeric order and retain the BEGIN/END + armor comments. */ + case CURLOPT_ABSTRACT_UNIX_SOCKET: + case CURLOPT_ACCEPT_ENCODING: + case CURLOPT_ALTSVC: + case CURLOPT_AWS_SIGV4: + case CURLOPT_CAINFO: + case CURLOPT_CAPATH: + case CURLOPT_COOKIE: + case CURLOPT_COOKIEFILE: + case CURLOPT_COOKIEJAR: + case CURLOPT_COOKIELIST: + case CURLOPT_CRLFILE: + case CURLOPT_CUSTOMREQUEST: + case CURLOPT_DEFAULT_PROTOCOL: + case CURLOPT_DNS_INTERFACE: + case CURLOPT_DNS_LOCAL_IP4: + case CURLOPT_DNS_LOCAL_IP6: + case CURLOPT_DNS_SERVERS: + case CURLOPT_DOH_URL: + case CURLOPT_ECH: + case CURLOPT_EGDSOCKET: + case CURLOPT_FTPPORT: + case CURLOPT_FTP_ACCOUNT: + case CURLOPT_FTP_ALTERNATIVE_TO_USER: + case CURLOPT_HAPROXY_CLIENT_IP: + case CURLOPT_HSTS: + case CURLOPT_INTERFACE: + case CURLOPT_ISSUERCERT: + case CURLOPT_KEYPASSWD: + case CURLOPT_KRBLEVEL: + case CURLOPT_LOGIN_OPTIONS: + case CURLOPT_MAIL_AUTH: + case CURLOPT_MAIL_FROM: + case CURLOPT_NETRC_FILE: + case CURLOPT_NOPROXY: + case CURLOPT_PASSWORD: + case CURLOPT_PINNEDPUBLICKEY: + case CURLOPT_PRE_PROXY: + case CURLOPT_PROTOCOLS_STR: + case CURLOPT_PROXY: + case CURLOPT_PROXYPASSWORD: + case CURLOPT_PROXYUSERNAME: + case CURLOPT_PROXYUSERPWD: + case CURLOPT_PROXY_CAINFO: + case CURLOPT_PROXY_CAPATH: + case CURLOPT_PROXY_CRLFILE: + case CURLOPT_PROXY_ISSUERCERT: + case CURLOPT_PROXY_KEYPASSWD: + case CURLOPT_PROXY_PINNEDPUBLICKEY: + case CURLOPT_PROXY_SERVICE_NAME: + case CURLOPT_PROXY_SSLCERT: + case CURLOPT_PROXY_SSLCERTTYPE: + case CURLOPT_PROXY_SSLKEY: + case CURLOPT_PROXY_SSLKEYTYPE: + case CURLOPT_PROXY_SSL_CIPHER_LIST: + case CURLOPT_PROXY_TLS13_CIPHERS: + case CURLOPT_PROXY_TLSAUTH_PASSWORD: + case CURLOPT_PROXY_TLSAUTH_TYPE: + case CURLOPT_PROXY_TLSAUTH_USERNAME: + case CURLOPT_RANDOM_FILE: + case CURLOPT_RANGE: + case CURLOPT_REDIR_PROTOCOLS_STR: + case CURLOPT_REFERER: + case CURLOPT_REQUEST_TARGET: + case CURLOPT_RTSP_SESSION_ID: + case CURLOPT_RTSP_STREAM_URI: + case CURLOPT_RTSP_TRANSPORT: + case CURLOPT_SASL_AUTHZID: + case CURLOPT_SERVICE_NAME: + case CURLOPT_SOCKS5_GSSAPI_SERVICE: + case CURLOPT_SSH_HOST_PUBLIC_KEY_MD5: + case CURLOPT_SSH_HOST_PUBLIC_KEY_SHA256: + case CURLOPT_SSH_KNOWNHOSTS: + case CURLOPT_SSH_PRIVATE_KEYFILE: + case CURLOPT_SSH_PUBLIC_KEYFILE: + case CURLOPT_SSLCERT: + case CURLOPT_SSLCERTTYPE: + case CURLOPT_SSLENGINE: + case CURLOPT_SSLKEY: + case CURLOPT_SSLKEYTYPE: + case CURLOPT_SSL_CIPHER_LIST: + case CURLOPT_SSL_EC_CURVES: + case CURLOPT_SSL_SIGNATURE_ALGORITHMS: + case CURLOPT_TLS13_CIPHERS: + case CURLOPT_TLSAUTH_PASSWORD: + case CURLOPT_TLSAUTH_TYPE: + case CURLOPT_TLSAUTH_USERNAME: + case CURLOPT_UNIX_SOCKET_PATH: + case CURLOPT_URL: + case CURLOPT_USERAGENT: + case CURLOPT_USERNAME: + case CURLOPT_USERPWD: + case CURLOPT_XOAUTH2_BEARER: + /* END TRANSLATABLE STRING OPTIONS */ + s = va_arg(arg, char *); + ccsid = va_arg(arg, unsigned int); + + if(s) { + s = dynconvert(ASCII_CCSID, s, -1, ccsid, NULL); + + if(!s) { + result = CURLE_OUT_OF_MEMORY; + break; + } + } + + result = curl_easy_setopt(easy, tag, s); + free(s); + break; + + case CURLOPT_COPYPOSTFIELDS: + /* Special case: byte count may have been given by CURLOPT_POSTFIELDSIZE + prior to this call. In this case, convert the given byte count and + replace the length according to the conversion result. */ + s = va_arg(arg, char *); + ccsid = va_arg(arg, unsigned int); + + pfsize = data->set.postfieldsize; + + if(!s || !pfsize || ccsid == NOCONV_CCSID || ccsid == ASCII_CCSID) { + result = curl_easy_setopt(easy, CURLOPT_COPYPOSTFIELDS, s); + break; + } + + if(pfsize == -1) { + /* Data is null-terminated. */ + s = dynconvert(ASCII_CCSID, s, -1, ccsid, NULL); + + if(!s) { + result = CURLE_OUT_OF_MEMORY; + break; + } + } + else { + /* Data length specified. */ + size_t len; + + if(pfsize < 0 || pfsize > SIZE_MAX) { + result = CURLE_OUT_OF_MEMORY; + break; + } + + len = pfsize; + pfsize = len * MAX_CONV_EXPANSION; + + if(pfsize > SIZE_MAX) + pfsize = SIZE_MAX; + + cp = malloc(pfsize); + + if(!cp) { + result = CURLE_OUT_OF_MEMORY; + break; + } + + pfsize = convert(cp, pfsize, ASCII_CCSID, s, len, ccsid); + + if(pfsize < 0) { + result = CURLE_OUT_OF_MEMORY; + break; + } + + data->set.postfieldsize = pfsize; /* Replace data size. */ + s = cp; + cp = NULL; + } + + result = curl_easy_setopt(easy, CURLOPT_POSTFIELDS, s); + data->set.str[STRING_COPYPOSTFIELDS] = s; /* Give to library. */ + break; + + default: + if(tag / 10000 == CURLOPTTYPE_BLOB) { + struct curl_blob *bp = va_arg(arg, struct curl_blob *); + struct curl_blob blob; + + ccsid = va_arg(arg, unsigned int); + + if(bp && bp->data && bp->len && + ccsid != NOCONV_CCSID && ccsid != ASCII_CCSID) { + pfsize = (curl_off_t)bp->len * MAX_CONV_EXPANSION; + + if(pfsize > SIZE_MAX) + pfsize = SIZE_MAX; + + cp = malloc(pfsize); + + if(!cp) { + result = CURLE_OUT_OF_MEMORY; + break; + } + + pfsize = convert(cp, pfsize, ASCII_CCSID, bp->data, bp->len, ccsid); + + if(pfsize < 0) { + result = CURLE_OUT_OF_MEMORY; + break; + } + + blob.data = cp; + blob.len = pfsize; + blob.flags = bp->flags | CURL_BLOB_COPY; + bp = &blob; + } + result = curl_easy_setopt(easy, tag, bp); + break; + } + FALLTHROUGH(); + case CURLOPT_ERRORBUFFER: /* This is an output buffer. */ + result = Curl_vsetopt(easy, tag, arg); + break; + } + + va_end(arg); + free(cp); + return result; +} + +/* ILE/RPG helper functions. */ + +char *curl_form_long_value(long value) +{ + /* ILE/RPG cannot cast an integer to a pointer. This procedure does it. */ + + return (char *)value; +} + +CURLcode curl_easy_setopt_RPGnum_(CURL *easy, CURLoption tag, curl_off_t arg) +{ + /* ILE/RPG procedure overloading cannot discriminate between different + size and/or signedness of format arguments. This provides a generic + wrapper that adapts size to the given tag expectation. + This procedure is not intended to be explicitly called from user code. */ + if(tag / 10000 != CURLOPTTYPE_OFF_T) + return curl_easy_setopt(easy, tag, (long)arg); + return curl_easy_setopt(easy, tag, arg); +} + +CURLcode curl_multi_setopt_RPGnum_(CURLM *multi, CURLMoption tag, + curl_off_t arg) +{ + /* Likewise, for multi handle. */ + if(tag / 10000 != CURLOPTTYPE_OFF_T) + return curl_multi_setopt(multi, tag, (long)arg); + return curl_multi_setopt(multi, tag, arg); +} + +char *curl_pushheader_bynum_cssid(struct curl_pushheaders *h, size_t num, + unsigned int ccsid) +{ + char *d = (char *)NULL; + char *s = curl_pushheader_bynum(h, num); + + if(s) + d = dynconvert(ccsid, s, -1, ASCII_CCSID, NULL); + + return d; +} + +char *curl_pushheader_byname_ccsid(struct curl_pushheaders *h, + const char *header, unsigned int ccsidin, + unsigned int ccsidout) +{ + char *d = (char *)NULL; + + if(header) { + header = dynconvert(ASCII_CCSID, header, -1, ccsidin, NULL); + + if(header) { + char *s = curl_pushheader_byname(h, header); + free((char *)header); + + if(s) + d = dynconvert(ccsidout, s, -1, ASCII_CCSID, NULL); + } + } + + return d; +} + +static CURLcode +mime_string_call(curl_mimepart *part, const char *string, unsigned int ccsid, + CURLcode (*mimefunc)(curl_mimepart *part, const char *string)) +{ + char *s = (char *)NULL; + CURLcode result; + + if(!string) + return mimefunc(part, string); + s = dynconvert(ASCII_CCSID, string, -1, ccsid, NULL); + if(!s) + return CURLE_OUT_OF_MEMORY; + + result = mimefunc(part, s); + free(s); + return result; +} + +CURLcode curl_mime_name_ccsid(curl_mimepart *part, const char *name, + unsigned int ccsid) +{ + return mime_string_call(part, name, ccsid, curl_mime_name); +} + +CURLcode curl_mime_filename_ccsid(curl_mimepart *part, const char *filename, + unsigned int ccsid) +{ + return mime_string_call(part, filename, ccsid, curl_mime_filename); +} + +CURLcode curl_mime_type_ccsid(curl_mimepart *part, const char *mimetype, + unsigned int ccsid) +{ + return mime_string_call(part, mimetype, ccsid, curl_mime_type); +} + +CURLcode curl_mime_encoder_ccsid(curl_mimepart *part, const char *encoding, + unsigned int ccsid) +{ + return mime_string_call(part, encoding, ccsid, curl_mime_encoder); +} + +CURLcode curl_mime_filedata_ccsid(curl_mimepart *part, const char *filename, + unsigned int ccsid) +{ + return mime_string_call(part, filename, ccsid, curl_mime_filedata); +} + +CURLcode curl_mime_data_ccsid(curl_mimepart *part, const char *data, + size_t datasize, unsigned int ccsid) +{ + char *s = (char *)NULL; + CURLcode result; + int osize; + + if(!data) + return curl_mime_data(part, data, datasize); + s = dynconvert(ASCII_CCSID, data, datasize, ccsid, &osize); + if(!s) + return CURLE_OUT_OF_MEMORY; + + result = curl_mime_data(part, s, osize); + free(s); + return result; +} + +CURLUcode curl_url_get_ccsid(CURLU *handle, CURLUPart what, char **part, + unsigned int flags, unsigned int ccsid) +{ + char *s = (char *)NULL; + CURLUcode result; + + if(!part) + return CURLUE_BAD_PARTPOINTER; + + *part = (char *)NULL; + result = curl_url_get(handle, what, &s, flags); + if(result == CURLUE_OK) { + if(s) { + *part = dynconvert(ccsid, s, -1, ASCII_CCSID, NULL); + if(!*part) + result = CURLUE_OUT_OF_MEMORY; + } + } + if(s) + free(s); + return result; +} + +CURLUcode curl_url_set_ccsid(CURLU *handle, CURLUPart what, const char *part, + unsigned int flags, unsigned int ccsid) +{ + char *s = (char *)NULL; + CURLUcode result; + + if(part) { + s = dynconvert(ASCII_CCSID, part, -1, ccsid, NULL); + if(!s) + return CURLUE_OUT_OF_MEMORY; + } + result = curl_url_set(handle, what, s, flags); + if(s) + free(s); + return result; +} + +const struct curl_easyoption * +curl_easy_option_by_name_ccsid(const char *name, unsigned int ccsid) +{ + const struct curl_easyoption *option = NULL; + + if(name) { + char *s = dynconvert(ASCII_CCSID, name, -1, ccsid, NULL); + + if(s) { + option = curl_easy_option_by_name(s); + free(s); + } + } + + return option; +} + +/* Return option name in the given ccsid. */ +const char * +curl_easy_option_get_name_ccsid(const struct curl_easyoption *option, + unsigned int ccsid) +{ + char *name = NULL; + + if(option && option->name) + name = dynconvert(ccsid, option->name, -1, ASCII_CCSID, NULL); + + return (const char *)name; +} + +/* Header API CCSID support. */ +CURLHcode curl_easy_header_ccsid(CURL *easy, const char *name, size_t index, + unsigned int origin, int request, + struct curl_header **hout, unsigned int ccsid) +{ + CURLHcode result = CURLHE_BAD_ARGUMENT; + + if(name) { + char *s = dynconvert(ASCII_CCSID, name, -1, ccsid, NULL); + + result = CURLHE_OUT_OF_MEMORY; + if(s) { + result = curl_easy_header(easy, s, index, origin, request, hout); + free(s); + } + } + + return result; +} diff --git a/3rdparty/curl-8.21.0/projects/OS400/ccsidcurl.h b/3rdparty/curl-8.21.0/projects/OS400/ccsidcurl.h new file mode 100644 index 0000000000..f9e667a9e4 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/OS400/ccsidcurl.h @@ -0,0 +1,112 @@ +#ifndef CURLINC_CCSIDCURL_H +#define CURLINC_CCSIDCURL_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + * + ***************************************************************************/ +#include "curl.h" +#include "easy.h" +#include "multi.h" + +CURL_EXTERN char *curl_version_ccsid(unsigned int ccsid); +CURL_EXTERN char *curl_easy_escape_ccsid(CURL *handle, + const char *string, int length, + unsigned int sccsid, + unsigned int dccsid); +CURL_EXTERN char *curl_easy_unescape_ccsid(CURL *handle, const char *string, + int length, int *outlength, + unsigned int sccsid, + unsigned int dccsid); +CURL_EXTERN struct curl_slist *curl_slist_append_ccsid(struct curl_slist *l, + const char *data, + unsigned int ccsid); +CURL_EXTERN time_t curl_getdate_ccsid(const char *p, const time_t *unused, + unsigned int ccsid); +CURL_EXTERN curl_version_info_data *curl_version_info_ccsid(CURLversion stamp, + unsigned int cid); +CURL_EXTERN const char *curl_easy_strerror_ccsid(CURLcode error, + unsigned int ccsid); +CURL_EXTERN const char *curl_share_strerror_ccsid(CURLSHcode error, + unsigned int ccsid); +CURL_EXTERN const char *curl_multi_strerror_ccsid(CURLMcode error, + unsigned int ccsid); +CURL_EXTERN CURLcode curl_easy_getinfo_ccsid(CURL *curl, CURLINFO info, ...); +CURL_EXTERN CURLFORMcode curl_formadd_ccsid(struct curl_httppost **httppost, + struct curl_httppost **last_post, + ...); +CURL_EXTERN char *curl_form_long_value(long value); +CURL_EXTERN int curl_formget_ccsid(struct curl_httppost *form, void *arg, + curl_formget_callback append, + unsigned int ccsid); +CURL_EXTERN CURLcode curl_easy_setopt_ccsid(CURL *curl, CURLoption tag, ...); +CURL_EXTERN void curl_certinfo_free_all(struct curl_certinfo *info); +CURL_EXTERN char *curl_pushheader_bynum_cssid(struct curl_pushheaders *h, + size_t num, unsigned int ccsid); +CURL_EXTERN char *curl_pushheader_byname_ccsid(struct curl_pushheaders *h, + const char *header, + unsigned int ccsidin, + unsigned int ccsidout); +CURL_EXTERN CURLcode curl_mime_name_ccsid(curl_mimepart *part, + const char *name, + unsigned int ccsid); +CURL_EXTERN CURLcode curl_mime_filename_ccsid(curl_mimepart *part, + const char *filename, + unsigned int ccsid); +CURL_EXTERN CURLcode curl_mime_type_ccsid(curl_mimepart *part, + const char *mimetype, + unsigned int ccsid); +CURL_EXTERN CURLcode curl_mime_encoder_ccsid(curl_mimepart *part, + const char *encoding, + unsigned int ccsid); +CURL_EXTERN CURLcode curl_mime_filedata_ccsid(curl_mimepart *part, + const char *filename, + unsigned int ccsid); +CURL_EXTERN CURLcode curl_mime_data_ccsid(curl_mimepart *part, + const char *data, size_t datasize, + unsigned int ccsid); +CURL_EXTERN CURLUcode curl_url_get_ccsid(CURLU *handle, CURLUPart what, + char **part, unsigned int flags, + unsigned int ccsid); +CURL_EXTERN CURLUcode curl_url_set_ccsid(CURLU *handle, CURLUPart what, + const char *part, unsigned int flags, + unsigned int ccsid); +CURL_EXTERN const struct curl_easyoption *curl_easy_option_by_name_ccsid( + const char *name, unsigned int ccsid); +CURL_EXTERN const char *curl_easy_option_get_name_ccsid( + const struct curl_easyoption *option, + unsigned int ccsid); +CURL_EXTERN const char *curl_url_strerror_ccsid(CURLUcode error, + unsigned int ccsid); +CURL_EXTERN CURLHcode curl_easy_header_ccsid(CURL *easy, const char *name, + size_t index, unsigned int origin, + int request, + struct curl_header **hout, + unsigned int ccsid); +CURL_EXTERN const char *curl_from_ccsid(const char *s, unsigned int ccsid); +CURL_EXTERN const char *curl_to_ccsid(const char *s, unsigned int ccsid); +CURL_EXTERN CURLcode curl_easy_setopt_RPGnum_(CURL *easy, + CURLoption tag, curl_off_t arg); +CURL_EXTERN CURLcode curl_multi_setopt_RPGnum_(CURLM *multi, CURLMoption tag, + curl_off_t arg); + +#endif diff --git a/3rdparty/curl-8.21.0/projects/OS400/config400.default b/3rdparty/curl-8.21.0/projects/OS400/config400.default new file mode 100644 index 0000000000..4e7ddbac57 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/OS400/config400.default @@ -0,0 +1,56 @@ +#!/bin/sh +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### + +# Tunable configuration parameters. + +setenv TARGETLIB 'CURL' # Target OS/400 program library. +setenv STATBNDDIR 'CURL_A' # Static binding directory. +setenv DYNBNDDIR 'CURL' # Dynamic binding directory. +setenv SRVPGM "CURL.${SONAME}" # Service program. +setenv CURLPGM 'CURL' # CLI tool bound program. +setenv CURLCMD 'CURL' # CL command name. +setenv CURLCLI 'CURLCL' # CL interface program. +setenv TGTCCSID '500' # Target CCSID of objects. +setenv DEBUG '*ALL' # Debug level. +setenv OPTIMIZE '10' # Optimization level +setenv OUTPUT '*NONE' # Compilation output option. +setenv TGTRLS '*CURRENT' # Target OS release. +setenv IFSDIR '/curl' # Installation IFS directory. +setenv QADRTDIR '/QIBM/ProdData/qadrt' # QADRT IFS directory. +setenv PASEPERL '/QOpenSys/pkgs/bin/perl' # PASE Perl interpreter. + +# Define ZLIB availability and locations. + +setenv WITH_ZLIB 0 # Define to 1 to enable. +setenv ZLIB_INCLUDE '/zlib/include' # ZLIB include IFS directory. +setenv ZLIB_LIB 'ZLIB' # ZLIB library. +setenv ZLIB_BNDDIR 'ZLIB_A' # ZLIB binding directory. + +# Define LIBSSH2 availability and locations. + +setenv WITH_LIBSSH2 0 # Define to 1 to enable. +setenv LIBSSH2_INCLUDE '/libssh2/include' # LIBSSH2 include IFS directory. +setenv LIBSSH2_LIB 'LIBSSH2' # LIBSSH2 library. +setenv LIBSSH2_BNDDIR 'LIBSSH2_A' # LIBSSH2 binding directory. diff --git a/3rdparty/curl-8.21.0/projects/OS400/curl.cmd b/3rdparty/curl-8.21.0/projects/OS400/curl.cmd new file mode 100644 index 0000000000..fa6aaa59a5 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/OS400/curl.cmd @@ -0,0 +1,32 @@ +/*****************************************************************************/ +/* _ _ ____ _ */ +/* Project ___| | | | _ \| | */ +/* / __| | | | |_) | | */ +/* | (__| |_| | _ <| |___ */ +/* \___|\___/|_| \_\_____| */ +/* */ +/* Copyright (C) Daniel Stenberg, , et al. */ +/* */ +/* This software is licensed as described in the file COPYING, which */ +/* you should have received as part of this distribution. The terms */ +/* are also available at https://curl.se/docs/copyright.html. */ +/* */ +/* You may opt to use, copy, modify, merge, publish, distribute and/or sell */ +/* copies of the Software, and permit persons to whom the Software is */ +/* furnished to do so, under the terms of the COPYING file. */ +/* */ +/* This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY */ +/* KIND, either express or implied. */ +/* */ +/* SPDX-License-Identifier: curl */ +/* */ +/* */ +/*****************************************************************************/ + +/* Use program CURLCL as interface to the curl command line tool */ + + CMD PROMPT('File transfer utility') + + PARM KWD(CMDARGS) TYPE(*CHAR) LEN(5000) VARY(*YES *INT2) + + CASE(*MIXED) EXPR(*YES) MIN(1) + + PROMPT('curl command arguments') diff --git a/3rdparty/curl-8.21.0/projects/OS400/curl.inc.in b/3rdparty/curl-8.21.0/projects/OS400/curl.inc.in new file mode 100644 index 0000000000..f97f26e012 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/OS400/curl.inc.in @@ -0,0 +1,3538 @@ + ************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF + * ANY KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + * + ************************************************************************** + * + /if not defined(CURL_CURL_INC_) + /define CURL_CURL_INC_ + * + * WARNING: this file should be kept in sync with C include files. + * + ************************************************************************** + * Constants + ************************************************************************** + * + d LIBCURL_VERSION... + d c '@LIBCURL_VERSION@' + d LIBCURL_VERSION_MAJOR... + d c @LIBCURL_VERSION_MAJOR@ + d LIBCURL_VERSION_MINOR... + d c @LIBCURL_VERSION_MINOR@ + d LIBCURL_VERSION_PATCH... + d c @LIBCURL_VERSION_PATCH@ + d LIBCURL_VERSION_NUM... + d c X'00@LIBCURL_VERSION_NUM@' + d LIBCURL_TIMESTAMP... + d c '@LIBCURL_TIMESTAMP@' + * + d CURL_SOCKET_BAD... + d c -1 + d CURL_SOCKET_TIMEOUT... + d c -1 + * + /if not defined(CURL_MAX_WRITE_SIZE) + /define CURL_MAX_WRITE_SIZE + d CURL_MAX_WRITE_SIZE... + d c 16384 + /endif + * + /if not defined(CURL_MAX_HTTP_HEADER) + /define CURL_MAX_HTTP_HEADER + d CURL_MAX_HTTP_HEADER... + d c 102400 + /endif + * + d CURLINFO_STRING... + d c X'00100000' + d CURLINFO_LONG c X'00200000' + d CURLINFO_DOUBLE... + d c X'00300000' + d CURLINFO_SLIST c X'00400000' + d CURLINFO_PTR c X'00400000' + d CURLINFO_SOCKET... + d c X'00500000' + d CURLINFO_OFF_T... + d c X'00600000' + d CURLINFO_MASK c X'000FFFFF' + d CURLINFO_TYPEMASK... + d c X'00F00000' + * + d CURL_GLOBAL_SSL... + d c X'00000001' + d CURL_GLOBAL_WIN32... + d c X'00000002' + d CURL_GLOBAL_ALL... + d c X'00000003' + d CURL_GLOBAL_NOTHING... + d c X'00000000' + d CURL_GLOBAL_DEFAULT... + d c X'00000003' + d CURL_GLOBAL_ACK_EINTR... + d c X'00000004' + * + d CURL_VERSION_IPV6... + d c X'00000001' + d CURL_VERSION_KERBEROS4... + d c X'00000002' + d CURL_VERSION_SSL... + d c X'00000004' + d CURL_VERSION_LIBZ... + d c X'00000008' + d CURL_VERSION_NTLM... + d c X'00000010' + d CURL_VERSION_GSSNEGOTIATE... + d c X'00000020' Deprecated + d CURL_VERSION_DEBUG... + d c X'00000040' + d CURL_VERSION_ASYNCHDNS... + d c X'00000080' + d CURL_VERSION_SPNEGO... + d c X'00000100' + d CURL_VERSION_LARGEFILE... + d c X'00000200' + d CURL_VERSION_IDN... + d c X'00000400' + d CURL_VERSION_SSPI... + d c X'00000800' + d CURL_VERSION_CONV... + d c X'00001000' + d CURL_VERSION_CURLDEBUG... + d c X'00002000' Deprecated + d CURL_VERSION_TLSAUTH_SRP... + d c X'00004000' + d CURL_VERSION_NTLM_WB... + d c X'00008000' + d CURL_VERSION_HTTP2... + d c X'00010000' + d CURL_VERSION_GSSAPI... + d c X'00020000' + d CURL_VERSION_KERBEROS5... + d c X'00040000' + d CURL_VERSION_UNIX_SOCKETS... + d c X'00080000' + d CURL_VERSION_PSL... + d c X'00100000' + d CURL_VERSION_HTTPS_PROXY... + d c X'00200000' + d CURL_VERSION_MULTI_SSL... + d c X'00400000' + d CURL_VERSION_BROTLI... + d c X'00800000' + d CURL_VERSION_ALTSVC... + d c X'01000000' + d CURL_VERSION_HTTP3... + d c X'02000000' + d CURL_VERSION_ZSTD... + d c X'04000000' + d CURL_VERSION_UNICODE... + d c X'08000000' + d CURL_VERSION_HSTS... + d c X'10000000' + d CURL_VERSION_GSASL... + d c X'20000000' + d CURL_VERSION_THREADSAFE... + d c X'40000000' + * + d CURL_HTTPPOST_FILENAME... + d c X'00000001' + d CURL_HTTPPOST_READFILE... + d c X'00000002' + d CURL_HTTPPOST_PTRNAME... + d c X'00000004' + d CURL_HTTPPOST_PTRCONTENTS... + d c X'00000008' + d CURL_HTTPPOST_BUFFER... + d c X'00000010' + d CURL_HTTPPOST_PTRBUFFER... + d c X'00000020' + d CURL_HTTPPOST_CALLBACK... + d c X'00000040' + d CURL_HTTPPOST_LARGE... + d c X'00000080' + * + d CURL_SEEKFUNC_OK... + d c 0 + d CURL_SEEKFUNC_FAIL... + d c 1 + d CURL_SEEKFUNC_CANTSEEK... + d c 2 + * + d CURL_READFUNC_ABORT... + d c X'10000000' + d CURL_READFUNC_PAUSE... + d c X'10000001' + * + d CURL_WRITEFUNC_PAUSE... + d c X'10000001' + d CURL_WRITEFUNC_ERROR... + d c X'FFFFFFFF' + * + d CURL_TRAILERFUNC_OK... + d c 0 + d CURL_TRAILERFUNC_ABORT... + d c 1 + * + d CURL_PREREQFUNC_OK... + d c 0 + d CURL_PREREQFUNC_ABORT... + d c 1 + * + d CURLAUTH_NONE c X'00000000' + d CURLAUTH_BASIC c X'00000001' + d CURLAUTH_DIGEST... + d c X'00000002' + d CURLAUTH_NEGOTIATE... + d c X'00000004' + d CURLAUTH_NTLM c X'00000008' + d CURLAUTH_DIGEST_IE... + d c X'00000010' + /if not defined(CURL_NO_OLDIES) + d CURLAUTH_NTLM_WB... + d c X'00000020' + /endif + d CURLAUTH_BEARER... + d c X'00000040' + d CURLAUTH_AWS_SIGV4... + d c X'00000080' + d CURLAUTH_ONLY... + d c X'80000000' + d CURLAUTH_ANY c X'7FFFFFEF' + d CURLAUTH_ANYSAFE... + d c X'7FFFFFEE' + * + d CURLSSH_AUTH_ANY... + d c X'7FFFFFFF' + d CURLSSH_AUTH_NONE... + d c X'00000000' + d CURLSSH_AUTH_PUBLICKEY... + d c X'00000001' + d CURLSSH_AUTH_PASSWORD... + d c X'00000002' + d CURLSSH_AUTH_HOST... + d c X'00000004' + d CURLSSH_AUTH_KEYBOARD... + d c X'00000008' + d CURLSSH_AUTH_AGENT... + d c X'00000010' + d CURLSSH_AUTH_DEFAULT... + d c X'7FFFFFFF' CURLSSH_AUTH_ANY + * + d CURLGSSAPI_DELEGATION_NONE... + d c 0 + d CURLGSSAPI_DELEGATION_POLICY_FLAG... + d c X'00000001' + d CURLGSSAPI_DELEGATION_FLAG... + d c X'00000002' + * + d CURL_ERROR_SIZE... + d c 256 + * + d CURLOPTTYPE_LONG... + d c 0 + d CURLOPTTYPE_VALUES... + d c 0 + d CURLOPTTYPE_OBJECTPOINT... + d c 10000 + d CURLOPTTYPE_STRINGPOINT... + d c 10000 + d CURLOPTTYPE_SLISTPOINT... + d c 10000 + d CURLOPTTYPE_CBPOINT... + d c 10000 + d CURLOPTTYPE_FUNCTIONPOINT... + d c 20000 + d CURLOPTTYPE_OFF_T... + d c 30000 + d CURLOPTTYPE_BLOB... + d c 40000 + * + d CURL_IPRESOLVE_WHATEVER... + d c 0 + d CURL_IPRESOLVE_V4... + d c 1 + d CURL_IPRESOLVE_V6... + d c 2 + * + d CURL_HTTP_VERSION_NONE... + d c 0 + d CURL_HTTP_VERSION_1_0... + d c 1 + d CURL_HTTP_VERSION_1_1... + d c 2 + d CURL_HTTP_VERSION_2_0... + d c 3 + d CURL_HTTP_VERSION_2... + d c 3 + d CURL_HTTP_VERSION_2TLS... + d c 4 + d CURL_HTTP_VERSION_2_PRIOR_KNOWLEDGE... + d c 5 + d CURL_HTTP_VERSION_3... + d c 30 + d CURL_HTTP_VERSION_3ONLY... + d c 31 + * + d CURL_NETRC_IGNORED... + d c 0 + d CURL_NETRC_OPTIONAL... + d c 1 + d CURL_NETRC_REQUIRED... + d c 2 + * + d CURL_SSLVERSION_DEFAULT... + d c 0 + d CURL_SSLVERSION_TLSv1... + d c 1 + d CURL_SSLVERSION_SSLv2... + d c 2 + d CURL_SSLVERSION_SSLv3... + d c 3 + d CURL_SSLVERSION_TLSv1_0... + d c 4 + d CURL_SSLVERSION_TLSv1_1... + d c 5 + d CURL_SSLVERSION_TLSv1_2... + d c 6 + d CURL_SSLVERSION_TLSv1_3... + d c 7 + d CURL_SSLVERSION_MAX_DEFAULT... + d c X'00010000' + d CURL_SSLVERSION_MAX_TLSv1_0... + d c X'00040000' + d CURL_SSLVERSION_MAX_TLSv1_1... + d c X'00050000' + d CURL_SSLVERSION_MAX_TLSv1_2... + d c X'00060000' + d CURL_SSLVERSION_MAX_TLSv1_3... + d c X'00070000' + * + d CURL_TLSAUTH_NONE... + d c 0 + d CURL_TLSAUTH_SRP... + d c 1 + * + d CURL_REDIR_GET_ALL... + d c 0 + d CURL_REDIR_POST_301... + d c 1 + d CURL_REDIR_POST_302... + d c 2 + d CURL_REDIR_POST_303... + d c 4 + d CURL_REDIR_POST_ALL... + d c 7 + * + d CURL_ZERO_TERMINATED... + d c X'FFFFFFFF' + * + d CURL_POLL_NONE c 0 + d CURL_POLL_IN c 1 + d CURL_POLL_OUT c 2 + d CURL_POLL_INOUT... + d c 3 + d CURL_POLL_REMOVE... + d c 4 + * + d CURL_BLOB_NOCOPY... + d c 0 + d CURL_BLOB_COPY c 1 + * + d CURL_CSELECT_IN... + d c X'00000001' + d CURL_CSELECT_OUT... + d c X'00000002' + d CURL_CSELECT_ERR... + d c X'00000004' + * + d CURL_PUSH_OK c 0 + d CURL_PUSH_DENY c 1 + d CURL_PUSH_ERROROUT... + d c 2 + * + d CURLMNOTIFY_INFO_READ... + d c 0 + d CURLMNOTIFY_EASY_DONE... + d c 1 + * + d CURLPAUSE_RECV c X'00000001' + d CURLPAUSE_RECV_CONT... + d c X'00000000' + d CURLPAUSE_SEND c X'00000004' + d CURLPAUSE_SEND_CONT... + d c X'00000000' + d CURLPAUSE_ALL c X'00000005' + d CURLPAUSE_CONT c X'00000000' + * + d CURLINFOFLAG_KNOWN_FILENAME... + d c X'00000001' + d CURLINFOFLAG_KNOWN_FILETYPE... + d c X'00000002' + d CURLINFOFLAG_KNOWN_TIME... + d c X'00000004' + d CURLINFOFLAG_KNOWN_PERM... + d c X'00000008' + d CURLINFOFLAG_KNOWN_UID... + d c X'00000010' + d CURLINFOFLAG_KNOWN_GID... + d c X'00000020' + d CURLINFOFLAG_KNOWN_SIZE... + d c X'00000040' + d CURLINFOFLAG_KNOWN_HLINKCOUNT... + d c X'00000080' + * + d CURL_CHUNK_BGN_FUNC_OK... + d c 0 + d CURL_CHUNK_BGN_FUNC_FAIL... + d c 1 + d CURL_CHUNK_BGN_FUNC_SKIP... + d c 2 + * + d CURL_CHUNK_END_FUNC_OK... + d c 0 + d CURL_CHUNK_END_FUNC_FAIL... + d c 1 + * + d CURL_FNMATCHFUNC_MATCH... + d c 0 + d CURL_FNMATCHFUNC_NOMATCH... + d c 1 + d CURL_FNMATCHFUNC_FAIL... + d c 2 + * + d CURL_WAIT_POLLIN... + d c X'0001' + d CURL_WAIT_POLLPRI... + d c X'0002' + d CURL_WAIT_POLLOUT... + d c X'0004' + * + d CURLU_DEFAULT_PORT... + d c X'00000001' + d CURLU_NO_DEFAULT_PORT... + d c X'00000002' + d CURLU_DEFAULT_SCHEME... + d c X'00000004' + d CURLU_NON_SUPPORT_SCHEME... + d c X'00000008' + d CURLU_PATH_AS_IS... + d c X'00000010' + d CURLU_DISALLOW_USER... + d c X'00000020' + d CURLU_URLDECODE... + d c X'00000040' + d CURLU_URLENCODE... + d c X'00000080' + d CURLU_APPENDQUERY... + d c X'00000100' + d CURLU_GUESS_SCHEME... + d c X'00000200' + d CURLU_NO_AUTHORITY... + d c X'00000400' + d CURLU_ALLOW_SPACE... + d c X'00000800' + d CURLU_PUNYCODE c X'00001000' + d CURLU_PUNY2IDN c X'00002000' + d CURLU_GET_EMPTY... + d c X'00004000' + d CURLU_NO_GUESS_SCHEME... + d c X'00008000' + * + d CURLOT_FLAG_ALIAS... + d c X'00000001' + * + d CURLH_HEADER c X'00000001' + d CURLH_TRAILER c X'00000002' + d CURLH_CONNECT c X'00000004' + d CURLH_1XX c X'00000008' + d CURLH_PSEUDO c X'00000010' + * + d CURLWS_TEXT c X'00000001' + d CURLWS_BINARY c X'00000002' + d CURLWS_CONT c X'00000004' + d CURLWS_CLOSE c X'00000008' + d CURLWS_PING c X'00000010' + d CURLWS_OFFSET c X'00000020' + d CURLWS_PONG c X'00000040' + * + d CURLWS_RAW_MODE... + d c X'00000001' + d CURLWS_NOAUTOPONG... + d c X'00000002' + * + ************************************************************************** + * Types + ************************************************************************** + * + d curl_socket_t s 10i 0 based(######ptr######) + * + d curl_off_t s 20i 0 based(######ptr######) + * + d CURLcode s 10i 0 based(######ptr######) Enum + d CURLE_OK c 0 + d CURLE_UNSUPPORTED_PROTOCOL... + d c 1 + d CURLE_FAILED_INIT... + d c 2 + d CURLE_URL_MALFORMAT... + d c 3 + d CURLE_NOT_BUILT_IN... + d c 4 + d CURLE_COULDNT_RESOLVE_PROXY... + d c 5 + d CURLE_COULDNT_RESOLVE_HOST... + d c 6 + d CURLE_COULDNT_CONNECT... + d c 7 + d CURLE_WEIRD_SERVER_REPLY... + d c 8 + d CURLE_REMOTE_ACCESS_DENIED... + d c 9 + d CURLE_FTP_ACCEPT_FAILED... + d c 10 + d CURLE_FTP_WEIRD_PASS_REPLY... + d c 11 + d CURLE_FTP_ACCEPT_TIMEOUT... + d c 12 + d CURLE_FTP_WEIRD_PASV_REPLY... + d c 13 + d CURLE_FTP_WEIRD_227_FORMAT... + d c 14 + d CURLE_FTP_CANT_GET_HOST... + d c 15 + d CURLE_HTTP2 c 16 + d CURLE_FTP_COULDNT_SET_TYPE... + d c 17 + d CURLE_PARTIAL_FILE... + d c 18 + d CURLE_FTP_COULDNT_RETR_FILE... + d c 19 + d CURLE_OBSOLETE20... + d c 20 + d CURLE_QUOTE_ERROR... + d c 21 + d CURLE_HTTP_RETURNED_ERROR... + d c 22 + d CURLE_WRITE_ERROR... + d c 23 + d CURLE_OBSOLETE24... + d c 24 + d CURLE_UPLOAD_FAILED... + d c 25 + d CURLE_READ_ERROR... + d c 26 + d CURLE_OUT_OF_MEMORY... + d c 27 + d CURLE_OPERATION_TIMEDOUT... + d c 28 + d CURLE_OBSOLETE29... + d c 29 + d CURLE_FTP_PORT_FAILED... + d c 30 + d CURLE_FTP_COULDNT_USE_REST... + d c 31 + d CURLE_OBSOLETE32... + d c 32 + d CURLE_RANGE_ERROR... + d c 33 + d CURLE_HTTP_POST_ERROR... + d c 34 + d CURLE_SSL_CONNECT_ERROR... + d c 35 + d CURLE_BAD_DOWNLOAD_RESUME... + d c 36 + d CURLE_FILE_COULDNT_READ_FILE... + d c 37 + d CURLE_LDAP_CANNOT_BIND... + d c 38 + d CURLE_LDAP_SEARCH_FAILED... + d c 39 + d CURLE_OBSOLETE40... + d c 40 + d CURLE_FUNCTION_NOT_FOUND... + d c 41 + d CURLE_ABORTED_BY_CALLBACK... + d c 42 + d CURLE_BAD_FUNCTION_ARGUMENT... + d c 43 + d CURLE_OBSOLETE44... + d c 44 + d CURLE_INTERFACE_FAILED... + d c 45 + d CURLE_OBSOLETE46... + d c 46 + d CURLE_TOO_MANY_REDIRECTS... + d c 47 + d CURLE_UNKNOWN_OPTION... + d c 48 + d CURLE_SETOPT_OPTION_SYNTAX... + d c 49 + d CURLE_OBSOLETE50... + d c 50 + d CURLE_OBSOLETE51... + d c 51 + d CURLE_GOT_NOTHING... + d c 52 + d CURLE_SSL_ENGINE_NOTFOUND... + d c 53 + d CURLE_SSL_ENGINE_SETFAILED... + d c 54 + d CURLE_SEND_ERROR... + d c 55 + d CURLE_RECV_ERROR... + d c 56 + d CURLE_OBSOLETE57... + d c 57 + d CURLE_SSL_CERTPROBLEM... + d c 58 + d CURLE_SSL_CIPHER... + d c 59 + d CURLE_PEER_FAILED_VERIFICATION... + d c 60 + d CURLE_BAD_CONTENT_ENCODING... + d c 61 + d CURLE_OBSOLETE62... + d c 62 + d CURLE_FILESIZE_EXCEEDED... + d c 63 + d CURLE_USE_SSL_FAILED... + d c 64 + d CURLE_SEND_FAIL_REWIND... + d c 65 + d CURLE_SSL_ENGINE_INITFAILED... + d c 66 + d CURLE_LOGIN_DENIED... + d c 67 + d CURLE_TFTP_NOTFOUND... + d c 68 + d CURLE_TFTP_PERM... + d c 69 + d CURLE_REMOTE_DISK_FULL... + d c 70 + d CURLE_TFTP_ILLEGAL... + d c 71 + d CURLE_TFTP_UNKNOWNID... + d c 72 + d CURLE_REMOTE_FILE_EXISTS... + d c 73 + d CURLE_TFTP_NOSUCHUSER... + d c 74 + d CURLE_OBSOLETE75... + d c 75 + d CURLE_OBSOLETE76... + d c 76 + d CURLE_SSL_CACERT_BADFILE... + d c 77 + d CURLE_REMOTE_FILE_NOT_FOUND... + d c 78 + d CURLE_SSH c 79 + d CURLE_SSL_SHUTDOWN_FAILED... + d c 80 + d CURLE_AGAIN c 81 + d CURLE_SSL_CRL_BADFILE... + d c 82 + d CURLE_SSL_ISSUER_ERROR... + d c 83 + d CURLE_FTP_PRET_FAILED... + d c 84 + d CURLE_RTSP_CSEQ_ERROR... + d c 85 + d CURLE_RTSP_SESSION_ERROR... + d c 86 + d CURLE_FTP_BAD_FILE_LIST... + d c 87 + d CURLE_CHUNK_FAILED... + d c 88 + d CURLE_NO_CONNECTION_AVAILABLE... + d c 89 + d CURLE_SSL_PINNEDPUBKEYNOTMATCH... + d c 90 + d CURLE_SSL_INVALIDCERTSTATUS... + d c 91 + d CURLE_HTTP2_STREAM... + d c 92 + d CURLE_RECURSIVE_API_CALL... + d c 93 + d CURLE_AUTH_ERROR... + d c 94 + d CURLE_HTTP3 c 95 + d CURLE_QUIC_CONNECT_ERROR... + d c 96 + d CURLE_PROXY c 97 + d CURLE_SSL_CLIENTCERT... + d c 98 + d CURLE_UNRECOVERABLE_POLL... + d c 99 + d CURLE_TOO_LARGE... + d c 100 + d CURLE_ECH_REQUIRED... + d c 101 + * + /if not defined(CURL_NO_OLDIES) + d CURLE_URL_MALFORMAT_USER... + d c 4 + d CURLE_FTP_WEIRD_SERVER_REPLY... + d c 8 + d CURLE_FTP_ACCESS_DENIED... + d c 9 + d CURLE_FTP_USER_PASSWORD_INCORRECT... + d c 10 + d CURLE_FTP_WEIRD_USER_REPLY... + d c 12 + d CURLE_FTP_CANT_RECONNECT... + d c 16 + d CURLE_FTP_COULDNT_SET_BINARY... + d c 17 + d CURLE_FTP_PARTIAL_FILE... + d c 18 + d CURLE_FTP_WRITE_ERROR... + d c 20 + d CURLE_FTP_QUOTE_ERROR... + d c 21 + d CURLE_HTTP_NOT_FOUND... + d c 22 + d CURLE_MALFORMAT_USER... + d c 24 + d CURLE_FTP_COULDNT_STOR_FILE... + d c 25 + d CURLE_OPERATION_TIMEOUTED... + d c 28 + d CURLE_FTP_COULDNT_SET_ASCII... + d c 29 + d CURLE_FTP_COULDNT_GET_SIZE... + d c 32 + d CURLE_HTTP_RANGE_ERROR... + d c 33 + d CURLE_FTP_BAD_DOWNLOAD_RESUME... + d c 36 + d CURLE_LIBRARY_NOT_FOUND... + d c 40 + d CURLE_BAD_CALLING_ORDER... + d c 44 + d CURLE_HTTP_PORT_FAILED... + d c 45 + d CURLE_BAD_PASSWORD_ENTERED... + d c 46 + d CURLE_UNKNOWN_TELNET_OPTION... + d c 48 + d CURLE_TELNET_OPTION_SYNTAX... + d c 49 + d CURLE_OBSOLETE... + d c 50 + d CURLE_SHARE_IN_USE... + d c 57 + d CURLE_SSL_CACERT... + d c 60 + d CURLE_SSL_PEER_CERTIFICATE... + d c 60 + d CURLE_LDAP_INVALID_URL... + d c 62 + d CURLE_FTP_SSL_FAILED... + d c 64 + d CURLE_TFTP_DISKFULL... + d c 70 + d CURLE_TFTP_EXISTS... + d c 73 + d CURLE_CONV_FAILED... + d c 75 + d CURLE_CONV_REQD... + d c 76 + d CURLE_ALREADY_COMPLETE... + d c 99999 + /endif + * + d CURLproxycode s 10i 0 based(######ptr######) Enum + d CURLPX_OK c 0 + d CURLPX_BAD_ADDRESS_TYPE... + d c 1 + d CURLPX_BAD_VERSION... + d c 2 + d CURLPX_CLOSED... + d c 3 + d CURLPX_GSSAPI... + d c 4 + d CURLPX_GSSAPI_PERMSG... + d c 5 + d CURLPX_GSSAPI_PROTECTION... + d c 6 + d CURLPX_IDENTD... + d c 7 + d CURLPX_IDENTD_DIFFER... + d c 8 + d CURLPX_LONG_HOSTNAME... + d c 9 + d CURLPX_LONG_PASSWD... + d c 10 + d CURLPX_LONG_USER... + d c 11 + d CURLPX_NO_AUTH... + d c 12 + d CURLPX_RECV_ADDRESS... + d c 13 + d CURLPX_RECV_AUTH... + d c 14 + d CURLPX_RECV_CONNECT... + d c 15 + d CURLPX_RECV_REQACK... + d c 16 + d CURLPX_REPLY_ADDRESS_TYPE_NOT_SUPPORTED... + d c 17 + d CURLPX_REPLY_COMMAND_NOT_SUPPORTED... + d c 18 + d CURLPX_REPLY_CONNECTION_REFUSED... + d c 10 + d CURLPX_REPLY_GENERAL_SERVER_FAILURE... + d c 20 + d CURLPX_REPLY_HOST_UNREACHABLE... + d c 21 + d CURLPX_REPLY_NETWORK_UNREACHABLE... + d c 22 + d CURLPX_REPLY_NOT_ALLOWED... + d c 23 + d CURLPX_REPLY_TTL_EXPIRED... + d c 24 + d CURLPX_REPLY_UNASSIGNED... + d c 25 + d CURLPX_REQUEST_FAILED... + d c 26 + d CURLPX_RESOLVE_HOST... + d c 27 + d CURLPX_SEND_AUTH... + d c 28 + d CURLPX_SEND_CONNECT... + d c 29 + d CURLPX_SEND_REQUEST... + d c 30 + d CURLPX_UNKNOWN_FAIL... + d c 31 + d CURLPX_UNKNOWN_MODE... + d c 32 + d CURLPX_USER_REJECTED... + d c 33 + * + d curlioerr s 10i 0 based(######ptr######) Enum + d CURLIOE_OK c 0 + d CURLIOE_UNKNOWNCMD... + d c 1 + d CURLIOE_FAILRESTART... + d c 2 + * + d curlfiletype s 10i 0 based(######ptr######) Enum + d CURLFILETYPE_FILE... + d c 0 + d CURLFILETYPE_DIRECTORY... + d c 1 + d CURLFILETYPE_SYMLINK... + d c 2 + d CURLFILETYPE_DEVICE_BLOCK... + d c 3 + d CURLFILETYPE_DEVICE_CHAR... + d c 4 + d CURLFILETYPE_NAMEDPIPE... + d c 5 + d CURLFILETYPE_SOCKET... + d c 6 + d CURLFILETYPE_DOOR... + d c 7 + * + d curliocmd s 10i 0 based(######ptr######) Enum + d CURLIOCMD_NOP c 0 + d CURLIOCMD_RESTARTREAD... + d c 1 + * + d curl_infotype s 10i 0 based(######ptr######) Enum + d CURLINFO_TEXT... + d c 0 + d CURLINFO_HEADER_IN... + d c 1 + d CURLINFO_HEADER_OUT... + d c 2 + d CURLINFO_DATA_IN... + d c 3 + d CURLINFO_DATA_OUT... + d c 4 + d CURLINFO_SSL_DATA_IN... + d c 5 + d CURLINFO_SSL_DATA_OUT... + d c 6 + d CURLINFO_END... + d c 7 + * + d curl_proxytype s 10i 0 based(######ptr######) Enum + d CURLPROXY_HTTP... + d c 0 + d CURLPROXY_HTTP_1_0... + d c 1 + d CURLPROXY_HTTPS... + d c 2 + d CURLPROXY_HTTPS2... + d c 3 + d CURLPROXY_SOCKS4... + d c 4 + d CURLPROXY_SOCKS5... + d c 5 + d CURLPROXY_SOCKS4A... + d c 6 + d CURLPROXY_SOCKS5_HOSTNAME... + d c 7 + * + d curl_khstat s 10i 0 based(######ptr######) Enum + d CURLKHSTAT_FINE_ADD_TO_FILE... + d c 0 + d CURLKHSTAT_FINE... + d c 1 + d CURLKHSTAT_REJECT... + d c 2 + d CURLKHSTAT_DEFER... + d c 3 + d CURLKHSTAT_FINE_REPLACE... + d c 4 + d CURLKHSTAT_LAST... + d c 5 + * + d curl_khmatch s 10i 0 based(######ptr######) Enum + d CURLKHMATCH_OK... + d c 0 + d CURLKHMATCH_MISMATCH... + d c 1 + d CURLKHMATCH_MISSING... + d c 2 + d CURLKHMATCH_LAST... + d c 3 + * + d curl_usessl s 10i 0 based(######ptr######) Enum + d CURLUSESSL_NONE... + d c 0 + d CURLUSESSL_TRY... + d c 1 + d CURLUSESSL_CONTROL... + d c 2 + d CURLUSESSL_ALL... + d c 3 + * + d CURLSSLOPT_ALLOW_BEAST... + d c X'00000001' + d CURLSSLOPT_NO_REVOKE... + d c X'00000002' + d CURLSSLOPT_NO_PARTIALCHAIN... + d c X'00000004' + d CURLSSLOPT_REVOKE_BEST_EFFORT... + d c X'00000008' + d CURLSSLOPT_NATIVE_CA... + d c X'00000010' + d CURLSSLOPT_AUTO_CLIENT_CERT... + d c X'00000020' + * + d CURLFOLLOW_ALL c 1 + d CURLFOLLOW_OBEYCODE... + d c 2 + d CURLFOLLOW_FIRSTONLY... + d c 3 + * + d CURL_HET_DEFAULT... + d c 200 + * + d CURL_UPKEEP_INTERVAL_DEFAULT... + d c 60000 + * + /if not defined(CURL_NO_OLDIES) + d curl_ftpssl s like(curl_usessl) + d based(######ptr######) + d CURLFTPSSL_NONE... + d c 0 + d CURLFTPSSL_TRY... + d c 1 + d CURLFTPSSL_CONTROL... + d c 2 + d CURLFTPSSL_ALL... + d c 3 + /endif + * + d curl_ftpccc s 10i 0 based(######ptr######) Enum + d CURLFTPSSL_CCC_NONE... + d c 0 + d CURLFTPSSL_CCC_PASSIVE... + d c 1 + d CURLFTPSSL_CCC_ACTIVE... + d c 2 + * + d curl_ftpauth s 10i 0 based(######ptr######) Enum + d CURLFTPAUTH_DEFAULT... + d c 0 + d CURLFTPAUTH_SSL... + d c 1 + d CURLFTPAUTH_TLS... + d c 2 + * + d curl_ftpcreatedir... + d s 10i 0 based(######ptr######) Enum + d CURLFTP_CREATE_DIR_NONE... + d c 0 + d CURLFTP_CREATE_DIR... + d c 1 + d CURLFTP_CREATE_DIR_RETRY... + d c 2 + * + d curl_ftpmethod s 10i 0 based(######ptr######) Enum + d CURLFTPMETHOD_DEFAULT... + d c 0 + d CURLFTPMETHOD_MULTICWD... + d c 1 + d CURLFTPMETHOD_NOCWD... + d c 2 + d CURLFTPMETHOD_SINGLECWD... + d c 3 + * + d CURLHEADER_UNIFIED... + d c X'00000000' + d CURLHEADER_SEPARATE... + d c X'00000001' + * + d CURLALTSVC_READONLYFILE... + d c X'00000004' + d CURLALTSVC_H1... + d c X'00000008' + d CURLALTSVC_H2... + d c X'00000010' + d CURLALTSVC_H3... + d c X'00000020' + * + d CURLULFLAG_ANSWERED... + d c X'00000001' + d CURLULFLAG_DELETED... + d c X'00000002' + d CURLULFLAG_DRAFT... + d c X'00000004' + d CURLULFLAG_FLAGGED... + d c X'00000008' + d CURLULFLAG_SEEN... + d c X'00000010' + * + d CURLHSTS_ENABLE... + d c X'00000001' + d CURLHSTS_READONLYFILE... + d c X'00000002' + * + d CURLPROTO_HTTP... + d c X'00000001' + d CURLPROTO_HTTPS... + d c X'00000002' + d CURLPROTO_FTP... + d c X'00000004' + d CURLPROTO_FTPS... + d c X'00000008' + d CURLPROTO_SCP... + d c X'00000010' + d CURLPROTO_SFTP... + d c X'00000020' + d CURLPROTO_TELNET... + d c X'00000040' + d CURLPROTO_LDAP... + d c X'00000080' + d CURLPROTO_LDAPS... + d c X'00000100' + d CURLPROTO_DICT... + d c X'00000200' + d CURLPROTO_FILE... + d c X'00000400' + d CURLPROTO_TFTP... + d c X'00000800' + d CURLPROTO_IMAP... + d c X'00001000' + d CURLPROTO_IMAPS... + d c X'00002000' + d CURLPROTO_POP3... + d c X'00004000' + d CURLPROTO_POP3S... + d c X'00008000' + d CURLPROTO_SMTP... + d c X'00010000' + d CURLPROTO_SMTPS... + d c X'00020000' + d CURLPROTO_RTSP... + d c X'00040000' + d CURLPROTO_RTMP... + d c X'00080000' + d CURLPROTO_RTMPT... + d c X'00100000' + d CURLPROTO_RTMPTE... + d c X'00200000' + d CURLPROTO_RTMPE... + d c X'00400000' + d CURLPROTO_RTMPS... + d c X'00800000' + d CURLPROTO_RTMPTS... + d c X'01000000' + d CURLPROTO_GOPHER... + d c X'02000000' + d CURLPROTO_SMB... + d c X'04000000' + d CURLPROTO_SMBS... + d c X'08000000' + d CURLPROTO_MQTT... + d c X'10000000' + d CURLPROTO_GOPHERS... + d c X'20000000' + d CURLPROTO_MQTTS... + d c X'40000000' + d CURLPROTO_ALL c X'FFFFFFFF' + * + d CURLoption s 10i 0 based(######ptr######) Enum + d CURLOPT_WRITEDATA... + d c 10001 + d CURLOPT_URL c 10002 + d CURLOPT_PORT c 00003 + d CURLOPT_PROXY c 10004 + d CURLOPT_USERPWD... + d c 10005 + d CURLOPT_PROXYUSERPWD... + d c 10006 + d CURLOPT_RANGE c 10007 + d CURLOPT_READDATA... + d c 10009 + d CURLOPT_ERRORBUFFER... + d c 10010 + d CURLOPT_WRITEFUNCTION... + d c 20011 + d CURLOPT_READFUNCTION... + d c 20012 + d CURLOPT_TIMEOUT... + d c 00013 + d CURLOPT_INFILESIZE... + d c 00014 + d CURLOPT_POSTFIELDS... + d c 10015 + d CURLOPT_REFERER... + d c 10016 + d CURLOPT_FTPPORT... + d c 10017 + d CURLOPT_USERAGENT... + d c 10018 + d CURLOPT_LOW_SPEED_LIMIT... + d c 00019 + d CURLOPT_LOW_SPEED_TIME... + d c 00020 + d CURLOPT_RESUME_FROM... + d c 00021 + d CURLOPT_COOKIE... + d c 10022 + d CURLOPT_HTTPHEADER... + d c 10023 + d CURLOPT_RTSPHEADER... + d c 10023 + d CURLOPT_HTTPPOST... + d c 10024 + d CURLOPT_SSLCERT... + d c 10025 + d CURLOPT_KEYPASSWD... + d c 10026 + d CURLOPT_CRLF c 00027 + d CURLOPT_QUOTE c 10028 + d CURLOPT_HEADERDATA... + d c 10029 + d CURLOPT_COOKIEFILE... + d c 10031 + d CURLOPT_SSLVERSION... + d c 00032 + d CURLOPT_TIMECONDITION... + d c 00033 + d CURLOPT_TIMEVALUE... + d c 00034 + d CURLOPT_CUSTOMREQUEST... + d c 10036 + d CURLOPT_STDERR... + d c 10037 + d CURLOPT_POSTQUOTE... + d c 10039 + d CURLOPT_VERBOSE... + d c 00041 + d CURLOPT_HEADER... + d c 00042 + d CURLOPT_NOPROGRESS... + d c 00043 + d CURLOPT_NOBODY... + d c 00044 + d CURLOPT_FAILONERROR... + d c 00045 + d CURLOPT_UPLOAD... + d c 00046 + d CURLOPT_POST c 00047 + d CURLOPT_DIRLISTONLY... + d c 00048 + d CURLOPT_APPEND... + d c 00050 + d CURLOPT_NETRC c 00051 + d CURLOPT_FOLLOWLOCATION... + d c 00052 + d CURLOPT_TRANSFERTEXT... + d c 00053 + d CURLOPT_PUT c 00054 + d CURLOPT_PROGRESSFUNCTION... + d c 20056 + d CURLOPT_PROGRESSDATA... + d c 10057 + d CURLOPT_XFERINFODATA... + d c 10057 PROGRESSDATA alias + d CURLOPT_AUTOREFERER... + d c 00058 + d CURLOPT_PROXYPORT... + d c 00059 + d CURLOPT_POSTFIELDSIZE... + d c 00060 + d CURLOPT_HTTPPROXYTUNNEL... + d c 00061 + d CURLOPT_INTERFACE... + d c 10062 + d CURLOPT_KRBLEVEL... + d c 10063 + d CURLOPT_SSL_VERIFYPEER... + d c 00064 + d CURLOPT_CAINFO... + d c 10065 + d CURLOPT_MAXREDIRS... + d c 00068 + d CURLOPT_FILETIME... + d c 00069 + d CURLOPT_TELNETOPTIONS... + d c 10070 + d CURLOPT_MAXCONNECTS... + d c 00071 + d CURLOPT_FRESH_CONNECT... + d c 00074 + d CURLOPT_FORBID_REUSE... + d c 00075 + d CURLOPT_RANDOM_FILE... + d c 10076 + d CURLOPT_EGDSOCKET... + d c 10077 + d CURLOPT_CONNECTTIMEOUT... + d c 00078 + d CURLOPT_HEADERFUNCTION... + d c 20079 + d CURLOPT_HTTPGET... + d c 00080 + d CURLOPT_SSL_VERIFYHOST... + d c 00081 + d CURLOPT_COOKIEJAR... + d c 10082 + d CURLOPT_SSL_CIPHER_LIST... + d c 10083 + d CURLOPT_HTTP_VERSION... + d c 00084 + d CURLOPT_FTP_USE_EPSV... + d c 00085 + d CURLOPT_SSLCERTTYPE... + d c 10086 + d CURLOPT_SSLKEY... + d c 10087 + d CURLOPT_SSLKEYTYPE... + d c 10088 + d CURLOPT_SSLENGINE... + d c 10089 + d CURLOPT_SSLENGINE_DEFAULT... + d c 00090 + d CURLOPT_DNS_USE_GLOBAL_CACHE... + d c 00091 + d CURLOPT_DNS_CACHE_TIMEOUT... + d c 00092 + d CURLOPT_PREQUOTE... + d c 10093 + d CURLOPT_DEBUGFUNCTION... + d c 20094 + d CURLOPT_DEBUGDATA... + d c 10095 + d CURLOPT_COOKIESESSION... + d c 00096 + d CURLOPT_CAPATH... + d c 10097 + d CURLOPT_BUFFERSIZE... + d c 00098 + d CURLOPT_NOSIGNAL... + d c 00099 + d CURLOPT_SHARE c 10100 + d CURLOPT_PROXYTYPE... + d c 00101 + d CURLOPT_ACCEPT_ENCODING... + d c 10102 + d CURLOPT_PRIVATE... + d c 10103 + d CURLOPT_HTTP200ALIASES... + d c 10104 + d CURLOPT_UNRESTRICTED_AUTH... + d c 00105 + d CURLOPT_FTP_USE_EPRT... + d c 00106 + d CURLOPT_HTTPAUTH... + d c 00107 + d CURLOPT_SSL_CTX_FUNCTION... + d c 20108 + d CURLOPT_SSL_CTX_DATA... + d c 10109 + d CURLOPT_FTP_CREATE_MISSING_DIRS... + d c 00110 + d CURLOPT_PROXYAUTH... + d c 00111 + d CURLOPT_SERVER_RESPONSE_TIMEOUT... + d c 00112 + d CURLOPT_IPRESOLVE... + d c 00113 + d CURLOPT_MAXFILESIZE... + d c 00114 + d CURLOPT_INFILESIZE_LARGE... + d c 30115 + d CURLOPT_RESUME_FROM_LARGE... + d c 30116 + d CURLOPT_MAXFILESIZE_LARGE... + d c 30117 + d CURLOPT_NETRC_FILE... + d c 10118 + d CURLOPT_USE_SSL... + d c 00119 + d CURLOPT_POSTFIELDSIZE_LARGE... + d c 30120 + d CURLOPT_TCP_NODELAY... + d c 00121 + d CURLOPT_FTPSSLAUTH... + d c 00129 + d CURLOPT_IOCTLFUNCTION... + d c 20130 + d CURLOPT_IOCTLDATA... + d c 10131 + d CURLOPT_FTP_ACCOUNT... + d c 10134 + d CURLOPT_COOKIELIST... + d c 10135 + d CURLOPT_IGNORE_CONTENT_LENGTH... + d c 00136 + d CURLOPT_FTP_SKIP_PASV_IP... + d c 00137 + d CURLOPT_FTP_FILEMETHOD... + d c 00138 + d CURLOPT_LOCALPORT... + d c 00139 + d CURLOPT_LOCALPORTRANGE... + d c 00140 + d CURLOPT_CONNECT_ONLY... + d c 00141 + d CURLOPT_CONV_FROM_NETWORK_FUNCTION... + d c 20142 + d CURLOPT_CONV_TO_NETWORK_FUNCTION... + d c 20143 + d CURLOPT_CONV_FROM_UTF8_FUNCTION... + d c 20144 + d CURLOPT_MAX_SEND_SPEED_LARGE... + d c 30145 + d CURLOPT_MAX_RECV_SPEED_LARGE... + d c 30146 + d CURLOPT_FTP_ALTERNATIVE_TO_USER... + d c 10147 + d CURLOPT_SOCKOPTFUNCTION... + d c 20148 + d CURLOPT_SOCKOPTDATA... + d c 10149 + d CURLOPT_SSL_SESSIONID_CACHE... + d c 00150 + d CURLOPT_SSH_AUTH_TYPES... + d c 00151 + d CURLOPT_SSH_PUBLIC_KEYFILE... + d c 10152 + d CURLOPT_SSH_PRIVATE_KEYFILE... + d c 10153 + d CURLOPT_FTP_SSL_CCC... + d c 00154 + d CURLOPT_TIMEOUT_MS... + d c 00155 + d CURLOPT_CONNECTTIMEOUT_MS... + d c 00156 + d CURLOPT_HTTP_TRANSFER_DECODING... + d c 00157 + d CURLOPT_HTTP_CONTENT_DECODING... + d c 00158 + d CURLOPT_NEW_FILE_PERMS... + d c 00159 + d CURLOPT_NEW_DIRECTORY_PERMS... + d c 00160 + d CURLOPT_POSTREDIR... + d c 00161 + d CURLOPT_SSH_HOST_PUBLIC_KEY_MD5... + d c 10162 + d CURLOPT_OPENSOCKETFUNCTION... + d c 20163 + d CURLOPT_OPENSOCKETDATA... + d c 10164 + d CURLOPT_COPYPOSTFIELDS... + d c 10165 + d CURLOPT_PROXY_TRANSFER_MODE... + d c 00166 + d CURLOPT_SEEKFUNCTION... + d c 20167 + d CURLOPT_SEEKDATA... + d c 10168 + d CURLOPT_CRLFILE... + d c 10169 + d CURLOPT_ISSUERCERT... + d c 10170 + d CURLOPT_ADDRESS_SCOPE... + d c 00171 + d CURLOPT_CERTINFO... + d c 00172 + d CURLOPT_USERNAME... + d c 10173 + d CURLOPT_PASSWORD... + d c 10174 + d CURLOPT_PROXYUSERNAME... + d c 10175 + d CURLOPT_PROXYPASSWORD... + d c 10176 + d CURLOPT_NOPROXY... + d c 10177 + d CURLOPT_TFTP_BLKSIZE... + d c 00178 + d CURLOPT_SOCKS5_GSSAPI_SERVICE... + d c 10179 + d CURLOPT_SOCKS5_GSSAPI_NEC... + d c 00180 + d CURLOPT_PROTOCOLS... + d c 00181 + d CURLOPT_REDIR_PROTOCOLS... + d c 00182 + d CURLOPT_SSH_KNOWNHOSTS... + d c 10183 + d CURLOPT_SSH_KEYFUNCTION... + d c 20184 + d CURLOPT_SSH_KEYDATA... + d c 10185 + d CURLOPT_MAIL_FROM... + d c 10186 + d CURLOPT_MAIL_RCPT... + d c 10187 + d CURLOPT_FTP_USE_PRET... + d c 00188 + d CURLOPT_RTSP_REQUEST... + d c 00189 + d CURLOPT_RTSP_SESSION_ID... + d c 10190 + d CURLOPT_RTSP_STREAM_URI... + d c 10191 + d CURLOPT_RTSP_TRANSPORT... + d c 10192 + d CURLOPT_RTSP_CLIENT_CSEQ... + d c 00193 + d CURLOPT_RTSP_SERVER_CSEQ... + d c 00194 + d CURLOPT_INTERLEAVEDATA... + d c 10195 + d CURLOPT_INTERLEAVEFUNCTION... + d c 20196 + d CURLOPT_WILDCARDMATCH... + d c 00197 + d CURLOPT_CHUNK_BGN_FUNCTION... + d c 20198 + d CURLOPT_CHUNK_END_FUNCTION... + d c 20199 + d CURLOPT_FNMATCH_FUNCTION... + d c 20200 + d CURLOPT_CHUNK_DATA... + d c 10201 + d CURLOPT_FNMATCH_DATA... + d c 10202 + d CURLOPT_RESOLVE... + d c 10203 + d CURLOPT_TLSAUTH_USERNAME... + d c 10204 + d CURLOPT_TLSAUTH_PASSWORD... + d c 10205 + d CURLOPT_TLSAUTH_TYPE... + d c 10206 + d CURLOPT_TRANSFER_ENCODING... + d c 00207 + d CURLOPT_CLOSESOCKETFUNCTION... + d c 20208 + d CURLOPT_CLOSESOCKETDATA... + d c 10209 + d CURLOPT_GSSAPI_DELEGATION... + d c 00210 + d CURLOPT_DNS_SERVERS... + d c 10211 + d CURLOPT_ACCEPTTIMEOUT_MS... + d c 00212 + d CURLOPT_TCP_KEEPALIVE... + d c 00213 + d CURLOPT_TCP_KEEPIDLE... + d c 00214 + d CURLOPT_TCP_KEEPINTVL... + d c 00215 + d CURLOPT_SSL_OPTIONS... + d c 00216 + d CURLOPT_MAIL_AUTH... + d c 10217 + d CURLOPT_SASL_IR... + d c 00218 + d CURLOPT_XFERINFOFUNCTION... + d c 20219 + d CURLOPT_XOAUTH2_BEARER... + d c 10220 + d CURLOPT_DNS_INTERFACE... + d c 10221 + d CURLOPT_DNS_LOCAL_IP4... + d c 10222 + d CURLOPT_DNS_LOCAL_IP6... + d c 10223 + d CURLOPT_LOGIN_OPTIONS... + d c 10224 + d CURLOPT_SSL_ENABLE_NPN... + d c 00225 + d CURLOPT_SSL_ENABLE_ALPN... + d c 00226 + d CURLOPT_EXPECT_100_TIMEOUT_MS... + d c 00227 + d CURLOPT_PROXYHEADER... + d c 10228 + d CURLOPT_HEADEROPT... + d c 00229 + d CURLOPT_PINNEDPUBLICKEY... + d c 10230 + d CURLOPT_UNIX_SOCKET_PATH... + d c 10231 + d CURLOPT_SSL_VERIFYSTATUS... + d c 00232 + d CURLOPT_SSL_FALSESTART... + d c 00233 + d CURLOPT_PATH_AS_IS... + d c 00234 + d CURLOPT_PROXY_SERVICE_NAME... + d c 10235 + d CURLOPT_SERVICE_NAME... + d c 10236 + d CURLOPT_PIPEWAIT... + d c 00237 + d CURLOPT_DEFAULT_PROTOCOL... + d c 10238 + d CURLOPT_STREAM_WEIGHT... + d c 00239 + d CURLOPT_STREAM_DEPENDS... + d c 10240 + d CURLOPT_STREAM_DEPENDS_E... + d c 10241 + d CURLOPT_TFTP_NO_OPTIONS... + d c 00242 + d CURLOPT_CONNECT_TO... + d c 10243 + d CURLOPT_TCP_FASTOPEN... + d c 00244 + d CURLOPT_KEEP_SENDING_ON_ERROR... + d c 00245 + d CURLOPT_PROXY_CAINFO... + d c 10246 + d CURLOPT_PROXY_CAPATH... + d c 10247 + d CURLOPT_PROXY_SSL_VERIFYPEER... + d c 00248 + d CURLOPT_PROXY_SSL_VERIFYHOST... + d c 00249 + d CURLOPT_PROXY_SSLVERSION... + d c 00250 + d CURLOPT_PROXY_TLSAUTH_USERNAME... + d c 10251 + d CURLOPT_PROXY_TLSAUTH_PASSWORD... + d c 10252 + d CURLOPT_PROXY_TLSAUTH_TYPE... + d c 10253 + d CURLOPT_PROXY_SSLCERT... + d c 10254 + d CURLOPT_PROXY_SSLCERTTYPE... + d c 10255 + d CURLOPT_PROXY_SSLKEY... + d c 10256 + d CURLOPT_PROXY_SSLKEYTYPE... + d c 10257 + d CURLOPT_PROXY_KEYPASSWD... + d c 10258 + d CURLOPT_PROXY_SSL_CIPHER_LIST... + d c 10259 + d CURLOPT_PROXY_CRLFILE... + d c 10260 + d CURLOPT_PROXY_SSL_OPTIONS... + d c 00261 + d CURLOPT_PRE_PROXY... + d c 10262 + d CURLOPT_PROXY_PINNEDPUBLICKEY... + d c 10263 + d CURLOPT_ABSTRACT_UNIX_SOCKET... + d c 10264 + d CURLOPT_SUPPRESS_CONNECT_HEADERS... + d c 00265 + d CURLOPT_REQUEST_TARGET... + d c 10266 + d CURLOPT_SOCKS5_AUTH... + d c 00267 + d CURLOPT_SSH_COMPRESSION... + d c 00268 + d CURLOPT_MIMEPOST... + d c 10269 + d CURLOPT_TIMEVALUE_LARGE... + d c 30270 + d CURLOPT_HAPPY_EYEBALLS_TIMEOUT_MS... + d c 00271 + d CURLOPT_RESOLVER_START_FUNCTION... + d c 20272 + d CURLOPT_RESOLVER_START_DATA... + d c 10273 + d CURLOPT_HAPROXYPROTOCOL... + d c 00274 + d CURLOPT_DNS_SHUFFLE_ADDRESSES... + d c 00275 + d CURLOPT_TLS13_CIPHERS... + d c 10276 + d CURLOPT_PROXY_TLS13_CIPHERS... + d c 10277 + d CURLOPT_DISALLOW_USERNAME_IN_URL... + d c 00278 + d CURLOPT_DOH_URL... + d c 10279 + d CURLOPT_UPLOAD_BUFFERSIZE... + d c 00280 + d CURLOPT_UPKEEP_INTERVAL_MS... + d c 00281 + d CURLOPT_CURLU c 10282 + d CURLOPT_TRAILERFUNCTION... + d c 20283 + d CURLOPT_TRAILERDATA... + d c 10284 + d CURLOPT_HTTP09_ALLOWED... + d c 00285 + d CURLOPT_ALTSVC_CTRL... + d c 00286 + d CURLOPT_ALTSVC... + d c 10287 + d CURLOPT_MAXAGE_CONN... + d c 00288 + d CURLOPT_SASL_AUTHZID... + d c 10289 + d CURLOPT_MAIL_RCPT_ALLOWFAILS... + d c 00290 + d CURLOPT_SSLCERT_BLOB... + d c 40291 + d CURLOPT_SSLKEY_BLOB... + d c 40292 + d CURLOPT_PROXY_SSLCERT_BLOB... + d c 40293 + d CURLOPT_PROXY_SSLKEY_BLOB... + d c 40294 + d CURLOPT_ISSUERCERT_BLOB... + d c 40295 + d CURLOPT_PROXY_ISSUERCERT... + d c 10296 + d CURLOPT_PROXY_ISSUERCERT_BLOB... + d c 40297 + d CURLOPT_SSL_EC_CURVES... + d c 10298 + d CURLOPT_HSTS_CTRL... + d c 00299 + d CURLOPT_HSTS... + d c 10300 + d CURLOPT_HSTSREADFUNCTION... + d c 20301 + d CURLOPT_HSTSREADDATA... + d c 10302 + d CURLOPT_HSTSWRITEFUNCTION... + d c 20303 + d CURLOPT_HSTSWRITEDATA... + d c 10304 + d CURLOPT_AWS_SIG4... + d c 10305 + d CURLOPT_DOH_SSL_VERIFYPEER... + d c 00306 + d CURLOPT_DOH_SSL_VERIFYHOST... + d c 00307 + d CURLOPT_DOH_SSL_VERIFYSTATUS... + d c 00308 + d CURLOPT_CAINFO_BLOB... + d c 40309 + d CURLOPT_PROXY_CAINFO_BLOB... + d c 40310 + d CURLOPT_SSH_HOST_PUBLIC_KEY_SHA256... + d c 10311 + d CURLOPT_PREREQFUNCTION... + d c 20312 + d CURLOPT_PREREQDATA... + d c 10313 + d CURLOPT_MAXLIFETIME_CONN... + d c 00314 + d CURLOPT_MIME_OPTIONS... + d c 00315 + d CURLOPT_SSH_HOSTKEYFUNCTION... + d c 20316 + d CURLOPT_SSH_HOSTKEYDATA... + d c 10317 + d CURLOPT_PROTOCOLS_STR... + d c 10318 + d CURLOPT_REDIR_PROTOCOLS_STR... + d c 10319 + d CURLOPT_WS_OPTIONS... + d c 00320 + d CURLOPT_CA_CACHE_TIMEOUT... + d c 00321 + d CURLOPT_QUICK_EXIT... + d c 00322 + d CURLOPT_HAPROXY_CLIENT_IP... + d c 10323 + d CURLOPT_SERVER_RESPONSE_TIMEOUT_MS... + d c 00324 + d CURLOPT_ECH c 10325 + d CURLOPT_TCP_KEEPCNT... + d c 00326 + d CURLOPT_UPLOAD_FLAGS... + d c 00327 + d CURLOPT_SSL_SIGNATURE_ALGORITHMS... + d c 10328 + * + /if not defined(CURL_NO_OLDIES) + d CURLOPT_FILE c 10001 + d CURLOPT_INFILE... + d c 10009 + d CURLOPT_SSLKEYPASSWD... + d c 10026 + d CURLOPT_SSLCERTPASSWD... + d c 10026 + d CURLOPT_WRITEHEADER... + d c 10029 + d CURLOPT_WRITEINFO... + d c 10040 + d CURLOPT_FTPLISTONLY... + d c 00048 + d CURLOPT_FTPAPPEND... + d c 00050 + d CURLOPT_CLOSEPOLICY... + d c 00072 + d CURLOPT_KRB4LEVEL... + d c 10063 + d CURLOPT_ENCODING... + d c 10102 + d CURLOPT_FTP_SSL... + d c 00119 + d CURLOPT_POST301... + d c 00161 + d CURLOPT_FTP_RESPONSE_TIMEOUT... + d c 00112 + /endif + * + d CURLFORMcode s 10i 0 based(######ptr######) Enum + d CURL_FORMADD_OK... + d c 0 + d CURL_FORMADD_MEMORY... + d c 1 + d CURL_FORMADD_OPTION_TWICE... + d c 2 + d CURL_FORMADD_NULL... + d c 3 + d CURL_FORMADD_UNKNOWN_OPTION... + d c 4 + d CURL_FORMADD_INCOMPLETE... + d c 5 + d CURL_FORMADD_ILLEGAL_ARRAY... + d c 6 + d CURL_FORMADD_DISABLED... + d c 7 + * + d CURLformoption s 10i 0 based(######ptr######) Enum + d CURLFORM_NOTHING... + d c 0 + d CURLFORM_COPYNAME... + d c 1 + d CURLFORM_PTRNAME... + d c 2 + d CURLFORM_NAMELENGTH... + d c 3 + d CURLFORM_COPYCONTENTS... + d c 4 + d CURLFORM_PTRCONTENTS... + d c 5 + d CURLFORM_CONTENTSLENGTH... + d c 6 + d CURLFORM_FILECONTENT... + d c 7 + d CURLFORM_ARRAY... + d c 8 + d CURLFORM_OBSOLETE... + d c 9 + d CURLFORM_FILE... + d c 10 + d CURLFORM_BUFFER... + d c 11 + d CURLFORM_BUFFERPTR... + d c 12 + d CURLFORM_BUFFERLENGTH... + d c 13 + d CURLFORM_CONTENTTYPE... + d c 14 + d CURLFORM_CONTENTHEADER... + d c 15 + d CURLFORM_FILENAME... + d c 16 + d CURLFORM_END... + d c 17 + d CURLFORM_OBSOLETE2... + d c 18 + d CURLFORM_STREAM... + d c 19 + d CURLFORM_CONTENTLEN... + d c 20 + * + d CURLMIMEOPT_FORMESCAPE... + d c X'00000001' + * + d CURLINFO s 10i 0 based(######ptr######) Enum + d CURLINFO_EFFECTIVE_URL... CURLINFO_STRING + 1 + d c X'00100001' + d CURLINFO_RESPONSE_CODE... CURLINFO_LONG + 2 + d c X'00200002' + d CURLINFO_TOTAL_TIME... CURLINFO_DOUBLE + 3 + d c X'00300003' + d CURLINFO_NAMELOOKUP_TIME... CURLINFO_DOUBLE + 4 + d c X'00300004' + d CURLINFO_CONNECT_TIME... CURLINFO_DOUBLE + 5 + d c X'00300005' + d CURLINFO_PRETRANSFER_TIME... CURLINFO_DOUBLE + 6 + d c X'00300006' + d CURLINFO_SIZE_UPLOAD... CURLINFO_DOUBLE + 7 + d c X'00300007' + d CURLINFO_SIZE_UPLOAD_T... CURLINFO_OFF_T + 7 + d c X'00600007' + d CURLINFO_SIZE_DOWNLOAD... CURLINFO_DOUBLE + 8 + d c X'00300008' + d CURLINFO_SIZE_DOWNLOAD_T... CURLINFO_OFF_T + 8 + d c X'00600008' + d CURLINFO_SPEED_DOWNLOAD... CURLINFO_DOUBLE + 9 + d c X'00300009' + d CURLINFO_SPEED_DOWNLOAD_T... CURLINFO_OFF_T + 9 + d c X'00600009' + d CURLINFO_SPEED_UPLOAD... CURLINFO_DOUBLE + 10 + d c X'0030000A' + d CURLINFO_SPEED_UPLOAD_T... CURLINFO_OFF_T + 10 + d c X'0060000A' + d CURLINFO_HEADER_SIZE... CURLINFO_LONG + 11 + d c X'0020000B' + d CURLINFO_REQUEST_SIZE... CURLINFO_LONG + 12 + d c X'0020000C' + d CURLINFO_SSL_VERIFYRESULT... CURLINFO_LONG + 13 + d c X'0020000D' + d CURLINFO_FILETIME... CURLINFO_LONG + 14 + d c X'0020000E' + d CURLINFO_FILETIME_T... CURLINFO_OFF_T + 14 + d c X'0060000E' + d CURLINFO_CONTENT_LENGTH_DOWNLOAD... CURLINFO_DOUBLE + 15 + d c X'0030000F' + d CURLINFO_CONTENT_LENGTH_DOWNLOAD_T... CURLINFO_OFF_T + 15 + d c X'0060000F' + d CURLINFO_CONTENT_LENGTH_UPLOAD... CURLINFO_DOUBLE + 16 + d c X'00300010' + d CURLINFO_CONTENT_LENGTH_UPLOAD_T... CURLINFO_OFF_T + 16 + d c X'00600010' + d CURLINFO_STARTTRANSFER_TIME... CURLINFO_DOUBLE + 17 + d c X'00300011' + d CURLINFO_CONTENT_TYPE... CURLINFO_STRING + 18 + d c X'00100012' + d CURLINFO_REDIRECT_TIME... CURLINFO_DOUBLE + 19 + d c X'00300013' + d CURLINFO_REDIRECT_COUNT... CURLINFO_LONG + 20 + d c X'00200014' + d CURLINFO_PRIVATE... CURLINFO_STRING + 21 + d c X'00100015' + d CURLINFO_HTTP_CONNECTCODE... CURLINFO_LONG + 22 + d c X'00200016' + d CURLINFO_HTTPAUTH_AVAIL... CURLINFO_LONG + 23 + d c X'00200017' + d CURLINFO_PROXYAUTH_AVAIL... CURLINFO_LONG + 24 + d c X'00200018' + d CURLINFO_OS_ERRNO... CURLINFO_LONG + 25 + d c X'00200019' + d CURLINFO_NUM_CONNECTS... CURLINFO_LONG + 26 + d c X'0020001A' + d CURLINFO_SSL_ENGINES... CURLINFO_SLIST + 27 + d c X'0040001B' + d CURLINFO_COOKIELIST... CURLINFO_SLIST + 28 + d c X'0040001C' + d CURLINFO_LASTSOCKET... CURLINFO_LONG + 29 + d c X'0020001D' + d CURLINFO_FTP_ENTRY_PATH... CURLINFO_STRING + 30 + d c X'0010001E' + d CURLINFO_REDIRECT_URL... CURLINFO_STRING + 31 + d c X'0010001F' + d CURLINFO_PRIMARY_IP... CURLINFO_STRING + 32 + d c X'00100020' + d CURLINFO_APPCONNECT_TIME... CURLINFO_DOUBLE + 33 + d c X'00300021' + d CURLINFO_CERTINFO... CURLINFO_SLIST + 34 + d c X'00400022' + d CURLINFO_CONDITION_UNMET... CURLINFO_LONG + 35 + d c X'00200023' + d CURLINFO_RTSP_SESSION_ID... CURLINFO_STRING + 36 + d c X'00100024' + d CURLINFO_RTSP_CLIENT_CSEQ... CURLINFO_LONG + 37 + d c X'00200025' + d CURLINFO_RTSP_SERVER_CSEQ... CURLINFO_LONG + 38 + d c X'00200026' + d CURLINFO_RTSP_CSEQ_RECV... CURLINFO_LONG + 39 + d c X'00200027' + d CURLINFO_PRIMARY_PORT... CURLINFO_LONG + 40 + d c X'00200028' + d CURLINFO_LOCAL_IP... CURLINFO_STRING + 41 + d c X'00100029' + d CURLINFO_LOCAL_PORT... CURLINFO_LONG + 42 + d c X'0020002A' + d CURLINFO_TLS_SESSION... CURLINFO_SLIST + 43 + d c X'0040002B' + d CURLINFO_ACTIVESOCKET... CURLINFO_SOCKET + 44 + d c X'0050002C' + d CURLINFO_TLS_SSL_PTR... CURLINFO_SLIST + 45 + d c X'0040002D' + d CURLINFO_HTTP_VERSION... CURLINFO_LONG + 46 + d c X'0020002E' + d CURLINFO_PROXY_SSL_VERIFYRESULT... CURLINFO_LONG + 47 + d c X'0020002F' + d CURLINFO_PROTOCOL... CURLINFO_LONG + 48 + d c X'00200030' + d CURLINFO_SCHEME... CURLINFO_STRING + 49 + d c X'00100031' + d CURLINFO_TOTAL_TIME_T... CURLINFO_OFF_T + 50 + d c X'00600032' + d CURLINFO_NAMELOOKUP_TIME_T... CURLINFO_OFF_T + 51 + d c X'00600033' + d CURLINFO_CONNECT_TIME_T... CURLINFO_OFF_T + 52 + d c X'00600034' + d CURLINFO_PRETRANSFER_TIME_T... CURLINFO_OFF_T + 53 + d c X'00600035' + d CURLINFO_STARTTRANSFER_TIME_T... CURLINFO_OFF_T + 54 + d c X'00600036' + d CURLINFO_REDIRECT_TIME_T... CURLINFO_OFF_T + 55 + d c X'00600037' + d CURLINFO_APPCONNECT_TIME_T... CURLINFO_OFF_T + 56 + d c X'00600038' + d CURLINFO_RETRY_AFTER... CURLINFO_OFF_T + 57 + d c X'00600039' + d CURLINFO_EFFECTIVE_METHOD... CURLINFO_STRING + 58 + d c X'0010003A' + d CURLINFO_PROXY_ERROR... CURLINFO_LONG + 59 + d c X'0020003B' + d CURLINFO_REFERER... CURLINFO_STRING + 60 + d c X'0010003C' + d CURLINFO_CAINFO... CURLINFO_STRING + 61 + d c X'0010003D' + d CURLINFO_CAPATH... CURLINFO_STRING + 62 + d c X'0010003E' + d CURLINFO_XFER_ID... CURLINFO_OFF_T + 63 + d c X'0060003F' + d CURLINFO_CONN_ID... CURLINFO_OFF_T + 64 + d c X'00600040' + d CURLINFO_QUEUE_TIME_T... CURLINFO_OFF_T + 65 + d c X'00600041' + d CURLINFO_USED_PROXY... CURLINFO_LONG + 66 + d c X'00200042' + * + d CURLINFO_HTTP_CODE... Old ...RESPONSE_CODE + d c X'00200002' + * + d curl_sslbackend... + d s 10i 0 based(######ptr######) Enum + d CURLSSLBACKEND_NONE... + d c 0 + d CURLSSLBACKEND_OPENSSL... + d c 1 + d CURLSSLBACKEND_GNUTLS... + d c 2 + d CURLSSLBACKEND_NSS... + d c 3 + d CURLSSLBACKEND_OBSOLETE4... + d c 4 + d CURLSSLBACKEND_GSKIT... + d c 5 + d CURLSSLBACKEND_POLARSSL... + d c 6 + d CURLSSLBACKEND_CYASSL... + d c 7 + d CURLSSLBACKEND_SCHANNEL... + d c 8 + d CURLSSLBACKEND_DARWINSSL... + d c 9 + d CURLSSLBACKEND_AXTLS... + d c 10 + d CURLSSLBACKEND_MBEDTLS... + d c 11 + d CURLSSLBACKEND_MESALINK... + d c 12 + d CURLSSLBACKEND_BEARSSL... + d c 13 + d CURLSSLBACKEND_RUSTLS... + d c 14 + * Aliases for clones. + d CURLSSLBACKEND_AWSLC... + d c 1 + d CURLSSLBACKEND_BORINGSSL... + d c 1 + d CURLSSLBACKEND_LIBRESSL... + d c 1 + d CURLSSLBACKEND_WOLFSSL... + d c 6 + * + d curl_closepolicy... + d s 10i 0 based(######ptr######) Enum + d CURLCLOSEPOLICY_OLDEST... + d c 1 + d CURLCLOSEPOLICY_LEAST_RECENTLY_USED... + d c 2 + d CURLCLOSEPOLICY_LEAST_TRAFFIC... + d c 3 + d CURLCLOSEPOLICY_SLOWEST... + d c 4 + d CURLCLOSEPOLICY_CALLBACK... + d c 5 + * + d curl_lock_data... + d s 10i 0 based(######ptr######) Enum + d CURL_LOCK_DATA_NONE... + d c 0 + d CURL_LOCK_DATA_SHARE... + d c 1 + d CURL_LOCK_DATA_COOKIE... + d c 2 + d CURL_LOCK_DATA_DNS... + d c 3 + d CURL_LOCK_DATA_SSL_SESSION... + d c 4 + d CURL_LOCK_DATA_CONNECT... + d c 5 + d CURL_LOCK_DATA_PSL... + d c 6 + d CURL_LOCK_DATA_HSTS... + d c 7 + d CURL_LOCK_DATA_LAST... + d c 8 + * + d curl_lock_access... + d s 10i 0 based(######ptr######) Enum + d CURL_LOCK_ACCESS_NONE... + d c 0 + d CURL_LOCK_ACCESS_SHARED... + d c 1 + d CURL_LOCK_ACCESS_SINGLE... + d c 2 + * + d curl_TimeCond s 10i 0 based(######ptr######) Enum + d CURL_TIMECOND_NONE... + d c 0 + d CURL_TIMECOND_IFMODSINCE... + d c 1 + d CURL_TIMECOND_LASTMOD... + d c 2 + d CURL_TIMECOND_LAST... + d c 3 + * + d curl_easytype s 10i 0 based(######ptr######) Enum + d CURLOT_LONG c 0 + d CURLOT_VALUES... + d c 1 + d CURLOT_OFF_T c 2 + d CURLOT_OBJECT... + d c 3 + d CURLOT_STRING... + d c 4 + d CURLOT_SLIST c 5 + d CURLOT_CBPTR c 6 + d CURLOT_BLOB c 7 + d CURLOT_FUNCTION... + d c 8 + * + d CURLSHcode s 10i 0 based(######ptr######) Enum + d CURLSHE_OK c 0 + d CURLSHE_BAD_OPTION... + d c 1 + d CURLSHE_IN_USE... + d c 2 + d CURLSHE_INVALID... + d c 3 + d CURLSHE_NOMEM... + d c 4 + d CURLSHE_NOT_BUILT_IN... + d c 5 + * + d CURLSHoption... + d s 10i 0 based(######ptr######) Enum + d CURLSHOPT_SHARE... + d c 1 + d CURLSHOPT_UNSHARE... + d c 2 + d CURLSHOPT_LOCKFUNC... + d c 3 + d CURLSHOPT_UNLOCKFUNC... + d c 4 + d CURLSHOPT_USERDATA... + d c 5 + * + d CURLversion s 10i 0 based(######ptr######) Enum + d CURLVERSION_FIRST... + d c 0 + d CURLVERSION_SECOND... + d c 1 + d CURLVERSION_THIRD... + d c 2 + d CURLVERSION_FOURTH... + d c 3 + d CURLVERSION_FIFTH... + d c 4 + d CURLVERSION_SIXTH... + d c 5 + d CURLVERSION_SEVENTH... + d c 6 + d CURLVERSION_EIGHTH... + d c 7 + d CURLVERSION_NINTH... + d c 8 + d CURLVERSION_TENTH... + d c 9 + d CURLVERSION_ELEVENTH... + d c 10 + d CURLVERSION_TWELFTH... + d c 11 + d CURLVERSION_NOW... + d c 11 CURLVERSION_ELEVENTH + * + d CURLHcode s 10i 0 based(######ptr######) Enum + d CURLHE_OK c 0 + d CURLHE_BADINDEX... + d c 1 + d CURLHE_MISSING... + d c 2 + d CURLHE_NOHEADERS... + d c 3 + d CURLHE_NOREQUEST... + d c 4 + d CURLHE_OUT_OF_MEMORY... + d c 5 + d CURLHE_BAD_ARGUMENT... + d c 6 + d CURLHE_NOT_BUILT_IN... + d c 7 + * + d curlsocktype s 10i 0 based(######ptr######) Enum + d CURLSOCKTYPE_IPCXN... + d c 0 + d CURLSOCKTYPE_ACCEPT... + d c 1 + * + d CURL_SOCKOPT_OK... + d c 0 + d CURL_SOCKOPT_ERROR... + d c 1 + d CURL_SOCKOPT_ALREADY_CONNECTED... + d c 2 + * + d CURLMcode s 10i 0 based(######ptr######) Enum + d CURLM_CALL_MULTI_PERFORM... + d c -1 + d CURLM_CALL_MULTI_SOCKET... + d c -1 + d CURLM_OK c 0 + d CURLM_BAD_HANDLE... + d c 1 + d CURLM_BAD_EASY_HANDLE... + d c 2 + d CURLM_OUT_OF_MEMORY... + d c 3 + d CURLM_INTERNAL_ERROR... + d c 4 + d CURLM_BAD_SOCKET... + d c 5 + d CURLM_UNKNOWN_OPTION... + d c 6 + d CURLM_ADDED_ALREADY... + d c 7 + d CURLM_RECURSIVE_API_CALL... + d c 8 + d CURLM_WAKEUP_FAILURE... + d c 9 + d CURLM_BAD_FUNCTION_ARGUMENT... + d c 10 + d CURLM_LAST c 11 + * + d CURLMSG s 10i 0 based(######ptr######) Enum + d CURLMSG_NONE c 0 + d CURLMSG_DONE c 1 + * + d CURLMoption s 10i 0 based(######ptr######) Enum + d CURLMOPT_SOCKETFUNCTION... + d c 20001 + d CURLMOPT_SOCKETDATA... + d c 10002 + d CURLMOPT_PIPELINING... + d c 00003 + d CURLMOPT_TIMERFUNCTION... + d c 20004 + d CURLMOPT_TIMERDATA... + d c 10005 + d CURLMOPT_MAXCONNECTS... + d c 00006 + d CURLMOPT_MAX_HOST_CONNECTIONS... + d c 00007 + d CURLMOPT_MAX_PIPELINE_LENGTH... + d c 00008 + d CURLMOPT_CONTENT_LENGTH_PENALTY_SIZE... + d c 30009 + d CURLMOPT_CHUNK_LENGTH_PENALTY_SIZE... + d c 30010 + d CURLMOPT_PIPELINING_SITE_BL... + d c 10011 + d CURLMOPT_PIPELINING_SERVER_BL... + d c 10012 + d CURLMOPT_MAX_TOTAL_CONNECTIONS... + d c 00013 + d CURLMOPT_PUSHFUNCTION... + d c 20014 + d CURLMOPT_PUSHDATA... + d c 10015 + d CURLMOPT_MAX_CONCURRENT_STREAMS... + d c 10016 + d CURLMOPT_NETWORK_CHANGED... + d c 10017 + d CURLMOPT_NOTIFYFUNCTION... + d c 20018 + d CURLMOPT_NOTIFYDATA... + d c 10019 + * + d CURLMinfo_offt s 10i 0 based(######ptr######) Enum + d CURLMINFO_NONE... + d c 0 + d CURLMINFO_XFERS_CURRENT... + d c 1 + d CURLMINFO_XFERS_RUNNING... + d c 2 + d CURLMINFO_XFERS_PENDING... + d c 3 + d CURLMINFO_XFERS_DONE... + d c 4 + d CURLMINFO_XFERS_ADDED... + d c 5 + * + * Definition of bits for the CURLMOPT_NETWORK_CHANGED argument. + * + d CURLMNWC_CLEAR_CONNS... + d c x'00000001' + d CURLMNWC_CLEAR_DNS... + d c x'00000002' + * + * Bitmask bits for CURLMOPT_PIPELINING. + * + d CURLPIPE_NOTHING... + d c x'00000000' + d CURLPIPE_HTTP1 c x'00000001' + d CURLPIPE_MULTIPLEX... + d c x'00000002' + * + * Public API enums for RTSP requests. + * + d CURLRTSPREQ_NONE... + d c 0 + d CURL_RTSPREQ_OPTIONS... + d c 1 + d CURL_RTSPREQ_DESCRIBE... + d c 2 + d CURL_RTSPREQ_ANNOUNCE... + d c 3 + d CURL_RTSPREQ_SETUP... + d c 4 + d CURL_RTSPREQ_PLAY... + d c 5 + d CURL_RTSPREQ_PAUSE... + d c 6 + d CURL_RTSPREQ_TEARDOWN... + d c 7 + d CURL_RTSPREQ_GET_PARAMETER... + d c 8 + d CURL_RTSPREQ_SET_PARAMETER... + d c 9 + d CURL_RTSPREQ_RECORD... + d c 10 + d CURL_RTSPREQ_RECEIVE... + d c 12 + d CURL_RTSPREQ_LAST... + d c 13 + * + d CURLUcode s 10i 0 based(######ptr######) Enum + d CURLUE_OK c 0 + d CURLUE_BAD_HANDLE... + d c 1 + d CURLUE_BAD_PARTPOINTER... + d c 2 + d CURLUE_MALFORMED_INPUT... + d c 3 + d CURLUE_BAD_PORT_NUMBER... + d c 4 + d CURLUE_UNSUPPORTED_SCHEME... + d c 5 + d CURLUE_URLDECODE... + d c 6 + d CURLUE_OUT_OF_MEMORY... + d c 7 + d CURLUE_USER_NOT_ALLOWED... + d c 8 + d CURLUE_UNKNOWN_PART... + d c 9 + d CURLUE_NO_SCHEME... + d c 10 + d CURLUE_NO_USER... + d c 11 + d CURLUE_NO_PASSWORD... + d c 12 + d CURLUE_NO_OPTIONS... + d c 13 + d CURLUE_NO_HOST... + d c 14 + d CURLUE_NO_PORT... + d c 15 + d CURLUE_NO_QUERY... + d c 16 + d CURLUE_NO_FRAGMENT... + d c 17 + d CURLUE_NO_ZONEID... + d c 18 + d CURLUE_BAD_FILE_URL... + d c 19 + d CURLUE_BAD_FRAGMENT... + d c 20 + d CURLUE_BAD_HOSTNAME... + d c 21 + d CURLUE_BAD_IPV6... + d c 22 + d CURLUE_BAD_LOGIN... + d c 23 + d CURLUE_BAD_PASSWORD... + d c 24 + d CURLUE_BAD_PATH... + d c 25 + d CURLUE_BAD_QUERY... + d c 26 + d CURLUE_BAD_SCHEME... + d c 27 + d CURLUE_BAD_SLASHES... + d c 28 + d CURLUE_BAD_USER... + d c 29 + d CURLUE_LACKS_IDN... + d c 30 + d CURLUE_TOO_LARGE... + d c 31 + * + d CURLUPart s 10i 0 based(######ptr######) Enum + d CURLUPART_URL c 0 + d CURLUPART_SCHEME... + d c 1 + d CURLUPART_USER... + d c 2 + d CURLUPART_PASSWORD... + d c 3 + d CURLUPART_OPTIONS... + d c 4 + d CURLUPART_HOST... + d c 5 + d CURLUPART_PORT... + d c 6 + d CURLUPART_PATH... + d c 7 + d CURLUPART_QUERY... + d c 8 + d CURLUPART_FRAGMENT... + d c 9 + d CURLUPART_ZONEID... + d c 10 + * + * + d CURLSTScode s 10i 0 based(######ptr######) Enum + d CURLSTS_OK c 0 + d CURLSTS_DONE c 1 + d CURLSTS_FAIL c 2 + * + * Renaming CURLMsg to CURL_Msg to avoid case-insensitivity name clash. + * + d CURL_Msg ds based(######ptr######) + d qualified + d msg like(CURLMSG) + d easy_handle * CURL * + d data * + d whatever * overlay(data) void * + d result overlay(data) like(CURLcode) + * + d curl_waitfd... + d ds based(######ptr######) + d qualified + d fd like(curl_socket_t) + d events 5i 0 + d revents 5i 0 + * + d curl_http_post... + d ds based(######ptr######) + d qualified + d next * curl_httppost * + d name * char * + d namelength 10i 0 long + d contents * char * + d contentslength... + d 10i 0 long + d buffer * char * + d bufferlength... + d 10i 0 long + d contenttype * char * + d contentheader... + d * curl_slist * + d more * curl_httppost * + d flags 10i 0 long + d showfilename * char * + d userp * void * + * + d curl_sockaddr ds based(######ptr######) + d qualified + d family 10i 0 + d socktype 10i 0 + d protocol 10i 0 + d addrlen 10u 0 + d addr 16 struct sockaddr + * + d curl_khtype s 10i 0 based(######ptr######) enum + d CURLKHTYPE_UNKNOWN... + d c 0 + d CURLKHTYPE_RSA1... + d c 1 + d CURLKHTYPE_RSA... + d c 2 + d CURLKHTYPE_DSS... + d c 3 + * + d curl_khkey ds based(######ptr######) + d qualified + d key * const char * + d len 10u 0 + d keytype like(curl_khtype) + * + d curl_forms ds based(######ptr######) + d qualified + d option like(CURLformoption) + d value * const char * + d value_ptr * overlay(value) + d value_procptr... + d * overlay(value) procptr + d value_num overlay(value: 8) like(curl_off_t) + * + d curl_slist ds based(######ptr######) + d qualified + d data * char * + d next * struct curl_slist * + * + d curl_version_info_data... + d ds based(######ptr######) + d qualified + d age like(CURLversion) + d version * const char * + d version_num 10u 0 + d host * const char * + d features 10i 0 + d ssl_version * const char * + d ssl_version_num... + d 10i 0 long + d libz_version * const char * + d protocols * const char * const * + d ares * const char * + d ares_num 10i 0 + d libidn * const char * + d iconv_ver_num... + d 10i 0 + d libssh_version... + d * const char * + d brotli_ver_num... + d 10u 0 + d brotli_version... + d * const char * + d nghttp2_ver_num... + d 10u 0 + d nghttp2_version... + d * const char * + d quic_version... + d * const char * + d cainfo... + d * const char * + d capath... + d * const char * + d zstd_ver_num... + d 10u 0 + d zstd_version... + d * const char * + d hyper_version... + d * const char * + d gsasl_version... + d * const char * + d feature_names... + d * const char * + d rtmp_version... + d * const char * + * + d curl_certinfo ds based(######ptr######) + d qualified + d num_of_certs 10i 0 + d certinfo * struct curl_slist ** + * + d curl_fistrgs ds based(######ptr######) + d qualified + d time * char * + d perm * char * + d user * char * + d group * char * + d target * char * + * + d curl_tlssessioninfo... + d ds based(######ptr######) + d qualified + d backend like(curl_sslbackend) + d internals * void * + * + d curl_fileinfo ds based(######ptr######) + d qualified + d filename * char * + d filetype like(curlfiletype) + d time 10i 0 time_t + d perm 10u 0 + d uid 10i 0 + d gid 10i 0 + d size like(curl_off_t) + d hardlinks 10i 0 + d strings likeds(curl_fistrgs) + d flags 10u 0 + d b_data * char * + d b_size 10u 0 size_t + d b_used 10u 0 size_t + * + d curl_easyoption... + d ds based(######ptr######) + d qualified + d name * const char * + d id like(CURLoption) + d type like(curl_easytype) + d flags 10u 0 + * + d curl_hstsentry... + d ds based(######ptr######) + d qualified + d name * char * + d namelen 10u 0 size_t + d includeSubDomain... + d 10u 0 Bit field: 1 + d expire 10 + * + d curl_index ds based(######ptr######) + d qualified + d index 10u 0 size_t + d total 10u 0 size_t + * + d curl_header ds based(######ptr######) + d qualified + d name * char * + d value * char * + d amount 10u 0 size_t + d index 10u 0 size_t + d origin 10u 0 + d anchor * void * + * + d curl_blob ds based(######ptr######) + d qualified + d data * void * + d len 10u 0 size_t + d flags 10u 0 + * + d curl_ws_frame ds based(######ptr######) + d qualified + d age 10i 0 + d flags 10i 0 + d offset like(curl_off_t) + d bytesleft like(curl_off_t) + d len 10u 0 size_t + * + d curl_formget_callback... + d s * based(######ptr######) procptr + * + d curl_malloc_callback... + d s * based(######ptr######) procptr + * + d curl_free_callback... + d s * based(######ptr######) procptr + * + d curl_realloc_callback... + d s * based(######ptr######) procptr + * + d curl_strdup_callback... + d s * based(######ptr######) procptr + * + d curl_calloc_callback... + d s * based(######ptr######) procptr + * + d curl_lock_function... + d s * based(######ptr######) procptr + * + d curl_unlock_function... + d s * based(######ptr######) procptr + * + d curl_progress_callback... + d s * based(######ptr######) procptr + * + d curl_xferinfo_callback... + d s * based(######ptr######) procptr + * + d curl_read_callback... + d s * based(######ptr######) procptr + * + d curl_trailer_callback... + d s * based(######ptr######) procptr + * + d curl_write_callback... + d s * based(######ptr######) procptr + * + d curl_seek_callback... + d s * based(######ptr######) procptr + * + d curl_sockopt_callback... + d s * based(######ptr######) procptr + * + d curl_ioctl_callback... + d s * based(######ptr######) procptr + * + d curl_debug_callback... + d s * based(######ptr######) procptr + * + d curl_conv_callback... + d s * based(######ptr######) procptr + * + d curl_ssl_ctx_callback... + d s * based(######ptr######) procptr + * + d curl_socket_callback... + d s * based(######ptr######) procptr + * + d curl_multi_timer_callback... + d s * based(######ptr######) procptr + * + d curl_push_callback... + d s * based(######ptr######) procptr + * + d curl_opensocket_callback... + d s * based(######ptr######) procptr + * + d curl_sshkeycallback... + d s * based(######ptr######) procptr + * + d curl_chunk_bgn_callback... + d s * based(######ptr######) procptr + * + d curl_chunk_end_callback... + d s * based(######ptr######) procptr + * + d curl_fnmatch_callback... + d s * based(######ptr######) procptr + * + d curl_closesocket_callback... + d s * based(######ptr######) procptr + * + d curl_resolver_start_callback... + d s * based(######ptr######) procptr + * + d curl_hstsread_callback... + d s * based(######ptr######) procptr + * + d curl_hstswrite_callback... + d s * based(######ptr######) procptr + * + d curl_prereq_callback... + d s * based(######ptr######) procptr + * + d curl_sshhostkeycallback... + d s * based(######ptr######) procptr + * + d curl_ws_write_callback... + d s * based(######ptr######) procptr + * + d curl_notify_callback... + d s * based(######ptr######) procptr + * + ************************************************************************** + * Prototypes + ************************************************************************** + * + d curl_mime_init pr * extproc('curl_mime_init') curl_mime * + d easy * value CURL * + * + d curl_mime_free pr extproc('curl_mime_free') + d mime * value curl_mime * + * + d curl_mime_addpart... + d pr * extproc('curl_mime_addpart') curl_mimepart * + d mime * value curl_mime * + * + d curl_mime_name pr extproc('curl_mime_name') + d like(CURLcode) + d part * value curl_mimepart * + d name * value options(*string) + * + d curl_mime_filename... + d pr extproc('curl_mime_filename') + d like(CURLcode) + d part * value curl_mimepart * + d filename * value options(*string) + * + d curl_mime_type pr extproc('curl_mime_type') + d like(CURLcode) + d part * value curl_mimepart * + d mimetype * value options(*string) + * + d curl_mime_encoder... + d pr extproc('curl_mime_encoder') + d like(CURLcode) + d part * value curl_mimepart * + d encoding * value options(*string) + * + d curl_mime_data pr extproc('curl_mime_data') + d like(CURLcode) + d part * value curl_mimepart * + d data * value options(*string) + d datasize 10u 0 value size_t + * + d curl_mime_filedata... + d pr extproc('curl_mime_filedata') + d like(CURLcode) + d part * value curl_mimepart * + d filename * value options(*string) + * + d curl_mime_data_cb... + d pr extproc('curl_mime_data_cb') + d like(CURLcode) + d part * value curl_mimepart * + d datasize value like(curl_off_t) + d readfunc value like(curl_read_callback) + d seekfunc value like(curl_seek_callback) + d freefunc value like(curl_free_callback) + d arg * value void * + * + d curl_mime_subparts... + d pr extproc('curl_mime_subparts') + d like(CURLcode) + d part * value curl_mimepart * + d subparts * value curl_mime * + * + d curl_mime_headers... + d pr extproc('curl_mime_headers') + d like(CURLcode) + d part * value curl_mimepart * + d headers * value curl_slist * + d take_ownership... + d 10i 0 value + * + * This procedure as a variable parameter list. + * This prototype allows use of an option array, or a single "object" + * option. Other argument lists may be implemented by alias procedure + * prototype definitions. + * + d curl_formadd pr extproc('curl_formadd') + d like(CURLFORMcode) + d httppost * curl_httppost * + d lastpost * curl_httppost * + d option1 value like(CURLFORMoption) CURLFORM_ARRAY + d options(*nopass) + d object1 * value options(*string: *nopass) + d option2 value like(CURLFORMoption) CURLFORM_END + d options(*nopass) + * + * + d curl_strequal pr 10i 0 extproc('curl_strequal') + d s1 * value options(*string) + d s2 * value options(*string) + * + d curl_strnequal pr 10i 0 extproc('curl_strnequal') + d s1 * value options(*string) + d s2 * value options(*string) + d n 10u 0 value + * + d curl_formget pr 10i 0 extproc('curl_formget') + d form * value curl_httppost * + d arg * value + d append value like(curl_formget_callback) + * + d curl_formfree pr extproc('curl_formfree') + d form * value curl_httppost * + * + d curl_getenv pr * extproc('curl_getenv') + d variable * value options(*string) + * + d curl_version pr * extproc('curl_version') + * + d curl_easy_escape... + d pr * extproc('curl_easy_escape') char * + d handle * value CURL * + d string * value options(*string) + d length 10i 0 value + * + d curl_escape pr * extproc('curl_escape') char * + d string * value options(*string) + d length 10i 0 value + * + d curl_easy_unescape... + d pr * extproc('curl_easy_unescape') char * + d handle * value CURL * + d string * value options(*string) + d length 10i 0 value + d outlength 10i 0 options(*omit) + * + d curl_unescape pr * extproc('curl_unescape') char * + d string * value options(*string) + d length 10i 0 value + * + d curl_free pr extproc('curl_free') + d p * value + * + d curl_global_init... + d pr extproc('curl_global_init') + d like(CURLcode) + d flags 10i 0 value + * + d curl_global_init_mem... + d pr extproc('curl_global_init_mem') + d like(CURLcode) + d m value like(curl_malloc_callback) + d f value like(curl_free_callback) + d r value like(curl_realloc_callback) + d s value like(curl_strdup_callback) + d c value like(curl_calloc_callback) + * + d curl_global_cleanup... + d pr extproc('curl_global_cleanup') + * + d curl_slist_append... + d pr * extproc('curl_slist_append') struct curl_slist * + d list * value struct curl_slist * + d data * value options(*string) const char * + * + d curl_slist_free_all... + d pr extproc('curl_slist_free_all') + d list * value struct curl_slist * + * + d curl_getdate pr 10i 0 extproc('curl_getdate') time_t + d p * value options(*string) const char * + d unused 10i 0 const options(*omit) time_t + * + d curl_share_init... + d pr * extproc('curl_share_init') CURLSH * (= void *) + * + * Variable argument type procedure. + * Multiply prototyped to support all possible types. + * + d curl_share_setopt_int... + d pr extproc('curl_share_setopt') + d like(CURLSHcode) + d share * value CURLSH * (= void *) + d option value like(CURLSHoption) + d intarg 10i 0 value options(*nopass) + * + d curl_share_setopt_ptr... + d pr extproc('curl_share_setopt') + d like(CURLSHcode) + d share * value CURLSH * (= void *) + d option value like(CURLSHoption) + d ptrarg * value options(*nopass) + * + d curl_share_setopt_proc... + d pr extproc('curl_share_setopt') + d like(CURLSHcode) + d share * value CURLSH * (= void *) + d option value like(CURLSHoption) + d procarg * value procptr options(*nopass) + * + d curl_share_cleanup... + d pr extproc('curl_share_cleanup') + d like(CURLSHcode) + d share * value CURLSH * (= void *) + * + d curl_version_info... + d pr * extproc('curl_version_info') c_i_version_data * + d version value like(CURLversion) + * + d curl_easy_strerror... + d pr * extproc('curl_easy_strerror') const char * + d code value like(CURLcode) + * + d curl_share_strerror... + d pr * extproc('curl_share_strerror') const char * + d code value like(CURLSHcode) + * + d curl_easy_init pr * extproc('curl_easy_init') CURL * + * + * Multiple prototypes for vararg procedure curl_easy_setopt. + * + d curl_easy_setopt_long... + d pr extproc('curl_easy_setopt') + d like(CURLcode) + d curl * value CURL * + d option value like(CURLoption) + d longarg 10i 0 value options(*nopass) + * + d curl_easy_setopt_object... + d pr extproc('curl_easy_setopt') + d like(CURLcode) + d curl * value CURL * + d option value like(CURLoption) + d objectarg * value options(*string: *nopass) + * + d curl_easy_setopt_function... + d pr extproc('curl_easy_setopt') + d like(CURLcode) + d curl * value CURL * + d option value like(CURLoption) + d functionarg * value procptr options(*nopass) + * + d curl_easy_setopt_offset... + d pr extproc('curl_easy_setopt') + d like(CURLcode) + d curl * value CURL * + d option value like(CURLoption) + d offsetarg value like(curl_off_t) + d options(*nopass) + * + d curl_easy_setopt_blob... + d pr extproc('curl_easy_setopt') + d like(CURLcode) + d curl * value CURL * + d option value like(CURLoption) + d blob const likeds(curl_blob) + d options(*nopass) + * + * + d curl_easy_perform... + d pr extproc('curl_easy_perform') + d like(CURLcode) + d curl * value CURL * + * + d curl_easy_cleanup... + d pr extproc('curl_easy_cleanup') + d curl * value CURL * + * + * Multiple prototypes for vararg procedure curl_easy_getinfo. + * + d curl_easy_getinfo_string... + d pr extproc('curl_easy_getinfo') + d like(CURLcode) + d curl * value CURL * + d info value like(CURLINFO) + d stringarg * options(*nopass) char * + * + d curl_easy_getinfo_long... + d pr extproc('curl_easy_getinfo') + d like(CURLcode) + d curl * value CURL * + d info value like(CURLINFO) + d longarg 10i 0 options(*nopass) + * + d curl_easy_getinfo_double... + d pr extproc('curl_easy_getinfo') + d like(CURLcode) + d curl * value CURL * + d info value like(CURLINFO) + d doublearg 8f options(*nopass) + * + d curl_easy_getinfo_slist... + d pr extproc('curl_easy_getinfo') + d like(CURLcode) + d curl * value CURL * + d info value like(CURLINFO) + d slistarg * options(*nopass) struct curl_slist * + * + d curl_easy_getinfo_ptr... + d pr extproc('curl_easy_getinfo') + d like(CURLcode) + d curl * value CURL * + d info value like(CURLINFO) + d ptrarg * options(*nopass) void * + * + d curl_easy_getinfo_socket... + d pr extproc('curl_easy_getinfo') + d like(CURLcode) + d curl * value CURL * + d info value like(CURLINFO) + d socketarg like(curl_socket_t) options(*nopass) + * + d curl_easy_getinfo_off_t... + d pr extproc('curl_easy_getinfo') + d like(CURLcode) + d curl * value CURL * + d info value like(CURLINFO) + d offsetarg like(curl_off_t) options(*nopass) + * + * + d curl_easy_duphandle... + d pr * extproc('curl_easy_duphandle') CURL * + d curl * value CURL * + * + d curl_easy_reset... + d pr extproc('curl_easy_reset') + d curl * value CURL * + * + d curl_easy_recv... + d pr extproc('curl_easy_recv') + d like(CURLcode) + d curl * value CURL * + d buffer * value void * + d buflen 10u 0 value size_t + d n 10u 0 size_t * + * + d curl_easy_send... + d pr extproc('curl_easy_send') + d like(CURLcode) + d curl * value CURL * + d buffer * value const void * + d buflen 10u 0 value size_t + d n 10u 0 size_t * + * + d curl_easy_pause... + d pr extproc('curl_easy_pause') + d like(CURLcode) + d curl * value CURL * + d bitmask 10i 0 value + * + d curl_easy_upkeep... + d pr extproc('curl_easy_upkeep') + d like(CURLcode) + d curl * value CURL * + * + d curl_multi_init... + d pr * extproc('curl_multi_init') CURLM * + * + d curl_multi_add_handle... + d pr extproc('curl_multi_add_handle') + d like(CURLMcode) + d multi_handle * value CURLM * + d curl_handle * value CURL * + * + d curl_multi_remove_handle... + d pr extproc('curl_multi_remove_handle') + d like(CURLMcode) + d multi_handle * value CURLM * + d curl_handle * value CURL * + * + d curl_multi_fdset... + d pr extproc('curl_multi_fdset') + d like(CURLMcode) + d multi_handle * value CURLM * + d read_fd_set 65535 options(*varsize) fd_set + d write_fd_set 65535 options(*varsize) fd_set + d exc_fd_set 65535 options(*varsize) fd_set + d max_fd 10i 0 + * + d curl_multi_wait... + d pr extproc('curl_multi_wait') + d like(CURLMcode) + d multi_handle * value CURLM * + d extra_fds * value curl_waitfd * + d extra_nfds 10u 0 value + d timeout_ms 10i 0 value + d ret 10i 0 options(*omit) + * + d curl_multi_perform... + d pr extproc('curl_multi_perform') + d like(CURLMcode) + d multi_handle * value CURLM * + d running_handles... + d 10i 0 + * + d curl_multi_cleanup... + d pr extproc('curl_multi_cleanup') + d like(CURLMcode) + d multi_handle * value CURLM * + * + d curl_multi_info_read... + d pr * extproc('curl_multi_info_read') CURL_Msg * + d multi_handle * value CURLM * + d msgs_in_queue 10i 0 + * + d curl_multi_strerror... + d pr * extproc('curl_multi_strerror') char * + d code value like(CURLMcode) + * + d curl_pushheader_bynum... + d pr * extproc('curl_pushheader_bynum') char * + d h * value curl_pushheaders * + d num 10u 0 value + * + d curl_pushheader_byname... + d pr * extproc('curl_pushheader_byname') char * + d h * value curl_pushheaders * + d header * value options(*string) const char * + * + d curl_multi_socket... + d pr extproc('curl_multi_socket') + d like(CURLMcode) + d multi_handle * value CURLM * + d s value like(curl_socket_t) + d running_handles... + d 10i 0 + * + d curl_multi_waitfds... + d pr extproc('curl_multi_waitfds') + d like(CURLMcode) + d multi * value CURLM * + d ufds * value curl_waitfd * + d size 10u 0 value + d fd_count 10u 0 + * + d curl_multi_socket_action... + d pr extproc('curl_multi_socket_action') + d like(CURLMcode) + d multi_handle * value CURLM * + d s value like(curl_socket_t) + d ev_bitmask 10i 0 value + d running_handles... + d 10i 0 + * + d curl_multi_socket_all... + d pr extproc('curl_multi_socket_all') + d like(CURLMcode) + d multi_handle * value CURLM * + d running_handles... + d 10i 0 + * + d curl_multi_timeout... + d pr extproc('curl_multi_timeout') + d like(CURLMcode) + d multi_handle * value CURLM * + d milliseconds 10i 0 + * + * Multiple prototypes for vararg procedure curl_multi_setopt. + * + d curl_multi_setopt_long... + d pr extproc('curl_multi_setopt') + d like(CURLMcode) + d multi_handle * value CURLM * + d option value like(CURLMoption) + d longarg 10i 0 value options(*nopass) + * + d curl_multi_setopt_object... + d pr extproc('curl_multi_setopt') + d like(CURLMcode) + d multi_handle * value CURLM * + d option value like(CURLMoption) + d objectarg * value options(*string: *nopass) + * + d curl_multi_setopt_function... + d pr extproc('curl_multi_setopt') + d like(CURLMcode) + d multi_handle * value CURLM * + d option value like(CURLMoption) + d functionarg * value procptr options(*nopass) + * + d curl_multi_setopt_offset... + d pr extproc('curl_multi_setopt') + d like(CURLMcode) + d multi_handle * value CURLM * + d option value like(CURLMoption) + d offsetarg value like(curl_off_t) + d options(*nopass) + * + * + d curl_multi_assign... + d pr extproc('curl_multi_assign') + d like(CURLMcode) + d multi_handle * value CURLM * + d sockfd value like(curl_socket_t) + d sockp * value void * + * + d curl_multi_get_handles... + d pr * extproc('curl_multi_get_handles') CURL ** + d multi_handle * value CURLM * + * + d curl_multi_get_offt... + d pr extproc('curl_multi_get_offt') + d like(CURLMcode) + d multi_handle * value CURLM * + d info value like(CURLMinfo_offt) + d pvalue like(curl_off_t) + * + d curl_multi_notify_disable... + d pr extproc('curl_multi_notify_disable') + d like(CURLMcode) + d multi_handle * value CURLM * + d notification 10i 0 value + * + d curl_multi_notify_enable... + d pr extproc('curl_multi_notify_enable') + d like(CURLMcode) + d multi_handle * value CURLM * + d notification 10i 0 value + * + d curl_url pr * extproc('curl_url') CURLU * + * + d curl_url_cleanup... + d pr extproc('curl_url_cleanup') + d handle * value CURLU * + * + d curl_url_dup pr * extproc('curl_url_dup') CURLU * + d in * value CURLU * + * + d curl_url_get pr extproc('curl_url_get') + d like(CURLUcode) + d handle * value CURLU * + d what value like(CURLUPart) + d part * char ** + d flags 10u 0 value + * + d curl_url_set pr extproc('curl_url_set') + d like(CURLUcode) + d handle * value CURLU * + d what value like(CURLUPart) + d part * value options(*string) + d flags 10u 0 value + * + d curl_url_strerror... + d pr * extproc('curl_url_strerror') const char * + d code value like(CURLUcode) + * + d curl_easy_option_by_name... + d pr * extproc('curl_easy_option_by_name') curl_easyoption * + d name * value options(*string) + * + d curl_easy_option_by_id... + d pr * extproc('curl_easy_option_by_id') curl_easyoption * + d id value like(CURLoption) + * + d curl_easy_option_next... + d pr * extproc('curl_easy_next') curl_easyoption * + d prev * value curl_easyoption * + * + d curl_ws_recv pr extproc('curl_ws_recv') + d like(CURLcode) + d curl * value CURL * + d buffer * value void * + d buflen 10u 0 value size_t + d recv 10u 0 size_t * + d metap likeds(curl_ws_frame) + * + d curl_ws_send pr extproc('curl_ws_send') + d like(CURLcode) + d curl * value CURL * + d buffer * value const void * + d buflen 10u 0 value size_t + d sent 10u 0 size_t * + d framesize like(curl_off_t) + d sendflags 10u 0 value + * + d curl_ws_meta pr * extproc('curl_ws_meta') curl_ws_frame * + d curl * value CURL * + * + d curl_ws_start pr extproc('curl_ws_start') + d like(CURLcode) + d curl * value CURL * + d flags 10u 0 value + d frame_len value like(curl_off_t) + * + d curl_easy_header... + d pr extproc('curl_easy_header') curl_header * + d like(CURLHcode) + d curl * value CURL * + d name * value options(*string) const char * + d index 10u 0 value size_t + d origin 10u 0 value + d request 10i 0 value + d hout * curl_header ** + * + d curl_easy_nextheader... + d pr * extproc('curl_easy_nextheader') curl_header * + d curl * value CURL * + d origin 10u 0 value + d request 10i 0 value + d prev * value curl_header * + * + ************************************************************************** + * CCSID wrapper procedure prototypes + ************************************************************************** + * + d curl_version_ccsid... + d pr * extproc('curl_version_ccsid') + d ccsid 10u 0 value + * + d curl_easy_escape_ccsid... + d pr * extproc('curl_easy_escape_ccsid') char * + d handle * value CURL * + d string * value options(*string) + d length 10i 0 value + d ccsid 10u 0 value + * + d curl_easy_unescape_ccsid... + d pr * extproc('curl_easy_unescape_ccsid') char * + d handle * value CURL * + d string * value options(*string) + d length 10i 0 value + d outlength 10i 0 options(*omit) + d ccsid 10u 0 value + * + d curl_slist_append_ccsid... + d pr * extproc('curl_slist_append_ccsid') struct curl_slist * + d list * value struct curl_slist * + d data * value options(*string) const char * + d ccsid 10u 0 value + * + d curl_getdate_ccsid... + d pr 10i 0 extproc('curl_getdate_ccsid') time_t + d p * value options(*string) const char * + d unused 10i 0 const options(*omit) time_t + d ccsid 10u 0 value + * + d curl_version_info_ccsid... + d pr * extproc('curl_version_info_ccsid') c_i_version_data * + d version value like(CURLversion) + d ccsid 10u 0 value + * + d curl_easy_strerror_ccsid... + d pr * extproc('curl_easy_strerror_ccsid') const char * + d code value like(CURLcode) + d ccsid 10u 0 value + * + d curl_share_strerror_ccsid... + d pr * extproc('curl_share_strerror_ccsid') const char * + d code value like(CURLSHcode) + d ccsid 10u 0 value + * + d curl_multi_strerror_ccsid... + d pr * extproc('curl_multi_strerror_ccsid') char * + d code value like(CURLMcode) + d ccsid 10u 0 value + * + * May be used for strings and structures. + d curl_easy_getinfo_ccsid... + d pr extproc('curl_easy_getinfo_ccsid') + d like(CURLcode) + d curl * value CURL * + d info value like(CURLINFO) + d ptrarg * options(*nopass) char * + d ccsid 10u 0 value options(*nopass) + * + d curl_certinfo_free_all... + d pr extproc('curl_certinfo_free_all') + d info * value + * + d curl_formadd_ccsid... + d pr extproc('curl_formadd_ccsid') + d like(CURLFORMcode) + d httppost * curl_httppost * + d lastpost * curl_httppost * + d option1 value like(CURLFORMoption) CURLFORM_ARRAY + d options(*nopass) + d object1 * value options(*string: *nopass) + d option2 value like(CURLFORMoption) CURLFORM_END + d options(*nopass) + * + d curl_formget_ccsid... + d pr 10i 0 extproc('curl_formget_ccsid') + d form * value curl_httppost * + d arg * value + d append value like(curl_formget_callback) + d ccsid 10u 0 value + * + d curl_form_long_value... + d pr * extproc('curl_form_long_value') + d value 10i 0 value curl_httppost * + * + d curl_easy_setopt_ccsid... + d pr extproc('curl_easy_setopt_ccsid') + d like(CURLcode) + d curl * value CURL * + d option value like(CURLoption) + d objectarg * value options(*string: *nopass) + d ccsid 10u 0 value options(*nopass) + * + d curl_easy_setopt_blob_ccsid... + d pr extproc('curl_easy_setopt_ccsid') + d like(CURLcode) + d curl * value CURL * + d option value like(CURLoption) + d blob const likeds(curl_blob) + d options(*nopass) + d ccsid 10u 0 value options(*nopass) + * + d curl_pushheader_bynum_ccsid... + d pr * extproc( char * + d 'curl_pushheader_bynum_ccsid') + d h * value curl_pushheaders * + d num 10u 0 value + d ccsid 10u 0 value + * + d curl_pushheader_byname_ccsid... + d pr * extproc( char * + d 'curl_pushheader_byname_ccsid') + d h * value curl_pushheaders * + d header * value options(*string) const char * + d ccsidin 10u 0 value + d ccsidout 10u 0 value + * + d curl_mime_name_ccsid... + d pr extproc('curl_mime_name_ccsid') + d like(CURLcode) + d part * value curl_mimepart * + d name * value options(*string) + d ccsid 10u 0 value + * + d curl_mime_filename_ccsid... + d pr extproc('curl_mime_filename_ccsid') + d like(CURLcode) + d part * value curl_mimepart * + d filename * value options(*string) + d ccsid 10u 0 value + * + d curl_mime_type_ccsid... + d pr extproc('curl_mime_type_ccsid') + d like(CURLcode) + d part * value curl_mimepart * + d mimetype * value options(*string) + d ccsid 10u 0 value + * + d curl_mime_encoder_ccsid... + d pr extproc('curl_mime_encoder_ccsid') + d like(CURLcode) + d part * value curl_mimepart * + d encoding * value options(*string) + d ccsid 10u 0 value + * + d curl_mime_data_ccsid... + d pr extproc('curl_mime_data_ccsid') + d like(CURLcode) + d part * value curl_mimepart * + d data * value options(*string) + d datasize 10u 0 value size_t + d ccsid 10u 0 value + * + d curl_mime_filedata_ccsid... + d pr extproc('curl_mime_filedata_ccsid') + d like(CURLcode) + d part * value curl_mimepart * + d filename * value options(*string) + d ccsid 10u 0 value + * + d curl_url_get_ccsid... + d pr extproc('curl_url_get_ccsid') + d like(CURLUcode) + d handle * value CURLU * + d what value like(CURLUPart) + d part * char ** + d flags 10u 0 value + d ccsid 10u 0 value + * + d curl_url_set_ccsid... + d pr extproc('curl_url_set_ccsid') + d like(CURLUcode) + d handle * value CURLU * + d what value like(CURLUPart) + d part * value options(*string) + d flags 10u 0 value + d ccsid 10u 0 value + * + d curl_url_strerror_ccsid... + d pr * extproc('curl_url_strerror_ccsid') const char * + d code value like(CURLUcode) + d ccsid 10u 0 value + * + d curl_easy_option_by_name_ccsid... + d pr * extproc( curl_easyoption * + d 'curl_easy_option_by_name_ccsid') + d name * value options(*string) + d ccsid 10u 0 value + * + d curl_easy_option_get_name_ccsid... + d pr * extproc( const char * + d 'curl_easy_option_get_name_ccsid') + d option * value curl_easyoption * + d ccsid 10u 0 value + * + d curl_easy_header_ccsid... + d pr extproc('curl_easy_header_ccsid') curl_header * + d like(CURLHcode) + d curl * value CURL * + d name * value options(*string) const char * + d index 10u 0 value size_t + d origin 10u 0 value + d request 10i 0 value + d hout * curl_header ** + d ccsid 10u 0 value + * + d curl_from_ccsid... + d pr * extproc('curl_from_ccsid') const char * + d s * value options(*string) const char * + d ccsid 10u 0 value + * + d curl_to_ccsid... + d pr * extproc('curl_to_ccsid') const char * + d s * value options(*string) const char * + d ccsid 10u 0 value + * + ************************************************************************** + * Procedure overloading + ************************************************************************** + * + /if defined(*V7R4M0) + d curl_easy_setopt_RPGnum_... + d pr extproc('curl_easy_setopt_RPGnum_') + d like(CURLcode) + d curl * value CURL * + d option value like(CURLoption) + d numarg 20i 0 value + * + d curl_easy_setopt... + d pr like(CURLcode) + d overload(curl_easy_setopt_RPGnum_: + d curl_easy_setopt_object: + d curl_easy_setopt_function) + * + d curl_multi_setopt_RPGnum_... + d pr extproc('curl_multi_setopt_RPGnum_') + d like(CURLcode) + d curl * value CURLM * + d option value like(CURLMoption) + d numarg 20i 0 value + * + d curl_multi_setopt... + d pr like(CURLcode) + d overload(curl_multi_setopt_RPGnum_: + d curl_multi_setopt_object: + d curl_multi_setopt_function) + * + d curl_share_setopt... + d pr like(CURLcode) + d overload(curl_share_setopt_int: + d curl_share_setopt_ptr: + d curl_share_setopt_proc) + * + d curl_easy_getinfo... + d pr like(CURLcode) + d overload(curl_easy_getinfo_long: + d curl_easy_getinfo_off_t: + d curl_easy_getinfo_double: + d curl_easy_getinfo_ptr) + /endif + * + /endif diff --git a/3rdparty/curl-8.21.0/projects/OS400/curlcl.c b/3rdparty/curl-8.21.0/projects/OS400/curlcl.c new file mode 100644 index 0000000000..8085307f31 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/OS400/curlcl.c @@ -0,0 +1,173 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + * + ***************************************************************************/ + +/* CL interface program to curl cli tool. */ + +#include +#include + +#include +#include +#include + +#ifndef CURLPGM +#define CURLPGM "CURL" +#endif + +/* Variable-length string, with 16-bit length. */ +struct vary2 { + short len; + char string[5000]; +}; + +/* Arguments from CL command. */ +struct arguments { + char *pgm; /* Program name. */ + struct vary2 *cmdargs; /* Command line arguments. */ +}; + +static int is_ifs(char c) +{ + return c == ' ' || c == '\t' || c == '\r' || c == '\n'; +} + +static int parse_command_line(const char *cmdargs, size_t len, size_t *argc, + char **argv, size_t *argsize, char *argbuf) +{ + const char *endline = cmdargs + len; + char quote = '\0'; + int inarg = 0; + + *argc = 0; + *argsize = 0; + + while(cmdargs < endline) { + char c = *cmdargs++; + + if(!inarg) { + /* Skip argument separator. */ + if(is_ifs(c)) + continue; + + /* Start a new argument. */ + ++*argc; + if(argv) + *argv++ = argbuf; + inarg = 1; + } + + /* Check for quoting end. */ + if(quote && quote == c) { + quote = '\0'; + continue; + } + + /* Check for backslash-escaping. */ + if(quote != '\'' && c == '\\') { + if(cmdargs >= endline) { + fputs("Trailing backslash in command\n", stderr); + return -1; + } + c = *cmdargs++; + } + else if(!quote && is_ifs(c)) { /* Check for end of argument. */ + inarg = 0; + c = '\0'; /* Will store a string terminator. */ + } + + /* Store argument character and count it. */ + if(argbuf) + *argbuf++ = c; + ++*argsize; + } + + if(quote) { + /* !checksrc! disable BANNEDFUNC 1 */ + fprintf(stderr, "Unterminated quote: %c\n", quote); + return -1; + } + + /* Terminate last argument. */ + if(inarg) { + if(argbuf) + *argbuf = '\0'; + ++*argsize; + } + + /* Terminate argument list. */ + if(argv) + *argv = NULL; + + return 0; +} + +int main(int argsc, struct arguments *args) +{ + size_t argc; + char **argv; + size_t argsize; + int i; + int exitcode; + char library[11]; + + /* Extract current program library name. */ + for(i = 0; i < 10; i++) { + char c = args->pgm[i]; + + if(!c || c == '/') + break; + + library[i] = c; + } + library[i] = '\0'; + + /* Measure arguments size. */ + exitcode = parse_command_line(args->cmdargs->string, args->cmdargs->len, + &argc, NULL, &argsize, NULL); + + if(!exitcode) { + /* Allocate space for parsed arguments. */ + argv = malloc((argc + 1) * sizeof(*argv) + argsize); + if(!argv) { + fputs("Memory allocation error\n", stderr); + exitcode = -2; + } + else { + _SYSPTR pgmptr = rslvsp(WLI_PGM, (char *)CURLPGM, library, _AUTH_NONE); + _LU_Work_Area_T *luwrka = (_LU_Work_Area_T *)_LUWRKA(); + + parse_command_line(args->cmdargs->string, args->cmdargs->len, &argc, + argv, &argsize, (char *)(argv + argc + 1)); + + /* Call program. */ + _CALLPGMV((void *)&pgmptr, argv, argc); + exitcode = luwrka->LU_RC; + + free(argv); + } + } + + return exitcode; +} diff --git a/3rdparty/curl-8.21.0/projects/OS400/curlmain.c b/3rdparty/curl-8.21.0/projects/OS400/curlmain.c new file mode 100644 index 0000000000..690e8c6221 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/OS400/curlmain.c @@ -0,0 +1,119 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + * + ***************************************************************************/ + +/* + * QADRT/QADRTMAIN2 substitution program. + * This is needed because the IBM-provided QADRTMAIN2 does not + * properly translate arguments by default or if no locale is provided. + */ + +#include +#include +#include +#include +#include + +/* Do not use qadrt.h since it defines unneeded static procedures. */ +extern void QadrtInit(void); +extern int QadrtFreeConversionTable(void); +extern int QadrtFreeEnviron(void); +extern char * setlocale_a(int, const char *); + +/* The ASCII main program. */ +extern int main_a(int argc, char **argv); + +/* Global values of original EBCDIC arguments. */ +int ebcdic_argc; +char ** ebcdic_argv; + +int main(int argc, char **argv) +{ + int i; + int j; + iconv_t cd; + size_t bytecount = 0; + char *inbuf; + char *outbuf; + size_t inbytesleft; + size_t outbytesleft; + char dummybuf[128]; + /* To/From codes are 32-byte strings with + reserved fields initialized to ZEROs */ + const char tocode[32] = { "IBMCCSID01208" }; /* Use UTF-8. */ + const char fromcode[32] = { "IBMCCSID000000000010" }; + + ebcdic_argc = argc; + ebcdic_argv = argv; + + /* Build the encoding converter. */ + cd = iconv_open(tocode, fromcode); + + /* Measure the arguments. */ + for(i = 0; i < argc; i++) { + inbuf = argv[i]; + do { + inbytesleft = 0; + outbuf = dummybuf; + outbytesleft = sizeof(dummybuf); + j = iconv(cd, &inbuf, &inbytesleft, &outbuf, &outbytesleft); + bytecount += outbuf - dummybuf; + } while(j == -1 && errno == E2BIG); + + /* Reset the shift state. */ + iconv(cd, NULL, &inbytesleft, &outbuf, &outbytesleft); + } + + /* Allocate memory for the ASCII arguments and vector. */ + argv = malloc((argc + 1) * sizeof(*argv) + bytecount); + + /* Build the vector and convert argument encoding. */ + outbuf = (char *)(argv + argc + 1); + outbytesleft = bytecount; + + for(i = 0; i < argc; i++) { + argv[i] = outbuf; + inbuf = ebcdic_argv[i]; + inbytesleft = 0; + iconv(cd, &inbuf, &inbytesleft, &outbuf, &outbytesleft); + iconv(cd, NULL, &inbytesleft, &outbuf, &outbytesleft); + } + + iconv_close(cd); + argv[argc] = NULL; + + /* Try setting the locale regardless of QADRT_ENV_LOCALE. */ + setlocale_a(LC_ALL, ""); + + /* Call the program. */ + i = main_a(argc, argv); + + /* Clean-up allocated items. */ + free((char *)argv); + QadrtFreeConversionTable(); + QadrtFreeEnviron(); + + /* Terminate. */ + return i; +} diff --git a/3rdparty/curl-8.21.0/projects/OS400/initscript.sh b/3rdparty/curl-8.21.0/projects/OS400/initscript.sh new file mode 100755 index 0000000000..dcdcfa8000 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/OS400/initscript.sh @@ -0,0 +1,297 @@ +#!/bin/sh +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### + +CLcommand() +{ + /usr/bin/system "${@}" || exit 1 +} + +setenv() + +{ + # Define and export. + + eval "${1}=${2}" + export "${1?}" +} + + +case "${SCRIPTDIR}" in +/*) ;; +*) SCRIPTDIR="$(pwd)/${SCRIPTDIR}" +esac + +while true +do case "${SCRIPTDIR}" in + */.) SCRIPTDIR="${SCRIPTDIR%/.}";; + *) break;; + esac +done + +# The script directory is supposed to be in $TOPDIR/projects/os400. + +TOPDIR=$(dirname "${SCRIPTDIR}") +TOPDIR=$(dirname "${TOPDIR}") +export SCRIPTDIR TOPDIR + +# Extract the SONAME from the library makefile. + +SONAME="$(sed -e '/^VERSIONCHANGE=/!d;s/^.*=\([0-9]*\).*/\1/' \ + < "${TOPDIR}/lib/Makefile.soname")" +export SONAME + +# Get OS/400 configuration parameters. + +. "${SCRIPTDIR}/config400.default" +if [ -f "${SCRIPTDIR}/config400.override" ] +then . "${SCRIPTDIR}/config400.override" +fi + +# Check if perl available. +{ [ -n "${PASEPERL}" ] && [ -x "${PASEPERL}" ]; } || PASEPERL= + +# Need to get the version definitions. + +LIBCURL_VERSION=$(grep '^#define *LIBCURL_VERSION ' \ + "${TOPDIR}/include/curl/curlver.h" | + sed 's/.*"\(.*\)".*/\1/') +LIBCURL_VERSION_MAJOR=$(grep '^#define *LIBCURL_VERSION_MAJOR ' \ + "${TOPDIR}/include/curl/curlver.h" | + sed 's/^#define *LIBCURL_VERSION_MAJOR *\([^ ]*\).*/\1/') +LIBCURL_VERSION_MINOR=$(grep '^#define *LIBCURL_VERSION_MINOR ' \ + "${TOPDIR}/include/curl/curlver.h" | + sed 's/^#define *LIBCURL_VERSION_MINOR *\([^ ]*\).*/\1/') +LIBCURL_VERSION_PATCH=$(grep '^#define *LIBCURL_VERSION_PATCH ' \ + "${TOPDIR}/include/curl/curlver.h" | + sed 's/^#define *LIBCURL_VERSION_PATCH *\([^ ]*\).*/\1/') +LIBCURL_VERSION_NUM=$(grep '^#define *LIBCURL_VERSION_NUM ' \ + "${TOPDIR}/include/curl/curlver.h" | + sed 's/^#define *LIBCURL_VERSION_NUM *0x\([^ ]*\).*/\1/') +LIBCURL_TIMESTAMP=$(grep '^#define *LIBCURL_TIMESTAMP ' \ + "${TOPDIR}/include/curl/curlver.h" | + sed 's/.*"\(.*\)".*/\1/') +export LIBCURL_VERSION +export LIBCURL_VERSION_MAJOR LIBCURL_VERSION_MINOR LIBCURL_VERSION_PATCH +export LIBCURL_VERSION_NUM LIBCURL_TIMESTAMP + +################################################################################ +# +# OS/400 specific definitions. +# +################################################################################ + +LIBIFSNAME="/QSYS.LIB/${TARGETLIB}.LIB" + + +################################################################################ +# +# Procedures. +# +################################################################################ + +# action_needed dest [src] +# +# dest is an object to build +# if specified, src is an object on which dest depends. +# +# exit 0 (succeeds) if some action has to be taken, else 1. + +action_needed() + +{ + [ ! -e "${1}" ] && return 0 + [ -n "${2}" ] || return 1 + # shellcheck disable=SC3013 + [ "${1}" -ot "${2}" ] && return 0 + return 1 +} + + +# canonicalize_path path +# +# Return canonicalized path as: +# - Absolute +# - No . or .. component. + +canonicalize_path() + +{ + if expr "${1}" : '^/' > /dev/null + then P="${1}" + else P="$(pwd)/${1}" + fi + + R= + IFSSAVE="${IFS}" + IFS="/" + + for C in ${P} + do IFS="${IFSSAVE}" + case "${C}" in + .) ;; + ..) R="$(expr "${R}" : '^\(.*/\)..*')" + ;; + ?*) R="${R}${C}/" + ;; + *) ;; + esac + done + + IFS="${IFSSAVE}" + echo "/$(expr "${R}" : '^\(.*\)/')" +} + + +# make_module module_name source_name [additional_definitions] +# +# Compile source name into ASCII module if needed. +# As side effect, append the module name to variable MODULES. +# Set LINK to "YES" if the module has been compiled. + +make_module() + +{ + MODULES="${MODULES} ${1}" + MODIFSNAME="${LIBIFSNAME}/${1}.MODULE" + action_needed "${MODIFSNAME}" "${2}" || return 0; + SRCDIR="$(dirname "$(canonicalize_path "${2}")")" + + # #pragma convert has to be in the source file itself, i.e. + # putting it in an include file makes it only active + # for that include file. + # Thus we build a temporary file with the pragma prepended to + # the source file and we compile that temporary file. + + { + echo "#line 1 \"${2}\"" + echo "#pragma convert(819)" + echo "#line 1" + cat "${2}" + } > "${1}"__819.c + CMD="CRTCMOD MODULE(${TARGETLIB}/${1}) SRCSTMF('${1}__819.c')" + CMD="${CMD} SYSIFCOPT(*IFS64IO *ASYNCSIGNAL)" +# CMD="${CMD} OPTION(*INCDIRFIRST *SHOWINC *SHOWSYS)" + CMD="${CMD} OPTION(*INCDIRFIRST)" + CMD="${CMD} LOCALETYPE(*LOCALE) FLAG(10)" + CMD="${CMD} INCDIR('${QADRTDIR}/include'" + CMD="${CMD} '${TOPDIR}/include/curl' '${TOPDIR}/include' '${SRCDIR}'" + CMD="${CMD} '${TOPDIR}/projects/OS400'" + + if [ "${WITH_ZLIB}" != "0" ] + then CMD="${CMD} '${ZLIB_INCLUDE}'" + fi + + if [ "${WITH_LIBSSH2}" != "0" ] + then CMD="${CMD} '${LIBSSH2_INCLUDE}'" + fi + + CMD="${CMD} ${INCLUDES})" + CMD="${CMD} TGTCCSID(${TGTCCSID}) TGTRLS(${TGTRLS})" + CMD="${CMD} OUTPUT(${OUTPUT})" + CMD="${CMD} OPTIMIZE(${OPTIMIZE})" + CMD="${CMD} DBGVIEW(${DEBUG})" + + DEFINES="${3} 'qadrt_use_inline'" + + if [ "${WITH_ZLIB}" != "0" ] + then DEFINES="${DEFINES} HAVE_LIBZ" + fi + + if [ "${WITH_LIBSSH2}" != "0" ] + then DEFINES="${DEFINES} USE_LIBSSH2" + fi + + if [ -n "${DEFINES}" ] + then CMD="${CMD} DEFINE(${DEFINES})" + fi + + CLcommand "${CMD}" + if [ "${DEBUG}" = "*NONE" ] + then rm -f "${1}"__819.c + fi + # shellcheck disable=SC2034 + LINK=YES +} + + +# Determine DB2 object name from IFS name. + +db2_name() + +{ + if [ "${2}" = 'nomangle' ] + then basename "${1}" | + tr 'a-z-' 'A-Z_' | + sed -e 's/\..*//' \ + -e 's/^\(.\).*\(.........\)$/\1\2/' + else basename "${1}" | + tr 'a-z-' 'A-Z_' | + sed -e 's/\..*//' \ + -e 's/^CURL_*/C/' \ + -e 's/^TOOL_*/T/' \ + -e 's/^\(.\).*\(.........\)$/\1\2/' + fi +} + + +# Copy IFS file replacing version info. + +versioned_copy() + +{ + sed -e "s/@LIBCURL_VERSION@/${LIBCURL_VERSION}/g" \ + -e "s/@LIBCURL_VERSION_MAJOR@/${LIBCURL_VERSION_MAJOR}/g" \ + -e "s/@LIBCURL_VERSION_MINOR@/${LIBCURL_VERSION_MINOR}/g" \ + -e "s/@LIBCURL_VERSION_PATCH@/${LIBCURL_VERSION_PATCH}/g" \ + -e "s/@LIBCURL_VERSION_NUM@/${LIBCURL_VERSION_NUM}/g" \ + -e "s/@LIBCURL_TIMESTAMP@/${LIBCURL_TIMESTAMP}/g" \ + < "${1}" > "${2}" +} + + +# Get definitions from a make file. +# The `sed' statement works as follows: +# - Join \nl-separated lines. +# - Retain only lines that begins with "identifier =". +# - Replace @...@ substitutions by shell variable references. +# - Turn these lines into shell variable assignments. + +get_make_vars() + +{ + eval "$(sed -e ': begin' \ + -e '/\\$/{' \ + -e 'N' \ + -e 's/\\\n/ /' \ + -e 'b begin' \ + -e '}' \ + -e 's/[[:space:]][[:space:]]*/ /g' \ + -e '/^[A-Za-z_][A-Za-z0-9_]* *=/!d' \ + -e 's/@\([A-Za-z0-9_]*\)@/${\1}/g' \ + -e 's/ *= */=/' \ + -e 's/=\(.*[^ ]\) *$/="\1"/' \ + -e 's/\$(\([^)]*\))/${\1}/g' \ + < "${1}")" +} diff --git a/3rdparty/curl-8.21.0/projects/OS400/make-docs.sh b/3rdparty/curl-8.21.0/projects/OS400/make-docs.sh new file mode 100755 index 0000000000..b79b19e928 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/OS400/make-docs.sh @@ -0,0 +1,65 @@ +#!/bin/sh +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# +# Documentation build script for the OS/400. +# + + +SCRIPTDIR=$(dirname "${0}") +. "${SCRIPTDIR}/initscript.sh" + +[ -n "${PASEPERL}" ] || exit 0 # Perl needed for doc build. +cd "${TOPDIR}/docs" || exit 1 +[ -d "${IFSDIR}/docs" ] || mkdir "${IFSDIR}/docs" + + +# Command line options. + +( + cd cmdline-opts || exit 1 + MANPAGE=curl.1 + TEXTPAGE=curl.txt + get_make_vars Makefile.inc + rm -f "${IFSDIR}/docs/${MANPAGE}" "${IFSDIR}/docs/${TEXTPAGE}" + + # Prepare online manual. + # shellcheck disable=SC2086 + ${PASEPERL} "${TOPDIR}/scripts/managen" -c 75 \ + listhelp ${DPAGES} > "${TOPDIR}/src/tool_listhelp.c" + + # Generate text manual and copy it to DB2. + # shellcheck disable=SC2086 + ${PASEPERL} "${TOPDIR}/scripts/managen" -I "${TOPDIR}/include" \ + -c 75 ascii ${DPAGES} > "${IFSDIR}/docs/${TEXTPAGE}" + MEMBER="${LIBIFSNAME}/DOCS.FILE/MANUAL.MBR" + CMD="CPY OBJ('${IFSDIR}/docs/${TEXTPAGE}') TOOBJ('${MEMBER}')" + CMD="${CMD} TOCCSID(${TGTCCSID}) DTAFMT(*TEXT) REPLACE(*YES)" + CLcommand "${CMD}" + +# Man page is useless as OS/400 has no man command. +# # shellcheck disable=SC2086 +# ${PASEPERL} "${TOPDIR}/scripts/managen" -I "${TOPDIR}/include" \ +# mainpage ${DPAGES} > "${IFSDIR}/docs/${MANPAGE}" +) diff --git a/3rdparty/curl-8.21.0/projects/OS400/make-include.sh b/3rdparty/curl-8.21.0/projects/OS400/make-include.sh new file mode 100755 index 0000000000..e30e950539 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/OS400/make-include.sh @@ -0,0 +1,106 @@ +#!/bin/sh +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# +# Installation of the header files in the OS/400 library. +# + +SCRIPTDIR=$(dirname "${0}") +. "${SCRIPTDIR}/initscript.sh" +cd "${TOPDIR}/include" || exit 1 + + +# Create the OS/400 source program file for the header files. + +SRCPF="${LIBIFSNAME}/H.FILE" + +if action_needed "${SRCPF}" +then CMD="CRTSRCPF FILE(${TARGETLIB}/H) RCDLEN(112)" + CMD="${CMD} CCSID(${TGTCCSID}) TEXT('curl: Header files')" + CLcommand "${CMD}" +fi + + +# Create the IFS directory for the header files. + +IFSINCLUDE="${IFSDIR}/include/curl" + +if action_needed "${IFSINCLUDE}" +then mkdir -p "${IFSINCLUDE}" +fi + + +# Enumeration values are used as va_arg tagfields, so they MUST be +# integers. + +copy_hfile() + +{ + destfile="${1}" + srcfile="${2}" + shift + shift + sed -e '1i\ +#pragma enum(int)\ +' "${@}" -e '$a\ +#pragma enum(pop)\ +' < "${srcfile}" > "${destfile}" +} + +# Copy the header files. + +for HFILE in curl/*.h ${SCRIPTDIR}/ccsidcurl.h +do case "$(basename "${HFILE}" .h)" in + stdcheaders|typecheck-gcc) + continue;; + esac + + DEST="${SRCPF}/$(db2_name "${HFILE}" nomangle).MBR" + + if action_needed "${DEST}" "${HFILE}" + then copy_hfile "${DEST}" "${HFILE}" + IFSDEST="${IFSINCLUDE}/$(basename "${HFILE}")" + rm -f "${IFSDEST}" + ln -s "${DEST}" "${IFSDEST}" + fi +done + + +# Copy the ILE/RPG header file, setting-up version number. + +versioned_copy "${SCRIPTDIR}/curl.inc.in" "${SRCPF}/CURL.INC.MBR" +rm -f "${IFSINCLUDE}/curl.inc.rpgle" +ln -s "${SRCPF}/CURL.INC.MBR" "${IFSINCLUDE}/curl.inc.rpgle" + + +# Duplicate file H as CURL to support more include path forms. + +if action_needed "${LIBIFSNAME}/CURL.FILE" +then : +else CLcommand "DLTF FILE(${TARGETLIB}/CURL)" +fi + +CMD="CRTDUPOBJ OBJ(H) FROMLIB(${TARGETLIB}) OBJTYPE(*FILE) TOLIB(*FROMLIB)" +CMD="${CMD} NEWOBJ(CURL) DATA(*YES)" +CLcommand "${CMD}" diff --git a/3rdparty/curl-8.21.0/projects/OS400/make-lib.sh b/3rdparty/curl-8.21.0/projects/OS400/make-lib.sh new file mode 100755 index 0000000000..cd3f71897f --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/OS400/make-lib.sh @@ -0,0 +1,181 @@ +#!/bin/sh +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# +# libcurl compilation script for the OS/400. +# + +SCRIPTDIR=$(dirname "${0}") +. "${SCRIPTDIR}/initscript.sh" +cd "${TOPDIR}/lib" || exit 1 + +# Need to have IFS access to the mih/cipher header file. + +if action_needed cipher.mih '/QSYS.LIB/QSYSINC.LIB/MIH.FILE/CIPHER.MBR' +then rm -f cipher.mih + ln -s '/QSYS.LIB/QSYSINC.LIB/MIH.FILE/CIPHER.MBR' cipher.mih +fi + + +# Create and compile the identification source file. + +{ + echo '#pragma comment(user, "libcurl version '"${LIBCURL_VERSION}"'")' + echo '#pragma comment(user, __DATE__)' + echo '#pragma comment(user, __TIME__)' + echo '#pragma comment(copyright, "Copyright (C) Daniel Stenberg et al. OS/400 version by P. Monnerat")' +} > os400.c +make_module OS400 os400.c BUILDING_LIBCURL +LINK= # No need to rebuild service program yet. +MODULES= + + +# Get source list (CSOURCES variable). + +get_make_vars Makefile.inc + + +# Compile the sources into modules. + +# shellcheck disable=SC2034 +INCLUDES="'$(pwd)'" + +make_module OS400SYS "${SCRIPTDIR}/os400sys.c" BUILDING_LIBCURL +make_module CCSIDCURL "${SCRIPTDIR}/ccsidcurl.c" BUILDING_LIBCURL + +for SRC in ${CSOURCES} +do MODULE=$(db2_name "${SRC}") + make_module "${MODULE}" "${SRC}" BUILDING_LIBCURL +done + + +# If needed, (re)create the static binding directory. + +if action_needed "${LIBIFSNAME}/${STATBNDDIR}.BNDDIR" +then LINK=YES +fi + +if [ -n "${LINK}" ] +then rm -rf "${LIBIFSNAME}/${STATBNDDIR}.BNDDIR" + CMD="CRTBNDDIR BNDDIR(${TARGETLIB}/${STATBNDDIR})" + CMD="${CMD} TEXT('libcurl API static binding directory')" + CLcommand "${CMD}" + + for MODULE in ${MODULES} + do CMD="ADDBNDDIRE BNDDIR(${TARGETLIB}/${STATBNDDIR})" + CMD="${CMD} OBJ((${TARGETLIB}/${MODULE} *MODULE))" + CLcommand "${CMD}" + done +fi + + +# The exportation file for service program creation must be in a DB2 +# source file, so make sure it exists. + +if action_needed "${LIBIFSNAME}/TOOLS.FILE" +then CMD="CRTSRCPF FILE(${TARGETLIB}/TOOLS) RCDLEN(112)" + CMD="${CMD} TEXT('curl: build tools')" + CLcommand "${CMD}" +fi + + +# Gather the list of symbols to export. +# - Unfold lines from the header files so that they contain a semicolon. +# - Keep only CURL_EXTERN definitions. +# - Remove the CURL_DEPRECATED and CURL_TEMP_PRINTF macro calls. +# - Drop the parenthesized function arguments and what follows. +# - Keep the trailing function name only. + +EXPORTS=$(cat "${TOPDIR}"/include/curl/*.h "${SCRIPTDIR}/ccsidcurl.h" | + sed -e 'H;s/.*//;x;s/\n//;s/.*/& /' \ + -e '/^CURL_EXTERN[[:space:]]/!d' \ + -e '/\;/!{x;d;}' \ + -e 's/ CURL_DEPRECATED([^)]*)//g' \ + -e 's/ CURL_TEMP_PRINTF([^)]*)//g' \ + -e 's/[[:space:]]*(.*$//' \ + -e 's/^.*[^A-Za-z0-9_]\([A-Za-z0-9_]*\)$/\1/') + + +# Create the service program exportation file in DB2 member if needed. + +BSF="${LIBIFSNAME}/TOOLS.FILE/BNDSRC.MBR" + +if action_needed "${BSF}" Makefile.am +then LINK=YES +fi + +if [ -n "${LINK}" ] +then echo " STRPGMEXP PGMLVL(*CURRENT) SIGNATURE('LIBCURL_${SONAME}')" \ + > "${BSF}" + for EXPORT in ${EXPORTS} + do echo ' EXPORT SYMBOL("'"${EXPORT}"'")' >> "${BSF}" + done + + echo ' ENDPGMEXP' >> "${BSF}" +fi + + +# Build the service program if needed. + +if action_needed "${LIBIFSNAME}/${SRVPGM}.SRVPGM" +then LINK=YES +fi + +if [ -n "${LINK}" ] +then CMD="CRTSRVPGM SRVPGM(${TARGETLIB}/${SRVPGM})" + CMD="${CMD} SRCFILE(${TARGETLIB}/TOOLS) SRCMBR(BNDSRC)" + CMD="${CMD} MODULE(${TARGETLIB}/OS400)" + CMD="${CMD} BNDDIR(${TARGETLIB}/${STATBNDDIR}" + if [ "${WITH_ZLIB}" != 0 ] + then CMD="${CMD} ${ZLIB_LIB}/${ZLIB_BNDDIR}" + liblist -a "${ZLIB_LIB}" + fi + if [ "${WITH_LIBSSH2}" != 0 ] + then CMD="${CMD} ${LIBSSH2_LIB}/${LIBSSH2_BNDDIR}" + liblist -a "${LIBSSH2_LIB}" + fi + CMD="${CMD})" + CMD="${CMD} BNDSRVPGM(QADRTTS QGLDCLNT QGLDBRDR)" + CMD="${CMD} TEXT('curl API library')" + CMD="${CMD} TGTRLS(${TGTRLS})" + CLcommand "${CMD}" + LINK=YES +fi + + +# If needed, (re)create the dynamic binding directory. + +if action_needed "${LIBIFSNAME}/${DYNBNDDIR}.BNDDIR" +then LINK=YES +fi + +if [ -n "${LINK}" ] +then rm -rf "${LIBIFSNAME}/${DYNBNDDIR}.BNDDIR" + CMD="CRTBNDDIR BNDDIR(${TARGETLIB}/${DYNBNDDIR})" + CMD="${CMD} TEXT('libcurl API dynamic binding directory')" + CLcommand "${CMD}" + CMD="ADDBNDDIRE BNDDIR(${TARGETLIB}/${DYNBNDDIR})" + CMD="${CMD} OBJ((*LIBL/${SRVPGM} *SRVPGM))" + CLcommand "${CMD}" +fi diff --git a/3rdparty/curl-8.21.0/projects/OS400/make-src.sh b/3rdparty/curl-8.21.0/projects/OS400/make-src.sh new file mode 100755 index 0000000000..5ca84be9b5 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/OS400/make-src.sh @@ -0,0 +1,118 @@ +#!/bin/sh +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# +# Command line interface tool compilation script for the OS/400. + +SCRIPTDIR=$(dirname "${0}") +. "${SCRIPTDIR}/initscript.sh" +cd "${TOPDIR}/src" || exit 1 + + +# Check if built-in manual can be generated. + +USE_MANUAL= +if [ -f "${IFSDIR}/docs/curl.txt" ] && [ -n "${PASEPERL}" ] +then "${PASEPERL}" ./mkhelp.pl < "${IFSDIR}/docs/curl.txt" > tool_hugehelp.c + USE_MANUAL="'USE_MANUAL'" +fi + + +# Get source lists. +# CURL_CFILES are in the current directory. +# CURLX_CFILES are in the lib directory and need to be recompiled because +# some function names change using macros. + +get_make_vars Makefile.inc + + +# Add hugehelp, as it is not included in Makefile.inc. +if [ "${USE_MANUAL}" = "'USE_MANUAL'" ] +then + CURL_CFILES="${CURL_CFILES} tool_hugehelp.c" + CURL_HFILES="${CURL_HFILES} tool_hugehelp.h" +fi + +# Compile the sources into modules. + +# shellcheck disable=SC2034 +LINK= +MODULES= +# shellcheck disable=SC2034 +INCLUDES="'${TOPDIR}/lib' '${TOPDIR}/lib/curlx'" + +# shellcheck disable=SC2153 +for SRC in ${CURLX_CFILES} +do MODULE=$(db2_name "${SRC}") + MODULE=$(db2_name "X${MODULE}") + make_module "${MODULE}" "${SRC}" "${USE_MANUAL}" +done + +for SRC in ${CURL_CFILES} +do MODULE=$(db2_name "${SRC}") + make_module "${MODULE}" "${SRC}" "${USE_MANUAL}" +done + + +# Link modules into program. + +MODULES="$(echo "${MODULES}" | sed "s/[^ ][^ ]*/${TARGETLIB}\/&/g")" +CMD="CRTPGM PGM(${TARGETLIB}/${CURLPGM})" +CMD="${CMD} ENTMOD(${TARGETLIB}/CURLMAIN)" +CMD="${CMD} MODULE(${MODULES})" +CMD="${CMD} BNDSRVPGM(${TARGETLIB}/${SRVPGM} QADRTTS)" +CMD="${CMD} TGTRLS(${TGTRLS})" +CLcommand "${CMD}" + + +# Create the IFS command. + +IFSBIN="${IFSDIR}/bin" + +if action_needed "${IFSBIN}" +then mkdir -p "${IFSBIN}" +fi + +rm -f "${IFSBIN}/curl" +ln -s "/QSYS.LIB/${TARGETLIB}.LIB/${CURLPGM}.PGM" "${IFSBIN}/curl" + + +# Create the CL interface program. + +if action_needed "${LIBIFSNAME}/CURLCL.PGM" "${SCRIPTDIR}/curlcl.c" +then CMD="CRTBNDC PGM(${TARGETLIB}/${CURLCLI})" + CMD="${CMD} SRCSTMF('${SCRIPTDIR}/curlcl.c')" + CMD="${CMD} DEFINE('CURLPGM=\"${CURLPGM}\"')" + CMD="${CMD} TGTCCSID(${TGTCCSID})" + CLcommand "${CMD}" +fi + + +# Create the CL command. + +if action_needed "${LIBIFSNAME}/${CURLCMD}.CMD" "${SCRIPTDIR}/curl.cmd" +then CMD="CRTCMD CMD(${TARGETLIB}/${CURLCMD}) PGM(${TARGETLIB}/${CURLCLI})" + CMD="${CMD} SRCSTMF('${SCRIPTDIR}/curl.cmd')" + CLcommand "${CMD}" +fi diff --git a/3rdparty/curl-8.21.0/projects/OS400/make-tests.sh b/3rdparty/curl-8.21.0/projects/OS400/make-tests.sh new file mode 100755 index 0000000000..4ddc537487 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/OS400/make-tests.sh @@ -0,0 +1,144 @@ +#!/bin/sh +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# +# tests compilation script for the OS/400. +# + + +SCRIPTDIR=$(dirname "${0}") +. "${SCRIPTDIR}/initscript.sh" +cd "${TOPDIR}/tests" || exit 1 + + +# Build programs in a directory. + +build_all_programs() + +{ + # Compile all programs. + # The list is found in variable "noinst_PROGRAMS" + + # shellcheck disable=SC2034 + INCLUDES="'$(pwd)' '${TOPDIR}/lib' '${TOPDIR}/src'" + MODS="${1}" + SRVPGMS="${2}" + + # shellcheck disable=SC2154 + for PGM in ${noinst_PROGRAMS} + do DB2PGM=$(db2_name "${PGM}") + PGMIFSNAME="${LIBIFSNAME}/${DB2PGM}.PGM" + + # Extract preprocessor symbol definitions from + # compilation options for the program. + + PGMCFLAGS="$(eval echo "\${${PGM}_CFLAGS}")" + PGMDFNS= + + for FLAG in ${PGMCFLAGS} + do case "${FLAG}" in + -D?*) + DEFINE="$(echo "${FLAG}" | sed 's/^..//')" + PGMDFNS="${PGMDFNS} '${DEFINE}'" + ;; + esac + done + + # Compile all C sources for the program into modules. + + PGMSOURCES="$(eval echo "\${${PGM}_SOURCES}")" + LINK= + MODULES= + + for SOURCE in ${PGMSOURCES} + do case "${SOURCE}" in + *.c) # Special processing for libxxx.c files: + # their module name is determined + # by the target PROGRAM name. + + case "${SOURCE}" in + lib*.c) MODULE="${DB2PGM}" + ;; + *) MODULE=$(db2_name "${SOURCE}") + ;; + esac + + # If source is in a sibling directory, + # prefix module name with 'X'. + + case "${SOURCE}" in + ../*) MODULE=$(db2_name "X${MODULE}") + ;; + esac + + make_module "${MODULE}" "${SOURCE}" "${PGMDFNS}" + if action_needed "${PGMIFSNAME}" "${MODIFSNAME}" + then LINK=yes + fi + ;; + esac + done + + # Link program if needed. + + if [ -n "${LINK}" ] + then PGMLDADD="$(eval echo "\${${PGM}_LDADD}")" + for M in ${PGMLDADD} + do case "${M}" in + -*) ;; # Ignore non-module. + *) MODULES="${MODULES} $(db2_name "${M}")" + ;; + esac + done + MODULES="$(echo "${MODULES}" | + sed "s/[^ ][^ ]*/${TARGETLIB}\/&/g")" + CMD="CRTPGM PGM(${TARGETLIB}/${DB2PGM})" + CMD="${CMD} ENTMOD(${TARGETLIB}/CURLMAIN)" + CMD="${CMD} MODULE(${MODULES} ${MODS})" + CMD="${CMD} BNDSRVPGM(${SRVPGMS} QADRTTS)" + CMD="${CMD} TGTRLS(${TGTRLS})" + CLcommand "${CMD}" + fi + done +} + + +# Build programs in the server directory. + +( + cd server || exit 1 + get_make_vars Makefile.inc + build_all_programs "${TARGETLIB}/OS400SYS" +) + + +# Build all programs in the libtest subdirectory. + +( + cd libtest || exit 1 + get_make_vars Makefile.inc + + # shellcheck disable=SC2153 + build_all_programs "" "${TARGETLIB}/${SRVPGM}" +) diff --git a/3rdparty/curl-8.21.0/projects/OS400/makefile.sh b/3rdparty/curl-8.21.0/projects/OS400/makefile.sh new file mode 100755 index 0000000000..2b688a4421 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/OS400/makefile.sh @@ -0,0 +1,137 @@ +#!/bin/sh +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +# +# curl compilation script for the OS/400. +# +# +# This is a shell script since make is not a standard component of OS/400. + +SCRIPTDIR=$(dirname "${0}") +. "${SCRIPTDIR}/initscript.sh" +cd "${TOPDIR}" || exit 1 + + +# Make sure all files are UTF8-encoded. + +# Qshell does not support -print0. ls -S has a non-POSIX meaning. +# https://www.ibm.com/docs/en/i/7.1.0?topic=qshell-command-language +# shellcheck disable=SC2038 +find "${TOPDIR}" -type f | xargs ls -S -- | while read -r CCSID FILE +do if [ "${CCSID}" != 1208 ] + then CMD="CPY OBJ('${FILE}') TOOBJ('${FILE}') FROMCCSID(*OBJ)" + CMD="${CMD} TOCCSID(1208) DTAFMT(*TEXT) REPLACE(*YES)" + (CLcommand "${CMD}") + fi +done + + +# Create the OS/400 library if it does not exist. + +if action_needed "${LIBIFSNAME}" +then CMD="CRTLIB LIB(${TARGETLIB}) TEXT('curl: multiprotocol support API')" + CLcommand "${CMD}" +fi + + +# Create the DOCS source file if it does not exist. + +if action_needed "${LIBIFSNAME}/DOCS.FILE" +then CMD="CRTSRCPF FILE(${TARGETLIB}/DOCS) RCDLEN(240)" + CMD="${CMD} CCSID(${TGTCCSID}) TEXT('Documentation texts')" + CLcommand "${CMD}" +fi + + +# Copy some documentation files if needed. + +for TEXT in "${TOPDIR}/COPYING" "${SCRIPTDIR}/README.OS400" \ + "${TOPDIR}/CHANGES.md" "${TOPDIR}/docs/THANKS" "${TOPDIR}/docs/FAQ.md" \ + "${TOPDIR}/docs/FEATURES" "${TOPDIR}/docs/SSLCERTS.md" \ + "${TOPDIR}/docs/RESOURCES" "${TOPDIR}/docs/VERSIONS.md" \ + "${TOPDIR}/docs/HISTORY.md" +do MEMBER="$(basename "${TEXT}" .OS400)" + MEMBER="$(basename "${MEMBER}" .md)" + MEMBER="${LIBIFSNAME}/DOCS.FILE/$(db2_name "${MEMBER}").MBR" + + [ -e "${TEXT}" ] || continue + + if action_needed "${MEMBER}" "${TEXT}" + then CMD="CPY OBJ('${TEXT}') TOOBJ('${MEMBER}') TOCCSID(${TGTCCSID})" + CMD="${CMD} DTAFMT(*TEXT) REPLACE(*YES)" + CLcommand "${CMD}" + fi +done + + +# Create the RPGXAMPLES source file if it does not exist. + +if action_needed "${LIBIFSNAME}/RPGXAMPLES.FILE" +then CMD="CRTSRCPF FILE(${TARGETLIB}/RPGXAMPLES) RCDLEN(240)" + CMD="${CMD} CCSID(${TGTCCSID}) TEXT('ILE/RPG examples')" + CLcommand "${CMD}" +fi + + +# Copy RPG examples if needed. + +for EXAMPLE in "${SCRIPTDIR}/rpg-examples"/* +do MEMBER="$(basename "${EXAMPLE}")" + IFSMEMBER="${LIBIFSNAME}/RPGXAMPLES.FILE/$(db2_name "${MEMBER}").MBR" + + [ -e "${EXAMPLE}" ] || continue + + if action_needed "${IFSMEMBER}" "${EXAMPLE}" + then CMD="CPY OBJ('${EXAMPLE}') TOOBJ('${IFSMEMBER}')" + CMD="${CMD} TOCCSID(${TGTCCSID}) DTAFMT(*TEXT) REPLACE(*YES)" + CLcommand "${CMD}" + MBRTEXT=$(sed -e '1!d;/^ \*/!d;s/^ *\* *//' \ + -e 's/ *$//;s/'"'"'/&&/g' < "${EXAMPLE}") + CMD="CHGPFM FILE(${TARGETLIB}/RPGXAMPLES) MBR(${MEMBER})" + CMD="${CMD} SRCTYPE(RPGLE) TEXT('${MBRTEXT}')" + CLcommand "${CMD}" + fi +done + + +# Compile the QADRTMAIN2 replacement module. + +if action_needed "${LIBIFSNAME}/CURLMAIN.MODULE" "${SCRIPTDIR}/curlmain.c" +then CMD="CRTCMOD MODULE(${TARGETLIB}/CURLMAIN)" + CMD="${CMD} SRCSTMF('${SCRIPTDIR}/curlmain.c')" + CMD="${CMD} SYSIFCOPT(*IFS64IO) LOCALETYPE(*LOCALE) FLAG(10)" + CMD="${CMD} TGTCCSID(${TGTCCSID}) TGTRLS(${TGTRLS})" + CMD="${CMD} OUTPUT(${OUTPUT})" + CMD="${CMD} OPTIMIZE(${OPTIMIZE})" + CMD="${CMD} DBGVIEW(${DEBUG})" + CLcommand "${CMD}" +fi + + +# Build in each directory. + +# for SUBDIR in include lib docs src tests +for SUBDIR in include lib docs src +do "${SCRIPTDIR}/make-${SUBDIR}.sh" +done diff --git a/3rdparty/curl-8.21.0/projects/OS400/os400sys.c b/3rdparty/curl-8.21.0/projects/OS400/os400sys.c new file mode 100644 index 0000000000..fc7ae3c612 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/OS400/os400sys.c @@ -0,0 +1,1038 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + * + ***************************************************************************/ + +/* OS/400 additional support. */ + +#include +#include "config-os400.h" /* Not curl_setup.h: we only need some defines. */ + +#include +#include +#include + +#include +#include +#include +#include +#include +#include +#include + +#ifdef HAVE_LIBZ +#include +#endif + +#ifdef HAVE_GSSAPI +#include +#endif + +#ifndef CURL_DISABLE_LDAP +#include +#endif + +#include +#include + +#include "os400sys.h" + +/** +*** QADRT OS/400 ASCII runtime defines only the most used procedures, but a +*** lot of them are not supported. This module implements ASCII wrappers for +*** those that are used by libcurl, but not defined by QADRT. +**/ + +#pragma convert(0) /* Restore EBCDIC. */ + +#define MIN_BYTE_GAIN 1024 /* Minimum gain when shortening a buffer. */ + +struct buffer_t { + unsigned long size; /* Buffer size. */ + char *buf; /* Buffer address. */ +}; + +static char *buffer_undef(localkey_t key, long size); +static char *buffer_threaded(localkey_t key, long size); +static char *buffer_unthreaded(localkey_t key, long size); + +static pthread_mutex_t mutex = PTHREAD_MUTEX_INITIALIZER; +static pthread_key_t thdkey; +static struct buffer_t *locbufs; + +char *(*Curl_thread_buffer)(localkey_t key, long size) = buffer_undef; + +static void thdbufdestroy(void *private) +{ + if(private) { + struct buffer_t *p = (struct buffer_t *)private; + localkey_t i; + + for(i = (localkey_t)0; i < LK_LAST; i++) { + free(p->buf); + p++; + } + + free(private); + } +} + +static void terminate(void) +{ + if(Curl_thread_buffer == buffer_threaded) { + locbufs = pthread_getspecific(thdkey); + pthread_setspecific(thdkey, (void *)NULL); + pthread_key_delete(thdkey); + } + + if(Curl_thread_buffer != buffer_undef) { + thdbufdestroy((void *)locbufs); + locbufs = (struct buffer_t *)NULL; + } + + Curl_thread_buffer = buffer_undef; +} + +static char *get_buffer(struct buffer_t *buf, long size) +{ + char *cp; + + /* If `size' >= 0, make sure buffer at `buf' is at least `size'-byte long. + Return the buffer address. */ + + if(size < 0) + return buf->buf; + + if(!buf->buf) { + buf->buf = malloc(size); + if(buf->buf) + buf->size = size; + + return buf->buf; + } + + if((unsigned long)size <= buf->size) { + /* Shorten the buffer only if it frees a significant byte count. This + avoids some realloc() overhead. */ + + if(buf->size - size < MIN_BYTE_GAIN) + return buf->buf; + } + + /* Resize the buffer. */ + + cp = realloc(buf->buf, size); + if(cp) { + buf->buf = cp; + buf->size = size; + } + else if(size <= buf->size) + cp = buf->buf; + + return cp; +} + +/* + * Get buffer address for the given local key. + * This is always called though `Curl_thread_buffer' and when threads are + * NOT made available by the os, so no mutex lock/unlock occurs. + */ +static char *buffer_unthreaded(localkey_t key, long size) +{ + return get_buffer(locbufs + key, size); +} + +/* + * Get buffer address for the given local key, taking care of + * concurrent threads. + * This is always called though `Curl_thread_buffer' and when threads are + * made available by the os. + */ +static char *buffer_threaded(localkey_t key, long size) +{ + struct buffer_t *bufs; + + /* Get the buffer for the given local key in the current thread, and + make sure it is at least `size'-byte long. Set `size' to < 0 to get + its address only. */ + + bufs = (struct buffer_t *)pthread_getspecific(thdkey); + + if(!bufs) { + if(size < 0) + return (char *)NULL; /* No buffer yet. */ + + /* Allocate buffer descriptors for the current thread. */ + + bufs = calloc((size_t)LK_LAST, sizeof(*bufs)); + if(!bufs) + return (char *)NULL; + + if(pthread_setspecific(thdkey, (void *)bufs)) { + free(bufs); + return (char *)NULL; + } + } + + return get_buffer(bufs + key, size); +} + +static char *buffer_undef(localkey_t key, long size) +{ + /* Define the buffer system, get the buffer for the given local key in + the current thread, and make sure it is at least `size'-byte long. + Set `size' to < 0 to get its address only. */ + + pthread_mutex_lock(&mutex); + + /* Determine if we can use pthread-specific data. */ + + if(Curl_thread_buffer == buffer_undef) { /* If unchanged during lock. */ + /* OS400 interactive jobs do not support threads: check here. */ + if(!pthread_key_create(&thdkey, thdbufdestroy)) { + /* Threads are supported: use the thread-aware buffer procedure. */ + Curl_thread_buffer = buffer_threaded; + } + else { + /* No multi-threading available: allocate storage for single-thread + * buffer headers. */ + locbufs = calloc((size_t)LK_LAST, sizeof(*locbufs)); + if(!locbufs) { + pthread_mutex_unlock(&mutex); /* For symmetry: will probably fail. */ + return (char *)NULL; + } + else + Curl_thread_buffer = buffer_unthreaded; /* Use unthreaded version. */ + } + + atexit(terminate); + } + + pthread_mutex_unlock(&mutex); + return Curl_thread_buffer(key, size); +} + +static char *set_thread_string(localkey_t key, const char *s) +{ + int i; + char *cp; + + if(!s) + return (char *)NULL; + + i = strlen(s) + 1; + cp = Curl_thread_buffer(key, MAX_CONV_EXPANSION * i + 1); + + if(cp) { + i = QadrtConvertE2A(cp, s, MAX_CONV_EXPANSION * i, i); + cp[i] = '\0'; + } + + return cp; +} + +int Curl_getnameinfo_a(const struct sockaddr *sa, socklen_t salen, + char *nodename, socklen_t nodenamelen, + char *servname, socklen_t servnamelen, + int flags) +{ + char *enodename = NULL; + char *eservname = NULL; + int status; + + if(nodename && nodenamelen) { + enodename = malloc(nodenamelen); + if(!enodename) + return EAI_MEMORY; + } + + if(servname && servnamelen) { + eservname = malloc(servnamelen); + if(!eservname) { + free(enodename); + return EAI_MEMORY; + } + } + + status = getnameinfo(sa, salen, enodename, nodenamelen, eservname, + servnamelen, flags); + + if(!status) { + int i; + if(enodename) { + i = QadrtConvertE2A(nodename, enodename, nodenamelen - 1, + strlen(enodename)); + nodename[i] = '\0'; + } + + if(eservname) { + i = QadrtConvertE2A(servname, eservname, servnamelen - 1, + strlen(eservname)); + servname[i] = '\0'; + } + } + + free(enodename); + free(eservname); + return status; +} + +int Curl_getaddrinfo_a(const char *nodename, const char *servname, + const struct addrinfo *hints, struct addrinfo **res) +{ + char *enodename; + char *eservname; + int status; + int i; + + enodename = (char *)NULL; + eservname = (char *)NULL; + + if(nodename) { + i = strlen(nodename); + + enodename = malloc(i + 1); + if(!enodename) + return EAI_MEMORY; + + i = QadrtConvertA2E(enodename, nodename, i, i); + enodename[i] = '\0'; + } + + if(servname) { + i = strlen(servname); + + eservname = malloc(i + 1); + if(!eservname) { + free(enodename); + return EAI_MEMORY; + } + + QadrtConvertA2E(eservname, servname, i, i); + eservname[i] = '\0'; + } + + /* !checksrc! disable BANNEDFUNC 1 */ + status = getaddrinfo(enodename, eservname, hints, res); + free(enodename); + free(eservname); + return status; +} + +#ifdef HAVE_GSSAPI + +/* ASCII wrappers for the GSSAPI procedures. */ + +static int Curl_gss_convert_in_place(OM_uint32 *minor_status, gss_buffer_t buf) +{ + unsigned int i = buf->length; + + /* Convert `buf' in place, from EBCDIC to ASCII. + If error, release the buffer and return -1. Else return 0. */ + + if(i) { + char *t = malloc(i); + if(!t) { + gss_release_buffer(minor_status, buf); + + if(minor_status) + /* !checksrc! disable ERRNOVAR 1 */ + *minor_status = ENOMEM; + + return -1; + } + + QadrtConvertE2A(t, buf->value, i, i); + memcpy(buf->value, t, i); + free(t); + } + + return 0; +} + +/* Max string input length is a precaution against abuse and to detect junk + input easier and better. */ +#define CURL_MAX_INPUT_LENGTH 8000000 + +OM_uint32 Curl_gss_import_name_a(OM_uint32 *minor_status, gss_buffer_t in_name, + gss_OID in_name_type, gss_name_t *out_name) +{ + OM_uint32 rc; + unsigned int i; + gss_buffer_desc in; + + if(!in_name || !in_name->value || !in_name->length) + return gss_import_name(minor_status, in_name, in_name_type, out_name); + + memcpy((char *)&in, (char *)in_name, sizeof(in)); + if(in.length > CURL_MAX_INPUT_LENGTH) { + if(minor_status) + /* !checksrc! disable ERRNOVAR 1 */ + *minor_status = ENOMEM; + + return GSS_S_FAILURE; + } + i = (unsigned int)in.length; + + in.value = malloc(i + 1); + if(!in.value) { + if(minor_status) + /* !checksrc! disable ERRNOVAR 1 */ + *minor_status = ENOMEM; + + return GSS_S_FAILURE; + } + + QadrtConvertA2E(in.value, in_name->value, i, i); + ((char *)in.value)[i] = '\0'; + rc = gss_import_name(minor_status, &in, in_name_type, out_name); + free(in.value); + return rc; +} + +OM_uint32 Curl_gss_display_status_a(OM_uint32 *minor_status, + OM_uint32 status_value, int status_type, + gss_OID mech_type, + gss_msg_ctx_t *message_context, + gss_buffer_t status_string) +{ + int rc; + + rc = gss_display_status(minor_status, status_value, status_type, + mech_type, message_context, status_string); + + if(rc != GSS_S_COMPLETE || !status_string || + !status_string->length || !status_string->value) + return rc; + + /* No way to allocate a buffer here, because it will be released by + gss_release_buffer(). The solution is to overwrite the EBCDIC buffer + with ASCII to return it. */ + + if(Curl_gss_convert_in_place(minor_status, status_string)) + return GSS_S_FAILURE; + + return rc; +} + +OM_uint32 Curl_gss_init_sec_context_a( + OM_uint32 *minor_status, + gss_cred_id_t cred_handle, + gss_ctx_id_t *context_handle, + gss_name_t target_name, gss_OID mech_type, + gss_flags_t req_flags, OM_uint32 time_req, + gss_channel_bindings_t input_chan_bindings, + gss_buffer_t input_token, + gss_OID *actual_mech_type, + gss_buffer_t output_token, gss_flags_t *ret_flags, + OM_uint32 *time_rec) +{ + int rc; + gss_buffer_desc in; + gss_buffer_t inp; + + in.value = NULL; + inp = input_token; + + if(inp) { + if(inp->length && inp->value) { + unsigned int i; + if(inp->length > CURL_MAX_INPUT_LENGTH) { + if(minor_status) + /* !checksrc! disable ERRNOVAR 1 */ + *minor_status = ENOMEM; + + return GSS_S_FAILURE; + } + i = (unsigned int)inp->length; + in.value = malloc(i + 1); + if(!in.value) { + if(minor_status) + /* !checksrc! disable ERRNOVAR 1 */ + *minor_status = ENOMEM; + + return GSS_S_FAILURE; + } + + QadrtConvertA2E(in.value, input_token->value, i, i); + ((char *)in.value)[i] = '\0'; + in.length = i; + inp = ∈ + } + } + + rc = gss_init_sec_context(minor_status, cred_handle, context_handle, + target_name, mech_type, req_flags, time_req, + input_chan_bindings, inp, actual_mech_type, + output_token, ret_flags, time_rec); + free(in.value); + + if(rc != GSS_S_COMPLETE || !output_token || + !output_token->length || !output_token->value) + return rc; + + /* No way to allocate a buffer here, because it will be released by + gss_release_buffer(). The solution is to overwrite the EBCDIC buffer + with ASCII to return it. */ + + if(Curl_gss_convert_in_place(minor_status, output_token)) + return GSS_S_FAILURE; + + return rc; +} + +OM_uint32 Curl_gss_delete_sec_context_a(OM_uint32 *minor_status, + gss_ctx_id_t *context_handle, + gss_buffer_t output_token) +{ + OM_uint32 rc; + + rc = gss_delete_sec_context(minor_status, context_handle, output_token); + + if(rc != GSS_S_COMPLETE || !output_token || + !output_token->length || !output_token->value) + return rc; + + /* No way to allocate a buffer here, because it will be released by + gss_release_buffer(). The solution is to overwrite the EBCDIC buffer + with ASCII to return it. */ + + if(Curl_gss_convert_in_place(minor_status, output_token)) + return GSS_S_FAILURE; + + return rc; +} + +#endif /* HAVE_GSSAPI */ + +#ifndef CURL_DISABLE_LDAP + +/* ASCII wrappers for the LDAP procedures. */ + +void *Curl_ldap_init_a(char *host, int port) +{ + size_t i; + char *ehost; + void *result; + + if(!host) + return (void *)ldap_init(host, port); + + i = strlen(host); + + ehost = malloc(i + 1); + if(!ehost) + return (void *)NULL; + + QadrtConvertA2E(ehost, host, i, i); + ehost[i] = '\0'; + result = (void *)ldap_init(ehost, port); + free(ehost); + return result; +} + +int Curl_ldap_simple_bind_s_a(void *ld, char *dn, char *passwd) +{ + int i; + char *edn; + char *epasswd; + + edn = (char *)NULL; + epasswd = (char *)NULL; + + if(dn) { + i = strlen(dn); + + edn = malloc(i + 1); + if(!edn) + return LDAP_NO_MEMORY; + + QadrtConvertA2E(edn, dn, i, i); + edn[i] = '\0'; + } + + if(passwd) { + i = strlen(passwd); + + epasswd = malloc(i + 1); + if(!epasswd) { + free(edn); + return LDAP_NO_MEMORY; + } + + QadrtConvertA2E(epasswd, passwd, i, i); + epasswd[i] = '\0'; + } + + i = ldap_simple_bind_s(ld, edn, epasswd); + free(epasswd); + free(edn); + return i; +} + +int Curl_ldap_search_s_a(void *ld, char *base, int scope, char *filter, + char **attrs, int attrsonly, LDAPMessage **res) +{ + int i; + int j; + char *ebase; + char *efilter; + char **eattrs; + int status; + + ebase = (char *)NULL; + efilter = (char *)NULL; + eattrs = (char **)NULL; + status = LDAP_SUCCESS; + + if(base) { + i = strlen(base); + + ebase = malloc(i + 1); + if(!ebase) + status = LDAP_NO_MEMORY; + else { + QadrtConvertA2E(ebase, base, i, i); + ebase[i] = '\0'; + } + } + + if(filter && status == LDAP_SUCCESS) { + i = strlen(filter); + + efilter = malloc(i + 1); + if(!efilter) + status = LDAP_NO_MEMORY; + else { + QadrtConvertA2E(efilter, filter, i, i); + efilter[i] = '\0'; + } + } + + if(attrs && status == LDAP_SUCCESS) { + for(i = 0; attrs[i++];) + ; + + eattrs = calloc(i, sizeof(*eattrs)); + if(!eattrs) + status = LDAP_NO_MEMORY; + else { + for(j = 0; attrs[j]; j++) { + i = strlen(attrs[j]); + + eattrs[j] = malloc(i + 1); + if(!eattrs[j]) { + status = LDAP_NO_MEMORY; + break; + } + + QadrtConvertA2E(eattrs[j], attrs[j], i, i); + eattrs[j][i] = '\0'; + } + } + } + + if(status == LDAP_SUCCESS) + status = ldap_search_s(ld, ebase ? ebase : "", scope, + efilter ? efilter : "(objectclass=*)", + eattrs, attrsonly, res); + + if(eattrs) { + for(j = 0; eattrs[j]; j++) + free(eattrs[j]); + + free(eattrs); + } + + free(efilter); + free(ebase); + return status; +} + +struct berval **Curl_ldap_get_values_len_a(void *ld, LDAPMessage *entry, + const char *attr) +{ + char *cp; + struct berval **result; + + cp = (char *)NULL; + + if(attr) { + int i = strlen(attr); + + cp = malloc(i + 1); + if(!cp) { + ldap_set_lderrno(ld, LDAP_NO_MEMORY, NULL, + ldap_err2string(LDAP_NO_MEMORY)); + return (struct berval **)NULL; + } + + QadrtConvertA2E(cp, attr, i, i); + cp[i] = '\0'; + } + + result = ldap_get_values_len(ld, entry, cp); + free(cp); + + /* Result data are binary in nature, so they have not been + converted to EBCDIC. Therefore do not convert. */ + + return result; +} + +char *Curl_ldap_err2string_a(int error) +{ + return set_thread_string(LK_LDAP_ERROR, ldap_err2string(error)); +} + +char *Curl_ldap_get_dn_a(void *ld, LDAPMessage *entry) +{ + int i; + char *cp; + char *cp2; + + cp = ldap_get_dn(ld, entry); + + if(!cp) + return cp; + + i = strlen(cp); + + cp2 = malloc(i + 1); + if(!cp2) + return cp2; + + QadrtConvertE2A(cp2, cp, i, i); + + /* No way to allocate a buffer here, because it will be released by + ldap_memfree() and ldap_memalloc() does not exist. The solution is to + overwrite the EBCDIC buffer with ASCII to return it. + + The destination buffer already has a null-terminator at the correct + position. Keep it outouched and copy the buffer without a terminator. */ + memcpy(cp, cp2, i); + free(cp2); + return cp; +} + +char *Curl_ldap_first_attribute_a(void *ld, LDAPMessage *entry, + BerElement **berptr) +{ + int i; + char *cp; + char *cp2; + + cp = ldap_first_attribute(ld, entry, berptr); + + if(!cp) + return cp; + + i = strlen(cp); + + cp2 = malloc(i + 1); + if(!cp2) + return cp2; + + QadrtConvertE2A(cp2, cp, i, i); + + /* No way to allocate a buffer here, because it will be released by + ldap_memfree() and ldap_memalloc() does not exist. The solution is to + overwrite the EBCDIC buffer with ASCII to return it. + + The destination buffer already has a null-terminator at the correct + position. Keep it outouched and copy the buffer without a terminator. */ + memcpy(cp, cp2, i); + free(cp2); + return cp; +} + +char *Curl_ldap_next_attribute_a(void *ld, LDAPMessage *entry, + BerElement *berptr) +{ + int i; + char *cp; + char *cp2; + + cp = ldap_next_attribute(ld, entry, berptr); + + if(!cp) + return cp; + + i = strlen(cp); + + cp2 = malloc(i + 1); + if(!cp2) + return cp2; + + QadrtConvertE2A(cp2, cp, i, i); + + /* No way to allocate a buffer here, because it will be released by + ldap_memfree() and ldap_memalloc() does not exist. The solution is to + overwrite the EBCDIC buffer with ASCII to return it. + + The destination buffer already has a null-terminator at the correct + position. Keep it outouched and copy the buffer without a terminator. */ + memcpy(cp, cp2, i); + free(cp2); + return cp; +} + +#endif /* CURL_DISABLE_LDAP */ + +static int sockaddr2ebcdic(struct sockaddr_storage *dstaddr, + const struct sockaddr *srcaddr, int srclen) +{ + const struct sockaddr_un *srcu; + struct sockaddr_un *dstu; + unsigned int i; + unsigned int dstsize; + + /* Convert a socket address to job CCSID, if needed. */ + + if(!srcaddr || srclen < offsetof(struct sockaddr, sa_family) + + sizeof(srcaddr->sa_family) || srclen > sizeof(*dstaddr)) { + /* !checksrc! disable ERRNOVAR 1 */ + errno = EINVAL; + return -1; + } + + memcpy((char *)dstaddr, (char *)srcaddr, srclen); + + switch(srcaddr->sa_family) { + + case AF_UNIX: + srcu = (const struct sockaddr_un *)srcaddr; + dstu = (struct sockaddr_un *)dstaddr; + dstsize = sizeof(*dstaddr) - offsetof(struct sockaddr_un, sun_path); + srclen -= offsetof(struct sockaddr_un, sun_path); + i = QadrtConvertA2E(dstu->sun_path, srcu->sun_path, dstsize - 1, srclen); + dstu->sun_path[i] = '\0'; + srclen = i + offsetof(struct sockaddr_un, sun_path); + } + + return srclen; +} + +static int sockaddr2ascii(struct sockaddr *dstaddr, int dstlen, + const struct sockaddr_storage *srcaddr, int srclen) +{ + const struct sockaddr_un *srcu; + struct sockaddr_un *dstu; + unsigned int dstsize; + + /* Convert a socket address to ASCII, if needed. */ + + if(!srclen) + return 0; + if(srclen > dstlen) + srclen = dstlen; + if(!srcaddr || srclen < 0) { + /* !checksrc! disable ERRNOVAR 1 */ + errno = EINVAL; + return -1; + } + + memcpy((char *)dstaddr, (char *)srcaddr, srclen); + + if(srclen >= offsetof(struct sockaddr_storage, ss_family) + + sizeof(srcaddr->ss_family)) { + switch(srcaddr->ss_family) { + + case AF_UNIX: + srcu = (const struct sockaddr_un *)srcaddr; + dstu = (struct sockaddr_un *)dstaddr; + dstsize = dstlen - offsetof(struct sockaddr_un, sun_path); + srclen -= offsetof(struct sockaddr_un, sun_path); + if(dstsize > 0 && srclen > 0) { + srclen = QadrtConvertE2A(dstu->sun_path, srcu->sun_path, + dstsize - 1, srclen); + dstu->sun_path[srclen] = '\0'; + } + srclen += offsetof(struct sockaddr_un, sun_path); + } + } + + return srclen; +} + +int Curl_os400_connect(int sd, struct sockaddr *destaddr, int addrlen) +{ + int i; + struct sockaddr_storage laddr; + + i = sockaddr2ebcdic(&laddr, destaddr, addrlen); + + if(i < 0) + return -1; + + return connect(sd, (struct sockaddr *)&laddr, i); +} + +int Curl_os400_bind(int sd, struct sockaddr *localaddr, int addrlen) +{ + int i; + struct sockaddr_storage laddr; + + i = sockaddr2ebcdic(&laddr, localaddr, addrlen); + + if(i < 0) + return -1; + + return bind(sd, (struct sockaddr *)&laddr, i); +} + +int Curl_os400_sendto(int sd, char *buffer, int buflen, int flags, + const struct sockaddr *dstaddr, int addrlen) +{ + int i; + struct sockaddr_storage laddr; + + i = sockaddr2ebcdic(&laddr, dstaddr, addrlen); + + if(i < 0) + return -1; + + return sendto(sd, buffer, buflen, flags, (struct sockaddr *)&laddr, i); +} + +int Curl_os400_recvfrom(int sd, char *buffer, int buflen, int flags, + struct sockaddr *fromaddr, int *addrlen) +{ + int rcvlen; + struct sockaddr_storage laddr; + int laddrlen = sizeof(laddr); + + if(!fromaddr || !addrlen || *addrlen <= 0) + return recvfrom(sd, buffer, buflen, flags, fromaddr, addrlen); + + laddr.ss_family = AF_UNSPEC; /* To detect if unused. */ + rcvlen = recvfrom(sd, buffer, buflen, flags, + (struct sockaddr *)&laddr, &laddrlen); + + if(rcvlen < 0) + return rcvlen; + + if(laddr.ss_family == AF_UNSPEC) + laddrlen = 0; + else { + laddrlen = sockaddr2ascii(fromaddr, *addrlen, &laddr, laddrlen); + if(laddrlen < 0) + return laddrlen; + } + *addrlen = laddrlen; + return rcvlen; +} + +int Curl_os400_getpeername(int sd, struct sockaddr *addr, int *addrlen) +{ + struct sockaddr_storage laddr; + int laddrlen = sizeof(laddr); + int retcode = getpeername(sd, (struct sockaddr *)&laddr, &laddrlen); + + if(!retcode) { + laddrlen = sockaddr2ascii(addr, *addrlen, &laddr, laddrlen); + if(laddrlen < 0) + return laddrlen; + *addrlen = laddrlen; + } + + return retcode; +} + +int Curl_os400_getsockname(int sd, struct sockaddr *addr, int *addrlen) +{ + struct sockaddr_storage laddr; + int laddrlen = sizeof(laddr); + int retcode = getsockname(sd, (struct sockaddr *)&laddr, &laddrlen); + + if(!retcode) { + laddrlen = sockaddr2ascii(addr, *addrlen, &laddr, laddrlen); + if(laddrlen < 0) + return laddrlen; + *addrlen = laddrlen; + } + + return retcode; +} + +#ifdef HAVE_LIBZ +const char *Curl_os400_zlibVersion(void) +{ + return set_thread_string(LK_ZLIB_VERSION, zlibVersion()); +} + +int Curl_os400_inflateInit_(z_streamp strm, const char *version, + int stream_size) +{ + z_const char *msgb4 = strm->msg; + int ret; + + ret = inflateInit(strm); + + if(strm->msg != msgb4) + strm->msg = set_thread_string(LK_ZLIB_MSG, strm->msg); + + return ret; +} + +int Curl_os400_inflateInit2_(z_streamp strm, int windowBits, + const char *version, int stream_size) +{ + z_const char *msgb4 = strm->msg; + int ret; + + ret = inflateInit2(strm, windowBits); + + if(strm->msg != msgb4) + strm->msg = set_thread_string(LK_ZLIB_MSG, strm->msg); + + return ret; +} + +int Curl_os400_inflate(z_streamp strm, int flush) +{ + z_const char *msgb4 = strm->msg; + int ret; + + ret = inflate(strm, flush); + + if(strm->msg != msgb4) + strm->msg = set_thread_string(LK_ZLIB_MSG, strm->msg); + + return ret; +} + +int Curl_os400_inflateEnd(z_streamp strm) +{ + z_const char *msgb4 = strm->msg; + int ret; + + ret = inflateEnd(strm); + + if(strm->msg != msgb4) + strm->msg = set_thread_string(LK_ZLIB_MSG, strm->msg); + + return ret; +} + +#endif diff --git a/3rdparty/curl-8.21.0/projects/OS400/os400sys.h b/3rdparty/curl-8.21.0/projects/OS400/os400sys.h new file mode 100644 index 0000000000..eb2cdb828a --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/OS400/os400sys.h @@ -0,0 +1,54 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + * + ***************************************************************************/ + +/* OS/400 additional definitions. */ + +#ifndef __OS400_SYS_ +#define __OS400_SYS_ + +/* Per-thread item identifiers. */ + +typedef enum { + LK_GSK_ERROR, + LK_LDAP_ERROR, + LK_CURL_VERSION, + LK_VERSION_INFO, + LK_VERSION_INFO_DATA, + LK_EASY_STRERROR, + LK_SHARE_STRERROR, + LK_MULTI_STRERROR, + LK_URL_STRERROR, + LK_ZLIB_VERSION, + LK_ZLIB_MSG, + LK_LAST +} localkey_t; + +extern char *(*Curl_thread_buffer)(localkey_t key, long size); + +/* Maximum string expansion factor due to character code conversion. */ + +#define MAX_CONV_EXPANSION 4 /* Can deal with UTF-8. */ + +#endif diff --git a/3rdparty/curl-8.21.0/projects/OS400/rpg-examples/HEADERAPI b/3rdparty/curl-8.21.0/projects/OS400/rpg-examples/HEADERAPI new file mode 100644 index 0000000000..f6ef80bbd4 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/OS400/rpg-examples/HEADERAPI @@ -0,0 +1,146 @@ + * curl header API: extract headers post transfer + * + h DFTACTGRP(*NO) ACTGRP(*NEW) + h OPTION(*NOSHOWCPY) + h BNDDIR('CURL') + * + ************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF + * ANY KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ************************************************************************** + * + /include H,CURL.INC + * + * Extract headers post transfer with the header API. + * + d pi + d url 120 + * + d urllen s 10u 0 URL length + * + ************************************************************************** + + urllen = trimmed_length(url: %len(url)); + + // Do the curl stuff. + + curl_global_init(CURL_GLOBAL_ALL); + main(); + curl_global_cleanup(); + *inlr = *on; // Exit + * + ************************************************************************** + * Main procedure: do the curl job. + ************************************************************************** + * + p main b + d main pi + * + d h s * Easy handle + d result s like(CURLcode) Curl return code + d inz(CURLE_OUT_OF_MEMORY) + d header ds likeds(curl_header) based(hp) + d strp1 s * Work string pointer + d strp2 s * Work string pointer + d inout s 52 For error display + + // Create and fill curl handle. + + h = curl_easy_init(); + if h <> *NULL; + curl_easy_setopt_ccsid(h: CURLOPT_URL: %subst(url: 1: urllen): 0); + curl_easy_setopt(h: CURLOPT_FOLLOWLOCATION: 1); + curl_easy_setopt(h: CURLOPT_WRITEFUNCTION: %paddr(in_data_cb)); // Ignore input data + + // Perform the request. + + result = curl_easy_perform(h); + endif; + + // Check for error and report if some. + + if result <> CURLE_OK; + inout = %str(curl_easy_strerror_ccsid(result: 0)); + dsply '' '*EXT' inout; + else; + if curl_easy_header_ccsid(h: 'Content-Type': 0: CURLH_HEADER: -1: + hp: 0) = CURLHE_OK; + strp2 = curl_to_ccsid(header.value: 0); + inout = 'Content-Type: ' + %str(strp2); + dsply inout; + curl_free(strp2); + endif; + dsply ' All server headers:'; + hp = *NULL; + dow *on; + hp = curl_easy_nextheader(h: CURLH_HEADER: -1: hp); + if hp = *NULL; + leave; + endif; + strp1 = curl_to_ccsid(header.name: 0); + strp2 = curl_to_ccsid(header.value: 0); + inout = %str(strp1) + ': ' + %str(strp2) + + ' (' + %char(header.amount) + ')'; + curl_free(strp2); + curl_free(strp1); + dsply inout; + enddo; + inout = 'Done'; + dsply '' '*EXT' inout; + curl_easy_cleanup(h); // Release handle + endif; + p main e + * + ************************************************************************** + * Dummy data input callback procedure. + ************************************************************************** + * + p in_data_cb b + d in_data_cb pi 10u 0 + d ptr * value Input data pointer + d size 10u 0 value Data element size + d nmemb 10u 0 value Data element count + d userdata * value User data pointer + * + return size * nmemb; + p in_data_cb e + * + ************************************************************************** + * Get the length of right-trimmed string + ************************************************************************** + * + p trimmed_length b + d trimmed_length pi 10u 0 + d string 999999 const options(*varsize) + d length 10u 0 value + * + d len s 10u 0 + * + len = %scan(X'00': string: 1: length); // Limit to null-terminated string + if len = 0; + len = length + 1; + endif; + if len <= 1; + return 0; + endif; + return %checkr(' ': string: len - 1); // Trim right + p trimmed_length e diff --git a/3rdparty/curl-8.21.0/projects/OS400/rpg-examples/HTTPPOST b/3rdparty/curl-8.21.0/projects/OS400/rpg-examples/HTTPPOST new file mode 100644 index 0000000000..8e5d0d74bb --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/OS400/rpg-examples/HTTPPOST @@ -0,0 +1,129 @@ + * curl MIME post data and display response + * + h DFTACTGRP(*NO) ACTGRP(*NEW) + h OPTION(*NOSHOWCPY) + h BNDDIR('CURL') + * + ************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF + * ANY KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ************************************************************************** + * + /include H,CURL.INC + * + * Example to HTTP POST data using the MIME API. Displays the response. + * + d pi + d userinput 120 User data to post + * + d url c 'http://httpbin.org/anything' + * + * + d inputlen s 10u 0 User input length + ************************************************************************** + + inputlen = trimmed_length(userinput: %len(userinput)); + + // Do the curl stuff. + + curl_global_init(CURL_GLOBAL_ALL); + main(); + curl_global_cleanup(); + *inlr = *on; // Exit + * + ************************************************************************** + * Main procedure: do the curl job. + ************************************************************************** + * + p main b + d main pi + * + d h s * Easy handle + d result s like(CURLcode) Curl return code + d inz(CURLE_OUT_OF_MEMORY) + d errmsgp s * Error string pointer + d response s 52 For error display + d mime s * MIME handle + d mimepart s * MIME part handle + d parthdrs s * inz(*NULL) Part headers + + // Create and fill curl handle. + + h = curl_easy_init(); + if h <> *NULL; + curl_easy_setopt_ccsid(h: CURLOPT_URL: url: 0); + curl_easy_setopt(h: CURLOPT_FOLLOWLOCATION: 1); + mime = curl_mime_init(h); + mimepart = curl_mime_addpart(mime); + curl_mime_name_ccsid(mimepart: 'autofield': 0); + curl_mime_data_ccsid(mimepart: 'program-generated value': + CURL_ZERO_TERMINATED: 0); + mimepart = curl_mime_addpart(mime); + curl_mime_name_ccsid(mimepart: 'userfield': 0); + curl_mime_data_ccsid(mimepart: %subst(userinput: 1: inputlen): + CURL_ZERO_TERMINATED: 0); + mimepart = curl_mime_addpart(mime); + curl_mime_name_ccsid(mimepart: 'ebcdicfield': 0); + curl_mime_data(mimepart: %subst(userinput: 1: inputlen): inputlen); + curl_mime_encoder_ccsid(mimepart: 'base64': 0); + // Avoid server to convert base64 to text. + parthdrs = curl_slist_append_ccsid(parthdrs: + 'Content-Transfer-Encoding: bit': 0); + curl_mime_headers(mimepart: parthdrs: 1); + curl_easy_setopt(h: CURLOPT_MIMEPOST: mime); + + // Perform the request. + + result = curl_easy_perform(h); + curl_mime_free(mime); + curl_easy_cleanup(h); // Release handle + endif; + + // Check for error and report if some. + + if result <> CURLE_OK; + errmsgp = curl_easy_strerror_ccsid(result: 0); + response = %str(errmsgp); + dsply '' '*EXT' response; + endif; + p main e + * + ************************************************************************** + * Get the length of right-trimmed string + ************************************************************************** + * + p trimmed_length b + d trimmed_length pi 10u 0 + d string 999999 const options(*varsize) + d length 10u 0 value + * + d len s 10u 0 + * + len = %scan(X'00': string: 1: length); // Limit to null-terminated string + if len = 0; + len = length + 1; + endif; + if len <= 1; + return 0; + endif; + return %checkr(' ': string: len - 1); // Trim right + p trimmed_length e diff --git a/3rdparty/curl-8.21.0/projects/OS400/rpg-examples/INMEMORY b/3rdparty/curl-8.21.0/projects/OS400/rpg-examples/INMEMORY new file mode 100644 index 0000000000..7111d565e9 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/OS400/rpg-examples/INMEMORY @@ -0,0 +1,159 @@ + * curl get in memory and count HTML tags + * + h DFTACTGRP(*NO) ACTGRP(*NEW) + h OPTION(*NOSHOWCPY) + h BNDDIR('CURL') + * + ************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF + * ANY KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ************************************************************************** + * + /include H,CURL.INC + * + * Example to request the URL given as command line parameter and count + * HTML tags in its response. + * + d pi + d url 120 + * + d countdata ds qualified based(###dummyptr) User data type + d tagcount 10u 0 Tag counter + d tagopen n Possible opening tag + * + d urllen s 10u 0 URL length + * + ************************************************************************** + + urllen = trimmed_length(url: %len(url)); + + // Do the curl stuff. + + curl_global_init(CURL_GLOBAL_ALL); + main(); + curl_global_cleanup(); + *inlr = *on; // Exit + * + ************************************************************************** + * Main procedure: do the curl job. + ************************************************************************** + * + p main b + d main pi + * + d h s * Easy handle + d result s like(CURLcode) Curl return code + d inz(CURLE_OUT_OF_MEMORY) + d errmsgp s * Error string pointer + d response s 52 For error display + d counter ds likeds(countdata) HTML tag counter + + counter.tagcount = 0; + counter.tagopen = *off; + + // Create and fill curl handle. + + h = curl_easy_init(); + if h <> *NULL; + curl_easy_setopt_ccsid(h: CURLOPT_URL: %subst(url: 1: urllen): 0); + curl_easy_setopt(h: CURLOPT_FOLLOWLOCATION: 1); + curl_easy_setopt(h: CURLOPT_WRITEFUNCTION: %paddr(in_data_cb)); + curl_easy_setopt(h: CURLOPT_WRITEDATA: %addr(counter)); + + // Perform the request. + + result = curl_easy_perform(h); + curl_easy_cleanup(h); // Release handle + endif; + + // Check for error and report if some. + + if result <> CURLE_OK; + errmsgp = curl_easy_strerror_ccsid(result: 0); + response = %str(errmsgp); + dsply '' '*EXT' response; + else; + // Display the tag count. + + response = 'Tag count: ' + %char(counter.tagcount); + dsply '' '*EXT' response; + endif; + p main e + * + ************************************************************************** + * Data input callback procedure. + ************************************************************************** + * + p in_data_cb b + d in_data_cb pi 10u 0 + d ptr * value Input data pointer + d size 10u 0 value Data element size + d nmemb 10u 0 value Data element count + d userdata * value User data pointer + * + d counter ds likeds(countdata) based(userdata) HTML tag counter + d ebcdata s * EBCDIC data pointer + d chars s 1 based(ebcdata) dim(1000000) + d i s 10u 0 Character position + * + size = size * nmemb; // The size in bytes. + ebcdata = curl_to_ccsid(%str(ptr: size): 0); // Convert to EBCDIC. + i = 1; + dow i <= size; + if counter.tagopen; // Did we see '<' ? + counter.tagopen = *off; + if chars(i) <> '/'; // Reject closing tag. + counter.tagcount = counter.tagcount + 1; // Count this tag. + endif; + else; + i = %scan('<': %str(ebcdata): i); // Search next possible tag. + if i = 0; + leave; + endif; + counter.tagopen = *on; // Found one: flag it. + endif; + i = i + 1; + enddo; + curl_free(ebcdata); + return size; + p in_data_cb e + * + ************************************************************************** + * Get the length of right-trimmed string + ************************************************************************** + * + p trimmed_length b + d trimmed_length pi 10u 0 + d string 999999 const options(*varsize) + d length 10u 0 value + * + d len s 10u 0 + * + len = %scan(X'00': string: 1: length); // Limit to null-terminated string + if len = 0; + len = length + 1; + endif; + if len <= 1; + return 0; + endif; + return %checkr(' ': string: len - 1); // Trim right + p trimmed_length e diff --git a/3rdparty/curl-8.21.0/projects/OS400/rpg-examples/SIMPLE1 b/3rdparty/curl-8.21.0/projects/OS400/rpg-examples/SIMPLE1 new file mode 100644 index 0000000000..2d2296ed40 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/OS400/rpg-examples/SIMPLE1 @@ -0,0 +1,108 @@ + * curl simple URL request + * + h DFTACTGRP(*NO) ACTGRP(*NEW) + h OPTION(*NOSHOWCPY) + h BNDDIR('CURL') + * + ************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF + * ANY KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ************************************************************************** + * + /include H,CURL.INC + * + * Simple example to request the URL given as command line parameter and + * output its response. + * + d pi + d url 120 + * + d urllen s 10u 0 URL length + * + ************************************************************************** + * + c eval urllen = trimmed_length(url: %len(url)) + * + * Do the curl stuff. + * + c callp curl_global_init(CURL_GLOBAL_ALL) + c callp main + c callp curl_global_cleanup() + c seton lr Exit + * + ************************************************************************** + * Main procedure: do the curl job. + ************************************************************************** + * + p main b + d main pi + * + d h s * Easy handle + d result s like(CURLcode) Curl return code + d inz(CURLE_OUT_OF_MEMORY) + d errmsgp s * Error string pointer + d response s 52 For error display + * + * Create and fill curl handle. + * + c eval h = curl_easy_init() + c if h <> *NULL + c callp curl_easy_setopt_ccsid(h: CURLOPT_URL: + c %subst(url: 1: urllen): 0) + c callp curl_easy_setopt_long(h: + c CURLOPT_FOLLOWLOCATION: 1) + * + * Perform the request. + * + c eval result = curl_easy_perform(h) + c callp curl_easy_cleanup(h) Release handle + c endif + * + * Check for error and report if some. + * + c if result <> CURLE_OK + c eval errmsgp = curl_easy_strerror_ccsid(result: 0) + c eval response = %str(errmsgp) + c dsply response + c endif + p main e + * + ************************************************************************** + * Get the length of right-trimmed string + ************************************************************************** + * + p trimmed_length b + d trimmed_length pi 10u 0 + d string 999999 const options(*varsize) + d length 10u 0 value + * + d len s 10u 0 + * + c eval len = %scan(X'00': string: 1: length) Limit null-terminated + c if len = 0 + c eval len = length + 1 + c endif + c if len <= 1 + c return 0 + c endif + c return %checkr(' ': string: len - 1) Trim right + p trimmed_length e diff --git a/3rdparty/curl-8.21.0/projects/OS400/rpg-examples/SIMPLE2 b/3rdparty/curl-8.21.0/projects/OS400/rpg-examples/SIMPLE2 new file mode 100644 index 0000000000..2fead8517c --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/OS400/rpg-examples/SIMPLE2 @@ -0,0 +1,108 @@ + * curl simple URL request (free-format RPG) + * + ctl-opt dftactgrp(*NO) actgrp(*NEW) + option(*NOSHOWCPY) + bnddir('CURL'); + * + ************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF + * ANY KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ************************************************************************** + + /include H,CURL.INC + + * Simple free-format RPG program to request the URL given as command line + * parameter and output its response. + + dcl-pi *N; + url char(120); + end-pi; + + dcl-s urllen int(10); // URL length + + ************************************************************************** + + urllen = trimmed_length(url: %len(url)); + + // Do the curl stuff. + + curl_global_init(CURL_GLOBAL_ALL); + main(); + curl_global_cleanup(); + *inlr = *on; // Exit + + ************************************************************************** + * Main procedure: do the curl job. + ************************************************************************** + + dcl-proc main; + dcl-pi *N end-pi; + + dcl-s h pointer; // Easy handle + dcl-s result like(CURLcode) inz(CURLE_OUT_OF_MEMORY); // Curl return code + dcl-s errmsgp pointer; // Error string pointer + dcl-s response char(52); // For error display + + // Create and fill curl handle. + + h = curl_easy_init(); + if h <> *NULL; + curl_easy_setopt_ccsid(h: CURLOPT_URL: %subst(url: 1: urllen): + 0); + curl_easy_setopt(h: CURLOPT_FOLLOWLOCATION: 1); + + // Perform the request. + + result = curl_easy_perform(h); + curl_easy_cleanup(h); // Release handle + endif; + + // Check for error and report if some. + + if result <> CURLE_OK; + errmsgp = curl_easy_strerror_ccsid(result: 0); + response = %str(errmsgp); + dsply '' '*EXT' response; + endif; + end-proc; + * + ************************************************************************** + * Get the length of right-trimmed string + ************************************************************************** + * + dcl-proc trimmed_length; + dcl-pi *N uns(10); + string char(9999999) const options(*varsize); + length uns(10) value; + end-pi; + + dcl-s len uns(10); + + len = %scan(X'00': string: 1: length); // Limit to null-terminated string + if len = 0; + len = length + 1; + endif; + if len <= 1; + return 0; + endif; + return %checkr(' ': string: len - 1); // Trim right + end-proc; diff --git a/3rdparty/curl-8.21.0/projects/OS400/rpg-examples/SMTPSRCMBR b/3rdparty/curl-8.21.0/projects/OS400/rpg-examples/SMTPSRCMBR new file mode 100644 index 0000000000..7e3a3fce6c --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/OS400/rpg-examples/SMTPSRCMBR @@ -0,0 +1,239 @@ + * curl SMTP send source member as attachment + * + h DFTACTGRP(*NO) ACTGRP(*NEW) + h OPTION(*NOSHOWCPY) + h BNDDIR('CURL') + * + ************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF + * ANY KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ************************************************************************** + * + /include H,CURL.INC + * + * Example to SMTP send source member as attachment via SMTP. + * + fRPGXAMPLESif e disk extmbr(program_name) + f rename(RPGXAMPLES: record) + d pi + d url 60 SMTP server URL + d recipient_mail 40 Recipient mail addr + * + d program_name c 'SMTPSRCMBR' Member name to send + d sender_name c 'Curl' Sender name + d sender_mail c 'curl@example.com' Sender e-mail + d recipient_name c 'WIMC' Recipient name + d crlf c X'0D25' + * + d urllen s 10u 0 URL length + d rcptmlen s 10u 0 Recipient mail len + * + ************************************************************************** + + urllen = trimmed_length(url: %len(url)); + rcptmlen = trimmed_length(recipient_mail: %len(recipient_mail)); + + // Do the curl stuff. + + curl_global_init(CURL_GLOBAL_ALL); + main(); + curl_global_cleanup(); + *inlr = *on; // Exit + * + ************************************************************************** + * Main procedure: do the curl job. + ************************************************************************** + * + p main b + d main pi + * + d h s * Easy handle + d result s like(CURLcode) Curl return code + d inz(CURLE_OUT_OF_MEMORY) + d errmsgp s * Error string pointer + d response s 52 For error display + d headers s * inz(*NULL) Mail headers + d rcpts s * inz(*NULL) List of recipients + d mime s * Mail MIME structure + d mimepart s * Mail part + + // Create and fill curl handle. + + h = curl_easy_init(); + if h <> *NULL; + rcpts = curl_slist_append_ccsid(rcpts: + %subst(recipient_mail: 1: rcptmlen): 0); + headers = curl_slist_append_ccsid(headers: 'From: ' + sender_name + + ' <' + sender_mail + '>': + 0); + headers = curl_slist_append_ccsid(headers: 'To: ' + recipient_name + + ' <' + %subst(recipient_mail: 1: rcptmlen) + '>': 0); + headers = curl_slist_append_ccsid(headers: 'Subject: An ILE/RPG ' + + 'source program': 0); + headers = curl_slist_append_ccsid(headers: 'Date: ' + mail_date(): + 0); + curl_easy_setopt_ccsid(h: CURLOPT_URL: %subst(url: 1: urllen): 0); + curl_easy_setopt_ccsid(h: CURLOPT_MAIL_FROM: sender_mail: 0); + curl_easy_setopt(h: CURLOPT_MAIL_RCPT: rcpts); + curl_easy_setopt(h: CURLOPT_HTTPHEADER: headers); + mime = curl_mime_init(h); + mimepart = curl_mime_addpart(mime); + curl_mime_data_ccsid(mimepart: 'Please find the ILE/RPG program ' + + program_name + ' source code in ' + + 'attachment.' + crlf: + CURL_ZERO_TERMINATED: 0); + mimepart = curl_mime_addpart(mime); + curl_mime_data_cb(mimepart: -1: %paddr(out_data_cb): *NULL: *NULL: + *NULL); + curl_mime_filename_ccsid(mimepart: program_name: 0); + curl_mime_encoder_ccsid(mimepart: 'quoted-printable': 0); + curl_easy_setopt(h: CURLOPT_MIMEPOST: mime); + + // Perform the request. + + setll *start RPGXAMPLES; + result = curl_easy_perform(h); + + // Cleanup. + + curl_mime_free(mime); + curl_slist_free_all(headers); + curl_slist_free_all(rcpts); + curl_easy_cleanup(h); // Release handle + endif; + + // Check for error and report if some. + + if result <> CURLE_OK; + errmsgp = curl_easy_strerror_ccsid(result: 0); + response = %str(errmsgp); + dsply '' '*EXT' response; + else; + response = 'Mail sent'; + dsply '' '*EXT' response; + endif; + p main e + * + ************************************************************************** + * Attachment data callback procedure. + ************************************************************************** + * + p out_data_cb b + d out_data_cb pi 10u 0 + d ptr * value Output data pointer + d size 10u 0 value Data element size + d nmemb 10u 0 value Data element count + d userdata * value User data pointer + * + d buffer s 9999999 based(ptr) Output buffer + d line s 9999999 based(lineptr) ASCII line pointer + d linelen s 10u 0 + d i s 10u 0 Buffer position + * + size = size * nmemb; // The size in bytes. + i = 0; + dow size - i >= %len(SRCDTA) + %len(crlf) and not %eof(RPGXAMPLES); + read record; + lineptr = curl_from_ccsid(%trimr(SRCDTA) + crlf: 0); + linelen = %scan(X'00': line) - 1; + %subst(buffer: i + 1: linelen) = %str(lineptr); + curl_free(lineptr); + i = i + linelen; + enddo; + return i; + p out_data_cb e + * + ************************************************************************** + * Mail-formatted date procedure. + ************************************************************************** + * + p mail_date b + d mail_date pi 50 varying + * + d sysval ds qualified To retrieve timezone + d numsysval 10u 0 + d offset 10u 0 + d 100 + * + d get_sysval pr extpgm('QWCRSVAL') + d outdata likeds(sysval) + d outsize 10u 0 const + d numsysval 10u 0 const + d name 10 const + d errcode 10000 options(*varsize) + * + d now ds qualified + d ts z + d year 4s 0 overlay(ts: 1) + d month 2s 0 overlay(ts: 6) + d day 2s 0 overlay(ts: 9) + d hour 2s 0 overlay(ts: 12) + d minute 2 overlay(ts: 15) + d second 2 overlay(ts: 18) + * + d sysvalinfo ds qualified based(sysvalinfoptr) + d name 10 + d type 1 + d status 1 + d length 10u 0 + d value 99999 + * + d qusec ds qualified + d 10u 0 inz(0) + * + d weekday s 10u 0 + * + now.ts = %timestamp(*SYS); + get_sysval(sysval: %len(sysval): 1: 'QUTCOFFSET': qusec); + sysvalinfoptr = %addr(sysval) + sysval.offset; + weekday = %rem(%diff(now.ts: %timestamp('2001-01-01-00.00.00.000000'): + *DAYS): 7); + return %subst('MonTueWedThuFriSatSun': 3 * weekday + 1: 3) + ', ' + + %char(now.day) + ' ' + + %subst('JanFebMarAprMayJunJulAugSepOctNovDec': + 3 * now.month - 2: 3) + ' ' + + %char(now.year) + ' ' + + %char(now.hour) + ':' + now.minute + ':' + now.second + ' ' + + %subst(sysvalinfo.value: 1: sysvalinfo.length); + p mail_date e + * + ************************************************************************** + * Get the length of right-trimmed string + ************************************************************************** + * + p trimmed_length b + d trimmed_length pi 10u 0 + d string 999999 const options(*varsize) + d length 10u 0 value + * + d addrdiff s 10i 0 + d len s 10u 0 + * + len = %scan(X'00': string: 1: length); // Limit to null-terminated string + if len = 0; + len = length + 1; + endif; + if len <= 1; + return 0; + endif; + return %checkr(' ': string: len - 1); // Trim right + p trimmed_length e diff --git a/3rdparty/curl-8.21.0/projects/README.md b/3rdparty/curl-8.21.0/projects/README.md new file mode 100644 index 0000000000..802a78f86a --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/README.md @@ -0,0 +1,12 @@ + + +# Packages + +This directory and all its subdirectories are for special package +information, templates, scripts and docs. The files herein should be of +use for those of you who want to package curl in a binary or source +format for these platforms. diff --git a/3rdparty/curl-8.21.0/projects/vms/Makefile.am b/3rdparty/curl-8.21.0/projects/vms/Makefile.am new file mode 100644 index 0000000000..0a061bf20b --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/Makefile.am @@ -0,0 +1,59 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +EXTRA_DIST = \ + backup_gnv_curl_src.com \ + build_curl-config_script.com \ + build_gnv_curl.com \ + build_gnv_curl_pcsi_desc.com \ + build_gnv_curl_pcsi_text.com \ + build_gnv_curl_release_notes.com \ + build_libcurl_pc.com \ + build_vms.com \ + clean_gnv_curl.com \ + compare_curl_source.com \ + config_h.com \ + curl_crtl_init.c \ + curl_gnv_build_steps.txt \ + curl_release_note_start.txt \ + curl_startup.com \ + curlmsg.h \ + curlmsg.msg \ + curlmsg.sdl \ + curlmsg_vms.h \ + generate_config_vms_h_curl.com \ + generate_vax_transfer.com \ + gnv_conftest.c_first \ + gnv_curl_configure.sh \ + gnv_libcurl_symbols.opt \ + gnv_link_curl.com \ + macro32_exactcase.patch \ + make_gnv_curl_install.sh \ + make_pcsi_curl_kit_name.com \ + pcsi_gnv_curl_file_list.txt \ + pcsi_product_gnv_curl.com \ + readme \ + report_openssl_version.c \ + setup_gnv_curl_build.com \ + stage_curl_install.com \ + vms_eco_level.h diff --git a/3rdparty/curl-8.21.0/projects/vms/Makefile.in b/3rdparty/curl-8.21.0/projects/vms/Makefile.in new file mode 100644 index 0000000000..3b15b9b4c4 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/Makefile.in @@ -0,0 +1,569 @@ +# Makefile.in generated by automake 1.16.5 from Makefile.am. +# @configure_input@ + +# Copyright (C) 1994-2021 Free Software Foundation, Inc. + +# This Makefile.in is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY, to the extent permitted by law; without +# even the implied warranty of MERCHANTABILITY or FITNESS FOR A +# PARTICULAR PURPOSE. + +@SET_MAKE@ +VPATH = @srcdir@ +am__is_gnu_make = { \ + if test -z '$(MAKELEVEL)'; then \ + false; \ + elif test -n '$(MAKE_HOST)'; then \ + true; \ + elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \ + true; \ + else \ + false; \ + fi; \ +} +am__make_running_with_option = \ + case $${target_option-} in \ + ?) ;; \ + *) echo "am__make_running_with_option: internal error: invalid" \ + "target option '$${target_option-}' specified" >&2; \ + exit 1;; \ + esac; \ + has_opt=no; \ + sane_makeflags=$$MAKEFLAGS; \ + if $(am__is_gnu_make); then \ + sane_makeflags=$$MFLAGS; \ + else \ + case $$MAKEFLAGS in \ + *\\[\ \ ]*) \ + bs=\\; \ + sane_makeflags=`printf '%s\n' "$$MAKEFLAGS" \ + | sed "s/$$bs$$bs[$$bs $$bs ]*//g"`;; \ + esac; \ + fi; \ + skip_next=no; \ + strip_trailopt () \ + { \ + flg=`printf '%s\n' "$$flg" | sed "s/$$1.*$$//"`; \ + }; \ + for flg in $$sane_makeflags; do \ + test $$skip_next = yes && { skip_next=no; continue; }; \ + case $$flg in \ + *=*|--*) continue;; \ + -*I) strip_trailopt 'I'; skip_next=yes;; \ + -*I?*) strip_trailopt 'I';; \ + -*O) strip_trailopt 'O'; skip_next=yes;; \ + -*O?*) strip_trailopt 'O';; \ + -*l) strip_trailopt 'l'; skip_next=yes;; \ + -*l?*) strip_trailopt 'l';; \ + -[dEDm]) skip_next=yes;; \ + -[JT]) skip_next=yes;; \ + esac; \ + case $$flg in \ + *$$target_option*) has_opt=yes; break;; \ + esac; \ + done; \ + test $$has_opt = yes +am__make_dryrun = (target_option=n; $(am__make_running_with_option)) +am__make_keepgoing = (target_option=k; $(am__make_running_with_option)) +pkgdatadir = $(datadir)/@PACKAGE@ +pkgincludedir = $(includedir)/@PACKAGE@ +pkglibdir = $(libdir)/@PACKAGE@ +pkglibexecdir = $(libexecdir)/@PACKAGE@ +am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd +install_sh_DATA = $(install_sh) -c -m 644 +install_sh_PROGRAM = $(install_sh) -c +install_sh_SCRIPT = $(install_sh) -c +INSTALL_HEADER = $(INSTALL_DATA) +transform = $(program_transform_name) +NORMAL_INSTALL = : +PRE_INSTALL = : +POST_INSTALL = : +NORMAL_UNINSTALL = : +PRE_UNINSTALL = : +POST_UNINSTALL = : +build_triplet = @build@ +host_triplet = @host@ +subdir = projects/vms +ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 +am__aclocal_m4_deps = $(top_srcdir)/m4/curl-amissl.m4 \ + $(top_srcdir)/m4/curl-apple-sectrust.m4 \ + $(top_srcdir)/m4/curl-compilers.m4 \ + $(top_srcdir)/m4/curl-confopts.m4 \ + $(top_srcdir)/m4/curl-functions.m4 \ + $(top_srcdir)/m4/curl-gnutls.m4 \ + $(top_srcdir)/m4/curl-mbedtls.m4 \ + $(top_srcdir)/m4/curl-openssl.m4 \ + $(top_srcdir)/m4/curl-override.m4 \ + $(top_srcdir)/m4/curl-reentrant.m4 \ + $(top_srcdir)/m4/curl-rustls.m4 \ + $(top_srcdir)/m4/curl-schannel.m4 \ + $(top_srcdir)/m4/curl-sysconfig.m4 \ + $(top_srcdir)/m4/curl-wolfssl.m4 $(top_srcdir)/m4/libtool.m4 \ + $(top_srcdir)/m4/ltoptions.m4 $(top_srcdir)/m4/ltsugar.m4 \ + $(top_srcdir)/m4/ltversion.m4 $(top_srcdir)/m4/lt~obsolete.m4 \ + $(top_srcdir)/m4/xc-am-iface.m4 \ + $(top_srcdir)/m4/xc-cc-check.m4 \ + $(top_srcdir)/m4/xc-lt-iface.m4 \ + $(top_srcdir)/m4/xc-val-flgs.m4 \ + $(top_srcdir)/m4/zz40-xc-ovr.m4 \ + $(top_srcdir)/m4/zz50-xc-ovr.m4 $(top_srcdir)/acinclude.m4 \ + $(top_srcdir)/configure.ac +am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ + $(ACLOCAL_M4) +DIST_COMMON = $(srcdir)/Makefile.am $(am__DIST_COMMON) +mkinstalldirs = $(install_sh) -d +CONFIG_HEADER = $(top_builddir)/lib/curl_config.h +CONFIG_CLEAN_FILES = +CONFIG_CLEAN_VPATH_FILES = +AM_V_P = $(am__v_P_@AM_V@) +am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) +am__v_P_0 = false +am__v_P_1 = : +AM_V_GEN = $(am__v_GEN_@AM_V@) +am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@) +am__v_GEN_0 = @echo " GEN " $@; +am__v_GEN_1 = +AM_V_at = $(am__v_at_@AM_V@) +am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) +am__v_at_0 = @ +am__v_at_1 = +SOURCES = +DIST_SOURCES = +am__can_run_installinfo = \ + case $$AM_UPDATE_INFO_DIR in \ + n|no|NO) false;; \ + *) (install-info --version) >/dev/null 2>&1;; \ + esac +am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) $(LISP) +am__DIST_COMMON = $(srcdir)/Makefile.in +DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) +ACLOCAL = @ACLOCAL@ +AMTAR = @AMTAR@ +AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ +APXS = @APXS@ +AR = @AR@ +AR_FLAGS = @AR_FLAGS@ +AS = @AS@ +AUTOCONF = @AUTOCONF@ +AUTOHEADER = @AUTOHEADER@ +AUTOMAKE = @AUTOMAKE@ +AWK = @AWK@ +BLANK_AT_MAKETIME = @BLANK_AT_MAKETIME@ +CADDY = @CADDY@ +CC = @CC@ +CCDEPMODE = @CCDEPMODE@ +CFLAGS = @CFLAGS@ +CFLAG_CURL_SYMBOL_HIDING = @CFLAG_CURL_SYMBOL_HIDING@ +CLANG_TIDY = @CLANG_TIDY@ +CONFIGURE_OPTIONS = @CONFIGURE_OPTIONS@ +CPP = @CPP@ +CPPFLAGS = @CPPFLAGS@ +CSCOPE = @CSCOPE@ +CTAGS = @CTAGS@ +CURLVERSION = @CURLVERSION@ +CURL_CA_BUNDLE = @CURL_CA_BUNDLE@ +CURL_CA_EMBED = @CURL_CA_EMBED@ +CURL_CFLAG_EXTRAS = @CURL_CFLAG_EXTRAS@ +CURL_CPP = @CURL_CPP@ +CURL_LIBCURL_VERSIONED_SYMBOLS_PREFIX = @CURL_LIBCURL_VERSIONED_SYMBOLS_PREFIX@ +CURL_LIBCURL_VERSIONED_SYMBOLS_SONAME = @CURL_LIBCURL_VERSIONED_SYMBOLS_SONAME@ +CURL_NETWORK_AND_TIME_LIBS = @CURL_NETWORK_AND_TIME_LIBS@ +CYGPATH_W = @CYGPATH_W@ +DANTED = @DANTED@ +DEFS = @DEFS@ +DEPDIR = @DEPDIR@ +DLLTOOL = @DLLTOOL@ +DSYMUTIL = @DSYMUTIL@ +DUMPBIN = @DUMPBIN@ +ECHO_C = @ECHO_C@ +ECHO_N = @ECHO_N@ +ECHO_T = @ECHO_T@ +EGREP = @EGREP@ +ENABLE_SHARED = @ENABLE_SHARED@ +ENABLE_STATIC = @ENABLE_STATIC@ +ETAGS = @ETAGS@ +EXEEXT = @EXEEXT@ +FGREP = @FGREP@ +FILECMD = @FILECMD@ +FISH_FUNCTIONS_DIR = @FISH_FUNCTIONS_DIR@ +GCOV = @GCOV@ +GREP = @GREP@ +H2O = @H2O@ +HAVE_LIBZ = @HAVE_LIBZ@ +HTTPD = @HTTPD@ +HTTPD_NGHTTPX = @HTTPD_NGHTTPX@ +INSTALL = @INSTALL@ +INSTALL_DATA = @INSTALL_DATA@ +INSTALL_PROGRAM = @INSTALL_PROGRAM@ +INSTALL_SCRIPT = @INSTALL_SCRIPT@ +INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ +LCOV = @LCOV@ +LD = @LD@ +LDFLAGS = @LDFLAGS@ +LIBCURL_PC_CFLAGS = @LIBCURL_PC_CFLAGS@ +LIBCURL_PC_CFLAGS_PRIVATE = @LIBCURL_PC_CFLAGS_PRIVATE@ +LIBCURL_PC_LDFLAGS_PRIVATE = @LIBCURL_PC_LDFLAGS_PRIVATE@ +LIBCURL_PC_LIBS = @LIBCURL_PC_LIBS@ +LIBCURL_PC_LIBS_PRIVATE = @LIBCURL_PC_LIBS_PRIVATE@ +LIBCURL_PC_REQUIRES = @LIBCURL_PC_REQUIRES@ +LIBCURL_PC_REQUIRES_PRIVATE = @LIBCURL_PC_REQUIRES_PRIVATE@ +LIBOBJS = @LIBOBJS@ +LIBS = @LIBS@ +LIBTOOL = @LIBTOOL@ +LIPO = @LIPO@ +LN_S = @LN_S@ +LTLIBOBJS = @LTLIBOBJS@ +LT_SYS_LIBRARY_PATH = @LT_SYS_LIBRARY_PATH@ +MAINT = @MAINT@ +MAKEINFO = @MAKEINFO@ +MANIFEST_TOOL = @MANIFEST_TOOL@ +MKDIR_P = @MKDIR_P@ +NM = @NM@ +NMEDIT = @NMEDIT@ +OBJDUMP = @OBJDUMP@ +OBJEXT = @OBJEXT@ +OTOOL = @OTOOL@ +OTOOL64 = @OTOOL64@ +PACKAGE = @PACKAGE@ +PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ +PACKAGE_NAME = @PACKAGE_NAME@ +PACKAGE_STRING = @PACKAGE_STRING@ +PACKAGE_TARNAME = @PACKAGE_TARNAME@ +PACKAGE_URL = @PACKAGE_URL@ +PACKAGE_VERSION = @PACKAGE_VERSION@ +PATH_SEPARATOR = @PATH_SEPARATOR@ +PERL = @PERL@ +PKGCONFIG = @PKGCONFIG@ +RANLIB = @RANLIB@ +RC = @RC@ +SED = @SED@ +SET_MAKE = @SET_MAKE@ +SFTPD = @SFTPD@ +SHELL = @SHELL@ +SSHD = @SSHD@ +SSL_BACKENDS = @SSL_BACKENDS@ +STRIP = @STRIP@ +SUPPORT_FEATURES = @SUPPORT_FEATURES@ +SUPPORT_PROTOCOLS = @SUPPORT_PROTOCOLS@ +TEST_NGHTTPX = @TEST_NGHTTPX@ +VERSION = @VERSION@ +VERSIONNUM = @VERSIONNUM@ +VSFTPD = @VSFTPD@ +ZLIB_LIBS = @ZLIB_LIBS@ +ZSH_FUNCTIONS_DIR = @ZSH_FUNCTIONS_DIR@ +abs_builddir = @abs_builddir@ +abs_srcdir = @abs_srcdir@ +abs_top_builddir = @abs_top_builddir@ +abs_top_srcdir = @abs_top_srcdir@ +ac_ct_AR = @ac_ct_AR@ +ac_ct_CC = @ac_ct_CC@ +ac_ct_DUMPBIN = @ac_ct_DUMPBIN@ +am__include = @am__include@ +am__leading_dot = @am__leading_dot@ +am__quote = @am__quote@ +am__tar = @am__tar@ +am__untar = @am__untar@ +bindir = @bindir@ +build = @build@ +build_alias = @build_alias@ +build_cpu = @build_cpu@ +build_os = @build_os@ +build_vendor = @build_vendor@ +builddir = @builddir@ +datadir = @datadir@ +datarootdir = @datarootdir@ +docdir = @docdir@ +dvidir = @dvidir@ +exec_prefix = @exec_prefix@ +host = @host@ +host_alias = @host_alias@ +host_cpu = @host_cpu@ +host_os = @host_os@ +host_vendor = @host_vendor@ +htmldir = @htmldir@ +includedir = @includedir@ +infodir = @infodir@ +install_sh = @install_sh@ +libdir = @libdir@ +libexecdir = @libexecdir@ +libext = @libext@ +localedir = @localedir@ +localstatedir = @localstatedir@ +mandir = @mandir@ +mkdir_p = @mkdir_p@ +oldincludedir = @oldincludedir@ +pdfdir = @pdfdir@ +prefix = @prefix@ +program_transform_name = @program_transform_name@ +psdir = @psdir@ +runstatedir = @runstatedir@ +sbindir = @sbindir@ +sharedstatedir = @sharedstatedir@ +srcdir = @srcdir@ +sysconfdir = @sysconfdir@ +target_alias = @target_alias@ +top_build_prefix = @top_build_prefix@ +top_builddir = @top_builddir@ +top_srcdir = @top_srcdir@ + +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### +EXTRA_DIST = \ + backup_gnv_curl_src.com \ + build_curl-config_script.com \ + build_gnv_curl.com \ + build_gnv_curl_pcsi_desc.com \ + build_gnv_curl_pcsi_text.com \ + build_gnv_curl_release_notes.com \ + build_libcurl_pc.com \ + build_vms.com \ + clean_gnv_curl.com \ + compare_curl_source.com \ + config_h.com \ + curl_crtl_init.c \ + curl_gnv_build_steps.txt \ + curl_release_note_start.txt \ + curl_startup.com \ + curlmsg.h \ + curlmsg.msg \ + curlmsg.sdl \ + curlmsg_vms.h \ + generate_config_vms_h_curl.com \ + generate_vax_transfer.com \ + gnv_conftest.c_first \ + gnv_curl_configure.sh \ + gnv_libcurl_symbols.opt \ + gnv_link_curl.com \ + macro32_exactcase.patch \ + make_gnv_curl_install.sh \ + make_pcsi_curl_kit_name.com \ + pcsi_gnv_curl_file_list.txt \ + pcsi_product_gnv_curl.com \ + readme \ + report_openssl_version.c \ + setup_gnv_curl_build.com \ + stage_curl_install.com \ + vms_eco_level.h + +all: all-am + +.SUFFIXES: +$(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps) + @for dep in $?; do \ + case '$(am__configure_deps)' in \ + *$$dep*) \ + ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \ + && { if test -f $@; then exit 0; else break; fi; }; \ + exit 1;; \ + esac; \ + done; \ + echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu projects/vms/Makefile'; \ + $(am__cd) $(top_srcdir) && \ + $(AUTOMAKE) --gnu projects/vms/Makefile +Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status + @case '$?' in \ + *config.status*) \ + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ + *) \ + echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__maybe_remake_depfiles)'; \ + cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__maybe_remake_depfiles);; \ + esac; + +$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh + +$(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh +$(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh +$(am__aclocal_m4_deps): + +mostlyclean-libtool: + -rm -f *.lo + +clean-libtool: + -rm -rf .libs _libs +tags TAGS: + +ctags CTAGS: + +cscope cscopelist: + +distdir: $(BUILT_SOURCES) + $(MAKE) $(AM_MAKEFLAGS) distdir-am + +distdir-am: $(DISTFILES) + @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ + topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ + list='$(DISTFILES)'; \ + dist_files=`for file in $$list; do echo $$file; done | \ + sed -e "s|^$$srcdirstrip/||;t" \ + -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ + case $$dist_files in \ + */*) $(MKDIR_P) `echo "$$dist_files" | \ + sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ + sort -u` ;; \ + esac; \ + for file in $$dist_files; do \ + if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ + if test -d $$d/$$file; then \ + dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ + if test -d "$(distdir)/$$file"; then \ + find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ + fi; \ + if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ + cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ + find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ + fi; \ + cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ + else \ + test -f "$(distdir)/$$file" \ + || cp -p $$d/$$file "$(distdir)/$$file" \ + || exit 1; \ + fi; \ + done +check-am: all-am +check: check-am +all-am: Makefile +installdirs: +install: install-am +install-exec: install-exec-am +install-data: install-data-am +uninstall: uninstall-am + +install-am: all-am + @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am + +installcheck: installcheck-am +install-strip: + if test -z '$(STRIP)'; then \ + $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ + install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ + install; \ + else \ + $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ + install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ + "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \ + fi +mostlyclean-generic: + +clean-generic: + +distclean-generic: + -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) + -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) + +maintainer-clean-generic: + @echo "This command is intended for maintainers to use" + @echo "it deletes files that may require special tools to rebuild." +clean: clean-am + +clean-am: clean-generic clean-libtool mostlyclean-am + +distclean: distclean-am + -rm -f Makefile +distclean-am: clean-am distclean-generic + +dvi: dvi-am + +dvi-am: + +html: html-am + +html-am: + +info: info-am + +info-am: + +install-data-am: + +install-dvi: install-dvi-am + +install-dvi-am: + +install-exec-am: + +install-html: install-html-am + +install-html-am: + +install-info: install-info-am + +install-info-am: + +install-man: + +install-pdf: install-pdf-am + +install-pdf-am: + +install-ps: install-ps-am + +install-ps-am: + +installcheck-am: + +maintainer-clean: maintainer-clean-am + -rm -f Makefile +maintainer-clean-am: distclean-am maintainer-clean-generic + +mostlyclean: mostlyclean-am + +mostlyclean-am: mostlyclean-generic mostlyclean-libtool + +pdf: pdf-am + +pdf-am: + +ps: ps-am + +ps-am: + +uninstall-am: + +.MAKE: install-am install-strip + +.PHONY: all all-am check check-am clean clean-generic clean-libtool \ + cscopelist-am ctags-am distclean distclean-generic \ + distclean-libtool distdir dvi dvi-am html html-am info info-am \ + install install-am install-data install-data-am install-dvi \ + install-dvi-am install-exec install-exec-am install-html \ + install-html-am install-info install-info-am install-man \ + install-pdf install-pdf-am install-ps install-ps-am \ + install-strip installcheck installcheck-am installdirs \ + maintainer-clean maintainer-clean-generic mostlyclean \ + mostlyclean-generic mostlyclean-libtool pdf pdf-am ps ps-am \ + tags-am uninstall uninstall-am + +.PRECIOUS: Makefile + + +# Tell versions [3.59,3.63) of GNU make to not export all variables. +# Otherwise a system limit (for SysV at least) may be exceeded. +.NOEXPORT: diff --git a/3rdparty/curl-8.21.0/projects/vms/backup_gnv_curl_src.com b/3rdparty/curl-8.21.0/projects/vms/backup_gnv_curl_src.com new file mode 100644 index 0000000000..298f11f80f --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/backup_gnv_curl_src.com @@ -0,0 +1,130 @@ +$! File: Backup_gnv_curl_src.com +$! +$! Procedure to create backup save sets for installing in a PCSI kit. +$! +$! To comply with most Open Source licenses, the source used for building +$! a kit will be packaged with the distribution kit for the binary. +$! +$! Backup save sets are the only storage format that I can expect a +$! VMS system to be able to extract ODS-5 filenames and directories. +$! +$! The make_pcsi_kit_name.com needs to be run before this procedure to +$! properly name the files that will be created. +$! +$! This file is created from a template file for the purpose of making it +$! easier to port Unix code, particularly open source code to VMS. +$! Therefore permission is freely granted for any use. +$! +$! Copyright (C) John Malmberg +$! +$! Permission to use, copy, modify, and/or distribute this software for any +$! purpose with or without fee is hereby granted, provided that the above +$! copyright notice and this permission notice appear in all copies. +$! +$! THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +$! WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +$! MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +$! ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +$! WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +$! ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT +$! OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +$! +$! SPDX-License-Identifier: ISC +$! +$!=========================================================================== +$! +$! Save default +$ default_dir = f$environment("DEFAULT") +$! +$ arch_type = f$getsyi("ARCH_NAME") +$ arch_code = f$extract(0, 1, arch_type) +$! +$ if arch_code .nes. "V" +$ then +$ set proc/parse=extended +$ endif +$! +$ ss_abort = 44 +$ status = ss_abort +$! +$ kit_name = f$trnlnm("GNV_PCSI_KITNAME") +$ if kit_name .eqs. "" +$ then +$ write sys$output "@MAKE_PCSI_CURL_KIT_NAME.COM has not been run." +$ goto all_exit +$ endif +$ producer = f$trnlnm("GNV_PCSI_PRODUCER") +$ if producer .eqs. "" +$ then +$ write sys$output "@MAKE_PCSI_CURL_KIT_NAME.COM has not been run." +$ goto all_exit +$ endif +$ filename_base = f$trnlnm("GNV_PCSI_FILENAME_BASE") +$ if filename_base .eqs. "" +$ then +$ write sys$output "@MAKE_PCSI_CURL_KIT_NAME.COM has not been run." +$ goto all_exit +$ endif +$! +$ node_swvers = f$getsyi("NODE_SWVERS") +$ node_swvers_type = f$extract(0, 1, node_swvers) +$ node_swvers_vers = f$extract(1, f$length(node_swvers), node_swvers) +$ swvers_maj = f$element(0, ".", node_swvers_vers) +$ node_swvers_min_update = f$element(1, ".", node_swvers_vers) +$ swvers_min = f$element(0, "-", node_swvers_min_update) +$ swvers_update = f$element(1, "-", node_swvers_min_update) +$! +$ if swvers_update .eqs. "-" then swvers_update = "" +$! +$ vms_vers = f$fao("!2ZB!2ZB!AS", 'swvers_maj', 'swvers_min', swvers_update) +$! +$! +$! +$! If available make an interchange save set +$!------------------------------------------- +$ interchange = "" +$ if arch_code .eqs. "V" +$ then +$ interchange = "/interchange" +$ endif +$ if (swvers_maj .ges. "8") .and. (swvers_min .ges. 4) +$ then +$ interchange = "/interchange/noconvert" +$ endif +$! +$! +$! Move to the base directories +$ set def [--] +$! +$! Put things back on error. +$ on warning then goto all_exit +$! +$ current_default = f$environment("DEFAULT") +$ my_dir = f$parse(current_default,,,"DIRECTORY") - "[" - "<" - ">" - "]" +$! +$ src_root = "src_root:" +$ if f$trnlnm("src_root1") .nes. "" then src_root = "src_root1:" +$ backup'interchange' 'src_root'[curl...]*.*;0 - + 'filename_base'_original_src.bck/sav +$ status = $status +$! +$! There may be a VMS specific source kit +$!----------------------------------------- +$ vms_root = "vms_root:" +$ if f$trnlnm("vms_root1") .nes. "" then vms_root = "vms_root1:" +$ files_found = 0 +$ define/user sys$error nl: +$ define/user sys$output nl: +$ directory 'vms_root'[...]*.*;*/exc=*.dir +$ if '$severity' .eq. 1 then files_found = 1 +$! +$ if files_found .eq. 1 +$ then +$ backup'interchange' 'vms_root'[curl...]*.*;0 - + 'filename_base'_vms_src.bck/sav +$ status = $status +$ endif +$! +$all_exit: +$ set def 'default_dir' +$ exit diff --git a/3rdparty/curl-8.21.0/projects/vms/build_curl-config_script.com b/3rdparty/curl-8.21.0/projects/vms/build_curl-config_script.com new file mode 100644 index 0000000000..1902b0c215 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/build_curl-config_script.com @@ -0,0 +1,153 @@ +$! build_curl-config_script.com +$! +$! This generates the curl-config. script from the curl-config.in file. +$! +$! Copyright (C) John Malmberg +$! +$! Permission to use, copy, modify, and/or distribute this software for any +$! purpose with or without fee is hereby granted, provided that the above +$! copyright notice and this permission notice appear in all copies. +$! +$! THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +$! WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +$! MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +$! ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +$! WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +$! ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT +$! OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +$! +$! SPDX-License-Identifier: ISC +$! +$!=========================================================================== +$! +$! Skip this if the curl-config. already exists. +$ if f$search("[--]curl-config.") .nes. "" then goto all_exit +$! +$ if (f$getsyi("HW_MODEL") .lt. 1024) +$ then +$ arch_name = "VAX" +$ else +$ arch_name = "" +$ arch_name = arch_name + f$edit(f$getsyi("ARCH_NAME"), "UPCASE") +$ if (arch_name .eqs. "") then arch_name = "UNK" +$ endif +$! +$ x_prefix = "/usr" +$ x_exec_prefix = "/usr" +$ x_includedir = "${prefix}/include" +$ x_cppflag_curl_staticlib = "-DCURL_STATICLIB" +$ x_enabled_shared = "no" +$ x_curl_ca_bundle = "" +$ x_cc = "cc" +$ x_support_features = "SSL IPv6 libz NTLM" +$ x_support_protocols1 = "DICT FILE FTP FTPS GOPHER HTTP HTTPS IMAP IMAPS LDAP" +$ x_support_protocols2 = " LDAPS POP3 POP3S RTSP SMTP SMTPS TELNET TFTP" +$ x_support_protocols = x_support_protocols1 + x_support_protocols2 +$ x_curlversion = "0.0.0.0" +$ x_versionnum = "" +$ x_libdir = "${prefix}/lib" +$ x_require_lib_deps = "" +$ x_enable_static = "" +$ x_ldflags = "" +$ part1 = "-L/usr/lib -L/SSL_LIB -lssl -lcrypto -lz" +$ if arch_name .eqs. "VAX" +$ then +$ x_libcurl_libs = part1 +$ else +$ x_libcurl_libs = part1 + " -lgssapi" +$ endif +$ x_libext = "a" +$! +$! Get the version number +$!----------------------- +$ i = 0 +$ open/read/error=version_loop_end vhf [--.include.curl]curlver.h +$ version_loop: +$ read/end=version_loop_end vhf line_in +$ if line_in .eqs. "" then goto version_loop +$ if f$locate("#define LIBCURL_VERSION ", line_in) .eq. 0 +$ then +$ x_curlversion = f$element(2," ", line_in) - """" - """" +$ i = i + 1 +$ endif +$ if f$locate("#define LIBCURL_VERSION_NUM ", line_in) .eq. 0 +$ then +$ x_versionnum = f$element(2," ", line_in) - """" - """" +$ i = i + 1 +$ endif +$ if i .lt 2 then goto version_loop +$ version_loop_end: +$ close vhf +$! +$ kit_type = "V" +$ if f$locate("-", x_curlversion) .lt. f$length(x_curlversion) +$ then +$ kit_type = "D" +$ x_prefix = "/beta" +$ x_exec_prefix = "/beta" +$ endif +$! +$ if kit_type .nes. "D" +$ then +$ part1 = " echo "" '--prefix=/usr' '--exec-prefix=/usr' " +$ else +$ part1 = " echo "" '--prefix=/beta' '--exec_prefix=/beta' " +$ endif +$ if arch_name .eqs. "VAX" +$ then +$ part3 = "" +$ else +$ part3 = "'--with-gssapi' " +$ endif +$ part2 = "'--disable-dependency-tracking' '--disable-libtool-lock' " +$ part4 = "'--disable-ntlm-wb' '--with-ca-path=gnv$curl_ca_path'""" +$! +$ x_configure_options = part1 + part2 + part3 + part4 +$! +$! +$ open/read/error=read_loop_end c_c_in sys$disk:[--]curl-config.in +$ create sys$disk:[--]curl-config. +$ open/append c_c_out sys$disk:[--]curl-config. +$read_loop: +$ read/end=read_loop_end c_c_in line_in +$ line_in_len = f$length(line_in) +$ if f$locate("@", line_in) .ge. line_in_len +$ then +$ write c_c_out line_in +$ goto read_loop +$ endif +$ i = 0 +$ line_out = "" +$sub_loop: +$ ! Replace between pairs of @ by alternating the elements. +$ ! If mismatched pairs, do not substitute anything. +$ section1 = f$element(i, "@", line_in) +$ if section1 .eqs. "@" +$ then +$ goto sub_loop_end +$ endif +$ i = i + 1 +$ section2 = f$element(i, "@", line_in) +$ if section2 .eqs. "@" +$ then +$ goto sub_loop_end +$ endif +$ i = i + 1 +$ section3 = f$element(i, "@", line_in) +$ if section3 .eqs. "@" +$ then +$ if line_out .eqs. "" then line_out = line_in +$ goto sub_loop_end +$ endif +$ line_out = line_out + section1 +$ if f$type(x_'section2') .eqs. "STRING" +$ then +$ line_out = line_out + x_'section2' +$ endif +$ goto sub_loop +$sub_loop_end: +$ write c_c_out line_out +$ goto read_loop +$read_loop_end: +$ close c_c_in +$ close c_c_out diff --git a/3rdparty/curl-8.21.0/projects/vms/build_gnv_curl.com b/3rdparty/curl-8.21.0/projects/vms/build_gnv_curl.com new file mode 100644 index 0000000000..36e7281135 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/build_gnv_curl.com @@ -0,0 +1,36 @@ +$! File: build_gnv_curl.com +$! +$! All in one build procedure +$! +$! Copyright (C) John Malmberg +$! +$! Permission to use, copy, modify, and/or distribute this software for any +$! purpose with or without fee is hereby granted, provided that the above +$! copyright notice and this permission notice appear in all copies. +$! +$! THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +$! WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +$! MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +$! ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +$! WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +$! ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT +$! OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +$! +$! SPDX-License-Identifier: ISC +$! +$!----------------------------------------------------------------------- +$! +$ @setup_gnv_curl_build.com +$! +$ bash gnv_curl_configure.sh +$! +$ @clean_gnv_curl.com +$! +$ bash make_gnv_curl_install.sh +$! +$ @gnv_link_curl.com +$! +$ purge new_gnu:[*...]/log +$! +$! +$exit diff --git a/3rdparty/curl-8.21.0/projects/vms/build_gnv_curl_pcsi_desc.com b/3rdparty/curl-8.21.0/projects/vms/build_gnv_curl_pcsi_desc.com new file mode 100644 index 0000000000..7726b4aa9f --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/build_gnv_curl_pcsi_desc.com @@ -0,0 +1,489 @@ +$! File: Build_GNV_CURL_PCSI_DESC.COM +$! +$! Build the *.pcsi$text file in the following sections: +$! Required software dependencies. +$! install/upgrade/postinstall steps. +$! 1. Duplicate filenames need an alias procedure. (N/A for curl) +$! 2. ODS-5 filenames need an alias procedure. (N/A for curl) +$! 3. Special alias links for executables (curl. -> curl.exe) +$! if a lot, then an alias procedure is needed. +$! 4. Rename the files to lowercase. +$! Move Release Notes to destination +$! Source kit option +$! Create directory lines +$! Add file lines for curl. +$! Add Link alias procedure file (N/A for curl) +$! Add [.SYS$STARTUP]curl_startup file +$! Add Release notes file. +$! +$! The file PCSI_GNV_CURL_FILE_LIST.TXT is read in to get the files other +$! than the release notes file and the source backup file. +$! +$! The PCSI system can really only handle ODS-2 format filenames and +$! assumes that there is only one source directory. It also assumes that +$! all destination files with the same name come from the same source file. +$! Fortunately curl does not trip most of these issues, so those steps +$! above are marked N/A. +$! +$! A rename action section is needed to make sure that the files are +$! created in the GNV$GNU: in the correct case, and to create the alias +$! link [usr.bin]curl. for [usr.bin]curl.exe. +$! +$! Copyright (C) John Malmberg +$! +$! Permission to use, copy, modify, and/or distribute this software for any +$! purpose with or without fee is hereby granted, provided that the above +$! copyright notice and this permission notice appear in all copies. +$! +$! THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +$! WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +$! MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +$! ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +$! WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +$! ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT +$! OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +$! +$! SPDX-License-Identifier: ISC +$! +$!=========================================================================== +$! +$ kit_name = f$trnlnm("GNV_PCSI_KITNAME") +$ if kit_name .eqs. "" +$ then +$ write sys$output "@MAKE_PCSI_CURL_KIT_NAME.COM has not been run." +$ goto all_exit +$ endif +$ producer = f$trnlnm("GNV_PCSI_PRODUCER") +$ if producer .eqs. "" +$ then +$ write sys$output "@MAKE_PCSI_CURL_KIT_NAME.COM has not been run." +$ goto all_exit +$ endif +$ filename_base = f$trnlnm("GNV_PCSI_FILENAME_BASE") +$ if filename_base .eqs. "" +$ then +$ write sys$output "@MAKE_PCSI_CURL_KIT_NAME.COM has not been run." +$ goto all_exit +$ endif +$! +$! +$! Parse the kit name into components. +$!--------------------------------------- +$ producer = f$element(0, "-", kit_name) +$ base = f$element(1, "-", kit_name) +$ product = f$element(2, "-", kit_name) +$ mmversion = f$element(3, "-", kit_name) +$ majorver = f$extract(0, 3, mmversion) +$ minorver = f$extract(3, 2, mmversion) +$ updatepatch = f$element(4, "-", kit_name) +$ if updatepatch .eqs. "-" then updatepatch = "" +$! +$! kit type of "D" means a daily build +$ kit_type = f$edit(f$extract(0, 1, majorver), "upcase") +$! +$! +$ product_line = "product ''producer' ''base' ''product'" +$ if updatepatch .eqs. "" +$ then +$ product_name = " ''majorver'.''minorver'" +$ else +$ product_name = " ''majorver'.''minorver'-''updatepatch'" +$ endif +$ product_line = product_line + " ''product_name' full;" +$!write sys$output product_line +$! +$! +$! +$! Create the file as a VMS text file. +$!---------------------------------------- +$ base_file = kit_name +$ create 'base_file'.pcsi$desc +$! +$! +$! Start building file. +$!---------------------- +$ open/append pdsc 'base_file'.pcsi$desc +$! +$ write pdsc product_line +$! +$! Required product dependencies. +$!---------------------------------- +$ vmsprd = "DEC" +$ if base .eqs. "I64VMS" then vmsprd = "HP" +$ vsiprd = "VSI" +$! +$ write pdsc " software ''vmsprd' ''base' VMS ;" +$ arch_type = f$getsyi("ARCH_NAME") +$ node_swvers = f$getsyi("node_swvers") +$ vernum = f$extract(1, f$length(node_swvers), node_swvers) +$ majver = f$element(0, ".", vernum) +$ minverdash = f$element(1, ".", vernum) +$ minver = f$element(0, "-", minverdash) +$ dashver = f$element(1, "-", minverdash) +$ if dashver .eqs. "-" then dashver = "" +$ vmstag = majver + minver + dashver +$ code = f$extract(0, 1, arch_type) +$ arch_code = f$extract(0, 1, arch_type) +$ line_out = - + " if ((not ) and" + - + " (not ));" +$ write pdsc line_out +$ write pdsc " error NEED_VMS''vmstag';" +$ write pdsc " end if;" +$! +$write pdsc " software VMSPORTS ''base' ZLIB ;" +$write pdsc - + " if (not ) ;" +$write pdsc " error NEED_ZLIB;" +$write pdsc " end if;" +$! +$! +$! +$! install/upgrade/postinstall steps. +$!----------------------------------- +$! 1. Duplicate filenames need an alias procedure. (N/A for curl) +$! 2. ODS-5 filenames need an alias procedure. (N/A for curl) +$! 3. Special alias links for executables (curl. -> curl.exe) +$! if a lot, then an alias procedure is needed. +$! 4. Rename the files to lowercase. +$! +$! +$! Alias links needed. +$!------------------------- +$ add_alias_lines = "" +$ rem_alias_lines = "" +$ line_out = "" +$! +$! Read through the file list to set up aliases and rename commands. +$!--------------------------------------------------------------------- +$ open/read flst pcsi_gnv_curl_file_list.txt +$! +$inst_alias_loop: +$ read/end=inst_alias_loop_end flst line_in +$ line_in = f$edit(line_in,"compress,trim,uncomment") +$ if line_in .eqs. "" then goto inst_alias_loop +$ pathname = f$element(0, " ", line_in) +$ linkflag = f$element(1, " ", line_in) + +$ if linkflag .nes. "->" then goto inst_alias_write +$! +$ linktarget = f$element(2, " ", line_in) +$ if kit_type .eqs. "D" +$ then +$ old_start = f$locate("[gnv.usr", pathname) +$ if old_start .lt. f$length(pathname) +$ then +$ pathname = "[gnv.beta" + pathname - "[gnv.usr" +$ linktarget = "[gnv.beta" + linktarget - "[gnv.usr" +$ endif +$ endif +$ nlink = "pcsi$destination:" + pathname +$ ntarg = "pcsi$destination:" + linktarget +$ new_add_alias_line = - + """if f$search(""""''nlink'"""") .eqs. """""""" then" + - + " set file/enter=''nlink' ''ntarg'""" +$ if add_alias_lines .nes. "" +$ then +$ add_alias_lines = add_alias_lines + "," + new_add_alias_line +$ else +$ add_alias_lines = new_add_alias_line +$ endif +$! +$ new_rem_alias_line = - + """if f$search(""""''nlink'"""") .nes. """""""" then" + - + " set file/remove ''nlink';""" +$ if rem_alias_lines .nes. "" +$ then +$ rem_alias_lines = rem_alias_lines + "," + new_rem_alias_line +$ else +$ rem_alias_lines = new_rem_alias_line +$ endif +$! +$ goto inst_alias_loop +$! +$inst_alias_write: +$! +$! execute install / remove +$ write pdsc " execute install (" +$! add aliases +$ i = 0 +$ex_ins_loop: +$ line = f$element(i, ",", add_alias_lines) +$ i = i + 1 +$ if line .eqs. "" then goto ex_ins_loop +$ if line .eqs. "," then goto ex_ins_loop_end +$ if line_out .nes. "" then write pdsc line_out,"," +$ line_out = line +$ goto ex_ins_loop +$ex_ins_loop_end: +$ write pdsc line_out +$ line_out = "" +$ write pdsc " )" +$ write pdsc " remove (" +$! remove aliases +$ i = 0 +$ex_rem_loop: +$ line = f$element(i, ",", rem_alias_lines) +$ i = i + 1 +$ if line .eqs. "" then goto ex_rem_loop +$ if line .eqs. "," then goto ex_rem_loop_end +$ if line_out .nes. "" then write pdsc line_out,"," +$ line_out = line +$ goto ex_rem_loop +$ex_rem_loop_end: +$ write pdsc line_out +$ line_out = "" +$ write pdsc " ) ;" +$! +$! execute upgrade +$ write pdsc " execute upgrade (" +$ i = 0 +$ex_upg_loop: +$ line = f$element(i, ",", rem_alias_lines) +$ i = i + 1 +$ if line .eqs. "" then goto ex_upg_loop +$ if line .eqs. "," then goto ex_upg_loop_end +$ if line_out .nes. "" then write pdsc line_out,"," +$ line_out = line +$ goto ex_upg_loop +$ex_upg_loop_end: +$ write pdsc line_out +$ line_out = "" +$! remove aliases +$ write pdsc " ) ;" +$! +$! execute postinstall +$ write pdsc " execute postinstall (" +$ if arch_code .nes. "V" +$ then +$ line_out = " ""set process/parse=extended""" +$ endif +$ i = 0 +$ex_pins_loop: +$ line = f$element(i, ",", add_alias_lines) +$ i = i + 1 +$ if line .eqs. "" then goto ex_pins_loop +$ if line .eqs. "," then goto ex_pins_loop_end +$ if line_out .nes. "" then write pdsc line_out,"," +$ line_out = line +$ goto ex_pins_loop +$ex_pins_loop_end: +$ if line_out .eqs. "" then line_out = " ""continue""" +$! write pdsc line_out +$! line_out = "" +$! add aliases and follow with renames. +$! +$goto inst_dir +$! +$inst_dir_loop: +$ read/end=inst_alias_loop_end flst line_in +$ line_in = f$edit(line_in,"compress,trim,uncomment") +$ if line_in .eqs. "" then goto inst_dir_loop +$inst_dir: +$ pathname = f$element(0, " ", line_in) +$ if kit_type .eqs. "D" +$ then +$ if pathname .eqs. "[gnv]usr.dir" +$ then +$ pathname = "[gnv]beta.dir" +$ else +$ old_start = f$locate("[gnv.usr", pathname) +$ if old_start .lt. f$length(pathname) +$ then +$ pathname = "[gnv.beta" + pathname - "[gnv.usr" +$ endif +$ endif +$ endif +$! +$! Ignore the directory entries for now. +$!----------------------------------------- +$ filedir = f$parse(pathname,,,"DIRECTORY") +$ if pathname .eqs. filedir then goto inst_dir_loop +$! +$! process .dir extensions for rename +$! If this is not a directory then start processing files. +$!------------------------- +$ filetype = f$parse(pathname,,,"TYPE") +$ filetype_u = f$edit(filetype, "upcase") +$ filename = f$parse(pathname,,,"NAME") +$ if filetype_u .nes. ".DIR" then goto inst_file +$! +$! process directory lines for rename. +$!-------------------------------------- +$ if line_out .nes. "" +$ then +$ write pdsc line_out,"," +$ line_out = "" +$ endif +$ if arch_code .nes. "V" +$ then +$ if line_out .nes. "" then write pdsc line_out,"," +$ line_out = " ""rename pcsi$destination:''pathname' ''filename'.DIR""" +$ else +$ if line_out .nes. "" then write pdsc line_out +$ line_out = "" +$ endif +$ goto inst_dir_loop +$! +$! +$! process file lines for rename +$!--------------------------------- +$inst_file_loop: +$ read/end=inst_alias_loop_end flst line_in +$ line_in = f$edit(line_in,"compress,trim,uncomment") +$ if line_in .eqs. "" then goto inst_dir_loop +$ pathname = f$element(0, " ", line_in) +$ if kit_type .eqs. "D" +$ then +$ if pathname .eqs. "[gnv]usr.dir" +$ then +$ pathname = "[gnv]beta.dir" +$ else +$ old_start = f$locate("[gnv.usr", pathname) +$ if old_start .lt. f$length(pathname) +$ then +$ pathname = "[gnv.beta" + pathname - "[gnv.usr" +$ endif +$ endif +$ endif +$! +$! Filenames with $ in them are VMS special and do not need to be lowercase. +$! -------------------------------------------------------------------------- +$ if f$locate("$", pathname) .lt. f$length(pathname) then goto inst_file_loop +$! +$ filetype = f$parse(pathname,,,"TYPE") +$ filename = f$parse(pathname,,,"NAME") + filetype +$inst_file: +$ if arch_code .nes. "V" +$ then +$ if line_out .nes. "" then write pdsc line_out,"," +$ filetype = f$parse(pathname,,,"TYPE") +$ filename = f$parse(pathname,,,"NAME") + filetype +$ line_out = " ""rename pcsi$destination:''pathname' ''filename'""" +$ else +$ if line_out .nes. "" then write pdsc line_out +$ line_out = "" +$ endif +$ goto inst_file_loop +$! +$inst_alias_loop_end: +$! +$write pdsc line_out +$write pdsc " ) ;" +$close flst +$! +$! Move Release Notes to destination +$!------------------------------------- +$write pdsc " information RELEASE_NOTES phase after ;" +$! +$! Source kit option +$!--------------------- +$write pdsc " option SOURCE default 0;" +$write pdsc " directory ""[gnv.common_src]"" PROTECTION PUBLIC ;" +$write pdsc - + " file ""[gnv.common_src]''filename_base'_original_src.bck""" +$write pdsc - + " source [common_src]''filename_base'_original_src.bck ;" +$if f$search("gnv$gnu:[vms_src]''filename_base'_vms_src.bck") .nes. "" +$then +$ write pdsc " directory ""[gnv.vms_src]"" PROTECTION PUBLIC ;" +$ write pdsc " file ""[gnv.vms_src]''filename_base'_vms_src.bck""" +$ write pdsc " source [vms_src]''filename_base'_vms_src.bck ;" +$endif +$write pdsc " end option;" +$! +$! +$! Read through the file list again. +$!---------------------------------- +$open/read flst pcsi_gnv_curl_file_list.txt +$! +$! +$! Create directory lines +$!------------------------- +$flst_dir_loop: +$ read/end=flst_loop_end flst line_in +$ line_in = f$edit(line_in,"compress,trim,uncomment") +$ if line_in .eqs. "" then goto flst_dir_loop +$! +$ filename = f$element(0, " ", line_in) +$ linkflag = f$element(1, " ", line_in) +$ if linkflag .eqs. "->" then goto flst_dir_loop +$! +$! Ignore .dir extensions +$!------------------------- +$ filetype = f$edit(f$parse(filename,,,"TYPE"), "upcase") +$ if filetype .eqs. ".DIR" then goto flst_dir_loop +$! +$ destname = filename +$ if kit_type .eqs. "D" +$ then +$ old_start = f$locate("[gnv.usr", destname) +$ if old_start .lt. f$length(destname) +$ then +$ destname = "[gnv.beta" + destname - "[gnv.usr" +$ endif +$ endif +$! +$! It should be a directory then. +$!------------------------------------- +$ filedir = f$edit(f$parse(filename,,,"DIRECTORY"), "lowercase") +$! If this is not a directory then start processing files. +$!--------------------------------------------------------- +$ if filename .nes. filedir then goto flst_file +$! +$ write pdsc " directory ""''destname'"" PROTECTION PUBLIC ;" +$ goto flst_dir_loop +$! +$! +$! Add file lines for curl. +$!--------------------------- +$flst_file_loop: +$ read/end=flst_loop_end flst line_in +$ line_in = f$edit(line_in,"compress,trim,uncomment") +$ if line_in .eqs. "" then goto inst_file_loop +$ filename = f$element(0, " ", line_in) +$ destname = filename +$ if kit_type .eqs. "D" +$ then +$ old_start = f$locate("[gnv.usr", destname) +$ if old_start .lt. f$length(destname) +$ then +$ destname = "[gnv.beta" + destname - "[gnv.usr" +$ endif +$ endif +$flst_file: +$ srcfile = filename - "gnv." +$ write pdsc " file ""''destname'"" " +$ write pdsc " source ""''srcfile'"" ;" +$ goto flst_file_loop +$! +$flst_loop_end: +$ close flst +$! +$! Add Link alias procedure file (N/A for curl) +$!------------------------------------------------ +$! +$! Add [.SYS$STARTUP]curl_startup file +$!--------------------------------------- +$ if kit_type .eqs. "D" +$ then +$ write pdsc " file ""[sys$startup]curl_daily_startup.com""" +$ else +$ write pdsc " file ""[sys$startup]curl_startup.com""" +$ endif +$ write pdsc " source [usr.lib]curl_startup.com ;" +$! +$! Add Release notes file. +$!------------------------------ +$ write pdsc - + " file ""[SYSHLP]''filename_base'.release_notes"" release notes ;" +$! +$! Close the product file +$!------------------------ +$ write pdsc "end product;" +$! +$close pdsc +$! +$all_exit: +$ exit diff --git a/3rdparty/curl-8.21.0/projects/vms/build_gnv_curl_pcsi_text.com b/3rdparty/curl-8.21.0/projects/vms/build_gnv_curl_pcsi_text.com new file mode 100644 index 0000000000..b67ad8f187 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/build_gnv_curl_pcsi_text.com @@ -0,0 +1,195 @@ +$! File: Build_GNV_curl_pcsi_text.com +$! +$! Build the *.pcsi$text file from the four components: +$! 1. Generated =product header section +$! 2. [--]readme. file from the curl distribution, modified to fit +$! a pcsi$text file format. +$! 3. [--]copying file from the curl distribution, modified to fit +$! a pcsi$text file format. +$! 4. Generated Producer section. +$! +$! Set the name of the release notes from the GNV_PCSI_FILENAME_BASE +$! +$! Copyright (C) John Malmberg +$! +$! Permission to use, copy, modify, and/or distribute this software for any +$! purpose with or without fee is hereby granted, provided that the above +$! copyright notice and this permission notice appear in all copies. +$! +$! THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +$! WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +$! MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +$! ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +$! WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +$! ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT +$! OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +$! +$! SPDX-License-Identifier: ISC +$! +$!=========================================================================== +$! +$ kit_name = f$trnlnm("GNV_PCSI_KITNAME") +$ if kit_name .eqs. "" +$ then +$ write sys$output "@MAKE_PCSI_CURL_KIT_NAME.COM has not been run." +$ goto all_exit +$ endif +$ producer = f$trnlnm("GNV_PCSI_PRODUCER") +$ if producer .eqs. "" +$ then +$ write sys$output "@MAKE_PCSI_CURL_KIT_NAME.COM has not been run." +$ goto all_exit +$ endif +$ producer_full_name = f$trnlnm("GNV_PCSI_PRODUCER_FULL_NAME") +$ if producer_full_name .eqs. "" +$ then +$ write sys$output "@MAKE_PCSI_CURL_KIT_NAME.COM has not been run." +$ goto all_exit +$ endif +$! +$! +$! Parse the kit name into components. +$!--------------------------------------- +$ producer = f$element(0, "-", kit_name) +$ base = f$element(1, "-", kit_name) +$ product = f$element(2, "-", kit_name) +$ mmversion = f$element(3, "-", kit_name) +$ majorver = f$extract(0, 3, mmversion) +$ minorver = f$extract(3, 2, mmversion) +$ updatepatch = f$element(4, "-", kit_name) +$ if updatepatch .eqs. "-" then updatepatch = "" +$! +$! +$ product_line = "=product ''producer' ''base' ''product'" +$ if updatepatch .eqs. "" +$ then +$ product_name = " ''majorver'.''minorver'" +$ else +$ product_name = " ''majorver'.''minorver'-''updatepatch'" +$ endif +$ product_line = product_line + " ''product_name' full" +$! +$! +$! If this is VAX and the file is on NFS, the names may be mangled. +$!----------------------------------------------------------------- +$ readme_file = "" +$ if f$search("[--]readme.") .nes. "" +$ then +$ readme_file = "[--]readme." +$ else +$ if f$search("[--]$README.") .nes. "" +$ then +$ readme_file = "[--]$README." +$ else +$ write sys$output "Can not find readme file." +$ goto all_exit +$ endif +$ endif +$ copying_file = "" +$ if f$search("[--]copying.") .nes. "" +$ then +$ copying_file = "[--]copying." +$ else +$ if f$search("[--]$COPYING.") .nes. "" +$ then +$ copying_file = "[--]$COPYING." +$ else +$ write sys$output "Can not find copying file." +$ goto all_exit +$ endif +$ endif +$! +$! Create the file as a VMS text file. +$!---------------------------------------- +$ base_file = kit_name +$ create 'base_file'.pcsi$text +$! +$! +$! Start building file. +$!---------------------- +$ open/append ptxt 'base_file'.pcsi$text +$ write ptxt product_line +$! +$! +$! First insert the Readme file. +$! +$ open/read rf 'readme_file' +$! +$ write ptxt "1 'PRODUCT" +$ write ptxt "=prompt ''producter' ''product' for OpenVMS" +$! +$rf_loop: +$ read/end=rf_loop_end rf line_in +$ if line_in .nes. "" +$ then +$! PCSI files use the first character in for their purposes. +$!-------------------------------------------------------------- +$ first_char = f$extract(0, 1, line_in) +$ if first_char .nes. " " then line_in = " " + line_in +$ endif +$ write ptxt line_in +$ goto rf_loop +$rf_loop_end: +$ close rf +$! +$! +$! Now add in the copying file +$!-------------------------------- +$ write ptxt "" +$ write ptxt "1 'NOTICE" +$ write ptxt "" +$! +$ open/read cf 'copying_file' +$! +$cf_loop: +$ read/end=cf_loop_end cf line_in +$ if line_in .nes. "" +$ then +$! PCSI files use the first character in for their purposes. +$!-------------------------------------------------------------- +$ first_char = f$extract(0, 1, line_in) +$ if first_char .nes. " " then line_in = " " + line_in +$ endif +$ write ptxt line_in +$ goto cf_loop +$cf_loop_end: +$ close cf +$! +$! Now we need the rest of the boiler plate. +$!-------------------------------------------- +$ write ptxt "" +$ write ptxt "1 'PRODUCER" +$ write ptxt "=prompt ''producer_full_name'" +$ write ptxt - + "This software product is provided by ''producer_full_name' with no warranty." +$! +$ arch_type = f$getsyi("ARCH_NAME") +$ node_swvers = f$getsyi("node_swvers") +$ vernum = f$extract(1, f$length(node_swvers), node_swvers) +$ majver = f$element(0, ".", vernum) +$ minverdash = f$element(1, ".", vernum) +$ minver = f$element(0, "-", minverdash) +$ dashver = f$element(1, "-", minverdash) +$ if dashver .eqs. "-" then dashver = "" +$ vmstag = majver + minver + dashver +$ code = f$extract(0, 1, arch_type) +$! +$ write ptxt "1 NEED_VMS''vmstag'" +$ write ptxt - + "=prompt OpenVMS ''vernum' or later is not installed on your system." +$ write ptxt "This product requires OpenVMS ''vernum' or later to function." +$ write ptxt "1 NEED_ZLIB" +$ write ptxt "=prompt ZLIB 1.2-8 or later is not installed on your system." +$ write ptxt "This product requires ZLIB 1.2-8 or later to function." +$ write ptxt "1 SOURCE" +$ write ptxt "=prompt Source modules for ''product'" +$ write ptxt "The Source modules for ''product' will be installed." +$ write ptxt "1 RELEASE_NOTES" +$ write ptxt "=prompt Release notes are available in the [SYSHLP] directory." +$! +$ close ptxt +$! +$! +$! +$all_exit: +$ exit diff --git a/3rdparty/curl-8.21.0/projects/vms/build_gnv_curl_release_notes.com b/3rdparty/curl-8.21.0/projects/vms/build_gnv_curl_release_notes.com new file mode 100644 index 0000000000..89b30ecbe9 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/build_gnv_curl_release_notes.com @@ -0,0 +1,100 @@ +$! File: Build_GNV_curl_release_notes.com +$! +$! Build the release note file from the four components: +$! 1. The curl_release_note_start.txt +$! 2. The hp_ssl_release_info.txt +$! 3. [--]readme. file from the curl distribution. +$! 4. The Curl_gnv-build_steps.txt. +$! +$! Set the name of the release notes from the GNV_PCSI_FILENAME_BASE +$! logical name. +$! +$! Copyright (C) John Malmberg +$! +$! Permission to use, copy, modify, and/or distribute this software for any +$! purpose with or without fee is hereby granted, provided that the above +$! copyright notice and this permission notice appear in all copies. +$! +$! THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +$! WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +$! MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +$! ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +$! WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +$! ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT +$! OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +$! +$! SPDX-License-Identifier: ISC +$! +$!=========================================================================== +$! +$ base_file = f$trnlnm("GNV_PCSI_FILENAME_BASE") +$ if base_file .eqs. "" +$ then +$ write sys$output "@MAKE_PCSI_CURL_KIT_NAME.COM has not been run." +$ goto all_exit +$ endif +$! +$! +$ curl_readme = f$search("sys$disk:[--]readme.") +$ if curl_readme .eqs. "" +$ then +$ curl_readme = f$search("sys$disk:[--]$README.") +$ endif +$ if curl_readme .eqs. "" +$ then +$ write sys$output "Can not find curl readme file." +$ goto all_exit +$ endif +$! +$ curl_copying = f$search("sys$disk:[--]copying.") +$ if curl_copying .eqs. "" +$ then +$ curl_copying = f$search("sys$disk:[--]$COPYING.") +$ endif +$ if curl_copying .eqs. "" +$ then +$ write sys$output "Can not find curl copying file." +$ goto all_exit +$ endif +$! +$ vms_readme = f$search("sys$disk:[]readme.") +$ if vms_readme .eqs. "" +$ then +$ vms_readme = f$search("sys$disk:[]$README.") +$ endif +$ if vms_readme .eqs. "" +$ then +$ write sys$output "Can not find VMS specific curl readme file." +$ goto all_exit +$ endif +$! +$ curl_release_notes = f$search("sys$disk:[--]release-notes.") +$ if curl_release_notes .eqs. "" +$ then +$ curl_release_notes = f$search("sys$disk:[--]$RELEASE-NOTES.") +$ endif +$ if curl_release_notes .eqs. "" +$ then +$ write sys$output "Can not find curl release-notes file." +$ goto all_exit +$ endif +$! +$ if f$search("sys$disk:[]hp_ssl_release_info.txt") .eqs. "" +$ then +$ write sys$output "GNV_LINK_CURL.COM has not been run!" +$ goto all_exit +$ endif +$! +$ type/noheader 'curl_readme', 'vms_readme', - + 'curl_release_notes', - + sys$disk:[]curl_release_note_start.txt, - + sys$disk:[]hp_ssl_release_info.txt, - + 'curl_copying', - + sys$disk:[]curl_gnv_build_steps.txt - + /out='base_file'.release_notes +$! +$ purge 'base_file'.release_notes +$ rename 'base_file.release_notes ;1 +$! +$all_exit: +$ exit diff --git a/3rdparty/curl-8.21.0/projects/vms/build_libcurl_pc.com b/3rdparty/curl-8.21.0/projects/vms/build_libcurl_pc.com new file mode 100644 index 0000000000..de7db26958 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/build_libcurl_pc.com @@ -0,0 +1,202 @@ +$! File: build_libcurl_pc.com +$! +$! Build the libcurl.pc file from the libcurl.pc.in file +$! +$! Copyright (C) John Malmberg +$! +$! Permission to use, copy, modify, and/or distribute this software for any +$! purpose with or without fee is hereby granted, provided that the above +$! copyright notice and this permission notice appear in all copies. +$! +$! THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +$! WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +$! MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +$! ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +$! WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +$! ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT +$! OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +$! +$! SPDX-License-Identifier: ISC +$! +$!=========================================================================== +$! +$! Skip this if the libcurl.pc already exists. +$ if f$search("[--]libcurl.pc") .nes. "" then goto all_exit +$! +$! Need to know the kit type. +$ kit_name = f$trnlnm("GNV_PCSI_KITNAME") +$ if kit_name .eqs. "" +$ then +$ write sys$output "@MAKE_PCSI_CURL_KIT_NAME.COM has not been run." +$ goto all_exit +$ endif +$! +$! +$! Parse the kit name into components. +$!--------------------------------------- +$ producer = f$element(0, "-", kit_name) +$ base = f$element(1, "-", kit_name) +$ product = f$element(2, "-", kit_name) +$ mmversion = f$element(3, "-", kit_name) +$ majorver = f$extract(0, 3, mmversion) +$ minorver = f$extract(3, 2, mmversion) +$ updatepatch = f$element(4, "-", kit_name) +$ if updatepatch .eqs. "-" then updatepatch = "" +$! +$! kit type of "D" means a daily build +$ kit_type = f$edit(f$extract(0, 1, majorver), "upcase") +$! +$ pc_file_in = "[--]libcurl^.pc.in" +$! +$ if f$search(pc_file_in) .eqs. "" +$ then +$ pc_file_in = "[--]libcurl.pc$5nin" +$ if f$search(pc_file_in) .eqs. "" +$ then +$ pc_file_in = "[--]libcurl.pc_in" +$ if f$search(pc_file_in) .eqs. "" +$ then +$ write sys$output "Can not find libcurl.pc.in." +$ goto all_exit +$ endif +$ endif +$ endif +$! +$ if (f$getsyi("HW_MODEL") .lt. 1024) +$ then +$ arch_name = "VAX" +$ else +$ arch_name = "" +$ arch_name = arch_name + f$edit(f$getsyi("ARCH_NAME"), "UPCASE") +$ if (arch_name .eqs. "") then arch_name = "UNK" +$ endif +$! +$! +$ curl_version = "0.0.0" +$ open/read vf [--.src]tool_version.h +$version_loop: +$ read vf/end=version_loop_end line_in +$ if line_in .eqs. "" then goto version_loop +$ key = f$element(0, " ", line_in) +$ if key .nes. "#define" then goto version_loop +$ name = f$element(1, " ", line_in) +$ if name .eqs. "VERSION" +$ then +$ curl_version = f$element(2, " ", line_in) - """" - """" +$ else +$ goto version_loop +$ endif +$version_loop_end: +$ close vf +$! +$! +$ create [--]libcurl.pc +$ open/append pco [--]libcurl.pc +$ open/read pci 'pc_file_in' +$pc_file_loop: +$ read pci/end=pc_file_loop_end line_in +$! +$! blank lines +$ if line_in .eqs. "" +$ then +$ write pco "" +$ goto pc_file_loop +$ endif +$! +$! comment lines +$ key = f$extract(0, 1, line_in) +$ if key .eqs. "#" +$ then +$ write pco line_in +$ goto pc_file_loop +$ endif +$! +$! Special handling for libs. +$ if f$locate("Libs:", line_in) .eq. 0 +$ then +$ write pco "#",line_in +$ goto pc_file_loop +$ endif +$! No substitution line +$ line_in_len = f$length(line_in) +$ if f$locate("@", line_in) .ge. line_in_len +$ then +$ write pco line_in +$ goto pc_file_loop +$ endif +$! +$ if f$locate("@prefix@", line_in) .lt line_in_len +$ then +$ if kit_type .nes. "D" +$ then +$ write pco "prefix=/usr" +$ else +$ write pco "prefix=/beta" +$ endif +$ goto pc_file_loop +$ endif +$ if f$locate("@exec_prefix@", line_in) .lt line_in_len +$ then +$ if kit_type .nes. "D" +$ then +$ write pco "exec_prefix=/usr" +$ else +$ write pco "exec_prefix=/beta" +$ endif +$ goto pc_file_loop +$ endif +$ if f$locate("@libdir@", line_in) .lt line_in_len +$ then +$ write pco "libdir=$(exec_prefix}/lib" +$ goto pc_file_loop +$ endif +$ if f$locate("@includedir@", line_in) .lt line_in_len +$ then +$ write pco "includedir=$(prefix}/include" +$ goto pc_file_loop +$ endif +$ if f$locate("@SUPPORT_PROTOCOLS@", line_in) .lt line_in_len +$ then +$ proto1 = "DICT FILE FTP FTPS GOPHER HTTP HTTPS IMAP IMAPS" +$ proto2 = " LDAP LDAPS POP3 POP3S RTSP SMTP SMTPS TELNET TFTP" +$ proto = proto1 + proto2 +$ write pco "supported_protocols=""" + proto + """" +$ goto pc_file_loop +$ endif +$ if f$locate("@SUPPORT_FEATURES@", line_in) .lt line_in_len +$ then +$ if arch_name .eqs. "VAX" +$ then +$ write pco "supported_features=""SSL libz NTLM""" +$ else +$ write pco "supported_features=""SSL IPv6 libz NTLM""" +$ endif +$ goto pc_file_loop +$ endif +$ if f$locate("@CURLVERSION@", line_in) .lt line_in_len +$ then +$ write pco "Version: ''curl_version'" +$ goto pc_file_loop +$ endif +$ if f$locate("@LIBCURL_PC_LIBS_PRIVATE@", line_in) .lt line_in_len +$ then +$ if arch_name .eqs. "VAX" +$ then +$ write pco "Libs.private: -lssl -lcrypto -lz" +$ else +$ write pco "Libs.private: -lssl -lcrypto -lgssapi -lz" +$ endif +$ goto pc_file_loop +$ endif +$ if f$locate("@LIBCURL_PC_CFLAGS@", line_in) .lt line_in_len +$ then +$ write pco "Cflags: -I${includedir} -DCURL_STATICLIB" +$ goto pc_file_loop +$ endif +$! +$pc_file_loop_end: +$ close pco +$ close pci +$! +$all_exit: +$ exit diff --git a/3rdparty/curl-8.21.0/projects/vms/build_vms.com b/3rdparty/curl-8.21.0/projects/vms/build_vms.com new file mode 100644 index 0000000000..d79fdb5940 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/build_vms.com @@ -0,0 +1,1038 @@ +$! BUILD_VMS.COM +$! +$! I have taken the original build_vms.com, supplied by Nico Baggus, if +$! memory serves me correctly, and made some modifications. +$! +$! SSL support is controlled by logical names. If SSL$INCLUDE is +$! defined, then it is assumed that HP's SSL product has been installed. +$! If OPENSSL is defined, but SSL$INCLUDE is not, then OpenSSL will be +$! used. If neither logical name is defined, then SSL support will not +$! be compiled/linked in. Command-line options NOHPSSL and NOSSL can be +$! specified to override the automatic SSL selection. +$! +$! Command-line Options: +$! +$! CLEAN Delete product files for this host architecture. (No +$! build done.) +$! CLEAN_ALL Delete product files for all host architectures. (No +$! build done.) +$! +$! 64 Compile with 64-bit pointers. +$! Note, you must match the pointer size that the OpenSSL +$! shared image expects. +$! Currently curl is not building properly with 64-bit pointers +$! on VMS because it is trying to cast pointers to 32-bit +$! integers and some OpenVMS library routines called by curl +$! do not yet support 64-bit pointers. +$! CCQUAL=x Add "x" to the C compiler qualifiers. +$! Default qualifiers are: +$! /standard=relaxed +$! /names=(as_is, shortened) +$! /repository=[.'arch'] +$! /nested_include_directory=none +$! /define=(_LARGEFILE=1,_USE_STD_STAT=1) (non-vax) +$! /float=ieee/ieee_mode=denorm_results (non-vax) +$! DEBUG Compile debug and nooptimize +$! Alpha/IA64 always compiles /debug. +$! Always link a debug image. +$! NOIEEE Do not use IEEE floating point. (Alpha/I64) +$! VAX must always use DFLOAT +$! NOLARGE Disable large-file support if large file support available. +$! (Non-VAX, VMS >= v7.2.) +$! NOLDAP Disable LDAP support if LDAP is available. +$! NOKERBEROS Disable Kerberos support if Kerberos is available. +$! LIST Create C compiler listings and linker maps. +$! /list/show=(expan,includ)/machine +$! FULLLIST Full detailed listing. +$! /list/show=(all, nomessages)/machine +$! NOHPSSL Do not use HP SSL, even if available. +$! Note, you must match the pointer size that the OpenSSL +$! shared image expects. This procedure will select the +$! correct HP OpenSSL image. +$! NOSSL Do not use any SSL, even if available. +$! OSSLOLB Use OpenSSL object libraries (.OLB), even if shared +$! images (.EXE) are available. +$! NOZLIB Do not use GNV$ZLIB shared image even if available. +$! REALCLEAN Delete product files for all host architectures. (No +$! build done.) Alias for CLEAN_ALL +$! +$! DCL Symbols: +$! +$! CURL_CCDEFS="c_macro_1=value1 [, c_macro_2=value2 [...]]" +$! Compile with these additional C macros defined. +$! +$! Revisions: +$! +$! 2-DEC-2003, MSK, the "original" version. +$! It works for me. Your mileage may vary. +$! 13-JAN-2004, MSK, moved this procedure to the [.projects.vms] directory +$! and updated it to do hardware dependent builds. +$! 29-JAN-2004, MSK, moved logical defines into defines.com +$! 6-FEB-2004, MSK, put in various SSL support bits +$! 9-MAR-2004, MSK, the config-vms.h* files are now copied to the lib and +$! src directories as curl_config.h. +$! 15-MAR-2004, MSK, All of the curlmsg*.* files have also been moved to +$! this build directory. They will be copied to the src +$! directory before build. The .msg file will be compiled +$! to get the .obj for messages, but the .h and .sdl files +$! are not automatically created since they partly rely on +$! the freeware SDL tool. +$! 8-FEB-2005, MSK, merged the two config-vms.h* files into one that uses +$! USE_SSLEAY to define if the target has SSL support built +$! in. Changed the cc/define parameter accordingly. +$! 11-FEB-2005, MSK, If [--.LIB]AMIGAOS.C and NWLIB.C are there, rename them +$! 23-MAR-2005, MSK, relocated cc_qual define so that DEBUG option would work +$! 25-APR-2007, STL, allow compilation in 64-bit mode. +$! 13-DEC-2009. SMS, Changed to skip unwanted source files without +$! renaming the original files. +$! Eliminated needless, persistent logical names. +$! Added CURL_CCDEFS DCL symbol for user-specified C +$! macro definitions. +$! Added CLEAN and CLEAN_ALL options. +$! Added CCQUAL option for user-specified C compiler +$! qualifiers. +$! Added IEEE option for IEEE floating point (Alpha). +$! Added LARGE option for large-file support. +$! Added OSSLOLB option, and support for OpenSSL +$! shared images. +$! Changed to put listing and map files into lisdir:. +$! Changed to avoid case confusion on ODS5 disks. +$! Added more default dev:[dir] save+restore. +$! Moved remaining "defines.com" code (back) into +$! here, eliminating the hard-coded OpenSSL nonsense. +$! Changed to use F$GETSYI("ARCH_NAME") (or +$! equivalent) to name architecture-specific product +$! file destination directory, and to create the +$! directory if needed (obviating inclusion of these +$! directories and dummy files in the distribution +$! kit). +$! Changed the "compile" subroutine to break the CC +$! command across multiple lines to avoid DCL +$! line-too-long problems. +$! Changed "vo_c" messages to show the CC qualifiers +$! once, not with every compile command. +$! 01-Jan-2013 J. Malmberg +$! VMS build procedures need to be able to work with +$! the default set to a search list, with created or +$! modified files only in the first member of the search +$! list. +$! Whitespace change to be more compatible with current +$! practices. +$! One pass option parsing instead of loop. +$! GNV ZLIB shared image support. +$! KERBEROS support where available. +$! LDAP default to on where available +$! LARGEFILE default to on where available +$! IEEE float default to on where available. +$! Generate the curl_config.h file from system inspection. +$! Linker finds ldap with out option file. +$! 13-Mar-2013, Tom Grace +$! Added missing slash in cc_full_list. +$! Removed unwanted extra quotes inside symbol tool_main +$! for non-VAX architectures that triggered link failure. +$! Replaced curl_sys_inc with sys_inc. +$! 19-Mar-2013, John Malmberg +$! symbol tool_main needs to be quoted when parse style is +$! set to extended in versions of VMS greater than 7.3-1. +$! Remove curlbuild.h generation as it should be pre-built +$! in the curl release or daily tarball. +$! 12-Jul-2013, John Malmberg +$! Adjust to find and use ZLIB from the Jean-Francois +$! Pieronne shared image and newer GNV ZLIB kit that +$! is upward compatible with Jean-Francois's kit. +$! Remove tabs from file. +$! Fixed DCL formatting as follows: +$! * Labels have no space after leading $. +$! * 1 space after $ for first level. +$! * 3 spaces after $ for second level. Line start + 4. +$! * 7 spaces after $ for third level. Line start + 8. +$! * Each level after that indents 4 characters. +$! * then/else/endif same indentation as if statement. +$! 17-Nov-2014, Michael Steve +$! Modified build to handle new location of the VTLS lib +$! source within zip archive. Not a pretty fix. +$! +$!=========================================================================== +$! +$! +$! Save the original default dev:[dir], and arrange for its restoration +$! at exit. +$!------------------------------------------------------------------------ +$ curl = "" +$ orig_def = f$environment("DEFAULT") +$ on error then goto Common_Exit +$ on control_y then goto Common_Exit +$! +$ ctrl_y = 1556 +$ proc = f$environment("PROCEDURE") +$ proc_fid = f$file_attributes(proc, "FID") +$ proc_dev = f$parse(proc, , , "DEVICE") +$ proc_dir = f$parse(proc, , , "DIRECTORY") +$ proc_name = f$parse(proc, , , "NAME") +$ proc_type = f$parse(proc, , , "TYPE") +$ proc_dev_dir = proc_dev + proc_dir +$! +$! Have to manually parse the device for a search list. +$! Can not use the f$parse() as it will return the first name +$! in the search list. +$! +$ orig_def_dev = f$element(0, ":", orig_def) + ":" +$ if orig_def_dev .eqs. "::" then orig_def_dev = "sys$disk:" +$ test_proc = orig_def_dev + proc_dir + proc_name + proc_type +$! +$! If we can find this file using the default directory +$! then we know that we should use the original device from the +$! default directory which could be a search list. +$! +$ test_proc_fid = f$file_attributes(test_proc, "FID") +$! +$ if (test_proc_fid .eq. proc_fid) +$ then +$ proc_dev_dir = orig_def_dev + proc_dir +$ endif +$! +$! +$! Verbose output message stuff. Define symbol to "write sys$output" or "!". +$! vo_c - verbose output for compile +$! vo_l - link +$! vo_o - object check +$! +$ vo_c := "write sys$output" +$ vo_l := "write sys$output" +$ vo_o := "!" +$! +$! Determine the main distribution directory ("[--]") in an +$! ODS5-tolerant (case-insensitive) way. (We do assume that the only +$! "]" or ">" is the one at the end.) +$! +$! Some non-US VMS installations report ">" for the directory delimiter +$! so do not assume that it is "]". +$! +$ orig_def_len = f$length(orig_def) +$ delim = f$extract(orig_def_len - 1, 1, orig_def) +$! +$ set default 'proc_dev_dir' +$ set default [--] +$ base_dev_dir = f$environment("default") +$ top_dev_dir = base_dev_dir - delim +$! +$! +$! +$! Define the architecture-specific product file destination directory +$! name(s). +$! +$ parse_style = "TRADITIONAL" +$ if (f$getsyi("HW_MODEL") .lt. 1024) +$ then +$ arch_name = "VAX" +$ else +$ arch_name = "" +$ arch_name = arch_name + f$edit(f$getsyi("ARCH_NAME"), "UPCASE") +$ if (arch_name .eqs. "") then arch_name = "UNK" +$! +$! Extended parsing option starts with VMS 7.3-1. +$! There is no 7.4, so that simplifies the parse a bit. +$! +$ node_swvers = f$getsyi("node_swvers") +$ version_patch = f$extract(1, f$length(node_swvers), node_swvers) +$ maj_ver = f$element(0, ".", version_patch) +$ min_ver_patch = f$element(1, ".", version_patch) +$ min_ver = f$element(0, "-", min_ver_patch) +$ patch = f$element(1, "-", min_ver_patch) +$ if patch .eqs. "-" then patch = "" +$ parse_x = 0 +$ if maj_ver .ges. "8" +$ then +$ parse_x = 1 +$ else +$ if maj_ver .eqs. "7" .and. min_ver .ges. "3" .and. patch .nes. "" +$ then +$ parse_x = 1 +$ endif +$ endif +$ if parse_x +$ then +$ parse_style = f$getjpi("", "parse_style_perm") +$ endif +$ endif +$! +$ exedir = proc_dev_dir - delim + ".''arch_name'" + delim +$ lisdir = exedir +$ objdir = exedir +$! +$! When building on a search list, need to do a create to make sure that +$! the output directory exists, since the clean procedure tries to delete +$! it. +$ create/dir 'exedir'/prot=o:rwed +$! +$! Interpret command-line options. +$! +$ hpssl = 0 +$ ldap = 1 +$ list = 0 +$ full_list = 0 +$ nohpssl = 0 +$ nossl = 0 +$ openssl = 0 +$ osslolb = 0 +$ nozlib = 0 +$ nokerberos = 0 +$ cc_names = "/names=(shortened, as_is)/repository='exedir' +$ cc_defs = "HAVE_CONFIG_H=1" +$ cc_list = "/list='objdir'/show=(expan, includ)/machine +$ cc_full_list = "/list='objdir'/show=(all, nomessages)/machine +$ link_qual = "" +$ if arch_name .eqs. "VAX" +$ then +$ cc_debug = "/nodebug/optimize" +$ !cc_defs = cc_defs + "" +$ cc_float = "" +$ cc_large = "" +$ else +$ cc_debug = "/debug/optimize" +$ cc_defs = cc_defs + ",_USE_STD_STAT" +$ cc_float = "/float=ieee/ieee_mode=denorm_results" +$ cc_large = ",_LARGEFILE" +$ endif +$ cc_qual1 = "" +$ cc_qual2 = "" +$ if (f$type(CURL_CCDEFS) .nes. "") +$ then +$ CURL_CCDEFS = f$edit(CURL_CCDEFS, "TRIM") +$ cc_defs = cc_defs + ", " + CURL_CCDEFS +$ endif +$ msg_qual = "/object = ''objdir'" +$ ssl_opt = "" +$! +$! Allow arguments to be grouped together with comma or separated by spaces +$! Do no know if we will need more than 8. +$ args = "," + p1 + "," + p2 + "," + p3 + "," + p4 + "," +$ args = args + p5 + "," + p6 + "," + p7 + "," + p8 + "," +$! +$! Provide lower case version to simplify parsing. +$ args_lower = f$edit(args, "LOWERCASE,COLLAPSE") +$! +$ args_len = f$length(args) +$ args_lower_len = f$length(args_lower) +$! +$ clean = 0 +$ if f$locate(",clean,", args_lower) .lt. args_lower_len +$ then +$ clean = 1 +$ endif +$ clean_all = 0 +$ if f$locate(",clean_all,", args_lower) .lt. args_lower_len +$ then +$ clean = 1 +$ clean_all = 1 +$ endif +$ if f$locate(",realclean,", args_lower) .lt. args_lower_len +$ then +$ clean = 1 +$ clean_all = 1 +$ endif +$! +$ if clean .ne. 0 +$ then +$ prods = "''exedir'*.*;*" +$ if (f$search(prods) .nes. "") then delete /log 'prods' +$ prods = proc_dev_dir + arch_name + ".DIR;1" +$ if (f$search(prods) .nes. "") then set prot=o:rwed 'prods' +$ if (f$search(prods) .nes. "") then delete /log 'prods' +$ file = "[]config_vms.h" +$ if f$search(file) .nes. "" then delete/log 'file';* +$ file = "[]config.h" +$ if f$search(file) .nes. "" then delete/log 'file';* +$ file = "[]curl-config." +$ if f$search(file) .nes. "" then delete/log 'file';* +$ file = "[]libcurl.pc" +$ if f$search(file) .nes. "" then delete/log 'file';* +$ file = "[.lib.cxx_repository]cxx$demangler_db." +$ if f$search(file) .nes. "" then delete/log 'file';* +$ file = "[.src.cxx_repository]cxx$demangler_db." +$ if f$search(file) .nes. "" then delete/log 'file';* +$ file = "[.lib]config_vms.h" +$ if f$search(file) .nes. "" then delete/log 'file';* +$ file = "[...]curl_crtl_init" +$ if f$search("''file'.lis") .nes. "" then delete/log 'file'.lis;* +$ if f$search("''file'.obj") .nes. "" then delete/log 'file'.obj;* +$ file = "[...]gnv$curlmsg" +$ if f$search("''file'.lis") .nes. "" then delete/log 'file'.lis;* +$ if f$search("''file'.obj") .nes. "" then delete/log 'file'.obj;* +$ if f$search("''file'.exe") .nes. "" then delete/log 'file'.exe;* +$ file = "[...]curlmsg" +$ if f$search("''file'.lis") .nes. "" then delete/log 'file'.lis;* +$ if f$search("''file'.obj") .nes. "" then delete/log 'file'.obj;* +$ if f$search("''file'.exe") .nes. "" then delete/log 'file'.exe;* +$ file = "[...]report_openssl_version" +$ if f$search("''file'.lis") .nes. "" then delete/log 'file'.lis;* +$ if f$search("''file'.obj") .nes. "" then delete/log 'file'.obj;* +$ if f$search("''file'.exe") .nes. "" then delete/log 'file'.exe;* +$ file = "[...]hp_ssl_release_info.txt" +$ if f$search(file) .nes. "" then delete/log 'file';* +$ file = "[...]gnv_libcurl_xfer.mar_exact" +$ if f$search(file) .nes. "" then delete/log 'file';* +$ file = "[...]gnv_libcurl_xfer" +$ if f$search("''file'.lis") .nes. "" then delete/log 'file'.lis;* +$ if f$search("''file'.obj") .nes. "" then delete/log 'file'.obj;* +$ if f$search("''file'.opt") .nes. "" then delete/log 'file'.opt;* +$ file = "[...]curl-*_original_src.bck" +$ if f$search(file) .nes. "" then delete/log 'file';* +$ file = "[...]curl_d-*_original_src.bck" +$ if f$search(file) .nes. "" then delete/log 'file';* +$ file = "[...]curl-*_vms_src.bck" +$ if f$search(file) .nes. "" then delete/log 'file';* +$ file = "[...]curl_d-*_vms_src.bck" +$ if f$search(file) .nes. "" then delete/log 'file';* +$ file = "[...]curl-*.release_notes" +$ if f$search(file) .nes. "" then delete/log 'file';* +$ file = "[...]curl_d-*.release_notes" +$ if f$search(file) .nes. "" then delete/log 'file';* +$ file = "[...]*curl*.pcsi$desc" +$ if f$search(file) .nes. "" then delete/log 'file';* +$ file = "[...]*curl_d*.pcsi$desc" +$ if f$search(file) .nes. "" then delete/log 'file';* +$ file = "[...]*curl*.pcsi$text" +$ if f$search(file) .nes. "" then delete/log 'file';* +$ file = "[...]*curl_d*.pcsi$text" +$ if f$search(file) .nes. "" then delete/log 'file';* +$! +$ if clean_all .eq. 0 then goto Common_Exit +$ endif +$! +$! +$ if clean_all .ne. 0 +$ then +$ file = "[...]gnv$libcurl" +$ if f$search("''file'.exe") .nes. "" then delete/log 'file'.exe;* +$ if f$search("''file'.map") .nes. "" then delete/log 'file'.map;* +$ if f$search("''file'.dsf") .nes. "" then delete/log 'file'.dsf;* +$ file = "[.src]curl" +$ if f$search("''file'.exe") .nes. "" then delete/log 'file'.exe;* +$ if f$search("''file'.map") .nes. "" then delete/log 'file'.map;* +$ if f$search("''file'.dsf") .nes. "" then delete/log 'file'.dsf;* +$ prods = proc_dev_dir - delim + ".ALPHA" + delim + "*.*;*" +$ if (f$search(prods) .nes. "") then delete /log 'prods' +$ prods = proc_dev_dir + "ALPHA" + ".DIR;1" +$ if (f$search(prods) .nes. "") then set prot=o:rwed 'prods' +$ if (f$search(prods) .nes. "") then delete /log 'prods' +$ prods = proc_dev_dir - delim + ".IA64" + delim + "*.*;*" +$ if (f$search(prods) .nes. "") then delete /log 'prods' +$ prods = proc_dev_dir + "IA64" + ".DIR;1" +$ if (f$search(prods) .nes. "") then set prot=o:rwed 'prods' +$ if (f$search(prods) .nes. "") then delete /log 'prods' +$ prods = proc_dev_dir - delim + ".VAX" + delim + "*.*;*" +$ if (f$search(prods) .nes. "") then delete /log 'prods' +$ prods = proc_dev_dir + "VAX"+ ".DIR;1" +$ if (f$search(prods) .nes. "") then set prot=o:rwed 'prods' +$ if (f$search(prods) .nes. "") then delete /log 'prods' +$ file = "[...]macro32_exactcase" +$ if f$search("''file'.exe") .nes. "" then delete/log 'file'.exe;* +$ if f$search("''file'.jnl") .nes. "" then delete/log 'file'.jnl;* +$ goto Common_Exit +$ endif +$! +$ build_64 = 0 +$ if f$locate(",64,", args_lower) .lt. args_lower_len +$ then +$ cc_qual1 = cc_qual1 + " /POINTER = 64" +$ build_64 = 1 +$ endif +$! +$ args_loc = f$locate(",ccqual=", args_lower) +$ if args_loc .lt. args_lower_len +$ then +$ arg = f$extract(args_loc + 1, args_lower_len, args_lower) +$ arg_val = f$element(0, ",", arg) +$ cc_qual2 = f$element(1, "=", arg_val); +$ endif +$! +$! On Alpha/IA64 no size penalty for compiling /debug/optimize +$! by default. +$ if f$locate(",debug,", args_lower) .lt. args_lower_len +$ then +$ cc_debug = "/debug/nooptimize" +$ endif +$! +$! We normally want IEEE float if it is available. Programs that are +$! calling libcurl will typically prefer IEEE behavior, unless on the +$! VAX where we have no choice. +$! +$ if f$locate(",noieee,", args_lower) .lt. args_lower_len +$ then +$ cc_float = "" +$ endif +$! +$! Normally we want large file if it is available. +$ if f$locate(",nolarge,", args_lower) .lt. args_lower_len +$ then +$ write sys$output "Handling of large files disabled." +$ cc_large = "" +$ endif +$ if cc_large .nes. "" +$ then +$ cc_defs = cc_defs + cc_large +$ endif +$! +$ if f$locate(",noldap,", args_lower) .lt. args_lower_len +$ then +$ ldap = 0 +$ endif +$! +$ if f$locate(",list,", args_lower) .lt. args_lower_len +$ then +$ list = 1 +$ endif +$ if f$locate(",fulllist,", args_lower) .lt. args_lower_len +$ then +$ list = 1 +$ full_list = 1 +$ endif +$! +$ if f$locate(",nohpssl,", args_lower) .lt. args_lower_len +$ then +$ nohpssl = 1 +$ endif +$! +$ if f$locate(",nossl,", args_lower) .lt. args_lower_len +$ then +$ nossl = 1 +$ endif +$! +$ if f$locate(",osslolb,", args_lower) .lt. args_lower_len +$ then +$ osslolb = 1 +$ endif +$! +$ if f$locate(",nozlib,", args_lower) .lt. args_lower_len +$ then +$ nozlib = 1 +$ endif +$! +$ if f$locate(",nokerberos,", args_lower) .lt. args_lower_len +$ then +$ nokerberos = 1 +$ endif +$! +$! +$! CC /LIST, LINK /MAP, and MESSAGE /LIST are defaults in batch mode, +$! so be explicit when they are not desired. +$! +$ +$ if list .eq. 0 +$ then +$ cc_qual1 = cc_qual1 + "/nolist" +$ msg_qual = msg_qual + "/nolist" +$ else +$ msg_qual = msg_qual + "/list='objdir'" +$ if (full_list .ne. 0) +$ then +$ cc_qual1 = cc_qual1 + cc_full_list +$ else +$ cc_qual1 = cc_qual1 + cc_list +$ endif +$ endif +$ cc_qual1 = cc_qual1 + cc_names + cc_float + cc_debug +$! +$! Create product directory, if needed. +$! +$ if (f$search(proc_dev_dir + arch_name + ".DIR;1") .eqs. "") +$ then +$ create /directory 'exedir' +$ endif +$! +$! Detect available (but not prohibited) SSL software. +$! +$ libsslshr_line = "" +$ libcryptoshr_line = "" +$ if (.not. nossl) +$ then +$ if (f$trnlnm("OPENSSL") .nes. "") +$ then +$! cc_defs = cc_defs + ", USE_OPENSSL=1" +$ if ((f$trnlnm("SSL$INCLUDE") .nes. "") .and. (.not. nohpssl)) +$ then +$! Use HP SSL. +$ hpssl = 1 +$! +$! Older SSL only has lib*_shr32 images +$!----------------------------------------------- +$ libsslshr = "sys$share:ssl$libssl_shr" +$ if (f$search("''libsslshr'.exe") .eqs. "") .or. (.not. build_64) +$ then +$ libsslshr = libsslshr + "32" +$ endif +$ libcryptoshr = "sys$share:ssl$libcrypto_shr" +$ if (f$search("''libcryptoshr'.exe") .eqs. "") .or. (.not. build_64) +$ then +$ libcryptoshr = libcryptoshr + "32" +$ endif +$ libsslshr_line = "''libsslshr'.exe/share" +$ libcryptoshr_line = "''libcryptoshr'.exe/share" +$ else +$! Use OpenSSL. Assume object libraries, unless shared images +$! are found (and not prohibited). +$! TODO: We do not know how to automatically choose based on the +$! pointer size. +$! +$ openssl = 1 +$ libsslshr_line = "ssllib:libssl.olb/lib" +$ libcryptoshr_line = "ssllib:libcrypto.olb/lib" +$ ssl_opt = ", ssllib:libssl.olb /library" + - + ", ssllib:libcrypto.olb /library" +$ if (osslolb .eq. 0) +$ then + if ((f$search("ssllib:ssl_libcrypto.exe") .nes. "") .and. - + (f$search("ssllib:ssl_libssl.exe") .nes. "")) +$ then +$! OpenSSL shared images with "SSL_xxx.EXE names. +$ openssl = 2 +$ libsslshr_line = "ssllib:ssl_libssl_shr.exe/share" +$ libcryptoshr_line = "ssllib:ssl_libcrypto_shr.exe/share" +$ else +$ if ((f$search("ssllib:libcrypto.exe") .nes. "") .and. - + (f$search("ssllib:libssl.exe") .nes. "")) +$ then +$! OpenSSL shared images with "xxx.EXE names. +$ openssl = 3 +$ libsslshr_line = "ssllib:libssl_shr.exe/share" +$ libcryptoshr_line = "ssllib:libcrypto_shr.exe/share" +$ endif +$ endif +$ endif +$ endif +$ endif +$ endif +$! +$! LDAP. +$! +$ if f$search("SYS$SHARE:LDAP$SHR.EXE") .eqs. "" +$ then +$ ldap = 0 +$ endif +$ if (ldap .eq. 0) +$ then +$! cc_defs = cc_defs + ", CURL_DISABLE_LDAP=1" +$ else +$ 'vo_c' "%CURL-I-BLDHPLDAP, building with HP LDAP support" +$ endif +$! +$! KERBEROS +$ gssrtlshr_line = "" +$ try_shr = "sys$share:gss$rtl" +$ if f$search("''try_shr'.exe") .eqs. "" +$ then +$ nokerberos = 1 +$ endif +$ curl_sys_krbinc = "" +$ if nokerberos .eq. 0 +$ then +$ 'vo_c' "%CURL-I-BLDHPKERBEROS, building with HP KERBEROS support" +$ curl_sys_krbinc = "sys$sysroot:[kerberos.include]" +$ gssrtlshr_line = "''try_shr'/share" +$ endif +$! +$! +$! LIBZ +$ libzshr_line = "" +$ try_shr = "gnv$libzshr" +$ if build_64 +$ then +$! First look for 64-bit +$ if f$search("''try_shr'64") .eqs. "" +$ then +$! Second look for the J.F. Pieronne 64-bit shared image +$ try_shr = "LIBZ_SHR64" +$ if f$search(try_shr) .eqs. "" then nozlib = 1 +$ endif +$ else +$! First look for 32-bit +$ if f$search("''try_shr'32") .eqs. "" +$ then +$! Second look for old 32-bit image +$ if f$search(try_shr) .eqs. "" +$ then +$! Third look for the J.F. Pieronne 32-bit shared image +$ try_shr = "LIBZ_SHR32" +$ if f$search(try_shr) .eqs. "" then nozlib = 1 +$ endif +$ endif +$ endif +$ if f$search(try_shr) .eqs. "" +$ then +$ nozlib = 1 +$ endif +$ curl_sys_zlibinc = "" +$ if nozlib .eq. 0 +$ then +$ libzshr_line = "''try_shr'/share" +$ if f$locate("LIBZ", try_shr) .eq. 0 +$ then +$ 'vo_c' "%CURL-I-BLDJFPLIBZ, building with JFP LIBZ support" +$ curl_sys_zlibinc = "LIBZ:" +$ else +$ 'vo_c' "%CURL-I-BLDGNVLIBZ, building with GNV LIBZ support" +$ curl_sys_zlibinc = "GNV$ZLIB_INCLUDE:" +$ endif +$ endif +$! +$! Form CC qualifiers. +$! +$ cc_defs = "/define = (''cc_defs')" +$ cc_qual2 = cc_qual2 + " /object = ''objdir'" +$ cc_qual2 = cc_qual2 + "/nested_include_directory=none" +$! +$ 'vo_c' "CC opts:", - + " ''cc_defs'", - + " ''cc_qual1'", - + " ''cc_qual2'" +$! +$! Inform the victim of our plans. +$! +$ if (hpssl) +$ then +$ 'vo_c' "%CURL-I-BLDHPSSL, building with HP SSL support" +$ else +$ if (openssl .ne. 0) +$ then +$ if (openssl .eq. 1) +$ then +$ 'vo_c' - + "%CURL-I-BLDOSSL_OLB, building with OpenSSL (object library) support" +$ else +$ 'vo_c' - + "%CURL-I-BLDOSSL_EXE, building with OpenSSL (shared image) support" +$ endif +$ else +$ 'vo_c' "%CURL-I-BLDNOSSL, building with NO SSL support" +$ endif +$ endif +$! +$! Announce destination and SSL directories. +$! +$ 'vo_c' " OBJDIR = ''objdir'" +$ 'vo_c' " EXEDIR = ''exedir'" +$! +$ if (openssl .ne. 0) +$ then +$ ssllib = f$trnlnm("ssllib") +$ if (ssllib .eqs. "") +$ then +$ ssllib = "(undefined)" +$ endif +$ 'vo_c' " SSLLIB = ''ssllib'" +$! +$! TODO: Why are we translating the logical name? +$! The logical aname used to find the shared image should be used +$! as translating it could result in the wrong location at run time. +$ if (openssl .eq. 1) +$ then +$ ossl_lib1 = f$trnlnm("ssllib")+ "LIBSSL.OLB" +$ ossl_lib2 = f$trnlnm("ssllib")+ "LIBCRYPTO.OLB" +$ msg = "object libraries" +$ else +$ if (openssl .eq. 2) +$ then +$ ossl_lib1 = f$trnlnm("ssllib")+ "SSL_LIBSSL.EXE" +$ ossl_lib2 = f$trnlnm("ssllib")+ "SSL_LIBCRYPTO.EXE" +$ else +$ ossl_lib1 = f$trnlnm("ssllib")+ "LIBSSL.EXE" +$ ossl_lib2 = f$trnlnm("ssllib")+ "LIBCRYPTO.EXE" +$ endif +$ msg = "shared images" +$ endif +$ if ((f$search(ossl_lib1) .eqs. "") .or. - + (f$search(ossl_lib2) .eqs. "")) +$ then +$ write sys$output "Cannot find OpenSSL ''msg':" +$ write sys$output " ''ossl_lib1'" +$ write sys$output " ''ossl_lib2'" +$ goto Common_Exit +$ endif +$ endif +$! +$! Define the "curl" (process) logical name for "#include ". +$! +$ curl = f$trnlnm("curl", "LNM$PROCESS") +$ if (curl .nes. "") +$ then +$ write sys$output "" +$ write sys$output - + "Process logical name ""curl"" is already defined, but this procedure" +$ write sys$output - + "would override that definition. Use a command like" +$ write sys$output - + " deassign /process curl" +$ write sys$output - + "to cancel that logical name definition, and then and re-run this procedure." +$ write sys$output "" +$ goto Common_Exit +$ endif +$ curl_logical = top_dev_dir + ".include.curl" + delim +$ curl_sys_inc2 = curl_logical +$ curl_sys_inc1 = top_dev_dir + ".include" + delim +$! define curl 'top_dev_dir'.include.curl'delim' +$! +$! Generate config file into the product directory. +$! +$! call MoveIfDiff [.lib]config-vms.h 'objdir'curl_config.h +$! +$ conf_params = "" +$ if nossl .ne. 0 then conf_params = conf_params + ",nossl" +$ if nohpssl .ne. 0 then conf_params = conf_params + ",nohpssl," +$ if ldap .eq. 0 then conf_params = conf_params + ",noldap," +$ if nozlib .ne. 0 then conf_params = conf_params + ",nozlib," +$ if nokerberos .ne. 0 then conf_params = conf_params + ",nokerberos" +$ conf_params = conf_params - "," +$! +$! +$ new_conf = f$search("''objdir'curl_config.h") +$ if new_conf .eqs. "" +$ then +$! set ver +$ write sys$output "Generating curl custom config_vms.h" +$ @'proc_dev_dir'generate_config_vms_h_curl.com ''conf_params' +$! +$ write sys$output "Generating curl_config.h" +$ conf_in = f$search("[.lib]curl_config*.*in") +$ if conf_in .eqs. "" +$ then +$ write sys$output "Can not find [.lib]curl_config*.*in file!" +$ goto common_exit +$ endif +$ @'proc_dev_dir'config_h.com 'conf_in' +$ copy config.h 'objdir'curl_config.h +$ delete config.h; +$! set nover +$ endif +$! +$! +$ on control_y then goto Common_Exit +$! +$ set default 'proc_dev_dir' +$ sys_inc = "''curl_sys_inc1', ''curl_sys_inc2', ''curl_logical'" +$ if curl_sys_krbinc .nes. "" +$ then +$ sys_inc = sys_inc + ",''curl_sys_krbinc'" +$ endif +$ if curl_sys_zlibinc .nes. "" +$ then +$ sys_inc = sys_inc + ",''curl_sys_zlibinc'" +$ endif +$! Build LIB +$ cc_include = "/include=([-.lib],[-.lib.vtls],[-.projects.vms]" +$ cc_include = cc_include + ",[-.projects.vms.''arch_name'])" +$ call build "[--.lib]" "*.c" "''objdir'CURLLIB.OLB" "amigaos, nwlib, nwos" +$ if ($status .eq. ctrl_y) then goto Common_Exit +$! Build VTLS +$ cc_include = "/include=([--.lib.vtls],[--.lib],[--.src]" +$ cc_include = cc_include + ",[--.projects.vms],[--.projects.vms.''arch_name'])" +$ call build "[--.lib.vtls]" "*.c" "''objdir'CURLLIB.OLB" "amigaos, nwlib, nwos" +$! Build SRC +$ cc_include = "/include=([-.src],[-.lib],[-.lib.vtls]" +$ cc_include = cc_include + ",[-.projects.vms],[-.projects.vms.''arch_name'])" +$ call build "[--.src]" "*.c" "''objdir'CURLSRC.OLB" +$ if ($status .eq. ctrl_y) then goto Common_Exit +$! Build MSG +$ call build "[]" "*.msg" "''objdir'CURLSRC.OLB" +$ if ($status .eq. ctrl_y) then goto Common_Exit +$! +$! +$ if (openssl .ne. 0) +$ then +$ if (openssl .eq. 1) +$ then +$ 'vo_l' "%CURL-I-LINK_OSSL, linking with OpenSSL (object library)" +$ else +$ 'vo_l' "%CURL-I-LINK_HPSSL, linking with OpenSSL (shared image)" +$ endif +$ else +$ if (hpssl) +$ then +$ 'vo_l' "%CURL-I-LINK_HPSSL, linking with HP SSL" +$ else +$ 'vo_l' "%CURL-I-LINK_NOSSL, linking with NO SSL support" +$ endif +$ endif +$! +$! +$! GNV helper files for building the test curl binary. +$!----------------------------------------------- +$ create 'exedir'gnv$curl.opt +$ open/append opt 'exedir'gnv$curl.opt +$ if libzshr_line .nes. "" then write opt libzshr_line +$ if gssrtlshr_line .nes. "" then write opt gssrtlshr_line +$ if libcryptoshr_line .nes. "" then write opt libcryptoshr_line +$ if libsslshr_line .nes. "" then write opt libsslshr_line +$ close opt +$! +$! +$! Create the libcurl +$!------------------------------------------------------ +$ create 'exedir'gnv_libcurl_linker.opt +$ open/append opt 'exedir'gnv_libcurl_linker.opt +$ if libzshr_line .nes. "" then write opt libzshr_line +$ if gssrtlshr_line .nes. "" then write opt gssrtlshr_line +$ if libcryptoshr_line .nes. "" then write opt libcryptoshr_line +$ if libsslshr_line .nes. "" then write opt libsslshr_line +$ close opt +$! +$! +$! If we are not on VAX, then we want the debug symbol table in +$! a separate file. +$! VAX needs the tool_main unquoted in uppercase, +$! Alpha and IA64 need tool_main quoted in exact case when parse style is +$! extended. +$ link_dsf1 = "" +$ link_dsf2 = "" +$ tool_main = "tool_main" +$ if arch_name .nes. "VAX" +$ then +$ if parse_style .eqs. "EXTENDED" +$ then +$ tool_main = """tool_main""" +$ endif +$ link_dsf1 = "/dsf=" + exedir + "CURL.DSF" +$ link_dsf2 = "/dsf=" + exedir + "CURL_DEBUG.DSF" +$ endif +$ if (list .eq. 0) +$ then +$ link_map1 = "/nomap" +$ link_map2 = "/nomap" +$ else +$ link_map1 = "/map=" + exedir + "CURL.MAP" +$ link_map2 = "/map=" + exedir + "CURL_DEBUG.MAP" +$ endif +$! +$! +$! Make a normal image. +$ set ver +$ link 'link_map1' 'link_dsf1' /executable = 'exedir'CURL.EXE - + 'objdir'curlsrc.olb /library /include = ('tool_main', curlmsg), - + 'objdir'curllib.olb /library, - + 'exedir'gnv$curl.opt/opt +$! +$! Also make a debug copy. +$ link/debug 'link_map2' 'link_dsf2' /executable = 'exedir'CURL_DEBUG.EXE - + 'objdir'curlsrc.olb /library /include = ('tool_main', curlmsg), - + 'objdir'curllib.olb /library, - + 'exedir'gnv$curl.opt/opt +$ set nover +$! +$ goto Common_Exit +$! +$! Subroutine to build everything with a filetype passed in via P2 in +$! the directory passed in via P1 and put it in the object library named +$! via P3. Exclude items in P4. +$! +$build: subroutine +$ build_def = f$environment("default") +$ on control_y then goto EndLoop ! SS$_CONTROLY +$ sts = 1 ! SS$_NORMAL. +$! set noon +$ set default 'p1' +$ search = "sys$disk:" + p2 +$ reset = f$search("reset") +$ if f$search( p3) .eqs. "" +$ then +$ librarian /create /object 'p3' +$ endif +$ reject_list__ = "," + f$edit(p4, "COLLAPSE, UPCASE") + "," +$ reject_list___len = f$length(reject_list__) +$ reset = f$search( "reset", 1) +$Loop: +$ file = f$search( search, 1) +$ if file .eqs. "" then goto EndLoop +$! Skip a name if it is in the P4 exclusion list. +$ if (p4 .nes. "") +$ then +$ name__ = "," + - + f$edit(f$parse(file, , , "NAME", "SYNTAX_ONLY"), "UPCASE") + - + "," +$ if (f$locate(name__, reject_list__) .lt. reject_list___len) +$ then +$ goto Loop +$ endif +$ endif +$ objfile = f$parse("''objdir'.OBJ;", file) +$ obj = f$search(objfile, 2) +$ if (obj .nes. "") +$ then +$ if (f$cvtime(f$file(file,"rdt")) .gts. f$cvtime(f$file(obj,"rdt"))) +$ then +$ call compile 'file' +$ sts = $status +$ if .not. sts +$ then +$ goto EndLoop +$ endif +$ librarian /object 'p3' 'objfile' +$ else +$ 'vo_o' "%CURL-I-OBJUTD, ", objfile, " is up to date" +$ endif +$ else +$ 'vo_o' "%CURL-I-OBJDNE, ", file, " does not exist" +$ call compile 'file' +$ sts = $status +$ if .not. sts +$ then +$ goto EndLoop +$ endif +$ librarian /object 'p3' 'objfile' +$ endif +$ goto Loop +$EndLoop: +$!!! purge +$ set default 'build_def' +$ exit 'sts' +$ endsubroutine ! Build +$! +$! Based on the file TYPE, do the right compile command. +$! Only C and MSG supported. +$! +$compile: subroutine +$ on control_y then return ctrl_y ! SS$_CONTROLY +$! set noon +$ file = p1 +$ qual = p2+ p3+ p4+ p5+ p6+ p7+ p8 +$ typ = f$edit(f$parse(file, , , "TYPE"), "UPCASE") - "." +$ if (typ .eqs. "C") +$ then +$ 'vo_c' "CC (opts) ", file +$ define/user curl 'curl_logical' +$ if curl_sys_krbinc .nes. "" then define/user gssapi 'curl_sys_krbinc' +$ define/user decc$system_include 'sys_inc' +$ CC 'cc_defs' - + 'cc_qual1' - + 'cc_qual2' - + 'cc_include' - + 'file' +$ else +$ cmd_msg = "MESSAGE " + msg_qual +$ x = cmd_'typ' +$ 'vo_c' x, " ", file +$ 'x' 'file' +$ endif +$ ENDSUBROUTINE ! Compile +$! +$! Do a diff of the file specified in P1 with that in P2. If different +$! copy P1 to P2. This also covers if P2 does not exist, but not if P2 +$! is an invalid filespec. +$! +$MoveIfDiff: subroutine +$ set NoOn +$ define /user_mode sys$error nl: +$ define /user_mode sys$output nl: +$ differences 'p1' 'p2' +$ status = $status +$ if (status .ne. %X006C8009) ! if status is not "no diff" +$ then +$ copy 'p1' 'p2' +$ purge /nolog 'p2' +$ endif +$ on control_y then return ctrl_y ! SS$_CONTROLY +$ ENDSUBROUTINE ! MoveIfDiff +$! +$Common_Exit: +$ set default 'orig_def' +$ exit diff --git a/3rdparty/curl-8.21.0/projects/vms/clean_gnv_curl.com b/3rdparty/curl-8.21.0/projects/vms/clean_gnv_curl.com new file mode 100644 index 0000000000..ab515ede6a --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/clean_gnv_curl.com @@ -0,0 +1,239 @@ +$! File: clean_gnv_curl.COM +$! +$! The GNV environment leaves behind some during the configure and build +$! procedure that need to be cleaned up. +$! +$! The default is to remove all the left over stuff from running the +$! configure script and to remove all intermediate binary files. +$! +$! This should be run with no parameters after the gnv_curl_configure.sh +$! script is run. +$! +$! Parameter P1: REALCLEAN +$! This removes all build products and brings the environment back to +$! the point where the gnv_curl_configure.sh procedure needs to be run again. +$! +$! Copyright (C) John Malmberg +$! +$! Permission to use, copy, modify, and/or distribute this software for any +$! purpose with or without fee is hereby granted, provided that the above +$! copyright notice and this permission notice appear in all copies. +$! +$! THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +$! WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +$! MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +$! ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +$! WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +$! ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT +$! OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +$! +$! SPDX-License-Identifier: ISC +$! +$!============================================================================ +$! +$! Save this so we can get back. +$ default_dir = f$environment("default") +$! +$! +$! Move to where the base directory is. +$ set def [--] +$! +$! +$ file = "sys$login:sh*." +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "sys$login:make*." +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[]confdefs.h" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[]conftest.dsf" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[]conftest.lis" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[]conftest.sym" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$! +$ file = "lcl_root:[.conf*...]*.*" +$ if f$search(file) .nes. "" then delete 'file';* +$ file = "lcl_root:[]conf*.dir +$ if f$search(file) .nes. "" then delete 'file';* +$! +$! +$ file = "lcl_root:[.lib]*.out" +$ if f$search(file) .nes. "" then delete 'file';* +$ file = "lcl_root:[.lib]*.o" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$! +$ file = "lcl_root:[.lib]*.lis" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[.src]*.lis" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[.src]cc_temp*." +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[.src]*.dsf" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[.src]*.o" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[.lib]ar*." +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[.lib]cc_temp*." +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[...]*.lo" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[...]*.a" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[...]*.la" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[...]*.lai" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[.projects.vms]curl-*_original_src.bck" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[.projects.vms]curl_d-*_original_src.bck" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[.projects.vms]curl-*_vms_src.bck" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[.projects.vms]curl_d-*_vms_src.bck" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[.projects.vms]curl-*.release_notes" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[.projects.vms]curl_d-*.release_notes" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[.projects.vms]*-curl-*.pcsi$desc" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[.projects.vms]*-curl_d-*.pcsi$desc" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[.projects.vms]*-curl-*.pcsi$text" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[.projects.vms]*-curl_d-*.pcsi$text" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$!====================================================================== +$! +$ if p1 .nes. "REALCLEAN" then goto all_exit +$! +$ file = "lcl_root:[...]*.obj" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[...]Makefile." +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[...]libtool." +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[...]*.lis" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[...]POTFILES." +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[]libcurl.pc" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[]curl-config." +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[]config.h" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[.src]config.h" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[.src]curl." +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[.tests]configurehelp.pm" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[.lib]config.h" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[.lib]curl_config.h" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[.lib]libcurl.vers" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[]ca-bundle.h" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[]config.log" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[]config.status" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[]conftest.dangle" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[]CXX$DEMANGLER_DB." +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[]stamp-h1." +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[...]stamp-h1." +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[...]stamp-h2." +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[...]stamp-h3." +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[.lib]*.a" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[...]*.spec" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[...]gnv$*.*" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[...]gnv*.opt" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[.projects.vms]macro32_exactcase.exe" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[.projects.vms]report_openssl_version.exe" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[.projects.vms]hp_ssl_release_info.txt" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$ file = "lcl_root:[.src]curl.exe" +$ if f$search(file) .nes. "" then delete 'file';* +$! +$all_exit: +$! +$! Put the default back. +$!----------------------- +$ set def 'default_dir' +$! +$ exit diff --git a/3rdparty/curl-8.21.0/projects/vms/compare_curl_source.com b/3rdparty/curl-8.21.0/projects/vms/compare_curl_source.com new file mode 100644 index 0000000000..b63080620e --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/compare_curl_source.com @@ -0,0 +1,363 @@ +$! Compare_curl_source.com +$! +$! This procedure compares the files in two directories and reports the +$! differences. It is customized for the vmsports repository layout. +$! +$! It needs to be customized to the local site directories. +$! +$! This is used by me for these purposes: +$! 1. Compare the original source of a project with an existing +$! VMS port. +$! 2. Compare the checked out repository of a project with the +$! the local working copy to make sure they are in sync. +$! 3. Keep a copy directory up to date. The third is needed by +$! me because VMS Backup can create a saveset of files from a +$! NFS mounted volume. +$! +$! First the files in the original source directory which is assumed to be +$! under source code control are compared with the copy directory. +$! +$! Only files present in the copy directory are listed. +$! +$! Diagnostics are displayed about the files: +$! 1. Files that are not generation 1. +$! 2. Files missing in the copy directory. +$! 3. Files in the copy directory not in the source directory. +$! 4. Files different from the source directory. +$! 5. Files that VMS DIFF can not process. +$! +$! This needs to be run on an ODS-5 volume. +$! +$! If UPDATE is given as a second parameter, files missing or different in the +$! copy directory will be updated. +$! +$! By default: +$! The directory src_root:[project_name] will be translated to something like +$! DISK:[dir.dir.reference.project_name] and this will be used +$! to calculate DISK:[dir.dir.vms_source.project_name] for the VMS specific +$! source directory. +$! +$! The copy directory is vms_root:[project_name] +$! The UPDATE parameter is ignored. +$! +$! This setting is used to make sure that the working vms directory +$! and the repository checkout directory have the same contents. +$! +$! If P1 is "SRCBCK" then this +$! The source directory tree is: src_root:[project_name] +$! The copy directory is src_root1:[project_name] +$! +$! src_root1:[project_name] is used by me to work around that VMS backup will +$! not use NFS as a source directory so I need to make a copy. +$! +$! This is to make sure that the backup save set for the unmodified +$! source is up to date. +$! +$! If your repository checkout is not on an NFS mounted volume, you do not +$! need to use this option or have the logical name src_root1 defined. +$! +$! If P1 is "VMSBCK" then this changes the two directories: +$! The source directory is vms_root:[project_name] +$! The copy directory is vms_root1:[project_name] +$! +$! vms_root:[project_name] is where I do the VMS specific edits. +$! vms_root1:[project_name] is used by me to work around that VMS backup will +$! not use NFS as a source directory so I need to make a copy. +$! +$! This is to make sure that the backup save set for the unmodified +$! source is up to date. +$! +$! Copyright (C) John Malmberg +$! +$! Permission to use, copy, modify, and/or distribute this software for any +$! purpose with or without fee is hereby granted, provided that the above +$! copyright notice and this permission notice appear in all copies. +$! +$! THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +$! WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +$! MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +$! ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +$! WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +$! ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT +$! OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +$! +$! SPDX-License-Identifier: ISC +$! +$!========================================================================== +$! +$! Update missing/changed files. +$ update_file = 0 +$ if (p2 .eqs. "UPDATE") +$ then +$ update_file = 1 +$ endif +$! +$ myproc = f$environment("PROCEDURE") +$ myprocdir = f$parse(myproc,,,"DIRECTORY") - "[" - "]" - "<" - ">" +$ myprocdir = f$edit(myprocdir, "LOWERCASE") +$ mydefault = f$environment("DEFAULT") +$ mydir = f$parse(mydefault,,,"DIRECTORY") +$ mydir = f$edit(mydir, "LOWERCASE") +$ odelim = f$extract(0, 1, mydir) +$ mydir = mydir - "[" - "]" - "<" - ">" +$ mydev = f$parse(mydefault,,,"DEVICE") +$! +$ ref = "" +$ if P1 .eqs. "" +$ then +$ ref_base_dir = myprocdir +$ wrk_base_dir = mydir +$ update_file = 0 +$ resultd = f$parse("src_root:",,,,"NO_CONCEAL") +$ resultd = f$edit(resultd, "LOWERCASE") +$ resultd = resultd - "][" - "><" - ".;" - ".." +$ resultd_len = f$length(resultd) - 1 +$ delim = f$extract(resultd_len, 1, resultd) +$ ref_root_base = mydir + delim +$ resultd = resultd - ref_root_base - "reference." + "vms_source." +$ ref = resultd + ref_base_dir +$ wrk = "VMS_ROOT:" + odelim + wrk_base_dir +$ resultd_len = f$length(resultd) - 1 +$ resultd = f$extract(0, resultd_len, resultd) + delim +$ ref_root_dir = f$parse(resultd,,,"DIRECTORY") +$ ref_root_dir = f$edit(ref_root_dir, "LOWERCASE") +$ ref_root_dir = ref_root_dir - "[" - "]" +$ ref_base_dir = ref_root_dir + "." + ref_base_dir +$ endif +$! +$ if p1 .eqs. "SRCBCK" +$ then +$ ref_base_dir = "curl" +$ wrk_base_dir = "curl" +$ ref = "src_root:[" + ref_base_dir +$ wrk = "src_root1:[" + wrk_base_dir +$ if update_file +$ then +$ if f$search("src_root1:[000000]curl.dir") .eqs. "" +$ then +$ create/dir/prot=o:rwed src_root1:[curl] +$ endif +$ endif +$ endif +$! +$! +$ if p1 .eqs. "VMSBCK" +$ then +$ ref_base_dir = "curl" +$ wrk_base_dir = "curl" +$ ref = "vms_root:[" + ref_base_dir +$ wrk = "vms_root1:[" + wrk_base_dir +$ if update_file +$ then +$ if f$search("vms_root1:[000000]curl.dir") .eqs. "" +$ then +$ create/dir/prot=o:rwed vms_root1:[curl] +$ endif +$ endif +$ endif +$! +$! +$ if ref .eqs. "" +$ then +$ write sys$output "Unknown compare type specified!" +$ exit 44 +$ endif +$! +$! +$! Future - check the device types involved for the +$! the syntax to check. +$ ODS2_SYNTAX = 0 +$ NFS_MANGLE = 0 +$ PWRK_MANGLE = 0 +$! +$ vax = f$getsyi("HW_MODEL") .lt. 1024 +$ if vax +$ then +$ ODS2_SYNTAX = 1 +$ endif +$! +$ report_missing = 1 +$! +$ if .not. ODS2_SYNTAX +$ then +$ set proc/parse=extended +$ endif +$! +$loop: +$ ref_spec = f$search("''ref'...]*.*;",1) +$ if ref_spec .eqs. "" then goto loop_end +$! +$ ref_dev = f$parse(ref_spec,,,"DEVICE") +$ ref_dir = f$parse(ref_spec,,,"DIRECTORY") +$ ref_dir = f$edit(ref_dir, "LOWERCASE") +$ ref_name = f$parse(ref_spec,,,"NAME") +$ ref_type = f$parse(ref_spec,,,"TYPE") +$! +$! +$ rel_path = ref_dir - "[" - ref_base_dir +$! rel_path_len = f$length(rel_path) - 1 +$! delim = f$extract(rel_path_len, 1, rel_path) +$! rel_path = rel_path - ".]" - ".>" - "]" - ">" +$! rel_path = rel_path + delim +$! +$ if ODS2_SYNTAX +$ then +$! if rel_path .eqs. ".examples.scripts^.noah]" +$! then +$! rel_path = ".examples.scripts_noah]" +$! endif +$! if rel_path .eqs. ".examples.scripts^.v2]" +$! then +$! rel_path = ".examples.scripts_v2]" +$! endif +$ endif +$! +$ wrk_path = wrk + rel_path +$! +$ ref_name_type = ref_name + ref_type +$! +$ if ODS2_SYNTAX +$ then +$ endif +$! +$ wrk_spec = wrk_path + ref_name_type +$! +$! +$ wrk_chk = f$search(wrk_spec, 0) +$ if wrk_chk .eqs. "" +$ then +$ if report_missing +$ then +$ write sys$output "''wrk_spec' is missing" +$ endif +$ if update_file +$ then +$ copy/log 'ref_spec' 'wrk_spec' +$ endif +$ goto loop +$ endif +$! +$ wrk_name = f$parse(wrk_spec,,,"NAME") +$ wrk_type = f$parse(wrk_spec,,,"TYPE") +$ wrk_fname = wrk_name + wrk_type" +$ ref_fname = ref_name + ref_type +$! +$ if ref_fname .nes. wrk_fname +$ then +$ write sys$output "''wrk_spc' wrong name, should be ""''ref_fname'""" +$ endif +$! +$ ref_type = f$edit(ref_type, "UPCASE") +$ if ref_type .eqs. ".DIR" then goto loop +$! +$ if ODS2_SYNTAX +$ then +$ ref_fname = f$edit(ref_fname, "LOWERCASE") +$ endif +$! +$! These files are in the wrong format for VMS diff, and we do not change them. +$ ref_skip = 0 +$ if ref_type .eqs. ".PDF" then ref_skip = 1 +$ if ref_type .eqs. ".HTML" then ref_skip = 1 +$ if ref_type .eqs. ".P12" then ref_skip = 1 +$ if ref_type .eqs. "." +$ then +$ if f$locate("test", ref_fname) .eq. 0 then ref_skip = 1 +$ if ref_fname .eqs. "configure." then ref_skip = 1 +$ endif +$! +$! +$ if ref_skip .ne. 0 +$ then +$ if report_missing +$ then +$ write sys$output "Skipping diff of ''ref_fname'" +$ endif +$ goto loop +$ endif +$! +$! +$ wrk_ver = f$parse(wrk_chk,,,"VERSION") +$ if wrk_ver .nes. ";1" +$ then +$ write sys$output "Version for ''wrk_spec' is not 1" +$ endif +$ set noon +$ diff/out=nl: 'wrk_spec' 'ref_spec' +$ if $severity .nes. "1" +$ then +$ write sys$output "''wrk_spec' is different from ''ref_spec'" +$ if update_file +$ then +$ delete 'wrk_spec';* +$ copy/log 'ref_spec' 'wrk_spec' +$ endif +$ endif +$ set on +$ +$! +$ goto loop +$loop_end: +$! +$! +$missing_loop: +$! For missing loop, check the latest generation. +$ ref_spec = f$search("''wrk'...]*.*;") +$ if ref_spec .eqs. "" then goto missing_loop_end +$! +$ ref_dev = f$parse(ref_spec,,,"DEVICE") +$ ref_dir = f$parse(ref_spec,,,"DIRECTORY") +$ ref_dir = f$edit(ref_dir, "LOWERCASE") +$ ref_name = f$parse(ref_spec,,,"NAME") +$ ref_type = f$parse(ref_spec,,,"TYPE") +$ ref_name_type = ref_name + ref_type +$! +$ rel_path = ref_dir - "[" - wrk_base_dir +$! +$! +$ wrk_path = ref + rel_path +$ wrk_spec = wrk_path + ref_name + ref_type +$ wrk_name = f$parse(wrk_spec,,,"NAME") +$ wrk_type = f$parse(wrk_spec,,,"TYPE") +$! +$ wrk_fname = wrk_name + wrk_type" +$ ref_fname = ref_name + ref_type +$! +$ wrk_skip = 0 +$ ref_utype = f$edit(ref_type,"UPCASE") +$ ref_ufname = f$edit(ref_fname,"UPCASE") +$! +$ if wrk_skip .eq. 0 +$ then +$ wrk_chk = f$search(wrk_spec, 0) +$ if wrk_chk .eqs. "" +$ then +$ if report_missing +$ then +$ write sys$output "''wrk_spec' is missing" +$ endif +$ goto missing_loop +$ endif +$ else +$ goto missing_loop +$ endif +$! +$ if ref_fname .nes. wrk_fname +$ then +$ write sys$output "''wrk_spc' wrong name, should be ""''ref_fname'""" +$ endif +$! +$ if ref_utype .eqs. ".DIR" then goto missing_loop +$! +$ wrk_ver = f$parse(wrk_chk,,,"VERSION") +$ if wrk_ver .nes. ";1" +$ then +$ write sys$output "Version for ''wrk_spec' is not 1" +$ endif +$! +$ goto missing_loop +$! +$! +$missing_loop_end: +$! +$exit diff --git a/3rdparty/curl-8.21.0/projects/vms/config_h.com b/3rdparty/curl-8.21.0/projects/vms/config_h.com new file mode 100644 index 0000000000..0b23cc6633 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/config_h.com @@ -0,0 +1,1932 @@ +$! File: config_h.com +$! +$! This procedure attempts to figure out how to build a config.h file +$! for the current project. +$! +$! P1 specifies the config.h.in file or equivalent. If it is not specified +$! then this procedure will search for several common names of the file. +$! +$! The CONFIGURE shell script will be examined for hints and a few symbols +$! but most of the tests will not produce valid results on OpenVMS. Some +$! will produce false positives and some will produce false negatives. +$! +$! It is easier to read the config.h_in file and make up tests based +$! on what is in it! +$! +$! This file will create an empty config_vms.h file if one does not exist. +$! The config_vms.h is intended for manual edits to handle things that +$! this procedure can not. +$! +$! The config_vms.h will be invoked by the resulting config.h file. +$! +$! This procedure knows about the DEC C RTL on the system it is on. +$! Future versions may be handle the GNV, the OpenVMS porting library, +$! and others. +$! +$! This procedure may not guess the options correctly for all architectures, +$! and is a work in progress. +$! +$! Copyright (C) John Malmberg +$! +$! Permission to use, copy, modify, and/or distribute this software for any +$! purpose with or without fee is hereby granted, provided that the above +$! copyright notice and this permission notice appear in all copies. +$! +$! THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +$! WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +$! MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +$! ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +$! WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +$! ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT +$! OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +$! +$! SPDX-License-Identifier: ISC +$! +$!============================================================================ +$! +$ss_normal = 1 +$ss_abort = 44 +$ss_control_y = 1556 +$status = ss_normal +$on control_y then goto control_y +$on warning then goto general_error +$!on warning then set ver +$! +$! Some information for writing timestamps to created files +$!---------------------------------------------------------- +$my_proc = f$environment("PROCEDURE") +$my_proc_file = f$parse(my_proc,,,"NAME") + f$parse(my_proc,,,"TYPE") +$tab[0,8] = 9 +$datetime = f$element(0,".",f$cvtime(,"ABSOLUTE","DATETIME")) +$username = f$edit(f$getjpi("","USERNAME"),"TRIM") +$! +$pid = f$getjpi("","PID") +$tfile1 = "SYS$SCRATCH:config_h_temp1_''pid'.TEMP" +$dchfile = "SYS$SCRATCH:config_h_decc_''pid'.TEMP" +$starhfile = "SYS$SCRATCH:config_h_starlet_''pid'.TEMP" +$configure_script = "SYS$SCRATCH:configure_script_''pid'.TEMP" +$! +$! Get the system type +$!---------------------- +$arch_type = f$getsyi("arch_type") +$! +$! Does config_vms.h exist? +$!------------------------- +$update_config_vms = 0 +$file = f$search("sys$disk:[]config_vms.h") +$if file .nes. "" +$then +$ write sys$output "Found existing custom file ''file'." +$else +$ update_config_vms = 1 +$ write sys$output "Creating new sys$disk:[]config_vms.h for you." +$ gosub write_config_vms +$endif +$! +$! +$! On some platforms, DCL search has problems with searching a file +$! on a NFS mounted volume. So copy it to sys$scratch: +$! +$if f$search(configure_script) .nes. "" then delete 'configure_script';* +$copy sys$disk:[]configure 'configure_script' +$! +$ssl_header_dir = "OPENSSL:" +$if f$trnlnm("OPENSSL") .eqs. "" +$then +$ ssl_header_dir = "SSL$INCLUDE:" +$endif +$! +$! +$! Write out the header +$!---------------------- +$gosub write_config_h_header +$! +$! +$! +$! config.h.in could have at least five different names depending +$! on how it was transferred to OpenVMS +$!------------------------------------------------------------------ +$if p1 .nes. "" +$then +$ cfile = p1 +$else +$ cfile = f$search("sys$disk:[]config.h.in") +$ if cfile .eqs. "" +$ then +$ cfile = f$search("sys$disk:[]config.h_in") +$ if cfile .eqs. "" +$ then +$ cfile = f$search("sys$disk:[]configh.in") +$ if cfile .eqs. "" +$ then +$ cfile = f$search("sys$disk:[]config__2eh.in") +$ if cfile .eqs. "" +$ then +$ cfile = f$search("sys$disk:[]config.h__2ein") +$ endif +$ endif +$ endif +$ endif +$endif +$if f$trnlnm("PRJ_INCLUDE") .nes. "" +$then +$ cfile = f$search("PRJ_INCLUDE:config.h.in") +$ if cfile .eqs. "" +$ then +$ cfile = f$search("PRJ_INCLUDE:config.h_in") +$ if cfile .eqs. "" +$ then +$ cfile = f$search("PRJ_INCLUDE:config__2eh.in") +$ if cfile .eqs. "" +$ then +$ cfile = f$search("PRJ_INCLUDE:config__2eh.in") +$ if cfile .eqs. "" +$ then +$ cfile = f$search("PRJ_INCLUDE:config.h__2ein") +$ endif +$ endif +$ endif +$ endif +$endif +$if cfile .eqs. "" +$then +$ write sys$output "Can not find sys$disk:config.h.in" +$ line_out = "Looked for config.h.in, config.h_in, configh.in, " +$ line_out = line_out + "config__2eh.in, config.h__2ein" +$ write/symbol sys$output line_out +$ if f$trnlnm("PRJ_INCLUDE") .nes. "" +$ then +$ write sys$output "Also looked in PRJ_INCLUDE: for these files." +$ endif +$! +$ write tf "" +$ write tf - + " /* Could not find sys$disk:config.h.in */" +$ write tf - + " /* Looked also for config.h_in, configh.in, config__2eh.in, */" +$ write tf - + " /* config.h__2ein */" +$ if f$trnlnm("PRJ_INCLUDE") .nes. "" +$ then +$ write tf - + " /* Also looked in PRJ_INCLUDE: for these files. */" +$ endif +$ write tf - + "/*--------------------------------------------------------------*/ +$ write tf "" +$ goto write_tail +$endif +$! +$! +$! Locate the DECC libraries in use +$!----------------------------------- +$decc_rtldef = f$parse("decc$rtldef","sys$library:.tlb;0") +$decc_starletdef = f$parse("sys$starlet_c","sys$library:.tlb;0") +$decc_shr = f$parse("decc$shr","sys$share:.exe;0") +$! +$! Dump the DECC header names into a file +$!---------------------------------------- +$if f$search(dchfile) .nes. "" then delete 'dchfile';* +$if f$search(tfile1) .nes. "" then delete 'tfile1';* +$define/user sys$output 'tfile1' +$library/list 'decc_rtldef' +$open/read/error=rtldef_loop1_end tf1 'tfile1' +$open/write/error=rtldef_loop1_end tf2 'dchfile' +$rtldef_loop1: +$ read/end=rtldef_loop1_end tf1 line_in +$ line_in = f$edit(line_in,"TRIM,COMPRESS") +$ key1 = f$element(0," ",line_in) +$ key2 = f$element(1," ",line_in) +$ if key1 .eqs. " " .or. key1 .eqs. "" then goto rtldef_loop1 +$ if key2 .nes. " " .and. key2 .nes. "" then goto rtldef_loop1 +$ write tf2 "|",key1,"|" +$ goto rtldef_loop1 +$rtldef_loop1_end: +$if f$trnlnm("tf1","lnm$process",,"SUPERVISOR") .nes. "" then close tf1 +$if f$trnlnm("tf2","lnm$process",,"SUPERVISOR") .nes. "" then close tf2 +$if f$search(tfile1) .nes. "" then delete 'tfile1';* +$! +$! Dump the STARLET header names into a file +$!---------------------------------------- +$if f$search(starhfile) .nes. "" then delete 'starhfile';* +$if f$search(tfile1) .nes. "" then delete 'tfile1';* +$define/user sys$output 'tfile1' +$library/list 'decc_starletdef' +$open/read/error=stardef_loop1_end tf1 'tfile1' +$open/write/error=stardef_loop1_end tf2 'starhfile' +$stardef_loop1: +$ read/end=stardef_loop1_end tf1 line_in +$ line_in = f$edit(line_in,"TRIM,COMPRESS") +$ key1 = f$element(0," ",line_in) +$ key2 = f$element(1," ",line_in) +$ if key1 .eqs. " " .or. key1 .eqs. "" then goto stardef_loop1 +$ if key2 .nes. " " .and. key2 .nes. "" then goto stardef_loop1 +$ write tf2 "|",key1,"|" +$ goto stardef_loop1 +$stardef_loop1_end: +$if f$trnlnm("tf1","lnm$process",,"SUPERVISOR") .nes. "" then close tf1 +$if f$trnlnm("tf2","lnm$process",,"SUPERVISOR") .nes. "" then close tf2 +$if f$search(tfile1) .nes. "" then delete 'tfile1';* +$! +$! +$! Now calculate what should be in the file from reading +$! config.h.in and CONFIGURE. +$!--------------------------------------------------------------- +$open/read inf 'cfile' +$do_comment = 0 +$if_block = 0 +$cfgh_in_loop1: +$!set nover +$ read/end=cfgh_in_loop1_end inf line_in +$ xline = f$edit(line_in,"TRIM,COMPRESS") +$! +$! Blank line handling +$!--------------------- +$ if xline .eqs. "" +$ then +$ write tf "" +$ goto cfgh_in_loop1 +$ endif +$ xlen = f$length(xline) +$ key = f$extract(0,2,xline) +$! +$! deal with comments by copying exactly +$!----------------------------------------- +$ if (do_comment .eq. 1) .or. (key .eqs. "/*") +$ then +$ do_comment = 1 +$ write tf line_in +$ key = f$extract(xlen - 2, 2, xline) +$ if key .eqs. "*/" then do_comment = 0 +$ goto cfgh_in_loop1 +$ endif +$! +$! Some quick parsing +$!---------------------- +$ keyif = f$extract(0,3,xline) +$ key1 = f$element(0," ",xline) +$ key2 = f$element(1," ",xline) +$ key2a = f$element(0,"_",key2) +$ key2b = f$element(1,"_",key2) +$ key2_len = f$length(key2) +$ key2_h = f$extract(key2_len - 2, 2, key2) +$ key2_t = f$extract(key2_len - 5, 5, key2) +$ if key2_t .eqs. "_TYPE" then key2_h = "_T" +$ key64 = 0 +$ if f$locate("64", xline) .lt. xlen then key64 = 1 +$! +$!write sys$output "xline = ''xline'" +$! +$! Comment out this section of the ifblock +$!----------------------------------------- +$ if if_block .ge. 3 +$ then +$ write tf "/* ", xline, " */" +$ if keyif .eqs. "#en" then if_block = 0 +$ goto cfgh_in_loop1 +$ endif +$! +$! Handle the end of an ifblock +$!------------------------------- +$ if keyif .eqs. "#en" +$ then +$ write tf xline +$ if_block = 0 +$ goto cfgh_in_loop1 +$ endif +$! +$ if key1 .eqs. "#ifndef" +$ then +$! Manual check for _ALL_SOURCE on AIX error +$!----------------------------------------------- +$ if key2 .eqs. "_ALL_SOURCE" +$ then +$ write tf "/* ", xline, " */" +$! +$! Ignore the rest of the block +$!-------------------------------------- +$ if_block = 3 +$ goto cfgh_in_loop1 +$ endif +$ endif +$! +$! +$! Default action for an #if/#else/#endif +$!------------------------------------------ +$ if keyif .eqs. "#if" .or. keyif .eqs. "#el" +$ then +$ if_block = 1 +$ write tf xline +$ goto cfgh_in_loop1 +$ endif +$! +$! +$! Process "normal?" stuff +$!--------------------------- +$ if key1 .eqs. "#undef" +$ then +$ key2c = f$element(2, "_", key2) +$ if (key2c .eqs. "_") .or. (key2c .eqs. "H") then key2c = "" +$ key2d = f$element(3, "_", key2) +$ if (key2d .eqs. "_") .or. (key2d .eqs. "H") then key2d = "" +$ key2e = f$element(4, "_", key2) +$ if (key2e .eqs. "_") .or. (key2e .eqs. "H") then key2e = "" +$ if key2d .eqs. "T" +$ then +$ if key2e .eqs. "TYPE" +$ then +$ key2_h = "_T" +$ key2d = "" +$ endif +$ endif +$! +$ double_under = 0 +$! +$! Process FCNTL directives +$!------------------------------------- +$ if (key2b .eqs. "FCNTL") .and. (key2c .eqs. "O") .and. - + (key2d .eqs. "NONBLOCK") +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$! Process GETADDRINFO directives +$!------------------------------------- +$ if key2 .eqs. "GETADDRINFO_THREADSAFE" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$! Process IOCTL directives +$!------------------------------------- +$ if (key2b .eqs. "IOCTL") .and. (key2c .nes. "") +$ then +$ if (key2c .eqs. "FIONBIO") .or. (key2c .eqs. "SIOCGIFADDR") +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$ endif +$! +$! +$! Manual check for LL on +$!----------------------------------------------- +$ if key2 .eqs. "LL" +$ then +$ write tf "#ifndef __VAX +$ write tf "#define HAVE_''key2' 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "bool_t" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' short" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "bits16_t" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' short" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "u_bits16_t" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' unsigned short" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "bits32_t" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' int" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "u_bits32_t" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' unsigned int" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "intmax_t" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#ifdef __VAX" +$ write tf "#define ''key2' long" +$ write tf "#else" +$ write tf "#define ''key2' long long" +$ write tf "#endif" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "uintmax_t" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#ifdef __VAX" +$ write tf "#define ''key2' unsigned long" +$ write tf "#else" +$ write tf "#define ''key2' unsigned long long" +$ write tf "#endif" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "socklen_t" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' int" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "GETGROUPS_T" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' gid_t" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "HAVE_DECL_SYS_SIGLIST" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 0" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "HAVE_SYS_ERRLIST" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "HAVE_STRUCT_DIRENT_D_INO" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "HAVE_STRUCT_TIMEVAL" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$! ! The header files have this information, however +$! ! The ioctl() call only works on sockets. +$! if key2 .eqs. "FIONREAD_IN_SYS_IOCTL" +$! then +$! write tf "#ifndef ''key2'" +$! write tf "#define ''key2' 1" +$! write tf "#endif" +$! goto cfgh_in_loop1 +$! endif +$! +$! ! The header files have this information, however +$! ! The ioctl() call only works on sockets. +$! if key2 .eqs. "GWINSZ_IN_SYS_IOCTL" +$! then +$! write tf "#ifndef ''key2'" +$! write tf "#define ''key2' 1" +$! write tf "#endif" +$! goto cfgh_in_loop1 +$! endif +$! +$! ! The header files have this information, however +$! ! The ioctl() call only works on sockets. +$! if key2 .eqs. "STRUCT_WINSIZE_IN_SYS_IOCTL" +$! then +$! write tf "#ifndef ''key2'" +$! write tf "#define ''key2' 0" +$! write tf "#endif" +$! goto cfgh_in_loop1 +$! endif +$! +$ if key2 .eqs. "HAVE_STRUCT_TM_TM_ZONE" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "HAVE_TM_ZONE" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "HAVE_TIMEVAL" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "WEXITSTATUS_OFFSET" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 2" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "HAVE_GETPW_DECLS" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "HAVE_DECL_CONFSTR" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "HAVE_DECL_PRINTF" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "HAVE_DECL_SBRK" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "HAVE_DECL_STRSIGNAL" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 0" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2a .eqs. "HAVE_DECL_STRTOLD" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 0" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "HAVE_DECL_STRTOIMAX" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 0" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "HAVE_DECL_STRTOL" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "HAVE_DECL_STRTOUL" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "HAVE_DECL_STRTOUMAX" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 0" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "GETPGRP_VOID" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "NAMED_PIPES_MISSING" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "OPENDIR_NOT_ROBUST" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "PGRP_PIPE" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "CAN_REDEFINE_GETENV" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "HAVE_PRINTF_A_FORMAT" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "CTYPE_NON_ASCII" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "HAVE_LANGINFO_CODESET" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 0" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$! This wants execve() to do this automagically to pass. +$! if key2 .eqs. "HAVE_HASH_BANG_EXEC" +$! then +$! write tf "#ifndef ''key2'" +$! write tf "#define ''key2' 1" +$! write tf "#endif" +$! goto cfgh_in_loop1 +$! endif +$! +$ if key2 .eqs. "ICONV_CONST" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2'" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "VOID_SIGHANDLER" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "HAVE_POSIX_SIGNALS" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "UNUSABLE_RT_SIGNALS" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2a .eqs. "HAVE_DECL_FPURGE" +$ then +$ write tf "#ifndef ''key2a'" +$ write tf "#define ''key2a' 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "HAVE_DECL_SETREGID" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "HAVE_POSIX_SIGSETJMP" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2b .eqs. "RAND" .and. key2c .nes. "" .and. key2d .eqs. "" +$ then +$ if (key2c .eqs. "EGD") .or. - + (key2c .eqs. "STATUS") .or. - + (key2c .eqs. "SCREEN") +$ then +$ if f$search("''ssl_header_dir'rand.h") .nes. "" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$ write tf "#endif" +$ else +$ write tf "/* #undef ''key2' */" +$ endif +$ endif +$ endif +$! +$ if key2 .eqs. "STRCOLL_BROKEN" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2 .eqs. "DUP_BROKEN" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$! This is for a test that getcwd(0,0) works. +$! It does not on VMS. +$!-------------------------- +$ if key2 .eqs. "GETCWD_BROKEN" +$ then +$ write sys$output "" +$ write sys$output - + "%CONFIG_H-I-NONPORT, ''key2' being tested for!" +$ write sys$output - + "-CONFIG_H-I-GETCWD, GETCWD(0,0) does not work on VMS." +$ write sys$output - + "-CONFIG_H-I-GETCWD2, Work around hack probably required." +$ write sys$output - + "-CONFIG_H-I-REVIEW, Manual Code review required!" +$ if update_config_vms +$ then +$ open/append tfcv sys$disk:[]config_vms.h +$ write tfcv "" +$ write tfcv - + "/* Check config.h for use of ''key2' settings */" +$ write tfcv "" +$ close tfcv +$ endif +$ +$ goto cfgh_in_loop1 +$ endif +$! +$ if (key2a .eqs. "HAVE") .or. (key2a .eqs. "STAT") .or. - + (key2 .eqs. "USE_IPV6") .or. (key2b .eqs. "LDAP") +$ then +$! +$! Process extra underscores +$!------------------------------------ +$ if f$locate("HAVE___", key2) .lt. key2_len +$ then +$ key2b = "__" + key2d +$ key2d = "" +$ double_under = 1 +$ else +$ if f$locate("HAVE__", key2) .lt. key2_len +$ then +$ key2b = "_" + key2c +$ key2c = "" +$ double_under = 1 +$ endif +$ endif +$! +$ if (key2_h .eqs. "_H") .or. (key2 .eqs. "USE_IPV6") .or. - + (key2b .eqs. "LDAP") +$ then +$! +$! Looking for a header file +$!--------------------------------------- +$ headf = key2b +$ if key2c .nes. "" then headf = headf + "_" + key2c +$ if key2d .nes. "" then headf = headf + "_" + key2d +$! +$! (key2b .eqs. "READLINE") +$! +$! Some special parsing +$!------------------------------------------ +$ if (key2b .eqs. "SYS") .or. (key2b .eqs. "ARPA") .or. - + (key2b .eqs. "NET") .or. (key2b .eqs. "NETINET") +$ then +$ if key2c .nes. "" +$ then +$ headf = key2c +$ if key2d .nes. "" then headf = key2c + "_" + key2d +$ endif +$ endif +$! +$! And of course what's life with out some special cases +$!-------------------------------------------------------------------- +$ if key2 .eqs. "USE_IPV6" +$ then +$ headf = "in6" +$ endif +$! +$ if key2b .eqs. "LDAP" +$ then +$ if (key2 .eqs. "HAVE_LDAP_SSL") .or. - + (key2 .eqs. "HAVE_LDAP_URL_PARSE") +$ then +$ headf = "ldap" +$ endif +$ endif +$! +$! +$ if key2b .eqs. "FILE" +$ then +$ write sys$output "" +$ write sys$output - + "%CONFIG_H-I-NONPORT, ''key2' being asked for!" +$ write sys$output - + "-CONFIG_H-I-FILE_OLD, file.h will not be configured as is obsolete!" +$ write sys$output - + "-CONFIG_H_I-FCNTL_NEW, "Expecting fcntl.h to be configured instead!" +$ write sys$output - + "-CONFIG_H_I-FCNTL_CHK, "Unable to verify at this time!" +$ write sys$output - + "-CONFIG_H-I-REVIEW, Manual Code review required!" +$! +$ if update_config_vms +$ then +$ open/append tfcv sys$disk:[]config_vms.h +$ write tfcv "" +$ write tfcv - + "/* Check config.h for use of fcntl.h instead of file.h */" +$ write tfcv "" +$ close tfcv +$ endif +$ endif +$! +$! Now look it up in the DEC C RTL +$!--------------------------------------------- +$ define/user sys$output nl: +$ define/user sys$error nl: +$ search/output=nl: 'dchfile' |'headf'|/exact +$ if '$severity' .eq. 1 +$ then +$ if key64 then write tf "#ifndef __VAX" +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$if p2 .nes. "" then write sys$output "''dchfile' - #define ''key2' 1" +$ write tf "#endif" +$ if key64 then write tf "#endif" +$set nover +$ goto cfgh_in_loop1 +$ endif +$! +$! +$! Now look it up in the DEC C STARLET_C +$!--------------------------------------------- +$ define/user sys$output nl: +$ define/user sys$error nl: +$ search/output=nl: 'starhfile' |'headf'|/exact +$ if '$severity' .eq. 1 +$ then +$ if key64 then write tf "#ifndef __VAX" +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$if p2 .nes. "" then write sys$output "''starfile' - #define ''key2' 1" +$ write tf "#endif" +$ if key64 then write tf "#endif" +$set nover +$ goto cfgh_in_loop1 +$ endif +$! +$! Now look for OPENSSL headers +$!--------------------------------------------------------- +$ if key2b .eqs. "OPENSSL" +$ then +$ headf = headf - "OPENSSL_" +$ header = f$search("''ssl_header_dir'''headf'.h") +$ if header .nes. "" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$ write tf "#endif" +$set nover +$ goto cfgh_in_loop1 +$ endif +$ endif +$! +$! Now look for Kerberos +$!------------------------------------------------------------ +$ if key2b .eqs. "GSSAPI" +$ then +$ header_dir = "sys$sysroot:[kerberos.include]" +$ headf = headf - "GSSAPI_" +$ header = f$search("''header_dir'''headf'.h") +$ if header .nes. "" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$ write tf "#endif" +$set nover +$ goto cfgh_in_loop1 +$ endif +$ endif +$! +$set nover +$ else +$! +$! Looking for a routine or a symbol +$!------------------------------------------------ +$ if key2c .eqs. "MACRO" +$ then +$ if (key2b .eqs. "FILE") .or. (key2b .eqs. "DATE") - + .or. (key2b .eqs. "LINE") .or. (key2b .eqs. "TIME") +$ then +$ write tf "#ifndef HAVE_''key2b'" +$ write tf "#define HAVE_''key2b' 1" +$ write tf "#endif" +$ endif +$ goto cfgh_in_loop1 +$ endif +$! +$! Special false tests +$!------------------------------------- +$ if double_under +$ then +$ if key2b .eqs. "_FCNTL" .or. key2b .eqs. "__FCNTL" +$ then +$ write tf "/* #undef HAVE_''key2b' */" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2b .eqs. "_STAT" .or. key2b .eqs. "__STAT" +$ then +$ write tf "/* #undef HAVE_''key2b' */" +$ goto cfgh_in_loop1 +$ endif +$! +$ if key2b .eqs. "_READ" .or. key2b .eqs. "__READ" +$ then +$ write tf "/* #undef HAVE_''key2b' */" +$ goto cfgh_in_loop1 +$ endif +$ endif +$! +$ keysym = key2b +$ if key2c .nes. "" then keysym = keysym + "_" + key2c +$ if key2d .nes. "" then keysym = keysym + "_" + key2d +$ if key2e .nes. "" then keysym = keysym + "_" + key2e +$! +$! +$! Stat structure members +$!------------------------------------- +$ if key2b .eqs. "STRUCT" +$ then +$ if key2c .eqs. "STAT" .and (key2d .nes. "") +$ then +$ key2b = key2b + "_" + key2c + "_" + key2d +$ key2c = key2e +$ key2d = "" +$ key2e = "" +$ endif +$ endif +$ if (key2b .eqs. "ST") .or. (key2b .eqs. "STRUCT_STAT_ST") +$ then +$ keysym = "ST" + "_" + key2c +$ keysym = f$edit(keysym,"LOWERCASE") +$ endif +$ if key2a .eqs. "STAT" +$ then +$ if (f$locate("STATVFS", key2b) .eq. 0) .and. key2c .eqs. "" +$ then +$ keysym = f$edit(key2b, "LOWERCASE") +$ endif +$!$ if (key2b .eqs. "STATVFS" .or. key2b .eqs. "STATFS2" - +$! .or. key2b .eqs. "STATFS3") .and. key2c .nes. "" +$! +$ if (key2b .eqs. "STATVFS") .and. key2c .nes. "" +$ then +$! Should really verify that the structure +$! named by key2b actually exists first. +$!------------------------------------------------------------ +$! +$! Statvfs structure members +$!------------------------------------------------- +$ keysym = "f_" + f$edit(key2c,"LOWERCASE") +$ endif +$ endif +$! +$! UTMPX structure members +$!-------------------------------------- +$ if key2b .eqs. "UT" .and. key2c .eqs. "UT" +$ then +$ keysym = "ut_" + f$edit(key2d,"LOWERCASE") +$ endif +$! +$ if f$locate("MMAP",key2) .lt. key2_len +$ then +$ write sys$output "" +$ write sys$output - + "%CONFIG_H-I-NONPORT, ''key2' being asked for!" +$ write sys$output - + "-CONFIG_H-I-MMAP, MMAP operations only work on STREAM and BINARY files!" +$ write sys$output - + "-CONFIG_H-I-REVIEW, Manual Code review required!" +$ if update_config_vms +$ then +$ open/append tfcv sys$disk:[]config_vms.h +$ write tfcv "" +$ write tfcv - + "/* Check config.h for use of ''key2' settings */" +$ write tfcv "" +$ close tfcv +$ endif +$ endif +$! +$! +$ if keysym .eqs. "CRYPT" +$ then +$ write sys$output "" +$ write sys$output - + "%CONFIG_H-I-NONPORT, ''key2' being asked for!" +$ write sys$output - + "-CONFIG_H-I-CRYPT, CRYPT operations on the VMS SYSUAF may not work!" +$ write sys$output - + "-CONFIG_H-I-REVIEW, Manual Code review required!" +$ if update_config_vms +$ then +$ open/append tfcv sys$disk:[]config_vms.h +$ write tfcv "" +$ write tfcv - + "/* Check config.h for use of ''keysym' */" +$ write tfcv "" +$ close tfcv +$ endif +$ endif +$! +$! +$ if keysym .eqs. "EXECL" +$ then +$ write sys$output "" +$ write sys$output - + "%CONFIG_H-I-NONPORT, ''key2' being asked for!" +$ write sys$output - + "-CONFIG_H-I-EXCEL, EXECL configured, Will probably not work." +$ write sys$output - + "-CONFIG_H-I-REVIEW, Manual Code review required!" +$ if update_config_vms +$ then +$ open/append tfcv sys$disk:[]config_vms.h +$ write tfcv "" +$ write tfcv - + "/* Check config.h for use of ''keysym' */" +$ write tfcv "" +$ close tfcv +$ endif +$ endif +$! +$! +$! Process if cpp supports ANSI-C stringizing '#' operator +$!----------------------------------------------------------------------- +$ if keysym .eqs. "STRINGIZE" +$ then +$ write tf "#ifndef HAVE_STRINGIZE" +$ write tf "#define HAVE_STRINGSIZE 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if keysym .eqs. "VOLATILE" +$ then +$ write tf "#ifndef HAVE_VOLATILE" +$ write tf "#define HAVE_VOLATILE 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if keysym .eqs. "ALLOCA" +$ then +$ write tf "#ifndef HAVE_ALLOCA" +$ write tf "#define HAVE_ALLOCA 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if keysym .eqs. "ERRNO_DECL" +$ then +$ write tf "#ifndef HAVE_ERRNO_DECL" +$ write tf "#define HAVE_ERRNO_DECL 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$! May need to test compiler version +$!----------------------------------------------- +$ if keysym .eqs. "LONG_LONG" +$ then +$ write tf "#ifndef __VAX" +$ write tf "#pragma message disable longlongtype" +$ write tf "#ifndef HAVE_LONG_LONG" +$ write tf "#define HAVE_LONG_LONG 1" +$ write tf "#endif" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$! May need to test compiler version +$!----------------------------------------------- +$ if keysym .eqs. "UNSIGNED_LONG_LONG" +$ then +$ write tf "#ifndef __VAX" +$ write tf "#pragma message disable longlongtype" +$ write tf "#ifndef HAVE_UNSIGNED_LONG_LONG" +$ write tf "#define HAVE_UNSIGNED_LONG_LONG 1" +$ write tf "#endif" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$! May need to test compiler version +$!----------------------------------------------- +$ if keysym .eqs. "UNSIGNED_LONG_LONG_INT" +$ then +$ write tf "#ifndef __VAX" +$ write tf "#pragma message disable longlongtype" +$ write tf "#ifndef HAVE_UNSIGNED_LONG_LONG_INT" +$ write tf "#define HAVE_UNSIGNED_LONG_LONG_INT 1" +$ write tf "#endif" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$! May need to test compiler version +$!----------------------------------------------- +$ if keysym .eqs. "LONG_DOUBLE" +$ then +$ write tf "#ifndef __VAX" +$ write tf "#pragma message disable longlongtype" +$ write tf "#ifndef HAVE_LONG_DOUBLE" +$ write tf "#define HAVE_LONG_DOUBLE 1" +$ write tf "#endif" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$ if keysym .eqs. "FCNTL_LOCK" +$ then +$ write sys$output - + "%CONFIG_H-I-NONPORT, ''key2' being asked for! +$ write sys$output - + "-CONFIG_H-I-REVIEW, Manual Code review required!" +$ goto cfgh_in_loop1 +$ endif +$! +$! +$! These libraries are provided by the DEC C RTL +$!------------------------------------------------------------- +$ if keysym .eqs. "LIBINET" .or. keysym .eqs. "LIBSOCKET" +$ then +$ write tf "#ifndef HAVE_''keysym'" +$ write tf "#define HAVE_''keysym' 1" +$if p2 .nes. "" then write sys$output "''decc_shr' #define ''keysym' 1" +$ write tf "#endif +$ goto cfgh_in_loop1 +$ endif +$! +$ if keysym .eqs. "HERRNO" then keysym = "h_errno" +$ if keysym .eqs. "UTIMBUF" then keysym = "utimbuf" +$ if key2c .eqs. "STRUCT" +$ then +$ keysym = f$edit(key2d,"LOWERCASE") +$ else +$ if key2_h .eqs. "_T" +$ then +$ if key2_t .eqs. "_TYPE" +$ then +$ keysym = f$extract(0, key2_len - 5, key2) - "HAVE_" +$ endif +$ keysym = f$edit(keysym,"LOWERCASE") +$ endif +$ endif +$! +$! Check the DEC C RTL shared image first +$!------------------------------------------------------ +$ if f$search(tfile1) .nes. "" then delete 'tfile1';* +$ define/user sys$output nl: +$ define/user sys$error nl: +$ search/format=nonull/out='tfile1' 'decc_shr' 'keysym' +$ if '$severity' .eq. 1 +$ then +$! +$! Not documented, but from observation +$!------------------------------------------------------ +$ define/user sys$output nl: +$ define/user sys$error nl: +$ if arch_type .eq. 3 +$ then +$ keyterm = "''keysym'" +$ else +$ if arch_type .eq. 2 +$ then +$ keyterm = "''keysym'" +$ else +$ keyterm = "''keysym'" +$ endif +$ endif +$ search/out=nl: 'tfile1' - + "$''keyterm'","$g''keyterm'","$__utc_''keyterm'",- + "$__utctz_''keyterm'","$__bsd44_''keyterm'","$bsd_''keyterm'",- + "$''keysym'decc$","$G''keysym'decc$","$GX''keyterm'" +$ severity = '$severity' +$! +$! +$! Of course the 64-bit stuff is different +$!--------------------------------------------------------- +$ if severity .ne. 1 .and. key64 +$ then +$ define/user sys$output nl: +$ define/user sys$error nl: +$ search/out=nl: 'tfile1' "$_''keyterm'" +$! search/out 'tfile1' "$_''keyterm'" +$ severity = '$severity' +$ endif +$! +$! Unix compatibility routines +$!--------------------------------------------- +$ if severity .ne. 1 +$ then +$ define/user sys$output nl: +$ define/user sys$error nl: +$ search/out=nl: 'tfile1' - + "$__unix_''keyterm'","$__vms_''keyterm'","$_posix_''keyterm'" +$ severity = '$severity' +$ endif +$! +$! Show the result of the search +$!------------------------------------------------ +$ if 'severity' .eq. 1 +$ then +$ if key64 then write tf "#ifndef __VAX" +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$if p2 .nes. "" then write sys$output "''decc_shr' #define ''key2' 1" +$ write tf "#endif" +$ if key64 then write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$ endif +$ if f$search(tfile1) .nes. "" then delete 'tfile1';* +$! +$! Check the DECC Header files next +$!---------------------------------------------- +$ define/user sys$output nl: +$ define/user sys$error nl: +$ search/out=nl: 'decc_rtldef' - + "''keysym';", "''keysym'[", "struct ''keysym'"/exact +$ severity = '$severity' +$ if severity .eq. 1 +$ then +$ if key64 then write tf "#ifndef __VAX" +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$if p2 .nes. "" then write sys$output "''decc_rtldef' #define ''key2' 1" +$ write tf "#endif" +$ if key64 then write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$! Check kerberos +$!-------------------------------------------- +$ if f$search("SYS$SYSROOT:[kerberos]include.dir") .nes. "" +$ then +$ test_mit = "SYS$SYSROOT:[kerberos.include]gssapi_krb5.h" +$ if (key2 .eqs. "HAVE_GSSAPI") +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$ endif +$! +$ endif +$ write tf "/* ", xline, " */" +$ goto cfgh_in_loop1 +$ endif +$! +$! +$! Process SIZEOF directives found in SAMBA and others +$!---------------------------------------------------------- +$ if key2a .eqs. "SIZEOF" +$ then +$ if key2b .eqs. "INO" .and. key2_h .eqs. "_T" +$ then +$ write tf "#ifndef SIZEOF_INO_T" +$ write tf "#if !__USING_STD_STAT +$ write tf "#define SIZEOF_INO_T 6" +$ write tf "#else +$ write tf "#define SIZEOF_INO_T 8" +$ write tf "#endif +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$ if key2b .eqs. "INTMAX" .and. key2_h .eqs. "_T" +$ then +$ write tf "#ifndef SIZEOF_INTMAX_T" +$ write tf "#ifdef __VAX" +$ write tf "#define SIZEOF_INTMAX_T 4" +$ write tf "#else" +$ write tf "#define SIZEOF_INTMAX_T 8" +$ write tf "#endif" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$ if key2b .eqs. "OFF" .and. key2_h .eqs. "_T" +$ then +$ write tf "#ifndef SIZEOF_OFF_T" +$ write tf "#if __USE_OFF64_T" +$ write tf "#define SIZEOF_OFF_T 8" +$ write tf "#else" +$ write tf "#define SIZEOF_OFF_T 4" +$ write tf "#endif" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$ if key2b .eqs. "CHAR" .and. key2_h .eqs. "_P" +$ then +$ write tf "#ifndef SIZEOF_CHAR_P" +$ write tf "#if __INITIAL_POINTER_SIZE == 64" +$ write tf "#define SIZEOF_CHAR_P 8" +$ write tf "#else" +$ write tf "#define SIZEOF_CHAR_P 4" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$ if key2b .eqs. "VOIDP" +$ then +$ write tf "#ifndef SIZEOF_VOIDP" +$ write tf "#if __INITIAL_POINTER_SIZE == 64" +$ write tf "#define SIZEOF_VOIDP 8" +$ write tf "#else" +$ write tf "#define SIZEOF_VOIDP 4" +$ write tf "#endif" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$ if key2b .eqs. "INT" +$ then +$ write tf "#ifndef SIZEOF_INT" +$ write tf "#define SIZEOF_INT 4" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$ if key2b .eqs. "SIZE" .and. key2_h .eqs. "_T" +$ then +$ write tf "#ifndef SIZEOF_SIZE_T" +$ write tf "#define SIZEOF_SIZE_T 4" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$ if key2b .eqs. "TIME" .and. key2_h .eqs. "_T" +$ then +$ write tf "#ifndef SIZEOF_TIME_T" +$ write tf "#define SIZEOF_TIME_T 4" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$ if key2b .eqs. "DOUBLE" +$ then +$ write tf "#ifndef SIZEOF_DOUBLE" +$ write tf "#define SIZEOF_DOUBLE 8" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$ if key2b .eqs. "LONG" +$ then +$ if key2c .eqs. "" +$ then +$ write tf "#ifndef SIZEOF_LONG" +$ write tf "#define SIZEOF_LONG 4" +$ write tf "#endif" +$ endif +$ goto cfgh_in_loop1 +$ endif +$ write tf "/* ", xline, " */" +$ goto cfgh_in_loop1 +$ endif +$! +$! Process NEED directives +$!------------------------------- +$ if key2a .eqs. "NEED" +$ then +$ if key2b .eqs. "STRINGS" .and. key2_h .eqs. "_H" +$ then +$ write tf "#ifndef NEED_STRINGS_H" +$ write tf "#define NEED_STRINGS_H 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$ write tf "/* ", xline, " */" +$ goto cfgh_in_loop1 +$ endif +$! +$! Process GETHOSTNAME directives +$!------------------------------------- +$ if key2 .eqs. "GETHOSTNAME_TYPE_ARG2" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#ifdef _DECC_V4_SOURCE" +$ write tf "#define ''key2' int" +$ write tf "#else" +$ write tf "#define ''key2' size_t" +$ write tf "#endif" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$! Process GETNAMEINFO directives +$!------------------------------------- +$ if key2a .eqs. "GETNAMEINFO" +$ then +$ if key2 .eqs. "GETNAMEINFO_QUAL_ARG1" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' const" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$ if key2 .eqs. "GETNAMEINFO_TYPE_ARG1" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' struct sockaddr *" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$ if key2 .eqs. "GETNAMEINFO_TYPE_ARG2" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' size_t" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$ if key2 .eqs. "GETNAMEINFO_TYPE_ARG46" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' size_t" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$ if key2 .eqs. "GETNAMEINFO_TYPE_ARG7" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' int" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$ endif +$! +$! Process RECV directives +$!------------------------------------- +$ if key2a .eqs. "RECV" +$ then +$ if key2 .eqs. "RECV_TYPE_ARG1" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' int" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$ if key2 .eqs. "RECV_TYPE_ARG2" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' void *" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$ if key2 .eqs. "RECV_TYPE_ARG3" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' size_t" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$ if key2 .eqs. "RECV_TYPE_ARG4" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' int" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$ if key2 .eqs. "RECV_TYPE_RETV" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' int" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$ endif +$! +$! Process SEND directives +$!------------------------------------- +$ if key2a .eqs. "SEND" +$ then +$ if key2 .eqs. "SEND_TYPE_ARG1" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' int" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$ if key2 .eqs. "SEND_TYPE_ARG2" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' void *" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$ if key2 .eqs. "SEND_TYPE_ARG3" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' size_t" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$ if key2 .eqs. "SEND_TYPE_ARG4" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' int" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$ if key2 .eqs. "SEND_TYPE_RETV" +$ then +$ write tf "#ifndef ''key2'" +$ write tf "#define ''key2' int" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$ endif +$! +$! +$! Process STATFS directives +$!------------------------------- +$! if key2a .eqs. "STATFS" +$! then +$! write tf "/* ", xline, " */" +$! goto cfgh_in_loop1 +$! endif +$! +$! Process inline directive +$!------------------------------ +$ if key2 .eqs. "inline" +$ then +$ write tf "#ifndef inline" +$ write tf "#define inline __inline" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$! Process restrict directive +$!-------------------------------- +$ if key2 .eqs. "restrict" +$ then +$ write tf "#ifndef restrict" +$ write tf "#define restrict __restrict" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$! Process STDC_HEADERS (SAMBA!) +$!--------------------------- +$ if key2 .eqs. "STDC_HEADERS" +$ then +$ write tf "#ifndef STDC_HEADERS" +$ write tf "#define STDC_HEADERS 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$! Process PROTOTYPES directive +$!------------------------------------- +$ if key2 .eqs. "PROTOTYPES" +$ then +$ write tf "#ifndef PROTOTYPES" +$ write tf "#define PROTOTYPES 1" +$ write tf "#endif" +$ goto cfgh_in_loop1 +$ endif +$! +$! Special for SEEKDIR_RETURNS_VOID +$!--------------------------------------- +$ if key2 .eqs. "SEEKDIR_RETURNS_VOID" +$ then +$ write tf "#ifndef SEEKDIR_RETURNS_VOID" +$ write tf "#define SEEKDIR_RETURNS_VOID 1" +$ write tf "#endif" +$ endif +$! +$! Unknown - See if CONFIGURE can give a clue for this +$!---------------------------------------------------------- +$ pflag = 0 +$ set_flag = 0 +$! gproj_name = proj_name - "_VMS" - "-VMS" +$ if f$search(tfile1) .nes. "" then delete 'tfile1';* +$ define/user sys$output nl: +$ define/user sys$error nl: +$! if f$locate("FILE", key2) .lt. key2_len then pflag = 1 +$! if f$locate("DIR", key2) .eq. key2_len - 3 then pflag = 1 +$! if f$locate("PATH", key2) .eq. key2_len - 4 then pflag = 1 +$! +$ search/out='tfile1' 'configure_script' "''key2'="/exact +$ search_sev = '$severity' +$ if 'search_sev' .eq. 1 +$ then +$ open/read/err=unknown_cf_rd_error sf 'tfile1' +$search_file_rd_loop: +$ read/end=unknown_cf_rd_err sf line_in +$ line_in = f$edit(line_in, "TRIM") +$ skey1 = f$element(0,"=",line_in) +$ if skey1 .eqs. key2 +$ then +$ skey2 = f$element(1,"=",line_in) +$ skey2a = f$extract(0,2,skey2) +$! +$! +$! We can not handle assignment to shell symbols. +$! For now skip them. +$!------------------------------------------------------------ +$ if f$locate("$", skey2) .lt. f$length(skey2) +$ then +$ write tf "/* ", xline, " */" +$ set_flag = 1 +$ goto found_in_configure +$ endif +$! +$! Keep these two cases separate to make it easier to add +$! more future intelligence to this routine +$!---------------------------------------------------------------------- +$ if skey2a .eqs. """`" +$ then +$! if pflag .eq. 1 +$! then +$! write tf "#ifndef ''key2'" +$! write tf "#define ",key2," """,gproj_name,"_",key2,"""" +$! write tf "#endif" +$! else +$! Ignore this for now +$!------------------------------------------ +$ write tf "/* ", xline, " */" +$! endif +$ set_flag = 1 +$ goto found_in_configure +$ endif +$ if skey2a .eqs. """$" +$ then +$! if pflag .eq. 1 +$! then +$! write tf "#ifndef ''key2'" +$! write tf "#define ",key2," """,gproj_name,"_",key2,"""" +$! write tf "#endif" +$! else +$! Ignore this for now +$!------------------------------------------- +$ write tf "/* ", xline, " */" +$! endif +$ set_flag = 1 +$ goto found_in_configure +$ endif +$! +$! Remove multiple layers of quotes if present +$!---------------------------------------------------------- +$ if f$extract(0, 1, skey2) .eqs. "'" +$ then +$ skey2 = skey2 - "'" - "'" - "'" - "'" +$ endif +$ if f$extract(0, 1, skey2) .eqs. """" +$ then +$ skey2 = skey2 - """" - """" - """" - """" +$ endif +$ write tf "#ifndef ''key2'" +$ if skey2 .eqs. "" +$ then +$ write tf "#define ",key2 +$ else +$! Only quote non-numbers +$!---------------------------------------- +$ if f$string(skey2+0) .eqs. skey2 +$ then +$ write tf "#define ",key2," ",skey2 +$ else +$ write tf "#define ",key2," """,skey2,"""" +$ endif +$ endif +$ write tf "#endif" +$ set_flag = 1 +$ else +$ goto search_file_rd_loop +$! if pflag .eq. 1 +$! then +$! write tf "#ifndef ''key2'" +$! write tf "#define ",key2," """,gproj_name,"_",key2,"""" +$! write tf "#endif" +$! set_flag = 1 +$! endif +$ endif +$found_in_configure: +$unknown_cf_rd_err: +$ if f$trnlnm("sf","lnm$process",,"SUPERVISOR") .nes. "" +$ then +$ close sf +$ endif +$ if f$search(tfile1) .nes. "" then delete 'tfile1';* +$ if set_flag .eq. 1 then goto cfgh_in_loop1 +$ endif +$ endif +$! +$! +$! +$! If it falls through everything else, comment it out +$!----------------------------------------------------- +$ write tf "/* ", xline, " */" +$ goto cfgh_in_loop1 +$cfgh_in_loop1_end: +$close inf +$! +$! +$! Write out the tail +$!-------------------- +$write_tail: +$gosub write_config_h_tail +$! +$! Exit and clean up +$!-------------------- +$general_error: +$status = '$status' +$all_exit: +$set noon +$if f$trnlnm("sf","lnm$process",,"SUPERVISOR") .nes. "" then close sf +$if f$trnlnm("tf","lnm$process",,"SUPERVISOR") .nes. "" then close tf +$if f$trnlnm("inf","lnm$process",,"SUPERVISOR") .nes. "" then close inf +$if f$trnlnm("tf1","lnm$process",,"SUPERVISOR") .nes. "" then close tf1 +$if f$trnlnm("tf2","lnm$process",,"SUPERVISOR") .nes. "" then close tf2 +$if f$trnlnm("tfcv","lnm$process",,"SUPERVISOR") .nes. "" then close tfcv +$if f$type(tfile1) .eqs. "STRING" +$then +$ if f$search(tfile1) .nes. "" then delete 'tfile1';* +$endif +$if f$type(dchfile) .eqs. "STRING" +$then +$ if f$search(dchfile) .nes. "" then delete 'dchfile';* +$endif +$if f$type(starhfile) .eqs. "STRING" +$then +$ if f$search(starhfile) .nes. "" then delete 'starhfile';* +$endif +$if f$type(configure_script) .eqs. "STRING" +$then +$ if f$search(configure_script) .nes. "" then delete 'configure_script';* +$endif +$exit 'status' +$! +$! +$control_y: +$ status = ss_control_y +$ goto all_exit +$! +$! +$! +$! Gosub to write a new config_vms.h +$!----------------------------------- +$write_config_vms: +$outfile = "sys$disk:[]config_vms.h" +$create 'outfile' +$open/append tf 'outfile' +$write tf "/* File: config_vms.h" +$write tf "**" +$write tf "** This file contains the manual edits needed for porting" +$!write tf "** the ''proj_name' package to OpenVMS. +$write tf "**" +$write tf "** Edit this file as needed. The procedure that automatically" +$write tf "** generated this header stub will not overwrite or make any" +$write tf "** changes to this file." +$write tf "**" +$write tf - + "** ", datetime, tab, username, tab, "Generated by ''my_proc_file'" +$write tf "**" +$write tf - + "**========================================================================*/" +$write tf "" +$close tf +$return +$! +$! gosub to write out a documentation header for config.h +$!---------------------------------------------------------------- +$write_config_h_header: +$outfile = "sys$disk:[]config.h" +$create 'outfile' +$open/append tf 'outfile' +$write tf "#ifndef CONFIG_H" +$write tf "#define CONFIG_H" +$write tf "/* File: config.h" +$write tf "**" +$write tf - + "** This file contains the options needed for porting " +$write tf "** the project on a VMS system." +$write tf "**" +$write tf "** Try not to make any edits to this file, as it is" +$write tf "** automagically generated." +$write tf "**" +$write tf "** Manual edits should be made to the config_vms.h file." +$write tf "**" +$write tf - + "** ", datetime, tab, username, tab, "Generated by ''my_proc_file'" +$write tf "**" +$write tf - + "**========================================================================*/" +$write tf "" +$write tf "#if (__CRTL_VER >= 70200000) && !defined (__VAX)" +$write tf "#define _LARGEFILE 1" +$write tf "#endif" +$write tf "" +$write tf "#ifndef __VAX" +$write tf "#ifdef __CRTL_VER" +$write tf "#if __CRTL_VER >= 80200000" +$write tf "#define _USE_STD_STAT 1" +$write tf "#endif" +$write tf "#endif" +$write tf "#endif" +$write tf "" +$! +$write tf " /* Allow compiler builtins */" +$write tf "/*-------------------------*/" +$write tf "#ifdef __DECC_VER" +$write tf "#include " +$write tf "#endif" +$! +$write tf "" +$return +$! +$! gosub to write out the tail for config.h and close it +$!--------------------------------------------------------- +$write_config_h_tail: +$write tf "" +$write tf " /* Include the hand customized settings */" +$write tf "/*--------------------------------------*/" +$write tf "#include ""config_vms.h""" +$write tf "" +$write tf "#endif /* CONFIG_H */" +$close tf +$return +$! diff --git a/3rdparty/curl-8.21.0/projects/vms/curl_crtl_init.c b/3rdparty/curl-8.21.0/projects/vms/curl_crtl_init.c new file mode 100644 index 0000000000..a044ee72e0 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/curl_crtl_init.c @@ -0,0 +1,323 @@ +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ +/* File: curl_crtl_init.c + * + * This file makes sure that the DECC Unix settings are correct for + * the mode the program is run in. + * + * The CRTL has not been initialized at the time that these routines + * are called, so many routines can not be called. + * + * This is a module that provides a LIB$INITIALIZE routine that + * will turn on some CRTL features that are not enabled by default. + * + * The CRTL features can also be turned on via logical names, but that + * impacts all programs and some are not ready, willing, or able to handle + * those settings. + * + * On VMS versions that are too old to use the feature setting API, this + * module falls back to using logical names. + * + * Copyright (C) John Malmberg + * + * Permission to use, copy, modify, and/or distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT + * OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + * + */ + +/* Unix headers */ +#include +#include + +/* VMS specific headers */ +#include +#include +#include + +#pragma member_alignment save +#pragma nomember_alignment longword +#pragma message save +#pragma message disable misalgndmem +struct itmlst_3 { + unsigned short int buflen; + unsigned short int itmcode; + void *bufadr; + unsigned short int *retlen; +}; +#pragma message restore +#pragma member_alignment restore + +#ifdef __VAX +#define ENABLE "ENABLE" +#define DISABLE "DISABLE" +#else + +#define ENABLE TRUE +#define DISABLE 0 +int decc$feature_get_index(const char *name); +int decc$feature_set_value(int index, int mode, int value); +#endif + +int SYS$TRNLNM(const unsigned long *attr, + const struct dsc$descriptor_s *table_dsc, + struct dsc$descriptor_s *name_dsc, + const unsigned char *acmode, + const struct itmlst_3 *item_list); +int SYS$CRELNM(const unsigned long *attr, + const struct dsc$descriptor_s *table_dsc, + const struct dsc$descriptor_s *name_dsc, + const unsigned char *acmode, + const struct itmlst_3 *item_list); + +/* Take all the fun out of looking up a logical name */ +static int sys_trnlnm(const char *logname, char *value, int value_len) +{ + const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV"); + const unsigned long attr = LNM$M_CASE_BLIND; + struct dsc$descriptor_s name_dsc; + int status; + unsigned short result; + struct itmlst_3 itlst[2]; + + itlst[0].buflen = value_len; + itlst[0].itmcode = LNM$_STRING; + itlst[0].bufadr = value; + itlst[0].retlen = &result; + + itlst[1].buflen = 0; + itlst[1].itmcode = 0; + + name_dsc.dsc$w_length = strlen(logname); + name_dsc.dsc$a_pointer = (char *)logname; + name_dsc.dsc$b_dtype = DSC$K_DTYPE_T; + name_dsc.dsc$b_class = DSC$K_CLASS_S; + + status = SYS$TRNLNM(&attr, &table_dsc, &name_dsc, 0, itlst); + + if($VMS_STATUS_SUCCESS(status)) { + + /* Null-terminate and return the string */ + /*--------------------------------------*/ + value[result] = '\0'; + } + + return status; +} + +/* How to create a logical name */ +static int sys_crelnm(const char *logname, const char *value) +{ + int ret_val; + const char *proc_table = "LNM$PROCESS_TABLE"; + struct dsc$descriptor_s proc_table_dsc; + struct dsc$descriptor_s logname_dsc; + struct itmlst_3 item_list[2]; + + proc_table_dsc.dsc$a_pointer = (char *)proc_table; + proc_table_dsc.dsc$w_length = strlen(proc_table); + proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T; + proc_table_dsc.dsc$b_class = DSC$K_CLASS_S; + + logname_dsc.dsc$a_pointer = (char *)logname; + logname_dsc.dsc$w_length = strlen(logname); + logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T; + logname_dsc.dsc$b_class = DSC$K_CLASS_S; + + item_list[0].buflen = strlen(value); + item_list[0].itmcode = LNM$_STRING; + item_list[0].bufadr = (char *)value; + item_list[0].retlen = NULL; + + item_list[1].buflen = 0; + item_list[1].itmcode = 0; + + ret_val = SYS$CRELNM(NULL, &proc_table_dsc, &logname_dsc, NULL, item_list); + + return ret_val; +} + +/* Start of DECC RTL Feature handling */ + +/* +** Sets default value for a feature +*/ +#ifdef __VAX +static void set_feature_default(const char *name, const char *value) +{ + sys_crelnm(name, value); +} +#else +static void set_feature_default(const char *name, int value) +{ + int index; + + index = decc$feature_get_index(name); + + if(index > 0) + decc$feature_set_value(index, 0, value); +} +#endif + +static void set_features(void) +{ + int status; + char unix_shell_name[255]; + int use_unix_settings = 1; + + status = sys_trnlnm("GNV$UNIX_SHELL", + unix_shell_name, sizeof(unix_shell_name) - 1); + if(!$VMS_STATUS_SUCCESS(status)) { + use_unix_settings = 0; + } + + /* ACCESS should check ACLs or it is lying. */ + set_feature_default("DECC$ACL_ACCESS_CHECK", ENABLE); + + /* We always want the new parse style */ + set_feature_default("DECC$ARGV_PARSE_STYLE", ENABLE); + + /* Unless we are in POSIX compliant mode, we want the old POSIX root + * enabled. + */ + set_feature_default("DECC$DISABLE_POSIX_ROOT", DISABLE); + + /* EFS charset, means UTF-8 support */ + /* VTF-7 support is controlled by a feature setting called UTF8 */ + set_feature_default("DECC$EFS_CHARSET", ENABLE); + set_feature_default("DECC$EFS_CASE_PRESERVE", ENABLE); + + /* Support timestamps when available */ + set_feature_default("DECC$EFS_FILE_TIMESTAMPS", ENABLE); + + /* Cache environment variables - performance improvements */ + set_feature_default("DECC$ENABLE_GETENV_CACHE", ENABLE); + + /* Start out with new file attribute inheritance */ +#ifdef __VAX + set_feature_default("DECC$EXEC_FILEATTR_INHERITANCE", "2"); +#else + set_feature_default("DECC$EXEC_FILEATTR_INHERITANCE", 2); +#endif + + /* Do not display trailing dot after files without type */ + set_feature_default("DECC$READDIR_DROPDOTNOTYPE", ENABLE); + + /* For standard output channels buffer output until terminator */ + /* Gets rid of output logs with single character lines in them. */ + set_feature_default("DECC$STDIO_CTX_EOL", ENABLE); + + /* Fix mv aa.bb aa */ + set_feature_default("DECC$RENAME_NO_INHERIT", ENABLE); + + if(use_unix_settings) { + + /* POSIX requires that open files be able to be removed */ + set_feature_default("DECC$ALLOW_REMOVE_OPEN_FILES", ENABLE); + + /* Default to outputting Unix filenames in VMS routines */ + set_feature_default("DECC$FILENAME_UNIX_ONLY", ENABLE); + /* FILENAME_UNIX_ONLY Implicitly sets */ + /* decc$disable_to_vms_logname_translation */ + + set_feature_default("DECC$FILE_PERMISSION_UNIX", ENABLE); + + set_feature_default("DECC$FILE_SHARING", ENABLE); + + set_feature_default("DECC$FILE_OWNER_UNIX", ENABLE); + set_feature_default("DECC$POSIX_SEEK_STREAM_FILE", ENABLE); + } + else { + set_feature_default("DECC$FILENAME_UNIX_REPORT", ENABLE); + } + + /* When reporting Unix filenames, glob the same way */ + set_feature_default("DECC$GLOB_UNIX_STYLE", ENABLE); + + /* The VMS version numbers on Unix filenames is incompatible with most */ + /* ported packages. */ + set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", ENABLE); + + /* The VMS version numbers on Unix filenames is incompatible with most */ + /* ported packages. */ + set_feature_default("DECC$UNIX_PATH_BEFORE_LOGNAME", ENABLE); + + /* Set strtol to proper behavior */ + set_feature_default("DECC$STRTOL_ERANGE", ENABLE); + + /* Commented here to prevent future bugs: A program or user should */ + /* never ever enable DECC$POSIX_STYLE_UID. */ + /* It will probably break all code that accesses UIDs */ +#if 0 + do_not_set_default("DECC$POSIX_STYLE_UID", TRUE); +#endif +} + +/* Some boilerplate to force this to be a proper LIB$INITIALIZE section */ + +#pragma nostandard +#pragma extern_model save +#ifdef __VAX +#pragma extern_model strict_refdef "LIB$INITIALIZE" nowrt, long, nopic +#else +#pragma extern_model strict_refdef "LIB$INITIALIZE" nowrt, long +# if __INITIAL_POINTER_SIZE +# pragma __pointer_size __save +# pragma __pointer_size 32 +# else +# pragma __required_pointer_size __save +# pragma __required_pointer_size 32 +# endif +#endif +/* Set our contribution to the LIB$INITIALIZE array */ +void (* const iniarray[])(void) = { set_features }; +#ifndef __VAX +# if __INITIAL_POINTER_SIZE +# pragma __pointer_size __restore +# else +# pragma __required_pointer_size __restore +# endif +#endif + +/* +** Force a reference to LIB$INITIALIZE to ensure it +** exists in the image. +*/ +int LIB$INITIALIZE(void); +#ifdef __DECC +#pragma extern_model strict_refdef +#endif +int lib_init_ref = (int)LIB$INITIALIZE; +#ifdef __DECC +#pragma extern_model restore +#pragma standard +#endif diff --git a/3rdparty/curl-8.21.0/projects/vms/curl_gnv_build_steps.txt b/3rdparty/curl-8.21.0/projects/vms/curl_gnv_build_steps.txt new file mode 100644 index 0000000000..88af34f580 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/curl_gnv_build_steps.txt @@ -0,0 +1,290 @@ +From File: curl_gnv_build_steps.txt + + Copyright (C) John Malmberg + + Permission to use, copy, modify, and/or distribute this software for any + purpose with or without fee is hereby granted, provided that the above + copyright notice and this permission notice appear in all copies. + + THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT + OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + + SPDX-License-Identifier: ISC + +Currently building curl using GNV takes longer than building curl via DCL. +The GNV procedure actually uses the same configure and makefiles that +Unix builds use. + +Building curl on OpenVMS using GNV requires GNV v2.1-2 or the updated +images that are available via anonymous FTP at encompasserve.org in the gnv +directory. It also requires the GNV Bash 4.2.45 kit as an update from the +same location or from the sourceforge.net GNV project. + +The HP C 7.x compiler was used for building the GNV version. + +The source kits are provided in backup savesets inside of the PCSI install kit. + +Backup save sets are currently the only distribution medium that I can be +sure is installed on a target VMS system that will correctly unpack files +with extended character sets in them. You may need to adjust the ownership +of the restored files, since /Interchange/noconvert was not available at the +time that this document was written. + +[gnv.common_src]curl_*_original_src.bck is the original source of the curl kit +as provided by the curl project. [gnv.vms_src]curl-*_vms_src.bck, if present, +has the OpenVMS specific files that are used for building that are not yet in +the curl source kits for that release distributed https://curl.se/ + +These backup savesets should be restored to different directory trees on +an ODS-5 volume(s) which are referenced by concealed rooted logical names. + +SRC_ROOT: is for the source files common to all platforms. +VMS_ROOT: is for the source files that are specific to OpenVMS. + Note, you should create the VMS_ROOT: directory tree even if it is + initially empty. This is where you should put edits if you are + making changes. +LCL_ROOT: is manually created to have the same base and subdirectories as + SRC_ROOT: and VMS_ROOT: + +The logical name REF_ROOT: may be defined to be a search list for +VMS_ROOT:,SRC_ROOT: + +The logical name PRJ_ROOT: is defined to be a search list for +LCL_ROOT:,VMS_ROOT:,SRC_ROOT: + +For the make install process to work, it must have write access to the +directories referenced by the GNU: logical name. + +In future releases of GNV, and with GNV Bash 4.3.30 installed, this name +should be GNV$GNU: + +As directly updating those directories would probably be disruptive to other +users of the system and require elevated privilege, this can be handled by +creating a separate directory tree to install into which can be referenced +by the concealed rooted logical name new_gnu:. A concealed logical name of +OLD_GNU: can be set up to reference the real GNV directory tree. + +Then a local copy of the GNU/GNV$GNU logical names can be set up as a search +list such as NEW_GNU:,OLD_GNU: + +The directory NEW_GNU:[usr] should be created. The make install phase should +create all the other directories. + +The make install process may abort if curl is already because it can not +uninstall the older version of curl because it does not have permission. + +The file stage_curl_install.com is used set up a new_gnu: directory tree +for testing. The PCSI kitting procedure uses these files as input. + +These files do not create the directories in the VMS_ROOT and LCL_ROOT +directory trees. You can create them with commands similar to: + + $ create/dir lcl_root:[curl]/prot=w:re + $ copy src_root:[curl...]*.dir - + lcl_root:[curl...]/prot=(o:rwed,w:re) + $ create/dir vms_root:[curl]/prot=w:re + $ copy src_root:[curl...]*.dir - + vms_root:[curl...]/prot=(o:rwed,w:re) + +One of the ways with to protect the source from being modified is to have +the directories under src_root: owned by a user or resource where the build +username only has read access to it. + + +Note to builders: + +GNV currently has a bug where configure scripts take a long time to run. +Some of the configure steps take a while to complete, and on a 600 Mhz +DS10 with IDE disks, taking an hour to run the curl configure is normal. + +The following messages can be ignored and may get fixed in a future version +of GNV. The GNV$*.OPT files are used to find the libraries as many have +different names on VMS than on Unix. The Bash environment variable +GNV_CC_QUALIFIERS can override all other settings for the C Compiler. + +? cc: No support for switch -warnprotos +? cc: Unrecognized file toomanyargs +? cc: Warning: library "ssl" not found +? cc: Warning: library "crypto" not found +? cc: Warning: library "gssapi" not found +? cc: Warning: library "z" not found +u unimplemented switch - ignored + + +With these search lists set up and the properly, curl can be built by +setting your default to PRJ_ROOT:[curl.projects.vms] and then issuing +either the command: + + $ @pcsi_product_gnv_curl.com + +or + + $ @build_gnv_curl.com. + +The GNV configure procedure takes considerably longer than the DCL build +procedure takes. It is of use for testing the GNV build environment, and +may not have been kept up to date. + +The pcsi_product_gnv_curl.com needs the following logical names which +are described in the section below: + + gnv_pcsi_producer + gnv_pcsi_producer_full_name + stage_root + vms_root1 (Optional if vms_root is on a NFS volume) + src_root1 (Optional if src_root is on a NFS volume) + +The pcsi_product_gnv_curl.com is described in more detail below. It does +the following steps. The build steps are only done if they are needed to +allow using either DCL or GNV based building procedures. + + $ @build_vms list + + $ @gnv_link_curl.com + + $ @build_gnv_curl_release_notes.com + + $ @backup_gnv_curl_src.com + + $ @build_gnv_curl_pcsi_desc.com + + $ @build_gnv_curl_pcsi_text.com + + $ @stage_curl_install remove + $ @stage_curl_install + + Then builds the kit. + +The build_gnv_curl.com command procedure does the following: + + $ @setup_gnv_curl_build.com + + $ bash gnv_curl_configure.sh + + $ @clean_gnv_curl.com + + $ bash make_gnv_curl_install.sh + + $ @gnv_link_curl.com + + $ @stage_curl_install.com + + $ purge new_gnu:[*...]/log + +To clean up after a GNV based build to start over, the following commands are +used: + + $ bash + bash$ cd ../.. + bash$ make clean + bash$ exit + +Then run the @clean_gnv_curl.com. Use the parameter "realclean" if you are +going to run the setup_gnv_curl_build.com and configure script again. + + $ @clean_gnv_curl.com realclean + +If new public symbols have been added, adjust the file gnv_libcurl_symbols.opt +to have the new symbols. If the symbols are longer than 32 characters, +then they will need to have the original be exact case CRC shortened and +an alias in upper case with CRC shortened, in addition to having an exact +case truncated alias and an uppercase truncated alias. + +The *.EXE files are not moved to the new_gnu: directory. + +After you are satisfied with the results of your build, you can move the +files from new_gnu: to old_gnu: at your convenience. + +Building a PCSI kit for an architecture takes the following steps after +making sure that you have a working build environment. + +Note that it requires manually creating two logical names as described +below. It is intentional that they be manually set. This is for +branding the PCSI kit based on who is making the kit. + + 1. Make sure that you have a staging directory that can be referenced + by the path STAGE_ROOT:[KIT] + + 2. Edit the file curl_release_note_start.txt or other text files to + reflect any changes. + + 3. Define the logical name GNV_PCSI_PRODUCER to indicate who is making + the distribution. For making updates to an existing open source + kit you may need to keep the producer the same. + + 4. Define the logical name GNV_PCSI_PRODUCER_FULL_NAME to be your full + name or full name of your company. + + 5. If you are producing an update kit, then update the file + vms_eco_level.h by changing the value for the VMS_ECO_LEVEL macro. + This file is currently only used in building the PCSI kit. + + 6. Edit the file PCSI_GNV_CURL_FILE_LIST.TXT if there are new files added + to the kit. These files should all be ODS-2 legal filenames and + directories. + + A limitation of the PCSI kitting procedure is that when selecting files, + it tends to ignore the directory structure and assumes that all files + with the same name are the same file, so every file placed in the kit + must have a unique name. Then a procedure needs to be added to the kit + to create an alias link on install and remove the link on remove. + + Since at this time curl does not need this alias procedure, the steps + to automatically build it are not included here. + + While newer versions of PCSI can support ODS-5 filenames, not all versions + of PCSI on systems that have ODS-5 filenames do. So as a post install + step, the PCSI kit built by these steps does a rename to the correct + case as a post install step. + + 7. Edit the build_curl_pcsi_desc.com and build_curl_pcsi_text.com if you + have changed the version of ZLIB that curl is built against. + + 8. Prepare to backup the files for building the kit. + + Note that if src_root: or vms_root: are NFS mounted disks, the + step of backing up the source files will probably hang or fail. + + You need to copy the source files to VMS mounted disks and create + logical names SRC_ROOT1 and VMS_ROOT1 to work around this to + reference local disks. Make sure src_root1:[000000] and + vms_root1:[000000] exist and can be written to. + + The command procedure compare_curl_source can be used to check + those directories and keep them up to date. + + @compare_curl_source.com SRCBCK UPDATE + + This compares the reference project source with the backup + staging directory for it and updates with any changes. + + @compare_curl_source.com VMSBCK UPDATE + + This compares the VMS specific source with the backup + staging directory for it and updates with any changes. + + Leave off "UPDATE" to check without doing any changes. + + If you are not using NFS mounted disks and do not want to have a + separate directory for staging the sources for backup make sure + that src_root1: and vms_root1: do not exist. + + 9. Build the PCSI kit with @pcsi_product_gnv_curl.com + + The following message is normal: + %PCSI-I-CANNOTVAL, cannot validate + EAGLE$DQA0:[stage_root.][kit]VMSPORTS-AXPVMS-CURL-V0731-0-1.PCSI;1 + -PCSI-I-NOTSIGNED, product kit is not signed and therefore has + no manifest file + + This will result in an uncompressed kit for the target platform. + On Alpha and Integrity, the pcsi_product_gnv_curl.com can be used with + the "COMPRESSED" parameter to build both a compressed and uncompressed + kits. + +Good Luck. diff --git a/3rdparty/curl-8.21.0/projects/vms/curl_release_note_start.txt b/3rdparty/curl-8.21.0/projects/vms/curl_release_note_start.txt new file mode 100644 index 0000000000..184b458dd6 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/curl_release_note_start.txt @@ -0,0 +1,77 @@ +From file: CURL_RELEASE_NOTE_START.TXT + +Note: These kits are produced by a hobbyist and are providing any support +or any commitment to supply bug fixes or future releases. This code is +as-is with no warranties. + +The testing of this build of curl was minimal and involved building some of +the sample and test programs, accessing a public HTTPS: website, doing a +form post of some VMS test files, and FTP upload of some text files. + +Due to the way that PCSI identifies packages, if you install a package from +one producer and then want to upgrade it from another producer, you will +probably need to uninstall the previous package first. + +OpenVMS specific building and kitting instructions are after the standard +curl readme file. + +This product may be available for your platform in a PCSI kit. The source kit +contains files for building curl using GNV or with a DCL procedure. + +The GNV based build creates a libcurl share imaged which is supplied in the +PCSI kit. + +This version of curl will return VMS compatible status codes when run from +DCL and Unix compatible exit codes and messages when run with the SHELL +environment variable set. + +This port of curl uses the OpenSSL, Ldap, and Kerberos V5 that are bundled +with OpenVMS or supplied as updates by HP. Ldap and Kerberos are not available +on the VAX platform. See section below for a special note about HP OpenSSL +on Alpha and IA64. + +The supplied CURL_STARTUP.COM procedure that is installed in +[VMS$COMMON.SYS$STARTUP] can be put in your VMS startup procedure to install +the GNV$LIBCURL shared image and create logical names GNV$LIBCURL to reference +it. It will create the GNV$CURL_INCLUDE logical name for build procedures +to access the header files. + +Normally to use curl from DCL, create a foreign command as: + curl :== $gnv$gnu:[usr.bin]gnv$curl.exe + +If you need to work around having the older HP SSL kit installed, then +for DCL create this command procedure: + + $ create/dir gnv$gnu:[vms_bin]/prot=w:re + $ create gnv$gnu:[vms_bin]curl.com + $ curl := $gnv$gnu:[usr.bin]gnv$curl.exe + $ define/user ssl$libcrypto_shr32 gnv$curl_ssl_libcryptoshr32 + $ curl "''p1'" "''p2'" "''p3'" "''p4'" "''p5'" "''p6'" "''p7'" "''p8'" + ^Z + +Then you can use: curl :== @gnv$gnu:[vms_bin]curl.com to run curl. + +For the HP SSL work around to work for GNV do the following: + $ create/dir gnv$gnu:[usr.local.bin]/prot=w:re + $ create gnv$gnu:[usr.local.bin]curl. + #! /bin/sh + dcl @gnv\$gnu:[vms_bin]curl.com $* + ^Z + +Similar workarounds will be needed for any program linked with GNV$LIBCURL +until the HP OpenSSL is upgraded to the current 1.4 version or later. + +If you are installing a "daily" build instead of a release build of curl, some +things have been changed so that it can be installed at the same time as +a production build without conflicts. + + The CURL_DAILY_STARTUP.COM will be supplied instead of CURL_STARTUP.COM. + This file is actually not used with the daily package and is provided as + a preview of what the next CURL_STARTUP.COM will be for the next release. + Do not run it. + + The files that are normally installed in [VMS$COMMON.GNV.usr], for the + daily build are installed in [VMS$COMMON.GNV.beta] directory. + + To use the daily GNV$LIBCURL image, you will need to define the logical + name GNV$LIBCURL to the image. diff --git a/3rdparty/curl-8.21.0/projects/vms/curl_startup.com b/3rdparty/curl-8.21.0/projects/vms/curl_startup.com new file mode 100644 index 0000000000..7e5b2729d8 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/curl_startup.com @@ -0,0 +1,98 @@ +$! File: curl_Startup.com +$! +$! Procedure to setup the curl libraries for use by programs from the +$! VMS SYSTARTUP*.COM procedure. +$! +$! Copyright (C) John Malmberg +$! +$! Permission to use, copy, modify, and/or distribute this software for any +$! purpose with or without fee is hereby granted, provided that the above +$! copyright notice and this permission notice appear in all copies. +$! +$! THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +$! WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +$! MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +$! ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +$! WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +$! ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT +$! OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +$! +$! SPDX-License-Identifier: ISC +$! +$!======================================================================== +$! +$! +$! GNV$GNU if needed. +$ if f$trnlnm("GNV$GNU") .eqs. "" +$ then +$ x = f$trnlnm("GNU","LNM$SYSTEM_TABLE") +$ if x .eqs. "" +$ then +$ write sys$output "GNV must be started up before this procedure. +$ exit 44 +$ endif +$ define/system/exec/trans=conc GNV$GNU 'x' +$ endif +$! +$! +$ myproc = f$environment("procedure") +$! +$! ZLIB needed. +$ if f$trnlnm("GNV$LIBZSHR32") .eqs. "" +$ then +$ zlib_startup = f$parse("gnv$zlib_startup.com;0", myproc,,,) +$ if f$search(zlib_startup) .nes. "" +$ then +$ @'zlib_startup +$ else +$ write sys$output "ZLIB package not found and is required." +$ exit 44 +$ endif +$ endif +$! +$! +$ curl_ssl_libcrypto32 = "" +$ curl_ssl_libssl32 = "" +$ gnv_ssl_libcrypto32 = "gnv$gnu:[lib]ssl$libcrypto_shr32.exe" +$ gnv_ssl_libssl32 = "gnv$gnu:[lib]ssl$libssl_shr32.exe" +$ if f$search(gnv_ssl_libcrypto32) .nes. "" +$ then +$ curl_ssl_libcrypto32 = gnv_ssl_libcrypto32 +$ curl_ssl_libssl32 = gnv_ssl_libssl32 +$ else +$ hp_ssl_libcrypto32 = "sys$share:ssl$libcrypto_shr32.exe" +$ hp_ssl_libssl32 = "sys$share:ssl$libssl_shr32.exe" +$ if f$search(hp_ssl_libcrypto32) .nes. "" +$ then +$ curl_ssl_libcrypto32 = hp_ssl_libcrypto32 +$ curl_ssl_libssl32 = hp_ssl_libssl32 +$ else +$ write sys$output "HP SSL package not found and is required." +$ endif +$ endif +$! +$ define/system/exec gnv$curl_ssl_libcryptoshr32 'curl_ssl_libcrypto32' +$ define/system/exec gnv$curl_ssl_libsslshr32 'curl_ssl_libssl32' +$! +$! +$! curl setup +$ define/system/exec gnv$libcurl gnv$gnu:[usr.lib]GNV$LIBCURL.EXE +$ define/system/exec gnv$curl_include gnv$gnu:[usr.include.curl] +$ if .not. f$file_attributes("gnv$libcurl", "known") +$ then +$ install ADD gnv$libcurl/OPEN/SHARE/HEADER +$ else +$ install REPLACE gnv$libcurl/OPEN/SHARE/HEADER +$ endif +$! +$! +$ curl_exe = "gnv$gnu:[usr.bin]gnv$curl.exe" +$ if .not. f$file_attributes(curl_exe, "known") +$ then +$ install ADD 'curl_exe'/OPEN/SHARE/HEADER +$ else +$ install REPLACE 'curl_exe'/OPEN/SHARE/HEADER +$ endif +$! +$all_exit: +$ exit diff --git a/3rdparty/curl-8.21.0/projects/vms/curlmsg.h b/3rdparty/curl-8.21.0/projects/vms/curlmsg.h new file mode 100644 index 0000000000..f05c3a8f5a --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/curlmsg.h @@ -0,0 +1,143 @@ +#ifndef HEADER_CURLMSG_H +#define HEADER_CURLMSG_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +#pragma __member_alignment __save +#pragma __nomember_alignment + +/* */ +/* CURLMSG.H */ +/* */ +/* SDL File Generated by VAX-11 Message V04-00 on 3-SEP-2008 13:33:54.09 */ +/* */ +/* THESE VMS ERROR CODES ARE GENERATED BY TAKING APART THE CURL.H */ +/* FILE AND PUTTING ALL THE CURLE_* ENUM STUFF INTO THIS FILE, */ +/* CURLMSG.MSG. AN .SDL FILE IS CREATED FROM THIS FILE WITH */ +/* MESSAGE/SDL. THE .H FILE IS CREATED USING THE FREEWARE SDL TOOL */ +/* AGAINST THE .SDL FILE WITH SDL/ALPHA/LANG=CC COMMAND. */ +/* */ +/* WITH THE EXCEPTION OF CURLE_OK, ALL OF THE MESSAGES ARE AT */ +/* THE ERROR SEVERITY LEVEL. WITH THE EXCEPTION OF */ +/* PEER_FAILED_VERIF, WHICH IS A SHORTENED FORM OF */ +/* PEER_FAILED_VERIFICATION, THESE ARE THE SAME NAMES AS THE */ +/* CURLE_ ONES IN INCLUDE/CURL.H. THE MESSAGE UTILITY MANUAL STATES */ +/* "THE COMBINED LENGTH OF THE PREFIX AND THE MESSAGE SYMBOL NAME CANNOT */ +/* EXCEED 31 CHARACTERS." WITH A PREFIX OF FIVE THAT LEAVES US WITH 26 */ +/* FOR THE MESSAGE NAME. */ +/* */ +/* IF YOU UPDATE THIS FILE, UPDATE CURLMSG_VMS.H SO THAT THEY ARE IN SYNC */ +/* */ + +#define CURL_FACILITY 3841 +#define CURL_OK 251756553 +#define CURL_UNSUPPORTED_PROTOCOL 251756562 +#define CURL_FAILED_INIT 251756570 +#define CURL_URL_MALFORMAT 251756578 +#define CURL_OBSOLETE4 251756586 +#define CURL_COULDNT_RESOLVE_PROXY 251756594 +#define CURL_COULDNT_RESOLVE_HOST 251756602 +#define CURL_COULDNT_CONNECT 251756610 +#define CURL_WEIRD_SERVER_REPLY 251756618 +#define CURL_FTP_WEIRD_SERVER_REPLY CURL_WEIRD_SERVER_REPLY +#define CURL_FTP_ACCESS_DENIED 251756626 +#define CURL_OBSOLETE10 251756634 +#define CURL_FTP_WEIRD_PASS_REPLY 251756642 +#define CURL_OBSOLETE12 251756650 +#define CURL_FTP_WEIRD_PASV_REPLY 251756658 +#define CURL_FTP_WEIRD_227_FORMAT 251756666 +#define CURL_FTP_CANT_GET_HOST 251756674 +#define CURL_OBSOLETE16 251756682 +#define CURL_FTP_COULDNT_SET_TYPE 251756690 +#define CURL_PARTIAL_FILE 251756698 +#define CURL_FTP_COULDNT_RETR_FILE 251756706 +#define CURL_OBSOLETE20 251756714 +#define CURL_QUOTE_ERROR 251756722 +#define CURL_HTTP_RETURNED_ERROR 251756730 +#define CURL_WRITE_ERROR 251756738 +#define CURL_OBSOLETE24 251756746 +#define CURL_UPLOAD_FAILED 251756754 +#define CURL_READ_ERROR 251756762 +#define CURL_OUT_OF_MEMORY 251756770 +#define CURL_OPERATION_TIMEOUTED 251756778 +#define CURL_OBSOLETE29 251756786 +#define CURL_FTP_PORT_FAILED 251756794 +#define CURL_FTP_COULDNT_USE_REST 251756802 +#define CURL_OBSOLETE32 251756810 +#define CURL_RANGE_ERROR 251756818 +#define CURL_HTTP_POST_ERROR 251756826 +#define CURL_SSL_CONNECT_ERROR 251756834 +#define CURL_BAD_DOWNLOAD_RESUME 251756842 +#define CURL_FILE_COULDNT_READ_FILE 251756850 +#define CURL_LDAP_CANNOT_BIND 251756858 +#define CURL_LDAP_SEARCH_FAILED 251756866 +#define CURL_OBSOLETE40 251756874 +#define CURL_FUNCTION_NOT_FOUND 251756882 +#define CURL_ABORTED_BY_CALLBACK 251756890 +#define CURL_BAD_FUNCTION_ARGUMENT 251756898 +#define CURL_OBSOLETE44 251756906 +#define CURL_INTERFACE_FAILED 251756914 +#define CURL_OBSOLETE46 251756922 +#define CURL_TOO_MANY_REDIRECTS 251756930 +#define CURL_UNKNOWN_TELNET_OPTION 251756938 +#define CURL_TELNET_OPTION_SYNTAX 251756946 +#define CURL_OBSOLETE50 251756954 +#define CURL_PEER_FAILED_VERIF 251756962 +#define CURL_GOT_NOTHING 251756970 +#define CURL_SSL_ENGINE_NOTFOUND 251756978 +#define CURL_SSL_ENGINE_SETFAILED 251756986 +#define CURL_SEND_ERROR 251756994 +#define CURL_RECV_ERROR 251757002 +#define CURL_OBSOLETE57 251757010 +#define CURL_SSL_CERTPROBLEM 251757018 +#define CURL_SSL_CIPHER 251757026 +#define CURL_SSL_CACERT 251757034 +#define CURL_BAD_CONTENT_ENCODING 251757042 +#define CURL_LDAP_INVALID_URL 251757050 +#define CURL_FILESIZE_EXCEEDED 251757058 +#define CURL_USE_SSL_FAILED 251757066 +#define CURL_SEND_FAIL_REWIND 251757074 +#define CURL_SSL_ENGINE_INITFAILED 251757082 +#define CURL_LOGIN_DENIED 251757090 +#define CURL_TFTP_NOTFOUND 251757098 +#define CURL_TFTP_PERM 251757106 +#define CURL_REMOTE_DISK_FULL 251757114 +#define CURL_TFTP_ILLEGAL 251757122 +#define CURL_TFTP_UNKNOWNID 251757130 +#define CURL_REMOTE_FILE_EXISTS 251757138 +#define CURL_TFTP_NOSUCHUSER 251757146 +#define CURL_CONV_FAILED 251757154 +#define CURL_CONV_REQD 251757162 +#define CURL_SSL_CACERT_BADFILE 251757170 +#define CURL_REMOTE_FILE_NOT_FOUND 251757178 +#define CURL_SSH 251757186 +#define CURL_SSL_SHUTDOWN_FAILED 251757194 +#define CURL_AGAIN 251757202 +#define CURL_SSL_CRL_BADFILE 251757210 +#define CURL_SSL_ISSUER_ERROR 251757218 +#define CURL_CURL_LAST 251757226 + +#pragma __member_alignment __restore + +#endif /* HEADER_CURLMSG_H */ diff --git a/3rdparty/curl-8.21.0/projects/vms/curlmsg.msg b/3rdparty/curl-8.21.0/projects/vms/curlmsg.msg new file mode 100644 index 0000000000..b02fe5649c --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/curlmsg.msg @@ -0,0 +1,134 @@ +!*************************************************************************** +! _ _ ____ _ +! Project ___| | | | _ \| | +! / __| | | | |_) | | +! | (__| |_| | _ <| |___ +! \___|\___/|_| \_\_____| +! +! Copyright (C) Daniel Stenberg, , et al. +! +! This software is licensed as described in the file COPYING, which +! you should have received as part of this distribution. The terms +! are also available at https://curl.se/docs/copyright.html. +! +! You may opt to use, copy, modify, merge, publish, distribute and/or sell +! copies of the Software, and permit persons to whom the Software is +! furnished to do so, under the terms of the COPYING file. +! +! This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +! KIND, either express or implied. +! +! SPDX-License-Identifier: curl +! +!########################################################################## +! +! These VMS error codes are generated by taking apart the curl.h +! file and putting all the CURLE_* enum stuff into this file, +! CURLMSG.MSG. An .SDL file is created from this file with +! MESSAGE/SDL. The .H file is created using the freeware SDL tool +! against the .SDL file with SDL/ALPHA/LANG=CC command. +! +! With the exception of CURLE_OK, all of the messages are at +! the error severity level. With the exception of +! PEER_FAILED_VERIF, which is a shortened form of +! PEER_FAILED_VERIFICATION, these are the same names as the +! CURLE_ ones in include/curl.h. The Message Utility manual states +! "The combined length of the prefix and the message symbol name cannot +! exceed 31 characters." With a prefix of five that leaves us with 26 +! for the message name. +! +! If you update this file also update curlmsg_vms.h so that they are in sync +! +.TITLE CURLMSG Message files +.FACILITY CURL,1793 /PREFIX=CURL_ +.BASE 1 +.SEVERITY SUCCESS +OK + +.SEVERITY ERROR +UNSUPPORTED_PROTOCOL +FAILED_INIT +URL_MALFORMAT +OBSOLETE4 +COULDNT_RESOLVE_PROXY +COULDNT_RESOLVE_HOST +COULDNT_CONNECT +WEIRD_SERVER_REPLY +FTP_ACCESS_DENIED +OBSOLETE10 +FTP_WEIRD_PASS_REPLY +OBSOLETE12 +FTP_WEIRD_PASV_REPLY +FTP_WEIRD_227_FORMAT +FTP_CANT_GET_HOST +OBSOLETE16 +FTP_COULDNT_SET_TYPE +PARTIAL_FILE +FTP_COULDNT_RETR_FILE +OBSOLETE20 +QUOTE_ERROR +HTTP_RETURNED_ERROR +WRITE_ERROR +OBSOLETE24 +UPLOAD_FAILED +READ_ERROR +OUT_OF_MEMORY +OPERATION_TIMEOUTED +OBSOLETE29 +FTP_PORT_FAILED +FTP_COULDNT_USE_REST +OBSOLETE32 +RANGE_ERROR +HTTP_POST_ERROR +SSL_CONNECT_ERROR +BAD_DOWNLOAD_RESUME +FILE_COULDNT_READ_FILE +LDAP_CANNOT_BIND +LDAP_SEARCH_FAILED +OBSOLETE40 +FUNCTION_NOT_FOUND +ABORTED_BY_CALLBACK +BAD_FUNCTION_ARGUMENT +OBSOLETE44 +INTERFACE_FAILED +OBSOLETE46 +TOO_MANY_REDIRECTS +UNKNOWN_TELNET_OPTION +TELNET_OPTION_SYNTAX +OBSOLETE50 +PEER_FAILED_VERIF +GOT_NOTHING +SSL_ENGINE_NOTFOUND +SSL_ENGINE_SETFAILED +SEND_ERROR +RECV_ERROR +OBSOLETE57 +SSL_CERTPROBLEM +SSL_CIPHER +SSL_CACERT +BAD_CONTENT_ENCODING +LDAP_INVALID_URL +FILESIZE_EXCEEDED +USE_SSL_FAILED +SEND_FAIL_REWIND +SSL_ENGINE_INITFAILED +LOGIN_DENIED +TFTP_NOTFOUND +TFTP_PERM +REMOTE_DISK_FULL +TFTP_ILLEGAL +TFTP_UNKNOWNID +REMOTE_FILE_EXISTS +TFTP_NOSUCHUSER +CONV_FAILED +CONV_REQD +SSL_CACERT_BADFILE +REMOTE_FILE_NOT_FOUND +SSH +SSL_SHUTDOWN_FAILED +AGAIN +SSL_CRL_BADFILE +SSL_ISSUER_ERROR +CURL_LAST + +.END diff --git a/3rdparty/curl-8.21.0/projects/vms/curlmsg.sdl b/3rdparty/curl-8.21.0/projects/vms/curlmsg.sdl new file mode 100644 index 0000000000..db5baad606 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/curlmsg.sdl @@ -0,0 +1,116 @@ + + + MODULE $CURDEF; + +/* +/* This SDL File Generated by VAX-11 Message V04-00 on 3-SEP-2008 13:33:54.09 +/* +/* $ID: CURLMSG.MSG,V 1.7 2008-05-30 23:51:09 CURLVMS EXP $ +/* +/* THESE VMS ERROR CODES ARE GENERATED BY TAKING APART THE CURL.H +/* FILE AND PUTTING ALL THE CURLE_* ENUM STUFF INTO THIS FILE, +/* CURLMSG.MSG. AN .SDL FILE IS CREATED FROM THIS FILE WITH +/* MESSAGE/SDL. THE .H FILE IS CREATED USING THE FREEWARE SDL TOOL +/* AGAINST THE .SDL FILE WITH SDL/ALPHA/LANG=CC COMMAND. +/* +/* WITH THE EXCEPTION OF CURLE_OK, ALL OF THE MESSAGES ARE AT +/* THE ERROR SEVERITY LEVEL. WITH THE EXCEPTION OF +/* PEER_FAILED_VERIF, WHICH IS A SHORTENED FORM OF +/* PEER_FAILED_VERIFICATION, THESE ARE THE SAME NAMES AS THE +/* CURLE_ ONES IN INCLUDE/CURL.H. THE MESSAGE UTILITY MANUAL STATES +/* "THE COMBINED LENGTH OF THE PREFIX AND THE MESSAGE SYMBOL NAME CANNOT +/* EXCEED 31 CHARACTERS." WITH A PREFIX OF FIVE THAT LEAVES US WITH 26 +/* FOR THE MESSAGE NAME. +/* +/* IF YOU UPDATE THIS FILE ALSO UPDATE CURLMSG_VMS.H SO THAT THEY ARE IN SYNC +/* + CONSTANT + "FACILITY" EQUALS 3841 PREFIX "CURL" TAG "" + ,"OK" EQUALS %X0F018009 PREFIX "CURL" TAG "" + ,"UNSUPPORTED_PROTOCOL" EQUALS %X0F018012 PREFIX "CURL" TAG "" + ,"FAILED_INIT" EQUALS %X0F01801A PREFIX "CURL" TAG "" + ,"URL_MALFORMAT" EQUALS %X0F018022 PREFIX "CURL" TAG "" + ,"OBSOLETE4" EQUALS %X0F01802A PREFIX "CURL" TAG "" + ,"COULDNT_RESOLVE_PROXY" EQUALS %X0F018032 PREFIX "CURL" TAG "" + ,"COULDNT_RESOLVE_HOST" EQUALS %X0F01803A PREFIX "CURL" TAG "" + ,"COULDNT_CONNECT" EQUALS %X0F018042 PREFIX "CURL" TAG "" + ,"WEIRD_SERVER_REPLY" EQUALS %X0F01804A PREFIX "CURL" TAG "" + ,"FTP_WEIRD_SERVER_REPLY" EQUALS %X0F01804A PREFIX "CURL" TAG "" + ,"FTP_ACCESS_DENIED" EQUALS %X0F018052 PREFIX "CURL" TAG "" + ,"OBSOLETE10" EQUALS %X0F01805A PREFIX "CURL" TAG "" + ,"FTP_WEIRD_PASS_REPLY" EQUALS %X0F018062 PREFIX "CURL" TAG "" + ,"OBSOLETE12" EQUALS %X0F01806A PREFIX "CURL" TAG "" + ,"FTP_WEIRD_PASV_REPLY" EQUALS %X0F018072 PREFIX "CURL" TAG "" + ,"FTP_WEIRD_227_FORMAT" EQUALS %X0F01807A PREFIX "CURL" TAG "" + ,"FTP_CANT_GET_HOST" EQUALS %X0F018082 PREFIX "CURL" TAG "" + ,"OBSOLETE16" EQUALS %X0F01808A PREFIX "CURL" TAG "" + ,"FTP_COULDNT_SET_TYPE" EQUALS %X0F018092 PREFIX "CURL" TAG "" + ,"PARTIAL_FILE" EQUALS %X0F01809A PREFIX "CURL" TAG "" + ,"FTP_COULDNT_RETR_FILE" EQUALS %X0F0180A2 PREFIX "CURL" TAG "" + ,"OBSOLETE20" EQUALS %X0F0180AA PREFIX "CURL" TAG "" + ,"QUOTE_ERROR" EQUALS %X0F0180B2 PREFIX "CURL" TAG "" + ,"HTTP_RETURNED_ERROR" EQUALS %X0F0180BA PREFIX "CURL" TAG "" + ,"WRITE_ERROR" EQUALS %X0F0180C2 PREFIX "CURL" TAG "" + ,"OBSOLETE24" EQUALS %X0F0180CA PREFIX "CURL" TAG "" + ,"UPLOAD_FAILED" EQUALS %X0F0180D2 PREFIX "CURL" TAG "" + ,"READ_ERROR" EQUALS %X0F0180DA PREFIX "CURL" TAG "" + ,"OUT_OF_MEMORY" EQUALS %X0F0180E2 PREFIX "CURL" TAG "" + ,"OPERATION_TIMEOUTED" EQUALS %X0F0180EA PREFIX "CURL" TAG "" + ,"OBSOLETE29" EQUALS %X0F0180F2 PREFIX "CURL" TAG "" + ,"FTP_PORT_FAILED" EQUALS %X0F0180FA PREFIX "CURL" TAG "" + ,"FTP_COULDNT_USE_REST" EQUALS %X0F018102 PREFIX "CURL" TAG "" + ,"OBSOLETE32" EQUALS %X0F01810A PREFIX "CURL" TAG "" + ,"RANGE_ERROR" EQUALS %X0F018112 PREFIX "CURL" TAG "" + ,"HTTP_POST_ERROR" EQUALS %X0F01811A PREFIX "CURL" TAG "" + ,"SSL_CONNECT_ERROR" EQUALS %X0F018122 PREFIX "CURL" TAG "" + ,"BAD_DOWNLOAD_RESUME" EQUALS %X0F01812A PREFIX "CURL" TAG "" + ,"FILE_COULDNT_READ_FILE" EQUALS %X0F018132 PREFIX "CURL" TAG "" + ,"LDAP_CANNOT_BIND" EQUALS %X0F01813A PREFIX "CURL" TAG "" + ,"LDAP_SEARCH_FAILED" EQUALS %X0F018142 PREFIX "CURL" TAG "" + ,"OBSOLETE40" EQUALS %X0F01814A PREFIX "CURL" TAG "" + ,"FUNCTION_NOT_FOUND" EQUALS %X0F018152 PREFIX "CURL" TAG "" + ,"ABORTED_BY_CALLBACK" EQUALS %X0F01815A PREFIX "CURL" TAG "" + ,"BAD_FUNCTION_ARGUMENT" EQUALS %X0F018162 PREFIX "CURL" TAG "" + ,"OBSOLETE44" EQUALS %X0F01816A PREFIX "CURL" TAG "" + ,"INTERFACE_FAILED" EQUALS %X0F018172 PREFIX "CURL" TAG "" + ,"OBSOLETE46" EQUALS %X0F01817A PREFIX "CURL" TAG "" + ,"TOO_MANY_REDIRECTS" EQUALS %X0F018182 PREFIX "CURL" TAG "" + ,"UNKNOWN_TELNET_OPTION" EQUALS %X0F01818A PREFIX "CURL" TAG "" + ,"TELNET_OPTION_SYNTAX" EQUALS %X0F018192 PREFIX "CURL" TAG "" + ,"OBSOLETE50" EQUALS %X0F01819A PREFIX "CURL" TAG "" + ,"PEER_FAILED_VERIF" EQUALS %X0F0181A2 PREFIX "CURL" TAG "" + ,"GOT_NOTHING" EQUALS %X0F0181AA PREFIX "CURL" TAG "" + ,"SSL_ENGINE_NOTFOUND" EQUALS %X0F0181B2 PREFIX "CURL" TAG "" + ,"SSL_ENGINE_SETFAILED" EQUALS %X0F0181BA PREFIX "CURL" TAG "" + ,"SEND_ERROR" EQUALS %X0F0181C2 PREFIX "CURL" TAG "" + ,"RECV_ERROR" EQUALS %X0F0181CA PREFIX "CURL" TAG "" + ,"OBSOLETE57" EQUALS %X0F0181D2 PREFIX "CURL" TAG "" + ,"SSL_CERTPROBLEM" EQUALS %X0F0181DA PREFIX "CURL" TAG "" + ,"SSL_CIPHER" EQUALS %X0F0181E2 PREFIX "CURL" TAG "" + ,"SSL_CACERT" EQUALS %X0F0181EA PREFIX "CURL" TAG "" + ,"BAD_CONTENT_ENCODING" EQUALS %X0F0181F2 PREFIX "CURL" TAG "" + ,"LDAP_INVALID_URL" EQUALS %X0F0181FA PREFIX "CURL" TAG "" + ,"FILESIZE_EXCEEDED" EQUALS %X0F018202 PREFIX "CURL" TAG "" + ,"USE_SSL_FAILED" EQUALS %X0F01820A PREFIX "CURL" TAG "" + ,"SEND_FAIL_REWIND" EQUALS %X0F018212 PREFIX "CURL" TAG "" + ,"SSL_ENGINE_INITFAILED" EQUALS %X0F01821A PREFIX "CURL" TAG "" + ,"LOGIN_DENIED" EQUALS %X0F018222 PREFIX "CURL" TAG "" + ,"TFTP_NOTFOUND" EQUALS %X0F01822A PREFIX "CURL" TAG "" + ,"TFTP_PERM" EQUALS %X0F018232 PREFIX "CURL" TAG "" + ,"REMOTE_DISK_FULL" EQUALS %X0F01823A PREFIX "CURL" TAG "" + ,"TFTP_ILLEGAL" EQUALS %X0F018242 PREFIX "CURL" TAG "" + ,"TFTP_UNKNOWNID" EQUALS %X0F01824A PREFIX "CURL" TAG "" + ,"REMOTE_FILE_EXISTS" EQUALS %X0F018252 PREFIX "CURL" TAG "" + ,"TFTP_NOSUCHUSER" EQUALS %X0F01825A PREFIX "CURL" TAG "" + ,"CONV_FAILED" EQUALS %X0F018262 PREFIX "CURL" TAG "" + ,"CONV_REQD" EQUALS %X0F01826A PREFIX "CURL" TAG "" + ,"SSL_CACERT_BADFILE" EQUALS %X0F018272 PREFIX "CURL" TAG "" + ,"REMOTE_FILE_NOT_FOUND" EQUALS %X0F01827A PREFIX "CURL" TAG "" + ,"SSH" EQUALS %X0F018282 PREFIX "CURL" TAG "" + ,"SSL_SHUTDOWN_FAILED" EQUALS %X0F01828A PREFIX "CURL" TAG "" + ,"AGAIN" EQUALS %X0F018292 PREFIX "CURL" TAG "" + ,"SSL_CRL_BADFILE" EQUALS %X0F01829A PREFIX "CURL" TAG "" + ,"SSL_ISSUER_ERROR" EQUALS %X0F0182A2 PREFIX "CURL" TAG "" + ,"CURL_LAST" EQUALS %X0F0182AA PREFIX "CURL" TAG "" + ; + END_MODULE; diff --git a/3rdparty/curl-8.21.0/projects/vms/curlmsg_vms.h b/3rdparty/curl-8.21.0/projects/vms/curlmsg_vms.h new file mode 100644 index 0000000000..83af6400f0 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/curlmsg_vms.h @@ -0,0 +1,129 @@ +#ifndef HEADER_CURLMSG_VMS_H +#define HEADER_CURLMSG_VMS_H +/*************************************************************************** + * _ _ ____ _ + * Project ___| | | | _ \| | + * / __| | | | |_) | | + * | (__| |_| | _ <| |___ + * \___|\___/|_| \_\_____| + * + * Copyright (C) Daniel Stenberg, , et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + ***************************************************************************/ + +/* */ +/* CURLMSG_VMS.H */ +/* */ +/* This defines the necessary bits to change CURLE_* error codes to VMS */ +/* style error codes. CURLMSG.H is built from CURLMSG.SDL which is built */ +/* from CURLMSG.MSG. The vms_cond array is used to return VMS errors by */ +/* putting the VMS error codes into the array offset based on CURLE_* code. */ +/* */ +/* If you update CURLMSG.MSG make sure to update this file to match. */ +/* */ + +#include "curlmsg.h" + +static const long vms_cond[] = +{ + CURL_OK, + CURL_UNSUPPORTED_PROTOCOL, + CURL_FAILED_INIT, + CURL_URL_MALFORMAT, + CURL_OBSOLETE4, + CURL_COULDNT_RESOLVE_PROXY, + CURL_COULDNT_RESOLVE_HOST, + CURL_COULDNT_CONNECT, + CURL_WEIRD_SERVER_REPLY, + CURL_FTP_ACCESS_DENIED, + CURL_OBSOLETE10, + CURL_FTP_WEIRD_PASS_REPLY, + CURL_OBSOLETE12, + CURL_FTP_WEIRD_PASV_REPLY, + CURL_FTP_WEIRD_227_FORMAT, + CURL_FTP_CANT_GET_HOST, + CURL_OBSOLETE16, + CURL_FTP_COULDNT_SET_TYPE, + CURL_PARTIAL_FILE, + CURL_FTP_COULDNT_RETR_FILE, + CURL_OBSOLETE20, + CURL_QUOTE_ERROR, + CURL_HTTP_RETURNED_ERROR, + CURL_WRITE_ERROR, + CURL_OBSOLETE24, + CURL_UPLOAD_FAILED, + CURL_READ_ERROR, + CURL_OUT_OF_MEMORY, + CURL_OPERATION_TIMEOUTED, + CURL_OBSOLETE29, + CURL_FTP_PORT_FAILED, + CURL_FTP_COULDNT_USE_REST, + CURL_OBSOLETE32, + CURL_RANGE_ERROR, + CURL_HTTP_POST_ERROR, + CURL_SSL_CONNECT_ERROR, + CURL_BAD_DOWNLOAD_RESUME, + CURL_FILE_COULDNT_READ_FILE, + CURL_LDAP_CANNOT_BIND, + CURL_LDAP_SEARCH_FAILED, + CURL_OBSOLETE40, + CURL_FUNCTION_NOT_FOUND, + CURL_ABORTED_BY_CALLBACK, + CURL_BAD_FUNCTION_ARGUMENT, + CURL_OBSOLETE44, + CURL_INTERFACE_FAILED, + CURL_OBSOLETE46, + CURL_TOO_MANY_REDIRECTS, + CURL_UNKNOWN_TELNET_OPTION, + CURL_TELNET_OPTION_SYNTAX, + CURL_OBSOLETE50, + CURL_PEER_FAILED_VERIF, + CURL_GOT_NOTHING, + CURL_SSL_ENGINE_NOTFOUND, + CURL_SSL_ENGINE_SETFAILED, + CURL_SEND_ERROR, + CURL_RECV_ERROR, + CURL_OBSOLETE57, + CURL_SSL_CERTPROBLEM, + CURL_SSL_CIPHER, + CURL_SSL_CACERT, + CURL_BAD_CONTENT_ENCODING, + CURL_LDAP_INVALID_URL, + CURL_FILESIZE_EXCEEDED, + CURL_USE_SSL_FAILED, + CURL_SEND_FAIL_REWIND, + CURL_SSL_ENGINE_INITFAILED, + CURL_LOGIN_DENIED, + CURL_TFTP_NOTFOUND, + CURL_TFTP_PERM, + CURL_REMOTE_DISK_FULL, + CURL_TFTP_ILLEGAL, + CURL_TFTP_UNKNOWNID, + CURL_REMOTE_FILE_EXISTS, + CURL_TFTP_NOSUCHUSER, + CURL_CONV_FAILED, + CURL_CONV_REQD, + CURL_SSL_CACERT_BADFILE, + CURL_REMOTE_FILE_NOT_FOUND, + CURL_SSH, + CURL_SSL_SHUTDOWN_FAILED, + CURL_AGAIN, + CURLE_SSL_CRL_BADFILE, + CURLE_SSL_ISSUER_ERROR, + CURL_CURL_LAST +}; + +#endif /* HEADER_CURLMSG_VMS_H */ diff --git a/3rdparty/curl-8.21.0/projects/vms/generate_config_vms_h_curl.com b/3rdparty/curl-8.21.0/projects/vms/generate_config_vms_h_curl.com new file mode 100644 index 0000000000..6e78b801f2 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/generate_config_vms_h_curl.com @@ -0,0 +1,427 @@ +$! File: GENERATE_CONFIG_H_CURL.COM +$! +$! curl like most open source products uses a variant of a config.h file. +$! Depending on the curl version, this could be config.h or curl_config.h. +$! +$! For GNV based builds, the configure script is run and that produces +$! a [curl_]config.h file. Configure scripts on VMS generally do not +$! know how to do everything, so there is also a [-.lib]config-vms.h file +$! that has VMS specific code that compensates for bugs in some of the +$! VMS shared images. +$! +$! This generates a [curl_]config.h file and also a config_vms.h file, +$! which is used to supplement that file. Note that the config_vms.h file +$! and the [.lib]config-vms.h file do two different tasks and that the +$! filenames are slightly different. +$! +$! Copyright (C) John Malmberg +$! +$! Permission to use, copy, modify, and/or distribute this software for any +$! purpose with or without fee is hereby granted, provided that the above +$! copyright notice and this permission notice appear in all copies. +$! +$! THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +$! WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +$! MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +$! ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +$! WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +$! ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT +$! OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +$! +$! SPDX-License-Identifier: ISC +$! +$!========================================================================= +$! +$! Allow arguments to be grouped together with comma or separated by spaces +$! Do no know if we will need more than 8. +$args = "," + p1 + "," + p2 + "," + p3 + "," + p4 + "," +$args = args + p5 + "," + p6 + "," + p7 + "," + p8 + "," +$! +$! Provide lower case version to simplify parsing. +$args_lower = f$edit(args, "LOWERCASE") +$! +$args_len = f$length(args) +$! +$if (f$getsyi("HW_MODEL") .lt. 1024) +$then +$ arch_name = "VAX" +$else +$ arch_name = "" +$ arch_name = arch_name + f$edit(f$getsyi("ARCH_NAME"), "UPCASE") +$ if (arch_name .eqs. "") then arch_name = "UNK" +$endif +$! +$! +$nossl = 0 +$nohpssl = 1 +$hpssl = 0 +$libidn = 0 +$libssh2 = 0 +$noldap = 0 +$nozlib = 0 +$nokerberos = 0 +$! +$! First check to see if SSL is disabled. +$!--------------------------------------- +$if f$locate(",nossl,", args_lower) .lt. args_len then nossl = 1 +$if .not. nossl +$then +$! +$! ssl$* logicals means HP SSL is present +$!---------------------------------------- +$ if f$trnlnm("ssl$root") .nes. "" +$ then +$ nohpssl = 0 +$ hpssl = 1 +$ endif +$! +$! HP defines OPENSSL as SSL$INCLUDE as a convenience for linking. +$! As it is a violation of VMS standards for this to be provided, +$! some sites may have removed it, but if present, assume that +$! it indicates which OpenSSL to use. +$!------------------------------------ +$ openssl_lnm = f$trnlnm("OPENSSL") +$ if (openssl_lnm .nes. "SYS$INCLUDE") +$ then +$! Non HP SSL is installed, default to use it. +$ nohpssl = 1 +$ hpssl = 0 +$ endif +$! +$! Now check to see if hpssl has been specifically disabled +$!---------------------------------------------------------- +$ if f$locate(",nohpssl,", args_lower) .lt. args_len +$ then +$ nohpssl = 1 +$ hpssl = 0 +$ endif +$! +$! Finally check to see if HP SSL has been specifically included. +$!---------------------------------------------------------------- +$ if f$locate(",nohpssl,", args_lower) .lt. args_len +$ then +$ nohpssl = 1 +$ hpssl = 0 +$ endif +$endif +$! +$! Did someone port LIBIDN in the GNV compatible way? +$!------------------------------------------------------ +$if f$trnlnm("GNV$LIBIDNSHR") .nes. "" +$then +$ write sys$output "NOTICE: A LIBIDN port has been detected." +$ write sys$output " This port of curl for VMS has not been tested with it." +$ if f$locate(",libidn,", args_lower) .lt. args_len +$ then +$ libidn = 1 +$ endif +$ if .not. libidn +$ then +$ write sys$output " LIBIDN support is not enabled." +$ write sys$output "Run with the ""libidn"" parameter to attempt to use." +$ else +$ write sys$output " Untested LIBIDN support requested." +$ endif +$endif +$! +$! Did someone port LIBSSH2 in the GNV compatible way? +$!------------------------------------------------------ +$if f$trnlnm("GNV$LIBSSH2SHR") .nes. "" +$then +$ write sys$output "NOTICE: A LIBSSH2 port has been detected." +$ write sys$output " This port of curl for VMS has not been tested with it." +$ if f$locate(",libssh2,", args_lower) .lt. args_len +$ then +$ libssh2 = 1 +$ endif +$ if .not. libssh2 +$ then +$ write sys$output " LIBSSH2 support is not enabled." +$ write sys$output "Run with the ""libssh2"" parameter to attempt to use." +$ else +$ write sys$output " Untested LIBSSH2 support requested." +$ endif +$endif +$! +$! LDAP suppressed? +$if f$locate(",noldap,", args_lower) .lt. args_len +$then +$ noldap = 1 +$endif +$if f$search("SYS$SHARE:LDAP$SHR.EXE") .eqs. "" +$then +$ noldap = 1 +$endif +$! +$if f$locate(",nokerberos,", args_lower) .lt. args_len then nokerberos = 1 +$if .not. nokerberos +$then +$! If kerberos is installed: sys$share:gss$rtl.exe exists. +$ if f$search("sys$shsare:gss$rtl.exe") .eqs. "" +$ then +$ nokerberos = 1 +$ endif +$endif +$! +$! +$! Is GNV compatible LIBZ present? +$!------------------------------------------------------ +$if f$trnlnm("GNV$LIBZSHR") .nes. "" +$then +$ if f$locate(",nozlib,", args_lower) .lt. args_len +$ then +$ nozlib = 1 +$ endif +$! if .not. nozlib +$! then +$! write sys$output " GNV$LIBZSHR support is enabled." +$! else +$! write sys$output " GNV$LIBZSHR support is disabled by nozlib." +$! endif +$else +$ nozlib = 1 +$endif +$! +$! +$! Start the configuration file. +$! Need to do a create and then an append to make the file have the +$! typical file attributes of a VMS text file. +$create sys$disk:[curl.lib]config_vms.h +$open/append cvh sys$disk:[curl.lib]config_vms.h +$! +$! Write the defines to prevent multiple includes. +$! These are probably not needed in this case, +$! but are best practice to put on all header files. +$write cvh "#ifndef __CONFIG_VMS_H__" +$write cvh "#define __CONFIG_VMS_H__" +$write cvh "" +$write cvh "/* Define cpu-machine-OS */" +$! +$! curl uses an OS macro to set the build environment. +$!---------------------------------------------------- +$! Now the DCL builds usually say xxx-HP-VMS and configure scripts +$! may put DEC or COMPAQ or HP for the middle part. +$! +$write cvh "#if defined(__alpha)" +$write cvh "#define CURL_OS ""ALPHA-HP-VMS""" +$write cvh "#elif defined(__vax)" +$write cvh "#define CURL_OS ""VAX-HP-VMS""" +$write cvh "#elif defined(__ia64)" +$write cvh "#define CURL_OS ""IA64-HP-VMS"" +$write cvh "#else" +$write cvh "#define CURL_OS ""UNKNOWN-HP-VMS"" +$write cvh "#endif" +$write cvh "" +$! +$! We are now setting this on the GNV build, so also do this +$! for compatibility. +$write cvh "/* Location of default CA path */" +$write cvh "#define curl_ca_path ""gnv$curl_ca_path""" +$! +$! The config_h.com finds a bunch of default disable commands in +$! configure and will incorrectly disable these options. The config_h.com +$! is a generic procedure and it would break more things to try to fix it +$! to special case it for curl. So we will fix it here. +$! +$! We do them all here, even the ones that config_h.com currently gets correct. +$! +$write cvh "#ifdef CURL_DISABLE_COOKIES" +$write cvh "#undef CURL_DISABLE_COOKIES" +$write cvh "#endif" +$write cvh "#ifdef CURL_DISABLE_DICT" +$write cvh "#undef CURL_DISABLE_DICT" +$write cvh "#endif" +$write cvh "#ifdef CURL_DISABLE_FILE" +$write cvh "#undef CURL_DISABLE_FILE" +$write cvh "#endif" +$write cvh "#ifdef CURL_DISABLE_FTP" +$write cvh "#undef CURL_DISABLE_FTP" +$write cvh "#endif" +$write cvh "#ifdef CURL_DISABLE_GOPHER" +$write cvh "#undef CURL_DISABLE_GOPHER" +$write cvh "#endif" +$write cvh "#ifdef CURL_DISABLE_HTTP" +$write cvh "#undef CURL_DISABLE_HTTP" +$write cvh "#endif" +$write cvh "#ifdef CURL_DISABLE_IMAP" +$write cvh "#undef CURL_DISABLE_IMAP" +$write cvh "#endif" +$if .not. noldap +$then +$ write cvh "#ifdef CURL_DISABLE_LDAP" +$ write cvh "#undef CURL_DISABLE_LDAP" +$ write cvh "#endif" +$ if .not. nossl +$ then +$ write cvh "#ifdef CURL_DISABLE_LDAPS" +$ write cvh "#undef CURL_DISABLE_LDAPS" +$ write cvh "#endif" +$ endif +$endif +$write cvh "#ifdef CURL_DISABLE_LIBCURL_OPTION" +$write cvh "#undef CURL_DISABLE_LIBCURL_OPTION" +$write cvh "#endif" +$write cvh "#ifndef __VAX" +$write cvh "#else" +$! NTLM needs long long or int64 support, missing from DECC C. +$write cvh "#ifdef __DECC +$write cvh "#endif" +$write cvh "#endif" +$write cvh "#ifdef CURL_DISABLE_POP3" +$write cvh "#undef CURL_DISABLE_POP3" +$write cvh "#endif" +$write cvh "#ifdef CURL_DISABLE_PROXY" +$write cvh "#undef CURL_DISABLE_PROXY" +$write cvh "#endif" +$write cvh "#ifdef CURL_DISABLE_RTSP" +$write cvh "#undef CURL_DISABLE_RTSP" +$write cvh "#endif" +$write cvh "#ifdef CURL_DISABLE_SMTP" +$write cvh "#undef CURL_DISABLE_SMTP" +$write cvh "#endif" +$write cvh "#ifdef CURL_DISABLE_TELNET" +$write cvh "#undef CURL_DISABLE_TELNET" +$write cvh "#endif" +$write cvh "#ifdef CURL_DISABLE_TFTP" +$write cvh "#undef CURL_DISABLE_TFTP" +$write cvh "#endif" +$write cvh "#ifdef CURL_DISABLE_POP3" +$write cvh "#undef CURL_DISABLE_POP3" +$write cvh "#endif" +$if .not. nossl +$then +$ write cvh "#ifdef CURL_DISABLE_TLS_SRP" +$ write cvh "#undef CURL_DISABLE_TLS_SRP" +$ write cvh "#endif" +$! +$endif +$write cvh "#ifdef CURL_DISABLE_VERBOSE_STRINGS" +$write cvh "#undef CURL_DISABLE_VERBOSE_STRINGS" +$write cvh "#endif" +$! +$! configure defaults to USE_*, a real configure on VMS chooses different. +$write cvh "#ifdef USE_ARES" +$write cvh "#undef USE_ARES" +$write cvh "#endif" +$write cvh "#ifdef USE_WOLFSSL" +$write cvh "#undef USE_WOLFSSL" +$write cvh "#endif" +$write cvh "#ifdef USE_GNUTLS" +$write cvh "#undef USE_GNUTLS" +$write cvh "#endif" +$write cvh "#ifdef USE_MANUAL" +$write cvh "#undef USE_MANUAL" +$write cvh "#endif" +$write cvh "#ifdef USE_NGHTTP2" +$write cvh "#undef USE_NGHTTP2" +$write cvh "#endif" +$write cvh "#ifdef USE_OPENLDAP" +$write cvh "#undef USE_OPENLDAP" +$write cvh "#endif" +$write cvh "#ifdef USE_RESOLV_THREADED" +$write cvh "#undef USE_RESOLV_THREADED" +$write cvh "#endif" +$write cvh "#ifdef USE_TLS_SRP" +$write cvh "#undef USE_TLS_SRP" +$write cvh "#endif" +$write cvh "#ifdef USE_UNIX_SOCKETS" +$write cvh "#undef USE_UNIX_SOCKETS" +$write cvh "#endif" +$! +$! Note: +$! The CURL_EXTERN_SYMBOL is used for platforms that need the compiler +$! to know about universal symbols. VMS does not need this support so +$! we do not set it here. +$! +$! +$! I can not figure out where the C compiler is finding the ALLOCA.H file +$! in the text libraries, so CONFIG_H.COM can not find it either. +$! Usually the header filename is the module name in the text library. +$! It does not appear to hurt anything to not find header file, so we +$! are not overriding it here. +$! +$! +$! Check to see if OpenSSL is present. +$!---------------------------------- +$ssl_include = f$trnlnm("OPENSSL") +$if ssl_include .eqs. "" +$then +$ ssl_include = f$trnlnm("ssl$include") +$endif +$if ssl_include .eqs. "" then nossl = 1 +$! +$if .not. nossl +$then +$! +$ write cvh "#ifndef USE_OPENSSL" +$ write cvh "#define USE_OPENSSL 1" +$ write cvh "#endif" +$ if arch_name .eqs. "VAX" +$ then +$ old_mes = f$environment("message") +$ set message/notext/nofaci/noseve/noident +$ search/output=nla0: ssl$include:*.h CONF_MFLAGS_IGNORE_MISSING_FILE +$ status = $severity +$ set message'old_mes' +$ if status .nes. "1" +$ then +$ write cvh "#define VMS_OLD_SSL 1" +$ endif +$ endif +$endif +$! +$! +$! libidn not ported to VMS at this time. +$! This is for international domain name support. +$! Allow explicit experimentation. +$if libidn +$then +$ write cvh "#define HAVE_IDNA_STRERROR 1" +$ write cvh "#define HAVE_IDNA_FREE 1" +$ write cvh "#define HAVE_IDNA_FREE_H 1" +$ write cvh "#define HAVE_LIBIDN 1" +$else +$ write cvh "#ifdef HAVE_LIBIDN" +$ write cvh "#undef HAVE_LIBIDN" +$ write cvh "#endif" +$endif +$! +$! +$! libssh2 not ported to VMS at this time. +$! Allow explicit experimentation. +$if libssh2 +$then +$ write cvh "#define HAVE_LIBSSH2_EXIT 1" +$ write cvh "#define HAVE_LIBSSH2_INIT 1" +$ write cvh "#define HAVE_LIBSSH2_SCP_SEND64 1" +$ write cvh "#define HAVE_LIBSSH2_SESSION_HANDSHAKE 1" +$ write cvh "#define HAVE_LIBSSH2_VERSION 1 +$! +$ write cvh "#ifndef USE_LIBSSH2" +$ write cvh "#define USE_LIBSSH2 1" +$ write cvh "#endif" +$else +$ write cvh "#ifdef USE_LIBSSH2" +$ write cvh "#undef USE_LIBSSH2" +$ write cvh "#endif" +$endif +$! +$! +$! +$if .not. nozlib +$then +$ write cvh "#define HAVE_LIBZ 1" +$endif +$! +$! +$! Suppress a message in curl_gssapi.c compile. +$write cvh "#pragma message disable notconstqual" +$! +$! Close out the file +$! +$write cvh "" +$write cvh "#endif /* __CONFIG_VMS_H__ */" +$close cvh +$! +$all_exit: +$exit diff --git a/3rdparty/curl-8.21.0/projects/vms/generate_vax_transfer.com b/3rdparty/curl-8.21.0/projects/vms/generate_vax_transfer.com new file mode 100644 index 0000000000..3ed49cb240 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/generate_vax_transfer.com @@ -0,0 +1,273 @@ +$! File: generate_vax_transfer.com +$! +$! File to generate and compile the VAX transfer vectors from reading in the +$! Alpha/Itanium gnv_libcurl_symbols.opt file. +$! +$! This procedure patches the VAX Macro32 assembler to be case sensitive +$! and then compiles the generated +$! +$! The output of this procedure is: +$! gnv_libcurl_xfer.mar_exact +$! gnv_libcurl_xfer.obj +$! gnv_libcurl_xfer.opt +$! macro32_exactcase.exe +$! +$! Copyright (C) John Malmberg +$! +$! Permission to use, copy, modify, and/or distribute this software for any +$! purpose with or without fee is hereby granted, provided that the above +$! copyright notice and this permission notice appear in all copies. +$! +$! THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +$! WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +$! MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +$! ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +$! WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +$! ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT +$! OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +$! +$! SPDX-License-Identifier: ISC +$! +$!============================================================================ +$! +$! Save this so we can get back. +$ default_dir = f$environment("default") +$! +$ on warning then goto all_exit +$! +$! Want hard tabs in the generated file. +$ tab[0,8] = 9 +$! +$! This procedure is used on VAX only +$ if (f$getsyi("HW_MODEL") .ge. 1024) +$ then +$ write sys$output "This procedure is only used on VAX." +$ goto all_exit +$ endif +$! +$! +$! Get the libcurl version to generate the ident string. +$! ident string is max of 31 characters. +$! +$ ident_string = "unknown" +$ open/read cver [-.-.include.curl]curlver.h +$cver_loop: +$ read/end=cver_loop_end cver line_in +$ line_in = f$edit(line_in, "COMPRESS,TRIM") +$ if line_in .eqs. "" then goto cver_loop +$ code = f$extract(0, 1, line_in) +$ if code .nes. "#" then goto cver_loop +$ directive = f$element(0, " ", line_in) +$ if directive .nes. "#define" then goto cver_loop +$ name = f$element(1, " ", line_in) +$ if name .nes. "LIBCURL_VERSION" then goto cver_loop +$ ident_string = f$element(2, " ", line_in) - "" - "" +$cver_loop_end: +$ close cver +$! +$ open/read aopt gnv_libcurl_symbols.opt +$! +$! Write out the header +$ gosub do_header +$! +$ open/append vopt gnv_libcurl_xfer.mar_exact +$ write vopt tab,".IDENT /", ident_string, "/" +$! +$ write vopt tab, ".PSECT LIBCURL_XFERVECTORS -" +$ write vopt tab,tab,tab, "PIC,USR,CON,REL,GBL,SHR,EXE,RD,NOWRT,QUAD" +$ write vopt "" +$ write vopt tab, "SPARE", tab, "; never delete this spare" +$ write vopt ";" +$ write vopt ";", tab, "Exact case and upper case transfer vectors" +$! +$ alias_count = 0 +$vector_loop: +$! +$! Read in symbol_vector +$! +$ read/end=vector_loop_end aopt line_in +$ line = f$edit(line_in, "UNCOMMENT,COMPRESS,TRIM") +$ if line .eqs. "" then goto vector_loop +$! +$ line_u = f$edit(line, "UPCASE") +$ key = f$element(0, "=", line_u) +$ if (key .eqs. "SYMBOL_VECTOR") +$ then +$ symbol_string = f$element(1, "=", line) - "(" +$ symbol_type = f$element(2, "=", line_u) - ")" +$ symbol_name = f$element(1, "/", symbol_string) +$ if symbol_type .nes. "PROCEDURE" +$ then +$ write sys$output "%CURLBUILD-W-NOTPROC, " + - +$ "This procedure can only handle procedure vectors" +$ write sys$output - +"Data vectors require manual construction for which this procedure or" +$ write sys$output - +"the shared library needs to be updated to resolve." +$ write sys$output - +"the preferred solution is to have a procedure return the address of the " +$ write sys$output - +"the variable instead of having a variable, as if the size of the variable " + write sys$output - +"changes, the symbol vector is no longer backwards compatible." +$ endif +$ if (symbol_name .eqs. "/") +$ then +$ symbol_name = symbol_string +$ write vopt tab, symbol_type, tab, symbol_name +$ else +$ alias_count = alias_count + 1 +$ symbol_alias = f$element(0, "/", symbol_string) +$ write vopt - + tab, "''symbol_type_U", tab, symbol_name, tab, symbol_alias +$ endif +$ endif +$ goto vector_loop +$vector_loop_end: +$! +$! End of pass one, second pass needed if aliases exist +$ close aopt +$! +$ if alias_count .eq. 0 then goto finish_file +$! +$! Start pass 2, write stub routine header +$! +$ open/read aopt gnv_libcurl_symbols.opt +$! +$alias_loop: +$! +$! Read in symbol_vector +$! +$ read/end=alias_loop_end aopt line_in +$ line = f$edit(line_in, "UNCOMMENT,COMPRESS,TRIM") +$ if line .eqs. "" then goto alias_loop +$! +$ line_u = f$edit(line, "UPCASE") +$ key = f$element(0, "=", line_u) +$ if (key .eqs. "SYMBOL_VECTOR") +$ then +$ symbol_string = f$element(1, "=", line) - "(" +$ symbol_type = f$element(2, "=", line_u) - ")" +$ symbol_name = f$element(1, "/", symbol_string) +$ if (symbol_name .eqs. "/") +$ then +$ symbol_name = symbol_string +$ else +$ alias_count = alias_count + 1 +$ symbol_alias = f$element(0, "/", symbol_string) +$ write vopt tab, ".ENTRY", tab, symbol_alias, ", ^M<>" +$ endif +$ endif +$ goto alias_loop +$! read in symbol_vector +$! if not alias, then loop +$! write out subroutine name +$! +$alias_loop_end: +$! +$ write vopt tab, "MOVL #1, R0" +$ write vopt tab, "RET" +$! +$finish_file: +$! +$ write vopt "" +$ write vopt tab, ".END" +$! +$ close aopt +$ close vopt +$! +$! Patch the Macro32 compiler +$!---------------------------- +$ patched_macro = "sys$disk:[]macro32_exactcase.exe" +$ if f$search(patched_macro) .eqs. "" +$ then +$ copy sys$system:macro32.exe 'patched_macro' +$ patch @macro32_exactcase.patch +$ endif +$ define/user macro32 'patched_macro' +$ macro/object=gnv_libcurl_xfer.obj gnv_libcurl_xfer.mar_exact +$! +$! Create the option file for linking the shared image. +$ create gnv_libcurl_xfer.opt +$ open/append lco gnv_libcurl_xfer.opt +$ write lco "gsmatch=lequal,1,1" +$ write lco "cluster=transfer_vector,,,''default_dir'gnv_libcurl_xfer" +$ write lco "collect=libcurl_global, libcurl_xfervectors" +$ close lco +$! +$! +$ goto all_exit +$! +$! Process the header +$do_header: +$! +$! Force the mode of the file to same as text editor generated. +$ create gnv_libcurl_xfer.mar_exact +$deck +; File: gnv_libcurl_xfer.mar_exact +; +; VAX transfer vectors +; +; This needs to be compiled with a specialized patch on Macro32 to make it +; preserve the case of symbols instead of converting it to uppercase. +; +; This patched Macro32 requires all directives to be in upper case. +; +; There are three sets of symbols for transfer vectors here. +; +; The first for upper case which matches the tradition method of generating +; VAX transfer vectors. +; +; The second is the exact case for compatibility with open source C programs +; that expect exact case symbols in images. These are separated because a +; previous kit had only upper case symbols. +; +; The third is the routine stub that is used to resolve part of the upper +; case transfer vectors, with exact case entry symbols. +; +; When you add routines, you need to add them after the second set of transfer +; vectors for both upper and exact case, and then additional entry points +; in upper case added to stub routines. +; +;************************************************************************* + + .TITLE libcurl_xfer - Transfer vector for libcurl + .DISABLE GLOBAL + +; +; Macro to generate a transfer vector entry +; + .MACRO PROCEDURE NAME + .EXTRN 'NAME + .ALIGN QUAD + .TRANSFER 'NAME + .MASK 'NAME + JMP 'NAME+2 + .ENDM + + .MACRO PROCEDUREU NAME NAMEU + .EXTRN 'NAME + .ALIGN QUAD + .TRANSFER 'NAMEU + .MASK 'NAME + JMP 'NAME+2 + + .ENDM +; +; +; Macro to reserve a spare entry. +; + .MACRO SPARE + .ALIGN QUAD + .ALIGN QUAD + .QUAD 0 + .ENDM + +$EOD +$! +$! +$ return +$! +$all_exit: +$set def 'default_dir' +$exit '$status' diff --git a/3rdparty/curl-8.21.0/projects/vms/gnv_conftest.c_first b/3rdparty/curl-8.21.0/projects/vms/gnv_conftest.c_first new file mode 100644 index 0000000000..a40f763a19 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/gnv_conftest.c_first @@ -0,0 +1,58 @@ +/* File: GNV$CONFTEST.C_FIRST + * + * Copyright (C) John Malmberg + * + * Permission to use, copy, modify, and/or distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT + * OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + * + * SPDX-License-Identifier: ISC + * + */ + +/* This is needed for Configure tests to get the correct exit status */ +void __posix_exit(int __status); +#define exit(__p1) __posix_exit(__p1) + +/* Fake pass the test to find a standard ldap routine that we know is */ +/* present on VMS, but with the wrong case for the symbol */ +char ldap_url_parse(void) {return 0;} + +/* These are to pass the test that does not use headers */ +/* Because configure does an #undef which keeps us from using #define */ +/* char CRYPTO_add_lock(void) {return 0;} */ +char SSL_connect(void) {return 0;} +char ENGINE_init(void) {return 0;} +char RAND_status(void) {return 0;} +/* char RAND_screen(void) {return 0;} In headers, but not present */ +char CRYPTO_cleanup_all_ex_data(void) {return 0;} +char SSL_get_shutdown(void) {return 0;} +char ENGINE_load_builtin_engines(void) {return 0;} + +/* And these are to pass the test that uses headers. */ +/* Because the HP OpenSSL transfer vectors are currently in Upper case only */ +#pragma message disable macroredef +#define CRYPTO_add_lock CRYPTO_ADD_LOCK +#define SSL_connect SSL_CONNECT +#define ENGINE_init ENGINE_INIT +#define RAND_status RAND_STATUS +/* #define RAND_screen RAND_SCREEN */ +#define CRYPTO_cleanup_all_ex_data CRYPTO_CLEANUP_ALL_EX_DATA +#define SSL_get_shutdown SSL_GET_SHUTDOWN +#define ENGINE_load_builtin_engines ENGINE_LOAD_BUILTIN_ENGINES + +/* Can not use the #define macro to fix the case on CRYPTO_lock because */ +/* there is a macro CRYPTO_LOCK that is a number */ + +/* After all the work to get configure to pass the CRYPTO_LOCK tests, + * it turns out that VMS does not have the CRYPTO_LOCK symbol in the + * transfer vector, even though it is in the header file. + */ diff --git a/3rdparty/curl-8.21.0/projects/vms/gnv_curl_configure.sh b/3rdparty/curl-8.21.0/projects/vms/gnv_curl_configure.sh new file mode 100755 index 0000000000..5f2038f87c --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/gnv_curl_configure.sh @@ -0,0 +1,44 @@ +# File: gnv_curl_configure.sh +# +# Set up and run the configure script for curl so that it can find the +# proper options for VMS. +# +# Copyright (C) John Malmberg +# +# Permission to use, copy, modify, and/or distribute this software for any +# purpose with or without fee is hereby granted, provided that the above +# copyright notice and this permission notice appear in all copies. +# +# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT +# OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +# +# SPDX-License-Identifier: ISC +# +#========================================================================== +# +# POSIX exit mode is needed for Unix shells. +export GNV_CC_MAIN_POSIX_EXIT=1 +# +# Where to look for the helper files. +export GNV_OPT_DIR=. +# +# How to find the SSL library files. +export LIB_OPENSSL=/SSL_LIB +# +# Override configure adding -std1 which is too strict for what curl +# actually wants. +export GNV_CC_QUALIFIERS=/STANDARD=RELAXED +# +# Set the directory to where the Configure script actually is. +cd ../.. +# +# +./configure --prefix=/usr --exec-prefix=/usr --disable-dependency-tracking \ + --disable-libtool-lock --with-gssapi --disable-ntlm-wb \ + --with-ca-path=gnv\$curl_ca_path +# diff --git a/3rdparty/curl-8.21.0/projects/vms/gnv_libcurl_symbols.opt b/3rdparty/curl-8.21.0/projects/vms/gnv_libcurl_symbols.opt new file mode 100644 index 0000000000..5bc2a852b9 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/gnv_libcurl_symbols.opt @@ -0,0 +1,181 @@ +! File GNV$LIBCURL_SYMBOLS.OPT +! +! This file must be manually maintained to allow upward compatibility +! The SYMBOL_VECTORs are set up so that applications can be compiled +! with either case sensitive symbol names or the default of uppercase. +! This is because many of the Open Source applications that would call +! the LIBCURL library need to be built with case sensitive names. +! +! Automatic generation is currently not practical because the order of +! the entries are important for upward compatibility. +! +! The GSMATCH is manually set to the major version of 1, with the minor +! version being the next two sections multiplied by a power of 10 to +! become the minor version. +! So LIBCURL 7.18.1 becomes 1,718010. +! And a future LIBCURL of 7.18.2 would be 1,718020 if new routines were added. +! +! This leaves some spare digits for minor patches. +! +! Note that the GSMATCH does not need to have any real relationship to the +! actual package version number. +! +! New SYMBOL_VECTORs must be added to the end of this list, and added +! in pairs for both exact and with an uppercase alias. +! If the public symbol is more than 31 characters long, then a special +! shortened symbol will be exported, and three aliases should be created, +! The aliases will be the special shortened uppercase alias, and both +! upper and lowercase versions of a truncated name (preferred) or a +! modified manually shortened name if a truncated name will not be +! unique. +! +! Routines can not be removed, the functionality must be maintained. +! If a new routine is supplied where the arguments are incompatible with +! the older version, both versions are needed to be maintained. +! The old version can be given a different name, but must be in the same +! SYMBOL_VECTOR positions in this file. +! +! Changing the number of parameters for an existing routine does not require +! maintaining multiple versions as long as the routine can be called with +! the old number of parameters. +! +! Copyright (C) John Malmberg +! +! Permission to use, copy, modify, and/or distribute this software for any +! purpose with or without fee is hereby granted, provided that the above +! copyright notice and this permission notice appear in all copies. +! +! THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +! WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +! ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +! WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +! ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT +! OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +! +! SPDX-License-Identifier: ISC +!============================================================================ +GSMATCH=LEQUAL,1,719050 +CASE_SENSITIVE=YES +SYMBOL_VECTOR=(curl_strequal=PROCEDURE) +SYMBOL_VECTOR=(CURL_STREQUAL/curl_strequal=PROCEDURE) +SYMBOL_VECTOR=(curl_strnequal=PROCEDURE) +SYMBOL_VECTOR=(CURL_STRNEQUAL/curl_strnequal=PROCEDURE) +SYMBOL_VECTOR=(curl_formadd=PROCEDURE) +SYMBOL_VECTOR=(CURL_FORMADD/curl_formadd=PROCEDURE) +SYMBOL_VECTOR=(curl_formget=PROCEDURE) +SYMBOL_VECTOR=(CURL_FORMGET/curl_formget=PROCEDURE) +SYMBOL_VECTOR=(curl_formfree=PROCEDURE) +SYMBOL_VECTOR=(CURL_FORMFREE/curl_formfree=PROCEDURE) +SYMBOL_VECTOR=(curl_getenv=PROCEDURE) +SYMBOL_VECTOR=(CURL_GETENV/curl_getenv=PROCEDURE) +SYMBOL_VECTOR=(curl_version=PROCEDURE) +SYMBOL_VECTOR=(CURL_VERSION/curl_version=PROCEDURE) +SYMBOL_VECTOR=(curl_easy_escape=PROCEDURE) +SYMBOL_VECTOR=(CURL_EASY_ESCAPE/curl_easy_escape=PROCEDURE) +SYMBOL_VECTOR=(curl_escape=PROCEDURE) +SYMBOL_VECTOR=(CURL_ESCAPE/curl_escape=PROCEDURE) +SYMBOL_VECTOR=(curl_easy_unescape=PROCEDURE) +SYMBOL_VECTOR=(CURL_EASY_UNESCAPE/curl_easy_unescape=PROCEDURE) +SYMBOL_VECTOR=(curl_unescape=PROCEDURE) +SYMBOL_VECTOR=(CURL_UNESCAPE/curl_unescape=PROCEDURE) +SYMBOL_VECTOR=(curl_free=PROCEDURE) +SYMBOL_VECTOR=(CURL_FREE/curl_free=PROCEDURE) +SYMBOL_VECTOR=(curl_global_init=PROCEDURE) +SYMBOL_VECTOR=(CURL_GLOBAL_INIT/curl_global_init=PROCEDURE) +SYMBOL_VECTOR=(curl_global_init_mem=PROCEDURE) +SYMBOL_VECTOR=(CURL_GLOBAL_INIT_MEM/curl_global_init_mem=PROCEDURE) +SYMBOL_VECTOR=(curl_global_cleanup=PROCEDURE) +SYMBOL_VECTOR=(CURL_GLOBAL_CLEANUP/curl_global_cleanup=PROCEDURE) +SYMBOL_VECTOR=(curl_slist_append=PROCEDURE) +SYMBOL_VECTOR=(CURL_SLIST_APPEND/curl_slist_append=PROCEDURE) +SYMBOL_VECTOR=(curl_slist_free_all=PROCEDURE) +SYMBOL_VECTOR=(CURL_SLIST_FREE_ALL/curl_slist_free_all=PROCEDURE) +SYMBOL_VECTOR=(curl_getdate=PROCEDURE) +SYMBOL_VECTOR=(CURL_GETDATE/curl_getdate=PROCEDURE) +SYMBOL_VECTOR=(curl_share_init=PROCEDURE) +SYMBOL_VECTOR=(CURL_SHARE_INIT/curl_share_init=PROCEDURE) +SYMBOL_VECTOR=(curl_share_setopt=PROCEDURE) +SYMBOL_VECTOR=(CURL_SHARE_SETOPT/curl_share_setopt=PROCEDURE) +SYMBOL_VECTOR=(curl_share_cleanup=PROCEDURE) +SYMBOL_VECTOR=(CURL_SHARE_CLEANUP/curl_share_cleanup=PROCEDURE) +SYMBOL_VECTOR=(curl_version_info=PROCEDURE) +SYMBOL_VECTOR=(CURL_VERSION_INFO/curl_version_info=PROCEDURE) +SYMBOL_VECTOR=(curl_easy_strerror=PROCEDURE) +SYMBOL_VECTOR=(CURL_EASY_STRERROR/curl_easy_strerror=PROCEDURE) +SYMBOL_VECTOR=(curl_share_strerror=PROCEDURE) +SYMBOL_VECTOR=(CURL_SHARE_STRERROR/curl_share_strerror=PROCEDURE) +SYMBOL_VECTOR=(curl_easy_pause=PROCEDURE) +SYMBOL_VECTOR=(CURL_EASY_PAUSE/curl_easy_pause=PROCEDURE) +! +! easy.h +SYMBOL_VECTOR=(curl_easy_init=PROCEDURE) +SYMBOL_VECTOR=(CURL_EASY_INIT/curl_easy_init=PROCEDURE) +SYMBOL_VECTOR=(curl_easy_setopt=PROCEDURE) +SYMBOL_VECTOR=(CURL_EASY_SETOPT/curl_easy_setopt=PROCEDURE) +SYMBOL_VECTOR=(curl_easy_perform=PROCEDURE) +SYMBOL_VECTOR=(CURL_EASY_PERFORM/curl_easy_perform=PROCEDURE) +SYMBOL_VECTOR=(curl_easy_cleanup=PROCEDURE) +SYMBOL_VECTOR=(CURL_EASY_CLEANUP/curl_easy_cleanup=PROCEDURE) +SYMBOL_VECTOR=(curl_easy_getinfo=PROCEDURE) +SYMBOL_VECTOR=(CURL_EASY_GETINFO/curl_easy_getinfo=PROCEDURE) +SYMBOL_VECTOR=(curl_easy_duphandle=PROCEDURE) +SYMBOL_VECTOR=(CURL_EASY_DUPHANDLE/curl_easy_duphandle=PROCEDURE) +SYMBOL_VECTOR=(curl_easy_reset=PROCEDURE) +SYMBOL_VECTOR=(CURL_EASY_RESET/curl_easy_reset=PROCEDURE) +SYMBOL_VECTOR=(curl_easy_recv=PROCEDURE) +SYMBOL_VECTOR=(CURL_EASY_RECV/curl_easy_recv=PROCEDURE) +SYMBOL_VECTOR=(curl_easy_send=PROCEDURE) +SYMBOL_VECTOR=(CURL_EASY_SEND/curl_easy_send=PROCEDURE) +! +! multi.h +SYMBOL_VECTOR=(curl_multi_init=PROCEDURE) +SYMBOL_VECTOR=(CURL_MULTI_INIT/curl_multi_init=PROCEDURE) +SYMBOL_VECTOR=(curl_multi_add_handle=PROCEDURE) +SYMBOL_VECTOR=(CURL_MULTI_ADD_HANDLE/curl_multi_add_handle=PROCEDURE) +SYMBOL_VECTOR=(curl_multi_remove_handle=PROCEDURE) +SYMBOL_VECTOR=(CURL_MULTI_REMOVE_HANDLE/curl_multi_remove_handle=PROCEDURE) +SYMBOL_VECTOR=(curl_multi_fdset=PROCEDURE) +SYMBOL_VECTOR=(CURL_MULTI_FDSET/curl_multi_fdset=PROCEDURE) +SYMBOL_VECTOR=(curl_multi_perform=PROCEDURE) +SYMBOL_VECTOR=(CURL_MULTI_PERFORM/curl_multi_perform=PROCEDURE) +SYMBOL_VECTOR=(curl_multi_cleanup=PROCEDURE) +SYMBOL_VECTOR=(CURL_MULTI_CLEANUP/curl_multi_cleanup=PROCEDURE) +SYMBOL_VECTOR=(curl_multi_info_read=PROCEDURE) +SYMBOL_VECTOR=(CURL_MULTI_INFO_READ/curl_multi_info_read=PROCEDURE) +SYMBOL_VECTOR=(curl_multi_strerror=PROCEDURE) +SYMBOL_VECTOR=(CURL_MULTI_STRERROR/curl_multi_strerror=PROCEDURE) +SYMBOL_VECTOR=(curl_multi_socket=PROCEDURE) +SYMBOL_VECTOR=(CURL_MULTI_SOCKET/curl_multi_socket=PROCEDURE) +SYMBOL_VECTOR=(curl_multi_socket_action=PROCEDURE) +SYMBOL_VECTOR=(CURL_MULTI_SOCKET_ACTION/curl_multi_socket_action=PROCEDURE) +SYMBOL_VECTOR=(curl_multi_socket_all=PROCEDURE) +SYMBOL_VECTOR=(CURL_MULTI_SOCKET_ALL/curl_multi_socket_all=PROCEDURE) +SYMBOL_VECTOR=(curl_multi_timeout=PROCEDURE) +SYMBOL_VECTOR=(CURL_MULTI_TIMEOUT/curl_multi_timeout=PROCEDURE) +SYMBOL_VECTOR=(curl_multi_setopt=PROCEDURE) +SYMBOL_VECTOR=(CURL_MULTI_SETOPT/curl_multi_setopt=PROCEDURE) +SYMBOL_VECTOR=(curl_multi_assign=PROCEDURE) +SYMBOL_VECTOR=(CURL_MULTI_ASSIGN/curl_multi_assign=PROCEDURE) +! +! mprintf.h +SYMBOL_VECTOR=(curl_mprintf=PROCEDURE) +SYMBOL_VECTOR=(CURL_MPRINTF/curl_mprintf=PROCEDURE) +SYMBOL_VECTOR=(curl_mfprintf=PROCEDURE) +SYMBOL_VECTOR=(CURL_MFPRINTF/curl_mfprintf=PROCEDURE) +SYMBOL_VECTOR=(curl_msprintf=PROCEDURE) +SYMBOL_VECTOR=(CURL_MSPRINTF/curl_msprintf=PROCEDURE) +SYMBOL_VECTOR=(curl_msnprintf=PROCEDURE) +SYMBOL_VECTOR=(CURL_MSNPRINTF/curl_msnprintf=PROCEDURE) +SYMBOL_VECTOR=(curl_mvprintf=PROCEDURE) +SYMBOL_VECTOR=(CURL_MVPRINTF/curl_mvprintf=PROCEDURE) +SYMBOL_VECTOR=(curl_mvfprintf=PROCEDURE) +SYMBOL_VECTOR=(CURL_MVFPRINTF/curl_mvfprintf=PROCEDURE) +SYMBOL_VECTOR=(curl_mvsprintf=PROCEDURE) +SYMBOL_VECTOR=(CURL_MVSPRINTF/curl_mvsprintf=PROCEDURE) +SYMBOL_VECTOR=(curl_mvsnprintf=PROCEDURE) +SYMBOL_VECTOR=(CURL_MVSNPRINTF/curl_mvsnprintf=PROCEDURE) +SYMBOL_VECTOR=(curl_maprintf=PROCEDURE) +SYMBOL_VECTOR=(CURL_MAPRINTF/curl_maprintf=PROCEDURE) +SYMBOL_VECTOR=(curl_mvaprintf=PROCEDURE) +SYMBOL_VECTOR=(CURL_MVAPRINTF/curl_mvaprintf=PROCEDURE) diff --git a/3rdparty/curl-8.21.0/projects/vms/gnv_link_curl.com b/3rdparty/curl-8.21.0/projects/vms/gnv_link_curl.com new file mode 100644 index 0000000000..330613b76d --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/gnv_link_curl.com @@ -0,0 +1,851 @@ +$! File: gnv_link_curl.com +$! +$! File to build images using gnv$libcurl.exe +$! +$! Copyright (C) John Malmberg +$! +$! Permission to use, copy, modify, and/or distribute this software for any +$! purpose with or without fee is hereby granted, provided that the above +$! copyright notice and this permission notice appear in all copies. +$! +$! THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +$! WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +$! MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +$! ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +$! WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +$! ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT +$! OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +$! +$! SPDX-License-Identifier: ISC +$! +$!============================================================================ +$! +$! Save this so we can get back. +$ default_dir = f$environment("default") +$ define/job gnv_packages_vms 'default_dir' +$! +$ on warning then goto all_exit +$! +$! On VAX, we need to generate a Macro transfer vector. +$ parse_style = "TRADITIONAL" +$ if (f$getsyi("HW_MODEL") .lt. 1024) +$ then +$ @generate_vax_transfer.com +$ arch_name = "VAX" +$ else +$ arch_name = "" +$ arch_name = arch_name + f$edit(f$getsyi("ARCH_NAME"), "UPCASE") +$ if (arch_name .eqs. "") then arch_name = "UNK" +$! +$! Extended parsing option starts with VMS 7.3-1. +$! There is no 7.4, so that simplifies the parse a bit. +$! +$ node_swvers = f$getsyi("node_swvers") +$ version_patch = f$extract(1, f$length(node_swvers), node_swvers) +$ maj_ver = f$element(0, ".", version_patch) +$ min_ver_patch = f$element(1, ".", version_patch) +$ min_ver = f$element(0, "-", min_ver_patch) +$ patch = f$element(1, "-", min_ver_patch) +$ if patch .eqs. "-" then patch = "" +$ parse_x = 0 +$ if maj_ver .ges. "8" +$ then +$ parse_x = 1 +$ else +$ if maj_ver .eqs. "7" .and. min_ver .ges. "3" .and. patch .nes. "" +$ then +$ parse_x = 1 +$ endif +$ endif +$ if parse_x +$ then +$ parse_style = f$getjpi("", "parse_style_perm") +$ endif +$ endif +$! +$! +$! Move to where the base directories. +$ set def [--] +$! +$! +$! Build the Message file. +$!-------------------------- +$ if f$search("[.projects.vms]curlmsg.obj") .eqs. "" +$ then +$ message [.projects.vms]curlmsg.msg/object=[.projects.vms] +$ endif +$ if f$search("gnv$curlmsg.exe") .eqs. "" +$ then +$ link/share=gnv$curlmsg.exe [.projects.vms]curlmsg.obj +$ endif +$! +$! +$! Need to build the common init module. +$!------------------------------------------- +$ cflags = "/list/show=(expan,includ)" +$ init_obj = "[.projects.vms]curl_crtl_init.obj" +$ if f$search(init_obj) .eqs. "" +$ then +$ cc'cflags' 'default_dir'curl_crtl_init.c/obj='init_obj' +$ endif +$ purge 'init_obj' +$ rename 'init_obj' ;1 +$! +$! +$! Need to build the module to test the HP OpenSSL version +$!-------------------------------------------------------- +$ if arch_name .nes. "VAX" +$ then +$ rpt_obj = "[.projects.vms]report_openssl_version.obj +$ if f$search(rpt_obj) .eqs. "" +$ then +$ cc'cflags' 'default_dir'report_openssl_version.c/obj='rpt_obj' +$ endif +$ purge 'rpt_obj' +$ rename 'rpt_obj' ;1 +$! +$ link/exe='default_dir'report_openssl_version.exe 'rpt_obj' +$ report_openssl_version := $'default_dir'report_openssl_version.exe +$ endif +$! +$! +$ base_link_opt_file = "[.projects.vms.''arch_name']gnv_libcurl_linker.opt" +$ share_link_opt_file = "[.projects.vms.''arch_name']gnv_ssl_libcurl_linker.opt" +$ if f$search(base_link_opt_file) .eqs. "" +$ then +$ base_link_opt_file = "[.projects.vms]gnv_libcurl_linker.opt" +$ share_link_opt_file = "[.projects.vms]gnv_ssl_libcurl_linker.opt" +$ if f$search(base_link_opt_file) .eqs. "" +$ then +$ write sys$output "Can not find base library option file!" +$ goto all_exit +$ endif +$ endif +$! +$! Create the a new option file with special fixup for HP SSL +$! For a shared image, we always want ZLIB and 32-bit HPSSL +$! +$ if f$search("gnv$libzshr32") .eqs. "" +$ then +$ write sys$output "VMSPORTS/GNV LIBZ Shared image not found!" +$ goto all_exit +$ endif +$! +$! +$! Need to check the version of the HP SSL shared image. +$! +$! VAX platform can not be checked this way, it appears symbol lookup +$! was disabled. VAX has not been updated in a while. +$ if arch_name .eqs. "VAX" +$ then +$ hp_ssl_libcrypto32 = "sys$common:[syslib]ssl$libcrypto_shr32.exe" +$ hp_ssl_libssl32 = "sys$common:[syslib]ssl$libssl_shr32.exe" +$ if f$search(hp_ssl_libcrypto32) .nes. "" +$ then +$ use_hp_ssl = 1 +$ curl_ssl_libcrypto32 = hp_ssl_libcrypto32 +$ curl_ssl_libssl32 = hp_ssl_libssl32 +$ curl_ssl_version = "OpenSSL/0.9.6g" +$ else +$ write sys$output "HP OpenSSL Shared images not found!" +$ goto all_exit +$ endif +$ else +$! +$! Minimum HP version we can use reports: +$! "OpenSSL 0.9.8w 23 Apr 2012" +$! +$ use_hp_ssl = 0 +$ hp_ssl_libcrypto32 = "sys$share:ssl$libcrypto_shr32.exe" +$ hp_ssl_libssl32 = "sys$share:ssl$libssl_shr32.exe" +$ if f$search(hp_ssl_libcrypto32) .nes. "" +$ then +$ curl_ssl_libcrypto32 = hp_ssl_libcrypto32 +$ curl_ssl_libssl32 = hp_ssl_libssl32 +$ report_openssl_version 'hp_ssl_libcrypto32' hp_ssl_version +$ endif +$! +$ if f$type(hp_ssl_version) .eqs. "STRING" +$ then +$ curl_ssl_version = hp_ssl_version +$ full_version = f$element(1, " ", hp_ssl_version) +$ ver_maj = f$element(0, ".", full_version) +$ ver_min = f$element(1, ".", full_version) +$ ver_patch = f$element(2, ".", full_version) +$! ! ver_patch is typically both a number and some letters +$ ver_patch_len = f$length(ver_patch) +$ ver_patchltr = "" +$ver_patch_loop: +$ ver_patchltr_c = f$extract(ver_patch_len - 1, 1, ver_patch) +$ if ver_patchltr_c .les. "9" then goto ver_patch_loop_end +$ ver_patchltr = ver_patchltr_c + ver_patchltr +$ ver_patch_len = ver_patch_len - 1 +$ goto ver_patch_loop +$ver_patch_loop_end: +$ ver_patchnum = ver_patch - ver_patchltr +$ if 'ver_maj' .ge. 0 +$ then +$ if 'ver_min' .ge. 9 +$ then +$ if 'ver_patchnum' .ge. 8 +$ then +$ if ver_patchltr .ges. "w" then use_hp_ssl = 1 +$ endif +$ endif +$ endif +$set nover +$ if use_hp_ssl .eq. 0 +$ then +$ write sys$output - + " HP OpenSSL version of ""''hp_ssl_version'"" is too old for shared libcurl!" +$ endif +$ else +$ write sys$output "Unable to get version of HP OpenSSL" +$ endif +$! +$ gnv_ssl_libcrypto32 = "gnv$gnu:[lib]ssl$libcrypto_shr32.exe" +$ gnv_ssl_libssl32 = "gnv$gnu:[lib]ssl$libssl_shr32.exe" +$ if f$search(gnv_ssl_libcrypto32) .nes. "" +$ then +$ report_openssl_version 'gnv_ssl_libcrypto32' gnv_ssl_version +$ endif +$! +$ use_gnv_ssl = 0 +$ if f$type(gnv_ssl_version) .eqs. "STRING" +$ then +$ gnv_full_version = f$element(1, " ", gnv_ssl_version) +$ gnv_ver_maj = f$element(0, ".", gnv_full_version) +$ gnv_ver_min = f$element(1, ".", gnv_full_version) +$ gnv_ver_patch = f$element(2, ".", gnv_full_version) +$ gnv_ver_patch_len = f$length(gnv_ver_patch) +$ gnv_ver_patchnum = f$extract(0, gnv_ver_patch_len - 1, gnv_ver_patch) +$ gnv_ver_patchltr = f$extract(gnv_ver_patch_len - 1, 1, gnv_ver_patch) +$ if 'gnv_ver_maj' .ge. 0 +$ then +$ if 'gnv_ver_min' .ge. 9 +$ then +$ if 'gnv_ver_patchnum' .ge. 8 +$ then +$ if gnv_ver_patchltr .ges. "w" then use_gnv_ssl = 1 +$ endif +$ endif +$ endif +$ if use_gnv_ssl .eq. 0 +$ then +$ write sys$output - + "GNV OpenSSL version of ""''gnv_ssl_version'" is too old for shared libcurl!" +$ endif +$! +$! Prefer to break the tie with the lowest supported version +$! For simplicity, if the GNV image is present, it will be used. +$! Version tuple is not a simple compare. +$! +$ if use_gnv_ssl .eq. 1 then +$ curl_ssl_libcrypto32 = gnv_ssl_libcrypto32 +$ curl_ssl_libssl32 = gnv_ssl_libssl32 +$ curl_ssl_version = gnv_ssl_version +$ use_hp_ssl = 0 +$ endif +!$! +$ else +$ write sys$output "Unable to get version of GNV OpenSSL" +$ endif +$! +$! Need to write a release note section about HP OpenSSL +$! +$create 'default_dir'hp_ssl_release_info.txt +$deck +This package is built on with the OpenSSL version listed below and requires +the shared images from the HP OpenSSL product that is kitted with that +version or a compatible later version. + +For Alpha and IA64 platforms, see the URL below to register to get the +download URL. The kit will be HP 1.4-467 or later. + https://h41379.www4.hpe.com/openvms/products/ssl/ssl.html + +For VAX, use the same registration, but remove the kit name from any of the +download URLs provided and put in CPQ-VAXVMS-SSL-V0101-B-1.PCSI-DCX_VAXEXE + +If your system can not be upgraded to a compatible version of OpenSSL, then +you can extract the two shared images from the kit and place them in the +[vms$common.gnv.lib]directory of the volume that you are installing GNV and +or GNV compatible components like curl. + +If GNV is installed, you must run the GNV startup procedure before these steps +and before installing curl. + + + 1. make sure that [vms$common.gnv.lib] exists by using the following + commands. We want the directory to be in lowercase except on VAX. + + $SET PROCESS/PARSE=extend !If not VAX. + $CREATE/DIR device:[vms$common.gnv.lib]/prot=w:re + + 2. Extract the ssl$crypto_shr32.exe and ssl$libssl_shr32.exe images. + + $PRODUCT EXTRACT FILE - + /select=(ssl$libcrypto_shr32.exe,ssl$libssl_shr32.exe)- + /source=device:[dir] - + /options=noconfirm - + /destination=device:[vms$common.gnv.lib] SSL + +The [vms$common.sys$startup}curl_startup.com procedure will then configure +libcurl to use these shared images instead of the system ones. + +When you upgrade SSL on VMS to the newer version of HP SSL, then these copies +should be deleted. + +$eod +$! +$ open/append sslr 'default_dir'hp_ssl_release_info.txt +$ write sslr "OpenSSL version used for building this kit: ",curl_ssl_version +$ write sslr "" +$ close sslr +$! +$! +$! LIBZ +$ libzshr_line = "" +$ try_shr = "gnv$libzshr32" +$ if f$search(try_shr) .nes. "" +$ then +$ libzshr_line = "''try_shr'/share" +$ else +$ write sys$output "''try_shr' image not found!" +$ goto all_exit +$ endif +$! +$! +$ gssrtlshr_line = "" +$ if arch_name .nes. "VAX" +$ then +$ try_shr = "sys$share:gss$rtl" +$ if f$search("''try_shr'.exe") .nes. "" +$ then +$ gssrtlshr_line = "''try_shr'/share" +$ else +$ write sys$output "''try_shr' image not found!" +$ goto all_exit +$ endif +$ endif +$! +$! +$! +$ if f$search(share_link_opt_file) .eqs. "" +$ then +$ create 'share_link_opt_file' +$ open/append slopt 'share_link_opt_file' +$ if libzshr_line .nes. "" then write slopt libzshr_line +$ if gssrtlshr_line .nes. "" then write slopt gssrtlshr_line +$ write slopt "gnv$curl_ssl_libcryptoshr32/share" +$ write slopt "gnv$curl_ssl_libsslshr32/share" +$ close slopt +$ endif +$! +$! DCL build puts curllib in architecture directory +$! GNV build uses the makefile. +$ libfile = "[.projects.vms.''arch_name']curllib.olb" +$ if f$search(libfile) .nes. "" +$ then +$ olb_file = libfile +$ else +$ ! GNV based build +$ libfile = "[.lib.^.libs]libcurl.a" +$ if f$search(libfile) .nes. "" +$ then +$ olb_file = libfile +$ else +$ write sys$output - + "Can not build shared image, libcurl object library not found!" +$ goto all_exit +$ endif +$ endif +$! +$gnv_libcurl_share = "''default_dir'gnv$libcurl.exe" +$! +$ if f$search(gnv_libcurl_share) .eqs. "" +$ then +$ if arch_name .nes. "VAX" +$ then +$ define/user gnv$curl_ssl_libcryptoshr32 'curl_ssl_libcrypto32' +$ define/user gnv$curl_ssl_libsslshr32 'curl_ssl_libssl32' +$ link/dsf='default_dir'gnv$libcurl.dsf/share='gnv_libcurl_share' - + /map='default_dir'gnv$libcurl.map - + gnv_packages_vms:gnv_libcurl_symbols.opt/opt,- + 'olb_file'/lib,- + 'share_link_opt_file'/opt +$ else +$! VAX will not allow the logical name hack for the +$! SSL libcryto library, it is pulling it in twice if I try it. +$ link/share='gnv_libcurl_share'/map='default_dir'gnv$libcurl.map - + gnv_packages_vms:gnv_libcurl_xfer.opt/opt,- + 'olb_file'/lib,- + 'base_link_opt_file'/opt +$ endif +$ endif +$! +$! +$ if f$search("[.src]curl-tool_main.o") .nes. "" +$ then +$! From src/makefile.inc: +$! # libcurl has sources that provide functions named curlx_* that are not +$! # part of the official API, but we reuse the code here to avoid +$! # duplication. +$! +$! +$ if f$search("[.src]curl.exe") .eqs. "" +$ then +$ define/user gnv$libcurl 'gnv_libcurl_share' +$ link'ldebug'/exe=[.src]curl.exe/dsf=[.src]curl.dsf - + [.src]curl-tool_main.o, - + [.src]curl-tool_bname.o, [.src]curl-tool_cb_dbg.o, - + [.src]curl-tool_cb_hdr.o, [.src]curl-tool_cb_prg.o, - + [.src]curl-tool_cb_rea.o, [.src]curl-tool_cb_see.o, - + [.src]curl-tool_cb_soc.o, - + [.src]curl-tool_cb_wrt.o, [.src]curl-tool_cfgable.o, - + [.src]curl-tool_convert.o, [.src]curl-tool_dirhie.o, - + [.src]curl-tool_doswin.o, [.src]curl-tool_easysrc.o, - + [.src]curl-tool_formparse.o, [.src]curl-tool_getparam.o, - + [.src]curl-tool_getpass.o, [.src]curl-tool_help.o, - + [.src]curl-tool_helpers.o, [.src]curl-tool_homedir.o, - + [.src]curl-tool_hugehelp.o, [.src]curl-tool_libinfo.o, - + [.src]curl-tool_mfiles.o, - + [.src]curl-tool_msgs.o, [.src]curl-tool_operate.o, - + [.src]curl-tool_operhlp.o, - + [.src]curl-tool_paramhlp.o, [.src]curl-tool_parsecfg.o, - + [.src]curl-tool_setopt.o, - + [.src]curl-tool_urlglob.o, [.src]curl-tool_util.o, - + [.src]curl-tool_vms.o, [.src]curl-tool_writeenv.o, - + [.src]curl-tool_writeout.o, [.src]curl-tool_xattr.o, - + [.src]curl-nonblock.o, gnv_packages_vms:curlmsg.obj,- + sys$input:/opt +gnv$libcurl/share +gnv_packages_vms:curl_crtl_init.obj +$ endif +$ else +$ curl_exe = "[.src]curl.exe" +$ curl_dsf = "[.src]curl.dsf" +$ curl_main = "[.projects.vms.''arch_name']tool_main.obj" +$ curl_src = "[.projects.vms.''arch_name']curlsrc.olb" +$ curl_lib = "[.projects.vms.''arch_name']curllib.olb" +$ strcase = "strcase" +$ nonblock = "nonblock" +$ warnless = "warnless" +$! +$! Extended parse style requires special quoting +$! +$ if (arch_name .nes. "VAX") .and. (parse_style .eqs. "EXTENDED") +$ then +$ strcase = """strcase""" +$ nonblock = """nonblock""" +$ warnless = """warnless""" +$ endif +$ if f$search(curl_exe) .eqs. "" +$ then +$ define/user gnv$libcurl 'gnv_libcurl_share' +$ link'ldebug'/exe='curl_exe'/dsf='curl_dsf' - + 'curl_main','curl_src'/lib, - + 'curl_lib'/library/include=- + ('strcase','nonblock','warnless'),- + gnv_packages_vms:curlmsg.obj,- + sys$input:/opt +gnv$libcurl/share +gnv_packages_vms:curl_crtl_init.obj +$ endif +$ endif +$! +$! +$! +$! in6addr_missing so skip building: +$! [.server]sws.o +$! [.server]sockfilt.o +$! [.server]tftpd.o +$! +$! +$ target = "10-at-a-time" +$ if f$search("[.docs.examples]''target'.o") .eqs. "" +$ then +$ write sys$output "examples not built" +$ goto all_exit +$ endif +$ if f$search("[.docs.examples]''target'.exe") .eqs. "" +$ then +$ define/user gnv$libcurl 'gnv_libcurl_share' +$ link'ldebug'/exe=[.docs.examples]'target'.exe- + /dsf=[.docs.examples]'target'.dsf - + [.docs.examples]'target'.o,- + gnv$'target'.opt/opt,- + sys$input:/opt +gnv$libcurl/share +$ endif +$! +$! +$ target = "anyauthput" +$ if f$search("[.docs.examples]''target'.exe") .eqs. "" +$ then +$ define/user gnv$libcurl 'gnv_libcurl_share' +$ link'ldebug'/exe=[.docs.examples]'target'.exe- + /dsf=[.docs.examples]'target'.dsf - + [.docs.examples]'target'.o,- + gnv$'target'.opt/opt,- + sys$input:/opt +gnv$libcurl/share +$ endif +$! +$! +$ target = "certinfo" +$ if f$search("[.docs.examples]''target'.exe") .eqs. "" +$ then +$ define/user gnv$libcurl 'gnv_libcurl_share' +$ link'ldebug'/exe=[.docs.examples]'target'.exe- + /dsf=[.docs.examples]'target'.dsf - + [.docs.examples]'target'.o,- + gnv$'target'.opt/opt,- + sys$input:/opt +gnv$libcurl/share +$ endif +$! +$! +$ target = "cookie_interface" +$ if f$search("[.docs.examples]''target'.exe") .eqs. "" +$ then +$ define/user gnv$libcurl 'gnv_libcurl_share' +$ link'ldebug'/exe=[.docs.examples]'target'.exe- + /dsf=[.docs.examples]'target'.dsf - + [.docs.examples]'target'.o,- + gnv$'target'.opt/opt,- + sys$input:/opt +gnv$libcurl/share +$ endif +$! +$! +$ target = "debug" +$ if f$search("[.docs.examples]''target'.exe") .eqs. "" +$ then +$ define/user gnv$libcurl 'gnv_libcurl_share' +$ link'ldebug'/exe=[.docs.examples]'target'.exe- + /dsf=[.docs.examples]'target'.dsf - + [.docs.examples]'target'.o,- + gnv$'target'.opt/opt,- + sys$input:/opt +gnv$libcurl/share +$ endif +$! +$! +$ target = "fileupload" +$ if f$search("[.docs.examples]''target'.exe") .eqs. "" +$ then +$ define/user gnv$libcurl 'gnv_libcurl_share' +$ link'ldebug'/exe=[.docs.examples]'target'.exe- + /dsf=[.docs.examples]'target'.dsf - + [.docs.examples]'target'.o,- + gnv$'target'.opt/opt,- + sys$input:/opt +gnv$libcurl/share +$ endif +$! +$! +$ target = "fopen" +$ if f$search("[.docs.examples]''target'.exe") .eqs. "" +$ then +$ define/user gnv$libcurl 'gnv_libcurl_share' +$ link'ldebug'/exe=[.docs.examples]'target'.exe- + /dsf=[.docs.examples]'target'.dsf - + [.docs.examples]'target'.o,- + gnv$'target'.opt/opt,- + sys$input:/opt +gnv$libcurl/share +$ endif +$! +$! +$target = "ftpget" +$if f$search("[.docs.examples]''target'.exe") .eqs. "" +$then +$ define/user gnv$libcurl 'gnv_libcurl_share' +$ link'ldebug'/exe=[.docs.examples]'target'.exe- + /dsf=[.docs.examples]'target'.dsf - + [.docs.examples]'target'.o,- + gnv$'target'.opt/opt,- + sys$input:/opt +gnv$libcurl/share +$endif +$! +$! +$target = "ftpgetresp" +$if f$search("[.docs.examples]''target'.exe") .eqs. "" +$then +$ define/user gnv$libcurl 'gnv_libcurl_share' +$ link'ldebug'/exe=[.docs.examples]'target'.exe- + /dsf=[.docs.examples]'target'.dsf - + [.docs.examples]'target'.o,- + gnv$'target'.opt/opt,- + sys$input:/opt +gnv$libcurl/share +$endif +$! +$! +$target = "ftpupload" +$if f$search("[.docs.examples]''target'.exe") .eqs. "" +$then +$ define/user gnv$libcurl 'gnv_libcurl_share' +$ link'ldebug'/exe=[.docs.examples]'target'.exe- + /dsf=[.docs.examples]'target'.dsf - + [.docs.examples]'target'.o,- + gnv$'target'.opt/opt,- + sys$input:/opt +gnv$libcurl/share +$endif +$! +$! +$target = "getinfo" +$if f$search("[.docs.examples]''target'.exe") .eqs. "" +$then +$ define/user gnv$libcurl 'gnv_libcurl_share' +$ link'ldebug'/exe=[.docs.examples]'target'.exe- + /dsf=[.docs.examples]'target'.dsf - + [.docs.examples]'target'.o,- + gnv$'target'.opt/opt,- + sys$input:/opt +gnv$libcurl/share +$endif +$! +$! +$target = "getinmemory" +$if f$search("[.docs.examples]''target'.exe") .eqs. "" +$then +$ define/user gnv$libcurl 'gnv_libcurl_share' +$ link'ldebug'/exe=[.docs.examples]'target'.exe- + /dsf=[.docs.examples]'target'.dsf - + [.docs.examples]'target'.o,- + gnv$'target'.opt/opt,- + sys$input:/opt +gnv$libcurl/share +$endif +$! +$! +$target = "http-post" +$if f$search("[.docs.examples]''target'.exe") .eqs. "" +$then +$ define/user gnv$libcurl 'gnv_libcurl_share' +$ link'ldebug'/exe=[.docs.examples]'target'.exe- + /dsf=[.docs.examples]'target'.dsf - + [.docs.examples]'target'.o,- + gnv$'target'.opt/opt,- + sys$input:/opt +gnv$libcurl/share +$endif +$! +$! +$target = "httpcustomheader" +$if f$search("[.docs.examples]''target'.exe") .eqs. "" +$then +$ define/user gnv$libcurl 'gnv_libcurl_share' +$ link'ldebug'/exe=[.docs.examples]'target'.exe- + /dsf=[.docs.examples]'target'.dsf - + [.docs.examples]'target'.o,- + gnv$'target'.opt/opt,- + sys$input:/opt +gnv$libcurl/share +$endif +$! +$! +$target = "httpput" +$if f$search("[.docs.examples]''target'.exe") .eqs. "" +$then +$ define/user gnv$libcurl 'gnv_libcurl_share' +$ link'ldebug'/exe=[.docs.examples]'target'.exe- + /dsf=[.docs.examples]'target'.dsf - + [.docs.examples]'target'.o,- + gnv$'target'.opt/opt,- + sys$input:/opt +gnv$libcurl/share +$endif +$! +$! +$target = "https" +$if f$search("[.docs.examples]''target'.exe") .eqs. "" +$then +$ define/user gnv$libcurl 'gnv_libcurl_share' +$ link'ldebug'/exe=[.docs.examples]'target'.exe- + /dsf=[.docs.examples]'target'.dsf - + [.docs.examples]'target'.o,- + gnv$'target'.opt/opt,- + sys$input:/opt +gnv$libcurl/share +$endif +$! +$! +$target = "multi-app" +$if f$search("[.docs.examples]''target'.exe") .eqs. "" +$then +$ define/user gnv$libcurl 'gnv_libcurl_share' +$ link'ldebug'/exe=[.docs.examples]'target'.exe- + /dsf=[.docs.examples]'target'.dsf - + [.docs.examples]'target'.o,- + gnv$'target'.opt/opt,- + sys$input:/opt +gnv$libcurl/share +$endif +$! +$! +$target = "multi-debugcallback" +$if f$search("[.docs.examples]''target'.exe") .eqs. "" +$then +$ define/user gnv$libcurl 'gnv_libcurl_share' +$ link'ldebug'/exe=[.docs.examples]'target'.exe- + /dsf=[.docs.examples]'target'.dsf - + [.docs.examples]'target'.o,- + gnv$'target'.opt/opt,- + sys$input:/opt +gnv$libcurl/share +$endif +$! +$! +$target = "multi-double" +$if f$search("[.docs.examples]''target'.exe") .eqs. "" +$then +$ define/user gnv$libcurl 'gnv_libcurl_share' +$ link'ldebug'/exe=[.docs.examples]'target'.exe- + /dsf=[.docs.examples]'target'.dsf - + [.docs.examples]'target'.o,- + gnv$'target'.opt/opt,- + sys$input:/opt +gnv$libcurl/share +$endif +$! +$! +$target = "multi-post" +$if f$search("[.docs.examples]''target'.exe") .eqs. "" +$then +$ define/user gnv$libcurl 'gnv_libcurl_share' +$ link'ldebug'/exe=[.docs.examples]'target'.exe- + /dsf=[.docs.examples]'target'.dsf - + [.docs.examples]'target'.o,- + gnv$'target'.opt/opt,- + sys$input:/opt +gnv$libcurl/share +$endif +$! +$! +$target = "multi-single" +$if f$search("[.docs.examples]''target'.exe") .eqs. "" +$then +$ define/user gnv$libcurl 'gnv_libcurl_share' +$ link'ldebug'/exe=[.docs.examples]'target'.exe- + /dsf=[.docs.examples]'target'.dsf - + [.docs.examples]'target'.o,- + gnv$'target'.opt/opt,- + sys$input:/opt +gnv$libcurl/share +$endif +$! +$! +$target = "persistent" +$if f$search("[.docs.examples]''target'.exe") .eqs. "" +$then +$ define/user gnv$libcurl 'gnv_libcurl_share' +$ link'ldebug'/exe=[.docs.examples]'target'.exe- + /dsf=[.docs.examples]'target'.dsf - + [.docs.examples]'target'.o,- + gnv$'target'.opt/opt,- + sys$input:/opt +gnv$libcurl/share +$endif +$! +$! +$target = "post-callback" +$if f$search("[.docs.examples]''target'.exe") .eqs. "" +$then +$ define/user gnv$libcurl 'gnv_libcurl_share' +$ link'ldebug'/exe=[.docs.examples]'target'.exe- + /dsf=[.docs.examples]'target'.dsf - + [.docs.examples]'target'.o,- + gnv$'target'.opt/opt,- + sys$input:/opt +gnv$libcurl/share +$endif +$! +$! +$target = "postit2" +$if f$search("[.docs.examples]''target'.exe") .eqs. "" +$then +$ define/user gnv$libcurl 'gnv_libcurl_share' +$ link'ldebug'/exe=[.docs.examples]'target'.exe- + /dsf=[.docs.examples]'target'.dsf - + [.docs.examples]'target'.o,- + gnv$'target'.opt/opt,- + sys$input:/opt +gnv$libcurl/share +$endif +$! +$! +$target = "sendrecv" +$if f$search("[.docs.examples]''target'.exe") .eqs. "" +$then +$ define/user gnv$libcurl 'gnv_libcurl_share' +$ link'ldebug'/exe=[.docs.examples]'target'.exe- + /dsf=[.docs.examples]'target'.dsf - + [.docs.examples]'target'.o,- + gnv$'target'.opt/opt,- + sys$input:/opt +gnv$libcurl/share +$endif +$! +$! +$target = "sepheaders" +$if f$search("[.docs.examples]''target'.exe") .eqs. "" +$then +$ define/user gnv$libcurl 'gnv_libcurl_share' +$ link'ldebug'/exe=[.docs.examples]'target'.exe- + /dsf=[.docs.examples]'target'.dsf - + [.docs.examples]'target'.o,- + gnv$'target'.opt/opt,- + sys$input:/opt +gnv$libcurl/share +$endif +$! +$! +$target = "simple" +$if f$search("[.docs.examples]''target'.exe") .eqs. "" +$then +$ define/user gnv$libcurl 'gnv_libcurl_share' +$ link'ldebug'/exe=[.docs.examples]'target'.exe- + /dsf=[.docs.examples]'target'.dsf - + [.docs.examples]'target'.o,- + gnv$'target'.opt/opt,- + sys$input:/opt +gnv$libcurl/share +$endif +$! +$! +$target = "simplepost" +$if f$search("[.docs.examples]''target'.exe") .eqs. "" +$then +$ define/user gnv$libcurl 'gnv_libcurl_share' +$ link'ldebug'/exe=[.docs.examples]'target'.exe- + /dsf=[.docs.examples]'target'.dsf - + [.docs.examples]'target'.o,- + gnv$'target'.opt/opt,- + sys$input:/opt +gnv$libcurl/share +$endif +$! +$! +$target = "simplessl" +$if f$search("[.docs.examples]''target'.exe") .eqs. "" +$then +$ define/user gnv$libcurl 'gnv_libcurl_share' +$ link'ldebug'/exe=[.docs.examples]'target'.exe- + /dsf=[.docs.examples]'target'.dsf - + [.docs.examples]'target'.o,- + gnv$'target'.opt/opt,- + sys$input:/opt +gnv$libcurl/share +$endif +$! +$! =============== End of docs/examples ========================= +$! +$! +$all_exit: +$set def 'default_dir' +$exit '$status' +$! diff --git a/3rdparty/curl-8.21.0/projects/vms/macro32_exactcase.patch b/3rdparty/curl-8.21.0/projects/vms/macro32_exactcase.patch new file mode 100644 index 0000000000..eda5cac7b7 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/macro32_exactcase.patch @@ -0,0 +1,11 @@ +macro32_exactcase.exe +SE EC +^X00000001 +RE /I +^X00012B1D +'BICB2 #^X00000020,R3' +EXIT +'BICB2 #^X00000000,R3' +EXI +U +EXI diff --git a/3rdparty/curl-8.21.0/projects/vms/make_gnv_curl_install.sh b/3rdparty/curl-8.21.0/projects/vms/make_gnv_curl_install.sh new file mode 100755 index 0000000000..623fcc3a6b --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/make_gnv_curl_install.sh @@ -0,0 +1,44 @@ +# File: make_gnv_curl_install.sh +# +# Set up and run the make script for curl. +# +# This makes the library, the curl binary and attempts an install. +# A search list should be set up for GNU (GNV$GNU). +# +# Copyright (C) John Malmberg +# +# Permission to use, copy, modify, and/or distribute this software for any +# purpose with or without fee is hereby granted, provided that the above +# copyright notice and this permission notice appear in all copies. +# +# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT +# OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +# +# SPDX-License-Identifier: ISC +# +#========================================================================== +# +# +# Needed VMS build setups for GNV. +export GNV_OPT_DIR=. +export GNV_CC_QUALIFIERS=/DEBUG/OPTIMIZE/STANDARD=RELAXED\ +/float=ieee_float/ieee_mode=denorm_results +export GNV_CXX_QUALIFIERS=/DEBUG/OPTIMIZE/float=ieee/ieee_mode=denorm_results +export GNV_CC_NO_INC_PRIMARY=1 +# +# +# POSIX exit mode is needed for Unix shells. +export GNV_CC_MAIN_POSIX_EXIT=1 +make +cd ../.. +# adjust the libcurl.pc file, GNV currently ignores the Lib: line. +# but is noisy about it, so we remove it. +sed -e 's/^Libs:/#Libs:/g' libcurl.pc > libcurl.pc_new +rm libcurl.pc +mv libcurl.pc_new libcurl.pc +make install diff --git a/3rdparty/curl-8.21.0/projects/vms/make_pcsi_curl_kit_name.com b/3rdparty/curl-8.21.0/projects/vms/make_pcsi_curl_kit_name.com new file mode 100644 index 0000000000..c7c2b26ada --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/make_pcsi_curl_kit_name.com @@ -0,0 +1,188 @@ +$! File: MAKE_PCSI_CURL_KIT_NAME.COM +$! +$! Calculates the PCSI kit name for use in building an installation kit. +$! PCSI is HP's PolyCenter Software Installation Utility. +$! +$! The results are stored in as logical names so that other procedures +$! can use them. +$! +$! Copyright (C) John Malmberg +$! +$! Permission to use, copy, modify, and/or distribute this software for any +$! purpose with or without fee is hereby granted, provided that the above +$! copyright notice and this permission notice appear in all copies. +$! +$! THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +$! WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +$! MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +$! ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +$! WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +$! ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT +$! OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +$! +$! SPDX-License-Identifier: ISC +$! +$!======================================================================== +$! +$! Save default +$ default_dir = f$environment("DEFAULT") +$! +$! Move to the base directories +$ set def [--] +$! +$! Put things back on error. +$ on warning then goto all_exit +$! +$! The producer is the name or common abbreviation for the entity that is +$! making the kit. It must be set as a logical name before running this +$! procedure. +$! +$! HP documents the producer as the legal owner of the software, but for +$! open source work, it should document who is creating the package for +$! distribution. +$! +$ producer = f$trnlnm("GNV_PCSI_PRODUCER") +$ if producer .eqs. "" +$ then +$ write sys$output "The logical name GNV_PCSI_PRODUCER needs to be defined." +$ write sys$output "This should be set to the common abbreviation or name of" +$ write sys$output "the entity creating this kit. If you are an individual" +$ write sys$output "then use your initials." +$ goto all_exit +$ endif +$ producer_full_name = f$trnlnm("GNV_PCSI_PRODUCER_FULL_NAME") +$ if producer_full_name .eqs. "" +$ then +$ write sys$output "The logical name GNV_PCSI_PRODUCER_FULL_NAME needs to" +$ write sys$output "be defined. This should be set to the full name of" +$ write sys$output "the entity creating this kit. If you are an individual" +$ write sys$output "then use your name." +$ write sys$output "EX: DEFINE GNV_PCSI_PRODUCER_FULL_NAME ""First M. Last""" +$ goto all_exit +$ endif +$! +$ write sys$output "*****" +$ write sys$output "***** Producer = ''producer'" +$ write sys$output "*****" +$! +$! +$! Base is one of 'VMS', 'AXPVMS', 'I64VMS', 'VAXVMS' and indicates what +$! binaries are in the kit. A kit with only 'VMS' can be installed on all +$! architectures. +$! +$ base = "VMS" +$ arch_type = f$getsyi("ARCH_NAME") +$ code = f$extract(0, 1, arch_type) +$ if (code .eqs. "I") then base = "I64VMS" +$ if (code .eqs. "V") then base = "VAXVMS" +$ if (code .eqs. "A") then base = "AXPVMS" +$! +$! +$ product = "curl" +$! +$! +$! We need to get the version from curlver_h. It will have a line like +$! #define LIBCURL_VERSION "7.31.0" +$! or +$! #define LIBCURL_VERSION "7.32.0-20130731". +$! +$! The dash indicates that this is a daily pre-release. +$! +$! +$ open/read/error=version_loop_end vhf [.include.curl]curlver.h +$ version_loop: +$ read vhf line_in +$ if line_in .eqs. "" then goto version_loop +$ if f$locate("#define LIBCURL_VERSION ", line_in) .ne. 0 +$ then +$ goto version_loop +$ endif +$ raw_version = f$element(2," ", line_in) - """" - """" +$ version_loop_end: +$ close vhf +$! +$! +$ eco_level = "" +$ if f$search("''default_dir'vms_eco_level.h") .nes. "" +$ then +$ open/read ef 'default_dir'vms_eco_level.h +$ecolevel_loop: +$ read/end=ecolevel_loop_end ef line_in +$ prefix = f$element(0, " ", line_in) +$ if prefix .nes. "#define" then goto ecolevel_loop +$ key = f$element(1, " ", line_in) +$ value = f$element(2, " ", line_in) - """" - """" +$ if key .eqs. "VMS_ECO_LEVEL" +$ then +$ eco_level = "''value'" +$ if eco_level .eqs. "0" +$ then +$ eco_level = "" +$ else +$ eco_level = "E" + eco_level +$ endif +$ goto ecolevel_loop_end +$ endif +$ goto ecolevel_loop +$ecolevel_loop_end: +$ close ef +$ endif +$! +$! +$! This translates to V0732-0 or D0732-0 +$! We encode the snapshot date into the version as an ECO since a daily +$! can never have an ECO. +$! +$! version_type = 'V' for a production release, and 'D' for a build from a +$! daiy snapshot of the curl source. +$ majorver = f$element(0, ".", raw_version) +$ minorver = f$element(1, ".", raw_version) +$ raw_update = f$element(2, ".", raw_version) +$ update = f$element(0, "-", raw_update) +$ if update .eqs. "0" then update = "" +$ daily_tag = f$element(1, "-", raw_update) +$ vtype = "V" +$ patch = "" +$ if daily_tag .nes. "-" +$ then +$ vtype = "D" +$ daily_tag_len = f$length(daily_tag) +$ daily_tag = f$extract(4, daily_tag_len - 4, daily_tag) +$ patch = vtype + daily_tag +$ product = product + "_d" +$ else +$ daily_tag = "" +$ if eco_level .nes. "" then patch = eco_level +$ endif +$! +$! +$ version_fao = "!2ZB!2ZB" +$ mmversion = f$fao(version_fao, 'majorver', 'minorver') +$ version = vtype + "''mmversion'" +$ if update .nes. "" .or. patch .nes. "" +$ then +$! The presence of a patch implies an update +$ if update .eqs. "" .and. patch .nes. "" then update = "0" +$ version = version + "-" + update + patch +$ fversion = version +$ else +$ fversion = version +$ version = version + "-" +$ endif +$! +$! Kit type 1 is complete kit, the only type that this procedure will make. +$ kittype = 1 +$! +$! Write out a logical name for the resulting base kit name. +$ name = "''producer'-''base'-''product'-''version'-''kittype'" +$ define GNV_PCSI_KITNAME "''name'" +$ fname = "''product'-''fversion'" +$ define GNV_PCSI_FILENAME_BASE "''fname'" +$ write sys$output "*****" +$ write sys$output "***** GNV_PCSI_KITNAME = ''name'." +$ write sys$output "***** GNV_PCSI_FILENAME_BASE = ''fname'." +$ write sys$output "*****" +$! +$all_exit: +$ set def 'default_dir' +$ exit '$status' diff --git a/3rdparty/curl-8.21.0/projects/vms/pcsi_gnv_curl_file_list.txt b/3rdparty/curl-8.21.0/projects/vms/pcsi_gnv_curl_file_list.txt new file mode 100644 index 0000000000..9ae49d5977 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/pcsi_gnv_curl_file_list.txt @@ -0,0 +1,125 @@ +! File: PCSI_GNV_CURL_FILE_LIST.TXT +! +! File list for building a PCSI kit. +! Simple format so that the parsing logic can be simple. +! links first, directory second, and files third. +! +! link -> file tells procedure to create/remove a link on install/uninstall +! If more than one link, consider using an alias file. +! +! [xxx.yyy]foo.dir is a directory file for the rename phase. +! [xxx.yyy.foo] is a directory file for the create phase. +! Each subdirectory needs to be on its own pair of lines. +! +! [xxx.yyy]file.ext is a file for the rename and add phases. +! +! Copyright (C) John Malmberg +! +! Permission to use, copy, modify, and/or distribute this software for any +! purpose with or without fee is hereby granted, provided that the above +! copyright notice and this permission notice appear in all copies. +! +! THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +! WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +! ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +! WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +! ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT +! OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +! +! SPDX-License-Identifier: ISC +! +!============================================================================ +[gnv.usr.bin]curl. -> [gnv.usr.bin]gnv$curl.exe +[gnv.usr.bin]curl.exe -> [gnv.usr.bin]gnv$curl.exe +[gnv] +[000000]gnv.dir +[gnv.usr] +[gnv]usr.dir +[gnv.usr]bin.dir +[gnv.usr.bin] +[gnv.usr]include.dir +[gnv.usr.include] +[gnv.usr.include]curl.dir +[gnv.usr.include.curl] +[gnv.usr]lib.dir +[gnv.usr.lib] +[gnv.usr.lib]pkgconfig.dir +[gnv.usr.lib.pkgconfig] +[gnv.usr]share.dir +[gnv.usr.share] +[gnv.usr.share]man.dir +[gnv.usr.share.man] +[gnv.usr.share.man]man1.dir +[gnv.usr.share.man.man1] +[gnv.usr.share.man]man3.dir +[gnv.usr.share.man.man3] +[gnv.usr.bin]curl-config. +[gnv.usr.bin]gnv$curl.exe +[gnv.usr.include.curl]curl.h +[gnv.usr.include.curl]system.h +[gnv.usr.include.curl]curlver.h +[gnv.usr.include.curl]easy.h +[gnv.usr.include.curl]mprintf.h +[gnv.usr.include.curl]multi.h +[gnv.usr.include.curl]stdcheaders.h +[gnv.usr.include.curl]typecheck-gcc.h +[gnv.usr.lib]gnv$libcurl.exe +[gnv.usr.lib]gnv$curlmsg.exe +[gnv.usr.lib.pkgconfig]libcurl.pc +[gnv.usr.share.man.man1]curl-config.1 +[gnv.usr.share.man.man1]curl.1 +[gnv.usr.share.man.man3]curl_easy_cleanup.3 +[gnv.usr.share.man.man3]curl_easy_duphandle.3 +[gnv.usr.share.man.man3]curl_easy_escape.3 +[gnv.usr.share.man.man3]curl_easy_getinfo.3 +[gnv.usr.share.man.man3]curl_easy_init.3 +[gnv.usr.share.man.man3]curl_easy_pause.3 +[gnv.usr.share.man.man3]curl_easy_perform.3 +[gnv.usr.share.man.man3]curl_easy_recv.3 +[gnv.usr.share.man.man3]curl_easy_reset.3 +[gnv.usr.share.man.man3]curl_easy_send.3 +[gnv.usr.share.man.man3]curl_easy_setopt.3 +[gnv.usr.share.man.man3]curl_easy_strerror.3 +[gnv.usr.share.man.man3]curl_easy_unescape.3 +[gnv.usr.share.man.man3]curl_escape.3 +[gnv.usr.share.man.man3]curl_formadd.3 +[gnv.usr.share.man.man3]curl_formfree.3 +[gnv.usr.share.man.man3]curl_formget.3 +[gnv.usr.share.man.man3]curl_free.3 +[gnv.usr.share.man.man3]curl_getdate.3 +[gnv.usr.share.man.man3]curl_getenv.3 +[gnv.usr.share.man.man3]curl_global_cleanup.3 +[gnv.usr.share.man.man3]curl_global_init.3 +[gnv.usr.share.man.man3]curl_global_init_mem.3 +[gnv.usr.share.man.man3]curl_mprintf.3 +[gnv.usr.share.man.man3]curl_multi_add_handle.3 +[gnv.usr.share.man.man3]curl_multi_assign.3 +[gnv.usr.share.man.man3]curl_multi_cleanup.3 +[gnv.usr.share.man.man3]curl_multi_fdset.3 +[gnv.usr.share.man.man3]curl_multi_info_read.3 +[gnv.usr.share.man.man3]curl_multi_init.3 +[gnv.usr.share.man.man3]curl_multi_perform.3 +[gnv.usr.share.man.man3]curl_multi_remove_handle.3 +[gnv.usr.share.man.man3]curl_multi_setopt.3 +[gnv.usr.share.man.man3]curl_multi_socket.3 +[gnv.usr.share.man.man3]curl_multi_socket_action.3 +[gnv.usr.share.man.man3]curl_multi_strerror.3 +[gnv.usr.share.man.man3]curl_multi_timeout.3 +[gnv.usr.share.man.man3]curl_multi_wait.3 +[gnv.usr.share.man.man3]curl_share_cleanup.3 +[gnv.usr.share.man.man3]curl_share_init.3 +[gnv.usr.share.man.man3]curl_share_setopt.3 +[gnv.usr.share.man.man3]curl_share_strerror.3 +[gnv.usr.share.man.man3]curl_slist_append.3 +[gnv.usr.share.man.man3]curl_slist_free_all.3 +[gnv.usr.share.man.man3]curl_strequal.3 +[gnv.usr.share.man.man3]curl_unescape.3 +[gnv.usr.share.man.man3]curl_version.3 +[gnv.usr.share.man.man3]curl_version_info.3 +[gnv.usr.share.man.man3]libcurl-easy.3 +[gnv.usr.share.man.man3]libcurl-errors.3 +[gnv.usr.share.man.man3]libcurl-multi.3 +[gnv.usr.share.man.man3]libcurl-share.3 +[gnv.usr.share.man.man3]libcurl-tutorial.3 +[gnv.usr.share.man.man3]libcurl.3 diff --git a/3rdparty/curl-8.21.0/projects/vms/pcsi_product_gnv_curl.com b/3rdparty/curl-8.21.0/projects/vms/pcsi_product_gnv_curl.com new file mode 100644 index 0000000000..15ab32f317 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/pcsi_product_gnv_curl.com @@ -0,0 +1,197 @@ +$! File: PCSI_PRODUCT_GNV_CURL.COM +$! +$! This command file packages up the product curl into a sequential +$! format kit +$! +$! Copyright (C) John Malmberg +$! +$! Permission to use, copy, modify, and/or distribute this software for any +$! purpose with or without fee is hereby granted, provided that the above +$! copyright notice and this permission notice appear in all copies. +$! +$! THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +$! WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +$! MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +$! ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +$! WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +$! ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT +$! OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +$! +$! SPDX-License-Identifier: ISC +$! +$!========================================================================= +$! +$! Save default +$ default_dir = f$environment("DEFAULT") +$! +$! Put things back on error. +$ on warning then goto all_exit +$! +$! +$ can_build = 1 +$ producer = f$trnlnm("GNV_PCSI_PRODUCER") +$ if producer .eqs. "" +$ then +$ write sys$output "GNV_PCSI_PRODUCER logical name has not been set." +$ can_build = 0 +$ endif +$ producer_full_name = f$trnlnm("GNV_PCSI_PRODUCER_FULL_NAME") +$ if producer_full_name .eqs. "" +$ then +$ write sys$output - + "GNV_PCSI_PRODUCER_FULL_NAME logical name has not been set." +$ can_build = 0 +$ endif +$ stage_root_name = f$trnlnm("STAGE_ROOT") +$ if stage_root_name .eqs. "" +$ then +$ write sys$output "STAGE_ROOT logical name has not been set." +$ can_build = 0 +$ endif +$! +$ if (can_build .eq. 0) +$ then +$ write sys$output "Not able to build a kit." +$ goto all_exit +$ endif +$! +$! Make sure that the kit name is up to date for this build +$!---------------------------------------------------------- +$ @MAKE_PCSI_CURL_KIT_NAME.COM +$! +$! +$! Make sure that the image is built +$!---------------------------------- +$ arch_name = f$edit(f$getsyi("arch_name"),"UPCASE") +$ if f$search("[--.src]curl.exe") .eqs. "" +$ then +$ build_it = 1 +$ libfile = "[.projects.vms.''arch_name']curllib.olb" +$ if f$search(libfile) .nes. "" +$ then +$ build_it = 0 +$ else +$ ! GNV based build +$ libfile = "[.lib.^.libs]libcurl.a" +$ if f$search(libfile) .nes. "" +$ then +$ build_it = 0; +$ endif +$ endif +$ if build_it .eq. 1 +$ then +$ @build_vms list +$ endif +$ @gnv_link_curl.com +$ endif +$! +$! Make sure that the release note filename is up to date +$!-------------------------------------------------------- +$ @BUILD_GNV_CURL_RELEASE_NOTES.COM +$! +$! +$! Make sure that the source has been backed up. +$!---------------------------------------------- +$ arch_type = f$getsyi("ARCH_NAME") +$ arch_code = f$extract(0, 1, arch_type) +$ @backup_gnv_curl_src.com +$! +$! Regenerate the PCSI description file. +$!-------------------------------------- +$ @BUILD_GNV_CURL_PCSI_DESC.COM +$! +$! Regenerate the PCSI Text file. +$!--------------------------------- +$ @BUILD_GNV_CURL_PCSI_TEXT.COM +$! +$! +$! Parse the kit name into components. +$!--------------------------------------- +$ kit_name = f$trnlnm("GNV_PCSI_KITNAME") +$ if kit_name .eqs. "" +$ then +$ write sys$output "@MAKE_PCSI_CURL_KIT_NAME.COM has not been run." +$ goto all_exit +$ endif +$ producer = f$element(0, "-", kit_name) +$ base = f$element(1, "-", kit_name) +$ product_name = f$element(2, "-", kit_name) +$ mmversion = f$element(3, "-", kit_name) +$ majorver = f$extract(0, 3, mmversion) +$ minorver = f$extract(3, 2, mmversion) +$ updatepatch = f$element(4, "-", kit_name) +$ if updatepatch .eqs. "" then updatepatch = "" +$! +$ version_fao = "!AS.!AS" +$ mmversion = f$fao(version_fao, "''majorver'", "''minorver'") +$ if updatepatch .nes. "" +$ then +$ version = "''mmversion'" + "-" + updatepatch +$ else +$ version = "''mmversion'" +$ endif +$! +$ @stage_curl_install remove +$ @stage_curl_install +$! +$! Move to the base directories +$ set def [--] +$ current_default = f$environment("DEFAULT") +$ my_dir = f$parse(current_default,,,"DIRECTORY") - "[" - "<" - ">" - "]" +$! +$! +$! +$ source = "''default_dir'" +$ src1 = "new_gnu:[usr.bin]," +$ src2 = "new_gnu:[usr.include.curl]," +$ src3 = "new_gnu:[usr.lib]," +$ src4 = "new_gnu:[usr.lib.pkgconfig]," +$ src5 = "new_gnu:[usr.share.man.man1]," +$ src6 = "new_gnu:[usr.share.man.man3]," +$ src7 = "new_gnu:[vms_src]," +$ src8 = "new_gnu:[common_src]," +$ src9 = "prj_root:[''my_dir'],prj_root:[''my_dir'.src]" +$ gnu_src = src1 + src2 + src3 + src4 + src5 + src6 + src7 + src8 + src9 +$! +$! +$ base = "" +$ if arch_name .eqs. "ALPHA" then base = "AXPVMS" +$ if arch_name .eqs. "IA64" then base = "I64VMS" +$ if arch_name .eqs. "VAX" then base = "VAXVMS" +$! +$ if base .eqs. "" then exit 44 +$! +$ pcsi_option = "/option=noconfirm" +$ if arch_code .eqs. "V" +$ then +$ pcsi_option = "" +$ endif +$! +$! +$product package 'product_name' - + /base='base' - + /producer='producer' - + /source='source' - + /destination=STAGE_ROOT:[KIT] - + /material=('gnu_src','source') - + /format=sequential 'pcsi_option' +$! +$! +$! VAX can not do a compressed kit. +$! ZIP -9 "-V" does a better job, so no reason to normally build a compressed +$! kit. +$!---------------------------------- +$if p1 .eqs. "COMPRESSED" +$then +$ if arch_code .nes. "V" +$ then +$ product copy /options=(novalidate, noconfirm) /format=compressed - + 'product_name' - + /source=stage_root:[kit]/dest=stage_root:[kit] - + /version='version'/base='base' +$ endif +$endif +$! +$all_exit: +$ set def 'default_dir' +$ exit diff --git a/3rdparty/curl-8.21.0/projects/vms/readme b/3rdparty/curl-8.21.0/projects/vms/readme new file mode 100644 index 0000000000..9db0ee3873 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/readme @@ -0,0 +1,228 @@ + _ _ ____ _ + ___| | | | _ \| | + / __| | | | |_) | | + ( (__| |_| | _ <| |___ + \___|\___/|_| \_\_____| + for OpenVMS + +History: + +09-MAR-2004, Created this readme. file. Marty Kuhrt (MSK). +15-MAR-2004, MSK, Updated to reflect the new files in this directory. +14-FEB-2005, MSK, removed config-vms.h_with* file comments +10-FEB-2010, SMS. General update. +14-Jul-2013, JEM, General Update, add GNV build information. + + +The release notes installed by the PCSI kit consist of this file and the +curl_gnv_build_steps.txt and other useful information. + +Prerequisites: + +OpenVMS v7.0 or later (any platform) +DECC v6.5 or later +OpenSSL or HP SSL, if you want SSL support + +What is Here: + +This directory contains the following files for a DCL based build. + +backup_gnv_curl_src.com This procedure backs up the source modules for + creating a PCSI kit. + +build_curl-config_script.com + Procedure to create the curl-config script. + +build_gnv_curl.com This procedure does a build of curl using the + GNV utilities and then uses DCL tools to build + the libcurl shared image. The setup_gnv_curl_build.com + procedure must be run first. + +build_gnv_curl_pcsi_desc.com + This procedure builds the pcsi$desc file for + creating a PCSI based package. + +build_gnv_curl_pcsi_text.com + This procedure builds the pcsi$text file for + creating a PCSI based package. + +build_gnv_curl_release_notes.com + This procedure creates the release notes for + a PCSI kit based on curl_release_note_start.txt, + this readme file, and the curl_gnv_build_steps.txt + +build_libcurl_pc.com Procedure to create a libcurl.pc file. + +build_vms.com DCL based build procedure. + +clean_gnv_curl.com This procedure cleans up the files generated by + a GNV based build. + +config_h.com DCL based procedure used by build_vms.com + to run generate the curl_config.h file. + This is a generic procedure that does most + of the work for generating config.h files. + +compare_curl_source.com Procedure to compare the working directory + with a repository directory or a backup staging + directory. + +curl_crtl_init.c A special pre-initialization routine to for + programs to behave more Unix like when run + under GNV. + +curl_gnv_build_steps.txt + Detailed instructions on how to built curl using + GNV and how to build the libcurl shared image and + PCSI kit. + +curl_release_note_start.txt + The first part of the curl release notes. + +curl_startup.com A procedure run at VMS startup to install the + libcurl shared image and to set up the needed + logical names. + +curlmsg.h C header defining curl status code macros. + +curlmsg.msg Error message source for curlmsg.h and curlmsg.sdl. + +curlmsg.sdl SDL source defining curl status code constants. + +curlmsg_vms.h Mapping of curl status codes to VMS-form codes. + +generate_config_vms_h_curl.com + DCL procedure to generate the curl specific + definitions for curl_config.h that config_h.com + can not properly generate. + +generate_vax_transfer.com + DCL procedure to read an Alpha/IA64 symbol vector + linker option file and generate the VAX transfer + vector modules. + +gnv_conftest.c_first A helper file for the configure script. + +gnv_curl_configure.sh A script to run the configure script with the + options needed for VMS. + +gnv_libcurl_symbols.opt The symbol vectors needed for Alpha and IA64 + libcurl shared image. + +gnv_link_curl.com Links the libcurl shared image and then links a curl + image to use the libcurl. + +macro32_exactcase.patch The patch file needed to modify VAX Macro32 to be + case sensitive and case preserving. + +Makefile.am curl kit file list for this directory. + +Makefile.in curl kit makefile source for this directory. + +make_gnv_curl_install.sh + Script to do a make install using GNV after running + the configure script. + +make_pcsi_curl_kit_name.com + This generates the name of the PCSI kit based on + the version of curl being built. + +pcsi_gnv_curl_file_list.txt + This is a text file describing what files should + be included in a PCSI kit. + +pcsi_product_gnv_curl.com + This generates the PCSI kit after the libcurl + shared image has been made. + +readme. This file. + +report_openssl_version.c + Program to check that the OpenSSL version is new + enough for building a shared libcurl image. + +setup_gnv_curl_build.com + This procedure sets up symbols and logical names + for a GNV build environment and also copies some + helper files. + +stage_curl_install.com This procedure sets up new_gnu: directory tree to + for testing the install and building the PCSI kit. + It takes a "remove" option to remove all the staged + files. + +vms_eco_level.h This sets the ECO level for the PCSI kit name. + + +How to Build: + +The GNV based build and the DCL based build procedures are not compatible +and you must make sure that none of the build files are present before +running a different type of build. Use the "REALCLEAN" option for +BUILD_VMS.COM and the "REALCLEAN" option for clean_gnv_curl.com. + +The (brute-force) DCL based builder is [.projects.vms]build_vms.com. +Comments in this procedure describe various optional parameters which +enable or disable optional program features, or which control the build +in other ways. Product files (.EXE, .H, .LIS, .MAP, .OBJ, .OLB, ...) +should be produced in an architecture-specific subdirectory under this +directory ([.ALPHA], [.IA64], [.VAX]). + +The file curl_gnv_build_steps.txt contains information on building using +the GNV tool kit, building a shared libcurl, and producing a PCSI kit for +distribution. The curl_gnv_build_steps.text is included in the release +notes file of the PCSI kit. + +The building with 64-bit pointers does not currently work. + +The build procedure will detect if HP OpenSSL, LDAP, and Kerberos are +installed and default to building with them. + +The build procedure will also detect if a compatible ZLIB shared image +is installed from a PCSI kit and default to using it. + + Example build commands: + + @ [.projects.vms]build_vms.com CLEAN + @ [.projects.vms]build_vms.com LARGE LDAP + submit /noprint [.projects.vms]build_vms.com /param = (LARGE, LDAP) + +The build_vms.com procedure does not build the shared image file or the PCSI +kit. If you have built a curl with ZLIB and HPSSL support as well as if +LDAP and Kerberos installed, you can use the GNV_LINK_CURL.COM file. + +The GNV_LINK_CURL.COM contains information on how to link and run with a newer +version of HP SSL than what may be install on an Alpha or IA64 based system. + +To build the PCSI kit, follow the instructions in the file +curl_gnv_build_steps.txt. + +Other Notes: + +This release fixes known bugs #22, and #57 in the [curl.docs]known_bugs. +file. + +The libcurl formdata.c module and curl tools post form now have some +understanding of VMS file types. Files will be posted in STREAM_LF format. + +The curl tool now has some understanding of VMS file types and will upload the +files in STREAM_LF format. + +When curl is uploading a VARIABLE format VMS file, it is less efficient as in +order to get the file size, it will first read the entire file once, and then +read the file again for the actual upload. + +The curl tool will now always download files into STREAM_LF format. Even if a +file by that name with a different format already exists. This is needed to +allow interrupted downloads to be continued. + + +The libcurl file module still does not understand VMS file types and requires +the input files to be in STREAM_LF to work property. + +The test suites are not supported as of 7.11.0. + +The curlmsg.sdl and curlmsg.h files are generated from curlmsg.msg. +This is not done automatically, since the .MSG file is a hand edit +of the relevant stuff from the curl.h file. If you want to do this +yourself you need the SDL package from the freeware collection. diff --git a/3rdparty/curl-8.21.0/projects/vms/report_openssl_version.c b/3rdparty/curl-8.21.0/projects/vms/report_openssl_version.c new file mode 100644 index 0000000000..d2b0d367bc --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/report_openssl_version.c @@ -0,0 +1,98 @@ +/* File: report_openssl_version.c + * + * This file dynamically loads the OpenSSL shared image to report the + * version string. + * + * It will optionally place that version string in a DCL symbol. + * + * Usage: report_openssl_version [] + * + * Copyright (C) John Malmberg + * + * Permission to use, copy, modify, and/or distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT + * OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + * + * SPDX-License-Identifier: ISC + * + */ + +#include +#include +#include + +#include +#include +#include +#include +#include + +unsigned long LIB$SET_SYMBOL(const struct dsc$descriptor_s *symbol, + const struct dsc$descriptor_s *value, + const unsigned long *table_type); + +int main(int argc, char **argv) +{ + void *libptr; + const char *(*ssl_version)(int t); + const char *version; + + if(argc < 1) { + puts("report_openssl_version filename"); + return 1; + } + + libptr = dlopen(argv[1], 0); + + ssl_version = (const char *(*)(int))dlsym(libptr, "SSLeay_version"); + if(!ssl_version) { + ssl_version = (const char *(*)(int))dlsym(libptr, "ssleay_version"); + if(!ssl_version) { + ssl_version = (const char *(*)(int))dlsym(libptr, "SSLEAY_VERSION"); + } + } + + dlclose(libptr); + + if(!ssl_version) { + puts("Unable to lookup version of OpenSSL"); + return 1; + } + + version = ssl_version(SSLEAY_VERSION); + + puts(version); + + /* Was a symbol argument given? */ + if(argc > 1) { + int status; + struct dsc$descriptor_s symbol_dsc; + struct dsc$descriptor_s value_dsc; + const unsigned long table_type = LIB$K_CLI_LOCAL_SYM; + + symbol_dsc.dsc$a_pointer = argv[2]; + symbol_dsc.dsc$w_length = strlen(argv[2]); + symbol_dsc.dsc$b_dtype = DSC$K_DTYPE_T; + symbol_dsc.dsc$b_class = DSC$K_CLASS_S; + + value_dsc.dsc$a_pointer = (char *)version; /* Cast ok */ + value_dsc.dsc$w_length = strlen(version); + value_dsc.dsc$b_dtype = DSC$K_DTYPE_T; + value_dsc.dsc$b_class = DSC$K_CLASS_S; + + status = LIB$SET_SYMBOL(&symbol_dsc, &value_dsc, &table_type); + if(!$VMS_STATUS_SUCCESS(status)) { + return status; + } + } + + return 0; +} diff --git a/3rdparty/curl-8.21.0/projects/vms/setup_gnv_curl_build.com b/3rdparty/curl-8.21.0/projects/vms/setup_gnv_curl_build.com new file mode 100644 index 0000000000..b7aa5ec379 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/setup_gnv_curl_build.com @@ -0,0 +1,286 @@ +$! File: setup_gnv_curl_build.com +$! +$! Set up build environment for building curl under GNV on VMS. +$! +$! GNV needs some files moved into the other directories to help with +$! the configure script and the build. +$! +$! Copyright (C) John Malmberg +$! +$! Permission to use, copy, modify, and/or distribute this software for any +$! purpose with or without fee is hereby granted, provided that the above +$! copyright notice and this permission notice appear in all copies. +$! +$! THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +$! WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +$! MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +$! ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +$! WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +$! ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT +$! OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +$! +$! SPDX-License-Identifier: ISC +$! +$!======================================================================= +$! +$! Save this so we can get back. +$ default_dir = f$environment("default") +$! +$! Move to where the Configure script is. +$ set def [--] +$! +$! Get the path to where the Configure script is. +$ base_dir = f$environment("default") +$! +$! Allow arguments to be grouped together with comma or separated by spaces +$! Do no know if we will need more than 8. +$ args = "," + p1 + "," + p2 + "," + p3 + "," + p4 + "," +$ args = args + p5 + "," + p6 + "," + p7 + "," + p8 + "," +$! +$! Provide lower case version to simplify parsing. +$ args_lower = f$edit(args, "LOWERCASE,COLLAPSE") +$! +$ args_len = f$length(args) +$ args_lower_len = f$length(args_lower) +$! +$ tests = 0 +$ if f$locate(",test", args_lower) .lt. args_lower_len +$ then +$ tests = 1 +$ endif +$! +$ examples = 0 +$ if f$locate(",exam", args_lower) .lt. args_lower_len +$ then +$ examples = 1 +$ endif +$! +$! We want detailed build logs. +$ clist = "/list/show=(expan,includ)" +$! +$! We want full symbol names in exact case. Need a common +$! repository for all directories. +$ cnames = "/names=(shortened,as_is)/repository=''base_dir'" +$! +$! Set the compiler options for GNV CC wrapper to inherit. +$ cc :== cc'clist''cnames'/nested_include_directory=none +$ cxx :== cxx'clist''cnames'/nested_include_directory=none +$ pointer_size = "32" +$! Note 64-bit pointers requires all libraries to either have +$! 64-bit pointers or have #pragma directives. +$! Currently building curl on VMS with 64-bit pointers does not work. +$! +$! A logical name to make it easier to find some of the hacks. +$ define/job gnv_hacks 'base_dir' +$! +$! A logical name to find the [.projects.vms] directory where we started. +$ define/job gnv_packages_vms 'default_dir' +$! +$! Kerberos headers: +$ if f$trnlnm("gssapi") .eqs. "" +$ then +$ if f$search("sys$sysroot:[kerberos]include.dir") .nes. "" +$ then +$ define/job gssapi sys$sysroot:[kerberos.include] +$ endif +$ endif +$! +$! OpenSSL headers +$ if f$trnlnm("openssl") .eqs. "" +$ then +$ if f$trnlnm("ssl$include") .nes. "" +$ then +$ define/job openssl ssl$include: +$ endif +$ endif +$! +$! C compiler include path. +$ define/job decc$system_include prj_root:[.include.curl],- + [-.projects.vms],- + ssl$include:,gnv$gnu:[usr.include],- + gnv$gnu:[usr.include.libz],gnv$gnu:[include],- + gnv$zlib_include:,- + sys$sysroot:[kerberos.include] +$! +$! Set up an include list for the compiler to find all the header files +$! that they need. +$! +$ define/job decc$user_include src_root:[.include.curl] +$ define ssl_lib sys$library: +$! +$! Calculate what is needed in the option files +$ libzshr_line = "" +$ try_shr = "gnv$libzshr''pointer_size'" +$ if f$search(try_shr) .nes. "" then libzshr_line = "''try_shr'/share" +$ if (libzshr_line .eqs. "") +$ then +$ try_shr = "sys$share:" + try_shr +$ if f$search("''try_shr'.exe") .nes. "" +$ then +$ libzshr_line = "''try_shr'/share" +$ endif +$ endif +$! +$! Kerberos +$ gssrtlshr_line = "" +$ try_shr = "sys$share:gss$rtl" +$ if f$search("''try_shr'.exe") .nes. "" +$ then +$ gssrtlshr_line = "''try_shr'/share" +$ endif +$! +$! HP OpenSSL +$ libcryptoshr_line = "" +$ try_shr = "sys$share:ssl$libcrypto_shr''pointer_size'" +$ if f$search("''try_shr'.exe") .nes. "" +$ then +$ libcryptoshr_line = "''try_shr'/share" +$ endif +$! +$ libsslshr_line = "" +$ try_shr = "sys$share:ssl$libssl_shr''pointer_size'" +$ if f$search("''try_shr'.exe") .nes. "" +$ then +$ libsslshr_line = "''try_shr'/share" +$ endif +$! +$! +$! Copy over the gnv$conftest* files to base directory. +$!----------------------------------------------------- +$ copy 'default_dir'gnv_conftest.c_first 'base_dir'gnv$conftest.c_first +$ create 'base_dir'gnv$conftest.opt +$ open/append opt 'base_dir'gnv$conftest.opt +$ if libzshr_line .nes. "" then write opt libzshr_line +$ if libcryptoshr_line .nes. "" then write opt libcryptoshr_line +$ if libsslshr_line .nes. "" then write opt libsslshr_line +$ close opt +$ purge 'base_dir'gnv$conftest.* +$ rename 'base_dir'gnv$conftest.* ;1 +$! +$! +$! +$! GNV helper files for building the test curl binary. +$!----------------------------------------------- +$ create [.src]gnv$curl.opt +$ open/append opt [.src]gnv$curl.opt +$ write opt "gnv_packages_vms:curlmsg.obj" +$ if libzshr_line .nes. "" then write opt libzshr_line +$ if gssrtlshr_line .nes. "" then write opt gssrtlshr_line +$ if libcryptoshr_line .nes. "" then write opt libcryptoshr_line +$ if libsslshr_line .nes. "" then write opt libsslshr_line +$ close opt +$ purge [.src]gnv$*.* +$ rename [.src]gnv$*.* ;1 +$! +$! +$! Create the libcurl +$!------------------------------------------------------ +$ create 'default_dir'gnv_libcurl_linker.opt +$ open/append opt 'default_dir'gnv_libcurl_linker.opt +$ if libzshr_line .nes. "" then write opt libzshr_line +$ if gssrtlshr_line .nes. "" then write opt gssrtlshr_line +$ if libcryptoshr_line .nes. "" then write opt libcryptoshr_line +$ if libsslshr_line .nes. "" then write opt libsslshr_line +$ close opt +$! +$! +$! Create the template linker file +$!--------------------------------- +$ create 'default_dir'gnv_template_linker.opt +$ open/append opt 'default_dir'gnv_template_linker.opt +$ write opt "gnv_vms_common:vms_curl_init_unix.obj" +$ if libzshr_line .nes. "" then write opt libzshr_line +$ if gssrtlshr_line .nes. "" then write opt gssrtlshr_line +$ if libcryptoshr_line .nes. "" then write opt libcryptoshr_line +$ if libsslshr_line .nes. "" then write opt libsslshr_line +$ close opt +$! +$! Copy over the gnv$*.opt files for [.docs.examples] +$!---------------------------------------------------- +$ if examples .ne. 0 +$ then +$ example_apps = "10-at-a-time,anyauthput,certinfo,cookie_interface,debug" +$ example_apps = example_apps + ",fileupload,fopen,ftpget,ftpgetresp" +$ example_apps = example_apps + ",ftpupload,getinfo,getinmemory" +$ example_apps = example_apps + ",http-post,httpcustomheader,httpput" +$ example_apps = example_apps + ",https,multi-app,multi-debugcallback" +$ example_apps = example_apps + ",multi-double,multi-post,multi-single" +$ example_apps = example_apps + ",persistent,post-callback,postit2" +$ example_apps = example_apps + ",sendrecv,sepheaders,simple,simplepost" +$ example_apps = example_apps + ",simplessl" +$! +$ i = 0 +$example_loop: +$ ap_name = f$element(i, ",", example_apps) +$ if ap_name .eqs. "," then goto example_loop_end +$ if ap_name .eqs. "" then goto example_loop_end +$ copy 'default_dir'gnv_template_linker.opt - + [.docs.examples]gnv$'ap_name'.opt +$ i = i + 1 +$ goto example_loop +$example_loop_end: +$! +$! clean up the copy. +$ purge [.docs.examples]gnv$*.opt +$ rename [.docs.examples]gnv$*.opt ;1 +$ endif +$! +$! +$ if tests .ne. 0 +$ then +$ libtest_apps = "lib500,lib501,lib502,lib503,lib504,lib505,lib506,lib507" +$ libtest_apps = libtest_apps + ",lib508,lib510,lib511,lib512,lib513,lib514" +$ libtest_apps = libtest_apps + ",lib515,lib516,lib517,lib518,lib519,lib520" +$ libtest_apps = libtest_apps + ",lib521,lib523,lib524,lib525,lib526,lib527" +$ libtest_apps = libtest_apps + ",lib529,lib530,lib532,lib533,lib536,lib537" +$ libtest_apps = libtest_apps + ",lib539,lib540,lib541,lib542,lib543,lib544" +$ libtest_apps = libtest_apps + ",lib545,lib547,lib548,lib549,lib552,lib553" +$ libtest_apps = libtest_apps + ",lib554,lib555,lib556,lib557,lib558,lib559" +$ libtest_apps = libtest_apps + ",lib560,lib562,lib564" +$ i = 0 +$libtest_loop: +$ ap_name = f$element(i, ",", libtest_apps) +$ if ap_name .eqs. "," then goto libtest_loop_end +$ if ap_name .eqs. "" then goto libtest_loop_end +$ copy 'default_dir'gnv_template_linker.opt - + [.tests.libtest]gnv$'ap_name'.opt +$ i = i + 1 +$ goto libtest_loop +$libtest_loop_end: +$! +$! clean up the copy. +$ purge [.tests.libtest]gnv$*.opt +$ rename [.tests.libtest]gnv$*.opt ;1 +$ endif +$! +$! +$! Build the Message file. +$!-------------------------- +$ if f$search("[.projects.vms]curlmsg.obj") .eqs. "" +$ then +$ message [.projects.vms]curlmsg.msg/object=[.projects.vms] +$ endif +$ if f$search("gnv$curlmsg.exe") .eqs. "" +$ then +$ link/share=gnv$curlmsg.exe [.projects.vms]curlmsg.obj +$ endif +$! +$! +$! +$! Need to build the common init module. +$!------------------------------------------- +$ init_obj = "[.projects.vms]curl_crtl_init.obj" +$ if f$search(init_obj) .eqs. "" +$ then +$ cc'cflags' 'default_dir'curl_crtl_init.c/obj='init_obj' +$ purge 'init_obj' +$ rename 'init_obj' ;1 +$ endif +$! +$all_exit: +$! +$ set def 'default_dir' +$! +$! Verify can break things in bash, especially in Configure scripts. +$ set nover +$ exit diff --git a/3rdparty/curl-8.21.0/projects/vms/stage_curl_install.com b/3rdparty/curl-8.21.0/projects/vms/stage_curl_install.com new file mode 100644 index 0000000000..48f6514e5f --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/stage_curl_install.com @@ -0,0 +1,170 @@ +$! File: stage_curl_install.com +$! +$! This updates or removes the GNV$CURL.EXE and related files for the +$! new_gnu:[*...] directory tree for running the self tests. +$! +$! The files installed/removed are: +$! [usr.bin]gnv$curl.exe +$! [usr.bin]curl-config. +$! [usr.lib]gnv$libcurl.exe +$! [usr.bin]curl. hard link for [usr.bin]gnv$curl.exe +$! [usr.include.curl]curl.h +$! [usr.include.curl]curlver.h +$! [usr.include.curl]easy.h +$! [usr.include.curl]mprintf.h +$! [usr.include.curl]multi.h +$! [usr.include.curl]stdcheaders.h +$! [usr.include.curl]typecheck-gcc.h +$! [usr.lib.pkgconfig]libcurl.pc +$! [usr.share.man.man1]curl-config.1 +$! [usr.share.man.man1]curl.1 +$! [usr.share.man.man3]curl*.3 +$! [usr.share.man.man3]libcurl*.3 +$! Future: A symbolic link to the release notes? +$! +$! Copyright (C) John Malmberg +$! +$! Permission to use, copy, modify, and/or distribute this software for any +$! purpose with or without fee is hereby granted, provided that the above +$! copyright notice and this permission notice appear in all copies. +$! +$! THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +$! WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +$! MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +$! ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +$! WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +$! ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT +$! OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +$! +$! SPDX-License-Identifier: ISC +$! +$!=========================================================================== +$! +$ arch_type = f$getsyi("ARCH_NAME") +$ arch_code = f$extract(0, 1, arch_type) +$! +$ if arch_code .nes. "V" +$ then +$ set proc/parse=extended +$ endif +$! +$! +$! If the first parameter begins with "r" or "R" then this is to +$! remove the files instead of installing them. +$ remove_filesq = f$edit(p1, "upcase,trim") +$ remove_filesq = f$extract(0, 1, remove_filesq) +$ remove_files = 0 +$ if remove_filesq .eqs. "R" then remove_files = 1 +$! +$! +$! If we are staging files, make sure that the libcurl.pc and curl-config +$! files are present. +$ if remove_files .eq. 0 +$ then +$ if f$search("[--]libcurl.pc") .eqs. "" +$ then +$ @build_libcurl_pc.com +$ endif +$ if f$search("[--]curl-config") .eqs. "" +$ then +$ @build_curl-config_script.com +$ endif +$ endif +$! +$! +$! Dest dirs +$!------------------ +$ dest_dirs1 = "[usr],[usr.bin],[usr.include],[usr.include.curl]" +$ dest_dirs2 = ",[usr.bin],[usr.lib.pkgconfig],[usr.share]" +$ dest_dirs3 = ",[usr.share.man],[usr.share.man.man1],[usr.share.man.man3]" +$ dest_dirs = dest_dirs1 + dest_dirs2 + dest_dirs3 +$! +$! +$! Alias links needed. +$!------------------------- +$ source_curl = "gnv$curl.exe" +$ dest_curl = "[bin]gnv$curl.exe" +$ curl_links = "[bin]curl." +$ new_gnu = "new_gnu:" +$! +$! +$! Create the directories if they do not exist +$!--------------------------------------------- +$ i = 0 +$curl_dir_loop: +$ this_dir = f$element(i, ",", dest_dirs) +$ i = i + 1 +$ if this_dir .eqs. "" then goto curl_dir_loop +$ if this_dir .eqs. "," then goto curl_dir_loop_end +$! Create the directories, do not delete them. +$! -------------------------------------------------- +$ if remove_files .eq. 0 +$ then +$ create/dir 'new_gnu''this_dir'/prot=(o:rwed) +$ endif +$ goto curl_dir_loop +$curl_dir_loop_end: +$! +$! +$! Need to add in the executable file +$!----------------------------------- +$ if remove_files .eq. 0 +$ then +$ copy [--.src]curl.exe 'new_gnu'[usr.bin]gnv$curl.exe/prot=w:re +$ copy [--]curl-config. 'new_gnu'[usr.bin]curl-config./prot=w:re +$ copy sys$disk:[]gnv$libcurl.exe 'new_gnu'[usr.lib]gnv$libcurl.exe/prot=w:re +$ endif +$! +$ if remove_files .eq. 0 +$ then +$ set file/enter='new_gnu'[bin]curl. 'new_gnu'[usr.bin]gnv$curl.exe +$ else +$ file = "''new_gnu'[bin]curl." +$ if f$search(file) .nes. "" then set file/remove 'file';* +$ endif +$! +$! +$ if remove_files .eq. 0 +$ then +$ copy [--.include.curl]curl.h 'new_gnu'[usr.include.curl]curl.h +$ copy [--.include.curl]system.h - + 'new_gnu'[usr.include.curl]system.h +$ copy [--.include.curl]curlver.h - + 'new_gnu'[usr.include.curl]curlver.h +$ copy [--.include.curl]easy.h - + 'new_gnu'[usr.include.curl]easy.h +$ copy [--.include.curl]mprintf.h - + 'new_gnu'[usr.include.curl]mprintf.h +$ copy [--.include.curl]multi.h - + 'new_gnu'[usr.include.curl]multi.h +$ copy [--.include.curl]stdcheaders.h - + 'new_gnu'[usr.include.curl]stdcheaders.h +$ copy [--.include.curl]typecheck-gcc.h - + 'new_gnu'[usr.include.curl]typecheck-gcc.h +$ copy [--]libcurl.pc 'new_gnu'[usr.lib.pkgconfig]libcurl.pc +$! +$ copy [--.docs]curl-config.1 'new_gnu'[usr.share.man.man1]curl-config.1 +$ copy [--.docs]curl.1 'new_gnu'[usr.share.man.man1]curl.1 +$! +$ copy [--.docs.libcurl]*.3 - + 'new_gnu'[usr.share.man.man3]*.3 +$! +$ else +$ file = "''new_gnu'[usr.bin]curl-config." +$ if f$search(file) .nes. "" then delete 'file';* +$ file = "''new_gnu'[usr.bin]gnv$curl.exe" +$ if f$search(file) .nes. "" then delete 'file';* +$ file = "''new_gnu'[usr.lib]gnv$libcurl.exe" +$ if f$search(file) .nes. "" then delete 'file';* +$ file = "''new_gnu'[usr.include.curl]*.h" +$ if f$search(file) .nes. "" then delete 'file';* +$ file = "''new_gnu'[usr.share.man.man1]curl-config.1" +$ if f$search(file) .nes. "" then delete 'file';* +$ file = "''new_gnu'[usr.share.man.man1]curl.1" +$ if f$search(file) .nes. "" then delete 'file';* +$ file = "''new_gnu'[usr.share.man.man3]curl*.3" +$ if f$search(file) .nes. "" then delete 'file';* +$ file = "''new_gnu'[usr.share.man.man3]libcurl*.3" +$ if f$search(file) .nes. "" then delete 'file';* +$ endif +$! diff --git a/3rdparty/curl-8.21.0/projects/vms/vms_eco_level.h b/3rdparty/curl-8.21.0/projects/vms/vms_eco_level.h new file mode 100644 index 0000000000..89f1dfd628 --- /dev/null +++ b/3rdparty/curl-8.21.0/projects/vms/vms_eco_level.h @@ -0,0 +1,30 @@ +/* File: vms_eco_level.h + * + * Copyright (C) John Malmberg + * + * Permission to use, copy, modify, and/or distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT + * OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + * + * SPDX-License-Identifier: ISC + * + */ + +/* This file should be incremented for each ECO that is kit */ +/* for a specific curl x.y-z release. */ +/* When any part of x.y-z is incremented, the ECO should be set back to 0 */ + +#ifndef _VMS_ECO_LEVEL_H +#define _VMS_ECO_LEVEL_H + +#define VMS_ECO_LEVEL "0" + +#endif diff --git a/3rdparty/curl-8.21.0/scripts/.checksrc b/3rdparty/curl-8.21.0/scripts/.checksrc new file mode 100644 index 0000000000..03e98fee89 --- /dev/null +++ b/3rdparty/curl-8.21.0/scripts/.checksrc @@ -0,0 +1,5 @@ +# Copyright (C) Daniel Stenberg, , et al. +# +# SPDX-License-Identifier: curl + +allowfunc printf diff --git a/3rdparty/curl-8.21.0/scripts/CMakeLists.txt b/3rdparty/curl-8.21.0/scripts/CMakeLists.txt new file mode 100644 index 0000000000..1dea27f63a --- /dev/null +++ b/3rdparty/curl-8.21.0/scripts/CMakeLists.txt @@ -0,0 +1,80 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Viktor Szakats, et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### + +if(BUILD_CURL_EXE) + option(CURL_COMPLETION_FISH "Install fish completions" OFF) + option(CURL_COMPLETION_ZSH "Install zsh completions" OFF) + + if(CURL_COMPLETION_FISH OR + CURL_COMPLETION_ZSH) + if(Perl_FOUND) + if(CURL_COMPLETION_FISH) + set(_completion_fish "${CMAKE_CURRENT_BINARY_DIR}/curl.fish") + add_custom_command(OUTPUT "${_completion_fish}" + COMMAND "${PERL_EXECUTABLE}" "${CMAKE_CURRENT_SOURCE_DIR}/completion.pl" + --opts-dir "${PROJECT_SOURCE_DIR}/docs/cmdline-opts" --shell fish > "${_completion_fish}" + DEPENDS "${CMAKE_CURRENT_SOURCE_DIR}/completion.pl" + VERBATIM + ) + add_custom_target("curl-completion-fish" ALL DEPENDS "${_completion_fish}") + endif() + + if(CURL_COMPLETION_ZSH) + set(_completion_zsh "${CMAKE_CURRENT_BINARY_DIR}/_curl") + add_custom_command(OUTPUT "${_completion_zsh}" + COMMAND "${PERL_EXECUTABLE}" "${CMAKE_CURRENT_SOURCE_DIR}/completion.pl" + --opts-dir "${PROJECT_SOURCE_DIR}/docs/cmdline-opts" --shell zsh > "${_completion_zsh}" + DEPENDS "${CMAKE_CURRENT_SOURCE_DIR}/completion.pl" + VERBATIM + ) + add_custom_target("curl-completion-zsh" ALL DEPENDS "${_completion_zsh}") + endif() + + if(NOT CURL_DISABLE_INSTALL) + if(CURL_COMPLETION_FISH) + if(NOT CURL_COMPLETION_FISH_DIR AND NOT CMAKE_CROSSCOMPILING AND NOT DEFINED CMAKE_INSTALL_PREFIX) + find_package(PkgConfig QUIET) + pkg_get_variable(CURL_COMPLETION_FISH_DIR "fish" "completionsdir") + endif() + if(NOT CURL_COMPLETION_FISH_DIR AND CMAKE_INSTALL_DATAROOTDIR) + set(CURL_COMPLETION_FISH_DIR "${CMAKE_INSTALL_DATAROOTDIR}/fish/vendor_completions.d") + endif() + if(CURL_COMPLETION_FISH_DIR) + install(FILES "${_completion_fish}" DESTINATION "${CURL_COMPLETION_FISH_DIR}") + endif() + endif() + if(CURL_COMPLETION_ZSH) + if(NOT CURL_COMPLETION_ZSH_DIR AND CMAKE_INSTALL_DATAROOTDIR) + set(CURL_COMPLETION_ZSH_DIR "${CMAKE_INSTALL_DATAROOTDIR}/zsh/site-functions") + endif() + if(CURL_COMPLETION_ZSH_DIR) + install(FILES "${_completion_zsh}" DESTINATION "${CURL_COMPLETION_ZSH_DIR}") + endif() + endif() + endif() + else() + message(WARNING "Perl not found. Cannot generate completion scripts.") + endif() + endif() +endif() diff --git a/3rdparty/curl-8.21.0/scripts/Makefile.am b/3rdparty/curl-8.21.0/scripts/Makefile.am new file mode 100644 index 0000000000..7ffa98ed9b --- /dev/null +++ b/3rdparty/curl-8.21.0/scripts/Makefile.am @@ -0,0 +1,66 @@ +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### + +EXTRA_DIST = coverage.sh completion.pl firefox-db2pem.sh checksrc.pl \ + checksrc-all.pl mk-ca-bundle.pl mk-unity.pl schemetable.c cd2nroff nroff2cd \ + cdall cd2cd managen dmaketgz maketgz release-tools.sh verify-release \ + cmakelint.sh mdlinkcheck CMakeLists.txt perlcheck.sh pythonlint.sh \ + spacecheck.pl randdisable wcurl top-complexity extract-unit-protos \ + .checksrc badwords badwords-all badwords.txt top-length + +dist_bin_SCRIPTS = wcurl + +if USE_ZSH_COMPLETION +ZSH_COMPLETION_FUNCTION_FILENAME = _curl +endif +if USE_FISH_COMPLETION +FISH_COMPLETION_FUNCTION_FILENAME = curl.fish +endif + +CLEANFILES = $(ZSH_COMPLETION_FUNCTION_FILENAME) $(FISH_COMPLETION_FUNCTION_FILENAME) + +all-local: $(ZSH_COMPLETION_FUNCTION_FILENAME) $(FISH_COMPLETION_FUNCTION_FILENAME) + +if USE_ZSH_COMPLETION +$(ZSH_COMPLETION_FUNCTION_FILENAME): completion.pl + @PERL@ $(srcdir)/completion.pl --opts-dir $(top_srcdir)/docs/cmdline-opts --shell zsh > $@ +endif + +if USE_FISH_COMPLETION +$(FISH_COMPLETION_FUNCTION_FILENAME): completion.pl + @PERL@ $(srcdir)/completion.pl --opts-dir $(top_srcdir)/docs/cmdline-opts --shell fish > $@ +endif + +install-data-local: +if USE_ZSH_COMPLETION + $(MKDIR_P) $(DESTDIR)@ZSH_FUNCTIONS_DIR@ + $(INSTALL_DATA) $(ZSH_COMPLETION_FUNCTION_FILENAME) $(DESTDIR)@ZSH_FUNCTIONS_DIR@/$(ZSH_COMPLETION_FUNCTION_FILENAME) +endif +if USE_FISH_COMPLETION + $(MKDIR_P) $(DESTDIR)@FISH_FUNCTIONS_DIR@ + $(INSTALL_DATA) $(FISH_COMPLETION_FUNCTION_FILENAME) $(DESTDIR)@FISH_FUNCTIONS_DIR@/$(FISH_COMPLETION_FUNCTION_FILENAME) +endif + +distclean: + rm -f $(CLEANFILES) diff --git a/3rdparty/curl-8.21.0/scripts/Makefile.in b/3rdparty/curl-8.21.0/scripts/Makefile.in new file mode 100644 index 0000000000..fe7e83d55e --- /dev/null +++ b/3rdparty/curl-8.21.0/scripts/Makefile.in @@ -0,0 +1,630 @@ +# Makefile.in generated by automake 1.16.5 from Makefile.am. +# @configure_input@ + +# Copyright (C) 1994-2021 Free Software Foundation, Inc. + +# This Makefile.in is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY, to the extent permitted by law; without +# even the implied warranty of MERCHANTABILITY or FITNESS FOR A +# PARTICULAR PURPOSE. + +@SET_MAKE@ + +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### + +VPATH = @srcdir@ +am__is_gnu_make = { \ + if test -z '$(MAKELEVEL)'; then \ + false; \ + elif test -n '$(MAKE_HOST)'; then \ + true; \ + elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \ + true; \ + else \ + false; \ + fi; \ +} +am__make_running_with_option = \ + case $${target_option-} in \ + ?) ;; \ + *) echo "am__make_running_with_option: internal error: invalid" \ + "target option '$${target_option-}' specified" >&2; \ + exit 1;; \ + esac; \ + has_opt=no; \ + sane_makeflags=$$MAKEFLAGS; \ + if $(am__is_gnu_make); then \ + sane_makeflags=$$MFLAGS; \ + else \ + case $$MAKEFLAGS in \ + *\\[\ \ ]*) \ + bs=\\; \ + sane_makeflags=`printf '%s\n' "$$MAKEFLAGS" \ + | sed "s/$$bs$$bs[$$bs $$bs ]*//g"`;; \ + esac; \ + fi; \ + skip_next=no; \ + strip_trailopt () \ + { \ + flg=`printf '%s\n' "$$flg" | sed "s/$$1.*$$//"`; \ + }; \ + for flg in $$sane_makeflags; do \ + test $$skip_next = yes && { skip_next=no; continue; }; \ + case $$flg in \ + *=*|--*) continue;; \ + -*I) strip_trailopt 'I'; skip_next=yes;; \ + -*I?*) strip_trailopt 'I';; \ + -*O) strip_trailopt 'O'; skip_next=yes;; \ + -*O?*) strip_trailopt 'O';; \ + -*l) strip_trailopt 'l'; skip_next=yes;; \ + -*l?*) strip_trailopt 'l';; \ + -[dEDm]) skip_next=yes;; \ + -[JT]) skip_next=yes;; \ + esac; \ + case $$flg in \ + *$$target_option*) has_opt=yes; break;; \ + esac; \ + done; \ + test $$has_opt = yes +am__make_dryrun = (target_option=n; $(am__make_running_with_option)) +am__make_keepgoing = (target_option=k; $(am__make_running_with_option)) +pkgdatadir = $(datadir)/@PACKAGE@ +pkgincludedir = $(includedir)/@PACKAGE@ +pkglibdir = $(libdir)/@PACKAGE@ +pkglibexecdir = $(libexecdir)/@PACKAGE@ +am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd +install_sh_DATA = $(install_sh) -c -m 644 +install_sh_PROGRAM = $(install_sh) -c +install_sh_SCRIPT = $(install_sh) -c +INSTALL_HEADER = $(INSTALL_DATA) +transform = $(program_transform_name) +NORMAL_INSTALL = : +PRE_INSTALL = : +POST_INSTALL = : +NORMAL_UNINSTALL = : +PRE_UNINSTALL = : +POST_UNINSTALL = : +build_triplet = @build@ +host_triplet = @host@ +subdir = scripts +ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 +am__aclocal_m4_deps = $(top_srcdir)/m4/curl-amissl.m4 \ + $(top_srcdir)/m4/curl-apple-sectrust.m4 \ + $(top_srcdir)/m4/curl-compilers.m4 \ + $(top_srcdir)/m4/curl-confopts.m4 \ + $(top_srcdir)/m4/curl-functions.m4 \ + $(top_srcdir)/m4/curl-gnutls.m4 \ + $(top_srcdir)/m4/curl-mbedtls.m4 \ + $(top_srcdir)/m4/curl-openssl.m4 \ + $(top_srcdir)/m4/curl-override.m4 \ + $(top_srcdir)/m4/curl-reentrant.m4 \ + $(top_srcdir)/m4/curl-rustls.m4 \ + $(top_srcdir)/m4/curl-schannel.m4 \ + $(top_srcdir)/m4/curl-sysconfig.m4 \ + $(top_srcdir)/m4/curl-wolfssl.m4 $(top_srcdir)/m4/libtool.m4 \ + $(top_srcdir)/m4/ltoptions.m4 $(top_srcdir)/m4/ltsugar.m4 \ + $(top_srcdir)/m4/ltversion.m4 $(top_srcdir)/m4/lt~obsolete.m4 \ + $(top_srcdir)/m4/xc-am-iface.m4 \ + $(top_srcdir)/m4/xc-cc-check.m4 \ + $(top_srcdir)/m4/xc-lt-iface.m4 \ + $(top_srcdir)/m4/xc-val-flgs.m4 \ + $(top_srcdir)/m4/zz40-xc-ovr.m4 \ + $(top_srcdir)/m4/zz50-xc-ovr.m4 $(top_srcdir)/acinclude.m4 \ + $(top_srcdir)/configure.ac +am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ + $(ACLOCAL_M4) +DIST_COMMON = $(srcdir)/Makefile.am $(dist_bin_SCRIPTS) \ + $(am__DIST_COMMON) +mkinstalldirs = $(install_sh) -d +CONFIG_HEADER = $(top_builddir)/lib/curl_config.h +CONFIG_CLEAN_FILES = +CONFIG_CLEAN_VPATH_FILES = +am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; +am__vpath_adj = case $$p in \ + $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \ + *) f=$$p;; \ + esac; +am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`; +am__install_max = 40 +am__nobase_strip_setup = \ + srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'` +am__nobase_strip = \ + for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||" +am__nobase_list = $(am__nobase_strip_setup); \ + for p in $$list; do echo "$$p $$p"; done | \ + sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \ + $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \ + if (++n[$$2] == $(am__install_max)) \ + { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \ + END { for (dir in files) print dir, files[dir] }' +am__base_list = \ + sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \ + sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g' +am__uninstall_files_from_dir = { \ + test -z "$$files" \ + || { test ! -d "$$dir" && test ! -f "$$dir" && test ! -r "$$dir"; } \ + || { echo " ( cd '$$dir' && rm -f" $$files ")"; \ + $(am__cd) "$$dir" && rm -f $$files; }; \ + } +am__installdirs = "$(DESTDIR)$(bindir)" +SCRIPTS = $(dist_bin_SCRIPTS) +AM_V_P = $(am__v_P_@AM_V@) +am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) +am__v_P_0 = false +am__v_P_1 = : +AM_V_GEN = $(am__v_GEN_@AM_V@) +am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@) +am__v_GEN_0 = @echo " GEN " $@; +am__v_GEN_1 = +AM_V_at = $(am__v_at_@AM_V@) +am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) +am__v_at_0 = @ +am__v_at_1 = +SOURCES = +DIST_SOURCES = +am__can_run_installinfo = \ + case $$AM_UPDATE_INFO_DIR in \ + n|no|NO) false;; \ + *) (install-info --version) >/dev/null 2>&1;; \ + esac +am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) $(LISP) +am__DIST_COMMON = $(srcdir)/Makefile.in +DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) +ACLOCAL = @ACLOCAL@ +AMTAR = @AMTAR@ +AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ +APXS = @APXS@ +AR = @AR@ +AR_FLAGS = @AR_FLAGS@ +AS = @AS@ +AUTOCONF = @AUTOCONF@ +AUTOHEADER = @AUTOHEADER@ +AUTOMAKE = @AUTOMAKE@ +AWK = @AWK@ +BLANK_AT_MAKETIME = @BLANK_AT_MAKETIME@ +CADDY = @CADDY@ +CC = @CC@ +CCDEPMODE = @CCDEPMODE@ +CFLAGS = @CFLAGS@ +CFLAG_CURL_SYMBOL_HIDING = @CFLAG_CURL_SYMBOL_HIDING@ +CLANG_TIDY = @CLANG_TIDY@ +CONFIGURE_OPTIONS = @CONFIGURE_OPTIONS@ +CPP = @CPP@ +CPPFLAGS = @CPPFLAGS@ +CSCOPE = @CSCOPE@ +CTAGS = @CTAGS@ +CURLVERSION = @CURLVERSION@ +CURL_CA_BUNDLE = @CURL_CA_BUNDLE@ +CURL_CA_EMBED = @CURL_CA_EMBED@ +CURL_CFLAG_EXTRAS = @CURL_CFLAG_EXTRAS@ +CURL_CPP = @CURL_CPP@ +CURL_LIBCURL_VERSIONED_SYMBOLS_PREFIX = @CURL_LIBCURL_VERSIONED_SYMBOLS_PREFIX@ +CURL_LIBCURL_VERSIONED_SYMBOLS_SONAME = @CURL_LIBCURL_VERSIONED_SYMBOLS_SONAME@ +CURL_NETWORK_AND_TIME_LIBS = @CURL_NETWORK_AND_TIME_LIBS@ +CYGPATH_W = @CYGPATH_W@ +DANTED = @DANTED@ +DEFS = @DEFS@ +DEPDIR = @DEPDIR@ +DLLTOOL = @DLLTOOL@ +DSYMUTIL = @DSYMUTIL@ +DUMPBIN = @DUMPBIN@ +ECHO_C = @ECHO_C@ +ECHO_N = @ECHO_N@ +ECHO_T = @ECHO_T@ +EGREP = @EGREP@ +ENABLE_SHARED = @ENABLE_SHARED@ +ENABLE_STATIC = @ENABLE_STATIC@ +ETAGS = @ETAGS@ +EXEEXT = @EXEEXT@ +FGREP = @FGREP@ +FILECMD = @FILECMD@ +FISH_FUNCTIONS_DIR = @FISH_FUNCTIONS_DIR@ +GCOV = @GCOV@ +GREP = @GREP@ +H2O = @H2O@ +HAVE_LIBZ = @HAVE_LIBZ@ +HTTPD = @HTTPD@ +HTTPD_NGHTTPX = @HTTPD_NGHTTPX@ +INSTALL = @INSTALL@ +INSTALL_DATA = @INSTALL_DATA@ +INSTALL_PROGRAM = @INSTALL_PROGRAM@ +INSTALL_SCRIPT = @INSTALL_SCRIPT@ +INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ +LCOV = @LCOV@ +LD = @LD@ +LDFLAGS = @LDFLAGS@ +LIBCURL_PC_CFLAGS = @LIBCURL_PC_CFLAGS@ +LIBCURL_PC_CFLAGS_PRIVATE = @LIBCURL_PC_CFLAGS_PRIVATE@ +LIBCURL_PC_LDFLAGS_PRIVATE = @LIBCURL_PC_LDFLAGS_PRIVATE@ +LIBCURL_PC_LIBS = @LIBCURL_PC_LIBS@ +LIBCURL_PC_LIBS_PRIVATE = @LIBCURL_PC_LIBS_PRIVATE@ +LIBCURL_PC_REQUIRES = @LIBCURL_PC_REQUIRES@ +LIBCURL_PC_REQUIRES_PRIVATE = @LIBCURL_PC_REQUIRES_PRIVATE@ +LIBOBJS = @LIBOBJS@ +LIBS = @LIBS@ +LIBTOOL = @LIBTOOL@ +LIPO = @LIPO@ +LN_S = @LN_S@ +LTLIBOBJS = @LTLIBOBJS@ +LT_SYS_LIBRARY_PATH = @LT_SYS_LIBRARY_PATH@ +MAINT = @MAINT@ +MAKEINFO = @MAKEINFO@ +MANIFEST_TOOL = @MANIFEST_TOOL@ +MKDIR_P = @MKDIR_P@ +NM = @NM@ +NMEDIT = @NMEDIT@ +OBJDUMP = @OBJDUMP@ +OBJEXT = @OBJEXT@ +OTOOL = @OTOOL@ +OTOOL64 = @OTOOL64@ +PACKAGE = @PACKAGE@ +PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ +PACKAGE_NAME = @PACKAGE_NAME@ +PACKAGE_STRING = @PACKAGE_STRING@ +PACKAGE_TARNAME = @PACKAGE_TARNAME@ +PACKAGE_URL = @PACKAGE_URL@ +PACKAGE_VERSION = @PACKAGE_VERSION@ +PATH_SEPARATOR = @PATH_SEPARATOR@ +PERL = @PERL@ +PKGCONFIG = @PKGCONFIG@ +RANLIB = @RANLIB@ +RC = @RC@ +SED = @SED@ +SET_MAKE = @SET_MAKE@ +SFTPD = @SFTPD@ +SHELL = @SHELL@ +SSHD = @SSHD@ +SSL_BACKENDS = @SSL_BACKENDS@ +STRIP = @STRIP@ +SUPPORT_FEATURES = @SUPPORT_FEATURES@ +SUPPORT_PROTOCOLS = @SUPPORT_PROTOCOLS@ +TEST_NGHTTPX = @TEST_NGHTTPX@ +VERSION = @VERSION@ +VERSIONNUM = @VERSIONNUM@ +VSFTPD = @VSFTPD@ +ZLIB_LIBS = @ZLIB_LIBS@ +ZSH_FUNCTIONS_DIR = @ZSH_FUNCTIONS_DIR@ +abs_builddir = @abs_builddir@ +abs_srcdir = @abs_srcdir@ +abs_top_builddir = @abs_top_builddir@ +abs_top_srcdir = @abs_top_srcdir@ +ac_ct_AR = @ac_ct_AR@ +ac_ct_CC = @ac_ct_CC@ +ac_ct_DUMPBIN = @ac_ct_DUMPBIN@ +am__include = @am__include@ +am__leading_dot = @am__leading_dot@ +am__quote = @am__quote@ +am__tar = @am__tar@ +am__untar = @am__untar@ +bindir = @bindir@ +build = @build@ +build_alias = @build_alias@ +build_cpu = @build_cpu@ +build_os = @build_os@ +build_vendor = @build_vendor@ +builddir = @builddir@ +datadir = @datadir@ +datarootdir = @datarootdir@ +docdir = @docdir@ +dvidir = @dvidir@ +exec_prefix = @exec_prefix@ +host = @host@ +host_alias = @host_alias@ +host_cpu = @host_cpu@ +host_os = @host_os@ +host_vendor = @host_vendor@ +htmldir = @htmldir@ +includedir = @includedir@ +infodir = @infodir@ +install_sh = @install_sh@ +libdir = @libdir@ +libexecdir = @libexecdir@ +libext = @libext@ +localedir = @localedir@ +localstatedir = @localstatedir@ +mandir = @mandir@ +mkdir_p = @mkdir_p@ +oldincludedir = @oldincludedir@ +pdfdir = @pdfdir@ +prefix = @prefix@ +program_transform_name = @program_transform_name@ +psdir = @psdir@ +runstatedir = @runstatedir@ +sbindir = @sbindir@ +sharedstatedir = @sharedstatedir@ +srcdir = @srcdir@ +sysconfdir = @sysconfdir@ +target_alias = @target_alias@ +top_build_prefix = @top_build_prefix@ +top_builddir = @top_builddir@ +top_srcdir = @top_srcdir@ +EXTRA_DIST = coverage.sh completion.pl firefox-db2pem.sh checksrc.pl \ + checksrc-all.pl mk-ca-bundle.pl mk-unity.pl schemetable.c cd2nroff nroff2cd \ + cdall cd2cd managen dmaketgz maketgz release-tools.sh verify-release \ + cmakelint.sh mdlinkcheck CMakeLists.txt perlcheck.sh pythonlint.sh \ + spacecheck.pl randdisable wcurl top-complexity extract-unit-protos \ + .checksrc badwords badwords-all badwords.txt top-length + +dist_bin_SCRIPTS = wcurl +@USE_ZSH_COMPLETION_TRUE@ZSH_COMPLETION_FUNCTION_FILENAME = _curl +@USE_FISH_COMPLETION_TRUE@FISH_COMPLETION_FUNCTION_FILENAME = curl.fish +CLEANFILES = $(ZSH_COMPLETION_FUNCTION_FILENAME) $(FISH_COMPLETION_FUNCTION_FILENAME) +all: all-am + +.SUFFIXES: +$(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps) + @for dep in $?; do \ + case '$(am__configure_deps)' in \ + *$$dep*) \ + ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \ + && { if test -f $@; then exit 0; else break; fi; }; \ + exit 1;; \ + esac; \ + done; \ + echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu scripts/Makefile'; \ + $(am__cd) $(top_srcdir) && \ + $(AUTOMAKE) --gnu scripts/Makefile +Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status + @case '$?' in \ + *config.status*) \ + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ + *) \ + echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__maybe_remake_depfiles)'; \ + cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__maybe_remake_depfiles);; \ + esac; + +$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh + +$(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh +$(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh +$(am__aclocal_m4_deps): +install-dist_binSCRIPTS: $(dist_bin_SCRIPTS) + @$(NORMAL_INSTALL) + @list='$(dist_bin_SCRIPTS)'; test -n "$(bindir)" || list=; \ + if test -n "$$list"; then \ + echo " $(MKDIR_P) '$(DESTDIR)$(bindir)'"; \ + $(MKDIR_P) "$(DESTDIR)$(bindir)" || exit 1; \ + fi; \ + for p in $$list; do \ + if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ + if test -f "$$d$$p"; then echo "$$d$$p"; echo "$$p"; else :; fi; \ + done | \ + sed -e 'p;s,.*/,,;n' \ + -e 'h;s|.*|.|' \ + -e 'p;x;s,.*/,,;$(transform)' | sed 'N;N;N;s,\n, ,g' | \ + $(AWK) 'BEGIN { files["."] = ""; dirs["."] = 1; } \ + { d=$$3; if (dirs[d] != 1) { print "d", d; dirs[d] = 1 } \ + if ($$2 == $$4) { files[d] = files[d] " " $$1; \ + if (++n[d] == $(am__install_max)) { \ + print "f", d, files[d]; n[d] = 0; files[d] = "" } } \ + else { print "f", d "/" $$4, $$1 } } \ + END { for (d in files) print "f", d, files[d] }' | \ + while read type dir files; do \ + if test "$$dir" = .; then dir=; else dir=/$$dir; fi; \ + test -z "$$files" || { \ + echo " $(INSTALL_SCRIPT) $$files '$(DESTDIR)$(bindir)$$dir'"; \ + $(INSTALL_SCRIPT) $$files "$(DESTDIR)$(bindir)$$dir" || exit $$?; \ + } \ + ; done + +uninstall-dist_binSCRIPTS: + @$(NORMAL_UNINSTALL) + @list='$(dist_bin_SCRIPTS)'; test -n "$(bindir)" || exit 0; \ + files=`for p in $$list; do echo "$$p"; done | \ + sed -e 's,.*/,,;$(transform)'`; \ + dir='$(DESTDIR)$(bindir)'; $(am__uninstall_files_from_dir) + +mostlyclean-libtool: + -rm -f *.lo + +clean-libtool: + -rm -rf .libs _libs +tags TAGS: + +ctags CTAGS: + +cscope cscopelist: + +distdir: $(BUILT_SOURCES) + $(MAKE) $(AM_MAKEFLAGS) distdir-am + +distdir-am: $(DISTFILES) + @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ + topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ + list='$(DISTFILES)'; \ + dist_files=`for file in $$list; do echo $$file; done | \ + sed -e "s|^$$srcdirstrip/||;t" \ + -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ + case $$dist_files in \ + */*) $(MKDIR_P) `echo "$$dist_files" | \ + sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ + sort -u` ;; \ + esac; \ + for file in $$dist_files; do \ + if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ + if test -d $$d/$$file; then \ + dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ + if test -d "$(distdir)/$$file"; then \ + find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ + fi; \ + if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ + cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ + find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ + fi; \ + cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ + else \ + test -f "$(distdir)/$$file" \ + || cp -p $$d/$$file "$(distdir)/$$file" \ + || exit 1; \ + fi; \ + done +check-am: all-am +check: check-am +all-am: Makefile $(SCRIPTS) all-local +installdirs: + for dir in "$(DESTDIR)$(bindir)"; do \ + test -z "$$dir" || $(MKDIR_P) "$$dir"; \ + done +install: install-am +install-exec: install-exec-am +install-data: install-data-am +uninstall: uninstall-am + +install-am: all-am + @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am + +installcheck: installcheck-am +install-strip: + if test -z '$(STRIP)'; then \ + $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ + install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ + install; \ + else \ + $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ + install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ + "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \ + fi +mostlyclean-generic: + +clean-generic: + -test -z "$(CLEANFILES)" || rm -f $(CLEANFILES) + +distclean-generic: + -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) + -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) + +maintainer-clean-generic: + @echo "This command is intended for maintainers to use" + @echo "it deletes files that may require special tools to rebuild." +clean: clean-am + +clean-am: clean-generic clean-libtool mostlyclean-am + +distclean-am: clean-am distclean-generic + +dvi: dvi-am + +dvi-am: + +html: html-am + +html-am: + +info: info-am + +info-am: + +install-data-am: install-data-local + +install-dvi: install-dvi-am + +install-dvi-am: + +install-exec-am: install-dist_binSCRIPTS + +install-html: install-html-am + +install-html-am: + +install-info: install-info-am + +install-info-am: + +install-man: + +install-pdf: install-pdf-am + +install-pdf-am: + +install-ps: install-ps-am + +install-ps-am: + +installcheck-am: + +maintainer-clean: maintainer-clean-am + -rm -f Makefile +maintainer-clean-am: distclean-am maintainer-clean-generic + +mostlyclean: mostlyclean-am + +mostlyclean-am: mostlyclean-generic mostlyclean-libtool + +pdf: pdf-am + +pdf-am: + +ps: ps-am + +ps-am: + +uninstall-am: uninstall-dist_binSCRIPTS + +.MAKE: install-am install-strip + +.PHONY: all all-am all-local check check-am clean clean-generic \ + clean-libtool cscopelist-am ctags-am distclean \ + distclean-generic distclean-libtool distdir dvi dvi-am html \ + html-am info info-am install install-am install-data \ + install-data-am install-data-local install-dist_binSCRIPTS \ + install-dvi install-dvi-am install-exec install-exec-am \ + install-html install-html-am install-info install-info-am \ + install-man install-pdf install-pdf-am install-ps \ + install-ps-am install-strip installcheck installcheck-am \ + installdirs maintainer-clean maintainer-clean-generic \ + mostlyclean mostlyclean-generic mostlyclean-libtool pdf pdf-am \ + ps ps-am tags-am uninstall uninstall-am \ + uninstall-dist_binSCRIPTS + +.PRECIOUS: Makefile + + +all-local: $(ZSH_COMPLETION_FUNCTION_FILENAME) $(FISH_COMPLETION_FUNCTION_FILENAME) + +@USE_ZSH_COMPLETION_TRUE@$(ZSH_COMPLETION_FUNCTION_FILENAME): completion.pl +@USE_ZSH_COMPLETION_TRUE@ @PERL@ $(srcdir)/completion.pl --opts-dir $(top_srcdir)/docs/cmdline-opts --shell zsh > $@ + +@USE_FISH_COMPLETION_TRUE@$(FISH_COMPLETION_FUNCTION_FILENAME): completion.pl +@USE_FISH_COMPLETION_TRUE@ @PERL@ $(srcdir)/completion.pl --opts-dir $(top_srcdir)/docs/cmdline-opts --shell fish > $@ + +install-data-local: +@USE_ZSH_COMPLETION_TRUE@ $(MKDIR_P) $(DESTDIR)@ZSH_FUNCTIONS_DIR@ +@USE_ZSH_COMPLETION_TRUE@ $(INSTALL_DATA) $(ZSH_COMPLETION_FUNCTION_FILENAME) $(DESTDIR)@ZSH_FUNCTIONS_DIR@/$(ZSH_COMPLETION_FUNCTION_FILENAME) +@USE_FISH_COMPLETION_TRUE@ $(MKDIR_P) $(DESTDIR)@FISH_FUNCTIONS_DIR@ +@USE_FISH_COMPLETION_TRUE@ $(INSTALL_DATA) $(FISH_COMPLETION_FUNCTION_FILENAME) $(DESTDIR)@FISH_FUNCTIONS_DIR@/$(FISH_COMPLETION_FUNCTION_FILENAME) + +distclean: + rm -f $(CLEANFILES) + +# Tell versions [3.59,3.63) of GNU make to not export all variables. +# Otherwise a system limit (for SysV at least) may be exceeded. +.NOEXPORT: diff --git a/3rdparty/curl-8.21.0/scripts/badwords b/3rdparty/curl-8.21.0/scripts/badwords new file mode 100755 index 0000000000..7d371b3bee --- /dev/null +++ b/3rdparty/curl-8.21.0/scripts/badwords @@ -0,0 +1,336 @@ +#!/usr/bin/env perl +# Copyright (C) Daniel Stenberg, , et al. +# +# SPDX-License-Identifier: curl +# +# bad[:=]correct +# +# If separator is '=', the string is compared case sensitively. +# If separator is ':', the check is done case insensitively. +# +# To add white listed uses of bad words that are removed before checking for +# the bad ones: +# +# ---(accepted word) +# ---:[path]:(accepted word) +# + +use strict; +use warnings; + +use File::Basename; + +# +## States +# +# 0 - default, initial state +# 1 - there was a slash +# 2 - quoted string +# 3 - // comment +# 4 - /* comment +# 5 - asterisk found within a /* comment +# 6 - #include line +# 7 - backslash in a string +# +## Flags +# +# 1 - include preprocessor line, ignore strings + +sub srcline { + my ($state, $flags, $l) = @_; + my $line = ""; + + if(($state == 0) && ($l =~ /^ *\# *include/)) { + # preprocessor include line + $flags |= 1; + } + else { + # not preprocessor + $flags &= ~1; + } + + if($state == 3) { + # // ended on the prev line, go back to init + $state = 0; + } + + my @c = split(//, $l); + + # state machine this line + for my $c (@c) { + if($state == 1) { + # we had a slash + if($c eq "/") { + # // confirmed, the rest of the line is a comment + $line .= "//"; + $state = 3; + } + elsif($c eq "*") { + # /* confirmed + $state = 4; + $line .= "/*"; + } + else { + # back to normal + $line .= " "; + $state = 0; + } + } + elsif($state == 2) { + # a string + if($c eq "\\") { + $line .= "\\"; + $state = 7; + } + elsif($c eq "\"") { + # end of the string + $line .= "\""; + $state = 0; + } + else { + $line .= $c; + } + } + elsif($state == 3) { + # a // comment + $line .= $c; + } + elsif($state == 4) { + # a /* comment + if($c eq "*") { + # could be a comment close + $state = 5; + } + else { + $line .= $c; + } + } + elsif($state == 5) { + if($c eq "/") { + # a /* */ comment ended here */ + $line .= "*/"; + $state = 0; + } + else { + # the /* comment continues + $line .= "*$c"; + $state = 4; + } + } + elsif($state == 7) { + # the prev was a backslash in a string + $line .= $c; + # switch back to normal string + $state = 2; + } + else { + if($c eq "/") { + $state = 1; # got a slash + } + elsif(($c eq "\"") && !($flags & 1)) { + # start of a string, not within a preprocessor line + $line .= "\""; + $state = 2; + } + elsif($c eq "\n") { + $line .= "\n"; + } + else { + $line .= " "; + } + } + } + return $state, $flags, $line; +} + +sub sourcecode { + my ($f) = @_; + my $state = 0; + my $flags = 0; + my @lines; + my $line; + open(F, "<$f"); + while() { + my $l = $_; + ($state, $flags, $line) = srcline($state, $flags, $l); + push @lines, $line; + } + close(F); + return @lines; +} + +my @whitelist = ( + # ignore what looks like URLs + '(^|\W)((https|http|ftp):\/\/[a-z0-9\-._~%:\/?\#\[\]\@!\$&\'\(\)*+,;=]+)', + # remove bolded sections + '\*\*.*?\*\*', + # remove backticked texts + '\`.*?\`' + ); +my %alt; +my %exactcase; + +my %wl; + +my @w; +my @exact; +my $file = shift @ARGV; +open(CONFIG, "<$file") or die "Cannot open '$file': $!"; +while() { + chomp; + if($_ =~ /^#/) { + next; + } + if(/^---:([^:]*):(.*)/) { + # whitelist file + word + my $word = lc($2); + $wl{"$1:$word"} = 1; + } + elsif($_ =~ /^---(.+)/) { + # whitelist word + push @whitelist, $1; + } + elsif($_ =~ /^(.*)([:=])(.*)/) { + my ($bad, $sep, $better) = ($1, $2, $3); + if($sep eq "=") { + $alt{$bad} = $better; + push @exact, $bad; + } + else { + $alt{lc($bad)} = $better; + push @w, $bad; + } + } +} +close(CONFIG); + +# Build a single combined regex for case-insensitive words +my $re_ci; +if(@w) { + my $pat = join('|', map { quotemeta($_) } @w); + $re_ci = qr/\b($pat)\b/i; +} + +# Build a single combined regex for case-sensitive (exact) words +my $re_cs; +if(@exact) { + my $pat = join('|', map { quotemeta($_) } @exact); + $re_cs = qr/\b($pat)\b/; +} + +# Build a single combined regex for removing whitelisted content +my $pat = join('|', map { $_ } @whitelist); +my $re_wl = qr/($pat)/; + +my $errors = 0; + +sub highlight { + my ($p, $w, $in, $f, $l, $lookup) = @_; + + my $c = length($p)+1; + my $ch; + + my $dir = dirname($f); + $ch = $dir . "/" . ":" . lc($w); + if($wl{$ch}) { + # whitelisted dirname + word + return; + } + my $updir = dirname($dir); + if($dir ne $updir) { + $ch = $updir . "/" . ":" . lc($w); + if($wl{$ch}) { + # whitelisted upper dirname + word + return; + } + } + $ch = $f . ":" . lc($w); + if($wl{$ch}) { + # whitelisted filename + word + return; + } + + print STDERR "$f:$l:$c: error: found bad word \"$w\"\n"; + printf STDERR " %4d | %s\n", $l, $in; + printf STDERR " | %*s^%s\n", length($p), " ", + "~" x (length($w)-1); + printf STDERR " maybe use \"%s\" instead?\n", $alt{$lookup}; + $errors++; +} + +sub document { + my ($f) = @_; + my @lines; + open(F, "<$f"); + while() { + push @lines, $_; + } + close(F); + return @lines; +} + +sub file { + my ($f) = @_; + my $l = 0; + + my $skip_indented = 0; + my $source_code = 0; + if($f =~ /\.[ch]$/) { + $source_code = 1; + } + else { + # markdown + $skip_indented = 1; + } + + my @lines; + if($source_code) { + @lines = sourcecode($f); + } + else { + @lines = document($f); + } + for my $in (@lines) { + $l++; + chomp $in; + if($skip_indented && $in =~ /^ /) { + next; + } + # remove the link part + $in =~ s/(\[.*\])\(.*\)/$1/g; + # remove whitelisted patterns (pre-compiled) + if($re_wl) { + $in =~ s/${re_wl}//ig; + } + # case-insensitive bad words + if($re_ci) { + if($in =~ /^(.*)$re_ci/i) { + highlight($1, $2, $in, $f, $l, lc($2)); + } + } + # case-sensitive (exact) bad words + if($re_cs) { + if($in =~ /^(.*)$re_cs/) { + highlight($1, $2, $in, $f, $l, $2); + } + } + } +} + +my @filemasks = @ARGV; +open(my $git_ls_files, '-|', 'git', 'ls-files', '--', ":!:$file", @filemasks) or die "Failed running git ls-files: $!"; +my @files; +while(my $each = <$git_ls_files>) { + chomp $each; + push @files, $each; +} +close $git_ls_files; + +my $onum = scalar(@files); +my $num; +for my $e (@files) { + #printf STDERR "Complete: %d%%\r", $num++ * 100 / $onum; + file($e); +} + +exit $errors; diff --git a/3rdparty/curl-8.21.0/scripts/badwords-all b/3rdparty/curl-8.21.0/scripts/badwords-all new file mode 100755 index 0000000000..99e1b52ff8 --- /dev/null +++ b/3rdparty/curl-8.21.0/scripts/badwords-all @@ -0,0 +1,14 @@ +#!/usr/bin/env perl +# Copyright (C) Daniel Stenberg, , et al. +# +# SPDX-License-Identifier: curl + +use strict; +use warnings; + +use File::Basename; + +chdir dirname(__FILE__) . '/..'; + +exit system('scripts/badwords', ('scripts/badwords.txt', + '**.md', 'projects/OS400/README.OS400', 'include', 'docs/examples')) >> 8; diff --git a/3rdparty/curl-8.21.0/scripts/badwords.txt b/3rdparty/curl-8.21.0/scripts/badwords.txt new file mode 100644 index 0000000000..2651a48598 --- /dev/null +++ b/3rdparty/curl-8.21.0/scripts/badwords.txt @@ -0,0 +1,135 @@ +# Copyright (C) Daniel Stenberg, , et al. +# +# SPDX-License-Identifier: curl +# +# whitelisted uses of bad words (case insensitive) can be done in two ways, +# globally and per-file. +# +# ---[word] +# ---:[file]:[word] +# +back-end:backend +e-mail:email +run-time:runtime +set-up:setup +tool chain:toolchain +tool-chain:toolchain +well known:well-known +wild-card:wildcard +wild card:wildcard +threadsafe:thread-safe +thread safe:thread-safe +thread safety:thread-safety +thread unsafe:thread-unsafe +multi thread:multi-thread +nul terminate:null-terminate +null terminate:null-terminate +zero terminate:null-terminate +nul terminated:null-terminated +null terminated:null-terminated +NULL-terminated=null-terminated +zero terminated:null-terminated +zero-terminated:null-terminated +nul terminator:null-terminator +null terminator:null-terminator +zero terminator:null-terminator +work-around:workaround or work around +work-arounds:workarounds or works around +it's:it is +aren't:are not +can't:cannot +could've:could have +couldn't:could not +didn't:did not +doesn't:does not +don't:do not +haven't:have not +i'd:I would +i'll:I will +i'm:I am +i've:I have +isn't:is not +it'd:it would +it'll:it will +might've:might have +needn't:need not +should've:should have +shouldn't:should not +that's:that is +there's:there is +they'd:They would +they'll:They will +they're:They are +they've:They have +this'll:this will +wasn't:was not +we'd:we would +we'll:we will +we're:we are +we've:we have +weren't:were not +won't:will not +would've:would have +wouldn't:would not +you'd:you would +you'll:you will +you're:you are +you've:you have +a html:an html +a http:an http +a ftp:an ftp +a IPv4:an IPv4 +a IPv6:an IPv6 + url= URL +internet=Internet +isation:ization +So=Rewrite it somehow? +And=Rewrite it somehow? +But=Rewrite it somehow? +sub-directory:subdirectory +web page:webpage +host name:hostname +host names:hostnames +file name:filename +file names:filenames +fist:first +user name:username +user names:usernames +pass phrase:passphrase +will:rewrite to present tense +7 bit:7-bit +8 bit:8-bit +16 bit:16-bit +24 bit:24-bit +32 bit:32-bit +56 bit:56-bit +63 bit:63-bit +64 bit:64-bit +128 bit:128-bit +256 bit:256-bit +8-bits:8 bits +16-bits:16 bits +32-bits:32 bits +64-bits:64 bits +initialise:initialize +initialising:initializing +very:rephrase using an alternative word +just:rephrase using an alternative word +simply:rephrase using an alternative word +Curl=curl +cURL=curl +Libcurl=libcurl +LibCurl=libcurl +manpages:man pages +manpage:man page +favour:favor +basically:rephrase? +However,:rephrase? +the the:the +with with:with +---WWW::Curl +---NET::Curl +---Curl Corporation +---:lib/:will +---:src/:will +---:tests/data/:file name diff --git a/3rdparty/curl-8.21.0/scripts/cd2cd b/3rdparty/curl-8.21.0/scripts/cd2cd new file mode 100755 index 0000000000..ead664dfd6 --- /dev/null +++ b/3rdparty/curl-8.21.0/scripts/cd2cd @@ -0,0 +1,233 @@ +#!/usr/bin/env perl +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### + +=begin comment + +This script updates a curldown file to current/better curldown. + +Example: cd2cd [--in-place] > + +--in-place: if used, it replaces the original file with the cleaned up + version. When this is used, cd2cd accepts multiple files to work + on and it ignores errors on single files. + +=end comment +=cut + +use strict; +use warnings; + +my $cd2cd = "0.1"; # to keep check +my $dir; +my $extension; +my $inplace = 0; + +while(1) { + if(@ARGV && $ARGV[0] eq "--in-place") { + shift @ARGV; + $inplace = 1; + } + else { + last; + } +} + +use POSIX qw(strftime); +my @ts; +if(defined($ENV{SOURCE_DATE_EPOCH})) { + @ts = localtime($ENV{SOURCE_DATE_EPOCH}); +} else { + @ts = localtime; +} +my $date = strftime "%B %d %Y", @ts; + +sub outseealso { + my (@sa) = @_; + my $comma = 0; + my @o; + push @o, ".SH SEE ALSO\n"; + for my $s (sort @sa) { + push @o, sprintf "%s.BR $s", $comma ? ",\n" : ""; + $comma = 1; + } + push @o, "\n"; + return @o; +} + +sub single { + my @head; + my @seealso; + my ($f) = @_; + my $title; + my $section; + my $source; + my $start = 0; + my $d; + my $line = 0; + my $salist = 0; + my $copyright; + my $spdx; + open(F, "<:crlf", $f) or + return 1; + while() { + $line++; + $d = $_; + if(!$start) { + if(/^---/) { + # header starts here + $start = 1; + push @head, $d; + } + next; + } + if(/^Title: *(.*)/i) { + $title = $1; + } + elsif(/^Section: *(.*)/i) { + $section = $1; + } + elsif(/^Source: *(.*)/i) { + $source = $1; + } + elsif(/^See-also: +(.*)/i) { + $salist = 0; + push @seealso, $1; + } + elsif(/^See-also: */i) { + if($seealso[0]) { + print STDERR "$f:$line:1:ERROR: bad See-Also, needs list\n"; + return 2; + } + $salist = 1; + } + elsif(/^ +- (.*)/i) { + # the only list we support is the see-also + if($salist) { + push @seealso, $1; + } + } + # REUSE-IgnoreStart + elsif(/^C: (.*)/i) { + $copyright = $1; + } + elsif(/^SPDX-License-Identifier: (.*)/i) { + $spdx = $1; + } + # REUSE-IgnoreEnd + elsif(/^---/) { + # end of the header section + if(!$title) { + print STDERR "ERROR: no 'Title:' in $f\n"; + return 1; + } + if(!$section) { + print STDERR "ERROR: no 'Section:' in $f\n"; + return 2; + } + if(!$seealso[0]) { + print STDERR "$f:$line:1:ERROR: no 'See-also:' present\n"; + return 2; + } + if(!$copyright) { + print STDERR "$f:$line:1:ERROR: no 'C:' field present\n"; + return 2; + } + if(!$spdx) { + # REUSE-IgnoreStart + print STDERR "$f:$line:1:ERROR: no 'SPDX-License-Identifier:' field present\n"; + # REUSE-IgnoreEnd + return 2; + } + last; + } + else { + chomp; + print STDERR "WARN: unrecognized line in $f, ignoring:\n:'$_';" + } + } + + if(!$start) { + print STDERR "$f:$line:1:ERROR: no header present\n"; + return 2; + } + + my @desc; + + push @desc, sprintf <, et al. +SPDX-License-Identifier: curl +Title: $title +Section: $section +Source: $source +HEAD + ; + push @desc, "See-also:\n"; + for my $s (sort @seealso) { + push @desc, " - $s\n" if($s); + } + push @desc, "---\n"; + + my $blankline = 0; + while() { + $d = $_; + $line++; + if($d =~ /^[ \t]*\n/) { + $blankline++; + } + else { + $blankline = 0; + } + # *italics* for curl symbol links get the asterisks removed + $d =~ s/\*((lib|)curl[^ ]*\(3\))\*/$1/gi; + + if(length($d) > 90) { + print STDERR "$f:$line:1:WARN: excessive line length\n"; + } + + push @desc, $d if($blankline < 2); + } + close(F); + + if($inplace) { + open(O, ">$f") or return 1; + print O @desc; + close(O); + } + else { + print @desc; + } + return 0; +} + +if($inplace) { + for my $a (@ARGV) { + # this ignores errors + single($a); + } +} +elsif(@ARGV) { + exit single($ARGV[0]); +} diff --git a/3rdparty/curl-8.21.0/scripts/cd2nroff b/3rdparty/curl-8.21.0/scripts/cd2nroff new file mode 100755 index 0000000000..27717cfbe3 --- /dev/null +++ b/3rdparty/curl-8.21.0/scripts/cd2nroff @@ -0,0 +1,588 @@ +#!/usr/bin/env perl +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### + +=begin comment + +Converts a curldown file to nroff (man page). + +=end comment +=cut + +use strict; +use warnings; + +my $cd2nroff = "0.1"; # to keep check +my $dir; +my $extension; +my $keepfilename; + +while(@ARGV) { + if($ARGV[0] eq "-d") { + shift @ARGV; + $dir = shift @ARGV; + } + elsif($ARGV[0] eq "-e") { + shift @ARGV; + $extension = shift @ARGV; + } + elsif($ARGV[0] eq "-k") { + shift @ARGV; + $keepfilename = 1; + } + elsif($ARGV[0] eq "-h") { + print < Write the output to the filename from the meta-data in the + specified directory, instead of writing to stdout +-e If -d is used, this option can provide an added "extension", arbitrary + text really, to append to the filename. +-h This help text, +-v Show version then exit +HELP + ; + exit 0; + } + elsif($ARGV[0] eq "-v") { + print "cd2nroff version $cd2nroff\n"; + exit 0; + } + else { + last; + } +} + +use POSIX qw(strftime); +my @ts; +if(defined($ENV{SOURCE_DATE_EPOCH})) { + @ts = gmtime($ENV{SOURCE_DATE_EPOCH}); +} else { + @ts = localtime; +} +my $date = strftime "%Y-%m-%d", @ts; + +sub outseealso { + my (@sa) = @_; + my $comma = 0; + my @o; + push @o, ".SH SEE ALSO\n"; + for my $s (sort @sa) { + push @o, sprintf "%s.BR $s", $comma ? ",\n" : ""; + $comma = 1; + } + push @o, "\n"; + return @o; +} + +sub outprotocols { + my (@p) = @_; + my $comma = 0; + my @o; + my $tls = 0; + push @o, ".SH PROTOCOLS\n"; + + my @s = sort @p; + push @o, "This functionality affects "; + for my $e (sort @s) { + if($e eq "TLS") { + $tls = 1; + } + else { + push @o, sprintf "%s%s", + $comma ? (($e eq $s[-1]) ? " and " : ", "): "", + lc($e); + $comma = 1; + } + } + if($tls) { + push @o, sprintf + "%sall TLS based protocols: HTTPS, FTPS, IMAPS, POP3S, SMTPS etc.", + $comma ? " and ": " "; + } + if($#s == 0) { + if($s[0] eq "All") { + push @o, " supported protocols"; + } + else { + push @o, " only"; + } + } + push @o, "\n"; + return @o; +} + +sub outtls { + my (@t) = @_; + my $comma = 0; + my @o; + if($t[0] eq "All") { + push @o, "\nAll TLS backends support this option."; + } + elsif($t[0] eq "none") { + push @o, "\nNo TLS backend supports this option."; + } + else { + push @o, "\nThis option works only with the following TLS backends:\n"; + my @s = sort @t; + for my $e (@s) { + push @o, sprintf "%s$e", + $comma ? (($e eq $s[-1]) ? " and " : ", "): ""; + $comma = 1; + } + } + push @o, "\n"; + return @o; +} + +my %knownprotos = ( + 'DICT' => 1, + 'FILE' => 1, + 'FTP' => 1, + 'FTPS' => 1, + 'GOPHER' => 1, + 'GOPHERS' => 1, + 'HTTP' => 1, + 'HTTPS' => 1, + 'IMAP' => 1, + 'IMAPS' => 1, + 'LDAP' => 1, + 'LDAPS' => 1, + 'MQTT' => 1, + 'POP3' => 1, + 'POP3S' => 1, + 'RTSP' => 1, + 'SCP' => 1, + 'SFTP' => 1, + 'SMB' => 1, + 'SMBS' => 1, + 'SMTP' => 1, + 'SMTPS' => 1, + 'TELNET' => 1, + 'TFTP' => 1, + 'WS' => 1, + 'WSS' => 1, + 'TLS' => 1, + 'TCP' => 1, + 'QUIC' => 1, + 'All' => 1 + ); + +my %knowntls = ( + 'GnuTLS' => 1, + 'mbedTLS' => 1, + 'OpenSSL' => 1, + 'Rustls' => 1, + 'Schannel' => 1, + 'wolfSSL' => 1, + 'All' => 1, + 'none' => 1, + ); + +sub single { + my @seealso; + my @proto; + my @tls; + my $d; + my ($f) = @_; + my $copyright; + my $errors = 0; + my $fh; + my $line; + my $list; + my $tlslist; + my $section; + my $source; + my $addedin; + my $spdx; + my $start = 0; + my $title; + + if(defined($f)) { + if(!open($fh, "<:crlf", $f)) { + print STDERR "cd2nroff failed to open '$f' for reading: $!\n"; + return 1; + } + } + else { + $f = "STDIN"; + $fh = \*STDIN; + binmode($fh, ":crlf"); + } + while(<$fh>) { + $line++; + if(!$start) { + if(/^---/) { + # header starts here + $start = 1; + } + next; + } + if(/^Title: *(.*)/i) { + $title = $1; + } + elsif(/^Section: *(.*)/i) { + $section = $1; + } + elsif(/^Source: *(.*)/i) { + $source = $1; + } + elsif(/^See-also: +(.*)/i) { + $list = 1; # 1 for see-also + push @seealso, $1; + } + elsif(/^See-also: */i) { + if($seealso[0]) { + print STDERR "$f:$line:1:ERROR: bad See-Also, needs list\n"; + return 2; + } + $list = 1; # 1 for see-also + } + elsif(/^Protocol:/i) { + $list = 2; # 2 for protocol + } + elsif(/^TLS-backend:/i) { + $list = 3; # 3 for TLS backend + } + elsif(/^Added-in: *(.*)/i) { + $addedin = $1; + if(($addedin !~ /^[0-9.]+[0-9]\z/) && + ($addedin ne "n/a")) { + print STDERR "$f:$line:1:ERROR: invalid version number in Added-in line: $addedin\n"; + return 2; + } + } + elsif(/^ +- (.*)/i) { + # the only lists we support are see-also and protocol + if($list == 1) { + push @seealso, $1; + } + elsif($list == 2) { + push @proto, $1; + } + elsif($list == 3) { + push @tls, $1; + } + else { + print STDERR "$f:$line:1:ERROR: list item without owner?\n"; + return 2; + } + } + # REUSE-IgnoreStart + elsif(/^C: (.*)/i) { + $copyright = $1; + } + elsif(/^SPDX-License-Identifier: (.*)/i) { + $spdx = $1; + } + # REUSE-IgnoreEnd + elsif(/^---/) { + # end of the header section + if(!$title) { + print STDERR "$f:$line:1:ERROR: no 'Title:' in $f\n"; + return 1; + } + if(!$section) { + print STDERR "$f:$line:1:ERROR: no 'Section:' in $f\n"; + return 2; + } + if(!$source) { + print STDERR "$f:$line:1:ERROR: no 'Source:' in $f\n"; + return 2; + } + if(($source eq "libcurl") && !$addedin) { + print STDERR "$f:$line:1:ERROR: no 'Added-in:' in $f\n"; + return 2; + } + if(!$seealso[0]) { + print STDERR "$f:$line:1:ERROR: no 'See-also:' present\n"; + return 2; + } + if(!$copyright) { + print STDERR "$f:$line:1:ERROR: no 'C:' field present\n"; + return 2; + } + if(!$spdx) { + # REUSE-IgnoreStart + print STDERR "$f:$line:1:ERROR: no 'SPDX-License-Identifier:' field present\n"; + # REUSE-IgnoreEnd + return 2; + } + if($section == 3) { + if(!$proto[0]) { + printf STDERR "$f:$line:1:ERROR: missing Protocol:\n"; + exit 2; + } + my $tls = 0; + for my $p (@proto) { + if($p eq "TLS") { + $tls = 1; + } + if(!$knownprotos{$p}) { + printf STDERR "$f:$line:1:ERROR: invalid protocol used: $p:\n"; + exit 2; + } + } + # This is for TLS, require TLS-backend: + if($tls) { + if(!$tls[0]) { + printf STDERR "$f:$line:1:ERROR: missing TLS-backend:\n"; + exit 2; + } + for my $t (@tls) { + if(!$knowntls{$t}) { + printf STDERR "$f:$line:1:ERROR: invalid TLS backend: $t:\n"; + exit 2; + } + } + } + } + last; + } + else { + chomp; + print STDERR "$f:$line:1:ERROR: unrecognized header keyword: '$_'\n"; + $errors++; + } + } + + if(!$start) { + print STDERR "$f:$line:1:ERROR: no header present\n"; + return 2; + } + + my @desc; + my $quote = 0; + my $blankline = 0; + my $header = 0; + + # cut off the leading path from the filename, if any + $f =~ s/^(.*[\\\/])//; + + push @desc, ".\\\" generated by cd2nroff $cd2nroff from $f\n"; + push @desc, ".TH $title $section \"$date\" $source\n"; + while(<$fh>) { + $line++; + + $d = $_; + + if($quote) { + if($quote == 4) { + # remove the indentation + if($d =~ /^ (.*)/) { + push @desc, "$1\n"; + next; + } + else { + # end of quote + $quote = 0; + push @desc, ".fi\n"; + next; + } + } + if(/^~~~/) { + # end of quote + $quote = 0; + push @desc, ".fi\n"; + next; + } + # convert single backslashes to doubles + $d =~ s/\\/\\\\/g; + # lines starting with a period needs it escaped + $d =~ s/^\./\\&./; + push @desc, $d; + next; + } + + # remove single line HTML comments + $d =~ s///g; + + # **bold** + $d =~ s/\*\*(\S.*?)\*\*/\\fB$1\\fP/g; + # *italics* + $d =~ s/\*(\S.*?)\*/\\fI$1\\fP/g; + + my $back = $d; + + # remove all backticked pieces + $back =~ s/\`(.*?)\`//g; + + if($back =~ /[^\\][\<\>]/) { + print STDERR "$f:$line:1:ERROR: un-escaped < or > used\n"; + $errors++; + } + # convert backslash-'<' or '> to the second character + $d =~ s/\\([<>])/$1/g; + + # mentions of curl symbols with man pages use italics by default + $d =~ s/((lib|)curl([^ ]*\(3\)))/\\fI$1\\fP/gi; + + # backticked becomes italics + $d =~ s/\`(.*?)\`/\\fI$1\\fP/g; + + if(/^## (.*)/) { + my $word = $1; + # if there are enclosing quotes, remove them first + $word =~ s/[\"\'\`](.*)[\"\'\`]\z/$1/; + + # enclose in double quotes if there is a space present + if($word =~ / /) { + push @desc, ".IP \"$word\"\n"; + } + else { + push @desc, ".IP $word\n"; + } + $header = 1; + } + elsif(/^##/) { + # end of IP sequence + push @desc, ".PP\n"; + $header = 1; + } + elsif(/^# (.*)/) { + my $word = $1; + # if there are enclosing quotes, remove them first + $word =~ s/[\"\'](.*)[\"\']\z/$1/; + + if($word eq "PROTOCOLS") { + print STDERR "$f:$line:1:WARN: PROTOCOLS section in source file\n"; + } + elsif($word eq "AVAILABILITY") { + print STDERR "$f:$line:1:WARN: AVAILABILITY section in source file\n"; + } + elsif($word eq "%PROTOCOLS%") { + # insert the generated PROTOCOLS section + push @desc, outprotocols(@proto); + + if($proto[0] eq "TLS") { + push @desc, outtls(@tls); + } + $header = 1; + next; + } + elsif($word eq "%AVAILABILITY%") { + if($addedin ne "n/a") { + # insert the generated AVAILABILITY section + push @desc, ".SH AVAILABILITY\n"; + push @desc, "Added in curl $addedin\n"; + } + $header = 1; + next; + } + push @desc, ".SH $word\n"; + $header = 1; + } + elsif(/^~~~c/) { + # start of a code section, not indented + $quote = 1; + push @desc, "\n" if($blankline && !$header); + $header = 0; + push @desc, ".nf\n"; + } + elsif(/^~~~/) { + # start of a quote section; not code, not indented + $quote = 1; + push @desc, "\n" if($blankline && !$header); + $header = 0; + push @desc, ".nf\n"; + } + elsif(/^ (.*)/) { + # quoted, indented by 4 space + $quote = 4; + push @desc, "\n" if($blankline && !$header); + $header = 0; + push @desc, ".nf\n$1\n"; + } + elsif(/^[ \t]*\n/) { + # count and ignore blank lines + $blankline++; + } + else { + # do not output newlines if this is the first content after a + # header + push @desc, "\n" if($blankline && !$header); + $blankline = 0; + $header = 0; + + # quote minuses in the output + $d =~ s/([^\\])-/$1\\-/g; + # replace single quotes + $d =~ s/\'/\\(aq/g; + # handle double quotes first on the line + $d =~ s/^(\s*)\"/$1\\&\"/; + + # lines starting with a period needs it escaped + $d =~ s/^\./\\&./; + + if($d =~ /^(.*) /) { + printf STDERR "$f:$line:%d:ERROR: 2 spaces detected\n", + length($1); + $errors++; + } + if($d =~ /^[ \t]*\n/) { + # replaced away all contents + $blankline= 1; + } + else { + push @desc, $d; + } + } + } + if($fh != \*STDIN) { + close($fh); + } + push @desc, outseealso(@seealso); + if($dir) { + if($keepfilename) { + $title = $f; + $title =~ s/\.[^.]*$//; + } + my $outfile = "$dir/$title.$section"; + if(defined($extension)) { + $outfile .= $extension; + } + if(!open(O, ">", $outfile)) { + print STDERR "Failed to open $outfile : $!\n"; + return 1; + } + print O @desc; + close(O); + } + else { + print @desc; + } + return $errors; +} + +if(@ARGV) { + for my $f (@ARGV) { + my $r = single($f); + if($r) { + exit $r; + } + } +} +else { + exit single(); +} diff --git a/3rdparty/curl-8.21.0/scripts/cdall b/3rdparty/curl-8.21.0/scripts/cdall new file mode 100755 index 0000000000..53e6e36929 --- /dev/null +++ b/3rdparty/curl-8.21.0/scripts/cdall @@ -0,0 +1,47 @@ +#!/usr/bin/env perl +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### + +# provide all directory names to scan on the command-line + +use strict; +use warnings; + +sub convert { + my ($dir) = @_; + opendir(my $dh, $dir) or die "could not open $dir"; + my @cd = grep { /\.md\z/ && -f "$dir/$_" } readdir($dh); + closedir $dh; + + for my $cd (@cd) { + my $nroff = $cd; + $nroff =~ s/\.md\z/.3/; + print "$dir/$cd = $dir/$nroff\n"; + system('./scripts/cd2nroff', ('-d', $dir, "$dir/$cd")); + } +} + +for my $d (sort @ARGV) { + convert($d); +} diff --git a/3rdparty/curl-8.21.0/scripts/checksrc-all.pl b/3rdparty/curl-8.21.0/scripts/checksrc-all.pl new file mode 100755 index 0000000000..fd80c1b427 --- /dev/null +++ b/3rdparty/curl-8.21.0/scripts/checksrc-all.pl @@ -0,0 +1,48 @@ +#!/usr/bin/env perl +# Copyright (C) Viktor Szakats +# +# SPDX-License-Identifier: curl + +use strict; +use warnings; + +use File::Basename; +use File::Find; +use Cwd 'abs_path'; + +my @files; +my $is_git = 0; +if(system('git rev-parse --is-inside-work-tree >/dev/null 2>&1') == 0) { + open(O, '-|', 'git', 'ls-files', '*.[ch]') or die; push @files, ; close(O); + $is_git = 1; +} +else { + find(sub { if(/\.[ch]$/) { push(@files, $File::Find::name) } }, ('.')); +} +if(@ARGV) { + find(sub { if(/\.[ch]$/) { push(@files, $File::Find::name) } }, @ARGV); +} + +@files = grep !/\/CMakeFiles\//, @files; +@files = grep !/tests\/data\/data.+\.c/, @files; +@files = map { dirname($_) } @files; +my @dirs = sort { $a cmp $b } keys %{{ map { $_ => 1 } @files }}; + +my $scripts_dir = dirname(abs_path($0)); +my $anyfailed = 0; + +for my $dir (@dirs) { + if($is_git) { + @files = (); + open(O, '-|', 'git', 'ls-files', ":(glob)$dir/*.[ch]") or die; push @files, ; close(O); + chomp(@files); + } + else { + @files = glob("$dir/*.[ch]"); + } + if(@files && system("$scripts_dir/checksrc.pl", @files) != 0) { + $anyfailed = 1; + } +} + +exit $anyfailed; diff --git a/3rdparty/curl-8.21.0/scripts/checksrc.pl b/3rdparty/curl-8.21.0/scripts/checksrc.pl new file mode 100755 index 0000000000..46d02ae3c8 --- /dev/null +++ b/3rdparty/curl-8.21.0/scripts/checksrc.pl @@ -0,0 +1,1276 @@ +#!/usr/bin/env perl +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### + +use strict; +use warnings; + +my $max_column = 79; +my $indent = 2; + +my $warnings = 0; +my $swarnings = 0; +my $errors = 0; +my $serrors = 0; +my $suppressed; # skipped problems +my $file; +my $dir = "."; +my $wlist = ""; +my @alist; +my $windows_os = $^O eq 'MSWin32' || $^O eq 'cygwin' || $^O eq 'msys'; +my $verbose = 0; +my %skiplist; + +my %ignore; +my %ignore_set; +my %ignore_used; +my @ignore_line; + +my %banfunc = ( + "_access" => 1, + "_fstati64" => 1, + "_lseeki64" => 1, + "_mbscat" => 1, + "_mbsncat" => 1, + "_open" => 1, + "_tcscat" => 1, + "_tcsdup" => 1, + "_tcsncat" => 1, + "_tcsncpy" => 1, + "_waccess" => 1, + "_wcscat" => 1, + "_wcsdup" => 1, + "_wcsncat" => 1, + "_wfopen" => 1, + "_wfreopen" => 1, + "_wopen" => 1, + "accept" => 1, + "accept4" => 1, + "access" => 1, + "aprintf" => 1, + "atoi" => 1, + "atol" => 1, + "calloc" => 1, + "close" => 1, + "CreateFile" => 1, + "CreateFileA" => 1, + "CreateFileW" => 1, + "fclose" => 1, + "fdopen" => 1, + "fopen" => 1, + "fprintf" => 1, + "free" => 1, + "freeaddrinfo" => 1, + "freopen" => 1, + "fstat" => 1, + "getaddrinfo" => 1, + "gets" => 1, + "gmtime" => 1, + "llseek" => 1, + "LoadLibrary" => 1, + "LoadLibraryA" => 1, + "LoadLibraryEx" => 1, + "LoadLibraryExA" => 1, + "LoadLibraryExW" => 1, + "LoadLibraryW" => 1, + "localtime" => 1, + "lseek" => 1, + "malloc" => 1, + "mbstowcs" => 1, + "MoveFileEx" => 1, + "MoveFileExA" => 1, + "MoveFileExW" => 1, + "msnprintf" => 1, + "mvsnprintf" => 1, + "open" => 1, + "printf" => 1, + "realloc" => 1, + "recv" => 1, + "rename" => 1, + "send" => 1, + "snprintf" => 1, + "socket" => 1, + "socketpair" => 1, + "sprintf" => 1, + "sscanf" => 1, + "stat" => 1, + "strcat" => 1, + "strcpy" => 1, + "strdup" => 1, + "strerror" => 1, + "strncat" => 1, + "strncpy" => 1, + "strtok_r" => 1, + "strtok" => 1, + "strtol" => 1, + "strtoul" => 1, + "vaprintf" => 1, + "vfprintf" => 1, + "vprintf" => 1, + "vsnprintf" => 1, + "vsprintf" => 1, + "wcscpy" => 1, + "wcsdup" => 1, + "wcsncpy" => 1, + "wcstombs" => 1, + "WSASocket" => 1, + "WSASocketA" => 1, + "WSASocketW" => 1, + ); + +my %warnings_extended = ( + 'COPYRIGHTYEAR' => 'copyright year incorrect', + 'STDERR' => 'stderr detected', + ); + +my %warnings = ( + 'ASSIGNWITHINCONDITION' => 'assignment within conditional expression', + 'ASTERISKNOSPACE' => 'pointer declared without space before asterisk', + 'ASTERISKSPACE' => 'pointer declared with space after asterisk', + 'BADCOMMAND' => 'bad !checksrc! instruction', + 'BANNEDFUNC' => 'a banned function was used', + 'BANNEDPREPROC' => 'a banned symbol was used on a preprocessor line', + 'BRACEELSE' => '} else on the same line', + 'BRACEPOS' => 'wrong position for an open brace', + 'BRACEWHILE' => 'A single space between open brace and while', + 'CLOSEBRACE' => 'close brace indent level vs line above is off', + 'COMMANOSPACE' => 'comma without following space', + 'COMMENTNOSPACEEND' => 'no space before */', + 'COMMENTNOSPACESTART' => 'no space following /*', + 'COPYRIGHT' => 'file missing a copyright statement', + 'CPPCOMMENTS' => '// comment detected', + 'CPPSPACE' => 'space before preprocessor hash', + 'DOBRACE' => 'A single space between do and open brace', + 'EMPTYLINEBRACE' => 'Empty line before the open brace', + 'EQUALSNOSPACE' => 'equals sign without following space', + 'EQUALSNULL' => 'if/while comparison with == NULL', + 'EQUALSPACE' => 'equals sign with too many spaces following', + 'ERRNOVAR' => 'use of bare errno define', + 'EXCLAMATIONSPACE' => 'Whitespace after exclamation mark in expression', + 'FIXME' => 'FIXME or TODO comment', + 'FOPENMODE' => 'fopen needs a macro for the mode string', + 'IFDEFSINGLE' => 'use ifdef/ifndef for single macro checks', + 'INCLUDEDUP' => 'same file is included again', + 'INDENTATION' => 'wrong start column for code', + 'LONGLINE' => "Line longer than $max_column", + 'MULTISPACE' => 'multiple spaces used when not suitable', + 'NOSPACEAND' => 'missing space around Logical AND operator', + 'NOSPACEC' => 'missing space around ternary colon operator', + 'NOSPACEEQUALS' => 'equals sign without preceding space', + 'NOSPACEPLUS' => 'no space before plus sign', + 'NOSPACEQ' => 'missing space around ternary question mark operator', + 'NOSPACETHAN' => 'missing space around less or greater than', + 'NOTEQUALSZERO' => 'if/while comparison with != 0', + 'ONELINECONDITION' => 'conditional block on the same line as the if()', + 'OPENCOMMENT' => 'file ended with a /* comment still "open"', + 'PARENBRACE' => '){ without sufficient space', + 'PLUSNOSPACE' => 'no space after plus sign', + 'RETURNNOSPACE' => 'return without space', + 'RETURNPAREN' => 'return with paren', + 'SEMINOSPACE' => 'semicolon without following space', + 'SIZEOFNOPAREN' => 'use of sizeof without parentheses', + 'SPACEAFTERPAREN' => 'space after open parenthesis', + 'SPACEBEFORECLOSE' => 'space before a close parenthesis', + 'SPACEBEFORECOMMA' => 'space before a comma', + 'SPACEBEFORELABEL' => 'labels not at the start of the line', + 'SPACEBEFOREPAREN' => 'space before an open parenthesis', + 'SPACESEMICOLON' => 'space before semicolon', + 'SPACESWITCHCOLON' => 'space before colon of switch label', + 'TABS' => 'TAB characters not allowed', + 'TRAILINGSPACE' => 'Trailing whitespace on the line', + 'TYPEDEFSTRUCT' => 'typedefed struct', + 'UNUSEDIGNORE' => 'a warning ignore was not used', + 'USESAFEFREE' => 'replace curlx_free() + NULL assignment with curlx_safefree()', + 'VOIDEXCL' => '(void)! is not something we like', + ); + +sub readskiplist { + open(my $W, '<', "$dir/checksrc.skip") or return; + my @all = <$W>; + for(@all) { + $windows_os ? $_ =~ s/\r?\n$// : chomp; + $skiplist{$_} = 1; + } + close($W); +} + +# Reads the .checksrc in $dir for any extended warnings to enable locally. +# Currently there is no support for disabling warnings from the standard set, +# and since that is already handled via !checksrc! commands there is probably +# little use to add it. +sub readlocalfile { + my ($file) = @_; + my $i = 0; + my $rcfile; + + if(($dir eq ".") && $file =~ /\//) { + my $ldir; + if($file =~ /(.*)\//) { + $ldir = $1; + open($rcfile, "<", "$dir/$ldir/.checksrc") or return; + } + } + else { + open($rcfile, "<", "$dir/.checksrc") or return; + } + + while(<$rcfile>) { + $windows_os ? $_ =~ s/\r?\n$// : chomp; + $i++; + + # Lines starting with '#' are considered comments + if(/^\s*(#.*)/) { + next; + } + # Skip empty lines + elsif($_ eq '') { + next; + } + elsif(/^enable ([A-Z]+)$/) { + if(!defined($warnings_extended{$1})) { + print STDERR "invalid warning specified in .checksrc: \"$1\"\n"; + next; + } + $warnings{$1} = $warnings_extended{$1}; + } + elsif(/^disable ([A-Z]+)$/) { + if(!defined($warnings{$1})) { + print STDERR "invalid warning specified in .checksrc: \"$1\"\n"; + next; + } + # Accept-list + push @alist, $1; + } + elsif(/^banfunc ([^ ]*)/) { + $banfunc{$1} = $1; + } + elsif(/^allowfunc ([^ ]*)/) { + undef $banfunc{$1}; + } + else { + die "Invalid format in $dir/.checksrc on line $i: $_\n"; + } + } + close($rcfile); +} + +sub checkwarn { + my ($name, $num, $col, $file, $line, $msg, $error) = @_; + + my $w = $error ? "error" : "warning"; + my $nowarn = 0; + + #if(!$warnings{$name}) { + # print STDERR "Dev! there is no description for $name!\n"; + #} + + # checksrc.skip + if($skiplist{$line}) { + $nowarn = 1; + } + # !checksrc! controlled + elsif($ignore{$name}) { + $ignore{$name}--; + $ignore_used{$name}++; + $nowarn = 1; + if(!$ignore{$name}) { + # reached zero, enable again + enable_warn($name, $num, $file, $line); + } + } + + if($nowarn) { + $suppressed++; + if($error) { + $serrors++; + } + else { + $swarnings++; + } + return; + } + + if($error) { + $errors++; + } + else { + $warnings++; + } + + $col++; + print "$file:$num:$col: $w: $msg ($name)\n"; + print " $line\n"; + + if($col < 80) { + my $pref = (' ' x $col); + print "${pref}^\n"; + } +} + +$file = shift @ARGV; + +while(defined $file) { + + if($file =~ /^-D(.*)/) { + $dir = $1; + $file = shift @ARGV; + next; + } + elsif($file =~ /^-W(.*)/) { + $wlist .= " $1 "; + $file = shift @ARGV; + next; + } + elsif($file =~ /^-b(.*)/) { + $banfunc{$1} = $1; + # print STDERR "ban use of \"$1\"\n"; + $file = shift @ARGV; + next; + } + elsif($file =~ /^-a(.*)/) { + undef $banfunc{$1}; + $file = shift @ARGV; + next; + } + elsif($file =~ /^-A(.+)/) { + push @alist, $1; + $file = shift @ARGV; + next; + } + elsif($file =~ /^-i([1-9])/) { + $indent = $1 + 0; + $file = shift @ARGV; + next; + } + elsif($file =~ /^-m([0-9]+)/) { + $max_column = $1 + 0; + $file = shift @ARGV; + next; + } + elsif($file =~ /^-v/) { + $verbose = 1; + $file = shift @ARGV; + next; + } + elsif($file =~ /^(-h|--help)/) { + undef $file; + last; + } + + last; +} + +if(!$file) { + print "checksrc.pl [option] [file2] ...\n"; + print " Options:\n"; + print " -A[rule] Accept this violation, can be used multiple times\n"; + print " -a[func] Allow use of this function\n"; + print " -b[func] Ban use of this function\n"; + print " -D[DIR] Directory to prepend filenames\n"; + print " -h Show help output\n"; + print " -W[file] Skip the given file - ignore all its flaws\n"; + print " -i Indent spaces. Default: 2\n"; + print " -m Maximum line length. Default: 79\n"; + print " -v Verbose\n"; + print "\nDetects and warns for these problems:\n"; + my @allw = keys %warnings; + push @allw, keys %warnings_extended; + for my $w (sort @allw) { + if($warnings{$w}) { + printf (" %-18s: %s\n", $w, $warnings{$w}); + } + else { + printf (" %-18s: %s[*]\n", $w, $warnings_extended{$w}); + } + } + print " [*] = disabled by default\n"; + + print "\nDetects and bans use of these functions:\n"; + for my $f (sort keys %banfunc) { + printf (" %-18s\n", $f); + } + exit; +} + +readskiplist(); +readlocalfile($file); + +do { + if($wlist !~ / $file /) { + my $fullname = $file; + $fullname = "$dir/$file" if($fullname !~ /^\.?\.?\//); + scanfile($fullname); + } + $file = shift @ARGV; + +} while($file); + +sub accept_violations { + for my $r (@alist) { + if(!$warnings{$r}) { + print "'$r' is not a warning to accept!\n"; + exit; + } + $ignore{$r} = 999999; + $ignore_used{$r} = 0; + } +} + +sub checksrc_clear { + undef %ignore; + undef %ignore_set; + undef @ignore_line; +} + +sub checksrc_endoffile { + my ($file) = @_; + for(keys %ignore_set) { + if($ignore_set{$_} && !$ignore_used{$_}) { + checkwarn("UNUSEDIGNORE", $ignore_set{$_}, + length($_) + 11, $file, + $ignore_line[$ignore_set{$_}], + "Unused ignore: $_"); + } + } +} + +sub enable_warn { + my ($what, $line, $file, $l) = @_; + + # switch it back on, but warn if not triggered! + if(!$ignore_used{$what}) { + checkwarn("UNUSEDIGNORE", + $line, length($what) + 11, $file, $l, + "No warning was inhibited!"); + } + $ignore_set{$what} = 0; + $ignore_used{$what} = 0; + $ignore{$what} = 0; +} +sub checksrc { + my ($cmd, $line, $file, $l) = @_; + if($cmd =~ / *([^ ]*) *(.*)/) { + my ($enable, $what) = ($1, $2); + $what =~ s: *\*/$::; # cut off end of C comment + # print "ENABLE $enable WHAT $what\n"; + if($enable eq "disable") { + my ($warn, $scope) = ($1, $2); + if($what =~ /([^ ]*) +(.*)/) { + ($warn, $scope) = ($1, $2); + } + else { + $warn = $what; + $scope = 1; + } + # print "IGNORE $warn for SCOPE $scope\n"; + if($scope eq "all") { + $scope = 999999; + } + + # Comparing for a literal zero rather than the scalar value zero + # covers the case where $scope contains the ending '*' from the + # comment. If we use a scalar comparison (==) we induce warnings + # on non-scalar contents. + if($scope eq "0") { + checkwarn("BADCOMMAND", + $line, 0, $file, $l, + "Disable zero not supported, did you mean to enable?"); + } + elsif($ignore_set{$warn}) { + checkwarn("BADCOMMAND", + $line, 0, $file, $l, + "$warn already disabled from line $ignore_set{$warn}"); + } + else { + $ignore{$warn} = $scope; + $ignore_set{$warn} = $line; + $ignore_line[$line] = $l; + } + } + elsif($enable eq "enable") { + enable_warn($what, $line, $file, $l); + } + else { + checkwarn("BADCOMMAND", + $line, 0, $file, $l, + "Illegal !checksrc! command"); + } + } +} + +sub nostrings { + my ($str) = @_; + $str =~ s/\".*\"//g; + return $str; +} + +sub scanfile { + my ($file) = @_; + + my $line = 1; + my $prevl = ""; + my $prevpl = ""; + my $l = ""; + my $prep = 0; + my $prevp = 0; + my $prevfreeindent = ""; + my $prevfreevar = ""; + + if($verbose) { + printf "Checking file: $file\n"; + } + + open(my $R, '<', $file) or die "failed to open $file"; + + my $incomment = 0; + my @copyright = (); + my %includes; + checksrc_clear(); # for file based ignores + accept_violations(); + + while(<$R>) { + $windows_os ? $_ =~ s/\r?\n$// : chomp; + my $l = $_; + my $ol = $l; # keep the unmodified line for error reporting + my $column = 0; + + # check for !checksrc! commands + if($l =~ /\!checksrc\! (.*)/) { + my $cmd = $1; + checksrc($cmd, $line, $file, $l); + } + + if($l =~ /^#line (\d+) \"([^\"]*)\"/) { + # a #line instruction + $file = $2; + $line = $1; + next; + } + + # check for a copyright statement and save the years + if($l =~ /\* +copyright .* (\d\d\d\d|)/i) { + my $count = 0; + while($l =~ /([\d]{4})/g) { + push @copyright, { + year => $1, + line => $line, + col => index($l, $1), + code => $l + }; + $count++; + } + if(!$count) { + # year-less + push @copyright, { + year => -1, + line => $line, + col => index($l, $1), + code => $l + }; + } + } + + # detect long lines + if(length($l) > $max_column && $l !~ / https:\/\//) { + checkwarn("LONGLINE", $line, length($l), $file, $l, + "Longer than $max_column columns"); + } + # detect TAB characters + if($l =~ /^(.*)\t/) { + checkwarn("TABS", + $line, length($1), $file, $l, "Contains TAB character", 1); + } + # detect trailing whitespace + if($l =~ /^(.*)[ \t]+\z/) { + checkwarn("TRAILINGSPACE", + $line, length($1), $file, $l, "Trailing whitespace"); + } + + # no space after comment start + if($l =~ /^(.*)\/\*\w/) { + checkwarn("COMMENTNOSPACESTART", + $line, length($1) + 2, $file, $l, + "Missing space after comment start"); + } + # no space at comment end + if($l =~ /^(.*)\w\*\//) { + checkwarn("COMMENTNOSPACEEND", + $line, length($1) + 1, $file, $l, + "Missing space before comment end"); + } + + if($l =~ /(.*)(FIXME|TODO)/) { + checkwarn("FIXME", + $line, length($1), $file, $l, + "Avoid $2 comments. Add to documentation instead"); + } + # ------------------------------------------------------------ + # Above this marker, the checks were done on lines *including* + # comments + # ------------------------------------------------------------ + + # strip off C89 comments + + comment: + if(!$incomment) { + if($l =~ s/\/\*.*\*\// /g) { + # full /* comments */ were removed! + } + if($l =~ s/\/\*.*//) { + # start of /* comment was removed + $incomment = 1; + } + } + else { + if($l =~ s/.*\*\///) { + # end of comment */ was removed + $incomment = 0; + goto comment; + } + else { + # still within a comment + $l = ""; + } + } + + # ------------------------------------------------------------ + # Below this marker, the checks were done on lines *without* + # comments + # ------------------------------------------------------------ + + # prev line was a preprocessor **and** ended with a backslash + if($prep && ($prevpl =~ /\\ *\z/)) { + # this is still a preprocessor line + $prep = 1; + goto preproc; + } + $prep = 0; + + # crude attempt to detect // comments without too many false + # positives + if($l =~ /^(([^"\*]*)[^:"]|)\/\//) { + checkwarn("CPPCOMMENTS", + $line, length($1), $file, $l, "\/\/ comment"); + } + + if($l =~ /^(\s*#\s*if\s+!?\s*defined\()[a-zA-Z0-9_]+\)$/) { + checkwarn("IFDEFSINGLE", + $line, length($1), $file, $l, "use ifdef/ifndef for single macro checks"); + } + + if($l =~ /^(\#\s*include\s+)([\">].*[>}"])/) { + my ($pre, $path) = ($1, $2); + if($includes{$path}) { + checkwarn("INCLUDEDUP", + $line, length($1), $file, $l, "duplicated include"); + } + $includes{$path} = $l; + } + + # detect leading space before the hash + if($l =~ /^([ \t]+)\#/) { + checkwarn("CPPSPACE", + $line, 0, $file, $l, "space before preprocessor hash"); + } + # detect and strip preprocessor directives + if($l =~ /^[ \t]*\#/) { + # preprocessor line + $prep = 1; + goto preproc; + } + + my $nostr = nostrings($l); + # check spaces after for/if/while/function call + if($nostr =~ /^(.*)(for|if|while|switch| ([a-zA-Z0-9_]+)) \((.)/) { + my ($leading, $word, $extra, $first) = ($1, $2, $3, $4); + if($1 =~ / *\#/) { + # this is a #if, treat it differently + } + elsif(defined $3 && $3 eq "return") { + # return must have a space + } + elsif(defined $3 && $3 eq "case") { + # case must have a space + } + elsif(($first eq "*") && ($word !~ /(for|if|while|switch)/)) { + # A "(*" beginning makes the space OK because it wants to + # allow function pointer declared + } + elsif($1 =~ / *typedef/) { + # typedefs can use space-paren + } + else { + checkwarn("SPACEBEFOREPAREN", $line, length($leading)+length($word), $file, $l, + "$word with space"); + } + } + # check for '== NULL' in if/while conditions but not if the thing on + # the left of it is a function call + if($nostr =~ /^(.*)(if|while)(\(.*?)([!=]= NULL|NULL [!=]=)/) { + checkwarn("EQUALSNULL", $line, + length($1) + length($2) + length($3), + $file, $l, "we prefer !variable instead of \"== NULL\" comparisons"); + } + + # check for '!= 0' in if/while conditions but not if the thing on + # the left of it is a function call + if($nostr =~ /^(.*)(if|while)(\(.*[^)]) != 0[^x]/) { + checkwarn("NOTEQUALSZERO", $line, + length($1) + length($2) + length($3), + $file, $l, "we prefer if(rc) instead of \"rc != 0\" comparisons"); + } + + # check spaces in 'do {' + if($nostr =~ /^( *)do( *)\{/ && length($2) != 1) { + checkwarn("DOBRACE", $line, length($1) + 2, $file, $l, "one space after do before brace"); + } + # check spaces in 'do {' + elsif($nostr =~ /^( *)\}( *)while/ && length($2) != 1) { + checkwarn("BRACEWHILE", $line, length($1) + 2, $file, $l, "one space between brace and while"); + } + if($nostr =~ /^((.*\s)(if) *\()(.*)\)(.*)/) { + my $pos = length($1); + my $postparen = $5; + my $cond = $4; + if($cond =~ / = /) { + checkwarn("ASSIGNWITHINCONDITION", + $line, $pos + 1, $file, $l, + "assignment within conditional expression"); + } + my $temp = $cond; + $temp =~ s/\(//g; # remove open parens + my $openc = length($cond) - length($temp); + + $temp = $cond; + $temp =~ s/\)//g; # remove close parens + my $closec = length($cond) - length($temp); + my $even = $openc == $closec; + + if($l =~ / *\#/) { + # this is a #if, treat it differently + } + elsif($even && $postparen && + ($postparen !~ /^ *$/) && ($postparen !~ /^ *[,{&|\\]+/)) { + checkwarn("ONELINECONDITION", + $line, length($l)-length($postparen), $file, $l, + "conditional block on the same line"); + } + } + # check spaces after open parentheses + if($l =~ /^(.*[a-z])\( /i) { + checkwarn("SPACEAFTERPAREN", + $line, length($1)+1, $file, $l, + "space after open parenthesis"); + } + + # check spaces before Logical AND operator + if($nostr =~ /^(.*)\w&&/i) { + checkwarn("NOSPACEAND", + $line, length($1)+1, $file, $l, + "missing space before Logical AND"); + } + + # check spaces after Logical AND operator + if($nostr =~ /^(.*&&)\w/i) { + checkwarn("NOSPACEAND", + $line, length($1), $file, $l, + "missing space after Logical AND"); + } + + # check spaces before colon + if($nostr =~ /^(.*[^']\?[^'].*)(\w|\)|\]|')\:/i) { + my $m = $1; + my $e = $nostr; + $e =~ s/'(.)':'(.)'/$1:$2/g; # eliminate chars quotes that surround colon + $e =~ s/':'//g; # ignore these + if($e =~ /^(.*[^']\?[^'].*)(\w|\)|\]|')\:/i) { + checkwarn("NOSPACEC", + $line, length($m)+1, $file, $l, + "missing space before colon"); + } + } + # check spaces after colon + if($nostr =~ /^(.*[^'"]\?[^'"].*)\:(\w|\)|\]|')/i) { + my $m = $1; + my $e = $nostr; + $e =~ s/'(.)':'(.)'/$1:$2/g; # eliminate chars quotes that surround colon + $e =~ s/':'//g; # ignore these + if($e =~ /^(.*[^'"]\?[^'"].*)\:(\w|\)|\]|')/i) { + checkwarn("NOSPACEC", + $line, length($m)+1, $file, $l, + "missing space after colon"); + } + } + + # check spaces before question mark + if($nostr =~ /^(.*)(\w|\)|\]|')\?/i) { + my $m = $1; + my $e = $nostr; + $e =~ s/'?'//g; # ignore these + if($e =~ /^(.*)(\w|\)|\]|')\?/i) { + checkwarn("NOSPACEQ", + $line, length($m)+1, $file, $l, + "missing space before question mark"); + } + } + # check spaces after question mark + if($nostr =~ /^(.*)\?\w/i) { + checkwarn("NOSPACEQ", + $line, length($1)+1, $file, $l, + "missing space after question mark"); + } + + # check spaces before less or greater than + if($nostr =~ /^(.*)(\w|\)|\])[<>]/) { + checkwarn("NOSPACETHAN", + $line, length($1)+1, $file, $l, + "missing space before less or greater than"); + } + # check spaces after less or greater than + if($nostr =~ /^(.*)[^-][<>](\w|\(|\[)/) { + checkwarn("NOSPACETHAN", + $line, length($1)+1, $file, $l, + "missing space after less or greater than"); + } + + # check spaces before close parentheses, unless it was a space or a + # close parenthesis! + if($l =~ /(.*[^\) ]) \)/) { + checkwarn("SPACEBEFORECLOSE", + $line, length($1)+1, $file, $l, + "space before close parenthesis"); + } + + # check spaces before comma! + if($l =~ /(.*[^ ]) ,/) { + checkwarn("SPACEBEFORECOMMA", + $line, length($1)+1, $file, $l, + "space before comma"); + } + + # check for "return(" without space + if($l =~ /^(.*\W)return\(/) { + if($1 =~ / *\#/) { + # this is a #if, treat it differently + } + else { + checkwarn("RETURNNOSPACE", $line, length($1)+6, $file, $l, + "return without space before paren"); + } + } + + # check for "return" with parentheses around a value/name + if($l =~ /^(.*\W)return \(\w*\);/) { + checkwarn("RETURNPAREN", $line, length($1)+7, $file, $l, + "return with paren"); + } + + # check for "sizeof" without parenthesis + if(($l =~ /^(.*)sizeof *([ (])/) && ($2 ne "(")) { + if($1 =~ / *\#/) { + # this is a #if, treat it differently + } + else { + checkwarn("SIZEOFNOPAREN", $line, length($1)+6, $file, $l, + "sizeof without parenthesis"); + } + } + + # check for comma without space + if($l =~ /^(.*),[^ \n]/) { + my $pref = $1; + my $ign = 0; + if($pref =~ / *\#/) { + # this is a #if, treat it differently + $ign = 1; + } + elsif($pref =~ /\/\*/) { + # this is a comment + $ign = 1; + } + elsif($pref =~ /[\"\']/) { + $ign = 1; + # There is a quote here, figure out whether the comma is + # within a string or '' or not. + if($pref =~ /\"/) { + # within a string + } + elsif($pref =~ /\'$/) { + # a single letter + } + else { + $ign = 0; + } + } + if(!$ign) { + checkwarn("COMMANOSPACE", $line, length($pref)+1, $file, $l, + "comma without following space"); + } + } + + # when the line starts with a brace + if($l =~ /^( *)\}/) { + my $tlen = length($1); + if($prevl =~ /^( *)(.)/) { + my $plen = length($1); + my $firstc = $2; + # skips the check if the previous line starts with a close + # brace since we see the occasional legit use of that oddity + if(($tlen + $indent) > $plen && ($firstc ne "}")) { + checkwarn("CLOSEBRACE", + $line, $plen, $file, $prevl, + "Suspicious close brace indentation"); + } + } + } + # check for "} else" + if($l =~ /^(.*)\} *else/) { + checkwarn("BRACEELSE", + $line, length($1), $file, $l, "else after closing brace on same line"); + } + # check for "){" + if($l =~ /^(.*)\)\{/) { + checkwarn("PARENBRACE", + $line, length($1)+1, $file, $l, "missing space after close paren"); + } + # check for "^{" with an empty line before it + if(($l =~ /^\{/) && ($prevl =~ /^[ \t]*\z/)) { + checkwarn("EMPTYLINEBRACE", + $line, 0, $file, $l, "empty line before open brace"); + } + + # check for space before the semicolon last in a line + if($l =~ /^(.*[^ ].*) ;$/) { + checkwarn("SPACESEMICOLON", + $line, length($1), $file, $ol, "no space before semicolon"); + } + + # check for space before the colon in a switch label + if($l =~ /^( *(case .+|default)) :/) { + checkwarn("SPACESWITCHCOLON", + $line, length($1), $file, $ol, "no space before colon of switch label"); + } + + if($prevl !~ /\?\z/ && $l =~ /^ +([A-Za-z_][A-Za-z0-9_]*):$/ && $1 ne 'default') { + checkwarn("SPACEBEFORELABEL", + $line, length($1), $file, $ol, "no space before label"); + } + + if($prevfreevar ne "") { + if(rindex($l, "$prevfreeindent$prevfreevar = NULL;", 0) == 0) { + checkwarn("USESAFEFREE", + $line, length($prevfreeindent), $file, $ol, + "replace curlx_free() + NULL assignment with curlx_safefree()"); + } + } + if($l) { + if($l =~ /^( *)curlx_free\(([^)]+)\);/) { + $prevfreeindent = $1; + $prevfreevar = $2; + } + else { + $prevfreeindent = ""; + $prevfreevar = ""; + } + } + + # scan for use of banned functions + my $bl = $l; + again: + if((($l =~ /^(.*?\W)(\w+)(\s*\()/x) && $banfunc{$2}) || + (($l =~ /^(.*?\()(\w+)(\s*\()/x) && $banfunc{$2})) { + my $bad = $2; + my $prefix = $1; + my $suff = $3; + if($prefix !~ /(->|\.)$/) { + checkwarn("BANNEDFUNC", + $line, length($prefix), $file, $ol, + "use of $bad is banned"); + } + my $search = quotemeta($prefix . $bad . $suff); + my $replace = $prefix . 'x' x (length($bad) + 1); + $l =~ s/$search/$replace/; + goto again; + } + $l = $bl; # restore to pre-bannedfunc content + + if($warnings{"STDERR"}) { + # scan for use of banned stderr. This is not a BANNEDFUNC to + # allow for individual enable/disable of this warning. + if($l =~ /^([^\"-]*\W)(stderr)[^\"_]/x) { + if($1 !~ /^ *\#/) { + # skip preprocessor lines + checkwarn("STDERR", + $line, length($1), $file, $ol, + "use of $2 is banned (use tool_stderr instead)"); + } + } + } + + # scan for use of non-binary fopen without the macro + if($l =~ /^(.*\W)(curlx_fopen|CURLX_FOPEN_LOW|curlx_freopen|CURLX_FREOPEN_LOW)\s*\([^,]*, *\"([^"]*)/) { + my $mode = $3; + if($mode !~ /b/) { + checkwarn("FOPENMODE", + $line, length($1), $file, $ol, + "use of non-binary fopen without FOPEN_* macro: $mode"); + } + } + + # check for open brace first on line but not first column only alert + # if previous line ended with a close paren and it was not a cpp line + if(($prevl =~ /\)\z/) && ($l =~ /^( +)\{/) && !$prevp) { + checkwarn("BRACEPOS", + $line, length($1), $file, $ol, "badly placed open brace"); + } + + # if the previous line starts with if/while/for AND ends with an open + # brace, or an else statement, check that this line is indented $indent + # more steps, if not a cpp line + if(!$prevp && ($prevl =~ /^( *)((if|while|for)\(.*\{|else)\z/)) { + my $first = length($1); + # this line has some character besides spaces + if($l =~ /^( *)[^ ]/) { + my $second = length($1); + my $expect = $first+$indent; + if($expect != $second) { + my $diff = $second - $first; + checkwarn("INDENTATION", $line, length($1), $file, $ol, + "not indented $indent steps (uses $diff)"); + } + } + } + + # if the previous line starts with if/while/for AND ends with a closed + # parenthesis and there is an equal number of open and closed + # parentheses, check that this line is indented $indent more steps, if + # not a cpp line + elsif(!$prevp && ($prevl =~ /^( *)(if|while|for)(\(.*\))\z/)) { + my $first = length($1); + my $op = $3; + my $cl = $3; + + $op =~ s/[^(]//g; + $cl =~ s/[^)]//g; + + if(length($op) == length($cl)) { + # this line has some character besides spaces + if($l =~ /^( *)[^ ]/) { + my $second = length($1); + my $expect = $first+$indent; + if($expect != $second) { + my $diff = $second - $first; + checkwarn("INDENTATION", $line, length($1), $file, $ol, + "not indented $indent steps (uses $diff)"); + } + } + } + } + + # check for 'char * name' + if(($l =~ /(^.*(char|int|long|void|CURL|CURLM|CURLMsg|[cC]url_[A-Za-z_]+|struct [a-zA-Z_]+) *(\*+)) (\w+)/) && ($4 !~ /^(const|volatile)$/)) { + checkwarn("ASTERISKSPACE", + $line, length($1), $file, $ol, + "space after declarative asterisk"); + } + # check for 'char*' + if(($l =~ /(^.*(char|int|long|void|curl_slist|CURL|CURLM|CURLMsg|curl_httppost|sockaddr_in|FILE)\*)/)) { + checkwarn("ASTERISKNOSPACE", + $line, length($1)-1, $file, $ol, + "no space before asterisk"); + } + + # check for 'void func() {', but avoid false positives by requiring + # both an open and closed parentheses before the open brace + if($l =~ /^((\w).*)\{\z/) { + my $k = $1; + $k =~ s/const *//; + $k =~ s/static *//; + if($k =~ /\(.*\)/) { + checkwarn("BRACEPOS", + $line, length($l)-1, $file, $ol, + "wrongly placed open brace"); + } + } + + # check for equals sign without spaces next to it + if($nostr =~ /(.*)\=[a-z0-9]/i) { + checkwarn("EQUALSNOSPACE", + $line, length($1)+1, $file, $ol, + "no space after equals sign"); + } + # check for equals sign without spaces before it + elsif($nostr =~ /(.*)[a-z0-9]\=/i) { + checkwarn("NOSPACEEQUALS", + $line, length($1)+1, $file, $ol, + "no space before equals sign"); + } + # check for equals sign with more than one space after it + elsif($l =~ /(.*)[a-z0-9] \= /i) { + checkwarn("EQUALSPACE", + $line, length($1)+3, $file, $ol, + "more than one space after equals sign"); + } + + # check for plus signs without spaces next to it + if($nostr =~ /(.*)[^+]\+[a-z0-9]/i) { + checkwarn("PLUSNOSPACE", + $line, length($1)+1, $file, $ol, + "no space after plus sign"); + } + # check for plus sign without spaces before it + elsif($nostr =~ /(.*)[a-z0-9]\+[^+]/i) { + checkwarn("NOSPACEPLUS", + $line, length($1)+1, $file, $ol, + "no space before plus sign"); + } + + # check for semicolons without space next to it + if($nostr =~ /(.*)\;[a-z0-9]/i) { + checkwarn("SEMINOSPACE", + $line, length($1)+1, $file, $ol, + "no space after semicolon"); + } + + # typedef struct ... { + if($nostr =~ /^(.*)typedef struct.*{/) { + checkwarn("TYPEDEFSTRUCT", + $line, length($1)+1, $file, $ol, + "typedef'ed struct"); + } + + if($nostr =~ /(.*)! +(\w|\()/) { + checkwarn("EXCLAMATIONSPACE", + $line, length($1)+1, $file, $ol, + "space after exclamation mark"); + } + + if($nostr =~ /(.*)\(void\)\!/) { + checkwarn("VOIDEXCL", + $line, length($1)+1, $file, $ol, + "exclamation after (void) is weird"); + } + + if($nostr =~ /(.*)\b(EACCES|EADDRINUSE|EADDRNOTAVAIL|EAFNOSUPPORT|EBADF|ECONNREFUSED|ECONNRESET|EINPROGRESS|EINTR|EINVAL|EISCONN|EMSGSIZE|ENOMEM|ETIMEDOUT|EWOULDBLOCK)\b/) { + checkwarn("ERRNOVAR", + $line, length($1), $file, $ol, + "use of bare errno define $2, use SOCK$2"); + } + + # check for more than one consecutive space before open brace or + # question mark. Skip lines containing strings since they make it hard + # due to artificially getting multiple spaces + if(($l eq $nostr) && + $nostr =~ /^(.*(\S)) + [{?]/i) { + checkwarn("MULTISPACE", + $line, length($1)+1, $file, $ol, + "multiple spaces"); + } + preproc: + if($prep) { + # scan for use of banned symbols on a preprocessor line + if($l =~ /^(^|.*\W) + (WIN32) + (\W|$) + /x) { + checkwarn("BANNEDPREPROC", + $line, length($1), $file, $ol, + "use of $2 is banned from preprocessor lines" . + (($2 eq "WIN32") ? ", use _WIN32 instead" : "")); + } + } + $line++; + $prevp = $prep; + $prevl = $ol if(!$prep); + $prevpl = $ol if($prep); + } + + if(!scalar(@copyright)) { + checkwarn("COPYRIGHT", 1, 0, $file, "", "Missing copyright statement", 1); + } + + # COPYRIGHTYEAR is an extended warning so we must first see if it has been + # enabled in .checksrc + if(defined($warnings{"COPYRIGHTYEAR"})) { + # The check for updated copyrightyear is overly complicated in order to + # not punish current hacking for past sins. The copyright years are + # right now a bit behind, so enforcing copyright year checking on all + # files would cause hundreds of errors. Instead we only look at files + # which are tracked in the Git repo and edited in the workdir, or + # committed locally on the branch without being in upstream master. + # + # The simple and naive test is to check for the current year, + # but updating the year even without an edit is against project policy + # (and it would fail every file on January 1st). + # + # A rather more interesting, and correct, check would be to not test + # only locally committed files but inspect all files wrt the year of + # their last commit. Removing the `git rev-list origin/master..HEAD` + # condition below enforces copyright year checks against the year + # the file was last committed (and thus edited to some degree). + my $commityear = undef; + @copyright = sort {$$b{year} cmp $$a{year}} @copyright; + + # if the file is modified, assume commit year this year + if(qx(git status -s -- "$file") =~ /^ [MARCU]/) { + $commityear = (localtime(time))[5] + 1900; + } + else { + # min-parents=1 to ignore wrong initial commit in truncated repos + my $grl = qx(git rev-list --max-count=1 --min-parents=1 --timestamp HEAD -- "$file"); + if($grl) { + chomp $grl; + $commityear = (localtime((split(/ /, $grl))[0]))[5] + 1900; + } + } + + if(defined($commityear) && scalar(@copyright) && + $copyright[0]{year} != $commityear) { + checkwarn("COPYRIGHTYEAR", $copyright[0]{line}, $copyright[0]{col}, + $file, $copyright[0]{code}, + "Copyright year out of date, should be $commityear, " . + "is $copyright[0]{year}", 1); + } + } + + if($incomment) { + checkwarn("OPENCOMMENT", 1, 0, $file, "", "Missing closing comment", 1); + } + + checksrc_endoffile($file); + + close($R); +} + +if($errors || $warnings || $verbose) { + printf "checksrc: %d errors and %d warnings\n", $errors, $warnings; + if($suppressed) { + printf "checksrc: %d errors and %d warnings suppressed\n", + $serrors, + $swarnings; + } + if($errors || $warnings) { + exit 5; # return failure + } +} diff --git a/3rdparty/curl-8.21.0/scripts/cmakelint.sh b/3rdparty/curl-8.21.0/scripts/cmakelint.sh new file mode 100755 index 0000000000..3fe258346d --- /dev/null +++ b/3rdparty/curl-8.21.0/scripts/cmakelint.sh @@ -0,0 +1,79 @@ +#!/bin/sh +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Dan Fandrich, , Viktor Szakats, et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### + +# https://cmake-format.readthedocs.io/en/latest/cmake-lint.html +# https://cmake-format.readthedocs.io/en/latest/lint-usage.html +# https://github.com/cheshirekow/cmake_format/blob/master/cmakelang/configuration.py + +# Run cmakelint on the curl source code. It checks all files given on the +# command-line, or else all relevant files in git, or if not in a git +# repository, all files starting in the tree rooted in the current directory. +# +# cmake-lint can be installed from PyPi with the command "python3 -m pip +# install cmakelang". +# +# The xargs invocation is portable, but does not preserve spaces in filenames. +# If such a file is ever added, then this can be portably fixed by switching to +# "xargs -I{}" and appending {} to the end of the xargs arguments (which calls +# cmakelint once per file) or by using the GNU extension "xargs -d'\n'". + +set -eu + +cd "$(dirname "$0")"/.. + +{ + if [ -n "${1:-}" ]; then + for A in "$@"; do printf '%s\n' "$A"; done + elif git rev-parse --is-inside-work-tree >/dev/null 2>&1; then + git ls-files '**CMakeLists.txt' '*.cmake' + else + find . -type f \( -name 'CMakeLists.txt' -o -name '*.cmake' \) + fi +} | sort | xargs \ + cmake-lint \ + --suppress-decorations \ + --disable \ + --line-width 132 \ + --tab-size 2 \ + --use-tabchars false \ + --disabled-codes C0113 \ + --function-pattern 'curl_[0-9a-z_]+' \ + --macro-pattern '(curl_[0-9a-z_]+|check_include_file_concat_curl)' \ + --global-var-pattern '[A-Z][0-9A-Z_]+' \ + --internal-var-pattern '_[a-z][0-9a-z_]+' \ + --local-var-pattern '_[a-z][0-9a-z_]+' \ + --private-var-pattern '_[0-9a-z_]+' \ + --public-var-pattern '([A-Z][0-9A-Z_]+|[A-Z][A-Za-z0-9]+_FOUND|[a-z]+_SOURCES|prefix|exec_prefix|includedir|libdir|ssize_t|_FILE_OFFSET_BITS)' \ + --argument-var-pattern '_[a-z][0-9a-z_]+' \ + --keyword-pattern '[A-Z][0-9A-Z_]+' \ + --max-conditionals-custom-parser 2 \ + --min-statement-spacing 1 \ + --max-statement-spacing 2 \ + --max-returns 6 \ + --max-branches 20 \ + --max-arguments 5 \ + --max-localvars 15 \ + --max-statements 95 \ + -- diff --git a/3rdparty/curl-8.21.0/scripts/completion.pl b/3rdparty/curl-8.21.0/scripts/completion.pl new file mode 100755 index 0000000000..203f2acfb6 --- /dev/null +++ b/3rdparty/curl-8.21.0/scripts/completion.pl @@ -0,0 +1,178 @@ +#!/usr/bin/env perl +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### + +use strict; +use warnings; +use Getopt::Long(); +use Pod::Usage(); + +my $opts_dir = '../docs/cmdline-opts'; +my $shell = 'zsh'; +my $help = 0; +Getopt::Long::GetOptions( + 'opts-dir=s' => \$opts_dir, + 'shell=s' => \$shell, + 'help' => \$help, +) or Pod::Usage::pod2usage(); +Pod::Usage::pod2usage() if $help; + +my @opts = parse_main_opts($opts_dir); + +if($shell eq 'fish') { + print "# curl fish completion\n\n"; + print "# Complete file paths after @\n"; + print q(complete -c curl -n 'string match -qr "^@" -- (commandline -ct)' -k -xa "(printf '%s\n' -- @(__fish_complete_suffix --complete=(commandline -ct | string replace -r '^@' '') ''))"); + print "\n\n"; + print qq{$_ \n} foreach (@opts); +} elsif($shell eq 'zsh') { + my $opts_str; + + $opts_str .= qq{ $_ \\\n} foreach (@opts); + chomp $opts_str; + + my $tmpl = <<"EOS"; +#compdef curl + +# curl zsh completion + +local curcontext="\$curcontext" state state_descr line +typeset -A opt_args + +local rc=1 + +_arguments -C -S \\ +$opts_str + '*:URL:_urls' && rc=0 + +return rc +EOS + + print $tmpl; +} else { + die("Unsupported shell: $shell"); +} + +sub parse_main_opts { + my ($opts_dir) = @_; + + my (@files, @list); + my ($dir_handle, $file_content); + + opendir($dir_handle, $opts_dir) or die "Unable to open dir: $opts_dir due to error: $!"; + @files = readdir($dir_handle); + closedir($dir_handle) or die "Unable to close handle on dir: $opts_dir due to error: $!"; + + # We want regular files that end with .md and do not start with an underscore + # Edge case: MANPAGE.md does not start with an underscore but also is not documentation for an option + @files = grep { $_ =~ /\.md$/i && !/^_/ && -f "$opts_dir/$_" && $_ ne "MANPAGE.md" } @files; + + for my $file (@files) { + open(my $doc_handle, '<', "$opts_dir/$file") or die "Unable to open file: $file due to error: $!"; + $file_content = join('', <$doc_handle>); + close($doc_handle) or die "Unable to close file: $file due to error: $!"; + + # Extract the curldown header section demarcated by --- + $file_content =~ /^---\s*\n(.*?)\n---\s*\n/s or die "Unable to parse file $file"; + + $file_content = $1; + my ($short, $long, $arg, $desc); + + if($file_content =~ /^Short:\s+(.*)\s*$/im) {$short = "-$1";} + if($file_content =~ /^Long:\s+(.*)\s*$/im) {$long = "--$1";} + if($file_content =~ /^Arg:\s+(.*)\s*$/im) {$arg = $1;} + if($file_content =~ /^Help:\s+(.*)\s*$/im) {$desc = $1;} + + $arg =~ s/\:/\\\:/g if defined $arg; + $desc =~ s/'/'\\''/g if defined $desc; + $desc =~ s/\[/\\\[/g if defined $desc; + $desc =~ s/\]/\\\]/g if defined $desc; + $desc =~ s/\:/\\\:/g if defined $desc; + + my $option = ''; + + if($shell eq 'fish') { + $option .= "complete --command curl"; + $option .= " --short-option '" . strip_dash(trim($short)) . "'" + if defined $short; + $option .= " --long-option '" . strip_dash(trim($long)) . "'" + if defined $long; + $option .= " --description '" . strip_dash(trim($desc)) . "'" + if defined $desc; + } elsif($shell eq 'zsh') { + $option .= '{' . trim($short) . ',' if defined $short; + $option .= trim($long) if defined $long; + $option .= '}' if defined $short; + $option .= '\'[' . trim($desc) . ']\'' if defined $desc; + + if(defined $arg) { + $option .= ":'$arg'"; + if($arg =~ /|/) { + $option .= ':_files'; + } elsif($arg =~ //) { + $option .= ":'_path_files -/'"; + } elsif($arg =~ //i) { + $option .= ':_urls'; + } elsif($long =~ /ftp/ && $arg =~ //) { + $option .= ":'(multicwd nocwd singlecwd)'"; + } elsif($arg =~ //) { + $option .= ":'(DELETE GET HEAD POST PUT)'"; + } + } + } + + push(@list, $option); + } + + # Sort longest first, because zsh does not complete an option listed + # after one that is a prefix of it. When length is equal, fall back + # to stringwise cmp. + @list = sort { + $a =~ /([^=]*)/; my $ma = $1; + $b =~ /([^=]*)/; my $mb = $1; + + length($mb) <=> length($ma) || $ma cmp $mb + } @list; + + return @list; +} + +sub trim { my $s = shift; $s =~ s/^\s+|\s+$//g; return $s }; +sub strip_dash { my $s = shift; $s =~ s/^-+//g; return $s }; + +__END__ + +=head1 NAME + +completion.pl - Generates tab-completion files for various shells + +=head1 SYNOPSIS + +completion.pl [options...] + + --opts-dir path to cmdline-opts directory + --shell zsh/fish + --help prints this help + +=cut diff --git a/3rdparty/curl-8.21.0/scripts/coverage.sh b/3rdparty/curl-8.21.0/scripts/coverage.sh new file mode 100755 index 0000000000..b5540568ff --- /dev/null +++ b/3rdparty/curl-8.21.0/scripts/coverage.sh @@ -0,0 +1,41 @@ +#!/bin/sh +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### + +set -eu + +autoreconf -fi +mkdir -p cvr +cd cvr +../configure --disable-shared --enable-debug --enable-maintainer-mode --enable-code-coverage +make -sj +# the regular test run +make TFLAGS=-n test-nonflaky +# make all allocs/file operations fail +#make TFLAGS=-n test-torture +# do everything event-based +make TFLAGS=-n test-event +lcov -d . -c -o cov.lcov +genhtml cov.lcov --output-directory coverage --title "curl code coverage" +tar -cjf curl-coverage.tar.bz2 coverage diff --git a/3rdparty/curl-8.21.0/scripts/dmaketgz b/3rdparty/curl-8.21.0/scripts/dmaketgz new file mode 100755 index 0000000000..fb7bfef2aa --- /dev/null +++ b/3rdparty/curl-8.21.0/scripts/dmaketgz @@ -0,0 +1,55 @@ +#!/bin/sh +# docker-maketgz +# +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### + +set -eu + +version="${1:-}" + +if [ -z "$version" ]; then + echo "Specify a version number!" + exit +fi + +timestamp="${2:-$(date -u +%s)}" + +if test -f Makefile; then + make distclean +fi +docker build \ + --no-cache \ + --build-arg SOURCE_DATE_EPOCH="$timestamp" \ + --build-arg UID="$(id -u)" \ + --build-arg GID="$(id -g)" \ + -t curl/curl . + +docker run --rm -u "$(id -u):$(id -g)" \ + -v "$(pwd):/usr/src" -w /usr/src curl/curl sh -c " + set -e + autoreconf -fi + ./configure --without-ssl --without-libpsl + make -sj8 + ./scripts/maketgz $version" diff --git a/3rdparty/curl-8.21.0/scripts/extract-unit-protos b/3rdparty/curl-8.21.0/scripts/extract-unit-protos new file mode 100755 index 0000000000..79c6605794 --- /dev/null +++ b/3rdparty/curl-8.21.0/scripts/extract-unit-protos @@ -0,0 +1,151 @@ +#!/usr/bin/env perl +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### + +use strict; +use warnings; + +my @proto; +my %func; +my %inc; +my %test; +my %from; +my $error; + +sub scanfile { + my ($file) = @_; + open(F, "<$file") or die "$file failed"; + my $unit = 0; + my $line = 0; + my $unitref = 0; + my $unittest = 0; + while() { + $line++; + my $full = $_; + if($_ =~ /\@unittest (\d+)/) { + $unittest = $1; + $unitref = $line; # store line number + } + if($_ =~ /^UNITTEST .*[* ]([a-z0-9_]+)\(/i) { + my $n = $1; + if($func{$n}) { + # already prototyped, this is now the function itself + } + else { + if($n =~ /^Curl_/) { + print STDERR "$file:$line:1: warn: $n is Curl_ prefixed?\n"; + $error++; + } + if(($line - $unitref) > 10) { + print STDERR "$file:$line:1: warn: Missing \@unittest reference?\n"; + $error++; + } + else { + $test{$full} = $unittest; + $from{$full} = "$file:$line"; + } + + $func{$n} = 1; + push @proto, $_; + $inc{$file} = 1; + $unit = 1; + } + } + if($unit) { + if($unit != 1) { + push @proto, $_; + } + if($_ =~ /\);/) { + # end of proto + $unit = 0; + } + else { + # proto continues + $unit++; + } + } + } + close(F); +} + +foreach my $f (@ARGV) { + scanfile($f); +} + +if($error) { + exit 1; +} + +print <, et al. + * + * This software is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at https://curl.se/docs/copyright.html. + * + * You may opt to use, copy, modify, merge, publish, distribute and/or sell + * copies of the Software, and permit persons to whom the Software is + * furnished to do so, under the terms of the COPYING file. + * + * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY + * KIND, either express or implied. + * + * SPDX-License-Identifier: curl + * + * Generated-by: extract-unit-protos + * + ***************************************************************************/ +HEAD + ; + +for my $f (sort keys %inc) { + # convert to suitable header file + $f =~ s/\.c/.h/; # .h extension + + if(-f $f) { + print "#include \"$f\"\n"; + } +} + +for my $p (@proto) { + if($test{$p}) { + printf "\n/* for unit test %d from %s */\n", + $test{$p}, $from{$p}; + } + print $p; +} + +print <, et al. +# * +# * This software is licensed as described in the file COPYING, which +# * you should have received as part of this distribution. The terms +# * are also available at https://curl.se/docs/copyright.html. +# * +# * You may opt to use, copy, modify, merge, publish, distribute and/or sell +# * copies of the Software, and permit persons to whom the Software is +# * furnished to do so, under the terms of the COPYING file. +# * +# * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# * KIND, either express or implied. +# * +# * SPDX-License-Identifier: curl +# * +# *************************************************************************** +# This shell script creates a fresh ca-bundle.crt file for use with libcurl. +# It extracts all CA certs it finds in the local Firefox database and converts +# them all into PEM format. +# +# It uses the "certutil" command line tool from the NSS project to perform the +# conversion. On Debian it comes in the "libnss3-tools" package. +# + +set -eu + +if [ -d "$HOME/Library/Application Support"/Firefox/Profiles ]; then + db=$(ls -1d "$HOME/Library/Application Support"/Firefox/Profiles/*default*) +else + db=$(ls -1d "$HOME"/.mozilla/firefox/*default*) +fi +out="${1:-}" + +if test -z "$out"; then + out="ca-bundle.crt" # use a sensible default +fi + +currentdate=$(date) + +cat > "$out" <> "$out" diff --git a/3rdparty/curl-8.21.0/scripts/maketgz b/3rdparty/curl-8.21.0/scripts/maketgz new file mode 100755 index 0000000000..e6bc53dcdc --- /dev/null +++ b/3rdparty/curl-8.21.0/scripts/maketgz @@ -0,0 +1,246 @@ +#!/bin/sh +# Script to build release-archives with. Note that this requires a checkout +# from git and you should first run autoreconf -fi and build curl once. +# +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### + +set -eu + +export LC_ALL=C +export TZ=UTC + +version="${1:-}" +cmd="${2:-}" + +if [ -z "$version" ]; then + echo "Specify a version number!" + exit +fi + +echo "$cmd" + +only="" +if [ "only" = "$cmd" ]; then + echo "Setup version number only!" + only=1 +fi + +commit="" +if [ "commit" = "$cmd" ]; then + commit=1 +fi + +libversion="$version" + +# we make curl the same version as libcurl +curlversion="$libversion" + +major=$(echo "$libversion" | cut -d. -f1 | sed -e "s/[^0-9]//g") +minor=$(echo "$libversion" | cut -d. -f2 | sed -e "s/[^0-9]//g") +patch=$(echo "$libversion" | cut -d. -f3 | cut -d- -f1 | sed -e "s/[^0-9]//g") + +if test -z "$patch"; then + echo "invalid version number? needs to be z.y.z" + exit +fi + +# +# As a precaution, remove all *.dist files that may be lying around, to reduce +# the risk of old leftovers getting shipped. +echo "removing all old *.dist files" +find . -name "*.dist" -exec rm -- {} \; + +numeric="$(printf "%02x%02x%02x\n" "$major" "$minor" "$patch")" + +HEADER=include/curl/curlver.h +CHEADER=src/tool_version.h + +if test -z "$only"; then + ext=".dist" + # when not setting up version numbers locally + for a in $HEADER $CHEADER; do + cp "$a" "$a$ext" + done + HEADER="$HEADER$ext" + CHEADER="$CHEADER$ext" +fi + +# requires a date command that knows + for format and -d for date input +timestamp=${SOURCE_DATE_EPOCH:-$(date +"%s")} +datestamp=$(date -d "@$timestamp" +"%F") +filestamp=$(date -d "@$timestamp" +"%Y%m%d%H%M.%S") + +# Replace version number in header file: +sed -i \ + -e "s/^#define LIBCURL_VERSION .*/#define LIBCURL_VERSION \"$libversion\"/g" \ + -e "s/^#define LIBCURL_VERSION_NUM .*/#define LIBCURL_VERSION_NUM 0x$numeric/g" \ + -e "s/^#define LIBCURL_VERSION_MAJOR .*/#define LIBCURL_VERSION_MAJOR $major/g" \ + -e "s/^#define LIBCURL_VERSION_MINOR .*/#define LIBCURL_VERSION_MINOR $minor/g" \ + -e "s/^#define LIBCURL_VERSION_PATCH .*/#define LIBCURL_VERSION_PATCH $patch/g" \ + -e "s/^#define LIBCURL_TIMESTAMP .*/#define LIBCURL_TIMESTAMP \"$datestamp\"/g" \ + "$HEADER" + +# Replace version number in header file: +sed -i "s/#define CURL_VERSION .*/#define CURL_VERSION \"$curlversion\"/g" "$CHEADER" + +if test -n "$only"; then + # done! + exit +fi + +echo "curl version $curlversion" +echo "libcurl version $libversion" +echo "libcurl numerical $numeric" +echo "datestamp $datestamp" + +findprog() { + file="$1" + for part in $(echo "$PATH" | tr ':' ' '); do + path="$part/$file" + if [ -x "$path" ]; then + # there it is! + return 1 + fi + done + + # no such executable + return 0 +} + +############################################################################ +# +# Enforce a rerun of configure (updates the VERSION) +# + +echo "Re-running config.status" +./config.status --recheck >/dev/null + +echo "Recreate the built-in manual (with correct version)" +export CURL_MAKETGZ_VERSION="$version" +rm -f docs/cmdline-opts/curl.txt +make -C src + +############################################################################ +# +# automake is needed to run to make a non-GNU Makefile.in if Makefile.am has +# been modified. +# + +if { findprog automake >/dev/null 2>/dev/null; } then + echo "- Could not find or run automake, I hope you know what you are doing!" +else + echo "Runs automake --include-deps" + automake --include-deps Makefile >/dev/null +fi + +if test -n "$commit"; then + echo "produce docs/tarball-commit.txt" + git rev-parse HEAD >docs/tarball-commit.txt.dist +fi + +echo "produce RELEASE-TOOLS.md" +./scripts/release-tools.sh "$timestamp" "$version" "$commit" > docs/RELEASE-TOOLS.md.dist + +############################################################################ +# +# Now run make dist to generate a tar.gz archive +# + +echo "make dist" +targz="curl-$version.tar.gz" +make -sj dist "VERSION=$version" +res=$? + +if test "$res" != 0; then + echo "make dist failed" + exit 2 +fi + +retar() { + tempdir=$1 + rm -rf "$tempdir" + mkdir "$tempdir" + cd "$tempdir" + gzip -dc "../$targz" | tar -xf - + find curl-* -depth -exec touch -c -t "$filestamp" -- '{}' + + tar --create --format=ustar --owner=0 --group=0 --numeric-owner --sort=name curl-* | gzip --best --no-name > out.tar.gz + mv out.tar.gz ../ + cd .. + rm -rf "$tempdir" +} + +retar ".tarbuild" +echo "replace $targz with out.tar.gz" +mv out.tar.gz "$targz" + +############################################################################ +# +# Now make a bz2 archive from the tar.gz original +# + +bzip2="curl-$version.tar.bz2" +echo "Generating $bzip2" +gzip -dc "$targz" | bzip2 --best > "$bzip2" + +############################################################################ +# +# Now make an xz archive from the tar.gz original +# + +xz="curl-$version.tar.xz" +echo "Generating $xz" +gzip -dc "$targz" | xz -6e - > "$xz" + +############################################################################ +# +# Now make a zip archive from the tar.gz original +# +makezip() { + rm -rf "$tempdir" + mkdir "$tempdir" + cd "$tempdir" + gzip -dc "../$targz" | tar -xf - + find . | sort | zip -9 -X "$zip" -@ >/dev/null + mv "$zip" ../ + cd .. + rm -rf "$tempdir" +} + +zip="curl-$version.zip" +echo "Generating $zip" +tempdir=".builddir" +makezip + +# Set deterministic timestamp +touch -c -t "$filestamp" "$targz" "$bzip2" "$xz" "$zip" + +echo "------------------" +echo "maketgz report:" +echo "" +ls -l "$targz" "$bzip2" "$xz" "$zip" +sha256sum "$targz" "$bzip2" "$xz" "$zip" + +echo "Run this:" +echo "gpg -b -a '$targz' && gpg -b -a '$bzip2' && gpg -b -a '$xz' && gpg -b -a '$zip'" diff --git a/3rdparty/curl-8.21.0/scripts/managen b/3rdparty/curl-8.21.0/scripts/managen new file mode 100755 index 0000000000..2bf1c3d75d --- /dev/null +++ b/3rdparty/curl-8.21.0/scripts/managen @@ -0,0 +1,1383 @@ +#!/usr/bin/env perl +#*************************************************************************** +# _ _ ____ _ +# Project ___| | | | _ \| | +# / __| | | | |_) | | +# | (__| |_| | _ <| |___ +# \___|\___/|_| \_\_____| +# +# Copyright (C) Daniel Stenberg, , et al. +# +# This software is licensed as described in the file COPYING, which +# you should have received as part of this distribution. The terms +# are also available at https://curl.se/docs/copyright.html. +# +# You may opt to use, copy, modify, merge, publish, distribute and/or sell +# copies of the Software, and permit persons to whom the Software is +# furnished to do so, under the terms of the COPYING file. +# +# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# KIND, either express or implied. +# +# SPDX-License-Identifier: curl +# +########################################################################### + +=begin comment + +This script generates the man page. + +Example: managen [files] > curl.1 + +Dev notes: + +We open *input* files in :crlf translation (a no-op on many platforms) in +case we have CRLF line endings in Windows but a perl that defaults to LF. +Unfortunately it seems some perls like msysgit cannot handle a global input-only +:crlf so it has to be specified on each file open for text input. + +=end comment +=cut + +use strict; +use warnings; + +my %optshort; +my %optlong; +my %helplong; +my %arglong; +my %redirlong; +my %protolong; +my %catlong; + +use POSIX qw(strftime); +my @ts; +if(defined($ENV{SOURCE_DATE_EPOCH})) { + @ts = gmtime($ENV{SOURCE_DATE_EPOCH}); +} else { + @ts = localtime; +} +my $date = strftime "%Y-%m-%d", @ts; +my $year = strftime "%Y", @ts; +my $version = "unknown"; +my $globals; +my $error = 0; +my $indent = 4; + +# get the long name version, return the man page string +sub manpageify { + my ($k, $manpage) = @_; + my $trail = ''; + # the matching pattern might include a trailing dot that cannot be part of + # the option name + if($k =~ s/\.$//) { + # cut off trailing dot + $trail = "."; + } + if($manpage) { + my $klong = $k; + # quote "bare" minuses in the long name + $klong =~ s/-/\\-/g; + + # only long + return "\\fI\\-\\-$klong\\fP$trail"; + } + return "--$k$trail"; +} + +my $colwidth = 79; # max number of columns + +sub prefixline { + my ($num) = @_; + print "\t" x ($num / 8); + print ' ' x ($num % 8); +} + +sub justline { + my ($lvl, @line) = @_; + my $w = -1; + my $spaces = -1; + my $width = $colwidth - ($lvl * $indent); + for(@line) { + $w += length($_); + $w++; + $spaces++; + } + my $inject = $width - $w; + my $ratio = 0; # stay at zero if no spaces at all + if($spaces) { + $ratio = $inject / $spaces; + } + my $spare = 0; + prefixline($lvl * $indent); + my $prev; + for(@line) { + while($spare >= 0.90) { + print " "; + $spare--; + } + printf "%s%s", $prev ? " " : "", $_; + $prev = 1; + $spare += $ratio; + } + print "\n"; +} + +sub lastline { + my ($lvl, @line) = @_; + my $l = 0; + $line[0] =~ s/^( +)//; + $l = length($1) if($1); + prefixline($lvl * $indent + $l); + my $prev = 0; + for(@line) { + printf "%s%s", $prev ? " " : "", $_; + $prev = 1; + } + print "\n"; +} + +sub outputpara { + my ($lvl, $f) = @_; + $f =~ s/\n/ /g; + + my $w = 0; + my @words = split(/ */, $f); + my $width = $colwidth - ($lvl * $indent); + + my @line; + for my $e (@words) { + my $l = length($e); + my $spaces = scalar(@line); + if(($w + $l + $spaces) >= $width) { + justline($lvl, @line); + undef @line; + $w = 0; + } + + push @line, $e; + $w += $l; # new width + } + if($w) { + lastline($lvl, @line); + print "\n"; + } +} + +sub printdesc { + my ($manpage, $baselvl, @desc) = @_; + + if($manpage) { + for my $d (@desc) { + print $d; + } + } + else { + my $p = -1; + my $pnum; + my $para = ''; + for my $l (@desc) { + my $lvl = 0; + my $lvlnum; + if($l !~ /^[\n\r]+/) { + # get the indent level off the string + $l =~ s/^\[([0-9q]*)\]//; + $lvl = $1; + } + if(($p =~ /q/) && ($lvl !~ /q/)) { + # the previous was quoted, this is not + print "\n"; + } + if($lvl ne $p) { + $pnum = $p; + $pnum =~ s/q$//; + outputpara($baselvl + $pnum, $para); + $para = ""; + } + if($lvl =~ /q/) { + # quoted, do not right-justify + chomp $l; + $lvlnum = $lvl; + $lvlnum =~ s/q$//; + lastline($baselvl + $lvlnum + 1, $l); + my $w = ($baselvl + $lvlnum + 1) * $indent + length($l); + if($w > $colwidth) { + print STDERR "ERROR: $w columns is too long\n"; + print STDERR "$l\n"; + $error++; + } + } + else { + $para .= $l; + } + + $p = $lvl; + } + $pnum = $p; + $pnum =~ s/q$//; + outputpara($baselvl + $pnum, $para); + } +} + +sub seealso { + my($standalone, $data) = @_; + if($standalone) { + return sprintf + ".SH \"SEE ALSO\"\n$data\n"; + } + else { + return "See also $data. "; + } +} + +sub overrides { + my ($standalone, $data) = @_; + if($standalone) { + return ".SH \"OVERRIDES\"\n$data\n"; + } + else { + return $data; + } +} + +my %protexists = ( + 'DNS' => 1, + 'FILE' => 1, + 'FTP' => 1, + 'FTPS' => 1, + 'GSS/kerberos' => 1, + 'HTTP' => 1, + 'HTTPS' => 1, + 'IMAP' => 1, + 'IPFS' => 1, + 'LDAP' => 1, + 'MQTT' => 1, + 'POP3' => 1, + 'SCP' => 1, + 'SFTP' => 1, + 'SMTP' => 1, + 'SSL' => 2, # deprecated + 'TELNET' => 1, + 'TFTP' => 1, + 'TLS' => 1, + ); + +sub protocols { + my ($f, $line, $manpage, $standalone, $data) = @_; + my @e = split(/ +/, $data); + for my $pr (@e) { + if(!$protexists{$pr}) { + + print STDERR "$f:$line:1:ERROR: unrecognized protocol: $pr\n"; + exit 2; + } + } + if($standalone) { + return ".SH \"PROTOCOLS\"\n$data\n"; + } + else { + return "($data) " if($manpage); + return "[1]($data) " if(!$manpage); + } +} + +sub too_old { + my ($version) = @_; + my $a = 999999; + if($version =~ /^(\d+)\.(\d+)\.(\d+)/) { + $a = $1 * 1000 + $2 * 10 + $3; + } + elsif($version =~ /^(\d+)\.(\d+)/) { + $a = $1 * 1000 + $2 * 10; + } + if($a < 7660) { + # we consider everything before 7.66.0 to be too old to mention + # specific changes for + return 1; + } + return 0; +} + +sub added { + my ($standalone, $data) = @_; + if(too_old($data)) { + # do not mention ancient additions + return ""; + } + if($standalone) { + return ".SH \"ADDED\"\nAdded in curl version $data\n"; + } + else { + return "Added in $data. "; + } +} + +sub render { + my ($manpage, $fh, $f, $line) = @_; + my @desc; + my $tablemode = 0; + my $header = 0; + # if $top is TRUE, it means a top-level page and not a command line option + my $top = ($line == 1); + my $quote = 0; + my $level = 0; + my $finalblank; + my $blankline = 0; + my $start = 0; + + while(<$fh>) { + my $d = $_; + $line++; + $finalblank = ($d eq "\n"); + if($d =~ /^\.(SH|BR|IP|B)/) { + print STDERR "$f:$line:1:ERROR: nroff instruction in input: \".$1\"\n"; + return 4; + } + if(/^ *>>>> - - >>> - - >>> - - \; - - |>>> - - \; - - -<\initial> - <\collection> - - - \ No newline at end of file diff --git a/TeXmacs/packages/standard/std-symbol.stem b/TeXmacs/packages/standard/std-symbol.stem new file mode 100644 index 0000000000..dfd02f91cb --- /dev/null +++ b/TeXmacs/packages/standard/std-symbol.stem @@ -0,0 +1,209 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; MODULE : std-symbol.stem +;; COPYRIGHT : (C) 1998--2025 Joris van der Hoeven, Darcy Shen +;; +;; This software falls under the GNU general public license version 3 or later. +;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE +;; in the root directory or . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(document (TeXmacs "2.1.4") + (style (tuple "source" "std")) + (body (document (active* (src-title (document (src-package "std-symbol" "1.0") + (src-purpose (document "Some additional symbols for text mode. This file should become obsolete when better support for Unicode will be implemented." + ) ;document + ) ;src-purpose + ) ;document + ) ;src-title + ) ;active* + (assign "cent" + (macro (active* (if (equal (value "mode") "math") + (with "mode" "text" "mode" "text" "font" "tc" "ć") + (with "mode" "text" "font" "tc" "ć") + ) ;if + ) ;active* + ) ;macro + ) ;assign + (assign "currency" + (macro (active* (if (equal (value "mode") "math") + (with "mode" "text" "mode" "text" "font" "tc" "ď") + (with "mode" "text" "font" "tc" "ď") + ) ;if + ) ;active* + ) ;macro + ) ;assign + (assign "yen" + (macro (active* (if (equal (value "mode") "math") + (with "mode" "text" "mode" "text" "font" "tc" "ě") + (with "mode" "text" "font" "tc" "ě") + ) ;if + ) ;active* + ) ;macro + ) ;assign + (assign "copyright" + (macro (active* (if (equal (value "mode") "math") + (with "mode" "text" "mode" "text" "font" "tcx" "ľ") + (with "mode" "text" "font" "tcx" "ľ") + ) ;if + ) ;active* + ) ;macro + ) ;assign + (assign "copyleft" + (macro (active* (if (equal (value "mode") "math") + (with "mode" "text" "mode" "text" "font" "tcx" "ń") + (with "mode" "text" "font" "tcx" "ń") + ) ;if + ) ;active* + ) ;macro + ) ;assign + (assign "registered" + (macro (active* (if (equal (value "mode") "math") + (with "mode" "text" "mode" "text" "font" "tcx" "ő") + (with "mode" "text" "font" "tcx" "ő") + ) ;if + ) ;active* + ) ;macro + ) ;assign + (assign "degreesign" + (macro (active* (if (equal (value "mode") "math") + (with "mode" "text" "mode" "text" "font" "tc" "ř") + (with "mode" "text" "font" "tc" "ř") + ) ;if + ) ;active* + ) ;macro + ) ;assign + (assign "twosuperior" + (macro (active* (if (equal (value "mode") "math") + (with "mode" "text" "mode" "text" "font" "tc" "š") + (with "mode" "text" "font" "tc" "š") + ) ;if + ) ;active* + ) ;macro + ) ;assign + (assign "threesuperior" + (macro (active* (if (equal (value "mode") "math") + (with "mode" "text" "mode" "text" "font" "tc" "ş") + (with "mode" "text" "font" "tc" "ş") + ) ;if + ) ;active* + ) ;macro + ) ;assign + (assign "onesuperior" + (macro (active* (if (equal (value "mode") "math") + (with "mode" "text" "mode" "text" "font" "tc" "ź") + (with "mode" "text" "font" "tc" "ź") + ) ;if + ) ;active* + ) ;macro + ) ;assign + (assign "mu" + (macro (active* (if (equal (value "mode") "math") + (with "mode" "text" "mode" "text" "font" "tcx" "ţ") + (with "mode" "text" "font" "tcx" "ţ") + ) ;if + ) ;active* + ) ;macro + ) ;assign + (assign "paragraphsign" + (active* (macro (if (equal (value "mode") "math") + (with "mode" "text" "mode" "text" "font" "tc" "ű") + (with "mode" "text" "font" "tc" "ű") + ) ;if + ) ;macro + ) ;active* + ) ;assign + (assign "onequarter" + (macro (active* (if (equal (value "mode") "math") + (with "mode" "text" "mode" "text" "font" "tc" "ij") + (with "mode" "text" "font" "tc" "ij") + ) ;if + ) ;active* + ) ;macro + ) ;assign + (assign "onehalf" + (macro (active* (if (equal (value "mode") "math") + (with "mode" "text" "mode" "text" "font" "tc" "¡") + (with "mode" "text" "font" "tc" "¡") + ) ;if + ) ;active* + ) ;macro + ) ;assign + (assign "threequarters" + (macro (active* (if (equal (value "mode") "math") + (with "mode" "text" "mode" "text" "font" "tc" "¿") + (with "mode" "text" "font" "tc" "¿") + ) ;if + ) ;active* + ) ;macro + ) ;assign + (assign "euro" + (macro (active* (if (equal (value "mode") "math") + (with "mode" "text" "mode" "text" "font" "tcx" "£") + (with "mode" "text" "font" "tcx" "£") + ) ;if + ) ;active* + ) ;macro + ) ;assign + (assign "trademark" + (macro (active* (if (equal (value "mode") "math") + (with "mode" "text" "mode" "text" "font" "tcx" "Ů") + (with "mode" "text" "font" "tcx" "Ů") + ) ;if + ) ;active* + ) ;macro + ) ;assign + (assign "emdash" + (macro (active* (if (equal (value "mode") "math") + (with "mode" "text" "font" "roman" "—") + (with "font" "roman" "—") + ) ;if + ) ;active* + ) ;macro + ) ;assign + (assign "masculine" (active* (rsup (wide* "o" "")))) + (assign "pandocbounded" (macro "body" "arg" (arg "body"))) + (assign "ordfeminine" (active* (rsup (wide* "a" "")))) + (assign "varmasculine" (active* (rsup "o"))) + (assign "varordfeminine" (active* (rsup "a"))) + (assign "textless" "") + (assign "textgreater" "") + (assign "textbar" "|") + (assign "textasciitilde" "~") + (assign "iint" (macro (big "iint"))) + (assign "iiint" (macro (big "iiint"))) + (assign "oint" (macro (big "oint"))) + (assign "oiint" (macro (big "oiint"))) + (assign "idotsint" (macro (big "idotsint"))) + (assign "nbsp-color" (value "bg-color")) + (assign "nbsp" + (macro (concat " " + (no-break) + (specific "screen" + (resize (move (with "color" (value "nbsp-color") "-") "-0.3em" "") + "0em" + "" + "0em" + "" + ) ;resize + ) ;specific + ) ;concat + ) ;macro + ) ;assign + (assign "nbhyph" (macro (concat "-" (no-break)))) + (assign "boxed" (macro "x" (ornament (arg "x")))) + (assign "textquotesingle" "'") + (assign "mathscr" (macro "body" (with "font" "cal*" (arg "body")))) + (assign "textendash" "–") + (assign "textemdash" "—") + (assign "mathbfcal" + (macro "var" (with "font" "cal" (with "font-series" "bold" (arg "var")))) + ) ;assign + (assign "bold" (macro "x" (with "font-series" "bold" (arg "x")))) + (assign "italic" (macro "x" (with "font-shape" "italic" (arg "x")))) + "" + ) ;document + ) ;body + (initial (collection (associate "preamble" "true"))) +) ;document diff --git a/TeXmacs/packages/standard/std-symbol.ts b/TeXmacs/packages/standard/std-symbol.ts deleted file mode 100644 index be87a9ce9b..0000000000 --- a/TeXmacs/packages/standard/std-symbol.ts +++ /dev/null @@ -1,117 +0,0 @@ - - -> - -<\body> - - - - <\src-purpose> - Some additional symbols for text mode. This file should become obsolete - when better support for Unicode will be implemented. - - - - - <\src-license> - This software falls under the . It comes WITHOUT ANY - WARRANTY WHATSOEVER. You should have received a copy of the license - which the software. If not, see . - - > - - |math>||>>>> - - |math>||>>>> - - |math>||>>>> - - |math>||>>>> - - |math>||>>>> - - |math>||>>>> - - |math>||>>>> - - |math>||>>>> - - |math>||>>>> - - |math>||>>>> - - |math>||>>>> - - |math>||>>>> - - |math>||>>>> - - |math>||>>>> - - |math>||>>>> - - |math>||>>>> - - |math>||>>>> - - |math>||>>>> - - >>>> - - >> - - >>>> - - >> - - >> - - > - - > - - - - - - >> - - >> - - >> - - >> - - >> - - > - - |->|-0.3em|>|0em||0em|>>>> - - >> - - >>> - - - - >>> - - - - - - >>>> - - >>> - - >>> - - \; - - -<\initial> - <\collection> - - - diff --git a/TeXmacs/packages/standard/std-utils.stem b/TeXmacs/packages/standard/std-utils.stem new file mode 100644 index 0000000000..22e08df3c3 --- /dev/null +++ b/TeXmacs/packages/standard/std-utils.stem @@ -0,0 +1,1018 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; MODULE : std-utils.stem +;; COPYRIGHT : (C) 1998--2004 Joris van der Hoeven +;; +;; This software falls under the GNU general public license version 3 or later. +;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE +;; in the root directory or . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(document (TeXmacs "1.99.19") + (style (tuple "source" "std")) + (body (document (active* (src-title (document (src-package "std-utils" "1.0") + (src-purpose (document "This package contains useful macros for writing style files.") + ) ;src-purpose + ) ;document + ) ;src-title + ) ;active* + (active* (document (src-comment (document "Helper macros for wide block environments (work also for inline content, like section titles)." + ) ;document + ) ;src-comment + ) ;document + ) ;active* + (assign "hflush" (macro (htab "0fn" "0"))) + (assign "right-flush" (macro (specific "texmacs" (htab "0fn" "first")))) + (assign "left-flush" (macro (htab "0fn" "last"))) + (assign "wide-normal" + (macro "body" + (surround (no-indent) (specific "texmacs" (htab "0fn" "first")) (arg "body")) + ) ;macro + ) ;assign + (assign "wide-centered" + (macro "body" + (surround (concat (no-indent) (htab "0fn" "last")) + (htab "0fn" "first") + (arg "body") + ) ;surround + ) ;macro + ) ;assign + (active* (document (src-comment (document "Helper macros for vertically padded environments")) + ) ;document + ) ;active* + (assign "padding-above" "0.5fn") + (assign "padding-below" "0.5fn") + (assign "large-padding-above" "1fn") + (assign "large-padding-below" "1fn") + (assign "padded-normal" + (macro "before" + "after" + "body" + (surround (concat (vspace* (arg "before")) (no-indent)) + (concat (specific "texmacs" (htab "0fn" "first")) (vspace (arg "after"))) + (arg "body") + ) ;surround + ) ;macro + ) ;assign + (assign "padded-centered" + (macro "before" + "after" + "body" + (surround (concat (vspace* (arg "before")) (no-indent) (htab "0fn" "last")) + (concat (htab "0fn" "first") (vspace (arg "after"))) + (arg "body") + ) ;surround + ) ;macro + ) ;assign + (assign "padded-normal-titled" + (macro "before" + "after" + "body" + "title" + (document (surround (concat (vspace* (arg "before")) (no-indent)) + "" + (document (arg "title")) + ) ;surround + (surround (no-indent) + (concat (specific "texmacs" (htab "0fn" "first")) (vspace (arg "after"))) + (document (arg "body")) + ) ;surround + ) ;document + ) ;macro + ) ;assign + (assign "padded" + (macro "body" + (document (padded-normal (value "padding-above") + (value "padding-below") + (document (arg "body")) + ) ;padded-normal + ) ;document + ) ;macro + ) ;assign + (assign "padded*" + (macro "body" + (document (padded-normal (value "large-padding-above") + (value "large-padding-below") + (document (arg "body")) + ) ;padded-normal + ) ;document + ) ;macro + ) ;assign + (assign "padded-titled" + (macro "body" + "title" + (document (padded-normal-titled (value "padding-above") + (value "padding-below") + (document (arg "body")) + (arg "title") + ) ;padded-normal-titled + ) ;document + ) ;macro + ) ;assign + (assign "padded-center" + (macro "body" + (with "par-mode" + "center" + (surround (concat (vspace* (value "padding-above")) (no-indent)) + (vspace (value "padding-below")) + (arg "body") + ) ;surround + ) ;with + ) ;macro + ) ;assign + (assign "padded-left-aligned" + (macro "body" + (with "par-mode" + "left" + (surround (concat (vspace* (value "padding-above")) (no-indent)) + (vspace (value "padding-below")) + (arg "body") + ) ;surround + ) ;with + ) ;macro + ) ;assign + (assign "padded-right-aligned" + (macro "body" + (with "par-mode" + "right" + (surround (concat (vspace* (value "padding-above")) (no-indent)) + (vspace (value "padding-below")) + (arg "body") + ) ;surround + ) ;with + ) ;macro + ) ;assign + (active* (document (src-comment (document "Helper macros for underlined/overlined block environments (work also for inline content, like page headers)." + ) ;document + ) ;src-comment + ) ;document + ) ;active* + (assign "overlined-width" "1ln") + (assign "overlined-sep" "1sep") + (assign "underlined-width" "1ln") + (assign "underlined-sep" "1sep") + (assign "wide-bothlined" + (macro "top-border" + "bot-border" + "top-sep" + "bot-sep" + "body" + (surround (no-indent) + "" + (tabular (tformat (twith "table-width" "1par") + (cwith "1" "1" "1" "1" "cell-width" "1par") + (cwith "1" "1" "1" "1" "cell-lsep" "0pt") + (cwith "1" "1" "1" "1" "cell-rsep" "0pt") + (cwith "1" "1" "1" "1" "cell-hyphen" "t") + (cwith "1" "1" "1" "1" "cell-tborder" (arg "top-border")) + (cwith "1" "1" "1" "1" "cell-bborder" (arg "bot-border")) + (cwith "1" "1" "1" "1" "cell-tsep" (arg "top-sep")) + (cwith "1" "1" "1" "1" "cell-bsep" (arg "bot-sep")) + (table (row (cell (arg "body")))) + ) ;tformat + ) ;tabular + ) ;surround + ) ;macro + ) ;assign + (assign "wide-bothlined-titled" + (macro "top-border" + "bot-border" + "top-sep" + "bot-sep" + "body" + "title" + (surround (no-indent) + "" + (tabular (tformat (twith "table-width" "1par") + (cwith "1" "2" "1" "1" "cell-width" "1par") + (cwith "1" "2" "1" "1" "cell-lsep" "0pt") + (cwith "1" "2" "1" "1" "cell-rsep" "0pt") + (cwith "2" "2" "1" "1" "cell-hyphen" "t") + (cwith "1" "2" "1" "1" "cell-tborder" (arg "top-border")) + (cwith "2" "2" "1" "1" "cell-bborder" (arg "bot-border")) + (cwith "1" "2" "1" "1" "cell-tsep" (arg "top-sep")) + (cwith "1" "1" "1" "1" "cell-bsep" (arg "top-sep")) + (cwith "2" "2" "1" "1" "cell-bsep" (arg "bot-sep")) + (cwith "1" "1" "1" "1" "cell-hyphen" "t") + (table (row (cell (document (arg "title")))) + (row (cell (document (arg "body")))) + ) ;table + ) ;tformat + ) ;tabular + ) ;surround + ) ;macro + ) ;assign + (assign "wide-bothlined-titled*" + (macro "top-border" + "bot-border" + "top-sep" + "bot-sep" + "body" + "title" + (surround (no-indent) + "" + (tabular (tformat (twith "table-width" "1par") + (cwith "1" "2" "1" "1" "cell-width" "1par") + (cwith "1" "2" "1" "1" "cell-lsep" "0pt") + (cwith "1" "2" "1" "1" "cell-rsep" "0pt") + (cwith "1" "1" "1" "1" "cell-hyphen" "t") + (cwith "1" "1" "1" "1" "cell-tborder" (arg "top-border")) + (cwith "1" "2" "1" "1" "cell-bborder" (arg "bot-border")) + (cwith "1" "1" "1" "1" "cell-tsep" (arg "top-sep")) + (cwith "2" "2" "1" "1" "cell-tsep" (arg "bot-sep")) + (cwith "1" "2" "1" "1" "cell-bsep" (arg "bot-sep")) + (cwith "2" "2" "1" "1" "cell-hyphen" "t") + (table (row (cell (document (arg "body")))) + (row (cell (document (arg "title")))) + ) ;table + ) ;tformat + ) ;tabular + ) ;surround + ) ;macro + ) ;assign + (assign "wide-std-bothlined" + (macro "body" + (wide-bothlined (value "overlined-width") + (value "underlined-width") + (value "overlined-sep") + (value "underlined-sep") + (arg "body") + ) ;wide-bothlined + ) ;macro + ) ;assign + (assign "wide-std-bothlined-titled" + (macro "body" + "title" + (wide-bothlined-titled (value "overlined-width") + (value "underlined-width") + (value "overlined-sep") + (value "underlined-sep") + (arg "body") + (arg "title") + ) ;wide-bothlined-titled + ) ;macro + ) ;assign + (assign "padded-bothlined" + (macro "before" + "after" + "top-border" + "bot-border" + "top-sep" + "bot-sep" + "body" + (surround (vspace* (arg "before")) + (vspace (arg "after")) + (wide-bothlined (arg "top-border") + (arg "bot-border") + (arg "top-sep") + (arg "bot-sep") + (arg "body") + ) ;wide-bothlined + ) ;surround + ) ;macro + ) ;assign + (assign "padded-std-bothlined" + (macro "before" + "after" + "body" + (document (padded-bothlined (arg "before") + (arg "after") + (value "overlined-width") + (value "underlined-width") + (value "overlined-sep") + (value "underlined-sep") + (arg "body") + ) ;padded-bothlined + ) ;document + ) ;macro + ) ;assign + (assign "wide-overlined" + (macro "tborder" + "tsep" + "body" + (wide-bothlined (arg "tborder") "0pt" (arg "tsep") "0pt" (arg "body")) + ) ;macro + ) ;assign + (assign "wide-std-overlined" + (macro "body" + (wide-overlined (value "overlined-width") (value "overlined-sep") (arg "body")) + ) ;macro + ) ;assign + (assign "wide-std-overlined-titled" + (macro "body" + "title" + (wide-bothlined-titled (value "overlined-width") + "0pt" + (value "overlined-sep") + "0pt" + (arg "body") + (arg "title") + ) ;wide-bothlined-titled + ) ;macro + ) ;assign + (assign "wide-underlined" + (macro "bborder" + "bsep" + "body" + (wide-bothlined "0pt" (arg "bborder") "0pt" (arg "bsep") (arg "body")) + ) ;macro + ) ;assign + (assign "wide-std-underlined" + (macro "body" + (wide-underlined (value "underlined-width") + (value "underlined-sep") + (arg "body") + ) ;wide-underlined + ) ;macro + ) ;assign + (assign "wide-std-underlined-titled" + (macro "body" + "title" + (wide-bothlined-titled* "0pt" + (value "underlined-width") + "0pt" + (value "underlined-sep") + (arg "body") + (arg "title") + ) ;wide-bothlined-titled* + ) ;macro + ) ;assign + (assign "overlined" + (macro "body" (document (padded (wide-std-overlined (arg "body"))))) + ) ;assign + (assign "underlined" + (macro "body" (document (padded (wide-std-underlined (arg "body"))))) + ) ;assign + (assign "bothlined" + (macro "body" (document (padded (wide-std-bothlined (arg "body"))))) + ) ;assign + (assign "overlined-titled" + (macro "body" + "title" + (document (padded (wide-std-overlined-titled (arg "body") (arg "title")))) + ) ;macro + ) ;assign + (assign "underlined-titled" + (macro "body" + "title" + (document (padded (wide-std-underlined-titled (arg "body") (arg "title")))) + ) ;macro + ) ;assign + (assign "bothlined-titled" + (macro "body" + "title" + (document (padded (wide-std-bothlined-titled (arg "body") (arg "title")))) + ) ;macro + ) ;assign + (active* (document (src-comment (document "Helper macros for framed block environments (work also for inline content)." + ) ;document + ) ;src-comment + ) ;document + ) ;active* + (assign "framed-color" "") + (assign "framed-width" "1ln") + (assign "framed-hsep" "1spc") + (assign "framed-vsep" "1sep") + (assign "wide-framed" + (macro "border-width" + "hsep" + "vsep" + "body" + (surround (no-indent) + "" + (tabular (tformat (twith "table-width" "1par") + (cwith "1" "1" "1" "1" "cell-width" "1par") + (cwith "1" "1" "1" "1" "cell-hyphen" "t") + (cwith "1" "1" "1" "1" "cell-lborder" (arg "border-width")) + (cwith "1" "1" "1" "1" "cell-rborder" (arg "border-width")) + (cwith "1" "1" "1" "1" "cell-tborder" (arg "border-width")) + (cwith "1" "1" "1" "1" "cell-bborder" (arg "border-width")) + (cwith "1" "1" "1" "1" "cell-lsep" (arg "hsep")) + (cwith "1" "1" "1" "1" "cell-rsep" (arg "hsep")) + (cwith "1" "1" "1" "1" "cell-tsep" (arg "vsep")) + (cwith "1" "1" "1" "1" "cell-bsep" (arg "vsep")) + (cwith "1" "1" "1" "1" "cell-background" (value "framed-color")) + (table (row (cell (arg "body")))) + ) ;tformat + ) ;tabular + ) ;surround + ) ;macro + ) ;assign + (assign "wide-framed-titled" + (macro "border-width" + "hsep" + "vsep" + "body" + "title" + (surround (no-indent) + "" + (tabular (tformat (twith "table-width" "1par") + (cwith "1" "2" "1" "1" "cell-width" "1par") + (cwith "2" "2" "1" "1" "cell-hyphen" "t") + (cwith "1" "2" "1" "1" "cell-lborder" (arg "border-width")) + (cwith "1" "2" "1" "1" "cell-rborder" (arg "border-width")) + (cwith "1" "2" "1" "1" "cell-tborder" (arg "border-width")) + (cwith "1" "2" "1" "1" "cell-bborder" (arg "border-width")) + (cwith "1" "2" "1" "1" "cell-lsep" (arg "hsep")) + (cwith "1" "2" "1" "1" "cell-rsep" (arg "hsep")) + (cwith "1" "2" "1" "1" "cell-tsep" (arg "vsep")) + (cwith "1" "2" "1" "1" "cell-bsep" (arg "vsep")) + (cwith "1" "2" "1" "1" "cell-background" (value "framed-color")) + (cwith "1" "1" "1" "1" "cell-hyphen" "t") + (table (row (cell (document (arg "title")))) + (row (cell (document (arg "body")))) + ) ;table + ) ;tformat + ) ;tabular + ) ;surround + ) ;macro + ) ;assign + (assign "wide-std-framed" + (macro "body" + (wide-framed (value "framed-width") + (value "framed-hsep") + (value "framed-vsep") + (arg "body") + ) ;wide-framed + ) ;macro + ) ;assign + (assign "wide-std-framed-titled" + (macro "body" + "title" + (wide-framed-titled (value "framed-width") + (value "framed-hsep") + (value "framed-vsep") + (arg "body") + (arg "title") + ) ;wide-framed-titled + ) ;macro + ) ;assign + (assign "wide-framed-colored" + (macro "border-color" + "body-color" + "border-width" + "hsep" + "vsep" + "body" + (with "old-color" + (value "color") + "color" + (arg "border-color") + "framed-color" + (arg "body-color") + (wide-framed (arg "border-width") + (arg "hsep") + (arg "vsep") + (with "color" + (value "old-color") + (style-with "src-compact" "none" (arg "body")) + ) ;with + ) ;wide-framed + ) ;with + ) ;macro + ) ;assign + (assign "wide-std-framed-colored" + (macro "border-color" + "body-color" + "body" + (wide-framed-colored (arg "border-color") + (arg "body-color") + (value "framed-width") + (value "framed-hsep") + (value "framed-vsep") + (style-with "src-compact" "none" (arg "body")) + ) ;wide-framed-colored + ) ;macro + ) ;assign + (assign "framed" + (macro "body" (document (padded (wide-std-framed (arg "body"))))) + ) ;assign + (assign "mdframed" (macro "body" (document (framed (arg "body"))))) + (assign "framed-titled" + (macro "body" + "title" + (document (padded (compound "wide-std-framed-titled" (arg "body") (arg "title"))) + ) ;document + ) ;macro + ) ;assign + (active* (document (src-comment (document "Ornamented environments.")))) + (assign "ornamented" + (macro "body" + (document (padded (document (decorated (document (surround "" (right-flush) (document (arg "body"))))) + ) ;document + ) ;padded + ) ;document + ) ;macro + ) ;assign + (assign "ornamented-titled" + (macro "body" + "title" + (document (padded (document (decorated-titled (arg "title") + (document (surround "" (right-flush) (document (arg "body")))) + ) ;decorated-titled + ) ;document + ) ;padded + ) ;document + ) ;macro + ) ;assign + (drd-props "ornamented" "arity" "1" "accessible" "all" "locals" (attrs)) + (drd-props "ornamented-titled" "arity" "2" "accessible" "all" "locals" (attrs)) + (assign "ornament-indent" + (macro "left" + "right" + "bottom" + "top" + "body" + (document (with "old-shape" + (value "ornament-shape") + "old-color" + (value "ornament-color") + "old-hpadding" + (value "ornament-hpadding") + "old-vpadding" + (value "ornament-vpadding") + "old-border" + (value "ornament-border") + "ornament-shape" + "classic" + "ornament-color" + "#fff0" + "ornament-hpadding" + (tuple (arg "left") (arg "right")) + "ornament-vpadding" + (tuple (arg "bottom") (arg "top")) + "ornament-border" + "0ln" + (document (ornament (document (surround "" + (right-flush) + (document (with "ornament-shape" + (value "old-shape") + "ornament-color" + (value "old-color") + "ornament-hpadding" + (value "old-hpadding") + "ornament-vpadding" + (value "old-vpadding") + "ornament-border" + (value "old-border") + (document (arg "body")) + ) ;with + ) ;document + ) ;surround + ) ;document + ) ;ornament + ) ;document + ) ;with + ) ;document + ) ;macro + ) ;assign + (active* (document (src-comment (document "Decorations based on ornaments.")))) + (assign "ornament-render-title" (macro "body" (arg "body"))) + (assign "ornament-render-body" (macro "body" (arg "body"))) + (assign "ornament-render-extra" (macro "body" (arg "body"))) + "" + (assign "decorated-hook" + (macro "body" + (with "bg-color" + (value "ornament-extra-color") + "old-color" + (value "color") + "old-math-color" + (value "math-color") + "old-strong-color" + (value "strong-color") + (ornament-render-title (with "ornament-extra-color" + (value "bg-color") + "color" + (value "old-color") + "math-color" + (value "old-math-color") + "strong-color" + (value "old-strong-color") + (with "bg-color" + (value "ornament-color") + (ornament-render-body (with "ornament-color" (value "bg-color") (arg "body"))) + ) ;with + ) ;with + ) ;ornament-render-title + ) ;with + ) ;macro + ) ;assign + (assign "decorated-title" (macro "body" (ornament-render-title (arg "body")))) + (assign "decorated-body" (macro "body" (ornament-render-body (arg "body")))) + (assign "decorated-extra" (macro "body" (ornament-render-extra (arg "body")))) + "" + (assign "decorated" + (macro "body" + (decorated-hook (decorated-extra (ornament (decorated-body (arg "body"))))) + ) ;macro + ) ;assign + (assign "decorated-block" + (macro "body" + (document (decorated-hook (decorated-extra (ornament (document (wide-normal (document (decorated-body (document (arg "body")))))) + ) ;ornament + ) ;decorated-extra + ) ;decorated-hook + ) ;document + ) ;macro + ) ;assign + (assign "decorated-titled" + (macro "name" + "body" + (decorated-hook (decorated-extra (ornament (decorated-body (arg "body")) (decorated-title (arg "name"))) + ) ;decorated-extra + ) ;decorated-hook + ) ;macro + ) ;assign + (assign "decorated-titled-block" + (macro "name" + "body" + (document (decorated-hook (decorated-extra (ornament (document (wide-normal (document (decorated-body (arg "body"))))) + (decorated-title (arg "name")) + ) ;ornament + ) ;decorated-extra + ) ;decorated-hook + ) ;document + ) ;macro + ) ;assign + (drd-props "decorated" "arity" "1" "accessible" "all" "locals" (attrs)) + (drd-props "decorated-block" "arity" "1" "accessible" "all" "locals" (attrs)) + (drd-props "decorated-titled" "arity" "2" "accessible" "all" "locals" (attrs)) + (drd-props "decorated-titled-block" + "arity" + "2" + "accessible" + "all" + "locals" + (attrs) + ) ;drd-props + (active* (document (src-comment (document "Indentation.")))) + (assign "indent-left" + (macro "indentation" + "body" + (document (with "par-left" + (plus (value "par-left") (arg "indentation")) + (document (arg "body")) + ) ;with + ) ;document + ) ;macro + ) ;assign + (assign "indent-right" + (macro "indentation" + "body" + (document (with "par-right" + (plus (value "par-right") (arg "indentation")) + (document (arg "body")) + ) ;with + ) ;document + ) ;macro + ) ;assign + (assign "indent-both" + (macro "left-indentation" + "right-indentation" + "body" + (document (with "par-left" + (plus (value "par-left") (arg "left-indentation")) + "par-right" + (plus (value "par-right") (arg "right-indentation")) + (document (arg "body")) + ) ;with + ) ;document + ) ;macro + ) ;assign + (assign "margin-first-other" + (macro "head-indent" + "tail-indent" + "body" + (with "par-left" + (plus (arg "tail-indent") "0em") + "par-first" + (minus (arg "head-indent") (arg "tail-indent")) + (surround (yes-indent) "" (arg "body")) + ) ;with + ) ;macro + ) ;assign + (assign "page-length" + (macro "x" + (if (equal (value "length-mode") "fixed") + (arg "x") + (over (arg "x") (value "magnification")) + ) ;if + ) ;macro + ) ;assign + (assign "no-left-margin" + (macro "body" + (document (with "par-left" + (minus (page-length (value "page-odd"))) + (document (arg "body")) + ) ;with + ) ;document + ) ;macro + ) ;assign + (assign "no-right-margin" + (macro "body" + (document (with "par-right" + (minus (page-length (value "page-right"))) + (document (arg "body")) + ) ;with + ) ;document + ) ;macro + ) ;assign + (assign "no-margins" + (macro "body" + (document (with "par-left" + (minus (page-length (value "page-odd"))) + "par-right" + (minus (page-length (value "page-right"))) + (document (arg "body")) + ) ;with + ) ;document + ) ;macro + ) ;assign + (active* (document (src-comment (document "Mini paragraphs.")))) + (assign "mini-paragraph" + (macro "width" + "body" + (document (tabular (tformat (cwith "1" "1" "1" "1" "cell-lsep" "0spc") + (cwith "1" "1" "1" "1" "cell-rsep" "0spc") + (cwith "1" "1" "1" "1" "cell-bsep" "0spc") + (cwith "1" "1" "1" "1" "cell-tsep" "0spc") + (cwith "1" "1" "1" "1" "cell-vcorrect" "n") + (cwith "1" "1" "1" "1" "cell-hyphen" "t") + (cwith "1" "1" "1" "1" "cell-width" (arg "width")) + (cwith "1" "1" "1" "1" "cell-hmode" "exact") + (table (row (cell (document (arg "body"))))) + ) ;tformat + ) ;tabular + ) ;document + ) ;macro + ) ;assign + (active* (document (src-comment (document "Header information.")))) + (assign "page-number" (macro (quote (page-the-page)))) + (assign "set-this-page-header" + (macro "header" + (style-with "src-compact" + "none" + (concat (flag (localize "this page header") "brown" "header") + (assign "page-this-header" (arg "header")) + ) ;concat + ) ;style-with + ) ;macro + ) ;assign + (assign "set-header" + (macro "header" + (style-with "src-compact" + "none" + (concat (flag (localize "header") "brown" "header") + (assign "page-odd-header" (arg "header")) + (assign "page-even-header" (arg "header")) + ) ;concat + ) ;style-with + ) ;macro + ) ;assign + (assign "set-odd-page-header" + (macro "header" + (style-with "src-compact" + "none" + (concat (flag (localize "odd page header") "brown" "header") + (assign "page-odd-header" (arg "header")) + ) ;concat + ) ;style-with + ) ;macro + ) ;assign + (assign "set-even-page-header" + (macro "header" + (style-with "src-compact" + "none" + (concat (flag (localize "even page header") "brown" "header") + (assign "page-odd-header" (arg "header")) + ) ;concat + ) ;style-with + ) ;macro + ) ;assign + (assign "set-this-page-footer" + (macro "footer" + (style-with "src-compact" + "none" + (concat (flag (localize "this page footer") "brown" "footer") + (assign "page-this-footer" (arg "footer")) + ) ;concat + ) ;style-with + ) ;macro + ) ;assign + (assign "set-footer" + (macro "footer" + (style-with "src-compact" + "none" + (concat (flag (localize "footer") "brown" "footer") + (assign "page-odd-footer" (arg "footer")) + (assign "page-even-footer" (arg "footer")) + ) ;concat + ) ;style-with + ) ;macro + ) ;assign + (assign "set-odd-page-footer" + (macro "footer" + (style-with "src-compact" + "none" + (concat (flag (localize "odd page footer") "brown" "footer") + (assign "page-odd-footer" (arg "footer")) + ) ;concat + ) ;style-with + ) ;macro + ) ;assign + (assign "set-even-page-footer" + (macro "footer" + (style-with "src-compact" + "none" + (concat (flag (localize "even page footer") "brown" "footer") + (assign "page-odd-footer" (arg "footer")) + ) ;concat + ) ;style-with + ) ;macro + ) ;assign + (assign "set-page-number" + (macro "nr" + (style-with "src-compact" + "none" + (concat (flag (localize "renumber this page") "brown" "nr") + (assign "page-nr" (arg "nr")) + ) ;concat + ) ;style-with + ) ;macro + ) ;assign + (assign "set-page-number-macro" + (macro "rendering-macro" + (style-with "src-compact" + "none" + (concat (flag (localize "page number text") "brown" "rendering-macro") + (assign "page-the-page" (arg "rendering-macro")) + ) ;concat + ) ;style-with + ) ;macro + ) ;assign + (assign "blanc-page" + (macro (style-with "src-compact" + "none" + (concat (assign "page-this-header" "") (assign "page-this-footer" "")) + ) ;style-with + ) ;macro + ) ;assign + (assign "simple-page" + (macro (style-with "src-compact" + "none" + (concat (assign "page-this-header" "") + (assign "page-this-footer" + (concat (no-indent) (htab "5mm") (page-number) (htab "5mm")) + ) ;assign + ) ;concat + ) ;style-with + ) ;macro + ) ;assign + (active* (document (src-comment (document "Further table macros.")))) + (assign "description-table" + (macro "body" + (tformat (twith "table-width" "1par") + (twith "table-hmode" "exact") + (twith "table-block" "yes") + (twith "table-min-cols" "2") + (cwith "1" "-1" "2" "-1" "cell-hyphen" "t") + (cwith "1" "-1" "1" "-1" "cell-hpart" "0.001") + (cwith "1" "-1" "1" "1" "cell-lsep" "0fn") + (cwith "1" "-1" "-1" "-1" "cell-rsep" "0fn") + (cwith "1" "-2" "1" "-1" "cell-bsep" (value "par-par-sep")) + (cwith "2" "-1" "1" "-1" "cell-tsep" (value "par-sep")) + (arg "body") + ) ;tformat + ) ;macro + ) ;assign + (assign "prefixed-line" + (macro "prefix" + "body" + (document (with "par-first" + "0fn" + (document (description-table (document (tformat (twith "table-valign" "T") + (twith "table-hmode" "min") + (cwith "1" "-1" "1" "-1" "cell-lsep" "0em") + (cwith "1" "-1" "1" "-1" "cell-rsep" "0em") + (cwith "1" "1" "1" "-1" "cell-tsep" "0em") + (cwith "-1" "-1" "1" "-1" "cell-bsep" "0em") + (cwith "1" "-1" "1" "-1" "cell-vcorrect" "n") + (table (row (cell (arg "prefix")) (cell (document (arg "body"))))) + ) ;tformat + ) ;document + ) ;description-table + ) ;document + ) ;with + ) ;document + ) ;macro + ) ;assign + (assign "alt-prefixed-line" + (macro "prefix" + "body" + (with "p" + (times (look-up (box-info (arg "prefix") "w") "0") "1tmpt") + (with "par-left" + (plus (value "par-left") (value "p")) + "par-first" + (minus (value "p")) + (surround (concat (yes-indent) (arg "prefix")) "" (arg "body")) + ) ;with + ) ;with + ) ;macro + ) ;assign + (active* (document (src-comment (document "Other macros.")))) + (assign "localize" + (macro "text" (translate (arg "text") "english" (value "language"))) + ) ;assign + (assign "language-suffix" (macro (extern "ext-language-suffix"))) + (assign "map" (macro "fun" "args" (extern "ext-map" (arg "fun") (arg "args")))) + (assign "concat-tuple" + (macro "args" + "sep" + "fin" + (extern "ext-concat-tuple" (arg "args") (arg "sep") (arg "fin")) + ) ;macro + ) ;assign + (assign "comma-separated" (xmacro "x" (concat-tuple (quote-arg "x") ", "))) + (assign "semicolon-separated" (xmacro "x" (concat-tuple (quote-arg "x") "; "))) + (drd-props "comma-separated" + "arity" + (tuple "repeat" "1" "1") + "accessible" + "all" + ) ;drd-props + (drd-props "semicolon-separated" + "arity" + (tuple "repeat" "1" "1") + "accessible" + "all" + ) ;drd-props + (assign "tm-ref" + (xmacro "x" + (extern "ext-tm-ref" (quote-arg "x" "0") (map-args "identity" "tuple" "x" "1")) + ) ;xmacro + ) ;assign + (assign "tm-arity" + (xmacro "x" + (extern "ext-tm-arity" + (quote-arg "x" "0") + (map-args "identity" "tuple" "x" "1") + ) ;extern + ) ;xmacro + ) ;assign + (assign "tm-index" + (xmacro "x" + (extern "ext-tm-index" + (quote-arg "x" "0") + (map-args "identity" "tuple" "x" "1") + ) ;extern + ) ;xmacro + ) ;assign + (assign "tm-last?" + (xmacro "x" + (extern "ext-tm-last?" + (quote-arg "x" "0") + (map-args "identity" "tuple" "x" "1") + ) ;extern + ) ;xmacro + ) ;assign + (assign "tm-ref-example" + (macro "body" (quasi (tm-ref (unquote (quote-arg "body")) "0"))) + ) ;assign + (drd-props "tm-ref" "arity" (tuple "repeat" "1" "1")) + (drd-props "tm-arity" "arity" (tuple "repeat" "1" "1")) + (drd-props "tm-index" "arity" (tuple "repeat" "1" "1")) + (drd-props "tm-last?" "arity" (tuple "repeat" "1" "1")) + (assign "prepend-space" (macro "x" (concat " " (arg "x")))) + (assign "space-separated" + (xmacro "items" + (concat (arg "items" "0") (map-args "prepend-space" "concat" "items" "1")) + ) ;xmacro + ) ;assign + (assign "document-bis" + (xmacro "items" (map-args "identity" "document" "items")) + ) ;assign + (assign "font-magnify" + (macro "factor" + "body" + (with "font-size" (times (value "font-size") (arg "factor")) (arg "body")) + ) ;macro + ) ;assign + (assign "hidden-title" (macro "title" "")) + (assign "inline-block" + (macro "body" + (tabular (tformat (cwith "1" "1" "1" "1" "cell-lsep" "0fn") + (twith "table-width" "1par") + (cwith "1" "1" "1" "1" "cell-rsep" "0fn") + (cwith "1" "1" "1" "1" "cell-hyphen" "t") + (table (row (cell (document (arg "body"))))) + ) ;tformat + ) ;tabular + ) ;macro + ) ;assign + ) ;document + ) ;body + (initial (collection (associate "preamble" "true"))) +) ;document diff --git a/TeXmacs/packages/standard/std-utils.ts b/TeXmacs/packages/standard/std-utils.ts deleted file mode 100644 index d0cffeb6dc..0000000000 --- a/TeXmacs/packages/standard/std-utils.ts +++ /dev/null @@ -1,483 +0,0 @@ - - -> - -<\body> - - - - <\src-purpose> - This package contains useful macros for writing style files. - - - - - <\src-license> - This software falls under the . It comes WITHOUT ANY - WARRANTY WHATSOEVER. You should have received a copy of the license - which the software. If not, see . - - > - - <\active*> - <\src-comment> - Helper macros for wide block environments (work also for inline - content, like section titles). - - - - >> - - >>> - - >> - - |>|>>> - - ||>>> - - <\active*> - <\src-comment> - Helper macros for vertically padded environments - - - - - - - - - - - - >|>>|>>> - - >|>|>>> - - - <\surround|>|> - - - - <\surround||>>> - - - > - - - <\padded-normal||> - - - > - - - <\padded-normal||> - - - > - - - <\padded-normal-titled||> - - > - > - - >|>|>>>> - - >|>|>>>> - - >|>|>>>> - - <\active*> - <\src-comment> - Helper macros for underlined/overlined block environments (work also - for inline content, like page headers). - - - - - - - - - - - - |||||||>|>|>|>|>>>>>>>> - - |||||||>|>|>|>|>|| - - >| - - >>>>>>> - - |||||||>|>|>|>|>|| - - >| - - >>>>>>> - - ||||>>> - - |||||>>> - - >|>|||||>>>> - - - ||||||> - > - - |0pt||0pt|>>> - - ||>>> - - |0pt||0pt||>>> - - |0pt||>>> - - ||>>> - - |0pt|||>>> - - - >> - > - - - >> - > - - - >> - > - - - |>> - > - - - |>> - > - - - |>> - > - - <\active*> - <\src-comment> - Helper macros for framed block environments (work also for inline - content). - - - - - - - - - - - - |||||>|>|>|>|>|>|>|>|>|>>>>>>>> - - |||||>|>|>|>|>|>|>|>|>|| - - >| - - >>>>>>> - - |||>>> - - ||||>>> - - |color||framed-color||||||>>>>>> - - |||||>>>> - - - >> - > - - - > - > - - - |>> - > - - <\active*> - <\src-comment> - Ornamented environments. - - - - - <\padded> - <\decorated> - <\surround||> - - - - - > - - - <\padded> - <\decorated-titled|> - <\surround||> - - - - - > - - > - - > - - - <\with|old-shape||old-color||old-hpadding||old-vpadding||old-border||ornament-shape|classic|ornament-color|#fff0|ornament-hpadding||>|ornament-vpadding||>|ornament-border|0ln> - <\ornament> - <\surround||> - <\with|ornament-shape||ornament-color||ornament-hpadding||ornament-vpadding||ornament-border|> - - - - - - > - - <\active*> - <\src-comment> - Decorations based on ornaments. - - - - >> - - >> - - >> - - \; - - |old-color||old-math-color||old-strong-color|||color||math-color||strong-color||||>>>>>>>> - - >>> - - >>> - - >>> - - \; - - >>>>>> - - - - <\wide-normal> - <\decorated-body> - - - - >> - > - - >|>>>>>> - - - - <\wide-normal> - > - - >>>> - > - - > - - > - - > - - > - - <\active*> - <\src-comment> - Indentation. - - - - - <\with|par-left||>> - - - > - - - <\with|par-right||>> - - - > - - - <\with|par-left||>|par-right||>> - - - > - - |0em>|par-first||>|||>>>> - - |fixed>|||>>>> - - - <\with|par-left|>>> - - - > - - - <\with|par-right|>>> - - - > - - - <\with|par-left|>>|par-right|>>> - - - > - - <\active*> - <\src-comment> - Mini paragraphs. - - - - - ||||||>|| - - >>>> - > - - <\active*> - <\src-comment> - Header information. - - - - >>> - - |brown|header>>>>> - - |brown|header>>>>>> - - |brown|header>>>>> - - |brown|header>>>>> - - |brown|footer>>>>> - - |brown|footer>>>>>> - - |brown|footer>>>>> - - |brown|footer>>>>> - - |brown|nr>>>>> - - |brown|rendering-macro>>>>> - - >>> - - >>>> - - <\active*> - <\src-comment> - Further table macros. - - - - ||||||||>|>|>>> - - - <\with|par-first|0fn> - <\description-table> - |||||||>|<\cell> - - >>> - - - > - - |w>|0>|1tmpt>||>|par-first|>|||>>>>> - - <\active*> - <\src-comment> - Other macros. - - - - |english|>>> - - >> - - |>>> - - ||>>> - - |, >>> - - |; >>> - - |accessible|all> - - |accessible|all> - - |>>> - - |>>> - - |>>> - - |>>> - - >|0>>>> - - > - - > - - > - - > - - >> - - >> - - >> - - |>|>>> - - > - - |||| - - >>>>>> - - -<\initial> - <\collection> - - - \ No newline at end of file diff --git a/TeXmacs/packages/standard/std.stem b/TeXmacs/packages/standard/std.stem new file mode 100644 index 0000000000..995fe0635c --- /dev/null +++ b/TeXmacs/packages/standard/std.stem @@ -0,0 +1,29 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; MODULE : std.stem +;; COPYRIGHT : (C) 1998--2004 Joris van der Hoeven +;; +;; This software falls under the GNU general public license version 3 or later. +;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE +;; in the root directory or . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(document (TeXmacs "1.99.4") + (style "source") + (body (document (active* (src-title (document (src-package "std" "1.0") + (src-purpose (document (concat "Common " (TeXmacs) " markup for most styles."))) + ) ;document + ) ;src-title + ) ;active* + (use-package "standard/std-counter" "standard/std-markup" + "standard/std-utils" "standard/std-symbol" "standard/std-math" + "standard/std-list" "standard/std-automatic" "standard/std-pattern" + "standard/std-fold" "standard/std-graphics" "standard/std-animate" + "compute/session" "compute/scripts" "compute/calc" "compute/program" + ) ;use-package + "" + ) ;document + ) ;body + (initial (collection (associate "preamble" "true"))) +) ;document diff --git a/TeXmacs/packages/standard/std.ts b/TeXmacs/packages/standard/std.ts deleted file mode 100644 index 77d7174911..0000000000 --- a/TeXmacs/packages/standard/std.ts +++ /dev/null @@ -1,32 +0,0 @@ - - - - -<\body> - - - - <\src-purpose> - Common markup for most styles. - - - - - <\src-license> - This software falls under the . It comes WITHOUT ANY - WARRANTY WHATSOEVER. You should have received a copy of the license - which the software. If not, see . - - > - - - - \; - - -<\initial> - <\collection> - - - \ No newline at end of file diff --git a/TeXmacs/plugins/account/progs/account/liii.scm b/TeXmacs/plugins/account/progs/account/liii.scm new file mode 100644 index 0000000000..1be9c62506 --- /dev/null +++ b/TeXmacs/plugins/account/progs/account/liii.scm @@ -0,0 +1,202 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; MODULE : liii.scm +;; DESCRIPTION : login +;; COPYRIGHT : (C) 2025 Mogan STEM authors +;; +;; This software falls under the GNU general public license version 3 or later. +;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE +;; in the root directory or . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(texmacs-module (account liii)) + +;; 获取当前时间戳（秒） + +(define (get-current-time) + (let* ((now (current-time)) (seconds (car now)) (microseconds (cdr now))) + (+ seconds (/ microseconds 1000000.0)) + ) ;let* +) ;define + +;; 获取账户数据目录 + +(define (get-account-data-dir) + (url-append (get-texmacs-home-path) "system/account") +) ;define + +;; 获取账户数据文件路径 + +(define (get-account-data-file filename) + (url-append (get-account-data-dir) filename) +) ;define + +;; 常量定义 + +(define TOKEN_FILENAME "token.txt") + +(define REFRESH_TOKEN_FILENAME "refresh_token.txt") + +(define TOKEN_EXPIRY_FILENAME "token_expiry.txt") + +;; 所有账户数据文件名列表 + +(define ACCOUNT_DATA_FILENAME_LIST + (list TOKEN_FILENAME REFRESH_TOKEN_FILENAME TOKEN_EXPIRY_FILENAME) +) ;define + +;; 确保数据目录存在的辅助函数 + +(define (ensure-data-dir-exists) + (let ((data-dir (get-account-data-dir))) + (if (not (url-exists? data-dir)) (system-mkdir data-dir)) + ) ;let +) ;define + +;; 通用：保存账户数据到文件 + +(define (save-account-data filename content) + (ensure-data-dir-exists) + (let ((data-file (get-account-data-file filename))) + ;; 如果文件存在则删除后重新创建，确保覆盖内容 + (when (url-exists? data-file) + (system-remove data-file) + ) ;when + ;; 保存内容到文件 + (string-save content data-file) + ) ;let +) ;define + +;; 通用：从文件读取账户数据 + +(define (load-account-data filename) + (let ((data-file (get-account-data-file filename))) + (if (url-exists? data-file) (string-load data-file) "") + ) ;let +) ;define + +(tm-define (current-stem-profile) + (with sp + (get-preference "stem-profile") + (if (string=? sp "default") "production" sp) + ) ;with +) ;tm-define + +;; stem-preview 只控制是否访问当前环境的蓝绿候选实例。 +;; stem-profile 仍只负责选择 staging 或 production 服务器。 +(tm-define (current-stem-preview?) + (string=? (get-preference "stem-preview") "on") +) ;tm-define + +(tm-define (stem-preview-cookie-header) + (if (current-stem-preview?) + "liii_user_preview=preview; liii_agent_preview=preview; liii_admin_preview=preview" + "" + ) ;if +) ;tm-define + +(tm-define (stem-preview-request-headers url headers) + (let ((preview-cookie (stem-preview-cookie-header))) + (if (and (not (string=? preview-cookie "")) + (string-starts? url (current-stem-site)) + ) ;and + (append headers (list (cons "Cookie" preview-cookie))) + headers + ) ;if + ) ;let +) ;tm-define + +(tm-define (current-stem-site) + (cond ((string=? (current-stem-profile) "production") "https://liiistem.cn") + ((string=? (current-stem-profile) "staging") "https://test.liiistem.cn") + (else "local") + ) ;cond +) ;tm-define + +;; OAuth2 配置 +(tm-define (account-oauth2-config key) + (let ((base-url (current-stem-site))) + (cond ((== key "authorization-url") (string-append base-url "/oauth2-login.html")) + ((== key "access-token-url") (string-append base-url "/api/v1/oauth2/token")) + ((== key "client-identifier") "public-client") + ((== key "scope") "user+llm") + ((== key "preview-cookie-header") (stem-preview-cookie-header)) + ((== key "port-list") + "6029,8087,9256,7438,5173,6391,8642,9901,44118,55055,1895" + ) ; + ((== key "user-info-url") + (string-append base-url "/api/v1/oauth2/membershipInfo") + ) ; + ((== key "pricing-url") (string-append base-url "/pricing.html")) + ((== key "invitation-url") + (string-append base-url "/personal-center/invitation") + ) ; + ((== key "growth-url") + (string-append base-url + "/personal-center/growth?from=oauth&version=v" + (xmacs-version) + ) ;string-append + ) ; + ((== key "click-return-liii-url") "https://liiistem.cn/?from=login_button") + (else "") + ) ;cond + ) ;let +) ;tm-define + +;; 本地 +;; (tm-define (account-oauth2-config key) +;; (cond +;; ((== key "authorization-url") "http://127.0.0.1:3000/oauth2-login") +;; ((== key "access-token-url") "http://127.0.0.1:8081/api/v1/oauth2/token") ;init:oauth2/token -> api/v1/oauth2/token +;; ((== key "client-identifier") "public-client") +;; ((== key "client-secret") "secret") +;; ((== key "scope") "user+llm") +;; ((== key "port-list") "6029,8087,9256,7438,5173,6391,8642,9901,44118,55055,1895") +;; ((== key "user-info-url") "http://127.0.0.1:8081/api/v1/oauth2/membershipInfo") ;init:api/oauthUser/membershipInfo -> api/v1/oauth2/membershipInfo +;; ((== key "pricing-url") "http://127.0.0.1:3000/pricing.html") +;; ((== key "invitation-url") "http://127.0.0.1:3000/personal-center/invitation") +;; ((== key "growth-url") (string-append "http://127.0.0.1:3000/personal-center/growth?from=oauth&version=v" (xmacs-version))) +;; ((== key "click-return-liii-url") "http://127.0.0.1:3000/?from=login_button") +;; (else ""))) + +;; 1.1 token 保存到数据文件 +(tm-define (account-save-token token) (save-account-data TOKEN_FILENAME token)) + +;; 1.2 读取token数据文件 +(tm-define (account-load-token) (load-account-data TOKEN_FILENAME)) + +;; 2.1 refresh_token 保存到数据文件 +(tm-define (account-save-refresh-token refresh-token) + (save-account-data REFRESH_TOKEN_FILENAME refresh-token) +) ;tm-define + +;; 2.2读取refresh_token数据文件 +(tm-define (account-load-refresh-token) + (load-account-data REFRESH_TOKEN_FILENAME) +) ;tm-define + +;; 3.1 token过期时间保存到数据文件 +(tm-define (account-save-token-expiry expiry-time) + (save-account-data TOKEN_EXPIRY_FILENAME expiry-time) +) ;tm-define + +;; 3.2 读取token过期时间数据文件 +(tm-define (account-load-token-expiry) + (load-account-data TOKEN_EXPIRY_FILENAME) +) ;tm-define + +;; 4 清除所有token数据 +(tm-define (account-clear-tokens) + (ensure-data-dir-exists) + (for-each (lambda (filename) + (let ((data-file (get-account-data-file filename))) + (when (url-exists? data-file) + (system-remove data-file) + ) ;when + ) ;let + ) ;lambda + ACCOUNT_DATA_FILENAME_LIST + ) ;for-each +) ;tm-define diff --git a/TeXmacs/plugins/account/progs/liii/account.scm b/TeXmacs/plugins/account/progs/liii/account.scm deleted file mode 100644 index d74d5b0853..0000000000 --- a/TeXmacs/plugins/account/progs/liii/account.scm +++ /dev/null @@ -1,203 +0,0 @@ - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : account.scm -;; DESCRIPTION : login -;; COPYRIGHT : (C) 2025 Mogan STEM authors -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (liii account)) -(import (liii os)) - -;; 获取当前时间戳（秒） - -(define (get-current-time) - (let* ((now (current-time)) (seconds (car now)) (microseconds (cdr now))) - (+ seconds (/ microseconds 1000000.0)) - ) ;let* -) ;define - -;; 获取账户数据目录 - -(define (get-account-data-dir) - (url-append (get-texmacs-home-path) "system/account") -) ;define - -;; 获取账户数据文件路径 - -(define (get-account-data-file filename) - (url-append (get-account-data-dir) filename) -) ;define - -;; 常量定义 - -(define TOKEN_FILENAME "token.txt") - -(define REFRESH_TOKEN_FILENAME "refresh_token.txt") - -(define TOKEN_EXPIRY_FILENAME "token_expiry.txt") - -;; 所有账户数据文件名列表 - -(define ACCOUNT_DATA_FILENAME_LIST - (list TOKEN_FILENAME REFRESH_TOKEN_FILENAME TOKEN_EXPIRY_FILENAME) -) ;define - -;; 确保数据目录存在的辅助函数 - -(define (ensure-data-dir-exists) - (let ((data-dir (get-account-data-dir))) - (if (not (url-exists? data-dir)) (system-mkdir data-dir)) - ) ;let -) ;define - -;; 通用：保存账户数据到文件 - -(define (save-account-data filename content) - (ensure-data-dir-exists) - (let ((data-file (get-account-data-file filename))) - ;; 如果文件存在则删除后重新创建，确保覆盖内容 - (when (url-exists? data-file) - (system-remove data-file) - ) ;when - ;; 保存内容到文件 - (string-save content data-file) - ) ;let -) ;define - -;; 通用：从文件读取账户数据 - -(define (load-account-data filename) - (let ((data-file (get-account-data-file filename))) - (if (url-exists? data-file) (string-load data-file) "") - ) ;let -) ;define - -(tm-define (current-stem-profile) - (with sp - (get-preference "stem-profile") - (if (string=? sp "default") "production" sp) - ) ;with -) ;tm-define - -;; stem-preview 只控制是否访问当前环境的蓝绿候选实例。 -;; stem-profile 仍只负责选择 staging 或 production 服务器。 -(tm-define (current-stem-preview?) - (string=? (get-preference "stem-preview") "on") -) ;tm-define - -(tm-define (stem-preview-cookie-header) - (if (current-stem-preview?) - "liii_user_preview=preview; liii_agent_preview=preview; liii_admin_preview=preview" - "" - ) ;if -) ;tm-define - -(tm-define (stem-preview-request-headers url headers) - (let ((preview-cookie (stem-preview-cookie-header))) - (if (and (not (string=? preview-cookie "")) - (string-starts? url (current-stem-site)) - ) ;and - (append headers (list (cons "Cookie" preview-cookie))) - headers - ) ;if - ) ;let -) ;tm-define - -(tm-define (current-stem-site) - (cond ((string=? (current-stem-profile) "production") "https://liiistem.cn") - ((string=? (current-stem-profile) "staging") "https://test.liiistem.cn") - (else "local") - ) ;cond -) ;tm-define - -;; OAuth2 配置 -(tm-define (account-oauth2-config key) - (let ((base-url (current-stem-site))) - (cond ((== key "authorization-url") (string-append base-url "/oauth2-login.html")) - ((== key "access-token-url") (string-append base-url "/api/v1/oauth2/token")) - ((== key "client-identifier") "public-client") - ((== key "scope") "user+llm") - ((== key "preview-cookie-header") (stem-preview-cookie-header)) - ((== key "port-list") - "6029,8087,9256,7438,5173,6391,8642,9901,44118,55055,1895" - ) ; - ((== key "user-info-url") - (string-append base-url "/api/v1/oauth2/membershipInfo") - ) ; - ((== key "pricing-url") (string-append base-url "/pricing.html")) - ((== key "invitation-url") - (string-append base-url "/personal-center/invitation") - ) ; - ((== key "growth-url") - (string-append base-url - "/personal-center/growth?from=oauth&version=v" - (xmacs-version) - ) ;string-append - ) ; - ((== key "click-return-liii-url") "https://liiistem.cn/?from=login_button") - (else "") - ) ;cond - ) ;let -) ;tm-define - -;; 本地 -;; (tm-define (account-oauth2-config key) -;; (cond -;; ((== key "authorization-url") "http://127.0.0.1:3000/oauth2-login") -;; ((== key "access-token-url") "http://127.0.0.1:8081/api/v1/oauth2/token") ;init:oauth2/token -> api/v1/oauth2/token -;; ((== key "client-identifier") "public-client") -;; ((== key "client-secret") "secret") -;; ((== key "scope") "user+llm") -;; ((== key "port-list") "6029,8087,9256,7438,5173,6391,8642,9901,44118,55055,1895") -;; ((== key "user-info-url") "http://127.0.0.1:8081/api/v1/oauth2/membershipInfo") ;init:api/oauthUser/membershipInfo -> api/v1/oauth2/membershipInfo -;; ((== key "pricing-url") "http://127.0.0.1:3000/pricing.html") -;; ((== key "invitation-url") "http://127.0.0.1:3000/personal-center/invitation") -;; ((== key "growth-url") (string-append "http://127.0.0.1:3000/personal-center/growth?from=oauth&version=v" (xmacs-version))) -;; ((== key "click-return-liii-url") "http://127.0.0.1:3000/?from=login_button") -;; (else ""))) - -;; 1.1 token 保存到数据文件 -(tm-define (account-save-token token) (save-account-data TOKEN_FILENAME token)) - -;; 1.2 读取token数据文件 -(tm-define (account-load-token) (load-account-data TOKEN_FILENAME)) - -;; 2.1 refresh_token 保存到数据文件 -(tm-define (account-save-refresh-token refresh-token) - (save-account-data REFRESH_TOKEN_FILENAME refresh-token) -) ;tm-define - -;; 2.2读取refresh_token数据文件 -(tm-define (account-load-refresh-token) - (load-account-data REFRESH_TOKEN_FILENAME) -) ;tm-define - -;; 3.1 token过期时间保存到数据文件 -(tm-define (account-save-token-expiry expiry-time) - (save-account-data TOKEN_EXPIRY_FILENAME expiry-time) -) ;tm-define - -;; 3.2 读取token过期时间数据文件 -(tm-define (account-load-token-expiry) - (load-account-data TOKEN_EXPIRY_FILENAME) -) ;tm-define - -;; 4 清除所有token数据 -(tm-define (account-clear-tokens) - (ensure-data-dir-exists) - (for-each (lambda (filename) - (let ((data-file (get-account-data-file filename))) - (when (url-exists? data-file) - (system-remove data-file) - ) ;when - ) ;let - ) ;lambda - ACCOUNT_DATA_FILENAME_LIST - ) ;for-each -) ;tm-define diff --git a/TeXmacs/plugins/autosave/goldfish/liii/autosave.scm b/TeXmacs/plugins/autosave/goldfish/liii/autosave.scm index df31d769eb..4b1ff8e4ca 100644 --- a/TeXmacs/plugins/autosave/goldfish/liii/autosave.scm +++ b/TeXmacs/plugins/autosave/goldfish/liii/autosave.scm @@ -19,13 +19,8 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-library (liii autosave) - (export autosave-keep-max - autosave-home - autosave-dir - autosave-target-path - ensure-parent-dir - autosave-prune-dir - document->string + (export autosave-keep-max autosave-home autosave-dir autosave-target-path + ensure-parent-dir autosave-prune-dir document->string ) ;export (import (liii base) (liii error) diff --git a/TeXmacs/plugins/autosave/progs/autosave/plugin.scm b/TeXmacs/plugins/autosave/progs/autosave/plugin.scm new file mode 100644 index 0000000000..c792fdd3c6 --- /dev/null +++ b/TeXmacs/plugins/autosave/progs/autosave/plugin.scm @@ -0,0 +1,359 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; MODULE : plugin.scm +;; DESCRIPTION : autosave and auto-backup implementation for the autosave plugin +;; COPYRIGHT : (C) 2026 Darcy Shen +;; +;; This software falls under the GNU general public license version 3 or later. +;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE +;; in the root directory or . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(texmacs-module (autosave plugin) + (:use (utils library cursor) (texmacs texmacs tm-collab)) +) ;texmacs-module + +(import (liii uuid)) +(import (liii json)) +(import (liii path)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Autosave +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define autosave-fixed-interval-ms 120000) + +(tm-define (autosave-enabled?) (!= (get-preference "autosave") "0")) + +(tm-define (auto-backup-enabled?) (!= (get-preference "autobackup") "off")) + +(tm-define (liiistem-version) (xmacs-version)) + +;; auto-backup-texmacs-path-buffer? +;; 判断 buffer 是否位于 get-texmacs-path 返回的目录或其子目录中。 +;; +;; 语法 +;; ---- +;; (auto-backup-texmacs-path-buffer? name) +;; +;; 参数 +;; ---- +;; name : url +;; 待检查的 buffer 名称。 +;; +;; 返回值 +;; ---- +;; boolean +;; #t 表示 buffer 对应路径位于 get-texmacs-path 下。 +;; +;; 逻辑 +;; ---- +;; 将 buffer url 转成系统路径，再使用 (liii path) 的 path-parent 逐级 +;; 向上检查是否能到达 get-texmacs-path。 +;; +;; 注意 +;; ---- +;; TeXmacs 安装路径下的文件被视为只读内置资源，不进入自动备份。 +(tm-define (auto-backup-texmacs-path-buffer? name) + (url-descends? name (get-texmacs-path)) +) ;tm-define + +(define (auto-backup-path->url p) + (system->url (path->string p)) +) ;define + +;; auto-backup-buffer-eligible? +;; 判断指定 buffer 是否允许进入自动备份。 +;; +;; 语法 +;; ---- +;; (auto-backup-buffer-eligible? name) +;; +;; 参数 +;; ---- +;; name : url +;; 待检查的 buffer 名称。 +;; +;; 返回值 +;; ---- +;; boolean +;; #t 表示允许自动备份，#f 表示跳过。 +;; +;; 逻辑 +;; ---- +;; 只允许本地、非 tmfs、非 web 且格式为 texmacs/stm/tmu 的文档备份； +;; 位于 get-texmacs-path 目录或子目录下的内置只读文件直接跳过。 +;; +;; 注意 +;; ---- +;; 这个判断也会影响 doc id 绑定，跳过的只读资源不会被写入 stem-doc-id。 +(tm-define (auto-backup-buffer-eligible? name) + (and (url? name) + (buffer-exists? name) + (not (url-rooted-web? name)) + (not (url-rooted-tmfs? name)) + (not (auto-backup-texmacs-path-buffer? name)) + (in? (url-format name) '("texmacs" "stm" "tmu" "stem")) + ) ;and +) ;tm-define + +(define (auto-backup-valid-doc-id? doc-id) + (and (string? doc-id) (!= doc-id "")) +) ;define + +(tm-define (auto-backup-buffer-doc-id name) + (catch #t + (lambda () + ;; First try to get from init-env (memory), then from document tree (file) + (with-buffer name + (let* ((from-env (get-init-env "stem-doc-id")) + (doc-id (if (and (string? from-env) (!= from-env "")) + from-env + (let* ((doc (buffer-get name)) (initial (tmfile-extract doc 'initial))) + (and initial (collection-ref initial "stem-doc-id")) + ) ;let* + ) ;if + ) ;doc-id + ) ; + doc-id + ) ;let* + ) ;with-buffer + ) ;lambda + (lambda args #f) + ) ;catch +) ;tm-define + +(tm-define (auto-backup-buffer-needs-doc-id? name) + (and (auto-backup-buffer-eligible? name) + (not (auto-backup-valid-doc-id? (auto-backup-buffer-doc-id name))) + ) ;and +) ;tm-define + +;; auto-backup-ensure-buffer-doc-id! +;; 确保可备份 buffer 已经绑定 stem-doc-id。 +;; +;; 语法 +;; ---- +;; (auto-backup-ensure-buffer-doc-id! name) +;; +;; 参数 +;; ---- +;; name : url +;; 待检查和绑定的 buffer 名称。 +;; +;; 返回值 +;; ---- +;; string or #f +;; 返回已有或新生成的 doc id；不可备份或失败时返回 #f。 +;; +;; 逻辑 +;; ---- +;; 先读取 buffer 当前 init-env 或 initial collection 中的 stem-doc-id； +;; 若没有，则生成新的 uuid4 并写入 init-env。 +;; +;; 注意 +;; ---- +;; 这里只写入 init-env，避免触发文档重新解析；doc id 是否持久化到文件由 +;; 用户后续保存动作决定。 +(tm-define (auto-backup-ensure-buffer-doc-id! name) + (catch #t + (lambda () + (and (auto-backup-buffer-eligible? name) + (with-buffer name + (let ((old-doc-id (auto-backup-buffer-doc-id name))) + (if (auto-backup-valid-doc-id? old-doc-id) + old-doc-id + (let ((doc-id (uuid4))) + ;; 写入 init-env 即可绑定到当前会话，避免 buffer-set 触发 + ;; 文档重新解析。 + (init-env "stem-doc-id" doc-id) + doc-id + ) ;let + ) ;if + ) ;let + ) ;with-buffer + ) ;and + ) ;lambda + (lambda args #f) + ) ;catch +) ;tm-define + +(tm-define (auto-backup-trig-payload name kind) + (let* ((collab? (collab-buffer? name)) + ;; 协作文档：path 指向本地不可见备份文件（collab-silent-backup 已在 save-buffer-save + ;; 里同步写盘）；id 用 tmfs URL 的 doc_id 段（非 stem-doc-id，后者对 tmfs 返 #f）。 + (path (if collab? + (url->system (collab-backup-url (collab-url->doc-id name))) + (url->system name) + ) ;if + ) ;path + (doc-id (if collab? (collab-url->doc-id name) (auto-backup-ensure-buffer-doc-id! name)) + ) ;doc-id + (session-id (uuid4)) + (payload (string->json "{}")) + ) ; + (set! payload (json-push payload "path" path)) + (set! payload (json-push payload "type" kind)) + (set! payload (json-push payload "id" doc-id)) + (set! payload (json-push payload "session-id" session-id)) + ;; 云备份请求头所需的 4 个静态字段：autosave 子进程通过 payload 拿到这些值， + ;; 构造 Authorization / User-Agent / X-Device-Id 头和 upload URL。 + ;; 账号模块或 glue 函数在未登录/未加载时会抛异常，逐个 catch 回退空串， + ;; 避免 payload 构造失败导致整个 copy 流程中断。 + (set! payload + (json-push payload + "site" + (catch #t (lambda () (current-stem-site)) (lambda args "")) + ) ;json-push + ) ;set! + (set! payload + (json-push payload + "token" + (catch #t (lambda () (account-load-token)) (lambda args "")) + ) ;json-push + ) ;set! + (set! payload + (json-push payload + "user-agent" + (catch #t (lambda () (stem-user-agent)) (lambda args "")) + ) ;json-push + ) ;set! + (set! payload + (json-push payload + "device-id" + (catch #t (lambda () (stem-device-id)) (lambda args "")) + ) ;json-push + ) ;set! + (values (json->string payload) session-id) + ) ;let* +) ;tm-define + +;; auto-backup-trig +;; 自动备份触发入口，当前仅用于调试输出触发参数。 +;; +;; 语法 +;; ---- +;; (auto-backup-trig u kind) +;; +;; 参数 +;; ---- +;; u : url +;; 需要备份的 buffer url。 +;; +;; kind : string +;; 备份类型，例如 "save"、"save-as"、"export-pdf"、"on-open"、"auto"、"manual-open"。 + +(tm-define (auto-backup-trig u kind) + (when (and (auto-backup-enabled?) + (or (collab-buffer? u) (auto-backup-buffer-eligible? u)) + ) ;and + (receive (s session-id) + (auto-backup-trig-payload u kind) + (silent-feed* "autosave" + session-id + `(document ,(utf8->cork s)) + (lambda (r) (noop)) + '() + ) ;silent-feed* + ) ;receive + ) ;when +) ;tm-define + +;; auto-backup-opened-buffer! +;; 文件打开后的自动备份准备流程。 +;; +;; 语法 +;; ---- +;; (auto-backup-opened-buffer! name) +;; +;; 参数 +;; ---- +;; name : url +;; 已经打开并切换完成的 buffer 名称。 +;; +;; 逻辑 +;; ---- +;; 打开文件时只在当前会话中绑定缺失的 stem-doc-id，避免静默改写源文件； +;; 随后延迟触发一次 on-open 备份，由 md5 去重避免重复版本。 + +(tm-define (auto-backup-opened-buffer! name) + (auto-backup-ensure-buffer-doc-id! name) + (delayed (:pause 100) (auto-backup-trig name "on-open")) +) ;tm-define + +(tm-define (auto-backup-official-url) + (if (== (get-output-language) "chinese") + "https://liiistem.cn/personal-center/backup.html?utm_source=auto_backup_button" + "https://liiistem.com/?utm_source=auto_backup_button" + ) ;if +) ;tm-define + +(tm-define (auto-backup-button-label) + (if (community-stem?) "View help" "Cloud backup") +) ;tm-define + +(tm-define (open-auto-backup-location) + (if (community-stem?) + (open-url "https://liiistem.cn/docs/guide-auto-backup") + (open-url (auto-backup-official-url)) + ) ;if + (auto-backup-trig (current-buffer-url) "visit-cloud-backup") +) ;tm-define + +;; scratch buffer 在磁盘上有真实路径（no_name .tmu），与普通文档一样原地自动保存； +;; 手动 Ctrl+S 的 save-as 弹窗走 save-buffer-check-permissions，不受影响。 +(tm-define (autosave-all) + (for-each (lambda (name) + (when (buffer-modified? name) + (save-buffer-save name (list) "auto") + ) ;when + ) ;lambda + (buffer-list) + ) ;for-each +) ;tm-define + +(tm-define (autosave-now) + (when (autosave-enabled?) + (let ((name (current-buffer))) + (when (buffer-modified? name) + (save-buffer-save name (list) "auto") + ) ;when + ) ;let + ;; 协作文档恒不 buffer-modified?（need_save(true) 短路）；用 buffer-modified-since-autosave? + ;; 捕获本端编辑（远端 apply_remote 不 require_save，故只跟本端）。扫所有 collab buffer， + ;; save-buffer-save 写备份时已清脏，下一 tick 无新编辑即跳过。 + (for-each (lambda (name) + (when (and (collab-buffer? name) (buffer-modified-since-autosave? name)) + (save-buffer-save name (list) "auto") + ) ;when + ) ;lambda + (buffer-list) + ) ;for-each + (autosave-delayed) + ) ;when +) ;tm-define + +(tm-define (save-all-buffers) + (for-each (lambda (buf) + (when (buffer-modified? buf) + (auto-backup-ensure-buffer-doc-id! buf) + (buffer-save buf) + ) ;when + ) ;lambda + (buffer-list) + ) ;for-each +) ;tm-define + +(tm-define (autosave-delayed) + (when (autosave-enabled?) + (delayed (:pause autosave-fixed-interval-ms) (autosave-now)) + ) ;when +) ;tm-define + +(define (notify-autosave var val) + (if (current-view) (begin (autosave-delayed))) +) ;define + +(define-preferences ("autosave" "120" notify-autosave)) diff --git a/TeXmacs/plugins/autosave/progs/init-autosave.scm b/TeXmacs/plugins/autosave/progs/init-autosave.scm index a61ba52b18..d7427a37dd 100644 --- a/TeXmacs/plugins/autosave/progs/init-autosave.scm +++ b/TeXmacs/plugins/autosave/progs/init-autosave.scm @@ -13,7 +13,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (use-modules (binary goldfish)) -(use-modules (plugin autosave)) +(use-modules (autosave plugin)) (import (liii path)) (define (autosave-serialize lan t) diff --git a/TeXmacs/plugins/autosave/progs/plugin/autosave-impl.scm b/TeXmacs/plugins/autosave/progs/plugin/autosave-impl.scm deleted file mode 100644 index 5cedf8b43b..0000000000 --- a/TeXmacs/plugins/autosave/progs/plugin/autosave-impl.scm +++ /dev/null @@ -1,339 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : autosave-impl.scm -;; DESCRIPTION : autosave and auto-backup implementation for the autosave plugin -;; COPYRIGHT : (C) 2026 Darcy Shen -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (plugin autosave-impl) (:use (utils library cursor))) - -(import (liii uuid)) -(import (liii json)) -(import (liii path)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Autosave -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define autosave-fixed-interval-ms 120000) - -(tm-define (autosave-enabled?) (!= (get-preference "autosave") "0")) - -(tm-define (auto-backup-enabled?) (!= (get-preference "autobackup") "off")) - -(tm-define (liiistem-version) (xmacs-version)) - -;; auto-backup-texmacs-path-buffer? -;; 判断 buffer 是否位于 get-texmacs-path 返回的目录或其子目录中。 -;; -;; 语法 -;; ---- -;; (auto-backup-texmacs-path-buffer? name) -;; -;; 参数 -;; ---- -;; name : url -;; 待检查的 buffer 名称。 -;; -;; 返回值 -;; ---- -;; boolean -;; #t 表示 buffer 对应路径位于 get-texmacs-path 下。 -;; -;; 逻辑 -;; ---- -;; 将 buffer url 转成系统路径，再使用 (liii path) 的 path-parent 逐级 -;; 向上检查是否能到达 get-texmacs-path。 -;; -;; 注意 -;; ---- -;; TeXmacs 安装路径下的文件被视为只读内置资源，不进入自动备份。 -(tm-define (auto-backup-texmacs-path-buffer? name) - (url-descends? name (get-texmacs-path)) -) ;tm-define - -(define (auto-backup-path->url p) - (system->url (path->string p)) -) ;define - -(define (auto-backup-format name) - (if (url-scratch? name) "texmacs" (url-format name)) -) ;define - -;; auto-backup-buffer-eligible? -;; 判断指定 buffer 是否允许进入自动备份。 -;; -;; 语法 -;; ---- -;; (auto-backup-buffer-eligible? name) -;; -;; 参数 -;; ---- -;; name : url -;; 待检查的 buffer 名称。 -;; -;; 返回值 -;; ---- -;; boolean -;; #t 表示允许自动备份，#f 表示跳过。 -;; -;; 逻辑 -;; ---- -;; 只允许本地、非 tmfs、非 web 且格式为 texmacs/stm/tmu 的文档备份； -;; 位于 get-texmacs-path 目录或子目录下的内置只读文件直接跳过。 -;; -;; 注意 -;; ---- -;; 这个判断也会影响 doc id 绑定，跳过的只读资源不会被写入 stem-doc-id。 -(tm-define (auto-backup-buffer-eligible? name) - (and (url? name) - (buffer-exists? name) - (not (url-rooted-web? name)) - (not (url-rooted-tmfs? name)) - (not (auto-backup-texmacs-path-buffer? name)) - (in? (auto-backup-format name) '("texmacs" "stm" "tmu" "stem")) - ) ;and -) ;tm-define - -(define (auto-backup-valid-doc-id? doc-id) - (and (string? doc-id) (!= doc-id "")) -) ;define - -(tm-define (auto-backup-buffer-doc-id name) - (catch #t - (lambda () - ;; First try to get from init-env (memory), then from document tree (file) - (with-buffer name - (let* ((from-env (get-init-env "stem-doc-id")) - (doc-id (if (and (string? from-env) (!= from-env "")) - from-env - (let* ((doc (buffer-get name)) (initial (tmfile-extract doc 'initial))) - (and initial (collection-ref initial "stem-doc-id")) - ) ;let* - ) ;if - ) ;doc-id - ) ; - doc-id - ) ;let* - ) ;with-buffer - ) ;lambda - (lambda args #f) - ) ;catch -) ;tm-define - -(tm-define (auto-backup-buffer-needs-doc-id? name) - (and (auto-backup-buffer-eligible? name) - (not (auto-backup-valid-doc-id? (auto-backup-buffer-doc-id name))) - ) ;and -) ;tm-define - -;; auto-backup-ensure-buffer-doc-id! -;; 确保可备份 buffer 已经绑定 stem-doc-id。 -;; -;; 语法 -;; ---- -;; (auto-backup-ensure-buffer-doc-id! name) -;; -;; 参数 -;; ---- -;; name : url -;; 待检查和绑定的 buffer 名称。 -;; -;; 返回值 -;; ---- -;; string or #f -;; 返回已有或新生成的 doc id；不可备份或失败时返回 #f。 -;; -;; 逻辑 -;; ---- -;; 先读取 buffer 当前 init-env 或 initial collection 中的 stem-doc-id； -;; 若没有，则生成新的 uuid4 并写入 init-env。 -;; -;; 注意 -;; ---- -;; 这里只写入 init-env，避免触发文档重新解析；doc id 是否持久化到文件由 -;; 用户后续保存动作决定。 -(tm-define (auto-backup-ensure-buffer-doc-id! name) - (catch #t - (lambda () - (and (auto-backup-buffer-eligible? name) - (with-buffer name - (let ((old-doc-id (auto-backup-buffer-doc-id name))) - (if (auto-backup-valid-doc-id? old-doc-id) - old-doc-id - (let ((doc-id (uuid4))) - ;; 写入 init-env 即可绑定到当前会话，避免 buffer-set 触发 - ;; 文档重新解析。 - (init-env "stem-doc-id" doc-id) - doc-id - ) ;let - ) ;if - ) ;let - ) ;with-buffer - ) ;and - ) ;lambda - (lambda args #f) - ) ;catch -) ;tm-define - -(tm-define (auto-backup-trig-payload name kind) - (let* ((path (url->system name)) - (doc-id (auto-backup-ensure-buffer-doc-id! name)) - (session-id (uuid4)) - (payload (string->json "{}")) - ) ; - (set! payload (json-push payload "path" path)) - (set! payload (json-push payload "type" kind)) - (set! payload (json-push payload "id" doc-id)) - (set! payload (json-push payload "session-id" session-id)) - ;; 云备份请求头所需的 4 个静态字段：autosave 子进程通过 payload 拿到这些值， - ;; 构造 Authorization / User-Agent / X-Device-Id 头和 upload URL。 - ;; 账号模块或 glue 函数在未登录/未加载时会抛异常，逐个 catch 回退空串， - ;; 避免 payload 构造失败导致整个 copy 流程中断。 - (set! payload - (json-push payload - "site" - (catch #t (lambda () (current-stem-site)) (lambda args "")) - ) ;json-push - ) ;set! - (set! payload - (json-push payload - "token" - (catch #t (lambda () (account-load-token)) (lambda args "")) - ) ;json-push - ) ;set! - (set! payload - (json-push payload - "user-agent" - (catch #t (lambda () (stem-user-agent)) (lambda args "")) - ) ;json-push - ) ;set! - (set! payload - (json-push payload - "device-id" - (catch #t (lambda () (stem-device-id)) (lambda args "")) - ) ;json-push - ) ;set! - (values (json->string payload) session-id) - ) ;let* -) ;tm-define - -;; auto-backup-trig -;; 自动备份触发入口，当前仅用于调试输出触发参数。 -;; -;; 语法 -;; ---- -;; (auto-backup-trig u kind) -;; -;; 参数 -;; ---- -;; u : url -;; 需要备份的 buffer url。 -;; -;; kind : string -;; 备份类型，例如 "save"、"save-as"、"export-pdf"、"on-open"、"auto"、"manual-open"。 - -(tm-define (auto-backup-trig u kind) - (when (and (auto-backup-enabled?) (auto-backup-buffer-eligible? u)) - (receive (s session-id) - (auto-backup-trig-payload u kind) - (silent-feed* "autosave" - session-id - `(document ,(utf8->cork s)) - (lambda (r) (noop)) - '() - ) ;silent-feed* - ) ;receive - ) ;when -) ;tm-define - -;; auto-backup-opened-buffer! -;; 文件打开后的自动备份准备流程。 -;; -;; 语法 -;; ---- -;; (auto-backup-opened-buffer! name) -;; -;; 参数 -;; ---- -;; name : url -;; 已经打开并切换完成的 buffer 名称。 -;; -;; 逻辑 -;; ---- -;; 打开文件时只在当前会话中绑定缺失的 stem-doc-id，避免静默改写源文件； -;; 随后延迟触发一次 on-open 备份，由 md5 去重避免重复版本。 - -(tm-define (auto-backup-opened-buffer! name) - (auto-backup-ensure-buffer-doc-id! name) - (delayed (:pause 100) (auto-backup-trig name "on-open")) -) ;tm-define - -(tm-define (auto-backup-official-url) - (if (== (get-output-language) "chinese") - "https://liiistem.cn/personal-center/backup.html?utm_source=auto_backup_button" - "https://liiistem.com/?utm_source=auto_backup_button" - ) ;if -) ;tm-define - -(tm-define (auto-backup-button-label) - (if (community-stem?) "View help" "Cloud backup") -) ;tm-define - -(tm-define (open-auto-backup-location) - (if (community-stem?) - (open-url "https://liiistem.cn/docs/guide-auto-backup") - (open-url (auto-backup-official-url)) - ) ;if - (auto-backup-trig (current-buffer-url) "visit-cloud-backup") -) ;tm-define - -(tm-define (autosave-all) - (for-each (lambda (name) - (when (and (buffer-modified? name) (not (url-scratch? name))) - (save-buffer-save name (list) "auto") - ) ;when - ) ;lambda - (buffer-list) - ) ;for-each -) ;tm-define - -(tm-define (autosave-now) - (when (autosave-enabled?) - (let ((name (current-buffer))) - (when (and (buffer-modified? name) (not (url-scratch? name))) - (save-buffer-save name (list) "auto") - ) ;when - ) ;let - (autosave-delayed) - ) ;when -) ;tm-define - -(tm-define (save-all-buffers) - (for-each (lambda (buf) - (when (buffer-modified? buf) - (auto-backup-ensure-buffer-doc-id! buf) - (buffer-save buf) - ) ;when - ) ;lambda - (buffer-list) - ) ;for-each -) ;tm-define - -(tm-define (autosave-delayed) - (when (autosave-enabled?) - (delayed (:pause autosave-fixed-interval-ms) (autosave-now)) - ) ;when -) ;tm-define - -(define (notify-autosave var val) - (if (current-view) (begin (autosave-delayed))) -) ;define - -(define-preferences ("autosave" "120" notify-autosave)) diff --git a/TeXmacs/plugins/autosave/progs/plugin/autosave.scm b/TeXmacs/plugins/autosave/progs/plugin/autosave.scm deleted file mode 100644 index 789fa0e47c..0000000000 --- a/TeXmacs/plugins/autosave/progs/plugin/autosave.scm +++ /dev/null @@ -1,24 +0,0 @@ - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : autosave.scm -;; DESCRIPTION : Entry point of the (plugin autosave) module -;; -;; This module serves as the entry point loaded by init-autosave.scm. -;; It MUST NOT contain (import ...) statements. -;; -;; Rationale: S7's R7RS (import ...) modifies the evaluation environment -;; in a way that breaks the texmacs module system when the importing module -;; is loaded directly by (use-modules ...). By keeping this top-level loader -;; free of (import ...), the deeper dependency module (autosave-impl) can -;; safely use (import ...). -;; -;; COPYRIGHT : (C) 2026 Darcy Shen -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (plugin autosave) (:use (plugin autosave-impl))) diff --git a/TeXmacs/plugins/bash/doc/bash.en.tmu b/TeXmacs/plugins/bash/doc/bash.en.tmu index 3878826c1c..9a86dfd412 100644 --- a/TeXmacs/plugins/bash/doc/bash.en.tmu +++ b/TeXmacs/plugins/bash/doc/bash.en.tmu @@ -1,4 +1,4 @@ -> +> > @@ -71,5 +71,6 @@ + diff --git a/TeXmacs/plugins/bash/packages/code/bash.stem b/TeXmacs/plugins/bash/packages/code/bash.stem new file mode 100644 index 0000000000..c061fd82cb --- /dev/null +++ b/TeXmacs/plugins/bash/packages/code/bash.stem @@ -0,0 +1,20 @@ +(document (TeXmacs "2.1.4") + (style (tuple "source" "std")) + (body (document (active* (src-title (document (compound "src-package" "bash" "1.0") + (src-purpose (document "Bash Language")) + ) ;document + ) ;src-title + ) ;active* + (concat (use-module "(bash bash-format)") " " (use-module "(bash bash-edit)")) + (assign "bash" + (macro "body" + (with "mode" "prog" "prog-language" "bash" "font-family" "rm" (arg "body")) + ) ;macro + ) ;assign + (assign "bash-code" + (macro "body" (document (pseudo-code (document (bash (arg "body")))))) + ) ;assign + ) ;document + ) ;body + (initial (collection (associate "preamble" "true") (associate "sfactor" "5"))) +) ;document diff --git a/TeXmacs/plugins/bash/packages/code/bash.ts b/TeXmacs/plugins/bash/packages/code/bash.ts deleted file mode 100644 index 46dc8ab5a9..0000000000 --- a/TeXmacs/plugins/bash/packages/code/bash.ts +++ /dev/null @@ -1,30 +0,0 @@ - - -> - -<\body> - - - - <\src-purpose> - Bash Language - - > - - - - >>> - - - <\pseudo-code> - > - - > - - -<\initial> - <\collection> - - - - \ No newline at end of file diff --git a/TeXmacs/plugins/bash/progs/bash/bash-edit.scm b/TeXmacs/plugins/bash/progs/bash/bash-edit.scm new file mode 100644 index 0000000000..f677e06ec2 --- /dev/null +++ b/TeXmacs/plugins/bash/progs/bash/bash-edit.scm @@ -0,0 +1,221 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; MODULE : bash-edit.scm +;; DESCRIPTION : editing bash scripts +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(texmacs-module (bash bash-edit) (:use (prog prog-edit) (bash bash-mode))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Indentation policy +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(tm-define (bash-tabstop) 2) + +(tm-define (get-tabstop) (:mode in-prog-bash?) (bash-tabstop)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Helpers (lightweight, line-based) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (bash-string-prefix? s p) + (and (>= (string-length s) (string-length p)) + (== (substring s 0 (string-length p)) p) + ) ;and +) ;define + +(define (bash-trim-left s) + (let loop + ((i 0) (n (string-length s))) + (if (or (>= i n) (not (char-whitespace? (string-ref s i)))) + (substring s i n) + (loop (+ i 1) n) + ) ;if + ) ;let +) ;define + +(define (bash-trim-right s) + (let loop + ((i (- (string-length s) 1))) + (if (< i 0) + "" + (if (char-whitespace? (string-ref s i)) (loop (- i 1)) (substring s 0 (+ i 1))) + ) ;if + ) ;let +) ;define + +(define (bash-trim s) + (bash-trim-right (bash-trim-left s)) +) ;define + +;; Continuation heuristic: \, pipes, &&, ||, redirects, etc. + +(define bash-continuation-ops + '("|" "||" "&&" "&" ">" ">>" "<" "<<" "2>" "2>>" "1>" "1>>") +) ;define + +(define bash-block-keywords + '("if" "for" "while" "until" "case" "select" "function") +) ;define + +(define (bash-line-continues? line) + (let* ((t (bash-trim-right line)) (n (string-length t))) + (if (<= n 0) + #f + (or (== (string-ref t (- n 1)) #\\) + (let loop + ((xs bash-continuation-ops)) + (if (null? xs) + #f + (let* ((op (car xs)) (m (string-length op))) + (if (and (>= n m) (== (substring t (- n m) n) op)) #t (loop (cdr xs))) + ) ;let* + ) ;if + ) ;let + ) ;or + ) ;if + ) ;let* +) ;define + +(define (bash-line-starts-with-closing-brace? line) + (let ((t (bash-trim-left line))) + (and (> (string-length t) 0) (== (string-ref t 0) #\})) + ) ;let +) ;define + +;; NOTE: this is still a heuristic (prefix-based). Consider word-boundary matching later. + +(define (bash-line-starts-with-fi-done-esac? line) + (let ((t (bash-trim-left line))) + (or (bash-string-prefix? t "fi") + (bash-string-prefix? t "done") + (bash-string-prefix? t "esac") + (bash-string-prefix? t "elif") + (bash-string-prefix? t "else") + ) ;or + ) ;let +) ;define + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Line access +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (bash-get-line row) + (let ((s (program-row row))) + (if s s "") + ) ;let +) ;define + +(define (bash-prev-nonempty-row row) + (let loop + ((r (- row 1))) + (if (< r 0) + -1 + (let* ((line (bash-get-line r)) (t (bash-trim line))) + (if (== t "") (loop (- r 1)) r) + ) ;let* + ) ;if + ) ;let +) ;define + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Indentation computation +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (bash-indent-level-from-prev row) + (let* ((pr (bash-prev-nonempty-row row))) + (if (< pr 0) + 0 + (let* ((pline (bash-get-line pr)) + (trimmed (bash-trim pline)) + (base (string-get-indent pline)) + (tab (get-tabstop)) + (inc? (or (bash-line-continues? pline) + ;; previous line ends with "{" + (and (> (string-length trimmed) 0) + (== (string-ref trimmed (- (string-length trimmed) 1)) #\{) + ) ;and + ;; crude: control keywords that often start blocks + (let loop + ((ws bash-block-keywords)) + (if (null? ws) + #f + (let ((w (car ws))) + (if (bash-string-prefix? trimmed w) #t (loop (cdr ws))) + ) ;let + ) ;if + ) ;let + ) ;or + ) ;inc? + ) ; + (+ base (if inc? tab 0)) + ) ;let* + ) ;if + ) ;let* +) ;define + +(tm-define (program-compute-indentation doc row col) + (:mode in-prog-bash?) + (let* ((tab (get-tabstop)) + (line (bash-get-line row)) + (base (bash-indent-level-from-prev row)) + ) ; + (cond ((or (bash-line-starts-with-closing-brace? line) + (bash-line-starts-with-fi-done-esac? line) + ) ;or + (max 0 (- base tab)) + ) ; + (else base) + ) ;cond + ) ;let* +) ;tm-define + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Commenting +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(tm-define (program-comment-start) (:mode in-prog-bash?) "#") + +(tm-define (program-toggle-comment) + (:mode in-prog-bash?) + (prog-toggle-line-comment "#") +) ;tm-define + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Paste import hook +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(tm-define (kbd-paste) + (:mode in-prog-bash?) + (clipboard-paste-import "bash" "primary") +) ;tm-define + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Brackets / quotes +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(tm-define (bash-bracket-open lbr rbr) (bracket-open lbr rbr "\\")) + +(tm-define (bash-bracket-close lbr rbr) (bracket-close lbr rbr "\\")) + +(tm-define (notify-cursor-moved status) + (:require prog-highlight-brackets?) + (:mode in-prog-bash?) + (select-brackets-after-movement "([{" ")]}" "\\") +) ;tm-define + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Keyboard mappings +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(kbd-map (:mode in-prog-bash?) + ("A-tab" (insert-tabstop)) + ("cmd S-tab" (remove-tabstop)) + ("{" (bash-bracket-open "{" "}")) + ("}" (bash-bracket-close "{" "}")) + ("(" (bash-bracket-open "(" ")")) + (")" (bash-bracket-close "(" ")")) + ("[" (bash-bracket-open "[" "]")) + ("]" (bash-bracket-close "[" "]")) + ("\"" (bash-bracket-open "\"" "\"")) + ("'" (bash-bracket-open "'" "'")) +) ;kbd-map diff --git a/TeXmacs/plugins/bash/progs/bash/bash-format.scm b/TeXmacs/plugins/bash/progs/bash/bash-format.scm new file mode 100644 index 0000000000..a971d1d60d --- /dev/null +++ b/TeXmacs/plugins/bash/progs/bash/bash-format.scm @@ -0,0 +1,32 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; MODULE : bash.scm +;; DESCRIPTION : Bash format definition (minimal) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(texmacs-module (bash bash-format)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Bash source files +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-format bash (:name "Bash shell script") (:suffix "sh" "bash")) + +(define (texmacs->bash x . opts) + (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '())) +) ;define + +(define (bash->texmacs x . opts) + (code->texmacs x) +) ;define + +(define (bash-snippet->texmacs x . opts) + (code-snippet->texmacs x) +) ;define + +(converter texmacs-tree bash-document (:function texmacs->bash)) + +(converter bash-document texmacs-tree (:function bash->texmacs)) + +(converter texmacs-tree bash-snippet (:function texmacs->bash)) + +(converter bash-snippet texmacs-tree (:function bash-snippet->texmacs)) diff --git a/TeXmacs/plugins/bash/progs/bash/bash-lang.scm b/TeXmacs/plugins/bash/progs/bash/bash-lang.scm new file mode 100644 index 0000000000..b1bc8ca0f3 --- /dev/null +++ b/TeXmacs/plugins/bash/progs/bash/bash-lang.scm @@ -0,0 +1,294 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; MODULE : bash-lang.scm +;; DESCRIPTION : Bash Language +;; COPYRIGHT : (C) 2026 Hongli Zha +;; +;; This software falls under the GNU general public license version 3 or later. +;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE +;; in the root directory or . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(texmacs-module (bash bash-lang) (:use (prog default-lang))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Parser Features +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Bash reserved words / builtins / constants +(tm-define (parser-feature lan key) + (:require (and (== lan "bash") (== key "keyword"))) + `(,(string->symbol key) + (extra_chars "_") + ;; 标识符允许下划线 + ;; 常量 + (constant "true" "false") + ;; Bash builtins + (declare_function ":" "." "source" "alias" "unalias" "bg" "fg" "jobs" + "disown" "wait" "kill" "suspend" "cd" "pwd" "dirs" "pushd" "popd" "echo" + "printf" "read" "mapfile" "test" "[" "[[" "type" "hash" "help" "builtin" + "command" "enable" "eval" "exec" "exit" "logout" "return" "export" + "readonly" "unset" "set" "shift" "getopts" "declare" "typeset" "local" + "let" "trap" "shopt" "ulimit" "umask" "history" "fc" "compgen" "complete" + "times") + (external_command "ssh" + "scp" + "rsync" + ;; 常用外部命令 + "curl" + "wget" + "xmake" + "cmake" + "make" + "ninja" + "gcc" + "g++" + "clang" + "clang++" + "python" + "python3" + "pip" + "pip3" + "node" + "npm" + "pnpm" + "docker" + "docker-compose" + "tar" + "zip" + "unzip" + "grep" + "sed" + "awk" + "jq" + "sudo" + "claude" + "ll" + "gh" + "code" + "gco" + ;; Git / GitHub + "git" + "gh" + "gco" + "gcb" + "gcm" + "gca" + "gcp" + "gst" + "gpl" + "gps" + ;; Editor / AI + "code" + "code-insiders" + "vim" + "nvim" + "claude" + "cursor" + "zed" + ;; Common shell aliases + "ll" + "la" + "l" + ;; GNU coreutils + "arch" + "basename" + "b2sum" + "base32" + "base64" + "basenc" + "cat" + "chcon" + "chgrp" + "chmod" + "chown" + "chroot" + "cksum" + "comm" + "cp" + "csplit" + "cut" + "date" + "dd" + "df" + "dir" + "dircolors" + "dirname" + "du" + "env" + "expand" + "expr" + "factor" + "false" + "fmt" + "fold" + "groups" + "head" + "hostid" + "id" + "install" + "join" + "link" + "ln" + "logname" + "ls" + "md5sum" + "mkdir" + "mkfifo" + "mknod" + "mktemp" + "mv" + "nice" + "nl" + "nohup" + "nproc" + "numfmt" + "od" + "paste" + "pathchk" + "pinky" + "pr" + "printenv" + "ptx" + "readlink" + "realpath" + "rm" + "rmdir" + "runcon" + "seq" + "sha1sum" + "sha224sum" + "sha256sum" + "sha384sum" + "sha512sum" + "shred" + "shuf" + "sleep" + "sort" + "split" + "stat" + "stdbuf" + "stty" + "sum" + "sync" + "tac" + "tail" + "tee" + "timeout" + "touch" + "tr" + "true" + "truncate" + "tsort" + "tty" + "uname" + "unexpand" + "uniq" + "unlink" + "uptime" + "users" + "vdir" + "wc" + "who" + "whoami" + "yes") + ;; 关键字 + (keyword "if" "then" "elif" "else" "fi" "for" "in" "until" "while" "do" + "done" "case" "esac" "select" "function" "coproc" "time" "{" "}" "!") + ;; 控制/环境相关 + (keyword_control "break" "continue")) +) ;tm-define + +;; Operators / redirections / parameter expansion helpers +(tm-define (parser-feature lan key) + (:require (and (== lan "bash") (== key "operator"))) + `(,(string->symbol key) + ;; 基本运算符（算术/比较/逻辑） + (operator "+" "-" "*" "/" "%" "**" "++" "--" "==" "!=" "<" ">" "<=" ">=" "!" + "~" "&" "&&" "|" "||" "^" "=" "+=" "-=" "*=" "/=" "%=") + ;; 特殊运算符 + (operator_special ";" ";;" "|&" ">" ">>" "<" "<<" "<<<" "<>" ">|" "2>" "2>>" + "1>" "1>>" "&>" "&>>") + ;; 开闭符号 + (operator_openclose "(" ")" "[" "]" "{" "}") + ;; 字段/参数相关符号（特殊参数 + 参数展开运算符） + (operator_field "$" + "@" + "#" + "?" + "!" + "-" + "*" + ;; $@ $# $? $! $$ $- $* + ":-" + ":=" + ":?" + ":+" + ;; ${var:-x} ${var:=x} ... + "##" + "#" + "%%" + "%" + ;; ${var##pat} ${var%pat} ... + )) +) ;tm-define + +;; Paths / urls +(tm-define (parser-feature lan key) + (:require (and (== lan "bash") (== key "path"))) + `(,(string->symbol key) (enable)) +) ;tm-define + +;; Numbers +(tm-define (parser-feature lan key) + (:require (and (== lan "bash") (== key "number"))) + `(,(string->symbol key) + ;; Bash 算术扩展常见前缀：0x(十六进制), 0(八进制) + (bool_features "decimal" "prefix_0x" "prefix_0") + (separator "_") + (suffix)) +) ;tm-define + +;; Strings +(tm-define (parser-feature lan key) + (:require (and (== lan "bash") (== key "string"))) + `(,(string->symbol key) + (bool_features "single_quote" "double_quote" "multi_byte" "unicode_escape" + "hex_escape") + ;; Bash 常见转义 + (escape_sequences "\\" "\"" "'" "a" "b" "f" "n" "r" "t" "v" "newline" "x" + "u" "U" "$" "`" "!")) +) ;tm-define + +;; Comments +(tm-define (parser-feature lan key) + (:require (and (== lan "bash") (== key "comment"))) + `(,(string->symbol key) (inline "#") (inline_require_space)) +) ;tm-define + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Preferences for syntax highlighting +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (notify-bash-syntax var val) + (syntax-read-preferences "bash") +) ;define + +(define-preferences ("syntax:bash:none" "red" notify-bash-syntax) + ("syntax:bash:comment" "brown" notify-bash-syntax) + ("syntax:bash:error" "dark red" notify-bash-syntax) + ("syntax:bash:constant" "#4040c0" notify-bash-syntax) + ("syntax:bash:constant_number" "#4040c0" notify-bash-syntax) + ("syntax:bash:constant_string" "dark grey" notify-bash-syntax) + ("syntax:bash:constant_char" "#333333" notify-bash-syntax) + ("syntax:bash:declare_function" "#0000c0" notify-bash-syntax) + ("syntax:bash:external_command" "#0000c0" notify-bash-syntax) + ("syntax:bash:declare_type" "#0000c0" notify-bash-syntax) + ("syntax:bash:operator" "#8b008b" notify-bash-syntax) + ("syntax:bash:operator_openclose" "#B02020" notify-bash-syntax) + ("syntax:bash:operator_field" "#B02020" notify-bash-syntax) + ("syntax:bash:operator_special" "orange" notify-bash-syntax) + ("syntax:bash:keyword" "#309090" notify-bash-syntax) + ("syntax:bash:keyword_control" "#309090" notify-bash-syntax) +) ;define-preferences diff --git a/TeXmacs/plugins/bash/progs/bash/bash-mode.scm b/TeXmacs/plugins/bash/progs/bash/bash-mode.scm new file mode 100644 index 0000000000..b9ac74a10c --- /dev/null +++ b/TeXmacs/plugins/bash/progs/bash/bash-mode.scm @@ -0,0 +1,11 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; MODULE : bash-mode.scm +;; DESCRIPTION : mode predicate for bash scripts +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(texmacs-module (bash bash-mode) (:use (kernel texmacs tm-modes))) + +(texmacs-modes (in-bash% (== (get-env "prog-language") "bash")) + (in-prog-bash% #t in-prog% in-bash%) +) ;texmacs-modes diff --git a/TeXmacs/plugins/bash/progs/code/bash-edit.scm b/TeXmacs/plugins/bash/progs/code/bash-edit.scm deleted file mode 100644 index 41e29eaf22..0000000000 --- a/TeXmacs/plugins/bash/progs/code/bash-edit.scm +++ /dev/null @@ -1,178 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; MODULE : bash-edit.scm -;; DESCRIPTION : editing bash scripts -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (code bash-edit) - (:use (prog prog-edit) - (code bash-mode))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Indentation policy -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(tm-define (bash-tabstop) 2) - -(tm-define (get-tabstop) - (:mode in-prog-bash?) - (bash-tabstop)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Helpers (lightweight, line-based) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (bash-string-prefix? s p) - (and (>= (string-length s) (string-length p)) - (== (substring s 0 (string-length p)) p))) - -(define (bash-trim-left s) - (let loop ((i 0) (n (string-length s))) - (if (or (>= i n) - (not (char-whitespace? (string-ref s i)))) - (substring s i n) - (loop (+ i 1) n)))) - -(define (bash-trim-right s) - (let loop ((i (- (string-length s) 1))) - (if (< i 0) "" - (if (char-whitespace? (string-ref s i)) - (loop (- i 1)) - (substring s 0 (+ i 1)))))) - -(define (bash-trim s) (bash-trim-right (bash-trim-left s))) - -;; Continuation heuristic: \, pipes, &&, ||, redirects, etc. -(define bash-continuation-ops '("|" "||" "&&" "&" ">" ">>" "<" "<<" "2>" "2>>" "1>" "1>>")) -(define bash-block-keywords '("if" "for" "while" "until" "case" "select" "function")) -(define (bash-line-continues? line) - (let* ((t (bash-trim-right line)) - (n (string-length t))) - (if (<= n 0) #f - (or - (== (string-ref t (- n 1)) #\\) - (let loop ((xs bash-continuation-ops)) - (if (null? xs) #f - (let* ((op (car xs)) - (m (string-length op))) - (if (and (>= n m) - (== (substring t (- n m) n) op)) - #t - (loop (cdr xs)))))))))) - -(define (bash-line-starts-with-closing-brace? line) - (let ((t (bash-trim-left line))) - (and (> (string-length t) 0) - (== (string-ref t 0) #\})))) - -;; NOTE: this is still a heuristic (prefix-based). Consider word-boundary matching later. -(define (bash-line-starts-with-fi-done-esac? line) - (let ((t (bash-trim-left line))) - (or (bash-string-prefix? t "fi") - (bash-string-prefix? t "done") - (bash-string-prefix? t "esac") - (bash-string-prefix? t "elif") - (bash-string-prefix? t "else")))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Line access -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (bash-get-line row) - (let ((s (program-row row))) - (if s s ""))) - -(define (bash-prev-nonempty-row row) - (let loop ((r (- row 1))) - (if (< r 0) -1 - (let* ((line (bash-get-line r)) - (t (bash-trim line))) - (if (== t "") (loop (- r 1)) r))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Indentation computation -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (bash-indent-level-from-prev row) - (let* ((pr (bash-prev-nonempty-row row))) - (if (< pr 0) 0 - (let* ((pline (bash-get-line pr)) - (trimmed (bash-trim pline)) - (base (string-get-indent pline)) - (tab (get-tabstop)) - (inc? - (or - (bash-line-continues? pline) - ;; previous line ends with "{" - (and (> (string-length trimmed) 0) - (== (string-ref trimmed (- (string-length trimmed) 1)) #\{)) - ;; crude: control keywords that often start blocks - (let loop ((ws bash-block-keywords)) - (if (null? ws) #f - (let ((w (car ws))) - (if (bash-string-prefix? trimmed w) - #t - (loop (cdr ws))))))))) - (+ base (if inc? tab 0)))))) - -(tm-define (program-compute-indentation doc row col) - (:mode in-prog-bash?) - (let* ((tab (get-tabstop)) - (line (bash-get-line row)) - (base (bash-indent-level-from-prev row))) - (cond - ((or (bash-line-starts-with-closing-brace? line) - (bash-line-starts-with-fi-done-esac? line)) - (max 0 (- base tab))) - (else base)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Commenting -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(tm-define (program-comment-start) - (:mode in-prog-bash?) - "#") - -(tm-define (program-toggle-comment) - (:mode in-prog-bash?) - (prog-toggle-line-comment "#")) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Paste import hook -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(tm-define (kbd-paste) - (:mode in-prog-bash?) - (clipboard-paste-import "bash" "primary")) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Brackets / quotes -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(tm-define (bash-bracket-open lbr rbr) - (bracket-open lbr rbr "\\")) - -(tm-define (bash-bracket-close lbr rbr) - (bracket-close lbr rbr "\\")) - -(tm-define (notify-cursor-moved status) - (:require prog-highlight-brackets?) - (:mode in-prog-bash?) - (select-brackets-after-movement "([{" ")]}" "\\")) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Keyboard mappings -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(kbd-map - (:mode in-prog-bash?) - ("A-tab" (insert-tabstop)) - ("cmd S-tab" (remove-tabstop)) - ("{" (bash-bracket-open "{" "}" )) - ("}" (bash-bracket-close "{" "}" )) - ("(" (bash-bracket-open "(" ")" )) - (")" (bash-bracket-close "(" ")" )) - ("[" (bash-bracket-open "[" "]" )) - ("]" (bash-bracket-close "[" "]" )) - ("\"" (bash-bracket-open "\"" "\"" )) - ("'" (bash-bracket-open "'" "'" ))) diff --git a/TeXmacs/plugins/bash/progs/code/bash-lang.scm b/TeXmacs/plugins/bash/progs/code/bash-lang.scm deleted file mode 100644 index d447970534..0000000000 --- a/TeXmacs/plugins/bash/progs/code/bash-lang.scm +++ /dev/null @@ -1,198 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : bash-lang.scm -;; DESCRIPTION : Bash Language -;; COPYRIGHT : (C) 2026 Hongli Zha -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (code bash-lang) - (:use (prog default-lang))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Parser Features -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Bash reserved words / builtins / constants -(tm-define (parser-feature lan key) - (:require (and (== lan "bash") (== key "keyword"))) - `(,(string->symbol key) - (extra_chars "_") ;; 标识符允许下划线 - - ;; 常量 - (constant - "true" "false") - - ;; Bash builtins - (declare_function - ":" "." "source" - "alias" "unalias" - "bg" "fg" "jobs" "disown" "wait" "kill" "suspend" - "cd" "pwd" "dirs" "pushd" "popd" - "echo" "printf" - "read" "mapfile" - "test" "[" "[[" - "type" "hash" "help" - "builtin" "command" "enable" - "eval" "exec" - "exit" "logout" "return" - "export" "readonly" "unset" - "set" "shift" - "getopts" - "declare" "typeset" "local" - "let" - "trap" "shopt" "ulimit" "umask" - "history" "fc" - "compgen" "complete" - "times" - ) - (external_command - "ssh" "scp" "rsync" ;; 常用外部命令 - "curl" "wget" - "xmake" "cmake" "make" "ninja" - "gcc" "g++" "clang" "clang++" - "python" "python3" "pip" "pip3" - "node" "npm" "pnpm" - "docker" "docker-compose" - "tar" "zip" "unzip" - "grep" "sed" "awk" - "jq" - "sudo" - "claude" "ll" "gh" "code" "gco" - ;; Git / GitHub - "git" "gh" - "gco" "gcb" "gcm" "gca" "gcp" "gst" "gpl" "gps" - ;; Editor / AI - "code" "code-insiders" "vim" "nvim" - "claude" "cursor" "zed" - ;; Common shell aliases - "ll" "la" "l" - ;; GNU coreutils - "arch" "basename" "b2sum" "base32" "base64" "basenc" - "cat" "chcon" "chgrp" "chmod" "chown" "chroot" - "cksum" "comm" "cp" "csplit" "cut" "date" "dd" - "df" "dir" "dircolors" "dirname" "du" - "env" "expand" "expr" "factor" "false" "fmt" "fold" - "groups" "head" "hostid" "id" "install" - "join" "link" "ln" "logname" "ls" "md5sum" - "mkdir" "mkfifo" "mknod" "mktemp" "mv" - "nice" "nl" "nohup" "nproc" "numfmt" "od" - "paste" "pathchk" "pinky" "pr" "printenv" "ptx" - "readlink" "realpath" "rm" "rmdir" "runcon" - "seq" "sha1sum" "sha224sum" "sha256sum" "sha384sum" "sha512sum" - "shred" "shuf" "sleep" "sort" "split" "stat" - "stdbuf" "stty" "sum" "sync" "tac" "tail" - "tee" "timeout" "touch" "tr" "true" "truncate" - "tsort" "tty" "uname" "unexpand" "uniq" "unlink" - "uptime" "users" "vdir" "wc" "who" "whoami" "yes") - ;; 关键字 - (keyword - "if" "then" "elif" "else" "fi" - "for" "in" "until" "while" "do" "done" - "case" "esac" "select" - "function" "coproc" "time" - "{" "}" - "!" ) - - ;; 控制/环境相关 - (keyword_control - "break" "continue"))) - -;; Operators / redirections / parameter expansion helpers -(tm-define (parser-feature lan key) - (:require (and (== lan "bash") (== key "operator"))) - `(,(string->symbol key) - - ;; 基本运算符（算术/比较/逻辑） - (operator - "+" "-" "*" "/" "%" "**" - "++" "--" - "==" "!=" "<" ">" "<=" ">=" - "!" "~" - "&" "&&" "|" "||" - "^" - "=" "+=" "-=" "*=" "/=" "%=") - - ;; 特殊运算符 - (operator_special - ";" ";;" - "|&" - ">" ">>" "<" "<<" - "<<<" - "<>" - ">|" - "2>" "2>>" "1>" "1>>" - "&>" "&>>") - - ;; 开闭符号 - (operator_openclose - "(" ")" "[" "]" "{" "}") - - ;; 字段/参数相关符号（特殊参数 + 参数展开运算符） - (operator_field - "$" "@" "#" "?" "!" "-" "*" ;; $@ $# $? $! $$ $- $* - ":-" ":=" ":?" ":+" ;; ${var:-x} ${var:=x} ... - "##" "#" "%%" "%" ;; ${var##pat} ${var%pat} ... - ))) - -;; Paths / urls -(tm-define (parser-feature lan key) - (:require (and (== lan "bash") (== key "path"))) - `(,(string->symbol key) - (enable))) - -;; Numbers -(tm-define (parser-feature lan key) - (:require (and (== lan "bash") (== key "number"))) - `(,(string->symbol key) - ;; Bash 算术扩展常见前缀：0x(十六进制), 0(八进制) - (bool_features "decimal" "prefix_0x" "prefix_0") - (separator "_") - (suffix))) - -;; Strings -(tm-define (parser-feature lan key) - (:require (and (== lan "bash") (== key "string"))) - `(,(string->symbol key) - (bool_features - "single_quote" "double_quote" - "multi_byte" "unicode_escape" "hex_escape") - ;; Bash 常见转义 - (escape_sequences "\\" "\"" "'" "a" "b" "f" "n" "r" "t" "v" - "newline" "x" "u" "U" "$" "`" "!"))) - -;; Comments -(tm-define (parser-feature lan key) - (:require (and (== lan "bash") (== key "comment"))) - `(,(string->symbol key) - (inline "#") - (inline_require_space))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Preferences for syntax highlighting -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (notify-bash-syntax var val) - (syntax-read-preferences "bash")) - -(define-preferences - ("syntax:bash:none" "red" notify-bash-syntax) - ("syntax:bash:comment" "brown" notify-bash-syntax) - ("syntax:bash:error" "dark red" notify-bash-syntax) - ("syntax:bash:constant" "#4040c0" notify-bash-syntax) - ("syntax:bash:constant_number" "#4040c0" notify-bash-syntax) - ("syntax:bash:constant_string" "dark grey" notify-bash-syntax) - ("syntax:bash:constant_char" "#333333" notify-bash-syntax) - ("syntax:bash:declare_function" "#0000c0" notify-bash-syntax) - ("syntax:bash:external_command" "#0000c0" notify-bash-syntax) - ("syntax:bash:declare_type" "#0000c0" notify-bash-syntax) - ("syntax:bash:operator" "#8b008b" notify-bash-syntax) - ("syntax:bash:operator_openclose" "#B02020" notify-bash-syntax) - ("syntax:bash:operator_field" "#B02020" notify-bash-syntax) - ("syntax:bash:operator_special" "orange" notify-bash-syntax) - ("syntax:bash:keyword" "#309090" notify-bash-syntax) - ("syntax:bash:keyword_control" "#309090" notify-bash-syntax)) diff --git a/TeXmacs/plugins/bash/progs/code/bash-mode.scm b/TeXmacs/plugins/bash/progs/code/bash-mode.scm deleted file mode 100644 index 067fd26ec5..0000000000 --- a/TeXmacs/plugins/bash/progs/code/bash-mode.scm +++ /dev/null @@ -1,12 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; MODULE : bash-mode.scm -;; DESCRIPTION : mode predicate for bash scripts -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(texmacs-module (code bash-mode) - (:use (kernel texmacs tm-modes))) - -(texmacs-modes - (in-bash% (== (get-env "prog-language") "bash")) - (in-prog-bash% #t in-prog% in-bash%)) \ No newline at end of file diff --git a/TeXmacs/plugins/bash/progs/data/bash.scm b/TeXmacs/plugins/bash/progs/data/bash.scm deleted file mode 100644 index 19000744c2..0000000000 --- a/TeXmacs/plugins/bash/progs/data/bash.scm +++ /dev/null @@ -1,35 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; MODULE : bash.scm -;; DESCRIPTION : Bash format definition (minimal) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (data bash)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Bash source files -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-format bash - (:name "Bash shell script") - (:suffix "sh" "bash")) - -(define (texmacs->bash x . opts) - (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '()))) - -(define (bash->texmacs x . opts) - (code->texmacs x)) - -(define (bash-snippet->texmacs x . opts) - (code-snippet->texmacs x)) - -(converter texmacs-tree bash-document - (:function texmacs->bash)) - -(converter bash-document texmacs-tree - (:function bash->texmacs)) - -(converter texmacs-tree bash-snippet - (:function texmacs->bash)) - -(converter bash-snippet texmacs-tree - (:function bash-snippet->texmacs)) \ No newline at end of file diff --git a/TeXmacs/plugins/binary/progs/binary/aspell.scm b/TeXmacs/plugins/binary/progs/binary/aspell.scm index 68ab2b1ccd..14d6fdcb85 100644 --- a/TeXmacs/plugins/binary/progs/binary/aspell.scm +++ b/TeXmacs/plugins/binary/progs/binary/aspell.scm @@ -11,24 +11,22 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(texmacs-module (binary aspell) - (:use (binary common))) +(texmacs-module (binary aspell) (:use (binary common))) (define (aspell-binary-candidates) - (cond ((os-macos?) - (list "/opt/homebrew/bin/aspell" - "/usr/local/bin/aspell")) - ((os-win32?) - (list "$USERPROFILE\\scoop\\apps\\aspell\\current\\bin\\aspell.exe")) - (else - (list "/usr/bin/aspell")))) + (cond ((os-macos?) (list "/opt/homebrew/bin/aspell" "/usr/local/bin/aspell")) + ((os-windows?) + (list "$USERPROFILE\\scoop\\apps\\aspell\\current\\bin\\aspell.exe") + ) ; + (else (list "/usr/bin/aspell")) + ) ;cond +) ;define (tm-define (find-binary-aspell) (:synopsis "Find the url to the aspell binary, return (url-none) if not found") - (find-binary (aspell-binary-candidates) "aspell")) + (find-binary (aspell-binary-candidates) "aspell") +) ;tm-define -(tm-define (has-binary-aspell?) - (not (url-none? (find-binary-aspell)))) +(tm-define (has-binary-aspell?) (not (url-none? (find-binary-aspell)))) -(tm-define (version-binary-aspell) - (version-binary (find-binary-aspell))) +(tm-define (version-binary-aspell) (version-binary (find-binary-aspell))) diff --git a/TeXmacs/plugins/binary/progs/binary/common.scm b/TeXmacs/plugins/binary/progs/binary/common.scm index 5f8803e2a4..89553f3b4f 100644 --- a/TeXmacs/plugins/binary/progs/binary/common.scm +++ b/TeXmacs/plugins/binary/progs/binary/common.scm @@ -15,44 +15,59 @@ (define (find-binary-in-path name) (let* ((u (url-resolve-in-path name)) - (excluded? (and (os-win32?) (url-descends? u (system->url "C:\\Windows\\System32"))))) - (if excluded? (url-none) u))) + (excluded? (and (os-windows?) (url-descends? u (system->url "C:\\Windows\\System32"))) + ) ;excluded? + ) ; + (if excluded? (url-none) u) + ) ;let* +) ;define -; If candidates name could bin found in path, return it, otherwise, return (url-none) (define (find-binary-in-candidates-name candidates) - (with names (list-remove-duplicates (map (lambda (x) (url->string (url-tail x))) candidates)) - (with u (list-find (map (lambda (x) (find-binary-in-path x)) names) url-exists?) - (or u (url-none))))) + (with names + (list-remove-duplicates (map (lambda (x) (url->string (url-tail x))) candidates) + ) ;list-remove-duplicates + (with u + (list-find (map (lambda (x) (find-binary-in-path x)) names) url-exists?) + (or u (url-none)) + ) ;with + ) ;with +) ;define -; If candidates exist, return it, otherwise, return #f (define (find-binary-in-candidates candidates) - (with u (list-find candidates (lambda (x) (url-exists? (url-resolve x "r")))) - (and u (url-resolve u "r")))) + (with u + (list-find candidates (lambda (x) (url-exists? (url-resolve x "r")))) + (and u (url-resolve u "r")) + ) ;with +) ;define (define (find-binary-in-specified path) - (with u (url-resolve path "r") - (if (and (url-exists? u) (url-regular? u)) - u - #f))) + (with u (url-resolve path "r") (if (and (url-exists? u) (url-regular? u)) u #f)) +) ;define (tm-define (find-binary candidates binary-id) (let* ((global-binary-opt (get-preference "plugin:binary")) - (this-binary-opt (get-preference (string-append "plugin:binary:" binary-id)))) + (this-binary-opt (get-preference (string-append "plugin:binary:" binary-id))) + ) ; (cond ((== global-binary-opt "off") (url-none)) ((== this-binary-opt "off") (url-none)) ((== this-binary-opt "candidates-only") (find-binary-in-candidates candidates)) - (else - (or (and (!= this-binary-opt "default") (find-binary-in-specified this-binary-opt)) - (find-binary-in-candidates candidates) - (find-binary-in-candidates-name candidates)))))) + (else (or (and (!= this-binary-opt "default") (find-binary-in-specified this-binary-opt)) + (find-binary-in-candidates candidates) + (find-binary-in-candidates-name candidates) + ) ;or + ) ;else + ) ;cond + ) ;let* +) ;tm-define (tm-define (version-binary u) (if (url-none? u) "" - (let* - ((msg (check-stdout (string-append (url->system u) " --version"))) - (msg-l (filter (lambda (x) (not (string-null? x))) - (string-split msg #\newline)))) - (if (== (length msg-l) 0) - "" - (car msg-l))))) + (let* ((msg (check-stdout (string-append (url->system u) " --version"))) + (msg-l (filter (lambda (x) (not (string-null? x))) (string-split msg #\newline)) + ) ;msg-l + ) ; + (if (== (length msg-l) 0) "" (car msg-l)) + ) ;let* + ) ;if +) ;tm-define diff --git a/TeXmacs/plugins/binary/progs/binary/conda.scm b/TeXmacs/plugins/binary/progs/binary/conda.scm index 2677ba62c4..d32899959b 100644 --- a/TeXmacs/plugins/binary/progs/binary/conda.scm +++ b/TeXmacs/plugins/binary/progs/binary/conda.scm @@ -11,70 +11,71 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(texmacs-module (binary conda) - (:use (binary common))) +(texmacs-module (binary conda) (:use (binary common))) (define (conda-binary-candidates) (cond ((os-macos?) - (list "/opt/homebrew/anaconda3/bin/conda" - "/opt/anaconda3/bin/conda" - "/opt/homebrew/miniconda3/bin/conda" - "/opt/miniconda3/bin/conda" - "$HOME/anaconda3/bin/conda" - "$HOME/miniconda3/bin/conda")) - ((os-win32?) + (list "/opt/homebrew/anaconda3/bin/conda" "/opt/anaconda3/bin/conda" + "/opt/homebrew/miniconda3/bin/conda" "/opt/miniconda3/bin/conda" + "$HOME/anaconda3/bin/conda" "$HOME/miniconda3/bin/conda" + ) ;list + ) ; + ((os-windows?) (list "$USERPROFILE/anaconda3/Scripts/conda.exe" - "$PROGRAMDATA/anaconda3/Scripts/conda.exe" - "$USERPROFILE/miniconda3/Scripts/conda.exe")) - (else - (list "$HOME/anaconda3/bin/conda" - "$HOME/miniconda3/bin/conda")))) + "$PROGRAMDATA/anaconda3/Scripts/conda.exe" + "$USERPROFILE/miniconda3/Scripts/conda.exe" + ) ;list + ) ; + (else (list "$HOME/anaconda3/bin/conda" "$HOME/miniconda3/bin/conda")) + ) ;cond +) ;define (tm-define (find-binary-conda) (:synopsis "Find the url to the conda binary, return (url-none) if not found") - (find-binary (conda-binary-candidates) "conda")) + (find-binary (conda-binary-candidates) "conda") +) ;tm-define -(tm-define (has-binary-conda?) - (not (url-none? (find-binary-conda)))) +(tm-define (has-binary-conda?) (not (url-none? (find-binary-conda)))) -(tm-define (version-binary-conda) - (version-binary (find-binary-conda))) +(tm-define (version-binary-conda) (version-binary (find-binary-conda))) (define (conda-prefix) - (url-or - (if (os-win32?) - (system->url "$USERPROFILE/.conda") - (system->url "$HOME/.conda")) - (url-append (url-append (find-binary-conda) (url-parent)) (url-parent)))) + (url-or (if (os-windows?) + (system->url "$USERPROFILE/.conda") + (system->url "$HOME/.conda") + ) ;if + (url-append (url-append (find-binary-conda) (url-parent)) (url-parent)) + ) ;url-or +) ;define (tm-define (conda-env-python-list) - (let* ((path (if (os-win32?) "envs/*/python.exe" "envs/*/bin/python")) - (env-python-list - (url->list - (url-expand - (url-complete (url-append (conda-prefix) path) "fr")))) - (base-python-raw - (url-append (conda-prefix) - (if (os-win32?) "python.exe" "bin/python"))) + (let* ((path (if (os-windows?) "envs/*/python.exe" "envs/*/bin/python")) + (env-python-list (url->list (url-expand (url-complete (url-append (conda-prefix) path) "fr"))) + ) ;env-python-list + (base-python-raw (url-append (conda-prefix) (if (os-windows?) "python.exe" "bin/python")) + ) ;base-python-raw (base-python (url-complete base-python-raw "fr")) - (base-python-list - (if (url-exists? base-python) (list base-python) (list)))) - (append base-python-list env-python-list))) + (base-python-list (if (url-exists? base-python) (list base-python) (list))) + ) ; + (append base-python-list env-python-list) + ) ;let* +) ;tm-define (define (cond-env-name-on-win u) - (if (== (url-tail (url-head (url-head u))) - (string->url "envs")) - (url->string (url-tail (url-head u))) - "base")) + (if (== (url-tail (url-head (url-head u))) (string->url "envs")) + (url->string (url-tail (url-head u))) + "base" + ) ;if +) ;define (define (cond-env-name-on-nix u) - (if (== (url-tail (url-head (url-head (url-head u)))) - (string->url "envs")) - (url->string (url-tail (url-head (url-head u)))) - "base")) + (if (== (url-tail (url-head (url-head (url-head u)))) (string->url "envs")) + (url->string (url-tail (url-head (url-head u)))) + "base" + ) ;if +) ;define (tm-define (conda-env-name u) (:synopsis "Extract the conda env name from the interpreter path") - (if (os-win32?) - (cond-env-name-on-win u) - (cond-env-name-on-nix u))) + (if (os-windows?) (cond-env-name-on-win u) (cond-env-name-on-nix u)) +) ;tm-define diff --git a/TeXmacs/plugins/binary/progs/binary/convert.scm b/TeXmacs/plugins/binary/progs/binary/convert.scm index b18523bacb..e07a936a73 100644 --- a/TeXmacs/plugins/binary/progs/binary/convert.scm +++ b/TeXmacs/plugins/binary/progs/binary/convert.scm @@ -11,37 +11,39 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(texmacs-module (binary convert) - (:use (binary common))) +(texmacs-module (binary convert) (:use (binary common))) (define (convert-binary-candidates) - (cond ((os-macos?) - (list "/opt/homebrew/bin/convert" - "/usr/local/bin/convert")) - ((os-win32?) - (list - "C:\\Program Files*\\ImageMagick*\\convert.exe" - "$USERPROFILE\\scoop\\apps\\imagemagick\\current\\convert.exe")) - (else - (list "/usr/bin/convert")))) + (cond ((os-macos?) (list "/opt/homebrew/bin/convert" "/usr/local/bin/convert")) + ((os-windows?) + (list "C:\\Program Files*\\ImageMagick*\\convert.exe" + "$USERPROFILE\\scoop\\apps\\imagemagick\\current\\convert.exe" + ) ;list + ) ; + (else (list "/usr/bin/convert")) + ) ;cond +) ;define (tm-define (find-binary-convert) (:synopsis "Find the url to the convert binary, return (url-none) if not found") - (find-binary (convert-binary-candidates) "convert")) + (find-binary (convert-binary-candidates) "convert") +) ;tm-define -(tm-define (has-binary-convert?) - (not (url-none? (find-binary-convert)))) +(tm-define (has-binary-convert?) (not (url-none? (find-binary-convert)))) -(tm-define (version-binary-convert) - (version-binary (find-binary-convert))) +(tm-define (version-binary-convert) (version-binary (find-binary-convert))) (tm-define (pdf-file->imagemagick-raster x opts) - (let* ((dest (assoc-ref opts 'dest)) - (res (get-raster-resolution opts))) - ;;(display (string-append "convert -density " res " " x " " dest)) - (system-2 (string-append (url->system (find-binary-convert)) " -density " res) x dest) + (let* ((dest (assoc-ref opts 'dest)) (res (get-raster-resolution opts))) + ;; (display (string-append "convert -density " res " " x " " dest)) + (system-2 (string-append (url->system (find-binary-convert)) " -density " res) + x + dest + ) ;system-2 ;; NOTE: changing the resolution to 300 (the default) causes a problem ;; when converting TeXmacs documents to Html with formulas as images: ;; the formulas appear way too large... - ;;(system-2 (string-append "convert ") x dest) - (if (url-exists? dest) dest #f))) + ;; (system-2 (string-append "convert ") x dest) + (if (url-exists? dest) dest #f) + ) ;let* +) ;tm-define diff --git a/TeXmacs/plugins/binary/progs/binary/goldfish.scm b/TeXmacs/plugins/binary/progs/binary/goldfish.scm index 080eec3765..959f49ef45 100644 --- a/TeXmacs/plugins/binary/progs/binary/goldfish.scm +++ b/TeXmacs/plugins/binary/progs/binary/goldfish.scm @@ -11,22 +11,29 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(texmacs-module (binary goldfish) - (:use (binary common))) +(texmacs-module (binary goldfish) (:use (binary common))) (define (goldfish-binary-candidates) - (cond ((os-win32?) - (list (string-append (url->system (get-texmacs-path)) "/plugins/goldfish/bin/goldfish.exe"))) - (else - (list (string-append (url->system (get-texmacs-path)) "/plugins/goldfish/bin/goldfish"))))) + (cond ((os-windows?) + (list (string-append (url->system (get-texmacs-path)) + "/plugins/goldfish/bin/goldfish.exe" + ) ;string-append + ) ;list + ) ; + (else (list (string-append (url->system (get-texmacs-path)) + "/plugins/goldfish/bin/goldfish" + ) ;string-append + ) ;list + ) ;else + ) ;cond +) ;define (tm-define (find-binary-goldfish) - (:synopsis "Find the url to the goldfish binary, return (url-none) if not found") - (find-binary (goldfish-binary-candidates) "goldfish")) + (:synopsis "Find the url to the goldfish binary, return (url-none) if not found" + ) ;:synopsis + (find-binary (goldfish-binary-candidates) "goldfish") +) ;tm-define -(tm-define (has-binary-goldfish?) - (not (url-none? (find-binary-goldfish)))) - -(tm-define (version-binary-goldfish) - (version-binary (find-binary-goldfish))) +(tm-define (has-binary-goldfish?) (not (url-none? (find-binary-goldfish)))) +(tm-define (version-binary-goldfish) (version-binary (find-binary-goldfish))) diff --git a/TeXmacs/plugins/binary/progs/binary/gs.scm b/TeXmacs/plugins/binary/progs/binary/gs.scm index 79085f51f7..31193b42cd 100644 --- a/TeXmacs/plugins/binary/progs/binary/gs.scm +++ b/TeXmacs/plugins/binary/progs/binary/gs.scm @@ -11,63 +11,87 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(texmacs-module (binary gs) - (:use (binary common))) +(texmacs-module (binary gs) (:use (binary common))) (define (gs-binary-candidates) (cond ((os-macos?) - (list - "/opt/homebrew/Cellar/ghostscript/1*/bin/gs" - "/usr/local/Cellar/ghostscript/1*/bin/gs")) - ((os-win32?) - (list - "$TEXMACS_HOME_PATH\\bin\\gs.exe" - "C:\\Program Files*\\gs\\gs*\\bin\\gswin64c.exe" - "C:\\Program Files*\\gs\\gs*\\bin\\gswin32c.exe")) - (else - (list "/usr/bin/gs")))) + (list "/opt/homebrew/Cellar/ghostscript/1*/bin/gs" + "/usr/local/Cellar/ghostscript/1*/bin/gs" + ) ;list + ) ; + ((os-windows?) + (list "$TEXMACS_HOME_PATH\\bin\\gs.exe" + "C:\\Program Files*\\gs\\gs*\\bin\\gswin64c.exe" + "C:\\Program Files*\\gs\\gs*\\bin\\gswin32c.exe" + ) ;list + ) ; + (else (list "/usr/bin/gs")) + ) ;cond +) ;define (tm-define (find-binary-gs) (:synopsis "Find the url to the gs binary, return (url-none) if not found") - (find-binary (gs-binary-candidates) "gs")) + (find-binary (gs-binary-candidates) "gs") +) ;tm-define -(tm-define (has-binary-gs?) - (not (url-none? (find-binary-gs)))) +(tm-define (has-binary-gs?) (not (url-none? (find-binary-gs)))) -(tm-define (version-binary-gs) - (version-binary (find-binary-gs))) +(tm-define (version-binary-gs) (version-binary (find-binary-gs))) (define (get-image-size-from-bbox line) (let* ((box (string-drop line (length "%%BoundingBox: "))) (num-box (string-replace box "\r" "")) - (fbox (and (> (length box) 0) (map string->float (string-split num-box #\space))))) + (fbox (and (> (length box) 0) (map string->float (string-split num-box #\space))) + ) ;fbox + ) ; (and (== (length fbox) 4) - (list (floor (first fbox)) ;; x1 - (floor (second fbox)) ;; y1 - (ceiling (third fbox)) ;; x2 - (ceiling (fourth fbox)))))) ;; y2 + (list (floor (first fbox)) + ;; x1 + (floor (second fbox)) + ;; y1 + (ceiling (third fbox)) + ;; x2 + (ceiling (fourth fbox)) + ) ;list + ) ;and + ) ;let* +) ;define +;; y2 (define (gs-image-size u) - (let* ((out (check-stderr (string-append - (url->system (find-binary-gs)) - " -dQUIET " - " -dNOPAUSE " - " -dBATCH " - " -dSAFER " - " -sDEVICE=bbox " - (url-sys-concretize u)))) + (let* ((out (check-stderr (string-append (url->system (find-binary-gs)) + " -dQUIET " + " -dNOPAUSE " + " -dBATCH " + " -dSAFER " + " -sDEVICE=bbox " + (url-sys-concretize u) + ) ;string-append + ) ;check-stderr + ) ;out (l (filter (lambda (x) (string-starts? x "%%BoundingBox: ")) - (string-split out #\newline)))) - (if (> (length l) 0) - (get-image-size-from-bbox (car l))))) + (string-split out #\newline) + ) ;filter + ) ;l + ) ; + (if (> (length l) 0) (get-image-size-from-bbox (car l))) + ) ;let* +) ;define (tm-define (eps-image-size u) (let* ((out (string-load u)) (l (filter (lambda (x) (string-starts? x "%%BoundingBox: ")) - (list-take (string-split out #\newline) 100)))) + (list-take (string-split out #\newline) 100) + ) ;filter + ) ;l + ) ; (when (> (length l) 0) (let ((res1 (get-image-size-from-bbox (car l)))) - (if res1 res1 (gs-image-size u)))))) + (if res1 res1 (gs-image-size u)) + ) ;let + ) ;when + ) ;let* +) ;tm-define (tm-define (gs-eps-to-pdf from opts) (let* ((to (assoc-ref opts 'dest)) @@ -76,27 +100,30 @@ (h (number->string (- (fourth box) (second box)))) (offset-x (number->string (- (first box)))) (offset-y (number->string (- (second box)))) - (gs-inline - (string-append - "<< /PageSize [ " w " " h " ] >> setpagedevice gsave " - offset-x " " offset-y " translate " - "1 1 scale")) - (cmd - (string-append - (url->system (find-binary-gs)) - " -dQUIET " - " -dNOPAUSE " - " -dBATCH " - " -dSAFER " - " -sDEVICE=pdfwrite " - " -dAutoRotatePages=/None " - " -dCompatibilityLevel=1.4 " - (string-append " -sOutputFile=" (url->system to) " ") - (string-append " -c " (string-quote gs-inline)) - (string-append " -f " (url-sys-concretize from) " ") - (string-append " -c " (string-quote " grestore "))))) + (gs-inline (string-append "<< /PageSize [ " w " " h + " ] >> setpagedevice gsave " offset-x " " offset-y + " translate " "1 1 scale" + ) ;string-append + ) ;gs-inline + (cmd (string-append (url->system (find-binary-gs)) + " -dQUIET " + " -dNOPAUSE " + " -dBATCH " + " -dSAFER " + " -sDEVICE=pdfwrite " + " -dAutoRotatePages=/None " + " -dCompatibilityLevel=1.4 " + (string-append " -sOutputFile=" (url->system to) " ") + (string-append " -c " (string-quote gs-inline)) + (string-append " -f " (url-sys-concretize from) " ") + (string-append " -c " (string-quote " grestore ")) + ) ;string-append + ) ;cmd + ) ; (debug-message "io" (string-append "call: " cmd "\n")) - (system cmd))) + (system cmd) + ) ;let* +) ;tm-define (tm-define (gs-eps-to-png from opts) (let* ((to (assoc-ref opts 'dest)) @@ -107,32 +134,44 @@ (box_h (- (fourth box) (second box))) (width (if (and opt_w (!= opt_w 0)) opt_w box_w)) (height (if (and opt_h (!= opt_h 0)) opt_h box_w)) - (page_size_in_px (string-append " -g" (number->string (exact (floor width))) "x" - (number->string (exact (floor height))))) - (resolution_in_px (string-append " -r" (number->string (round (/ (* width 72.0) box_w))) "x" - (number->string (round (/ (* height 72.0) box_h))) " ")) + (page_size_in_px (string-append " -g" + (number->string (exact (floor width))) + "x" + (number->string (exact (floor height))) + ) ;string-append + ) ;page_size_in_px + (resolution_in_px (string-append " -r" + (number->string (round (/ (* width 72.0) box_w))) + "x" + (number->string (round (/ (* height 72.0) box_h))) + " " + ) ;string-append + ) ;resolution_in_px (offset-x (number->string (- (first box)))) (offset-y (number->string (- (second box)))) - (gs-inline - (string-append " " offset-x " " offset-y " translate gsave ")) - (cmd (string-append - (string-append - (url->system (find-binary-gs)) - " -dQUIET " - " -dNOPAUSE " - " -dBATCH " - " -dSAFER " - " -sDEVICE=pngalpha " - " -dGraphicsAlphaBits=4 " - " -dTextAlphaBits=4 "; - page_size_in_px - (string-append " -sOutputFile=" (url->system to) " ") - resolution_in_px - (string-append " -c " (string-quote gs-inline)) - (string-append " -f " (url-sys-concretize from) " ") - (string-append " -c " (string-quote " grestore ")))))) + (gs-inline (string-append " " offset-x " " offset-y " translate gsave ")) + (cmd (string-append (string-append (url->system (find-binary-gs)) + " -dQUIET " + " -dNOPAUSE " + " -dBATCH " + " -dSAFER " + " -sDEVICE=pngalpha " + " -dGraphicsAlphaBits=4 " + " -dTextAlphaBits=4 " + page_size_in_px + (string-append " -sOutputFile=" (url->system to) " ") + resolution_in_px + (string-append " -c " (string-quote gs-inline)) + (string-append " -f " (url-sys-concretize from) " ") + (string-append " -c " (string-quote " grestore ")) + ) ;string-append + ) ;string-append + ) ;cmd + ) ; (debug-message "io" (string-append cmd "\n")) - (system cmd))) + (system cmd) + ) ;let* +) ;tm-define (tm-define (gs-pdf-to-png from opts) (let* ((to (assoc-ref opts 'dest)) @@ -143,23 +182,33 @@ (box_h (second image_size)) (width (if (and opt_w (!= opt_w 0)) opt_w box_w)) (height (if (and opt_h (!= opt_h 0)) opt_h box_w)) - (page_size_in_px (string-append " -g" (number->string width) "x" (number->string height))) - (resolution_in_px (string-append " -r" (number->string (/ (* width 72.0) box_w)) "x" - (number->string (/ (* height 72.0) box_h)) " ")) - (cmd (string-append - (string-append - (url->system (find-binary-gs)) - " -dQUIET " - " -dNOPAUSE " - " -dBATCH " - " -dSAFER " - " -sDEVICE=pngalpha " - " -dGraphicsAlphaBits=4 " - " -dTextAlphaBits=4 " - " -dUseCropBox " - (string-append " -sOutputFile=" (url->system to) " ") - page_size_in_px - resolution_in_px - (url-sys-concretize from))))) + (page_size_in_px (string-append " -g" (number->string width) "x" (number->string height)) + ) ;page_size_in_px + (resolution_in_px (string-append " -r" + (number->string (/ (* width 72.0) box_w)) + "x" + (number->string (/ (* height 72.0) box_h)) + " " + ) ;string-append + ) ;resolution_in_px + (cmd (string-append (string-append (url->system (find-binary-gs)) + " -dQUIET " + " -dNOPAUSE " + " -dBATCH " + " -dSAFER " + " -sDEVICE=pngalpha " + " -dGraphicsAlphaBits=4 " + " -dTextAlphaBits=4 " + " -dUseCropBox " + (string-append " -sOutputFile=" (url->system to) " ") + page_size_in_px + resolution_in_px + (url-sys-concretize from) + ) ;string-append + ) ;string-append + ) ;cmd + ) ; (debug-message "io" (string-append cmd "\n")) - (system cmd))) + (system cmd) + ) ;let* +) ;tm-define diff --git a/TeXmacs/plugins/binary/progs/binary/hunspell.scm b/TeXmacs/plugins/binary/progs/binary/hunspell.scm index df1413ea2d..ff7a3409cf 100644 --- a/TeXmacs/plugins/binary/progs/binary/hunspell.scm +++ b/TeXmacs/plugins/binary/progs/binary/hunspell.scm @@ -11,24 +11,21 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(texmacs-module (binary hunspell) - (:use (binary common))) +(texmacs-module (binary hunspell) (:use (binary common))) (define (hunspell-binary-candidates) - (cond ((os-macos?) - (list "/opt/homebrew/bin/hunspell" - "/usr/local/bin/hunspell")) - ((os-win32?) - (list )) - (else - (list "/usr/bin/hunspell")))) + (cond ((os-macos?) (list "/opt/homebrew/bin/hunspell" "/usr/local/bin/hunspell")) + ((os-windows?) (list)) + (else (list "/usr/bin/hunspell")) + ) ;cond +) ;define (tm-define (find-binary-hunspell) - (:synopsis "Find the url to the hunspell binary, return (url-none) if not found") - (find-binary (hunspell-binary-candidates) "hunspell")) + (:synopsis "Find the url to the hunspell binary, return (url-none) if not found" + ) ;:synopsis + (find-binary (hunspell-binary-candidates) "hunspell") +) ;tm-define -(tm-define (has-binary-hunspell?) - (not (url-none? (find-binary-hunspell)))) +(tm-define (has-binary-hunspell?) (not (url-none? (find-binary-hunspell)))) -(tm-define (version-binary-hunspell) - (version-binary (find-binary-hunspell))) +(tm-define (version-binary-hunspell) (version-binary (find-binary-hunspell))) diff --git a/TeXmacs/plugins/binary/progs/binary/identify.scm b/TeXmacs/plugins/binary/progs/binary/identify.scm index 6141080aed..3aa3ed1a5c 100644 --- a/TeXmacs/plugins/binary/progs/binary/identify.scm +++ b/TeXmacs/plugins/binary/progs/binary/identify.scm @@ -11,26 +11,25 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(texmacs-module (binary identify) - (:use (binary common))) +(texmacs-module (binary identify) (:use (binary common))) (define (identify-binary-candidates) - (cond ((os-macos?) - (list "/opt/homebrew/bin/identify" - "/usr/local/bin/identify")) - ((os-win32?) - (list - "C:\\Program Files*\\ImageMagick*\\convert.exe" - "$USERPROFILE\\scoop\\apps\\imagemagick\\current\\identify.exe")) - (else - (list "/usr/bin/identify")))) + (cond ((os-macos?) (list "/opt/homebrew/bin/identify" "/usr/local/bin/identify")) + ((os-windows?) + (list "C:\\Program Files*\\ImageMagick*\\convert.exe" + "$USERPROFILE\\scoop\\apps\\imagemagick\\current\\identify.exe" + ) ;list + ) ; + (else (list "/usr/bin/identify")) + ) ;cond +) ;define (tm-define (find-binary-identify) - (:synopsis "Find the url to the identify binary, return (url-none) if not found") - (find-binary (identify-binary-candidates) "identify")) + (:synopsis "Find the url to the identify binary, return (url-none) if not found" + ) ;:synopsis + (find-binary (identify-binary-candidates) "identify") +) ;tm-define -(tm-define (has-binary-identify?) - (not (url-none? (find-binary-identify)))) +(tm-define (has-binary-identify?) (not (url-none? (find-binary-identify)))) -(tm-define (version-binary-identify) - (version-binary (find-binary-identify))) +(tm-define (version-binary-identify) (version-binary (find-binary-identify))) diff --git a/TeXmacs/plugins/binary/progs/binary/inkscape.scm b/TeXmacs/plugins/binary/progs/binary/inkscape.scm index 2af067ee83..5e5c3ccd7a 100644 --- a/TeXmacs/plugins/binary/progs/binary/inkscape.scm +++ b/TeXmacs/plugins/binary/progs/binary/inkscape.scm @@ -11,23 +11,21 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(texmacs-module (binary inkscape) - (:use (binary common))) +(texmacs-module (binary inkscape) (:use (binary common))) (define (inkscape-binary-candidates) - (cond ((os-macos?) - (list "/Applications/Inkscape.app/Contents/MacOS/inkscape")) - ((os-win32?) - (list "C:\\Program Files*\\Inkscape\\bin\\inkscape.exe")) - (else - (list "/usr/bin/inkscape")))) + (cond ((os-macos?) (list "/Applications/Inkscape.app/Contents/MacOS/inkscape")) + ((os-windows?) (list "C:\\Program Files*\\Inkscape\\bin\\inkscape.exe")) + (else (list "/usr/bin/inkscape")) + ) ;cond +) ;define (tm-define (find-binary-inkscape) - (:synopsis "Find the url to the inkscape binary, return (url-none) if not found") - (find-binary (inkscape-binary-candidates) "inkscape")) + (:synopsis "Find the url to the inkscape binary, return (url-none) if not found" + ) ;:synopsis + (find-binary (inkscape-binary-candidates) "inkscape") +) ;tm-define -(tm-define (has-binary-inkscape?) - (not (url-none? (find-binary-inkscape)))) +(tm-define (has-binary-inkscape?) (not (url-none? (find-binary-inkscape)))) -(tm-define (version-binary-inkscape) - (version-binary (find-binary-inkscape))) +(tm-define (version-binary-inkscape) (version-binary (find-binary-inkscape))) diff --git a/TeXmacs/plugins/binary/progs/binary/julia.scm b/TeXmacs/plugins/binary/progs/binary/julia.scm deleted file mode 100644 index e0eda10f5d..0000000000 --- a/TeXmacs/plugins/binary/progs/binary/julia.scm +++ /dev/null @@ -1,36 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : julia.scm -;; DESCRIPTION : julia Binary plugin -;; COPYRIGHT : (C) 2026 Tianyou Liu -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (binary julia) - (:use (binary common))) - -(define (julia-binary-candidates) - (cond ((os-macos?) - (list "/Applications/Julia-*.app/Contents/Resources/julia/bin/julia" - "$HOME/Applications/Julia-*.app/Contents/Resources/julia/bin/julia" - "/opt/homebrew/bin/julia" - "/usr/local/bin/julia")) - ((os-win32?) - (list "$LOCALAPPDATA/Programs/Julia*/bin/julia.exe" - "C:\\Program Files*\\Julia*\\bin\\julia.exe")) - (else - (list "/usr/bin/julia")))) - -(tm-define (find-binary-julia) - (:synopsis "Find the url to the julia binary, return (url-none) if not found") - (find-binary (julia-binary-candidates) "julia")) - -(tm-define (has-binary-julia?) - (not (url-none? (find-binary-julia)))) - -(tm-define (version-binary-julia) - (version-binary (find-binary-julia))) diff --git a/TeXmacs/plugins/binary/progs/binary/pandoc.scm b/TeXmacs/plugins/binary/progs/binary/pandoc.scm index b41c4ced1c..a6bcbb48f5 100644 --- a/TeXmacs/plugins/binary/progs/binary/pandoc.scm +++ b/TeXmacs/plugins/binary/progs/binary/pandoc.scm @@ -10,25 +10,22 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(texmacs-module (binary pandoc) - (:use (binary common))) +(texmacs-module (binary pandoc) (:use (binary common))) (define (pandoc-binary-candidates) - (cond ((os-macos?) - (list "/usr/local/bin/pandoc" - "/opt/homebrew/bin/pandoc")) - ((os-win32?) - (list "$TEXMACS_PATH\\bin\\pandoc.exe" - "C:\\Program Files\\Pandoc\\pandoc.exe")) - (else - (list "/usr/bin/pandoc" "/usr/local/bin/pandoc")))) + (cond ((os-macos?) (list "/usr/local/bin/pandoc" "/opt/homebrew/bin/pandoc")) + ((os-windows?) + (list "$TEXMACS_PATH\\bin\\pandoc.exe" "C:\\Program Files\\Pandoc\\pandoc.exe") + ) ; + (else (list "/usr/bin/pandoc" "/usr/local/bin/pandoc")) + ) ;cond +) ;define (tm-define (find-binary-pandoc) (:synopsis "Find the url to the pandoc binary, return (url-none) if not found") - (find-binary (pandoc-binary-candidates) "pandoc")) + (find-binary (pandoc-binary-candidates) "pandoc") +) ;tm-define -(tm-define (has-binary-pandoc?) - (not (url-none? (find-binary-pandoc)))) +(tm-define (has-binary-pandoc?) (not (url-none? (find-binary-pandoc)))) -(tm-define (version-binary-pandoc) - (version-binary (find-binary-pandoc))) +(tm-define (version-binary-pandoc) (version-binary (find-binary-pandoc))) diff --git a/TeXmacs/plugins/binary/progs/binary/pdflatex.scm b/TeXmacs/plugins/binary/progs/binary/pdflatex.scm new file mode 100644 index 0000000000..6cdd96b062 --- /dev/null +++ b/TeXmacs/plugins/binary/progs/binary/pdflatex.scm @@ -0,0 +1,44 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; MODULE : pdflatex.scm +;; DESCRIPTION : TikZ Binary plugin (pdflatex) +;; COPYRIGHT : (C) 2024 Darcy Shen +;; 2026 (Jack) Yansong Li +;; +;; This software falls under the GNU general public license version 3 or later. +;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE +;; in the root directory or . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(texmacs-module (binary pdflatex) (:use (binary common))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; pdflatex +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (pdflatex-binary-candidates) + (cond ((os-macos?) + (list "/Library/TeX/texbin/pdflatex" "/usr/texbin/pdflatex" + "/opt/homebrew/bin/pdflatex" "/usr/local/bin/pdflatex" + ) ;list + ) ; + ((os-windows?) + (list "C:\\Program Files*\\MiKTeX*\\miktex\\bin\\x64\\pdflatex.exe" + "C:\\Program Files*\\MiKTeX*\\miktex\\bin\\pdflatex.exe" + ) ;list + ) ; + (else (list "/usr/bin/pdflatex" "/usr/local/bin/pdflatex")) + ) ;cond +) ;define + +(tm-define (find-binary-pdflatex) + (:synopsis "Find the url to the pdflatex binary, return (url-none) if not found" + ) ;:synopsis + (find-binary (pdflatex-binary-candidates) "pdflatex") +) ;tm-define + +(tm-define (has-binary-pdflatex?) (not (url-none? (find-binary-pdflatex)))) + +(tm-define (version-binary-pdflatex) (version-binary (find-binary-pdflatex))) diff --git a/TeXmacs/plugins/binary/progs/binary/pdftocairo.scm b/TeXmacs/plugins/binary/progs/binary/pdftocairo.scm index 7aaa8fdbe0..51850db64a 100644 --- a/TeXmacs/plugins/binary/progs/binary/pdftocairo.scm +++ b/TeXmacs/plugins/binary/progs/binary/pdftocairo.scm @@ -11,27 +11,26 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(texmacs-module (binary pdftocairo) - (:use (binary common))) +(texmacs-module (binary pdftocairo) (:use (binary common))) (define (pdftocairo-binary-candidates) - (cond ((os-macos?) - (list "/opt/homebrew/bin/pdftocairo" - "/usr/local/bin/pdftocairo")) - ((os-win32?) - (list )) - (else - (list "/usr/bin/pdftocairo")))) + (cond ((os-macos?) (list "/opt/homebrew/bin/pdftocairo" "/usr/local/bin/pdftocairo")) + ((os-windows?) (list)) + (else (list "/usr/bin/pdftocairo")) + ) ;cond +) ;define (tm-define (find-binary-pdftocairo) - (:synopsis "Find the url to the pdftocairo binary, return (url-none) if not found") - (find-binary (pdftocairo-binary-candidates) "pdftocairo")) + (:synopsis "Find the url to the pdftocairo binary, return (url-none) if not found" + ) ;:synopsis + (find-binary (pdftocairo-binary-candidates) "pdftocairo") +) ;tm-define -(tm-define (has-binary-pdftocairo?) - (not (url-none? (find-binary-pdftocairo)))) +(tm-define (has-binary-pdftocairo?) (not (url-none? (find-binary-pdftocairo)))) (tm-define (version-binary-pdftocairo) - (version-binary (find-binary-pdftocairo))) + (version-binary (find-binary-pdftocairo)) +) ;tm-define (tm-define (pdf-file->pdftocairo-raster x opts) (let* ((dest (assoc-ref opts 'dest)) @@ -41,8 +40,10 @@ (suffix (url-suffix fullname)) (name (string-drop-right fullname (+ 1 (string-length suffix)))) (res (get-raster-resolution opts)) - (cmd (url->system (find-binary-pdftocairo)))) - ;;(display (string-append cmd " -singlefile " transp "-" fm " -r " res " " x " " name)) - (system-2 (string-append cmd " -singlefile " transp "-" fm " -r " res) - x name) - (if (url-exists? dest) dest #f))) + (cmd (url->system (find-binary-pdftocairo))) + ) ; + ;; (display (string-append cmd " -singlefile " transp "-" fm " -r " res " " x " " name)) + (system-2 (string-append cmd " -singlefile " transp "-" fm " -r " res) x name) + (if (url-exists? dest) dest #f) + ) ;let* +) ;tm-define diff --git a/TeXmacs/plugins/binary/progs/binary/python3.scm b/TeXmacs/plugins/binary/progs/binary/python3.scm deleted file mode 100644 index d19c5e5fdd..0000000000 --- a/TeXmacs/plugins/binary/progs/binary/python3.scm +++ /dev/null @@ -1,35 +0,0 @@ - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : python3.scm -;; DESCRIPTION : python3 Binary plugin -;; COPYRIGHT : (C) 2024 Darcy Shen -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (binary python3) - (:use (binary common))) - -(define (python3-binary-candidates) - (cond ((os-macos?) - (list "/usr/bin/python3" - "/opt/homebrew/bin/python3" - "/usr/local/bin/python3")) - ((os-win32?) - (list "$LOCALAPPDATA/Programs/Python/Python3*/python.exe")) - (else - (list "/usr/bin/python3")))) - -(tm-define (find-binary-python3) - (:synopsis "Find the url to the python3 binary, return (url-none) if not found") - (find-binary (python3-binary-candidates) "python3")) - -(tm-define (has-binary-python3?) - (not (url-none? (find-binary-python3)))) - -(tm-define (version-binary-python3) - (version-binary (find-binary-python3))) diff --git a/TeXmacs/plugins/binary/progs/binary/rsvg-convert.scm b/TeXmacs/plugins/binary/progs/binary/rsvg-convert.scm index 5e5f71f9ac..ec490612e4 100644 --- a/TeXmacs/plugins/binary/progs/binary/rsvg-convert.scm +++ b/TeXmacs/plugins/binary/progs/binary/rsvg-convert.scm @@ -11,32 +11,38 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(texmacs-module (binary rsvg-convert) - (:use (binary common))) +(texmacs-module (binary rsvg-convert) (:use (binary common))) (define (rsvg-convert-binary-candidates) (cond ((os-macos?) - (list "/opt/homebrew/bin/rsvg-convert" - "/usr/local/bin/rsvg-convert")) - ((os-win32?) - (list )) - (else - (list "/usr/bin/rsvg-convert")))) + (list "/opt/homebrew/bin/rsvg-convert" "/usr/local/bin/rsvg-convert") + ) ; + ((os-windows?) (list)) + (else (list "/usr/bin/rsvg-convert")) + ) ;cond +) ;define (tm-define (find-binary-rsvg-convert) - (:synopsis "Find the url to the rsvg-convert binary, return (url-none) if not found") - (find-binary (rsvg-convert-binary-candidates) "rsvg-convert")) + (:synopsis "Find the url to the rsvg-convert binary, return (url-none) if not found" + ) ;:synopsis + (find-binary (rsvg-convert-binary-candidates) "rsvg-convert") +) ;tm-define (tm-define (has-binary-rsvg-convert?) - (not (url-none? (find-binary-rsvg-convert)))) + (not (url-none? (find-binary-rsvg-convert))) +) ;tm-define (tm-define (version-binary-rsvg-convert) - (version-binary (find-binary-rsvg-convert))) + (version-binary (find-binary-rsvg-convert)) +) ;tm-define (tm-define (svg2png-by-rsvg-convert x opts) (let* ((dest (assoc-ref opts 'dest)) (fm (url-format (url-concretize dest))) (res (get-raster-resolution opts)) - (cmd (url->system (find-binary-rsvg-convert)))) + (cmd (url->system (find-binary-rsvg-convert))) + ) ; (system-2 (string-append cmd " -f " fm " -d " res " -o ") dest x) - (if (url-exists? dest) dest #f))) + (if (url-exists? dest) dest #f) + ) ;let* +) ;tm-define diff --git a/TeXmacs/plugins/cite/doc/cite.en.tm b/TeXmacs/plugins/cite/doc/cite.en.tm deleted file mode 100644 index 65b6cef781..0000000000 --- a/TeXmacs/plugins/cite/doc/cite.en.tm +++ /dev/null @@ -1,181 +0,0 @@ - - -> - -<\body> - - - - - Click or click - |Contrib|cite-sort> on the focus toolbar. - - - - Cite two entries: - - Cite three entries: \<#74DC\>\<#4E66\>> - - - - <\session|scheme|default> - <\folded-io|Scheme] > - (use-modules (contrib cite cite-sort-test)) - <|folded-io> - (#1=(inlet 'supports-slidemove? supports-slidemove? 'supports-python? - supports-python? 'all-python-launchers all-python-launchers - 'conda-launchers conda-launchers 'conda-launcher conda-launcher - 'python-launcher python-launcher 'python-utf8-command - python-utf8-command 'python-serialize python-serialize - 'scala-snippet-\texmacs scala-snippet-\texmacs - 'scala-\texmacs scala-\texmacs 'texmacs-\scala - texmacs-\scala 'python-snippet-\texmacs - python-snippet-\texmacs ...)) - - - <\input|Scheme] > - (regtest-cite-sort) - - - <\input|Scheme] > - \; - - - - <\bibliography|bib|tm-plain|global.bib> - <\bib-list|3> - \<#74DC\>\<#4E66\>>\<#5468\>\<#5FD7\>\<#534E\>. - \<#5668\>\<#5B66\>\<#4E60\>>. - \<#6E05\>\<#534E\>\<#5927\>\<#5B66\>\<#51FA\>\<#7248\>\<#793E\>, - \<#5317\>\<#4EAC\>, 1, 1 2016. - - BurtonH.Bloom. - Space/time trade-offs in hash coding with allowable errors. - , 13(7):422-426, jul - 1970. - - StephenCole Kleene. - . - Courier Corporation, 2002. - - - - -<\initial> - <\collection> - - - - -<\attachments> - <\collection> - <\associate|bib-bibliography> - <\db-entry|+M0Oye9e1owShdem|article|10.1145/362686.362692> - - - - - - <|db-entry> - > - - - - - - - - - - - - - - - - - - - - - - - - > - - - - - - - - - - - <\db-entry|+M0Oye9e1owShdel|book|kleene2002mathematical> - - - - - - <|db-entry> - > - - - - - - - - - <\db-entry|+M0Oye9e1owShdep|book|\<#897F\>\<#74DC\>\<#4E66\>> - - - - - - <|db-entry> - \<#5FD7\>\<#534E\>>> - - \<#5668\>\<#5B66\>\<#4E60\>> - - \<#534E\>\<#5927\>\<#5B66\>\<#51FA\>\<#7248\>\<#793E\>> - - - - \<#4EAC\>> - - - - - - - - \ No newline at end of file diff --git a/TeXmacs/plugins/cite/doc/cite.en.tmu b/TeXmacs/plugins/cite/doc/cite.en.tmu new file mode 100644 index 0000000000..f4f65613b0 --- /dev/null +++ b/TeXmacs/plugins/cite/doc/cite.en.tmu @@ -0,0 +1,126 @@ +> + +> + +<\body> + + + + + Click or click |Contrib|cite-sort> on the focus toolbar. + + + + Cite two entries: + + Cite three entries: + + Cite two entries: + + <\bibliography|bib|tm-plain|global.bib> + <\bib-list|5> + 周志华. . 清华大学出版社, 北京, 1 edition, 1 2016. + + 常庚哲 and 史济怀. . 中国科学技术大学出版社, 合肥, 3 edition, 8 2012. + + 李航. . 清华大学出版社, 北京, 1 edition, 3 2012. + + BurtonH.Bloom. Space/time trade-offs in hash coding with allowable errors. , 13(7):422–426, jul 1970. + + StephenCole Kleene. . Courier Corporation, 2002. + + + + +<\initial> + <\collection> + + + + + +<\attachments> + <\collection> + <\associate|bib-bibliography> + <\db-entry|+M0Oye9e1owShdem|article|10.1145/362686.362692> + + + + + + <|db-entry> + > + + + + + + + + + + + + + + + + + + + + + + + + > + + + + + + + + + + + <\db-entry|+M0Oye9e1owShdel|book|kleene2002mathematical> + + + + + + <|db-entry> + > + + + + + + + + + <\db-entry|+M0Oye9e1owShdep|book|西瓜书> + + + + + + <|db-entry> + > + + + + + + + + + + + + + + + + diff --git a/TeXmacs/plugins/cite/packages/contrib/cite-sort.stem b/TeXmacs/plugins/cite/packages/contrib/cite-sort.stem new file mode 100644 index 0000000000..f0d25b56f6 --- /dev/null +++ b/TeXmacs/plugins/cite/packages/contrib/cite-sort.stem @@ -0,0 +1,32 @@ +(document (TeXmacs "2.1.4") + (style (tuple "source" "std")) + (body (document (active* (src-title (document (src-package "cite-sort" "1.0.0") + (src-purpose (document "This package contains macros for the automatic sorting of citations." + ) ;document + ) ;src-purpose + (compound "src-copyright" "2013" "François Poulain, Joris van der Hoeven") + (src-license (document (concat "This software falls under the " + (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE") + ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see " + (hlink "http://www.gnu.org/licenses/gpl-3.0.html" + "http://www.gnu.org/licenses/gpl-3.0.html" + ) ;hlink + "." + ) ;concat + ) ;document + ) ;src-license + ) ;document + ) ;src-title + ) ;active* + (use-module "(cite cite-sort)") + (assign "cite-sort" (macro "body" (extern "cite-sort" (arg "body")))) + (assign "cite-raw" + (xmacro "keys" (cite-sort (map-args "cite-arg" "tuple" "keys"))) + ) ;assign + (assign "cite" + (xmacro "keys" (render-cite (cite-sort (map-args "cite-arg" "tuple" "keys")))) + ) ;assign + ) ;document + ) ;body + (initial (collection (associate "preamble" "true"))) +) ;document diff --git a/TeXmacs/plugins/cite/packages/contrib/cite-sort.ts b/TeXmacs/plugins/cite/packages/contrib/cite-sort.ts deleted file mode 100644 index 4065042757..0000000000 --- a/TeXmacs/plugins/cite/packages/contrib/cite-sort.ts +++ /dev/null @@ -1,33 +0,0 @@ - - -> - -<\body> - - - - <\src-purpose> - This package contains macros for the automatic sorting of citations. - - - - - <\src-license> - This software falls under the . It comes WITHOUT ANY - WARRANTY WHATSOEVER. You should have received a copy of the license - which the software. If not, see . - - > - - - - >>> - - >>> - - >>>> - - - -> \ No newline at end of file diff --git a/TeXmacs/plugins/cite/progs/cite/cite-sort.scm b/TeXmacs/plugins/cite/progs/cite/cite-sort.scm new file mode 100644 index 0000000000..e449ab3fe1 --- /dev/null +++ b/TeXmacs/plugins/cite/progs/cite/cite-sort.scm @@ -0,0 +1,99 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; MODULE : cite-sort.scm +;; DESCRIPTION : support utilities for sorting citations +;; COPYRIGHT : (C) 2013 François Poulain, Joris van der Hoeven +;; 2023 hammerfunctor, jingkaimori +;; +;; This software falls under the GNU general public license version 3 or later. +;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE +;; in the root directory or . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(texmacs-module (cite cite-sort)) + +(define (compare-string s1 s2) + (if (and (string->number s1) (string->number s2)) + (< (string->number s1) (string->number s2)) + (stringnumber s1) (string->number s2)) + (== 1 (- (string->number s2) (string->number s1))) + #f + ) ;if +) ;define + +(define (compare-cite-keys t1 t2 comparator) + (let* ((t1 (car t1)) + (t2 (car t2)) + (s1 (if (string? t1) t1 (convert t1 "texmacs-stree" "verbatim-snippet"))) + (s2 (if (string? t2) t2 (convert t2 "texmacs-stree" "verbatim-snippet"))) + ) ; + (comparator s1 s2) + ) ;let* +) ;define + +(define (expand-references k) + (with key + (stree->tree `(get-binding ,(cadr k))) + (with ret (tree->stree (texmacs-exec key)) (if (!= ret '(uninit)) ret "")) + ) ;with +) ;define + +(define (merge-contiguous new old present) + (let* ((get-write (lambda (item) (car (cdadr item)))) + (flush (lambda () + (if (> (length present) 2) + (list (list (caar present) + `(concat ,@(map get-write present) + ,@(cddar (cdar present)) + ,"-" + ,@(cddar (cdAr present))) + ) ;list + ) ;list + present + ) ;if + ) ;lambda + ) ;flush + ) ; + (if (null? old) + (if (null? present) new (append new (flush))) + (if (null? present) + (merge-contiguous new (cdr old) (list (car old))) + (if (compare-cite-keys (cAr present) (car old) compare-string-inc?) + (merge-contiguous new (cdr old) (append present (list (car old)))) + (merge-contiguous (append new (flush)) (cdr old) (list (car old))) + ) ;if + ) ;if + ) ;if + ) ;let* +) ;define + +(tm-define (indice-sort tup) + (let* ((sorted-tup (list-sort tup (lambda (s1 s2) (compare-cite-keys s1 s2 compare-string))) + ) ;sorted-tup + (merged-tup (merge-contiguous '() sorted-tup '())) + (merged-args (map cadr merged-tup)) + ) ; + merged-args + ) ;let* +) ;tm-define + +(tm-define (cite-sort args) + ;; get a (tuple (concat (write "bib" key_1) (reference value_1))) ... (concat key_n value_n)) + ;; and sort it according to values. + (:secure #t) + (let* ((args (map tree->stree (tree-children args))) + (keys (map expand-references (map caddr args))) + (tup (map list keys args)) + (merged-args (indice-sort tup)) + (ret `(concat ,@(list-intersperse merged-args '(cite-sep)))) + ) ; + ret + ) ;let* +) ;tm-define diff --git a/TeXmacs/plugins/cite/progs/contrib/cite/cite-sort-test.scm b/TeXmacs/plugins/cite/progs/contrib/cite/cite-sort-test.scm deleted file mode 100644 index 1683095051..0000000000 --- a/TeXmacs/plugins/cite/progs/contrib/cite/cite-sort-test.scm +++ /dev/null @@ -1,97 +0,0 @@ - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : cite-sort-test.scm -;; DESCRIPTION : Test suite for cite-sort package -;; COPYRIGHT : (C) 2023 jingkaimori -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (contrib cite cite-sort-test) (:use (contrib cite cite-sort))) - -(import (liii check)) - -(check-set-mode! 'report-failed) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Tests for indice-sort -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (test-indice-sort) - (check (indice-sort '(("1" (concat (write "bib1") (reference "bib1"))) - ("2" (concat (write "bib2") (reference "bib2"))) - ("4" (concat (write "bib4") (reference "bib4"))) - ("5" (concat (write "bib5") (reference "bib5")))) - ) ;indice-sort - => - '((concat (write "bib1") (reference "bib1")) - (concat (write "bib2") (reference "bib2")) - (concat (write "bib4") (reference "bib4")) - (concat (write "bib5") (reference "bib5"))) - ) ;check - - (check (indice-sort '(("1" (concat (write "bib1") (reference "bib1"))) - ("3" (concat (write "bib3") (reference "bib3")))) - ) ;indice-sort - => - '((concat (write "bib1") (reference "bib1")) - (concat (write "bib3") (reference "bib3"))) - ) ;check - - (check (indice-sort '(("1" (concat (write "bib1") (reference "bib1"))) - ("3" (concat (write "bib3") (reference "bib3"))) - ("4" (concat (write "bib4") (reference "bib4"))) - ("5" (concat (write "bib5") (reference "bib5"))) - ("7" (concat (write "bib7") (reference "bib7")))) - ) ;indice-sort - => - '((concat (write "bib1") (reference "bib1")) - (concat (write "bib3") - (write "bib4") - (write "bib5") - (reference "bib3") - "-" - (reference "bib5")) - (concat (write "bib7") (reference "bib7"))) - ) ;check - - (check (indice-sort '(("1" (concat (write "bib1") (reference "bib1"))) - ("2" (concat (write "bib2") (reference "bib2"))) - ("3" (concat (write "bib3") (reference "bib3")))) - ) ;indice-sort - => - '((concat (write "bib1") - (write "bib2") - (write "bib3") - (reference "bib1") - "-" - (reference "bib3"))) - ) ;check - - (check (indice-sort '(("1" (concat (write "bib1") (reference "bib1"))) - ("3" (concat (write "bib3") (reference "bib3"))) - ("4" (concat (write "bib4") (reference "bib4"))) - ("2" (concat (write "bib2") (reference "bib2"))) - ("5" (concat (write "bib5") (reference "bib5")))) - ) ;indice-sort - => - '((concat (write "bib1") - (write "bib2") - (write "bib3") - (write "bib4") - (write "bib5") - (reference "bib1") - "-" - (reference "bib5"))) - ) ;check -) ;define - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Test entry point -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(tm-define (regtest-cite-sort) (test-indice-sort) (check-report)) diff --git a/TeXmacs/plugins/cite/progs/contrib/cite/cite-sort.scm b/TeXmacs/plugins/cite/progs/contrib/cite/cite-sort.scm deleted file mode 100644 index f322c11fc0..0000000000 --- a/TeXmacs/plugins/cite/progs/contrib/cite/cite-sort.scm +++ /dev/null @@ -1,79 +0,0 @@ - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : cite-sort.scm -;; DESCRIPTION : support utilities for sorting citations -;; COPYRIGHT : (C) 2013 François Poulain, Joris van der Hoeven -;; 2023 hammerfunctor, jingkaimori -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (contrib cite cite-sort)) - -(define (compare-string s1 s2) - (if (and (string->number s1) (string->number s2)) - (< (string->number s1) (string->number s2)) - (stringnumber s1) (string->number s2)) - (== 1 (- (string->number s2) (string->number s1))) - #f)) - -(define (compare-cite-keys t1 t2 comparator) - (let* - ((t1 (car t1)) - (t2 (car t2)) - (s1 (if (string? t1) t1 (convert t1 "texmacs-stree" "verbatim-snippet"))) - (s2 (if (string? t2) t2 (convert t2 "texmacs-stree" "verbatim-snippet")))) - (compare-string s1 s2))) - -(define (expand-references k) - (with key (stree->tree `(get-binding ,(cadr k))) - (with ret (tree->stree (texmacs-exec key)) - (if (!= ret '(uninit)) ret "")))) - -(define (merge-contiguous new old present) - (let* - ((get-write (lambda (item) (car (cdadr item)))) - (flush - (lambda () - (if (> (length present) 2) - (list (list - (caar present) - `(concat - ,@(map get-write present) - ,@(cddar (cdar present)) "-" ,@(cddar (cdAr present))))) - present)))) - (if (null? old) - (if (null? present) - new - (append new (flush))) - (if (null? present) - (merge-contiguous new (cdr old) (list (car old))) - (if (compare-cite-keys (cAr present) (car old) compare-string-inc?) - (merge-contiguous new (cdr old) (append present (list (car old)))) - (merge-contiguous (append new (flush)) (cdr old) (list (car old)))))))) - -(tm-define (indice-sort tup) - (let* ((sorted-tup - (list-sort tup (lambda (s1 s2) (compare-cite-keys s1 s2 compare-string)))) - (merged-tup (merge-contiguous '() sorted-tup '())) - (merged-args (map cadr merged-tup))) - merged-args)) - -(tm-define (cite-sort args) - ;; get a (tuple (concat (write "bib" key_1) (reference value_1))) ... (concat key_n value_n)) - ;; and sort it according to values. - (:secure #t) - ; (display* "args: " (tree->stree args)) - (let* ((args (map tree->stree (tree-children args))) - (keys (map expand-references (map caddr args))) - (tup (map list keys args)) - (merged-args (indice-sort tup)) - (ret `(concat ,@(list-intersperse merged-args '(cite-sep))))) - ret)) diff --git a/TeXmacs/plugins/code/progs/code/cpp-edit.scm b/TeXmacs/plugins/code/progs/code/cpp-edit.scm deleted file mode 100644 index 6034a8b428..0000000000 --- a/TeXmacs/plugins/code/progs/code/cpp-edit.scm +++ /dev/null @@ -1,56 +0,0 @@ - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : cpp-edit.scm -;; DESCRIPTION : editing C++ programs -;; COPYRIGHT : -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;; -;; TO-DO: this module should provide automatic indentation and other facilities -;; for C++ source code. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (code cpp-edit) - (:use (prog prog-edit))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Automatic insertion, highlighting and selection of brackets and quotes -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(tm-define (cpp-bracket-open lbr rbr) - (bracket-open lbr rbr "\\")) - -(tm-define (cpp-bracket-close lbr rbr) - (bracket-close lbr rbr "\\")) - -; TODO: select strings first -(tm-define (kbd-select-enlarge) - (:require prog-select-brackets?) - (:mode in-prog-cpp?) - (program-select-enlarge "{" "}")) - -(tm-define (notify-cursor-moved status) - (:require prog-highlight-brackets?) - (:mode in-prog-cpp?) - (select-brackets-after-movement "([{" ")]}" "\\")) - -(tm-define (program-compute-indentation doc row col) - (:mode in-prog-cpp?) - (if (<= row 0) 0 - (let ((prev-row (program-row (- row 1)))) - (if prev-row (string-get-indent prev-row) 0)))) - -(kbd-map - (:mode in-prog-cpp?) - ("{" (cpp-bracket-open "{" "}" )) - ("}" (cpp-bracket-close "{" "}" )) - ("(" (cpp-bracket-open "(" ")" )) - (")" (cpp-bracket-close "(" ")" )) - ("[" (cpp-bracket-open "[" "]" )) - ("]" (cpp-bracket-close "[" "]" )) - ("\"" (cpp-bracket-open "\"" "\"" ))) diff --git a/TeXmacs/plugins/code/progs/code/cpp-lang.scm b/TeXmacs/plugins/code/progs/code/cpp-lang.scm deleted file mode 100644 index 5b86fc754b..0000000000 --- a/TeXmacs/plugins/code/progs/code/cpp-lang.scm +++ /dev/null @@ -1,108 +0,0 @@ - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : cpp-lang.scm -;; DESCRIPTION : the C++ Language -;; COPYRIGHT : (C) 2008 Francis Jamet -;; (C) 2020 Darcy Shen -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (code cpp-lang) - (:use (prog default-lang))) - -(tm-define (parser-feature lan key) - (:require (and (== lan "cpp") (== key "keyword"))) - `(,(string->symbol key) - (constant - "false" "true" "cout" "cin" "cerr" - "null" "nullptr" "nullptr_t" "NULL") - (constant_type - "bool" "byte" "char" "char16_t" "char32_t" "char8_t" "double" "float" - "int" "int16_t" "int32_t" "int8_t" "long" "short" "signed" "uint16_t" - "uint32_t" "uint8_t" "unsigned" "void" "wchar_t") - (declare_type "class" "interface" "enum") - (declare_module "namespace" "using") - (keyword - "asm" "auto" "calloc" "class" "concept" "concrete" "const" - "const_cast" "constant" "constexpr" "default" "delete" "dynamic_cast" - "enum" "explicit" "export" "extern" "free" "friend" "inline" "malloc" - "mutable" "new" "operator" "private" "protected" "public" "realloc" - "register" "reinterpret_cast" "sizeof" "static" "static_cast" - "struct" "template" "this" "to" "typedef" "typeid" "typename" "union" - "virtual" "volatile") - (keyword_conditional - "break" "continue" "do" "else" "for" "if" - "while" "goto" "switch" "case") - (keyword_control - "throw" "catch" "finally" "return" "try" "yield"))) - - -(tm-define (parser-feature lan key) - (:require (and (== lan "cpp") (== key "operator"))) - `(,(string->symbol key) - (operator - "+" "-" "/" "*" "%" ;; Arith - "|" "&" "^" ;; Bit - "<<" ">>" - "==" "!=" "<" ">" "<=" ">=" "&&" "||" "!" "==" ;; Boolean - "+=" "-=" "/=" "*=" "%=" "|=" "&=" "^=" ;; Assignment - "=" ":") - (operator_special "->") - (operator_decoration "@") - (operator_field "." "::") - (operator_openclose "{" "[" "(" ")" "]" "}"))) - - -(define (cpp-number-suffix) - `(suffix - (long "l" "L") - (double "d" "D") - (float "f" "F"))) - -(tm-define (parser-feature lan key) - (:require (and (== lan "cpp") (== key "number"))) - `(,(string->symbol key) - (bool_features - "prefix_0x" - "sci_notation") - ,(cpp-number-suffix) - (separator "_"))) - -(tm-define (parser-feature lan key) - (:require (and (== lan "cpp") (== key "string"))) - `(,(string->symbol key) - (bool_features ) - (escape_sequences "\\" "\"" "'" "b" "f" "n" "r" "t"))) - - -;; https://en.cppreference.com/w/cpp/preprocessor -(tm-define (parser-feature lan key) - (:require (and (== lan "cpp") (== key "preprocessor"))) - `(,(string->symbol key) - (directives - "define" "undef" "include" - "if" "ifdef" "ifndef" "else" "elif" "endif" - "line" "error" "pragma"))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Preferences for syntax highlighting -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (notify-cpp-pref var val) - (syntax-read-preferences "cpp")) - -(define-preferences - ("syntax:cpp:none" "black" notify-cpp-pref) - ("syntax:cpp:comment" "dark grey" notify-cpp-pref) - ("syntax:cpp:keyword" "dark magenta" notify-cpp-pref) - ("syntax:cpp:error" "dark red" notify-cpp-pref) - ("syntax:cpp:preprocessor" "dark brown" notify-cpp-pref) - ("syntax:cpp:preprocessor_directive" "dark green" notify-cpp-pref) - ("syntax:cpp:constant_type" "#4040c0" notify-cpp-pref) - ("syntax:cpp:constant_number" "#4040c0" notify-cpp-pref) - ("syntax:cpp:constant_string" "dark red" notify-cpp-pref)) diff --git a/TeXmacs/plugins/code/progs/code/prog-drd.scm b/TeXmacs/plugins/code/progs/code/prog-drd.scm new file mode 100644 index 0000000000..96f596a384 --- /dev/null +++ b/TeXmacs/plugins/code/progs/code/prog-drd.scm @@ -0,0 +1,28 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; MODULE : prog-drd.scm +;; DESCRIPTION : data relation definitions for prog mode +;; COPYRIGHT : (C) 2005 Joris van der Hoeven +;; +;; This software falls under the GNU general public license version 3 or later. +;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE +;; in the root directory or . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(texmacs-module (code prog-drd)) + +;; Code fragments + +(define-group code-tag (inline-code-tag) (block-code-tag)) + +(define-group inline-code-tag verbatim scm cpp mmx r fortran python scilab shell +) ;define-group + +(define-group block-code-tag verbatim-code scm-code cpp-code mmx-code r-code + fortran-code python-code scilab-code shell-code +) ;define-group + +;; Listings +(define-group listing-tag listing shell-listing scm-listing cpp-listing) diff --git a/TeXmacs/plugins/code/progs/prog/prog-kbd.scm b/TeXmacs/plugins/code/progs/code/prog-kbd.scm similarity index 85% rename from TeXmacs/plugins/code/progs/prog/prog-kbd.scm rename to TeXmacs/plugins/code/progs/code/prog-kbd.scm index 42958c7b4c..9673f28b99 100644 --- a/TeXmacs/plugins/code/progs/prog/prog-kbd.scm +++ b/TeXmacs/plugins/code/progs/code/prog-kbd.scm @@ -11,15 +11,16 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(texmacs-module (prog prog-kbd) +(texmacs-module (code prog-kbd) (:use (kernel gui kbd-define) (utils edit selections) (prog scheme-tools) - (prog prog-mode) + (code prog-mode) (code scheme-edit) - (code cpp-edit) + (cpp cpp-edit) ) ;:use ) ;texmacs-module +(debug-message "keyboard" "(code prog-kbd): registering kbd-map ...\n") (kbd-map (:mode in-prog?) ("cmd i" (program-indent #f)) @@ -45,3 +46,4 @@ ("- -" "--") ("- - -" "---") ) ;kbd-map +(debug-message "keyboard" "(code prog-kbd): kbd-map registered\n") diff --git a/TeXmacs/plugins/code/progs/prog/prog-mode.scm b/TeXmacs/plugins/code/progs/code/prog-mode.scm similarity index 87% rename from TeXmacs/plugins/code/progs/prog/prog-mode.scm rename to TeXmacs/plugins/code/progs/code/prog-mode.scm index 55282201bb..a5612aad30 100644 --- a/TeXmacs/plugins/code/progs/prog/prog-mode.scm +++ b/TeXmacs/plugins/code/progs/code/prog-mode.scm @@ -11,11 +11,9 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(texmacs-module (prog prog-mode) - (:use (kernel texmacs tm-modes))) +(texmacs-module (code prog-mode) (:use (kernel texmacs tm-modes))) -(texmacs-modes - (in-cpp% (== (get-env "prog-language") "cpp")) +(texmacs-modes (in-cpp% (== (get-env "prog-language") "cpp")) (in-prog-cpp% #t in-prog% in-cpp%) (in-dot% (== (get-env "prog-language") "dot")) (in-prog-dot% #t in-prog% in-dot%) @@ -32,4 +30,5 @@ (in-python% (== (get-env "prog-language") "python")) (in-prog-python% #t in-prog% in-python%) (in-julia% (== (get-env "prog-language") "julia")) - (in-prog-julia% #t in-prog% in-julia%)) + (in-prog-julia% #t in-prog% in-julia%) +) ;texmacs-modes diff --git a/TeXmacs/plugins/code/progs/code/scheme-edit.scm b/TeXmacs/plugins/code/progs/code/scheme-edit.scm index be0ab4c9bd..18c8e692de 100644 --- a/TeXmacs/plugins/code/progs/code/scheme-edit.scm +++ b/TeXmacs/plugins/code/progs/code/scheme-edit.scm @@ -13,9 +13,11 @@ (texmacs-module (code scheme-edit) (:use (prog prog-edit) - (prog scheme-tools) - (prog scheme-autocomplete) - (utils misc tm-keywords))) + (prog scheme-tools) + (prog scheme-autocomplete) + (utils misc tm-keywords) + ) ;:use +) ;texmacs-module ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Treatment of special characters @@ -24,195 +26,210 @@ (define (previous-special s col) (cond ((< col 0) col) ((in? (string-ref s col) '(#\( #\) #\space #\")) col) -(else (previous-special s (- col 1))))) + (else (previous-special s (- col 1))) + ) ;cond +) ;define (define (next-special s col) (cond ((>= col (string-length s)) col) ((in? (string-ref s col) '(#\( #\) #\space #\")) col) -(else (next-special s (+ col 1))))) + (else (next-special s (+ col 1))) + ) ;cond +) ;define (define (next-word doc row col) - (and-with par (program-row row) + (and-with par + (program-row row) (and (>= col 0) - (<= col (string-length par)) - (substring par col (next-special par col))))) + (<= col (string-length par)) + (substring par col (next-special par col)) + ) ;and + ) ;and-with +) ;define (define (quoted-backwards s col) (cond ((< col 0) col) ((== (string-ref s col) #\") (- col 1)) -(else (quoted-backwards s (- col 1))))) + (else (quoted-backwards s (- col 1))) + ) ;cond +) ;define (define (quoted-forwards s col) (cond ((>= col (string-length s)) col) ((== (string-ref s col) #\") (+ col 1)) -(else (quoted-forwards s (+ col 1))))) + (else (quoted-forwards s (+ col 1))) + ) ;cond +) ;define (define (string-uncommented s col) (cond ((>= col (string-length s)) col) ((== (string-ref s col) #\;) col) - ((== (string-ref s col) #\") - (string-uncommented s (quoted-forwards s (+ col 1)))) - (else (string-uncommented s (+ col 1))))) + ((== (string-ref s col) #\") + (string-uncommented s (quoted-forwards s (+ col 1))) + ) ; + (else (string-uncommented s (+ col 1))) + ) ;cond +) ;define (define (string-uncommented-length s) - (string-uncommented s 0)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Search for previous arguments -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (string-uncommented s 0) +) ;define (define (previous-argument doc row col level) - ;;(display* "search " row ", " col "\n") (and (>= row 0) - (< row (tree-arity doc)) - (tree-atomic? (tree-ref doc row)) - (with par (tree->string (tree-ref doc row)) - (cond ((>= col (string-length par)) - (with len (string-uncommented-length par) - (previous-argument doc row (- len 1) level))) - ((< col 0) - (previous-argument doc (- row 1) 1000000000 level)) - ((== (string-ref par col) #\() - (cond ((== level 0) #f) - ((== level 1) (cons row col)) - (else (previous-argument - doc row (- col 1) (- level 1))))) - ((== (string-ref par col) #\)) - (previous-argument doc row (- col 1) (+ level 1))) - ((== (string-ref par col) #\space) - (previous-argument doc row (- col 1) level)) - ((== (string-ref par col) #\") - (with ncol (quoted-backwards par (- col 1)) - (if (== level 0) (cons row (+ ncol 1)) - (previous-argument doc row ncol level)))) - (else (with ncol (previous-special par (- col 1)) - (if (== level 0) (cons row (+ ncol 1)) - (previous-argument doc row ncol level)))))))) + (< row (tree-arity doc)) + (tree-atomic? (tree-ref doc row)) + (with par + (tree->string (tree-ref doc row)) + (cond ((>= col (string-length par)) + (with len + (string-uncommented-length par) + (previous-argument doc row (- len 1) level) + ) ;with + ) ; + ((< col 0) (previous-argument doc (- row 1) 1000000000 level)) + ((== (string-ref par col) #\() + (cond ((== level 0) #f) + ((== level 1) (cons row col)) + (else (previous-argument doc row (- col 1) (- level 1))) + ) ;cond + ) ; + ((== (string-ref par col) #\)) + (previous-argument doc row (- col 1) (+ level 1)) + ) ; + ((== (string-ref par col) #\space) (previous-argument doc row (- col 1) level)) + ((== (string-ref par col) #\") + (with ncol + (quoted-backwards par (- col 1)) + (if (== level 0) (cons row (+ ncol 1)) (previous-argument doc row ncol level)) + ) ;with + ) ; + (else (with ncol + (previous-special par (- col 1)) + (if (== level 0) (cons row (+ ncol 1)) (previous-argument doc row ncol level)) + ) ;with + ) ;else + ) ;cond + ) ;with + ) ;and +) ;define (define (previous-arguments doc row col bound) - (with arg (previous-argument doc row col 0) + (with arg + (previous-argument doc row col 0) (cond ((not arg) '()) ((<= bound 0) '((-1 -1))) (else (let* ((nrow (car arg)) (ncol (- (cdr arg) 1)) - (nbound (if (== nrow row) bound (- bound 1)))) - (cons arg (previous-arguments doc nrow ncol nbound))))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Automatic indentation -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (nbound (if (== nrow row) bound (- bound 1))) + ) ; + (cons arg (previous-arguments doc nrow ncol nbound)) + ) ;let* + ) ;else + ) ;cond + ) ;with +) ;define (define (reference-type doc l) - (if (null? l) "" - (with arg (cAr l) - (or (next-word doc (car arg) (cdr arg)) "")))) + (if (null? l) "" (with arg (cAr l) (or (next-word doc (car arg) (cdr arg)) ""))) +) ;define (define (reference-argument l) (cond ((null? l) #f) ((null? (cdr l)) (car l)) ((null? (cddr l)) (car l)) - (else (let* ((a1 (car l)) - (a2 (cadr l))) - (if (< (car a2) (car a1)) a1 - (reference-argument (cdr l))))))) + (else (let* ((a1 (car l)) (a2 (cadr l))) + (if (< (car a2) (car a1)) a1 (reference-argument (cdr l))) + ) ;let* + ) ;else + ) ;cond +) ;define (define (tm-count l inc) - ;; helper routine for correct indentation of and (cond ((null? l) 0) ((== (car l) #\<) (tm-count (cdr l) 0)) ((== (car l) #\>) (+ (tm-count (cdr l) 1) 1)) - (else (+ (tm-count (cdr l) inc) inc)))) + (else (+ (tm-count (cdr l) inc) inc)) + ) ;cond +) ;define (define (get-offset doc a) - ;; helper routine for correct indentation of and - (with s (tree->string (tree-ref doc (car a))) - (tm-count (string->list (substring s 0 (cdr a))) 1))) - + (with s + (tree->string (tree-ref doc (car a))) + (tm-count (string->list (substring s 0 (cdr a))) 1) + ) ;with +) ;define (tm-define (program-compute-indentation doc row col) (:mode in-prog-scheme?) (let* ((l (previous-arguments doc row col 10)) (t (reference-type doc l)) (i (indent-get-arity t)) (n (length l)) - (a (reference-argument l))) + (a (reference-argument l)) + ) ; (cond ((not a) 0) ((not i) (get-offset doc a)) ((<= n i) (+ (get-offset doc (cAr l)) 3)) ((== n (+ i 1)) (+ (get-offset doc (cAr l)) 1)) - (else (get-offset doc a))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; User interface for autocompletion -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - + (else (get-offset doc a)) + ) ;cond + ) ;let* +) ;tm-define (tm-define (kbd-variant t forwards?) (:mode in-prog-scheme?) (if (not scheme-completions-built?) (scheme-completions-rebuild)) - (custom-complete (tm->tree (scheme-completions (cursor-word))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Automatic insertion, highlighting and selection of brackets and quotes -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(tm-define (scheme-bracket-open lbr rbr) - (bracket-open lbr rbr "\\")) - -(tm-define (scheme-bracket-close lbr rbr) - (bracket-close lbr rbr "\\")) - -; TODO: select strings first + (custom-complete (tm->tree (scheme-completions (cursor-word)))) +) ;tm-define +(tm-define (scheme-bracket-open lbr rbr) (bracket-open lbr rbr "\\")) +(tm-define (scheme-bracket-close lbr rbr) (bracket-close lbr rbr "\\")) (tm-define (kbd-select-enlarge) (:require prog-select-brackets?) (:mode in-prog-scheme?) - (program-select-enlarge "(" ")")) - + (program-select-enlarge "(" ")") +) ;tm-define (tm-define (notify-cursor-moved status) (:require prog-highlight-brackets?) (:mode in-prog-scheme?) - (select-brackets-after-movement "([{" ")]}" "\\")) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Preferences for syntax highlighting -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (select-brackets-after-movement "([{" ")]}" "\\") +) ;tm-define (define (notify-scheme-syntax var val) - (syntax-read-preferences "scheme")) - -(define-preferences - ("syntax:scheme:none" "red" notify-scheme-syntax) - ("syntax:scheme:comment" "brown" notify-scheme-syntax) - ("syntax:scheme:keyword" "#309090" notify-scheme-syntax) - ("syntax:scheme:error" "dark red" notify-scheme-syntax) - ("syntax:scheme:constant_number" "#4040c0" notify-scheme-syntax) - ("syntax:scheme:constant_string" "dark grey" notify-scheme-syntax) - ("syntax:scheme:constant_char" "#333333" notify-scheme-syntax) - ("syntax:scheme:variable_identifier" "#204080" notify-scheme-syntax) - ("syntax:scheme:declare_category" "#d030d0" notify-scheme-syntax)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Copy and Paste -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (syntax-read-preferences "scheme") +) ;define +(define-preferences ("syntax:scheme:none" "red" notify-scheme-syntax) + ("syntax:scheme:comment" "brown" notify-scheme-syntax) + ("syntax:scheme:keyword" "#309090" notify-scheme-syntax) + ("syntax:scheme:error" "dark red" notify-scheme-syntax) + ("syntax:scheme:constant_number" "#4040c0" notify-scheme-syntax) + ("syntax:scheme:constant_string" "dark grey" notify-scheme-syntax) + ("syntax:scheme:constant_char" "#333333" notify-scheme-syntax) + ("syntax:scheme:variable_identifier" "#204080" notify-scheme-syntax) + ("syntax:scheme:declare_category" "#d030d0" notify-scheme-syntax) +) ;define-preferences (define (textual? x) (or (tm-atomic? x) - (and (tm-in? x '(concat document)) - (forall? textual? (tm-children x))))) - -(kbd-map - (:mode in-prog-scheme?) - ("(" (scheme-bracket-open "(" ")" )) - (")" (scheme-bracket-close "(" ")" )) - ("[" (scheme-bracket-open "[" "]" )) - ("]" (scheme-bracket-close "[" "]" )) - ("\"" (scheme-bracket-open "\"" "\""))) - -(kbd-map - (:require (and developer-mode? (in-prog-scheme?))) - ("A-F1" (scheme-popup-help (cursor-word))) - ("cmd A-F1" (scheme-inbuffer-help (cursor-word))) - ("std F1" (scheme-go-to-definition (cursor-word)))) - -(kbd-map - (:require (and developer-mode? (in-prog-scheme?) - (== "scheme-file" (file-format (current-buffer-url))))) - ("std R" (run-scheme-file (current-buffer-url)))) + (and (tm-in? x '(concat document)) (forall? textual? (tm-children x))) + ) ;or +) ;define +(kbd-map (:mode in-prog-scheme?) + ("(" (scheme-bracket-open "(" ")")) + (")" (scheme-bracket-close "(" ")")) + ("[" (scheme-bracket-open "[" "]")) + ("]" (scheme-bracket-close "[" "]")) + ("\"" (scheme-bracket-open "\"" "\"")) +) ;kbd-map + +(kbd-map (:require (and developer-mode? (in-prog-scheme?))) + ("A-F1" (scheme-popup-help (cursor-word))) + ("cmd A-F1" (scheme-inbuffer-help (cursor-word))) + ("std F1" (scheme-go-to-definition (cursor-word))) +) ;kbd-map + +(kbd-map (:require (and developer-mode? + (in-prog-scheme?) + (== "scheme-file" (file-format (current-buffer-url))) + ) ;and + ) ;:require + ("std R" (run-scheme-file (current-buffer-url))) +) ;kbd-map diff --git a/TeXmacs/plugins/code/progs/init-code.scm b/TeXmacs/plugins/code/progs/init-code.scm new file mode 100644 index 0000000000..47c39b0445 --- /dev/null +++ b/TeXmacs/plugins/code/progs/init-code.scm @@ -0,0 +1,15 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; MODULE : init-code.scm +;; DESCRIPTION : Initialize the code plugin +;; COPYRIGHT : (C) 2026 Darcy Shen +;; +;; This software falls under the GNU general public license version 3 or later. +;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE +;; in the root directory or . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(texmacs-module (code)) + +(lazy-keyboard (code prog-kbd) in-prog?) diff --git a/TeXmacs/plugins/code/progs/prog/prog-drd.scm b/TeXmacs/plugins/code/progs/prog/prog-drd.scm deleted file mode 100644 index d819cf2f79..0000000000 --- a/TeXmacs/plugins/code/progs/prog/prog-drd.scm +++ /dev/null @@ -1,31 +0,0 @@ - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : prog-drd.scm -;; DESCRIPTION : data relation definitions for prog mode -;; COPYRIGHT : (C) 2005 Joris van der Hoeven -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (prog prog-drd)) - -;; Code fragments - -(define-group code-tag - (inline-code-tag) (block-code-tag)) - -(define-group inline-code-tag - verbatim scm cpp mmx r fortran - python scilab shell) - -(define-group block-code-tag - verbatim-code scm-code cpp-code mmx-code r-code fortran-code - python-code scilab-code shell-code) - -;; Listings -(define-group listing-tag - listing shell-listing scm-listing cpp-listing) diff --git a/TeXmacs/plugins/comment/packages/utilities/comment.stem b/TeXmacs/plugins/comment/packages/utilities/comment.stem new file mode 100644 index 0000000000..df34dbec78 --- /dev/null +++ b/TeXmacs/plugins/comment/packages/utilities/comment.stem @@ -0,0 +1,391 @@ +(document (TeXmacs "2.1.4") + (style "source") + (body (document (active* (src-title (document (src-package "comment" "1.0") + (src-purpose (document "Various types of comments by various authors on a text") + ) ;src-purpose + (src-copyright "2020" "Joris van der Hoeven") + (src-license (document (concat "This software falls under the " + (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE") + ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see " + (hlink "http://www.gnu.org/licenses/gpl-3.0.html" + "http://www.gnu.org/licenses/gpl-3.0.html" + ) ;hlink + "." + ) ;concat + ) ;document + ) ;src-license + ) ;document + ) ;src-title + ) ;active* + (use-package "std-shadow") + (use-module "(comment comment-menu)") + (active* (document (src-comment (document "Rendering macros")))) + (concat (assign "comment-color" + (macro "type" "by" (extern "ext-comment-color" (arg "type") (arg "by"))) + ) ;assign + " " + (assign "comment-bg-color" (macro "type" "by" (extern "ext-comment-bg-color"))) + ) ;concat + (assign "abbreviate-name" + (macro "by" (extern "ext-abbreviate-name" (arg "by"))) + ) ;assign + (assign "render-inline-comment" + (macro "type" + "by" + "body" + (surround (with "color" + (comment-color (arg "type") (arg "by")) + (concat "[" (condensed (name (abbreviate-name (arg "by")))) ": ") + ) ;with + (with "color" (compound "comment-color" (arg "type") (arg "by")) "]") + (arg "body") + ) ;surround + ) ;macro + ) ;assign + (assign "render-block-comment" + (macro "type" + "by" + "body" + (surround (with "color" + (comment-color (arg "type") (arg "by")) + (concat (name (abbreviate-name (arg "by"))) " ") + ) ;with + "" + (arg "body") + ) ;surround + ) ;macro + ) ;assign + (assign "render-box-comment" + (macro "type" + "by" + "body" + (document (with "shadow-elevation" + "0.75" + (half-bend-in-shadow (document (wide-tabular (document (tformat (cwith "1" + "1" + "1" + "1" + "cell-background" + (comment-color (arg "type") (arg "by")) + ) ;cwith + (cwith "1" "-1" "1" "1" "cell-lsep" "1spc") + (cwith "1" "-1" "1" "1" "cell-rsep" "1spc") + (cwith "1" "-1" "1" "1" "cell-tsep" "0.5spc") + (cwith "1" "-1" "1" "1" "cell-bsep" "0.5spc") + (cwith "2" "-1" "1" "1" "cell-tsep" "2spc") + (cwith "2" "-1" "1" "1" "cell-bsep" "1spc") + (table (row (cell (document (samp (with "color" "white" "locus-color" "preserve" (copy (arg "by")))) + ) ;document + ) ;cell + ) ;row + (row (cell (document (arg "body")))) + ) ;table + ) ;tformat + ) ;document + ) ;wide-tabular + ) ;document + ) ;half-bend-in-shadow + ) ;with + ) ;document + ) ;macro + ) ;assign + (active* (document (src-comment (document "Various kinds of comments")))) + (assign "inline-comment" + (macro "unique-id" + "mirror-id" + "type" + "by" + "time" + "src" + "body" + (with "old-locus-color" + (value "locus-color") + "locus-color" + "preserve" + (style-with "src-compact" + "none" + (locus (id (arg "mirror-id")) + (observer (arg "unique-id") "mirror-notify") + (with "locus-color" + (value "old-color") + (surround (extern "mirror-initialize" (quote-arg "body")) + "" + (expand-as (arg "body") + (render-inline-comment (arg "type") (arg "by") (arg "body")) + ) ;expand-as + ) ;surround + ) ;with + ) ;locus + ) ;style-with + ) ;with + ) ;macro + ) ;assign + (assign "block-comment" + (macro "unique-id" + "mirror-id" + "type" + "by" + "time" + "src" + "body" + (with "old-locus-color" + (value "locus-color") + "locus-color" + "preserve" + (style-with "src-compact" + "none" + (locus (id (arg "mirror-id")) + (observer (arg "unique-id") "mirror-notify") + (with "locus-color" + (value "old-color") + (surround (extern "mirror-initialize" (quote-arg "body")) + "" + (expand-as (arg "body") + (render-block-comment (arg "type") (arg "by") (arg "body")) + ) ;expand-as + ) ;surround + ) ;with + ) ;locus + ) ;style-with + ) ;with + ) ;macro + ) ;assign + (assign "unfolded-comment" + (macro "unique-id" + "mirror-id" + "type" + "by" + "time" + "src" + "body" + (expand-as (arg "body") + (compound (if (equal (get-label (quote-arg "body")) "document") + "block-comment" + "inline-comment" + ) ;if + (arg "unique-id") + (arg "mirror-id") + (arg "type") + (arg "by") + (arg "time") + (arg "src") + (arg "body") + ) ;compound + ) ;expand-as + ) ;macro + ) ;assign + (assign "nested-comment" + (macro "unique-id" + "mirror-id" + "type" + "by" + "time" + "src" + "body" + (expand-as (arg "body") + (compound (if (equal (get-label (quote-arg "body")) "document") + "block-comment" + "inline-comment" + ) ;if + (arg "unique-id") + (arg "mirror-id") + (arg "type") + (arg "by") + (arg "time") + (arg "src") + (arg "body") + ) ;compound + ) ;expand-as + ) ;macro + ) ;assign + (assign "folded-comment" + (macro "unique-id" + "mirror-id" + "type" + "by" + "time" + "src" + "body" + (with "old-locus-color" + (value "locus-color") + "locus-color" + "preserve" + (style-with "src-compact" + "none" + (locus (id (arg "mirror-id")) + (observer (arg "unique-id") "mirror-notify") + (expand-as (arg "body") + (concat (extern "mirror-initialize" (quote-arg "body")) + (flag (abbreviate-name (arg "by")) (comment-color (arg "type") (arg "by"))) + (hidden (arg "body")) + ) ;concat + ) ;expand-as + ) ;locus + ) ;style-with + ) ;with + ) ;macro + ) ;assign + (assign "mirror-comment" + (macro "unique-id" + "mirror-id" + "type" + "by" + "time" + "src" + "body" + (with "old-locus-color" + (value "locus-color") + "locus-color" + "preserve" + (style-with "src-compact" + "none" + (locus (id (arg "mirror-id")) + (observer (arg "unique-id") "mirror-notify") + (with "locus-color" + (value "old-color") + (surround (extern "mirror-initialize" (quote-arg "body")) + "" + (render-box-comment (arg "type") (arg "by") (arg "body")) + ) ;surround + ) ;with + ) ;locus + ) ;style-with + ) ;with + ) ;macro + ) ;assign + (assign "carbon-comment" + (macro "unique-id" + "mirror-id" + "type" + "by" + "time" + "src" + "body" + (with "old-locus-color" + (value "locus-color") + "locus-color" + "preserve" + (style-with "src-compact" + "none" + (locus (id (arg "mirror-id")) + (observer (arg "unique-id") "mirror-notify") + (with "locus-color" + (value "old-color") + (surround (extern "mirror-initialize" (quote-arg "body")) "" (arg "body")) + ) ;with + ) ;locus + ) ;style-with + ) ;with + ) ;macro + ) ;assign + (assign "preview-comment" + (macro "unique-id" + "mirror-id" + "type" + "by" + "time" + "src" + "body" + (document (with "preview-bg-color" + (blend (comment-bg-color) (comment-color (arg "type") (arg "by"))) + (document (preview-balloon (document (render-block-comment (arg "type") (arg "by") (arg "body"))) + ) ;preview-balloon + ) ;document + ) ;with + ) ;document + ) ;macro + ) ;assign + (drd-props "unfolded-comment" "arity" "7" "accessible" "6") + (drd-props "nested-comment" "arity" "7" "accessible" "6") + (drd-props "mirror-comment" "arity" "7" "accessible" "6" "border" "no") + (drd-props "carbon-comment" "arity" "7" "accessible" "6" "border" "no") + (active* (document (src-comment (document "Completely invisible comments (except when they contain visible nested comments)" + ) ;document + ) ;src-comment + ) ;document + ) ;active* + (assign "hidden-comment" + (macro "unique-id" + "mirror-id" + "type" + "by" + "time" + "src" + "body" + (hidden (arg "body")) + ) ;macro + ) ;assign + (assign "hidden-unfolded-comment" + (macro "unique-id" + "mirror-id" + "type" + "by" + "time" + "src" + "body" + (compound (if (extern "ext-contains-shown-comments?" (quote-arg "body")) + (if (equal (get-label (quote-arg "body")) "document") + "block-comment" + "inline-comment" + ) ;if + "hidden-comment" + ) ;if + (arg "unique-id") + (arg "mirror-id") + (arg "type") + (arg "by") + (arg "time") + (arg "src") + (arg "body") + ) ;compound + ) ;macro + ) ;assign + (assign "hidden-folded-comment" + (macro "unique-id" + "mirror-id" + "type" + "by" + "time" + "src" + "body" + (compound (if (extern "ext-contains-shown-comments?" (quote-arg "body")) + "folded-comment" + "hidden-comment" + ) ;if + (arg "unique-id") + (arg "mirror-id") + (arg "type") + (arg "by") + (arg "time") + (arg "src") + (arg "body") + ) ;compound + ) ;macro + ) ;assign + (assign "hidden-nested-comment" + (macro "unique-id" + "mirror-id" + "type" + "by" + "time" + "src" + "body" + (compound (if (extern "ext-contains-shown-comments?" (quote-arg "body")) + "nested-comment" + "hidden-comment" + ) ;if + (arg "unique-id") + (arg "mirror-id") + (arg "type") + (arg "by") + (arg "time") + (arg "src") + (arg "body") + ) ;compound + ) ;macro + ) ;assign + "" + ) ;document + ) ;body + (initial (collection (associate "preamble" "true"))) +) ;document diff --git a/TeXmacs/plugins/comment/packages/utilities/comment.ts b/TeXmacs/plugins/comment/packages/utilities/comment.ts deleted file mode 100644 index 40d157864b..0000000000 --- a/TeXmacs/plugins/comment/packages/utilities/comment.ts +++ /dev/null @@ -1,114 +0,0 @@ - - - - -<\body> - - - - <\src-purpose> - Various types of comments by various authors on a text - - - - - <\src-license> - This software falls under the . It comes WITHOUT ANY - WARRANTY WHATSOEVER. You should have received a copy of the license - which the software. If not, see . - - > - - - - - - <\active*> - <\src-comment> - Rendering macros - - - - |>>> - >> - - >>> - - |>|[>>>: - >||>|]>|>>> - - |>|>>\ - >||>>> - - - - <\wide-tabular> - |>>||||||| - >>> - >| - - >>> - - > - > - - <\active*> - <\src-comment> - Various kinds of comments - - - - |locus-color|preserve|>||mirror-notify>||>|||||>>>>>>>>> - - |locus-color|preserve|>||mirror-notify>||>|||||>>>>>>>>> - - |>|document>|block-comment|inline-comment>|||||||>>>> - - |>|document>|block-comment|inline-comment>|||||||>>>> - - |locus-color|preserve|>||mirror-notify>||>>||>>>>>>>>> - - |locus-color|preserve|>||mirror-notify>||>||||>>>>>>>> - - |locus-color|preserve|>||mirror-notify>||>||>>>>>>> - - - <\with|preview-bg-color|||>>> - <\preview-balloon> - ||> - - - > - - - - - - - - - - <\active*> - <\src-comment> - Completely invisible comments (except when they contain visible nested - comments) - - - - >>> - - >|>|document>|block-comment|inline-comment>|hidden-comment>|||||||>>> - - >|folded-comment|hidden-comment>|||||||>>> - - >|nested-comment|hidden-comment>|||||||>>> - - \; - - -<\initial> - <\collection> - - - \ No newline at end of file diff --git a/TeXmacs/plugins/comment/progs/comment/comment-drd.scm b/TeXmacs/plugins/comment/progs/comment/comment-drd.scm new file mode 100644 index 0000000000..76039293cc --- /dev/null +++ b/TeXmacs/plugins/comment/progs/comment/comment-drd.scm @@ -0,0 +1,48 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; MODULE : comment-drd.scm +;; DESCRIPTION : various types of comments +;; COPYRIGHT : (C) 2020 Joris van der Hoeven +;; +;; This software falls under the GNU general public license version 3 or later. +;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE +;; in the root directory or . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(texmacs-module (comment comment-drd) (:use (utils edit variants))) + +;; General groups + +(define-group variant-tag (comment-tag)) + +(define-group similar-tag (comment-tag)) + +;; Comments + +(define-group folded-comment-tag folded-comment) + +(define-group comment-tag folded-comment unfolded-comment) + +(define-group shown-comment-tag (comment-tag) nested-comment) + +;; Hidden comments + +(define-group hidden-folded-comment-tag hidden-folded-comment) + +(define-group hidden-comment-tag hidden-folded-comment hidden-unfolded-comment + hidden-nested-comment +) ;define-group + +(define-group any-comment-tag + (shown-comment-tag) + (hidden-comment-tag) + mirror-comment + carbon-comment +) ;define-group + +(define-group any-folded-comment-tag + (folded-comment-tag) + (hidden-folded-comment-tag) +) ;define-group diff --git a/TeXmacs/plugins/comment/progs/comment/comment-edit.scm b/TeXmacs/plugins/comment/progs/comment/comment-edit.scm new file mode 100644 index 0000000000..0e6641382c --- /dev/null +++ b/TeXmacs/plugins/comment/progs/comment/comment-edit.scm @@ -0,0 +1,460 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; MODULE : comment-edit.scm +;; DESCRIPTION : editing various types of comments +;; COPYRIGHT : (C) 2020 Joris van der Hoeven +;; +;; This software falls under the GNU general public license version 3 or later. +;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE +;; in the root directory or . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(texmacs-module (comment comment-edit) + (:use (utils library tree) + (utils library cursor) + (generic document-edit) + (generic document-style) + (link ref-edit) + (comment comment-drd) + ) ;:use +) ;texmacs-module + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Caching highly volatile computations +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define volatile-cache-stamp #f) + +(define volatile-cache (make-ahash-table)) + +(tm-define-macro (with-cache time-stamp feature . body) + `(let ((stamp ,time-stamp) (key ,feature)) + (when (!= volatile-cache-stamp stamp) + (set! volatile-cache-stamp stamp) + (set! volatile-cache (make-ahash-table))) + (when (not (ahash-ref volatile-cache key)) + (ahash-set! volatile-cache key (begin ,@body))) + (ahash-ref volatile-cache key)) +) ;tm-define-macro + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; External macros +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(tm-define (ext-abbreviate-name t) + (:secure #t) + (if (not (and (tree? t) (tree-atomic? t))) + t + (let* ((s (tree->string t)) (i (string-search-forwards " " 0 s))) + (if (>= i 0) (substring s 0 i) s) + ) ;let* + ) ;if +) ;tm-define + +(tm-define (ext-contains-shown-comments? t) + (:secure #t) + (if (nnull? (tree-search t shown-comment-context?)) "true" "false") +) ;tm-define + +(tm-define (ext-comment-color type by) + (:secure #t) + (get-comment-color (or (tm->string type) "?") (or (tm->string by) "?")) +) ;tm-define + +(tm-define (ext-comment-bg-color) + (:secure #t) + (if (has-style-package? "dark") "#333" "#fffd") +) ;tm-define + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Colors +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (default-comment-color type by) + (cond ((== type "reminder") "#844") + ((== by (utf8->cork (get-user-name))) "#277") + (else "#727") + ) ;cond +) ;define + +(tm-define (get-comment-color type by) + (let* ((key (string-append by " " type " color")) + (val (default-comment-color type by)) + ) ; + (cpp-get-preference key val) + ) ;let* +) ;tm-define + +(tm-define (default-comment-color? type by) + (with key (string-append by " " type " color") (not (cpp-has-preference? key))) +) ;tm-define + +(tm-define (reset-comment-color type by) + (with key + (string-append by " " type " color") + (cpp-reset-preference key) + (for (t (tree-search (buffer-tree) any-comment-context?)) (update-tree t)) + ) ;with +) ;tm-define + +(tm-define (set-comment-color type by val) + (with key + (string-append by " " type " color") + (cpp-set-preference key val) + (for (t (tree-search (buffer-tree) any-comment-context?)) (update-tree t)) + ) ;with +) ;tm-define + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Basic subroutines +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define comment-mode :show) + +(tm-define (comment-context? t) + (and (tm-in? t + (cond ((== comment-mode :show) (comment-tag-list)) + ((== comment-mode :hide) (hidden-comment-tag-list)) + (else (any-comment-tag-list)) + ) ;cond + ) ;tm-in? + (== (tm-arity t) 7) + ) ;and +) ;tm-define + +(tm-define (folded-comment-context? t) + (and (tree-in? t + (cond ((== comment-mode :show) (folded-comment-tag-list)) + ((== comment-mode :hide) (hidden-folded-comment-tag-list)) + (else (any-folded-comment-tag-list)) + ) ;cond + ) ;tree-in? + (== (tree-arity t) 7) + ) ;and +) ;tm-define + +(define (shown-comment-context? t) + (and (tm-in? t (shown-comment-tag-list)) (== (tm-arity t) 7)) +) ;define + +(tm-define (any-comment-context? t) + (and (tm-in? t (any-comment-tag-list)) (== (tm-arity t) 7)) +) ;tm-define + +(tm-define (comment-id t) + (and (any-comment-context? t) (tm->string (tree-ref t 1))) +) ;tm-define + +(tm-define (comment-type t) + (or (and (any-comment-context? t) (tm->string (tree-ref t 2))) "?") +) ;tm-define + +(tm-define (comment-by t) + (or (and (any-comment-context? t) (tm->string (tree-ref t 3))) "?") +) ;tm-define + +(define (comment-preview t) + (and (folded-comment-context? t) `(preview-comment ,@(tm-children t))) +) ;define + +(tm-define (behind-folded-comment?) + (and (== (cAr (cursor-path)) 1) + (== (cDr (cursor-path)) (tree->path (cursor-tree))) + (folded-comment-context? (path->tree (cDr (cursor-path)))) + (list (tree-label (cursor-tree)) (tree->path (cursor-tree))) + ) ;and +) ;tm-define + +(tm-define (at-comment-start?) + (with comment + (tree-innermost any-comment-context? #t) + (and comment + (not (tm-in? comment '(mirror-comment carbon-comment))) + (let* ((p (cursor-path)) (cp (tree->path comment))) + (cond + ;; 光标在注释的第一个子节点前面（折叠注释的情况） + ((and (== (cAr p) 1) (== (cDr p) cp)) #t) + ;; 光标在注释的第6个子节点的开始位置（展开注释的情况） + ((and (>= (length p) (+ (length cp) 2)) + (== (list-ref p (length cp)) 6) + (== (list-ref p (+ (length cp) 1)) 0) + ) ;and + #t + ) ; + (else #f) + ) ;cond + ) ;let* + ) ;and + ) ;with +) ;tm-define + +(tm-define (hidden-child? t i) + (:require (any-comment-context? t)) + (in? i (list 2 3)) +) ;tm-define + +(tm-define (hidden-child? t i) (:require (tree-is? t 'mirror-comment)) #f) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Searching comments +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(tm-define (search-comments t) (tree-search t comment-context?)) + +(tm-define (comments-in-buffer) + (with-cache (change-time) + :comments-in-buffer + (with-global comment-mode :all (and-nnull? (search-comments (buffer-tree)))) + ) ;with-cache +) ;tm-define + +(define (comment-list) + (with-cache (change-time) + (list :comment-list comment-mode) + (if (selection-active-any?) + (append-map search-comments (selection-trees)) + (search-comments (buffer-tree)) + ) ;if + ) ;with-cache +) ;define + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Notifying comments editor in case of added of removed comments +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (notify-comments-editor) + (let* ((u (current-buffer)) + (cu (string-append "tmfs://comments/" (url->tmfs-string u))) + ) ; + (when (buffer-exists? cu) + (with-buffer cu (revert-buffer-revert)) + ) ;when + ) ;let* +) ;define + +(tm-define (clipboard-cut which) + (with l + (tree-search (selection-tree) any-comment-context?) + (former which) + (when (nnull? l) + (notify-comments-editor) + ) ;when + ) ;with +) ;tm-define + +(tm-define (clipboard-paste which) + (with l + (tree-search (clipboard-get which) any-comment-context?) + (former which) + (when (nnull? l) + (notify-comments-editor) + ) ;when + ) ;with +) ;tm-define + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Inserting a new comment +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (nest? t) + (or (any-comment-context? t) (tree-is? t 'mirror-comment)) +) ;define + +(tm-define (inside-comment?) (tree-innermost nest?)) + +(tm-define (make-comment lab type pos . opt-after) + (let ((after-create (if (null? opt-after) (lambda () (noop)) (car opt-after)))) + (if (has-style-package? "comment") + (let* ((id (create-unique-id)) + (mirror-id (create-unique-id)) + (by (utf8->cork (get-user-name))) + (date (number->string (current-time))) + (tree `(,lab ,id ,mirror-id ,type ,by ,date ,"" ,"")) + ) ; + (insert-go-to tree pos) + (notify-comments-editor) + (after-create) + ) ;let* + (begin + (add-style-package "comment") + (delayed (:idle 1) (make-comment lab type pos after-create)) + ) ;begin + ) ;if + ) ;let +) ;tm-define + +(tm-define (make-unfolded-comment type) + (with lab + (if (inside-comment?) 'nested-comment 'unfolded-comment) + (make-comment lab type (list 6 0)) + ) ;with +) ;tm-define + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Comment navigation +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(tm-define (go-to-comment dir) + (:applicable (comment-list)) + (list-go-to (comment-list) dir) +) ;tm-define + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Operate on comments +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (operate-on-comments-in op l) + (for (c (reverse l)) + (with lab + (tree-label c) + (cond ((== op :cut) (tree-cut c)) + ((and (== op :fold) (== lab 'unfolded-comment)) + (tree-assign-node c 'folded-comment) + ) ; + ((and (== op :fold) (== lab 'hidden-unfolded-comment)) + (tree-assign-node c 'hidden-folded-comment) + ) ; + ((and (== op :unfold) (== lab 'folded-comment)) + (tree-assign-node c 'unfolded-comment) + ) ; + ((and (== op :unfold) (== lab 'hidden-folded-comment)) + (tree-assign-node c 'hidden-unfolded-comment) + ) ; + ((and (== op :hide) (in? lab (shown-comment-tag-list))) + (with lab* (symbol-append 'hidden- lab) (tree-assign-node c lab*)) + ) ; + ((and (== op :show) (in? lab (hidden-comment-tag-list))) + (with lab* (symbol-drop lab 7) (tree-assign-node c lab*)) + ) ; + ) ;cond + ) ;with + ) ;for +) ;define + +(tm-define (operate-on-comments op) + (:applicable (nnull? (comment-list))) + (operate-on-comments-in op (comment-list)) +) ;tm-define + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Types +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(tm-define (comment-type-list mode) + (with-cache (change-time) + (list :comment-type-list mode) + (with-global comment-mode + mode + (with l + (map comment-type (comment-list)) + (sort (list-remove-duplicates l) string<=?) + ) ;with + ) ;with-global + ) ;with-cache +) ;tm-define + +(tm-define (comment-test-type? tp) (nin? tp (comment-type-list :hide))) + +(tm-define (comment-toggle-type tp) + (let* ((new-mode (if (comment-test-type? tp) :hide :show)) + (l (with-global comment-mode :all (comment-list))) + (f (list-filter l (lambda (c) (== (comment-type c) tp)))) + ) ; + (operate-on-comments-in new-mode f) + ) ;let* +) ;tm-define + +(tm-define (child-proposals t i) + (:require (and (any-comment-context? t) (== i 2))) + (rcons (comment-type-list :all) :other) +) ;tm-define + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Authors +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(tm-define (comment-by-list mode) + (with-cache (change-time) + (list :comment-by-list mode) + (with-global comment-mode + mode + (with l + (map comment-by (comment-list)) + (sort (list-remove-duplicates l) string<=?) + ) ;with + ) ;with-global + ) ;with-cache +) ;tm-define + +(tm-define (comment-test-by? by) (nin? by (comment-by-list :hide))) + +(tm-define (comment-toggle-by by) + (let* ((new-mode (if (comment-test-by? by) :hide :show)) + (l (with-global comment-mode :all (comment-list))) + (f (list-filter l (lambda (c) (== (comment-by c) by)))) + ) ; + (operate-on-comments-in new-mode f) + ) ;let* +) ;tm-define + +(tm-define (child-proposals t i) + (:require (and (any-comment-context? t) (== i 3))) + (rcons (comment-by-list :all) :other) +) ;tm-define + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Previewing +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(tm-define (update-comment-tooltip) + (let* ((id (comment-id (cursor-tree))) (tip (comment-preview (cursor-tree)))) + (if (and id tip) + (begin + (close-tooltip) + (delayed (:idle 10) + (show-tooltip id (cursor-tree) tip "auto" "auto" "keyboard" 2.0) + ) ;delayed + ) ;begin + (close-tooltip) + ) ;if + ) ;let* +) ;tm-define + +(tm-define (mouse-event key x y mods time data) + (with before? + (behind-folded-comment?) + (former key x y mods time data) + (with after? + (behind-folded-comment?) + (when (and (or (!= before? after?) after?) (== key "release-left")) + (update-comment-tooltip) + ) ;when + ) ;with + ) ;with +) ;tm-define + +(tm-define (keyboard-press key time) + (with before? + (behind-folded-comment?) + (former key time) + (with after? + (behind-folded-comment?) + (when (or (!= before? after?) after?) + (update-comment-tooltip) + ) ;when + ) ;with + ) ;with +) ;tm-define + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Delete +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(tm-define (kbd-remove t forwards?) + (:require (at-comment-start?)) + (let ((comment (tree-innermost any-comment-context? #t))) + (tree-cut comment) + ) ;let +) ;tm-define diff --git a/TeXmacs/plugins/comment/progs/comment/comment-menu.scm b/TeXmacs/plugins/comment/progs/comment/comment-menu.scm new file mode 100644 index 0000000000..a245cbd058 --- /dev/null +++ b/TeXmacs/plugins/comment/progs/comment/comment-menu.scm @@ -0,0 +1,108 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; MODULE : comment-menu.scm +;; DESCRIPTION : menus for commenting a text +;; COPYRIGHT : (C) 2020 Joris van der Hoeven +;; +;; This software falls under the GNU general public license version 3 or later. +;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE +;; in the root directory or . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(texmacs-module (comment comment-menu) + (:use (comment comment-edit) (comment comment-widgets)) +) ;texmacs-module + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Main 'Comment' menu +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(menu-bind comment-menu + (:require (in-comment?)) + ((shortcut "Edit comment" "C-return") (open-comment-editor)) + --- + ("First comment" (go-to-comment :first)) + ("Previous comment" (go-to-comment :previous)) + ("Next comment" (go-to-comment :next)) + ("Last comment" (go-to-comment :last)) + --- + ("Fold comments" (operate-on-comments :fold)) + ("Unfold comments" (operate-on-comments :unfold)) + ("Remove comments" (operate-on-comments :cut)) + (with tl + (comment-type-list :all) + (assuming (> (length tl) 1) + --- + (for (tp tl) + ((check (eval (upcase-first tp)) "v" (comment-test-type? tp)) + (comment-toggle-type tp) + ) ; + ) ;for + ) ;assuming + ) ;with + (with bl + (comment-by-list :all) + (assuming (> (length bl) 1) + --- + (for (by bl) + ((check (eval by) "v" (comment-test-by? by)) (comment-toggle-by by)) + ) ;for + ) ;assuming + ) ;with +) ;menu-bind + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Selecting the colors of different types of comments +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(tm-menu (comment-color-menu type by val) + (with setter + (lambda (val) (when val (set-comment-color type by val))) + ((check "Default" "v" (default-comment-color? type by)) + (reset-comment-color type by) + ) ; + --- + (pick-color (setter answer)) + --- + ("Palette" (interactive-color setter (list val))) + ("Other" (interactive setter (list "Color" "color" val))) + ) ;with +) ;tm-menu + +(tm-menu (focus-extra-menu t) + (:require (any-comment-context? t)) + (let* ((type (comment-type t)) (by (comment-by t)) (val (get-comment-color type by))) + (-> "Set color" (dynamic (comment-color-menu type by val))) + ) ;let* +) ;tm-menu + +(tm-menu (focus-hidden-icons t) + (:require (any-comment-context? t)) + (dynamic (string-input-icon t 3)) +) ;tm-menu + +(tm-menu (focus-extra-icons t) + (:require (any-comment-context? t)) + (let* ((type (comment-type t)) + (by (comment-by t)) + (val (get-comment-color type by)) + (setter (lambda (val) (when val (set-comment-color type by val)))) + ) ; + // + (mini #t (text "Color:")) + (=> (color val #f #f 24 16) (dynamic (comment-color-menu type by val))) + ) ;let* +) ;tm-menu + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Keyboard shortcuts for comments +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(kbd-map (:mode in-comment?) + ("std [" (go-to-comment :previous)) + ("std ]" (go-to-comment :next)) + ("std {" (go-to-comment :first)) + ("std }" (go-to-comment :last)) +) ;kbd-map diff --git a/TeXmacs/plugins/comment/progs/comment/comment-widgets.scm b/TeXmacs/plugins/comment/progs/comment/comment-widgets.scm new file mode 100644 index 0000000000..19461cc383 --- /dev/null +++ b/TeXmacs/plugins/comment/progs/comment/comment-widgets.scm @@ -0,0 +1,327 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; MODULE : comment-widgets.scm +;; DESCRIPTION : special widgets for editing comments +;; COPYRIGHT : (C) 2020 Joris van der Hoeven +;; +;; This software falls under the GNU general public license version 3 or later. +;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE +;; in the root directory or . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(texmacs-module (comment comment-widgets) + (:use (comment comment-edit) + (utils library cursor) + (generic document-style) + (generic generic-edit) + (kernel gui menu-widget) + ) ;:use +) ;texmacs-module + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Editing a simple comment in a separate widget +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define comment-quit-command ignore) + +(define comment-window-table (make-ahash-table)) + +(define comment-text "comment") + + +;; 设置comment编辑器窗口状态 +(tm-define (set-comment-window-state opened?) + (set-auxiliary-widget-state opened? 'comment-editor) +) ;tm-define + +;; 获取当前窗口的comment编辑器状态 +(tm-define (get-comment-window-state) + (let ((state (get-auxiliary-widget-state))) + (if state + (let ((opened? (car state)) (widget-type (cadr state))) + (and (== widget-type 'comment-editor) opened?) + ) ;let + #f + ) ;if + ) ;let +) ;tm-define + +(define (comment-editor-done u b) + (buffer-focus u #t) + (and-let* ((pc (tree-innermost any-comment-context? #t)) + (mid (and pc (tm->string (tm-ref pc 1)))) + (body (and pc (tm-ref pc :last))) + ) ; + (with-buffer b + (let* ((mb (buffer-get-body b)) + (l (tree-search mb + (lambda (t) (and (any-comment-context? t) (== (tm->string (tm-ref t 1)) mid))) + ) ;tree-search + ) ;l + ) ; + (when (nnull? l) + (tree-set! (car l) :last (tree-copy body)) + ) ;when + ) ;let* + ) ;with-buffer + ) ;and-let* + (when (defined? 'mirror-treat-pending) + (mirror-treat-pending) + ) ;when + (when (defined? 'mirror-synchronize) + (mirror-synchronize) + ) ;when + (set-comment-window-state #f) + (show-auxiliary-widget #f) + (comment-quit-command) +) ;define + +;; 用于auxiliary-widget的comment编辑器widget +(tm-widget ((comment-aux-widget u packs doc b) quit) + (padded (resize "480px" "300px" (texmacs-input doc `(style (tuple ,@packs)) u)) + === + (hlist >> (explicit-buttons ("Done" (comment-editor-done u b)))) + ) ;padded +) ;tm-widget + +;; Comment编辑器取消函数 +(tm-define ((comment-cancel u) . args) (set-comment-window-state #f)) + +(define (allow-init? init) + (and (string? (car init)) (not (string-starts? (car init) "page-"))) +) ;define + +(tm-define (open-comment-editor-aux) + (and-let* ((c (tm->stree (tree-innermost any-comment-context? #t))) + (b (current-buffer-url)) + (u (string->url (string-append "tmfs://aux/edit-comment" + "/" + (url->string (url-tail (get-auxiliary-widget-parent-url))) + ) ;string-append + ) ;string->url + ) ;u + (packs (embedded-style-list)) + (pre (document-get-preamble (buffer-tree))) + (inits* (map cdr (cdr (tm->stree (get-all-inits))))) + (inits (list-filter inits* allow-init?)) + (env (apply append inits)) + (com (mirror-comment c 'carbon-comment)) + (doc `(with ,@env (document (hide-preamble ,pre) ,com))) + ) ; + (buffer-set-master u b) + (auxiliary-widget (comment-aux-widget u packs doc b) + (comment-cancel b) + (translate comment-text) + u + ) ;auxiliary-widget + (buffer-focus u #t) + (go-end) + ) ;and-let* +) ;tm-define + +(tm-define (open-comment-editor) + (:applicable (behind-folded-comment?)) + (:interactive #t) + (set-comment-window-state #t) + (open-comment-editor-aux) +) ;tm-define + +(tm-define (kbd-control-return) + (:require (behind-folded-comment?)) + (let ((state (get-comment-window-state))) + (if state + (begin + (set-comment-window-state #f) + (show-auxiliary-widget #f) + ) ;begin + (open-comment-editor) + ) ;if + ) ;let +) ;tm-define + +(tm-define (kbd-control-return) + (:require (inside? 'carbon-comment)) + (comment-editor-done) +) ;tm-define + +(tm-define (make-folded-comment type) + (:applicable (not (inside-comment?))) + (make-comment 'folded-comment type (list 1) open-comment-editor) +) ;tm-define + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Open comments editor +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(tmfs-permission-handler (comments name type) (in? type (list "read"))) + +(tmfs-title-handler (comments name doc) + (with u + (tmfs-string->url name) + (string-append (url->system (url-tail u)) " - Comments") + ) ;with +) ;tmfs-title-handler + +(define (mirror-comment t . opt-lab) + (let* ((uid' (if (tm-atomic? (tm-ref t 0)) + (string-append (tm->string (tm-ref t 0)) "-edit") + (create-unique-id) + ) ;if + ) ;uid' + (mid (tm->string (tm-ref t 1))) + (typ (tm->string (tm-ref t 2))) + (by (tm->string (tm-ref t 3))) + (tim (tm->string (tm-ref t 4))) + (bod (tm-ref t :last)) + (lab (if (null? opt-lab) 'mirror-comment (car opt-lab))) + ) ; + `(,lab ,uid' ,mid ,typ ,by ,tim ,"" ,bod) + ) ;let* +) ;define + +(tmfs-load-handler (comments name) + (let* ((u (tmfs-string->url name)) (doc (tree->stree (buffer-get u)))) + (tm-replace doc + (cut tm-func? <> 'body 1) + (lambda (t) + (let* ((l (tm-search t comment-context?)) (r (map mirror-comment l))) + (if (null? r) '(body (document "")) `(body (document ,@r))) + ) ;let* + ) ;lambda + ) ;tm-replace + ) ;let* +) ;tmfs-load-handler + +(tm-define (open-comments-editor) + (:applicable (comments-in-buffer)) + (let* ((l (comments-in-buffer)) + (u (current-buffer)) + (cu (string-append "tmfs://comments/" (url->tmfs-string u))) + ) ; + (when (not (tree-innermost any-comment-context? #t)) + (list-go-to l :next) + ) ;when + (when (not (tree-innermost any-comment-context? #t)) + (list-go-to l :previous) + ) ;when + (when (not (tree-innermost any-comment-context? #t)) + (list-go-to l :first) + ) ;when + (let* ((t (tree-innermost any-comment-context? #t)) (id (comment-id t))) + (when t + (tree-select t) + ) ;when + (load-buffer-in-new-window cu) + (buffer-set-master cu u) + (delayed (:pause 50) + (and-let* ((b (buffer-get-body cu)) (c (search-comment b id))) + (with-buffer cu (tree-go-to c :start)) + ) ;and-let* + ) ;delayed + ) ;let* + ) ;let* +) ;tm-define + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Pairing cursor positions: comments -> commented +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (in-comments-editor?) + (string-starts? (url->string (current-buffer)) "tmfs://comments/") +) ;define + +(define ((comment-by-id? id) t) + (and (any-comment-context? t) (== (comment-id t) id)) +) ;define + +(define (search-comment t id) + (with l (tree-search t (comment-by-id? id)) (and (nnull? l) (car l))) +) ;define + +(define (sync-master-cursor) + (and-let* ((c (tree-innermost 'mirror-comment)) + (m (buffer-get-master (current-buffer))) + (b (buffer-get-body m)) + (i (comment-id c)) + (t (search-comment b i)) + (inv? (not (notified-change? 4))) + ) ; + (with-buffer m + (when inv? + (tree-select t) + ) ;when + (tree-go-to t :end) + (when (and (not (cursor-accessible?)) (not (in-source?))) + (cursor-show-hidden) + ) ;when + ) ;with-buffer + ) ;and-let* +) ;define + +(tm-define (mouse-event key x y mods time data) + (former key x y mods time data) + (when (and (in-comments-editor?) (!= key "move")) + (sync-master-cursor) + ) ;when +) ;tm-define + +(tm-define (keyboard-press key time) + (former key time) + (when (in-comments-editor?) + (sync-master-cursor) + ) ;when +) ;tm-define + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Pairing cursor positions: commented -> comments +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (has-comments-editor?) + (let* ((u (current-buffer)) + (cu (string-append "tmfs://comments/" (url->tmfs-string u))) + ) ; + (and (buffer-exists? cu) + (in? (string->url cu) (map window->buffer (window-list))) + ) ;and + ) ;let* +) ;define + +(define (sync-comments-cursor) + (let* ((m (current-buffer)) + (u (string-append "tmfs://comments/" (url->tmfs-string m))) + (b (buffer-get-body u)) + (t (tree-innermost any-comment-context? #t)) + (inv? (not (notified-change? 4))) + ) ; + (with-buffer u + (if t + (and-let* ((i (comment-id t)) (c (search-comment b i))) + (when inv? + (tree-select (tm-ref c :last)) + ) ;when + (tree-go-to c :start) + ) ;and-let* + (selection-cancel) + ) ;if + ) ;with-buffer + ) ;let* +) ;define + +(tm-define (mouse-event key x y mods time data) + (former key x y mods time data) + (when (and (has-comments-editor?) (!= key "move")) + (sync-comments-cursor) + ) ;when +) ;tm-define + +(tm-define (keyboard-press key time) + (former key time) + (when (has-comments-editor?) + (sync-comments-cursor) + ) ;when +) ;tm-define + +;; 注册comment编辑器widget类型 +(register-auxiliary-widget-type 'comment-editor (list open-comment-editor-aux)) diff --git a/TeXmacs/plugins/comment/progs/various/comment-drd.scm b/TeXmacs/plugins/comment/progs/various/comment-drd.scm deleted file mode 100644 index 23cf41d9dd..0000000000 --- a/TeXmacs/plugins/comment/progs/various/comment-drd.scm +++ /dev/null @@ -1,49 +0,0 @@ - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : comment-drd.scm -;; DESCRIPTION : various types of comments -;; COPYRIGHT : (C) 2020 Joris van der Hoeven -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (various comment-drd) - (:use (utils edit variants))) - -;; General groups - -(define-group variant-tag - (comment-tag)) - -(define-group similar-tag - (comment-tag)) - -;; Comments - -(define-group folded-comment-tag - folded-comment) - -(define-group comment-tag - folded-comment unfolded-comment) - -(define-group shown-comment-tag - (comment-tag) nested-comment) - -;; Hidden comments - -(define-group hidden-folded-comment-tag - hidden-folded-comment) - -(define-group hidden-comment-tag - hidden-folded-comment hidden-unfolded-comment hidden-nested-comment) - -(define-group any-comment-tag - (shown-comment-tag) (hidden-comment-tag) - mirror-comment carbon-comment) - -(define-group any-folded-comment-tag - (folded-comment-tag) (hidden-folded-comment-tag)) diff --git a/TeXmacs/plugins/comment/progs/various/comment-edit.scm b/TeXmacs/plugins/comment/progs/various/comment-edit.scm deleted file mode 100644 index 8cdd996e4c..0000000000 --- a/TeXmacs/plugins/comment/progs/various/comment-edit.scm +++ /dev/null @@ -1,367 +0,0 @@ - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : comment-edit.scm -;; DESCRIPTION : editing various types of comments -;; COPYRIGHT : (C) 2020 Joris van der Hoeven -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (various comment-edit) - (:use (utils library tree) - (utils library cursor) - (generic document-edit) - (generic document-style) - (link ref-edit) - (various comment-drd))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Caching highly volatile computations -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define volatile-cache-stamp #f) -(define volatile-cache (make-ahash-table)) - -(tm-define-macro (with-cache time-stamp feature . body) - `(let ((stamp ,time-stamp) - (key ,feature)) - (when (!= volatile-cache-stamp stamp) - (set! volatile-cache-stamp stamp) - (set! volatile-cache (make-ahash-table))) - (when (not (ahash-ref volatile-cache key)) - (ahash-set! volatile-cache key (begin ,@body))) - (ahash-ref volatile-cache key))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; External macros -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(tm-define (ext-abbreviate-name t) - (:secure #t) - (if (not (and (tree? t) (tree-atomic? t))) t - (let* ((s (tree->string t)) - (i (string-search-forwards " " 0 s))) - (if (>= i 0) (substring s 0 i) s)))) - -(tm-define (ext-contains-shown-comments? t) - (:secure #t) - (if (nnull? (tree-search t shown-comment-context?)) "true" "false")) - -(tm-define (ext-comment-color type by) - (:secure #t) - (get-comment-color (or (tm->string type) "?") - (or (tm->string by) "?"))) - -(tm-define (ext-comment-bg-color) - (:secure #t) - (if (has-style-package? "dark") - "#333" - "#fffd")) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Colors -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (default-comment-color type by) - (cond ((== type "reminder") "#844") - ((== by (utf8->cork (get-user-name))) "#277") - (else "#727"))) - -(tm-define (get-comment-color type by) - (let* ((key (string-append by " " type " color")) - (val (default-comment-color type by))) - (cpp-get-preference key val))) - -(tm-define (default-comment-color? type by) - (with key (string-append by " " type " color") - (not (cpp-has-preference? key)))) - -(tm-define (reset-comment-color type by) - (with key (string-append by " " type " color") - (cpp-reset-preference key) - (for (t (tree-search (buffer-tree) any-comment-context?)) - (update-tree t)))) - -(tm-define (set-comment-color type by val) - (with key (string-append by " " type " color") - (cpp-set-preference key val) - (for (t (tree-search (buffer-tree) any-comment-context?)) - (update-tree t)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Basic subroutines -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define comment-mode :show) - -(tm-define (comment-context? t) - (and (tm-in? t (cond ((== comment-mode :show) - (comment-tag-list)) - ((== comment-mode :hide) - (hidden-comment-tag-list)) - (else - (any-comment-tag-list)))) - (== (tm-arity t) 7))) - -(tm-define (folded-comment-context? t) - (and (tree-in? t (cond ((== comment-mode :show) - (folded-comment-tag-list)) - ((== comment-mode :hide) - (hidden-folded-comment-tag-list)) - (else - (any-folded-comment-tag-list)))) - (== (tree-arity t) 7))) - -(define (shown-comment-context? t) - (and (tm-in? t (shown-comment-tag-list)) - (== (tm-arity t) 7))) - -(tm-define (any-comment-context? t) - (and (tm-in? t (any-comment-tag-list)) - (== (tm-arity t) 7))) - -(tm-define (comment-id t) - (and (any-comment-context? t) - (tm->string (tree-ref t 1)))) - -(tm-define (comment-type t) - (or (and (any-comment-context? t) - (tm->string (tree-ref t 2))) - "?")) - -(tm-define (comment-by t) - (or (and (any-comment-context? t) - (tm->string (tree-ref t 3))) - "?")) - -(define (comment-preview t) - (and (folded-comment-context? t) - `(preview-comment ,@(tm-children t)))) - -(tm-define (behind-folded-comment?) - (and (== (cAr (cursor-path)) 1) - (== (cDr (cursor-path)) (tree->path (cursor-tree))) - (folded-comment-context? (path->tree (cDr (cursor-path)))) - (list (tree-label (cursor-tree)) - (tree->path (cursor-tree))))) - -(tm-define (at-comment-start?) - (with comment (tree-innermost any-comment-context? #t) - (and comment - (not (tm-in? comment '(mirror-comment carbon-comment))) - (let* ((p (cursor-path)) - (cp (tree->path comment))) - (cond - ;; 光标在注释的第一个子节点前面（折叠注释的情况） - ((and (== (cAr p) 1) - (== (cDr p) cp)) - #t) - ;; 光标在注释的第6个子节点的开始位置（展开注释的情况） - ((and (>= (length p) (+ (length cp) 2)) - (== (list-ref p (length cp)) 6) - (== (list-ref p (+ (length cp) 1)) 0)) - #t) - (else #f)))))) - -(tm-define (hidden-child? t i) - (:require (any-comment-context? t)) - (in? i (list 2 3))) - -(tm-define (hidden-child? t i) - (:require (tree-is? t 'mirror-comment)) - #f) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Searching comments -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(tm-define (search-comments t) - (tree-search t comment-context?)) - -(tm-define (comments-in-buffer) - (with-cache (change-time) :comments-in-buffer - (with-global comment-mode :all - (and-nnull? (search-comments (buffer-tree)))))) - -(define (comment-list) - (with-cache (change-time) (list :comment-list comment-mode) - (if (selection-active-any?) - (append-map search-comments (selection-trees)) - (search-comments (buffer-tree))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Notifying comments editor in case of added of removed comments -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (notify-comments-editor) - (let* ((u (current-buffer)) - (cu (string-append "tmfs://comments/" (url->tmfs-string u)))) - (when (buffer-exists? cu) - (with-buffer cu - (revert-buffer-revert))))) - -(tm-define (clipboard-cut which) - (with l (tree-search (selection-tree) any-comment-context?) - (former which) - (when (nnull? l) (notify-comments-editor)))) - -(tm-define (clipboard-paste which) - (with l (tree-search (clipboard-get which) any-comment-context?) - (former which) - (when (nnull? l) (notify-comments-editor)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Inserting a new comment -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (nest? t) - (or (any-comment-context? t) - (tree-is? t 'mirror-comment))) - -(tm-define (inside-comment?) - (tree-innermost nest?)) - -(tm-define (make-comment lab type pos . opt-after) - (let ((after-create (if (null? opt-after) (lambda () (noop)) (car opt-after)))) - (if (has-style-package? "comment") - (let* ((id (create-unique-id)) - (mirror-id (create-unique-id)) - (by (utf8->cork (get-user-name))) - (date (number->string (current-time))) - (tree `(,lab ,id ,mirror-id ,type ,by ,date "" ""))) - (insert-go-to tree pos) - (notify-comments-editor) - (after-create)) - (begin - (add-style-package "comment") - (delayed - (:idle 1) - (make-comment lab type pos after-create)))))) - -(tm-define (make-unfolded-comment type) - (with lab (if (inside-comment?) 'nested-comment 'unfolded-comment) - (make-comment lab type (list 6 0)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Comment navigation -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(tm-define (go-to-comment dir) - (:applicable (comment-list)) - (list-go-to (comment-list) dir)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Operate on comments -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (operate-on-comments-in op l) - (for (c (reverse l)) - (with lab (tree-label c) - (cond ((== op :cut) (tree-cut c)) - ((and (== op :fold) (== lab 'unfolded-comment)) - (tree-assign-node c 'folded-comment)) - ((and (== op :fold) (== lab 'hidden-unfolded-comment)) - (tree-assign-node c 'hidden-folded-comment)) - ((and (== op :unfold) (== lab 'folded-comment)) - (tree-assign-node c 'unfolded-comment)) - ((and (== op :unfold) (== lab 'hidden-folded-comment)) - (tree-assign-node c 'hidden-unfolded-comment)) - ((and (== op :hide) (in? lab (shown-comment-tag-list))) - (with lab* (symbol-append 'hidden- lab) - (tree-assign-node c lab*))) - ((and (== op :show) (in? lab (hidden-comment-tag-list))) - (with lab* (symbol-drop lab 7) - (tree-assign-node c lab*))))))) - -(tm-define (operate-on-comments op) - (:applicable (nnull? (comment-list))) - (operate-on-comments-in op (comment-list))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Types -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(tm-define (comment-type-list mode) - (with-cache (change-time) (list :comment-type-list mode) - (with-global comment-mode mode - (with l (map comment-type (comment-list)) - (sort (list-remove-duplicates l) string<=?))))) - -(tm-define (comment-test-type? tp) - (nin? tp (comment-type-list :hide))) - -(tm-define (comment-toggle-type tp) - (let* ((new-mode (if (comment-test-type? tp) :hide :show)) - (l (with-global comment-mode :all (comment-list))) - (f (list-filter l (lambda (c) (== (comment-type c) tp))))) - (operate-on-comments-in new-mode f))) - -(tm-define (child-proposals t i) - (:require (and (any-comment-context? t) (== i 2))) - (rcons (comment-type-list :all) :other)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Authors -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(tm-define (comment-by-list mode) - (with-cache (change-time) (list :comment-by-list mode) - (with-global comment-mode mode - (with l (map comment-by (comment-list)) - (sort (list-remove-duplicates l) string<=?))))) - -(tm-define (comment-test-by? by) - (nin? by (comment-by-list :hide))) - -(tm-define (comment-toggle-by by) - (let* ((new-mode (if (comment-test-by? by) :hide :show)) - (l (with-global comment-mode :all (comment-list))) - (f (list-filter l (lambda (c) (== (comment-by c) by))))) - (operate-on-comments-in new-mode f))) - -(tm-define (child-proposals t i) - (:require (and (any-comment-context? t) (== i 3))) - (rcons (comment-by-list :all) :other)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Previewing -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(tm-define (update-comment-tooltip) - (let* ((id (comment-id (cursor-tree))) - (tip (comment-preview (cursor-tree)))) - (if (and id tip) - (begin - (close-tooltip) - (delayed - (:idle 10) - (show-tooltip id (cursor-tree) tip - "auto" "auto" "keyboard" 2.0))) - (close-tooltip)))) - -(tm-define (mouse-event key x y mods time data) - (with before? (behind-folded-comment?) - (former key x y mods time data) - (with after? (behind-folded-comment?) - (when (and (or (!= before? after?) after?) (== key "release-left")) - (update-comment-tooltip))))) - -(tm-define (keyboard-press key time) - (with before? (behind-folded-comment?) - (former key time) - (with after? (behind-folded-comment?) - (when (or (!= before? after?) after?) - (update-comment-tooltip))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Delete -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(tm-define (kbd-remove t forwards?) - (:require (at-comment-start?)) - (let ((comment (tree-innermost any-comment-context? #t))) - (tree-cut comment))) diff --git a/TeXmacs/plugins/comment/progs/various/comment-menu.scm b/TeXmacs/plugins/comment/progs/various/comment-menu.scm deleted file mode 100644 index 926622f748..0000000000 --- a/TeXmacs/plugins/comment/progs/various/comment-menu.scm +++ /dev/null @@ -1,94 +0,0 @@ - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : comment-menu.scm -;; DESCRIPTION : menus for commenting a text -;; COPYRIGHT : (C) 2020 Joris van der Hoeven -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (various comment-menu) - (:use (various comment-edit) - (various comment-widgets))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Main 'Comment' menu -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(menu-bind comment-menu - (:require (in-comment?)) - ((shortcut "Edit comment" "C-return") (open-comment-editor)) - --- - ("First comment" (go-to-comment :first)) - ("Previous comment" (go-to-comment :previous)) - ("Next comment" (go-to-comment :next)) - ("Last comment" (go-to-comment :last)) - --- - ("Fold comments" (operate-on-comments :fold)) - ("Unfold comments" (operate-on-comments :unfold)) - ("Remove comments" (operate-on-comments :cut)) - (with tl (comment-type-list :all) - (assuming (> (length tl) 1) - --- - (for (tp tl) - ((check (eval (upcase-first tp)) "v" (comment-test-type? tp)) - (comment-toggle-type tp))))) - (with bl (comment-by-list :all) - (assuming (> (length bl) 1) - --- - (for (by bl) - ((check (eval by) "v" (comment-test-by? by)) - (comment-toggle-by by)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Selecting the colors of different types of comments -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(tm-menu (comment-color-menu type by val) - (with setter (lambda (val) (when val (set-comment-color type by val))) - ((check "Default" "v" (default-comment-color? type by)) - (reset-comment-color type by)) - --- - (pick-color (setter answer)) - --- - ("Palette" (interactive-color setter (list val))) - ("Other" (interactive setter - (list "Color" "color" val))))) - -(tm-menu (focus-extra-menu t) - (:require (any-comment-context? t)) - (let* ((type (comment-type t)) - (by (comment-by t)) - (val (get-comment-color type by))) - (-> "Set color" - (dynamic (comment-color-menu type by val))))) - -(tm-menu (focus-hidden-icons t) - (:require (any-comment-context? t)) - (dynamic (string-input-icon t 3))) - -(tm-menu (focus-extra-icons t) - (:require (any-comment-context? t)) - (let* ((type (comment-type t)) - (by (comment-by t)) - (val (get-comment-color type by)) - (setter (lambda (val) (when val (set-comment-color type by val))))) - // - (mini #t (text "Color:")) - (=> (color val #f #f 24 16) - (dynamic (comment-color-menu type by val))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Keyboard shortcuts for comments -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(kbd-map - (:mode in-comment?) - ("std [" (go-to-comment :previous)) - ("std ]" (go-to-comment :next)) - ("std {" (go-to-comment :first)) - ("std }" (go-to-comment :last))) diff --git a/TeXmacs/plugins/comment/progs/various/comment-widgets.scm b/TeXmacs/plugins/comment/progs/various/comment-widgets.scm deleted file mode 100644 index abd196c313..0000000000 --- a/TeXmacs/plugins/comment/progs/various/comment-widgets.scm +++ /dev/null @@ -1,257 +0,0 @@ - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : comment-widgets.scm -;; DESCRIPTION : special widgets for editing comments -;; COPYRIGHT : (C) 2020 Joris van der Hoeven -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (various comment-widgets) - (:use (various comment-edit) - (utils library cursor) - (generic document-style) - (generic generic-edit) - (kernel gui menu-widget))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Editing a simple comment in a separate widget -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define comment-quit-command ignore) -(define comment-window-table (make-ahash-table)) -(define comment-text "comment") - - -;; 设置comment编辑器窗口状态 -(tm-define (set-comment-window-state opened?) - (set-auxiliary-widget-state opened? 'comment-editor)) - -;; 获取当前窗口的comment编辑器状态 -(tm-define (get-comment-window-state) - (let ((state (get-auxiliary-widget-state))) - (if state - (let ((opened? (car state)) - (widget-type (cadr state))) - (and (== widget-type 'comment-editor) opened?)) - #f))) - -(define (comment-editor-done u b) - (buffer-focus u #t) - (and-let* ((pc (tree-innermost any-comment-context? #t)) - (mid (and pc (tm->string (tm-ref pc 1)))) - (body (and pc (tm-ref pc :last)))) - (with-buffer b - (let* ((mb (buffer-get-body b)) - (l (tree-search - mb - (lambda (t) - (and (any-comment-context? t) - (== (tm->string (tm-ref t 1)) mid)))))) - (when (nnull? l) - (tree-set! (car l) :last (tree-copy body)))))) - (when (defined? 'mirror-treat-pending) - (mirror-treat-pending)) - (when (defined? 'mirror-synchronize) - (mirror-synchronize)) - (set-comment-window-state #f) - (show-auxiliary-widget #f) - (comment-quit-command)) - -;; 用于auxiliary-widget的comment编辑器widget -(tm-widget ((comment-aux-widget u packs doc b) quit) - (padded - (resize "480px" "300px" - (texmacs-input doc `(style (tuple ,@packs)) u)) - === - (hlist - >> - (explicit-buttons - ("Done" (comment-editor-done u b)))))) - -;; Comment编辑器取消函数 -(tm-define ((comment-cancel u) . args) - (set-comment-window-state #f)) - -(define (allow-init? init) - (and (string? (car init)) - (not (string-starts? (car init) "page-")))) - -(tm-define (open-comment-editor-aux) - (and-let* ((c (tm->stree (tree-innermost any-comment-context? #t))) - (b (current-buffer-url)) - (u (string->url (string-append "tmfs://aux/edit-comment" - "/" (url->string - (url-tail (get-auxiliary-widget-parent-url)))))) - (packs (embedded-style-list)) - (pre (document-get-preamble (buffer-tree))) - (inits* (map cdr (cdr (tm->stree (get-all-inits))))) - (inits (list-filter inits* allow-init?)) - (env (apply append inits)) - (com (mirror-comment c 'carbon-comment)) - (doc `(with ,@env (document (hide-preamble ,pre) ,com)))) - (buffer-set-master u b) - (auxiliary-widget (comment-aux-widget u packs doc b) - (comment-cancel b) - (translate comment-text) u) - (buffer-focus u #t) - (go-end))) - -(tm-define (open-comment-editor) - (:applicable (behind-folded-comment?)) - (:interactive #t) - (set-comment-window-state #t) - (open-comment-editor-aux)) - -(tm-define (kbd-control-return) - (:require (behind-folded-comment?)) - (let ((state (get-comment-window-state))) - (if state - (begin - (set-comment-window-state #f) - (show-auxiliary-widget #f)) - (open-comment-editor)))) - -(tm-define (kbd-control-return) - (:require (inside? 'carbon-comment)) - (comment-editor-done)) - -(tm-define (make-folded-comment type) - (:applicable (not (inside-comment?))) - (make-comment 'folded-comment type (list 1) open-comment-editor)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Open comments editor -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(tmfs-permission-handler (comments name type) - (in? type (list "read"))) - -(tmfs-title-handler (comments name doc) - (with u (tmfs-string->url name) - (string-append (url->system (url-tail u)) " - Comments"))) - -(define (mirror-comment t . opt-lab) - (let* ((uid' (if (tm-atomic? (tm-ref t 0)) - (string-append (tm->string (tm-ref t 0)) "-edit") - (create-unique-id))) - (mid (tm->string (tm-ref t 1))) - (typ (tm->string (tm-ref t 2))) - (by (tm->string (tm-ref t 3))) - (tim (tm->string (tm-ref t 4))) - (bod (tm-ref t :last)) - (lab (if (null? opt-lab) 'mirror-comment (car opt-lab)))) - `(,lab ,uid' ,mid ,typ ,by ,tim "" ,bod))) - -(tmfs-load-handler (comments name) - (let* ((u (tmfs-string->url name)) - (doc (tree->stree (buffer-get u)))) - (tm-replace doc (cut tm-func? <> 'body 1) - (lambda (t) - (let* ((l (tm-search t comment-context?)) - (r (map mirror-comment l))) - (if (null? r) - `(body (document "")) - `(body (document ,@r)))))))) - -(tm-define (open-comments-editor) - (:applicable (comments-in-buffer)) - (let* ((l (comments-in-buffer)) - (u (current-buffer)) - (cu (string-append "tmfs://comments/" (url->tmfs-string u)))) - (when (not (tree-innermost any-comment-context? #t)) - (list-go-to l :next)) - (when (not (tree-innermost any-comment-context? #t)) - (list-go-to l :previous)) - (when (not (tree-innermost any-comment-context? #t)) - (list-go-to l :first)) - (let* ((t (tree-innermost any-comment-context? #t)) - (id (comment-id t))) - (when t (tree-select t)) - (load-buffer-in-new-window cu) - (buffer-set-master cu u) - (delayed - (:pause 50) - (and-let* ((b (buffer-get-body cu)) - (c (search-comment b id))) - (with-buffer cu - (tree-go-to c :start))))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Pairing cursor positions: comments -> commented -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (in-comments-editor?) - (string-starts? (url->string (current-buffer)) "tmfs://comments/")) - -(define ((comment-by-id? id) t) - (and (any-comment-context? t) - (== (comment-id t) id))) - -(define (search-comment t id) - (with l (tree-search t (comment-by-id? id)) - (and (nnull? l) (car l)))) - -(define (sync-master-cursor) - (and-let* ((c (tree-innermost 'mirror-comment)) - (m (buffer-get-master (current-buffer))) - (b (buffer-get-body m)) - (i (comment-id c)) - (t (search-comment b i)) - (inv? (not (notified-change? 4)))) - (with-buffer m - (when inv? (tree-select t)) - (tree-go-to t :end) - (when (and (not (cursor-accessible?)) (not (in-source?))) - (cursor-show-hidden))))) - -(tm-define (mouse-event key x y mods time data) - (former key x y mods time data) - (when (and (in-comments-editor?) (!= key "move")) - (sync-master-cursor))) - -(tm-define (keyboard-press key time) - (former key time) - (when (in-comments-editor?) - (sync-master-cursor))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Pairing cursor positions: commented -> comments -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (has-comments-editor?) - (let* ((u (current-buffer)) - (cu (string-append "tmfs://comments/" (url->tmfs-string u)))) - (and (buffer-exists? cu) - (in? (string->url cu) (map window->buffer (window-list)))))) - -(define (sync-comments-cursor) - (let* ((m (current-buffer)) - (u (string-append "tmfs://comments/" (url->tmfs-string m))) - (b (buffer-get-body u)) - (t (tree-innermost any-comment-context? #t)) - (inv? (not (notified-change? 4)))) - (with-buffer u - (if t - (and-let* ((i (comment-id t)) - (c (search-comment b i))) - (when inv? (tree-select (tm-ref c :last))) - (tree-go-to c :start)) - (selection-cancel))))) - -(tm-define (mouse-event key x y mods time data) - (former key x y mods time data) - (when (and (has-comments-editor?) (!= key "move")) - (sync-comments-cursor))) - -(tm-define (keyboard-press key time) - (former key time) - (when (has-comments-editor?) - (sync-comments-cursor))) - -;; 注册comment编辑器widget类型 -(register-auxiliary-widget-type 'comment-editor (list open-comment-editor-aux)) diff --git a/TeXmacs/plugins/cpp/progs/cpp/cpp-edit.scm b/TeXmacs/plugins/cpp/progs/cpp/cpp-edit.scm new file mode 100644 index 0000000000..b30c7e58d9 --- /dev/null +++ b/TeXmacs/plugins/cpp/progs/cpp/cpp-edit.scm @@ -0,0 +1,58 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; MODULE : cpp-edit.scm +;; DESCRIPTION : editing C++ programs +;; COPYRIGHT : +;; +;; This software falls under the GNU general public license version 3 or later. +;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE +;; in the root directory or . +;; +;; +;; TO-DO: this module should provide automatic indentation and other facilities +;; for C++ source code. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(texmacs-module (cpp cpp-edit) (:use (prog prog-edit))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Automatic insertion, highlighting and selection of brackets and quotes +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(tm-define (cpp-bracket-open lbr rbr) (bracket-open lbr rbr "\\")) + +(tm-define (cpp-bracket-close lbr rbr) (bracket-close lbr rbr "\\")) + +(tm-define (kbd-select-enlarge) + (:require prog-select-brackets?) + (:mode in-prog-cpp?) + (program-select-enlarge "{" "}") +) ;tm-define + +(tm-define (notify-cursor-moved status) + (:require prog-highlight-brackets?) + (:mode in-prog-cpp?) + (select-brackets-after-movement "([{" ")]}" "\\") +) ;tm-define + +(tm-define (program-compute-indentation doc row col) + (:mode in-prog-cpp?) + (if (<= row 0) + 0 + (let ((prev-row (program-row (- row 1)))) + (if prev-row (string-get-indent prev-row) 0) + ) ;let + ) ;if +) ;tm-define + +(kbd-map (:mode in-prog-cpp?) + ("{" (cpp-bracket-open "{" "}")) + ("}" (cpp-bracket-close "{" "}")) + ("(" (cpp-bracket-open "(" ")")) + (")" (cpp-bracket-close "(" ")")) + ("[" (cpp-bracket-open "[" "]")) + ("]" (cpp-bracket-close "[" "]")) + ("\"" (cpp-bracket-open "\"" "\"")) +) ;kbd-map diff --git a/TeXmacs/plugins/cpp/progs/cpp/cpp-lang.scm b/TeXmacs/plugins/cpp/progs/cpp/cpp-lang.scm new file mode 100644 index 0000000000..a147f1d86a --- /dev/null +++ b/TeXmacs/plugins/cpp/progs/cpp/cpp-lang.scm @@ -0,0 +1,129 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; MODULE : cpp-lang.scm +;; DESCRIPTION : the C++ Language +;; COPYRIGHT : (C) 2008 Francis Jamet +;; (C) 2020 Darcy Shen +;; +;; This software falls under the GNU general public license version 3 or later. +;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE +;; in the root directory or . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(texmacs-module (cpp cpp-lang) (:use (prog default-lang))) + +(tm-define (parser-feature lan key) + (:require (and (== lan "cpp") (== key "keyword"))) + `(,(string->symbol key) + (constant "false" "true" "cout" "cin" "cerr" "null" "nullptr" "nullptr_t" + "NULL") + (constant_type "bool" "byte" "char" "char16_t" "char32_t" "char8_t" "double" + "float" "int" "int16_t" "int32_t" "int8_t" "long" "short" "signed" + "uint16_t" "uint32_t" "uint8_t" "unsigned" "void" "wchar_t") + (declare_type "class" "interface" "enum") + (declare_module "namespace" "using") + (keyword "asm" "auto" "calloc" "class" "concept" "concrete" "const" + "const_cast" "constant" "constexpr" "default" "delete" "dynamic_cast" + "enum" "explicit" "export" "extern" "free" "friend" "inline" "malloc" + "mutable" "new" "operator" "private" "protected" "public" "realloc" + "register" "reinterpret_cast" "sizeof" "static" "static_cast" "struct" + "template" "this" "to" "typedef" "typeid" "typename" "union" "virtual" + "volatile") + (keyword_conditional "break" "continue" "do" "else" "for" "if" "while" + "goto" "switch" "case") + (keyword_control "throw" "catch" "finally" "return" "try" "yield")) +) ;tm-define + + +(tm-define (parser-feature lan key) + (:require (and (== lan "cpp") (== key "operator"))) + `(,(string->symbol key) + (operator "+" + "-" + "/" + "*" + "%" + ;; Arith + "|" + "&" + "^" + ;; Bit + "<<" + ">>" + "==" + "!=" + "<" + ">" + "<=" + ">=" + "&&" + "||" + "!" + "==" + ;; Boolean + "+=" + "-=" + "/=" + "*=" + "%=" + "|=" + "&=" + "^=" + ;; Assignment + "=" + ":") + (operator_special "->") + (operator_decoration "@") + (operator_field "." "::") + (operator_openclose "{" "[" "(" ")" "]" "}")) +) ;tm-define + + +(define (cpp-number-suffix) + '(suffix (long "l" "L") (double "d" "D") (float "f" "F")) +) ;define + +(tm-define (parser-feature lan key) + (:require (and (== lan "cpp") (== key "number"))) + `(,(string->symbol key) + (bool_features "prefix_0x" "sci_notation") + ,(cpp-number-suffix) + (separator "_")) +) ;tm-define + +(tm-define (parser-feature lan key) + (:require (and (== lan "cpp") (== key "string"))) + `(,(string->symbol key) + (bool_features) + (escape_sequences "\\" "\"" "'" "b" "f" "n" "r" "t")) +) ;tm-define + + +;; https://en.cppreference.com/w/cpp/preprocessor +(tm-define (parser-feature lan key) + (:require (and (== lan "cpp") (== key "preprocessor"))) + `(,(string->symbol key) + (directives "define" "undef" "include" "if" "ifdef" "ifndef" "else" "elif" + "endif" "line" "error" "pragma")) +) ;tm-define + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Preferences for syntax highlighting +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (notify-cpp-pref var val) + (syntax-read-preferences "cpp") +) ;define + +(define-preferences ("syntax:cpp:none" "black" notify-cpp-pref) + ("syntax:cpp:comment" "dark grey" notify-cpp-pref) + ("syntax:cpp:keyword" "dark magenta" notify-cpp-pref) + ("syntax:cpp:error" "dark red" notify-cpp-pref) + ("syntax:cpp:preprocessor" "dark brown" notify-cpp-pref) + ("syntax:cpp:preprocessor_directive" "dark green" notify-cpp-pref) + ("syntax:cpp:constant_type" "#4040c0" notify-cpp-pref) + ("syntax:cpp:constant_number" "#4040c0" notify-cpp-pref) + ("syntax:cpp:constant_string" "dark red" notify-cpp-pref) +) ;define-preferences diff --git a/TeXmacs/plugins/csv/progs/csv/csv-format.scm b/TeXmacs/plugins/csv/progs/csv/csv-format.scm new file mode 100644 index 0000000000..c405a33b8b --- /dev/null +++ b/TeXmacs/plugins/csv/progs/csv/csv-format.scm @@ -0,0 +1,40 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; MODULE : csv.scm +;; DESCRIPTION : CSV data format +;; COPYRIGHT : (C) 2022 Darcy Shen, Joris van der Hoeven +;; +;; This software falls under the GNU general public license version 3 or later. +;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE +;; in the root directory or . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(texmacs-module (csv csv-format)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; CSV source files +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-format csv (:name "CSV") (:suffix "csv")) + +(define (texmacs->csv x . opts) + (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '())) +) ;define + +(define (csv->texmacs x . opts) + (code->texmacs x) +) ;define + +(define (csv-snippet->texmacs x . opts) + (code-snippet->texmacs x) +) ;define + +(converter texmacs-tree csv-document (:function texmacs->csv)) + +(converter csv-document texmacs-tree (:function csv->texmacs)) + +(converter texmacs-tree csv-snippet (:function texmacs->csv)) + +(converter csv-snippet texmacs-tree (:function csv-snippet->texmacs)) diff --git a/TeXmacs/plugins/csv/progs/code/csv-lang.scm b/TeXmacs/plugins/csv/progs/csv/csv-lang.scm similarity index 77% rename from TeXmacs/plugins/csv/progs/code/csv-lang.scm rename to TeXmacs/plugins/csv/progs/csv/csv-lang.scm index 8d7634ab82..4c3cebc408 100644 --- a/TeXmacs/plugins/csv/progs/code/csv-lang.scm +++ b/TeXmacs/plugins/csv/progs/csv/csv-lang.scm @@ -11,16 +11,16 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(texmacs-module (code csv-lang) - (:use (prog default-lang))) +(texmacs-module (csv csv-lang) (:use (prog default-lang))) (tm-define (parser-feature lan key) (:require (and (== lan "csv") (== key "operator"))) - `(,(string->symbol key) - (operator ","))) + `(,(string->symbol key) (operator ",")) +) ;tm-define (tm-define (parser-feature lan key) (:require (and (== lan "csv") (== key "string"))) `(,(string->symbol key) - (bool_features ) - (escape_sequences "\\" "/" "\"" "b" "f" "n" "r" "t"))) + (bool_features) + (escape_sequences "\\" "/" "\"" "b" "f" "n" "r" "t")) +) ;tm-define diff --git a/TeXmacs/plugins/csv/progs/data/csv.scm b/TeXmacs/plugins/csv/progs/data/csv.scm deleted file mode 100644 index ad57ad6b62..0000000000 --- a/TeXmacs/plugins/csv/progs/data/csv.scm +++ /dev/null @@ -1,43 +0,0 @@ - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : csv.scm -;; DESCRIPTION : CSV data format -;; COPYRIGHT : (C) 2022 Darcy Shen, Joris van der Hoeven -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (data csv)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; CSV source files -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-format csv - (:name "CSV") - (:suffix "csv")) - -(define (texmacs->csv x . opts) - (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '()))) - -(define (csv->texmacs x . opts) - (code->texmacs x)) - -(define (csv-snippet->texmacs x . opts) - (code-snippet->texmacs x)) - -(converter texmacs-tree csv-document - (:function texmacs->csv)) - -(converter csv-document texmacs-tree - (:function csv->texmacs)) - -(converter texmacs-tree csv-snippet - (:function texmacs->csv)) - -(converter csv-snippet texmacs-tree - (:function csv-snippet->texmacs)) diff --git a/TeXmacs/plugins/data/progs/data/code-format.scm b/TeXmacs/plugins/data/progs/data/code-format.scm new file mode 100644 index 0000000000..1988db0d51 --- /dev/null +++ b/TeXmacs/plugins/data/progs/data/code-format.scm @@ -0,0 +1,68 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; MODULE : code.scm +;; DESCRIPTION : prog format +;; COPYRIGHT : (C) 2022 Darcy Shen, Joris van der Hoeven +;; +;; This software falls under the GNU general public license version 3 or later. +;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE +;; in the root directory or . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(texmacs-module (data code-format)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; C++ source files +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-format cpp (:name "C++ source code") (:suffix "cpp" "cc" "hpp" "hh")) + +(define (texmacs->cpp x . opts) + (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '())) +) ;define + +(define (cpp->texmacs x . opts) + (code->texmacs x) +) ;define + +(define (cpp-snippet->texmacs x . opts) + (code-snippet->texmacs x) +) ;define + +(converter texmacs-tree cpp-document (:function texmacs->cpp)) + +(converter cpp-document texmacs-tree (:function cpp->texmacs)) + +(converter texmacs-tree cpp-snippet (:function texmacs->cpp)) + +(converter cpp-snippet texmacs-tree (:function cpp-snippet->texmacs)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Scheme source files +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-format scheme (:name "Scheme source code") (:suffix "scm")) + +(define (texmacs->scheme x . opts) + (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '())) +) ;define + +(define (scheme->texmacs x . opts) + (verbatim->texmacs x (acons "verbatim->texmacs:encoding" "SourceCode" '())) +) ;define + +(define (scheme-snippet->texmacs x . opts) + (verbatim-snippet->texmacs x + (acons "verbatim->texmacs:encoding" "SourceCode" '()) + ) ;verbatim-snippet->texmacs +) ;define + +(converter texmacs-tree scheme-document (:function texmacs->scheme)) + +(converter scheme-document texmacs-tree (:function scheme->texmacs)) + +(converter texmacs-tree scheme-snippet (:function texmacs->scheme)) + +(converter scheme-snippet texmacs-tree (:function scheme-snippet->texmacs)) diff --git a/TeXmacs/plugins/data/progs/data/code.scm b/TeXmacs/plugins/data/progs/data/code.scm deleted file mode 100644 index 1b38636632..0000000000 --- a/TeXmacs/plugins/data/progs/data/code.scm +++ /dev/null @@ -1,73 +0,0 @@ - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : code.scm -;; DESCRIPTION : prog format -;; COPYRIGHT : (C) 2022 Darcy Shen, Joris van der Hoeven -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (data code)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; C++ source files -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-format cpp - (:name "C++ source code") - (:suffix "cpp" "cc" "hpp" "hh")) - -(define (texmacs->cpp x . opts) - (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '()))) - -(define (cpp->texmacs x . opts) - (code->texmacs x)) - -(define (cpp-snippet->texmacs x . opts) - (code-snippet->texmacs x)) - -(converter texmacs-tree cpp-document - (:function texmacs->cpp)) - -(converter cpp-document texmacs-tree - (:function cpp->texmacs)) - -(converter texmacs-tree cpp-snippet - (:function texmacs->cpp)) - -(converter cpp-snippet texmacs-tree - (:function cpp-snippet->texmacs)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Scheme source files -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-format scheme - (:name "Scheme source code") - (:suffix "scm")) - -(define (texmacs->scheme x . opts) - (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '()))) - -(define (scheme->texmacs x . opts) - (verbatim->texmacs x (acons "verbatim->texmacs:encoding" "SourceCode" '()))) - -(define (scheme-snippet->texmacs x . opts) - (verbatim-snippet->texmacs x - (acons "verbatim->texmacs:encoding" "SourceCode" '()))) - -(converter texmacs-tree scheme-document - (:function texmacs->scheme)) - -(converter scheme-document texmacs-tree - (:function scheme->texmacs)) - -(converter texmacs-tree scheme-snippet - (:function texmacs->scheme)) - -(converter scheme-snippet texmacs-tree - (:function scheme-snippet->texmacs)) diff --git a/TeXmacs/plugins/data/progs/data/image-format.scm b/TeXmacs/plugins/data/progs/data/image-format.scm new file mode 100644 index 0000000000..b3c99f41ff --- /dev/null +++ b/TeXmacs/plugins/data/progs/data/image-format.scm @@ -0,0 +1,44 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; MODULE : image.scm +;; DESCRIPTION : Image data formats +;; COPYRIGHT : (C) 2003 Joris van der Hoeven +;; +;; This software falls under the GNU general public license version 3 or later. +;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE +;; in the root directory or . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(texmacs-module (data image-format)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Graphical document and geometric image formats +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-format postscript (:name "Postscript") (:suffix "ps" "eps")) + +(define-format pdf (:name "Pdf") (:suffix "pdf")) + +(define-format tmu.pdf (:name "TMU.PDF") (:suffix "tmu.pdf")) + +(define-format svg (:name "Svg") (:suffix "svg")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Bitmap image formats +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-format gif (:name "Gif") (:suffix "gif")) + +(define-format jpeg (:name "Jpeg") (:suffix "jpg" "jpeg")) + +(define-format png (:name "Png") (:suffix "png")) + +(define-format ppm (:name "Ppm") (:suffix "ppm")) + +(define-format tif (:name "Tif") (:suffix "tif" "tiff")) + +(define-format webp (:name "WebP") (:suffix "webp")) + +(define-format xpm (:name "Xpm") (:suffix "xpm")) diff --git a/TeXmacs/plugins/data/progs/data/image.scm b/TeXmacs/plugins/data/progs/data/image.scm deleted file mode 100644 index e7c774f0ac..0000000000 --- a/TeXmacs/plugins/data/progs/data/image.scm +++ /dev/null @@ -1,66 +0,0 @@ - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : image.scm -;; DESCRIPTION : Image data formats -;; COPYRIGHT : (C) 2003 Joris van der Hoeven -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (data image)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Graphical document and geometric image formats -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-format postscript - (:name "Postscript") - (:suffix "ps" "eps")) - -(define-format pdf - (:name "Pdf") - (:suffix "pdf")) - -(define-format tmu.pdf - (:name "TMU.PDF") - (:suffix "tmu.pdf")) - -(define-format svg - (:name "Svg") - (:suffix "svg")) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Bitmap image formats -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-format gif - (:name "Gif") - (:suffix "gif")) - -(define-format jpeg - (:name "Jpeg") - (:suffix "jpg" "jpeg")) - -(define-format png - (:name "Png") - (:suffix "png")) - -(define-format ppm - (:name "Ppm") - (:suffix "ppm")) - -(define-format tif - (:name "Tif") - (:suffix "tif" "tiff")) - -(define-format webp - (:name "WebP") - (:suffix "webp")) - -(define-format xpm - (:name "Xpm") - (:suffix "xpm")) diff --git a/TeXmacs/plugins/docx/progs/data/docx.scm b/TeXmacs/plugins/docx/progs/data/docx.scm deleted file mode 100644 index 5e8693e484..0000000000 --- a/TeXmacs/plugins/docx/progs/data/docx.scm +++ /dev/null @@ -1,76 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : docx.scm -;; DESCRIPTION : DOCX data format -;; COPYRIGHT : (C) 2024 ATQlove -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(import (liii uuid)) -(import (liii os)) - -(texmacs-module (data docx) - (:use (binary pandoc) - (texmacs texmacs tm-files) - (network url))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; DOCX format defination -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-format docx - (:name "docx") - (:suffix "docx")) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Function to export TeXmacs document to DOCX using Pandoc -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(tm-define (texmacs-tree->docx-string t opt) - (:synopsis "Export TeXmacs document to DOCX format using Pandoc") - (let* ( - (temp-name (string-append "/" (uuid4))) - (temp-dir (string-append (os-temp-dir) temp-name)) - (html-temp-url (system->url (string-append temp-dir ".html"))) - (docx-temp-url (system->url (string-append temp-dir ".docx"))) - (html-dir (url-head (url->string html-temp-url))) ;; get dir of html-temp-url - (html-dir-str (url->string html-dir))) - ;; First, export the document to HTML - (silent-html-progress #t) ;; TODO: implement docx-progress UI - (export-buffer-main (current-buffer) html-temp-url "html" ()) - (silent-html-progress #f) - ;; Then, use Pandoc to convert the HTML to DOCX - (if (has-binary-pandoc?) - (begin - (chdir html-dir-str) - (let ((cmd (string-append "\"" (url->string (find-binary-pandoc)) "\"" - " " - (url->string html-temp-url) - " -o " - (url->string docx-temp-url)))) - (debug-message "debug-io" (string-append "debug: cmd for Pandoc: " cmd "\n")) ;; For debugging - (system cmd) - (with result (string-load docx-temp-url) - (system-remove html-temp-url) - (system-remove docx-temp-url) - result)) - ;; Delete the intermediate HTML file - ) ;; Expected:$TEXMACS_PATH/tests/tm.html") - (error "Pandoc binary not found")))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Converter for exporting TeXmacs tree to DOCX string -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(converter texmacs-tree docx-document - (:require (has-binary-pandoc?)) - (:function-with-options texmacs-tree->docx-string) - (:option "texmacs->html:css" "on") - (:option "texmacs->html:mathjax" "off") - (:option "texmacs->html:mathml" "on") - (:option "texmacs->html:images" "off") - (:option "texmacs->html:css-stylesheet" "---")) diff --git a/TeXmacs/plugins/docx/progs/docx/docx-format.scm b/TeXmacs/plugins/docx/progs/docx/docx-format.scm new file mode 100644 index 0000000000..8fa874b846 --- /dev/null +++ b/TeXmacs/plugins/docx/progs/docx/docx-format.scm @@ -0,0 +1,89 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; MODULE : docx.scm +;; DESCRIPTION : DOCX data format +;; COPYRIGHT : (C) 2024 ATQlove +;; +;; This software falls under the GNU general public license version 3 or later. +;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE +;; in the root directory or . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(import (liii uuid)) + +(texmacs-module (docx docx-format) + (:use (binary pandoc) (texmacs texmacs tm-files) (network url)) +) ;texmacs-module + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; DOCX format defination +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-format docx (:name "docx") (:suffix "docx")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Function to export TeXmacs document to DOCX using Pandoc +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(tm-define (texmacs-tree->docx-string t opt) + (:synopsis "Export TeXmacs document to DOCX format using Pandoc") + (let* ((temp-name (string-append "/" (uuid4))) + (temp-dir (string-append (os-temp-dir) temp-name)) + (html-temp-url (system->url (string-append temp-dir ".html"))) + (docx-temp-url (system->url (string-append temp-dir ".docx"))) + (html-dir (url-head (url->string html-temp-url))) + ;; get dir of html-temp-url + (html-dir-str (url->string html-dir)) + ) ; + ;; First, export the document to HTML + (silent-html-progress #t) + ;; TODO: implement docx-progress UI + (export-buffer-main (current-buffer) html-temp-url "html" ()) + (silent-html-progress #f) + ;; Then, use Pandoc to convert the HTML to DOCX + (if (has-binary-pandoc?) + (begin + (chdir html-dir-str) + (let ((cmd (string-append "\"" + (url->string (find-binary-pandoc)) + "\"" + " " + (url->string html-temp-url) + " -o " + (url->string docx-temp-url) + ) ;string-append + ) ;cmd + ) ; + (debug-message "debug-io" (string-append "debug: cmd for Pandoc: " cmd "\n")) + ;; For debugging + (system cmd) + (with result + (string-load docx-temp-url) + (system-remove html-temp-url) + (system-remove docx-temp-url) + result + ) ;with + ) ;let + ;; Delete the intermediate HTML file + ) ;begin + ;; Expected:$TEXMACS_PATH/tests/tm.html") + (error "Pandoc binary not found") + ) ;if + ) ;let* +) ;tm-define + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Converter for exporting TeXmacs tree to DOCX string +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(converter texmacs-tree + docx-document + (:require (has-binary-pandoc?)) + (:function-with-options texmacs-tree->docx-string) + (:option "texmacs->html:css" "on") + (:option "texmacs->html:mathjax" "off") + (:option "texmacs->html:mathml" "on") + (:option "texmacs->html:images" "off") + (:option "texmacs->html:css-stylesheet" "---") +) ;converter diff --git a/TeXmacs/plugins/emacs/progs/init-emacs.scm b/TeXmacs/plugins/emacs/progs/init-emacs.scm new file mode 100644 index 0000000000..d1c26c88b6 --- /dev/null +++ b/TeXmacs/plugins/emacs/progs/init-emacs.scm @@ -0,0 +1,184 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; MODULE : init-emacs.scm +;; DESCRIPTION : Initialize the 'emacs' plugin (Emacs look and feel keymap) +;; COPYRIGHT : (C) 1999 Joris van der Hoeven +;; +;; This software falls under the GNU general public license version 3 or later. +;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE +;; in the root directory or . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(when (like-emacs?) + (kbd-map (:profile emacs) + + ;; standard Emacs shortcuts + ("emacs a" (kbd-start-line)) + ("emacs b" (kbd-left)) + ;; ("emacs d" (remove-text #t)) + ("emacs d" (kbd-delete)) + ("emacs e" (kbd-end-line)) + ("emacs f" (kbd-right)) + ("emacs g" (selection-cancel)) + ("emacs j" (insert-return)) + ("emacs k" (kill-paragraph)) + ("emacs l" (refresh-window)) + ("emacs m" (insert-return)) + ("emacs n" (kbd-down)) + ("emacs p" (kbd-up)) + ("emacs q" (make 'symbol)) + ("emacs r" (interactive-search)) + ("emacs s" (interactive-search)) + ("emacs v" (kbd-page-down)) + ("emacs w" (kbd-cut)) + ("emacs y" (kbd-paste)) + ("emacs insert" (kbd-copy)) + ("emacs _" (undo 0)) + ("emacs /" (undo 0)) + + ("emacs:meta v" (kbd-page-up)) + ("emacs:meta w" (kbd-copy)) + ("emacs:meta x" (interactive exec-interactive-command)) + ("emacs:meta X" (interactive footer-eval)) + ("emacs:meta <" (go-start)) + ("emacs:meta >" (go-end)) + ("emacs:meta $" (interactive-spell)) + ("emacs:meta %" (interactive-replace)) + ("emacs:meta backspace" (backward-kill-word)) + ("emacs:meta delete" (kill-word)) + + ("emacs:prefix b" (interactive go-to-buffer)) + ("emacs:prefix h" (select-all)) + ("emacs:prefix k" (close-document)) + ("emacs:prefix K" (close-document*)) + ("emacs:prefix C-c" (safely-quit-TeXmacs)) + ("emacs:prefix C-f" (interactive load-document)) + ("emacs:prefix C-i" (make 'indent)) + ("emacs:prefix C-s" (save-buffer)) + ("emacs:prefix C-w" (interactive save-buffer-as)) + + ("search emacs s" (search-next-match #t)) + ("search emacs r" (search-next-match #f)) + + ;; not implemented + ;; ("emacs h ..." (help ...)) + ;; ("emacs l" (recenter-window)) + ;; ("emacs o" (open-line)) + ("emacs t" (new-document)) + ;; ("emacs u" (universal-argument)) + ;; ("emacs z" (suspend-texmacs)) + ;; ("emacs \\" (toggle-input-method)) + ;; ("emacs ]" (abort-recursive-edit)) + ;; ("emacs:meta !" (shell-command)) + ;; ("emacs:meta (" (insert-parentheses)) + ;; ("emacs:meta )" (move-past-closed-and-reindent)) + ;; ("emacs:meta *" (pop-tag-mark)) ;; conflict altcmd * + ;; ("emacs:meta ," (loops-tag-continue)) + ;; ("emacs:meta ." (find-tag)) + ;; ("emacs:meta /" (dabbrev-expand)) ;; conflict altcmd / + ;; ("emacs:meta \\" (delete-horizontal-space)) ;; conflict altcmd \ + ;; ("emacs:meta :" (interactive footer-eval)) ;; conflict altcmd : + ;; ("emacs:meta ;" (comment-dwim)) ;; conflict altcmd ; + ;; ("emacs:meta =" (count-lines-region)) + ;; ("emacs:meta {" (backward-paragraph)) + ;; ("emacs:meta |" (shell-command-on-region)) + ;; ("emacs:meta }" (forward-paragraph)) + ;; ("emacs:meta @" (mark-word)) + ;; ("emacs:meta a" (traverse-up)) ;; conflict altcmd a + ;; ("emacs:meta b" (traverse-left)) + ;; ("emacs:meta c" (capitalize-word)) + ;; ("emacs:meta e" (traverse-down)) ;; conflict altcmd e + ;; ("emacs:meta f" (traverse-right)) ;; conflict altcmd f + ;; ("emacs:meta h" (mark-paragraph)) + ;; ("emacs:meta i" (tab-to-tab-stop)) ;; conflict altcmd i + ;; ("emacs:meta j" (indent-new-command-line)) + ;; ("emacs:meta l" (downcase-word)) ;; conflict altcmd l + ;; ("emacs:meta m" (back-to-indentation)) + ;; ("emacs:meta q" (fill-paragraph)) + ;; ("emacs:meta r" (move-to-window-line)) + ;; ("emacs:meta t" (transpose-words)) ;; conflict altcmd t + ;; ("emacs:meta u" (upcase-word)) + ;; ("emacs:meta y" (yank-pop)) + ;; ("emacs:meta z" (zap-to-char)) + ;; ("emacs:prefix delete" (backward-kill-sentence)) + ;; ("emacs:prefix `" (next-error)) + ;; ("emacs:prefix 0" (delete-window)) + ;; ("emacs:prefix 1" (delete-other-windows)) + ;; ("emacs:prefix 2" (split-window-vertically)) + ;; ("emacs:prefix 3" (split-window-horizontally)) + ;; ("emacs:prefix d" (dired)) + ;; ("emacs:prefix f" (set-fill-column)) + ;; ("emacs:prefix i" (interactive insert-buffer)) + ;; ("emacs:prefix l" (count-lines-page)) + ;; ("emacs:prefix m" (compose-mail)) + ;; ("emacs:prefix o" (other-window)) + ;; ("emacs:prefix s" (save-some-buffers)) + ;; ("emacs:prefix u" (advertised-undo)) + ;; ("emacs:prefix z" (repeat)) + ;; ("emacs:prefix C-@" (pop-global-mark)) + ;; ("emacs:prefix C-d" (list-directory)) + ;; ("emacs:prefix C-e" (eval-last-expression)) + ;; ("emacs:prefix C-l" (downcase-region)) + ;; ("emacs:prefix C-n" (set-goal-column)) + ;; ("emacs:prefix C-o" (delete-blank-lines)) + ;; ("emacs:prefix C-p" (mark-page)) + ;; ("emacs:prefix C-q" (toggle-read-only)) + ;; ("emacs:prefix C-r" (interactive load-readonly-buffer)) + ;; ("emacs:prefix C-t" (transpose-lines)) + ;; ("emacs:prefix C-u" (upcase-region)) + ;; ("emacs:prefix C-v" (interactive load-alternate-buffer)) + ;; ("emacs:prefix C-x" (exchange-point-and-mark)) + ;; ("emacs:prefix C-z" (suspend-texmacs)) + + ;; further shortcuts for the Emacs mode + ("F2" (open-document)) + ("S-F2" (open-document*)) + ("C-F2" (revert-buffer)) + ("M-F2" (new-document)) + ("M-S-F2" (new-document*)) + ;; ("M-C-F2" (clone-window)) + ("F3" (save-buffer)) + ("S-F3" (choose-file save-buffer-as "Save TeXmacs file" "action_save_as")) + ("F4" (preview-buffer)) + ("S-F4" (print-buffer)) + ("C-F4" (interactive print-to-file)) + ("M-F4" (interactive print-pages)) + ("M-S-F4" (interactive print-pages-to-file)) + + ("emacs =" (interactive-replace)) + ("emacs:meta g" (kbd-cancel)) + ("emacs:meta [" (undo 0)) + ("emacs:meta ]" (redo 0)) + + ("A-C-tab" (geometry-circulate #t)) + ("A-C-S-tab" (geometry-circulate #f)) + ("A-C-[" (geometry-slower)) + ("A-C-]" (geometry-faster)) + + ("C-<" (cursor-history-backward)) + ("C->" (cursor-history-forward)) + ("C-!" (cursor-history-add (cursor-path))) + ("C-#" (numbered-toggle (focus-tree))) + ("C-*" (alternate-toggle (focus-tree))) + ("C-%" (inactive-toggle (focus-tree))) + ("C-+" (zoom-in (sqrt (sqrt 2.0)))) + ("C--" (zoom-out (sqrt (sqrt 2.0)))) + ("C-0" (change-zoom-factor 1.0)) + + ("C-7" (fit-all-to-screen)) + ("C-8" (fit-to-screen)) + ("C-9" (fit-to-screen-width)) + ) ;kbd-map + + (kbd-map (:profile emacs) + (:require (and (not (in-prog?)) (not (in-verbatim?)))) + ("A-tab" (kbd-alternate-tab)) + ("A-S-tab" (kbd-shift-alternate-tab)) + ("A-space" (make-space "0.2spc")) + ("A-S-space" (make-space "-0.2spc")) + ("M-space" (make-space "0.2spc")) + ("M-S-space" (make-space "-0.2spc")) + ) ;kbd-map +) ;when diff --git a/TeXmacs/plugins/emoji/progs/init-emoji.scm b/TeXmacs/plugins/emoji/progs/init-emoji.scm deleted file mode 100644 index 610a04b713..0000000000 --- a/TeXmacs/plugins/emoji/progs/init-emoji.scm +++ /dev/null @@ -1,811 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : init-emoji.scm -;; DESCRIPTION : Initialize the emoji plugin -;; COPYRIGHT : (C) 2024 Darcy Shen -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (emoji)) - -(kbd-map (": + 1 :" "<#1F44D>") - (": - 1 :" "<#1F44E>") - (": 1 0 0 :" "<#1F4AF>") - (": 1 2 3 4 :" "<#1F522>") - (": 8 b a l l :" "<#1F3B1>") - (": a b c :" "<#1F524>") - (": a b c d :" "<#1F521>") - (": a e r i a l t r a m w a y :" "<#1F6A1>") - (": a i r p l a n e :" "<#2708>") - (": a l i e n :" "<#1F47D>") - (": a m b u l a n c e :" "<#1F691>") - (": a n c h o r :" "<#2693>") - (": a n g e l :" "<#1F47C>") - (": a n g e r :" "<#1F4A2>") - (": a n g r y :" "<#1F620>") - (": a n g u i s h e d :" "<#1F627>") - (": a n t :" "<#1F41C>") - (": a p p l e :" "<#1F34E>") - (": a q u a r i u s :" "<#2652>") - (": a r i e s :" "<#2648>") - (": a r r o w b a c k w a r d :" "<#25C0>") - (": a r r o w d o w n :" "<#2B07>") - (": a r r o w d o w n s m a l l :" "<#1F53D>") - (": a r r o w f o r w a r d :" "<#25B6>") - (": a r r o w h e a d i n g d o w n :" "<#2935>") - (": a r r o w h e a d i n g u p :" "<#2934>") - (": a r r o w l e f t :" "<#2B05>") - (": a r r o w l o w e r l e f t :" "<#2199>") - (": a r r o w l o w e r r i g h t :" "<#2198>") - (": a r r o w r i g h t :" "<#27A1>") - (": a r r o w r i g h t h o o k :" "<#21AA>") - (": a r r o w u p :" "<#2B06>") - (": a r r o w u p d o w n :" "<#2195>") - (": a r r o w u p s m a l l :" "<#1F53C>") - (": a r r o w u p p e r l e f t :" "<#2196>") - (": a r r o w u p p e r r i g h t :" "<#2197>") - (": a r r o w s c l o c k w i s e :" "<#1F503>") - (": a r r o w s c o u n t e r c l o c k w i s e :" "<#1F504>") - (": a r t :" "<#1F3A8>") - (": a r t i c u l a t e d l o r r y :" "<#1F69B>") - (": a s t o n i s h e d :" "<#1F632>") - (": a t m :" "<#1F3E7>") - (": b a b y :" "<#1F476>") - (": b a b y b o t t l e :" "<#1F37C>") - (": b a b y c h i c k :" "<#1F424>") - (": b a b y s y m b o l :" "<#1F6BC>") - (": b a g g a g e c l a i m :" "<#1F6C4>") - (": b a l l o o n :" "<#1F388>") - (": b a l l o t b o x w i t h c h e c k :" "<#2611>") - (": b a m b o o :" "<#1F38D>") - (": b a n a n a :" "<#1F34C>") - (": b a n g b a n g :" "<#203C>") - (": b a n k :" "<#1F3E6>") - (": b a r c h a r t :" "<#1F4CA>") - (": b a r b e r :" "<#1F488>") - (": b a s e b a l l :" "<#26BE>") - (": b a s k e t b a l l :" "<#1F3C0>") - (": b a t h :" "<#1F6C0>") - (": b a t h t u b :" "<#1F6C1>") - (": b a t t e r y :" "<#1F50B>") - (": b e a r :" "<#1F43B>") - (": b e e r :" "<#1F37A>") - (": b e e r s :" "<#1F37B>") - (": b e e t l e :" "<#1FAB2>") - (": b e g i n n e r :" "<#1F530>") - (": b e l l :" "<#1F514>") - (": b e n t o :" "<#1F371>") - (": b i c y c l i s t :" "<#1F6B4>") - (": b i k e :" "<#1F6B2>") - (": b i k i n i :" "<#1F459>") - (": b i r d :" "<#1F426>") - (": b i r t h d a y :" "<#1F382>") - (": b l a c k c i r c l e :" "<#26AB>") - (": b l a c k n i b :" "<#2712>") - (": b l a c k s q u a r e b u t t o n :" "<#1F532>") - (": b l o s s o m :" "<#1F33C>") - (": b l o w f i s h :" "<#1F421>") - (": b l u e b o o k :" "<#1F4D8>") - (": b l u e c a r :" "<#1F699>") - (": b l u e h e a r t :" "<#1F499>") - (": b l u s h :" "<#1F60A>") - (": b o a r :" "<#1F417>") - (": b o a t :" "<#26F5>") - (": b o m b :" "<#1F4A3>") - (": b o o k :" "<#1F4D6>") - (": b o o k m a r k :" "<#1F516>") - (": b o o k m a r k t a b s :" "<#1F4D1>") - (": b o o k s :" "<#1F4DA>") - (": b o o m :" "<#1F4A5>") - (": b o o t :" "<#1F462>") - (": b o u q u e t :" "<#1F490>") - (": b o w :" "<#1F647>") - (": b o w l i n g :" "<#1F3B3>") - (": b o y :" "<#1F466>") - (": b r e a d :" "<#1F35E>") - (": b r i d e w i t h v e i l :" "<#1F470>") - (": b r i d g e a t n i g h t :" "<#1F309>") - (": b r i e f c a s e :" "<#1F4BC>") - (": b r o k e n h e a r t :" "<#1F494>") - (": b u g :" "<#1F41B>") - (": b u l b :" "<#1F4A1>") - (": b u l l e t t r a i n f r o n t :" "<#1F685>") - (": b u l l e t t r a i n s i d e :" "<#1F684>") - (": b u s :" "<#1F68C>") - (": b u s s t o p :" "<#1F68F>") - (": b u s t i n s i l h o u e t t e :" "<#1F464>") - (": b u s t s i n s i l h o u e t t e :" "<#1F465>") - (": c a c t u s :" "<#1F335>") - (": c a k e :" "<#1F370>") - (": c a l e n d a r :" "<#1F4C6>") - (": c a l l i n g :" "<#1F4F2>") - (": c a m e l :" "<#1F42B>") - (": c a m e r a :" "<#1F4F7>") - (": c a n c e r :" "<#264B>") - (": c a n d y :" "<#1F36C>") - (": c a p i t a l a b c d :" "<#1F520>") - (": c a p r i c o r n :" "<#2651>") - (": c a r :" "<#1F697>") - (": c a r d i n d e x :" "<#1F4C7>") - (": c a r o u s e l h o r s e :" "<#1F3A0>") - (": c a t :" "<#1F431>") - (": c a t 2 :" "<#1F408>") - (": c d :" "<#1F4BF>") - (": c h a r t :" "<#1F4B9>") - (": c h a r t w i t h d o w n w a r d s t r e n d :" "<#1F4C9>") - (": c h a r t w i t h u p w a r d s t r e n d :" "<#1F4C8>") - (": c h e c k e r e d f l a g :" "<#1F3C1>") - (": c h e r r i e s :" "<#1F352>") - (": c h e r r y b l o s s o m :" "<#1F338>") - (": c h e s t n u t :" "<#1F330>") - (": c h i c k e n :" "<#1F414>") - (": c h i l d r e n c r o s s i n g :" "<#1F6B8>") - (": c h o c o l a t e b a r :" "<#1F36B>") - (": c h r i s t m a s t r e e :" "<#1F384>") - (": c h u r c h :" "<#26EA>") - (": c i n e m a :" "<#1F3A6>") - (": c i r c u s t e n t :" "<#1F3AA>") - (": c i t y s u n r i s e :" "<#1F307>") - (": c i t y s u n s e t :" "<#1F306>") - (": c l a p :" "<#1F44F>") - (": c l a p p e r :" "<#1F3AC>") - (": c l i p b o a r d :" "<#1F4CB>") - (": c l o c k 1 :" "<#1F550>") - (": c l o c k 1 0 :" "<#1F559>") - (": c l o c k 1 0 3 0 :" "<#1F565>") - (": c l o c k 1 1 :" "<#1F55A>") - (": c l o c k 1 1 3 0 :" "<#1F566>") - (": c l o c k 1 2 :" "<#1F55B>") - (": c l o c k 1 2 3 0 :" "<#1F567>") - (": c l o c k 1 3 0 :" "<#1F55C>") - (": c l o c k 2 :" "<#1F551>") - (": c l o c k 2 3 0 :" "<#1F55D>") - (": c l o c k 3 :" "<#1F552>") - (": c l o c k 3 3 0 :" "<#1F55E>") - (": c l o c k 4 :" "<#1F553>") - (": c l o c k 4 3 0 :" "<#1F55F>") - (": c l o c k 5 :" "<#1F554>") - (": c l o c k 5 3 0 :" "<#1F560>") - (": c l o c k 6 :" "<#1F555>") - (": c l o c k 6 3 0 :" "<#1F561>") - (": c l o c k 7 :" "<#1F556>") - (": c l o c k 7 3 0 :" "<#1F562>") - (": c l o c k 8 :" "<#1F557>") - (": c l o c k 8 3 0 :" "<#1F563>") - (": c l o c k 9 :" "<#1F558>") - (": c l o c k 9 3 0 :" "<#1F564>") - (": c l o s e d b o o k :" "<#1F4D5>") - (": c l o s e d l o c k w i t h k e y :" "<#1F510>") - (": c l o s e d u m b r e l l a :" "<#1F302>") - (": c l o u d :" "<#2601>") - (": c l u b s :" "<#2663>") - (": c n :" "<#1F1E8>") - (": c o c k t a i l :" "<#1F378>") - (": c o f f e e :" "<#2615>") - (": c o l d s w e a t :" "<#1F630>") - (": c o l l i s i o n :" "<#1F4A5>") - (": c o m p u t e r :" "<#1F4BB>") - (": c o n f e t t i b a l l :" "<#1F38A>") - (": c o n f o u n d e d :" "<#1F616>") - (": c o n f u s e d :" "<#1F615>") - (": c o n s t r u c t i o n :" "<#1F6A7>") - (": c o n s t r u c t i o n w o r k e r :" "<#1F477>") - (": c o n v e n i e n c e s t o r e :" "<#1F3EA>") - (": c o o k i e :" "<#1F36A>") - (": c o p :" "<#1F46E>") - (": c o p y r i g h t :" "<#00A9>") - (": c o r n :" "<#1F33D>") - (": c o u p l e :" "<#1F46B>") - (": c o u p l e w i t h h e a r t :" "<#1F491>") - (": c o u p l e k i s s :" "<#1F48F>") - (": c o w :" "<#1F42E>") - (": c o w 2 :" "<#1F404>") - (": c r e d i t c a r d :" "<#1F4B3>") - (": c r o c o d i l e :" "<#1F40A>") - (": c r o s s e d f l a g s :" "<#1F38C>") - (": c r o w n :" "<#1F451>") - (": c r y :" "<#1F622>") - (": c r y i n g c a t f a c e :" "<#1F63F>") - (": c r y s t a l b a l l :" "<#1F52E>") - (": c u p i d :" "<#1F498>") - (": c u r l y l o o p :" "<#27B0>") - (": c u r r e n c y e x c h a n g e :" "<#1F4B1>") - (": c u r r y :" "<#1F35B>") - (": c u s t a r d :" "<#1F36E>") - (": c u s t o m s :" "<#1F6C3>") - (": c y c l o n e :" "<#1F300>") - (": d a n c e r :" "<#1F483>") - (": d a n c e r s :" "<#1F46F>") - (": d a n g o :" "<#1F361>") - (": d a r t :" "<#1F3AF>") - (": d a s h :" "<#1F4A8>") - (": d a t e :" "<#1F4C5>") - (": d e :" "<#1F1E9>") - (": d e c i d u o u s t r e e :" "<#1F333>") - (": d e p a r t m e n t s t o r e :" "<#1F3EC>") - (": d i a m o n d s h a p e w i t h a d o t i n s i d e :" "<#1F4A0>") - (": d i a m o n d s :" "<#2666>") - (": d i s a p p o i n t e d :" "<#1F61E>") - (": d i s a p p o i n t e d r e l i e v e d :" "<#1F625>") - (": d i z z y :" "<#1F4AB>") - (": d i z z y f a c e :" "<#1F635>") - (": d o n o t l i t t e r :" "<#1F6AF>") - (": d o g :" "<#1F436>") - (": d o g 2 :" "<#1F415>") - (": d o l l a r :" "<#1F4B5>") - (": d o l l s :" "<#1F38E>") - (": d o l p h i n :" "<#1F42C>") - (": d o o r :" "<#1F6AA>") - (": d o u g h n u t :" "<#1F369>") - (": d r a g o n :" "<#1F409>") - (": d r a g o n f a c e :" "<#1F432>") - (": d r e s s :" "<#1F457>") - (": d r o m e d a r y c a m e l :" "<#1F42A>") - (": d r o p l e t :" "<#1F4A7>") - (": d v d :" "<#1F4C0>") - (": e m a i l :" "<#1F4E7>") - (": e a r :" "<#1F442>") - (": e a r o f r i c e :" "<#1F33E>") - (": e a r t h a f r i c a :" "<#1F30D>") - (": e a r t h a m e r i c a s :" "<#1F30E>") - (": e a r t h a s i a :" "<#1F30F>") - (": e g g :" "<#1F95A>") - (": e g g p l a n t :" "<#1F346>") - (": e i g h t p o i n t e d b l a c k s t a r :" "<#2734>") - (": e i g h t s p o k e d a s t e r i s k :" "<#2733>") - (": e l e c t r i c p l u g :" "<#1F50C>") - (": e l e p h a n t :" "<#1F418>") - (": e m a i l :" "<#1F4E7>") - (": e n d :" "<#1F51A>") - (": e n v e l o p e :" "<#2709>") - (": e s :" "<#1F1EA>") - (": e u r o :" "<#1F4B6>") - (": e u r o p e a n c a s t l e :" "<#1F3F0>") - (": e u r o p e a n p o s t o f f i c e :" "<#1F3E4>") - (": e v e r g r e e n t r e e :" "<#1F332>") - (": e x c l a m a t i o n :" "<#2757>") - (": e x p r e s s i o n l e s s :" "<#1F611>") - (": e y e g l a s s e s :" "<#1F453>") - (": e y e s :" "<#1F440>") - (": f a c e p u n c h :" "<#1F44A>") - (": f a c t o r y :" "<#1F3ED>") - (": f a l l e n l e a f :" "<#1F342>") - (": f a m i l y :" "<#1F46A>") - (": f a x :" "<#1F4E0>") - (": f e a r f u l :" "<#1F628>") - (": f e e t :" "<#1F43E>") - (": f e r r i s w h e e l :" "<#1F3A1>") - (": f i l e f o l d e r :" "<#1F4C1>") - (": f i r e :" "<#1F525>") - (": f i r e e n g i n e :" "<#1F692>") - (": f i r e w o r k s :" "<#1F386>") - (": f i r s t q u a r t e r m o o n :" "<#1F313>") - (": f i r s t q u a r t e r m o o n w i t h f a c e :" "<#1F31B>") - (": f i s h :" "<#1F41F>") - (": f i s h c a k e :" "<#1F365>") - (": f i s h i n g p o l e a n d f i s h :" "<#1F3A3>") - (": f i s t :" "<#270A>") - (": f l a g s :" "<#1F38F>") - (": f l a s h l i g h t :" "<#1F526>") - (": f l o p p y d i s k :" "<#1F4BE>") - (": f l o w e r p l a y i n g c a r d s :" "<#1F3B4>") - (": f l u s h e d :" "<#1F633>") - (": f o g g y :" "<#1F301>") - (": f o o t b a l l :" "<#1F3C8>") - (": f o r k a n d k n i f e :" "<#1F374>") - (": f o u n t a i n :" "<#26F2>") - (": f o u r l e a f c l o v e r :" "<#1F340>") - (": f r :" "<#1F1EB>") - (": f r i e d s h r i m p :" "<#1F364>") - (": f r i e s :" "<#1F35F>") - (": f r o g :" "<#1F438>") - (": f r o w n i n g :" "<#1F626>") - (": f u :" "<#1F595>") - (": f u e l p u m p :" "<#26FD>") - (": f u l l m o o n :" "<#1F315>") - (": f u l l m o o n w i t h f a c e :" "<#1F31D>") - (": g a m e d i e :" "<#1F3B2>") - (": g b :" "<#1F1EC>") - (": g e m :" "<#1F48E>") - (": g e m i n i :" "<#264A>") - (": g h o s t :" "<#1F47B>") - (": g i f t :" "<#1F381>") - (": g i f t h e a r t :" "<#1F49D>") - (": g i r l :" "<#1F467>") - (": g l o b e w i t h m e r i d i a n s :" "<#1F310>") - (": g o a t :" "<#1F410>") - (": g o l f :" "<#26F3>") - (": g r a p e s :" "<#1F347>") - (": g r e e n a p p l e :" "<#1F34F>") - (": g r e e n b o o k :" "<#1F4D7>") - (": g r e e n h e a r t :" "<#1F49A>") - (": g r e y e x c l a m a t i o n :" "<#2755>") - (": g r e y q u e s t i o n :" "<#2754>") - (": g r i m a c i n g :" "<#1F62C>") - (": g r i n :" "<#1F601>") - (": g r i n n i n g :" "<#1F600>") - (": g u a r d s m a n :" "<#1F482>") - (": g u i t a r :" "<#1F3B8>") - (": g u n :" "<#1F52B>") - (": h a i r c u t :" "<#1F487>") - (": h a m b u r g e r :" "<#1F354>") - (": h a m m e r :" "<#1F528>") - (": h a m s t e r :" "<#1F439>") - (": h a n d :" "<#270B>") - (": h a n d b a g :" "<#1F45C>") - (": h a n k e y :" "<#1F4A9>") - (": h a s h :" "<#0023>") - (": h a t c h e d c h i c k :" "<#1F425>") - (": h a t c h i n g c h i c k :" "<#1F423>") - (": h e a d p h o n e s :" "<#1F3A7>") - (": h e a r n o e v i l :" "<#1F649>") - (": h e a r t :" "<#2764>") - (": h e a r t d e c o r a t i o n :" "<#1F49F>") - (": h e a r t e y e s :" "<#1F60D>") - (": h e a r t e y e s c a t :" "<#1F63B>") - (": h e a r t b e a t :" "<#1F493>") - (": h e a r t p u l s e :" "<#1F497>") - (": h e a r t s :" "<#2665>") - (": h e a v y c h e c k m a r k :" "<#2714>") - (": h e a v y d i v i s i o n s i g n :" "<#2797>") - (": h e a v y d o l l a r s i g n :" "<#1F4B2>") - (": h e a v y e x c l a m a t i o n m a r k :" "<#2757>") - (": h e a v y m i n u s s i g n :" "<#2796>") - (": h e a v y m u l t i p l i c a t i o n x :" "<#2716>") - (": h e a v y p l u s s i g n :" "<#2795>") - (": h e l i c o p t e r :" "<#1F681>") - (": h e r b :" "<#1F33F>") - (": h i b i s c u s :" "<#1F33A>") - (": h i g h b r i g h t n e s s :" "<#1F506>") - (": h i g h h e e l :" "<#1F460>") - (": h o c h o :" "<#1F52A>") - (": h o n e y p o t :" "<#1F36F>") - (": h o n e y b e e :" "<#1F41D>") - (": h o r s e :" "<#1F434>") - (": h o r s e r a c i n g :" "<#1F3C7>") - (": h o s p i t a l :" "<#1F3E5>") - (": h o t e l :" "<#1F3E8>") - (": h o t s p r i n g s :" "<#2668>") - (": h o u r g l a s s :" "<#231B>") - (": h o u s e :" "<#1F3E0>") - (": h o u s e w i t h g a r d e n :" "<#1F3E1>") - (": h u s h e d :" "<#1F62F>") - (": i c e c r e a m :" "<#1F368>") - (": i c e c r e a m :" "<#1F366>") - (": i m p :" "<#1F47F>") - (": i n b o x t r a y :" "<#1F4E5>") - (": i n c o m i n g e n v e l o p e :" "<#1F4E8>") - (": i n f o r m a t i o n d e s k p e r s o n :" "<#1F481>") - (": i n f o r m a t i o n s o u r c e :" "<#2139>") - (": i n n o c e n t :" "<#1F607>") - (": i n t e r r o b a n g :" "<#2049>") - (": i p h o n e :" "<#1F4F1>") - (": i t :" "<#1F1EE>") - (": i z a k a y a l a n t e r n :" "<#1F3EE>") - (": j a c k o l a n t e r n :" "<#1F383>") - (": j a p a n :" "<#1F5FE>") - (": j a p a n e s e c a s t l e :" "<#1F3EF>") - (": j a p a n e s e g o b l i n :" "<#1F47A>") - (": j a p a n e s e o g r e :" "<#1F479>") - (": j e a n s :" "<#1F456>") - (": j o y :" "<#1F602>") - (": j o y c a t :" "<#1F639>") - (": j p :" "<#1F1EF>") - (": k e y :" "<#1F511>") - (": k e y c a p t e n :" "<#1F51F>") - (": k i m o n o :" "<#1F458>") - (": k i s s :" "<#1F48B>") - (": k i s s i n g :" "<#1F617>") - (": k i s s i n g c a t :" "<#1F63D>") - (": k i s s i n g c l o s e d e y e s :" "<#1F61A>") - (": k i s s i n g h e a r t :" "<#1F618>") - (": k i s s i n g s m i l i n g e y e s :" "<#1F619>") - (": k o a l a :" "<#1F428>") - (": k r :" "<#1F1F0>") - (": l a r g e b l u e c i r c l e :" "<#1F535>") - (": l a r g e b l u e d i a m o n d :" "<#1F537>") - (": l a r g e o r a n g e d i a m o n d :" "<#1F536>") - (": l a s t q u a r t e r m o o n :" "<#1F317>") - (": l a s t q u a r t e r m o o n w i t h f a c e :" "<#1F31C>") - (": l a u g h i n g :" "<#1F606>") - (": l e a v e s :" "<#1F343>") - (": l e d g e r :" "<#1F4D2>") - (": l e f t l u g g a g e :" "<#1F6C5>") - (": l e f t r i g h t a r r o w :" "<#2194>") - (": l e f t w a r d s a r r o w w i t h h o o k :" "<#21A9>") - (": l e m o n :" "<#1F34B>") - (": l e o :" "<#264C>") - (": l e o p a r d :" "<#1F406>") - (": l i b r a :" "<#264E>") - (": l i g h t r a i l :" "<#1F688>") - (": l i n k :" "<#1F517>") - (": l i p s :" "<#1F444>") - (": l i p s t i c k :" "<#1F484>") - (": l o c k :" "<#1F512>") - (": l o c k w i t h i n k p e n :" "<#1F50F>") - (": l o l l i p o p :" "<#1F36D>") - (": l o o p :" "<#27BF>") - (": l o u d s p e a k e r :" "<#1F4E2>") - (": l o v e h o t e l :" "<#1F3E9>") - (": l o v e l e t t e r :" "<#1F48C>") - (": l o w b r i g h t n e s s :" "<#1F505>") - (": m :" "<#24C2>") - (": m a g :" "<#1F50D>") - (": m a g r i g h t :" "<#1F50E>") - (": m a i l b o x :" "<#1F4EB>") - (": m a i l b o x c l o s e d :" "<#1F4EA>") - (": m a i l b o x w i t h m a i l :" "<#1F4EC>") - (": m a i l b o x w i t h n o m a i l :" "<#1F4ED>") - (": m a n :" "<#1F468>") - (": m a n w i t h g u a p i m a o :" "<#1F472>") - (": m a n w i t h t u r b a n :" "<#1F473>") - (": m a n s s h o e :" "<#1F45E>") - (": m a p l e l e a f :" "<#1F341>") - (": m a s k :" "<#1F637>") - (": m a s s a g e :" "<#1F486>") - (": m e a t o n b o n e :" "<#1F356>") - (": m e g a :" "<#1F4E3>") - (": m e l o n :" "<#1F348>") - (": m e m o :" "<#1F4DD>") - (": m e n s :" "<#1F6B9>") - (": m e t a l :" "<#1F918>") - (": m e t r o :" "<#1F687>") - (": m i c r o p h o n e :" "<#1F3A4>") - (": m i c r o s c o p e :" "<#1F52C>") - (": m i l k y w a y :" "<#1F30C>") - (": m i n i b u s :" "<#1F690>") - (": m i n i d i s c :" "<#1F4BD>") - (": m o b i l e p h o n e o f f :" "<#1F4F4>") - (": m o n e y w i t h w i n g s :" "<#1F4B8>") - (": m o n e y b a g :" "<#1F4B0>") - (": m o n k e y :" "<#1F412>") - (": m o n k e y f a c e :" "<#1F435>") - (": m o n o r a i l :" "<#1F69D>") - (": m o o n :" "<#1F314>") - (": m o r t a r b o a r d :" "<#1F393>") - (": m o u n t f u j i :" "<#1F5FB>") - (": m o u n t a i n b i c y c l i s t :" "<#1F6B5>") - (": m o u n t a i n c a b l e w a y :" "<#1F6A0>") - (": m o u n t a i n r a i l w a y :" "<#1F69E>") - (": m o u s e :" "<#1F42D>") - (": m o u s e 2 :" "<#1F401>") - (": m o v i e c a m e r a :" "<#1F3A5>") - (": m o y a i :" "<#1F5FF>") - (": m u s c l e :" "<#1F4AA>") - (": m u s h r o o m :" "<#1F344>") - (": m u s i c a l k e y b o a r d :" "<#1F3B9>") - (": m u s i c a l n o t e :" "<#1F3B5>") - (": m u s i c a l s c o r e :" "<#1F3BC>") - (": m u t e :" "<#1F507>") - (": n a i l c a r e :" "<#1F485>") - (": n a m e b a d g e :" "<#1F4DB>") - (": n e c k t i e :" "<#1F454>") - (": n e g a t i v e s q u a r e d c r o s s m a r k :" "<#274E>") - (": n e u t r a l f a c e :" "<#1F610>") - (": n e w m o o n :" "<#1F311>") - (": n e w m o o n w i t h f a c e :" "<#1F31A>") - (": n e w s p a p e r :" "<#1F4F0>") - (": n o b e l l :" "<#1F515>") - (": n o b i c y c l e s :" "<#1F6B3>") - (": n o e n t r y :" "<#26D4>") - (": n o e n t r y s i g n :" "<#1F6AB>") - (": n o g o o d :" "<#1F645>") - (": n o m o b i l e p h o n e s :" "<#1F4F5>") - (": n o m o u t h :" "<#1F636>") - (": n o p e d e s t r i a n s :" "<#1F6B7>") - (": n o s m o k i n g :" "<#1F6AD>") - (": n o n p o t a b l e w a t e r :" "<#1F6B1>") - (": n o s e :" "<#1F443>") - (": n o t e b o o k :" "<#1F4D3>") - (": n o t e b o o k w i t h d e c o r a t i v e c o v e r :" "<#1F4D4>") - (": n o t e s :" "<#1F3B6>") - (": n u t a n d b o l t :" "<#1F529>") - (": o c e a n :" "<#1F30A>") - (": o c t o p u s :" "<#1F419>") - (": o d e n :" "<#1F362>") - (": o f f i c e :" "<#1F3E2>") - (": o k h a n d :" "<#1F44C>") - (": o k w o m a n :" "<#1F646>") - (": o l d e r m a n :" "<#1F474>") - (": o l d e r w o m a n :" "<#1F475>") - (": o n :" "<#1F51B>") - (": o n c o m i n g a u t o m o b i l e :" "<#1F698>") - (": o n c o m i n g b u s :" "<#1F68D>") - (": o n c o m i n g p o l i c e c a r :" "<#1F694>") - (": o n c o m i n g t a x i :" "<#1F696>") - (": o p e n f i l e f o l d e r :" "<#1F4C2>") - (": o p e n h a n d s :" "<#1F450>") - (": o p e n m o u t h :" "<#1F62E>") - (": o p h i u c h u s :" "<#26CE>") - (": o r a n g e b o o k :" "<#1F4D9>") - (": o u t b o x t r a y :" "<#1F4E4>") - (": o x :" "<#1F402>") - (": p a g e f a c i n g u p :" "<#1F4C4>") - (": p a g e w i t h c u r l :" "<#1F4C3>") - (": p a g e r :" "<#1F4DF>") - (": p a l m t r e e :" "<#1F334>") - (": p a n d a f a c e :" "<#1F43C>") - (": p a p e r c l i p :" "<#1F4CE>") - (": p a r t a l t e r n a t i o n m a r k :" "<#303D>") - (": p a r t l y s u n n y :" "<#26C5>") - (": p a s s p o r t c o n t r o l :" "<#1F6C2>") - (": p a w p r i n t s :" "<#1F43E>") - (": p e a c h :" "<#1F351>") - (": p e a r :" "<#1F350>") - (": p e n c i l :" "<#1F4DD>") - (": p e n c i l 2 :" "<#270F>") - (": p e n g u i n :" "<#1F427>") - (": p e n s i v e :" "<#1F614>") - (": p e r f o r m i n g a r t s :" "<#1F3AD>") - (": p e r s e v e r e :" "<#1F623>") - (": p h o n e :" "<#260E>") - (": p i g :" "<#1F437>") - (": p i g 2 :" "<#1F416>") - (": p i g n o s e :" "<#1F43D>") - (": p i l l :" "<#1F48A>") - (": p i n e a p p l e :" "<#1F34D>") - (": p i s c e s :" "<#2653>") - (": p i z z a :" "<#1F355>") - (": p o i n t d o w n :" "<#1F447>") - (": p o i n t l e f t :" "<#1F448>") - (": p o i n t r i g h t :" "<#1F449>") - (": p o i n t u p :" "<#261D>") - (": p o i n t u p 2 :" "<#1F446>") - (": p o l i c e c a r :" "<#1F693>") - (": p o o d l e :" "<#1F429>") - (": p o o p :" "<#1F4A9>") - (": p o s t o f f i c e :" "<#1F3E3>") - (": p o s t a l h o r n :" "<#1F4EF>") - (": p o s t b o x :" "<#1F4EE>") - (": p o t a b l e w a t e r :" "<#1F6B0>") - (": p o u c h :" "<#1F45D>") - (": p o u l t r y l e g :" "<#1F357>") - (": p o u n d :" "<#1F4B7>") - (": p o u t i n g c a t :" "<#1F63E>") - (": p r a y :" "<#1F64F>") - (": p r i n c e s s :" "<#1F478>") - (": p u n c h :" "<#1F44A>") - (": p u r p l e h e a r t :" "<#1F49C>") - (": p u r s e :" "<#1F45B>") - (": p u s h p i n :" "<#1F4CC>") - (": p u t l i t t e r i n i t s p l a c e :" "<#1F6AE>") - (": q u e s t i o n :" "<#2753>") - (": r a b b i t :" "<#1F430>") - (": r a b b i t 2 :" "<#1F407>") - (": r a c e h o r s e :" "<#1F40E>") - (": r a d i o :" "<#1F4FB>") - (": r a d i o b u t t o n :" "<#1F518>") - (": r a g e :" "<#1F621>") - (": r a i l w a y c a r :" "<#1F683>") - (": r a i n b o w :" "<#1F308>") - (": r a i s e d h a n d :" "<#270B>") - (": r a i s e d h a n d s :" "<#1F64C>") - (": r a i s i n g h a n d :" "<#1F64B>") - (": r a m :" "<#1F40F>") - (": r a m e n :" "<#1F35C>") - (": r a t :" "<#1F400>") - (": r e c y c l e :" "<#267B>") - (": r e d c a r :" "<#1F697>") - (": r e d c i r c l e :" "<#1F534>") - (": r e g i s t e r e d :" "<#00AE>") - (": r e l a x e d :" "<#263A>") - (": r e l i e v e d :" "<#1F60C>") - (": r e p e a t :" "<#1F501>") - (": r e p e a t o n e :" "<#1F502>") - (": r e s t r o o m :" "<#1F6BB>") - (": r e v o l v i n g h e a r t s :" "<#1F49E>") - (": r i b b o n :" "<#1F380>") - (": r i c e :" "<#1F35A>") - (": r i c e b a l l :" "<#1F359>") - (": r i c e c r a c k e r :" "<#1F358>") - (": r i c e s c e n e :" "<#1F391>") - (": r i n g :" "<#1F48D>") - (": r o c k e t :" "<#1F680>") - (": r o l l e r c o a s t e r :" "<#1F3A2>") - (": r o o s t e r :" "<#1F413>") - (": r o s e :" "<#1F339>") - (": r o t a t i n g l i g h t :" "<#1F6A8>") - (": r o u n d p u s h p i n :" "<#1F4CD>") - (": r o w b o a t :" "<#1F6A3>") - (": r u :" "<#1F1F7>") - (": r u g b y f o o t b a l l :" "<#1F3C9>") - (": r u n n e r :" "<#1F3C3>") - (": r u n n i n g :" "<#1F3C3>") - (": r u n n i n g s h i r t w i t h s a s h :" "<#1F3BD>") - (": s a g i t t a r i u s :" "<#2650>") - (": s a i l b o a t :" "<#26F5>") - (": s a k e :" "<#1F376>") - (": s a n d a l :" "<#1F461>") - (": s a n t a :" "<#1F385>") - (": s a t e l l i t e :" "<#1F4E1>") - (": s a t i s f i e d :" "<#1F606>") - (": s a x o p h o n e :" "<#1F3B7>") - (": s c h o o l :" "<#1F3EB>") - (": s c h o o l s a t c h e l :" "<#1F392>") - (": s c i s s o r s :" "<#2702>") - (": s c o r p i u s :" "<#264F>") - (": s c r e a m :" "<#1F631>") - (": s c r e a m c a t :" "<#1F640>") - (": s c r o l l :" "<#1F4DC>") - (": s e a t :" "<#1F4BA>") - (": s e e n o e v i l :" "<#1F648>") - (": s e e d l i n g :" "<#1F331>") - (": s h a v e d i c e :" "<#1F367>") - (": s h e e p :" "<#1F411>") - (": s h e l l :" "<#1F41A>") - (": s h i p :" "<#1F6A2>") - (": s h i r t :" "<#1F455>") - (": s h i t :" "<#1F4A9>") - (": s h o e :" "<#1F45E>") - (": s h o w e r :" "<#1F6BF>") - (": s i g n a l s t r e n g t h :" "<#1F4F6>") - (": s i x p o i n t e d s t a r :" "<#1F52F>") - (": s k i :" "<#1F3BF>") - (": s k u l l :" "<#1F480>") - (": s l e e p i n g :" "<#1F634>") - (": s l e e p y :" "<#1F62A>") - (": s l o t m a c h i n e :" "<#1F3B0>") - (": s m a l l b l u e d i a m o n d :" "<#1F539>") - (": s m a l l o r a n g e d i a m o n d :" "<#1F538>") - (": s m a l l r e d t r i a n g l e :" "<#1F53A>") - (": s m a l l r e d t r i a n g l e d o w n :" "<#1F53B>") - (": s m i l e :" "<#1F604>") - (": s m i l e c a t :" "<#1F638>") - (": s m i l e y :" "<#1F603>") - (": s m i l e y c a t :" "<#1F63A>") - (": s m i l i n g i m p :" "<#1F608>") - (": s m i r k :" "<#1F60F>") - (": s m i r k c a t :" "<#1F63C>") - (": s m o k i n g :" "<#1F6AC>") - (": s n a i l :" "<#1F40C>") - (": s n a k e :" "<#1F40D>") - (": s n o w b o a r d e r :" "<#1F3C2>") - (": s n o w f l a k e :" "<#2744>") - (": s n o w m a n :" "<#26C4>") - (": s o b :" "<#1F62D>") - (": s o c c e r :" "<#26BD>") - (": s o o n :" "<#1F51C>") - (": s o u n d :" "<#1F509>") - (": s p a c e i n v a d e r :" "<#1F47E>") - (": s p a d e s :" "<#2660>") - (": s p a g h e t t i :" "<#1F35D>") - (": s p a r k l e r :" "<#1F387>") - (": s p a r k l e s :" "<#2728>") - (": s p a r k l i n g h e a r t :" "<#1F496>") - (": s p e a k n o e v i l :" "<#1F64A>") - (": s p e a k e r :" "<#1F508>") - (": s p e e c h b a l l o o n :" "<#1F4AC>") - (": s p e e d b o a t :" "<#1F6A4>") - (": s t a r :" "<#2B50>") - (": s t a r 2 :" "<#1F31F>") - (": s t a r s :" "<#1F320>") - (": s t a t i o n :" "<#1F689>") - (": s t a t u e o f l i b e r t y :" "<#1F5FD>") - (": s t e a m l o c o m o t i v e :" "<#1F682>") - (": s t e w :" "<#1F372>") - (": s t r a i g h t r u l e r :" "<#1F4CF>") - (": s t r a w b e r r y :" "<#1F353>") - (": s t u c k o u t t o n g u e :" "<#1F61B>") - (": s t u c k o u t t o n g u e c l o s e d e y e s :" "<#1F61D>") - (": s t u c k o u t t o n g u e w i n k i n g e y e :" "<#1F61C>") - (": s u n w i t h f a c e :" "<#1F31E>") - (": s u n f l o w e r :" "<#1F33B>") - (": s u n g l a s s e s :" "<#1F60E>") - (": s u n n y :" "<#2600>") - (": s u n r i s e :" "<#1F305>") - (": s u n r i s e o v e r m o u n t a i n s :" "<#1F304>") - (": s u r f e r :" "<#1F3C4>") - (": s u s h i :" "<#1F363>") - (": s u s p e n s i o n r a i l w a y :" "<#1F69F>") - (": s w e a t :" "<#1F613>") - (": s w e a t d r o p s :" "<#1F4A6>") - (": s w e a t s m i l e :" "<#1F605>") - (": s w e e t p o t a t o :" "<#1F360>") - (": s w i m m e r :" "<#1F3CA>") - (": s y m b o l s :" "<#1F523>") - (": s y r i n g e :" "<#1F489>") - (": t a d a :" "<#1F389>") - (": t a n a b a t a t r e e :" "<#1F38B>") - (": t a n g e r i n e :" "<#1F34A>") - (": t a u r u s :" "<#2649>") - (": t a x i :" "<#1F695>") - (": t e a :" "<#1F375>") - (": t e l e p h o n e :" "<#260E>") - (": t e l e p h o n e r e c e i v e r :" "<#1F4DE>") - (": t e l e s c o p e :" "<#1F52D>") - (": t e n n i s :" "<#1F3BE>") - (": t e n t :" "<#26FA>") - (": t h o u g h t b a l l o o n :" "<#1F4AD>") - (": t h u m b s d o w n :" "<#1F44E>") - (": t h u m b s u p :" "<#1F44D>") - (": t i c k e t :" "<#1F3AB>") - (": t i g e r :" "<#1F42F>") - (": t i g e r 2 :" "<#1F405>") - (": t i r e d f a c e :" "<#1F62B>") - (": t m :" "<#2122>") - (": t o i l e t :" "<#1F6BD>") - (": t o k y o t o w e r :" "<#1F5FC>") - (": t o m a t o :" "<#1F345>") - (": t o n g u e :" "<#1F445>") - (": t o p :" "<#1F51D>") - (": t o p h a t :" "<#1F3A9>") - (": t r a c t o r :" "<#1F69C>") - (": t r a f f i c l i g h t :" "<#1F6A5>") - (": t r a i n :" "<#1F68B>") - (": t r a i n 2 :" "<#1F686>") - (": t r a m :" "<#1F68A>") - (": t r i a n g u l a r f l a g o n p o s t :" "<#1F6A9>") - (": t r i a n g u l a r r u l e r :" "<#1F4D0>") - (": t r i d e n t :" "<#1F531>") - (": t r i u m p h :" "<#1F624>") - (": t r o l l e y b u s :" "<#1F68E>") - (": t r o p h y :" "<#1F3C6>") - (": t r o p i c a l d r i n k :" "<#1F379>") - (": t r o p i c a l f i s h :" "<#1F420>") - (": t r u c k :" "<#1F69A>") - (": t r u m p e t :" "<#1F3BA>") - (": t s h i r t :" "<#1F455>") - (": t u l i p :" "<#1F337>") - (": t u r t l e :" "<#1F422>") - (": t v :" "<#1F4FA>") - (": t w i s t e d r i g h t w a r d s a r r o w s :" "<#1F500>") - (": t w o h e a r t s :" "<#1F495>") - (": t w o m e n h o l d i n g h a n d s :" "<#1F46C>") - (": t w o w o m e n h o l d i n g h a n d s :" "<#1F46D>") - (": u k :" "<#1F1EC>") - (": u m b r e l l a :" "<#2614>") - (": u n a m u s e d :" "<#1F612>") - (": u n d e r a g e :" "<#1F51E>") - (": u n l o c k :" "<#1F513>") - (": u s :" "<#1F1FA>") - (": v :" "<#270C>") - (": v e r t i c a l t r a f f i c l i g h t :" "<#1F6A6>") - (": v h s :" "<#1F4FC>") - (": v i b r a t i o n m o d e :" "<#1F4F3>") - (": v i d e o c a m e r a :" "<#1F4F9>") - (": v i d e o g a m e :" "<#1F3AE>") - (": v i o l i n :" "<#1F3BB>") - (": v i r g o :" "<#264D>") - (": v o l c a n o :" "<#1F30B>") - (": w a l k i n g :" "<#1F6B6>") - (": w a n i n g c r e s c e n t m o o n :" "<#1F318>") - (": w a n i n g g i b b o u s m o o n :" "<#1F316>") - (": w a r n i n g :" "<#26A0>") - (": w a t c h :" "<#231A>") - (": w a t e r b u f f a l o :" "<#1F403>") - (": w a t e r m e l o n :" "<#1F349>") - (": w a v e :" "<#1F44B>") - (": w a v y d a s h :" "<#3030>") - (": w a x i n g c r e s c e n t m o o n :" "<#1F312>") - (": w a x i n g g i b b o u s m o o n :" "<#1F314>") - (": w c :" "<#1F6BE>") - (": w e a r y :" "<#1F629>") - (": w e d d i n g :" "<#1F492>") - (": w h a l e :" "<#1F433>") - (": w h a l e 2 :" "<#1F40B>") - (": w h e e l c h a i r :" "<#267F>") - (": w h i t e c h e c k m a r k :" "<#2705>") - (": w h i t e c i r c l e :" "<#26AA>") - (": w h i t e f l o w e r :" "<#1F4AE>") - (": w h i t e s q u a r e b u t t o n :" "<#1F533>") - (": w i n d c h i m e :" "<#1F390>") - (": w i n e g l a s s :" "<#1F377>") - (": w i n k :" "<#1F609>") - (": w o l f :" "<#1F43A>") - (": w o m a n :" "<#1F469>") - (": w o m a n s c l o t h e s :" "<#1F45A>") - (": w o m a n s h a t :" "<#1F452>") - (": w o m e n s :" "<#1F6BA>") - (": w o r r i e d :" "<#1F61F>") - (": w r e n c h :" "<#1F527>") - (": x :" "<#274C>") - (": y e l l o w h e a r t :" "<#1F49B>") - (": y e n :" "<#1F4B4>") - (": y u m :" "<#1F60B>") - (": z a p :" "<#26A1>") - (": z z z :" "<#1F4A4>") -) ;kbd-map diff --git a/TeXmacs/plugins/fish/packages/code/fish.stem b/TeXmacs/plugins/fish/packages/code/fish.stem new file mode 100644 index 0000000000..be9b50db5d --- /dev/null +++ b/TeXmacs/plugins/fish/packages/code/fish.stem @@ -0,0 +1,20 @@ +(document (TeXmacs "2.1.4") + (style (tuple "source" "std")) + (body (document (active* (src-title (document (compound "src-package" "fish" "1.0") + (src-purpose (document "FISH Language support for TeXmacs")) + ) ;document + ) ;src-title + ) ;active* + (concat (use-module "(fish fish-format)") " " (use-module "(fish fish-edit)")) + (assign "fish" + (macro "body" + (with "mode" "prog" "prog-language" "fish" "font-family" "rm" (arg "body")) + ) ;macro + ) ;assign + (assign "fish-code" + (macro "body" (document (pseudo-code (document (fish (arg "body")))))) + ) ;assign + ) ;document + ) ;body + (initial (collection (associate "preamble" "true") (associate "sfactor" "5"))) +) ;document diff --git a/TeXmacs/plugins/fish/packages/code/fish.ts b/TeXmacs/plugins/fish/packages/code/fish.ts deleted file mode 100644 index 1ccb6acfaf..0000000000 --- a/TeXmacs/plugins/fish/packages/code/fish.ts +++ /dev/null @@ -1,31 +0,0 @@ - - -> - -<\body> - - - - <\src-purpose> - FISH Language support for TeXmacs - - > - - - - - >>> - - - <\pseudo-code> - > - - > - - -<\initial> - <\collection> - - - - diff --git a/TeXmacs/plugins/fish/progs/code/fish-edit.scm b/TeXmacs/plugins/fish/progs/code/fish-edit.scm deleted file mode 100644 index f4b1a99e02..0000000000 --- a/TeXmacs/plugins/fish/progs/code/fish-edit.scm +++ /dev/null @@ -1,263 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : fish-edit.scm -;; DESCRIPTION : editing fish programs -;; COPYRIGHT : (C) 2025 vesita -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (code fish-edit) - (:use (prog prog-edit) - (code fish-mode) - ) ;:use -) ;texmacs-module - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Indentation policy -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(tm-define (fish-tabstop) 4) - -(tm-define (get-tabstop) - (:mode in-prog-fish?) - (fish-tabstop) -) ;tm-define - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Helpers -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define fish-block-openers - '("case" "command" "define" "else" "for" "foreach" "if" "loop" - "section" "struct" "structure" "while") -) ;define - -(define fish-block-closers - '("end" "end_if" "endif" "end_loop" "end_section" - "endcase" "endcommand" "endloop" "endsection") -) ;define - -(define fish-block-middle - '("case" "else") -) ;define - -(define (fish-word-in? w lst) - (cond - ((null? lst) #f) - ((== w (car lst)) #t) - (else (fish-word-in? w (cdr lst))) - ) ;cond -) ;define - -(define (fish-string-prefix? s p) - (and (>= (string-length s) (string-length p)) - (== (substring s 0 (string-length p)) p) - ) ;and -) ;define - -(define (fish-trim-left s) - (let loop ((i 0) (n (string-length s))) - (if (or (>= i n) - (not (char-whitespace? (string-ref s i)))) - (substring s i n) - (loop (+ i 1) n) - ) ;if - ) ;let -) ;define - -(define (fish-trim-right s) - (let loop ((i (- (string-length s) 1))) - (if (< i 0) "" - (if (char-whitespace? (string-ref s i)) - (loop (- i 1)) - (substring s 0 (+ i 1)) - ) ;if - ) ;if - ) ;let -) ;define - -(define (fish-trim s) - (fish-trim-right (fish-trim-left s)) -) ;define - -(define (fish-word-char? c) - (or (char-alphabetic? c) - (char-numeric? c) - (== c #\_) - ) ;or -) ;define - -(define (fish-first-word s) - (let* ((t (fish-trim-left s)) - (n (string-length t))) - (let loop ((i 0)) - (if (or (>= i n) - (not (fish-word-char? (string-ref t i)))) - (if (<= i 0) "" (substring t 0 i)) - (loop (+ i 1)) - ) ;if - ) ;let - ) ;let* -) ;define - -(define (fish-line-continues? line) - (let* ((t (fish-trim-right line)) - (n (string-length t))) - (and (> n 0) - (or (and (>= n 3) - (== (substring t (- n 3) n) "...")) - (== (string-ref t (- n 1)) #\&) - ) ;or - ) ;and - ) ;let* -) ;define - -(define (fish-line-opens-block? line) - (let* ((t (fish-trim line)) - (w (fish-first-word t))) - (or (and (!= w "") - (or (fish-word-in? w fish-block-openers) - (== w "caseof")) - ) ;or - (fish-string-prefix? t "if ") - (== t "if") - (fish-string-prefix? t "else if ") - (and (or (fish-string-prefix? t "if ") - (fish-string-prefix? t "else if ") - (fish-string-prefix? t "caseof ")) - (or (== t "then") - (fish-string-prefix? t "then ") - (and (>= (string-length t) 4) - (== (substring t (- (string-length t) 4) - (string-length t)) - "then" - ) ;== - ) ;and - ) ;or - ) ;and - ) ;or - ) ;let* -) ;define - -(define (fish-line-starts-with-outdent? line) - (let ((w (fish-first-word line))) - (or (fish-word-in? w fish-block-closers) - (fish-word-in? w fish-block-middle) - ) ;or - ) ;let -) ;define - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Line access -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (fish-get-line row) - (let ((s (program-row row))) - (if s s "") - ) ;let -) ;define - -(define (fish-prev-nonempty-row row) - (let loop ((r (- row 1))) - (if (< r 0) -1 - (let* ((line (fish-get-line r)) - (t (fish-trim line))) - (if (== t "") (loop (- r 1)) r) - ) ;let* - ) ;if - ) ;let -) ;define - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Indentation computation -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (fish-indent-level-from-prev row) - (let* ((pr (fish-prev-nonempty-row row))) - (if (< pr 0) 0 - (let* ((pline (fish-get-line pr)) - (base (string-get-indent pline)) - (tab (get-tabstop)) - (inc? (or (fish-line-continues? pline) - (fish-line-opens-block? pline))) - ) ;inc? - (+ base (if inc? tab 0)) - ) ;let* - ) ;if - ) ;let* -) ;define - -(tm-define (program-compute-indentation doc row col) - (:mode in-prog-fish?) - (let* ((tab (get-tabstop)) - (line (fish-get-line row)) - (base (fish-indent-level-from-prev row))) - (if (fish-line-starts-with-outdent? line) - (max 0 (- base tab)) - base - ) ;if - ) ;let* -) ;tm-define - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Commenting -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(tm-define (program-comment-start) - (:mode in-prog-fish?) - ";" -) ;tm-define - -(tm-define (program-toggle-comment) - (:mode in-prog-fish?) - (prog-toggle-line-comment ";") -) ;tm-define - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Paste import hook -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(tm-define (kbd-paste) - (:mode in-prog-fish?) - (clipboard-paste-import "fish" "primary") -) ;tm-define - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Brackets / quotes -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(tm-define (fish-bracket-open lbr rbr) - (bracket-open lbr rbr "\\") -) ;tm-define - -(tm-define (fish-bracket-close lbr rbr) - (bracket-close lbr rbr "\\") -) ;tm-define - -(tm-define (notify-cursor-moved status) - (:require prog-highlight-brackets?) - (:mode in-prog-fish?) - (select-brackets-after-movement "([{" ")]}" "\\") -) ;tm-define - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Keyboard mappings -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(kbd-map - (:mode in-prog-fish?) - ("A-tab" (insert-tabstop)) - ("cmd S-tab" (remove-tabstop)) - ("{" (fish-bracket-open "{" "}" )) - ("}" (fish-bracket-close "{" "}" )) - ("(" (fish-bracket-open "(" ")" )) - (")" (fish-bracket-close "(" ")" )) - ("[" (fish-bracket-open "[" "]" )) - ("]" (fish-bracket-close "[" "]" )) - ("\"" (fish-bracket-open "\"" "\"" )) - ("'" (fish-bracket-open "'" "'" )) -) ;kbd-map diff --git a/TeXmacs/plugins/fish/progs/code/fish-lang.scm b/TeXmacs/plugins/fish/progs/code/fish-lang.scm deleted file mode 100644 index 332edc9283..0000000000 --- a/TeXmacs/plugins/fish/progs/code/fish-lang.scm +++ /dev/null @@ -1,239 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : fish-lang.scm -;; DESCRIPTION : fish language support -;; COPYRIGHT : (C) 2025 veista -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (code fish-lang) - (:use (prog default-lang)) -) ;texmacs-module - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Parser Features -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(tm-define (parser-feature lan key) - (:require (and (== lan "fish") (== key "keyword"))) - `(,(string->symbol key) - ;; Built-in names may contain underscores and official dotted namespaces. - (extra_chars "_" ".") - - (constant - "false" "true" "null") - - (declare_function - "define" - "code.name" - - "creep.active" "creep.cycle" "creep.safety.factor" "creep.solve" - "creep.step" "creep.time.total" "creep.timestep" - "creep.timestep.given" "creep.timestep.max" - - "dynamic.active" "dynamic.cycle" "dynamic.safety.factor" - "dynamic.solve" "dynamic.step" "dynamic.time.total" - "dynamic.timestep" "dynamic.timestep.given" - "dynamic.timestep.max" - - "file.all" "file.close" "file.delete" "file.end" "file.exist" - "file.name" "file.open" "file.open.check" "file.pos" - "file.read" "file.rename" "file.size" "file.write" - - "fluid.active" "fluid.cycle" "fluid.safety.factor" "fluid.solve" - "fluid.step" "fluid.time.total" "fluid.timestep" - "fluid.timestep.given" "fluid.timestep.max" - - "global.cycle" "global.deterministic" "global.dim" "global.fos" - "global.gravity" "global.step" "global.threads" - "global.timestep" "global.title" - - "io.dialog.in" "io.dialog.message" "io.dialog.notify" - "io.in" "io.input" "io.out" - - "mail.account" "mail.attachment.add" "mail.attachment.delete" - "mail.body" "mail.clear" "mail.domain" "mail.from" - "mail.host" "mail.password" "mail.port" - "mail.recipient.add" "mail.recipient.delete" - "mail.send" "mail.subject" - - "math.aangle.to.euler" "math.abs" "math.acos" "math.and" - "math.area.intersect.poly.poly" "math.area.poly" "math.asin" - "math.atan" "math.atan2" "math.bound" "math.ceiling" - "math.choose" "math.closest.segment.point" - "math.closest.triangle.point" "math.cos" "math.cosh" - "math.cross" "math.cyl.bessel.i" "math.ddir.from.normal" - "math.degrad" "math.dip.from.normal" "math.dist.segment.point" - "math.dist.segment.segment" "math.dist.triangle.segment" - "math.dot" "math.erf" "math.erfc" "math.euler.to.aangle" - "math.exp" "math.expint" "math.floor" "math.gamma" - "math.in.range" "math.isinf" "math.isnan" "math.ln" - "math.log" "math.lshift" "math.mag" "math.mag2" - "math.max" "math.min" "math.normal.from.dip" - "math.normal.from.dip.ddir" "math.not" "math.or" - "math.outer.product" "math.pi" "math.random.gauss" - "math.random.uniform" "math.round" "math.rshift" - "math.sgn" "math.sin" "math.sinh" "math.sqrt" - "math.tan" "math.tanh" "math.triangle.inside" - "math.triangle.interp" "math.unit" - - "mech.active" "mech.cycle" "mech.safety.factor" - "mech.solve" "mech.step" "mech.time.total" - "mech.timestep" "mech.timestep.given" "mech.timestep.max" - - "socket.close" "socket.create" "socket.delete" - "socket.open" "socket.read" "socket.read.array" - "socket.write" "socket.write.array" - - "system.beep" "system.clone" "system.command" - "system.directory" "system.directory.absolute" - "system.directory.create" "system.directory.current" - "system.directory.delete" "system.directory.list" - "system.directory.relative" "system.environment" - "system.error" "system.os" "system.sleep" - - "thermal.active" "thermal.cycle" "thermal.safety.factor" - "thermal.solve" "thermal.step" "thermal.time.total" - "thermal.timestep" "thermal.timestep.given" - "thermal.timestep.max" - - "time.clock" "time.cpu" "time.kernel" "time.real" - - "array.copy" "array.delete" "array.dim" "array.size" - - "list.append" "list.at" "list.concatenate" "list.count" - "list.create" "list.extend" "list.find.index" "list.insert" - "list.insert.list" "list.max" "list.min" "list.prepend" - "list.range" "list.resize" "list.reverse" "list.separate" - "list.sequence" "list.size" "list.sort" "list.sum" - - "map.add" "map.add.list" "map.has" "map.keys" - "map.merge" "map.remove" "map.size" "map.value" - "map.value.all" - - "matrix.cols" "matrix.det" "matrix.from.axis.angle" - "matrix.from.euler" "matrix.identity" "matrix.inverse" - "matrix.lubksb" "matrix.ludcmp" "matrix.rows" - "matrix.to.axis.angle" "matrix.to.euler" - "matrix.transpose" - - "memory" "memory.create" "memory.delete" - "memory.fortran.float" "memory.fortran.index" - "memory.fortran.integer" "memory.offset" "memory.size" - - "string.build" "string.compare" "string.csv.from" - "string.csv.to" "string.file.ext" "string.file.name" - "string.file.path" "string.find" "string.find.regex" - "string.join" "string.len" "string.lower" - "string.match.regex" "string.replace" - "string.replace.regex" "string.simplify" "string.split" - "string.split.regex" "string.sub" "string.token" - "string.token.type" "string.type" "string.upper" - - "structure.check" "structure.from.map" "structure.name" - - "tensor.i2" "tensor.j2" "tensor.prin" - "tensor.prin.dir" "tensor.prin.from" "tensor.total" - "tensor.trace" - - "type" "type.index" "type.name" - "type.pointer" "type.pointer.id" "type.pointer.name" - - "version.code.major" "version.code.minor" - "version.fish.major" "version.fish.minor") - - (declare_type - "array" "boolean" "float" "index" "int" "list" - "map" "matrix" "string" "struct" "structure" - "tensor" "vector") - - (declare_identifier - "global" "local") - - (declare_module - "creep" "dynamic" "file" "fluid" "io" "mail" - "math" "mech" "socket" "system" "thermal" "time") - - ;; Lightweight approximation for command/endcommand blocks. - (keyword - "call" "fish" "history" "model" "new" - "program" "restore" "save" "solve") - - (keyword_conditional - "case" "caseof" "else" "endcase" - "end_if" "endif" "if" "then") - - (keyword_control - "command" "continue" "end_loop" "end_section" - "endcommand" "endloop" "endsection" "exit" - "exit_loop" "exit_section" "foreach" "for" - "lock" "loop" "return" "section" "while")) -) ;tm-define - -(tm-define (parser-feature lan key) - (:require (and (== lan "fish") (== key "operator"))) - `(,(string->symbol key) - (operator - "^" "/" "//" "*" "%" "-" "+" - "==" ">" "<" "#" ">=" "<=" "&" "|") - (operator_special - "~" "and" "or" "not" "," "::" - "=::" "+=::" "-=::" "*=::" "/=::") - (operator_field - "->" "=" "+=" "-=" "*=" "/=") - (operator_openclose - "(" ")" "[" "]")) -) ;tm-define - -(tm-define (parser-feature lan key) - (:require (and (== lan "fish") (== key "number"))) - `(,(string->symbol key) - (bool_features - "sci_notation")) -) ;tm-define - -(tm-define (parser-feature lan key) - (:require (and (== lan "fish") (== key "string"))) - `(,(string->symbol key) - (escape_sequences - "\\" "\"" "'" "b" "t" "r" "n")) -) ;tm-define - -(tm-define (parser-feature lan key) - (:require (and (== lan "fish") (== key "comment"))) - `(,(string->symbol key) - (inline ";")) -) ;tm-define - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Preferences for syntax highlighting -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (notify-fish-syntax var val) - (syntax-read-preferences "fish") -) ;define - -(define-preferences - ("syntax:fish:none" "red" notify-fish-syntax) - ("syntax:fish:comment" "brown" notify-fish-syntax) - ("syntax:fish:error" "dark red" notify-fish-syntax) - ("syntax:fish:constant" "#4040c0" notify-fish-syntax) - ("syntax:fish:constant_number" "#4040c0" notify-fish-syntax) - ("syntax:fish:constant_string" "dark grey" notify-fish-syntax) - ("syntax:fish:constant_char" "#333333" notify-fish-syntax) - ("syntax:fish:declare_function" "#0000c0" notify-fish-syntax) - ("syntax:fish:declare_type" "#0000c0" notify-fish-syntax) - ("syntax:fish:declare_module" "#0000c0" notify-fish-syntax) - ("syntax:fish:declare_identifier" "#0000c0" notify-fish-syntax) - ("syntax:fish:operator" "#8b008b" notify-fish-syntax) - ("syntax:fish:operator_openclose" "#B02020" notify-fish-syntax) - ("syntax:fish:operator_field" "#B02020" notify-fish-syntax) - ("syntax:fish:operator_special" "orange" notify-fish-syntax) - ("syntax:fish:keyword" "#309090" notify-fish-syntax) - ("syntax:fish:keyword_conditional" "#309090" notify-fish-syntax) - ("syntax:fish:keyword_control" "#309090" notify-fish-syntax) -) ;define-preferences diff --git a/TeXmacs/plugins/fish/progs/data/fish.scm b/TeXmacs/plugins/fish/progs/data/fish.scm deleted file mode 100644 index 5fbe70e6f9..0000000000 --- a/TeXmacs/plugins/fish/progs/data/fish.scm +++ /dev/null @@ -1,50 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : fish.scm -;; DESCRIPTION : prog format for fish -;; COPYRIGHT : (C) 2022-2025 Darcy Shen, Joris van der Hoeven -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (data fish)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; FISH source files -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-format fish - (:name "FISH source code") - (:suffix "fis" "FIS") -) ;define-format - -(define (texmacs->fish x . opts) - (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '())) -) ;define - -(define (fish->texmacs x . opts) - (code->texmacs x) -) ;define - -(define (fish-snippet->texmacs x . opts) - (code-snippet->texmacs x) -) ;define - -(converter texmacs-tree fish-document - (:function texmacs->fish) -) ;converter - -(converter fish-document texmacs-tree - (:function fish->texmacs) -) ;converter - -(converter texmacs-tree fish-snippet - (:function texmacs->fish) -) ;converter - -(converter fish-snippet texmacs-tree - (:function fish-snippet->texmacs) -) ;converter diff --git a/TeXmacs/plugins/fish/progs/fish/fish-edit.scm b/TeXmacs/plugins/fish/progs/fish/fish-edit.scm new file mode 100644 index 0000000000..972d37711c --- /dev/null +++ b/TeXmacs/plugins/fish/progs/fish/fish-edit.scm @@ -0,0 +1,229 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; MODULE : fish-edit.scm +;; DESCRIPTION : editing fish programs +;; COPYRIGHT : (C) 2025 vesita +;; +;; This software falls under the GNU general public license version 3 or later. +;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE +;; in the root directory or . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(texmacs-module (fish fish-edit) (:use (prog prog-edit) (fish fish-mode))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Indentation policy +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(tm-define (fish-tabstop) 4) + +(tm-define (get-tabstop) (:mode in-prog-fish?) (fish-tabstop)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Helpers +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define fish-block-openers + '("case" "command" "define" "else" "for" "foreach" "if" "loop" "section" + "struct" "structure" "while") +) ;define + +(define fish-block-closers + '("end" "end_if" "endif" "end_loop" "end_section" "endcase" "endcommand" + "endloop" "endsection") +) ;define + +(define fish-block-middle '("case" "else")) + +(define (fish-word-in? w lst) + (cond ((null? lst) #f) + ((== w (car lst)) #t) + (else (fish-word-in? w (cdr lst))) + ) ;cond +) ;define + +(define (fish-string-prefix? s p) + (and (>= (string-length s) (string-length p)) + (== (substring s 0 (string-length p)) p) + ) ;and +) ;define + +(define (fish-trim-left s) + (let loop + ((i 0) (n (string-length s))) + (if (or (>= i n) (not (char-whitespace? (string-ref s i)))) + (substring s i n) + (loop (+ i 1) n) + ) ;if + ) ;let +) ;define + +(define (fish-trim-right s) + (let loop + ((i (- (string-length s) 1))) + (if (< i 0) + "" + (if (char-whitespace? (string-ref s i)) (loop (- i 1)) (substring s 0 (+ i 1))) + ) ;if + ) ;let +) ;define + +(define (fish-trim s) + (fish-trim-right (fish-trim-left s)) +) ;define + +(define (fish-word-char? c) + (or (char-alphabetic? c) (char-numeric? c) (== c #\_)) +) ;define + +(define (fish-first-word s) + (let* ((t (fish-trim-left s)) (n (string-length t))) + (let loop + ((i 0)) + (if (or (>= i n) (not (fish-word-char? (string-ref t i)))) + (if (<= i 0) "" (substring t 0 i)) + (loop (+ i 1)) + ) ;if + ) ;let + ) ;let* +) ;define + +(define (fish-line-continues? line) + (let* ((t (fish-trim-right line)) (n (string-length t))) + (and (> n 0) + (or (and (>= n 3) (== (substring t (- n 3) n) "...")) + (== (string-ref t (- n 1)) #\&) + ) ;or + ) ;and + ) ;let* +) ;define + +(define (fish-line-opens-block? line) + (let* ((t (fish-trim line)) (w (fish-first-word t))) + (or (and (!= w "") (or (fish-word-in? w fish-block-openers) (== w "caseof"))) + (fish-string-prefix? t "if ") + (== t "if") + (fish-string-prefix? t "else if ") + (and (or (fish-string-prefix? t "if ") + (fish-string-prefix? t "else if ") + (fish-string-prefix? t "caseof ") + ) ;or + (or (== t "then") + (fish-string-prefix? t "then ") + (and (>= (string-length t) 4) + (== (substring t (- (string-length t) 4) (string-length t)) "then") + ) ;and + ) ;or + ) ;and + ) ;or + ) ;let* +) ;define + +(define (fish-line-starts-with-outdent? line) + (let ((w (fish-first-word line))) + (or (fish-word-in? w fish-block-closers) (fish-word-in? w fish-block-middle)) + ) ;let +) ;define + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Line access +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (fish-get-line row) + (let ((s (program-row row))) + (if s s "") + ) ;let +) ;define + +(define (fish-prev-nonempty-row row) + (let loop + ((r (- row 1))) + (if (< r 0) + -1 + (let* ((line (fish-get-line r)) (t (fish-trim line))) + (if (== t "") (loop (- r 1)) r) + ) ;let* + ) ;if + ) ;let +) ;define + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Indentation computation +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (fish-indent-level-from-prev row) + (let* ((pr (fish-prev-nonempty-row row))) + (if (< pr 0) + 0 + (let* ((pline (fish-get-line pr)) + (base (string-get-indent pline)) + (tab (get-tabstop)) + (inc? (or (fish-line-continues? pline) (fish-line-opens-block? pline))) + ) ; + (+ base (if inc? tab 0)) + ) ;let* + ) ;if + ) ;let* +) ;define + +(tm-define (program-compute-indentation doc row col) + (:mode in-prog-fish?) + (let* ((tab (get-tabstop)) + (line (fish-get-line row)) + (base (fish-indent-level-from-prev row)) + ) ; + (if (fish-line-starts-with-outdent? line) (max 0 (- base tab)) base) + ) ;let* +) ;tm-define + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Commenting +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(tm-define (program-comment-start) (:mode in-prog-fish?) ";") + +(tm-define (program-toggle-comment) + (:mode in-prog-fish?) + (prog-toggle-line-comment ";") +) ;tm-define + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Paste import hook +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(tm-define (kbd-paste) + (:mode in-prog-fish?) + (clipboard-paste-import "fish" "primary") +) ;tm-define + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Brackets / quotes +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(tm-define (fish-bracket-open lbr rbr) (bracket-open lbr rbr "\\")) + +(tm-define (fish-bracket-close lbr rbr) (bracket-close lbr rbr "\\")) + +(tm-define (notify-cursor-moved status) + (:require prog-highlight-brackets?) + (:mode in-prog-fish?) + (select-brackets-after-movement "([{" ")]}" "\\") +) ;tm-define + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Keyboard mappings +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(kbd-map (:mode in-prog-fish?) + ("A-tab" (insert-tabstop)) + ("cmd S-tab" (remove-tabstop)) + ("{" (fish-bracket-open "{" "}")) + ("}" (fish-bracket-close "{" "}")) + ("(" (fish-bracket-open "(" ")")) + (")" (fish-bracket-close "(" ")")) + ("[" (fish-bracket-open "[" "]")) + ("]" (fish-bracket-close "[" "]")) + ("\"" (fish-bracket-open "\"" "\"")) + ("'" (fish-bracket-open "'" "'")) +) ;kbd-map diff --git a/TeXmacs/plugins/fish/progs/fish/fish-format.scm b/TeXmacs/plugins/fish/progs/fish/fish-format.scm new file mode 100644 index 0000000000..a07c3df1c8 --- /dev/null +++ b/TeXmacs/plugins/fish/progs/fish/fish-format.scm @@ -0,0 +1,39 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; MODULE : fish.scm +;; DESCRIPTION : prog format for fish +;; COPYRIGHT : (C) 2022-2025 Darcy Shen, Joris van der Hoeven +;; +;; This software falls under the GNU general public license version 3 or later. +;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE +;; in the root directory or . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(texmacs-module (fish fish-format)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; FISH source files +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-format fish (:name "FISH source code") (:suffix "fis" "FIS")) + +(define (texmacs->fish x . opts) + (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '())) +) ;define + +(define (fish->texmacs x . opts) + (code->texmacs x) +) ;define + +(define (fish-snippet->texmacs x . opts) + (code-snippet->texmacs x) +) ;define + +(converter texmacs-tree fish-document (:function texmacs->fish)) + +(converter fish-document texmacs-tree (:function fish->texmacs)) + +(converter texmacs-tree fish-snippet (:function texmacs->fish)) + +(converter fish-snippet texmacs-tree (:function fish-snippet->texmacs)) diff --git a/TeXmacs/plugins/fish/progs/fish/fish-lang.scm b/TeXmacs/plugins/fish/progs/fish/fish-lang.scm new file mode 100644 index 0000000000..12af3166b8 --- /dev/null +++ b/TeXmacs/plugins/fish/progs/fish/fish-lang.scm @@ -0,0 +1,159 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; MODULE : fish-lang.scm +;; DESCRIPTION : fish language support +;; COPYRIGHT : (C) 2025 veista +;; +;; This software falls under the GNU general public license version 3 or later. +;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE +;; in the root directory or . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(texmacs-module (fish fish-lang) (:use (prog default-lang))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Parser Features +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(tm-define (parser-feature lan key) + (:require (and (== lan "fish") (== key "keyword"))) + `(,(string->symbol key) + ;; Built-in names may contain underscores and official dotted namespaces. + (extra_chars "_" ".") + (constant "false" "true" "null") + (declare_function "define" "code.name" "creep.active" "creep.cycle" + "creep.safety.factor" "creep.solve" "creep.step" "creep.time.total" + "creep.timestep" "creep.timestep.given" "creep.timestep.max" + "dynamic.active" "dynamic.cycle" "dynamic.safety.factor" "dynamic.solve" + "dynamic.step" "dynamic.time.total" "dynamic.timestep" + "dynamic.timestep.given" "dynamic.timestep.max" "file.all" "file.close" + "file.delete" "file.end" "file.exist" "file.name" "file.open" + "file.open.check" "file.pos" "file.read" "file.rename" "file.size" + "file.write" "fluid.active" "fluid.cycle" "fluid.safety.factor" + "fluid.solve" "fluid.step" "fluid.time.total" "fluid.timestep" + "fluid.timestep.given" "fluid.timestep.max" "global.cycle" + "global.deterministic" "global.dim" "global.fos" "global.gravity" + "global.step" "global.threads" "global.timestep" "global.title" + "io.dialog.in" "io.dialog.message" "io.dialog.notify" "io.in" "io.input" + "io.out" "mail.account" "mail.attachment.add" "mail.attachment.delete" + "mail.body" "mail.clear" "mail.domain" "mail.from" "mail.host" + "mail.password" "mail.port" "mail.recipient.add" "mail.recipient.delete" + "mail.send" "mail.subject" "math.aangle.to.euler" "math.abs" "math.acos" + "math.and" "math.area.intersect.poly.poly" "math.area.poly" "math.asin" + "math.atan" "math.atan2" "math.bound" "math.ceiling" "math.choose" + "math.closest.segment.point" "math.closest.triangle.point" "math.cos" + "math.cosh" "math.cross" "math.cyl.bessel.i" "math.ddir.from.normal" + "math.degrad" "math.dip.from.normal" "math.dist.segment.point" + "math.dist.segment.segment" "math.dist.triangle.segment" "math.dot" + "math.erf" "math.erfc" "math.euler.to.aangle" "math.exp" "math.expint" + "math.floor" "math.gamma" "math.in.range" "math.isinf" "math.isnan" + "math.ln" "math.log" "math.lshift" "math.mag" "math.mag2" "math.max" + "math.min" "math.normal.from.dip" "math.normal.from.dip.ddir" "math.not" + "math.or" "math.outer.product" "math.pi" "math.random.gauss" + "math.random.uniform" "math.round" "math.rshift" "math.sgn" "math.sin" + "math.sinh" "math.sqrt" "math.tan" "math.tanh" "math.triangle.inside" + "math.triangle.interp" "math.unit" "mech.active" "mech.cycle" + "mech.safety.factor" "mech.solve" "mech.step" "mech.time.total" + "mech.timestep" "mech.timestep.given" "mech.timestep.max" "socket.close" + "socket.create" "socket.delete" "socket.open" "socket.read" + "socket.read.array" "socket.write" "socket.write.array" "system.beep" + "system.clone" "system.command" "system.directory" + "system.directory.absolute" "system.directory.create" + "system.directory.current" "system.directory.delete" + "system.directory.list" "system.directory.relative" "system.environment" + "system.error" "system.os" "system.sleep" "thermal.active" "thermal.cycle" + "thermal.safety.factor" "thermal.solve" "thermal.step" + "thermal.time.total" "thermal.timestep" "thermal.timestep.given" + "thermal.timestep.max" "time.clock" "time.cpu" "time.kernel" "time.real" + "array.copy" "array.delete" "array.dim" "array.size" "list.append" + "list.at" "list.concatenate" "list.count" "list.create" "list.extend" + "list.find.index" "list.insert" "list.insert.list" "list.max" "list.min" + "list.prepend" "list.range" "list.resize" "list.reverse" "list.separate" + "list.sequence" "list.size" "list.sort" "list.sum" "map.add" + "map.add.list" "map.has" "map.keys" "map.merge" "map.remove" "map.size" + "map.value" "map.value.all" "matrix.cols" "matrix.det" + "matrix.from.axis.angle" "matrix.from.euler" "matrix.identity" + "matrix.inverse" "matrix.lubksb" "matrix.ludcmp" "matrix.rows" + "matrix.to.axis.angle" "matrix.to.euler" "matrix.transpose" "memory" + "memory.create" "memory.delete" "memory.fortran.float" + "memory.fortran.index" "memory.fortran.integer" "memory.offset" + "memory.size" "string.build" "string.compare" "string.csv.from" + "string.csv.to" "string.file.ext" "string.file.name" "string.file.path" + "string.find" "string.find.regex" "string.join" "string.len" + "string.lower" "string.match.regex" "string.replace" + "string.replace.regex" "string.simplify" "string.split" + "string.split.regex" "string.sub" "string.token" "string.token.type" + "string.type" "string.upper" "structure.check" "structure.from.map" + "structure.name" "tensor.i2" "tensor.j2" "tensor.prin" "tensor.prin.dir" + "tensor.prin.from" "tensor.total" "tensor.trace" "type" "type.index" + "type.name" "type.pointer" "type.pointer.id" "type.pointer.name" + "version.code.major" "version.code.minor" "version.fish.major" + "version.fish.minor") + (declare_type "array" "boolean" "float" "index" "int" "list" "map" "matrix" + "string" "struct" "structure" "tensor" "vector") + (declare_identifier "global" "local") + (declare_module "creep" "dynamic" "file" "fluid" "io" "mail" "math" "mech" + "socket" "system" "thermal" "time") + ;; Lightweight approximation for command/endcommand blocks. + (keyword "call" "fish" "history" "model" "new" "program" "restore" "save" + "solve") + (keyword_conditional "case" "caseof" "else" "endcase" "end_if" "endif" "if" + "then") + (keyword_control "command" "continue" "end_loop" "end_section" "endcommand" + "endloop" "endsection" "exit" "exit_loop" "exit_section" "foreach" "for" + "lock" "loop" "return" "section" "while")) +) ;tm-define + +(tm-define (parser-feature lan key) + (:require (and (== lan "fish") (== key "operator"))) + `(,(string->symbol key) + (operator "^" "/" "//" "*" "%" "-" "+" "==" ">" "<" "#" ">=" "<=" "&" "|") + (operator_special "~" "and" "or" "not" "," "::" "=::" "+=::" "-=::" "*=::" + "/=::") + (operator_field "->" "=" "+=" "-=" "*=" "/=") + (operator_openclose "(" ")" "[" "]")) +) ;tm-define + +(tm-define (parser-feature lan key) + (:require (and (== lan "fish") (== key "number"))) + `(,(string->symbol key) (bool_features "sci_notation")) +) ;tm-define + +(tm-define (parser-feature lan key) + (:require (and (== lan "fish") (== key "string"))) + `(,(string->symbol key) (escape_sequences "\\" "\"" "'" "b" "t" "r" "n")) +) ;tm-define + +(tm-define (parser-feature lan key) + (:require (and (== lan "fish") (== key "comment"))) + `(,(string->symbol key) (inline ";")) +) ;tm-define + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Preferences for syntax highlighting +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (notify-fish-syntax var val) + (syntax-read-preferences "fish") +) ;define + +(define-preferences ("syntax:fish:none" "red" notify-fish-syntax) + ("syntax:fish:comment" "brown" notify-fish-syntax) + ("syntax:fish:error" "dark red" notify-fish-syntax) + ("syntax:fish:constant" "#4040c0" notify-fish-syntax) + ("syntax:fish:constant_number" "#4040c0" notify-fish-syntax) + ("syntax:fish:constant_string" "dark grey" notify-fish-syntax) + ("syntax:fish:constant_char" "#333333" notify-fish-syntax) + ("syntax:fish:declare_function" "#0000c0" notify-fish-syntax) + ("syntax:fish:declare_type" "#0000c0" notify-fish-syntax) + ("syntax:fish:declare_module" "#0000c0" notify-fish-syntax) + ("syntax:fish:declare_identifier" "#0000c0" notify-fish-syntax) + ("syntax:fish:operator" "#8b008b" notify-fish-syntax) + ("syntax:fish:operator_openclose" "#B02020" notify-fish-syntax) + ("syntax:fish:operator_field" "#B02020" notify-fish-syntax) + ("syntax:fish:operator_special" "orange" notify-fish-syntax) + ("syntax:fish:keyword" "#309090" notify-fish-syntax) + ("syntax:fish:keyword_conditional" "#309090" notify-fish-syntax) + ("syntax:fish:keyword_control" "#309090" notify-fish-syntax) +) ;define-preferences diff --git a/TeXmacs/plugins/fish/progs/code/fish-mode.scm b/TeXmacs/plugins/fish/progs/fish/fish-mode.scm similarity index 78% rename from TeXmacs/plugins/fish/progs/code/fish-mode.scm rename to TeXmacs/plugins/fish/progs/fish/fish-mode.scm index 90bd3908c6..bbf4b979d9 100644 --- a/TeXmacs/plugins/fish/progs/code/fish-mode.scm +++ b/TeXmacs/plugins/fish/progs/fish/fish-mode.scm @@ -10,11 +10,8 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(texmacs-module (code fish-mode) - (:use (kernel texmacs tm-modes)) -) ;texmacs-module +(texmacs-module (fish fish-mode) (:use (kernel texmacs tm-modes))) -(texmacs-modes - (in-fish% (== (get-env "prog-language") "fish")) +(texmacs-modes (in-fish% (== (get-env "prog-language") "fish")) (in-prog-fish% #t in-prog% in-fish%) ) ;texmacs-modes diff --git a/TeXmacs/plugins/gnome/progs/init-gnome.scm b/TeXmacs/plugins/gnome/progs/init-gnome.scm new file mode 100644 index 0000000000..0c4559882c --- /dev/null +++ b/TeXmacs/plugins/gnome/progs/init-gnome.scm @@ -0,0 +1,64 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; MODULE : init-gnome.scm +;; DESCRIPTION : Initialize the 'gnome' plugin (Gnome look and feel keymap) +;; COPYRIGHT : (C) 1999 Joris van der Hoeven +;; +;; This software falls under the GNU general public license version 3 or later. +;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE +;; in the root directory or . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(when (like-gnome?) + (kbd-map (:profile gnome) + + ;; standard Gnome shortcuts + ("gnome d" (remove-text #t)) + ("gnome h" (interactive-replace)) + ("gnome k" (kill-paragraph)) + ("gnome left" (traverse-left)) + ("gnome right" (traverse-right)) + ("gnome home" (go-start)) + ("gnome end" (go-end)) + ("gnome S-left" (kbd-select traverse-left)) + ("gnome S-right" (kbd-select traverse-right)) + ("gnome S-home" (kbd-select go-start)) + ("gnome S-end" (kbd-select go-end)) + + ("search F3" (search-next-match #t)) + ("search S-F3" (search-next-match #f)) + ("search gnome g" (search-next-match #t)) + ("search gnome G" (search-next-match #f)) + + ;; not yet implemented + ;; ("gnome delete" (delete-end-word)) + ;; ("gnome backspace" (delete-start-word)) + ;; ("forward" (next-tab)) + ;; ("back" (previous-tab)) + + ;; further shortcuts for Gnome look and feel + ("gnome g" (selection-cancel)) + ("gnome l" (refresh-window)) + ("gnome F" (interactive-search)) + + ("cmd q" (make 'symbol)) + ("altcmd g" (kbd-cancel)) + ("altcmd x" (interactive footer-eval)) + ("A-x" (interactive exec-interactive-command)) + ("altcmd $" (interactive-spell)) + + ("C-P" (toggle-preamble-mode)) + ("C-O" (toggle-source-mode)) + + ("structured:cmd left" (kbd-select-if-active traverse-left)) + ("structured:cmd right" (kbd-select-if-active traverse-right)) + ) ;kbd-map + + (kbd-map (:profile gnome) + (:require (and (not (in-prog?)) (not (in-verbatim?)))) + ("M-space" (make-space "0.2spc")) + ("M-S-space" (make-space "-0.2spc")) + ) ;kbd-map +) ;when diff --git a/TeXmacs/plugins/gnuplot/goldfish/tm-gnuplot.scm b/TeXmacs/plugins/gnuplot/goldfish/tm-gnuplot.scm index 0ace6c98bc..7bec063d16 100644 --- a/TeXmacs/plugins/gnuplot/goldfish/tm-gnuplot.scm +++ b/TeXmacs/plugins/gnuplot/goldfish/tm-gnuplot.scm @@ -58,49 +58,27 @@ ) ;define (define (gen-pdf-precode pdf-path) - (string-append "reset\n" - "set terminal pdfcairo enhanced\n" - "set output\n" - "set output '" - pdf-path - "'\n" - "set size 1,1\n" - "set autoscale\n" + (string-append "reset\n" "set terminal pdfcairo enhanced\n" "set output\n" + "set output '" pdf-path "'\n" "set size 1,1\n" "set autoscale\n" ) ;string-append ) ;define (define (gen-eps-precode eps-path) - (string-append "reset\n" - "set terminal postscript eps enhanced\n" - "set output\n" - "set output '" - eps-path - "'\n" - "set size 1,1\n" + (string-append "reset\n" "set terminal postscript eps enhanced\n" + "set output\n" "set output '" eps-path "'\n" "set size 1,1\n" "set autoscale\n" ) ;string-append ) ;define (define (gen-png-precode png-path) - (string-append "reset\n" - "set terminal pngcairo enhanced\n" - "set output\n" - "set output '" - png-path - "'\n" - "set size 1,1\n" + (string-append "reset\n" "set terminal pngcairo enhanced\n" "set output\n" + "set output '" png-path "'\n" "set size 1,1\n" ) ;string-append ) ;define (define (gen-svg-precode svg-path) - (string-append "reset\n" - "set terminal svg enhanced\n" - "set output\n" - "set output '" - svg-path - "'\n" - "set size 1,1\n" - "set autoscale\n" + (string-append "reset\n" "set terminal svg enhanced\n" "set output\n" + "set output '" svg-path "'\n" "set size 1,1\n" "set autoscale\n" ) ;string-append ) ;define diff --git a/TeXmacs/plugins/gnuplot/packages/code/gnuplot.stem b/TeXmacs/plugins/gnuplot/packages/code/gnuplot.stem new file mode 100644 index 0000000000..e107345881 --- /dev/null +++ b/TeXmacs/plugins/gnuplot/packages/code/gnuplot.stem @@ -0,0 +1,31 @@ +(document (TeXmacs "2.1.2") + (style (tuple "source" "std")) + (body (document (active* (src-title (document (compound "src-package" "gnuplot" "1.0") + (src-purpose (document "gnuplot Language")) + (src-copyright "2024" "Darcy Shen") + (src-license (document (concat "This software falls under the " + (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE") + ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see " + (hlink "http://www.gnu.org/licenses/gpl-3.0.html" + "http://www.gnu.org/licenses/gpl-3.0.html" + ) ;hlink + "." + ) ;concat + ) ;document + ) ;src-license + ) ;document + ) ;src-title + ) ;active* + (use-module "(gnuplot gnuplot-format)") + (assign "gnuplot" + (macro "body" + (with "mode" "prog" "prog-language" "gnuplot" "font-family" "rm" (arg "body")) + ) ;macro + ) ;assign + (assign "gnuplot-code" + (macro "body" (document (pseudo-code (document (gnuplot (arg "body")))))) + ) ;assign + ) ;document + ) ;body + (initial (collection (associate "preamble" "true") (associate "sfactor" "5"))) +) ;document diff --git a/TeXmacs/plugins/gnuplot/packages/code/gnuplot.ts b/TeXmacs/plugins/gnuplot/packages/code/gnuplot.ts deleted file mode 100644 index 437a52889d..0000000000 --- a/TeXmacs/plugins/gnuplot/packages/code/gnuplot.ts +++ /dev/null @@ -1,40 +0,0 @@ - - -> - -<\body> - - - - <\src-purpose> - gnuplot Language - - - - - <\src-license> - This software falls under the . It comes WITHOUT ANY - WARRANTY WHATSOEVER. You should have received a copy of the license - which the software. If not, see . - - > - - - - >>> - - - <\pseudo-code> - > - - > - - -<\initial> - <\collection> - - - - - diff --git a/TeXmacs/plugins/gnuplot/progs/binary/gnuplot.scm b/TeXmacs/plugins/gnuplot/progs/binary/gnuplot.scm deleted file mode 100644 index 9cb2fdc163..0000000000 --- a/TeXmacs/plugins/gnuplot/progs/binary/gnuplot.scm +++ /dev/null @@ -1,34 +0,0 @@ - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : gnuplot.scm -;; DESCRIPTION : gnuplot Binary plugin -;; COPYRIGHT : (C) 2024 Darcy Shen -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (binary gnuplot) (:use (binary common))) - -(define (gnuplot-binary-candidates) - (cond ((os-macos?) (list "/opt/homebrew/bin/gnuplot" "/usr/local/bin/gnuplot")) - ((os-win32?) - (list "C:\\Program Files*\\gnuplot\\bin\\gnuplot.exe" - "$USERPROFILE\\scoop\\apps\\gnuplot\\current\\bin\\gnuplot.exe" - ) ;list - ) ; - (else (list "/usr/bin/gnuplot")) - ) ;cond -) ;define - -(tm-define (find-binary-gnuplot) - (:synopsis "Find the url to the gnuplot binary, return (url-none) if not found") - (find-binary (gnuplot-binary-candidates) "gnuplot") -) ;tm-define - -(tm-define (has-binary-gnuplot?) (not (url-none? (find-binary-gnuplot)))) - -(tm-define (version-binary-gnuplot) (version-binary (find-binary-gnuplot))) diff --git a/TeXmacs/plugins/gnuplot/progs/data/gnuplot.scm b/TeXmacs/plugins/gnuplot/progs/data/gnuplot.scm deleted file mode 100644 index 89120f90dd..0000000000 --- a/TeXmacs/plugins/gnuplot/progs/data/gnuplot.scm +++ /dev/null @@ -1,36 +0,0 @@ - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : gnuplot.scm -;; DESCRIPTION : prog format for Gnuplot -;; COPYRIGHT : (C) 2024 Darcy Shen -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (data gnuplot)) - -(define-format gnuplot (:name "Gnuplot Source Code") (:suffix "gp")) - -(define (texmacs->gnuplot x . opts) - (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '())) -) ;define - -(define (gnuplot->texmacs x . opts) - (code->texmacs x) -) ;define - -(define (gnuplot-snippet->texmacs x . opts) - (code-snippet->texmacs x) -) ;define - -(converter texmacs-tree gnuplot-document (:function texmacs->gnuplot)) - -(converter gnuplot-document texmacs-tree (:function gnuplot->texmacs)) - -(converter texmacs-tree gnuplot-snippet (:function texmacs->gnuplot)) - -(converter gnuplot-snippet texmacs-tree (:function gnuplot-snippet->texmacs)) diff --git a/TeXmacs/plugins/gnuplot/progs/gnuplot/gnuplot-binary.scm b/TeXmacs/plugins/gnuplot/progs/gnuplot/gnuplot-binary.scm new file mode 100644 index 0000000000..02e25a60a6 --- /dev/null +++ b/TeXmacs/plugins/gnuplot/progs/gnuplot/gnuplot-binary.scm @@ -0,0 +1,34 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; MODULE : gnuplot.scm +;; DESCRIPTION : gnuplot Binary plugin +;; COPYRIGHT : (C) 2024 Darcy Shen +;; +;; This software falls under the GNU general public license version 3 or later. +;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE +;; in the root directory or . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(texmacs-module (gnuplot gnuplot-binary) (:use (binary common))) + +(define (gnuplot-binary-candidates) + (cond ((os-macos?) (list "/opt/homebrew/bin/gnuplot" "/usr/local/bin/gnuplot")) + ((os-windows?) + (list "C:\\Program Files*\\gnuplot\\bin\\gnuplot.exe" + "$USERPROFILE\\scoop\\apps\\gnuplot\\current\\bin\\gnuplot.exe" + ) ;list + ) ; + (else (list "/usr/bin/gnuplot")) + ) ;cond +) ;define + +(tm-define (find-binary-gnuplot) + (:synopsis "Find the url to the gnuplot binary, return (url-none) if not found") + (find-binary (gnuplot-binary-candidates) "gnuplot") +) ;tm-define + +(tm-define (has-binary-gnuplot?) (not (url-none? (find-binary-gnuplot)))) + +(tm-define (version-binary-gnuplot) (version-binary (find-binary-gnuplot))) diff --git a/TeXmacs/plugins/gnuplot/progs/gnuplot/gnuplot-format.scm b/TeXmacs/plugins/gnuplot/progs/gnuplot/gnuplot-format.scm new file mode 100644 index 0000000000..83d2462edc --- /dev/null +++ b/TeXmacs/plugins/gnuplot/progs/gnuplot/gnuplot-format.scm @@ -0,0 +1,36 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; MODULE : gnuplot.scm +;; DESCRIPTION : prog format for Gnuplot +;; COPYRIGHT : (C) 2024 Darcy Shen +;; +;; This software falls under the GNU general public license version 3 or later. +;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE +;; in the root directory or . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(texmacs-module (gnuplot gnuplot-format)) + +(define-format gnuplot (:name "Gnuplot Source Code") (:suffix "gp")) + +(define (texmacs->gnuplot x . opts) + (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '())) +) ;define + +(define (gnuplot->texmacs x . opts) + (code->texmacs x) +) ;define + +(define (gnuplot-snippet->texmacs x . opts) + (code-snippet->texmacs x) +) ;define + +(converter texmacs-tree gnuplot-document (:function texmacs->gnuplot)) + +(converter gnuplot-document texmacs-tree (:function gnuplot->texmacs)) + +(converter texmacs-tree gnuplot-snippet (:function texmacs->gnuplot)) + +(converter gnuplot-snippet texmacs-tree (:function gnuplot-snippet->texmacs)) diff --git a/TeXmacs/plugins/gnuplot/progs/code/gnuplot-lang.scm b/TeXmacs/plugins/gnuplot/progs/gnuplot/gnuplot-lang.scm similarity index 92% rename from TeXmacs/plugins/gnuplot/progs/code/gnuplot-lang.scm rename to TeXmacs/plugins/gnuplot/progs/gnuplot/gnuplot-lang.scm index 7fcc409f6f..343575dfa0 100644 --- a/TeXmacs/plugins/gnuplot/progs/code/gnuplot-lang.scm +++ b/TeXmacs/plugins/gnuplot/progs/gnuplot/gnuplot-lang.scm @@ -11,7 +11,7 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(texmacs-module (code gnuplot-lang) (:use (prog default-lang))) +(texmacs-module (gnuplot gnuplot-lang) (:use (prog default-lang))) (tm-define (parser-feature lan key) (:require (and (== lan "gnuplot") (== key "keyword"))) diff --git a/TeXmacs/plugins/gnuplot/progs/init-gnuplot.scm b/TeXmacs/plugins/gnuplot/progs/init-gnuplot.scm index dbe0b5278e..721f8666ff 100644 --- a/TeXmacs/plugins/gnuplot/progs/init-gnuplot.scm +++ b/TeXmacs/plugins/gnuplot/progs/init-gnuplot.scm @@ -11,64 +11,57 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-library (session gnuplot) - (import (scheme base) (liii list)) - (export init-gnuplot) - (begin - (use-modules (binary gnuplot) (binary goldfish) (binary gs)) +(use-modules (gnuplot gnuplot-binary) (binary goldfish) (binary gs)) - (lazy-format (data gnuplot) gnuplot) +(lazy-format (gnuplot gnuplot-format) gnuplot) - (define (gnuplot-serialize lan t) - (let* ((u (pre-serialize lan t)) (s (texmacs->utf8raw (stree->tree u)))) - (string-append s "\n\n") - ) ;let* - ) ;define +(define (gnuplot-serialize lan t) + (let* ((u (pre-serialize lan t)) (s (texmacs->utf8raw (stree->tree u)))) + (string-append s "\n\n") + ) ;let* +) ;define - (define (gen-launcher image-format) - (string-append (string-quote (url->system (find-binary-goldfish))) - " " - "load" - " " - (string-quote (string-append (url->system (get-texmacs-path)) - "/plugins/gnuplot/goldfish/tm-gnuplot.scm" - ) ;string-append - ) ;string-quote - " " - (string-quote (url->system (find-binary-gnuplot))) - " " - image-format - ) ;string-append - ) ;define +(define (gen-launcher image-format) + (string-append (string-quote (url->system (find-binary-goldfish))) + " " + "load" + " " + (string-quote (string-append (url->system (get-texmacs-path)) + "/plugins/gnuplot/goldfish/tm-gnuplot.scm" + ) ;string-append + ) ;string-quote + " " + (string-quote (url->system (find-binary-gnuplot))) + " " + image-format + ) ;string-append +) ;define - (define (gnuplot-launchers) - (let ((l (list (list :launch "pdf" (gen-launcher "pdf")) - (list :launch "svg" (gen-launcher "svg")) - (list :launch "png" (gen-launcher "png")) - ) ;list - ) ;l - ) ; - (if (has-binary-gs?) - (append l (list (list :launch "eps" (gen-launcher "eps")))) - l - ) ;if - ) ;let - ) ;define +(define (gnuplot-launchers) + (let ((l (list (list :launch "pdf" (gen-launcher "pdf")) + (list :launch "svg" (gen-launcher "svg")) + (list :launch "png" (gen-launcher "png")) + ) ;list + ) ;l + ) ; + (if (has-binary-gs?) + (append l (list (list :launch "eps" (gen-launcher "eps")))) + l + ) ;if + ) ;let +) ;define - (define (all-gnuplot-launchers) - (cons (list :launch (gen-launcher "pdf")) (gnuplot-launchers)) - ) ;define +(define (all-gnuplot-launchers) + (cons (list :launch (gen-launcher "pdf")) (gnuplot-launchers)) +) ;define - (define (init-gnuplot) - (plugin-configure gnuplot - (:require (and (has-binary-goldfish?) (has-binary-gnuplot?))) - ,(#_apply-values (all-gnuplot-launchers)) - (:serializer ,gnuplot-serialize) - (:session "Gnuplot") - ) ;plugin-configure - ) ;define - ) ;begin -) ;define-library +(define (init-gnuplot) + (plugin-configure gnuplot + (:require (and (has-binary-goldfish?) (has-binary-gnuplot?))) + ,@(all-gnuplot-launchers) + (:serializer ,gnuplot-serialize) + (:session "Gnuplot") + ) ;plugin-configure +) ;define -(import (session gnuplot)) (init-gnuplot) diff --git a/TeXmacs/plugins/goldfish/goldfish/goldfish/repl.scm b/TeXmacs/plugins/goldfish/goldfish/goldfish/repl.scm index edaad93dc7..a37e9ef1d2 100644 --- a/TeXmacs/plugins/goldfish/goldfish/goldfish/repl.scm +++ b/TeXmacs/plugins/goldfish/goldfish/goldfish/repl.scm @@ -7,7 +7,7 @@ (liii base) (scheme char) ) ;import - (export goldfish-welcome goldfish-repl is-sicp-mode?) + (export goldfish-welcome goldfish-repl) (begin (define (goldfish-welcome) diff --git a/TeXmacs/plugins/goldfish/goldfish/guenchi/json.scm b/TeXmacs/plugins/goldfish/goldfish/guenchi/json.scm deleted file mode 100644 index 65a87059ed..0000000000 --- a/TeXmacs/plugins/goldfish/goldfish/guenchi/json.scm +++ /dev/null @@ -1,640 +0,0 @@ -;; MIT License -;; Copyright guenchi (c) 2018 - 2019 -;; Da Shen (c) 2024 - 2025 -;; (Jack) Yansong Li (c) 2025 -;; 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-library (guenchi json) - (import (liii base) - (liii chez) - (liii alist) - (liii error) - (liii list) - (liii string) - (liii unicode) - ) ;import - (export json-string-escape - json-string-unescape - string->json - json->string - json-ref - json-ref* - json-set - json-set* - json-push - json-push* - json-drop - json-drop* - json-reduce - json-reduce* - ) ;export - (begin - - (define (json-string-escape str) - (let ((out (open-output-string))) - (write-char #\" out) - (let* ((bv (string->utf8 str)) (len (bytevector-length bv))) - (let loop - ((i 0)) - (if (>= i len) - (begin - (write-char #\" out) - (get-output-string out) - ) ;begin - (let ((next (bytevector-advance-utf8 bv i len))) - (cond ((= next i) (loop (+ i 1))) - ((= next (+ i 1)) - (let ((c (integer->char (bytevector-u8-ref bv i)))) - (case c - ((#\") (display "\\\"" out)) - ((#\\) (display "\\\\" out)) - ((#\/) (display "\\/" out)) - ((#\backspace) (display "\\b" out)) - ((#\xc) (display "\\f" out)) - ((#\newline) (display "\\n" out)) - ((#\return) (display "\\r" out)) - ((#\tab) (display "\\t" out)) - (else (write-char c out)) - ) ;case - (loop next) - ) ;let - ) ; - (else - ;; 多字节 UTF-8 字符，直接输出原始字节 - (display (copy bv (make-string (- next i)) i next) out) - (loop next) - ) ;else - ) ;cond - ) ;let - ) ;if - ) ;let - ) ;let* - ) ;let - ) ;define - - (define (string-length-sum strings) - (let loop - ((o 0) (rest strings)) - (cond ((eq? '() rest) o) - (else (loop (+ o (string-length (car rest))) (cdr rest))) - ) ;cond - ) ;let - ) ;define - - (define (fast-string-list-append strings) - (let* ((output-length (string-length-sum strings)) - (output (make-string output-length #\_)) - (fill 0) - ) ; - (let outer - ((rest strings)) - (cond ((eq? '() rest) output) - (else (let* ((s (car rest)) (n (string-length s))) - (let inner - ((i 0)) - (cond ((= i n) 'done) - (else (string-set! output fill (string-ref s i)) - (set! fill (+ fill 1)) - (inner (+ i 1)) - ) ;else - ) ;cond - ) ;let - ) ;let* - (outer (cdr rest)) - ) ;else - ) ;cond - ) ;let - ) ;let* - ) ;define - - (define (handle-escape-char s end len) - (let ((next-char (if (< (+ end 1) len) (string-ref s (+ end 1)) #f))) - (case next-char - ((#\") (values "\\\"" 2)) - ((#\\) (values "\\\\" 2)) - ((#\/) (values "/" 2)) - ((#\b) (values "\\b" 2)) - ((#\f) (values "\\f" 2)) - ((#\n) (values "\\n" 2)) - ((#\r) (values "\\r" 2)) - ((#\t) (values "\\t" 2)) - ((#\u) - (let ((start-pos (+ end 2)) (end-pos (+ end 6))) - (if (and (>= start-pos 0) (< end-pos len)) - (let ((hex-str (substring s start-pos end-pos))) - (let ((code-point (string->number hex-str 16))) - (when (not code-point) - (error 'parse-error (string-append "Invalid HEX sequence " hex-str)) - ) ;when - ;; 检查是否存在连续的两个 \u - (let ((next-u-pos (+ end 6))) - (if (and (< (+ next-u-pos 6) len) - (char=? (string-ref s next-u-pos) #\\) - (char=? (string-ref s (+ next-u-pos 1)) #\u) - ) ;and - ;; 存在连续的两个 \u - (let ((next-hex-str (substring s (+ next-u-pos 2) (+ next-u-pos 6)))) - (let ((next-code-point (string->number next-hex-str 16))) - (when (not next-code-point) - (error 'parse-error (string-append "Invalid HEX sequence " next-hex-str)) - ) ;when - ;; 检查是否满足代理对条件 - (if (and (>= code-point 55296) - (<= code-point 56319) - (>= next-code-point 56320) - (<= next-code-point 57343) - ) ;and - ;; 满足代理对条件，使用 unicode 模块计算码点并转换为字符串 - (let ((surrogate-code-point (+ (* (- code-point 55296) 1024) (- next-code-point 56320) 65536) - ) ;surrogate-code-point - ) ; - (values (utf8->string (codepoint->utf8 surrogate-code-point)) 12) - ) ;let - ;; 不满足代理对条件，仅对第一个 \u 进行转换 - (values (utf8->string (codepoint->utf8 code-point)) 6) - ) ;if - ) ;let - ) ;let - ;; 不存在连续的两个 \u，仅对第一个 \u 进行转换 - (values (utf8->string (codepoint->utf8 code-point)) 6) - ) ;if - ) ;let - ) ;let - ) ;let - ;; 索引无效，返回原字符 - (error 'parse-error - (string-append "HEX sequence too short " (substring s start-pos)) - ) ;error - ) ;if - ) ;let - ) ; - (else (error 'parse-error (string-append "Invalid escape char: " (string next-char))) - ) ;else - ) ;case - ) ;let - ) ;define - - (define string->json - (lambda (s) - (read (open-input-string (let loop - ((s s) (bgn 0) (end 0) (rst '()) (len (string-length s)) (quts? #f) (lst '(#t))) - (cond ((= end len) (fast-string-list-append (reverse rst))) - ((and quts? (char=? (string-ref s end) #\\) (< (+ end 1) len)) - (let-values (((unescaped step) (handle-escape-char s end len))) - (loop s - (+ end step) - (+ end step) - (cons (string-append (substring s bgn end) unescaped) rst) - len - quts? - lst - ) ;loop - ) ;let-values - ) ; - ((and quts? (not (char=? (string-ref s end) #\"))) - (loop s bgn (+ 1 end) rst len quts? lst) - ) ; - (else (case (string-ref s end) - ((#\{) - (loop s - (+ 1 end) - (+ 1 end) - (cons (string-append (substring s bgn end) "((") rst) - len - quts? - (cons #t lst) - ) ;loop - ) ; - ((#\}) - (loop s - (+ 1 end) - (+ 1 end) - (cons (string-append (substring s bgn end) "))") rst) - len - quts? - (loose-cdr lst) - ) ;loop - ) ; - ((#\[) - (loop s - (+ 1 end) - (+ 1 end) - (cons (string-append (substring s bgn end) "#(") rst) - len - quts? - (cons #f lst) - ) ;loop - ) ; - ((#\]) - (loop s - (+ 1 end) - (+ 1 end) - (cons (string-append (substring s bgn end) ")") rst) - len - quts? - (loose-cdr lst) - ) ;loop - ) ; - ((#\:) - (loop s - (+ 1 end) - (+ 1 end) - (cons (string-append (substring s bgn end) " . ") rst) - len - quts? - lst - ) ;loop - ) ; - ((#\,) - (loop s - (+ 1 end) - (+ 1 end) - (cons (string-append (substring s bgn end) (if (loose-car lst) ")(" " ")) rst) - len - quts? - lst - ) ;loop - ) ; - ((#\") (loop s bgn (+ 1 end) rst len (not quts?) lst)) - (else (loop s bgn (+ 1 end) rst len quts? lst)) - ) ;case - ) ;else - ) ;cond - ) ;let - ) ;open-input-string - ) ;read - ) ;lambda - ) ;define - (define (json->string json-scm) - (when (procedure? json-scm) - (type-error "json->string: input must not be a procedure") - ) ;when - (let ((out (open-output-string))) - (define (write-scalar x) - (cond ((string? x) (display (json-string-escape x) out)) - ((number? x) (display (number->string x) out)) - ((boolean? x) (display (if x "true" "false") out)) - ((symbol? x) (display (symbol->string x) out)) - ((null? x) (display "{}" out)) - (else (type-error "Unexpected x: " x)) - ) ;cond - ) ;define - (define (write-json x) - (cond ((vector? x) - (display "[" out) - (let ((len (vector-length x))) - (do ((i 0 (+ i 1))) - ((= i len)) - (when (> i 0) - (display "," out) - ) ;when - (let ((k (vector-ref x i))) - (cond ((vector? k) (write-json k)) - ((pair? k) (write-json k)) - (else (write-scalar k)) - ) ;cond - ) ;let - ) ;do - ) ;let - (display "]" out) - ) ; - ((pair? x) - (display "{" out) - (let loop - ((lst x) (i 0)) - (unless (null? lst) - (let ((d (car lst))) - (when (> i 0) - (display "," out) - ) ;when - (if (null? d) - (display "{}" out) - (begin - (let ((len (length d))) - (when (not (or (= len 0) (= len -1) (>= len 2))) - (value-error d " must be null, pair, or list with at least 2 elements") - ) ;when - ) ;let - (let ((k (loose-car d)) (v (loose-cdr d))) - (write-scalar k) - (display ":" out) - (cond ((null? v) (display "{}" out)) - ((list? v) (write-json v)) - ((vector? v) (write-json v)) - (else (write-scalar v)) - ) ;cond - ) ;let - ) ;begin - ) ;if - (loop (cdr lst) (+ i 1)) - ) ;let - ) ;unless - ) ;let - (display "}" out) - ) ; - (else (write-scalar x)) - ) ;cond - ) ;define - (write-json json-scm) - (get-output-string out) - ) ;let - ) ;define - (define json-ref - (lambda (x k) - (define return - (lambda (x) - (if (symbol? x) - (cond ((symbol=? x 'true) #t) - ((symbol=? x 'false) #f) - (else x) - ) ;cond - x - ) ;if - ) ;lambda - ) ;define - (if (vector? x) - (return (vector-ref x k)) - (let loop - ((x x) (k k)) - (if (null? x) '() (if (equal? (caar x) k) (return (cdar x)) (loop (cdr x) k))) - ) ;let - ) ;if - ) ;lambda - ) ;define - (define (json-ref* j . keys) - (let loop - ((expr j) (keys keys)) - (if (null? keys) expr (loop (json-ref expr (car keys)) (cdr keys))) - ) ;let - ) ;define - (define json-set - (lambda (x v p) - (let ((x x) (v v) (p (if (procedure? p) p (lambda (x) p)))) - (if (vector? x) - (list->vector (cond ((boolean? v) - (if v - (let l - ((x (vector->alist x)) (p p)) - (if (null? x) '() (cons (p (cdar x)) (l (cdr x) p))) - ) ;let - ) ;if - ) ; - ((procedure? v) - (let l - ((x (vector->alist x)) (v v) (p p)) - (if (null? x) - '() - (if (v (caar x)) - (cons (p (cdar x)) (l (cdr x) v p)) - (cons (cdar x) (l (cdr x) v p)) - ) ;if - ) ;if - ) ;let - ) ; - (else (let l - ((x (vector->alist x)) (v v) (p p)) - (if (null? x) - '() - (if (equal? (caar x) v) - (cons (p (cdar x)) (l (cdr x) v p)) - (cons (cdar x) (l (cdr x) v p)) - ) ;if - ) ;if - ) ;let - ) ;else - ) ;cond - ) ;list->vector - (cond ((boolean? v) - (if v - (let l - ((x x) (p p)) - (if (null? x) '() (cons (cons (caar x) (p (cdar x))) (l (cdr x) p))) - ) ;let - ) ;if - ) ; - ((procedure? v) - (let l - ((x x) (v v) (p p)) - (if (null? x) - '() - (if (v (caar x)) - (cons (cons (caar x) (p (cdar x))) (l (cdr x) v p)) - (cons (car x) (l (cdr x) v p)) - ) ;if - ) ;if - ) ;let - ) ; - (else (let l - ((x x) (v v) (p p)) - (if (null? x) - '() - (if (equal? (caar x) v) - (cons (cons v (p (cdar x))) (l (cdr x) v p)) - (cons (car x) (l (cdr x) v p)) - ) ;if - ) ;if - ) ;let - ) ;else - ) ;cond - ) ;if - ) ;let - ) ;lambda - ) ;define - (define (json-set* json k0 k1_or_v . ks_and_v) - (if (null? ks_and_v) - (json-set json k0 k1_or_v) - (json-set json - k0 - (lambda (x) (apply json-set* (cons x (cons k1_or_v ks_and_v)))) - ) ;json-set - ) ;if - ) ;define - (define (json-push x k v) - (if (vector? x) - (if (= (vector-length x) 0) - (vector v) - (list->vector (let l - ((x (vector->alist x)) (k k) (v v) (b #f)) - (if (null? x) - (if b '() (cons v '())) - (if (equal? (caar x) k) - (cons v (cons (cdar x) (l (cdr x) k v #t))) - (cons (cdar x) (l (cdr x) k v b)) - ) ;if - ) ;if - ) ;let - ) ;list->vector - ) ;if - (cons (cons k v) x) - ) ;if - ) ;define - (define (json-push* json k0 v0 . rest) - (if (null? rest) - (json-push json k0 v0) - (json-set json k0 (lambda (x) (apply json-push* (cons x (cons v0 rest))))) - ) ;if - ) ;define - (define json-drop - (lambda (x v) - (if (vector? x) - (if (zero? (vector-length x)) - x - (list->vector (cond ((procedure? v) - (let l - ((x (vector->alist x)) (v v)) - (if (null? x) '() (if (v (caar x)) (l (cdr x) v) (cons (cdar x) (l (cdr x) v)))) - ) ;let - ) ; - (else (let l - ((x (vector->alist x)) (v v)) - (if (null? x) - '() - (if (equal? (caar x) v) (l (cdr x) v) (cons (cdar x) (l (cdr x) v))) - ) ;if - ) ;let - ) ;else - ) ;cond - ) ;list->vector - ) ;if - (cond ((procedure? v) - (let l - ((x x) (v v)) - (if (null? x) '() (if (v (caar x)) (l (cdr x) v) (cons (car x) (l (cdr x) v)))) - ) ;let - ) ; - (else (let l - ((x x) (v v)) - (if (null? x) - '() - (if (equal? (caar x) v) (l (cdr x) v) (cons (car x) (l (cdr x) v))) - ) ;if - ) ;let - ) ;else - ) ;cond - ) ;if - ) ;lambda - ) ;define - (define json-drop* - (lambda (json key . rest) - (if (null? rest) - (json-drop json key) - (json-set json key (lambda (x) (apply json-drop* (cons x rest)))) - ) ;if - ) ;lambda - ) ;define - (define json-reduce - (lambda (x v p) - (if (vector? x) - (list->vector (cond ((boolean? v) - (if v - (let l - ((x (vector->alist x)) (p p)) - (if (null? x) '() (cons (p (caar x) (cdar x)) (l (cdr x) p))) - ) ;let - x - ) ;if - ) ; - ((procedure? v) - (let l - ((x (vector->alist x)) (v v) (p p)) - (if (null? x) - '() - (if (v (caar x)) - (cons (p (caar x) (cdar x)) (l (cdr x) v p)) - (cons (cdar x) (l (cdr x) v p)) - ) ;if - ) ;if - ) ;let - ) ; - (else (let l - ((x (vector->alist x)) (v v) (p p)) - (if (null? x) - '() - (if (equal? (caar x) v) - (cons (p (caar x) (cdar x)) (l (cdr x) v p)) - (cons (cdar x) (l (cdr x) v p)) - ) ;if - ) ;if - ) ;let - ) ;else - ) ;cond - ) ;list->vector - (cond ((boolean? v) - (if v - (let l - ((x x) (p p)) - (if (null? x) '() (cons (cons (caar x) (p (caar x) (cdar x))) (l (cdr x) p))) - ) ;let - x - ) ;if - ) ; - ((procedure? v) - (let l - ((x x) (v v) (p p)) - (if (null? x) - '() - (if (v (caar x)) - (cons (cons (caar x) (p (caar x) (cdar x))) (l (cdr x) v p)) - (cons (car x) (l (cdr x) v p)) - ) ;if - ) ;if - ) ;let - ) ; - (else (let l - ((x x) (v v) (p p)) - (if (null? x) - '() - (if (equal? (caar x) v) - (cons (cons v (p v (cdar x))) (l (cdr x) v p)) - (cons (car x) (l (cdr x) v p)) - ) ;if - ) ;if - ) ;let - ) ;else - ) ;cond - ) ;if - ) ;lambda - ) ;define - (define (json-reduce* j v1 v2 . rest) - (cond ((null? rest) (json-reduce j v1 v2)) - ((length=? 1 rest) - (json-reduce j - v1 - (lambda (x y) - (let* ((new-v1 v2) (p (last rest))) - (json-reduce y new-v1 (lambda (n m) (p (list x n) m))) - ) ;let* - ) ;lambda - ) ;json-reduce - ) ; - (else (json-reduce j - v1 - (lambda (x y) - (let* ((new-v1 v2) (p (last rest))) - (apply json-reduce* - (append (cons y (cons new-v1 (drop-right rest 1))) - (list (lambda (n m) (p (cons x n) m))) - ) ;append - ) ;apply - ) ;let* - ) ;lambda - ) ;json-reduce - ) ;else - ) ;cond - ) ;define - ) ;begin -) ;define-library diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/bag.scm b/TeXmacs/plugins/goldfish/goldfish/liii/bag.scm index aa47ad9fb6..4060dcee44 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/bag.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/bag.scm @@ -44,45 +44,13 @@ ) ;only (srfi srfi-128) ) ;import - (export bag - bag-unfold - bag-member - bag-comparator - bag->list - list->bag - list->bag! - bag-copy - bag? - bag-contains? - bag-empty? - bag-disjoint? - bag-size - bag-find - bag-count - bag-any? - bag-every? - bag=? - bag? - bag<=? - bag>=? - bag-union - bag-intersection - bag-difference - bag-xor - bag-union! - bag-intersection! - bag-difference! - bag-xor! - bag-adjoin - bag-adjoin! - bag-replace - bag-replace! - bag-delete - bag-delete! - bag-delete-all - bag-delete-all! - bag-search! + (export bag bag-unfold bag-member bag-comparator bag->list list->bag + list->bag! bag-copy bag? bag-contains? bag-empty? bag-disjoint? bag-size + bag-find bag-count bag-any? bag-every? bag=? bag? bag<=? bag>=? + bag-union bag-intersection bag-difference bag-xor bag-union! + bag-intersection! bag-difference! bag-xor! bag-adjoin bag-adjoin! + bag-replace bag-replace! bag-delete bag-delete! bag-delete-all + bag-delete-all! bag-search! ) ;export (define comp (make-default-comparator)) diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/base.scm b/TeXmacs/plugins/goldfish/goldfish/liii/base.scm index c0dd212d13..857152d49f 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/base.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/base.scm @@ -1,35 +1,11 @@ (define-library (liii base) (import (scheme base) (srfi srfi-2) (srfi srfi-8)) - (export and-let* - receive - define* - lambda* - procedure-source - procedure-arglist - arity - defined? - object->string - eval-string - signature - copy - keyword? - string->keyword - symbol->keyword - keyword->symbol - loose-car - loose-cdr - compose - identity - any? - typed-lambda - make-hook - hook-functions - with-output-to-string - with-input-from-string - call-with-input-string - call-with-output-string - reverse! - format + (export and-let* receive define* lambda* procedure-source procedure-arglist + arity defined? object->string eval-string signature copy keyword? + string->keyword symbol->keyword keyword->symbol loose-car loose-cdr compose + identity any? typed-lambda make-hook hook-functions with-output-to-string + with-input-from-string call-with-input-string call-with-output-string + reverse! sort! format cyclic-sequences ) ;export (begin diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/base64.scm b/TeXmacs/plugins/goldfish/goldfish/liii/base64.scm index 9cc5daba06..f57d047674 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/base64.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/base64.scm @@ -1,11 +1,7 @@ (define-library (liii base64) (import (scheme base) (liii base) (liii bitwise) (liii error)) - (export string-base64-encode - bytevector-base64-encode - base64-encode - string-base64-decode - bytevector-base64-decode - base64-decode + (export string-base64-encode bytevector-base64-encode base64-encode + string-base64-decode bytevector-base64-decode base64-decode ) ;export (begin (define bytevector-base64-encode diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/bitwise.scm b/TeXmacs/plugins/goldfish/goldfish/liii/bitwise.scm index ec1ebf44bf..534201f060 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/bitwise.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/bitwise.scm @@ -1,33 +1,11 @@ (define-library (liii bitwise) (import (srfi srfi-151) (liii error)) (export lognot logand logior logxor ash) - (export bitwise-not - bitwise-and - bitwise-ior - bitwise-xor - bitwise-eqv - bitwise-or - bitwise-nor - bitwise-nand - bit-count - bitwise-orc1 - bitwise-orc2 - bitwise-andc1 - bitwise-andc2 - arithmetic-shift - integer-length - bitwise-if - bit-set? - copy-bit - bit-swap - any-bit-set? - every-bit-set? - first-set-bit - bit-field - bit-field-any? - bit-field-every? - bit-field-clear - bit-field-set + (export bitwise-not bitwise-and bitwise-ior bitwise-xor bitwise-eqv bitwise-or + bitwise-nor bitwise-nand bit-count bitwise-orc1 bitwise-orc2 bitwise-andc1 + bitwise-andc2 arithmetic-shift integer-length bitwise-if bit-set? copy-bit + bit-swap any-bit-set? every-bit-set? first-set-bit bit-field bit-field-any? + bit-field-every? bit-field-clear bit-field-set ) ;export (begin (define bitwise-or bitwise-ior) diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/check.scm b/TeXmacs/plugins/goldfish/goldfish/liii/check.scm index 11770a78ce..6e1cdea48b 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/check.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/check.scm @@ -1,14 +1,6 @@ (define-library (liii check) - (export test - check - check-approx - check-set-mode! - check:proc - check-catch - check-report - check-failed? - check-true - check-false + (export test check check-approx check-set-mode! check:proc check-catch + check-report check-failed? check-true check-false ) ;export (import (srfi srfi-78) (rename (srfi srfi-78) (check-report srfi-78-check-report)) diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/comparator.scm b/TeXmacs/plugins/goldfish/goldfish/liii/comparator.scm index 88892c65bd..03db6a58d2 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/comparator.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/comparator.scm @@ -1,36 +1,13 @@ (define-library (liii comparator) (import (srfi srfi-128)) - (export comparator? - comparator-ordered? - comparator-hashable? - make-comparator - make-pair-comparator - make-list-comparator - make-vector-comparator - make-eq-comparator - make-eqv-comparator - make-equal-comparator - boolean-hash - char-hash - char-ci-hash - string-hash - string-ci-hash - symbol-hash - number-hash - make-default-comparator - default-hash - comparator-type-test-predicate - comparator-equality-predicate - comparator-ordering-predicate - comparator-hash-function - comparator-test-type - comparator-check-type - comparator-hash - =? - ? - <=? - >=? + (export comparator? comparator-ordered? comparator-hashable? make-comparator + make-pair-comparator make-list-comparator make-vector-comparator + make-eq-comparator make-eqv-comparator make-equal-comparator boolean-hash + char-hash char-ci-hash string-hash string-ci-hash symbol-hash number-hash + make-default-comparator default-hash comparator-type-test-predicate + comparator-equality-predicate comparator-ordering-predicate + comparator-hash-function comparator-test-type comparator-check-type + comparator-hash =? ? <=? >=? ) ;export (begin ) ;begin diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/config-parser.scm b/TeXmacs/plugins/goldfish/goldfish/liii/config-parser.scm index 23436ab7c9..6ec232b82a 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/config-parser.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/config-parser.scm @@ -24,22 +24,10 @@ (liii error) (srfi srfi-128) ) ;import - (export make-config-parser - config-parser? - config-read-string - config-read-file - config-sections - config-has-section? - config-has-option? - config-get - config-get-int - config-get-boolean - config-options - config-items - config-set! - config-add-section! - config-remove-section! - config-remove-option! + (export make-config-parser config-parser? config-read-string config-read-file + config-sections config-has-section? config-has-option? config-get + config-get-int config-get-boolean config-options config-items config-set! + config-add-section! config-remove-section! config-remove-option! config-write ) ;export (begin diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/either.scm b/TeXmacs/plugins/goldfish/goldfish/liii/either.scm index 28adc25f08..5443189c8e 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/either.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/either.scm @@ -1,20 +1,8 @@ (define-library (liii either) (import (liii base)) - (export from-left - to-left - from-right - to-right - either? - either-left? - either-right? - either-map - either-flat-map - either-for-each - either-get-or-else - either-or-else - either-filter-or-else - either-contains? - either-every + (export from-left to-left from-right to-right either? either-left? + either-right? either-map either-flat-map either-for-each either-get-or-else + either-or-else either-filter-or-else either-contains? either-every either-any ) ;export (begin diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/enum.scm b/TeXmacs/plugins/goldfish/goldfish/liii/enum.scm index 9a50ba209a..8bdd81b529 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/enum.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/enum.scm @@ -1,84 +1,23 @@ (define-library (liii enum) (import (srfi srfi-209)) - (export enum-type? - enum? - enum-type-contains? - enum=? - enum? - enum<=? - enum>=? - make-enum-type - enum-type - enum-name - enum-ordinal - enum-value - enum-name->enum - enum-ordinal->enum - enum-name->ordinal - enum-name->value - enum-ordinal->name - enum-ordinal->value - enum-type-size - enum-min - enum-max - enum-type-enums - enum-type-names - enum-type-values - enum-next - enum-prev - make-enum-comparator - enum-empty-set - enum-type->enum-set - enum-set - list->enum-set - enum-set-projection - enum-set-copy - make-enumeration - enum-set-universe - enum-set-constructor - enum-set-indexer - enum-set? - enum-set-contains? - enum-set-member? - enum-set-empty? - enum-set-disjoint? - enum-set=? - enum-set? - enum-set<=? - enum-set>=? - enum-set-subset? - enum-set-any? - enum-set-every? - enum-set-type - enum-set-adjoin - enum-set-adjoin! - enum-set-delete - enum-set-delete! - enum-set-delete-all - enum-set-delete-all! - enum-set-size - enum-set->enum-list - enum-set->list - enum-set-map->list - enum-set-count - enum-set-filter - enum-set-filter! - enum-set-remove - enum-set-remove! - enum-set-for-each - enum-set-fold - enum-set-union - enum-set-union! - enum-set-intersection - enum-set-intersection! - enum-set-difference - enum-set-difference! - enum-set-xor - enum-set-xor! - enum-set-complement - enum-set-complement! + (export enum-type? enum? enum-type-contains? enum=? enum? enum<=? + enum>=? make-enum-type enum-type enum-name enum-ordinal enum-value + enum-name->enum enum-ordinal->enum enum-name->ordinal enum-name->value + enum-ordinal->name enum-ordinal->value enum-type-size enum-min enum-max + enum-type-enums enum-type-names enum-type-values enum-next enum-prev + make-enum-comparator enum-empty-set enum-type->enum-set enum-set + list->enum-set enum-set-projection enum-set-copy make-enumeration + enum-set-universe enum-set-constructor enum-set-indexer enum-set? + enum-set-contains? enum-set-member? enum-set-empty? enum-set-disjoint? + enum-set=? enum-set? enum-set<=? enum-set>=? enum-set-subset? + enum-set-any? enum-set-every? enum-set-type enum-set-adjoin enum-set-adjoin! + enum-set-delete enum-set-delete! enum-set-delete-all enum-set-delete-all! + enum-set-size enum-set->enum-list enum-set->list enum-set-map->list + enum-set-count enum-set-filter enum-set-filter! enum-set-remove + enum-set-remove! enum-set-for-each enum-set-fold enum-set-union + enum-set-union! enum-set-intersection enum-set-intersection! + enum-set-difference enum-set-difference! enum-set-xor enum-set-xor! + enum-set-complement enum-set-complement! ) ;export (begin ) ;begin diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/error.scm b/TeXmacs/plugins/goldfish/goldfish/liii/error.scm index 4f88676af8..05bef94859 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/error.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/error.scm @@ -1,14 +1,6 @@ (define-library (liii error) - (export ??? - os-error - file-not-found-error - not-a-directory-error - file-exists-error - timeout-error - type-error - type-error? - key-error - value-error + (export ??? os-error file-not-found-error not-a-directory-error + file-exists-error timeout-error type-error type-error? key-error value-error index-error ) ;export (begin diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/fxmapping.scm b/TeXmacs/plugins/goldfish/goldfish/liii/fxmapping.scm index 7e76e4aa3b..687bdd63fd 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/fxmapping.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/fxmapping.scm @@ -4,7 +4,6 @@ ;; Constructors fxmapping fxmapping-unfold - fxmapping-accumulate alist->fxmapping alist->fxmapping/combinator ;; Predicates @@ -23,13 +22,9 @@ fxmapping-adjust fxmapping-delete fxmapping-delete-all - fxmapping-update - fxmapping-alter fxmapping-delete-min - fxmapping-update-min fxmapping-pop-min fxmapping-delete-max - fxmapping-update-max fxmapping-pop-max ;; Whole fxmapping fxmapping-size @@ -51,8 +46,6 @@ fxmapping->decreasing-alist fxmapping-keys fxmapping-values - fxmapping->generator - fxmapping->decreasing-generator ;; Comparison fxmapping=? fxmapping= fxmapping-split ;; Relations - fxmapping-relation-map ) ;export ) ;define-library diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/hash-table.scm b/TeXmacs/plugins/goldfish/goldfish/liii/hash-table.scm index ce4cd81867..2bbaa24433 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/hash-table.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/hash-table.scm @@ -1,33 +1,11 @@ (define-library (liii hash-table) (import (srfi srfi-125) (srfi srfi-128)) - (export make-hash-table - hash-table - hash-table-unfold - alist->hash-table - hash-table? - hash-table-contains? - hash-table-empty? - hash-table=? - hash-table-mutable? - hash-table-ref - hash-table-ref/default - hash-table-set! - hash-table-delete! - hash-table-intern! - hash-table-update! - hash-table-update!/default - hash-table-pop! - hash-table-clear! - hash-table-size - hash-table-keys - hash-table-values - hash-table-entries - hash-table-find - hash-table-count - hash-table-fold - hash-table-for-each - hash-table-map->list - hash-table->alist + (export make-hash-table hash-table alist->hash-table hash-table? + hash-table-contains? hash-table-empty? hash-table=? hash-table-ref + hash-table-ref/default hash-table-set! hash-table-delete! hash-table-update! + hash-table-update!/default hash-table-clear! hash-table-size hash-table-keys + hash-table-values hash-table-entries hash-table-find hash-table-count + hash-table-fold hash-table-for-each hash-table-map->list hash-table->alist hash-table-copy ) ;export (begin diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/http-async.scm b/TeXmacs/plugins/goldfish/goldfish/liii/http-async.scm new file mode 100644 index 0000000000..4308e29654 --- /dev/null +++ b/TeXmacs/plugins/goldfish/goldfish/liii/http-async.scm @@ -0,0 +1,75 @@ +;; +;; Copyright (C) 2025 The Goldfish Scheme Authors +;; +;; Licensed under the Apache License, Version 2.0 (the "License"); +;; you may not use this file except in compliance with the License. +;; You may obtain a copy of the License at +;; +;; http://www.apache.org/licenses/LICENSE-2.0 +;; +;; Unless required by applicable law or agreed to in writing, software +;; distributed under the License is distributed on an "AS IS" BASIS, +;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;; See the License for the specific language governing permissions and +;; limitations under the License. +;; + +(define-library (liii http-async) + (import (liii http-common)) + (export http-async-get http-async-post http-async-head http-poll http-wait-all + http-ok? + ) ;export + (begin + + (define* (http-async-get url callback (params '()) (headers '()) (proxy '())) + (let ((url (http-require-string "http-async-get" "url" url)) + (callback (http-require-procedure "http-async-get" "callback" callback)) + (params (http-normalize-string-alist "http-async-get" "params" params)) + (headers (http-normalize-string-alist "http-async-get" "headers" headers)) + (proxy (http-normalize-string-alist "http-async-get" "proxy" proxy)) + ) ; + (g_http-async-get url params headers proxy callback) + ) ;let + ) ;define* + + (define* (http-async-post url callback (params '()) (data "") (headers '()) (proxy '())) + (let* ((url (http-require-string "http-async-post" "url" url)) + (callback (http-require-procedure "http-async-post" "callback" callback)) + (params (http-normalize-string-alist "http-async-post" "params" params)) + (data (http-require-string "http-async-post" "data" data)) + (headers (http-normalize-string-alist "http-async-post" "headers" headers)) + (proxy (http-normalize-string-alist "http-async-post" "proxy" proxy)) + ) ; + (cond ((and (> (string-length data) 0) (null? headers)) + (g_http-async-post url + params + data + '(("Content-Type" . "text/plain")) + proxy + callback + ) ;g_http-async-post + ) ; + (else (g_http-async-post url params data headers proxy callback)) + ) ;cond + ) ;let* + ) ;define* + + (define* (http-async-head url callback (params '()) (headers '()) (proxy '())) + (let ((url (http-require-string "http-async-head" "url" url)) + (callback (http-require-procedure "http-async-head" "callback" callback)) + (params (http-normalize-string-alist "http-async-head" "params" params)) + (headers (http-normalize-string-alist "http-async-head" "headers" headers)) + (proxy (http-normalize-string-alist "http-async-head" "proxy" proxy)) + ) ; + (g_http-async-head url params headers proxy callback) + ) ;let + ) ;define* + + (define (http-poll) + (g_http-poll) + ) ;define + + (define* (http-wait-all (timeout -1)) (g_http-wait-all timeout)) + + ) ;begin +) ;define-library diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/http-common.scm b/TeXmacs/plugins/goldfish/goldfish/liii/http-common.scm new file mode 100644 index 0000000000..cd959e1513 --- /dev/null +++ b/TeXmacs/plugins/goldfish/goldfish/liii/http-common.scm @@ -0,0 +1,213 @@ +;; +;; Copyright (C) 2025 The Goldfish Scheme Authors +;; +;; Licensed under the Apache License, Version 2.0 (the "License"); +;; you may not use this file except in compliance with the License. +;; You may obtain a copy of the License at +;; +;; http://www.apache.org/licenses/LICENSE-2.0 +;; +;; Unless required by applicable law or agreed to in writing, software +;; distributed under the License is distributed on an "AS IS" BASIS, +;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;; See the License for the specific language governing permissions and +;; limitations under the License. +;; + +(define-library (liii http-common) + (import (liii alist) (liii error) (scheme file)) + (export http-ok? http-require-string http-require-procedure + http-require-boolean http-optional-string http-optional-procedure + http-scalar->string http-normalize-string-alist http-normalize-files + http-normalize-post-form-data + ) ;export + (begin + + (define (http-ok? r) + (let ((status-code (r 'status-code)) (reason (r 'reason)) (url (r 'url))) + (cond ((and (>= status-code 400) (< status-code 500)) + (error 'http-error + (string-append (number->string status-code) + " Client Error: " + reason + " for url: " + url + ) ;string-append + ) ;error + ) ; + ((and (>= status-code 500) (< status-code 600)) + (error 'http-error + (string-append (number->string status-code) + " Server Error: " + reason + " for url: " + url + ) ;string-append + ) ;error + ) ; + (else #t) + ) ;cond + ) ;let + ) ;define + + (define (http-require-string who field value) + (when (not (string? value)) + (type-error (string-append who ": " field " must be string") value) + ) ;when + value + ) ;define + + (define (http-require-procedure who field value) + (when (not (procedure? value)) + (type-error (string-append who ": " field " must be a procedure") value) + ) ;when + value + ) ;define + + (define (http-require-boolean who field value) + (when (not (boolean? value)) + (type-error (string-append who ": " field " must be boolean") value) + ) ;when + value + ) ;define + + (define (http-optional-string who field value) + (if value (http-require-string who field value) #f) + ) ;define + + (define (http-optional-procedure who field value) + (if value (http-require-procedure who field value) #f) + ) ;define + + (define (http-scalar->string who field value) + (cond ((string? value) value) + ((symbol? value) (symbol->string value)) + ((or (integer? value) (real? value)) (number->string value)) + (else (type-error (string-append who ": " field " must be a string, symbol, or number") + value + ) ;type-error + ) ;else + ) ;cond + ) ;define + + (define (http-normalize-string-alist-entry who field entry) + (when (not (pair? entry)) + (type-error (string-append who ": " field " entries must be key/value pairs") + entry + ) ;type-error + ) ;when + (when (pair? (cdr entry)) + (type-error (string-append who ": " field " entries must be key/value pairs") + entry + ) ;type-error + ) ;when + (cons (http-scalar->string who (string-append field " key") (car entry)) + (http-scalar->string who (string-append field " value") (cdr entry)) + ) ;cons + ) ;define + + (define (http-normalize-string-alist who field entries) + (when (not (alist? entries)) + (type-error (string-append who ": " field " must be an association list") + entries + ) ;type-error + ) ;when + (map (lambda (entry) (http-normalize-string-alist-entry who field entry)) + entries + ) ;map + ) ;define + + (define (http-normalize-part-key who key) + (cond ((string? key) key) + ((symbol? key) (symbol->string key)) + (else (type-error (string-append who ": multipart part key must be string or symbol") + key + ) ;type-error + ) ;else + ) ;cond + ) ;define + + (define http-file-spec-keys '("file" "filename" "content-type")) + + (define (http-part-ref part key) + (let ((entry (assoc key part string=?))) + (and entry (cdr entry)) + ) ;let + ) ;define + + (define (http-normalize-file-spec-entry who entry) + (when (not (pair? entry)) + (type-error (string-append who ": files entries must be key/value pairs") entry) + ) ;when + (when (pair? (cdr entry)) + (type-error (string-append who ": files entries must be key/value pairs") entry) + ) ;when + (let* ((key (http-normalize-part-key who (car entry))) (value (cdr entry))) + (when (not (member key http-file-spec-keys string=?)) + (value-error (string-append who ": file spec contains unsupported key") key) + ) ;when + (when (not (string? value)) + (type-error (string-append who ": file spec " key " must be string") value) + ) ;when + (cons key value) + ) ;let* + ) ;define + + (define (http-normalize-file-entry who entry) + (when (not (pair? entry)) + (type-error (string-append who ": files must be an association list") entry) + ) ;when + (let* ((name (http-scalar->string who "files key" (car entry))) (spec (cdr entry))) + (cond ((string? spec) + (when (not (file-exists? spec)) + (value-error (string-append who ": file does not exist") spec) + ) ;when + `((name . ,name) (file . ,spec)) + ) ; + ((alist? spec) + (let* ((normalized-spec (map (lambda (item) (http-normalize-file-spec-entry who item)) spec) + ) ;normalized-spec + (file (http-part-ref normalized-spec "file")) + (filename (http-part-ref normalized-spec "filename")) + (content-type (http-part-ref normalized-spec "content-type")) + ) ; + (when (not file) + (value-error (string-append who ": file spec requires a file path") spec) + ) ;when + (when (not (file-exists? file)) + (value-error (string-append who ": file does not exist") file) + ) ;when + (append `((name . ,name) (file . ,file)) + (if filename `((filename . ,filename)) '()) + (if content-type `((content-type . ,content-type)) '()) + ) ;append + ) ;let* + ) ; + (else (type-error (string-append who ": files value must be a path string or file spec alist") + spec + ) ;type-error + ) ;else + ) ;cond + ) ;let* + ) ;define + + (define (http-normalize-files who files) + (when (not (alist? files)) + (type-error (string-append who ": files must be an association list") files) + ) ;when + (map (lambda (entry) (http-normalize-file-entry who entry)) files) + ) ;define + + (define (http-normalize-post-form-data who data) + (cond ((null? data) '()) + ((and (string? data) (= (string-length data) 0)) '()) + ((alist? data) (http-normalize-string-alist who "data" data)) + (else (type-error (string-append who ": data must be an association list when files is provided") + data + ) ;type-error + ) ;else + ) ;cond + ) ;define + + ) ;begin +) ;define-library diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/http.scm b/TeXmacs/plugins/goldfish/goldfish/liii/http.scm index c50faed87f..4be41f848d 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/http.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/http.scm @@ -1,208 +1,24 @@ ;; -;; COPYRIGHT: (C) 2025 Liii Network Inc -;; All rights reverved. +;; Copyright (C) 2025 The Goldfish Scheme Authors +;; +;; Licensed under the Apache License, Version 2.0 (the "License"); +;; you may not use this file except in compliance with the License. +;; You may obtain a copy of the License at +;; +;; http://www.apache.org/licenses/LICENSE-2.0 +;; +;; Unless required by applicable law or agreed to in writing, software +;; distributed under the License is distributed on an "AS IS" BASIS, +;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;; See the License for the specific language governing permissions and +;; limitations under the License. ;; (define-library (liii http) - (import (liii hash-table) (liii alist) (liii error) (scheme file)) - (export http-head - http-get - http-post - http-ok? - http-async-get - http-async-post - http-async-head - http-poll - http-wait-all - ) ;export + (import (liii error) (liii http-common) (scheme file)) + (export http-head http-get http-post http-ok?) (begin - (define (http-ok? r) - (let ((status-code (r 'status-code)) (reason (r 'reason)) (url (r 'url))) - (cond ((and (>= status-code 400) (< status-code 500)) - (error 'http-error - (string-append (number->string status-code) - " Client Error: " - reason - " for url: " - url - ) ;string-append - ) ;error - ) ; - ((and (>= status-code 500) (< status-code 600)) - (error 'http-error - (string-append (number->string status-code) - " Server Error: " - reason - " for url: " - url - ) ;string-append - ) ;error - ) ; - (else #t) - ) ;cond - ) ;let - ) ;define - - (define (http-require-string who field value) - (when (not (string? value)) - (type-error (string-append who ": " field " must be string") value) - ) ;when - value - ) ;define - - (define (http-require-procedure who field value) - (when (not (procedure? value)) - (type-error (string-append who ": " field " must be a procedure") value) - ) ;when - value - ) ;define - - (define (http-require-boolean who field value) - (when (not (boolean? value)) - (type-error (string-append who ": " field " must be boolean") value) - ) ;when - value - ) ;define - - (define (http-optional-string who field value) - (if value (http-require-string who field value) #f) - ) ;define - - (define (http-optional-procedure who field value) - (if value (http-require-procedure who field value) #f) - ) ;define - - (define (http-scalar->string who field value) - (cond ((string? value) value) - ((symbol? value) (symbol->string value)) - ((or (integer? value) (real? value)) (number->string value)) - (else (type-error (string-append who ": " field " must be a string, symbol, or number") - value - ) ;type-error - ) ;else - ) ;cond - ) ;define - - (define (http-normalize-string-alist-entry who field entry) - (when (not (pair? entry)) - (type-error (string-append who ": " field " entries must be key/value pairs") - entry - ) ;type-error - ) ;when - (when (pair? (cdr entry)) - (type-error (string-append who ": " field " entries must be key/value pairs") - entry - ) ;type-error - ) ;when - (cons (http-scalar->string who (string-append field " key") (car entry)) - (http-scalar->string who (string-append field " value") (cdr entry)) - ) ;cons - ) ;define - - (define (http-normalize-string-alist who field entries) - (when (not (alist? entries)) - (type-error (string-append who ": " field " must be an association list") - entries - ) ;type-error - ) ;when - (map (lambda (entry) (http-normalize-string-alist-entry who field entry)) - entries - ) ;map - ) ;define - - (define (http-normalize-part-key who key) - (cond ((string? key) key) - ((symbol? key) (symbol->string key)) - (else (type-error (string-append who ": multipart part key must be string or symbol") - key - ) ;type-error - ) ;else - ) ;cond - ) ;define - - (define http-file-spec-keys '("file" "filename" "content-type")) - - (define (http-part-ref part key) - (let ((entry (assoc key part string=?))) - (and entry (cdr entry)) - ) ;let - ) ;define - - (define (http-normalize-file-spec-entry who entry) - (when (not (pair? entry)) - (type-error (string-append who ": files entries must be key/value pairs") entry) - ) ;when - (when (pair? (cdr entry)) - (type-error (string-append who ": files entries must be key/value pairs") entry) - ) ;when - (let* ((key (http-normalize-part-key who (car entry))) (value (cdr entry))) - (when (not (member key http-file-spec-keys string=?)) - (value-error (string-append who ": file spec contains unsupported key") key) - ) ;when - (when (not (string? value)) - (type-error (string-append who ": file spec " key " must be string") value) - ) ;when - (cons key value) - ) ;let* - ) ;define - - (define (http-normalize-file-entry who entry) - (when (not (pair? entry)) - (type-error (string-append who ": files must be an association list") entry) - ) ;when - (let* ((name (http-scalar->string who "files key" (car entry))) (spec (cdr entry))) - (cond ((string? spec) - (when (not (file-exists? spec)) - (value-error (string-append who ": file does not exist") spec) - ) ;when - `((name unquote name) (file unquote spec)) - ) ; - ((alist? spec) - (let* ((normalized-spec (map (lambda (item) (http-normalize-file-spec-entry who item)) spec) - ) ;normalized-spec - (file (http-part-ref normalized-spec "file")) - (filename (http-part-ref normalized-spec "filename")) - (content-type (http-part-ref normalized-spec "content-type")) - ) ; - (when (not file) - (value-error (string-append who ": file spec requires a file path") spec) - ) ;when - (when (not (file-exists? file)) - (value-error (string-append who ": file does not exist") file) - ) ;when - (append `((name unquote name) (file unquote file)) - (if filename `((filename unquote filename)) '()) - (if content-type `((content-type unquote content-type)) '()) - ) ;append - ) ;let* - ) ; - (else (type-error (string-append who ": files value must be a path string or file spec alist") - spec - ) ;type-error - ) ;else - ) ;cond - ) ;let* - ) ;define - - (define (http-normalize-files who files) - (when (not (alist? files)) - (type-error (string-append who ": files must be an association list") files) - ) ;when - (map (lambda (entry) (http-normalize-file-entry who entry)) files) - ) ;define - - (define (http-normalize-post-form-data who data) - (cond ((null? data) '()) - ((and (string? data) (= (string-length data) 0)) '()) - ((alist? data) (http-normalize-string-alist who "data" data)) - (else (type-error (string-append who ": data must be an association list when files is provided") - data - ) ;type-error - ) ;else - ) ;cond - ) ;define - (define* (http-head url) (let ((r (g_http-head (http-require-string "http-head" "url" url)))) r @@ -320,57 +136,5 @@ ) ;let* ) ;define* - ;; Async HTTP API wrapper functions - - (define* (http-async-get url callback (params '()) (headers '()) (proxy '())) - (let ((url (http-require-string "http-async-get" "url" url)) - (callback (http-require-procedure "http-async-get" "callback" callback)) - (params (http-normalize-string-alist "http-async-get" "params" params)) - (headers (http-normalize-string-alist "http-async-get" "headers" headers)) - (proxy (http-normalize-string-alist "http-async-get" "proxy" proxy)) - ) ; - (g_http-async-get url params headers proxy callback) - ) ;let - ) ;define* - - (define* (http-async-post url callback (params '()) (data "") (headers '()) (proxy '())) - (let* ((url (http-require-string "http-async-post" "url" url)) - (callback (http-require-procedure "http-async-post" "callback" callback)) - (params (http-normalize-string-alist "http-async-post" "params" params)) - (data (http-require-string "http-async-post" "data" data)) - (headers (http-normalize-string-alist "http-async-post" "headers" headers)) - (proxy (http-normalize-string-alist "http-async-post" "proxy" proxy)) - ) ; - (cond ((and (> (string-length data) 0) (null? headers)) - (g_http-async-post url - params - data - '(("Content-Type" . "text/plain")) - proxy - callback - ) ;g_http-async-post - ) ; - (else (g_http-async-post url params data headers proxy callback)) - ) ;cond - ) ;let* - ) ;define* - - (define* (http-async-head url callback (params '()) (headers '()) (proxy '())) - (let ((url (http-require-string "http-async-head" "url" url)) - (callback (http-require-procedure "http-async-head" "callback" callback)) - (params (http-normalize-string-alist "http-async-head" "params" params)) - (headers (http-normalize-string-alist "http-async-head" "headers" headers)) - (proxy (http-normalize-string-alist "http-async-head" "proxy" proxy)) - ) ; - (g_http-async-head url params headers proxy callback) - ) ;let - ) ;define* - - (define (http-poll) - (g_http-poll) - ) ;define - - (define* (http-wait-all (timeout -1)) (g_http-wait-all timeout)) - ) ;begin ) ;define-library diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/json.scm b/TeXmacs/plugins/goldfish/goldfish/liii/json.scm index 34721c1cef..20cfbc0a10 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/json.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/json.scm @@ -1,19 +1,5 @@ (define-library (liii json) - (import (liii base) - (liii list) - (rename (guenchi json) - (json-ref g:json-ref) - (json-ref* g:json-ref*) - (json-set g:json-set) - (json-set* g:json-set*) - (json-push g:json-push) - (json-push* g:json-push*) - (json-drop g:json-drop) - (json-drop* g:json-drop*) - (json-reduce g:json-reduce) - (json-reduce* g:json-reduce*) - ) ;rename - ) ;import + (import (liii base) (liii list)) (export json-string-escape string->json json->string @@ -50,86 +36,37 @@ ;; ; 0. 统一接口 ;; ; --------------------------------------------------------- - (define (ensure-json-structure x) - (unless (or (json-object? x) (json-array? x)) - (type-error "Value is not a JSON object or array" x) - ) ;unless - ) ;define + ;; json-string-escape 由 C++ 实现（src/liii_json.cpp 中的 g_json_string_escape） + (define json-string-escape g_json_string_escape) - (define (json-ref json key . args) - (if (null? json) - '() - (begin - (ensure-json-structure json) - (let ((val (if (and (json-object? json) (equal? json '(()))) '() (g:json-ref json key)) - ) ;val - ) ; - (if (null? args) val (apply json-ref (cons val args))) - ) ;let - ) ;begin - ) ;if - ) ;define + ;; json->string 由 C++ 实现（src/liii_json.cpp 中的 g_json->string） + (define json->string g_json->string) - (define (json-set json key val . args) - (ensure-json-structure json) - (if (null? args) - (if (and (json-object? json) (equal? json '(()))) - json - (g:json-set json key val) - ) ;if - (json-set json key (lambda (x) (apply json-set (cons x (cons val args))))) - ) ;if - ) ;define + ;; string->json 由 C++ 实现（src/liii_json.cpp 中的 g_string->json） + (define string->json g_string->json) - (define (json-push json key val . args) - (ensure-json-structure json) - (if (null? args) - (if (and (json-object? json) (equal? json '(()))) - (g:json-push '() key val) - (g:json-push json key val) - ) ;if - (json-set json key (lambda (x) (apply json-push (cons x (cons val args))))) - ) ;if - ) ;define + ;; json-ref 由 C++ 实现（src/liii_json.cpp 中的 g_json_ref） + (define json-ref g_json_ref) - (define (json-drop json key . args) - (ensure-json-structure json) - (if (null? args) - (if (and (json-object? json) (equal? json '(()))) json (g:json-drop json key)) - (json-set json key (lambda (x) (apply json-drop (cons x args)))) - ) ;if - ) ;define + ;; json-set 由 C++ 实现（src/liii_json.cpp 中的 g_json_set） + (define json-set g_json_set) - (define (json-reduce json key . args) - (if (null? json) - '() - (begin - (ensure-json-structure json) - (if (null? args) - (value-error "json-reduce: missing arguments") - (if (null? (cdr args)) - ;; Single level: (json-reduce json key proc) - (let ((proc (car args))) - (if (and (json-object? json) (equal? json '(()))) - json - (g:json-reduce json key proc) - ) ;if - ) ;let - ;; Multi level - (let* ((keys (cons key (drop-right args 1))) - (proc (last args)) - (top-key (car keys)) - (rest-keys (cdr keys)) - ) ; - (json-reduce json - top-key - (lambda (k v) (apply json-reduce (append (list v) rest-keys (list proc)))) - ) ;json-reduce - ) ;let* - ) ;if - ) ;if - ) ;begin - ) ;if + ;; json-push 由 C++ 实现（src/liii_json.cpp 中的 g_json_push，含变参多键路径， + ;; 语义覆盖历史上的 json-push 与 json-push*） + (define json-push g_json_push) + + ;; json-drop 由 C++ 实现（src/liii_json.cpp 中的 g_json_drop，含变参多键路径， + ;; 语义覆盖历史上的 json-drop 与 json-drop*） + (define json-drop g_json_drop) + + ;; json-reduce 由 C++ 实现（src/liii_json.cpp 中的 g_json_reduce，含变参多键路径， + ;; 语义覆盖历史上的 json-reduce 多层路径模式） + (define json-reduce g_json_reduce) + + (define (ensure-json-structure x) + (unless (or (json-object? x) (json-array? x)) + (type-error "Value is not a JSON object or array" x) + ) ;unless ) ;define ;; ; --------------------------------------------------------- diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/list.scm b/TeXmacs/plugins/goldfish/goldfish/liii/list.scm index 067db619b6..939a0dc89f 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/list.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/list.scm @@ -1,59 +1,11 @@ (define-library (liii list) - (export circular-list - iota - xcons - cons* - null-list? - circular-list? - proper-list? - dotted-list? - first - second - third - fourth - fifth - sixth - seventh - eighth - ninth - tenth - take - drop - take-right - drop-right - split-at - last-pair - last - zip - count - fold - fold-right - reduce - reduce-right - filter - partition - remove - append-map - find - any - every - list-index - take-while - drop-while - delete - alist-cons - flat-map - list-null? - list-not-null? - not-null-list? - length=? - length>? - length>=? - flatten - list-take - list-drop - list-take-right - list-drop-right + (export circular-list iota xcons cons* null-list? circular-list? proper-list? + dotted-list? first second third fourth fifth sixth seventh eighth ninth + tenth take drop take-right drop-right split-at last-pair last zip count fold + fold-right reduce reduce-right filter partition remove append-map find any + every list-index take-while drop-while delete alist-cons flat-map list-null? + list-not-null? not-null-list? length=? length>? length>=? flatten list-take + list-drop list-take-right list-drop-right ) ;export (import (scheme base) (srfi srfi-1) (srfi srfi-13) (liii error)) (begin @@ -140,9 +92,20 @@ (unless (integer? n) (type-error "list-take-right: second argument must be an integer" n) ) ;unless - (cond ((< n 0) '()) - ((>= n (length lst)) lst) - (else (take-right lst n)) + (cond ((<= n 0) '()) + (else (let advance + ((lead lst) (count 0)) + (cond ((null? lead) lst) + ((>= count n) + (let scan + ((lead lead) (lag lst)) + (if (null? lead) lag (scan (cdr lead) (cdr lag))) + ) ;let + ) ; + (else (advance (cdr lead) (+ count 1))) + ) ;cond + ) ;let + ) ;else ) ;cond ) ;define @@ -153,7 +116,7 @@ (unless (integer? n) (type-error "list-drop-right: second argument must be an integer" n) ) ;unless - (cond ((< n 0) lst) + (cond ((<= n 0) lst) ((>= n (length lst)) '()) (else (drop-right lst n)) ) ;cond diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/logging.scm b/TeXmacs/plugins/goldfish/goldfish/liii/logging.scm index 52368b4c2a..32f807f325 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/logging.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/logging.scm @@ -18,41 +18,13 @@ ;; 提供便捷函数、级别控制、格式化输出和文件处理器 (define-library (liii logging) - (export send-log - current-log-fields - current-log-callback - EMERGENCY - ALERT - CRITICAL - ERROR - WARNING - NOTICE - INFO - DEBUG - log-set-fields! - log-set-callback! - log-set-file-handler! - current-log-fields-in-alist - log-emergency - log-alert - log-critical - log-error - log-warning - log-notice - log-info - log-debug - log-set-level! - current-log-level - log-set-format! - current-log-format - log-flush! - default-log-handler - make-stdout-handler - make-stderr-handler - make-file-handler - log-message-severity - log-message-message - log-message-field + (export send-log current-log-fields current-log-callback EMERGENCY ALERT + CRITICAL ERROR WARNING NOTICE INFO DEBUG log-set-fields! log-set-callback! + log-set-file-handler! current-log-fields-in-alist log-emergency log-alert + log-critical log-error log-warning log-notice log-info log-debug + log-set-level! current-log-level log-set-format! current-log-format + log-flush! default-log-handler make-stdout-handler make-stderr-handler + make-file-handler log-message-severity log-message-message log-message-field ) ;export (import (scheme base) (scheme write) @@ -182,13 +154,11 @@ (callback *log-callback*) ) ; (if callback - (callback `((SEVERITY unquote severity) - (MESSAGE unquote message) - ,@alist)) + (callback `((SEVERITY . ,severity) (MESSAGE . ,message) ,@alist)) ;; 默认行为：ERROR 及以上到 stderr，其他到 stdout (let ((port (if (<= severity ERROR) (current-error-port) (current-output-port)))) - (default-log-handler `((SEVERITY unquote severity) - (MESSAGE unquote message) + (default-log-handler `((SEVERITY . ,severity) + (MESSAGE . ,message) ,@alist) port ) ;default-log-handler diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/njson.scm b/TeXmacs/plugins/goldfish/goldfish/liii/njson.scm index fed7d8d613..d205a4d9d3 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/njson.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/njson.scm @@ -10,43 +10,14 @@ (json-ref ljson-ref) ) ;rename ) ;import - (export njson? - njson-null? - njson-object? - njson-array? - njson-string? - njson-number? - njson-integer? - njson-boolean? - njson-size - njson-empty? - njson-free - string->njson - file->njson - njson->string - njson-format-string - njson->file - json->njson - njson->json - njson-object->alist - njson-object->hash-table - njson-array->list - njson-array->vector - let-njson - njson-ref - njson-set - njson-append - njson-set! - njson-append! - njson-merge - njson-merge! - njson-deep-merge - njson-deep-merge! - njson-drop - njson-drop! - njson-contains-key? - njson-keys - njson-schema-report + (export njson? njson-null? njson-object? njson-array? njson-string? + njson-number? njson-integer? njson-boolean? njson-size njson-empty? + njson-free string->njson file->njson njson->string njson-format-string + njson->file json->njson njson->json njson-object->alist + njson-object->hash-table njson-array->list njson-array->vector let-njson + njson-ref njson-set njson-append njson-set! njson-append! njson-merge + njson-merge! njson-deep-merge njson-deep-merge! njson-drop njson-drop! + njson-contains-key? njson-keys njson-schema-report ) ;export (begin (define (njson-null-symbol? x) diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/option.scm b/TeXmacs/plugins/goldfish/goldfish/liii/option.scm index 8095051f49..37382d0349 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/option.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/option.scm @@ -1,20 +1,8 @@ (define-library (liii option) (import (liii base)) - (export none - option - option? - option-map - option-filter - option-flat-map - option-for-each - option-get - option-get-or-else - option=? - option-or-else - option-defined? - option-empty? - option-every - option-any + (export none option option? option-map option-filter option-flat-map + option-for-each option-get option-get-or-else option=? option-or-else + option-defined? option-empty? option-every option-any ) ;export (begin diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/os.scm b/TeXmacs/plugins/goldfish/goldfish/liii/os.scm index bb6c1edabd..89028e200d 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/os.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/os.scm @@ -1,26 +1,7 @@ (define-library (liii os) - (export os-arch - os-type - os-windows? - os-linux? - os-macos? - os-temp-dir - os-sep - pathsep - os-call - mkdir - chdir - rmdir - remove - rename - getenv - putenv - unsetenv - getcwd - listdir - access - getlogin - getpid + (export os-arch os-type os-windows? os-linux? os-macos? os-temp-dir os-sep + pathsep os-call mkdir chdir rmdir remove rename getenv putenv unsetenv + getcwd listdir access getlogin getpid ) ;export (import (scheme process-context) (liii base) (liii error) (liii string)) (begin diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/path.scm b/TeXmacs/plugins/goldfish/goldfish/liii/path.scm index c2e7b098b7..04ebf53aa1 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/path.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/path.scm @@ -1,57 +1,14 @@ (define-library (liii path) - (export path - path? - path-copy - path-copy-into - path-dir? - path-file? - path-exists? - path-getsize - path-read-text - path-read-bytes - path-write-text - path-write-bytes - path-append-text - path-touch - path-root - path-of-drive - path-from-parts - path-from-env - path-cwd - path-home - path-temp-dir - path-parts - path-type - path-drive - path->string - path-from-string - path-name - path-stem - path-suffix - path-suffixes - path-with-name - path-with-stem - path-with-suffix - path-relative-to - path-starts-with? - path-equals? - path=? - path-absolute? - path-relative? - path-join - path-parent - path-parents - path-list - path-list-path - path-rmdir - path-unlink - path-rename - path-mkdir - path-absolute - path-expanduser - path-match - path-as-posix - path-resolve + (export path path? path-copy path-copy-into path-dir? path-file? path-exists? + path-getsize path-read-text path-read-bytes path-write-text path-write-bytes + path-append-text path-touch path-root path-of-drive path-from-parts + path-from-env path-cwd path-home path-temp-dir path-parts path-type + path-drive path->string path-from-string path-name path-stem path-suffix + path-suffixes path-with-name path-with-stem path-with-suffix + path-relative-to path-starts-with? path-equals? path=? path-absolute? + path-relative? path-join path-parent path-parents path-list path-list-path + path-rmdir path-unlink path-rename path-mkdir path-absolute path-expanduser + path-match path-as-posix path-resolve ) ;export (import (liii base) (liii error) diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/queue.scm b/TeXmacs/plugins/goldfish/goldfish/liii/queue.scm index 8d05e2f624..9d378b2dba 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/queue.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/queue.scm @@ -1,26 +1,10 @@ (define-library (liii queue) - (export make-list-queue - list-queue - list-queue-copy - list-queue-unfold - list-queue-unfold-right - list-queue? - list-queue-empty? - list-queue-front - list-queue-back - list-queue-list - list-queue-first-last - list-queue-add-front! - list-queue-add-back! - list-queue-remove-front! - list-queue-remove-back! - list-queue-remove-all! - list-queue-set-list! - list-queue-append - list-queue-append! - list-queue-concatenate - list-queue-map - list-queue-map! + (export make-list-queue list-queue list-queue-copy list-queue-unfold + list-queue-unfold-right list-queue? list-queue-empty? list-queue-front + list-queue-back list-queue-list list-queue-first-last list-queue-add-front! + list-queue-add-back! list-queue-remove-front! list-queue-remove-back! + list-queue-remove-all! list-queue-set-list! list-queue-append + list-queue-append! list-queue-concatenate list-queue-map list-queue-map! list-queue-for-each ) ;export (import (srfi srfi-117)) diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/random.scm b/TeXmacs/plugins/goldfish/goldfish/liii/random.scm index 453980552e..6a87326567 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/random.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/random.scm @@ -19,16 +19,9 @@ (define-library (liii random) (import (srfi srfi-27)) - (export random-integer - random-real - default-random-source - make-random-source - random-source? - random-source-state-ref - random-source-state-set! - random-source-randomize! - random-source-pseudo-randomize! - random-source-make-integers - random-source-make-reals + (export random-integer random-real default-random-source make-random-source + random-source? random-source-state-ref random-source-state-set! + random-source-randomize! random-source-pseudo-randomize! + random-source-make-integers random-source-make-reals ) ;export ) ;define-library diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/range.scm b/TeXmacs/plugins/goldfish/goldfish/liii/range.scm index 505efbf27a..37402b547c 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/range.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/range.scm @@ -1,41 +1,11 @@ (define-library (liii range) (import (srfi srfi-196)) - (export range - numeric-range - vector-range - string-range - range-append - iota-range - range? - range=? - range-length - range-ref - range-first - range-last - subrange - range-segment - range-split-at - range-take - range-take-right - range-drop - range-drop-right - range-count - range-map->list - range-for-each - range-fold - range-fold-right - range-any - range-every - range-filter->list - range-remove->list - range-reverse - range-map->vector - range-filter->vector - range-remove->vector - vector->range - range->list - range->vector - range->string - range->generator + (export range numeric-range vector-range string-range range-append iota-range + range? range=? range-length range-ref range-first range-last subrange + range-segment range-split-at range-take range-take-right range-drop + range-drop-right range-count range-map->list range-for-each range-fold + range-fold-right range-any range-every range-filter->list range-remove->list + range-reverse range-map->vector range-filter->vector range-remove->vector + vector->range range->list range->vector range->string range->generator ) ;export ) ;define-library diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/raw-string.scm b/TeXmacs/plugins/goldfish/goldfish/liii/raw-string.scm index 74cc63e418..7cd5ead011 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/raw-string.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/raw-string.scm @@ -11,15 +11,9 @@ (define-library (liii raw-string) (import (srfi srfi-267) (srfi srfi-1) (srfi srfi-13) (liii error)) - (export raw-string-read-error? - raw-string-write-error? - read-raw-string - read-raw-string-after-prefix - can-delimit? - generate-delimiter - write-raw-string - deindent - &- + (export raw-string-read-error? raw-string-write-error? read-raw-string + read-raw-string-after-prefix can-delimit? generate-delimiter + write-raw-string deindent &- ) ;export (begin (define (string-split-lines str) diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/set.scm b/TeXmacs/plugins/goldfish/goldfish/liii/set.scm index c8b5635214..95c9439e31 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/set.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/set.scm @@ -5,55 +5,14 @@ ) ;rename (srfi srfi-128) ) ;import - (export set - set-unfold - list->set - list->set! - set-copy - set->list - list->set-with-comparator - make-set-with-comparator - set? - set-contains? - set-empty? - set-disjoint? - set-element-comparator - set-size - set=? - set? - set<=? - set>=? - set-any? - set-every? - set-find - set-count - set-member - set-search! - set-map - set-for-each - set-fold - set-filter - set-filter! - set-remove - set-remove! - set-partition - set-partition! - set-union - set-intersection - set-difference - set-xor - set-union! - set-intersection! - set-difference! - set-xor! - set-adjoin - set-adjoin! - set-replace - set-replace! - set-delete - set-delete! - set-delete-all + (export set set-unfold list->set list->set! set-copy set->list + list->set-with-comparator make-set-with-comparator set? set-contains? + set-empty? set-disjoint? set-element-comparator set-size set=? set? + set<=? set>=? set-any? set-every? set-find set-count set-member set-search! + set-map set-for-each set-fold set-filter set-filter! set-remove set-remove! + set-partition set-partition! set-union set-intersection set-difference + set-xor set-union! set-intersection! set-difference! set-xor! set-adjoin + set-adjoin! set-replace set-replace! set-delete set-delete! set-delete-all set-delete-all! ) ;export diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/sort.scm b/TeXmacs/plugins/goldfish/goldfish/liii/sort.scm index c70eec17ae..c569458490 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/sort.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/sort.scm @@ -1,18 +1,7 @@ (define-library (liii sort) - (export list-sorted? - vector-sorted? - list-merge - list-sort - list-stable-sort - vector-merge - vector-sort - vector-stable-sort - list-merge! - list-sort! - list-stable-sort! - vector-merge! - vector-sort! - vector-stable-sort! + (export list-sorted? vector-sorted? list-merge list-sort list-stable-sort + vector-merge vector-sort vector-stable-sort list-merge! list-sort! + list-stable-sort! vector-merge! vector-sort! vector-stable-sort! ) ;export (import (srfi srfi-132)) ) ;define-library diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/stack.scm b/TeXmacs/plugins/goldfish/goldfish/liii/stack.scm index ada16ca950..2b497552a2 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/stack.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/stack.scm @@ -1,17 +1,6 @@ (define-library (liii stack) - (export make-stack - stack - stack? - stack-empty? - stack-top - stack-size - stack-push! - stack-pop! - stack->list - list->stack - stack-map - stack-map! - stack-for-each + (export make-stack stack stack? stack-empty? stack-top stack-size stack-push! + stack-pop! stack->list list->stack stack-map stack-map! stack-for-each stack-copy ) ;export (import (liii error)) diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/string-cursor.scm b/TeXmacs/plugins/goldfish/goldfish/liii/string-cursor.scm index d304b95763..ba87f697cf 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/string-cursor.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/string-cursor.scm @@ -86,205 +86,88 @@ (begin - ;; ==== Internal data structures ==== - - (define-record-type - (make-string-offsets bv positions) - string-offsets? - (bv string-offsets-bv) - (positions string-offsets-positions) - ) ;define-record-type - - (define-record-type - (make-string-cursor-raw offsets char-index) - string-cursor? - (offsets string-cursor-offsets) - (char-index string-cursor-char-index) - ) ;define-record-type - - ;; Pre-scan a UTF-8 bytevector to generate position vector - (define (make-string-positions bv) - (let ((len (bytevector-length bv))) - (let loop - ((pos 0) (result '(0))) - (if (>= pos len) - (list->vector (reverse result)) - (let ((next (bytevector-advance-utf8 bv pos len))) - (loop next (cons next result)) - ) ;let - ) ;if - ) ;let - ) ;let - ) ;define - - ;; ==== Cursor operations ==== - - (define (string-cursor-start str) - (let* ((bv (string->utf8 str)) - (off (make-string-offsets bv (make-string-positions bv))) - ) ; - (make-string-cursor-raw off 0) - ) ;let* - ) ;define - - (define (string-cursor-end str) - (let* ((bv (string->utf8 str)) - (off (make-string-offsets bv (make-string-positions bv))) - (positions (string-offsets-positions off)) - ) ; - (make-string-cursor-raw off (- (vector-length positions) 1)) - ) ;let* - ) ;define - - (define (string-cursor-next str cursor) - (let* ((c (if (string-cursor? cursor) cursor (string-index->cursor str cursor))) - (off (string-cursor-offsets c)) - (char-idx (string-cursor-char-index c)) - (positions (string-offsets-positions off)) - (max-idx (- (vector-length positions) 1)) - ) ; - (if (>= char-idx max-idx) - (error 'value-error "string-cursor-next: already at end cursor") - (let ((new-idx (+ char-idx 1))) - (if (string-cursor? cursor) (make-string-cursor-raw off new-idx) new-idx) - ) ;let - ) ;if - ) ;let* - ) ;define - - (define (string-cursor-prev str cursor) - (let* ((c (if (string-cursor? cursor) cursor (string-index->cursor str cursor))) - (off (string-cursor-offsets c)) - (char-idx (string-cursor-char-index c)) - ) ; - (if (<= char-idx 0) - (error 'value-error "string-cursor-prev: already at start cursor") - (let ((new-idx (- char-idx 1))) - (if (string-cursor? cursor) (make-string-cursor-raw off new-idx) new-idx) - ) ;let - ) ;if - ) ;let* - ) ;define - - (define (string-cursor-forward str cursor nchars) - (let* ((c (if (string-cursor? cursor) cursor (string-index->cursor str cursor))) - (off (string-cursor-offsets c)) - (char-idx (string-cursor-char-index c)) - (positions (string-offsets-positions off)) - (max-idx (- (vector-length positions) 1)) - (new-idx (+ char-idx nchars)) - ) ; - (if (or (< new-idx 0) (> new-idx max-idx)) - (error 'value-error "string-cursor-forward: result would be invalid cursor") - (if (string-cursor? cursor) (make-string-cursor-raw off new-idx) new-idx) - ) ;if - ) ;let* - ) ;define + ;; ==== Cursor representation ==== + ;; 核心原语由 src/liii_string_cursor.cpp 实现（g_* 函数）。 + ;; 游标表示为负整数 -(byte_offset+2)，即字节 0 对应 -2。 + ;; -1 不是合法游标，保留给"负索引"错误语义。 - (define (string-cursor-back str cursor nchars) - (string-cursor-forward str cursor (- nchars)) + (define (string-cursor? obj) + (and (integer? obj) (< obj -1)) ) ;define - (define (string-cursor=? cursor1 cursor2) - (let ((idx1 (if (string-cursor? cursor1) (string-cursor-char-index cursor1) cursor1)) - (idx2 (if (string-cursor? cursor2) (string-cursor-char-index cursor2) cursor2)) - ) ; - (= idx1 idx2) - ) ;let - ) ;define + (define string-cursor-start g_string-cursor-start) + (define string-cursor-end g_string-cursor-end) + (define string-cursor-next g_string-cursor-next) + (define string-cursor-prev g_string-cursor-prev) + (define string-cursor-forward g_string-cursor-forward) + (define string-cursor-back g_string-cursor-back) + (define string-cursor=? g_string-cursor=?) + (define string-cursor? g_string-cursor>?) + (define string-cursor<=? g_string-cursor<=?) + (define string-cursor>=? g_string-cursor>=?) + (define string-ref/cursor g_string-ref/cursor) - (define (string-cursor? cursor1 cursor2) - (let ((idx1 (if (string-cursor? cursor1) (string-cursor-char-index cursor1) cursor1)) - (idx2 (if (string-cursor? cursor2) (string-cursor-char-index cursor2) cursor2)) - ) ; - (> idx1 idx2) - ) ;let + ;; 将索引或游标统一转换为游标 + (define (as-cursor s x) + (cond ((string-cursor? x) x) + ((integer? x) (string-index->cursor s x)) + (else (error 'type-error "cursor argument must be integer or cursor")) + ) ;cond ) ;define - (define (string-cursor<=? cursor1 cursor2) - (let ((idx1 (if (string-cursor? cursor1) (string-cursor-char-index cursor1) cursor1)) - (idx2 (if (string-cursor? cursor2) (string-cursor-char-index cursor2) cursor2)) - ) ; - (<= idx1 idx2) - ) ;let + ;; 将索引或游标转换为游标，索引超出 char-len 时截断到 char-len + (define (as-cursor-clamped s x char-len) + (if (string-cursor? x) x (string-index->cursor s (min x char-len))) ) ;define - (define (string-cursor>=? cursor1 cursor2) - (let ((idx1 (if (string-cursor? cursor1) (string-cursor-char-index cursor1) cursor1)) - (idx2 (if (string-cursor? cursor2) (string-cursor-char-index cursor2) cursor2)) - ) ; - (>= idx1 idx2) - ) ;let + (define (validate-start-end start end) + (when (not (integer? start)) + (error 'type-error "start must be integer or cursor") + ) ;when + (when (not (integer? end)) + (error 'type-error "end must be integer or cursor") + ) ;when + (cond + ;; 两者均为负整数：游标模式 + ((and (string-cursor? start) (string-cursor? end)) + (when (string-cursor>? start end) + (error 'value-error "start must be <= end") + ) ;when + ) ; + ;; start 为负、end 为非负：按旧索引语义报 value-error + ((string-cursor? start) (error 'value-error "start must be >= 0")) + ;; start 为非负、end 为负：视为游标与索引混用 + ((string-cursor? end) + (error 'type-error "start and end must both be integer or both be cursor") + ) ; + ;; 两者均为非负整数：索引模式（-1 视为负索引） + (else (when (> start end) + (error 'value-error "start must be <= end") + ) ;when + (when (< start 0) + (error 'value-error "start must be >= 0") + ) ;when + (when (< end 0) + (error 'value-error "end must be >= 0") + ) ;when + ) ;else + ) ;cond ) ;define (define (string-cursor-diff str start end) (validate-start-end start end) - (let ((s-idx (if (string-cursor? start) (string-cursor-char-index start) start)) - (e-idx (if (string-cursor? end) (string-cursor-char-index end) end)) - ) ; - (- e-idx s-idx) - ) ;let + (g_string-cursor-diff str start end) ) ;define (define (string-cursor->index str cursor) - (if (string-cursor? cursor) (string-cursor-char-index cursor) cursor) + (g_string-cursor->index str cursor) ) ;define (define (string-index->cursor str index) - (if (string-cursor? index) - index - (let* ((bv (string->utf8 str)) - (off (make-string-offsets bv (make-string-positions bv))) - (positions (string-offsets-positions off)) - (max-idx (- (vector-length positions) 1)) - ) ; - (if (or (< index 0) (> index max-idx)) - (error 'value-error "string-index->cursor: index out of range") - (make-string-cursor-raw off index) - ) ;if - ) ;let* - ) ;if - ) ;define - - ;; ==== Helper functions ==== - - (define (cursor->index c) - (if (string-cursor? c) (string-cursor-char-index c) c) - ) ;define - - (define (validate-start-end start end) - (let ((start-cursor? (string-cursor? start)) (end-cursor? (string-cursor? end))) - (when (and (not start-cursor?) (not (integer? start))) - (error 'type-error "start must be integer or cursor") - ) ;when - (when (and (not end-cursor?) (not (integer? end))) - (error 'type-error "end must be integer or cursor") - ) ;when - (when (not (eq? start-cursor? end-cursor?)) - (error 'type-error "start and end must both be integer or both be cursor") - ) ;when - (let ((start-idx (if start-cursor? (string-cursor-char-index start) start)) - (end-idx (if end-cursor? (string-cursor-char-index end) end)) - ) ; - (when (> start-idx end-idx) - (error 'value-error "start must be <= end") - ) ;when - (when (< start-idx 0) - (error 'value-error "start must be >= 0") - ) ;when - (when (< end-idx 0) - (error 'value-error "end must be >= 0") - ) ;when - ) ;let - ) ;let + (g_string-index->cursor str index) ) ;define (define (list->utf8-string chars) @@ -293,79 +176,40 @@ ) ;let ) ;define - ;; ==== Selection ==== - - (define (string-ref/cursor str cursor) - (let* ((c (if (string-cursor? cursor) cursor (string-index->cursor str cursor))) - (off (string-cursor-offsets c)) - (bv (string-offsets-bv off)) - (pos (string-offsets-positions off)) - (idx (string-cursor-char-index c)) - (max-idx (- (vector-length pos) 1)) - (_ (when (>= idx max-idx) - (error 'value-error "string-ref/cursor: cursor at or past end of string") - ) ;when - ) ;_ - (start (vector-ref pos idx)) - ) ; - (integer->char (utf8->codepoint-at bv start)) - ) ;let* - ) ;define + ;; ==== Cursor operations (with validation) ==== (define (substring/cursors str start end) (validate-start-end start end) - (let* ((start-off (if (string-cursor? start) - (string-cursor-offsets start) - (let ((bv (string->utf8 str))) - (make-string-offsets bv (make-string-positions bv)) - ) ;let - ) ;if - ) ;start-off - (end-off (if (string-cursor? end) (string-cursor-offsets end) start-off)) - (pos (string-offsets-positions start-off)) - (bv (string-offsets-bv start-off)) - (start-idx (if (string-cursor? start) (string-cursor-char-index start) start)) - (end-idx (if (string-cursor? end) (string-cursor-char-index end) end)) - (max-idx (- (vector-length pos) 1)) - (_ (when (> end-idx max-idx) - (error 'value-error "substring/cursors: end index out of range") - ) ;when - ) ;_ - (byte-start (vector-ref pos start-idx)) - (byte-end (vector-ref pos end-idx)) - ) ; - (utf8->string (bytevector-copy bv byte-start byte-end)) - ) ;let* + (g_substring/cursors str start end) ) ;define + ;; ==== Selection ==== + (define (string-copy/cursors str . maybe-start+end) - (let* ((bv (string->utf8 str)) - (off (make-string-offsets bv (make-string-positions bv))) - (positions (string-offsets-positions off)) - (len (- (vector-length positions) 1)) - (end-c-raw (make-string-cursor-raw off len)) + (let* ((end-c (string-cursor-end str)) + (start (if (null? maybe-start+end) (string-cursor-start str) (car maybe-start+end)) + ) ;start + (rest (if (null? maybe-start+end) '() (cdr maybe-start+end))) + (end (if (null? rest) + (if (string-cursor? start) end-c (string-cursor->index str end-c)) + (car rest) + ) ;if + ) ;end ) ; - (if (null? maybe-start+end) - (substring/cursors str (make-string-cursor-raw off 0) end-c-raw) - (let ((start (car maybe-start+end)) (rest (cdr maybe-start+end))) - (let ((end (if (null? rest) (if (string-cursor? start) end-c-raw len) (car rest)))) - (substring/cursors str start end) - ) ;let - ) ;let - ) ;if + (substring/cursors str start end) ) ;let* ) ;define ;; ==== String operations ==== (define (string-take str nchars) - (let ((end (string-index->cursor str nchars))) + (let ((end (string-cursor-forward str (string-cursor-start str) nchars))) (substring/cursors str (string-cursor-start str) end) ) ;let ) ;define (define (string-drop str nchars) - (let ((start (string-index->cursor str nchars))) + (let ((start (string-cursor-forward str (string-cursor-start str) nchars))) (substring/cursors str start (string-cursor-end str)) ) ;let ) ;define @@ -389,14 +233,13 @@ ) ;define (define (string-every pred s . maybe-start+end) - (let* ((end-c-raw (string-cursor-end s)) - (char-len (string-cursor-char-index end-c-raw)) + (let* ((char-len (string-cursor->index s (string-cursor-end s))) (start (if (null? maybe-start+end) 0 (car maybe-start+end))) (rest (if (null? maybe-start+end) '() (cdr maybe-start+end))) (end (if (null? rest) char-len (car rest))) (_ (validate-start-end start end)) - (start-c (string-index->cursor s start)) - (end-c (string-index->cursor s end)) + (start-c (as-cursor s start)) + (end-c (as-cursor s end)) ) ; (let loop ((cur start-c)) @@ -416,14 +259,13 @@ ) ;define (define (string-any pred s . maybe-start+end) - (let* ((end-c-raw (string-cursor-end s)) - (char-len (string-cursor-char-index end-c-raw)) + (let* ((char-len (string-cursor->index s (string-cursor-end s))) (start (if (null? maybe-start+end) 0 (car maybe-start+end))) (rest (if (null? maybe-start+end) '() (cdr maybe-start+end))) (end (if (null? rest) char-len (car rest))) (_ (validate-start-end start end)) - (start-c (string-index->cursor s start)) - (end-c (string-index->cursor s end)) + (start-c (as-cursor s start)) + (end-c (as-cursor s end)) ) ; (let loop ((cur start-c)) @@ -440,14 +282,13 @@ ;; ==== Fold and iteration ==== (define (string-fold kons knil s . maybe-start+end) - (let* ((end-c-raw (string-cursor-end s)) - (char-len (string-cursor-char-index end-c-raw)) + (let* ((char-len (string-cursor->index s (string-cursor-end s))) (start (if (null? maybe-start+end) 0 (car maybe-start+end))) (rest (if (null? maybe-start+end) '() (cdr maybe-start+end))) (end (if (null? rest) char-len (car rest))) (_ (validate-start-end start end)) - (start-c (string-index->cursor s start)) - (end-c (string-index->cursor s end)) + (start-c (as-cursor s start)) + (end-c (as-cursor s end)) ) ; (let loop ((acc knil) (cur start-c)) @@ -460,14 +301,13 @@ ) ;define (define (string-fold-right kons knil s . maybe-start+end) - (let* ((end-c-raw (string-cursor-end s)) - (char-len (string-cursor-char-index end-c-raw)) + (let* ((char-len (string-cursor->index s (string-cursor-end s))) (start (if (null? maybe-start+end) 0 (car maybe-start+end))) (rest (if (null? maybe-start+end) '() (cdr maybe-start+end))) (end (if (null? rest) char-len (car rest))) (_ (validate-start-end start end)) - (start-c (string-index->cursor s start)) - (end-c (string-index->cursor s end)) + (start-c (as-cursor s start)) + (end-c (as-cursor s end)) ) ; ;; Non-recursive implementation using iteration (let ((chars (let collect @@ -490,14 +330,13 @@ ) ;define (define (string-for-each-cursor proc s . maybe-start+end) - (let* ((end-c-raw (string-cursor-end s)) - (char-len (string-cursor-char-index end-c-raw)) + (let* ((char-len (string-cursor->index s (string-cursor-end s))) (start (if (null? maybe-start+end) 0 (car maybe-start+end))) (rest (if (null? maybe-start+end) '() (cdr maybe-start+end))) (end (if (null? rest) char-len (car rest))) (_ (validate-start-end start end)) - (start-c (string-index->cursor s start)) - (end-c (string-index->cursor s end)) + (start-c (as-cursor s start)) + (end-c (as-cursor s end)) ) ; (let loop ((cur start-c)) @@ -510,14 +349,13 @@ ) ;define (define (string-count pred s . maybe-start+end) - (let* ((end-c-raw (string-cursor-end s)) - (char-len (string-cursor-char-index end-c-raw)) + (let* ((char-len (string-cursor->index s (string-cursor-end s))) (start (if (null? maybe-start+end) 0 (car maybe-start+end))) (rest (if (null? maybe-start+end) '() (cdr maybe-start+end))) (end (if (null? rest) char-len (car rest))) (_ (validate-start-end start end)) - (start-c (string-index->cursor s start)) - (end-c (string-index->cursor s end)) + (start-c (as-cursor s start)) + (end-c (as-cursor s end)) ) ; (let loop ((cur start-c) (count 0)) @@ -534,14 +372,13 @@ ;; ==== Searching ==== (define (string-index s pred . maybe-start+end) - (let* ((end-c-raw (string-cursor-end s)) - (char-len (string-cursor-char-index end-c-raw)) + (let* ((char-len (string-cursor->index s (string-cursor-end s))) (start (if (null? maybe-start+end) 0 (car maybe-start+end))) (rest (if (null? maybe-start+end) '() (cdr maybe-start+end))) (end (if (null? rest) char-len (car rest))) (_ (validate-start-end start end)) - (start-c (string-index->cursor s start)) - (end-c (string-index->cursor s end)) + (start-c (as-cursor s start)) + (end-c (as-cursor s end)) ) ; (let loop ((cur start-c)) @@ -554,14 +391,13 @@ ) ;define (define (string-index-right s pred . maybe-start+end) - (let* ((end-c-raw (string-cursor-end s)) - (char-len (string-cursor-char-index end-c-raw)) + (let* ((char-len (string-cursor->index s (string-cursor-end s))) (start (if (null? maybe-start+end) 0 (car maybe-start+end))) (rest (if (null? maybe-start+end) '() (cdr maybe-start+end))) (end (if (null? rest) char-len (car rest))) (_ (validate-start-end start end)) - (start-c (string-index->cursor s start)) - (end-c (string-index->cursor s end)) + (start-c (as-cursor s start)) + (end-c (as-cursor s end)) ) ; (if (string-cursor=? start-c end-c) start-c @@ -577,14 +413,13 @@ ) ;define (define (string-skip s pred . maybe-start+end) - (let* ((end-c-raw (string-cursor-end s)) - (char-len (string-cursor-char-index end-c-raw)) + (let* ((char-len (string-cursor->index s (string-cursor-end s))) (start (if (null? maybe-start+end) 0 (car maybe-start+end))) (rest (if (null? maybe-start+end) '() (cdr maybe-start+end))) (end (if (null? rest) char-len (car rest))) (_ (validate-start-end start end)) - (start-c (string-index->cursor s start)) - (end-c (string-index->cursor s end)) + (start-c (as-cursor s start)) + (end-c (as-cursor s end)) ) ; (let loop ((cur start-c)) @@ -597,14 +432,13 @@ ) ;define (define (string-skip-right s pred . maybe-start+end) - (let* ((end-c-raw (string-cursor-end s)) - (char-len (string-cursor-char-index end-c-raw)) + (let* ((char-len (string-cursor->index s (string-cursor-end s))) (start (if (null? maybe-start+end) 0 (car maybe-start+end))) (rest (if (null? maybe-start+end) '() (cdr maybe-start+end))) (end (if (null? rest) char-len (car rest))) (_ (validate-start-end start end)) - (start-c (string-index->cursor s start)) - (end-c (string-index->cursor s end)) + (start-c (as-cursor s start)) + (end-c (as-cursor s end)) ) ; (if (string-cursor=? start-c end-c) start-c @@ -622,12 +456,11 @@ ;; ==== Trim and Pad ==== (define* (string-trim s (pred char-whitespace?) (start 0) (end #t)) - (let* ((end-c-raw (string-cursor-end s)) - (char-len (string-cursor-char-index end-c-raw)) + (let* ((char-len (string-cursor->index s (string-cursor-end s))) (end-idx (if (eq? end #t) char-len end)) (_ (validate-start-end start end-idx)) - (start-c (string-index->cursor s start)) - (end-c (string-index->cursor s end-idx)) + (start-c (as-cursor s start)) + (end-c (as-cursor s end-idx)) ) ; (let ((trimmed-start (string-skip s pred start-c end-c))) (substring/cursors s trimmed-start end-c) @@ -636,12 +469,11 @@ ) ;define* (define* (string-trim-right s (pred char-whitespace?) (start 0) (end #t)) - (let* ((end-c-raw (string-cursor-end s)) - (char-len (string-cursor-char-index end-c-raw)) + (let* ((char-len (string-cursor->index s (string-cursor-end s))) (end-idx (if (eq? end #t) char-len end)) (_ (validate-start-end start end-idx)) - (start-c (string-index->cursor s start)) - (end-c (string-index->cursor s end-idx)) + (start-c (as-cursor s start)) + (end-c (as-cursor s end-idx)) ) ; (let ((trimmed-end (string-skip-right s pred start-c end-c))) (substring/cursors s start-c trimmed-end) @@ -650,12 +482,11 @@ ) ;define* (define* (string-trim-both s (pred char-whitespace?) (start 0) (end #t)) - (let* ((end-c-raw (string-cursor-end s)) - (char-len (string-cursor-char-index end-c-raw)) + (let* ((char-len (string-cursor->index s (string-cursor-end s))) (end-idx (if (eq? end #t) char-len end)) (_ (validate-start-end start end-idx)) - (start-c (string-index->cursor s start)) - (end-c (string-index->cursor s end-idx)) + (start-c (as-cursor s start)) + (end-c (as-cursor s end-idx)) ) ; (let ((trimmed-start (string-skip s pred start-c end-c)) (trimmed-end (string-skip-right s pred start-c end-c)) @@ -669,37 +500,35 @@ ) ;define* (define* (string-pad s len (char #\space) (start 0) (end #t)) - (let* ((end-c-raw (string-cursor-end s)) - (char-len (string-cursor-char-index end-c-raw)) + (let* ((char-len (string-cursor->index s (string-cursor-end s))) (end-idx (if (eq? end #t) char-len end)) (_ (validate-start-end start end-idx)) - (start-c (string-index->cursor s start)) - (end-c (string-index->cursor s end-idx)) - (sub (substring/cursors s start-c end-c)) - (sub-len (string-cursor-diff sub (string-cursor-start sub) (string-cursor-end sub)) - ) ;sub-len + (start-c (as-cursor s start)) + (end-c (as-cursor s end-idx)) + (sub-len (string-cursor-diff s start-c end-c)) ) ; (if (>= sub-len len) - (string-take-right sub len) - (string-append (make-string (- len sub-len) char) sub) + (string-take-right (substring/cursors s start-c end-c) len) + (string-append (make-string (- len sub-len) char) + (substring/cursors s start-c end-c) + ) ;string-append ) ;if ) ;let* ) ;define* (define* (string-pad-right s len (char #\space) (start 0) (end #t)) - (let* ((end-c-raw (string-cursor-end s)) - (char-len (string-cursor-char-index end-c-raw)) + (let* ((char-len (string-cursor->index s (string-cursor-end s))) (end-idx (if (eq? end #t) char-len end)) (_ (validate-start-end start end-idx)) - (start-c (string-index->cursor s start)) - (end-c (string-index->cursor s end-idx)) - (sub (substring/cursors s start-c end-c)) - (sub-len (string-cursor-diff sub (string-cursor-start sub) (string-cursor-end sub)) - ) ;sub-len + (start-c (as-cursor s start)) + (end-c (as-cursor s end-idx)) + (sub-len (string-cursor-diff s start-c end-c)) ) ; (if (>= sub-len len) - (string-take sub len) - (string-append sub (make-string (- len sub-len) char)) + (string-take (substring/cursors s start-c end-c) len) + (string-append (substring/cursors s start-c end-c) + (make-string (- len sub-len) char) + ) ;string-append ) ;if ) ;let* ) ;define* @@ -707,10 +536,8 @@ ;; ==== Prefix and Suffix ==== (define (string-prefix-length s1 s2 . maybe-start+end) - (let* ((end1-c-raw (string-cursor-end s1)) - (char-len1 (string-cursor-char-index end1-c-raw)) - (end2-c-raw (string-cursor-end s2)) - (char-len2 (string-cursor-char-index end2-c-raw)) + (let* ((char-len1 (string-cursor->index s1 (string-cursor-end s1))) + (char-len2 (string-cursor->index s2 (string-cursor-end s2))) (start1 (if (null? maybe-start+end) 0 (car maybe-start+end))) (rest1 (if (null? maybe-start+end) '() (cdr maybe-start+end))) (end1 (if (null? rest1) char-len1 (car rest1))) @@ -720,38 +547,27 @@ (end2 (if (null? rest3) char-len2 (car rest3))) (_ (validate-start-end start1 end1)) (_ (validate-start-end start2 end2)) - (start1-idx (cursor->index start1)) - (end1-idx (min (cursor->index end1) char-len1)) - (start2-idx (cursor->index start2)) - (end2-idx (min (cursor->index end2) char-len2)) - (off1 (string-cursor-offsets end1-c-raw)) - (pos1 (string-offsets-positions off1)) - (bv1 (string-offsets-bv off1)) - (off2 (string-cursor-offsets end2-c-raw)) - (pos2 (string-offsets-positions off2)) - (bv2 (string-offsets-bv off2)) + (start1-c (as-cursor-clamped s1 start1 char-len1)) + (end1-c (as-cursor-clamped s1 end1 char-len1)) + (start2-c (as-cursor-clamped s2 start2 char-len2)) + (end2-c (as-cursor-clamped s2 end2 char-len2)) ) ; (let loop - ((i start1-idx) (j start2-idx) (count 0)) - (if (or (>= i end1-idx) (>= j end2-idx)) + ((i start1-c) (j start2-c) (count 0)) + (if (or (string-cursor>=? i end1-c) (string-cursor>=? j end2-c)) count - (let* ((b1-start (vector-ref pos1 i)) - (ch1 (integer->char (utf8->codepoint-at bv1 b1-start))) - (b2-start (vector-ref pos2 j)) - (ch2 (integer->char (utf8->codepoint-at bv2 b2-start))) - ) ; - (if (char=? ch1 ch2) (loop (+ i 1) (+ j 1) (+ count 1)) count) - ) ;let* + (if (char=? (string-ref/cursor s1 i) (string-ref/cursor s2 j)) + (loop (string-cursor-next s1 i) (string-cursor-next s2 j) (+ count 1)) + count + ) ;if ) ;if ) ;let ) ;let* ) ;define (define (string-suffix-length s1 s2 . maybe-start+end) - (let* ((end1-c-raw (string-cursor-end s1)) - (char-len1 (string-cursor-char-index end1-c-raw)) - (end2-c-raw (string-cursor-end s2)) - (char-len2 (string-cursor-char-index end2-c-raw)) + (let* ((char-len1 (string-cursor->index s1 (string-cursor-end s1))) + (char-len2 (string-cursor->index s2 (string-cursor-end s2))) (start1 (if (null? maybe-start+end) 0 (car maybe-start+end))) (rest1 (if (null? maybe-start+end) '() (cdr maybe-start+end))) (end1 (if (null? rest1) char-len1 (car rest1))) @@ -761,38 +577,32 @@ (end2 (if (null? rest3) char-len2 (car rest3))) (_ (validate-start-end start1 end1)) (_ (validate-start-end start2 end2)) - (start1-idx (cursor->index start1)) - (end1-idx (min (cursor->index end1) char-len1)) - (start2-idx (cursor->index start2)) - (end2-idx (min (cursor->index end2) char-len2)) - (off1 (string-cursor-offsets end1-c-raw)) - (pos1 (string-offsets-positions off1)) - (bv1 (string-offsets-bv off1)) - (off2 (string-cursor-offsets end2-c-raw)) - (pos2 (string-offsets-positions off2)) - (bv2 (string-offsets-bv off2)) + (start1-c (as-cursor-clamped s1 start1 char-len1)) + (end1-c (as-cursor-clamped s1 end1 char-len1)) + (start2-c (as-cursor-clamped s2 start2 char-len2)) + (end2-c (as-cursor-clamped s2 end2 char-len2)) ) ; (let loop - ((i (- end1-idx 1)) (j (- end2-idx 1)) (count 0)) - (if (or (< i start1-idx) (< j start2-idx)) - count - (let* ((b1-start (vector-ref pos1 i)) - (ch1 (integer->char (utf8->codepoint-at bv1 b1-start))) - (b2-start (vector-ref pos2 j)) - (ch2 (integer->char (utf8->codepoint-at bv2 b2-start))) - ) ; - (if (char=? ch1 ch2) (loop (- i 1) (- j 1) (+ count 1)) count) - ) ;let* - ) ;if + ((i end1-c) (j end2-c) (count 0)) + (let ((i2 (if (string-cursor>? i start1-c) (string-cursor-prev s1 i) i)) + (j2 (if (string-cursor>? j start2-c) (string-cursor-prev s2 j) j)) + ) ; + (if (or (string-cursor=? i i2) (string-cursor=? j j2)) + ;; 某一侧已无法后退（到 start），停止 + count + (if (char=? (string-ref/cursor s1 i2) (string-ref/cursor s2 j2)) + (loop i2 j2 (+ count 1)) + count + ) ;if + ) ;if + ) ;let ) ;let ) ;let* ) ;define (define (string-prefix? s1 s2 . maybe-start+end) - (let* ((end1-c-raw (string-cursor-end s1)) - (char-len1 (string-cursor-char-index end1-c-raw)) - (end2-c-raw (string-cursor-end s2)) - (char-len2 (string-cursor-char-index end2-c-raw)) + (let* ((char-len1 (string-cursor->index s1 (string-cursor-end s1))) + (char-len2 (string-cursor->index s2 (string-cursor-end s2))) (start1 (if (null? maybe-start+end) 0 (car maybe-start+end))) (rest1 (if (null? maybe-start+end) '() (cdr maybe-start+end))) (end1 (if (null? rest1) char-len1 (car rest1))) @@ -802,10 +612,18 @@ (end2 (if (null? rest3) char-len2 (car rest3))) (_ (validate-start-end start1 end1)) (_ (validate-start-end start2 end2)) - (start1-idx (cursor->index start1)) - (end1-idx (min (cursor->index end1) char-len1)) - (start2-idx (cursor->index start2)) - (end2-idx (min (cursor->index end2) char-len2)) + (start1-idx (min (if (string-cursor? start1) (string-cursor->index s1 start1) start1) + char-len1 + ) ;min + ) ;start1-idx + (end1-idx (min (if (string-cursor? end1) (string-cursor->index s1 end1) end1) char-len1) + ) ;end1-idx + (start2-idx (min (if (string-cursor? start2) (string-cursor->index s2 start2) start2) + char-len2 + ) ;min + ) ;start2-idx + (end2-idx (min (if (string-cursor? end2) (string-cursor->index s2 end2) end2) char-len2) + ) ;end2-idx ) ; (let ((len1 (- end1-idx start1-idx))) (and (<= len1 (- end2-idx start2-idx)) @@ -816,10 +634,8 @@ ) ;define (define (string-suffix? s1 s2 . maybe-start+end) - (let* ((end1-c-raw (string-cursor-end s1)) - (char-len1 (string-cursor-char-index end1-c-raw)) - (end2-c-raw (string-cursor-end s2)) - (char-len2 (string-cursor-char-index end2-c-raw)) + (let* ((char-len1 (string-cursor->index s1 (string-cursor-end s1))) + (char-len2 (string-cursor->index s2 (string-cursor-end s2))) (start1 (if (null? maybe-start+end) 0 (car maybe-start+end))) (rest1 (if (null? maybe-start+end) '() (cdr maybe-start+end))) (end1 (if (null? rest1) char-len1 (car rest1))) @@ -829,10 +645,18 @@ (end2 (if (null? rest3) char-len2 (car rest3))) (_ (validate-start-end start1 end1)) (_ (validate-start-end start2 end2)) - (start1-idx (cursor->index start1)) - (end1-idx (min (cursor->index end1) char-len1)) - (start2-idx (cursor->index start2)) - (end2-idx (min (cursor->index end2) char-len2)) + (start1-idx (min (if (string-cursor? start1) (string-cursor->index s1 start1) start1) + char-len1 + ) ;min + ) ;start1-idx + (end1-idx (min (if (string-cursor? end1) (string-cursor->index s1 end1) end1) char-len1) + ) ;end1-idx + (start2-idx (min (if (string-cursor? start2) (string-cursor->index s2 start2) start2) + char-len2 + ) ;min + ) ;start2-idx + (end2-idx (min (if (string-cursor? end2) (string-cursor->index s2 end2) end2) char-len2) + ) ;end2-idx ) ; (let ((len1 (- end1-idx start1-idx))) (and (<= len1 (- end2-idx start2-idx)) @@ -844,29 +668,23 @@ ;; ==== Contains ==== - (define (string-prefix-at? s1 s2 s1-pos s2-start s2-end off1 pos1 bv1 off2 pos2 bv2) - ;; Check if s2[s2-start:s2-end] matches s1 at character position s1-pos - ;; Uses pre-computed offsets for O(m) comparison without re-scanning + ;; Check if s2[s2-start:s2-end] matches s1 at cursor s1-pos + (define (string-prefix-at? s1 s2 s1-pos s2-start s2-end) (let loop ((i s1-pos) (j s2-start)) - (if (>= j s2-end) + (if (string-cursor>=? j s2-end) #t - (let* ((b1-start (vector-ref pos1 i)) - (ch1 (integer->char (utf8->codepoint-at bv1 b1-start))) - (b2-start (vector-ref pos2 j)) - (ch2 (integer->char (utf8->codepoint-at bv2 b2-start))) - ) ; - (if (char=? ch1 ch2) (loop (+ i 1) (+ j 1)) #f) - ) ;let* + (if (char=? (string-ref/cursor s1 i) (string-ref/cursor s2 j)) + (loop (string-cursor-next s1 i) (string-cursor-next s2 j)) + #f + ) ;if ) ;if ) ;let ) ;define (define (string-contains s1 s2 . maybe-start+end) - (let* ((end1-c-raw (string-cursor-end s1)) - (char-len1 (string-cursor-char-index end1-c-raw)) - (end2-c-raw (string-cursor-end s2)) - (char-len2 (string-cursor-char-index end2-c-raw)) + (let* ((char-len1 (string-cursor->index s1 (string-cursor-end s1))) + (char-len2 (string-cursor->index s2 (string-cursor-end s2))) (start1 (if (null? maybe-start+end) 0 (car maybe-start+end))) (rest1 (if (null? maybe-start+end) '() (cdr maybe-start+end))) (end1 (if (null? rest1) char-len1 (car rest1))) @@ -876,40 +694,36 @@ (end2 (if (null? rest3) char-len2 (car rest3))) (_ (validate-start-end start1 end1)) (_ (validate-start-end start2 end2)) - (start1-idx (cursor->index start1)) - (end1-idx (min (cursor->index end1) char-len1)) - (start2-idx (cursor->index start2)) - (end2-idx (min (cursor->index end2) char-len2)) - (off1 (string-cursor-offsets end1-c-raw)) - (pos1 (string-offsets-positions off1)) - (bv1 (string-offsets-bv off1)) - (off2 (string-cursor-offsets end2-c-raw)) - (pos2 (string-offsets-positions off2)) - (bv2 (string-offsets-bv off2)) + (start1-c (as-cursor s1 start1)) + (end1-c (as-cursor-clamped s1 end1 char-len1)) + (start2-c (as-cursor s2 start2)) + (end2-c (as-cursor-clamped s2 end2 char-len2)) + (s2-len (string-cursor-diff s2 start2-c end2-c)) ) ; - (let ((s2-len (- end2-idx start2-idx))) - (if (zero? s2-len) - (string-index->cursor s1 start1-idx) - (let loop - ((i start1-idx)) - (if (> (+ i s2-len) end1-idx) - #f - (if (string-prefix-at? s1 s2 i start2-idx end2-idx off1 pos1 bv1 off2 pos2 bv2) - (string-index->cursor s1 i) - (loop (+ i 1)) + (if (zero? s2-len) + start1-c + (if (< (string-cursor-diff s1 start1-c end1-c) s2-len) + #f + (let ((limit (string-cursor-back s1 end1-c s2-len))) + (let loop + ((i start1-c)) + (if (string-cursor>? i limit) + #f + (if (string-prefix-at? s1 s2 i start2-c end2-c) + i + (loop (string-cursor-next s1 i)) + ) ;if ) ;if - ) ;if + ) ;let ) ;let ) ;if - ) ;let + ) ;if ) ;let* ) ;define (define (string-contains-right s1 s2 . maybe-start+end) - (let* ((end1-c-raw (string-cursor-end s1)) - (char-len1 (string-cursor-char-index end1-c-raw)) - (end2-c-raw (string-cursor-end s2)) - (char-len2 (string-cursor-char-index end2-c-raw)) + (let* ((char-len1 (string-cursor->index s1 (string-cursor-end s1))) + (char-len2 (string-cursor->index s2 (string-cursor-end s2))) (start1 (if (null? maybe-start+end) 0 (car maybe-start+end))) (rest1 (if (null? maybe-start+end) '() (cdr maybe-start+end))) (end1 (if (null? rest1) char-len1 (car rest1))) @@ -919,32 +733,29 @@ (end2 (if (null? rest3) char-len2 (car rest3))) (_ (validate-start-end start1 end1)) (_ (validate-start-end start2 end2)) - (start1-idx (cursor->index start1)) - (end1-idx (min (cursor->index end1) char-len1)) - (start2-idx (cursor->index start2)) - (end2-idx (min (cursor->index end2) char-len2)) - (off1 (string-cursor-offsets end1-c-raw)) - (pos1 (string-offsets-positions off1)) - (bv1 (string-offsets-bv off1)) - (off2 (string-cursor-offsets end2-c-raw)) - (pos2 (string-offsets-positions off2)) - (bv2 (string-offsets-bv off2)) + (start1-c (as-cursor s1 start1)) + (end1-c (as-cursor-clamped s1 end1 char-len1)) + (start2-c (as-cursor s2 start2)) + (end2-c (as-cursor-clamped s2 end2 char-len2)) + (s2-len (string-cursor-diff s2 start2-c end2-c)) ) ; - (let ((s2-len (- end2-idx start2-idx))) - (if (zero? s2-len) - (string-index->cursor s1 end1-idx) - (let loop - ((i (- end1-idx s2-len))) - (if (< i start1-idx) - #f - (if (string-prefix-at? s1 s2 i start2-idx end2-idx off1 pos1 bv1 off2 pos2 bv2) - (string-index->cursor s1 i) - (loop (- i 1)) - ) ;if - ) ;if + (if (zero? s2-len) + end1-c + (if (< (string-cursor-diff s1 start1-c end1-c) s2-len) + #f + (let ((limit (string-cursor-back s1 end1-c s2-len))) + (let loop + ((i limit)) + (cond ((string-cursorindex final (string-cursor-end final)) (car rest) ) ;if ) ;end - (end-idx (cursor->index end)) + (end-idx (if (string-cursor? end) (string-cursor->index final end) end)) (final-part (substring/cursors final 0 end-idx)) ) ; (let* ((all-strings (reverse (cons final-part string-list))) @@ -972,16 +783,13 @@ ) ;define (define (string-reverse s . maybe-start+end) - (let* ((end-c-raw (string-cursor-end s)) - (char-len (string-cursor-char-index end-c-raw)) + (let* ((char-len (string-cursor->index s (string-cursor-end s))) (start (if (null? maybe-start+end) 0 (car maybe-start+end))) (rest (if (null? maybe-start+end) '() (cdr maybe-start+end))) (end (if (null? rest) char-len (car rest))) (_ (validate-start-end start end)) - (start-idx (cursor->index start)) - (end-idx (min (cursor->index end) char-len)) - (start-c (string-index->cursor s start-idx)) - (end-c (string-index->cursor s end-idx)) + (start-c (as-cursor s start)) + (end-c (as-cursor s end)) ) ; (let loop ((cur start-c) (result '())) @@ -994,30 +802,19 @@ ) ;define (define (string-replicate s from . maybe-to+start+end) - (when (string-cursor? from) - (error 'type-error "string-replicate: from cannot be a cursor") - ) ;when (when (null? maybe-to+start+end) (error 'value-error "string-replicate: to argument is required") ) ;when - (let* ((end-c-raw (string-cursor-end s)) - (char-len (string-cursor-char-index end-c-raw)) + (let* ((char-len (string-cursor->index s (string-cursor-end s))) (to (car maybe-to+start+end)) (start (if (null? (cdr maybe-to+start+end)) 0 (cadr maybe-to+start+end))) (rest1 (if (null? (cdr maybe-to+start+end)) '() (cddr maybe-to+start+end))) (end (if (null? rest1) char-len (car rest1))) - (_ (when (string-cursor? to) - (error 'type-error "string-replicate: to cannot be a cursor") - ) ;when - ) ;_ (_ (validate-start-end start end)) - (start-idx (cursor->index start)) - (end-idx (cursor->index end)) - (from-idx from) - (to-idx to) - (slen (- end-idx start-idx)) - (anslen (- to-idx from-idx)) - (start-c (string-index->cursor s start-idx)) + (start-c (as-cursor s start)) + (end-c (as-cursor s end)) + (slen (string-cursor-diff s start-c end-c)) + (anslen (- to from)) (source-chars (let loop ((cur start-c) (n 0) (result '())) (if (>= n slen) @@ -1030,7 +827,7 @@ ) ;let ) ;source-chars ) ; - (when (> from-idx to-idx) + (when (> from to) (error 'value-error "string-replicate: from > to") ) ;when (cond ((zero? anslen) "") @@ -1039,7 +836,7 @@ ((i 0) (result '())) (if (>= i anslen) (list->utf8-string (reverse result)) - (let ((ch (vector-ref source-chars (modulo (+ from-idx i) slen)))) + (let ((ch (vector-ref source-chars (modulo (+ from i) slen)))) (loop (+ i 1) (cons ch result)) ) ;let ) ;if @@ -1050,43 +847,35 @@ ) ;define (define (string-replace s1 s2 start1 end1 . maybe-start+end) - (let* ((end1-c-raw (string-cursor-end s1)) - (char-len1 (string-cursor-char-index end1-c-raw)) - (end2-c-raw (string-cursor-end s2)) - (char-len2 (string-cursor-char-index end2-c-raw)) + (let* ((char-len1 (string-cursor->index s1 (string-cursor-end s1))) + (char-len2 (string-cursor->index s2 (string-cursor-end s2))) (start2 (if (null? maybe-start+end) 0 (car maybe-start+end))) (rest (if (null? maybe-start+end) '() (cdr maybe-start+end))) (end2 (if (null? rest) char-len2 (car rest))) (_ (validate-start-end start1 end1)) (_ (validate-start-end start2 end2)) - (start1-idx (cursor->index start1)) - (end1-idx (cursor->index end1)) - (start2-idx (cursor->index start2)) - (end2-idx (cursor->index end2)) - (before (substring/cursors s1 0 start1-idx)) - (middle (substring/cursors s2 start2-idx end2-idx)) - (after (substring/cursors s1 end1-idx char-len1)) + (before (substring/cursors s1 (as-cursor s1 0) (as-cursor s1 start1))) + (middle (substring/cursors s2 (as-cursor s2 start2) (as-cursor s2 end2))) + (after (substring/cursors s1 (as-cursor s1 end1) (as-cursor s1 char-len1))) ) ; (string-append before middle after) ) ;let* ) ;define (define (string-split s delimiter . args) - (let* ((slen (string-cursor-char-index (string-cursor-end s))) + (let* ((char-len (string-cursor->index s (string-cursor-end s))) (grammar (if (null? args) 'infix (car args))) (rest1 (if (null? args) '() (cdr args))) (limit (if (null? rest1) #f (car rest1))) (rest2 (if (null? rest1) '() (cdr rest1))) (start (if (null? rest2) 0 (car rest2))) (rest3 (if (null? rest2) '() (cdr rest2))) - (end (if (null? rest3) slen (car rest3))) + (end (if (null? rest3) char-len (car rest3))) (_ (validate-start-end start end)) - (start-idx (cursor->index start)) - (end-idx (cursor->index end)) - (start-c (string-index->cursor s start-idx)) - (end-c (string-index->cursor s end-idx)) + (start-c (as-cursor s start)) + (end-c (as-cursor s end)) ) ; - (cond ((= start-idx end-idx) + (cond ((= start end) (if (eq? grammar 'strict-infix) (error 'value-error "empty string cannot be split with strict-infix grammar") '() @@ -1107,7 +896,7 @@ ) ;cond ) ;let ) ; - (else (let ((dlen (string-cursor-char-index (string-cursor-end delimiter)))) + (else (let ((dlen (string-cursor->index delimiter (string-cursor-end delimiter)))) (define (finish r c) (let ((rest-str (substring/cursors s c end-c))) (if (and (eq? grammar 'suffix) (string-null? rest-str)) @@ -1140,16 +929,13 @@ ) ;define (define (string-filter pred s . maybe-start+end) - (let* ((end-c-raw (string-cursor-end s)) - (char-len (string-cursor-char-index end-c-raw)) + (let* ((char-len (string-cursor->index s (string-cursor-end s))) (start (if (null? maybe-start+end) 0 (car maybe-start+end))) (rest (if (null? maybe-start+end) '() (cdr maybe-start+end))) (end (if (null? rest) char-len (car rest))) (_ (validate-start-end start end)) - (start-idx (cursor->index start)) - (end-idx (cursor->index end)) - (start-c (string-index->cursor s start-idx)) - (end-c (string-index->cursor s end-idx)) + (start-c (as-cursor s start)) + (end-c (as-cursor s end)) ) ; (let loop ((cur start-c) (result '())) @@ -1167,16 +953,13 @@ ) ;define (define (string-remove pred s . maybe-start+end) - (let* ((end-c-raw (string-cursor-end s)) - (char-len (string-cursor-char-index end-c-raw)) + (let* ((char-len (string-cursor->index s (string-cursor-end s))) (start (if (null? maybe-start+end) 0 (car maybe-start+end))) (rest (if (null? maybe-start+end) '() (cdr maybe-start+end))) (end (if (null? rest) char-len (car rest))) (_ (validate-start-end start end)) - (start-idx (cursor->index start)) - (end-idx (cursor->index end)) - (start-c (string-index->cursor s start-idx)) - (end-c (string-index->cursor s end-idx)) + (start-c (as-cursor s start)) + (end-c (as-cursor s end)) ) ; (let loop ((cur start-c) (result '())) @@ -1238,16 +1021,13 @@ ;; ==== Conversion ==== (define (string->list/cursors s . maybe-start+end) - (let* ((end-c-raw (string-cursor-end s)) - (char-len (string-cursor-char-index end-c-raw)) + (let* ((char-len (string-cursor->index s (string-cursor-end s))) (start (if (null? maybe-start+end) 0 (car maybe-start+end))) (rest (if (null? maybe-start+end) '() (cdr maybe-start+end))) (end (if (null? rest) char-len (car rest))) (_ (validate-start-end start end)) - (start-idx (cursor->index start)) - (end-idx (cursor->index end)) - (start-c (string-index->cursor s start-idx)) - (end-c (string-index->cursor s end-idx)) + (start-c (as-cursor s start)) + (end-c (as-cursor s end)) ) ; (let loop ((cur start-c) (result '())) diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/string.scm b/TeXmacs/plugins/goldfish/goldfish/liii/string.scm index f251a1b798..be0dce4e61 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/string.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/string.scm @@ -1,39 +1,12 @@ (define-library (liii string) - (export string-null? - string-join - string-every - string-any - string-take - string-take-right - string-drop - string-drop-right - string-pad - string-pad-right - string-trim - string-trim-left - string-trim-right - string-trim-both - string-index - string-index-right - string-skip - string-skip-right - string-contains - string-count - string-fold - string-fold-right - string-for-each-index - string-reverse - string-tokenize - string-starts? - string-contains? - string-ends? - string-split - string-replace - string-remove-prefix - string-remove-suffix - pyfmt - string-position - char-position + (export string-null? string-join string-every string-any string-take + string-take-right string-drop string-drop-right string-pad string-pad-right + string-trim string-trim-left string-trim-right string-trim-both string-index + string-index-right string-skip string-skip-right string-contains + string-count string-fold string-fold-right string-for-each-index + string-reverse string-tokenize string-starts? string-contains? string-ends? + string-split string-replace string-remove-prefix string-remove-suffix pyfmt + string-position char-position ) ;export (import (except (srfi srfi-13) string-replace) (scheme base) @@ -47,124 +20,17 @@ ;; ; 基于 SRFI-13 的 string-trim 实现 (define string-trim-left string-trim) - (define (string-starts? str prefix) - (if (and (string? str) (string? prefix)) - (string-prefix? prefix str) - (type-error "string-starts? parameter is not a string") - ) ;if - ) ;define + (define string-starts? g_string-starts?) (define string-contains? (typed-lambda ((str string?) (sub-str string?)) (string-contains str sub-str)) ) ;define - (define (string-split str sep) - (define (split-characters input) - (let ((input-len (utf8-string-length input))) - (let loop - ((i 0) (parts '())) - (if (= i input-len) - (reverse parts) - (loop (+ i 1) (cons (utf8-substring input i (+ i 1)) parts)) - ) ;if - ) ;let - ) ;let - ) ;define + (define string-split g_string-split) - (when (not (string? str)) - (type-error "string-split: first parameter must be string") - ) ;when - - (let* ((sep-str (cond ((string? sep) sep) - ((char? sep) (string sep)) - (else (type-error "string-split: second parameter must be string or char")) - ) ;cond - ) ;sep-str - (str-len (string-length str)) - (sep-len (string-length sep-str)) - ) ; - (if (zero? sep-len) - (split-characters str) - (let loop - ((search-start 0) (parts '())) - (let ((next-pos (string-position sep-str str search-start))) - (if next-pos - (loop (+ next-pos sep-len) (cons (substring str search-start next-pos) parts)) - (reverse (cons (substring str search-start str-len) parts)) - ) ;if - ) ;let - ) ;let - ) ;if - ) ;let* - ) ;define + (define string-replace g_string-replace) - (define (string-replace str old new . rest) - (when (> (length rest) 1) - (error 'wrong-number-of-args "string-replace: too many arguments") - ) ;when - (unless (string? str) - (type-error "string-replace: str must be a string") - ) ;unless - (unless (string? old) - (type-error "string-replace: old must be a string") - ) ;unless - (unless (string? new) - (type-error "string-replace: new must be a string") - ) ;unless - (let ((count (if (null? rest) -1 (car rest)))) - (unless (integer? count) - (type-error "string-replace: count must be an integer") - ) ;unless - (let ((str-len (string-length str)) (old-len (string-length old))) - (cond ((zero? count) (string-copy str)) - ((zero? old-len) - (if (zero? str-len) - new - (let* ((max-inserts (+ str-len 1)) - (remaining (if (negative? count) max-inserts (min count max-inserts))) - ) ; - (let loop - ((i 0) (acc '()) (r remaining)) - (cond ((and (= i str-len) (> r 0)) (apply string-append (reverse (cons new acc)))) - ((= i str-len) (apply string-append (reverse acc))) - ((zero? r) (apply string-append (reverse (cons (substring str i str-len) acc)))) - (else (loop (+ i 1) (cons (substring str i (+ i 1)) (cons new acc)) (- r 1))) - ) ;cond - ) ;let - ) ;let* - ) ;if - ) ; - (else (let ((remaining (if (negative? count) -1 count))) - (let loop - ((search-start 0) (parts '()) (r remaining)) - (let ((next-pos (string-position old str search-start))) - (if (and next-pos (not (zero? r))) - (loop (+ next-pos old-len) - (cons new (cons (substring str search-start next-pos) parts)) - (- r 1) - ) ;loop - (if (null? parts) - (string-copy str) - (apply string-append - (reverse (cons (substring str search-start str-len) parts)) - ) ;apply - ) ;if - ) ;if - ) ;let - ) ;let - ) ;let - ) ;else - ) ;cond - ) ;let - ) ;let - ) ;define - - (define (string-ends? str suffix) - (if (and (string? str) (string? suffix)) - (string-suffix? suffix str) - (type-error "string-ends? parameter is not a string") - ) ;if - ) ;define + (define string-ends? g_string-ends?) (define string-remove-prefix (typed-lambda ((str string?) (prefix string?)) diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/subprocess.scm b/TeXmacs/plugins/goldfish/goldfish/liii/subprocess.scm index ab35fd3b3d..1f49cf79d2 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/subprocess.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/subprocess.scm @@ -15,20 +15,8 @@ ;; (define-library (liii subprocess) - (export run - run-values - run-either - run-set! - run-get - run-allow! - run-ban! - run-unban! - run-and - run-or - run-sequence - run-pipe - run-if - run-when + (export run run-values run-either run-set! run-get run-allow! run-ban! + run-unban! run-and run-or run-sequence run-pipe run-if run-when ) ;export (import (scheme base) (liii base) @@ -175,21 +163,10 @@ ) ; ((or env input timeout stdout stderr stdin) (let-values (((out err code) - (run-values command - :cwd - cwd - :env - env - :input - input - :timeout - timeout - :stdout - stdout - :stderr - stderr - :stdin - stdin + (run-values command :cwd cwd :env env + :input input :timeout timeout + :stdout stdout :stderr stderr + :stdin stdin ) ;run-values ) ; ) ; @@ -301,28 +278,14 @@ (values "" "" 0) ) ; ((pair? cmd-spec) - (g_subprocess-run-values cmd-spec - cwd - env - input - timeout - stdout - stdout-mode - stderr - stderr-mode + (g_subprocess-run-values cmd-spec cwd env input + timeout stdout stdout-mode stderr stderr-mode stdin ) ;g_subprocess-run-values ) ; - (else (g_subprocess-run-values cmd-spec - cwd - env - input - timeout - stdout - stdout-mode - stderr - stderr-mode - stdin + (else (g_subprocess-run-values cmd-spec cwd env + input timeout stdout stdout-mode stderr + stderr-mode stdin ) ;g_subprocess-run-values ) ;else ) ;cond diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/unicode.scm b/TeXmacs/plugins/goldfish/goldfish/liii/unicode.scm index 5e59e178ae..23e48b39e5 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/unicode.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/unicode.scm @@ -594,10 +594,8 @@ (low-surrogate-high (ash low-surrogate -8)) (low-surrogate-low (bitwise-and low-surrogate 255)) ) ; - (bytevector high-surrogate-high - high-surrogate-low - low-surrogate-high - low-surrogate-low + (bytevector high-surrogate-high high-surrogate-low + low-surrogate-high low-surrogate-low ) ;bytevector ) ;let* ) ;else @@ -697,10 +695,8 @@ (low-surrogate-low (bitwise-and low-surrogate 255)) (low-surrogate-high (ash low-surrogate -8)) ) ; - (bytevector high-surrogate-low - high-surrogate-high - low-surrogate-low - low-surrogate-high + (bytevector high-surrogate-low high-surrogate-high + low-surrogate-low low-surrogate-high ) ;bytevector ) ;let* ) ;else diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/vector.scm b/TeXmacs/plugins/goldfish/goldfish/liii/vector.scm index f403194094..b1e1459f96 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/vector.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/vector.scm @@ -1,64 +1,21 @@ (define-library (liii vector) (import (scheme base) (srfi srfi-133) (srfi srfi-13)) - (export vector-empty? - vector-unfold - vector-unfold-right - vector-unfold! - vector-unfold-right! - vector-fold - vector-fold-right - vector-count - vector-any - vector-every - vector-index - vector-index-right - vector-skip - vector-skip-right - vector-binary-search - vector-concatenate - vector-partition - vector-append-subvectors - vector-swap! - vector-reverse! - vector-reverse-copy - vector-reverse-copy! - vector-map! - vector-cumulate - reverse-vector->list - reverse-list->vector - vector= - vector-contains? - vector-filter - vector-contains? - vector-take - vector-drop - vector-take-right - vector-drop-right - int-vector - int-vector? - make-int-vector - int-vector-ref - int-vector-set! - complex-vector - complex-vector? - make-complex-vector - complex-vector-ref - complex-vector-set! - float-vector - float-vector? - make-float-vector - float-vector-ref + (export vector-empty? vector-unfold vector-unfold-right vector-unfold! + vector-unfold-right! vector-fold vector-fold-right vector-count vector-any + vector-every vector-index vector-index-right vector-skip vector-skip-right + vector-binary-search vector-concatenate vector-partition + vector-append-subvectors vector-swap! vector-reverse! vector-reverse-copy + vector-reverse-copy! vector-map! vector-cumulate reverse-vector->list + reverse-list->vector vector= vector-contains? vector-filter vector-contains? + vector-take vector-drop vector-take-right vector-drop-right int-vector + int-vector? make-int-vector int-vector-ref int-vector-set! complex-vector + complex-vector? make-complex-vector complex-vector-ref complex-vector-set! + float-vector float-vector? make-float-vector float-vector-ref float-vector-set! ) ;export (begin - (define (vector-filter pred vec) - (list->vector (vector-fold-right (lambda (elem acc) (if (pred elem) (cons elem acc) acc)) - '() - vec - ) ;vector-fold-right - ) ;list->vector - ) ;define + (define vector-filter g_vector_filter) (define (vector-contains? vec elem . args) (let ((cmp (if (null? args) equal? (car args)))) diff --git a/TeXmacs/plugins/goldfish/goldfish/scheme/base.scm b/TeXmacs/plugins/goldfish/goldfish/scheme/base.scm index 6f0656cd4d..76ec91a2e0 100644 --- a/TeXmacs/plugins/goldfish/goldfish/scheme/base.scm +++ b/TeXmacs/plugins/goldfish/goldfish/scheme/base.scm @@ -183,8 +183,6 @@ current-error-port open-input-file open-output-file - open-binary-input-file - open-binary-output-file close-port close-input-port close-output-port @@ -259,41 +257,6 @@ (varlet (curlet) ((lambda ,vars (curlet)) ,expression))) ) ;define-macro - (define-macro (define-record-type type make ? . fields) - (let ((obj (gensym)) - (typ (gensym)) - (args (map (lambda (field) - (values (list 'quote (car field)) - (let ((par (memq (car field) (cdr make)))) - (and (pair? par) (car par)) - ) ;let - ) ;values - ) ;lambda - fields - ) ;map - ) ;args - ) ; - `(begin - (define (,? ,obj) - (and (let? ,obj) (eq? (let-ref ,obj (quote ,typ)) (quote ,type)))) - (define ,make (inlet (quote ,typ) (quote ,type) ,@args)) - ,@(map (lambda (field) - (when (pair? field) - (if (null? (cdr field)) - (values) - (if (null? (cddr field)) - `(define (,(cadr field) ,obj) - (let-ref ,obj (quote ,(car field)))) - `(begin - (define (,(cadr field) ,obj) - (let-ref ,obj (quote ,(car field)))) - (define (,(caddr field) ,obj val) - (let-set! ,obj (quote ,(car field)) val))))))) - fields) - (quote ,type)) - ) ;let - ) ;define-macro - (define exact inexact->exact) (define inexact exact->inexact) diff --git a/TeXmacs/plugins/goldfish/goldfish/scheme/boot.scm b/TeXmacs/plugins/goldfish/goldfish/scheme/boot.scm index dd2724e9b4..68306069a9 100644 --- a/TeXmacs/plugins/goldfish/goldfish/scheme/boot.scm +++ b/TeXmacs/plugins/goldfish/goldfish/scheme/boot.scm @@ -25,53 +25,47 @@ ) ;if ) ;define -(define-macro (define-library libname . body) - `(define ,(symbol (object->string libname)) - (with-let (sublet (unlet) - (cons 'import import) - (cons '*export* ()) - (cons 'export - (define-macro (,(gensym) . names) - (#_list-values - 'set! - '*export* - (#_list-values - 'append - (#_list-values #_quote names) - '*export*))))) - ,@body - (apply inlet - (map (lambda (entry) - (if (or (member (car entry) '(*export* export import)) - (and (pair? *export*) (not (member (car entry) *export*)))) - (values) - entry)) - (curlet))))) -) ;define-macro +;; C 实现的 define-library（src/s7_r7rs_library.c）已注册时，此后备版本不生效 +(unless (defined? 'define-library) + (define-macro (define-library libname . body) + `(define ,(symbol (object->string libname)) + (with-let (sublet (unlet) + (cons 'import import) + (cons '*export* ()) + (cons 'export + (define-macro (,(gensym) . names) + `(set! *export* (append (quote ,names) *export*))))) + ,@body + (apply inlet + (map (lambda (entry) + (if (or (member (car entry) '(*export* export import)) + (and (pair? *export*) + (not (member (car entry) *export*)))) + (values) + entry)) + (curlet))))) + ) ;define-macro +) ;unless (unless (defined? 'r7rs-import-library-filename) (define (r7rs-import-library-filename libs) (when (pair? libs) - (let ((lib-filename (let loop - ((lib (if (memq (caar libs) '(only except - prefix - rename)) (cadar libs) (car libs)) - ) ;lib - (name "") - ) ; - (set! name (string-append name (symbol->string (car lib)))) - (if (null? (cdr lib)) - (string-append name ".scm") - (begin - (set! name (string-append name "/")) - (loop (cdr lib) name) - ) ;begin - ) ;if - ) ;let - ) ;lib-filename + (let ((lib (if (memq (caar libs) '(only except prefix rename)) (cadar libs) (car libs)) + ) ;lib ) ; - (when (not (defined? (symbol (object->string (car libs))))) - (load lib-filename) + (when (not (defined? (symbol (object->string lib)))) + (load (let loop + ((parts lib) (name "")) + (set! name (string-append name (symbol->string (car parts)))) + (if (null? (cdr parts)) + (string-append name ".scm") + (begin + (set! name (string-append name "/")) + (loop (cdr parts) name) + ) ;begin + ) ;if + ) ;let + ) ;load ) ;when (r7rs-import-library-filename (cdr libs)) ) ;let @@ -79,56 +73,59 @@ ) ;define ) ;unless -(define-macro (import . libs) - `(begin - (r7rs-import-library-filename (quote ,libs)) - (varlet (curlet) - ,@(map (lambda (lib) - (case (car lib) - ((only) - `((lambda (e names) - (apply inlet - (map (lambda (name) (cons name (e name))) names))) - (symbol->value (symbol (object->string (cadr (quote - ,lib))))) - (cddr (quote ,lib)))) - ((except) - `((lambda (e names) - (apply inlet - (map (lambda (entry) - (if (member (car entry) names) - (values) - entry)) - e))) - (symbol->value (symbol (object->string (cadr (quote - ,lib))))) - (cddr (quote ,lib)))) - ((prefix) - `((lambda (e prefx) - (apply inlet - (map (lambda (entry) - (cons (string->symbol (string-append (symbol->string prefx) - (symbol->string (car entry)))) - (cdr entry))) - e))) - (symbol->value (symbol (object->string (cadr (quote - ,lib))))) - (caddr (quote ,lib)))) - ((rename) - `((lambda (e names) - (apply inlet - (map (lambda (entry) - (let ((info (assoc (car entry) names))) - (if info - (cons (cadr info) (cdr entry)) - entry))) - e))) - (symbol->value (symbol (object->string (cadr (quote - ,lib))))) - (cddr (quote ,lib)))) - (else `(let ((sym (symbol (object->string (quote ,lib))))) - (if (not (defined? sym)) - (format () "~A not loaded~%" sym) - (symbol->value sym)))))) - libs))) -) ;define-macro +;; C 实现的 import（src/s7_r7rs_library.c）已注册时，此后备版本不生效 +(unless (defined? 'import) + (define-macro (import . libs) + `(begin + (r7rs-import-library-filename (quote ,libs)) + (varlet (curlet) + ,@(map (lambda (lib) + (case (car lib) + ((only) + `((lambda (e names) + (apply inlet + (map (lambda (name) (cons name (e name))) names))) + (symbol->value (symbol (object->string (cadr (quote + ,lib))))) + (cddr (quote ,lib)))) + ((except) + `((lambda (e names) + (apply inlet + (map (lambda (entry) + (if (member (car entry) names) + (values) + entry)) + e))) + (symbol->value (symbol (object->string (cadr (quote + ,lib))))) + (cddr (quote ,lib)))) + ((prefix) + `((lambda (e prefx) + (apply inlet + (map (lambda (entry) + (cons (string->symbol (string-append (symbol->string prefx) + (symbol->string (car entry)))) + (cdr entry))) + e))) + (symbol->value (symbol (object->string (cadr (quote + ,lib))))) + (caddr (quote ,lib)))) + ((rename) + `((lambda (e names) + (apply inlet + (map (lambda (entry) + (let ((info (assoc (car entry) names))) + (if info + (cons (cadr info) (cdr entry)) + entry))) + e))) + (symbol->value (symbol (object->string (cadr (quote + ,lib))))) + (cddr (quote ,lib)))) + (else `(let ((sym (symbol (object->string (quote ,lib))))) + (if (not (defined? sym)) + (format () "~A not loaded~%" sym) + (symbol->value sym)))))) + libs))) + ) ;define-macro +) ;unless diff --git a/TeXmacs/plugins/goldfish/goldfish/scheme/char.scm b/TeXmacs/plugins/goldfish/goldfish/scheme/char.scm index b3d3f86205..0682b42ab3 100644 --- a/TeXmacs/plugins/goldfish/goldfish/scheme/char.scm +++ b/TeXmacs/plugins/goldfish/goldfish/scheme/char.scm @@ -15,27 +15,10 @@ ;; (define-library (scheme char) - (export char-upcase - char-downcase - char-foldcase - char-upper-case? - char-lower-case? - digit-value - char-numeric? - char-alphabetic? - char-whitespace? - char-ci=? - char-ci? - char-ci<=? - char-ci>=? - string-ci=? - string-ci? - string-ci<=? - string-ci>=? - string-upcase - string-downcase + (export char-upcase char-downcase char-foldcase char-upper-case? + char-lower-case? digit-value char-numeric? char-alphabetic? char-whitespace? + char-ci=? char-ci? char-ci<=? char-ci>=? string-ci=? string-ci? string-ci<=? string-ci>=? string-upcase string-downcase string-foldcase ) ;export (import (scheme base) (liii unicode)) diff --git a/TeXmacs/plugins/goldfish/goldfish/scheme/cxr.scm b/TeXmacs/plugins/goldfish/goldfish/scheme/cxr.scm index 0b66ff70a6..e3367bc5e5 100644 --- a/TeXmacs/plugins/goldfish/goldfish/scheme/cxr.scm +++ b/TeXmacs/plugins/goldfish/goldfish/scheme/cxr.scm @@ -15,30 +15,9 @@ ;; (define-library (scheme cxr) - (export caaar - caadr - cadar - caddr - cdaar - cdadr - cddar - cdddr - caaaar - caaadr - caadar - caaddr - cadaar - cadadr - caddar - cadddr - cdaaar - cdaadr - cdadar - cdaddr - cddaar - cddadr - cdddar - cddddr + (export caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar + caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr + cdddar cddddr ) ;export (begin ) ;begin diff --git a/TeXmacs/plugins/goldfish/goldfish/scheme/file.scm b/TeXmacs/plugins/goldfish/goldfish/scheme/file.scm index 15fcba3195..420fd490df 100644 --- a/TeXmacs/plugins/goldfish/goldfish/scheme/file.scm +++ b/TeXmacs/plugins/goldfish/goldfish/scheme/file.scm @@ -15,16 +15,9 @@ ;; (define-library (scheme file) - (export call-with-input-file - call-with-output-file - delete-file - file-exists? - open-binary-input-file - open-binary-output-file - open-input-file - open-output-file - with-input-from-file - with-output-to-file + (export call-with-input-file call-with-output-file delete-file file-exists? + open-binary-input-file open-binary-output-file open-input-file + open-output-file with-input-from-file with-output-to-file ) ;export (begin diff --git a/TeXmacs/plugins/goldfish/goldfish/scheme/let.scm b/TeXmacs/plugins/goldfish/goldfish/scheme/let.scm new file mode 100644 index 0000000000..f5fbce82d9 --- /dev/null +++ b/TeXmacs/plugins/goldfish/goldfish/scheme/let.scm @@ -0,0 +1,47 @@ +;; +;; Copyright (C) 2026 The Goldfish Scheme Authors +;; +;; Licensed under the Apache License, Version 2.0 (the "License"); +;; you may not use this file except in compliance with the License. +;; You may obtain a copy of the License at +;; +;; http://www.apache.org/licenses/LICENSE-2.0 +;; +;; Unless required by applicable law or agreed to in writing, software +;; distributed under the License is distributed on an "AS IS" BASIS, WITHOUT +;; WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the +;; License for the specific language governing permissions and limitations +;; under the License. +;; + +(define-library (scheme let) + (export + ;; 谓词 + let? + openlet? + funclet? + ;; 环境获取 + curlet + outlet + rootlet + owlet + funclet + ;; 环境构造与操作 + inlet + sublet + varlet + cutlet + openlet + coverlet + unlet + ;; 绑定访问 + let-ref + let-set! + let->list + ;; 符号查找 + symbol->value + symbol->dynamic-value + ) ;export + (begin + ) ;begin +) ;define-library diff --git a/TeXmacs/plugins/goldfish/goldfish/scheme/time.scm b/TeXmacs/plugins/goldfish/goldfish/scheme/time.scm index 7b23c08238..fca8c0aecc 100644 --- a/TeXmacs/plugins/goldfish/goldfish/scheme/time.scm +++ b/TeXmacs/plugins/goldfish/goldfish/scheme/time.scm @@ -16,13 +16,8 @@ (define-library (scheme time) (import (only (scheme base) let-values s7-round)) - (export current-second - current-jiffy - jiffies-per-second - get-time-of-day - monotonic-nanosecond - system-clock-resolution - steady-clock-resolution + (export current-second current-jiffy jiffies-per-second get-time-of-day + monotonic-nanosecond system-clock-resolution steady-clock-resolution ) ;export (begin diff --git a/TeXmacs/plugins/goldfish/goldfish/scheme/write.scm b/TeXmacs/plugins/goldfish/goldfish/scheme/write.scm index a9b314a384..dcb02db740 100644 --- a/TeXmacs/plugins/goldfish/goldfish/scheme/write.scm +++ b/TeXmacs/plugins/goldfish/goldfish/scheme/write.scm @@ -15,7 +15,7 @@ ;; (define-library (scheme write) - (export display write write-shared write-simple) + (export display write write-shared write-simple write-string) (begin (define write-simple write) diff --git a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-1.scm b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-1.scm index c377b98d24..5df52c2240 100644 --- a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-1.scm +++ b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-1.scm @@ -16,36 +16,12 @@ (export circular-list iota list-copy xcons cons*) (export circular-list? null-list? proper-list? dotted-list?) (export first second third fourth fifth sixth seventh eighth ninth tenth) - (export take - drop - take-right - drop-right - fold - fold-right - split-at - reduce - reduce-right - append-map - filter - partition - remove - find - delete - delete-duplicates - zip - count + (export take drop take-right drop-right fold fold-right split-at reduce + reduce-right append-map filter partition remove find delete + delete-duplicates zip count ) ;export - (export assoc - assq - assv - alist-cons - take-while - drop-while - list-index - any - every - last-pair - last + (export assoc assq assv alist-cons take-while drop-while list-index any every + last-pair last ) ;export (begin @@ -166,12 +142,7 @@ (car (last-pair l)) ) ;define - (define (count pred list1 . lists) - (let lp - ((lis list1) (i 0)) - (if (null-list? lis) i (lp (cdr lis) (if (pred (car lis)) (+ i 1) i))) - ) ;let - ) ;define + (define count g_count) (define (zip . lists) (apply map list lists) @@ -183,10 +154,7 @@ ) ;unless (cond ((null? lists) initial) ((and (pair? lists) (null? (cdr lists)) (list? (car lists))) - (let loop - ((acc initial) (lst (car lists))) - (if (null? lst) acc (loop (f (car lst) acc) (cdr lst))) - ) ;let + (g_fold f initial (car lists)) ) ; (else (let loop ((acc initial) (lsts lists)) @@ -207,10 +175,7 @@ ) ;unless (cond ((null? lists) initial) ((and (pair? lists) (null? (cdr lists)) (list? (car lists))) - (let loop - ((lst (car lists))) - (if (null? lst) initial (f (car lst) (loop (cdr lst)))) - ) ;let + (g_fold_right f initial (car lists)) ) ; (else (let loop ((lsts lists)) @@ -269,12 +234,7 @@ (filter (lambda (x) (not (pred x))) l) ) ;define - (define (find pred l) - (cond ((null? l) #f) - ((pred (car l)) (car l)) - (else (find pred (cdr l))) - ) ;cond - ) ;define + (define find g_find) (define (take-while pred lst) (if (null? lst) @@ -287,26 +247,11 @@ (if (null? l) '() (if (pred (car l)) (drop-while pred (cdr l)) l)) ) ;define - (define (list-index pred l) - (let loop - ((index 0) (l l)) - (if (null? l) #f (if (pred (car l)) index (loop (+ index 1) (cdr l)))) - ) ;let - ) ;define + (define list-index g_list_index) - (define (any pred? l) - (cond ((null? l) #f) - ((pred? (car l)) #t) - (else (any pred? (cdr l))) - ) ;cond - ) ;define + (define any g_any) - (define (every pred? l) - (cond ((null? l) #t) - ((not (pred? (car l))) #f) - (else (every pred? (cdr l))) - ) ;cond - ) ;define + (define every g_every) (define (%extract-maybe-equal maybe-equal) (let ((my-equal (if (null-list? maybe-equal) equal? (car maybe-equal)))) diff --git a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-113.scm b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-113.scm index e7a5139cf5..e5862b5b06 100644 --- a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-113.scm +++ b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-113.scm @@ -29,93 +29,20 @@ (srfi srfi-1) (srfi srfi-128) ) ;import - (export set - set-unfold - list->set - list->set! - set-copy - set->list - set? - set-contains? - set-empty? - set-disjoint? - set-element-comparator - set-size - set=? - set? - set<=? - set>=? - set-any? - set-every? - set-find - set-count - set-member - set-search! - set-map - set-for-each - set-fold - set-filter - set-filter! - set-remove - set-remove! - set-partition - set-partition! - set-union - set-intersection - set-difference - set-xor - set-union! - set-intersection! - set-difference! - set-xor! - set-adjoin - set-adjoin! - set-replace - set-replace! - set-delete - set-delete! - set-delete-all - set-delete-all! - bag - bag-unfold - bag-member - bag-comparator - bag->list - bag-copy - list->bag - list->bag! - bag? - bag-contains? - bag-empty? - bag-disjoint? - bag-size - bag-find - bag-count - bag-any? - bag-every? - bag=? - bag? - bag<=? - bag>=? - bag-union - bag-intersection - bag-difference - bag-xor - bag-union! - bag-intersection! - bag-difference! - bag-xor! - bag-adjoin - bag-adjoin! - bag-replace - bag-replace! - bag-delete - bag-delete! - bag-delete-all - bag-delete-all! - bag-search! + (export set set-unfold list->set list->set! set-copy set->list set? + set-contains? set-empty? set-disjoint? set-element-comparator set-size set=? + set? set<=? set>=? set-any? set-every? set-find set-count set-member + set-search! set-map set-for-each set-fold set-filter set-filter! set-remove + set-remove! set-partition set-partition! set-union set-intersection + set-difference set-xor set-union! set-intersection! set-difference! set-xor! + set-adjoin set-adjoin! set-replace set-replace! set-delete set-delete! + set-delete-all set-delete-all! bag bag-unfold bag-member bag-comparator + bag->list bag-copy list->bag list->bag! bag? bag-contains? bag-empty? + bag-disjoint? bag-size bag-find bag-count bag-any? bag-every? bag=? bag? bag<=? bag>=? bag-union bag-intersection bag-difference bag-xor + bag-union! bag-intersection! bag-difference! bag-xor! bag-adjoin bag-adjoin! + bag-replace bag-replace! bag-delete bag-delete! bag-delete-all + bag-delete-all! bag-search! ) ;export (begin diff --git a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-117.scm b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-117.scm index 8947d5f077..bc8dc3c722 100644 --- a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-117.scm +++ b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-117.scm @@ -9,28 +9,12 @@ ;; Follow the same License as the original one (define-library (srfi srfi-117) - (export make-list-queue - list-queue - list-queue-copy - list-queue-unfold - list-queue-unfold-right - list-queue? - list-queue-empty? - list-queue-front - list-queue-back - list-queue-list - list-queue-first-last - list-queue-add-front! - list-queue-add-back! - list-queue-remove-front! - list-queue-remove-back! - list-queue-remove-all! - list-queue-set-list! - list-queue-append - list-queue-append! - list-queue-concatenate - list-queue-map - list-queue-map! + (export make-list-queue list-queue list-queue-copy list-queue-unfold + list-queue-unfold-right list-queue? list-queue-empty? list-queue-front + list-queue-back list-queue-list list-queue-first-last list-queue-add-front! + list-queue-add-back! list-queue-remove-front! list-queue-remove-back! + list-queue-remove-all! list-queue-set-list! list-queue-append + list-queue-append! list-queue-concatenate list-queue-map list-queue-map! list-queue-for-each ) ;export (import (liii base) (liii error) (liii list)) diff --git a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-125.scm b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-125.scm index e8aaf91eb8..cdfece499e 100644 --- a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-125.scm +++ b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-125.scm @@ -16,34 +16,12 @@ (define-library (srfi srfi-125) (import (srfi srfi-1) (srfi srfi-128) (liii base) (liii error)) - (export make-hash-table - hash-table - hash-table-unfold - alist->hash-table - hash-table? - hash-table-contains? - hash-table-empty? - hash-table=? - hash-table-mutable? - hash-table-ref - hash-table-ref/default - hash-table-set! - hash-table-delete! - hash-table-intern! - hash-table-update! - hash-table-update!/default - hash-table-pop! - hash-table-clear! - hash-table-size - hash-table-keys - hash-table-values - hash-table-entries - hash-table-find - hash-table-count - hash-table-fold - hash-table-for-each - hash-table-map->list - hash-table->alist + (export make-hash-table hash-table alist->hash-table hash-table? + hash-table-contains? hash-table-empty? hash-table=? hash-table-ref + hash-table-ref/default hash-table-set! hash-table-delete! hash-table-update! + hash-table-update!/default hash-table-clear! hash-table-size hash-table-keys + hash-table-values hash-table-entries hash-table-find hash-table-count + hash-table-fold hash-table-for-each hash-table-map->list hash-table->alist hash-table-copy ) ;export (begin diff --git a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-128.scm b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-128.scm index fb620cfdd1..d48424c20d 100644 --- a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-128.scm +++ b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-128.scm @@ -32,37 +32,14 @@ (define-library (srfi srfi-128) (import (scheme base) (liii error)) - (export comparator? - comparator-ordered? - comparator-hashable? - make-comparator - make-pair-comparator - make-list-comparator - make-vector-comparator - make-eq-comparator - make-eqv-comparator - make-equal-comparator - boolean-hash - char-hash - char-ci-hash - string-hash - string-ci-hash - symbol-hash - number-hash - make-default-comparator - default-hash - comparator-type-test-predicate - comparator-equality-predicate - comparator-ordering-predicate - comparator-hash-function - comparator-test-type - comparator-check-type - comparator-hash - =? - ? - <=? - >=? + (export comparator? comparator-ordered? comparator-hashable? make-comparator + make-pair-comparator make-list-comparator make-vector-comparator + make-eq-comparator make-eqv-comparator make-equal-comparator boolean-hash + char-hash char-ci-hash string-hash string-ci-hash symbol-hash number-hash + make-default-comparator default-hash comparator-type-test-predicate + comparator-equality-predicate comparator-ordering-predicate + comparator-hash-function comparator-test-type comparator-check-type + comparator-hash =? ? <=? >=? ) ;export (begin diff --git a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-13.scm b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-13.scm index 2d28c7467b..85db4e199d 100644 --- a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-13.scm +++ b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-13.scm @@ -16,33 +16,12 @@ (define-library (srfi srfi-13) (import (liii base) (srfi srfi-1) (scheme char) (srfi srfi-175)) - (export string-null? - string-copy - string-join - string-every - string-any - string-take - string-take-right - string-drop - string-drop-right - string-pad - string-pad-right - string-trim - string-trim-right - string-trim-both - string-prefix? - string-suffix? - string-index - string-index-right - string-skip - string-skip-right - string-contains - string-count - string-fold - string-fold-right - string-for-each-index - string-reverse - string-tokenize + (export string-null? string-copy string-join string-every string-any + string-take string-take-right string-drop string-drop-right string-pad + string-pad-right string-trim string-trim-right string-trim-both + string-prefix? string-suffix? string-index string-index-right string-skip + string-skip-right string-contains string-count string-fold string-fold-right + string-for-each-index string-reverse string-tokenize ) ;export (begin @@ -61,46 +40,12 @@ ) ;cond ) ;define - (define (string-join l . delim+grammer) - (define (extract-params params-l) - (cond ((null-list? params-l) (list "" 'infix)) - ((and (= (length params-l) 1) (string? (car params-l))) - (list (car params-l) 'infix) - ) ; - ((and (= (length params-l) 2) - (string? (first params-l)) - (symbol? (second params-l)) - ) ;and - params-l - ) ; - ((> (length params-l) 2) - (error 'wrong-number-of-args "optional params in string-join") - ) ; - (else (error 'type-error "optional params in string-join")) - ) ;cond - ) ;define - (define (string-join-sub l delim) - (cond ((null-list? l) "") - ((= (length l) 1) (car l)) - (else (string-append (car l) delim (string-join-sub (cdr l) delim))) - ) ;cond - ) ;define - (let* ((params (extract-params delim+grammer)) - (delim (first params)) - (grammer (second params)) - (ret (string-join-sub l delim)) - ) ; - (case grammer - ('infix ret) - ('strict-infix - (if (null-list? l) (error 'value-error "empty list not allowed") ret) - ) ; - ('suffix (if (null-list? l) "" (string-append ret delim))) - ('prefix (if (null-list? l) "" (string-append delim ret))) - (else (error 'value-error "invalid grammer")) - ) ;case - ) ;let* - ) ;define + ;; string-join 的 C 实现见 src/liii_string.cpp 的 g_string-join + ;; 错误契约与旧 Scheme 实现一致： + ;; type-error "optional params in string-join"（分隔符非字符串或 grammar 非符号） + ;; value-error "invalid grammer"（grammar 非四种之一） + ;; value-error "empty list not allowed"（strict-infix 遇到空列表） + (define string-join g_string-join) (define (string-null? str) (if (not (string? str)) @@ -321,18 +266,21 @@ ) ;let ) ;define + ;; string-prefix?/string-suffix? 复用 C 实现的 g_string-starts?/g_string-ends? + ;; （见 src/liii_string.cpp），避免旧实现的 substring 临时分配； + ;; 注意参数顺序相反，且错误契约为 wrong-type-arg（区别于 liii 的 type-error） (define (string-prefix? prefix str) - (let* ((prefix-len (string-length prefix)) (str-len (string-length str))) - (and (<= prefix-len str-len) (string=? prefix (substring str 0 prefix-len))) - ) ;let* + (if (and (string? prefix) (string? str)) + (g_string-starts? str prefix) + (error 'wrong-type-arg "string-prefix?: expected string arguments") + ) ;if ) ;define (define (string-suffix? suffix str) - (let* ((suffix-len (string-length suffix)) (str-len (string-length str))) - (and (<= suffix-len str-len) - (string=? suffix (substring str (- str-len suffix-len) str-len)) - ) ;and - ) ;let* + (if (and (string? suffix) (string? str)) + (g_string-ends? str suffix) + (error 'wrong-type-arg "string-suffix?: expected string arguments") + ) ;if ) ;define (define (string-index str char/pred? . start+end) diff --git a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-132.scm b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-132.scm index 91a53b7cf1..d3655a1dab 100644 --- a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-132.scm +++ b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-132.scm @@ -15,34 +15,16 @@ ;; (define-library (srfi srfi-132) - (export list-sorted? - vector-sorted? - list-merge - list-sort - list-stable-sort - vector-merge - vector-sort - vector-stable-sort - list-merge! - list-sort! - list-stable-sort! - vector-merge! - vector-sort! - vector-stable-sort! + (export list-sorted? vector-sorted? list-merge list-sort list-stable-sort + vector-merge vector-sort vector-stable-sort list-merge! list-sort! + list-stable-sort! vector-merge! vector-sort! vector-stable-sort! ) ;export (import (liii list) (liii error) (scheme case-lambda)) (begin + ;; list-sorted? 复用 liii_sort.cpp 的 C++ 实现 g_list-sorted? (define (list-sorted? less-p lis) - (if (null? lis) - #t - (do ((first lis (cdr first)) - (second (cdr lis) (cdr second)) - (res #t (not (less-p (car second) (car first)))) - ) ; - ((or (null? second) (not res)) res) - ) ;do - ) ;if + (g_list-sorted? less-p lis) ) ;define (define vector-sorted? @@ -124,45 +106,12 @@ ) ;if ) ;define - (define (list-sort! less-p lst) - ;; 辅助函数：将列表分成小于和大于 pivot 的部分 - (define (partition! lst pivot less-p) - (let loop - ((lst lst) (less '()) (greater '())) - (cond ((null? lst) (values (reverse less) (reverse greater))) - ;; 返回小于和大于部分 - ((less-p (car lst) pivot) (loop (cdr lst) (cons (car lst) less) greater)) - (else (loop (cdr lst) less (cons (car lst) greater))) - ) ;cond - ) ;let - ) ;define - ;; 排序函数：原地排序 - (if (or (null? lst) (null? (cdr lst))) - ;; 如果列表为空或只有一个元素，已经排序好 - lst - (let* ((pivot (car lst))) - (call-with-values (lambda () (partition! (cdr lst) pivot less-p)) - ;; 调用 partition 并返回小于和大于部分 - (lambda (less greater) - ;; 对小于和大于部分递归排序 - (let ((sorted-less (list-sort! less-p less)) - (sorted-greater (list-sort! less-p greater)) - ) ; - ;; 如果 sorted-less 是空，直接返回 sorted-greater - (if (null? sorted-less) - sorted-greater - (begin - ;; 原地连接两个部分和 pivot - (set-cdr! (last-pair sorted-less) (cons pivot sorted-greater)) - sorted-less - ;; 返回排序后的列表 - ) ;begin - ) ;if - ) ;let - ) ;lambda - ) ;call-with-values - ) ;let* - ) ;if + ;; list-sort! 复用 S7 内置的 sort!：基于 C qsort 的原地排序， + ;; 只重写各 pair 的 car，列表骨架不变，返回值与输入 eq?。 + ;; 注意参数顺序相反：list-sort! 是 (list-sort! less-p lis)， + ;; 内置 sort! 是 (sort! seq less?)。 + (define (list-sort! less-p lis) + (sort! lis less-p) ) ;define (define list-stable-sort! @@ -206,8 +155,38 @@ (define vector-sort vector-stable-sort) - (define (vector-sort! . r) - (???) + ;; vector-sort! 复用 S7 内置的 sort!：基于 C qsort 的原地排序， + ;; 直接重写向量元素，返回值与输入 eq?。 + ;; 注意参数顺序相反：vector-sort! 是 (vector-sort! less-p v)， + ;; 内置 sort! 是 (sort! seq less?)。 + (define vector-sort! + (case-lambda + ((less-p v) + (if (vector? v) + (sort! v less-p) + (type-error "vector-sort!: expected a vector" v) + ) ;if + ) ; + ((less-p v start) + (if (vector? v) + (vector-sort! less-p v start (vector-length v)) + (type-error "vector-sort!: expected a vector" v) + ) ;if + ) ; + ((less-p v start end) + (cond ((not (vector? v)) (type-error "vector-sort!: expected a vector" v)) + ((or (< start 0) (> end (vector-length v)) (> start end)) + (value-error "Invalid start or end parameters") + ) ; + (else + ;; S7 subvector 与原向量共享存储， + ;; 对子区间 sort! 即原地排序原向量的对应区间 + (sort! (subvector v start end) less-p) + v + ) ;else + ) ;cond + ) ; + ) ;case-lambda ) ;define (define (vector-stable-sort! . r) diff --git a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-133.scm b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-133.scm index d789a48710..072d411dda 100644 --- a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-133.scm +++ b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-133.scm @@ -16,35 +16,13 @@ (define-library (srfi srfi-133) (import (liii base)) - (export vector-empty? - vector-unfold - vector-unfold-right - vector-unfold! - vector-unfold-right! - vector-fold - vector-fold-right - vector-count - vector-any - vector-every - vector-copy - vector-copy! - vector-index - vector-index-right - vector-skip - vector-skip-right - vector-binary-search - vector-concatenate - vector-partition - vector-append-subvectors - vector-swap! - vector-reverse! - vector-reverse-copy - vector-reverse-copy! - vector-map! - vector-cumulate - reverse-vector->list - reverse-list->vector - vector= + (export vector-empty? vector-unfold vector-unfold-right vector-unfold! + vector-unfold-right! vector-fold vector-fold-right vector-count vector-any + vector-every vector-copy vector-copy! vector-index vector-index-right + vector-skip vector-skip-right vector-binary-search vector-concatenate + vector-partition vector-append-subvectors vector-swap! vector-reverse! + vector-reverse-copy vector-reverse-copy! vector-map! vector-cumulate + reverse-vector->list reverse-list->vector vector= ) ;export (begin diff --git a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-151.scm b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-151.scm index 1c473ce490..28f42fb85c 100644 --- a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-151.scm +++ b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-151.scm @@ -16,32 +16,11 @@ (define-library (srfi srfi-151) (import (liii base) (liii error)) - (export bitwise-not - bitwise-and - bitwise-ior - bitwise-xor - bitwise-eqv - bitwise-nor - bitwise-nand - bit-count - bitwise-orc1 - bitwise-orc2 - bitwise-andc1 - bitwise-andc2 - arithmetic-shift - integer-length - bitwise-if - bit-set? - copy-bit - bit-swap - any-bit-set? - every-bit-set? - first-set-bit - bit-field - bit-field-any? - bit-field-every? - bit-field-clear - bit-field-set + (export bitwise-not bitwise-and bitwise-ior bitwise-xor bitwise-eqv + bitwise-nor bitwise-nand bit-count bitwise-orc1 bitwise-orc2 bitwise-andc1 + bitwise-andc2 arithmetic-shift integer-length bitwise-if bit-set? copy-bit + bit-swap any-bit-set? every-bit-set? first-set-bit bit-field bit-field-any? + bit-field-every? bit-field-clear bit-field-set ) ;export (begin diff --git a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-19.scm b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-19.scm index a83d1e6196..b7d7520aa2 100644 --- a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-19.scm +++ b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-19.scm @@ -152,35 +152,13 @@ ) ;define ;; note empty string in 0th place. (define priv:LOCALE-ABBR-MONTH-VECTOR - (vector "" - "Jan" - "Feb" - "Mar" - "Apr" - "May" - "Jun" - "Jul" - "Aug" - "Sep" - "Oct" - "Nov" - "Dec" + (vector "" "Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" + "Nov" "Dec" ) ;vector ) ;define (define priv:LOCALE-LONG-MONTH-VECTOR - (vector "" - "January" - "February" - "March" - "April" - "May" - "June" - "July" - "August" - "September" - "October" - "November" - "December" + (vector "" "January" "February" "March" "April" "May" "June" "July" + "August" "September" "October" "November" "December" ) ;vector ) ;define @@ -488,10 +466,9 @@ (define priv:TIME-DISPATCH `((,TIME-MONOTONIC ,priv:current-time-monotonic - unquote - steady-clock-resolution) - (,TIME-TAI ,priv:current-time-tai unquote system-clock-resolution) - (,TIME-UTC ,priv:current-time-utc unquote system-clock-resolution)) + . ,steady-clock-resolution) + (,TIME-TAI ,priv:current-time-tai . ,system-clock-resolution) + (,TIME-UTC ,priv:current-time-utc . ,system-clock-resolution)) ) ;define (define (priv:query-time-dispatch clock-type querier) (let ((entry (assq clock-type priv:TIME-DISPATCH))) diff --git a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-196.scm b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-196.scm index c0572bf2e7..3d325c4b1c 100644 --- a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-196.scm +++ b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-196.scm @@ -23,43 +23,13 @@ (define-library (srfi srfi-196) (import (scheme base) (scheme case-lambda)) - (export range - numeric-range - vector-range - string-range - range-append - iota-range - range? - range=? - range-length - range-ref - range-first - range-last - subrange - range-segment - range-split-at - range-take - range-take-right - range-drop - range-drop-right - range-count - range-map->list - range-for-each - range-fold - range-fold-right - range-any - range-every - range-filter->list - range-remove->list - range-reverse - range-map->vector - range-filter->vector - range-remove->vector - vector->range - range->list - range->vector - range->string - range->generator + (export range numeric-range vector-range string-range range-append iota-range + range? range=? range-length range-ref range-first range-last subrange + range-segment range-split-at range-take range-take-right range-drop + range-drop-right range-count range-map->list range-for-each range-fold + range-fold-right range-any range-every range-filter->list range-remove->list + range-reverse range-map->vector range-filter->vector range-remove->vector + vector->range range->list range->vector range->string range->generator ) ;export (begin diff --git a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-209.scm b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-209.scm index 00238d456b..0a24d8818b 100644 --- a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-209.scm +++ b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-209.scm @@ -30,85 +30,24 @@ (srfi srfi-128) (liii hash-table) ) ;import - (export enum-type? - enum? - enum-type-contains? - enum=? - enum? - enum<=? - enum>=? - make-enum-type - enum-type - enum-name - enum-ordinal - enum-value - enum-name->enum - enum-ordinal->enum - enum-name->ordinal - enum-name->value - enum-ordinal->name - enum-ordinal->value - enum-type-size - enum-min - enum-max - enum-type-enums - enum-type-names - enum-type-values - enum-next - enum-prev - make-enum-comparator - enum-empty-set - enum-type->enum-set - enum-set - list->enum-set - enum-set-projection - enum-set-copy - make-enumeration - enum-set-universe - enum-set-constructor - enum-set-indexer - enum-set? - enum-set-contains? - enum-set-member? - enum-set-empty? - enum-set-disjoint? - enum-set=? - enum-set? - enum-set<=? - enum-set>=? - enum-set-subset? - enum-set-any? - enum-set-every? - enum-set-type - enum-set-adjoin - enum-set-adjoin! - enum-set-delete - enum-set-delete! - enum-set-delete-all - enum-set-delete-all! - enum-set-size - enum-set->enum-list - enum-set->list - enum-set-map->list - enum-set-count - enum-set-filter - enum-set-filter! - enum-set-remove - enum-set-remove! - enum-set-for-each - enum-set-fold - enum-set-union - enum-set-union! - enum-set-intersection - enum-set-intersection! - enum-set-difference - enum-set-difference! - enum-set-xor - enum-set-xor! - enum-set-complement - enum-set-complement! + (export enum-type? enum? enum-type-contains? enum=? enum? enum<=? + enum>=? make-enum-type enum-type enum-name enum-ordinal enum-value + enum-name->enum enum-ordinal->enum enum-name->ordinal enum-name->value + enum-ordinal->name enum-ordinal->value enum-type-size enum-min enum-max + enum-type-enums enum-type-names enum-type-values enum-next enum-prev + make-enum-comparator enum-empty-set enum-type->enum-set enum-set + list->enum-set enum-set-projection enum-set-copy make-enumeration + enum-set-universe enum-set-constructor enum-set-indexer enum-set? + enum-set-contains? enum-set-member? enum-set-empty? enum-set-disjoint? + enum-set=? enum-set? enum-set<=? enum-set>=? enum-set-subset? + enum-set-any? enum-set-every? enum-set-type enum-set-adjoin enum-set-adjoin! + enum-set-delete enum-set-delete! enum-set-delete-all enum-set-delete-all! + enum-set-size enum-set->enum-list enum-set->list enum-set-map->list + enum-set-count enum-set-filter enum-set-filter! enum-set-remove + enum-set-remove! enum-set-for-each enum-set-fold enum-set-union + enum-set-union! enum-set-intersection enum-set-intersection! + enum-set-difference enum-set-difference! enum-set-xor enum-set-xor! + enum-set-complement enum-set-complement! ) ;export (begin diff --git a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-215.scm b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-215.scm index cce1f621f6..5567b24db3 100644 --- a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-215.scm +++ b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-215.scm @@ -18,17 +18,8 @@ ;; 严格按照 SRFI-215 标准实现 (define-library (srfi srfi-215) - (export send-log - current-log-fields - current-log-callback - EMERGENCY - ALERT - CRITICAL - ERROR - WARNING - NOTICE - INFO - DEBUG + (export send-log current-log-fields current-log-callback EMERGENCY ALERT + CRITICAL ERROR WARNING NOTICE INFO DEBUG ) ;export (import (scheme base) (scheme write)) (begin @@ -110,9 +101,7 @@ (callback (current-log-callback)) ) ; (when (procedure? callback) - (callback `((SEVERITY unquote severity) - (MESSAGE unquote message) - ,@alist)) + (callback `((SEVERITY . ,severity) (MESSAGE . ,message) ,@alist)) ) ;when ) ;let* ) ;define diff --git a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-224.scm b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-224.scm index 0a6df146ff..5ef3cae0b7 100644 --- a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-224.scm +++ b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-224.scm @@ -42,7 +42,6 @@ alist->fxmapping alist->fxmapping/combinator fxmapping-unfold - fxmapping-accumulate ;; Predicates fxmapping? fxmapping-contains? @@ -59,13 +58,9 @@ fxmapping-adjust fxmapping-delete fxmapping-delete-all - fxmapping-update - fxmapping-alter fxmapping-delete-min - fxmapping-update-min fxmapping-pop-min fxmapping-delete-max - fxmapping-update-max fxmapping-pop-max ;; The whole fxmapping fxmapping-size diff --git a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-26.scm b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-26.scm index 9b447eb17b..71d66dec8d 100644 --- a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-26.scm +++ b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-26.scm @@ -45,7 +45,7 @@ (error 'syntax-error "<...> must be the last parameter of cut") ) ;when (let ((parsed (parse xs paras))) - `(lambda (,@xs unquote rest) (apply ,@parsed)) + `(lambda (,@xs . ,rest) (apply ,@parsed)) ) ;let ) ;else ) ;cond diff --git a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-267.scm b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-267.scm index 6b341a80b8..0cb406462e 100644 --- a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-267.scm +++ b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-267.scm @@ -29,12 +29,8 @@ (define-library (srfi srfi-267) (import (only (srfi srfi-13) string-contains string-suffix?)) - (export raw-string-read-error? - raw-string-write-error? - read-raw-string - read-raw-string-after-prefix - can-delimit? - generate-delimiter + (export raw-string-read-error? raw-string-write-error? read-raw-string + read-raw-string-after-prefix can-delimit? generate-delimiter write-raw-string ) ;export (begin diff --git a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-27.scm b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-27.scm index dbd3e30e56..a65ddb216c 100644 --- a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-27.scm +++ b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-27.scm @@ -26,17 +26,10 @@ (define-library (srfi srfi-27) (import (scheme base) (srfi srfi-19) (liii error)) - (export random-integer - random-real - default-random-source - make-random-source - random-source? - random-source-state-ref - random-source-state-set! - random-source-randomize! - random-source-pseudo-randomize! - random-source-make-integers - random-source-make-reals + (export random-integer random-real default-random-source make-random-source + random-source? random-source-state-ref random-source-state-set! + random-source-randomize! random-source-pseudo-randomize! + random-source-make-integers random-source-make-reals ) ;export (begin @@ -53,13 +46,8 @@ ;; - make-reals: procedure returning a random-real generator (define-record-type - (%make-random-source state - state-ref - state-set! - randomize! - pseudo-randomize! - make-integers - make-reals + (%make-random-source state state-ref state-set! randomize! + pseudo-randomize! make-integers make-reals ) ;%make-random-source random-source? (state random-source-internal-state) diff --git a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-78.scm b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-78.scm index 9b359ee074..13d65f0335 100644 --- a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-78.scm +++ b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-78.scm @@ -39,13 +39,8 @@ (define-library (srfi srfi-78) (import (scheme base)) - (export check - check-set-mode! - check-report - check-reset! - check-passed? - check-failed? - check:proc + (export check check-set-mode! check-report check-reset! check-passed? + check-failed? check:proc ) ;export (begin @@ -79,12 +74,8 @@ (set! check:correct (+ check:correct 1)) ) ;define - (define (check:add-failed! expression - actual-result - expected-result - file - line - call-stack + (define (check:add-failed! expression actual-result expected-result file + line call-stack ) ;check:add-failed! (set! check:failed (cons (list expression actual-result expected-result file line call-stack) @@ -113,11 +104,13 @@ (newline) (check:write expression) (display " => ") + (flush-output-port) ) ;define (define (check:report-actual-result actual-result) (check:write actual-result) (display " ; ") + (flush-output-port) ) ;define (define (check:report-correct cases) diff --git a/TeXmacs/plugins/goldfish/goldfish/texmacs/protocol.scm b/TeXmacs/plugins/goldfish/goldfish/texmacs/protocol.scm index 6e602566c1..6fc568b84a 100644 --- a/TeXmacs/plugins/goldfish/goldfish/texmacs/protocol.scm +++ b/TeXmacs/plugins/goldfish/goldfish/texmacs/protocol.scm @@ -1,20 +1,8 @@ (define-library (texmacs protocol) - (export data-begin - data-end - data-escape - DATA_BEGIN - DATA_END - DATA_COMMAND - DATA_ESCAPE - flush-verbatim - flush-prompt - flush-scheme - flush-file - flush-markdown - flush-latex - flush-command - read-paragraph-by-visible-eof + (export data-begin data-end data-escape DATA_BEGIN DATA_END DATA_COMMAND + DATA_ESCAPE flush-verbatim flush-prompt flush-scheme flush-file + flush-markdown flush-latex flush-command read-paragraph-by-visible-eof ) ;export (begin diff --git a/TeXmacs/plugins/goldfish/packages/code/goldfish.stem b/TeXmacs/plugins/goldfish/packages/code/goldfish.stem new file mode 100644 index 0000000000..2835710f2b --- /dev/null +++ b/TeXmacs/plugins/goldfish/packages/code/goldfish.stem @@ -0,0 +1,74 @@ +(document (TeXmacs "2.1.2") + (style "source") + (body (document (active* (src-title (document (src-package "goldfish" "1.0") + (src-purpose (document "Markup for Scheme defined in R7RS.")) + (src-copyright "2024" "Darcy Shen") + (src-license (document (concat "This software falls under the " + (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE") + ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see " + (hlink "http://www.gnu.org/licenses/gpl-3.0.html" + "http://www.gnu.org/licenses/gpl-3.0.html" + ) ;hlink + "." + ) ;concat + ) ;document + ) ;src-license + ) ;document + ) ;src-title + ) ;active* + (use-module "(goldfish goldfish-format)") + (use-module "(goldfish goldfish-edit)") + (assign "goldfish-prompt-color" "dark green") + (assign "goldfish-lang" + (macro "body" + (with "mode" "prog" "prog-language" "goldfish" "font-family" "rm" (arg "body")) + ) ;macro + ) ;assign + (assign "goldfish-code" + (macro "body" (document (pseudo-code (document (goldfish-lang (arg "body")))))) + ) ;assign + (assign "goldfish-prompt" + (macro "prompt" + (with "mode" + "text" + "language" + "verbatim" + "font-family" + "tt" + (style-with "src-compact" "none" (arg "prompt")) + ) ;with + ) ;macro + ) ;assign + (assign "goldfish-input" + (macro "prompt" + "body" + (document (with "generic-prompt-color" + (value "goldfish-prompt-color") + "generic-input-color" + (value "scheme-input-color") + (document (generic-input (arg "prompt") (arg "body"))) + ) ;with + ) ;document + ) ;macro + ) ;assign + (assign "goldfish-result" + (macro "body" + (document (with "ornament-border" + "0ln" + "ornament-hpadding" + "0spc" + "padding-above" + "0fn" + "padding-below" + "0fn" + "ornament-color" + "pastel green" + (ornamented (document (arg "body"))) + ) ;with + ) ;document + ) ;macro + ) ;assign + ) ;document + ) ;body + (initial (collection)) +) ;document diff --git a/TeXmacs/plugins/goldfish/packages/code/goldfish.ts b/TeXmacs/plugins/goldfish/packages/code/goldfish.ts deleted file mode 100644 index 9a7e38eac8..0000000000 --- a/TeXmacs/plugins/goldfish/packages/code/goldfish.ts +++ /dev/null @@ -1,54 +0,0 @@ - - - - -<\body> - - - - <\src-purpose> - Markup for Scheme defined in R7RS. - - - - - <\src-license> - This software falls under the . It comes WITHOUT ANY - WARRANTY WHATSOEVER. You should have received a copy of the license - which the software. If not, see . - - > - - - - - - - - >>> - - - <\pseudo-code> - > - - > - - >>>> - - - <\with|generic-prompt-color||generic-input-color|> - |> - - > - - - - - > - > - - - -> \ No newline at end of file diff --git a/TeXmacs/plugins/goldfish/progs/code/liii-keyword.scm b/TeXmacs/plugins/goldfish/progs/code/liii-keyword.scm deleted file mode 100644 index 0cb5fe3eeb..0000000000 --- a/TeXmacs/plugins/goldfish/progs/code/liii-keyword.scm +++ /dev/null @@ -1,236 +0,0 @@ - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : liii-keyword.scm -;; DESCRIPTION : keywords for the Goldfish Scheme Language -;; COPYRIGHT : (C) 2024 Darcy Shen -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (code liii-keyword)) - -(define (liii-base) - (map symbol->string '(== != display* in? compose identity case-class? any?)) -) ;define - -(define (liii-check) - (map symbol->string - '(test check - check-set-mode! - check-catch - check-report - check-failed? - check-true - check-false) - ) ;map -) ;define - -(define (liii-list) - (map symbol->string - '(list-view flat-map flatten list-null? list-not-null? not-null-list?) - ) ;map -) ;define - -(define (liii-string) - (map symbol->string - '(string-starts? string-ends? string-remove-prefix string-remove-suffix) - ) ;map -) ;define - -(define (liii-os) - (map symbol->string - '(os-arch os-type - os-windows? - os-linux? - os-macos? - os-temp-dir - os-call - system - mkdir - chdir - rmdir - getenv - unsetenv - getcwd - listdir - access - getlogin - getpid) - ) ;map -) ;define - -(define (liii-queue) - (map symbol->string - '(queue queue? - queue-empty? - queue-size - queue-front - queue-back - queue-pop! - queue-push! - queue->list) - ) ;map -) ;define - -(define (liii-stack) - (map symbol->string - '(stack stack? - stack-empty? - stack-size - stack-top - stack-push! - stack-pop! - stack->list) - ) ;map -) ;define - -(define (liii-sys) - (map symbol->string '(argv)) -) ;define - -(define (liii-uuid) - (map symbol->string '(uuid4)) -) ;define - -(define (liii-base64) - (map symbol->string - '(string-base64-encode bytevector-base64-encode - base64-encode - string-base64-decode - bytevector-base64-decode - base64-decode) - ) ;map -) ;define - -(define (liii-bitwise) - (map symbol->string - '(bitwise-not bitwise-and - bitwise-ior - bitwise-xor - bitwise-or - bitwise-nor - bitwise-nand - bit-count - arithmetic-shift - lognot - logand - logior - logxor - ash) - ) ;map -) ;define - -(define (liii-lang) - (map symbol->string - '(box rich-integer rich-string rich-char rich-vector rich-hash-table) - ) ;map -) ;define - -(tm-define (liii-methods) - (map symbol->string - '(:equals :to-string - :is-instance-of - :apply - :get - :get-or-else - :or-else - :collect - :exists - :forall - :contains - :empty? - :defined? - :map - :filter - :flat-map - :for-each - :fold - :fold-right - :reduce - :reduce-right - :take - :take-right - :drop - :drop-right - :take-while - :drop-while - :sum - :produce - :min - :max - :min-by - :max-by - :sorted - :sort-by - :sortWith - :union - :intersect - :diff - :distinct - :find - :count - :length - :size - :group-by - :partition - :zip - :zip-with-index - :unzip - :par - :make-string - :to-list - :to-vector - :to-map - :to-set) - ) ;map -) ;tm-define - -(tm-define (liii-keywords) - `(,@(liii-base) - ,@(liii-check) - ,@(liii-list) - ,@(liii-string) - ,@(liii-os) - ,@(liii-queue) - ,@(liii-stack) - ,@(liii-sys) - ,@(liii-uuid) - ,@(liii-base64) - ,@(liii-bitwise) - ,@(liii-lang)) -) ;tm-define - -(tm-define (liii-keywords-define) - (map symbol->string - '(and-let* typed-lambda - defined? - define-macro - define-constant - autoload - require - provide - define* - lambda* - eval-string - case* - typed-define - define-case-class) - ) ;map -) ;tm-define - -(tm-define (liii-keywords-error) - (map symbol->string - '(os-error file-not-found-error - not-a-directory-error - file-exists-error - timeout-error - type-error - value-error - ??? - not-implemented-error) - ) ;map -) ;tm-define diff --git a/TeXmacs/plugins/goldfish/progs/data/goldfish.scm b/TeXmacs/plugins/goldfish/progs/data/goldfish.scm deleted file mode 100644 index df1c6005ed..0000000000 --- a/TeXmacs/plugins/goldfish/progs/data/goldfish.scm +++ /dev/null @@ -1,43 +0,0 @@ - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : goldfish.scm -;; DESCRIPTION : prog format for goldfish -;; COPYRIGHT : (C) 2022 Darcy Shen, Joris van der Hoeven -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (data goldfish)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; goldfish source files -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-format goldfish - (:name "Goldfish source code") - (:suffix "scm" ".sld" ".ss") -) ;define-format - -(define (texmacs->goldfish x . opts) - (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '())) -) ;define - -(define (goldfish->texmacs x . opts) - (code->texmacs x) -) ;define - -(define (goldfish-snippet->texmacs x . opts) - (code-snippet->texmacs x) -) ;define - -(converter texmacs-tree goldfish-document (:function texmacs->goldfish)) - -(converter goldfish-document texmacs-tree (:function goldfish->texmacs)) - -(converter texmacs-tree goldfish-snippet (:function texmacs->goldfish)) - -(converter goldfish-snippet texmacs-tree (:function goldfish-snippet->texmacs)) diff --git a/TeXmacs/plugins/goldfish/progs/code/goldfish-ast-lang.scm b/TeXmacs/plugins/goldfish/progs/goldfish/goldfish-ast-lang.scm similarity index 95% rename from TeXmacs/plugins/goldfish/progs/code/goldfish-ast-lang.scm rename to TeXmacs/plugins/goldfish/progs/goldfish/goldfish-ast-lang.scm index 27650c05d5..a9d8357c8d 100644 --- a/TeXmacs/plugins/goldfish/progs/code/goldfish-ast-lang.scm +++ b/TeXmacs/plugins/goldfish/progs/goldfish/goldfish-ast-lang.scm @@ -11,11 +11,11 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(texmacs-module (code goldfish-ast-lang) +(texmacs-module (goldfish goldfish-ast-lang) (:use (code default-ast-lang) - (code r7rs-keyword) - (code srfi-keyword) - (code liii-keyword) + (r7rs r7rs-keyword) + (r7rs srfi-keyword) + (goldfish liii-keyword) ) ;:use ) ;texmacs-module @@ -123,11 +123,7 @@ ("#D32F2F" "string_content" "string_quote" "character") ("#BF2C2C" "escape_sequence") ("red" "error") - ("#000000" - "symbol" - "operator" - "normal-brackets" - "vector_tag" + ("#000000" "symbol" "operator" "normal-brackets" "vector_tag" "byte_vector_tag") ("#800080" "ERROR") ("#ff115f" "(0" ")0" "[0" "]0" "{0" "}0") diff --git a/TeXmacs/plugins/goldfish/progs/code/goldfish-edit.scm b/TeXmacs/plugins/goldfish/progs/goldfish/goldfish-edit.scm similarity index 96% rename from TeXmacs/plugins/goldfish/progs/code/goldfish-edit.scm rename to TeXmacs/plugins/goldfish/progs/goldfish/goldfish-edit.scm index 36671a0015..47f4b6b62e 100644 --- a/TeXmacs/plugins/goldfish/progs/code/goldfish-edit.scm +++ b/TeXmacs/plugins/goldfish/progs/goldfish/goldfish-edit.scm @@ -11,7 +11,7 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(texmacs-module (code goldfish-edit) (:use (prog prog-edit))) +(texmacs-module (goldfish goldfish-edit) (:use (prog prog-edit))) (texmacs-modes (in-goldfish% (== (get-env "prog-language") "goldfish")) (in-prog-goldfish% #t in-prog% in-goldfish%) diff --git a/TeXmacs/plugins/goldfish/progs/goldfish/goldfish-format.scm b/TeXmacs/plugins/goldfish/progs/goldfish/goldfish-format.scm new file mode 100644 index 0000000000..b3aeb25153 --- /dev/null +++ b/TeXmacs/plugins/goldfish/progs/goldfish/goldfish-format.scm @@ -0,0 +1,43 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; MODULE : goldfish.scm +;; DESCRIPTION : prog format for goldfish +;; COPYRIGHT : (C) 2022 Darcy Shen, Joris van der Hoeven +;; +;; This software falls under the GNU general public license version 3 or later. +;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE +;; in the root directory or . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(texmacs-module (goldfish goldfish-format)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; goldfish source files +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-format goldfish + (:name "Goldfish source code") + (:suffix "scm" ".sld" ".ss") +) ;define-format + +(define (texmacs->goldfish x . opts) + (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '())) +) ;define + +(define (goldfish->texmacs x . opts) + (code->texmacs x) +) ;define + +(define (goldfish-snippet->texmacs x . opts) + (code-snippet->texmacs x) +) ;define + +(converter texmacs-tree goldfish-document (:function texmacs->goldfish)) + +(converter goldfish-document texmacs-tree (:function goldfish->texmacs)) + +(converter texmacs-tree goldfish-snippet (:function texmacs->goldfish)) + +(converter goldfish-snippet texmacs-tree (:function goldfish-snippet->texmacs)) diff --git a/TeXmacs/plugins/goldfish/progs/code/goldfish-lang.scm b/TeXmacs/plugins/goldfish/progs/goldfish/goldfish-lang.scm similarity index 96% rename from TeXmacs/plugins/goldfish/progs/code/goldfish-lang.scm rename to TeXmacs/plugins/goldfish/progs/goldfish/goldfish-lang.scm index b6043becf4..862618b72e 100644 --- a/TeXmacs/plugins/goldfish/progs/code/goldfish-lang.scm +++ b/TeXmacs/plugins/goldfish/progs/goldfish/goldfish-lang.scm @@ -11,11 +11,11 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(texmacs-module (code goldfish-lang) +(texmacs-module (goldfish goldfish-lang) (:use (prog default-lang) - (code r7rs-keyword) - (code srfi-keyword) - (code liii-keyword) + (r7rs r7rs-keyword) + (r7rs srfi-keyword) + (goldfish liii-keyword) ) ;:use ) ;texmacs-module @@ -129,9 +129,7 @@ (tm-define (parser-feature lan key) (:require (and (== lan "goldfish") (== key "string"))) `(,(string->symbol key) - (bool_features "hex_with_8_bits" - "hex_with_16_bits" - "hex_with_32_bits" + (bool_features "hex_with_8_bits" "hex_with_16_bits" "hex_with_32_bits" "octal_upto_3_digits") (escape_sequences "\\" "\"" "a" "b" "f" "n" "r" "t" "v") (pairs "\"")) diff --git a/TeXmacs/plugins/goldfish/progs/goldfish/liii-keyword.scm b/TeXmacs/plugins/goldfish/progs/goldfish/liii-keyword.scm new file mode 100644 index 0000000000..fdbfb1f94f --- /dev/null +++ b/TeXmacs/plugins/goldfish/progs/goldfish/liii-keyword.scm @@ -0,0 +1,129 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; MODULE : liii-keyword.scm +;; DESCRIPTION : keywords for the Goldfish Scheme Language +;; COPYRIGHT : (C) 2024 Darcy Shen +;; +;; This software falls under the GNU general public license version 3 or later. +;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE +;; in the root directory or . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(texmacs-module (goldfish liii-keyword)) + +(define (liii-base) + (map symbol->string '(== != display* in? compose identity case-class? any?)) +) ;define + +(define (liii-check) + (map symbol->string + '(test check check-set-mode! check-catch check-report check-failed? + check-true check-false) + ) ;map +) ;define + +(define (liii-list) + (map symbol->string + '(list-view flat-map flatten list-null? list-not-null? not-null-list?) + ) ;map +) ;define + +(define (liii-string) + (map symbol->string + '(string-starts? string-ends? string-remove-prefix string-remove-suffix) + ) ;map +) ;define + +(define (liii-os) + (map symbol->string + '(os-arch os-type os-windows? os-linux? os-macos? os-temp-dir os-call system + mkdir chdir rmdir getenv unsetenv getcwd listdir access getlogin getpid) + ) ;map +) ;define + +(define (liii-queue) + (map symbol->string + '(queue queue? queue-empty? queue-size queue-front queue-back queue-pop! + queue-push! queue->list) + ) ;map +) ;define + +(define (liii-stack) + (map symbol->string + '(stack stack? stack-empty? stack-size stack-top stack-push! stack-pop! + stack->list) + ) ;map +) ;define + +(define (liii-sys) + (map symbol->string '(argv)) +) ;define + +(define (liii-uuid) + (map symbol->string '(uuid4)) +) ;define + +(define (liii-base64) + (map symbol->string + '(string-base64-encode bytevector-base64-encode base64-encode + string-base64-decode bytevector-base64-decode base64-decode) + ) ;map +) ;define + +(define (liii-bitwise) + (map symbol->string + '(bitwise-not bitwise-and bitwise-ior bitwise-xor bitwise-or bitwise-nor + bitwise-nand bit-count arithmetic-shift lognot logand logior logxor ash) + ) ;map +) ;define + +(define (liii-lang) + (map symbol->string + '(box rich-integer rich-string rich-char rich-vector rich-hash-table) + ) ;map +) ;define + +(tm-define (liii-methods) + (map symbol->string + '(:equals :to-string :is-instance-of :apply :get :get-or-else :or-else + :collect :exists :forall :contains :empty? :defined? :map :filter + :flat-map :for-each :fold :fold-right :reduce :reduce-right :take + :take-right :drop :drop-right :take-while :drop-while :sum :produce :min + :max :min-by :max-by :sorted :sort-by :sortWith :union :intersect :diff + :distinct :find :count :length :size :group-by :partition :zip + :zip-with-index :unzip :par :make-string :to-list :to-vector :to-map + :to-set) + ) ;map +) ;tm-define + +(tm-define (liii-keywords) + `(,@(liii-base) + ,@(liii-check) + ,@(liii-list) + ,@(liii-string) + ,@(liii-os) + ,@(liii-queue) + ,@(liii-stack) + ,@(liii-sys) + ,@(liii-uuid) + ,@(liii-base64) + ,@(liii-bitwise) + ,@(liii-lang)) +) ;tm-define + +(tm-define (liii-keywords-define) + (map symbol->string + '(and-let* typed-lambda defined? define-macro define-constant autoload + require provide define* lambda* eval-string case* typed-define + define-case-class) + ) ;map +) ;tm-define + +(tm-define (liii-keywords-error) + (map symbol->string + '(os-error file-not-found-error not-a-directory-error file-exists-error + timeout-error type-error value-error ??? not-implemented-error) + ) ;map +) ;tm-define diff --git a/TeXmacs/plugins/goldfish/progs/init-goldfish.scm b/TeXmacs/plugins/goldfish/progs/init-goldfish.scm index 3af2836e0b..d776d42c22 100644 --- a/TeXmacs/plugins/goldfish/progs/init-goldfish.scm +++ b/TeXmacs/plugins/goldfish/progs/init-goldfish.scm @@ -13,7 +13,7 @@ (use-modules (binary goldfish)) -(lazy-format (data r7rs) r7rs) +(lazy-format (r7rs r7rs-format) r7rs) (define (goldfish-serialize lan t) (let* ((u (pre-serialize lan t)) (s (texmacs->utf8raw (stree->tree u)))) diff --git a/TeXmacs/plugins/goldfish/src/goldfish.hpp b/TeXmacs/plugins/goldfish/src/goldfish.hpp index 5dee439f64..13fe92d813 100644 --- a/TeXmacs/plugins/goldfish/src/goldfish.hpp +++ b/TeXmacs/plugins/goldfish/src/goldfish.hpp @@ -15,6 +15,8 @@ // #include "s7.h" +#include "s7_liii_record.h" +#include "s7_r7rs_library.h" #include #include #include @@ -68,7 +70,7 @@ #include #endif -#define GOLDFISH_VERSION "18.11.18" +#define GOLDFISH_VERSION "18.11.31" #define GOLDFISH_PATH_MAXN TB_PATH_MAXN @@ -90,8 +92,8 @@ namespace fs= std::filesystem; using nlohmann::json; -inline void glue_define (s7_scheme* sc, const char* name, const char* desc, - s7_function f, s7_int required, s7_int optional); +inline void glue_define (s7_scheme* sc, const char* name, const char* desc, s7_function f, s7_int required, + s7_int optional); static s7_pointer f_function_libraries (s7_scheme* sc, s7_pointer args); @@ -99,14 +101,11 @@ static s7_pointer f_gfproject_load_config (s7_scheme* sc, s7_pointer args); static s7_pointer f_project_root (s7_scheme* sc, s7_pointer args); -static bool split_library_query (const string& query, string& group, - string& library); +static bool split_library_query (const string& query, string& group, string& library); static string find_goldfish_library (); -static vector -find_function_libraries_in_load_path (s7_scheme* sc, - const string& function_name); +static vector find_function_libraries_in_load_path (s7_scheme* sc, const string& function_name); void glue_njson (s7_scheme* sc); #ifdef GOLDFISH_ENABLE_HTTP @@ -114,11 +113,15 @@ void glue_http (s7_scheme* sc); void glue_http_async (s7_scheme* sc); #endif void glue_liii_base64 (s7_scheme* sc); +void glue_liii_json (s7_scheme* sc); void glue_scheme_base (s7_scheme* sc); void glue_scheme_char (s7_scheme* sc); void glue_liii_hashlib (s7_scheme* sc); void glue_liii_os (s7_scheme* sc); void glue_liii_path (s7_scheme* sc); +void glue_liii_sort (s7_scheme* sc); +void glue_liii_string (s7_scheme* sc); +void glue_liii_string_cursor (s7_scheme* sc); void glue_subprocess_run_values (s7_scheme* sc); inline s7_pointer @@ -132,11 +135,9 @@ string_vector_to_s7_vector (s7_scheme* sc, vector v) { } inline void -glue_define (s7_scheme* sc, const char* name, const char* desc, s7_function f, - s7_int required, s7_int optional) { +glue_define (s7_scheme* sc, const char* name, const char* desc, s7_function f, s7_int required, s7_int optional) { s7_pointer cur_env= s7_curlet (sc); - s7_pointer func = s7_make_typed_function (sc, name, f, required, optional, - false, desc, NULL); + s7_pointer func = s7_make_typed_function (sc, name, f, required, optional, false, desc, NULL); s7_define (sc, cur_env, s7_make_symbol (sc, name), func); } @@ -161,43 +162,34 @@ glue_goldfish (s7_scheme* sc) { const char* d_delete_file = "(g_delete-file string) => boolean"; const char* s_function_libraries= "g_function-libraries"; const char* d_function_libraries= - "(g_function-libraries function-name) => list, returns visible library " - "names such as '((liii string)) that " + "(g_function-libraries function-name) => list, returns visible library names such as '((liii string)) that " "export function-name in the current *load-path*"; const char* s_gfproject_load_config= "g_gfproject-load-config"; - const char* d_gfproject_load_config= - "(g_gfproject-load-config) => string, returns merged gfproject.json"; - const char* s_project_root= "g_project-root"; + const char* d_gfproject_load_config= "(g_gfproject-load-config) => string, returns merged gfproject.json"; + const char* s_project_root = "g_project-root"; const char* d_project_root= - "(g_project-root) => string or #f, returns the directory containing the " - "local gfproject.json, " + "(g_project-root) => string or #f, returns the directory containing the local gfproject.json, " "or #f if none is found in the current working directory"; s7_define (sc, cur_env, s7_make_symbol (sc, s_version), - s7_make_typed_function (sc, s_version, f_version, 0, 0, false, - d_version, NULL)); + s7_make_typed_function (sc, s_version, f_version, 0, 0, false, d_version, NULL)); s7_define (sc, cur_env, s7_make_symbol (sc, s_delete_file), - s7_make_typed_function (sc, s_delete_file, f_delete_file, 1, 0, - false, d_delete_file, NULL)); + s7_make_typed_function (sc, s_delete_file, f_delete_file, 1, 0, false, d_delete_file, NULL)); - s7_define (sc, cur_env, s7_make_symbol (sc, s_function_libraries), - s7_make_typed_function (sc, s_function_libraries, - f_function_libraries, 1, 0, false, - d_function_libraries, NULL)); + s7_define ( + sc, cur_env, s7_make_symbol (sc, s_function_libraries), + s7_make_typed_function (sc, s_function_libraries, f_function_libraries, 1, 0, false, d_function_libraries, NULL)); s7_define (sc, cur_env, s7_make_symbol (sc, s_gfproject_load_config), - s7_make_typed_function (sc, s_gfproject_load_config, - f_gfproject_load_config, 0, 0, false, + s7_make_typed_function (sc, s_gfproject_load_config, f_gfproject_load_config, 0, 0, false, d_gfproject_load_config, NULL)); s7_define (sc, cur_env, s7_make_symbol (sc, s_project_root), - s7_make_typed_function (sc, s_project_root, f_project_root, 0, 0, - false, d_project_root, NULL)); + s7_make_typed_function (sc, s_project_root, f_project_root, 0, 0, false, d_project_root, NULL)); } -// old `f_current_second` TODO: use std::chrono::tai_clock::now() when using C++ -// 20 +// old `f_current_second` TODO: use std::chrono::tai_clock::now() when using C++ 20 // NOTE(jinser): use a new name for tai // `current-second` impl by g_get-time-of-day now static s7_pointer @@ -207,8 +199,8 @@ f_get_time_of_day (s7_scheme* sc, s7_pointer args) { auto since_epoch= now.time_since_epoch (); auto sec = duration_cast (since_epoch); - s7_pointer vs= s7_list (sc, 2, s7_make_integer (sc, sec.count ()), - s7_make_integer (sc, (since_epoch - sec).count ())); + s7_pointer vs= + s7_list (sc, 2, s7_make_integer (sc, sec.count ()), s7_make_integer (sc, (since_epoch - sec).count ())); return s7_values (sc, vs); } @@ -225,7 +217,7 @@ template constexpr int64_t clock_resolution_ns () { typedef std::chrono::duration NS; - NS ns= typename Clock::duration (1); + NS ns= typename Clock::duration (1); return ns.count (); } @@ -234,29 +226,22 @@ glue_scheme_time (s7_scheme* sc) { s7_pointer cur_env= s7_curlet (sc); const char* s_get_time_of_day= "g_get-time-of-day"; - const char* d_get_time_of_day= - "(g_get-time-of-day): () => (integer, integer), return the " - "current second and microsecond in integer"; + const char* d_get_time_of_day= "(g_get-time-of-day): () => (integer, integer), return the " + "current second and microsecond in integer"; s7_define (sc, cur_env, s7_make_symbol (sc, s_get_time_of_day), - s7_make_typed_function (sc, s_get_time_of_day, f_get_time_of_day, - 0, 0, false, d_get_time_of_day, NULL)); + s7_make_typed_function (sc, s_get_time_of_day, f_get_time_of_day, 0, 0, false, d_get_time_of_day, NULL)); const char* s_monotonic_nanosecond= "g_monotonic-nanosecond"; - const char* d_monotonic_nanosecond= - "(g_monotonic-nanosecond): () => integer, returns the steady clock's " - "monotonic " - "nanoseconds since an unspecified epoch"; + const char* d_monotonic_nanosecond= "(g_monotonic-nanosecond): () => integer, returns the steady clock's monotonic " + "nanoseconds since an unspecified epoch"; s7_define (sc, cur_env, s7_make_symbol (sc, s_monotonic_nanosecond), - s7_make_typed_function (sc, s_monotonic_nanosecond, - f_monotonic_nanosecond, 0, 0, false, + s7_make_typed_function (sc, s_monotonic_nanosecond, f_monotonic_nanosecond, 0, 0, false, d_monotonic_nanosecond, NULL)); - s7_define_constant_with_environment ( - sc, cur_env, "g_system-clock-resolution", - s7_make_integer (sc, clock_resolution_ns ())); - s7_define_constant_with_environment ( - sc, cur_env, "g_steady-clock-resolution", - s7_make_integer (sc, clock_resolution_ns ())); + s7_define_constant_with_environment (sc, cur_env, "g_system-clock-resolution", + s7_make_integer (sc, clock_resolution_ns ())); + s7_define_constant_with_environment (sc, cur_env, "g_steady-clock-resolution", + s7_make_integer (sc, clock_resolution_ns ())); } static s7_pointer @@ -273,9 +258,7 @@ f_get_environment_variable (s7_scheme* sc, s7_pointer args) { if (environment) { size= tb_environment_load (environment, key); if (size >= 1) { - tb_for_all_if (tb_char_t const*, value, environment, value) { - ret.append (value).append (path_sep); - } + tb_for_all_if (tb_char_t const*, value, environment, value) { ret.append (value).append (path_sep); } } } tb_environment_exit (environment); @@ -322,8 +305,7 @@ f_getenvs (s7_scheme* sc, s7_pointer args) { for (int32_t i= 0; environ[i]; i++) { const char* eq= strchr (environ[i], '='); if (eq) { - s7_pointer name= - s7_make_string_with_length (sc, environ[i], eq - environ[i]); + s7_pointer name = s7_make_string_with_length (sc, environ[i], eq - environ[i]); s7_pointer value= s7_make_string (sc, eq + 1); p = s7_cons (sc, s7_cons (sc, name, value), p); } @@ -338,24 +320,19 @@ glue_scheme_process_context (s7_scheme* sc) { s7_pointer cur_env= s7_curlet (sc); const char* s_get_environment_variable= "g_get-environment-variable"; - const char* d_get_environment_variable= - "(g_get-environemt-variable string) => string"; - const char* s_command_line= "g_command-line"; - const char* d_command_line= "(g_command-line) => string"; - const char* s_getenvs = "g_getenvs"; - const char* d_getenvs= - "(g_getenvs) => alist, returns all environment variables as an alist"; + const char* d_get_environment_variable= "(g_get-environemt-variable string) => string"; + const char* s_command_line = "g_command-line"; + const char* d_command_line = "(g_command-line) => string"; + const char* s_getenvs = "g_getenvs"; + const char* d_getenvs = "(g_getenvs) => alist, returns all environment variables as an alist"; s7_define (sc, cur_env, s7_make_symbol (sc, s_get_environment_variable), - s7_make_typed_function (sc, s_get_environment_variable, - f_get_environment_variable, 1, 0, false, + s7_make_typed_function (sc, s_get_environment_variable, f_get_environment_variable, 1, 0, false, d_get_environment_variable, NULL)); s7_define (sc, cur_env, s7_make_symbol (sc, s_command_line), - s7_make_typed_function (sc, s_command_line, f_command_line, 0, 0, - false, d_command_line, NULL)); + s7_make_typed_function (sc, s_command_line, f_command_line, 0, 0, false, d_command_line, NULL)); s7_define (sc, cur_env, s7_make_symbol (sc, s_getenvs), - s7_make_typed_function (sc, s_getenvs, f_getenvs, 0, 0, false, - d_getenvs, NULL)); + s7_make_typed_function (sc, s_getenvs, f_getenvs, 0, 0, false, d_getenvs, NULL)); } string @@ -414,8 +391,7 @@ f_which (s7_scheme* sc, s7_pointer args) { vector search_dirs; string cmd_name; - bool has_dir_sep= (cmd_str.find ('/') != string::npos) || - (cmd_str.find ('\\') != string::npos); + bool has_dir_sep= (cmd_str.find ('/') != string::npos) || (cmd_str.find ('\\') != string::npos); if (has_dir_sep) { size_t last_sep= cmd_str.find_last_of ("/\\"); @@ -517,8 +493,7 @@ f_which (s7_scheme* sc, s7_pointer args) { inline void glue_which (s7_scheme* sc) { const char* name= "g_which"; - const char* desc= "(g_which cmd [path]) => string or #f, locate a command in " - "PATH or given search path"; + const char* desc= "(g_which cmd [path]) => string or #f, locate a command in PATH or given search path"; glue_define (sc, name, desc, f_which, 1, 1); } @@ -548,8 +523,7 @@ f_sleep (s7_scheme* sc, s7_pointer args) { inline void glue_sleep (s7_scheme* sc) { const char* name= "g_sleep"; - const char* desc= - "(g_sleep seconds) => nil, sleep for the specified number of seconds"; + const char* desc= "(g_sleep seconds) => nil, sleep for the specified number of seconds"; glue_define (sc, name, desc, f_sleep, 1, 0); } @@ -593,19 +567,15 @@ f_datetime_now (s7_scheme* sc, s7_pointer args) { uli.LowPart = ft.dwLowDateTime; uli.HighPart= ft.dwHighDateTime; // Convert to microseconds and get modulo - micros= (uli.QuadPart / 10) % - 1000000; // Convert from 100-nanosecond intervals to microseconds + micros= (uli.QuadPart / 10) % 1000000; // Convert from 100-nanosecond intervals to microseconds #else // Standard approach for other platforms auto now_chrono= std::chrono::system_clock::now (); auto duration = now_chrono.time_since_epoch (); - micros= std::chrono::duration_cast (duration) - .count () % - 1000000; + micros = std::chrono::duration_cast (duration).count () % 1000000; #endif - // Create a vector with the time components - vector is easier to index than - // list in Scheme + // Create a vector with the time components - vector is easier to index than list in Scheme s7_pointer time_vec= s7_make_vector (sc, 7); // Fill the vector with values @@ -615,7 +585,7 @@ f_datetime_now (s7_scheme* sc, s7_pointer args) { s7_vector_set (sc, time_vec, 3, s7_make_integer (sc, lt.hour)); // hour s7_vector_set (sc, time_vec, 4, s7_make_integer (sc, lt.minute)); // minute s7_vector_set (sc, time_vec, 5, s7_make_integer (sc, lt.second)); // second - s7_vector_set (sc, time_vec, 6, s7_make_integer (sc, micros)); // micro-second + s7_vector_set (sc, time_vec, 6, s7_make_integer (sc, micros)); // micro-second return time_vec; } @@ -623,8 +593,7 @@ f_datetime_now (s7_scheme* sc, s7_pointer args) { inline void glue_datetime_now (s7_scheme* sc) { const char* name= "g_datetime-now"; - const char* desc= "(g_datetime-now) => datetime, create a datetime object " - "with current time"; + const char* desc= "(g_datetime-now) => datetime, create a datetime object with current time"; s7_define_function (sc, name, f_datetime_now, 0, 0, false, desc); } @@ -639,8 +608,7 @@ f_date_now (s7_scheme* sc, s7_pointer args) { return s7_f (sc); } - // Create a vector with the time components - vector is easier to index than - // list in Scheme + // Create a vector with the time components - vector is easier to index than list in Scheme s7_pointer time_vec= s7_make_vector (sc, 3); // Fill the vector with values @@ -654,8 +622,7 @@ f_date_now (s7_scheme* sc, s7_pointer args) { inline void glue_date_now (s7_scheme* sc) { const char* name= "g_date-now"; - const char* desc= - "(g_date-now) => date, create a date object with current date"; + const char* desc= "(g_date-now) => date, create a date object with current date"; s7_define_function (sc, name, f_date_now, 0, 0, false, desc); } @@ -683,31 +650,23 @@ iota_list (s7_scheme* sc, s7_int count, s7_pointer start, s7_int step) { } static s7_pointer -iota_list_p_ppp (s7_scheme* sc, s7_pointer count, s7_pointer start, - s7_pointer step) { +iota_list_p_ppp (s7_scheme* sc, s7_pointer count, s7_pointer start, s7_pointer step) { if (!s7_is_integer (count)) { - return s7_error ( - sc, s7_make_symbol (sc, "type-error"), - s7_list (sc, 2, s7_make_string (sc, "iota: count must be an integer"), - count)); + return s7_error (sc, s7_make_symbol (sc, "type-error"), + s7_list (sc, 2, s7_make_string (sc, "iota: count must be an integer"), count)); } if (!s7_is_integer (start)) { - return s7_error ( - sc, s7_make_symbol (sc, "type-error"), - s7_list (sc, 2, s7_make_string (sc, "iota: start must be an integer"), - start)); + return s7_error (sc, s7_make_symbol (sc, "type-error"), + s7_list (sc, 2, s7_make_string (sc, "iota: start must be an integer"), start)); } if (!s7_is_integer (step)) { - return s7_error ( - sc, s7_make_symbol (sc, "type-error"), - s7_list (sc, 2, s7_make_string (sc, "iota: step must be an integer"), - step)); + return s7_error (sc, s7_make_symbol (sc, "type-error"), + s7_list (sc, 2, s7_make_string (sc, "iota: step must be an integer"), step)); } s7_int cnt= s7_integer (count); if (cnt < 0) { - return s7_error ( - sc, s7_make_symbol (sc, "value-error"), - s7_list (sc, 2, s7_make_string (sc, "iota: count is negative"), count)); + return s7_error (sc, s7_make_symbol (sc, "value-error"), + s7_list (sc, 2, s7_make_string (sc, "iota: count is negative"), count)); } s7_int st = s7_integer (start); s7_int stp= s7_integer (step); @@ -718,21 +677,16 @@ static s7_pointer g_iota_list (s7_scheme* sc, s7_pointer args) { s7_pointer arg1 = s7_car (args); // count s7_pointer rest1= s7_cdr (args); - s7_pointer arg2 = (s7_is_pair (rest1)) - ? s7_car (rest1) - : s7_make_integer (sc, 0); // start value, default 0 + s7_pointer arg2 = (s7_is_pair (rest1)) ? s7_car (rest1) : s7_make_integer (sc, 0); // start value, default 0 s7_pointer rest2= s7_cdr (rest1); - s7_pointer arg3 = (s7_is_pair (rest2)) - ? s7_car (rest2) - : s7_make_integer (sc, 1); // step size, default 1 + s7_pointer arg3 = (s7_is_pair (rest2)) ? s7_car (rest2) : s7_make_integer (sc, 1); // step size, default 1 return iota_list_p_ppp (sc, arg1, arg2, arg3); } inline void glue_iota_list (s7_scheme* sc) { const char* name= "iota"; - const char* desc= "(iota count [start [step]]) => list, returns a list of " - "count elements starting from start " + const char* desc= "(iota count [start [step]]) => list, returns a list of count elements starting from start " "(default 0) with step (default 1)"; s7_define_function (sc, name, g_iota_list, 1, 2, false, desc); } @@ -751,14 +705,20 @@ glue_for_community_edition (s7_scheme* sc) { glue_liii_os (sc); glue_subprocess_run_values (sc); glue_liii_path (sc); + glue_liii_sort (sc); glue_liii_list (sc); + glue_liii_string (sc); + glue_liii_string_cursor (sc); glue_liii_time (sc); glue_liii_datetime (sc); glue_liii_uuid (sc); glue_liii_hashlib (sc); glue_liii_base64 (sc); + glue_liii_json (sc); glue_scheme_base (sc); glue_scheme_char (sc); + glue_r7rs_library (sc); + glue_liii_record (sc); glue_njson (sc); #ifdef GOLDFISH_ENABLE_HTTP glue_http (sc); @@ -775,96 +735,56 @@ display_help () { cout << " version Display version" << endl; cout << " eval CODE Evaluate Scheme code" << endl; cout << " Example: gf eval '(+ 1 2)'" << endl; - cout << " Prefer single quotes so double quotes inside " - "Scheme strings usually do not need escaping" - << endl; - cout << " load FILE Load Scheme code from FILE, then enter REPL" - << endl; - cout << " fix [options] PATH Format PATH (PATH can be a .scm file or " - "directory)" - << endl; + cout + << " Prefer single quotes so double quotes inside Scheme strings usually do not need escaping" + << endl; + cout << " load FILE Load Scheme code from FILE, then enter REPL" << endl; + cout << " fix [options] PATH Format PATH (PATH can be a .scm file or directory)" << endl; cout << " Options:" << endl; - cout << " --dry-run Print formatted result to stdout" - << endl; - cout << " source ORG/LIB Print the exact source of ORG/LIB from current " - "*load-path*" - << endl; - cout << " Reads the real library file, not tests/ or " - "generated docs" - << endl; + cout << " --dry-run Print formatted result to stdout" << endl; + cout << " source ORG/LIB Print the exact source of ORG/LIB from current *load-path*" << endl; + cout << " Reads the real library file, not tests/ or generated docs" << endl; cout << " Example: gf source liii/path" << endl; - cout << " doc ORG/LIB Show the library overview for ORG/LIB from " - "tests/" - << endl; + cout << " doc ORG/LIB Show the library overview for ORG/LIB from tests/" << endl; cout << " Usually reads tests/ORG/LIB-test.scm" << endl; cout << " Example: gf doc liii/path" << endl; - cout << " doc ORG/LIB FUNC Show the function doc/test file for FUNC under " - "a specific library" - << endl; - cout << " Best when you already know the library, or the " - "name is ambiguous" - << endl; - cout << " Example: gf doc liii/path \"path-read-text\"" - << endl; - cout << " Quote FUNC for names like \"bag-delete!\", " - "\"path?\", \"alist->fxmapping\", or " + cout << " doc ORG/LIB FUNC Show the function doc/test file for FUNC under a specific library" << endl; + cout << " Best when you already know the library, or the name is ambiguous" << endl; + cout << " Example: gf doc liii/path \"path-read-text\"" << endl; + cout << " Quote FUNC for names like \"bag-delete!\", \"path?\", \"alist->fxmapping\", or " "\"bag<=?\"" << endl; - cout << " This preserves symbols such as ! ? > < and " - "keeps FUNC as one shell argument" - << endl; - cout << " doc FUNC Search visible libraries for exported FUNC, " - "then show its doc/test file" - << endl; - cout << " If multiple libraries export it, candidates " - "are listed" - << endl; + cout << " This preserves symbols such as ! ? > < and keeps FUNC as one shell argument" << endl; + cout << " doc FUNC Search visible libraries for exported FUNC, then show its doc/test file" << endl; + cout << " If multiple libraries export it, candidates are listed" << endl; cout << " Example: gf doc \"string-split\"" << endl; - cout << " Quote FUNC for names like \"bag-delete!\", " - "\"path?\", \"alist->fxmapping\", or " + cout << " Quote FUNC for names like \"bag-delete!\", \"path?\", \"alist->fxmapping\", or " "\"bag<=?\"" << endl; - cout << " This keeps shell-sensitive symbols intact and " - "makes it clear FUNC is one argument" - << endl; - cout << " doc --build-json Rebuild tests/function-library-index.json for " - "global gf doc FUNC lookup" - << endl; - cout << " Needed by function-name search and fuzzy " - "suggestions" - << endl; - cout << " Run this after changing exports, or before " - "packaging" - << endl; - cout << " test [PATTERN] Run tests (all *-test.scm files under tests/)" + cout << " This keeps shell-sensitive symbols intact and makes it clear FUNC is one argument" << endl; + cout << " doc --build-json Rebuild tests/function-library-index.json for global gf doc FUNC lookup" << endl; + cout << " Needed by function-name search and fuzzy suggestions" << endl; + cout << " Run this after changing exports, or before packaging" << endl; + cout << " test [PATTERN] Run tests (all *-test.scm files under tests/)" << endl; cout << " PATTERN can be:" << endl; cout << " (none) Run all tests" << endl; - cout << " FILE.scm Run specific test file" - << endl; - cout << " DIR/ Run tests in directory" - << endl; + cout << " FILE.scm Run specific test file" << endl; + cout << " DIR/ Run tests in directory" << endl; cout << " name-test.scm Match by file name" << endl; - cout << " substring Match by path substring" - << endl; + cout << " substring Match by path substring" << endl; cout << " run TARGET Run main function from TARGET" << endl; cout << " TARGET can be:" << endl; - cout << " FILE.scm Load file and run main" - << endl; - cout << " x/y/z.scm Load file and run main" - << endl; - cout << " module.name Import (module name) and run " - "main" - << endl; + cout << " FILE.scm Load file and run main" << endl; + cout << " x/y/z.scm Load file and run main" << endl; + cout << " module.name Import (module name) and run main" << endl; #ifdef GOLDFISH_WITH_REPL cout << " repl Enter interactive REPL mode" << endl; #endif - cout << " FILE Load and evaluate Scheme code from FILE" - << endl; + cout << " FILE Load and evaluate Scheme code from FILE" << endl; cout << endl; cout << "Options:" << endl; - cout << " --mode, -m MODE Set mode: default, liii, sicp, r7rs, s7" - << endl; + cout << " --mode, -m MODE Set mode: default, liii, sicp, r7rs, s7" << endl; cout << " -I DIR Prepend DIR to library search path" << endl; cout << " -A DIR Append DIR to library search path" << endl; cout << " -e CODE Alias for eval CODE" << endl; @@ -912,8 +832,7 @@ goldfish_cli_program_name () { static bool goldfish_is_fix_hint_candidate_error (const string& errmsg) { - return errmsg.find ("unexpected close paren") != string::npos || - errmsg.find ("missing close paren") != string::npos; + return errmsg.find ("unexpected close paren") != string::npos || errmsg.find ("missing close paren") != string::npos; } static string @@ -923,8 +842,8 @@ goldfish_extract_scheme_path_from_error (const string& errmsg) { size_t start= marker; while (start > 0) { unsigned char ch= static_cast (errmsg[start - 1]); - if (std::isspace (ch) || ch == '"' || ch == '\'' || ch == '`' || - ch == '(' || ch == ')' || ch == ',' || ch == ';') { + if (std::isspace (ch) || ch == '"' || ch == '\'' || ch == '`' || ch == '(' || ch == ')' || ch == ',' || + ch == ';') { break; } --start; @@ -959,18 +878,15 @@ goldfish_extract_error_expression (const string& errmsg, size_t search_start) { } static bool -goldfish_form_contains_called_symbol (s7_scheme* sc, s7_pointer form, - const string& function_name) { +goldfish_form_contains_called_symbol (s7_scheme* sc, s7_pointer form, const string& function_name) { if (s7_is_pair (form)) { s7_pointer operator_form= s7_car (form); - if (s7_is_symbol (operator_form) && - (function_name == s7_symbol_name (operator_form))) { + if (s7_is_symbol (operator_form) && (function_name == s7_symbol_name (operator_form))) { return true; } for (s7_pointer iter= form; s7_is_pair (iter); iter= s7_cdr (iter)) { - if (goldfish_form_contains_called_symbol (sc, s7_car (iter), - function_name)) { + if (goldfish_form_contains_called_symbol (sc, s7_car (iter), function_name)) { return true; } } @@ -979,8 +895,7 @@ goldfish_form_contains_called_symbol (s7_scheme* sc, s7_pointer form, while (s7_is_pair (tail)) { tail= s7_cdr (tail); } - if ((!s7_is_null (sc, tail)) && - goldfish_form_contains_called_symbol (sc, tail, function_name)) { + if ((!s7_is_null (sc, tail)) && goldfish_form_contains_called_symbol (sc, tail, function_name)) { return true; } } @@ -989,8 +904,7 @@ goldfish_form_contains_called_symbol (s7_scheme* sc, s7_pointer form, } static bool -goldfish_error_expression_contains_function_call (s7_scheme* sc, - const string& expression, +goldfish_error_expression_contains_function_call (s7_scheme* sc, const string& expression, const string& function_name) { if (expression.empty ()) { return false; @@ -1009,8 +923,7 @@ goldfish_error_expression_contains_function_call (s7_scheme* sc, } static string -goldfish_extract_unbound_function_name_from_error (s7_scheme* sc, - const string& errmsg) { +goldfish_extract_unbound_function_name_from_error (s7_scheme* sc, const string& errmsg) { const string prefix= "unbound variable "; size_t start = errmsg.find (prefix); if (start == string::npos) { @@ -1037,8 +950,7 @@ goldfish_extract_unbound_function_name_from_error (s7_scheme* sc, } string error_expression= goldfish_extract_error_expression (errmsg, end); - if (!goldfish_error_expression_contains_function_call (sc, error_expression, - function_name)) { + if (!goldfish_error_expression_contains_function_call (sc, error_expression, function_name)) { return ""; } @@ -1067,8 +979,8 @@ goldfish_format_scheme_error_message (const char* errmsg) { if ((!formatted.empty ()) && (formatted.back () != '\n')) { formatted+= '\n'; } - formatted+= "Hint: try `" + goldfish_cli_program_name () + " fix " + path + - "` to repair common parenthesis issues.\n"; + formatted+= + "Hint: try `" + goldfish_cli_program_name () + " fix " + path + "` to repair common parenthesis issues.\n"; return formatted; } @@ -1119,10 +1031,8 @@ goldfish_library_import_form (const string& library_query) { } static string -goldfish_library_doc_command (const string& library_query, - const string& function_name) { - return goldfish_cli_program_name () + " doc " + library_query + " " + - goldfish_shell_double_quote (function_name); +goldfish_library_doc_command (const string& library_query, const string& function_name) { + return goldfish_cli_program_name () + " doc " + library_query + " " + goldfish_shell_double_quote (function_name); } static string @@ -1131,8 +1041,7 @@ goldfish_append_doc_hint_if_needed (s7_scheme* sc, const string& errmsg) { return errmsg; } - string function_name= - goldfish_extract_unbound_function_name_from_error (sc, errmsg); + string function_name= goldfish_extract_unbound_function_name_from_error (sc, errmsg); if (function_name.empty ()) { return errmsg; } @@ -1150,13 +1059,11 @@ goldfish_append_doc_hint_if_needed (s7_scheme* sc, const string& errmsg) { } if (library_queries.empty ()) { - formatted+= "Hint: try `" + goldfish_cli_program_name () + " doc " + - goldfish_shell_double_quote (function_name) + "`\n"; - formatted+= "`" + goldfish_cli_program_name () + - " doc` may show similarly named functions when there is no " - "exact match.\n"; - formatted+= "If it finds nothing similar, try searching the codebase with " - "`git grep " + + formatted+= + "Hint: try `" + goldfish_cli_program_name () + " doc " + goldfish_shell_double_quote (function_name) + "`\n"; + formatted+= + "`" + goldfish_cli_program_name () + " doc` may show similarly named functions when there is no exact match.\n"; + formatted+= "If it finds nothing similar, try searching the codebase with `git grep " + goldfish_shell_double_quote (function_name) + "`, implement that function yourself, or stop using it.\n"; return formatted; @@ -1165,33 +1072,27 @@ goldfish_append_doc_hint_if_needed (s7_scheme* sc, const string& errmsg) { if (library_queries.size () == 1) { string import_form= goldfish_library_import_form (library_queries.front ()); formatted+= "Hint: function `" + function_name + "` exists in library `" + - goldfish_library_display_name (library_queries.front ()) + - "`.\n"; + goldfish_library_display_name (library_queries.front ()) + "`.\n"; if (!import_form.empty ()) { formatted+= "Please import that library first: `" + import_form + "`.\n"; } return formatted; } - formatted+= "Hint: function `" + function_name + - "` exists in multiple visible libraries:\n"; + formatted+= "Hint: function `" + function_name + "` exists in multiple visible libraries:\n"; for (const auto& library_query : library_queries) { formatted+= " " + goldfish_library_display_name (library_query) + "\n"; } formatted+= "Try one of these commands to decide which library to use:\n"; for (const auto& library_query : library_queries) { - formatted+= " " + - goldfish_library_doc_command (library_query, function_name) + - "\n"; + formatted+= " " + goldfish_library_doc_command (library_query, function_name) + "\n"; } return formatted; } static void -goldfish_render_scheme_error_message (s7_scheme* sc, const char* errmsg, - string& rendered) { - rendered= goldfish_append_doc_hint_if_needed ( - sc, goldfish_format_scheme_error_message (errmsg)); +goldfish_render_scheme_error_message (s7_scheme* sc, const char* errmsg, string& rendered) { + rendered= goldfish_append_doc_hint_if_needed (sc, goldfish_format_scheme_error_message (errmsg)); if ((!rendered.empty ()) && (rendered.back () != '\n')) { rendered+= '\n'; } @@ -1207,9 +1108,7 @@ goldfish_print_scheme_error_message (s7_scheme* sc, const char* errmsg) { } static void -goldfish_print_prefixed_scheme_error_message (s7_scheme* sc, - const string& prefix, - const char* errmsg) { +goldfish_print_prefixed_scheme_error_message (s7_scheme* sc, const string& prefix, const char* errmsg) { if ((errmsg) && (*errmsg)) { string rendered; goldfish_render_scheme_error_message (sc, errmsg, rendered); @@ -1232,8 +1131,7 @@ static string find_golddoc_tool_root (const char* gf_lib) { std::error_code ec; vector candidates= {fs::path (gf_lib) / "tools" / "doc", - fs::path (gf_lib).parent_path () / "tools" / - "doc"}; + fs::path (gf_lib).parent_path () / "tools" / "doc"}; for (const auto& candidate : candidates) { if (fs::is_directory (candidate, ec)) { @@ -1249,8 +1147,7 @@ static string find_goldsource_tool_root (const char* gf_lib) { std::error_code ec; vector candidates= {fs::path (gf_lib) / "tools" / "source", - fs::path (gf_lib).parent_path () / "tools" / - "source"}; + fs::path (gf_lib).parent_path () / "tools" / "source"}; for (const auto& candidate : candidates) { if (fs::is_directory (candidate, ec)) { @@ -1266,8 +1163,7 @@ static string find_goldhelp_tool_root (const char* gf_lib) { std::error_code ec; vector candidates= {fs::path (gf_lib) / "tools" / "help", - fs::path (gf_lib).parent_path () / "tools" / - "help"}; + fs::path (gf_lib).parent_path () / "tools" / "help"}; for (const auto& candidate : candidates) { if (fs::is_directory (candidate, ec)) { @@ -1332,8 +1228,7 @@ load_json_file_or_empty (const fs::path& path) { static json gfproject_extract_tools (const json& config) { - if (config.is_object () && config.contains ("tools") && - config["tools"].is_object ()) { + if (config.is_object () && config.contains ("tools") && config["tools"].is_object ()) { return config["tools"]; } return json::object (); @@ -1365,18 +1260,16 @@ struct gfproject_config_bundle { static gfproject_config_bundle load_gfproject_config_bundle (const char* gf_lib) { gfproject_config_bundle bundle; - bundle.lib_config= load_json_file_or_empty (find_lib_gfproject_json (gf_lib)); + bundle.lib_config = load_json_file_or_empty (find_lib_gfproject_json (gf_lib)); bundle.local_config= load_json_file_or_empty (find_local_gfproject_json ()); - json merged= - bundle.lib_config.is_object () ? bundle.lib_config : json::object (); + json merged = bundle.lib_config.is_object () ? bundle.lib_config : json::object (); json merged_tools= gfproject_extract_tools (bundle.lib_config); json local_tools = gfproject_extract_tools (bundle.local_config); for (const auto& [command, local_tool] : local_tools.items ()) { if (merged_tools.contains (command)) { - merged_tools[command]= - gfproject_deep_merge_value (merged_tools[command], local_tool); + merged_tools[command]= gfproject_deep_merge_value (merged_tools[command], local_tool); } else { merged_tools[command]= local_tool; @@ -1403,10 +1296,10 @@ struct gfproject_tool_resolution { static gfproject_tool_resolution resolve_gfproject_tool (const char* gf_lib, const string& command) { - gfproject_config_bundle bundle= load_gfproject_config_bundle (gf_lib); - json local_tools = gfproject_extract_tools (bundle.local_config); - json lib_tools = gfproject_extract_tools (bundle.lib_config); - json merged_tools= gfproject_extract_tools (bundle.merged_config); + gfproject_config_bundle bundle = load_gfproject_config_bundle (gf_lib); + json local_tools = gfproject_extract_tools (bundle.local_config); + json lib_tools = gfproject_extract_tools (bundle.lib_config); + json merged_tools= gfproject_extract_tools (bundle.merged_config); gfproject_tool_resolution resolved; resolved.has_local_override= local_tools.contains (command); @@ -1443,35 +1336,27 @@ struct gfproject_tool_prepare_result { s7_pointer main_func= nullptr; }; -static string find_tool_root_by_command (const char* gf_lib, - const string& command); +static string find_tool_root_by_command (const char* gf_lib, const string& command); static gfproject_tool_prepare_result -goldfish_prepare_tool_main (s7_scheme* sc, const char* gf_lib, - const string& command, const json& tool_config) { +goldfish_prepare_tool_main (s7_scheme* sc, const char* gf_lib, const string& command, const json& tool_config) { gfproject_tool_prepare_result result; if (!tool_config.is_object ()) { - result.error= gfproject_tool_prepare_error::invalid_config_value; - result.message= - "Error: Tool '" + command + "' config must be a JSON object."; + result.error = gfproject_tool_prepare_error::invalid_config_value; + result.message= "Error: Tool '" + command + "' config must be a JSON object."; return result; } - if (!tool_config.contains ("organization") || - !tool_config.contains ("module")) { - result.error= gfproject_tool_prepare_error::incomplete_config; - result.message= - "Error: Tool '" + command + - "' is not fully implemented (missing organization or module)."; + if (!tool_config.contains ("organization") || !tool_config.contains ("module")) { + result.error = gfproject_tool_prepare_error::incomplete_config; + result.message= "Error: Tool '" + command + "' is not fully implemented (missing organization or module)."; return result; } - if (!tool_config["organization"].is_string () || - !tool_config["module"].is_string ()) { - result.error= gfproject_tool_prepare_error::invalid_config_value; - result.message= - "Error: Tool '" + command + "' organization/module must be strings."; + if (!tool_config["organization"].is_string () || !tool_config["module"].is_string ()) { + result.error = gfproject_tool_prepare_error::invalid_config_value; + result.message= "Error: Tool '" + command + "' organization/module must be strings."; return result; } @@ -1480,9 +1365,8 @@ goldfish_prepare_tool_main (s7_scheme* sc, const char* gf_lib, string tool_root= find_tool_root_by_command (gf_lib, command); if (tool_root.empty ()) { - result.error= gfproject_tool_prepare_error::missing_tool_root; - result.message= - "Error: tools/" + command + "/" + org + " directory not found."; + result.error = gfproject_tool_prepare_error::missing_tool_root; + result.message= "Error: tools/" + command + "/" + org + " directory not found."; return result; } @@ -1490,7 +1374,7 @@ goldfish_prepare_tool_main (s7_scheme* sc, const char* gf_lib, string import_expr = "(import (" + org + " " + module + "))"; s7_pointer import_result= s7_eval_c_string (sc, import_expr.c_str ()); - const char* errmsg= s7_get_output_string (sc, s7_current_error_port (sc)); + const char* errmsg = s7_get_output_string (sc, s7_current_error_port (sc)); if (!import_result || ((errmsg) && (*errmsg))) { result.error = gfproject_tool_prepare_error::import_failed; result.message= "Error importing (" + org + " " + module + "):"; @@ -1499,9 +1383,8 @@ goldfish_prepare_tool_main (s7_scheme* sc, const char* gf_lib, s7_pointer main_func= s7_name_to_value (sc, "main"); if ((!main_func) || (!s7_is_procedure (main_func))) { - result.error= gfproject_tool_prepare_error::missing_main; - result.message= - "Error: Failed to find main function in (" + org + " " + module + ")."; + result.error = gfproject_tool_prepare_error::missing_main; + result.message= "Error: Failed to find main function in (" + org + " " + module + ")."; return result; } @@ -1510,9 +1393,8 @@ goldfish_prepare_tool_main (s7_scheme* sc, const char* gf_lib, } static int -goldfish_finish_tool_error (s7_scheme* sc, const string& message, - const char*& errmsg, s7_pointer old_port, - int gc_loc, bool include_scheme_error) { +goldfish_finish_tool_error (s7_scheme* sc, const string& message, const char*& errmsg, s7_pointer old_port, int gc_loc, + bool include_scheme_error) { errmsg= s7_get_output_string (sc, s7_current_error_port (sc)); if (!message.empty ()) { if (include_scheme_error && (errmsg) && (*errmsg)) { @@ -1532,9 +1414,7 @@ goldfish_finish_tool_error (s7_scheme* sc, const string& message, } static int -goldfish_finish_tool_success (s7_scheme* sc, s7_pointer result, - const char*& errmsg, s7_pointer old_port, - int gc_loc) { +goldfish_finish_tool_success (s7_scheme* sc, s7_pointer result, const char*& errmsg, s7_pointer old_port, int gc_loc) { errmsg= s7_get_output_string (sc, s7_current_error_port (sc)); goldfish_print_scheme_error_message (sc, errmsg); s7_close_output_port (sc, s7_current_error_port (sc)); @@ -1547,22 +1427,17 @@ goldfish_finish_tool_success (s7_scheme* sc, s7_pointer result, } static int -goldfish_run_tool_with_config (s7_scheme* sc, const char* gf_lib, - const string& command, const json& tool_config, - const char*& errmsg, s7_pointer old_port, - int gc_loc, bool allow_fallback) { - gfproject_tool_prepare_result prepared= - goldfish_prepare_tool_main (sc, gf_lib, command, tool_config); +goldfish_run_tool_with_config (s7_scheme* sc, const char* gf_lib, const string& command, const json& tool_config, + const char*& errmsg, s7_pointer old_port, int gc_loc, bool allow_fallback) { + gfproject_tool_prepare_result prepared= goldfish_prepare_tool_main (sc, gf_lib, command, tool_config); if (prepared.error != gfproject_tool_prepare_error::none) { if (allow_fallback) { goldfish_reset_captured_error_port (sc); return -1; } - bool include_scheme_error= - prepared.error == gfproject_tool_prepare_error::import_failed; - return goldfish_finish_tool_error (sc, prepared.message, errmsg, old_port, - gc_loc, include_scheme_error); + bool include_scheme_error= prepared.error == gfproject_tool_prepare_error::import_failed; + return goldfish_finish_tool_error (sc, prepared.message, errmsg, old_port, gc_loc, include_scheme_error); } s7_pointer result= s7_call (sc, prepared.main_func, s7_nil (sc)); @@ -1593,32 +1468,28 @@ f_project_root (s7_scheme* sc, s7_pointer args) { } static int -goldfish_run_tool (s7_scheme* sc, const char* gf_lib, const string& command, - const char*& errmsg, s7_pointer old_port, int gc_loc) { +goldfish_run_tool (s7_scheme* sc, const char* gf_lib, const string& command, const char*& errmsg, s7_pointer old_port, + int gc_loc) { gfproject_tool_resolution resolved= resolve_gfproject_tool (gf_lib, command); if (!resolved.has_merged_tool) { return -1; } - bool allow_builtin_fallback= command == "help" || command == "version" || - command == "eval" || command == "load" || + bool allow_builtin_fallback= command == "help" || command == "version" || command == "eval" || command == "load" || command == "repl" || command == "run"; if (resolved.has_local_override && resolved.has_lib_tool) { - int merged_ret= goldfish_run_tool_with_config (sc, gf_lib, command, - resolved.merged_tool, errmsg, - old_port, gc_loc, true); + int merged_ret= + goldfish_run_tool_with_config (sc, gf_lib, command, resolved.merged_tool, errmsg, old_port, gc_loc, true); if (merged_ret != -1) { return merged_ret; } - return goldfish_run_tool_with_config (sc, gf_lib, command, - resolved.lib_tool, errmsg, old_port, - gc_loc, allow_builtin_fallback); + return goldfish_run_tool_with_config (sc, gf_lib, command, resolved.lib_tool, errmsg, old_port, gc_loc, + allow_builtin_fallback); } - return goldfish_run_tool_with_config (sc, gf_lib, command, - resolved.merged_tool, errmsg, old_port, - gc_loc, allow_builtin_fallback); + return goldfish_run_tool_with_config (sc, gf_lib, command, resolved.merged_tool, errmsg, old_port, gc_loc, + allow_builtin_fallback); } static string @@ -1654,8 +1525,7 @@ static string read_text_file_exact (const fs::path& path) { std::ifstream input (path, std::ios::binary); if (!input.is_open ()) { - throw std::runtime_error ("Failed to open file for reading: " + - path.string ()); + throw std::runtime_error ("Failed to open file for reading: " + path.string ()); } std::ostringstream buffer; @@ -1679,15 +1549,13 @@ init_goldfish_scheme (const char* gf_lib) { } void -customize_goldfish_by_mode (s7_scheme* sc, string mode, - const char* boot_file_path) { +customize_goldfish_by_mode (s7_scheme* sc, string mode, const char* boot_file_path) { if (mode != "s7") { s7_load (sc, boot_file_path); } if (mode == "default" || mode == "liii") { - s7_eval_c_string ( - sc, "(import (scheme base) (liii base) (liii error) (liii string))"); + s7_eval_c_string (sc, "(import (scheme base) (liii base) (liii error) (liii string))"); } else if (mode == "scheme") { s7_eval_c_string (sc, "(import (liii base) (liii error))"); @@ -1711,16 +1579,13 @@ find_goldfish_library () { string exe_path= goldfish_exe (); tb_char_t data_bin[TB_PATH_MAXN]= {0}; - tb_char_t const* ret_bin= - tb_path_directory (exe_path.c_str (), data_bin, sizeof (data_bin)); + tb_char_t const* ret_bin = tb_path_directory (exe_path.c_str (), data_bin, sizeof (data_bin)); tb_char_t data_root[TB_PATH_MAXN]= {0}; - tb_char_t const* gf_root= - tb_path_directory (ret_bin, data_root, sizeof (data_root)); + tb_char_t const* gf_root = tb_path_directory (ret_bin, data_root, sizeof (data_root)); tb_char_t data_lib[TB_PATH_MAXN]= {0}; - tb_char_t const* gf_lib= tb_path_absolute_to (gf_root, "share/goldfish", - data_lib, sizeof (data_lib)); + tb_char_t const* gf_lib = tb_path_absolute_to (gf_root, "share/goldfish", data_lib, sizeof (data_lib)); #ifdef TB_CONFIG_OS_LINUX if (strcmp (gf_root, "/") == 0) { gf_lib= "/usr/share/goldfish"; @@ -1728,11 +1593,9 @@ find_goldfish_library () { #endif if (!tb_file_access (gf_lib, TB_FILE_MODE_RO)) { - gf_lib= - tb_path_absolute_to (gf_root, "goldfish", data_lib, sizeof (data_lib)); + gf_lib= tb_path_absolute_to (gf_root, "goldfish", data_lib, sizeof (data_lib)); if (!tb_file_access (gf_lib, TB_FILE_MODE_RO)) { - cerr << "The load path for Goldfish standard library does not exist" - << endl; + cerr << "The load path for Goldfish standard library does not exist" << endl; exit (-1); } } @@ -1743,8 +1606,7 @@ find_goldfish_library () { string find_goldfish_boot (const char* gf_lib) { tb_char_t data_boot[TB_PATH_MAXN]= {0}; - tb_char_t const* gf_boot= tb_path_absolute_to (gf_lib, "scheme/boot.scm", - data_boot, sizeof (data_boot)); + tb_char_t const* gf_boot= tb_path_absolute_to (gf_lib, "scheme/boot.scm", data_boot, sizeof (data_boot)); if (!tb_file_access (gf_boot, TB_FILE_MODE_RO)) { cerr << "The boot.scm for Goldfish Scheme does not exist" << endl; @@ -1784,8 +1646,7 @@ update_symbol_cache (s7_scheme* sc) { inline void ic_goldfish_eval (s7_scheme* sc, const char* code) { int err_gc_loc= -1, out_gc_loc= -1; - s7_pointer old_err_port= - s7_set_current_error_port (sc, s7_open_output_string (sc)); + s7_pointer old_err_port= s7_set_current_error_port (sc, s7_open_output_string (sc)); if (old_err_port != s7_nil (sc)) err_gc_loc= s7_gc_protect (sc, old_err_port); s7_pointer out_port = s7_open_output_string (sc); @@ -1922,8 +1783,7 @@ goldfish_highlighter (ic_highlight_env_t* henv, const char* input, void* arg) { long len = (long) strlen (input); for (long i= 0; i < len;) { long tlen; - if ((tlen= ic_match_any_token (input, i, &ic_char_is_idletter, keywords)) > - 0) { + if ((tlen= ic_match_any_token (input, i, &ic_char_is_idletter, keywords)) > 0) { // 关键字 ic_highlight (henv, i, tlen, "keyword"); i+= tlen; @@ -1932,9 +1792,8 @@ goldfish_highlighter (ic_highlight_env_t* henv, const char* input, void* arg) { // 已定义符号 std::string token (input + i, tlen); - if (std::any_of ( - cached_symbols.begin (), cached_symbols.end (), - [&] (const SymbolInfo& info) { return info.name == token; })) { + if (std::any_of (cached_symbols.begin (), cached_symbols.end (), + [&] (const SymbolInfo& info) { return info.name == token; })) { ic_highlight (henv, i, tlen, "symbol"); } else { @@ -1982,8 +1841,7 @@ struct MetaCommand { const char* help; bool exact; - std::function - handler; + std::function handler; }; inline bool meta_quit (const char*, s7_scheme*, const char*); @@ -2076,10 +1934,8 @@ meta_describe (const char*, s7_scheme* sc, const char* arg) { s7_int min_args= s7_integer (s7_car (arity)); s7_int max_args= s7_integer (s7_cdr (arity)); - std::string max_str= - (max_args >= 0x20000000) ? "any" : std::to_string (max_args); - ic_printf (" [gray]Arity:[/] min [number]%d[/], max [number]%s[/]\n", - min_args, max_str.c_str ()); + std::string max_str= (max_args >= 0x20000000) ? "any" : std::to_string (max_args); + ic_printf (" [gray]Arity:[/] min [number]%d[/], max [number]%s[/]\n", min_args, max_str.c_str ()); s7_pointer sig= s7_signature (sc, val); if (sig && !s7_is_null (sc, sig)) { @@ -2117,8 +1973,7 @@ handle_meta_command (const char* input, s7_scheme* sc) { for (const auto& cmd : commands) { size_t len= strlen (cmd.name); if (cmd.exact) { - if (strcmp (input, cmd.name) == 0) - return cmd.handler (input, sc, nullptr); + if (strcmp (input, cmd.name) == 0) return cmd.handler (input, sc, nullptr); } else { if (strncmp (input, cmd.name, len) == 0) { @@ -2149,8 +2004,7 @@ goldfish_repl (s7_scheme* sc, const string& mode) { GOLDFISH_VERSION, S7_VERSION, S7_DATE); // Display mode info; liii mode shows extra imported libraries if (mode == "liii" || mode == "default") { - ic_printf ("[b]Mode:[/] [b]%s[/] (additionally imports: (scheme base) " - "(liii base) (liii error) (liii string) " + ic_printf ("[b]Mode:[/] [b]%s[/] (additionally imports: (scheme base) (liii base) (liii error) (liii string) " "compared to r7rs)\n\n", mode.c_str ()); } @@ -2160,8 +2014,7 @@ goldfish_repl (s7_scheme* sc, const string& mode) { ic_printf ("- Type ',quit' or ',q' to quit. (or use [kbd]ctrl-d[/]).\n" "- Type ',help' for REPL commands help.\n" "- Press [kbd]F1[/] for help on editing commands.\n" - "- Use [kbd]shift-tab[/] for multiline input. (or " - "[kbd]ctrl-enter[/], or [kbd]ctrl-j[/])\n" + "- Use [kbd]shift-tab[/] for multiline input. (or [kbd]ctrl-enter[/], or [kbd]ctrl-j[/])\n" "- Use [kbd]ctrl-r[/] to search the history.\n\n"); auto history_path= get_history_path (); @@ -2207,8 +2060,7 @@ struct StartupCliOptions { }; static std::string -parse_mode_option (int argc, char** argv, - const std::string& default_mode= "default") { +parse_mode_option (int argc, char** argv, const std::string& default_mode= "default") { std::string mode= default_mode; for (int i= 1; i < argc; ++i) { string arg= argv[i]; @@ -2227,8 +2079,7 @@ parse_mode_option (int argc, char** argv, static bool is_legacy_cli_command (const string& arg) { - return arg == "--help" || arg == "-h" || arg == "--version" || arg == "-v" || - arg == "-e"; + return arg == "--help" || arg == "-h" || arg == "--version" || arg == "-v" || arg == "-e"; } static string @@ -2249,8 +2100,7 @@ static bool append_unique_string (vector& items, const string& raw_item) { string item= normalize_load_path_dir (raw_item); if (item.empty ()) return false; - if (std::find (items.begin (), items.end (), item) != items.end ()) - return false; + if (std::find (items.begin (), items.end (), item) != items.end ()) return false; items.push_back (item); return true; } @@ -2258,32 +2108,27 @@ append_unique_string (vector& items, const string& raw_item) { static bool is_plugin_name_part (const string& value) { if (value.empty ()) return false; - return std::all_of (value.begin (), value.end (), [] (unsigned char ch) { - return (ch >= 'a' && ch <= 'z') || (ch >= '0' && ch <= '9'); - }); + return std::all_of (value.begin (), value.end (), + [] (unsigned char ch) { return (ch >= 'a' && ch <= 'z') || (ch >= '0' && ch <= '9'); }); } static bool is_auto_goldfish_plugin_dir_name (const string& name) { size_t dash_pos= name.find ('-'); - if (dash_pos == string::npos || dash_pos == 0 || - dash_pos == name.length () - 1) { + if (dash_pos == string::npos || dash_pos == 0 || dash_pos == name.length () - 1) { return false; } if (name.find ('-', dash_pos + 1) != string::npos) { return false; } - return is_plugin_name_part (name.substr (0, dash_pos)) && - is_plugin_name_part (name.substr (dash_pos + 1)); + return is_plugin_name_part (name.substr (0, dash_pos)) && is_plugin_name_part (name.substr (dash_pos + 1)); } static bool directory_contains_scheme_sources (const fs::path& dir) { std::error_code ec; - for (fs::recursive_directory_iterator - it (dir, fs::directory_options::skip_permission_denied, ec), - end; - it != end; it.increment (ec)) { + for (fs::recursive_directory_iterator it (dir, fs::directory_options::skip_permission_denied, ec), end; it != end; + it.increment (ec)) { if (ec) { ec.clear (); continue; @@ -2310,10 +2155,8 @@ discover_auto_goldfish_library_dirs () { return dirs; } - for (fs::directory_iterator - it (root, fs::directory_options::skip_permission_denied, ec), - end; - it != end; it.increment (ec)) { + for (fs::directory_iterator it (root, fs::directory_options::skip_permission_denied, ec), end; it != end; + it.increment (ec)) { if (ec) { ec.clear (); continue; @@ -2344,8 +2187,7 @@ discover_auto_goldfish_library_dirs () { static vector current_load_path_entries (s7_scheme* sc) { vector entries; - for (s7_pointer rest= s7_load_path (sc); s7_is_pair (rest); - rest = s7_cdr (rest)) { + for (s7_pointer rest= s7_load_path (sc); s7_is_pair (rest); rest= s7_cdr (rest)) { s7_pointer entry= s7_car (rest); if (s7_is_string (entry)) { append_unique_string (entries, string (s7_string (entry))); @@ -2382,8 +2224,7 @@ append_load_path_entries (s7_scheme* sc, const vector& append_dirs) { for (const auto& raw_dir : append_dirs) { string dir= normalize_load_path_dir (raw_dir); if (dir.empty ()) continue; - if (std::find (entries.begin (), entries.end (), dir) != entries.end ()) - continue; + if (std::find (entries.begin (), entries.end (), dir) != entries.end ()) continue; entries.push_back (dir); changed= true; } @@ -2395,8 +2236,7 @@ append_load_path_entries (s7_scheme* sc, const vector& append_dirs) { static bool append_unique_exact_string (vector& items, const string& value) { if (value.empty ()) return false; - if (std::find (items.begin (), items.end (), value) != items.end ()) - return false; + if (std::find (items.begin (), items.end (), value) != items.end ()) return false; items.push_back (value); return true; } @@ -2411,8 +2251,7 @@ string_is_decimal_integer (const string& value) { } if (index >= value.size ()) return false; - return std::all_of (value.begin () + static_cast (index), - value.end (), + return std::all_of (value.begin () + static_cast (index), value.end (), [] (unsigned char ch) { return std::isdigit (ch) != 0; }); } @@ -2430,8 +2269,7 @@ make_library_name_part (s7_scheme* sc, const string& part) { static bool split_library_query (const string& query, string& group, string& library) { size_t slash_pos= query.find ('/'); - if (slash_pos == string::npos || slash_pos == 0 || - slash_pos == query.size () - 1) { + if (slash_pos == string::npos || slash_pos == 0 || slash_pos == query.size () - 1) { return false; } if (query.find ('/', slash_pos + 1) != string::npos) { @@ -2461,10 +2299,8 @@ library_name_part_to_string (s7_pointer value, string& out) { } static bool -extract_library_name_from_form (s7_scheme* sc, s7_pointer library_name_form, - string& group, string& library) { - if ((!s7_is_list (sc, library_name_form)) || - (s7_list_length (sc, library_name_form) != 2)) { +extract_library_name_from_form (s7_scheme* sc, s7_pointer library_name_form, string& group, string& library) { + if ((!s7_is_list (sc, library_name_form)) || (s7_list_length (sc, library_name_form) != 2)) { return false; } @@ -2473,8 +2309,7 @@ extract_library_name_from_form (s7_scheme* sc, s7_pointer library_name_form, } static bool -export_spec_name_matches (s7_scheme* sc, s7_pointer export_spec, - const string& function_name) { +export_spec_name_matches (s7_scheme* sc, s7_pointer export_spec, const string& function_name) { if (s7_is_symbol (export_spec)) { return function_name == s7_symbol_name (export_spec); } @@ -2491,31 +2326,27 @@ export_spec_name_matches (s7_scheme* sc, s7_pointer export_spec, } static bool -define_library_form_exports_function (s7_scheme* sc, s7_pointer form, - const string& function_name, - string& group, string& library) { - if ((!s7_is_list (sc, form)) || s7_is_null (sc, form) || - (!is_named_symbol (s7_car (form), "define-library"))) { +define_library_form_exports_function (s7_scheme* sc, s7_pointer form, const string& function_name, string& group, + string& library) { + if ((!s7_is_list (sc, form)) || s7_is_null (sc, form) || (!is_named_symbol (s7_car (form), "define-library"))) { return false; } string form_group; string form_library; - if (!extract_library_name_from_form (sc, s7_cadr (form), form_group, - form_library)) { + if (!extract_library_name_from_form (sc, s7_cadr (form), form_group, form_library)) { return false; } - for (s7_pointer declarations= s7_cddr (form); s7_is_pair (declarations); - declarations = s7_cdr (declarations)) { + for (s7_pointer declarations= s7_cddr (form); s7_is_pair (declarations); declarations= s7_cdr (declarations)) { s7_pointer declaration= s7_car (declarations); if ((!s7_is_list (sc, declaration)) || s7_is_null (sc, declaration) || (!is_named_symbol (s7_car (declaration), "export"))) { continue; } - for (s7_pointer export_specs = s7_cdr (declaration); - s7_is_pair (export_specs); export_specs= s7_cdr (export_specs)) { + for (s7_pointer export_specs= s7_cdr (declaration); s7_is_pair (export_specs); + export_specs = s7_cdr (export_specs)) { if (export_spec_name_matches (sc, s7_car (export_specs), function_name)) { group = form_group; library= form_library; @@ -2528,8 +2359,7 @@ define_library_form_exports_function (s7_scheme* sc, s7_pointer form, } static bool -source_file_exports_function (s7_scheme* sc, const fs::path& source_file, - const string& function_name, string& group, +source_file_exports_function (s7_scheme* sc, const fs::path& source_file, const string& function_name, string& group, string& library) { string source_text= read_text_file_exact (source_file); s7_pointer port = s7_open_input_string (sc, source_text.c_str ()); @@ -2538,8 +2368,7 @@ source_file_exports_function (s7_scheme* sc, const fs::path& source_file, while (true) { s7_pointer form= s7_read (sc, port); if (form == eof_object) break; - if (define_library_form_exports_function (sc, form, function_name, group, - library)) { + if (define_library_form_exports_function (sc, form, function_name, group, library)) { s7_close_input_port (sc, port); return true; } @@ -2550,10 +2379,8 @@ source_file_exports_function (s7_scheme* sc, const fs::path& source_file, } static s7_pointer -make_library_name_list (s7_scheme* sc, const string& group, - const string& library) { - return s7_list (sc, 2, make_library_name_part (sc, group), - make_library_name_part (sc, library)); +make_library_name_list (s7_scheme* sc, const string& group, const string& library) { + return s7_list (sc, 2, make_library_name_part (sc, group), make_library_name_part (sc, library)); } static vector @@ -2561,10 +2388,8 @@ sorted_child_directories (const fs::path& root) { vector directories; std::error_code ec; - for (fs::directory_iterator - it (root, fs::directory_options::skip_permission_denied, ec), - end; - it != end; it.increment (ec)) { + for (fs::directory_iterator it (root, fs::directory_options::skip_permission_denied, ec), end; it != end; + it.increment (ec)) { if (ec) { ec.clear (); continue; @@ -2576,9 +2401,7 @@ sorted_child_directories (const fs::path& root) { } std::sort (directories.begin (), directories.end (), - [] (const fs::path& lhs, const fs::path& rhs) { - return lhs.string () < rhs.string (); - }); + [] (const fs::path& lhs, const fs::path& rhs) { return lhs.string () < rhs.string (); }); return directories; } @@ -2587,10 +2410,8 @@ sorted_scheme_source_files (const fs::path& dir) { vector files; std::error_code ec; - for (fs::directory_iterator - it (dir, fs::directory_options::skip_permission_denied, ec), - end; - it != end; it.increment (ec)) { + for (fs::directory_iterator it (dir, fs::directory_options::skip_permission_denied, ec), end; it != end; + it.increment (ec)) { if (ec) { ec.clear (); continue; @@ -2602,15 +2423,12 @@ sorted_scheme_source_files (const fs::path& dir) { } std::sort (files.begin (), files.end (), - [] (const fs::path& lhs, const fs::path& rhs) { - return lhs.string () < rhs.string (); - }); + [] (const fs::path& lhs, const fs::path& rhs) { return lhs.string () < rhs.string (); }); return files; } static vector -find_function_libraries_in_load_path (s7_scheme* sc, - const string& function_name) { +find_function_libraries_in_load_path (s7_scheme* sc, const string& function_name) { vector library_queries; std::error_code ec; @@ -2626,8 +2444,7 @@ find_function_libraries_in_load_path (s7_scheme* sc, for (const auto& source_file : sorted_scheme_source_files (group_dir)) { string group; string library; - if (source_file_exports_function (sc, source_file, function_name, group, - library)) { + if (source_file_exports_function (sc, source_file, function_name, group, library)) { append_unique_exact_string (library_queries, group + "/" + library); } } @@ -2639,11 +2456,9 @@ find_function_libraries_in_load_path (s7_scheme* sc, } static s7_pointer -make_library_name_list_list (s7_scheme* sc, - const vector& library_queries) { +make_library_name_list_list (s7_scheme* sc, const vector& library_queries) { s7_pointer result= s7_nil (sc); - for (auto it= library_queries.rbegin (); it != library_queries.rend (); - ++it) { + for (auto it= library_queries.rbegin (); it != library_queries.rend (); ++it) { string group; string library; if (!split_library_query (*it, group, library)) continue; @@ -2658,29 +2473,20 @@ f_function_libraries (s7_scheme* sc, s7_pointer args) { if (!s7_is_string (function_name_arg)) { return s7_error ( sc, s7_make_symbol (sc, "type-error"), - s7_list (sc, 2, - s7_make_string ( - sc, "g_function-libraries: function-name must be string?"), - function_name_arg)); + s7_list (sc, 2, s7_make_string (sc, "g_function-libraries: function-name must be string?"), function_name_arg)); } string function_name= s7_string (function_name_arg); vector visible_library_queries; try { - visible_library_queries= - find_function_libraries_in_load_path (sc, function_name); + visible_library_queries= find_function_libraries_in_load_path (sc, function_name); } catch (const std::exception& ex) { return s7_error ( sc, s7_make_symbol (sc, "read-error"), s7_list ( sc, 2, - s7_make_string ( - sc, - (string ( - "g_function-libraries: failed to inspect libraries: ") + - ex.what ()) - .c_str ()), + s7_make_string (sc, (string ("g_function-libraries: failed to inspect libraries: ") + ex.what ()).c_str ()), function_name_arg)); } @@ -2779,29 +2585,24 @@ repl_for_community_edition (s7_scheme* sc, int argc, char** argv) { } if (command == "-e") { command= "eval"; - if (command_index >= 0 && - command_index < static_cast (command_args.size ())) { + if (command_index >= 0 && command_index < static_cast (command_args.size ())) { command_args[command_index]= "eval"; } } // 自动路由：如果参数是目录且第一级文件夹是 tests，自动视为 test 命令 - if (!command.empty () && command != "help" && command != "version" && - command != "eval" && command != "load" && command != "repl" && - command != "run" && command != "test" && command != "-e") { + if (!command.empty () && command != "help" && command != "version" && command != "eval" && command != "load" && + command != "repl" && command != "run" && command != "test" && command != "-e") { std::error_code ec; if (fs::is_directory (command, ec)) { fs::path p (command); auto it= p.begin (); if (it != p.end () && *it == "tests") { - if (command_index >= 0 && - command_index <= static_cast (command_args.size ())) { + if (command_index >= 0 && command_index <= static_cast (command_args.size ())) { command_args.insert (command_args.begin () + command_index, "test"); } command= "test"; - std::cerr << "[gf] Auto-routing: detected tests directory, routing to " - "test command" - << "\n"; + std::cerr << "[gf] Auto-routing: detected tests directory, routing to test command" << "\n"; std::cerr << "[gf] Executing: "; for (size_t i= 0; i < command_args.size (); ++i) { if (i > 0) std::cerr << " "; @@ -2835,24 +2636,20 @@ repl_for_community_edition (s7_scheme* sc, int argc, char** argv) { customize_goldfish_by_mode (sc, mode, gf_boot); // start capture error output - const char* errmsg= NULL; - s7_pointer old_port= - s7_set_current_error_port (sc, s7_open_output_string (sc)); - int gc_loc= -1; + const char* errmsg = NULL; + s7_pointer old_port= s7_set_current_error_port (sc, s7_open_output_string (sc)); + int gc_loc = -1; if (old_port != s7_nil (sc)) gc_loc= s7_gc_protect (sc, old_port); // 处理动态注册的工具（从 gfproject.json 加载） json gfproject_config= load_gfproject_config (gf_lib); - if (gfproject_config.contains ("tools") && - gfproject_config["tools"].contains (command)) { - int tool_ret= - goldfish_run_tool (sc, gf_lib, command, errmsg, old_port, gc_loc); + if (gfproject_config.contains ("tools") && gfproject_config["tools"].contains (command)) { + int tool_ret= goldfish_run_tool (sc, gf_lib, command, errmsg, old_port, gc_loc); if (tool_ret != -1) { // Tool was found and executed (or failed with an error) return tool_ret; } - // If tool_ret == -1, tool config exists but execution failed, fall through - // to check other commands + // If tool_ret == -1, tool config exists but execution failed, fall through to check other commands } if (command == "help") { @@ -2969,8 +2766,7 @@ repl_for_community_edition (s7_scheme* sc, int argc, char** argv) { s7_close_output_port (sc, s7_current_error_port (sc)); s7_set_current_error_port (sc, old_port); if (gc_loc != -1) s7_gc_unprotect_at (sc, gc_loc); - std::cerr << "Interactive REPL is not available in this build.\n" - << std::endl; + std::cerr << "Interactive REPL is not available in this build.\n" << std::endl; exit (-1); #endif } @@ -2994,8 +2790,7 @@ repl_for_community_edition (s7_scheme* sc, int argc, char** argv) { s7_close_output_port (sc, s7_current_error_port (sc)); s7_set_current_error_port (sc, old_port); if (gc_loc != -1) s7_gc_unprotect_at (sc, gc_loc); - std::cerr << "Interactive REPL is not available in this build.\n" - << std::endl; + std::cerr << "Interactive REPL is not available in this build.\n" << std::endl; exit (-1); #endif } @@ -3025,8 +2820,7 @@ repl_for_community_edition (s7_scheme* sc, int argc, char** argv) { } // 判断类型并处理 - if (target.find ('/') != string::npos || - target.rfind (".scm") == target.length () - 4) { + if (target.find ('/') != string::npos || target.rfind (".scm") == target.length () - 4) { // 包含 / 或以 .scm 结尾，按文件路径处理 // 检查文件是否存在 std::error_code ec; @@ -3064,8 +2858,7 @@ repl_for_community_edition (s7_scheme* sc, int argc, char** argv) { s7_close_output_port (sc, s7_current_error_port (sc)); s7_set_current_error_port (sc, old_port); if (gc_loc != -1) s7_gc_unprotect_at (sc, gc_loc); - std::cerr << "Error: No main function found in target: " << target - << std::endl; + std::cerr << "Error: No main function found in target: " << target << std::endl; return 1; } diff --git a/TeXmacs/plugins/goldfish/src/liii_json.cpp b/TeXmacs/plugins/goldfish/src/liii_json.cpp new file mode 100644 index 0000000000..c8f88e938e --- /dev/null +++ b/TeXmacs/plugins/goldfish/src/liii_json.cpp @@ -0,0 +1,1354 @@ +// +// Copyright (C) 2026 The Goldfish Scheme Authors +// +// Licensed under the Apache License, Version 2.0 (the "License"); +// you may not use this file except in compliance with the License. +// You may obtain a copy of the License at +// +// http://www.apache.org/licenses/LICENSE-2.0 +// +// Unless required by applicable law or agreed to in writing, software +// distributed under the License is distributed on an "AS IS" BASIS, WITHOUT +// WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the +// License for the specific language governing permissions and limitations +// under the License. +// + +#include "s7.h" +#include +#include +#include +#include +#include + +namespace goldfish { + +// json->string 的 C++ 实现，语义与历史上 (guenchi json) 中的 Scheme 实现完全一致： +// - vector => JSON 数组 +// - 序对列表 => JSON 对象（键为符号时输出宽松格式，即不带引号） +// - '() => {} +// - 字符串 => 转义后带引号输出（\" \\ \/ \b \f \n \r \t，多字节 UTF-8 原样输出） +// - symbol => 原样输出（如 true false null） +// - number => number->string +// - boolean => true / false + +static s7_pointer +json_type_error (s7_scheme* sc, const char* msg, s7_pointer arg) { + return s7_error (sc, s7_make_symbol (sc, "type-error"), s7_list (sc, 2, s7_make_string (sc, msg), arg)); +} + +static void +json_write_escaped_string (std::string& out, const char* s, s7_int len) { + // [0125] 快路径：成段追加无特殊字符的区间，遇 '"' '\\' '/' 或控制字符才特殊处理 + out.push_back ('"'); + s7_int bgn= 0; + for (s7_int i= 0; i < len; i++) { + unsigned char c= (unsigned char) s[i]; + if (c >= 0x20 && c != '"' && c != '\\' && c != '/') continue; + out.append (s + bgn, (size_t) (i - bgn)); + switch (c) { + case '"': + out+= "\\\""; + break; + case '\\': + out+= "\\\\"; + break; + case '/': + out+= "\\/"; + break; + case '\b': + out+= "\\b"; + break; + case '\f': + out+= "\\f"; + break; + case '\n': + out+= "\\n"; + break; + case '\r': + out+= "\\r"; + break; + case '\t': + out+= "\\t"; + break; + default: + if (c < 0x20) { + // [0125] 控制字符（含 NUL）转义为 \uXXXX，保证输出可再解析 + char buf[8]; + snprintf (buf, sizeof (buf), "\\u%04x", (unsigned) c); + out+= buf; + } + else { + // 多字节 UTF-8 字符，直接输出原始字节 + out.push_back ((char) c); + } + break; + } + bgn= i + 1; + } + out.append (s + bgn, (size_t) (len - bgn)); + out.push_back ('"'); +} + +static void json_write_value (s7_scheme* sc, s7_pointer x, std::string& out); + +// [0125] 空对象 '(()) 在顶层与嵌套位置都应输出 {}（此前顶层输出 {{}}） +static bool json_is_null_object (s7_scheme* sc, s7_pointer x); + +static void +json_write_scalar (s7_scheme* sc, s7_pointer x, std::string& out) { + if (s7_is_string (x)) { + json_write_escaped_string (out, s7_string (x), s7_string_length (x)); + } + else if (s7_is_number (x)) { + char* s= s7_number_to_string (sc, x, 10); + out+= s; + free (s); + } + else if (s7_is_boolean (x)) { + out+= (s7_boolean (sc, x) ? "true" : "false"); + } + else if (s7_is_symbol (x)) { + out+= s7_symbol_name (x); + } + else if (s7_is_null (sc, x)) { + out+= "{}"; + } + else { + json_type_error (sc, "Unexpected x: ", x); + } +} + +// 统计序对链的长度；链以非空原子结尾（非真列表）时返回 -1 +static s7_int +json_pair_chain_length (s7_scheme* sc, s7_pointer x) { + s7_int len= 0; + s7_pointer p = x; + while (s7_is_pair (p)) { + len++; + p= s7_cdr (p); + } + if (!s7_is_null (sc, p)) return -1; + return len; +} + +static void +json_write_object_entry (s7_scheme* sc, s7_pointer d, std::string& out) { + if (s7_is_null (sc, d)) { + out+= "{}"; + return; + } + if (!s7_is_pair (d)) { + s7_error (sc, s7_make_symbol (sc, "value-error"), + s7_list (sc, 2, d, s7_make_string (sc, " must be null, pair, or list with at least 2 elements"))); + return; + } + s7_int len= json_pair_chain_length (sc, d); + if (!(len == -1 || len >= 2)) { + s7_error (sc, s7_make_symbol (sc, "value-error"), + s7_list (sc, 2, d, s7_make_string (sc, " must be null, pair, or list with at least 2 elements"))); + return; + } + s7_pointer k= s7_car (d); + s7_pointer v= s7_cdr (d); + json_write_scalar (sc, k, out); + out.push_back (':'); + if (s7_is_null (sc, v)) { + out+= "{}"; + } + else if ((s7_is_pair (v) && json_pair_chain_length (sc, v) != -1) || s7_is_vector (v)) { + json_write_value (sc, v, out); + } + else { + json_write_scalar (sc, v, out); + } +} + +static void +json_write_value (s7_scheme* sc, s7_pointer x, std::string& out) { + if (json_is_null_object (sc, x)) { + out+= "{}"; + return; + } + if (s7_is_vector (x)) { + out.push_back ('['); + s7_int len = s7_vector_length (x); + s7_pointer* elems= s7_vector_elements (x); + for (s7_int i= 0; i < len; i++) { + if (i > 0) out.push_back (','); + s7_pointer k= elems[i]; + if (s7_is_vector (k) || s7_is_pair (k)) { + json_write_value (sc, k, out); + } + else { + json_write_scalar (sc, k, out); + } + } + out.push_back (']'); + } + else if (s7_is_pair (x)) { + out.push_back ('{'); + s7_pointer lst= x; + s7_int i = 0; + while (s7_is_pair (lst)) { + if (i > 0) out.push_back (','); + json_write_object_entry (sc, s7_car (lst), out); + lst= s7_cdr (lst); + i++; + } + if (!s7_is_null (sc, lst)) { + s7_error (sc, s7_make_symbol (sc, "value-error"), + s7_list (sc, 2, lst, s7_make_string (sc, " must be null, pair, or list with at least 2 elements"))); + return; + } + out.push_back ('}'); + } + else { + json_write_scalar (sc, x, out); + } +} + +static s7_pointer +f_json_to_string (s7_scheme* sc, s7_pointer args) { + s7_pointer x= s7_car (args); + if (s7_is_procedure (x)) { + return s7_error (sc, s7_make_symbol (sc, "type-error"), + s7_list (sc, 1, s7_make_string (sc, "json->string: input must not be a procedure"))); + } + std::string out; + out.reserve (256); + json_write_value (sc, x, out); + return s7_make_string_with_length (sc, out.data (), (s7_int) out.size ()); +} + +static void +glue_json_to_string (s7_scheme* sc) { + const char* name= "g_json->string"; + const char* desc= "(g_json->string data) => string, encode Scheme-form JSON data to a JSON string"; + s7_define_function (sc, name, f_json_to_string, 1, 0, false, desc); +} + +// json-string-escape 的 C++ 实现，复用 json_write_escaped_string（与 json->string 的 +// 字符串转义完全一致）：\" \\ \/ \b \f \n \r \t，其余控制字符（< 0x20）转义为 \uXXXX， +// 多字节 UTF-8 原样输出。历史上 (guenchi json) 的 Scheme 实现对其他控制字符原样输出， +// 迁移后改为 \uXXXX 转义，保证输出是可再解析的合法 JSON +static s7_pointer +f_json_string_escape (s7_scheme* sc, s7_pointer args) { + s7_pointer arg= s7_car (args); + if (!s7_is_string (arg)) { + return s7_wrong_type_arg_error (sc, "json-string-escape", 1, arg, "a string"); + } + std::string out; + out.reserve ((size_t) s7_string_length (arg) + 2); + json_write_escaped_string (out, s7_string (arg), s7_string_length (arg)); + return s7_make_string_with_length (sc, out.data (), (s7_int) out.size ()); +} + +static void +glue_json_string_escape (s7_scheme* sc) { + const char* name= "g_json_string_escape"; + const char* desc= "(g_json_string_escape str) => string, escape a string as a JSON string literal"; + s7_define_function (sc, name, f_json_string_escape, 1, 0, false, desc); +} + +// string->json 的 C++ 实现，语义与历史上 (guenchi json) 中的 Scheme 实现完全一致。 +// Scheme 实现的做法是：逐字符扫描 JSON 文本，把 { } [ ] : , 改写为 Scheme 可读形式 +// （{ -> "((", } -> "))", [ -> "#(", ] -> ")", : -> " . ", 对象内 , -> ")(", 数组内 , -> " "）， +// 字符串内的转义做部分处理（\/ 变为 /，\uXXXX 直接展开为 UTF-8 字节，其余转义原样保留 +// 交由 reader 处理），然后对改写后的字符串调用 read。 +// 关键行为（必须与 Scheme 版逐字节一致）： +// - 只在分隔符处落盘：最后一个分隔符之后的内容被丢弃（故顶层标量解析为 eof-object） +// - 上下文栈初始为 (#t)，loose-cdr 到空后保持为空，空栈顶按真值处理（即对象上下文） +// - \uXXXX 需要满足 end+6 < len，否则 parse-error "HEX sequence too short ..." +// - 代理对合并要求 end+12 < len；非法 hex 抛 parse-error "Invalid HEX sequence ..." +// - 非法转义字符抛 parse-error "Invalid escape char: X" +// - 码点超出 [0, 1114111] 抛 value-error（与 (liii unicode) codepoint->utf8 一致） + +static s7_pointer +json_parse_error (s7_scheme* sc, const std::string& msg) { + return s7_error (sc, s7_make_symbol (sc, "parse-error"), + s7_list (sc, 1, s7_make_string_with_length (sc, msg.data (), (s7_int) msg.size ()))); +} + +// glue 时缓存 string->number 并永久 GC 保护：仅用于超出 int64 范围的大整数回退 +static s7_pointer cached_string_to_number= NULL; + +// glue 时缓存 true/false/null 符号并永久 GC 保护： +// parser 高频构造这三个符号，缓存避免每次符号 intern 查找（json-ref 转换亦复用） +static s7_pointer symbol_true = NULL; +static s7_pointer symbol_false= NULL; +static s7_pointer symbol_null = NULL; + +// 与 (liii unicode) 的 codepoint->utf8 一致：不排斥代理区码点，逐字节编码 +static bool +json_append_utf8 (std::string& out, s7_int cp) { + if (cp < 0 || cp > 1114111) return false; + if (cp <= 127) { + out.push_back ((char) cp); + } + else if (cp <= 2047) { + out.push_back ((char) (192 | ((cp >> 6) & 31))); + out.push_back ((char) (128 | (cp & 63))); + } + else if (cp <= 65535) { + out.push_back ((char) (224 | ((cp >> 12) & 15))); + out.push_back ((char) (128 | ((cp >> 6) & 63))); + out.push_back ((char) (128 | (cp & 63))); + } + else { + out.push_back ((char) (240 | ((cp >> 18) & 7))); + out.push_back ((char) (128 | ((cp >> 12) & 63))); + out.push_back ((char) (128 | ((cp >> 6) & 63))); + out.push_back ((char) (128 | (cp & 63))); + } + return true; +} + +// 与 (string->number hex-str 16) 一致地解析 4 字符 hex（允许前导 +/-） +static bool +json_parse_hex4 (const char* s, s7_int n, s7_int& result) { + s7_int i = 0; + bool neg= false; + if (i < n && (s[i] == '+' || s[i] == '-')) { + neg= (s[i] == '-'); + i++; + } + if (i >= n) return false; + s7_int v= 0; + for (; i < n; i++) { + char c= s[i]; + int d; + if (c >= '0' && c <= '9') d= c - '0'; + else if (c >= 'a' && c <= 'f') d= c - 'a' + 10; + else if (c >= 'A' && c <= 'F') d= c - 'A' + 10; + else return false; + v= v * 16 + d; + } + result= neg ? -v : v; + return true; +} + +// [0125] 按 RFC 8259 重写的严格递归下降 parser，目标是 JSONTestSuite 的 y_/n_ 用例： +// - 严格数字文法：-?(0|[1-9][0-9]*)(\.[0-9]+)?([eE][+-]?[0-9]+)? +// - 严格结构文法：逗号/冒号缺失、尾逗号、尾部垃圾均报 parse-error +// - 字符串内裸控制字符（< 0x20）报 parse-error +// - 剥离 UTF-8 BOM；空白仅认 space/\t/\n/\r +// - 顶层标量直接返回值；空/纯空白输入仍返回 eof-object（历史行为） +// 保留的 goldfish 扩展（与 RFC 的已知偏差）： +// - 不带引号的对象键（{a:1}，键解析为符号） +// 单引号字符串不是合法 JSON，报 parse-error（与 0124 行为一致） +// +// 实现分两步：先解析为 C++ 侧的 jnode 树，再一次性转换为 s7 对象； +// 转换期间对每个已完成的子树用 s7_gc_protect_via_stack 保护，避免分配触发 +// GC 回收未挂接的子树。 + +struct json_parser { + s7_scheme* sc; + const char* s; + s7_int len; + s7_int pos; + s7_int depth; // 当前容器嵌套深度 +}; + +// 嵌套深度上限：防止恶意/损坏输入导致 C++ 递归爆栈（JSONTestSuite 最深合法用例为 500 层） +#define JSON_MAX_DEPTH 10000 + +static void +json_skip_ws (json_parser* p) { + while (p->pos < p->len) { + char c= p->s[p->pos]; + if (c == ' ' || c == '\t' || c == '\n' || c == '\r') p->pos++; + else break; + } +} + +static s7_int +json_peek (json_parser* p) { + return (p->pos < p->len) ? (unsigned char) p->s[p->pos] : -1; +} + +// 解析失败统一返回 NULL（调用方负责报 parse-error） +static s7_pointer json_parse_value (json_parser* p); + +static bool +json_parse_hex4_at (json_parser* p, s7_int at, s7_int& cp) { + if (at + 4 > p->len) return false; + return json_parse_hex4 (p->s + at, 4, cp); +} + +// 解析字符串体（进入时 pos 指向开引号之后），返回 s7 字符串； +// 快路径：成段拷贝无特殊字符的区间，遇 '"' '\\' 或控制字符才逐字符处理 +static s7_pointer +json_parse_string_body (json_parser* p) { + s7_scheme* sc = p->sc; + const char* s = p->s; + s7_int len= p->len; + std::string out; + s7_int bgn= p->pos; + while (p->pos < len) { + unsigned char c= (unsigned char) s[p->pos]; + if (c == '"') { + out.append (s + bgn, (size_t) (p->pos - bgn)); + p->pos++; + return s7_make_string_with_length (sc, out.data (), (s7_int) out.size ()); + } + if (c < 0x20) { + return NULL; // 裸控制字符 + } + if (c != '\\') { + p->pos++; + continue; + } + // 遇转义：先把前面的原文落盘 + out.append (s + bgn, (size_t) (p->pos - bgn)); + if (p->pos + 1 >= len) return NULL; + char next= s[p->pos + 1]; + switch (next) { + case '"': + out+= '"'; + p->pos+= 2; + break; + case '\\': + out+= '\\'; + p->pos+= 2; + break; + case '/': + out+= '/'; + p->pos+= 2; + break; + case 'b': + out+= '\b'; + p->pos+= 2; + break; + case 'f': + out+= '\f'; + p->pos+= 2; + break; + case 'n': + out+= '\n'; + p->pos+= 2; + break; + case 'r': + out+= '\r'; + p->pos+= 2; + break; + case 't': + out+= '\t'; + p->pos+= 2; + break; + case 'u': { + s7_int cp; + if (!json_parse_hex4_at (p, p->pos + 2, cp)) return NULL; + s7_int next_cp; + if (cp >= 55296 && cp <= 56319 && p->pos + 6 + 6 < len && s[p->pos + 6] == '\\' && s[p->pos + 7] == 'u' && + json_parse_hex4_at (p, p->pos + 8, next_cp) && next_cp >= 56320 && next_cp <= 57343) { + cp= (cp - 55296) * 1024 + (next_cp - 56320) + 65536; + p->pos+= 12; + } + else { + p->pos+= 6; + } + if (!json_append_utf8 (out, cp)) return NULL; + break; + } + default: + return NULL; + } + bgn= p->pos; + } + return NULL; // 未闭合 +} + +// 严格数字文法：-?(0|[1-9][0-9]*)(\.[0-9]+)?([eE][+-]?[0-9]+)? +// 整数走 strtoll + s7_make_integer（int64 溢出回退 string->number 保持 bignum）， +// 实数走 strtod + s7_make_real（与 reader 双精度语义一致，1e2 => 100.0） +static s7_pointer +json_parse_number (json_parser* p) { + s7_scheme* sc = p->sc; + s7_int bgn = p->pos; + bool is_real= false; + if (json_peek (p) == '-') p->pos++; + s7_int c= json_peek (p); + if (c == '0') { + p->pos++; + } + else if (c >= '1' && c <= '9') { + while (json_peek (p) >= '0' && json_peek (p) <= '9') + p->pos++; + } + else return NULL; + if (json_peek (p) == '.') { + is_real= true; + p->pos++; + if (!(json_peek (p) >= '0' && json_peek (p) <= '9')) return NULL; + while (json_peek (p) >= '0' && json_peek (p) <= '9') + p->pos++; + } + c= json_peek (p); + if (c == 'e' || c == 'E') { + is_real= true; + p->pos++; + c= json_peek (p); + if (c == '+' || c == '-') p->pos++; + if (!(json_peek (p) >= '0' && json_peek (p) <= '9')) return NULL; + while (json_peek (p) >= '0' && json_peek (p) <= '9') + p->pos++; + } + // 文本已在原文缓冲区内且后续必为分隔符，可安全临时 NUL 终止 + const char* text= p->s + bgn; + size_t tlen= (size_t) (p->pos - bgn); + if (!is_real) { + errno = 0; + char* endp = NULL; + char saved = p->s[p->pos]; + ((char*) p->s)[p->pos]= '\0'; + long long v = strtoll (text, &endp, 10); + ((char*) p->s)[p->pos]= saved; + if (errno != ERANGE && endp == text + tlen) { + return s7_make_integer (sc, (s7_int) v); + } + } + else { + char* endp = NULL; + char saved = p->s[p->pos]; + ((char*) p->s)[p->pos]= '\0'; + double d = strtod (text, &endp); + ((char*) p->s)[p->pos]= saved; + if (endp == text + tlen) { + return s7_make_real (sc, d); + } + } + // 回退：超大整数等罕见情形（需要构造临时 std::string） + s7_pointer txt= s7_make_string_with_length (sc, text, (s7_int) tlen); + s7_gc_protect_via_stack (sc, txt); + s7_pointer num= s7_call (sc, cached_string_to_number, s7_list (sc, 1, txt)); + s7_gc_unprotect_via_stack (sc, txt); + return num; +} + +// 不带引号的符号键：读到 ':'、空白或结构分隔符为止；至少一个字符。 +// 数字开头（含负号）的键是 JSON 数字而非符号；null/true/false 是保留字不能作键 +static s7_pointer +json_parse_symbol_key (json_parser* p) { + s7_int bgn= p->pos; + while (p->pos < p->len) { + char c= p->s[p->pos]; + if (c == ':' || c == ',' || c == '}' || c == ']' || c == '[' || c == ' ' || c == '\t' || c == '\n' || c == '\r' || + c == '\'' || c == '"') + break; + p->pos++; + } + if (p->pos == bgn) return NULL; + char c0= p->s[bgn]; + if ((c0 >= '0' && c0 <= '9') || c0 == '-') return NULL; + size_t n= (size_t) (p->pos - bgn); + if ((n == 4 && strncmp (p->s + bgn, "null", 4) == 0) || (n == 4 && strncmp (p->s + bgn, "true", 4) == 0) || + (n == 5 && strncmp (p->s + bgn, "false", 5) == 0)) { + return NULL; + } + // s7 无 make_symbol_with_length：pos < len 时临时 NUL 终止构造（随即恢复）， + // 否则（键后直接 EOF）走 std::string + if (p->pos < p->len) { + char saved = p->s[p->pos]; + ((char*) p->s)[p->pos]= '\0'; + s7_pointer sym = s7_make_symbol (p->sc, p->s + bgn); + ((char*) p->s)[p->pos]= saved; + return sym; + } + std::string name (p->s + bgn, n); + return s7_make_symbol (p->sc, name.c_str ()); +} + +static s7_pointer +json_parse_object (json_parser* p) { + s7_scheme* sc= p->sc; + if (++p->depth > JSON_MAX_DEPTH) return NULL; + p->pos++; // 跳过 '{' + json_skip_ws (p); + if (json_peek (p) == '}') { + p->pos++; + p->depth--; + // 空对象 '() + return s7_cons (sc, s7_nil (sc), s7_nil (sc)); + } + // GC 已被调用方关闭，裸指针收集键值安全；单数组交错存放 k0 v0 k1 v1 ... + std::vector kv; + kv.reserve (32); + while (true) { + json_skip_ws (p); + s7_pointer key; + if (json_peek (p) == '"') { + p->pos++; + key= json_parse_string_body (p); + } + else { + key= json_parse_symbol_key (p); + } + if (key == NULL) { + p->depth--; + return NULL; + } + json_skip_ws (p); + if (json_peek (p) != ':') { + p->depth--; + return NULL; + } + p->pos++; + json_skip_ws (p); + s7_pointer val= json_parse_value (p); + if (val == NULL) { + p->depth--; + return NULL; + } + kv.push_back (key); + kv.push_back (val); + json_skip_ws (p); + s7_int c= json_peek (p); + if (c == ',') { + p->pos++; + continue; // 尾逗号会在下一轮的 key 解析处报错 + } + p->depth--; + if (c == '}') { + p->pos++; + // 从尾向头 cons，直接得到正序 alist（无需 s7_reverse 二次遍历） + s7_pointer lst= s7_nil (sc); + for (size_t i= kv.size (); i > 0; i-= 2) { + lst= s7_cons (sc, s7_cons (sc, kv[i - 2], kv[i - 1]), lst); + } + return lst; + } + return NULL; + } +} + +static s7_pointer +json_parse_array (json_parser* p) { + s7_scheme* sc= p->sc; + if (++p->depth > JSON_MAX_DEPTH) return NULL; + p->pos++; // 跳过 '[' + json_skip_ws (p); + if (json_peek (p) == ']') { + p->pos++; + p->depth--; + return s7_make_vector (sc, 0); + } + // GC 已被调用方关闭，裸指针收集元素安全 + std::vector elems; + elems.reserve (32); + while (true) { + json_skip_ws (p); + s7_pointer val= json_parse_value (p); + if (val == NULL) { + p->depth--; + return NULL; + } + elems.push_back (val); + json_skip_ws (p); + s7_int c= json_peek (p); + if (c == ',') { + p->pos++; + continue; // 尾逗号会在下一轮的 value 解析处报错 + } + p->depth--; + if (c == ']') { + p->pos++; + s7_pointer vec= s7_make_vector (sc, (s7_int) elems.size ()); + s7_pointer* dst= s7_vector_elements (vec); + for (size_t i= 0; i < elems.size (); i++) + dst[i]= elems[i]; + return vec; + } + return NULL; + } +} + +static bool +json_parse_literal (json_parser* p, const char* lit) { + size_t n= strlen (lit); + if ((s7_int) (p->pos + n) > p->len) return false; + if (strncmp (p->s + p->pos, lit, n) != 0) return false; + p->pos+= (s7_int) n; + return true; +} + +static s7_pointer +json_parse_value (json_parser* p) { + s7_int c= json_peek (p); + switch (c) { + case '{': + return json_parse_object (p); + case '[': + return json_parse_array (p); + case '"': + p->pos++; + return json_parse_string_body (p); + case 't': + if (!json_parse_literal (p, "true")) return NULL; + return symbol_true; + case 'f': + if (!json_parse_literal (p, "false")) return NULL; + return symbol_false; + case 'n': + if (!json_parse_literal (p, "null")) return NULL; + return symbol_null; + case '\'': + // 单引号字符串不是合法 JSON（RFC 8259） + return NULL; + default: + return json_parse_number (p); + } +} + +static bool +json_is_value_end (s7_int c) { + return c == -1 || c == ',' || c == ']' || c == '}' || c == ' ' || c == '\t' || c == '\n' || c == '\r'; +} + +static s7_pointer +f_string_to_json (s7_scheme* sc, s7_pointer args) { + s7_pointer arg= s7_car (args); + if (!s7_is_string (arg)) { + return s7_wrong_type_arg_error (sc, "string->json", 1, arg, "a string"); + } + const char* s = s7_string (arg); + s7_int len= s7_string_length (arg); + + json_parser p= {sc, s, len, 0, 0}; + // 剥离 UTF-8 BOM + if (len >= 3 && (unsigned char) s[0] == 0xEF && (unsigned char) s[1] == 0xBB && (unsigned char) s[2] == 0xBF) + p.pos= 3; + json_skip_ws (&p); + if (json_peek (&p) == -1) { + // 空输入/纯空白输入：保持历史行为返回 eof-object + return s7_eof_object (sc); + } + // 解析+构造期间关闭 GC（参考 njson 的做法）：解析过程不中断、不回调 Scheme， + // 中间对象以裸指针暂存于 C++ 容器中安全；结束后恢复 + s7_gc_on (sc, false); + s7_pointer result= json_parse_value (&p); + bool ok = (result != NULL) && json_is_value_end (json_peek (&p)); + if (ok) { + json_skip_ws (&p); + ok= (json_peek (&p) == -1); + } + s7_gc_on (sc, true); + if (!ok) { + return json_parse_error (sc, result == NULL ? "string->json: invalid JSON" + : "string->json: trailing garbage after JSON value"); + } + return result; +} + +static void +glue_string_to_json (s7_scheme* sc) { + const char* name= "g_string->json"; + const char* desc= "(g_string->json str) => data, parse a JSON string to Scheme-form JSON data"; + s7_define_function (sc, name, f_string_to_json, 1, 0, false, desc); + cached_string_to_number= s7_name_to_value (sc, "string->number"); + s7_gc_protect (sc, cached_string_to_number); +} + +// json-ref / json-set 的 C++ 实现，语义与历史上 (liii json) 包装 (guenchi json) +// 的 Scheme 实现完全一致： +// - json-ref：多键路径逐层下钻；'() 透传（安全导航）；空对象 '(()) 读出为 '()； +// 每层先做结构校验（非对象/数组抛 type-error）；读到的符号 'true/'false 转为 #t/#f； +// 数组用 vector-ref 语义（非整数索引抛 wrong-type-arg、越界抛 out-of-range） +// - json-set：多键路径逐层函数式更新；空对象 '(()) 原样返回； +// 键 #t 表示映射所有值；键为过程表示按键谓词筛选；普通键按 equal? 匹配； +// 匹配成功后新序对的键：普通键分支用传入的键，#t/过程键分支保留原键； +// 叶层值可以是过程（接收旧值返回新值）； +// 键 #f 落入 guenchi (if v ...) 无 else 分支的历史怪癖原样保留 +// （对象返回 #，数组走 (list->vector #) 抛 wrong-type-arg） + +// 真列表长度；非真列表（含循环列表）返回 -1 +static s7_int +json_proper_list_length (s7_scheme* sc, s7_pointer x) { + s7_pointer slow= x, fast= x; + s7_int len= 0; + while (s7_is_pair (fast)) { + fast= s7_cdr (fast); + len++; + if (s7_is_pair (fast)) { + fast= s7_cdr (fast); + len++; + slow= s7_cdr (slow); + if (fast == slow) return -1; // 循环列表 + } + } + if (!s7_is_null (sc, fast)) return -1; + return len; +} + +// 空对象 '(()) +static bool +json_is_null_object (s7_scheme* sc, s7_pointer x) { + return s7_is_pair (x) && s7_is_null (sc, s7_car (x)) && s7_is_null (sc, s7_cdr (x)); +} + +// 与 (liii json) 的 json-object? 一致（x 已知非 '()）： +// (and (list? x) (not (null? x)) (or (equal? x '(())) (every pair? x))) +static bool +json_is_object (s7_scheme* sc, s7_pointer x, s7_int& len) { + if (!s7_is_pair (x)) return false; + if (json_is_null_object (sc, x)) { + len= 1; + return true; + } + len= json_proper_list_length (sc, x); + if (len < 0) return false; + s7_pointer p= x; + while (s7_is_pair (p)) { + if (!s7_is_pair (s7_car (p))) return false; + p= s7_cdr (p); + } + return true; +} + +// glue 时缓存 vector-ref / list->vector 并永久 GC 保护： +// 仅在报错路径上调用，保证错误类型和消息与 Scheme 实现逐字节一致 +static s7_pointer cached_vector_ref = NULL; +static s7_pointer cached_list_to_vector= NULL; + +// guenchi json-ref 的 return 包装：'true -> #t，'false -> #f + +static s7_pointer +json_ref_convert (s7_scheme* sc, s7_pointer x) { + if (s7_is_symbol (x)) { + if (x == symbol_true) return s7_t (sc); + if (x == symbol_false) return s7_f (sc); + } + return x; +} + +static s7_pointer +f_json_ref (s7_scheme* sc, s7_pointer args) { + s7_pointer cur = s7_car (args); + s7_pointer keys= s7_cdr (args); + while (s7_is_pair (keys)) { + s7_pointer key= s7_car (keys); + keys = s7_cdr (keys); + // '() 透传：安全导航，直接返回 '() + if (s7_is_null (sc, cur)) return s7_nil (sc); + s7_pointer val; + if (s7_is_vector (cur)) { + if (s7_is_integer (key)) { + s7_int i= s7_integer (key); + if (i >= 0 && i < s7_vector_length (cur)) { + val= s7_vector_elements (cur)[i]; + } + else { + // 抛出与 vector-ref 一致的 out-of-range 错误 + return s7_call (sc, cached_vector_ref, s7_list (sc, 2, cur, key)); + } + } + else { + // 抛出与 vector-ref 一致的 wrong-type-arg 错误 + return s7_call (sc, cached_vector_ref, s7_list (sc, 2, cur, key)); + } + } + else if (s7_is_pair (cur)) { + if (json_is_null_object (sc, cur)) { + val= s7_nil (sc); + } + else { + s7_int len; + if (!json_is_object (sc, cur, len)) { + return json_type_error (sc, "Value is not a JSON object or array", cur); + } + val = s7_nil (sc); + s7_pointer p= cur; + while (s7_is_pair (p)) { + s7_pointer entry= s7_car (p); + if (s7_is_equal (sc, s7_car (entry), key)) { + val= s7_cdr (entry); + break; + } + p= s7_cdr (p); + } + } + } + else { + return json_type_error (sc, "Value is not a JSON object or array", cur); + } + cur= json_ref_convert (sc, val); + } + return cur; +} + +static void +glue_json_ref (s7_scheme* sc) { + const char* name= "g_json_ref"; + const char* desc= "(g_json_ref json key . keys) => value, ref a value from Scheme-form JSON data by key path"; + s7_define_function (sc, name, f_json_ref, 2, 0, true, desc); + cached_vector_ref= s7_name_to_value (sc, "vector-ref"); + s7_gc_protect (sc, cached_vector_ref); + symbol_true= s7_make_symbol (sc, "true"); + s7_gc_protect (sc, symbol_true); + symbol_false= s7_make_symbol (sc, "false"); + s7_gc_protect (sc, symbol_false); + symbol_null= s7_make_symbol (sc, "null"); + s7_gc_protect (sc, symbol_null); +} + +// json-set 的叶层写入器：rest 非空表示多键路径（对旧值递归 json-set）， +// 否则写入叶层值（叶层值为过程时以旧值调用之）； +// is_push 表示 json-push 的多键路径（对旧值递归 json-push，kvs 为键值序列）； +// is_drop 表示 json-drop 的多键路径（对旧值递归 json-drop，keys 为键序列） +struct json_setter { + s7_pointer rest; // 剩余 (key val ...) 参数；'() 表示已到叶层 + s7_pointer leaf; // 叶层值（仅 rest 为 '() 时有效） + bool leaf_is_proc; + bool is_push; // json-push 多键模式 + s7_pointer push_args; // (key ... val) 序列（仅 is_push 时有效） + bool is_drop; // json-drop 多键模式 + s7_pointer drop_args; // (key ...) 序列（仅 is_drop 时有效） +}; + +static s7_pointer json_set_dispatch (s7_scheme* sc, s7_pointer x, s7_pointer kargs); +static s7_pointer json_push_dispatch (s7_scheme* sc, s7_pointer x, s7_pointer kvs); +static s7_pointer json_drop_dispatch (s7_scheme* sc, s7_pointer x, s7_pointer keys); + +static s7_pointer +json_setter_apply (s7_scheme* sc, const json_setter& st, s7_pointer old) { + if (st.is_push) return json_push_dispatch (sc, old, st.push_args); + if (st.is_drop) return json_drop_dispatch (sc, old, st.drop_args); + if (!s7_is_null (sc, st.rest)) return json_set_dispatch (sc, old, st.rest); + if (st.leaf_is_proc) return s7_call (sc, st.leaf, s7_list (sc, 1, old)); + return st.leaf; +} + +// guenchi json-set 的单层语义：x 已校验为 JSON 对象（含 len 个条目）或数组 +static s7_pointer +json_guenchi_set (s7_scheme* sc, s7_pointer x, s7_pointer v, s7_int len, const json_setter& st) { + if (s7_is_vector (x)) { + s7_int n = s7_vector_length (x); + s7_pointer* elems= s7_vector_elements (x); + if (s7_is_boolean (v) && !s7_boolean (sc, v)) { + // guenchi 的 (if v ...) 无 else 分支：(list->vector #) 抛 wrong-type-arg + return s7_call (sc, cached_list_to_vector, s7_list (sc, 1, s7_unspecified (sc))); + } + s7_pointer result= s7_make_vector (sc, n); + s7_gc_protect_via_stack (sc, result); + s7_pointer* relems= s7_vector_elements (result); + for (s7_int i= 0; i < n; i++) { + bool replace; + if (s7_is_boolean (v)) replace= true; + else if (s7_is_procedure (v)) { + replace= (s7_call (sc, v, s7_list (sc, 1, s7_make_integer (sc, i))) != s7_f (sc)); + } + else { + replace= s7_is_equal (sc, s7_make_integer (sc, i), v); + } + relems[i]= replace ? json_setter_apply (sc, st, elems[i]) : elems[i]; + } + s7_gc_unprotect_via_stack (sc, result); + return result; + } + // 对象（alist）：键 #t 或过程键保留原键，普通键匹配后用传入的键构造新序对 + bool map_all= false, use_pred= false; + if (s7_is_boolean (v)) { + if (!s7_boolean (sc, v)) return s7_unspecified (sc); // (if v ...) 无 else 分支 + map_all= true; + } + else if (s7_is_procedure (v)) { + use_pred= true; + } + // 先搭建与输入等长的结果骨架并 GC 保护（搭建期间不调用用户过程） + s7_pointer head= s7_cons (sc, s7_nil (sc), s7_nil (sc)); + s7_gc_protect_via_stack (sc, head); + s7_pointer tail= head; + for (s7_int i= 1; i < len; i++) { + s7_set_cdr (tail, s7_cons (sc, s7_nil (sc), s7_nil (sc))); + tail= s7_cdr (tail); + } + s7_pointer p= x; + tail = head; + while (s7_is_pair (p)) { + s7_pointer entry= s7_car (p); + bool replace; + if (map_all) replace= true; + else if (use_pred) { + replace= (s7_call (sc, v, s7_list (sc, 1, s7_car (entry))) != s7_f (sc)); + } + else { + replace= s7_is_equal (sc, s7_car (entry), v); + } + if (replace) { + s7_pointer newkey= (map_all || use_pred) ? s7_car (entry) : v; + s7_set_car (tail, s7_cons (sc, newkey, json_setter_apply (sc, st, s7_cdr (entry)))); + } + else { + s7_set_car (tail, entry); // 未匹配的条目复用原序对 + } + tail= s7_cdr (tail); + p = s7_cdr (p); + } + s7_gc_unprotect_via_stack (sc, head); + return head; +} + +// 对应 (liii json) 的 json-set 包装：结构校验 + '(()) 特判 + 单键/多键分派 +// kargs 为 (key val . rest) +static s7_pointer +json_set_dispatch (s7_scheme* sc, s7_pointer x, s7_pointer kargs) { + s7_int len= 0; + if (!s7_is_vector (x) && !json_is_object (sc, x, len)) { + return json_type_error (sc, "Value is not a JSON object or array", x); + } + // 空对象 '(()) 原样返回（单键与多键均如此） + if (json_is_null_object (sc, x)) return x; + s7_pointer key = s7_car (kargs); + s7_pointer rest= s7_cdr (kargs); + json_setter st; + st.is_push = false; + st.push_args= NULL; + st.is_drop = false; + st.drop_args= NULL; + if (s7_is_null (sc, s7_cdr (rest))) { + st.rest = s7_nil (sc); + st.leaf = s7_car (rest); + st.leaf_is_proc= s7_is_procedure (st.leaf); + } + else { + st.rest = rest; + st.leaf = NULL; + st.leaf_is_proc= false; + } + return json_guenchi_set (sc, x, key, len, st); +} + +static s7_pointer +f_json_set (s7_scheme* sc, s7_pointer args) { + return json_set_dispatch (sc, s7_car (args), s7_cdr (args)); +} + +static void +glue_json_set (s7_scheme* sc) { + const char* name= "g_json_set"; + const char* desc= + "(g_json_set json key val . keys-and-val) => data, set a value in Scheme-form JSON data by key path"; + s7_define_function (sc, name, f_json_set, 3, 0, true, desc); + cached_list_to_vector= s7_name_to_value (sc, "list->vector"); + s7_gc_protect (sc, cached_list_to_vector); +} + +// json-push / json-push* 的 C++ 实现，语义与历史上 (liii json) 包装 (guenchi json) +// 的 Scheme 实现完全一致： +// - 单键：对象 (cons (cons k v) x) 前插；空对象 '(()) 退化为对 '() 前插得 '((k . v))； +// 数组空时返回 #(v)；非空时按索引 equal? 匹配，首匹配处前插 v（仅一次），无匹配尾插 +// - 多键：等价于 (json-set json key (lambda (x) (apply json-push x ...)))， +// 即经 json-set 的单层语义逐层下钻（中间键不存在时静默不生效）， +// 空对象 '(()) 原样返回；每层进入时先做结构校验 + +// guenchi json-push 的单层语义：x 已校验为 JSON 对象（或 '()）或数组 +static s7_pointer +json_guenchi_push (s7_scheme* sc, s7_pointer x, s7_pointer k, s7_pointer v) { + if (s7_is_vector (x)) { + s7_int n = s7_vector_length (x); + s7_pointer* elems= s7_vector_elements (x); + if (n == 0) { + s7_pointer result = s7_make_vector (sc, 1); + s7_vector_elements (result)[0]= v; + return result; + } + // 首个 equal? 匹配的索引处前插 v；无匹配则尾插 + s7_int match= -1; + for (s7_int i= 0; i < n; i++) { + if (s7_is_equal (sc, s7_make_integer (sc, i), k)) { + match= i; + break; + } + } + s7_pointer result= s7_make_vector (sc, n + 1); + s7_gc_protect_via_stack (sc, result); + s7_pointer* relems= s7_vector_elements (result); + s7_int at = 0; + for (s7_int i= 0; i < n; i++) { + if (i == match) relems[at++]= v; + relems[at++]= elems[i]; + } + if (match < 0) relems[at]= v; + s7_gc_unprotect_via_stack (sc, result); + return result; + } + // 对象：前插 (k . v) + return s7_cons (sc, s7_cons (sc, k, v), x); +} + +// 对应 (liii json) 的 json-push 包装：结构校验 + 单键/多键分派 +// kvs 为 (key val) 或 (key ... val)（多键时 key 之后逐层下钻，末项为值） +static s7_pointer +json_push_dispatch (s7_scheme* sc, s7_pointer x, s7_pointer kvs) { + s7_int len= 0; + if (!s7_is_vector (x) && !json_is_object (sc, x, len)) { + return json_type_error (sc, "Value is not a JSON object or array", x); + } + if (s7_is_null (sc, s7_cdr (s7_cdr (kvs)))) { + // 单键：空对象 '(()) 退化为对 '() 前插 + s7_pointer k= s7_car (kvs); + s7_pointer v= s7_cadr (kvs); + if (json_is_null_object (sc, x)) x= s7_nil (sc); + return json_guenchi_push (sc, x, k, v); + } + // 多键：空对象 '(()) 原样返回（json-set 语义） + if (json_is_null_object (sc, x)) return x; + json_setter st; + st.rest = s7_nil (sc); + st.leaf = NULL; + st.leaf_is_proc= false; + st.is_push = true; + st.push_args = s7_cdr (kvs); + st.is_drop = false; + st.drop_args = NULL; + return json_guenchi_set (sc, x, s7_car (kvs), len, st); +} + +static s7_pointer +f_json_push (s7_scheme* sc, s7_pointer args) { + return json_push_dispatch (sc, s7_car (args), s7_cdr (args)); +} + +static void +glue_json_push (s7_scheme* sc) { + const char* name= "g_json_push"; + const char* desc= "(g_json_push json key val . keys) => data, push a value into Scheme-form JSON data by key path"; + s7_define_function (sc, name, f_json_push, 3, 0, true, desc); +} + +// json-drop / json-drop* 的 C++ 实现，语义与历史上 (liii json) 包装 (guenchi json) +// 的 Scheme 实现完全一致： +// - 单键：对象删除键 equal? 匹配或谓词命中键的条目（全部删空时退化为 '()）； +// 空对象 '(()) 原样返回；数组空时返回自身，非空时按键（即索引）equal? 匹配 +// 或谓词命中索引删除对应元素 +// - 多键：等价于 (json-set json key (lambda (x) (apply json-drop x ...)))， +// 即经 json-set 的单层语义逐层下钻（中间键不存在时静默不生效）， +// 空对象 '(()) 原样返回；每层进入时先做结构校验 + +// guenchi json-drop 的单层语义：x 已校验为 JSON 对象或数组 +// v 为过程时按键（数组为索引）谓词筛选，否则按 equal? 匹配键（数组为索引） +static s7_pointer +json_guenchi_drop (s7_scheme* sc, s7_pointer x, s7_pointer v) { + bool use_pred= s7_is_procedure (v); + if (s7_is_vector (x)) { + s7_int n = s7_vector_length (x); + s7_pointer* elems= s7_vector_elements (x); + if (n == 0) return x; + // 谓词可能触发 GC 或回调 Scheme，先只判定再分配结果（ elems 经 x 有根） + std::vector drop (n, false); + s7_int count= 0; + for (s7_int i= 0; i < n; i++) { + bool hit= use_pred ? (s7_call (sc, v, s7_list (sc, 1, s7_make_integer (sc, i))) != s7_f (sc)) + : s7_is_equal (sc, s7_make_integer (sc, i), v); + drop[i] = hit; + if (hit) count++; + } + if (count == 0) return x; + s7_pointer result= s7_make_vector (sc, n - count); + s7_int at = 0; + s7_pointer* relems= s7_vector_elements (result); + for (s7_int i= 0; i < n; i++) { + if (!drop[i]) relems[at++]= elems[i]; + } + return result; + } + // 对象（alist）：删除键命中的条目，未命中的条目复用原序对；命中后从尾向头 cons + std::vector kept; + kept.reserve (16); + s7_pointer p= x; + while (s7_is_pair (p)) { + s7_pointer entry= s7_car (p); + bool hit = use_pred ? (s7_call (sc, v, s7_list (sc, 1, s7_car (entry))) != s7_f (sc)) + : s7_is_equal (sc, s7_car (entry), v); + if (!hit) kept.push_back (entry); + p= s7_cdr (p); + } + s7_pointer lst= s7_nil (sc); + for (size_t i= kept.size (); i > 0; i--) + lst= s7_cons (sc, kept[i - 1], lst); + return lst; +} + +// 对应 (liii json) 的 json-drop 包装：结构校验 + 空对象特判 + 单键/多键分派 +// keys 为 (key) 或 (key ...)（多键时 key 之后逐层下钻，末项为目标键或谓词） +static s7_pointer +json_drop_dispatch (s7_scheme* sc, s7_pointer x, s7_pointer keys) { + s7_int len= 0; + if (!s7_is_vector (x) && !json_is_object (sc, x, len)) { + return json_type_error (sc, "Value is not a JSON object or array", x); + } + // 空对象 '(()) 原样返回（单键与多键均如此） + if (json_is_null_object (sc, x)) return x; + if (s7_is_null (sc, s7_cdr (keys))) { + // 单键 + return json_guenchi_drop (sc, x, s7_car (keys)); + } + // 多键：经 json-set 的单层语义逐层下钻，叶层对旧值在 C++ 内递归 drop + json_setter st; + st.rest = s7_nil (sc); + st.leaf = NULL; + st.leaf_is_proc= false; + st.is_push = false; + st.push_args = NULL; + st.is_drop = true; + st.drop_args = s7_cdr (keys); + return json_guenchi_set (sc, x, s7_car (keys), len, st); +} + +static s7_pointer +f_json_drop (s7_scheme* sc, s7_pointer args) { + return json_drop_dispatch (sc, s7_car (args), s7_cdr (args)); +} + +static void +glue_json_drop (s7_scheme* sc) { + const char* name= "g_json_drop"; + const char* desc= "(g_json_drop json key . keys) => data, drop values from Scheme-form JSON data by key path"; + s7_define_function (sc, name, f_json_drop, 2, 0, true, desc); +} + +// json-reduce / json-reduce* 的 C++ 实现，语义与历史上 (liii json) 包装 (guenchi json) +// 的 Scheme 实现完全一致： +// - 单层：(json-reduce json key proc)； +// 键 #t 映射所有条目；键为过程表示按键（数组为索引）谓词筛选命中后转换； +// 普通键按 equal? 匹配；命中条目的新值 = (proc key old-value)，未命中条目复用原序对 +// （对象分支命中后新序对的键：#t/过程键保留原键，普通键用传入的键）； +// 键 #f 落入 guenchi (if v ...) 无 else 分支的历史怪癖原样保留 +// （对象返回 x，数组被外层 (list->vector x) 抛 wrong-type-arg） +// - 多键：等价于 (json-reduce json key (lambda (k v) (apply json-reduce v ...)))， +// 即经 json-reduce 的单层语义逐层下钻（中间键不存在时静默不生效）， +// 叶层对旧值在 C++ 内递归 reduce，不经 Scheme 闭包回调； +// '() 透传（安全导航）；空对象 '(()) 原样返回；每层先做结构校验 + +// json-reduce 的叶层转换器：p 为转换过程 ((key val) -> new)， +// is_reduce 表示多键路径（对旧值递归 json-reduce，rest 为 (key ... proc) 序列） +struct json_reducer { + s7_pointer p; // 叶层转换过程（仅非 is_reduce 时有效） + bool is_reduce; // 多键模式 + s7_pointer reduce_args; +}; + +static s7_pointer json_reduce_dispatch (s7_scheme* sc, s7_pointer x, s7_pointer kargs); + +static s7_pointer +json_reducer_apply (s7_scheme* sc, const json_reducer& r, s7_pointer k, s7_pointer old) { + if (r.is_reduce) return json_reduce_dispatch (sc, old, r.reduce_args); + return s7_call (sc, r.p, s7_list (sc, 2, k, old)); +} + +// guenchi json-reduce 的单层语义：x 已校验为 JSON 对象（含 len 个条目）或数组 +static s7_pointer +json_guenchi_reduce (s7_scheme* sc, s7_pointer x, s7_pointer v, const json_reducer& r, s7_int len) { + bool is_bool = s7_is_boolean (v); + bool truthy = is_bool && s7_boolean (sc, v); + bool use_pred= s7_is_procedure (v); + if (s7_is_vector (x)) { + if (is_bool && !truthy) { + // guenchi 的 (if v ...) 无 else 分支：(list->vector x) 对 vector 抛 wrong-type-arg + return s7_call (sc, cached_list_to_vector, s7_list (sc, 1, x)); + } + s7_int n = s7_vector_length (x); + s7_pointer* elems = s7_vector_elements (x); + s7_pointer result= s7_make_vector (sc, n); + s7_gc_protect_via_stack (sc, result); + s7_pointer* relems= s7_vector_elements (result); + for (s7_int i= 0; i < n; i++) { + s7_pointer idx= s7_make_integer (sc, i); + bool hit= + truthy ? true : (use_pred ? (s7_call (sc, v, s7_list (sc, 1, idx)) != s7_f (sc)) : s7_is_equal (sc, idx, v)); + relems[i]= hit ? json_reducer_apply (sc, r, idx, elems[i]) : elems[i]; + } + s7_gc_unprotect_via_stack (sc, result); + return result; + } + // 对象（alist）：#f 原样返回；命中的条目换新序对，未命中的条目复用原序对 + if (is_bool && !truthy) return x; + // 先搭建与输入等长的结果骨架并 GC 保护（搭建期间不调用用户过程） + s7_pointer head= s7_cons (sc, s7_nil (sc), s7_nil (sc)); + s7_gc_protect_via_stack (sc, head); + s7_pointer tail= head; + for (s7_int i= 1; i < len; i++) { + s7_set_cdr (tail, s7_cons (sc, s7_nil (sc), s7_nil (sc))); + tail= s7_cdr (tail); + } + s7_pointer p= x; + tail = head; + while (s7_is_pair (p)) { + s7_pointer entry= s7_car (p); + s7_pointer k = s7_car (entry); + bool hit= truthy ? true : (use_pred ? (s7_call (sc, v, s7_list (sc, 1, k)) != s7_f (sc)) : s7_is_equal (sc, k, v)); + if (hit) { + s7_pointer newkey= (is_bool || use_pred) ? k : v; // 普通键分支历史用传入的键构造新序对 + s7_set_car (tail, s7_cons (sc, newkey, json_reducer_apply (sc, r, newkey, s7_cdr (entry)))); + } + else { + s7_set_car (tail, entry); + } + tail= s7_cdr (tail); + p = s7_cdr (p); + } + s7_gc_unprotect_via_stack (sc, head); + return head; +} + +// 对应 (liii json) 的 json-reduce 包装：'() 透传 + 结构校验 + 空对象特判 + 单层/多键分派 +// kargs 为 (key proc) 或 (key ... proc)：恰好两个元素时是单层（p 为转换函数）， +// 否则多键（等价于以 (lambda (k v) (apply json-reduce v rest)) 作转换函数逐层下钻， +// rest 为 (k2 ... proc) 序列，与递归调用的 kargs 结构一致） +static s7_pointer +json_reduce_dispatch (s7_scheme* sc, s7_pointer x, s7_pointer kargs) { + // '() 透传：安全导航 + if (s7_is_null (sc, x)) return s7_nil (sc); + s7_int len= 0; + if (!s7_is_vector (x) && !json_is_object (sc, x, len)) { + return json_type_error (sc, "Value is not a JSON object or array", x); + } + // 空对象 '(()) 原样返回（单层与多键均如此） + if (json_is_null_object (sc, x)) return x; + s7_pointer rest= s7_cdr (kargs); + json_reducer r; + if (s7_is_null (sc, s7_cdr (rest))) { + // 单层：(key proc) + r.p = s7_car (rest); + r.is_reduce = false; + r.reduce_args= NULL; + } + else { + // 多键：(key k2 ... proc) + r.p = NULL; + r.is_reduce = true; + r.reduce_args= rest; + } + return json_guenchi_reduce (sc, x, s7_car (kargs), r, len); +} + +static s7_pointer +f_json_reduce (s7_scheme* sc, s7_pointer args) { + if (s7_is_null (sc, s7_cdr (s7_cdr (args)))) { + return s7_error (sc, s7_make_symbol (sc, "value-error"), + s7_list (sc, 1, s7_make_string (sc, "json-reduce: missing arguments"))); + } + return json_reduce_dispatch (sc, s7_car (args), s7_cdr (args)); +} + +static void +glue_json_reduce (s7_scheme* sc) { + const char* name= "g_json_reduce"; + const char* desc= + "(g_json_reduce json key proc . keys) => data, transform values in Scheme-form JSON data by key path"; + s7_define_function (sc, name, f_json_reduce, 2, 0, true, desc); +} + +void +glue_liii_json (s7_scheme* sc) { + glue_json_to_string (sc); + glue_json_string_escape (sc); + glue_string_to_json (sc); + glue_json_ref (sc); + glue_json_set (sc); + glue_json_push (sc); + glue_json_drop (sc); + glue_json_reduce (sc); +} + +} // namespace goldfish diff --git a/TeXmacs/plugins/goldfish/src/liii_sort.cpp b/TeXmacs/plugins/goldfish/src/liii_sort.cpp new file mode 100644 index 0000000000..1106983241 --- /dev/null +++ b/TeXmacs/plugins/goldfish/src/liii_sort.cpp @@ -0,0 +1,80 @@ +// +// Copyright (C) 2026 The Goldfish Scheme Authors +// +// Licensed under the Apache License, Version 2.0 (the "License"); +// you may not use this file except in compliance with the License. +// You may obtain a copy of the License at +// +// http://www.apache.org/licenses/LICENSE-2.0 +// +// Unless required by applicable law or agreed to in writing, software +// distributed under the License is distributed on an "AS IS" BASIS, +// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +// See the License for the specific language governing permissions and +// limitations under the License. +// + +#include "s7.h" + +namespace goldfish { + +// (g_list-sorted? less-p lis) => boolean +// 判定标准与 SRFI-132 参考实现一致：对所有相邻元素对， +// (less-p next prev) 为真（非 #f）即视为逆序。 +static s7_pointer +f_list_sorted_p (s7_scheme* sc, s7_pointer args) { + s7_pointer less_p= s7_car (args); + s7_pointer lis = s7_cadr (args); + + if (!s7_is_procedure (less_p)) { + return s7_wrong_type_arg_error (sc, "list-sorted?", 1, less_p, "a procedure"); + } + if (!s7_is_pair (lis)) { + if (s7_is_null (sc, lis)) return s7_t (sc); + return s7_wrong_type_arg_error (sc, "list-sorted?", 2, lis, "a proper list"); + } + + /* args 的 cons 单元在 less_p 回调期间可能被求值器复用， + * 因此把 less_p、列表头和我们自建的二元调用列表放进同一个 + * 栈上保护的 anchor，保证回调触发 GC 时全部可达 */ + s7_pointer call_args= s7_cons (sc, s7_f (sc), s7_cons (sc, s7_f (sc), s7_nil (sc))); + s7_pointer anchor = s7_cons (sc, less_p, s7_cons (sc, lis, call_args)); + s7_gc_protect_via_stack (sc, anchor); + s7_pointer call_args_second= s7_cdr (call_args); + + bool sorted= true; + s7_pointer prev = s7_car (lis); + s7_pointer p = s7_cdr (lis); + while (s7_is_pair (p)) { + s7_pointer cur= s7_car (p); + s7_set_car (call_args, cur); + s7_set_car (call_args_second, prev); + if (s7_apply_function (sc, less_p, call_args) != s7_f (sc)) { + sorted= false; + break; + } + prev= cur; + p = s7_cdr (p); + } + s7_gc_unprotect_via_stack (sc, anchor); + + if (!sorted) return s7_f (sc); + if (!s7_is_null (sc, p)) { + return s7_wrong_type_arg_error (sc, "list-sorted?", 2, lis, "a proper list"); + } + return s7_t (sc); +} + +static void +glue_list_sorted_p (s7_scheme* sc) { + const char* name= "g_list-sorted?"; + const char* desc= "(g_list-sorted? less-p lis) => boolean"; + s7_define_function (sc, name, f_list_sorted_p, 2, 0, false, desc); +} + +void +glue_liii_sort (s7_scheme* sc) { + glue_list_sorted_p (sc); +} + +} // namespace goldfish diff --git a/TeXmacs/plugins/goldfish/src/liii_string.cpp b/TeXmacs/plugins/goldfish/src/liii_string.cpp new file mode 100644 index 0000000000..bebd9810c2 --- /dev/null +++ b/TeXmacs/plugins/goldfish/src/liii_string.cpp @@ -0,0 +1,387 @@ +// +// Copyright (C) 2026 The Goldfish Scheme Authors +// +// Licensed under the Apache License, Version 2.0 (the "License"); +// you may not use this file except in compliance with the License. +// You may obtain a copy of the License at +// +// http://www.apache.org/licenses/LICENSE-2.0 +// +// Unless required by applicable law or agreed to in writing, software +// distributed under the License is distributed on an "AS IS" BASIS, +// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +// See the License for the specific language governing permissions and +// limitations under the License. +// + +#include "s7.h" +#include +#include +#include +#include +#include +#include + +namespace goldfish { + +static s7_pointer +liii_string_type_error (s7_scheme* sc, const char* msg, s7_pointer arg) { + return s7_error (sc, s7_make_symbol (sc, "type-error"), s7_list (sc, 2, s7_make_string (sc, msg), arg)); +} + +// 返回 UTF-8 首字节 b 对应的码点字节宽度（1~4）；非法首字节返回 0 +static inline int +utf8_seq_len (uint8_t b) { + if (b < 0x80) return 1; + if ((b & 0xE0) == 0xC0) return 2; + if ((b & 0xF0) == 0xE0) return 3; + if ((b & 0xF8) == 0xF0) return 4; + return 0; +} + +// 将码点编码为 UTF-8 写入 out，返回字节数（1~4） +static int +utf8_encode (uint32_t cp, char* out) { + if (cp < 0x80) { + out[0]= (char) cp; + return 1; + } + if (cp < 0x800) { + out[0]= (char) (0xC0 | (cp >> 6)); + out[1]= (char) (0x80 | (cp & 0x3F)); + return 2; + } + if (cp < 0x10000) { + out[0]= (char) (0xE0 | (cp >> 12)); + out[1]= (char) (0x80 | ((cp >> 6) & 0x3F)); + out[2]= (char) (0x80 | (cp & 0x3F)); + return 3; + } + out[0]= (char) (0xF0 | (cp >> 18)); + out[1]= (char) (0x80 | ((cp >> 12) & 0x3F)); + out[2]= (char) (0x80 | ((cp >> 6) & 0x3F)); + out[3]= (char) (0x80 | (cp & 0x3F)); + return 4; +} + +static s7_pointer +f_string_split (s7_scheme* sc, s7_pointer args) { + s7_pointer str_arg= s7_car (args); + s7_pointer sep_arg= s7_cadr (args); + + if (!s7_is_string (str_arg)) { + return liii_string_type_error (sc, "string-split: first parameter must be string", str_arg); + } + + std::string sep; + if (s7_is_string (sep_arg)) { + sep.assign (s7_string (sep_arg), (size_t) s7_string_length (sep_arg)); + } + else if (s7_is_character (sep_arg)) { + char buf[4]; + int n= utf8_encode (s7_character (sep_arg), buf); + sep.assign (buf, (size_t) n); + } + else { + return liii_string_type_error (sc, "string-split: second parameter must be string or char", sep_arg); + } + + const char* s = s7_string (str_arg); + size_t len= (size_t) s7_string_length (str_arg); + + std::vector> parts; + if (sep.empty ()) { + // 空分隔符：按 UTF-8 字符拆分；非法字节按单字节处理 + size_t i= 0; + while (i < len) { + int n= utf8_seq_len ((uint8_t) s[i]); + if (n == 0 || i + (size_t) n > len) n= 1; + parts.emplace_back (i, (size_t) n); + i+= (size_t) n; + } + } + else { + std::string_view sv (s, len); + size_t start= 0; + while (true) { + size_t pos= sv.find (sep, start); + if (pos == std::string_view::npos) { + parts.emplace_back (start, len - start); + break; + } + parts.emplace_back (start, pos - start); + start= pos + sep.size (); + } + } + + /* no Scheme callbacks here, so args stay put; only the result being built + * needs a GC anchor, with each new pair linked in right after s7_cons */ + s7_pointer head= s7_cons (sc, s7_nil (sc), s7_nil (sc)); + s7_gc_protect_via_stack (sc, head); + s7_pointer tail= head; + for (const auto& part : parts) { + s7_pointer str= s7_make_string_with_length (sc, s + part.first, (s7_int) part.second); + s7_set_cdr (tail, s7_cons (sc, str, s7_nil (sc))); + tail= s7_cdr (tail); + } + s7_gc_unprotect_via_stack (sc, head); + return s7_cdr (head); +} + +enum class string_join_grammar { infix, strict_infix, suffix, prefix }; + +static s7_pointer +f_string_join (s7_scheme* sc, s7_pointer args) { + s7_pointer l = s7_car (args); + s7_pointer rest= s7_cdr (args); + + std::string delim; + if (!s7_is_null (sc, rest)) { + s7_pointer delim_arg= s7_car (rest); + if (!s7_is_string (delim_arg)) { + return liii_string_type_error (sc, "optional params in string-join", delim_arg); + } + delim.assign (s7_string (delim_arg), (size_t) s7_string_length (delim_arg)); + rest= s7_cdr (rest); + } + + string_join_grammar grammar = string_join_grammar::infix; + bool grammar_valid= true; + if (!s7_is_null (sc, rest)) { + s7_pointer grammar_arg= s7_car (rest); + if (!s7_is_symbol (grammar_arg)) { + return liii_string_type_error (sc, "optional params in string-join", grammar_arg); + } + const char* name= s7_symbol_name (grammar_arg); + if (std::strcmp (name, "infix") == 0) grammar= string_join_grammar::infix; + else if (std::strcmp (name, "strict-infix") == 0) grammar= string_join_grammar::strict_infix; + else if (std::strcmp (name, "suffix") == 0) grammar= string_join_grammar::suffix; + else if (std::strcmp (name, "prefix") == 0) grammar= string_join_grammar::prefix; + else grammar_valid= false; + } + + // 第一趟：校验元素均为字符串并累计总字节数，与旧实现一样在 grammar 分支之前报错 + size_t count = 0; + size_t total_len= 0; + s7_pointer p = l; + while (s7_is_pair (p)) { + s7_pointer elem= s7_car (p); + if (!s7_is_string (elem)) { + return liii_string_type_error (sc, "string-join: elements must be strings", elem); + } + total_len+= (size_t) s7_string_length (elem); + count++; + p= s7_cdr (p); + } + if (!s7_is_null (sc, p)) { + return liii_string_type_error (sc, "string-join: first parameter must be a proper list", l); + } + + if (!grammar_valid) { + return s7_error (sc, s7_make_symbol (sc, "value-error"), s7_list (sc, 1, s7_make_string (sc, "invalid grammer"))); + } + + if (grammar == string_join_grammar::strict_infix && count == 0) { + return s7_error (sc, s7_make_symbol (sc, "value-error"), + s7_list (sc, 1, s7_make_string (sc, "empty list not allowed"))); + } + + const size_t delim_len = delim.size (); + size_t delim_count= 0; + switch (grammar) { + case string_join_grammar::infix: + case string_join_grammar::strict_infix: + delim_count= (count > 0) ? count - 1 : 0; + break; + case string_join_grammar::suffix: + case string_join_grammar::prefix: + delim_count= count; + break; + } + + std::string result; + result.reserve (total_len + delim_count * delim_len); + size_t i= 0; + for (p= l; s7_is_pair (p); p= s7_cdr (p), i++) { + if (grammar == string_join_grammar::prefix || (i > 0 && grammar != string_join_grammar::suffix)) { + result.append (delim); + } + s7_pointer elem= s7_car (p); + result.append (s7_string (elem), (size_t) s7_string_length (elem)); + if (grammar == string_join_grammar::suffix) result.append (delim); + } + + /* no Scheme callbacks here, so args (and the strings reachable from the + * input list) stay put; the result is built in a C++ buffer first and + * copied into the Scheme heap in a single allocation */ + return s7_make_string_with_length (sc, result.data (), (s7_int) result.size ()); +} + +static s7_pointer +f_string_replace (s7_scheme* sc, s7_pointer args) { + s7_pointer str_arg= s7_car (args); + s7_pointer old_arg= s7_cadr (args); + s7_pointer new_arg= s7_caddr (args); + s7_pointer rest = s7_cdddr (args); + + if (!s7_is_string (str_arg)) { + return liii_string_type_error (sc, "string-replace: str must be a string", str_arg); + } + if (!s7_is_string (old_arg)) { + return liii_string_type_error (sc, "string-replace: old must be a string", old_arg); + } + if (!s7_is_string (new_arg)) { + return liii_string_type_error (sc, "string-replace: new must be a string", new_arg); + } + + s7_int count= -1; + if (!s7_is_null (sc, rest)) { + s7_pointer count_arg= s7_car (rest); + // 与旧实现 (integer? count) 的契约一致：整数或整数值的浮点数均可 + if (s7_is_integer (count_arg)) { + count= s7_integer (count_arg); + } + else if (s7_is_real (count_arg) && std::floor (s7_real (count_arg)) == s7_real (count_arg)) { + count= (s7_int) s7_real (count_arg); + } + else { + return liii_string_type_error (sc, "string-replace: count must be an integer", count_arg); + } + } + + /* 先全部拷入 C++ 缓冲区，之后只在最后做一次 Scheme 堆分配， + * 因此无需额外的 GC anchor（且全程没有 Scheme 回调） */ + const std::string_view str (s7_string (str_arg), (size_t) s7_string_length (str_arg)); + const std::string_view old_v (s7_string (old_arg), (size_t) s7_string_length (old_arg)); + const std::string_view new_v (s7_string (new_arg), (size_t) s7_string_length (new_arg)); + + if (count == 0) { + return s7_make_string_with_length (sc, str.data (), (s7_int) str.size ()); + } + + std::string result; + if (old_v.empty ()) { + // 空 pattern：在每个字节之间插入 new（Python 兼容行为） + if (str.empty ()) { + result.assign (new_v); + } + else { + const size_t max_insert= str.size () + 1; + size_t remaining = (count < 0) ? max_insert : std::min ((size_t) count, max_insert); + result.reserve (str.size () + remaining * new_v.size ()); + size_t i= 0; + while (i < str.size () && remaining > 0) { + result.append (new_v); + result.append (str, i, 1); + i++; + remaining--; + } + if (i == str.size ()) { + if (remaining > 0) result.append (new_v); + } + else { + result.append (str, i, str.size () - i); + } + } + } + else { + // 非空 pattern：从左到右、非重叠替换；UTF-8 字节级匹配是精确的 + size_t remaining= (count < 0) ? std::string_view::npos : (size_t) count; + size_t start = 0; + while (remaining > 0) { + size_t pos= str.find (old_v, start); + if (pos == std::string_view::npos) break; + result.append (str, start, pos - start); + result.append (new_v); + start= pos + old_v.size (); + remaining--; + } + if (start == 0) { + // 无匹配：返回原内容的副本 + return s7_make_string_with_length (sc, str.data (), (s7_int) str.size ()); + } + result.append (str, start, str.size () - start); + } + + return s7_make_string_with_length (sc, result.data (), (s7_int) result.size ()); +} + +static s7_pointer +f_string_starts_p (s7_scheme* sc, s7_pointer args) { + s7_pointer str_arg = s7_car (args); + s7_pointer prefix_arg= s7_cadr (args); + + if (!s7_is_string (str_arg) || !s7_is_string (prefix_arg)) { + return s7_error (sc, s7_make_symbol (sc, "type-error"), + s7_list (sc, 1, s7_make_string (sc, "string-starts? parameter is not a string"))); + } + + // UTF-8 字节级前缀比较是精确的：前缀字节序列必然落在码点边界上 + const size_t str_len = (size_t) s7_string_length (str_arg); + const size_t prefix_len= (size_t) s7_string_length (prefix_arg); + if (prefix_len > str_len) return s7_f (sc); + return s7_make_boolean (sc, std::memcmp (s7_string (str_arg), s7_string (prefix_arg), prefix_len) == 0); +} + +static s7_pointer +f_string_ends_p (s7_scheme* sc, s7_pointer args) { + s7_pointer str_arg = s7_car (args); + s7_pointer suffix_arg= s7_cadr (args); + + if (!s7_is_string (str_arg) || !s7_is_string (suffix_arg)) { + return s7_error (sc, s7_make_symbol (sc, "type-error"), + s7_list (sc, 1, s7_make_string (sc, "string-ends? parameter is not a string"))); + } + + const size_t str_len = (size_t) s7_string_length (str_arg); + const size_t suffix_len= (size_t) s7_string_length (suffix_arg); + if (suffix_len > str_len) return s7_f (sc); + const char* tail= s7_string (str_arg) + (str_len - suffix_len); + return s7_make_boolean (sc, std::memcmp (tail, s7_string (suffix_arg), suffix_len) == 0); +} + +static void +glue_string_join (s7_scheme* sc) { + const char* name= "g_string-join"; + const char* desc= "(g_string-join string-list . delim+grammar) => string"; + s7_define_function (sc, name, f_string_join, 1, 2, false, desc); +} + +static void +glue_string_starts_p (s7_scheme* sc) { + const char* name= "g_string-starts?"; + const char* desc= "(g_string-starts? str prefix) => boolean"; + s7_define_function (sc, name, f_string_starts_p, 2, 0, false, desc); +} + +static void +glue_string_ends_p (s7_scheme* sc) { + const char* name= "g_string-ends?"; + const char* desc= "(g_string-ends? str suffix) => boolean"; + s7_define_function (sc, name, f_string_ends_p, 2, 0, false, desc); +} + +static void +glue_string_replace (s7_scheme* sc) { + const char* name= "g_string-replace"; + const char* desc= "(g_string-replace str old new . count) => string"; + s7_define_function (sc, name, f_string_replace, 3, 1, false, desc); +} + +static void +glue_string_split (s7_scheme* sc) { + const char* name= "g_string-split"; + const char* desc= "(g_string-split str sep) => list of strings"; + s7_define_function (sc, name, f_string_split, 2, 0, false, desc); +} + +void +glue_liii_string (s7_scheme* sc) { + glue_string_join (sc); + glue_string_replace (sc); + glue_string_starts_p (sc); + glue_string_ends_p (sc); + glue_string_split (sc); +} + +} // namespace goldfish diff --git a/TeXmacs/plugins/goldfish/src/liii_string_cursor.cpp b/TeXmacs/plugins/goldfish/src/liii_string_cursor.cpp new file mode 100644 index 0000000000..807a699076 --- /dev/null +++ b/TeXmacs/plugins/goldfish/src/liii_string_cursor.cpp @@ -0,0 +1,443 @@ +// +// Copyright (C) 2026 The Goldfish Scheme Authors +// +// Licensed under the Apache License, Version 2.0 (the "License"); +// you may not use this file except in compliance with the License. +// You may obtain a copy of the License at +// +// http://www.apache.org/licenses/LICENSE-2.0 +// +// Unless required by applicable law or agreed to in writing, software +// distributed under the License is distributed on an "AS IS" BASIS, +// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +// See the License for the specific language governing permissions and +// limitations under the License. +// + +// (liii string-cursor) 的核心游标原语的 C++ 实现 +// +// 游标表示：负整数 -(byte_offset+2)，即字节 0 对应 -2。-1 不是合法游标， +// 保留给"负索引"错误语义（见 validate-start-end）。 +// 与字符索引（非负整数）天然不相交，满足 SRFI 130 的要求， +// 且比较、前进、后退都是 O(1) 或 O(字符宽度) 的整数/字节运算，无分配。 + +#include "s7.h" +#include +#include + +namespace goldfish { + +static s7_pointer +liii_string_cursor_type_error (s7_scheme* sc, const char* msg, s7_pointer arg) { + return s7_error (sc, s7_make_symbol (sc, "type-error"), s7_list (sc, 2, s7_make_string (sc, msg), arg)); +} + +static s7_pointer +liii_string_cursor_value_error (s7_scheme* sc, const char* msg) { + return s7_error (sc, s7_make_symbol (sc, "value-error"), s7_list (sc, 1, s7_make_string (sc, msg))); +} + +// 返回 UTF-8 首字节 b 对应的码点字节宽度（1~4）；非法首字节返回 1 +static inline s7_int +utf8_seq_len (uint8_t b) { + if (b < 0x80) return 1; + if ((b & 0xE0) == 0xC0) return 2; + if ((b & 0xF0) == 0xE0) return 3; + if ((b & 0xF8) == 0xF0) return 4; + return 1; +} + +// 游标 <-> 字节偏移 +static inline s7_int +cursor_to_offset (s7_pointer cursor) { + return -s7_integer (cursor) - 2; +} + +static inline s7_pointer +offset_to_cursor (s7_scheme* sc, s7_int offset) { + return s7_make_integer (sc, -offset - 2); +} + +// 校验第一个参数是字符串；失败时抛 type-error 并返回 NULL +static const char* +check_string_arg (s7_scheme* sc, s7_pointer arg, const char* who) { + if (!s7_is_string (arg)) { + liii_string_cursor_type_error (sc, who, arg); + return NULL; + } + return s7_string (arg); +} + +// 校验 cursor 参数：负整数（游标）或非负整数（索引）；返回 true 表示是游标 +static bool +parse_cursor_arg (s7_scheme* sc, s7_pointer arg, const char* who, s7_int* value) { + if (!s7_is_integer (arg)) { + liii_string_cursor_type_error (sc, who, arg); + return false; + } + *value= s7_integer (arg); + return *value < -1; +} + +// ---- string-cursor-start / string-cursor-end ---- + +static s7_pointer +f_string_cursor_start (s7_scheme* sc, s7_pointer args) { + s7_pointer str= s7_car (args); + if (!check_string_arg (sc, str, "string-cursor-start: first parameter must be string")) return NULL; + return s7_make_integer (sc, -2); +} + +static s7_pointer +f_string_cursor_end (s7_scheme* sc, s7_pointer args) { + s7_pointer str= s7_car (args); + if (!check_string_arg (sc, str, "string-cursor-end: first parameter must be string")) return NULL; + return offset_to_cursor (sc, (s7_int) s7_string_length (str)); +} + +// ---- 字节偏移上的前进/后退 ---- + +static s7_int +utf8_advance (const char* s, s7_int off) { + return off + utf8_seq_len ((uint8_t) s[off]); +} + +static s7_int +utf8_retreat (const char* s, s7_int off) { + do { + off--; + } while (off > 0 && ((s[off] & 0xC0) == 0x80)); + return off; +} + +// ---- string-cursor-next / string-cursor-prev ---- + +static s7_pointer +f_string_cursor_next (s7_scheme* sc, s7_pointer args) { + s7_pointer str= s7_car (args); + const char* s = check_string_arg (sc, str, "string-cursor-next: first parameter must be string"); + if (!s) return NULL; + s7_int cur; + bool is_cursor= + parse_cursor_arg (sc, s7_cadr (args), "string-cursor-next: second parameter must be integer or cursor", &cur); + s7_int len= (s7_int) s7_string_length (str); + + if (!is_cursor) { + // 索引语义：返回索引 +1 + if (cur < 0 || cur >= len) return liii_string_cursor_value_error (sc, "string-cursor-next: already at end cursor"); + return s7_make_integer (sc, cur + 1); + } + s7_int off= cursor_to_offset (s7_car (s7_cdr (args))); + if (off >= len) return liii_string_cursor_value_error (sc, "string-cursor-next: already at end cursor"); + return offset_to_cursor (sc, utf8_advance (s, off)); +} + +static s7_pointer +f_string_cursor_prev (s7_scheme* sc, s7_pointer args) { + s7_pointer str= s7_car (args); + const char* s = check_string_arg (sc, str, "string-cursor-prev: first parameter must be string"); + if (!s) return NULL; + s7_pointer cur_arg= s7_cadr (args); + s7_int cur; + bool is_cursor= + parse_cursor_arg (sc, cur_arg, "string-cursor-prev: second parameter must be integer or cursor", &cur); + if (is_cursor) { + s7_int off= cursor_to_offset (cur_arg); + if (off <= 0) return liii_string_cursor_value_error (sc, "string-cursor-prev: already at start cursor"); + return offset_to_cursor (sc, utf8_retreat (s, off)); + } + if (cur <= 0) return liii_string_cursor_value_error (sc, "string-cursor-prev: already at start cursor"); + return s7_make_integer (sc, cur - 1); +} + +// ---- string-cursor-forward / string-cursor-back ---- + +static s7_pointer +string_cursor_move (s7_scheme* sc, s7_pointer args, bool forward, const char* who) { + s7_pointer str= s7_car (args); + const char* s = check_string_arg (sc, str, who); + if (!s) return NULL; + s7_pointer cur_arg= s7_cadr (args); + s7_int cur, nchars; + bool is_cursor= parse_cursor_arg (sc, cur_arg, who, &cur); + s7_pointer n_arg = s7_cadr (s7_cdr (args)); + if (!s7_is_integer (n_arg)) return liii_string_cursor_type_error (sc, who, n_arg); + nchars= s7_integer (n_arg); + if (!forward) nchars= -nchars; + s7_int len= (s7_int) s7_string_length (str); + + if (!is_cursor) return s7_make_integer (sc, cur + nchars); + + s7_int off= cursor_to_offset (cur_arg); + if (nchars >= 0) { + for (s7_int i= 0; i < nchars; i++) { + if (off >= len) + return liii_string_cursor_value_error (sc, "string-cursor-forward: result would be invalid cursor"); + off= utf8_advance (s, off); + } + } + else { + for (s7_int i= 0; i < -nchars; i++) { + if (off <= 0) return liii_string_cursor_value_error (sc, "string-cursor-back: result would be invalid cursor"); + off= utf8_retreat (s, off); + } + } + return offset_to_cursor (sc, off); +} + +static s7_pointer +f_string_cursor_forward (s7_scheme* sc, s7_pointer args) { + return string_cursor_move (sc, args, true, "string-cursor-forward"); +} + +static s7_pointer +f_string_cursor_back (s7_scheme* sc, s7_pointer args) { + return string_cursor_move (sc, args, false, "string-cursor-back"); +} + +// ---- 游标比较 ---- +// 索引空间：非负整数直接比较；游标空间：字节偏移越大，负整数越小，方向取反。 +// 混用游标与索引是类型错误。 + +enum cursor_cmp { CMP_EQ, CMP_LT, CMP_GT, CMP_LE, CMP_GE }; + +static s7_pointer +string_cursor_compare (s7_scheme* sc, s7_pointer args, cursor_cmp op, const char* who) { + s7_pointer a= s7_car (args), b= s7_cadr (args); + s7_int ia, ib; + bool ca= parse_cursor_arg (sc, a, who, &ia); + bool cb= parse_cursor_arg (sc, b, who, &ib); + if (ca != cb) return liii_string_cursor_type_error (sc, "string-cursor compare: cannot mix cursor and index", b); + + s7_int x, y; + if (ca) { + x= -ia; + y= -ib; + } // 取反后恢复字节偏移的升序 + else { + x= ia; + y= ib; + } + + bool result; + switch (op) { + case CMP_EQ: + result= (x == y); + break; + case CMP_LT: + result= (x < y); + break; + case CMP_GT: + result= (x > y); + break; + case CMP_LE: + result= (x <= y); + break; + default: + result= (x >= y); + break; + } + return s7_make_boolean (sc, result); +} + +static s7_pointer +f_string_cursor_eq (s7_scheme* sc, s7_pointer args) { + return string_cursor_compare (sc, args, CMP_EQ, "string-cursor=?"); +} +static s7_pointer +f_string_cursor_lt (s7_scheme* sc, s7_pointer args) { + return string_cursor_compare (sc, args, CMP_LT, "string-cursor?"); +} +static s7_pointer +f_string_cursor_le (s7_scheme* sc, s7_pointer args) { + return string_cursor_compare (sc, args, CMP_LE, "string-cursor<=?"); +} +static s7_pointer +f_string_cursor_ge (s7_scheme* sc, s7_pointer args) { + return string_cursor_compare (sc, args, CMP_GE, "string-cursor>=?"); +} + +// ---- string-cursor-diff ---- + +static s7_pointer +f_string_cursor_diff (s7_scheme* sc, s7_pointer args) { + s7_pointer str= s7_car (args); + const char* s = check_string_arg (sc, str, "string-cursor-diff: first parameter must be string"); + if (!s) return NULL; + s7_pointer a= s7_cadr (args), b= s7_caddr (args); + s7_int ia, ib; + bool ca= parse_cursor_arg (sc, a, "string-cursor-diff: start must be integer or cursor", &ia); + bool cb= parse_cursor_arg (sc, b, "string-cursor-diff: end must be integer or cursor", &ib); + if (ca != cb) return liii_string_cursor_type_error (sc, "string-cursor-diff: cannot mix cursor and index", b); + + if (!ca) return s7_make_integer (sc, ib - ia); + + s7_int off1= cursor_to_offset (a), off2= cursor_to_offset (b); + s7_int count= 0; + while (off1 < off2) { + off1= utf8_advance (s, off1); + count++; + } + return s7_make_integer (sc, count); +} + +// ---- string-cursor->index / string-index->cursor ---- + +static s7_pointer +f_string_cursor_to_index (s7_scheme* sc, s7_pointer args) { + s7_pointer str= s7_car (args); + const char* s = check_string_arg (sc, str, "string-cursor->index: first parameter must be string"); + if (!s) return NULL; + s7_pointer cur_arg= s7_cadr (args); + s7_int cur; + bool is_cursor= + parse_cursor_arg (sc, cur_arg, "string-cursor->index: second parameter must be integer or cursor", &cur); + if (!is_cursor) return s7_make_integer (sc, cur); + + s7_int off= cursor_to_offset (cur_arg); + s7_int len= (s7_int) s7_string_length (str); + if (off > len) return liii_string_cursor_value_error (sc, "string-cursor->index: cursor out of range"); + s7_int count= 0; + while (off > 0) { + off= utf8_retreat (s, off); + count++; + } + return s7_make_integer (sc, count); +} + +static s7_pointer +f_string_index_to_cursor (s7_scheme* sc, s7_pointer args) { + s7_pointer str= s7_car (args); + const char* s = check_string_arg (sc, str, "string-index->cursor: first parameter must be string"); + if (!s) return NULL; + s7_pointer idx_arg= s7_cadr (args); + s7_int idx; + bool is_cursor= + parse_cursor_arg (sc, idx_arg, "string-index->cursor: second parameter must be integer or cursor", &idx); + if (is_cursor) return idx_arg; + + if (idx < 0) return liii_string_cursor_value_error (sc, "string-index->cursor: index out of range"); + s7_int off= 0, len= (s7_int) s7_string_length (str); + for (s7_int i= 0; i < idx; i++) { + if (off >= len) return liii_string_cursor_value_error (sc, "string-index->cursor: index out of range"); + off= utf8_advance (s, off); + } + return offset_to_cursor (sc, off); +} + +// ---- string-ref/cursor ---- + +static s7_pointer +f_string_ref_cursor (s7_scheme* sc, s7_pointer args) { + s7_pointer str= s7_car (args); + const char* s = check_string_arg (sc, str, "string-ref/cursor: first parameter must be string"); + if (!s) return NULL; + s7_pointer cur_arg= s7_cadr (args); + s7_int cur; + bool is_cursor= parse_cursor_arg (sc, cur_arg, "string-ref/cursor: second parameter must be integer or cursor", &cur); + if (!is_cursor && cur < 0) + return liii_string_cursor_value_error (sc, "string-ref/cursor: cursor at or past end of string"); + + s7_int len= (s7_int) s7_string_length (str); + s7_int off; + if (is_cursor) { + off= cursor_to_offset (cur_arg); + if (off >= len) return liii_string_cursor_value_error (sc, "string-ref/cursor: cursor at or past end of string"); + } + else { + off= 0; + for (s7_int i= 0; i < cur; i++) { + if (off >= len) return liii_string_cursor_value_error (sc, "string-ref/cursor: cursor at or past end of string"); + off= utf8_advance (s, off); + } + if (off >= len) return liii_string_cursor_value_error (sc, "string-ref/cursor: cursor at or past end of string"); + } + + // 解码 UTF-8 码点 + uint32_t cp; + uint8_t b0= (uint8_t) s[off]; + s7_int n = utf8_seq_len (b0); + if (n == 1) cp= b0; + else if (n == 2) cp= ((b0 & 0x1F) << 6) | (s[off + 1] & 0x3F); + else if (n == 3) cp= ((b0 & 0x0F) << 12) | ((s[off + 1] & 0x3F) << 6) | (s[off + 2] & 0x3F); + else cp= ((b0 & 0x07) << 18) | ((s[off + 1] & 0x3F) << 12) | ((s[off + 2] & 0x3F) << 6) | (s[off + 3] & 0x3F); + return s7_make_character (sc, cp); +} + +// ---- substring/cursors ---- + +static s7_pointer +f_substring_cursors (s7_scheme* sc, s7_pointer args) { + s7_pointer str= s7_car (args); + const char* s = check_string_arg (sc, str, "substring/cursors: first parameter must be string"); + if (!s) return NULL; + s7_pointer a= s7_cadr (args), b= s7_caddr (args); + s7_int ia, ib; + bool ca= parse_cursor_arg (sc, a, "substring/cursors: start must be integer or cursor", &ia); + bool cb= parse_cursor_arg (sc, b, "substring/cursors: end must be integer or cursor", &ib); + if (ca != cb) return liii_string_cursor_type_error (sc, "substring/cursors: cannot mix cursor and index", b); + + s7_int len= (s7_int) s7_string_length (str); + s7_int byte_start, byte_end; + if (ca) { + byte_start= cursor_to_offset (a); + byte_end = cursor_to_offset (b); + } + else { + byte_end= 0; + for (s7_int i= 0; i < ib; i++) { + if (byte_end >= len) return liii_string_cursor_value_error (sc, "substring/cursors: end index out of range"); + byte_end= utf8_advance (s, byte_end); + } + byte_start= 0; + for (s7_int i= 0; i < ia; i++) + byte_start= utf8_advance (s, byte_start); + } + if (byte_start > byte_end || byte_end > len) + return liii_string_cursor_value_error (sc, "substring/cursors: end index out of range"); + + s7_pointer result= s7_make_string_with_length (sc, "", byte_end - byte_start); + memcpy ((char*) s7_string (result), s + byte_start, byte_end - byte_start); + return result; +} + +// ---- 注册 ---- + +void +glue_liii_string_cursor (s7_scheme* sc) { + s7_define_function (sc, "g_string-cursor-start", f_string_cursor_start, 1, 0, false, + "(g_string-cursor-start str) => start cursor"); + s7_define_function (sc, "g_string-cursor-end", f_string_cursor_end, 1, 0, false, + "(g_string-cursor-end str) => post-end cursor"); + s7_define_function (sc, "g_string-cursor-next", f_string_cursor_next, 2, 0, false, + "(g_string-cursor-next str cur) => next cursor"); + s7_define_function (sc, "g_string-cursor-prev", f_string_cursor_prev, 2, 0, false, + "(g_string-cursor-prev str cur) => previous cursor"); + s7_define_function (sc, "g_string-cursor-forward", f_string_cursor_forward, 3, 0, false, + "(g_string-cursor-forward str cur nchars) => cursor"); + s7_define_function (sc, "g_string-cursor-back", f_string_cursor_back, 3, 0, false, + "(g_string-cursor-back str cur nchars) => cursor"); + s7_define_function (sc, "g_string-cursor=?", f_string_cursor_eq, 2, 0, false, "(g_string-cursor=? c1 c2) => boolean"); + s7_define_function (sc, "g_string-cursor boolean"); + s7_define_function (sc, "g_string-cursor>?", f_string_cursor_gt, 2, 0, false, "(g_string-cursor>? c1 c2) => boolean"); + s7_define_function (sc, "g_string-cursor<=?", f_string_cursor_le, 2, 0, false, + "(g_string-cursor<=? c1 c2) => boolean"); + s7_define_function (sc, "g_string-cursor>=?", f_string_cursor_ge, 2, 0, false, + "(g_string-cursor>=? c1 c2) => boolean"); + s7_define_function (sc, "g_string-cursor-diff", f_string_cursor_diff, 3, 0, false, + "(g_string-cursor-diff str start end) => nchars"); + s7_define_function (sc, "g_string-cursor->index", f_string_cursor_to_index, 2, 0, false, + "(g_string-cursor->index str cur) => index"); + s7_define_function (sc, "g_string-index->cursor", f_string_index_to_cursor, 2, 0, false, + "(g_string-index->cursor str idx) => cursor"); + s7_define_function (sc, "g_string-ref/cursor", f_string_ref_cursor, 2, 0, false, + "(g_string-ref/cursor str cur) => char"); + s7_define_function (sc, "g_substring/cursors", f_substring_cursors, 3, 0, false, + "(g_substring/cursors str start end) => string"); +} + +} // namespace goldfish diff --git a/TeXmacs/plugins/goldfish/src/liii_subprocess.cpp b/TeXmacs/plugins/goldfish/src/liii_subprocess.cpp index 2a805d245a..595ffdb336 100644 --- a/TeXmacs/plugins/goldfish/src/liii_subprocess.cpp +++ b/TeXmacs/plugins/goldfish/src/liii_subprocess.cpp @@ -21,6 +21,10 @@ #include #include +#ifdef _WIN32 +#include +#endif + #if !defined(_MSC_VER) && !defined(__MINGW32__) && !defined(__EMSCRIPTEN__) #include #endif @@ -180,7 +184,15 @@ f_subprocess_run_values (s7_scheme* sc, s7_pointer args) { (stdout_mode == redirect_mode::tee || stdout_mode == redirect_mode::capture) || (stderr_to_stdout && stdout_mode != redirect_mode::file && stdout_mode != redirect_mode::discard); +#ifdef _WIN32 + HANDLE h_out_read= NULL, h_out_write= NULL; + HANDLE h_err_read= NULL, h_err_write= NULL; + HANDLE h_in_read= NULL, h_in_write= NULL; + SECURITY_ATTRIBUTES sa= {sizeof (SECURITY_ATTRIBUTES), NULL, TRUE}; +#else tb_pipe_file_ref_t out_pipe[2]= {tb_null}; +#endif + if (stdout_mode == redirect_mode::file) { attr.outtype = TB_PROCESS_REDIRECT_TYPE_FILEPATH; attr.out.path= stdout_path; @@ -196,13 +208,22 @@ f_subprocess_run_values (s7_scheme* sc, s7_pointer args) { attr.outmode= TB_FILE_MODE_RW | TB_FILE_MODE_CREAT | TB_FILE_MODE_TRUNC; } else if (need_stdout_pipe) { +#ifdef _WIN32 + CreatePipe (&h_out_read, &h_out_write, &sa, 0); + SetHandleInformation (h_out_read, HANDLE_FLAG_INHERIT, 0); + attr.outtype = TB_PROCESS_REDIRECT_TYPE_FILE; + attr.out.file= (tb_file_ref_t) h_out_write; +#else tb_size_t mode[2]= {TB_PIPE_MODE_RO, TB_PIPE_MODE_WO}; tb_pipe_file_init_pair (out_pipe, mode, 0); attr.outtype = TB_PROCESS_REDIRECT_TYPE_PIPE; attr.out.pipe= out_pipe[1]; +#endif } +#ifndef _WIN32 tb_pipe_file_ref_t err_pipe[2]= {tb_null}; +#endif if (stderr_mode == redirect_mode::file) { attr.errtype = TB_PROCESS_REDIRECT_TYPE_FILEPATH; attr.err.path= stderr_path; @@ -217,6 +238,18 @@ f_subprocess_run_values (s7_scheme* sc, s7_pointer args) { #endif attr.errmode= TB_FILE_MODE_RW | TB_FILE_MODE_CREAT | TB_FILE_MODE_TRUNC; } +#ifdef _WIN32 + else if (stderr_to_stdout && h_out_write) { + attr.errtype = TB_PROCESS_REDIRECT_TYPE_FILE; + attr.err.file= (tb_file_ref_t) h_out_write; + } + else if (stderr_mode == redirect_mode::tee || stderr_mode == redirect_mode::capture) { + CreatePipe (&h_err_read, &h_err_write, &sa, 0); + SetHandleInformation (h_err_read, HANDLE_FLAG_INHERIT, 0); + attr.errtype = TB_PROCESS_REDIRECT_TYPE_FILE; + attr.err.file= (tb_file_ref_t) h_err_write; + } +#else else if (stderr_to_stdout && out_pipe[1]) { attr.errtype = TB_PROCESS_REDIRECT_TYPE_PIPE; attr.err.pipe= out_pipe[1]; @@ -227,13 +260,36 @@ f_subprocess_run_values (s7_scheme* sc, s7_pointer args) { attr.errtype = TB_PROCESS_REDIRECT_TYPE_PIPE; attr.err.pipe= err_pipe[1]; } +#endif +#ifndef _WIN32 tb_pipe_file_ref_t in_pipe[2]= {tb_null}; +#endif if (stdin_path) { attr.intype = TB_PROCESS_REDIRECT_TYPE_FILEPATH; attr.in.path= stdin_path; attr.inmode = TB_FILE_MODE_RO; } +#ifdef _WIN32 + else if (stdin_null) { + CreatePipe (&h_in_read, &h_in_write, &sa, 0); + SetHandleInformation (h_in_write, HANDLE_FLAG_INHERIT, 0); + attr.intype = TB_PROCESS_REDIRECT_TYPE_FILE; + attr.in.file= (tb_file_ref_t) h_in_read; + CloseHandle (h_in_write); + h_in_write= NULL; + } + else if (input) { + CreatePipe (&h_in_read, &h_in_write, &sa, 0); + SetHandleInformation (h_in_write, HANDLE_FLAG_INHERIT, 0); + attr.intype = TB_PROCESS_REDIRECT_TYPE_FILE; + attr.in.file = (tb_file_ref_t) h_in_read; + DWORD written= 0; + WriteFile (h_in_write, input, (DWORD) input_len, &written, NULL); + CloseHandle (h_in_write); + h_in_write= NULL; + } +#else else if (stdin_null) { tb_size_t mode[2]= {TB_PIPE_MODE_RO, TB_PIPE_MODE_WO}; tb_pipe_file_init_pair (in_pipe, mode, 0); @@ -249,6 +305,7 @@ f_subprocess_run_values (s7_scheme* sc, s7_pointer args) { tb_pipe_file_write (in_pipe[1], (tb_byte_t*) input, input_len); tb_pipe_file_exit (in_pipe[1]); } +#endif tb_process_ref_t process= tb_null; if (s7_is_string (cmd_arg)) { @@ -282,8 +339,23 @@ f_subprocess_run_values (s7_scheme* sc, s7_pointer args) { } } +#ifdef _WIN32 + if (h_out_write) { + CloseHandle (h_out_write); + h_out_write= NULL; + } + if (h_err_write) { + CloseHandle (h_err_write); + h_err_write= NULL; + } + if (h_in_read) { + CloseHandle (h_in_read); + h_in_read= NULL; + } +#else if (out_pipe[1]) tb_pipe_file_exit (out_pipe[1]); if (err_pipe[1]) tb_pipe_file_exit (err_pipe[1]); +#endif string stdout_str; string stderr_str; @@ -298,6 +370,37 @@ f_subprocess_run_values (s7_scheme* sc, s7_pointer args) { status= -1; } +#ifdef _WIN32 + if (h_out_read) { + char buf[4096]; + DWORD n= 0; + while (ReadFile (h_out_read, buf, sizeof (buf) - 1, &n, NULL) && n > 0) { + buf[n]= '\0'; + stdout_str.append (buf, n); + if (stdout_mode == redirect_mode::tee) { + fwrite (buf, 1, n, stdout); + fflush (stdout); + } + } + CloseHandle (h_out_read); + h_out_read= NULL; + } + + if (h_err_read) { + char buf[4096]; + DWORD n= 0; + while (ReadFile (h_err_read, buf, sizeof (buf) - 1, &n, NULL) && n > 0) { + buf[n]= '\0'; + stderr_str.append (buf, n); + if (stderr_mode == redirect_mode::tee) { + fwrite (buf, 1, n, stderr); + fflush (stderr); + } + } + CloseHandle (h_err_read); + h_err_read= NULL; + } +#else if (out_pipe[0]) { char buf[4096]; tb_long_t n; @@ -325,9 +428,14 @@ f_subprocess_run_values (s7_scheme* sc, s7_pointer args) { } tb_pipe_file_exit (err_pipe[0]); } +#endif tb_process_exit (process); } +#ifdef _WIN32 + if (h_out_read) CloseHandle (h_out_read); + if (h_err_read) CloseHandle (h_err_read); +#endif s7_pointer out_s7 = s7_make_string (sc, stdout_str.c_str ()); s7_pointer err_s7 = s7_make_string (sc, stderr_str.c_str ()); diff --git a/TeXmacs/plugins/goldfish/src/s7.c b/TeXmacs/plugins/goldfish/src/s7.c index c70c5cd2af..ac46741a23 100644 --- a/TeXmacs/plugins/goldfish/src/s7.c +++ b/TeXmacs/plugins/goldfish/src/s7.c @@ -6,9 +6,8 @@ * Bill Schottstaedt, bil@ccrma.stanford.edu * * Mike Scholz provided the FreeBSD support (complex trig funcs, etc) - * Rick Taube, Andrew Burnson, Donny Ward, Greg Santucci, and Christos Vagias - * provided the MS Visual C++ support Kjetil Matheussen provided the mingw - * support + * Rick Taube, Andrew Burnson, Donny Ward, Greg Santucci, and Christos Vagias provided the MS Visual C++ support + * Kjetil Matheussen provided the mingw support * * Documentation is in s7.h, s7.html, s7-ffi.html, and s7-scm.html. * s7test.scm is a regression test. @@ -56,34 +55,29 @@ * 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, - * scheme "?" corresponds to C "is_", scheme "->" to C "_to_", - * *_1 are ancillary functions, big_* refer to gmp, *_nr means no return, - * Inline means always-inline. In variables, i, j, and k are ints, p is a pair - * (usually), e is a let (environment), x and y are numbers (usually), o is - * opt_info*. + * naming conventions: s7_* usually are C accessible (s7.h), g_* are scheme accessible, + * H_* are documentation strings, Q_* are procedure signatures, scheme "?" corresponds to C "is_", scheme "->" to C "_to_", + * *_1 are ancillary functions, big_* refer to gmp, *_nr means no return, Inline means always-inline. + * In variables, i, j, and k are ints, p is a pair (usually), e is a let (environment), x and y are numbers (usually), o is opt_info*. * * ---------------- compile time switches ---------------- */ #if defined __has_include -#if __has_include("mus-config.h") -#include "mus-config.h" -#endif +# if __has_include ("mus-config.h") +# include "mus-config.h" +# endif #else -#include "mus-config.h" +# include "mus-config.h" #endif /* - * 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). + * 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++, + * 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 @@ -95,438 +89,408 @@ * * In Windows and tcc 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 + * 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). + * 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. * - * and we use these predefined macros: __cplusplus, _MSC_VER, __GNUC__, - * __clang__, __ANDROID__ + * 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. if you want this file to compile into a - * stand-alone interpreter, define WITH_MAIN, to use nrepl also define - * WITH_NOTCURSES + * if WITH_SYSTEM_EXTRAS is 1 (default is 1 unless _MSC_VER), various OS and file related functions are included. + * if you want this file to compile into a stand-alone interpreter, define WITH_MAIN, + * to use nrepl also define WITH_NOTCURSES * * -O3 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 * -fno-math-errno -fno-signed-zeros are slower - * I also tried -fno-signaling-nans -fno-trapping-math -fassociative-math, but - * at least one of them is much slower this code doesn't compile anymore in - * gcc 4.3 + * I also tried -fno-signaling-nans -fno-trapping-math -fassociative-math, but at least one of them is much slower + * this code doesn't compile anymore in gcc 4.3 */ -#if (defined(__GNUC__) || defined(__clang__) || \ - defined(__TINYC__)) /* s7 uses PRId64 so (for example) g++ 4.4 is too \ - old. clang defines __GNUC__ */ -#define WITH_GCC 1 +#if (defined(__GNUC__) || defined(__clang__) || defined(__TINYC__)) /* s7 uses PRId64 so (for example) g++ 4.4 is too old. clang defines __GNUC__ */ + #define WITH_GCC 1 #else -#define WITH_GCC 0 + #define WITH_GCC 0 #endif -#if (defined(__clang__) && \ - __cplusplus) /* pointless -- this is a moving target */ -#define WITH_CLANG_PP 1 +#if (defined(__clang__) && __cplusplus) /* pointless -- this is a moving target */ + #define WITH_CLANG_PP 1 #else -#define WITH_CLANG_PP 0 + #define WITH_CLANG_PP 0 #endif + /* ---------------- initial sizes ---------------- */ #ifndef INITIAL_HEAP_SIZE -#define INITIAL_HEAP_SIZE 64000 /* 29-Jul-21 -- seems faster */ + #ifdef __EMSCRIPTEN__ + #define INITIAL_HEAP_SIZE 64000 /* wasm 内存受限，保持小堆 */ + #else + #define INITIAL_HEAP_SIZE 256000 /* [0137] 更大的初始堆减少 GC 频率，read 密集负载约快 12% */ + #endif #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 hardware cache size probably matters more). The - * heap size must be a multiple of 32. Each object takes 48 bytes. s7 is fine - * with the initial heap size set to 800. +/* 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 hardware cache size probably matters more). + * The heap size must be a multiple of 32. Each object takes 48 bytes. s7 is fine with the initial heap size set to 800. */ #ifndef SYMBOL_TABLE_SIZE -#define SYMBOL_TABLE_SIZE 32749 + #define SYMBOL_TABLE_SIZE 32749 #endif -/* names are hashed into the symbol table (a vector) and collisions are chained - * as lists. 4129: tlet +530 [symbol_p_pp], thash +565 [make_symbol], max-bin: - * (3 5), tlet: (258 3) 16381: tlet +80 [symbol_p_pp], thash +80 - * [make_symbol], max-bin: (2 25), tlet: (85 1) 24001: tlet +33 [symbol_p_pp], - * thash +50 [make_symbol], max-bin: (2 19), tlet: (56 7) 32749: (677 symbols - * if exit.scm) max-bin: (2 13), tlet: (40 4) 72101: - * tlet -40 [symbol_p_pp], thash -40 [make_symbol], max-bin: (2 11), tlet: (30 - * 5) +/* names are hashed into the symbol table (a vector) and collisions are chained as lists. + * 4129: tlet +530 [symbol_p_pp], thash +565 [make_symbol], max-bin: (3 5), tlet: (258 3) + * 16381: tlet +80 [symbol_p_pp], thash +80 [make_symbol], max-bin: (2 25), tlet: (85 1) + * 24001: tlet +33 [symbol_p_pp], thash +50 [make_symbol], max-bin: (2 19), tlet: (56 7) + * 32749: (677 symbols if exit.scm) max-bin: (2 13), tlet: (40 4) + * 72101: tlet -40 [symbol_p_pp], thash -40 [make_symbol], max-bin: (2 11), tlet: (30 5) */ #ifndef INITIAL_STACK_SIZE -#define INITIAL_STACK_SIZE 4096 /* was 2048 17-Mar-21 */ + #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 */ +/* 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 \ - 256 /* was INITIAL_STACK_SIZE/2 which seems excessive */ +#define STACK_RESIZE_TRIGGER 256 /* was INITIAL_STACK_SIZE/2 which seems excessive */ #ifndef GC_TEMPS_SIZE -#define GC_TEMPS_SIZE 256 + #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. +/* 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. */ #ifndef INITIAL_PROTECTED_OBJECTS_SIZE -#define INITIAL_PROTECTED_OBJECTS_SIZE 16 + #define INITIAL_PROTECTED_OBJECTS_SIZE 16 #endif -/* a vector of objects that are (semi-permanently) protected from the GC, grows - * as needed */ +/* a vector of objects that are (semi-permanently) protected from the GC, grows as needed */ + /* ---------------- scheme choices ---------------- */ + #ifndef WITH_PURE_S7 -#define WITH_PURE_S7 0 + #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. - */ + #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_R7RS -#define WITH_R7RS !WITH_PURE_S7 -/* this also requires (set! (*s7* 'scheme-version) 'r7rs) */ + #define WITH_R7RS !WITH_PURE_S7 + /* this also requires (set! (*s7* 'scheme-version) 'r7rs) */ #endif #ifndef WITH_EXTRA_EXPONENT_MARKERS -#define WITH_EXTRA_EXPONENT_MARKERS 0 + #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") */ +/* 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 */ + #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" */ + #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 + #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) */ + #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 */ + #define DEFAULT_HISTORY_SIZE 8 + /* this is the default length of the eval history buffer */ #endif #if WITH_HISTORY -#define MAX_HISTORY_SIZE 1048576 + #define MAX_HISTORY_SIZE 1048576 #endif #ifndef DEFAULT_PRINT_LENGTH -#define DEFAULT_PRINT_LENGTH \ - 40 /* (*s7* 'print-length) initial value, was 32 but that's too small \ - 26-May-24 */ + #define DEFAULT_PRINT_LENGTH 40 /* (*s7* 'print-length) initial value, was 32 but that's too small 26-May-24 */ #endif #ifndef WITH_NUMBER_SEPARATOR -#define WITH_NUMBER_SEPARATOR 0 + #define WITH_NUMBER_SEPARATOR 0 #endif /* in case mus-config.h forgets these */ #ifdef _MSC_VER -#ifndef HAVE_COMPLEX_NUMBERS -#define HAVE_COMPLEX_NUMBERS 0 -/* Da Shen adds that you'll need the compiler flag /fp:precise if you're using - * github actions */ -#endif -#ifndef HAVE_COMPLEX_TRIG -#define HAVE_COMPLEX_TRIG 0 -#endif -#else -#ifndef HAVE_COMPLEX_NUMBERS -#if __TINYC__ || (__clang__ && __cplusplus) /* clang++ is hopeless */ -#define HAVE_COMPLEX_NUMBERS 0 -#else -#define HAVE_COMPLEX_NUMBERS 1 -#endif -#endif -#if __cplusplus || __TINYC__ -#ifndef HAVE_COMPLEX_TRIG -#define HAVE_COMPLEX_TRIG 0 -#endif + #ifndef HAVE_COMPLEX_NUMBERS + #define HAVE_COMPLEX_NUMBERS 0 + /* Da Shen adds that you'll need the compiler flag /fp:precise if you're using github actions */ + #endif + #ifndef HAVE_COMPLEX_TRIG + #define HAVE_COMPLEX_TRIG 0 + #endif #else -#ifndef HAVE_COMPLEX_TRIG -#define HAVE_COMPLEX_TRIG 1 -#endif -#endif + #ifndef HAVE_COMPLEX_NUMBERS + #if __TINYC__ || (__clang__ && __cplusplus) /* clang++ is hopeless */ + #define HAVE_COMPLEX_NUMBERS 0 + #else + #define HAVE_COMPLEX_NUMBERS 1 + #endif + #endif + #if __cplusplus || __TINYC__ + #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 */ + #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) */ + #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 + #define S7_DEBUGGING 0 #endif #undef DEBUGGING -#define DEBUGGING typo ! -#define HAVE_GMP typo ! +#define DEBUGGING typo! +#define HAVE_GMP typo! #define SHOW_EVAL_OPS 0 #ifndef _GNU_SOURCE -#define _GNU_SOURCE /* for qsort_r, grumble... */ + #define _GNU_SOURCE /* for qsort_r, grumble... */ #endif #ifndef _MSC_VER -#include -#include -#include -#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 */ + /* 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 + #define Inline inline __attribute__((__always_inline__)) #else -#define Inline inline -#endif + #ifdef _MSC_VER + #define Inline __forceinline + #else + #define Inline inline + #endif #endif #ifndef WITH_VECTORIZE -#define WITH_VECTORIZE 1 + #define WITH_VECTORIZE 1 #endif -#if (WITH_VECTORIZE) && \ - (defined(__GNUC__) && (__GNUC__ >= 5)) /* is this included -in -O2 now? */ -#define Vectorized __attribute__ ((optimize ("tree-vectorize"))) +#if (WITH_VECTORIZE) && (defined(__GNUC__) && (__GNUC__ >= 5)) /* is this included -in -O2 now? */ + #define Vectorized __attribute__((optimize("tree-vectorize"))) #else -#define Vectorized + #define Vectorized #endif #if WITH_GCC -#define Sentinel __attribute__ ((sentinel)) + #define Sentinel __attribute__((sentinel)) #else -#define Sentinel + #define Sentinel #endif #ifdef _MSC_VER -#define no_return _Noreturn /* deprecated in C23 */ + #define no_return _Noreturn /* deprecated in C23 */ #else -#define no_return __attribute__ ((noreturn)) -/* this is ok in gcc/g++/clang and tcc; clang++ complains about "noreturn", - * hence "no_return" */ -/* pure attribute is rarely applicable here, and does not seem to be helpful - * (maybe safe_strlen) */ + #define no_return __attribute__((noreturn)) + /* this is ok in gcc/g++/clang and tcc; clang++ complains about "noreturn", hence "no_return" */ + /* pure attribute is rarely applicable here, and does not seem to be helpful (maybe safe_strlen) */ #endif #ifndef S7_ALIGNED -#define S7_ALIGNED 0 -/* memclr, local_memset, local_strncmp */ + #define S7_ALIGNED 0 + /* memclr, local_memset, local_strncmp */ #endif -#include -#include -#include -#include -#include -#include -#include -#include #include -#include +#include +#include #include +#include #include #include +#include +#include +#include +#include +#include +#include #ifdef _MSC_VER -#define MS_WINDOWS 1 + #define MS_WINDOWS 1 #else -#define MS_WINDOWS 0 + #define MS_WINDOWS 0 #endif #if defined(_MSC_VER) || defined(__MINGW32__) -#define Jmp_Buf jmp_buf -#define SetJmp(A, B) setjmp (A) -#define LongJmp(A, B) longjmp (A, B) + #define Jmp_Buf jmp_buf + #define SetJmp(A, B) setjmp(A) + #define LongJmp(A, B) longjmp(A, B) #else -#define Jmp_Buf sigjmp_buf -#define SetJmp(A, B) sigsetjmp (A, B) -#define LongJmp(A, B) siglongjmp (A, B) -/* we need sigsetjmp, not setjmp for nrepl's interrupt (something to do with - * signal masks??) unfortunately sigsetjmp is slower than setjmp. In one case, - * the sigsetjmp version runs in 24 seconds, but the setjmp version takes 10 - * seconds, yet callgrind says there is almost no difference? - */ + #define Jmp_Buf sigjmp_buf + #define SetJmp(A, B) sigsetjmp(A, B) + #define LongJmp(A, B) siglongjmp(A, B) + /* we need sigsetjmp, not setjmp for nrepl's interrupt (something to do with signal masks??) + * unfortunately sigsetjmp is slower than setjmp. In one case, the sigsetjmp version runs + * in 24 seconds, but the setjmp version takes 10 seconds, yet callgrind says there is almost no difference? + */ #endif #if !MS_WINDOWS -#include + #include #endif #if __cplusplus -#include + #include #else -#include + #include #endif #include "s7.h" -#include "s7_ctables.h" -#include "s7_dtoa.h" #include "s7_internal_helpers.h" +#include "s7_scheme_format.h" +#include "s7_scheme_base.h" +#include "s7_scheme_inexact.h" +#include "s7_scheme_complex.h" +#include "s7_scheme_char.h" +#include "s7_scheme_write.h" +#include "s7_scheme_read.h" +#include "s7_scheme_symbol.h" +#include "s7_scheme_predicate.h" #include "s7_liii_bitwise.h" +#include "s7_liii_string.h" #include "s7_liii_hash_table.h" #include "s7_liii_list.h" -#include "s7_liii_string.h" #include "s7_liii_vector.h" +#include "s7_scheme_cxr.h" #include "s7_module.h" +#include "s7_dtoa.h" +#include "s7_scheme_let.h" #include "s7_op_names.h" -#include "s7_scheme_base.h" -#include "s7_scheme_char.h" -#include "s7_scheme_complex.h" -#include "s7_scheme_format.h" -#include "s7_scheme_inexact.h" -#include "s7_scheme_predicate.h" -#include "s7_scheme_symbol.h" -#include "s7_scheme_write.h" +#include "s7_ctables.h" /* there is also apparently __STDC_NO_COMPLEX__ */ #if WITH_CLANG_PP -#define CMPLX(x, y) __builtin_complex ((double) (x), (double) (y)) + #define CMPLX(x, y) __builtin_complex ((double) (x), (double) (y)) #endif #if HAVE_COMPLEX_NUMBERS -#if __cplusplus -#include -using namespace std; /* the code has to work in C as well as C++, so we can't - scatter std:: all over the place */ -/* moved the typedef to s7.h. */ -#else -#include -/* typedef double complex s7_complex; */ -#if defined(__sun) && defined(__SVR4) -#undef _Complex_I -#define _Complex_I 1.0i -#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) * (s7_complex) _Complex_I)) -#endif -#endif + #if __cplusplus + #include + using namespace std; /* the code has to work in C as well as C++, so we can't scatter std:: all over the place */ + /* moved the typedef to s7.h. */ + #else + #include + /* typedef double complex s7_complex; */ + #if defined(__sun) && defined(__SVR4) + #undef _Complex_I + #define _Complex_I 1.0i + #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) * (s7_complex)_Complex_I)) + #endif + #endif #endif #if WITH_CLANG_PP -#define s7_complex_i ((double) 1.0i) + #define s7_complex_i ((double)1.0i) #else #if (defined(__GNUC__)) -#define s7_complex_i 1.0i + #define s7_complex_i 1.0i #else -#define s7_complex_i \ - (s7_complex) _Complex_I /* a float, but we want a double \ - */ + #define s7_complex_i (s7_complex)_Complex_I /* a float, but we want a double */ #endif #endif #ifndef M_PI -#define M_PI 3.1415926535897932384626433832795029L + #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 + #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 /* deprecated in C23? */ -#define NAN (INFINITY / INFINITY) /* apparently ieee754 suggests 0.0/0.0 */ +#ifndef NAN /* deprecated in C23? */ + #define NAN (INFINITY / INFINITY) /* apparently ieee754 suggests 0.0/0.0 */ #endif -#if ((!__NetBSD__) && \ - ((_MSC_VER) || (!defined(__STC__)) || \ - (defined(__STDC_VERSION__) && (__STDC_VERSION__ < 199901L)))) -#define __func__ __FUNCTION__ +#if ((!__NetBSD__) && ((_MSC_VER) || (!defined(__STC__)) || (defined(__STDC_VERSION__) && (__STDC_VERSION__ < 199901L)))) + #define __func__ __FUNCTION__ #endif #ifndef POINTER_32 /* for testing */ -#if (((defined(SIZEOF_VOID_P)) && (SIZEOF_VOID_P == 4)) || \ - ((defined(__SIZEOF_POINTER__)) && (__SIZEOF_POINTER__ == 4)) || \ - (!defined(__LP64__))) -#define POINTER_32 true +#if (((defined(SIZEOF_VOID_P)) && (SIZEOF_VOID_P == 4)) || ((defined(__SIZEOF_POINTER__)) && (__SIZEOF_POINTER__ == 4)) || (!defined(__LP64__))) + #define POINTER_32 true #else -#define POINTER_32 false + #define POINTER_32 false #endif #endif #define WRITE_REAL_PRECISION 16 #ifdef __TINYC__ -typedef double long_double; /* (- .1 1) -> 0.9! and others similarly: (- double - long_double) is broken */ + typedef double long_double; /* (- .1 1) -> 0.9! and others similarly: (- double long_double) is broken */ #else -typedef long double long_double; + typedef long double long_double; #endif typedef uint64_t s7_uint; @@ -534,137 +498,70 @@ typedef uint64_t s7_uint; /* #define lu64 PRIu64 */ #define p64 PRIdPTR -#define MAX_FLOAT_FORMAT_PRECISION \ - 128 /* does this make any sense? 53 bits in mantissa: 16 digits, are the \ - extra digits just garbage? */ +#define MAX_FLOAT_FORMAT_PRECISION 128 /* does this make any sense? 53 bits in mantissa: 16 digits, are the extra digits just garbage? */ /* 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_COMPLEX_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_RST_NO_REQ_FUNCTION, - NUM_TYPES -}; -/* T_UNUSED, T_STACK, T_SLOT, T_DYNAMIC_WIND, T_CATCH, and T_COUNTER are - * internal */ - -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", "complex_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_rst_no_req_function", -}; - -/* 1:pair, 2:nil, 3:unused, 4:undefined, 5:unspecified, 6:eof, 7:boolean, - 8:character, 9:syntax, 10:symbol, 11:integer, 12:ratio, 13:real, 14:complex, - 15:big_integer, 16:big_ratio, 17:big_real, 18:big_complex, 19:string, - 20:c_object, 21:vector, 22:int_vector, 23:float_vector, 24:byte_vector, - 25:complex_vector, 26:catch, 27:dynamic_wind, 28:hash_table, 29:let, - 30:iterator, 31:stack, 32:counter, 33:slot, 34:c_pointer, 35:output_port, - 36:input_port, 37:random_state, 38:continuation, 39:goto, 40:closure, - 41:closure_star, 42:macro, 43:macro_star, 44:bacro, 45:bacro_star, +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_COMPLEX_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_RST_NO_REQ_FUNCTION, + NUM_TYPES}; +/* T_UNUSED, T_STACK, T_SLOT, T_DYNAMIC_WIND, T_CATCH, and T_COUNTER are internal */ + +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", "complex_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_rst_no_req_function", + }; + +/* 1:pair, 2:nil, 3:unused, 4:undefined, 5:unspecified, 6:eof, 7:boolean, 8:character, 9:syntax, 10:symbol, + 11:integer, 12:ratio, 13:real, 14:complex, 15:big_integer, 16:big_ratio, 17:big_real, 18:big_complex, + 19:string, 20:c_object, 21:vector, 22:int_vector, 23:float_vector, 24:byte_vector, 25:complex_vector, + 26:catch, 27:dynamic_wind, 28:hash_table, 29:let, 30:iterator, + 31:stack, 32:counter, 33:slot, 34:c_pointer, 35:output_port, 36:input_port, 37:random_state, 38:continuation, 39:goto, + 40:closure, 41:closure_star, 42:macro, 43:macro_star, 44:bacro, 45:bacro_star, 46:c_macro, 47:c_function_star, 48:c_function, 49:c_rst_no_req_function, 50:num_types */ typedef struct block_t { union { - void* data; + void *data; s7_pointer d_ptr; - s7_int* i_ptr; - s7_int tag; + s7_int *i_ptr; + s7_int tag; } dx; int32_t index; union { - bool needs_free; + bool needs_free; uint32_t iter_or_size; } ln; union { - s7_int size; + s7_int size; s7_uint usize; } sz; union { - struct block_t* next; - char* documentation; - s7_pointer ksym; - s7_uint nx_uint; - s7_int* ix_ptr; + struct block_t *next; + char *documentation; + s7_pointer ksym; + s7_uint nx_uint; + s7_int *ix_ptr; struct { uint32_t i1, i2; } ix; } nx; union { s7_pointer ex_ptr; - void* ex_info; - s7_int ckey; + void *ex_info; + s7_int ckey; } ex; } block_t; @@ -672,4251 +569,3241 @@ typedef struct block_t { #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->sz.size -#define block_set_size(p, Size) p->sz.size= Size -#define block_next(p) p->nx.next -#define block_info(p) p->ex.ex_info - -typedef block_t hash_entry_t; /* I think this means we waste 8 bytes per entry - but can use the mallocate functions */ -#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) p->sz.usize /* block_size(p) */ -#define hash_entry_set_raw_hash(p, Hash) \ - p->sz.usize= Hash /* block_set_size(p, Hash) */ +#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->sz.size +#define block_set_size(p, Size) p->sz.size = Size +#define block_next(p) p->nx.next +#define block_info(p) p->ex.ex_info + +typedef block_t hash_entry_t; /* I think this means we waste 8 bytes per entry but can use the mallocate functions */ +#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) p->sz.usize /* block_size(p) */ +#define hash_entry_set_raw_hash(p, Hash) p->sz.usize = Hash /* block_set_size(p, Hash) */ typedef block_t vdims_t; -#define vdims_rank(p) p->sz.size +#define vdims_rank(p) p->sz.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_complex_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, if typedef'd becomes uint32_t (but we want -1) */ - -typedef enum { file_port, string_port, function_port } port_type_t; +#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_complex_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, if typedef'd becomes uint32_t (but we want -1) */ + +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 port); /* internal get-next-name reader */ - s7_pointer (*read_sharp) ( - s7_scheme* sc, - s7_pointer port); /* internal get-next-sharp-constant reader */ - s7_pointer (*read_line) ( - s7_scheme* sc, s7_pointer port, - bool eol_case); /* function to read a string up to \n */ - void (*displayer) (s7_scheme* sc, const char* s, - s7_pointer port); /* (display s pt) -- port_write_string - without strlen?? */ - void (*close_port) (s7_scheme* sc, - s7_pointer port); /* close-in|output-port */ + 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 port); /* internal get-next-name reader */ + s7_pointer (*read_sharp)(s7_scheme *sc, s7_pointer port); /* internal get-next-sharp-constant reader */ + s7_pointer (*read_line)(s7_scheme *sc, s7_pointer port, bool eol_case);/* function to read a string up to \n */ + void (*displayer)(s7_scheme *sc, const char *s, s7_pointer port); /* (display s pt) -- port_write_string without strlen?? */ + void (*close_port)(s7_scheme *sc, s7_pointer port); /* close-in|output-port */ } port_functions_t; typedef struct { - bool needs_free, is_closed; + 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 or function port - function */ - 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); + 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 or function port function */ + 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_ip, - o_d_pd, - o_d_7p, - 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 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_ip, o_d_pd, o_d_7p, 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_func_t typ; + void *func; + struct opt_funcs_t *next; } opt_funcs_t; typedef struct { - const char* name; - int32_t name_length; - uint32_t class_id; /* can't use "class" -- confuses g++ */ - const char* doc; - opt_funcs_t* opt_data; /* vunion-functions (see below) */ - s7_pointer generic_ff, setter, signature, pars, let; - s7_pointer (*chooser) (s7_scheme* sc, s7_pointer f, int32_t args, - s7_pointer expr); - /* arg_defaults|names call_args only T_C_FUNCTION_STAR -- call args for GC - * protection */ + const char *name; + int32_t name_length; + uint32_t class_id; /* can't use "class" -- confuses g++ */ + const char *doc; + opt_funcs_t *opt_data; /* vunion-functions (see below) */ + s7_pointer generic_ff, setter, signature, pars, let; + s7_pointer (*chooser)(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr); + /* arg_defaults|names call_args only T_C_FUNCTION_STAR -- call args for GC protection */ union { - s7_pointer* arg_defaults; - s7_pointer bool_setter; + s7_pointer *arg_defaults; + s7_pointer bool_setter; } dam; union { - s7_pointer* arg_names; - s7_pointer c_sym; + s7_pointer *arg_names; + s7_pointer c_sym; } sam; union { s7_pointer call_args; - void (*marker) (s7_pointer p, s7_int len); + void (*marker)(s7_pointer p, s7_int len); } cam; } c_proc_t; /* 104 = sizeof(c_proc_t) */ + typedef struct { - s7_int type, outer_type; + s7_int type, outer_type; s7_pointer scheme_name, getter, setter; - void (*mark) (void* val); - void (*free) (void* value); - bool (*eql) (void* val1, void* val2); + void (*mark)(void *val); + void (*free)(void *value); + bool (*eql)(void *val1, void *val2); #if !DISABLE_DEPRECATED - char* (*print) (s7_scheme* sc, void* value); + 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); + 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_uint (*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 */ + +typedef s7_uint (*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_t) (s7_scheme* sc); -typedef s7_pointer (*s7_p_ppi_t) (s7_scheme* sc, s7_pointer p1, s7_pointer p2, - s7_int i1); -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_7p_t) (s7_scheme* sc, s7_pointer p1); -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_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_t)(s7_scheme *sc); +typedef s7_pointer (*s7_p_ppi_t)(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_int i1); +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_7p_t)(s7_scheme *sc, s7_pointer p1); +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 struct opt_info opt_info; typedef union { - s7_int i; - s7_double x; - s7_pointer p; - void* gen; - opt_info* o1; + s7_int i; + s7_double x; + s7_pointer p; + void *gen; + 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_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_double (*d_7p_f) (s7_scheme* sc, 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); + 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_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_double (*d_7p_f)(s7_scheme *sc, 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; /* libgsl 15 d_i */ #define num_vunions 15 struct opt_info { - vunion v[num_vunions]; - s7_scheme* sc; + vunion v[num_vunions]; + s7_scheme *sc; }; #define q_temp(o) o->v[num_vunions - 1] + typedef intptr_t opcode_t; typedef struct unlet_entry_t { - s7_pointer symbol; - struct unlet_entry_t* next; + s7_pointer symbol; + struct unlet_entry_t *next; } unlet_entry_t; -/* -------------------------------- cell structure - * -------------------------------- */ + +/* -------------------------------- cell structure -------------------------------- */ typedef struct s7_cell { union { - s7_uint u64_type; /* type info */ - s7_int s64_type; + s7_uint u64_type; /* type info */ + s7_int s64_type; uint8_t type_field; struct { - uint16_t low_bits; /* 8 bits for type (type_field above, pair?/string? - etc, 6 bits in use), 8 flag bits */ - uint16_t mid_bits; /* 16 more flag bits */ - uint16_t opt_bits; /* 16 bits for opcode_t (eval choice), 10 in use) */ - uint16_t high_bits; /* 16 more flag bits */ + uint16_t low_bits; /* 8 bits for type (type_field above, pair?/string? etc, 6 bits in use), 8 flag bits */ + uint16_t mid_bits; /* 16 more flag bits */ + uint16_t opt_bits; /* 16 bits for opcode_t (eval choice), 10 in use) */ + uint16_t high_bits; /* 16 more flag bits */ } bits; } tf; union { union { - s7_int integer_value; /* integers */ - s7_double real_value; /* floats */ + s7_int integer_value; /* integers */ + s7_double real_value; /* floats */ - struct { /* ratios */ - s7_int numerator; - s7_int denominator; + struct { /* ratios */ + s7_int numerator; + s7_int denominator; } fraction_value; union { #if !WITH_CLANG_PP - s7_complex z; + s7_complex z; #endif - struct { /* complex numbers */ - s7_double rl; - s7_double im; - } complex_value; + struct { /* complex numbers */ + s7_double rl; + s7_double im; + } complex_value; } cz; + } number; - struct { /* ports */ - port_t* port; - uint8_t* data; - s7_int size, point; - block_t* block; + struct { /* ports */ + port_t *port; + uint8_t *data; + s7_int size, point; + block_t *block; } prt; - struct { /* characters */ + struct{ /* characters */ uint32_t c, up_c; - int32_t length; - bool alpha_c, digit_c, space_c, upper_c, lower_c; - char c_name[12]; + 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; + struct { /* c-pointers */ + void *c_pointer; s7_pointer c_type, info, weak1, weak2; } cptr; - struct { /* vectors */ + struct { /* vectors */ s7_int length; union { - s7_pointer* objects; - s7_int* ints; - s7_double* floats; - s7_complex* complexes; - uint8_t* bytes; + s7_pointer *objects; + s7_int *ints; + s7_double *floats; + s7_complex *complexes; + uint8_t *bytes; } elements; - block_t* block; - s7_pointer (*vget) (s7_scheme* sc, s7_pointer vec, s7_int loc); + 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; + 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; - s7_int top, flags; + struct { /* stacks (internal) struct must match vector above for length/objects */ + s7_int length; + s7_pointer *objects; + block_t *block; + s7_int top, flags; } stk; - struct { /* hash-tables */ + struct { /* hash-tables */ s7_uint mask; - hash_entry_t** - elements; /* a pointer into block below: takes up a field in - object.hasher but is faster (50 in thash) */ + hash_entry_t **elements; /* a pointer into block below: takes up a field in object.hasher but is faster (50 in thash) */ hash_check_t hash_func; - hash_map_t* loc; - block_t* block; + hash_map_t *loc; + block_t *block; } hasher; - struct { /* iterators */ + struct { /* iterators */ s7_pointer seq, cur; union { - s7_int loc; - s7_pointer slot; /* let iterator current slow */ + s7_int loc; + s7_pointer slot; /* let iterator current slow */ } lc; union { - s7_int len; - s7_pointer slow; /* pair iterator cycle check */ - hash_entry_t* entry; /* hash-table iterator current entry */ + s7_int len; + s7_pointer slow; /* pair iterator cycle check */ + hash_entry_t *entry; /* hash-table iterator current entry */ } lw; - s7_pointer (*next) (s7_scheme* sc, s7_pointer iterator); + s7_pointer (*next)(s7_scheme *sc, s7_pointer iterator); } iter; struct { - c_proc_t* c_proc; /* C functions, macros */ + c_proc_t *c_proc; /* C functions, macros */ s7_function ff; - s7_int required_args, optional_args, - all_args; /* these could be uint32_t */ + s7_int required_args, optional_args, all_args; /* these could be uint32_t */ } fnc; - struct { /* pairs */ + struct { /* pairs */ s7_pointer car, cdr, opt1; - union { - s7_pointer opt2; - s7_int n; + union + { + s7_pointer opt2; + s7_int n; } o2; union { - s7_pointer opt3; - s7_int n; - uint8_t opt_type; + s7_pointer opt3; + s7_int n; + uint8_t opt_type; } o3; } cons; - struct { /* special purpose pairs (symbol-table etc) */ - s7_pointer unused_car, unused_cdr; - s7_uint hash; - const char* fstr; - s7_uint location; /* line/file/position, also used in symbol_table as - raw_len */ + struct { /* special purpose pairs (symbol-table etc) */ + s7_pointer unused_car, unused_cdr; + s7_uint hash; + const char *fstr; + s7_uint location; /* line/file/position, also used in symbol_table as raw_len */ } sym_cons; - struct { /* scheme functions */ - s7_pointer args, body, let, - setter; /* args can be a symbol, as well as a list, setter can be #f - as well as a procedure/closure */ + struct { /* scheme functions */ + s7_pointer args, body, let, 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; - s7_uint hash; /* string hash-index */ - block_t* block; - block_t* gensym_block; + struct { /* strings */ + s7_int length; + char *svalue; + s7_uint hash; /* string hash-index */ + block_t *block; + block_t *gensym_block; } string; - struct { /* symbols */ + struct { /* symbols */ s7_pointer name, global_slot, local_slot; - s7_int - id; /* which let last bound the symbol -- for faster symbol lookup */ - uint32_t ctr; /* how many times has symbol been bound */ - uint32_t small_symbol_tag; /* symbol as member of a (small) set - (tree-set-memq etc), assumed to be uint32_t - in clear_small_symbol_set */ + s7_int id; /* which let last bound the symbol -- for faster symbol lookup */ + uint32_t ctr; /* how many times has symbol been bound */ + uint32_t small_symbol_tag; /* symbol as member of a (small) set (tree-set-memq etc), assumed to be uint32_t in clear_small_symbol_set */ } sym; - struct { /* syntax */ - s7_pointer symbol; - opcode_t op; - int32_t min_args, max_args; - const char* documentation; + struct { /* syntax */ + s7_pointer symbol; + opcode_t op; + int32_t min_args, max_args; + const char *documentation; /* 1 unused */ } syn; - struct { /* slots (bindings) */ - s7_pointer sym, val, nxt, pending_value, - expr; /* pending_value is also the setter field which works by a - whisker */ + struct { /* slots (bindings) */ + s7_pointer sym, val, nxt, pending_value, expr; /* pending_value is also the setter field which works by a whisker */ } slt; - struct { /* lets (environments) */ + struct { /* lets (environments) */ s7_pointer slots, nxt; - s7_int id; /* id of rootlet is -1 */ + s7_int id; /* id of rootlet is -1 */ union { - struct { - s7_pointer function; /* *function* (symbol) 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; - s7_int key; /* sc->baffle_ctr type */ + struct { + s7_pointer function; /* *function* (symbol) 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; + s7_int key; /* sc->baffle_ctr type */ } edat; } let; - struct { /* special stuff like # */ - s7_pointer car, cdr; /* unique_car|cdr, for sc->nil these are - sc->unspecified for faster assoc etc */ - s7_int unused_let_id; - const char* name; - s7_int len; + struct { /* special stuff like # */ + s7_pointer car, cdr; /* unique_car|cdr, for sc->nil these are sc->unspecified for faster assoc etc */ + s7_int unused_let_id; + const char *name; + s7_int len; } unq; - struct { /* #<...> */ - char* name; /* not const because the GC frees it */ + struct { /* #<...> */ + char *name; /* not const because the GC frees it */ s7_int len; /* 3 unused */ } undef; - struct { /* # */ - const char* name; - s7_int len; + struct { /* # */ + const char *name; + s7_int len; /* 3 unused */ } eof; - struct { /* counter (internal) */ - s7_pointer result, list, let, - slots; /* let = counter_let (curlet after map/for-each let created) */ - s7_uint cap; /* sc->capture_let_counter for let reuse */ + struct { /* counter (internal) */ + s7_pointer result, list, let, slots; /* let = counter_let (curlet after map/for-each let created) */ + s7_uint cap; /* sc->capture_let_counter for let reuse */ } ctr; - struct { /* random-state */ + struct { /* random-state */ s7_uint seed, carry; /* for 64-bit floats we probably need 4 state fields */ } rng; - struct { /* additional object types (C) */ - s7_int type; - void* value; /* the value the caller associates with the c_object */ - s7_pointer let; /* the method list, if any (openlet) */ - s7_scheme* sc; + struct { /* additional object types (C) */ + s7_int type; + void *value; /* the value the caller associates with the c_object */ + s7_pointer let; /* the method list, if any (openlet) */ + s7_scheme *sc; /* 1 unused */ } c_obj; - struct { /* continuations */ - block_t* block; - s7_pointer stack, op_stack; + struct { /* continuations */ + block_t *block; + s7_pointer stack, op_stack; s7_pointer *stack_start, *stack_end; } cwcc; - struct { /* call-with-exit */ - s7_uint goto_loc, op_stack_loc; - bool active; + struct { /* call-with-exit */ + s7_uint goto_loc, op_stack_loc; + bool active; s7_pointer name; /* 1 unused */ } rexit; - struct { /* catch */ - s7_uint goto_loc, op_stack_loc; + struct { /* catch */ + s7_uint goto_loc, op_stack_loc; s7_pointer tag; s7_pointer handler; - Jmp_Buf* cstack; + Jmp_Buf *cstack; } rcatch; /* C++ reserves "catch" I guess */ - struct { /* dynamic-wind */ + struct { /* dynamic-wind */ s7_pointer in, out, body; - dwind_t state; + dwind_t state; /* 1 unused */ } winder; } object; #if S7_DEBUGGING int32_t alloc_line, uses, explicit_free_line, gc_line, holders, carrier_line; - s7_int alloc_type, debugger_bits; + s7_int alloc_type, debugger_bits; const char *alloc_func, *gc_func, *root; - s7_pointer holder; + s7_pointer holder; #endif } s7_cell; + typedef struct s7_big_cell { s7_cell cell; - s7_int big_hloc; + s7_int big_hloc; } s7_big_cell; -typedef struct s7_big_cell* s7_big_pointer; +typedef struct s7_big_cell *s7_big_pointer; typedef struct heap_block_t { - intptr_t start, end; - s7_int offset; - struct heap_block_t* next; + intptr_t start, end; + s7_int 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, ctr; - bool* defined; +typedef struct shared_info { + 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, ctr; + bool *defined; } shared_info_t; typedef struct gc_obj_t { - s7_pointer p; - struct gc_obj_t* nxt; + s7_pointer p; + struct gc_obj_t *nxt; } gc_obj_t; typedef struct { - s7_pointer* list; - s7_int size, loc; + s7_pointer *list; + s7_int size, loc; } gc_list_t; typedef struct { - s7_int size, top, excl_size, excl_top; + s7_int size, top, excl_size, excl_top; s7_pointer *funcs, *let_names, *files; - s7_int * timing_data, *excl, *lines; + s7_int *timing_data, *excl, *lines; } profile_data_t; -typedef enum { - no_jump, - call_with_exit_jump, - throw_jump, - catch_jump, - error_jump, - error_quit_jump -} jump_loc_t; -typedef enum { - no_set_jump, - read_set_jump, - load_set_jump, - dynamic_wind_set_jump, - s7_call_set_jump, - eval_set_jump -} setjmp_loc_t; -static const char* jump_string[6]= {"no_jump", "call_with_exit_jump", - "throw_jump", "catch_jump", - "error_jump", "error_quit_jump"}; - -/* -------------------------------- s7_scheme struct - * -------------------------------- */ +typedef enum {no_jump, call_with_exit_jump, throw_jump, catch_jump, error_jump, error_quit_jump} jump_loc_t; +typedef enum {no_set_jump, read_set_jump, load_set_jump, dynamic_wind_set_jump, s7_call_set_jump, eval_set_jump} setjmp_loc_t; +static const char *jump_string[6] = {"no_jump", "call_with_exit_jump", "throw_jump", "catch_jump", "error_jump", "error_quit_jump"}; + + +/* -------------------------------- s7_scheme struct -------------------------------- */ struct s7_scheme { - s7_pointer - code; /* layout of first 4 entries should match stack frame layout */ + s7_pointer code; /* layout of first 4 entries should match stack frame layout */ s7_pointer curlet; s7_pointer args; - opcode_t cur_op; + opcode_t cur_op; s7_pointer value, cur_code; - 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 stack; /* stack is a vector */ - uint32_t stack_size; + 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 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; + uint32_t op_stack_size, max_stack_size; - s7_cell **heap, **free_heap, **free_heap_top, **free_heap_trigger, - **previous_free_heap_top; - s7_int heap_size, gc_freed, gc_total_freed, max_heap_size, gc_temps_size; + s7_cell **heap, **free_heap, **free_heap_top, **free_heap_trigger, **previous_free_heap_top; + s7_int 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, gc_true_calls, - gc_true_total_time; - heap_block_t* heap_blocks; + s7_int gc_calls, gc_total_time, gc_start, gc_end, gc_true_calls, gc_true_total_time; + heap_block_t *heap_blocks; #if WITH_HISTORY - s7_pointer eval_history1, eval_history2, error_history, history_sink, - history_pairs, old_cur_code; + 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; + int32_t lock_count; pthread_mutex_t lock; #endif - gc_obj_t * semipermanent_objects, *semipermanent_lets; - s7_pointer protected_objects, protected_setters, - protected_setter_symbols; /* vectors of gc-protected objects */ - s7_int* protected_objects_free_list; /* to avoid a linear search for a place - to store an object in - sc->protected_objects */ + gc_obj_t *semipermanent_objects, *semipermanent_lets; + s7_pointer protected_objects, protected_setters, protected_setter_symbols; /* vectors of gc-protected objects */ + s7_int *protected_objects_free_list; /* to avoid a linear search for a place to store an object in sc->protected_objects */ s7_int protected_objects_size, protected_setters_size, protected_setters_loc; s7_int protected_objects_free_list_loc; - s7_pointer symbol_table; - s7_pointer rootlet, rootlet_slots, shadow_rootlet; - unlet_entry_t* unlet_entries; /* original bindings of predefined functions */ + s7_pointer symbol_table; + s7_pointer rootlet, rootlet_slots, shadow_rootlet; + unlet_entry_t *unlet_entries; /* original bindings of predefined functions */ - s7_pointer input_port; /* current-input-port */ - s7_pointer* - input_port_stack; /* input port stack (load and read internally) */ + 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 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 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* */ - s7_pointer exit_hook; /* *exit-hook* hook object */ - token_t tok; - bool gc_off, gc_in_progress; /* 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; + s7_pointer error_hook, read_error_hook; /* *error-hook* hook object, and *read-error-hook* */ + s7_pointer exit_hook; /* *exit-hook* hook object */ + token_t tok; + bool gc_off, gc_in_progress; /* 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, error_argnum; s7_uint capture_let_counter; - bool short_print, is_autoloading, in_with_let, object_out_locked, - has_openlets, is_expanding, accept_all_keyword_arguments; + bool short_print, is_autoloading, in_with_let, object_out_locked, has_openlets, is_expanding, accept_all_keyword_arguments; bool got_tc, got_rec, not_tc, muffle_warnings, symbol_quote, reset_error_hook; - s7_int rec_tc_args; - s7_int let_number; + s7_int rec_tc_args; + s7_int let_number; unsigned char number_separator; - 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_file_port_length; - s7_int max_vector_length, max_string_length, max_list_length, - max_vector_dimensions, max_string_port_length, rec_loc, rec_len, - max_show_stack_frames; - s7_pointer stacktrace_defaults, symbol_printer, do_body_p, - iterator_at_end_value, scheme_version; - - s7_pointer rec_stack, rec_testp, rec_f1p, rec_f2p, rec_f3p, rec_f4p, rec_f5p, - rec_f6p, rec_f7p, rec_f8p; - 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_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_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_file_port_length; + s7_int max_vector_length, max_string_length, max_list_length, max_vector_dimensions, max_string_port_length, rec_loc, rec_len, max_show_stack_frames; + s7_pointer stacktrace_defaults, symbol_printer, do_body_p, iterator_at_end_value, scheme_version; + + s7_pointer rec_stack, rec_testp, rec_f1p, rec_f2p, rec_f3p, rec_f4p, rec_f5p, rec_f6p, rec_f7p, rec_f8p; + 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_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; - bool rec_bool; + bool rec_bool; - int32_t float_format_precision; - vdims_t* wrap_only; + 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 */ + 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_FILE_NAMES_SIZE 8 + s7_pointer *file_names; + int32_t file_names_size, file_names_top; -#define INITIAL_STRBUF_SIZE 1024 + #define INITIAL_STRBUF_SIZE 1024 s7_int strbuf_size; - char* strbuf; + char *strbuf; - char* read_line_buf; + char *read_line_buf; s7_int read_line_buf_size; s7_pointer v, w, x, y, z; - s7_pointer temp1, temp2, temp3, temp4, temp5, temp6, temp7, temp8, temp9, - read_dims; + s7_pointer temp1, temp2, temp3, temp4, temp5, temp6, temp7, temp8, temp9, read_dims; s7_pointer t1_1, t2_1, t2_2, t3_1, t3_2, t3_3, t4_1, u1_1; s7_pointer elist_1, elist_2, elist_3, elist_4, elist_5, elist_6, elist_7; s7_pointer plist_1, plist_2, plist_2_2, plist_3, plist_4; - s7_pointer qlist_2, qlist_3, clist_1, clist_2, dlist_1, mlist_1, - mlist_2; /* dlist|clist and ulist must not overlap */ + s7_pointer qlist_2, qlist_3, clist_1, clist_2, dlist_1, mlist_1, mlist_2; /* dlist|clist and ulist must not overlap */ - Jmp_Buf* goto_start; - bool longjmp_ok; + Jmp_Buf *goto_start; + bool longjmp_ok; setjmp_loc_t setjmp_loc; - void (*begin_hook) (s7_scheme* sc, bool* val); + 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, debug, profile, profile_position; - s7_pointer profile_prefix; - 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, safety; - gc_list_t * strings, *vectors, *input_ports, *output_ports, - *input_string_ports, *continuations, *c_objects, *hash_tables; - gc_list_t *gensyms, *undefineds, *multivectors, *weak_refs, - *weak_hash_iterators, *opt1_funcs; - - s7_pointer* setters; - s7_int setters_size, setters_loc; - s7_pointer* tree_pointers; - int32_t tree_pointers_size, tree_pointers_top, semipermanent_cells, - num_to_str_size; + bool debug_or_profile, profiling_gensyms; + s7_int current_line, s7_call_line, debug, profile, profile_position; + s7_pointer profile_prefix; + 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, safety; + gc_list_t *strings, *vectors, *input_ports, *output_ports, *input_string_ports, *continuations, *c_objects, *hash_tables; + gc_list_t *gensyms, *undefineds, *multivectors, *weak_refs, *weak_hash_iterators, *opt1_funcs; + + s7_pointer *setters; + s7_int setters_size, setters_loc; + s7_pointer *tree_pointers; + int32_t tree_pointers_size, tree_pointers_top, semipermanent_cells, num_to_str_size; s7_pointer format_ports; - uint32_t alloc_pointer_k, alloc_function_k, alloc_symbol_k, - alloc_big_pointer_k; - s7_cell* alloc_pointer_cells; - c_proc_t* alloc_function_cells; - s7_big_cell* alloc_big_pointer_cells; - s7_pointer string_wrappers, integer_wrappers, real_wrappers, complex_wrappers, - c_pointer_wrappers, let_wrappers, slot_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]; - - s7_int big_symbol_tag; + uint32_t alloc_pointer_k, alloc_function_k, alloc_symbol_k, alloc_big_pointer_k; + s7_cell *alloc_pointer_cells; + c_proc_t *alloc_function_cells; + s7_big_cell *alloc_big_pointer_cells; + s7_pointer string_wrappers, integer_wrappers, real_wrappers, complex_wrappers, c_pointer_wrappers, let_wrappers, slot_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]; + + s7_int big_symbol_tag; uint32_t small_symbol_tag; #if S7_DEBUGGING - int32_t big_symbol_set_line, small_symbol_set_line, big_symbol_set_state, - small_symbol_set_state, y_line, v_line, x_line, t_line; + int32_t big_symbol_set_line, small_symbol_set_line, big_symbol_set_state, small_symbol_set_state, y_line, v_line, x_line, t_line; const char *big_symbol_set_func, *small_symbol_set_func; #endif - s7_int baffle_ctr, map_call_ctr; + s7_int baffle_ctr, map_call_ctr; s7_pointer default_random_state; s7_pointer sort_body, sort_begin, sort_v1, sort_v2; - opcode_t sort_op; - s7_int sort_body_len; + 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, 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, 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_eq_symbol, char_geq_symbol, char_gt_symbol, char_leq_symbol, - char_lt_symbol, char_position_symbol, char_to_integer_symbol, - cload_directory_symbol, close_input_port_symbol, close_output_port_symbol, - complex_symbol, complex_vector_ref_symbol, complex_vector_set_symbol, - complex_vector_symbol, cond_expand_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, procedure_arglist_symbol, gc_symbol, gcd_symbol, - gensym_symbol, geq_symbol, get_output_string_symbol, gt_symbol, - hash_table_size_symbol, hash_table_key_typer_symbol, - hash_table_ref_symbol, hash_table_set_symbol, hash_table_symbol, - hash_table_value_typer_symbol, help_symbol, hook_functions_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_boolean_symbol, is_byte_symbol, is_byte_vector_symbol, - is_c_object_symbol, c_object_let_symbol, c_object_type_symbol, - is_c_pointer_symbol, is_char_alphabetic_symbol, is_char_symbol, - is_char_whitespace_symbol, is_complex_symbol, is_complex_vector_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_integer_or_number_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, local_documentation_symbol, - local_signature_symbol, local_setter_symbol, local_iterator_symbol, - macro_symbol, macro_star_symbol, magnitude_symbol, - make_byte_vector_symbol, make_complex_vector_symbol, - make_float_vector_symbol, make_hash_table_symbol, - make_weak_hash_table_symbol, make_int_vector_symbol, make_iterator_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, nan_symbol, - nan_payload_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, port_string_symbol, procedure_source_symbol, - provide_symbol, qq_append_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, reader_cond_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_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_keyword_symbol, string_to_number_symbol, - string_to_symbol_symbol, sublet_symbol, substring_symbol, - substring_uncopied_symbol, subtract_symbol, subvector_symbol, - subvector_position_symbol, subvector_vector_symbol, symbol_symbol, - symbol_to_dynamic_value_symbol, symbol_initial_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, vector_typer_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; + 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, 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, + 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_eq_symbol, char_geq_symbol, char_gt_symbol, char_leq_symbol, char_lt_symbol, + char_position_symbol, char_to_integer_symbol, cload_directory_symbol, close_input_port_symbol, + close_output_port_symbol, complex_symbol, complex_vector_ref_symbol, complex_vector_set_symbol, complex_vector_symbol, + cond_expand_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, procedure_arglist_symbol, + gc_symbol, gcd_symbol, gensym_symbol, geq_symbol, get_output_string_symbol, gt_symbol, + hash_table_size_symbol, hash_table_key_typer_symbol, hash_table_ref_symbol, hash_table_set_symbol, hash_table_symbol, + hash_table_value_typer_symbol, help_symbol, hook_functions_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_boolean_symbol, is_byte_symbol, is_byte_vector_symbol, + is_c_object_symbol, c_object_let_symbol, c_object_type_symbol, is_c_pointer_symbol, + is_char_alphabetic_symbol, is_char_symbol, is_char_whitespace_symbol, + is_complex_symbol, is_complex_vector_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_integer_or_number_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, + local_documentation_symbol, local_signature_symbol, local_setter_symbol, local_iterator_symbol, + macro_symbol, macro_star_symbol, magnitude_symbol, + make_byte_vector_symbol, make_complex_vector_symbol, make_float_vector_symbol, make_hash_table_symbol, + make_weak_hash_table_symbol, make_int_vector_symbol, make_iterator_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, nan_symbol, nan_payload_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, port_string_symbol, procedure_source_symbol, provide_symbol, + qq_append_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, reader_cond_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_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_keyword_symbol, string_to_number_symbol, string_to_symbol_symbol, + sublet_symbol, substring_symbol, substring_uncopied_symbol, subtract_symbol, subvector_symbol, subvector_position_symbol, subvector_vector_symbol, + symbol_symbol, symbol_to_dynamic_value_symbol, symbol_initial_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, vector_typer_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; s7_pointer hash_code_symbol, dummy_equal_hash_table, features_setter; #if !WITH_PURE_S7 - s7_pointer integer_length_symbol, is_char_ready_symbol, let_to_list_symbol, - list_to_string_symbol, list_to_vector_symbol, make_polar_symbol, - string_length_symbol, string_to_list_symbol, vector_length_symbol, - vector_to_list_symbol; + s7_pointer integer_length_symbol, + is_char_ready_symbol, let_to_list_symbol, list_to_string_symbol, list_to_vector_symbol, make_polar_symbol, string_length_symbol, + string_to_list_symbol, vector_length_symbol, vector_to_list_symbol; #endif #if WITH_R7RS s7_pointer clock_gettime_symbol, uname_symbol; #endif - bool r7rs_inited; - s7_pointer s7_symbol, r5rs_symbol, r7rs_symbol, global_is_eq, initial_is_eq, - global_memq, initial_memq, global_assq, initial_assq; + bool r7rs_inited; + s7_pointer s7_symbol, r5rs_symbol, r7rs_symbol, global_is_eq, initial_is_eq, global_memq, initial_memq, global_assq, initial_assq; /* syntax symbols et al */ - s7_pointer allow_other_keys_keyword, and_symbol, anon_symbol, - autoload_error_symbol, bad_result_symbol, baffled_symbol, begin_symbol, - body_symbol, case_symbol, class_name_symbol, cond_symbol, - define_bacro_star_symbol, define_bacro_symbol, define_constant_symbol, - define_expansion_star_symbol, define_expansion_symbol, - define_macro_star_symbol, define_macro_symbol, define_star_symbol, - define_symbol, display_keyword, division_by_zero_symbol, do_symbol, - else_symbol, feed_to_symbol, format_error_symbol, if_keyword, if_symbol, - immutable_error_symbol, invalid_exit_function_symbol, io_error_symbol, - lambda_star_symbol, lambda_symbol, let_star_symbol, let_symbol, - letrec_star_symbol, letrec_symbol, macroexpand_symbol, - missing_method_symbol, no_setter_symbol, number_to_real_symbol, or_symbol, - out_of_memory_symbol, out_of_range_symbol, profile_in_symbol, - quasiquote_function, quasiquote_symbol, quote_function, quote_symbol, - read_error_symbol, readable_keyword, rest_keyword, set_symbol, - string_read_error_symbol, symbol_table_symbol, syntax_error_symbol, - trace_in_symbol, type_symbol, unbound_variable_symbol, unless_symbol, - unquote_symbol, value_symbol, when_symbol, with_baffle_symbol, - with_let_symbol, write_keyword, wrong_number_of_args_symbol, - wrong_type_arg_symbol; + s7_pointer allow_other_keys_keyword, and_symbol, anon_symbol, autoload_error_symbol, bad_result_symbol, baffled_symbol, begin_symbol, body_symbol, case_symbol, + class_name_symbol, cond_symbol, define_bacro_star_symbol, define_bacro_symbol, define_constant_symbol, define_expansion_star_symbol, + define_expansion_symbol, define_macro_star_symbol, define_macro_symbol, define_star_symbol, define_symbol, display_keyword, + division_by_zero_symbol, do_symbol, else_symbol, feed_to_symbol, format_error_symbol, if_keyword, if_symbol, immutable_error_symbol, + invalid_exit_function_symbol, io_error_symbol, lambda_star_symbol, lambda_symbol, let_star_symbol, let_symbol, + letrec_star_symbol, letrec_symbol, macroexpand_symbol, missing_method_symbol, no_setter_symbol, number_to_real_symbol, or_symbol, + out_of_memory_symbol, out_of_range_symbol, profile_in_symbol, quasiquote_function, quasiquote_symbol, quote_function, quote_symbol, + read_error_symbol, readable_keyword, rest_keyword, set_symbol, string_read_error_symbol, symbol_table_symbol, + syntax_error_symbol, trace_in_symbol, type_symbol, unbound_variable_symbol, unless_symbol, + unquote_symbol, value_symbol, when_symbol, with_baffle_symbol, with_let_symbol, write_keyword, + wrong_number_of_args_symbol, wrong_type_arg_symbol; /* signatures of sequences used as applicable objects: ("hi" 1) */ - s7_pointer byte_vector_signature, c_object_signature, float_vector_signature, - hash_table_signature, int_vector_signature, let_signature, pair_signature, - string_signature, vector_signature, complex_vector_signature; + s7_pointer byte_vector_signature, c_object_signature, float_vector_signature, hash_table_signature, int_vector_signature, + let_signature, pair_signature, string_signature, vector_signature, complex_vector_signature; /* common signatures */ - s7_pointer pcl_bc, pcl_bs, pcl_bt, pcl_c, 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; + s7_pointer pcl_bc, pcl_bs, pcl_bt, pcl_c, 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_1x, add_2, add_3, add_4, add_i_random, add_x1, append_2, - ash_ic, ash_ii, bv_ref_2, bv_ref_3, bv_set_3, cdr_let_ref, cdr_let_set, - char_equal_2, char_greater_2, char_less_2, char_position_csi, - complex_wrapped, curlet_ref, cv_ref_2, cv_set_3, display_2, display_f, - dynamic_wind_body, dynamic_wind_init, dynamic_wind_unchecked, - format_as_objstr, format_f, format_just_control_string, format_no_column, - fv_ref_2, fv_ref_3, fv_set_3, fv_set_unchecked, geq_2, - get_output_string_uncopied, hash_table_2, hash_table_ref_2, int_log2, - is_defined_in_rootlet, is_defined_in_unlet, iv_ref_2, iv_ref_3, iv_set_3, - list_0, list_1, list_2, list_3, list_4, list_ref_at_0, list_ref_at_1, - list_ref_at_2, list_set_i, logand_2, logand_ii, logior_ii, logior_2, - logxor_2, memq_2, memq_3, memq_4, memq_any, multiply_3, outlet_unlet, - profile_out, read_char_1, restore_setter, rootlet_ref, simple_char_eq, - simple_char_eq1, simple_char_eq2, simple_inlet, simple_list_values, - starlet_ref, starlet_set, string_append_2, string_c1, string_equal_2, - string_equal_2c, string_greater_2, string_less_2, sublet_curlet, - substring_uncopied, subtract_1, subtract_2, subtract_2f, subtract_3, - subtract_f2, subtract_x1, sv_unlet_ref, symbol_to_string_uncopied, - tree_set_memq_syms, unlet_disabled, unlet_ref, unlet_set, values_uncopied, - vector_2, vector_3, vector_ref_2, vector_ref_3, vector_set_3, - vector_set_4, write_2; - - s7_pointer divide_2, divide_by_2, geq_xf, geq_xi, greater_2, greater_xf, - greater_xi, invert_1, invert_x, leq_2, leq_ixx, leq_xi, less_2, less_x0, - less_xf, less_xi, max_2, max_3, min_2, min_3, multiply_2, num_eq_2, - num_eq_ix, num_eq_xi, random_1, random_f, random_i; + s7_pointer add_1x, add_2, add_3, add_4, add_i_random, add_x1, append_2, ash_ic, ash_ii, bv_ref_2, bv_ref_3, bv_set_3, + cdr_let_ref, cdr_let_set, char_equal_2, char_greater_2, char_less_2, char_position_csi, complex_wrapped, curlet_ref, cv_ref_2, cv_set_3, + display_2, display_f, dynamic_wind_body, dynamic_wind_init, dynamic_wind_unchecked, + format_as_objstr, format_f, format_just_control_string, format_no_column, fv_ref_2, fv_ref_3, fv_set_3, fv_set_unchecked, geq_2, + get_output_string_uncopied, hash_table_2, hash_table_ref_2, int_log2, is_defined_in_rootlet, is_defined_in_unlet, iv_ref_2, iv_ref_3, iv_set_3, + list_0, list_1, list_2, list_3, list_4, list_ref_at_0, list_ref_at_1, list_ref_at_2, list_set_i, + logand_2, logand_ii, logior_ii, logior_2, logxor_2, memq_2, memq_3, memq_4, memq_any, multiply_3, + outlet_unlet, profile_out, read_char_1, restore_setter, rootlet_ref, simple_char_eq, simple_char_eq1, simple_char_eq2, + simple_inlet, simple_list_values, starlet_ref, starlet_set, + string_append_2, string_c1, string_equal_2, string_equal_2c, string_greater_2, string_less_2, sublet_curlet, substring_uncopied, subtract_1, + subtract_2, subtract_2f, subtract_3, subtract_f2, subtract_x1, sv_unlet_ref, symbol_to_string_uncopied, tree_set_memq_syms, + unlet_disabled, unlet_ref, unlet_set, values_uncopied, vector_2, vector_3, vector_ref_2, vector_ref_3, vector_set_3, vector_set_4, write_2; + + s7_pointer divide_2, divide_by_2, geq_xf, geq_xi, greater_2, greater_xf, greater_xi, invert_1, invert_x, leq_2, leq_ixx, + leq_xi, less_2, less_x0, less_xf, less_xi, max_2, max_3, min_2, min_3, + multiply_2, num_eq_2, num_eq_ix, num_eq_xi, random_1, random_f, random_i; s7_pointer seed_symbol, carry_symbol; /* object->let symbols */ - s7_pointer active_symbol, alias_symbol, at_end_symbol, c_object_ref_symbol, - c_type_symbol, class_symbol, closed_symbol, current_value_symbol, - data_symbol, dimensions_symbol, entries_symbol, file_info_symbol, - file_symbol, function_symbol, info_symbol, is_mutable_symbol, line_symbol, - open_symbol, original_vector_symbol, pointer_symbol, port_type_symbol, - position_symbol, sequence_symbol, size_symbol, source_symbol, weak_symbol; + s7_pointer active_symbol, alias_symbol, at_end_symbol, c_object_ref_symbol, c_type_symbol, class_symbol, closed_symbol, + current_value_symbol, data_symbol, dimensions_symbol, entries_symbol, file_info_symbol, file_symbol, function_symbol, info_symbol, + is_mutable_symbol, line_symbol, open_symbol, original_vector_symbol, pointer_symbol, port_type_symbol, position_symbol, + sequence_symbol, size_symbol, source_symbol, weak_symbol; + 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, sole_arg_wrong_type_info, - sole_arg_out_of_range_info; + 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, sole_arg_wrong_type_info, sole_arg_out_of_range_info; s7_pointer unicode_chars_table; -#define NUM_SAFE_PRELISTS 8 -#define NUM_SAFE_LISTS \ - 32 /* 36 is the biggest normally (lint.scm), 49 in s7test, 57 in snd-test, > \ - 16 doesn't happen much */ + #define NUM_SAFE_PRELISTS 8 + #define NUM_SAFE_LISTS 32 /* 36 is the biggest normally (lint.scm), 49 in s7test, 57 in snd-test, > 16 doesn't happen much */ s7_pointer safe_lists[NUM_SAFE_LISTS]; - int32_t current_safe_list; - int32_t** current_distance; + int32_t current_safe_list; + int32_t **current_distance; #if S7_DEBUGGING - s7_int safe_list_uses[NUM_SAFE_LISTS]; - int32_t* tc_rec_calls; - bool printing_gc_info; - s7_int blocks_allocated, format_ports_allocated, c_functions_allocated; - s7_int blocks_borrowed[NUM_BLOCK_LISTS], blocks_freed[NUM_BLOCK_LISTS], - blocks_mallocated[NUM_BLOCK_LISTS]; - s7_int string_wrapper_allocs, integer_wrapper_allocs, real_wrapper_allocs, - complex_wrapper_allocs, c_pointer_wrapper_allocs, let_wrapper_allocs, - slot_wrapper_allocs; + s7_int safe_list_uses[NUM_SAFE_LISTS]; + int32_t *tc_rec_calls; + bool printing_gc_info; + s7_int blocks_allocated, format_ports_allocated, c_functions_allocated; + s7_int blocks_borrowed[NUM_BLOCK_LISTS], blocks_freed[NUM_BLOCK_LISTS], blocks_mallocated[NUM_BLOCK_LISTS]; + s7_int string_wrapper_allocs, integer_wrapper_allocs, real_wrapper_allocs, complex_wrapper_allocs, c_pointer_wrapper_allocs, let_wrapper_allocs, slot_wrapper_allocs; #endif - s7_pointer autoload_table, starlet, starlet_symbol, temp_error_hook; - 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; + s7_pointer autoload_table, starlet, starlet_symbol, temp_error_hook; + 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; + 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]; /* this form is a lot faster than opt_info**! */ + #define OPTS_SIZE 256 /* pqw-vox needs 178 */ + opt_info *opts[OPTS_SIZE]; /* this form is a lot faster than opt_info**! */ -#define INITIAL_SAVED_POINTERS_SIZE 256 - void** saved_pointers; + #define INITIAL_SAVED_POINTERS_SIZE 256 + void **saved_pointers; s7_int saved_pointers_loc, saved_pointers_size; s7_pointer type_names[NUM_TYPES]; - s7_int overall_start_time; -}; /* store all s7_scheme bools in one int? ca 60 bytes saved out of 11440? */ + s7_int overall_start_time; +}; /* store all s7_scheme bools in one int? ca 60 bytes saved out of 11440? */ -no_return void error_nr (s7_scheme* sc, s7_pointer type, s7_pointer info); -s7_pointer wrap_string (s7_scheme* sc, const char* str, s7_int len); -s7_pointer splice_in_values (s7_scheme* sc, s7_pointer args); -void let_temp_done (s7_scheme* sc, s7_pointer args, s7_pointer let); +no_return void error_nr(s7_scheme *sc, s7_pointer type, s7_pointer info); +s7_pointer wrap_string(s7_scheme *sc, const char *str, s7_int len); +s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args); +void let_temp_done(s7_scheme *sc, s7_pointer args, s7_pointer let); #if S7_DEBUGGING -static void gdb_break (void) {}; + static void gdb_break(void) {}; #endif #ifndef DISABLE_FILE_OUTPUT -#define DISABLE_FILE_OUTPUT 0 + #define DISABLE_FILE_OUTPUT 0 #endif #if S7_DEBUGGING || DISABLE_FILE_OUTPUT || POINTER_32 -static s7_scheme* cur_sc= NULL; + static s7_scheme *cur_sc = NULL; #endif #if S7_DEBUGGING || ((DISABLE_FILE_OUTPUT || POINTER_32) && (!WITH_GCC)) -static s7_scheme* original_cur_sc= NULL; + static s7_scheme *original_cur_sc = NULL; #endif -s7_pointer set_elist_1 (s7_scheme* sc, s7_pointer x1); +s7_pointer set_elist_1(s7_scheme *sc, s7_pointer x1); -static inline FILE* -xfopen (const char* path, const char* mode) { - setlocale (LC_ALL, ".UTF8"); - return fopen (path, mode); +static inline FILE *xfopen(const char *path, const char *mode) +{ + setlocale(LC_ALL, ".UTF8"); + return fopen(path, mode); } -#define fopen(path, mode) xfopen (path, mode) +#define fopen(path, mode) xfopen(path, mode) #if DISABLE_FILE_OUTPUT -static FILE* -old_fopen (const char* pathname, const char* mode) { - return (fopen (pathname, mode)); -} +static FILE *old_fopen(const char *pathname, const char *mode) {return(fopen(pathname, mode));} #if !WITH_GCC -/* I assume that MS C can't handle the ({...}) business (WITH_GCC include clang - * and tinyc) */ +/* I assume that MS C can't handle the ({...}) business (WITH_GCC include clang and tinyc) */ #define fwrite local_fwrite -size_t -local_fwrite (const void* ptr, size_t size, size_t nmemb, FILE* stream) { - error_nr ( - cur_sc, cur_sc->io_error_symbol, - set_elist_1 ( - cur_sc, - wrap_string (cur_sc, - "writing a file is not allowed in this version of s7", - 51))); - return (0); -} -FILE* -local_fopen (const char* pathname, const char* mode) { +size_t local_fwrite(const void *ptr, size_t size, size_t nmemb, FILE *stream) +{ + error_nr(cur_sc, cur_sc->io_error_symbol, + set_elist_1(cur_sc, wrap_string(cur_sc, "writing a file is not allowed in this version of s7", 51))); + return(0); +} +FILE *local_fopen(const char *pathname, const char *mode) +{ if ((mode[0] == 'w') || (mode[0] == 'a')) - error_nr ( - cur_sc, cur_sc->io_error_symbol, - set_elist_1 ( - cur_sc, - wrap_string (cur_sc, - "opening a file is not allowed in this version of s7", - 51))); - return (old_fopen (pathname, mode)); + error_nr(cur_sc, cur_sc->io_error_symbol, + set_elist_1(cur_sc, wrap_string(cur_sc, "opening a file is not allowed in this version of s7", 51))); + return(old_fopen(pathname, mode)); } #else -#define fwrite(Ptr, Size, N, Stream) \ - ({ \ - error_nr ( \ - sc, sc->io_error_symbol, \ - set_elist_1 ( \ - sc, wrap_string ( \ - sc, "writing a file is not allowed in this version of s7", \ - 51))); \ - 0; \ - }) -#define fopen(Path, Mode) \ - ({ \ - if ((Mode[0] == 'w') || (Mode[0] == 'a')) \ - error_nr (sc, sc->io_error_symbol, \ - set_elist_1 ( \ - cur_sc, \ - wrap_string ( \ - cur_sc, \ - "opening a file is not allowed in this version of s7", \ - 51))); \ - old_fopen (Path, Mode); \ - }) +#define fwrite(Ptr, Size, N, Stream) ({error_nr(sc, sc->io_error_symbol, set_elist_1(sc, wrap_string(sc, "writing a file is not allowed in this version of s7", 51))); 0;}) +#define fopen(Path, Mode) \ + ({if ((Mode[0] == 'w') || (Mode[0] == 'a')) \ + error_nr(sc, sc->io_error_symbol, set_elist_1(cur_sc, wrap_string(cur_sc, "opening a file is not allowed in this version of s7", 51))); \ + old_fopen(Path, Mode);}) #endif #endif /* DISABLE_FILE_OUTPUT */ #if POINTER_32 -/* passing in sc here gloms up the 64-bit code intolerably -- 32-bit users will - * just have to live with cur_sc! */ -void* -Malloc (size_t bytes) { - void* p= malloc (bytes); - if (!p) - error_nr (cur_sc, cur_sc->out_of_memory_symbol, - set_elist_1 (cur_sc, wrap_string (cur_sc, "malloc failed", 13))); - return (p); +/* passing in sc here gloms up the 64-bit code intolerably -- 32-bit users will just have to live with cur_sc! */ +void *Malloc(size_t bytes) +{ + void *p = malloc(bytes); + if (!p) error_nr(cur_sc, cur_sc->out_of_memory_symbol, set_elist_1(cur_sc, wrap_string(cur_sc, "malloc failed", 13))); + return(p); } -void* -Calloc (size_t nmemb, size_t size) { - void* p= calloc (nmemb, size); - if (!p) - error_nr (cur_sc, cur_sc->out_of_memory_symbol, - set_elist_1 (cur_sc, wrap_string (cur_sc, "calloc failed", 13))); - return (p); +void *Calloc(size_t nmemb, size_t size) +{ + void *p = calloc(nmemb, size); + if (!p) error_nr(cur_sc, cur_sc->out_of_memory_symbol, set_elist_1(cur_sc, wrap_string(cur_sc, "calloc failed", 13))); + return(p); } -void* -Realloc (void* ptr, size_t size) { - void* p= realloc (ptr, size); - if (!p) - error_nr (cur_sc, cur_sc->out_of_memory_symbol, - set_elist_1 (cur_sc, wrap_string (cur_sc, "realloc failed", 14))); - return (p); +void *Realloc(void *ptr, size_t size) +{ + void *p = realloc(ptr, size); + if (!p) error_nr(cur_sc, cur_sc->out_of_memory_symbol, set_elist_1(cur_sc, wrap_string(cur_sc, "realloc failed", 14))); + return(p); } #else -#define Malloc(Size) malloc (Size) -#define Calloc(N, Size) calloc (N, Size) -#define Realloc(Ptr, Size) realloc (Ptr, Size) +#define Malloc(Size) malloc(Size) +#define Calloc(N, Size) calloc(N, Size) +#define Realloc(Ptr, Size) realloc(Ptr, Size) #endif -/* -------------------------------- mallocate -------------------------------- - */ -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; -} - -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}; - -void -memclr (void* s, size_t n) { - uint8_t* s2; + +/* -------------------------------- mallocate -------------------------------- */ +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; +} + +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}; + +void memclr(void *s, size_t n) +{ + uint8_t *s2; #if S7_ALIGNED - s2= (uint8_t*) s; + s2 = (uint8_t *)s; #else #if (defined(__x86_64__) || defined(__i386__)) - if (n >= 8) { - s7_int* s1= (s7_int*) s; - size_t n8= n >> 3; - do { - *s1++= 0; - } while (--n8 > 0); /* LOOP_4 here is slower */ - n&= 7; - s2= (uint8_t*) s1; - } - else s2= (uint8_t*) s; + if (n >= 8) + { + s7_int *s1 = (s7_int *)s; + size_t n8 = n >> 3; + do {*s1++ = 0;} while (--n8 > 0); /* LOOP_4 here is slower */ + n &= 7; + s2 = (uint8_t *)s1; + } + else s2 = (uint8_t *)s; #else - s2= (uint8_t*) s; + s2 = (uint8_t *)s; #endif #endif - while (n > 0) { - *s2++= 0; - n--; - } + 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 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 -Vectorized void -memclr64 (void* p, size_t bytes) { - size_t n = bytes >> 3; - s7_int* vals= (s7_int*) p; - for (size_t i= 0; i < n;) - LOOP_8 (vals[i++]= 0); +Vectorized void memclr64(void *p, size_t bytes) +{ + size_t n = bytes >> 3; + s7_int *vals = (s7_int *)p; + for (size_t i = 0; i < n; ) + LOOP_8(vals[i++] = 0); } #endif -void -init_block_lists (s7_scheme* sc) { - for (int32_t i= 0; i < NUM_BLOCK_LISTS; i++) - sc->block_lists[i]= NULL; +void init_block_lists(s7_scheme *sc) +{ + for (int32_t i = 0; i < NUM_BLOCK_LISTS; i++) + sc->block_lists[i] = NULL; #if S7_DEBUGGING - sc->blocks_allocated= 0; - for (int32_t i= 0; i < NUM_BLOCK_LISTS; i++) - sc->blocks_borrowed[i]= 0; + sc->blocks_allocated = 0; + for (int32_t i = 0; i < NUM_BLOCK_LISTS; i++) + sc->blocks_borrowed[i] = 0; #endif } -static inline void -liberate (s7_scheme* sc, block_t* blk) { +extern inline void liberate(s7_scheme *sc, block_t *blk) +{ #if S7_DEBUGGING - sc->blocks_freed[block_index (blk)]++; + sc->blocks_freed[block_index(blk)]++; #endif - if (block_index (blk) != TOP_BLOCK_LIST) { - block_next (blk)= (struct block_t*) sc->block_lists[block_index (blk)]; - sc->block_lists[block_index (blk)]= blk; - } - else /* biggest blocks (allocated according to each particular size) are freed - and placed on the 0-th list */ - { - if (block_data (blk)) { - free (block_data (blk)); - block_data (blk)= NULL; + if (block_index(blk) != TOP_BLOCK_LIST) + { + block_next(blk) = (struct block_t *)sc->block_lists[block_index(blk)]; + sc->block_lists[block_index(blk)] = blk; + } + else /* biggest blocks (allocated according to each particular size) are freed and placed on the 0-th list */ + { + if (block_data(blk)) + { + free(block_data(blk)); + block_data(blk) = NULL; + } + block_next(blk) = (struct block_t *)sc->block_lists[BLOCK_LIST]; + sc->block_lists[BLOCK_LIST] = blk; } - block_next (blk) = (struct block_t*) sc->block_lists[BLOCK_LIST]; - sc->block_lists[BLOCK_LIST]= blk; - } } -void -liberate_block (s7_scheme* sc, block_t* blk) { +void liberate_block(s7_scheme *sc, block_t *blk) +{ #if S7_DEBUGGING sc->blocks_freed[BLOCK_LIST]++; #endif - block_next (blk)= - (struct block_t*) sc->block_lists[BLOCK_LIST]; /* BLOCK_LIST==0 */ - sc->block_lists[BLOCK_LIST]= blk; -} - -void -fill_block_list (s7_scheme* sc) { -#define BLOCK_MALLOC_SIZE 256 - block_t* 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 */ + block_next(blk) = (struct block_t *)sc->block_lists[BLOCK_LIST]; /* BLOCK_LIST==0 */ + sc->block_lists[BLOCK_LIST] = blk; +} + +void fill_block_list(s7_scheme *sc) +{ + #define BLOCK_MALLOC_SIZE 256 + block_t *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 */ #if S7_DEBUGGING - sc->blocks_allocated+= BLOCK_MALLOC_SIZE; + sc->blocks_allocated += BLOCK_MALLOC_SIZE; #endif - add_saved_pointer (sc, b); - sc->block_lists[BLOCK_LIST]= b; - for (int32_t i= 0; i < BLOCK_MALLOC_SIZE - 1; b++, i++) - block_next (b)= (block_t*) (b + 1); - block_next (b)= NULL; + add_saved_pointer(sc, b); + sc->block_lists[BLOCK_LIST] = b; + for (int32_t i = 0; i < BLOCK_MALLOC_SIZE - 1; b++, i++) + block_next(b) = (block_t *)(b + 1); + block_next(b) = NULL; } -extern inline block_t* -mallocate_block (s7_scheme* sc) { - block_t* p; +extern 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); -} - -extern 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 */ + 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); +} + +extern 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 */ 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) { - char* 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; - } + 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) + { + char *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; + } { - char* result = &(sc->alloc_string_cells[sc->alloc_string_k]); - sc->alloc_string_k= next_k; - return (result); + char *result = &(sc->alloc_string_cells[sc->alloc_string_k]); + sc->alloc_string_k = next_k; + return(result); } } -static Inline block_t* -inline_mallocate (s7_scheme* sc, s7_int bytes) { - block_t* blk; - 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]; +static Inline block_t *inline_mallocate(s7_scheme *sc, s7_int bytes) +{ + block_t *blk; + 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 - index= (bytes <= 65536) ? (8 + intlen_bits[(bytes - 1) >> 8]) - : TOP_BLOCK_LIST; /* expansion to (1 << 17) made - no difference */ - } - blk= sc->block_lists[index]; - if (blk) { + { + 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 */ + } + blk = sc->block_lists[index]; + if (blk) + { #if S7_DEBUGGING - sc->blocks_mallocated[index]++; + sc->blocks_mallocated[index]++; #endif - sc->block_lists[index]= (block_t*) block_next (blk); - } - else { - if (index < (TOP_BLOCK_LIST - 1)) { - blk= sc->block_lists[index + 1]; - if (blk) { - /* 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] = (block_t *)block_next(blk); + } + else + { + if (index < (TOP_BLOCK_LIST - 1)) + { + blk = sc->block_lists[index + 1]; + if (blk) + { + /* 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. + */ #if S7_DEBUGGING - sc->blocks_mallocated[index + 1]++; - sc->blocks_borrowed[index + 1]++; + sc->blocks_mallocated[index + 1]++; + sc->blocks_borrowed[index + 1]++; #endif - sc->block_lists[index + 1]= (block_t*) block_next (blk); - block_set_size (blk, bytes); - return (blk); - } - } - blk = mallocate_block (sc); - block_data (blk)= (index < TOP_BLOCK_LIST) - ? (void*) permalloc (sc, (size_t) (1 << index)) - : Malloc (bytes); - block_set_index (blk, index); + sc->block_lists[index + 1] = (block_t *)block_next(blk); + block_set_size(blk, bytes); + return(blk); + }} + blk = mallocate_block(sc); + block_data(blk) = (index < TOP_BLOCK_LIST) ? (void *)permalloc(sc, (size_t)(1 << index)) : Malloc(bytes); + block_set_index(blk, index); #if S7_DEBUGGING - sc->blocks_mallocated[index]++; + sc->blocks_mallocated[index]++; #endif - } - } - else { + }} + else + { #if S7_DEBUGGING - sc->blocks_mallocated[BLOCK_LIST]++; + sc->blocks_mallocated[BLOCK_LIST]++; #endif - blk= mallocate_block (sc); - } - block_set_size (blk, bytes); - return (blk); + blk = mallocate_block(sc); + } + block_set_size(blk, bytes); + return(blk); } -block_t* -mallocate (s7_scheme* sc, s7_int bytes) { - return (inline_mallocate (sc, bytes)); -} +block_t *mallocate(s7_scheme *sc, s7_int bytes) {return(inline_mallocate(sc, bytes));} -block_t* -callocate (s7_scheme* sc, s7_int bytes) { - block_t* blk= inline_mallocate (sc, bytes); - if ((block_data (blk)) && (block_index (blk) != BLOCK_LIST)) { - if ((bytes & (~0x3f)) > 0) - memclr64 ((void*) block_data (blk), bytes & (~0x3f)); - if ((bytes & 0x3f) > 0) - memclr ((void*) ((uint8_t*) block_data (blk) + (bytes & (~0x3f))), - bytes & 0x3f); - } - return (blk); +block_t *callocate(s7_scheme *sc, s7_int bytes) +{ + block_t *blk = inline_mallocate(sc, bytes); + if ((block_data(blk)) && (block_index(blk) != BLOCK_LIST)) + { + if ((bytes & (~0x3f)) > 0) + memclr64((void *)block_data(blk), bytes & (~0x3f)); + if ((bytes & 0x3f) > 0) + memclr((void *)((uint8_t *)block_data(blk) + (bytes & (~0x3f))), bytes & 0x3f); + } + return(blk); } -block_t* -reallocate (s7_scheme* sc, block_t* old_blk, size_t bytes) { - block_t* new_blk= inline_mallocate (sc, bytes); - if ((S7_DEBUGGING) && (bytes < (size_t) block_size (old_blk))) - fprintf (stderr, "reallocate to smaller block?\n"); - if (block_data (old_blk)) /* presumably block_data(new_blk) is not null */ - memcpy ((uint8_t*) (block_data (new_blk)), - (uint8_t*) (block_data (old_blk)), block_size (old_blk)); - liberate (sc, old_blk); - return (new_blk); +block_t *reallocate(s7_scheme *sc, block_t *old_blk, size_t bytes) +{ + block_t *new_blk = inline_mallocate(sc, bytes); + if ((S7_DEBUGGING) && (bytes < (size_t)block_size(old_blk))) fprintf(stderr, "reallocate to smaller block?\n"); + if (block_data(old_blk)) /* presumably block_data(new_blk) is not null */ + memcpy((uint8_t *)(block_data(new_blk)), (uint8_t *)(block_data(old_blk)), block_size(old_blk)); + liberate(sc, old_blk); + return(new_blk); } -/* 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 ideally we'd have a way to release excessive - * mallocate bins, but they are permalloc'd individually +/* 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 + * ideally we'd have a way to release excessive mallocate bins, but they are permalloc'd individually */ -/* -------------------------------------------------------------------------------- - */ -typedef enum { p_display, p_write, p_readable, p_key, p_code } use_write_t; - -s7_pointer too_many_arguments_string, not_enough_arguments_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_input_port_string, an_open_output_port_string, - an_output_port_or_f_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, it_is_infinite_string, it_is_nan_string, - it_is_negative_string, it_is_too_large_string, it_is_too_small_string, - parameter_set_twice_string, result_is_too_large_string, - something_applicable_string, too_many_indices_string, - intermediate_too_large_string, format_string_1, format_string_2, - format_string_3, format_string_4, keyword_value_missing_string; - -bool t_number_p[NUM_TYPES], t_small_real_p[NUM_TYPES], t_rational_p[NUM_TYPES], - t_real_p[NUM_TYPES]; + +/* -------------------------------------------------------------------------------- */ +typedef enum {p_display, p_write, p_readable, p_key, p_code} use_write_t; + +s7_pointer too_many_arguments_string, not_enough_arguments_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_input_port_string, + an_open_output_port_string, an_output_port_or_f_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, it_is_infinite_string, it_is_nan_string, + it_is_negative_string, it_is_too_large_string, it_is_too_small_string, parameter_set_twice_string, result_is_too_large_string, + something_applicable_string, too_many_indices_string, intermediate_too_large_string, + format_string_1, format_string_2, format_string_3, format_string_4, keyword_value_missing_string; + +bool t_number_p[NUM_TYPES], t_small_real_p[NUM_TYPES], t_rational_p[NUM_TYPES], t_real_p[NUM_TYPES]; bool t_simple_p[NUM_TYPES], t_structure_p[NUM_TYPES], t_immutable_p[NUM_TYPES]; -bool t_any_macro_p[NUM_TYPES], t_any_closure_p[NUM_TYPES], - t_has_closure_let[NUM_TYPES]; +bool t_any_macro_p[NUM_TYPES], t_any_closure_p[NUM_TYPES], t_has_closure_let[NUM_TYPES]; bool t_mappable_p[NUM_TYPES], t_sequence_p[NUM_TYPES], t_vector_p[NUM_TYPES]; -bool t_procedure_p[NUM_TYPES], t_applicable_p[NUM_TYPES], - t_macro_setter_p[NUM_TYPES]; +bool t_procedure_p[NUM_TYPES], t_applicable_p[NUM_TYPES], t_macro_setter_p[NUM_TYPES]; #if S7_DEBUGGING -bool t_ext_p[NUM_TYPES], - t_exs_p[NUM_TYPES]; /* make sure internal types don't leak out */ +bool t_ext_p[NUM_TYPES], t_exs_p[NUM_TYPES]; /* make sure internal types don't leak out */ #endif -void -init_types (void) { - for (int32_t i= 0; i < NUM_TYPES; i++) { - t_any_closure_p[i] = false; - t_any_macro_p[i] = false; - t_applicable_p[i] = false; - t_has_closure_let[i]= false; - t_immutable_p[i] = true; - t_macro_setter_p[i] = false; - t_mappable_p[i] = false; - t_number_p[i] = false; - t_procedure_p[i] = false; - t_rational_p[i] = false; - t_real_p[i] = false; - t_sequence_p[i] = false; - t_simple_p[i] = false; - t_small_real_p[i] = false; - t_structure_p[i] = false; - t_vector_p[i] = false; +void init_types(void) +{ + for (int32_t i = 0; i < NUM_TYPES; i++) + { + t_any_closure_p[i] = false; + t_any_macro_p[i] = false; + t_applicable_p[i] = false; + t_has_closure_let[i] = false; + t_immutable_p[i] = true; + t_macro_setter_p[i] = false; + t_mappable_p[i] = false; + t_number_p[i] = false; + t_procedure_p[i] = false; + t_rational_p[i] = false; + t_real_p[i] = false; + t_sequence_p[i] = false; + t_simple_p[i] = false; + t_small_real_p[i] = false; + t_structure_p[i] = false; + t_vector_p[i] = false; #if S7_DEBUGGING - t_ext_p[i]= false; - t_exs_p[i]= false; + t_ext_p[i] = false; + t_exs_p[i] = false; #endif - } + } { - const int32_t nums[4]= {T_INTEGER, T_RATIO, T_REAL, T_COMPLEX}; - for (int32_t i= 0; i < 4; i++) - t_number_p[nums[i]]= true; + const int32_t nums[4] = {T_INTEGER, T_RATIO, T_REAL, T_COMPLEX}; + for (int32_t i = 0; i < 4; i++) t_number_p[nums[i]] = true; } - t_rational_p[T_INTEGER]= true; - t_rational_p[T_RATIO] = true; + t_rational_p[T_INTEGER] = true; + t_rational_p[T_RATIO] = true; - t_small_real_p[T_INTEGER]= true; - t_small_real_p[T_RATIO] = true; - t_small_real_p[T_REAL] = 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_INTEGER] = true; + t_real_p[T_RATIO] = true; + t_real_p[T_REAL] = true; { - const int32_t recs[8]= {T_PAIR, T_VECTOR, T_HASH_TABLE, T_SLOT, - T_LET, T_ITERATOR, T_C_OBJECT, T_C_POINTER}; - for (int32_t i= 0; i < 8; i++) - t_structure_p[recs[i]]= true; + const int32_t recs[8] = {T_PAIR, T_VECTOR, T_HASH_TABLE, T_SLOT, T_LET, T_ITERATOR, T_C_OBJECT, T_C_POINTER}; + for (int32_t i = 0; i < 8; i++) t_structure_p[recs[i]] = true; } { - const int32_t seqs[11]= {T_NIL, T_PAIR, T_STRING, - T_VECTOR, T_INT_VECTOR, T_FLOAT_VECTOR, - T_BYTE_VECTOR, T_COMPLEX_VECTOR, T_HASH_TABLE, - T_LET, T_C_OBJECT}; + const int32_t seqs[11] = { + T_NIL, T_PAIR, T_STRING, T_VECTOR, T_INT_VECTOR, T_FLOAT_VECTOR, T_BYTE_VECTOR, T_COMPLEX_VECTOR, T_HASH_TABLE, T_LET, T_C_OBJECT}; /* this assumes the object has a length method? */ - for (int32_t i= 0; i < 11; i++) - t_sequence_p[seqs[i]]= true; + for (int32_t i = 0; i < 11; i++) t_sequence_p[seqs[i]] = true; } { - const int32_t maps[18]= {T_PAIR, T_STRING, T_VECTOR, - T_INT_VECTOR, T_FLOAT_VECTOR, T_BYTE_VECTOR, - T_COMPLEX_VECTOR, T_HASH_TABLE, T_LET, - T_C_OBJECT, T_ITERATOR, T_C_MACRO, - T_MACRO, T_MACRO_STAR, T_BACRO, - T_BACRO_STAR, T_CLOSURE, T_CLOSURE_STAR}; - for (int32_t i= 0; i < 18; i++) - t_mappable_p[maps[i]]= true; + const int32_t maps[18] = { + T_PAIR, T_STRING, T_VECTOR, T_INT_VECTOR, T_FLOAT_VECTOR, T_BYTE_VECTOR, T_COMPLEX_VECTOR, T_HASH_TABLE, + T_LET, T_C_OBJECT, T_ITERATOR, T_C_MACRO, T_MACRO, T_MACRO_STAR, T_BACRO, T_BACRO_STAR, T_CLOSURE, T_CLOSURE_STAR}; + for (int32_t i = 0; i < 18; i++) t_mappable_p[maps[i]] = true; } { - const int32_t appls[24]= {T_PAIR, - T_STRING, - T_VECTOR, - T_INT_VECTOR, - T_FLOAT_VECTOR, - T_BYTE_VECTOR, - T_COMPLEX_VECTOR, - T_HASH_TABLE, - T_ITERATOR, - T_LET, - T_C_OBJECT, - T_C_MACRO, - T_MACRO, - T_MACRO_STAR, - T_BACRO, - T_BACRO_STAR, - T_SYNTAX, - T_C_FUNCTION, - T_C_FUNCTION_STAR, - T_C_RST_NO_REQ_FUNCTION, - T_CLOSURE, - T_CLOSURE_STAR, - T_GOTO, - T_CONTINUATION}; - for (int32_t i= 0; i < 24; i++) - t_applicable_p[appls[i]]= true; + const int32_t appls[24] = { + T_PAIR, T_STRING, T_VECTOR, T_INT_VECTOR, T_FLOAT_VECTOR, T_BYTE_VECTOR, T_COMPLEX_VECTOR, + T_HASH_TABLE, T_ITERATOR, T_LET, T_C_OBJECT, T_C_MACRO, T_MACRO, T_MACRO_STAR, T_BACRO, T_BACRO_STAR, + T_SYNTAX, T_C_FUNCTION, T_C_FUNCTION_STAR, T_C_RST_NO_REQ_FUNCTION, + T_CLOSURE, T_CLOSURE_STAR, T_GOTO, T_CONTINUATION}; + for (int32_t i = 0; i < 24; i++) t_applicable_p[appls[i]] = true; } { - const int32_t immuts[15]= {T_PAIR, T_UNDEFINED, T_SYMBOL, - T_STRING, T_C_OBJECT, T_C_POINTER, - T_VECTOR, T_FLOAT_VECTOR, T_INT_VECTOR, - T_BYTE_VECTOR, T_COMPLEX_VECTOR, T_HASH_TABLE, - T_LET, T_SLOT, T_RANDOM_STATE}; - for (int32_t i= 0; i < 15; i++) - t_immutable_p[immuts[i]]= false; + const int32_t immuts[15] = { + T_PAIR, T_UNDEFINED, T_SYMBOL, T_STRING, T_C_OBJECT, T_C_POINTER, T_VECTOR, T_FLOAT_VECTOR, T_INT_VECTOR, + T_BYTE_VECTOR, T_COMPLEX_VECTOR, T_HASH_TABLE, T_LET, T_SLOT, T_RANDOM_STATE}; + for (int32_t i = 0; i < 15; i++) t_immutable_p[immuts[i]] = false; /* T_ITERATOR, T_INPUT_PORT, T_OUTPUT_PORT ?? */ } { - const int32_t vecs[5]= {T_VECTOR, T_INT_VECTOR, T_FLOAT_VECTOR, - T_BYTE_VECTOR, T_COMPLEX_VECTOR}; - for (int32_t i= 0; i < 5; i++) - t_vector_p[vecs[i]]= true; + const int32_t vecs[5] = {T_VECTOR, T_INT_VECTOR, T_FLOAT_VECTOR, T_BYTE_VECTOR, T_COMPLEX_VECTOR}; + for (int32_t i = 0; i < 5; i++) t_vector_p[vecs[i]] = true; } { - const int32_t procs[7]= { - T_C_FUNCTION, T_C_FUNCTION_STAR, T_C_RST_NO_REQ_FUNCTION, - T_CLOSURE, T_CLOSURE_STAR, T_GOTO, - T_CONTINUATION}; - for (int32_t i= 0; i < 7; i++) - t_procedure_p[procs[i]]= true; + const int32_t procs[7] = {T_C_FUNCTION, T_C_FUNCTION_STAR, T_C_RST_NO_REQ_FUNCTION, T_CLOSURE, T_CLOSURE_STAR, T_GOTO, T_CONTINUATION}; + for (int32_t i = 0; i < 7; i++) t_procedure_p[procs[i]] = true; } - for (int32_t i= T_CLOSURE; i < NUM_TYPES; i++) - t_macro_setter_p[i]= true; - t_macro_setter_p[T_SYMBOL]= true; /* (slot setter); apparently T_LET and - T_C_OBJECT are not possible here */ - - t_any_macro_p[T_C_MACRO] = true; - t_any_macro_p[T_MACRO] = true; - t_any_macro_p[T_MACRO_STAR]= true; - t_any_macro_p[T_BACRO] = 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_MACRO_STAR] = true; - t_has_closure_let[T_BACRO] = true; - t_has_closure_let[T_BACRO_STAR] = true; - t_has_closure_let[T_CLOSURE] = true; - t_has_closure_let[T_CLOSURE_STAR]= true; + for (int32_t i = T_CLOSURE; i < NUM_TYPES; i++) t_macro_setter_p[i] = true; + t_macro_setter_p[T_SYMBOL] = true; /* (slot setter); apparently T_LET and T_C_OBJECT are not possible here */ + + t_any_macro_p[T_C_MACRO] = true; + t_any_macro_p[T_MACRO] = true; + t_any_macro_p[T_MACRO_STAR] = true; + t_any_macro_p[T_BACRO] = 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_MACRO_STAR] = true; + t_has_closure_let[T_BACRO] = true; + t_has_closure_let[T_BACRO_STAR] = true; + t_has_closure_let[T_CLOSURE] = true; + t_has_closure_let[T_CLOSURE_STAR] = true; /* not T_UNDEFINED here: only # itself will work with eq? */ - /* T_LET needs let_equal in member et al, 29-Nov-22. Also not sure about - * ports. */ + /* T_LET needs let_equal in member et al, 29-Nov-22. Also not sure about ports. */ { - const int32_t simps[12]= {T_NIL, - T_EOF, - T_BOOLEAN, - T_CHARACTER, - T_SYMBOL, - T_SYNTAX, - T_C_MACRO, - T_C_FUNCTION, - T_C_FUNCTION_STAR, - T_C_RST_NO_REQ_FUNCTION, - T_INPUT_PORT, - T_OUTPUT_PORT}; - for (int32_t i= 0; i < 12; i++) - t_simple_p[simps[i]]= true; + const int32_t simps[12] = {T_NIL, T_EOF, T_BOOLEAN, T_CHARACTER, T_SYMBOL, T_SYNTAX, + T_C_MACRO, T_C_FUNCTION, T_C_FUNCTION_STAR, T_C_RST_NO_REQ_FUNCTION, T_INPUT_PORT, T_OUTPUT_PORT}; + for (int32_t i = 0; i < 12; i++) t_simple_p[simps[i]] = true; } #if S7_DEBUGGING - t_ext_p[T_UNUSED] = true; - t_ext_p[T_SLOT] = true; - t_ext_p[T_STACK] = true; - t_ext_p[T_DYNAMIC_WIND]= true; - t_ext_p[T_CATCH] = true; - t_ext_p[T_COUNTER] = true; - /* these cases are errors (null pointer, T_FREE checked by check_nref called - * by check_ref_exs) */ - t_exs_p[T_STACK] = true; - t_exs_p[T_DYNAMIC_WIND]= true; - t_exs_p[T_CATCH] = true; - t_exs_p[T_COUNTER] = true; + t_ext_p[T_UNUSED] = true; + t_ext_p[T_SLOT] = true; + t_ext_p[T_STACK] = true; + t_ext_p[T_DYNAMIC_WIND] = true; + t_ext_p[T_CATCH] = true; + t_ext_p[T_COUNTER] = true; + /* these cases are errors (null pointer, T_FREE checked by check_nref called by check_ref_exs) */ + t_exs_p[T_STACK] = true; + t_exs_p[T_DYNAMIC_WIND] = true; + t_exs_p[T_CATCH] = true; + t_exs_p[T_COUNTER] = 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, Code); \ - } while (0) -#define replace_current_code(Sc, Code) set_car (Sc->cur_code, 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) +#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, Code);} while (0) +#define replace_current_code(Sc, Code) set_car(Sc->cur_code, 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= Code -#define replace_current_code(Sc, Code) Sc->cur_code= Code -#define mark_current_code(Sc) gc_mark (Sc->cur_code) +#define current_code(Sc) Sc->cur_code +#define set_current_code(Sc, Code) Sc->cur_code = Code +#define replace_current_code(Sc, Code) Sc->cur_code = Code +#define mark_current_code(Sc) gc_mark(Sc->cur_code) #endif -#define full_type(p) ((p)->tf.u64_type) +#define full_type(p) ((p)->tf.u64_type) #define low_type_bits(p) ((p)->tf.bits.low_bits) -#define TYPE_MASK 0xff +#define TYPE_MASK 0xff #if S7_DEBUGGING -static void print_gc_info (s7_scheme* sc, s7_pointer obj, const char* func, - int32_t line); -static s7_pointer check_ref_one (s7_pointer p, uint8_t expected_type, - const char* func, int32_t line, - const char* func1, const char* func2); -static s7_pointer check_ref_num (s7_pointer p, const char* func, int32_t line); -static s7_pointer check_ref_app (s7_pointer p, const char* func, int32_t line); -static s7_pointer check_ref_ext (s7_pointer p, const char* func, int32_t line); -static s7_pointer check_ref_exs (s7_pointer p, const char* func, int32_t line); -static s7_pointer check_ref_out (s7_pointer p, const char* func, int32_t line); -static s7_pointer check_ref_sln (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_opcode (s7_scheme* sc, s7_pointer p, const char* func, - int32_t line); -static s7_pointer check_let_ref (s7_pointer p, s7_uint role, const char* func, - int32_t line); -static s7_pointer -check_ref_two (s7_pointer p, uint8_t expected_type, int32_t other_type, - const char* func, int32_t line, const char* func1, - const char* func2); /* for REPORT_ROOTLET_REDEF below */ -#define type_unchecked(p) ((p)->tf.type_field) + static void print_gc_info(s7_scheme *sc, s7_pointer obj, const char *func, int32_t line); + static s7_pointer check_ref_one(s7_pointer p, uint8_t expected_type, const char *func, int32_t line, const char *func1, const char *func2); + static s7_pointer check_ref_num(s7_pointer p, const char *func, int32_t line); + static s7_pointer check_ref_app(s7_pointer p, const char *func, int32_t line); + static s7_pointer check_ref_ext(s7_pointer p, const char *func, int32_t line); + static s7_pointer check_ref_exs(s7_pointer p, const char *func, int32_t line); + static s7_pointer check_ref_out(s7_pointer p, const char *func, int32_t line); + static s7_pointer check_ref_sln(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_opcode(s7_scheme *sc, s7_pointer p, const char *func, int32_t line); + static s7_pointer check_let_ref(s7_pointer p, s7_uint role, const char *func, int32_t line); + static s7_pointer check_ref_two(s7_pointer p, uint8_t expected_type, int32_t other_type, const char *func, int32_t line, const char *func1, const char *func2); /* for REPORT_ROOTLET_REDEF below */ + #define type_unchecked(p) ((p)->tf.type_field) #if WITH_GCC -#define type(p) \ - ({ \ - uint8_t _t_; \ - _t_= (p)->tf.type_field; \ - if ((!cur_sc->printing_gc_info) && \ - ((_t_ == T_FREE) || (_t_ >= NUM_TYPES))) \ - print_gc_info (cur_sc, p, __func__, __LINE__); \ - _t_; \ - }) + #define type(p) ({uint8_t _t_; _t_ = (p)->tf.type_field; if ((!cur_sc->printing_gc_info) && ((_t_ == T_FREE) || (_t_ >= NUM_TYPES))) print_gc_info(cur_sc, p, __func__, __LINE__); _t_;}) #else -#define type(p) (p)->tf.type_field + #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_App(P) check_ref_app (P, __func__, __LINE__) /* applicable or #f */ -#define T_Arg(P) \ - check_ref_arg (P, __func__, __LINE__) /* closure arg (list, symbol) */ -#define T_BVc(P) \ - check_ref_one (P, T_BYTE_VECTOR, __func__, __LINE__, "sweep", NULL) -#define T_CMac(P) check_ref_one (P, T_C_MACRO, __func__, __LINE__, NULL, NULL) -#define T_Cat(P) check_ref_one (P, T_CATCH, __func__, __LINE__, NULL, NULL) -#define T_CFn(P) \ - check_ref_cfn (P, __func__, __LINE__) /* c-functions (not c-macro) */ -#define T_Chr(P) check_ref_one (P, T_CHARACTER, __func__, __LINE__, NULL, NULL) -#define T_Clo(P) check_ref_clo (P, __func__, __LINE__) /* has closure let */ -#define T_Cmp(P) check_ref_one (P, T_COMPLEX, __func__, __LINE__, NULL, NULL) -#define T_Con(P) \ - check_ref_one (P, T_CONTINUATION, __func__, __LINE__, "sweep", \ - "process_continuation") -#define T_Ctr(P) check_ref_one (P, T_COUNTER, __func__, __LINE__, NULL, NULL) -#define T_Cvc(P) \ - check_ref_one (P, T_COMPLEX_VECTOR, __func__, __LINE__, "sweep", NULL) -#define T_Dyn(P) \ - check_ref_one (P, T_DYNAMIC_WIND, __func__, __LINE__, NULL, NULL) -#define T_Eof(P) check_ref_one (P, T_EOF, __func__, __LINE__, "sweep", NULL) -#define T_Exs(P) \ - check_ref_exs (P, __func__, \ - __LINE__) /* not an internal (user-visible) type, but \ - # and slot are ok */ -#define T_Ext(P) \ - check_ref_ext (P, __func__, __LINE__) /* not an internal type */ -#define T_Fnc(P) \ - check_ref_fnc (P, __func__, __LINE__) /* any c_function|c_macro */ -#define T_Frc(P) \ - check_ref_two (P, T_RATIO, T_INTEGER, __func__, __LINE__, NULL, NULL) -#define T_Fst(P) \ - check_ref_one (P, T_C_FUNCTION_STAR, __func__, __LINE__, NULL, NULL) -#define T_Fvc(P) \ - check_ref_one (P, T_FLOAT_VECTOR, __func__, __LINE__, "sweep", NULL) -#define T_Got(P) check_ref_one (P, T_GOTO, __func__, __LINE__, NULL, NULL) -#define T_Hsh(P) \ - check_ref_one (P, T_HASH_TABLE, __func__, __LINE__, "sweep", \ - "free_hash_table") -#define T_Int(P) check_ref_one (P, T_INTEGER, __func__, __LINE__, NULL, NULL) -#define T_Itr(P) \ - check_ref_one (P, T_ITERATOR, __func__, __LINE__, "sweep", "process_iterator") -#define T_Ivc(P) \ - check_ref_one (P, T_INT_VECTOR, __func__, __LINE__, "sweep", NULL) -#define T_Key(P) check_ref_key (P, __func__, __LINE__) /* keyword */ -#define T_Let(P) check_ref_one (P, T_LET, __func__, __LINE__, NULL, NULL) -#define T_Lst(P) \ - check_ref_two (P, T_PAIR, T_NIL, __func__, __LINE__, "gc", NULL) -#define T_Mac(P) check_ref_mac (P, __func__, __LINE__) /* a non-C macro */ -#define T_Met(P) \ - check_ref_met (P, __func__, \ - __LINE__) /* anything that might contain a method */ -#define T_Muti(P) \ - check_ref_muti (P, __func__, __LINE__) /* a mutable integer \ - */ -#define T_Nmv(P) \ - check_ref_nmv ( \ - P, __func__, \ - __LINE__) /* not multiple-value, not free, only affects slot values */ -#define T_Num(P) \ - check_ref_num (P, __func__, __LINE__) /* any number (not bignums) */ -#define T_Nvc(P) check_ref_one (P, T_VECTOR, __func__, __LINE__, "sweep", NULL) -#define T_Obj(P) \ - check_ref_one (P, T_C_OBJECT, __func__, __LINE__, "sweep", \ - "s7_c_object_value") -#define T_Op(P) check_opcode (sc, P, __func__, __LINE__) -#define T_Out(P) check_ref_out (P, __func__, __LINE__) /* let or NULL */ -#define T_Pair(P) check_ref_one (P, T_PAIR, __func__, __LINE__, NULL, NULL) -#define T_Pcs(P) \ - check_ref_two (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_ref_prc (P, __func__, \ - __LINE__) /* any procedure (3-arg setters) or #f|#t */ -#define T_Prf(P) check_ref_prf (P, __func__, __LINE__) /* pair or #f */ -#define T_Pri(P) check_ref_pri (P, __func__, __LINE__) /* input_port or #f */ -#define T_Pro(P) check_ref_pro (P, __func__, __LINE__) /* output_port or #f */ -#define T_Prt(P) check_ref_prt (P, __func__, __LINE__) /* input|output_port */ -#define T_Ptr(P) check_ref_one (P, T_C_POINTER, __func__, __LINE__, NULL, NULL) -#define T_Ran(P) \ - check_ref_one (P, T_RANDOM_STATE, __func__, __LINE__, NULL, NULL) -#define T_Rel(P) check_ref_one (P, T_REAL, __func__, __LINE__, NULL, NULL) -#define T_Seq(P) \ - check_ref_seq (P, __func__, __LINE__) /* any sequence or structure */ -#define T_Sld(P) \ - check_ref_two (P, T_SLOT, T_UNDEFINED, __func__, __LINE__, NULL, NULL) -#define T_Sln(P) \ - check_ref_sln (P, __func__, \ - __LINE__) /* slot, # or end_slot, only for \ - traversing let slot lists */ -#define T_Slt(P) check_ref_one (P, T_SLOT, __func__, __LINE__, NULL, NULL) -#define T_Stk(P) check_ref_one (P, T_STACK, __func__, __LINE__, NULL, NULL) -#define T_Str(P) check_ref_one (P, T_STRING, __func__, __LINE__, "sweep", NULL) -#define T_SVec(P) check_ref_svec (P, __func__, __LINE__) /* subvector */ -#define T_Sym(P) \ - check_ref_one (P, T_SYMBOL, __func__, __LINE__, "sweep", \ - "remove_gensym_from_symbol_table") -#define T_Syn(P) check_ref_one (P, T_SYNTAX, __func__, __LINE__, NULL, NULL) -#define T_Undf(P) \ - check_ref_one (P, T_UNDEFINED, __func__, __LINE__, "sweep", NULL) -#define T_Vec(P) check_ref_vec (P, __func__, __LINE__) /* any vector */ + #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_App(P) check_ref_app(P, __func__, __LINE__) /* applicable or #f */ + #define T_Arg(P) check_ref_arg(P, __func__, __LINE__) /* closure arg (list, symbol) */ + #define T_BVc(P) check_ref_one(P, T_BYTE_VECTOR, __func__, __LINE__, "sweep", NULL) + #define T_CMac(P) check_ref_one(P, T_C_MACRO, __func__, __LINE__, NULL, NULL) + #define T_Cat(P) check_ref_one(P, T_CATCH, __func__, __LINE__, NULL, NULL) + #define T_CFn(P) check_ref_cfn(P, __func__, __LINE__) /* c-functions (not c-macro) */ + #define T_Chr(P) check_ref_one(P, T_CHARACTER, __func__, __LINE__, NULL, NULL) + #define T_Clo(P) check_ref_clo(P, __func__, __LINE__) /* has closure let */ + #define T_Cmp(P) check_ref_one(P, T_COMPLEX, __func__, __LINE__, NULL, NULL) + #define T_Con(P) check_ref_one(P, T_CONTINUATION, __func__, __LINE__, "sweep", "process_continuation") + #define T_Ctr(P) check_ref_one(P, T_COUNTER, __func__, __LINE__, NULL, NULL) + #define T_Cvc(P) check_ref_one(P, T_COMPLEX_VECTOR, __func__, __LINE__, "sweep", NULL) + #define T_Dyn(P) check_ref_one(P, T_DYNAMIC_WIND, __func__, __LINE__, NULL, NULL) + #define T_Eof(P) check_ref_one(P, T_EOF, __func__, __LINE__, "sweep", NULL) + #define T_Exs(P) check_ref_exs(P, __func__, __LINE__) /* not an internal (user-visible) type, but # and slot are ok */ + #define T_Ext(P) check_ref_ext(P, __func__, __LINE__) /* not an internal type */ + #define T_Fnc(P) check_ref_fnc(P, __func__, __LINE__) /* any c_function|c_macro */ + #define T_Frc(P) check_ref_two(P, T_RATIO, T_INTEGER, __func__, __LINE__, NULL, NULL) + #define T_Fst(P) check_ref_one(P, T_C_FUNCTION_STAR, __func__, __LINE__, NULL, NULL) + #define T_Fvc(P) check_ref_one(P, T_FLOAT_VECTOR, __func__, __LINE__, "sweep", NULL) + #define T_Got(P) check_ref_one(P, T_GOTO, __func__, __LINE__, NULL, NULL) + #define T_Hsh(P) check_ref_one(P, T_HASH_TABLE, __func__, __LINE__, "sweep", "free_hash_table") + #define T_Int(P) check_ref_one(P, T_INTEGER, __func__, __LINE__, NULL, NULL) + #define T_Itr(P) check_ref_one(P, T_ITERATOR, __func__, __LINE__, "sweep", "process_iterator") + #define T_Ivc(P) check_ref_one(P, T_INT_VECTOR, __func__, __LINE__, "sweep", NULL) + #define T_Key(P) check_ref_key(P, __func__, __LINE__) /* keyword */ + #define T_Let(P) check_ref_one(P, T_LET, __func__, __LINE__, NULL, NULL) + #define T_Lst(P) check_ref_two(P, T_PAIR, T_NIL, __func__, __LINE__, "gc", NULL) + #define T_Mac(P) check_ref_mac(P, __func__, __LINE__) /* a non-C macro */ + #define T_Met(P) check_ref_met(P, __func__, __LINE__) /* anything that might contain a method */ + #define T_Muti(P) check_ref_muti(P, __func__, __LINE__) /* a mutable integer */ + #define T_Nmv(P) check_ref_nmv(P, __func__, __LINE__) /* not multiple-value, not free, only affects slot values */ + #define T_Num(P) check_ref_num(P, __func__, __LINE__) /* any number (not bignums) */ + #define T_Nvc(P) check_ref_one(P, T_VECTOR, __func__, __LINE__, "sweep", NULL) + #define T_Obj(P) check_ref_one(P, T_C_OBJECT, __func__, __LINE__, "sweep", "s7_c_object_value") + #define T_Op(P) check_opcode(sc, P, __func__, __LINE__) + #define T_Out(P) check_ref_out(P, __func__, __LINE__) /* let or NULL */ + #define T_Pair(P) check_ref_one(P, T_PAIR, __func__, __LINE__, NULL, NULL) + #define T_Pcs(P) check_ref_two(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_ref_prc(P, __func__, __LINE__) /* any procedure (3-arg setters) or #f|#t */ + #define T_Prf(P) check_ref_prf(P, __func__, __LINE__) /* pair or #f */ + #define T_Pri(P) check_ref_pri(P, __func__, __LINE__) /* input_port or #f */ + #define T_Pro(P) check_ref_pro(P, __func__, __LINE__) /* output_port or #f */ + #define T_Prt(P) check_ref_prt(P, __func__, __LINE__) /* input|output_port */ + #define T_Ptr(P) check_ref_one(P, T_C_POINTER, __func__, __LINE__, NULL, NULL) + #define T_Ran(P) check_ref_one(P, T_RANDOM_STATE, __func__, __LINE__, NULL, NULL) + #define T_Rel(P) check_ref_one(P, T_REAL, __func__, __LINE__, NULL, NULL) + #define T_Seq(P) check_ref_seq(P, __func__, __LINE__) /* any sequence or structure */ + #define T_Sld(P) check_ref_two(P, T_SLOT, T_UNDEFINED, __func__, __LINE__, NULL, NULL) + #define T_Sln(P) check_ref_sln(P, __func__, __LINE__) /* slot, # or end_slot, only for traversing let slot lists */ + #define T_Slt(P) check_ref_one(P, T_SLOT, __func__, __LINE__, NULL, NULL) + #define T_Stk(P) check_ref_one(P, T_STACK, __func__, __LINE__, NULL, NULL) + #define T_Str(P) check_ref_one(P, T_STRING, __func__, __LINE__, "sweep", NULL) + #define T_SVec(P) check_ref_svec(P, __func__, __LINE__) /* subvector */ + #define T_Sym(P) check_ref_one(P, T_SYMBOL, __func__, __LINE__, "sweep", "remove_gensym_from_symbol_table") + #define T_Syn(P) check_ref_one(P, T_SYNTAX, __func__, __LINE__, NULL, NULL) + #define T_Undf(P) check_ref_one(P, T_UNDEFINED, __func__, __LINE__, "sweep", NULL) + #define T_Vec(P) check_ref_vec(P, __func__, __LINE__) /* any vector */ #else -/* if not debugging, all those checks go away */ -#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_CFn(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_Cvc(P) P -#define T_Dyn(P) P -#define T_Eof(P) P -#define T_Exs(P) P -#define T_Ext(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_Key(P) P -#define T_Let(P) P -#define T_Lst(P) P -#define T_Mac(P) P -#define T_Met(P) P -#define T_Muti(P) P -#define T_Nmv(P) P -#define T_Num(P) P -#define T_Nvc(P) P -#define T_Obj(P) P -#define T_Op(P) P -#define T_Out(P) P -#define T_Pair(P) P -#define T_Pcs(P) P -#define T_Pos(P) P -#define T_Prc(P) P -#define T_Prf(P) P -#define T_Pri(P) P -#define T_Pro(P) P -#define T_Prt(P) P -#define T_Ptr(P) P -#define T_Ran(P) P -#define T_Rel(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_SVec(P) P -#define T_Sym(P) P -#define T_Syn(P) P -#define T_Undf(P) P -#define T_Vec(P) P - -#define type_unchecked(p) ((p)->tf.type_field) -#define type(p) ((p)->tf.type_field) -#define set_full_type(p, f) full_type (p)= f + /* if not debugging, all those checks go away */ + #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_CFn(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_Cvc(P) P + #define T_Dyn(P) P + #define T_Eof(P) P + #define T_Exs(P) P + #define T_Ext(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_Key(P) P + #define T_Let(P) P + #define T_Lst(P) P + #define T_Mac(P) P + #define T_Met(P) P + #define T_Muti(P) P + #define T_Nmv(P) P + #define T_Num(P) P + #define T_Nvc(P) P + #define T_Obj(P) P + #define T_Op(P) P + #define T_Out(P) P + #define T_Pair(P) P + #define T_Pcs(P) P + #define T_Pos(P) P + #define T_Prc(P) P + #define T_Prf(P) P + #define T_Pri(P) P + #define T_Pro(P) P + #define T_Prt(P) P + #define T_Ptr(P) P + #define T_Ran(P) P + #define T_Rel(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_SVec(P) P + #define T_Sym(P) P + #define T_Syn(P) P + #define T_Undf(P) P + #define T_Vec(P) P + + #define type_unchecked(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.s64_type -#define clear_type(p) full_type (p)= T_FREE - -#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_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_boolean(p) (type (p) == T_BOOLEAN) - -#define is_free(p) (type_unchecked (p) == T_FREE) -#define is_free_and_clear(p) \ - (full_type (p) == T_FREE) /* protect against new_cell in-between states? \ - full_type is unchecked */ -#define is_simple(P) t_simple_p[type (P)] /* eq? */ -#define has_structure(P) \ - ((t_structure_p[type (P)]) && \ - ((!is_t_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_sequence_or_iterator(P) \ - ((t_sequence_p[type (P)]) || (is_iterator (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 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_low_type_bit(p, b) low_type_bits (p)|= (b) -#define clear_low_type_bit(p, b) low_type_bits (p)&= (~(b)) -#define has_low_type_bit(p, b) ((low_type_bits (p) & (b)) != 0) - -#define set_mid_type_bit(p, b) (p)->tf.bits.mid_bits|= (b) -#define clear_mid_type_bit(p, b) (p)->tf.bits.mid_bits&= (~(b)) -#define has_mid_type_bit(p, b) (((p)->tf.bits.mid_bits & (b)) != 0) - -#define set_high_type_bit(p, b) (p)->tf.bits.high_bits|= (b) -#define clear_high_type_bit(p, b) (p)->tf.bits.high_bits&= (~(b)) -#define has_high_type_bit(p, b) (((p)->tf.bits.high_bits & (b)) != 0) +#define signed_type(p) (p)->tf.s64_type +#define clear_type(p) full_type(p) = T_FREE + +#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_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_boolean(p) (type(p) == T_BOOLEAN) + +#define is_free(p) (type_unchecked(p) == T_FREE) +#define is_free_and_clear(p) (full_type(p) == T_FREE) /* protect against new_cell in-between states? full_type is unchecked */ +#define is_simple(P) t_simple_p[type(P)] /* eq? */ +#define has_structure(P) ((t_structure_p[type(P)]) && ((!is_t_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_sequence_or_iterator(P) ((t_sequence_p[type(P)]) || (is_iterator(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 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_low_type_bit(p, b) low_type_bits(p) |= (b) +#define clear_low_type_bit(p, b) low_type_bits(p) &= (~(b)) +#define has_low_type_bit(p, b) ((low_type_bits(p) & (b)) != 0) + +#define set_mid_type_bit(p, b) (p)->tf.bits.mid_bits |= (b) +#define clear_mid_type_bit(p, b) (p)->tf.bits.mid_bits &= (~(b)) +#define has_mid_type_bit(p, b) (((p)->tf.bits.mid_bits & (b)) != 0) + +#define set_high_type_bit(p, b) (p)->tf.bits.high_bits |= (b) +#define clear_high_type_bit(p, b) (p)->tf.bits.high_bits &= (~(b)) +#define has_high_type_bit(p, b) (((p)->tf.bits.high_bits & (b)) != 0) /* -------- low type bits -------- */ -#define T_SYNTACTIC (1 << (8 + 1)) -#define is_symbol_and_syntactic(p) \ - (low_type_bits (T_Ext (p)) == (uint16_t) (T_SYMBOL | T_SYNTACTIC)) -#define is_syntactic_symbol(p) has_low_type_bit (T_Sym (p), T_SYNTACTIC) -#define is_syntactic_pair(p) has_low_type_bit (T_Pair (p), T_SYNTACTIC) -#define clear_syntactic(p) clear_low_type_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 << (8 + 2)) -#define lambda_has_simple_defaults(p) \ - has_low_type_bit (T_Pair (closure_body (p)), T_SIMPLE_ARG_DEFAULTS) -#define lambda_set_simple_defaults(p) \ - set_low_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_SAFE_LIST_IN_USE T_SIMPLE_ARG_DEFAULTS /* only on sc->safe_lists */ -#define safe_list_is_in_use(p) has_low_type_bit (T_Pair (p), T_SAFE_LIST_IN_USE) -#define set_safe_list_in_use(p) \ - set_low_type_bit (T_Pair (p), T_SAFE_LIST_IN_USE) -#define clear_safe_list_in_use(Sc, p) \ - do { \ - clear_low_type_bit (T_Pair (p), T_SAFE_LIST_IN_USE); \ - Sc->current_safe_list= 0; \ - } while (0) - -#define T_ONE_FORM T_SIMPLE_ARG_DEFAULTS -#define set_closure_has_one_form(p) set_low_type_bit (T_Clo (p), T_ONE_FORM) -#define T_MULTIFORM (1 << (8 + 0)) -#define set_closure_has_multiform(p) set_low_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_low_type_bit (T_Clo (p), T_ONE_FORM_FX_ARG) -/* can't use T_HAS_FX here because closure_is_ok wants to examine low_type_bits - */ - -#define T_OPTIMIZED (1 << (8 + 3)) -#define set_optimized(p) set_low_type_bit (T_Pair (p), T_OPTIMIZED) -#define clear_optimized(p) \ - clear_low_type_bit (T_Pair (p), \ - T_OPTIMIZED | T_SYNTACTIC | T_HAS_FX | T_HAS_FN) -#define is_optimized(p) \ - (low_type_bits (T_Ext (p)) == (uint16_t) (T_PAIR | T_OPTIMIZED)) -/* 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_low_type_bit (T_Fnc (p), T_SCOPE_SAFE) -#define set_scope_safe(p) set_low_type_bit (T_Fnc (p), T_SCOPE_SAFE) - -#define T_SAFE_CLOSURE (1 << (8 + 4)) -#define is_safe_closure(p) has_low_type_bit (T_Clo (p), T_SAFE_CLOSURE) -#define set_safe_closure(p) set_low_type_bit (T_Clo (p), T_SAFE_CLOSURE) -#define is_safe_closure_body(p) has_low_type_bit (T_Pair (p), T_SAFE_CLOSURE) -#define set_safe_closure_body(p) set_low_type_bit (T_Pair (p), T_SAFE_CLOSURE) -#define clear_safe_closure_body(p) \ - clear_low_type_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 in define_funchcecked letrec_setup_closures - * etc, 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 low_type_bits). 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_SYNTACTIC (1 << (8 + 1)) +#define is_symbol_and_syntactic(p) (low_type_bits(T_Ext(p)) == (uint16_t)(T_SYMBOL | T_SYNTACTIC)) +#define is_syntactic_symbol(p) has_low_type_bit(T_Sym(p), T_SYNTACTIC) +#define is_syntactic_pair(p) has_low_type_bit(T_Pair(p), T_SYNTACTIC) +#define clear_syntactic(p) clear_low_type_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 << (8 + 2)) +#define lambda_has_simple_defaults(p) has_low_type_bit(T_Pair(closure_body(p)), T_SIMPLE_ARG_DEFAULTS) +#define lambda_set_simple_defaults(p) set_low_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_SAFE_LIST_IN_USE T_SIMPLE_ARG_DEFAULTS /* only on sc->safe_lists */ +#define safe_list_is_in_use(p) has_low_type_bit(T_Pair(p), T_SAFE_LIST_IN_USE) +#define set_safe_list_in_use(p) set_low_type_bit(T_Pair(p), T_SAFE_LIST_IN_USE) +#define clear_safe_list_in_use(Sc, p) do {clear_low_type_bit(T_Pair(p), T_SAFE_LIST_IN_USE); Sc->current_safe_list = 0;} while (0) + +#define T_ONE_FORM T_SIMPLE_ARG_DEFAULTS +#define set_closure_has_one_form(p) set_low_type_bit(T_Clo(p), T_ONE_FORM) +#define T_MULTIFORM (1 << (8 + 0)) +#define set_closure_has_multiform(p) set_low_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_low_type_bit(T_Clo(p), T_ONE_FORM_FX_ARG) +/* can't use T_HAS_FX here because closure_is_ok wants to examine low_type_bits */ + +#define T_OPTIMIZED (1 << (8 + 3)) +#define set_optimized(p) set_low_type_bit(T_Pair(p), T_OPTIMIZED) +#define clear_optimized(p) clear_low_type_bit(T_Pair(p), T_OPTIMIZED | T_SYNTACTIC | T_HAS_FX | T_HAS_FN) +#define is_optimized(p) (low_type_bits(T_Ext(p)) == (uint16_t)(T_PAIR | T_OPTIMIZED)) +/* 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_low_type_bit(T_Fnc(p), T_SCOPE_SAFE) +#define set_scope_safe(p) set_low_type_bit(T_Fnc(p), T_SCOPE_SAFE) + +#define T_SAFE_CLOSURE (1 << (8 + 4)) +#define is_safe_closure(p) has_low_type_bit(T_Clo(p), T_SAFE_CLOSURE) +#define set_safe_closure(p) set_low_type_bit(T_Clo(p), T_SAFE_CLOSURE) +#define is_safe_closure_body(p) has_low_type_bit(T_Pair(p), T_SAFE_CLOSURE) +#define set_safe_closure_body(p) set_low_type_bit(T_Pair(p), T_SAFE_CLOSURE) +#define clear_safe_closure_body(p) clear_low_type_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 in define_funchcecked letrec_setup_closures etc, 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 low_type_bits). + * 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 << (8 + 5)) -#define dont_eval_args(p) has_low_type_bit (T_Ext (p), T_DONT_EVAL_ARGS) +#define T_DONT_EVAL_ARGS (1 << (8 + 5)) +#define dont_eval_args(p) has_low_type_bit(T_Ext(p), T_DONT_EVAL_ARGS) /* this marks things that don't evaluate their arguments */ -#define T_EXPANSION (1 << (8 + 6)) -#define is_expansion(p) has_low_type_bit (T_Ext (p), T_EXPANSION) -#define clear_expansion(p) clear_low_type_bit (T_Sym (p), T_EXPANSION) -/* this marks the symbol and its run-time macro value, distinguishing it from an - * ordinary macro */ +#define T_EXPANSION (1 << (8 + 6)) +#define is_expansion(p) has_low_type_bit(T_Ext(p), T_EXPANSION) +#define clear_expansion(p) clear_low_type_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 << (8 + 7)) -#define is_multiple_value(p) \ - has_low_type_bit (T_Exs (p), \ - T_MULTIPLE_VALUE) /* not T_Ext -- can be a slot */ +#define T_MULTIPLE_VALUE (1 << (8 + 7)) +#define is_multiple_value(p) has_low_type_bit(T_Exs(p), T_MULTIPLE_VALUE) /* not T_Ext -- can be a slot */ #if S7_DEBUGGING -#define set_multiple_value(p) \ - do { \ - if (!in_heap (p)) { \ - fprintf (stderr, "%s[%d] (from set_multiple_value): arg not in heap\n", \ - __func__, __LINE__); \ - abort (); \ - } \ - set_low_type_bit (T_Pair (p), T_MULTIPLE_VALUE); \ - } while (0) + #define set_multiple_value(p) do {if (!in_heap(p)) {fprintf(stderr, "%s[%d] (from set_multiple_value): arg not in heap\n", __func__, __LINE__); abort();} set_low_type_bit(T_Pair(p), T_MULTIPLE_VALUE);} while (0) #else -#define set_multiple_value(p) set_low_type_bit (T_Pair (p), T_MULTIPLE_VALUE) + #define set_multiple_value(p) set_low_type_bit(T_Pair(p), T_MULTIPLE_VALUE) #endif -#define clear_multiple_value(p) \ - clear_low_type_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_low_type_bit (T_Pair (p), T_MATCHED) -#define clear_match_pair(p) clear_low_type_bit (T_Pair (p), T_MATCHED) -#define set_match_pair(p) set_low_type_bit (T_Pair (p), T_MATCHED) -#define set_match_symbol(p) set_low_type_bit (T_Sym (p), T_MATCHED) -#define is_matched_symbol(p) has_low_type_bit (T_Sym (p), T_MATCHED) -#define clear_match_symbol(p) clear_low_type_bit (T_Sym (p), T_MATCHED) +#define clear_multiple_value(p) clear_low_type_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_low_type_bit(T_Pair(p), T_MATCHED) +#define clear_match_pair(p) clear_low_type_bit(T_Pair(p), T_MATCHED) +#define set_match_pair(p) set_low_type_bit(T_Pair(p), T_MATCHED) +#define set_match_symbol(p) set_low_type_bit(T_Sym(p), T_MATCHED) +#define is_matched_symbol(p) has_low_type_bit(T_Sym(p), T_MATCHED) +#define clear_match_symbol(p) clear_low_type_bit(T_Sym(p), T_MATCHED) /* -------- mid type bits -------- */ -#define T_UNSAFE_DO (1 << (16 + 0)) -#define T_MID_UNSAFE_DO (1 << 0) -#define is_unsafe_do(p) has_mid_type_bit (T_Pair (p), T_MID_UNSAFE_DO) -#define set_unsafe_do(p) set_mid_type_bit (T_Pair (p), T_MID_UNSAFE_DO) +#define T_UNSAFE_DO (1 << (16 + 0)) +#define T_MID_UNSAFE_DO (1 << 0) +#define is_unsafe_do(p) has_mid_type_bit(T_Pair(p), T_MID_UNSAFE_DO) +#define set_unsafe_do(p) set_mid_type_bit(T_Pair(p), T_MID_UNSAFE_DO) /* marks do-loops that resist optimization */ -#define T_MID_DOX_SLOT1 T_MID_UNSAFE_DO -#define has_dox_slot1(p) has_mid_type_bit (T_Let (p), T_MID_DOX_SLOT1) -#define set_has_dox_slot1(p) set_mid_type_bit (T_Let (p), T_MID_DOX_SLOT1) +#define T_MID_DOX_SLOT1 T_MID_UNSAFE_DO +#define has_dox_slot1(p) has_mid_type_bit(T_Let(p), T_MID_DOX_SLOT1) +#define set_has_dox_slot1(p) set_mid_type_bit(T_Let(p), T_MID_DOX_SLOT1) /* marks a let that includes the dox_slot1 */ -#define T_MID_EVEN_ARGS T_MID_UNSAFE_DO -#define has_even_args(p) has_mid_type_bit (T_CFn (p), T_MID_EVEN_ARGS) -#define set_has_even_args(p) set_mid_type_bit (T_CFn (p), T_MID_EVEN_ARGS) - -#define T_MID_MAYBE_SHADOWED T_MID_UNSAFE_DO -#define is_maybe_shadowed(p) has_mid_type_bit (T_Sym (p), T_MID_MAYBE_SHADOWED) -#define set_is_maybe_shadowed(p) \ - set_mid_type_bit (T_Sym (p), T_MID_MAYBE_SHADOWED) - -#define T_COLLECTED (1 << (16 + 1)) -#define T_MID_COLLECTED (1 << 1) -#define is_collected(p) has_mid_type_bit (T_Seq (p), T_MID_COLLECTED) -#define is_collected_unchecked(p) has_mid_type_bit (p, T_MID_COLLECTED) -#define set_collected(p) set_mid_type_bit (T_Seq (p), T_MID_COLLECTED) -/* #define clear_collected(p) clear_mid_type_bit(T_Seq(p), - * T_MID_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_MID_EVEN_ARGS T_MID_UNSAFE_DO +#define has_even_args(p) has_mid_type_bit(T_CFn(p), T_MID_EVEN_ARGS) +#define set_has_even_args(p) set_mid_type_bit(T_CFn(p), T_MID_EVEN_ARGS) + +#define T_MID_MAYBE_SHADOWED T_MID_UNSAFE_DO +#define is_maybe_shadowed(p) has_mid_type_bit(T_Sym(p), T_MID_MAYBE_SHADOWED) +#define set_is_maybe_shadowed(p) set_mid_type_bit(T_Sym(p), T_MID_MAYBE_SHADOWED) + +#define T_COLLECTED (1 << (16 + 1)) +#define T_MID_COLLECTED (1 << 1) +#define is_collected(p) has_mid_type_bit(T_Seq(p), T_MID_COLLECTED) +#define is_collected_unchecked(p) has_mid_type_bit(p, T_MID_COLLECTED) +#define set_collected(p) set_mid_type_bit(T_Seq(p), T_MID_COLLECTED) +/* #define clear_collected(p) clear_mid_type_bit(T_Seq(p), T_MID_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 << (16 + 2)) -#define T_MID_LOCATION (1 << 2) -#define has_location(p) has_mid_type_bit (T_Pair (p), T_MID_LOCATION) -#define set_has_location(p) set_mid_type_bit (T_Pair (p), T_MID_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_LOCATION (1 << (16 + 2)) +#define T_MID_LOCATION (1 << 2) +#define has_location(p) has_mid_type_bit(T_Pair(p), T_MID_LOCATION) +#define set_has_location(p) set_mid_type_bit(T_Pair(p), T_MID_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_MID_LOCATION -#define is_loader_port(p) has_mid_type_bit (T_Pri (p), T_LOADER_PORT) -#define set_loader_port(p) set_mid_type_bit (T_Pri (p), T_LOADER_PORT) -#define clear_loader_port(p) clear_mid_type_bit (T_Pri (p), T_LOADER_PORT) -/* this bit marks a port used by the loader so that random load-time reads do - * not screw up the load process */ +#define T_LOADER_PORT T_MID_LOCATION +#define is_loader_port(p) has_mid_type_bit(T_Pri(p), T_LOADER_PORT) +#define set_loader_port(p) set_mid_type_bit(T_Pri(p), T_LOADER_PORT) +#define clear_loader_port(p) clear_mid_type_bit(T_Pri(p), T_LOADER_PORT) +/* this bit marks a port used by the loader so that random load-time reads do not screw up the load process */ -#define T_HAS_SETTER T_MID_LOCATION -#define slot_has_setter(p) has_mid_type_bit (T_Slt (p), T_HAS_SETTER) -#define slot_set_has_setter(p) set_mid_type_bit (T_Slt (p), T_HAS_SETTER) +#define T_HAS_SETTER T_MID_LOCATION +#define slot_has_setter(p) has_mid_type_bit(T_Slt(p), T_HAS_SETTER) +#define slot_set_has_setter(p) set_mid_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_MID_LOCATION -#define is_with_let_let(p) has_mid_type_bit (T_Let (p), T_WITH_LET_LET) -#define set_with_let_let(p) set_mid_type_bit (T_Let (p), T_WITH_LET_LET) +#define T_WITH_LET_LET T_MID_LOCATION +#define is_with_let_let(p) has_mid_type_bit(T_Let(p), T_WITH_LET_LET) +#define set_with_let_let(p) set_mid_type_bit(T_Let(p), T_WITH_LET_LET) /* marks a let that is the argument to with-let (but not rootlet in its uses) */ -#define T_SIMPLE_DEFAULTS T_MID_LOCATION -#define c_func_has_simple_defaults(p) \ - has_mid_type_bit (T_Fst (p), T_SIMPLE_DEFAULTS) -#define c_func_set_simple_defaults(p) \ - set_mid_type_bit (T_Fst (p), T_SIMPLE_DEFAULTS) -#define c_func_clear_simple_defaults(p) \ - clear_mid_type_bit (T_Fst (p), T_SIMPLE_DEFAULTS) +#define T_SIMPLE_DEFAULTS T_MID_LOCATION +#define c_func_has_simple_defaults(p) has_mid_type_bit(T_Fst(p), T_SIMPLE_DEFAULTS) +#define c_func_set_simple_defaults(p) set_mid_type_bit(T_Fst(p), T_SIMPLE_DEFAULTS) +#define c_func_clear_simple_defaults(p) clear_mid_type_bit(T_Fst(p), T_SIMPLE_DEFAULTS) /* flag c_func_star arg defaults that need GC protection */ -#define T_NO_SETTER T_MID_LOCATION -#define closure_no_setter(p) has_mid_type_bit (T_Clo (p), T_NO_SETTER) -#define closure_set_no_setter(p) set_mid_type_bit (T_Clo (p), T_NO_SETTER) - -#define T_SHARED (1 << (16 + 3)) -#define T_MID_SHARED (1 << 3) -#define is_shared(p) has_mid_type_bit (T_Seq (p), T_MID_SHARED) -#define set_shared(p) set_mid_type_bit (T_Seq (p), T_MID_SHARED) -#define is_collected_or_shared(p) \ - has_mid_type_bit (T_Seq (p), T_MID_COLLECTED | T_MID_SHARED) -#define clear_collected_and_shared(p) \ - clear_mid_type_bit ( \ - T_Seq (p), \ - T_MID_COLLECTED | T_MID_SHARED) /* this can clear free cells = calloc */ - -#define T_LOW_COUNT (1 << (16 + 4)) -#define T_MID_LOW_COUNT (1 << 4) -#define has_low_count(p) has_mid_type_bit (T_Pair (p), T_LOW_COUNT) -#define set_has_low_count(p) set_mid_type_bit (T_Pair (p), T_LOW_COUNT) - -#define T_TC T_MID_LOW_COUNT -#define has_tc(p) has_mid_type_bit (T_Pair (p), T_TC) -#define set_has_tc(p) set_mid_type_bit (T_Pair (p), T_TC) - -#define T_INITIAL_VALUE T_MID_LOW_COUNT -#define is_initial_value(p) has_mid_type_bit (p, T_INITIAL_VALUE) -#define set_is_initial_value(p) set_mid_type_bit (p, T_INITIAL_VALUE) -#define initial_value_is_defined(Sc, p) \ - (initial_value (T_Sym (p)) != Sc->undefined) - -#define T_SAFE_PROCEDURE (1 << (16 + 5)) -#define T_MID_SAFE_PROCEDURE (1 << 5) -#define is_safe_procedure(p) has_mid_type_bit (T_App (p), T_MID_SAFE_PROCEDURE) -#define is_safe_or_scope_safe_procedure(p) \ - ((full_type (T_Fnc (p)) & (T_SCOPE_SAFE | T_SAFE_PROCEDURE)) != \ - 0) /* T_SCOPE_SAFE is a low_type bit */ -/* 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_NO_SETTER T_MID_LOCATION +#define closure_no_setter(p) has_mid_type_bit(T_Clo(p), T_NO_SETTER) +#define closure_set_no_setter(p) set_mid_type_bit(T_Clo(p), T_NO_SETTER) + +#define T_SHARED (1 << (16 + 3)) +#define T_MID_SHARED (1 << 3) +#define is_shared(p) has_mid_type_bit(T_Seq(p), T_MID_SHARED) +#define set_shared(p) set_mid_type_bit(T_Seq(p), T_MID_SHARED) +#define is_collected_or_shared(p) has_mid_type_bit(T_Seq(p), T_MID_COLLECTED | T_MID_SHARED) +#define clear_collected_and_shared(p) clear_mid_type_bit(T_Seq(p), T_MID_COLLECTED | T_MID_SHARED) /* this can clear free cells = calloc */ + +#define T_LOW_COUNT (1 << (16 + 4)) +#define T_MID_LOW_COUNT (1 << 4) +#define has_low_count(p) has_mid_type_bit(T_Pair(p), T_LOW_COUNT) +#define set_has_low_count(p) set_mid_type_bit(T_Pair(p), T_LOW_COUNT) + +#define T_TC T_MID_LOW_COUNT +#define has_tc(p) has_mid_type_bit(T_Pair(p), T_TC) +#define set_has_tc(p) set_mid_type_bit(T_Pair(p), T_TC) + +#define T_INITIAL_VALUE T_MID_LOW_COUNT +#define is_initial_value(p) has_mid_type_bit(p, T_INITIAL_VALUE) +#define set_is_initial_value(p) set_mid_type_bit(p, T_INITIAL_VALUE) +#define initial_value_is_defined(Sc, p) (initial_value(T_Sym(p)) != Sc->undefined) + +#define T_SAFE_PROCEDURE (1 << (16 + 5)) +#define T_MID_SAFE_PROCEDURE (1 << 5) +#define is_safe_procedure(p) has_mid_type_bit(T_App(p), T_MID_SAFE_PROCEDURE) +#define is_safe_or_scope_safe_procedure(p) ((full_type(T_Fnc(p)) & (T_SCOPE_SAFE | T_SAFE_PROCEDURE)) != 0) /* T_SCOPE_SAFE is a low_type bit */ +/* 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 << (16 + 6)) -#define T_MID_CHECKED (1 << 6) -#define set_checked(p) set_mid_type_bit (T_Pair (p), T_MID_CHECKED) -#define is_checked(p) has_mid_type_bit (T_Pair (p), T_MID_CHECKED) -#define clear_checked(p) clear_mid_type_bit (T_Pair (p), T_MID_CHECKED) -#define set_checked_slot(p) set_mid_type_bit (T_Slt (p), T_MID_CHECKED) -#define is_checked_slot(p) has_mid_type_bit (T_Slt (p), T_MID_CHECKED) -#define clear_checked_slot(p) clear_mid_type_bit (T_Slt (p), T_MID_CHECKED) - -#define T_ALL_INTEGER T_MID_CHECKED -#define is_all_integer(p) has_mid_type_bit (T_Sym (p), T_ALL_INTEGER) -#define set_all_integer(p) set_mid_type_bit (T_Sym (p), T_ALL_INTEGER) - -#define T_UNSAFE (1 << (16 + 7)) -#define T_MID_UNSAFE (1 << 7) -#define set_unsafe(p) set_mid_type_bit (T_Pair (p), T_MID_UNSAFE) -#define set_unsafely_optimized(p) \ - full_type (T_Pair (p))= (full_type (p) | T_UNSAFE | \ - T_OPTIMIZED) /* T_OPTIMIZED is a low_type bit */ -#define is_unsafe(p) has_mid_type_bit (T_Pair (p), T_MID_UNSAFE) -#define clear_unsafe(p) clear_mid_type_bit (T_Pair (p), T_MID_UNSAFE) -#define is_safely_optimized(p) \ - ((full_type (T_Pair (p)) & (T_OPTIMIZED | T_UNSAFE)) == T_OPTIMIZED) -/* optimizer flag saying "this expression is not completely self-contained. It - * might involve the stack, etc" */ +#define T_CHECKED (1 << (16 + 6)) +#define T_MID_CHECKED (1 << 6) +#define set_checked(p) set_mid_type_bit(T_Pair(p), T_MID_CHECKED) +#define is_checked(p) has_mid_type_bit(T_Pair(p), T_MID_CHECKED) +#define clear_checked(p) clear_mid_type_bit(T_Pair(p), T_MID_CHECKED) +#define set_checked_slot(p) set_mid_type_bit(T_Slt(p), T_MID_CHECKED) +#define is_checked_slot(p) has_mid_type_bit(T_Slt(p), T_MID_CHECKED) +#define clear_checked_slot(p) clear_mid_type_bit(T_Slt(p), T_MID_CHECKED) + +#define T_ALL_INTEGER T_MID_CHECKED +#define is_all_integer(p) has_mid_type_bit(T_Sym(p), T_ALL_INTEGER) +#define set_all_integer(p) set_mid_type_bit(T_Sym(p), T_ALL_INTEGER) + +#define T_UNSAFE (1 << (16 + 7)) +#define T_MID_UNSAFE (1 << 7) +#define set_unsafe(p) set_mid_type_bit(T_Pair(p), T_MID_UNSAFE) +#define set_unsafely_optimized(p) full_type(T_Pair(p)) = (full_type(p) | T_UNSAFE | T_OPTIMIZED) /* T_OPTIMIZED is a low_type bit */ +#define is_unsafe(p) has_mid_type_bit(T_Pair(p), T_MID_UNSAFE) +#define clear_unsafe(p) clear_mid_type_bit(T_Pair(p), T_MID_UNSAFE) +#define is_safely_optimized(p) ((full_type(T_Pair(p)) & (T_OPTIMIZED | T_UNSAFE)) == T_OPTIMIZED) +/* optimizer flag saying "this expression is not completely self-contained. It might involve the stack, etc" */ /* see also T_NO_FLOAT_OPT below */ -#define T_CLEAN_SYMBOL T_MID_UNSAFE -#define is_clean_symbol(p) has_mid_type_bit (T_Sym (p), T_CLEAN_SYMBOL) -#define set_clean_symbol(p) set_mid_type_bit (T_Sym (p), T_CLEAN_SYMBOL) -/* set if we know the symbol name can be printed without quotes (slashification) - */ +#define T_CLEAN_SYMBOL T_MID_UNSAFE +#define is_clean_symbol(p) has_mid_type_bit(T_Sym(p), T_CLEAN_SYMBOL) +#define set_clean_symbol(p) set_mid_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_MID_UNSAFE -#define has_stepper(p) has_mid_type_bit (T_Slt (p), T_HAS_STEPPER) -#define set_has_stepper(p) set_mid_type_bit (T_Slt (p), T_HAS_STEPPER) +#define T_HAS_STEPPER T_MID_UNSAFE +#define has_stepper(p) has_mid_type_bit(T_Slt(p), T_HAS_STEPPER) +#define set_has_stepper(p) set_mid_type_bit(T_Slt(p), T_HAS_STEPPER) -#define T_DOX_SLOT2 T_MID_UNSAFE -#define has_dox_slot2(p) has_mid_type_bit (T_Let (p), T_DOX_SLOT2) -#define set_has_dox_slot2(p) set_mid_type_bit (T_Let (p), T_DOX_SLOT2) +#define T_DOX_SLOT2 T_MID_UNSAFE +#define has_dox_slot2(p) has_mid_type_bit(T_Let(p), T_DOX_SLOT2) +#define set_has_dox_slot2(p) set_mid_type_bit(T_Let(p), T_DOX_SLOT2) /* marks a let that includes the dox_slot2 */ -#define T_IMMUTABLE (1 << (16 + 8)) -#define T_MID_IMMUTABLE (1 << 8) -#define is_immutable(p) has_mid_type_bit (T_Exs (p), T_MID_IMMUTABLE) -#define set_immutable(p) \ - set_mid_type_bit (T_Exs (p), \ - T_MID_IMMUTABLE) /* can be a slot, so not T_Ext */ -#define set_immutable_let(p) set_mid_type_bit (T_Let (p), T_MID_IMMUTABLE) -#define set_immutable_slot(p) set_mid_type_bit (T_Slt (p), T_MID_IMMUTABLE) -#define set_immutable_string(p) set_mid_type_bit (T_Str (p), T_MID_IMMUTABLE) -#define set_immutable_pair(p) set_mid_type_bit (T_Pair (p), T_MID_IMMUTABLE) -#define is_immutable_port(p) has_mid_type_bit (T_Prt (p), T_MID_IMMUTABLE) -#define is_immutable_symbol(p) has_mid_type_bit (T_Sym (p), T_MID_IMMUTABLE) -#define is_immutable_slot(p) has_mid_type_bit (T_Slt (p), T_MID_IMMUTABLE) -#define is_immutable_pair(p) has_mid_type_bit (T_Pair (p), T_MID_IMMUTABLE) -#define is_immutable_vector(p) has_mid_type_bit (T_Vec (p), T_MID_IMMUTABLE) -#define is_immutable_string(p) has_mid_type_bit (T_Str (p), T_MID_IMMUTABLE) -#define is_immutable_hash_table(p) has_mid_type_bit (T_Hsh (p), T_MID_IMMUTABLE) -#define is_immutable_let(p) has_mid_type_bit (T_Let (p), T_MID_IMMUTABLE) -/* T_IMMUTABLE is compatible with T_MUTABLE -- the latter is an internal bit for - * locally mutable numbers */ - -#define T_FULL_ALLOW_OTHER_KEYS (1 << (16 + 9)) -#define T_ALLOW_OTHER_KEYS (1 << 9) -#define set_allow_other_keys(p) \ - set_mid_type_bit (T_Pair (p), T_ALLOW_OTHER_KEYS) -#define allows_other_keys(p) has_mid_type_bit (T_Pair (p), T_ALLOW_OTHER_KEYS) -#define c_function_set_allow_other_keys(p) \ - set_mid_type_bit (T_Fst (p), T_ALLOW_OTHER_KEYS) -#define c_function_allows_other_keys(p) \ - has_mid_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)...) (where - * there are no args) because there's only one nil, and besides, it does say - * "other". +#define T_IMMUTABLE (1 << (16 + 8)) +#define T_MID_IMMUTABLE (1 << 8) +#define is_immutable(p) has_mid_type_bit(T_Exs(p), T_MID_IMMUTABLE) +#define set_immutable(p) set_mid_type_bit(T_Exs(p), T_MID_IMMUTABLE) /* can be a slot, so not T_Ext */ +#define set_immutable_let(p) set_mid_type_bit(T_Let(p), T_MID_IMMUTABLE) +#define set_immutable_slot(p) set_mid_type_bit(T_Slt(p), T_MID_IMMUTABLE) +#define set_immutable_string(p) set_mid_type_bit(T_Str(p), T_MID_IMMUTABLE) +#define set_immutable_pair(p) set_mid_type_bit(T_Pair(p), T_MID_IMMUTABLE) +#define is_immutable_port(p) has_mid_type_bit(T_Prt(p), T_MID_IMMUTABLE) +#define is_immutable_symbol(p) has_mid_type_bit(T_Sym(p), T_MID_IMMUTABLE) +#define is_immutable_slot(p) has_mid_type_bit(T_Slt(p), T_MID_IMMUTABLE) +#define is_immutable_pair(p) has_mid_type_bit(T_Pair(p), T_MID_IMMUTABLE) +#define is_immutable_vector(p) has_mid_type_bit(T_Vec(p), T_MID_IMMUTABLE) +#define is_immutable_string(p) has_mid_type_bit(T_Str(p), T_MID_IMMUTABLE) +#define is_immutable_hash_table(p) has_mid_type_bit(T_Hsh(p), T_MID_IMMUTABLE) +#define is_immutable_let(p) has_mid_type_bit(T_Let(p), T_MID_IMMUTABLE) +/* T_IMMUTABLE is compatible with T_MUTABLE -- the latter is an internal bit for locally mutable numbers */ + +#define T_FULL_ALLOW_OTHER_KEYS (1 << (16 + 9)) +#define T_ALLOW_OTHER_KEYS (1 << 9) +#define set_allow_other_keys(p) set_mid_type_bit(T_Pair(p), T_ALLOW_OTHER_KEYS) +#define allows_other_keys(p) has_mid_type_bit(T_Pair(p), T_ALLOW_OTHER_KEYS) +#define c_function_set_allow_other_keys(p) set_mid_type_bit(T_Fst(p), T_ALLOW_OTHER_KEYS) +#define c_function_allows_other_keys(p) has_mid_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)...) (where there are no args) because there's only one nil, and besides, it does say "other". */ -#define T_LET_REMOVED T_ALLOW_OTHER_KEYS -#define let_set_removed(p) set_mid_type_bit (T_Let (p), T_LET_REMOVED) -#define let_removed(p) has_mid_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_ALLOW_OTHER_KEYS -#define slot_set_has_expression(p) \ - set_mid_type_bit (T_Slt (p), T_HAS_EXPRESSION) -#define slot_has_expression(p) has_mid_type_bit (T_Slt (p), T_HAS_EXPRESSION) - -#define T_MUTABLE (1 << (16 + 10)) -#define T_MID_MUTABLE (1 << 10) -#define is_mutable(p) has_mid_type_bit (p, T_MID_MUTABLE) -#define is_mutable_number(p) has_mid_type_bit (T_Num (p), T_MID_MUTABLE) -#define is_mutable_integer(p) has_mid_type_bit (T_Int (p), T_MID_MUTABLE) +#define T_LET_REMOVED T_ALLOW_OTHER_KEYS +#define let_set_removed(p) set_mid_type_bit(T_Let(p), T_LET_REMOVED) +#define let_removed(p) has_mid_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_ALLOW_OTHER_KEYS +#define slot_set_has_expression(p) set_mid_type_bit(T_Slt(p), T_HAS_EXPRESSION) +#define slot_has_expression(p) has_mid_type_bit(T_Slt(p), T_HAS_EXPRESSION) + +#define T_MUTABLE (1 << (16 + 10)) +#define T_MID_MUTABLE (1 << 10) +#define is_mutable(p) has_mid_type_bit(p, T_MID_MUTABLE) +#define is_mutable_number(p) has_mid_type_bit(T_Num(p), T_MID_MUTABLE) +#define is_mutable_integer(p) has_mid_type_bit(T_Int(p), T_MID_MUTABLE) #if S7_DEBUGGING -#define clear_mutable_number(p) \ - do { \ - check_mutable_bit (p); \ - clear_mid_type_bit (T_Num (p), T_MID_MUTABLE); \ - } while (0) -#define clear_mutable_integer(p) \ - do { \ - check_mutable_bit (p); \ - clear_mid_type_bit (T_Int (p), T_MID_MUTABLE); \ - } while (0) +#define clear_mutable_number(p) do {check_mutable_bit(p); clear_mid_type_bit(T_Num(p), T_MID_MUTABLE);} while (0) +#define clear_mutable_integer(p) do {check_mutable_bit(p); clear_mid_type_bit(T_Int(p), T_MID_MUTABLE);} while (0) #else -#define clear_mutable_number(p) clear_mid_type_bit (T_Num (p), T_MID_MUTABLE) -#define clear_mutable_integer(p) clear_mid_type_bit (T_Int (p), T_MID_MUTABLE) +#define clear_mutable_number(p) clear_mid_type_bit(T_Num(p), T_MID_MUTABLE) +#define clear_mutable_integer(p) clear_mid_type_bit(T_Int(p), T_MID_MUTABLE) #endif -/* used for mutable numbers, can occur with T_IMMUTABLE (outside view vs inside) - */ +/* used for mutable numbers, can occur with T_IMMUTABLE (outside view vs inside) */ -#define T_HAS_KEYWORD T_MID_MUTABLE -#define has_keyword(p) has_mid_type_bit (T_Sym (p), T_HAS_KEYWORD) -#define set_has_keyword(p) set_mid_type_bit (T_Sym (p), T_HAS_KEYWORD) +#define T_HAS_KEYWORD T_MID_MUTABLE +#define has_keyword(p) has_mid_type_bit(T_Sym(p), T_HAS_KEYWORD) +#define set_has_keyword(p) set_mid_type_bit(T_Sym(p), T_HAS_KEYWORD) -#define T_MARK_SEQ T_MID_MUTABLE -#define has_carrier(p) has_mid_type_bit (T_Itr (p), T_MARK_SEQ) +#define T_MARK_SEQ T_MID_MUTABLE +#define has_carrier(p) has_mid_type_bit(T_Itr(p), T_MARK_SEQ) #if S7_DEBUGGING -#define set_has_carrier(p) \ - do { \ - set_mid_type_bit (T_Itr (p), T_MARK_SEQ); \ - p->carrier_line= __LINE__; \ - } while (0) + #define set_has_carrier(p) do {set_mid_type_bit(T_Itr(p), T_MARK_SEQ); p->carrier_line = __LINE__;} while (0) #else -#define set_has_carrier(p) set_mid_type_bit (T_Itr (p), T_MARK_SEQ) + #define set_has_carrier(p) set_mid_type_bit(T_Itr(p), T_MARK_SEQ) #endif /* used in iterators for GC mark of sequence */ -#define T_HAS_LOOP_END T_MID_MUTABLE -#define has_loop_end(p) has_mid_type_bit (T_Slt (p), T_HAS_LOOP_END) -#define loop_end_fits(Slot, Len) \ - ((has_loop_end (Slot)) && (denominator (slot_value (Slot)) <= Len)) -#define set_has_loop_end(p) set_mid_type_bit (T_Slt (p), T_HAS_LOOP_END) -/* marks a slot that holds a do-loop's step-or-end variable, numerator=current, - * denominator=end */ - -#define T_NO_CELL_OPT T_MID_MUTABLE -#define set_no_cell_opt(p) set_mid_type_bit (T_Pair (p), T_NO_CELL_OPT) -#define no_cell_opt(p) has_mid_type_bit (T_Pair (p), T_NO_CELL_OPT) - -#define T_IS_ELIST T_MUTABLE -#define T_MID_IS_ELIST T_MID_MUTABLE -#define set_is_elist(p) set_mid_type_bit (T_Lst (p), T_MID_IS_ELIST) -#define is_elist(p) has_mid_type_bit (T_Lst (p), T_MID_IS_ELIST) - -#define T_NO_INT_OPT T_ALLOW_OTHER_KEYS -#define set_no_int_opt(p) set_mid_type_bit (T_Pair (p), T_NO_INT_OPT) -#define no_int_opt(p) has_mid_type_bit (T_Pair (p), T_NO_INT_OPT) - -#define T_NO_FLOAT_OPT T_MID_UNSAFE -#define set_no_float_opt(p) set_mid_type_bit (T_Pair (p), T_NO_FLOAT_OPT) -#define no_float_opt(p) has_mid_type_bit (T_Pair (p), T_NO_FLOAT_OPT) - -#define T_INTEGER_KEYS T_ALLOW_OTHER_KEYS -#define set_has_integer_keys(p) set_mid_type_bit (T_Pair (p), T_INTEGER_KEYS) -#define has_integer_keys(p) has_mid_type_bit (T_Pair (p), T_INTEGER_KEYS) - -#define T_SAFE_STEPPER (1 << (16 + 11)) -#define T_MID_SAFE_STEPPER (1 << 11) -#define is_safe_stepper(p) has_mid_type_bit (T_Slt (p), T_MID_SAFE_STEPPER) -#define set_safe_stepper(p) set_mid_type_bit (T_Slt (p), T_MID_SAFE_STEPPER) -#define clear_safe_stepper(p) clear_mid_type_bit (T_Slt (p), T_MID_SAFE_STEPPER) -#define is_safe_stepper_expr(p) \ - has_mid_type_bit (T_Pair (p), T_MID_SAFE_STEPPER) -#define set_safe_stepper_expr(p) \ - set_mid_type_bit (T_Pair (p), T_MID_SAFE_STEPPER) - -#define T_NO_BOOL_OPT T_MID_SAFE_STEPPER -#define set_no_bool_opt(p) set_mid_type_bit (T_Pair (p), T_NO_BOOL_OPT) -#define no_bool_opt(p) has_mid_type_bit (T_Pair (p), T_NO_BOOL_OPT) - -#define T_MAYBE_SAFE T_MID_SAFE_STEPPER -#define is_maybe_safe(p) has_mid_type_bit (T_Fnc (p), T_MAYBE_SAFE) -#define set_maybe_safe(p) set_mid_type_bit (T_Fnc (p), T_MAYBE_SAFE) - -#define T_PAIR_MACRO T_MID_SAFE_STEPPER -#define has_pair_macro(p) has_mid_type_bit (T_Mac (p), T_PAIR_MACRO) -#define set_has_pair_macro(p) set_mid_type_bit (T_Mac (p), T_PAIR_MACRO) - -#define T_WEAK_HASH T_MID_SAFE_STEPPER -#define set_weak_hash_table(p) set_mid_type_bit (T_Hsh (p), T_WEAK_HASH) -#define is_weak_hash_table(p) has_mid_type_bit (T_Hsh (p), T_WEAK_HASH) - -#define T_ALL_FLOAT T_MID_SAFE_STEPPER -#define is_all_float(p) has_mid_type_bit (T_Sym (p), T_ALL_FLOAT) -#define set_all_float(p) set_mid_type_bit (T_Sym (p), T_ALL_FLOAT) -#define set_all_integer_and_float(p) \ - set_mid_type_bit (T_Sym (p), (T_ALL_INTEGER | T_ALL_FLOAT)) - -#define T_COPY_ARGS (1 << (16 + 12)) -#define T_MID_COPY_ARGS (1 << 12) -#define needs_copied_args(p) \ - has_mid_type_bit (T_Ext (p), \ - T_MID_COPY_ARGS) /* set via explicit T_COPY_ARGS */ -#define set_needs_copied_args(p) set_mid_type_bit (T_Pair (p), T_MID_COPY_ARGS) -#define clear_needs_copied_args(p) \ - clear_mid_type_bit (T_Pair (p), T_MID_COPY_ARGS) -/* this marks something that might mess with its argument list, it should not be - * in the second byte */ - -#define T_GENSYM (1 << (16 + 13)) -#define T_MID_GENSYM (1 << 13) -#define is_gensym(p) has_mid_type_bit (T_Sym (p), T_MID_GENSYM) +#define T_HAS_LOOP_END T_MID_MUTABLE +#define has_loop_end(p) has_mid_type_bit(T_Slt(p), T_HAS_LOOP_END) +#define loop_end_fits(Slot, Len) ((has_loop_end(Slot)) && (denominator(slot_value(Slot)) <= Len)) +#define set_has_loop_end(p) set_mid_type_bit(T_Slt(p), T_HAS_LOOP_END) +/* marks a slot that holds a do-loop's step-or-end variable, numerator=current, denominator=end */ + +#define T_NO_CELL_OPT T_MID_MUTABLE +#define set_no_cell_opt(p) set_mid_type_bit(T_Pair(p), T_NO_CELL_OPT) +#define no_cell_opt(p) has_mid_type_bit(T_Pair(p), T_NO_CELL_OPT) + +#define T_IS_ELIST T_MUTABLE +#define T_MID_IS_ELIST T_MID_MUTABLE +#define set_is_elist(p) set_mid_type_bit(T_Lst(p), T_MID_IS_ELIST) +#define is_elist(p) has_mid_type_bit(T_Lst(p), T_MID_IS_ELIST) + +#define T_NO_INT_OPT T_ALLOW_OTHER_KEYS +#define set_no_int_opt(p) set_mid_type_bit(T_Pair(p), T_NO_INT_OPT) +#define no_int_opt(p) has_mid_type_bit(T_Pair(p), T_NO_INT_OPT) + +#define T_NO_FLOAT_OPT T_MID_UNSAFE +#define set_no_float_opt(p) set_mid_type_bit(T_Pair(p), T_NO_FLOAT_OPT) +#define no_float_opt(p) has_mid_type_bit(T_Pair(p), T_NO_FLOAT_OPT) + +#define T_INTEGER_KEYS T_ALLOW_OTHER_KEYS +#define set_has_integer_keys(p) set_mid_type_bit(T_Pair(p), T_INTEGER_KEYS) +#define has_integer_keys(p) has_mid_type_bit(T_Pair(p), T_INTEGER_KEYS) + +#define T_SAFE_STEPPER (1 << (16 + 11)) +#define T_MID_SAFE_STEPPER (1 << 11) +#define is_safe_stepper(p) has_mid_type_bit(T_Slt(p), T_MID_SAFE_STEPPER) +#define set_safe_stepper(p) set_mid_type_bit(T_Slt(p), T_MID_SAFE_STEPPER) +#define clear_safe_stepper(p) clear_mid_type_bit(T_Slt(p), T_MID_SAFE_STEPPER) +#define is_safe_stepper_expr(p) has_mid_type_bit(T_Pair(p), T_MID_SAFE_STEPPER) +#define set_safe_stepper_expr(p) set_mid_type_bit(T_Pair(p), T_MID_SAFE_STEPPER) + +#define T_NO_BOOL_OPT T_MID_SAFE_STEPPER +#define set_no_bool_opt(p) set_mid_type_bit(T_Pair(p), T_NO_BOOL_OPT) +#define no_bool_opt(p) has_mid_type_bit(T_Pair(p), T_NO_BOOL_OPT) + +#define T_MAYBE_SAFE T_MID_SAFE_STEPPER +#define is_maybe_safe(p) has_mid_type_bit(T_Fnc(p), T_MAYBE_SAFE) +#define set_maybe_safe(p) set_mid_type_bit(T_Fnc(p), T_MAYBE_SAFE) + +#define T_PAIR_MACRO T_MID_SAFE_STEPPER +#define has_pair_macro(p) has_mid_type_bit(T_Mac(p), T_PAIR_MACRO) +#define set_has_pair_macro(p) set_mid_type_bit(T_Mac(p), T_PAIR_MACRO) + +#define T_WEAK_HASH T_MID_SAFE_STEPPER +#define set_weak_hash_table(p) set_mid_type_bit(T_Hsh(p), T_WEAK_HASH) +#define is_weak_hash_table(p) has_mid_type_bit(T_Hsh(p), T_WEAK_HASH) + +#define T_ALL_FLOAT T_MID_SAFE_STEPPER +#define is_all_float(p) has_mid_type_bit(T_Sym(p), T_ALL_FLOAT) +#define set_all_float(p) set_mid_type_bit(T_Sym(p), T_ALL_FLOAT) +#define set_all_integer_and_float(p) set_mid_type_bit(T_Sym(p), (T_ALL_INTEGER | T_ALL_FLOAT)) + +#define T_COPY_ARGS (1 << (16 + 12)) +#define T_MID_COPY_ARGS (1 << 12) +#define needs_copied_args(p) has_mid_type_bit(T_Ext(p), T_MID_COPY_ARGS) /* set via explicit T_COPY_ARGS */ +#define set_needs_copied_args(p) set_mid_type_bit(T_Pair(p), T_MID_COPY_ARGS) +#define clear_needs_copied_args(p) clear_mid_type_bit(T_Pair(p), T_MID_COPY_ARGS) +/* this marks something that might mess with its argument list, it should not be in the second byte */ + +#define T_GENSYM (1 << (16 + 13)) +#define T_MID_GENSYM (1 << 13) +#define is_gensym(p) has_mid_type_bit(T_Sym(p), T_MID_GENSYM) /* symbol is from gensym (GC-able etc) */ -#define T_FUNCLET T_GENSYM -#define T_MID_FUNCLET T_MID_GENSYM -#define is_funclet(p) has_mid_type_bit (T_Let (p), T_MID_FUNCLET) -#define set_funclet(p) set_mid_type_bit (T_Let (p), T_MID_FUNCLET) +#define T_FUNCLET T_GENSYM +#define T_MID_FUNCLET T_MID_GENSYM +#define is_funclet(p) has_mid_type_bit(T_Let(p), T_MID_FUNCLET) +#define set_funclet(p) set_mid_type_bit(T_Let(p), T_MID_FUNCLET) /* this marks a funclet */ -#define T_HASH_CHOSEN T_MID_GENSYM -#define hash_chosen(p) has_mid_type_bit (T_Hsh (p), T_HASH_CHOSEN) -#define hash_set_chosen(p) set_mid_type_bit (T_Hsh (p), T_HASH_CHOSEN) -#define hash_clear_chosen(p) clear_mid_type_bit (T_Hsh (p), T_HASH_CHOSEN) +#define T_HASH_CHOSEN T_MID_GENSYM +#define hash_chosen(p) has_mid_type_bit(T_Hsh(p), T_HASH_CHOSEN) +#define hash_set_chosen(p) set_mid_type_bit(T_Hsh(p), T_HASH_CHOSEN) +#define hash_clear_chosen(p) clear_mid_type_bit(T_Hsh(p), T_HASH_CHOSEN) -#define T_DOCUMENTED T_MID_GENSYM -#define is_documented(p) has_mid_type_bit (T_Str (p), T_DOCUMENTED) -#define set_documented(p) set_mid_type_bit (T_Str (p), T_DOCUMENTED) +#define T_DOCUMENTED T_MID_GENSYM +#define is_documented(p) has_mid_type_bit(T_Str(p), T_DOCUMENTED) +#define set_documented(p) set_mid_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_MID_GENSYM -#define is_fx_treed(p) has_mid_type_bit (T_Pair (p), T_FX_TREED) -#define set_fx_treed(p) set_mid_type_bit (T_Pair (p), T_FX_TREED) - -#define T_SUBVECTOR T_GENSYM -#define T_MID_SUBVECTOR T_MID_GENSYM -#define is_subvector(p) has_mid_type_bit (T_Vec (p), T_MID_SUBVECTOR) - -#define T_HAS_PENDING_VALUE T_MID_GENSYM -#define slot_set_has_pending_value(p) \ - set_mid_type_bit (T_Slt (p), T_HAS_PENDING_VALUE) -#define slot_has_pending_value(p) \ - has_mid_type_bit (T_Slt (p), T_HAS_PENDING_VALUE) -#define slot_clear_has_pending_value(p) \ - do { \ - clear_mid_type_bit (T_Slt (p), T_HAS_PENDING_VALUE); \ - slot_set_pending_value (p, sc->F); \ - } while (0) -#define slot_has_setter_or_pending_value(p) \ - has_mid_type_bit (T_Slt (p), T_HAS_SETTER | T_HAS_PENDING_VALUE) - -#define T_HAS_METHODS (1 << (16 + 14)) -#define T_MID_HAS_METHODS (1 << 14) -#define has_methods(p) \ - has_mid_type_bit (T_Exs (p), \ - T_MID_HAS_METHODS) /* display slot hits T_Ext here */ -#define has_methods_unchecked(p) has_mid_type_bit (p, T_MID_HAS_METHODS) -#define is_openlet(p) has_mid_type_bit (T_Let (p), T_MID_HAS_METHODS) -#define has_active_methods(Sc, p) \ - ((has_mid_type_bit (T_Ext (p), T_MID_HAS_METHODS)) && \ - (Sc->has_openlets)) /* g_char # */ -#define set_has_methods(p) set_mid_type_bit (T_Met (p), T_MID_HAS_METHODS) -#define clear_has_methods(p) clear_mid_type_bit (T_Met (p), T_MID_HAS_METHODS) -/* this marks a let or closure that is "open" for generic functions etc, don't - * reuse this bit */ - -#define mid_type(p) (p)->tf.bits.mid_bits -#define T_HAS_LET_SET_FALLBACK T_SAFE_STEPPER -#define T_MID_HAS_LET_SET_FALLBACK T_MID_SAFE_STEPPER -#define T_HAS_LET_REF_FALLBACK T_MUTABLE -#define T_MID_HAS_LET_REF_FALLBACK T_MID_MUTABLE -#define has_let_ref_fallback(p) \ - ((mid_type (T_Let (p)) & \ - (T_MID_HAS_LET_REF_FALLBACK | T_MID_HAS_METHODS)) == \ - (T_MID_HAS_LET_REF_FALLBACK | T_MID_HAS_METHODS)) -#define has_let_set_fallback(p) \ - ((mid_type (T_Let (p)) & \ - (T_MID_HAS_LET_SET_FALLBACK | T_MID_HAS_METHODS)) == \ - (T_MID_HAS_LET_SET_FALLBACK | T_MID_HAS_METHODS)) -#define set_has_let_ref_fallback(p) \ - set_mid_type_bit (T_Let (p), T_MID_HAS_LET_REF_FALLBACK) -#define set_has_let_set_fallback(p) \ - set_mid_type_bit (T_Let (p), T_MID_HAS_LET_SET_FALLBACK) -#define has_let_fallback(p) \ - has_mid_type_bit (T_Let (p), \ - (T_MID_HAS_LET_REF_FALLBACK | T_MID_HAS_LET_SET_FALLBACK)) -#define set_all_methods(p, Let) \ - mid_type (T_Let (p))|= \ - (mid_type (Let) & (T_MID_HAS_METHODS | T_MID_HAS_LET_REF_FALLBACK | \ - T_MID_HAS_LET_SET_FALLBACK)) - -#define T_ITER_OK (1LL << (16 + 15)) -#define T_MID_ITER_OK (1 << 15) -#define iter_ok(p) has_mid_type_bit (T_Itr (p), T_MID_ITER_OK) -#define clear_iter_ok(p) clear_mid_type_bit (T_Itr (p), T_MID_ITER_OK) - -#define T_LOOP_END_POSSIBLE T_MID_ITER_OK -#define loop_end_possible(p) has_mid_type_bit (T_Pair (p), T_LOOP_END_POSSIBLE) -#define set_loop_end_possible(p) \ - set_mid_type_bit (T_Pair (p), T_LOOP_END_POSSIBLE) - -#define T_IN_ROOTLET T_MID_ITER_OK -#define in_rootlet(p) has_mid_type_bit (T_Slt (p), T_IN_ROOTLET) -#define set_in_rootlet(p) set_mid_type_bit (T_Slt (p), T_IN_ROOTLET) - -#define T_BOOL_FUNCTION T_MID_ITER_OK -#define is_bool_function(p) has_mid_type_bit (T_Prc (p), T_BOOL_FUNCTION) -#define set_is_bool_function(p) set_mid_type_bit (T_CFn (p), T_BOOL_FUNCTION) - -#define T_SYMBOL_FROM_SYMBOL T_MID_ITER_OK -#define is_symbol_from_symbol(p) \ - has_mid_type_bit (T_Sym (p), T_SYMBOL_FROM_SYMBOL) -#define set_is_symbol_from_symbol(p) \ - set_mid_type_bit (T_Sym (p), T_SYMBOL_FROM_SYMBOL) -#define clear_symbol_from_symbol(p) \ - clear_mid_type_bit (T_Sym (p), \ - T_SYMBOL_FROM_SYMBOL) /* was high_type?? 20-Dec-23 */ +#define T_FX_TREED T_MID_GENSYM +#define is_fx_treed(p) has_mid_type_bit(T_Pair(p), T_FX_TREED) +#define set_fx_treed(p) set_mid_type_bit(T_Pair(p), T_FX_TREED) + +#define T_SUBVECTOR T_GENSYM +#define T_MID_SUBVECTOR T_MID_GENSYM +#define is_subvector(p) has_mid_type_bit(T_Vec(p), T_MID_SUBVECTOR) + +#define T_HAS_PENDING_VALUE T_MID_GENSYM +#define slot_set_has_pending_value(p) set_mid_type_bit(T_Slt(p), T_HAS_PENDING_VALUE) +#define slot_has_pending_value(p) has_mid_type_bit(T_Slt(p), T_HAS_PENDING_VALUE) +#define slot_clear_has_pending_value(p) do {clear_mid_type_bit(T_Slt(p), T_HAS_PENDING_VALUE); slot_set_pending_value(p, sc->F);} while (0) +#define slot_has_setter_or_pending_value(p) has_mid_type_bit(T_Slt(p), T_HAS_SETTER | T_HAS_PENDING_VALUE) + +#define T_HAS_METHODS (1 << (16 + 14)) +#define T_MID_HAS_METHODS (1 << 14) +#define has_methods(p) has_mid_type_bit(T_Exs(p), T_MID_HAS_METHODS) /* display slot hits T_Ext here */ +#define has_methods_unchecked(p) has_mid_type_bit(p, T_MID_HAS_METHODS) +#define is_openlet(p) has_mid_type_bit(T_Let(p), T_MID_HAS_METHODS) +#define has_active_methods(Sc, p) ((has_mid_type_bit(T_Ext(p), T_MID_HAS_METHODS)) && (Sc->has_openlets)) /* g_char # */ +#define set_has_methods(p) set_mid_type_bit(T_Met(p), T_MID_HAS_METHODS) +#define clear_has_methods(p) clear_mid_type_bit(T_Met(p), T_MID_HAS_METHODS) +/* this marks a let or closure that is "open" for generic functions etc, don't reuse this bit */ + +#define mid_type(p) (p)->tf.bits.mid_bits +#define T_HAS_LET_SET_FALLBACK T_SAFE_STEPPER +#define T_MID_HAS_LET_SET_FALLBACK T_MID_SAFE_STEPPER +#define T_HAS_LET_REF_FALLBACK T_MUTABLE +#define T_MID_HAS_LET_REF_FALLBACK T_MID_MUTABLE +#define has_let_ref_fallback(p) ((mid_type(T_Let(p)) & (T_MID_HAS_LET_REF_FALLBACK | T_MID_HAS_METHODS)) == (T_MID_HAS_LET_REF_FALLBACK | T_MID_HAS_METHODS)) +#define has_let_set_fallback(p) ((mid_type(T_Let(p)) & (T_MID_HAS_LET_SET_FALLBACK | T_MID_HAS_METHODS)) == (T_MID_HAS_LET_SET_FALLBACK | T_MID_HAS_METHODS)) +#define set_has_let_ref_fallback(p) set_mid_type_bit(T_Let(p), T_MID_HAS_LET_REF_FALLBACK) +#define set_has_let_set_fallback(p) set_mid_type_bit(T_Let(p), T_MID_HAS_LET_SET_FALLBACK) +#define has_let_fallback(p) has_mid_type_bit(T_Let(p), (T_MID_HAS_LET_REF_FALLBACK | T_MID_HAS_LET_SET_FALLBACK)) +#define set_all_methods(p, Let) mid_type(T_Let(p)) |= (mid_type(Let) & (T_MID_HAS_METHODS | T_MID_HAS_LET_REF_FALLBACK | T_MID_HAS_LET_SET_FALLBACK)) + +#define T_ITER_OK (1LL << (16 + 15)) +#define T_MID_ITER_OK (1 << 15) +#define iter_ok(p) has_mid_type_bit(T_Itr(p), T_MID_ITER_OK) +#define clear_iter_ok(p) clear_mid_type_bit(T_Itr(p), T_MID_ITER_OK) + +#define T_LOOP_END_POSSIBLE T_MID_ITER_OK +#define loop_end_possible(p) has_mid_type_bit(T_Pair(p), T_LOOP_END_POSSIBLE) +#define set_loop_end_possible(p) set_mid_type_bit(T_Pair(p), T_LOOP_END_POSSIBLE) + +#define T_IN_ROOTLET T_MID_ITER_OK +#define in_rootlet(p) has_mid_type_bit(T_Slt(p), T_IN_ROOTLET) +#define set_in_rootlet(p) set_mid_type_bit(T_Slt(p), T_IN_ROOTLET) + +#define T_BOOL_FUNCTION T_MID_ITER_OK +#define is_bool_function(p) has_mid_type_bit(T_Prc(p), T_BOOL_FUNCTION) +#define set_is_bool_function(p) set_mid_type_bit(T_CFn(p), T_BOOL_FUNCTION) + +#define T_SYMBOL_FROM_SYMBOL T_MID_ITER_OK +#define is_symbol_from_symbol(p) has_mid_type_bit(T_Sym(p), T_SYMBOL_FROM_SYMBOL) +#define set_is_symbol_from_symbol(p) set_mid_type_bit(T_Sym(p), T_SYMBOL_FROM_SYMBOL) +#define clear_symbol_from_symbol(p) clear_mid_type_bit(T_Sym(p), T_SYMBOL_FROM_SYMBOL) /* was high_type?? 20-Dec-23 */ + /* -------- high type bits -------- */ /* it's faster here to use the high_bits bits rather than typeflag bits */ -#define T_FULL_SYMCONS (1LL << (48 + 0)) -#define T_SYMCONS (1 << 0) -#define is_possibly_constant(p) has_high_type_bit (T_Sym (p), T_SYMCONS) -#define set_possibly_constant(p) set_high_type_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_high_type_bit (T_Prc (p), T_HAS_LET_ARG) -#define set_has_let_arg(p) set_high_type_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_high_type_bit (T_Hsh (p), T_HASH_VALUE_TYPE) -#define set_has_hash_value_type(p) \ - set_high_type_bit (T_Hsh (p), T_HASH_VALUE_TYPE) - -#define T_INT_OPTABLE T_SYMCONS -#define is_int_optable(p) has_high_type_bit (T_Pair (p), T_INT_OPTABLE) -#define set_is_int_optable(p) set_high_type_bit (T_Pair (p), T_INT_OPTABLE) - -#define T_UNLET T_SYMCONS -#define is_unlet(p) has_high_type_bit (T_Let (p), T_UNLET) -#define set_is_unlet(p) set_high_type_bit (T_Let (p), T_UNLET) - -#define T_SYMBOL_TABLE T_SYMCONS -#define is_symbol_table(p) has_high_type_bit (T_Nvc (p), T_SYMBOL_TABLE) -#define set_is_symbol_table(p) set_high_type_bit (T_Nvc (p), T_SYMBOL_TABLE) - -#define T_FULL_HAS_LET_FILE (1LL << (48 + 1)) -#define T_HAS_LET_FILE (1 << 1) -#define has_let_file(p) has_high_type_bit (T_Let (p), T_HAS_LET_FILE) -#define set_has_let_file(p) set_high_type_bit (T_Let (p), T_HAS_LET_FILE) -#define clear_has_let_file(p) clear_high_type_bit (T_Let (p), T_HAS_LET_FILE) - -#define T_TYPED_VECTOR T_HAS_LET_FILE -#define is_typed_vector(p) has_high_type_bit (T_Nvc (p), T_TYPED_VECTOR) -#define is_typed_t_vector(p) ((is_t_vector (p)) && (is_typed_vector (p))) -#define set_typed_vector(p) set_high_type_bit (T_Nvc (p), T_TYPED_VECTOR) -#define clear_typed_vector(p) clear_high_type_bit (T_Nvc (p), T_TYPED_VECTOR) - -#define T_TYPED_HASH_TABLE T_HAS_LET_FILE -#define is_typed_hash_table(p) has_high_type_bit (T_Hsh (p), T_TYPED_HASH_TABLE) -#define set_is_typed_hash_table(p) \ - set_high_type_bit (T_Hsh (p), T_TYPED_HASH_TABLE) -#define clear_is_typed_hash_table(p) \ - clear_high_type_bit (T_Hsh (p), T_TYPED_HASH_TABLE) - -#define T_BOOL_SETTER T_HAS_LET_FILE -#define c_function_has_bool_setter(p) \ - has_high_type_bit (T_CFn (p), T_BOOL_SETTER) -#define c_function_set_has_bool_setter(p) \ - set_high_type_bit (T_CFn (p), T_BOOL_SETTER) - -#define T_REST_SLOT T_HAS_LET_FILE -#define is_rest_slot(p) has_high_type_bit (T_Slt (p), T_REST_SLOT) -#define set_is_rest_slot(p) set_high_type_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_high_type_bit (T_Pcs (p), T_NO_DEFAULTS) -#define set_has_no_defaults(p) set_high_type_bit (T_Pcs (p), T_NO_DEFAULTS) +#define T_FULL_SYMCONS (1LL << (48 + 0)) +#define T_SYMCONS (1 << 0) +#define is_possibly_constant(p) has_high_type_bit(T_Sym(p), T_SYMCONS) +#define set_possibly_constant(p) set_high_type_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_high_type_bit(T_Prc(p), T_HAS_LET_ARG) +#define set_has_let_arg(p) set_high_type_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_high_type_bit(T_Hsh(p), T_HASH_VALUE_TYPE) +#define set_has_hash_value_type(p) set_high_type_bit(T_Hsh(p), T_HASH_VALUE_TYPE) + +#define T_INT_OPTABLE T_SYMCONS +#define is_int_optable(p) has_high_type_bit(T_Pair(p), T_INT_OPTABLE) +#define set_is_int_optable(p) set_high_type_bit(T_Pair(p), T_INT_OPTABLE) + +#define T_UNLET T_SYMCONS +#define is_unlet(p) has_high_type_bit(T_Let(p), T_UNLET) +#define set_is_unlet(p) set_high_type_bit(T_Let(p), T_UNLET) + +#define T_SYMBOL_TABLE T_SYMCONS +#define is_symbol_table(p) has_high_type_bit(T_Nvc(p), T_SYMBOL_TABLE) +#define set_is_symbol_table(p) set_high_type_bit(T_Nvc(p), T_SYMBOL_TABLE) + +#define T_FULL_HAS_LET_FILE (1LL << (48 + 1)) +#define T_HAS_LET_FILE (1 << 1) +#define has_let_file(p) has_high_type_bit(T_Let(p), T_HAS_LET_FILE) +#define set_has_let_file(p) set_high_type_bit(T_Let(p), T_HAS_LET_FILE) +#define clear_has_let_file(p) clear_high_type_bit(T_Let(p), T_HAS_LET_FILE) + +#define T_TYPED_VECTOR T_HAS_LET_FILE +#define is_typed_vector(p) has_high_type_bit(T_Nvc(p), T_TYPED_VECTOR) +#define is_typed_t_vector(p) ((is_t_vector(p)) && (is_typed_vector(p))) +#define set_typed_vector(p) set_high_type_bit(T_Nvc(p), T_TYPED_VECTOR) +#define clear_typed_vector(p) clear_high_type_bit(T_Nvc(p), T_TYPED_VECTOR) + +#define T_TYPED_HASH_TABLE T_HAS_LET_FILE +#define is_typed_hash_table(p) has_high_type_bit(T_Hsh(p), T_TYPED_HASH_TABLE) +#define set_is_typed_hash_table(p) set_high_type_bit(T_Hsh(p), T_TYPED_HASH_TABLE) +#define clear_is_typed_hash_table(p) clear_high_type_bit(T_Hsh(p), T_TYPED_HASH_TABLE) + +#define T_BOOL_SETTER T_HAS_LET_FILE +#define c_function_has_bool_setter(p) has_high_type_bit(T_CFn(p), T_BOOL_SETTER) +#define c_function_set_has_bool_setter(p) set_high_type_bit(T_CFn(p), T_BOOL_SETTER) + +#define T_REST_SLOT T_HAS_LET_FILE +#define is_rest_slot(p) has_high_type_bit(T_Slt(p), T_REST_SLOT) +#define set_is_rest_slot(p) set_high_type_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_high_type_bit(T_Pcs(p), T_NO_DEFAULTS) +#define set_has_no_defaults(p) set_high_type_bit(T_Pcs(p), T_NO_DEFAULTS) /* pair=closure* body, transferred to closure* */ -#define T_FULL_DEFINER (1LL << (48 + 2)) -#define T_DEFINER (1 << 2) -#define is_definer(p) has_high_type_bit (T_Sym (p), T_DEFINER) -#define set_is_definer(p) set_high_type_bit (T_Sym (p), T_DEFINER) -#define is_func_definer(p) has_high_type_bit (T_CFn (p), T_DEFINER) -#define set_func_is_definer(p) \ - do { \ - set_high_type_bit (T_CFn (initial_value (p)), T_DEFINER); \ - set_high_type_bit (T_Sym (p), T_DEFINER); \ - } while (0) -#define is_syntax_definer(p) has_high_type_bit (T_Syn (p), T_DEFINER) -#define set_syntax_is_definer(p) \ - do { \ - set_high_type_bit (T_Syn (initial_value (p)), T_DEFINER); \ - set_high_type_bit (T_Sym (p), T_DEFINER); \ - } while (0) +#define T_FULL_DEFINER (1LL << (48 + 2)) +#define T_DEFINER (1 << 2) +#define is_definer(p) has_high_type_bit(T_Sym(p), T_DEFINER) +#define set_is_definer(p) set_high_type_bit(T_Sym(p), T_DEFINER) +#define is_func_definer(p) has_high_type_bit(T_CFn(p), T_DEFINER) +#define set_func_is_definer(p) do {set_high_type_bit(T_CFn(initial_value(p)), T_DEFINER); set_high_type_bit(T_Sym(p), T_DEFINER);} while (0) +#define is_syntax_definer(p) has_high_type_bit(T_Syn(p), T_DEFINER) +#define set_syntax_is_definer(p) do {set_high_type_bit(T_Syn(initial_value(p)), T_DEFINER); set_high_type_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_high_type_bit (T_Let (p), T_MACLET) -#define set_maclet(p) set_high_type_bit (T_Let (p), T_MACLET) - -#define T_HAS_FX T_DEFINER -#define set_has_fx(p) set_high_type_bit (T_Pair (p), T_HAS_FX) -#define has_fx(p) has_high_type_bit (T_Pair (p), T_HAS_FX) -#define clear_has_fx(p) clear_high_type_bit (T_Pair (p), T_HAS_FX) - -#define T_SLOT_DEFAULTS T_DEFINER -#define slot_defaults(p) has_high_type_bit (T_Slt (p), T_SLOT_DEFAULTS) -#define set_slot_defaults(p) set_high_type_bit (T_Slt (p), T_SLOT_DEFAULTS) - -#define T_WEAK_HASH_ITERATOR T_DEFINER -#define is_weak_hash_iterator(p) \ - has_high_type_bit (T_Itr (p), T_WEAK_HASH_ITERATOR) -#define set_weak_hash_iterator(p) \ - set_high_type_bit (T_Itr (p), T_WEAK_HASH_ITERATOR) -#define clear_weak_hash_iterator(p) \ - clear_high_type_bit (T_Itr (p), T_WEAK_HASH_ITERATOR) - -#define T_HASH_KEY_TYPE T_DEFINER -#define has_hash_key_type(p) has_high_type_bit (T_Hsh (p), T_HASH_KEY_TYPE) -#define set_has_hash_key_type(p) set_high_type_bit (T_Hsh (p), T_HASH_KEY_TYPE) - -#define T_FULL_BINDER (1LL << (48 + 3)) -#define T_BINDER (1 << 3) -#define set_syntax_is_binder(p) \ - do { \ - set_high_type_bit (T_Syn (initial_value (p)), T_BINDER); \ - set_high_type_bit (T_Sym (p), T_BINDER); \ - } while (0) -#define is_definer_or_binder(p) \ - has_high_type_bit (T_Sym (p), T_DEFINER | T_BINDER) +#define T_MACLET T_DEFINER +#define is_maclet(p) has_high_type_bit(T_Let(p), T_MACLET) +#define set_maclet(p) set_high_type_bit(T_Let(p), T_MACLET) + +#define T_HAS_FX T_DEFINER +#define set_has_fx(p) set_high_type_bit(T_Pair(p), T_HAS_FX) +#define has_fx(p) has_high_type_bit(T_Pair(p), T_HAS_FX) +#define clear_has_fx(p) clear_high_type_bit(T_Pair(p), T_HAS_FX) + +#define T_SLOT_DEFAULTS T_DEFINER +#define slot_defaults(p) has_high_type_bit(T_Slt(p), T_SLOT_DEFAULTS) +#define set_slot_defaults(p) set_high_type_bit(T_Slt(p), T_SLOT_DEFAULTS) + +#define T_WEAK_HASH_ITERATOR T_DEFINER +#define is_weak_hash_iterator(p) has_high_type_bit(T_Itr(p), T_WEAK_HASH_ITERATOR) +#define set_weak_hash_iterator(p) set_high_type_bit(T_Itr(p), T_WEAK_HASH_ITERATOR) +#define clear_weak_hash_iterator(p) clear_high_type_bit(T_Itr(p), T_WEAK_HASH_ITERATOR) + +#define T_HASH_KEY_TYPE T_DEFINER +#define has_hash_key_type(p) has_high_type_bit(T_Hsh(p), T_HASH_KEY_TYPE) +#define set_has_hash_key_type(p) set_high_type_bit(T_Hsh(p), T_HASH_KEY_TYPE) + +#define T_FULL_BINDER (1LL << (48 + 3)) +#define T_BINDER (1 << 3) +#define set_syntax_is_binder(p) do {set_high_type_bit(T_Syn(initial_value(p)), T_BINDER); set_high_type_bit(T_Sym(p), T_BINDER);} while (0) +#define is_definer_or_binder(p) has_high_type_bit(T_Sym(p), T_DEFINER | T_BINDER) /* this marks "binders" like let */ -#define T_SEMISAFE T_BINDER -#define is_semisafe(p) has_high_type_bit (T_CFn (p), T_SEMISAFE) -#define set_is_semisafe(p) set_high_type_bit (T_CFn (p), T_SEMISAFE) +#define T_SEMISAFE T_BINDER +#define is_semisafe(p) has_high_type_bit(T_CFn(p), T_SEMISAFE) +#define set_is_semisafe(p) set_high_type_bit(T_CFn(p), T_SEMISAFE) /* #define T_TREE_COLLECTED T_FULL_BINDER */ -#define T_SHORT_TREE_COLLECTED T_BINDER -#define tree_is_collected(p) \ - has_high_type_bit (T_Pair (p), T_SHORT_TREE_COLLECTED) -#define tree_set_collected(p) \ - set_high_type_bit (T_Pair (p), T_SHORT_TREE_COLLECTED) -#define tree_clear_collected(p) \ - clear_high_type_bit (T_Pair (p), T_SHORT_TREE_COLLECTED) - -#define T_SIMPLE_VALUES T_BINDER -#define has_simple_values(p) has_high_type_bit (T_Hsh (p), T_SIMPLE_VALUES) -#define set_has_simple_values(p) set_high_type_bit (T_Hsh (p), T_SIMPLE_VALUES) -#define clear_has_simple_values(p) \ - clear_high_type_bit (T_Hsh (p), T_SIMPLE_VALUES) - -#define T_VERY_SAFE_CLOSURE (1LL << (48 + 4)) -#define T_SHORT_VERY_SAFE_CLOSURE (1 << 4) -#define is_very_safe_closure(p) \ - has_high_type_bit (T_Clo (p), T_SHORT_VERY_SAFE_CLOSURE) -#define set_very_safe_closure(p) \ - set_high_type_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_high_type_bit (T_Pair (p), T_SHORT_VERY_SAFE_CLOSURE) -#define set_very_safe_closure_body(p) \ - set_high_type_bit (T_Pair (p), T_SHORT_VERY_SAFE_CLOSURE) - -#define T_BAFFLE_LET T_SHORT_VERY_SAFE_CLOSURE -#define is_baffle_let(p) has_high_type_bit (T_Let (p), T_BAFFLE_LET) -#define set_baffle_let(p) set_high_type_bit (T_Let (p), T_BAFFLE_LET) - -#define T_CYCLIC (1LL << (48 + 5)) -#define T_SHORT_CYCLIC (1 << 5) -#define is_cyclic(p) has_high_type_bit (T_Seq (p), T_SHORT_CYCLIC) -#define set_cyclic(p) set_high_type_bit (T_Seq (p), T_SHORT_CYCLIC) - -#define T_CYCLIC_SET (1LL << (48 + 6)) -#define T_SHORT_CYCLIC_SET (1 << 6) -#define is_cyclic_set(p) has_high_type_bit (T_Seq (p), T_SHORT_CYCLIC_SET) -#define set_cyclic_set(p) set_high_type_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) /* not T_Seq, p can be free(!) */ - -#define T_KEYWORD (1LL << (48 + 7)) -#define T_SHORT_KEYWORD (1 << 7) -#define is_keyword(p) has_high_type_bit (T_Sym (p), T_SHORT_KEYWORD) -#define is_symbol_and_keyword(p) ((is_symbol (p)) && (is_keyword (p))) +#define T_SHORT_TREE_COLLECTED T_BINDER +#define tree_is_collected(p) has_high_type_bit(T_Pair(p), T_SHORT_TREE_COLLECTED) +#define tree_set_collected(p) set_high_type_bit(T_Pair(p), T_SHORT_TREE_COLLECTED) +#define tree_clear_collected(p) clear_high_type_bit(T_Pair(p), T_SHORT_TREE_COLLECTED) + +#define T_SIMPLE_VALUES T_BINDER +#define has_simple_values(p) has_high_type_bit(T_Hsh(p), T_SIMPLE_VALUES) +#define set_has_simple_values(p) set_high_type_bit(T_Hsh(p), T_SIMPLE_VALUES) +#define clear_has_simple_values(p) clear_high_type_bit(T_Hsh(p), T_SIMPLE_VALUES) + +#define T_VERY_SAFE_CLOSURE (1LL << (48 + 4)) +#define T_SHORT_VERY_SAFE_CLOSURE (1 << 4) +#define is_very_safe_closure(p) has_high_type_bit(T_Clo(p), T_SHORT_VERY_SAFE_CLOSURE) +#define set_very_safe_closure(p) set_high_type_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_high_type_bit(T_Pair(p), T_SHORT_VERY_SAFE_CLOSURE) +#define set_very_safe_closure_body(p) set_high_type_bit(T_Pair(p), T_SHORT_VERY_SAFE_CLOSURE) + +#define T_BAFFLE_LET T_SHORT_VERY_SAFE_CLOSURE +#define is_baffle_let(p) has_high_type_bit(T_Let(p), T_BAFFLE_LET) +#define set_baffle_let(p) set_high_type_bit(T_Let(p), T_BAFFLE_LET) + +#define T_CYCLIC (1LL << (48 + 5)) +#define T_SHORT_CYCLIC (1 << 5) +#define is_cyclic(p) has_high_type_bit(T_Seq(p), T_SHORT_CYCLIC) +#define set_cyclic(p) set_high_type_bit(T_Seq(p), T_SHORT_CYCLIC) + +#define T_CYCLIC_SET (1LL << (48 + 6)) +#define T_SHORT_CYCLIC_SET (1 << 6) +#define is_cyclic_set(p) has_high_type_bit(T_Seq(p), T_SHORT_CYCLIC_SET) +#define set_cyclic_set(p) set_high_type_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) /* not T_Seq, p can be free(!) */ + +#define T_KEYWORD (1LL << (48 + 7)) +#define T_SHORT_KEYWORD (1 << 7) +#define is_keyword(p) has_high_type_bit(T_Sym(p), T_SHORT_KEYWORD) +#define is_symbol_and_keyword(p) ((is_symbol(p)) && (is_keyword(p))) /* this bit distinguishes a symbol from a symbol that is also a keyword */ -#define T_FX_TREEABLE T_SHORT_KEYWORD -#define is_fx_treeable(p) has_high_type_bit (T_Pair (p), T_FX_TREEABLE) -#define set_is_fx_treeable(p) set_high_type_bit (T_Pair (p), T_FX_TREEABLE) - -#define T_FULL_SIMPLE_ELEMENTS (1LL << (48 + 8)) -#define T_SIMPLE_ELEMENTS (1 << 8) -#define has_simple_elements(p) has_high_type_bit (T_Nvc (p), T_SIMPLE_ELEMENTS) -#define set_has_simple_elements(p) \ - set_high_type_bit (T_Nvc (p), T_SIMPLE_ELEMENTS) -#define clear_has_simple_elements(p) \ - clear_high_type_bit (T_Nvc (p), T_SIMPLE_ELEMENTS) -#define c_function_has_simple_elements(p) \ - has_high_type_bit (T_CFn (p), T_SIMPLE_ELEMENTS) -#define c_function_set_has_simple_elements(p) \ - set_high_type_bit (T_CFn (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_high_type_bit (T_Hsh (p), T_SIMPLE_KEYS) -#define set_has_simple_keys(p) set_high_type_bit (T_Hsh (p), T_SIMPLE_KEYS) -#define clear_has_simple_keys(p) clear_high_type_bit (T_Hsh (p), T_SIMPLE_KEYS) - -#define T_SAFE_SETTER T_SIMPLE_ELEMENTS -#define is_safe_setter(p) has_high_type_bit (T_Sym (p), T_SAFE_SETTER) -#define set_is_safe_setter(p) set_high_type_bit (T_Sym (p), T_SAFE_SETTER) - -#define T_FLOAT_OPTABLE T_SIMPLE_ELEMENTS -#define is_float_optable(p) has_high_type_bit (T_Pair (p), T_FLOAT_OPTABLE) -#define set_is_float_optable(p) set_high_type_bit (T_Pair (p), T_FLOAT_OPTABLE) - -#define T_FULL_CASE_KEY (1LL << (48 + 9)) -#define T_CASE_KEY (1 << 9) -#define is_case_key(p) has_high_type_bit (T_Ext (p), T_CASE_KEY) -#define set_case_key(p) set_high_type_bit (T_Sym (p), T_CASE_KEY) - -#define T_OPT1_FUNC_LISTED T_CASE_KEY -#define opt1_func_listed(p) has_high_type_bit (T_Pair (p), T_OPT1_FUNC_LISTED) -#define set_opt1_func_listed(p) \ - set_high_type_bit (T_Pair (p), T_OPT1_FUNC_LISTED) - -#define T_FULL_TRUE_IS_DONE (1LL << (48 + 10)) -#define T_TRUE_IS_DONE (1 << 10) -#define true_is_done(p) has_high_type_bit (T_Pair (p), T_TRUE_IS_DONE) -#define set_true_is_done(p) set_high_type_bit (T_Pair (p), T_TRUE_IS_DONE) -#define set_a_is_cadr(p) set_true_is_done (p) -#define a_is_cadr(p) true_is_done (p) +#define T_FX_TREEABLE T_SHORT_KEYWORD +#define is_fx_treeable(p) has_high_type_bit(T_Pair(p), T_FX_TREEABLE) +#define set_is_fx_treeable(p) set_high_type_bit(T_Pair(p), T_FX_TREEABLE) + +#define T_FULL_SIMPLE_ELEMENTS (1LL << (48 + 8)) +#define T_SIMPLE_ELEMENTS (1 << 8) +#define has_simple_elements(p) has_high_type_bit(T_Nvc(p), T_SIMPLE_ELEMENTS) +#define set_has_simple_elements(p) set_high_type_bit(T_Nvc(p), T_SIMPLE_ELEMENTS) +#define clear_has_simple_elements(p) clear_high_type_bit(T_Nvc(p), T_SIMPLE_ELEMENTS) +#define c_function_has_simple_elements(p) has_high_type_bit(T_CFn(p), T_SIMPLE_ELEMENTS) +#define c_function_set_has_simple_elements(p) set_high_type_bit(T_CFn(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_high_type_bit(T_Hsh(p), T_SIMPLE_KEYS) +#define set_has_simple_keys(p) set_high_type_bit(T_Hsh(p), T_SIMPLE_KEYS) +#define clear_has_simple_keys(p) clear_high_type_bit(T_Hsh(p), T_SIMPLE_KEYS) + +#define T_SAFE_SETTER T_SIMPLE_ELEMENTS +#define is_safe_setter(p) has_high_type_bit(T_Sym(p), T_SAFE_SETTER) +#define set_is_safe_setter(p) set_high_type_bit(T_Sym(p), T_SAFE_SETTER) + +#define T_FLOAT_OPTABLE T_SIMPLE_ELEMENTS +#define is_float_optable(p) has_high_type_bit(T_Pair(p), T_FLOAT_OPTABLE) +#define set_is_float_optable(p) set_high_type_bit(T_Pair(p), T_FLOAT_OPTABLE) + +#define T_FULL_CASE_KEY (1LL << (48 + 9)) +#define T_CASE_KEY (1 << 9) +#define is_case_key(p) has_high_type_bit(T_Ext(p), T_CASE_KEY) +#define set_case_key(p) set_high_type_bit(T_Sym(p), T_CASE_KEY) + +#define T_OPT1_FUNC_LISTED T_CASE_KEY +#define opt1_func_listed(p) has_high_type_bit(T_Pair(p), T_OPT1_FUNC_LISTED) +#define set_opt1_func_listed(p) set_high_type_bit(T_Pair(p), T_OPT1_FUNC_LISTED) + +#define T_FULL_TRUE_IS_DONE (1LL << (48 + 10)) +#define T_TRUE_IS_DONE (1 << 10) +#define true_is_done(p) has_high_type_bit(T_Pair(p), T_TRUE_IS_DONE) +#define set_true_is_done(p) set_high_type_bit(T_Pair(p), T_TRUE_IS_DONE) +#define set_a_is_cadr(p) set_true_is_done(p) +#define a_is_cadr(p) true_is_done(p) /* #define T_FULL_IS_SAVER T_FULL_TRUE_IS_DONE */ -#define T_IS_SAVER T_TRUE_IS_DONE -#define is_saver(p) has_high_type_bit (p, T_IS_SAVER) -#define set_is_saver(p) \ - do { \ - set_high_type_bit (T_Sym (p), T_IS_SAVER); \ - set_high_type_bit (T_Fnc (global_value (p)), T_IS_SAVER); \ - } while (0) +#define T_IS_SAVER T_TRUE_IS_DONE +#define is_saver(p) has_high_type_bit(p, T_IS_SAVER) +#define set_is_saver(p) do {set_high_type_bit(T_Sym(p), T_IS_SAVER); set_high_type_bit(T_Fnc(global_value(p)), T_IS_SAVER);} while (0) -#define T_FULL_UNKNOPT (1LL << (48 + 11)) -#define T_UNKNOPT (1 << 11) -#define is_unknopt(p) has_high_type_bit (T_Pair (p), T_UNKNOPT) -#define set_is_unknopt(p) set_high_type_bit (T_Pair (p), T_UNKNOPT) +#define T_FULL_UNKNOPT (1LL << (48 + 11)) +#define T_UNKNOPT (1 << 11) +#define is_unknopt(p) has_high_type_bit(T_Pair(p), T_UNKNOPT) +#define set_is_unknopt(p) set_high_type_bit(T_Pair(p), T_UNKNOPT) /* #define T_FULL_IS_TRANSLUCENT T_FULL_UNKNOPT */ -#define T_IS_TRANSLUCENT T_UNKNOPT -#define is_translucent(p) \ - (((is_symbol (p)) || (is_c_function (p))) && \ - (has_high_type_bit (p, T_IS_TRANSLUCENT))) -#define set_is_translucent(p) \ - do { \ - set_high_type_bit (T_Sym (p), T_IS_TRANSLUCENT); \ - set_high_type_bit (T_Fnc (global_value (p)), T_IS_TRANSLUCENT); \ - } while (0) - -#define T_MAC_OK T_UNKNOPT -#define mac_is_ok(p) has_high_type_bit (T_Pair (p), T_MAC_OK) -#define set_mac_is_ok(p) set_high_type_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 << (48 + 12)) -#define T_SAFETY_CHECKED (1 << 12) -#define is_safety_checked(p) has_high_type_bit (T_Pair (p), T_SAFETY_CHECKED) -#define set_safety_checked(p) \ - do { \ - if (in_heap (p)) set_high_type_bit (T_Pair (p), T_SAFETY_CHECKED); \ - } while (0) - -#define T_SETTER T_SAFETY_CHECKED -#define set_is_setter(p) \ - do { \ - set_high_type_bit (T_Sym (p), T_SETTER); \ - set_high_type_bit (global_value (p), T_SETTER); \ - } while (0) -#define is_setter(p) ((has_high_type_bit (p, T_SETTER)) && (!is_pair (p))) -/* optimizer flag for a procedure that sets some variable (set-car! for example) - */ - -#define T_FULL_HAS_FN (1LL << (48 + 13)) -#define T_HAS_FN (1 << 13) -#define set_has_fn(p) set_high_type_bit (T_Pair (p), T_HAS_FN) -#define has_fn(p) has_high_type_bit (T_Pair (p), T_HAS_FN) -#define clear_has_fn(p) clear_high_type_bit (T_Pair (p), T_HAS_FN) +#define T_IS_TRANSLUCENT T_UNKNOPT +#define is_translucent(p) (((is_symbol(p)) || (is_c_function(p))) && (has_high_type_bit(p, T_IS_TRANSLUCENT))) +#define set_is_translucent(p) do {set_high_type_bit(T_Sym(p), T_IS_TRANSLUCENT); set_high_type_bit(T_Fnc(global_value(p)), T_IS_TRANSLUCENT);} while (0) + +#define T_MAC_OK T_UNKNOPT +#define mac_is_ok(p) has_high_type_bit(T_Pair(p), T_MAC_OK) +#define set_mac_is_ok(p) set_high_type_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 << (48 + 12)) +#define T_SAFETY_CHECKED (1 << 12) +#define is_safety_checked(p) has_high_type_bit(T_Pair(p), T_SAFETY_CHECKED) +#define set_safety_checked(p) do {if (in_heap(p)) set_high_type_bit(T_Pair(p), T_SAFETY_CHECKED);} while (0) + +#define T_SETTER T_SAFETY_CHECKED +#define set_is_setter(p) do {set_high_type_bit(T_Sym(p), T_SETTER); set_high_type_bit(global_value(p), T_SETTER);} while (0) +#define is_setter(p) ((has_high_type_bit(p, T_SETTER)) && (!is_pair(p))) +/* optimizer flag for a procedure that sets some variable (set-car! for example) */ + +#define T_FULL_HAS_FN (1LL << (48 + 13)) +#define T_HAS_FN (1 << 13) +#define set_has_fn(p) set_high_type_bit(T_Pair(p), T_HAS_FN) +#define has_fn(p) has_high_type_bit(T_Pair(p), T_HAS_FN) +#define clear_has_fn(p) clear_high_type_bit(T_Pair(p), T_HAS_FN) /* #define T_FULL_IS_ESCAPER T_FULL_HAS_FN */ -#define T_IS_ESCAPER T_HAS_FN -#define is_escaper(p) ((has_high_type_bit (p, T_IS_ESCAPER)) && (!is_pair (p))) -#define set_is_escaper_syntax(p) \ - do { \ - set_high_type_bit (T_Sym (p), T_IS_ESCAPER); \ - set_high_type_bit (T_Syn (global_value (p)), T_IS_ESCAPER); \ - } while (0) -#define set_is_escaper_function(p) \ - do { \ - set_high_type_bit (T_Sym (p), T_IS_ESCAPER); \ - set_high_type_bit (T_Fnc (global_value (p)), T_IS_ESCAPER); \ - } while (0) - -#define T_UNHEAP 0x4000000000000000 -#define T_SHORT_UNHEAP (1 << 14) -#define in_heap(p) \ - (((T_Pos (p))->tf.bits.high_bits & T_SHORT_UNHEAP) == \ - 0) /* can be slot, make_starlet let_set_slot */ -#define unheap(p) set_high_type_bit (T_Ext (p), T_SHORT_UNHEAP) - -#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 is_eof(p) ((T_Ext (p)) == eof_object) -#define is_true(Sc, p) ((T_Ext (p)) != Sc->F) -#define is_false(Sc, p) ((T_Ext (p)) == Sc->F) +#define T_IS_ESCAPER T_HAS_FN +#define is_escaper(p) ((has_high_type_bit(p, T_IS_ESCAPER)) && (!is_pair(p))) +#define set_is_escaper_syntax(p) do {set_high_type_bit(T_Sym(p), T_IS_ESCAPER); set_high_type_bit(T_Syn(global_value(p)), T_IS_ESCAPER);} while (0) +#define set_is_escaper_function(p) do {set_high_type_bit(T_Sym(p), T_IS_ESCAPER); set_high_type_bit(T_Fnc(global_value(p)), T_IS_ESCAPER);} while (0) + +#define T_UNHEAP 0x4000000000000000 +#define T_SHORT_UNHEAP (1 << 14) +#define in_heap(p) (((T_Pos(p))->tf.bits.high_bits & T_SHORT_UNHEAP) == 0) /* can be slot, make_starlet let_set_slot */ +#define unheap(p) set_high_type_bit(T_Ext(p), T_SHORT_UNHEAP) + +#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 is_eof(p) ((T_Ext(p)) == eof_object) +#define is_true(Sc, p) ((T_Ext(p)) != Sc->F) +#define is_false(Sc, p) ((T_Ext(p)) == Sc->F) #ifdef _MSC_VER -static s7_pointer -make_boolean (s7_scheme* sc, bool val) { - if (val) return (sc->T); - return (sc->F); -} + 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) + #define make_boolean(Sc, Val) ((Val) ? Sc->T : Sc->F) #endif -#define is_pair(p) (type (p) == T_PAIR) -#define is_mutable_pair(p) \ - ((is_pair (p)) && \ - (!is_immutable (p))) /* same speed: ((full_type(p) & (TYPE_MASK | \ - T_IMMUTABLE)) == T_PAIR) */ -#define is_null(p) ((T_Exs (p)) == sc->nil) -#define is_not_null(p) ((T_Exs (p)) != sc->nil) -#define is_list(p) ((is_pair (p)) || (type (p) == T_NIL)) -#define is_quote(Sc, p) \ - (((p) == Sc->quote_symbol) || \ - ((p) == Sc->quote_function)) /* order here apparently does not matter */ -#define is_safe_quote(Sc, p) \ - ((((p) == Sc->quote_symbol) && (is_global (Sc->quote_symbol))) || \ - ((p) == Sc->quote_function)) -#define is_quoted_pair(Sc, p) ((is_pair (p)) && (is_quote (Sc, car (p)))) -#define is_safe_quoted_pair(Sc, p) \ - ((is_pair (p)) && (is_safe_quote (Sc, car (p)))) -#define is_unquoted_pair(Sc, p) ((is_pair (p)) && (!is_quote (Sc, car (p)))) -#define is_quoted_symbol(Sc, p) \ - ((is_quoted_pair (Sc, p)) && (is_pair (cdr (p))) && (is_symbol (cadr (p)))) +#define is_pair(p) (type(p) == T_PAIR) +#define is_mutable_pair(p) ((is_pair(p)) && (!is_immutable(p))) /* same speed: ((full_type(p) & (TYPE_MASK | T_IMMUTABLE)) == T_PAIR) */ +#define is_null(p) ((T_Exs(p)) == sc->nil) +#define is_not_null(p) ((T_Exs(p)) != sc->nil) +#define is_list(p) ((is_pair(p)) || (type(p) == T_NIL)) +#define is_quote(Sc, p) (((p) == Sc->quote_symbol) || ((p) == Sc->quote_function)) /* order here apparently does not matter */ +#define is_safe_quote(Sc, p) ((((p) == Sc->quote_symbol) && (is_global(Sc->quote_symbol))) || ((p) == Sc->quote_function)) +#define is_quoted_pair(Sc, p) ((is_pair(p)) && (is_quote(Sc, car(p)))) +#define is_safe_quoted_pair(Sc, p) ((is_pair(p)) && (is_safe_quote(Sc, car(p)))) +#define is_unquoted_pair(Sc, p) ((is_pair(p)) && (!is_quote(Sc, car(p)))) +#define is_quoted_symbol(Sc, p) ((is_quoted_pair(Sc, p)) && (is_pair(cdr(p))) && (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(Port) \ - (((port_line_number (Port) & PAIR_LINE_MASK) << PAIR_LINE_OFFSET) | \ - ((port_file_number (Port) & PAIR_FILE_MASK) << PAIR_FILE_OFFSET) | \ - ((port_position (Port) & 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)) +#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(Port) (((port_line_number(Port) & PAIR_LINE_MASK) << PAIR_LINE_OFFSET) | \ + ((port_file_number(Port) & PAIR_FILE_MASK) << PAIR_FILE_OFFSET) | \ + ((port_position(Port) & 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.o2.opt2) -#define set_opt2(p, x, r) (p)->object.cons.o2.opt2= (s7_pointer) (x) -#define opt2_n(p, r) ((p)->object.cons.o2.n) -#define set_opt2_n(p, x, r) (p)->object.cons.o2.n= x -#define opt3(p, r) ((p)->object.cons.o3.opt3) -#define set_opt3(p, x, r) \ - do { \ - (p)->object.cons.o3.opt3= x; \ - clear_type_bit (p, T_LOCATION); \ - } while (0) -#define opt3_n(p, r) ((p)->object.cons.o3.n) -#define set_opt3_n(p, x, r) \ - do { \ - (p)->object.cons.o3.n= x; \ - clear_type_bit (p, T_LOCATION); \ - } while (0) +#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.o2.opt2) +#define set_opt2(p, x, r) (p)->object.cons.o2.opt2 = (s7_pointer)(x) +#define opt2_n(p, r) ((p)->object.cons.o2.n) +#define set_opt2_n(p, x, r) (p)->object.cons.o2.n = x +#define opt3(p, r) ((p)->object.cons.o3.opt3) +#define set_opt3(p, x, r) do {(p)->object.cons.o3.opt3 = x; clear_type_bit(p, T_LOCATION);} while (0) +#define opt3_n(p, r) ((p)->object.cons.o3.n) +#define set_opt3_n(p, x, r) do {(p)->object.cons.o3.n = 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. +/* 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) /* hash code used in the symbol table (pair_raw_hash) */ -#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, __func__, __LINE__) - -#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) /* named used by symbol table (pair_raw_name) */ -#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 opt2_n(p, Role) opt2_n_1 (sc, T_Pair (p), Role, __func__, __LINE__) -#define set_opt2_n(p, x, Role) \ - set_opt2_n_1 (sc, T_Pair (p), 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 opt3_n(p, Role) opt3_n_1 (sc, T_Pair (p), Role, __func__, __LINE__) -#define set_opt3_n(p, x, Role) set_opt3_n_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_MASK (L_FUNC | L_DOX) +#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) /* hash code used in the symbol table (pair_raw_hash) */ +#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, __func__, __LINE__) + +#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) /* named used by symbol table (pair_raw_name) */ +#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 opt2_n(p, Role) opt2_n_1(sc, T_Pair(p), Role, __func__, __LINE__) +#define set_opt2_n(p, x, Role) set_opt2_n_1(sc, T_Pair(p), 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 opt3_n(p, Role) opt3_n_1(sc, T_Pair(p), Role, __func__, __LINE__) +#define set_opt3_n(p, x, Role) set_opt3_n_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_MASK (L_FUNC | L_DOX) #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_Exs (opt1 (P, OPT1_CFUNC)) -#define set_opt1_cfunc(P, X) set_opt1 (P, T_CFn (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_Exs (opt1 (P, OPT1_CLAUSE)) -#define set_opt1_clause(P, X) set_opt1 (P, T_Exs (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_Exs (opt1 (P, OPT1_CON)) -#define set_opt1_con(P, X) \ - set_opt1 (P, T_Exs (X), OPT1_CON) /* can be # */ -#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) opt2_n (P, OPT2_INT) -#define set_opt2_int(P, X) set_opt2_n (P, 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_Exs (opt2 (P, OPT2_CON)) -#define set_opt2_con(P, X) set_opt2 (P, T_Exs (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) opt3_n (P, OPT3_ARGLEN) -#define set_opt3_arglen(P, X) set_opt3_n (P, X, OPT3_ARGLEN) -#define opt3_int(P) opt3_n (P, OPT3_INT) -#define set_opt3_int(P, X) set_opt3_n (P, 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_Exs (opt3 (P, OPT3_CON)) -#define set_opt3_con(P, X) set_opt3 (P, T_Exs (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) /* can be -1 (arity), check_lambda[78617] */ -#define opt3_let(P) T_Let (opt3 (P, OPT3_LET)) -#define set_opt3_let(P, X) set_opt3 (P, T_Let (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) +#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_Exs(opt1(P, OPT1_CFUNC)) +#define set_opt1_cfunc(P, X) set_opt1(P, T_CFn(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_Exs(opt1(P, OPT1_CLAUSE)) +#define set_opt1_clause(P, X) set_opt1(P, T_Exs(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_Exs(opt1(P, OPT1_CON)) +#define set_opt1_con(P, X) set_opt1(P, T_Exs(X), OPT1_CON) /* can be # */ +#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) opt2_n(P, OPT2_INT) +#define set_opt2_int(P, X) set_opt2_n(P, 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_Exs(opt2(P, OPT2_CON)) +#define set_opt2_con(P, X) set_opt2(P, T_Exs(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) opt3_n(P, OPT3_ARGLEN) +#define set_opt3_arglen(P, X) set_opt3_n(P, X, OPT3_ARGLEN) +#define opt3_int(P) opt3_n(P, OPT3_INT) +#define set_opt3_int(P, X) set_opt3_n(P, 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_Exs(opt3(P, OPT3_CON)) +#define set_opt3_con(P, X) set_opt3(P, T_Exs(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) /* can be -1 (arity), check_lambda[78617] */ +#define opt3_let(P) T_Let(opt3(P, OPT3_LET)) +#define set_opt3_let(P, X) set_opt3(P, T_Let(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__) +#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.o3.opt_type /* op_if_is_type, opt_type == opt3 in cons */ -#define set_opt3_byte(P, X) \ - do { \ - T_Pair (P)->object.cons.o3.opt_type= X; \ - clear_type_bit (P, T_LOCATION); \ - } while (0) +#define opt3_byte(P) T_Pair(P)->object.cons.o3.opt_type /* op_if_is_type, opt_type == opt3 in cons */ +#define set_opt3_byte(P, X) do {T_Pair(P)->object.cons.o3.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 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.o2.opt2)) +#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.o2.opt2)) -#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 { \ - clear_has_fn (f); \ - 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_fn (f); \ - } while (0) -#define set_fn_direct(f, X) \ - do { \ - set_opt2 (f, (s7_pointer) (X), OPT2_FN); \ - set_has_fn (f); \ - } while (0) -#define set_class_and_fn_proc(X, f) \ - do { \ - set_opt1_cfunc (X, f); \ - set_fn_direct (X, c_function_call (f)); \ - } while (0) +#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 {clear_has_fn(f); 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_fn(f);} while (0) +#define set_fn_direct(f, X) do {set_opt2(f, (s7_pointer)(X), OPT2_FN); set_has_fn(f);} while (0) +#define set_class_and_fn_proc(X, f) do {set_opt1_cfunc(X, f); set_fn_direct(X, c_function_call(f));} while (0) #if WITH_GCC #if S7_DEBUGGING -#define fx_call(Sc, F) \ - ({ \ - s7_pointer _P_, _C_, _V_; \ - _P_= F; \ - _C_= Sc->code; \ - _V_= fx_proc (_P_) (Sc, car (_P_)); \ - if (Sc->code != _C_) \ - fprintf (stderr, "%s%s[%d]: %s clobbered sc->code%s\n", bold_text, \ - __func__, __LINE__, display (_C_), unbold_text); \ - _V_; \ - }) -#define fn_call(Sc, F) \ - ({ \ - s7_pointer _P_, _C_, _V_; \ - _P_= F; \ - _C_= Sc->code; \ - _V_= fn_proc (_P_) (Sc, cdr (_P_)); \ - if (Sc->code != _C_) \ - fprintf (stderr, "%s%s[%d]: %s clobbered sc->code%s\n", bold_text, \ - __func__, __LINE__, display (_C_), unbold_text); \ - _V_; \ - }) -/* this warning can happen when calling apply_mv from splice_in_values -- it - * appears to be innocuous */ + #define fx_call(Sc, F) ({s7_pointer _P_, _C_, _V_; _P_ = F; _C_ = Sc->code; _V_ = fx_proc(_P_)(Sc, car(_P_)); if (Sc->code != _C_) fprintf(stderr, "%s%s[%d]: %s clobbered sc->code%s\n", bold_text, __func__, __LINE__, display(_C_), unbold_text); _V_;}) + #define fn_call(Sc, F) ({s7_pointer _P_, _C_, _V_; _P_ = F; _C_ = Sc->code; _V_ = fn_proc(_P_)(Sc, cdr(_P_)); if (Sc->code != _C_) fprintf(stderr, "%s%s[%d]: %s clobbered sc->code%s\n", bold_text, __func__, __LINE__, display(_C_), unbold_text); _V_;}) + /* this warning can happen when calling apply_mv from splice_in_values -- it appears to be innocuous */ #else -#define fx_call(Sc, F) \ - ({ \ - s7_pointer _P_; \ - _P_= F; \ - fx_proc (_P_) (Sc, car (_P_)); \ - }) -#define fn_call(Sc, F) \ - ({ \ - s7_pointer _P_; \ - _P_= F; \ - fn_proc (_P_) (Sc, cdr (_P_)); \ - }) + #define fx_call(Sc, F) ({s7_pointer _P_; _P_ = F; fx_proc(_P_)(Sc, car(_P_));}) + #define fn_call(Sc, F) ({s7_pointer _P_; _P_ = F; fn_proc(_P_)(Sc, cdr(_P_));}) #endif #else -#define fx_call(Sc, F) fx_proc (F) (Sc, car (F)) -#define fn_call(Sc, F) fn_proc (F) (Sc, cdr (F)) +#define fx_call(Sc, F) fx_proc(F)(Sc, car(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 car_unchecked(p) (T_Pos (p))->object.cons.car -#define set_car(p, Val) \ - car (p)= Val /* can be a slot or # or # etc */ -#define cdr(p) (T_Pair (p))->object.cons.cdr -#define set_cdr_unchecked(p, Val) cdr (p)= T_Exs (Val) /* # in g_gc */ -#define cdr_unchecked(p) (T_Exs (p))->object.cons.cdr +#define car(p) (T_Pair(p))->object.cons.car +#define car_unchecked(p) (T_Pos(p))->object.cons.car +#define set_car(p, Val) car(p) = Val /* can be a slot or # or # etc */ +#define cdr(p) (T_Pair(p))->object.cons.cdr +#define set_cdr_unchecked(p, Val) cdr(p) = T_Exs(Val) /* # in g_gc */ +#define cdr_unchecked(p) (T_Exs(p))->object.cons.cdr #if S7_DEBUGGING -static void check_set_cdr (s7_pointer p, s7_pointer Val, const char* func, - int32_t line); -#define set_cdr(p, Val) check_set_cdr (p, Val, __func__, __LINE__) + static void check_set_cdr(s7_pointer p, s7_pointer Val, const char *func, int32_t line); + #define set_cdr(p, Val) check_set_cdr(p, Val, __func__, __LINE__) #else -#define set_cdr(p, Val) cdr (p)= T_Ext (Val) + #define set_cdr(p, Val) cdr(p) = T_Ext(Val) #endif -#define caar(p) car (car (p)) -#define cadr(p) car (cdr (p)) -#define set_cadr(p, Val) \ - car (cdr (p))= T_Exs (Val) /* # in g_gc[8178], set_elist_2, we're \ - clearing the elists */ -#define cdar(p) cdr (car (p)) -#define set_cdar(p, Val) cdr (car (p))= T_Ext (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_Ext (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_Ext (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)) +#define caar(p) car(car(p)) +#define cadr(p) car(cdr(p)) +#define set_cadr(p, Val) car(cdr(p)) = T_Exs(Val) /* # in g_gc[8178], set_elist_2, we're clearing the elists */ +#define cdar(p) cdr(car(p)) +#define set_cdar(p, Val) cdr(car(p)) = T_Ext(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_Ext(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_Ext(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, macro here is faster - * than inline function */ -#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_; \ - }) + /* slightly tricky because cons can be called recursively, macro here is faster than inline function */ + #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) + #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 with_list_t1(Sc, A) \ - (set_car (Sc->t1_1, A), Sc->t1_1) /* this is slower than explicit code, esp \ - t3, procedures are same as this */ -#define with_list_t2(Sc, A, B) \ - (set_car (Sc->t2_1, A), set_car (Sc->t2_2, B), Sc->t2_1) -#define with_list_t3(Sc, A, B, C) \ - (set_car (Sc->t3_1, A), set_car (Sc->t3_2, B), set_car (Sc->t3_3, C), \ - Sc->t3_1) -/* #define with_list_t4(Sc, A, B, C, D) (set_car(Sc->t4_1, A), set_car(Sc->t3_1, - * B), set_car(Sc->t3_2, C), set_car(Sc->t3_3, D), Sc->t4_1) */ - -#define is_string(p) (type (p) == T_STRING) -#define is_mutable_string(p) \ - ((full_type (T_Ext (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 string_block_unchecked(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_Ext (P))->tf.bits.opt_bits -#define optimize_op_unchecked(P) (P)->tf.bits.opt_bits -#define set_optimize_op(P, Op) \ - (T_Ext (P))->tf.bits.opt_bits= (Op) /* not T_Pair */ -#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 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 with_list_t1(Sc, A) (set_car(Sc->t1_1, A), Sc->t1_1) /* this is slower than explicit code, esp t3, procedures are same as this */ +#define with_list_t2(Sc, A, B) (set_car(Sc->t2_1, A), set_car(Sc->t2_2, B), Sc->t2_1) +#define with_list_t3(Sc, A, B, C) (set_car(Sc->t3_1, A), set_car(Sc->t3_2, B), set_car(Sc->t3_3, C), Sc->t3_1) +/* #define with_list_t4(Sc, A, B, C, D) (set_car(Sc->t4_1, A), set_car(Sc->t3_1, B), set_car(Sc->t3_2, C), set_car(Sc->t3_3, D), Sc->t4_1) */ + +#define is_string(p) (type(p) == T_STRING) +#define is_mutable_string(p) ((full_type(T_Ext(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 string_block_unchecked(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_Ext(P))->tf.bits.opt_bits +#define optimize_op_unchecked(P) (P)->tf.bits.opt_bits +#define set_optimize_op(P, Op) (T_Ext(P))->tf.bits.opt_bits = (Op) /* not T_Pair */ +#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) #if S7_DEBUGGING -#define s7_t_slot(Sc, P) s7_t_slot_1 (Sc, P, __func__, __LINE__) -s7_pointer -s7_t_slot_1 (s7_scheme* sc, s7_pointer symbol, const char* func, int line) { - s7_pointer p= s7_slot (sc, symbol); - if (type (p) == T_SLOT) return (p); - fprintf (stderr, "%s[%d]: slot: %d\n", func, line, (p == sc->undefined)); - return (p); +#define s7_t_slot(Sc, P) s7_t_slot_1(Sc, P, __func__, __LINE__) +s7_pointer s7_t_slot_1(s7_scheme *sc, s7_pointer symbol, const char *func, int line) +{ + s7_pointer p = s7_slot(sc, symbol); + if (type(p) == T_SLOT) return(p); + fprintf(stderr, "%s[%d]: slot: %d\n", func, line, (p == sc->undefined)); + return(p); } #else -#define s7_t_slot(Sc, P) s7_slot (Sc, P) +#define s7_t_slot(Sc, P) s7_slot(Sc, P) #endif -#define is_symbol(p) (type (p) == T_SYMBOL) -#define is_normal_symbol(p) \ - ((is_symbol (p)) && \ - (!is_keyword (p))) /* ((full_type(p) & (0xff | T_KEYWORD)) == T_SYMBOL) is \ - exactly the same speed */ -#define is_bound_symbol(Sc, p) \ - (is_slot (s7_slot (Sc, p))) /* (s7_slot(Sc, p) != Sc->undefined) is the same \ - speed apparently */ -#define is_safe_symbol(Sc, p) ((is_symbol (p)) && (is_bound_symbol (Sc, p))) -#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_uint) ((intptr_t) (p)) -#define symbol_id(p) (T_Sym (p))->object.sym.id -#define symbol_set_id_unchecked(p, X) (T_Sym (p))->object.sym.id= X +#define is_symbol(p) (type(p) == T_SYMBOL) +#define is_normal_symbol(p) ((is_symbol(p)) && (!is_keyword(p))) /* ((full_type(p) & (0xff | T_KEYWORD)) == T_SYMBOL) is exactly the same speed */ +#define is_bound_symbol(Sc, p) (is_slot(s7_slot(Sc, p))) /* (s7_slot(Sc, p) != Sc->undefined) is the same speed apparently */ +#define is_safe_symbol(Sc, p) ((is_symbol(p)) && (is_bound_symbol(Sc, p))) +#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_uint)((intptr_t)(p)) +#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 -void -symbol_set_id (s7_pointer sym, s7_int id) { - if (id < symbol_id (sym)) { - fprintf (stderr, "%s[%d]: id mismatch: sym: %s %" ld64 ", let: %" ld64 "\n", - __func__, __LINE__, symbol_name (sym), symbol_id (sym), id); - abort (); - } - (T_Sym (sym))->object.sym.id= id; +void symbol_set_id(s7_pointer sym, s7_int id) +{ + if (id < symbol_id(sym)) + { + fprintf(stderr, "%s[%d]: id mismatch: sym: %s %" ld64 ", let: %" ld64 "\n", __func__, __LINE__, symbol_name(sym), symbol_id(sym), id); + abort(); + } + (T_Sym(sym))->object.sym.id = id; } #else -#define symbol_set_id(p, X) (T_Sym (p))->object.sym.id= X +#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 a uint32_t! +/* 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 a 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 starlet_symbol_id(p) \ - ((uint8_t) ((block_size (symbol_info (p)) >> 8) & \ - 0xff)) /* *s7* id -- can be gensym, eval unopt section */ -#define starlet_symbol_set_id(p, F) \ - block_size (symbol_info (p))= \ - ((block_size (symbol_info (p)) & ~0xff00) | (((F) & 0xff) << 8)) +#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 starlet_symbol_id(p) ((uint8_t)((block_size(symbol_info(p)) >> 8) & 0xff)) /* *s7* id -- can be gensym, eval unopt section */ +#define starlet_symbol_set_id(p, F) block_size(symbol_info(p)) = ((block_size(symbol_info(p)) & ~0xff00) | (((F) & 0xff) << 8)) #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, T_Sym (Symbol), __func__, __LINE__) + /* 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, T_Sym(Symbol), __func__, __LINE__) #else -#define set_local(p) full_type (T_Sym (p))&= ~(T_DONT_EVAL_ARGS | T_SYNTACTIC) -/* if symbol_increment_ctr, local shadowing value is not found? same if {} */ + #define set_local(p) full_type(T_Sym(p)) &= ~(T_DONT_EVAL_ARGS | T_SYNTACTIC) + /* if symbol_increment_ctr, local shadowing value is not found? same if {} */ #endif -#define is_global(p) (symbol_id (p) == 0) -#define is_defined_global(p) \ - ((is_slot (global_slot (p))) && (symbol_id (p) == 0)) - -#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) /* # from new_symbol and g_gensym */ -#define local_slot(p) \ - T_Slt ((T_Sym (p))->object.sym.local_slot) /* was T_Sld 1-Aug-25 */ -#define set_local_slot(p, Val) (T_Sym (p))->object.sym.local_slot= T_Slt (Val) - -#define initial_value(p) symbol_info (p)->ex.ex_ptr -#define set_initial_value(p, Val) initial_value (p)= T_Ext (Val) -#define local_value(p) slot_value (local_slot (T_Sym (p))) -#define local_value_unchecked(p) local_slot (p)->object.slt.val -#define global_value(p) slot_value (global_slot (T_Sym (p))) -#define set_global_value(p, Val) \ - slot_set_value (global_slot (T_Sym (p)), \ - Val) /* slot_set_value checks T_Ext */ - -#define keyword_symbol(p) \ - symbol_info (T_Key (p)) \ - ->nx.ksym /* keyword only, so does not collide with documentation */ -#define keyword_symbol_unchecked(p) symbol_info (p)->nx.ksym -#define keyword_set_symbol(p, Val) symbol_info (T_Key (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 big_symbol_tag(p) symbol_info (p)->dx.tag -#define set_big_symbol_tag(p, Val) symbol_info (p)->dx.tag= Val - -#define small_symbol_tag(p) (T_Sym (p))->object.sym.small_symbol_tag -#define set_small_symbol_tag(p, Val) \ - (T_Sym (p))->object.sym.small_symbol_tag= Val -#define symbol_shadows(p) symbol_info (p)->ln.iter_or_size -/* #define symbol_set_shadows(p, Val) symbol_info(p)->ln.iter_or_size = Val - */ /* checked in new_symbol that it's 0 for a gensym */ -/* field incremented in add_symbol_to_big_symbol_set and decremented in - * cleanup_big_symbol_set */ -#define symbol_clear_shadows(p) symbol_info (p)->ln.iter_or_size= 0 - -#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 /* used only to set initial ctr value */ -#define symbol_increment_ctr(p) \ - (T_Sym (p))->object.sym.ctr++ /* despite this expense, ctr does save a lot \ - overall */ -#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_set_local_slot_unchecked(Symbol, Id, Slot) \ - do { \ - (Symbol)->object.sym.local_slot= T_Sld (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_Sld (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) */ - -/* block_index(symbol_info()) is free. We won't deallocate a symbol unless it is - * a gensym. remove_gensym_from_symbol_table could be opt'd by using this as - * the location. high bits of block_size(symbol_info()) might be free. Maybe - * use the gensym block instead? +#define is_global(p) (symbol_id(p) == 0) +#define is_defined_global(p) ((is_slot(global_slot(p))) && (symbol_id(p) == 0)) + +#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) /* # from new_symbol and g_gensym */ +#define local_slot(p) T_Slt((T_Sym(p))->object.sym.local_slot) /* was T_Sld 1-Aug-25 */ +#define set_local_slot(p, Val) (T_Sym(p))->object.sym.local_slot = T_Slt(Val) + +#define initial_value(p) symbol_info(p)->ex.ex_ptr +#define set_initial_value(p, Val) initial_value(p) = T_Ext(Val) +#define local_value(p) slot_value(local_slot(T_Sym(p))) +#define local_value_unchecked(p) local_slot(p)->object.slt.val +#define global_value(p) slot_value(global_slot(T_Sym(p))) +#define set_global_value(p, Val) slot_set_value(global_slot(T_Sym(p)), Val) /* slot_set_value checks T_Ext */ + +#define keyword_symbol(p) symbol_info(T_Key(p))->nx.ksym /* keyword only, so does not collide with documentation */ +#define keyword_symbol_unchecked(p) symbol_info(p)->nx.ksym +#define keyword_set_symbol(p, Val) symbol_info(T_Key(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 big_symbol_tag(p) symbol_info(p)->dx.tag +#define set_big_symbol_tag(p, Val) symbol_info(p)->dx.tag = Val + +#define small_symbol_tag(p) (T_Sym(p))->object.sym.small_symbol_tag +#define set_small_symbol_tag(p, Val) (T_Sym(p))->object.sym.small_symbol_tag = Val +#define symbol_shadows(p) symbol_info(p)->ln.iter_or_size +/* #define symbol_set_shadows(p, Val) symbol_info(p)->ln.iter_or_size = Val */ /* checked in new_symbol that it's 0 for a gensym */ +/* field incremented in add_symbol_to_big_symbol_set and decremented in cleanup_big_symbol_set */ +#define symbol_clear_shadows(p) symbol_info(p)->ln.iter_or_size = 0 + +#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 /* used only to set initial ctr value */ +#define symbol_increment_ctr(p) (T_Sym(p))->object.sym.ctr++ /* despite this expense, ctr does save a lot overall */ +#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_set_local_slot_unchecked(Symbol, Id, Slot) \ + do {(Symbol)->object.sym.local_slot = T_Sld(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_Sld(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) */ + +/* block_index(symbol_info()) is free. We won't deallocate a symbol unless it is a gensym. remove_gensym_from_symbol_table could be opt'd by using this as the location. + * high bits of block_size(symbol_info()) might be free. Maybe use the gensym block instead? */ -#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 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) #if S7_DEBUGGING -/* how to see an unheaped and un-GC-checked slot with a heap value? Can't do it - * here because unheap=most rootlet slots */ -#define slot_set_value(slot, value) \ - do { \ - if (is_immutable_slot (slot)) \ - fprintf (stderr, "%s[%d]: setting immutable slot %s\n", __func__, \ - __LINE__, symbol_name (slot_symbol (slot))); \ - (T_Slt (slot))->object.slt.val= T_Nmv (value); \ - } while (0) +/* how to see an unheaped and un-GC-checked slot with a heap value? Can't do it here because unheap=most rootlet slots */ +#define slot_set_value(slot, value) \ + do { \ + if (is_immutable_slot(slot)) fprintf(stderr, "%s[%d]: setting immutable slot %s\n", __func__, __LINE__, symbol_name(slot_symbol(slot))); \ + (T_Slt(slot))->object.slt.val = T_Nmv(value); \ + } while (0) #else -#define slot_set_value(p, Val) (T_Slt (p))->object.slt.val= T_Nmv (Val) +#define slot_set_value(p, Val) (T_Slt(p))->object.slt.val = T_Nmv(Val) #endif -#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, T_Slt (Slot), T_Nmv (Value)); \ - else slot_set_value (T_Slt (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) +#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, T_Slt(Slot), T_Nmv(Value)); else slot_set_value(T_Slt(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, "%s[%d]: slot: no pending value\n", __func__, __LINE__); - abort (); - return (NULL); -} -static s7_pointer -slot_expression (s7_pointer p) { - if (slot_has_expression (p)) return (p->object.slt.expr); - fprintf (stderr, "%s[%d]: slot: no expression\n", __func__, __LINE__); - abort (); - return (NULL); -} +static s7_pointer slot_pending_value(s7_pointer p) \ + {if (slot_has_pending_value(p)) return(p->object.slt.pending_value); fprintf(stderr, "%s[%d]: slot: no pending value\n", __func__, __LINE__); abort(); return(NULL);} +static s7_pointer slot_expression(s7_pointer p) \ + {if (slot_has_expression(p)) return(p->object.slt.expr); fprintf(stderr, "%s[%d]: slot: no expression\n", __func__, __LINE__); abort(); return(NULL);} #else -#define slot_pending_value(p) (T_Slt (p))->object.slt.pending_value -#define slot_expression(p) (T_Slt (p))->object.slt.expr +#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_pending_value_unchecked(p) (T_Slt (p))->object.slt.pending_value +#define slot_pending_value_unchecked(p) (T_Slt(p))->object.slt.pending_value -#define slot_set_expression(p, Val) \ - do { \ - (T_Slt (p))->object.slt.expr= T_Ext (Val); \ - slot_set_has_expression (p); \ - } while (0) -#define slot_just_set_expression(p, Val) \ - (T_Slt (p))->object.slt.expr= T_Ext (Val) -#define slot_setter(p) T_Prc ((T_Slt (p)->object.slt.pending_value)) -#define slot_set_setter_1(p, Val) \ - (T_Slt (p))->object.slt.pending_value= T_Prc (Val) +#define slot_set_expression(p, Val) do {(T_Slt(p))->object.slt.expr = T_Ext(Val); slot_set_has_expression(p);} while (0) +#define slot_just_set_expression(p, Val) (T_Slt(p))->object.slt.expr = T_Ext(Val) +#define slot_setter(p) T_Prc((T_Slt(p)->object.slt.pending_value)) +#define slot_set_setter_1(p, Val) (T_Slt(p))->object.slt.pending_value = T_Prc(Val) #if S7_DEBUGGING -#define is_not_slot_end(p) ((p) && (T_Slt (p))) + #define is_not_slot_end(p) ((p) && (T_Slt(p))) #else -#define is_not_slot_end(p) \ - (p) /* used for loop through let slots which end in null, not for general \ - slot recognition */ + #define is_not_slot_end(p) (p) /* used for loop through let slots which end in null, not for general slot recognition */ #endif -#define slot_end NULL -#define is_slot_end(p) (!(p)) -#define curlet_has_slots(Sc) is_not_slot_end (let_slots (Sc->curlet)) - -#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 is_syntax_or_qq(p) \ - ((is_syntax (p)) || \ - ((p) == \ - sc->quasiquote_function)) /* qq is from s7_define_macro -> T_C_MACRO */ - -#define let_id(p) (T_Let (p))->object.let.id -#define is_let(p) (type (p) == T_LET) -#define is_let_unchecked(p) (type_unchecked (p) == T_LET) -#define let_slots(p) T_Sln ((T_Let (p))->object.let.slots) -#define let_outlet(p) T_Out ((T_Let (p))->object.let.nxt) -#define let_set_outlet(p, ol) (T_Let (p))->object.let.nxt= T_Out (ol) +#define slot_end NULL +#define is_slot_end(p) (!(p)) +#define curlet_has_slots(Sc) is_not_slot_end(let_slots(Sc->curlet)) + +#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 is_syntax_or_qq(p) ((is_syntax(p)) || ((p) == sc->quasiquote_function)) /* qq is from s7_define_macro -> T_C_MACRO */ + +#define let_id(p) (T_Let(p))->object.let.id +#define is_let(p) (type(p) == T_LET) +#define is_let_unchecked(p) (type_unchecked(p) == T_LET) +#define let_slots(p) T_Sln((T_Let(p))->object.let.slots) +#define let_outlet(p) T_Out((T_Let(p))->object.let.nxt) +#define let_set_outlet(p, ol) (T_Let(p))->object.let.nxt = T_Out(ol) #if S7_DEBUGGING -#define let_set_id(p, Id) \ - do { \ - (T_Let (p))->object.let.id= Id; \ - if ((p == sc->rootlet) && (Id != -1)) { \ - fprintf (stderr, "%s[%d]: rootlet id: %" ld64 "\n", __func__, __LINE__, \ - (s7_int) Id); \ - if (sc->stop_at_error) abort (); \ - } \ - } while (0) -#define let_set_slots(p, Slot) \ - check_let_set_slots (sc, p, Slot, __func__, __LINE__) -#define C_Let(p, role) check_let_ref (p, role, __func__, __LINE__) -#define S_Let(p, role) check_let_set (p, role, __func__, __LINE__) + #define let_set_id(p, Id) do {(T_Let(p))->object.let.id = Id; if ((p == sc->rootlet) && (Id != -1)) {fprintf(stderr, "%s[%d]: rootlet id: %" ld64 "\n", __func__, __LINE__, (s7_int)Id); if (sc->stop_at_error) abort();}} while (0) + #define let_set_slots(p, Slot) check_let_set_slots(sc, p, Slot, __func__, __LINE__) + #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_id(p, Id) (T_Let (p))->object.let.id= Id -#define let_set_slots(p, Slot) (T_Let (p))->object.let.slots= T_Sln (Slot) -#define C_Let(p, role) p -#define S_Let(p, role) p + #define let_set_id(p, Id) (T_Let(p))->object.let.id = Id + #define let_set_slots(p, Slot) (T_Let(p))->object.let.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.let.edat.efnc.function) -#define funclet_set_function(p, F) \ - (S_Let (p, L_FUNC))->object.let.edat.efnc.function= T_Sym (F) -#define set_curlet(Sc, P) Sc->curlet= T_Let (P) - -#define let_baffle_key(p) (T_Let (p))->object.let.edat.key -#define let_set_baffle_key(p, K) (T_Let (p))->object.let.edat.key= K - -#define let_line(p) (C_Let (p, L_FUNC))->object.let.edat.efnc.line -#define let_set_line(p, L) (S_Let (p, L_FUNC))->object.let.edat.efnc.line= L -#define let_file(p) (C_Let (p, L_FUNC))->object.let.edat.efnc.file -#define let_set_file(p, F) (S_Let (p, L_FUNC))->object.let.edat.efnc.file= F - -#define let_dox_slot1(p) T_Slt ((C_Let (p, L_DOX))->object.let.edat.dox.dox1) -#define let_set_dox_slot1(p, S) \ - do { \ - (S_Let (p, L_DOX))->object.let.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.let.edat.dox.dox2) /* # from opt_cell_do */ -#define let_set_dox_slot2(p, S) \ - do { \ - (S_Let (p, L_DOX))->object.let.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.let.edat.dox.dox2) -#define let_set_dox_slot2_unchecked(p, S) \ - do { \ - S_Let (p, L_DOX)->object.let.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_t_vector(p) (type (p) == T_VECTOR) -#define vector_length(p) (p)->object.vector.length -#define vector_elements_unchecked(p) (p)->object.vector.elements.objects +#define funclet_function(p) T_Sym((C_Let(p, L_FUNC))->object.let.edat.efnc.function) +#define funclet_set_function(p, F) (S_Let(p, L_FUNC))->object.let.edat.efnc.function = T_Sym(F) +#define set_curlet(Sc, P) Sc->curlet = T_Let(P) + +#define let_baffle_key(p) (T_Let(p))->object.let.edat.key +#define let_set_baffle_key(p, K) (T_Let(p))->object.let.edat.key = K + +#define let_line(p) (C_Let(p, L_FUNC))->object.let.edat.efnc.line +#define let_set_line(p, L) (S_Let(p, L_FUNC))->object.let.edat.efnc.line = L +#define let_file(p) (C_Let(p, L_FUNC))->object.let.edat.efnc.file +#define let_set_file(p, F) (S_Let(p, L_FUNC))->object.let.edat.efnc.file = F + +#define let_dox_slot1(p) T_Slt((C_Let(p, L_DOX))->object.let.edat.dox.dox1) +#define let_set_dox_slot1(p, S) do {(S_Let(p, L_DOX))->object.let.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.let.edat.dox.dox2) /* # from opt_cell_do */ +#define let_set_dox_slot2(p, S) do {(S_Let(p, L_DOX))->object.let.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.let.edat.dox.dox2) +#define let_set_dox_slot2_unchecked(p, S) do {S_Let(p, L_DOX)->object.let.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_t_vector(p) (type(p) == T_VECTOR) +#define vector_length(p) (p)->object.vector.length +#define vector_elements_unchecked(p) (p)->object.vector.elements.objects #define vector_element_unchecked(p, i) ((p)->object.vector.elements.objects[i]) -#define vector_element(p, i) ((T_Nvc (p))->object.vector.elements.objects[i]) -#define vector_elements(p) (T_Nvc (p))->object.vector.elements.objects -#define any_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 vector_block_unchecked(p) p->object.vector.block - -#define typed_vector_typer(p) T_Prc ((T_Nvc (p))->object.vector.setv.fset) -#define typed_vector_set_typer(p, Fnc) \ - (T_Nvc (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_complex_vector(p) (type (p) == T_COMPLEX_VECTOR) -#define complex_vector(p, i) ((T_Cvc (p))->object.vector.elements.complexes[i]) -#define complex_vector_complexes(p) \ - (T_Cvc (p))->object.vector.elements.complexes - -#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 stack_element(p, i) vector_element_unchecked (T_Stk (p), i) -#define stack_elements(p) vector_elements_unchecked (T_Stk (p)) -#define stack_block(p) vector_block_unchecked (T_Stk (p)) -#define stack_top(Sc) ((Sc)->stack_end - (Sc)->stack_start) -#define temp_stack_top(p) (T_Stk (p))->object.stk.top +#define vector_element(p, i) ((T_Nvc(p))->object.vector.elements.objects[i]) +#define vector_elements(p) (T_Nvc(p))->object.vector.elements.objects +#define any_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 vector_block_unchecked(p) p->object.vector.block + +#define typed_vector_typer(p) T_Prc((T_Nvc(p))->object.vector.setv.fset) +#define typed_vector_set_typer(p, Fnc) (T_Nvc(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_complex_vector(p) (type(p) == T_COMPLEX_VECTOR) +#define complex_vector(p, i) ((T_Cvc(p))->object.vector.elements.complexes[i]) +#define complex_vector_complexes(p) (T_Cvc(p))->object.vector.elements.complexes + +#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 stack_element(p, i) vector_element_unchecked(T_Stk(p), i) +#define stack_elements(p) vector_elements_unchecked(T_Stk(p)) +#define stack_block(p) vector_block_unchecked(T_Stk(p)) +#define 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_Ext (p)) & (TYPE_MASK | T_IMMUTABLE)) == T_HASH_TABLE) -#define hash_table_mask(p) (T_Hsh (p))->object.hasher.mask -/* hash_table_mask comes from an earlier hash_map, but hash_table_size is still - * a power of 2, so hash_map's % wastes an entry, but the mask (pow2-1) is still - * useful -- in pointer_map for example if we divide by pow2, we can end up just - * tossing the 3 lower bits, (hash-table :a 1 :b 2 :c 3) -> - * hash-stats:empty|1|2|n|most (7 0 0 1 3) +#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_Ext(p)) & (TYPE_MASK | T_IMMUTABLE)) == T_HASH_TABLE) +#define hash_table_mask(p) (T_Hsh(p))->object.hasher.mask +/* hash_table_mask comes from an earlier hash_map, but hash_table_size is still a power of 2, so hash_map's % wastes an entry, but + * the mask (pow2-1) is still useful -- in pointer_map for example if we divide by pow2, we can end up just tossing the 3 lower bits, + * (hash-table :a 1 :b 2 :c 3) -> hash-stats:empty|1|2|n|most (7 0 0 1 3) */ -#define hash_table_size(p) ((T_Hsh (p))->object.hasher.mask + 1) -#define hash_table_block(p) (T_Hsh (p))->object.hasher.block -#define hash_table_block_unchecked(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_uint -#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_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) /* both the checker/mapper: car/cdr, and the two typers \ - (opt1/opt2) */ -#define hash_table_procedures_checker(p) T_Prc (car (hash_table_procedures (p))) -#define hash_table_procedures_mapper(p) T_Prc (cdr (hash_table_procedures (p))) -#define hash_table_set_procedures_checker(p, f) \ - set_car (hash_table_procedures (p), T_Prc (f)) -#define hash_table_set_procedures_mapper(p, f) \ - set_cdr (hash_table_procedures (p), T_Prc (f)) -#define hash_table_key_typer(p) T_Prc (opt1_any (hash_table_procedures (p))) -#define hash_table_key_typer_unchecked(p) \ - hash_table_block (p)->ex.ex_ptr->object.cons.opt1 -#define hash_table_set_key_typer(p, Fnc) \ - set_opt1_any (hash_table_procedures (T_Hsh (p)), T_Prc (Fnc)) -#define hash_table_value_typer(p) T_Prc (opt2_any (hash_table_procedures (p))) -#define hash_table_value_typer_unchecked(p) \ - hash_table_block (p)->ex.ex_ptr->object.cons.o2.opt2 -#define hash_table_set_value_typer(p, Fnc) \ - set_opt2_any (hash_table_procedures (T_Hsh (p)), T_Prc (Fnc)) -#define weak_hash_iters(p) hash_table_block (p)->ln.iter_or_size -#define missing_key_value(Sc) hash_entry_value (Sc->unentry) +#define hash_table_size(p) ((T_Hsh(p))->object.hasher.mask + 1) +#define hash_table_block(p) (T_Hsh(p))->object.hasher.block +#define hash_table_block_unchecked(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_uint +#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_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) /* both the checker/mapper: car/cdr, and the two typers (opt1/opt2) */ +#define hash_table_procedures_checker(p) T_Prc(car(hash_table_procedures(p))) +#define hash_table_procedures_mapper(p) T_Prc(cdr(hash_table_procedures(p))) +#define hash_table_set_procedures_checker(p, f) set_car(hash_table_procedures(p), T_Prc(f)) +#define hash_table_set_procedures_mapper(p, f) set_cdr(hash_table_procedures(p), T_Prc(f)) +#define hash_table_key_typer(p) T_Prc(opt1_any(hash_table_procedures(p))) +#define hash_table_key_typer_unchecked(p) hash_table_block(p)->ex.ex_ptr->object.cons.opt1 +#define hash_table_set_key_typer(p, Fnc) set_opt1_any(hash_table_procedures(T_Hsh(p)), T_Prc(Fnc)) +#define hash_table_value_typer(p) T_Prc(opt2_any(hash_table_procedures(p))) +#define hash_table_value_typer_unchecked(p) hash_table_block(p)->ex.ex_ptr->object.cons.o2.opt2 +#define hash_table_set_value_typer(p, Fnc) set_opt2_any(hash_table_procedures(T_Hsh(p)), T_Prc(Fnc)) +#define weak_hash_iters(p) hash_table_block(p)->ln.iter_or_size +#define missing_key_value(Sc) hash_entry_value(Sc->unentry) #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__) + #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 + #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.seq -#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_current(p) (T_Itr (p))->object.iter.cur -#define iterator_carrier(p) (T_Itr (p))->object.iter.cur -#define iterator_is_at_end(p) \ - (!iter_ok (p)) /* ((full_type(T_Itr(p)) & T_ITER_OK) == 0) */ -#define iterator_at_end_value(Sc) Sc->iterator_at_end_value - -#define pair_iterator_slow(p) \ - T_Lst ((T_Itr_Pair (p))->object.iter.lw.slow) /* applies only to pairs */ -#define pair_iterator_set_slow(p, Val) \ - (T_Itr_Pair (p))->object.iter.lw.slow= T_Lst (Val) -#define hash_iterator_entry(p) \ - (T_Itr_Hash (p))->object.iter.lw.entry /* applies only to hash-tables */ -#define let_iterator_slot(p) \ - T_Sln ((T_Itr_Let (p))->object.iter.lc.slot) /* applies only to lets */ -#define let_iterator_set_slot(p, Val) \ - (T_Itr_Let (p))->object.iter.lc.slot= T_Sln (Val) - -#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 port_data_block_unchecked(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 -#define port_needs_free(p) port_port (p)->needs_free -#define port_next(p) port_block (p)->nx.next -#define port_output_function(p) \ - port_port (p)->output_function /* these two are for function ports */ -#define port_input_function(p) port_port (p)->input_function -#define port_string_or_function(p) port_port (p)->orig_str -#define port_set_string_or_function(p, S) port_port (p)->orig_str= S - -#define current_input_port(Sc) T_Pri (Sc->input_port) -#define set_current_input_port(Sc, P) Sc->input_port= T_Pri (P) -#define current_output_port(Sc) T_Pro (Sc->output_port) -#define set_current_output_port(Sc, P) Sc->output_port= T_Pro (P) -#define current_error_port(Sc) T_Pro (Sc->error_port) -#define set_current_error_port(Sc, P) Sc->error_port= T_Pro (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) /* does not include T_C_FUNCTION_STAR */ -#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 is_safe_c_function(f) ((is_c_function (f)) && (is_safe_procedure (f))) -#define c_function_data(f) \ - (T_Fnc (f)) \ - ->object.fnc.c_proc /* not T_CFn -- this also applies to T_C_MACROs */ -#define c_function_call(f) (T_Fnc (f))->object.fnc.ff -#define c_function_min_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_max_args(f) (T_Fnc (f))->object.fnc.all_args -#define c_function_is_aritable(f, N) \ - ((c_function_min_args (f) <= N) && (c_function_max_args (f) >= N)) -#define c_function_name(f) c_function_data (f)->name /* const char* */ -#define c_function_name_length(f) \ - c_function_data (f)->name_length /* int32_t \ - */ -#define c_function_documentation(f) c_function_data (f)->doc /* const char* */ -#define c_function_signature(f) \ - T_Prf (c_function_data (f)->signature) /* pair or #f */ -#define c_function_set_signature(f, Val) \ - c_function_data (f)->signature= T_Prf (Val) -#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_class(f) c_function_data (f)->class_id /* uint32_t */ -#define c_function_chooser(f) c_function_data (f)->chooser -#define c_function_base(f) T_CFn (c_function_data (f)->generic_ff) -#define c_function_set_base(f, Val) c_function_data (f)->generic_ff= T_CFn (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) \ - T_Sym (c_function_data (f) \ - ->sam.c_sym) /* f is c_function or c_macro, but not c_function* \ - -- doesn't fit current checks */ -#define c_function_set_symbol(f, Sym) \ - c_function_data (f)->sam.c_sym= T_Sym (Sym) -#define c_function_let(f) T_Let (c_function_data (f)->let) -#define c_function_set_let(f, Val) c_function_data (f)->let= T_Let (Val) - -#define c_function_bool_setter(f) T_CFn (c_function_data (f)->dam.bool_setter) -#define c_function_set_bool_setter(f, Val) \ - c_function_data (f)->dam.bool_setter= T_CFn (Val) - -#define c_function_arg_defaults(f) \ - c_function_data (T_Fst (f))->dam.arg_defaults /* array of s7_pointer */ -#define c_function_call_args(f) \ - c_function_data (T_Fst (f))->cam.call_args /* pair or NULL */ -#define c_function_par_names(f) \ - c_function_data (T_Fst (f))->sam.arg_names /* array of s7_pointer */ -#define c_function_opt_data(f) \ - c_function_data (f)->opt_data /* opt_funcs_t (vunion) */ - -#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_min_args(f) (T_CMac (f))->object.fnc.required_args -#define c_macro_max_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 could_be_macro_setter(Obj) t_macro_setter_p[type (Obj)] - -#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 is_macro(p) (type (p) == T_MACRO) -#define is_macro_star(p) (type (p) == T_MACRO_STAR) -#define is_bacro(p) (type (p) == T_BACRO) -#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) ((is_bacro (p)) || (is_bacro_star (p))) - -#define is_closure(p) (type (p) == T_CLOSURE) -#define is_closure_star(p) (type (p) == T_CLOSURE_STAR) -#define closure_pars(p) T_Arg ((T_Clo (p))->object.func.args) -#define closure_set_pars(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_Let ((T_Clo (p))->object.func.let) -#define closure_set_let(p, L) (T_Clo (p))->object.func.let= T_Let (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) -#define closure_set_setter_or_map_list(p, Val) \ - T_Clo (p)->object.func.setter= Val +#define is_iterator(p) (type(p) == T_ITERATOR) +#define iterator_sequence(p) (T_Itr(p))->object.iter.seq +#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_current(p) (T_Itr(p))->object.iter.cur +#define iterator_carrier(p) (T_Itr(p))->object.iter.cur +#define iterator_is_at_end(p) (!iter_ok(p)) /* ((full_type(T_Itr(p)) & T_ITER_OK) == 0) */ +#define iterator_at_end_value(Sc) Sc->iterator_at_end_value + +#define pair_iterator_slow(p) T_Lst((T_Itr_Pair(p))->object.iter.lw.slow) /* applies only to pairs */ +#define pair_iterator_set_slow(p, Val) (T_Itr_Pair(p))->object.iter.lw.slow = T_Lst(Val) +#define hash_iterator_entry(p) (T_Itr_Hash(p))->object.iter.lw.entry /* applies only to hash-tables */ +#define let_iterator_slot(p) T_Sln((T_Itr_Let(p))->object.iter.lc.slot) /* applies only to lets */ +#define let_iterator_set_slot(p, Val) (T_Itr_Let(p))->object.iter.lc.slot = T_Sln(Val) + +#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 port_data_block_unchecked(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 +#define port_needs_free(p) port_port(p)->needs_free +#define port_next(p) port_block(p)->nx.next +#define port_output_function(p) port_port(p)->output_function /* these two are for function ports */ +#define port_input_function(p) port_port(p)->input_function +#define port_string_or_function(p) port_port(p)->orig_str +#define port_set_string_or_function(p, S) port_port(p)->orig_str = S + +#define current_input_port(Sc) T_Pri(Sc->input_port) +#define set_current_input_port(Sc, P) Sc->input_port = T_Pri(P) +#define current_output_port(Sc) T_Pro(Sc->output_port) +#define set_current_output_port(Sc, P) Sc->output_port = T_Pro(P) +#define current_error_port(Sc) T_Pro(Sc->error_port) +#define set_current_error_port(Sc, P) Sc->error_port = T_Pro(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) /* does not include T_C_FUNCTION_STAR */ +#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 is_safe_c_function(f) ((is_c_function(f)) && (is_safe_procedure(f))) +#define c_function_data(f) (T_Fnc(f))->object.fnc.c_proc /* not T_CFn -- this also applies to T_C_MACROs */ +#define c_function_call(f) (T_Fnc(f))->object.fnc.ff +#define c_function_min_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_max_args(f) (T_Fnc(f))->object.fnc.all_args +#define c_function_is_aritable(f, N) ((c_function_min_args(f) <= N) && (c_function_max_args(f) >= N)) +#define c_function_name(f) c_function_data(f)->name /* const char* */ +#define c_function_name_length(f) c_function_data(f)->name_length /* int32_t */ +#define c_function_documentation(f) c_function_data(f)->doc /* const char* */ +#define c_function_signature(f) T_Prf(c_function_data(f)->signature) /* pair or #f */ +#define c_function_set_signature(f, Val) c_function_data(f)->signature = T_Prf(Val) +#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_class(f) c_function_data(f)->class_id /* uint32_t */ +#define c_function_chooser(f) c_function_data(f)->chooser +#define c_function_base(f) T_CFn(c_function_data(f)->generic_ff) +#define c_function_set_base(f, Val) c_function_data(f)->generic_ff = T_CFn(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) T_Sym(c_function_data(f)->sam.c_sym) /* f is c_function or c_macro, but not c_function* -- doesn't fit current checks */ +#define c_function_set_symbol(f, Sym) c_function_data(f)->sam.c_sym = T_Sym(Sym) +#define c_function_let(f) T_Let(c_function_data(f)->let) +#define c_function_set_let(f, Val) c_function_data(f)->let = T_Let(Val) + +#define c_function_bool_setter(f) T_CFn(c_function_data(f)->dam.bool_setter) +#define c_function_set_bool_setter(f, Val) c_function_data(f)->dam.bool_setter = T_CFn(Val) + +#define c_function_arg_defaults(f) c_function_data(T_Fst(f))->dam.arg_defaults /* array of s7_pointer */ +#define c_function_call_args(f) c_function_data(T_Fst(f))->cam.call_args /* pair or NULL */ +#define c_function_par_names(f) c_function_data(T_Fst(f))->sam.arg_names /* array of s7_pointer */ +#define c_function_opt_data(f) c_function_data(f)->opt_data /* opt_funcs_t (vunion) */ + +#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_min_args(f) (T_CMac(f))->object.fnc.required_args +#define c_macro_max_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 could_be_macro_setter(Obj) t_macro_setter_p[type(Obj)] + +#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 is_macro(p) (type(p) == T_MACRO) +#define is_macro_star(p) (type(p) == T_MACRO_STAR) +#define is_bacro(p) (type(p) == T_BACRO) +#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) ((is_bacro(p)) || (is_bacro_star(p))) + +#define is_closure(p) (type(p) == T_CLOSURE) +#define is_closure_star(p) (type(p) == T_CLOSURE_STAR) +#define closure_pars(p) T_Arg((T_Clo(p))->object.func.args) +#define closure_set_pars(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_Let((T_Clo(p))->object.func.let) +#define closure_set_let(p, L) (T_Clo(p))->object.func.let = T_Let(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) +#define closure_set_setter_or_map_list(p, Val) T_Clo(p)->object.func.setter = Val /* closure_map_list refers to a cyclic list detector in map */ -#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_cstack(p) (T_Cat (p))->object.rcatch.cstack -#define catch_handler(p) T_Ext ((T_Cat (p))->object.rcatch.handler) -#define catch_set_handler(p, val) \ - (T_Cat (p))->object.rcatch.handler= T_Ext (val) - -#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_Let ((T_Obj (p))->object.c_obj.let) -#define c_object_set_let(p, L) (T_Obj (p))->object.c_obj.let= T_Let (L) -#define c_object_sc(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 +#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_cstack(p) (T_Cat(p))->object.rcatch.cstack +#define catch_handler(p) T_Ext((T_Cat(p))->object.rcatch.handler) +#define catch_set_handler(p, val) (T_Cat(p))->object.rcatch.handler = T_Ext(val) + +#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_Let((T_Obj(p))->object.c_obj.let) +#define c_object_set_let(p, L) (T_Obj(p))->object.c_obj.let = T_Let(L) +#define c_object_sc(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 + #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_Ext (q) -#define c_pointer_set_weak2(p, q) (T_Ptr (p))->object.cptr.weak2= T_Ext (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_Ext (Val) -#define counter_list(p) (T_Ctr (p))->object.ctr.list -#define counter_set_list(p, Val) (T_Ctr (p))->object.ctr.list= T_Ext (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_Let ((T_Ctr (p))->object.ctr.let) -#define counter_set_let(p, L) (T_Ctr (p))->object.ctr.let= T_Let (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) +#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_Ext(q) +#define c_pointer_set_weak2(p, q) (T_Ptr(p))->object.cptr.weak2 = T_Ext(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_Ext(Val) +#define counter_list(p) (T_Ctr(p))->object.ctr.list +#define counter_set_list(p, Val) (T_Ctr(p))->object.ctr.list = T_Ext(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_Let((T_Ctr(p))->object.ctr.let) +#define counter_set_let(p, L) (T_Ctr(p))->object.ctr.let = T_Let(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 S7_DEBUGGING -#define begin_temp(P, Val) \ - do { \ - s7_pointer __val__= Val; \ - begin_temp_1 (sc, P, __val__, __func__, __LINE__); \ - P= __val__; \ - } while (0) -void -begin_temp_1 (s7_scheme* sc, s7_pointer p, s7_pointer val, const char* func, - int line) { - if (p != sc->unused) { - char* str; - fprintf ( - stderr, "%s[%d]: begin_temp %s %d %s\n", func, line, - (p == sc->y) - ? "sc->y" - : ((p == sc->v) - ? "sc->v" - : ((p == sc->x) ? "sc->x" - : ((p == sc->temp6) ? "sc->temp6" : "???"))), - (p == sc->y) - ? sc->y_line - : ((p == sc->v) ? sc->v_line - : ((p == sc->x) ? sc->x_line : sc->t_line)), - str= s7_object_to_c_string (sc, p)); - free (str); - /* if (sc->stop_at_error) abort(); */ /* this happens when an error - interrupts a loop (for-each etc) so - end_temp is missed */ - } - if (p == sc->y) sc->y_line= line; - else if (p == sc->v) sc->v_line= line; - else if (p == sc->x) sc->x_line= line; - else sc->t_line= line; +#define begin_temp(P, Val) do {s7_pointer __val__ = Val; begin_temp_1(sc, P, __val__, __func__, __LINE__); P = __val__;} while (0) +void begin_temp_1(s7_scheme *sc, s7_pointer p, s7_pointer val, const char *func, int line) +{ + if(p != sc->unused) + { + char *str; + fprintf(stderr, "%s[%d]: begin_temp %s %d %s\n", func, line, + (p == sc->y) ? "sc->y" : ((p == sc->v) ? "sc->v" : ((p == sc->x) ? "sc->x" : ((p == sc->temp6) ? "sc->temp6" : "???"))), + (p == sc->y) ? sc->y_line : ((p == sc->v) ? sc->v_line : ((p == sc->x) ? sc->x_line : sc->t_line)), + str = s7_object_to_c_string(sc, p)); + free(str); + /* if (sc->stop_at_error) abort(); */ /* this happens when an error interrupts a loop (for-each etc) so end_temp is missed */ + } + if (p == sc->y) sc->y_line = line; + else + if (p == sc->v) sc->v_line = line; + else + if (p == sc->x) sc->x_line = line; + else sc->t_line = line; } #else -#define begin_temp(p, Val) p= Val +#define begin_temp(p, Val) p = Val #endif -#define end_temp(p) p= sc->unused -#define return_with_end_temp(Temp) \ - do { \ - s7_pointer Result= Temp; \ - end_temp (Temp); \ - return (Result); \ - } while (0) +#define end_temp(p) p = sc->unused +#define return_with_end_temp(Temp) do {s7_pointer Result = Temp; end_temp(Temp); return(Result);} while (0) #if __cplusplus && HAVE_COMPLEX_NUMBERS -static s7_double -Real (complex x) { - return (real (x)); -} /* protect the C++ name */ -static s7_double -Imag (complex x) { - return (imag (x)); -} + 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 set_numerator(p, x) numerator (p)= x -#define denominator(p) (T_Frc (p))->object.number.fraction_value.denominator -#define set_denominator(p, x) denominator (p)= x -#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.cz.complex_value.rl -#define set_real_part(p, x) real_part (p)= x -#define imag_part(p) (T_Cmp (p))->object.number.cz.complex_value.im -#define set_imag_part(p, x) imag_part (p)= x +#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 set_numerator(p, x) numerator(p) = x +#define denominator(p) (T_Frc(p))->object.number.fraction_value.denominator +#define set_denominator(p, x) denominator(p) = x +#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.cz.complex_value.rl +#define set_real_part(p, x) real_part(p) = x +#define imag_part(p) (T_Cmp(p))->object.number.cz.complex_value.im +#define set_imag_part(p, x) imag_part(p) = x #if WITH_CLANG_PP -#define a_bi(p) \ - CMPLX ((T_Cmp (p))->object.number.cz.complex_value.rl, \ - p->object.number.cz.complex_value.im) +#define a_bi(p) CMPLX((T_Cmp(p))->object.number.cz.complex_value.rl, p->object.number.cz.complex_value.im) #else -#define a_bi(p) (T_Cmp (p))->object.number.cz.z -#define set_a_bi(p, x) a_bi (p)= x +#define a_bi(p) (T_Cmp(p))->object.number.cz.z +#define set_a_bi(p, x) a_bi(p) = x #endif #if HAVE_COMPLEX_NUMBERS -#define to_c_complex(p) CMPLX (real_part (p), imag_part (p)) + #define to_c_complex(p) CMPLX(real_part(p), imag_part(p)) #endif + #if S7_DEBUGGING -const char* display (s7_pointer obj); -const char* -display (s7_pointer obj) { - const char* result; - if (!has_methods_unchecked (obj)) - return (string_value (s7_object_to_string (cur_sc, obj, false))); - clear_type_bit ( - obj, T_HAS_METHODS); /* clear_has_methods calls T_Met -> check_ref_met */ - result= string_value (s7_object_to_string (cur_sc, obj, false)); - set_type_bit (obj, T_HAS_METHODS); /* same for set_has_methods */ - return (result); +const char *display(s7_pointer obj); +const char *display(s7_pointer obj) +{ + const char *result; + if (!has_methods_unchecked(obj)) + return(string_value(s7_object_to_string(cur_sc, obj, false))); + clear_type_bit(obj, T_HAS_METHODS); /* clear_has_methods calls T_Met -> check_ref_met */ + result = string_value(s7_object_to_string(cur_sc, obj, false)); + set_type_bit(obj, T_HAS_METHODS); /* same for set_has_methods */ + return(result); } #else -#define display(Obj) string_value (s7_object_to_string (sc, Obj, false)) +#define display(Obj) string_value(s7_object_to_string(sc, Obj, false)) #endif -#define display_truncated(Obj) \ - string_value (object_to_string_truncated (sc, Obj)) +#define display_truncated(Obj) string_value(object_to_string_truncated(sc, Obj)) #if S7_DEBUGGING -static void -check_mutable_bit (s7_pointer p) { - if (!is_mutable (p)) - fprintf (stderr, "%s[%d]: mutable cleared already?\n", p->gc_func, - p->gc_line); -} - -void -set_type_1 (s7_pointer p, s7_uint typ, const char* func, int32_t line) { - p->alloc_line = line; - p->alloc_func = func; - p->alloc_type = typ; - p->explicit_free_line= 0; +static void check_mutable_bit(s7_pointer p) +{ + if (!is_mutable(p)) + fprintf(stderr, "%s[%d]: mutable cleared already?\n", p->gc_func, p->gc_line); +} + +void set_type_1(s7_pointer p, s7_uint typ, const char *func, int32_t line) +{ + p->alloc_line = line; + p->alloc_func = func; + p->alloc_type = typ; + p->explicit_free_line = 0; p->uses++; - if (((typ) &TYPE_MASK) == T_FREE) - fprintf (stderr, "%d: set free, %p type to #x%" PRIx64 "\n", __LINE__, p, - (s7_int) (typ)); - else if (((typ) &TYPE_MASK) >= NUM_TYPES) - fprintf (stderr, "%d: set invalid type, %p type to #x%" PRIx64 "\n", - __LINE__, p, (s7_int) (typ)); - else { - if (((full_type (p) & T_IMMUTABLE) != 0) && - ((full_type (p) != (s7_uint) (typ)))) { - fprintf (stderr, "%s[%d]: set immutable %p type %d to %" ld64 "\n", - __func__, __LINE__, p, type_unchecked (p), (s7_int) (typ)); - abort (); - } - if (((full_type (p) & T_UNHEAP) != 0) && (((typ) &T_UNHEAP) == 0)) - fprintf (stderr, "%s[%d]: clearing unheap in set type!\n", __func__, - __LINE__); - } - full_type (p)= typ; + if (((typ) & TYPE_MASK) == T_FREE) + fprintf(stderr, "%d: set free, %p type to #x%" PRIx64 "\n", __LINE__, p, (s7_int)(typ)); + else + if (((typ) & TYPE_MASK) >= NUM_TYPES) + fprintf(stderr, "%d: set invalid type, %p type to #x%" PRIx64 "\n", __LINE__, p, (s7_int)(typ)); + else + { + if (((full_type(p) & T_IMMUTABLE) != 0) && ((full_type(p) != (s7_uint)(typ)))) + { + fprintf(stderr, "%s[%d]: set immutable %p type %d to %" ld64 "\n", __func__, __LINE__, p, type_unchecked(p), (s7_int)(typ)); + abort(); + } + if (((full_type(p) & T_UNHEAP) != 0) && (((typ) & T_UNHEAP) == 0)) + fprintf(stderr, "%s[%d]: clearing unheap in set type!\n", __func__, __LINE__); + } + full_type(p) = typ; } #endif @@ -4925,185 +3812,140 @@ static int32_t s7_int_digits_by_radix[17]; #define S7_INT_BITS 63 #define S7_INT64_MAX 9223372036854775807LL -/* #define S7_INT64_MIN -9223372036854775808LL */ /* why is this disallowed in - C? "warning: integer - constant is so large that - it is unsigned" */ -#define S7_INT64_MIN \ - (int64_t) (-S7_INT64_MAX - 1LL) /* in gcc 9 we had to assign this to an \ - s7_int, then use that! */ +/* #define S7_INT64_MIN -9223372036854775808LL */ /* why is this disallowed in C? "warning: integer constant is so large that it is unsigned" */ +#define S7_INT64_MIN (int64_t)(-S7_INT64_MAX - 1LL) /* in gcc 9 we had to assign this to an s7_int, then use that! */ #define S7_INT32_MAX 2147483647LL #define S7_INT32_MIN (-S7_INT32_MAX - 1LL) -static void -init_int_limits (void) { -/* 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 - s7_int_digits_by_radix[0]= 0; - s7_int_digits_by_radix[1]= 0; - for (int32_t i= 2; i < 17; i++) - s7_int_digits_by_radix[i]= - (int32_t) (floor (S7_LOG_INT64_MAX / log ((double) i))); +static void init_int_limits(void) +{ + /* 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 + s7_int_digits_by_radix[0] = 0; + s7_int_digits_by_radix[1] = 0; + for (int32_t 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 (s7_int i) { - s7_pointer p= (s7_pointer) Malloc ( - sizeof (s7_cell)); /* was using Calloc to clear name. 22-May-25 */ - full_type (p)= T_IMMUTABLE | T_INTEGER | T_UNHEAP; - set_integer (p, i); - return (p); +static s7_pointer make_permanent_integer(s7_int i) +{ + s7_pointer p = (s7_pointer)Malloc(sizeof(s7_cell)); /* was using Calloc to clear name. 22-May-25 */ + full_type(p) = T_IMMUTABLE | T_INTEGER | T_UNHEAP; + set_integer(p, i); + return(p); } #define NUM_CHARS 256 #ifndef NUM_SMALL_INTS -#define NUM_SMALL_INTS 8192 + #define NUM_SMALL_INTS 8192 #else -#if (NUM_SMALL_INTS < \ - NUM_CHARS) /* g_char_to_integer assumes this is at least NUM_CHARS, as \ - does the byte_vector stuff (256) */ -#error NUM_SMALL_INTS is less than NUM_CHARS which will not work +#if (NUM_SMALL_INTS < NUM_CHARS) /* g_char_to_integer assumes this is at least NUM_CHARS, as does the byte_vector stuff (256) */ + #error NUM_SMALL_INTS is less than NUM_CHARS which will not work #endif #endif -/* if NUM_SMALL_INTS 256, tvect: +240 trclo +200 tfft +170 trec +300 etc -- - * mostly gc + various adds */ +/* if NUM_SMALL_INTS 256, tvect: +240 trclo +200 tfft +170 trec +300 etc -- mostly gc + various adds */ -static bool t_number_separator_p[NUM_CHARS]; -static s7_cell* small_ints= NULL; +static bool t_number_separator_p[NUM_CHARS]; +static s7_cell *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) { - s7_cell* cells; - small_ints= (s7_cell*) Malloc ( - NUM_SMALL_INTS * - sizeof (s7_cell)); /* was calloc 14-Apr-22, used a pointless intermediate - s7_pointer array until 22-May-25 */ - for (int32_t i= 0; i < NUM_SMALL_INTS; i++) { - s7_pointer p; - p = &small_ints[i]; - full_type (p)= T_IMMUTABLE | T_INTEGER | T_UNHEAP; - set_integer (p, i); - } -/* setup a few other numbers while we're here */ -#define EXTRA_NUMBERS 11 - cells= (s7_cell*) Malloc (EXTRA_NUMBERS * sizeof (s7_cell)); - -#define init_integer(Ptr, Num) \ - do { \ - full_type (Ptr)= T_INTEGER | T_IMMUTABLE | T_UNHEAP; \ - set_integer (Ptr, Num); \ - } while (0) -#define init_real(Ptr, Num) \ - do { \ - full_type (Ptr)= T_REAL | T_IMMUTABLE | T_UNHEAP; \ - set_real (Ptr, Num); \ - } while (0) -#define init_complex(Ptr, Real, Imag) \ - do { \ - full_type (Ptr)= T_COMPLEX | T_IMMUTABLE | T_UNHEAP; \ - set_real_part (Ptr, Real); \ - set_imag_part (Ptr, Imag); \ - } while (0) +#define is_small_int(n) ((n & ~(NUM_SMALL_INTS - 1)) == 0) /* ((n >= 0) && (n < NUM_SMALL_INTS)) is slower */ - real_zero= &cells[0]; - init_real (real_zero, 0.0); - real_one= &cells[1]; - init_real (real_one, 1.0); - real_NaN= &cells[2]; - init_real (real_NaN, NAN); - complex_NaN= &cells[10]; - init_complex (complex_NaN, NAN, NAN); - real_infinity= &cells[3]; - init_real (real_infinity, INFINITY); - real_minus_infinity= &cells[4]; - init_real (real_minus_infinity, -INFINITY); - real_pi= &cells[5]; - init_real (real_pi, 3.1415926535897932384626433832795029L); - - arity_not_set= &cells[6]; - init_integer (arity_not_set, CLOSURE_ARITY_NOT_SET); - max_arity= &cells[7]; - init_integer (max_arity, MAX_ARITY); - minus_one= &cells[8]; - init_integer (minus_one, -1); - minus_two= &cells[9]; - init_integer (minus_two, -2); +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) +{ + s7_cell *cells; + small_ints = (s7_cell *)Malloc(NUM_SMALL_INTS * sizeof(s7_cell)); /* was calloc 14-Apr-22, used a pointless intermediate s7_pointer array until 22-May-25 */ + for (int32_t i = 0; i < NUM_SMALL_INTS; i++) + { + s7_pointer p; + p = &small_ints[i]; + full_type(p) = T_IMMUTABLE | T_INTEGER | T_UNHEAP; + set_integer(p, i); + } + /* setup a few other numbers while we're here */ + #define EXTRA_NUMBERS 11 + cells = (s7_cell *)Malloc(EXTRA_NUMBERS * sizeof(s7_cell)); + + #define init_integer(Ptr, Num) \ + do {full_type(Ptr) = T_INTEGER | T_IMMUTABLE | T_UNHEAP; set_integer(Ptr, Num);} while (0) + #define init_real(Ptr, Num) \ + do {full_type(Ptr) = T_REAL | T_IMMUTABLE | T_UNHEAP; set_real(Ptr, Num);} while (0) + #define init_complex(Ptr, Real, Imag) \ + do {full_type(Ptr) = T_COMPLEX | T_IMMUTABLE | T_UNHEAP; set_real_part(Ptr, Real); set_imag_part(Ptr, Imag);} while (0) + + real_zero = &cells[0]; init_real(real_zero, 0.0); + real_one = &cells[1]; init_real(real_one, 1.0); + real_NaN = &cells[2]; init_real(real_NaN, NAN); + complex_NaN = &cells[10]; init_complex(complex_NaN, NAN, NAN); + real_infinity = &cells[3]; init_real(real_infinity, INFINITY); + real_minus_infinity = &cells[4]; init_real(real_minus_infinity, -INFINITY); + real_pi = &cells[5]; init_real(real_pi, 3.1415926535897932384626433832795029L); + + arity_not_set = &cells[6]; init_integer(arity_not_set, CLOSURE_ARITY_NOT_SET); + max_arity = &cells[7]; init_integer(max_arity, MAX_ARITY); + minus_one = &cells[8]; init_integer(minus_one, -1); + minus_two = &cells[9]; init_integer(minus_two, -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 (S7_INT64_MAX); - leastfix= make_permanent_integer (S7_INT64_MIN); - for (int32_t i= 0; i < NUM_CHARS; i++) - t_number_separator_p[i]= true; - t_number_separator_p[(uint8_t) 'i']= false; - t_number_separator_p[(uint8_t) '+']= false; - t_number_separator_p[(uint8_t) '-']= false; - t_number_separator_p[(uint8_t) '/']= false; - t_number_separator_p[(uint8_t) '@']= false; - t_number_separator_p[(uint8_t) '.']= false; - t_number_separator_p[(uint8_t) 'e']= false; - t_number_separator_p[(uint8_t) 'E']= false; + int_one = &small_ints[1]; + int_two = &small_ints[2]; + int_three = &small_ints[3]; + + mostfix = make_permanent_integer(S7_INT64_MAX); + leastfix = make_permanent_integer(S7_INT64_MIN); + for (int32_t i = 0; i < NUM_CHARS; i++) t_number_separator_p[i] = true; + t_number_separator_p[(uint8_t)'i'] = false; + t_number_separator_p[(uint8_t)'+'] = false; + t_number_separator_p[(uint8_t)'-'] = false; + t_number_separator_p[(uint8_t)'/'] = false; + t_number_separator_p[(uint8_t)'@'] = false; + t_number_separator_p[(uint8_t)'.'] = false; + t_number_separator_p[(uint8_t)'e'] = false; + t_number_separator_p[(uint8_t)'E'] = false; } #define clamp_length(NLen, Len) (((NLen) < (Len)) ? (NLen) : (Len)) -/* -------------------------------------------------------------------------------- - */ -#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)); -} +/* -------------------------------------------------------------------------------- */ +#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 /* but this is cpu time? */ -#define ticks_per_second() CLOCKS_PER_SEC + #define my_clock clock /* but this is cpu time? */ + #define ticks_per_second() CLOCKS_PER_SEC #endif #ifndef GC_TRIGGER_SIZE -#define GC_TRIGGER_SIZE 64 + #define GC_TRIGGER_SIZE 64 #endif #if S7_DEBUGGING -void try_to_call_gc_1 (s7_scheme* sc, const char* func, int32_t line); -#define try_to_call_gc(Sc) try_to_call_gc_1 (Sc, __func__, __LINE__) + void try_to_call_gc_1(s7_scheme *sc, const char *func, int32_t line); + #define try_to_call_gc(Sc) try_to_call_gc_1(Sc, __func__, __LINE__) #else -void try_to_call_gc (s7_scheme* sc); + void try_to_call_gc(s7_scheme *sc); #endif #define GC_STATS 1 @@ -5111,5776 +3953,4010 @@ void try_to_call_gc (s7_scheme* sc); #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) +#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_unchecked(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. +/* 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_unchecked(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 FINIT NULL /* or sc->unused */ -#define new_cell(Sc, Obj, Type) \ - do { \ - if (Sc->gc_in_progress) \ - fprintf (stderr, "%s[%d]: new_cell during GC\n", __func__, __LINE__); \ - 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; \ - Obj->gc_line = 0; \ - Obj->object.cons.car = FINIT; \ - Obj->object.cons.cdr = FINIT; \ - Obj->object.cons.opt1 = FINIT; \ - Obj->object.cons.o2.opt2= FINIT; \ - Obj->object.cons.o3.opt3= FINIT; \ - set_full_type (Obj, Type); \ +#define new_cell(Sc, Obj, Type) \ + do { \ + if (Sc->gc_in_progress) fprintf(stderr, "%s[%d]: new_cell during GC\n", __func__, __LINE__); \ + 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; Obj->gc_line = 0; \ + Obj->object.cons.car = FINIT; Obj->object.cons.cdr = FINIT; Obj->object.cons.opt1 = FINIT; Obj->object.cons.o2.opt2 = FINIT; Obj->object.cons.o3.opt3 = FINIT; \ + set_full_type(Obj, Type); \ } while (0) -#define new_cell_unchecked(Sc, Obj, Type) \ - do { \ - if (Sc->gc_in_progress) \ - fprintf (stderr, "%s[%d]: new_cell_unchecked during GC\n", __func__, \ - __LINE__); \ - Obj= (*(--(Sc->free_heap_top))); \ - if (Sc->free_heap_top < Sc->free_heap) { \ - fprintf (stderr, "%s[%d]: free heap exhausted\n", __func__, __LINE__); \ - abort (); \ - } \ - Obj->debugger_bits = 0; \ - Obj->gc_func = NULL; \ - Obj->gc_line = 0; \ - Obj->object.cons.car = FINIT; \ - Obj->object.cons.cdr = FINIT; \ - Obj->object.cons.opt1 = FINIT; \ - Obj->object.cons.o2.opt2= FINIT; \ - Obj->object.cons.o3.opt3= FINIT; \ - set_full_type (Obj, Type); \ - } while (0) +#define new_cell_unchecked(Sc, Obj, Type) \ + do { \ + if (Sc->gc_in_progress) fprintf(stderr, "%s[%d]: new_cell_unchecked during GC\n", __func__, __LINE__); \ + Obj = (*(--(Sc->free_heap_top))); \ + if (Sc->free_heap_top < Sc->free_heap) {fprintf(stderr, "%s[%d]: free heap exhausted\n", __func__, __LINE__); abort();}\ + Obj->debugger_bits = 0; Obj->gc_func = NULL; Obj->gc_line = 0; \ + Obj->object.cons.car = FINIT; Obj->object.cons.cdr = FINIT; Obj->object.cons.opt1 = FINIT; Obj->object.cons.o2.opt2 = FINIT; Obj->object.cons.o3.opt3 = FINIT; \ + 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) */ +/* #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); \ - set_integer (_I_, _N_); \ - _I_; \ - })); \ - }) -#define make_integer_unchecked(Sc, N) \ - ({ \ - s7_int _N_; \ - _N_= (N); \ - (is_small_int (_N_) ? small_int (_N_) : ({ \ - s7_pointer _I_; \ - new_cell_unchecked (Sc, _I_, T_INTEGER); \ - set_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_unchecked (Sc, _R_, T_REAL); \ - set_real (_R_, _N_); \ - _R_; \ - }) +#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); set_integer(_I_, _N_); _I_;}) ); }) +#define make_integer_unchecked(Sc, N) \ + ({ s7_int _N_; _N_ = (N); (is_small_int(_N_) ? small_int(_N_) : ({ s7_pointer _I_; new_cell_unchecked(Sc, _I_, T_INTEGER); set_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_unchecked(Sc, _R_, T_REAL); set_real(_R_, _N_); _R_;}) #if S7_DEBUGGING -#define make_complex_not_0i(Sc, R, I) \ - ({ \ - s7_double _im_; \ - _im_= (I); \ - if (_im_ == 0.0) \ - fprintf (stderr, "%s[%d]: make_complex i: %f\n", __func__, __LINE__, \ - _im_); \ - ({ \ - s7_pointer _C_; \ - new_cell (Sc, _C_, T_COMPLEX); \ - set_real_part (_C_, R); \ - set_imag_part (_C_, _im_); \ - _C_; \ - }); \ - }) +#define make_complex_not_0i(Sc, R, I) \ + ({ s7_double _im_; _im_ = (I); if (_im_ == 0.0) fprintf(stderr, "%s[%d]: make_complex i: %f\n", __func__, __LINE__, _im_); \ + ({ s7_pointer _C_; new_cell(Sc, _C_, T_COMPLEX); set_real_part(_C_, R); set_imag_part(_C_, _im_); _C_;}); }) #else -#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_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_;}) #endif -#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 make_complex_unchecked(Sc, R, I) \ - ({ \ - s7_double _im_; \ - _im_= (I); \ - ((_im_ == 0.0) ? make_real_unchecked (Sc, R) : ({ \ - s7_pointer _C_; \ - new_cell_unchecked (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_) \ - : (s7_double) fraction (_x_)); \ - }) +#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 make_complex_unchecked(Sc, R, I) \ + ({ s7_double _im_; _im_ = (I); ((_im_ == 0.0) ? make_real_unchecked(Sc, R) : \ + ({ s7_pointer _C_; new_cell_unchecked(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_) : (s7_double)fraction(_x_)); }) #else -#define make_integer(Sc, N) s7_make_integer (Sc, N) -#define make_integer_unchecked(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_unchecked(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) +#define make_integer(Sc, N) s7_make_integer(Sc, N) +#define make_integer_unchecked(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_unchecked(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 + /* -------------------------------------------------------------------------------- * local versions of some standard C library functions - * timing tests involving these are very hard to interpret, local_memset is - * faster using s7_int than int32_t but don't replace local_memset and memclr64 - * with memset! tbig -> 290! + * timing tests involving these are very hard to interpret, local_memset is faster using s7_int than int32_t + * but don't replace local_memset and memclr64 with memset! tbig -> 290! */ -static void -local_memset (void* s, uint8_t val, size_t n) { - uint8_t* s2; +static void local_memset(void *s, uint8_t val, size_t n) +{ + uint8_t *s2; #if S7_ALIGNED - s2= (uint8_t*) s; + s2 = (uint8_t *)s; #else #if (defined(__x86_64__) || defined(__i386__)) - if (n >= 8) { - s7_int* s1 = (s7_int*) s; - size_t n8 = n >> 3; - s7_int ival= val | (val << 8) | (val << 16) | - (((s7_uint) val) - << 24); /* s7_uint casts make gcc/clang/fsanitize happy */ - ival= (((s7_uint) ival) << 32) | ival; - if ((n8 & 0x3) == 0) - while (n8 > 0) { - LOOP_4 (*s1++= ival); - n8-= 4; - } - else do { - *s1++= ival; - } while (--n8 > 0); - n&= 7; - s2= (uint8_t*) s1; - } - else s2= (uint8_t*) s; + if (n >= 8) + { + s7_int *s1 = (s7_int *)s; + size_t n8 = n >> 3; + s7_int ival = val | (val << 8) | (val << 16) | (((s7_uint)val) << 24); /* s7_uint casts make gcc/clang/fsanitize happy */ + ival = (((s7_uint)ival) << 32) | ival; + if ((n8 & 0x3) == 0) + while (n8 > 0) {LOOP_4(*s1++ = ival); n8 -= 4;} + else do {*s1++ = ival;} while (--n8 > 0); + n &= 7; + s2 = (uint8_t *)s1; + } + else s2 = (uint8_t *)s; #else - s2= (uint8_t*) s; + s2 = (uint8_t *)s; #endif #endif - while (n > 0) { - *s2++= val; - n--; - } + while (n > 0) + { + *s2++ = val; + n--; + } } -#define local_strcmp(S1, S2) (strcmp (S1, S2) == 0) -#define c_strings_are_equal(Str1, Str2) \ - (local_strcmp (Str1, Str2)) /* scheme strings can have embedded nulls */ +#define local_strcmp(S1, S2) (strcmp(S1, S2) == 0) +#define c_strings_are_equal(Str1, Str2) (local_strcmp(Str1, Str2)) /* scheme strings can have embedded nulls */ -#define strings_are_equal_with_length(Str1, Str2, Len) \ - (local_strncmp (Str1, Str2, Len)) +#define strings_are_equal_with_length(Str1, Str2, Len) (local_strncmp(Str1, Str2, Len)) -static char* -pos_int_to_str (s7_scheme* sc, s7_int num, s7_int* len, char endc) { - char* p = (char*) (sc->int_to_str3 + INT_TO_STR_SIZE - 1); /* str[31] */ - char* op= p; - if ((S7_DEBUGGING) && (num < 0)) { - fprintf (stderr, "%s[%d]: num=%" ld64, __func__, __LINE__, num); - if (sc->stop_at_error) abort (); - } - *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= (char*) (sc->int_to_str4 + INT_TO_STR_SIZE - 1); - if ((S7_DEBUGGING) && (num < 0)) { - fprintf (stderr, "%s[%d]: num=%" ld64, __func__, __LINE__, num); - if (sc->stop_at_error) abort (); - } - *p--= '\0'; - do { - *p--= "0123456789"[num % 10]; - num/= 10; - } while (num); - return ((char*) (p + 1)); +char *pos_int_to_str(s7_scheme *sc, s7_int num, s7_int *len, char endc) +{ + char *p = (char *)(sc->int_to_str3 + INT_TO_STR_SIZE - 1); /* str[31] */ + char *op = p; + if ((S7_DEBUGGING) && (num < 0)) {fprintf(stderr, "%s[%d]: num=%" ld64, __func__, __LINE__, num); if (sc->stop_at_error) abort();} + *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_1 (s7_scheme* sc, s7_int num) { - char* 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)); +char *pos_int_to_str_direct(s7_scheme *sc, s7_int num) +{ + char *p = (char *)(sc->int_to_str4 + INT_TO_STR_SIZE - 1); + if ((S7_DEBUGGING) && (num < 0)) {fprintf(stderr, "%s[%d]: num=%" ld64, __func__, __LINE__, num); if (sc->stop_at_error) abort();} + *p-- = '\0'; + do {*p-- = "0123456789"[num % 10]; num /= 10;} while (num); + return((char *)(p + 1)); +} + +char *pos_int_to_str_direct_1(s7_scheme *sc, s7_int num) +{ + char *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 WITH_GCC -#if S7_DEBUGGING -s7_pointer lookup_1 (s7_scheme* sc, const s7_pointer symbol); -#define lookup(Sc, Sym) \ - check_null_sym (Sc, lookup_1 (Sc, T_Sym (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, T_Sym (Sym)) -#define lookup_checked(Sc, Sym) \ - ({ \ - s7_pointer _x_; \ - _x_= lookup_1 (Sc, T_Sym (Sym)); \ - ((_x_) ? _x_ : unbound_variable (Sc, T_Sym (Sym))); \ - }) -#else -s7_pointer lookup (s7_scheme* sc, const s7_pointer symbol); -#define lookup_unexamined(Sc, Sym) lookup (Sc, Sym) -#define lookup_checked(Sc, Sym) \ - ({ \ - s7_pointer _x_; \ - _x_= lookup (Sc, Sym); \ - ((_x_) ? _x_ : unbound_variable (Sc, Sym)); \ - }) -#endif + #if S7_DEBUGGING + s7_pointer lookup_1(s7_scheme *sc, const s7_pointer symbol); + #define lookup(Sc, Sym) check_null_sym(Sc, lookup_1(Sc, T_Sym(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, T_Sym(Sym)) + #define lookup_checked(Sc, Sym) ({s7_pointer _x_; _x_ = lookup_1(Sc, T_Sym(Sym)); ((_x_) ? _x_ : unbound_variable(Sc, T_Sym(Sym)));}) + #else + s7_pointer lookup(s7_scheme *sc, const s7_pointer symbol); + #define lookup_unexamined(Sc, Sym) lookup(Sc, Sym) + #define lookup_checked(Sc, Sym) ({s7_pointer _x_; _x_ = lookup(Sc, Sym); ((_x_) ? _x_ : unbound_variable(Sc, Sym));}) + #endif #else -s7_pointer lookup (s7_scheme* sc, const s7_pointer symbol); -#define lookup_unexamined(Sc, Sym) \ - s7_symbol_value (Sc, \ - Sym) /* changed 3-Nov-22 -- we're using lookup_unexamined \ - below to avoid the unbound_variable check */ -#define lookup_checked(Sc, Sym) lookup (Sc, Sym) + s7_pointer lookup(s7_scheme *sc, const s7_pointer symbol); + #define lookup_unexamined(Sc, Sym) s7_symbol_value(Sc, Sym) /* changed 3-Nov-22 -- we're using lookup_unexamined below to avoid the unbound_variable check */ + #define lookup_checked(Sc, Sym) lookup(Sc, Sym) #endif -static s7_pointer symbol_to_local_slot (s7_scheme* sc, s7_pointer symbol, - s7_pointer let); +s7_pointer symbol_to_local_slot(s7_scheme *sc, s7_pointer symbol, s7_pointer let); + /* ---------------- 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 lower 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_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_SAFE_C_PP, - HOP_SAFE_C_PP, - OP_SAFE_C_FF, - HOP_SAFE_C_FF, - 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, - - OP_THUNK, - HOP_THUNK, - OP_THUNK_O, - HOP_THUNK_O, - OP_THUNK_ANY, - HOP_THUNK_ANY, - OP_SAFE_THUNK, - HOP_SAFE_THUNK, - OP_SAFE_THUNK_A, - HOP_SAFE_THUNK_A, - OP_SAFE_THUNK_ANY, - HOP_SAFE_THUNK_ANY, - - 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_3S_O, - HOP_CLOSURE_3S_O, - OP_CLOSURE_4S, - HOP_CLOSURE_4S, - OP_CLOSURE_4S_O, - HOP_CLOSURE_4S_O, - OP_CLOSURE_5S, - HOP_CLOSURE_5S, - 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, /* safe_closure_4s gained very little */ - 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_NP, - HOP_ANY_CLOSURE_NP, - OP_ANY_CLOSURE_SYM, - HOP_ANY_CLOSURE_SYM, - OP_ANY_CLOSURE_A_SYM, - HOP_ANY_CLOSURE_A_SYM, - - 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_C_SS, - HOP_C_SS, - OP_C_S, - HOP_C_S, - OP_C_SC, - HOP_C_SC, - 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_NC, - HOP_C_NC, - 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, - /* 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_G, - OP_S_A, - OP_S_AA, - OP_A_A, - OP_A_AA, - OP_A_SC, - OP_P_S, - OP_P_S_1, - OP_MAP_FOR_EACH_FA, - OP_MAP_FOR_EACH_FAA, - OP_F, - OP_F_A, - OP_F_AA, - OP_F_NP, - OP_F_NP_1, - - 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_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_HASH_TABLE_REF_AA, - OP_IMPLICIT_LET_REF_C, - OP_IMPLICIT_LET_REF_A, - OP_IMPLICIT_STARLET_REF_S, - OP_IMPLICIT_STARLET_SET_S, - OP_UNKNOWN, - OP_UNKNOWN_NS, - OP_UNKNOWN_NA, - OP_UNKNOWN_S, - OP_UNKNOWN_GG, - OP_UNKNOWN_A, - OP_UNKNOWN_AA, - OP_UNKNOWN_NP, - - OP_SYMBOL, - OP_CONSTANT, - OP_PAIR_SYM, - OP_PAIR_PAIR, - OP_PAIR_ANY, - 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_EVAL_SET1_NO_MV, - OP_EVAL_SET2, - OP_EVAL_SET2_MV, - OP_EVAL_SET2_NO_MV, - OP_EVAL_SET3, - OP_EVAL_SET3_MV, - OP_EVAL_SET3_NO_MV, - OP_APPLY, - OP_EVAL_MACRO, - OP_LAMBDA, - OP_QUOTE, - OP_QUOTE_UNCHECKED, - OP_MACROEXPAND, - OP_CALL_CC, - OP_CALL_WITH_EXIT, - OP_CALL_WITH_EXIT_O, - OP_C_CATCH, - OP_C_CATCH_ALL, - OP_C_CATCH_ALL_O, - OP_C_CATCH_ALL_A, - - 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_LET_STAR_SHADOWED, - 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_NA, - OP_LET_TEMP_A, - OP_LET_TEMP_SETTER, - OP_LET_TEMP_UNWIND, - OP_LET_TEMP_S7_UNWIND, - OP_LET_TEMP_SETTER_UNWIND, - OP_LET_TEMP_A_A, - OP_LET_TEMP_S7_OPENLETS, - OP_LET_TEMP_S7_OPENLETS_UNWIND, - 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_COMPLEX_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_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_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_MAP_UNWIND, - 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_S_C, - OP_SET_S_S, - OP_SET_S_P, - OP_SET_S_A, - OP_SET_NORMAL, - OP_SET_opSq_A, - OP_SET_opSAq_A, - OP_SET_opSAq_P, - OP_SET_opSAq_P_1, - OP_SET_opSAAq_A, - OP_SET_opSAAq_P, - OP_SET_opSAAq_P_1, - OP_SET_FROM_SETTER, - OP_SET_FROM_LET_TEMP, - OP_SET_SAFE, - OP_INCREMENT_BY_1, - OP_DECREMENT_BY_1, - OP_INCREMENT_SS, - OP_INCREMENT_SA, - OP_INCREMENT_SAA, - OP_SET_CONS, - - 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_NA, - OP_NAMED_LET_STAR, - OP_LET_NA_OLD, - OP_LET_NA_NEW, - OP_LET_2A_OLD, - OP_LET_2A_NEW, - OP_LET_3A_OLD, - OP_LET_3A_NEW, - OP_LET_opaSSq_OLD, - OP_LET_opaSSq_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_NA_OLD, - OP_LET_A_NA_NEW, - OP_LET_A_OLD_2, - OP_LET_A_NEW_2, - OP_LET_STAR_NA, - OP_LET_STAR_NA_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_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_E_S, - OP_CASE_I_S, - OP_CASE_G_S, - OP_CASE_E_G, - OP_CASE_G_G, - OP_CASE_A_I_S_A, - OP_CASE_A_E_S_A, - OP_CASE_A_G_S_A, - OP_CASE_A_S_G_A, - - 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_S_A_P, - 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_IS_TYPE_S_P_A, - OP_IF_IS_TYPE_S_A_A, - OP_IF_IS_TYPE_S_A_P, - 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_PN, - OP_IF_PR, - OP_IF_PRR, - OP_WHEN_PP, - OP_UNLESS_PP, - - OP_COND_NA_NA, - OP_COND_NA_NP, - OP_COND_NA_NP_1, - OP_COND_NA_2E, - OP_COND_NA_3E, - OP_COND_NA_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_NA_VARS, - OP_DO_NO_BODY_NA_VARS_STEP, - OP_DO_NO_BODY_NA_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_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_CONS_SP_1, - OP_SAFE_ADD_SP_1, - OP_SAFE_MULTIPLY_SP_1, - OP_SAFE_C_PS_1, - OP_SAFE_C_PC_1, - OP_EVAL_MACRO_MV, - OP_MACROEXPAND_1, - OP_APPLY_LAMBDA, - OP_ANY_C_NP_1, - OP_ANY_C_NP_MV, - OP_SAFE_C_SSP_1, - OP_C_P_1, - OP_C_AP_1, - OP_ANY_C_NP_2, - OP_SAFE_C_PA_1, - 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_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_L2A, - OP_TC_OR_A_AND_A_L2A, - OP_TC_AND_A_OR_A_L3A, - OP_TC_OR_A_AND_A_L3A, - 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_LA, - OP_TC_WHEN_L2A, - OP_TC_WHEN_L3A, - OP_TC_LET_WHEN_L2A, - OP_TC_COND_A_Z_A_L2A_L2A, - OP_TC_LET_COND, - OP_TC_COND_N, - OP_TC_IF_A_Z_LA, - OP_TC_IF_A_Z_L2A, - OP_TC_IF_A_Z_L3A, - 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_L2A, - OP_TC_IF_A_Z_IF_A_L2A_Z, - OP_TC_IF_A_Z_IF_A_Z_L3A, - OP_TC_IF_A_Z_IF_A_L3A_Z, - OP_TC_IF_A_Z_IF_A_L3A_L3A, - OP_TC_LET_IF_A_Z_LA, - OP_TC_LET_IF_A_Z_L2A, - OP_TC_IF_A_Z_LET_IF_A_Z_L2A, - OP_TC_AND_A_IF_A_Z_LA, - OP_TC_AND_A_IF_A_LA_Z, - OP_TC_CASE_LA, - OP_TC_CASE_L2A, - OP_TC_CASE_L3A, /* treat this as last tc op (see below) */ - - OP_RECUR_IF_A_A_opLA_LAq, - OP_RECUR_IF_A_A_opL2A_L2Aq, - OP_RECUR_IF_A_A_opL3A_L3Aq, - OP_RECUR_IF_A_A_opA_LAq, - OP_RECUR_IF_A_A_opA_L2Aq, - OP_RECUR_IF_A_A_opA_L3Aq, - OP_RECUR_IF_A_A_opLA_LA_LAq, - OP_RECUR_IF_A_A_AND_A_L2A_L2A, - OP_RECUR_IF_A_A_opA_LA_LAq, - OP_RECUR_IF_A_A_IF_A_A_opLA_LAq, - OP_RECUR_IF_A_A_IF_A_A_opL2A_L2Aq, - OP_RECUR_IF_A_A_IF_A_A_opL3A_L3Aq, - OP_RECUR_IF_A_A_IF_A_L2A_opA_L2Aq, - OP_RECUR_COND_A_A_A_A_opA_L2Aq, - OP_RECUR_COND_A_A_A_L2A_LopA_L2Aq, - OP_RECUR_AND_A_OR_A_L2A_L2A, - - NUM_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 lower 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_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_SAFE_C_PP, HOP_SAFE_C_PP, OP_SAFE_C_FF, HOP_SAFE_C_FF, 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, + + OP_THUNK, HOP_THUNK, OP_THUNK_O, HOP_THUNK_O, OP_THUNK_ANY, HOP_THUNK_ANY, + OP_SAFE_THUNK, HOP_SAFE_THUNK, OP_SAFE_THUNK_A, HOP_SAFE_THUNK_A, OP_SAFE_THUNK_ANY, HOP_SAFE_THUNK_ANY, + + 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_3S_O, HOP_CLOSURE_3S_O, OP_CLOSURE_4S, HOP_CLOSURE_4S, OP_CLOSURE_4S_O, HOP_CLOSURE_4S_O, OP_CLOSURE_5S, HOP_CLOSURE_5S, + 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, /* safe_closure_4s gained very little */ + 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_NP, HOP_ANY_CLOSURE_NP, + OP_ANY_CLOSURE_SYM, HOP_ANY_CLOSURE_SYM, OP_ANY_CLOSURE_A_SYM, HOP_ANY_CLOSURE_A_SYM, + + 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_C_SS, HOP_C_SS, OP_C_S, HOP_C_S, OP_C_SC, HOP_C_SC, 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_NC, HOP_C_NC, 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, + /* 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_G, OP_S_A, OP_S_AA, OP_A_A, OP_A_AA, OP_A_SC, OP_P_S, OP_P_S_1, OP_MAP_FOR_EACH_FA, OP_MAP_FOR_EACH_FAA, + OP_F, OP_F_A, OP_F_AA, OP_F_NP, OP_F_NP_1, + + 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_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_HASH_TABLE_REF_AA, + OP_IMPLICIT_LET_REF_C, OP_IMPLICIT_LET_REF_A, OP_IMPLICIT_STARLET_REF_S, OP_IMPLICIT_STARLET_SET_S, + OP_UNKNOWN, OP_UNKNOWN_NS, OP_UNKNOWN_NA, OP_UNKNOWN_S, OP_UNKNOWN_GG, OP_UNKNOWN_A, OP_UNKNOWN_AA, OP_UNKNOWN_NP, + + OP_SYMBOL, OP_CONSTANT, OP_PAIR_SYM, OP_PAIR_PAIR, OP_PAIR_ANY, 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_EVAL_SET1_NO_MV, OP_EVAL_SET2, OP_EVAL_SET2_MV, OP_EVAL_SET2_NO_MV, OP_EVAL_SET3, OP_EVAL_SET3_MV, OP_EVAL_SET3_NO_MV, + OP_APPLY, OP_EVAL_MACRO, OP_LAMBDA, OP_QUOTE, OP_QUOTE_UNCHECKED, OP_MACROEXPAND, OP_CALL_CC, OP_CALL_WITH_EXIT, OP_CALL_WITH_EXIT_O, + OP_C_CATCH, OP_C_CATCH_ALL, OP_C_CATCH_ALL_O, OP_C_CATCH_ALL_A, + + 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_LET_STAR_SHADOWED, + 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_NA, OP_LET_TEMP_A, OP_LET_TEMP_SETTER, OP_LET_TEMP_UNWIND, OP_LET_TEMP_S7_UNWIND, OP_LET_TEMP_SETTER_UNWIND, + OP_LET_TEMP_A_A, OP_LET_TEMP_S7_OPENLETS, OP_LET_TEMP_S7_OPENLETS_UNWIND, + 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_COMPLEX_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_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_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_MAP_UNWIND, + 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_S_C, OP_SET_S_S, OP_SET_S_P, OP_SET_S_A, + OP_SET_NORMAL, OP_SET_opSq_A, OP_SET_opSAq_A, OP_SET_opSAq_P, OP_SET_opSAq_P_1, OP_SET_opSAAq_A, OP_SET_opSAAq_P, OP_SET_opSAAq_P_1, + OP_SET_FROM_SETTER, OP_SET_FROM_LET_TEMP, OP_SET_SAFE, + OP_INCREMENT_BY_1, OP_DECREMENT_BY_1, OP_INCREMENT_SS, OP_INCREMENT_SA, OP_INCREMENT_SAA, OP_SET_CONS, + + 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_NA, OP_NAMED_LET_STAR, + OP_LET_NA_OLD, OP_LET_NA_NEW, OP_LET_2A_OLD, OP_LET_2A_NEW, OP_LET_3A_OLD, OP_LET_3A_NEW, + OP_LET_opaSSq_OLD, OP_LET_opaSSq_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_NA_OLD, OP_LET_A_NA_NEW, OP_LET_A_OLD_2, OP_LET_A_NEW_2, + OP_LET_STAR_NA, OP_LET_STAR_NA_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_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_E_S, OP_CASE_I_S, OP_CASE_G_S, OP_CASE_E_G, OP_CASE_G_G, + OP_CASE_A_I_S_A, OP_CASE_A_E_S_A, OP_CASE_A_G_S_A, OP_CASE_A_S_G_A, + + 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_S_A_P, 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_IS_TYPE_S_P_A, OP_IF_IS_TYPE_S_A_A, OP_IF_IS_TYPE_S_A_P, + 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_PN, OP_IF_PR, OP_IF_PRR, OP_WHEN_PP, OP_UNLESS_PP, + + OP_COND_NA_NA, OP_COND_NA_NP, OP_COND_NA_NP_1, OP_COND_NA_2E, OP_COND_NA_3E, OP_COND_NA_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_NA_VARS, OP_DO_NO_BODY_NA_VARS_STEP, OP_DO_NO_BODY_NA_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_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_CONS_SP_1, OP_SAFE_ADD_SP_1, OP_SAFE_MULTIPLY_SP_1, OP_SAFE_C_PS_1, OP_SAFE_C_PC_1, + OP_EVAL_MACRO_MV, OP_MACROEXPAND_1, OP_APPLY_LAMBDA, + OP_ANY_C_NP_1, OP_ANY_C_NP_MV, OP_SAFE_C_SSP_1, OP_C_P_1, OP_C_AP_1, OP_ANY_C_NP_2, OP_SAFE_C_PA_1, + 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_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_L2A, OP_TC_OR_A_AND_A_L2A, OP_TC_AND_A_OR_A_L3A, OP_TC_OR_A_AND_A_L3A, + 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_LA, OP_TC_WHEN_L2A, OP_TC_WHEN_L3A, OP_TC_LET_WHEN_L2A, + OP_TC_COND_A_Z_A_L2A_L2A, OP_TC_LET_COND, OP_TC_COND_N, + OP_TC_IF_A_Z_LA, OP_TC_IF_A_Z_L2A, OP_TC_IF_A_Z_L3A, + 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_L2A, OP_TC_IF_A_Z_IF_A_L2A_Z, + OP_TC_IF_A_Z_IF_A_Z_L3A, OP_TC_IF_A_Z_IF_A_L3A_Z, OP_TC_IF_A_Z_IF_A_L3A_L3A, + OP_TC_LET_IF_A_Z_LA, OP_TC_LET_IF_A_Z_L2A, OP_TC_IF_A_Z_LET_IF_A_Z_L2A, + OP_TC_AND_A_IF_A_Z_LA, OP_TC_AND_A_IF_A_LA_Z, + OP_TC_CASE_LA, OP_TC_CASE_L2A, OP_TC_CASE_L3A, /* treat this as last tc op (see below) */ + + OP_RECUR_IF_A_A_opLA_LAq, OP_RECUR_IF_A_A_opL2A_L2Aq, OP_RECUR_IF_A_A_opL3A_L3Aq, + OP_RECUR_IF_A_A_opA_LAq, OP_RECUR_IF_A_A_opA_L2Aq, OP_RECUR_IF_A_A_opA_L3Aq, + OP_RECUR_IF_A_A_opLA_LA_LAq, OP_RECUR_IF_A_A_AND_A_L2A_L2A, OP_RECUR_IF_A_A_opA_LA_LAq, + OP_RECUR_IF_A_A_IF_A_A_opLA_LAq, OP_RECUR_IF_A_A_IF_A_A_opL2A_L2Aq, OP_RECUR_IF_A_A_IF_A_A_opL3A_L3Aq, + OP_RECUR_IF_A_A_IF_A_L2A_opA_L2Aq, OP_RECUR_COND_A_A_A_A_opA_L2Aq, + OP_RECUR_COND_A_A_A_L2A_LopA_L2Aq, OP_RECUR_AND_A_OR_A_L2A_L2A, + + NUM_OPS}; #define is_tc_op(Op) ((Op >= OP_TC_AND_A_OR_A_LA) && (Op <= OP_TC_CASE_L3A)) -typedef enum { - combine_p, - combine_pp, - combine_cp, - combine_sp, - combine_pc, - combine_ps -} combine_op_t; +typedef enum {combine_p, combine_pp, combine_cp, combine_sp, combine_pc, combine_ps} combine_op_t; /* op_names[] moved to s7_op_names.c */ -#define is_safe_c_op(op) ((op >= OP_SAFE_C_NC) && (op < OP_THUNK)) -#define is_safe_closure_op(op) \ - ((op >= OP_SAFE_CLOSURE_S) && (op < OP_ANY_CLOSURE_3P)) -#define is_safe_closure_star_op(op) \ - ((op >= OP_SAFE_CLOSURE_STAR_A) && (op < OP_C_SS)) -#define is_unknown_op(op) ((op >= OP_UNKNOWN) && (op <= OP_UNKNOWN_NP)) -#define is_h_safe_c_nc(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 is_safe_c_op(op) ((op >= OP_SAFE_C_NC) && (op < OP_THUNK)) +#define is_safe_closure_op(op) ((op >= OP_SAFE_CLOSURE_S) && (op < OP_ANY_CLOSURE_3P)) +#define is_safe_closure_star_op(op) ((op >= OP_SAFE_CLOSURE_STAR_A) && (op < OP_C_SS)) +#define is_unknown_op(op) ((op >= OP_UNKNOWN) && (op <= OP_UNKNOWN_NP)) +#define is_h_safe_c_nc(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)); +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)); } /* if this changes, remember to change lint.scm */ -typedef enum { - sl_no_field= 0, - sl_accept_all_keyword_arguments, - sl_autoloading, - sl_catches, - sl_cpu_time, - sl_c_types, - sl_debug, - sl_default_hash_table_length, - sl_default_random_state, - sl_default_rationalize_error, - sl_equivalent_float_epsilon, - sl_expansions, - sl_filenames, - sl_file_names, - sl_float_format_precision, - sl_free_heap_size, - sl_gc_freed, - sl_gc_info, - sl_gc_protected_objects, - sl_gc_resize_heap_by_4_fraction, - sl_gc_resize_heap_fraction, - sl_gc_stats, - sl_gc_temps_size, - sl_gc_total_freed, - sl_hash_table_float_epsilon, - sl_hash_table_missing_key_value, - sl_heap_size, - sl_history, - sl_history_enabled, - sl_history_size, - sl_initial_string_port_length, - sl_iterator_at_end_value, - sl_major_version, - sl_max_heap_size, - sl_max_list_length, - sl_max_stack_size, - sl_max_string_length, - sl_max_string_port_length, - sl_max_vector_dimensions, - sl_max_vector_length, - sl_memory_usage, - sl_minor_version, - sl_most_negative_fixnum, - sl_most_positive_fixnum, - sl_muffle_warnings, - sl_number_separator, - sl_openlets, - sl_output_file_port_length, - sl_print_length, - sl_profile, - sl_profile_info, - sl_profile_prefix, - sl_rootlet_size, - sl_safety, - sl_scheme_version, - sl_stack, - sl_stacktrace_defaults, - sl_stack_size, - sl_stack_top, - sl_symbol_quote, - sl_symbol_printer, - sl_undefined_constant_warnings, - sl_undefined_identifier_warnings, - sl_version, - sl_num_fields -} starlet_t; - -static const char* starlet_names[sl_num_fields]= { - "no-field", - "accept-all-keyword-arguments", - "autoloading?", - "catches", - "cpu-time", - "c-types", - "debug", - "default-hash-table-length", - "default-random-state", - "default-rationalize-error", - "equivalent-float-epsilon", - "expansions?", - "filenames", - "file-names", - "float-format-precision", - "free-heap-size", - "gc-freed", - "gc-info", - "gc-protected-objects", - "gc-resize-heap-by-4-fraction", - "gc-resize-heap-fraction", - "gc-stats", - "gc-temps-size", - "gc-total-freed", - "hash-table-float-epsilon", - "hash-table-missing-key-value", - "heap-size", - "history", - "history-enabled", - "history-size", - "initial-string-port-length", - "iterator-at-end-value", - "major-version", - "max-heap-size", - "max-list-length", - "max-stack-size", - "max-string-length", - "max-string-port-length", - "max-vector-dimensions", - "max-vector-length", - "memory-usage", - "minor-version", - "most-negative-fixnum", - "most-positive-fixnum", - "muffle-warnings?", - "number-separator", - "openlets", - "output-file-port-length", - "print-length", - "profile", - "profile-info", - "profile-prefix", - "rootlet-size", - "safety", - "scheme-version", - "stack", - "stacktrace-defaults", - "stack-size", - "stack-top", - "symbol-quote?", - "symbol-printer", - "undefined-constant-warnings", - "undefined-identifier-warnings", - "version"}; - -static s7_pointer object_to_string_truncated (s7_scheme* sc, s7_pointer p); -static const char* type_name (s7_scheme* sc, s7_pointer arg, article_t article); -s7_pointer cons_unchecked (s7_scheme* sc, s7_pointer a, s7_pointer b); -s7_pointer unbound_variable (s7_scheme* sc, s7_pointer sym); - -#define bold_text "\033[1m" -#define unbold_text "\033[22m" -#define red_text "\033[31m" -#define green_text "\033[32m" -#define blue_text "\033[34m" +typedef enum {sl_no_field=0, sl_accept_all_keyword_arguments, sl_autoloading, sl_catches, sl_cpu_time, sl_c_types, + sl_debug, sl_default_hash_table_length, sl_default_random_state, sl_default_rationalize_error, sl_equivalent_float_epsilon, + sl_expansions, sl_filenames, sl_file_names, sl_float_format_precision, sl_free_heap_size, sl_gc_freed, sl_gc_info, + sl_gc_protected_objects, sl_gc_resize_heap_by_4_fraction, sl_gc_resize_heap_fraction, sl_gc_stats, sl_gc_temps_size, + sl_gc_total_freed, sl_hash_table_float_epsilon, sl_hash_table_missing_key_value, sl_heap_size, sl_history, sl_history_enabled, + sl_history_size, sl_initial_string_port_length, sl_iterator_at_end_value, sl_major_version, sl_max_heap_size, sl_max_list_length, + sl_max_stack_size, sl_max_string_length, sl_max_string_port_length, sl_max_vector_dimensions, sl_max_vector_length, + sl_memory_usage, sl_minor_version, sl_most_negative_fixnum, sl_most_positive_fixnum, sl_muffle_warnings, + sl_number_separator, sl_openlets, sl_output_file_port_length, sl_print_length, sl_profile, sl_profile_info, + sl_profile_prefix, sl_rootlet_size, sl_safety, sl_scheme_version, sl_stack, sl_stacktrace_defaults, sl_stack_size, sl_stack_top, + sl_symbol_quote, sl_symbol_printer, sl_undefined_constant_warnings, sl_undefined_identifier_warnings, sl_version, + sl_num_fields} starlet_t; + +static const char *starlet_names[sl_num_fields] = + {"no-field", "accept-all-keyword-arguments", "autoloading?", "catches", "cpu-time", "c-types", + "debug", "default-hash-table-length", "default-random-state", "default-rationalize-error", "equivalent-float-epsilon", + "expansions?", "filenames", "file-names", "float-format-precision", "free-heap-size", "gc-freed", "gc-info", + "gc-protected-objects", "gc-resize-heap-by-4-fraction", "gc-resize-heap-fraction", "gc-stats", "gc-temps-size", + "gc-total-freed", "hash-table-float-epsilon", "hash-table-missing-key-value", "heap-size", "history", "history-enabled", + "history-size", "initial-string-port-length", "iterator-at-end-value", "major-version", "max-heap-size", "max-list-length", + "max-stack-size", "max-string-length", "max-string-port-length", "max-vector-dimensions", "max-vector-length", + "memory-usage", "minor-version", "most-negative-fixnum", "most-positive-fixnum", "muffle-warnings?", + "number-separator", "openlets", "output-file-port-length", "print-length", "profile", "profile-info", + "profile-prefix", "rootlet-size", "safety", "scheme-version", "stack", "stacktrace-defaults", "stack-size", "stack-top", + "symbol-quote?", "symbol-printer", "undefined-constant-warnings", "undefined-identifier-warnings", "version"}; + +static s7_pointer object_to_string_truncated(s7_scheme *sc, s7_pointer p); +const char *type_name(s7_scheme *sc, s7_pointer arg, article_t article); +s7_pointer cons_unchecked(s7_scheme *sc, s7_pointer a, s7_pointer b); +s7_pointer unbound_variable(s7_scheme *sc, s7_pointer sym); + + +#define bold_text "\033[1m" +#define unbold_text "\033[22m" +#define red_text "\033[31m" +#define green_text "\033[32m" +#define blue_text "\033[34m" #define uncolor_text "\033[0m" /* yellow=33 */ -/* -------------------------------- internal debugging apparatus - * -------------------------------- */ -static s7_int -heap_location (s7_scheme* sc, s7_pointer p) { - for (heap_block_t* 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); + +/* -------------------------------- internal debugging apparatus -------------------------------- */ +static s7_int heap_location(s7_scheme *sc, s7_pointer p) +{ + for (heap_block_t *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 siglet; /* 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 unused) { - if (can_jump) LongJmp (siglet, 1); -} +static Jmp_Buf siglet; /* 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 unused) {if (can_jump) LongJmp(siglet, 1);} #endif #if S7_DEBUGGING -static bool -s7_is_in_heap (s7_scheme* sc, s7_pointer arg) /* for heap analysis where we only - care about stuff in the heap */ +static bool s7_is_in_heap(s7_scheme *sc, s7_pointer arg) /* for heap analysis where we only care about stuff in the heap */ { - s7_pointer heap0= *(sc->heap); - s7_pointer heap1= (s7_pointer) (heap0 + sc->heap_size); - return ((arg >= heap0) && (arg < heap1)); + s7_pointer heap0 = *(sc->heap); + s7_pointer heap1 = (s7_pointer)(heap0 + sc->heap_size); + return((arg >= heap0) && (arg < heap1)); } #endif -bool -s7_is_valid (s7_scheme* sc, s7_pointer arg) { - bool result= false; - if (!arg) return (false); +bool s7_is_valid(s7_scheme *sc, s7_pointer arg) +{ + bool result = false; + if (!arg) return(false); { - s7_pointer heap0= *(sc->heap); - s7_pointer heap1= (s7_pointer) (heap0 + sc->heap_size); - if ((arg >= heap0) && (arg < heap1)) return (true); + s7_pointer heap0 = *(sc->heap); + s7_pointer heap1 = (s7_pointer)(heap0 + sc->heap_size); + if ((arg >= heap0) && (arg < heap1)) return(true); } #if TRAP_SEGFAULT - if (SetJmp (siglet, 1) == 0) { - void (*old_segv) (int32_t sig); - can_jump= 1; - old_segv= signal (SIGSEGV, segv); + if (SetJmp(siglet, 1) == 0) + { + void (*old_segv)(int32_t sig); + can_jump = 1; + old_segv = signal(SIGSEGV, segv); #endif - if ((type_unchecked (arg) > T_FREE) && (type_unchecked (arg) < NUM_TYPES)) { - if (!in_heap (arg)) result= true; - else { - s7_int loc= heap_location (sc, arg); - if ((loc >= 0) && (loc < sc->heap_size)) result= (sc->heap[loc] == arg); - } - } + if ((type_unchecked(arg) > T_FREE) && + (type_unchecked(arg) < NUM_TYPES)) + { + if (!in_heap(arg)) + result = true; + else + { + s7_int 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; + signal(SIGSEGV, old_segv); + } + else result = false; + can_jump = 0; #endif - return (result); + return(result); } -#define safe_print(Code) \ - do { \ - bool _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_; \ +#define safe_print(Code) \ + do { \ + bool _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); -void -s7_show_history (s7_scheme* sc) { +void s7_show_history(s7_scheme *sc); +void s7_show_history(s7_scheme *sc) +{ #if WITH_HISTORY - if (sc->cur_code == sc->history_sink) fprintf (stderr, "history diabled\n"); - else { - s7_pointer p= cdr (sc->cur_code); - fprintf (stderr, "history:\n"); - for (int32_t i= 0, size= sc->history_size; i < size; - i++, p = cdr (p)) /* stepper "i" is not redundant */ - safe_print (fprintf (stderr, "%d: %s\n", i, display_truncated (car (p)))); - fprintf (stderr, "\n"); - } + if (sc->cur_code == sc->history_sink) + fprintf(stderr, "history diabled\n"); + else + { + s7_pointer p = cdr(sc->cur_code); + fprintf(stderr, "history:\n"); + for (int32_t i = 0, size = sc->history_size; i < size; i++, p = cdr(p)) /* stepper "i" is not redundant */ + safe_print(fprintf(stderr, "%d: %s\n", i, display_truncated(car(p)))); + fprintf(stderr, "\n"); + } #else - fprintf (stderr, "%s\n", display (sc->cur_code)); + fprintf(stderr, "%s\n", display(sc->cur_code)); #endif } #if S7_DEBUGGING -#define UNUSED_BITS \ - 0x000fc00000000c0 /* high 6 bits of optimizer code + high 2 bits of type */ - -static char* -describe_type_bits (s7_scheme* sc, s7_pointer obj) { - const s7_uint full_typ= full_type (obj); - const uint8_t typ = type_unchecked (obj); - 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_any_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_UNSAFE_DO) != 0) - ? ((is_pair (obj)) ? " unsafe-do" - : ((is_let (obj)) ? " dox-slot1" - : ((is_any_c_function (obj)) - ? " even-args" - : ((is_symbol (obj)) - ? " maybe-shadowed" - : " ?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_slot (obj)) ? " has-setter" - : " ?10?"))))) - : "", - /* bit 19 */ - ((full_typ & T_SHARED) != 0) ? ((is_sequence (obj)) ? " shared" : " ?11?") - : "", - /* bit 20 */ - ((full_typ & T_LOW_COUNT) != 0) - ? ((is_pair (obj)) ? " low-count" : " init-value") - : "", - /* 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_ALLOW_OTHER_KEYS) != 0) - ? ((is_pair (obj)) - ? " allow-other-keys|no-int-opt" - : ((is_slot (obj)) - ? " has-expression" - : ((is_c_function_star (obj)) - ? " allow-other-keys" - : ((is_let (obj)) ? " let-removed-from-heap" - : " ?17?")))) - : "", - /* bit 26 */ - ((full_typ & T_MUTABLE) != 0) - ? ((is_number (obj)) - ? " mutable" - : ((is_symbol (obj)) - ? " has-keyword" - : ((is_let (obj)) - ? " ref-fallback" - : ((is_iterator (obj)) - ? " mark-sequence" - : ((is_slot (obj)) - ? " step-end" - : ((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_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)) - ? " loop-end-possible" - : ((is_slot (obj)) ? " in-rootlet" - : ((is_c_function (obj)) - ? " bool-function" - : ((is_symbol (obj)) - ? " symbol-from-symbol" - : " ?23?"))))) - : "", - /* bit 24+24 */ - ((full_typ & T_FULL_SYMCONS) != 0) - ? ((is_symbol (obj)) - ? " possibly-constant" - : ((is_any_procedure (obj)) - ? " has-let-arg" - : ((is_hash_table (obj)) - ? " has-value-type" - : ((is_pair (obj)) - ? " int-optable" - : ((is_let (obj)) ? " unlet" - : ((is_t_vector (obj)) - ? " symbol-table" - : " ?24?")))))) - : "", - /* bit 25+24 */ - ((full_typ & T_FULL_HAS_LET_FILE) != 0) - ? ((is_let (obj)) - ? " has-let-file" - : ((is_t_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" - : ((is_syntax (obj)) ? " syntax-binder" - : " ?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" - : ((is_pair (obj)) ? " fx-treeable" : " ?31?")) - : "", - /* bit 32+24 */ - ((full_typ & T_FULL_SIMPLE_ELEMENTS) != 0) - ? ((is_t_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_TRUE_IS_DONE) != 0) - ? ((is_pair (obj)) ? " #t-is-done" - : ((is_symbol (obj)) ? " saver-symbol" - : ((is_c_function (obj)) - ? " saver-c-function" - : " ?34?"))) - : "", - /* bit 35+24 */ - ((full_typ & T_FULL_UNKNOPT) != 0) - ? ((is_pair (obj)) - ? " unknopt" - : ((is_symbol (obj)) - ? " translucent-symbol" - : ((is_c_function (obj)) ? " translucent-c-function" - : " ?35?"))) - : "", - /* bit 36+24 */ - ((full_typ & T_FULL_SAFETY_CHECKED) != 0) - ? ((is_pair (obj)) - ? " safety-checked" - : ((is_symbol (obj)) - ? " setter" - : ((is_c_function (obj)) - ? " setter-c-function" - : ((is_syntax (obj)) ? " setter-syntax" - : " ?36?")))) - : "", - /* bit 37+24 */ - ((full_typ & T_FULL_HAS_FN) != 0) - ? ((is_pair (obj)) - ? " has-fn" - : ((is_symbol (obj)) - ? " escaper-symbol" - : ((is_syntax (obj)) - ? " escaper-syntax" - : ((is_c_function (obj)) ? " escaper-c-function" - : " ?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" - : "", - (((is_any_macro (obj)) || (is_syntax (obj))) && - ((full_typ & T_DONT_EVAL_ARGS) == 0)) - ? " dont-eval-args not set" - : "", - /* for is_applicable, e.g. goto is not a safe procedure -- maybe check - goto/continuation...? */ - NULL); +#define UNUSED_BITS 0x000fc00000000c0 /* high 6 bits of optimizer code + high 2 bits of type */ + +static char *describe_type_bits(s7_scheme *sc, s7_pointer obj) +{ + const s7_uint full_typ = full_type(obj); + const uint8_t typ = type_unchecked(obj); + 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_any_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_UNSAFE_DO) != 0) ? ((is_pair(obj)) ? " unsafe-do" : + ((is_let(obj)) ? " dox-slot1" : + ((is_any_c_function(obj)) ? " even-args" : + ((is_symbol(obj)) ? " maybe-shadowed" : + " ?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_slot(obj)) ? " has-setter" : + " ?10?"))))) : "", + /* bit 19 */ + ((full_typ & T_SHARED) != 0) ? ((is_sequence(obj)) ? " shared" : " ?11?") : "", + /* bit 20 */ + ((full_typ & T_LOW_COUNT) != 0) ? ((is_pair(obj)) ? " low-count" : " init-value") : "", + /* 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_ALLOW_OTHER_KEYS) != 0) ? ((is_pair(obj)) ? " allow-other-keys|no-int-opt" : + ((is_slot(obj)) ? " has-expression" : + ((is_c_function_star(obj)) ? " allow-other-keys" : + ((is_let(obj)) ? " let-removed-from-heap" : + " ?17?")))) : "", + /* bit 26 */ + ((full_typ & T_MUTABLE) != 0) ? ((is_number(obj)) ? " mutable" : + ((is_symbol(obj)) ? " has-keyword" : + ((is_let(obj)) ? " ref-fallback" : + ((is_iterator(obj)) ? " mark-sequence" : + ((is_slot(obj)) ? " step-end" : + ((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_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)) ? " loop-end-possible" : + ((is_slot(obj)) ? " in-rootlet" : + ((is_c_function(obj)) ? " bool-function" : + ((is_symbol(obj)) ? " symbol-from-symbol" : + " ?23?"))))) : "", + /* bit 24+24 */ + ((full_typ & T_FULL_SYMCONS) != 0) ? ((is_symbol(obj)) ? " possibly-constant" : + ((is_any_procedure(obj)) ? " has-let-arg" : + ((is_hash_table(obj)) ? " has-value-type" : + ((is_pair(obj)) ? " int-optable" : + ((is_let(obj)) ? " unlet" : + ((is_t_vector(obj)) ? " symbol-table" : + " ?24?")))))) : "", + /* bit 25+24 */ + ((full_typ & T_FULL_HAS_LET_FILE) != 0) ? ((is_let(obj)) ? " has-let-file" : + ((is_t_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" : + ((is_syntax(obj)) ? " syntax-binder" : + " ?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" : + ((is_pair(obj)) ? " fx-treeable" : + " ?31?")) : "", + /* bit 32+24 */ + ((full_typ & T_FULL_SIMPLE_ELEMENTS) != 0) ? ((is_t_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_TRUE_IS_DONE) != 0) ? ((is_pair(obj)) ? " #t-is-done" : + ((is_symbol(obj)) ? " saver-symbol" : + ((is_c_function(obj)) ? " saver-c-function" : + " ?34?"))) : "", + /* bit 35+24 */ + ((full_typ & T_FULL_UNKNOPT) != 0) ? ((is_pair(obj)) ? " unknopt" : + ((is_symbol(obj)) ? " translucent-symbol" : + ((is_c_function(obj)) ? " translucent-c-function" : + " ?35?"))) : "", + /* bit 36+24 */ + ((full_typ & T_FULL_SAFETY_CHECKED) != 0) ? ((is_pair(obj)) ? " safety-checked" : + ((is_symbol(obj)) ? " setter" : + ((is_c_function(obj)) ? " setter-c-function" : + ((is_syntax(obj)) ? " setter-syntax" : + " ?36?")))) : "", + /* bit 37+24 */ + ((full_typ & T_FULL_HAS_FN) != 0) ? ((is_pair(obj)) ? " has-fn" : + ((is_symbol(obj)) ? " escaper-symbol" : + ((is_syntax(obj)) ? " escaper-syntax" : + ((is_c_function(obj)) ? " escaper-c-function" : + " ?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" : "", + (((is_any_macro(obj)) || (is_syntax(obj))) && ((full_typ & T_DONT_EVAL_ARGS) == 0)) ? " dont-eval-args not set" : "", + /* for is_applicable, e.g. goto is not a safe procedure -- maybe check goto/continuation...? */ + NULL); { - char* buf= (char*) Malloc (1024); - snprintf (buf, 1024, - "%s? (type: %d), opt_op: %d %s, full_type: #x%" PRIx64 "%s", - type_name (sc, obj, no_article), typ, optimize_op_unchecked (obj), - (optimize_op_unchecked (obj) < NUM_OPS) - ? op_names[optimize_op_unchecked (obj)] - : "", - full_typ, str); - return (buf); + char *buf = (char *)Malloc(1024); + snprintf(buf, 1024, "%s? (type: %d), opt_op: %d %s, full_type: #x%" PRIx64 "%s", + type_name(sc, obj, no_article), typ, + optimize_op_unchecked(obj), (optimize_op_unchecked(obj) < NUM_OPS) ? op_names[optimize_op_unchecked(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)))) */ +/* snprintf returns the number of bytes that would have been written: (display (c-pointer 123123123 (symbol (make-string 130 #\a)))) */ static bool never_unheaped[NUM_TYPES]; -static void -init_never_unheaped (void) { -#define HEAPED_SIZE 20 - const int32_t heaped[HEAPED_SIZE]= { - T_BACRO, T_BACRO_STAR, T_CATCH, T_CLOSURE, T_CLOSURE_STAR, - T_CONTINUATION, T_COUNTER, T_C_OBJECT, T_C_POINTER, T_DYNAMIC_WIND, - T_FREE, T_GOTO, T_HASH_TABLE, T_ITERATOR, T_MACRO, - T_MACRO_STAR, T_RANDOM_STATE, T_SLOT, T_STACK, T_VECTOR}; - /* T_UNUSED, like T_NIL, is never in the heap, but can be unheaped slot value - */ - for (int32_t i= 0; i < NUM_TYPES; i++) - never_unheaped[i]= false; - for (int32_t i= 0; i < HEAPED_SIZE; i++) - never_unheaped[heaped[i]]= true; -} - -static bool -has_odd_bits (s7_pointer obj) { - const s7_uint 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_pair (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_any_macro (obj))) - return (true); - if (((full_typ & T_MULTIPLE_VALUE) != 0) && (!is_symbol (obj)) && - (!is_pair (obj))) - return (true); - if (((full_typ & T_UNSAFE_DO) != 0) && (!is_pair (obj)) && (!is_let (obj)) && - (!is_any_c_function (obj)) && (!is_symbol (obj))) - return (true); - if (((full_typ & T_ITER_OK) != 0) && (!is_iterator (obj)) && - (!is_pair (obj)) && (!is_slot (obj)) && (!is_c_function (obj)) && - (!is_symbol (obj))) - return (true); +static void init_never_unheaped(void) +{ + #define HEAPED_SIZE 20 + const int32_t heaped[HEAPED_SIZE] = { + T_BACRO, T_BACRO_STAR, T_CATCH, T_CLOSURE, T_CLOSURE_STAR, T_CONTINUATION, T_COUNTER, T_C_OBJECT, T_C_POINTER, T_DYNAMIC_WIND, + T_FREE, T_GOTO, T_HASH_TABLE, T_ITERATOR, T_MACRO, T_MACRO_STAR, T_RANDOM_STATE, T_SLOT, T_STACK, T_VECTOR}; + /* T_UNUSED, like T_NIL, is never in the heap, but can be unheaped slot value */ + for (int32_t i = 0; i < NUM_TYPES; i++) never_unheaped[i] = false; + for (int32_t i = 0; i < HEAPED_SIZE; i++) never_unheaped[heaped[i]] = true; +} + +static bool has_odd_bits(s7_pointer obj) +{ + const s7_uint 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_pair(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_any_macro(obj))) return(true); + if (((full_typ & T_MULTIPLE_VALUE) != 0) && (!is_symbol(obj)) && (!is_pair(obj))) return(true); + if (((full_typ & T_UNSAFE_DO) != 0) && (!is_pair(obj)) && (!is_let(obj)) && (!is_any_c_function(obj)) && (!is_symbol(obj))) return(true); + if (((full_typ & T_ITER_OK) != 0) && (!is_iterator(obj)) && (!is_pair(obj)) && (!is_slot(obj)) && (!is_c_function(obj)) && (!is_symbol(obj))) return(true); /* if (((full_typ & T_LOW_COUNT) != 0) && (!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)) && - (!is_symbol (obj)) && (!is_c_function (obj))) - return (true); - if (((full_typ & T_FULL_SAFETY_CHECKED) != 0) && (!is_pair (obj)) && - (!is_normal_symbol (obj)) && (!is_c_function (obj)) && (!is_syntax (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_FULL_ALLOW_OTHER_KEYS) != 0) && (!is_slot (obj)) && - (!is_pair (obj)) && (!is_let (obj)) && (!is_c_function_star (obj)) && - (!is_let (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_any_procedure (obj)) && (!is_hash_table (obj)) && (!is_pair (obj)) && - (!is_let (obj)) && (!is_t_vector (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_t_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_pair (obj)) && - (!is_hash_table (obj)) && (!is_any_macro (obj)) && (!is_symbol (obj))) - return (true); - if (((full_typ & T_LOCATION) != 0) && (!is_pair (obj)) && - (!is_input_port (obj)) && (!is_let (obj)) && (!is_any_procedure (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_t_vector (obj)) && - (!is_hash_table (obj)) && (!is_normal_symbol (obj)) && (!is_pair (obj)) && - (type_unchecked (obj) < T_C_MACRO)) - return (true); - if (((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))) - 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)) && - (!is_symbol (obj)) && (!is_syntax (obj)) && (!is_c_function (obj))) - return (true); - if (((full_typ & T_FULL_TRUE_IS_DONE) != 0) && (!is_pair (obj)) && - (!is_symbol (obj)) && (!is_c_function (obj))) - return (true); - if (is_symbol (obj)) { - if ((uint8_t) (symbol_type (obj) & 0xff) >= NUM_TYPES) return (true); - if ((symbol_type (obj) & ~0xffff) != - 0) /* boolean function bool type and *s7*_let field id */ - return (true); - } - if ((signed_type (obj) == 0) && ((full_typ & T_GC_MARK) != 0)) 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)) && (!is_symbol(obj)) && (!is_c_function(obj))) return(true); + if (((full_typ & T_FULL_SAFETY_CHECKED) != 0) && (!is_pair(obj)) && (!is_normal_symbol(obj)) && (!is_c_function(obj)) && (!is_syntax(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_FULL_ALLOW_OTHER_KEYS) != 0) && (!is_slot(obj)) && (!is_pair(obj)) && (!is_let(obj)) && (!is_c_function_star(obj)) && (!is_let(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_any_procedure(obj)) && (!is_hash_table(obj)) && (!is_pair(obj)) && (!is_let(obj)) && (!is_t_vector(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_t_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_pair(obj)) && (!is_hash_table(obj)) && (!is_any_macro(obj)) && (!is_symbol(obj))) + return(true); + if (((full_typ & T_LOCATION) != 0) && + (!is_pair(obj)) && (!is_input_port(obj)) && (!is_let(obj)) && (!is_any_procedure(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_t_vector(obj)) && (!is_hash_table(obj)) && (!is_normal_symbol(obj)) && (!is_pair(obj)) && (type_unchecked(obj) < T_C_MACRO)) + return(true); + if (((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))) + 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)) && (!is_symbol(obj)) && (!is_syntax(obj)) && (!is_c_function(obj))) return(true); + if (((full_typ & T_FULL_TRUE_IS_DONE) != 0) && (!is_pair(obj)) && (!is_symbol(obj)) && (!is_c_function(obj))) return(true); + if (is_symbol(obj)) + { + if ((uint8_t)(symbol_type(obj) & 0xff) >= NUM_TYPES) + return(true); + if ((symbol_type(obj) & ~0xffff) != 0) /* boolean function bool type and *s7*_let field id */ + return(true); + } + if ((signed_type(obj) == 0) && ((full_typ & T_GC_MARK) != 0)) return(true); - if (!in_heap (obj)) { - uint8_t typ= type_unchecked (obj); - if (never_unheaped[typ]) { - fprintf (stderr, "unheap %s!\n", s7_type_names[typ]); - print_gc_info (cur_sc, obj, __func__, __LINE__); - return (true); + if (!in_heap(obj)) + { + uint8_t typ = type_unchecked(obj); + if (never_unheaped[typ]) {fprintf(stderr, "unheap %s!\n", s7_type_names[typ]); print_gc_info(cur_sc, obj, __func__, __LINE__); return(true);} } - } - /* all the hash_table bits seem to be compatible, symbols? - * (all_float/all_integer only apply to sc->divide_symbol et al at init time) - */ - return (false); + /* all the hash_table bits seem to be compatible, symbols? (all_float/all_integer only apply to sc->divide_symbol et al at init time) */ + return(false); } -void s7_show_let (s7_scheme* sc); -void -s7_show_let (s7_scheme* sc) /* debugging convenience */ +void s7_show_let(s7_scheme *sc); +void s7_show_let(s7_scheme *sc) /* debugging convenience */ { - for (s7_pointer let= sc->curlet; let; let= let_outlet (let)) { - if (let == sc->owlet) fprintf (stderr, "(owlet): "); - else if (let == sc->rootlet) fprintf (stderr, "(rootlet): "); - else if (is_funclet (let)) - fprintf (stderr, "(%s funclet): ", display (funclet_function (let))); - else if (let == sc->shadow_rootlet) fprintf (stderr, "(shadow rootlet): "); - fprintf (stderr, "%s\n", display (let)); - } + for (s7_pointer let = sc->curlet; let; let = let_outlet(let)) + { + if (let == sc->owlet) + fprintf(stderr, "(owlet): "); + else + if (let == sc->rootlet) + fprintf(stderr, "(rootlet): "); + else + if (is_funclet(let)) + fprintf(stderr, "(%s funclet): ", display(funclet_function(let))); + else + if (let == sc->shadow_rootlet) + fprintf(stderr, "(shadow rootlet): "); + fprintf(stderr, "%s\n", display(let)); + } } -static const char* -checked_type_name (s7_scheme* sc, int32_t typ) { - if ((typ >= 0) && (typ < NUM_TYPES)) { - s7_pointer p= sc->type_names[typ]; - if (is_string (p)) return (string_value (p)); - } - return ("unknown type!"); +static const char *checked_type_name(s7_scheme *sc, int32_t typ) +{ + if ((typ >= 0) && (typ < NUM_TYPES)) + { + s7_pointer p = sc->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_defined_global (symbol)) - fprintf (stderr, "%s[%d]: %s%s%s in %s\n", func, line, bold_text, - display (symbol), unbold_text, display_truncated (sc->cur_code)); - full_type (symbol)= (full_type (symbol) & ~(T_DONT_EVAL_ARGS | T_SYNTACTIC)); +static void set_local_1(s7_scheme *sc, s7_pointer symbol, const char *func, int32_t line) +{ + if (is_defined_global(symbol)) + fprintf(stderr, "%s[%d]: %s%s%s in %s\n", func, line, bold_text, display(symbol), unbold_text, display_truncated(sc->cur_code)); + full_type(symbol) = (full_type(symbol) & ~(T_DONT_EVAL_ARGS | T_SYNTACTIC)); } #endif -static char* -object_raw_type_to_string (s7_pointer p) { - char* buf= (char*) Malloc (128); - snprintf (buf, 128, "type: %d", type_unchecked (p)); - return (buf); -} - -static void -complain (s7_scheme* sc, const char* complaint, s7_pointer p, const char* func, - int32_t line, uint8_t typ) { - char* pstr= object_raw_type_to_string (p); - fprintf (stderr, complaint, bold_text, func, line, - checked_type_name (sc, typ), pstr, unbold_text); - free (pstr); - if (sc->stop_at_error) abort (); -} - -static char* -show_debugger_bits (s7_pointer p) { - char* bits_str= (char*) Malloc (512); - const s7_int bits = p->debugger_bits; - 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", - ((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) ? " opt1_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_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" : ""); - return (bits_str); -} - -static s7_pointer -check_ref_one (s7_pointer p, uint8_t expected_type, const char* func, - int32_t line, const char* func1, const char* func2) { - if (!p) { - fprintf (stderr, "%s%s[%d]: null pointer passed to check_ref_one%s\n", - bold_text, func, line, unbold_text); - if (cur_sc->stop_at_error) abort (); - } - else { - const uint8_t typ= type_unchecked (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, checked_type_name (cur_sc, expected_type), - checked_type_name (cur_sc, typ), object_raw_type_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, checked_type_name (cur_sc, expected_type), unbold_text); - if (cur_sc->stop_at_error) abort (); - } +static char *object_raw_type_to_string(s7_pointer p) +{ + char *buf = (char *)Malloc(128); + snprintf(buf, 128, "type: %d", type_unchecked(p)); + return(buf); +} + +static void complain(s7_scheme *sc, const char *complaint, s7_pointer p, const char *func, int32_t line, uint8_t typ) +{ + char *pstr = object_raw_type_to_string(p); + fprintf(stderr, complaint, bold_text, func, line, checked_type_name(sc, typ), pstr, unbold_text); + free(pstr); + if (sc->stop_at_error) abort(); +} + +static char *show_debugger_bits(s7_pointer p) +{ + char *bits_str = (char *)Malloc(512); + const s7_int bits = p->debugger_bits; + 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", + ((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) ? " opt1_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_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" : ""); + return(bits_str); +} + +static s7_pointer check_ref_one(s7_pointer p, uint8_t expected_type, const char *func, int32_t line, const char *func1, const char *func2) +{ + if (!p) + { + fprintf(stderr, "%s%s[%d]: null pointer passed to check_ref_one%s\n", bold_text, func, line, unbold_text); + if (cur_sc->stop_at_error) abort(); } - } - return (p); + else + { + const uint8_t typ = type_unchecked(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, checked_type_name(cur_sc, expected_type), checked_type_name(cur_sc, typ), object_raw_type_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, checked_type_name(cur_sc, expected_type), unbold_text); + if (cur_sc->stop_at_error) abort(); + }}} + return(p); } -static void -check_let_set_slots (s7_scheme* sc, s7_pointer let, s7_pointer slot, - const char* func, int32_t line) { - if ((!in_heap (let)) && (slot) && (in_heap (slot))) - fprintf (stderr, "%s[%d]: let+slot mismatch\n", func, line); - if ((let == sc->rootlet) && (slot != slot_end)) { - fprintf (stderr, "%s[%d]: setting rootlet slots!\n", func, line); - if (sc->stop_at_error) abort (); - } - T_Let (let)->object.let.slots= T_Sln (slot); +void check_let_set_slots(s7_scheme *sc, s7_pointer let, s7_pointer slot, const char *func, int32_t line) +{ + if ((!in_heap(let)) && (slot) && (in_heap(slot))) fprintf(stderr, "%s[%d]: let+slot mismatch\n", func, line); + if ((let == sc->rootlet) && (slot != slot_end)) + { + fprintf(stderr, "%s[%d]: setting rootlet slots!\n", func, line); + if (sc->stop_at_error) abort(); + } + T_Let(let)->object.let.slots = T_Sln(slot); } -static s7_pointer -check_let_ref (s7_pointer p, s7_uint role, const char* func, int32_t line) { - check_ref_one (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_ref(s7_pointer p, s7_uint role, const char *func, int32_t line) +{ + check_ref_one(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, s7_uint role, const char* func, int32_t line) { - check_ref_one (p, T_LET, func, line, NULL, NULL); - p->debugger_bits&= (~L_MASK); - p->debugger_bits|= (L_HIT | role); - return (p); +static s7_pointer check_let_set(s7_pointer p, s7_uint role, const char *func, int32_t line) +{ + check_ref_one(p, T_LET, func, line, NULL, NULL); + p->debugger_bits &= (~L_MASK); + p->debugger_bits |= (L_HIT | role); + return(p); } -static s7_pointer -check_ref_two (s7_pointer p, uint8_t expected_type, int32_t other_type, - const char* func, int32_t line, const char* func1, - const char* func2) { +static s7_pointer check_ref_two(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_ref_two\n", func, - line); - else { - uint8_t typ= type_unchecked (p); - if ((typ != expected_type) && (typ != other_type)) - return (check_ref_one (p, expected_type, func, line, func1, func2)); - } - return (p); + fprintf(stderr, "%s[%d]: null pointer passed to check_ref_two\n", func, line); + else + { + uint8_t typ = type_unchecked(p); + if ((typ != expected_type) && (typ != other_type)) + return(check_ref_one(p, expected_type, func, line, func1, func2)); + } + return(p); } -static s7_pointer -check_ref_prf (s7_pointer p, const char* func, int32_t line) { - uint8_t typ= type_unchecked (p); +static s7_pointer check_ref_prf(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = type_unchecked(p); if ((typ != T_PAIR) && (p != cur_sc->F)) - complain (cur_sc, "%s%s[%d]: not a pair or #f, but %s (%s)%s\n", p, func, - line, typ); - return (p); + complain(cur_sc, "%s%s[%d]: not a pair or #f, but %s (%s)%s\n", p, func, line, typ); + return(p); } -static s7_pointer -check_ref_prt (s7_pointer p, const char* func, int32_t line) { - uint8_t typ= type_unchecked (p); +static s7_pointer check_ref_prt(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = type_unchecked(p); if ((typ != T_INPUT_PORT) && (typ != T_OUTPUT_PORT) && (typ != T_FREE)) - complain (cur_sc, "%s%s[%d]: not a port, but %s (%s)%s\n", p, func, line, - typ); - return (p); + complain(cur_sc, "%s%s[%d]: not a port, but %s (%s)%s\n", p, func, line, typ); + return(p); } -static s7_pointer -check_ref_pri (s7_pointer p, const char* func, int32_t line) { - uint8_t typ= type_unchecked (p); +static s7_pointer check_ref_pri(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = type_unchecked(p); if ((typ != T_INPUT_PORT) && (p != cur_sc->F)) - complain (cur_sc, "%s%s[%d]: not an input port or #f, but %s (%s)%s\n", p, - func, line, typ); - return (p); + complain(cur_sc, "%s%s[%d]: not an input port or #f, but %s (%s)%s\n", p, func, line, typ); + return(p); } -static s7_pointer -check_ref_pro (s7_pointer p, const char* func, int32_t line) { - uint8_t typ= type_unchecked (p); +static s7_pointer check_ref_pro(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = type_unchecked(p); if ((typ != T_OUTPUT_PORT) && (p != cur_sc->F)) - complain (cur_sc, "%s%s[%d]: not an output port or #f, but %s (%s)%s\n", p, - func, line, typ); - return (p); -} - -static s7_pointer -check_ref_vec (s7_pointer p, const char* func, int32_t line) { - if ((strcmp (func, "sweep") != 0) && - (strcmp (func, "process_multivector") != 0)) { - uint8_t typ= type_unchecked (p); - if (!t_vector_p[typ]) - complain (cur_sc, "%s%s[%d]: not a vector, but %s (%s)%s\n", p, func, - line, typ); - } - return (p); -} - -static s7_pointer -check_ref_clo (s7_pointer p, const char* func, int32_t line) { - if (!p) - fprintf (stderr, "%s[%d]: null pointer passed to check_ref_clo\n", func, - line); - else { - uint8_t typ= type_unchecked (p); - if (!t_has_closure_let[typ]) - complain (cur_sc, "%s%s[%d]: not a closure, but %s (%s)%s\n", p, func, - line, typ); - } - return (p); -} - -static s7_pointer -check_ref_cfn (s7_pointer p, const char* func, int32_t line) { - uint8_t typ= type_unchecked (p); - if (typ < T_C_FUNCTION_STAR) - complain (cur_sc, - "%s%s[%d]: not a c-function (type < T_C_FUNCTION_STAR, from " - "T_CFn), but %s (%s)%s\n", - p, func, line, typ); - return (p); -} - -static s7_pointer -check_ref_fnc (s7_pointer p, const char* func, int32_t line) { - uint8_t typ= type_unchecked (p); - if (typ < T_C_MACRO) - complain (cur_sc, - "%s%s[%d]: not a c-function or c-macro (type < T_C_MACRO, from " - "T_Fnc), but %s (%s)%s\n", - p, func, line, typ); - return (p); -} - -static s7_pointer -check_ref_num (s7_pointer p, const char* func, int32_t line) { - uint8_t typ= type_unchecked (p); - if ((typ < T_INTEGER) || (typ > T_COMPLEX)) - complain (cur_sc, "%s%s[%d]: not a number, but %s (%s)%s\n", p, func, line, - typ); - return (p); -} - -static s7_pointer -check_ref_seq (s7_pointer p, const char* func, int32_t line) { - uint8_t typ= type_unchecked (p); - if ((!t_sequence_p[typ]) && (!t_structure_p[typ]) && - (!is_any_closure (p))) /* closure as iterator -- see s7test */ - complain (cur_sc, "%s%s[%d]: not a sequence or structure, but %s (%s)%s\n", - p, func, line, typ); - return (p); -} - -static s7_pointer -check_ref_met (s7_pointer p, const char* func, int32_t line) { - uint8_t typ= type_unchecked (p); - if ((typ != T_LET) && (typ != T_C_OBJECT) && (!is_any_closure (p)) && - (!is_any_macro (p)) && (typ != T_C_POINTER)) - complain (cur_sc, "%s%s[%d]: not a possible method holder, but %s (%s)%s\n", - p, func, line, typ); - return (p); -} - -static s7_pointer -check_ref_arg (s7_pointer p, const char* func, int32_t line) { - uint8_t typ= type_unchecked (p); - if ((typ != T_PAIR) && (typ != T_NIL) && (typ != T_SYMBOL)) - complain (cur_sc, "%s%s[%d]: arglist is %s (%s)%s?\n", p, func, line, typ); - return (p); + complain(cur_sc, "%s%s[%d]: not an output port or #f, but %s (%s)%s\n", p, func, line, typ); + return(p); } -static s7_pointer -check_ref_app (s7_pointer p, const char* func, int32_t line) { - uint8_t typ= type_unchecked (p); - if ((!t_applicable_p[typ]) && (p != cur_sc->F)) - complain (cur_sc, "%s%s[%d]: applicable object is %s (%s)%s?\n", p, func, - line, typ); - return (p); +static s7_pointer check_ref_vec(s7_pointer p, const char *func, int32_t line) +{ + if ((strcmp(func, "sweep") != 0) && + (strcmp(func, "process_multivector") != 0)) + { + uint8_t typ = type_unchecked(p); + if (!t_vector_p[typ]) complain(cur_sc, "%s%s[%d]: not a vector, but %s (%s)%s\n", p, func, line, typ); + } + return(p); } -static s7_pointer -check_ref_sln (s7_pointer p, const char* func, int32_t line) { - uint8_t typ; - if (is_slot_end (p)) return (p); - typ= type_unchecked (p); - if ((typ != T_SLOT) && - (typ != T_UNDEFINED)) /* unset slots are # */ - complain (cur_sc, "%s%s[%d]: slot is %s (%s)%s?\n", p, func, line, typ); - return (p); +static s7_pointer check_ref_clo(s7_pointer p, const char *func, int32_t line) +{ + if (!p) + fprintf(stderr, "%s[%d]: null pointer passed to check_ref_clo\n", func, line); + else + { + uint8_t typ = type_unchecked(p); + if (!t_has_closure_let[typ]) complain(cur_sc, "%s%s[%d]: not a closure, but %s (%s)%s\n", p, func, line, typ); + } + return(p); } -static s7_pointer -check_ref_out (s7_pointer p, const char* func, int32_t line) { - uint8_t typ; - if (!p) return (NULL); - typ= type_unchecked (p); - if (typ != T_LET) - complain (cur_sc, "%s%s[%d]: outlet is %s (%s)%s?\n", p, func, line, typ); - return (p); -} - -static s7_pointer -check_ref_svec (s7_pointer p, const char* func, int32_t line) { - if (!is_any_vector (p)) - complain (cur_sc, "%s%s[%d]: subvector is %s (%s)%s?\n", p, func, line, - type_unchecked (p)); - if (!is_subvector (p)) - complain (cur_sc, - "%s%s[%d]: subvector is %s (%s), but not a subvector?%s\n", p, - func, line, type_unchecked (p)); - return (p); -} - -static s7_pointer -check_ref_prc (s7_pointer p, const char* func, int32_t line) { - if ((!is_any_procedure (p)) && (!is_boolean (p))) - complain (cur_sc, "%s%s[%d]: setter is %s (%s)%s?\n", p, func, line, - type_unchecked (p)); - return (p); -} - -static void -print_gc_info (s7_scheme* sc, s7_pointer obj, const char* func, int32_t line) { - if (!obj) fprintf (stderr, "[%d]: obj is %p\n", line, obj); - else if (!is_free (obj)) - fprintf (stderr, "%s from %s[%d]: %p type is %d?\n", __func__, func, line, - obj, type_unchecked (obj)); - else { - const s7_int free_type= full_type (obj); - char* bits; - char fline[128]; - full_type (obj)= obj->alloc_type; /* not set_full_type here! it clobbers - existing alloc/free info */ - sc->printing_gc_info= true; - bits= describe_type_bits (sc, obj); /* this func called in type macro */ - sc->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 (%s[%d], alloc type: %s %" ld64 " #x%" PRIx64 - " (%s)), alloc: %s[%d], %sgc: %s[%d], uses: %d%s", - bold_text, obj, func, line, s7_type_names[obj->alloc_type & 0xff], - obj->alloc_type, obj->alloc_type, bits, obj->alloc_func, - obj->alloc_line, (obj->explicit_free_line > 0) ? fline : "", - obj->gc_func, obj->gc_line, obj->uses, unbold_text); - fprintf (stderr, "\n"); - free (bits); - } - if (sc->stop_at_error) abort (); +static s7_pointer check_ref_cfn(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = type_unchecked(p); + if (typ < T_C_FUNCTION_STAR) complain(cur_sc, "%s%s[%d]: not a c-function (type < T_C_FUNCTION_STAR, from T_CFn), but %s (%s)%s\n", p, func, line, typ); + return(p); } -static s7_pointer -check_nref (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 (cur_sc->stop_at_error) abort (); - } - else if (type_unchecked (p) >= NUM_TYPES) { - fprintf (stderr, "%s%s[%d]: attempt to use messed up cell (type: %d)%s\n", - bold_text, func, line, type_unchecked (p), unbold_text); - if (cur_sc->stop_at_error) abort (); - } - if (is_free (p)) { - fprintf (stderr, "%s%s[%d]: attempt to use free cell%s\n", bold_text, func, - line, unbold_text); - print_gc_info (cur_sc, p, func, line); - if (cur_sc->stop_at_error) abort (); - } - return (p); +static s7_pointer check_ref_fnc(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = type_unchecked(p); + if (typ < T_C_MACRO) complain(cur_sc, "%s%s[%d]: not a c-function or c-macro (type < T_C_MACRO, from T_Fnc), but %s (%s)%s\n", p, func, line, typ); + return(p); } -static s7_pointer -check_ref_nmv (s7_pointer p, const char* func, int32_t line) { - uint8_t typ; - check_nref (p, func, line); - typ= type_unchecked (p); /* must follow check_nref -- p might be NULL */ - if ((is_multiple_value (p)) && - (!safe_strcmp (func, "mark_slot"))) /* match == multiple-values which - causes false error messages */ - complain (cur_sc, "%s%s[%d]: slot value is a multiple-value, %s (%s)%s?\n", - p, func, line, typ); - if (has_odd_bits (p)) { - char* str; - fprintf (stderr, "%s[%d]: odd bits: %s\n", __func__, __LINE__, - str= describe_type_bits (cur_sc, p)); - free (str); - } - if (t_exs_p[typ]) /* can be t_slot, make_funclet[81614] */ - { - fprintf (stderr, "%s%s[%d]: slot_value is %s?%s\n", bold_text, func, line, - s7_type_names[typ], unbold_text); - if (cur_sc->stop_at_error) abort (); - } - return (p); -} - -static s7_pointer -check_ref_mac (s7_pointer p, const char* func, int32_t line) { - if ((!is_any_macro (p)) || (is_c_macro (p))) - complain (cur_sc, "%s%s[%d]: macro is %s (%s)%s?\n", p, func, line, - type_unchecked (p)); - return (p); -} - -static s7_pointer -check_ref_key (s7_pointer p, const char* func, int32_t line) { - if (!is_symbol_and_keyword (p)) - complain (cur_sc, "%s%s[%d]: not a keyword: %s (%s)%s?\n", p, func, line, - type_unchecked (p)); - if (strcmp (func, "new_symbol") != 0) { - if (global_value (p) != p) { - fprintf (stderr, - "%s%s[%d]: keyword %s value is not itself (type: %s)%s\n", - bold_text, func, line, display (p), - s7_type_names[type_unchecked (global_value (p))], unbold_text); - if (cur_sc->stop_at_error) abort (); - } - if (in_heap (keyword_symbol_unchecked (p))) - fprintf (stderr, "%s%s[%d]: keyword %s symbol is in the heap%s\n", - bold_text, func, line, display (p), unbold_text); - if (has_odd_bits (p)) { - char* str; - fprintf (stderr, "odd bits: %s\n", str= describe_type_bits (cur_sc, p)); - free (str); - } - } - return (p); +static s7_pointer check_ref_num(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = type_unchecked(p); + if ((typ < T_INTEGER) || (typ > T_COMPLEX)) + complain(cur_sc, "%s%s[%d]: not a number, but %s (%s)%s\n", p, func, line, typ); + return(p); } -static s7_pointer -check_ref_ext (s7_pointer p, const char* func, int32_t line) { - uint8_t typ; - check_nref (p, func, line); - typ= type_unchecked (p); - if (t_ext_p[typ]) { - fprintf (stderr, "%s%s[%d]: attempt to use (internal) %s cell%s\n", - bold_text, func, line, s7_type_names[typ], unbold_text); - if (cur_sc->stop_at_error) abort (); - } - return (p); +static s7_pointer check_ref_seq(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = type_unchecked(p); + if ((!t_sequence_p[typ]) && (!t_structure_p[typ]) && (!is_any_closure(p))) /* closure as iterator -- see s7test */ + complain(cur_sc, "%s%s[%d]: not a sequence or structure, but %s (%s)%s\n", p, func, line, typ); + return(p); } -static s7_pointer -check_ref_exs (s7_pointer p, const char* func, int32_t line) { - uint8_t typ; - check_nref (p, func, line); - typ= type_unchecked (p); - if (t_exs_p[typ]) { - fprintf (stderr, "%s%s[%d]: attempt to use (internal) %s cell%s\n", - bold_text, func, line, s7_type_names[typ], unbold_text); - if (cur_sc->stop_at_error) abort (); - } - return (p); +static s7_pointer check_ref_met(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = type_unchecked(p); + if ((typ != T_LET) && (typ != T_C_OBJECT) && (!is_any_closure(p)) && (!is_any_macro(p)) && (typ != T_C_POINTER)) + complain(cur_sc, "%s%s[%d]: not a possible method holder, but %s (%s)%s\n", p, func, line, typ); + return(p); } -static s7_pointer -check_opcode (s7_scheme* sc, s7_pointer p, const char* func, int32_t line) { - s7_int op= (s7_int) (intptr_t) p; - if ((op < 0) || (op >= NUM_OPS)) { - fprintf (stderr, "%s%s[%d]: opcode_t: %" ld64 " == %p?%s\n", bold_text, - func, line, op, p, unbold_text); - if (sc->stop_at_error) abort (); - } - return (p); -} - -static void -check_set_cdr (s7_pointer p, s7_pointer val, const char* func, - int32_t line) { /* set-car! is a bother to check -- many calls on - lists not in the heap etc */ - if ((is_immutable (p)) && (!in_heap (p))) { - fprintf ( - stderr, - "%s[%d]: set-cdr! target is immutable and not in the heap, %p %s\n", - func, line, p, display (p)); - if (cur_sc->stop_at_error) abort (); - } - if ((!in_heap (p)) && (in_heap (val))) - fprintf (stderr, - "%s[%d]: set-cdr! target is not in the heap, but the new value " - "is, %p %s, %p %s\n", - func, line, p, display (p), val, display (val)); - cdr (p)= val; -} - -static const char* -opt1_role_name (s7_uint role) { - if (role == OPT1_FAST) return ("opt1_fast"); - if (role == OPT1_CFUNC) return ("opt1_cfunc"); - if (role == OPT1_LAMBDA) return ("opt1_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 (s7_uint 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 (s7_uint 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 void -show_opt1_bits (s7_pointer p, const char* func, int32_t line, s7_uint role) { - char* bits= show_debugger_bits (p); - fprintf (stderr, - "%s%s[%d]%s: opt1: %p->%p wants %s, debugger bits are #x%" PRIx64 - "%s but expects #x%" PRIx64, - bold_text, func, line, unbold_text, p, p->object.cons.opt1, - opt1_role_name (role), p->debugger_bits, bits, (s7_int) role); - free (bits); -} - -static s7_pointer -opt1_1 (s7_scheme* sc, s7_pointer p, s7_uint 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 s7_pointer check_ref_arg(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = type_unchecked(p); + if ((typ != T_PAIR) && (typ != T_NIL) && (typ != T_SYMBOL)) + complain(cur_sc, "%s%s[%d]: arglist is %s (%s)%s?\n", p, func, line, typ); + return(p); } -static void -base_opt1 (s7_pointer p, s7_uint role) { - set_opt1_role (p, role); - set_opt1_is_set (p); +static s7_pointer check_ref_app(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = type_unchecked(p); + if ((!t_applicable_p[typ]) && (p != cur_sc->F)) + complain(cur_sc, "%s%s[%d]: applicable object is %s (%s)%s?\n", p, func, line, typ); + return(p); } -static s7_pointer -set_opt1_1 (s7_pointer p, s7_pointer x, s7_uint role, const char* func, - int32_t line) { - if (((p->debugger_bits & OPT1_MASK) != role) && - ((p->debugger_bits & OPT1_MASK) == OPT1_LAMBDA) && (role != OPT1_CFUNC)) - fprintf (stderr, "%s[%d]: opt1_lambda -> %s, op: %s, x: %s,\n %s\n", - func, line, opt1_role_name (role), - (is_optimized (x)) ? op_names[optimize_op (x)] : "unopt", - display (x), display (p)); - p->object.cons.opt1= x; - base_opt1 (p, role); - return (x); -} - -static s7_uint -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, (s7_uint) OPT1_HASH); - if (sc->stop_at_error) abort (); - } - return (p->object.sym_cons.hash); -} - -static void -set_opt1_hash_1 (s7_pointer p, s7_uint 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, s7_uint role) { - char* bits= show_debugger_bits (p); - fprintf (stderr, - "%s%s[%d]%s: %s opt2: %p->%p wants %s, debugger bits are #x%" PRIx64 - "%s but expects #x%" PRIx64 " %s", - bold_text, func, line, unbold_text, display (p), p, - p->object.cons.o2.opt2, opt2_role_name (role), p->debugger_bits, - bits, (s7_int) 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 void -check_opt2_bits (s7_scheme* sc, s7_pointer p, s7_uint 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 (); - } +static s7_pointer check_ref_sln(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ; + if (is_slot_end(p)) return(p); + typ = type_unchecked(p); + if ((typ != T_SLOT) && (typ != T_UNDEFINED)) /* unset slots are # */ + complain(cur_sc, "%s%s[%d]: slot is %s (%s)%s?\n", p, func, line, typ); + return(p); } -static s7_pointer -opt2_1 (s7_scheme* sc, s7_pointer p, s7_uint role, const char* func, - int32_t line) { - check_opt2_bits (sc, p, role, func, line); - return (p->object.cons.o2.opt2); -} - -static s7_int -opt2_n_1 (s7_scheme* sc, s7_pointer p, s7_uint role, const char* func, - int32_t line) { - check_opt2_bits (sc, p, role, func, line); - return (p->object.cons.o2.n); -} - -static void -base_opt2 (s7_pointer p, s7_uint 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, s7_uint 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_string_truncated (sc, p)), - ((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_truncated (p)); - if (sc->stop_at_error) abort (); - } - if ((role != OPT2_FN) && (has_fn (p))) { - fprintf (stderr, "%s[%d]: overwrite has_fn: %s %s\n", func, line, - opt2_role_name (role), display_truncated (p)); - if (sc->stop_at_error) abort (); - } - p->object.cons.o2.opt2= x; - base_opt2 (p, role); +static s7_pointer check_ref_out(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ; + if (!p) return(NULL); + typ = type_unchecked(p); + if (typ != T_LET) + complain(cur_sc, "%s%s[%d]: outlet is %s (%s)%s?\n", p, func, line, typ); + return(p); } -static void -set_opt2_n_1 (s7_scheme* unused_sc, s7_pointer p, s7_int x, s7_uint role, - const char* unused_func, int32_t unused_line) { - p->object.cons.o2.n= x; - base_opt2 (p, role); +static s7_pointer check_ref_svec(s7_pointer p, const char *func, int32_t line) +{ + if (!is_any_vector(p)) complain(cur_sc, "%s%s[%d]: subvector is %s (%s)%s?\n", p, func, line, type_unchecked(p)); + if (!is_subvector(p)) complain(cur_sc, "%s%s[%d]: subvector is %s (%s), but not a subvector?%s\n", p, func, line, type_unchecked(p)); + return(p); } -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, (s7_uint) OPT2_NAME); - if (sc->stop_at_error) abort (); - } - return (p->object.sym_cons.fstr); +static s7_pointer check_ref_prc(s7_pointer p, const char *func, int32_t line) +{ + if ((!is_any_procedure(p)) && (!is_boolean(p))) + complain(cur_sc, "%s%s[%d]: setter is %s (%s)%s?\n", p, func, line, type_unchecked(p)); + return(p); } -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 print_gc_info(s7_scheme *sc, s7_pointer obj, const char *func, int32_t line) +{ + if (!obj) + fprintf(stderr, "[%d]: obj is %p\n", line, obj); + else + if (!is_free(obj)) + fprintf(stderr, "%s from %s[%d]: %p type is %d?\n", __func__, func, line, obj, type_unchecked(obj)); + else + { + const s7_int free_type = full_type(obj); + char *bits; + char fline[128]; + full_type(obj) = obj->alloc_type; /* not set_full_type here! it clobbers existing alloc/free info */ + sc->printing_gc_info = true; + bits = describe_type_bits(sc, obj); /* this func called in type macro */ + sc->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 (%s[%d], alloc type: %s %" ld64 " #x%" PRIx64 " (%s)), alloc: %s[%d], %sgc: %s[%d], uses: %d%s", + bold_text, obj, func, line, s7_type_names[obj->alloc_type & 0xff], obj->alloc_type, obj->alloc_type, + bits, obj->alloc_func, obj->alloc_line, + (obj->explicit_free_line > 0) ? fline : "", obj->gc_func, obj->gc_line, obj->uses, unbold_text); + fprintf(stderr, "\n"); + free(bits); + } + if (sc->stop_at_error) abort(); +} + +static s7_pointer check_nref(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 (cur_sc->stop_at_error) abort(); + } + else + if (type_unchecked(p) >= NUM_TYPES) + { + fprintf(stderr, "%s%s[%d]: attempt to use messed up cell (type: %d)%s\n", bold_text, func, line, type_unchecked(p), unbold_text); + if (cur_sc->stop_at_error) abort(); + } + if (is_free(p)) + { + fprintf(stderr, "%s%s[%d]: attempt to use free cell%s\n", bold_text, func, line, unbold_text); + print_gc_info(cur_sc, p, func, line); + if (cur_sc->stop_at_error) abort(); + } + return(p); } -static void -show_opt3_bits (s7_pointer p, const char* func, int32_t line, s7_uint role) { - char* bits= show_debugger_bits (p); - fprintf (stderr, "%s%s[%d]%s: opt3: %s #x%" PRIx64 "%s", bold_text, func, - line, unbold_text, opt3_role_name (role), p->debugger_bits, bits); - free (bits); +static s7_pointer check_ref_nmv(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ; + check_nref(p, func, line); + typ = type_unchecked(p); /* must follow check_nref -- p might be NULL */ + if ((is_multiple_value(p)) && + (!safe_strcmp(func, "mark_slot"))) /* match == multiple-values which causes false error messages */ + complain(cur_sc, "%s%s[%d]: slot value is a multiple-value, %s (%s)%s?\n", p, func, line, typ); + if (has_odd_bits(p)) + {char *str; fprintf(stderr, "%s[%d]: odd bits: %s\n", __func__, __LINE__, str = describe_type_bits(cur_sc, p)); free(str);} + if (t_exs_p[typ]) /* can be t_slot, make_funclet[81614] */ + { + fprintf(stderr, "%s%s[%d]: slot_value is %s?%s\n", bold_text, func, line, s7_type_names[typ], unbold_text); + if (cur_sc->stop_at_error) abort(); + } + return(p); } -static void -check_opt3_bits (s7_scheme* sc, s7_pointer p, s7_uint role, const char* func, - int32_t line) { - if (!p) { - fprintf (stderr, "%s%s[%d]: opt3 null!\n%s", bold_text, func, line, - unbold_text); - if (sc->stop_at_error) abort (); - } - 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 check_ref_mac(s7_pointer p, const char *func, int32_t line) +{ + if ((!is_any_macro(p)) || (is_c_macro(p))) + complain(cur_sc, "%s%s[%d]: macro is %s (%s)%s?\n", p, func, line, type_unchecked(p)); + return(p); } -static s7_pointer -opt3_1 (s7_scheme* sc, s7_pointer p, s7_uint role, const char* func, - int32_t line) { - check_opt3_bits (sc, p, role, func, line); - return (p->object.cons.o3.opt3); +static s7_pointer check_ref_key(s7_pointer p, const char *func, int32_t line) +{ + if (!is_symbol_and_keyword(p)) + complain(cur_sc, "%s%s[%d]: not a keyword: %s (%s)%s?\n", p, func, line, type_unchecked(p)); + if (strcmp(func, "new_symbol") != 0) + { + if (global_value(p) != p) + { + fprintf(stderr, "%s%s[%d]: keyword %s value is not itself (type: %s)%s\n", + bold_text, func, line, display(p), s7_type_names[type_unchecked(global_value(p))], unbold_text); + if (cur_sc->stop_at_error) abort(); + } + if (in_heap(keyword_symbol_unchecked(p))) + fprintf(stderr, "%s%s[%d]: keyword %s symbol is in the heap%s\n", bold_text, func, line, display(p), unbold_text); + if (has_odd_bits(p)) + {char *str; fprintf(stderr, "odd bits: %s\n", str = describe_type_bits(cur_sc, p)); free(str);} + } + return(p); } -static s7_int -opt3_n_1 (s7_scheme* sc, s7_pointer p, s7_uint role, const char* func, - int32_t line) { - check_opt3_bits (sc, p, role, func, line); - return (p->object.cons.o3.n); +static s7_pointer check_ref_ext(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ; + check_nref(p, func, line); + typ = type_unchecked(p); + if (t_ext_p[typ]) + { + fprintf(stderr, "%s%s[%d]: attempt to use (internal) %s cell%s\n", bold_text, func, line, s7_type_names[typ], unbold_text); + if (cur_sc->stop_at_error) abort(); + } + return(p); } -static void -base_opt3 (s7_pointer p, s7_uint role) { - set_opt3_role (p, role); - set_opt3_is_set (p); +static s7_pointer check_ref_exs(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ; + check_nref(p, func, line); + typ = type_unchecked(p); + if (t_exs_p[typ]) + { + fprintf(stderr, "%s%s[%d]: attempt to use (internal) %s cell%s\n", bold_text, func, line, s7_type_names[typ], unbold_text); + if (cur_sc->stop_at_error) abort(); + } + return(p); } -static void -set_opt3_1 (s7_pointer p, s7_pointer x, s7_uint role) { - clear_type_bit (p, T_LOCATION); - p->object.cons.o3.opt3= x; - base_opt3 (p, role); +static s7_pointer check_opcode(s7_scheme *sc, s7_pointer p, const char *func, int32_t line) +{ + s7_int op = (s7_int)(intptr_t)p; + if ((op < 0) || (op >= NUM_OPS)) + { + fprintf(stderr, "%s%s[%d]: opcode_t: %" ld64 " == %p?%s\n", bold_text, func, line, op, p, unbold_text); + if (sc->stop_at_error) abort(); + } + return(p); } -static void -set_opt3_n_1 (s7_pointer p, s7_int x, s7_uint role) { - clear_type_bit (p, T_LOCATION); - p->object.cons.o3.n= x; - base_opt3 (p, role); +static void check_set_cdr(s7_pointer p, s7_pointer val, const char *func, int32_t line) +{ /* set-car! is a bother to check -- many calls on lists not in the heap etc */ + if ((is_immutable(p)) && (!in_heap(p))) + { + fprintf(stderr, "%s[%d]: set-cdr! target is immutable and not in the heap, %p %s\n", func, line, p, display(p)); + if (cur_sc->stop_at_error) abort(); + } + if ((!in_heap(p)) && (in_heap(val))) + fprintf(stderr, "%s[%d]: set-cdr! target is not in the heap, but the new value is, %p %s, %p %s\n", func, line, p, display(p), val, display(val)); + cdr(p) = val; } -static uint8_t -opt3_byte_1 (s7_scheme* sc, s7_pointer p, s7_uint role, const char* func, - int32_t line) { - check_opt3_bits (sc, p, role, func, line); - return (p->object.cons.o3.opt_type); +static const char *opt1_role_name(s7_uint role) +{ + if (role == OPT1_FAST) return("opt1_fast"); + if (role == OPT1_CFUNC) return("opt1_cfunc"); + if (role == OPT1_LAMBDA) return("opt1_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(s7_uint 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(s7_uint 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 void show_opt1_bits(s7_pointer p, const char *func, int32_t line, s7_uint role) +{ + char *bits = show_debugger_bits(p); + fprintf(stderr, "%s%s[%d]%s: opt1: %p->%p wants %s, debugger bits are #x%" PRIx64 "%s but expects #x%" PRIx64, + bold_text, func, line, unbold_text, + p, p->object.cons.opt1, opt1_role_name(role), p->debugger_bits, bits, (s7_int)role); + free(bits); } -static void -set_opt3_byte_1 (s7_pointer p, uint8_t x, s7_uint role, const char* unused_func, - int32_t unused_line) { - clear_type_bit (p, T_LOCATION); - p->object.cons.o3.opt_type= x; - base_opt3 (p, role); +static s7_pointer opt1_1(s7_scheme *sc, s7_pointer p, s7_uint 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 s7_uint -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, (s7_uint) OPT3_LOCATION); - if (sc->stop_at_error) abort (); - } - return ( - p->object.sym_cons - .location); /* don't use pair_location macro here or below (infinite - recursion if S7_DEBUGGING via opt3_location_1) */ -} - -static void -set_opt3_location_1 (s7_pointer p, s7_uint 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 s7_uint -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, (s7_uint) OPT3_LEN); - if (sc->stop_at_error) abort (); - } - return (p->object.sym_cons.location); +static void base_opt1(s7_pointer p, s7_uint role) +{ + set_opt1_role(p, role); + set_opt1_is_set(p); +} + +static s7_pointer set_opt1_1(s7_pointer p, s7_pointer x, s7_uint role, const char *func, int32_t line) +{ + if (((p->debugger_bits & OPT1_MASK) != role) && + ((p->debugger_bits & OPT1_MASK) == OPT1_LAMBDA) && + (role != OPT1_CFUNC)) + fprintf(stderr, "%s[%d]: opt1_lambda -> %s, op: %s, x: %s,\n %s\n", + func, line, opt1_role_name(role), + (is_optimized(x)) ? op_names[optimize_op(x)] : "unopt", + display(x), display(p)); + p->object.cons.opt1 = x; + base_opt1(p, role); + return(x); +} + +static s7_uint 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, (s7_uint)OPT1_HASH); + if (sc->stop_at_error) abort(); + } + return(p->object.sym_cons.hash); +} + +static void set_opt1_hash_1(s7_pointer p, s7_uint 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, s7_uint role) +{ + char *bits = show_debugger_bits(p); + fprintf(stderr, "%s%s[%d]%s: %s opt2: %p->%p wants %s, debugger bits are #x%" PRIx64 "%s but expects #x%" PRIx64 " %s", + bold_text, func, line, unbold_text, + display(p), p, p->object.cons.o2.opt2, opt2_role_name(role), p->debugger_bits, bits, (s7_int)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 void check_opt2_bits(s7_scheme *sc, s7_pointer p, s7_uint 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(); + } +} + +static s7_pointer opt2_1(s7_scheme *sc, s7_pointer p, s7_uint role, const char *func, int32_t line) +{ + check_opt2_bits(sc, p, role, func, line); + return(p->object.cons.o2.opt2); +} + +static s7_int opt2_n_1(s7_scheme *sc, s7_pointer p, s7_uint role, const char *func, int32_t line) +{ + check_opt2_bits(sc, p, role, func, line); + return(p->object.cons.o2.n); +} + +static void base_opt2(s7_pointer p, s7_uint role) +{ + set_opt2_role(p, role); + set_opt2_is_set(p); +} + +void set_opt2_1(s7_scheme *sc, s7_pointer p, s7_pointer x, s7_uint 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_string_truncated(sc, p)), + ((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_truncated(p)); + if (sc->stop_at_error) abort(); + } + if ((role != OPT2_FN) && (has_fn(p))) + { + fprintf(stderr, "%s[%d]: overwrite has_fn: %s %s\n", func, line, opt2_role_name(role), display_truncated(p)); + if (sc->stop_at_error) abort(); + } + p->object.cons.o2.opt2 = x; + base_opt2(p, role); +} + +static void set_opt2_n_1(s7_scheme *unused_sc, s7_pointer p, s7_int x, s7_uint role, const char *unused_func, int32_t unused_line) +{ + p->object.cons.o2.n = 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, (s7_uint)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, s7_uint role) +{ + char *bits = show_debugger_bits(p); + fprintf(stderr, "%s%s[%d]%s: opt3: %s #x%" 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, s7_uint role, const char *func, int32_t line) +{ + if (!p) + { + fprintf(stderr, "%s%s[%d]: opt3 null!\n%s", bold_text, func, line, unbold_text); + if (sc->stop_at_error) abort(); + } + 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, s7_uint role, const char *func, int32_t line) +{ + check_opt3_bits(sc, p, role, func, line); + return(p->object.cons.o3.opt3); +} + +static s7_int opt3_n_1(s7_scheme *sc, s7_pointer p, s7_uint role, const char *func, int32_t line) +{ + check_opt3_bits(sc, p, role, func, line); + return(p->object.cons.o3.n); +} + +static void base_opt3(s7_pointer p, s7_uint role) +{ + set_opt3_role(p, role); + set_opt3_is_set(p); +} + +void set_opt3_1(s7_pointer p, s7_pointer x, s7_uint role) +{ + clear_type_bit(p, T_LOCATION); + p->object.cons.o3.opt3 = x; + base_opt3(p, role); +} + +static void set_opt3_n_1(s7_pointer p, s7_int x, s7_uint role) +{ + clear_type_bit(p, T_LOCATION); + p->object.cons.o3.n = x; + base_opt3(p, role); +} + +static uint8_t opt3_byte_1(s7_scheme *sc, s7_pointer p, s7_uint role, const char *func, int32_t line) +{ + check_opt3_bits(sc, p, role, func, line); + return(p->object.cons.o3.opt_type); +} + +static void set_opt3_byte_1(s7_pointer p, uint8_t x, s7_uint role, const char *unused_func, int32_t unused_line) +{ + clear_type_bit(p, T_LOCATION); + p->object.cons.o3.opt_type = x; + base_opt3(p, role); +} + +static s7_uint 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, (s7_uint)OPT3_LOCATION); + if (sc->stop_at_error) abort(); + } + return(p->object.sym_cons.location); /* don't use pair_location macro here or below (infinite recursion if S7_DEBUGGING via opt3_location_1) */ +} + +static void set_opt3_location_1(s7_pointer p, s7_uint 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 s7_uint 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, (s7_uint)OPT3_LEN); + if (sc->stop_at_error) abort(); + } + return(p->object.sym_cons.location); } -static void -set_opt3_len_1 (s7_pointer p, s7_uint 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 set_opt3_len_1(s7_pointer p, s7_uint 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) { +void print_debugging_state(s7_scheme *sc, s7_pointer obj, s7_pointer port) +{ /* show current state, current allocated state */ - char * allocated_bits, *str; - const s7_int save_full_type= full_type (obj); - s7_int len, nlen; - const char* excl_name= (is_free (obj)) ? "free cell!" : "unknown object!"; - block_t* b; - char* current_bits= describe_type_bits (sc, obj); - - set_full_type (obj, obj->alloc_type); - allocated_bits= describe_type_bits (sc, obj); - set_full_type (obj, save_full_type); - - len= safe_strlen (excl_name) + safe_strlen (current_bits) + - safe_strlen (allocated_bits) + safe_strlen (obj->alloc_func) + 512; - b = mallocate (sc, len); - str = (char*) block_data (b); - nlen= snprintf (str, len, "\n<%s %s,\n alloc: %s[%d] %s, %d uses>", - excl_name, current_bits, obj->alloc_func, obj->alloc_line, - allocated_bits, obj->uses); - free (current_bits); - free (allocated_bits); - if (is_null (port)) - fprintf (stderr, "%s[%d]: %p: %s\n", __func__, __LINE__, obj, str); - else port_write_string (port) (sc, str, clamp_length (nlen, len), port); - liberate (sc, b); -} - -static s7_pointer -check_null_sym (s7_scheme* sc, s7_pointer p, s7_pointer sym, int32_t line, - const char* func) { - if (!p) { - const s7_pointer slot= symbol_to_local_slot (sc, sym, sc->curlet); - char* str = describe_type_bits (sc, sym); - 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 ", %s", - symbol_id (sym), let_id (sc->curlet), str); - free (str); - if (is_slot (slot)) fprintf (stderr, ", slot: %s", display (slot)); - fprintf (stderr, "\n"); - if (sc->stop_at_error) abort (); - } - return (p); + char *allocated_bits, *str; + const s7_int save_full_type = full_type(obj); + s7_int len, nlen; + const char *excl_name = (is_free(obj)) ? "free cell!" : "unknown object!"; + block_t *b; + char *current_bits = describe_type_bits(sc, obj); + + set_full_type(obj, obj->alloc_type); + allocated_bits = describe_type_bits(sc, obj); + set_full_type(obj, save_full_type); + + len = safe_strlen(excl_name) + safe_strlen(current_bits) + safe_strlen(allocated_bits) + safe_strlen(obj->alloc_func) + 512; + b = mallocate(sc, len); + str = (char *)block_data(b); + nlen = snprintf(str, len, + "\n<%s %s,\n alloc: %s[%d] %s, %d uses>", excl_name, current_bits, + obj->alloc_func, obj->alloc_line, allocated_bits, obj->uses); + free(current_bits); + free(allocated_bits); + if (is_null(port)) + fprintf(stderr, "%s[%d]: %p: %s\n", __func__, __LINE__, obj, str); + else port_write_string(port)(sc, str, clamp_length(nlen, len), port); + liberate(sc, b); +} + +static s7_pointer check_null_sym(s7_scheme *sc, s7_pointer p, s7_pointer sym, int32_t line, const char *func) +{ + if (!p) + { + const s7_pointer slot = symbol_to_local_slot(sc, sym, sc->curlet); + char *str = describe_type_bits(sc, sym); + 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 ", %s", symbol_id(sym), let_id(sc->curlet), str); + free(str); + if (is_slot(slot)) fprintf(stderr, ", slot: %s", display(slot)); + fprintf(stderr, "\n"); + if (sc->stop_at_error) abort(); + } + return(p); } #endif /* S7_DEBUGGING */ + /* -------- wrappers -------- */ -static s7_pointer -wrap_mutable_integer (s7_scheme* sc, - s7_int x) /* wrap_integer without small_int possibility -- - usable as a mutable integer for example */ +static s7_pointer wrap_mutable_integer(s7_scheme *sc, s7_int x) /* wrap_integer without small_int possibility -- usable as a mutable integer for example */ { - s7_pointer wrapped_int= car (sc->integer_wrappers); + s7_pointer wrapped_int = car(sc->integer_wrappers); #if S7_DEBUGGING - if ((full_type (wrapped_int) & (~T_GC_MARK)) != (T_INTEGER | T_UNHEAP)) - fprintf (stderr, "%s[%d]: %s\n", __func__, __LINE__, - describe_type_bits (sc, wrapped_int)); + if ((full_type(wrapped_int) & (~T_GC_MARK)) != (T_INTEGER | T_UNHEAP)) + fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, describe_type_bits(sc, wrapped_int)); sc->integer_wrapper_allocs++; #endif - set_integer (wrapped_int, x); - sc->integer_wrappers= cdr (sc->integer_wrappers); - return (wrapped_int); + set_integer(wrapped_int, x); + sc->integer_wrappers = cdr(sc->integer_wrappers); + return(wrapped_int); } -static s7_pointer -wrap_integer (s7_scheme* sc, s7_int x) { - if (is_small_int (x)) return (small_int (x)); - return (wrap_mutable_integer (sc, x)); +static s7_pointer wrap_integer(s7_scheme *sc, s7_int x) +{ + if (is_small_int(x)) return(small_int(x)); + return(wrap_mutable_integer(sc, x)); } -static s7_pointer -wrap_real (s7_scheme* sc, s7_double x) { - s7_pointer wrapped_real= car (sc->real_wrappers); +s7_pointer wrap_real(s7_scheme *sc, s7_double x) +{ + s7_pointer wrapped_real = car(sc->real_wrappers); #if S7_DEBUGGING - if ((full_type (wrapped_real) & (~T_GC_MARK)) != (T_REAL | T_UNHEAP)) - fprintf (stderr, "%s[%d]: %s\n", __func__, __LINE__, - describe_type_bits (sc, wrapped_real)); + if ((full_type(wrapped_real) & (~T_GC_MARK)) != (T_REAL | T_UNHEAP)) + fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, describe_type_bits(sc, wrapped_real)); sc->real_wrapper_allocs++; #endif - set_real (wrapped_real, x); - sc->real_wrappers= cdr (sc->real_wrappers); - return (wrapped_real); + set_real(wrapped_real, x); + sc->real_wrappers = cdr(sc->real_wrappers); + return(wrapped_real); } -static s7_pointer -wrap_complex (s7_scheme* sc, s7_double rl, s7_double im) { - s7_pointer wrapped_complex= car (sc->complex_wrappers); +static s7_pointer wrap_complex(s7_scheme *sc, s7_double rl, s7_double im) +{ + s7_pointer wrapped_complex = car(sc->complex_wrappers); #if S7_DEBUGGING - if ((full_type (wrapped_complex) & (~T_GC_MARK)) != (T_COMPLEX | T_UNHEAP)) - fprintf (stderr, "%s[%d]: %s\n", __func__, __LINE__, - describe_type_bits (sc, wrapped_complex)); + if ((full_type(wrapped_complex) & (~T_GC_MARK)) != (T_COMPLEX | T_UNHEAP)) + fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, describe_type_bits(sc, wrapped_complex)); sc->complex_wrapper_allocs++; #endif - set_real_part (wrapped_complex, rl); - set_imag_part (wrapped_complex, im); - sc->complex_wrappers= cdr (sc->complex_wrappers); - return (wrapped_complex); + set_real_part(wrapped_complex, rl); + set_imag_part(wrapped_complex, im); + sc->complex_wrappers = cdr(sc->complex_wrappers); + return(wrapped_complex); } -static s7_pointer -wrap_real_or_complex (s7_scheme* sc, s7_double rl, s7_double im) { - if (im == 0.0) return (wrap_real (sc, rl)); - return (wrap_complex (sc, rl, im)); +static s7_pointer wrap_real_or_complex(s7_scheme *sc, s7_double rl, s7_double im) +{ + if (im == 0.0) return(wrap_real(sc, rl)); + return(wrap_complex(sc, rl, im)); } -static s7_pointer -wrap_let (s7_scheme* sc, s7_pointer old_let) { - s7_pointer wrapped_let= car (sc->let_wrappers); +static s7_pointer wrap_let(s7_scheme *sc, s7_pointer old_let) +{ + s7_pointer wrapped_let = car(sc->let_wrappers); #if S7_DEBUGGING - if ((full_type (wrapped_let) & (~T_GC_MARK)) != - (T_LET | T_SAFE_PROCEDURE | T_UNHEAP)) - fprintf (stderr, "%s[%d]: %s\n", __func__, __LINE__, - describe_type_bits (sc, wrapped_let)); + if ((full_type(wrapped_let) & (~T_GC_MARK)) != (T_LET | T_SAFE_PROCEDURE | T_UNHEAP)) + fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, describe_type_bits(sc, wrapped_let)); sc->let_wrapper_allocs++; #endif - let_set_id (wrapped_let, ++sc->let_number); - let_set_slots (wrapped_let, slot_end); - let_set_outlet (wrapped_let, old_let); - sc->let_wrappers= cdr (sc->let_wrappers); - return (wrapped_let); + let_set_id(wrapped_let, ++sc->let_number); + let_set_slots(wrapped_let, slot_end); + let_set_outlet(wrapped_let, old_let); + sc->let_wrappers = cdr(sc->let_wrappers); + return(wrapped_let); } -static s7_pointer -wrap_slot (s7_scheme* sc, s7_pointer symbol, s7_pointer value) { - s7_pointer wrapped_slot= car (sc->slot_wrappers); +static s7_pointer wrap_slot(s7_scheme *sc, s7_pointer symbol, s7_pointer value) +{ + s7_pointer wrapped_slot = car(sc->slot_wrappers); #if S7_DEBUGGING - if ((full_type (wrapped_slot) & (~T_GC_MARK)) != (T_SLOT | T_UNHEAP)) - fprintf (stderr, "%s[%d]: %s\n", __func__, __LINE__, - describe_type_bits (sc, wrapped_slot)); + if ((full_type(wrapped_slot) & (~T_GC_MARK)) != (T_SLOT | T_UNHEAP)) + fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, describe_type_bits(sc, wrapped_slot)); sc->slot_wrapper_allocs++; #endif - slot_set_symbol_and_value (wrapped_slot, symbol, value); - sc->slot_wrappers= cdr (sc->slot_wrappers); - return (wrapped_slot); + slot_set_symbol_and_value(wrapped_slot, symbol, value); + sc->slot_wrappers = cdr(sc->slot_wrappers); + return(wrapped_slot); } /* -------- prebuilt lists -------- */ -s7_pointer -set_elist_1 (s7_scheme* sc, s7_pointer x1) { - set_car (sc->elist_1, x1); - return (sc->elist_1); -} - -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= 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= 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); +s7_pointer set_elist_1(s7_scheme *sc, s7_pointer x1) +{ + set_car(sc->elist_1, x1); + return(sc->elist_1); +} + +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); +} + +s7_pointer set_elist_3(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3) +{ + s7_pointer 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); +} + +s7_pointer set_elist_4(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4) +{ + s7_pointer 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) { - set_car (sc->elist_5, x1); - set_elist_4 (sc, x2, x3, x4, x5); - return (sc->elist_5); +s7_pointer set_elist_5(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4, s7_pointer x5) +{ + set_car(sc->elist_5, x1); + set_elist_4(sc, x2, x3, x4, x5); + return(sc->elist_5); } -static s7_pointer -set_elist_6 (s7_scheme* sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, - s7_pointer x4, s7_pointer x5, s7_pointer x6) { - set_car (sc->elist_6, x1); - set_elist_5 (sc, x2, x3, x4, x5, x6); - return (sc->elist_6); +static s7_pointer set_elist_6(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4, s7_pointer x5, s7_pointer x6) +{ + set_car(sc->elist_6, x1); + set_elist_5(sc, x2, x3, x4, x5, x6); + return(sc->elist_6); } -static s7_pointer -set_elist_7 (s7_scheme* sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, - s7_pointer x4, s7_pointer x5, s7_pointer x6, s7_pointer x7) { - set_car (sc->elist_7, x1); - set_elist_6 (sc, x2, x3, x4, x5, x6, x7); - return (sc->elist_7); +static s7_pointer set_elist_7(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4, s7_pointer x5, s7_pointer x6, s7_pointer x7) +{ + set_car(sc->elist_7, x1); + set_elist_6(sc, x2, x3, x4, x5, x6, x7); + return(sc->elist_7); } -static s7_pointer -set_wlist_3 (s7_pointer lst, s7_pointer x1, s7_pointer x2, s7_pointer x3) { - s7_pointer 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_3(s7_pointer lst, s7_pointer x1, s7_pointer x2, s7_pointer x3) +{ + s7_pointer 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= 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_wlist_4(s7_pointer lst, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4) +{ + s7_pointer 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_mlist_1 (s7_scheme* sc, s7_pointer x1) { - set_car (sc->mlist_1, x1); - return (sc->mlist_1); +s7_pointer set_mlist_1(s7_scheme *sc, s7_pointer x1) +{ + set_car(sc->mlist_1, x1); + return(sc->mlist_1); } -static s7_pointer -set_mlist_2 ( - s7_scheme* sc, s7_pointer x1, - s7_pointer x2) /* mlist_3 saves 3 in tmock -- see ~/old/s7-mlist_3.c */ +s7_pointer set_mlist_2(s7_scheme *sc, s7_pointer x1, s7_pointer x2) /* mlist_3 saves 3 in tmock -- see ~/old/s7-mlist_3.c */ { - set_car (sc->mlist_2, x1); - set_cadr (sc->mlist_2, x2); - return (sc->mlist_2); + set_car(sc->mlist_2, x1); + set_cadr(sc->mlist_2, x2); + return(sc->mlist_2); } -s7_pointer -set_plist_1 (s7_scheme* sc, s7_pointer x1) { - set_car (sc->plist_1, x1); - return (sc->plist_1); +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); +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)); +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_plist_4 (s7_scheme* sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, - s7_pointer x4) { - return (set_wlist_4 (sc->plist_4, x1, x2, x3, x4)); +static s7_pointer set_plist_4(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4) +{ + return(set_wlist_4(sc->plist_4, x1, x2, x3, x4)); } -static s7_pointer -set_qlist_2 (s7_scheme* sc, s7_pointer x1, s7_pointer x2) /* let_ref_fallback */ +s7_pointer set_qlist_2(s7_scheme *sc, s7_pointer x1, s7_pointer x2) /* let_ref_fallback */ { - set_car (sc->qlist_2, x1); - set_cadr (sc->qlist_2, x2); - return (sc->qlist_2); + 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) /* let_set_fallback */ +s7_pointer set_qlist_3(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3) /* let_set_fallback */ { - return (set_wlist_3 (sc->qlist_3, x1, x2, x3)); + return(set_wlist_3(sc->qlist_3, x1, x2, x3)); } -static s7_pointer -set_clist_1 (s7_scheme* sc, - s7_pointer x1) /* for c_object length method etc, a "weak" list */ +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); + set_car(sc->clist_1, x1); + return(sc->clist_1); } -static s7_pointer -set_clist_2 (s7_scheme* sc, s7_pointer x1, - s7_pointer x2) /* for c_object equal method etc, a "weak" list */ +static s7_pointer set_clist_2(s7_scheme *sc, s7_pointer x1, s7_pointer x2) /* for c_object equal method etc, a "weak" list */ { - set_car (sc->clist_2, x1); - set_cadr (sc->clist_2, x2); - return (sc->clist_2); + set_car(sc->clist_2, x1); + set_cadr(sc->clist_2, x2); + return(sc->clist_2); } -static s7_pointer -set_dlist_1 (s7_scheme* sc, - s7_pointer x1) /* another like clist: temp usage, "weak" (not - gc_marked), but semipermanent list */ +s7_pointer set_dlist_1(s7_scheme *sc, s7_pointer x1) /* another like clist: temp usage, "weak" (not gc_marked), but semipermanent list */ { - set_car (sc->dlist_1, x1); - return (sc->dlist_1); + 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_unchecked (sc->u1_1, x2); - return (sc->u1_1); +s7_pointer set_ulist_1(s7_scheme *sc, s7_pointer x1, s7_pointer x2) +{ + set_car(sc->u1_1, x1); + set_cdr_unchecked(sc->u1_1, x2); + return(sc->u1_1); } + /* ---------------- error handlers ---------------- */ -static const char* -make_type_name (s7_scheme* sc, const char* name, article_t article) { - s7_int i; - const s7_int slen= safe_strlen (name); +static const char *make_type_name(s7_scheme *sc, const char *name, article_t article) +{ + s7_int i; + const s7_int slen = safe_strlen(name); const s7_int 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), (const void*) name, slen); - sc->typnam[i + slen]= '\0'; - return (sc->typnam); -} - -static const char* -type_name_from_type (int32_t typ, article_t article) { - /* if the type enum never changed, this could just be an array lookup, but it - * doesn't matter -- this function isn't called much */ - const bool not_articled= (article == no_article); - switch (typ) { - case T_BACRO: - return ((not_articled) ? "bacro" : "a bacro"); - case T_BACRO_STAR: - return ((not_articled) ? "bacro*" : "a bacro*"); - case T_BOOLEAN: - return ("boolean"); - case T_BYTE_VECTOR: - return ((not_articled) ? "byte-vector" : "a byte-vector"); - case T_CATCH: - return ((not_articled) ? "catch" : "a catch"); - case T_CHARACTER: - return ((not_articled) ? "character" : "a character"); - case T_CLOSURE: - return ((not_articled) ? "function" : "a function"); - case T_CLOSURE_STAR: - return ((not_articled) ? "function*" : "a function*"); - case T_COMPLEX: - return ((not_articled) ? "complex-number" : "a complex number"); - case T_COMPLEX_VECTOR: - return ((not_articled) ? "complex-vector" : "a complex-vector"); - case T_CONTINUATION: - return ((not_articled) ? "continuation" : "a continuation"); - case T_COUNTER: - return ((not_articled) ? "internal-counter" : "an internal counter"); - case T_C_FUNCTION: - return ((not_articled) ? "c-function" : "a c-function"); - case T_C_FUNCTION_STAR: - return ((not_articled) ? "c-function*" : "a c-function*"); - case T_C_MACRO: - return ((not_articled) ? "c-macro" : "a c-macro"); - case T_C_OBJECT: - return ((not_articled) ? "c-object" : "a c_object"); - case T_C_POINTER: - return ((not_articled) ? "c-pointer" : "a c-pointer"); - case T_C_RST_NO_REQ_FUNCTION: - return ((not_articled) ? "c-function" : "a c-function"); - case T_DYNAMIC_WIND: - return ((not_articled) ? "dynamic-wind" : "a dynamic-wind"); - case T_EOF: - return ((not_articled) ? "#" : "the end-of-file object"); - case T_FLOAT_VECTOR: - return ((not_articled) ? "float-vector" : "a float-vector"); - case T_FREE: - return ((not_articled) ? "free-cell" : "a free cell"); - case T_GOTO: - return ((not_articled) ? "goto" : "a goto (from call-with-exit)"); - case T_HASH_TABLE: - return ((not_articled) ? "hash-table" : "a hash-table"); - case T_INPUT_PORT: - return ((not_articled) ? "input-port" : "an input port"); - case T_INTEGER: - return ((not_articled) ? "integer" : "an integer"); - case T_INT_VECTOR: - return ((not_articled) ? "int-vector" : "an int-vector"); - case T_ITERATOR: - return ((not_articled) ? "iterator" : "an iterator"); - case T_LET: - return ((not_articled) ? "let" : "a let"); - case T_MACRO: - return ((not_articled) ? "macro" : "a macro"); - case T_MACRO_STAR: - return ((not_articled) ? "macro*" : "a macro*"); - case T_NIL: - return ("nil"); - case T_OUTPUT_PORT: - return ((not_articled) ? "output-port" : "an output port"); - case T_PAIR: - return ((not_articled) ? "pair" : "a pair"); - case T_RANDOM_STATE: - return ((not_articled) ? "random-state" : "a random-state"); - case T_RATIO: - return ((not_articled) ? "ratio" : "a ratio"); - case T_REAL: - return ((not_articled) ? "real" : "a real"); - case T_SLOT: - return ((not_articled) ? "slot" : "a slot (variable binding)"); - case T_STACK: - return ((not_articled) ? "stack" : "a stack"); - case T_STRING: - return ((not_articled) ? "string" : "a string"); - case T_SYMBOL: - return ((not_articled) ? "symbol" : "a symbol"); - case T_SYNTAX: - return ((not_articled) ? "syntax" : "syntactic"); - case T_UNDEFINED: - return ((not_articled) ? "undefined" : "an undefined object"); - case T_UNSPECIFIED: - return ((not_articled) ? "#" : "the unspecified object"); - case T_UNUSED: - return ((not_articled) ? "#" : "the unused object"); - case T_VECTOR: - return ((not_articled) ? "vector" : "a vector"); - } - return (NULL); + 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), (const void *)name, slen); + sc->typnam[i + slen] = '\0'; + return(sc->typnam); } -static s7_pointer -find_let (s7_scheme* sc, s7_pointer obj) { - if ((S7_DEBUGGING) && (is_let (obj))) { - fprintf (stderr, "let passed to find_let: %s\n", display (obj)); - if (sc->stop_at_error) abort (); - } - if (has_closure_let (obj)) - return (closure_let (obj)); /* some of these are immutable -- they hold the - parameter names */ - switch (type (obj)) { - case T_C_OBJECT: - if (is_let (c_object_let (obj))) return (c_object_let (obj)); - return (sc->rootlet); - case T_C_POINTER: - if (is_let (c_pointer_info (obj))) return (c_pointer_info (obj)); - return (sc->rootlet); - case T_C_MACRO: - case T_C_FUNCTION_STAR: - case T_C_FUNCTION: - case T_C_RST_NO_REQ_FUNCTION: - return (c_function_let (obj)); - } - return (sc->nil); +static const char *type_name_from_type(int32_t typ, article_t article) +{ + /* if the type enum never changed, this could just be an array lookup, but it doesn't matter -- this function isn't called much */ + const bool not_articled = (article == no_article); + switch (typ) + { + case T_BACRO: return((not_articled) ? "bacro" : "a bacro"); + case T_BACRO_STAR: return((not_articled) ? "bacro*" : "a bacro*"); + case T_BOOLEAN: return("boolean"); + case T_BYTE_VECTOR: return((not_articled) ? "byte-vector" : "a byte-vector"); + case T_CATCH: return((not_articled) ? "catch" : "a catch"); + case T_CHARACTER: return((not_articled) ? "character" : "a character"); + case T_CLOSURE: return((not_articled) ? "function" : "a function"); + case T_CLOSURE_STAR: return((not_articled) ? "function*" : "a function*"); + case T_COMPLEX: return((not_articled) ? "complex-number" : "a complex number"); + case T_COMPLEX_VECTOR: return((not_articled) ? "complex-vector" : "a complex-vector"); + case T_CONTINUATION: return((not_articled) ? "continuation" : "a continuation"); + case T_COUNTER: return((not_articled) ? "internal-counter" : "an internal counter"); + case T_C_FUNCTION: return((not_articled) ? "c-function" : "a c-function"); + case T_C_FUNCTION_STAR: return((not_articled) ? "c-function*" : "a c-function*"); + case T_C_MACRO: return((not_articled) ? "c-macro" : "a c-macro"); + case T_C_OBJECT: return((not_articled) ? "c-object" : "a c_object"); + case T_C_POINTER: return((not_articled) ? "c-pointer" : "a c-pointer"); + case T_C_RST_NO_REQ_FUNCTION: return((not_articled) ? "c-function" : "a c-function"); + case T_DYNAMIC_WIND: return((not_articled) ? "dynamic-wind" : "a dynamic-wind"); + case T_EOF: return((not_articled) ? "#" : "the end-of-file object"); + case T_FLOAT_VECTOR: return((not_articled) ? "float-vector" : "a float-vector"); + case T_FREE: return((not_articled) ? "free-cell" : "a free cell"); + case T_GOTO: return((not_articled) ? "goto" : "a goto (from call-with-exit)"); + case T_HASH_TABLE: return((not_articled) ? "hash-table" : "a hash-table"); + case T_INPUT_PORT: return((not_articled) ? "input-port" : "an input port"); + case T_INTEGER: return((not_articled) ? "integer" : "an integer"); + case T_INT_VECTOR: return((not_articled) ? "int-vector" : "an int-vector"); + case T_ITERATOR: return((not_articled) ? "iterator" : "an iterator"); + case T_LET: return((not_articled) ? "let" : "a let"); + case T_MACRO: return((not_articled) ? "macro" : "a macro"); + case T_MACRO_STAR: return((not_articled) ? "macro*" : "a macro*"); + case T_NIL: return("nil"); + case T_OUTPUT_PORT: return((not_articled) ? "output-port" : "an output port"); + case T_PAIR: return((not_articled) ? "pair" : "a pair"); + case T_RANDOM_STATE: return((not_articled) ? "random-state" : "a random-state"); + case T_RATIO: return((not_articled) ? "ratio" : "a ratio"); + case T_REAL: return((not_articled) ? "real" : "a real"); + case T_SLOT: return((not_articled) ? "slot" : "a slot (variable binding)"); + case T_STACK: return((not_articled) ? "stack" : "a stack"); + case T_STRING: return((not_articled) ? "string" : "a string"); + case T_SYMBOL: return((not_articled) ? "symbol" : "a symbol"); + case T_SYNTAX: return((not_articled) ? "syntax" : "syntactic"); + case T_UNDEFINED: return((not_articled) ? "undefined" : "an undefined object"); + case T_UNSPECIFIED: return((not_articled) ? "#" : "the unspecified object"); + case T_UNUSED: return((not_articled) ? "#" : "the unused object"); + case T_VECTOR: return((not_articled) ? "vector" : "a vector"); + } + return(NULL); +} + +s7_pointer find_let(s7_scheme *sc, s7_pointer obj) +{ + if ((S7_DEBUGGING) && (is_let(obj))) {fprintf(stderr, "let passed to find_let: %s\n", display(obj)); if (sc->stop_at_error) abort();} + if (has_closure_let(obj)) return(closure_let(obj)); /* some of these are immutable -- they hold the parameter names */ + switch (type(obj)) + { + case T_C_OBJECT: + if (is_let(c_object_let(obj))) return(c_object_let(obj)); + return(sc->rootlet); + case T_C_POINTER: + if (is_let(c_pointer_info(obj))) return(c_pointer_info(obj)); + return(sc->rootlet); + case T_C_MACRO: case T_C_FUNCTION_STAR: case T_C_FUNCTION: case T_C_RST_NO_REQ_FUNCTION: + return(c_function_let(obj)); + } + return(sc->nil); } -s7_pointer -s7_function_let (s7_scheme* sc, s7_pointer obj) { - return (c_function_let (obj)); -} +s7_pointer s7_function_let(s7_scheme *sc, s7_pointer obj) {return(c_function_let(obj));} -static inline s7_pointer lookup_slot_from (s7_pointer symbol, s7_pointer let); +static inline s7_pointer lookup_slot_from(s7_pointer symbol, s7_pointer let); -static s7_pointer -find_method (s7_scheme* sc, s7_pointer let, s7_pointer symbol) { +s7_pointer find_method(s7_scheme *sc, s7_pointer let, s7_pointer symbol) +{ s7_pointer slot; - if (is_global (symbol)) /* this means the symbol has never been bound 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) { - if (!is_let (let)) let= find_let (sc, let); - return (find_method (sc, let, symbol)); -} - -s7_pointer -s7i_find_method_with_let (s7_scheme* sc, s7_pointer obj, s7_pointer method) { - return (find_method_with_let (sc, obj, method)); -} - -bool -s7i_has_active_methods (s7_scheme* sc, s7_pointer obj) { - return (has_active_methods (sc, obj)); -} - -static s7_pointer -find_method_with_c_object (s7_scheme* sc, s7_pointer c_obj, s7_pointer symbol) { - s7_pointer let= c_object_let (c_obj); - return (find_method (sc, (is_let (let)) ? let : sc->rootlet, symbol)); -} - -static const char* -type_name (s7_scheme* sc, s7_pointer arg, article_t article) { - switch (type_unchecked (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= 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= type_name_from_type (type_unchecked (arg), article); - if (str) return (str); - } - } - return ("messed up object"); + if (is_global(symbol)) /* this means the symbol has never been bound 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 -object_type_name (s7_scheme* sc, - s7_pointer obj) /* used only by the error handlers */ +static s7_pointer find_method_with_let(s7_scheme *sc, s7_pointer let, s7_pointer symbol) { - uint8_t typ; - if (has_active_methods (sc, obj)) { - s7_pointer func= find_method_with_let (sc, obj, sc->class_name_symbol); - if (func != sc->undefined) - return (s7_apply_function (sc, func, set_plist_1 (sc, obj))); - if (is_symbol (func)) return (symbol_name_cell (func)); - } - typ= type (obj); - if (typ < NUM_TYPES) { - if (typ == T_C_OBJECT) return (c_object_scheme_name (sc, obj)); - return (sc->type_names[typ]); - } - return (wrap_string (sc, "unknown type!", 13)); + if (!is_let(let)) let = find_let(sc, let); + return(find_method(sc, let, symbol)); } -static s7_pointer -type_name_string (s7_scheme* sc, s7_pointer arg) { - if (type (arg) < NUM_TYPES) { - s7_pointer p= sc->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))); -} - -void -sole_arg_wrong_type_error_nr (s7_scheme* sc, s7_pointer caller, s7_pointer arg, - s7_pointer typ) { - set_wlist_4 (cdr (sc->sole_arg_wrong_type_info), caller, arg, - object_type_name (sc, arg), typ); - error_nr (sc, sc->wrong_type_arg_symbol, sc->sole_arg_wrong_type_info); -} - -static /* Inline */ no_return void -wrong_type_error_nr (s7_scheme* sc, s7_pointer caller, s7_int arg_num, - s7_pointer arg, s7_pointer typ) { - 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, (is_small_int (arg_num)) ? small_int (arg_num) - : wrap_integer (sc, arg_num)); - p= cdr (p); - set_car (p, arg); - p= cdr (p); - set_car (p, object_type_name (sc, arg)); - p= cdr (p); - set_car (p, typ); - error_nr (sc, sc->wrong_type_arg_symbol, sc->wrong_type_arg_info); -} - -void -s7i_wrong_type_error_nr (s7_scheme* sc, s7_pointer caller, s7_int arg_num, - s7_pointer arg, s7_pointer typ) { - wrong_type_error_nr (sc, caller, arg_num, arg, typ); -} - -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) - wrong_type_error_nr (sc, wrap_string (sc, caller, safe_strlen (caller)), - arg_n, arg, - wrap_string (sc, descr, safe_strlen (descr))); - sole_arg_wrong_type_error_nr ( - sc, wrap_string (sc, caller, safe_strlen (caller)), arg, - wrap_string (sc, descr, safe_strlen (descr))); - return (sc->wrong_type_arg_symbol); -} - -s7_pointer -s7_wrong_type_error (s7_scheme* sc, s7_pointer caller, s7_int arg_n, - s7_pointer arg, s7_pointer descr) { - if (arg_n > 0) wrong_type_error_nr (sc, caller, arg_n, arg, descr); - sole_arg_wrong_type_error_nr (sc, caller, arg, descr); - return (sc->wrong_type_arg_symbol); /* never happens */ -} - -static no_return void -sole_arg_out_of_range_error_nr (s7_scheme* sc, s7_pointer caller, - s7_pointer arg, s7_pointer descr) { - set_wlist_3 (cdr (sc->sole_arg_out_of_range_info), caller, arg, descr); - error_nr (sc, sc->out_of_range_symbol, sc->sole_arg_out_of_range_info); -} - -static no_return void -out_of_range_error_nr (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); - error_nr (sc, sc->out_of_range_symbol, sc->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) { - set_wlist_4 (cdr (sc->out_of_range_info), - wrap_string (sc, caller, safe_strlen (caller)), - wrap_integer (sc, arg_n), arg, - wrap_string (sc, descr, safe_strlen (descr))); - error_nr (sc, sc->out_of_range_symbol, sc->out_of_range_info); - } - set_wlist_3 (cdr (sc->sole_arg_out_of_range_info), - wrap_string (sc, caller, safe_strlen (caller)), arg, - wrap_string (sc, descr, safe_strlen (descr))); - error_nr (sc, sc->out_of_range_symbol, sc->sole_arg_out_of_range_info); - return (sc->out_of_range_symbol); +s7_pointer s7i_find_method_with_let(s7_scheme *sc, s7_pointer obj, s7_pointer method) +{ + return(find_method_with_let(sc, obj, method)); } -static no_return void -wrong_number_of_arguments_error_nr (s7_scheme* sc, const char* errmsg, - s7_int len, s7_pointer args) { - error_nr (sc, sc->wrong_number_of_args_symbol, - set_elist_2 (sc, wrap_string (sc, errmsg, len), args)); +bool s7i_has_active_methods(s7_scheme *sc, s7_pointer obj) +{ + return(has_active_methods(sc, obj)); } -s7_pointer -s7_wrong_number_of_args_error (s7_scheme* sc, const char* caller, - s7_pointer args) { - error_nr (sc, sc->wrong_number_of_args_symbol, - set_elist_2 (sc, wrap_string (sc, caller, safe_strlen (caller)), - args)); /* "caller" includes the format directives */ - return (sc->wrong_number_of_args_symbol); +static s7_pointer find_method_with_c_object(s7_scheme *sc, s7_pointer c_obj, s7_pointer symbol) +{ + s7_pointer let = c_object_let(c_obj); + return(find_method(sc, (is_let(let)) ? let : sc->rootlet, symbol)); } -void -syntax_error_nr (s7_scheme* sc, const char* errmsg, s7_int len, - s7_pointer obj) { - error_nr (sc, sc->syntax_error_symbol, - set_elist_2 (sc, wrap_string (sc, errmsg, len), obj)); +const char *type_name(s7_scheme *sc, s7_pointer arg, article_t article) +{ + switch (type_unchecked(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 = 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 = type_name_from_type(type_unchecked(arg), article); + if (str) return(str); + }} + return("messed up object"); } -static no_return void -syntax_error_with_caller_nr (s7_scheme* sc, const char* errmsg, s7_int len, - s7_pointer caller, s7_pointer obj) { - error_nr (sc, sc->syntax_error_symbol, - set_elist_3 (sc, wrap_string (sc, errmsg, len), caller, obj)); +s7_pointer object_type_name(s7_scheme *sc, s7_pointer obj) /* used only by the error handlers */ +{ + uint8_t typ; + if (has_active_methods(sc, obj)) + { + s7_pointer func = find_method_with_let(sc, obj, sc->class_name_symbol); + if (func != sc->undefined) + return(s7_apply_function(sc, func, set_plist_1(sc, obj))); + if (is_symbol(func)) + return(symbol_name_cell(func)); + } + typ = type(obj); + if (typ < NUM_TYPES) + { + if (typ == T_C_OBJECT) return(c_object_scheme_name(sc, obj)); + return(sc->type_names[typ]); + } + return(wrap_string(sc, "unknown type!", 13)); } -static no_return void -syntax_error_with_caller2_nr (s7_scheme* sc, const char* errmsg, s7_int len, - s7_pointer caller, s7_pointer name, - s7_pointer obj) { - error_nr (sc, sc->syntax_error_symbol, - set_elist_4 (sc, wrap_string (sc, errmsg, len), caller, name, obj)); +static s7_pointer type_name_string(s7_scheme *sc, s7_pointer arg) +{ + if (type(arg) < NUM_TYPES) + { + s7_pointer p = sc->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 make_symbol (s7_scheme* sc, const char* name, - s7_int len); /* calls new_symbol */ -#define make_symbol_with_strlen(Sc, Name) \ - make_symbol (Sc, Name, safe_strlen (Name)) -static s7_pointer -missing_method_class_name (s7_scheme* sc, s7_pointer obj) { - s7_pointer class_name= find_method (sc, obj, sc->class_name_symbol); - if (is_symbol (class_name)) return (class_name); - return (sc->is_openlet_symbol); +void sole_arg_wrong_type_error_nr(s7_scheme *sc, s7_pointer caller, s7_pointer arg, s7_pointer typ) +{ + set_wlist_4(cdr(sc->sole_arg_wrong_type_info), caller, arg, object_type_name(sc, arg), typ); + error_nr(sc, sc->wrong_type_arg_symbol, sc->sole_arg_wrong_type_info); } -static no_return void -missing_method_error_nr (s7_scheme* sc, s7_pointer method, s7_pointer obj) { - error_nr (sc, sc->missing_method_symbol, - set_elist_4 ( - sc, wrap_string (sc, "~S method is not defined in ~A ~A", 33), - method, - (is_c_object (obj)) - ? c_object_scheme_name (sc, obj) - : (((is_let (obj)) && (is_openlet (obj))) - ? missing_method_class_name (sc, obj) - : s7_make_string_wrapper ( - sc, type_name (sc, obj, no_article))), - object_to_string_truncated (sc, obj))); +/* Inline */ no_return void wrong_type_error_nr(s7_scheme *sc, s7_pointer caller, s7_int arg_num, s7_pointer arg, s7_pointer typ) +{ + 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, (is_small_int(arg_num)) ? small_int(arg_num) : wrap_integer(sc, arg_num)); p = cdr(p); + set_car(p, arg); p = cdr(p); + set_car(p, object_type_name(sc, arg)); p = cdr(p); + set_car(p, typ); + error_nr(sc, sc->wrong_type_arg_symbol, sc->wrong_type_arg_info); } -void -immutable_object_error_nr (s7_scheme* sc, s7_pointer info) { - error_nr (sc, sc->immutable_error_symbol, info); +void s7i_wrong_type_error_nr(s7_scheme *sc, s7_pointer caller, s7_int arg_num, s7_pointer arg, s7_pointer typ) +{ + wrong_type_error_nr(sc, caller, arg_num, arg, typ); } -/* -------- method handlers -------- */ -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 if_method_exists_return_value(Sc, Obj, Method, Args) \ - { \ - s7_pointer _Func_; \ - if ((has_active_methods (Sc, Obj)) && \ - ((_Func_= find_method_with_let (Sc, Obj, Method)) != Sc->undefined)) \ - return (s7_apply_function (Sc, _Func_, Args)); \ - } - -#define if_let_method_exists_return_value(Sc, Let, Method, Args) \ - { \ - s7_pointer _Func_; \ - if ((has_active_methods (Sc, T_Let (Let))) && \ - ((_Func_= find_method (Sc, Let, Method)) != Sc->undefined)) \ - return (s7_apply_function (Sc, _Func_, Args)); \ - } - -#define if_c_object_method_exists_return_value(Sc, C_Obj, Method, Args) \ - { \ - s7_pointer _Func_; \ - if ((has_active_methods (Sc, T_Obj (C_Obj))) && \ - ((_Func_= find_method_with_c_object (Sc, C_Obj, Method)) != \ - Sc->undefined)) \ - return (s7_apply_function (Sc, _Func_, Args)); \ - } - -static s7_pointer -apply_boolean_method (s7_scheme* sc, s7_pointer obj, s7_pointer method) { - s7_pointer func= find_method_with_let (sc, obj, method); - if (func == sc->undefined) return (sc->F); - return (s7_apply_function ( - sc, func, set_mlist_1 (sc, obj))); /* plist here and below will probably - not work (_pp case known bad) */ +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) + wrong_type_error_nr(sc, wrap_string(sc, caller, safe_strlen(caller)), arg_n, arg, wrap_string(sc, descr, safe_strlen(descr))); + sole_arg_wrong_type_error_nr(sc, wrap_string(sc, caller, safe_strlen(caller)), arg, wrap_string(sc, descr, safe_strlen(descr))); + return(sc->wrong_type_arg_symbol); } -s7_pointer -s7i_apply_boolean_method (s7_scheme* sc, s7_pointer obj, s7_pointer method) { - return apply_boolean_method (sc, obj, method); +s7_pointer s7_wrong_type_error(s7_scheme *sc, s7_pointer caller, s7_int arg_n, s7_pointer arg, s7_pointer descr) +{ + if (arg_n > 0) wrong_type_error_nr(sc, caller, arg_n, arg, descr); + sole_arg_wrong_type_error_nr(sc, caller, arg, descr); + return(sc->wrong_type_arg_symbol); /* never happens */ } -/* this is a macro mainly to simplify the Checker handling */ -#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 no_return void sole_arg_out_of_range_error_nr(s7_scheme *sc, s7_pointer caller, s7_pointer arg, s7_pointer descr) +{ + set_wlist_3(cdr(sc->sole_arg_out_of_range_info), caller, arg, descr); + error_nr(sc, sc->out_of_range_symbol, sc->sole_arg_out_of_range_info); +} -static s7_pointer apply_method_closure (s7_scheme* sc, s7_pointer func, - s7_pointer args); +no_return void out_of_range_error_nr(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); + error_nr(sc, sc->out_of_range_symbol, sc->out_of_range_info); +} -static s7_pointer -find_and_apply_method (s7_scheme* sc, s7_pointer obj, s7_pointer sym, - s7_pointer args) /* slower if inline */ +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 func= find_method_with_let ( - sc, obj, - sym); /* perhaps find_and_apply_c_object_method for g_c_object_let */ - /* fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display(args)); */ - if (is_closure (func)) return (apply_method_closure (sc, func, args)); - if (func == sc->undefined) missing_method_error_nr (sc, sym, obj); - if ((S7_DEBUGGING) && (func == global_value (sym))) { - fprintf (stderr, "loop in %s?\n", __func__); - if (sc->stop_at_error) abort (); - } - return (s7_apply_function (sc, func, args)); -} - -static s7_pointer -method_or_bust (s7_scheme* sc, s7_pointer obj, s7_pointer method, - s7_pointer args, s7_pointer typ, int32_t num) { - if (!has_active_methods (sc, obj)) - wrong_type_error_nr (sc, method, num, obj, typ); - return (find_and_apply_method (sc, obj, method, args)); -} - -s7_pointer -s7i_method_or_bust (s7_scheme* sc, s7_pointer obj, const char* method_name, - s7_pointer args, const char* type_name, s7_int arg_pos) { - return (method_or_bust (sc, obj, s7_make_symbol (sc, method_name), args, - wrap_string (sc, type_name, safe_strlen (type_name)), - (int32_t) arg_pos)); -} - -bool -s7i_method_or_bust_bool (s7_scheme* sc, s7_pointer obj, const char* method_name, - s7_pointer args, const char* type_name, - s7_int arg_pos) { - return (s7i_method_or_bust (sc, obj, method_name, args, type_name, arg_pos) != - sc->F); -} - -static s7_pointer -mutable_method_or_bust (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)); - if (sc->type_names[type (obj)] != typ) - wrong_type_error_nr (sc, method, num, obj, typ); - if (!is_immutable (obj)) wrong_type_error_nr (sc, method, num, obj, typ); - immutable_object_error_nr ( - sc, set_elist_3 (sc, immutable_error_string, method, obj)); - return (NULL); -} - -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, - s7_pointer typ, int32_t num) { - return (mutable_method_or_bust (sc, obj, method, set_qlist_3 (sc, x1, x2, x3), - typ, num)); /* was list_3, plist_3 not safe */ -} - -s7_pointer -method_or_bust_p (s7_scheme* sc, s7_pointer obj, s7_pointer method, - s7_pointer typ) { - if (!has_active_methods (sc, obj)) - sole_arg_wrong_type_error_nr (sc, method, obj, typ); - return (find_and_apply_method (sc, obj, method, set_mlist_1 (sc, obj))); -} - -static s7_pointer -method_or_bust_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)) - wrong_type_error_nr (sc, method, num, obj, typ); - return (find_and_apply_method (sc, obj, method, set_mlist_2 (sc, x1, x2))); -} - -static s7_pointer -methods_or_bust_pp (s7_scheme* sc, s7_pointer obj, s7_pointer method1, - s7_pointer method2, s7_pointer x1, s7_pointer x2, - s7_pointer typ, - int32_t num) { /* this is for the memq/memv and assq/assv - equivalence in r7rs */ - s7_pointer func; - if (!has_active_methods (sc, obj)) - wrong_type_error_nr (sc, method1, num, obj, typ); - func= find_method_with_let (sc, obj, method1); - if (func == sc->undefined) func= find_method_with_let (sc, obj, method2); - if (func == sc->undefined) missing_method_error_nr (sc, method1, obj); - return (s7_apply_function (sc, func, set_mlist_2 (sc, x1, x2))); -} - -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, s7_pointer typ, - int32_t num) { - if (!has_active_methods (sc, obj)) - wrong_type_error_nr (sc, method, num, obj, typ); - return (find_and_apply_method ( - sc, obj, method, - set_qlist_3 (sc, x1, x2, x3))); /* was list_3, plist not safe */ -} - -static s7_pointer -method_or_bust_with_type_and_loc_pp (s7_scheme* sc, s7_pointer obj, - s7_pointer method, s7_pointer x1, - s7_pointer x2, s7_pointer typ, - int32_t num) { - int32_t loc = sc->error_argnum + num; - sc->error_argnum= 0; - if (!has_active_methods (sc, obj)) - wrong_type_error_nr (sc, method, loc, obj, typ); - return (find_and_apply_method (sc, obj, method, set_mlist_2 (sc, x1, x2))); -} - -static s7_pointer -sole_arg_method_or_bust (s7_scheme* sc, s7_pointer obj, s7_pointer method, - s7_pointer args, s7_pointer typ) { - if (!has_active_methods (sc, obj)) - sole_arg_wrong_type_error_nr (sc, method, obj, typ); - return (find_and_apply_method (sc, obj, method, args)); -} - -s7_pointer -s7i_sole_arg_method_or_bust (s7_scheme* sc, s7_pointer obj, - const char* method_name, s7_pointer args, - const char* type_name) { - return (sole_arg_method_or_bust ( - sc, obj, s7_make_symbol (sc, method_name), args, - wrap_string (sc, type_name, safe_strlen (type_name)))); -} - -bool -s7i_sole_arg_method_or_bust_bool (s7_scheme* sc, s7_pointer obj, - const char* method_name, s7_pointer args, - const char* type_name) { - return s7i_sole_arg_method_or_bust (sc, obj, method_name, args, type_name) != - sc->F; -} - -s7_double -s7i_default_rationalize_error (s7_scheme* sc) { - return (sc->default_rationalize_error); -} - -/* -------------------------------- constants -------------------------------- - */ -/* #f and #t */ -s7_pointer -s7_f (s7_scheme* sc) { - return (sc->F); + if (arg_n > 0) + { + set_wlist_4(cdr(sc->out_of_range_info), wrap_string(sc, caller, safe_strlen(caller)), + wrap_integer(sc, arg_n), arg, wrap_string(sc, descr, safe_strlen(descr))); + error_nr(sc, sc->out_of_range_symbol, sc->out_of_range_info); + } + set_wlist_3(cdr(sc->sole_arg_out_of_range_info), wrap_string(sc, caller, safe_strlen(caller)), + arg, wrap_string(sc, descr, safe_strlen(descr))); + error_nr(sc, sc->out_of_range_symbol, sc->sole_arg_out_of_range_info); + return(sc->out_of_range_symbol); } -s7_pointer -s7_t (s7_scheme* sc) { - return (sc->T); + +static no_return void wrong_number_of_arguments_error_nr(s7_scheme *sc, const char *errmsg, s7_int len, s7_pointer args) +{ + error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_2(sc, wrap_string(sc, errmsg, len), args)); } -/* () */ -s7_pointer -s7_nil (s7_scheme* sc) { - return (sc->nil); -} /* should this be "s7_null" ? */ -bool -s7_is_null (s7_scheme* sc, s7_pointer p) { - return (is_null (p)); -} -bool -is_null_b_p (s7_pointer p) { - return (type (p) == T_NIL); -} /* faster than b_7p because opt_b_p is faster */ +s7_pointer s7_wrong_number_of_args_error(s7_scheme *sc, const char *caller, s7_pointer args) +{ + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_2(sc, wrap_string(sc, caller, safe_strlen(caller)), args)); /* "caller" includes the format directives */ + return(sc->wrong_number_of_args_symbol); +} -#define H_is_null "(null? obj) returns #t if obj is the empty list" -#define Q_is_null sc->pl_bt -/* g_is_null is now defined in s7_liii_list.c */ -/* # and # */ -s7_pointer -s7_undefined (s7_scheme* sc) { - return (sc->undefined); -} -s7_pointer -s7_unspecified (s7_scheme* sc) { - return (sc->unspecified); +void syntax_error_nr(s7_scheme *sc, const char *errmsg, s7_int len, s7_pointer obj) +{ + error_nr(sc, sc->syntax_error_symbol, set_elist_2(sc, wrap_string(sc, errmsg, len), obj)); } -bool -s7_is_unspecified (s7_scheme* sc, s7_pointer val) { - return (is_unspecified (val)); +static no_return void syntax_error_with_caller_nr(s7_scheme *sc, const char *errmsg, s7_int len, s7_pointer caller, s7_pointer obj) +{ + error_nr(sc, sc->syntax_error_symbol, set_elist_3(sc, wrap_string(sc, errmsg, len), caller, obj)); } -/* g_is_undefined is now defined in s7_scheme_predicate.c */ -#define H_is_undefined \ - "(undefined? val) returns #t if val is # or some other #... value that s7 does not recognize; (undefined? #asdf): #t.\ -This is not the same as (not (defined? val)) which refers to whether a symbol has a binding: (undefined? 'asdf): #f, but (not (defined? 'asdf)): #t" -#define Q_is_undefined sc->pl_bt +static no_return void syntax_error_with_caller2_nr(s7_scheme *sc, const char *errmsg, s7_int len, s7_pointer caller, s7_pointer name, s7_pointer obj) +{ + error_nr(sc, sc->syntax_error_symbol, set_elist_4(sc, wrap_string(sc, errmsg, len), caller, name, obj)); +} -/* g_is_unspecified is now defined in s7_scheme_predicate.c */ -#define H_is_unspecified \ - "(unspecified? val) returns #t if val is #" -#define Q_is_unspecified sc->pl_bt +s7_pointer make_symbol(s7_scheme *sc, const char *name, s7_int len); /* calls new_symbol */ +#define make_symbol_with_strlen(Sc, Name) make_symbol(Sc, Name, safe_strlen(Name)) -/* -------------------------------- eof-object? -------------------------------- - */ -s7_pointer eof_object= - NULL; /* # is an entry in the chars array, so it's not a part of sc */ +static s7_pointer missing_method_class_name(s7_scheme *sc, s7_pointer obj) +{ + s7_pointer class_name = find_method(sc, obj, sc->class_name_symbol); + if (is_symbol(class_name)) return(class_name); + return(sc->is_openlet_symbol); +} -s7_pointer -s7_eof_object (s7_scheme* sc) { - return (eof_object); +static no_return void missing_method_error_nr(s7_scheme *sc, s7_pointer method, s7_pointer obj) +{ + error_nr(sc, sc->missing_method_symbol, + set_elist_4(sc, wrap_string(sc, "~S method is not defined in ~A ~A", 33), method, + (is_c_object(obj)) ? c_object_scheme_name(sc, obj) : + (((is_let(obj)) && (is_openlet(obj))) ? missing_method_class_name(sc, obj) : + s7_make_string_wrapper(sc, type_name(sc, obj, no_article))), + object_to_string_truncated(sc, obj))); } -/* g_is_eof_object is now defined in s7_scheme_predicate.c */ -#define H_is_eof_object \ - "(eof-object? val) returns #t if val is the end-of-file object, #. " \ - "It is the same as (eq? val #)" -#define Q_is_eof_object sc->pl_bt +void immutable_object_error_nr(s7_scheme *sc, s7_pointer info) {error_nr(sc, sc->immutable_error_symbol, info);} -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); +/* -------- method handlers -------- */ +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); } -/* g_not is now defined in s7_scheme_predicate.c */ -#define H_not "(not obj) returns #t if obj is #f, otherwise #f: (not ()) -> #f" -#define Q_not sc->pl_bt +/* 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 if_method_exists_return_value(Sc, Obj, Method, Args) \ + { \ + s7_pointer _Func_; \ + if ((has_active_methods(Sc, Obj)) && \ + ((_Func_ = find_method_with_let(Sc, Obj, Method)) != Sc->undefined)) \ + return(s7_apply_function(Sc, _Func_, Args)); \ + } -/* -------------------------------- boolean? -------------------------------- */ -bool -s7_boolean (s7_scheme* sc, s7_pointer obj) { - return (obj != sc->F); -} -s7_pointer -s7_make_boolean (s7_scheme* sc, bool obj) { - return (make_boolean (sc, obj)); -} +#define if_let_method_exists_return_value(Sc, Let, Method, Args) \ + { \ + s7_pointer _Func_; \ + if ((has_active_methods(Sc, T_Let(Let))) && \ + ((_Func_ = find_method(Sc, Let, Method)) != Sc->undefined)) \ + return(s7_apply_function(Sc, _Func_, Args)); \ + } + +#define if_c_object_method_exists_return_value(Sc, C_Obj, Method, Args) \ + { \ + s7_pointer _Func_; \ + if ((has_active_methods(Sc, T_Obj(C_Obj))) && \ + ((_Func_ = find_method_with_c_object(Sc, C_Obj, Method)) != Sc->undefined)) \ + return(s7_apply_function(Sc, _Func_, Args)); \ + } -bool -s7_is_boolean (s7_pointer x) { - return (type (x) == T_BOOLEAN); +static s7_pointer apply_boolean_method(s7_scheme *sc, s7_pointer obj, s7_pointer method) +{ + s7_pointer func = find_method_with_let(sc, obj, method); + if (func == sc->undefined) return(sc->F); + return(s7_apply_function(sc, func, set_mlist_1(sc, obj))); /* plist here and below will probably not work (_pp case known bad) */ } -/* g_is_boolean is now defined in s7_scheme_predicate.c */ -#define H_is_boolean \ - "(boolean? obj) returns #t if obj is #f or #t: (boolean? ()) -> #f" -#define Q_is_boolean sc->pl_bt +s7_pointer s7i_apply_boolean_method(s7_scheme *sc, s7_pointer obj, s7_pointer method) +{ + return apply_boolean_method(sc, obj, method); +} -/* -------------------------------- constant? -------------------------------- - */ -static inline bool -is_constant_symbol (s7_scheme* sc, - s7_pointer sym) /* inline: 7 in cb, 5 in tgen */ -{ - if (is_immutable_symbol (sym)) /* for keywords */ - return (true); - if (is_possibly_constant (sym)) { - s7_pointer slot= s7_slot (sc, sym); - return ((is_slot (slot)) && (is_immutable_slot (slot))); +/* this is a macro mainly to simplify the Checker handling */ +#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)); \ } - return (false); -} -#define is_constant(sc, p) \ - ((type (p) != T_SYMBOL) || (is_constant_symbol (sc, p))) +static s7_pointer apply_method_closure(s7_scheme *sc, s7_pointer func, s7_pointer args); -/* g_is_constant is now defined in s7_scheme_predicate.c */ -#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 +static s7_pointer find_and_apply_method(s7_scheme *sc, s7_pointer obj, s7_pointer sym, s7_pointer args) /* slower if inline */ +{ + s7_pointer func = find_method_with_let(sc, obj, sym); /* perhaps find_and_apply_c_object_method for g_c_object_let */ + /* fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display(args)); */ + if (is_closure(func)) return(apply_method_closure(sc, func, args)); + if (func == sc->undefined) missing_method_error_nr(sc, sym, obj); + if ((S7_DEBUGGING) && (func == global_value(sym))) {fprintf(stderr, "loop in %s?\n", __func__); if (sc->stop_at_error) abort();} + return(s7_apply_function(sc, func, args)); +} -static bool -is_constant_b_7p (s7_scheme* sc, s7_pointer p) { - return (is_constant (sc, p)); +s7_pointer method_or_bust(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer args, s7_pointer typ, int32_t num) +{ + if (!has_active_methods(sc, obj)) wrong_type_error_nr(sc, method, num, obj, typ); + return(find_and_apply_method(sc, obj, method, args)); } -static s7_pointer -is_constant_p_p (s7_scheme* sc, s7_pointer p) { - return (make_boolean (sc, is_constant (sc, p))); + +s7_pointer s7i_method_or_bust(s7_scheme *sc, s7_pointer obj, const char *method_name, + s7_pointer args, const char *type_name, s7_int arg_pos) +{ + return(method_or_bust(sc, obj, + s7_make_symbol(sc, method_name), + args, + wrap_string(sc, type_name, safe_strlen(type_name)), + (int32_t)arg_pos)); } -/* -------------------------------- immutable? -------------------------------- - */ +bool s7i_method_or_bust_bool(s7_scheme *sc, s7_pointer obj, const char *method_name, + s7_pointer args, const char *type_name, s7_int arg_pos) +{ + return(s7i_method_or_bust(sc, obj, method_name, args, type_name, arg_pos) != sc->F); +} -static no_return void -find_let_error_nr (s7_scheme* sc, s7_pointer caller, s7_pointer let, - s7_pointer new_let, s7_int arg_num, s7_pointer args) { - if (new_let == sc->rootlet) { - if ((arg_num > 1) || (is_pair (cdr (args)))) - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_5 (sc, - wrap_string (sc, - "(~A~{~^ ~$~}) ~:D argument is ~A, " - "but it does not have its own let", - 66), - caller, args, wrap_integer (sc, arg_num), - object_type_name (sc, let))); - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_4 (sc, - wrap_string (sc, - "(~A~{~^ ~$~}) argument is ~A, but it " - "does not have its own let", - 62), - caller, args, object_type_name (sc, let))); - } - wrong_type_error_nr ( - sc, caller, arg_num, s7_list_ref (sc, args, arg_num - 1), - wrap_string (sc, "a let or an object that has its own let", 39)); -} - -bool -s7_is_immutable (s7_pointer p) { - return (is_immutable (p)); -} -#define has_let_signature(sc) \ - s7_make_signature (sc, 5, sc->is_let_symbol, sc->is_c_object_symbol, \ - sc->is_c_pointer_symbol, sc->is_procedure_symbol, \ - sc->is_macro_symbol) - -static s7_pointer -g_is_immutable (s7_scheme* sc, s7_pointer args) { -#define H_is_immutable \ - "(immutable? obj (env (curlet))) returns #t if obj (or obj in the " \ - "environment env) is immutable" -#define Q_is_immutable \ - s7_make_signature (sc, 3, sc->is_boolean_symbol, sc->T, \ - has_let_signature (sc)) - const s7_pointer obj= car (args); - if (is_symbol (obj)) { - s7_pointer slot; - if (is_keyword (obj)) return (sc->T); - if (is_pair (cdr (args))) { - s7_pointer let= cadr (args); - if (!is_let (let)) { - s7_pointer new_let= find_let (sc, let); - if ((!is_let (new_let)) || (new_let == sc->rootlet)) - find_let_error_nr (sc, sc->is_immutable_symbol, let, new_let, 2, - args); - let= new_let; - } - if (let == sc->rootlet) slot= global_slot (obj); - else - slot= lookup_slot_from ((is_keyword (obj)) ? keyword_symbol (obj) : obj, - let); +static s7_pointer mutable_method_or_bust(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)); + if (sc->type_names[type(obj)] != typ) wrong_type_error_nr(sc, method, num, obj, typ); + if (!is_immutable(obj)) wrong_type_error_nr(sc, method, num, obj, typ); + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, method, obj)); + return(NULL); +} + +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, s7_pointer typ, int32_t num) +{ + return(mutable_method_or_bust(sc, obj, method, set_qlist_3(sc, x1, x2, x3), typ, num)); /* was list_3, plist_3 not safe */ +} + +s7_pointer method_or_bust_p(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer typ) +{ + if (!has_active_methods(sc, obj)) sole_arg_wrong_type_error_nr(sc, method, obj, typ); + return(find_and_apply_method(sc, obj, method, set_mlist_1(sc, obj))); +} + +s7_pointer method_or_bust_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)) wrong_type_error_nr(sc, method, num, obj, typ); + return(find_and_apply_method(sc, obj, method, set_mlist_2(sc, x1, x2))); +} + +static s7_pointer methods_or_bust_pp(s7_scheme *sc, s7_pointer obj, s7_pointer method1, s7_pointer method2, s7_pointer x1, s7_pointer x2, s7_pointer typ, int32_t num) +{ /* this is for the memq/memv and assq/assv equivalence in r7rs */ + s7_pointer func; + if (!has_active_methods(sc, obj)) wrong_type_error_nr(sc, method1, num, obj, typ); + func = find_method_with_let(sc, obj, method1); + if (func == sc->undefined) func = find_method_with_let(sc, obj, method2); + if (func == sc->undefined) missing_method_error_nr(sc, method1, obj); + return(s7_apply_function(sc, func, set_mlist_2(sc, x1, x2))); +} + +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, s7_pointer typ, int32_t num) +{ + if (!has_active_methods(sc, obj)) wrong_type_error_nr(sc, method, num, obj, typ); + return(find_and_apply_method(sc, obj, method, set_qlist_3(sc, x1, x2, x3))); /* was list_3, plist not safe */ +} + +static s7_pointer method_or_bust_with_type_and_loc_pp(s7_scheme *sc, s7_pointer obj, s7_pointer method, + s7_pointer x1, s7_pointer x2, s7_pointer typ, int32_t num) +{ + int32_t loc = sc->error_argnum + num; + sc->error_argnum = 0; + if (!has_active_methods(sc, obj)) wrong_type_error_nr(sc, method, loc, obj, typ); + return(find_and_apply_method(sc, obj, method, set_mlist_2(sc, x1, x2))); +} + +static s7_pointer sole_arg_method_or_bust(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer args, s7_pointer typ) +{ + if (!has_active_methods(sc, obj)) sole_arg_wrong_type_error_nr(sc, method, obj, typ); + return(find_and_apply_method(sc, obj, method, args)); +} + +s7_pointer s7i_sole_arg_method_or_bust(s7_scheme *sc, s7_pointer obj, const char *method_name, s7_pointer args, const char *type_name) +{ + return(sole_arg_method_or_bust(sc, obj, s7_make_symbol(sc, method_name), args, wrap_string(sc, type_name, safe_strlen(type_name)))); +} + +bool s7i_sole_arg_method_or_bust_bool(s7_scheme *sc, s7_pointer obj, const char *method_name, s7_pointer args, const char *type_name) +{ + return s7i_sole_arg_method_or_bust(sc, obj, method_name, args, type_name) != sc->F; +} + +s7_double s7i_default_rationalize_error(s7_scheme *sc) {return(sc->default_rationalize_error);} + +/* -------------------------------- 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);} /* should this be "s7_null" ? */ +bool s7_is_null(s7_scheme *sc, s7_pointer p) {return(is_null(p));} +bool is_null_b_p(s7_pointer p) {return(type(p) == T_NIL);} /* faster than b_7p because opt_b_p is faster */ + +#define H_is_null "(null? obj) returns #t if obj is the empty list" +#define Q_is_null sc->pl_bt +/* g_is_null is now defined in s7_liii_list.c */ + + +/* # 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));} + +/* g_is_undefined is now defined in s7_scheme_predicate.c */ + #define H_is_undefined "(undefined? val) returns #t if val is # or some other #... value that s7 does not recognize; (undefined? #asdf): #t.\ +This is not the same as (not (defined? val)) which refers to whether a symbol has a binding: (undefined? 'asdf): #f, but (not (defined? 'asdf)): #t" + #define Q_is_undefined sc->pl_bt + +/* g_is_unspecified is now defined in s7_scheme_predicate.c */ +#define H_is_unspecified "(unspecified? val) returns #t if val is #" +#define Q_is_unspecified sc->pl_bt + + +/* -------------------------------- 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);} + +/* g_is_eof_object is now defined in s7_scheme_predicate.c */ + #define H_is_eof_object "(eof-object? val) returns #t if val is the end-of-file object, #. It is the same as (eq? val #)" + #define Q_is_eof_object sc->pl_bt + +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);} + +/* g_not is now defined in s7_scheme_predicate.c */ + #define H_not "(not obj) returns #t if obj is #f, otherwise #f: (not ()) -> #f" + #define Q_not sc->pl_bt + + +/* -------------------------------- boolean? -------------------------------- */ +bool s7_boolean(s7_scheme *sc, s7_pointer obj) {return(obj != sc->F);} +s7_pointer s7_make_boolean(s7_scheme *sc, bool obj) {return(make_boolean(sc, obj));} + +bool s7_is_boolean(s7_pointer x) {return(type(x) == T_BOOLEAN);} + +/* g_is_boolean is now defined in s7_scheme_predicate.c */ + #define H_is_boolean "(boolean? obj) returns #t if obj is #f or #t: (boolean? ()) -> #f" + #define Q_is_boolean sc->pl_bt + + +/* -------------------------------- constant? -------------------------------- */ +extern inline bool is_constant_symbol(s7_scheme *sc, s7_pointer sym) /* inline: 7 in cb, 5 in tgen */ +{ + if (is_immutable_symbol(sym)) /* for keywords */ + return(true); + if (is_possibly_constant(sym)) + { + s7_pointer slot = s7_slot(sc, sym); + return((is_slot(slot)) && (is_immutable_slot(slot))); } - else slot= s7_slot (sc, obj); - if (is_slot (slot)) /* might be # */ - return (make_boolean (sc, is_immutable_slot (slot))); - } - else if ((is_pair (cdr (args))) && - (!is_let (cadr (args)))) /* (immutable? 1 2) */ - wrong_type_error_nr (sc, sc->is_immutable_symbol, 2, cadr (args), - a_let_string); - return (make_boolean ( - sc, (is_immutable (obj)) || (t_immutable_p[type (obj)]) || - ((is_any_vector (obj)) && (vector_length (obj) == 0)))); + return(false); } -/* -------------------------------- immutable! -------------------------------- - */ -s7_pointer -s7_set_immutable (s7_scheme* sc, s7_pointer obj) { - if (is_symbol (obj)) /* trying to mimic g_immutable */ - { - s7_pointer slot; - if (is_keyword (obj)) return (obj); - slot= s7_slot (sc, obj); - if (is_slot (slot)) set_immutable_slot (slot); - /* symbol is not set immutable (as below) */ - } - else set_immutable (obj); - return (obj); +#define is_constant(sc, p) ((type(p) != T_SYMBOL) || (is_constant_symbol(sc, p))) + +/* g_is_constant is now defined in s7_scheme_predicate.c */ + #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 + +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? -------------------------------- */ + +no_return void find_let_error_nr(s7_scheme *sc, s7_pointer caller, s7_pointer let, s7_pointer new_let, s7_int arg_num, s7_pointer args) +{ + if (new_let == sc->rootlet) + { + if ((arg_num > 1) || (is_pair(cdr(args)))) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_5(sc, wrap_string(sc, "(~A~{~^ ~$~}) ~:D argument is ~A, but it does not have its own let", 66), + caller, args, wrap_integer(sc, arg_num), object_type_name(sc, let))); + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "(~A~{~^ ~$~}) argument is ~A, but it does not have its own let", 62), + caller, args, object_type_name(sc, let))); + } + wrong_type_error_nr(sc, caller, arg_num, s7_list_ref(sc, args, arg_num - 1), wrap_string(sc, "a let or an object that has its own let", 39)); } -#if (!DISABLE_DEPRECATED) && (S7_DEBUGGING || DISABLE_FILE_OUTPUT || POINTER_32) -s7_pointer -s7_immutable (s7_pointer obj) { - return (s7_set_immutable (cur_sc, obj)); +bool s7_is_immutable(s7_pointer p) {return(is_immutable(p));} +#define has_let_signature(sc) s7_make_signature(sc, 5, sc->is_let_symbol, sc->is_c_object_symbol, sc->is_c_pointer_symbol, sc->is_procedure_symbol, sc->is_macro_symbol) + +static s7_pointer g_is_immutable(s7_scheme *sc, s7_pointer args) +{ + #define H_is_immutable "(immutable? obj (env (curlet))) returns #t if obj (or obj in the environment env) is immutable" + #define Q_is_immutable s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->T, has_let_signature(sc)) + const s7_pointer obj = car(args); + if (is_symbol(obj)) + { + s7_pointer slot; + if (is_keyword(obj)) return(sc->T); + if (is_pair(cdr(args))) + { + s7_pointer let = cadr(args); + if (!is_let(let)) + { + s7_pointer new_let = find_let(sc, let); + if ((!is_let(new_let)) || (new_let == sc->rootlet)) + find_let_error_nr(sc, sc->is_immutable_symbol, let, new_let, 2, args); + let = new_let; + } + if (let == sc->rootlet) + slot = global_slot(obj); + else slot = lookup_slot_from((is_keyword(obj)) ? keyword_symbol(obj) : obj, let); + } + else slot = s7_slot(sc, obj); + if (is_slot(slot)) /* might be # */ + return(make_boolean(sc, is_immutable_slot(slot))); + } + else + if ((is_pair(cdr(args))) && (!is_let(cadr(args)))) /* (immutable? 1 2) */ + wrong_type_error_nr(sc, sc->is_immutable_symbol, 2, cadr(args), a_let_string); + return(make_boolean(sc, (is_immutable(obj)) || (t_immutable_p[type(obj)]) || + ((is_any_vector(obj)) && (vector_length(obj) == 0)))); } -#endif -static s7_pointer -g_immutable (s7_scheme* sc, s7_pointer args) { -#define H_immutable \ - "(immutable! obj (env (curlet))) declares that the object obj (or obj in " \ - "the environment env) can't be changed. obj is returned." -#define Q_immutable \ - s7_make_signature (sc, 3, sc->T, sc->T, has_let_signature (sc)) - - const s7_pointer obj= car (args); - if (is_symbol (obj)) { - s7_pointer slot; - if (is_pair (cdr (args))) { - s7_pointer let= cadr (args); - if ((!is_let (let)) || (let == sc->rootlet)) { - s7_pointer new_let= find_let (sc, let); - if ((!is_let (new_let)) || (new_let == sc->rootlet)) - find_let_error_nr (sc, sc->immutable_symbol, let, new_let, 2, args); - let= new_let; - } - slot= symbol_to_local_slot ( - sc, (is_keyword (obj)) ? keyword_symbol (obj) : obj, - let); /* different from immutable? */ + +/* -------------------------------- immutable! -------------------------------- */ +s7_pointer s7_set_immutable(s7_scheme *sc, s7_pointer obj) +{ + if (is_symbol(obj)) /* trying to mimic g_immutable */ + { + s7_pointer slot; + if (is_keyword(obj)) return(obj); + slot = s7_slot(sc, obj); + if (is_slot(slot)) + set_immutable_slot(slot); + /* symbol is not set immutable (as below) */ } - else { - if (is_keyword (obj)) return (obj); - slot= s7_slot (sc, obj); + else set_immutable(obj); + return(obj); +} + +#if (!DISABLE_DEPRECATED) && (S7_DEBUGGING || DISABLE_FILE_OUTPUT || POINTER_32) + s7_pointer s7_immutable(s7_pointer obj) {return(s7_set_immutable(cur_sc, obj));} +#endif + +static s7_pointer g_immutable(s7_scheme *sc, s7_pointer args) +{ + #define H_immutable "(immutable! obj (env (curlet))) declares that the object obj (or obj in the environment env) can't be changed. obj is returned." + #define Q_immutable s7_make_signature(sc, 3, sc->T, sc->T, has_let_signature(sc)) + + const s7_pointer obj = car(args); + if (is_symbol(obj)) + { + s7_pointer slot; + if (is_pair(cdr(args))) + { + s7_pointer let = cadr(args); + if ((!is_let(let)) || (let == sc->rootlet)) + { + s7_pointer new_let = find_let(sc, let); + if ((!is_let(new_let)) || (new_let == sc->rootlet)) + find_let_error_nr(sc, sc->immutable_symbol, let, new_let, 2, args); + let = new_let; + } + slot = symbol_to_local_slot(sc, (is_keyword(obj)) ? keyword_symbol(obj) : obj, let); /* different from immutable? */ + } + else + { + if (is_keyword(obj)) return(obj); + slot = s7_slot(sc, obj); + } + if (is_slot(slot)) + set_immutable_slot(slot); + return(obj); /* symbol is not set immutable ? */ } - if (is_slot (slot)) set_immutable_slot (slot); - return (obj); /* symbol is not set immutable ? */ - } - if ((is_pair (cdr (args))) && - (!is_let (cadr (args)))) /* (immutable! 1 2), but this error could be - better (find_let etc) */ - wrong_type_error_nr (sc, sc->immutable_symbol, 2, cadr (args), - a_let_string); - set_immutable (obj); - return (obj); + if ((is_pair(cdr(args))) && (!is_let(cadr(args)))) /* (immutable! 1 2), but this error could be better (find_let etc) */ + wrong_type_error_nr(sc, sc->immutable_symbol, 2, cadr(args), a_let_string); + set_immutable(obj); + return(obj); } -/* there's no way to make a slot setter (as setter) immutable (t_multiform as - * bit) */ +/* 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 slower - * because we need (in that case) to manage them in the sweep process by - * tracking lets. +/* 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 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) { - static bool already_warned= false; - s7_int loc = s7_gc_protect (sc, x); - if ((sc->safety > no_safety) && (!already_warned) && (loc > 8192)) { - already_warned= true; - fprintf (stderr, - "s7_gc_protect has protected more than 8192 values? (line: %d, " - "code: %s, loc: %" ld64 ")\n", - line, - string_value (s7_object_to_string (sc, current_code (sc), false)), - loc); - if (sc->stop_at_error) abort (); - } - return (loc); +s7_int gc_protect_2(s7_scheme *sc, s7_pointer x, int32_t line) +{ + static bool already_warned = false; + s7_int loc = s7_gc_protect(sc, x); + if ((sc->safety > no_safety) && (!already_warned) && (loc > 8192)) + { + already_warned = true; + fprintf(stderr, "s7_gc_protect has protected more than 8192 values? (line: %d, code: %s, loc: %" ld64 ")\n", + line, string_value(s7_object_to_string(sc, current_code(sc), false)), loc); + if (sc->stop_at_error) abort(); + } + return(loc); } -#define gc_protect_1(Sc, X) gc_protect_2 (Sc, X, __LINE__) +#define gc_protect_1(Sc, X) gc_protect_2(Sc, X, __LINE__) #else -#define gc_protect_1(Sc, X) s7_gc_protect (Sc, X) +#define gc_protect_1(Sc, X) s7_gc_protect(Sc, X) #endif -static void -resize_gc_protect (s7_scheme* sc) { - const s7_int size = sc->protected_objects_size; - block_t* old_b = vector_block (sc->protected_objects); - const s7_int new_size= 2 * size; - block_t* new_b = reallocate (sc, old_b, new_size * sizeof (s7_pointer)); - block_info (new_b) = NULL; - vector_block (sc->protected_objects) = new_b; - vector_elements (sc->protected_objects)= (s7_pointer*) block_data (new_b); - vector_length (sc->protected_objects) = new_size; - sc->protected_objects_size = new_size; - sc->protected_objects_free_list = (s7_int*) Realloc ( - sc->protected_objects_free_list, new_size * sizeof (s7_int)); - for (s7_int i= size; i < new_size; i++) { - vector_element (sc->protected_objects, i)= sc->unused; - sc->protected_objects_free_list[++sc->protected_objects_free_list_loc]= i; - } +static void resize_gc_protect(s7_scheme *sc) +{ + const s7_int size = sc->protected_objects_size; + block_t *old_b = vector_block(sc->protected_objects); + const s7_int new_size = 2 * size; + block_t *new_b = reallocate(sc, old_b, new_size * sizeof(s7_pointer)); + block_info(new_b) = NULL; + vector_block(sc->protected_objects) = new_b; + vector_elements(sc->protected_objects) = (s7_pointer *)block_data(new_b); + vector_length(sc->protected_objects) = new_size; + sc->protected_objects_size = new_size; + sc->protected_objects_free_list = (s7_int *)Realloc(sc->protected_objects_free_list, new_size * sizeof(s7_int)); + for (s7_int i = size; i < new_size; i++) + { + vector_element(sc->protected_objects, i) = sc->unused; + sc->protected_objects_free_list[++sc->protected_objects_free_list_loc] = i; + } } -s7_int -s7_gc_protect (s7_scheme* sc, s7_pointer x) { +s7_int s7_gc_protect(s7_scheme *sc, s7_pointer x) +{ s7_int loc; - if (sc->protected_objects_free_list_loc < 0) resize_gc_protect (sc); - loc= sc->protected_objects_free_list[sc->protected_objects_free_list_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->protected_objects_free_list[++sc->protected_objects_free_list_loc]= - loc; - else if (S7_DEBUGGING) - fprintf (stderr, "redundant gc_unprotect_at location %" ld64 "\n", loc); - vector_element (sc->protected_objects, loc)= sc->unused; - } + if (sc->protected_objects_free_list_loc < 0) + resize_gc_protect(sc); + loc = sc->protected_objects_free_list[sc->protected_objects_free_list_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->protected_objects_free_list[++sc->protected_objects_free_list_loc] = loc; + else if (S7_DEBUGGING) fprintf(stderr, "redundant gc_unprotect_at location %" ld64 "\n", loc); + 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; +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); + 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) +#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_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->unused; - sc->protected_objects_free_list[++sc->protected_objects_free_list_loc]= - loc; /* added 13-Feb-25 */ - return (sc->F); +s7_pointer s7_gc_unprotect_via_location(s7_scheme *sc, s7_int loc) +{ + vector_element(sc->protected_objects, loc) = sc->unused; + sc->protected_objects_free_list[++sc->protected_objects_free_list_loc] = loc; /* added 13-Feb-25 */ + return(sc->F); } + /* these 3 are needed by sweep */ -static void (*mark_function[NUM_TYPES]) (s7_pointer p); -void -s7_mark (s7_pointer p) { - if (!is_marked (p)) (*mark_function[type_unchecked (p)]) (p); -} -static void -mark_noop (s7_pointer unused_p) {} - -static void -process_iterator (s7_scheme* unused_sc, s7_pointer iter) { - if (is_weak_hash_iterator (iter)) { - s7_pointer seq= iterator_sequence (iter); - clear_weak_hash_iterator (iter); - if (type_unchecked (seq) == T_HASH_TABLE) weak_hash_iters (seq)--; - } +static void (*mark_function[NUM_TYPES])(s7_pointer p); +void s7_mark(s7_pointer p) {if (!is_marked(p)) (*mark_function[type_unchecked(p)])(p);} +static void mark_noop(s7_pointer unused_p) {} + +static void process_iterator(s7_scheme *unused_sc, s7_pointer iter) +{ + if (is_weak_hash_iterator(iter)) + { + s7_pointer seq = iterator_sequence(iter); + clear_weak_hash_iterator(iter); + if (type_unchecked(seq) == T_HASH_TABLE) + weak_hash_iters(seq)--; + } } -static void -process_multivector (s7_scheme* sc, s7_pointer vect) { - vdims_t* info= vector_dimension_info ( - vect); /* 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 */ +static void process_multivector(s7_scheme *sc, s7_pointer vect) +{ + vdims_t *info = vector_dimension_info(vect); /* a multidimensional empty vector can have dimension info, wrapped vectors always have dimension info */ + if ((info) && (info != sc->wrap_only)) { - free (any_vector_elements (vect)); - vector_elements_should_be_freed (info)= false; + if (vector_elements_should_be_freed(info)) /* a kludge for foreign code convenience */ + { + free(any_vector_elements(vect)); + vector_elements_should_be_freed(info) = false; + } + liberate(sc, info); + vector_set_dimension_info(vect, NULL); } - liberate (sc, info); - vector_set_dimension_info (vect, NULL); - } - liberate (sc, vector_block (vect)); + liberate(sc, vector_block(vect)); } -static void -process_input_string_port (s7_scheme* sc, s7_pointer port) { +static void process_input_string_port(s7_scheme *sc, s7_pointer port) +{ #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 + /* 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 (port)) - fprintf (stderr, "%s[%d]: string input port has a filename: %s\n", __func__, - __LINE__, port_filename (port)); - if (port_needs_free (port)) - fprintf (stderr, "%s[%d]: string input port needs data release\n", __func__, - __LINE__); + if (port_filename(port)) + fprintf(stderr, "%s[%d]: string input port has a filename: %s\n", __func__, __LINE__, port_filename(port)); + if (port_needs_free(port)) + fprintf(stderr, "%s[%d]: string input port needs data release\n", __func__, __LINE__); #endif - liberate (sc, port_block (port)); + liberate(sc, port_block(port)); } -static void -free_port_data (s7_scheme* sc, s7_pointer port) { - if (port_data (port)) { - liberate (sc, port_data_block (port)); - port_data_block (port)= NULL; - port_data (port) = NULL; - port_data_size (port) = 0; - } - port_needs_free (port)= false; +static void free_port_data(s7_scheme *sc, s7_pointer port) +{ + if (port_data(port)) + { + liberate(sc, port_data_block(port)); + port_data_block(port) = NULL; + port_data(port) = NULL; + port_data_size(port) = 0; + } + port_needs_free(port) = false; } -static void close_input_function_port (s7_scheme* sc, s7_pointer port); -static void close_output_port (s7_scheme* sc, s7_pointer port); +static void close_input_function_port(s7_scheme *sc, s7_pointer port); +static void close_output_port(s7_scheme *sc, s7_pointer port); -static void -process_input_port (s7_scheme* sc, s7_pointer port) { - if (!port_is_closed (port)) { - if (is_file_port (port)) { - if (port_file (port)) { - fclose (port_file (port)); - port_file (port)= NULL; - } +static void process_input_port(s7_scheme *sc, s7_pointer port) +{ + if (!port_is_closed(port)) + { + if (is_file_port(port)) + { + if (port_file(port)) + { + fclose(port_file(port)); + port_file(port) = NULL; + }} + else + if (is_function_port(port)) + close_input_function_port(sc, port); } - else if (is_function_port (port)) close_input_function_port (sc, port); - } - if (port_needs_free (port)) free_port_data (sc, port); + if (port_needs_free(port)) + free_port_data(sc, port); - if (port_filename (port)) { - liberate (sc, port_filename_block (port)); - port_filename (port)= NULL; - } - liberate (sc, port_block (port)); + if (port_filename(port)) + { + liberate(sc, port_filename_block(port)); + port_filename(port) = NULL; + } + liberate(sc, port_block(port)); } -static void -process_output_port (s7_scheme* sc, s7_pointer port) { - close_output_port (sc, port); /* needed for free filename, etc */ - liberate (sc, port_block (port)); - if (port_needs_free (port)) { - port_needs_free (port)= false; - if (port_data_block (port)) { - liberate (sc, port_data_block (port)); - port_data_block (port)= NULL; - } - } +static void process_output_port(s7_scheme *sc, s7_pointer port) +{ + close_output_port(sc, port); /* needed for free filename, etc */ + liberate(sc, port_block(port)); + if (port_needs_free(port)) + { + port_needs_free(port) = false; + if (port_data_block(port)) + { + liberate(sc, port_data_block(port)); + port_data_block(port) = NULL; + }} } -#define s7_integer_clamped_if_gmp(Sc, P) integer (P) +#define s7_integer_clamped_if_gmp(Sc, P) integer(P) -void process_continuation (s7_scheme* sc, s7_pointer cc); -void mark_continuation (s7_pointer cc); +void process_continuation(s7_scheme *sc, s7_pointer cc); +void mark_continuation(s7_pointer cc); -static void free_hash_table (s7_scheme* sc, s7_pointer table); -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 free_hash_table(s7_scheme *sc, s7_pointer table); +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 -sweep (s7_scheme* sc) { - s7_int i, j; - gc_list_t* gp; +static void sweep(s7_scheme *sc) +{ + s7_int i, j; + gc_list_t *gp; + + #define process_gc_list(Code) \ + if (gp->loc > 0) \ + { \ + for (i = 0, j = 0; i < gp->loc; i++) \ + { \ + s7_pointer gc_obj = gp->list[i]; \ + if (is_free_and_clear(gc_obj)) \ + { \ + Code; /* may access gc_obj internally */ \ + } \ + else if (in_heap(gc_obj)) gp->list[j++] = gc_obj; \ + } \ + gp->loc = j; \ + } \ -#define process_gc_list(Code) \ - if (gp->loc > 0) { \ - for (i= 0, j= 0; i < gp->loc; i++) { \ - s7_pointer gc_obj= gp->list[i]; \ - if (is_free_and_clear (gc_obj)) { \ - Code; /* may access gc_obj internally */ \ - } \ - else if (in_heap (gc_obj)) gp->list[j++]= gc_obj; \ - } \ - gp->loc= j; \ - } + gp = sc->strings; + process_gc_list(liberate(sc, string_block(gc_obj))); - gp= sc->strings; - process_gc_list (liberate (sc, string_block (gc_obj))); - - gp= sc->gensyms; - process_gc_list (remove_gensym_from_symbol_table (sc, gc_obj); - liberate (sc, gensym_block (gc_obj))); - if (gp->loc == 0) mark_function[T_SYMBOL]= mark_noop; - - gp= sc->undefineds; - process_gc_list (free (undefined_name (gc_obj))); - - gp= sc->c_objects; - process_gc_list ( - if (c_object_gc_free (sc, gc_obj)) (*(c_object_gc_free (sc, gc_obj))) ( - sc, gc_obj); - else (*(c_object_free (sc, gc_obj))) (c_object_value (gc_obj))); - - gp= sc->vectors; - process_gc_list (liberate (sc, vector_block (gc_obj))); - - gp= sc->multivectors; - process_gc_list (process_multivector (sc, gc_obj)); - - gp= sc->hash_tables; - if (gp->loc > 0) { - for (i= 0, j= 0; i < gp->loc; i++) { - s7_pointer gc_obj= gp->list[i]; - if (is_free_and_clear (gc_obj)) free_hash_table (sc, gc_obj); - else { - if ((is_weak_hash_table (gc_obj)) && (weak_hash_iters (gc_obj) == 0) && - (hash_table_entries (gc_obj) > 0)) - cull_weak_hash_table (sc, gc_obj); - gp->list[j++]= gc_obj; - } + gp = sc->gensyms; + process_gc_list(remove_gensym_from_symbol_table(sc, gc_obj); liberate(sc, gensym_block(gc_obj))); + if (gp->loc == 0) mark_function[T_SYMBOL] = mark_noop; + + gp = sc->undefineds; + process_gc_list(free(undefined_name(gc_obj))); + + gp = sc->c_objects; + process_gc_list(if (c_object_gc_free(sc, gc_obj)) (*(c_object_gc_free(sc, gc_obj)))(sc, gc_obj); else (*(c_object_free(sc, gc_obj)))(c_object_value(gc_obj))); + + gp = sc->vectors; + process_gc_list(liberate(sc, vector_block(gc_obj))); + + gp = sc->multivectors; + process_gc_list(process_multivector(sc, gc_obj)); + + gp = sc->hash_tables; + if (gp->loc > 0) + { + for (i = 0, j = 0; i < gp->loc; i++) + { + s7_pointer gc_obj = gp->list[i]; + if (is_free_and_clear(gc_obj)) + free_hash_table(sc, gc_obj); + else + { + if ((is_weak_hash_table(gc_obj)) && + (weak_hash_iters(gc_obj) == 0) && + (hash_table_entries(gc_obj) > 0)) + cull_weak_hash_table(sc, gc_obj); + gp->list[j++] = gc_obj; + }} + gp->loc = j; } - gp->loc= j; - } - gp= sc->weak_hash_iterators; - process_gc_list (process_iterator (sc, gc_obj)); + gp = sc->weak_hash_iterators; + process_gc_list(process_iterator(sc, gc_obj)); - gp= sc->opt1_funcs; - if (gp->loc > 0) { - for (i= 0, j= 0; i < gp->loc; i++) { - s7_pointer gc_obj= gp->list[i]; - if (!is_free_and_clear (gc_obj)) gp->list[j++]= gc_obj; + gp = sc->opt1_funcs; + if (gp->loc > 0) + { + for (i = 0, j = 0; i < gp->loc; i++) + { + s7_pointer gc_obj = gp->list[i]; + if (!is_free_and_clear(gc_obj)) + gp->list[j++] = gc_obj; + } + gp->loc = j; } - gp->loc= j; - } - gp= sc->input_ports; - process_gc_list (process_input_port (sc, gc_obj)); - - gp= sc->input_string_ports; - process_gc_list (process_input_string_port (sc, gc_obj)); - - gp= sc->output_ports; - process_gc_list (process_output_port (sc, gc_obj)); - - gp= sc->continuations; - process_gc_list (process_continuation (sc, gc_obj)); - - gp= sc->weak_refs; - if (gp->loc > 0) { - for (i= 0, j= 0; i < gp->loc; i++) { - s7_pointer gc_obj= gp->list[i]; - if (!is_free_and_clear (gc_obj)) { - if (is_free_and_clear (c_pointer_weak1 (gc_obj))) - c_pointer_weak1 (gc_obj)= sc->F; - if (is_free_and_clear (c_pointer_weak2 (gc_obj))) - c_pointer_weak2 (gc_obj)= sc->F; - if ((c_pointer_weak1 (gc_obj) != sc->F) || - (c_pointer_weak2 (gc_obj) != sc->F)) - gp->list[j++]= gc_obj; - } + gp = sc->input_ports; + process_gc_list(process_input_port(sc, gc_obj)); + + gp = sc->input_string_ports; + process_gc_list(process_input_string_port(sc, gc_obj)); + + gp = sc->output_ports; + process_gc_list(process_output_port(sc, gc_obj)); + + gp = sc->continuations; + process_gc_list(process_continuation(sc, gc_obj)); + + gp = sc->weak_refs; + if (gp->loc > 0) + { + for (i = 0, j = 0; i < gp->loc; i++) + { + s7_pointer gc_obj = gp->list[i]; + if (!is_free_and_clear(gc_obj)) + { + if (is_free_and_clear(c_pointer_weak1(gc_obj))) + c_pointer_weak1(gc_obj) = sc->F; + if (is_free_and_clear(c_pointer_weak2(gc_obj))) + c_pointer_weak2(gc_obj) = sc->F; + if ((c_pointer_weak1(gc_obj) != sc->F) || + (c_pointer_weak2(gc_obj) != sc->F)) + gp->list[j++] = gc_obj; + }} + gp->loc = j; } - gp->loc= j; - } + + } -void -add_to_gc_list (s7_scheme* sc, gc_list_t* gp, s7_pointer p) { +void add_to_gc_list(s7_scheme *sc, gc_list_t *gp, s7_pointer p) +{ #if S7_DEBUGGING - if ((!in_heap (p)) && (gp != sc->opt1_funcs)) { - char* str= describe_type_bits (sc, p); - fprintf (stderr, "%s[%d]: %s not in heap, %s\n", __func__, __LINE__, - display (p), str); - free (str); - if (sc->stop_at_error) abort (); - } + if ((!in_heap(p)) && (gp != sc->opt1_funcs)) + { + char *str = describe_type_bits(sc, p); + fprintf(stderr, "%s[%d]: %s not in heap, %s\n", __func__, __LINE__, display(p), str); + free(str); + if (sc->stop_at_error) abort(); + } #endif - 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; + 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= (gc_list_t*) Malloc (sizeof (gc_list_t)); -#define INIT_GC_CACHE_SIZE 4 - gp->size= INIT_GC_CACHE_SIZE; +static gc_list_t *make_gc_list(void) +{ + gc_list_t *gp = (gc_list_t *)Malloc(sizeof(gc_list_t)); + #define INIT_GC_CACHE_SIZE 4 + gp->size = INIT_GC_CACHE_SIZE; gp->loc = 0; - gp->list= (s7_pointer*) Malloc (gp->size * sizeof (s7_pointer)); - return (gp); -} - -void -just_mark (s7_pointer p) { - set_mark (p); -} - -static void -add_gensym (s7_scheme* sc, s7_pointer p) { - add_to_gc_list (sc, sc->gensyms, p); - mark_function[T_SYMBOL]= just_mark; -} - -#define add_c_object(sc, p) add_to_gc_list (sc, sc->c_objects, p) -#define add_hash_table(sc, p) add_to_gc_list (sc, sc->hash_tables, p) -#define add_string(sc, p) add_to_gc_list (sc, sc->strings, p) -#define add_input_port(sc, p) add_to_gc_list (sc, sc->input_ports, p) -#define add_input_string_port(sc, p) \ - add_to_gc_list (sc, sc->input_string_ports, p) -#define add_output_port(sc, p) add_to_gc_list (sc, sc->output_ports, p) -#define add_undefined(sc, p) add_to_gc_list (sc, sc->undefineds, p) -#define add_vector(sc, p) add_to_gc_list (sc, sc->vectors, p) -#define add_multivector(sc, p) add_to_gc_list (sc, sc->multivectors, p) -#define add_weak_ref(sc, p) add_to_gc_list (sc, sc->weak_refs, p) -#define add_weak_hash_iterator(sc, p) \ - add_to_gc_list (sc, sc->weak_hash_iterators, p) -#define add_opt1_func(sc, p) \ - do { \ - if (!opt1_func_listed (p)) add_to_gc_list (sc, sc->opt1_funcs, p); \ - set_opt1_func_listed (p); \ - } while (0) /* called by set_opt1_lambda_add */ - -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->weak_refs = make_gc_list (); - sc->weak_hash_iterators= make_gc_list (); - sc->opt1_funcs = make_gc_list (); + gp->list = (s7_pointer *)Malloc(gp->size * sizeof(s7_pointer)); + return(gp); +} + +void just_mark(s7_pointer p) {set_mark(p);} + +static void add_gensym(s7_scheme *sc, s7_pointer p) +{ + add_to_gc_list(sc, sc->gensyms, p); + mark_function[T_SYMBOL] = just_mark; +} + +#define add_c_object(sc, p) add_to_gc_list(sc, sc->c_objects, p) +#define add_hash_table(sc, p) add_to_gc_list(sc, sc->hash_tables, p) +#define add_string(sc, p) add_to_gc_list(sc, sc->strings, p) +#define add_input_port(sc, p) add_to_gc_list(sc, sc->input_ports, p) +#define add_input_string_port(sc, p) add_to_gc_list(sc, sc->input_string_ports, p) +#define add_output_port(sc, p) add_to_gc_list(sc, sc->output_ports, p) +#define add_undefined(sc, p) add_to_gc_list(sc, sc->undefineds, p) +#define add_vector(sc, p) add_to_gc_list(sc, sc->vectors, p) +#define add_multivector(sc, p) add_to_gc_list(sc, sc->multivectors, p) +#define add_weak_ref(sc, p) add_to_gc_list(sc, sc->weak_refs, p) +#define add_weak_hash_iterator(sc, p) add_to_gc_list(sc, sc->weak_hash_iterators, p) +#define add_opt1_func(sc, p) do {if (!opt1_func_listed(p)) add_to_gc_list(sc, sc->opt1_funcs, p); set_opt1_func_listed(p);} while (0) /* called by set_opt1_lambda_add */ + + +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->weak_refs = make_gc_list(); + sc->weak_hash_iterators = make_gc_list(); + sc->opt1_funcs = make_gc_list(); /* slightly unrelated... */ - sc->setters_size= 4; + sc->setters_size = 4; sc->setters_loc = 0; - sc->setters= (s7_pointer*) Malloc (sc->setters_size * sizeof (s7_pointer)); + sc->setters = (s7_pointer *)Malloc(sc->setters_size * sizeof(s7_pointer)); } -static s7_pointer semipermanent_cons (s7_scheme* sc, s7_pointer a, s7_pointer b, - s7_uint type); +static s7_pointer semipermanent_cons(s7_scheme *sc, s7_pointer a, s7_pointer b, s7_uint type); -static void -add_setter (s7_scheme* sc, s7_pointer func, 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. +static void add_setter(s7_scheme *sc, s7_pointer func, 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. */ - for (s7_int i= 0; i < sc->setters_loc; i++) { - s7_pointer x= sc->setters[i]; - if (car (x) == func) { - set_cdr_unchecked ( - x, T_Clo (setter)); /* T_Clo else no GC protection needed */ - return; + for (s7_int i = 0; i < sc->setters_loc; i++) + { + s7_pointer x = sc->setters[i]; + if (car(x) == func) + { + set_cdr_unchecked(x, T_Clo(setter)); /* T_Clo else no GC protection needed */ + 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)); } - } - 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++]= - semipermanent_cons (sc, func, T_Prc (setter), T_PAIR | T_IMMUTABLE); + sc->setters[sc->setters_loc++] = semipermanent_cons(sc, func, T_Prc(setter), T_PAIR | T_IMMUTABLE); } -static inline void -gc_mark (s7_pointer p) { - if (!is_marked (p)) (*mark_function[type_unchecked (p)]) (p); -} -static void -mark_symbol_vector (s7_pointer vec, s7_int len) { - set_mark (vec); +static inline void gc_mark(s7_pointer p) {if (!is_marked(p)) (*mark_function[type_unchecked(p)])(p);} + +static void mark_symbol_vector(s7_pointer vec, s7_int len) +{ + set_mark(vec); if (mark_function[T_SYMBOL] != mark_noop) /* else no gensyms */ - { - s7_pointer* els= vector_elements (vec); - for (s7_int i= 0; i < len; i++) - if ((is_symbol (els[i])) && - (is_gensym ( - els[i]))) /* need is_symbol: make-vector + set! vector-typer - symbol? where init is not a symbol */ - set_mark (els[i]); - } + { + s7_pointer *els = vector_elements(vec); + for (s7_int i = 0; i < len; i++) + if ((is_symbol(els[i])) && (is_gensym(els[i]))) /* need is_symbol: make-vector + set! vector-typer symbol? where init is not a symbol */ + set_mark(els[i]); + } } -static void -mark_simple_vector (s7_pointer vec, s7_int len) { - s7_pointer* vels= vector_elements (vec); - set_mark (vec); - for (s7_int i= 0; i < len; i++) - set_mark (vels[i]); +static void mark_simple_vector(s7_pointer vec, s7_int len) +{ + s7_pointer *vels = vector_elements(vec); + set_mark(vec); + for (s7_int i = 0; i < len; i++) + set_mark(vels[i]); } -static void -just_mark_vector (s7_pointer vect, s7_int unused_len) { - set_mark (vect); -} +static void just_mark_vector(s7_pointer vect, s7_int unused_len) {set_mark(vect);} -static void -mark_vector_1 (s7_pointer vect, s7_int top) { - s7_pointer* tp= (s7_pointer*) (vector_elements (vect)); +static void mark_vector_1(s7_pointer vect, s7_int top) +{ + s7_pointer *tp = (s7_pointer *)(vector_elements(vect)); s7_pointer *tend, *tend4; - set_mark (vect); + set_mark(vect); if (!tp) return; - tend = (s7_pointer*) (tp + top); - tend4= (s7_pointer*) (tend - 16); - while (tp <= tend4) { - LOOP_8 (gc_mark (*tp++)); - LOOP_8 (gc_mark (*tp++)); - } /* faster if large vectors in use, maybe slower otherwise? */ + tend = (s7_pointer *)(tp + top); + tend4 = (s7_pointer *)(tend - 16); + while (tp <= tend4) {LOOP_8(gc_mark(*tp++)); LOOP_8(gc_mark(*tp++));} /* faster if large vectors in use, maybe slower otherwise? */ while (tp < tend) - gc_mark (*tp++); -} - -static void -mark_typed_vector_1 (s7_pointer vect, - s7_int top) /* for typed vectors with closure setters */ -{ - gc_mark (typed_vector_typer (vect)); - mark_vector_1 (vect, top); -} - -static inline void -mark_slot (s7_pointer slot) { - set_mark (T_Slt (slot)); - gc_mark (slot_value (slot)); - if (slot_has_setter_or_pending_value (slot)) - gc_mark (slot_pending_value_unchecked ( - slot)); /* setter field == pending_value */ - set_mark (slot_symbol (slot)); -} - -static void -mark_let (s7_pointer let) { - for (; (let) && (!is_marked (let)); let= let_outlet (let)) { - set_mark (let); - if (has_dox_slot1 (let)) mark_slot (let_dox_slot1 (let)); - if ((has_dox_slot2 (let)) && (is_slot (let_dox_slot2 (let)))) - mark_slot (let_dox_slot2 (let)); - /* it can happen (call/cc related) that let_dox_slot2 is a slot but invalid, - * but in that case has_dox_slot2 will not be set(?) */ - for (s7_pointer slot= let_slots (let); is_not_slot_end (slot); - slot = next_slot (slot)) - if (!is_marked (slot)) /* slot value might be the enclosing let */ - mark_slot (slot); - } + gc_mark(*tp++); +} + +static void mark_typed_vector_1(s7_pointer vect, s7_int top) /* for typed vectors with closure setters */ +{ + gc_mark(typed_vector_typer(vect)); + mark_vector_1(vect, top); } -static void -mark_wrappers (s7_scheme* sc) { - s7_pointer p = sc->let_wrappers; - s7_pointer end_p= p; +static inline void mark_slot(s7_pointer slot) +{ + set_mark(T_Slt(slot)); + gc_mark(slot_value(slot)); + if (slot_has_setter_or_pending_value(slot)) + gc_mark(slot_pending_value_unchecked(slot)); /* setter field == pending_value */ + set_mark(slot_symbol(slot)); +} + +static void mark_let(s7_pointer let) +{ + for (; (let) && (!is_marked(let)); let = let_outlet(let)) + { + set_mark(let); + if (has_dox_slot1(let)) mark_slot(let_dox_slot1(let)); + if ((has_dox_slot2(let)) && (is_slot(let_dox_slot2(let)))) mark_slot(let_dox_slot2(let)); + /* it can happen (call/cc related) that let_dox_slot2 is a slot but invalid, but in that case has_dox_slot2 will not be set(?) */ + for (s7_pointer slot = let_slots(let); is_not_slot_end(slot); slot = next_slot(slot)) + if (!is_marked(slot)) /* slot value might be the enclosing let */ + mark_slot(slot); + } +} + +static void mark_wrappers(s7_scheme *sc) +{ + s7_pointer p = sc->let_wrappers; + s7_pointer end_p = p; do { - for (s7_pointer slot= let_slots (car (p)); is_not_slot_end (slot); - slot = next_slot (slot)) - if (!is_marked (slot)) mark_slot (slot); - p= cdr (p); + for (s7_pointer slot = let_slots(car(p)); is_not_slot_end(slot); slot = next_slot(slot)) + if (!is_marked(slot)) mark_slot(slot); + p = cdr(p); } while (p != end_p); /* dox1|2? gensyms? maybe don't wrap gensym-slot */ } -static void -unmark_wrappers (s7_scheme* sc) { - s7_pointer p = sc->let_wrappers; - s7_pointer end_p= p; +static void unmark_wrappers(s7_scheme *sc) +{ + s7_pointer p = sc->let_wrappers; + s7_pointer end_p = p; do { - for (s7_pointer slot= let_slots (car (p)); is_not_slot_end (slot); - slot = next_slot (slot)) - clear_mark (slot); - p= cdr (p); + for (s7_pointer slot = let_slots(car(p)); is_not_slot_end(slot); slot = next_slot(slot)) clear_mark(slot); + p = cdr(p); } while (p != end_p); } #if WITH_HISTORY -static void -gc_owlet_mark (s7_pointer tp) { +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[type_unchecked (tp)]) (tp); -} -#endif - -static void -mark_owlet (s7_scheme* sc) { + 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[type_unchecked(tp)])(tp); +} +#endif + +static void mark_owlet(s7_scheme *sc) +{ #if WITH_HISTORY { - for (s7_pointer p1= sc->eval_history1, p2= sc->eval_history2, - p3= sc->history_pairs; - ; p2= cdr (p2), p3= cdr (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 */ - } - } + for (s7_pointer p1 = sc->eval_history1, p2 = sc->eval_history2, p3 = sc->history_pairs; ; p2 = cdr(p2), p3 = cdr(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); + 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); + mark_slot(sc->error_history); #endif - set_mark (sc->owlet); - mark_let (let_outlet (sc->owlet)); + set_mark(sc->owlet); + mark_let(let_outlet(sc->owlet)); } -static void -mark_c_pointer (s7_pointer cp) { - set_mark (cp); - gc_mark (c_pointer_type (cp)); - gc_mark (c_pointer_info (cp)); +static void mark_c_pointer(s7_pointer cp) +{ + set_mark(cp); + gc_mark(c_pointer_type(cp)); + gc_mark(c_pointer_info(cp)); } -static void -mark_c_proc_star (s7_pointer proc) { - set_mark (proc); - if ((!c_func_has_simple_defaults (proc)) && - (c_function_call_args (proc))) /* NULL if not a safe function */ - for (s7_pointer arg= c_function_call_args (proc); is_pair (arg); - arg = cdr (arg)) - gc_mark (car (arg)); +static void mark_c_proc_star(s7_pointer proc) +{ + set_mark(proc); + if ((!c_func_has_simple_defaults(proc)) && + (c_function_call_args(proc))) /* NULL if not a safe function */ + for (s7_pointer arg = c_function_call_args(proc); is_pair(arg); arg = cdr(arg)) + gc_mark(car(arg)); } -static void -mark_pair (s7_pointer p) { +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 ctr) { - set_mark (ctr); - gc_mark (counter_result (ctr)); - gc_mark (counter_list (ctr)); - gc_mark (counter_let (ctr)); -} - -static void -mark_closure (s7_pointer clo) { - set_mark (clo); - gc_mark (closure_pars (clo)); - gc_mark (closure_body (clo)); - mark_let (closure_let (clo)); - /* because we can't tell if a closure is live, we can't clear closure_let - * slot_values that are not currently in play (all gc roots are live!) */ - gc_mark (closure_setter_or_map_list (clo)); -} - -void -mark_stack_1 (s7_pointer stack, s7_int top) { - s7_pointer *tp= (s7_pointer*) (stack_elements (stack)), *tend; - set_mark (stack); + 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 ctr) +{ + set_mark(ctr); + gc_mark(counter_result(ctr)); + gc_mark(counter_list(ctr)); + gc_mark(counter_let(ctr)); +} + +static void mark_closure(s7_pointer clo) +{ + set_mark(clo); + gc_mark(closure_pars(clo)); + gc_mark(closure_body(clo)); + mark_let(closure_let(clo)); + /* because we can't tell if a closure is live, we can't clear closure_let slot_values that are not currently in play (all gc roots are live!) */ + gc_mark(closure_setter_or_map_list(clo)); +} + +void mark_stack_1(s7_pointer stack, s7_int top) +{ + s7_pointer *tp = (s7_pointer *)(stack_elements(stack)), *tend; + set_mark(stack); if (!tp) return; - tend= (s7_pointer*) (tp + top); - while (tp < tend) { - gc_mark (*tp++); /* sc->code */ - gc_mark (*tp++); /* sc->curlet */ - gc_mark (*tp++); /* sc->args */ - tp++; /* sc->cur_op */ - } + tend = (s7_pointer *)(tp + top); + while (tp < tend) + { + gc_mark(*tp++); /* sc->code */ + gc_mark(*tp++); /* sc->curlet */ + gc_mark(*tp++); /* sc->args */ + tp++; /* sc->cur_op */ + } } -static void -mark_stack (s7_pointer stack) { - /* 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 (stack, temp_stack_top (stack)); +static void mark_stack(s7_pointer stack) +{ + /* 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(stack, temp_stack_top(stack)); } -static void -mark_vector (s7_pointer vect) { - if (is_typed_vector (vect)) - typed_vector_gc_mark (vect) (vect, vector_length (vect)); - else mark_vector_1 (vect, vector_length (vect)); +static void mark_vector(s7_pointer vect) +{ + if (is_typed_vector(vect)) + typed_vector_gc_mark(vect)(vect, vector_length(vect)); + else mark_vector_1(vect, vector_length(vect)); } -static void -mark_vector_possibly_shared (s7_pointer vect) { - /* 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). +static void mark_vector_possibly_shared(s7_pointer vect) +{ + /* 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. + * 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. + * 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 (vect)) - mark_vector_possibly_shared (subvector_vector (vect)); + if (is_subvector(vect)) + mark_vector_possibly_shared(subvector_vector(vect)); - /* 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. + /* 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 (vect)) mark_vector_1 (vect, vector_length (vect)); + if (!is_marked(vect)) + mark_vector_1(vect, vector_length(vect)); } -static void -mark_int_or_float_vector (s7_pointer vect) { - set_mark (vect); -} +static void mark_int_or_float_vector(s7_pointer vect) {set_mark(vect);} -static void -mark_int_or_float_vector_possibly_shared ( - s7_pointer vect) /* also complex_vector */ +static void mark_int_or_float_vector_possibly_shared(s7_pointer vect) /* also complex_vector */ { - if (is_subvector (vect)) - mark_int_or_float_vector_possibly_shared (subvector_vector (vect)); - set_mark (vect); -} - -static void -mark_c_object (s7_pointer cobj) { - set_mark (cobj); - mark_let (c_object_let ( - cobj)); /* I think this is guaranteed to be a let, added 5-Apr-25 */ - if (c_object_gc_mark (c_object_sc (cobj), - cobj)) /* c_object_sc = s7_scheme pointer */ - (*(c_object_gc_mark (c_object_sc (cobj), cobj))) (c_object_sc (cobj), cobj); - else (*(c_object_mark (c_object_sc (cobj), cobj))) (c_object_value (cobj)); + if (is_subvector(vect)) + mark_int_or_float_vector_possibly_shared(subvector_vector(vect)); + set_mark(vect); } -static void -mark_catch (s7_pointer catcher) /* C++ reserves "catch" */ +static void mark_c_object(s7_pointer cobj) { - set_mark (catcher); - gc_mark (catch_tag (catcher)); - gc_mark (catch_handler (catcher)); + set_mark(cobj); + mark_let(c_object_let(cobj)); /* I think this is guaranteed to be a let, added 5-Apr-25 */ + if (c_object_gc_mark(c_object_sc(cobj), cobj)) /* c_object_sc = s7_scheme pointer */ + (*(c_object_gc_mark(c_object_sc(cobj), cobj)))(c_object_sc(cobj), cobj); + else (*(c_object_mark(c_object_sc(cobj), cobj)))(c_object_value(cobj)); } -static void -mark_dynamic_wind (s7_pointer dw) { - set_mark (dw); - gc_mark (dynamic_wind_in (dw)); - gc_mark (dynamic_wind_out (dw)); - gc_mark (dynamic_wind_body (dw)); +static void mark_catch(s7_pointer catcher) /* C++ reserves "catch" */ +{ + set_mark(catcher); + gc_mark(catch_tag(catcher)); + gc_mark(catch_handler(catcher)); } -static void -mark_hash_table (s7_pointer table) { - set_mark (table); - gc_mark (hash_table_procedures (table)); - if (is_pair (hash_table_procedures (table))) { - gc_mark (hash_table_key_typer_unchecked ( - table)); /* unchecked to avoid s7-debugger's reference to sc */ - gc_mark (hash_table_value_typer_unchecked (table)); - } - if (hash_table_entries (table) > 0) { - const s7_int len = (s7_int) hash_table_size (table); - hash_entry_t** entries= hash_table_elements (table); - hash_entry_t** last = (hash_entry_t**) (entries + len); - - if ((is_weak_hash_table (table)) && (weak_hash_iters (table) == 0)) - while (entries < last) { - hash_entry_t* entry; - for (entry= *entries++; entry; entry= hash_entry_next (entry)) - gc_mark (hash_entry_value (entry)); - for (entry= *entries++; entry; entry= hash_entry_next (entry)) - gc_mark (hash_entry_value (entry)); - } - else - while (entries < last) /* counting entries here was slightly faster */ - { - hash_entry_t* entry; - for (entry= *entries++; entry; entry= hash_entry_next (entry)) { - gc_mark (hash_entry_key (entry)); - gc_mark (hash_entry_value (entry)); - } - for (entry= *entries++; entry; entry= hash_entry_next (entry)) { - gc_mark (hash_entry_key (entry)); - gc_mark (hash_entry_value (entry)); - } - } - } +static void mark_dynamic_wind(s7_pointer dw) +{ + set_mark(dw); + gc_mark(dynamic_wind_in(dw)); + gc_mark(dynamic_wind_out(dw)); + gc_mark(dynamic_wind_body(dw)); } -static void -mark_iterator (s7_pointer iter) { - set_mark (iter); - gc_mark (iterator_sequence (iter)); - if (has_carrier (iter)) { - if (iterator_carrier (iter)) gc_mark (iterator_carrier (iter)); +static void mark_hash_table(s7_pointer table) +{ + set_mark(table); + gc_mark(hash_table_procedures(table)); + if (is_pair(hash_table_procedures(table))) + { + gc_mark(hash_table_key_typer_unchecked(table)); /* unchecked to avoid s7-debugger's reference to sc */ + gc_mark(hash_table_value_typer_unchecked(table)); + } + if (hash_table_entries(table) > 0) + { + const s7_int len = (s7_int)hash_table_size(table); + hash_entry_t **entries = hash_table_elements(table); + hash_entry_t **last = (hash_entry_t **)(entries + len); + + if ((is_weak_hash_table(table)) && + (weak_hash_iters(table) == 0)) + while (entries < last) + { + hash_entry_t *entry; + for (entry = *entries++; entry; entry = hash_entry_next(entry)) + gc_mark(hash_entry_value(entry)); + for (entry = *entries++; entry; entry = hash_entry_next(entry)) + gc_mark(hash_entry_value(entry)); + } + else + while (entries < last) /* counting entries here was slightly faster */ + { + hash_entry_t *entry; + for (entry = *entries++; entry; entry = hash_entry_next(entry)) + { + gc_mark(hash_entry_key(entry)); + gc_mark(hash_entry_value(entry)); + } + for (entry = *entries++; entry; entry = hash_entry_next(entry)) + { + gc_mark(hash_entry_key(entry)); + gc_mark(hash_entry_value(entry)); + }}} +} + +static void mark_iterator(s7_pointer iter) +{ + set_mark(iter); + gc_mark(iterator_sequence(iter)); + if (has_carrier(iter)) + { + if (iterator_carrier(iter)) + gc_mark(iterator_carrier(iter)); #if S7_DEBUGGING - else - fprintf ( - stderr, - "mark_iterator[%d]: has_carrier set (at line %d), but no carrier!\n", - __LINE__, iter->carrier_line); + else fprintf(stderr, "mark_iterator[%d]: has_carrier set (at line %d), but no carrier!\n", __LINE__, iter->carrier_line); #endif - } + } } -static void -mark_input_port (s7_pointer port) { - set_mark (port); - gc_mark (port_string_or_function (port)); +static void mark_input_port(s7_pointer port) +{ + set_mark(port); + gc_mark(port_string_or_function(port)); } -static void -mark_output_port (s7_pointer port) { - set_mark (port); - if (is_function_port (port)) gc_mark (port_string_or_function (port)); +static void mark_output_port(s7_pointer port) +{ + set_mark(port); + if (is_function_port(port)) + gc_mark(port_string_or_function(port)); } -static void -mark_free (s7_pointer p) { - if (S7_DEBUGGING) { - fprintf (stderr, "mark_free!\n"); - abort (); - } -} /* set_mark also checks */ - -static void -init_mark_functions (void) { - mark_function[T_BACRO] = mark_closure; - mark_function[T_BACRO_STAR] = mark_closure; - mark_function[T_BOOLEAN] = mark_noop; - mark_function[T_BYTE_VECTOR] = just_mark; - mark_function[T_CATCH] = mark_catch; - mark_function[T_CHARACTER] = mark_noop; - mark_function[T_CLOSURE] = mark_closure; - mark_function[T_CLOSURE_STAR] = mark_closure; - mark_function[T_COMPLEX] = just_mark; - mark_function[T_COMPLEX_VECTOR]= mark_int_or_float_vector; - mark_function[T_CONTINUATION] = mark_continuation; - mark_function[T_COUNTER] = mark_counter; - 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_MACRO] = just_mark; - mark_function[T_C_OBJECT] = mark_c_object; - mark_function[T_C_POINTER] = mark_c_pointer; - mark_function[T_C_RST_NO_REQ_FUNCTION]= just_mark; - mark_function[T_DYNAMIC_WIND] = mark_dynamic_wind; - mark_function[T_EOF] = mark_noop; - mark_function[T_FLOAT_VECTOR] = mark_int_or_float_vector; - mark_function[T_FREE] = mark_free; - mark_function[T_GOTO] = just_mark; - mark_function[T_HASH_TABLE] = mark_hash_table; - mark_function[T_INPUT_PORT] = mark_input_port; - mark_function[T_INTEGER] = just_mark; - mark_function[T_INT_VECTOR] = mark_int_or_float_vector; - mark_function[T_ITERATOR] = mark_iterator; - mark_function[T_LET] = mark_let; - mark_function[T_MACRO] = mark_closure; - mark_function[T_MACRO_STAR] = mark_closure; - mark_function[T_NIL] = mark_noop; - mark_function[T_OUTPUT_PORT]= - just_mark; /* changed to mark_output_port if output function ports are - active */ - mark_function[T_PAIR] = mark_pair; - mark_function[T_RANDOM_STATE]= just_mark; - mark_function[T_RATIO] = just_mark; - mark_function[T_REAL] = just_mark; - mark_function[T_SLOT] = mark_slot; - mark_function[T_STACK] = mark_stack; - mark_function[T_STRING] = just_mark; - mark_function[T_SYMBOL]= - mark_noop; /* this changes to just_mark when gensyms are in the heap */ - mark_function[T_SYNTAX] = mark_noop; - mark_function[T_UNDEFINED] = just_mark; - mark_function[T_UNSPECIFIED]= mark_noop; - mark_function[T_UNUSED] = mark_noop; - mark_function[T_VECTOR]= - mark_vector; /* this changes if subvector created (similarly below) */ -} - -static void -mark_op_stack (s7_scheme* sc) { - s7_pointer* p = sc->op_stack; - s7_pointer* tp= sc->op_stack_now; +static void mark_free(s7_pointer p) {if (S7_DEBUGGING) {fprintf(stderr, "mark_free!\n"); abort();}} /* set_mark also checks */ + +static void init_mark_functions(void) +{ + mark_function[T_BACRO] = mark_closure; + mark_function[T_BACRO_STAR] = mark_closure; + mark_function[T_BOOLEAN] = mark_noop; + mark_function[T_BYTE_VECTOR] = just_mark; + mark_function[T_CATCH] = mark_catch; + mark_function[T_CHARACTER] = mark_noop; + mark_function[T_CLOSURE] = mark_closure; + mark_function[T_CLOSURE_STAR] = mark_closure; + mark_function[T_COMPLEX] = just_mark; + mark_function[T_COMPLEX_VECTOR] = mark_int_or_float_vector; + mark_function[T_CONTINUATION] = mark_continuation; + mark_function[T_COUNTER] = mark_counter; + 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_MACRO] = just_mark; + mark_function[T_C_OBJECT] = mark_c_object; + mark_function[T_C_POINTER] = mark_c_pointer; + mark_function[T_C_RST_NO_REQ_FUNCTION] = just_mark; + mark_function[T_DYNAMIC_WIND] = mark_dynamic_wind; + mark_function[T_EOF] = mark_noop; + mark_function[T_FLOAT_VECTOR] = mark_int_or_float_vector; + mark_function[T_FREE] = mark_free; + mark_function[T_GOTO] = just_mark; + mark_function[T_HASH_TABLE] = mark_hash_table; + mark_function[T_INPUT_PORT] = mark_input_port; + mark_function[T_INTEGER] = just_mark; + mark_function[T_INT_VECTOR] = mark_int_or_float_vector; + mark_function[T_ITERATOR] = mark_iterator; + mark_function[T_LET] = mark_let; + mark_function[T_MACRO] = mark_closure; + mark_function[T_MACRO_STAR] = mark_closure; + mark_function[T_NIL] = mark_noop; + mark_function[T_OUTPUT_PORT] = just_mark; /* changed to mark_output_port if output function ports are active */ + mark_function[T_PAIR] = mark_pair; + mark_function[T_RANDOM_STATE] = just_mark; + mark_function[T_RATIO] = just_mark; + mark_function[T_REAL] = just_mark; + mark_function[T_SLOT] = mark_slot; + mark_function[T_STACK] = mark_stack; + mark_function[T_STRING] = just_mark; + mark_function[T_SYMBOL] = mark_noop; /* this changes to just_mark when gensyms are in the heap */ + mark_function[T_SYNTAX] = mark_noop; + mark_function[T_UNDEFINED] = just_mark; + mark_function[T_UNSPECIFIED] = mark_noop; + mark_function[T_UNUSED] = mark_noop; + mark_function[T_VECTOR] = mark_vector; /* this changes if subvector created (similarly below) */ +} + +static void mark_op_stack(s7_scheme *sc) +{ + s7_pointer *p = sc->op_stack; + s7_pointer *tp = sc->op_stack_now; while (p < tp) - gc_mark (*p++); -} - -static void -mark_input_port_stack (s7_scheme* sc) { - s7_pointer* tp= - (s7_pointer*) (sc->input_port_stack + sc->input_port_stack_loc); - for (s7_pointer* p= sc->input_port_stack; p < tp; p++) - gc_mark (*p); -} - -static void -mark_rootlet (s7_scheme* sc) { - for (s7_pointer slot= sc->rootlet_slots; is_not_slot_end (slot); - slot = next_slot (slot)) - gc_mark (slot_value ( - slot)); /* slot is semipermanent? does this assume slot_value is not - rootlet? or that rootlet is marked? */ - /* 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). + gc_mark(*p++); +} + +static void mark_input_port_stack(s7_scheme *sc) +{ + s7_pointer *tp = (s7_pointer *)(sc->input_port_stack + sc->input_port_stack_loc); + for (s7_pointer *p = sc->input_port_stack; p < tp; p++) + gc_mark(*p); +} + +static void mark_rootlet(s7_scheme *sc) +{ + for (s7_pointer slot = sc->rootlet_slots; is_not_slot_end(slot); slot = next_slot(slot)) + gc_mark(slot_value(slot)); /* slot is semipermanent? does this assume slot_value is not rootlet? or that rootlet is marked? */ + /* 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). */ } /* 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? + * 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_semipermanent_objects (s7_scheme* sc) { - for (gc_obj_t* g= sc->semipermanent_objects; g; g= (gc_obj_t*) (g->nxt)) - gc_mark (g->p); - /* semipermanent_objects also has lets (removed from heap) -- should they be - * handled like semipermanent_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 semipermanent_lets(slots) than - * semipermanent objects +static void mark_semipermanent_objects(s7_scheme *sc) +{ + for (gc_obj_t *g = sc->semipermanent_objects; g; g = (gc_obj_t *)(g->nxt)) + gc_mark(g->p); + /* semipermanent_objects also has lets (removed from heap) -- should they be handled like semipermanent_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 semipermanent_lets(slots) than semipermanent objects */ } -/* do we mark funclet slot values from the function as root? Maybe treat them - * like semipermanent_lets here? */ +/* do we mark funclet slot values from the function as root? Maybe treat them like semipermanent_lets here? */ -static void -unmark_semipermanent_objects (s7_scheme* sc) { - for (gc_obj_t* g= sc->semipermanent_objects; g; g= (gc_obj_t*) (g->nxt)) - clear_mark (g->p); - for (gc_obj_t* g= sc->semipermanent_lets; g; - g= (gc_obj_t*) (g->nxt)) /* there are lets and slots in this list */ - clear_mark (g->p); +static void unmark_semipermanent_objects(s7_scheme *sc) +{ + for (gc_obj_t *g = sc->semipermanent_objects; g; g = (gc_obj_t *)(g->nxt)) + clear_mark(g->p); + for (gc_obj_t *g = sc->semipermanent_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 + #include + #include #endif #if WITH_GCC -static __attribute__ ((format (printf, 3, 4))) void -s7_warn (s7_scheme* sc, s7_int len, const char* ctrl, ...); +static __attribute__ ((format (printf, 3, 4))) void s7_warn(s7_scheme *sc, s7_int len, const char *ctrl, ...); #else -static void s7_warn (s7_scheme* sc, s7_int len, const char* ctrl, ...); +static void s7_warn(s7_scheme *sc, s7_int len, const char *ctrl, ...); #endif #if S7_DEBUGGING -s7_int -gc (s7_scheme* sc, const char* func, int32_t line) +s7_int gc(s7_scheme *sc, const char *func, int32_t line) #else -s7_int -gc (s7_scheme* sc) +s7_int gc(s7_scheme *sc) #endif { - s7_cell** old_free_heap_top; + s7_cell **old_free_heap_top; if (sc->gc_in_progress) - error_nr (sc, sc->error_symbol, - set_elist_1 (sc, wrap_string (sc, "GC called recursively", 21))); - sc->gc_in_progress= true; - sc->gc_start = my_clock (); + error_nr(sc, sc->error_symbol, set_elist_1(sc, wrap_string(sc, "GC called recursively", 21))); + sc->gc_in_progress = true; + sc->gc_start = my_clock(); sc->gc_calls++; sc->gc_true_calls++; - mark_rootlet (sc); - mark_owlet (sc); - gc_mark (sc->code); - if ((S7_DEBUGGING) && (!(sc->args))) { - fprintf (stderr, "%d: sc->args is NULL\n", __LINE__); - if (sc->stop_at_error) abort (); - } - 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 */ - gc_mark (sc->value); - - mark_stack_1 (sc->stack, stack_top (sc)); - set_mark (current_input_port (sc)); - mark_input_port_stack (sc); - set_mark (current_output_port (sc)); - set_mark (current_error_port (sc)); - mark_pair (sc->stacktrace_defaults); - gc_mark (sc->autoload_table); /* () or a hash-table */ - set_mark (sc->default_random_state); /* always a random_state object */ - gc_mark (sc->temp_error_hook); - - gc_mark (sc->v); - gc_mark (sc->w); - gc_mark (sc->x); - gc_mark (sc->y); - gc_mark (sc->z); - 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); - just_mark (sc->read_dims); - - 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->mlist_1)); - gc_mark (car (sc->mlist_2)); - gc_mark (cadr (sc->mlist_2)); - gc_mark (car (sc->plist_1)); - gc_mark (car (sc->plist_2)); - gc_mark (car (sc->plist_2_2)); - gc_mark (car (sc->plist_3)); - gc_mark (cadr (sc->plist_3)); - gc_mark (caddr (sc->plist_3)); - gc_mark (car (sc->plist_4)); - gc_mark (car (sc->qlist_2)); - gc_mark (cadr (sc->qlist_2)); - gc_mark (car (sc->qlist_3)); - gc_mark (car (sc->u1_1)); - gc_mark (sc->rec_p1); - gc_mark (sc->rec_p2); - - /* these do need to be marked, at least protecting "info" for the duration of - * the error handler procedure */ - for (s7_pointer p= cdr (sc->wrong_type_arg_info); is_pair (p); p= cdr (p)) - gc_mark (car (p)); - for (s7_pointer p= cdr (sc->sole_arg_wrong_type_info); is_pair (p); - p = cdr (p)) - gc_mark (car (p)); - for (s7_pointer p= cdr (sc->out_of_range_info); is_pair (p); p= cdr (p)) - gc_mark (car (p)); - for (s7_pointer p= cdr (sc->sole_arg_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)); - gc_mark (car (sc->elist_3)); - gc_mark (cadr (sc->elist_3)); - gc_mark (caddr (sc->elist_3)); - gc_mark (car (sc->elist_4)); - gc_mark (car (sc->elist_5)); - gc_mark (car (sc->elist_6)); - gc_mark (car (sc->elist_7)); - - for (s7_int i= 1; i < NUM_SAFE_LISTS; - i++) /* see tgen.scm -- we can't just check sc->current_safe_list */ - if ((is_pair (sc->safe_lists[i])) && - (safe_list_is_in_use ( - sc->safe_lists[i]))) /* safe_lists are semipermanent, so we have to - mark contents by hand */ - for (s7_pointer p= sc->safe_lists[i]; is_pair (p); p= cdr (p)) - gc_mark (car (p)); - - for (s7_int i= 0; i < sc->setters_loc; i++) - gc_mark (cdr (sc->setters[i])); - - for (s7_int i= 0; i <= sc->format_depth; - i++) /* sc->num_fdats is size of array */ - if (sc->fdats[i]) gc_mark (sc->fdats[i]->curly_arg); - - if (sc->rec_stack) { - set_mark (sc->rec_stack); - for (s7_int 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); - if ((is_symbol (sc->profile_prefix)) && (is_gensym (sc->profile_prefix))) - set_mark (sc->profile_prefix); - gc_mark (sc->symbol_printer); - - /* 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. + mark_rootlet(sc); + mark_owlet(sc); + gc_mark(sc->code); + if ((S7_DEBUGGING) && (!(sc->args))) {fprintf(stderr, "%d: sc->args is NULL\n", __LINE__); if (sc->stop_at_error) abort();} + 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 */ + gc_mark(sc->value); + + mark_stack_1(sc->stack, stack_top(sc)); + set_mark(current_input_port(sc)); + mark_input_port_stack(sc); + set_mark(current_output_port(sc)); + set_mark(current_error_port(sc)); + mark_pair(sc->stacktrace_defaults); + gc_mark(sc->autoload_table); /* () or a hash-table */ + set_mark(sc->default_random_state); /* always a random_state object */ + gc_mark(sc->temp_error_hook); + + gc_mark(sc->v); + gc_mark(sc->w); + gc_mark(sc->x); + gc_mark(sc->y); + gc_mark(sc->z); + 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); + just_mark(sc->read_dims); + + 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->mlist_1)); + gc_mark(car(sc->mlist_2)); gc_mark(cadr(sc->mlist_2)); + gc_mark(car(sc->plist_1)); + gc_mark(car(sc->plist_2)); gc_mark(car(sc->plist_2_2)); + gc_mark(car(sc->plist_3)); gc_mark(cadr(sc->plist_3)); gc_mark(caddr(sc->plist_3)); gc_mark(car(sc->plist_4)); + gc_mark(car(sc->qlist_2)); gc_mark(cadr(sc->qlist_2)); + gc_mark(car(sc->qlist_3)); + gc_mark(car(sc->u1_1)); + gc_mark(sc->rec_p1); + gc_mark(sc->rec_p2); + + /* these do need to be marked, at least protecting "info" for the duration of the error handler procedure */ + for (s7_pointer p = cdr(sc->wrong_type_arg_info); is_pair(p); p = cdr(p)) gc_mark(car(p)); + for (s7_pointer p = cdr(sc->sole_arg_wrong_type_info); is_pair(p); p = cdr(p)) gc_mark(car(p)); + for (s7_pointer p = cdr(sc->out_of_range_info); is_pair(p); p = cdr(p)) gc_mark(car(p)); + for (s7_pointer p = cdr(sc->sole_arg_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)); + gc_mark(car(sc->elist_3)); gc_mark(cadr(sc->elist_3)); gc_mark(caddr(sc->elist_3)); + gc_mark(car(sc->elist_4)); + gc_mark(car(sc->elist_5)); + gc_mark(car(sc->elist_6)); + gc_mark(car(sc->elist_7)); + + for (s7_int i = 1; i < NUM_SAFE_LISTS; i++) /* see tgen.scm -- we can't just check sc->current_safe_list */ + if ((is_pair(sc->safe_lists[i])) && + (safe_list_is_in_use(sc->safe_lists[i]))) /* safe_lists are semipermanent, so we have to mark contents by hand */ + for (s7_pointer p = sc->safe_lists[i]; is_pair(p); p = cdr(p)) + gc_mark(car(p)); + + for (s7_int i = 0; i < sc->setters_loc; i++) + gc_mark(cdr(sc->setters[i])); + + for (s7_int i = 0; i <= sc->format_depth; i++) /* sc->num_fdats is size of array */ + if (sc->fdats[i]) + gc_mark(sc->fdats[i]->curly_arg); + + if (sc->rec_stack) + { + set_mark(sc->rec_stack); + for (s7_int 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); + if ((is_symbol(sc->profile_prefix)) && (is_gensym(sc->profile_prefix))) set_mark(sc->profile_prefix); + gc_mark(sc->symbol_printer); + + /* 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. */ { - s7_pointer* tmps = sc->free_heap_top; - s7_pointer* tmps_top= tmps + sc->gc_temps_size; + s7_pointer *tmps = sc->free_heap_top; + s7_pointer *tmps_top = tmps + sc->gc_temps_size; if (tmps_top > sc->previous_free_heap_top) - 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_semipermanent_objects (sc); - mark_wrappers (sc); - - if (sc->profiling_gensyms) { - profile_data_t* pd= sc->profile_data; - for (s7_int i= 0; i < pd->top; i++) - if ((pd->funcs[i]) && (is_gensym (pd->funcs[i]))) set_mark (pd->funcs[i]); + gc_mark(*tmps++); } + mark_op_stack(sc); + mark_semipermanent_objects(sc); + mark_wrappers(sc); - { - gc_list_t* gp= sc->opt1_funcs; - for (s7_int i= 0; i < gp->loc; i++) { - s7_pointer gc_obj= T_Pair (gp->list[i]); - if ((is_marked (gc_obj)) && - (!is_marked (opt1_any (gc_obj)))) /* opt1_lambda, but op_unknown* can - change to opt1_cfunc etc */ - gc_mark (opt1_any (gc_obj)); /* not set_mark -- need to protect - let/body/args as well */ + if (sc->profiling_gensyms) + { + profile_data_t *pd = sc->profile_data; + for (s7_int i = 0; i < pd->top; i++) + if ((pd->funcs[i]) && (is_gensym(pd->funcs[i]))) + set_mark(pd->funcs[i]); } - } + + { + gc_list_t *gp = sc->opt1_funcs; + for (s7_int i = 0; i < gp->loc; i++) + { + s7_pointer gc_obj = T_Pair(gp->list[i]); + if ((is_marked(gc_obj)) && (!is_marked(opt1_any(gc_obj)))) /* opt1_lambda, but op_unknown* can change to opt1_cfunc etc */ + gc_mark(opt1_any(gc_obj)); /* not set_mark -- need to protect let/body/args as well */ + }} /* free up all unmarked objects */ - old_free_heap_top= sc->free_heap_top; + old_free_heap_top = sc->free_heap_top; { - s7_pointer* fp = sc->free_heap_top; - s7_pointer* tp = sc->heap; - s7_pointer* heap_top= (s7_pointer*) (sc->heap + sc->heap_size); + s7_pointer *fp = sc->free_heap_top; + s7_pointer *tp = sc->heap; + s7_pointer *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 (has_odd_bits (p)) { \ - char* str; \ - fprintf (stderr, "odd bits: %s\n", str= describe_type_bits (sc, p)); \ - free (str); \ - } \ - if (!in_heap (p)) { \ - char* str; \ - fprintf (stderr, "not in heap: %s\n", str= describe_type_bits (sc, p)); \ - free (str); \ - } \ - clear_type (p); \ - (*fp++)= p; \ - } \ - else if (signed_type (p) < 0) clear_mark (p); + #define gc_object(Tp) \ + p = (*Tp++); \ + if (signed_type(p) > 0) \ + { \ + p->debugger_bits = 0; p->gc_func = func; p->gc_line = line; \ + if (has_odd_bits(p)) {char *str; fprintf(stderr, "odd bits: %s\n", str = describe_type_bits(sc, p)); free(str);} \ + if (!in_heap(p)) {char *str; fprintf(stderr, "not in heap: %s\n", str = describe_type_bits(sc, p)); free(str);} \ + clear_type(p); \ + (*fp++) = p; \ + } \ + else if (signed_type(p) < 0) clear_mark(p); #else -#define gc_object(Tp) \ - p= (*Tp++); \ - if (signed_type (p) > 0) { \ - clear_type (p); \ - (*fp++)= p; \ - } \ - else if (signed_type (p) != 0) clear_mark (p); - /* this appears to be about 10% faster than the previous form, using !=0 is - * about the same as <0 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. - */ + #define gc_object(Tp) p = (*Tp++); if (signed_type(p) > 0) {clear_type(p); (*fp++) = p;} else if (signed_type(p) != 0) clear_mark(p); + /* this appears to be about 10% faster than the previous form, using !=0 is about the same as <0 + * 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 */ - { - s7_pointer p; /* gc_object defined above needs this pointer */ - 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"? + while (tp < heap_top) /* != here or ^ makes no difference, and going to 64 (from 32) doesn't matter */ + { + s7_pointer p; /* gc_object defined above needs this pointer */ + 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); + sc->free_heap_top = fp; + sweep(sc); } - unmark_semipermanent_objects (sc); - unmark_wrappers (sc); + unmark_semipermanent_objects(sc); + unmark_wrappers(sc); - sc->gc_freed= (s7_int) (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); - sc->gc_true_total_time+= (sc->gc_end - sc->gc_start); + sc->gc_freed = (s7_int)(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); + sc->gc_true_total_time += (sc->gc_end - sc->gc_start); - if (show_gc_stats (sc)) { + 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 ()); + 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); + s7_warn(sc, 256, "gc freed %" ld64 "/%" ld64 "\n", sc->gc_freed, sc->heap_size); #endif - } - if (show_protected_objects_stats (sc)) - s7_warn (sc, 256, "gc-protected-objects: %" ld64 " in use of %" ld64 "\n", - sc->protected_objects_size - 1 - - sc->protected_objects_free_list_loc, - sc->protected_objects_size); - sc->previous_free_heap_top= sc->free_heap_top; - sc->gc_in_progress = false; - return (sc->gc_freed); + } + if (show_protected_objects_stats(sc)) + s7_warn(sc, 256, "gc-protected-objects: %" ld64 " in use of %" ld64 "\n", + sc->protected_objects_size - 1 - sc->protected_objects_free_list_loc, + sc->protected_objects_size); + sc->previous_free_heap_top = sc->free_heap_top; + sc->gc_in_progress = false; + return(sc->gc_freed); } + #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 + #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 #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 - */ +/* .5+.1: test -3?, dup +86, tmap +45, tsort -3, thash +305. .85+.7: dup -5 */ #if S7_DEBUGGING -#define resize_heap_to(Sc, Size) resize_heap_to_1 (Sc, Size, __func__, __LINE__) -void -resize_heap_to_1 (s7_scheme* sc, s7_int size, const char* func, int line) +#define resize_heap_to(Sc, Size) resize_heap_to_1(Sc, Size, __func__, __LINE__) +void resize_heap_to_1(s7_scheme *sc, s7_int size, const char *func, int line) #else -void -resize_heap_to (s7_scheme* sc, s7_int size) +void resize_heap_to(s7_scheme *sc, s7_int size) #endif { - const s7_int old_size= sc->heap_size; - const s7_int old_free= sc->free_heap_top - sc->free_heap; + const s7_int old_size = sc->heap_size; + const s7_int old_free = sc->free_heap_top - sc->free_heap; #if S7_DEBUGGING && (!MS_WINDOWS) - if (show_gc_stats (sc)) - s7_warn (sc, 512, - "%s from %s[%d]: old: %" ld64 " / %" ld64 ", new: %" ld64 - ", fraction: %.3f -> %" ld64 "\n", - __func__, func, line, old_free, old_size, size, - sc->gc_resize_heap_fraction, - (s7_int) (floor (sc->heap_size * sc->gc_resize_heap_fraction))); + if (show_gc_stats(sc)) + s7_warn(sc, 512, "%s from %s[%d]: old: %" ld64 " / %" ld64 ", new: %" ld64 ", fraction: %.3f -> %" ld64 "\n", + __func__, func, line, old_free, old_size, size, sc->gc_resize_heap_fraction, (s7_int)(floor(sc->heap_size * sc->gc_resize_heap_fraction))); #endif - if (size == 0) { - if ((old_free < old_size * sc->gc_resize_heap_by_4_fraction) && - (sc->max_heap_size > (sc->heap_size * 4))) - sc->heap_size*= - 4; /* *8 if < 1M (or whatever) doesn't make much difference */ - else sc->heap_size*= 2; - if ((S7_DEBUGGING) && (sc->heap_size >= sc->max_heap_size)) - fprintf (stderr, "%s[%d]: heap_size: %" ld64 ", max: %" ld64 "\n", - __func__, __LINE__, sc->heap_size, sc->max_heap_size); - if (sc->gc_resize_heap_fraction > .4) sc->gc_resize_heap_fraction*= .95; - } - else { - if (size > sc->heap_size) - while (sc->heap_size < size) - sc->heap_size*= 2; - else return; - if ((S7_DEBUGGING) && (sc->heap_size >= sc->max_heap_size)) - fprintf (stderr, "%s[%d]: heap_size: %" ld64 ", max: %" ld64 "\n", - __func__, __LINE__, sc->heap_size, sc->max_heap_size); - } - if (sc->heap_size >= sc->max_heap_size) { - const s7_int new_heap_size= 32 * (s7_int) floor (sc->max_heap_size / 32.0); - if (new_heap_size > old_size) { - s7_warn (sc, 256, - "heap size requested is greater than (*s7* 'max-heap-size); " - "trying %" ld64 "\n", - new_heap_size); - sc->heap_size= new_heap_size; + if (size == 0) + { + if ((old_free < old_size * sc->gc_resize_heap_by_4_fraction) && + (sc->max_heap_size > (sc->heap_size * 4))) + sc->heap_size *= 4; /* *8 if < 1M (or whatever) doesn't make much difference */ + else sc->heap_size *= 2; if ((S7_DEBUGGING) && (sc->heap_size >= sc->max_heap_size)) - fprintf (stderr, "%s[%d]: heap_size: %" ld64 ", max: %" ld64 "\n", - __func__, __LINE__, sc->heap_size, sc->max_heap_size); - } - else { - const s7_int new_size= sc->heap_size; - sc->heap_size= - old_size; /* needed if user catches this error and (for example) runs - (*s7* 'memory-usage) in the error handler */ - error_nr ( - sc, make_symbol (sc, "heap-too-big", 12), - set_elist_3 ( - sc, - wrap_string ( - sc, "heap has grown past (*s7* 'max-heap-size): ~D > ~D", 50), - wrap_integer (sc, new_size), - wrap_integer (sc, sc->max_heap_size))); - return; + fprintf(stderr, "%s[%d]: heap_size: %" ld64 ", max: %" ld64 "\n", __func__, __LINE__, sc->heap_size, sc->max_heap_size); + if (sc->gc_resize_heap_fraction > .4) + sc->gc_resize_heap_fraction *= .95; } - } + else + { + if (size > sc->heap_size) + while (sc->heap_size < size) sc->heap_size *= 2; + else return; + if ((S7_DEBUGGING) && (sc->heap_size >= sc->max_heap_size)) + fprintf(stderr, "%s[%d]: heap_size: %" ld64 ", max: %" ld64 "\n", __func__, __LINE__, sc->heap_size, sc->max_heap_size); + } + if (sc->heap_size >= sc->max_heap_size) + { + const s7_int new_heap_size = 32 * (s7_int)floor(sc->max_heap_size / 32.0); + if (new_heap_size > old_size) + { + s7_warn(sc, 256, "heap size requested is greater than (*s7* 'max-heap-size); trying %" ld64 "\n", new_heap_size); + sc->heap_size = new_heap_size; + if ((S7_DEBUGGING) && (sc->heap_size >= sc->max_heap_size)) + fprintf(stderr, "%s[%d]: heap_size: %" ld64 ", max: %" ld64 "\n", __func__, __LINE__, sc->heap_size, sc->max_heap_size); + } + else + { + const s7_int new_size = sc->heap_size; + sc->heap_size = old_size; /* needed if user catches this error and (for example) runs (*s7* 'memory-usage) in the error handler */ + error_nr(sc, make_symbol(sc, "heap-too-big", 12), + set_elist_3(sc, wrap_string(sc, "heap has grown past (*s7* 'max-heap-size): ~D > ~D", 50), + wrap_integer(sc, new_size), + wrap_integer(sc, sc->max_heap_size))); + return; + }} /* do not call new_cell here! */ #if POINTER_32 - if (((2 * sc->heap_size * sizeof (s7_cell*)) + - ((sc->heap_size - old_size) * sizeof (s7_cell))) >= - SIZE_MAX) { /* can this happen in 64-bit land? SIZE_MAX is unsigned int - in 32-bit, unsigned long in 64 bit = UINTPTR_MAX = - 18446744073709551615UL */ - 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)), - (s7_int) SIZE_MAX); - sc->heap_size= old_size + 64000; - if ((S7_DEBUGGING) && (sc->heap_size >= sc->max_heap_size)) - fprintf (stderr, "%s[%d]: heap_size: %" ld64 ", max: %" ld64 "\n", - __func__, __LINE__, sc->heap_size, sc->max_heap_size); - } + if (((2 * sc->heap_size * sizeof(s7_cell *)) + ((sc->heap_size - old_size) * sizeof(s7_cell))) >= SIZE_MAX) + { /* can this happen in 64-bit land? SIZE_MAX is unsigned int in 32-bit, unsigned long in 64 bit = UINTPTR_MAX = 18446744073709551615UL */ + 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)), + (s7_int)SIZE_MAX); + sc->heap_size = old_size + 64000; + if ((S7_DEBUGGING) && (sc->heap_size >= sc->max_heap_size)) + fprintf(stderr, "%s[%d]: heap_size: %" ld64 ", max: %" ld64 "\n", __func__, __LINE__, sc->heap_size, sc->max_heap_size); + } #endif { - s7_cell** cp= - (s7_cell**) Realloc (sc->heap, sc->heap_size * sizeof (s7_cell*)); - if (cp) sc->heap= cp; + s7_cell **cp = (s7_cell **)Realloc(sc->heap, sc->heap_size * sizeof(s7_cell *)); + if (cp) + sc->heap = cp; else /* can this happen? */ - { - s7_warn (sc, 256, - "heap reallocation failed! tried to get %" ld64 - " bytes (will retry with a smaller amount)\n", - (s7_int) (sc->heap_size * sizeof (s7_cell*))); - sc->heap_size= old_size + 64000; - if ((S7_DEBUGGING) && (sc->heap_size >= sc->max_heap_size)) - fprintf (stderr, "%s[%d]: heap_size: %" ld64 ", max: %" ld64 "\n", - __func__, __LINE__, sc->heap_size, sc->max_heap_size); - 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?!? */ + { + s7_warn(sc, 256, "heap reallocation failed! tried to get %" ld64 " bytes (will retry with a smaller amount)\n", + (s7_int)(sc->heap_size * sizeof(s7_cell *))); + sc->heap_size = old_size + 64000; + if ((S7_DEBUGGING) && (sc->heap_size >= sc->max_heap_size)) + fprintf(stderr, "%s[%d]: heap_size: %" ld64 ", max: %" ld64 "\n", __func__, __LINE__, sc->heap_size, sc->max_heap_size); + 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?!? */ { - s7_cell* cells= (s7_cell*) Calloc ( - sc->heap_size - old_size, - sizeof (s7_cell)); /* Malloc + clear_type below is much slower?! */ - add_saved_pointer (sc, (void*) cells); - { - s7_pointer p= cells; - for (s7_int 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++); - } - } + s7_cell *cells = (s7_cell *)Calloc(sc->heap_size - old_size, sizeof(s7_cell)); /* Malloc + clear_type below is much slower?! */ + add_saved_pointer(sc, (void *)cells); { - heap_block_t* 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; + s7_pointer p = cells; + for (s7_int 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++); + }} + { + heap_block_t *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)) + { + if (size != 0) + s7_warn(sc, 512, "heap grows to %" ld64 " (old free/size: %" ld64 "/%" ld64 ", requested %" ld64 ")\n", + sc->heap_size, old_free, old_size, size); + else s7_warn(sc, 512, "heap grows to %" ld64 " (old free/size: %" ld64 "/%" ld64 ", %.3f)\n", + sc->heap_size, old_free, old_size, sc->gc_resize_heap_fraction); } - } - sc->previous_free_heap_top= sc->free_heap_top; - - if (show_heap_stats (sc)) { - if (size != 0) - s7_warn (sc, 512, - "heap grows to %" ld64 " (old free/size: %" ld64 "/%" ld64 - ", requested %" ld64 ")\n", - sc->heap_size, old_free, old_size, size); - else - s7_warn (sc, 512, - "heap grows to %" ld64 " (old free/size: %" ld64 "/%" ld64 - ", %.3f)\n", - sc->heap_size, old_free, old_size, sc->gc_resize_heap_fraction); - } } -#define resize_heap(Sc) resize_heap_to (Sc, 0) +#define resize_heap(Sc) resize_heap_to(Sc, 0) #if S7_DEBUGGING -#define call_gc(Sc) gc (Sc, __func__, __LINE__) -void -try_to_call_gc_1 (s7_scheme* sc, const char* func, int32_t line) +#define call_gc(Sc) gc(Sc, __func__, __LINE__) +void try_to_call_gc_1(s7_scheme *sc, const char *func, int32_t line) #else -#define call_gc(Sc) gc (Sc) -void -try_to_call_gc (s7_scheme* sc) +#define call_gc(Sc) gc(Sc) +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 */ - { + if (sc->gc_off) /* we can't just return here! Someone needs a new cell, and once the heap free list is exhausted, segfault */ + { #if S7_DEBUGGING - fprintf (stderr, "%s[%d]: forced resize from %s[%d]\n", __func__, __LINE__, - func, line); + fprintf(stderr, "%s[%d]: forced resize from %s[%d]\n", __func__, __LINE__, func, line); #endif - resize_heap (sc); - } - else { - if ((sc->gc_resize_heap_fraction > 0.5) && (sc->heap_size >= 4194304)) - sc->gc_resize_heap_fraction= 0.5; + resize_heap(sc); + } + else + { + if ((sc->gc_resize_heap_fraction > 0.5) && (sc->heap_size >= 4194304)) + sc->gc_resize_heap_fraction = 0.5; #if S7_DEBUGGING - gc (sc, func, line); /* not call_gc! */ - /* describe_gc_strings(sc); */ + gc(sc, func, line); /* not call_gc! */ + /* describe_gc_strings(sc); */ #else - gc (sc); + gc(sc); #endif - if ((s7_int) (sc->free_heap_top - sc->free_heap) < - (sc->heap_size * sc->gc_resize_heap_fraction)) /* changed 21-Jul-22 */ - resize_heap (sc); - } + if ((s7_int)(sc->free_heap_top - sc->free_heap) < (sc->heap_size * sc->gc_resize_heap_fraction)) /* changed 21-Jul-22 */ + resize_heap(sc); + } } -/* 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. - */ + /* 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' (a boolean) is supplied, it turns the GC on or off. \ +static s7_pointer g_gc(s7_scheme *sc, s7_pointer args) +{ + #define H_gc "(gc (on #t)) runs the garbage collector. If 'on' (a boolean) 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) - - set_elist_1 (sc, sc->unused); - set_elist_2 (sc, sc->unused, sc->unused); - set_elist_3 (sc, sc->unused, sc->unused, sc->unused); - set_car (sc->elist_4, sc->unused); - set_car (sc->elist_5, sc->unused); - set_car (sc->elist_6, sc->unused); - set_car (sc->elist_7, sc->unused); /* clist and dlist are weak references */ - if (is_pair (args)) { - if (!is_boolean (car (args))) - return (sole_arg_method_or_bust (sc, car (args), sc->gc_symbol, args, - sc->type_names[T_BOOLEAN])); - sc->gc_off= (car (args) == sc->F); - if (sc->gc_off) return (sc->F); - } - call_gc (sc); - return (sc->unspecified); + #define Q_gc s7_make_signature(sc, 2, sc->T, sc->is_boolean_symbol) + + set_elist_1(sc, sc->unused); + set_elist_2(sc, sc->unused, sc->unused); + set_elist_3(sc, sc->unused, sc->unused, sc->unused); + set_car(sc->elist_4, sc->unused); + set_car(sc->elist_5, sc->unused); + set_car(sc->elist_6, sc->unused); + set_car(sc->elist_7, sc->unused); /* clist and dlist are weak references */ + if (is_pair(args)) + { + if (!is_boolean(car(args))) + return(sole_arg_method_or_bust(sc, car(args), sc->gc_symbol, args, sc->type_names[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 (make_boolean (sc, on)); +s7_pointer s7_gc_on(s7_scheme *sc, bool on) +{ + sc->gc_off = !on; + return(make_boolean(sc, on)); } #if S7_DEBUGGING -static void -check_free_heap_size_1 (s7_scheme* sc, s7_int size, const char* func, - int32_t line) -#define check_free_heap_size(Sc, Size) \ - check_free_heap_size_1 (Sc, Size, __func__, __LINE__) +static void check_free_heap_size_1(s7_scheme *sc, s7_int size, const char *func, int32_t 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) +static void check_free_heap_size(s7_scheme *sc, s7_int size) #endif { - s7_int free_cells= sc->free_heap_top - sc->free_heap; - if (free_cells < size) { + s7_int free_cells = sc->free_heap_top - sc->free_heap; + if (free_cells < size) + { #if S7_DEBUGGING - gc (sc, func, line); + gc(sc, func, line); #else - gc (sc); + gc(sc); #endif - while ((sc->free_heap_top - sc->free_heap) < (s7_int) (size * 1.5)) - resize_heap (sc); - } + while ((sc->free_heap_top - sc->free_heap) < (s7_int)(size * 1.5)) + 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->semipermanent_cells+= ALLOC_POINTER_SIZE; - sc->alloc_pointer_cells= (s7_cell*) Calloc ( - ALLOC_POINTER_SIZE, - sizeof (s7_cell)); /* not Malloc here or below (maybe set full type to 0 - if Malloc) */ - add_saved_pointer (sc, sc->alloc_pointer_cells); - sc->alloc_pointer_k= 0; - } - return (&(sc->alloc_pointer_cells[sc->alloc_pointer_k++])); +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->semipermanent_cells += ALLOC_POINTER_SIZE; + sc->alloc_pointer_cells = (s7_cell *)Calloc(ALLOC_POINTER_SIZE, sizeof(s7_cell)); /* not Malloc here or below (maybe set full type to 0 if Malloc) */ + 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, s7_int loc) { +static s7_big_cell *alloc_big_pointer(s7_scheme *sc, s7_int loc) +{ s7_big_pointer p; - if (sc->alloc_big_pointer_k == ALLOC_BIG_POINTER_SIZE) { - sc->semipermanent_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 + if (sc->alloc_big_pointer_k == ALLOC_BIG_POINTER_SIZE) + { + sc->semipermanent_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); + return(p); } -static void -add_semipermanent_object (s7_scheme* sc, - s7_pointer obj) /* called by remove_from_heap */ +static void add_semipermanent_object(s7_scheme *sc, s7_pointer obj) /* called by remove_from_heap */ { - gc_obj_t* g = (gc_obj_t*) Malloc (sizeof (gc_obj_t)); - g->p = obj; - g->nxt = sc->semipermanent_objects; - sc->semipermanent_objects= g; + gc_obj_t *g = (gc_obj_t *)Malloc(sizeof(gc_obj_t)); + g->p = obj; + g->nxt = sc->semipermanent_objects; + sc->semipermanent_objects = g; } -static void -add_semipermanent_let_or_slot (s7_scheme* sc, s7_pointer obj) { - gc_obj_t* g = (gc_obj_t*) Malloc (sizeof (gc_obj_t)); - g->p = obj; - g->nxt = sc->semipermanent_lets; - sc->semipermanent_lets= g; +static void add_semipermanent_let_or_slot(s7_scheme *sc, s7_pointer obj) +{ + gc_obj_t *g = (gc_obj_t *)Malloc(sizeof(gc_obj_t)); + g->p = obj; + g->nxt = sc->semipermanent_lets; + sc->semipermanent_lets = g; } -static inline s7_pointer -petrify (s7_scheme* sc, s7_pointer x) { - const s7_int loc = heap_location (sc, x); - const s7_pointer p = (s7_pointer) alloc_big_pointer (sc, loc); - sc->heap[loc] = p; - (*(sc->free_heap_top++))= p; - unheap (x); /* set_immutable(x); */ /* if there are GC troubles, this might - catch them? */ - return (x); +static inline s7_pointer petrify(s7_scheme *sc, s7_pointer x) +{ + const s7_int loc = heap_location(sc, x); + const s7_pointer p = (s7_pointer)alloc_big_pointer(sc, loc); + sc->heap[loc] = p; + (*(sc->free_heap_top++)) = p; + unheap(x); /* set_immutable(x); */ /* if there are GC troubles, this might catch them? */ + return(x); } #if S7_DEBUGGING -#define remove_gensym_from_heap(Sc, Gensym) \ - remove_gensym_from_heap_1 (Sc, Gensym, __func__, __LINE__) -static void -remove_gensym_from_heap_1 (s7_scheme* sc, s7_pointer x, const char* func, - int line) +#define remove_gensym_from_heap(Sc, Gensym) remove_gensym_from_heap_1(Sc, Gensym, __func__, __LINE__) +static void remove_gensym_from_heap_1(s7_scheme *sc, s7_pointer x, const char *func, int line) #else -static void -remove_gensym_from_heap ( - s7_scheme* sc, s7_pointer x) /* x known to be a symbol and in the heap */ +static void remove_gensym_from_heap(s7_scheme *sc, s7_pointer x) /* x known to be a symbol and in the heap */ #endif { - const s7_int loc = heap_location (sc, x); - sc->heap[loc] = (s7_pointer) alloc_big_pointer (sc, loc); - (*(sc->free_heap_top++))= sc->heap[loc]; + const s7_int loc = heap_location(sc, x); + sc->heap[loc] = (s7_pointer)alloc_big_pointer(sc, loc); + (*(sc->free_heap_top++)) = sc->heap[loc]; #if S7_DEBUGGING - x->gc_func= func; /* main culprit in s7test/t725 is (essentially) - (symbol->keyword (gensym)) */ - x->gc_line= line; + x->gc_func = func; /* main culprit in s7test/t725 is (essentially) (symbol->keyword (gensym)) */ + x->gc_line = line; #endif - unheap (x); /* set UNHEAP bit in type(x) */ + unheap(x); /* set UNHEAP bit in type(x) */ { - gc_list_t* gp= sc->gensyms; - for (s7_int 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) { - for (s7_int 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; - } - } + gc_list_t *gp = sc->gensyms; + for (s7_int 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) + { + for (s7_int 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; + }} } -static inline void -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 ((!x) || (is_free (x))) return; - if (type_unchecked (x) == T_CHARACTER) { - /* Unicode characters >255 are interned in sc->unicode_chars_table and can - * be shared across multiple syntax trees. Removing them from the heap here - * can double-remove the same cached character when another closure refers - * to it later. - */ - return; - } - if (!in_heap (x)) return; - if (is_pair (x)) /* all the compute time is here, might be faster to go down a - level explicitly */ - { - s7_pointer p= x; - do { - petrify (sc, p); - 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: /* very rare */ - if (is_funclet (x)) set_immutable_let (x); - case T_HASH_TABLE: - case T_VECTOR: - /* not byte|int|float|complex_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_semipermanent_object (sc, x); - return; - case T_SYMBOL: - if (is_gensym (x)) remove_gensym_from_heap (sc, x); - 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_semipermanent_object (sc, x); - return; - default: - break; - } - petrify (sc, x); +static inline void 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 ((!x) || (is_free(x))) return; + if (type_unchecked(x) == T_CHARACTER) + { + /* Unicode characters >255 are interned in sc->unicode_chars_table and can be shared + * across multiple syntax trees. Removing them from the heap here can double-remove the + * same cached character when another closure refers to it later. + */ + return; + } + if (!in_heap(x)) return; + if (is_pair(x)) /* all the compute time is here, might be faster to go down a level explicitly */ + { + s7_pointer p = x; + do { + petrify(sc, p); + 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: /* very rare */ + if (is_funclet(x)) set_immutable_let(x); + case T_HASH_TABLE: + case T_VECTOR: + /* not byte|int|float|complex_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_semipermanent_object(sc, x); + return; + case T_SYMBOL: + if (is_gensym(x)) + remove_gensym_from_heap(sc, x); + 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_semipermanent_object(sc, x); + return; + default: break; + } + petrify(sc, x); } + /* -------------------------------- stacks -------------------------------- */ /* -------- op stack -------- */ @@ -10889,679 +7965,579 @@ remove_from_heap (s7_scheme* sc, s7_pointer x) { #define op_stack_entry(Sc) (*(Sc->op_stack_now - 1)) #if S7_DEBUGGING -static void -push_op_stack (s7_scheme* sc, s7_pointer op) { - (*sc->op_stack_now++)= T_Ext (op); /* not T_App etc -- args can be pushed */ - 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 void push_op_stack(s7_scheme *sc, s7_pointer op) +{ + (*sc->op_stack_now++) = T_Ext(op); /* not T_App etc -- args can be pushed */ + 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= T_Ext (*(--(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_Ext (op)); +static s7_pointer pop_op_stack(s7_scheme *sc) +{ + s7_pointer op = T_Ext(*(--(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_Ext(op)); } #else -#define push_op_stack(Sc, Op) (*Sc->op_stack_now++)= Op -#define pop_op_stack(Sc) (*(--(Sc->op_stack_now))) +#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) { - sc->op_stack= - (s7_pointer*) Malloc (OP_STACK_INITIAL_SIZE * sizeof (s7_pointer)); - sc->op_stack_size= OP_STACK_INITIAL_SIZE; +static void initialize_op_stack(s7_scheme *sc) +{ + 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 (int32_t i= 0; i < OP_STACK_INITIAL_SIZE; i++) - sc->op_stack[i]= sc->unused; + sc->op_stack_end = (s7_pointer *)(sc->op_stack + sc->op_stack_size); + for (int32_t i = 0; i < OP_STACK_INITIAL_SIZE; i++) sc->op_stack[i] = sc->unused; } -static void -resize_op_stack (s7_scheme* sc) { - const uint32_t new_size= sc->op_stack_size * 2; - const uint32_t loc = (uint32_t) (sc->op_stack_now - sc->op_stack); +static void resize_op_stack(s7_scheme *sc) +{ + const uint32_t new_size = sc->op_stack_size * 2; + const uint32_t loc = (uint32_t)(sc->op_stack_now - sc->op_stack); if (new_size > sc->max_stack_size) #if S7_DEBUGGING - { - fprintf (stderr, - "%s%s[%d]: op stack will be too big after resize, %u > %u%s\n", - bold_text, __func__, __LINE__, new_size, sc->max_stack_size, - unbold_text); - if (sc->stop_at_error) abort (); - } + { + fprintf(stderr, "%s%s[%d]: op stack will be too big after resize, %u > %u%s\n", bold_text, __func__, __LINE__, new_size, sc->max_stack_size, unbold_text); + if (sc->stop_at_error) abort(); + } #else - error_nr ( - sc, make_symbol (sc, "stack-too-big", 13), - set_elist_3 ( - sc, - wrap_string ( - sc, "op stack has grown past (*s7* 'max-stack-size): ~D > ~D", - 55), - wrap_integer (sc, (s7_int) new_size), - wrap_integer (sc, (s7_int) sc->max_stack_size))); + error_nr(sc, make_symbol(sc, "stack-too-big", 13), + set_elist_3(sc, wrap_string(sc, "op stack has grown past (*s7* 'max-stack-size): ~D > ~D", 55), + wrap_integer(sc, (s7_int)new_size), + wrap_integer(sc, (s7_int)sc->max_stack_size))); #endif - sc->op_stack= (s7_pointer*) Realloc ((void*) (sc->op_stack), - new_size * sizeof (s7_pointer)); - for (uint32_t i= sc->op_stack_size; i < new_size; i++) - sc->op_stack[i]= sc->unused; - 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); + sc->op_stack = (s7_pointer *)Realloc((void *)(sc->op_stack), new_size * sizeof(s7_pointer)); + for (uint32_t i = sc->op_stack_size; i < new_size; i++) sc->op_stack[i] = sc->unused; + 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); } + /* -------- main stack -------- */ -/* stack_top_code changes. If a function has a tail-call, the stack_top_code - * that form sees if stack_top_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. +/* stack_top_code changes. If a function has a tail-call, the stack_top_code that form sees + * if stack_top_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. */ -#define stack_op(Stack, Loc) ((opcode_t) T_Op (stack_element (Stack, Loc))) -#define stack_args(Stack, Loc) stack_element (Stack, Loc - 1) -#define stack_let(Stack, Loc) stack_element (Stack, Loc - 2) -#define stack_code(Stack, Loc) stack_element (Stack, Loc - 3) -#define set_stack_op(Stack, Loc, Op) \ - stack_element (Stack, Loc)= (s7_pointer) (opcode_t) (Op) - -#define stack_top_op(Sc) ((opcode_t) T_Op (Sc->stack_end[-1])) -#define stack_top_op_unchecked(Sc) ((opcode_t) (Sc->stack_end[-1])) -#define stack_top_args(Sc) (Sc->stack_end[-2]) -#define stack_top_let(Sc) (Sc->stack_end[-3]) -#define stack_top_code(Sc) (Sc->stack_end[-4]) -#define set_stack_top_op(Sc, Op) Sc->stack_end[-1]= (s7_pointer) (opcode_t) (Op) -#define set_stack_top_args(Sc, Args) Sc->stack_end[-2]= Args -#define set_stack_top_code(Sc, Code) Sc->stack_end[-4]= Code +#define stack_op(Stack, Loc) ((opcode_t)T_Op(stack_element(Stack, Loc))) +#define stack_args(Stack, Loc) stack_element(Stack, Loc - 1) +#define stack_let(Stack, Loc) stack_element(Stack, Loc - 2) +#define stack_code(Stack, Loc) stack_element(Stack, Loc - 3) +#define set_stack_op(Stack, Loc, Op) stack_element(Stack, Loc) = (s7_pointer)(opcode_t)(Op) + +#define stack_top_op(Sc) ((opcode_t)T_Op(Sc->stack_end[-1])) +#define stack_top_op_unchecked(Sc) ((opcode_t)(Sc->stack_end[-1])) +#define stack_top_args(Sc) (Sc->stack_end[-2]) +#define stack_top_let(Sc) (Sc->stack_end[-3]) +#define stack_top_code(Sc) (Sc->stack_end[-4]) +#define set_stack_top_op(Sc, Op) Sc->stack_end[-1] = (s7_pointer)(opcode_t)(Op) +#define set_stack_top_args(Sc, Args) Sc->stack_end[-2] = Args +#define set_stack_top_code(Sc, Code) Sc->stack_end[-4] = Code #define stack_end_code(Sc) Sc->stack_end[0] -#define stack_end_let(Sc) Sc->stack_end[1] +#define stack_end_let(Sc) Sc->stack_end[1] #define stack_end_args(Sc) Sc->stack_end[2] -#define stack_end_op(Sc) Sc->stack_end[3] +#define stack_end_op(Sc) Sc->stack_end[3] -void s7_show_stack (s7_scheme* sc); +void s7_show_stack(s7_scheme *sc); #if S7_DEBUGGING -#define pop_stack(Sc) pop_stack_1 (Sc, __func__, __LINE__) -void -pop_stack_1 (s7_scheme* sc, const char* func, int32_t line) { - /* fprintf(stderr, "%s[%d]: pop_stack %s\n", func, line, - * op_names[(opcode_t)stack_top_op(sc)]); */ - 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. +#define pop_stack(Sc) pop_stack_1(Sc, __func__, __LINE__) +void pop_stack_1(s7_scheme *sc, const char *func, int32_t line) +{ + /* fprintf(stderr, "%s[%d]: pop_stack %s\n", func, line, op_names[(opcode_t)stack_top_op(sc)]); */ + 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 (stack_end_code (sc)); - sc->curlet= stack_end_let ( - sc); /* not T_Let|Pos (hence not set_curlet), see op_any_closure_3p_end et - al (stack used to pass args, not curlet) */ - sc->args = stack_end_args (sc); - sc->cur_op= (opcode_t) T_Op (stack_end_op (sc)); - if ((sc->cur_op != OP_GC_PROTECT) && (!is_let (stack_end_let (sc))) && - (!is_null (stack_end_let (sc))) && - (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, int32_t line) { - /* fprintf(stderr, "%s[%d]: pop_stack_no_op %s\n", func, line, - * op_names[(opcode_t)stack_top_op(sc)]); */ - 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 (stack_end_code (sc)); - if ((sc->cur_op != OP_GC_PROTECT) && (!is_let (stack_end_let (sc)))) - fprintf (stderr, "%s[%d]: curlet not a let\n", func, line); - sc->curlet= - stack_end_let (sc); /* not T_Let|Pos: gc_protect can set this directly - (not through push_stack) to anything */ - sc->args= stack_end_args (sc); -} - -void -push_stack_1 (s7_scheme* sc, opcode_t op, s7_pointer args, s7_pointer code, - s7_pointer* end, const char* func, int32_t line) { - /* fprintf(stderr, "%s[%d]: %u push_stack %s\n", func, line, - * (uint32_t)((intptr_t)(sc->stack_end - sc->stack_start)), op_names[op]); */ - if ((SHOW_EVAL_OPS) && (op == OP_EVAL_DONE)) - fprintf (stderr, " %s[%d]: push eval_done\n", func, line); - if (sc->stack_end >= sc->stack_start + sc->stack_size) { - fprintf ( - stderr, "%s%s[%d]: stack overflow, %u > %u, trigger: %u %s\n", - bold_text, func, line, - (uint32_t) ((intptr_t) (sc->stack_end - sc->stack_start)), - sc->stack_size, - (uint32_t) ((intptr_t) (sc->stack_resize_trigger - sc->stack_start)), - unbold_text); - s7_show_stack (sc); - if (sc->stop_at_error) abort (); - } - if (sc->stack_end >= sc->stack_resize_trigger) { - fprintf (stderr, - "%s%s[%d] from %s: stack resize skipped, stack at %u of %u %s%s\n", - bold_text, func, line, op_names[op], - (uint32_t) ((intptr_t) (sc->stack_end - sc->stack_start)), - sc->stack_size, display_truncated (code), unbold_text); - s7_show_stack (sc); - } + sc->code = T_Pos(stack_end_code(sc)); + sc->curlet = stack_end_let(sc); /* not T_Let|Pos (hence not set_curlet), see op_any_closure_3p_end et al (stack used to pass args, not curlet) */ + sc->args = stack_end_args(sc); + sc->cur_op = (opcode_t)T_Op(stack_end_op(sc)); + if ((sc->cur_op != OP_GC_PROTECT) && + (!is_let(stack_end_let(sc))) && (!is_null(stack_end_let(sc))) && + (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, int32_t line) +{ + /* fprintf(stderr, "%s[%d]: pop_stack_no_op %s\n", func, line, op_names[(opcode_t)stack_top_op(sc)]); */ + 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(stack_end_code(sc)); + if ((sc->cur_op != OP_GC_PROTECT) && (!is_let(stack_end_let(sc)))) + fprintf(stderr, "%s[%d]: curlet not a let\n", func, line); + sc->curlet = stack_end_let(sc); /* not T_Let|Pos: gc_protect can set this directly (not through push_stack) to anything */ + sc->args = stack_end_args(sc); +} + +void push_stack_1(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer code, s7_pointer *end, const char *func, int32_t line) +{ + /* fprintf(stderr, "%s[%d]: %u push_stack %s\n", func, line, (uint32_t)((intptr_t)(sc->stack_end - sc->stack_start)), op_names[op]); */ + if ((SHOW_EVAL_OPS) && (op == OP_EVAL_DONE)) fprintf(stderr, " %s[%d]: push eval_done\n", func, line); + if (sc->stack_end >= sc->stack_start + sc->stack_size) + { + fprintf(stderr, "%s%s[%d]: stack overflow, %u > %u, trigger: %u %s\n", + bold_text, func, line, + (uint32_t)((intptr_t)(sc->stack_end - sc->stack_start)), sc->stack_size, + (uint32_t)((intptr_t)(sc->stack_resize_trigger - sc->stack_start)), + unbold_text); + s7_show_stack(sc); + if (sc->stop_at_error) abort(); + } + if (sc->stack_end >= sc->stack_resize_trigger) + { + fprintf(stderr, "%s%s[%d] from %s: stack resize skipped, stack at %u of %u %s%s\n", + bold_text, func, line, op_names[op], + (uint32_t)((intptr_t)(sc->stack_end - sc->stack_start)), + sc->stack_size, display_truncated(code), unbold_text); + s7_show_stack(sc); + } 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) stack_end_code (sc)= T_Pos (code); - stack_end_let (sc)= T_Let (sc->curlet); - if ((args) && (!is_free (args))) stack_end_args (sc)= T_Pos (args); - stack_end_op (sc)= (s7_pointer) op; - sc->stack_end+= 4; -} - -#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) + 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) stack_end_code(sc) = T_Pos(code); + stack_end_let(sc) = T_Let(sc->curlet); + if ((args) && (!is_free(args))) stack_end_args(sc) = T_Pos(args); + stack_end_op(sc) = (s7_pointer)op; + sc->stack_end += 4; +} + +#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) -#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 */ +#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) \ - do { \ - Sc->stack_end-= 4; \ - memcpy ((void*) Sc, (void*) (Sc->stack_end), 3 * sizeof (s7_pointer)); \ - } while (0) +#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) do {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 { \ - stack_end_code (Sc)= Code; \ - stack_end_let (Sc) = Sc->curlet; \ - stack_end_args (Sc)= Args; \ - stack_end_op (Sc) = (s7_pointer) (opcode_t) (Op); \ - Sc->stack_end+= 4; \ +#define push_stack(Sc, Op, Args, Code) \ + do { \ + stack_end_code(Sc) = Code; \ + stack_end_let(Sc) = Sc->curlet; \ + stack_end_args(Sc) = Args; \ + stack_end_op(Sc) = (s7_pointer)(opcode_t)(Op); \ + Sc->stack_end += 4; \ } while (0) -#define push_stack_direct(Sc, Op) \ - do { \ - Sc->cur_op= Op; \ - memcpy ((void*) (Sc->stack_end), (void*) Sc, 4 * sizeof (s7_pointer)); \ - /* stack_end_op(Sc) = (s7_pointer)(opcode_t)(Op); */ \ - Sc->stack_end+= 4; \ +#define push_stack_direct(Sc, Op) \ + do { \ + Sc->cur_op = Op; \ + memcpy((void *)(Sc->stack_end), (void *)Sc, 4 * sizeof(s7_pointer)); \ + /* stack_end_op(Sc) = (s7_pointer)(opcode_t)(Op); */ \ + Sc->stack_end += 4; \ } while (0) -/* is this faster with cur_op because of the cast to s7_pointer, or is callgrind - * messing up memcpy stats? time's output is all over the map. I think the - * cur_op form should be slower, but callgrind disagrees. +/* is this faster with cur_op because of the cast to s7_pointer, or is callgrind messing up memcpy stats? + * time's output is all over the map. I think the cur_op form should be slower, but callgrind disagrees. */ -#define push_stack_no_code(Sc, Op, Args) \ - do { \ - stack_end_let (Sc) = Sc->curlet; \ - stack_end_args (Sc)= Args; \ - stack_end_op (Sc) = (s7_pointer) (opcode_t) (Op); \ - Sc->stack_end+= 4; \ +#define push_stack_no_code(Sc, Op, Args) \ + do { \ + stack_end_let(Sc) = Sc->curlet; \ + stack_end_args(Sc) = Args; \ + stack_end_op(Sc) = (s7_pointer)(opcode_t)(Op); \ + Sc->stack_end += 4; \ } while (0) -#define push_stack_no_let_no_code(Sc, Op, Args) \ - do { \ - stack_end_args (Sc)= Args; \ - stack_end_op (Sc) = (s7_pointer) (opcode_t) (Op); \ - Sc->stack_end+= 4; \ +#define push_stack_no_let_no_code(Sc, Op, Args) \ + do { \ + stack_end_args(Sc) = Args; \ + stack_end_op(Sc) = (s7_pointer)(opcode_t)(Op); \ + Sc->stack_end += 4; \ } while (0) -#define push_stack_no_args(Sc, Op, Code) \ - do { \ - stack_end_code (Sc)= Code; \ - stack_end_let (Sc) = Sc->curlet; \ - stack_end_op (Sc) = (s7_pointer) (opcode_t) (Op); \ - Sc->stack_end+= 4; \ +#define push_stack_no_args(Sc, Op, Code) \ + do { \ + stack_end_code(Sc) = Code; \ + stack_end_let(Sc) = Sc->curlet; \ + stack_end_op(Sc) = (s7_pointer)(opcode_t)(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)); \ - stack_end_op (Sc)= (s7_pointer) (opcode_t) (Op); \ - Sc->stack_end+= 4; \ +#define push_stack_no_args_direct(Sc, Op) \ + do { \ + memcpy((void *)(Sc->stack_end), (void *)Sc, 2 * sizeof(s7_pointer)); \ + stack_end_op(Sc) = (s7_pointer)(opcode_t)(Op); \ + Sc->stack_end += 4; \ } while (0) -#define push_stack_no_let(Sc, Op, Args, Code) \ - do { \ - stack_end_code (Sc)= Code; \ - stack_end_args (Sc)= Args; \ - stack_end_op (Sc) = (s7_pointer) (opcode_t) (Op); \ - Sc->stack_end+= 4; \ +#define push_stack_no_let(Sc, Op, Args, Code) \ + do { \ + stack_end_code(Sc) = Code; \ + stack_end_args(Sc) = Args; \ + stack_end_op(Sc) = (s7_pointer)(opcode_t)(Op); \ + Sc->stack_end += 4; \ } while (0) -#define push_stack_op(Sc, Op) \ - do { \ - stack_end_op (Sc)= (s7_pointer) (opcode_t) (Op); \ - Sc->stack_end+= 4; \ +#define push_stack_op(Sc, Op) \ + do { \ + stack_end_op(Sc) = (s7_pointer)(opcode_t)(Op); \ + Sc->stack_end += 4; \ } while (0) -#define push_stack_op_let(Sc, Op) \ - do { \ - stack_end_let (Sc)= Sc->curlet; \ - stack_end_op (Sc) = (s7_pointer) (opcode_t) (Op); \ - Sc->stack_end+= 4; \ +#define push_stack_op_let(Sc, Op) \ + do { \ + stack_end_let(Sc) = Sc->curlet; \ + stack_end_op(Sc) = (s7_pointer)(opcode_t)(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. +/* 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_with(Sc, Op) unstack_1 (Sc, Op, __func__, __LINE__) -static void -unstack_1 (s7_scheme* sc, opcode_t op, const char* func, int32_t line) { - sc->stack_end-= 4; - if ((opcode_t) T_Op (stack_end_op (sc)) != op) { - fprintf (stderr, "%s%s[%d]: popped %s? (expected %s)%s\n", bold_text, func, - line, op_names[(opcode_t) T_Op (stack_end_op (sc))], op_names[op], - unbold_text); - /* "popped apply" means we called something that went to eval+apply when we - * thought it was a safe function */ - fprintf (stderr, " code: %s\n args: %s\n", display (sc->code), - display (sc->args)); - fprintf (stderr, " cur_code: %s\n estr: %s\n", - display (current_code (sc)), - display (s7_name_to_value (sc, "estr"))); - s7_show_stack (sc); - if (sc->stop_at_error) abort (); - } +#define unstack_with(Sc, Op) unstack_1(Sc, Op, __func__, __LINE__) +void unstack_1(s7_scheme *sc, opcode_t op, const char *func, int32_t line) +{ + sc->stack_end -= 4; + if ((opcode_t)T_Op(stack_end_op(sc)) != op) + { + fprintf(stderr, "%s%s[%d]: popped %s? (expected %s)%s\n", bold_text, func, line, op_names[(opcode_t)T_Op(stack_end_op(sc))], op_names[op], unbold_text); + /* "popped apply" means we called something that went to eval+apply when we thought it was a safe function */ + fprintf(stderr, " code: %s\n args: %s\n", display(sc->code), display(sc->args)); + fprintf(stderr, " cur_code: %s\n estr: %s\n", display(current_code(sc)), display(s7_name_to_value(sc, "estr"))); + s7_show_stack(sc); + if (sc->stop_at_error) abort(); + } } -#define unstack_gc_protect(Sc) unstack_with (Sc, OP_GC_PROTECT) +#define unstack_gc_protect(Sc) unstack_with(Sc, OP_GC_PROTECT) #else -#define unstack_gc_protect(Sc) Sc->stack_end-= 4 -#define unstack_with(Sc, op) Sc->stack_end-= 4 +#define unstack_gc_protect(Sc) Sc->stack_end -= 4 +#define unstack_with(Sc, op) Sc->stack_end -= 4 #endif -static void -stack_reset (s7_scheme* sc) { - sc->stack_end= sc->stack_start; - push_stack_op (sc, OP_EVAL_DONE); -} - -static uint32_t -resize_stack_unchecked (s7_scheme* sc) { - const s7_uint loc = stack_top (sc); - const uint32_t new_size= sc->stack_size * 2; - block_t* old_b = stack_block (sc->stack); - block_t* new_b= reallocate (sc, old_b, new_size * sizeof (s7_pointer)); - block_info (new_b) = NULL; - stack_block (sc->stack) = new_b; - stack_elements (sc->stack)= (s7_pointer*) block_data (new_b); +static void stack_reset(s7_scheme *sc) +{ + sc->stack_end = sc->stack_start; + push_stack_op(sc, OP_EVAL_DONE); +} + +static uint32_t resize_stack_unchecked(s7_scheme *sc) +{ + const s7_uint loc = stack_top(sc); + const uint32_t new_size = sc->stack_size * 2; + block_t *old_b = stack_block(sc->stack); + block_t *new_b = reallocate(sc, old_b, new_size * sizeof(s7_pointer)); + block_info(new_b) = NULL; + stack_block(sc->stack) = new_b; + stack_elements(sc->stack) = (s7_pointer *)block_data(new_b); { - s7_pointer* orig= stack_elements (sc->stack); - s7_int i = sc->stack_size; - const s7_int left= new_size - i - 8; + s7_pointer *orig = stack_elements(sc->stack); + s7_int i = sc->stack_size; + const s7_int left = new_size - i - 8; while (i <= left) - LOOP_8 (orig[i++]= sc->unused); + LOOP_8(orig[i++] = sc->unused); for (; i < new_size; i++) - orig[i]= sc->unused; + orig[i] = sc->unused; } - 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 + (new_size - STACK_RESIZE_TRIGGER)); - return (new_size); + 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 + (new_size - STACK_RESIZE_TRIGGER)); + return(new_size); } -void -s7_show_stack (s7_scheme* sc) { - if (sc->stack_end >= sc->stack_resize_trigger) resize_stack_unchecked (sc); - fprintf (stderr, "stack:\n"); - for (s7_int op_loc= stack_top (sc) - 1, j= 0; - (op_loc >= 3) && (j < sc->max_show_stack_frames); - op_loc-= 4, j++) /* s7_int (or s7_uint?) is correct -- not uint32_t */ - fprintf (stderr, " %s\n", op_names[stack_op (sc->stack, op_loc)]); +void s7_show_stack(s7_scheme *sc) +{ + if (sc->stack_end >= sc->stack_resize_trigger) + resize_stack_unchecked(sc); + fprintf(stderr, "stack:\n"); + for (s7_int op_loc = stack_top(sc) - 1, j = 0; (op_loc >= 3) && (j < sc->max_show_stack_frames); op_loc -= 4, j++) /* s7_int (or s7_uint?) is correct -- not uint32_t */ + fprintf(stderr, " %s\n", op_names[stack_op(sc->stack, op_loc)]); } #if S7_DEBUGGING -void s7_show_full_stack (s7_scheme* sc); -void -s7_show_full_stack (s7_scheme* sc) { - const bool old_stop= sc->stop_at_error; - if (sc->stack_end >= sc->stack_resize_trigger) resize_stack_unchecked (sc); - sc->stop_at_error= false; - fprintf (stderr, "stack:\n"); - for (s7_int op_loc= stack_top (sc) - 1, j= 0; - (op_loc >= 3) && (j < sc->max_show_stack_frames); op_loc-= 4, j++) { - fprintf (stderr, " %s: ", op_names[stack_op (sc->stack, op_loc)]); - if (s7_is_valid (sc, stack_code (sc->stack, op_loc))) - fprintf (stderr, "code: %s, ", - display_truncated (stack_code (sc->stack, op_loc))); - if (s7_is_valid (sc, stack_args (sc->stack, op_loc))) - fprintf (stderr, "args: %s, ", - display_truncated (stack_args (sc->stack, op_loc))); - if ((stack_op (sc->stack, op_loc) != OP_GC_PROTECT) && - (s7_is_valid ( - sc, stack_let (sc->stack, op_loc)))) /* this probably won't work */ - fprintf (stderr, "let: %s", - display_truncated (stack_let (sc->stack, op_loc))); - fprintf (stderr, "\n"); - } - sc->stop_at_error= old_stop; -} - -#define resize_stack(Sc) resize_stack_1 (Sc, __func__, __LINE__) -static void -resize_stack_1 (s7_scheme* sc, const char* func, int line) { - if ((sc->stack_size * 2) > sc->max_stack_size) { - fprintf ( - stderr, - "%s%s[%d]: stack will be too big after resize, %u > %u, trigger: %" ld64 - "%s\n", - bold_text, func, line, sc->stack_size * 2, sc->max_stack_size, - (s7_int) ((intptr_t) (sc->stack_resize_trigger - sc->stack_start)), - unbold_text); - s7_show_stack (sc); - if (sc->stop_at_error) abort (); - } - resize_stack_unchecked (sc); +void s7_show_full_stack(s7_scheme *sc); +void s7_show_full_stack(s7_scheme *sc) +{ + const bool old_stop = sc->stop_at_error; + if (sc->stack_end >= sc->stack_resize_trigger) + resize_stack_unchecked(sc); + sc->stop_at_error = false; + fprintf(stderr, "stack:\n"); + for (s7_int op_loc = stack_top(sc) - 1, j = 0; (op_loc >= 3) && (j < sc->max_show_stack_frames); op_loc -= 4, j++) + { + fprintf(stderr, " %s: ", op_names[stack_op(sc->stack, op_loc)]); + if (s7_is_valid(sc, stack_code(sc->stack, op_loc))) + fprintf(stderr, "code: %s, ", display_truncated(stack_code(sc->stack, op_loc))); + if (s7_is_valid(sc, stack_args(sc->stack, op_loc))) + fprintf(stderr, "args: %s, ", display_truncated(stack_args(sc->stack, op_loc))); + if ((stack_op(sc->stack, op_loc) != OP_GC_PROTECT) && (s7_is_valid(sc, stack_let(sc->stack, op_loc)))) /* this probably won't work */ + fprintf(stderr, "let: %s", display_truncated(stack_let(sc->stack, op_loc))); + fprintf(stderr, "\n"); + } + sc->stop_at_error = old_stop; +} + +#define resize_stack(Sc) resize_stack_1(Sc, __func__, __LINE__) +void resize_stack_1(s7_scheme *sc, const char *func, int line) +{ + if ((sc->stack_size * 2) > sc->max_stack_size) + { + fprintf(stderr, "%s%s[%d]: stack will be too big after resize, %u > %u, trigger: %" ld64 "%s\n", + bold_text, func, line, sc->stack_size * 2, sc->max_stack_size, + (s7_int)((intptr_t)(sc->stack_resize_trigger - sc->stack_start)), + unbold_text); + s7_show_stack(sc); + if (sc->stop_at_error) abort(); + } + resize_stack_unchecked(sc); } #else -static void -resize_stack (s7_scheme* sc) { - const uint32_t new_size= resize_stack_unchecked (sc); - if (show_stack_stats (sc)) s7_warn (sc, 128, "stack grows to %u\n", new_size); +void resize_stack(s7_scheme *sc) +{ + const uint32_t new_size = resize_stack_unchecked(sc); + if (show_stack_stats(sc)) + s7_warn(sc, 128, "stack grows to %u\n", new_size); if (new_size > sc->max_stack_size) - error_nr ( - sc, make_symbol (sc, "stack-too-big", 13), - set_elist_3 ( - sc, - wrap_string ( - sc, "stack has grown past (*s7* 'max-stack-size): ~D > ~D", 52), - wrap_integer (sc, new_size), - wrap_integer (sc, sc->max_stack_size))); - /* error needs to follow realloc, else error -> catchers in error_nr -> - * let_temp* -> eval_done -> stack_resize -> infinite loop */ + error_nr(sc, make_symbol(sc, "stack-too-big", 13), + set_elist_3(sc, wrap_string(sc, "stack has grown past (*s7* 'max-stack-size): ~D > ~D", 52), + wrap_integer(sc, new_size), + wrap_integer(sc, sc->max_stack_size))); + /* error needs to follow realloc, else error -> catchers in error_nr -> let_temp* -> eval_done -> stack_resize -> infinite loop */ } #endif -#define check_stack_size(Sc) \ - do { \ - if (Sc->stack_end >= Sc->stack_resize_trigger) resize_stack (Sc); \ - } while (0) +#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) { - check_stack_size (sc); /* this can be called externally, so we need to be - careful about this */ - push_stack_no_code (sc, OP_GC_PROTECT, x); - return (x); +s7_pointer s7_gc_protect_via_stack(s7_scheme *sc, s7_pointer x) +{ + check_stack_size(sc); /* this can be called externally, so we need to be careful about this */ + push_stack_no_code(sc, OP_GC_PROTECT, x); + return(x); } -s7_pointer -s7_gc_protect_2_via_stack (s7_scheme* sc, s7_pointer x, s7_pointer y) { - check_stack_size (sc); - push_stack (sc, OP_GC_PROTECT, x, y); - return (x); +s7_pointer s7_gc_protect_2_via_stack(s7_scheme *sc, s7_pointer x, s7_pointer y) +{ + check_stack_size(sc); + push_stack(sc, OP_GC_PROTECT, x, y); + return(x); } -s7_pointer -s7_gc_unprotect_via_stack (s7_scheme* sc, s7_pointer x) { - unstack_gc_protect ( - sc); /* this might not be related to 'x' -- something got unprotected */ - return (x); +s7_pointer s7_gc_unprotect_via_stack(s7_scheme *sc, s7_pointer x) +{ + unstack_gc_protect(sc); /* this might not be related to 'x' -- something got unprotected */ + return(x); } #if S7_DEBUGGING -static s7_pointer -stack_protected1_1 (s7_scheme* sc, opcode_t op, const char* func, int line) { - if (stack_top_op (sc) != op) { - fprintf (stderr, "%s[%d]: stack_protected1 %s\n", func, line, - op_names[stack_top_op (sc)]); - if (sc->stop_at_error) abort (); + static s7_pointer stack_protected1_1(s7_scheme *sc, opcode_t op, const char *func, int line) + { + if (stack_top_op(sc) != op) + { + fprintf(stderr, "%s[%d]: stack_protected1 %s\n", func, line, op_names[stack_top_op(sc)]); + if (sc->stop_at_error) abort(); + } + return(stack_top_args(sc)); } - return (stack_top_args (sc)); -} -static s7_pointer -stack_protected2_1 (s7_scheme* sc, opcode_t op, const char* func, int line) { - if (stack_top_op (sc) != op) { - fprintf (stderr, "%s[%d]: stack_protected2 %s\n", func, line, - op_names[stack_top_op (sc)]); - if (sc->stop_at_error) abort (); + static s7_pointer stack_protected2_1(s7_scheme *sc, opcode_t op, const char *func, int line) + { + if (stack_top_op(sc) != op) + { + fprintf(stderr, "%s[%d]: stack_protected2 %s\n", func, line, op_names[stack_top_op(sc)]); + if (sc->stop_at_error) abort(); + } + return(stack_top_code(sc)); } - return (stack_top_code (sc)); -} -static s7_pointer -stack_protected3_1 (s7_scheme* sc, opcode_t op, const char* func, int line) { - if (stack_top_op (sc) != op) { - fprintf (stderr, "%s[%d]: stack_protected3 %s\n", func, line, - op_names[stack_top_op (sc)]); - if (sc->stop_at_error) abort (); - } - return (stack_top_let (sc)); -} + static s7_pointer stack_protected3_1(s7_scheme *sc, opcode_t op, const char *func, int line) + { + if (stack_top_op(sc) != op) + { + fprintf(stderr, "%s[%d]: stack_protected3 %s\n", func, line, op_names[stack_top_op(sc)]); + if (sc->stop_at_error) abort(); + } + return(stack_top_let(sc)); + } -#define stack_protected1(Sc, Op) stack_protected1_1 (Sc, Op, __func__, __LINE__) -#define stack_protected2(Sc, Op) stack_protected2_1 (Sc, Op, __func__, __LINE__) -#define stack_protected3(Sc, Op) stack_protected3_1 (Sc, Op, __func__, __LINE__) + #define stack_protected1(Sc, Op) stack_protected1_1(Sc, Op, __func__, __LINE__) + #define stack_protected2(Sc, Op) stack_protected2_1(Sc, Op, __func__, __LINE__) + #define stack_protected3(Sc, Op) stack_protected3_1(Sc, Op, __func__, __LINE__) -#define set_stack_protected1(Sc, Val, Op) \ - do { \ - if (stack_top_op (Sc) != Op) \ - fprintf (stderr, "%s[%d]: set_stack_protected1 %s\n", __func__, \ - __LINE__, op_names[stack_top_op (Sc)]); \ - stack_top_args (Sc)= Val; \ - } while (0) -#define set_stack_protected2(Sc, Val, Op) \ - do { \ - if (stack_top_op (Sc) != Op) \ - fprintf (stderr, "%s[%d]: set_stack_protected2 %s\n", __func__, \ - __LINE__, op_names[stack_top_op (Sc)]); \ - stack_top_code (Sc)= Val; \ - } while (0) -#define set_stack_protected3(Sc, Val, Op) \ - do { \ - if (stack_top_op (Sc) != Op) \ - fprintf (stderr, "%s[%d]: set_stack_protected3 %s\n", __func__, \ - __LINE__, op_names[stack_top_op (Sc)]); \ - stack_top_let (Sc)= Val; \ - } while (0) + #define set_stack_protected1(Sc, Val, Op) do {if (stack_top_op(Sc) != Op) fprintf(stderr, "%s[%d]: set_stack_protected1 %s\n", __func__, __LINE__, op_names[stack_top_op(Sc)]); stack_top_args(Sc) = Val;} while (0) + #define set_stack_protected2(Sc, Val, Op) do {if (stack_top_op(Sc) != Op) fprintf(stderr, "%s[%d]: set_stack_protected2 %s\n", __func__, __LINE__, op_names[stack_top_op(Sc)]); stack_top_code(Sc) = Val;} while (0) + #define set_stack_protected3(Sc, Val, Op) do {if (stack_top_op(Sc) != Op) fprintf(stderr, "%s[%d]: set_stack_protected3 %s\n", __func__, __LINE__, op_names[stack_top_op(Sc)]); stack_top_let(Sc) = Val;} while (0) #else -#define stack_protected1(Sc, Op) stack_top_args (Sc) -#define stack_protected2(Sc, Op) stack_top_code (Sc) -#define stack_protected3(Sc, Op) stack_top_let (Sc) + #define stack_protected1(Sc, Op) stack_top_args(Sc) + #define stack_protected2(Sc, Op) stack_top_code(Sc) + #define stack_protected3(Sc, Op) stack_top_let(Sc) -#define set_stack_protected1(Sc, Val, Op) stack_top_args (Sc)= Val -#define set_stack_protected2(Sc, Val, Op) stack_top_code (Sc)= Val -#define set_stack_protected3(Sc, Val, Op) stack_top_let (Sc)= Val + #define set_stack_protected1(Sc, Val, Op) stack_top_args(Sc) = Val + #define set_stack_protected2(Sc, Val, Op) stack_top_code(Sc) = Val + #define set_stack_protected3(Sc, Val, Op) stack_top_let(Sc) = Val #endif -#define gc_protected1(Sc) stack_protected1 (Sc, OP_GC_PROTECT) -#define gc_protected2(Sc) stack_protected2 (Sc, OP_GC_PROTECT) -#define gc_protected3(Sc) stack_protected3 (Sc, OP_GC_PROTECT) - -#define set_gc_protected1(Sc, Val) set_stack_protected1 (Sc, Val, OP_GC_PROTECT) -#define set_gc_protected2(Sc, Val) set_stack_protected2 (Sc, Val, OP_GC_PROTECT) -#define set_gc_protected3(Sc, Val) set_stack_protected3 (Sc, Val, OP_GC_PROTECT) - -#define map_unwind_list(Sc) stack_protected3 (Sc, OP_MAP_UNWIND) -#define set_map_unwind_list(Sc, Val) \ - set_stack_protected3 (Sc, Val, OP_MAP_UNWIND) - -#define gc_protect_via_stack(Sc, Obj) \ - push_stack_no_code (Sc, OP_GC_PROTECT, Obj) -#define gc_protect_via_stack_no_let(Sc, Obj) \ - push_stack_no_let_no_code (Sc, OP_GC_PROTECT, Obj) -#define gc_protect_2_via_stack(Sc, X, Y) \ - do { \ - gc_protect_via_stack (Sc, X); \ - set_gc_protected2 (Sc, Y); \ - } while (0) -/* often X and Y are fx_calls, so push X, then set Y */ -#define gc_protect_2_via_stack_no_let(Sc, X, Y) \ - do { \ - push_stack_no_let_no_code (Sc, OP_GC_PROTECT, X); \ - set_gc_protected2 (Sc, Y); \ - } while (0) +#define gc_protected1(Sc) stack_protected1(Sc, OP_GC_PROTECT) +#define gc_protected2(Sc) stack_protected2(Sc, OP_GC_PROTECT) +#define gc_protected3(Sc) stack_protected3(Sc, OP_GC_PROTECT) + +#define set_gc_protected1(Sc, Val) set_stack_protected1(Sc, Val, OP_GC_PROTECT) +#define set_gc_protected2(Sc, Val) set_stack_protected2(Sc, Val, OP_GC_PROTECT) +#define set_gc_protected3(Sc, Val) set_stack_protected3(Sc, Val, OP_GC_PROTECT) + +#define map_unwind_list(Sc) stack_protected3(Sc, OP_MAP_UNWIND) +#define set_map_unwind_list(Sc, Val) set_stack_protected3(Sc, Val, OP_MAP_UNWIND) + +#define gc_protect_via_stack(Sc, Obj) push_stack_no_code(Sc, OP_GC_PROTECT, Obj) +#define gc_protect_via_stack_no_let(Sc, Obj) push_stack_no_let_no_code(Sc, OP_GC_PROTECT, Obj) +#define gc_protect_2_via_stack(Sc, X, Y) do {gc_protect_via_stack(Sc, X); set_gc_protected2(Sc, Y);} while (0) + /* often X and Y are fx_calls, so push X, then set Y */ +#define gc_protect_2_via_stack_no_let(Sc, X, Y) do {push_stack_no_let_no_code(Sc, OP_GC_PROTECT, X); set_gc_protected2(Sc, Y);} while (0) + /* -------------------------------- symbols -------------------------------- */ -static inline s7_uint -raw_string_hash (const uint8_t* key, - s7_int len) /* used in symbols, hash-tables */ -{ - if (len <= 8) { - s7_uint xs[1]= {0}; - memcpy ((void*) xs, (const void*) key, len); - return (xs[0]); - } - else { +static inline s7_uint raw_string_hash(const uint8_t *key, s7_int len) /* used in symbols, hash-tables */ +{ + if (len <= 8) + { + s7_uint xs[1] = {0}; + memcpy((void *)xs, (const void *)key, len); + return(xs[0]); + } + else + { #if 0 s7_uint xs[2] = {0, 0}; memcpy((void *)xs, (const void *)key, (len > 16) ? 16 : len); return(xs[0] + xs[1]); #else - /* this seems to be slightly faster. Using start and end portions is worse. - */ - if (len <= 16) { - s7_uint xs[2]= {0, 0}; - memcpy ((void*) xs, (const void*) key, len); - return (xs[0] + xs[1]); + /* this seems to be slightly faster. Using start and end portions is worse. */ + if (len <= 16) + { + s7_uint xs[2] = {0, 0}; + memcpy((void *)xs, (const void *)key, len); + return(xs[0] + xs[1]); + } + else + { + s7_uint xs[3] = {0, 0, 0}; + memcpy((void *)xs, (const void *)key, (len > 24) ? 24 : len); + return(xs[0] + xs[1] + xs[2]); + } +#endif } - else { - s7_uint xs[3]= {0, 0, 0}; - memcpy ((void*) xs, (const void*) key, (len > 24) ? 24 : len); - return (xs[0] + xs[1] + xs[2]); +} + +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; } -#endif - } + result = &(sc->alloc_symbol_cells[sc->alloc_symbol_k]); + sc->alloc_symbol_k += SYMBOL_SIZE; + return(result); } -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_semipermanent_slot (s7_scheme* sc, s7_pointer symbol, s7_pointer value) { - s7_pointer slot= alloc_pointer (sc); - set_full_type (slot, T_SLOT | T_UNHEAP); - slot_set_symbol_and_value (slot, symbol, value); - return (slot); -} - -static /* inline */ s7_pointer -new_symbol (s7_scheme* sc, const char* name, s7_int len, s7_uint hash, - uint32_t location) /* inline useless here 20-Oct-22 */ -{ - /* name might not be null-terminated, these are semipermanent symbols even in - * s7_gensym; g_gensym handles everything separately */ - uint8_t* base = alloc_symbol (sc); - const s7_pointer new_sym= (s7_pointer) base; - const s7_pointer str = (s7_pointer) (base + sizeof (s7_cell)); - const s7_pointer p = (s7_pointer) (base + 2 * sizeof (s7_cell)); - uint8_t* val = (uint8_t*) permalloc (sc, len + 1); - memcpy ((void*) val, (const 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 (new_sym)= T_SYMBOL | T_UNHEAP; - symbol_set_name_cell (new_sym, str); - set_global_slot (new_sym, sc->undefined); /* undefined_slot? */ - symbol_info (new_sym)= (block_t*) (base + 3 * sizeof (s7_cell)); - set_initial_value (new_sym, sc->undefined); - symbol_set_local_slot_unchecked_and_unincremented (new_sym, 0LL, - sc->undefined); - set_big_symbol_tag (new_sym, 0); - set_small_symbol_tag (new_sym, 0); - symbol_clear_shadows (new_sym); - symbol_clear_ctr (new_sym); /* alloc_symbol uses malloc */ - symbol_clear_type (new_sym); - - 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 (new_sym, T_IMMUTABLE | T_KEYWORD); - set_optimize_op (str, OP_CONSTANT); - ksym= make_symbol (sc, (name[0] == ':') ? (const char*) (name + 1) : name, - len - 1); - keyword_set_symbol (new_sym, ksym); - set_has_keyword (ksym); - /* the keyword symbol needs to be semipermanent (not a gensym) else we have - * to laboriously gc-protect it */ - if ((is_gensym (ksym)) && (in_heap (ksym))) - remove_gensym_from_heap (sc, ksym); - slot= make_semipermanent_slot (sc, new_sym, new_sym); - set_global_slot (new_sym, slot); - set_local_slot (new_sym, slot); - set_immutable_slot (slot); - /* we need to include this keyword in the symbol-table */ - } - full_type (p)= - T_PAIR | T_IMMUTABLE | T_UNHEAP; /* add x to the symbol table */ - set_car (p, new_sym); - set_cdr_unchecked (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, (s7_uint) len); /* symbol name length, so it ought to fit! */ - pair_set_raw_name (p, string_value (str)); +static s7_pointer make_semipermanent_slot(s7_scheme *sc, s7_pointer symbol, s7_pointer value) +{ + s7_pointer slot = alloc_pointer(sc); + set_full_type(slot, T_SLOT | T_UNHEAP); + slot_set_symbol_and_value(slot, symbol, value); + return(slot); +} + +static /* inline */ s7_pointer new_symbol(s7_scheme *sc, const char *name, s7_int len, s7_uint hash, uint32_t location) /* inline useless here 20-Oct-22 */ +{ + /* name might not be null-terminated, these are semipermanent symbols even in s7_gensym; g_gensym handles everything separately */ + uint8_t *base = alloc_symbol(sc); + const s7_pointer new_sym = (s7_pointer)base; + const s7_pointer str = (s7_pointer)(base + sizeof(s7_cell)); + const s7_pointer p = (s7_pointer)(base + 2 * sizeof(s7_cell)); + uint8_t *val = (uint8_t *)permalloc(sc, len + 1); + memcpy((void *)val, (const 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(new_sym) = T_SYMBOL | T_UNHEAP; + symbol_set_name_cell(new_sym, str); + set_global_slot(new_sym, sc->undefined); /* undefined_slot? */ + symbol_info(new_sym) = (block_t *)(base + 3 * sizeof(s7_cell)); + set_initial_value(new_sym, sc->undefined); + symbol_set_local_slot_unchecked_and_unincremented(new_sym, 0LL, sc->undefined); + set_big_symbol_tag(new_sym, 0); + set_small_symbol_tag(new_sym, 0); + symbol_clear_shadows(new_sym); + symbol_clear_ctr(new_sym); /* alloc_symbol uses malloc */ + symbol_clear_type(new_sym); + + 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(new_sym, T_IMMUTABLE | T_KEYWORD); + set_optimize_op(str, OP_CONSTANT); + ksym = make_symbol(sc, (name[0] == ':') ? (const char *)(name + 1) : name, len - 1); + keyword_set_symbol(new_sym, ksym); + set_has_keyword(ksym); + /* the keyword symbol needs to be semipermanent (not a gensym) else we have to laboriously gc-protect it */ + if ((is_gensym(ksym)) && + (in_heap(ksym))) + remove_gensym_from_heap(sc, ksym); + slot = make_semipermanent_slot(sc, new_sym, new_sym); + set_global_slot(new_sym, slot); + set_local_slot(new_sym, slot); + set_immutable_slot(slot); + /* we need to include this keyword in the symbol-table */ + } + full_type(p) = T_PAIR | T_IMMUTABLE | T_UNHEAP; /* add x to the symbol table */ + set_car(p, new_sym); + set_cdr_unchecked(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, (s7_uint)len); /* symbol name length, so it ought to fit! */ + pair_set_raw_name(p, string_value(str)); #if 0 { /* high 6 bytes are probably unused, and index */ @@ -11575,4154 +8551,2379 @@ new_symbol (s7_scheme* sc, const char* name, s7_int len, s7_uint hash, */ } #endif - return (new_sym); + return(new_sym); } -static Inline s7_pointer -inline_make_symbol (s7_scheme* sc, const char* name, - s7_int len) /* inline out: ca 40=2% in tload */ +static Inline s7_pointer inline_make_symbol(s7_scheme *sc, const char *name, s7_int len) /* inline out: ca 40=2% in tload */ { /* name here might not be null-terminated or aligned */ - const s7_uint hash = raw_string_hash ((const uint8_t*) name, len); - const uint32_t location= hash % SYMBOL_TABLE_SIZE; - - if (len <= 8) { - for (s7_pointer syms = vector_element (sc->symbol_table, location); - is_pair (syms); syms= cdr (syms)) - if ((hash == pair_raw_hash (syms)) && - ((s7_uint) len == pair_raw_len (syms))) - return (car (syms)); - } + const s7_uint hash = raw_string_hash((const uint8_t *)name, len); + const uint32_t location = hash % SYMBOL_TABLE_SIZE; + + if (len <= 8) + { + for (s7_pointer syms = vector_element(sc->symbol_table, location); is_pair(syms); syms = cdr(syms)) + if ((hash == pair_raw_hash(syms)) && + ((s7_uint)len == pair_raw_len(syms))) + return(car(syms)); + } else /* checking name[len=='\0' and using strcmp if so was not a big win */ - for (s7_pointer syms = vector_element (sc->symbol_table, location); - is_pair (syms); syms= cdr (syms)) - if ((hash == pair_raw_hash (syms)) && - ((s7_uint) len == pair_raw_len (syms)) && - (strings_are_equal_with_length ( - name, pair_raw_name (syms), - len))) /* length here because name might not be null-terminated or - aligned */ - return (car (syms)); - return (new_symbol (sc, name, len, hash, location)); -} - -static s7_pointer -make_symbol (s7_scheme* sc, const char* name, s7_int len) { - return (inline_make_symbol (sc, name, len)); -} - -s7_pointer -s7_make_symbol (s7_scheme* sc, const char* name) { - return (inline_make_symbol (sc, name, safe_strlen (name))); -} - -static s7_pointer -symbol_table_find_by_name (s7_scheme* sc, const char* name, s7_uint hash, - uint32_t location, s7_int len) { - for (s7_pointer syms = vector_element (sc->symbol_table, location); - is_pair (syms); syms= cdr (syms)) - if ((hash == pair_raw_hash (syms)) && - (strings_are_equal_with_length (name, pair_raw_name (syms), len))) - return (car (syms)); - return (sc->nil); -} - -s7_pointer -s7_symbol_table_find_name (s7_scheme* sc, const char* name) { - s7_int len = safe_strlen (name); - s7_uint hash= raw_string_hash ((const uint8_t*) name, len); - s7_pointer result= - symbol_table_find_by_name (sc, name, hash, hash % SYMBOL_TABLE_SIZE, len); - return ((is_null (result)) ? NULL : result); -} - -/* -------------------------------- symbol-table - * -------------------------------- */ -extern inline s7_pointer make_simple_vector (s7_scheme* sc, s7_int len); - -static s7_pointer -g_symbol_table (s7_scheme* sc, s7_pointer unused_args) { -#define H_symbol_table \ - "(symbol-table) returns a vector containing the current contents (symbols) " \ - "of s7's symbol-table" -#define Q_symbol_table s7_make_signature (sc, 1, sc->is_vector_symbol) - - int32_t syms = 0; - s7_pointer* entries= vector_elements (sc->symbol_table); - - /* 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. can be called in gdb: p display(s7_eval_c_string(sc, "(for-each - * (lambda (x) (when (gensym? x) (format *stderr* \"~A \" x))) - * (symbol-table))")) + for (s7_pointer syms = vector_element(sc->symbol_table, location); is_pair(syms); syms = cdr(syms)) + if ((hash == pair_raw_hash(syms)) && + ((s7_uint)len == pair_raw_len(syms)) && + (strings_are_equal_with_length(name, pair_raw_name(syms), len))) /* length here because name might not be null-terminated or aligned */ + return(car(syms)); + return(new_symbol(sc, name, len, hash, location)); +} + +s7_pointer make_symbol(s7_scheme *sc, const char *name, s7_int len) {return(inline_make_symbol(sc, name, len));} + +s7_pointer s7_make_symbol(s7_scheme *sc, const char *name) {return(inline_make_symbol(sc, name, safe_strlen(name)));} + +static s7_pointer symbol_table_find_by_name(s7_scheme *sc, const char *name, s7_uint hash, uint32_t location, s7_int len) +{ + for (s7_pointer syms = vector_element(sc->symbol_table, location); is_pair(syms); syms = cdr(syms)) + if ((hash == pair_raw_hash(syms)) && + (strings_are_equal_with_length(name, pair_raw_name(syms), len))) + return(car(syms)); + return(sc->nil); +} + +s7_pointer s7_symbol_table_find_name(s7_scheme *sc, const char *name) +{ + s7_int len = safe_strlen(name); + s7_uint hash = raw_string_hash((const uint8_t *)name, len); + s7_pointer result = symbol_table_find_by_name(sc, name, hash, hash % SYMBOL_TABLE_SIZE, len); + return((is_null(result)) ? NULL : result); +} + + +/* -------------------------------- symbol-table -------------------------------- */ +extern inline s7_pointer make_simple_vector(s7_scheme *sc, s7_int len); + +static s7_pointer g_symbol_table(s7_scheme *sc, s7_pointer unused_args) +{ + #define H_symbol_table "(symbol-table) returns a vector containing the current contents (symbols) of s7's symbol-table" + #define Q_symbol_table s7_make_signature(sc, 1, sc->is_vector_symbol) + + int32_t syms = 0; + s7_pointer *entries = vector_elements(sc->symbol_table); + + /* 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. + * can be called in gdb: p display(s7_eval_c_string(sc, "(for-each (lambda (x) (when (gensym? x) (format *stderr* \"~A \" x))) (symbol-table))")) */ - for (int32_t i= 0; i < SYMBOL_TABLE_SIZE; i++) - for (s7_pointer symlist= entries[i]; is_pair (symlist); - symlist = cdr (symlist)) + for (int32_t i = 0; i < SYMBOL_TABLE_SIZE; i++) + for (s7_pointer symlist = entries[i]; is_pair(symlist); symlist = cdr(symlist)) syms++; if (syms > sc->max_vector_length) - error_nr (sc, sc->out_of_range_symbol, - set_elist_3 (sc, - wrap_string (sc, - "symbol-table size, ~D, is greater " - "than (*s7* 'max-vector-length), ~D", - 68), - wrap_integer (sc, syms), - wrap_integer (sc, sc->max_vector_length))); + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "symbol-table size, ~D, is greater than (*s7* 'max-vector-length), ~D", 68), + wrap_integer(sc, syms), wrap_integer(sc, sc->max_vector_length))); { - const s7_pointer vec= make_simple_vector (sc, syms); - s7_pointer* els= vector_elements (vec); - set_is_symbol_table (vec); - for (int32_t i= 0, j= 0; i < SYMBOL_TABLE_SIZE; i++) - for (s7_pointer symlist= entries[i]; is_pair (symlist); - symlist = cdr (symlist)) - els[j++]= car (symlist); - return (vec); + const s7_pointer vec = make_simple_vector(sc, syms); + s7_pointer *els = vector_elements(vec); + set_is_symbol_table(vec); + for (int32_t i = 0, j = 0; i < SYMBOL_TABLE_SIZE; i++) + for (s7_pointer symlist = entries[i]; is_pair(symlist); symlist = cdr(symlist)) + els[j++] = car(symlist); + return(vec); } } -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? */ - for (int32_t i= 0; i < SYMBOL_TABLE_SIZE; i++) - for (s7_pointer syms= vector_element (sc->symbol_table, i); is_pair (syms); - syms = cdr (syms)) - if (symbol_func (symbol_name (car (syms)), 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) { - for (int32_t i= 0; i < SYMBOL_TABLE_SIZE; i++) - for (s7_pointer syms= vector_element (sc->symbol_table, i); is_pair (syms); - syms = cdr (syms)) - if (symbol_func (symbol_name (car (syms)), data)) return (true); - return (false); +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? */ + for (int32_t i = 0; i < SYMBOL_TABLE_SIZE; i++) + for (s7_pointer syms = vector_element(sc->symbol_table, i); is_pair(syms); syms = cdr(syms)) + if (symbol_func(symbol_name(car(syms)), 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) +{ + for (int32_t i = 0; i < SYMBOL_TABLE_SIZE; i++) + for (s7_pointer syms = vector_element(sc->symbol_table, i); is_pair(syms); syms = cdr(syms)) + if (symbol_func(symbol_name(car(syms)), 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 */ - const uint32_t location= - string_hash (symbol_name_cell (sym)) % SYMBOL_TABLE_SIZE; - s7_pointer symbols= vector_element (sc->symbol_table, location); - if (car (symbols) == sym) - vector_element (sc->symbol_table, location)= cdr (symbols); +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 */ + const uint32_t location = string_hash(symbol_name_cell(sym)) % SYMBOL_TABLE_SIZE; + s7_pointer symbols = vector_element(sc->symbol_table, location); + if (car(symbols) == sym) + vector_element(sc->symbol_table, location) = cdr(symbols); else - for (s7_pointer syms= cdr (symbols); is_pair (syms); - symbols= syms, syms= cdr (syms)) - if (car (syms) == sym) { - set_cdr_unchecked (symbols, cdr (syms)); /* delete z */ - return; - } + for (s7_pointer syms = cdr(symbols); is_pair(syms); symbols = syms, syms = cdr(syms)) + if (car(syms) == sym) + { + set_cdr_unchecked(symbols, cdr(syms)); /* delete z */ + return; + } } -s7_pointer -s7_gensym (s7_scheme* sc, const char* prefix) { - const s7_int len = safe_strlen (prefix) + 32; - block_t* b = mallocate (sc, len); - char* 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'; +s7_pointer s7_gensym(s7_scheme *sc, const char *prefix) +{ + const s7_int len = safe_strlen(prefix) + 32; + block_t *b = mallocate(sc, len); + char *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'; { - s7_int slen = catstrs (name, len, "{", (prefix) ? prefix : "", "}-", - pos_int_to_str_direct (sc, sc->gensym_counter++), - (char*) NULL); - s7_uint hash = raw_string_hash ((const uint8_t*) name, slen); - int32_t location= hash % SYMBOL_TABLE_SIZE; - s7_pointer x = new_symbol (sc, name, slen, hash, - location); /* not T_GENSYM -- might be called from - outside so should not be GC'd(?) */ - liberate (sc, b); - return (x); + s7_int slen = catstrs(name, len, "{", (prefix) ? prefix : "", "}-", pos_int_to_str_direct(sc, sc->gensym_counter++), (char *)NULL); + s7_uint hash = raw_string_hash((const uint8_t *)name, slen); + int32_t location = hash % SYMBOL_TABLE_SIZE; + s7_pointer x = new_symbol(sc, name, slen, hash, location); /* not T_GENSYM -- might be called from outside so should not be GC'd(?) */ + liberate(sc, b); + return(x); } } -bool -is_gensym_b_p (s7_pointer g) { - return ((is_symbol (g)) && (is_gensym (g))); -} +bool is_gensym_b_p(s7_pointer g) {return((is_symbol(g)) && (is_gensym(g)));} /* g_is_gensym is now defined in s7_scheme_predicate.c */ -#define H_is_gensym "(gensym? sym) returns #t if sym is a gensym" -#define Q_is_gensym sc->pl_bt + #define H_is_gensym "(gensym? sym) returns #t if sym is a gensym" + #define Q_is_gensym sc->pl_bt -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) +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; - s7_int plen; + const char *prefix; + s7_int plen; /* get symbol name */ - if (is_pair (args)) { - s7_pointer gname= car (args); - if (!is_string (gname)) - return (sole_arg_method_or_bust (sc, gname, sc->gensym_symbol, args, - sc->type_names[T_STRING])); - prefix= string_value (gname); - plen= string_length (gname); /* was safe_strlen(prefix): were we stopping at - #\null deliberately? */ - } - else { - prefix= "gensym"; - plen = 6; - } + if (is_pair(args)) + { + s7_pointer gname = car(args); + if (!is_string(gname)) + return(sole_arg_method_or_bust(sc, gname, sc->gensym_symbol, args, sc->type_names[T_STRING])); + prefix = string_value(gname); + plen = string_length(gname); /* was safe_strlen(prefix): were we stopping at #\null deliberately? */ + } + else + { + prefix = "gensym"; + plen = 6; + } { - s7_int len= plen + 32; /* why 32 -- we need room for the gensym_counter - integer, but (length "9223372036854775807") = 19, - see gensym name collision loop below */ - /* it might be better (less predictable) to use a random number instead of - * gensym_counter, but that looks messy */ - block_t* b= mallocate (sc, len + sizeof (block_t) + 2 * sizeof (s7_cell)); - char* base= (char*) block_data (b); - s7_pointer str = (s7_cell*) base; - s7_pointer stc = (s7_cell*) (base + sizeof (s7_cell)); - block_t* ib = (block_t*) (base + 2 * sizeof (s7_cell)); - char* name= (char*) (base + sizeof (block_t) + 2 * sizeof (s7_cell)); - name[0] = '{'; - memcpy ((void*) (name + 1), prefix, - plen); /* memcpy is ok with plen==0, I think */ - name[plen + 1]= '}'; - name[plen + 2]= '-'; /* {gensym}-nnn */ + s7_int len = plen + 32; /* why 32 -- we need room for the gensym_counter integer, but (length "9223372036854775807") = 19, see gensym name collision loop below */ + /* it might be better (less predictable) to use a random number instead of gensym_counter, but that looks messy */ + block_t *b = mallocate(sc, len + sizeof(block_t) + 2 * sizeof(s7_cell)); + char *base = (char *)block_data(b); + s7_pointer str = (s7_cell *)base; + s7_pointer stc = (s7_cell *)(base + sizeof(s7_cell)); + block_t *ib = (block_t *)(base + 2 * sizeof(s7_cell)); + char *name = (char *)(base + sizeof(block_t) + 2 * sizeof(s7_cell)); + name[0] = '{'; + memcpy((void *)(name + 1), prefix, plen); /* memcpy is ok with plen==0, I think */ + name[plen + 1] = '}'; + name[plen + 2] = '-'; /* {gensym}-nnn */ { s7_pointer new_gensym; - s7_uint hash; - uint32_t location; - s7_int nlen; - while (true) { - const char* p= pos_int_to_str (sc, sc->gensym_counter++, &len, '\0'); - memcpy ((void*) (name + plen + 3), (void*) p, len); - nlen = len + plen + 2; - name[nlen]= '\0'; - hash = raw_string_hash ((const uint8_t*) name, nlen); - location = hash % SYMBOL_TABLE_SIZE; - if (is_null ( - symbol_table_find_by_name (sc, name, hash, location, nlen))) - break; - if (sc->safety > no_safety) - s7_warn (sc, nlen + 25, "%s collides with gensym?\n", name); - } + s7_uint hash; + uint32_t location; + s7_int nlen; + while (true) + { + const char *p = pos_int_to_str(sc, sc->gensym_counter++, &len, '\0'); + memcpy((void *)(name + plen + 3), (void *)p, len); + nlen = len + plen + 2; + name[nlen] = '\0'; + hash = raw_string_hash((const uint8_t *)name, nlen); + location = hash % SYMBOL_TABLE_SIZE; + if (is_null(symbol_table_find_by_name(sc, name, hash, location, nlen))) break; + if (sc->safety > no_safety) + s7_warn(sc, nlen + 25, "%s collides with gensym?\n", 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); /* was T_UNHEAP? 17-Mar-25 */ - string_length (str)= nlen; - string_value (str) = name; - string_hash (str) = hash; + 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); /* was T_UNHEAP? 17-Mar-25 */ + 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, new_gensym, T_SYMBOL | T_GENSYM); - symbol_set_name_cell (new_gensym, str); - symbol_info (new_gensym)= ib; - set_global_slot (new_gensym, sc->undefined); /* undefined_slot? */ - set_initial_value (new_gensym, sc->undefined); - symbol_set_local_slot_unchecked (new_gensym, 0LL, sc->undefined); - symbol_clear_ctr (new_gensym); - set_big_symbol_tag (new_gensym, 0); - set_small_symbol_tag (new_gensym, 0); - symbol_clear_shadows (new_gensym); - symbol_clear_type (new_gensym); - gensym_block (new_gensym)= b; + new_cell(sc, new_gensym, T_SYMBOL | T_GENSYM); + symbol_set_name_cell(new_gensym, str); + symbol_info(new_gensym) = ib; + set_global_slot(new_gensym, sc->undefined); /* undefined_slot? */ + set_initial_value(new_gensym, sc->undefined); + symbol_set_local_slot_unchecked(new_gensym, 0LL, sc->undefined); + symbol_clear_ctr(new_gensym); + set_big_symbol_tag(new_gensym, 0); + set_small_symbol_tag(new_gensym, 0); + symbol_clear_shadows(new_gensym); + symbol_clear_type(new_gensym); + gensym_block(new_gensym) = b; /* place new symbol in symbol-table */ - if (S7_DEBUGGING) full_type (stc)= 0; - set_full_type (stc, T_PAIR | T_IMMUTABLE); /* was T_UNHEAP? 17-Mar-25 */ - set_car (stc, new_gensym); - set_cdr_unchecked (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, (s7_uint) string_length (str)); - pair_set_raw_name (stc, string_value (str)); - - add_gensym (sc, new_gensym); - return (new_gensym); - } - } + if (S7_DEBUGGING) full_type(stc) = 0; + set_full_type(stc, T_PAIR | T_IMMUTABLE); /* was T_UNHEAP? 17-Mar-25 */ + set_car(stc, new_gensym); + set_cdr_unchecked(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, (s7_uint)string_length(str)); + pair_set_raw_name(stc, string_value(str)); + + add_gensym(sc, new_gensym); + return(new_gensym); + }} } + /* -------------------------------- syntax? -------------------------------- */ -bool -s7_is_syntax (s7_pointer p) { - return (is_syntax (p)); -} +bool s7_is_syntax(s7_pointer p) {return(is_syntax(p));} /* g_is_syntax is now defined in s7_scheme_predicate.c */ -#define H_is_syntax \ - "(syntax? obj) returns #t if obj is a syntactic value (e.g. lambda)" -#define Q_is_syntax sc->pl_bt + #define H_is_syntax "(syntax? obj) returns #t if obj is a syntactic value (e.g. lambda)" + #define Q_is_syntax sc->pl_bt -/* -------------------------------- symbol helpers - * -------------------------------- */ -bool -s7i_is_gensym (s7_pointer p) { - return (is_gensym (p)); -} -s7_pointer -s7i_symbol_name_cell (s7_pointer sym) { - return (symbol_name_cell (sym)); -} -s7_int -s7i_symbol_name_length (s7_pointer sym) { - return (symbol_name_length (sym)); -} -s7_pointer -s7i_make_symbol_with_length (s7_scheme* sc, const char* name, s7_int len) { - return (make_symbol (sc, name, len)); -} -s7_pointer -s7i_initial_value (s7_pointer symbol) { - return (initial_value (symbol)); -} -void -s7i_set_initial_value (s7_pointer symbol, s7_pointer value) { - set_initial_value (symbol, value); -} -bool -s7i_initial_value_is_defined (s7_scheme* sc, s7_pointer symbol) { - return (initial_value_is_defined (sc, symbol)); -} + +/* -------------------------------- symbol helpers -------------------------------- */ +bool s7i_is_gensym(s7_pointer p) {return(is_gensym(p));} +s7_pointer s7i_symbol_name_cell(s7_pointer sym) {return(symbol_name_cell(sym));} +s7_int s7i_symbol_name_length(s7_pointer sym) {return(symbol_name_length(sym));} +s7_pointer s7i_make_symbol_with_length(s7_scheme *sc, const char *name, s7_int len) {return(make_symbol(sc, name, len));} +s7_pointer s7i_initial_value(s7_pointer symbol) {return(initial_value(symbol));} +void s7i_set_initial_value(s7_pointer symbol, s7_pointer value) {set_initial_value(symbol, value);} +bool s7i_initial_value_is_defined(s7_scheme *sc, s7_pointer symbol) {return(initial_value_is_defined(sc, symbol));} /* -------------------------------- symbol? -------------------------------- */ -bool -s7_is_symbol (s7_pointer p) { - return (is_symbol (p)); -} +bool s7_is_symbol(s7_pointer p) {return(is_symbol(p));} /* g_is_symbol is now defined in s7_scheme_predicate.c */ -#define H_is_symbol "(symbol? obj) returns #t if obj is a symbol" -#define Q_is_symbol sc->pl_bt + #define H_is_symbol "(symbol? obj) returns #t if obj is a symbol" + #define Q_is_symbol sc->pl_bt -const char* -s7_symbol_name (s7_pointer sym) { - return (symbol_name (sym)); -} +const char *s7_symbol_name(s7_pointer sym) {return(symbol_name(sym));} -s7_pointer -s7_name_to_value (s7_scheme* sc, const char* name) { - return (s7_symbol_value (sc, make_symbol_with_strlen (sc, name))); -} +s7_pointer s7_name_to_value(s7_scheme *sc, const char *name) {return(s7_symbol_value(sc, make_symbol_with_strlen(sc, name)));} /* should this also handle non-symbols such as "+nan.0"? */ -/* -------------------------------- symbol->string - * -------------------------------- */ + +/* -------------------------------- symbol->string -------------------------------- */ static s7_pointer nil_string; /* permanent "" */ -/* nil_vector is complicated by the many vector types, and s7test assumes it is - * mutable! and not eq? to other nil_vectors (watch out for add_vector!) */ +/* nil_vector is complicated by the many vector types, and s7test assumes it is mutable! and not eq? to other nil_vectors (watch out for add_vector!) */ -s7_pointer -s7i_nil_string (void) { - return (nil_string); -} +s7_pointer s7i_nil_string(void) {return(nil_string);} -s7_pointer -s7i_set_plist_2 (s7_scheme* sc, s7_pointer x1, s7_pointer x2) { - return (set_plist_2 (sc, x1, x2)); -} -s7_pointer -s7i_set_ulist_1 (s7_scheme* sc, s7_pointer x1, s7_pointer x2) { - return (set_ulist_1 (sc, x1, x2)); -} +s7_pointer s7i_set_plist_2(s7_scheme *sc, s7_pointer x1, s7_pointer x2) {return(set_plist_2(sc, x1, x2));} +s7_pointer s7i_set_ulist_1(s7_scheme *sc, s7_pointer x1, s7_pointer x2) {return(set_ulist_1(sc, x1, x2));} -void -s7i_string_append_length_error (s7_scheme* sc, s7_pointer caller, s7_int len) { - error_nr (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_integer (sc, len), - wrap_integer (sc, sc->max_string_length))); +void s7i_string_append_length_error(s7_scheme *sc, s7_pointer caller, s7_int len) +{ + error_nr(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_integer(sc, len), wrap_integer(sc, sc->max_string_length))); } -bool -s7i_is_string_append_or_symbol_caller (s7_scheme* sc, s7_pointer caller) { - return ((caller == sc->string_append_symbol) || - (caller == sc->symbol_symbol)); +bool s7i_is_string_append_or_symbol_caller(s7_scheme *sc, s7_pointer caller) +{ + return((caller == sc->string_append_symbol) || (caller == sc->symbol_symbol)); } -void -s7i_set_string_value (s7_pointer str, const char* val) { - string_value (str)= (char*) val; -} -char* -s7i_string_value_ptr (s7_pointer str) { - return (string_value (str)); -} +void s7i_set_string_value(s7_pointer str, const char *val) {string_value(str) = (char *)val;} +char *s7i_string_value_ptr(s7_pointer str) {return(string_value(str));} /* string comparison bridge functions (defined after scheme_strcmp etc.) */ -static Inline s7_pointer -inline_make_string_with_length (s7_scheme* sc, const char* str, s7_int len) { +static Inline s7_pointer inline_make_string_with_length(s7_scheme *sc, const char *str, s7_int len) +{ s7_pointer new_string; - new_cell (sc, new_string, T_STRING | T_SAFE_PROCEDURE); - string_block (new_string)= inline_mallocate (sc, len + 1); - string_value (new_string)= (char*) block_data (string_block (new_string)); - if (str) memcpy ((void*) string_value (new_string), (const void*) str, len); - string_value (new_string)[len]= 0; - string_length (new_string) = len; - string_hash (new_string) = 0; - add_string (sc, new_string); - return (new_string); -} - -static s7_pointer -make_string_with_length (s7_scheme* sc, const char* str, s7_int len) { - return (inline_make_string_with_length ( - sc, str, len)); /* packaged to avoid inlining everywhere */ -} - -/* g_symbol_to_string, g_symbol_to_string_uncopied, symbol_to_string_p_p, - symbol_to_string_uncopied_p migrated to s7_scheme_symbol.c */ -#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) - -#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) + new_cell(sc, new_string, T_STRING | T_SAFE_PROCEDURE); + string_block(new_string) = inline_mallocate(sc, len + 1); + string_value(new_string) = (char *)block_data(string_block(new_string)); + if (str) memcpy((void *)string_value(new_string), (const void *)str, len); + string_value(new_string)[len] = 0; + string_length(new_string) = len; + string_hash(new_string) = 0; + add_string(sc, new_string); + return(new_string); +} + +s7_pointer make_string_with_length(s7_scheme *sc, const char *str, s7_int len) +{ + return(inline_make_string_with_length(sc, str, len)); /* packaged to avoid inlining everywhere */ +} + +/* g_symbol_to_string, g_symbol_to_string_uncopied, symbol_to_string_p_p, symbol_to_string_uncopied_p + migrated to s7_scheme_symbol.c */ +#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) + +#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) /* g_string_to_symbol_1 still needed by g_symbol in s7.c */ -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_p (sc, str, caller, sc->type_names[T_STRING])); - if (string_length (str) <= 0) - sole_arg_wrong_type_error_nr (sc, caller, str, - wrap_string (sc, "a non-null string", 17)); - return (make_symbol (sc, string_value (str), string_length (str))); +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_p(sc, str, caller, sc->type_names[T_STRING])); + if (string_length(str) <= 0) + sole_arg_wrong_type_error_nr(sc, caller, str, wrap_string(sc, "a non-null string", 17)); + return(make_symbol(sc, string_value(str), string_length(str))); } + /* -------------------------------- symbol -------------------------------- */ -s7_pointer s7i_string_append_1 (s7_scheme* sc, s7_pointer args, - s7_pointer caller); - -static s7_pointer -mark_as_symbol_from_symbol (s7_pointer sym) { - set_is_symbol_from_symbol (sym); - return (sym); -} - -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) - - /* (let ((x 0)) (set! (symbol "x") 12)) ;symbol (a c-function) does not have a - * setter: (set! (symbol "x") 12) (let (((symbol "x") 3)) x) ; bad variable - * ((symbol "x") (let ((x 2)) (+ (symbol "x") 1)) ;+ first argument, x, is a - * symbol but should be a number maybe document this: (symbol...) just returns - * the symbol (let ((x 3)) (+ (symbol->value (symbol "x")) 1)) -> 4, (let ((x - * 0)) (apply set! (symbol "x") (list 32)) x) -> 32 +s7_pointer s7i_string_append_1(s7_scheme *sc, s7_pointer args, s7_pointer caller); + +static s7_pointer mark_as_symbol_from_symbol(s7_pointer sym) +{ + set_is_symbol_from_symbol(sym); + return(sym); +} + +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) + + /* (let ((x 0)) (set! (symbol "x") 12)) ;symbol (a c-function) does not have a setter: (set! (symbol "x") 12) + * (let (((symbol "x") 3)) x) ; bad variable ((symbol "x") + * (let ((x 2)) (+ (symbol "x") 1)) ;+ first argument, x, is a symbol but should be a number + * maybe document this: (symbol...) just returns the symbol + * (let ((x 3)) (+ (symbol->value (symbol "x")) 1)) -> 4, (let ((x 0)) (apply set! (symbol "x") (list 32)) x) -> 32 */ - s7_int len= 0; + s7_int len = 0; s7_pointer p; - for (p= args; is_pair (p); p= cdr (p)) - if (is_string (car (p))) len+= string_length (car (p)); + 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 (mark_as_symbol_from_symbol ( - g_string_to_symbol_1 (sc, car (args), sc->symbol_symbol))); - return (mark_as_symbol_from_symbol (g_string_to_symbol_1 ( - sc, s7i_string_append_1 (sc, args, sc->symbol_symbol), - sc->symbol_symbol))); - } + if (is_pair(p)) + { + if (is_null(cdr(args))) + return(mark_as_symbol_from_symbol(g_string_to_symbol_1(sc, car(args), sc->symbol_symbol))); + return(mark_as_symbol_from_symbol(g_string_to_symbol_1(sc, s7i_string_append_1(sc, args, sc->symbol_symbol), sc->symbol_symbol))); + } if (len == 0) - sole_arg_wrong_type_error_nr (sc, sc->symbol_symbol, car (args), - wrap_string (sc, "a non-null string", 17)); + sole_arg_wrong_type_error_nr(sc, sc->symbol_symbol, car(args), wrap_string(sc, "a non-null string", 17)); { /* can't use catstrs_direct here because it stops at embedded null */ - block_t* b = mallocate (sc, len + 1); - char* name= (char*) block_data (b); + block_t *b = mallocate(sc, len + 1); + char *name = (char *)block_data(b); s7_pointer sym; - p= args; - for (s7_int cur_len= 0; 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 = mark_as_symbol_from_symbol (inline_make_symbol (sc, name, len)); - liberate (sc, b); - return (sym); + p = args; + for (s7_int cur_len = 0; 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 = mark_as_symbol_from_symbol(inline_make_symbol(sc, name, len)); + liberate(sc, b); + return(sym); } } -static s7_pointer -symbol_p_pp (s7_scheme* sc, s7_pointer str1, s7_pointer str2) { - char buf[256]; +static s7_pointer symbol_p_pp(s7_scheme *sc, s7_pointer str1, s7_pointer str2) +{ + char buf[256]; s7_int len; - if ((!is_string (str1)) || (!is_string (str2))) - return (g_symbol (sc, set_plist_2 (sc, str1, str2))); - len= string_length (str1) + string_length (str2); - if ((len == 0) || (len >= 256)) - return (g_symbol (sc, set_plist_2 (sc, str1, str2))); - memcpy ((void*) buf, (void*) string_value (str1), string_length (str1)); - memcpy ((void*) (buf + string_length (str1)), (void*) string_value (str2), - string_length (str2)); - return (mark_as_symbol_from_symbol (inline_make_symbol (sc, buf, len))); + if ((!is_string(str1)) || (!is_string(str2))) return(g_symbol(sc, set_plist_2(sc, str1, str2))); + len = string_length(str1) + string_length(str2); + if ((len == 0) || (len >= 256)) return(g_symbol(sc, set_plist_2(sc, str1, str2))); + memcpy((void *)buf, (void *)string_value(str1), string_length(str1)); + memcpy((void *)(buf + string_length(str1)), (void *)string_value(str2), string_length(str2)); + return(mark_as_symbol_from_symbol(inline_make_symbol(sc, buf, len))); } /* -------- symbol-initial-value -------- */ /* g_symbol_initial_value migrated to s7_scheme_symbol.c */ -#define H_symbol_initial_value \ - "(symbol-initial-value sym) returns the initial binding of the symbol sym" -#define Q_symbol_initial_value \ - s7_make_signature (sc, 2, sc->T, sc->is_symbol_symbol) - -static s7_pointer -g_symbol_set_initial_value (s7_scheme* sc, s7_pointer args) { - const s7_pointer symbol= car (args), value= cadr (args); - if (!is_symbol (symbol)) - wrong_type_error_nr (sc, wrap_string (sc, "set! symbol-initial-value", 25), - 1, symbol, sc->type_names[T_SYMBOL]); - if (initial_value_is_defined (sc, symbol)) - immutable_object_error_nr ( - sc, - set_elist_2 ( - sc, - wrap_string ( - sc, "can't set! (symbol-initial-value '~S); it is immutable", - 54), - symbol)); - set_initial_value (symbol, value); - if (in_heap (value)) add_semipermanent_object (sc, value); +#define H_symbol_initial_value "(symbol-initial-value sym) returns the initial binding of the symbol sym" +#define Q_symbol_initial_value s7_make_signature(sc, 2, sc->T, sc->is_symbol_symbol) + +static s7_pointer g_symbol_set_initial_value(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer symbol = car(args), value = cadr(args); + if (!is_symbol(symbol)) + wrong_type_error_nr(sc, wrap_string(sc, "set! symbol-initial-value", 25), 1, symbol, sc->type_names[T_SYMBOL]); + if (initial_value_is_defined(sc, symbol)) + immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't set! (symbol-initial-value '~S); it is immutable", 54), symbol)); + set_initial_value(symbol, value); + if (in_heap(value)) add_semipermanent_object(sc, value); /* should this tie into unlet? */ - return (value); -} - -s7_pointer -s7_symbol_initial_value (s7_pointer symbol) { - return (initial_value (symbol)); -} - -static bool -is_eq_initial_value (s7_pointer symbol, s7_pointer other) { - const s7_pointer init= initial_value (symbol); - if (init == other) return (true); - if (is_c_function (init)) - return ((is_c_function (other)) && - (c_function_data (init) == c_function_data (other))); - if (is_syntax (init)) - return ((is_syntax (other)) && - (syntax_symbol (init) == syntax_symbol (other))); - if (is_unspecified (init)) return (is_unspecified (other)); - if (is_c_macro (init)) - return ((is_c_macro (other)) && - (c_macro_data (init) == c_macro_data (other))); - return (false); -} - -static bool -is_eq_initial_c_function_data (s7_pointer symbol, s7_pointer s_func) { - return ( - (is_c_function (s_func)) && - (c_function_data (s_func) == c_function_data (initial_value (symbol)))); -} - -static void -copy_initial_value (s7_scheme* sc, s7_pointer sym) { - s7_pointer curval= initial_value (sym); - if (!is_symbol (curval)) /* otherwise we end up with a copied symbol */ - { - s7_pointer newval= alloc_pointer (sc); - memcpy ((void*) newval, (void*) curval, sizeof (s7_cell)); - set_is_initial_value (newval); - set_initial_value (sym, newval); - /* fprintf(stderr, "%s[%d]: %s %s\n", __func__, __LINE__, - * string_value(s7_object_to_string(sc, sym, false)), - * string_value(s7_object_to_string(sc, newval, false))); */ - } + return(value); } -s7_pointer -s7_symbol_set_initial_value (s7_scheme* sc, s7_pointer symbol, - s7_pointer value) { - if (initial_value (symbol) == sc->undefined) { - set_initial_value (symbol, value); - /* copy_initial_value(sc, symbol); */ - if (in_heap (value)) add_semipermanent_object (sc, value); - } - return (initial_value (symbol)); +s7_pointer s7_symbol_initial_value(s7_pointer symbol) {return(initial_value(symbol));} + +bool is_eq_initial_value(s7_pointer symbol, s7_pointer other) +{ + const s7_pointer init = initial_value(symbol); + if (init == other) return(true); + if (is_c_function(init)) return((is_c_function(other)) && (c_function_data(init) == c_function_data(other))); + if (is_syntax(init)) return((is_syntax(other)) && (syntax_symbol(init) == syntax_symbol(other))); + if (is_unspecified(init)) return(is_unspecified(other)); + if (is_c_macro(init)) return((is_c_macro(other)) && (c_macro_data(init) == c_macro_data(other))); + return(false); +} + +static bool is_eq_initial_c_function_data(s7_pointer symbol, s7_pointer s_func) +{ + return((is_c_function(s_func)) && (c_function_data(s_func) == c_function_data(initial_value(symbol)))); +} + +static void copy_initial_value(s7_scheme *sc, s7_pointer sym) +{ + s7_pointer curval = initial_value(sym); + if (!is_symbol(curval)) /* otherwise we end up with a copied symbol */ + { + s7_pointer newval = alloc_pointer(sc); + memcpy((void *)newval, (void *)curval, sizeof(s7_cell)); + set_is_initial_value(newval); + set_initial_value(sym, newval); + /* fprintf(stderr, "%s[%d]: %s %s\n", __func__, __LINE__, string_value(s7_object_to_string(sc, sym, false)), string_value(s7_object_to_string(sc, newval, false))); */ + } +} + +s7_pointer s7_symbol_set_initial_value(s7_scheme *sc, s7_pointer symbol, s7_pointer value) +{ + if (initial_value(symbol) == sc->undefined) + { + set_initial_value(symbol, value); + /* copy_initial_value(sc, symbol); */ + if (in_heap(value)) add_semipermanent_object(sc, value); + } + return(initial_value(symbol)); } + /* -------- small symbol set -------- */ #if S7_DEBUGGING -enum { set_ignore, set_begin, set_end }; +enum {set_ignore, set_begin, set_end}; -#define symbol_is_in_small_symbol_set(Sc, Sym) \ - symbol_is_in_small_symbol_set_1 (Sc, Sym, __func__, __LINE__) -static bool -symbol_is_in_small_symbol_set_1 (s7_scheme* sc, s7_pointer sym, - const char* func, int line) { +#define symbol_is_in_small_symbol_set(Sc, Sym) symbol_is_in_small_symbol_set_1(Sc, Sym, __func__, __LINE__) +static bool symbol_is_in_small_symbol_set_1(s7_scheme *sc, s7_pointer sym, const char *func, int line) +{ if (sc->small_symbol_set_state == set_end) - fprintf (stderr, - "%s[%d]: small_symbol_set membership test but it's not running\n", - func, line); - return (small_symbol_tag (sym) == sc->small_symbol_tag); + fprintf(stderr, "%s[%d]: small_symbol_set membership test but it's not running\n", func, line); + return(small_symbol_tag(sym) == sc->small_symbol_tag); } -#define add_symbol_to_small_symbol_set(Sc, Sym) \ - add_symbol_to_small_symbol_set_1 (Sc, Sym, __func__, __LINE__) -static s7_pointer -add_symbol_to_small_symbol_set_1 (s7_scheme* sc, s7_pointer sym, - const char* func, int line) { +#define add_symbol_to_small_symbol_set(Sc, Sym) add_symbol_to_small_symbol_set_1(Sc, Sym, __func__, __LINE__) +static s7_pointer add_symbol_to_small_symbol_set_1(s7_scheme *sc, s7_pointer sym, const char *func, int line) +{ if (sc->small_symbol_set_state == set_end) - fprintf (stderr, - "%s[%d]: small_symbol_set add member but it's not running\n", func, - line); - set_small_symbol_tag (sym, sc->small_symbol_tag); - return (sym); -} - -#define clear_small_symbol_set(Sc) \ - clear_small_symbol_set_1 (Sc, set_ignore, __func__, __LINE__) -static void -clear_small_symbol_set_1 (s7_scheme* sc, int status, const char* func, - int line) { - /* if running end is ok, begin is an error, if not running end is error, begin - * is ok */ - if (status == set_begin) { - if (sc->small_symbol_set_state == set_begin) { - fprintf (stderr, - "%s[%d]: small_symbol_set is running but begin requested " - "(started at %s[%d])\n", - func, line, sc->small_symbol_set_func, - sc->small_symbol_set_line); - if (sc->stop_at_error) abort (); - } - sc->small_symbol_set_func= func; - sc->small_symbol_set_line= line; - } + fprintf(stderr, "%s[%d]: small_symbol_set add member but it's not running\n", func, line); + set_small_symbol_tag(sym, sc->small_symbol_tag); + return(sym); +} + +#define clear_small_symbol_set(Sc) clear_small_symbol_set_1(Sc, set_ignore, __func__, __LINE__) +static void clear_small_symbol_set_1(s7_scheme *sc, int status, const char *func, int line) +{ + /* if running end is ok, begin is an error, if not running end is error, begin is ok */ + if (status == set_begin) + { + if (sc->small_symbol_set_state == set_begin) + { + fprintf(stderr, "%s[%d]: small_symbol_set is running but begin requested (started at %s[%d])\n", + func, line, sc->small_symbol_set_func, sc->small_symbol_set_line); + if (sc->stop_at_error) abort(); + } + sc->small_symbol_set_func = func; + sc->small_symbol_set_line = line; + } if ((status == set_end) && (sc->small_symbol_set_state == set_end)) - fprintf (stderr, - "%s[%d]: small_symbol_set is not running but end requested " - "(started at %s[%d])\n", - func, line, sc->small_symbol_set_func, sc->small_symbol_set_line); - sc->small_symbol_set_state= status; + fprintf(stderr, "%s[%d]: small_symbol_set is not running but end requested (started at %s[%d])\n", + func, line, sc->small_symbol_set_func, sc->small_symbol_set_line); + sc->small_symbol_set_state = status; if (sc->small_symbol_tag == 0) /* see comment below */ - { - s7_pointer* els= vector_elements (sc->symbol_table); - for (int32_t i= 0; i < SYMBOL_TABLE_SIZE; - i++) /* clear old small_symbol_tags */ - for (s7_pointer syms= els[i]; is_pair (syms); syms= cdr (syms)) - set_small_symbol_tag (car (syms), 0); - sc->small_symbol_tag= 1; - } + { + s7_pointer *els = vector_elements(sc->symbol_table); + for (int32_t i = 0; i < SYMBOL_TABLE_SIZE; i++) /* clear old small_symbol_tags */ + for (s7_pointer syms = els[i]; is_pair(syms); syms = cdr(syms)) + set_small_symbol_tag(car(syms), 0); + sc->small_symbol_tag = 1; + } else sc->small_symbol_tag++; } -#define begin_small_symbol_set(Sc) \ - clear_small_symbol_set_1 (Sc, set_begin, __func__, __LINE__) -#define end_small_symbol_set(Sc) \ - clear_small_symbol_set_1 (Sc, set_end, __func__, __LINE__) +#define begin_small_symbol_set(Sc) clear_small_symbol_set_1(Sc, set_begin, __func__, __LINE__) +#define end_small_symbol_set(Sc) clear_small_symbol_set_1(Sc, set_end, __func__, __LINE__) #else -#define symbol_is_in_small_symbol_set(Sc, Sym) \ - (small_symbol_tag (Sym) == Sc->small_symbol_tag) +#define symbol_is_in_small_symbol_set(Sc, Sym) (small_symbol_tag(Sym) == Sc->small_symbol_tag) -static /* inline */ s7_pointer -add_symbol_to_small_symbol_set (s7_scheme* sc, s7_pointer sym) { - set_small_symbol_tag (sym, sc->small_symbol_tag); - return (sym); +static /* inline */ s7_pointer add_symbol_to_small_symbol_set(s7_scheme *sc, s7_pointer sym) +{ + set_small_symbol_tag(sym, sc->small_symbol_tag); + return(sym); } -static /* inline */ void -clear_small_symbol_set (s7_scheme* sc) { - if (sc->small_symbol_tag == - 0) /* or 2^32 - 1, but that's much slower than checking for 0 -- unsigned - wrap around is defined in C */ - { - s7_pointer* els= vector_elements (sc->symbol_table); - for (int32_t i= 0; i < SYMBOL_TABLE_SIZE; - i++) /* clear old small_symbol_tags */ - for (s7_pointer syms= els[i]; is_pair (syms); syms= cdr (syms)) - set_small_symbol_tag (car (syms), 0); - sc->small_symbol_tag= 1; - } +static /* inline */ void clear_small_symbol_set(s7_scheme *sc) +{ + if (sc->small_symbol_tag == 0) /* or 2^32 - 1, but that's much slower than checking for 0 -- unsigned wrap around is defined in C */ + { + s7_pointer *els = vector_elements(sc->symbol_table); + for (int32_t i = 0; i < SYMBOL_TABLE_SIZE; i++) /* clear old small_symbol_tags */ + for (s7_pointer syms = els[i]; is_pair(syms); syms = cdr(syms)) + set_small_symbol_tag(car(syms), 0); + sc->small_symbol_tag = 1; + } else sc->small_symbol_tag++; } -#define begin_small_symbol_set(Sc) clear_small_symbol_set (Sc) +#define begin_small_symbol_set(Sc) clear_small_symbol_set(Sc) #define end_small_symbol_set(Sc) #endif /* -------- big symbol set -------- */ -#define symbol_is_in_big_symbol_set(Sc, Sym) \ - (big_symbol_tag (Sym) == Sc->big_symbol_tag) +#define symbol_is_in_big_symbol_set(Sc, Sym) (big_symbol_tag(Sym) == Sc->big_symbol_tag) #define clear_big_symbol_set(Sc) Sc->big_symbol_tag++ -static s7_pointer -add_symbol_to_big_symbol_set (s7_scheme* sc, s7_pointer sym) { - if (symbol_is_in_big_symbol_set (sc, sym)) symbol_shadows (sym)++; - else symbol_clear_shadows (sym); - set_big_symbol_tag (sym, sc->big_symbol_tag); - return (sym); +static s7_pointer add_symbol_to_big_symbol_set(s7_scheme *sc, s7_pointer sym) +{ + if (symbol_is_in_big_symbol_set(sc, sym)) symbol_shadows(sym)++; else symbol_clear_shadows(sym); + set_big_symbol_tag(sym, sc->big_symbol_tag); + return(sym); } -/* -------------------------------- lets/slots -------------------------------- - */ -static Inline s7_pointer -inline_make_let (s7_scheme* sc, s7_pointer old_let) { + +/* -------------------------------- lets/slots -------------------------------- */ +static Inline s7_pointer inline_make_let(s7_scheme *sc, s7_pointer old_let) +{ s7_pointer new_let; - new_cell (sc, new_let, T_LET | T_SAFE_PROCEDURE); - let_set_id (new_let, ++sc->let_number); - let_set_slots (new_let, slot_end); - let_set_outlet (new_let, old_let); - return (new_let); + new_cell(sc, new_let, T_LET | T_SAFE_PROCEDURE); + let_set_id(new_let, ++sc->let_number); + let_set_slots(new_let, slot_end); + let_set_outlet(new_let, old_let); + return(new_let); } -extern inline s7_pointer -make_let (s7_scheme* sc, s7_pointer old_let) { - return (inline_make_let (sc, old_let)); -} +extern inline s7_pointer make_let(s7_scheme *sc, s7_pointer old_let) {return(inline_make_let(sc, old_let));} -extern inline s7_pointer -inline_make_let_with_slot (s7_scheme* sc, s7_pointer old_let, s7_pointer symbol, - s7_pointer value) { +extern inline s7_pointer inline_make_let_with_slot(s7_scheme *sc, s7_pointer old_let, s7_pointer symbol, s7_pointer value) +{ s7_pointer new_let, slot; - sc->value= value; - 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_unchecked (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); - let_set_slots (new_let, slot); - return (new_let); -} - -static s7_pointer -wrap_let_with_slot (s7_scheme* sc, s7_pointer old_let, s7_pointer symbol, - s7_pointer value) { - s7_pointer let = wrap_let (sc, old_let); /* increments let_number */ - s7_pointer slot= wrap_slot (sc, symbol, value); - symbol_set_local_slot (symbol, sc->let_number, slot); - slot_set_next (slot, slot_end); - let_set_slots (let, slot); - return (let); -} - -static s7_pointer -make_let_with_slot (s7_scheme* sc, s7_pointer old_let, s7_pointer symbol, - s7_pointer value) { - return (inline_make_let_with_slot (sc, old_let, symbol, value)); -} - -static Inline s7_pointer -inline_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*. + sc->value = value; + 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_unchecked(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); + let_set_slots(new_let, slot); + return(new_let); +} + +static s7_pointer wrap_let_with_slot(s7_scheme *sc, s7_pointer old_let, s7_pointer symbol, s7_pointer value) +{ + s7_pointer let = wrap_let(sc, old_let); /* increments let_number */ + s7_pointer slot = wrap_slot(sc, symbol, value); + symbol_set_local_slot(symbol, sc->let_number, slot); + slot_set_next(slot, slot_end); + let_set_slots(let, slot); + return(let); +} + +static s7_pointer make_let_with_slot(s7_scheme *sc, s7_pointer old_let, s7_pointer symbol, s7_pointer value) +{ + return(inline_make_let_with_slot(sc, old_let, symbol, value)); +} + +static Inline s7_pointer inline_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_unchecked (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_unchecked (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); - slot_set_next (slot1, slot2); - return (new_let); -} - -static 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) { - return (inline_make_let_with_two_slots (sc, old_let, symbol1, value1, symbol2, - value2)); -} - -/* 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, s7_uint id) { + 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_unchecked(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_unchecked(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); + slot_set_next(slot1, slot2); + return(new_let); +} + +static 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) +{ + return(inline_make_let_with_two_slots(sc, old_let, symbol1, value1, symbol2, value2)); +} + +/* 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 */ +extern inline void add_slot_unchecked(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value, s7_uint id) +{ s7_pointer slot; - new_cell_unchecked (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); + new_cell_unchecked(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); } -static s7_pointer -add_slot_unchecked_no_local_slot (s7_scheme* sc, s7_pointer let, - s7_pointer symbol, s7_pointer value) { +static s7_pointer add_slot_unchecked_no_local_slot(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) +{ s7_pointer slot; - new_cell_unchecked (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); - return (slot); + new_cell_unchecked(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); + return(slot); } -#define add_slot(Sc, Let, Symbol, Value) \ - add_slot_unchecked (Sc, Let, Symbol, Value, let_id (Let)) +#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) { +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); + 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) { +extern 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); + 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 inline s7_pointer -add_slot_no_local ( - s7_scheme* sc, s7_pointer let, s7_pointer symbol, - s7_pointer value) /* no symbol_set_local_slot, no set_local */ +static inline s7_pointer add_slot_no_local(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) /* no symbol_set_local_slot, no set_local */ { s7_pointer slot; - new_cell (sc, slot, T_SLOT); - slot_set_symbol_and_value (slot, symbol, value); - slot_set_next (slot, let_slots (let)); - let_set_slots (let, slot); - return (slot); + new_cell(sc, slot, T_SLOT); + slot_set_symbol_and_value(slot, symbol, value); + 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_unchecked (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, s7_uint id, s7_pointer last_slot, - s7_pointer symbol, s7_pointer value) { - s7_pointer slot; - new_cell_unchecked (sc, slot, T_SLOT); - slot_set_symbol_and_value (slot, symbol, value); - slot_set_next (slot, slot_end); - symbol_set_local_slot (symbol, id, slot); - slot_set_next (last_slot, slot); - return (slot); -} - -static s7_pointer -add_slot_checked_at_end ( - s7_scheme* sc, s7_uint id, s7_pointer last_slot, s7_pointer symbol, - s7_pointer value) { /* same as above but new_cell is checked */ +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 (sc, slot, T_SLOT); - slot_set_symbol_and_value (slot, symbol, value); - slot_set_next (slot, slot_end); - symbol_set_local_slot (symbol, id, slot); - slot_set_next (last_slot, slot); - return (slot); + new_cell_unchecked(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_at_end_no_local (s7_scheme* sc, s7_pointer last_slot, - s7_pointer symbol, s7_pointer value) { +extern inline s7_pointer add_slot_at_end(s7_scheme *sc, s7_uint id, s7_pointer last_slot, s7_pointer symbol, s7_pointer value) +{ s7_pointer slot; - new_cell_unchecked (sc, slot, T_SLOT); - slot_set_symbol_and_value (slot, symbol, value); - slot_set_next (slot, slot_end); - 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, pars= closure_pars (func); - set_curlet (sc, inline_make_let_with_two_slots (sc, closure_let (func), - car (pars), val1, cadr (pars), - val2)); - last_slot= next_slot (let_slots (sc->curlet)); - add_slot_at_end (sc, let_id (sc->curlet), last_slot, caddr (pars), 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, pars= closure_pars (func); - set_curlet (sc, inline_make_let_with_two_slots (sc, closure_let (func), - car (pars), val1, cadr (pars), - val2)); - pars = cddr (pars); - last_slot= next_slot (let_slots (sc->curlet)); - last_slot= - add_slot_at_end (sc, let_id (sc->curlet), last_slot, car (pars), val3); - add_slot_at_end (sc, let_id (sc->curlet), last_slot, cadr (pars), val4); -} - -static inline void -make_let_with_five_slots (s7_scheme* sc, s7_pointer func, s7_pointer val1, - s7_pointer val2, s7_pointer val3, s7_pointer val4, - s7_pointer val5) { - s7_pointer last_slot, pars= closure_pars (func); - set_curlet (sc, inline_make_let_with_two_slots (sc, closure_let (func), - car (pars), val1, cadr (pars), - val2)); - pars = cddr (pars); - last_slot= next_slot (let_slots (sc->curlet)); - last_slot= - add_slot_at_end (sc, let_id (sc->curlet), last_slot, car (pars), val3); - pars= cdr (pars); - last_slot= - add_slot_at_end (sc, let_id (sc->curlet), last_slot, car (pars), val4); - add_slot_at_end (sc, let_id (sc->curlet), last_slot, cadr (pars), val5); -} - -#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); - s7_int id = ++sc->let_number; - if ((S7_DEBUGGING) && (slot == slot_end)) - fprintf (stderr, "%s[%d]: no slot!\n", __func__, __LINE__); - 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); - s7_int 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); - const s7_int 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); - const s7_int 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_semipermanent_let (s7_scheme* sc, s7_pointer vars) { - s7_pointer slot; - const s7_pointer 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_semipermanent_slot (sc, caar (vars), sc->F); - add_semipermanent_let_or_slot (sc, slot); - symbol_set_local_slot (caar (vars), sc->let_number, slot); - let_set_slots (let, slot); - for (s7_pointer var= cdr (vars); is_pair (var); var= cdr (var)) { - s7_pointer last_slot= slot; - slot = make_semipermanent_slot (sc, caar (var), sc->F); - add_semipermanent_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); - add_semipermanent_let_or_slot ( - sc, let); /* need to mark outlet and maybe slot values */ - return (let); -} - -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 slot, s7_pointer value) { - if (slot_has_setter (slot)) - slot_set_value (slot, call_setter (sc, slot, value)); - else { - if (is_immutable_slot (slot)) - immutable_object_error_nr (sc, set_elist_3 (sc, immutable_error_string, - sc->let_set_symbol, - slot_symbol (slot))); - slot_set_value (slot, value); - } - return (slot_value (slot)); + new_cell_unchecked(sc, slot, T_SLOT); + slot_set_symbol_and_value(slot, symbol, value); + slot_set_next(slot, slot_end); + symbol_set_local_slot(symbol, id, slot); + slot_set_next(last_slot, slot); + return(slot); } -static s7_pointer -let_fill (s7_scheme* sc, s7_pointer args) { - const s7_pointer let= car (args); - s7_pointer val; - if (let == sc->rootlet) - out_of_range_error_nr (sc, sc->fill_symbol, int_one, let, - wrap_string (sc, "can't fill! rootlet", 19)); - if (let == sc->starlet) - out_of_range_error_nr (sc, sc->fill_symbol, int_one, let, - wrap_string (sc, "can't fill! *s7*", 16)); - /* (owlet) copies sc->owlet, so let can't be sc->owlet */ - if (is_funclet (let)) - out_of_range_error_nr (sc, sc->fill_symbol, int_one, let, - wrap_string (sc, "can't fill! a funclet", 21)); - val= cadr (args); - for (s7_pointer slot= let_slots (let); is_not_slot_end (slot); - slot = next_slot (slot)) - checked_slot_set_value (sc, slot, val); - return (val); +s7_pointer add_slot_checked_at_end(s7_scheme *sc, s7_uint id, s7_pointer last_slot, s7_pointer symbol, s7_pointer value) +{ /* same as above but new_cell is checked */ + s7_pointer slot; + new_cell(sc, slot, T_SLOT); + slot_set_symbol_and_value(slot, symbol, value); + slot_set_next(slot, slot_end); + symbol_set_local_slot(symbol, id, slot); + slot_set_next(last_slot, slot); + return(slot); } -static s7_int starlet_length (void); +static s7_pointer add_slot_at_end_no_local(s7_scheme *sc, s7_pointer last_slot, s7_pointer symbol, s7_pointer value) +{ + s7_pointer slot; + new_cell_unchecked(sc, slot, T_SLOT); + slot_set_symbol_and_value(slot, symbol, value); + slot_set_next(slot, slot_end); + slot_set_next(last_slot, slot); + return(slot); +} -static s7_int -let_length (s7_scheme* sc, s7_pointer let) { - /* used by length, applicable_length, copy, and some length optimizations */ - if (let == sc->rootlet) { - s7_int i= 0; - for (s7_pointer slot= sc->rootlet_slots; is_not_slot_end (slot); - i++, slot= next_slot (slot)) - ; - return (i); - } - if (let == sc->starlet) return (starlet_length ()); - if (has_active_methods (sc, let)) { - s7_pointer length_func= find_method (sc, let, sc->length_symbol); - if (length_func != sc->undefined) { - s7_pointer num= - s7_apply_function (sc, length_func, set_plist_1 (sc, let)); - return ((s7_is_integer (num)) ? s7_integer (num) : -1); /* ?? */ - } - } - { - s7_int i= 0; - for (s7_pointer slot= let_slots (let); is_not_slot_end (slot); - i++, slot= next_slot (slot)) - ; - return (i); - } +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, pars = closure_pars(func); + set_curlet(sc, inline_make_let_with_two_slots(sc, closure_let(func), car(pars), val1, cadr(pars), val2)); + last_slot = next_slot(let_slots(sc->curlet)); + add_slot_at_end(sc, let_id(sc->curlet), last_slot, caddr(pars), val3); } -static void -slot_set_setter (s7_pointer slot, s7_pointer val) { - if ((type (val) == T_C_FUNCTION) && (c_function_has_bool_setter (val))) - slot_set_setter_1 (slot, c_function_bool_setter (val)); - else slot_set_setter_1 (slot, val); +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, pars = closure_pars(func); + set_curlet(sc, inline_make_let_with_two_slots(sc, closure_let(func), car(pars), val1, cadr(pars), val2)); + pars = cddr(pars); + last_slot = next_slot(let_slots(sc->curlet)); + last_slot = add_slot_at_end(sc, let_id(sc->curlet), last_slot, car(pars), val3); + add_slot_at_end(sc, let_id(sc->curlet), last_slot, cadr(pars), val4); } -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 'name) (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_plist_2 (sc, symbol, value)); - slot_set_value (slot, value); +static inline void make_let_with_five_slots(s7_scheme *sc, s7_pointer func, s7_pointer val1, s7_pointer val2, s7_pointer val3, s7_pointer val4, s7_pointer val5) +{ + s7_pointer last_slot, pars = closure_pars(func); + set_curlet(sc, inline_make_let_with_two_slots(sc, closure_let(func), car(pars), val1, cadr(pars), val2)); + pars = cddr(pars); + last_slot = next_slot(let_slots(sc->curlet)); + last_slot = add_slot_at_end(sc, let_id(sc->curlet), last_slot, car(pars), val3); + pars = cdr(pars); + last_slot = add_slot_at_end(sc, let_id(sc->curlet), last_slot, car(pars), val4); + add_slot_at_end(sc, let_id(sc->curlet), last_slot, cadr(pars), val5); } -static void -remove_function_from_heap (s7_scheme* sc, - s7_pointer value); /* calls remove_let_from_heap */ +#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 void -remove_let_from_heap (s7_scheme* sc, s7_pointer let) { - for (s7_pointer slot= let_slots (let); is_not_slot_end (slot); - slot = next_slot (slot)) { - s7_pointer val= slot_value (slot); - if ((has_closure_let (val)) && (in_heap (closure_pars (val)))) - remove_function_from_heap (sc, val); - } - let_set_removed (let); +static s7_pointer update_let_with_slot(s7_scheme *sc, s7_pointer let, s7_pointer val) +{ + s7_pointer slot = let_slots(let); + s7_int id = ++sc->let_number; + if ((S7_DEBUGGING) && (slot == slot_end)) fprintf(stderr, "%s[%d]: no slot!\n", __func__, __LINE__); + let_set_id(let, id); + update_slot(slot, val, id); + return(let); } -static s7_pointer -funclet_entry (s7_scheme* sc, s7_pointer x, s7_pointer sym) { - if ((has_closure_let (x)) && (is_let (closure_let (x))) && - (closure_let (x) != sc->rootlet)) { - s7_pointer val= symbol_to_local_slot (sc, sym, closure_let (x)); - if ((!is_slot (val)) && (let_outlet (closure_let (x)) != sc->rootlet)) - val= symbol_to_local_slot (sc, sym, let_outlet (closure_let (x))); - if (is_slot (val)) return (slot_value (val)); - } - return (NULL); +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); + s7_int 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 void -remove_function_from_heap (s7_scheme* sc, s7_pointer value) { - remove_from_heap (sc, closure_pars (value)); - remove_from_heap ( - sc, closure_body (value)); /* this is where the compute time goes */ - /* remove closure if it's local to current func (meaning (define f (let ...) - * (lambda ...)) removes the enclosing let) */ - - { /* not sure this is worth the effort (finds 46 strings during s7test, checks - 407 functions) */ - s7_pointer val= funclet_entry (sc, value, sc->local_documentation_symbol); - if ((val) && (is_string (val)) && (in_heap (val))) petrify (sc, val); - } - { - s7_pointer let= closure_let (value); - if ((is_let (let)) && (!let_removed (let)) && (let != sc->shadow_rootlet)) { - let= let_outlet (let); - if ((is_let (let)) && (!let_removed (let)) && - (let != sc->shadow_rootlet)) { - remove_let_from_heap (sc, let); - let= let_outlet (let); - if ((is_let (let)) && (!let_removed (let)) && - (let != sc->shadow_rootlet)) - remove_let_from_heap (sc, 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); + const s7_int 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 void -add_slot_to_rootlet (s7_scheme* sc, s7_pointer slot) { - set_in_rootlet (slot); - slot_set_next (slot, sc->rootlet_slots); - sc->rootlet_slots= slot; -} - -static void -add_to_unlet (s7_scheme* sc, s7_pointer symbol) { - unlet_entry_t* new_entry= - (unlet_entry_t*) permalloc (sc, sizeof (unlet_entry_t)); - new_entry->symbol= symbol; - new_entry->next = sc->unlet_entries; - sc->unlet_entries= new_entry; -} - -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)) - immutable_object_error_nr ( - 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); /* optimization of access pointers happens later so - presumably this is safe */ - - /* 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); - if (is_immutable_slot ( - slot)) /* 2-Oct-23: (immutable! 'abs) (set! abs 3) */ - immutable_object_error_nr (sc, set_elist_3 (sc, immutable_error_string, - sc->set_symbol, symbol)); - symbol_increment_ctr (symbol); - slot_set_value_with_hook (slot, value); - return (slot); - } - - slot= make_semipermanent_slot (sc, symbol, value); - add_slot_to_rootlet (sc, slot); - set_global_slot (symbol, slot); - if (is_global ( - symbol)) /* never defined locally (symbol_id tracks let_id) */ - { - if ((!is_gensym (symbol)) && (!initial_value_is_defined (sc, symbol)) && - (!in_heap (value)) && /* else initial_value can be GC'd if symbol set! - (initial != global, initial unprotected) */ - ((!sc->string_signature) || /* from init_signatures -- maybe need a - boolean for this */ - (is_c_function (value)))) /* || (is_syntax(value)) -- we need 'else - as a special case? */ - /* the string_signature business means only the initial rootlet - * c_functions take part in unlet. It would be neat if any cload - * library's c_functions could be there as well, but then (unlet) needs to - * know which lets are in the chain. The current shadow_rootlet could be - * saved in each initial_value, these could be marked in some way, then - * the chain searched in (unlet) to get the currently active lets -- maybe - * too complex? We could also provide a way to overrule the - * string_signature check, but then symbol collisions would probably be - * resolved as the last loaded (which might not be in the active chain). - * Also, the c_function check is overly paranoid -- all we need is that - * the value is semipermanent (T_UNHEAP?). But I don't see any interesting - * omissions. - */ - { - set_initial_value (symbol, value); - if ((!sc->string_signature) && - ((is_c_function (value)) || - (is_syntax (value)))) /* syntax probably can't happen here (handled - explicitly in syntax procedure) */ - add_to_unlet (sc, symbol); - } - set_local_slot (symbol, slot); - } - symbol_increment_ctr (symbol); - if (is_gensym (symbol)) remove_gensym_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 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); + const s7_int 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_slot (s7_scheme* sc, s7_pointer variable, s7_pointer value) { +static s7_pointer make_semipermanent_let(s7_scheme *sc, s7_pointer vars) +{ s7_pointer slot; - new_cell (sc, slot, T_SLOT); - slot_set_symbol_and_value (slot, variable, value); - return (slot); + const s7_pointer 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_semipermanent_slot(sc, caar(vars), sc->F); + add_semipermanent_let_or_slot(sc, slot); + symbol_set_local_slot(caar(vars), sc->let_number, slot); + let_set_slots(let, slot); + for (s7_pointer var = cdr(vars); is_pair(var); var = cdr(var)) + { + s7_pointer last_slot = slot; + slot = make_semipermanent_slot(sc, caar(var), sc->F); + add_semipermanent_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); + add_semipermanent_let_or_slot(sc, let); /* need to mark outlet and maybe slot values */ + return(let); } -/* -------------------------------- let? -------------------------------- */ -bool -s7_is_let (s7_pointer let) { - return (is_let (let)); +s7_pointer call_setter(s7_scheme *sc, s7_pointer slot, s7_pointer old_value); + +extern inline s7_pointer checked_slot_set_value(s7_scheme *sc, s7_pointer slot, s7_pointer value) +{ + if (slot_has_setter(slot)) + slot_set_value(slot, call_setter(sc, slot, value)); + else + { + if (is_immutable_slot(slot)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->let_set_symbol, slot_symbol(slot))); + slot_set_value(slot, value); + } + return(slot_value(slot)); } -/* g_is_let is now defined in s7_scheme_predicate.c */ -#define H_is_let "(let? obj) returns #t if obj is a let." -#define Q_is_let sc->pl_bt +static s7_pointer let_fill(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer let = car(args); + s7_pointer val; + if (let == sc->rootlet) + out_of_range_error_nr(sc, sc->fill_symbol, int_one, let, wrap_string(sc, "can't fill! rootlet", 19)); + if (let == sc->starlet) + out_of_range_error_nr(sc, sc->fill_symbol, int_one, let, wrap_string(sc, "can't fill! *s7*", 16)); + /* (owlet) copies sc->owlet, so let can't be sc->owlet */ + if (is_funclet(let)) + out_of_range_error_nr(sc, sc->fill_symbol, int_one, let, wrap_string(sc, "can't fill! a funclet", 21)); + val = cadr(args); + for (s7_pointer slot = let_slots(let); is_not_slot_end(slot); slot = next_slot(slot)) + checked_slot_set_value(sc, slot, val); + return(val); +} -/* -------------------------------- funclet? -------------------------------- */ -/* g_is_funclet is now defined in s7_scheme_predicate.c */ -#define H_is_funclet \ - "(funclet? obj) returns #t if obj is a funclet (a function's environment)." -#define Q_is_funclet sc->pl_bt +static s7_int starlet_length(void); -/* -------------------------------- unlet -------------------------------- */ -static s7_pointer -g_unlet (s7_scheme* sc, s7_pointer unused_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) - - const s7_pointer result= make_let (sc, sc->curlet); - begin_temp (sc->y, result); - set_is_unlet (result); - if (global_value (sc->else_symbol) != sc->else_symbol) - add_slot_checked_with_id (sc, result, sc->else_symbol, - initial_value (sc->else_symbol)); - for (unlet_entry_t* p= sc->unlet_entries; p; p= p->next) { - s7_pointer sym= p->symbol; - if ((!is_eq_initial_value ( - sym, 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, result, sym, initial_value (sym)); +static s7_int let_length(s7_scheme *sc, s7_pointer let) +{ + /* used by length, applicable_length, copy, and some length optimizations */ + if (let == sc->rootlet) + { + s7_int i = 0; + for (s7_pointer slot = sc->rootlet_slots; is_not_slot_end(slot); i++, slot = next_slot(slot)); + return(i); + } + if (let == sc->starlet) + return(starlet_length()); + if (has_active_methods(sc, let)) + { + s7_pointer length_func = find_method(sc, let, sc->length_symbol); + if (length_func != sc->undefined) + { + s7_pointer num = s7_apply_function(sc, length_func, set_plist_1(sc, let)); + return((s7_is_integer(num)) ? s7_integer(num) : -1); /* ?? */ + }} + { + s7_int i = 0; + for (s7_pointer slot = let_slots(let); is_not_slot_end(slot); i++, slot = next_slot(slot)); + return(i); } - end_temp (sc->y); - return (result); } -/* -------------------------------- openlet? -------------------------------- */ -bool -s7_is_openlet (s7_pointer let) { - return (has_methods (let)); +void slot_set_setter(s7_pointer slot, s7_pointer val) +{ + if ((type(val) == T_C_FUNCTION) && + (c_function_has_bool_setter(val))) + slot_set_setter_1(slot, c_function_bool_setter(val)); + else slot_set_setter_1(slot, val); } -/* g_is_openlet is now defined in s7_scheme_predicate.c */ -#define H_is_openlet "(openlet? obj) returns #t if 'obj' has methods." -#define Q_is_openlet sc->pl_bt - -/* -------------------------------- openlet -------------------------------- */ -s7_pointer -s7_openlet (s7_scheme* sc, s7_pointer let) { - /* if e is not a let, the openlet bit is still set on it (c-pointer etc) */ - set_has_methods (let); - return (let); -} - -static s7_pointer -g_openlet (s7_scheme* sc, s7_pointer args) { -#define H_openlet \ - "(openlet e) tells the built-in functions that the let e might have an " \ - "over-riding method. e is returned." -#define Q_openlet \ - s7_make_signature (sc, 2, has_let_signature (sc), has_let_signature (sc)) - - const s7_pointer let= car (args); - s7_pointer new_let, func; - if (!is_let (let)) { - new_let= find_let (sc, let); - if ((!is_let (new_let)) || (new_let == sc->rootlet)) - find_let_error_nr (sc, sc->openlet_symbol, let, new_let, 1, args); - } - else new_let= let; - if ((new_let == sc->rootlet) || (new_let == sc->starlet)) - error_nr (sc, sc->out_of_range_symbol, - set_elist_2 (sc, wrap_string (sc, "can't openlet ~S", 17), let)); - if (is_unlet (new_let)) /* protect against infinite loop: (let () (define + -) - (with-let (unlet) (+ (openlet (unlet)) 2))) */ - error_nr (sc, sc->out_of_range_symbol, - set_elist_1 (sc, wrap_string (sc, "can't openlet unlet", 19))); - if ((has_active_methods (sc, let)) && - ((func= find_method (sc, new_let, sc->openlet_symbol)) != sc->undefined)) - return (s7_apply_function (sc, func, args)); - set_has_methods (let); - return (let); /* openlet and coverlet return their argument */ +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 'name) (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_plist_2(sc, symbol, value)); + slot_set_value(slot, value); } -/* -------------------------------- coverlet -------------------------------- */ -static s7_pointer -g_coverlet (s7_scheme* sc, s7_pointer args) { -#define H_coverlet "(coverlet e) undoes an earlier openlet. e is returned." -#define Q_coverlet \ - s7_make_signature (sc, 2, has_let_signature (sc), has_let_signature (sc)) - - const s7_pointer let= car (args); - s7_pointer new_let, func; - if (!is_let (let)) { - new_let= find_let (sc, let); - if ((!is_let (new_let)) || (new_let == sc->rootlet)) - find_let_error_nr (sc, sc->coverlet_symbol, let, new_let, 1, args); - } - else new_let= let; - if ((new_let == sc->rootlet) || (new_let == sc->starlet)) - error_nr (sc, sc->out_of_range_symbol, - set_elist_2 (sc, wrap_string (sc, "can't coverlet ~S", 17), let)); - if (is_unlet (new_let)) - error_nr (sc, sc->out_of_range_symbol, - set_elist_1 (sc, wrap_string (sc, "can't coverlet unlet", 20))); - if ((has_active_methods (sc, let)) && - ((func= find_method (sc, new_let, sc->coverlet_symbol)) != sc->undefined)) - return (s7_apply_function (sc, func, args)); - clear_has_methods (let); - return (let); /* mimic openlet in everything */ +static void remove_function_from_heap(s7_scheme *sc, s7_pointer value); /* calls remove_let_from_heap */ + +static void remove_let_from_heap(s7_scheme *sc, s7_pointer let) +{ + for (s7_pointer slot = let_slots(let); is_not_slot_end(slot); slot = next_slot(slot)) + { + s7_pointer val = slot_value(slot); + if ((has_closure_let(val)) && + (in_heap(closure_pars(val)))) + remove_function_from_heap(sc, val); + } + let_set_removed(let); } -/* -------------------------------- varlet -------------------------------- */ -static void -check_let_fallback (s7_scheme* sc, const s7_pointer symbol, s7_pointer let) { - if (symbol == sc->let_ref_fallback_symbol) set_has_let_ref_fallback (let); - else if (symbol == sc->let_set_fallback_symbol) - set_has_let_set_fallback (let); +static s7_pointer funclet_entry(s7_scheme *sc, s7_pointer x, s7_pointer sym) +{ + if ((has_closure_let(x)) && (is_let(closure_let(x))) && (closure_let(x) != sc->rootlet)) + { + s7_pointer val = symbol_to_local_slot(sc, sym, closure_let(x)); + if ((!is_slot(val)) && (let_outlet(closure_let(x)) != sc->rootlet)) + val = symbol_to_local_slot(sc, sym, let_outlet(closure_let(x))); + if (is_slot(val)) + return(slot_value(val)); + } + return(NULL); } -static void -append_let (s7_scheme* sc, s7_pointer new_let, s7_pointer old_let) { - if (new_let == sc->rootlet) - for (s7_pointer slot= let_slots (old_let); is_not_slot_end (slot); - slot = next_slot (slot)) { - s7_pointer sym= slot_symbol (slot), val= slot_value (slot); - if (is_slot (global_slot (sym))) set_global_value (sym, val); - else s7_make_slot (sc, sc->rootlet, sym, val); - } - else if (old_let == sc->starlet) { - const s7_pointer iter = s7_make_iterator (sc, sc->starlet); - const s7_int gc_loc= gc_protect_1 (sc, iter); - iterator_carrier (iter)= cons_unchecked (sc, sc->F, sc->F); - set_has_carrier (iter); /* so carrier is GC protected by mark_iterator */ - while (true) { - s7_pointer field= s7_iterate (sc, iter); - if (iterator_is_at_end (iter)) break; - add_slot_checked_with_id (sc, new_let, car (field), cdr (field)); - } - s7_gc_unprotect_at (sc, gc_loc); - } - else - for (s7_pointer slot= let_slots (old_let); is_not_slot_end (slot); - slot = next_slot (slot)) - add_slot_checked_with_id ( - sc, new_let, slot_symbol (slot), - slot_value (slot)); /* not add_slot here because it might run off the - free heap end */ -} - -s7_pointer -s7_varlet (s7_scheme* sc, s7_pointer let, s7_pointer symbol, s7_pointer value) { - if (!is_let (let)) - wrong_type_error_nr (sc, sc->varlet_symbol, 1, let, a_let_string); - if (!is_symbol (symbol)) - wrong_type_error_nr (sc, sc->varlet_symbol, 2, symbol, a_symbol_string); - if ((is_slot (global_slot (symbol))) && (is_syntax (global_value (symbol)))) - wrong_type_error_nr (sc, sc->varlet_symbol, 2, symbol, - wrap_string (sc, "a non-syntactic symbol", 22)); - - if (let == sc->rootlet) { - if (is_slot (global_slot (symbol))) set_global_value (symbol, value); - else s7_make_slot (sc, sc->rootlet, symbol, value); - } - else { - add_slot_checked_with_id (sc, let, symbol, value); - check_let_fallback (sc, symbol, let); +static void remove_function_from_heap(s7_scheme *sc, s7_pointer value) +{ + remove_from_heap(sc, closure_pars(value)); + remove_from_heap(sc, closure_body(value)); /* this is where the compute time goes */ + /* remove closure if it's local to current func (meaning (define f (let ...) (lambda ...)) removes the enclosing let) */ + + { /* not sure this is worth the effort (finds 46 strings during s7test, checks 407 functions) */ + s7_pointer val = funclet_entry(sc, value, sc->local_documentation_symbol); + if ((val) && (is_string(val)) && (in_heap(val))) petrify(sc, val); } - return (value); + { + s7_pointer let = closure_let(value); + if ((is_let(let)) && (!let_removed(let)) && (let != sc->shadow_rootlet)) + { + let = let_outlet(let); + if ((is_let(let)) && (!let_removed(let)) && (let != sc->shadow_rootlet)) + { + remove_let_from_heap(sc, let); + let = let_outlet(let); + if ((is_let(let)) && (!let_removed(let)) && (let != sc->shadow_rootlet)) + remove_let_from_heap(sc, let); + }}} } -static int32_t -position_of (const s7_pointer p, s7_pointer args) { - int32_t i; - for (i= 1; p != args; i++, args= cdr (args)) - ; - return (i); +static void add_slot_to_rootlet(s7_scheme *sc, s7_pointer slot) +{ + set_in_rootlet(slot); + slot_set_next(slot, sc->rootlet_slots); + sc->rootlet_slots = slot; } -s7_int -s7i_position_of (const s7_pointer p, s7_pointer args) { - return ((s7_int) position_of (p, args)); +static void add_to_unlet(s7_scheme *sc, s7_pointer symbol) +{ + unlet_entry_t *new_entry = (unlet_entry_t *)permalloc(sc, sizeof(unlet_entry_t)); + new_entry->symbol = symbol; + new_entry->next = sc->unlet_entries; + sc->unlet_entries = new_entry; } -static s7_pointer -g_varlet (s7_scheme* sc, s7_pointer args) /* varlet = with-let + define */ +s7_pointer s7_make_slot(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) { -#define H_varlet \ - "(varlet target-let ...) adds its arguments (a let, a cons: (symbol . value), or two arguments, the symbol and its value) \ -to the let target-let, and returns target-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, has_let_signature (sc), \ - s7_make_signature (sc, 3, sc->is_pair_symbol, sc->is_symbol_symbol, \ - sc->is_let_symbol), \ - sc->T) - s7_pointer let= car (args); - if (!is_let (let)) { - s7_pointer new_let= find_let (sc, let); - if ((!is_let (new_let)) || (new_let == sc->rootlet)) - find_let_error_nr (sc, sc->varlet_symbol, let, new_let, 1, args); - let= new_let; - } - if ((is_immutable_let (let)) || (let == sc->starlet)) - immutable_object_error_nr ( - sc, - set_elist_3 ( - sc, - wrap_string (sc, "can't (varlet ~{~S~^ ~}), ~S is immutable", 41), - args, let)); - - for (s7_pointer arglist= cdr (args); is_pair (arglist); - arglist = cdr (arglist)) { - s7_pointer sym, val; - const s7_pointer arg= car (arglist); - if (is_symbol (arg)) { - sym= (is_keyword (arg)) ? keyword_symbol (arg) : arg; - if (!is_pair (cdr (arglist))) - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_3 ( - sc, wrap_string (sc, "varlet: symbol ~S, but no value: ~S", 35), - arg, args)); - if (is_constant_symbol (sc, sym)) - wrong_type_error_nr (sc, sc->varlet_symbol, position_of (arglist, args), - sym, a_non_constant_symbol_string); - arglist= cdr (arglist); - val = car (arglist); - } - else if (is_let (arg)) { - if ((arg != sc->rootlet) && - (let != sc->starlet)) /* (varlet (inlet 'a 1) (rootlet)) is trouble */ - { - append_let (sc, let, arg); - if (has_let_set_fallback (arg)) set_has_let_set_fallback (let); - if (has_let_ref_fallback (arg)) set_has_let_ref_fallback (let); - } - continue; - } - else if (is_pair (arg)) { - sym= car (arg); - if (!is_symbol (sym)) - wrong_type_error_nr (sc, sc->varlet_symbol, position_of (arglist, args), - arg, a_symbol_string); - if (is_constant_symbol (sc, sym)) - wrong_type_error_nr (sc, sc->varlet_symbol, position_of (arglist, args), - sym, a_non_constant_symbol_string); - val= cdr (arg); - } - else - wrong_type_error_nr (sc, sc->varlet_symbol, position_of (arglist, args), - arg, wrap_string (sc, "a symbol, let, or cons", 22)); - - if (let == sc->rootlet) { - s7_pointer gslot= global_slot (sym); - if (is_slot (gslot)) { - if (is_immutable ( - gslot)) /* (immutable! 'abs) (varlet (rootlet) 'abs 1) */ - immutable_object_error_nr ( - sc, - set_elist_5 ( - sc, - wrap_string (sc, "~S is immutable in (varlet ~S '~S ~S)", 37), - sym, car (args), arg, val)); - slot_set_value_with_hook (global_slot (sym), val); - } - else s7_make_slot (sc, sc->rootlet, sym, val); - } - else { - check_let_fallback (sc, sym, let); - add_slot_checked_with_id (sc, let, 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!. - */ + if ((!is_let(let)) || (let == sc->rootlet)) + { + s7_pointer slot; + if (is_immutable(sc->rootlet)) + immutable_object_error_nr(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); /* optimization of access pointers happens later so presumably this is safe */ + + /* 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); + if (is_immutable_slot(slot)) /* 2-Oct-23: (immutable! 'abs) (set! abs 3) */ + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->set_symbol, symbol)); + symbol_increment_ctr(symbol); + slot_set_value_with_hook(slot, value); + return(slot); + } + + slot = make_semipermanent_slot(sc, symbol, value); + add_slot_to_rootlet(sc, slot); + set_global_slot(symbol, slot); + if (is_global(symbol)) /* never defined locally (symbol_id tracks let_id) */ + { + if ((!is_gensym(symbol)) && + (!initial_value_is_defined(sc, symbol)) && + (!in_heap(value)) && /* else initial_value can be GC'd if symbol set! (initial != global, initial unprotected) */ + ((!sc->string_signature) || /* from init_signatures -- maybe need a boolean for this */ + (is_c_function(value)))) /* || (is_syntax(value)) -- we need 'else as a special case? */ + /* the string_signature business means only the initial rootlet c_functions take part in unlet. It would be neat if any + * cload library's c_functions could be there as well, but then (unlet) needs to know which lets are in the chain. + * The current shadow_rootlet could be saved in each initial_value, these could be marked in some way, then the chain + * searched in (unlet) to get the currently active lets -- maybe too complex? We could also provide a way to overrule + * the string_signature check, but then symbol collisions would probably be resolved as the last loaded (which might not + * be in the active chain). + * Also, the c_function check is overly paranoid -- all we need is that the value is semipermanent (T_UNHEAP?). + * But I don't see any interesting omissions. + */ + { + set_initial_value(symbol, value); + if ((!sc->string_signature) && ((is_c_function(value)) || (is_syntax(value)))) /* syntax probably can't happen here (handled explicitly in syntax procedure) */ + add_to_unlet(sc, symbol); + } + set_local_slot(symbol, slot); + } + symbol_increment_ctr(symbol); + if (is_gensym(symbol)) + remove_gensym_from_heap(sc, symbol); + return(slot); } - } - return (let); + 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 */ } -/* -------------------------------- 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, \ - has_let_signature (sc), sc->is_symbol_symbol) - - s7_pointer let= car (args); - s7_int the_un_id; - if (let != sc->rootlet) { - if_method_exists_return_value (sc, let, sc->cutlet_symbol, args); - if (!is_let (let)) { - s7_pointer new_let= find_let (sc, let); - if ((!is_let (new_let)) || (new_let == sc->rootlet)) - find_let_error_nr (sc, sc->cutlet_symbol, let, new_let, 1, args); - let= new_let; - } - } - if ((is_immutable_let (let)) || (let == sc->starlet)) - immutable_object_error_nr ( - sc, set_elist_3 (sc, immutable_error_string, sc->cutlet_symbol, let)); - - /* 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! So use the next - * (unused) id. (let ((b 1)) (let ((b 2)) (cutlet (curlet) 'b)) b) - */ - the_un_id= ++sc->let_number; - - for (s7_pointer syms= cdr (args); is_pair (syms); syms= cdr (syms)) { - s7_pointer sym= car (syms); - if (!is_symbol (sym)) - wrong_type_error_nr (sc, sc->cutlet_symbol, position_of (syms, args), sym, - a_symbol_string); - if (is_keyword (sym)) sym= keyword_symbol (sym); - - if (let == sc->rootlet) { - if (!is_slot (global_slot (sym))) - error_nr (sc, sc->out_of_range_symbol, - set_elist_2 ( - sc, wrap_string (sc, "cutlet can't remove ~S", 22), sym)); - if (is_immutable (global_slot (sym))) - immutable_object_error_nr (sc, set_elist_3 (sc, immutable_error_string, - sc->cutlet_symbol, sym)); - symbol_set_id (sym, the_un_id); - set_global_value (sym, sc->undefined); - /* here we need to at least clear bits: syntactic binder clean-symbol(?) - * etc, maybe also locally */ - } - else { - s7_pointer slot; - if ((has_let_fallback (let)) && ((sym == sc->let_ref_fallback_symbol) || - (sym == sc->let_set_fallback_symbol))) - error_nr (sc, sc->out_of_range_symbol, - set_elist_2 ( - sc, wrap_string (sc, "cutlet can't remove ~S", 22), sym)); - slot= let_slots (let); - if (is_not_slot_end (slot)) { - if (slot_symbol (slot) == sym) { - if (is_immutable_slot (slot)) - immutable_object_error_nr (sc, - set_elist_3 (sc, immutable_error_string, - sc->cutlet_symbol, sym)); - let_set_slots (let, next_slot (let_slots (let))); - symbol_set_id (sym, the_un_id); - } - else { - s7_pointer last_slot= slot; - for (slot = next_slot (let_slots (let)); is_not_slot_end (slot); - last_slot= slot, slot= next_slot (slot)) - if (slot_symbol (slot) == sym) { - if (is_immutable_slot (slot)) - immutable_object_error_nr ( - sc, set_elist_3 (sc, immutable_error_string, - sc->cutlet_symbol, sym)); - symbol_set_id (sym, the_un_id); - slot_set_next (last_slot, next_slot (slot)); - break; - } - } - } - } - } - return (let); +static s7_pointer make_slot(s7_scheme *sc, s7_pointer variable, s7_pointer value) +{ + s7_pointer slot; + new_cell(sc, slot, T_SLOT); + slot_set_symbol_and_value(slot, variable, value); + return(slot); } -/* -------------------------------- sublet -------------------------------- */ -static s7_pointer -sublet_1 (s7_scheme* sc, s7_pointer let, s7_pointer bindings, - s7_pointer caller) { - const s7_pointer new_let= make_let (sc, let); - set_all_methods (new_let, let); - - if (!is_null (bindings)) { - sc->temp3= new_let; - for (s7_pointer slot= NULL, entries= bindings; is_pair (entries); - entries= cdr (entries)) { - s7_pointer entry= car (entries), sym, val; - - switch (type (entry)) { - case T_SYMBOL: - sym= (is_keyword (entry)) ? keyword_symbol (entry) : entry; - if (!is_pair (cdr (entries))) - error_nr (sc, sc->syntax_error_symbol, - set_elist_4 ( - sc, - wrap_string (sc, "~A: entry ~S, but no value: ~S", 30), - caller, entry, bindings)); - entries= cdr (entries); - val = car (entries); - break; - - case T_PAIR: /* (cons sym val) */ - sym= car (entry); - if (!is_symbol (sym)) - wrong_type_error_nr (sc, caller, 1 + position_of (entries, bindings), - entry, a_symbol_string); - if (is_keyword (sym)) sym= keyword_symbol (sym); - val= cdr (entry); - break; - - case T_LET: - if ((entry == sc->rootlet) || (new_let == sc->starlet)) continue; - append_let (sc, new_let, entry); - if (is_not_slot_end (let_slots ( - new_let))) /* make sure the end slot (slot) is correct */ - for (slot= let_slots (new_let); is_not_slot_end (next_slot (slot)); - slot= next_slot (slot)) - ; /* slot can't be local -- see below */ - continue; - default: - wrong_type_error_nr (sc, caller, 1 + position_of (entries, bindings), - entry, a_symbol_string); - } - if (is_constant_symbol (sc, sym)) - wrong_type_error_nr (sc, caller, 1 + position_of (entries, bindings), - sym, a_non_constant_symbol_string); -#if 0 - if ((is_slot(global_slot(sym))) && - (is_syntax_or_qq(global_value(sym)))) - wrong_type_error_nr(sc, caller, 2, sym, wrap_string(sc, "a non-syntactic symbol", 22)); - /* this is a local redefinition which we accept elsewhere: (let ((if 3)) if) -> 3 */ - /* so s7_inlet (which calls sublet) differs from g_inlet? which is correct? */ - /* (define (f1) (with-let (sublet (curlet)) (inlet 'quasiquote 1))) (f1) */ +/* -------------------------------- let? -------------------------------- */ +bool s7_is_let(s7_pointer let) {return(is_let(let));} -#endif - /* here we know new_let is a let and is not rootlet */ - if (!slot) slot= add_slot_checked_with_id (sc, new_let, sym, val); - else { - /* if (sc->free_heap_top <= sc->free_heap_trigger) try_to_call_gc(sc);*/ /* or maybe add add_slot_at_end_checked? */ - slot= add_slot_checked_at_end (sc, let_id (new_let), slot, sym, val); - set_local (sym); /* ? */ - } - check_let_fallback (sc, sym, new_let); - } - if ((S7_DEBUGGING) && (sc->temp3 != new_let)) - fprintf (stderr, "%s[%d]: temp3: %s\n", __func__, __LINE__, - display (sc->temp3)); - sc->temp3= sc->unused; - } - return (new_let); +/* g_is_let is now defined in s7_scheme_predicate.c */ + #define H_is_let "(let? obj) returns #t if obj is a let." + #define Q_is_let sc->pl_bt + + +/* -------------------------------- funclet? -------------------------------- */ +/* g_is_funclet is now defined in s7_scheme_predicate.c */ + #define H_is_funclet "(funclet? obj) returns #t if obj is a funclet (a function's environment)." + #define Q_is_funclet sc->pl_bt + + +/* -------------------------------- unlet -------------------------------- */ +/* g_unlet moved to s7_scheme_let.c */ + #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) + + +/* -------------------------------- openlet? -------------------------------- */ +/* s7_is_openlet moved to s7_scheme_let.c */ + +/* g_is_openlet is now defined in s7_scheme_predicate.c */ + #define H_is_openlet "(openlet? obj) returns #t if 'obj' has methods." + #define Q_is_openlet sc->pl_bt + + +/* -------------------------------- openlet -------------------------------- */ +/* s7_openlet moved to s7_scheme_let.c */ + +/* g_openlet moved to s7_scheme_let.c */ + #define H_openlet "(openlet e) tells the built-in functions that the let e might have an over-riding method. e is returned." + #define Q_openlet s7_make_signature(sc, 2, has_let_signature(sc), has_let_signature(sc)) + +/* -------------------------------- coverlet -------------------------------- */ +/* g_coverlet moved to s7_scheme_let.c */ + #define H_coverlet "(coverlet e) undoes an earlier openlet. e is returned." + #define Q_coverlet s7_make_signature(sc, 2, has_let_signature(sc), has_let_signature(sc)) + + +/* -------------------------------- varlet -------------------------------- */ +/* check_let_fallback moved to s7_scheme_let.c */ + +/* append_let moved to s7_scheme_let.c */ + +/* s7_varlet moved to s7_scheme_let.c */ + +int32_t position_of(const s7_pointer p, s7_pointer args) +{ + int32_t i; + for (i = 1; p != args; i++, args = cdr(args)); + return(i); } -s7_pointer -s7_sublet (s7_scheme* sc, s7_pointer let, s7_pointer bindings) { - return (sublet_1 (sc, let, bindings, sc->sublet_symbol)); +s7_int s7i_position_of(const s7_pointer p, s7_pointer args) +{ + return((s7_int)position_of(p, args)); } -static s7_pointer -g_sublet (s7_scheme* sc, s7_pointer args) { -#define H_sublet \ - "(sublet lt ...) makes a new let (an environment) within the environment " \ - "'lt', initializing it with the bindings" -#define Q_sublet Q_varlet +/* g_varlet moved to s7_scheme_let.c */ + #define H_varlet "(varlet target-let ...) adds its arguments (a let, a cons: (symbol . value), or two arguments, the symbol and its value) \ +to the let target-let, and returns target-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, has_let_signature(sc), \ + s7_make_signature(sc, 3, sc->is_pair_symbol, sc->is_symbol_symbol, sc->is_let_symbol), sc->T) + + +/* -------------------------------- cutlet -------------------------------- */ +/* g_cutlet moved to s7_scheme_let.c */ + #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, has_let_signature(sc), sc->is_symbol_symbol) + + +/* -------------------------------- sublet -------------------------------- */ +/* sublet_1 moved to s7_scheme_let.c */ + +/* s7_sublet moved to s7_scheme_let.c */ + +/* g_sublet moved to s7_scheme_let.c */ + #define H_sublet "(sublet lt ...) makes a new let (an environment) within the environment 'lt', initializing it with the bindings" + #define Q_sublet Q_varlet + +/* g_sublet_curlet moved to s7_scheme_let.c */ + +/* sublet_chooser moved to s7_scheme_let.c */ - s7_pointer let= car (args); - if (!is_let (let)) { - s7_pointer new_let= find_let (sc, let); - if ((!is_let (new_let)) || (new_let == sc->rootlet)) - find_let_error_nr (sc, sc->sublet_symbol, let, new_let, 1, args); - let= new_let; - } - return (sublet_1 (sc, let, cdr (args), sc->sublet_symbol)); -} - -static s7_pointer -g_sublet_curlet (s7_scheme* sc, s7_pointer args) { - s7_pointer sym= cadr (args), new_let; - if_let_method_exists_return_value (sc, sc->curlet, sc->sublet_symbol, - args); /* curlet is a let so... */ - new_let= inline_make_let_with_slot (sc, sc->curlet, sym, caddr (args)); - set_all_methods (new_let, sc->curlet); - check_let_fallback (sc, sym, new_let); - return (new_let); -} - -static s7_pointer -sublet_chooser (s7_scheme* sc, s7_pointer func, int32_t num_args, - s7_pointer expr) { - if (num_args == 3) { - s7_pointer args= cdr (expr); - if ((is_pair (car (args))) && (caar (args) == sc->curlet_symbol) && - (is_null (cdar (args))) && (is_quoted_symbol (sc, cadr (args)))) - return (sc->sublet_curlet); - } - return (func); -} /* -------------------------------- 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 symbol/value pair, \ +/* s7_inlet moved to s7_scheme_let.c */ + #define H_inlet "(inlet ...) adds its arguments, each a let, a cons: '(symbol . value), or a symbol/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 Q_inlet s7_make_circular_signature(sc, 1, 2, sc->is_let_symbol, sc->T) #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, no syntax, etc */ - const s7_pointer new_let= make_let (sc, sc->rootlet); - const s7_int id = let_id (new_let); +/* g_simple_inlet moved to s7_scheme_let.c */ - begin_temp (sc->temp6, new_let); - for (s7_pointer x= args, last_slot= NULL; 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) */ - { - end_temp (sc->temp6); - wrong_type_error_nr (sc, sc->inlet_symbol, 1, symbol, - a_non_constant_symbol_string); - } - if (!last_slot) { - add_slot_unchecked (sc, new_let, symbol, cadr (x), id); - last_slot= let_slots (new_let); - } - else - last_slot= add_slot_checked_at_end (sc, id, last_slot, symbol, cadr (x)); - } - end_temp (sc->temp6); - return (new_let); -} - -static s7_pointer -inlet_p_pp (s7_scheme* sc, s7_pointer symbol, s7_pointer value) { - if (!is_symbol (symbol)) - return (sublet_1 (sc, sc->rootlet, set_plist_2 (sc, symbol, value), - sc->inlet_symbol)); - if (is_keyword (symbol)) symbol= keyword_symbol (symbol); - if (is_constant_symbol (sc, symbol)) - wrong_type_error_nr (sc, sc->inlet_symbol, 1, symbol, - a_non_constant_symbol_string); - if ((is_defined_global (symbol)) && (is_syntax_or_qq (global_value (symbol)))) - wrong_type_error_nr (sc, sc->inlet_symbol, 1, symbol, - wrap_string (sc, "a non-syntactic symbol", 22)); - { - s7_pointer new_let; - new_cell (sc, new_let, T_LET | T_SAFE_PROCEDURE); - begin_temp (sc->x, new_let); - let_set_id (new_let, ++sc->let_number); - let_set_outlet (new_let, sc->rootlet); - let_set_slots (new_let, slot_end); - add_slot_unchecked (sc, new_let, symbol, value, let_id (new_let)); - end_temp (sc->x); - return (new_let); - } -} +/* inlet_p_pp moved to s7_scheme_let.c */ -static s7_pointer -internal_inlet (s7_scheme* sc, s7_int num_args, ...) /* used in *->let */ -{ - va_list ap; - const s7_pointer new_let = make_let (sc, sc->rootlet); - const s7_int id = let_id (new_let); - s7_pointer last_slot= NULL; +/* internal_inlet moved to s7_scheme_let.c */ - begin_temp (sc->x, new_let); - va_start (ap, num_args); - for (s7_int i= 0; i < num_args; i+= 2) { - s7_pointer symbol= T_Sym (va_arg (ap, s7_pointer)); - s7_pointer value = T_Ext (va_arg (ap, s7_pointer)); - if (!last_slot) { - add_slot_unchecked (sc, new_let, symbol, value, id); - last_slot= let_slots (new_let); - } - else last_slot= add_slot_at_end (sc, id, last_slot, symbol, value); - } - va_end (ap); - end_temp (sc->x); - return (new_let); +bool is_proper_quote(s7_scheme *sc, s7_pointer p) +{ + return((is_safe_quoted_pair(sc, p)) && + (is_pair(cdr(p))) && + (is_null(cddr(p)))); } -static bool -is_proper_quote (s7_scheme* sc, s7_pointer p) { - return ((is_safe_quoted_pair (sc, p)) && (is_pair (cdr (p))) && - (is_null (cddr (p)))); -} +/* inlet_chooser moved to s7_scheme_let.c */ -static s7_pointer -inlet_chooser (s7_scheme* sc, s7_pointer func, int32_t args, s7_pointer expr) { - if ((args > 0) && ((args % 2) == 0)) { - for (s7_pointer p= cdr (expr); is_pair (p); p= cddr (p)) { - s7_pointer sym; - if (is_symbol_and_keyword (car (p))) /* (inlet :if ...) */ - sym= keyword_symbol (car (p)); - else { - if (!is_proper_quote (sc, car (p))) return (func); /* (inlet abs ...) */ - sym= cadar (p); /* looking for (inlet 'a ...) */ - if (!is_symbol (sym)) return (func); /* (inlet '(a . 3) ...) */ - if (is_keyword (sym)) sym= keyword_symbol (sym); /* (inlet ':abs ...) */ - } - if ((is_possibly_constant ( - sym)) || /* (inlet 'define-constant ...) or (inlet 'pi ...) */ - (is_syntactic_symbol (sym)) || /* (inlet 'if 3) */ - ((is_slot (global_slot (sym))) && - (is_syntax_or_qq ( - global_value (sym)))) || /* (inlet 'quasiquote 1) */ - (sym == sc->let_ref_fallback_symbol) || - (sym == sc->let_set_fallback_symbol)) - return (func); - } - return (sc->simple_inlet); - } - return (func); -} -/* -------------------------------- let->list -------------------------------- - */ -static s7_pointer proper_list_reverse_in_place (s7_scheme* sc, s7_pointer list); - -static s7_pointer -abbreviate_let (s7_scheme* sc, s7_pointer val) { - if (is_let (val)) return (make_symbol (sc, "", 11)); - return (val); -} - -s7_pointer -s7_let_to_list (s7_scheme* sc, s7_pointer let) { - if (let == sc->rootlet) { - begin_temp (sc->temp6, sc->nil); - for (s7_pointer lib= global_value (sc->libraries_symbol); is_pair (lib); - lib = cdr (lib)) - sc->temp6= cons (sc, caar (lib), sc->temp6); - sc->temp6= cons (sc, cons (sc, sc->libraries_symbol, sc->temp6), sc->nil); - for (s7_pointer slot= sc->rootlet_slots; is_not_slot_end (slot); - slot = next_slot (slot)) - if (slot_symbol (slot) != sc->libraries_symbol) - sc->temp6= - cons_unchecked (sc, - cons (sc, slot_symbol (slot), - abbreviate_let (sc, slot_value (slot))), - sc->temp6); - { - s7_pointer result= proper_list_reverse_in_place (sc, sc->temp6); - end_temp (sc->temp6); - return (result); - } - } - else { - s7_pointer iter, func; - s7_int gc_loc= -1; - /* need to check make-iterator method before dropping into let->list */ - sc->temp3= sc->w; - sc->w = sc->nil; - - if ((has_active_methods (sc, let)) && - ((func= find_method (sc, let, sc->make_iterator_symbol)) != - sc->undefined)) - iter= s7_apply_function (sc, func, set_plist_1 (sc, let)); - else if (let == - sc->starlet) /* (let->list *s7*) via starlet_make_iterator */ - { - iter = s7_make_iterator (sc, let); - gc_loc= gc_protect_1 (sc, iter); - } - else iter= sc->nil; - - if (is_null (iter)) - for (s7_pointer slot= let_slots (let); is_not_slot_end (slot); - slot = next_slot (slot)) - sc->w= cons_unchecked ( - sc, cons (sc, slot_symbol (slot), slot_value (slot)), sc->w); - else - /* (begin (load "mockery.scm") (let ((lt ((*mock-pair* 'mock-pair) 1 2 - * 3))) (format *stderr* "~{~A ~}" lt))) */ - while (true) { - s7_pointer val= s7_iterate (sc, iter); - if (iterator_is_at_end (iter)) break; - sc->w= cons (sc, val, sc->w); - } - sc->w= proper_list_reverse_in_place (sc, sc->w); - if (gc_loc != -1) s7_gc_unprotect_at (sc, gc_loc); - { - s7_pointer result= sc->w; - sc->w = sc->temp3; - sc->temp3 = sc->unused; - return (result); - } - } -} +/* -------------------------------- let->list -------------------------------- */ +s7_pointer proper_list_reverse_in_place(s7_scheme *sc, s7_pointer list); + +/* abbreviate_let moved to s7_scheme_let.c */ + +/* s7_let_to_list moved to s7_scheme_let.c */ + +/* g_let_to_list moved to s7_scheme_let.c */ + #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, has_let_signature(sc)) -#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, has_let_signature (sc)) - - s7_pointer let= car (args); - if_method_exists_return_value (sc, let, sc->let_to_list_symbol, args); - if (!is_let (let)) { - s7_pointer new_let= find_let (sc, let); - if ((!is_let (new_let)) || (new_let == sc->rootlet)) - find_let_error_nr (sc, sc->let_to_list_symbol, let, new_let, 1, args); - /* this is not (let->list (rootlet)) but (say) (let->list func) which - * defaults in find_let to rootlet */ - let= new_let; - } - return (s7_let_to_list (sc, let)); -} -/* *s7* in gdb: p display(s7_let_to_list(sc, sc->starlet)) */ -#endif /* -------------------------------- let-ref -------------------------------- */ -static s7_pointer -call_let_ref_fallback (s7_scheme* sc, s7_pointer let, s7_pointer symbol) { - s7_pointer result; - const s7_pointer val= find_method (sc, let, sc->let_ref_fallback_symbol); - /* (let ((x #f)) (let begin ((x 1234)) (begin 1) 2)) -> stack overflow - * eventually, but should we try to catch it? */ - if (!is_applicable (val)) return (val); - push_stack_no_let (sc, OP_GC_PROTECT, sc->value, sc->code); - result= s7_apply_function (sc, val, set_qlist_2 (sc, let, symbol)); - unstack_gc_protect (sc); - sc->code = T_Pos (stack_end_code (sc)); /* can be # */ - sc->value= T_Ext (stack_end_args (sc)); - return (result); -} - -static s7_pointer -call_let_set_fallback (s7_scheme* sc, s7_pointer let, s7_pointer symbol, - s7_pointer value) { - s7_pointer result; - push_stack_no_let (sc, OP_GC_PROTECT, sc->value, sc->code); - result= - s7_apply_function (sc, find_method (sc, let, sc->let_set_fallback_symbol), - set_qlist_3 (sc, let, symbol, value)); - unstack_gc_protect (sc); - sc->code = T_Pos (stack_end_code (sc)); - sc->value= T_Ext (stack_end_args (sc)); - return (result); -} +/* call_let_ref_fallback moved to s7_scheme_let.c */ + +/* call_let_set_fallback moved to s7_scheme_let.c */ /* g_unlet_disabled is now defined in s7_scheme_predicate.c */ -/* we need a self-id here for let_ref, but it needs to be a real s7_cell, not - * g_unlet_disabled itself, hence sc->unlet_disabled */ - -static /* inline */ s7_pointer -let_ref (s7_scheme* sc, s7_pointer let, s7_pointer symbol) { - /* (let ((a 1)) ((curlet) 'a)) or ((rootlet) 'abs) */ - if (!is_let (let)) { - s7_pointer new_let; - if (let == sc->unlet_disabled) return (initial_value (symbol)); - new_let= find_let (sc, let); - if ((!is_let (new_let)) || (new_let == sc->rootlet)) - find_let_error_nr (sc, sc->let_ref_symbol, let, new_let, 1, - set_mlist_2 (sc, let, symbol)); - let= new_let; - } - if (!is_symbol (symbol)) { - if ((let != sc->rootlet) && - (has_let_ref_fallback ( - let))) /* let-ref|set-fallback refer to (explicit) let-ref in - various forms, not the method lookup process */ - return (call_let_ref_fallback (sc, let, symbol)); - wrong_type_error_nr (sc, sc->let_ref_symbol, 2, symbol, a_symbol_string); - } - /* 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. What - * about other let-as-first-arg funcs? - */ +/* we need a self-id here for let_ref, but it needs to be a real s7_cell, not g_unlet_disabled itself, hence sc->unlet_disabled */ - if (let_id (let) == symbol_id (symbol)) - return (local_value (symbol)); /* this has to follow the rootlet check(?) */ +/* let_ref moved to s7_scheme_let.c */ - if (is_keyword (symbol)) symbol= keyword_symbol (symbol); - if (let == sc->rootlet) - return ((is_slot (global_slot (symbol))) ? global_value (symbol) - : sc->undefined); - - for (s7_pointer e= let; e; e= let_outlet (e)) - for (s7_pointer slot= let_slots (e); is_not_slot_end (slot); - slot = next_slot (slot)) - if (slot_symbol (slot) == symbol) return (slot_value (slot)); - - if (is_openlet (let)) { - /* 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)); - } - return ((is_slot (global_slot (symbol))) - ? global_value (symbol) - : sc->undefined); /* (let () ((curlet) 'pi)) */ -} - -s7_pointer -s7_let_ref (s7_scheme* sc, s7_pointer let, s7_pointer symbol) { - return (let_ref (sc, let, symbol)); -} - -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, has_let_signature (sc), sc->is_symbol_symbol) - if (!is_pair (cdr (args))) - error_nr (sc, sc->syntax_error_symbol, - set_elist_2 (sc, - wrap_string (sc, "let-ref: symbol missing: ~S", 27), - set_ulist_1 (sc, sc->let_ref_symbol, args))); - return (let_ref (sc, car (args), cadr (args))); -} - -static s7_pointer -slot_in_let (s7_scheme* sc, s7_pointer let, const s7_pointer sym) { - for (s7_pointer slot= let_slots (let); is_not_slot_end (slot); - slot = next_slot (slot)) - if (slot_symbol (slot) == sym) return (slot); - return (sc->undefined); -} - -static s7_pointer -let_ref_p_pp (s7_scheme* sc, s7_pointer let, s7_pointer sym) { - if (let_id (let) == symbol_id (sym)) - return (local_value (sym)); /* see add in tlet! */ - if (let == sc->rootlet) /* op_implicit_let_ref_c can pass rootlet */ - return ((is_slot (global_slot (sym))) ? global_value (sym) : sc->undefined); - for (s7_pointer e= let; e; e= let_outlet (e)) - for (s7_pointer slot= let_slots (e); is_not_slot_end (slot); - slot = next_slot (slot)) - if (slot_symbol (slot) == sym) return (slot_value (slot)); - if (has_let_ref_fallback (let)) return (call_let_ref_fallback (sc, let, sym)); - return ((is_slot (global_slot (sym))) ? global_value (sym) : sc->undefined); -} - -static inline s7_pointer -g_cdr_let_ref (s7_scheme* sc, s7_pointer args) { - const s7_pointer let= car (args), sym= cadr (args); - if (!is_let (let)) - wrong_type_error_nr (sc, sc->let_ref_symbol, 1, let, a_let_string); - if (let_id (let) == symbol_id (sym)) return (local_value (sym)); - if (let == sc->rootlet) - return ((is_slot (global_slot (sym))) ? global_value (sym) : sc->undefined); - for (s7_pointer slot= let_slots (let); is_not_slot_end (slot); - slot = next_slot (slot)) - if (slot_symbol (slot) == sym) return (slot_value (slot)); - return (let_ref_p_pp (sc, let_outlet (let), sym)); -} - -static s7_pointer starlet (s7_scheme* sc, s7_int choice); -s7_pointer -g_starlet_ref (s7_scheme* sc, s7_pointer args) { - return (starlet (sc, starlet_symbol_id (cadr (args)))); -} - -static s7_pointer -g_rootlet_ref (s7_scheme* sc, s7_pointer args) { - s7_pointer sym= cadr (args); - return ((is_slot (global_slot (sym))) ? global_value (sym) : sc->undefined); -} - -static s7_pointer -let_ref_chooser (s7_scheme* sc, s7_pointer func, int32_t unused_args, - s7_pointer expr) { - const s7_pointer arg1= cadr (expr), arg2= caddr (expr); - if ((is_quoted_symbol (sc, arg2)) && (!is_keyword (cadr (arg2)))) { - if (is_pair (arg1)) { - if ((optimize_op (expr) == HOP_SAFE_C_opSq_C) && - (car (arg1) == sc->cdr_symbol)) { - set_opt3_sym (cdr (expr), cadr (arg2)); - return (sc->cdr_let_ref); - } - if (car (arg1) == sc->rootlet_symbol) return (sc->rootlet_ref); - if (car (arg1) == sc->curlet_symbol) return (sc->curlet_ref); - if (car (arg1) == sc->unlet_symbol) { - set_fn_direct (arg1, g_unlet_disabled); - return (sc->unlet_ref); - } - } - if (arg1 == sc->starlet_symbol) - return (sc->starlet_ref); /* should *curlet* be added? */ - } - return (func); -} +/* s7_let_ref moved to s7_scheme_let.c */ -static bool -op_implicit_let_ref_c (s7_scheme* sc) { - s7_pointer let= lookup_checked (sc, car (sc->code)); - if (!is_let (let)) { - sc->last_function= let; - return (false); - } - sc->value= let_ref_p_pp (sc, let, opt3_con (sc->code)); - return (true); +/* g_let_ref moved to s7_scheme_let.c */ + #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, has_let_signature(sc), sc->is_symbol_symbol) + +/* slot_in_let moved to s7_scheme_let.c */ + +/* let_ref_p_pp moved to s7_scheme_let.c */ + +/* g_cdr_let_ref moved to s7_scheme_let.c */ + +s7_pointer starlet(s7_scheme *sc, s7_int choice); +/* g_starlet_ref moved to s7_scheme_let.c */ + + +/* g_rootlet_ref moved to s7_scheme_let.c */ + +/* let_ref_chooser moved to s7_scheme_let.c */ + +static bool op_implicit_let_ref_c(s7_scheme *sc) +{ + s7_pointer let = lookup_checked(sc, car(sc->code)); + if (!is_let(let)) {sc->last_function = let; return(false);} + sc->value = let_ref_p_pp(sc, let, opt3_con(sc->code)); + return(true); } -static bool -op_implicit_let_ref_a (s7_scheme* sc) { - s7_pointer sym, let= lookup_checked (sc, car (sc->code)); - if (!is_let (let)) { - sc->last_function= let; - return (false); - } - sym= fx_call (sc, cdr (sc->code)); - if (is_symbol (sym)) - sc->value= - let_ref_p_pp (sc, let, (is_keyword (sym)) ? keyword_symbol (sym) : sym); - else sc->value= let_ref (sc, let, sym); - return (true); +static bool op_implicit_let_ref_a(s7_scheme *sc) +{ + s7_pointer sym, let = lookup_checked(sc, car(sc->code)); + if (!is_let(let)) {sc->last_function = let; return(false);} + sym = fx_call(sc, cdr(sc->code)); + if (is_symbol(sym)) + sc->value = let_ref_p_pp(sc, let, (is_keyword(sym)) ? keyword_symbol(sym) : sym); + else sc->value = let_ref(sc, let, sym); + return(true); } -static s7_pointer -fx_implicit_let_ref_c (s7_scheme* sc, s7_pointer arg) { - s7_pointer let= lookup_checked (sc, car (arg)); /* the let */ - if (!is_let (let)) - return (s7_apply_function (sc, let, list_1 (sc, opt3_con (arg)))); - return (let_ref_p_pp (sc, let, opt3_con (arg))); +static s7_pointer fx_implicit_let_ref_c(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer let = lookup_checked(sc, car(arg)); /* the let */ + if (!is_let(let)) + return(s7_apply_function(sc, let, list_1(sc, opt3_con(arg)))); + return(let_ref_p_pp(sc, let, opt3_con(arg))); } + /* -------------------------------- let-set! -------------------------------- */ -static s7_pointer -let_set_1 (s7_scheme* sc, s7_pointer let, s7_pointer symbol, s7_pointer value) { - if (is_keyword (symbol)) symbol= keyword_symbol (symbol); - - if (let == sc->rootlet) { - s7_pointer slot; - if (is_constant_symbol (sc, symbol)) /* (let-set! (rootlet) 'pi #f) */ - wrong_type_error_nr (sc, sc->let_set_symbol, 2, symbol, - a_non_constant_symbol_string); - /* it would be nice if safety>0 to add an error check for bad arity if a - * built-in method is set (set! (lt 'write) hash-table-set!), built_in being - * (initial_value_is_defined(sc, sym)), but this function is called a ton, - * and this error can't easily be checked by the optimizer (we see the - * names, but not the values, so bad arity check requires assumptions about - * those values). - */ - slot= global_slot (symbol); - if (!is_slot (slot)) - error_nr (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 (slot))) - wrong_type_error_nr (sc, sc->let_set_symbol, 2, symbol, - wrap_string (sc, "a non-syntactic symbol", 22)); - if (is_immutable (slot)) - immutable_object_error_nr ( - sc, - set_elist_2 (sc, wrap_string (sc, "~S is immutable in (rootlet)", 28), - symbol)); /* also (set! (with-let...)...) */ - symbol_increment_ctr (symbol); - slot_set_value ( - slot, (slot_has_setter (slot)) ? call_setter (sc, slot, value) : value); - return (slot_value (slot)); - } - if (is_unlet (let)) - immutable_object_error_nr ( - sc, set_elist_2 (sc, wrap_string (sc, "~S is immutable in (unlet)", 26), - symbol)); - if (let_id (let) == symbol_id (symbol)) { - s7_pointer slot= local_slot (symbol); - if (is_slot (slot)) { - symbol_increment_ctr (symbol); - return (checked_slot_set_value (sc, slot, value)); - } - } - for (s7_pointer e= let; e; e= let_outlet (e)) - for (s7_pointer slot= let_slots (e); is_not_slot_end (slot); - slot = next_slot (slot)) - if (slot_symbol (slot) == symbol) { - symbol_increment_ctr (symbol); - return (checked_slot_set_value (sc, slot, value)); - } - if (!has_let_set_fallback (let)) - error_nr (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? */ - return (call_let_set_fallback (sc, let, symbol, value)); -} - -static s7_pointer -let_set_2 (s7_scheme* sc, s7_pointer let, s7_pointer symbol, s7_pointer value) { - if (!is_let (let)) { - s7_pointer new_let= find_let (sc, let); - if (!is_let (new_let)) - find_let_error_nr (sc, sc->let_set_symbol, let, new_let, 1, - set_plist_3 (sc, let, symbol, value)); - let= new_let; - } - if (!is_symbol (symbol)) { - if ((let != sc->rootlet) && (has_let_set_fallback (let))) - return (call_let_set_fallback (sc, let, symbol, value)); - wrong_type_error_nr (sc, sc->let_set_symbol, 2, symbol, a_symbol_string); - } - /* currently let-set! is immutable, so we don't have to check for a let-set! - * method (so let_set! is always global) */ - return (let_set_1 (sc, let, symbol, value)); -} - -s7_pointer -s7_let_set (s7_scheme* sc, s7_pointer let, s7_pointer symbol, - s7_pointer value) { - return (let_set_2 (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, has_let_signature (sc), \ - sc->is_symbol_symbol, sc->T) - - if (!is_pair (cdr (args))) /* (let ((a 123.0)) (define (f) (set! (let-ref) a)) - (catch #t f (lambda args #f)) (f)) */ - error_nr (sc, sc->wrong_number_of_args_symbol, - set_elist_3 (sc, - wrap_string (sc, "~S: not enough arguments: ~S", 28), - sc->let_set_symbol, sc->code)); - - return (let_set_2 (sc, car (args), cadr (args), caddr (args))); -} - -static s7_pointer -let_set_p_ppp_2 (s7_scheme* sc, s7_pointer let, s7_pointer sym, - s7_pointer val) { - if (!is_symbol (sym)) - wrong_type_error_nr (sc, sc->let_set_symbol, 2, sym, a_symbol_string); - return (let_set_1 (sc, let, sym, val)); -} - -static s7_pointer -g_cdr_let_set (s7_scheme* sc, s7_pointer args) { - s7_pointer let= car (args); - const s7_pointer sym= cadr (args), val= caddr (args); - if (!is_let (let)) { - s7_pointer new_let= find_let (sc, let); - if (!is_let (new_let)) - find_let_error_nr (sc, sc->let_set_symbol, let, new_let, 1, args); - let= new_let; - } - if (let != sc->rootlet) { - for (s7_pointer e= let; e; e= let_outlet (e)) - for (s7_pointer slot= let_slots (e); is_not_slot_end (slot); - slot = next_slot (slot)) - if (slot_symbol (slot) == sym) { - slot_set_value (slot, (slot_has_setter (slot)) - ? call_setter (sc, slot, val) - : val); - return (slot_value (slot)); - } - if ((let != sc->rootlet) && (has_let_set_fallback (let))) - return (call_let_set_fallback (sc, let, sym, val)); - } - { - s7_pointer slot= global_slot (sym); - if (!is_slot (slot)) - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_3 ( - sc, - wrap_string (sc, "let-set!: ~A is not defined in ~A", 33), - sym, let)); - slot_set_value (slot, (slot_has_setter (slot)) ? call_setter (sc, slot, val) - : val); - return (slot_value (slot)); - } -} +/* let_set_1 moved to s7_scheme_let.c */ -s7_pointer starlet_set_1 (s7_scheme* sc, s7_pointer sym, s7_pointer val); - -static s7_pointer -g_starlet_set (s7_scheme* sc, s7_pointer args) { - s7_pointer sym= cadr (args); - if (!is_symbol (sym)) /* (let () (define (func) (let-set! *s7* '(1 . 2) - (hash-table))) (func) (func)) */ - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_3 (sc, - wrap_string (sc, - "(let-set! *s7* ~A ...) second " - "argument is ~A but should be a symbol", - 67), - sym, object_type_name (sc, sym))); - if (is_keyword (sym)) sym= keyword_symbol (sym); - if (starlet_symbol_id (sym) == sl_no_field) - error_nr ( - 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 (starlet_set_1 (sc, sym, caddr (args))); -} - -static s7_pointer -g_unlet_set (s7_scheme* sc, s7_pointer args) { - immutable_object_error_nr ( - sc, set_elist_2 (sc, wrap_string (sc, "~S is immutable in (unlet)", 26), - cadr (args))); - return (sc->F); -} - -static s7_pointer -let_set_chooser (s7_scheme* sc, s7_pointer func, int32_t unused_args, - s7_pointer expr) { - const s7_pointer arg1= cadr (expr); - if (optimize_op (expr) == HOP_SAFE_C_opSq_CS) { - const s7_pointer arg2= caddr (expr), arg3= cadddr (expr); - if ((car (arg1) == sc->cdr_symbol) && (is_quoted_symbol (sc, arg2)) && - (!is_possibly_constant (cadr (arg2))) && /* assumes T_Sym */ - (!is_possibly_constant (arg3))) - return (sc->cdr_let_set); - if (car (arg1) == sc->unlet_symbol) { - set_fn_direct (arg1, g_unlet_disabled); - return (sc->unlet_set); - } - } - if (arg1 == sc->starlet_symbol) return (sc->starlet_set); - return (func); -} - -static s7_pointer -reverse_slots (s7_pointer let_slots) { - s7_pointer slot= let_slots, result= slot_end; - while (is_not_slot_end (slot)) { - s7_pointer nextslot= next_slot (slot); - slot_set_next (slot, result); - result= slot; - slot = nextslot; - } - return (result); -} +/* let_set_2 moved to s7_scheme_let.c */ + +/* s7_let_set moved to s7_scheme_let.c */ + +/* g_let_set moved to s7_scheme_let.c */ + #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, has_let_signature(sc), sc->is_symbol_symbol, sc->T) + +/* let_set_p_ppp_2 moved to s7_scheme_let.c */ + +/* g_cdr_let_set moved to s7_scheme_let.c */ + +s7_pointer starlet_set_1(s7_scheme *sc, s7_pointer sym, s7_pointer val); + +/* g_starlet_set moved to s7_scheme_let.c */ + +/* g_unlet_set moved to s7_scheme_let.c */ + +/* let_set_chooser moved to s7_scheme_let.c */ + + +/* reverse_slots moved to s7_scheme_let.c */ + +/* let_copy moved to s7_scheme_let.c */ -static s7_pointer -let_copy (s7_scheme* sc, s7_pointer let) { - s7_pointer new_let; - if (T_Let (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_let= make_let (sc, let_outlet (let)); - set_all_methods (new_let, let); - begin_temp (sc->x, new_let); - if (is_not_slot_end (let_slots (let))) { - const s7_int id= let_id (new_let); - for (s7_pointer last_slot= NULL, slot= let_slots (let); - is_not_slot_end (slot); slot= next_slot (slot)) { - s7_pointer new_slot; - new_cell (sc, new_slot, T_SLOT); - slot_set_symbol_and_value (new_slot, slot_symbol (slot), - slot_value (slot)); - if (symbol_id (slot_symbol (new_slot)) != id) /* keep shadowing intact */ - symbol_set_local_slot (slot_symbol (slot), id, new_slot); - if (slot_has_setter (slot)) { - slot_set_setter (new_slot, slot_setter (slot)); - slot_set_has_setter (new_slot); - } - if (last_slot) slot_set_next (last_slot, new_slot); - else let_set_slots (new_let, new_slot); - slot_set_next (new_slot, slot_end); /* in case GC runs during this loop */ - last_slot= new_slot; - } - } - /* 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))))) - */ - end_temp (sc->x); - return (new_let); -} /* -------------------------------- rootlet -------------------------------- */ /* g_rootlet is now defined in s7_scheme_predicate.c */ -#define H_rootlet \ - "(rootlet) returns the current top-level definitions (symbol bindings)." -#define Q_rootlet s7_make_signature (sc, 1, sc->is_let_symbol) + #define H_rootlet "(rootlet) returns the current top-level definitions (symbol bindings)." + #define Q_rootlet s7_make_signature(sc, 1, sc->is_let_symbol) -s7_pointer -s7_rootlet (s7_scheme* sc) { - return (sc->rootlet); -} +/* s7_rootlet moved to s7_scheme_let.c */ -/* 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). +/* 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_shadow_rootlet moved to s7_scheme_let.c */ + +/* s7_set_shadow_rootlet moved to s7_scheme_let.c */ -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 -------------------------------- */ -s7_pointer -s7_curlet (s7_scheme* sc) /* see also fx_curlet */ -{ - sc->capture_let_counter++; - return (sc->curlet); -} +/* s7_curlet moved to s7_scheme_let.c */ /* g_curlet is now defined in s7_scheme_predicate.c */ #define H_curlet "(curlet) returns the current definitions (symbol bindings)" -#define Q_curlet s7_make_signature (sc, 1, sc->is_let_symbol) - -static void -update_symbol_ids (s7_scheme* sc, s7_pointer let) { - for (s7_pointer slot= let_slots (let); is_not_slot_end (slot); - slot = next_slot (slot)) { - s7_pointer sym= slot_symbol (slot); - if (symbol_id (sym) != sc->let_number) - symbol_set_local_slot_unincremented (sym, sc->let_number, slot); - } -} +#define Q_curlet s7_make_signature(sc, 1, sc->is_let_symbol) + +/* update_symbol_ids moved to s7_scheme_let.c */ + +/* s7_set_curlet moved to s7_scheme_let.c */ -s7_pointer -s7_set_curlet (s7_scheme* sc, s7_pointer let) { - const s7_pointer old_let= sc->curlet; - if (is_let (let)) { - set_curlet (sc, let); - if (let_id (let) > 0) { - let_set_id (let, ++sc->let_number); - update_symbol_ids (sc, let); - } - } - return (old_let); -} /* -------------------------------- outlet -------------------------------- */ -s7_pointer -s7_outlet (s7_scheme* sc, s7_pointer let) { - return (let_outlet (let)); -} - -static s7_pointer -outlet_p_p (s7_scheme* sc, s7_pointer let) { - if (!is_let (let)) { - s7_pointer new_let= find_let (sc, let); - if (!is_let (new_let)) - find_let_error_nr (sc, sc->outlet_symbol, let, new_let, 1, - set_mlist_1 (sc, let)); - let= new_let; - } - return ((let == sc->rootlet) - ? sc->rootlet - : let_outlet (let)); /* rootlet check is needed(!) */ -} +/* s7_outlet moved to s7_scheme_let.c */ + +/* outlet_p_p moved to s7_scheme_let.c */ /* g_outlet_unlet migrated to s7_scheme_predicate.c */ -s7_pointer -s7i_outlet_p_p (s7_scheme* sc, s7_pointer let) { - return (outlet_p_p (sc, let)); -} +/* s7i_outlet_p_p moved to s7_scheme_let.c */ #define H_outlet "(outlet let) is the environment that contains let." -#define Q_outlet \ - s7_make_signature (sc, 2, sc->is_let_symbol, has_let_signature (sc)) - -static s7_pointer -outlet_chooser (s7_scheme* sc, s7_pointer func, int32_t num_args, - s7_pointer expr) { - if ((num_args == 1) && (is_pair (cadr (expr))) && - (caadr (expr) == sc->unlet_symbol)) { - set_fn_direct (cadr (expr), g_unlet_disabled); - return (sc->outlet_unlet); - } - return (func); -} +#define Q_outlet s7_make_signature(sc, 2, sc->is_let_symbol, has_let_signature(sc)) -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; +/* outlet_chooser moved to s7_scheme_let.c */ - if (!is_let (let)) { - s7_pointer new_let= find_let (sc, let); - if (!is_let (new_let)) - find_let_error_nr (sc, wrap_string (sc, "set! outlet", 11), let, new_let, - 1, args); - let= new_let; - } - if (let == sc->starlet) - error_nr ( - sc, sc->out_of_range_symbol, - set_elist_1 (sc, wrap_string (sc, "can't set! (outlet *s7*)", 24))); - if (is_immutable_let (let)) - immutable_object_error_nr ( - sc, set_elist_4 ( - sc, - wrap_string (sc, "can't (set! (outlet ~S) ~S), ~S is immutable", - 44), - let, cadr (args), let)); - new_outer= cadr (args); - if (!is_let (new_outer)) { - s7_pointer new_let= find_let (sc, new_outer); - if (!is_let (new_let)) - find_let_error_nr (sc, wrap_string (sc, "set! outlet", 11), new_outer, - new_let, 2, args); - new_outer= new_let; - } - if (let != sc->rootlet) { - /* here it's possible to get cyclic let chains; maybe do this check only if - * safety>0 */ - for (s7_pointer new_let= new_outer; new_let; new_let= let_outlet (new_let)) - if (let == new_let) - error_nr ( - sc, make_symbol (sc, "cyclic-let", 10), - set_elist_2 ( - sc, - wrap_string (sc, "set! (outlet ~A) creates a cyclic let chain", - 43), - let)); - let_set_outlet (let, new_outer); - } - return (new_outer); -} - -/* -------------------------------- symbol lookup - * -------------------------------- */ -static Inline s7_pointer -inline_lookup_from (s7_scheme* sc, const s7_pointer symbol, s7_pointer let) { - /* splitting out the no-sc WITH_GCC case made no difference in speed, same if - * using s7_int id = symbol_id(symbol) */ - if (let_id (let) == symbol_id (symbol)) return (local_value (symbol)); - if (let_id (let) > - symbol_id (symbol)) /* let is newer so look back in the outlet chain */ - { - do { - let= let_outlet (let); - } while (let_id (let) > symbol_id (symbol)); - if (let_id (let) == symbol_id (symbol)) return (local_value (symbol)); - } - for (; let; let= let_outlet (let)) - for (s7_pointer slot= let_slots (let); is_not_slot_end (slot); - slot = next_slot (slot)) - if (slot_symbol (slot) == symbol) return (slot_value (slot)); +/* g_set_outlet moved to s7_scheme_let.c */ + +/* -------------------------------- symbol lookup -------------------------------- */ +static Inline s7_pointer inline_lookup_from(s7_scheme *sc, const s7_pointer symbol, s7_pointer let) +{ + /* splitting out the no-sc WITH_GCC case made no difference in speed, same if using s7_int id = symbol_id(symbol) */ + if (let_id(let) == symbol_id(symbol)) + return(local_value(symbol)); + if (let_id(let) > symbol_id(symbol)) /* let is newer so look back in the outlet chain */ + { + do {let = let_outlet(let);} while (let_id(let) > symbol_id(symbol)); + if (let_id(let) == symbol_id(symbol)) + return(local_value(symbol)); + } + for (; let; let = let_outlet(let)) + for (s7_pointer slot = let_slots(let); is_not_slot_end(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == symbol) + return(slot_value(slot)); - if (is_slot (global_slot (symbol))) return (global_value (symbol)); + if (is_slot(global_slot(symbol))) + return(global_value(symbol)); #if WITH_GCC && ((!__cplusplus) || (!__clang__)) - return (NULL); /* much faster than various alternatives */ + return(NULL); /* much faster than various alternatives */ #else - return (unbound_variable (sc, symbol)); /* only use of sc */ + return(unbound_variable(sc, symbol)); /* only use of sc */ #endif } #if WITH_GCC && S7_DEBUGGING -s7_pointer -lookup_1 (s7_scheme* sc, const s7_pointer symbol) +s7_pointer lookup_1(s7_scheme *sc, const s7_pointer symbol) #else -s7_pointer -lookup (s7_scheme* sc, - const s7_pointer - symbol) /* lookup_checked includes the unbound_variable call */ +s7_pointer lookup(s7_scheme *sc, const s7_pointer symbol) /* lookup_checked includes the unbound_variable call */ #endif { - return (inline_lookup_from (sc, symbol, sc->curlet)); + return(inline_lookup_from(sc, symbol, sc->curlet)); } -s7_pointer -s7i_lookup_p_p (s7_scheme* sc, s7_pointer symbol) { - return (lookup (sc, symbol)); -} +s7_pointer s7i_lookup_p_p(s7_scheme *sc, s7_pointer symbol) {return(lookup(sc, symbol));} -static inline s7_pointer -lookup_slot_from (s7_pointer symbol, s7_pointer let) { - if (let_id (let) == symbol_id (symbol)) return (T_Slt (local_slot (symbol))); - if (let_id (let) > symbol_id (symbol)) { - do { - let= let_outlet (let); - } while (let_id (let) > symbol_id (symbol)); - if (let_id (let) == symbol_id (symbol)) - return (T_Slt (local_slot (symbol))); - } - for (; let; let= let_outlet (let)) - for (s7_pointer slot= let_slots (let); is_not_slot_end (slot); - slot = next_slot (slot)) - if (slot_symbol (slot) == symbol) return (T_Slt (slot)); - return (T_Sld (global_slot ( - symbol))); /* # when (define x ...) and x is not yet defined */ +static inline s7_pointer lookup_slot_from(s7_pointer symbol, s7_pointer let) +{ + if (let_id(let) == symbol_id(symbol)) + return(T_Slt(local_slot(symbol))); + if (let_id(let) > symbol_id(symbol)) + { + do {let = let_outlet(let);} while (let_id(let) > symbol_id(symbol)); + if (let_id(let) == symbol_id(symbol)) + return(T_Slt(local_slot(symbol))); + } + for (; let; let = let_outlet(let)) + for (s7_pointer slot = let_slots(let); is_not_slot_end(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == symbol) + return(T_Slt(slot)); + return(T_Sld(global_slot(symbol))); /* # when (define x ...) and x is not yet defined */ } -s7_pointer -s7_slot (s7_scheme* sc, s7_pointer symbol) { - return (lookup_slot_from (symbol, sc->curlet)); -} +s7_pointer s7_slot(s7_scheme *sc, s7_pointer symbol) {return(lookup_slot_from(symbol, sc->curlet));} -static s7_pointer -lookup_slot_with_let (s7_scheme* sc, s7_pointer symbol, s7_pointer let) { - return (lookup_slot_from (symbol, let)); -} +static s7_pointer lookup_slot_with_let(s7_scheme *sc, s7_pointer symbol, s7_pointer let) {return(lookup_slot_from(symbol, let));} -s7_pointer -s7_slot_value (s7_pointer slot) { - return (slot_value (slot)); -} +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); -} +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); -} +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 let) /* assumes e is a let */ +s7_pointer symbol_to_local_slot(s7_scheme *sc, s7_pointer symbol, s7_pointer let) /* assumes e is a let */ { - if (T_Let (let) == sc->rootlet) return (global_slot (symbol)); - if (!is_global (symbol)) /* i.e. rootlet is not the desired let, and the - symbol might have a local value */ - for (s7_pointer slot= let_slots (let); is_not_slot_end (slot); - slot = next_slot (slot)) - if (slot_symbol (slot) == symbol) return (slot); - return (sc->undefined); + if (T_Let(let) == sc->rootlet) + return(global_slot(symbol)); + if (!is_global(symbol)) /* i.e. rootlet is not the desired let, and the symbol might have a local value */ + for (s7_pointer slot = let_slots(let); is_not_slot_end(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == symbol) + return(slot); + return(sc->undefined); } -s7_pointer -s7_symbol_value (s7_scheme* sc, s7_pointer sym) { - s7_pointer slot= s7_slot (sc, sym); - return ((is_slot (slot)) ? slot_value (slot) : sc->undefined); +s7_pointer s7_symbol_value(s7_scheme *sc, s7_pointer sym) +{ + s7_pointer slot = s7_slot(sc, sym); + return((is_slot(slot)) ? slot_value(slot) : sc->undefined); } -s7_pointer -s7_symbol_local_value (s7_scheme* sc, s7_pointer sym, s7_pointer let) { - if (let_id (let) == symbol_id (sym)) return (local_value (sym)); - if (let_id (let) > symbol_id (sym)) { - do { - let= let_outlet (let); - } while (let_id (let) > symbol_id (sym)); - if (let_id (let) == symbol_id (sym)) return (local_value (sym)); - } - for (; let; let= let_outlet (let)) - for (s7_pointer slot= let_slots (let); is_not_slot_end (slot); - slot = next_slot (slot)) - if (slot_symbol (slot) == sym) return (slot_value (slot)); +s7_pointer s7_symbol_local_value(s7_scheme *sc, s7_pointer sym, s7_pointer let) +{ + if (let_id(let) == symbol_id(sym)) + return(local_value(sym)); + if (let_id(let) > symbol_id(sym)) + { + do {let = let_outlet(let);} while (let_id(let) > symbol_id(sym)); + if (let_id(let) == symbol_id(sym)) + return(local_value(sym)); + } + for (; let; let = let_outlet(let)) + for (s7_pointer slot = let_slots(let); is_not_slot_end(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == sym) + return(slot_value(slot)); /* maybe let is local but sym is global but previously shadowed */ - if (is_slot (global_slot (sym))) return (global_value (sym)); + 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 */ + /* (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_defined_global (Sym)) ? global_value (Sym) : lookup_checked (Sc, Sym)) -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->value -------------------------------- */ +#define lookup_global(Sc, Sym) ((is_defined_global(Sym)) ? global_value(Sym) : lookup_checked(Sc, Sym)) + +/* g_symbol_to_value moved to s7_scheme_let.c */ + #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, has_let_signature (sc)) - - const s7_pointer sym= car (args); - if (!is_symbol (sym)) - return (method_or_bust (sc, sym, sc->symbol_to_value_symbol, args, - sc->type_names[T_SYMBOL], 1)); - if (is_keyword (sym)) { - if ((is_pair (cdr (args))) && (!is_let (cadr (args))) && - (!is_let (find_let (sc, cadr (args))))) - wrong_type_error_nr (sc, sc->symbol_to_value_symbol, 2, cadr (args), - sc->type_names[T_LET]); - return (sym); - } - if (is_pair (cdr (args))) { - s7_pointer local_let= cadr (args); - if (!is_let (local_let)) { - local_let= find_let (sc, local_let); - if (!is_let (local_let)) - return (method_or_bust (sc, cadr (args), sc->symbol_to_value_symbol, - args, a_let_string, 2)); /* not local_let */ - } - if (local_let == sc->rootlet) - return ((is_slot (global_slot (sym))) ? global_value (sym) - : sc->undefined); - if (is_unlet (local_let)) return (initial_value (sym)); - if (local_let == sc->starlet) - return (starlet (sc, starlet_symbol_id (sym))); - return (s7_symbol_local_value (sc, sym, local_let)); - } - if (is_defined_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 slot= - s7_slot (sc, sym); /* if immutable should this return an error? */ - if (is_slot (slot)) slot_set_value (slot, val); /* with_hook? */ - return (val); -} - -static s7_pointer -symbol_to_value_chooser (s7_scheme* sc, s7_pointer func, int32_t unused_args, - s7_pointer expr) { - s7_pointer arg1= cadr (expr), - arg2= (is_pair (cddr (expr))) ? caddr (expr) : sc->F; - if ((is_quoted_symbol (sc, arg1)) && (!is_keyword (cadr (arg1))) && - (is_pair (arg2)) && - (car (arg2) == - sc->unlet_symbol)) /* old-style (obsolete) unlet as third arg(!) */ - { - set_fn_direct (arg2, g_unlet_disabled); - return (sc->sv_unlet_ref); - } - return (func); -} - -/* -------------------------------- symbol->dynamic-value - * -------------------------------- */ -static s7_pointer -find_dynamic_value (s7_scheme* sc, s7_pointer let, s7_pointer sym, s7_int* id) { - for (; let_id (let) > symbol_id (sym); let= let_outlet (let)) - ; - if (let_id (let) == symbol_id (sym)) { - (*id)= let_id (let); - return (local_value (sym)); - } - for (; (let) && (let_id (let) > (*id)); let= let_outlet (let)) - for (s7_pointer slot= let_slots (let); is_not_slot_end (slot); - slot = next_slot (slot)) - if (slot_symbol (slot) == sym) { - (*id)= let_id (let); - return (slot_value (slot)); - } - return (sc->unused); + #define Q_symbol_to_value s7_make_signature(sc, 3, sc->T, sc->is_symbol_symbol, has_let_signature(sc)) + +s7_pointer s7_symbol_set_value(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + s7_pointer slot = s7_slot(sc, sym); /* if immutable should this return an error? */ + if (is_slot(slot)) + slot_set_value(slot, val); /* with_hook? */ + return(val); } -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) - const s7_pointer sym= car (args); - s7_pointer val; - s7_int top_id= -1; +/* symbol_to_value_chooser moved to s7_scheme_let.c */ - if (!is_symbol (sym)) - return (method_or_bust (sc, sym, sc->symbol_to_dynamic_value_symbol, args, - sc->type_names[T_SYMBOL], 1)); - if (is_defined_global (sym)) return (global_value (sym)); +/* -------------------------------- symbol->dynamic-value -------------------------------- */ +/* find_dynamic_value moved to s7_scheme_let.c */ - if (let_id (sc->curlet) == symbol_id (sym)) return (local_value (sym)); +/* g_symbol_to_dynamic_value moved to s7_scheme_let.c */ + #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) - val= find_dynamic_value (sc, sc->curlet, sym, &top_id); - if (top_id == symbol_id (sym)) return (val); +static bool direct_memq(const s7_pointer symbol, s7_pointer symbols) +{ + for (s7_pointer syms = symbols; is_pair(syms); syms = cdr(syms)) + if (car(syms) == symbol) + return(true); + return(false); +} - for (s7_int op_loc= stack_top (sc) - 1; op_loc > 0; op_loc-= 4) - if (is_let_unchecked (stack_let ( - sc->stack, - op_loc))) /* OP_GC_PROTECT let slot can be anything (even free) */ +static bool direct_translucent_member(const s7_pointer symbol, s7_pointer symbols) +{ + for (s7_pointer syms = symbols; is_pair(syms); syms = cdr(syms)) { - s7_pointer cur_val= - find_dynamic_value (sc, stack_let (sc->stack, op_loc), sym, &top_id); - if (cur_val != sc->unused) val= cur_val; - if (top_id == symbol_id (sym)) return (val); + if (car(syms) == symbol) return(true); + if ((is_pair(car(syms))) && (is_translucent(caar(syms))) && (is_pair(cdar(syms))) && (cadar(syms) == symbol)) return(true); } - /* what about call/cc stacks? */ - return ((val == sc->unused) ? s7_symbol_value (sc, sym) : val); -} - -static bool -direct_memq (const s7_pointer symbol, s7_pointer symbols) { - for (s7_pointer syms= symbols; is_pair (syms); syms= cdr (syms)) - if (car (syms) == symbol) return (true); - return (false); + return(false); } -static bool -direct_translucent_member (const s7_pointer symbol, s7_pointer symbols) { - for (s7_pointer syms= symbols; is_pair (syms); syms= cdr (syms)) { - if (car (syms) == symbol) return (true); - if ((is_pair (car (syms))) && (is_translucent (caar (syms))) && - (is_pair (cdar (syms))) && (cadar (syms) == symbol)) - return (true); - } - return (false); +static bool direct_assq(const s7_pointer symbol, s7_pointer symbols) /* used only below in do_symbol_is_safe */ +{ + for (s7_pointer syms = symbols; is_pair(syms); syms = cdr(syms)) + if (caar(syms) == symbol) + return(true); + return(false); } -static bool -direct_assq (const s7_pointer symbol, - s7_pointer symbols) /* used only below in do_symbol_is_safe */ +static bool do_symbol_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer var_list) { - for (s7_pointer syms= symbols; is_pair (syms); syms= cdr (syms)) - if (caar (syms) == symbol) return (true); - return (false); + return((is_slot(global_slot(sym))) || + (direct_assq(sym, var_list)) || + (is_bound_symbol(sc, sym))); } -static bool -do_symbol_is_safe (s7_scheme* sc, s7_pointer sym, s7_pointer var_list) { - return ((is_slot (global_slot (sym))) || (direct_assq (sym, var_list)) || - (is_bound_symbol (sc, sym))); +static bool let_symbol_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer var_list) +{ + if (is_slot(global_slot(sym))) + return(true); + if (var_list == sc->rootlet) + return(false); + return((!is_with_let_let(var_list)) && (is_bound_symbol(sc, sym))); } -static bool -let_symbol_is_safe (s7_scheme* sc, s7_pointer sym, s7_pointer var_list) { - if (is_slot (global_slot (sym))) return (true); - if (var_list == sc->rootlet) return (false); - return ((!is_with_let_let (var_list)) && (is_bound_symbol (sc, sym))); +static bool let_symbol_is_safe_or_listed(s7_scheme *sc, s7_pointer sym, s7_pointer var_list) +{ + return((symbol_is_in_big_symbol_set(sc, sym)) || + (let_symbol_is_safe(sc, sym, var_list))); } -static bool -let_symbol_is_safe_or_listed (s7_scheme* sc, s7_pointer sym, - s7_pointer var_list) { - return ((symbol_is_in_big_symbol_set (sc, sym)) || - (let_symbol_is_safe (sc, sym, var_list))); +static bool let_star_symbol_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer var_list) +{ + return((symbol_is_in_big_symbol_set(sc, sym)) || + (is_slot(global_slot(sym))) || + ((is_let(var_list)) && (!is_with_let_let(var_list)) && (is_bound_symbol(sc, sym)))); } -static bool -let_star_symbol_is_safe (s7_scheme* sc, s7_pointer sym, s7_pointer var_list) { - return ((symbol_is_in_big_symbol_set (sc, sym)) || - (is_slot (global_slot (sym))) || - ((is_let (var_list)) && (!is_with_let_let (var_list)) && - (is_bound_symbol (sc, sym)))); +static bool pair_symbol_is_safe(s7_scheme *unused_sc, s7_pointer sym, s7_pointer symbols) +{ + return((is_slot(global_slot(sym))) || + (direct_memq(sym, symbols))); /* optimize_syntax pushes :if (and others like () I think) on this list */ } -static bool -pair_symbol_is_safe (s7_scheme* unused_sc, s7_pointer sym, s7_pointer symbols) { - return ( - (is_slot (global_slot (sym))) || - (direct_memq (sym, symbols))); /* optimize_syntax pushes :if (and others - like () I think) on this list */ +static s7_pointer collect_variables(s7_scheme *sc, s7_pointer lst, s7_pointer var_list) +{ + /* collect local variable names from let/do (pre-error-check), 20 overhead in tgen -> 14 if cons_unchecked below */ + begin_temp(sc->y, var_list); + for (s7_pointer p = lst; is_pair(p); p = cdr(p)) + sc->y = cons(sc, add_symbol_to_big_symbol_set(sc, caar(p)), sc->y); + return_with_end_temp(sc->y); } -static s7_pointer -collect_variables (s7_scheme* sc, s7_pointer lst, s7_pointer var_list) { - /* collect local variable names from let/do (pre-error-check), 20 overhead in - * tgen -> 14 if cons_unchecked below */ - begin_temp (sc->y, var_list); - for (s7_pointer p= lst; is_pair (p); p= cdr (p)) - sc->y= cons (sc, add_symbol_to_big_symbol_set (sc, caar (p)), sc->y); - return_with_end_temp (sc->y); +static s7_pointer collect_parameters(s7_scheme *sc, s7_pointer lst, s7_pointer var_list) +{ + /* collect local variable names from lambda arglists (pre-error-check) */ + s7_pointer pars; + const s7_int the_un_id = ++sc->let_number; + if (is_normal_symbol(lst)) + { + symbol_set_id(lst, the_un_id); + return(cons(sc, add_symbol_to_big_symbol_set(sc, lst), var_list)); + } + begin_temp(sc->y, var_list); + for (pars = lst; is_pair(pars); pars = cdr(pars)) + { + s7_pointer par = car(pars); + if (is_pair(par)) + par = car(par); + if (is_normal_symbol(par)) + { + symbol_set_id(par, the_un_id); + sc->y = cons(sc, add_symbol_to_big_symbol_set(sc, par), sc->y); + }} + if (is_normal_symbol(pars)) /* rest arg */ + { + symbol_set_id(pars, the_un_id); + sc->y = cons(sc, add_symbol_to_big_symbol_set(sc, pars), sc->y); + } + return_with_end_temp(sc->y); } -static s7_pointer -collect_parameters (s7_scheme* sc, s7_pointer lst, s7_pointer var_list) { - /* collect local variable names from lambda arglists (pre-error-check) */ - s7_pointer pars; - const s7_int the_un_id= ++sc->let_number; - if (is_normal_symbol (lst)) { - symbol_set_id (lst, the_un_id); - return (cons (sc, add_symbol_to_big_symbol_set (sc, lst), var_list)); - } - begin_temp (sc->y, var_list); - for (pars= lst; is_pair (pars); pars= cdr (pars)) { - s7_pointer par= car (pars); - if (is_pair (par)) par= car (par); - if (is_normal_symbol (par)) { - symbol_set_id (par, the_un_id); - sc->y= cons (sc, add_symbol_to_big_symbol_set (sc, par), sc->y); +static void clear_all_optimizations(s7_scheme *sc, s7_pointer p) +{ + if (is_unquoted_pair(sc, 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)); } - } - if (is_normal_symbol (pars)) /* rest arg */ - { - symbol_set_id (pars, the_un_id); - sc->y= cons (sc, add_symbol_to_big_symbol_set (sc, pars), sc->y); - } - return_with_end_temp (sc->y); -} - -static void -clear_all_optimizations (s7_scheme* sc, s7_pointer p) { - if (is_unquoted_pair (sc, 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_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) { +static s7_pointer add_profile(s7_scheme *sc, s7_pointer code) +{ s7_pointer result; - if ((is_pair (car (code))) && (caar (code) == sc->profile_in_symbol)) - return (code); - result= - cons_unchecked (sc, - list_3 (sc, sc->profile_in_symbol, - make_integer_unchecked (sc, sc->profile_position), - list_1 (sc, sc->curlet_symbol)), - code); + if ((is_pair(car(code))) && (caar(code) == sc->profile_in_symbol)) + return(code); + result = cons_unchecked(sc, list_3(sc, sc->profile_in_symbol, make_integer_unchecked(sc, sc->profile_position), list_1(sc, sc->curlet_symbol)), code); sc->profile_position++; - set_unsafe_optimize_op (car (result), OP_PROFILE_IN); - return (result); -} - -static bool -tree_has_definer (s7_scheme* sc, s7_pointer tree) { - for (s7_pointer p= tree; is_pair (p); p= cdr (p)) - if (tree_has_definer (sc, car (p))) return (true); - return ((is_symbol (tree)) && (is_definer (tree))); -} - -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); - default: - if (S7_DEBUGGING) - fprintf (stderr, "%s[%d]: %s?\n", __func__, __LINE__, op_names[op]); - } - return (NULL); + set_unsafe_optimize_op(car(result), OP_PROFILE_IN); + return(result); } -typedef enum { opt_bad, opt_ok, opt_oops } opt_t; -static opt_t optimize (s7_scheme* sc, s7_pointer code, int32_t hop, - s7_pointer let_or_list); +static bool tree_has_definer(s7_scheme *sc, s7_pointer tree) +{ + for (s7_pointer p = tree; is_pair(p); p = cdr(p)) + if (tree_has_definer(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; - s7_uint typ; - if (SHOW_EVAL_OPS) - fprintf (stderr, " %s[%d]: %d, %s\n", __func__, __LINE__, named, - display_truncated (sc->code)); - 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 | ((sc->curlet != sc->rootlet) ? 0 : T_EXPANSION); - break; /* local expansions are just normal macros */ - case OP_DEFINE_EXPANSION_STAR: - typ= T_MACRO_STAR | ((sc->curlet != sc->rootlet) ? 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); - closure_set_pars (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++; - gc_protect_via_stack (sc, mac); - - if (named) { - s7_pointer mac_slot; - mac_name= caar (sc->code); - if (((op == OP_DEFINE_EXPANSION) || (op == OP_DEFINE_EXPANSION_STAR)) && - (sc->curlet == sc->rootlet)) - 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 */ - mac_slot= symbol_to_local_slot ( - sc, mac_name, - sc->curlet); /* returns global_slot(symbol) if sc->curlet == nil */ - - if (is_slot (mac_slot)) { - if (is_immutable_slot (mac_slot)) - immutable_object_error_nr ( - sc, set_elist_3 ( - sc, wrap_string (sc, "can't ~S ~S; it is immutable", 28), - cur_op_to_caller (sc, op), mac_name)); - - if ((sc->curlet == sc->nil) && (!in_rootlet (mac_slot))) - add_slot_to_rootlet (sc, mac_slot); - slot_set_value_with_hook (mac_slot, mac); +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); + default: + if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: %s?\n", __func__, __LINE__, op_names[op]); } - else - s7_make_slot (sc, sc->curlet, mac_name, - mac); /* was current but we've checked immutable already */ - if (tree_has_definer (sc, body)) - set_is_definer (mac_name); /* (list-values 'define ...) t101-13 */ - } - clear_big_symbol_set (sc); - if ((!is_either_bacro (mac)) && - (optimize (sc, body, 1, - collect_parameters (sc, closure_pars (mac), sc->nil)) == - opt_oops)) - clear_all_optimizations (sc, body); - clear_big_symbol_set (sc); + return(NULL); +} - if (sc->debug > 1) /* no profile here */ - closure_set_body (mac, add_trace (sc, body)); +typedef enum {opt_bad, opt_ok, opt_oops} opt_t; +static opt_t optimize(s7_scheme *sc, s7_pointer code, int32_t hop, s7_pointer let_or_list); - unstack_gc_protect (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)); +static s7_pointer make_macro(s7_scheme *sc, opcode_t op, bool named) +{ + s7_pointer mac, body, mac_name = NULL; + s7_uint typ; + if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %d, %s\n", __func__, __LINE__, named, display_truncated(sc->code)); + 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 | ((sc->curlet != sc->rootlet) ? 0 : T_EXPANSION); break; /* local expansions are just normal macros */ + case OP_DEFINE_EXPANSION_STAR: typ = T_MACRO_STAR | ((sc->curlet != sc->rootlet) ? 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); + closure_set_pars(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++; + gc_protect_via_stack(sc, mac); + + if (named) + { + s7_pointer mac_slot; + mac_name = caar(sc->code); + if (((op == OP_DEFINE_EXPANSION) || (op == OP_DEFINE_EXPANSION_STAR)) && + (sc->curlet == sc->rootlet)) + 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 */ + mac_slot = symbol_to_local_slot(sc, mac_name, sc->curlet); /* returns global_slot(symbol) if sc->curlet == nil */ + + if (is_slot(mac_slot)) + { + if (is_immutable_slot(mac_slot)) + immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "can't ~S ~S; it is immutable", 28), cur_op_to_caller(sc, op), mac_name)); + + if ((sc->curlet == sc->nil) && (!in_rootlet(mac_slot))) + add_slot_to_rootlet(sc, mac_slot); + slot_set_value_with_hook(mac_slot, mac); + } + else s7_make_slot(sc, sc->curlet, mac_name, mac); /* was current but we've checked immutable already */ + if (tree_has_definer(sc, body)) + set_is_definer(mac_name); /* (list-values 'define ...) t101-13 */ + } + clear_big_symbol_set(sc); + if ((!is_either_bacro(mac)) && + (optimize(sc, body, 1, collect_parameters(sc, closure_pars(mac), sc->nil)) == opt_oops)) + clear_all_optimizations(sc, body); + clear_big_symbol_set(sc); + + if (sc->debug > 1) /* no profile here */ + closure_set_body(mac, add_trace(sc, body)); + + unstack_gc_protect(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 */ /* we can't add the T_EXPANSION bit ourselves if - * ((mac_name) && (!is_bacro(mac_name)) && (!is_expansion(mac_name)) && - * (sc->curlet == sc->rootlet) && (is_global(mac_name))) because the user - * might reuse mac_name locally later, and our hidden expansion setting will - * cause the s7 reader to try to treat that reuse as a call of the original - * macro. + * ((mac_name) && (!is_bacro(mac_name)) && (!is_expansion(mac_name)) && (sc->curlet == sc->rootlet) && (is_global(mac_name))) + * because the user might reuse mac_name locally later, and our hidden expansion setting will cause the s7 reader to try to + * treat that reuse as a call of the original macro. */ - return (mac); + return(mac); } -static s7_pointer -make_closure_unchecked (s7_scheme* sc, s7_pointer args, s7_pointer code, - s7_uint type, int32_t arity) { +static s7_pointer make_closure_unchecked(s7_scheme *sc, s7_pointer args, s7_pointer code, s7_uint type, int32_t arity) +{ s7_pointer new_func; - new_cell_unchecked (sc, new_func, (type | closure_bits (code))); - closure_set_pars (new_func, args); - closure_set_let (new_func, sc->curlet); - closure_set_setter (new_func, sc->F); - closure_set_arity (new_func, arity); - closure_set_body (new_func, code); - if (is_pair (cdr (code))) set_closure_has_multiform (new_func); - else set_closure_has_one_form (new_func); + new_cell_unchecked(sc, new_func, (type | closure_bits(code))); + closure_set_pars(new_func, args); + closure_set_let(new_func, sc->curlet); + closure_set_setter(new_func, sc->F); + closure_set_arity(new_func, arity); + closure_set_body(new_func, code); + if (is_pair(cdr(code))) set_closure_has_multiform(new_func); else set_closure_has_one_form(new_func); sc->capture_let_counter++; - return (new_func); + return(new_func); } -static inline s7_pointer -make_closure_gc_checked (s7_scheme* sc, s7_pointer args, s7_pointer code, - s7_uint type, - int32_t arity) /* inline 100>1% tgc, 35=2% texit */ -{ /* used in op_lambda_unchecked to avoid enormous call overhead if using - make_closure -- this code is repetitive but faster */ +static inline s7_pointer make_closure_gc_checked(s7_scheme *sc, s7_pointer args, s7_pointer code, s7_uint type, int32_t arity) /* inline 100>1% tgc, 35=2% texit */ +{ /* used in op_lambda_unchecked to avoid enormous call overhead if using make_closure -- this code is repetitive but faster */ s7_pointer new_func; - new_cell (sc, new_func, (type | closure_bits (code))); - closure_set_pars (new_func, args); - closure_set_let (new_func, sc->curlet); - closure_set_setter (new_func, sc->F); - closure_set_arity (new_func, arity); - closure_set_body (new_func, code); - if (is_pair (cdr (code))) set_closure_has_multiform (new_func); - else set_closure_has_one_form (new_func); + new_cell(sc, new_func, (type | closure_bits(code))); + closure_set_pars(new_func, args); + closure_set_let(new_func, sc->curlet); + closure_set_setter(new_func, sc->F); + closure_set_arity(new_func, arity); + closure_set_body(new_func, code); + if (is_pair(cdr(code))) set_closure_has_multiform(new_func); else set_closure_has_one_form(new_func); sc->capture_let_counter++; - return (new_func); + return(new_func); } -static s7_pointer -make_closure (s7_scheme* sc, s7_pointer args, s7_pointer code, s7_uint type, - int32_t arity) { - /* this is called (almost?) every time a lambda form is evaluated, or during - * letrec, etc */ +static s7_pointer make_closure(s7_scheme *sc, s7_pointer args, s7_pointer code, s7_uint type, int32_t arity) +{ + /* this is called (almost?) every time a lambda form is evaluated, or during letrec, etc */ s7_pointer new_func; - new_cell (sc, new_func, (type | closure_bits (code))); - closure_set_pars (new_func, args); - closure_set_let (new_func, sc->curlet); - closure_set_setter (new_func, sc->F); - closure_set_arity (new_func, arity); - closure_set_body (new_func, - 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, new_func); /* GC protect func during add_trace */ - closure_set_body (new_func, (sc->debug > 1) ? add_trace (sc, code) - : add_profile (sc, code)); - set_closure_has_multiform (new_func); - unstack_gc_protect (sc); - } - else if (is_pair (cdr (code))) set_closure_has_multiform (new_func); - else set_closure_has_one_form (new_func); + new_cell(sc, new_func, (type | closure_bits(code))); + closure_set_pars(new_func, args); + closure_set_let(new_func, sc->curlet); + closure_set_setter(new_func, sc->F); + closure_set_arity(new_func, arity); + closure_set_body(new_func, 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, new_func); /* GC protect func during add_trace */ + closure_set_body(new_func, (sc->debug > 1) ? add_trace(sc, code) : add_profile(sc, code)); + set_closure_has_multiform(new_func); + unstack_gc_protect(sc); + } + else + if (is_pair(cdr(code))) + set_closure_has_multiform(new_func); + else set_closure_has_one_form(new_func); sc->capture_let_counter++; - return (new_func); + return(new_func); } -static int32_t -closure_length (s7_scheme* sc, s7_pointer clo) { - /* we can't use let_length(sc, closure_let(clo)) because the - * closure_let(closure) changes. So the open bit is not always on. Besides, - * the fallbacks need to be for closures, not lets. +static int32_t closure_length(s7_scheme *sc, s7_pointer clo) +{ + /* we can't use let_length(sc, closure_let(clo)) 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= - find_method (sc, closure_let (clo), sc->length_symbol); + s7_pointer length_func = find_method(sc, closure_let(clo), sc->length_symbol); if (length_func != sc->undefined) - return ((int32_t) s7_integer ( - s7_apply_function (sc, length_func, set_plist_1 (sc, clo)))); - /* there are cases where this should raise a wrong-type-arg error, but for - * now... */ - return (-1); + return((int32_t)s7_integer(s7_apply_function(sc, length_func, set_plist_1(sc, clo)))); + /* 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) /* (used only in copy_tree_with_type) */ +static s7_pointer cons_unchecked_with_type(s7_scheme *sc, s7_pointer p, s7_pointer a, s7_pointer b) /* (used only in copy_tree_with_type) */ { s7_pointer new_pair; - new_cell_unchecked (sc, new_pair, - full_type (p) & - (TYPE_MASK | T_IMMUTABLE | T_SAFE_PROCEDURE)); - set_car (new_pair, a); - set_cdr (new_pair, b); - return (new_pair); -} - -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. + new_cell_unchecked(sc, new_pair, full_type(p) & (TYPE_MASK | T_IMMUTABLE | T_SAFE_PROCEDURE)); + set_car(new_pair, a); + set_cdr(new_pair, b); + return(new_pair); +} + +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 (sc, car (_p))) ? copy_tree_with_type (sc, car (_p)) \ - : car (_p), \ - (is_unquoted_pair (sc, cdr (_p))) ? copy_tree_with_type (sc, cdr (_p)) \ - : cdr (_p)); \ - }) + #define COPY_TREE_WITH_TYPE(P) ({s7_pointer _p; _p = P; \ + cons_unchecked_with_type(sc, _p, (is_unquoted_pair(sc, car(_p))) ? copy_tree_with_type(sc, car(_p)) : car(_p), \ + (is_unquoted_pair(sc, cdr(_p))) ? copy_tree_with_type(sc, cdr(_p)) : cdr(_p));}) #else -#define COPY_TREE_WITH_TYPE(P) copy_tree_with_type (sc, P) + #define COPY_TREE_WITH_TYPE(P) copy_tree_with_type(sc, P) #endif - return (cons_unchecked_with_type ( - sc, tree, - (is_unquoted_pair (sc, car (tree))) ? COPY_TREE_WITH_TYPE (car (tree)) - : car (tree), - (is_unquoted_pair (sc, cdr (tree))) ? COPY_TREE_WITH_TYPE (cdr (tree)) - : cdr (tree))); + return(cons_unchecked_with_type(sc, tree, + (is_unquoted_pair(sc, car(tree))) ? COPY_TREE_WITH_TYPE(car(tree)) : car(tree), + (is_unquoted_pair(sc, cdr(tree))) ? COPY_TREE_WITH_TYPE(cdr(tree)) : cdr(tree))); } -static inline s7_pointer -copy_tree (s7_scheme* sc, s7_pointer tree) { +static inline 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 (sc, car (_p))) ? copy_tree (sc, car (_p)) \ - : car (_p), \ - (is_pair (cdr (_p))) ? copy_tree (sc, cdr (_p)) : cdr (_p)); \ - }) + #define COPY_TREE(P) ({s7_pointer _p; _p = P; \ + cons_unchecked(sc, (is_unquoted_pair(sc, 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) + #define COPY_TREE(P) copy_tree(sc, P) #endif - return (cons_unchecked ( - sc, - (is_unquoted_pair (sc, car (tree))) ? COPY_TREE (car (tree)) : car (tree), - (is_pair (cdr (tree))) ? COPY_TREE (cdr (tree)) : cdr (tree))); + return(cons_unchecked(sc, + (is_unquoted_pair(sc, car(tree))) ? COPY_TREE(car(tree)) : car(tree), + (is_pair(cdr(tree))) ? COPY_TREE(cdr(tree)) : cdr(tree))); } -/* -------------------------------- tree-cyclic? - * -------------------------------- */ + +/* -------------------------------- tree-cyclic? -------------------------------- */ #define TREE_NOT_CYCLIC 0 #define TREE_CYCLIC 1 #define TREE_HAS_PAIRS 2 -static int32_t -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 (sc, car (fast)))) has_pairs= true; - fast= cdr (fast); - if (!is_pair (fast)) - return ((has_pairs) ? TREE_HAS_PAIRS : TREE_NOT_CYCLIC); - - if (tree_is_collected (fast)) return (TREE_CYCLIC); - if ((!has_pairs) && (is_unquoted_pair (sc, car (fast)))) has_pairs= true; - fast= cdr (fast); - if (!is_pair (fast)) - return ((has_pairs) ? TREE_HAS_PAIRS : TREE_NOT_CYCLIC); - - slow= cdr (slow); - if (fast == slow) return (TREE_CYCLIC); - } - return (TREE_HAS_PAIRS); /* not reached */ -} +static int32_t 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(sc, car(fast)))) has_pairs = true; + fast = cdr(fast); + if (!is_pair(fast)) return((has_pairs) ? TREE_HAS_PAIRS : TREE_NOT_CYCLIC); -/* 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 */ + if (tree_is_collected(fast)) return(TREE_CYCLIC); + if ((!has_pairs) && (is_unquoted_pair(sc, car(fast)))) has_pairs = true; + fast = cdr(fast); + if (!is_pair(fast)) return((has_pairs) ? TREE_HAS_PAIRS : TREE_NOT_CYCLIC); -static bool -tree_is_cyclic_1 (s7_scheme* sc, s7_pointer tree) { - for (s7_pointer 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)); - } + slow = cdr(slow); + if (fast == slow) return(TREE_CYCLIC); } - sc->tree_pointers[sc->tree_pointers_top++]= p; - if (is_unquoted_pair (sc, car (p))) { - const int32_t old_top= sc->tree_pointers_top; - const int32_t result = tree_is_cyclic_or_has_pairs (sc, car (p)); - if ((result == TREE_CYCLIC) || (tree_is_cyclic_1 (sc, car (p)))) - return (true); - for (int32_t i= old_top; i < sc->tree_pointers_top; i++) - tree_clear_collected (sc->tree_pointers[i]); - sc->tree_pointers_top= old_top; - } - } - return (false); + return(TREE_HAS_PAIRS); /* not reached */ } -static bool -tree_is_cyclic (s7_scheme* sc, s7_pointer tree) { +/* 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) +{ + for (s7_pointer 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(sc, car(p))) + { + const int32_t old_top = sc->tree_pointers_top; + const int32_t result = tree_is_cyclic_or_has_pairs(sc, car(p)); + if ((result == TREE_CYCLIC) || (tree_is_cyclic_1(sc, car(p)))) + return(true); + for (int32_t i = old_top; i < sc->tree_pointers_top; i++) + tree_clear_collected(sc->tree_pointers[i]); + sc->tree_pointers_top = old_top; + }} + return(false); +} + +bool tree_is_cyclic(s7_scheme *sc, s7_pointer tree) +{ int32_t 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 (int32_t i= 0; i < sc->tree_pointers_top; i++) - tree_clear_collected (sc->tree_pointers[i]); - sc->tree_pointers_top= 0; - return (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 (int32_t i = 0; i < sc->tree_pointers_top; i++) + tree_clear_collected(sc->tree_pointers[i]); + sc->tree_pointers_top = 0; + return(result); } /* g_tree_is_cyclic migrated to s7_scheme_predicate.c */ -#define H_tree_is_cyclic \ - "(tree-cyclic? tree) returns #t if the tree has a cycle." +#define H_tree_is_cyclic "(tree-cyclic? tree) returns #t if the tree has a cycle." #define Q_tree_is_cyclic sc->pl_bt -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)) /* don't wrap this in is_safety_checked */ - error_nr ( - 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 new_fnc; - const s7_pointer 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, new_fnc, - full_type (fnc) & - (~T_COLLECTED)); /* I'm paranoid about that is_collected bit */ - closure_set_pars (new_fnc, closure_pars (fnc)); - closure_set_body (new_fnc, body); - closure_set_setter_or_map_list (new_fnc, closure_setter_or_map_list (fnc)); - closure_set_arity (new_fnc, closure_arity (fnc)); - closure_set_let (new_fnc, closure_let (fnc)); - return (new_fnc); +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)) /* don't wrap this in is_safety_checked */ + error_nr(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 new_fnc; + const s7_pointer 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, new_fnc, full_type(fnc) & (~T_COLLECTED)); /* I'm paranoid about that is_collected bit */ + closure_set_pars(new_fnc, closure_pars(fnc)); + closure_set_body(new_fnc, body); + closure_set_setter_or_map_list(new_fnc, closure_setter_or_map_list(fnc)); + closure_set_arity(new_fnc, closure_arity(fnc)); + closure_set_let(new_fnc, closure_let(fnc)); + return(new_fnc); } + /* -------------------------------- 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 let. \ +/* g_is_defined moved to s7_scheme_let.c */ + #define H_is_defined "(defined? symbol (let (curlet)) ignore-globals) returns #t if symbol has a binding (a value) in the let. \ Only the let is searched if ignore-globals is #t." -#define Q_is_defined \ - s7_make_signature (sc, 4, sc->is_boolean_symbol, sc->is_symbol_symbol, \ - has_let_signature (sc), 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, - sc->type_names[T_SYMBOL], 1)); - - if (is_pair (cdr (args))) { - s7_pointer let= cadr (args); - const s7_pointer ignore_globals= - (is_pair (cddr (args))) ? caddr (args) : sc->F; - if (!is_let (let)) { - const s7_pointer new_let= find_let (sc, let); /* returns () if none */ - if (!is_let (new_let)) - find_let_error_nr (sc, sc->is_defined_symbol, let, new_let, 2, args); - if ((new_let == sc->rootlet) && (is_pair (cddr (args))) && - (ignore_globals != sc->F)) { - if (ignore_globals != - sc->T) /* signature claims this should be a boolean */ - return (method_or_bust (sc, ignore_globals, sc->is_defined_symbol, - args, a_boolean_string, 3)); - return (sc->F); - } - let= new_let; - } - /* if (is_unlet(let)) return(make_boolean(sc, initial_value_is_defined(sc, - * sym))); */ - /* this ^ is wrong: (with-let (unlet) (define xx 1) (list (defined? 'xx) - * (defined? 'xx (curlet)))) should be (#t #t) */ + #define Q_is_defined s7_make_signature(sc, 4, sc->is_boolean_symbol, sc->is_symbol_symbol, has_let_signature(sc), sc->is_boolean_symbol) - if (is_keyword (sym)) /* if no "let", is global -> #t */ - { /* we're treating :x as 'x outside rootlet, but consider all keywords - defined (as themselves) in rootlet? */ - if (let == sc->rootlet) - return (sc->T); /* (defined? x (rootlet)) where x value is a keyword */ - sym= keyword_symbol (sym); /* (defined? :print-length *s7*) */ - } - if (let == sc->starlet) - return (make_boolean (sc, starlet_symbol_id (sym) != sl_no_field)); - if (!is_boolean (ignore_globals)) - return (method_or_bust (sc, ignore_globals, sc->is_defined_symbol, args, - a_boolean_string, 3)); - if (let == sc->rootlet) /* we checked (let? let) above */ - { - if (ignore_globals == sc->F) - return (make_boolean ( - sc, - is_slot (global_slot (sym)))); /* new_symbol and gensym initialize - global_slot to # */ - return (sc->F); - } - if (is_slot (symbol_to_local_slot (sc, sym, T_Let (let)))) return (sc->T); - return ((ignore_globals == sc->T) - ? sc->F - : make_boolean (sc, is_slot (global_slot (sym)))); - } - return ((is_defined_global (sym)) - ? sc->T - : make_boolean (sc, is_bound_symbol (sc, sym))); -} - -static s7_pointer -is_defined_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer expr) { - if (args == 2) { - const s7_pointer arg2= caddr (expr); - if ((is_pair (arg2)) && (is_null (cdr (arg2)))) { - if (car (arg2) == sc->rootlet_symbol) return (sc->is_defined_in_rootlet); - if (car (arg2) == sc->unlet_symbol) { - set_fn_direct (arg2, g_unlet_disabled); - return (sc->is_defined_in_unlet); - } - } - } - return (func); +static s7_pointer is_defined_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + if (args == 2) + { + const s7_pointer arg2 = caddr(expr); + if ((is_pair(arg2)) && (is_null(cdr(arg2)))) + { + if (car(arg2) == sc->rootlet_symbol) + return(sc->is_defined_in_rootlet); + if (car(arg2) == sc->unlet_symbol) + { + set_fn_direct(arg2, g_unlet_disabled); + return(sc->is_defined_in_unlet); + }}} + return(func); } -bool -s7_is_defined (s7_scheme* sc, const char* name) { - s7_pointer symbol= s7_symbol_table_find_name (sc, name); - if (!symbol) return (false); - return (is_bound_symbol (sc, symbol)); +bool s7_is_defined(s7_scheme *sc, const char *name) +{ + s7_pointer symbol = s7_symbol_table_find_name(sc, name); + if (!symbol) return(false); + return(is_bound_symbol(sc, symbol)); } -static bool -is_defined_b_7p (s7_scheme* sc, s7_pointer sym) { - if (!is_symbol (sym)) - return (method_or_bust (sc, sym, sc->is_defined_symbol, - set_plist_1 (sc, sym), sc->type_names[T_SYMBOL], - 1) != sc->F); - return (is_bound_symbol (sc, sym)); +static bool is_defined_b_7p(s7_scheme *sc, s7_pointer sym) +{ + if (!is_symbol(sym)) return(method_or_bust(sc, sym, sc->is_defined_symbol, set_plist_1(sc, sym), sc->type_names[T_SYMBOL], 1) != sc->F); + return(is_bound_symbol(sc, sym)); } -static bool -is_defined_b_7pp (s7_scheme* sc, s7_pointer sym, s7_pointer let) { - return (g_is_defined (sc, set_plist_2 (sc, sym, let)) != sc->F); -} +static bool is_defined_b_7pp(s7_scheme *sc, s7_pointer sym, s7_pointer let) {return(g_is_defined(sc, set_plist_2(sc, sym, let)) != sc->F);} -void -s7_define (s7_scheme* sc, s7_pointer let, s7_pointer symbol, - s7_pointer value) /* assumes let is a let */ + +void s7_define(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) /* assumes let is a let */ { s7_pointer slot; - if (T_Let (let) == sc->rootlet) - let= sc->shadow_rootlet; /* if symbol is a gensym should we issue a warning? - */ - slot= symbol_to_local_slot (sc, symbol, let); /* x can be # */ - if (is_slot (slot)) slot_set_value_with_hook (slot, value); - else { - s7_make_slot ( - sc, let, symbol, - value); /* I think this means C code can override "constant" defs */ - /* if let is rootlet, s7_make_slot makes a semipermanent_slot */ - if ((let == sc->shadow_rootlet) && (!is_slot (global_slot (symbol)))) - set_global_slot (symbol, local_slot (symbol)); - } + if (T_Let(let) == sc->rootlet) let = sc->shadow_rootlet; /* if symbol is a gensym should we issue a warning? */ + slot = symbol_to_local_slot(sc, symbol, let); /* x can be # */ + if (is_slot(slot)) + slot_set_value_with_hook(slot, value); + else + { + s7_make_slot(sc, let, symbol, value); /* I think this means C code can override "constant" defs */ + /* if let is rootlet, s7_make_slot makes a semipermanent_slot */ + if ((let == sc->shadow_rootlet) && + (!is_slot(global_slot(symbol)))) + set_global_slot(symbol, local_slot(symbol)); + } } -s7_pointer -s7_define_variable (s7_scheme* sc, const char* name, s7_pointer value) { - s7_pointer sym= make_symbol_with_strlen (sc, name); - s7_define (sc, sc->rootlet, sym, value); - return (sym); +s7_pointer s7_define_variable(s7_scheme *sc, const char *name, s7_pointer value) +{ + s7_pointer sym = make_symbol_with_strlen(sc, name); + s7_define(sc, sc->rootlet, 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= 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_variable_with_documentation(s7_scheme *sc, const char *name, s7_pointer value, const char *help) +{ + s7_pointer 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 let, - const char* name, s7_pointer value) { - const s7_pointer sym= make_symbol_with_strlen (sc, name); - s7_define (sc, T_Let (let), sym, value); - set_immutable (sym); - set_possibly_constant (sym); - set_immutable (global_slot (sym)); /* might also be # */ - set_immutable_slot (local_slot (sym)); - return (sym); +s7_pointer s7_define_constant_with_environment(s7_scheme *sc, s7_pointer let, const char *name, s7_pointer value) +{ + const s7_pointer sym = make_symbol_with_strlen(sc, name); + s7_define(sc, T_Let(let), sym, value); + set_immutable(sym); + set_possibly_constant(sym); + set_immutable(global_slot(sym)); /* might also be # */ + set_immutable_slot(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->rootlet, name, value)); +s7_pointer s7_define_constant(s7_scheme *sc, const char *name, s7_pointer value) +{ + return(s7_define_constant_with_environment(sc, sc->rootlet, 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 +/* (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= 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? */ +s7_pointer s7_define_constant_with_documentation(s7_scheme *sc, const char *name, s7_pointer value, const char *help) +{ + s7_pointer 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_symbol_and_keyword (obj)); -} +bool s7_is_keyword(s7_pointer obj) {return(is_symbol_and_keyword(obj));} -#define H_is_keyword \ - "(keyword? obj) returns #t if obj is a keyword, (keyword? :rest) -> #t" +#define H_is_keyword "(keyword? obj) returns #t if obj is a keyword, (keyword? :rest) -> #t" #define Q_is_keyword sc->pl_bt /* g_is_keyword is now defined in s7_scheme_predicate.c */ -/* -------------------------------- string->keyword - * -------------------------------- */ -s7_pointer -s7_make_keyword (s7_scheme* sc, const char* key) { - const size_t slen= (size_t) safe_strlen (key); - block_t* b = inline_mallocate (sc, slen + 2); - char* name= (char*) block_data (b); - name[0] = ':'; - memcpy ((void*) (name + 1), (const void*) key, slen); - name[slen + 1]= '\0'; + +/* -------------------------------- string->keyword -------------------------------- */ +s7_pointer s7_make_keyword(s7_scheme *sc, const char *key) +{ + const size_t slen = (size_t)safe_strlen(key); + block_t *b = inline_mallocate(sc, slen + 2); + char *name = (char *)block_data(b); + name[0] = ':'; + memcpy((void *)(name + 1), (const void *)key, slen); + name[slen + 1] = '\0'; { - s7_pointer sym= inline_make_symbol ( - sc, name, slen + 1); /* keyword slot etc taken care of here (in - new_symbol actually) */ - liberate (sc, b); - return (sym); + s7_pointer sym = inline_make_symbol(sc, name, slen + 1); /* keyword slot etc taken care of here (in new_symbol actually) */ + liberate(sc, b); + return(sym); } } /* g_string_to_keyword migrated to s7_scheme_symbol.c */ -#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) +#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) -/* -------------------------------- keyword->symbol - * -------------------------------- */ + +/* -------------------------------- keyword->symbol -------------------------------- */ /* g_keyword_to_symbol migrated to s7_scheme_symbol.c */ -#define H_keyword_to_symbol \ - "(keyword->symbol key) returns a symbol with the same name as key but no " \ - "prepended or appended colon" -#define Q_keyword_to_symbol \ - s7_make_signature (sc, 2, sc->is_symbol_symbol, sc->is_keyword_symbol) +#define H_keyword_to_symbol "(keyword->symbol key) returns a symbol with the same name as key but no prepended or appended colon" +#define Q_keyword_to_symbol s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_keyword_symbol) -s7_pointer -s7_keyword_to_symbol (s7_scheme* sc, s7_pointer key) { - return (keyword_symbol (key)); -} +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)) + +/* -------------------------------- symbol->keyword -------------------------------- */ +#define symbol_to_keyword(Sc, Sym) s7_make_keyword(Sc, symbol_name(Sym)) /* g_symbol_to_keyword migrated to s7_scheme_symbol.c */ -#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) +#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) -/* -------------------------------- 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)); -} +/* -------------------------------- 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));} /* g_is_c_pointer is now defined in s7_scheme_predicate.c */ -#define H_is_c_pointer \ - "(c-pointer? obj type) returns #t if obj is a C pointer being held in s7. \ + #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) + #define Q_is_c_pointer s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->T, sc->T) -/* -------------------------------- c-pointer -------------------------------- - */ -void* -s7_c_pointer (s7_pointer p) { - return (c_pointer (p)); -} - -void* -s7_c_pointer_with_type (s7_scheme* sc, s7_pointer cptr, - s7_pointer expected_type, const char* caller, - s7_int argnum) { - if (!is_c_pointer (cptr)) - wrong_type_error_nr (sc, wrap_string (sc, caller, safe_strlen (caller)), - argnum, cptr, sc->type_names[T_C_POINTER]); - if ((c_pointer (cptr) != NULL) && (c_pointer_type (cptr) != expected_type)) - error_nr ( - sc, sc->wrong_type_arg_symbol, - (argnum == 0) - ? set_elist_4 ( - sc, - wrap_string ( - sc, - "~S argument is a pointer of type ~S, but expected ~S", - 52), - wrap_string (sc, caller, safe_strlen (caller)), - c_pointer_type (cptr), expected_type) - : set_elist_5 (sc, - wrap_string (sc, - "~S ~:D argument got a pointer of type " - "~S, but expected ~S", - 57), - wrap_string (sc, caller, safe_strlen (caller)), - wrap_integer (sc, argnum), c_pointer_type (cptr), - expected_type)); - return (c_pointer (cptr)); -} - -s7_pointer -s7_make_c_pointer_with_type (s7_scheme* sc, void* ptr, s7_pointer type, - s7_pointer info) { + +/* -------------------------------- c-pointer -------------------------------- */ +void *s7_c_pointer(s7_pointer p) {return(c_pointer(p));} + +void *s7_c_pointer_with_type(s7_scheme *sc, s7_pointer cptr, s7_pointer expected_type, const char *caller, s7_int argnum) +{ + if (!is_c_pointer(cptr)) + wrong_type_error_nr(sc, wrap_string(sc, caller, safe_strlen(caller)), argnum, cptr, sc->type_names[T_C_POINTER]); + if ((c_pointer(cptr) != NULL) && + (c_pointer_type(cptr) != expected_type)) + error_nr(sc, sc->wrong_type_arg_symbol, + (argnum == 0) ? + set_elist_4(sc, wrap_string(sc, "~S argument is a pointer of type ~S, but expected ~S", 52), + wrap_string(sc, caller, safe_strlen(caller)), c_pointer_type(cptr), expected_type) : + set_elist_5(sc, wrap_string(sc, "~S ~:D argument got a pointer of type ~S, but expected ~S", 57), + wrap_string(sc, caller, safe_strlen(caller)), + wrap_integer(sc, argnum), c_pointer_type(cptr), expected_type)); + return(c_pointer(cptr)); +} + +s7_pointer s7_make_c_pointer_with_type(s7_scheme *sc, void *ptr, s7_pointer type, s7_pointer info) +{ s7_pointer new_cptr; - new_cell (sc, new_cptr, T_C_POINTER); - c_pointer (new_cptr) = ptr; - c_pointer_type (new_cptr) = type; - c_pointer_info (new_cptr) = info; - c_pointer_weak1 (new_cptr)= sc->F; - c_pointer_weak2 (new_cptr)= sc->F; - return (new_cptr); + new_cell(sc, new_cptr, T_C_POINTER); + c_pointer(new_cptr) = ptr; + c_pointer_type(new_cptr) = type; + c_pointer_info(new_cptr) = info; + c_pointer_weak1(new_cptr) = sc->F; + c_pointer_weak2(new_cptr) = sc->F; + return(new_cptr); } -s7_pointer -s7_make_c_pointer (s7_scheme* sc, void* ptr) { - return (s7_make_c_pointer_with_type (sc, ptr, sc->F, sc->F)); -} +s7_pointer s7_make_c_pointer(s7_scheme *sc, void *ptr) {return(s7_make_c_pointer_with_type(sc, ptr, sc->F, sc->F));} #define NUM_C_POINTER_WRAPPERS 16 /* need at least 9 for gsl */ -s7_pointer -s7_make_c_pointer_wrapper_with_type (s7_scheme* sc, void* ptr, s7_pointer type, - s7_pointer info) { - s7_pointer new_cptr= car (sc->c_pointer_wrappers); +s7_pointer s7_make_c_pointer_wrapper_with_type(s7_scheme *sc, void *ptr, s7_pointer type, s7_pointer info) +{ + s7_pointer new_cptr = car(sc->c_pointer_wrappers); #if S7_DEBUGGING - if ((full_type (new_cptr) & (~T_GC_MARK)) != (T_C_POINTER | T_UNHEAP)) - fprintf (stderr, "%s[%d]: %s\n", __func__, __LINE__, - describe_type_bits (sc, new_cptr)); + if ((full_type(new_cptr) & (~T_GC_MARK)) != (T_C_POINTER | T_UNHEAP)) fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, describe_type_bits(sc, new_cptr)); sc->c_pointer_wrapper_allocs++; #endif - sc->c_pointer_wrappers = cdr (sc->c_pointer_wrappers); - c_pointer (new_cptr) = ptr; - c_pointer_type (new_cptr) = type; - c_pointer_info (new_cptr) = info; - c_pointer_weak1 (new_cptr)= sc->F; - c_pointer_weak2 (new_cptr)= sc->F; - return (new_cptr); -} - -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) - - const s7_pointer ptr_as_int= car (args); - s7_pointer type= sc->F, info= sc->F, weak1= sc->F, weak2= sc->F; - intptr_t cptr; - - if (!s7_is_integer (ptr_as_int)) - return (method_or_bust (sc, ptr_as_int, sc->c_pointer_symbol, args, - sc->type_names[T_INTEGER], 1)); - cptr= (intptr_t) s7_integer_clamped_if_gmp ( - sc, ptr_as_int); /* (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); - } - } - } + sc->c_pointer_wrappers = cdr(sc->c_pointer_wrappers); + c_pointer(new_cptr) = ptr; + c_pointer_type(new_cptr) = type; + c_pointer_info(new_cptr) = info; + c_pointer_weak1(new_cptr) = sc->F; + c_pointer_weak2(new_cptr) = sc->F; + return(new_cptr); +} + +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) + + const s7_pointer ptr_as_int = car(args); + s7_pointer type = sc->F, info = sc->F, weak1 = sc->F, weak2 = sc->F; + intptr_t cptr; + + if (!s7_is_integer(ptr_as_int)) + return(method_or_bust(sc, ptr_as_int, sc->c_pointer_symbol, args, sc->type_names[T_INTEGER], 1)); + cptr = (intptr_t)s7_integer_clamped_if_gmp(sc, ptr_as_int); /* (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); + }}} { - s7_pointer cp= s7_make_c_pointer_with_type (sc, (void*) cptr, 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); + s7_pointer cp = s7_make_c_pointer_with_type(sc, (void *)cptr, 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 cptr) { - if (!is_c_pointer (cptr)) - return (method_or_bust_p (sc, cptr, sc->c_pointer_info_symbol, - sc->type_names[T_C_POINTER])); - return (c_pointer_info (cptr)); + +/* -------------------------------- c-pointer-info -------------------------------- */ +static s7_pointer c_pointer_info_p_p(s7_scheme *sc, s7_pointer cptr) +{ + if (!is_c_pointer(cptr)) + return(method_or_bust_p(sc, cptr, sc->c_pointer_info_symbol, sc->type_names[T_C_POINTER])); + return(c_pointer_info(cptr)); } /* g_c_pointer_info is now defined in s7_scheme_predicate.c */ -#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) + #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) -/* -------------------------------- c-pointer-type - * -------------------------------- */ -static s7_pointer -method_or_bust_lp (s7_scheme* sc, s7_pointer obj, s7_pointer method, - uint8_t typ) { /* weird -- overhead goes berserk in callgrind - if using the simpler method_or_bust_p! */ - if (!has_active_methods (sc, obj)) - wrong_type_error_nr (sc, method, 1, obj, sc->type_names[typ]); - return (find_and_apply_method (sc, obj, method, set_plist_1 (sc, obj))); -} -s7_pointer -s7_c_pointer_type (s7_pointer cptr) { - return ((is_c_pointer (cptr)) ? c_pointer_type (cptr) : NULL); +/* -------------------------------- c-pointer-type -------------------------------- */ +static s7_pointer method_or_bust_lp(s7_scheme *sc, s7_pointer obj, s7_pointer method, uint8_t typ) +{ /* weird -- overhead goes berserk in callgrind if using the simpler method_or_bust_p! */ + if (!has_active_methods(sc, obj)) + wrong_type_error_nr(sc, method, 1, obj, sc->type_names[typ]); + return(find_and_apply_method(sc, obj, method, set_plist_1(sc, obj))); } -static s7_pointer -c_pointer_type_p_p (s7_scheme* sc, s7_pointer cptr) { - return ((is_c_pointer (cptr)) - ? c_pointer_type (cptr) - : method_or_bust_lp (sc, cptr, sc->c_pointer_type_symbol, - T_C_POINTER)); +s7_pointer s7_c_pointer_type(s7_pointer cptr) {return((is_c_pointer(cptr)) ? c_pointer_type(cptr) : NULL);} + +static s7_pointer c_pointer_type_p_p(s7_scheme *sc, s7_pointer cptr) +{ + return((is_c_pointer(cptr)) ? c_pointer_type(cptr) : method_or_bust_lp(sc, cptr, sc->c_pointer_type_symbol, T_C_POINTER)); } /* g_c_pointer_type is now defined in s7_scheme_predicate.c */ -#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) + #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) -/* -------------------------------- c-pointer-weak1/2 - * -------------------------------- */ -static s7_pointer -c_pointer_weak1_p_p (s7_scheme* sc, s7_pointer cptr) { - return ((is_c_pointer (cptr)) - ? c_pointer_weak1 (cptr) - : method_or_bust_lp (sc, cptr, sc->c_pointer_weak1_symbol, - T_C_POINTER)); + +/* -------------------------------- c-pointer-weak1/2 -------------------------------- */ +static s7_pointer c_pointer_weak1_p_p(s7_scheme *sc, s7_pointer cptr) +{ + return((is_c_pointer(cptr)) ? c_pointer_weak1(cptr) : method_or_bust_lp(sc, cptr, sc->c_pointer_weak1_symbol, T_C_POINTER)); } /* g_c_pointer_weak1 is now defined in s7_scheme_predicate.c */ -#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) +#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) -static s7_pointer -c_pointer_weak2_p_p (s7_scheme* sc, s7_pointer cptr) { - return ((is_c_pointer (cptr)) - ? c_pointer_weak2 (cptr) - : method_or_bust_lp (sc, cptr, sc->c_pointer_weak2_symbol, - T_C_POINTER)); +static s7_pointer c_pointer_weak2_p_p(s7_scheme *sc, s7_pointer cptr) +{ + return((is_c_pointer(cptr)) ? c_pointer_weak2(cptr) : method_or_bust_lp(sc, cptr, sc->c_pointer_weak2_symbol, T_C_POINTER)); } /* g_c_pointer_weak2 is now defined in s7_scheme_predicate.c */ -#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) - -/* -------------------------------- 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 cptr= car (args); - if (!is_c_pointer (cptr)) - return (method_or_bust (sc, cptr, sc->c_pointer_to_list_symbol, args, - sc->type_names[T_C_POINTER], 1)); - return (list_3 (sc, make_integer (sc, (s7_int) ((intptr_t) c_pointer (cptr))), - c_pointer_type (cptr), c_pointer_info (cptr))); -} - -void symbol_to_port (s7_scheme* sc, s7_pointer obj, s7_pointer port, - use_write_t use_write, shared_info_t* unused_ci); -s7_pointer b_simple_setter (s7_scheme* sc, int32_t typer, 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) + + +/* -------------------------------- 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 cptr = car(args); + if (!is_c_pointer(cptr)) + return(method_or_bust(sc, cptr, sc->c_pointer_to_list_symbol, args, sc->type_names[T_C_POINTER], 1)); + return(list_3(sc, make_integer(sc, (s7_int)((intptr_t)c_pointer(cptr))), c_pointer_type(cptr), c_pointer_info(cptr))); +} + +s7_pointer b_simple_setter(s7_scheme *sc, int32_t typer, s7_pointer args); #include "s7_continuation.h" + /* -------------------------------- numbers -------------------------------- */ -static block_t* -string_to_block (s7_scheme* sc, const char* p, s7_int len) { - block_t* b = inline_mallocate (sc, len + 1); - char* bp= (char*) block_data (b); - memcpy ((void*) bp, (const void*) p, len); - bp[len]= '\0'; - return (b); +static block_t *string_to_block(s7_scheme *sc, const char *p, s7_int len) +{ + block_t *b = inline_mallocate(sc, len + 1); + char *bp = (char *)block_data(b); + memcpy((void *)bp, (const void *)p, len); + bp[len] = '\0'; + return(b); } -static Inline s7_pointer -inline_block_to_string (s7_scheme* sc, block_t* block, s7_int len) { +static Inline s7_pointer inline_block_to_string(s7_scheme *sc, block_t *block, s7_int len) +{ s7_pointer new_string; - new_cell (sc, new_string, T_STRING | T_SAFE_PROCEDURE); - string_block (new_string) = block; - string_value (new_string) = (char*) block_data (block); - string_length (new_string) = len; - string_value (new_string)[len]= '\0'; - string_hash (new_string) = 0; - add_string (sc, new_string); - return (new_string); + new_cell(sc, new_string, T_STRING | T_SAFE_PROCEDURE); + string_block(new_string) = block; + string_value(new_string) = (char *)block_data(block); + string_length(new_string) = len; + string_value(new_string)[len] = '\0'; + string_hash(new_string) = 0; + add_string(sc, new_string); + return(new_string); } -static s7_pointer -block_to_string (s7_scheme* sc, block_t* block, s7_int len) { - return (inline_block_to_string (sc, block, len)); -} +static s7_pointer block_to_string(s7_scheme *sc, block_t *block, s7_int len) {return(inline_block_to_string(sc, block, len));} -static /* inline */ s7_pointer -make_simple_ratio (s7_scheme* sc, s7_int num, - s7_int den) /* no gcd needed in this case */ +static /* inline */ s7_pointer make_simple_ratio(s7_scheme *sc, s7_int num, s7_int den) /* no gcd needed in this case */ { s7_pointer new_ratio; - if (den < 0) { - if ((num == S7_INT64_MIN) || - (den == S7_INT64_MIN)) /* assume no gcd involved */ - return (make_real (sc, (long_double) num / (long_double) den)); - if (den == -1) return (make_integer (sc, -num)); - new_cell (sc, new_ratio, T_RATIO); - set_numerator (new_ratio, -num); - set_denominator (new_ratio, -den); - } - else { - if (den == 1) return (make_integer (sc, num)); - new_cell (sc, new_ratio, T_RATIO); - set_numerator (new_ratio, num); - set_denominator (new_ratio, den); - } - return (new_ratio); + if (den < 0) + { + if ((num == S7_INT64_MIN) || (den == S7_INT64_MIN)) /* assume no gcd involved */ + return(make_real(sc, (long_double)num / (long_double)den)); + if (den == -1) + return(make_integer(sc, -num)); + new_cell(sc, new_ratio, T_RATIO); + set_numerator(new_ratio, -num); + set_denominator(new_ratio, -den); + } + else + { + if (den == 1) + return(make_integer(sc, num)); + new_cell(sc, new_ratio, T_RATIO); + set_numerator(new_ratio, num); + set_denominator(new_ratio, den); + } + return(new_ratio); } -static /* inline */ s7_pointer -make_simpler_ratio (s7_scheme* sc, s7_int num, - s7_int den) /* no gcd needed, and den > 1 */ +static /* inline */ s7_pointer make_simpler_ratio(s7_scheme *sc, s7_int num, s7_int den) /* no gcd needed, and den > 1 */ { s7_pointer new_ratio; - if ((S7_DEBUGGING) && (den < 2)) - fprintf (stderr, "%s[%d]: denominator: %" ld64 "/n", __func__, __LINE__, - den); - new_cell (sc, new_ratio, T_RATIO); - set_numerator (new_ratio, num); - set_denominator (new_ratio, den); - return (new_ratio); + if ((S7_DEBUGGING) && (den < 2)) fprintf(stderr, "%s[%d]: denominator: %" ld64 "/n", __func__, __LINE__, den); + new_cell(sc, new_ratio, T_RATIO); + set_numerator(new_ratio, num); + set_denominator(new_ratio, den); + return(new_ratio); } -static inline s7_pointer -make_simpler_ratio_or_integer ( - s7_scheme* sc, s7_int num, - s7_int den) /* nom gcd needed and den > 0 (might be 1) */ +static inline s7_pointer make_simpler_ratio_or_integer(s7_scheme *sc, s7_int num, s7_int den) /* nom gcd needed and den > 0 (might be 1) */ { s7_pointer new_ratio; - if ((S7_DEBUGGING) && (den <= 0)) - fprintf (stderr, "%s[%d]: denominator: %" ld64 "/n", __func__, __LINE__, - den); - if (den == 1) return (make_integer (sc, num)); - new_cell (sc, new_ratio, T_RATIO); - set_numerator (new_ratio, num); - set_denominator (new_ratio, den); - return (new_ratio); -} - -static bool is_zero (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); - -/* is_NaN is declared in s7_scheme_inexact.h and defined in s7_scheme_inexact.c - */ + if ((S7_DEBUGGING) && (den <= 0)) fprintf(stderr, "%s[%d]: denominator: %" ld64 "/n", __func__, __LINE__, den); + if (den == 1) + return(make_integer(sc, num)); + new_cell(sc, new_ratio, T_RATIO); + set_numerator(new_ratio, num); + set_denominator(new_ratio, den); + return(new_ratio); +} + +static bool is_zero(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); + +/* is_NaN is declared in s7_scheme_inexact.h and defined in s7_scheme_inexact.c */ /* 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 */ + 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 + #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 */ + 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)); -} + /* 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 */ -static s7_pointer -make_nan_with_payload (s7_scheme* sc, s7_int payload) { - return (make_real (sc, nan_with_payload (payload))); + +static s7_pointer make_nan_with_payload(s7_scheme *sc, s7_int payload) +{ + return(make_real(sc, nan_with_payload(payload))); } -static s7_pointer -g_nan (s7_scheme* sc, s7_pointer args) { -#define H_nan "(nan (int 0)) returns a NaN with payload int" -#define Q_nan \ - s7_make_signature (sc, 2, sc->is_real_symbol, sc->is_integer_symbol) -#define NAN_PAYLOAD_LIMIT \ - (1LL << 51LL) /* 53 is probably ok, (nan (- (ash 1 53) 1)): \ - +nan.9007199254740991 -- 52 bits available? */ +static s7_pointer g_nan(s7_scheme *sc, s7_pointer args) +{ + #define H_nan "(nan (int 0)) returns a NaN with payload int" + #define Q_nan s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_integer_symbol) + #define NAN_PAYLOAD_LIMIT (1LL << 51LL) /* 53 is probably ok, (nan (- (ash 1 53) 1)): +nan.9007199254740991 -- 52 bits available? */ s7_pointer payload; - if (is_null (args)) return (real_NaN); /* payload defaults to 0 */ - payload= car (args); - if (!is_t_integer (payload)) - return (method_or_bust_p (sc, payload, sc->nan_symbol, - sc->type_names[T_INTEGER])); - if (integer (payload) < 0) - sole_arg_out_of_range_error_nr ( - sc, sc->nan_symbol, set_elist_1 (sc, payload), it_is_negative_string); - if (integer (payload) >= NAN_PAYLOAD_LIMIT) - sole_arg_out_of_range_error_nr ( - sc, sc->nan_symbol, set_elist_1 (sc, payload), it_is_too_large_string); - return (make_nan_with_payload (sc, integer (payload))); -} - -static s7_pointer -g_nan_payload (s7_scheme* sc, s7_pointer args) { -#define H_nan_payload \ - "(nan-payload x) returns the payload associated with the NaN x" -#define Q_nan_payload \ - s7_make_signature (sc, 2, sc->is_integer_symbol, sc->is_real_symbol) - s7_pointer nan= car (args); - if (!is_t_real (nan)) - return (method_or_bust_p (sc, nan, sc->nan_payload_symbol, - sc->type_names[T_REAL])); - if (!is_NaN (real ( - nan))) /* for complex case, use real-part etc (see s7test.scm) */ - sole_arg_wrong_type_error_nr (sc, sc->nan_payload_symbol, nan, - wrap_string (sc, "a NaN", 5)); - return (make_integer (sc, nan_payload (real (nan)))); -} - -/* no similar support for +inf.0 because inf is just a single bit pattern in - * ieee754 */ + if (is_null(args)) return(real_NaN); /* payload defaults to 0 */ + payload = car(args); + if (!is_t_integer(payload)) + return(method_or_bust_p(sc, payload, sc->nan_symbol, sc->type_names[T_INTEGER])); + if (integer(payload) < 0) + sole_arg_out_of_range_error_nr(sc, sc->nan_symbol, set_elist_1(sc, payload), it_is_negative_string); + if (integer(payload) >= NAN_PAYLOAD_LIMIT) + sole_arg_out_of_range_error_nr(sc, sc->nan_symbol, set_elist_1(sc, payload), it_is_too_large_string); + return(make_nan_with_payload(sc, integer(payload))); +} + +static s7_pointer g_nan_payload(s7_scheme *sc, s7_pointer args) +{ + #define H_nan_payload "(nan-payload x) returns the payload associated with the NaN x" + #define Q_nan_payload s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol) + s7_pointer nan = car(args); + if (!is_t_real(nan)) + return(method_or_bust_p(sc, nan, sc->nan_payload_symbol, sc->type_names[T_REAL])); + if (!is_NaN(real(nan))) /* for complex case, use real-part etc (see s7test.scm) */ + sole_arg_wrong_type_error_nr(sc, sc->nan_payload_symbol, nan, wrap_string(sc, "a NaN", 5)); + return(make_integer(sc, nan_payload(real(nan)))); +} + +/* no similar support for +inf.0 because inf is just a single bit pattern in ieee754 */ + /* -------- gmp stuff -------- */ #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") -/* these are untested */ -static bool -add_overflow (s7_int A, s7_int B, s7_int* C) { - *C= A + B; - return (false); -} /* #define add_overflow(A, B, C) 0 */ -static bool -subtract_overflow (s7_int A, s7_int B, s7_int* C) { - *C= A - B; - return (false); -} /* #define subtract_overflow(A, B, C) 0 */ -static bool -multiply_overflow (s7_int A, s7_int B, s7_int* C) { - *C= A * B; - return (false); -} /* #define multiply_overflow(A, B, C) 0 */ -#endif + #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") + /* these are untested */ + static bool add_overflow(s7_int A, s7_int B, s7_int *C) {*C = A + B; return(false);} /* #define add_overflow(A, B, C) 0 */ + static bool subtract_overflow(s7_int A, s7_int B, s7_int *C) {*C = A - B; return(false);} /* #define subtract_overflow(A, B, C) 0 */ + static bool multiply_overflow(s7_int A, s7_int B, s7_int *C) {*C = A * B; return(false);} /* #define multiply_overflow(A, B, C) 0 */ + #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_add_overflow(A, B, C) __builtin_sadd_overflow (A, B, C) -#define int32_multiply_overflow(A, B, C) __builtin_smul_overflow (A, B, C) +#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_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_add_overflow(A, B, C) __builtin_add_overflow (A, B, C) -#define int32_multiply_overflow(A, B, C) __builtin_mul_overflow (A, B, C) + #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_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 @@ -15730,5811 +10931,5002 @@ multiply_overflow (s7_int A, s7_int B, s7_int* C) { /* can't use abs even in gcc -- it doesn't work with s7_ints! */ #if !__NetBSD__ -#define s7_fabsl(X) fabsl (X) + #define s7_fabsl(X) fabsl(X) #else -static double -s7_fabsl (long_double x) { - return ((signbit (x)) ? -x : x); -} + 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 */ -static double -s7_round (double number) { - return ((number < 0.0) ? ceil (number - 0.5) : floor (number + 0.5)); -} +/* for g_log, we also need round. this version is from stackoverflow, see also r5rs_round below */ +static 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) + #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) #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 (-s7_complex_i * clog (s7_complex_i * z + csqrt (1.0 - z * z))); -} -static s7_complex -cacos (s7_complex z) { - return (-s7_complex_i * clog (z + s7_complex_i * csqrt (1.0 - z * z))); -} -static s7_complex -catan (s7_complex z) { - return (s7_complex_i * clog ((s7_complex_i + z) / (s7_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); -} + 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(-s7_complex_i * clog(s7_complex_i * z + csqrt(1.0 - z * z)));} + static s7_complex cacos(s7_complex z) {return(-s7_complex_i * clog(z + s7_complex_i * csqrt(1.0 - z * z)));} + static s7_complex catan(s7_complex z) {return(s7_complex_i * clog((s7_complex_i + z) / (s7_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) * s7_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)) * s7_complex_i); +static s7_complex clog(s7_complex z) {return(log(fabs(cabs(z))) + carg(z) * s7_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)) * s7_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))) * s7_complex_i); -} +#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))) * s7_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))) * s7_complex_i); -} -static s7_complex -ccos (s7_complex z) { - return (cos (creal (z)) * cosh (cimag (z)) + - (-sin (creal (z)) * sinh (cimag (z))) * s7_complex_i); -} -static s7_complex -csinh (s7_complex z) { - return (sinh (creal (z)) * cos (cimag (z)) + - (cosh (creal (z)) * sin (cimag (z))) * s7_complex_i); -} -static s7_complex -ccosh (s7_complex z) { - return (cosh (creal (z)) * cos (cimag (z)) + - (sinh (creal (z)) * sin (cimag (z))) * s7_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 (-s7_complex_i * clog (s7_complex_i * z + csqrt (1.0 - z * z))); -} -static s7_complex -cacos (s7_complex z) { - return (-s7_complex_i * clog (z + s7_complex_i * csqrt (1.0 - z * z))); -} -static s7_complex -catan (s7_complex z) { - return (s7_complex_i * clog ((s7_complex_i + z) / (s7_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))); -} + static s7_complex csin(s7_complex z) {return(sin(creal(z)) * cosh(cimag(z)) + (cos(creal(z)) * sinh(cimag(z))) * s7_complex_i);} + static s7_complex ccos(s7_complex z) {return(cos(creal(z)) * cosh(cimag(z)) + (-sin(creal(z)) * sinh(cimag(z))) * s7_complex_i);} + static s7_complex csinh(s7_complex z) {return(sinh(creal(z)) * cos(cimag(z)) + (cosh(creal(z)) * sin(cimag(z))) * s7_complex_i);} + static s7_complex ccosh(s7_complex z) {return(cosh(creal(z)) * cos(cimag(z)) + (sinh(creal(z)) * sin(cimag(z))) * s7_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(-s7_complex_i * clog(s7_complex_i * z + csqrt(1.0 - z * z)));} + static s7_complex cacos(s7_complex z) {return(-s7_complex_i * clog(z + s7_complex_i * csqrt(1.0 - z * z)));} + static s7_complex catan(s7_complex z) {return(s7_complex_i * clog((s7_complex_i + z) / (s7_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 */ -#define _Complex_I 1.0 -#define creal(x) 0.0 -#define cimag(x) 0.0 -#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 +#else /* not HAVE_COMPLEX_NUMBERS */ + #define _Complex_I 1.0 + #define creal(x) 0.0 + #define cimag(x) 0.0 + #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))); -} + /* 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))); -} + 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_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) { - return (is_t_integer (p)); +bool s7_is_integer(s7_pointer p) +{ + return(is_t_integer(p)); } -bool -s7_is_ratio (s7_pointer p) { - return (is_t_ratio (p)); +bool s7_is_ratio(s7_pointer p) +{ + return(is_t_ratio(p)); } -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_simpler_ratio_or_integer (sc, numer, denom)); - return (make_real (sc, x)); +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_simpler_ratio_or_integer(sc, numer, denom)); + return(make_real(sc, x)); } -s7_pointer -s7_make_integer (s7_scheme* sc, s7_int n) { +s7_pointer s7_make_integer(s7_scheme *sc, s7_int n) +{ s7_pointer new_int; - if (is_small_int (n)) return (small_int (n)); - new_cell (sc, new_int, T_INTEGER); - set_integer (new_int, n); - return (new_int); + if (is_small_int(n)) + return(small_int(n)); + new_cell(sc, new_int, T_INTEGER); + set_integer(new_int, n); + return(new_int); } #if S7_DEBUGGING -#define make_mutable_integer(Sc, N) \ - make_mutable_integer_1 (Sc, N, __func__, __LINE__) -static s7_pointer -make_mutable_integer_1 (s7_scheme* sc, s7_int n, const char* func, int line) +#define make_mutable_integer(Sc, N) make_mutable_integer_1(Sc, N, __func__, __LINE__) +static s7_pointer make_mutable_integer_1(s7_scheme *sc, s7_int n, const char *func, int line) #else -static s7_pointer -make_mutable_integer (s7_scheme* sc, s7_int n) +static s7_pointer make_mutable_integer(s7_scheme *sc, s7_int n) #endif { s7_pointer new_int; - new_cell (sc, new_int, T_INTEGER | T_MUTABLE); + new_cell(sc, new_int, T_INTEGER | T_MUTABLE); #if S7_DEBUGGING - new_int->carrier_line= __LINE__; - new_int->gc_line = line; - new_int->gc_func = func; + new_int->carrier_line = __LINE__; + new_int->gc_line = line; + new_int->gc_func = func; #endif - set_integer (new_int, n); - return (new_int); + set_integer(new_int, n); + return(new_int); } -s7_pointer -s7_make_real (s7_scheme* sc, s7_double n) { +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); + new_cell(sc, x, T_REAL); + set_real(x, n); + return(x); } #if S7_DEBUGGING -#define make_mutable_real(Sc, N) make_mutable_real_1 (Sc, N, __func__, __LINE__) -static s7_pointer -make_mutable_real_1 (s7_scheme* sc, s7_double n, const char* func, int line) { +#define make_mutable_real(Sc, N) make_mutable_real_1(Sc, N, __func__, __LINE__) +static s7_pointer make_mutable_real_1(s7_scheme *sc, s7_double n, const char *func, int line) +{ s7_pointer x; - new_cell (sc, x, T_REAL | T_MUTABLE); - x->carrier_line= __LINE__; - x->gc_line = line; - x->gc_func = func; - set_real (x, n); - return (x); + new_cell(sc, x, T_REAL | T_MUTABLE); + x->carrier_line = __LINE__; + x->gc_line = line; + x->gc_func = func; + set_real(x, n); + return(x); } #else -#define make_mutable_real(Sc, N) s7_make_mutable_real (Sc, N) +#define make_mutable_real(Sc, N) s7_make_mutable_real(Sc, N) #endif -s7_pointer -s7_make_mutable_real (s7_scheme* sc, s7_double n) { +s7_pointer s7_make_mutable_real(s7_scheme *sc, s7_double n) +{ s7_pointer x; - new_cell (sc, x, T_REAL | T_MUTABLE); - set_real (x, n); - return (x); + new_cell(sc, x, T_REAL | T_MUTABLE); + set_real(x, n); + return(x); } -s7_pointer -s7_make_complex (s7_scheme* sc, s7_double a, s7_double b) { +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); + 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_pointer -make_mutable_complex (s7_scheme* sc, s7_double rl, s7_double im) { +static s7_pointer make_mutable_complex(s7_scheme *sc, s7_double rl, s7_double im) +{ s7_pointer x; - new_cell (sc, x, - T_COMPLEX | - T_MUTABLE); /* do we need to change to real if imag==0? */ - set_real_part (x, rl); - set_imag_part (x, im); - return (x); + new_cell(sc, x, T_COMPLEX | T_MUTABLE); /* do we need to change to real if imag==0? */ + set_real_part(x, rl); + set_imag_part(x, im); + return(x); } -static s7_complex -s7_to_c_complex (s7_pointer z) { +static s7_complex s7_to_c_complex(s7_pointer z) +{ #if HAVE_COMPLEX_NUMBERS - return (CMPLX (s7_real_part (z), s7_imag_part (z))); + return(CMPLX(s7_real_part(z), s7_imag_part(z))); #else - return (0.0); + return(0.0); #endif } -static inline s7_pointer -c_complex_to_s7 (s7_scheme* sc, s7_complex z) { - return (make_complex (sc, creal (z), cimag (z))); -} +static inline s7_pointer c_complex_to_s7(s7_scheme *sc, s7_complex z) {return(make_complex(sc, creal(z), cimag(z)));} -static no_return void -division_by_zero_error_1_nr (s7_scheme* sc, s7_pointer caller, s7_pointer x) { - error_nr (sc, sc->division_by_zero_symbol, - set_elist_4 (sc, - wrap_string (sc, "~A: division by zero, (~A ~S)", 29), - caller, caller, x)); +static no_return void division_by_zero_error_1_nr(s7_scheme *sc, s7_pointer caller, s7_pointer x) +{ + error_nr(sc, sc->division_by_zero_symbol, + set_elist_4(sc, wrap_string(sc, "~A: division by zero, (~A ~S)", 29), caller, caller, x)); } -static no_return void -division_by_zero_error_2_nr (s7_scheme* sc, s7_pointer caller, s7_pointer x, - s7_pointer y) { - error_nr ( - sc, sc->division_by_zero_symbol, - set_elist_5 (sc, wrap_string (sc, "~A: division by zero, (~A ~S ~S)", 32), - caller, caller, x, y)); +static no_return void division_by_zero_error_2_nr(s7_scheme *sc, s7_pointer caller, s7_pointer x, s7_pointer y) +{ + error_nr(sc, sc->division_by_zero_symbol, + set_elist_5(sc, wrap_string(sc, "~A: division by zero, (~A ~S ~S)", 32), caller, caller, x, y)); } -static s7_pointer -make_ratio (s7_scheme* sc, s7_int a, s7_int b) { - if (b < 0) { - if (b == S7_INT64_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 == b) return(int_one); */ - if (a & 1) return (make_real (sc, (long_double) a / (long_double) b)); - a/= 2; - b/= 2; - } - if (a == S7_INT64_MIN) { - if (b & 1) return (make_real (sc, (long_double) a / (long_double) b)); - a/= 2; - b/= 2; - } - a= -a; - b= -b; - } - if (a == S7_INT64_MIN) { - while (((a & 1) == 0) && ((b & 1) == 0)) { - a/= 2; - b/= 2; - } - } - else { - s7_int b1= b, divisor= s7_int_abs (a); - do { - s7_int 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)); - { - s7_pointer x; - new_cell (sc, x, T_RATIO); - set_numerator (x, a); - set_denominator (x, b); - return (x); - } +static s7_pointer make_ratio(s7_scheme *sc, s7_int a, s7_int b) +{ + if (b < 0) + { + if (b == S7_INT64_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 == b) return(int_one); */ + if (a & 1) + return(make_real(sc, (long_double)a / (long_double)b)); + a /= 2; + b /= 2; + } + if (a == S7_INT64_MIN) + { + if (b & 1) + return(make_real(sc, (long_double)a / (long_double)b)); + a /= 2; + b /= 2; + } + a = -a; + b = -b; + } + if (a == S7_INT64_MIN) + { + while (((a & 1) == 0) && ((b & 1) == 0)) + { + a /= 2; + b /= 2; + }} + else + { + s7_int b1 = b, divisor = s7_int_abs(a); + do { + s7_int 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)); + { + s7_pointer x; + new_cell(sc, x, T_RATIO); + set_numerator(x, a); + set_denominator(x, b); + return(x); + } } -/* using make_ratio here is a desperate kludge trying to maintain backwards - * compatibility; internally we use make_ratio_with_div_check below */ -s7_pointer -s7_make_ratio (s7_scheme* sc, s7_int a, s7_int b) { +/* using make_ratio here is a desperate kludge trying to maintain backwards compatibility; internally we use make_ratio_with_div_check below */ +s7_pointer s7_make_ratio(s7_scheme *sc, s7_int a, s7_int b) +{ if (b == 0) - division_by_zero_error_2_nr (sc, wrap_string (sc, "s7_make_ratio", 13), - wrap_integer (sc, a), int_zero); - return (make_ratio (sc, a, b)); + division_by_zero_error_2_nr(sc, wrap_string(sc, "s7_make_ratio", 13), wrap_integer(sc, a), int_zero); + return(make_ratio(sc, a, b)); } -static s7_pointer -make_ratio_with_div_check (s7_scheme* sc, s7_pointer caller, s7_int a, - s7_int b) { +static s7_pointer make_ratio_with_div_check(s7_scheme *sc, s7_pointer caller, s7_int a, s7_int b) +{ if (b == 0) - division_by_zero_error_2_nr (sc, caller, wrap_integer (sc, a), int_zero); - return (make_ratio (sc, a, b)); + division_by_zero_error_2_nr(sc, caller, wrap_integer(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) -/* 9007199254740991LL is where a truncated double starts to skip integers (expt - * 2 53) = ca 1e16 (ceiling (+ 1e16 1)) -> 10000000000000000 +/* 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, + * 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. + * but we don't currently give an error in this case -- not sure what the right thing is. */ -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)); - default: - sole_arg_wrong_type_error_nr ( - sc, wrap_string (sc, caller, safe_strlen (caller)), x, - sc->type_names[T_REAL]); - } - return (0.0); -} - -s7_double -s7_number_to_real_with_location (s7_scheme* sc, s7_pointer x, - s7_pointer 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)); - default: - sole_arg_wrong_type_error_nr (sc, caller, x, sc->type_names[T_REAL]); - } - return (0.0); +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)); + default: + sole_arg_wrong_type_error_nr(sc, wrap_string(sc, caller, safe_strlen(caller)), x, sc->type_names[T_REAL]); + } + return(0.0); } -s7_double -s7_number_to_real (s7_scheme* sc, s7_pointer x) { - return (s7_number_to_real_with_location (sc, x, sc->number_to_real_symbol)); +s7_double s7_number_to_real_with_location(s7_scheme *sc, s7_pointer x, s7_pointer 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)); + default: + sole_arg_wrong_type_error_nr(sc, caller, x, sc->type_names[T_REAL]); + } + return(0.0); } -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)); - sole_arg_wrong_type_error_nr (sc, - wrap_string (sc, caller, safe_strlen (caller)), - x, sc->type_names[T_INTEGER]); - return (0); -} +s7_double s7_number_to_real(s7_scheme *sc, s7_pointer x) {return(s7_number_to_real_with_location(sc, x, sc->number_to_real_symbol));} -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_number_to_integer_with_caller(s7_scheme *sc, s7_pointer x, const char *caller) +{ + if (is_t_integer(x)) return(integer(x)); + sole_arg_wrong_type_error_nr(sc, wrap_string(sc, caller, safe_strlen(caller)), x, sc->type_names[T_INTEGER]); + return(0); } -s7_int -s7_numerator (s7_pointer x) { - switch (type (x)) { - case T_INTEGER: - return (integer (x)); - case T_RATIO: - return (numerator (x)); - } - 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)); + } + return(0); } -s7_int -s7_denominator (s7_pointer x) { - if (is_t_ratio (x)) return (denominator (x)); - return (1); +s7_int s7_denominator(s7_pointer x) +{ + if (is_t_ratio(x)) return(denominator(x)); + return(1); } -s7_int -s7_integer (s7_pointer p) { - if (is_t_integer (p)) return (integer (p)); - return (0); +s7_int s7_integer(s7_pointer p) +{ + if (is_t_integer(p)) return(integer(p)); + 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)); - } - return (0.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)); + } + 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))); +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 /* faster startup if 32, but much slower in tbig; also waiting until use \ - to init_pows is faster at startup, but slower in tbig */ -static double** pepow= NULL; /* [17][MAX_POW * 2]; */ - -static void -init_pows (void) { - pepow = (double**) Malloc (17 * sizeof (double*)); - pepow[0]= NULL; - pepow[1]= NULL; - for (int32_t i= 2; i < 17; i++) - pepow[i]= (double*) Malloc ((MAX_POW * 2) * sizeof (double)); - for (int32_t i= 2; i < 17; i++) /* radix between 2 and 16 */ - for (int32_t 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) { +#define MAX_POW 64 /* faster startup if 32, but much slower in tbig; also waiting until use to init_pows is faster at startup, but slower in tbig */ +static double **pepow = NULL; /* [17][MAX_POW * 2]; */ + +static void init_pows(void) +{ + pepow = (double **)Malloc(17 * sizeof(double *)); + pepow[0] = NULL; + pepow[1] = NULL; + for (int32_t i = 2; i < 17; i++) pepow[i] = (double *)Malloc((MAX_POW * 2) * sizeof(double)); + for (int32_t i = 2; i < 17; i++) /* radix between 2 and 16 */ + for (int32_t 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 */ - return (pow ((double) x, (double) y)); - return (pepow[x][y + MAX_POW]); + return(pow((double)x, (double)y)); + return(pepow[x][y + MAX_POW]); } + /* dtoa (Grisu2 double-to-ASCII) is now in s7_dtoa.c */ #ifndef WITH_DTOA -#define WITH_DTOA 1 + #define WITH_DTOA 1 #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; - const bool sign= (n < 0); - s7_int pown; - - if ((radix < 2) || (radix > 16)) return (0); - if (sign) { - 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, (const void*) mnfs[radix], len); - p[len]= '\0'; - return (len); - } - 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; + +/* -------------------------------- number->string -------------------------------- */ +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; + const bool sign = (n < 0); + s7_int pown; + + if ((radix < 2) || (radix > 16)) + return(0); + if (sign) + { + 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, (const void *)mnfs[radix], len); + p[len] = '\0'; + return(len); + } + 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); + 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 const char* -integer_to_string (s7_scheme* sc, s7_int num, - s7_int* nlen) /* do not free the returned string */ +const char *integer_to_string(s7_scheme *sc, s7_int num, s7_int *nlen) /* do not free the returned string */ { char *p, *op; - bool sign= (num < 0); - if (sign) { - if (num == S7_INT64_MIN) { - (*nlen)= 20; - return ((const char*) "-9223372036854775808"); + bool sign = (num < 0); + if (sign) + { + if (num == S7_INT64_MIN) + { + (*nlen) = 20; + return((const char *)"-9223372036854775808"); + } + num = -num; /* we need a positive index below */ + } + p = (char *)(sc->int_to_str1 + INT_TO_STR_SIZE - 1); + op = p; + *p-- = '\0'; + do {*p-- = "0123456789"[num % 10]; num /= 10;} while (num); + if (sign) + { + *p = '-'; + (*nlen) = op - p; + return(p); } - num= -num; /* we need a positive index below */ - } - p = (char*) (sc->int_to_str1 + INT_TO_STR_SIZE - 1); - op = p; - *p--= '\0'; - do { - *p--= "0123456789"[num % 10]; - num/= 10; - } while (num); - if (sign) { - *p = '-'; - (*nlen)= op - p; - return (p); - } - (*nlen)= op - p - 1; - return (++p); + (*nlen) = op - p - 1; + return(++p); } -static const char* -integer_to_string_no_length (s7_scheme* sc, - s7_int num) /* do not free the returned string */ +const char *integer_to_string_no_length(s7_scheme *sc, s7_int num) /* do not free the returned string */ { - char* p; - const bool sign= (num < 0); - if (sign) { - if (num == S7_INT64_MIN) return ("-9223372036854775808"); - num= -num; - } - p = (char*) (sc->int_to_str2 + INT_TO_STR_SIZE - 1); - *p--= '\0'; - do { - *p--= "0123456789"[num % 10]; - num/= 10; - } while (num); - if (sign) { - *p= '-'; - return (p); - } - return (++p); + char *p; + const bool sign = (num < 0); + if (sign) + { + if (num == S7_INT64_MIN) + return("-9223372036854775808"); + num = -num; + } + p = (char *)(sc->int_to_str2 + INT_TO_STR_SIZE - 1); + *p-- = '\0'; + do {*p-- = "0123456789"[num % 10]; num /= 10;} while (num); + if (sign) + { + *p = '-'; + return(p); + } + return(++p); } -static 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'; /* need to retain 'str' as output */ - len = 4; - } - else if (str[0] == 'i') { - str[0]= '+'; - str[1]= 'i'; - str[2]= 'n'; - str[3]= 'f'; - len = 4; - } +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'; /* need to retain 'str' as output */ + len = 4; + } + else + 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; } - str[len] = '.'; - str[len + 1]= '0'; - str[len + 2]= '\0'; - (*nlen) = len + 2; - } - return (str); + return(str); } -static void -insert_spaces (s7_scheme* sc, const char* src, s7_int width, s7_int len) { - s7_int spaces= width - len; +void insert_spaces(s7_scheme *sc, const char *src, s7_int width, s7_int len) +{ + s7_int spaces = width - len; if ((spaces <= 0) || (len <= 0)) return; - 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); - } - sc->num_to_str[width]= '\0'; - memmove ((void*) (sc->num_to_str + spaces), (const void*) src, len); - local_memset ((void*) (sc->num_to_str), (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); + } + sc->num_to_str[width] = '\0'; + memmove((void *)(sc->num_to_str + spaces), (const void *)src, len); + local_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 */ +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 */ + /* 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)! + * 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= 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; - } + s7_int 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)) { - const char* p; - if (width == 0) - return ((char*) integer_to_string (sc, integer (obj), nlen)); - p= integer_to_string (sc, integer (obj), &len); - if (width > len) { - insert_spaces (sc, p, width, len); /* writes sc->num_to_str */ - (*nlen)= width; - return (sc->num_to_str); - } - (*nlen)= len; - return ((char*) p); - } + if (is_t_integer(obj)) + { + const char *p; + if (width == 0) + return((char *)integer_to_string(sc, integer(obj), nlen)); + p = integer_to_string(sc, integer(obj), &len); + if (width > len) + { + insert_spaces(sc, p, width, len); /* writes sc->num_to_str */ + (*nlen) = width; + return(sc->num_to_str); + } + (*nlen) = len; + return((char *)p); + } - if (is_t_real (obj)) { - if (width == 0) { + if (is_t_real(obj)) + { + if (width == 0) + { #if WITH_DTOA - if ((float_choice == 'g') && - (precision == WRITE_REAL_PRECISION)) /* set to 6 in format! need ~,16G - to hit this code */ - { - /* (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. - */ - if (obj == real_pi) { - static const char pi_name[]= - "3.141592653589793"; /* array form for ISO C++ */ - (*nlen)= 17; - memcpy ((void*) (sc->num_to_str), (void*) pi_name, 17); - return (sc->num_to_str); /* code below assumes we return - sc->num_to_str in this case -- ugly! */ - } - len = fpconv_dtoa (real (obj), sc->num_to_str); - sc->num_to_str[len]= '\0'; - (*nlen) = len; - return (sc->num_to_str); - } + if ((float_choice == 'g') && + (precision == WRITE_REAL_PRECISION)) /* set to 6 in format! need ~,16G to hit this code */ + { + /* (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. + */ + if (obj == real_pi) + { + static const char pi_name[] = "3.141592653589793"; /* array form for ISO C++ */ + (*nlen) = 17; + memcpy((void *)(sc->num_to_str), (void *)pi_name, 17); + return(sc->num_to_str); /* code below assumes we return sc->num_to_str in this case -- ugly! */ + } + 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'; - imag = copy_string ( - number_to_string_base_10 (sc, wrap_real (sc, imag_part (obj)), 0, - precision, float_choice, &len, choice)); + 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'; + imag = copy_string(number_to_string_base_10(sc, wrap_real(sc, imag_part(obj)), 0, precision, float_choice, &len, choice)); - sc->num_to_str[0]= '\0'; - number_to_string_base_10 (sc, wrap_real (sc, real_part (obj)), 0, precision, - float_choice, &len, choice); + sc->num_to_str[0] = '\0'; + number_to_string_base_10(sc, wrap_real(sc, real_part(obj)), 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); + 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; + 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); } - 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); + 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) */ +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 (radix == 10) { - p= number_to_string_base_10 (sc, obj, width, precision, float_choice, nlen, - p_write); - return (string_to_block (sc, p, *nlen)); - } + block_t *b; + char *p; + s7_int len, str_len; - switch (type (obj)) { - case T_INTEGER: { - size_t len1; - b = inline_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= width - len1; - memmove ((void*) (p + start), (void*) p, len1); - local_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 = inline_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= (int32_t) floor (log (x) / log ((double) radix)); - block_t* b1; - len= 0; - b = number_to_string_with_radix ( - sc, - wrap_real (sc, x / pow ((double) radix, - (double) ep)), /* divide it down to one digit, - then the fractional part */ - radix, width, precision, float_choice, &len); - b1 = inline_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= (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 = inline_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++; + 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 = inline_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 = width - len1; + memmove((void *)(p + start), (void *)p, len1); + local_memset((void *)p, (int)' ', start); + p[width] = '\0'; + *nlen = width; + } + else *nlen = len1; + return(b); } - 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: { - char* pt; - s7_int real_len= 0, imag_len= 0; - block_t* n= number_to_string_with_radix ( - sc, wrap_real (sc, real_part (obj)), radix, 0, precision, float_choice, - &real_len); /* include floatify */ - block_t* d= - number_to_string_with_radix (sc, wrap_real (sc, imag_part (obj)), radix, - 0, precision, float_choice, &imag_len); - const char* dp= (const char*) block_data (d); - b = inline_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); - local_memset ((void*) p, (int) ' ', spaces); - (*nlen)= width; - } - else (*nlen)= len; - return (b); + case T_RATIO: + { + size_t len1, len2; + str_len = 256 + width; + b = inline_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 = (int32_t)floor(log(x) / log((double)radix)); + block_t *b1; + len = 0; + b = number_to_string_with_radix(sc, wrap_real(sc, x / pow((double)radix, (double)ep)), /* divide it down to one digit, then the fractional part */ + radix, width, precision, float_choice, &len); + b1 = inline_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 = (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 = inline_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: + { + char *pt; + s7_int real_len = 0, imag_len = 0; + block_t *n = number_to_string_with_radix(sc, wrap_real(sc, real_part(obj)), radix, 0, precision, float_choice, &real_len); /* include floatify */ + block_t *d = number_to_string_with_radix(sc, wrap_real(sc, imag_part(obj)), radix, 0, precision, float_choice, &imag_len); + const char *dp = (const char *)block_data(d); + b = inline_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); + local_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 = number_to_string_with_radix ( - sc, obj, radix, 0, sc->float_format_precision, 'g', &nlen); - char* str= copy_string_with_length ((char*) block_data (b), nlen); - liberate (sc, b); - return (str); +char *s7_number_to_string(s7_scheme *sc, s7_pointer obj, s7_int radix) +{ + s7_int nlen = 0; + block_t *b = number_to_string_with_radix(sc, obj, radix, 0, sc->float_format_precision, 'g', &nlen); + char *str = copy_string_with_length((char *)block_data(b), nlen); + liberate(sc, b); + return(str); } -#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) +#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) + /* ctables moved to s7_ctables.c */ #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 - */ + /* 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 value = sc->F; - const bool need_loader_port= is_loader_port (current_input_port (sc)); +/* -------------------------------- *#readers* -------------------------------- */ +static s7_pointer check_sharp_readers(s7_scheme *sc, const char *name) +{ + s7_pointer value = sc->F; + const bool need_loader_port = is_loader_port(current_input_port(sc)); /* *#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) + * 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) */ - 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 (s7_pointer args= sc->F, reader= slot_value (sc->sharp_readers); - is_pair (reader); reader= cdr (reader)) - if (name[0] == s7_character (caar (reader))) { - if (args == sc->F) - args= set_plist_1 (sc, wrap_string (sc, name, safe_strlen (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) { + 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 (s7_pointer args = sc->F, reader = slot_value(sc->sharp_readers); is_pair(reader); reader = cdr(reader)) + if (name[0] == s7_character(caar(reader))) + { + if (args == sc->F) + args = set_plist_1(sc, wrap_string(sc, name, safe_strlen(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) */ s7_pointer readers; - if (is_null (cadr (args))) return (sc->nil); - if (!is_pair (cadr (args))) - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_2 (sc, - wrap_string (sc, "can't set *#readers* to ~S", 26), - cadr (args))); - for (readers= cadr (args); is_pair (readers); readers= cdr (readers)) - if ((!is_pair (car (readers))) || (!is_character (caar (readers))) || - (!is_procedure (cdar (readers)))) - error_nr (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 (readers)) - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_2 (sc, - wrap_string (sc, "can't set *#readers* to ~S", 26), - cadr (args))); - return (cadr (args)); -} - -static s7_pointer -make_undefined (s7_scheme* sc, const char* name) { - const s7_int len = safe_strlen (name); - char* newstr= (char*) Malloc (len + 2); - s7_pointer undef; - new_cell (sc, undef, T_UNDEFINED | T_IMMUTABLE); - newstr[0]= '#'; - memcpy ((void*) (newstr + 1), (const 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 (undef, len + 1); - undefined_name (undef)= newstr; - add_undefined (sc, undef); - return (undef); -} - -static int32_t -inchar (s7_pointer port) { + if (is_null(cadr(args))) return(sc->nil); + if (!is_pair(cadr(args))) + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *#readers* to ~S", 26), cadr(args))); + for (readers = cadr(args); is_pair(readers); readers = cdr(readers)) + if ((!is_pair(car(readers))) || + (!is_character(caar(readers))) || + (!is_procedure(cdar(readers)))) + error_nr(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(readers)) + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *#readers* to ~S", 26), cadr(args))); + return(cadr(args)); +} + +static s7_pointer make_undefined(s7_scheme *sc, const char *name) +{ + const s7_int len = safe_strlen(name); + char *newstr = (char *)Malloc(len + 2); + s7_pointer undef; + new_cell(sc, undef, T_UNDEFINED | T_IMMUTABLE); + newstr[0] = '#'; + memcpy((void *)(newstr + 1), (const 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(undef, len + 1); + undefined_name(undef) = newstr; + add_undefined(sc, undef); + return(undef); +} + +static int32_t inchar(s7_pointer port) +{ int32_t c; - if (is_file_port (port)) - c= fgetc (port_file (port)); /* not uint8_t! -- could be EOF */ - else { - if (port_data_size (port) <= port_position (port)) return (EOF); - c= (uint8_t) port_data (port)[port_position (port)++]; - } - if (c == '\n') port_line_number (port)++; - return (c); + if (is_file_port(port)) + c = fgetc(port_file(port)); /* not uint8_t! -- could be EOF */ + else + { + if (port_data_size(port) <= port_position(port)) + return(EOF); + c = (uint8_t)port_data(port)[port_position(port)++]; + } + if (c == '\n') + port_line_number(port)++; + return(c); } -static void -backchar (char c, s7_pointer port) { - if (c == '\n') port_line_number (port)--; - if (is_file_port (port)) ungetc (c, port_file (port)); - else if (port_position (port) > 0) port_position (port)--; +static void backchar(char c, s7_pointer port) +{ + if (c == '\n') + port_line_number(port)--; + if (is_file_port(port)) + ungetc(c, port_file(port)); + else + if (port_position(port) > 0) + port_position(port)--; } -static void -resize_strbuf (s7_scheme* sc, s7_int needed_size) { - s7_int 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 (s7_int i= old_size; i < sc->strbuf_size; i++) - sc->strbuf[i]= '\0'; +static void resize_strbuf(s7_scheme *sc, s7_int needed_size) +{ + s7_int 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 (s7_int i = old_size; i < sc->strbuf_size; i++) sc->strbuf[i] = '\0'; } -s7_pointer* chars; +/* bridges for s7_scheme_read.c */ +void s7i_backchar(char c, s7_pointer port) {backchar(c, port);} +void s7i_resize_strbuf(s7_scheme *sc, s7_int needed_size) {resize_strbuf(sc, needed_size);} +bool s7i_is_loader_port(s7_pointer p) {return(is_loader_port(p));} + +s7_pointer *chars; -static s7_pointer -unknown_sharp_constant (s7_scheme* sc, const char* name, s7_pointer port) { +static s7_pointer unknown_sharp_constant(s7_scheme *sc, const char *name, s7_pointer port) +{ /* if name[len - 1] != '>' there's no > delimiter at the end */ - if (hook_has_functions (sc->read_error_hook)) /* check *read-error-hook* */ - { - bool old_history_enabled= s7_set_history_enabled ( - sc, - false); /* see sc->error_hook for a more robust way to handle this */ - s7_pointer result= s7_call ( - sc, sc->read_error_hook, - set_plist_2 (sc, sc->T, wrap_string (sc, name, safe_strlen (name)))); - s7_set_history_enabled (sc, old_history_enabled); - if (result != sc->unspecified) return (result); - } - if (port) /* #<"..."> which gets here as name="#<" */ - { - const s7_int len= safe_strlen (name); - if ((name[len - 1] != '>') && (is_input_port (port)) && - (port != sc->standard_input)) { - if (s7_peek_char (sc, port) != - chars[(uint8_t) '"']) /* if not #<"...">, just return it */ - return (make_undefined (sc, name)); - /* PERHAPS: strchr port-data '>'?? it might be # etc -- what would - * this break? maybe extend section below */ - - if (is_string_port (port)) /* probably unnecessary (see below) */ - { - s7_int c= inchar (port); - const char* pstart= - (const char*) (port_data (port) + port_position (port)); - const char* p= strchr (pstart, (int) '"'); - s7_int added_len; - char* buf; - if (!p) { - backchar (c, port); - 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, (const void*) name, len); - buf[len]= '"'; /* from inchar */ - memcpy ((void*) (buf + len + 1), (const void*) pstart, added_len); - buf[len + added_len + 1]= 0; - port_position (port)+= added_len; - { - s7_pointer result= make_undefined (sc, (const char*) buf); - free (buf); - return (result); - } - } + if (hook_has_functions(sc->read_error_hook)) /* check *read-error-hook* */ + { + bool old_history_enabled = s7_set_history_enabled(sc, false); /* see sc->error_hook for a more robust way to handle this */ + s7_pointer result = s7_call(sc, sc->read_error_hook, set_plist_2(sc, sc->T, wrap_string(sc, name, safe_strlen(name)))); + s7_set_history_enabled(sc, old_history_enabled); + if (result != sc->unspecified) + return(result); } - } - return (make_undefined (sc, name)); -} + if (port) /* #<"..."> which gets here as name="#<" */ + { + const s7_int len = safe_strlen(name); + if ((name[len - 1] != '>') && + (is_input_port(port)) && + (port != sc->standard_input)) + { + if (s7_peek_char(sc, port) != chars[(uint8_t)'"']) /* if not #<"...">, just return it */ + return(make_undefined(sc, name)); + /* PERHAPS: strchr port-data '>'?? it might be # etc -- what would this break? maybe extend section below */ -s7_pointer make_atom (s7_scheme* sc, char* q, int32_t radix, bool want_symbol, - bool with_error); + if (is_string_port(port)) /* probably unnecessary (see below) */ + { + s7_int c = inchar(port); + const char *pstart = (const char *)(port_data(port) + port_position(port)); + const char *p = strchr(pstart, (int)'"'); + s7_int added_len; + char *buf; + if (!p) + { + backchar(c, port); + 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, (const void *)name, len); + buf[len] = '"'; /* from inchar */ + memcpy((void *)(buf + len + 1), (const void *)pstart, added_len); + buf[len + added_len + 1] = 0; + port_position(port) += added_len; + { + s7_pointer result = make_undefined(sc, (const char *)buf); + free(buf); + return(result); + }}}} + return(make_undefined(sc, name)); +} + +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, const char* name, bool with_error, - s7_pointer port, bool error_if_bad_number) { - /* name is the stuff after the '#', return sc->nil if not a recognized #... - * entity */ +static s7_pointer make_sharp_constant(s7_scheme *sc, const char *name, bool with_error, s7_pointer port, bool error_if_bad_number) +{ + /* name is the stuff after the '#', return sc->nil if not a recognized #... entity */ if ((!name) || (!*name)) /* (string->number "#") for example */ - return (make_undefined (sc, name)); + return(make_undefined(sc, name)); /* stupid r7rs special cases */ if ((name[0] == 't') && - ((name[1] == '\0') || (c_strings_are_equal (name, "true")))) - return (sc->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] == '_') { - /* we handle #_ before looking at *#readers* below (via check_sharp_readers) - * because #_ needs to be unsettable via *#readers*: (set! *#readers* (list - * (cons #\_ (lambda (str) (string->symbol (substring str 1)))))) (let ((+ - * -)) (#_+ 1 2)): -1 - */ - s7_pointer sym= make_symbol_with_strlen (sc, (const char*) (name + 1)); - if ((!is_gensym (sym)) && (initial_value_is_defined (sc, sym))) + ((name[1] == '\0') || (c_strings_are_equal(name, "false")))) + return(sc->F); + + if (name[0] == '_') + { + /* we handle #_ before looking at *#readers* below (via check_sharp_readers) because #_ needs to be unsettable via *#readers*: + * (set! *#readers* (list (cons #\_ (lambda (str) (string->symbol (substring str 1)))))) + * (let ((+ -)) (#_+ 1 2)): -1 + */ + s7_pointer sym = make_symbol_with_strlen(sc, (const char *)(name + 1)); + if ((!is_gensym(sym)) && (initial_value_is_defined(sc, sym))) #if 0 return(initial_value(sym)); #else - { - if (!is_initial_value (initial_value (sym))) copy_initial_value (sc, sym); - return (initial_value (sym)); - } + { + if (!is_initial_value(initial_value(sym))) + copy_initial_value(sc, sym); + return(initial_value(sym)); + } #endif - /* 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? */ - } + /* 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_pair (slot_value (sc->sharp_readers))) { - s7_pointer x= check_sharp_readers (sc, name); - if (x != sc->F) return (x); - } + if (is_pair(slot_value(sc->sharp_readers))) + { + s7_pointer 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, port)); /* port 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, port)); - - /* -------- #o #x #b -------- */ - case 'o': /* #o (octal) */ - case 'x': /* #x (hex) */ - case 'b': /* #b (binary) */ - { - s7_pointer result= - make_atom (sc, (char*) (name + 1), - (name[0] == 'o') ? 8 : ((name[0] == 'x') ? 16 : 2), - NO_SYMBOLS, with_error); - if ((error_if_bad_number) && - (result == sc->F)) /* #b32 etc but not if called from string->number */ - error_nr (sc, sc->read_error_symbol, - set_elist_2 (sc, wrap_string (sc, "#~A is not a number", 19), - wrap_string (sc, name, safe_strlen (name)))); - return (result); - } - - /* -------- #\... -------- */ - 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; + return(unknown_sharp_constant(sc, name, port)); /* port here because #<"..."> comes here as "<" so name[1] is '\0'! */ - 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 'd': - if (c_strings_are_equal (name + 1, "delete")) return (chars[0x7f]); - break; - case 'e': - if (c_strings_are_equal (name + 1, "escape")) return (chars[0x1b]); - break; - case 'l': - if (c_strings_are_equal (name + 1, "linefeed")) - return (chars[(uint8_t) '\n']); - break; - case 'r': - if (c_strings_are_equal (name + 1, "return")) - return (chars[(uint8_t) '\r']); - break; - case 's': - if (c_strings_are_equal (name + 1, "space")) - return (chars[(uint8_t) ' ']); - break; - case 't': - if (c_strings_are_equal (name + 1, "tab")) return (chars[(uint8_t) '\t']); - break; - /* to print something in bold-face: (format *stderr* "~Ahiho~A~%" - * (string-append (string #\escape) "[1m") (string-append (string - * #\escape) "[22m")) */ + 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, port)); + + /* -------- #o #x #b -------- */ + case 'o': /* #o (octal) */ + case 'x': /* #x (hex) */ + case 'b': /* #b (binary) */ + { + s7_pointer result = make_atom(sc, (char *)(name + 1), (name[0] == 'o') ? 8 : ((name[0] == 'x') ? 16 : 2), NO_SYMBOLS, with_error); + if ((error_if_bad_number) && (result == sc->F)) /* #b32 etc but not if called from string->number */ + error_nr(sc, sc->read_error_symbol, set_elist_2(sc, wrap_string(sc, "#~A is not a number", 19), wrap_string(sc, name, safe_strlen(name)))); + return(result); + } - case 'x': - /* #\x is just x, but apparently #\x is int->char? #\x65 -> #\e, and - * #\xcebb is lambda? */ + /* -------- #\... -------- */ + 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 '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 'd': if (c_strings_are_equal(name + 1, "delete")) return(chars[0x7f]); break; + case 'e': if (c_strings_are_equal(name + 1, "escape")) return(chars[0x1b]); break; + case 'l': if (c_strings_are_equal(name + 1, "linefeed")) return(chars[(uint8_t)'\n']); break; + case 'r': if (c_strings_are_equal(name + 1, "return")) return(chars[(uint8_t)'\r']); break; + case 's': if (c_strings_are_equal(name + 1, "space")) return(chars[(uint8_t)' ']); break; + case 't': if (c_strings_are_equal(name + 1, "tab")) return(chars[(uint8_t)'\t']); break; + /* to print something in bold-face: (format *stderr* "~Ahiho~A~%" (string-append (string #\escape) "[1m") (string-append (string #\escape) "[22m")) */ + + 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 new_int is -593310740 -> segfault unless caught + */ + bool happy = true; + const char *tmp = (const char *)(name + 2); + int32_t new_int = 0; + + while ((*tmp) && (happy) && (new_int >= 0) && (new_int < 0x110000)) + { + int32_t dig = digits[(int32_t)(*tmp++)]; + if (dig < 16) + new_int = dig + (new_int * 16); + else happy = false; + } + if ((happy) && + (new_int >= 0) && + (new_int < 0x110000)) + return(s7_make_character(sc, (uint32_t)new_int)); + } + break; + } + /* 尝试解析为多字节 UTF-8 字符 */ { - /* 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 new_int - * is -593310740 -> segfault unless caught - */ - bool happy = true; - const char* tmp = (const char*) (name + 2); - int32_t new_int= 0; - - while ((*tmp) && (happy) && (new_int >= 0) && (new_int < 0x110000)) { - int32_t dig= digits[(int32_t) (*tmp++)]; - if (dig < 16) new_int= dig + (new_int * 16); - else happy= false; - } - if ((happy) && (new_int >= 0) && (new_int < 0x110000)) - return (s7_make_character (sc, (uint32_t) new_int)); + int32_t nlen = safe_strlen(name); + if (nlen >= 3 && nlen <= 5) + { + uint32_t cp = 0; + const uint8_t *u = (const uint8_t *)(name + 1); + if (nlen == 3 && (u[0] & 0xE0) == 0xC0 && (u[1] & 0xC0) == 0x80) + { + cp = ((u[0] & 0x1F) << 6) | (u[1] & 0x3F); + if (cp >= 0x80) + return(s7_make_character(sc, cp)); + } + else if (nlen == 4 && (u[0] & 0xF0) == 0xE0 && (u[1] & 0xC0) == 0x80 && (u[2] & 0xC0) == 0x80) + { + cp = ((u[0] & 0x0F) << 12) | ((u[1] & 0x3F) << 6) | (u[2] & 0x3F); + if (cp >= 0x800 && (cp < 0xD800 || cp > 0xDFFF)) + return(s7_make_character(sc, cp)); + } + else if (nlen == 5 && (u[0] & 0xF8) == 0xF0 && (u[1] & 0xC0) == 0x80 && (u[2] & 0xC0) == 0x80 && (u[3] & 0xC0) == 0x80) + { + cp = ((u[0] & 0x07) << 18) | ((u[1] & 0x3F) << 12) | ((u[2] & 0x3F) << 6) | (u[3] & 0x3F); + if (cp >= 0x10000 && cp <= 0x10FFFF) + return(s7_make_character(sc, cp)); + } + } } - break; - } - /* 尝试解析为多字节 UTF-8 字符 */ - { - int32_t nlen= safe_strlen (name); - if (nlen >= 3 && nlen <= 5) { - uint32_t cp= 0; - const uint8_t* u = (const uint8_t*) (name + 1); - if (nlen == 3 && (u[0] & 0xE0) == 0xC0 && (u[1] & 0xC0) == 0x80) { - cp= ((u[0] & 0x1F) << 6) | (u[1] & 0x3F); - if (cp >= 0x80) return (s7_make_character (sc, cp)); - } - else if (nlen == 4 && (u[0] & 0xF0) == 0xE0 && (u[1] & 0xC0) == 0x80 && - (u[2] & 0xC0) == 0x80) { - cp= ((u[0] & 0x0F) << 12) | ((u[1] & 0x3F) << 6) | (u[2] & 0x3F); - if (cp >= 0x800 && (cp < 0xD800 || cp > 0xDFFF)) - return (s7_make_character (sc, cp)); - } - else if (nlen == 5 && (u[0] & 0xF8) == 0xF0 && (u[1] & 0xC0) == 0x80 && - (u[2] & 0xC0) == 0x80 && (u[3] & 0xC0) == 0x80) { - cp= ((u[0] & 0x07) << 18) | ((u[1] & 0x3F) << 12) | - ((u[2] & 0x3F) << 6) | (u[3] & 0x3F); - if (cp >= 0x10000 && cp <= 0x10FFFF) - return (s7_make_character (sc, cp)); - } } - } - } - return (unknown_sharp_constant (sc, name, NULL)); -} - -static const char* radstr[17]= {NULL, - NULL, - "01", - "012", - "0123", - "01234", - "012345", - "0123456", - "01234567", - "012345678", - "0123456789", - "0123456789aA", - "0123456789aAbB", - "0123456789aAbBcC", - "0123456789aAbBcCdD", - "0123456789aAbBcCdDeE", - "0123456789aAbBcCdDeEfF"}; - -static s7_double -string_to_double_with_radix (const char* ur_str, int32_t radix) { - /* Use simple implementation for base 10 to avoid precision issues on Windows - */ - if (radix == 10) return s7_string_to_double_simple (ur_str, radix); + return(unknown_sharp_constant(sc, name, NULL)); +} + +/* bridge for s7_scheme_read.c */ +s7_pointer s7i_make_sharp_constant(s7_scheme *sc, const char *name, bool with_error, s7_pointer port, bool error_if_bad_number) {return(make_sharp_constant(sc, name, with_error, port, error_if_bad_number));} + +static const char *radstr[17] = {NULL, NULL, "01", "012", "0123", "01234", "012345", "0123456", "01234567", "012345678", "0123456789", + "0123456789aA", "0123456789aAbB", "0123456789aAbBcC", "0123456789aAbBcCdD", "0123456789aAbBcCdDeE", "0123456789aAbBcCdDeEfF"}; - /* 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 +static s7_double string_to_double_with_radix(const char *ur_str, int32_t radix) +{ + /* Use simple implementation for base 10 to avoid precision issues on Windows */ + if (radix == 10) + return s7_string_to_double_simple(ur_str, radix); + + /* 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 sign= 1, frac_len, int_len, dig, exponent= 0; + int32_t sign = 1, frac_len, int_len, dig, exponent = 0; const int32_t max_len = s7_int_digits_by_radix[radix]; - s7_int int_part= 0, frac_part= 0; - const char* str= ur_str; - const 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. + s7_int int_part = 0, frac_part = 0; + const char *str = ur_str; + const 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 + * 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 */ - if (*str == '-') { - str++; - sign= -1; - } - else if (*str == '+') str++; - while (*str == '0') { - str++; - }; + if (*str == '-') + { + str++; + sign = -1; + } + else + if (*str == '+') + str++; + while (*str == '0') {str++;}; - ipart= str; + ipart = str; /* while (digits[(int32_t)(*str)] < radix) str++; */ /* int_len = str - ipart; */ - int_len= strspn ( - (const char*) str, - radstr[radix]); /* this is faster than the while loop with digits[] */ - str+= int_len; + int_len = strspn((const char *)str, radstr[radix]); /* this is faster than the while loop with digits[] */ + str += int_len; if (*str == '.') str++; - fpart= str; + fpart = str; /* while (digits[(int32_t)(*str)] < radix) str++; */ /* frac_len = str - fpart; */ - frac_len= strspn ((const char*) str, radstr[radix]); - str+= frac_len; - - if ((*str) && (exponent_table[(uint8_t) (*str)])) { - bool 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 */ + frac_len = strspn((const char *)str, radstr[radix]); + str += frac_len; + + if ((*str) && (exponent_table[(uint8_t)(*str)])) { + bool 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; - } + if ((int32_multiply_overflow(exponent, 10, &exponent)) || + (int32_add_overflow(exponent, dig, &exponent))) + { + exponent = 1000000; /* see below */ + break; + } #else - exponent= dig + (exponent * 10); + 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 */ + 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 (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 + */ + } - 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 - */ + 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 (int32_t i= 0; i < max_len; i++) { - dig= digits[(int32_t) (*str++)]; - if (dig < radix) int_part= dig + (int_part * radix); - else break; - } + for (int32_t 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 (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) { - str= fpart; - for (int32_t k= 0; (frac_len > 0) && (k < exponent); k+= max_len) { - int32_t flen= (frac_len > max_len) ? max_len : frac_len; /* ? */ - frac_len-= max_len; - frac_part= 0; - for (int32_t 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); - } + /* 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 (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) + { + str = fpart; + for (int32_t k = 0; (frac_len > 0) && (k < exponent); k += max_len) + { + int32_t flen = (frac_len > max_len) ? max_len : frac_len; /* ? */ + frac_len -= max_len; + frac_part = 0; + for (int32_t 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 = int_len - max_len; /* we read these above */ + /* str should be at the last digit we read */ + if (ilen > max_len) + ilen = max_len; + for (int32_t i = 0; i < ilen; i++) + frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); + dval += frac_part * dpow(radix, exponent - ilen); + } + return(sign * dval); } - 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= int_len - max_len; /* we read these above */ - /* str should be at the last digit we read */ - if (ilen > max_len) ilen= max_len; - for (int32_t 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= 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. - */ - if (int_len > 0) { - const char* iend= (const 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); + if (int_len <= max_len) + { + int32_t int_exponent = 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. + */ + if (int_len > 0) + { + const char *iend = (const 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); } - dval= (int_exponent == 0) ? (s7_double) int_part - : int_part * dpow (radix, int_exponent); - } - else { - int32_t flen, len= int_len + exponent; - s7_int frpart= 0; - - /* 98765432101234567890987654321.0e-20 987654321.012346 - * 98765432101234567890987654321.0e-29 0.98765432101235 - * 98765432101234567890987654321.0e-30 0.098765432101235 - * 98765432101234567890987654321.0e-28 9.8765432101235 - */ - for (int32_t i= 0; i < len; i++) - int_part= digits[(int32_t) (*str++)] + (int_part * radix); - flen= -exponent; - if (flen > max_len) flen= max_len; - for (int32_t 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); - } + else + { + int32_t flen, len = int_len + exponent; + s7_int frpart = 0; - 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 */ - const char* fend= (const 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. + /* 98765432101234567890987654321.0e-20 987654321.012346 + * 98765432101234567890987654321.0e-29 0.98765432101235 + * 98765432101234567890987654321.0e-30 0.098765432101235 + * 98765432101234567890987654321.0e-28 9.8765432101235 */ + for (int32_t i = 0; i < len; i++) + int_part = digits[(int32_t)(*str++)] + (int_part * radix); + flen = -exponent; + if (flen > max_len) + flen = max_len; + for (int32_t 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); } - else { - if (exponent <= 0) { - for (int32_t 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 (int32_t 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 (int32_t i= 0; i < frac_len; i++) - frac_part= digits[(int32_t) (*str++)] + (frac_part * radix); - dval+= int_part + frac_part * dpow (radix, -frac_len); - } - } - } - return (sign * dval); -} + 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 */ + const char *fend = (const 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 (int32_t i = 0; i < max_len; i++) + frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); -static s7_pointer -make_undefined_overflow (s7_scheme* sc, const char* name) { - s7_int len= safe_strlen (name) + 16; - block_t* b = mallocate (sc, len); - char* buf= (char*) block_data (b); + 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 (int32_t 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 (int32_t i = 0; i < frac_len; i++) + frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); + dval += int_part + frac_part * dpow(radix, -frac_len); + }}} + return(sign * dval); +} + +static s7_pointer make_undefined_overflow(s7_scheme *sc, const char *name) +{ + s7_int len = safe_strlen(name) + 16; + block_t *b = mallocate(sc, len); + char *buf = (char *)block_data(b); s7_pointer result; - snprintf (buf, len, "", name); - result= make_undefined (sc, (const char*) buf); - liberate (sc, b); - return (result); + snprintf(buf, len, "", name); + result = make_undefined(sc, (const char *)buf); + liberate(sc, b); + return(result); } -static s7_pointer -nan1_or_bust (s7_scheme* sc, s7_double x, const char* p, const char* q, - int32_t radix, bool want_symbol, int32_t offset) { - const s7_int len= safe_strlen (p); - if (p[len - 1] == 'i') /* +nan.0[+/-]...i */ - { - if (len == (offset + 2)) /* +nan.0+i */ - return (make_complex_not_0i (sc, x, (p[offset] == '+') ? 1.0 : -1.0)); - if ((len > (offset + 1)) && (len < 1024)) /* make compiler happy */ - { - char* ip= copy_string_with_length ((const char*) (p + offset), - len - offset - 1); - s7_pointer 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_with_strlen (sc, q) : sc->F); +static s7_pointer nan1_or_bust(s7_scheme *sc, s7_double x, const char *p, const char *q, int32_t radix, bool want_symbol, int32_t offset) +{ + const s7_int len = safe_strlen(p); + if (p[len - 1] == 'i') /* +nan.0[+/-]...i */ + { + if (len == (offset + 2)) /* +nan.0+i */ + return(make_complex_not_0i(sc, x, (p[offset] == '+') ? 1.0 : -1.0)); + if ((len > (offset + 1)) && (len < 1024)) /* make compiler happy */ + { + char *ip = copy_string_with_length((const char *)(p + offset), len - offset - 1); + s7_pointer 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_with_strlen(sc, q) : sc->F); } -static s7_pointer -nan2_or_bust (s7_scheme* sc, s7_double x, const char* q, int32_t radix, - bool want_symbol, s7_int rl_len) { - const s7_int len= safe_strlen (q); +static s7_pointer nan2_or_bust(s7_scheme *sc, s7_double x, const char *q, int32_t radix, bool want_symbol, s7_int rl_len) +{ + const s7_int len = safe_strlen(q); if ((len > rl_len) && (len < 1024)) /* make compiler happy */ - { - char* ip= copy_string_with_length (q, rl_len); - s7_pointer 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_with_strlen (sc, q) : sc->F); + { + char *ip = copy_string_with_length(q, rl_len); + s7_pointer 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_with_strlen(sc, q) : sc->F); } #if WITH_NUMBER_SEPARATOR -static s7_pointer -make_symbol_or_number (s7_scheme* sc, const char* name, int32_t radix, - bool want_symbol) { - block_t* b; - char* new_name; - const char sep= sc->number_separator; - s7_int len, j= 0; + +static s7_pointer make_symbol_or_number(s7_scheme *sc, const char *name, int32_t radix, bool want_symbol) +{ + block_t *b; + char *new_name; + const char sep = sc->number_separator; + s7_int len, j = 0; if (name[0] == sep) - return ((want_symbol) ? make_symbol_with_strlen (sc, name) : sc->F); - len = safe_strlen (name); - b = mallocate (sc, len + 1); - new_name= (char*) block_data (b); - memcpy ((void*) new_name, (const void*) name, len); - new_name[len]= 0; - - for (s7_int i= 0; i < len; i++) - if (name[i] != sep) { - if ((digits[(uint8_t) (name[i])] < radix) || - (!t_number_separator_p[(uint8_t) name[i]])) - new_name[j++]= name[i]; - else { - liberate (sc, b); - return ((want_symbol) ? make_symbol_with_strlen (sc, name) : sc->F); - } - } - else /* sep has to be between two digits */ - if ((digits[(uint8_t) (name[i - 1])] >= radix) || - (digits[(uint8_t) (name[i + 1])] >= radix)) { - liberate (sc, b); - return ((want_symbol) ? make_symbol_with_strlen (sc, name) : sc->F); - } - new_name[j]= '\0'; + return((want_symbol) ? make_symbol_with_strlen(sc, name) : sc->F); + len = safe_strlen(name); + b = mallocate(sc, len + 1); + new_name = (char *)block_data(b); + memcpy((void *)new_name, (const void *)name, len); + new_name[len] = 0; + + for (s7_int i = 0; i < len; i++) + if (name[i] != sep) + { + if ((digits[(uint8_t)(name[i])] < radix) || (!t_number_separator_p[(uint8_t)name[i]])) + new_name[j++] = name[i]; + else + { + liberate(sc, b); + return((want_symbol) ? make_symbol_with_strlen(sc, name) : sc->F); + }} + else /* sep has to be between two digits */ + if ((digits[(uint8_t)(name[i - 1])] >= radix) || (digits[(uint8_t)(name[i + 1])] >= radix)) + { + liberate(sc, b); + return((want_symbol) ? make_symbol_with_strlen(sc, name) : sc->F); + } + new_name[j] = '\0'; { - s7_pointer result= s7i_string_to_number (sc, new_name, radix); - liberate (sc, b); - return (result); + s7_pointer result = s7i_string_to_number(sc, new_name, radix); + liberate(sc, b); + return(result); } } #endif -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 */ +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 */ #if WITH_NUMBER_SEPARATOR -#define is_digit(Chr, Rad) \ - ((digits[(uint8_t) Chr] < Rad) || \ - ((Chr == sc->number_separator) && (sc->number_separator != '\0'))) + #define is_digit(Chr, Rad) ((digits[(uint8_t)Chr] < Rad) || ((Chr == sc->number_separator) && (sc->number_separator != '\0'))) #else -#define is_digit(Chr, Rad) (digits[(uint8_t) Chr] < Rad) + #define is_digit(Chr, Rad) (digits[(uint8_t)Chr] < Rad) #endif - 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_with_strlen (sc, q) : sc->F); - if (!is_digit (c, radix)) { - if (has_dec_point1) - return ((want_symbol) ? make_symbol_with_strlen (sc, q) : sc->F); - if (c == 'n') { - if (local_strcmp (p, "an.0")) /* +nan.0, even if we read -nan.0 -- - what's the point of a negative NaN? */ - return (real_NaN); /* not make_nan_with_payload(sc, __LINE__) here - since it says "0" */ - if ((local_strncmp (p, "an.0", 4)) && /* +nan.0[+/-]...i */ - ((p[4] == '+') || (p[4] == '-'))) - return (nan1_or_bust (sc, NAN, p, q, radix, want_symbol, 4)); - /* read +/-nan. or +/-nan.+/-...i */ - if (local_strncmp (p, "an.", 3)) /* +nan. */ - { - bool overflow= false; - int32_t i; - for (i= 3; is_digit (p[i], 10); i++) - ; - if ((p[i] == '+') || (p[i] == '-')) /* complex case */ - { - s7_int payload= - s7_string_to_integer ((char*) (p + 3), 10, &overflow); - return (nan1_or_bust (sc, nan_with_payload (payload), p, q, radix, - want_symbol, i)); - } - if ((p[i] != '\0') && - (!white_space[(uint8_t) (p[i])])) /* check for +nan.0i etc, '\0' - is not white_space apparently - */ - return ((want_symbol) ? make_symbol_with_strlen (sc, q) : sc->F); - return (make_nan_with_payload ( - sc, s7_string_to_integer ((char*) (p + 3), 10, &overflow))); - } - } - 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)) && /* unaligned */ - ((p[4] == '+') || (p[4] == '-'))) - return (nan1_or_bust (sc, (q[0] == '-') ? -INFINITY : INFINITY, p, q, - radix, want_symbol, 4)); - } - return ((want_symbol) ? make_symbol_with_strlen (sc, q) : sc->F); - } - break; + 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_with_strlen(sc, q) : sc->F); + if (!is_digit(c, radix)) + { + if (has_dec_point1) + return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); + if (c == 'n') + { + if (local_strcmp(p, "an.0")) /* +nan.0, even if we read -nan.0 -- what's the point of a negative NaN? */ + return(real_NaN); /* not make_nan_with_payload(sc, __LINE__) here since it says "0" */ + if ((local_strncmp(p, "an.0", 4)) && /* +nan.0[+/-]...i */ + ((p[4] == '+') || (p[4] == '-'))) + return(nan1_or_bust(sc, NAN, p, q, radix, want_symbol, 4)); + /* read +/-nan. or +/-nan.+/-...i */ + if (local_strncmp(p, "an.", 3)) /* +nan. */ + { + bool overflow = false; + int32_t i; + for (i = 3; is_digit(p[i], 10); i++); + if ((p[i] == '+') || (p[i] == '-')) /* complex case */ + { + s7_int payload = s7_string_to_integer((char *)(p + 3), 10, &overflow); + return(nan1_or_bust(sc, nan_with_payload(payload), p, q, radix, want_symbol, i)); + } + if ((p[i] != '\0') && (!white_space[(uint8_t)(p[i])])) /* check for +nan.0i etc, '\0' is not white_space apparently */ + return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); + return(make_nan_with_payload(sc, s7_string_to_integer((char *)(p + 3), 10, &overflow))); + }} + 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)) && /* unaligned */ + ((p[4] == '+') || (p[4] == '-'))) + return(nan1_or_bust(sc, (q[0] == '-') ? -INFINITY : INFINITY, p, q, radix, want_symbol, 4)); + } + return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); + } + break; - case '.': - has_dec_point1= true; - c = *p++; - if ((!c) || (!is_digit (c, radix))) - return ((want_symbol) ? make_symbol_with_strlen (sc, q) : sc->F); - break; + case '.': + has_dec_point1 = true; + c = *p++; + if ((!c) || (!is_digit(c, radix))) + return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); + break; - case 'n': - return ((want_symbol) ? make_symbol_with_strlen (sc, q) : sc->F); + case 'n': + return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - case 'i': - return ((want_symbol) ? make_symbol_with_strlen (sc, q) : sc->F); + case 'i': + return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - case '0': /* these two are always digits */ - case '1': - break; + case '0': /* these two are always digits */ + case '1': + break; - default: - if (!is_digit (c, radix)) - return ((want_symbol) ? make_symbol_with_strlen (sc, q) : sc->F); - break; - } + default: + if (!is_digit(c, radix)) + return((want_symbol) ? make_symbol_with_strlen(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 */ + /* 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; - bool overflow = false; /* for string_to_integer */ - 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_with_strlen (sc, q) : sc->F); - - if (has_plus_or_minus == 0) { - if ((has_dec_point1) || (slash1)) - return ((want_symbol) ? make_symbol_with_strlen (sc, q) : sc->F); - has_dec_point1= true; - } - else { - if ((has_dec_point2) || (slash2)) - return ((want_symbol) ? make_symbol_with_strlen (sc, q) : sc->F); - has_dec_point2= true; - } - continue; + 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; + bool overflow = false; /* for string_to_integer */ + current_radix = radix; /* current_radix is 10 for the exponent portions, but radix for all the rest */ - /* -------- exponent marker -------- */ + 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_with_strlen(sc, q) : sc->F); + + if (has_plus_or_minus == 0) + { + if ((has_dec_point1) || (slash1)) + return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); + has_dec_point1 = true; + } + else + { + if ((has_dec_point2) || (slash2)) + return((want_symbol) ? make_symbol_with_strlen(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': + /* 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_with_strlen (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_with_strlen (sc, q) : sc->F); - - if (((ex2) || (slash2)) && (has_plus_or_minus != 0)) /* 1+1.0ee */ - return ((want_symbol) ? make_symbol_with_strlen (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_with_strlen (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_with_strlen (sc, q) : sc->F); - - has_plus_or_minus= (c == '+') ? 1 : -1; - plus = (char*) (p + 1); - /* now check for nan/inf as imaginary part */ - - if ((plus[0] == 'n') && (local_strncmp (plus, "nan.", 4))) { - bool overflow1= false; - s7_int payload= - s7_string_to_integer ((char*) (p + 5), 10, &overflow1); - return (nan2_or_bust (sc, nan_with_payload (payload), q, radix, - want_symbol, (intptr_t) (p - q))); - } - if ((plus[0] == 'i') && (local_strcmp (plus, "inf.0i"))) - return (nan2_or_bust (sc, (c == '+') ? INFINITY : -INFINITY, q, - radix, want_symbol, (intptr_t) (p - q))); - continue; - - /* ratio marker */ - case '/': - if ((has_plus_or_minus == 0) && - ((ex1) || (slash1) || (has_dec_point1))) - return ((want_symbol) ? make_symbol_with_strlen (sc, q) : sc->F); - - if ((has_plus_or_minus != 0) && - ((ex2) || (slash2) || (has_dec_point2))) - return ((want_symbol) ? make_symbol_with_strlen (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_with_strlen (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_with_strlen (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_with_strlen (sc, q) : sc->F); + case 'e': case 'E': + if (current_radix > 10) /* see above */ + return((want_symbol) ? make_symbol_with_strlen(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_with_strlen(sc, q) : sc->F); + + if (((ex2) || + (slash2)) && + (has_plus_or_minus != 0)) /* 1+1.0ee */ + return((want_symbol) ? make_symbol_with_strlen(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_with_strlen(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_with_strlen(sc, q) : sc->F); + + has_plus_or_minus = (c == '+') ? 1 : -1; + plus = (char *)(p + 1); + /* now check for nan/inf as imaginary part */ + + if ((plus[0] == 'n') && + (local_strncmp(plus, "nan.", 4))) + { + bool overflow1 = false; + s7_int payload = s7_string_to_integer((char *)(p + 5), 10, &overflow1); + return(nan2_or_bust(sc, nan_with_payload(payload), q, radix, want_symbol, (intptr_t)(p - q))); + } + if ((plus[0] == 'i') && + (local_strcmp(plus, "inf.0i"))) + return(nan2_or_bust(sc, (c == '+') ? INFINITY : -INFINITY, q, radix, want_symbol, (intptr_t)(p - q))); + continue; + + /* ratio marker */ + case '/': + if ((has_plus_or_minus == 0) && + ((ex1) || + (slash1) || + (has_dec_point1))) + return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); + + if ((has_plus_or_minus != 0) && + ((ex2) || + (slash2) || + (has_dec_point2))) + return((want_symbol) ? make_symbol_with_strlen(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_with_strlen(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_with_strlen(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_with_strlen(sc, q) : sc->F); #if WITH_NUMBER_SEPARATOR - if ((sc->number_separator != '\0') && - (strchr (q, (int) (sc->number_separator)))) - return (make_symbol_or_number (sc, q, radix, want_symbol)); + if ((sc->number_separator != '\0') && (strchr(q, (int)(sc->number_separator)))) + return(make_symbol_or_number(sc, q, radix, want_symbol)); #endif - if (has_i) { - s7_double rl= 0.0, im= 0.0; - s7_pointer result; - s7_int len= safe_strlen (q); - char ql1, pl1; - - if (q[len - 1] != 'i') - return ((want_symbol) ? make_symbol_with_strlen (sc, q) : sc->F); - - /* save original string */ - ql1= q[len - 1]; - pl1= (*(plus - 1)); - /* look for cases like 1+i */ - q[len - 1]= ((q[len - 2] == '+') || (q[len - 2] == '-')) - ? '1' - : '\0'; /* remove 'i' */ - - (*((char*) (plus - 1)))= '\0'; - - 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); - else /* no decimal point, no exponent, a ratio (1/2+i for example, but - 1+2/3i is handled below) */ + if (has_i) { - if (slash1) { - /* here the overflow could be innocuous if it's in the denominator and - * the numerator is 0: 0/100000000000000000000000000000000000000 */ - s7_int den, num= s7_string_to_integer (q, radix, &overflow); - if (overflow) return (make_undefined_overflow (sc, q)); - den= s7_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_overflow (sc, q)); /* denominator overflow */ - rl= (long_double) num / - (long_double) den; /* no gmp, so we do what we can */ - } - } - } - else { - rl= (s7_double) s7_string_to_integer (q, radix, &overflow); - if (overflow) return (make_undefined_overflow (sc, q)); - } - } - if (rl == -0.0) rl= 0.0; - - if ((has_dec_point2) || (ex2)) - im= string_to_double_with_radix (plus, radix); - else { - if (slash2) /* complex part I think */ - { - /* same as above: 0-0/100000000000000000000000000000000000000i */ - s7_int den; - const s7_int num= s7_string_to_integer (plus, radix, &overflow); - if (overflow) return (make_undefined_overflow (sc, q)); - den= s7_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_overflow (sc, q)); /* denominator overflow */ - im= (long_double) num / (long_double) den; - } - } - } - else { - im= (s7_double) s7_string_to_integer (plus, radix, &overflow); - if (overflow) return (make_undefined_overflow (sc, q)); - } + s7_double rl = 0.0, im = 0.0; + s7_pointer result; + s7_int len = safe_strlen(q); + char ql1, pl1; + + if (q[len - 1] != 'i') + return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); + + /* save original string */ + ql1 = q[len - 1]; + pl1 = (*(plus - 1)); + /* look for cases like 1+i */ + q[len - 1] = ((q[len - 2] == '+') || (q[len - 2] == '-')) ? '1' : '\0'; /* remove 'i' */ + + (*((char *)(plus - 1))) = '\0'; + + 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); + 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 den, num = s7_string_to_integer(q, radix, &overflow); + if (overflow) return(make_undefined_overflow(sc, q)); + den = s7_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_overflow(sc, q)); /* denominator overflow */ + rl = (long_double)num / (long_double)den; /* no gmp, so we do what we can */ + }}} + else + { + rl = (s7_double)s7_string_to_integer(q, radix, &overflow); + if (overflow) return(make_undefined_overflow(sc, q)); + }} + if (rl == -0.0) rl = 0.0; + + if ((has_dec_point2) || + (ex2)) + im = string_to_double_with_radix(plus, radix); + else + { + if (slash2) /* complex part I think */ + { + /* same as above: 0-0/100000000000000000000000000000000000000i */ + s7_int den; + const s7_int num = s7_string_to_integer(plus, radix, &overflow); + if (overflow) return(make_undefined_overflow(sc, q)); + den = s7_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_overflow(sc, q)); /* denominator overflow */ + im = (long_double)num / (long_double)den; + }}} + else + { + im = (s7_double)s7_string_to_integer(plus, radix, &overflow); + if (overflow) return(make_undefined_overflow(sc, q)); + }} + if ((has_plus_or_minus == -1) && + (im != 0.0)) + im = -im; + result = make_complex(sc, rl, im); + /* restore original string */ + q[len - 1] = ql1; + (*((char *)(plus - 1))) = pl1; + return(result); } - if ((has_plus_or_minus == -1) && (im != 0.0)) im= -im; - result= make_complex (sc, rl, im); - /* restore original string */ - q[len - 1] = ql1; - (*((char*) (plus - 1)))= pl1; - 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_with_strlen (sc, q) : sc->F); + if ((has_dec_point1) || + (ex1)) + { + s7_pointer result; + if (slash1) /* not complex, so slash and "." is not a number */ + return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - result= make_real (sc, string_to_double_with_radix (q, radix)); - return (result); - } + result = make_real(sc, string_to_double_with_radix(q, radix)); + return(result); + } /* rational */ - if (slash1) { - s7_int d; - const s7_int n= s7_string_to_integer (q, radix, &overflow); - if (overflow) return (make_undefined_overflow (sc, q)); - d= s7_string_to_integer (slash1, radix, &overflow); - - if ((n == 0) && (d != 0)) /* 0/100000000000000000000000000000000000000 */ - return (int_zero); - if (d == 0) - return (real_NaN); /* nan.__LINE__ here seems less than optimal */ - if (overflow) return (make_undefined_overflow (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)); - } + if (slash1) + { + s7_int d; + const s7_int n = s7_string_to_integer(q, radix, &overflow); + if (overflow) return(make_undefined_overflow(sc, q)); + d = s7_string_to_integer(slash1, radix, &overflow); + + if ((n == 0) && (d != 0)) /* 0/100000000000000000000000000000000000000 */ + return(int_zero); + if (d == 0) return(real_NaN); /* nan.__LINE__ here seems less than optimal */ + if (overflow) return(make_undefined_overflow(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)); + } /* integer */ { - s7_int x= s7_string_to_integer (q, radix, &overflow); - if (overflow) return (make_undefined_overflow (sc, q)); - return (make_integer (sc, x)); + s7_int x = s7_string_to_integer(q, radix, &overflow); + if (overflow) return(make_undefined_overflow(sc, q)); + return(make_integer(sc, x)); } } } -/* -------------------------------- string->number - * -------------------------------- */ -#define H_string_to_number \ - "(string->number str (radix 10)) converts str into a number. \ + +/* -------------------------------- string->number -------------------------------- */ +#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) +#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) /* g_string_to_number is now defined in s7_liii_string.c */ + /* (abs|magnitude -9223372036854775808) won't work here */ -/* -------------------------------- inexact helpers - * -------------------------------- */ + +/* -------------------------------- inexact helpers -------------------------------- */ #if !HAVE_COMPLEX_NUMBERS -static s7_pointer no_complex_numbers_string; + static s7_pointer no_complex_numbers_string; #endif /* -------------------------------- log -------------------------------- */ -static s7_pointer -log_chooser (s7_scheme* sc, s7_pointer func, int32_t args, s7_pointer expr) { - if (args == 2) { - s7_pointer x= cadr (expr), y= caddr (expr); - if ((is_t_integer (y)) && (integer (y) == 2) && (is_t_integer (x)) && - (integer (x) > 0)) - return (sc->int_log2); - } - return (func); +static s7_pointer log_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + if (args == 2) + { + s7_pointer x = cadr(expr), y = caddr(expr); + if ((is_t_integer(y)) && (integer(y) == 2) && (is_t_integer(x)) && (integer(x) > 0)) + return(sc->int_log2); + } + return(func); } -/* ---------------------------------------- add - * ---------------------------------------- */ -static inline s7_pointer -add_if_overflow_to_real_or_big_integer (s7_scheme* sc, s7_int x, s7_int y) { + +/* ---------------------------------------- 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_WARNINGS) - s7_warn (sc, 128, "integer add overflow: (+ %" ld64 " %" ld64 ")\n", x, - y); - return (make_real (sc, (long_double) x + (long_double) y)); - } - return (make_integer (sc, val)); + if (add_overflow(x, y, &val)) + { + 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)); + } + return(make_integer(sc, val)); #else - return (make_integer (sc, x + y)); + 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 */ +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_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))); - } - return (make_ratio (sc, z, denominator (y))); + if ((multiply_overflow(integer(x), denominator(y), &z)) || + (add_overflow(z, numerator(y), &z))) + { + 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))); + } + return(make_ratio(sc, z, denominator(y))); #else - return (make_ratio (sc, integer (x) * denominator (y) + numerator (y), - denominator (y))); + 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% */ +#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) { +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))); - if (is_t_real (y)) - return (make_real (sc, (long_double) integer (x) + real (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: - 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))); - default: - return (method_or_bust_with_type_and_loc_pp (sc, y, sc->add_symbol, x, y, - a_number_string, 2)); + /* 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))); + if (is_t_real(y)) + return(make_real(sc, (long_double)integer(x) + real(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))); - case T_RATIO: - switch (type (y)) { + switch (type(x)) + { 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) { + 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: + 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))); + default: + return(method_or_bust_with_type_and_loc_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_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)); - } - return (make_ratio_with_div_check (sc, sc->add_symbol, q, d1)); + s7_int q; + if (add_overflow(n1, n2, &q)) + { + 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)); + } + return(make_ratio_with_div_check(sc, sc->add_symbol, q, d1)); #else - return (make_ratio_with_div_check (sc, sc->add_symbol, n1 + n2, d1)); + return(make_ratio_with_div_check(sc, sc->add_symbol, 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_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))); - } - return (make_ratio_with_div_check (sc, sc->add_symbol, q, d1d2)); - } + { + 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_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))); + } + return(make_ratio_with_div_check(sc, sc->add_symbol, q, d1d2)); + } #else - return (make_ratio_with_div_check (sc, sc->add_symbol, n1 * d2 + n2 * d1, - d1 * d2)); + return(make_ratio_with_div_check(sc, sc->add_symbol, 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, (s7_double) fraction (x) + real_part (y), - imag_part (y))); - default: - return (method_or_bust_with_type_and_loc_pp (sc, y, sc->add_symbol, x, y, - a_number_string, 2)); - } + } + case T_REAL: + return(make_real(sc, fraction(x) + real(y))); + case T_COMPLEX: + return(make_complex_not_0i(sc, (s7_double)fraction(x) + real_part(y), imag_part(y))); + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); + } - case T_REAL: - switch (type (y)) { - case T_INTEGER: - return (make_real (sc, real (x) + (long_double) integer (y))); - case T_RATIO: - return (make_real (sc, real (x) + (s7_double) 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))); - default: - return (method_or_bust_with_type_and_loc_pp (sc, y, sc->add_symbol, x, y, - a_number_string, 2)); - } + switch (type(y)) + { + case T_INTEGER: + return(make_real(sc, real(x) + (long_double)integer(y))); + case T_RATIO: + return(make_real(sc, real(x) + (s7_double)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))); + default: + return(method_or_bust_with_type_and_loc_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) + (s7_double) 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))); - default: - return (method_or_bust_with_type_and_loc_pp (sc, y, sc->add_symbol, x, y, - a_number_string, 2)); - } + 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) + (s7_double)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))); + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); + } - default: - return ( - method_or_bust_pp (sc, x, sc->add_symbol, x, y, a_number_string, 1)); - } + default: + return(method_or_bust_pp(sc, x, sc->add_symbol, x, y, a_number_string, 1)); + } } -s7_pointer -s7i_add_p_pp (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (add_p_pp (sc, x, y)); -} +s7_pointer s7i_add_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(add_p_pp(sc, x, y));} -static inline s7_pointer -add_if_overflow_to_real_wrapped (s7_scheme* sc, s7_int x, s7_int y) { +static inline s7_pointer add_if_overflow_to_real_wrapped(s7_scheme *sc, s7_int x, s7_int y) +{ #if HAVE_OVERFLOW_CHECKS s7_int val; - if (add_overflow (x, y, &val)) { - if (WITH_WARNINGS) - s7_warn (sc, 128, "integer add overflow: (+ %" ld64 " %" ld64 ")\n", x, - y); - return (wrap_real (sc, (long_double) x + (long_double) y)); - } - return (wrap_integer (sc, val)); + if (add_overflow(x, y, &val)) + { + if (WITH_WARNINGS) s7_warn(sc, 128, "integer add overflow: (+ %" ld64 " %" ld64 ")\n", x, y); + return(wrap_real(sc, (long_double)x + (long_double)y)); + } + return(wrap_integer(sc, val)); #else - return (wrap_integer (sc, x + y)); + return(wrap_integer(sc, x + y)); #endif } -static s7_pointer -add_p_pp_wrapped (s7_scheme* sc, s7_pointer x, s7_pointer y) { +static s7_pointer add_p_pp_wrapped(s7_scheme *sc, s7_pointer x, s7_pointer y) +{ /* an experiment -- wraps rather than boxes results */ #if 1 - if (is_t_integer (x)) { - if (is_t_integer (y)) - return (add_if_overflow_to_real_wrapped (sc, integer (x), integer (y))); - if (is_t_real (y)) - return (wrap_real (sc, (long_double) integer (x) + real (y))); - } - else if (is_t_real (x)) { - if (is_t_real (y)) return (wrap_real (sc, real (x) + real (y))); - } - else if ((is_t_complex (x)) && (is_t_complex (y))) - return (wrap_real_or_complex (sc, real_part (x) + real_part (y), - imag_part (x) + imag_part (y))); + if (is_t_integer(x)) + { + if (is_t_integer(y)) + return(add_if_overflow_to_real_wrapped(sc, integer(x), integer(y))); + if (is_t_real(y)) + return(wrap_real(sc, (long_double)integer(x) + real(y))); + } + else + if (is_t_real(x)) + { + if (is_t_real(y)) + return(wrap_real(sc, real(x) + real(y))); + } + else + if ((is_t_complex(x)) && (is_t_complex(y))) + return(wrap_real_or_complex(sc, real_part(x) + real_part(y), imag_part(x) + imag_part(y))); #endif - switch (type (x)) { - case T_INTEGER: - switch (type (y)) { + switch (type(x)) + { case T_INTEGER: - return (add_if_overflow_to_real_wrapped (sc, integer (x), integer (y))); - case T_REAL: - return (wrap_real (sc, (long_double) integer (x) + real (y))); - case T_COMPLEX: - return (wrap_complex ( - sc, (long_double) integer (x) + (long_double) real_part (y), - imag_part (y))); - } + switch (type(y)) + { + case T_INTEGER: + return(add_if_overflow_to_real_wrapped(sc, integer(x), integer(y))); + case T_REAL: + return(wrap_real(sc, (long_double)integer(x) + real(y))); + case T_COMPLEX: + return(wrap_complex(sc, (long_double)integer(x) + (long_double)real_part(y), imag_part(y))); + } - case T_REAL: - switch (type (y)) { - case T_INTEGER: - return (wrap_real (sc, real (x) + (long_double) integer (y))); case T_REAL: - return (make_real (sc, real (x) + real (y))); - case T_COMPLEX: - return (wrap_complex (sc, real (x) + real_part (y), imag_part (y))); - } + switch (type(y)) + { + case T_INTEGER: + return(wrap_real(sc, real(x) + (long_double)integer(y))); + case T_REAL: + return(make_real(sc, real(x) + real(y))); + case T_COMPLEX: + return(wrap_complex(sc, real(x) + real_part(y), imag_part(y))); + } - case T_COMPLEX: - switch (type (y)) { - case T_INTEGER: - return (wrap_complex (sc, real_part (x) + integer (y), imag_part (x))); - case T_REAL: - return (wrap_complex (sc, real_part (x) + real (y), imag_part (x))); case T_COMPLEX: - return (wrap_real_or_complex (sc, real_part (x) + real_part (y), - imag_part (x) + imag_part (y))); - } - } - return (add_p_pp (sc, x, y)); + switch (type(y)) + { + case T_INTEGER: + return(wrap_complex(sc, real_part(x) + integer(y), imag_part(x))); + case T_REAL: + return(wrap_complex(sc, real_part(x) + real(y), imag_part(x))); + case T_COMPLEX: + return(wrap_real_or_complex(sc, real_part(x) + real_part(y), imag_part(x) + imag_part(y))); + }} + return(add_p_pp(sc, x, y)); } -s7_pointer -s7i_add_p_pp_wrapped (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (add_p_pp_wrapped (sc, x, y)); -} +s7_pointer s7i_add_p_pp_wrapped(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(add_p_pp_wrapped(sc, x, y));} -static s7_pointer -add_p_ppp (s7_scheme* sc, s7_pointer x, s7_pointer y, s7_pointer z) { - if ((is_t_integer (x)) && (is_t_integer (y)) && (is_t_integer (z))) { +static s7_pointer add_p_ppp(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_pointer z) +{ + if ((is_t_integer(x)) && (is_t_integer(y)) && (is_t_integer(z))) + { #if HAVE_OVERFLOW_CHECKS - 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))); + 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))); #else - return (make_integer (sc, integer (x) + integer (y) + integer (z))); + return(make_integer(sc, integer(x) + integer(y) + 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))); + } + if ((is_t_real(x)) && (is_t_real(y)) && (is_t_real(z))) + return(make_real(sc, real(x) + real(y) + real(z))); { - s7_pointer num = add_p_pp_wrapped (sc, x, y); - sc->error_argnum= 1; - num = add_p_pp (sc, num, z); - sc->error_argnum= 0; - return (num); + s7_pointer num = add_p_pp_wrapped(sc, x, y); + sc->error_argnum = 1; + num = add_p_pp(sc, num, z); + sc->error_argnum = 0; + return(num); } } -s7_pointer -s7i_add_p_ppp (s7_scheme* sc, s7_pointer x, s7_pointer y, s7_pointer z) { - return (add_p_ppp (sc, x, y, z)); -} +s7_pointer s7i_add_p_ppp(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_pointer z) {return(add_p_ppp(sc, x, y, z));} -static s7_pointer -add_p_ppp_wrapped (s7_scheme* sc, s7_pointer x, s7_pointer y, s7_pointer z) { - if ((is_t_integer (x)) && (is_t_integer (y)) && (is_t_integer (z))) { +static s7_pointer add_p_ppp_wrapped(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_pointer z) +{ + if ((is_t_integer(x)) && (is_t_integer(y)) && (is_t_integer(z))) + { #if HAVE_OVERFLOW_CHECKS - s7_int val; - if ((!add_overflow (integer (x), integer (y), &val)) && - (!add_overflow (val, integer (z), &val))) - return (wrap_integer (sc, val)); - if (WITH_WARNINGS) - s7_warn (sc, 128, - "integer add overflow: (+ %" ld64 " %" ld64 " %" ld64 ")\n", - integer (x), integer (y), integer (z)); - return (wrap_real (sc, (long_double) integer (x) + - (long_double) integer (y) + - (long_double) integer (z))); + s7_int val; + if ((!add_overflow(integer(x), integer(y), &val)) && + (!add_overflow(val, integer(z), &val))) + return(wrap_integer(sc, val)); + if (WITH_WARNINGS) s7_warn(sc, 128, "integer add overflow: (+ %" ld64 " %" ld64 " %" ld64 ")\n", integer(x), integer(y), integer(z)); + return(wrap_real(sc, (long_double)integer(x) + (long_double)integer(y) + (long_double)integer(z))); #else - return (wrap_integer (sc, integer (x) + integer (y) + integer (z))); + return(wrap_integer(sc, integer(x) + integer(y) + integer(z))); #endif - } - if ((is_t_real (x)) && (is_t_real (y)) && (is_t_real (z))) - return (wrap_real (sc, real (x) + real (y) + real (z))); + } + if ((is_t_real(x)) && (is_t_real(y)) && (is_t_real(z))) + return(wrap_real(sc, real(x) + real(y) + real(z))); { - s7_pointer num = add_p_pp_wrapped (sc, x, y); - sc->error_argnum= 1; - num = add_p_pp_wrapped (sc, num, z); - sc->error_argnum= 0; - return (num); + s7_pointer num = add_p_pp_wrapped(sc, x, y); + sc->error_argnum = 1; + num = add_p_pp_wrapped(sc, num, z); + sc->error_argnum = 0; + return(num); } } -s7_pointer -s7i_add_p_ppp_wrapped (s7_scheme* sc, s7_pointer x, s7_pointer y, - s7_pointer z) { - return (add_p_ppp_wrapped (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 s7i_add_p_ppp_wrapped(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_pointer z) {return(add_p_ppp_wrapped(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_p (sc, x, sc->add_symbol, a_number_string)); - return (x); - } - if (is_null (cdr (p))) return (add_p_pp (sc, x, car (p))); - for (sc->error_argnum= 0; is_pair (cdr (p)); p= cdr (p), sc->error_argnum++) - x= add_p_pp_wrapped (sc, x, car (p)); - x = add_p_pp (sc, x, car (p)); - sc->error_argnum= 0; - return (x); -} - -static s7_pointer -g_add_x1_1 (s7_scheme* sc, s7_pointer x, int32_t 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 (integer_ratio_add_if_overflow_to_real_or_rational ( - sc, int_one, x)); /* 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))); - default: - return (method_or_bust (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); -} - -static s7_pointer -g_add_x1 (s7_scheme* sc, s7_pointer args) { - s7_pointer x= car (args); - if (is_t_integer (x)) - return (add_if_overflow_to_real_or_big_integer ( - sc, integer (x), 1)); /* 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)); -} -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, int32_t loc) { - 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_integer (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))); - default: - return (method_or_bust_pp (sc, x, sc->add_symbol, x, make_integer (sc, y), - a_number_string, loc)); - } - return (x); -} - -static s7_pointer -g_add_xf (s7_scheme* sc, s7_pointer x, s7_double y, int32_t loc) { - 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, (s7_double) fraction (x) + y)); - case T_COMPLEX: - return (make_complex_not_0i (sc, real_part (x) + y, imag_part (x))); - default: - return (method_or_bust_pp (sc, x, sc->add_symbol, x, make_real (sc, y), - a_number_string, loc)); - } - return (x); -} - -static s7_pointer -add_p_pi (s7_scheme* sc, s7_pointer p1, s7_int i1) { - return (g_add_xi (sc, p1, i1, 1)); -} -static s7_pointer -add_p_dd (s7_scheme* sc, s7_double x1, s7_double x2) { - return (make_real (sc, x1 + x2)); -} /* very few calls */ -static s7_pointer -add_p_ii (s7_scheme* sc, s7_int x1, s7_int x2) { - return (make_integer (sc, x1 + x2)); -} /* no calls */ -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_id (s7_int 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 (is_quote (sc, car (arg1))) - 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= 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); + 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_p(sc, x, sc->add_symbol, a_number_string)); + return(x); + } + if (is_null(cdr(p))) + return(add_p_pp(sc, x, car(p))); + for (sc->error_argnum = 0; is_pair(cdr(p)); p = cdr(p), sc->error_argnum++) + x = add_p_pp_wrapped(sc, x, car(p)); + x = add_p_pp(sc, x, car(p)); + sc->error_argnum = 0; + return(x); } -static s7_pointer g_random_i (s7_scheme* sc, s7_pointer args); +static s7_pointer g_add_x1_1(s7_scheme *sc, s7_pointer x, int32_t pos) +{ + if (is_t_integer(x)) + return(add_if_overflow_to_real_or_big_integer(sc, integer(x), 1)); -static s7_pointer -add_chooser (s7_scheme* sc, s7_pointer func, int32_t args, s7_pointer expr) { - /* (+ s f) (+ (* s s) s) (+ s s) (+ s (* s s)) */ - if (args == 2) { - const s7_pointer arg1= cadr (expr), arg2= caddr (expr); - if ((is_pair (arg1)) && (has_fn (arg1)) && (fn_proc (arg1) == g_multiply_2)) - set_fn_direct (arg1, g_multiply_2_wrapped); - if ((is_pair (arg2)) && (has_fn (arg2))) { - if (fn_proc (arg2) == g_multiply_2) - set_fn_direct (arg2, g_multiply_2_wrapped); - if (fn_proc (arg2) == g_subtract_2) - set_fn_direct (arg2, g_subtract_2_wrapped); - } - if (arg2 == int_one) /* (+ ... 1) */ - return (sc->add_x1); - if ((is_t_integer (arg1)) && - ((is_pair (arg2)) && (is_optimized (arg2)) && (is_h_safe_c_nc (arg2)) && - (fn_proc (arg2) == g_random_i))) { - set_opt3_int (cdr (expr), integer (cadr (arg2))); - set_safe_optimize_op ( - expr, - HOP_SAFE_C_NC); /* i.e. don't evaluate random call beforehand(?) */ - return (sc->add_i_random); - } - if (arg1 == int_one) return (sc->add_1x); - return (sc->add_2); - } - return ((args == 3) ? sc->add_3 : ((args == 4) ? sc->add_4 : func)); -} - -/* ---------------------------------------- subtract - * ---------------------------------------- */ -static s7_pointer -negate_p_p (s7_scheme* sc, - s7_pointer x) /* can't use "negate" because it confuses C++! */ -{ - switch (type (x)) { - case T_INTEGER: - if (integer (x) == S7_INT64_MIN) - sole_arg_out_of_range_error_nr ( - sc, sc->subtract_symbol, x, - wrap_string (sc, "most-negative-fixnum can't be negated", 37)); - return (make_integer (sc, -integer (x))); - - case T_RATIO: - return (make_simpler_ratio (sc, -numerator (x), denominator (x))); - case T_REAL: - return (make_real (sc, -real (x))); - case T_COMPLEX: - return (make_complex_not_0i (sc, -real_part (x), -imag_part (x))); - - default: - return (method_or_bust_p (sc, x, sc->subtract_symbol, a_number_string)); - } + switch (type(x)) + { + case T_RATIO: return(integer_ratio_add_if_overflow_to_real_or_rational(sc, int_one, x)); /* 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))); + default: + return(method_or_bust(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); } -s7_pointer -s7i_negate_p_p (s7_scheme* sc, s7_pointer x) { - return (negate_p_p (sc, x)); +static s7_pointer g_add_x1(s7_scheme *sc, s7_pointer args) +{ + s7_pointer x = car(args); + if (is_t_integer(x)) return(add_if_overflow_to_real_or_big_integer(sc, integer(x), 1)); /* 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)); } +static s7_pointer g_add_1x(s7_scheme *sc, s7_pointer args) {return(g_add_x1_1(sc, cadr(args), 2));} -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_WARNINGS) - s7_warn (sc, 128, "integer subtract overflow: (- %" ld64 " %" ld64 ")\n", - x, y); - return (make_real (sc, (long_double) x - (long_double) y)); - } - return (make_integer (sc, val)); -#else - return (make_integer (sc, x - y)); -#endif -} +static s7_pointer g_add_xi(s7_scheme *sc, s7_pointer x, s7_int y, int32_t loc) +{ + if (is_t_integer(x)) + return(add_if_overflow_to_real_or_big_integer(sc, integer(x), y)); -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)) { + switch (type(x)) + { + case T_RATIO: return(add_p_pp(sc, x, wrap_integer(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))); + default: return(method_or_bust_pp(sc, x, sc->add_symbol, x, make_integer(sc, y), a_number_string, loc)); + } + return(x); +} + +static s7_pointer g_add_xf(s7_scheme *sc, s7_pointer x, s7_double y, int32_t loc) +{ + 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, (s7_double)fraction(x) + y)); + case T_COMPLEX: return(make_complex_not_0i(sc, real_part(x) + y, imag_part(x))); + default: return(method_or_bust_pp(sc, x, sc->add_symbol, x, make_real(sc, y), a_number_string, loc)); + } + return(x); +} + +static s7_pointer add_p_pi(s7_scheme *sc, s7_pointer p1, s7_int i1) {return(g_add_xi(sc, p1, i1, 1));} +static s7_pointer add_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_real(sc, x1 + x2));} /* very few calls */ +static s7_pointer add_p_ii(s7_scheme *sc, s7_int x1, s7_int x2) {return(make_integer(sc, x1 + x2));} /* no calls */ +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_id(s7_int 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 (is_quote(sc, car(arg1))) + 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 = 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 g_random_i(s7_scheme *sc, s7_pointer args); + +static s7_pointer add_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + /* (+ s f) (+ (* s s) s) (+ s s) (+ s (* s s)) */ + if (args == 2) + { + const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); + if ((is_pair(arg1)) && (has_fn(arg1)) && (fn_proc(arg1) == g_multiply_2)) set_fn_direct(arg1, g_multiply_2_wrapped); + if ((is_pair(arg2)) && (has_fn(arg2))) + { + if (fn_proc(arg2) == g_multiply_2) set_fn_direct(arg2, g_multiply_2_wrapped); + if (fn_proc(arg2) == g_subtract_2) set_fn_direct(arg2, g_subtract_2_wrapped); + } + if (arg2 == int_one) /* (+ ... 1) */ + return(sc->add_x1); + if ((is_t_integer(arg1)) && ((is_pair(arg2)) && (is_optimized(arg2)) && (is_h_safe_c_nc(arg2)) && (fn_proc(arg2) == g_random_i))) + { + set_opt3_int(cdr(expr), integer(cadr(arg2))); + set_safe_optimize_op(expr, HOP_SAFE_C_NC); /* i.e. don't evaluate random call beforehand(?) */ + return(sc->add_i_random); + } + if (arg1 == int_one) return(sc->add_1x); + return(sc->add_2); + } + return((args == 3) ? sc->add_3 : ((args == 4) ? sc->add_4 : func)); +} + +/* ---------------------------------------- subtract ---------------------------------------- */ +static s7_pointer negate_p_p(s7_scheme *sc, s7_pointer x) /* can't use "negate" because it confuses C++! */ +{ + switch (type(x)) + { + case T_INTEGER: + if (integer(x) == S7_INT64_MIN) + sole_arg_out_of_range_error_nr(sc, sc->subtract_symbol, x, wrap_string(sc, "most-negative-fixnum can't be negated", 37)); + return(make_integer(sc, -integer(x))); + + case T_RATIO: return(make_simpler_ratio(sc, -numerator(x), denominator(x))); + case T_REAL: return(make_real(sc, -real(x))); + case T_COMPLEX: return(make_complex_not_0i(sc, -real_part(x), -imag_part(x))); + + default: + return(method_or_bust_p(sc, x, sc->subtract_symbol, a_number_string)); + } +} + +s7_pointer s7i_negate_p_p(s7_scheme *sc, s7_pointer x) {return(negate_p_p(sc, x));} + +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_WARNINGS) s7_warn(sc, 128, "integer subtract overflow: (- %" ld64 " %" ld64 ")\n", x, y); + return(make_real(sc, (long_double)x - (long_double)y)); + } + 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: - return (subtract_if_overflow_to_real_or_big_integer (sc, integer (x), - integer (y))); + 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: { + 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_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))); - } - return (make_ratio (sc, z, denominator (y))); + s7_int z; + if ((multiply_overflow(integer(x), denominator(y), &z)) || + (subtract_overflow(z, numerator(y), &z))) + { + 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))); + } + return(make_ratio(sc, z, denominator(y))); #else - return (make_ratio (sc, integer (x) * denominator (y) - numerator (y), - denominator (y))); + return(make_ratio(sc, integer(x) * denominator(y) - numerator(y), denominator(y))); #endif - } - case T_REAL: - 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))); - default: - return (method_or_bust_with_type_and_loc_pp (sc, y, sc->subtract_symbol, - x, y, a_number_string, 2)); - } + } + case T_REAL: + 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))); + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); + } - case T_RATIO: - switch (type (y)) { - case T_INTEGER: { + 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_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))); - } - return (make_ratio (sc, z, denominator (x))); + s7_int z; + if ((multiply_overflow(integer(y), denominator(x), &z)) || + (subtract_overflow(numerator(x), z, &z))) + { + 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))); + } + return(make_ratio(sc, z, denominator(x))); #else - return (make_ratio (sc, numerator (x) - (integer (y) * denominator (x)), - denominator (x))); + 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) { + } + 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_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)); - } - return (make_ratio_with_div_check (sc, sc->subtract_symbol, q, d1)); + s7_int q; + if (subtract_overflow(n1, n2, &q)) + { + 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)); + } + return(make_ratio_with_div_check(sc, sc->subtract_symbol, q, d1)); #else - return ( - make_ratio (sc, numerator (x) - numerator (y), denominator (x))); + 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_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))); - } - return (make_ratio_with_div_check (sc, sc->subtract_symbol, q, d1d2)); - } + { + 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_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))); + } + return(make_ratio_with_div_check(sc, sc->subtract_symbol, q, d1d2)); + } #else - return (make_ratio_with_div_check (sc, sc->subtract_symbol, - n1 * d2 - n2 * d1, d1 * d2)); + return(make_ratio_with_div_check(sc, sc->subtract_symbol, n1 * d2 - n2 * d1, d1 * d2)); #endif - } - case T_REAL: - return (make_real (sc, (s7_double) fraction (x) - real (y))); - case T_COMPLEX: - return (make_complex_not_0i (sc, (s7_double) fraction (x) - real_part (y), - -imag_part (y))); - default: - return (method_or_bust_with_type_and_loc_pp (sc, y, sc->subtract_symbol, - x, y, a_number_string, 2)); - } + } + case T_REAL: + return(make_real(sc, (s7_double)fraction(x) - real(y))); + case T_COMPLEX: + return(make_complex_not_0i(sc, (s7_double)fraction(x) - real_part(y), -imag_part(y))); + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); + } - case T_REAL: - switch (type (y)) { - case T_INTEGER: - 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) - (s7_double) fraction (y))); case T_REAL: - return (make_real (sc, real (x) - real (y))); + switch (type(y)) + { + case T_INTEGER: + 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) - (s7_double)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))); + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); + } + case T_COMPLEX: - return ( - make_complex_not_0i (sc, real (x) - real_part (y), -imag_part (y))); - default: - return (method_or_bust_with_type_and_loc_pp (sc, y, sc->subtract_symbol, - x, y, a_number_string, 2)); + 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) - (s7_double)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))); + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); + } + + default: + return(method_or_bust_pp(sc, x, sc->subtract_symbol, x, y, a_number_string, 1)); } +} - case T_COMPLEX: - switch (type (y)) { +s7_pointer s7i_subtract_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(subtract_p_pp(sc, x, y));} + +static s7_pointer negate_p_p_wrapped(s7_scheme *sc, s7_pointer x) /* can't use "negate" because it confuses C++! */ +{ + switch (type(x)) + { 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) - (s7_double) fraction (y), - imag_part (x))); + if (integer(x) == S7_INT64_MIN) + sole_arg_out_of_range_error_nr(sc, sc->subtract_symbol, x, wrap_string(sc, "most-negative-fixnum can't be negated", 37)); + return(wrap_integer(sc, -integer(x))); case T_REAL: - return ( - make_complex_not_0i (sc, real_part (x) - real (y), imag_part (x))); + return(wrap_real(sc, -real(x))); case T_COMPLEX: - return (make_complex (sc, real_part (x) - real_part (y), - imag_part (x) - imag_part (y))); - default: - return (method_or_bust_with_type_and_loc_pp (sc, y, sc->subtract_symbol, - x, y, a_number_string, 2)); + return(wrap_complex(sc, -real_part(x), -imag_part(x))); } - - default: - return (method_or_bust_pp (sc, x, sc->subtract_symbol, x, y, - a_number_string, 1)); - } + return(negate_p_p(sc, x)); } -s7_pointer -s7i_subtract_p_pp (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (subtract_p_pp (sc, x, y)); -} +s7_pointer s7i_negate_p_p_wrapped(s7_scheme *sc, s7_pointer x) {return(negate_p_p_wrapped(sc, x));} -static s7_pointer -negate_p_p_wrapped ( - s7_scheme* sc, - s7_pointer x) /* can't use "negate" because it confuses C++! */ +static s7_pointer subtract_if_overflow_to_real_wrapped(s7_scheme *sc, s7_int x, s7_int y) { - switch (type (x)) { - case T_INTEGER: - if (integer (x) == S7_INT64_MIN) - sole_arg_out_of_range_error_nr ( - sc, sc->subtract_symbol, x, - wrap_string (sc, "most-negative-fixnum can't be negated", 37)); - return (wrap_integer (sc, -integer (x))); - case T_REAL: - return (wrap_real (sc, -real (x))); - case T_COMPLEX: - return (wrap_complex (sc, -real_part (x), -imag_part (x))); - } - return (negate_p_p (sc, x)); -} - -s7_pointer -s7i_negate_p_p_wrapped (s7_scheme* sc, s7_pointer x) { - return (negate_p_p_wrapped (sc, x)); -} - -static s7_pointer -subtract_if_overflow_to_real_wrapped (s7_scheme* sc, s7_int x, s7_int y) { #if HAVE_OVERFLOW_CHECKS s7_int val; - if (subtract_overflow (x, y, &val)) { - if (WITH_WARNINGS) - s7_warn (sc, 128, "integer subtract overflow: (- %" ld64 " %" ld64 ")\n", - x, y); - return (wrap_real (sc, (long_double) x - (long_double) y)); - } - return (wrap_integer (sc, val)); + if (subtract_overflow(x, y, &val)) + { + if (WITH_WARNINGS) s7_warn(sc, 128, "integer subtract overflow: (- %" ld64 " %" ld64 ")\n", x, y); + return(wrap_real(sc, (long_double)x - (long_double)y)); + } + return(wrap_integer(sc, val)); #else - return (wrap_integer (sc, x - y)); + return(wrap_integer(sc, x - y)); #endif } -static s7_pointer -subtract_p_pp_wrapped (s7_scheme* sc, s7_pointer x, s7_pointer y) { - switch (type (x)) { - case T_INTEGER: - if (integer (x) == 0) return (negate_p_p_wrapped (sc, y)); - switch (type (y)) { +static s7_pointer subtract_p_pp_wrapped(s7_scheme *sc, s7_pointer x, s7_pointer y) +{ + switch (type(x)) + { case T_INTEGER: - return ( - subtract_if_overflow_to_real_wrapped (sc, integer (x), integer (y))); + if (integer(x) == 0) return(negate_p_p_wrapped(sc, y)); + switch (type(y)) + { + case T_INTEGER: return(subtract_if_overflow_to_real_wrapped(sc, integer(x), integer(y))); + case T_REAL: return(wrap_real(sc, (long_double)integer(x) - real(y))); + case T_COMPLEX: return(wrap_complex(sc, (long_double)integer(x) - real_part(y), -imag_part(y))); + } case T_REAL: - return (wrap_real (sc, (long_double) integer (x) - real (y))); + switch (type(y)) + { + case T_INTEGER: return(wrap_real(sc, real(x) - (long_double)integer(y))); /* long_double saves (- 9007199254740996.0 9007199254740995): 1.0 */ + case T_REAL: return(wrap_real(sc, real(x) - real(y))); + case T_COMPLEX: return(wrap_complex(sc, real(x) - real_part(y), -imag_part(y))); + } case T_COMPLEX: - return (wrap_complex (sc, (long_double) integer (x) - real_part (y), - -imag_part (y))); + switch (type(y)) + { + case T_INTEGER: return(wrap_complex(sc, real_part(x) - integer(y), imag_part(x))); + case T_REAL: return(wrap_complex(sc, real_part(x) - real(y), imag_part(x))); + case T_COMPLEX: return(wrap_real_or_complex(sc, real_part(x) - real_part(y), imag_part(x) - imag_part(y))); + }} + return(subtract_p_pp(sc, x, y)); +} + +s7_pointer s7i_subtract_p_pp_wrapped(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(subtract_p_pp_wrapped(sc, x, y));} + +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)); + for (sc->error_argnum = 0; is_pair(cdr(p)); p = cdr(p), sc->error_argnum++) + x = subtract_p_pp_wrapped(sc, x, car(p)); + x = subtract_p_pp(sc, x, car(p)); + sc->error_argnum = 0; + return(x); +} + +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))); + default: + return(method_or_bust_pp(sc, x, sc->subtract_symbol, x, int_one, a_number_string, 1)); } - case T_REAL: - switch (type (y)) { - case T_INTEGER: - return (wrap_real ( - sc, real (x) - (long_double) integer ( - y))); /* long_double saves (- 9007199254740996.0 - 9007199254740995): 1.0 */ - case T_REAL: - return (wrap_real (sc, real (x) - real (y))); - case T_COMPLEX: - return (wrap_complex (sc, real (x) - real_part (y), -imag_part (y))); + return(x); +} + +static s7_pointer g_subtract_x1(s7_scheme *sc, s7_pointer args) +{ + s7_pointer num = car(args); + /* return((is_t_integer(num)) ? make_integer(sc, integer(num) - 1) : minus_c1(sc, num)); */ + return((is_t_integer(num)) ? subtract_if_overflow_to_real_or_big_integer(sc, integer(num), 1) : minus_c1(sc, num)); +} + +static s7_pointer g_subtract_2f(s7_scheme *sc, s7_pointer args) /* (- x f) */ +{ + const s7_pointer x = car(args); + const 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, (s7_double)fraction(x) - n)); + case T_COMPLEX: return(make_complex_not_0i(sc, real_part(x) - n, imag_part(x))); + default: + return(method_or_bust(sc, x, sc->subtract_symbol, args, a_number_string, 1)); } - case T_COMPLEX: - switch (type (y)) { - case T_INTEGER: - return (wrap_complex (sc, real_part (x) - integer (y), imag_part (x))); - case T_REAL: - return (wrap_complex (sc, real_part (x) - real (y), imag_part (x))); - case T_COMPLEX: - return (wrap_real_or_complex (sc, real_part (x) - real_part (y), - imag_part (x) - imag_part (y))); + return(x); +} + +static s7_pointer g_subtract_f2(s7_scheme *sc, s7_pointer args) /* (- f x) */ +{ + const s7_pointer x = cadr(args); + const 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 - (s7_double)fraction(x))); + case T_COMPLEX: return(make_complex_not_0i(sc, n - real_part(x), -imag_part(x))); + default: + return(method_or_bust(sc, x, sc->subtract_symbol, args, a_number_string, 1)); } - } - return (subtract_p_pp (sc, x, y)); -} - -s7_pointer -s7i_subtract_p_pp_wrapped (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (subtract_p_pp_wrapped (sc, x, y)); -} - -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)); - for (sc->error_argnum= 0; is_pair (cdr (p)); p= cdr (p), sc->error_argnum++) - x= subtract_p_pp_wrapped (sc, x, car (p)); - x = subtract_p_pp (sc, x, car (p)); - sc->error_argnum= 0; - return (x); -} - -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))); - default: - return (method_or_bust_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 num= car (args); - /* return((is_t_integer(num)) ? make_integer(sc, integer(num) - 1) : - * minus_c1(sc, num)); */ - return ((is_t_integer (num)) ? subtract_if_overflow_to_real_or_big_integer ( - sc, integer (num), 1) - : minus_c1 (sc, num)); -} - -static s7_pointer -g_subtract_2f (s7_scheme* sc, s7_pointer args) /* (- x f) */ -{ - const s7_pointer x= car (args); - const 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, (s7_double) fraction (x) - n)); - case T_COMPLEX: - return (make_complex_not_0i (sc, real_part (x) - n, imag_part (x))); - default: - return ( - method_or_bust (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) */ -{ - const s7_pointer x= cadr (args); - const 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 - (s7_double) fraction (x))); - case T_COMPLEX: - return (make_complex_not_0i (sc, n - real_part (x), -imag_part (x))); - default: - return ( - method_or_bust (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_id (s7_int 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))); - default: - return (method_or_bust_pp (sc, x, sc->subtract_symbol, x, - make_integer (sc, y), a_number_string, 1)); - } - return (x); + 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_id(s7_int 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))); + default: return(method_or_bust_pp(sc, x, sc->subtract_symbol, x, make_integer(sc, y), a_number_string, 1)); + } + return(x); } -static s7_pointer -subtract_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer expr) { +static s7_pointer subtract_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ s7_pointer arg1, arg2; - if (args == 1) return (sc->subtract_1); - if (args != 2) return ((args == 3) ? sc->subtract_3 : func); - arg1= cadr (expr); - arg2= caddr (expr); - if ((is_pair (arg1)) && (has_fn (arg1))) { - if (fn_proc (arg1) == g_multiply_2) - set_fn_direct (arg1, g_multiply_2_wrapped); - if (fn_proc (arg1) == g_add_2) set_fn_direct (arg1, g_add_2_wrapped); - } - if ((is_pair (arg2)) && (has_fn (arg2)) && (fn_proc (arg2) == g_multiply_2)) - set_fn_direct (arg2, g_multiply_2_wrapped); + if (args == 1) return(sc->subtract_1); + if (args != 2) return((args == 3) ? sc->subtract_3 : func); + arg1 = cadr(expr); + arg2 = caddr(expr); + if ((is_pair(arg1)) && (has_fn(arg1))) + { + if (fn_proc(arg1) == g_multiply_2) set_fn_direct(arg1, g_multiply_2_wrapped); + if (fn_proc(arg1) == g_add_2) set_fn_direct(arg1, g_add_2_wrapped); + } + if ((is_pair(arg2)) && (has_fn(arg2)) && (fn_proc(arg2) == g_multiply_2)) set_fn_direct(arg2, g_multiply_2_wrapped); /* sub_random_i (parallels add_i_random) only occurs in tmap.scm */ - 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); + 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); } -/* ---------------------------------------- multiply - * ---------------------------------------- */ + +/* ---------------------------------------- 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 */ +/* 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) { +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_WARNINGS) - s7_warn (sc, 128, "integer multiply overflow: (* %" ld64 " %" ld64 ")\n", - x, y); - return (make_real (sc, (s7_double) x * (s7_double) y)); - } - return (make_integer (sc, val)); + 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, (s7_double)x * (s7_double)y)); + } + return(make_integer(sc, val)); #else - return (make_integer (sc, x * y)); + 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) { +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_WARNINGS) - s7_warn (sc, 128, - "integer * ratio overflow: (* %" ld64 " %" ld64 "/%" ld64 ")\n", - x, numerator (y), denominator (y)); - return (make_real (sc, (s7_double) x * (s7_double) fraction (y))); - } - return (make_ratio (sc, z, denominator (y))); + if (multiply_overflow(x, numerator(y), &z)) + { + if (WITH_WARNINGS) s7_warn(sc, 128, "integer * ratio overflow: (* %" ld64 " %" ld64 "/%" ld64 ")\n", x, numerator(y), denominator(y)); + return(make_real(sc, (s7_double)x * (s7_double)fraction(y))); + } + return(make_ratio(sc, z, denominator(y))); #else - return (make_ratio (sc, x * numerator (y), denominator (y))); + 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)) { +static s7_pointer multiply_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) +{ + switch (type(x)) + { case T_INTEGER: - return (multiply_if_overflow_to_real_or_big_integer (sc, integer (x), - integer (y))); + 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: + return(make_real(sc, (long_double)integer(x) * real(y))); + case T_COMPLEX: + return(make_complex(sc, (long_double)integer(x) * real_part(y), (long_double)integer(x) * imag_part(y))); + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); + } case T_RATIO: - return (integer_ratio_multiply_if_overflow_to_real_or_ratio ( - sc, integer (x), y)); - case T_REAL: - return (make_real (sc, (long_double) integer (x) * real (y))); - case T_COMPLEX: - return (make_complex (sc, (long_double) integer (x) * real_part (y), - (long_double) integer (x) * imag_part (y))); - default: - return (method_or_bust_with_type_and_loc_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); + 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_WARNINGS) - s7_warn (sc, 128, - "ratio * ratio overflow: (* %" ld64 "/%" ld64 " %" ld64 - "/%" ld64 ")\n", - n1, d1, n2, d2); - return (make_real (sc, (s7_double) fraction (x) * - (s7_double) fraction (y))); - } - return ( - make_ratio_with_div_check (sc, sc->multiply_symbol, n1n2, d1d2)); - } + { + s7_int n1n2, d1d2; + if ((multiply_overflow(d1, d2, &d1d2)) || + (multiply_overflow(n1, n2, &n1n2))) + { + if (WITH_WARNINGS) s7_warn(sc, 128, "ratio * ratio overflow: (* %" ld64 "/%" ld64 " %" ld64 "/%" ld64 ")\n", n1, d1, n2, d2); + return(make_real(sc, (s7_double)fraction(x) * (s7_double)fraction(y))); + } + return(make_ratio_with_div_check(sc, sc->multiply_symbol, n1n2, d1d2)); + } #else - return (make_ratio_with_div_check (sc, sc->multiply_symbol, n1 * n2, - d1 * d2)); + return(make_ratio_with_div_check(sc, sc->multiply_symbol, n1 * n2, d1 * d2)); #endif - } - case T_REAL: - return (make_real (sc, (s7_double) fraction (x) * real (y))); - case T_COMPLEX: - return (make_complex (sc, (s7_double) fraction (x) * real_part (y), - (s7_double) fraction (x) * imag_part (y))); - default: - return (method_or_bust_with_type_and_loc_pp (sc, y, sc->multiply_symbol, - x, y, a_number_string, 2)); - } - case T_REAL: - switch (type (y)) { - case T_INTEGER: - return (make_real (sc, real (x) * (long_double) integer (y))); - case T_RATIO: - return (make_real (sc, (s7_double) fraction (y) * real (x))); + } + case T_REAL: + return(make_real(sc, (s7_double)fraction(x) * real(y))); + case T_COMPLEX: + return(make_complex(sc, (s7_double)fraction(x) * real_part(y), (s7_double)fraction(x) * imag_part(y))); + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); + } case T_REAL: - return (make_real (sc, real (x) * real (y))); + switch (type(y)) + { + case T_INTEGER: + return(make_real(sc, real(x) * (long_double)integer(y))); + case T_RATIO: + return(make_real(sc, (s7_double)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))); + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); + } case T_COMPLEX: - return (make_complex (sc, real (x) * real_part (y), - real (x) * imag_part (y))); - default: - return (method_or_bust_with_type_and_loc_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 (make_complex (sc, real_part (x) * (s7_double) fraction (y), - imag_part (x) * (s7_double) 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= 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)); - } - default: - return (method_or_bust_with_type_and_loc_pp (sc, y, sc->multiply_symbol, - x, y, a_number_string, 2)); - } + switch (type(y)) + { + case T_INTEGER: + return(make_complex(sc, real_part(x) * integer(y), imag_part(x) * integer(y))); + case T_RATIO: + return(make_complex(sc, real_part(x) * (s7_double)fraction(y), imag_part(x) * (s7_double)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 = 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)); + } + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); + } - default: - return (method_or_bust_pp (sc, x, sc->multiply_symbol, x, y, - a_number_string, 1)); - } + default: + return(method_or_bust_pp(sc, x, sc->multiply_symbol, x, y, a_number_string, 1)); + } } -s7_pointer -s7i_multiply_p_pp (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (multiply_p_pp (sc, x, y)); -} +s7_pointer s7i_multiply_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(multiply_p_pp(sc, x, y));} -static inline s7_pointer -multiply_if_overflow_to_real_wrapped (s7_scheme* sc, s7_int x, s7_int y) { +static inline s7_pointer multiply_if_overflow_to_real_wrapped(s7_scheme *sc, s7_int x, s7_int y) +{ #if HAVE_OVERFLOW_CHECKS s7_int val; - if (multiply_overflow (x, y, &val)) { - if (WITH_WARNINGS) - s7_warn (sc, 128, "integer multiply overflow: (* %" ld64 " %" ld64 ")\n", - x, y); - return (wrap_real (sc, (s7_double) x * (s7_double) y)); - } - return (wrap_integer (sc, val)); + if (multiply_overflow(x, y, &val)) + { + if (WITH_WARNINGS) s7_warn(sc, 128, "integer multiply overflow: (* %" ld64 " %" ld64 ")\n", x, y); + return(wrap_real(sc, (s7_double)x * (s7_double)y)); + } + return(wrap_integer(sc, val)); #else - return (wrap_integer (sc, x * y)); + return(wrap_integer(sc, x * y)); #endif } -static s7_pointer -multiply_p_pp_wrapped (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_wrapped (sc, integer (x), integer (y))); - case T_REAL: - return (wrap_real (sc, (long_double) integer (x) * real (y))); - case T_COMPLEX: - return (wrap_real_or_complex (sc, - (long_double) integer (x) * real_part (y), - (long_double) integer (x) * imag_part (y))); - } - case T_REAL: - switch (type (y)) { +static s7_pointer multiply_p_pp_wrapped(s7_scheme *sc, s7_pointer x, s7_pointer y) +{ + switch (type(x)) + { case T_INTEGER: - return (wrap_real (sc, real (x) * (long_double) integer (y))); + switch (type(y)) + { + case T_INTEGER: return(multiply_if_overflow_to_real_wrapped(sc, integer(x), integer(y))); + case T_REAL: return(wrap_real(sc, (long_double)integer(x) * real(y))); + case T_COMPLEX: return(wrap_real_or_complex(sc, (long_double)integer(x) * real_part(y), (long_double)integer(x) * imag_part(y))); + } case T_REAL: - return (wrap_real (sc, real (x) * real (y))); + switch (type(y)) + { + case T_INTEGER: return(wrap_real(sc, real(x) * (long_double)integer(y))); + case T_REAL: return(wrap_real(sc, real(x) * real(y))); + case T_COMPLEX: return(wrap_real_or_complex(sc, real(x) * real_part(y), real(x) * imag_part(y))); + } case T_COMPLEX: - return (wrap_real_or_complex (sc, real (x) * real_part (y), - real (x) * imag_part (y))); - } - case T_COMPLEX: - switch (type (y)) { - case T_INTEGER: - return (wrap_real_or_complex (sc, real_part (x) * integer (y), - real_part (x) * imag_part (y))); - case T_REAL: - return (wrap_real_or_complex (sc, real_part (x) * real (y), - imag_part (x) * imag_part (y))); - case T_COMPLEX: { - s7_double r1= real_part (x), r2= real_part (y), i1= imag_part (x), - i2= imag_part (y); - return (wrap_real_or_complex (sc, r1 * r2 - i1 * i2, r1 * i2 + r2 * i1)); - } - } - } - return (multiply_p_pp (sc, x, y)); + switch (type(y)) + { + case T_INTEGER: return(wrap_real_or_complex(sc, real_part(x) * integer(y), real_part(x) * imag_part(y))); + case T_REAL: return(wrap_real_or_complex(sc, real_part(x) * real(y), imag_part(x) * imag_part(y))); + case T_COMPLEX: + { + s7_double r1 = real_part(x), r2 = real_part(y), i1 = imag_part(x), i2 = imag_part(y); + return(wrap_real_or_complex(sc, r1 * r2 - i1 * i2, r1 * i2 + r2 * i1)); + }}} + return(multiply_p_pp(sc, x, y)); } -s7_pointer -s7i_multiply_p_pp_wrapped (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (multiply_p_pp_wrapped (sc, x, y)); -} +s7_pointer s7i_multiply_p_pp_wrapped(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(multiply_p_pp_wrapped(sc, x, y));} -static s7_pointer -multiply_p_ppp (s7_scheme* sc, s7_pointer x, s7_pointer y, s7_pointer z) { +static s7_pointer multiply_p_ppp(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_pointer z) +{ /* no hits for reals in tnum */ - /* if ((is_t_real(x)) && (is_t_real(y)) && (is_t_real(z))) - * return(make_real(sc, real(x) * real(y) * real(z))); */ - x = multiply_p_pp_wrapped (sc, x, y); - sc->error_argnum= 1; - x = multiply_p_pp (sc, x, z); - sc->error_argnum= 0; - return (x); + /* if ((is_t_real(x)) && (is_t_real(y)) && (is_t_real(z))) return(make_real(sc, real(x) * real(y) * real(z))); */ + x = multiply_p_pp_wrapped(sc, x, y); + sc->error_argnum = 1; + x = multiply_p_pp(sc, x, z); + sc->error_argnum = 0; + return(x); } -s7_pointer -s7i_multiply_p_ppp (s7_scheme* sc, s7_pointer x, s7_pointer y, s7_pointer z) { - return (multiply_p_ppp (sc, x, y, z)); -} +s7_pointer s7i_multiply_p_ppp(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_pointer z) {return(multiply_p_ppp(sc, x, y, z));} -static s7_pointer -multiply_p_ppp_wrapped (s7_scheme* sc, s7_pointer x, s7_pointer y, - s7_pointer z) { +static s7_pointer multiply_p_ppp_wrapped(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_pointer z) +{ /* no hits for reals in tnum */ - /* if ((is_t_real(x)) && (is_t_real(y)) && (is_t_real(z))) - * return(make_real(sc, real(x) * real(y) * real(z))); */ - x = multiply_p_pp_wrapped (sc, x, y); - sc->error_argnum= 1; - x = multiply_p_pp_wrapped (sc, x, z); - sc->error_argnum= 0; - return (x); -} - -s7_pointer -s7i_multiply_p_ppp_wrapped (s7_scheme* sc, s7_pointer x, s7_pointer y, - s7_pointer z) { - return (multiply_p_ppp_wrapped (sc, x, y, z)); -} - -static s7_pointer -multiply_method_or_bust (s7_scheme* sc, s7_pointer obj, 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 ((is_t_real(x)) && (is_t_real(y)) && (is_t_real(z))) return(make_real(sc, real(x) * real(y) * real(z))); */ + x = multiply_p_pp_wrapped(sc, x, y); + sc->error_argnum = 1; + x = multiply_p_pp_wrapped(sc, x, z); + sc->error_argnum = 0; + return(x); +} + +s7_pointer s7i_multiply_p_ppp_wrapped(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_pointer z) {return(multiply_p_ppp_wrapped(sc, x, y, z));} + +static s7_pointer multiply_method_or_bust(s7_scheme *sc, s7_pointer obj, 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) - sole_arg_wrong_type_error_nr (sc, sc->multiply_symbol, obj, typ); - wrong_type_error_nr (sc, sc->multiply_symbol, num, obj, typ); - return (NULL); + sole_arg_wrong_type_error_nr(sc, sc->multiply_symbol, obj, typ); + wrong_type_error_nr(sc, sc->multiply_symbol, num, obj, typ); + return(NULL); } -static s7_pointer -g_multiply (s7_scheme* sc, s7_pointer args) { -#define H_multiply "(* ...) multiplies its arguments" -#define Q_multiply sc->pcl_n +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, args, a_number_string, 0)); - return (x); - } - for (sc->error_argnum= 0; is_pair (cdr (p)); p= cdr (p), sc->error_argnum++) - x= multiply_p_pp_wrapped (sc, x, car (p)); - x = multiply_p_pp (sc, x, car (p)); - sc->error_argnum= 0; - return (x); -} - -static s7_pointer -g_mul_xi (s7_scheme* sc, s7_pointer x, s7_int n, int32_t loc) { - 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 (make_complex (sc, real_part (x) * n, imag_part (x) * n)); - 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_pp (sc, x, sc->multiply_symbol, x, - make_integer (sc, n), a_number_string, loc)); - } - return (x); + 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, args, a_number_string, 0)); + return(x); + } + for (sc->error_argnum = 0; is_pair(cdr(p)); p = cdr(p), sc->error_argnum++) + x = multiply_p_pp_wrapped(sc, x, car(p)); + x = multiply_p_pp(sc, x, car(p)); + sc->error_argnum = 0; + return(x); } -static s7_pointer -multiply_p_pi (s7_scheme* sc, s7_pointer p1, s7_int i1) { - return (g_mul_xi (sc, p1, i1, 1)); +static s7_pointer g_mul_xi(s7_scheme *sc, s7_pointer x, s7_int n, int32_t loc) +{ + 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(make_complex(sc, real_part(x) * n, imag_part(x) * n)); + 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_pp(sc, x, sc->multiply_symbol, x, make_integer(sc, n), a_number_string, loc)); + } + return(x); } -static s7_pointer -g_mul_xf (s7_scheme* sc, s7_pointer x, s7_double y, int32_t num) { - /* it's possible to return different argument NaNs depending on the expression - * or how it is wrapped: +static s7_pointer multiply_p_pi(s7_scheme *sc, s7_pointer p1, s7_int i1) {return(g_mul_xi(sc, p1, i1, 1));} + +static s7_pointer g_mul_xf(s7_scheme *sc, s7_pointer x, s7_double y, int32_t num) +{ + /* it's possible to return different argument NaNs depending on the expression or how it is wrapped: * (* (bignum +nan.0) +nan.123) -> nan.123 - * (let () (define (func) (* (bignum +nan.0) +nan.123)) (func) (func)) -> - * nan.0 latter call is fx_c_aaa->fx_c_ac->g_mul_xf (if +nan.122 instead of - * +nan.0, we get +nan.122 so we always get one of the NaNs) + * (let () (define (func) (* (bignum +nan.0) +nan.123)) (func) (func)) -> nan.0 + * latter call is fx_c_aaa->fx_c_ac->g_mul_xf (if +nan.122 instead of +nan.0, we get +nan.122 so we always get one of the NaNs) */ - 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 (make_complex (sc, real_part (x) * y, imag_part (x) * y)); - default: - return (method_or_bust_pp (sc, x, sc->multiply_symbol, x, make_real (sc, y), - a_number_string, num)); - } - return (x); + 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(make_complex(sc, real_part(x) * y, imag_part(x) * y)); + default: return(method_or_bust_pp(sc, x, sc->multiply_symbol, x, make_real(sc, y), a_number_string, num)); + } + return(x); } -static s7_int -multiply_i_ii (s7_int i1, s7_int i2) { +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 (multiply_overflow(i1, i2, &val)) + { #if WITH_WARNINGS - fprintf (stderr, - "%s[%d]: integer multiply overflow: (* %" ld64 " %" ld64 ")\n", - __func__, __LINE__, i1, i2); + fprintf(stderr, "%s[%d]: integer multiply overflow: (* %" ld64 " %" ld64 ")\n", __func__, __LINE__, i1, i2); #endif - 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); + 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); + return(i1 * i2); #endif } -static s7_int -multiply_i_iii (s7_int i1, s7_int i2, s7_int i3) { +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 ((multiply_overflow(i1, i2, &val1)) || + (multiply_overflow(val1, i3, &val2))) + { #if WITH_WARNINGS - fprintf (stderr, - "%s[%d]: integer multiply overflow: (* %" ld64 " %" ld64 " %" ld64 - ")\n", - __func__, __LINE__, i1, i2, i3); + fprintf(stderr, "%s[%d]: integer multiply overflow: (* %" ld64 " %" ld64 " %" ld64 ")\n", __func__, __LINE__, i1, i2, i3); #endif - return (S7_INT64_MAX); - } - return (val2); + return(S7_INT64_MAX); + } + return(val2); #else - return (i1 * i2 * i3); + 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_id (s7_int 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_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_id(s7_int 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 func, int32_t args, - s7_pointer expr) { +static s7_pointer multiply_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ s7_pointer arg1, arg2; - if (args < 2) return (func); - arg1= cadr (expr); - if ((is_pair (arg1)) && (has_fn (arg1))) { - if (fn_proc (arg1) == g_add_2) set_fn_direct (arg1, g_add_2_wrapped); - if (fn_proc (arg1) == g_add_3) set_fn_direct (arg1, g_add_3_wrapped); - if (fn_proc (arg1) == g_subtract_2) - set_fn_direct (arg1, g_subtract_2_wrapped); - if (fn_proc (arg1) == g_subtract_1) - set_fn_direct (arg1, g_subtract_1_wrapped); - } - arg2= caddr (expr); - if ((is_pair (arg2)) && (has_fn (arg2))) { - if (fn_proc (arg2) == g_add_2) set_fn_direct (arg2, g_add_2_wrapped); - if (fn_proc (arg2) == g_add_3) set_fn_direct (arg2, g_add_3_wrapped); - if (fn_proc (arg2) == g_subtract_2) - set_fn_direct (arg2, g_subtract_2_wrapped); - if (fn_proc (arg2) == g_subtract_1) - set_fn_direct (arg2, g_subtract_1_wrapped); - } - if (args == 2) return (sc->multiply_2); - if (args == 3) return (sc->multiply_3); - return (func); -} - -/* ---------------------------------------- divide - * ---------------------------------------- */ -static s7_pointer -complex_invert (s7_scheme* sc, s7_pointer x) { - s7_double r2= real_part (x), i2= imag_part (x); - s7_double den= (r2 * r2 + i2 * i2); - /* here if x 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 (make_complex (sc, r2 / den, -i2 / den)); -} - -static s7_pointer -invert_p_p (s7_scheme* sc, s7_pointer num) { - switch (type (num)) { - case T_INTEGER: - if (integer (num) == 0) - division_by_zero_error_1_nr (sc, sc->divide_symbol, num); - return (make_simple_ratio (sc, 1, integer (num))); /* this checks for int */ - case T_RATIO: - return (make_simple_ratio (sc, denominator (num), numerator (num))); - case T_REAL: - if (real (num) == 0.0) - division_by_zero_error_1_nr (sc, sc->divide_symbol, num); - return (make_real (sc, 1.0 / real (num))); - case T_COMPLEX: - return (complex_invert (sc, num)); - - default: - if_method_exists_return_value (sc, num, sc->divide_symbol, - set_plist_1 (sc, num)); - wrong_type_error_nr (sc, sc->divide_symbol, 1, num, a_number_string); - } - return (NULL); + if (args < 2) return(func); + arg1 = cadr(expr); + if ((is_pair(arg1)) && (has_fn(arg1))) + { + if (fn_proc(arg1) == g_add_2) set_fn_direct(arg1, g_add_2_wrapped); + if (fn_proc(arg1) == g_add_3) set_fn_direct(arg1, g_add_3_wrapped); + if (fn_proc(arg1) == g_subtract_2) set_fn_direct(arg1, g_subtract_2_wrapped); + if (fn_proc(arg1) == g_subtract_1) set_fn_direct(arg1, g_subtract_1_wrapped); + } + arg2 = caddr(expr); + if ((is_pair(arg2)) && (has_fn(arg2))) + { + if (fn_proc(arg2) == g_add_2) set_fn_direct(arg2, g_add_2_wrapped); + if (fn_proc(arg2) == g_add_3) set_fn_direct(arg2, g_add_3_wrapped); + if (fn_proc(arg2) == g_subtract_2) set_fn_direct(arg2, g_subtract_2_wrapped); + if (fn_proc(arg2) == g_subtract_1) set_fn_direct(arg2, g_subtract_1_wrapped); + } + if (args == 2) return(sc->multiply_2); + if (args == 3) return(sc->multiply_3); + return(func); } -s7_pointer -s7i_invert_p_p (s7_scheme* sc, s7_pointer x) { - return (invert_p_p (sc, x)); + +/* ---------------------------------------- divide ---------------------------------------- */ +static s7_pointer complex_invert(s7_scheme *sc, s7_pointer x) +{ + s7_double r2 = real_part(x), i2 = imag_part(x); + s7_double den = (r2 * r2 + i2 * i2); + /* here if x 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(make_complex(sc, r2 / den, -i2 / den)); } -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 -------- */ +static s7_pointer invert_p_p(s7_scheme *sc, s7_pointer num) +{ + switch (type(num)) + { case T_INTEGER: - if (integer (y) == 0) - division_by_zero_error_2_nr (sc, sc->divide_symbol, 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))); /* make_ratio calls gcd */ + if (integer(num) == 0) + division_by_zero_error_1_nr(sc, sc->divide_symbol, num); + return(make_simple_ratio(sc, 1, integer(num))); /* this checks for int */ case T_RATIO: -#if HAVE_OVERFLOW_CHECKS - { - s7_int dn; - if (multiply_overflow (integer (x), denominator (y), &dn)) { - 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))); - } - return ( - make_ratio_with_div_check (sc, sc->divide_symbol, dn, numerator (y))); - } -#else - return (make_ratio_with_div_check ( - sc, sc->divide_symbol, integer (x) * denominator (y), numerator (y))); -#endif + return(make_simple_ratio(sc, denominator(num), numerator(num))); case T_REAL: - if (is_NaN (real (y))) return (y); - if (is_inf (real (y))) return (real_zero); - if (real (y) == 0.0) - division_by_zero_error_2_nr (sc, sc->divide_symbol, x, y); - return (make_real (sc, (s7_double) (integer (x)) / real (y))); - case T_COMPLEX: { - s7_double r1= (s7_double) integer (x), r2= real_part (y), - i2 = imag_part (y); - s7_double 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 (make_complex (sc, r1 * r2 * den, -(r1 * i2 * den))); - } + if (real(num) == 0.0) + division_by_zero_error_1_nr(sc, sc->divide_symbol, num); + return(make_real(sc, 1.0 / real(num))); + case T_COMPLEX: + return(complex_invert(sc, num)); default: - return (method_or_bust_with_type_and_loc_pp (sc, y, sc->divide_symbol, x, - y, a_number_string, 2)); + if_method_exists_return_value(sc, num, sc->divide_symbol, set_plist_1(sc, num)); + wrong_type_error_nr(sc, sc->divide_symbol, 1, num, a_number_string); } - break; + return(NULL); +} + +s7_pointer s7i_invert_p_p(s7_scheme *sc, s7_pointer x) {return(invert_p_p(sc, x));} - /* -------- ratio x -------- */ - case T_RATIO: - switch (type (y)) { +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: - if (integer (y) == 0) - division_by_zero_error_2_nr (sc, sc->divide_symbol, x, y); + switch (type(y)) + { + /* -------- integer x -------- */ + case T_INTEGER: + if (integer(y) == 0) + division_by_zero_error_2_nr(sc, sc->divide_symbol, 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))); /* make_ratio calls gcd */ + case T_RATIO: #if HAVE_OVERFLOW_CHECKS - { - s7_int dn; - if (multiply_overflow (denominator (x), integer (y), &dn)) { - 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)))); - } - return (make_ratio_with_div_check (sc, sc->divide_symbol, numerator (x), - dn)); - } + { + s7_int dn; + if (multiply_overflow(integer(x), denominator(y), &dn)) + { + 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))); + } + return(make_ratio_with_div_check(sc, sc->divide_symbol, dn, numerator(y))); + } #else - return (make_ratio_with_div_check (sc, sc->divide_symbol, numerator (x), - denominator (x) * integer (y))); + return(make_ratio_with_div_check(sc, sc->divide_symbol, integer(x) * denominator(y), numerator(y))); #endif - case T_RATIO: { - s7_int d1, d2, n1, n2; - parcel_out_fractions (x, y); - if (d1 == d2) - return (make_ratio_with_div_check (sc, sc->divide_symbol, n1, n2)); + case T_REAL: + if (is_NaN(real(y))) return(y); + if (is_inf(real(y))) return(real_zero); + if (real(y) == 0.0) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + return(make_real(sc, (s7_double)(integer(x)) / real(y))); + case T_COMPLEX: + { + s7_double r1 = (s7_double)integer(x), r2 = real_part(y), i2 = imag_part(y); + s7_double 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(make_complex(sc, r1 * r2 * den, -(r1 * i2 * den))); + } + + default: + return(method_or_bust_with_type_and_loc_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) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); #if HAVE_OVERFLOW_CHECKS - if ((multiply_overflow (n1, d2, &n1)) || - (multiply_overflow (n2, d1, &d1))) { - 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)); - } - return (make_ratio_with_div_check (sc, sc->divide_symbol, n1, d1)); + { + s7_int dn; + if (multiply_overflow(denominator(x), integer(y), &dn)) + { + 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)))); + } + return(make_ratio_with_div_check(sc, sc->divide_symbol, numerator(x), dn)); + } #else - return ( - make_ratio_with_div_check (sc, sc->divide_symbol, n1 * d2, n2 * d1)); + return(make_ratio_with_div_check(sc, sc->divide_symbol, numerator(x), denominator(x) * integer(y))); #endif - } - case T_REAL: - if (real (y) == 0.0) - division_by_zero_error_2_nr (sc, sc->divide_symbol, x, y); - return (make_real (sc, (s7_double) fraction (x) / real (y))); - case T_COMPLEX: { - s7_double rx= fraction (x), r2= real_part (y), i2= imag_part (y); - s7_double den= 1.0 / (r2 * r2 + i2 * i2); - return ( - make_complex (sc, rx * r2 * den, - -rx * i2 * den)); /* not unchecked: (/ 3/4 -inf.0+i) */ - } - - default: - return (method_or_bust_with_type_and_loc_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) - division_by_zero_error_2_nr (sc, sc->divide_symbol, x, y); - if (is_NaN (real (x))) return (x); /* 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 (x); - 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_RATIO: + { + s7_int d1, d2, n1, n2; + parcel_out_fractions(x, y); + if (d1 == d2) + return(make_ratio_with_div_check(sc, sc->divide_symbol, n1, n2)); +#if HAVE_OVERFLOW_CHECKS + if ((multiply_overflow(n1, d2, &n1)) || + (multiply_overflow(n2, d1, &d1))) + { + 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)); + } + return(make_ratio_with_div_check(sc, sc->divide_symbol, n1, d1)); +#else + return(make_ratio_with_div_check(sc, sc->divide_symbol, n1 * d2, n2 * d1)); +#endif + } + case T_REAL: + if (real(y) == 0.0) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + return(make_real(sc, (s7_double)fraction(x) / real(y))); + case T_COMPLEX: + { + s7_double rx = fraction(x), r2 = real_part(y), i2 = imag_part(y); + s7_double den = 1.0 / (r2 * r2 + i2 * i2); + return(make_complex(sc, rx * r2 * den, -rx * i2 * den)); /* not unchecked: (/ 3/4 -inf.0+i) */ + } + + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); + } + + /* -------- real x -------- */ case T_REAL: - if (is_NaN (real (y))) return (y); - if (real (y) == 0.0) - division_by_zero_error_2_nr (sc, sc->divide_symbol, x, y); - if (is_NaN (real (x))) return (x); - 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 (make_complex (sc, real (x) * r2 * den, -real (x) * i2 * den)); - } - - default: - return (method_or_bust_with_type_and_loc_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) - division_by_zero_error_2_nr (sc, sc->divide_symbol, x, y); - r1= (long_double) 1.0 / (long_double) integer (y); - return (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) - division_by_zero_error_2_nr (sc, sc->divide_symbol, 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= real_part (x), r2, i1, i2, den; - if (is_NaN (r1)) return (x); - i1= imag_part (x); - if (is_NaN (i1)) return (x); - r2= real_part (y); - if (is_NaN (r2)) return (y); - if (is_inf (r2)) return (complex_NaN); - i2= imag_part (y); - if (is_NaN (i2)) return (y); - den= 1.0 / (r2 * r2 + i2 * i2); - return (make_complex (sc, (r1 * r2 + i1 * i2) * den, - (r2 * i1 - r1 * i2) * den)); - } + switch (type(y)) + { + case T_INTEGER: + if (integer(y) == 0) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + if (is_NaN(real(x))) return(x); /* 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(x); + 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(y); + if (real(y) == 0.0) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + if (is_NaN(real(x))) return(x); + 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(make_complex(sc, real(x) * r2 * den, -real(x) * i2 * den)); + } + + default: + return(method_or_bust_with_type_and_loc_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) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + r1 = (long_double)1.0 / (long_double)integer(y); + return(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) + division_by_zero_error_2_nr(sc, sc->divide_symbol, 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 = real_part(x), r2, i1, i2, den; + if (is_NaN(r1)) return(x); + i1 = imag_part(x); + if (is_NaN(i1)) return(x); + r2 = real_part(y); + if (is_NaN(r2)) return(y); + if (is_inf(r2)) return(complex_NaN); + i2 = imag_part(y); + if (is_NaN(i2)) return(y); + den = 1.0 / (r2 * r2 + i2 * i2); + return(make_complex(sc, (r1 * r2 + i1 * i2) * den, (r2 * i1 - r1 * i2) * den)); + } + + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); + } + + + default: /* x is not a built-in number */ + return(method_or_bust_pp(sc, x, sc->divide_symbol, x, y, a_number_string, 1)); /* not args here! y = apply * to cdr(args) */ + } + if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: we should not be here\n", __func__, __LINE__); + return(NULL); /* make the compiler happy */ +} + +s7_pointer s7i_divide_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(divide_p_pp(sc, x, y));} + +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 - default: - return (method_or_bust_with_type_and_loc_pp (sc, y, sc->divide_symbol, x, - y, a_number_string, 2)); + s7_pointer x = car(args), p = cdr(args); + if (is_null(p)) /* (/ x) */ + { + if (!is_number(x)) + return(method_or_bust_p(sc, x, sc->divide_symbol, a_number_string)); + return(invert_p_p(sc, x)); } - - default: /* x is not a built-in number */ - return ( - method_or_bust_pp (sc, x, sc->divide_symbol, x, y, a_number_string, - 1)); /* not args here! y = apply * to cdr(args) */ - } - if (S7_DEBUGGING) - fprintf (stderr, "%s[%d]: we should not be here\n", __func__, __LINE__); - return (NULL); /* make the compiler happy */ -} - -s7_pointer -s7i_divide_p_pp (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (divide_p_pp (sc, x, y)); + for (sc->error_argnum = 0; is_pair(p); p = cdr(p), sc->error_argnum++) + x = divide_p_pp(sc, x, car(p)); + sc->error_argnum = 0; + return(x); } -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), p= cdr (args); - if (is_null (p)) /* (/ x) */ - { - if (!is_number (x)) - return (method_or_bust_p (sc, x, sc->divide_symbol, a_number_string)); - return (invert_p_p (sc, x)); - } - for (sc->error_argnum= 0; is_pair (p); p= cdr (p), sc->error_argnum++) - x= divide_p_pp (sc, x, car (p)); - sc->error_argnum= 0; - return (x); -} - -static s7_pointer -g_divide_by_2 (s7_scheme* sc, s7_pointer args) { - const 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); - set_numerator (x, i); - set_denominator (x, 2); - return (x); - } - return (make_integer (sc, i >> 1)); - } - switch (type (num)) { - case T_RATIO: +static s7_pointer g_divide_by_2(s7_scheme *sc, s7_pointer args) +{ + const 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); + set_numerator(x, i); + set_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_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))); + { + s7_int dn; + if (multiply_overflow(denominator(num), 2, &dn)) + { + if ((numerator(num) & 1) == 1) + { + 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))); + } + return(make_ratio(sc, numerator(num) / 2, denominator(num))); + } + return(make_ratio_with_div_check(sc, sc->divide_symbol, numerator(num), dn)); } - return (make_ratio (sc, numerator (num) / 2, denominator (num))); - } - return ( - make_ratio_with_div_check (sc, sc->divide_symbol, numerator (num), dn)); - } #else - return (make_ratio (sc, numerator (num), denominator (num) * 2)); + 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)); - - default: - return (method_or_bust_pp (sc, num, sc->divide_symbol, num, int_two, - a_number_string, 1)); - } + 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)); + + default: + return(method_or_bust_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) { +static s7_pointer g_invert_x(s7_scheme *sc, s7_pointer args) +{ /* (/ 1.0 x) */ - const s7_pointer x= cadr (args); - if (is_t_real (x)) { - s7_double rl= real (x); - if (rl == 0.0) - division_by_zero_error_2_nr (sc, sc->divide_symbol, car (args), x); - return ((is_NaN (rl)) ? x : make_real (sc, 1.0 / rl)); - } - return (divide_p_pp (sc, car (args), x)); + const s7_pointer x = cadr(args); + if (is_t_real(x)) + { + s7_double rl = real(x); + if (rl == 0.0) + division_by_zero_error_2_nr(sc, sc->divide_symbol, car(args), x); + return((is_NaN(rl)) ? x : make_real(sc, 1.0 / rl)); + } + return(divide_p_pp(sc, car(args), x)); } -static s7_double -divide_d_7d (s7_scheme* sc, s7_double x) { - if (x == 0.0) division_by_zero_error_1_nr (sc, sc->divide_symbol, real_zero); - return (1.0 / x); +static s7_double divide_d_7d(s7_scheme *sc, s7_double x) +{ + if (x == 0.0) division_by_zero_error_1_nr(sc, sc->divide_symbol, 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_1_nr (sc, sc->divide_symbol, real_zero); - return (x1 / x2); +static s7_double divide_d_7dd(s7_scheme *sc, s7_double x1, s7_double x2) +{ + if (x2 == 0.0) division_by_zero_error_1_nr(sc, sc->divide_symbol, real_zero); + return(x1 / x2); } -static s7_pointer -divide_p_ii (s7_scheme* sc, s7_int x, s7_int y) { - return (make_ratio_with_div_check (sc, sc->divide_symbol, x, y)); -} -static s7_pointer -divide_p_i (s7_scheme* sc, s7_int x) { - return (make_ratio_with_div_check (sc, sc->divide_symbol, 1, x)); -} +static s7_pointer divide_p_ii(s7_scheme *sc, s7_int x, s7_int y) {return(make_ratio_with_div_check(sc, sc->divide_symbol, x, y));} +static s7_pointer divide_p_i(s7_scheme *sc, s7_int x) {return(make_ratio_with_div_check(sc, sc->divide_symbol, 1, x));} -static s7_pointer -divide_chooser (s7_scheme* sc, s7_pointer func, int32_t args, s7_pointer expr) { - if (args == 1) return (sc->invert_1); - if (args == 2) { - const s7_pointer arg1= cadr (expr), arg2= caddr (expr); - if ((is_t_real (arg1)) && (real (arg1) == 1.0)) return (sc->invert_x); - if ((is_pair (arg1)) && (has_fn (arg1))) { - if (fn_proc (arg1) == g_multiply_2) - set_fn_direct (arg1, g_multiply_2_wrapped); - else if (fn_proc (arg1) == g_multiply_3) - set_fn_direct (arg1, g_multiply_3_wrapped); +static s7_pointer divide_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + if (args == 1) return(sc->invert_1); + if (args == 2) + { + const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); + if ((is_t_real(arg1)) && (real(arg1) == 1.0)) return(sc->invert_x); + if ((is_pair(arg1)) && (has_fn(arg1))) + { + if (fn_proc(arg1) == g_multiply_2) set_fn_direct(arg1, g_multiply_2_wrapped); + else if (fn_proc(arg1) == g_multiply_3) set_fn_direct(arg1, g_multiply_3_wrapped); + } + if ((is_pair(arg2)) && (has_fn(arg2)) && (fn_proc(arg2) == g_multiply_2)) set_fn_direct(arg2, g_multiply_2_wrapped); + return(((is_t_integer(arg2)) && (integer(arg2) == 2)) ? sc->divide_by_2 : sc->divide_2); } - if ((is_pair (arg2)) && (has_fn (arg2)) && (fn_proc (arg2) == g_multiply_2)) - set_fn_direct (arg2, g_multiply_2_wrapped); - return (((is_t_integer (arg2)) && (integer (arg2) == 2)) ? sc->divide_by_2 - : sc->divide_2); - } - return (func); + return(func); } + /* -------------------------------- 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); +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_2_nr (sc, sc->quotient_symbol, wrap_integer (sc, x), - int_zero); - if (x == S7_INT64_MIN) /* (quotient most-negative-fixnum -1) */ - sole_arg_out_of_range_error_nr (sc, sc->quotient_symbol, - set_elist_2 (sc, leastfix, minus_one), - it_is_too_large_string); - return (-x); /* (quotient x -1) */ + division_by_zero_error_2_nr(sc, sc->quotient_symbol, wrap_integer(sc, x), int_zero); + if (x == S7_INT64_MIN) /* (quotient most-negative-fixnum -1) */ + sole_arg_out_of_range_error_nr(sc, sc->quotient_symbol, set_elist_2(sc, leastfix, minus_one), it_is_too_large_string); + return(-x); /* (quotient x -1) */ } -static s7_pointer -s7_truncate (s7_scheme* sc, s7_pointer caller, - s7_double xf) /* can't use "truncate" -- it's in unistd.h */ +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) - sole_arg_out_of_range_error_nr (sc, caller, wrap_real (sc, xf), - it_is_too_large_string); - return ( - make_integer (sc, (xf > 0.0) ? (s7_int) floor (xf) : (s7_int) ceil (xf))); + if (fabs(xf) > QUOTIENT_FLOAT_LIMIT) + sole_arg_out_of_range_error_nr(sc, caller, wrap_real(sc, xf), it_is_too_large_string); + return(make_integer(sc, (xf > 0.0) ? (s7_int)floor(xf) : (s7_int)ceil(xf))); } -static s7_int -c_quo_dbl (s7_scheme* sc, s7_double x, s7_double y) { +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_2_nr (sc, sc->quotient_symbol, wrap_real (sc, x), - real_zero); - if ((is_inf (y)) || (is_NaN (y))) /* here we can't return NAN so I guess we - should signal an error */ - wrong_type_error_nr (sc, sc->quotient_symbol, 2, wrap_real (sc, y), - a_normal_real_string); - xf= x / y; - if (fabs (xf) > QUOTIENT_FLOAT_LIMIT) - sole_arg_out_of_range_error_nr (sc, sc->quotient_symbol, wrap_real (sc, xf), - it_is_too_large_string); - return ((xf > 0.0) ? (s7_int) floor (xf) : (s7_int) ceil (xf)); -} - -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) { + division_by_zero_error_2_nr(sc, sc->quotient_symbol, wrap_real(sc, x), real_zero); + if ((is_inf(y)) || (is_NaN(y))) /* here we can't return NAN so I guess we should signal an error */ + wrong_type_error_nr(sc, sc->quotient_symbol, 2, wrap_real(sc, y), a_normal_real_string); + xf = x / y; + if (fabs(xf) > QUOTIENT_FLOAT_LIMIT) + sole_arg_out_of_range_error_nr(sc, sc->quotient_symbol, wrap_real(sc, xf), it_is_too_large_string); + return((xf > 0.0) ? (s7_int)floor(xf) : (s7_int)ceil(xf)); +} + +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) +{ 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)))); + 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)) { + switch (type(x)) + { 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) - division_by_zero_error_2_nr (sc, sc->quotient_symbol, x, y); - if (is_inf (real (y))) return (make_nan_with_payload (sc, __LINE__)); - if (is_NaN (real (y))) return (y); - 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, - sc->type_names[T_REAL], 2)); - } + 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) + division_by_zero_error_2_nr(sc, sc->quotient_symbol, x, y); + if (is_inf(real(y))) return(make_nan_with_payload(sc, __LINE__)); + if (is_NaN(real(y))) return(y); + 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, sc->type_names[T_REAL], 2)); + } - case T_RATIO: - switch (type (y)) { - case T_INTEGER: - if (integer (y) == 0) - division_by_zero_error_2_nr (sc, sc->quotient_symbol, 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) */ + switch (type(y)) + { + case T_INTEGER: + if (integer(y) == 0) + division_by_zero_error_2_nr(sc, sc->quotient_symbol, 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)); - } + { + 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))); + return(make_integer(sc, (n1 * d2) / (n2 * d1))); #endif + case T_REAL: + if (real(y) == 0.0) + division_by_zero_error_2_nr(sc, sc->quotient_symbol, x, y); + if (is_inf(real(y))) return(make_nan_with_payload(sc, __LINE__)); + if (is_NaN(real(y))) return(y); + 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, sc->type_names[T_REAL], 2)); + } case T_REAL: - if (real (y) == 0.0) - division_by_zero_error_2_nr (sc, sc->quotient_symbol, x, y); - if (is_inf (real (y))) return (make_nan_with_payload (sc, __LINE__)); - if (is_NaN (real (y))) return (y); - 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, - sc->type_names[T_REAL], 2)); - } - case T_REAL: - if (((is_inf (real (x))) || (is_NaN (real (x)))) && (is_real (y))) - return (make_nan_with_payload (sc, __LINE__)); - /* 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) - division_by_zero_error_2_nr (sc, sc->quotient_symbol, 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 */ + if (((is_inf(real(x))) || (is_NaN(real(x)))) && (is_real(y))) + return(make_nan_with_payload(sc, __LINE__)); + /* 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) + division_by_zero_error_2_nr(sc, sc->quotient_symbol, 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, sc->type_names[T_REAL], 2)); + } default: - return (method_or_bust_pp (sc, y, sc->quotient_symbol, x, y, - sc->type_names[T_REAL], 2)); + return(method_or_bust_pp(sc, x, sc->quotient_symbol, x, y, sc->type_names[T_REAL], 2)); } - default: - return (method_or_bust_pp (sc, x, sc->quotient_symbol, x, y, - sc->type_names[T_REAL], 2)); - } } -static s7_pointer -quotient_p_pi (s7_scheme* sc, s7_pointer x, s7_int y) { - if ((is_t_integer (x)) && ((y > 0) || (y < -1))) - return (make_integer (sc, integer (x) / y)); - return (quotient_p_pp (sc, x, wrap_integer (sc, y))); +static s7_pointer quotient_p_pi(s7_scheme *sc, s7_pointer x, s7_int y) +{ + if ((is_t_integer(x)) && ((y > 0) || (y < -1))) return(make_integer(sc, integer(x) / y)); + return(quotient_p_pp(sc, x, wrap_integer(sc, y))); } -s7_pointer -s7i_quotient_p_pp (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (quotient_p_pp (sc, x, y)); -} +s7_pointer s7i_quotient_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(quotient_p_pp(sc, x, y));} -#define H_quotient \ - "(quotient x1 x2) returns the integer quotient of x1 and x2; (quotient 4 " \ - "3) = 1" +#define H_quotient "(quotient x1 x2) returns the integer quotient of x1 and x2; (quotient 4 3) = 1" #define Q_quotient sc->pcl_r -/* -------------------------------- remainder -------------------------------- - */ + +/* -------------------------------- remainder -------------------------------- */ #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); /* avoid floating exception if (remainder - -9223372036854775808 -1)! */ +static inline s7_int remainder_i_7ii(s7_scheme *sc, s7_int x, s7_int y) +{ + if ((y > 1) || (y < -1)) return(x % y); /* avoid floating exception if (remainder -9223372036854775808 -1)! */ if (y == 0) - division_by_zero_error_2_nr (sc, sc->remainder_symbol, wrap_integer (sc, x), - int_zero); - return (0); + division_by_zero_error_2_nr(sc, sc->remainder_symbol, wrap_integer(sc, x), int_zero); + return(0); } -static s7_double -c_rem_dbl (s7_scheme* sc, s7_double x, s7_double y) { - s7_int quo; +static s7_double c_rem_dbl(s7_scheme *sc, s7_double x, s7_double y) +{ + s7_int quo; s7_double pre_quo; - if (is_NaN (y)) return (y); - if (is_inf (y)) return (NAN); - pre_quo= x / y; - if (fabs (pre_quo) > REMAINDER_FLOAT_LIMIT) - sole_arg_out_of_range_error_nr ( - sc, sc->remainder_symbol, - set_elist_2 (sc, wrap_real (sc, x), wrap_real (sc, y)), - it_is_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 x, s7_double y) { + if (is_NaN(y)) return(y); + if (is_inf(y)) return(NAN); + pre_quo = x / y; + if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT) + sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, wrap_real(sc, x), wrap_real(sc, y)), it_is_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 x, s7_double y) +{ if (y == 0.0) - division_by_zero_error_2_nr (sc, sc->remainder_symbol, wrap_real (sc, x), - real_zero); - if (is_NaN (x)) return (x); - if (is_inf (x)) return (NAN); /* match remainder_p_pp */ - return (c_rem_dbl (sc, x, y)); + division_by_zero_error_2_nr(sc, sc->remainder_symbol, wrap_real(sc, x), real_zero); + if (is_NaN(x)) return(x); + if (is_inf(x)) return(NAN); /* match remainder_p_pp */ + return(c_rem_dbl(sc, x, y)); } -static s7_pointer -remainder_p_pp (s7_scheme* sc, s7_pointer x, s7_pointer y) { - s7_int quo, d1, d2, n1, n2; +static s7_pointer remainder_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) +{ + 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)))); + 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) - division_by_zero_error_2_nr (sc, sc->remainder_symbol, x, y); - if (is_inf (real (y))) return (make_nan_with_payload (sc, __LINE__)); - if (is_NaN (real (y))) return (y); - pre_quo= (long_double) integer (x) / (long_double) real (y); - if (fabs (pre_quo) > REMAINDER_FLOAT_LIMIT) - sole_arg_out_of_range_error_nr (sc, sc->remainder_symbol, - set_elist_2 (sc, x, y), - it_is_too_large_string); - quo= (pre_quo > 0.0) ? (s7_int) floor (pre_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, - sc->type_names[T_REAL], 2)); - } - case T_RATIO: - switch (type (y)) { + switch (type(x)) + { case T_INTEGER: - n2= integer (y); - if (n2 == 0) division_by_zero_error_2_nr (sc, sc->remainder_symbol, x, y); - n1= numerator (x); - d1= denominator (x); - d2= 1; - goto RATIO_REM_RATIO; + 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) + division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y); + if (is_inf(real(y))) return(make_nan_with_payload(sc, __LINE__)); + if (is_NaN(real(y))) return(y); + pre_quo = (long_double)integer(x) / (long_double)real(y); + if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT) + sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), it_is_too_large_string); + quo = (pre_quo > 0.0) ? (s7_int)floor(pre_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, sc->type_names[T_REAL], 2)); + } 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 { + switch (type(y)) + { + case T_INTEGER: + n2 = integer(y); + if (n2 == 0) + division_by_zero_error_2_nr(sc, sc->remainder_symbol, 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) - sole_arg_out_of_range_error_nr (sc, sc->remainder_symbol, - set_elist_2 (sc, x, y), - it_is_too_large_string); - quo= (pre_quo > 0.0) ? (s7_int) floor (pre_quo) - : (s7_int) ceil (pre_quo); - } - else quo= n1d2 / n2d1; + 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) + sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), it_is_too_large_string); + quo = (pre_quo > 0.0) ? (s7_int)floor(pre_quo) : (s7_int)ceil(pre_quo); + } + else quo = n1d2 / n2d1; #else - quo= (n1 * d2) / (n2 * d1); + quo = (n1 * d2) / (n2 * d1); #endif - } - } - if (quo == 0) return (x); + }} + 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 ( - make_ratio_with_div_check (sc, sc->remainder_symbol, dn, d1)); - - if ((!multiply_overflow (n1, d2, &dn)) && - (!multiply_overflow (nq, d1, &nq)) && - (!subtract_overflow (dn, nq, &nq)) && - (!multiply_overflow (d1, d2, &d1))) - return ( - make_ratio_with_div_check (sc, sc->remainder_symbol, nq, d1)); - } - } + { + s7_int dn, nq; + if (!multiply_overflow(n2, quo, &nq)) + { + if ((d1 == d2) && + (!subtract_overflow(n1, nq, &dn))) + return(make_ratio_with_div_check(sc, sc->remainder_symbol, dn, d1)); + + if ((!multiply_overflow(n1, d2, &dn)) && + (!multiply_overflow(nq, d1, &nq)) && + (!subtract_overflow(dn, nq, &nq)) && + (!multiply_overflow(d1, d2, &d1))) + return(make_ratio_with_div_check(sc, sc->remainder_symbol, nq, d1)); + }} #else - if (d1 == d2) - return (make_ratio_with_div_check (sc, sc->remainder_symbol, - n1 - n2 * quo, d1)); + if (d1 == d2) + return(make_ratio_with_div_check(sc, sc->remainder_symbol, n1 - n2 * quo, d1)); - return (make_ratio_with_div_check (sc, sc->remainder_symbol, - n1 * d2 - n2 * d1 * quo, d1 * d2)); + return(make_ratio_with_div_check(sc, sc->remainder_symbol, n1 * d2 - n2 * d1 * quo, d1 * d2)); #endif - sole_arg_out_of_range_error_nr (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) - division_by_zero_error_2_nr (sc, sc->remainder_symbol, x, y); - if (is_inf (real (y))) return (make_nan_with_payload (sc, __LINE__)); - if (is_NaN (real (y))) return (y); - if (s7_int_abs (numerator (x)) > QUOTIENT_INT_LIMIT) - return (subtract_p_pp ( - sc, x, multiply_p_pp_wrapped (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) - sole_arg_out_of_range_error_nr (sc, sc->remainder_symbol, - set_elist_2 (sc, x, y), - it_is_too_large_string); - quo= (pre_quo > 0.0) ? (s7_int) floor (pre_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, - sc->type_names[T_REAL], 2)); - } - case T_REAL: - if (((is_inf (real (x))) || (is_NaN (real (x)))) && (is_real (y))) { - if (is_zero (y)) - division_by_zero_error_2_nr (sc, sc->remainder_symbol, x, y); - return (make_nan_with_payload (sc, __LINE__)); - } - switch (type (y)) { - case T_INTEGER: - if (integer (y) == 0) - division_by_zero_error_2_nr (sc, sc->remainder_symbol, 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) - sole_arg_out_of_range_error_nr (sc, sc->remainder_symbol, - set_elist_2 (sc, x, y), - it_is_too_large_string); - quo= (pre_quo > 0.0) ? (s7_int) floor (pre_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_wrapped (sc, y, quotient_p_pp (sc, x, y)))); - { - s7_double frac= (s7_double) fraction (y); - pre_quo = real (x) / frac; - if (fabs (pre_quo) > REMAINDER_FLOAT_LIMIT) - sole_arg_out_of_range_error_nr (sc, sc->remainder_symbol, - set_elist_2 (sc, x, y), - it_is_too_large_string); - quo= (pre_quo > 0.0) ? (s7_int) floor (pre_quo) - : (s7_int) ceil (pre_quo); - return (make_real (sc, real (x) - frac * quo)); - } + sole_arg_out_of_range_error_nr(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) + division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y); + if (is_inf(real(y))) return(make_nan_with_payload(sc, __LINE__)); + if (is_NaN(real(y))) return(y); + if (s7_int_abs(numerator(x)) > QUOTIENT_INT_LIMIT) + return(subtract_p_pp(sc, x, multiply_p_pp_wrapped(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) + sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), it_is_too_large_string); + quo = (pre_quo > 0.0) ? (s7_int)floor(pre_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, sc->type_names[T_REAL], 2)); + } case T_REAL: - if (real (y) == 0.0) - division_by_zero_error_2_nr (sc, sc->remainder_symbol, 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). - */ + if (((is_inf(real(x))) || (is_NaN(real(x)))) && (is_real(y))) + { + if (is_zero(y)) + division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y); + return(make_nan_with_payload(sc, __LINE__)); + } + switch (type(y)) + { + case T_INTEGER: + if (integer(y) == 0) + division_by_zero_error_2_nr(sc, sc->remainder_symbol, 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) + sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), it_is_too_large_string); + quo = (pre_quo > 0.0) ? (s7_int)floor(pre_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_wrapped(sc, y, quotient_p_pp(sc, x, y)))); + { + s7_double frac = (s7_double)fraction(y); + pre_quo = real(x) / frac; + if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT) + sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), it_is_too_large_string); + quo = (pre_quo > 0.0) ? (s7_int)floor(pre_quo) : (s7_int)ceil(pre_quo); + return(make_real(sc, real(x) - frac * quo)); + } + case T_REAL: + if (real(y) == 0.0) + division_by_zero_error_2_nr(sc, sc->remainder_symbol, 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, sc->type_names[T_REAL], 2)); + } default: - return (method_or_bust_pp (sc, y, sc->remainder_symbol, x, y, - sc->type_names[T_REAL], 2)); + return(method_or_bust_pp(sc, x, sc->remainder_symbol, x, y, sc->type_names[T_REAL], 1)); } - default: - return (method_or_bust_pp (sc, x, sc->remainder_symbol, x, y, - sc->type_names[T_REAL], 1)); - } } -static s7_pointer -remainder_p_pi (s7_scheme* sc, s7_pointer x, s7_int y) { - if ((is_t_integer (x)) && ((y > 1) || (y < -1))) - return (make_integer (sc, integer (x) % y)); - return (remainder_p_pp (sc, x, wrap_integer (sc, y))); +static s7_pointer remainder_p_pi(s7_scheme *sc, s7_pointer x, s7_int y) +{ + if ((is_t_integer(x)) && ((y > 1) || (y < -1))) return(make_integer(sc, integer(x) % y)); + return(remainder_p_pp(sc, x, wrap_integer(sc, y))); } -s7_pointer -s7i_remainder_p_pp (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (remainder_p_pp (sc, x, y)); -} +s7_pointer s7i_remainder_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(remainder_p_pp(sc, x, y));} -#define H_remainder \ - "(remainder x y) returns the remainder of x/y; (remainder 10 3) = 1" +#define H_remainder "(remainder x y) returns the remainder of x/y; (remainder 10 3) = 1" #define Q_remainder sc->pcl_r + /* -------------------------------- modulo -------------------------------- */ -static s7_int -modulo_i_ii (s7_int x, s7_int y) { +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); + 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 */ +static s7_int modulo_i_ii_unchecked(s7_int i1, s7_int i2) /* here we know i2 > 1 */ { - s7_int z= i1 % i2; - return ((z < 0) ? (z + i2) : z); + s7_int z = i1 % i2; + return((z < 0) ? (z + i2) : z); } -static s7_double -modulo_d_7dd (s7_scheme* sc, s7_double x, s7_double y) { +static s7_double modulo_d_7dd(s7_scheme *sc, s7_double x, s7_double y) +{ s7_double z; - if (is_NaN (x)) return (x); - if (is_NaN (y)) return (y); - if ((is_inf (x)) || (is_inf (y))) return (NAN); - if (y == 0.0) return (x); - if (fabs (x) > 1e17) - out_of_range_error_nr (sc, sc->modulo_symbol, int_one, wrap_real (sc, x), - it_is_too_large_string); - z= x / y; + if (is_NaN(x)) return(x); + if (is_NaN(y)) return(y); + if ((is_inf(x)) || (is_inf(y))) return(NAN); + if (y == 0.0) return(x); + if (fabs(x) > 1e17) + out_of_range_error_nr(sc, sc->modulo_symbol, int_one, wrap_real(sc, x), it_is_too_large_string); + z = x / y; if ((z > 1e19) || (z < -1e19)) - sole_arg_out_of_range_error_nr (sc, sc->modulo_symbol, - set_elist_3 (sc, sc->divide_symbol, - wrap_real (sc, x), - wrap_real (sc, y)), - intermediate_too_large_string); - return (x - y * (s7_int) floor (z)); + sole_arg_out_of_range_error_nr(sc, sc->modulo_symbol, + set_elist_3(sc, sc->divide_symbol, wrap_real(sc, x), wrap_real(sc, y)), + intermediate_too_large_string); + return(x - y * (s7_int)floor(z)); } -static s7_pointer -modulo_p_pp (s7_scheme* sc, s7_pointer x, s7_pointer y) { +static s7_pointer modulo_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) +{ s7_double a, b; - s7_int n1, n2, d1, d2; - if ((is_t_integer (x)) && - (is_t_integer (y))) /* this is nearly always the case */ - return (make_integer (sc, modulo_i_ii (integer (x), integer (y)))); - - 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)) - out_of_range_error_nr (sc, sc->modulo_symbol, int_one, x, - it_is_too_large_string); - b= real (y); - if (b == 0.0) return (x); - if (is_NaN (b)) return (y); - if (is_inf (b)) return (make_nan_with_payload (sc, __LINE__)); - a= (s7_double) integer (x); - goto REAL_MOD; - default: - return (method_or_bust_pp (sc, y, sc->modulo_symbol, x, y, - sc->type_names[T_REAL], 2)); - } - case T_RATIO: - switch (type (y)) { + s7_int n1, n2, d1, d2; + if ((is_t_integer(x)) && (is_t_integer(y))) /* this is nearly always the case */ + return(make_integer(sc, modulo_i_ii(integer(x), integer(y)))); + + switch (type(x)) + { 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) - sole_arg_out_of_range_error_nr ( - 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; + 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)) + out_of_range_error_nr(sc, sc->modulo_symbol, int_one, x, it_is_too_large_string); + b = real(y); + if (b == 0.0) return(x); + if (is_NaN(b)) return(y); + if (is_inf(b)) return(make_nan_with_payload(sc, __LINE__)); + a = (s7_double)integer(x); + goto REAL_MOD; + default: + return(method_or_bust_pp(sc, y, sc->modulo_symbol, x, y, sc->type_names[T_REAL], 2)); + } case T_RATIO: - parcel_out_fractions (x, y); - if (d1 == d2) - return (make_ratio_with_div_check (sc, sc->modulo_symbol, - modulo_i_ii (n1, n2), d1)); - if ((n1 == n2) && (d1 > d2)) return (x); - RATIO_MOD_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) + sole_arg_out_of_range_error_nr(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(make_ratio_with_div_check(sc, sc->modulo_symbol, 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 ( - make_ratio_with_div_check (sc, sc->modulo_symbol, fl, d1d2)); - } - } - } + { + 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(make_ratio_with_div_check(sc, sc->modulo_symbol, fl, d1d2)); + }}} #else - { - s7_int fl; - s7_int n1d2= n1 * d2; - s7_int n2d1= n2 * d1; - if ((n2d1 == 1) || (n2d1 == -1)) /* (modulo 100 -1/2) as above) */ - 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 (make_ratio_with_div_check (sc, sc->modulo_symbol, - n1d2 - (n2d1 * fl), d1 * d2)); - } + { + s7_int fl; + s7_int n1d2 = n1 * d2; + s7_int n2d1 = n2 * d1; + if ((n2d1 == 1) || (n2d1 == -1)) /* (modulo 100 -1/2) as above) */ + 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(make_ratio_with_div_check(sc, sc->modulo_symbol, n1d2 - (n2d1 * fl), d1 * d2)); + } #endif - sole_arg_out_of_range_error_nr (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 (make_nan_with_payload (sc, __LINE__)); - if (fabs (b) > 1e17) - out_of_range_error_nr (sc, sc->modulo_symbol, int_two, y, - it_is_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, - sc->type_names[T_REAL], 2)); - } - case T_REAL: - a= real (x); - if (!is_real (y)) - return (method_or_bust_pp (sc, y, sc->modulo_symbol, x, y, - sc->type_names[T_REAL], 2)); - if (is_NaN (a)) return (x); - if (is_inf (a)) return (make_nan_with_payload (sc, __LINE__)); /* not b */ - if (fabs (a) > 1e17) - out_of_range_error_nr (sc, sc->modulo_symbol, int_one, x, - it_is_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)) - out_of_range_error_nr (sc, sc->modulo_symbol, int_two, y, - it_is_too_large_string); - b= (s7_double) integer (y); - goto REAL_MOD; - case T_RATIO: - b= fraction (y); - goto REAL_MOD; + sole_arg_out_of_range_error_nr(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(make_nan_with_payload(sc, __LINE__)); + if (fabs(b) > 1e17) + out_of_range_error_nr(sc, sc->modulo_symbol, int_two, y, it_is_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, sc->type_names[T_REAL], 2)); + } case T_REAL: - b= real (y); - if (b == 0.0) return (x); - if (is_NaN (b)) return (y); - if (is_inf (b)) return (make_nan_with_payload (sc, __LINE__)); - REAL_MOD: { - s7_double c= a / b; - if (fabs (c) > 1e19) - sole_arg_out_of_range_error_nr ( - 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))); - } + a = real(x); + if (!is_real(y)) + return(method_or_bust_pp(sc, y, sc->modulo_symbol, x, y, sc->type_names[T_REAL], 2)); + if (is_NaN(a)) return(x); + if (is_inf(a)) return(make_nan_with_payload(sc, __LINE__)); /* not b */ + if (fabs(a) > 1e17) + out_of_range_error_nr(sc, sc->modulo_symbol, int_one, x, it_is_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)) + out_of_range_error_nr(sc, sc->modulo_symbol, int_two, y, it_is_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(make_nan_with_payload(sc, __LINE__)); + REAL_MOD: + { + s7_double c = a / b; + if (fabs(c) > 1e19) + sole_arg_out_of_range_error_nr(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, sc->type_names[T_REAL], 2)); + } default: - return (method_or_bust_pp (sc, y, sc->modulo_symbol, x, y, - sc->type_names[T_REAL], 2)); + return(method_or_bust_pp(sc, x, sc->modulo_symbol, x, y, sc->type_names[T_REAL], 1)); } - default: - return (method_or_bust_pp (sc, x, sc->modulo_symbol, x, y, - sc->type_names[T_REAL], 1)); - } } -static s7_pointer -modulo_p_pi (s7_scheme* sc, s7_pointer x, s7_int y) { - if (is_t_integer (x)) - return (make_integer (sc, modulo_i_ii (integer (x), y))); - return (modulo_p_pp (sc, x, wrap_integer (sc, y))); +static s7_pointer modulo_p_pi(s7_scheme *sc, s7_pointer x, s7_int y) +{ + if (is_t_integer(x)) return(make_integer(sc, modulo_i_ii(integer(x), y))); + return(modulo_p_pp(sc, x, wrap_integer(sc, y))); } -s7_pointer -s7i_modulo_p_pp (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (modulo_p_pp (sc, x, y)); -} +s7_pointer s7i_modulo_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(modulo_p_pp(sc, x, y));} -#define H_modulo \ - "(modulo x y) returns x mod y; (modulo 4 3) = 1. The arguments can be " \ - "real numbers." +#define H_modulo "(modulo x y) returns x mod y; (modulo 4 3) = 1. The arguments can be real numbers." #define Q_modulo sc->pcl_r -/* ---------------------------------------- max - * ---------------------------------------- */ -static bool -is_real_via_method_1 (s7_scheme* sc, s7_pointer p) { - s7_pointer func= find_method_with_let (sc, p, sc->is_real_symbol); + +/* ---------------------------------------- max ---------------------------------------- */ +static bool is_real_via_method_1(s7_scheme *sc, s7_pointer p) +{ + s7_pointer func = find_method_with_let(sc, p, sc->is_real_symbol); if (func != sc->undefined) - return (is_true (sc, s7_apply_function (sc, func, set_plist_1 (sc, p)))); - return (false); + return(is_true(sc, s7_apply_function(sc, func, 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 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, Sc->type_names[T_REAL], 1) -#define max_out_y(Sc, X, Y) \ - method_or_bust_pp (Sc, Y, Sc->max_symbol, X, Y, Sc->type_names[T_REAL], 2) +#define max_out_x(Sc, X, Y) method_or_bust_pp(Sc, X, Sc->max_symbol, X, Y, Sc->type_names[T_REAL], 1) +#define max_out_y(Sc, X, Y) method_or_bust_pp(Sc, Y, Sc->max_symbol, X, Y, Sc->type_names[T_REAL], 2) -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. +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); */ - return (((real (x) >= real (y)) || (is_NaN (real (x)))) ? x : y); - if (is_t_ratio (x)) return ((fraction (x) < fraction (y)) ? y : x); - } - switch (type (x)) { - case T_INTEGER: - switch (type (y)) { - case T_RATIO: - return ((integer (x) < fraction (y)) ? y : x); - case T_REAL: - return (((integer (x) < real (y)) || (is_NaN (real (y)))) ? y : x); - 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: - return (((fraction (x) < real (y)) || (is_NaN (real (y)))) ? y : x); - default: - return (max_out_y (sc, x, y)); - } - case T_REAL: - switch (type (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); */ + return(((real(x) >= real(y)) || (is_NaN(real(x)))) ? x : y); + if (is_t_ratio(x)) + return((fraction(x) < fraction(y)) ? y : x); + } + switch (type(x)) + { case T_INTEGER: - return (((real (x) >= integer (y)) || (is_NaN (real (x)))) ? x : y); + switch (type(y)) + { + case T_RATIO: + return((integer(x) < fraction(y)) ? y : x); + case T_REAL: + return(((integer(x) < real(y)) || (is_NaN(real(y)))) ? y : x); + default: + return(max_out_y(sc, x, y)); + } + break; case T_RATIO: - return ((real (x) < fraction (y)) ? y : x); + switch (type(y)) + { + case T_INTEGER: + return((fraction(x) < integer(y)) ? y : x); + case T_REAL: + return(((fraction(x) < real(y)) || (is_NaN(real(y)))) ? y : x); + default: + return(max_out_y(sc, x, y)); + } + case T_REAL: + switch (type(y)) + { + case T_INTEGER: + return(((real(x) >= integer(y)) || (is_NaN(real(x)))) ? x : y); + case T_RATIO: + return((real(x) < fraction(y)) ? y : x); + default: + return(max_out_y(sc, x, y)); + } + break; + default: - return (max_out_y (sc, x, y)); + return(max_out_x(sc, x, y)); } - break; - - default: - return (max_out_x (sc, x, y)); - } - return (x); + return(x); } -static s7_pointer -max_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer unused_expr) { - return ((args == 2) ? sc->max_2 : ((args == 3) ? sc->max_3 : func)); +static s7_pointer max_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr) +{ + return((args == 2) ? sc->max_2 : ((args == 3) ? sc->max_3 : func)); } -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) { - return (((x1 > x2) || (is_NaN (x1))) ? 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))); -} +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) {return(((x1 > x2) || (is_NaN(x1))) ? 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, Sc->type_names[T_REAL], 1) -#define min_out_y(Sc, X, Y) \ - method_or_bust_pp (Sc, Y, Sc->min_symbol, X, Y, Sc->type_names[T_REAL], 2) -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 (((real (x) <= real (y)) || (is_NaN (real (x)))) ? x : y); - if (is_t_ratio (x)) return ((fraction (x) > fraction (y)) ? y : x); - } - switch (type (x)) { - case T_INTEGER: - switch (type (y)) { - case T_RATIO: - return ((integer (x) > fraction (y)) ? y : x); - case T_REAL: - return (((integer (x) > real (y)) || (is_NaN (real (y)))) ? y : x); - 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: - return (((fraction (x) > real (y)) || (is_NaN (real (y)))) ? y : x); - default: - return (min_out_y (sc, x, y)); - } - case T_REAL: - switch (type (y)) { +/* ---------------------------------------- min ---------------------------------------- */ +#define min_out_x(Sc, X, Y) method_or_bust_pp(Sc, X, Sc->min_symbol, X, Y, Sc->type_names[T_REAL], 1) +#define min_out_y(Sc, X, Y) method_or_bust_pp(Sc, Y, Sc->min_symbol, X, Y, Sc->type_names[T_REAL], 2) + +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(((real(x) <= real(y)) || (is_NaN(real(x)))) ? x : y); + if (is_t_ratio(x)) + return((fraction(x) > fraction(y)) ? y : x); + } + switch (type(x)) + { case T_INTEGER: - return (((real (x) <= integer (y)) || (is_NaN (real (x)))) ? x : y); + switch (type(y)) + { + case T_RATIO: return((integer(x) > fraction(y)) ? y : x); + case T_REAL: + return(((integer(x) > real(y)) || (is_NaN(real(y)))) ? y : x); + default: + return(min_out_y(sc, x, y)); + } + break; case T_RATIO: - return ((real (x) > fraction (y)) ? y : x); + switch (type(y)) + { + case T_INTEGER: + return((fraction(x) > integer(y)) ? y : x); + case T_REAL: + return(((fraction(x) > real(y)) || (is_NaN(real(y)))) ? y : x); + default: + return(min_out_y(sc, x, y)); + } + case T_REAL: + switch (type(y)) + { + case T_INTEGER: + return(((real(x) <= integer(y)) || (is_NaN(real(x)))) ? x : y); + case T_RATIO: + return((real(x) > fraction(y)) ? y : x); + default: + return(min_out_y(sc, x, y)); + } + break; + default: - return (min_out_y (sc, x, y)); + return(min_out_x(sc, x, y)); } - break; - - default: - return (min_out_x (sc, x, y)); - } - return (x); + return(x); } -static s7_pointer -min_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer unused_expr) { - return ((args == 2) ? sc->min_2 : ((args == 3) ? sc->min_3 : func)); +static s7_pointer min_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr) +{ + return((args == 2) ? sc->min_2 : ((args == 3) ? sc->min_3 : func)); } -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) { - return (((x1 < x2) || (is_NaN (x1))) ? 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 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) {return(((x1 < x2) || (is_NaN(x1))) ? 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_error_nr (sc, sc->num_eq_symbol, 1, x, a_number_string); - return (false); +/* ---------------------------------------- = ---------------------------------------- */ +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_error_nr(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_error_nr (sc, sc->num_eq_symbol, 2, y, 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_error_nr(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) { - /* (= float int) here can be confusing if the float is the result of (say) (* - * 4478554083/3166815962 4478554083/3166815962) -- sometimes the extra low - * order bits are lost somewhere, so it looks like (= 2.0 2) returning #t. - * Maybe the caller should have used eqv? +static bool num_eq_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) +{ + /* (= float int) here can be confusing if the float is the result of (say) (* 4478554083/3166815962 4478554083/3166815962) -- sometimes + * the extra low order bits are lost somewhere, so it looks like (= 2.0 2) returning #t. Maybe the caller should have used eqv? */ - 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 (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))); + } - switch (type (x)) { - case T_INTEGER: - switch (type (y)) { + switch (type(x)) + { + case T_INTEGER: + switch (type(y)) + { + case T_RATIO: + return(false); + case T_REAL: + return(integer(x) == real(y)); + case T_COMPLEX: + return(false); + default: return(eq_out_y(sc, x, y)); + } + break; case T_RATIO: - return (false); + switch (type(y)) + { + case T_INTEGER: return(false); + case T_REAL: return(fraction(x) == real(y)); + case T_COMPLEX: return(false); + default: return(eq_out_y(sc, x, y)); + } + break; case T_REAL: - return (integer (x) == real (y)); + switch (type(y)) + { + case T_INTEGER: + return(real(x) == integer(y)); + case T_RATIO: + return(real(x) == fraction(y)); + case T_COMPLEX: + return(false); + default: return(eq_out_y(sc, x, y)); + } + break; case T_COMPLEX: - return (false); - default: - return (eq_out_y (sc, x, y)); + if (is_real(y)) return(false); + return(eq_out_y(sc, x, y)); + + default: return(eq_out_x(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); - 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); - default: - return (eq_out_y (sc, x, y)); - } - break; - case T_COMPLEX: - if (is_real (y)) return (false); - return (eq_out_y (sc, x, y)); + return(false); +} - default: - return (eq_out_x (sc, x, y)); - } - return (false); +bool s7i_num_eq_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(num_eq_b_7pp(sc, x, y));} + +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 func = find_method_with_let(sc, p, sc->is_number_symbol); + if (func != sc->undefined) + return(is_true(sc, s7_apply_function(sc, func, set_plist_1(sc, p)))); + } + return(false); } -bool -s7i_num_eq_b_7pp (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (num_eq_b_7pp (sc, x, y)); +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) + + const s7_pointer x = car(args); + s7_pointer nums = cdr(args); + if (is_null(cdr(nums))) + return(make_boolean(sc, num_eq_b_7pp(sc, x, car(nums)))); + + for (; is_pair(nums); nums = cdr(nums)) + if (!num_eq_b_7pp(sc, x, car(nums))) + { + for (nums = cdr(nums); is_pair(nums); nums = cdr(nums)) + if (!is_number_via_method(sc, car(nums))) + wrong_type_error_nr(sc, sc->num_eq_symbol, position_of(nums, args), car(nums), a_number_string); + return(sc->F); + } + return(sc->T); } -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 func= find_method_with_let (sc, p, sc->is_number_symbol); - if (func != sc->undefined) - return (is_true (sc, s7_apply_function (sc, func, 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) - - const s7_pointer x = car (args); - s7_pointer nums= cdr (args); - if (is_null (cdr (nums))) - return (make_boolean (sc, num_eq_b_7pp (sc, x, car (nums)))); - - for (; is_pair (nums); nums= cdr (nums)) - if (!num_eq_b_7pp (sc, x, car (nums))) { - for (nums= cdr (nums); is_pair (nums); nums= cdr (nums)) - if (!is_number_via_method (sc, car (nums))) - wrong_type_error_nr (sc, sc->num_eq_symbol, position_of (nums, args), - car (nums), 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 x, s7_int y) { - 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_number (x)) return (sc->F); /* complex/ratio can't == int */ - if (has_active_methods (sc, x)) - return (find_and_apply_method (sc, x, sc->num_eq_symbol, - set_plist_2 (sc, x, make_integer (sc, y)))); - wrong_type_error_nr (sc, sc->num_eq_symbol, 1, x, a_number_string); +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 x, s7_int y) +{ + 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_number(x)) + return(sc->F); /* complex/ratio can't == int */ + if (has_active_methods(sc, x)) + return(find_and_apply_method(sc, x, sc->num_eq_symbol, set_plist_2(sc, x, make_integer(sc, y)))); + wrong_type_error_nr(sc, sc->num_eq_symbol, 1, x, a_number_string); #ifdef __TINYC__ - return (sc->F); + return(sc->F); #endif } -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 (!is_number (x)) /* complex/ratio can't == int */ - wrong_type_error_nr (sc, sc->num_eq_symbol, 1, x, a_number_string); - return (false); +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 (!is_number(x)) /* complex/ratio can't == int */ + wrong_type_error_nr(sc, sc->num_eq_symbol, 1, x, a_number_string); + return(false); } -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 (make_boolean (sc, real (x) == integer (y))); - if (!is_number (x)) return (make_boolean (sc, eq_out_x (sc, x, y))); - return (sc->F); +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(make_boolean(sc, real(x) == integer(y))); + if (!is_number(x)) + return(make_boolean(sc, eq_out_x(sc, x, y))); + return(sc->F); } -s7_pointer -s7i_num_eq_xx (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (num_eq_xx (sc, x, y)); -} +s7_pointer s7i_num_eq_xx(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(num_eq_xx(sc, x, y));} -static s7_pointer -num_eq_chooser (s7_scheme* sc, s7_pointer func, int32_t args, s7_pointer expr) { +static s7_pointer num_eq_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ s7_pointer arg1, arg2; - if (args != 2) return (func); - arg1= cadr (expr); - arg2= caddr (expr); - if ((is_pair (arg1)) && (has_fn (arg1)) && (fn_proc (arg1) == g_add_3)) - set_fn_direct (arg1, g_add_3_wrapped); - if (is_t_integer (arg2)) return (sc->num_eq_xi); - return ((is_t_integer (arg1)) ? sc->num_eq_ix : sc->num_eq_2); -} - -/* ---------------------------------------- < - * ---------------------------------------- */ -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, list_2 (sc, x, y)) != - sc->F); /* not plist */ - wrong_type_error_nr (sc, sc->lt_symbol, 1, x, sc->type_names[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, list_2 (sc, x, y)) != - sc->F); - wrong_type_error_nr (sc, sc->lt_symbol, 2, y, sc->type_names[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)); - } - 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)); - 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)); - default: - return (lt_out_y (sc, x, y)); - } - case T_REAL: - switch (type (y)) { + if (args != 2) return(func); + arg1 = cadr(expr); + arg2 = caddr(expr); + if ((is_pair(arg1)) && (has_fn(arg1)) && (fn_proc(arg1) == g_add_3)) set_fn_direct(arg1, g_add_3_wrapped); + if (is_t_integer(arg2)) return(sc->num_eq_xi); + return((is_t_integer(arg1)) ? sc->num_eq_ix : sc->num_eq_2); +} + + +/* ---------------------------------------- < ---------------------------------------- */ +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, list_2(sc, x, y)) != sc->F); /* not plist */ + wrong_type_error_nr(sc, sc->lt_symbol, 1, x, sc->type_names[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, list_2(sc, x, y)) != sc->F); + wrong_type_error_nr(sc, sc->lt_symbol, 2, y, sc->type_names[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)); + } + switch (type(x)) + { case T_INTEGER: - return (real (x) < integer (y)); + switch (type(y)) + { + case T_RATIO: return(integer(x) < fraction(y)); /* ?? */ + case T_REAL: return(integer(x) < real(y)); + default: return(lt_out_y(sc, x, y)); + } + break; case T_RATIO: - return (real (x) < fraction (y)); - default: - return (lt_out_y (sc, x, y)); - } - break; + switch (type(y)) + { + case T_INTEGER: return(fraction(x) < integer(y)); + case T_REAL: return(fraction(x) < real(y)); + 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)); + default: return(lt_out_y(sc, x, y)); + } + break; - default: - return (lt_out_x (sc, x, y)); - } - return (true); + 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) +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)))); + 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))) - wrong_type_error_nr (sc, sc->lt_symbol, position_of (p, args), - car (p), sc->type_names[T_REAL]); - return (sc->F); + 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))) + wrong_type_error_nr(sc, sc->lt_symbol, position_of(p, args), car(p), sc->type_names[T_REAL]); + return(sc->F); + } + x = car(p); } - x= car (p); - } - return (sc->T); + 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 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) { - const 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))); - return ( - method_or_bust (sc, x, sc->lt_symbol, args, sc->type_names[T_REAL], 1)); +static s7_pointer g_less_x0(s7_scheme *sc, s7_pointer args) +{ + const 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))); + return(method_or_bust(sc, x, sc->lt_symbol, args, sc->type_names[T_REAL], 1)); } -static s7_pointer -g_less_xi (s7_scheme* sc, s7_pointer args) { - const s7_int y= integer (cadr (args)); - const s7_pointer x= car (args); +static s7_pointer g_less_xi(s7_scheme *sc, s7_pointer args) +{ + const s7_int y = integer(cadr(args)); + const 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))); - return ( - method_or_bust (sc, x, sc->lt_symbol, args, sc->type_names[T_REAL], 1)); + 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))); + return(method_or_bust(sc, x, sc->lt_symbol, args, sc->type_names[T_REAL], 1)); } -static s7_pointer -g_less_xf (s7_scheme* sc, s7_pointer args) { - const s7_double y= real (cadr (args)); /* chooser below checks is_t_real(y) */ - const s7_pointer x= car (args); +static s7_pointer g_less_xf(s7_scheme *sc, s7_pointer args) +{ + const s7_double y = real(cadr(args)); /* chooser below checks is_t_real(y) */ + const 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)); - return ( - method_or_bust (sc, x, sc->lt_symbol, args, sc->type_names[T_REAL], 1)); + 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)); + return(method_or_bust(sc, x, sc->lt_symbol, args, sc->type_names[T_REAL], 1)); } -static inline s7_pointer -lt_p_pp (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (make_boolean (sc, lt_b_7pp (sc, x, y))); -} +static inline s7_pointer lt_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(make_boolean(sc, lt_b_7pp(sc, x, y)));} -s7_pointer -s7i_lt_p_pp (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (lt_p_pp (sc, x, y)); -} +s7_pointer s7i_lt_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(lt_p_pp(sc, x, y));} -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_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 x, s7_int y) { - if (is_t_integer (x)) return (integer (x) < y); - if (is_t_real (x)) return (real (x) < y); - if (is_t_ratio (x)) return (ratio_lt_pi (x, y)); - return (lt_out_x (sc, x, make_integer (sc, y))); +static bool lt_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 (is_t_ratio(x)) return(ratio_lt_pi(x, y)); + return(lt_out_x(sc, x, make_integer(sc, y))); } -static s7_pointer -lt_p_pi (s7_scheme* sc, s7_pointer x, s7_int y) { - return (make_boolean (sc, lt_b_pi (sc, x, y))); -} +static s7_pointer lt_p_pi(s7_scheme *sc, s7_pointer x, s7_int y) {return(make_boolean(sc, lt_b_pi(sc, x, y)));} -static s7_pointer -less_chooser (s7_scheme* sc, s7_pointer func, int32_t args, s7_pointer expr) { +static s7_pointer less_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ s7_pointer arg2; - if (args != 2) return (func); - 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); -} - -/* ---------------------------------------- <= - * ---------------------------------------- */ -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, list_2 (sc, x, y)) != - sc->F); /* not plist */ - wrong_type_error_nr (sc, sc->leq_symbol, 1, x, sc->type_names[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, list_2 (sc, x, y)) != - sc->F); - wrong_type_error_nr (sc, sc->leq_symbol, 2, y, sc->type_names[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)); - } - 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)); - 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)); - 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)); - default: - return (leq_out_y (sc, x, y)); + if (args != 2) return(func); + 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); } - break; - - 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))) - wrong_type_error_nr (sc, sc->leq_symbol, position_of (p, args), - car (p), sc->type_names[T_REAL]); - return (sc->F); - } - return (sc->T); -} - -static inline s7_pointer -leq_p_pp (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (make_boolean (sc, leq_b_7pp (sc, x, y))); -} -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) { - const s7_int y= integer (cadr (args)); - const 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))); - return ( - method_or_bust (sc, x, sc->leq_symbol, args, sc->type_names[T_REAL], 1)); -} - -static bool -leq_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 (is_t_ratio (x)) return (ratio_leq_pi (x, y)); - if (has_active_methods (sc, x)) - return (find_and_apply_method ( - sc, x, sc->leq_symbol, - list_2 (sc, x, make_integer (sc, y)))); /* not plist */ - wrong_type_error_nr (sc, sc->leq_symbol, 1, x, sc->type_names[T_REAL]); -#ifdef __TINYC__ - return (false); -#endif + if (is_t_real(arg2)) + return(sc->less_xf); + return(sc->less_2); } -static s7_pointer -leq_p_pi (s7_scheme* sc, s7_pointer x, s7_int y) { - return (make_boolean (sc, leq_b_pi (sc, x, y))); + +/* ---------------------------------------- <= ---------------------------------------- */ +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, list_2(sc, x, y)) != sc->F); /* not plist */ + wrong_type_error_nr(sc, sc->leq_symbol, 1, x, sc->type_names[T_REAL]); + return(false); } -/* bridge for g_leq_2 migration */ -bool -s7i_leq_b_7pp (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (leq_b_7pp (sc, x, y)); -} - -static s7_pointer -g_leq_ixx (s7_scheme* sc, s7_pointer args) { - const s7_pointer nums= cdr (args); - if (is_t_integer (car (nums))) { - if (integer (car (args)) > integer (car (nums))) { - if (!is_real_via_method (sc, cadr (nums))) - wrong_type_error_nr (sc, sc->leq_symbol, 3, cadr (nums), - sc->type_names[T_REAL]); - return (sc->F); - } - if (is_t_integer (cadr (nums))) - return ((integer (car (nums)) > integer (cadr (nums))) ? sc->F : sc->T); - } - return (g_less_or_equal (sc, args)); +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, list_2(sc, x, y)) != sc->F); + wrong_type_error_nr(sc, sc->leq_symbol, 2, y, sc->type_names[T_REAL]); + return(false); } -static s7_pointer -leq_chooser (s7_scheme* sc, s7_pointer func, int32_t args, s7_pointer expr) { - if (args == 2) { - const 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 (func); -} - -/* ---------------------------------------- > - * ---------------------------------------- */ -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, list_2 (sc, x, y)) != - sc->F); /* not plist */ - wrong_type_error_nr (sc, sc->gt_symbol, 1, x, sc->type_names[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, list_2 (sc, x, y)) != - sc->F); - wrong_type_error_nr (sc, sc->gt_symbol, 2, y, sc->type_names[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)); - } - 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)); - 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)); - default: - return (gt_out_y (sc, x, y)); - } - case T_REAL: - switch (type (y)) { +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)); + } + switch (type(x)) + { case T_INTEGER: - return (real (x) > integer (y)); + switch (type(y)) + { + case T_RATIO: return(integer(x) <= fraction(y)); /* ?? */ + case T_REAL: return(integer(x) <= real(y)); + default: return(leq_out_y(sc, x, y)); + } + break; case T_RATIO: - return (real (x) > fraction (y)); - default: - return (gt_out_y (sc, x, y)); - } - break; + switch (type(y)) + { + case T_INTEGER: return(fraction(x) <= integer(y)); + case T_REAL: return(fraction(x) <= real(y)); + 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)); + default: return(leq_out_y(sc, x, y)); + } + break; - default: - return (gt_out_x (sc, x, y)); - } - return (true); + default: return(leq_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) +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); - 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))) + wrong_type_error_nr(sc, sc->leq_symbol, position_of(p, args), car(p), sc->type_names[T_REAL]); + return(sc->F); + } + return(sc->T); +} - if (is_null (cdr (p))) return (make_boolean (sc, gt_b_7pp (sc, x, car (p)))); +static inline s7_pointer leq_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(make_boolean(sc, leq_b_7pp(sc, x, y)));} +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));} - 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))) - wrong_type_error_nr (sc, sc->gt_symbol, position_of (p, args), - car (p), sc->type_names[T_REAL]); - return (sc->F); - } - return (sc->T); +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_greater_xi (s7_scheme* sc, s7_pointer args) { - const s7_int y= integer (cadr (args)); - const s7_pointer x= car (args); +static s7_pointer g_leq_xi(s7_scheme *sc, s7_pointer args) +{ + const s7_int y = integer(cadr(args)); + const 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))); - return (method_or_bust (sc, x, sc->gt_symbol, args, a_number_string, 1)); + 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))); + return(method_or_bust(sc, x, sc->leq_symbol, args, sc->type_names[T_REAL], 1)); } -static s7_pointer -g_greater_xf (s7_scheme* sc, s7_pointer args) { - const s7_double y= real (cadr (args)); - const s7_pointer x= car (args); +static bool leq_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 (is_t_ratio(x)) return(ratio_leq_pi(x, y)); + if (has_active_methods(sc, x)) + return(find_and_apply_method(sc, x, sc->leq_symbol, list_2(sc, x, make_integer(sc, y)))); /* not plist */ + wrong_type_error_nr(sc, sc->leq_symbol, 1, x, sc->type_names[T_REAL]); +#ifdef __TINYC__ + return(false); +#endif +} - if (is_t_real (x)) return (make_boolean (sc, real (x) > y)); +static s7_pointer leq_p_pi(s7_scheme *sc, s7_pointer x, s7_int y) {return(make_boolean(sc, leq_b_pi(sc, 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)); +/* bridge for g_leq_2 migration */ +bool s7i_leq_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(leq_b_7pp(sc, x, y));} - default: - return (method_or_bust (sc, x, sc->gt_symbol, args, a_number_string, 1)); - } - return (sc->T); +static s7_pointer g_leq_ixx(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer nums = cdr(args); + if (is_t_integer(car(nums))) + { + if (integer(car(args)) > integer(car(nums))) + { + if (!is_real_via_method(sc, cadr(nums))) + wrong_type_error_nr(sc, sc->leq_symbol, 3, cadr(nums), sc->type_names[T_REAL]); + return(sc->F); + } + if (is_t_integer(cadr(nums))) + return((integer(car(nums)) > integer(cadr(nums))) ? sc->F : sc->T); + } + return(g_less_or_equal(sc, args)); } -static inline s7_pointer -gt_p_pp (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (make_boolean (sc, gt_b_7pp (sc, x, y))); -} -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 s7_pointer leq_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + if (args == 2) + { + const 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(func); } -static bool -gt_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 (is_t_ratio (x)) return (!ratio_leq_pi (x, y)); - return (gt_out_x (sc, x, make_integer (sc, y))); + +/* ---------------------------------------- > ---------------------------------------- */ +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, list_2(sc, x, y)) != sc->F); /* not plist */ + wrong_type_error_nr(sc, sc->gt_symbol, 1, x, sc->type_names[T_REAL]); + return(false); } -static s7_pointer -gt_p_pi (s7_scheme* sc, s7_pointer x, s7_int y) { - return (make_boolean (sc, gt_b_pi (sc, x, y))); +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, list_2(sc, x, y)) != sc->F); + wrong_type_error_nr(sc, sc->gt_symbol, 2, y, sc->type_names[T_REAL]); + return(false); } -static s7_pointer -g_greater_2 (s7_scheme* sc, s7_pointer args) { - /* ridiculous repetition, but overheads are killing this poor thing */ - const 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))); - 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)) { +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)); + } + switch (type(x)) + { case T_INTEGER: - return (make_boolean (sc, real (x) > integer (y))); + switch (type(y)) + { + case T_RATIO: return(integer(x) > fraction(y)); /* ?? */ + case T_REAL: return(integer(x) > real(y)); + default: return(gt_out_y(sc, x, y)); + } + break; case T_RATIO: - return (make_boolean (sc, real (x) > fraction (y))); - default: - return (make_boolean (sc, gt_out_y (sc, x, y))); + switch (type(y)) + { + case T_INTEGER: return(fraction(x) > integer(y)); + case T_REAL: return(fraction(x) > real(y)); + 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)); + default: return(gt_out_y(sc, x, y)); + } + break; + + default: return(gt_out_x(sc, x, y)); } - break; + return(true); +} - default: - return (make_boolean (sc, gt_out_x (sc, x, y))); - } - return (sc->T); +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))) + wrong_type_error_nr(sc, sc->gt_symbol, position_of(p, args), car(p), sc->type_names[T_REAL]); + return(sc->F); + } + return(sc->T); } -static s7_pointer -greater_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer expr) { - s7_pointer arg2; - if (args != 2) return (func); - 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); -} - -/* ---------------------------------------- >= - * ---------------------------------------- */ -static bool -geq_out_x (s7_scheme* sc, s7_pointer x, s7_pointer y) { - if (!has_active_methods (sc, x)) - wrong_type_error_nr (sc, sc->geq_symbol, 1, x, sc->type_names[T_REAL]); - return (find_and_apply_method (sc, x, sc->geq_symbol, list_2 (sc, x, y)) != - sc->F); /* not plist */ -} - -static bool -geq_out_y (s7_scheme* sc, s7_pointer x, s7_pointer y) { - if (!has_active_methods (sc, y)) - wrong_type_error_nr (sc, sc->geq_symbol, 2, y, sc->type_names[T_REAL]); - return (find_and_apply_method (sc, y, sc->geq_symbol, list_2 (sc, x, y)) != - sc->F); /* not plist */ -} - -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)); - } - 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)); - 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)); - default: - return (geq_out_y (sc, x, y)); - } - case T_REAL: - switch (type (y)) { +static s7_pointer g_greater_xi(s7_scheme *sc, s7_pointer args) +{ + const s7_int y = integer(cadr(args)); + const 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))); + return(method_or_bust(sc, x, sc->gt_symbol, args, a_number_string, 1)); +} + +static s7_pointer g_greater_xf(s7_scheme *sc, s7_pointer args) +{ + const s7_double y = real(cadr(args)); + const s7_pointer x = car(args); + + if (is_t_real(x)) + return(make_boolean(sc, real(x) > y)); + + switch (type(x)) + { case T_INTEGER: - return (real (x) >= integer (y)); + return(make_boolean(sc, integer(x) > y)); case T_RATIO: - return (real (x) >= fraction (y)); + /* (> 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)); + default: - return (geq_out_y (sc, x, y)); + return(method_or_bust(sc, x, sc->gt_symbol, args, a_number_string, 1)); } - break; + return(sc->T); +} - default: - return (geq_out_x (sc, x, y)); - } - return (true); +static inline s7_pointer gt_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(make_boolean(sc, gt_b_7pp(sc, x, y)));} +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 x, s7_int y) +{ + if (is_t_integer(x)) return(integer(x) > y); + if (is_t_real(x)) return(real(x) > y); + if (is_t_ratio(x)) return(!ratio_leq_pi(x, y)); + return(gt_out_x(sc, x, make_integer(sc, y))); } -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) +static s7_pointer gt_p_pi(s7_scheme *sc, s7_pointer x, s7_int y) {return(make_boolean(sc, gt_b_pi(sc, x, y)));} - s7_pointer x= car (args), p= cdr (args); - if (is_null (cdr (p))) return (make_boolean (sc, geq_b_7pp (sc, x, car (p)))); +static s7_pointer g_greater_2(s7_scheme *sc, s7_pointer args) +{ + /* ridiculous repetition, but overheads are killing this poor thing */ + const 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))); + 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))); + default: return(make_boolean(sc, gt_out_y(sc, x, y))); + } + break; - 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))) - wrong_type_error_nr (sc, sc->geq_symbol, position_of (p, args), - car (p), sc->type_names[T_REAL]); - return (sc->F); + default: return(make_boolean(sc, gt_out_x(sc, x, y))); } - return (sc->T); + return(sc->T); } -static inline s7_pointer -geq_p_pp (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (make_boolean (sc, geq_b_7pp (sc, x, y))); +static s7_pointer greater_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + s7_pointer arg2; + if (args != 2) return(func); + 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); } -static bool -geq_b_ii (s7_int i1, s7_int i2) { - return (i1 >= i2); + + +/* ---------------------------------------- >= ---------------------------------------- */ +static bool geq_out_x(s7_scheme *sc, s7_pointer x, s7_pointer y) +{ + if (!has_active_methods(sc, x)) + wrong_type_error_nr(sc, sc->geq_symbol, 1, x, sc->type_names[T_REAL]); + return(find_and_apply_method(sc, x, sc->geq_symbol, list_2(sc, x, y)) != sc->F); /* not plist */ } -static bool -geq_b_dd (s7_double i1, s7_double i2) { - return (i1 >= i2); + +static bool geq_out_y(s7_scheme *sc, s7_pointer x, s7_pointer y) +{ + if (!has_active_methods(sc, y)) + wrong_type_error_nr(sc, sc->geq_symbol, 2, y, sc->type_names[T_REAL]); + return(find_and_apply_method(sc, y, sc->geq_symbol, list_2(sc, x, y)) != sc->F); /* not plist */ } -static s7_pointer -geq_p_dd (s7_scheme* sc, s7_double x1, s7_double x2) { - return (make_boolean (sc, x1 >= x2)); + +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)); + } + 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)); + 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)); + 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)); + default: return(geq_out_y(sc, x, y)); + } + break; + + default: return(geq_out_x(sc, x, y)); + } + return(true); } -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_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))) + wrong_type_error_nr(sc, sc->geq_symbol, position_of(p, args), car(p), sc->type_names[T_REAL]); + return(sc->F); + } + return(sc->T); } +static inline s7_pointer geq_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(make_boolean(sc, geq_b_7pp(sc, x, y)));} +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));} + /* bridge for g_geq_2 migration */ -bool -s7i_geq_b_7pp (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (geq_b_7pp (sc, x, y)); -} +bool s7i_geq_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(geq_b_7pp(sc, x, y));} -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_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) { - const s7_int y= integer (cadr (args)); - const s7_pointer x= car (args); +static s7_pointer g_geq_xi(s7_scheme *sc, s7_pointer args) +{ + const s7_int y = integer(cadr(args)); + const 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))); - return ( - method_or_bust (sc, x, sc->geq_symbol, args, sc->type_names[T_REAL], 1)); + 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))); + return(method_or_bust(sc, x, sc->geq_symbol, args, sc->type_names[T_REAL], 1)); } -static bool -geq_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 (is_t_ratio (x)) return (!ratio_lt_pi (x, y)); - if (!has_active_methods (sc, x)) - wrong_type_error_nr (sc, sc->geq_symbol, 1, x, sc->type_names[T_REAL]); - return (find_and_apply_method ( - sc, x, sc->geq_symbol, - list_2 (sc, x, make_integer (sc, y)))); /* not plist */ +static bool geq_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 (is_t_ratio(x)) return(!ratio_lt_pi(x, y)); + if (!has_active_methods(sc, x)) + wrong_type_error_nr(sc, sc->geq_symbol, 1, x, sc->type_names[T_REAL]); + return(find_and_apply_method(sc, x, sc->geq_symbol, list_2(sc, x, make_integer(sc, y)))); /* not plist */ } -static s7_pointer -geq_p_pi (s7_scheme* sc, s7_pointer x, s7_int y) { - return (make_boolean (sc, geq_b_pi (sc, x, y))); -} +static s7_pointer geq_p_pi(s7_scheme *sc, s7_pointer x, s7_int y) {return(make_boolean(sc, geq_b_pi(sc, x, y)));} -static s7_pointer -geq_chooser (s7_scheme* sc, s7_pointer func, int32_t args, s7_pointer expr) { +static s7_pointer geq_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ s7_pointer arg2; - if (args != 2) return (func); - 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); -} - -/* ---------------------------------------- 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 ((s7_double) fraction (x)); - case T_REAL: - return (real (x)); - case T_COMPLEX: - return (real_part (x)); - } - return (0.0); + if (args != 2) return(func); + 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); +} + + +/* ---------------------------------------- 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((s7_double)fraction(x)); + case T_REAL: return(real(x)); + case T_COMPLEX: return(real_part(x)); + } + return(0.0); } -/* ---------------------------------------- imag-part - * ---------------------------------------- */ -s7_double -s7_imag_part (s7_pointer x) { - if (is_t_complex (x)) return (imag_part (x)); - return (0.0); +/* ---------------------------------------- imag-part ---------------------------------------- */ +s7_double s7_imag_part(s7_pointer x) +{ + if (is_t_complex(x)) + return(imag_part(x)); + return(0.0); } -/* ---------------------------------------- numerator denominator - * ---------------------------------------- */ -static s7_int -numerator_i_7p (s7_scheme* sc, s7_pointer x) { - if (is_t_ratio (x)) return (numerator (x)); - if (is_t_integer (x)) return (integer (x)); - return (integer ( - method_or_bust_p (sc, x, sc->numerator_symbol, a_rational_string))); +/* ---------------------------------------- numerator denominator ---------------------------------------- */ +static s7_int numerator_i_7p(s7_scheme *sc, s7_pointer x) +{ + if (is_t_ratio(x)) return(numerator(x)); + if (is_t_integer(x)) return(integer(x)); + return(integer(method_or_bust_p(sc, x, sc->numerator_symbol, a_rational_string))); } /* g_numerator is now defined in s7_scheme_predicate.c */ -#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) + #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) + /* g_denominator is now defined in s7_scheme_predicate.c */ -#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) + #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) -static s7_int -denominator_i_7p (s7_scheme* sc, s7_pointer x) { - if (is_t_ratio (x)) return (denominator (x)); - if (is_t_integer (x)) return (1); - return (integer ( - method_or_bust_p (sc, x, sc->denominator_symbol, a_rational_string))); +static s7_int denominator_i_7p(s7_scheme *sc, s7_pointer x) +{ + if (is_t_ratio(x)) return(denominator(x)); + if (is_t_integer(x)) return(1); + return(integer(method_or_bust_p(sc, x, sc->denominator_symbol, a_rational_string))); } -/* ---------------------------------------- number? bignum? complex? integer? - * byte? rational? real? ---------------------------------------- */ + +/* ---------------------------------------- number? bignum? complex? integer? byte? rational? real? ---------------------------------------- */ /* g_is_number is now defined in s7_scheme_predicate.c */ #define H_is_number "(number? obj) returns #t if obj is a number" #define Q_is_number sc->pl_bt @@ -21543,15 +15935,10 @@ denominator_i_7p (s7_scheme* sc, s7_pointer x) { #define H_is_integer "(integer? obj) returns #t if obj is an integer" #define Q_is_integer sc->pl_bt -static bool -is_byte (s7_pointer x) { - return ((s7_is_integer (x)) && (s7_integer (x) >= 0) && - (s7_integer (x) < 256)); -} +static bool is_byte(s7_pointer x) {return((s7_is_integer(x)) && (s7_integer(x) >= 0) && (s7_integer(x) < 256));} /* g_is_byte is now defined in s7_scheme_predicate.c */ -#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 + #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 /* g_is_real is now defined in s7_scheme_predicate.c */ #define H_is_real "(real? obj) returns #t if obj is a real number" @@ -21562,4401 +15949,2927 @@ is_byte (s7_pointer x) { #define Q_is_complex sc->pl_bt /* g_is_rational is now defined in s7_scheme_predicate.c */ -#define H_is_rational \ - "(rational? obj) returns #t if obj is a rational number (either an integer " \ - "or a ratio)" +#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 /* g_is_float is now defined in s7_scheme_predicate.c */ -#define H_is_float "(float? x) returns #t is x is real and not rational." -#define Q_is_float sc->pl_bt + #define H_is_float "(float? x) returns #t is x is real and not rational." + #define Q_is_float sc->pl_bt -static bool -is_float_b (s7_pointer x) { - return (is_t_real (x)); -} +static bool is_float_b(s7_pointer x) {return(is_t_real(x));} -/* ---------------------------------------- nan? - * ---------------------------------------- */ -static bool -is_nan_b_7p (s7_scheme* sc, s7_pointer x) { - return s7_is_nan (sc, x); + +/* ---------------------------------------- nan? ---------------------------------------- */ +static bool is_nan_b_7p(s7_scheme *sc, s7_pointer x) +{ + return s7_is_nan(sc, x); } -/* ---------------------------------------- zero? - * ---------------------------------------- */ -static bool -is_zero (s7_pointer x) { - if (s7_is_integer (x)) return s7_integer (x) == 0; - if (s7_is_real (x)) return s7_real (x) == 0.0; - return false; /* ratios and complex numbers here are already collapsed into - integers and reals */ +/* ---------------------------------------- zero? ---------------------------------------- */ + +static bool is_zero(s7_pointer x) +{ + if (s7_is_integer(x)) + return s7_integer(x) == 0; + if (s7_is_real(x)) + return s7_real(x) == 0.0; + return false; /* ratios and complex numbers here are already collapsed into integers and reals */ } -static bool -is_positive (s7_scheme* sc, s7_pointer x) { - if (s7_is_integer (x)) return s7_integer (x) > 0; - if (s7_is_rational (x) && !s7_is_integer (x)) return s7_numerator (x) > 0; - if (s7_is_real (x)) return s7_real (x) > 0.0; - s7_wrong_type_arg_error (sc, "positive?", 1, x, "a real number"); +static bool is_positive(s7_scheme *sc, s7_pointer x) +{ + if (s7_is_integer(x)) + return s7_integer(x) > 0; + if (s7_is_rational(x) && !s7_is_integer(x)) + return s7_numerator(x) > 0; + if (s7_is_real(x)) + return s7_real(x) > 0.0; + s7_wrong_type_arg_error(sc, "positive?", 1, x, "a real number"); return false; } -static bool -is_negative (s7_scheme* sc, s7_pointer x) { - if (s7_is_integer (x)) return s7_integer (x) < 0; - if (s7_is_rational (x) && !s7_is_integer (x)) return s7_numerator (x) < 0; - if (s7_is_real (x)) return s7_real (x) < 0.0; - s7_wrong_type_arg_error (sc, "negative?", 1, x, "a real number"); +static bool is_negative(s7_scheme *sc, s7_pointer x) +{ + if (s7_is_integer(x)) + return s7_integer(x) < 0; + if (s7_is_rational(x) && !s7_is_integer(x)) + return s7_numerator(x) < 0; + if (s7_is_real(x)) + return s7_real(x) < 0.0; + s7_wrong_type_arg_error(sc, "negative?", 1, x, "a real number"); return false; } #if !WITH_PURE_S7 -/* ---------------------------------------- exact<->inexact exact? inexact? - * ---------------------------------------- */ - -/* ---------------------------------------- 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 +/* ---------------------------------------- exact<->inexact exact? inexact? ---------------------------------------- */ - const s7_pointer num= car (args); - if (is_t_integer (num)) { - s7_int x= integer (num); - return ((x < 0) ? small_int (integer_length (-(x + 1))) - : small_int (integer_length (x))); - } - return (sole_arg_method_or_bust (sc, num, sc->integer_length_symbol, args, - sc->type_names[T_INTEGER])); + +/* ---------------------------------------- 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_int -integer_length_i_i (s7_int x) { - return ((x < 0) ? integer_length (-(x + 1)) : integer_length (x)); +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 + + const s7_pointer num = car(args); + if (is_t_integer(num)) + { + s7_int x = integer(num); + return((x < 0) ? small_int(integer_length(-(x + 1))) : small_int(integer_length(x))); + } + return(sole_arg_method_or_bust(sc, num, sc->integer_length_symbol, args, sc->type_names[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 \ + +/* ---------------------------------------- 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) - - decode_float_t num; - const 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_unchecked ( - 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)); - } - return (method_or_bust_p (sc, x, sc->integer_decode_float_symbol, - wrap_string (sc, "a non-rational real", 19))); -} - -/* -------------------------------- 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 + #define Q_integer_decode_float s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_float_symbol) + + decode_float_t num; + const 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_unchecked(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)); + } + return(method_or_bust_p(sc, x, sc->integer_decode_float_symbol, wrap_string(sc, "a non-rational real", 19))); +} + + +/* -------------------------------- 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 */ -static s7_pointer -random_state_copy (s7_scheme* sc, s7_pointer args) { - 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); +static s7_pointer random_state_copy(s7_scheme *sc, s7_pointer args) +{ + 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); } #ifndef MWC_32 -#define MWC_32 1 + #define MWC_32 1 #endif -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'. \ +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) + #define Q_random_state s7_make_circular_signature(sc, 1, 2, sc->is_random_state_symbol, sc->is_integer_symbol) s7_pointer r1, r2, rs; - s7_int i1, i2; /* actually want s7_uint here -- we lose the sign bit? */ - if (is_null (args)) return (sc->default_random_state); - - r1= car (args); - if (!s7_is_integer (r1)) - return (method_or_bust (sc, r1, sc->random_state_symbol, args, - sc->type_names[T_INTEGER], 1)); - i1= integer (r1); + s7_int i1, i2; /* actually want s7_uint here -- we lose the sign bit? */ + if (is_null(args)) + return(sc->default_random_state); + + r1 = car(args); + if (!s7_is_integer(r1)) + return(method_or_bust(sc, r1, sc->random_state_symbol, args, sc->type_names[T_INTEGER], 1)); + i1 = integer(r1); #if MWC_32 if (i1 < 0) - out_of_range_error_nr (sc, sc->random_state_symbol, int_one, r1, - it_is_negative_string); + out_of_range_error_nr(sc, sc->random_state_symbol, int_one, r1, it_is_negative_string); #endif - if (is_null (cdr (args))) { - new_cell (sc, rs, T_RANDOM_STATE); - random_seed (rs) = (s7_uint) i1; - random_carry (rs)= 1675393560; /* should this be dependent on the seed? */ - return (rs); - } + if (is_null(cdr(args))) + { + new_cell(sc, rs, T_RANDOM_STATE); + random_seed(rs) = (s7_uint)i1; + random_carry(rs) = 1675393560; /* should this be dependent on the seed? */ + return(rs); + } - r2= cadr (args); - if (!s7_is_integer (r2)) - return (method_or_bust (sc, r2, sc->random_state_symbol, args, - sc->type_names[T_INTEGER], 2)); - i2= integer (r2); + r2 = cadr(args); + if (!s7_is_integer(r2)) + return(method_or_bust(sc, r2, sc->random_state_symbol, args, sc->type_names[T_INTEGER], 2)); + i2 = integer(r2); #if MWC_32 if (i2 < 0) - out_of_range_error_nr (sc, sc->random_state_symbol, int_two, r2, - it_is_negative_string); + out_of_range_error_nr(sc, sc->random_state_symbol, int_two, r2, it_is_negative_string); #endif - new_cell (sc, rs, T_RANDOM_STATE); - random_seed (rs) = (s7_uint) i1; - random_carry (rs)= (s7_uint) i2; - return (rs); + new_cell(sc, rs, T_RANDOM_STATE); + random_seed(rs) = (s7_uint)i1; + random_carry(rs) = (s7_uint)i2; + return(rs); } #define g_random_state s7_random_state -static s7_pointer -random_state_getter (s7_scheme* sc, s7_pointer r, s7_int loc) { - if (loc == 0) return (make_integer (sc, random_seed (r))); - if (loc == 1) return (make_integer (sc, random_carry (r))); - return (sc->F); +static s7_pointer random_state_getter(s7_scheme *sc, s7_pointer r, s7_int loc) +{ + if (loc == 0) return(make_integer(sc, random_seed(r))); + if (loc == 1) return(make_integer(sc, random_carry(r))); + return(sc->F); } -static s7_pointer -random_state_setter (s7_scheme* sc, s7_pointer r, s7_int loc, s7_pointer val) { - if (is_t_integer (val)) { - s7_int i= s7_integer_clamped_if_gmp (sc, val); - if (loc == 0) random_seed (r)= i; - if (loc == 1) random_carry (r)= i; - } - return (sc->F); +static s7_pointer random_state_setter(s7_scheme *sc, s7_pointer r, s7_int loc, s7_pointer val) +{ + if (is_t_integer(val)) + { + s7_int i = s7_integer_clamped_if_gmp(sc, val); + if (loc == 0) random_seed(r) = i; + if (loc == 1) random_carry(r) = i; + } + return(sc->F); } -/* -------------------------------- random-state? - * -------------------------------- */ + +/* -------------------------------- random-state? -------------------------------- */ /* g_is_random_state is now defined in s7_scheme_predicate.c */ -#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 - -bool -s7_is_random_state (s7_pointer r) { - return (type (r) == 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.\ + #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 + +bool s7_is_random_state(s7_pointer r) {return(type(r) == 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) + #define Q_random_state_to_list s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_random_state_symbol) - s7_pointer r= (is_null (args)) ? sc->default_random_state : car (args); - if (!is_random_state (r)) - return (method_or_bust (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_unchecked (sc, random_carry (r)))); + s7_pointer r = (is_null(args)) ? sc->default_random_state : car(args); + if (!is_random_state(r)) + return(method_or_bust(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_unchecked(sc, random_carry(r)))); } #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) { +void s7_set_default_random_state(s7_scheme *sc, s7_int seed, s7_int carry) +{ s7_pointer rs; - new_cell (sc, rs, T_RANDOM_STATE); - random_seed (rs) = (s7_uint) seed; - random_carry (rs) = (s7_uint) carry; - sc->default_random_state= rs; + new_cell(sc, rs, T_RANDOM_STATE); + random_seed(rs) = (s7_uint)seed; + random_carry(rs) = (s7_uint)carry; + sc->default_random_state = rs; } + /* -------------------------------- random -------------------------------- */ -static double -next_random (s7_pointer r) { +static double next_random(s7_pointer r) +{ #if MWC_32 -/* 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) - * - * see s7_random_state for 64 bit version of this, L26622 - * here's a check that things are not totally broken: - (define (check-random-integers lo hi) - (let* ((range (- hi lo)) - (num-bins 32) - (bins (make-int-vector num-bins 0))) - (do ((i 0 (+ i 1)) - (x (random range) (random range))) - ((= i 10000) bins) - (let ((bin (floor (* (/ x range) num-bins)))) - (set! (bins bin) (+ (bins bin) 1)))))) - (display (check-random-integers 0 9223372036854775807)) (newline) - - (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)))) - (display (list mn mx)) (newline)) - */ -#define RAN_MULT 2131995753UL - double result; - s7_uint 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)) + /* 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) + * + * see s7_random_state for 64 bit version of this, L26622 + * here's a check that things are not totally broken: + (define (check-random-integers lo hi) + (let* ((range (- hi lo)) + (num-bins 32) + (bins (make-int-vector num-bins 0))) + (do ((i 0 (+ i 1)) + (x (random range) (random range))) + ((= i 10000) bins) + (let ((bin (floor (* (/ x range) num-bins)))) + (set! (bins bin) (+ (bins bin) 1)))))) + (display (check-random-integers 0 9223372036854775807)) (newline) + + (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)))) + (display (list mn mx)) (newline)) + */ + #define RAN_MULT 2131995753UL + double result; + s7_uint 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)) */ #else /* 64-bit MWC from https://prng.di.unimi.it/#shootout */ double result; -#define MWC_A1 0xffebb71d94fcdaf9 - /* The state must be initialized so that 0 < c < MWC_A1 - 1. For simplicity, - * we suggest to set c = 1 and x to a 64-bit seed. */ - - s7_uint x= random_seed (r), c= random_carry (r); - s7_uint u_result= x; - /* Or, result = x ^ (x << 32) (see above) */ /* s7_uint == uint64_t */ - const __uint128_t t= MWC_A1 * (__uint128_t) x + c; - random_seed (r) = t; - random_carry (r) = t >> 64; - result= ((long_double) (random_seed (r)) / (long_double) 4294967296.0) / - (long_double) 4294967295.5; + #define MWC_A1 0xffebb71d94fcdaf9 + /* The state must be initialized so that 0 < c < MWC_A1 - 1. For simplicity, we suggest to set c = 1 and x to a 64-bit seed. */ + + s7_uint x = random_seed(r), c = random_carry(r); + s7_uint u_result = x; /* Or, result = x ^ (x << 32) (see above) */ /* s7_uint == uint64_t */ + const __uint128_t t = MWC_A1 * (__uint128_t)x + c; + random_seed(r) = t; + random_carry(r) = t >> 64; + result = ((long_double)(random_seed(r)) / (long_double)4294967296.0) / (long_double)4294967295.5; #endif - return (result); + return(result); } -static s7_pointer -g_random (s7_scheme* sc, s7_pointer args) { -#define H_random \ - "(random num state) 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) +static s7_pointer g_random(s7_scheme *sc, s7_pointer args) +{ + #define H_random "(random num state) 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 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_random_state; - else { - r= cadr (args); - if (!is_random_state (r)) - return (method_or_bust (sc, r, sc->random_symbol, args, - a_random_state_object_string, 2)); - } - num= car (args); - switch (type (num)) { - case T_INTEGER: - return (make_integer (sc, (s7_int) (integer (num) * next_random (r)))); - case T_RATIO: { - const s7_double x= fraction (num); - s7_double 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 { - s7_int diff= S7_INT64_MAX - denominator (num); - numer = numerator (num); - if (diff < 100) return (make_ratio (sc, numer, denominator (num))); - denom= denominator (num) + (s7_int) floor (diff * next_random (r)); - return ( - make_ratio_with_div_check (sc, sc->random_symbol, numer, denom)); + if (is_null(cdr(args))) + r = sc->default_random_state; + else + { + r = cadr(args); + if (!is_random_state(r)) + return(method_or_bust(sc, r, sc->random_symbol, args, a_random_state_object_string, 2)); + } + num = car(args); + switch (type(num)) + { + case T_INTEGER: + return(make_integer(sc, (s7_int)(integer(num) * next_random(r)))); + case T_RATIO: + { + const s7_double x = fraction(num); + s7_double 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 + { + s7_int diff = S7_INT64_MAX - denominator(num); + numer = numerator(num); + if (diff < 100) + return(make_ratio(sc, numer, denominator(num))); + denom = denominator(num) + (s7_int)floor(diff * next_random(r)); + return(make_ratio_with_div_check(sc, sc->random_symbol, 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_simpler_ratio_or_integer(sc, numer, denom)); } - return (make_ratio (sc, numer, denominator (num))); + case T_REAL: + return(make_real(sc, real(num) * next_random(r))); + /* (x >> 11) * 0x1.0p-53, (1LL << 50) * 0x1.0p-53) -> .125, here "x" is 64 bits, but isn't this int64 related? */ + case T_COMPLEX: + return(make_complex(sc, real_part(num) * next_random(r), imag_part(num) * next_random(r))); + default: + return(method_or_bust(sc, num, sc->random_symbol, args, a_number_string, 1)); } - error= ((x < 1e-6) && (x > -1e-6)) ? 1e-18 : 1e-12; - c_rationalize (x * next_random (r), error, &numer, &denom); - return (make_simpler_ratio_or_integer (sc, numer, denom)); - } - case T_REAL: - return (make_real (sc, real (num) * next_random (r))); - /* (x >> 11) * 0x1.0p-53, (1LL << 50) * 0x1.0p-53) -> .125, here "x" is 64 - * bits, but isn't this int64 related? */ - case T_COMPLEX: - return (make_complex (sc, real_part (num) * next_random (r), - imag_part (num) * next_random (r))); - default: - return ( - method_or_bust (sc, num, sc->random_symbol, args, a_number_string, 1)); - } - return (sc->F); + return(sc->F); } -s7_double -s7_random (s7_scheme* sc, s7_pointer state) { - return (next_random ((state) ? state : sc->default_random_state)); +s7_double s7_random(s7_scheme *sc, s7_pointer state) +{ + return(next_random((state) ? state : sc->default_random_state)); } -static s7_double -random_d_7d (s7_scheme* sc, s7_double x) { - return (x * next_random (sc->default_random_state)); +static s7_double random_d_7d(s7_scheme *sc, s7_double x) +{ + return(x * next_random(sc->default_random_state)); } -static s7_int -random_i_7i (s7_scheme* sc, s7_int i) { - return ((s7_int) (i * next_random (sc->default_random_state))); +static s7_int random_i_7i(s7_scheme *sc, s7_int i) +{ + return((s7_int)(i * next_random(sc->default_random_state))); } -static s7_pointer -g_random_i (s7_scheme* sc, s7_pointer args) { - return (make_integer (sc, (s7_int) (integer (car (args)) * - next_random (sc->default_random_state)))); +static s7_pointer g_random_i(s7_scheme *sc, s7_pointer args) +{ + return(make_integer(sc, (s7_int)(integer(car(args)) * next_random(sc->default_random_state)))); } -static s7_pointer -g_random_f (s7_scheme* sc, s7_pointer args) { - return (make_real (sc, real (car (args)) * - next_random (sc->default_random_state))); +static s7_pointer g_random_f(s7_scheme *sc, s7_pointer args) +{ + return(make_real(sc, real(car(args)) * next_random(sc->default_random_state))); } -static s7_pointer -g_random_1 (s7_scheme* sc, s7_pointer args) { - s7_pointer num= car (args), r= sc->default_random_state; - 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))); - return (g_random (sc, args)); +static s7_pointer g_random_1(s7_scheme *sc, s7_pointer args) +{ + s7_pointer num = car(args), r = sc->default_random_state; + 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))); + return(g_random(sc, args)); } -static s7_pointer -random_p_p (s7_scheme* sc, s7_pointer num) { - if (is_t_integer (num)) - return (make_integer ( - sc, (s7_int) (integer (num) * next_random (sc->default_random_state)))); - if (is_t_real (num)) - return ( - make_real (sc, real (num) * next_random (sc->default_random_state))); - return (g_random (sc, set_plist_1 (sc, num))); +static s7_pointer random_p_p(s7_scheme *sc, s7_pointer num) +{ + if (is_t_integer(num)) + return(make_integer(sc, (s7_int)(integer(num) * next_random(sc->default_random_state)))); + if (is_t_real(num)) + return(make_real(sc, real(num) * next_random(sc->default_random_state))); + return(g_random(sc, set_plist_1(sc, num))); } -static s7_pointer -random_p_p_wrapped (s7_scheme* sc, s7_pointer num) { - if (is_t_integer (num)) - return (wrap_integer ( - sc, (s7_int) (integer (num) * next_random (sc->default_random_state)))); - if (is_t_real (num)) - return ( - wrap_real (sc, real (num) * next_random (sc->default_random_state))); - return (g_random (sc, set_plist_1 (sc, num))); +static s7_pointer random_p_p_wrapped(s7_scheme *sc, s7_pointer num) +{ + if (is_t_integer(num)) + return(wrap_integer(sc, (s7_int)(integer(num) * next_random(sc->default_random_state)))); + if (is_t_real(num)) + return(wrap_real(sc, real(num) * next_random(sc->default_random_state))); + return(g_random(sc, set_plist_1(sc, num))); } -static s7_pointer -random_chooser (s7_scheme* sc, s7_pointer func, int32_t args, s7_pointer expr) { - if (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 (func); +static s7_pointer random_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + if (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(func); } -static s7_pointer -g_add_i_random (s7_scheme* sc, s7_pointer args) { - s7_int x= integer (car (args)), y= opt3_int (args); /* cadadr */ - return (make_integer ( - sc, - x + (s7_int) (y * next_random ( - sc->default_random_state)))); /* (+ -1 (random 1)) - -- placement of the - (s7_int) cast - matters! */ +static s7_pointer g_add_i_random(s7_scheme *sc, s7_pointer args) +{ + s7_int x = integer(car(args)), y = opt3_int(args); /* cadadr */ + return(make_integer(sc, x + (s7_int)(y * next_random(sc->default_random_state)))); /* (+ -1 (random 1)) -- placement of the (s7_int) cast matters! */ } -uint8_t uppers[256], lowers[256]; -static void -init_uppers (void) { - for (int32_t i= 0; i < 256; i++) { - uppers[i]= (uint8_t) toupper (i); - lowers[i]= (uint8_t) tolower (i); - } -} -static int -digitp (int c) { - return (((c >= '0') && (c <= '9')) ? 1 : 0); -} - -static void -init_chars (void) { - s7_cell* cells= (s7_cell*) Calloc (NUM_CHARS + 1, sizeof (s7_cell)); - chars = (s7_pointer*) Malloc ((NUM_CHARS + 1) * sizeof (s7_pointer)); - 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++; /* I tried a version without the cells array using &chars[] - everywhere -- decided it was ugly */ - - for (int32_t 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_CONSTANT); - character (cp) = c; - upper_character (cp) = (uint8_t) toupper (i); - is_char_alphabetic (cp)= (bool) isalpha (i); - is_char_numeric (cp) = (bool) digitp (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)= (int32_t) 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 - character_name_length (cp)= - snprintf ((char*) (&(character_name (cp))), P_SIZE, - ((c < 32) || (c >= 127)) ? "#\\x%x" : "#\\%c", c); - break; +uint8_t uppers[256], lowers[256]; +static void init_uppers(void) +{ + for (int32_t i = 0; i < 256; i++) + { + uppers[i] = (uint8_t)toupper(i); + lowers[i] = (uint8_t)tolower(i); } - } } -s7_pointer -s7_make_character (s7_scheme* sc, uint32_t c) { - if (c < 256) return (chars[c]); - if (!sc->unicode_chars_table) { - sc->unicode_chars_table= s7_make_hash_table (sc, 128); - s7_gc_protect (sc, sc->unicode_chars_table); - if (mark_function[T_CHARACTER] == mark_noop) - mark_function[T_CHARACTER]= just_mark; - } +static int digitp(int c) {return(((c >= '0') && (c <= '9')) ? 1 : 0);} + +static void init_chars(void) +{ + s7_cell *cells = (s7_cell *)Calloc(NUM_CHARS + 1, sizeof(s7_cell)); + chars = (s7_pointer *)Malloc((NUM_CHARS + 1) * sizeof(s7_pointer)); + 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++; /* I tried a version without the cells array using &chars[] everywhere -- decided it was ugly */ + + for (int32_t 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_CONSTANT); + character(cp) = c; + upper_character(cp) = (uint8_t)toupper(i); + is_char_alphabetic(cp) = (bool)isalpha(i); + is_char_numeric(cp) = (bool)digitp(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) = (int32_t)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 + character_name_length(cp) = snprintf((char *)(&(character_name(cp))), P_SIZE, ((c < 32) || (c >= 127)) ? "#\\x%x" : "#\\%c", c); + break; + }} +} + + +s7_pointer s7_make_character(s7_scheme *sc, uint32_t c) { + if (c < 256) return(chars[c]); + if (!sc->unicode_chars_table) + { + sc->unicode_chars_table = s7_make_hash_table(sc, 128); + s7_gc_protect(sc, sc->unicode_chars_table); + if (mark_function[T_CHARACTER] == mark_noop) + mark_function[T_CHARACTER] = just_mark; + } { - s7_pointer key= s7_make_integer (sc, (s7_int) c); - s7_pointer val= s7_hash_table_ref (sc, sc->unicode_chars_table, key); - if (val != sc->F) return (val); + s7_pointer key = s7_make_integer(sc, (s7_int)c); + s7_pointer val = s7_hash_table_ref(sc, sc->unicode_chars_table, key); + if (val != sc->F) + return(val); { s7_pointer cp; - new_cell (sc, cp, T_CHARACTER | T_IMMUTABLE); - character (cp) = c; - upper_character (cp) = c; - is_char_alphabetic (cp)= false; - is_char_numeric (cp) = false; - is_char_whitespace (cp)= false; - is_char_uppercase (cp) = false; - is_char_lowercase (cp) = false; + new_cell(sc, cp, T_CHARACTER | T_IMMUTABLE); + character(cp) = c; + upper_character(cp) = c; + is_char_alphabetic(cp) = false; + is_char_numeric(cp) = false; + is_char_whitespace(cp) = false; + is_char_uppercase(cp) = false; + is_char_lowercase(cp) = false; if (c < 32 || (c >= 127 && c < 160)) - character_name_length (cp)= - snprintf ((char*) (&(character_name (cp))), 12, "#\\x%x", c); - else { - char buf[12]; - int len= 2; - buf[0] = '#'; - buf[1] = '\\'; - if (c < 0x80) buf[len++]= c; - else if (c < 0x800) { - buf[len++]= 0xC0 | (c >> 6); - buf[len++]= 0x80 | (c & 0x3F); - } - else if (c < 0x10000) { - buf[len++]= 0xE0 | (c >> 12); - buf[len++]= 0x80 | ((c >> 6) & 0x3F); - buf[len++]= 0x80 | (c & 0x3F); - } - else { - buf[len++]= 0xF0 | (c >> 18); - buf[len++]= 0x80 | ((c >> 12) & 0x3F); - buf[len++]= 0x80 | ((c >> 6) & 0x3F); - buf[len++]= 0x80 | (c & 0x3F); + character_name_length(cp) = snprintf((char *)(&(character_name(cp))), 12, "#\\x%x", c); + else + { + char buf[12]; + int len = 2; + buf[0] = '#'; + buf[1] = '\\'; + if (c < 0x80) + buf[len++] = c; + else if (c < 0x800) + { + buf[len++] = 0xC0 | (c >> 6); + buf[len++] = 0x80 | (c & 0x3F); + } + else if (c < 0x10000) + { + buf[len++] = 0xE0 | (c >> 12); + buf[len++] = 0x80 | ((c >> 6) & 0x3F); + buf[len++] = 0x80 | (c & 0x3F); + } + else + { + buf[len++] = 0xF0 | (c >> 18); + buf[len++] = 0x80 | ((c >> 12) & 0x3F); + buf[len++] = 0x80 | ((c >> 6) & 0x3F); + buf[len++] = 0x80 | (c & 0x3F); + } + character_name_length(cp) = len; + memcpy((void *)(&(character_name(cp))), buf, len); } - character_name_length (cp)= len; - memcpy ((void*) (&(character_name (cp))), buf, len); - } - add_semipermanent_object (sc, cp); - s7_hash_table_set (sc, sc->unicode_chars_table, key, cp); - return (cp); + add_semipermanent_object(sc, cp); + s7_hash_table_set(sc, sc->unicode_chars_table, key, cp); + return(cp); } } } -bool -s7_is_character (s7_pointer c) { - return (is_character (c)); -} +bool s7_is_character(s7_pointer c) {return(is_character(c));} -uint32_t -s7_character (s7_pointer c) { - return (character (c)); -} +uint32_t s7_character(s7_pointer c) {return(character(c));} -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 func, int32_t args, - s7_pointer expr) { - if (args != 2) return (func); - { - const s7_pointer arg1= cadr (expr), arg2= caddr (expr); - if (returns_char (sc, arg1)) { - if (returns_char (sc, arg2)) return (sc->simple_char_eq); - return (sc->simple_char_eq1); +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 func, int32_t args, s7_pointer expr) +{ + if (args != 2) return(func); + { + const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); + if (returns_char(sc, arg1)) + { + if (returns_char(sc, arg2)) return(sc->simple_char_eq); + return(sc->simple_char_eq1); + } + else + if (returns_char(sc, arg2)) return(sc->simple_char_eq2); } - else if (returns_char (sc, arg2)) return (sc->simple_char_eq2); - } - return (sc->char_equal_2); + return(sc->char_equal_2); } -static s7_pointer -char_less_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer unused_expr) { - return ((args == 2) ? sc->char_less_2 : func); -} -static s7_pointer -char_greater_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer unused_expr) { - return ((args == 2) ? sc->char_greater_2 : func); -} +static s7_pointer char_less_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr) {return((args == 2) ? sc->char_less_2 : func);} +static s7_pointer char_greater_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr) {return((args == 2) ? sc->char_greater_2 : func);} + -static s7_pointer -char_position_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer expr) { - if ((is_character (cadr (expr))) && ((args == 2) || (args == 3))) - return (sc->char_position_csi); - return (func); +static s7_pointer char_position_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + if ((is_character(cadr(expr))) && ((args == 2) || (args == 3))) + return(sc->char_position_csi); + return(func); } -/* -------------------------------- string-position - * -------------------------------- */ -#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) + +/* -------------------------------- string-position -------------------------------- */ +#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) + /* -------------------------------- strings -------------------------------- */ -bool -s7_is_string (s7_pointer p) { - return (is_string (p)); -} +bool s7_is_string(s7_pointer p) {return(is_string(p));} #define H_is_string "(string? obj) returns #t if obj is a string" #define Q_is_string sc->pl_bt /* g_is_string is now defined in s7_liii_string.c */ -s7_int -s7_string_length (s7_pointer str) { - return (string_length (str)); -} + +s7_int s7_string_length(s7_pointer str) {return(string_length(str));} + #define NUM_STRING_WRAPPERS 8 -s7_pointer -wrap_string (s7_scheme* sc, const char* str, s7_int len) { - const s7_pointer temp_str= car (sc->string_wrappers); +s7_pointer wrap_string(s7_scheme *sc, const char *str, s7_int len) +{ + const s7_pointer temp_str = car(sc->string_wrappers); #if S7_DEBUGGING - if ((full_type (temp_str) & (~T_GC_MARK)) != - (T_STRING | T_UNHEAP | T_SAFE_PROCEDURE)) - fprintf (stderr, "%s[%d]: %s\n", __func__, __LINE__, - describe_type_bits (sc, temp_str)); + if ((full_type(temp_str) & (~T_GC_MARK)) != (T_STRING | T_UNHEAP | T_SAFE_PROCEDURE)) + fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, describe_type_bits(sc, temp_str)); sc->string_wrapper_allocs++; #endif - sc->string_wrappers = cdr (sc->string_wrappers); - string_value (temp_str) = (char*) str; - string_length (temp_str)= len; - return (temp_str); + sc->string_wrappers = cdr(sc->string_wrappers); + string_value(temp_str) = (char *)str; + string_length(temp_str) = len; + return(temp_str); } -s7_pointer -s7_make_string_wrapper (s7_scheme* sc, const char* str) { - return (wrap_string (sc, str, safe_strlen (str))); -} -s7_pointer -s7_make_string_wrapper_with_length (s7_scheme* sc, const char* str, - s7_int len) { - return (wrap_string (sc, str, len)); -} +s7_pointer s7_make_string_wrapper(s7_scheme *sc, const char *str) {return(wrap_string(sc, str, safe_strlen(str)));} +s7_pointer s7_make_string_wrapper_with_length(s7_scheme *sc, const char *str, s7_int len) {return(wrap_string(sc, str, len));} -static Inline s7_pointer -inline_make_empty_string (s7_scheme* sc, s7_int len, char fill) { +static Inline s7_pointer inline_make_empty_string(s7_scheme *sc, s7_int len, char fill) +{ s7_pointer new_string; - block_t* b; - if (len == 0) return (nil_string); - new_cell (sc, new_string, T_STRING); - b = inline_mallocate (sc, len + 1); - string_block (new_string)= b; - string_value (new_string)= (char*) block_data (b); + block_t *b; + if (len == 0) return(nil_string); + new_cell(sc, new_string, T_STRING); + b = inline_mallocate(sc, len + 1); + string_block(new_string) = b; + string_value(new_string) = (char *)block_data(b); if (fill != '\0') - local_memset ((void*) (string_value (new_string)), fill, len); - string_value (new_string)[len]= 0; - string_hash (new_string) = 0; - string_length (new_string) = len; - add_string (sc, new_string); - return (new_string); + local_memset((void *)(string_value(new_string)), fill, len); + string_value(new_string)[len] = 0; + string_hash(new_string) = 0; + string_length(new_string) = len; + add_string(sc, new_string); + return(new_string); } -static s7_pointer -make_empty_string (s7_scheme* sc, s7_int len, char fill) { - return (inline_make_empty_string (sc, len, fill)); -} +static s7_pointer make_empty_string(s7_scheme *sc, s7_int len, char fill) {return(inline_make_empty_string(sc, len, fill));} -s7_pointer -s7i_make_empty_string (s7_scheme* sc, s7_int len, char fill) { - return (make_empty_string (sc, len, fill)); +s7_pointer s7i_make_empty_string(s7_scheme *sc, s7_int len, char fill) +{ + return(make_empty_string(sc, len, fill)); } -s7_int -s7i_max_string_length (s7_scheme* sc) { - return (sc->max_string_length); +s7_int s7i_max_string_length(s7_scheme *sc) +{ + return(sc->max_string_length); } -s7_int -s7i_max_list_length (s7_scheme* sc) { - return (sc->max_list_length); +s7_int s7i_max_list_length(s7_scheme *sc) +{ + return(sc->max_list_length); } -s7_pointer -s7_make_string (s7_scheme* sc, const char* str) { - s7_int len= safe_strlen (str); - return ((len > 0) ? make_string_with_length (sc, str, len) : nil_string); +s7_pointer s7_make_string(s7_scheme *sc, const char *str) +{ + s7_int len = safe_strlen(str); + return((len > 0) ? make_string_with_length(sc, str, len) : nil_string); } -static char* -make_semipermanent_c_string (s7_scheme* sc, - const char* str) /* strcpy but avoid malloc */ +static char *make_semipermanent_c_string(s7_scheme *sc, const char *str) /* strcpy but avoid malloc */ { - s7_int len = safe_strlen (str); - char* new_str= (char*) permalloc (sc, len + 1); - memcpy ((void*) new_str, (const void*) str, len); - new_str[len]= 0; - return (new_str); + s7_int len = safe_strlen(str); + char *new_str = (char *)permalloc(sc, len + 1); + memcpy((void *)new_str, (const void *)str, len); + new_str[len] = 0; + return(new_str); } -s7_pointer -s7_make_semipermanent_string ( - s7_scheme* sc, const char* str) /* for (s7) string permanent within one s7 - instance (freed upon s7_free) */ +s7_pointer s7_make_semipermanent_string(s7_scheme *sc, const char *str) /* for (s7) string permanent within one s7 instance (freed upon s7_free) */ { s7_pointer new_string; - s7_int len; - if (!str) return (nil_string); - new_string= alloc_pointer (sc); - set_full_type (new_string, T_STRING | T_IMMUTABLE | T_UNHEAP); - set_optimize_op (new_string, OP_CONSTANT); - len = safe_strlen (str); - string_length (new_string)= len; - string_block (new_string) = NULL; - string_value (new_string) = (char*) permalloc (sc, len + 1); - memcpy ((void*) string_value (new_string), (const void*) str, len); - string_value (new_string)[len]= 0; - string_hash (new_string) = 0; - return (new_string); -} - -static s7_pointer -make_permanent_string (const char* str, - s7_int len) /* for (s7) strings outside all s7 GC's */ -{ - s7_pointer new_string= - (s7_pointer) Malloc (sizeof (s7_cell)); /* was Calloc 22-May-25 */ - full_type (new_string)= - T_STRING | T_IMMUTABLE | T_UNHEAP; /* not set_full_type if calloc'd */ - set_optimize_op (new_string, OP_CONSTANT); - string_length (new_string)= len; - if ((S7_DEBUGGING) && (len != safe_strlen (str))) - fprintf (stderr, "%s[%d]: strlen(%s) != %" ld64 "\n", __func__, __LINE__, - str, safe_strlen (str)); - string_block (new_string)= NULL; - string_value (new_string)= (char*) str; - string_hash (new_string) = 0; - return (new_string); -} - -s7_pointer -s7_make_permanent_string ( - s7_scheme* sc, - const char* str) /* keep s7_scheme* arg for backwards compatibility */ -{ - return (make_permanent_string (str, safe_strlen (str))); -} - -static void -init_strings (void) { - nil_string= make_permanent_string ("", 0); - nil_string->tf.u64_type= - T_STRING | - T_UNHEAP; /* turn off T_IMMUTABLE? -- (copy str (make-string 0))! */ - set_optimize_op (nil_string, OP_CONSTANT); - - car_a_list_string= - make_permanent_string ("a pair whose car is also a pair", 31); - cdr_a_list_string= - make_permanent_string ("a pair whose cdr is also a pair", 31); - - caar_a_list_string= - make_permanent_string ("a pair whose caar is also a pair", 32); - cadr_a_list_string= - make_permanent_string ("a pair whose cadr is also a pair", 32); - cdar_a_list_string= - make_permanent_string ("a pair whose cdar is also a pair", 32); - cddr_a_list_string= - make_permanent_string ("a pair whose cddr is also a pair", 32); - - caaar_a_list_string= - make_permanent_string ("a pair whose caaar is also a pair", 33); - caadr_a_list_string= - make_permanent_string ("a pair whose caadr is also a pair", 33); - cadar_a_list_string= - make_permanent_string ("a pair whose cadar is also a pair", 33); - caddr_a_list_string= - make_permanent_string ("a pair whose caddr is also a pair", 33); - cdaar_a_list_string= - make_permanent_string ("a pair whose cdaar is also a pair", 33); - cdadr_a_list_string= - make_permanent_string ("a pair whose cdadr is also a pair", 33); - cddar_a_list_string= - make_permanent_string ("a pair whose cddar is also a pair", 33); - cdddr_a_list_string= - make_permanent_string ("a pair whose cdddr is also a pair", 33); - - a_boolean_string = make_permanent_string ("a boolean", 9); - a_byte_vector_string= make_permanent_string ("a byte-vector", 13); - a_format_port_string= - make_permanent_string ("#f, #t, (), or an open output port", 34); - a_let_string = make_permanent_string ("a let (an environment)", 22); - a_list_string= make_permanent_string ("a list", 6); - a_non_constant_symbol_string= - make_permanent_string ("a non-constant symbol", 21); - a_non_negative_integer_string= - make_permanent_string ("a non-negative integer", 22); - a_normal_procedure_string= make_permanent_string ("a normal procedure", 18); - a_normal_real_string = make_permanent_string ("a normal real", 13); - a_number_string = make_permanent_string ("a number", 8); - a_procedure_or_a_macro_string= - make_permanent_string ("a procedure or a macro", 22); - a_procedure_string = make_permanent_string ("a procedure", 11); - a_proper_list_string= make_permanent_string ("a proper list", 13); - a_random_state_object_string= - make_permanent_string ("a random-state object", 21); - a_rational_string= make_permanent_string ("an integer or a ratio", 21); - a_sequence_string= make_permanent_string ("a sequence", 10); - a_symbol_string = make_permanent_string ("a symbol", 8); - a_thunk_string = make_permanent_string ("a thunk", 7); - a_valid_radix_string= - make_permanent_string ("it should be between 2 and 16", 29); - an_association_list_string= make_permanent_string ("an association list", 19); - an_eq_func_string= - make_permanent_string ("a procedure that can take two arguments", 39); - an_input_file_port_string= make_permanent_string ("an input file port", 18); - an_input_port_string = make_permanent_string ("an input port", 13); - an_input_string_port_string= - make_permanent_string ("an input string port", 20); - an_open_input_port_string = make_permanent_string ("an open input port", 18); - an_open_output_port_string= make_permanent_string ("an open output port", 19); - an_output_file_port_string= make_permanent_string ("an output file port", 19); - an_output_port_or_f_string= - make_permanent_string ("an output port or #f", 20); - an_output_port_string= make_permanent_string ("an output port", 14); - an_output_string_port_string= - make_permanent_string ("an output string port", 21); - an_unsigned_byte_string= make_permanent_string ("an unsigned byte", 16); - cant_bind_immutable_string= - make_permanent_string ("~A: can't bind an immutable object: ~S", 38); - immutable_error_string= - make_permanent_string ("can't ~S ~S (it is immutable)", 29); - intermediate_too_large_string= - make_permanent_string ("intermediate result is too large", 32); - it_is_infinite_string= make_permanent_string ("it is infinite", 14); - it_is_nan_string= - make_permanent_string ("NaN usually indicates a numerical error", 39); - it_is_negative_string = make_permanent_string ("it is negative", 14); - it_is_too_large_string= make_permanent_string ("it is too large", 15); - it_is_too_small_string= - make_permanent_string ("it is less than the start position", 34); - parameter_set_twice_string= - make_permanent_string ("parameter set twice, ~S in ~S", 29); - result_is_too_large_string= make_permanent_string ("result is too large", 19); - something_applicable_string= - make_permanent_string ("a procedure or something applicable", 35); - too_many_indices_string= make_permanent_string ("too many indices", 16); + s7_int len; + if (!str) return(nil_string); + new_string = alloc_pointer(sc); + set_full_type(new_string, T_STRING | T_IMMUTABLE | T_UNHEAP); + set_optimize_op(new_string, OP_CONSTANT); + len = safe_strlen(str); + string_length(new_string) = len; + string_block(new_string) = NULL; + string_value(new_string) = (char *)permalloc(sc, len + 1); + memcpy((void *)string_value(new_string), (const void *)str, len); + string_value(new_string)[len] = 0; + string_hash(new_string) = 0; + return(new_string); +} + +static s7_pointer make_permanent_string(const char *str, s7_int len) /* for (s7) strings outside all s7 GC's */ +{ + s7_pointer new_string = (s7_pointer)Malloc(sizeof(s7_cell)); /* was Calloc 22-May-25 */ + full_type(new_string) = T_STRING | T_IMMUTABLE | T_UNHEAP; /* not set_full_type if calloc'd */ + set_optimize_op(new_string, OP_CONSTANT); + string_length(new_string) = len; + if ((S7_DEBUGGING) && (len != safe_strlen(str))) fprintf(stderr, "%s[%d]: strlen(%s) != %" ld64 "\n", __func__, __LINE__, str, safe_strlen(str)); + string_block(new_string) = NULL; + string_value(new_string) = (char *)str; + string_hash(new_string) = 0; + return(new_string); +} + +s7_pointer s7_make_permanent_string(s7_scheme *sc, const char *str) /* keep s7_scheme* arg for backwards compatibility */ +{ + return(make_permanent_string(str, safe_strlen(str))); +} + +static void init_strings(void) +{ + nil_string = make_permanent_string("", 0); + nil_string->tf.u64_type = T_STRING | T_UNHEAP; /* turn off T_IMMUTABLE? -- (copy str (make-string 0))! */ + set_optimize_op(nil_string, OP_CONSTANT); + + car_a_list_string = make_permanent_string("a pair whose car is also a pair", 31); + cdr_a_list_string = make_permanent_string("a pair whose cdr is also a pair", 31); + + caar_a_list_string = make_permanent_string("a pair whose caar is also a pair", 32); + cadr_a_list_string = make_permanent_string("a pair whose cadr is also a pair", 32); + cdar_a_list_string = make_permanent_string("a pair whose cdar is also a pair", 32); + cddr_a_list_string = make_permanent_string("a pair whose cddr is also a pair", 32); + + caaar_a_list_string = make_permanent_string("a pair whose caaar is also a pair", 33); + caadr_a_list_string = make_permanent_string("a pair whose caadr is also a pair", 33); + cadar_a_list_string = make_permanent_string("a pair whose cadar is also a pair", 33); + caddr_a_list_string = make_permanent_string("a pair whose caddr is also a pair", 33); + cdaar_a_list_string = make_permanent_string("a pair whose cdaar is also a pair", 33); + cdadr_a_list_string = make_permanent_string("a pair whose cdadr is also a pair", 33); + cddar_a_list_string = make_permanent_string("a pair whose cddar is also a pair", 33); + cdddr_a_list_string = make_permanent_string("a pair whose cdddr is also a pair", 33); + + a_boolean_string = make_permanent_string("a boolean", 9); + a_byte_vector_string = make_permanent_string("a byte-vector", 13); + a_format_port_string = make_permanent_string("#f, #t, (), or an open output port", 34); + a_let_string = make_permanent_string("a let (an environment)", 22); + a_list_string = make_permanent_string("a list", 6); + a_non_constant_symbol_string = make_permanent_string("a non-constant symbol", 21); + a_non_negative_integer_string = make_permanent_string("a non-negative integer", 22); + a_normal_procedure_string = make_permanent_string("a normal procedure", 18); + a_normal_real_string = make_permanent_string("a normal real", 13); + a_number_string = make_permanent_string("a number", 8); + a_procedure_or_a_macro_string = make_permanent_string("a procedure or a macro", 22); + a_procedure_string = make_permanent_string("a procedure", 11); + a_proper_list_string = make_permanent_string("a proper list", 13); + a_random_state_object_string = make_permanent_string("a random-state object", 21); + a_rational_string = make_permanent_string("an integer or a ratio", 21); + a_sequence_string = make_permanent_string("a sequence", 10); + a_symbol_string = make_permanent_string("a symbol", 8); + a_thunk_string = make_permanent_string("a thunk", 7); + a_valid_radix_string = make_permanent_string("it should be between 2 and 16", 29); + an_association_list_string = make_permanent_string("an association list", 19); + an_eq_func_string = make_permanent_string("a procedure that can take two arguments", 39); + an_input_file_port_string = make_permanent_string("an input file port", 18); + an_input_port_string = make_permanent_string("an input port", 13); + an_input_string_port_string = make_permanent_string("an input string port", 20); + an_open_input_port_string = make_permanent_string("an open input port", 18); + an_open_output_port_string = make_permanent_string("an open output port", 19); + an_output_file_port_string = make_permanent_string("an output file port", 19); + an_output_port_or_f_string = make_permanent_string("an output port or #f", 20); + an_output_port_string = make_permanent_string("an output port", 14); + an_output_string_port_string = make_permanent_string("an output string port", 21); + an_unsigned_byte_string = make_permanent_string("an unsigned byte", 16); + cant_bind_immutable_string = make_permanent_string("~A: can't bind an immutable object: ~S", 38); + immutable_error_string = make_permanent_string("can't ~S ~S (it is immutable)", 29); + intermediate_too_large_string = make_permanent_string("intermediate result is too large", 32); + it_is_infinite_string = make_permanent_string("it is infinite", 14); + it_is_nan_string = make_permanent_string("NaN usually indicates a numerical error", 39); + it_is_negative_string = make_permanent_string("it is negative", 14); + it_is_too_large_string = make_permanent_string("it is too large", 15); + it_is_too_small_string = make_permanent_string("it is less than the start position", 34); + parameter_set_twice_string = make_permanent_string("parameter set twice, ~S in ~S", 29); + result_is_too_large_string = make_permanent_string("result is too large", 19); + something_applicable_string = make_permanent_string("a procedure or something applicable", 35); + too_many_indices_string = make_permanent_string("too many indices", 16); #if !HAVE_COMPLEX_NUMBERS - no_complex_numbers_string= make_permanent_string ( - "this version of s7 does not support complex numbers", 51); + no_complex_numbers_string = make_permanent_string("this version of s7 does not support complex numbers", 51); #endif - keyword_value_missing_string= make_permanent_string ( - "~A: keyword argument's value is missing: ~S in ~S", 49); + keyword_value_missing_string = make_permanent_string("~A: keyword argument's value is missing: ~S in ~S", 49); - format_string_1= make_permanent_string ("format: ~S ~{~S~^ ~}: ~A", 24); - format_string_2= make_permanent_string ("format: ~S: ~A", 14); - format_string_3= make_permanent_string ("format: ~S ~{~S~^ ~}~&~NT^: ~A", 30); - format_string_4= make_permanent_string ("format: ~S~&~NT^: ~A", 20); + format_string_1 = make_permanent_string("format: ~S ~{~S~^ ~}: ~A", 24); + format_string_2 = make_permanent_string("format: ~S: ~A", 14); + format_string_3 = make_permanent_string("format: ~S ~{~S~^ ~}~&~NT^: ~A", 30); + format_string_4 = make_permanent_string("format: ~S~&~NT^: ~A", 20); - too_many_arguments_string= - make_permanent_string ("~S: too many arguments: ~A", 26); - not_enough_arguments_string= - make_permanent_string ("~S: not enough arguments: ~A", 28); + too_many_arguments_string = make_permanent_string("~S: too many arguments: ~A", 26); + not_enough_arguments_string = make_permanent_string("~S: not enough arguments: ~A", 28); } -/* -------------------------------- make-string -------------------------------- - */ -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 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) +/* -------------------------------- make-string -------------------------------- */ +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 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) /* g_make_string is now defined in s7_liii_string.c */ -static s7_pointer -make_string_p_i (s7_scheme* sc, s7_int len) { - if (len == 0) return (nil_string); +static s7_pointer make_string_p_i(s7_scheme *sc, s7_int len) +{ + if (len == 0) return(nil_string); if (len < 0) - out_of_range_error_nr (sc, sc->make_string_symbol, int_one, - wrap_integer (sc, len), it_is_negative_string); + out_of_range_error_nr(sc, sc->make_string_symbol, int_one, wrap_integer(sc, len), it_is_negative_string); if (len > sc->max_string_length) - error_nr ( - sc, sc->out_of_range_symbol, - set_elist_3 (sc, - wrap_string (sc, - "make-string length argument ~D is greater " - "than (*s7* 'max-string-length), ~D", - 76), - wrap_integer (sc, len), - wrap_integer (sc, sc->max_string_length))); - return (make_empty_string (sc, len, '\0')); + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "make-string length argument ~D is greater than (*s7* 'max-string-length), ~D", 76), + wrap_integer(sc, len), wrap_integer(sc, sc->max_string_length))); + return(make_empty_string(sc, len, '\0')); } + #if !WITH_PURE_S7 -/* -------------------------------- string-length - * -------------------------------- */ +/* -------------------------------- string-length -------------------------------- */ -static s7_int -string_length_i_7p (s7_scheme* sc, s7_pointer str) { - if (!is_string (str)) - return (integer (method_or_bust_p (sc, str, sc->string_length_symbol, - sc->type_names[T_STRING]))); - return (string_length (str)); +static s7_int string_length_i_7p(s7_scheme *sc, s7_pointer str) +{ + if (!is_string(str)) + return(integer(method_or_bust_p(sc, str, sc->string_length_symbol, sc->type_names[T_STRING]))); + return(string_length(str)); } #endif -/* -------------------------------- string-ref -------------------------------- - */ -static s7_pointer -string_ref_p_pi (s7_scheme* sc, s7_pointer str, s7_int index) { - if (!is_string (str)) - return (method_or_bust (sc, str, sc->string_ref_symbol, - set_plist_2 (sc, str, make_integer (sc, index)), - sc->type_names[T_STRING], 1)); - if ((index < 0) || (index >= string_length (str))) - out_of_range_error_nr ( - sc, sc->string_ref_symbol, int_two, wrap_integer (sc, index), - (index < 0) ? it_is_negative_string : it_is_too_large_string); - return (chars[((uint8_t*) string_value (str))[index]]); -} - -static s7_pointer -string_ref_p_pp (s7_scheme* sc, s7_pointer str, s7_pointer index) { - s7_int ind; - if (!is_string (str)) - return (method_or_bust_pp (sc, str, sc->string_ref_symbol, str, index, - sc->type_names[T_STRING], 1)); - if (!s7_is_integer (index)) - return (method_or_bust_pp (sc, index, sc->string_ref_symbol, str, index, - sc->type_names[T_INTEGER], 2)); - ind= s7_integer_clamped_if_gmp (sc, index); - if (ind < 0) - out_of_range_error_nr (sc, sc->string_ref_symbol, int_two, index, - it_is_negative_string); - if (ind >= string_length (str)) - out_of_range_error_nr (sc, sc->string_ref_symbol, int_two, index, - it_is_too_large_string); - return (chars[((uint8_t*) string_value (str))[ind]]); -} - -static s7_pointer -string_ref_p_p0 (s7_scheme* sc, s7_pointer str, s7_pointer unused_index) { - if (!is_string (str)) - return (method_or_bust_pp (sc, str, sc->string_ref_symbol, str, int_zero, - sc->type_names[T_STRING], 1)); - if (string_length (str) <= 0) - out_of_range_error_nr (sc, sc->string_ref_symbol, int_two, int_zero, - it_is_too_large_string); - return (chars[((uint8_t*) string_value (str))[0]]); -} - -static s7_pointer -string_plast_via_method (s7_scheme* sc, s7_pointer str) /* tmock */ -{ - s7_pointer len= - method_or_bust_p (sc, str, sc->length_symbol, sc->type_names[T_STRING]); - return (method_or_bust_pp (sc, str, sc->string_ref_symbol, str, - make_integer (sc, integer (len) - 1), - sc->type_names[T_STRING], 1)); -} - -static s7_pointer -string_ref_p_plast (s7_scheme* sc, s7_pointer str, s7_pointer unused_index) { - if (!is_string (str)) return (string_plast_via_method (sc, str)); - if (string_length (str) <= 0) - out_of_range_error_nr (sc, sc->string_ref_symbol, int_two, - wrap_integer (sc, string_length (str) - 1), - it_is_too_large_string); - return (chars[((uint8_t*) string_value (str))[string_length (str) - 1]]); -} - -static inline s7_pointer -string_ref_p_pi_unchecked (s7_scheme* sc, s7_pointer str, s7_int index) { - if ((index < 0) || (index >= string_length (str))) - out_of_range_error_nr ( - sc, sc->string_ref_symbol, int_two, wrap_integer (sc, index), - (index < 0) ? it_is_negative_string : it_is_too_large_string); - return (chars[((uint8_t*) string_value (str))[index]]); -} - -static s7_pointer -string_ref_p_pi_direct (s7_scheme* unused_sc, s7_pointer str, s7_int index) { - return (chars[((uint8_t*) string_value (str))[index]]); -} - -/* -------------------------------- string-set! -------------------------------- - */ -static s7_pointer -string_set_p_pip (s7_scheme* sc, s7_pointer str, s7_int index, s7_pointer chr) { - if (!is_string (str)) - wrong_type_error_nr (sc, sc->string_set_symbol, 1, str, - sc->type_names[T_STRING]); - if (!is_character (chr)) - wrong_type_error_nr (sc, sc->string_set_symbol, 2, chr, - sc->type_names[T_CHARACTER]); - if (s7_character (chr) > 0xFF) { - const char* hint= "string-set! only accepts characters in range " - "#x00..#xFF; use utf8-string-set! for Unicode characters"; - out_of_range_error_nr (sc, sc->string_set_symbol, int_two, chr, - wrap_string (sc, hint, safe_strlen (hint))); - } - if ((index >= 0) && (index < string_length (str))) - string_value (str)[index]= s7_character (chr); - else - out_of_range_error_nr ( - sc, sc->string_set_symbol, int_two, wrap_integer (sc, index), - (index < 0) ? it_is_negative_string : it_is_too_large_string); - return (chr); + +/* -------------------------------- string-ref -------------------------------- */ +/* string_ref_p_pi, string_ref_p_pp, string_ref_p_p0, string_plast_via_method, + string_ref_p_plast, string_ref_p_pi_unchecked, string_ref_p_pi_direct, + string_set_p_pip, string_set_p_pip_unchecked, string_set_p_pip_direct + migrated to s7_liii_string.c */ + + +/* -------------------------------- string-append -------------------------------- */ +static s7_pointer c_object_length(s7_scheme *sc, s7_pointer obj); + +static bool sequence_is_empty(s7_scheme *sc, s7_pointer seq) /* "is_empty" is taken by C++?? */ +{ + switch (type(seq)) + { + case T_BYTE_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_COMPLEX_VECTOR: + case T_VECTOR: return(vector_length(seq) == 0); + case T_NIL: return(true); + case T_PAIR: return(false); + case T_STRING: return(string_length(seq) == 0); + case T_HASH_TABLE: return(hash_table_entries(seq) == 0); + case T_C_OBJECT: return(s7_is_eqv(sc, c_object_length(sc, seq), int_zero)); + case T_LET: if (seq != sc->rootlet) return(!is_not_slot_end(let_slots(seq))); /* (append (rootlet) #f) */ + default: return(false); + } } -static s7_pointer -string_set_p_pip_unchecked (s7_scheme* sc, s7_pointer str, s7_int index, - s7_pointer chr) { - if ((index >= 0) && (index < string_length (str))) - string_value (str)[index]= s7_character (chr); - else - out_of_range_error_nr ( - sc, sc->string_set_symbol, int_two, wrap_integer (sc, index), - (index < 0) ? it_is_negative_string : it_is_too_large_string); - return (chr); -} - -static s7_pointer -string_set_p_pip_direct (s7_scheme* unused_sc, s7_pointer str, s7_int index, - s7_pointer chr) { - string_value (str)[index]= s7_character (chr); - return (chr); -} - -/* -------------------------------- string-append - * -------------------------------- */ -static s7_pointer c_object_length (s7_scheme* sc, s7_pointer obj); - -static bool -sequence_is_empty (s7_scheme* sc, - s7_pointer seq) /* "is_empty" is taken by C++?? */ -{ - switch (type (seq)) { - case T_BYTE_VECTOR: - case T_INT_VECTOR: - case T_FLOAT_VECTOR: - case T_COMPLEX_VECTOR: - case T_VECTOR: - return (vector_length (seq) == 0); - case T_NIL: - return (true); - case T_PAIR: - return (false); - case T_STRING: - return (string_length (seq) == 0); - case T_HASH_TABLE: - return (hash_table_entries (seq) == 0); - case T_C_OBJECT: - return (s7_is_eqv (sc, c_object_length (sc, seq), int_zero)); - case T_LET: - if (seq != sc->rootlet) - return (!is_not_slot_end (let_slots (seq))); /* (append (rootlet) #f) */ - default: - return (false); - } +static s7_int pair_length_1(s7_scheme *sc, s7_pointer seq) +{ + s7_int len = s7_list_length(sc, seq); + return((len == 0) ? -1 : len); } -static s7_int -pair_length_1 (s7_scheme* sc, s7_pointer seq) { - s7_int len= s7_list_length (sc, seq); - return ((len == 0) ? -1 : len); -} - -static s7_int -cobj_len (s7_scheme* sc, s7_pointer seq) { - s7_pointer len= c_object_length (sc, seq); - if (s7_is_integer (len)) return (s7_integer_clamped_if_gmp (sc, len)); - return (-1); -} - -static s7_int -sequence_length (s7_scheme* sc, s7_pointer seq) { - switch (type (seq)) { - case T_PAIR: - return (pair_length_1 (sc, seq)); - case T_NIL: - return (0); - case T_BYTE_VECTOR: - case T_INT_VECTOR: - case T_FLOAT_VECTOR: - case T_COMPLEX_VECTOR: - case T_VECTOR: - return (vector_length (seq)); - case T_STRING: - return (string_length (seq)); - case T_HASH_TABLE: - return (hash_table_entries (seq)); - case T_LET: - return (let_length (sc, seq)); - case T_C_OBJECT: - return (cobj_len (sc, seq)); - default: - return (-1); - } +static s7_int cobj_len(s7_scheme *sc, s7_pointer seq) +{ + s7_pointer len = c_object_length(sc, seq); + if (s7_is_integer(len)) + return(s7_integer_clamped_if_gmp(sc, len)); + return(-1); +} + +static s7_int sequence_length(s7_scheme *sc, s7_pointer seq) +{ + switch (type(seq)) + { + case T_PAIR: return(pair_length_1(sc, seq)); + case T_NIL: return(0); + case T_BYTE_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_COMPLEX_VECTOR: + case T_VECTOR: return(vector_length(seq)); + case T_STRING: return(string_length(seq)); + case T_HASH_TABLE: return(hash_table_entries(seq)); + case T_LET: return(let_length(sc, seq)); + case T_C_OBJECT: return(cobj_len(sc, seq)); + default: return(-1); + } } -bool -s7i_is_sequence (s7_pointer p) { - return (is_sequence (p)); +bool s7i_is_sequence(s7_pointer p) +{ + return(is_sequence(p)); } -bool -s7i_sequence_is_empty (s7_scheme* sc, s7_pointer seq) { - return (sequence_is_empty (sc, seq)); +bool s7i_sequence_is_empty(s7_scheme *sc, s7_pointer seq) +{ + return(sequence_is_empty(sc, seq)); } -s7_int -s7i_sequence_length (s7_scheme* sc, s7_pointer seq) { - return (sequence_length (sc, seq)); +s7_int s7i_sequence_length(s7_scheme *sc, s7_pointer seq) +{ + return(sequence_length(sc, seq)); } -static s7_pointer s7_copy_1 (s7_scheme* sc, s7_pointer caller, s7_pointer args); +static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args); -/* string_append_2, s7i_string_append_1, string_append_1, string_append_p_pp, - g_string_append_2 migrated to s7_liii_string.c */ +/* string_append_2, s7i_string_append_1, string_append_1, string_append_p_pp, g_string_append_2 + migrated to s7_liii_string.c */ -#define H_string_append \ - "(string-append str1 ...) appends all its string arguments into one string" +#define H_string_append "(string-append str1 ...) appends all its string arguments into one string" #define Q_string_append sc->pcl_s /* g_string_append is now defined in s7_liii_string.c */ -static void check_for_substring_temp (s7_scheme* sc, s7_pointer expr); +static void check_for_substring_temp(s7_scheme *sc, s7_pointer expr); -static s7_pointer -string_append_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer expr) { - check_for_substring_temp (sc, expr); - return ((args == 2) ? sc->string_append_2 : func); +static s7_pointer string_append_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + check_for_substring_temp(sc, expr); + return((args == 2) ? sc->string_append_2 : func); } -/* -------------------------------- 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 - * sc->unused if method called but wants to indicate that it gives up -- is - * this useful?? */ - const s7_pointer pstart= car (index_args); - s7_int index; - - if (!s7_is_integer (pstart)) - return (method_or_bust (sc, pstart, caller, args, sc->type_names[T_INTEGER], - position)); - index= s7_integer_clamped_if_gmp (sc, pstart); - if ((index < 0) || (index > *end)) /* *end == length here */ - out_of_range_error_nr (sc, caller, small_int (position), pstart, - (index < 0) ? it_is_negative_string - : it_is_too_large_string); - *start= index; - - if (is_pair (cdr (index_args))) { - const s7_pointer pend= cadr (index_args); - if (!s7_is_integer (pend)) - return (method_or_bust (sc, pend, caller, args, sc->type_names[T_INTEGER], - position + 1)); - index= s7_integer_clamped_if_gmp (sc, pend); - if ((index < *start) || (index > *end)) - out_of_range_error_nr (sc, caller, small_int (position + 1), pend, - (index < *start) ? it_is_too_small_string - : it_is_too_large_string); - *end= index; - } - return (sc->unused); + +/* -------------------------------- 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 sc->unused if method called but wants to indicate that it gives up -- is this useful?? */ + const s7_pointer pstart = car(index_args); + s7_int index; + + if (!s7_is_integer(pstart)) + return(method_or_bust(sc, pstart, caller, args, sc->type_names[T_INTEGER], position)); + index = s7_integer_clamped_if_gmp(sc, pstart); + if ((index < 0) || + (index > *end)) /* *end == length here */ + out_of_range_error_nr(sc, caller, small_int(position), pstart, (index < 0) ? it_is_negative_string : it_is_too_large_string); + *start = index; + + if (is_pair(cdr(index_args))) + { + const s7_pointer pend = cadr(index_args); + if (!s7_is_integer(pend)) + return(method_or_bust(sc, pend, caller, args, sc->type_names[T_INTEGER], position + 1)); + index = s7_integer_clamped_if_gmp(sc, pend); + if ((index < *start) || + (index > *end)) + out_of_range_error_nr(sc, caller, small_int(position + 1), pend, (index < *start) ? it_is_too_small_string : it_is_too_large_string); + *end = index; + } + return(sc->unused); } -#define H_substring \ - "(substring str start (end (length str))) returns the portion of the string str between start and \ +#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_signature (sc, 4, sc->is_string_symbol, sc->is_string_symbol, \ - sc->is_integer_symbol, sc->is_integer_symbol) +#define Q_substring s7_make_signature(sc, 4, sc->is_string_symbol, sc->is_string_symbol, sc->is_integer_symbol, sc->is_integer_symbol) /* g_substring is now defined in s7_liii_string.c */ -#define H_substring_uncopied \ - "(substring-uncopied str start (end (length str))) returns an immutable string sharing the portion of the string str between start and \ +#define H_substring_uncopied "(substring-uncopied str start (end (length str))) returns an immutable string sharing the portion of the string str between start and \ end: (substring-uncopied \"01234\" 1 2) -> \"1\". substring-uncopied does not GC protect the original string; it is intended for very brief uses." -#define Q_substring_uncopied \ - s7_make_signature (sc, 4, sc->is_string_symbol, sc->is_string_symbol, \ - sc->is_integer_symbol, sc->is_integer_symbol) +#define Q_substring_uncopied s7_make_signature(sc, 4, sc->is_string_symbol, sc->is_string_symbol, sc->is_integer_symbol, sc->is_integer_symbol) /* g_substring_uncopied is now defined in s7_liii_string.c */ -static s7_pointer -substring_uncopied_p_pii (s7_scheme* sc, s7_pointer str, s7_int start, - s7_int end) { - /* is_string(arg1) already checked in opt */ - if ((end < start) || (end > string_length (str))) - out_of_range_error_nr ( - sc, sc->substring_uncopied_symbol, int_three, wrap_integer (sc, end), - (end < start) ? it_is_too_small_string : it_is_too_large_string); - if (start < 0) - out_of_range_error_nr (sc, sc->substring_uncopied_symbol, int_two, - wrap_integer (sc, start), it_is_negative_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) { - int32_t substrs= 0; - /* don't use substring_uncopied for arg if arg is returned: (reverse! - * (write-string (substring x ...))) */ - for (s7_pointer p= cdr (expr); is_pair (p); p= cdr (p)) { - const s7_pointer 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) - set_class_and_fn_proc (arg, sc->substring_uncopied); - substrs++; - } - else if (fn_proc (arg) == g_symbol_to_string) - set_class_and_fn_proc (arg, sc->symbol_to_string_uncopied); - else if ((fn_proc (arg) == g_get_output_string) && (is_null (cddr (arg)))) - set_class_and_fn_proc (arg, sc->get_output_string_uncopied); - } - } +/* substring_uncopied_p_pii migrated to s7_liii_string.c */ + +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) +{ + int32_t substrs = 0; + /* don't use substring_uncopied for arg if arg is returned: (reverse! (write-string (substring x ...))) */ + for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p)) + { + const s7_pointer 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) + set_class_and_fn_proc(arg, sc->substring_uncopied); + substrs++; + } + else + if (fn_proc(arg) == g_symbol_to_string) + set_class_and_fn_proc(arg, sc->symbol_to_string_uncopied); + else + if ((fn_proc(arg) == g_get_output_string) && (is_null(cddr(arg)))) + set_class_and_fn_proc(arg, sc->get_output_string_uncopied); + }} } -static s7_pointer -string_substring_chooser (s7_scheme* sc, s7_pointer func, int32_t unused_args, - s7_pointer expr) { +static s7_pointer string_substring_chooser(s7_scheme *sc, s7_pointer func, int32_t unused_args, s7_pointer expr) +{ /* used by several string functions */ - check_for_substring_temp (sc, expr); - return (func); + check_for_substring_temp(sc, expr); + return(func); } -/* -------------------------------- string-copy -------------------------------- - */ -#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 -------------------------------- */ +#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) +#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) /* g_string_copy is now defined in s7_liii_string.c */ -static s7_pointer -string_copy_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer expr) { - if (args == 1) check_for_substring_temp (sc, expr); - return (func); +static s7_pointer string_copy_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + if (args == 1) check_for_substring_temp(sc, expr); + return(func); } -/* -------------------------------- 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 + +/* -------------------------------- 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 */ - const size_t len1= (size_t) string_length (s1); - const size_t len2= (size_t) string_length (s2); + const size_t len1 = (size_t)string_length(s1); + const size_t len2 = (size_t)string_length(s2); const size_t len = (len1 > len2) ? len2 : len1; - const char* str1= string_value (s1); - const char* str2= string_value (s2); - - if (len < sizeof (size_t)) - for (size_t 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 i= 0, last= len / sizeof (size_t); - for (const size_t *ptr1= (size_t*) str1, *ptr2= (size_t*) str2; i < last; - i++) - if (ptr1[i] != ptr2[i]) break; - for (size_t 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); + const char *str1 = string_value(s1); + const char *str2 = string_value(s2); + + if (len < sizeof(size_t)) + for (size_t 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 i = 0, last = len / sizeof(size_t); + for (const size_t *ptr1 = (size_t *)str1, *ptr2 = (size_t *)str2; i < last; i++) + if (ptr1[i] != ptr2[i]) + break; + for (size_t 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 obj) +{ + if (s7_is_string(obj)) + return(true); + if (has_active_methods(sc, obj)) + { + s7_pointer func = find_method_with_let(sc, obj, sc->is_string_symbol); + if (func != sc->undefined) + return(is_true(sc, s7_apply_function(sc, func, set_plist_1(sc, obj)))); } - } - if (len1 < len2) return (-1); - return ((len1 > len2) ? 1 : 0); -} - -static bool -is_string_via_method (s7_scheme* sc, s7_pointer obj) { - if (s7_is_string (obj)) return (true); - if (has_active_methods (sc, obj)) { - s7_pointer func= find_method_with_let (sc, obj, sc->is_string_symbol); - if (func != sc->undefined) - return ( - is_true (sc, s7_apply_function (sc, func, set_plist_1 (sc, obj)))); - } - return (false); + return(false); } -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)))); /* unaligned */ +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)))); /* unaligned */ } /* string comparison bridge functions */ -int32_t -s7i_scheme_strcmp (s7_pointer s1, s7_pointer s2) { - return (scheme_strcmp (s1, s2)); -} -bool -s7i_scheme_strings_are_equal (s7_pointer x, s7_pointer y) { - return (scheme_strings_are_equal (x, y)); -} -bool -s7i_is_string_via_method (s7_scheme* sc, s7_pointer obj) { - return (is_string_via_method (sc, obj)); +int32_t s7i_scheme_strcmp(s7_pointer s1, s7_pointer s2) {return(scheme_strcmp(s1, s2));} +bool s7i_scheme_strings_are_equal(s7_pointer x, s7_pointer y) {return(scheme_strings_are_equal(x, y));} +bool s7i_is_string_via_method(s7_scheme *sc, s7_pointer obj) {return(is_string_via_method(sc, obj));} + +s7_pointer s7i_method_or_bust_sym(s7_scheme *sc, s7_pointer obj, s7_pointer method_sym, s7_pointer args, s7_pointer typ, s7_int arg_pos) +{ + return(method_or_bust(sc, obj, method_sym, args, typ, (int32_t)arg_pos)); +} + +s7_pointer s7i_set_plist_1(s7_scheme *sc, s7_pointer x1) {return(set_plist_1(sc, x1));} +s7_pointer s7i_string_type_name(s7_scheme *sc) {return(sc->type_names[T_STRING]);} +s7_pointer s7i_character_type_name(s7_scheme *sc) {return(sc->type_names[T_CHARACTER]);} +void s7i_check_free_heap_size(s7_scheme *sc, s7_int size) {check_free_heap_size(sc, size);} +s7_pointer s7i_string_eq_symbol(s7_scheme *sc) {return(sc->string_eq_symbol);} +s7_pointer s7i_string_lt_symbol(s7_scheme *sc) {return(sc->string_lt_symbol);} +s7_pointer s7i_string_gt_symbol(s7_scheme *sc) {return(sc->string_gt_symbol);} +s7_pointer s7i_string_leq_symbol(s7_scheme *sc) {return(sc->string_leq_symbol);} +s7_pointer s7i_string_geq_symbol(s7_scheme *sc) {return(sc->string_geq_symbol);} +bool s7i_is_true(s7_scheme *sc, s7_pointer p) {return(is_true(sc, p));} +s7_pointer s7i_is_string_symbol(s7_scheme *sc) {return(sc->is_string_symbol);} +s7_pointer s7i_is_boolean_symbol(s7_scheme *sc) {return(sc->is_boolean_symbol);} +s7_pointer s7i_is_unspecified_symbol(s7_scheme *sc) {return(sc->is_unspecified_symbol);} +s7_pointer s7i_is_number_symbol(s7_scheme *sc) {return(sc->is_number_symbol);} +s7_pointer s7i_is_integer_symbol(s7_scheme *sc) {return(sc->is_integer_symbol);} +s7_pointer s7i_is_real_symbol(s7_scheme *sc) {return(sc->is_real_symbol);} +s7_pointer s7i_is_complex_symbol(s7_scheme *sc) {return(sc->is_complex_symbol);} +s7_pointer s7i_is_rational_symbol(s7_scheme *sc) {return(sc->is_rational_symbol);} +s7_pointer s7i_is_keyword_symbol(s7_scheme *sc) {return(sc->is_keyword_symbol);} +s7_pointer s7i_is_dilambda_symbol(s7_scheme *sc) {return(sc->is_dilambda_symbol);} +s7_pointer s7i_is_sequence_symbol(s7_scheme *sc) {return(sc->is_sequence_symbol);} +s7_pointer s7i_is_symbol_symbol(s7_scheme *sc) {return(sc->is_symbol_symbol);} +s7_pointer s7i_is_input_port_symbol(s7_scheme *sc) {return(sc->is_input_port_symbol);} +s7_pointer s7i_is_output_port_symbol(s7_scheme *sc) {return(sc->is_output_port_symbol);} +s7_pointer s7i_is_macro_symbol(s7_scheme *sc) {return(sc->is_macro_symbol);} +s7_pointer s7i_is_undefined_symbol(s7_scheme *sc) {return(sc->is_undefined_symbol);} +s7_pointer s7i_is_eof_object_symbol(s7_scheme *sc) {return(sc->is_eof_object_symbol);} +s7_pointer s7i_is_byte_symbol(s7_scheme *sc) {return(sc->is_byte_symbol);} +s7_pointer s7i_is_float_symbol(s7_scheme *sc) {return(sc->is_float_symbol);} +s7_pointer s7i_is_random_state_symbol(s7_scheme *sc) {return(sc->is_random_state_symbol);} +s7_pointer s7i_is_continuation_symbol(s7_scheme *sc) {return(sc->is_continuation_symbol);} +s7_pointer s7i_is_iterator_symbol(s7_scheme *sc) {return(sc->is_iterator_symbol);} +s7_pointer s7i_is_gensym_symbol(s7_scheme *sc) {return(sc->is_gensym_symbol);} +s7_pointer s7i_is_syntax_symbol(s7_scheme *sc) {return(sc->is_syntax_symbol);} +s7_pointer s7i_is_let_symbol(s7_scheme *sc) {return(sc->is_let_symbol);} +bool s7i_is_goto(s7_pointer p) {return(is_goto(p));} +bool s7i_is_constant(s7_scheme *sc, s7_pointer p) {return(is_constant(sc, p));} +s7_pointer s7i_is_c_object_symbol(s7_scheme *sc) {return(sc->is_c_object_symbol);} +s7_pointer s7i_help_symbol(s7_scheme *sc) {return(sc->help_symbol);} +bool s7i_is_undefined(s7_pointer p) {return(is_undefined(p));} +bool s7i_is_eof(s7_pointer p) {return(is_eof(p));} +bool s7i_is_t_real(s7_pointer p) {return(is_t_real(p));} +bool s7i_is_continuation(s7_pointer p) {return(is_continuation(p));} +const uint8_t *s7i_uppers_ptr(void) {return(uppers);} + +/* bridge functions for s7_scheme_predicate.c migration */ +s7_pointer s7i_c_pointer_type(s7_pointer p) {return(c_pointer_type(p));} +bool s7i_has_methods(s7_pointer p) {return(has_methods(p));} +bool s7i_is_funclet(s7_pointer p) {return(is_funclet(p));} +bool s7i_is_maclet(s7_pointer p) {return(is_maclet(p));} +s7_pointer s7i_rootlet(s7_scheme *sc) {return(sc->rootlet);} +s7_pointer s7i_is_c_pointer_symbol(s7_scheme *sc) {return(sc->is_c_pointer_symbol);} +s7_pointer s7i_is_openlet_symbol(s7_scheme *sc) {return(sc->is_openlet_symbol);} +s7_pointer s7i_is_funclet_symbol(s7_scheme *sc) {return(sc->is_funclet_symbol);} + +/* bridge functions for g_c_pointer_info and g_c_pointer_type migration */ +s7_pointer s7i_c_pointer_info_p_p(s7_scheme *sc, s7_pointer cptr) {return(c_pointer_info_p_p(sc, cptr));} +s7_pointer s7i_c_pointer_type_p_p(s7_scheme *sc, s7_pointer cptr) {return(c_pointer_type_p_p(sc, cptr));} + +/* bridge functions for g_tree_is_cyclic and g_type_of migration */ +bool s7i_tree_is_cyclic(s7_scheme *sc, s7_pointer p) {return(tree_is_cyclic(sc, p));} +s7_pointer s7i_type_of(s7_scheme *sc, s7_pointer p) {return(sc->type_to_typers[type(p)]);} + +/* g_string_cmp, g_string_cmp_not, g_strings_are_equal, g_strings_are_less, g_strings_are_greater, + g_strings_are_geq, g_strings_are_leq, g_string_equal_2, g_string_equal_2c, string_eq_p_pp, + g_string_less_2, string_lt_p_pp, g_string_greater_2, string_gt_p_pp, + string_lt_b_unchecked/7pp, string_leq_b_unchecked/7pp, string_gt_b_unchecked/7pp, + string_geq_b_unchecked/7pp, string_eq_b_unchecked/7pp + migrated to s7_liii_string.c */ + +#define H_strings_are_equal "(string=? str ...) returns #t if all the string arguments are equal" +#define Q_strings_are_equal sc->pcl_bs +#define H_strings_are_less "(stringpcl_bs +#define H_strings_are_greater "(string>? str ...) returns #t if all the string arguments are decreasing" +#define Q_strings_are_greater sc->pcl_bs +#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 +#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 + +static s7_pointer string_equal_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + check_for_substring_temp(sc, expr); + return((args == 2) ? ((is_string(caddr(expr))) ? sc->string_equal_2c : sc->string_equal_2) : func); } -s7_pointer -s7i_method_or_bust_sym (s7_scheme* sc, s7_pointer obj, s7_pointer method_sym, - s7_pointer args, s7_pointer typ, s7_int arg_pos) { - return (method_or_bust (sc, obj, method_sym, args, typ, (int32_t) arg_pos)); +static s7_pointer string_less_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + check_for_substring_temp(sc, expr); + return((args == 2) ? sc->string_less_2 : func); } -s7_pointer -s7i_set_plist_1 (s7_scheme* sc, s7_pointer x1) { - return (set_plist_1 (sc, x1)); +static s7_pointer string_greater_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + check_for_substring_temp(sc, expr); + return((args == 2) ? sc->string_greater_2 : func); } -s7_pointer -s7i_string_type_name (s7_scheme* sc) { - return (sc->type_names[T_STRING]); -} -s7_pointer -s7i_string_eq_symbol (s7_scheme* sc) { - return (sc->string_eq_symbol); -} -s7_pointer -s7i_string_lt_symbol (s7_scheme* sc) { - return (sc->string_lt_symbol); -} -s7_pointer -s7i_string_gt_symbol (s7_scheme* sc) { - return (sc->string_gt_symbol); -} -s7_pointer -s7i_string_leq_symbol (s7_scheme* sc) { - return (sc->string_leq_symbol); -} -s7_pointer -s7i_string_geq_symbol (s7_scheme* sc) { - return (sc->string_geq_symbol); -} -bool -s7i_is_true (s7_scheme* sc, s7_pointer p) { - return (is_true (sc, p)); -} -s7_pointer -s7i_is_string_symbol (s7_scheme* sc) { - return (sc->is_string_symbol); -} -s7_pointer -s7i_is_boolean_symbol (s7_scheme* sc) { - return (sc->is_boolean_symbol); -} -s7_pointer -s7i_is_unspecified_symbol (s7_scheme* sc) { - return (sc->is_unspecified_symbol); -} -s7_pointer -s7i_is_number_symbol (s7_scheme* sc) { - return (sc->is_number_symbol); -} -s7_pointer -s7i_is_integer_symbol (s7_scheme* sc) { - return (sc->is_integer_symbol); -} -s7_pointer -s7i_is_real_symbol (s7_scheme* sc) { - return (sc->is_real_symbol); -} -s7_pointer -s7i_is_complex_symbol (s7_scheme* sc) { - return (sc->is_complex_symbol); -} -s7_pointer -s7i_is_rational_symbol (s7_scheme* sc) { - return (sc->is_rational_symbol); -} -s7_pointer -s7i_is_keyword_symbol (s7_scheme* sc) { - return (sc->is_keyword_symbol); -} -s7_pointer -s7i_is_dilambda_symbol (s7_scheme* sc) { - return (sc->is_dilambda_symbol); -} -s7_pointer -s7i_is_sequence_symbol (s7_scheme* sc) { - return (sc->is_sequence_symbol); -} -s7_pointer -s7i_is_symbol_symbol (s7_scheme* sc) { - return (sc->is_symbol_symbol); -} -s7_pointer -s7i_is_input_port_symbol (s7_scheme* sc) { - return (sc->is_input_port_symbol); -} -s7_pointer -s7i_is_output_port_symbol (s7_scheme* sc) { - return (sc->is_output_port_symbol); -} -s7_pointer -s7i_is_macro_symbol (s7_scheme* sc) { - return (sc->is_macro_symbol); -} -s7_pointer -s7i_is_undefined_symbol (s7_scheme* sc) { - return (sc->is_undefined_symbol); -} -s7_pointer -s7i_is_eof_object_symbol (s7_scheme* sc) { - return (sc->is_eof_object_symbol); -} -s7_pointer -s7i_is_byte_symbol (s7_scheme* sc) { - return (sc->is_byte_symbol); -} -s7_pointer -s7i_is_float_symbol (s7_scheme* sc) { - return (sc->is_float_symbol); -} -s7_pointer -s7i_is_random_state_symbol (s7_scheme* sc) { - return (sc->is_random_state_symbol); -} -s7_pointer -s7i_is_continuation_symbol (s7_scheme* sc) { - return (sc->is_continuation_symbol); -} -s7_pointer -s7i_is_iterator_symbol (s7_scheme* sc) { - return (sc->is_iterator_symbol); -} -s7_pointer -s7i_is_gensym_symbol (s7_scheme* sc) { - return (sc->is_gensym_symbol); -} -s7_pointer -s7i_is_syntax_symbol (s7_scheme* sc) { - return (sc->is_syntax_symbol); -} -s7_pointer -s7i_is_let_symbol (s7_scheme* sc) { - return (sc->is_let_symbol); -} -bool -s7i_is_goto (s7_pointer p) { - return (is_goto (p)); -} -bool -s7i_is_constant (s7_scheme* sc, s7_pointer p) { - return (is_constant (sc, p)); -} -s7_pointer -s7i_is_c_object_symbol (s7_scheme* sc) { - return (sc->is_c_object_symbol); -} -s7_pointer -s7i_help_symbol (s7_scheme* sc) { - return (sc->help_symbol); -} -bool -s7i_is_undefined (s7_pointer p) { - return (is_undefined (p)); -} -bool -s7i_is_eof (s7_pointer p) { - return (is_eof (p)); -} -bool -s7i_is_t_real (s7_pointer p) { - return (is_t_real (p)); -} -bool -s7i_is_continuation (s7_pointer p) { - return (is_continuation (p)); -} -const uint8_t* -s7i_uppers_ptr (void) { - return (uppers); -} - -/* bridge functions for s7_scheme_predicate.c migration */ -s7_pointer -s7i_c_pointer_type (s7_pointer p) { - return (c_pointer_type (p)); -} -bool -s7i_has_methods (s7_pointer p) { - return (has_methods (p)); -} -bool -s7i_is_funclet (s7_pointer p) { - return (is_funclet (p)); -} -bool -s7i_is_maclet (s7_pointer p) { - return (is_maclet (p)); -} -s7_pointer -s7i_rootlet (s7_scheme* sc) { - return (sc->rootlet); -} -s7_pointer -s7i_is_c_pointer_symbol (s7_scheme* sc) { - return (sc->is_c_pointer_symbol); -} -s7_pointer -s7i_is_openlet_symbol (s7_scheme* sc) { - return (sc->is_openlet_symbol); -} -s7_pointer -s7i_is_funclet_symbol (s7_scheme* sc) { - return (sc->is_funclet_symbol); -} - -/* bridge functions for g_c_pointer_info and g_c_pointer_type migration */ -s7_pointer -s7i_c_pointer_info_p_p (s7_scheme* sc, s7_pointer cptr) { - return (c_pointer_info_p_p (sc, cptr)); -} -s7_pointer -s7i_c_pointer_type_p_p (s7_scheme* sc, s7_pointer cptr) { - return (c_pointer_type_p_p (sc, cptr)); -} - -/* bridge functions for g_tree_is_cyclic and g_type_of migration */ -bool -s7i_tree_is_cyclic (s7_scheme* sc, s7_pointer p) { - return (tree_is_cyclic (sc, p)); -} -s7_pointer -s7i_type_of (s7_scheme* sc, s7_pointer p) { - return (sc->type_to_typers[type (p)]); -} - -/* g_string_cmp, g_string_cmp_not, g_strings_are_equal, g_strings_are_less, - g_strings_are_greater, g_strings_are_geq, g_strings_are_leq, - g_string_equal_2, g_string_equal_2c, string_eq_p_pp, g_string_less_2, - string_lt_p_pp, g_string_greater_2, string_gt_p_pp, - string_lt_b_unchecked/7pp, string_leq_b_unchecked/7pp, - string_gt_b_unchecked/7pp, string_geq_b_unchecked/7pp, - string_eq_b_unchecked/7pp migrated to s7_liii_string.c */ - -#define H_strings_are_equal \ - "(string=? str ...) returns #t if all the string arguments are equal" -#define Q_strings_are_equal sc->pcl_bs -#define H_strings_are_less \ - "(stringpcl_bs -#define H_strings_are_greater \ - "(string>? str ...) returns #t if all the string arguments are decreasing" -#define Q_strings_are_greater sc->pcl_bs -#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 -#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 - -static s7_pointer -string_equal_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer expr) { - check_for_substring_temp (sc, expr); - return ((args == 2) ? ((is_string (caddr (expr))) ? sc->string_equal_2c - : sc->string_equal_2) - : func); -} - -static s7_pointer -string_less_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer expr) { - check_for_substring_temp (sc, expr); - return ((args == 2) ? sc->string_less_2 : func); -} - -static s7_pointer -string_greater_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer expr) { - check_for_substring_temp (sc, expr); - return ((args == 2) ? sc->string_greater_2 : func); -} - -#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). - */ - const s7_int len1= string_length (s1); - const s7_int len2= string_length (s2); - const s7_int len = (len1 > len2) ? len2 : len1; - const uint8_t* str1= (const uint8_t*) string_value (s1); - const uint8_t* str2= (const uint8_t*) string_value (s2); - - for (s7_int 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); + + +#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). + */ + const s7_int len1 = string_length(s1); + const s7_int len2 = string_length(s2); + const s7_int len = (len1 > len2) ? len2 : len1; + const uint8_t *str1 = (const uint8_t *)string_value(s1); + const uint8_t *str2 = (const uint8_t *)string_value(s2); + + for (s7_int 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) { +static bool scheme_strequal_ci(s7_pointer s1, s7_pointer s2) +{ /* same as scheme_strcmp -- watch out for unwanted sign! */ - const s7_int len = string_length (s1); - const s7_int len2= string_length (s2); + const s7_int len = string_length(s1); + const s7_int len2 = string_length(s2); const uint8_t *str1, *str2; - if (len != len2) return (false); - str1= (const uint8_t*) string_value (s1); - str2= (const uint8_t*) string_value (s2); - for (s7_int i= 0; i < len; i++) - if (uppers[(int32_t) str1[i]] != uppers[(int32_t) str2[i]]) return (false); - return (true); + if (len != len2) return(false); + str1 = (const uint8_t *)string_value(s1); + str2 = (const uint8_t *)string_value(s2); + for (s7_int i = 0; i < len; i++) + if (uppers[(int32_t)str1[i]] != uppers[(int32_t)str2[i]]) + return(false); + return(true); } -static s7_pointer -check_rest_are_strings (s7_scheme* sc, s7_pointer sym, s7_pointer x, - s7_pointer args) { - for (s7_pointer strs= x; is_pair (strs); strs= cdr (strs)) - if (!is_string_via_method (sc, car (strs))) - wrong_type_error_nr (sc, sym, position_of (strs, args), car (strs), - sc->type_names[T_STRING]); - return (sc->F); +static s7_pointer check_rest_are_strings(s7_scheme *sc, s7_pointer sym, s7_pointer x, s7_pointer args) +{ + for (s7_pointer strs = x; is_pair(strs); strs = cdr(strs)) + if (!is_string_via_method(sc, car(strs))) + wrong_type_error_nr(sc, sym, position_of(strs, args), car(strs), sc->type_names[T_STRING]); + return(sc->F); } #endif /* pure s7 */ -/* -------------------------------- string-fill! - * -------------------------------- */ - -#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) + +/* -------------------------------- string-fill! -------------------------------- */ + +#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) /* g_string_fill is now defined in s7_liii_string.c */ + /* -------------------------------- string -------------------------------- */ -const char* -s7_string (s7_pointer str) { - return (string_value (str)); -} +const char *s7_string(s7_pointer str) {return(string_value(str));} -s7_pointer -s7i_string_1 (s7_scheme* sc, s7_pointer args, s7_pointer sym) { - int32_t len; - s7_pointer chrs, newstr; - char* str; - const char* unicode_string_hint= - "string only accepts characters in range #x00..#xFF; use utf8-string for " - "Unicode characters"; +s7_pointer s7i_string_1(s7_scheme *sc, s7_pointer args, s7_pointer sym) +{ + int32_t len; + s7_pointer chrs, newstr; + char *str; + const char *unicode_string_hint = "string only accepts characters in range #x00..#xFF; use utf8-string for Unicode characters"; /* get length for new string and check arg types */ - for (len= 0, chrs= args; is_pair (chrs); len++, chrs= cdr (chrs)) { - const s7_pointer chr= car (chrs); - if (!is_character (chr)) { - if (has_active_methods (sc, chr)) { - const s7_pointer func= find_method_with_let (sc, chr, sym); - if (func != sc->undefined) { - s7_pointer ok_chrs; - if (len == 0) return (s7_apply_function (sc, func, args)); - newstr = make_empty_string (sc, len, '\0'); - str = string_value (newstr); - ok_chrs= args; - for (int32_t i= 0; ok_chrs != chrs; i++, ok_chrs= cdr (ok_chrs)) - str[i]= character (car (ok_chrs)); - return (s7i_string_append_1 ( - sc, set_plist_2 (sc, newstr, s7_apply_function (sc, func, chrs)), - sym)); - } - } - wrong_type_error_nr (sc, sym, len + 1, chr, sc->type_names[T_CHARACTER]); + for (len = 0, chrs = args; is_pair(chrs); len++, chrs = cdr(chrs)) + { + const s7_pointer chr = car(chrs); + if (!is_character(chr)) + { + if (has_active_methods(sc, chr)) + { + const s7_pointer func = find_method_with_let(sc, chr, sym); + if (func != sc->undefined) + { + s7_pointer ok_chrs; + if (len == 0) + return(s7_apply_function(sc, func, args)); + newstr = make_empty_string(sc, len, '\0'); + str = string_value(newstr); + ok_chrs = args; + for (int32_t i = 0; ok_chrs != chrs; i++, ok_chrs = cdr(ok_chrs)) + str[i] = character(car(ok_chrs)); + return(s7i_string_append_1(sc, set_plist_2(sc, newstr, s7_apply_function(sc, func, chrs)), sym)); + }} + wrong_type_error_nr(sc, sym, len + 1, chr, sc->type_names[T_CHARACTER]); + } + if (s7_character(chr) > 0xFF) + out_of_range_error_nr(sc, sym, wrap_integer(sc, len + 1), chr, + wrap_string(sc, unicode_string_hint, safe_strlen(unicode_string_hint))); } - if (s7_character (chr) > 0xFF) - out_of_range_error_nr (sc, sym, wrap_integer (sc, len + 1), chr, - wrap_string (sc, unicode_string_hint, - safe_strlen (unicode_string_hint))); - } if (len > sc->max_string_length) - error_nr (sc, sc->out_of_range_symbol, - set_elist_4 (sc, - wrap_string (sc, - "~S result string is too large (> ~D " - "~D) (*s7* 'max-string-length)", - 65), - sym, wrap_integer (sc, len), - wrap_integer (sc, sc->max_string_length))); - newstr= inline_make_empty_string (sc, len, '\0'); - str = string_value (newstr); - chrs = args; - for (int32_t i= 0; is_pair (chrs); i++, chrs= cdr (chrs)) - str[i]= character (car (chrs)); - return (newstr); -} - -#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) + error_nr(sc, sc->out_of_range_symbol, + set_elist_4(sc, wrap_string(sc, "~S result string is too large (> ~D ~D) (*s7* 'max-string-length)", 65), + sym, wrap_integer(sc, len), wrap_integer(sc, sc->max_string_length))); + newstr = inline_make_empty_string(sc, len, '\0'); + str = string_value(newstr); + chrs = args; + for (int32_t i = 0; is_pair(chrs); i++, chrs = cdr(chrs)) + str[i] = character(car(chrs)); + return(newstr); +} + +#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) /* g_string is now defined in s7_liii_string.c */ -s7_pointer -s7i_string_c1 (s7_scheme* sc, s7_pointer args) { - s7_pointer c= car (args), str; - const char* unicode_string_hint= - "string only accepts characters in range #x00..#xFF; use utf8-string for " - "Unicode characters"; +s7_pointer s7i_string_c1(s7_scheme *sc, s7_pointer args) +{ + s7_pointer c = car(args), str; + const char *unicode_string_hint = "string only accepts characters in range #x00..#xFF; use utf8-string for Unicode characters"; /* no multiple values here because no pairs below */ - if (!is_character (c)) - return (method_or_bust (sc, c, sc->string_symbol, args, - sc->type_names[T_CHARACTER], 1)); - if (s7_character (c) > 0xFF) - out_of_range_error_nr (sc, sc->string_symbol, int_one, c, - wrap_string (sc, unicode_string_hint, - safe_strlen (unicode_string_hint))); - 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 func, int32_t args, s7_pointer expr) { - return (((args == 1) && (!is_pair (cadr (expr)))) ? sc->string_c1 : func); -} - -static s7_pointer -string_p_p (s7_scheme* sc, s7_pointer c) { - s7_pointer str; - const char* unicode_string_hint= - "string only accepts characters in range #x00..#xFF; use utf8-string for " - "Unicode characters"; - if (!is_character (c)) - return (s7i_string_1 (sc, set_plist_1 (sc, c), sc->string_symbol)); - if (s7_character (c) > 0xFF) - out_of_range_error_nr (sc, sc->string_symbol, int_one, c, - wrap_string (sc, unicode_string_hint, - safe_strlen (unicode_string_hint))); - str = inline_make_empty_string (sc, 1, '\0'); - string_value (str)[0]= character (c); - return (str); -} - -/* -------------------------------- list->string - * -------------------------------- */ + if (!is_character(c)) + return(method_or_bust(sc, c, sc->string_symbol, args, sc->type_names[T_CHARACTER], 1)); + if (s7_character(c) > 0xFF) + out_of_range_error_nr(sc, sc->string_symbol, int_one, c, + wrap_string(sc, unicode_string_hint, safe_strlen(unicode_string_hint))); + 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 func, int32_t args, s7_pointer expr) +{ + return(((args == 1) && (!is_pair(cadr(expr)))) ? sc->string_c1 : func); +} + +/* string_p_p migrated to s7_liii_string.c */ + + +/* -------------------------------- list->string -------------------------------- */ #if !WITH_PURE_S7 -#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) +#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) /* g_list_to_string is now defined in s7_liii_string.c */ #endif -/* -------------------------------- string->list - * -------------------------------- */ -static s7_pointer -string_to_list (s7_scheme* sc, const char* str, s7_int len) { - if (len == 0) return (sc->nil); - check_free_heap_size (sc, len); - begin_temp (sc->y, sc->nil); - for (s7_int i= len - 1; i >= 0; i--) - sc->y= cons_unchecked (sc, chars[((uint8_t) str[i])], sc->y); - return_with_end_temp (sc->y); + +/* -------------------------------- string->list -------------------------------- */ +static s7_pointer string_to_list(s7_scheme *sc, const char *str, s7_int len) +{ + if (len == 0) + return(sc->nil); + check_free_heap_size(sc, len); + begin_temp(sc->y, sc->nil); + for (s7_int i = len - 1; i >= 0; i--) + sc->y = cons_unchecked(sc, chars[((uint8_t)str[i])], sc->y); + return_with_end_temp(sc->y); } #if !WITH_PURE_S7 -#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) +#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) /* g_string_to_list is now defined in s7_liii_string.c */ -static s7_pointer -string_to_list_p_p (s7_scheme* sc, s7_pointer str) { - s7_int len; - const uint8_t* val; - if (!is_string (str)) - return (sole_arg_method_or_bust (sc, str, sc->string_to_list_symbol, - set_plist_1 (sc, str), - sc->type_names[T_STRING])); - len= string_length (str); - if (len == 0) return (sc->nil); - if (len > sc->max_list_length) - error_nr (sc, sc->out_of_range_symbol, - set_elist_3 (sc, - wrap_string (sc, - "string->list length, ~D, is greater " - "than (*s7* 'max-list-length), ~D", - 68), - wrap_integer (sc, len), - wrap_integer (sc, sc->max_list_length))); - check_free_heap_size (sc, len); - val= (const uint8_t*) string_value (str); - { - s7_pointer result= sc->nil; - for (s7_int i= len - 1; i >= 0; i--) - result= cons_unchecked (sc, chars[val[i]], result); - return (result); - } -} +/* string_to_list_p_p migrated to s7_liii_string.c */ #endif -/* -------------------------------- port-closed? - * -------------------------------- */ + +/* -------------------------------- port-closed? -------------------------------- */ /* g_is_port_closed is now defined in s7_scheme_predicate.c */ -#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)) - -static bool -is_port_closed_b_7p (s7_scheme* sc, s7_pointer port) { - if ((is_input_port (port)) || (is_output_port (port))) - return (port_is_closed (port)); - if ((port == current_output_port (sc)) && (port == sc->F)) return (false); - return (method_or_bust_p (sc, port, sc->is_port_closed_symbol, - wrap_string (sc, "a port", 6)) != sc->F); -} - -/* -------------------------------- port-string -------------------------------- - */ -static s7_pointer -g_port_string (s7_scheme* sc, s7_pointer args) { -#define H_port_string "(port-string port) returns the port data as a string" -#define Q_port_string \ - s7_make_signature (sc, 2, sc->is_string_symbol, \ - s7_make_signature (sc, 2, sc->is_input_port_symbol, \ - sc->is_output_port_symbol)) - - const s7_pointer port= car (args); - if ((!is_input_port (port)) && (!is_output_port (port))) - return (method_or_bust_p (sc, port, sc->port_string_symbol, - wrap_string (sc, "a port", 6))); - if (!is_string_port (port)) - wrong_type_error_nr (sc, wrap_string (sc, "port-string", 11), 1, port, - wrap_string (sc, "a string port", 13)); - if ((port_is_closed (port)) || (is_function_port (port))) return (nil_string); - if (is_output_port (port)) - return ( - s7_output_string (sc, port)); /* both here and below we copy the data, - so the returned value can be mutated */ - return ( - make_string_with_length (sc, (const char*) port_data (port), - port_data_size (port))); /* max_string_length? */ -} - -static void -resize_string_port_data (s7_scheme* sc, s7_pointer port, s7_int new_size) { - const s7_int loc= port_data_size (port); - block_t* new_b; + #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)) + +static bool is_port_closed_b_7p(s7_scheme *sc, s7_pointer port) +{ + if ((is_input_port(port)) || (is_output_port(port))) + return(port_is_closed(port)); + if ((port == current_output_port(sc)) && (port == sc->F)) + return(false); + return(method_or_bust_p(sc, port, sc->is_port_closed_symbol, wrap_string(sc, "a port", 6)) != sc->F); +} + + +/* -------------------------------- port-string -------------------------------- */ +static s7_pointer g_port_string(s7_scheme *sc, s7_pointer args) +{ + #define H_port_string "(port-string port) returns the port data as a string" + #define Q_port_string s7_make_signature(sc, 2, sc->is_string_symbol, s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_output_port_symbol)) + + const s7_pointer port = car(args); + if ((!is_input_port(port)) && (!is_output_port(port))) + return(method_or_bust_p(sc, port, sc->port_string_symbol, wrap_string(sc, "a port", 6))); + if (!is_string_port(port)) + wrong_type_error_nr(sc, wrap_string(sc, "port-string", 11), 1, port, wrap_string(sc, "a string port", 13)); + if ((port_is_closed(port)) || (is_function_port(port))) + return(nil_string); + if (is_output_port(port)) + return(s7_output_string(sc, port)); /* both here and below we copy the data, so the returned value can be mutated */ + return(make_string_with_length(sc, (const char *)port_data(port), port_data_size(port))); /* max_string_length? */ +} + +static void resize_string_port_data(s7_scheme *sc, s7_pointer port, s7_int new_size) +{ + const s7_int loc = port_data_size(port); + block_t *new_b; if (new_size < loc) return; if (new_size > sc->max_string_port_length) - error_nr ( - sc, make_symbol (sc, "port-too-big", 12), - set_elist_3 (sc, - wrap_string (sc, - "string port length has grown past (*s7* " - "'max-string-port-length): ~D > ~D", - 73), - wrap_integer (sc, new_size), - wrap_integer (sc, sc->max_string_port_length))); - liberate (sc, - port_data_block (port)); /* reallocate has an irrelevant memcpy */ - new_b = inline_mallocate (sc, new_size); - port_data_block (port)= new_b; - port_data (port) = (uint8_t*) (block_data (new_b)); - port_data_size (port) = new_size; -} - -static s7_pointer -set_input_port_string ( - s7_scheme* sc, s7_pointer port, - s7_pointer str) { /*assume port is an input string port */ + error_nr(sc, make_symbol(sc, "port-too-big", 12), + set_elist_3(sc, wrap_string(sc, "string port length has grown past (*s7* 'max-string-port-length): ~D > ~D", 73), + wrap_integer(sc, new_size), + wrap_integer(sc, sc->max_string_port_length))); + liberate(sc, port_data_block(port)); /* reallocate has an irrelevant memcpy */ + new_b = inline_mallocate(sc, new_size); + port_data_block(port) = new_b; + port_data(port) = (uint8_t *)(block_data(new_b)); + port_data_size(port) = new_size; +} + + +static s7_pointer set_input_port_string(s7_scheme *sc, s7_pointer port, s7_pointer str) +{ /*assume port is an input string port */ s7_int str_len; - if ((S7_DEBUGGING) && ((!is_input_port (port)) || (!is_string_port (port)))) - fprintf (stderr, "%s[%d]: %s should be an input string port\n", __func__, - __LINE__, display (port)); - if (port_is_closed (port)) - wrong_type_error_nr (sc, wrap_string (sc, "set! port-string", 16), 1, port, - wrap_string (sc, "an open port", 12)); - str_len = string_length (str); - port_data (port) = (uint8_t*) string_value (str); - port_data (port)[str_len]= '\0'; - port_data_size (port) = str_len; - port_position (port) = 0; - port_set_string_or_function (port, str); - return (str); -} - -static s7_pointer -set_output_port_string ( - s7_scheme* sc, s7_pointer port, - s7_pointer str) { /*assume port is an output string port */ + if ((S7_DEBUGGING) && ((!is_input_port(port)) || (!is_string_port(port)))) + fprintf(stderr, "%s[%d]: %s should be an input string port\n", __func__, __LINE__, display(port)); + if (port_is_closed(port)) + wrong_type_error_nr(sc, wrap_string(sc, "set! port-string", 16), 1, port, wrap_string(sc, "an open port", 12)); + str_len = string_length(str); + port_data(port) = (uint8_t *)string_value(str); + port_data(port)[str_len] = '\0'; + port_data_size(port) = str_len; + port_position(port) = 0; + port_set_string_or_function(port, str); + return(str); +} + +static s7_pointer set_output_port_string(s7_scheme *sc, s7_pointer port, s7_pointer str) +{ /*assume port is an output string port */ s7_int str_len; - if ((S7_DEBUGGING) && ((!is_output_port (port)) || (!is_string_port (port)))) - fprintf (stderr, "%s[%d]: %s should be an output string port\n", __func__, - __LINE__, display (port)); - if (port_is_closed (port)) - wrong_type_error_nr (sc, wrap_string (sc, "set! port-string", 16), 1, port, - wrap_string (sc, "an open port", 12)); - str_len= string_length (str); - if (port_data_size (port) <= - str_len) /* sc->initial_string_port_length is 128 */ - resize_string_port_data (sc, port, str_len * 2); - memcpy ((void*) port_data (port), (const void*) string_value (str), str_len); - port_position (port) = str_len; - port_data (port)[str_len]= '\0'; - return (str); -} - -static s7_pointer -g_set_port_string (s7_scheme* sc, s7_pointer args) { - const s7_pointer port= car (args); - s7_pointer str; - if ((!is_input_port (port)) && (!is_output_port (port))) - wrong_type_error_nr (sc, wrap_string (sc, "set! port-string", 16), 1, port, - wrap_string (sc, "an input or output port", 23)); - if (!is_string_port (port)) - wrong_type_error_nr (sc, wrap_string (sc, "set! port-string", 16), 1, port, - wrap_string (sc, "a string port", 13)); - str= cadr (args); - if (!is_string (str)) - wrong_type_error_nr (sc, wrap_string (sc, "set! port-string", 16), 2, str, - sc->type_names[T_STRING]); - if (is_input_port (port)) set_input_port_string (sc, port, str); - else set_output_port_string (sc, port, str); - return (str); -} - -/* -------------------------------- 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) \ + if ((S7_DEBUGGING) && ((!is_output_port(port)) || (!is_string_port(port)))) + fprintf(stderr, "%s[%d]: %s should be an output string port\n", __func__, __LINE__, display(port)); + if (port_is_closed(port)) + wrong_type_error_nr(sc, wrap_string(sc, "set! port-string", 16), 1, port, wrap_string(sc, "an open port", 12)); + str_len = string_length(str); + if (port_data_size(port) <= str_len) /* sc->initial_string_port_length is 128 */ + resize_string_port_data(sc, port, str_len * 2); + memcpy((void *)port_data(port), (const void *)string_value(str), str_len); + port_position(port) = str_len; + port_data(port)[str_len] = '\0'; + return(str); +} + +static s7_pointer g_set_port_string(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer port = car(args); + s7_pointer str; + if ((!is_input_port(port)) && (!is_output_port(port))) + wrong_type_error_nr(sc, wrap_string(sc, "set! port-string", 16), 1, port, wrap_string(sc, "an input or output port", 23)); + if (!is_string_port(port)) + wrong_type_error_nr(sc, wrap_string(sc, "set! port-string", 16), 1, port, wrap_string(sc, "a string port", 13)); + str = cadr(args); + if (!is_string(str)) + wrong_type_error_nr(sc, wrap_string(sc, "set! port-string", 16), 2, str, sc->type_names[T_STRING]); + if (is_input_port(port)) + set_input_port_string(sc, port, str); + else set_output_port_string(sc, port, str); + return(str); +} + + +/* -------------------------------- 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) - - const s7_pointer port= car (args); - if (!is_input_port (port)) - return (method_or_bust_p (sc, port, sc->port_position_symbol, - sc->type_names[T_INPUT_PORT])); - if (port_is_closed (port)) - sole_arg_wrong_type_error_nr (sc, sc->port_position_symbol, port, - an_open_input_port_string); - if (is_string_port (port)) return (make_integer (sc, port_position (port))); + #define Q_port_position s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_input_port_symbol) + + const s7_pointer port = car(args); + if (!is_input_port(port)) + return(method_or_bust_p(sc, port, sc->port_position_symbol, sc->type_names[T_INPUT_PORT])); + if (port_is_closed(port)) + sole_arg_wrong_type_error_nr(sc, sc->port_position_symbol, port, an_open_input_port_string); + 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)))); + 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) { - const s7_pointer port= car (args); - s7_pointer pos; - s7_int position; - - if (!is_input_port (port)) - wrong_type_error_nr (sc, wrap_string (sc, "set! port-position", 18), 1, - port, an_input_port_string); - if (port_is_closed (port)) - wrong_type_error_nr (sc, wrap_string (sc, "set! port-position", 18), 1, - port, an_open_input_port_string); - - pos= cadr (args); - if (!is_t_integer (pos)) - wrong_type_error_nr (sc, wrap_string (sc, "set! port-position", 18), 2, pos, - sc->type_names[T_INTEGER]); - position= s7_integer_clamped_if_gmp (sc, pos); + return(int_zero); +} + +static s7_pointer g_set_port_position(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer port = car(args); + s7_pointer pos; + s7_int position; + + if (!is_input_port(port)) + wrong_type_error_nr(sc, wrap_string(sc, "set! port-position", 18), 1, port, an_input_port_string); + if (port_is_closed(port)) + wrong_type_error_nr(sc, wrap_string(sc, "set! port-position", 18), 1, port, an_open_input_port_string); + + pos = cadr(args); + if (!is_t_integer(pos)) + wrong_type_error_nr(sc, wrap_string(sc, "set! port-position", 18), 2, pos, sc->type_names[T_INTEGER]); + position = s7_integer_clamped_if_gmp(sc, pos); if (position < 0) - out_of_range_error_nr (sc, sc->port_position_symbol, int_two, pos, - it_is_negative_string); - if (is_string_port (port)) - port_position (port)= - (position > port_data_size (port)) ? port_data_size (port) : position; + out_of_range_error_nr(sc, sc->port_position_symbol, int_two, pos, it_is_negative_string); + if (is_string_port(port)) + port_position(port) = (position > port_data_size(port)) ? port_data_size(port) : position; #if !MS_WINDOWS - else if (is_file_port (port)) { - rewind (port_file (port)); - fseek (port_file (port), (long) position, SEEK_SET); - } + else + if (is_file_port(port)) + { + rewind(port_file(port)); + fseek(port_file(port), (long)position, SEEK_SET); + } #endif - return (pos); + 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)) - - const s7_pointer port= car (args); - if ((!is_input_port (port)) && (!is_output_port (port))) - return (method_or_bust_p (sc, port, sc->port_file_symbol, - wrap_string (sc, "a port", 6))); - if (port_is_closed (port)) - sole_arg_wrong_type_error_nr (sc, sc->port_file_symbol, port, - wrap_string (sc, "an open port", 12)); + +/* -------------------------------- 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)) + + const s7_pointer port = car(args); + if ((!is_input_port(port)) && (!is_output_port(port))) + return(method_or_bust_p(sc, port, sc->port_file_symbol, wrap_string(sc, "a port", 6))); + if (port_is_closed(port)) + sole_arg_wrong_type_error_nr(sc, sc->port_file_symbol, port, wrap_string(sc, "an open port", 12)); #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)); + 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)); + 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)) /* used to check port_is_closed? */ - return (method_or_bust_p (sc, x, sc->port_line_number_symbol, - an_input_port_string)); - return (make_integer (sc, port_line_number (x))); + +/* -------------------------------- port-line-number -------------------------------- */ +static s7_pointer port_line_number_p_p(s7_scheme *sc, s7_pointer x) +{ + if (!is_input_port(x)) /* used to check port_is_closed? */ + return(method_or_bust_p(sc, x, sc->port_line_number_symbol, an_input_port_string)); + return(make_integer(sc, port_line_number(x))); } /* g_port_line_number is now defined in s7_scheme_predicate.c */ -#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) - -s7_int -s7_port_line_number (s7_scheme* sc, s7_pointer p) { - if (!is_input_port (p)) - sole_arg_wrong_type_error_nr (sc, sc->port_line_number_symbol, p, - sc->type_names[T_INPUT_PORT]); - return (port_line_number (p)); -} - -static s7_pointer -g_set_port_line_number (s7_scheme* sc, s7_pointer args) { - s7_pointer port, line; - if ((is_null (car (args))) || - ((is_null (cdr (args))) && (is_t_integer (car (args))))) - port= current_input_port (sc); - else { - port= car (args); - if (!is_input_port (port)) - wrong_type_error_nr (sc, wrap_string (sc, "set! port-line-number", 21), 1, - port, an_input_port_string); - } - line= (is_null (cdr (args)) ? car (args) : cadr (args)); - if (!is_t_integer (line)) - wrong_type_error_nr (sc, wrap_string (sc, "set! port-line-number", 21), 2, - line, sc->type_names[T_INTEGER]); - port_line_number (port)= integer (line); - return (line); -} - -/* -------------------------------- port-filename - * -------------------------------- */ -const char* -s7_port_filename (s7_scheme* sc, s7_pointer port) { - if (((is_input_port (port)) || (is_output_port (port))) && - (!port_is_closed (port))) - return (port_filename (port)); - return (NULL); -} - -static s7_pointer -port_filename_p_p (s7_scheme* sc, s7_pointer port) { - if (((is_input_port (port)) || (is_output_port (port))) && - (!port_is_closed (port))) { - if (port_filename (port)) { - if (port_filename_length (port) > sc->max_string_length) - error_nr (sc, sc->out_of_range_symbol, - set_elist_3 (sc, - wrap_string (sc, - "port-filename is too long (> ~D " - "~D) (*s7* 'max-string-length)", - 61), - wrap_integer (sc, port_filename_length (port)), - wrap_integer (sc, sc->max_string_length))); - return (make_string_with_length ( - sc, port_filename (port), - port_filename_length (port))); /* not wrapper here! */ - } - return (nil_string); - /* otherwise (eval-string (port-filename)) and (string->symbol - * (port-filename)) segfault */ - } - return (method_or_bust_p (sc, port, sc->port_filename_symbol, - wrap_string (sc, "an open port", 12))); +#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) + +s7_int s7_port_line_number(s7_scheme *sc, s7_pointer p) +{ + if (!is_input_port(p)) + sole_arg_wrong_type_error_nr(sc, sc->port_line_number_symbol, p, sc->type_names[T_INPUT_PORT]); + return(port_line_number(p)); } -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))); +static s7_pointer g_set_port_line_number(s7_scheme *sc, s7_pointer args) +{ + s7_pointer port, line; + if ((is_null(car(args))) || + ((is_null(cdr(args))) && (is_t_integer(car(args))))) + port = current_input_port(sc); + else + { + port = car(args); + if (!is_input_port(port)) + wrong_type_error_nr(sc, wrap_string(sc, "set! port-line-number", 21), 1, port, an_input_port_string); + } + line = (is_null(cdr(args)) ? car(args) : cadr(args)); + if (!is_t_integer(line)) + wrong_type_error_nr(sc, wrap_string(sc, "set! port-line-number", 21), 2, line, sc->type_names[T_INTEGER]); + port_line_number(port) = integer(line); + return(line); } -/* -------------------------------- 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_p (sc, p, sc->pair_line_number_symbol, - sc->type_names[T_PAIR])); - return ((has_location (p)) ? make_integer (sc, pair_line_number (p)) : sc->F); + +/* -------------------------------- port-filename -------------------------------- */ +const char *s7_port_filename(s7_scheme *sc, s7_pointer port) +{ + if (((is_input_port(port)) || (is_output_port(port))) && + (!port_is_closed(port))) + return(port_filename(port)); + return(NULL); } -/* g_pair_line_number is now defined in s7_scheme_predicate.c */ -#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) - -/* -------------------------------- 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) - - const 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 */ - if_method_exists_return_value (sc, p, sc->pair_filename_symbol, args); - sole_arg_wrong_type_error_nr (sc, sc->pair_filename_symbol, p, - sc->type_names[T_PAIR]); - return (NULL); -} - -/* -------------------------------- input-port? -------------------------------- - */ -bool -s7_is_input_port (s7_scheme* sc, s7_pointer p) { - return (is_input_port (p)); +static s7_pointer port_filename_p_p(s7_scheme *sc, s7_pointer port) +{ + if (((is_input_port(port)) || (is_output_port(port))) && + (!port_is_closed(port))) + { + if (port_filename(port)) + { + if (port_filename_length(port) > sc->max_string_length) + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "port-filename is too long (> ~D ~D) (*s7* 'max-string-length)", 61), + wrap_integer(sc, port_filename_length(port)), wrap_integer(sc, sc->max_string_length))); + return(make_string_with_length(sc, port_filename(port), port_filename_length(port))); /* not wrapper here! */ + } + return(nil_string); + /* otherwise (eval-string (port-filename)) and (string->symbol (port-filename)) segfault */ + } + return(method_or_bust_p(sc, port, sc->port_filename_symbol, wrap_string(sc, "an open port", 12))); } -static bool -is_input_port_b (s7_pointer p) { - return (is_input_port (p)); + +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))); } -/* g_is_input_port is now defined in s7_scheme_predicate.c */ -#define H_is_input_port "(input-port? p) returns #t if p is an input port" -#define Q_is_input_port sc->pl_bt -/* -------------------------------- 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)); +/* -------------------------------- 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_p(sc, p, sc->pair_line_number_symbol, sc->type_names[T_PAIR])); + return((has_location(p)) ? make_integer(sc, pair_line_number(p)) : sc->F); } -/* g_is_output_port is now defined in s7_scheme_predicate.c */ -#define H_is_output_port "(output-port? p) returns #t if p is an output port" -#define Q_is_output_port sc->pl_bt - -/* -------------------------------- current-input-port - * -------------------------------- */ -#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) -s7_pointer -s7_current_input_port (s7_scheme* sc) { - 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) - - const 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 { - if_method_exists_return_value (sc, port, sc->set_current_input_port_symbol, - args); - sole_arg_wrong_type_error_nr (sc, sc->set_current_input_port_symbol, port, - an_open_input_port_string); - } - 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 - * -------------------------------- */ -#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)) -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_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)) - const s7_pointer port = car (args); - const s7_pointer 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 { - if_method_exists_return_value (sc, port, sc->set_current_output_port_symbol, - args); - sole_arg_wrong_type_error_nr (sc, sc->set_current_output_port_symbol, port, - an_output_port_or_f_string); - } - return (old_port); -} - -/* -------------------------------- current-error-port - * -------------------------------- */ -#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)) -s7_pointer -s7_current_error_port (s7_scheme* sc) { - return (current_error_port (sc)); -} - -s7_pointer -s7_set_current_error_port (s7_scheme* sc, s7_pointer port) { - s7_pointer old_port= current_error_port (sc); - set_current_error_port (sc, port); - return (old_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)) - const s7_pointer port = car (args); - const s7_pointer old_port= current_error_port (sc); - if (((is_output_port (port)) && (!port_is_closed (port))) || (port == sc->F)) - set_current_error_port (sc, port); - else { - if_method_exists_return_value (sc, port, sc->set_current_error_port_symbol, - args); - sole_arg_wrong_type_error_nr (sc, sc->set_current_error_port_symbol, port, - an_output_port_or_f_string); - } - return (old_port); -} +/* g_pair_line_number is now defined in s7_scheme_predicate.c */ +#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) -/* -------------------------------- 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 port; - if (is_null (args)) - return (make_boolean (sc, (is_input_port (current_input_port (sc))) && - (is_string_port (current_input_port (sc))))); - port= car (args); - if (!is_input_port (port)) - return (method_or_bust_p (sc, port, sc->is_char_ready_symbol, - an_input_port_string)); - if (port_is_closed (port)) - sole_arg_wrong_type_error_nr (sc, sc->is_char_ready_symbol, port, - an_open_input_port_string); - if (!is_function_port (port)) - return (make_boolean (sc, is_string_port (port))); - { - s7_pointer result= - (*(port_input_function (port))) (sc, S7_IS_CHAR_READY, port); - if (is_multiple_value (result)) { - clear_multiple_value (result); - error_nr (sc, sc->bad_result_symbol, - set_elist_2 ( - sc, - wrap_string ( - sc, "input-function-port char-ready? returned: ~S", 44), - result)); - } - return (make_boolean ( - sc, (result != sc->F))); /* char-ready? returns a boolean */ - } -} -#endif +/* -------------------------------- 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) -/* -------- 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 port) { - if (port_filename ( - port)) /* for string ports, this is the original input file name */ - { - liberate (sc, port_filename_block (port)); - port_filename (port)= NULL; - } - if (port_file (port)) { - fclose (port_file (port)); - port_file (port)= NULL; - } - if (port_needs_free (port)) free_port_data (sc, port); - port_port (port)->pf= &closed_port_functions; - port_set_closed (port, true); - port_position (port)= 0; + const 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 */ + if_method_exists_return_value(sc, p, sc->pair_filename_symbol, args); + sole_arg_wrong_type_error_nr(sc, sc->pair_filename_symbol, p, sc->type_names[T_PAIR]); + return(NULL); } -static void -close_input_string (s7_scheme* sc, s7_pointer port) { - if (port_filename ( - port)) /* for string ports, this is the original input file name */ - { - liberate (sc, port_filename_block (port)); - port_filename (port)= NULL; - } - if (port_needs_free (port)) free_port_data (sc, port); - port_port (port)->pf= &closed_port_functions; - port_set_closed (port, true); - port_position (port)= 0; -} -static void -close_simple_input_string (s7_scheme* sc, s7_pointer port) { -#if S7_DEBUGGING - if (port_filename (port)) - fprintf (stderr, "%s: port has a filename\n", __func__); - if (port_needs_free (port)) - fprintf (stderr, "%s: port needs free\n", __func__); -#endif - port_port (port)->pf= &closed_port_functions; - port_set_closed (port, true); - port_position (port)= 0; -} - -void -s7_close_input_port (s7_scheme* sc, s7_pointer port) { - port_close (port) (sc, port); -} - -/* -------------------------------- 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) - - const s7_pointer port= car (args); - if (!is_input_port (port)) - return (method_or_bust_p (sc, port, sc->close_input_port_symbol, - an_input_port_string)); - if ((!is_immutable_port (port)) && /* (close-input-port *stdin*) */ - (!is_loader_port ( - port))) /* top-level unmatched (close-input-port (current-input-port)) - should not clobber the loader's input port */ - s7_close_input_port (sc, port); - return (sc->unspecified); -} - -/* -------------------------------- flush-output-port - * -------------------------------- */ -static no_return void -file_error_nr (s7_scheme* sc, const char* caller, const char* descr, - const char* name) { - error_nr (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))); -} - -bool -s7_flush_output_port (s7_scheme* sc, s7_pointer port) { - bool result= true; - if ((is_output_port (port)) && /* type=T_OUTPUT_PORT, so this excludes #f */ - (is_file_port (port)) && (!port_is_closed (port)) && (port_file (port))) { - if (port_position (port) > 0) { - result= (fwrite ((void*) (port_data (port)), 1, port_position (port), - port_file (port)) == (size_t) port_position (port)); - port_position (port)= 0; - } - if (fflush (port_file (port)) == -1) - file_error_nr (sc, "flush-output-port", strerror (errno), - port_filename (port)); - } - 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)) - - const s7_pointer port= - (is_null (args)) ? current_output_port (sc) : car (args); - if (!is_output_port (port)) { - if (port == sc->F) return (port); - if_method_exists_return_value (sc, port, sc->flush_output_port_symbol, - args); - sole_arg_wrong_type_error_nr (sc, sc->flush_output_port_symbol, port, - an_output_port_or_f_string); - } - if (!s7_flush_output_port (sc, port)) - error_nr (sc, sc->io_error_symbol, - set_elist_2 (sc, - wrap_string (sc, "flush-output-port ~S failed", 27), - port)); - return (port); -} - -/* -------------------------------- close-output-port - * -------------------------------- */ -static void -close_output_file (s7_scheme* sc, s7_pointer port) { - if (port_filename (port)) /* only a file output port has a filename(?) */ - { - /* type(port) might be T_FREE -- this is called in sweep if port is - * free_and_clear */ - if ((S7_DEBUGGING) && (!is_free (port)) && - ((!is_output_port (port)) || (!is_file_port (port)))) - fprintf (stderr, "%s[%d]: unexpected port\n", __func__, __LINE__); - liberate (sc, port_filename_block (port)); - port_filename (port) = NULL; - port_filename_length (port)= 0; - } - if (port_file (port)) { -#if WITH_WARNINGS - if ((port_position (port) > 0) && - (fwrite ((void*) (port_data (port)), 1, port_position (port), - port_file (port)) != (size_t) port_position (port))) - s7_warn (sc, 64, "fwrite trouble in close-output-port\n"); -#else - if (port_position (port) > 0) - fwrite ((void*) (port_data (port)), 1, port_position (port), - port_file (port)); -#endif - if (fflush (port_file (port)) == -1) - s7_warn (sc, 64, "fflush in close-output-port: %s\n", strerror (errno)); - fclose (port_file (port)); - port_file (port)= NULL; - } - port_port (port)->pf= &closed_port_functions; - port_set_closed (port, true); - port_position (port)= 0; -} +/* -------------------------------- 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 void -close_output_string (s7_scheme* sc, s7_pointer port) { - if (port_data (port)) { - port_data (port) = NULL; - port_data_size (port)= 0; - } - port_port (port)->pf= &closed_port_functions; - port_set_closed (port, true); - port_position (port)= 0; -} - -static void -close_output_port (s7_scheme* sc, s7_pointer port) { - port_close (port) (sc, port); -} - -void -s7_close_output_port (s7_scheme* sc, s7_pointer port) { - if ((port == sc->F) || (is_immutable_port (port))) - return; /* can these happen? */ - close_output_port (sc, port); -} - -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)) - - const s7_pointer port= car (args); - if (!is_output_port (port)) { - if (port == sc->F) return (sc->unspecified); - if_method_exists_return_value (sc, port, sc->close_output_port_symbol, - args); - sole_arg_wrong_type_error_nr (sc, sc->close_output_port_symbol, port, - an_output_port_or_f_string); - } - s7_close_output_port (sc, port); - return (sc->unspecified); -} +/* g_is_input_port is now defined in s7_scheme_predicate.c */ + #define H_is_input_port "(input-port? p) returns #t if p is an input port" + #define Q_is_input_port sc->pl_bt -/* -------- read character functions -------- */ -static int32_t -file_read_char (s7_scheme* sc, s7_pointer port) { - int32_t c= fgetc (port_file (port)); - if ((c == (int32_t) '\n') && (!is_loader_port (port))) - port_line_number (port)++; - return (c); -} +/* -------------------------------- 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 int32_t -function_read_char (s7_scheme* sc, s7_pointer port) { - const s7_pointer result= - (*(port_input_function (port))) (sc, S7_READ_CHAR, port); - if (is_eof (result)) return (EOF); - if (!is_character ( - result)) /* port_input_function might return some non-character */ - { - if (is_multiple_value (result)) { - clear_multiple_value (result); - error_nr (sc, sc->bad_result_symbol, - set_elist_2 ( - sc, - wrap_string ( - sc, "input-function-port read-char returned: ~S", 42), - result)); - } - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_2 ( - sc, - wrap_string (sc, "input-function-port read-char returned: ~S", 42), - result)); - } - return ((int32_t) character ( - result)); /* kinda nutty -- we return chars[this] in g_read_char! */ -} +/* g_is_output_port is now defined in s7_scheme_predicate.c */ + #define H_is_output_port "(output-port? p) returns #t if p is an output port" + #define Q_is_output_port sc->pl_bt -static int32_t -string_read_char (s7_scheme* sc, s7_pointer port) { - uint8_t c; - if (port_data_size (port) <= port_position (port)) return (EOF); - c= (uint8_t) port_data ( - port)[port_position (port)++]; /* port_string_length is 0 if no port - string, port_data is uint8_t* */ - if ((c == (uint8_t) '\n') && (!is_loader_port (port))) - port_line_number (port)++; - return (c); -} -static int32_t -output_read_char (s7_scheme* sc, s7_pointer port) /* not reachable I think */ +/* -------------------------------- current-input-port -------------------------------- */ +#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) +s7_pointer s7_current_input_port(s7_scheme *sc) {return(current_input_port(sc));} + +static s7_pointer g_set_current_input_port(s7_scheme *sc, s7_pointer args) { - sole_arg_wrong_type_error_nr (sc, sc->read_char_symbol, port, - an_input_port_string); - return (0); -} + #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) -static int32_t -closed_port_read_char (s7_scheme* sc, s7_pointer port) { - sole_arg_wrong_type_error_nr (sc, sc->read_char_symbol, port, - an_open_input_port_string); - return (0); + const 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 + { + if_method_exists_return_value(sc, port, sc->set_current_input_port_symbol, args); + sole_arg_wrong_type_error_nr(sc, sc->set_current_input_port_symbol, port, an_open_input_port_string); + } + return(old_port); } -/* -------- read line functions -------- */ - -static s7_pointer -output_read_line (s7_scheme* sc, s7_pointer port, - bool with_eol) /* not reachable I think */ +s7_pointer s7_set_current_input_port(s7_scheme *sc, s7_pointer port) { - sole_arg_wrong_type_error_nr (sc, sc->read_line_symbol, port, - an_input_port_string); - return (NULL); + s7_pointer old_port = current_input_port(sc); + set_current_input_port(sc, port); + return(old_port); } -static s7_pointer -closed_port_read_line (s7_scheme* sc, s7_pointer port, bool with_eol) { - sole_arg_wrong_type_error_nr (sc, sc->read_line_symbol, port, - an_open_input_port_string); - return (NULL); -} -static s7_pointer -function_read_line (s7_scheme* sc, s7_pointer port, bool with_eol) { - s7_pointer result= (*(port_input_function (port))) (sc, S7_READ_LINE, port); - if (is_multiple_value (result)) { - clear_multiple_value (result); - error_nr ( - sc, sc->bad_result_symbol, - set_elist_2 ( - sc, - wrap_string (sc, "input-function-port read-line returned: ~S", 42), - result)); - } - return (result); -} +/* -------------------------------- current-output-port -------------------------------- */ +#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)) +s7_pointer s7_current_output_port(s7_scheme *sc) {return(current_output_port(sc));} -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 (eof_object); +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 -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; - const char* 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 (inline_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; - const char* port_str = (const char*) port_data (port); - const s7_int port_start= port_position (port); - const char* start = port_str + port_start; - const char* cur = (const char*) strchr ( - start, (int) '\n'); /* this can run off the end making valgrind unhappy, - but I think it's innocuous */ - if (cur) { - s7_int len; - port_line_number (port)++; - i = cur - port_str; - port_position (port)= i + 1; - len = ((with_eol) ? i + 1 : i) - port_start; - if (len == 0) return (nil_string); - return (inline_make_string_with_length (sc, start, len)); - } - 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 (make_string_with_length (sc, start, i - port_start)); + +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)) + const s7_pointer port = car(args); + const s7_pointer 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 + { + if_method_exists_return_value(sc, port, sc->set_current_output_port_symbol, args); + sole_arg_wrong_type_error_nr(sc, sc->set_current_output_port_symbol, port, an_output_port_or_f_string); + } + return(old_port); } -/* -------- write character functions -------- */ -static void -resize_port_data (s7_scheme* sc, s7_pointer port, s7_int new_size) { - const s7_int loc= port_data_size (port); - block_t* new_b; - if (new_size < loc) return; - if (new_size > sc->max_string_port_length) - error_nr ( - sc, make_symbol (sc, "port-too-big", 12), - set_elist_3 (sc, - wrap_string (sc, - "string port length has grown past (*s7* " - "'max-string-port-length): ~D > ~D", - 73), - wrap_integer (sc, new_size), - wrap_integer (sc, sc->max_string_port_length))); - new_b = reallocate (sc, port_data_block (port), new_size); - port_data_block (port)= new_b; - port_data (port) = (uint8_t*) (block_data (new_b)); - port_data_size (port) = new_size; -} - -static void -string_write_char_resized (s7_scheme* sc, uint8_t c, s7_pointer port) { - /* this division looks repetitive, but it is much faster */ - resize_port_data (sc, port, port_data_size (port) * 2); - port_data (port)[port_position (port)++]= c; -} +/* -------------------------------- current-error-port -------------------------------- */ +#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)) +s7_pointer s7_current_error_port(s7_scheme *sc) {return(current_error_port(sc));} -static void -string_write_char (s7_scheme* sc, uint8_t c, s7_pointer port) { - if (port_position (port) < port_data_size (port)) - port_data (port)[port_position (port)++]= c; - else string_write_char_resized (sc, c, port); +s7_pointer s7_set_current_error_port(s7_scheme *sc, s7_pointer port) +{ + s7_pointer old_port = current_error_port(sc); + set_current_error_port(sc, port); + return(old_port); } -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 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)) + const s7_pointer port = car(args); + const s7_pointer old_port = current_error_port(sc); + if (((is_output_port(port)) && + (!port_is_closed(port))) || + (port == sc->F)) + set_current_error_port(sc, port); + else + { + if_method_exists_return_value(sc, port, sc->set_current_error_port_symbol, args); + sole_arg_wrong_type_error_nr(sc, sc->set_current_error_port_symbol, port, an_output_port_or_f_string); + } + return(old_port); } -static void -function_write_char (s7_scheme* sc, uint8_t c, s7_pointer port) { - push_stack_direct (sc, OP_NO_VALUES); - /* sc->args = sc->nil; */ - (*(port_output_function (port))) (sc, c, port); - unstack_with (sc, OP_NO_VALUES); - memcpy ((void*) sc, (void*) (sc->stack_end), - 3 * sizeof (s7_pointer)); /* code/let/args */ -} -#ifndef OUTPUT_FILE_PORT_LENGTH -#define OUTPUT_FILE_PORT_LENGTH 2048 -#endif +/* -------------------------------- 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 port; -static Inline void -inline_file_write_char (s7_scheme* sc, uint8_t c, s7_pointer port) { - if (port_position (port) == sc->output_file_port_length) { - fwrite ((void*) (port_data (port)), 1, sc->output_file_port_length, - port_file (port)); - port_position (port)= 0; + if (is_null(args)) + return(make_boolean(sc, (is_input_port(current_input_port(sc))) && (is_string_port(current_input_port(sc))))); + port = car(args); + if (!is_input_port(port)) + return(method_or_bust_p(sc, port, sc->is_char_ready_symbol, an_input_port_string)); + if (port_is_closed(port)) + sole_arg_wrong_type_error_nr(sc, sc->is_char_ready_symbol, port, an_open_input_port_string); + if (!is_function_port(port)) + return(make_boolean(sc, is_string_port(port))); + { + s7_pointer result = (*(port_input_function(port)))(sc, S7_IS_CHAR_READY, port); + if (is_multiple_value(result)) + { + clear_multiple_value(result); + error_nr(sc, sc->bad_result_symbol, set_elist_2(sc, wrap_string(sc, "input-function-port char-ready? returned: ~S", 44), result)); + } + return(make_boolean(sc, (result != sc->F))); /* char-ready? returns a boolean */ } - port_data (port)[port_position (port)++]= c; } +#endif -static void -file_write_char (s7_scheme* sc, uint8_t c, s7_pointer port) { - inline_file_write_char (sc, c, port); -} +/* -------- ports -------- */ +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 -input_write_char (s7_scheme* sc, uint8_t c, - s7_pointer port) /* not reachable I think */ -{ - sole_arg_wrong_type_error_nr (sc, sc->write_char_symbol, port, - an_output_port_string); -} +static void close_closed_port(s7_scheme *sc, s7_pointer port) {return;} -static void -closed_port_write_char (s7_scheme* sc, uint8_t c, s7_pointer port) { - sole_arg_wrong_type_error_nr (sc, sc->write_char_symbol, port, - an_open_output_port_string); -} +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}; -/* -------- write string functions -------- */ -static void -input_write_string (s7_scheme* sc, const char* str, s7_int len, - s7_pointer port) { - sole_arg_wrong_type_error_nr (sc, sc->write_symbol, port, - an_output_port_string); +static void close_input_file(s7_scheme *sc, s7_pointer port) +{ + if (port_filename(port)) /* for string ports, this is the original input file name */ + { + liberate(sc, port_filename_block(port)); + port_filename(port) = NULL; + } + if (port_file(port)) + { + fclose(port_file(port)); + port_file(port) = NULL; + } + if (port_needs_free(port)) + free_port_data(sc, port); + port_port(port)->pf = &closed_port_functions; + port_set_closed(port, true); + port_position(port) = 0; } -static void -closed_port_write_string (s7_scheme* sc, const char* str, s7_int len, - s7_pointer port) { - sole_arg_wrong_type_error_nr (sc, sc->write_symbol, port, - an_open_output_port_string); +static void close_input_string(s7_scheme *sc, s7_pointer port) +{ + if (port_filename(port)) /* for string ports, this is the original input file name */ + { + liberate(sc, port_filename_block(port)); + port_filename(port) = NULL; + } + if (port_needs_free(port)) + free_port_data(sc, port); + port_port(port)->pf = &closed_port_functions; + port_set_closed(port, true); + port_position(port) = 0; } -static void -input_display (s7_scheme* sc, const char* s, s7_pointer port) { - sole_arg_wrong_type_error_nr (sc, sc->display_symbol, port, - an_output_port_string); +static void close_simple_input_string(s7_scheme *sc, s7_pointer port) +{ +#if S7_DEBUGGING + if (port_filename(port)) fprintf(stderr, "%s: port has a filename\n", __func__); + if (port_needs_free(port)) fprintf(stderr, "%s: port needs free\n", __func__); +#endif + port_port(port)->pf = &closed_port_functions; + port_set_closed(port, true); + port_position(port) = 0; } -static void -closed_port_display (s7_scheme* sc, const char* s, s7_pointer port) { - sole_arg_wrong_type_error_nr (sc, sc->display_symbol, port, - an_open_output_port_string); -} +void s7_close_input_port(s7_scheme *sc, s7_pointer port) {port_close(port)(sc, port);} -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 - for (s7_int i= 0; i < len; i++) - fputc (str[i], stdout); + +/* -------------------------------- 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) + + const s7_pointer port = car(args); + if (!is_input_port(port)) + return(method_or_bust_p(sc, port, sc->close_input_port_symbol, an_input_port_string)); + if ((!is_immutable_port(port)) && /* (close-input-port *stdin*) */ + (!is_loader_port(port))) /* top-level unmatched (close-input-port (current-input-port)) should not clobber the loader's input port */ + s7_close_input_port(sc, port); + return(sc->unspecified); } -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 - for (s7_int 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 port) { - s7_int new_len= - port_position (port) + - len; /* len is known to be non-zero, str might not be 0-terminated */ - resize_port_data (sc, port, new_len * 2); - memcpy ((void*) (port_data (port) + port_position (port)), (const void*) str, - len); - port_position (port)= new_len; -} - -static void -string_write_string (s7_scheme* sc, const char* str, s7_int len, - s7_pointer port) { - if ((S7_DEBUGGING) && (len == 0)) { - fprintf (stderr, "string_write_string len == 0\n"); - abort (); - } - if (port_position (port) + len < port_data_size (port)) { - memcpy ((void*) (port_data (port) + port_position (port)), - (const 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 (port)+= len; - } - else string_write_string_resized (sc, str, len, port); + +/* -------------------------------- flush-output-port -------------------------------- */ +static no_return void file_error_nr(s7_scheme *sc, const char *caller, const char *descr, const char *name) +{ + error_nr(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))); } -static void -file_write_string (s7_scheme* sc, const char* str, s7_int len, - s7_pointer port) { - const s7_int new_len= port_position (port) + len; - if (new_len >= sc->output_file_port_length) { - 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 write-string\n"); -#else - fwrite ((void*) (port_data (port)), 1, port_position (port), - port_file (port)); -#endif - port_position (port)= 0; +bool s7_flush_output_port(s7_scheme *sc, s7_pointer port) +{ + bool result = true; + if ((is_output_port(port)) && /* type=T_OUTPUT_PORT, so this excludes #f */ + (is_file_port(port)) && + (!port_is_closed(port)) && + (port_file(port))) + { + if (port_position(port) > 0) + { + result = (fwrite((void *)(port_data(port)), 1, port_position(port), port_file(port)) == (size_t)port_position(port)); + port_position(port) = 0; + } + if (fflush(port_file(port)) == -1) + file_error_nr(sc, "flush-output-port", strerror(errno), port_filename(port)); } - fwrite ((const void*) str, 1, len, port_file (port)); - } - else { - memcpy ((void*) (port_data (port) + port_position (port)), - (const void*) str, len); - port_position (port)= new_len; - } + return(result); } -static void -string_display (s7_scheme* sc, const char* str, s7_pointer port) { - if (str) string_write_string (sc, str, safe_strlen (str), port); +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)) + + const s7_pointer port = (is_null(args)) ? current_output_port(sc) : car(args); + if (!is_output_port(port)) + { + if (port == sc->F) return(port); + if_method_exists_return_value(sc, port, sc->flush_output_port_symbol, args); + sole_arg_wrong_type_error_nr(sc, sc->flush_output_port_symbol, port, an_output_port_or_f_string); + } + if (!s7_flush_output_port(sc, port)) + error_nr(sc, sc->io_error_symbol, set_elist_2(sc, wrap_string(sc, "flush-output-port ~S failed", 27), port)); + return(port); } -static void -file_display (s7_scheme* sc, const char* str, s7_pointer port) { - if (str) { - if (port_position (port) > 0) { + +/* -------------------------------- close-output-port -------------------------------- */ +static void close_output_file(s7_scheme *sc, s7_pointer port) +{ + if (port_filename(port)) /* only a file output port has a filename(?) */ + { + /* type(port) might be T_FREE -- this is called in sweep if port is free_and_clear */ + if ((S7_DEBUGGING) && (!is_free(port)) && ((!is_output_port(port)) || (!is_file_port(port)))) + fprintf(stderr, "%s[%d]: unexpected port\n", __func__, __LINE__); + liberate(sc, port_filename_block(port)); + port_filename(port) = NULL; + port_filename_length(port) = 0; + } + if (port_file(port)) + { #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"); + if ((port_position(port) > 0) && + (fwrite((void *)(port_data(port)), 1, port_position(port), port_file(port)) != (size_t)port_position(port))) + s7_warn(sc, 64, "fwrite trouble in close-output-port\n"); #else - fwrite ((void*) (port_data (port)), 1, port_position (port), - port_file (port)); + if (port_position(port) > 0) + fwrite((void *)(port_data(port)), 1, port_position(port), port_file(port)); #endif - port_position (port)= 0; + if (fflush(port_file(port)) == -1) + s7_warn(sc, 64, "fflush in close-output-port: %s\n", strerror(errno)); + fclose(port_file(port)); + port_file(port) = NULL; } -#if WITH_WARNINGS - if (fputs (str, port_file (port)) == EOF) - s7_warn (sc, 64, "write to %s: %s\n", port_filename (port), - strerror (errno)); -#else - fputs (str, port_file (port)); -#endif - } + port_port(port)->pf = &closed_port_functions; + port_set_closed(port, true); + port_position(port) = 0; } -static void -function_display (s7_scheme* sc, const char* str, s7_pointer port) { - if (!str) return; - push_stack_direct (sc, OP_NO_VALUES); - for (; *str; str++) - (*(port_output_function (port))) (sc, *str, port); - unstack_with (sc, OP_NO_VALUES); - memcpy ((void*) sc, (void*) (sc->stack_end), - 3 * sizeof (s7_pointer)); /* code/let/args */ +static void close_output_string(s7_scheme *sc, s7_pointer port) +{ + if (port_data(port)) + { + port_data(port) = NULL; + port_data_size(port) = 0; + } + port_port(port)->pf = &closed_port_functions; + port_set_closed(port, true); + port_position(port) = 0; +} + +static void close_output_port(s7_scheme *sc, s7_pointer port) {port_close(port)(sc, port);} + +void s7_close_output_port(s7_scheme *sc, s7_pointer port) +{ + if ((port == sc->F) || (is_immutable_port(port))) return; /* can these happen? */ + close_output_port(sc, port); +} + +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)) + + const s7_pointer port = car(args); + if (!is_output_port(port)) + { + if (port == sc->F) return(sc->unspecified); + if_method_exists_return_value(sc, port, sc->close_output_port_symbol, args); + sole_arg_wrong_type_error_nr(sc, sc->close_output_port_symbol, port, an_output_port_or_f_string); + } + s7_close_output_port(sc, port); + return(sc->unspecified); } -static void -function_write_string (s7_scheme* sc, const char* str, s7_int len, - s7_pointer port) { - push_stack_direct (sc, OP_NO_VALUES); - for (s7_int i= 0; i < len; i++) - (*(port_output_function (port))) (sc, str[i], port); - unstack_with (sc, OP_NO_VALUES); - memcpy ((void*) sc, (void*) (sc->stack_end), - 3 * sizeof (s7_pointer)); /* code/let/args */ + +/* -------- read character/line functions moved to s7_scheme_read.c -------- */ + + +/* -------- write character functions -------- */ + +void resize_port_data(s7_scheme *sc, s7_pointer port, s7_int new_size) +{ + const s7_int loc = port_data_size(port); + block_t *new_b; + if (new_size < loc) return; + if (new_size > sc->max_string_port_length) + error_nr(sc, make_symbol(sc, "port-too-big", 12), + set_elist_3(sc, wrap_string(sc, "string port length has grown past (*s7* 'max-string-port-length): ~D > ~D", 73), + wrap_integer(sc, new_size), + wrap_integer(sc, sc->max_string_port_length))); + new_b = reallocate(sc, port_data_block(port), new_size); + port_data_block(port) = new_b; + port_data(port) = (uint8_t *)(block_data(new_b)); + port_data_size(port) = new_size; } -static void -stdout_display (s7_scheme* sc, const char* str, s7_pointer port) { - if (str) fputs (str, stdout); +static void string_write_char_resized(s7_scheme *sc, uint8_t c, s7_pointer port) +{ + /* this division looks repetitive, but it is much faster */ + resize_port_data(sc, port, port_data_size(port) * 2); + port_data(port)[port_position(port)++] = c; } -static void -stderr_display (s7_scheme* sc, const char* str, s7_pointer port) { - if (str) fputs (str, stderr); + +static void string_write_char(s7_scheme *sc, uint8_t c, s7_pointer port) +{ + if (port_position(port) < port_data_size(port)) + port_data(port)[port_position(port)++] = c; + else string_write_char_resized(sc, c, port); } -/* -------- skip to newline readers -------- */ -static token_t token (s7_scheme* sc); +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 token_t -file_read_semicolon (s7_scheme* sc, s7_pointer port) { - int32_t c; - do - (c= fgetc (port_file (port))); - while ((c != '\n') && (c != EOF)); - port_line_number (port)++; - return ((c == EOF) ? token_eof : token (sc)); -} - -static token_t -string_read_semicolon (s7_scheme* sc, s7_pointer port) { - const char* str = (const char*) (port_data (port) + port_position (port)); - const char* orig_str= strchr (str, (int) '\n'); - if (!orig_str) { - port_position (port)= port_data_size (port); - return (token_eof); - } - port_position (port)+= - (orig_str - str + - 1); /* + 1 because strchr leaves orig_str pointing at the newline */ - port_line_number (port)++; - return (token (sc)); +static void function_write_char(s7_scheme *sc, uint8_t c, s7_pointer port) +{ + push_stack_direct(sc, OP_NO_VALUES); + /* sc->args = sc->nil; */ + (*(port_output_function(port)))(sc, c, port); + unstack_with(sc, OP_NO_VALUES); + memcpy((void *)sc, (void *)(sc->stack_end), 3 * sizeof(s7_pointer)); /* code/let/args */ } -/* -------- white space readers -------- */ +#ifndef OUTPUT_FILE_PORT_LENGTH + #define OUTPUT_FILE_PORT_LENGTH 2048 +#endif -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 Inline void inline_file_write_char(s7_scheme *sc, uint8_t c, s7_pointer port) +{ + if (port_position(port) == sc->output_file_port_length) + { + fwrite((void *)(port_data(port)), 1, sc->output_file_port_length, port_file(port)); + port_position(port) = 0; + } + port_data(port)[port_position(port)++] = c; } -static int32_t -terminated_string_read_white_space (s7_scheme* sc, s7_pointer port) { - const uint8_t* str= - (const uint8_t*) (port_data (port) + port_position (port)); - uint8_t c; - /* here we know we have null termination and white_space[#\null] is false */ - while (white_space[c= *str++]) /* 255 is not -1 = EOF */ - if (c == '\n') port_line_number (port)++; - port_position (port)= (c) ? str - port_data (port) : port_data_size (port); - return ((int32_t) c); +static void file_write_char(s7_scheme *sc, uint8_t c, s7_pointer port) {inline_file_write_char(sc, c, port);} + +static void input_write_char(s7_scheme *sc, uint8_t c, s7_pointer port) /* not reachable I think */ +{ + sole_arg_wrong_type_error_nr(sc, sc->write_char_symbol, port, an_output_port_string); } -/* -------- name readers -------- */ -#define BASE_10 10 +static void closed_port_write_char(s7_scheme *sc, uint8_t c, s7_pointer port) +{ + sole_arg_wrong_type_error_nr(sc, sc->write_char_symbol, port, an_open_output_port_string); +} -static s7_pointer -file_read_name_or_sharp (s7_scheme* sc, s7_pointer port, 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 (port)); /* might return EOF */ - if (c == '\n') port_line_number (port)++; - sc->strbuf[i++]= (unsigned char) c; - if (i >= sc->strbuf_size) resize_strbuf (sc, i); - } while ((c != EOF) && (char_ok_in_a_name[c])); +/* -------- write string functions -------- */ - if ((i == 2) && (sc->strbuf[0] == '\\')) sc->strbuf[2]= '\0'; - else { - if (c != EOF) { - if (c == '\n') port_line_number (port)--; - ungetc (c, port_file (port)); - } - 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, port, true)); +static void input_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer port) +{ + sole_arg_wrong_type_error_nr(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) +{ + sole_arg_wrong_type_error_nr(sc, sc->write_symbol, port, an_open_output_port_string); +} + +static void input_display(s7_scheme *sc, const char *s, s7_pointer port) +{ + sole_arg_wrong_type_error_nr(sc, sc->display_symbol, port, an_output_port_string); +} + +static void closed_port_display(s7_scheme *sc, const char *s, s7_pointer port) +{ + sole_arg_wrong_type_error_nr(sc, sc->display_symbol, port, an_open_output_port_string); } -static s7_pointer -file_read_name (s7_scheme* sc, s7_pointer port) { - return (file_read_name_or_sharp (sc, port, true)); +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 + for (s7_int i = 0; i < len; i++) + fputc(str[i], stdout); } -static s7_pointer -file_read_sharp (s7_scheme* sc, s7_pointer port) { - return (file_read_name_or_sharp (sc, port, false)); + +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 + for (s7_int i = 0; i < len; i++) + fputc(str[i], stderr); } -static s7_pointer -string_read_name_no_free (s7_scheme* sc, s7_pointer port) { - /* sc->strbuf[0] has the first char of the string we're reading */ - const uint8_t* str= (uint8_t*) (port_data (port) + port_position (port)); +void string_write_string_resized(s7_scheme *sc, const char *str, s7_int len, s7_pointer port) +{ + s7_int new_len = port_position(port) + len; /* len is known to be non-zero, str might not be 0-terminated */ + resize_port_data(sc, port, new_len * 2); + memcpy((void *)(port_data(port) + port_position(port)), (const void *)str, len); + port_position(port) = new_len; +} - if (char_ok_in_a_name[*str]) { - s7_int k; - const uint8_t* orig_str= str - 1; - str++; - while (char_ok_in_a_name[*str]) - str++; - k= str - orig_str; - if (*str != 0) port_position (port)+= (k - 1); - else port_position (port)= port_data_size (port); - /* 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[*orig_str]) - return (inline_make_symbol (sc, (const char*) 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)); - } - { - s7_pointer result= sc->singletons[(uint8_t) (sc->strbuf[0])]; - if (!result) { - sc->strbuf[1]= '\0'; - result = make_symbol (sc, sc->strbuf, 1); - sc->singletons[(uint8_t) (sc->strbuf[0])]= result; +static void string_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer port) +{ + if ((S7_DEBUGGING) && (len == 0)) {fprintf(stderr, "string_write_string len == 0\n"); abort();} + if (port_position(port) + len < port_data_size(port)) + { + memcpy((void *)(port_data(port) + port_position(port)), (const 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(port) += len; } - return (result); - } + else string_write_string_resized(sc, str, len, port); } -static s7_pointer -string_read_sharp (s7_scheme* sc, s7_pointer port) { - /* 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= (char*) (port_data (port) + port_position (port)); - if (char_ok_in_a_name[(uint8_t) *str]) { - s7_int k; - const char* orig_str= (char*) (str - 1); - str++; - while (char_ok_in_a_name[(uint8_t) (*str)]) { - str++; +static void file_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer port) +{ + const s7_int new_len = port_position(port) + len; + if (new_len >= sc->output_file_port_length) + { + 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 write-string\n"); +#else + fwrite((void *)(port_data(port)), 1, port_position(port), port_file(port)); +#endif + port_position(port) = 0; + } + fwrite((const void *)str, 1, len, port_file(port)); + } + else + { + memcpy((void *)(port_data(port) + port_position(port)), (const void *)str, len); + port_position(port) = new_len; } - k= str - orig_str; - port_position (port)+= (k - 1); - 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, port, 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 (port)++; - } - else sc->strbuf[1]= '\0'; - return ( - make_sharp_constant (sc, sc->strbuf, WITH_OVERFLOW_ERROR, port, true)); } -static s7_pointer -string_read_name (s7_scheme* sc, s7_pointer port) { - /* port_string was allocated (and read from a file) so we can mess with it - * directly */ - s7_pointer result; - uint8_t* str= (uint8_t*) (port_data (port) + port_position (port)); - if (char_ok_in_a_name[*str]) { - s7_int k; - uint8_t endc; - const uint8_t* orig_str= str - 1; - str++; - while (char_ok_in_a_name[*str]) - str++; - k= str - orig_str; - port_position (port)+= (k - 1); - if (!number_table[*orig_str]) - return (inline_make_symbol (sc, (const char*) orig_str, k)); - endc = *str; - *str = 0; /* temp end for make_atom */ - result= make_atom (sc, (char*) 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 (sc, sc->strbuf, 1); - sc->singletons[(uint8_t) (sc->strbuf[0])]= result; - } - return (result); -} - -static void -port_set_filename (s7_scheme* sc, s7_pointer port, const char* name, - size_t len) { - block_t* b = inline_mallocate (sc, len + 1); - port_filename_block (port)= b; - port_filename (port) = (char*) block_data (b); - memcpy ((void*) block_data (b), (const void*) name, len); - port_filename (port)[len]= '\0'; -} - -static block_t* -mallocate_port (s7_scheme* sc) { -#define PORT_LIST 8 /* sizeof(port_t): 160 */ - block_t* blk= sc->block_lists[PORT_LIST]; - if (blk) sc->block_lists[PORT_LIST]= (block_t*) block_next (blk); - else { /* this is mallocate without the index calc */ - blk = mallocate_block (sc); - block_data (blk)= (void*) permalloc (sc, (size_t) (1 << PORT_LIST)); - block_set_index (blk, PORT_LIST); - } - block_set_size (blk, sizeof (port_t)); -#if S7_DEBUGGING - sc->blocks_mallocated[PORT_LIST]++; +static void string_display(s7_scheme *sc, const char *str, s7_pointer port) +{ + if (str) string_write_string(sc, str, safe_strlen(str), port); +} + +static void file_display(s7_scheme *sc, const char *str, s7_pointer port) +{ + if (str) + { + 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 - return (blk); -} - -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; + port_position(port) = 0; + } +#if WITH_WARNINGS + if (fputs(str, port_file(port)) == EOF) + s7_warn(sc, 64, "write to %s: %s\n", port_filename(port), strerror(errno)); +#else + fputs(str, port_file(port)); #endif - block_t* b= mallocate_port (sc); - new_cell (sc, port, T_INPUT_PORT); - gc_protect_via_stack (sc, port); - port_block (port)= b; - port_port (port) = (port_t*) block_data (b); - port_set_closed (port, false); - port_set_string_or_function (port, sc->nil); - 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 */ - { - block_t* block = mallocate (sc, size + 2); - uint8_t* content= (uint8_t*) (block_data (block)); - const size_t 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= 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; +static void function_display(s7_scheme *sc, const char *str, s7_pointer port) +{ + if (!str) return; + push_stack_direct(sc, OP_NO_VALUES); + for (; *str; str++) + (*(port_output_function(port)))(sc, *str, port); + unstack_with(sc, OP_NO_VALUES); + memcpy((void *)sc, (void *)(sc->stack_end), 3 * sizeof(s7_pointer)); /* code/let/args */ +} + +static void function_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer port) +{ + push_stack_direct(sc, OP_NO_VALUES); + for (s7_int i = 0; i < len; i++) + (*(port_output_function(port)))(sc, str[i], port); + unstack_with(sc, OP_NO_VALUES); + memcpy((void *)sc, (void *)(sc->stack_end), 3 * sizeof(s7_pointer)); /* code/let/args */ +} + +static void stdout_display(s7_scheme *sc, const char *str, s7_pointer port) {if (str) fputs(str, stdout);} +static void stderr_display(s7_scheme *sc, const char *str, s7_pointer port) {if (str) fputs(str, stderr);} + + +/* -------- skip-to-newline / white space / name readers moved to s7_scheme_read.c -------- */ +static token_t token(s7_scheme *sc); +token_t file_read_semicolon(s7_scheme *sc, s7_pointer port); +token_t string_read_semicolon(s7_scheme *sc, s7_pointer port); +int32_t s7i_token(s7_scheme *sc) {return(token(sc));} + + +static void port_set_filename(s7_scheme *sc, s7_pointer port, const char *name, size_t len) +{ + block_t *b = inline_mallocate(sc, len + 1); + port_filename_block(port) = b; + port_filename(port) = (char *)block_data(b); + memcpy((void *)block_data(b), (const void *)name, len); + port_filename(port)[len] = '\0'; +} + +static block_t *mallocate_port(s7_scheme *sc) +{ + #define PORT_LIST 8 /* sizeof(port_t): 160 */ + block_t *blk = sc->block_lists[PORT_LIST]; + if (blk) + sc->block_lists[PORT_LIST] = (block_t *)block_next(blk); + else + { /* this is mallocate without the index calc */ + blk = mallocate_block(sc); + block_data(blk) = (void *)permalloc(sc, (size_t)(1 << PORT_LIST)); + block_set_index(blk, PORT_LIST); + } + block_set_size(blk, sizeof(port_t)); +#if S7_DEBUGGING + sc->blocks_mallocated[PORT_LIST]++; #endif - unstack_gc_protect (sc); - return (port); + return(blk); } -/* -------------------------------- open-input-file - * -------------------------------- */ -static int32_t -remember_file_name (s7_scheme* sc, const char* file) { - for (int32_t i= 0; i <= sc->file_names_top; i++) - if (safe_strcmp (file, string_value (sc->file_names[i]))) return (i); +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}; + +/* read_file moved to s7_scheme_read.c */ +const port_functions_t *s7i_input_file_functions(void) {return(&input_file_functions);} +const port_functions_t *s7i_input_string_functions_1(void) {return(&input_string_functions_1);} +block_t *s7i_mallocate_port(s7_scheme *sc) {return(mallocate_port(sc));} +void s7i_port_set_filename(s7_scheme *sc, s7_pointer port, const char *name, s7_int len) {port_set_filename(sc, port, name, (size_t)len);} + + +/* -------------------------------- open-input-file -------------------------------- */ +static int32_t remember_file_name(s7_scheme *sc, const char *file) +{ + for (int32_t 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 (int32_t i= old_size; i < sc->file_names_size; i++) - sc->file_names[i]= sc->F; - } - sc->file_names[sc->file_names_top]= s7_make_semipermanent_string (sc, file); - return (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 (int32_t i = old_size; i < sc->file_names_size; i++) + sc->file_names[i] = sc->F; + } + sc->file_names[sc->file_names_top] = s7_make_semipermanent_string(sc, file); + return(sc->file_names_top); } #ifndef MAX_SIZE_FOR_FILE_TO_STRING_PORT_CONVERSION -#define MAX_SIZE_FOR_FILE_TO_STRING_PORT_CONVERSION 10000000 -/* I'd add this to *s7* but it doesn't make much difference unless you're - * reading a large text file */ + #define MAX_SIZE_FOR_FILE_TO_STRING_PORT_CONVERSION 10000000 + /* I'd add this to *s7* but it doesn't make much difference unless you're reading a large text file */ #endif -static s7_pointer -make_input_file (s7_scheme* sc, const char* name, FILE* fp) { - return (read_file (sc, fp, name, MAX_SIZE_FOR_FILE_TO_STRING_PORT_CONVERSION, - "open")); +static s7_pointer make_input_file(s7_scheme *sc, const char *name, FILE *fp) +{ + return(read_file(sc, fp, name, MAX_SIZE_FOR_FILE_TO_STRING_PORT_CONVERSION, "open")); } + #if !MS_WINDOWS #include #endif -static bool -is_directory (const char* filename) { +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 + #ifdef S_ISDIR + struct stat statbuf; + return((stat(filename, &statbuf) >= 0) && + (S_ISDIR(statbuf.st_mode))); + #endif #endif - return (false); + return(false); } -static block_t* -expand_filename (s7_scheme* sc, const char* name) { +static block_t *expand_filename(s7_scheme *sc, const char *name) +{ #if WITH_GCC - if ((name[0] == '~') && - (name[1] == '/')) /* catch one special case, "~/..." */ - { - char* home= getenv ("HOME"); - if (home) { - s7_int len = safe_strlen (name) + safe_strlen (home) + 1; - block_t* b = mallocate (sc, len); - char* filename= (char*) block_data (b); - filename[0] = '\0'; - catstrs (filename, len, home, (const char*) (name + 1), (char*) NULL); - return (b); - } - } + if ((name[0] == '~') && (name[1] == '/')) /* catch one special case, "~/..." */ + { + char *home = getenv("HOME"); + if (home) + { + s7_int len = safe_strlen(name) + safe_strlen(home) + 1; + block_t *b = mallocate(sc, len); + char *filename = (char *)block_data(b); + filename[0] = '\0'; + catstrs(filename, len, home, (const char *)(name + 1), (char *)NULL); + return(b); + }} #endif - return (NULL); + return(NULL); } -static s7_pointer -open_input_file_1 (s7_scheme* sc, const char* name, const char* mode, - const char* caller) { - FILE* fp; +static s7_pointer open_input_file_1(s7_scheme *sc, const char *name, const char *mode, const char *caller) +{ + FILE *fp; #if WITH_GCC - block_t* b; + block_t *b; #endif /* see if we can open this file before allocating a port */ - if (is_directory (name)) - file_error_nr (sc, caller, "file is a directory:", name); - errno= 0; - fp = fopen (name, mode); - if (fp) return (make_input_file (sc, name, fp)); + if (is_directory(name)) + file_error_nr(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) file_error_nr (sc, caller, "invalid mode", mode); + if (errno == EINVAL) + file_error_nr(sc, caller, "invalid mode", mode); #if WITH_GCC - if ((!name) || (!*name)) file_error_nr (sc, caller, strerror (errno), name); - b= expand_filename (sc, name); - if (b) { - char* new_name= (char*) block_data (b); - fp = fopen (new_name, mode); - liberate (sc, b); - if (fp) return (make_input_file (sc, name, fp)); - } + if ((!name) || (!*name)) + file_error_nr(sc, caller, strerror(errno), name); + b = expand_filename(sc, name); + if (b) + { + char *new_name = (char *)block_data(b); + fp = fopen(new_name, mode); + liberate(sc, b); + if (fp) + return(make_input_file(sc, name, fp)); + } #endif #endif - file_error_nr (sc, caller, strerror (errno), name); - return (sc->io_error_symbol); -} - -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) - - const s7_pointer 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, - sc->type_names[T_STRING], 1)); - if (!is_pair (cdr (args))) - return ( - open_input_file_1 (sc, string_value (name), "r", "open-input-file")); + file_error_nr(sc, caller, strerror(errno), name); + return(sc->io_error_symbol); +} + +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) + + const s7_pointer 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, sc->type_names[T_STRING], 1)); + if (!is_pair(cdr(args))) + return(open_input_file_1(sc, string_value(name), "r", "open-input-file")); { - s7_pointer mode= cadr (args); - if (!is_string (mode)) - return (method_or_bust ( - 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")); + s7_pointer mode = cadr(args); + if (!is_string(mode)) + return(method_or_bust(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 s7_pointer -alloc_standard_output_port (s7_scheme* sc) { - const s7_pointer port= alloc_pointer (sc); - set_full_type (port, T_OUTPUT_PORT | T_IMMUTABLE | T_UNHEAP); - port_port (port) = (port_t*) Calloc (1, sizeof (port_t)); - port_type (port) = file_port; - port_data (port) = NULL; - port_data_block (port)= NULL; - port_set_closed (port, false); - port_line_number (port)= 0; - port_needs_free (port) = false; - return (port); -} - -static void -init_standard_ports (s7_scheme* sc) { +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 s7_pointer alloc_standard_output_port(s7_scheme *sc) +{ + const s7_pointer port = alloc_pointer(sc); + set_full_type(port, T_OUTPUT_PORT | T_IMMUTABLE | T_UNHEAP); + port_port(port) = (port_t *)Calloc(1, sizeof(port_t)); + port_type(port) = file_port; + port_data(port) = NULL; + port_data_block(port) = NULL; + port_set_closed(port, false); + port_line_number(port) = 0; + port_needs_free(port) = false; + return(port); +} + +static void init_standard_ports(s7_scheme *sc) +{ s7_pointer port; /* standard output */ - port = alloc_standard_output_port (sc); - port_filename_length (port)= 8; - port_set_filename (sc, port, "*stdout*", 8); - port_file_number (port)= remember_file_name ( - sc, port_filename (port)); /* these numbers need to be correct for the - evaluator (*function* data) */ - port_file (port) = stdout; - port_port (port)->pf= &stdout_functions; + port = alloc_standard_output_port(sc); + port_filename_length(port) = 8; + port_set_filename(sc, port, "*stdout*", 8); + port_file_number(port) = remember_file_name(sc, port_filename(port)); /* these numbers need to be correct for the evaluator (*function* data) */ + port_file(port) = stdout; + port_port(port)->pf = &stdout_functions; sc->standard_output = port; /* standard error */ - port = alloc_standard_output_port (sc); - port_filename_length (port)= 8; - port_set_filename (sc, port, "*stderr*", 8); - port_file_number (port)= remember_file_name (sc, port_filename (port)); - port_file (port) = stderr; - port_port (port)->pf = &stderr_functions; - sc->standard_error = port; + port = alloc_standard_output_port(sc); + port_filename_length(port) = 8; + port_set_filename(sc, port, "*stderr*", 8); + port_file_number(port) = remember_file_name(sc, port_filename(port)); + port_file(port) = stderr; + port_port(port)->pf = &stderr_functions; + sc->standard_error = port; /* standard input */ - port= alloc_pointer (sc); - set_full_type (port, T_INPUT_PORT | T_IMMUTABLE | T_UNHEAP); - port_port (port)= (port_t*) Calloc (1, sizeof (port_t)); - port_type (port)= file_port; - port_set_closed (port, false); - port_set_string_or_function (port, sc->nil); - port_filename_length (port)= 7; - port_set_filename (sc, port, "*stdin*", 7); - port_file_number (port)= remember_file_name (sc, port_filename (port)); - port_line_number (port)= 0; - port_file (port) = stdin; - port_data_block (port) = NULL; - port_needs_free (port) = false; - port_port (port)->pf = &stdin_functions; - sc->standard_input = port; - - 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); - set_current_error_port (sc, 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; + port = alloc_pointer(sc); + set_full_type(port, T_INPUT_PORT | T_IMMUTABLE | T_UNHEAP); + port_port(port) = (port_t *)Calloc(1, sizeof(port_t)); + port_type(port) = file_port; + port_set_closed(port, false); + port_set_string_or_function(port, sc->nil); + port_filename_length(port) = 7; + port_set_filename(sc, port, "*stdin*", 7); + port_file_number(port) = remember_file_name(sc, port_filename(port)); + port_line_number(port) = 0; + port_file(port) = stdin; + port_data_block(port) = NULL; + port_needs_free(port) = false; + port_port(port)->pf = &stdin_functions; + sc->standard_input = port; + + 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); + set_current_error_port(sc, 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 port; - block_t * block, *b; + block_t *block, *b; /* see if we can open this file before allocating a port */ - errno= 0; - fp = fopen (name, mode); - if (!fp) { + errno = 0; + fp = fopen(name, mode); + if (!fp) + { #if !MS_WINDOWS - if (errno == EINVAL) - file_error_nr (sc, "open-output-file", "invalid mode", mode); + if (errno == EINVAL) + file_error_nr(sc, "open-output-file", "invalid mode", mode); #endif - file_error_nr (sc, "open-output-file", strerror (errno), name); - } - new_cell (sc, port, T_OUTPUT_PORT); - b = mallocate_port (sc); - port_block (port)= b; - port_port (port) = (port_t*) block_data (b); - port_type (port) = file_port; - port_set_closed (port, false); - port_filename_length (port)= safe_strlen (name); - port_set_filename (sc, port, name, port_filename_length (port)); - port_line_number (port)= 1; - port_file_number (port)= 0; - port_file (port) = fp; - port_needs_free (port) = true; /* hmm -- I think these are freed via - s7_close_output_port -> close_output_port */ - port_position (port) = 0; - port_data_size (port) = sc->output_file_port_length; - block = mallocate (sc, sc->output_file_port_length); - port_data_block (port)= block; - port_data (port) = (uint8_t*) (block_data (block)); - port_port (port)->pf = &output_file_functions; - add_output_port (sc, port); - return (port); -} - -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) - - const s7_pointer name= car (args); - if (!is_string (name)) - return (method_or_bust (sc, name, sc->open_output_file_symbol, args, - sc->type_names[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 ( - 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. + file_error_nr(sc, "open-output-file", strerror(errno), name); + } + new_cell(sc, port, T_OUTPUT_PORT); + b = mallocate_port(sc); + port_block(port) = b; + port_port(port) = (port_t *)block_data(b); + port_type(port) = file_port; + port_set_closed(port, false); + port_filename_length(port) = safe_strlen(name); + port_set_filename(sc, port, name, port_filename_length(port)); + port_line_number(port) = 1; + port_file_number(port) = 0; + port_file(port) = fp; + port_needs_free(port) = true; /* hmm -- I think these are freed via s7_close_output_port -> close_output_port */ + port_position(port) = 0; + port_data_size(port) = sc->output_file_port_length; + block = mallocate(sc, sc->output_file_port_length); + port_data_block(port) = block; + port_data(port) = (uint8_t *)(block_data(block)); + port_port(port)->pf = &output_file_functions; + add_output_port(sc, port); + return(port); +} + +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) + + const s7_pointer name = car(args); + if (!is_string(name)) + return(method_or_bust(sc, name, sc->open_output_file_symbol, args, sc->type_names[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(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) { +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 port; - block_t* b= mallocate_port (sc); - new_cell (sc, port, T_INPUT_PORT); - port_block (port)= b; - port_port (port) = (port_t*) block_data (b); - port_type (port) = string_port; - port_set_closed (port, false); - port_set_string_or_function (port, sc->nil); - port_data (port) = (uint8_t*) input_string; - port_data_block (port) = NULL; - port_data_size (port) = len; - port_position (port) = 0; - port_filename_block (port) = NULL; - port_filename_length (port)= 0; - port_filename (port) = NULL; - port_file_number (port) = 0; - port_line_number (port) = 0; - port_file (port) = NULL; - port_needs_free (port) = false; + block_t *b = mallocate_port(sc); + new_cell(sc, port, T_INPUT_PORT); + port_block(port) = b; + port_port(port) = (port_t *)block_data(b); + port_type(port) = string_port; + port_set_closed(port, false); + port_set_string_or_function(port, sc->nil); + port_data(port) = (uint8_t *)input_string; + port_data_block(port) = NULL; + port_data_size(port) = len; + port_position(port) = 0; + port_filename_block(port) = NULL; + port_filename_length(port) = 0; + port_filename(port) = NULL; + port_file_number(port) = 0; + port_line_number(port) = 0; + port_file(port) = NULL; + port_needs_free(port) = false; #if S7_DEBUGGING - if ((len > 0) && (input_string[len] != '\0')) { - fprintf (stderr, - "%s%s[%d]: input_string is not terminated: len: %" ld64 - ", at end: %c%c, str: %s%s\n", - bold_text, __func__, __LINE__, len, input_string[len - 1], - input_string[len], input_string, unbold_text); - if (sc->stop_at_error) abort (); - } + if ((len > 0) && (input_string[len] != '\0')) + { + fprintf(stderr, "%s%s[%d]: input_string is not terminated: len: %" ld64 ", at end: %c%c, str: %s%s\n", + bold_text, __func__, __LINE__, len, input_string[len - 1], input_string[len], input_string, unbold_text); + if (sc->stop_at_error) abort(); + } #endif - port_port (port)->pf= &input_string_functions; - add_input_string_port (sc, port); - return (port); + port_port(port)->pf = &input_string_functions; + add_input_string_port(sc, port); + return(port); } -static /* inline */ s7_pointer -open_and_protect_input_string (s7_scheme* sc, s7_pointer str) { - s7_pointer port= - open_input_string (sc, string_value (str), string_length (str)); - port_set_string_or_function (port, str); - return (port); +static /* inline */ s7_pointer open_and_protect_input_string(s7_scheme *sc, s7_pointer str) +{ + s7_pointer port = open_input_string(sc, string_value(str), string_length(str)); + port_set_string_or_function(port, str); + return(port); } -s7_pointer -s7_open_input_string (s7_scheme* sc, const char* input_string) { - return (open_input_string (sc, input_string, safe_strlen (input_string))); +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); - if (!is_string (input_string)) - return (sole_arg_method_or_bust (sc, input_string, - sc->open_input_string_symbol, args, - sc->type_names[T_STRING])); - return (open_and_protect_input_string (sc, 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); + if (!is_string(input_string)) + return(sole_arg_method_or_bust(sc, input_string, sc->open_input_string_symbol, args, sc->type_names[T_STRING])); + return(open_and_protect_input_string(sc, input_string)); } -/* -------------------------------- open-output-string - * -------------------------------- */ + +/* -------------------------------- 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) +/* 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) { +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 port; - block_t* b = mallocate_port (sc); - block_t* block= inline_mallocate (sc, sc->initial_string_port_length); - new_cell (sc, port, T_OUTPUT_PORT); - port_block (port)= b; - port_port (port) = (port_t*) block_data (b); - port_type (port) = string_port; - port_set_closed (port, false); - port_data_size (port) = sc->initial_string_port_length; - port_data_block (port)= block; - port_data (port) = (uint8_t*) (block_data (block)); - port_data (port)[0]= - '\0'; /* in case s7_get_output_string before any output */ - port_position (port) = 0; - port_needs_free (port) = true; - port_filename_block (port)= NULL; - port_filename_length (port)= - 0; /* protect against (port-filename (open-output-string)) */ - port_filename (port)= NULL; - port_port (port)->pf= &output_string_functions; - add_output_port (sc, port); - return (port); + block_t *b = mallocate_port(sc); + block_t *block = inline_mallocate(sc, sc->initial_string_port_length); + new_cell(sc, port, T_OUTPUT_PORT); + port_block(port) = b; + port_port(port) = (port_t *)block_data(b); + port_type(port) = string_port; + port_set_closed(port, false); + port_data_size(port) = sc->initial_string_port_length; + port_data_block(port) = block; + port_data(port) = (uint8_t *)(block_data(block)); + port_data(port)[0] = '\0'; /* in case s7_get_output_string before any output */ + port_position(port) = 0; + port_needs_free(port) = true; + port_filename_block(port) = NULL; + port_filename_length(port) = 0; /* protect against (port-filename (open-output-string)) */ + port_filename(port) = NULL; + port_port(port)->pf = &output_string_functions; + add_output_port(sc, port); + return(port); } #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) - -/* -------------------------------- get-output-string - * -------------------------------- */ -const char* -s7_get_output_string (s7_scheme* sc, s7_pointer port) { - port_data (port)[port_position (port)]= '\0'; - return ((const char*) port_data (port)); -} - -s7_pointer -s7_output_string (s7_scheme* sc, s7_pointer port) { - port_data (port)[port_position (port)]= '\0'; - if (port_position (port) == 0) return (nil_string); - return (make_string_with_length (sc, (const char*) port_data (port), - port_position (port))); -} - -static inline void -check_get_output_string_port (s7_scheme* sc, s7_pointer port) { - if (port_is_closed (port)) - wrong_type_error_nr (sc, sc->get_output_string_symbol, 1, port, - wrap_string (sc, "an active (open) string port", 28)); - if (port_position (port) > sc->max_string_length) - error_nr ( - sc, sc->out_of_range_symbol, - set_elist_3 (sc, - wrap_string (sc, - "get-output-string port-position ~D is " - "greater than (*s7* 'max-string-length), ~D", - 80), - wrap_integer (sc, port_position (port)), - wrap_integer (sc, sc->max_string_length))); -} -/* if pos>max and clear, where should the clear be? Not here because we might - * want to see output in error handler. similarly below if pos>size how can we - * call make_string (out-of-bounds) and ignore error? if pos>size shouldn't we - * raise an error somewhere? +#define Q_open_output_string s7_make_signature(sc, 1, sc->is_output_port_symbol) + + +/* -------------------------------- get-output-string -------------------------------- */ +const char *s7_get_output_string(s7_scheme *sc, s7_pointer port) +{ + port_data(port)[port_position(port)] = '\0'; + return((const char *)port_data(port)); +} + +s7_pointer s7_output_string(s7_scheme *sc, s7_pointer port) +{ + port_data(port)[port_position(port)] = '\0'; + if (port_position(port) == 0) return(nil_string); + return(make_string_with_length(sc, (const char *)port_data(port), port_position(port))); +} + +static inline void check_get_output_string_port(s7_scheme *sc, s7_pointer port) +{ + if (port_is_closed(port)) + wrong_type_error_nr(sc, sc->get_output_string_symbol, 1, port, wrap_string(sc, "an active (open) string port", 28)); + if (port_position(port) > sc->max_string_length) + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "get-output-string port-position ~D is greater than (*s7* 'max-string-length), ~D", 80), + wrap_integer(sc, port_position(port)), wrap_integer(sc, sc->max_string_length))); +} +/* if pos>max and clear, where should the clear be? Not here because we might want to see output in error handler. + * similarly below if pos>size how can we call make_string (out-of-bounds) and ignore error? + * if pos>size shouldn't we raise an error somewhere? */ -static s7_pointer -g_get_output_string (s7_scheme* sc, s7_pointer args) { -#define H_get_output_string \ - "(get-output-string port (clear-port #f)) returns the output accumulated in port. \ +static s7_pointer g_get_output_string(s7_scheme *sc, s7_pointer args) +{ + #define H_get_output_string "(get-output-string port (clear-port #f)) 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) + #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 port; - bool clear_port= false; - port = car (args); - if (port == sc->F) { - s7_pointer clear; - if ((is_null (cdr (args))) || (is_boolean (cadr (args)))) - return (nil_string); - clear= cadr (args); - if_method_exists_return_value (sc, clear, sc->get_output_string_symbol, - set_mlist_2 (sc, port, clear)); - wrong_type_error_nr (sc, sc->get_output_string_symbol, 2, clear, - sc->type_names[T_BOOLEAN]); - } - if ((!is_output_port (port)) || (!is_string_port (port))) { - if_method_exists_return_value (sc, port, sc->get_output_string_symbol, - args); - wrong_type_error_nr ( - sc, sc->get_output_string_symbol, 1, port, - wrap_string (sc, "an open string output port or #f", 32)); - } - check_get_output_string_port (sc, port); - if (is_pair (cdr (args))) { - s7_pointer clear= cadr (args); - if (!is_boolean (clear)) { - if_method_exists_return_value (sc, clear, sc->get_output_string_symbol, - set_mlist_2 (sc, port, clear)); - wrong_type_error_nr (sc, sc->get_output_string_symbol, 2, clear, - sc->type_names[T_BOOLEAN]); - } - clear_port= (clear == sc->T); - } - if ((clear_port) && (port_position (port) < port_data_size (port))) { - block_t* block; - s7_pointer result= - block_to_string (sc, port_data_block (port), port_position (port)); - /* this is slightly faster than make_string_with_length(sc, (char - * *)(port_data(port)), port_position(port)): we're trading a mallocate for - * a memcpy */ - port_data_size (port) = sc->initial_string_port_length; - block = inline_mallocate (sc, port_data_size (port)); - port_data_block (port)= block; - port_data (port) = (uint8_t*) (block_data (block)); - port_position (port) = 0; - port_data (port)[0] = '\0'; - return (result); - } - if (port_position (port) == 0) return (nil_string); - return (make_string_with_length (sc, (const char*) port_data (port), - port_position (port))); -} - -static void -op_get_output_string (s7_scheme* sc) { - const s7_pointer port= sc->code; - if (!is_output_port (port)) - wrong_type_error_nr (sc, sc->with_output_to_string_symbol, 1, port, - wrap_string (sc, "an open string output port", 26)); - check_get_output_string_port (sc, port); + bool clear_port = false; + port = car(args); + if (port == sc->F) + { + s7_pointer clear; + if ((is_null(cdr(args))) || (is_boolean(cadr(args)))) return(nil_string); + clear = cadr(args); + if_method_exists_return_value(sc, clear, sc->get_output_string_symbol, set_mlist_2(sc, port, clear)); + wrong_type_error_nr(sc, sc->get_output_string_symbol, 2, clear, sc->type_names[T_BOOLEAN]); + } + if ((!is_output_port(port)) || (!is_string_port(port))) + { + if_method_exists_return_value(sc, port, sc->get_output_string_symbol, args); + wrong_type_error_nr(sc, sc->get_output_string_symbol, 1, port, wrap_string(sc, "an open string output port or #f", 32)); + } + check_get_output_string_port(sc, port); + if (is_pair(cdr(args))) + { + s7_pointer clear = cadr(args); + if (!is_boolean(clear)) + { + if_method_exists_return_value(sc, clear, sc->get_output_string_symbol, set_mlist_2(sc, port, clear)); + wrong_type_error_nr(sc, sc->get_output_string_symbol, 2, clear, sc->type_names[T_BOOLEAN]); + } + clear_port = (clear == sc->T); + } + if ((clear_port) && + (port_position(port) < port_data_size(port))) + { + block_t *block; + s7_pointer result = block_to_string(sc, port_data_block(port), port_position(port)); + /* this is slightly faster than make_string_with_length(sc, (char *)(port_data(port)), port_position(port)): we're trading a mallocate for a memcpy */ + port_data_size(port) = sc->initial_string_port_length; + block = inline_mallocate(sc, port_data_size(port)); + port_data_block(port) = block; + port_data(port) = (uint8_t *)(block_data(block)); + port_position(port) = 0; + port_data(port)[0] = '\0'; + return(result); + } + if (port_position(port) == 0) return(nil_string); + return(make_string_with_length(sc, (const char *)port_data(port), port_position(port))); +} + +static void op_get_output_string(s7_scheme *sc) +{ + const s7_pointer port = sc->code; + if (!is_output_port(port)) + wrong_type_error_nr(sc, sc->with_output_to_string_symbol, 1, port, wrap_string(sc, "an open string output port", 26)); + check_get_output_string_port(sc, port); /* nil_string here is tricky (need liberate etc) */ - 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)); - /* block_to_string attaches the port's data_block to the string for later free - */ - 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) { - const s7_pointer port= car (args); - if ((!is_output_port (port)) || (!is_string_port (port))) { - if (port == sc->F) return (nil_string); - return (method_or_bust_p (sc, port, sc->get_output_string_symbol, - wrap_string (sc, "an output string port", 21))); - } - check_get_output_string_port (sc, port); - port_data (port)[port_position (port)]= - '\0'; /* wrap_string can't do this, and (for example) open_input_string - wants terminated strings */ - if (port_position (port) == 0) return (nil_string); - return ( - wrap_string (sc, (const char*) port_data (port), port_position (port))); -} - -/* -------------------------------- open-input-function - * -------------------------------- */ -static s7_pointer -g_closed_input_function_port (s7_scheme* sc, s7_pointer unused_args) { - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_1 ( - sc, wrap_string ( - sc, "attempt to read from a closed input-function port", - 49))); - return (NULL); -} - -static void -close_input_function_port (s7_scheme* sc, s7_pointer port) { - port_port (port)->pf= &closed_port_functions; - port_set_string_or_function ( - port, sc->closed_input_function); /* from s7_make_function so it is - GC-protected */ - port_set_closed (port, 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_port}; - -static void -function_port_set_defaults (s7_pointer port) { - port_type (port) = function_port; - port_data (port) = NULL; - port_data_block (port)= NULL; - port_set_closed (port, false); - port_needs_free (port)= false; - port_filename_block (port)= - NULL; /* next three protect against port-filename misunderstandings */ - port_filename (port) = NULL; - port_filename_length (port)= 0; - port_file_number (port) = 0; - port_line_number (port) = 0; - port_file (port) = 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 port; - block_t* b= mallocate_port (sc); - new_cell (sc, port, T_INPUT_PORT); - port_block (port)= b; - port_port (port) = (port_t*) block_data (b); - function_port_set_defaults (port); - port_set_string_or_function (port, sc->nil); - port_input_function (port)= function; - port_port (port)->pf = &input_function_functions; - add_input_port (sc, port); - return (port); -} - -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 + 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)); + /* block_to_string attaches the port's data_block to the string for later free */ + port_data(port) = NULL; + port_data_size(port) = 0; + port_data_block(port) = NULL; + port_needs_free(port) = false; } -static s7_pointer -input_scheme_function_wrapper (s7_scheme* sc, s7_read_t read_choice, - s7_pointer port) { - return (s7_apply_function ( - sc, port_string_or_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, \ - s7_make_signature (sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol)) - - const s7_pointer func= car (args); - if (!is_any_procedure (func)) /* is_procedure is too lenient: we need to flag - (open-input-function (block)) for example */ - return (method_or_bust_p (sc, func, sc->open_input_function_symbol, - a_procedure_string)); - if (!s7_is_aritable (sc, func, 1)) - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_2 ( - sc, - wrap_string ( - sc, - "input-function-port function, ~A, should take one argument", - 58), - func)); - { - s7_pointer port= s7_open_input_function (sc, input_scheme_function_wrapper); - port_set_string_or_function (port, func); - return (port); - } +static s7_pointer g_get_output_string_uncopied(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer port = car(args); + if ((!is_output_port(port)) || (!is_string_port(port))) + { + if (port == sc->F) return(nil_string); + return(method_or_bust_p(sc, port, sc->get_output_string_symbol, wrap_string(sc, "an output string port", 21))); + } + check_get_output_string_port(sc, port); + port_data(port)[port_position(port)] = '\0'; /* wrap_string can't do this, and (for example) open_input_string wants terminated strings */ + if (port_position(port) == 0) return(nil_string); + return(wrap_string(sc, (const char *)port_data(port), port_position(port))); } -/* -------------------------------- open-output-function - * -------------------------------- */ -static s7_pointer -g_closed_output_function_port (s7_scheme* sc, s7_pointer unused_args) { - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_1 ( - sc, wrap_string ( - sc, "attempt to write to a closed output-function port", - 49))); - return (NULL); -} - -static void -close_output_function_port (s7_scheme* sc, s7_pointer port) { - port_port (port)->pf= &closed_port_functions; - port_set_string_or_function (port, sc->closed_output_function); - port_set_closed (port, 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_port}; - -s7_pointer -s7_open_output_function (s7_scheme* sc, - void (*function) (s7_scheme* sc, uint8_t c, - s7_pointer port)) { - s7_pointer port; - block_t* b= mallocate_port (sc); - new_cell (sc, port, T_OUTPUT_PORT); - port_block (port)= b; - port_port (port) = (port_t*) block_data (b); - function_port_set_defaults (port); - port_output_function (port)= function; - port_set_string_or_function (port, sc->nil); - port_port (port)->pf= &output_function_functions; - add_output_port (sc, port); - return (port); -} - -static void -output_scheme_function_wrapper (s7_scheme* sc, uint8_t c, s7_pointer port) { - s7_apply_function (sc, port_string_or_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, \ - s7_make_signature (sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol)) - - const s7_pointer func= car (args); - if (!is_any_procedure (func)) - return (method_or_bust_p (sc, func, sc->open_output_function_symbol, - a_procedure_string)); - if (!s7_is_aritable (sc, func, 1)) - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_2 ( - sc, - wrap_string ( - sc, - "output-function-port function, ~A, should take one argument", - 59), - func)); - { - s7_pointer port= - s7_open_output_function (sc, output_scheme_function_wrapper); - port_set_string_or_function (port, func); - mark_function[T_OUTPUT_PORT]= mark_output_port; - return (port); - } + +/* -------------------------------- open-input-function -------------------------------- */ +static s7_pointer g_closed_input_function_port(s7_scheme *sc, s7_pointer unused_args) +{ + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_1(sc, wrap_string(sc, "attempt to read from a closed input-function port", 49))); + return(NULL); } -/* -------- current-input-port stack -------- */ -#define INPUT_PORT_STACK_INITIAL_SIZE 4 +static void close_input_function_port(s7_scheme *sc, s7_pointer port) +{ + port_port(port)->pf = &closed_port_functions; + port_set_string_or_function(port, sc->closed_input_function); /* from s7_make_function so it is GC-protected */ + port_set_closed(port, true); +} -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); -} - -void -pop_input_port (s7_scheme* sc) { - set_current_input_port ( - sc, (sc->input_port_stack_loc > 0) - ? sc->input_port_stack[--(sc->input_port_stack_loc)] - : sc->standard_input); -} - -static s7_pointer -input_port_if_not_loading (s7_scheme* sc) { - const 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); +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_port}; + +static void function_port_set_defaults(s7_pointer port) +{ + port_type(port) = function_port; + port_data(port) = NULL; + port_data_block(port) = NULL; + port_set_closed(port, false); + port_needs_free(port) = false; + port_filename_block(port) = NULL; /* next three protect against port-filename misunderstandings */ + port_filename(port) = NULL; + port_filename_length(port) = 0; + port_file_number(port) = 0; + port_line_number(port) = 0; + port_file(port) = 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 port; + block_t *b = mallocate_port(sc); + new_cell(sc, port, T_INPUT_PORT); + port_block(port) = b; + port_port(port) = (port_t *)block_data(b); + function_port_set_defaults(port); + port_set_string_or_function(port, sc->nil); + port_input_function(port) = function; + port_port(port)->pf = &input_function_functions; + add_input_port(sc, port); + return(port); +} + +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 } -/* Export helper functions for s7_scheme_base.c */ -const char* -s7i_an_input_port_string (void) { - return ("an input port"); +static s7_pointer input_scheme_function_wrapper(s7_scheme *sc, s7_read_t read_choice, s7_pointer port) +{ + return(s7_apply_function(sc, port_string_or_function(port), set_plist_1(sc, sc->open_input_function_choices[(int)read_choice]))); } -const char* -s7i_a_boolean_string (void) { - return ("a boolean"); + +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, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol)) + + const s7_pointer func = car(args); + if (!is_any_procedure(func)) /* is_procedure is too lenient: we need to flag (open-input-function (block)) for example */ + return(method_or_bust_p(sc, func, sc->open_input_function_symbol, a_procedure_string)); + if (!s7_is_aritable(sc, func, 1)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "input-function-port function, ~A, should take one argument", 58), func)); + { + s7_pointer port = s7_open_input_function(sc, input_scheme_function_wrapper); + port_set_string_or_function(port, func); + return(port); + } } -s7_pointer -s7i_input_port_if_not_loading (s7_scheme* sc) { - return (input_port_if_not_loading (sc)); + +/* -------------------------------- open-output-function -------------------------------- */ +static s7_pointer g_closed_output_function_port(s7_scheme *sc, s7_pointer unused_args) +{ + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_1(sc, wrap_string(sc, "attempt to write to a closed output-function port", 49))); + return(NULL); } -s7_pointer -s7i_port_read_line (s7_scheme* sc, s7_pointer port, bool with_eol) { - return (port_read_line (port) (sc, port, with_eol)); +static void close_output_function_port(s7_scheme *sc, s7_pointer port) +{ + port_port(port)->pf = &closed_port_functions; + port_set_string_or_function(port, sc->closed_output_function); + port_set_closed(port, true); } -/* -------------------------------- read-char -------------------------------- - */ -s7_pointer -s7_read_char (s7_scheme* sc, s7_pointer port) { - int32_t 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) +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_port}; +s7_pointer s7_open_output_function(s7_scheme *sc, void (*function)(s7_scheme *sc, uint8_t c, s7_pointer port)) +{ s7_pointer port; - if (is_pair (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_p (sc, port, sc->read_char_symbol, - an_input_port_string)); - return (chars[port_read_character (port) (sc, port)]); + block_t *b = mallocate_port(sc); + new_cell(sc, port, T_OUTPUT_PORT); + port_block(port) = b; + port_port(port) = (port_t *)block_data(b); + function_port_set_defaults(port); + port_output_function(port) = function; + port_set_string_or_function(port, sc->nil); + port_port(port)->pf = &output_function_functions; + add_output_port(sc, port); + return(port); +} + +static void output_scheme_function_wrapper(s7_scheme *sc, uint8_t c, s7_pointer port) +{ + s7_apply_function(sc, port_string_or_function(port), set_plist_1(sc, make_integer(sc, c))); } -static s7_pointer -read_char_p_p (s7_scheme* sc, s7_pointer port) { - if (!is_input_port (port)) - return (method_or_bust_p (sc, port, sc->read_char_symbol, - an_input_port_string)); - return (chars[port_read_character (port) (sc, port)]); +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, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol)) + + const s7_pointer func = car(args); + if (!is_any_procedure(func)) + return(method_or_bust_p(sc, func, sc->open_output_function_symbol, a_procedure_string)); + if (!s7_is_aritable(sc, func, 1)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "output-function-port function, ~A, should take one argument", 59), func)); + { + s7_pointer port = s7_open_output_function(sc, output_scheme_function_wrapper); + port_set_string_or_function(port, func); + mark_function[T_OUTPUT_PORT] = mark_output_port; + return(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_p (sc, port, sc->read_char_symbol, - an_input_port_string)); - return (chars[port_read_character (port) (sc, port)]); + +/* -------- current-input-port stack -------- */ +#define INPUT_PORT_STACK_INITIAL_SIZE 4 + +/* 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 s7_pointer -read_char_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer unused_expr) { - return ((args == 1) ? sc->read_char_1 : func); +void pop_input_port(s7_scheme *sc) +{ + set_current_input_port(sc, (sc->input_port_stack_loc > 0) ? sc->input_port_stack[--(sc->input_port_stack_loc)] : sc->standard_input); } -/* -------------------------------- write-char -------------------------------- - */ -static void -port_write_unicode_char (s7_scheme* sc, uint32_t c, s7_pointer port) { - if (c < 0x80) port_write_character (port) (sc, (uint8_t) c, port); - else if (c < 0x800) { - char buf[2]; - buf[0]= 0xC0 | (c >> 6); - buf[1]= 0x80 | (c & 0x3F); - port_write_string (port) (sc, buf, 2, port); - } - else if (c < 0x10000) { - char buf[3]; - buf[0]= 0xE0 | (c >> 12); - buf[1]= 0x80 | ((c >> 6) & 0x3F); - buf[2]= 0x80 | (c & 0x3F); - port_write_string (port) (sc, buf, 3, port); - } - else { - char buf[4]; - buf[0]= 0xF0 | (c >> 18); - buf[1]= 0x80 | ((c >> 12) & 0x3F); - buf[2]= 0x80 | ((c >> 6) & 0x3F); - buf[3]= 0x80 | (c & 0x3F); - port_write_string (port) (sc, buf, 4, port); - } +/* input_port_if_not_loading, s7i_input_port_if_not_loading and s7i_port_read_line moved to s7_scheme_read.c */ + +/* Export helper functions for s7_scheme_base.c */ +const char *s7i_an_input_port_string(void) {return("an input port");} +const char *s7i_a_boolean_string(void) {return("a boolean");} + +s7_pointer s7i_an_input_port_string_obj(void) {return(an_input_port_string);} +s7_pointer s7i_an_open_input_port_string_obj(void) {return(an_open_input_port_string);} + +/* read-char functions moved to s7_scheme_read.c */ +/* their H_/Q_ doc/signature macros stay here: defun() in init_s7 references them below */ +#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) +#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) +#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) +#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) +#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) +#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) + + +/* -------------------------------- write-char -------------------------------- */ +void port_write_unicode_char(s7_scheme *sc, uint32_t c, s7_pointer port) +{ + if (c < 0x80) + port_write_character(port)(sc, (uint8_t)c, port); + else if (c < 0x800) + { + char buf[2]; + buf[0] = 0xC0 | (c >> 6); + buf[1] = 0x80 | (c & 0x3F); + port_write_string(port)(sc, buf, 2, port); + } + else if (c < 0x10000) + { + char buf[3]; + buf[0] = 0xE0 | (c >> 12); + buf[1] = 0x80 | ((c >> 6) & 0x3F); + buf[2] = 0x80 | (c & 0x3F); + port_write_string(port)(sc, buf, 3, port); + } + else + { + char buf[4]; + buf[0] = 0xF0 | (c >> 18); + buf[1] = 0x80 | ((c >> 12) & 0x3F); + buf[2] = 0x80 | ((c >> 6) & 0x3F); + buf[3] = 0x80 | (c & 0x3F); + port_write_string(port)(sc, buf, 4, port); + } } /* (with-output-to-string (lambda () (write-char #\space))) -> " " @@ -25964,77852 +18877,60377 @@ port_write_unicode_char (s7_scheme* sc, uint32_t c, s7_pointer port) { * (with-output-to-string (lambda () (display #\space))) -> " " * is this correct? It's what Guile does. write-char is actually display-char. */ -/* should write-char, write, write-string, display, and newline count newlines - * for port-line-number? Currently we only accept input ports */ - -/* -------------------------------- 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)) - ? eof_object - : 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 result; - const s7_pointer port= - (is_pair (args)) ? car (args) : current_input_port (sc); - if (!is_input_port (port)) - return (method_or_bust_p (sc, port, sc->peek_char_symbol, - an_input_port_string)); - if (port_is_closed (port)) - sole_arg_wrong_type_error_nr (sc, sc->peek_char_symbol, port, - an_open_input_port_string); - if (!is_function_port (port)) return (s7_peek_char (sc, port)); - - result= (*(port_input_function (port))) (sc, S7_PEEK_CHAR, port); - if (is_multiple_value (result)) { - clear_multiple_value (result); - error_nr ( - sc, sc->bad_result_symbol, - set_elist_2 ( - sc, - wrap_string ( - sc, - "input-function-port peek-char returned multiple values: ~S", - 58), - result)); - } - if (!is_character (result)) - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_2 ( - sc, - wrap_string (sc, "input-function-port peek-char returned: ~S", 42), - result)); - return (result); -} - -/* -------------------------------- 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) +/* should write-char, write, write-string, display, and newline count newlines for port-line-number? Currently we only accept input ports */ - s7_pointer port; - int32_t c; - if (is_pair (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_p (sc, port, sc->read_byte_symbol, - an_input_port_string)); - if (port_is_closed (port)) /* avoid reporting caller here as read-char */ - sole_arg_wrong_type_error_nr (sc, sc->read_byte_symbol, port, - an_open_input_port_string); - c= port_read_character (port) (sc, port); - return ((c == EOF) ? eof_object : small_int (c)); -} -/* -------------------------------- read-line -------------------------------- - */ -/* g_read_line is now implemented in s7_scheme_base.c */ -#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) - -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_pp (sc, port, sc->read_line_symbol, port, with_eol, - an_input_port_string, 1)); - if (!is_boolean (with_eol)) - wrong_type_error_nr (sc, sc->read_line_symbol, 2, with_eol, - a_boolean_string); - 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_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 -------------------------------- - */ -#define READ_STRING_LINE_NUMBERS \ - 0 /* 1 adds port-line-number support to read-string, doubling the time it \ - takes */ - -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. should this worry about - * newlines? read-char and read-line keep port-line-number up to date, but here - * we'd need to scan the new string (via strchr?) or xor with \n\n\n\n... up to - * 8-at-a-time, and count zeros. - */ -#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) - const s7_pointer k= car (args); - s7_pointer port, str; - s7_int nchars; - uint8_t* str_chars; - - if (!s7_is_integer (k)) - return (method_or_bust (sc, k, sc->read_string_symbol, args, - sc->type_names[T_INTEGER], 1)); - nchars= s7_integer_clamped_if_gmp (sc, k); - if (nchars < 0) - out_of_range_error_nr (sc, sc->read_string_symbol, int_one, k, - it_is_negative_string); - if (nchars > sc->max_string_length) - error_nr ( - sc, sc->out_of_range_symbol, - set_elist_3 (sc, - wrap_string (sc, - "read-string first argument ~D is greater " - "than (*s7* 'max-string-length), ~D", - 75), - wrap_integer (sc, nchars), - wrap_integer (sc, sc->max_string_length))); - 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_pp (sc, port, sc->read_string_symbol, k, port, - an_input_port_string, 2)); - if (port_is_closed (port)) - wrong_type_error_nr (sc, sc->read_string_symbol, 2, port, - an_open_input_port_string); - - str= make_empty_string (sc, nchars, '\0'); - if (nchars == 0) return (str); - str_chars= (uint8_t*) string_value (str); - if (is_string_port (port)) { - const s7_int pos= port_position (port); - const s7_int end= port_data_size (port); - s7_int len= end - pos; - if (len > nchars) len= nchars; - if (len <= 0) return (eof_object); - memcpy ((void*) str_chars, (void*) (port_data (port) + pos), len); - string_length (str)= len; - str_chars[len] = '\0'; - port_position (port)+= len; -#if READ_STRING_LINE_NUMBERS - for (s7_int i= 0; i < len; i++) - if (str_chars[i] == '\n') port_line_number (port)++; -#endif - return (str); - } - if (is_file_port (port)) { - const s7_int len= - (s7_int) fread ((void*) str_chars, 1, nchars, port_file (port)); - str_chars[len] = '\0'; - string_length (str)= len; -#if READ_STRING_LINE_NUMBERS - for (s7_int i= 0; i < len; i++) - if (str_chars[i] == '\n') port_line_number (port)++; -#endif - return (str); - } - for (s7_int i= 0; i < nchars; i++) { - const int32_t c= port_read_character (port) (sc, port); - if (c == EOF) { - if (i == 0) return (eof_object); - string_length (str)= i; - return (str); - } - str_chars[i]= (uint8_t) c; -#if READ_STRING_LINE_NUMBERS - if (c == '\n') port_line_number (port)++; -#endif - } - return (str); -} +/* peek-char, read-byte, read-line, read-string functions moved to s7_scheme_read.c */ /* -------------------------------- read -------------------------------- */ -#define declare_jump_info() \ - bool old_longjmp; \ - setjmp_loc_t old_jump_loc; \ - jump_loc_t jump_loc; \ - Jmp_Buf* old_goto_start; \ - Jmp_Buf new_goto_start - -#define store_jump_info(Sc) \ - do { \ - old_longjmp = Sc->longjmp_ok; \ - old_jump_loc = Sc->setjmp_loc; \ - old_goto_start= Sc->goto_start; \ - } while (0) +#define declare_jump_info() bool old_longjmp; setjmp_loc_t old_jump_loc; jump_loc_t jump_loc; Jmp_Buf *old_goto_start; Jmp_Buf new_goto_start -#define restore_jump_info(Sc) \ - do { \ - Sc->longjmp_ok= old_longjmp; \ - Sc->setjmp_loc= old_jump_loc; \ - Sc->goto_start= old_goto_start; \ - if ((jump_loc == error_jump) && (Sc->longjmp_ok)) \ - LongJmp (*(Sc->goto_start), error_jump); \ +#define store_jump_info(Sc) \ + do { \ + old_longjmp = Sc->longjmp_ok; \ + old_jump_loc = Sc->setjmp_loc; \ + old_goto_start = Sc->goto_start; \ } while (0) -#define set_jump_info(Sc, Tag) \ - do { \ - Sc->longjmp_ok= true; \ - Sc->setjmp_loc= Tag; \ - jump_loc = (jump_loc_t) SetJmp (new_goto_start, 1); \ - Sc->goto_start= &new_goto_start; \ +#define restore_jump_info(Sc) \ + do { \ + Sc->longjmp_ok = old_longjmp; \ + Sc->setjmp_loc = old_jump_loc; \ + Sc->goto_start = old_goto_start; \ + if ((jump_loc == error_jump) && \ + (Sc->longjmp_ok)) \ + LongJmp(*(Sc->goto_start), error_jump); \ } while (0) -static s7_pointer eval (s7_scheme* sc, opcode_t first_op); - -s7_pointer -s7_read (s7_scheme* sc, s7_pointer port) { - if (!is_input_port (port)) - sole_arg_wrong_type_error_nr (sc, sc->read_symbol, port, - an_input_port_string); - { - const s7_pointer old_let= sc->curlet; - declare_jump_info (); - set_curlet (sc, sc->rootlet); - 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) && /* pushed above */ - (stack_top_op (sc) == OP_BARRIER)) - pop_stack (sc); - } - pop_input_port (sc); - set_curlet (sc, old_let); - restore_jump_info (sc); - return (sc->value); - } -} +#define set_jump_info(Sc, Tag) \ + do { \ + Sc->longjmp_ok = true; \ + Sc->setjmp_loc = Tag; \ + jump_loc = (jump_loc_t)SetJmp(new_goto_start, 1); \ + Sc->goto_start = &new_goto_start; \ + } while (0) -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) +static s7_pointer eval(s7_scheme *sc, opcode_t first_op); +s7_pointer s7i_eval(s7_scheme *sc, s7_int op) {return(eval(sc, (opcode_t)op));} /* bridge for s7_scheme_read.c */ - s7_pointer port; - if (is_pair (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_p (sc, port, sc->read_symbol, an_input_port_string)); - - if (is_function_port (port)) { - s7_pointer result= (*(port_input_function (port))) (sc, S7_READ, port); - if (is_multiple_value (result)) { - clear_multiple_value (result); - error_nr ( - sc, sc->bad_result_symbol, - set_elist_2 ( - sc, wrap_string (sc, "input-function-port read returned: ~S", 37), - result)); - } - return (result); - } - 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 */ + 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) { - int32_t result= pthread_mutex_trylock (&sc->lock); - if (result != 0) { - fprintf (stderr, "pthread_mutex_trylock failed: %d (EBUSY: %d)", result, - EBUSY); - abort (); - } +static lock_scope_t enter_lock_scope(s7_scheme *sc) +{ + int32_t 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); + 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); - } +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) +#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) { - const s7_pointer lst= s7_load_path (sc); - if (is_pair (lst)) { +static block_t *search_load_path(s7_scheme *sc, const char *name) +{ + const s7_pointer lst = s7_load_path(sc); + if (is_pair(lst)) + { #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* */ + #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 + #define S7_FILENAME_MAX 1024 #endif - /* linux: PATH_MAX: 4096, windows: MAX_PATH: unlimited?, Mac: 1016?, BSD: - * MAX_PATH_LENGTH: 1024 */ - block_t* b = mallocate (sc, S7_FILENAME_MAX); - char* filename= (char*) block_data (b); - const s7_int name_len= safe_strlen (name); - for (s7_pointer 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); + /* linux: PATH_MAX: 4096, windows: MAX_PATH: unlimited?, Mac: 1016?, BSD: MAX_PATH_LENGTH: 1024 */ + block_t *b = mallocate(sc, S7_FILENAME_MAX); + char *filename = (char *)block_data(b); + const s7_int name_len = safe_strlen(name); + for (s7_pointer 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); + if (_access(filename, 0) != -1) + return(b); #else - if (access (filename, F_OK) == 0) return (b); + if (access(filename, F_OK) == 0) + return(b); #endif - } + }} + liberate(sc, b); } - liberate (sc, b); - } - return (NULL); + return(NULL); } #if WITH_C_LOADER #include -static block_t* -full_filename (s7_scheme* sc, const char* filename) { - char* new_name; - block_t* block; - if ((S7_DEBUGGING) && ((!filename) || (!*filename))) - fprintf (stderr, "%s[%d]: filename is %s\n", __func__, __LINE__, filename); - if (filename[0] == '/') { - const s7_int len= safe_strlen (filename); - block = mallocate (sc, len + 1); - new_name = (char*) block_data (block); - memcpy ((void*) new_name, (const void*) filename, len); - new_name[len]= '\0'; - } - else { - char* pwd= getcwd (NULL, 0); /* docs say this means it will return a new - string of the right size */ - const size_t pwd_len = safe_strlen (pwd); - const size_t filename_len= safe_strlen (filename); - const s7_int len= - pwd_len + filename_len + - 2; /* not 1! we need room for the '/' and the terminating 0 */ - block = mallocate (sc, len); - new_name= (char*) block_data (block); - if (pwd) { - memcpy ((void*) new_name, (void*) pwd, pwd_len); - new_name[pwd_len]= '/'; - memcpy ((void*) (new_name + pwd_len + 1), (const void*) filename, - filename_len); - new_name[pwd_len + filename_len + 1]= '\0'; - free (pwd); - } - else /* can this happen in glibc? */ +static block_t *full_filename(s7_scheme *sc, const char *filename) +{ + char *new_name; + block_t *block; + if ((S7_DEBUGGING) && ((!filename) || (!*filename))) fprintf(stderr, "%s[%d]: filename is %s\n", __func__, __LINE__, filename); + if (filename[0] == '/') { - if (sc->safety > no_safety) - s7_warn (sc, 256, "getcwd: %s\n", strerror (errno)); - memcpy ((void*) new_name, (const void*) filename, filename_len); - new_name[filename_len]= '\0'; + const s7_int len = safe_strlen(filename); + block = mallocate(sc, len + 1); + new_name = (char *)block_data(block); + memcpy((void *)new_name, (const void *)filename, len); + new_name[len] = '\0'; } - } - return (block); + else + { + char *pwd = getcwd(NULL, 0); /* docs say this means it will return a new string of the right size */ + const size_t pwd_len = safe_strlen(pwd); + const size_t filename_len = safe_strlen(filename); + const s7_int len = pwd_len + filename_len + 2; /* not 1! we need room for the '/' and the terminating 0 */ + block = mallocate(sc, len); + new_name = (char *)block_data(block); + if (pwd) + { + memcpy((void *)new_name, (void *)pwd, pwd_len); + new_name[pwd_len] = '/'; + memcpy((void *)(new_name + pwd_len + 1), (const void *)filename, filename_len); + new_name[pwd_len + filename_len + 1] = '\0'; + free(pwd); + } + else /* can this happen in glibc? */ + { + if (sc->safety > no_safety) + s7_warn(sc, 256, "getcwd: %s\n", strerror(errno)); + memcpy((void *)new_name, (const void *)filename, filename_len); + new_name[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|.dylib, try loading it as a C shared object: (load - * "/home/bil/cl/m_j0.so" (inlet 'init_func 'init_m_j0)) */ - const s7_int fname_len= safe_strlen (fname); +static s7_pointer load_shared_object(s7_scheme *sc, const char *fname, s7_pointer let) +{ + /* if fname ends in .so|.dylib, try loading it as a C shared object: (load "/home/bil/cl/m_j0.so" (inlet 'init_func 'init_m_j0)) */ + const s7_int fname_len = safe_strlen(fname); if (((fname_len > 3) && - (local_strcmp ((const char*) (fname + (fname_len - 3)), - ".so"))) || /* linux */ + (local_strcmp((const char *)(fname + (fname_len - 3)), ".so"))) || /* linux */ ((fname_len > 6) && - (local_strcmp ((const char*) (fname + (fname_len - 3)), - ".dylib")))) /* mac */ - { - 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= - 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 { /* this is necessary, at least in Linux -- we can't blithely - dlopen whatever is passed to us */ - pname= full_filename (sc, (const char*) block_data (searched)); - 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); - } - } - if ((S7_DEBUGGING) && (!pname)) - fprintf (stderr, "%s[%d]: pname is null\n", __func__, __LINE__); - 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 -- let has been checked by - caller that it actually is a let */ - { - const s7_pointer init= - let_ref_p_pp (sc, let, make_symbol (sc, "init_func", 9)); - /* 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, - 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); - const s7_pointer init_args= - let_ref_p_pp (sc, let, make_symbol (sc, "init_args", 9)); - s7_pointer result; - gc_protect_via_stack (sc, init_args); - if (is_pair (init_args)) { - result= ((dl_func_with_args) init_func) (sc, init_args); - set_gc_protected2 (sc, result); - } - /* 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 an s7_cell pointer (scan - * permallocs and use heap_location?) - */ - ((dl_func) init_func) (sc); - result= sc->F; - } - unstack_gc_protect (sc); - if (pname) liberate (sc, pname); - return (result); - } - 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); + (local_strcmp((const char *)(fname + (fname_len - 3)), ".dylib")))) /* mac */ + { + 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 = 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 + { /* this is necessary, at least in Linux -- we can't blithely dlopen whatever is passed to us */ + pname = full_filename(sc, (const char *)block_data(searched)); + 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); + }} + if ((S7_DEBUGGING) && (!pname)) fprintf(stderr, "%s[%d]: pname is null\n", __func__, __LINE__); + 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 -- let has been checked by caller that it actually is a let */ + { + const s7_pointer init = let_ref_p_pp(sc, let, make_symbol(sc, "init_func", 9)); + /* 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, 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); + const s7_pointer init_args = let_ref_p_pp(sc, let, make_symbol(sc, "init_args", 9)); + s7_pointer result; + gc_protect_via_stack(sc, init_args); + if (is_pair(init_args)) + { + result = ((dl_func_with_args)init_func)(sc, init_args); + set_gc_protected2(sc, result); + } + /* 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 an s7_cell pointer (scan permallocs and use heap_location?) + */ + ((dl_func)init_func)(sc); + result = sc->F; + } + unstack_gc_protect(sc); + if (pname) liberate(sc, pname); + return(result); + } + 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) { - char* local_file_name= NULL; - FILE* fp = fopen (filename, "r"); +static s7_pointer load_file_1(s7_scheme *sc, const char *filename) +{ + char *local_file_name = NULL; + FILE* fp = fopen(filename, "r"); #if WITH_GCC - if (!fp) /* catch one special case, "~/..." since it causes 99.9% of the - "can't load ..." errors */ - { - block_t* b= expand_filename (sc, filename); - if (b) { - fp= fopen ((char*) block_data (b), "r"); - if (fp) local_file_name= copy_string ((char*) block_data (b)); - liberate (sc, b); - } - } + if (!fp) /* catch one special case, "~/..." since it causes 99.9% of the "can't load ..." errors */ + { + block_t *b = expand_filename(sc, filename); + if (b) + { + fp = fopen((char *)block_data(b), "r"); + if (fp) local_file_name = copy_string((char *)block_data(b)); + liberate(sc, b); + }} #endif - if (!fp) { - const char* fname; - block_t* b= search_load_path (sc, filename); - if (!b) return (NULL); - fname= (const char*) block_data (b); - fp = fopen (fname, "r"); - if (fp) - local_file_name= copy_string_with_length (fname, safe_strlen (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, - s7_make_string (sc, (local_file_name) ? local_file_name - : filename))); - port= read_file (sc, fp, (local_file_name) ? local_file_name : filename, -1, - "load"); /* -1 = read entire file into string, this is - currently not tweakable */ - port_file_number (port)= - remember_file_name (sc, (local_file_name) ? local_file_name : filename); - if (local_file_name) free (local_file_name); - set_loader_port (port); - if ((is_string_port (port)) && (port_data_size (port) >= 2) && - (port_data (port)[0] == '#') && (port_data (port)[1] == '!')) { - uint8_t* data= port_data (port); - s7_int pos = 0; - while (pos < port_data_size (port) && data[pos] != '\n') - pos++; - if (pos < port_data_size (port)) port_position (port)= pos + 1; - else port_position (port)= port_data_size (port); - } - else if (is_file_port (port)) { - int32_t c0= fgetc (port_file (port)); - if (c0 != EOF) { - int32_t c1= fgetc (port_file (port)); - if ((c0 == '#') && (c1 == '!')) { - int32_t c; - while (((c= fgetc (port_file (port))) != EOF) && (c != '\n')) { - } - } - else { - if (c1 != EOF) ungetc (c1, port_file (port)); - ungetc (c0, port_file (port)); + if (!fp) + { + const char *fname; + block_t *b = search_load_path(sc, filename); + if (!b) return(NULL); + fname = (const char *)block_data(b); + fp = fopen(fname, "r"); + if (fp) local_file_name = copy_string_with_length(fname, safe_strlen(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, s7_make_string(sc, (local_file_name) ? local_file_name : filename))); + port = read_file(sc, fp, (local_file_name) ? local_file_name : filename, -1, "load"); /* -1 = read entire file into string, this is currently not tweakable */ + port_file_number(port) = remember_file_name(sc, (local_file_name) ? local_file_name : filename); + if (local_file_name) free(local_file_name); + set_loader_port(port); + if ((is_string_port(port)) && + (port_data_size(port) >= 2) && + (port_data(port)[0] == '#') && + (port_data(port)[1] == '!')) + { + uint8_t *data = port_data(port); + s7_int pos = 0; + while (pos < port_data_size(port) && data[pos] != '\n') + pos++; + if (pos < port_data_size(port)) + port_position(port) = pos + 1; + else port_position(port) = port_data_size(port); } - } + else + if (is_file_port(port)) + { + int32_t c0 = fgetc(port_file(port)); + if (c0 != EOF) + { + int32_t c1 = fgetc(port_file(port)); + if ((c0 == '#') && + (c1 == '!')) + { + int32_t c; + while (((c = fgetc(port_file(port))) != EOF) && + (c != '\n')) + {} + } + else + { + if (c1 != EOF) + ungetc(c1, port_file(port)); + ungetc(c0, port_file(port)); + } + } + } + push_input_port(sc, port); + return(port); } - push_input_port (sc, port); - return (port); - } - return (NULL); + return(NULL); } -s7_pointer -s7_load_with_environment (s7_scheme* sc, const char* filename, s7_pointer let) { - /* returns either the value of the load or NULL if filename not found or if - * the optional let is *s7* */ +s7_pointer s7_load_with_environment(s7_scheme *sc, const char *filename, s7_pointer let) +{ + /* returns either the value of the load or NULL if filename not found or if the optional let is *s7* */ s7_pointer port; - declare_jump_info (); - TRACK (sc); - if (let == sc->starlet) return (NULL); - if (!is_let (let)) { - s7_pointer obj_let= find_let (sc, let); - if (!is_let (obj_let)) - s7_warn (sc, 128, - "third argument to s7_load_with_environment is not a let or an " - "object that has a let"); - else let= obj_let; - } + declare_jump_info(); + TRACK(sc); + if (let == sc->starlet) return(NULL); + if (!is_let(let)) + { + s7_pointer obj_let = find_let(sc, let); + if (!is_let(obj_let)) + s7_warn(sc, 128, "third argument to s7_load_with_environment is not a let or an object that has a let"); + else let = obj_let; + } #if WITH_C_LOADER - port= load_shared_object (sc, filename, let); - if (port) return (port); + port = load_shared_object(sc, filename, let); + if (port) return(port); #endif - if (is_directory (filename)) return (NULL); - port= load_file_1 (sc, filename); - if (!port) return (NULL); + if (is_directory(filename)) return(NULL); + port = load_file_1(sc, filename); + if (!port) return(NULL); + + set_curlet(sc, let); + 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->rootlet));} - set_curlet (sc, let); - push_stack (sc, OP_LOAD_RETURN_IF_EOF, port, sc->code); +s7_pointer s7_load_c_string_with_environment(s7_scheme *sc, const char *content, s7_int bytes, s7_pointer let) +{ + s7_pointer port; + s7_int port_loc; + declare_jump_info(); + TRACK(sc); - 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 (bytes == 0) + bytes = strlen(content); + else + if (content[bytes] != 0) + error_nr(sc, make_symbol(sc, "bad-data", 8), set_elist_1(sc, wrap_string(sc, "s7_load_c_string content is not null terminated", 47))); + 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, let); + 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); + 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->rootlet)); +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->rootlet)); } -s7_pointer -s7_load_c_string_with_environment (s7_scheme* sc, const char* content, - s7_int bytes, s7_pointer let) { - s7_pointer port; - s7_int port_loc; - declare_jump_info (); - TRACK (sc); - - if (bytes == 0) bytes= strlen (content); - else if (content[bytes] != 0) - error_nr (sc, make_symbol (sc, "bad-data", 8), - set_elist_1 ( - sc, wrap_string ( - sc, "s7_load_c_string content is not null terminated", - 47))); - 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, let); - 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); -} - -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->rootlet)); -} - -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 \ +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, \ - has_let_signature (sc)) + #define Q_load s7_make_signature(sc, 3, sc->values_symbol, sc->is_string_symbol, has_let_signature(sc)) - const s7_pointer name= car (args); - const char* fname; + const s7_pointer name = car(args); + const char *fname; - if (!is_string (name)) - return (method_or_bust (sc, name, sc->load_symbol, args, - sc->type_names[T_STRING], 1)); + if (!is_string(name)) + return(method_or_bust(sc, name, sc->load_symbol, args, sc->type_names[T_STRING], 1)); - if (is_pair (cdr (args))) { - s7_pointer let= cadr (args); - if (!is_let (let)) { - s7_pointer new_let= find_let (sc, let); - if (!is_let (new_let)) - find_let_error_nr (sc, sc->load_symbol, let, new_let, 2, args); - let= new_let; - } - if (let == sc->starlet) - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_2 ( - sc, wrap_string (sc, "can't load ~S into *s7*", 23), name)); - set_curlet (sc, let); - } - else set_curlet (sc, sc->rootlet); - - fname= string_value (name); - if ((!fname) || (!*fname)) /* fopen("", "r") returns a file pointer?? */ - error_nr ( - 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 (is_directory (fname)) - error_nr (sc, sc->io_error_symbol, - set_elist_2 (sc, wrap_string (sc, "load: ~S is a directory", 23), - wrap_string (sc, fname, safe_strlen (fname)))); + if (is_pair(cdr(args))) + { + s7_pointer let = cadr(args); + if (!is_let(let)) + { + s7_pointer new_let = find_let(sc, let); + if (!is_let(new_let)) + find_let_error_nr(sc, sc->load_symbol, let, new_let, 2, args); + let = new_let; + } + if (let == sc->starlet) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "can't load ~S into *s7*", 23), name)); + set_curlet(sc, let); + } + else set_curlet(sc, sc->rootlet); + + fname = string_value(name); + if ((!fname) || (!*fname)) /* fopen("", "r") returns a file pointer?? */ + error_nr(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 (is_directory(fname)) + error_nr(sc, sc->io_error_symbol, + set_elist_2(sc, wrap_string(sc, "load: ~S is a directory", 23), wrap_string(sc, fname, safe_strlen(fname)))); #if WITH_C_LOADER { - s7_pointer p= load_shared_object (sc, fname, sc->curlet); - if (p) return (p); + s7_pointer p = load_shared_object(sc, fname, sc->curlet); + if (p) return(p); } #endif - errno= 0; - if (!load_file_1 (sc, fname)) - file_error_nr (sc, "load", strerror (errno), fname); + errno = 0; + if (!load_file_1(sc, fname)) + file_error_nr(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); + 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_local_value (sc, sc->load_path_symbol, sc->curlet)); -} +s7_pointer s7_load_path(s7_scheme *sc) {return(s7_symbol_local_value(sc, sc->load_path_symbol, sc->curlet));} -s7_pointer -s7_add_to_load_path (s7_scheme* sc, const char* dir) { - s7_pointer slot= lookup_slot_from (sc->load_path_symbol, - sc->curlet); /* rootlet possible here */ - s7_pointer path= cons (sc, s7_make_string (sc, dir), slot_value (slot)); - slot_set_value (slot, path); - return (path); +s7_pointer s7_add_to_load_path(s7_scheme *sc, const char *dir) +{ + s7_pointer slot = lookup_slot_from(sc->load_path_symbol, sc->curlet); /* rootlet possible here */ + s7_pointer path = cons(sc, s7_make_string(sc, dir), slot_value(slot)); + slot_set_value(slot, path); + return(path); } /* ---------------- 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. +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 > immutable_vector_safety) - for (int32_t 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) { - 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 (s7_int 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; + for (int32_t 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; } - } - 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)); + else + if (sc->autoload_names_loc >= sc->autoload_names_top) + { + 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 (s7_int 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++; } -const char* -find_autoload_name (s7_scheme* sc, s7_pointer symbol, bool* already_loaded, - bool loading) { - s7_int libs= sc->autoload_names_loc; - const char* name= symbol_name (symbol); - for (s7_int lib= 0, l= 0; lib < libs; lib++) { - s7_int u = sc->autoload_names_sizes[lib] - 1; - const char** 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); +const char *find_autoload_name(s7_scheme *sc, s7_pointer symbol, bool *already_loaded, bool loading) +{ + s7_int libs = sc->autoload_names_loc; + const char *name = symbol_name(symbol); + for (s7_int lib = 0, l = 0; lib < libs; lib++) + { + s7_int u = sc->autoload_names_sizes[lib] - 1; + const char **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) { +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, 32); /* add_hash_table here, perhaps sc->hash_tables->loc-- */ - if (sc->safety >= more_safety_warnings) { - s7_pointer p= s7_hash_table_ref (sc, sc->autoload_table, symbol); - if ((p != missing_key_value (sc)) && (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); + if (is_null(sc->autoload_table)) + sc->autoload_table = s7_make_hash_table(sc, 32); /* add_hash_table here, perhaps sc->hash_tables->loc-- */ + if (sc->safety >= more_safety_warnings) + { + s7_pointer p = s7_hash_table_ref(sc, sc->autoload_table, symbol); + if ((p != missing_key_value(sc)) && (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); } -bool -s7i_is_closure (s7_pointer p) { - return is_closure (p); -} -bool -s7i_is_closure_star (s7_pointer p) { - return is_closure_star (p); -} -s7_pointer -s7i_missing_key_value (s7_scheme* sc) { - return missing_key_value (sc); -} -const char* -s7i_find_autoload_name (s7_scheme* sc, s7_pointer symbol, bool* already_loaded, - bool loading) { - return find_autoload_name (sc, symbol, already_loaded, loading); +bool s7i_is_closure(s7_pointer p) { return is_closure(p); } +bool s7i_is_closure_star(s7_pointer p) { return is_closure_star(p); } +s7_pointer s7i_missing_key_value(s7_scheme *sc) { return missing_key_value(sc); } +const char *s7i_find_autoload_name(s7_scheme *sc, s7_pointer symbol, bool *already_loaded, bool loading) +{ + return find_autoload_name(sc, symbol, already_loaded, loading); } /* -------- *cload-directory* -------- */ -static s7_pointer -g_cload_directory_set (s7_scheme* sc, s7_pointer args) { +static s7_pointer g_cload_directory_set(s7_scheme *sc, s7_pointer args) +{ /* this sets the directory for cload.scm's output */ - const s7_pointer cl_dir= cadr (args); - if (!is_string (cl_dir)) - error_nr (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 (string_length (cl_dir) > 0) /* was strlen(string_value)? */ - 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); -} - -static s7_pointer -g_autoload (s7_scheme* sc, s7_pointer args) { - s7_pointer sym= car (args), value; - if (is_string (sym)) { - if (string_length (sym) == 0) /* (autoload "" ...) */ - wrong_type_error_nr (sc, sc->autoload_symbol, 1, sym, - wrap_string (sc, "a symbol-name or a symbol", 25)); - sym= make_symbol (sc, string_value (sym), string_length (sym)); - } - if (!is_symbol (sym)) { - if_method_exists_return_value (sc, sym, sc->autoload_symbol, args); - wrong_type_error_nr ( - sc, sc->autoload_symbol, 1, sym, - wrap_string (sc, "a string (symbol-name) or a symbol", 34)); - } - if (is_keyword (sym)) - wrong_type_error_nr ( - sc, sc->autoload_symbol, 1, sym, - wrap_string (sc, "a normal symbol (a keyword is never unbound)", 44)); - - value= cadr (args); - if (is_string (value)) - return (s7_autoload ( - sc, sym, - s7_set_immutable ( - sc, make_string_with_length ( - sc, string_value (value), - string_length ( - value))))); /* s7_set_immutable to pass arg through */ - if (((is_closure (value)) || (is_closure_star (value))) && - (s7_is_aritable (sc, value, 1))) - return (s7_autoload (sc, sym, value)); - - if_method_exists_return_value (sc, value, sc->autoload_symbol, args); - wrong_type_error_nr (sc, sc->autoload_symbol, 2, value, - wrap_string (sc, "a string (file-name) or a thunk", 31)); + const s7_pointer cl_dir = cadr(args); + if (!is_string(cl_dir)) + error_nr(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 (string_length(cl_dir) > 0) /* was strlen(string_value)? */ + 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); +} + +static s7_pointer g_autoload(s7_scheme *sc, s7_pointer args) +{ + s7_pointer sym = car(args), value; + if (is_string(sym)) + { + if (string_length(sym) == 0) /* (autoload "" ...) */ + wrong_type_error_nr(sc, sc->autoload_symbol, 1, sym, wrap_string(sc, "a symbol-name or a symbol", 25)); + sym = make_symbol(sc, string_value(sym), string_length(sym)); + } + if (!is_symbol(sym)) + { + if_method_exists_return_value(sc, sym, sc->autoload_symbol, args); + wrong_type_error_nr(sc, sc->autoload_symbol, 1, sym, wrap_string(sc, "a string (symbol-name) or a symbol", 34)); + } + if (is_keyword(sym)) + wrong_type_error_nr(sc, sc->autoload_symbol, 1, sym, wrap_string(sc, "a normal symbol (a keyword is never unbound)", 44)); + + value = cadr(args); + if (is_string(value)) + return(s7_autoload(sc, sym, s7_set_immutable(sc, make_string_with_length(sc, string_value(value), string_length(value))))); /* s7_set_immutable to pass arg through */ + if (((is_closure(value)) || (is_closure_star(value))) && + (s7_is_aritable(sc, value, 1))) + return(s7_autoload(sc, sym, value)); + + if_method_exists_return_value(sc, value, sc->autoload_symbol, args); + wrong_type_error_nr(sc, sc->autoload_symbol, 2, value, wrap_string(sc, "a string (file-name) or a thunk", 31)); #ifdef __TINYC__ - return (NULL); /* make tcc happy */ + return(NULL); /* make tcc happy */ #endif } -/* -------------------------------- *autoload* -------------------------------- - */ -static s7_pointer -g_autoloader (s7_scheme* sc, s7_pointer args) /* the *autoload* function */ -{ - const s7_pointer sym= car (args); - if (!is_symbol (sym)) { - if_method_exists_return_value (sc, sym, sc->autoloader_symbol, - set_plist_1 (sc, sym)); - wrong_type_error_nr (sc, wrap_string (sc, "*autoload*", 10), 1, sym, - sc->type_names[T_SYMBOL]); - } - if (sc->autoload_names) { - bool loaded= false; - const char* file = find_autoload_name (sc, sym, &loaded, false); - if (file) return (s7_make_string (sc, file)); - } - if (is_hash_table (sc->autoload_table)) { - s7_pointer val= s7_hash_table_ref (sc, sc->autoload_table, sym); - if (val != missing_key_value (sc)) return (val); - } - return (sc->F); +/* -------------------------------- *autoload* -------------------------------- */ +static s7_pointer g_autoloader(s7_scheme *sc, s7_pointer args) /* the *autoload* function */ +{ + const s7_pointer sym = car(args); + if (!is_symbol(sym)) + { + if_method_exists_return_value(sc, sym, sc->autoloader_symbol, set_plist_1(sc, sym)); + wrong_type_error_nr(sc, wrap_string(sc, "*autoload*", 10), 1, sym, sc->type_names[T_SYMBOL]); + } + if (sc->autoload_names) + { + bool loaded = false; + const char *file = find_autoload_name(sc, sym, &loaded, false); + if (file) + return(s7_make_string(sc, file)); + } + if (is_hash_table(sc->autoload_table)) + { + s7_pointer val = s7_hash_table_ref(sc, sc->autoload_table, sym); + if (val != missing_key_value(sc)) return(val); + } + return(sc->F); } /* ---------------- require ---------------- */ -static bool -is_a_feature (const s7_pointer sym, - s7_pointer lst) /* used only with *features* which (sigh) can be - circular: (set-cdr! *features* *features*) */ -{ - s7_pointer p= lst, slow= lst; - while (true) { - if (!is_pair (p)) return (false); - if (sym == car (p)) return (true); - p= cdr (p); - if (!is_pair (p)) return (false); - if (sym == car (p)) return (true); - p = cdr (p); - slow= cdr (slow); - if (p == slow) return (false); - } - return (false); +static bool is_a_feature(const s7_pointer sym, s7_pointer lst) /* used only with *features* which (sigh) can be circular: (set-cdr! *features* *features*) */ +{ + s7_pointer p = lst, slow = lst; + while (true) + { + if (!is_pair(p)) return(false); + if (sym == car(p)) return(true); + p = cdr(p); + if (!is_pair(p)) return(false); + if (sym == car(p)) return(true); + p = cdr(p); + slow = cdr(slow); + if (p == slow) return(false); + } + 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.\ +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) */ + /* #define Q_require s7_make_circular_signature(sc, 1, 2, sc->T, sc->is_symbol_symbol) */ - gc_protect_via_stack (sc, args); - for (s7_pointer syms= args; is_pair (syms); syms= cdr (syms)) { - s7_pointer sym; - if (is_symbol (car (syms))) sym= car (syms); - else if ((is_proper_quote (sc, car (syms))) && (is_symbol (cadar (syms)))) - sym= cadar (syms); - else { - unstack_gc_protect (sc); - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_2 (sc, wrap_string (sc, "require: ~S is not a symbol", 27), - car (syms))); - } - if (!is_a_feature ( - sym, - s7_symbol_value (sc, sc->features_symbol))) /* if on *features* it's - already loaded */ - { - if (sc->is_autoloading) { - const s7_pointer func= g_autoloader (sc, set_plist_1 (sc, sym)); - if (is_false (sc, func)) { - unstack_gc_protect (sc); - error_nr ( - 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, func)); - if (is_string (func)) - s7_load_with_environment (sc, string_value (func), sc->curlet); - else if (is_closure ( - func)) /* func should be a function of one argument, the - current (calling) environment */ - s7_call (sc, func, set_ulist_1 (sc, sc->curlet, sc->nil)); - } + gc_protect_via_stack(sc, args); + for (s7_pointer syms = args; is_pair(syms); syms = cdr(syms)) + { + s7_pointer sym; + if (is_symbol(car(syms))) + sym = car(syms); else - s7_warn (sc, 256, - "require: can't load %s because (*s7* 'autoloading?) is #f\n", - symbol_name (sym)); - } - } - if (stack_top_op (sc) == OP_GC_PROTECT) - unstack_gc_protect (sc); /* op_error_quit if load failed in scheme in Snd */ - return (sc->T); + if ((is_proper_quote(sc, car(syms))) && + (is_symbol(cadar(syms)))) + sym = cadar(syms); + else + { + unstack_gc_protect(sc); + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "require: ~S is not a symbol", 27), car(syms))); + } + if (!is_a_feature(sym, s7_symbol_value(sc, sc->features_symbol))) /* if on *features* it's already loaded */ + { + if (sc->is_autoloading) + { + const s7_pointer func = g_autoloader(sc, set_plist_1(sc, sym)); + if (is_false(sc, func)) + { + unstack_gc_protect(sc); + error_nr(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, func)); + if (is_string(func)) + s7_load_with_environment(sc, string_value(func), sc->curlet); + else + if (is_closure(func)) /* func should be a function of one argument, the current (calling) environment */ + s7_call(sc, func, set_ulist_1(sc, sc->curlet, sc->nil)); + } + else s7_warn(sc, 256, "require: can't load %s because (*s7* 'autoloading?) is #f\n", symbol_name(sym)); + }} + if (stack_top_op(sc) == OP_GC_PROTECT) unstack_gc_protect(sc); /* op_error_quit if load failed in scheme in Snd */ + 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) - - const s7_pointer sym= car (args); - s7_pointer topf, let; - if (!is_symbol (sym)) - return (method_or_bust_p (sc, sym, sc->is_provided_symbol, - sc->type_names[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. +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) + + const s7_pointer sym = car(args); + s7_pointer topf, let; + if (!is_symbol(sym)) + return(method_or_bust_p(sc, sym, sc->is_provided_symbol, sc->type_names[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_a_feature (sym, topf)) return (sc->T); - - if (is_global (sc->features_symbol)) return (sc->F); - for (let= sc->curlet; let_id (let) > symbol_id (sc->features_symbol); - let= let_outlet (let)) - ; - for (; let; let= let_outlet (let)) - for (s7_pointer slot= let_slots (let); is_not_slot_end (slot); - slot = next_slot (slot)) - if ((slot_symbol (slot) == sc->features_symbol) && - (slot_value (slot) != topf) && - (is_a_feature (sym, slot_value (slot)))) - return (sc->T); - return (sc->F); -} - -bool -s7_is_provided (s7_scheme* sc, const char* feature) { - return (is_a_feature ( - make_symbol_with_strlen (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_p (sc, sym, sc->is_provided_symbol, - sc->type_names[T_SYMBOL]) != sc->F); - return (is_a_feature (sym, s7_symbol_value (sc, sc->features_symbol))); + topf = global_value(sc->features_symbol); + if (is_a_feature(sym, topf)) + return(sc->T); + + if (is_global(sc->features_symbol)) + return(sc->F); + for (let = sc->curlet; let_id(let) > symbol_id(sc->features_symbol); let = let_outlet(let)); + for (; let; let = let_outlet(let)) + for (s7_pointer slot = let_slots(let); is_not_slot_end(slot); slot = next_slot(slot)) + if ((slot_symbol(slot) == sc->features_symbol) && + (slot_value(slot) != topf) && + (is_a_feature(sym, slot_value(slot)))) + return(sc->T); + return(sc->F); +} + +bool s7_is_provided(s7_scheme *sc, const char *feature) +{ + return(is_a_feature(make_symbol_with_strlen(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_p(sc, sym, sc->is_provided_symbol, sc->type_names[T_SYMBOL]) != sc->F); + return(is_a_feature(sym, s7_symbol_value(sc, sc->features_symbol))); +} + + /* ---------------- provide ---------------- */ -static s7_pointer -c_provide (s7_scheme* sc, s7_pointer sym) { +static s7_pointer c_provide(s7_scheme *sc, s7_pointer sym) +{ /* this has to be relative to the curlet: (load file let) - * the things loaded are only present in let, and go away with it, so should - * not be in the global *features* list + * the things loaded are only present in let, and go away with it, so should not be in the global *features* list */ s7_pointer features; - if (!is_symbol (sym)) - return (method_or_bust_p (sc, sym, sc->provide_symbol, - sc->type_names[T_SYMBOL])); - if ((sc->curlet == sc->rootlet) || - (sc->curlet == sc->shadow_rootlet)) /* sc->curlet can also be (for - example) the repl top-level */ - features= global_slot (sc->features_symbol); + if (!is_symbol(sym)) + return(method_or_bust_p(sc, sym, sc->provide_symbol, sc->type_names[T_SYMBOL])); + if ((sc->curlet == sc->rootlet) || (sc->curlet == sc->shadow_rootlet)) /* sc->curlet can also be (for example) the repl top-level */ + features = global_slot(sc->features_symbol); + else features = 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(features)) && (is_immutable_slot(features))) + s7_warn(sc, 256, "provide: *features* is immutable!\n"); else - features= 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 (features)) && (is_immutable_slot (features))) - s7_warn (sc, 256, "provide: *features* is immutable!\n"); - else { - const s7_pointer lst= slot_value ( - s7_t_slot (sc, sc->features_symbol)); /* in either case, we want the - current *features* list */ - if (features == sc->undefined) { - /* (setter symbol) follows local lets, so we need to make sure this one is - * set */ - s7_pointer slot= add_slot_checked_with_id ( - sc, sc->curlet, sc->features_symbol, cons (sc, sym, lst)); - slot_set_setter (slot, sc->features_setter); - slot_set_has_setter (slot); - } - else if ((!is_a_feature (sym, lst)) && - (!is_a_feature (sym, slot_value (features)))) - slot_set_value (features, cons (sc, sym, slot_value (features))); - } - return (sym); + { + const s7_pointer lst = slot_value(s7_t_slot(sc, sc->features_symbol)); /* in either case, we want the current *features* list */ + if (features == sc->undefined) + { + /* (setter symbol) follows local lets, so we need to make sure this one is set */ + s7_pointer slot = add_slot_checked_with_id(sc, sc->curlet, sc->features_symbol, cons(sc, sym, lst)); + slot_set_setter(slot, sc->features_setter); + slot_set_has_setter(slot); + } + else + if ((!is_a_feature(sym, lst)) && (!is_a_feature(sym, slot_value(features)))) + slot_set_value(features, cons(sc, sym, slot_value(features))); + } + 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) +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)) - immutable_object_error_nr ( - sc, - set_elist_2 ( - sc, - wrap_string ( - sc, "can't provide '~S (current environment is immutable)", 52), - car (args))); - return (c_provide (sc, car (args))); + if ((is_immutable(sc->curlet)) && + (sc->curlet != sc->nil)) + immutable_object_error_nr(sc, 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, make_symbol_with_strlen (sc, feature)); -} +void s7_provide(s7_scheme *sc, const char *feature) {c_provide(sc, make_symbol_with_strlen(sc, feature));} -/* -------------------------------- eval-string -------------------------------- - */ -s7_pointer -s7_eval_c_string_with_environment (s7_scheme* sc, const char* str, - s7_pointer let) { + +/* -------------------------------- eval-string -------------------------------- */ +s7_pointer s7_eval_c_string_with_environment(s7_scheme *sc, const char *str, s7_pointer let) +{ 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_Ext (code), let); - if (stack_top_op_unchecked (sc) == OP_GC_PROTECT) - unstack_gc_protect (sc); /* 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, \ - has_let_signature (sc)) - - const s7_pointer str= car (args); - if (!is_string (str)) - return (method_or_bust (sc, str, sc->eval_string_symbol, args, - sc->type_names[T_STRING], 1)); - if (string_length (str) == 0) return (sc->F); /* (eval-string "") -> #f */ - if (is_pair (cdr (args))) { - s7_pointer let= cadr (args); - if (!is_let (let)) { - s7_pointer new_let= find_let (sc, let); - if (!is_let (new_let)) - find_let_error_nr (sc, sc->eval_string_symbol, let, new_let, 2, args); - let= new_let; - } - set_curlet (sc, let); - } - begin_temp (sc->temp6, sc->args); /* see t101-17.scm */ - push_stack (sc, OP_EVAL_STRING, args, sc->code); - { - s7_pointer port= open_and_protect_input_string (sc, str); - push_input_port (sc, port); - } - push_stack_op_let (sc, OP_READ_INTERNAL); - end_temp (sc->temp6); - return (sc->F); /* I think this means that sc->value defaults to #f in - op_eval_string below, so (eval-string "") mimics (eval) -> - #f */ + 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_Ext(code), let); + if (stack_top_op_unchecked(sc) == OP_GC_PROTECT) unstack_gc_protect(sc); /* pop_stack(sc); */ + return(result); } -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") */ +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, has_let_signature(sc)) + + const s7_pointer str = car(args); + if (!is_string(str)) + return(method_or_bust(sc, str, sc->eval_string_symbol, args, sc->type_names[T_STRING], 1)); + if (string_length(str) == 0) + return(sc->F); /* (eval-string "") -> #f */ + if (is_pair(cdr(args))) + { + s7_pointer let = cadr(args); + if (!is_let(let)) + { + s7_pointer new_let = find_let(sc, let); + if (!is_let(new_let)) + find_let_error_nr(sc, sc->eval_string_symbol, let, new_let, 2, args); + let = new_let; + } + set_curlet(sc, let); + } + begin_temp(sc->temp6, sc->args); /* see t101-17.scm */ + push_stack(sc, OP_EVAL_STRING, args, sc->code); { - int32_t tk= - token (sc); /* (eval-string "(+ 1 2) ; a comment (not a mistake)") */ - if (tk != token_eof) { - s7_pointer trail_data; - s7_int 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= wrap_string ( - 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); - error_nr (sc, sc->read_error_symbol, - set_elist_2 ( - sc, wrap_string (sc, "eval-string trailing junk: ~S", 29), - trail_data)); - } + s7_pointer port = open_and_protect_input_string(sc, str); + push_input_port(sc, port); } - 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) { - const s7_pointer proc= cadr (args); - if (SHOW_EVAL_OPS) - fprintf (stderr, " call_with_input %s %s\n", display (car (args)), - display (proc)); - port_set_string_or_function (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), proc); - 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 + push_stack_op_let(sc, OP_READ_INTERNAL); + end_temp(sc->temp6); + 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 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 = token(sc); /* (eval-string "(+ 1 2) ; a comment (not a mistake)") */ + if (tk != token_eof) + { + s7_pointer trail_data; + s7_int 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 = wrap_string(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); + error_nr(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) +{ + const s7_pointer proc = cadr(args); + if (SHOW_EVAL_OPS) fprintf(stderr, " call_with_input %s %s\n", display(car(args)), display(proc)); + port_set_string_or_function(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), proc); + 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 */ - const s7_pointer str= car (args), proc= cadr (args); - if (!is_string (str)) - return (method_or_bust (sc, str, sc->call_with_input_string_symbol, args, - sc->type_names[T_STRING], 1)); - if (!is_procedure (proc)) - if_method_exists_return_value (sc, proc, sc->call_with_input_string_symbol, - args); - if (!s7_is_aritable (sc, proc, 1)) - wrong_type_error_nr ( - 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))) - wrong_type_error_nr (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 - - const s7_pointer str= car (args), proc= cadr (args); - if (!is_string (str)) - return (method_or_bust (sc, str, sc->call_with_input_file_symbol, args, - sc->type_names[T_STRING], 1)); - if (!is_procedure (proc)) - if_method_exists_return_value (sc, proc, sc->call_with_input_file_symbol, - args); - if (!s7_is_aritable (sc, proc, 1)) - wrong_type_error_nr ( - 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))) - wrong_type_error_nr (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) { - const s7_pointer old_input_port= current_input_port (sc); - set_current_input_port (sc, port); - port_set_string_or_function (port, car (args)); - push_stack (sc, OP_UNWIND_INPUT, old_input_port, port); - push_stack (sc, OP_APPLY, sc->nil, cadr (args)); - return (sc->F); -} - -static s7_int -procedure_required_args (s7_scheme* sc, s7_pointer x) { - switch (type (x)) { - case T_C_FUNCTION: - return (c_function_min_args (x)); - case T_C_MACRO: - return (c_macro_min_args (x)); - case T_CLOSURE: - case T_MACRO: - case T_BACRO: - if (closure_arity_unknown (x)) - closure_set_arity (x, s7_list_length (sc, closure_pars (x))); - return (s7_int_abs (closure_arity (x))); - } - return (0); -} - -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 - - const s7_pointer str= car (args), proc= cadr (args); - if (!is_string (str)) - return (method_or_bust (sc, str, sc->with_input_from_string_symbol, args, - sc->type_names[T_STRING], 1)); - if (is_eq_initial_c_function_data (sc->read_symbol, - proc)) /* was global_value 11-June-24 */ - { - 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_set_string_or_function (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, proc)) { - if (is_any_procedure (proc)) /* i.e. c_function, lambda, macro, etc */ - { - s7_pointer req_args= - wrap_integer (sc, procedure_required_args (sc, proc)); - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_4 ( - sc, - wrap_string ( - sc, - "~A requires ~D argument~P, but with-input-from-string's " - "second argument should be a thunk", - 89), - proc, req_args, req_args)); + const s7_pointer str = car(args), proc = cadr(args); + if (!is_string(str)) + return(method_or_bust(sc, str, sc->call_with_input_string_symbol, args, sc->type_names[T_STRING], 1)); + if (!is_procedure(proc)) + if_method_exists_return_value(sc, proc, sc->call_with_input_string_symbol, args); + if (!s7_is_aritable(sc, proc, 1)) + wrong_type_error_nr(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))) + wrong_type_error_nr(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 + + const s7_pointer str = car(args), proc = cadr(args); + if (!is_string(str)) + return(method_or_bust(sc, str, sc->call_with_input_file_symbol, args, sc->type_names[T_STRING], 1)); + if (!is_procedure(proc)) + if_method_exists_return_value(sc, proc, sc->call_with_input_file_symbol, args); + if (!s7_is_aritable(sc, proc, 1)) + wrong_type_error_nr(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))) + wrong_type_error_nr(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) +{ + const s7_pointer old_input_port = current_input_port(sc); + set_current_input_port(sc, port); + port_set_string_or_function(port, car(args)); + push_stack(sc, OP_UNWIND_INPUT, old_input_port, port); + push_stack(sc, OP_APPLY, sc->nil, cadr(args)); + return(sc->F); +} + +static s7_int procedure_required_args(s7_scheme *sc, s7_pointer x) +{ + switch (type(x)) + { + case T_C_FUNCTION: return(c_function_min_args(x)); + case T_C_MACRO: return(c_macro_min_args(x)); + case T_CLOSURE: case T_MACRO: case T_BACRO: + if (closure_arity_unknown(x)) + closure_set_arity(x, s7_list_length(sc, closure_pars(x))); + return(s7_int_abs(closure_arity(x))); } - else - return (method_or_bust (sc, proc, 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 also this can't be split into wifs and wifs_read because we need the - * runtime value of 'read + return(0); +} + +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 + + const s7_pointer str = car(args), proc = cadr(args); + if (!is_string(str)) + return(method_or_bust(sc, str, sc->with_input_from_string_symbol, args, sc->type_names[T_STRING], 1)); + if (is_eq_initial_c_function_data(sc->read_symbol, proc)) /* was global_value 11-June-24 */ + { + 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_set_string_or_function(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, proc)) + { + if (is_any_procedure(proc)) /* i.e. c_function, lambda, macro, etc */ + { + s7_pointer req_args = wrap_integer(sc, procedure_required_args(sc, proc)); + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "~A requires ~D argument~P, but with-input-from-string's second argument should be a thunk", 89), + proc, req_args, req_args)); + } + else return(method_or_bust(sc, proc, 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 + * also this can't be split into wifs and wifs_read because we need the runtime value of 'read */ - 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 - - const s7_pointer str= car (args), proc= cadr (args); - if (!is_string (str)) - return (method_or_bust (sc, str, sc->with_input_from_file_symbol, args, - sc->type_names[T_STRING], 1)); - if (!is_thunk (sc, proc)) { - if (is_any_procedure (proc)) /* i.e. c_function, lambda, macro, etc */ - { - s7_pointer req_args= - wrap_integer (sc, procedure_required_args (sc, proc)); - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_4 ( - sc, - wrap_string ( - sc, - "~A requires ~D argument~P, but with-input-from-file's " - "second argument should be a thunk", - 87), - proc, req_args, req_args)); + 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 + + const s7_pointer str = car(args), proc = cadr(args); + if (!is_string(str)) + return(method_or_bust(sc, str, sc->with_input_from_file_symbol, args, sc->type_names[T_STRING], 1)); + if (!is_thunk(sc, proc)) + { + if (is_any_procedure(proc)) /* i.e. c_function, lambda, macro, etc */ + { + s7_pointer req_args = wrap_integer(sc, procedure_required_args(sc, proc)); + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "~A requires ~D argument~P, but with-input-from-file's second argument should be a thunk", 87), + proc, req_args, req_args)); + } + else return(method_or_bust(sc, proc, sc->with_input_from_file_symbol, args, a_thunk_string, 2)); + } + return(with_input(sc, open_input_file_1(sc, string_value(str), "r", "with-input-from-file"), args)); +} + +static s7_pointer with_string_in(s7_scheme *sc, s7_pointer unused_args) +{ + const 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)); + set_curlet(sc, inline_make_let(sc, sc->curlet)); + return(opt2_pair(sc->code)); +} + +static s7_pointer with_file_in(s7_scheme *sc, s7_pointer unused_args) +{ + const 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)); + set_curlet(sc, inline_make_let(sc, sc->curlet)); + return(opt2_pair(sc->code)); +} + +static s7_pointer with_file_out(s7_scheme *sc, s7_pointer unused_args) +{ + const 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)); + set_curlet(sc, make_let(sc, sc->curlet)); + return(opt2_pair(sc->code)); +} + +static s7_pointer call_string_in(s7_scheme *sc, s7_pointer unused_args) +{ + const s7_pointer port = open_and_protect_input_string(sc, sc->value); + push_stack(sc, OP_UNWIND_INPUT, sc->unused, port); + set_curlet(sc, inline_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 unused_args) +{ + const s7_pointer port = open_input_file_1(sc, string_value(sc->value), "r", "with-input-from-file"); + push_stack(sc, OP_UNWIND_INPUT, sc->unused, port); + set_curlet(sc, inline_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 unused_args) +{ + const s7_pointer port = s7_open_output_file(sc, string_value(sc->value), "w"); + push_stack(sc, OP_UNWIND_OUTPUT, sc->unused, port); + set_curlet(sc, make_let_with_slot(sc, sc->curlet, opt3_sym(sc->code), port)); + return(opt2_pair(sc->code)); +} + +static s7_pointer c_function_name_to_symbol(s7_scheme *sc, s7_pointer func) +{ + if ((is_c_function(func)) || (is_c_macro(func))) + return(c_function_symbol(func)); /* c_function* uses c_sym slot for arg_names */ + if ((S7_DEBUGGING) && (!is_c_function_star(func))) fprintf(stderr, "%s[%d]: %s is not a c-function-star\n", __func__, __LINE__, display(func)); + return(make_symbol(sc, c_function_name(func), c_function_name_length(func))); /* c_function* */ +} + +#define op_with_io_1(Sc) (((s7_function)(opt1(Sc->code, OPT1_ANY)))(Sc, Sc->nil)) +static s7_pointer op_lambda(s7_scheme *sc, s7_pointer code); + +static void op_with_io_1_method(s7_scheme *sc) +{ + const s7_pointer let = sc->value; + if (has_active_methods(sc, let)) + { + s7_pointer method = car(sc->code); + if (is_c_function(method)) /* #_call-with-input-string et al */ + method = c_function_symbol(method); + push_stack(sc, OP_GC_PROTECT, let, sc->code); + sc->code = caddr(sc->code); + sc->value = op_lambda(sc, sc->code); /* don't unstack */ + sc->value = find_and_apply_method(sc, let, method, list_2(sc, let, sc->value)); } - else - return (method_or_bust (sc, proc, sc->with_input_from_file_symbol, args, - a_thunk_string, 2)); - } - return (with_input ( - sc, - open_input_file_1 (sc, string_value (str), "r", "with-input-from-file"), - args)); -} - -static s7_pointer -with_string_in (s7_scheme* sc, s7_pointer unused_args) { - const 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)); - set_curlet (sc, inline_make_let (sc, sc->curlet)); - return (opt2_pair (sc->code)); -} - -static s7_pointer -with_file_in (s7_scheme* sc, s7_pointer unused_args) { - const 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)); - set_curlet (sc, inline_make_let (sc, sc->curlet)); - return (opt2_pair (sc->code)); -} - -static s7_pointer -with_file_out (s7_scheme* sc, s7_pointer unused_args) { - const 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)); - set_curlet (sc, make_let (sc, sc->curlet)); - return (opt2_pair (sc->code)); -} - -static s7_pointer -call_string_in (s7_scheme* sc, s7_pointer unused_args) { - const s7_pointer port= open_and_protect_input_string (sc, sc->value); - push_stack (sc, OP_UNWIND_INPUT, sc->unused, port); - set_curlet (sc, inline_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 unused_args) { - const s7_pointer port= open_input_file_1 (sc, string_value (sc->value), "r", - "with-input-from-file"); - push_stack (sc, OP_UNWIND_INPUT, sc->unused, port); - set_curlet (sc, inline_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 unused_args) { - const s7_pointer port= - s7_open_output_file (sc, string_value (sc->value), "w"); - push_stack (sc, OP_UNWIND_OUTPUT, sc->unused, port); - set_curlet (sc, - make_let_with_slot (sc, sc->curlet, opt3_sym (sc->code), port)); - return (opt2_pair (sc->code)); -} - -static s7_pointer -c_function_name_to_symbol (s7_scheme* sc, s7_pointer func) { - if ((is_c_function (func)) || (is_c_macro (func))) - return (c_function_symbol ( - func)); /* c_function* uses c_sym slot for arg_names */ - if ((S7_DEBUGGING) && (!is_c_function_star (func))) - fprintf (stderr, "%s[%d]: %s is not a c-function-star\n", __func__, - __LINE__, display (func)); - return (make_symbol (sc, c_function_name (func), - c_function_name_length (func))); /* c_function* */ -} - -#define op_with_io_1(Sc) \ - (((s7_function) (opt1 (Sc->code, OPT1_ANY))) (Sc, Sc->nil)) -static s7_pointer op_lambda (s7_scheme* sc, s7_pointer code); - -static void -op_with_io_1_method (s7_scheme* sc) { - const s7_pointer let= sc->value; - if (has_active_methods (sc, let)) { - s7_pointer method= car (sc->code); - if (is_c_function (method)) /* #_call-with-input-string et al */ - method= c_function_symbol (method); - push_stack (sc, OP_GC_PROTECT, let, sc->code); - sc->code = caddr (sc->code); - sc->value= op_lambda (sc, sc->code); /* don't unstack */ - sc->value= - find_and_apply_method (sc, let, method, list_2 (sc, let, sc->value)); - } - else if (is_symbol (car (sc->code))) /* might be e.g. #_call-with-input-string - so use c_function_name */ - wrong_type_error_nr (sc, car (sc->code), 1, let, sc->type_names[T_STRING]); else - wrong_type_error_nr (sc, - wrap_string (sc, c_function_name (car (sc->code)), - c_function_name_length (car (sc->code))), - 1, let, sc->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_direct (sc, OP_WITH_IO_1); - sc->code= sc->value; - return (true); + if (is_symbol(car(sc->code))) /* might be e.g. #_call-with-input-string so use c_function_name */ + wrong_type_error_nr(sc, car(sc->code), 1, let, sc->type_names[T_STRING]); + else wrong_type_error_nr(sc, wrap_string(sc, c_function_name(car(sc->code)), c_function_name_length(car(sc->code))), 1, let, sc->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_direct(sc, OP_WITH_IO_1); + sc->code = sc->value; + return(true); } -static void -op_with_output_to_string (s7_scheme* sc) { - const 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)); - set_curlet (sc, inline_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_with_output_to_string(s7_scheme *sc) +{ + const 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)); + set_curlet(sc, inline_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= s7_open_output_string (sc); - push_stack (sc, OP_UNWIND_OUTPUT, sc->unused, port); - set_curlet (sc, inline_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); +static void op_call_with_output_string(s7_scheme *sc) +{ + s7_pointer port = s7_open_output_string(sc); + push_stack(sc, OP_UNWIND_OUTPUT, sc->unused, port); + set_curlet(sc, inline_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 -------------------------------- - */ + +/* -------------------------------- iterators -------------------------------- */ #if S7_DEBUGGING -static s7_pointer -titr_let (s7_scheme* sc, s7_pointer iter, const char* func, int32_t line) { - if (!is_let (iterator_sequence (iter))) { - fprintf (stderr, "%s%s[%d]: let iterator sequence is %s%s\n", bold_text, - func, line, - checked_type_name (sc, type_unchecked (iterator_sequence (iter))), - unbold_text); - if (sc->stop_at_error) abort (); - } - return (iter); +static s7_pointer titr_let(s7_scheme *sc, s7_pointer iter, const char *func, int32_t line) +{ + if (!is_let(iterator_sequence(iter))) + { + fprintf(stderr, "%s%s[%d]: let iterator sequence is %s%s\n", + bold_text, func, line, checked_type_name(sc, type_unchecked(iterator_sequence(iter))), unbold_text); + if (sc->stop_at_error) abort(); + } + return(iter); } -static s7_pointer -titr_pair (s7_scheme* sc, s7_pointer iter, const char* func, int32_t line) { - if (!is_pair (iterator_sequence (iter))) { - fprintf (stderr, "%s%s[%d]: pair iterator sequence is %s%s\n", bold_text, - func, line, - checked_type_name (sc, type_unchecked (iterator_sequence (iter))), - unbold_text); - if (sc->stop_at_error) abort (); - } - return (iter); +static s7_pointer titr_pair(s7_scheme *sc, s7_pointer iter, const char *func, int32_t line) +{ + if (!is_pair(iterator_sequence(iter))) + { + fprintf(stderr, "%s%s[%d]: pair iterator sequence is %s%s\n", + bold_text, func, line, checked_type_name(sc, type_unchecked(iterator_sequence(iter))), unbold_text); + if (sc->stop_at_error) abort(); + } + return(iter); } -static s7_pointer -titr_hash (s7_scheme* sc, s7_pointer iter, const char* func, int32_t line) { - if (!is_hash_table (iterator_sequence (iter))) { - fprintf (stderr, "%s%s[%d]: hash iterator sequence is %s%s\n", bold_text, - func, line, - checked_type_name (sc, type_unchecked (iterator_sequence (iter))), - unbold_text); - if (sc->stop_at_error) abort (); - } - return (iter); -} - -static s7_pointer -titr_len (s7_scheme* sc, s7_pointer iter, const char* func, int32_t line) { - if ((is_hash_table (iterator_sequence (iter))) || - (is_pair (iterator_sequence (iter)))) { - fprintf (stderr, "%s%s[%d]: iterator length sequence is %s%s\n", bold_text, - func, line, - checked_type_name (sc, type_unchecked (iterator_sequence (iter))), - unbold_text); - if (sc->stop_at_error) abort (); - } - return (iter); -} - -static s7_pointer -titr_pos (s7_scheme* sc, s7_pointer iter, const char* func, int32_t line) { - if (((is_let (iterator_sequence (iter))) && - (iterator_sequence (iter) != sc->rootlet) && - (iterator_sequence (iter) != sc->starlet)) || - (is_pair (iterator_sequence (iter)))) { - fprintf (stderr, "%s%s[%d]: iterator-position sequence is %s%s\n", - bold_text, func, line, - checked_type_name (sc, type_unchecked (iterator_sequence (iter))), - unbold_text); - if (sc->stop_at_error) abort (); - } - return (iter); +static s7_pointer titr_hash(s7_scheme *sc, s7_pointer iter, const char *func, int32_t line) +{ + if (!is_hash_table(iterator_sequence(iter))) + { + fprintf(stderr, "%s%s[%d]: hash iterator sequence is %s%s\n", + bold_text, func, line, checked_type_name(sc, type_unchecked(iterator_sequence(iter))), unbold_text); + if (sc->stop_at_error) abort(); + } + return(iter); +} + +static s7_pointer titr_len(s7_scheme *sc, s7_pointer iter, const char *func, int32_t line) +{ + if ((is_hash_table(iterator_sequence(iter))) || (is_pair(iterator_sequence(iter)))) + { + fprintf(stderr, "%s%s[%d]: iterator length sequence is %s%s\n", + bold_text, func, line, checked_type_name(sc, type_unchecked(iterator_sequence(iter))), unbold_text); + if (sc->stop_at_error) abort(); + } + return(iter); +} + +static s7_pointer titr_pos(s7_scheme *sc, s7_pointer iter, const char *func, int32_t line) +{ + if (((is_let(iterator_sequence(iter))) && (iterator_sequence(iter) != sc->rootlet) && (iterator_sequence(iter) != sc->starlet)) || + (is_pair(iterator_sequence(iter)))) + { + fprintf(stderr, "%s%s[%d]: iterator-position sequence is %s%s\n", + bold_text, func, line, checked_type_name(sc, type_unchecked(iterator_sequence(iter))), unbold_text); + if (sc->stop_at_error) abort(); + } + return(iter); } #endif -/* -------------------------------- iterator? -------------------------------- - */ + +/* -------------------------------- iterator? -------------------------------- */ /* g_is_iterator is now defined in s7_scheme_predicate.c */ -#define H_is_iterator "(iterator? obj) returns #t if obj is an iterator." -#define Q_is_iterator sc->pl_bt + #define H_is_iterator "(iterator? obj) returns #t if obj is an iterator." + #define Q_is_iterator sc->pl_bt -bool -s7_is_iterator (s7_pointer obj) { - return (is_iterator (obj)); -} +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 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 old_iter) { +static s7_pointer iterator_copy(s7_scheme *sc, s7_pointer old_iter) +{ s7_pointer iter; - new_cell (sc, iter, T_ITERATOR | T_SAFE_PROCEDURE); - memcpy ((void*) iter, (void*) old_iter, - sizeof (s7_cell)); /* picks up ITER_OK I hope */ - return (iter); + new_cell(sc, iter, T_ITERATOR | T_SAFE_PROCEDURE); + memcpy((void *)iter, (void *)old_iter, sizeof(s7_cell)); /* picks up ITER_OK I hope */ + return(iter); } -static s7_pointer -iterator_finished (s7_scheme* sc, s7_pointer iterator) { - return (sc->iterator_at_end_value); -} +static s7_pointer iterator_finished(s7_scheme *sc, s7_pointer iterator) {return(sc->iterator_at_end_value);} -static s7_pointer -iterator_quit (s7_scheme* sc, s7_pointer iterator) { - iterator_next (iterator)= iterator_finished; - clear_iter_ok (iterator); - return (sc->iterator_at_end_value); +static s7_pointer iterator_quit(s7_scheme *sc, s7_pointer iterator) +{ + iterator_next(iterator) = iterator_finished; + clear_iter_ok(iterator); + return(sc->iterator_at_end_value); } -static s7_pointer -let_iterate_uncarried (s7_scheme* sc, s7_pointer iterator) { - s7_pointer slot= let_iterator_slot (iterator); - if (!is_not_slot_end (slot)) return (iterator_quit (sc, iterator)); - let_iterator_set_slot (iterator, next_slot (slot)); - return (cons (sc, slot_symbol (slot), slot_value (slot))); +static s7_pointer let_iterate_uncarried(s7_scheme *sc, s7_pointer iterator) +{ + s7_pointer slot = let_iterator_slot(iterator); + if (!is_not_slot_end(slot)) + return(iterator_quit(sc, iterator)); + let_iterator_set_slot(iterator, next_slot(slot)); + return(cons(sc, slot_symbol(slot), slot_value(slot))); } -static s7_pointer -let_iterate_carried (s7_scheme* sc, s7_pointer iterator) { - s7_pointer result, slot= let_iterator_slot (iterator); - if (!is_not_slot_end (slot)) return (iterator_quit (sc, iterator)); - let_iterator_set_slot (iterator, next_slot (slot)); - result= iterator_carrier (iterator); - set_car (result, slot_symbol (slot)); - set_cdr (result, slot_value (slot)); - return (result); +static s7_pointer let_iterate_carried(s7_scheme *sc, s7_pointer iterator) +{ + s7_pointer result, slot = let_iterator_slot(iterator); + if (!is_not_slot_end(slot)) + return(iterator_quit(sc, iterator)); + let_iterator_set_slot(iterator, next_slot(slot)); + result = iterator_carrier(iterator); + set_car(result, slot_symbol(slot)); + set_cdr(result, slot_value(slot)); + return(result); } -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_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; - hash_entry_t** elements; - hash_entry_t* lst= hash_iterator_entry (iterator); +s7_pointer hash_table_iterate(s7_scheme *sc, s7_pointer iterator) +{ + s7_pointer table; + hash_entry_t **elements; + hash_entry_t *lst = hash_iterator_entry(iterator); - if (lst) { - hash_iterator_entry (iterator)= hash_entry_next (lst); - return (hash_entry_to_cons (sc, lst, iterator_carrier (iterator))); - } - table= iterator_sequence ( - iterator); /* using iterator_length and hash_table_entries here was - slightly slower */ - elements= hash_table_elements (table); - for (s7_int len= (s7_int) hash_table_size (table), - loc= iterator_position (iterator) + 1; - loc < len; loc++) { - hash_entry_t* x= elements[loc]; - if (x) { - iterator_position (iterator) = loc; - hash_iterator_entry (iterator)= hash_entry_next (x); - return (hash_entry_to_cons (sc, x, iterator_carrier (iterator))); + if (lst) + { + hash_iterator_entry(iterator) = hash_entry_next(lst); + return(hash_entry_to_cons(sc, lst, iterator_carrier(iterator))); } - } - if (is_weak_hash_table (table)) { - clear_weak_hash_iterator (iterator); - weak_hash_iters (table)--; - } - return (iterator_quit (sc, iterator)); + table = iterator_sequence(iterator); /* using iterator_length and hash_table_entries here was slightly slower */ + elements = hash_table_elements(table); + for (s7_int len = (s7_int)hash_table_size(table), loc = iterator_position(iterator) + 1; loc < len; loc++) + { + hash_entry_t *x = elements[loc]; + if (x) + { + iterator_position(iterator) = loc; + hash_iterator_entry(iterator) = hash_entry_next(x); + return(hash_entry_to_cons(sc, x, iterator_carrier(iterator))); + }} + if (is_weak_hash_table(table)) + { + clear_weak_hash_iterator(iterator); + weak_hash_iters(table)--; + } + return(iterator_quit(sc, iterator)); } -static s7_pointer -string_iterate (s7_scheme* sc, s7_pointer iter) { - if (iterator_position (iter) < iterator_length (iter)) - return (chars[(uint8_t) (string_value ( - iterator_sequence (iter))[iterator_position (iter)++])]); - return (iterator_quit (sc, iter)); +static s7_pointer string_iterate(s7_scheme *sc, s7_pointer iter) +{ + if (iterator_position(iter) < iterator_length(iter)) + return(chars[(uint8_t)(string_value(iterator_sequence(iter))[iterator_position(iter)++])]); + return(iterator_quit(sc, iter)); } -static s7_pointer -byte_vector_iterate (s7_scheme* sc, s7_pointer iter) { - if (iterator_position (iter) < iterator_length (iter)) - return (small_int ( - byte_vector (iterator_sequence (iter), iterator_position (iter)++))); - return (iterator_quit (sc, iter)); +static s7_pointer byte_vector_iterate(s7_scheme *sc, s7_pointer iter) +{ + if (iterator_position(iter) < iterator_length(iter)) + return(small_int(byte_vector(iterator_sequence(iter), iterator_position(iter)++))); + return(iterator_quit(sc, iter)); } -static s7_pointer -float_vector_iterate_uncarried (s7_scheme* sc, s7_pointer iter) { - if (iterator_position (iter) < iterator_length (iter)) - return (make_real (sc, float_vector (iterator_sequence (iter), - iterator_position (iter)++))); - return (iterator_quit (sc, iter)); +static s7_pointer float_vector_iterate_uncarried(s7_scheme *sc, s7_pointer iter) +{ + if (iterator_position(iter) < iterator_length(iter)) + return(make_real(sc, float_vector(iterator_sequence(iter), iterator_position(iter)++))); + return(iterator_quit(sc, iter)); } -static s7_pointer -float_vector_iterate_carried (s7_scheme* sc, s7_pointer iter) { - if (iterator_position (iter) < iterator_length (iter)) { - set_real ( - iterator_carrier (iter), - float_vector (iterator_sequence (iter), iterator_position (iter)++)); - return (iterator_carrier (iter)); - } - clear_mutable_number (iterator_carrier (iter)); - return (iterator_quit (sc, iter)); +static s7_pointer float_vector_iterate_carried(s7_scheme *sc, s7_pointer iter) +{ + if (iterator_position(iter) < iterator_length(iter)) + { + set_real(iterator_carrier(iter), float_vector(iterator_sequence(iter), iterator_position(iter)++)); + return(iterator_carrier(iter)); + } + clear_mutable_number(iterator_carrier(iter)); + return(iterator_quit(sc, iter)); } -static s7_pointer -complex_vector_iterate_uncarried (s7_scheme* sc, s7_pointer iter) { - if (iterator_position (iter) < iterator_length (iter)) - return (c_complex_to_s7 (sc, complex_vector (iterator_sequence (iter), - iterator_position (iter)++))); - return (iterator_quit (sc, iter)); +static s7_pointer complex_vector_iterate_uncarried(s7_scheme *sc, s7_pointer iter) +{ + if (iterator_position(iter) < iterator_length(iter)) + return(c_complex_to_s7(sc, complex_vector(iterator_sequence(iter), iterator_position(iter)++))); + return(iterator_quit(sc, iter)); } -static s7_pointer -complex_vector_iterate_carried (s7_scheme* sc, s7_pointer iter) { - if (iterator_position (iter) < iterator_length (iter)) { +static s7_pointer complex_vector_iterate_carried(s7_scheme *sc, s7_pointer iter) +{ + if (iterator_position(iter) < iterator_length(iter)) + { #if WITH_CLANG_PP - return (c_complex_to_s7 (sc, complex_vector (iterator_sequence (iter), - iterator_position (iter)++))); + return(c_complex_to_s7(sc, complex_vector(iterator_sequence(iter), iterator_position(iter)++))); #else - set_a_bi ( - iterator_carrier (iter), - complex_vector (iterator_sequence (iter), iterator_position (iter)++)); - return (iterator_carrier (iter)); + set_a_bi(iterator_carrier(iter), complex_vector(iterator_sequence(iter), iterator_position(iter)++)); + return(iterator_carrier(iter)); #endif - } - clear_mutable_number (iterator_carrier (iter)); - return (iterator_quit (sc, iter)); + } + clear_mutable_number(iterator_carrier(iter)); + return(iterator_quit(sc, iter)); } -static s7_pointer -int_vector_iterate_uncarried (s7_scheme* sc, s7_pointer iter) { - if (iterator_position (iter) < iterator_length (iter)) - return (make_integer ( - sc, int_vector (iterator_sequence (iter), iterator_position (iter)++))); - return (iterator_quit (sc, iter)); +static s7_pointer int_vector_iterate_uncarried(s7_scheme *sc, s7_pointer iter) +{ + if (iterator_position(iter) < iterator_length(iter)) + return(make_integer(sc, int_vector(iterator_sequence(iter), iterator_position(iter)++))); + return(iterator_quit(sc, iter)); } -static s7_pointer -int_vector_iterate_carried (s7_scheme* sc, s7_pointer iter) { - if (iterator_position (iter) < iterator_length (iter)) { - set_integer ( - iterator_carrier (iter), - int_vector (iterator_sequence (iter), iterator_position (iter)++)); - return (iterator_carrier (iter)); - } - clear_mutable_integer (iterator_carrier (iter)); - return (iterator_quit (sc, iter)); -} - -static s7_pointer -vector_iterate (s7_scheme* sc, s7_pointer iter) { - if (iterator_position (iter) < iterator_length (iter)) - return ( - vector_element (iterator_sequence (iter), iterator_position (iter)++)); - return (iterator_quit (sc, iter)); -} - -static s7_pointer -closure_iterate (s7_scheme* sc, s7_pointer iter) { - /* this can be confusing: below a hash-table is the "function", and a function - is the "iterator" only because with-let exports +iterator+=#t -> infinite - loop! (with-let (let ((+iterator+ #t)) (lambda () #)) ; this works - because a function has an associated let?? with-let first arg should be a - let. (for-each (make-hash-table) ; (hash-table) -- ((hash-table) ()) is - #f (not an error) - ;(vector 1) ; error: vector-ref second argument, (), is - nil but should be an integer - ;(vector) ; error: for-each first argument #() called - with 1 argument? - ;(list) ; for-each first argument, (), is nil but - should be a procedure or something applicable (lambda args args) ; - function as iterator because local +iterator+ above is #t, never returns - # (always () because iterator func takes no args) - ;(lambda (asd) ()) ; error: make-iterator argument, #, is a function but should be a thunk +static s7_pointer int_vector_iterate_carried(s7_scheme *sc, s7_pointer iter) +{ + if (iterator_position(iter) < iterator_length(iter)) + { + set_integer(iterator_carrier(iter), int_vector(iterator_sequence(iter), iterator_position(iter)++)); + return(iterator_carrier(iter)); + } + clear_mutable_integer(iterator_carrier(iter)); + return(iterator_quit(sc, iter)); +} + +static s7_pointer vector_iterate(s7_scheme *sc, s7_pointer iter) +{ + if (iterator_position(iter) < iterator_length(iter)) + return(vector_element(iterator_sequence(iter), iterator_position(iter)++)); + return(iterator_quit(sc, iter)); +} + +static s7_pointer closure_iterate(s7_scheme *sc, s7_pointer iter) +{ + /* this can be confusing: below a hash-table is the "function", and a function is the "iterator" only because with-let exports +iterator+=#t -> infinite loop! + (with-let + (let ((+iterator+ #t)) + (lambda () #)) ; this works because a function has an associated let?? with-let first arg should be a let. + (for-each + (make-hash-table) ; (hash-table) -- ((hash-table) ()) is #f (not an error) + ;(vector 1) ; error: vector-ref second argument, (), is nil but should be an integer + ;(vector) ; error: for-each first argument #() called with 1 argument? + ;(list) ; for-each first argument, (), is nil but should be a procedure or something applicable + (lambda args args) ; function as iterator because local +iterator+ above is #t, never returns # (always () because iterator func takes no args) + ;(lambda (asd) ()) ; error: make-iterator argument, #, is a function but should be a thunk )) * similarly: (with-let (let ((+documentation+ "hiho")) (curlet)) - (define (f) 1) ; (define (f) "a string" 1) - would return doc as "a string" (display (documentation f)) (newline)) ; - "hiho" -- should we block +documentation+ in with-let? + (define (f) 1) ; (define (f) "a string" 1) would return doc as "a string" + (display (documentation f)) (newline)) ; "hiho" -- should we block +documentation+ in with-let? */ - s7_pointer result= s7_call (sc, iterator_sequence (iter), sc->nil); - /* this can't use s7_apply_function -- we need to catch the error handler's - * longjmp here */ - if (result == sc->iterator_at_end_value) { - iterator_next (iter)= iterator_finished; - clear_iter_ok (iter); - } - return (result); + s7_pointer result = s7_call(sc, iterator_sequence(iter), sc->nil); + /* this can't use s7_apply_function -- we need to catch the error handler's longjmp here */ + if (result == sc->iterator_at_end_value) + { + iterator_next(iter) = iterator_finished; + clear_iter_ok(iter); + } + return(result); } -static s7_pointer -c_object_iterate (s7_scheme* sc, s7_pointer iter) { +static s7_pointer c_object_iterate(s7_scheme *sc, s7_pointer iter) +{ s7_pointer result, p, cur; - if (iterator_position (iter) >= iterator_length (iter)) - return (iterator_quit (sc, iter)); - p = iterator_sequence (iter); - cur= iterator_carrier (iter); - set_car (cur, p); - set_car (cdr (cur), - wrap_integer ( - sc, iterator_position (iter))); /* was make_integer 7-May-25, - c_object_ref->c_object_getter - is c_function in scheme? */ - result= (*(c_object_ref (sc, p))) (sc, cur); - iterator_position (iter)++; - if (result == sc->iterator_at_end_value) { - iterator_next (iter)= iterator_finished; - clear_iter_ok (iter); - } - return (result); + if (iterator_position(iter) >= iterator_length(iter)) + return(iterator_quit(sc, iter)); + p = iterator_sequence(iter); + cur = iterator_carrier(iter); + set_car(cur, p); + set_car(cdr(cur), wrap_integer(sc, iterator_position(iter))); /* was make_integer 7-May-25, c_object_ref->c_object_getter is c_function in scheme? */ + result = (*(c_object_ref(sc, p)))(sc, cur); + iterator_position(iter)++; + if (result == sc->iterator_at_end_value) + { + iterator_next(iter) = iterator_finished; + clear_iter_ok(iter); + } + return(result); } -static s7_pointer pair_iterate_1 (s7_scheme* sc, s7_pointer iter); -static s7_pointer -pair_iterate (s7_scheme* sc, s7_pointer iter) { +static s7_pointer pair_iterate_1(s7_scheme *sc, s7_pointer iter); +static s7_pointer pair_iterate(s7_scheme *sc, s7_pointer iter) +{ s7_pointer result; - if (!is_pair (iterator_current (iter))) return (iterator_quit (sc, iter)); - result = car (iterator_current (iter)); - iterator_current (iter)= cdr (iterator_current (iter)); - if (iterator_current (iter) == pair_iterator_slow (iter)) - iterator_current (iter)= sc->nil; - iterator_next (iter)= pair_iterate_1; - return (result); + if (!is_pair(iterator_current(iter))) return(iterator_quit(sc, iter)); + result = car(iterator_current(iter)); + iterator_current(iter) = cdr(iterator_current(iter)); + if (iterator_current(iter) == pair_iterator_slow(iter)) + iterator_current(iter) = sc->nil; + iterator_next(iter) = pair_iterate_1; + return(result); } -static s7_pointer -pair_iterate_1 (s7_scheme* sc, s7_pointer iter) { +static s7_pointer pair_iterate_1(s7_scheme *sc, s7_pointer iter) +{ s7_pointer result; - if (!is_pair (iterator_current (iter))) return (iterator_quit (sc, iter)); - result = car (iterator_current (iter)); - iterator_current (iter)= cdr (iterator_current (iter)); - if (iterator_current (iter) == pair_iterator_slow (iter)) - iterator_current (iter)= sc->nil; - else pair_iterator_set_slow (iter, cdr (pair_iterator_slow (iter))); - iterator_next (iter)= pair_iterate; - return (result); -} - -static s7_pointer -find_make_iterator_method (s7_scheme* sc, s7_pointer let, s7_pointer iter) { + if (!is_pair(iterator_current(iter))) return(iterator_quit(sc, iter)); + result = car(iterator_current(iter)); + iterator_current(iter) = cdr(iterator_current(iter)); + if (iterator_current(iter) == pair_iterator_slow(iter)) + iterator_current(iter) = sc->nil; + else pair_iterator_set_slow(iter, cdr(pair_iterator_slow(iter))); + iterator_next(iter) = pair_iterate; + return(result); +} + +static s7_pointer find_make_iterator_method(s7_scheme *sc, s7_pointer let, s7_pointer iter) +{ s7_pointer func; - if ((has_active_methods (sc, let)) && - ((func= find_method_with_let (sc, let, sc->make_iterator_symbol)) != - sc->undefined)) { - s7_pointer it; - gc_protect_via_stack (sc, iter); - it= s7_apply_function (sc, func, set_plist_1 (sc, let)); - unstack_gc_protect (sc); - if (!is_iterator (it)) - error_nr ( - 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); + if ((has_active_methods(sc, let)) && + ((func = find_method_with_let(sc, let, sc->make_iterator_symbol)) != sc->undefined)) + { + s7_pointer it; + gc_protect_via_stack(sc, iter); + it = s7_apply_function(sc, func, set_plist_1(sc, let)); + unstack_gc_protect(sc); + if (!is_iterator(it)) + error_nr(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 bool -is_iterable_closure (s7_scheme* sc, s7_pointer x) { + +/* -------------------------------- make-iterator -------------------------------- */ +static bool is_iterable_closure(s7_scheme *sc, s7_pointer x) +{ s7_pointer iter; - if (!is_thunk (sc, x)) - sole_arg_wrong_type_error_nr (sc, sc->make_iterator_symbol, x, - a_thunk_string); - iter= funclet_entry (sc, x, sc->local_iterator_symbol); - return ((iter) && (iter != sc->F)); + if (!is_thunk(sc, x)) + sole_arg_wrong_type_error_nr(sc, sc->make_iterator_symbol, x, a_thunk_string); + iter = funclet_entry(sc, x, sc->local_iterator_symbol); + return((iter) && (iter != sc->F)); } -static s7_pointer starlet_make_iterator (s7_scheme* sc, s7_pointer iter); -static s7_int c_object_length_to_int (s7_scheme* sc, s7_pointer obj); +static s7_pointer starlet_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 seq) { +s7_pointer s7_make_iterator(s7_scheme *sc, s7_pointer seq) +{ s7_pointer iter; - new_cell (sc, iter, T_ITERATOR | T_SAFE_PROCEDURE | T_ITER_OK); - iterator_sequence (iter)= seq; - if (is_pair (seq)) /* by far the most common case */ - { - iterator_current (iter)= seq; - iterator_next (iter) = pair_iterate; - pair_iterator_set_slow (iter, seq); - return (iter); - } - iterator_carrier (iter)= NULL; - if (!is_let (seq)) iterator_position (iter)= 0; - - switch (type (seq)) { - case T_LET: - if (seq == sc->rootlet) { - let_iterator_set_slot (iter, sc->rootlet_slots); - iterator_next (iter)= let_iterate_uncarried; - return (iter); - } - if (seq == sc->starlet) return (starlet_make_iterator (sc, iter)); - { - s7_pointer func= find_make_iterator_method (sc, seq, iter); - if (func) return (func); - } - let_iterator_set_slot (iter, let_slots (seq)); - iterator_next (iter)= let_iterate_uncarried; - break; - - case T_HASH_TABLE: - hash_iterator_entry (iter)= NULL; - iterator_position (iter) = -1; - iterator_next (iter) = hash_table_iterate; - if (is_weak_hash_table (seq)) { - set_weak_hash_iterator (iter); - weak_hash_iters (seq)++; - add_weak_hash_iterator (sc, iter); - } - break; - - case T_STRING: - iterator_length (iter)= string_length (seq); - iterator_next (iter) = string_iterate; - break; - - case T_BYTE_VECTOR: - iterator_length (iter)= byte_vector_length (seq); - iterator_next (iter) = byte_vector_iterate; - break; - - case T_VECTOR: - iterator_length (iter)= vector_length (seq); - iterator_next (iter) = vector_iterate; - break; - - case T_INT_VECTOR: - iterator_length (iter)= vector_length (seq); - iterator_next (iter) = int_vector_iterate_uncarried; - break; - - case T_FLOAT_VECTOR: - iterator_length (iter)= vector_length (seq); - iterator_next (iter) = float_vector_iterate_uncarried; - break; - - case T_COMPLEX_VECTOR: - iterator_length (iter)= vector_length (seq); - iterator_next (iter) = complex_vector_iterate_uncarried; - 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, seq)) { - iterator_carrier (iter)= list_1_unchecked (sc, int_zero); - set_has_carrier (iter); - iterator_next (iter) = closure_iterate; - iterator_length (iter)= (has_active_methods (sc, seq)) - ? closure_length (sc, seq) - : S7_INT64_MAX; + new_cell(sc, iter, T_ITERATOR | T_SAFE_PROCEDURE | T_ITER_OK); + iterator_sequence(iter) = seq; + if (is_pair(seq)) /* by far the most common case */ + { + iterator_current(iter) = seq; + iterator_next(iter) = pair_iterate; + pair_iterator_set_slow(iter, seq); + return(iter); } - else - sole_arg_wrong_type_error_nr ( - sc, sc->make_iterator_symbol, seq, - 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, seq); - { - s7_pointer func= find_make_iterator_method (sc, seq, iter); - if (func) return (func); - } - iterator_carrier (iter)= list_2_unchecked ( - sc, seq, int_zero); /* if not unchecked, gc protect iter */ - set_has_carrier (iter); - iterator_next (iter)= c_object_iterate; - break; - - default: - sole_arg_wrong_type_error_nr (sc, sc->make_iterator_symbol, seq, - a_sequence_string); - } - return (iter); -} + iterator_carrier(iter) = NULL; + if (!is_let(seq)) + iterator_position(iter) = 0; -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 (*s7* 'iterator-at-end-value), # by default. In some cases, \ -the iterator either returns two values in a cons (if the sequence is a hash-table, the cons has the key and value), \ -in others the iterator normally returns an s7_cell created for the value (for example, a float-vector stores data as \ -doubles, but for each value, the iterator returns an s7 object). To avoid all this allocation, 'carrier' can be a cons \ -or #t; in the latter case s7 chooses an appropriate value." -#define Q_make_iterator \ - s7_make_signature ( \ - sc, 3, sc->is_iterator_symbol, sc->is_sequence_symbol, \ - s7_make_signature (sc, 2, sc->is_boolean_symbol, sc->is_pair_symbol)) - - /* we need to call s7_make_iterator before fixing up the optional second arg - * in case let->method */ - const s7_pointer seq = car (args); - const s7_pointer carrier= (is_pair (cdr (args))) ? cadr (args) : NULL; - s7_pointer iter = s7_make_iterator (sc, seq); - - if (carrier) { - /* no carrier needed if seq is t_vector, byte_vector, string, c-object, nil - * or list, else cons for hash/let, mutable int|float|complex if - * int|byte|float|complex-vector, but scheme code can't create a mutable - * number, so use #t as carrier arg. - */ - if (carrier == sc->T) /* #t = conjure up an appropriate carrier */ + switch (type(seq)) { - switch ( - type (seq)) /* all types that have carriers use iterator_carrier */ + case T_LET: + if (seq == sc->rootlet) + { + let_iterator_set_slot(iter, sc->rootlet_slots); + iterator_next(iter) = let_iterate_uncarried; + return(iter); + } + if (seq == sc->starlet) + return(starlet_make_iterator(sc, iter)); { - case T_INT_VECTOR: - iterator_carrier (iter)= make_mutable_integer (sc, 0); - iterator_next (iter) = int_vector_iterate_carried; - break; - case T_FLOAT_VECTOR: - iterator_carrier (iter)= make_mutable_real (sc, 0.0); - iterator_next (iter) = float_vector_iterate_carried; - break; - case T_COMPLEX_VECTOR: - iterator_carrier (iter)= make_mutable_complex (sc, 0.0, 0.0); - iterator_next (iter) = complex_vector_iterate_carried; - break; - case T_HASH_TABLE: - iterator_carrier (iter)= cons (sc, sc->F, sc->F); - break; - case T_LET: - iterator_carrier (iter)= cons (sc, sc->F, sc->F); - if (seq != sc->starlet) { - s7_pointer func= find_make_iterator_method ( - sc, seq, - iter); /* (iterate (make-iterator (mock-string #\h #\i) #t)) */ - if (func) iter= func; /* should this free the previous iterator? */ - if (iterator_next (iter) == let_iterate_uncarried) - iterator_next (iter)= let_iterate_carried; - else if (!iterator_carrier (iter)) - return (iter); /* don't set has_carrier because GC will segfault - upon gc_mark(iterator_carrier(iter)) */ - } - break; - default: - return (iter); + s7_pointer func = find_make_iterator_method(sc, seq, iter); + if (func) return(func); } - set_has_carrier (iter); - } - else { - if (!is_pair (carrier)) - sole_arg_wrong_type_error_nr (sc, sc->make_iterator_symbol, carrier, - sc->type_names[T_PAIR]); - if (is_immutable_pair (carrier)) - immutable_object_error_nr (sc, set_elist_3 (sc, immutable_error_string, - sc->make_iterator_symbol, - carrier)); - if ((!is_hash_table (seq)) && (!is_let (seq))) - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_4 ( - sc, - wrap_string (sc, - "make-iterator carrier argument ~S is a pair, but " - "~S is ~S, not a hash-table or let", - 79), - carrier, seq, object_type_name (sc, seq))); - if (seq != sc->rootlet) { - iterator_carrier (iter)= carrier; - if ((is_let (seq)) && (seq != sc->starlet)) { - s7_pointer func= find_make_iterator_method ( - sc, seq, iter); /* mock-hash-table for example */ - if (func) - iter= func; /* (iterate (make-iterator (mock-hash-table 'b 2) - (list #f))) */ - if (iterator_next (iter) == let_iterate_uncarried) - iterator_next (iter)= let_iterate_carried; - else if (!iterator_carrier (iter)) - return (iter); /* don't set has_carrier because GC will segfault - upon gc_mark(iterator_carrier(iter)) */ - } - set_has_carrier (iter); - } - } - } - return (iter); -} + let_iterator_set_slot(iter, let_slots(seq)); + iterator_next(iter) = let_iterate_uncarried; + break; -/* -------------------------------- 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 (*s7* " \ - "'iterator-at-end-value), # by default." -#define Q_iterate s7_make_signature (sc, 2, sc->T, sc->is_iterator_symbol) - s7_pointer iter= car (args); - if (!is_iterator (iter)) - return (sole_arg_method_or_bust (sc, iter, sc->iterate_symbol, args, - sc->type_names[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_p (sc, iter, sc->iterate_symbol, - sc->type_names[T_ITERATOR])); - return ((iterator_next (iter)) (sc, iter)); -} - -s7_pointer -s7_iterate (s7_scheme* sc, s7_pointer obj) { - return ((iterator_next (obj)) (sc, obj)); -} - -static bool -op_implicit_iterate (s7_scheme* sc) { - s7_pointer iter= lookup_checked (sc, car (sc->code)); - if (!is_iterator (iter)) { - sc->last_function= iter; - return (false); - } - sc->value= (iterator_next (iter)) (sc, iter); - return (true); -} - -/* -------------------------------- iterator-at-end? - * -------------------------------- */ -bool -s7_iterator_is_at_end (s7_scheme* sc, s7_pointer obj) { - if (!is_iterator (obj)) - sole_arg_wrong_type_error_nr (sc, sc->iterator_is_at_end_symbol, obj, - sc->type_names[T_ITERATOR]); - return (!iter_ok (obj)); -} - -static bool -iterator_is_at_end_b_7p (s7_scheme* sc, s7_pointer obj) { - if (!is_iterator (obj)) - sole_arg_wrong_type_error_nr (sc, sc->iterator_is_at_end_symbol, obj, - sc->type_names[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 (sole_arg_method_or_bust (sc, iter, sc->iterator_is_at_end_symbol, - args, sc->type_names[T_ITERATOR])); - return (make_boolean (sc, !iter_ok (iter))); -} - -/* -------------------------------- iterator-sequence - * -------------------------------- */ -/* g_iterator_sequence is now defined in s7_scheme_predicate.c */ -#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) + case T_HASH_TABLE: + hash_iterator_entry(iter) = NULL; + iterator_position(iter) = -1; + iterator_next(iter) = hash_table_iterate; + if (is_weak_hash_table(seq)) + { + set_weak_hash_iterator(iter); + weak_hash_iters(seq)++; + add_weak_hash_iterator(sc, iter); + } + break; -/* iterator-length and iterator-position run up against the function iterator */ + case T_STRING: + iterator_length(iter) = string_length(seq); + iterator_next(iter) = string_iterate; + break; -/* -------- cycles -------- */ + case T_BYTE_VECTOR: + iterator_length(iter) = byte_vector_length(seq); + iterator_next(iter) = byte_vector_iterate; + break; -#define INITIAL_SHARED_INFO_SIZE 8 + case T_VECTOR: + iterator_length(iter) = vector_length(seq); + iterator_next(iter) = vector_iterate; + break; -static int32_t -shared_ref (shared_info_t* ci, const s7_pointer p) { - /* from print after collecting refs, not called by equality check, only called - * in object_to_port_with_circle_check_1 */ - s7_pointer* objs= ci->objs; - for (int32_t 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); -} + case T_INT_VECTOR: + iterator_length(iter) = vector_length(seq); + iterator_next(iter) = int_vector_iterate_uncarried; + break; -static void -flip_ref (shared_info_t* ci, const s7_pointer p) { - s7_pointer* objs= ci->objs; - for (int32_t i= 0; i < ci->top; i++) - if (objs[i] == p) { - ci->refs[i]= -ci->refs[i]; + case T_FLOAT_VECTOR: + iterator_length(iter) = vector_length(seq); + iterator_next(iter) = float_vector_iterate_uncarried; break; - } -} -static int32_t -peek_shared_ref_1 (shared_info_t* ci, const s7_pointer p) { - /* returns 0 if not found, otherwise the ref value for p */ - s7_pointer* objs= ci->objs; - for (int32_t i= 0; i < ci->top; i++) - if (objs[i] == p) return (ci->refs[i]); - return (0); -} + case T_COMPLEX_VECTOR: + iterator_length(iter) = vector_length(seq); + iterator_next(iter) = complex_vector_iterate_uncarried; + break; -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); -} + 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; -static void -enlarge_shared_info (shared_info_t* ci) { - 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, memclr is not faster */ - for (int32_t i= ci->top; i < ci->size; i++) { - ci->refs[i]= 0; - ci->objs[i]= NULL; - } -} + 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, seq)) + { + iterator_carrier(iter) = list_1_unchecked(sc, int_zero); + set_has_carrier(iter); + iterator_next(iter) = closure_iterate; + iterator_length(iter) = (has_active_methods(sc, seq)) ? closure_length(sc, seq) : S7_INT64_MAX; + } + else + sole_arg_wrong_type_error_nr(sc, sc->make_iterator_symbol, seq, + wrap_string(sc, "a function or macro with a '+iterator+ local that is not #f", 59)); + break; -static bool -check_collected (s7_pointer top, shared_info_t* ci) { - const s7_pointer* objs_end= (s7_pointer*) (ci->objs + ci->top); - for (s7_pointer* p= ci->objs; p < objs_end; p++) - if ((*p) == top) { - int32_t 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 */ + case T_C_OBJECT: + iterator_length(iter) = c_object_length_to_int(sc, seq); + { + s7_pointer func = find_make_iterator_method(sc, seq, iter); + if (func) return(func); } + iterator_carrier(iter) = list_2_unchecked(sc, seq, int_zero); /* if not unchecked, gc protect iter */ + set_has_carrier(iter); + iterator_next(iter) = c_object_iterate; break; + + default: + sole_arg_wrong_type_error_nr(sc, sc->make_iterator_symbol, seq, a_sequence_string); } - set_cyclic (top); - return (true); + return(iter); } -static bool collect_shared_info (s7_scheme* sc, shared_info_t* ci, - s7_pointer top, bool stop_at_print_length); -static bool hash_keys_not_cyclic (s7_scheme* sc, s7_pointer hash); +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 (*s7* 'iterator-at-end-value), # by default. In some cases, \ +the iterator either returns two values in a cons (if the sequence is a hash-table, the cons has the key and value), \ +in others the iterator normally returns an s7_cell created for the value (for example, a float-vector stores data as \ +doubles, but for each value, the iterator returns an s7 object). To avoid all this allocation, 'carrier' can be a cons \ +or #t; in the latter case s7 chooses an appropriate value." + #define Q_make_iterator s7_make_signature(sc, 3, sc->is_iterator_symbol, sc->is_sequence_symbol, s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_pair_symbol)) -static bool -collect_vector_info (s7_scheme* sc, shared_info_t* ci, s7_pointer top, - bool stop_at_print_length) { - s7_int plen; - bool cyclic= false; + /* we need to call s7_make_iterator before fixing up the optional second arg in case let->method */ + const s7_pointer seq = car(args); + const s7_pointer carrier = (is_pair(cdr(args))) ? cadr(args) : NULL; + s7_pointer iter = s7_make_iterator(sc, seq); - if (stop_at_print_length) { - plen= sc->print_length; - if (plen > vector_length (top)) plen= vector_length (top); - } - else plen= vector_length (top); - for (s7_int i= 0; i < plen; i++) { - const s7_pointer vel= vector_element_unchecked ( - 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 (carrier) + { + /* no carrier needed if seq is t_vector, byte_vector, string, c-object, nil or list, else cons for hash/let, + * mutable int|float|complex if int|byte|float|complex-vector, but scheme code can't create a mutable number, so use #t as carrier arg. + */ + if (carrier == sc->T) /* #t = conjure up an appropriate carrier */ + { + switch (type(seq)) /* all types that have carriers use iterator_carrier */ + { + case T_INT_VECTOR: + iterator_carrier(iter) = make_mutable_integer(sc, 0); + iterator_next(iter) = int_vector_iterate_carried; + break; + case T_FLOAT_VECTOR: + iterator_carrier(iter) = make_mutable_real(sc, 0.0); + iterator_next(iter) = float_vector_iterate_carried; + break; + case T_COMPLEX_VECTOR: + iterator_carrier(iter) = make_mutable_complex(sc, 0.0, 0.0); + iterator_next(iter) = complex_vector_iterate_carried; + break; + case T_HASH_TABLE: + iterator_carrier(iter) = cons(sc, sc->F, sc->F); + break; + case T_LET: + iterator_carrier(iter) = cons(sc, sc->F, sc->F); + if (seq != sc->starlet) + { + s7_pointer func = find_make_iterator_method(sc, seq, iter); /* (iterate (make-iterator (mock-string #\h #\i) #t)) */ + if (func) iter = func; /* should this free the previous iterator? */ + if (iterator_next(iter) == let_iterate_uncarried) + iterator_next(iter) = let_iterate_carried; + else + if (!iterator_carrier(iter)) + return(iter); /* don't set has_carrier because GC will segfault upon gc_mark(iterator_carrier(iter)) */ + } + break; + default: + return(iter); + } + set_has_carrier(iter); + } + else + { + if (!is_pair(carrier)) + sole_arg_wrong_type_error_nr(sc, sc->make_iterator_symbol, carrier, sc->type_names[T_PAIR]); + if (is_immutable_pair(carrier)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->make_iterator_symbol, carrier)); + if ((!is_hash_table(seq)) && (!is_let(seq))) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "make-iterator carrier argument ~S is a pair, but ~S is ~S, not a hash-table or let", 79), + carrier, seq, object_type_name(sc, seq))); + if (seq != sc->rootlet) + { + iterator_carrier(iter) = carrier; + if ((is_let(seq)) && (seq != sc->starlet)) + { + s7_pointer func = find_make_iterator_method(sc, seq, iter); /* mock-hash-table for example */ + if (func) iter = func; /* (iterate (make-iterator (mock-hash-table 'b 2) (list #f))) */ + if (iterator_next(iter) == let_iterate_uncarried) + iterator_next(iter) = let_iterate_carried; + else + if (!iterator_carrier(iter)) + return(iter); /* don't set has_carrier because GC will segfault upon gc_mark(iterator_carrier(iter)) */ + } + set_has_carrier(iter); + }}} + return(iter); +} - 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; - 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 (s7_pointer 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 (s7_pointer 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) { - const s7_int len = (s7_int) hash_table_size (top); - hash_entry_t** entries = hash_table_elements (top); - const bool keys_safe= hash_keys_not_cyclic (sc, top); - for (s7_int i= 0; i < len; i++) - for (hash_entry_t* entry= entries[i]; entry; - entry = hash_entry_next (entry)) { - if ((!keys_safe) && (has_structure (hash_entry_key (entry))) && - (collect_shared_info (sc, ci, hash_entry_key (entry), - stop_at_print_length))) - top_cyclic= true; - if ((has_structure (hash_entry_value (entry))) && - (collect_shared_info (sc, ci, hash_entry_value (entry), - stop_at_print_length))) { - if ((is_c_pointer (hash_entry_value (entry))) || - (is_iterator (hash_entry_value (entry))) || - (is_c_object (hash_entry_value (entry)))) - 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 - for (s7_pointer let= top; let; let= let_outlet (let)) - for (s7_pointer slot= let_slots (let); is_not_slot_end (slot); - slot = next_slot (slot)) - if ((has_structure (slot_value (slot))) && - (collect_shared_info (sc, ci, slot_value (slot), - stop_at_print_length))) { - top_cyclic= true; - if ((is_c_pointer (slot_value (slot))) || - (is_iterator (slot_value (slot))) || - (is_c_object (slot_value (slot)))) - 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* -make_shared_info (s7_scheme* sc) { - shared_info_t* 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 void -free_shared_info (shared_info_t* ci) { - if (ci) { - free (ci->objs); - free (ci->refs); - free (ci->defined); - free (ci); - } +/* -------------------------------- 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 (*s7* 'iterator-at-end-value), # by default." + #define Q_iterate s7_make_signature(sc, 2, sc->T, sc->is_iterator_symbol) + s7_pointer iter = car(args); + if (!is_iterator(iter)) + return(sole_arg_method_or_bust(sc, iter, sc->iterate_symbol, args, sc->type_names[T_ITERATOR])); + return((iterator_next(iter))(sc, iter)); } -static inline shared_info_t* -clear_shared_info (shared_info_t* ci) { - if (ci->top > 0) { - memclr ((void*) (ci->refs), ci->top * sizeof (int32_t)); - memclr ((void*) (ci->defined), ci->top * sizeof (bool)); - for (int32_t 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; - ci->ctr = 0; - return (ci); +static s7_pointer iterate_p_p(s7_scheme *sc, s7_pointer iter) +{ + if (!is_iterator(iter)) + return(method_or_bust_p(sc, iter, sc->iterate_symbol, sc->type_names[T_ITERATOR])); + return((iterator_next(iter))(sc, iter)); } -static shared_info_t* -load_shared_info (s7_scheme* sc, s7_pointer top, bool stop_at_print_length, - shared_info_t* ci) { - /* for the printer, here only if is_structure(top) and top is not sc->rootlet - */ - bool no_problem= true; - s7_int stop_len; - - /* check for simple cases first */ - if (is_pair (top)) { - s7_pointer p= top; - if (stop_at_print_length) { - s7_pointer slow= top; - stop_len = sc->print_length; - for (s7_int k= 0; k < stop_len; k+= 2) { - if (!is_pair (p)) break; - if (has_structure (car (p))) { - no_problem= false; - break; - } - p= cdr (p); - if (!is_pair (p)) break; - if (has_structure (car (p))) { - no_problem= false; - break; - } - p = cdr (p); - slow= cdr (slow); - if (p == 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 (p); p= cdr (p)) - if (has_structure (car (p))) { - no_problem= false; - break; - } /* perhaps (and (length > 0 via sequence_is_empty)) or vector typer - etc */ - if ((no_problem) && (!is_null (p)) && (has_structure (p))) - no_problem= false; - if (no_problem) return (NULL); - } - else if (is_t_vector (top)) /* any other vector can't happen */ - { - stop_len= vector_length (top); - if ((stop_at_print_length) && (stop_len > sc->print_length)) - stop_len= sc->print_length; - for (s7_int k= 0; k < stop_len; k++) - if (has_structure (vector_element (top, k))) { - no_problem= false; - break; - } - if (no_problem) return (NULL); - } +s7_pointer s7_iterate(s7_scheme *sc, s7_pointer obj) {return((iterator_next(obj))(sc, obj));} - else /* added these 19-Oct-22 -- helps in tgc, but not much elsewhere */ - if ((is_let (top)) && (top != sc->rootlet)) { - for (s7_pointer let= top; (no_problem) && (let); let= let_outlet (let)) - for (s7_pointer slot= let_slots (let); is_not_slot_end (slot); - slot = next_slot (slot)) - if (has_structure ( - slot_value (slot))) /* slot_symbol need not be checked? */ - { - no_problem= false; - break; - } - if (no_problem) return (NULL); - } - else if (is_hash_table (top)) { - hash_entry_t** entries = hash_table_elements (top); - bool keys_safe= hash_keys_not_cyclic (sc, top); - if (hash_table_entries (top) == 0) return (NULL); - for (s7_int len= (s7_int) hash_table_size (top), i= 0; i < len; i++) - for (hash_entry_t* entry= entries[i]; entry; - entry = hash_entry_next (entry)) - if (((!keys_safe) && (has_structure (hash_entry_key (entry)))) || - (has_structure (hash_entry_value (entry)))) { - no_problem= false; - break; - } - if (no_problem) return (NULL); - } +static bool op_implicit_iterate(s7_scheme *sc) +{ + s7_pointer iter = lookup_checked(sc, car(sc->code)); + if (!is_iterator(iter)) {sc->last_function = iter; return(false);} + sc->value = (iterator_next(iter))(sc, iter); + return(true); +} - if ((S7_DEBUGGING) && (is_any_vector (top)) && (!is_t_vector (top))) - fprintf (stderr, "%s[%d]: got abnormal vector\n", __func__, __LINE__); - clear_shared_info (ci); - { - /* collect all pointers associated with top */ - const bool cyclic= collect_shared_info (sc, ci, top, stop_at_print_length); - s7_pointer* ci_objs= ci->objs; - int32_t* ci_refs= ci->refs; - int32_t refs = 0; - - for (int32_t i= 0; i < ci->top; i++) - clear_collected_and_shared (ci_objs[i]); - if (!cyclic) return (NULL); - if (!(ci->has_hits)) return (NULL); - - /* 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 (int32_t i= 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); - } + +/* -------------------------------- iterator-at-end? -------------------------------- */ +bool s7_iterator_is_at_end(s7_scheme *sc, s7_pointer obj) +{ + if (!is_iterator(obj)) + sole_arg_wrong_type_error_nr(sc, sc->iterator_is_at_end_symbol, obj, sc->type_names[T_ITERATOR]); + return(!iter_ok(obj)); } -/* -------------------------------- cyclic-sequences - * -------------------------------- */ -static s7_pointer -cyclic_sequences_p_p (s7_scheme* sc, s7_pointer obj) { - if (has_structure (obj)) { - shared_info_t* ci= - (sc->object_out_locked) - ? sc->circle_info - : load_shared_info (sc, obj, false, - sc->circle_info); /* false=don't stop at print - length (vectors etc) */ - if (ci) { - check_free_heap_size (sc, ci->top); - begin_temp (sc->y, sc->nil); - for (int32_t i= 0; i < ci->top; i++) - sc->y= cons_unchecked (sc, ci->objs[i], sc->y); - return_with_end_temp (sc->y); - } - } - return (sc->nil); +static bool iterator_is_at_end_b_7p(s7_scheme *sc, s7_pointer obj) +{ + if (!is_iterator(obj)) + sole_arg_wrong_type_error_nr(sc, sc->iterator_is_at_end_symbol, obj, sc->type_names[T_ITERATOR]); + return(!iter_ok(obj)); } -/* g_cyclic_sequences is now defined in s7_scheme_predicate.c */ -#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) - -/* -------------------------------- object->port (display format etc) - * -------------------------------- */ -static int32_t -circular_list_entries (s7_pointer lst) { - int32_t i= 1; - for (s7_pointer x= cdr (lst);; i++, x= cdr (x)) { - int32_t j= 0; - for (s7_pointer y= lst; j < i; y= cdr (y), j++) - if (x == y) return (i); - } +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(sole_arg_method_or_bust(sc, iter, sc->iterator_is_at_end_symbol, args, sc->type_names[T_ITERATOR])); + return(make_boolean(sc, !iter_ok(iter))); } -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[type_unchecked (Obj)]) (Sc, Obj, Port, Use_Write, Ci) - -static bool -string_needs_slashification (const uint8_t* str, s7_int len) { - /* we have to go by len (str len) not *s==0 because s7 strings can have - * embedded nulls */ - for (const uint8_t *p= str, *pend= (const uint8_t*) (str + len); 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) { - const uint8_t *pcur, *pend, *pstart= NULL; - if (len == 0) { - if (quoted) port_write_string (port) (sc, "\"\"", 2, port); - return; - } - pend= (const 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) 12 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= (const uint8_t*) p; pcur < pend; pcur++) - if (slashify_table[*pcur]) { - if (pstart) pstart++; - else pstart= (const uint8_t*) p; - if (pstart != pcur) { - port_write_string (port) (sc, (const 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 '\n': - port_write_character (port) (sc, 'n', port); - break; /* added 17-Sep-25 for r7rs */ - 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, (const char*) p, len, port); - else { - pstart++; - if (pstart != pcur) - port_write_string (port) (sc, (const 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* unused_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 = (int32_t) 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); - } -} +/* -------------------------------- iterator-sequence -------------------------------- */ +/* g_iterator_sequence is now defined in s7_scheme_predicate.c */ + #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) -static void -input_port_to_port (s7_scheme* sc, s7_pointer obj, s7_pointer port, - use_write_t use_write, shared_info_t* unused_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 = (int32_t) catstrs (str, 256, "(open-input-file \"", - port_filename (obj), "\")", (char*) NULL); - port_write_string (port) (sc, str, nlen, port); - } - else { - const s7_int data_len= port_data_size (obj) - port_position (obj); - if (data_len > 100) { - const char* 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= (int32_t) 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 = (int32_t) 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= (int32_t) 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, "#", 9, port); - else port_write_character (port) (sc, '>', port); - } -} +/* iterator-length and iterator-position run up against the function iterator */ -static bool -symbol_needs_slashification (s7_scheme* sc, s7_pointer obj) { - uint8_t* pend; - char* str= symbol_name (obj); /* not const for make_atom */ - s7_int len; - - if ((str[0] == '#') || (str[0] == '\'') || (str[0] == ',')) return (true); - if (is_number (make_atom (sc, str, 10, NO_SYMBOLS, WITHOUT_OVERFLOW_ERROR))) - return (true); - - len = symbol_name_length (obj); - pend= (uint8_t*) (str + len); - for (uint8_t* p= (uint8_t*) str; p < pend; p++) - if (symbol_slashify_table[*p]) return (true); - set_clean_symbol (obj); - return (false); -} - -void -symbol_to_port (s7_scheme* sc, s7_pointer obj, s7_pointer port, - use_write_t use_write, shared_info_t* unused_ci) { - /* I think this is the only place we print a symbol's name */ - if ((!is_clean_symbol (obj)) && (symbol_needs_slashification (sc, obj))) { - /* this can't work in general if use_write == p_readable: - * (define f (apply lambda (list () (list 'let (list (list (symbol "a b") - * 3)) (symbol "a b"))))) ; (f) -> 3 prints "readably" as "(lambda () (let - * (((symbol \"a b\") 3)) (symbol \"a b\")))" so, 30-May-24 added (*s7* - * 'symbol-printer). - */ - if (is_any_procedure (sc->symbol_printer)) /* we see p_write here */ - { - const s7_pointer printer= sc->symbol_printer; - s7_pointer result; - sc->symbol_printer= sc->F; /* avoid infinite recursion */ - result = s7_call (sc, printer, set_plist_1 (sc, obj)); - if (!is_string (result)) - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_2 ( - sc, - wrap_string ( - sc, "(*s7* 'symbol-printer) should return a string: ~S", - 49), - result)); - /* if we restore symbol-printer before the error, and the printer function - * stupidly returned the bad symbol, infinite loop */ - sc->symbol_printer= printer; - port_write_string (port) (sc, string_value (result), - string_length (result), port); - } - else { - 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) || (use_write == p_code)) { - if (!is_keyword (obj)) c= '\''; - } - else if ((use_write == p_key) && (!is_keyword (obj))) c= ':'; - if (is_string_port (port)) { - s7_int 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= vector_dimension (vect, cur_dim); - s7_int 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_1 (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) { - if (use_write != p_readable) { - if (*last) port_write_string (port) (sc, " (", 2, port); - else port_write_character (port) (sc, '(', port); - (*last)= false; - } - for (int32_t 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_1 (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 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, use_write_t use_write, - shared_info_t* ci) { - bool last= false; - return (multivector_to_port_1 (sc, vec, port, out_len, flat_ref, dimension, - dimensions, &last, use_write, ci)); -} - -static void -make_vector_to_port (s7_scheme* sc, s7_pointer vect, s7_pointer port) { - const s7_int vlen= vector_length (vect); - 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-"; - else if (is_complex_vector (vect)) vtyp= "complex-"; - - if (vector_rank (vect) == 1) { - plen= (int32_t) 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= (int32_t) 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= (int32_t) 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= (int32_t) 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 port_write_vector_typer (s7_scheme* sc, s7_pointer vect, - s7_pointer 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)) { - const s7_int vlen= vector_length (vect); - s7_pointer* els = vector_elements (vect); - const s7_pointer 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); - if (is_typed_vector (vect)) { - port_write_character (port) (sc, ' ', port); - port_write_vector_typer (sc, vect, port); - } - port_write_character (port) (sc, ')', port); - return; - } - } - check_stack_size (sc); - 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_gc_protect (sc); - return; - } +/* g_cyclic_sequences is now defined in s7_scheme_predicate.c */ +#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) - if (is_typed_vector (vect)) - port_write_string (port) (sc, "(let (( ", 11, port); - 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])) { - int32_t eref= peek_shared_ref (ci, els[i]); - port_write_string (port) (sc, " #f", 3, port); - if (eref != 0) { - if (eref < 0) eref= -eref; - if (vector_rank (vect) > 1) { - const s7_int dimension= vector_rank (vect) - 1; - const int32_t str_len= - (dimension < 8) ? 128 : ((dimension + 1) * 16); - block_t* b = callocate (sc, str_len); - char* 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= 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) { - const s7_int dimension= vector_rank (vect) - 1; - const int32_t str_len= - (dimension < 8) ? 128 : ((dimension + 1) * 16); - block_t* b = callocate (sc, str_len); - char* 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= 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); - } - if (is_typed_vector (vect)) { - port_write_string (port) (sc, ")) (set! (vector-typer ) ", 28, port); - port_write_vector_typer (sc, vect, port); - port_write_string (port) (sc, ") )", 6, port); - } + +/* pair_append: general pair utility used by eval and the writer */ +s7_pointer pair_append(s7_scheme *sc, s7_pointer a, s7_pointer b) +{ + s7_pointer p = cdr(a), tp; + gc_protect_via_stack(sc, b); + if (is_null(p)) + tp = cons(sc, car(a), b); + else + { + s7_pointer np; + tp = list_1(sc, car(a)); + set_gc_protected2(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); } - else { - if (is_typed_vector (vect)) - port_write_string (port) (sc, "(let (( ", 11, port); - /* (let ((v (make-vector 3 'a symbol?))) (object->string v :readable)): - * "(let (( (vector 'a 'a 'a))) (set! (vector-typer ) symbol?) )" - */ + unstack_gc_protect(sc); + return(tp); +} - 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); +/* -------------------------------- s7i helpers for s7_scheme_write.c -------------------------------- */ - 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); - } +bool s7i_port_is_closed(s7_pointer p) { return port_is_closed(p); } - if (is_immutable_vector (vect)) - port_write_string (port) (sc, "))", 2, port); - else port_write_character (port) (sc, ')', port); +void s7i_port_write_character(s7_scheme *sc, char c, s7_pointer port) +{ + port_write_character(port)(sc, c, port); +} - if (vector_rank (vect) > 1) /* subvector above */ - { - 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); - } - if (is_typed_vector (vect)) { - port_write_string (port) (sc, ")) (set! (vector-typer ) ", 28, port); - port_write_vector_typer (sc, vect, port); - port_write_string (port) (sc, ") )", 6, port); - } - } - } - else /* not readable write */ - { - if (vector_rank (vect) > 1) /* if rank>1, ndims exists */ - { - 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); - multivector_to_port (sc, vect, port, len, 0, 0, vector_ndims (vect), - 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); +void s7i_port_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer port) +{ + port_write_string(port)(sc, str, len, port); +} - if (too_long) port_write_string (port) (sc, " ...)", 5, port); - else port_write_character (port) (sc, ')', port); - } - } - unstack_gc_protect (sc); -} - -static s7_int -print_vector_length (s7_scheme* sc, s7_pointer vect, s7_pointer port, - use_write_t use_write) { - const s7_int len = vector_length (vect); - const char* vtype= "r"; /* "const" here for g++ */ - - if (is_int_vector (vect)) vtype= "i"; - else if (is_complex_vector (vect)) vtype= "c"; - else if (is_byte_vector (vect)) vtype= "u"; - if (len == 0) { - char buf[128]; - s7_int plen; - if (vector_rank (vect) > 1) - plen= (s7_int) catstrs_direct ( - buf, "#", vtype, pos_int_to_str_direct (sc, vector_ndims (vect)), - "d()", (const char*) (const char*) NULL); - else - plen= (s7_int) 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) { - char buf[128]; - s7_int plen= (s7_int) 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 if (is_byte_vector (vect)) - port_write_string (port) (sc, "#u8(...)", 8, port); - else port_write_string (port) (sc, "#c(...)", 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* unused_ci) { - s7_int plen; - bool too_long; - char buf[128]; - const char* str; - const s7_int len= print_vector_length (sc, vect, port, use_write); - if (len < 0) - return; /* actually -1, see above -- this means there's nothing more to - print */ - 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 i; - const s7_int vlen = vector_length (vect); - const s7_int* els = int_vector_ints (vect); - s7_int first= els[0]; - for (i= 1; i < vlen; i++) - if (els[i] != first) break; - if (i == vlen) { - make_vector_to_port (sc, vect, port); - str= integer_to_string (sc, int_vector (vect, 0), &plen); - port_write_string (port) (sc, str, 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)) { - str= integer_to_string (sc, int_vector (vect, 0), &plen); - port_write_string (port) (sc, str, plen, port); - for (s7_int 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); - s7_int 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); - } - str= integer_to_string (sc, int_vector (vect, 0), &plen); - memcpy ((void*) (dbuf + new_len), (const void*) str, plen); - new_len+= plen; - for (s7_int 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 { - 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); - gc_protect_via_stack (sc, vect); - multivector_to_port (sc, vect, port, len, 0, 0, vector_ndims (vect), - p_display, NULL); - unstack_gc_protect (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* unused_ci) { -#define FV_BUFSIZE 512 /* some floats can take around 312 bytes */ - char buf[FV_BUFSIZE]; - s7_int plen; - bool too_long; - const s7_double* els= float_vector_floats (vect); - const s7_int 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 i; - const s7_int vlen = vector_length (vect); - const 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; - } - } +void s7i_port_write_unicode_char(s7_scheme *sc, uint32_t c, s7_pointer port) +{ + port_write_unicode_char(sc, c, port); +} - 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 (s7_int 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 { - 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); - gc_protect_via_stack (sc, vect); - multivector_to_port (sc, vect, port, len, 0, 0, vector_ndims (vect), - p_display, NULL); - unstack_gc_protect (sc); - } - if ((use_write == p_readable) && (is_immutable_vector (vect))) - port_write_character (port) (sc, ')', port); -} - -static char* -complex_to_string_base_10 (s7_scheme* sc, s7_complex obj, s7_int width, - s7_int precision, char float_choice, s7_int* nlen, - use_write_t choice) { - char* imag; - s7_int 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; - } - sc->num_to_str[0]= '\0'; - imag= copy_string (number_to_string_base_10 (sc, wrap_real (sc, cimag (obj)), - 0, precision, float_choice, &len, - choice)); - sc->num_to_str[0]= '\0'; - number_to_string_base_10 (sc, wrap_real (sc, creal (obj)), 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) { - 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); -} - -static void -complex_vector_to_port (s7_scheme* sc, s7_pointer vect, s7_pointer port, - use_write_t use_write, shared_info_t* unused_ci) { -#define CV_BUFSIZE 1024 /* some floats can take around 312 bytes */ - bool too_long; - const s7_complex* els= complex_vector_complexes (vect); - s7_int 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 i; - const s7_int vlen = vector_length (vect); - const s7_complex first= els[0]; - for (i= 1; i < vlen; i++) - if (els[i] != first) break; - if (i == vlen) { - s7_int plen; - char* num= complex_to_string_base_10 ( - sc, first, 0, sc->float_format_precision, 'g', &plen, use_write); - make_vector_to_port (sc, vect, port); - port_write_string (port) (sc, num, clamp_length (plen, CV_BUFSIZE), 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; - } - } +s7_pointer s7i_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) +{ + return start_and_end(sc, caller, args, position, index_args, start, end); +} - if (vector_rank (vect) == 1) { - s7_int plen; - char* num= complex_to_string_base_10 ( - sc, els[0], 0, sc->float_format_precision, 'g', &plen, use_write); - port_write_string (port) (sc, "#c(", 3, port); - port_write_string (port) (sc, num, clamp_length (plen, CV_BUFSIZE), port); - for (s7_int i= 1; i < len; i++) { - num= complex_to_string_base_10 (sc, els[i], 0, sc->float_format_precision, - 'g', &plen, use_write); - port_write_character (port) (sc, ' ', port); - port_write_string (port) (sc, num, clamp_length (plen, CV_BUFSIZE), port); - } - if (too_long) port_write_string (port) (sc, " ...)", 5, port); - else port_write_character (port) (sc, ')', port); - } - else { - char buf[CV_BUFSIZE]; - s7_int plen= catstrs_direct ( - buf, "#c", pos_int_to_str_direct (sc, vector_ndims (vect)), "d", - (const char*) NULL); - port_write_string (port) (sc, buf, plen, port); - gc_protect_via_stack (sc, vect); - multivector_to_port (sc, vect, port, len, 0, 0, vector_ndims (vect), - p_display, NULL); - unstack_gc_protect (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* unused_ci) { - bool too_long; - const s7_int 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 i; - const s7_int vlen = vector_length (vect); - const uint8_t* els = byte_vector_bytes (vect); - uint8_t first= els[0]; - for (i= 1; i < vlen; i++) - if (els[i] != first) break; - if (i == vlen) { - s7_int plen; - const char* str; /* const for integer_to_string */ - make_vector_to_port (sc, vect, port); - str= integer_to_string ( - sc, byte_vector (vect, 0), - &plen); /* only 0..10 start out with names: init_small_ints */ - port_write_string (port) (sc, str, 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; - } - } +bool s7i_is_unused(s7_scheme *sc, s7_pointer p) +{ + return p == sc->unused; +} - if (vector_rank (vect) == 1) { - s7_int plen; - const char* str; - port_write_string (port) (sc, "#u8(", 4, port); - str= integer_to_string (sc, byte_vector (vect, 0), &plen); - port_write_string (port) (sc, str, plen, port); - for (s7_int i= 1; i < len; i++) { - char buf[128]; - 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 { - char buf[128]; - s7_int plen= catstrs_direct ( - buf, "#u8", 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), - 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* unused_ci) { - bool 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)) { - const s7_pointer c = chars[(int32_t) ((uint8_t) (buf[0]))]; - const int32_t nlen= (int32_t) 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 ((const uint8_t*) 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 s7_int -list_length_with_immutable_check (s7_scheme* sc, s7_pointer a, - bool* immutable) { - s7_pointer slow= a, fast= a; - for (s7_int i= 0;; i+= 2) { - if (!is_pair (fast)) return ((is_null (fast)) ? i : -i); - if (is_immutable_pair (fast)) *immutable= true; - fast= cdr (fast); - if (!is_pair (fast)) return ((is_null (fast)) ? (i + 1) : (-i - 1)); - if (is_immutable_pair (fast)) *immutable= true; - fast= cdr (fast); - slow= cdr (slow); - if (fast == slow) return (0); - } - return (0); +s7_pointer s7i_method_or_bust_p(s7_scheme *sc, s7_pointer obj, const char *method_name, const char *type_name) +{ + return method_or_bust_p(sc, obj, s7_make_symbol(sc, method_name), wrap_string(sc, type_name, safe_strlen(type_name))); } -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, - bool immutable) { - /* the easier cases: no circles or shared refs to patch up */ - if ((true_len > 0) && (!immutable)) { - port_write_string (port) (sc, "list", 4, port); - for (s7_pointer p= lst; is_pair (p); p= cdr (p)) { - port_write_character (port) (sc, ' ', port); - object_to_port_with_circle_check (sc, car (p), port, p_readable, ci); - } - port_write_character (port) (sc, ')', port); - } - else { - s7_pointer p; - s7_int immutable_ctr= 0; - if (is_immutable_pair (lst)) { - port_write_string (port) (sc, "immutable! (cons ", 17, port); - immutable_ctr++; - } - else port_write_string (port) (sc, "cons ", 5, port); - object_to_port_with_circle_check (sc, car (lst), port, p_readable, ci); - - for (p= cdr (lst); is_pair (p); p= cdr (p)) { - if (is_immutable_pair (p)) { - port_write_string (port) (sc, " (immutable! (cons ", 19, port); - immutable_ctr++; - } - else port_write_string (port) (sc, " (cons ", 7, port); - object_to_port_with_circle_check (sc, car (p), port, p_readable, ci); - } - if (is_null (p)) port_write_string (port) (sc, " ()", 3, port); - else { - port_write_character (port) (sc, ' ', port); - object_to_port_with_circle_check (sc, p, port, p_readable, ci); - } - for (s7_int i= (true_len <= 0) ? 1 : 0; i < len; i++) - port_write_character (port) (sc, ')', port); - for (s7_int i= 0; i < immutable_ctr; i++) - port_write_character (port) (sc, ')', port); - } +s7_pointer s7i_method_or_bust_pp(s7_scheme *sc, s7_pointer obj, const char *method_name, s7_pointer x1, s7_pointer x2, const char *type_name, s7_int arg_pos) +{ + return method_or_bust_pp(sc, obj, s7_make_symbol(sc, method_name), x1, x2, wrap_string(sc, type_name, safe_strlen(type_name)), (int32_t)arg_pos); } -static void -pair_to_port (s7_scheme* sc, s7_pointer lst, s7_pointer port, - use_write_t use_write, shared_info_t* ci) { - s7_int len; - bool immutable= false; - const s7_int true_len= list_length_with_immutable_check (sc, lst, &immutable); - 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= 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= (int32_t) 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_function) || (car (lst) == sc->quote_symbol)) && - (true_len == 2)) { - const bool need_new_ci= ((!ci) && (is_pair (cadr (lst)))); - shared_info_t *new_ci= NULL, *temp_ci= NULL; - const bool old_locked= sc->object_out_locked; - /* true_len == 2 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 - */ - if (car (lst) == sc->quote_symbol) - port_write_string (port) (sc, "(quote ", 7, port); - else port_write_character (port) (sc, '\'', port); - if (need_new_ci) { - new_ci= make_shared_info (sc); - /* clear_shared_info(new_ci); */ - temp_ci= load_shared_info (sc, cadr (lst), false, - new_ci); /* temp_ci can be NULL! */ - } - else temp_ci= ci; - if (need_new_ci) sc->object_out_locked= true; - object_to_port_with_circle_check (sc, cadr (lst), port, p_write, temp_ci); - if (need_new_ci) { - sc->object_out_locked= old_locked; - free_shared_info (new_ci); - } - if (car (lst) == sc->quote_symbol) - port_write_character (port) (sc, ')', port); - return; - } -#if WITH_IMMUTABLE_UNQUOTE - if ((car (lst) == sc->unquote_symbol) && (true_len == 2)) { - port_write_character (port) (sc, ',', port); - object_to_port_with_circle_check (sc, cadr (lst), port, p_write, ci); - return; - } -#endif +void s7i_division_by_zero_error(s7_scheme *sc, const char *caller, s7_pointer x, s7_pointer y) +{ + division_by_zero_error_2_nr(sc, wrap_string(sc, caller, safe_strlen(caller)), x, y); +} - if (is_multiple_value (lst)) - port_write_string (port) (sc, "(values ", 8, port); - else port_write_character (port) (sc, '(', port); +bool s7i_is_subvector(s7_pointer p) {return(is_subvector(p));} - if (use_write == p_readable) { - if (!is_cyclic (lst)) { - /* here (and in the cyclic case) we need to handle immutable pairs -- this - * requires using cons rather than list etc */ - simple_list_readable_display (sc, lst, true_len, len, port, ci, - immutable); - return; - } - if (ci) { - int32_t plen; - s7_pointer p, local_port; - char buf[128], lst_name[128]; - bool lst_local= false; - int32_t lst_ref = peek_shared_ref (ci, lst); - if (lst_ref == 0) { - 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, - immutable); - 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 */ - } - p= lst; - for (s7_int i= 0; (i < len) && (is_pair (p)); p= cdr (p), i++) { - if ((has_structure (car (p))) && (is_cyclic (car (p)))) - port_write_string (port) (sc, " #f", 3, port); - else { - port_write_character (port) (sc, ' ', port); - object_to_port_with_circle_check (sc, car (p), port, use_write, ci); - } - if ((is_pair (cdr (p))) && (peek_shared_ref (ci, cdr (p)) != 0)) break; - } +s7_pointer s7i_int_one(s7_scheme *sc) {(void)sc; return(int_one);} - 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 `(p . 1) - (signature (int-vector))) :readable) */ - p= lst; - for (s7_int i= 0; (i < len) && (is_pair (p)); p= cdr (p), i++) { - int32_t lref; - if ((has_structure (car (p))) && (is_cyclic (car (p)))) { - if (i == 0) - plen= (int32_t) catstrs_direct (buf, " (set-car! ", lst_name, " ", - (const char*) NULL); - else - plen= (int32_t) 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 (p)); - if (lref == 0) - object_to_port_with_circle_check (sc, car (p), local_port, - use_write, ci); - else { - if (lref < 0) lref= -lref; - plen= (int32_t) 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 (p))) && - ((lref= peek_shared_ref (ci, cdr (p))) != 0)) { - if (lref < 0) lref= -lref; - if (i == 0) - plen= (int32_t) catstrs_direct ( - buf, (lst_local) ? " " : " ", "(set-cdr! ", lst_name, " <", - pos_int_to_str_direct (sc, lref), ">) ", (const char*) NULL); - else if (i == 1) - plen= (int32_t) catstrs_direct (buf, (lst_local) ? " " : " ", - "(set-cdr! (cdr ", lst_name, ") <", - pos_int_to_str_direct (sc, lref), - ">) ", (const char*) NULL); - else - plen= (int32_t) 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 s7i_iterator_sequence(s7_pointer iter) {return(iterator_sequence(iter));} + +s7_int s7i_subvector_position(s7_pointer p) +{ + if (is_subvector(p)) + switch (type(p)) { - s7_pointer end_p; - for (end_p= lst; is_pair (end_p); end_p= cdr (end_p)) - ; /* or maybe faster, start at p? */ - /* we can't depend on the loops above to set p to the last element - * because they sometimes break out */ - if (true_len == -1) /* cons cell */ - plen= (int32_t) catstrs_direct (buf, (lst_local) ? " " : " ", - "(set-cdr! ", lst_name, " ", - (const char*) NULL); - else if (true_len == -2) - plen= (int32_t) catstrs_direct (buf, (lst_local) ? " " : " ", - "(set-cdr! (cdr ", lst_name, ") ", - (const char*) NULL); - else - plen= (int32_t) 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_p, 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, - immutable); - } - else /* not :readable */ - { - const s7_int 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 */ - return; - } - if (ci) { - s7_pointer p; - s7_int i; - for (p= lst, i= 0; (is_pair (p)) && (i < plen) && - ((i == 0) || (peek_shared_ref (ci, p) == 0)); - i++, p= cdr (p)) { - ci->ctr++; - if (ci->ctr > sc->print_length) { - port_write_string (port) (sc, " ...)", 5, port); - return; - } - object_to_port_with_circle_check (sc, car (p), port, - not_p_display (use_write), ci); - if (i < (len - 1)) port_write_character (port) (sc, ' ', port); - } - if (is_not_null (p)) { - 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, p, port, - not_p_display (use_write), ci); - } - } - port_write_character (port) (sc, ')', port); - } - else { - s7_pointer p = lst; - const s7_int len1= plen - 1; - if (is_string_port (port)) { - for (s7_int i= 0; (is_pair (p)) && (i < len1); i++, p= cdr (p)) { - object_to_port (sc, car (p), port, not_p_display (use_write), ci); - if (port_position (port) >= sc->objstr_max_len) 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) ' '; - } + case T_VECTOR: return((s7_int)(vector_elements(p) - vector_elements(subvector_vector(p)))); + case T_INT_VECTOR: return((s7_int)(int_vector_ints(p) - int_vector_ints(subvector_vector(p)))); + case T_FLOAT_VECTOR: return((s7_int)(float_vector_floats(p) - float_vector_floats(subvector_vector(p)))); + case T_COMPLEX_VECTOR: return((s7_int)(complex_vector_complexes(p) - complex_vector_complexes(subvector_vector(p)))); + case T_BYTE_VECTOR: return((s7_int)(byte_vector_bytes(p) - byte_vector_bytes(subvector_vector(p)))); } - else - for (s7_int i= 0; (is_pair (p)) && (i < len1); i++, p= cdr (p)) { - object_to_port (sc, car (p), port, not_p_display (use_write), - ci); /* lst free here if unprotected */ - port_write_character (port) (sc, ' ', port); - } - if (is_pair (p)) { - object_to_port (sc, car (p), port, not_p_display (use_write), ci); - p= cdr (p); - } - if (is_not_null (p)) { - if (plen < len) port_write_string (port) (sc, " ...", 4, port); - else { - port_write_string (port) (sc, ". ", 2, port); - object_to_port (sc, p, port, not_p_display (use_write), ci); - } - } - port_write_character (port) (sc, ')', port); - } - } + return(-1); } -static s7_pointer find_closure (s7_scheme* sc, s7_pointer closure, - s7_pointer current_let); -static const char* hash_table_checker_name (s7_scheme* sc, s7_pointer ht); +s7_pointer s7i_subvector_vector(s7_scheme *sc, s7_pointer p) {return(subvector_vector(p));} +bool s7i_is_typed_t_vector(s7_pointer p) {return(is_typed_t_vector(p));} +s7_pointer s7i_typed_vector_typer(s7_scheme *sc, s7_pointer p) {return(typed_vector_typer(p));} -static s7_pointer -find_typer (s7_scheme* sc, s7_pointer typer) { - s7_pointer sym= find_closure (sc, typer, closure_let (typer)); - if (!is_symbol (sym)) sym= find_closure (sc, typer, sc->curlet); - return (sym); +static s7_pointer new_format_port(s7_scheme *sc) +{ + const s7_int len = FORMAT_PORT_LENGTH; + block_t *block = mallocate(sc, len); + block_t *b = mallocate_port(sc); + const s7_pointer port = alloc_pointer(sc); + set_full_type(port, T_OUTPUT_PORT); + port_block(port) = b; + port_port(port) = (port_t *)block_data(b); + port_type(port) = string_port; + port_set_closed(port, false); + port_data_size(port) = len; + port_next(port) = NULL; + port_data(port) = (uint8_t *)(block_data(block)); + port_data_block(port) = block; + port_data(port)[0] = '\0'; + port_position(port) = 0; + port_needs_free(port) = false; + port_port(port)->pf = &output_string_functions; +#if S7_DEBUGGING + sc->format_ports_allocated++; +#endif + return(port); } -static const char* -hash_table_typer_name (s7_scheme* sc, s7_pointer typer) { - if (is_c_function (typer)) return (c_function_name (typer)); - if (is_boolean (typer)) return ("#t"); -#if S7_DEBUGGING /* I don't think this happens anymore */ - if (typer == sc->unused) { - fprintf (stderr, "%s[%d]: hash typer is #\n", __func__, __LINE__); - return ("#"); /* mapper can be sc->unused briefly -- where? */ - } -#endif - { - s7_pointer sym= find_typer (sc, typer); - return ((is_symbol (sym)) - ? symbol_name (sym) - : NULL); /* see below in hash_table_procedures_to_port */ - } +static inline s7_pointer open_format_port(s7_scheme *sc) +{ + s7_pointer port = sc->format_ports; + if (!port) return(new_format_port(sc)); + sc->format_ports = (s7_pointer)(port_next(port)); + port_position(port) = 0; + port_data(port)[0] = '\0'; + return(port); } -static void -hash_typers_to_port (s7_scheme* sc, s7_pointer hash, s7_pointer port) { - if (((is_typed_hash_table (hash)) || - (is_pair (hash_table_procedures (hash)))) && - ((!is_boolean (hash_table_key_typer (hash))) || - (!is_boolean (hash_table_value_typer (hash))))) { - const char* typer= hash_table_typer_name (sc, hash_table_key_typer (hash)); - port_write_string (port) (sc, " (cons ", 7, port); - port_write_string (port) (sc, typer, safe_strlen (typer), port); - port_write_character (port) (sc, ' ', port); - typer= hash_table_typer_name (sc, hash_table_value_typer (hash)); - port_write_string (port) (sc, typer, safe_strlen (typer), port); - port_write_string (port) (sc, "))", 2, port); - } - else port_write_character (port) (sc, ')', port); +static void close_format_port(s7_scheme *sc, s7_pointer port) +{ + port_next(port) = (struct block_t *)(sc->format_ports); + sc->format_ports = port; } -static void -hash_table_procedures_to_port (s7_scheme* sc, s7_pointer hash, s7_pointer port, - bool closed, shared_info_t* ci) { - const char* typer= hash_table_checker_name (sc, hash); - if ((closed) && (is_immutable_hash_table (hash))) - port_write_string (port) (sc, "(immutable! ", 12, port); +char *s7_object_to_c_string(s7_scheme *sc, s7_pointer obj) +{ + char *str; + s7_pointer strport; + s7_int len; - if (typer[0] == '#') /* #f */ - { - if (is_pair (hash_table_procedures (hash))) { - s7_int nlen= 0; - const char* str= - (const char*) integer_to_string (sc, hash_table_size (hash), &nlen); - const char* checker= - hash_table_typer_name (sc, hash_table_procedures_checker (hash)); - const char* mapper= - hash_table_typer_name (sc, hash_table_procedures_mapper (hash)); - if (is_weak_hash_table (hash)) - port_write_string (port) (sc, "(make-weak-hash-table ", 22, port); - else port_write_string (port) (sc, "(make-hash-table ", 17, port); - port_write_string (port) (sc, str, nlen, port); - if ((checker) && (mapper)) { - if ((is_boolean (hash_table_procedures_checker (hash))) && - (is_boolean (hash_table_procedures_mapper (hash)))) - port_write_string (port) (sc, " #f", 3, - port); /* no checker/mapper set? */ - else { - port_write_string (port) (sc, " (cons ", 7, port); - port_write_string (port) (sc, checker, safe_strlen (checker), port); - port_write_character (port) (sc, ' ', port); - port_write_string (port) (sc, mapper, safe_strlen (mapper), port); - port_write_character (port) (sc, ')', port); - } - } - else if ((is_any_closure (hash_table_procedures_checker (hash))) || - (is_any_closure (hash_table_procedures_mapper (hash)))) { - port_write_string (port) (sc, " (cons ", 7, port); - if (is_any_closure (hash_table_procedures_checker (hash))) - object_to_port_with_circle_check ( - sc, hash_table_procedures_checker (hash), port, p_readable, ci); - else - port_write_string (port) (sc, checker, safe_strlen (checker), port); - port_write_character (port) (sc, ' ', port); - if (is_any_closure (hash_table_procedures_mapper (hash))) - object_to_port_with_circle_check ( - sc, hash_table_procedures_mapper (hash), port, p_readable, ci); - else port_write_string (port) (sc, mapper, safe_strlen (mapper), port); - port_write_character (port) (sc, ')', port); - } - else - port_write_string (port) (sc, " #f", 3, - port); /* no checker/mapper set? */ - hash_typers_to_port (sc, hash, port); - } - else 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); - } - else { - s7_int nlen= 0; - const char* str = integer_to_string (sc, hash_table_size (hash), &nlen); - if (is_weak_hash_table (hash)) - port_write_string (port) (sc, "(make-weak-hash-table ", 22, port); - else port_write_string (port) (sc, "(make-hash-table ", 17, port); - port_write_string (port) (sc, str, nlen, port); - port_write_character (port) (sc, ' ', port); - port_write_string (port) (sc, typer, safe_strlen (typer), port); - hash_typers_to_port (sc, hash, port); - } - if (is_immutable_hash_table (hash)) - port_write_character (port) (sc, ')', port); + TRACK(sc); + if ((sc->safety > no_safety) && + (!s7_is_valid(sc, obj))) + s7_warn(sc, 256, "the second argument to %s (the object): %p, is not an s7 object\n", __func__, obj); + + strport = open_format_port(sc); + s7i_object_out(sc, T_Pos(obj), strport, S7I_P_WRITE); + len = port_position(strport); + if ((S7_DEBUGGING) && (len == 0)) fprintf(stderr, "%s[%d]: len == 0\n", __func__, __LINE__); + /* 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 = inline_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); } -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 gc_iter, len= hash_table_entries (hash); - bool too_long= false, hash_cyclic= false, copied= false, immut= false, - letd= false; - s7_pointer iterator; - int32_t href= -1; - if (len == 0) { - if (use_write == p_readable) - hash_table_procedures_to_port (sc, hash, port, true, ci); - else { - 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= - 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); - iterator_carrier (iterator)= cons_unchecked (sc, sc->F, sc->F); - set_has_carrier (iterator); - hash_cyclic= - ((ci) && (is_cyclic (hash)) && ((href= peek_shared_ref (ci, hash)) != 0)); - - if (use_write == p_readable) { - if ((is_typed_hash_table (hash)) || - (is_pair (hash_table_procedures (hash))) || (hash_chosen (hash))) { - port_write_string (port) (sc, "(let (( ", 11, port); - letd= true; - } - else if ((is_immutable_hash_table (hash)) && (!hash_cyclic)) { - port_write_string (port) (sc, "(immutable! ", 12, port); - immut= true; - } +/* -------------------------------- object->string -------------------------------- */ +s7_pointer s7_object_to_string(s7_scheme *sc, s7_pointer obj, bool use_write) /* unavoidable backwards compatibility rigidity here */ +{ + if ((sc->safety > no_safety) && + (!s7_is_valid(sc, obj))) + s7_warn(sc, 256, "the second argument to %s (the object): %p, is not an s7 object\n", __func__, obj); + { + s7_pointer result; + const s7_pointer strport = open_format_port(sc); + s7i_object_out(sc, obj, strport, (use_write) ? S7I_P_WRITE : S7I_P_DISPLAY); + if (port_position(strport) >= port_data_size(strport)) + result = block_to_string(sc, reallocate(sc, port_data_block(strport), port_position(strport) + 1), port_position(strport)); + else result = block_to_string(sc, port_data_block(strport), port_position(strport)); + restore_format_port(sc, strport); + return(result); } +} - if ((use_write == p_readable) && (hash_cyclic)) { - if (href < 0) href= -href; - if ((!is_typed_hash_table (hash)) && - (!is_pair (hash_table_procedures (hash))) && (!hash_chosen (hash))) { - 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 */ - } - else { - hash_table_procedures_to_port (sc, hash, port, true, ci); - port_write_character (port) (sc, ')', port); - } +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 (*s7* '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; + const s7_pointer obj = car(args); + s7_int pending_max = S7_INT64_MAX; + const bool old_openlets = sc->has_openlets; + + if (is_pair(cdr(args))) + { + const s7_pointer arg2 = cadr(args); + if (arg2 == sc->F) choice = p_display; + else {if (arg2 == sc->T) choice = p_write; + else {if (arg2 == sc->readable_keyword) choice = p_readable; + else {if (arg2 == sc->display_keyword) choice = p_display; + else {if (arg2 == sc->write_keyword) choice = p_write; + else wrong_type_error_nr(sc, sc->object_to_string_symbol, 2, arg2, wrap_string(sc, "a boolean or :readable", 22));}}}} + + if (is_pair(cddr(args))) + { + const s7_pointer arg3 = caddr(args); + if (!s7_is_integer(arg3)) + { + if (choice == p_readable) /* (object->string #r(1 2 3) :readable "hi") */ + wrong_type_error_nr(sc, sc->object_to_string_symbol, 3, arg3, sc->type_names[T_INTEGER]); + return(method_or_bust(sc, arg3, sc->object_to_string_symbol, args, sc->type_names[T_INTEGER], 3)); + } + if (s7_integer_clamped_if_gmp(sc, arg3) < 0) + out_of_range_error_nr(sc, sc->object_to_string_symbol, int_three, arg3, a_non_negative_integer_string); + pending_max = s7_integer_clamped_if_gmp(sc, arg3); + }} + else choice = p_write; + /* can't use s7_object_to_string here anymore because it assumes use_write arg is a boolean */ - /* output here is deferred via ci->cycle_port until later in cyclic_out */ - for (s7_int i= 0; i < len; i++) { - const s7_pointer key_val= hash_table_iterate (sc, iterator); - if (key_val == sc->iterator_at_end_value) - break; /* key_val can be # if hash is a weak-hash-table, and a GC - happens during this loop */ + if (choice == p_readable) + sc->has_openlets = false; /* so (object->string obj :readable) ignores obj's object->string method -- is this a good idea? */ + else if_method_exists_return_value(sc, obj, sc->object_to_string_symbol, args); + { + s7_int out_len; + const s7_pointer strport = open_format_port(sc); + sc->objstr_max_len = pending_max; + s7i_object_out(sc, obj, strport, (s7i_use_write_t)choice); + sc->objstr_max_len = S7_INT64_MAX; + out_len = port_position(strport); + + if ((pending_max >= 0) && + (out_len > pending_max)) { - const s7_pointer key= car (key_val); - const s7_pointer val= cdr (key_val); - char buf[128]; - int32_t eref= peek_shared_ref (ci, val); - int32_t kref= peek_shared_ref (ci, key); - int32_t 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); - } + if (choice == p_readable) /* (object->string #r(1 2 3) :readable 4) */ + { + close_format_port(sc, strport); + sc->has_openlets = old_openlets; + out_of_range_error_nr(sc, sc->object_to_string_symbol, int_three, wrap_integer(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 (s7_int i = out_len - 3; i < out_len; i++) + port_data(strport)[i] = (uint8_t)'.'; } - } - } - else { - if (((!is_typed_hash_table (hash)) && - (!is_pair (hash_table_procedures (hash))) && (!hash_chosen (hash))) || - (use_write != p_readable)) { - 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); - } - else { - hash_table_procedures_to_port (sc, hash, port, true, ci); - port_write_character (port) (sc, ')', port); - port_write_string (port) (sc, ") (copy (hash-table", 19, port); - copied= true; - } - for (s7_int i= 0; i < len; i++) { - const s7_pointer key_val= hash_table_iterate (sc, iterator); - if (key_val == sc->iterator_at_end_value) - break; /* key_val can be # if hash is a weak-hash-table, and a GC - happens during this loop */ - port_write_character (port) (sc, ' ', port); - if ((use_write != p_readable) && (use_write != p_code) && - (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 (use_write != p_readable) { - if (too_long) port_write_string (port) (sc, " ...)", 5, port); - else port_write_character (port) (sc, ')', port); - } - } + { + s7_pointer result; + if (out_len >= port_data_size(strport)) /* this can happen (but only == I think) */ + result = block_to_string(sc, reallocate(sc, port_data_block(strport), out_len + 1), out_len); + else result = block_to_string(sc, port_data_block(strport), out_len); + restore_format_port(sc, strport); + sc->has_openlets = old_openlets; + return(result); + }} +} - if (use_write == p_readable) { - if (copied) { - if (!letd) { - char buf[128]; - int32_t plen= - catstrs_direct (buf, ") <", pos_int_to_str_direct (sc, href), ">", - (const char*) NULL); - port_write_string (port) (sc, buf, plen, port); - } - else port_write_string (port) (sc, ") ))", 7, port); - } - else if (letd) port_write_string (port) (sc, ") )", 6, port); - else port_write_character (port) (sc, ')', port); - if ((is_immutable_hash_table (hash)) && (!hash_cyclic) && - (!is_typed_hash_table (hash))) - port_write_character (port) (sc, ')', port); +/* -------------------------------- write -------------------------------- */ - if ((!immut) && (is_immutable_hash_table (hash)) && (!hash_cyclic)) - port_write_string (port) (sc, ") (immutable! ))", 19, port); - } - s7_gc_unprotect_at (sc, gc_iter); - iterator_carrier (iterator)= sc->nil; +static s7_pointer write_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + if (args == 2) /* not check_for_substring_temp(sc, expr) here -- write returns arg so can be immutable if substring_uncopied */ + return((caddr(expr) == sc->F) ? sc->display_f : sc->write_2); + return(func); } -static void -slot_list_to_port (s7_scheme* sc, s7_pointer slot, s7_pointer port, - shared_info_t* ci, - bool bindings) /* bindings=let/inlet choice */ + +/* -------------------------------- display -------------------------------- */ + +static s7_pointer display_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) { - bool first_time= true; - for (; is_not_slot_end (slot); slot= next_slot (slot)) { - if (bindings) { - if (first_time) { - port_write_character (port) (sc, '(', port); - first_time= false; - } - else port_write_string (port) (sc, " (", 2, port); - } - else port_write_character (port) (sc, ' ', port); - symbol_to_port ( - sc, slot_symbol (slot), port, (bindings) ? p_display : p_key, - NULL); /* (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); - } + 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(func); } -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) { - bool first_time= true; - for (; is_not_slot_end (slot); slot= next_slot (slot)) { - const s7_pointer sym= slot_symbol (slot), val= slot_value (slot); - if (bindings) { - if (first_time) { - port_write_character (port) (sc, '(', port); - first_time= false; - } - else port_write_string (port) (sc, " (", 2, port); - } - else port_write_character (port) (sc, ' ', port); - symbol_to_port (sc, sym, port, (bindings) ? p_display : p_key, NULL); - if (has_structure (val)) { - char buf[128]; - int32_t symref; - int32_t len= catstrs_direct ( - buf, " (set! (<", - pos_int_to_str_direct (sc, -peek_shared_ref (ci, obj)), "> ", - (const char*) NULL); - port_write_string (port) (sc, " #f", 3, port); - port_write_string (ci->cycle_port) (sc, buf, len, ci->cycle_port); - symbol_to_port (sc, sym, ci->cycle_port, p_key, NULL); - - 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= 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); - } - } -} +/* display may not be following the spec: (display '("a" #\b)): ("a" #\b), whereas Guile says (a b), in s7 write here == display, Guile write == s7 write */ -static bool -let_has_setter (s7_pointer obj) { - for (s7_pointer slot= let_slots (obj); is_not_slot_end (slot); - slot = next_slot (slot)) - if ((slot_has_setter (slot)) || (is_immutable_slot (slot))) return (true); - return (false); -} - -static bool -slot_setters_to_port (s7_scheme* sc, s7_pointer obj, s7_pointer port, - shared_info_t* ci) { - bool spaced_out= false; - for (s7_pointer slot= let_slots (obj); is_not_slot_end (slot); - slot = next_slot (slot)) - if (slot_has_setter (slot)) { - if (spaced_out) port_write_character (port) (sc, ' ', port); - else spaced_out= true; - port_write_string (port) (sc, "(set! (setter '", 15, port); - symbol_to_port (sc, slot_symbol (slot), port, p_display, NULL); - 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); - } - return (spaced_out); -} - -static void -immutable_slots_to_port (s7_scheme* sc, s7_pointer obj, s7_pointer port, - bool spaced_out) { - for (s7_pointer slot= let_slots (obj); is_not_slot_end (slot); - slot = next_slot (slot)) - if (is_immutable_slot (slot)) { - if (spaced_out) port_write_character (port) (sc, ' ', port); - else spaced_out= true; - port_write_string (port) (sc, "(immutable! '", 13, port); - symbol_to_port (sc, slot_symbol (slot), port, p_display, NULL); - port_write_character (port) (sc, ')', 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, NULL); - port_write_character (port) (sc, ' ', port); - object_to_port_with_circle_check (sc, slot_value (obj), port, use_write, ci); -} - -static void -internal_slot_to_port (s7_scheme* sc, s7_pointer obj, s7_pointer port, - use_write_t use_write, shared_info_t* ci) { - /* here we're displaying a slot in the debugger -- T_SLOT objects are not - * directly accessible in scheme */ - port_write_string (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 let points to (say) method list, the object needs to specialize - * object->string itself */ - if ((!sc->short_print) && - (has_active_methods ( - sc, obj))) /* short_print 14-Dec-24 from stacktrace (see below) */ - { - const s7_pointer print_func= - find_method (sc, obj, sc->object_to_string_symbol); - if (print_func != sc->undefined) { - s7_pointer str; - /* what needs to be protected here? for one, the function might not return - * a string! */ - - clear_has_methods (obj); - if ((use_write == p_write) || (use_write == p_code)) - str= s7_apply_function (sc, print_func, set_plist_1 (sc, obj)); - else - str= s7_apply_function (sc, print_func, - set_plist_2 (sc, obj, - (use_write == p_display) - ? sc->F - : sc->readable_keyword)); - set_has_methods (obj); - - if ((is_string (str)) && (string_length (str) > 0)) - port_write_string (port) (sc, string_value (str), string_length (str), - port); - return; - } - } - if (obj == sc->rootlet) { - port_write_string (port) (sc, "(rootlet)", 9, port); - return; - } - if (obj == sc->starlet) { - port_write_string (port) (sc, "*s7*", 4, port); - return; - } - /* if (is_unlet(obj)) {port_write_string(port)(sc, "(unlet)", 7, port); - * return;} */ /* this is the let created by (unlet), not sc->unlet_entries */ - if (sc->short_print) { - port_write_string (port) (sc, "#", 6, port); - return; - } - /* circles can happen here: (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= (int32_t) 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->rootlet) { - char buf[128]; - int32_t len= (int32_t) 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 (is_openlet (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)) /* both explicit setters and immutable slots */ - { - 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); - immutable_slots_to_port (sc, obj, 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 (is_openlet (obj)) port_write_character (port) (sc, ')', port); - } - else { - if (is_openlet (obj)) port_write_string (port) (sc, "(openlet ", 9, port); - if (is_immutable_let (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); - immutable_slots_to_port (sc, obj, 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->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= (int32_t) 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= let_ref_p_pp (sc, obj, sc->class_name_symbol); - if (is_symbol (name)) - symbol_to_port (sc, name, port, p_display, NULL); - 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_let (obj)) port_write_character (port) (sc, ')', port); - if (is_openlet (obj)) port_write_character (port) (sc, ')', port); - } - } - else /* not readable write */ +/* -------------------------------- 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)) + + const s7_pointer proc = car(args); + if ((!is_any_procedure(proc)) || /* this disallows goto/continuation */ + (!s7_is_aritable(sc, proc, 1))) + return(method_or_bust(sc, proc, sc->call_with_output_string_symbol, args, wrap_string(sc, "a procedure of one argument (the port)", 38), 1)); { - s7_pointer slot= let_slots (obj); - port_write_string (port) (sc, "(inlet", 6, port); - for (int32_t i= 1; is_not_slot_end (slot); i++, slot= next_slot (slot)) { - port_write_character (port) (sc, ' ', port); - slot_to_port (sc, slot, port, use_write, ci); - if ((is_not_slot_end (next_slot (slot))) && (i == sc->print_length)) { - port_write_string (port) (sc, " ...", 4, port); - break; - } - } - port_write_character (port) (sc, ')', port); + const s7_pointer 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); } -static void -write_macro_readably (s7_scheme* sc, s7_pointer obj, s7_pointer port) { - const s7_pointer body= closure_body (obj), parlist= closure_pars (obj); - /* this doesn't handle recursive macros well -- we need letrec or the - * equivalent as in write_closure_readably */ - /* (letrec ((m2 (macro (x) `(if (> ,x 0) (m2 (- ,x 1)) 32)))) - * (object->string m2 :readable)) */ - - 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 (parlist)) { - port_write_character (port) (sc, ' ', port); - port_write_string (port) (sc, symbol_name (parlist), - symbol_name_length (parlist), port); - port_write_character (port) (sc, ' ', port); - } - else if (is_pair (parlist)) { - s7_pointer pars; - port_write_string (port) (sc, " (", 2, port); - for (pars= parlist; is_pair (pars); pars= cdr (pars)) { - object_to_port (sc, car (pars), port, p_write, NULL); - if (is_pair (cdr (pars))) port_write_character (port) (sc, ' ', port); - } - if (!is_null (pars)) { - port_write_string (port) (sc, " . ", 3, port); - object_to_port (sc, pars, port, p_write, NULL); - } - port_write_string (port) (sc, ") ", 2, port); - } - else port_write_string (port) (sc, " () ", 4, port); - - for (s7_pointer 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 (const s7_pointer symbol, s7_pointer let) { - for (s7_pointer le= let; le; le= let_outlet (le)) - for (s7_pointer slot= let_slots (le); is_not_slot_end (slot); - slot = next_slot (slot)) - if (slot_symbol (slot) == symbol) return (slot); - return (NULL); -} - -static bool -slot_memq (const s7_pointer symbol, s7_pointer symbols) { - for (s7_pointer syms= symbols; is_pair (syms); syms= cdr (syms)) - if (slot_symbol (car (syms)) == symbol) return (true); - return (false); -} - -static bool -arg_memq (const s7_pointer symbol, s7_pointer args) { - for (s7_pointer p= args; is_pair (p); p= cdr (p)) - if ((car (p) == symbol) || ((is_pair (car (p))) && (caar (p) == symbol))) - return (true); - return (false); -} - -static void -collect_symbol (s7_scheme* sc, s7_pointer sym, s7_pointer let, 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= match_symbol (sym, let); - 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 let, s7_pointer args, - s7_int gc_loc) /* currently called only in write_closure_readably */ +/* -------------------------------- call-with-output-file -------------------------------- */ +static s7_pointer g_call_with_output_file(s7_scheme *sc, s7_pointer args) { - if (is_unquoted_pair (sc, body)) { - collect_locals (sc, car (body), let, args, gc_loc); - collect_locals (sc, cdr (body), let, args, gc_loc); + #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 + + const s7_pointer file = car(args), proc = cadr(args); + if (!is_string(file)) + return(method_or_bust(sc, file, sc->call_with_output_file_symbol, args, sc->type_names[T_STRING], 1)); + if ((!is_any_procedure(proc)) || + (!s7_is_aritable(sc, proc, 1))) + return(method_or_bust(sc, proc, sc->call_with_output_file_symbol, args, wrap_string(sc, "a procedure of one argument (the port)", 38), 2)); + { + const s7_pointer 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); } - else if (is_symbol (body)) collect_symbol (sc, body, let, args, gc_loc); + return(sc->F); } -static void -collect_specials (s7_scheme* sc, s7_pointer let, s7_pointer args, - s7_int gc_loc) { - collect_symbol (sc, sc->local_signature_symbol, let, args, gc_loc); - collect_symbol (sc, sc->local_setter_symbol, let, args, gc_loc); - collect_symbol (sc, sc->local_documentation_symbol, let, args, gc_loc); - collect_symbol (sc, sc->local_iterator_symbol, let, args, gc_loc); -} -static s7_pointer -find_closure (s7_scheme* sc, s7_pointer closure, s7_pointer current_let) { - for (s7_pointer let= current_let; let; let= let_outlet (let)) { - if ((is_funclet (let)) || (is_maclet (let))) { - s7_pointer sym = funclet_function (let); - s7_pointer func= s7_symbol_local_value (sc, sym, let); - if (func == closure) return (sym); - } - for (s7_pointer slot= let_slots (let); is_not_slot_end (slot); - slot = next_slot (slot)) - if (slot_value (slot) == closure) return (slot_symbol (slot)); - } - 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); -} +/* -------------------------------- 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)) -static void -write_closure_name (s7_scheme* sc, s7_pointer closure, s7_pointer port) { + const s7_pointer proc = car(args); + if (!is_thunk(sc, proc)) + { + if (is_any_procedure(proc)) /* i.e. c_function, lambda, macro, etc */ + { + s7_pointer req_args = wrap_integer(sc, procedure_required_args(sc, proc)); + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "~A requires ~D argument~P, but with-output-to-string's first argument should be a thunk", 87), + proc, req_args, req_args)); + } + else return(method_or_bust(sc, proc, sc->with_output_to_string_symbol, args, a_thunk_string, 1)); + } + if ((is_continuation(proc)) || (is_goto(proc))) + wrong_type_error_nr(sc, sc->with_output_to_string_symbol, 1, proc, a_normal_procedure_string); { - s7_pointer sym= find_closure (sc, closure, closure_let (closure)); - if (is_symbol (sym)) { - port_write_string (port) (sc, symbol_name (sym), symbol_name_length (sym), - port); - return; - } - } - switch (type (closure)) { - case T_CLOSURE: - port_write_string (port) (sc, "#", 3, port); - else { - s7_pointer pars= closure_pars (closure); - if (is_symbol (pars)) { - port_write_string (port) (sc, symbol_name (pars), - symbol_name_length (pars), port); - port_write_character (port) (sc, '>', - port); /* (lambda a a) -> # */ - } - else { - s7_pointer sym= car (pars); - if (is_pair (sym)) sym= car (sym); - port_write_character (port) (sc, '(', port); - port_write_string (port) (sc, symbol_name (sym), symbol_name_length (sym), - port); - if (!is_null (cdr (pars))) { - s7_pointer par; - port_write_character (port) (sc, ' ', port); - if (is_pair (cdr (pars))) { - par= cadr (pars); - if (is_pair (par)) par= car (par); - else if (par == sc->rest_keyword) { - port_write_string (port) (sc, ":rest ", 6, port); - pars= cdr (pars); - par = cadr (pars); - if (is_pair (par)) par= car (par); - } - } - else { - port_write_string (port) (sc, ". ", 2, port); - par= cdr (pars); - } - port_write_string (port) (sc, symbol_name (par), - symbol_name_length (par), port); - if ((is_pair (cdr (pars))) && (!is_null (cddr (pars)))) - port_write_string (port) (sc, " ...", 4, port); - } - port_write_string (port) (sc, ")>", 2, port); - } + const s7_pointer 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, proc); + return(sc->F); } -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 sym= find_closure (sc, closure, sc->curlet); - if (is_symbol (sym)) return (sym); - 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; - gc_protect_via_stack (sc, b); - if (is_null (p)) tp= cons (sc, car (a), b); - else { - s7_pointer np; - tp= list_1 (sc, car (a)); - set_gc_protected2 (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_gc_protect (sc); - return (tp); -} - -static void -write_closure_readably_1 (s7_scheme* sc, s7_pointer obj, s7_pointer arglist, - s7_pointer body, s7_pointer port) { - const s7_int old_print_length= sc->print_length; - - 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->temp7= - (is_null (cdr (arglist))) - ? set_plist_2 (sc, car (arglist), sc->allow_other_keys_keyword) - : ((is_null (cddr (arglist))) - ? set_plist_3 (sc, car (arglist), cadr (arglist), - sc->allow_other_keys_keyword) - : pair_append (sc, arglist, - list_1 (sc, sc->allow_other_keys_keyword))); - object_to_port (sc, sc->temp7, port, p_write, NULL); - sc->temp7= sc->unused; - } - else - object_to_port (sc, arglist, port, p_write, - NULL); /* here we just want the straight output (a b) not - (list 'a 'b) */ - - sc->print_length= 1048576; - for (s7_pointer 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) { - const s7_pointer body = closure_body (obj); - s7_pointer parlist= closure_pars (obj); - s7_pointer pe, local_slots, setter= NULL, obj_slot= NULL; - s7_int gc_loc; - bool sent_let= false, sent_letrec= false; - - if (sc->safety > no_safety) { - if (tree_is_cyclic (sc, body)) { - port_write_string (port) (sc, "#", - 41, port); /* not s7_error here! */ - return; - } - if ((!ci) && - (is_pair (parlist))) { /* (format #f "~W" (make-hook (let ((cp (list - 1))) (set-cdr! cp cp) (list 'quote cp)))) */ - shared_info_t* new_ci= make_shared_info (sc); - clear_shared_info (new_ci); - if (collect_shared_info (sc, new_ci, parlist, false)) { - free_shared_info (new_ci); - port_write_string (port) ( - sc, "#", 51, - port); /* not s7_error here! */ - return; - } - free_shared_info (new_ci); - } - } - if (is_symbol (parlist)) parlist= set_dlist_1 (sc, parlist); - pe= closure_let (obj); - gc_loc= gc_protect_1 (sc, sc->nil); - collect_locals (sc, body, pe, parlist, - gc_loc); /* collect locals used only here (and below) */ - collect_specials (sc, pe, parlist, gc_loc); +/* -------------------------------- 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 - if (s7_is_dilambda (obj)) { - setter= closure_setter (obj); - if (has_closure_let ( - setter)) /* collect args etc so need the parameter list */ + const s7_pointer file = car(args), proc = cadr(args); + if (!is_string(file)) + return(method_or_bust(sc, file, sc->with_output_to_file_symbol, args, sc->type_names[T_STRING], 1)); + if (!is_thunk(sc, proc)) { - parlist= closure_pars (setter); - if (is_symbol (parlist)) parlist= set_dlist_1 (sc, parlist); - collect_locals (sc, closure_body (setter), pe, parlist, gc_loc); - } + if (is_any_procedure(proc)) /* i.e. c_function, lambda, macro, etc */ + { + s7_pointer req_args = wrap_integer(sc, procedure_required_args(sc, proc)); + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "~A requires ~D argument~P, but with-output-to-file's second argument should be a thunk", 86), + proc, req_args, req_args)); + } + else return(method_or_bust(sc, proc, sc->with_output_to_file_symbol, args, a_thunk_string, 2)); + } + if ((is_continuation(proc)) || (is_goto(proc))) + wrong_type_error_nr(sc, sc->with_output_to_file_symbol, 1, proc, a_normal_procedure_string); + { + const s7_pointer 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); +} - local_slots= - T_Lst (gc_protected_at (sc, gc_loc)); /* possibly a list of slots */ - if (!is_null (local_slots)) { - /* if (let|letrec ((f (lambda () f))) (object->string f :readable)), - * local_slots: ('f f) */ - /* but we can't handle it below because that leads to an infinite loop */ - for (s7_pointer slots= local_slots; is_pair (slots); slots= cdr (slots)) { - const s7_pointer slot= car (slots); - 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))) { - if (!sent_let) { - port_write_string (port) (sc, "(let (", 6, port); - sent_let= true; - } - 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 (slots))) port_write_character (port) (sc, ')', port); - else port_write_string (port) (sc, ") ", 2, port); - } - } - if (sent_let) port_write_string (port) (sc, ") ", 2, port); - } - /* now we need to know if obj is in the closure_let via letrec, and if so, - * send out letrec+obj name+def below, then close it with obj-name?? the two - * cases are: (let ((f (lambda () f)))...) which is ok now, and (letrec ((f - * (lambda () f)))...) which needs the letrec - */ - if (!is_null (local_slots)) - for (s7_pointer slots= local_slots; is_pair (slots); slots= cdr (slots)) { - const s7_pointer slot= car (slots); - if ((is_any_closure (slot_value (slot))) && (slot_value (slot) == obj)) { - port_write_string (port) (sc, "(letrec ((", 10, - port); /* (letrec ((f (lambda () f))) f) */ - sent_letrec= true; - port_write_string (port) (sc, symbol_name (slot_symbol (slot)), - symbol_name_length (slot_symbol (slot)), - port); - port_write_character (port) (sc, ' ', port); - obj_slot= slot; - break; - } - } +/* -------------------------------- lists -------------------------------- */ +s7_pointer s7_cons(s7_scheme *sc, s7_pointer a, s7_pointer b) +{ + s7_pointer p; + new_cell(sc, p, T_PAIR | T_SAFE_PROCEDURE); + set_car(p, a); + set_cdr(p, b); + return(p); +} - if (setter) port_write_string (port) (sc, "(dilambda ", 10, port); - write_closure_readably_1 (sc, obj, closure_pars (obj), body, port); - if (setter) { - port_write_character (port) (sc, ' ', port); - if (has_closure_let (setter)) - write_closure_readably_1 (sc, setter, closure_pars (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 (sent_letrec) { - port_write_string (port) (sc, ")) ", 3, port); - port_write_string (port) (sc, symbol_name (slot_symbol (obj_slot)), - symbol_name_length (slot_symbol (obj_slot)), - port); - port_write_character (port) (sc, ')', port); - } - if (sent_let) port_write_character (port) (sc, ')', port); - s7_gc_unprotect_at (sc, gc_loc); +s7_pointer cons_unchecked(s7_scheme *sc, s7_pointer a, s7_pointer b) +{ + /* apparently slightly faster as a function? */ + s7_pointer p; + new_cell_unchecked(sc, p, T_PAIR | T_SAFE_PROCEDURE); + set_car(p, a); + set_cdr(p, b); + return(p); } -static void -iterator_hash_table_to_port (s7_scheme* sc, s7_pointer port, s7_pointer table) { - if (is_weak_hash_table (table)) - port_write_string (port) (sc, "(make-iterator (weak-hash-table))", 33, - port); - else port_write_string (port) (sc, "(make-iterator (hash-table))", 28, port); +static s7_pointer semipermanent_cons(s7_scheme *sc, s7_pointer a, s7_pointer b, s7_uint type) +{ + s7_pointer p = alloc_pointer(sc); + set_full_type(p, type | T_UNHEAP); + set_car(p, a); + set_cdr_unchecked(p, b); + return(p); } -static void -iterator_to_port (s7_scheme* sc, s7_pointer iter, s7_pointer port, - use_write_t use_write, shared_info_t* ci) { - if (use_write == p_readable) { - if (iterator_is_at_end (iter)) { - switch (type (iterator_sequence (iter))) { - 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_COMPLEX_VECTOR: - port_write_string (port) (sc, "(make-iterator #c())", 20, port); - break; - case T_LET: - port_write_string (port) (sc, "(make-iterator (inlet))", 23, port); - break; - case T_HASH_TABLE: - iterator_hash_table_to_port (sc, port, iterator_sequence (iter)); - break; - default: - port_write_string (port) (sc, "(make-iterator ())", 18, port); - break; /* c-object?? function? */ - } - } - else { - const s7_pointer seq= iterator_sequence (iter); - int32_t iter_ref; - if ((ci) && (is_cyclic (iter)) && - ((iter_ref= peek_shared_ref (ci, iter)) != 0)) { - /* basically the same as c_pointer_to_port */ - if (!is_cyclic_set (iter)) { - 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= (int32_t) 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 (iter); - return; - } - } +static s7_pointer semipermanent_list(s7_scheme *sc, s7_int len) +{ + s7_pointer p = sc->nil; + for (s7_int j = 0; j < len; j++) + p = semipermanent_cons(sc, sc->unused, p, T_PAIR | T_IMMUTABLE); + return(p); +} - if (is_string (seq)) { - const s7_int len= string_length (seq) - iterator_position (iter); - if (len == 0) - port_write_string (port) (sc, "(make-iterator \"\")", 18, port); - else { - const char* iter_str= - (const char*) (string_value (seq) + iterator_position (iter)); - port_write_string (port) (sc, "(make-iterator \"", 16, port); - if (!string_needs_slashification ((const uint8_t*) 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 (iter), port, - use_write, ci); - port_write_character (port) (sc, ')', port); - } - else { - if ((is_let (seq)) && (seq != sc->rootlet) && (seq != sc->starlet)) { - 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 (s7_pointer slot = let_slots (seq); - slot != let_iterator_slot (iter); slot= next_slot (slot)) - port_write_string (port) (sc, "(iter) ", 7, port); - port_write_string (port) (sc, "iter)", 5, port); - } - else { - if (iterator_position (iter) > 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 (iter) > 0) { - if (iterator_position (iter) == 1) - port_write_string (port) (sc, "))) (iter) iter)", 16, port); - else { - char str[128]; - int32_t nlen= (int32_t) catstrs_direct ( - str, "))) (do ((i 0 (+ i 1))) ((= i ", - pos_int_to_str_direct (sc, iterator_position (iter)), - ") iter) (iter)))", (const char*) NULL); - port_write_string (port) (sc, str, nlen, port); - } - } - else port_write_character (port) (sc, ')', port); - } - } - } +s7_pointer s7_make_signature(s7_scheme *sc, s7_int len, ...) +{ + va_list ap; + s7_int i; + s7_pointer result = sc->nil; + + for (i = 0; i < len; i++) + result = semipermanent_cons(sc, sc->unused, result, T_PAIR | T_IMMUTABLE); + va_start(ap, len); + i = 0; /* or 1? */ + for (s7_pointer p = result; is_pair(p); p = cdr(p), i++) + { + set_car(p, va_arg(ap, s7_pointer)); + if ((!is_normal_symbol(car(p))) && (!is_boolean(car(p))) && (!is_pair(car(p)))) + s7_warn(sc, 512, "s7_make_signature got an invalid entry %s at position %" ld64, display(car(p)), i); } - } - else { - const char* str; - if ((is_hash_table (iterator_sequence (iter))) && - (is_weak_hash_table (iterator_sequence (iter)))) - str= "weak-hash-table"; - else if (iterator_sequence (iter) == sc->starlet) str= "*s7*"; - else str= type_name (sc, iterator_sequence (iter), no_article); - port_write_string (port) (sc, "#', port); - } + va_end(ap); + return(result); } -static void -c_pointer_to_port (s7_scheme* sc, s7_pointer cptr, s7_pointer port, - use_write_t use_write, shared_info_t* ci) { -#define CP_BUFSIZE 128 - char buf[CP_BUFSIZE]; - int32_t nlen; - if (use_write == p_readable) { - int32_t ref; - if ((ci) && (is_cyclic (cptr)) && - ((ref= peek_shared_ref (ci, cptr)) != 0)) { - port_write_string (port) (sc, "#f", 2, port); - if (!is_cyclic_set (cptr)) { - 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 (cptr)); - port_write_string (ci->init_port) (sc, buf, nlen, ci->init_port); - - if ((c_pointer_type (cptr) != sc->F) || - (c_pointer_info (cptr) != sc->F)) { - flip_ref (ci, c_pointer_type (cptr)); - - port_write_character (ci->init_port) (sc, ' ', ci->init_port); - object_to_port_with_circle_check (sc, c_pointer_type (cptr), - ci->init_port, use_write, ci); +s7_pointer s7_make_circular_signature(s7_scheme *sc, s7_int cycle_point, s7_int len, ...) +{ + va_list ap; + s7_int i; + s7_pointer result = sc->nil, back = NULL, end = NULL; + + for (i = 0; i < len; i++) + result = semipermanent_cons(sc, sc->nil, result, T_PAIR | T_IMMUTABLE); + va_start(ap, len); + i = 0; + for (s7_pointer p = result; is_pair(p); p = cdr(p), i++) + { + set_car(p, va_arg(ap, s7_pointer)); + if ((!is_normal_symbol(car(p))) && (!is_boolean(car(p))) && (!is_pair(car(p)))) + s7_warn(sc, 512, "s7_make_circular_signature got an invalid entry %s at position %" ld64, display(car(p)), i); + if (i == cycle_point) back = p; + if (i == (len - 1)) end = p; + } + va_end(ap); + if (end) set_cdr_unchecked(end, back); + if (i < len) + s7_warn(sc, 256, "s7_make_circular_signature got too few entries: %s\n", display(result)); + return(result); +} + + +bool s7_is_pair(s7_pointer p) {return(is_pair(p));} +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);} + + +/* -------------------------------------------------------------------------------- */ +void s7_list_to_array(s7_scheme *sc, s7_pointer list, s7_pointer *array, int32_t len) +{ + int32_t i = 0; + for (s7_pointer p = list; is_pair(p); p = cdr(p), i++) array[i] = car(p); + for (; i < len; i++) array[i] = sc->undefined; +} - flip_ref (ci, c_pointer_type (cptr)); - flip_ref (ci, c_pointer_info (cptr)); - port_write_character (ci->init_port) (sc, ' ', ci->init_port); - object_to_port_with_circle_check (sc, c_pointer_info (cptr), - ci->init_port, use_write, ci); +/* ---------------- 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 = car(p); + if ((!is_pair(cp)) || + (is_quote(sc, car(cp)))) + sum++; + else + { + do { + s7_pointer ccp = car(cp); + if ((!is_pair(ccp)) || + (is_quote(sc, car(ccp)))) + sum++; + else + { + do { + s7_pointer cccp = car(ccp); + if ((!is_pair(cccp)) || + (is_quote(sc, car(cccp)))) + 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 tree) +{ + if (is_null(tree)) + return(0); + if ((!is_pair(tree)) || (is_quote(sc, car(tree)))) + return(1); + return(tree_len_1(sc, tree)); +} - flip_ref (ci, c_pointer_info (cptr)); - } - port_write_string (ci->init_port) (sc, "))\n", 3, ci->init_port); - set_cyclic_set (cptr); - } - } - else { - nlen= snprintf (buf, CP_BUFSIZE, "(c-pointer %" p64, - (intptr_t) c_pointer (cptr)); - port_write_string (port) (sc, buf, clamp_length (nlen, CP_BUFSIZE), port); - if ((c_pointer_type (cptr) != sc->F) || - (c_pointer_info (cptr) != sc->F)) { - port_write_character (port) (sc, ' ', port); - object_to_port_with_circle_check (sc, c_pointer_type (cptr), port, - use_write, ci); - port_write_character (port) (sc, ' ', port); - object_to_port_with_circle_check (sc, c_pointer_info (cptr), port, - use_write, ci); - } - port_write_character (port) (sc, ')', port); +static s7_int tree_leaves_i_7p(s7_scheme *sc, s7_pointer tree) +{ + if (!is_pair(tree)) + { + if (is_null(tree)) return(0); + if (!has_active_methods(sc, tree)) + sole_arg_wrong_type_error_nr(sc, sc->tree_leaves_symbol, tree, a_list_string); + return(integer(find_and_apply_method(sc, tree, sc->tree_leaves_symbol, set_mlist_1(sc, tree)))); } - } - else { - if ((is_symbol (c_pointer_type (cptr))) && - (symbol_name_length (c_pointer_type (cptr)) < (CP_BUFSIZE / 2))) - nlen= snprintf (buf, CP_BUFSIZE, "#<%s %p>", - symbol_name (c_pointer_type (cptr)), c_pointer (cptr)); - else nlen= snprintf (buf, CP_BUFSIZE, "#", c_pointer (cptr)); - port_write_string (port) (sc, buf, clamp_length (nlen, CP_BUFSIZE), port); - } + if ((sc->safety > no_safety) && (tree_is_cyclic(sc, tree))) + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "tree-leaves: tree is cyclic: ~S", 31), tree)); + return(tree_len(sc, tree)); } -static void -random_state_to_port (s7_scheme* sc, s7_pointer rs, s7_pointer port, - use_write_t use_write, shared_info_t* unused_ci) { -#define B_BUFSIZE 128 - char buf[B_BUFSIZE]; - int32_t nlen; - if (use_write == p_readable) - nlen= snprintf (buf, B_BUFSIZE, "(random-state %" PRIu64 " %" PRIu64 ")", - random_seed (rs), random_carry (rs)); - else - nlen= snprintf (buf, B_BUFSIZE, "#", - random_seed (rs), random_carry (rs)); - port_write_string (port) (sc, buf, clamp_length (nlen, B_BUFSIZE), port); -} +/* tree_leaves_p_p migrated to s7_liii_list.c */ -static void -display_fallback (s7_scheme* sc, s7_pointer obj, s7_pointer port, - use_write_t unused_use_write, shared_info_t* unused_ci) { -#if S7_DEBUGGING - print_debugging_state (sc, obj, port); -#else - if (is_free (obj)) port_write_string (port) (sc, "", 12, port); - else port_write_string (port) (sc, "", 17, port); -#endif -} +/* g_tree_leaves is now defined in s7_scheme_predicate.c */ +#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->is_list_symbol) -static void -unique_to_port (s7_scheme* sc, s7_pointer obj, s7_pointer port, - use_write_t unused_use_write, shared_info_t* unused_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* unused_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); +/* ---------------- tree-memq ---------------- */ +static inline bool tree_memq_1(s7_scheme *sc, s7_pointer sym, s7_pointer tree) /* sym need not be a symbol */ +{ + if (is_quote(sc, car(tree))) + 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 (is_quote(sc, car(cp))) + { + 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); /* this happens a lot */ + if ((sc->safety > no_safety) && (tree_is_cyclic(sc, tree))) + error_nr(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 void -eof_to_port (s7_scheme* sc, s7_pointer obj, s7_pointer port, - use_write_t use_write, shared_info_t* unused_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 unused_obj, s7_pointer port, - use_write_t unused_use_write, shared_info_t* unused_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 unused_use_write, shared_info_t* unused_ci) { - /* killer overhead here; breaking it into named/unnamed funcs helps only - * slightly -- still ridiculous overhead according to callgrind */ - const s7_int num= integer (obj); - if ((num < 10) && (num >= 0)) { - static const char* ones[10]= {"0", "1", "2", "3", "4", - "5", "6", "7", "8", "9"}; - if (is_string_port (port)) { - if (port_position (port) + 1 < port_data_size (port)) { - memcpy ((void*) (port_data (port) + port_position (port)), - (void*) ones[num], 1); - port_position (port)+= 1; - } - else string_write_string_resized (sc, ones[num], 1, port); +static bool tree_memq_b_7pp(s7_scheme *sc, s7_pointer sym, s7_pointer tree) +{ + if (!is_list(tree)) + { + if (!has_active_methods(sc, tree)) + wrong_type_error_nr(sc, sc->tree_memq_symbol, 2, tree, a_list_string); + return(find_and_apply_method(sc, tree, sc->tree_memq_symbol, set_mlist_2(sc, sym, tree)) != sc->F); } - else port_write_string (port) (sc, ones[num], 1, port); - } - else { - s7_int nlen= 0; - const char* str = integer_to_string (sc, integer (obj), &nlen); - port_write_string (port) (sc, str, nlen, port); - } + return(s7_tree_memq(sc, sym, tree)); } -static void -number_to_port (s7_scheme* sc, s7_pointer num, s7_pointer port, - use_write_t use_write, shared_info_t* unused_ci) { - s7_int nlen= 0; - char* str = number_to_string_base_10 (sc, num, 0, sc->float_format_precision, - 'g', &nlen, use_write); /* was 14 */ - port_write_string (port) (sc, str, nlen, port); -} +/* g_tree_memq is now defined in s7_scheme_predicate.c */ +#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->is_list_symbol) -static void -syntax_to_port (s7_scheme* sc, s7_pointer obj, s7_pointer port, - use_write_t unused_use_write, shared_info_t* unused_ci) { - if (is_initial_value (obj)) port_write_string (port) (sc, "#_", 2, port); - port_display (port) (sc, symbol_name (syntax_symbol (obj)), port); +static /* inline */ bool tree_including_quote_memq(s7_scheme *sc, s7_pointer sym, s7_pointer tree) /* sym need not be a symbol */ +{ + do { + if (sym == car(tree)) + return(true); + if (is_pair(car(tree))) + { + s7_pointer cp = car(tree); + do { + if (sym == car(cp)) + return(true); + if ((is_pair(car(cp))) && (tree_including_quote_memq(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); } -static void -character_to_port (s7_scheme* sc, s7_pointer c, s7_pointer port, - use_write_t use_write, shared_info_t* unused_ci) { - if (use_write == p_display) port_write_unicode_char (sc, character (c), port); - else - port_write_string (port) (sc, character_name (c), character_name_length (c), - port); -} - -static void -closure_to_port (s7_scheme* sc, s7_pointer func, s7_pointer port, - use_write_t use_write, shared_info_t* ci) { - if (has_active_methods (sc, func)) { - /* 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. - */ - const s7_pointer print_func= - find_method (sc, closure_let (func), sc->object_to_string_symbol); - if (print_func != sc->undefined) { - s7_pointer str= - s7_apply_function (sc, print_func, set_plist_1 (sc, func)); - if (string_length (str) > 0) - port_write_string (port) (sc, string_value (str), string_length (str), - port); - return; - } - } - if (use_write == p_readable) write_closure_readably (sc, func, port, ci); - else write_closure_name (sc, func, port); -} - -static void -macro_to_port (s7_scheme* sc, s7_pointer func, s7_pointer port, - use_write_t use_write, shared_info_t* unused_ci) { - if (has_active_methods (sc, func)) { - const s7_pointer print_func= - find_method (sc, closure_let (func), sc->object_to_string_symbol); - if (print_func != sc->undefined) { - s7_pointer str= - s7_apply_function (sc, print_func, set_plist_1 (sc, func)); - if (string_length (str) > 0) - port_write_string (port) (sc, string_value (str), string_length (str), - port); - return; + +/* ---------------- 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_small_symbol_set(sc, p)) + return(true); + } + else + if ((is_unquoted_pair(sc, p)) && + (pair_set_memq(sc, p))) + return(true); + tree = cdr(tree); + if (!is_pair(tree)) break; } - } - if (use_write == p_readable) write_macro_readably (sc, func, port); - else write_closure_name (sc, func, port); + return((is_symbol(tree)) && (symbol_is_in_small_symbol_set(sc, tree))); } -static void -c_function_to_port ( - s7_scheme* sc, s7_pointer func, s7_pointer port, use_write_t use_write, - shared_info_t* unused_ci) { /* includes c_function_star, so - c_function_symbol can't be used */ - const s7_int len= c_function_name_length (func); - - if (is_string_port (port)) /* expand port_write_string -> string_write_string, - 15 in tauto */ - { - if (len > 0) { - if (port_position (port) + len + 2 < port_data_size (port)) { - if (is_initial_value (func)) - port_write_string (port) (sc, "#_", 2, port); - memcpy ((void*) (port_data (port) + port_position (port)), - (const void*) c_function_name (func), len); - port_position (port)+= len; - } - else string_write_string_resized (sc, c_function_name (func), len, port); +static bool tree_set_memq_b_7pp(s7_scheme *sc, s7_pointer syms, s7_pointer tree) +{ + bool non_symbols = false; + if (!is_list(syms)) + { + if (!has_active_methods(sc, syms)) + wrong_type_error_nr(sc, sc->tree_set_memq_symbol, 1, syms, a_list_string); + return(find_and_apply_method(sc, syms, sc->tree_set_memq_symbol, set_mlist_2(sc, syms, tree)) != sc->F); } - else port_write_string (port) (sc, "#", 13, port); - } - else if (len > 0) { - if (is_initial_value (func)) port_write_string (port) (sc, "#_", 2, port); - port_write_string (port) (sc, c_function_name (func), len, port); + if (!is_pair(tree)) + { + if (is_null(tree)) return(false); + /* (define (func) (do ((i 0 (+ i 1)) (var #f)) ((= i 1) var) (set! var (tree-set-memq (list) (block))))) (func) */ + if (!has_active_methods(sc, tree)) + wrong_type_error_nr(sc, sc->tree_set_memq_symbol, 2, tree, a_list_string); + return(find_and_apply_method(sc, tree, sc->tree_set_memq_symbol, set_mlist_2(sc, syms, tree)) != sc->F); + } + if (is_null(syms)) return(false); + if (sc->safety > no_safety) + { + if (tree_is_cyclic(sc, syms)) + error_nr(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)) + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "tree-set-memq: tree is cyclic: ~S", 33), tree)); + } + begin_small_symbol_set(sc); + for (s7_pointer p = syms; is_pair(p); p = cdr(p)) + if (is_symbol(car(p))) + add_symbol_to_small_symbol_set(sc, car(p)); + else non_symbols = true; + { + bool result = pair_set_memq(sc, tree); + end_small_symbol_set(sc); + if (result) return(true); } - else port_write_string (port) (sc, "#", 13, port); + if (non_symbols) + for (s7_pointer p = syms; is_pair(p); p = cdr(p)) + if ((!is_symbol(car(p))) && + (s7_tree_memq(sc, car(p), tree))) + return(true); + return(false); } -static void -c_macro_to_port (s7_scheme* sc, s7_pointer func, s7_pointer port, - use_write_t unused_use_write, shared_info_t* unused_ci) { - if (c_macro_name_length (func) > 0) { - if (is_initial_value (func)) port_write_string (port) (sc, "#_", 2, port); - port_write_string (port) (sc, c_macro_name (func), - c_macro_name_length (func), port); - } - else port_write_string (port) (sc, "#", 10, port); -} +/* tree_set_memq_p_pp migrated to s7_liii_list.c */ -/* (eval-string (object->string (call-with-exit (lambda (go) go)) :readable)) - * should at least be readable if use_write == p_readable, but the normal form - * "#" gives a read-error due to the embedded space. So if :readable, - * we return "#" which isn't going to do "the right thing", but at - * least it doesn't raise a read-error. - */ +/* g_tree_set_memq is now defined in s7_scheme_predicate.c */ +#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->is_list_symbol, sc->is_list_symbol) -static void -goto_to_port (s7_scheme* sc, s7_pointer obj, s7_pointer port, - use_write_t use_write, shared_info_t* unused_ci) { - if (is_symbol (call_exit_name (obj))) { - port_write_string (port) (sc, "#', port); +static s7_pointer tree_set_memq_syms_direct(s7_scheme *sc, s7_pointer syms, s7_pointer tree) +{ + if (!is_pair(tree)) + { + if (is_null(tree)) return(sc->F); + if (!has_active_methods(sc, tree)) + wrong_type_error_nr(sc, sc->tree_set_memq_symbol, 2, tree, a_list_string); + return(find_and_apply_method(sc, tree, sc->tree_set_memq_symbol, set_mlist_2(sc, syms, tree))); + } + if (is_quote(sc, car(tree))) return(sc->F); + if ((sc->safety > no_safety) && (tree_is_cyclic(sc, tree))) + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "tree-set-memq: tree is cyclic: ~S", 33), tree)); + begin_small_symbol_set(sc); + for (s7_pointer p = syms; is_pair(p); p = cdr(p)) + add_symbol_to_small_symbol_set(sc, car(p)); + { + bool result = pair_set_memq(sc, tree); + end_small_symbol_set(sc); + return(make_boolean(sc, result)); } - 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, "#', port); -} +/* g_tree_set_memq_syms migrated to s7_scheme_predicate.c */ -static void -dynamic_wind_to_port (s7_scheme* sc, s7_pointer unused_obj, s7_pointer port, - use_write_t unused_use_write, shared_info_t* unused_ci) { - /* this can happen because (*s7* 'stack) can involve dynamic-wind markers */ - port_write_string (port) (sc, "#", 15, port); +/* bridge for g_tree_set_memq_syms migration */ +s7_pointer s7i_tree_set_memq_syms_direct(s7_scheme *sc, s7_pointer a, s7_pointer b) +{ + return(tree_set_memq_syms_direct(sc, a, b)); } -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 s7_pointer tree_set_memq_chooser(s7_scheme *sc, s7_pointer func, int32_t unused_args, s7_pointer expr) +{ + if ((is_proper_quote(sc, cadr(expr))) && /* not (tree-set-memq (quote) ...) */ + (is_pair(cadadr(expr)))) /* (tree-set-memq '(...)...) */ + { + for (s7_pointer p = cadadr(expr); is_pair(p); p = cdr(p)) + if (!is_symbol(car(p))) + return(func); + return(sc->tree_set_memq_syms); + } + return(func); } -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= ((*(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)) /* plist here and below can clobber args if SHOW_EVAL_ARGS */ - { - set_mlist_2 (sc, obj, - (use_write == p_readable) - ? sc->readable_keyword - : ((use_write == p_write) ? sc->T : sc->F)); - port_display (port) ( - sc, s7_string ((*(c_object_to_string (sc, obj))) (sc, sc->mlist_2)), - 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))) { - int32_t href; - const s7_pointer old_w= sc->w; - const s7_pointer obj_list= - ((*(c_object_to_list (sc, obj))) (sc, set_mlist_1 (sc, obj))); - sc->w= obj_list; - if ((ci) && (is_cyclic (obj)) && - ((href= peek_shared_ref (ci, obj)) != 0)) { - s7_pointer p= obj_list; - if (href < 0) href= -href; - if ((ci->defined[href]) || (port == ci->cycle_port)) { - char buf[128]; - int32_t 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 (int32_t i= 0; is_pair (p); i++, p= cdr (p)) { - s7_pointer val= car (p); - if (has_structure (val)) { - char buf[128]; - int32_t symref; - int32_t len= (int32_t) 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 (port) (sc, " #f", 3, port); - 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= (int32_t) 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 (s7_pointer p= obj_list; is_pair (p); p= cdr (p)) { - s7_pointer 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 -stack_to_port (s7_scheme* sc, const s7_pointer obj, s7_pointer port, - use_write_t unused_use_write, shared_info_t* unused_ci) { - if (obj == sc->stack) - port_write_string (port) (sc, "#", 16, port); - else port_write_string (port) (sc, "#", 8, port); -} - -static void -init_display_functions (void) { - for (int32_t i= 0; i < 256; i++) - display_functions[i]= display_fallback; - display_functions[T_BACRO] = macro_to_port; - display_functions[T_BACRO_STAR] = macro_to_port; - display_functions[T_BOOLEAN] = unique_to_port; - display_functions[T_BYTE_VECTOR] = byte_vector_to_port; - display_functions[T_CATCH] = catch_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_COMPLEX] = number_to_port; - display_functions[T_COMPLEX_VECTOR] = complex_vector_to_port; - display_functions[T_CONTINUATION] = continuation_to_port; - display_functions[T_COUNTER] = counter_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_OBJECT] = c_object_to_port; - display_functions[T_C_POINTER] = c_pointer_to_port; - display_functions[T_C_RST_NO_REQ_FUNCTION]= c_function_to_port; - display_functions[T_DYNAMIC_WIND] = dynamic_wind_to_port; - display_functions[T_EOF] = eof_to_port; - display_functions[T_FLOAT_VECTOR] = float_vector_to_port; - display_functions[T_GOTO] = goto_to_port; - display_functions[T_HASH_TABLE] = hash_table_to_port; - display_functions[T_INPUT_PORT] = input_port_to_port; - display_functions[T_INTEGER] = integer_to_port; - display_functions[T_INT_VECTOR] = int_vector_to_port; - display_functions[T_ITERATOR] = iterator_to_port; - display_functions[T_LET] = let_to_port; - display_functions[T_MACRO] = macro_to_port; - display_functions[T_MACRO_STAR] = macro_to_port; - display_functions[T_NIL] = unique_to_port; - display_functions[T_OUTPUT_PORT] = output_port_to_port; - display_functions[T_PAIR] = pair_to_port; - display_functions[T_RANDOM_STATE] = random_state_to_port; - display_functions[T_RATIO] = number_to_port; - display_functions[T_REAL] = number_to_port; - display_functions[T_SLOT] = internal_slot_to_port; - display_functions[T_STACK] = stack_to_port; - display_functions[T_STRING] = string_to_port; - display_functions[T_SYMBOL] = symbol_to_port; - display_functions[T_SYNTAX] = syntax_to_port; - display_functions[T_UNDEFINED] = undefined_to_port; - display_functions[T_UNSPECIFIED] = unique_to_port; - display_functions[T_UNUSED] = unique_to_port; - display_functions[T_VECTOR] = vector_to_port; -} - -static void -object_to_port_with_circle_check_1 (s7_scheme* sc, s7_pointer obj, - s7_pointer port, use_write_t use_write, - shared_info_t* ci) { - const int32_t ref= (is_collected (obj)) ? shared_ref (ci, obj) : 0; - if (ref == 0) object_to_port (sc, obj, port, use_write, ci); - else { - char buf[32]; - int32_t nlen; - if (ref > 0) { - if (use_write == p_readable) { - if (ci->defined[ref]) { - flip_ref (ci, obj); - nlen= (int32_t) 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, obj, port, p_readable, ci); - } - else { /* "normal" printout involving #n= and #n# */ s7_int len= 0; - char* p= pos_int_to_str (sc, (s7_int) ref, &len, '='); - *--p = '#'; - port_write_string (port) (sc, p, len, port); - object_to_port (sc, obj, port, not_p_display (use_write), ci); - } - } - else if (use_write == p_readable) { - nlen= (int32_t) catstrs_direct ( - buf, "<", pos_int_to_str_direct (sc, -ref), ">", (const char*) NULL); - port_write_string (port) (sc, buf, nlen, port); - } - else { - s7_int len= 0; - char* p = pos_int_to_str (sc, (s7_int) (-ref), &len, '#'); - *--p = '#'; - port_write_string (port) (sc, p, len, port); - } - } +/* ---------------- tree-count ---------------- */ +static s7_int tree_count(s7_scheme *sc, s7_pointer obj, s7_pointer tree, s7_int count) +{ + if (tree == obj) return(count + 1); + if ((!is_pair(tree)) || (is_quote(sc, car(tree)))) return(count); + return(tree_count(sc, obj, cdr(tree), tree_count(sc, obj, car(tree), count))); } -static s7_pointer -cyclic_out (s7_scheme* sc, s7_pointer obj, s7_pointer port, shared_info_t* ci) { - int32_t 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 (int32_t 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= (int32_t) 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; - } +static inline s7_int tree_count_at_least(s7_scheme *sc, s7_pointer obj, s7_pointer tree, s7_int count, s7_int top) +{ + if (tree == obj) return(count + 1); + if ((!is_pair(tree)) || (is_quote(sc, car(tree)))) return(count); + do { + count = tree_count_at_least(sc, obj, car(tree), count, top); + if (count >= top) return(count); + tree = cdr(tree); + if (tree == obj) return(count + 1); + } while (is_pair(tree)); + return(count); +} - 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= (int32_t) catstrs_direct ( - buf, "<", pos_int_to_str_direct (sc, (ref < 0) ? -ref : ref), ">", - (const char*) NULL); - port_write_string (port) (sc, buf, len, port); - } +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->is_list_symbol, sc->is_integer_symbol) + const s7_pointer obj = car(args), tree = cadr(args); + s7_pointer count; - 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_Pos (obj), strport, choice, - sc->circle_info); - else { - shared_info_t* ci= load_shared_info (sc, T_Pos (obj), choice != p_readable, - sc->circle_info); - 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, T_Pos (obj), strport, choice, ci); - sc->object_out_locked= false; + if (!is_pair(tree)) + { + if ((is_pair(cddr(args))) && + (!s7_is_integer(caddr(args)))) + wrong_type_error_nr(sc, sc->tree_count_symbol, 3, caddr(args), sc->type_names[T_INTEGER]); + if (is_null(tree)) return(int_zero); + if (!has_active_methods(sc, tree)) + wrong_type_error_nr(sc, sc->tree_count_symbol, 2, tree, a_list_string); + return(find_and_apply_method(sc, tree, sc->tree_count_symbol, set_mlist_2(sc, obj, tree))); } - else object_to_port (sc, obj, strport, choice, NULL); - } + if ((sc->safety > no_safety) && (tree_is_cyclic(sc, tree))) + error_nr(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)) + wrong_type_error_nr(sc, sc->tree_count_symbol, 3, count, sc->type_names[T_INTEGER]); + return(make_integer(sc, tree_count_at_least(sc, obj, tree, 0, s7_integer_clamped_if_gmp(sc, count)))); } -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); -} - -/* -------------------------------- s7i helpers for s7_scheme_write.c - * -------------------------------- */ -bool -s7i_port_is_closed (s7_pointer p) { - return port_is_closed (p); -} +/* -------------------------------- pair? -------------------------------- */ +#define H_is_pair "(pair? obj) returns #t if obj is a pair (a non-empty list)" +#define Q_is_pair sc->pl_bt +/* g_is_pair is now defined in s7_liii_list.c */ -s7_pointer -s7i_object_out (s7_scheme* sc, s7_pointer obj, s7_pointer port, - s7i_use_write_t choice) { - return object_out (sc, obj, port, (use_write_t) choice); -} -void -s7i_port_write_character (s7_scheme* sc, char c, s7_pointer port) { - port_write_character (port) (sc, c, port); -} +/* -------------------------------- list? -------------------------------- */ +bool s7_is_list(s7_scheme *sc, s7_pointer p) {return(is_list(p));} -void -s7i_port_write_string (s7_scheme* sc, const char* str, s7_int len, - s7_pointer port) { - port_write_string (port) (sc, str, len, port); -} +static bool is_list_b(s7_pointer p) {return((is_pair(p)) || (type(p) == T_NIL));} -void -s7i_port_write_unicode_char (s7_scheme* sc, uint32_t c, s7_pointer port) { - port_write_unicode_char (sc, c, port); -} +#define H_is_list "(list? obj) returns #t if obj is a pair or null" +#define Q_is_list sc->pl_bt +/* g_is_list is now defined in s7_liii_list.c */ -s7_pointer -s7i_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) { - return start_and_end (sc, caller, args, position, index_args, start, end); +static s7_int proper_list_length(s7_pointer a) +{ + s7_int i = 0; + for (s7_pointer b = a; is_pair(b); i++, b = cdr(b)) {}; + return(i); } -bool -s7i_is_unused (s7_scheme* sc, s7_pointer p) { - return p == sc->unused; +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_pointer -s7i_method_or_bust_p (s7_scheme* sc, s7_pointer obj, const char* method_name, - const char* type_name) { - return method_or_bust_p ( - sc, obj, s7_make_symbol (sc, method_name), - wrap_string (sc, type_name, safe_strlen (type_name))); +s7_int s7_list_length(s7_scheme *sc, s7_pointer a) /* returns -len if list is dotted, 0 if it's (directly) circular */ +{ + s7_pointer slow = a, fast = a; + for (s7_int 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); } -s7_pointer -s7i_method_or_bust_pp (s7_scheme* sc, s7_pointer obj, const char* method_name, - s7_pointer x1, s7_pointer x2, const char* type_name, - s7_int arg_pos) { - return method_or_bust_pp ( - sc, obj, s7_make_symbol (sc, method_name), x1, x2, - wrap_string (sc, type_name, safe_strlen (type_name)), (int32_t) arg_pos); -} -void -s7i_division_by_zero_error (s7_scheme* sc, const char* caller, s7_pointer x, - s7_pointer y) { - division_by_zero_error_2_nr ( - sc, wrap_string (sc, caller, safe_strlen (caller)), x, y); +/* -------------------------------- proper-list? -------------------------------- */ +static /* inline */ s7_pointer copy_proper_list(s7_scheme *sc, s7_pointer lst) +{ + s7_pointer tp; + if (!is_pair(lst)) return(sc->nil); + begin_temp(sc->x, lst); + tp = list_1(sc, car(lst)); + begin_temp(sc->temp6, tp); + for (s7_pointer 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; + } + end_temp(sc->temp6); + end_temp(sc->x); + return(tp); } -bool -s7i_is_subvector (s7_pointer p) { - return (is_subvector (p)); +s7_pointer s7i_copy_proper_list(s7_scheme *sc, s7_pointer lst) +{ + return(copy_proper_list(sc, lst)); } -s7_pointer -s7i_int_one (s7_scheme* sc) { - (void) sc; - return (int_one); +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); } -s7_pointer -s7i_iterator_sequence (s7_pointer iter) { - return (iterator_sequence (iter)); -} +#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 +/* g_is_proper_list is now defined in s7_liii_list.c */ -s7_int -s7i_subvector_position (s7_pointer p) { - if (is_subvector (p)) switch (type (p)) { - case T_VECTOR: - return ((s7_int) (vector_elements (p) - - vector_elements (subvector_vector (p)))); - case T_INT_VECTOR: - return ((s7_int) (int_vector_ints (p) - - int_vector_ints (subvector_vector (p)))); - case T_FLOAT_VECTOR: - return ((s7_int) (float_vector_floats (p) - - float_vector_floats (subvector_vector (p)))); - case T_COMPLEX_VECTOR: - return ((s7_int) (complex_vector_complexes (p) - - complex_vector_complexes (subvector_vector (p)))); - case T_BYTE_VECTOR: - return ((s7_int) (byte_vector_bytes (p) - - byte_vector_bytes (subvector_vector (p)))); - } - return (-1); -} - -s7_pointer -s7i_subvector_vector (s7_scheme* sc, s7_pointer p) { - return (subvector_vector (p)); -} -bool -s7i_is_typed_t_vector (s7_pointer p) { - return (is_typed_t_vector (p)); -} -s7_pointer -s7i_typed_vector_typer (s7_scheme* sc, s7_pointer p) { - return (typed_vector_typer (p)); -} - -static s7_pointer -new_format_port (s7_scheme* sc) { - const s7_int len = FORMAT_PORT_LENGTH; - block_t* block= mallocate (sc, len); - block_t* b = mallocate_port (sc); - const s7_pointer port = alloc_pointer (sc); - set_full_type (port, T_OUTPUT_PORT); - port_block (port)= b; - port_port (port) = (port_t*) block_data (b); - port_type (port) = string_port; - port_set_closed (port, false); - port_data_size (port) = len; - port_next (port) = NULL; - port_data (port) = (uint8_t*) (block_data (block)); - port_data_block (port)= block; - port_data (port)[0] = '\0'; - port_position (port) = 0; - port_needs_free (port)= false; - port_port (port)->pf = &output_string_functions; -#if S7_DEBUGGING - sc->format_ports_allocated++; -#endif - return (port); -} +/* is_proper_list_p_p migrated to s7_liii_list.c */ -static inline s7_pointer -open_format_port (s7_scheme* sc) { - s7_pointer port= sc->format_ports; - if (!port) return (new_format_port (sc)); - sc->format_ports = (s7_pointer) (port_next (port)); - port_position (port)= 0; - port_data (port)[0] = '\0'; - return (port); -} +bool is_proper_list_1(s7_scheme *sc, s7_pointer p) {return((is_pair(p)) && (is_null(cdr(p))));} +bool is_proper_list_2(s7_scheme *sc, s7_pointer p) {return((is_pair(p)) && (is_pair(cdr(p))) && (is_null(cddr(p))));} +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 *unused_sc, s7_pointer p) {return(proper_list_length(p) == 4);} -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, - "the second argument to %s (the object): %p, is not an s7 object\n", - __func__, obj); - - strport= open_format_port (sc); - object_out (sc, T_Pos (obj), strport, p_write); - len= port_position (strport); - if ((S7_DEBUGGING) && (len == 0)) - fprintf (stderr, "%s[%d]: len == 0\n", __func__, __LINE__); - /* 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 = inline_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 */ -{ - if ((sc->safety > no_safety) && (!s7_is_valid (sc, obj))) - s7_warn ( - sc, 256, - "the second argument to %s (the object): %p, is not an s7 object\n", - __func__, obj); - { - s7_pointer result; - const s7_pointer strport= open_format_port (sc); - object_out (sc, obj, strport, (use_write) ? p_write : p_display); - if (port_position (strport) >= port_data_size (strport)) - result= block_to_string (sc, - reallocate (sc, port_data_block (strport), - port_position (strport) + 1), - port_position (strport)); - else - result= block_to_string (sc, port_data_block (strport), - port_position (strport)); - restore_format_port (sc, strport); - return (result); - } +/* -------------------------------- make-list -------------------------------- */ +static s7_pointer make_big_list(s7_scheme *sc, s7_int len, s7_pointer init) +{ + check_free_heap_size(sc, len + 1); /* using cons_unchecked below, +1 in case we are on the trigger at the end */ + begin_temp(sc->x, sc->nil); + for (s7_int i = 0; i < len; i++) sc->x = cons_unchecked(sc, init, sc->x); + return_with_end_temp(sc->x); } -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 (*s7* '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; - const s7_pointer obj = car (args); - s7_int pending_max = S7_INT64_MAX; - const bool old_openlets= sc->has_openlets; - - if (is_pair (cdr (args))) { - const s7_pointer arg2= cadr (args); - if (arg2 == sc->F) choice= p_display; - else { - if (arg2 == sc->T) choice= p_write; - else { - if (arg2 == sc->readable_keyword) choice= p_readable; - else { - if (arg2 == sc->display_keyword) choice= p_display; - else { - if (arg2 == sc->write_keyword) choice= p_write; - else - wrong_type_error_nr ( - sc, sc->object_to_string_symbol, 2, arg2, - wrap_string (sc, "a boolean or :readable", 22)); - } - } - } - } - - if (is_pair (cddr (args))) { - const s7_pointer arg3= caddr (args); - if (!s7_is_integer (arg3)) { - if (choice == - p_readable) /* (object->string #r(1 2 3) :readable "hi") */ - wrong_type_error_nr (sc, sc->object_to_string_symbol, 3, arg3, - sc->type_names[T_INTEGER]); - return (method_or_bust (sc, arg3, sc->object_to_string_symbol, args, - sc->type_names[T_INTEGER], 3)); - } - if (s7_integer_clamped_if_gmp (sc, arg3) < 0) - out_of_range_error_nr (sc, sc->object_to_string_symbol, int_three, arg3, - a_non_negative_integer_string); - pending_max= s7_integer_clamped_if_gmp (sc, arg3); - } - } - 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; /* so (object->string obj :readable) ignores obj's - object->string method -- is this a good idea? */ - else - if_method_exists_return_value (sc, obj, sc->object_to_string_symbol, args); - { - s7_int out_len; - const s7_pointer 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)) { - if (choice == p_readable) /* (object->string #r(1 2 3) :readable 4) */ - { - close_format_port (sc, strport); - sc->has_openlets= old_openlets; - out_of_range_error_nr ( - sc, sc->object_to_string_symbol, int_three, - wrap_integer (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 (s7_int i= out_len - 3; i < out_len; i++) - port_data (strport)[i]= (uint8_t) '.'; - } +static inline s7_pointer make_list(s7_scheme *sc, s7_int len, s7_pointer init) +{ + switch (len) { - s7_pointer result; - if (out_len >= - port_data_size (strport)) /* this can happen (but only == I think) */ - result= block_to_string ( - sc, reallocate (sc, port_data_block (strport), out_len + 1), - out_len); - else result= block_to_string (sc, port_data_block (strport), out_len); - restore_format_port (sc, strport); - sc->has_openlets= old_openlets; - return (result); + 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: break; } - } + return(make_big_list(sc, len, init)); } -/* -------------------------------- write -------------------------------- */ +s7_pointer s7_make_list(s7_scheme *sc, s7_int len, s7_pointer init) {return(make_list(sc, len, init));} -static s7_pointer -write_chooser (s7_scheme* sc, s7_pointer func, int32_t args, s7_pointer expr) { - if (args == 2) /* not check_for_substring_temp(sc, expr) here -- write returns - arg so can be immutable if substring_uncopied */ - return ((caddr (expr) == sc->F) ? sc->display_f : sc->write_2); - return (func); +/* make_list_p_pp migrated to s7_liii_list.c */ + +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)); } -/* -------------------------------- display -------------------------------- */ -static s7_pointer -display_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer expr) { - 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 (func); -} - -/* display may not be following the spec: (display '("a" #\b)): ("a" #\b), - * whereas Guile says (a b), in s7 write here == display, Guile write == s7 - * write */ - -/* -------------------------------- 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)) - - const s7_pointer proc= car (args); - if ((!is_any_procedure (proc)) || /* this disallows goto/continuation */ - (!s7_is_aritable (sc, proc, 1))) - return (method_or_bust ( - sc, proc, sc->call_with_output_string_symbol, args, - wrap_string (sc, "a procedure of one argument (the port)", 38), 1)); - { - const s7_pointer 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 - - const s7_pointer file= car (args), proc= cadr (args); - if (!is_string (file)) - return (method_or_bust (sc, file, sc->call_with_output_file_symbol, args, - sc->type_names[T_STRING], 1)); - if ((!is_any_procedure (proc)) || (!s7_is_aritable (sc, proc, 1))) - return (method_or_bust ( - sc, proc, sc->call_with_output_file_symbol, args, - wrap_string (sc, "a procedure of one argument (the port)", 38), 2)); - { - const s7_pointer 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); +/* -------------------------------- list-ref -------------------------------- */ +s7_pointer s7_list_ref(s7_scheme *sc, s7_pointer lst, s7_int num) +{ + s7_pointer p = lst; + for (s7_int i = 0; (i < num) && (is_pair(p)); i++, p = cdr(p)) {} + if (is_pair(p)) return(car(p)); + return(sc->nil); } -/* -------------------------------- 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)) - - const s7_pointer proc= car (args); - if (!is_thunk (sc, proc)) { - if (is_any_procedure (proc)) /* i.e. c_function, lambda, macro, etc */ - { - s7_pointer req_args= - wrap_integer (sc, procedure_required_args (sc, proc)); - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_4 ( - sc, - wrap_string ( - sc, - "~A requires ~D argument~P, but with-output-to-string's " - "first argument should be a thunk", - 87), - proc, req_args, req_args)); - } - else - return (method_or_bust (sc, proc, sc->with_output_to_string_symbol, args, - a_thunk_string, 1)); - } - if ((is_continuation (proc)) || (is_goto (proc))) - wrong_type_error_nr (sc, sc->with_output_to_string_symbol, 1, proc, - a_normal_procedure_string); - { - const s7_pointer 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, proc); - return (sc->F); -} - -/* -------------------------------- 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 - - const s7_pointer file= car (args), proc= cadr (args); - if (!is_string (file)) - return (method_or_bust (sc, file, sc->with_output_to_file_symbol, args, - sc->type_names[T_STRING], 1)); - if (!is_thunk (sc, proc)) { - if (is_any_procedure (proc)) /* i.e. c_function, lambda, macro, etc */ - { - s7_pointer req_args= - wrap_integer (sc, procedure_required_args (sc, proc)); - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_4 ( - sc, - wrap_string ( - sc, - "~A requires ~D argument~P, but with-output-to-file's " - "second argument should be a thunk", - 86), - proc, req_args, req_args)); - } - else - return (method_or_bust (sc, proc, sc->with_output_to_file_symbol, args, - a_thunk_string, 2)); - } - if ((is_continuation (proc)) || (is_goto (proc))) - wrong_type_error_nr (sc, sc->with_output_to_file_symbol, 1, proc, - a_normal_procedure_string); - { - const s7_pointer 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); -} +static s7_pointer list_ref_1(s7_scheme *sc, s7_pointer lst, s7_pointer ind) +{ + s7_int index; + s7_pointer p = lst; -/* -------------------------------- lists -------------------------------- */ -s7_pointer -s7_cons (s7_scheme* sc, s7_pointer a, s7_pointer b) { - s7_pointer p; - new_cell (sc, p, T_PAIR | T_SAFE_PROCEDURE); - set_car (p, a); - set_cdr (p, b); - return (p); + if (!s7_is_integer(ind)) + return(method_or_bust_pp(sc, ind, sc->list_ref_symbol, lst, ind, sc->type_names[T_INTEGER], 2)); + index = s7_integer_clamped_if_gmp(sc, ind); + if ((index < 0) || (index > sc->max_list_length)) /* max-list-length check for circular list-ref? */ + out_of_range_error_nr(sc, sc->list_ref_symbol, int_two, ind, (index < 0) ? it_is_negative_string : it_is_too_large_string); + for (s7_int i = 0; (i < index) && is_pair(p); i++, p = cdr(p)) {} + if (is_pair(p)) return(car(p)); + if (is_null(p)) + out_of_range_error_nr(sc, sc->list_ref_symbol, int_two, ind, it_is_too_large_string); + wrong_type_error_nr(sc, sc->list_ref_symbol, 1, lst, a_proper_list_string); + return(NULL); } -s7_pointer -cons_unchecked (s7_scheme* sc, s7_pointer a, s7_pointer b) { - /* apparently slightly faster as a function? */ - s7_pointer p; - new_cell_unchecked (sc, p, T_PAIR | T_SAFE_PROCEDURE); - set_car (p, a); - set_cdr (p, b); - return (p); -} - -static s7_pointer -semipermanent_cons (s7_scheme* sc, s7_pointer a, s7_pointer b, s7_uint type) { - s7_pointer p= alloc_pointer (sc); - set_full_type (p, type | T_UNHEAP); - set_car (p, a); - set_cdr_unchecked (p, b); - return (p); -} - -static s7_pointer -semipermanent_list (s7_scheme* sc, s7_int len) { - s7_pointer p= sc->nil; - for (s7_int j= 0; j < len; j++) - p= semipermanent_cons (sc, sc->unused, p, T_PAIR | T_IMMUTABLE); - return (p); -} - -s7_pointer -s7_make_signature (s7_scheme* sc, s7_int len, ...) { - va_list ap; - s7_int i; - s7_pointer result= sc->nil; - - for (i= 0; i < len; i++) - result= semipermanent_cons (sc, sc->unused, result, T_PAIR | T_IMMUTABLE); - va_start (ap, len); - i= 0; /* or 1? */ - for (s7_pointer p= result; is_pair (p); p= cdr (p), i++) { - set_car (p, va_arg (ap, s7_pointer)); - if ((!is_normal_symbol (car (p))) && (!is_boolean (car (p))) && - (!is_pair (car (p)))) - s7_warn (sc, 512, - "s7_make_signature got an invalid entry %s at position %" ld64, - display (car (p)), i); - } - va_end (ap); - return (result); -} - -s7_pointer -s7_make_circular_signature (s7_scheme* sc, s7_int cycle_point, s7_int len, - ...) { - va_list ap; - s7_int i; - s7_pointer result= sc->nil, back= NULL, end= NULL; - - for (i= 0; i < len; i++) - result= semipermanent_cons (sc, sc->nil, result, T_PAIR | T_IMMUTABLE); - va_start (ap, len); - i= 0; - for (s7_pointer p= result; is_pair (p); p= cdr (p), i++) { - set_car (p, va_arg (ap, s7_pointer)); - if ((!is_normal_symbol (car (p))) && (!is_boolean (car (p))) && - (!is_pair (car (p)))) - s7_warn (sc, 512, - "s7_make_circular_signature got an invalid entry %s at position " - "%" ld64, - display (car (p)), i); - if (i == cycle_point) back= p; - if (i == (len - 1)) end= p; - } - va_end (ap); - if (end) set_cdr_unchecked (end, back); - if (i < len) - s7_warn (sc, 256, "s7_make_circular_signature got too few entries: %s\n", - display (result)); - return (result); -} +static s7_pointer implicit_index(s7_scheme *sc, s7_pointer obj, s7_pointer indices); -bool -s7_is_pair (s7_pointer p) { - return (is_pair (p)); -} -s7_pointer -is_pair_p_p (s7_scheme* sc, s7_pointer p) { - return ((is_pair (p)) ? sc->T : sc->F); +s7_pointer s7i_ref_index_checked(s7_scheme *sc, s7_pointer caller, s7_pointer in_obj, s7_pointer args) +{ + if (!is_applicable(in_obj)) /* let implicit_index shuffle syntax and closures */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "~$ becomes ~$, but ~S can't take arguments", 42), + set_ulist_1(sc, caller, args), cons(sc, in_obj, cddr(args)), in_obj)); + /* perhaps first $s -> "(~S ~{~$~^ ~})..." and we can pass the symbol rather than the global value as "caller" */ + return(implicit_index(sc, in_obj, cddr(args))); } -s7_pointer -s7_car (s7_pointer p) { - return (car (p)); -} -s7_pointer -s7_cdr (s7_pointer p) { - return (cdr (p)); -} +#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) +/* g_list_ref is now defined in s7_liii_list.c */ -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)); +static bool op_implicit_pair_ref_a(s7_scheme *sc) +{ + s7_pointer lst = lookup_checked(sc, car(sc->code)); + if (!is_pair(lst)) {sc->last_function = lst; return(false);} + sc->value = list_ref_1(sc, lst, fx_call(sc, cdr(sc->code))); + return(true); } -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)); +static s7_pointer fx_implicit_pair_ref_a(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer lst = lookup_checked(sc, car(arg)); + if (!is_pair(lst)) + return(s7_apply_function(sc, lst, list_1(sc, fx_call(sc, cdr(arg))))); + return(list_ref_1(sc, lst, fx_call(sc, cdr(arg)))); } -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)); +static s7_pointer implicit_pair_index_checked(s7_scheme *sc, s7_pointer obj, s7_pointer in_obj, s7_pointer indices) +{ + if (!is_applicable(in_obj)) + { + sc->temp9 = indices; /* ulist_1 below is not GC protected */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "~$ becomes (apply ~$ ...), but ~$ can't take arguments", 54), + set_ulist_1(sc, obj, sc->temp9), in_obj, in_obj)); + } + return(implicit_index(sc, in_obj, cdr(indices))); } -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)); +static bool op_implicit_pair_ref_aa(s7_scheme *sc) +{ + s7_pointer index; + s7_pointer lst = lookup_checked(sc, car(sc->code)); + if (!is_pair(lst)) {sc->last_function = lst; return(false);} + sc->args = fx_call(sc, cddr(sc->code)); + index = fx_call(sc, cdr(sc->code)); + sc->value = implicit_pair_index_checked(sc, lst, list_ref_1(sc, lst, index), set_plist_2(sc, index, sc->args)); + return(true); } -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); +static s7_pointer list_ref_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + 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(func); } -/* -------------------------------------------------------------------------------- - */ -void -s7_list_to_array (s7_scheme* sc, s7_pointer list, s7_pointer* array, - int32_t len) { - int32_t i= 0; - for (s7_pointer p= list; is_pair (p); p= cdr (p), i++) - array[i]= car (p); - for (; i < len; i++) - array[i]= sc->undefined; -} +/* list_ref_p_pi_unchecked, list_ref_p_pi, list_ref_p_pp migrated to s7_liii_list.c */ -/* ---------------- 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= car (p); - if ((!is_pair (cp)) || (is_quote (sc, car (cp)))) sum++; - else { - do { - s7_pointer ccp= car (cp); - if ((!is_pair (ccp)) || (is_quote (sc, car (ccp)))) sum++; - else { - do { - s7_pointer cccp= car (ccp); - if ((!is_pair (cccp)) || (is_quote (sc, car (cccp)))) 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 tree) { - if (is_null (tree)) return (0); - if ((!is_pair (tree)) || (is_quote (sc, car (tree)))) return (1); - return (tree_len_1 (sc, tree)); +/* -------------------------------- list-set! -------------------------------- */ +s7_pointer s7_list_set(s7_scheme *sc, s7_pointer lst, s7_int num, s7_pointer val) +{ + s7_pointer p = lst; + for (s7_int i = 0; (i < num) && (is_pair(p)); i++, p = cdr(p)) {} + if (is_pair(p)) + set_car(p, T_Ext(val)); + return(val); } -static s7_int -tree_leaves_i_7p (s7_scheme* sc, s7_pointer tree) { - if (!is_pair (tree)) { - if (is_null (tree)) return (0); - if (!has_active_methods (sc, tree)) - sole_arg_wrong_type_error_nr (sc, sc->tree_leaves_symbol, tree, - a_list_string); - return (integer (find_and_apply_method (sc, tree, sc->tree_leaves_symbol, - set_mlist_1 (sc, tree)))); - } - if ((sc->safety > no_safety) && (tree_is_cyclic (sc, tree))) - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_2 ( - sc, wrap_string (sc, "tree-leaves: tree is cyclic: ~S", 31), tree)); - return (tree_len (sc, tree)); -} - -static s7_pointer -tree_leaves_p_p (s7_scheme* sc, s7_pointer tree) { - if (is_list (tree)) { - if ((sc->safety > no_safety) && (tree_is_cyclic (sc, tree))) - error_nr (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))); - } - return (method_or_bust_p (sc, tree, sc->tree_leaves_symbol, a_list_string)); -} +/* g_list_set and g_list_set_i are now defined in s7_liii_list.c */ -/* g_tree_leaves is now defined in s7_scheme_predicate.c */ -#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->is_list_symbol) +#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) -/* ---------------- tree-memq ---------------- */ -static inline bool -tree_memq_1 (s7_scheme* sc, s7_pointer sym, - s7_pointer tree) /* sym need not be a symbol */ +/* list_set_index_check_nr, list_set_p_pip_unchecked, list_set_p_pip migrated to s7_liii_list.c */ + +static s7_pointer list_set_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) { - if (is_quote (sc, car (tree))) - 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 (is_quote (sc, car (cp))) { - 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); /* this happens a lot */ - if ((sc->safety > no_safety) && (tree_is_cyclic (sc, tree))) - error_nr ( - 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 bool -tree_memq_b_7pp (s7_scheme* sc, s7_pointer sym, s7_pointer tree) { - if (!is_list (tree)) { - if (!has_active_methods (sc, tree)) - wrong_type_error_nr (sc, sc->tree_memq_symbol, 2, tree, a_list_string); - return (find_and_apply_method (sc, tree, sc->tree_memq_symbol, - set_mlist_2 (sc, sym, tree)) != sc->F); - } - return (s7_tree_memq (sc, sym, tree)); + if ((args == 3) && + (s7_is_integer(caddr(expr))) && + (s7_integer_clamped_if_gmp(sc, caddr(expr)) >= 0) && + (s7_integer_clamped_if_gmp(sc, caddr(expr)) < sc->max_list_length)) + return(sc->list_set_i); + return(func); } -/* g_tree_memq is now defined in s7_scheme_predicate.c */ -#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->is_list_symbol) -static /* inline */ bool -tree_including_quote_memq (s7_scheme* sc, s7_pointer sym, - s7_pointer tree) /* sym need not be a symbol */ -{ - do { - if (sym == car (tree)) return (true); - if (is_pair (car (tree))) { - s7_pointer cp= car (tree); - do { - if (sym == car (cp)) return (true); - if ((is_pair (car (cp))) && - (tree_including_quote_memq (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); -} +/* -------------------------------- list-tail -------------------------------- */ +/* list_tail_p_pp migrated to s7_liii_list.c */ -/* ---------------- 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_small_symbol_set (sc, p)) return (true); - } - else if ((is_unquoted_pair (sc, p)) && (pair_set_memq (sc, p))) - return (true); - tree= cdr (tree); - if (!is_pair (tree)) break; - } - return ((is_symbol (tree)) && (symbol_is_in_small_symbol_set (sc, tree))); -} - -static bool -tree_set_memq_b_7pp (s7_scheme* sc, s7_pointer syms, s7_pointer tree) { - bool non_symbols= false; - if (!is_list (syms)) { - if (!has_active_methods (sc, syms)) - wrong_type_error_nr (sc, sc->tree_set_memq_symbol, 1, syms, - a_list_string); - return (find_and_apply_method (sc, syms, sc->tree_set_memq_symbol, - set_mlist_2 (sc, syms, tree)) != sc->F); - } - if (!is_pair (tree)) { - if (is_null (tree)) return (false); - /* (define (func) (do ((i 0 (+ i 1)) (var #f)) ((= i 1) var) (set! var - * (tree-set-memq (list) (block))))) (func) */ - if (!has_active_methods (sc, tree)) - wrong_type_error_nr (sc, sc->tree_set_memq_symbol, 2, tree, - a_list_string); - return (find_and_apply_method (sc, tree, sc->tree_set_memq_symbol, - set_mlist_2 (sc, syms, tree)) != sc->F); - } - if (is_null (syms)) return (false); - if (sc->safety > no_safety) { - if (tree_is_cyclic (sc, syms)) - error_nr ( - 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)) - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_2 ( - sc, - wrap_string (sc, "tree-set-memq: tree is cyclic: ~S", 33), - tree)); - } - begin_small_symbol_set (sc); - for (s7_pointer p= syms; is_pair (p); p= cdr (p)) - if (is_symbol (car (p))) add_symbol_to_small_symbol_set (sc, car (p)); - else non_symbols= true; - { - bool result= pair_set_memq (sc, tree); - end_small_symbol_set (sc); - if (result) return (true); - } - if (non_symbols) - for (s7_pointer p= syms; is_pair (p); p= cdr (p)) - if ((!is_symbol (car (p))) && (s7_tree_memq (sc, car (p), tree))) - return (true); - return (false); -} +#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 */ +/* g_list_tail is now defined in s7_liii_list.c */ -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))); -} -/* g_tree_set_memq is now defined in s7_scheme_predicate.c */ -#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->is_list_symbol, \ - sc->is_list_symbol) - -static s7_pointer -tree_set_memq_syms_direct (s7_scheme* sc, s7_pointer syms, s7_pointer tree) { - if (!is_pair (tree)) { - if (is_null (tree)) return (sc->F); - if (!has_active_methods (sc, tree)) - wrong_type_error_nr (sc, sc->tree_set_memq_symbol, 2, tree, - a_list_string); - return (find_and_apply_method (sc, tree, sc->tree_set_memq_symbol, - set_mlist_2 (sc, syms, tree))); - } - if (is_quote (sc, car (tree))) return (sc->F); - if ((sc->safety > no_safety) && (tree_is_cyclic (sc, tree))) - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_2 ( - sc, wrap_string (sc, "tree-set-memq: tree is cyclic: ~S", 33), - tree)); - begin_small_symbol_set (sc); - for (s7_pointer p= syms; is_pair (p); p= cdr (p)) - add_symbol_to_small_symbol_set (sc, car (p)); - { - bool result= pair_set_memq (sc, tree); - end_small_symbol_set (sc); - return (make_boolean (sc, result)); - } -} +/* -------------------------------- cons -------------------------------- */ +#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) +/* g_cons is now defined in s7_liii_list.c */ -/* g_tree_set_memq_syms migrated to s7_scheme_predicate.c */ +/* cons_p_pp migrated to s7_liii_list.c */ -/* bridge for g_tree_set_memq_syms migration */ -s7_pointer -s7i_tree_set_memq_syms_direct (s7_scheme* sc, s7_pointer a, s7_pointer b) { - return (tree_set_memq_syms_direct (sc, a, b)); -} -static s7_pointer -tree_set_memq_chooser (s7_scheme* sc, s7_pointer func, int32_t unused_args, - s7_pointer expr) { - if ((is_proper_quote (sc, - cadr (expr))) && /* not (tree-set-memq (quote) ...) */ - (is_pair (cadadr (expr)))) /* (tree-set-memq '(...)...) */ - { - for (s7_pointer p= cadadr (expr); is_pair (p); p= cdr (p)) - if (!is_symbol (car (p))) return (func); - return (sc->tree_set_memq_syms); - } - return (func); -} +/* -------- car -------- */ -/* ---------------- tree-count ---------------- */ -static s7_int -tree_count (s7_scheme* sc, s7_pointer obj, s7_pointer tree, s7_int count) { - if (tree == obj) return (count + 1); - if ((!is_pair (tree)) || (is_quote (sc, car (tree)))) return (count); - return (tree_count (sc, obj, cdr (tree), - tree_count (sc, obj, car (tree), count))); -} - -static inline s7_int -tree_count_at_least (s7_scheme* sc, s7_pointer obj, s7_pointer tree, - s7_int count, s7_int top) { - if (tree == obj) return (count + 1); - if ((!is_pair (tree)) || (is_quote (sc, car (tree)))) return (count); - do { - count= tree_count_at_least (sc, obj, car (tree), count, top); - if (count >= top) return (count); - tree= cdr (tree); - if (tree == obj) return (count + 1); - } while (is_pair (tree)); - 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->is_list_symbol, \ - sc->is_integer_symbol) - const s7_pointer obj= car (args), tree= cadr (args); - s7_pointer count; - - if (!is_pair (tree)) { - if ((is_pair (cddr (args))) && (!s7_is_integer (caddr (args)))) - wrong_type_error_nr (sc, sc->tree_count_symbol, 3, caddr (args), - sc->type_names[T_INTEGER]); - if (is_null (tree)) return (int_zero); - if (!has_active_methods (sc, tree)) - wrong_type_error_nr (sc, sc->tree_count_symbol, 2, tree, a_list_string); - return (find_and_apply_method (sc, tree, sc->tree_count_symbol, - set_mlist_2 (sc, obj, tree))); - } - if ((sc->safety > no_safety) && (tree_is_cyclic (sc, tree))) - error_nr ( - 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)) - wrong_type_error_nr (sc, sc->tree_count_symbol, 3, count, - sc->type_names[T_INTEGER]); - return (make_integer ( - sc, tree_count_at_least (sc, obj, tree, 0, - s7_integer_clamped_if_gmp (sc, count)))); -} +#define H_car "(car pair) returns the first element of the pair" +#define Q_car sc->pl_p +/* g_car is now defined in s7_liii_list.c */ -/* -------------------------------- pair? -------------------------------- */ -#define H_is_pair "(pair? obj) returns #t if obj is a pair (a non-empty list)" -#define Q_is_pair sc->pl_bt -/* g_is_pair is now defined in s7_liii_list.c */ +/* car_p_p migrated to s7_liii_list.c */ -/* -------------------------------- list? -------------------------------- */ -bool -s7_is_list (s7_scheme* sc, s7_pointer p) { - return (is_list (p)); +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, sc->type_names[T_PAIR], 1)); /* 1=arg num if error */ } -static bool -is_list_b (s7_pointer p) { - return ((is_pair (p)) || (type (p) == T_NIL)); +#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) +/* g_set_car is now defined in s7_liii_list.c */ + +static Inline s7_pointer inline_set_car(s7_scheme *sc, s7_pointer lst, s7_pointer value) +{ + if (!is_mutable_pair(lst)) + return(mutable_method_or_bust(sc, lst, sc->set_car_symbol, set_plist_2(sc, lst, value), sc->type_names[T_PAIR], 1)); + set_car(lst, value); + return(value); } -#define H_is_list "(list? obj) returns #t if obj is a pair or null" -#define Q_is_list sc->pl_bt -/* g_is_list is now defined in s7_liii_list.c */ +/* set_car_p_pp migrated to s7_liii_list.c */ -static s7_int -proper_list_length (s7_pointer a) { - s7_int i= 0; - for (s7_pointer 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_pointer slow= a, fast= a; - for (s7_int 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); -} - -/* -------------------------------- proper-list? - * -------------------------------- */ -static /* inline */ s7_pointer -copy_proper_list (s7_scheme* sc, s7_pointer lst) { - s7_pointer tp; - if (!is_pair (lst)) return (sc->nil); - begin_temp (sc->x, lst); - tp= list_1 (sc, car (lst)); - begin_temp (sc->temp6, tp); - for (s7_pointer 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; - } - end_temp (sc->temp6); - end_temp (sc->x); - return (tp); -} - -s7_pointer -s7i_copy_proper_list (s7_scheme* sc, s7_pointer lst) { - return (copy_proper_list (sc, lst)); -} - -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); -} - -#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 -/* g_is_proper_list is now defined in s7_liii_list.c */ - -static s7_pointer -is_proper_list_p_p (s7_scheme* sc, s7_pointer arg) { - return (make_boolean (sc, s7_is_proper_list (sc, arg))); -} - -bool -is_proper_list_1 (s7_scheme* sc, s7_pointer p) { - return ((is_pair (p)) && (is_null (cdr (p)))); -} -bool -is_proper_list_2 (s7_scheme* sc, s7_pointer p) { - return ((is_pair (p)) && (is_pair (cdr (p))) && (is_null (cddr (p)))); -} -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* unused_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) { - check_free_heap_size (sc, len + 1); /* using cons_unchecked below, +1 in case - we are on the trigger at the end */ - begin_temp (sc->x, sc->nil); - for (s7_int i= 0; i < len; i++) - sc->x= cons_unchecked (sc, init, sc->x); - return_with_end_temp (sc->x); -} - -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: - break; - } - return (make_big_list (sc, len, init)); -} - -s7_pointer -s7_make_list (s7_scheme* sc, s7_int len, s7_pointer init) { - return (make_list (sc, len, init)); -} - -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), - sc->type_names[T_INTEGER], 1)); - - len= s7_integer_clamped_if_gmp (sc, n); - if (len == 0) return (sc->nil); /* what about (make-list 0 123)? */ - if (len < 0) - out_of_range_error_nr (sc, sc->make_list_symbol, int_one, n, - it_is_negative_string); - if (len > sc->max_list_length) - error_nr ( - sc, sc->out_of_range_symbol, - set_elist_3 (sc, - wrap_string (sc, - "make-list length argument ~D is greater " - "than (*s7* 'max-list-length), ~D", - 72), - wrap_integer (sc, len), - wrap_integer (sc, sc->max_list_length))); - 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_pointer p= lst; - for (s7_int i= 0; (i < num) && (is_pair (p)); i++, p= cdr (p)) { - } - if (is_pair (p)) return (car (p)); - return (sc->nil); -} - -static s7_pointer -list_ref_1 (s7_scheme* sc, s7_pointer lst, s7_pointer ind) { - s7_int index; - s7_pointer p= lst; - - if (!s7_is_integer (ind)) - return (method_or_bust_pp (sc, ind, sc->list_ref_symbol, lst, ind, - sc->type_names[T_INTEGER], 2)); - index= s7_integer_clamped_if_gmp (sc, ind); - if ((index < 0) || - (index > - sc->max_list_length)) /* max-list-length check for circular list-ref? */ - out_of_range_error_nr (sc, sc->list_ref_symbol, int_two, ind, - (index < 0) ? it_is_negative_string - : it_is_too_large_string); - for (s7_int i= 0; (i < index) && is_pair (p); i++, p= cdr (p)) { - } - if (is_pair (p)) return (car (p)); - if (is_null (p)) - out_of_range_error_nr (sc, sc->list_ref_symbol, int_two, ind, - it_is_too_large_string); - wrong_type_error_nr (sc, sc->list_ref_symbol, 1, lst, a_proper_list_string); - return (NULL); -} - -static s7_pointer implicit_index (s7_scheme* sc, s7_pointer obj, - s7_pointer indices); - -s7_pointer -s7i_ref_index_checked (s7_scheme* sc, s7_pointer caller, s7_pointer in_obj, - s7_pointer args) { - if (!is_applicable ( - in_obj)) /* let implicit_index shuffle syntax and closures */ - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_4 ( - sc, - wrap_string (sc, "~$ becomes ~$, but ~S can't take arguments", 42), - set_ulist_1 (sc, caller, args), cons (sc, in_obj, cddr (args)), - in_obj)); - /* perhaps first $s -> "(~S ~{~$~^ ~})..." and we can pass the symbol rather - * than the global value as "caller" */ - return (implicit_index (sc, in_obj, cddr (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) -/* g_list_ref is now defined in s7_liii_list.c */ - -static bool -op_implicit_pair_ref_a (s7_scheme* sc) { - s7_pointer lst= lookup_checked (sc, car (sc->code)); - if (!is_pair (lst)) { - sc->last_function= lst; - return (false); - } - sc->value= list_ref_1 (sc, lst, fx_call (sc, cdr (sc->code))); - return (true); -} - -static s7_pointer -fx_implicit_pair_ref_a (s7_scheme* sc, s7_pointer arg) { - s7_pointer lst= lookup_checked (sc, car (arg)); - if (!is_pair (lst)) - return (s7_apply_function (sc, lst, list_1 (sc, fx_call (sc, cdr (arg))))); - return (list_ref_1 (sc, lst, fx_call (sc, cdr (arg)))); -} - -static s7_pointer -implicit_pair_index_checked (s7_scheme* sc, s7_pointer obj, s7_pointer in_obj, - s7_pointer indices) { - if (!is_applicable (in_obj)) { - sc->temp9= indices; /* ulist_1 below is not GC protected */ - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_4 ( - sc, - wrap_string ( - sc, "~$ becomes (apply ~$ ...), but ~$ can't take arguments", - 54), - set_ulist_1 (sc, obj, sc->temp9), in_obj, in_obj)); - } - return (implicit_index (sc, in_obj, cdr (indices))); -} - -static bool -op_implicit_pair_ref_aa (s7_scheme* sc) { - s7_pointer index; - s7_pointer lst= lookup_checked (sc, car (sc->code)); - if (!is_pair (lst)) { - sc->last_function= lst; - return (false); - } - sc->args = fx_call (sc, cddr (sc->code)); - index = fx_call (sc, cdr (sc->code)); - sc->value= implicit_pair_index_checked (sc, lst, list_ref_1 (sc, lst, index), - set_plist_2 (sc, index, sc->args)); - return (true); -} - -static s7_pointer -list_ref_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer expr) { - 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 (func); -} - -static inline s7_pointer -list_ref_p_pi_unchecked (s7_scheme* sc, s7_pointer lst, s7_int index) { - s7_pointer p= lst; - if (index < 0) - out_of_range_error_nr (sc, sc->list_ref_symbol, int_two, - wrap_integer (sc, index), it_is_negative_string); - if (index > sc->max_list_length) - error_nr ( - sc, sc->out_of_range_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, - "list-ref index ~D is too large, (*s7* 'max-list-length) is ~D", - 61), - wrap_integer (sc, index), wrap_integer (sc, sc->max_list_length))); - for (s7_int i= 0; ((is_pair (p)) && (i < index)); i++, p= cdr (p)) - ; - if (!is_pair (p)) { - if (is_null (p)) - out_of_range_error_nr (sc, sc->list_ref_symbol, int_two, - wrap_integer (sc, index), it_is_too_large_string); - wrong_type_error_nr (sc, sc->list_ref_symbol, 1, lst, a_proper_list_string); - } - return (car (p)); -} - -static s7_pointer -list_ref_p_pi (s7_scheme* sc, s7_pointer lst, s7_int index) { - if (!is_pair (lst)) - wrong_type_error_nr (sc, sc->list_ref_symbol, 1, lst, - sc->type_names[T_PAIR]); - return (list_ref_p_pi_unchecked (sc, lst, index)); -} - -static s7_pointer -list_ref_p_pp (s7_scheme* sc, s7_pointer lst, s7_pointer index) { - if (!is_pair (lst)) return (g_list_ref (sc, set_plist_2 (sc, lst, index))); - if (!s7_is_integer (index)) - wrong_type_error_nr (sc, sc->list_ref_symbol, 1, index, - sc->type_names[T_INTEGER]); - return ( - list_ref_p_pi_unchecked (sc, lst, s7_integer_clamped_if_gmp (sc, index))); -} - -/* -------------------------------- list-set! -------------------------------- - */ -s7_pointer -s7_list_set (s7_scheme* sc, s7_pointer lst, s7_int num, s7_pointer val) { - s7_pointer p= lst; - for (s7_int i= 0; (i < num) && (is_pair (p)); i++, p= cdr (p)) { - } - if (is_pair (p)) set_car (p, T_Ext (val)); - return (val); -} - -/* g_list_set and g_list_set_i are now defined in s7_liii_list.c */ - -#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) - -static no_return void -list_set_index_check_nr (s7_scheme* sc, s7_int index) { - if (index < 0) - out_of_range_error_nr (sc, sc->list_set_symbol, int_two, - wrap_integer (sc, index), it_is_negative_string); - error_nr ( - sc, sc->out_of_range_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, - "list-set! index ~D is too large, (*s7* 'max-list-length) is ~D", - 62), - wrap_integer (sc, index), wrap_integer (sc, sc->max_list_length))); -} - -static inline s7_pointer -list_set_p_pip_unchecked (s7_scheme* sc, s7_pointer lst, s7_int index, - s7_pointer value) { - s7_pointer p= lst; - if ((index < 0) || (index > sc->max_list_length)) - list_set_index_check_nr (sc, index); - for (s7_int i= 0; ((is_pair (p)) && (i < index)); i++, p= cdr (p)) - ; - if (!is_pair (p)) { - if (is_null (p)) - out_of_range_error_nr (sc, sc->list_set_symbol, int_two, - wrap_integer (sc, index), it_is_too_large_string); - wrong_type_error_nr (sc, sc->list_set_symbol, 1, lst, a_proper_list_string); - } - set_car (p, value); - return (value); -} - -static s7_pointer -list_set_p_pip (s7_scheme* sc, s7_pointer lst, s7_int index, - s7_pointer value) /* called in t101-12|14... */ -{ - if (!is_pair (lst)) - wrong_type_error_nr (sc, sc->list_set_symbol, 1, lst, - sc->type_names[T_PAIR]); - return (list_set_p_pip_unchecked (sc, lst, index, value)); -} - -static s7_pointer -list_set_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer expr) { - if ((args == 3) && (s7_is_integer (caddr (expr))) && - (s7_integer_clamped_if_gmp (sc, caddr (expr)) >= 0) && - (s7_integer_clamped_if_gmp (sc, caddr (expr)) < sc->max_list_length)) - return (sc->list_set_i); - return (func); -} - -/* -------------------------------- list-tail -------------------------------- - */ -static s7_pointer -list_tail_p_pp (s7_scheme* sc, s7_pointer lst, s7_pointer ind) { - s7_int i, index; - if (!s7_is_integer (ind)) - return (method_or_bust_pp (sc, ind, sc->list_tail_symbol, lst, ind, - sc->type_names[T_INTEGER], 2)); - index= s7_integer_clamped_if_gmp (sc, ind); - - if (!is_list (lst)) /* (list-tail () 0) -> () */ - return (method_or_bust_pp (sc, lst, sc->list_tail_symbol, lst, ind, - a_list_string, 1)); - if (index < 0) - out_of_range_error_nr (sc, sc->list_tail_symbol, int_two, - wrap_integer (sc, index), it_is_negative_string); - if (index > sc->max_list_length) - error_nr (sc, sc->out_of_range_symbol, - set_elist_3 (sc, - wrap_string (sc, - "list-tail index ~D is too large, " - "(*s7* 'max-list-length) is ~D", - 62), - wrap_integer (sc, index), - wrap_integer (sc, sc->max_list_length))); - - for (i= 0; (i < index) && (is_pair (lst)); i++, lst= cdr (lst)) { - } - if (i < index) - out_of_range_error_nr (sc, sc->list_tail_symbol, int_two, - wrap_integer (sc, index), it_is_too_large_string); - return (lst); -} - -#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 */ -/* g_list_tail is now defined in s7_liii_list.c */ - -/* -------------------------------- cons -------------------------------- */ -#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) -/* g_cons is now defined in s7_liii_list.c */ - -static s7_pointer -cons_p_pp (s7_scheme* sc, s7_pointer p1, s7_pointer p2) { - s7_pointer p; - new_cell (sc, p, T_PAIR | T_SAFE_PROCEDURE); - set_car (p, p1); - set_cdr (p, p2); - return (p); -} - -/* -------- car -------- */ - -#define H_car "(car pair) returns the first element of the pair" -#define Q_car sc->pl_p -/* g_car is now defined in s7_liii_list.c */ - -static s7_pointer -car_p_p (s7_scheme* sc, s7_pointer lst) { - if (is_pair (lst)) return (car (lst)); - return (sole_arg_method_or_bust ( - sc, lst, sc->car_symbol, set_plist_1 (sc, lst), sc->type_names[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, - sc->type_names[T_PAIR], 1)); /* 1=arg num if error */ -} - -#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) -/* g_set_car is now defined in s7_liii_list.c */ - -static Inline s7_pointer -inline_set_car (s7_scheme* sc, s7_pointer lst, s7_pointer value) { - if (!is_mutable_pair (lst)) - return (mutable_method_or_bust (sc, lst, sc->set_car_symbol, - set_plist_2 (sc, lst, value), - sc->type_names[T_PAIR], 1)); - set_car (lst, value); - return (value); -} - -static s7_pointer -set_car_p_pp (s7_scheme* sc, s7_pointer lst, s7_pointer value) { - return (inline_set_car (sc, lst, value)); -} /* -------- cdr -------- */ #define H_cdr "(cdr pair) returns the second element of the pair" #define Q_cdr sc->pl_p /* g_cdr is now defined in s7_liii_list.c */ -static s7_pointer -cdr_p_p (s7_scheme* sc, s7_pointer lst) { - if (is_pair (lst)) return (cdr (lst)); - return (sole_arg_method_or_bust ( - sc, lst, sc->cdr_symbol, set_plist_1 (sc, lst), sc->type_names[T_PAIR])); -} +/* cdr_p_p migrated to s7_liii_list.c */ #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) +#define Q_set_cdr s7_make_signature(sc, 3, sc->T, sc->is_pair_symbol, sc->T) /* g_set_cdr is now defined in s7_liii_list.c */ -static Inline s7_pointer -inline_set_cdr (s7_scheme* sc, s7_pointer lst, s7_pointer value) { - if (!is_mutable_pair (lst)) - return (mutable_method_or_bust (sc, lst, sc->set_cdr_symbol, - set_plist_2 (sc, lst, value), - sc->type_names[T_PAIR], 1)); - set_cdr (lst, value); - return (value); +static Inline s7_pointer inline_set_cdr(s7_scheme *sc, s7_pointer lst, s7_pointer value) +{ + if (!is_mutable_pair(lst)) + return(mutable_method_or_bust(sc, lst, sc->set_cdr_symbol, set_plist_2(sc, lst, value), sc->type_names[T_PAIR], 1)); + set_cdr(lst, value); + return(value); } -static s7_pointer -set_cdr_p_pp (s7_scheme* sc, s7_pointer lst, s7_pointer value) { - return (inline_set_cdr (sc, lst, value)); -} +/* set_cdr_p_pp migrated to s7_liii_list.c */ + /* -------- caar --------*/ #define H_caar "(caar lst) returns (car (car lst)): (caar '((1 2))) -> 1" #define Q_caar sc->pl_p /* g_caar is now defined in s7_liii_list.c */ -static s7_pointer -caar_p_p (s7_scheme* sc, s7_pointer lst) { - if ((is_pair (lst)) && (is_pair (car (lst)))) return (caar (lst)); - if (is_pair (lst)) - sole_arg_wrong_type_error_nr (sc, sc->caar_symbol, lst, car_a_list_string); - return (sole_arg_method_or_bust ( - sc, lst, sc->caar_symbol, set_plist_1 (sc, lst), sc->type_names[T_PAIR])); -} +/* caar_p_p is now defined in s7_scheme_cxr.c */ + /* -------- cadr --------*/ #define H_cadr "(cadr lst) returns (car (cdr lst)): (cadr '(1 2 3)) -> 2" #define Q_cadr sc->pl_p /* g_cadr is now defined in s7_liii_list.c */ -static s7_pointer -cadr_p_p (s7_scheme* sc, s7_pointer lst) { - if ((is_pair (lst)) && (is_pair (cdr (lst)))) return (cadr (lst)); - if (is_pair (lst)) - sole_arg_wrong_type_error_nr (sc, sc->cadr_symbol, lst, cdr_a_list_string); - return (sole_arg_method_or_bust ( - sc, lst, sc->cadr_symbol, set_plist_1 (sc, lst), sc->type_names[T_PAIR])); -} +/* cadr_p_p is now defined in s7_scheme_cxr.c */ -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, - sc->type_names[T_PAIR], 1)); - if (!is_pair (cdr (lst))) - out_of_range_error_nr (sc, sc->list_ref_symbol, int_two, cadr (args), - it_is_too_large_string); - return (cadr (lst)); +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, sc->type_names[T_PAIR], 1)); + if (!is_pair(cdr(lst))) out_of_range_error_nr(sc, sc->list_ref_symbol, int_two, cadr(args), it_is_too_large_string); + return(cadr(lst)); } + /* -------- cdar -------- */ #define H_cdar "(cdar lst) returns (cdr (car lst)): (cdar '((1 2 3))) -> '(2 3)" #define Q_cdar sc->pl_p /* g_cdar is now defined in s7_liii_list.c */ -static s7_pointer -cdar_p_p (s7_scheme* sc, s7_pointer lst) { - if ((is_pair (lst)) && (is_pair (car (lst)))) return (cdar (lst)); - if (!is_pair (lst)) - sole_arg_wrong_type_error_nr (sc, sc->cdar_symbol, lst, car_a_list_string); - return (sole_arg_method_or_bust ( - sc, lst, sc->cdar_symbol, set_plist_1 (sc, lst), sc->type_names[T_PAIR])); -} +/* cdar_p_p is now defined in s7_scheme_cxr.c */ + /* -------- cddr -------- */ #define H_cddr "(cddr lst) returns (cdr (cdr lst)): (cddr '(1 2 3 4)) -> '(3 4)" #define Q_cddr sc->pl_p /* g_cddr is now defined in s7_liii_list.c */ -static s7_pointer -cddr_p_p (s7_scheme* sc, s7_pointer lst) { - if ((is_pair (lst)) && (is_pair (cdr (lst)))) return (cddr (lst)); - if (is_pair (lst)) - sole_arg_wrong_type_error_nr (sc, sc->cddr_symbol, lst, cdr_a_list_string); - return (sole_arg_method_or_bust ( - sc, lst, sc->cddr_symbol, set_plist_1 (sc, lst), sc->type_names[T_PAIR])); -} +/* cddr_p_p is now defined in s7_scheme_cxr.c */ /* -------- caaar -------- */ -static s7_pointer -caaar_p_p (s7_scheme* sc, s7_pointer lst) { - if (!is_pair (lst)) - return (sole_arg_method_or_bust (sc, lst, sc->caaar_symbol, - set_plist_1 (sc, lst), - sc->type_names[T_PAIR])); - if (!is_pair (car (lst))) - sole_arg_wrong_type_error_nr (sc, sc->caaar_symbol, lst, car_a_list_string); - if (!is_pair (caar (lst))) - sole_arg_wrong_type_error_nr (sc, sc->caaar_symbol, lst, - caar_a_list_string); - if (!is_pair (caar (lst))) - sole_arg_wrong_type_error_nr (sc, sc->caaar_symbol, lst, - caar_a_list_string); - return (caaar (lst)); -} - -#define H_caaar \ - "(caaar lst) returns (car (car (car lst))): (caaar '(((1 2)))) -> 1" +/* caaar_p_p is now defined in s7_scheme_cxr.c */ + +#define H_caaar "(caaar lst) returns (car (car (car lst))): (caaar '(((1 2)))) -> 1" #define Q_caaar sc->pl_p /* g_caaar is now defined in s7_liii_list.c */ /* -------- caadr -------- */ -static s7_pointer -caadr_p_p (s7_scheme* sc, s7_pointer lst) { - if ((is_pair (lst)) && (is_pair (cdr (lst))) && (is_pair (cadr (lst)))) - return (caadr (lst)); - if (!is_pair (lst)) - return (sole_arg_method_or_bust (sc, lst, sc->caadr_symbol, - set_plist_1 (sc, lst), - sc->type_names[T_PAIR])); - if (!is_pair (cdr (lst))) - sole_arg_wrong_type_error_nr (sc, sc->caadr_symbol, lst, cdr_a_list_string); - sole_arg_wrong_type_error_nr (sc, sc->caadr_symbol, lst, cadr_a_list_string); - return (NULL); -} - -#define H_caadr \ - "(caadr lst) returns (car (car (cdr lst))): (caadr '(1 (2 3))) -> 2" +/* caadr_p_p is now defined in s7_scheme_cxr.c */ + +#define H_caadr "(caadr lst) returns (car (car (cdr lst))): (caadr '(1 (2 3))) -> 2" #define Q_caadr sc->pl_p /* g_caadr is now defined in s7_liii_list.c */ /* -------- cadar -------- */ -#define H_cadar \ - "(cadar lst) returns (car (cdr (car lst))): (cadar '((1 2 3))) -> 2" +#define H_cadar "(cadar lst) returns (car (cdr (car lst))): (cadar '((1 2 3))) -> 2" #define Q_cadar sc->pl_p /* g_cadar is now defined in s7_liii_list.c */ -static s7_pointer -cadar_p_p (s7_scheme* sc, s7_pointer lst) { - if ((is_pair (lst)) && (is_pair (car (lst))) && (is_pair (cdar (lst)))) - return (cadar (lst)); - if (!is_pair (lst)) - return (sole_arg_method_or_bust (sc, lst, sc->cadar_symbol, - set_plist_1 (sc, lst), - sc->type_names[T_PAIR])); - if (!is_pair (car (lst))) - sole_arg_wrong_type_error_nr (sc, sc->cadar_symbol, lst, car_a_list_string); - sole_arg_wrong_type_error_nr (sc, sc->cadar_symbol, lst, cdar_a_list_string); - return (NULL); -} +/* cadar_p_p is now defined in s7_scheme_cxr.c */ /* -------- cdaar -------- */ -static s7_pointer -cdaar_p_p (s7_scheme* sc, s7_pointer lst) { - if (!is_pair (lst)) - return (sole_arg_method_or_bust (sc, lst, sc->cdaar_symbol, - set_plist_1 (sc, lst), - sc->type_names[T_PAIR])); - if (!is_pair (car (lst))) - sole_arg_wrong_type_error_nr (sc, sc->cdaar_symbol, lst, car_a_list_string); - if (!is_pair (caar (lst))) - sole_arg_wrong_type_error_nr (sc, sc->cdaar_symbol, lst, - caar_a_list_string); - return (cdaar (lst)); -} - -#define H_cdaar \ - "(cdaar lst) returns (cdr (car (car lst))): (cdaar '(((1 2 3)))) -> '(2 3)" +/* cdaar_p_p is now defined in s7_scheme_cxr.c */ + +#define H_cdaar "(cdaar lst) returns (cdr (car (car lst))): (cdaar '(((1 2 3)))) -> '(2 3)" #define Q_cdaar sc->pl_p /* g_cdaar is now defined in s7_liii_list.c */ /* -------- caddr -------- */ -#define H_caddr \ - "(caddr lst) returns (car (cdr (cdr lst))): (caddr '(1 2 3 4)) -> 3" +#define H_caddr "(caddr lst) returns (car (cdr (cdr lst))): (caddr '(1 2 3 4)) -> 3" #define Q_caddr sc->pl_p /* g_caddr is now defined in s7_liii_list.c */ -static s7_pointer -caddr_p_p (s7_scheme* sc, s7_pointer lst) { - if ((is_pair (lst)) && (is_pair (cdr (lst))) && (is_pair (cddr (lst)))) - return (caddr (lst)); - if (!is_pair (lst)) - return (sole_arg_method_or_bust (sc, lst, sc->caddr_symbol, - set_plist_1 (sc, lst), - sc->type_names[T_PAIR])); - if (!is_pair (cdr (lst))) - sole_arg_wrong_type_error_nr (sc, sc->caddr_symbol, lst, cdr_a_list_string); - sole_arg_wrong_type_error_nr (sc, sc->caddr_symbol, lst, cddr_a_list_string); - return (NULL); -} - -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, - sc->type_names[T_PAIR], 1)); - if ((!is_pair (cdr (lst))) || (!is_pair (cddr (lst)))) - out_of_range_error_nr (sc, sc->list_ref_symbol, int_two, cadr (args), - it_is_too_large_string); - return (caddr (lst)); +/* caddr_p_p is now defined in s7_scheme_cxr.c */ + +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, sc->type_names[T_PAIR], 1)); + if ((!is_pair(cdr(lst))) || (!is_pair(cddr(lst)))) + out_of_range_error_nr(sc, sc->list_ref_symbol, int_two, cadr(args), it_is_too_large_string); + return(caddr(lst)); } /* -------- cdddr -------- */ -static s7_pointer -cdddr_p_p (s7_scheme* sc, s7_pointer lst) { - if (!is_pair (lst)) - return (sole_arg_method_or_bust (sc, lst, sc->cdddr_symbol, - set_plist_1 (sc, lst), - sc->type_names[T_PAIR])); - if (!is_pair (cdr (lst))) - sole_arg_wrong_type_error_nr (sc, sc->cdddr_symbol, lst, cdr_a_list_string); - if (!is_pair (cddr (lst))) - sole_arg_wrong_type_error_nr (sc, sc->cdddr_symbol, lst, - cddr_a_list_string); - return (cdddr (lst)); -} - -#define H_cdddr \ - "(cdddr lst) returns (cdr (cdr (cdr lst))): (cdddr '(1 2 3 4)) -> '(4)" +/* cdddr_p_p is now defined in s7_scheme_cxr.c */ + +#define H_cdddr "(cdddr lst) returns (cdr (cdr (cdr lst))): (cdddr '(1 2 3 4)) -> '(4)" #define Q_cdddr sc->pl_p /* g_cdddr is now defined in s7_liii_list.c */ /* -------- cdadr -------- */ -static s7_pointer -cdadr_p_p (s7_scheme* sc, s7_pointer lst) { - if (!is_pair (lst)) - return (sole_arg_method_or_bust (sc, lst, sc->cdadr_symbol, - set_plist_1 (sc, lst), - sc->type_names[T_PAIR])); - if (!is_pair (cdr (lst))) - sole_arg_wrong_type_error_nr (sc, sc->cdadr_symbol, lst, cdr_a_list_string); - if (!is_pair (cadr (lst))) - sole_arg_wrong_type_error_nr (sc, sc->cdadr_symbol, lst, - cadr_a_list_string); - return (cdadr (lst)); -} - -#define H_cdadr \ - "(cdadr lst) returns (cdr (car (cdr lst))): (cdadr '(1 (2 3 4))) -> '(3 4)" +/* cdadr_p_p is now defined in s7_scheme_cxr.c */ + +#define H_cdadr "(cdadr lst) returns (cdr (car (cdr lst))): (cdadr '(1 (2 3 4))) -> '(3 4)" #define Q_cdadr sc->pl_p /* g_cdadr is now defined in s7_liii_list.c */ /* -------- cddar -------- */ -static s7_pointer -cddar_p_p (s7_scheme* sc, s7_pointer lst) { - if (!is_pair (lst)) - return (sole_arg_method_or_bust (sc, lst, sc->cddar_symbol, - set_plist_1 (sc, lst), - sc->type_names[T_PAIR])); - if (!is_pair (car (lst))) - sole_arg_wrong_type_error_nr (sc, sc->cddar_symbol, lst, car_a_list_string); - if (!is_pair (cdar (lst))) - sole_arg_wrong_type_error_nr (sc, sc->cddar_symbol, lst, - cdar_a_list_string); - return (cddar (lst)); -} - -#define H_cddar \ - "(cddar lst) returns (cdr (cdr (car lst))): (cddar '((1 2 3 4))) -> '(3 4)" +/* cddar_p_p is now defined in s7_scheme_cxr.c */ + +#define H_cddar "(cddar lst) returns (cdr (cdr (car lst))): (cddar '((1 2 3 4))) -> '(3 4)" #define Q_cddar sc->pl_p /* g_cddar is now defined in s7_liii_list.c */ /* -------- caaaar -------- */ -#define H_caaaar \ - "(caaaar lst) returns (car (car (car (car lst)))): (caaaar '((((1 2))))) " \ - "-> 1" +#define H_caaaar "(caaaar lst) returns (car (car (car (car lst)))): (caaaar '((((1 2))))) -> 1" #define Q_caaaar sc->pl_p /* g_caaaar is now defined in s7_liii_list.c */ /* -------- caaadr -------- */ -#define H_caaadr \ - "(caaadr lst) returns (car (car (car (cdr lst)))): (caaadr '(1 ((2 3)))) " \ - "-> 2" +#define H_caaadr "(caaadr lst) returns (car (car (car (cdr lst)))): (caaadr '(1 ((2 3)))) -> 2" #define Q_caaadr sc->pl_p /* g_caaadr is now defined in s7_liii_list.c */ /* -------- caadar -------- */ -#define H_caadar \ - "(caadar lst) returns (car (car (cdr (car lst)))): (caadar '((1 (2 3)))) " \ - "-> 2" +#define H_caadar "(caadar lst) returns (car (car (cdr (car lst)))): (caadar '((1 (2 3)))) -> 2" #define Q_caadar sc->pl_p /* g_caadar is now defined in s7_liii_list.c */ /* -------- cadaar -------- */ -#define H_cadaar \ - "(cadaar lst) returns (car (cdr (car (car lst)))): (cadaar '(((1 2 3)))) " \ - "-> 2" +#define H_cadaar "(cadaar lst) returns (car (cdr (car (car lst)))): (cadaar '(((1 2 3)))) -> 2" #define Q_cadaar sc->pl_p /* g_cadaar is now defined in s7_liii_list.c */ /* -------- caaddr -------- */ -static s7_pointer -caaddr_p_p (s7_scheme* sc, s7_pointer lst) { - if (!is_pair (lst)) - return (sole_arg_method_or_bust (sc, lst, sc->caaddr_symbol, - set_plist_1 (sc, lst), - sc->type_names[T_PAIR])); - if (!is_pair (cdr (lst))) - sole_arg_wrong_type_error_nr (sc, sc->caaddr_symbol, lst, - cdr_a_list_string); - if (!is_pair (cddr (lst))) - sole_arg_wrong_type_error_nr (sc, sc->caaddr_symbol, lst, - cddr_a_list_string); - if (!is_pair (caddr (lst))) - sole_arg_wrong_type_error_nr (sc, sc->caaddr_symbol, lst, - caddr_a_list_string); - return (caaddr (lst)); -} - -#define H_caaddr \ - "(caaddr lst) returns (car (car (cdr (cdr lst)))): (caaddr '(1 2 (3 4))) " \ - "-> 3" +/* caaddr_p_p is now defined in s7_scheme_cxr.c */ + +#define H_caaddr "(caaddr lst) returns (car (car (cdr (cdr lst)))): (caaddr '(1 2 (3 4))) -> 3" #define Q_caaddr sc->pl_p /* g_caaddr is now defined in s7_liii_list.c */ /* -------- cadddr -------- */ -static s7_pointer -cadddr_p_p (s7_scheme* sc, s7_pointer lst) { - if (!is_pair (lst)) - return (sole_arg_method_or_bust (sc, lst, sc->cadddr_symbol, - set_plist_1 (sc, lst), - sc->type_names[T_PAIR])); - if (!is_pair (cdr (lst))) - sole_arg_wrong_type_error_nr (sc, sc->cadddr_symbol, lst, - cdr_a_list_string); - if (!is_pair (cddr (lst))) - sole_arg_wrong_type_error_nr (sc, sc->cadddr_symbol, lst, - cddr_a_list_string); - if (!is_pair (cdddr (lst))) - sole_arg_wrong_type_error_nr (sc, sc->cadddr_symbol, lst, - cdddr_a_list_string); - return (cadddr (lst)); -} - -#define H_cadddr \ - "(cadddr lst) returns (car (cdr (cdr (cdr lst)))): (cadddr '(1 2 3 4 5)) " \ - "-> 4" +/* cadddr_p_p is now defined in s7_scheme_cxr.c */ + +#define H_cadddr "(cadddr lst) returns (car (cdr (cdr (cdr lst)))): (cadddr '(1 2 3 4 5)) -> 4" #define Q_cadddr sc->pl_p /* g_cadddr is now defined in s7_liii_list.c */ /* -------- cadadr -------- */ -static s7_pointer -cadadr_p_p (s7_scheme* sc, s7_pointer lst) { - if (!is_pair (lst)) - return (sole_arg_method_or_bust (sc, lst, sc->cadadr_symbol, - set_plist_1 (sc, lst), - sc->type_names[T_PAIR])); - if (!is_pair (cdr (lst))) - sole_arg_wrong_type_error_nr (sc, sc->cadadr_symbol, lst, - cdr_a_list_string); - if (!is_pair (cadr (lst))) - sole_arg_wrong_type_error_nr (sc, sc->cadadr_symbol, lst, - cadr_a_list_string); - if (!is_pair (cdadr (lst))) - sole_arg_wrong_type_error_nr (sc, sc->cadadr_symbol, lst, - cdadr_a_list_string); - return (cadadr (lst)); -} - -#define H_cadadr \ - "(cadadr lst) returns (car (cdr (car (cdr lst)))): (cadadr '(1 (2 3 4))) " \ - "-> 3" +/* cadadr_p_p is now defined in s7_scheme_cxr.c */ + +#define H_cadadr "(cadadr lst) returns (car (cdr (car (cdr lst)))): (cadadr '(1 (2 3 4))) -> 3" #define Q_cadadr sc->pl_p /* g_cadadr is now defined in s7_liii_list.c */ /* -------- caddar -------- */ -static s7_pointer -caddar_p_p (s7_scheme* sc, s7_pointer lst) { - if (!is_pair (lst)) - return (sole_arg_method_or_bust (sc, lst, sc->caddar_symbol, - set_plist_1 (sc, lst), - sc->type_names[T_PAIR])); - if (!is_pair (car (lst))) - sole_arg_wrong_type_error_nr (sc, sc->caddar_symbol, lst, - car_a_list_string); - if (!is_pair (cdar (lst))) - sole_arg_wrong_type_error_nr (sc, sc->caddar_symbol, lst, - cdar_a_list_string); - if (!is_pair (cddar (lst))) - sole_arg_wrong_type_error_nr (sc, sc->caddar_symbol, lst, - cddar_a_list_string); - return (caddar (lst)); -} - -#define H_caddar \ - "(caddar lst) returns (car (cdr (cdr (car lst)))): (caddar '((1 2 3 4))) " \ - "-> 3" +/* caddar_p_p is now defined in s7_scheme_cxr.c */ + +#define H_caddar "(caddar lst) returns (car (cdr (cdr (car lst)))): (caddar '((1 2 3 4))) -> 3" #define Q_caddar sc->pl_p /* g_caddar is now defined in s7_liii_list.c */ /* -------- cdaaar -------- */ -#define H_cdaaar \ - "(cdaaar lst) returns (cdr (car (car (car lst)))): (cdaaar '((((1 2 3))))) " \ - "-> '(2 3)" +#define H_cdaaar "(cdaaar lst) returns (cdr (car (car (car lst)))): (cdaaar '((((1 2 3))))) -> '(2 3)" #define Q_cdaaar sc->pl_p /* g_cdaaar is now defined in s7_liii_list.c */ /* -------- cdaadr -------- */ -#define H_cdaadr \ - "(cdaadr lst) returns (cdr (car (car (cdr lst)))): (cdaadr '(1 ((2 3 4)))) " \ - "-> '(3 4)" +#define H_cdaadr "(cdaadr lst) returns (cdr (car (car (cdr lst)))): (cdaadr '(1 ((2 3 4)))) -> '(3 4)" #define Q_cdaadr sc->pl_p /* g_cdaadr is now defined in s7_liii_list.c */ /* -------- cdadar -------- */ -#define H_cdadar \ - "(cdadar lst) returns (cdr (car (cdr (car lst)))): (cdadar '((1 (2 3 4)))) " \ - "-> '(3 4)" +#define H_cdadar "(cdadar lst) returns (cdr (car (cdr (car lst)))): (cdadar '((1 (2 3 4)))) -> '(3 4)" #define Q_cdadar sc->pl_p /* g_cdadar is now defined in s7_liii_list.c */ /* -------- cddaar -------- */ -#define H_cddaar \ - "(cddaar lst) returns (cdr (cdr (car (car lst)))): (cddaar '(((1 2 3 4)))) " \ - "-> '(3 4)" +#define H_cddaar "(cddaar lst) returns (cdr (cdr (car (car lst)))): (cddaar '(((1 2 3 4)))) -> '(3 4)" #define Q_cddaar sc->pl_p /* g_cddaar is now defined in s7_liii_list.c */ /* -------- cdaddr -------- */ -#define H_cdaddr \ - "(cdaddr lst) returns (cdr (car (cdr (cdr lst)))): (cdaddr '(1 2 (3 4 5))) " \ - "-> '(4 5)" +#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 /* g_cdaddr is now defined in s7_liii_list.c */ /* -------- cddddr -------- */ -static s7_pointer -cddddr_p_p (s7_scheme* sc, s7_pointer lst) { - if (!is_pair (lst)) - return (sole_arg_method_or_bust (sc, lst, sc->cddddr_symbol, - set_plist_1 (sc, lst), - sc->type_names[T_PAIR])); - if (!is_pair (cdr (lst))) - sole_arg_wrong_type_error_nr (sc, sc->cddddr_symbol, lst, - cdr_a_list_string); - if (!is_pair (cddr (lst))) - sole_arg_wrong_type_error_nr (sc, sc->cddddr_symbol, lst, - cddr_a_list_string); - if (!is_pair (cdddr (lst))) - sole_arg_wrong_type_error_nr (sc, sc->cddddr_symbol, lst, - cdddr_a_list_string); - return (cddddr (lst)); -} - -#define H_cddddr \ - "(cddddr lst) returns (cdr (cdr (cdr (cdr lst)))): (cddddr '(1 2 3 4 5)) " \ - "-> '(5)" +/* cddddr_p_p is now defined in s7_scheme_cxr.c */ + +#define H_cddddr "(cddddr lst) returns (cdr (cdr (cdr (cdr lst)))): (cddddr '(1 2 3 4 5)) -> '(5)" #define Q_cddddr sc->pl_p /* g_cddddr is now defined in s7_liii_list.c */ /* -------- cddadr -------- */ -static s7_pointer -cddadr_p_p (s7_scheme* sc, s7_pointer lst) { - if (!is_pair (lst)) - return (sole_arg_method_or_bust (sc, lst, sc->cddadr_symbol, - set_plist_1 (sc, lst), - sc->type_names[T_PAIR])); - if (!is_pair (cdr (lst))) - sole_arg_wrong_type_error_nr (sc, sc->cddadr_symbol, lst, - cdr_a_list_string); - if (!is_pair (cadr (lst))) - sole_arg_wrong_type_error_nr (sc, sc->cddadr_symbol, lst, - cadr_a_list_string); - if (!is_pair (cdadr (lst))) - sole_arg_wrong_type_error_nr (sc, sc->cddadr_symbol, lst, - cdadr_a_list_string); - return (cddadr (lst)); -} - -#define H_cddadr \ - "(cddadr lst) returns (cdr (cdr (car (cdr lst)))): (cddadr '(1 (2 3 4 5))) " \ - "-> '(4 5)" +/* cddadr_p_p is now defined in s7_scheme_cxr.c */ + +#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 /* g_cddadr is now defined in s7_liii_list.c */ /* -------- cdddar -------- */ -static s7_pointer -cdddar_p_p (s7_scheme* sc, s7_pointer lst) { - if (!is_pair (lst)) - return (sole_arg_method_or_bust (sc, lst, sc->cdddar_symbol, - set_plist_1 (sc, lst), - sc->type_names[T_PAIR])); - if (!is_pair (car (lst))) - sole_arg_wrong_type_error_nr (sc, sc->cdddar_symbol, lst, - car_a_list_string); - if (!is_pair (cdar (lst))) - sole_arg_wrong_type_error_nr (sc, sc->cdddar_symbol, lst, - cdar_a_list_string); - if (!is_pair (cddar (lst))) - sole_arg_wrong_type_error_nr (sc, sc->cdddar_symbol, lst, - cddar_a_list_string); - return (cdddar (lst)); -} - -#define H_cdddar \ - "(cdddar lst) returns (cdr (cdr (cdr (car lst)))): (cdddar '((1 2 3 4 5))) " \ - "-> '(4 5)" +/* cdddar_p_p is now defined in s7_scheme_cxr.c */ + +#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 /* g_cdddar is now defined in s7_liii_list.c */ -/* -------------------------------- assoc assv assq - * -------------------------------- */ -s7_pointer -s7_assq (s7_scheme* sc, s7_pointer obj, s7_pointer lst) { - s7_pointer slow= lst; - 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 == car_unchecked (car (lst))) && - (is_pair (car (lst)))) return (car (lst)); - lst= cdr (lst); if (!is_pair (lst)) return (sc->F)); - slow= cdr (slow); - if (lst == slow) return (sc->F); - } - return (sc->F); /* not reached */ -} -static s7_pointer -assq_p_pp (s7_scheme* sc, s7_pointer obj, s7_pointer lst) { - return ((is_pair (lst)) - ? s7_assq (sc, obj, lst) - : ((is_null (lst)) - ? sc->F - : method_or_bust_pp (sc, lst, sc->assq_symbol, obj, lst, - an_association_list_string, 2))); +/* -------------------------------- assoc assv assq -------------------------------- */ +s7_pointer s7_assq(s7_scheme *sc, s7_pointer obj, s7_pointer lst) +{ + s7_pointer slow = lst; + 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 == car_unchecked(car(lst))) && (is_pair(car(lst)))) return(car(lst)); lst = cdr(lst); if (!is_pair(lst)) return(sc->F)); + slow = cdr(slow); + if (lst == slow) return(sc->F); + } + return(sc->F); /* not reached */ } +/* assq_p_pp migrated to s7_liii_list.c */ + /* g_assq migrated to s7_scheme_predicate.c */ -#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) +#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) /* bridge for g_assq migration */ -s7_pointer -s7i_assq_p_pp (s7_scheme* sc, s7_pointer a, s7_pointer b) { - return (assq_p_pp (sc, a, b)); +s7_pointer s7i_assq_p_pp(s7_scheme *sc, s7_pointer a, s7_pointer b) +{ + return(assq_p_pp(sc, a, b)); } -static s7_pointer -assv_p_pp (s7_scheme* sc, s7_pointer obj, s7_pointer lst) { - s7_pointer slow; - if (!is_pair (lst)) { - if (is_null (lst)) return (sc->F); - if (sc->scheme_version == sc->s7_symbol) - return (method_or_bust_pp (sc, lst, sc->assv_symbol, obj, lst, - an_association_list_string, 2)); - return (methods_or_bust_pp (sc, lst, sc->assv_symbol, sc->assq_symbol, obj, - lst, an_association_list_string, 2)); - } - if (is_simple (obj)) return (s7_assq (sc, obj, lst)); - - slow= lst; - 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 (lst))) && (s7_is_eqv (sc, obj, caar (lst)))) - return (car (lst)); - lst= cdr (lst); - if (!is_pair (lst)) return (sc->F); - - if ((is_pair (car (lst))) && (s7_is_eqv (sc, obj, caar (lst)))) - return (car (lst)); - lst= cdr (lst); - if (!is_pair (lst)) return (sc->F); - - slow= cdr (slow); - if (slow == lst) return (sc->F); - } - return (sc->F); /* not reached */ -} +/* assv_p_pp migrated to s7_liii_list.c */ /* g_assv migrated to s7_scheme_predicate.c */ -#define H_assv \ - "(assv obj alist) returns the key-value pair associated (via eqv?) with " \ - "the key obj in the association list alist" +#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 /* bridge for g_assv migration */ -s7_pointer -s7i_assv_p_pp (s7_scheme* sc, s7_pointer a, s7_pointer b) { - return (assv_p_pp (sc, a, b)); +s7_pointer s7i_assv_p_pp(s7_scheme *sc, s7_pointer a, s7_pointer b) +{ + return(assv_p_pp(sc, a, b)); } -s7_pointer -s7_assoc (s7_scheme* sc, s7_pointer obj, s7_pointer lst) { +s7_pointer s7_assoc(s7_scheme *sc, s7_pointer obj, s7_pointer lst) +{ s7_pointer slow; - if (!is_pair (lst)) return (sc->F); - slow= lst; - while (true) { - if ((is_pair (car (lst))) && (s7_is_equal (sc, obj, caar (lst)))) - return (car (lst)); - lst= cdr (lst); - if (!is_pair (lst)) return (sc->F); - - if ((is_pair (car (lst))) && (s7_is_equal (sc, obj, caar (lst)))) - return (car (lst)); - lst= cdr (lst); - if (!is_pair (lst)) return (sc->F); - - slow= cdr (slow); - if (lst == slow) return (sc->F); - } - return (sc->F); -} - -static s7_pointer -assoc_1 (s7_scheme* sc, s7_pointer obj, s7_pointer lst) { - s7_pointer slow= lst; - if (is_string (obj)) { - while (true) { - if (is_pair (car (lst))) { - s7_pointer val= caar (lst); - if ((val == obj) || - ((is_string (val)) && (scheme_strings_are_equal (obj, val)))) - return (car (lst)); - } - lst= cdr (lst); - if (!is_pair (lst)) return (sc->F); - - if (is_pair (car (lst))) { - s7_pointer val= caar (lst); - if ((val == obj) || - ((is_string (val)) && (scheme_strings_are_equal (obj, val)))) - return (car (lst)); - } - lst= cdr (lst); - if (!is_pair (lst)) return (sc->F); - slow= cdr (slow); - if (lst == slow) return (sc->F); + if (!is_pair(lst)) + return(sc->F); + slow = lst; + while (true) + { + if ((is_pair(car(lst))) && (s7_is_equal(sc, obj, caar(lst)))) return(car(lst)); + lst = cdr(lst); + if (!is_pair(lst)) return(sc->F); + + if ((is_pair(car(lst))) && (s7_is_equal(sc, obj, caar(lst)))) return(car(lst)); + lst = cdr(lst); + if (!is_pair(lst)) return(sc->F); + + slow = cdr(slow); + if (lst == slow) return(sc->F); } - return (sc->F); - } - while (true) { - if ((is_pair (car (lst))) && (s7_is_equal (sc, obj, caar (lst)))) - return (car (lst)); - lst= cdr (lst); - if (!is_pair (lst)) return (sc->F); - - if ((is_pair (car (lst))) && (s7_is_equal (sc, obj, caar (lst)))) - return (car (lst)); - lst= cdr (lst); - if (!is_pair (lst)) return (sc->F); - slow= cdr (slow); - if (lst == slow) return (sc->F); - } - return (sc->F); /* not reached */ + return(sc->F); +} + +static s7_pointer assoc_1(s7_scheme *sc, s7_pointer obj, s7_pointer lst) +{ + s7_pointer slow = lst; + if (is_string(obj)) + { + while (true) + { + if (is_pair(car(lst))) + { + s7_pointer val = caar(lst); + if ((val == obj) || + ((is_string(val)) && + (scheme_strings_are_equal(obj, val)))) + return(car(lst)); + } + lst = cdr(lst); + if (!is_pair(lst)) return(sc->F); + + if (is_pair(car(lst))) + { + s7_pointer val = caar(lst); + if ((val == obj) || + ((is_string(val)) && + (scheme_strings_are_equal(obj, val)))) + return(car(lst)); + } + lst = cdr(lst); + if (!is_pair(lst)) return(sc->F); + slow = cdr(slow); + if (lst == slow) return(sc->F); + } + return(sc->F); + } + while (true) + { + if ((is_pair(car(lst))) && (s7_is_equal(sc, obj, caar(lst)))) return(car(lst)); + lst = cdr(lst); + if (!is_pair(lst)) return(sc->F); + + if ((is_pair(car(lst))) && (s7_is_equal(sc, obj, caar(lst)))) return(car(lst)); + lst = cdr(lst); + if (!is_pair(lst)) return(sc->F); + slow = cdr(slow); + if (lst == slow) return(sc->F); + } + return(sc->F); /* not reached */ } -static bool -closure_has_two_normal_args (s7_scheme* sc, - s7_pointer eq_func) /* sc for is_null */ +static bool closure_has_two_normal_args(s7_scheme *sc, s7_pointer eq_func) /* sc for is_null */ { - return ((is_closure (eq_func)) && (is_pair (closure_pars (eq_func))) && - (is_pair (cdr (closure_pars (eq_func)))) && /* not dotted arg list */ - (is_null (cddr (closure_pars (eq_func))))); /* arity == 2 */ + return((is_closure(eq_func)) && + (is_pair(closure_pars(eq_func))) && + (is_pair(cdr(closure_pars(eq_func)))) && /* not dotted arg list */ + (is_null(cddr(closure_pars(eq_func))))); /* arity == 2 */ } /* g_is_eq and g_is_eqv migrated to s7_scheme_predicate.c */ -static s7_pfunc s7_bool_optimize (s7_scheme* sc, s7_pointer expr); +static s7_pfunc s7_bool_optimize(s7_scheme *sc, s7_pointer expr); /* a naming experiment, "q_" to match signature "Q_" */ #define q_call(o) o->v[0] -static s7_pointer -g_assoc (s7_scheme* sc, s7_pointer args) { -#define H_assoc \ - "(assoc obj alist func) returns the key-value pair associated (via equal?) with the key obj in the association list alist.\ +static s7_pointer g_assoc(s7_scheme *sc, s7_pointer args) +{ + #define H_assoc "(assoc obj alist func) 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 lst= cadr (args); - if (!is_null (lst)) { - if (!is_pair (lst)) - return (method_or_bust (sc, lst, sc->assoc_symbol, args, - an_association_list_string, 2)); - if (!is_pair (car (lst))) - wrong_type_error_nr ( - sc, sc->assoc_symbol, 2, lst, - an_association_list_string); /* we're assuming caar below so it better - exist */ - } - if (is_pair (cddr (args))) { - const s7_pointer eq_func= caddr (args); - /* here we know lst 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_safe_c_function (eq_func)) { - const s7_function func= c_function_call (eq_func); - if (func == g_is_eq) - return (is_null (lst) ? sc->F : s7_assq (sc, car (args), lst)); - if (func == g_is_eqv) return (assv_p_pp (sc, car (args), lst)); - if (!s7_is_aritable (sc, eq_func, 2)) - wrong_type_error_nr (sc, sc->assoc_symbol, 3, eq_func, - an_eq_func_string); - set_car (sc->t2_1, car (args)); - for (s7_pointer slow= lst; is_pair (lst); - lst= cdr (lst), slow= cdr (slow)) { - if (!is_pair (car (lst))) - wrong_type_error_nr (sc, sc->assoc_symbol, 2, cadr (args), - an_association_list_string); /* not p */ - set_car (sc->t2_2, caar (lst)); - if (is_true (sc, func (sc, sc->t2_1))) return (car (lst)); - lst= cdr (lst); - if ((!is_pair (lst)) || (lst == slow)) return (sc->F); - if (!is_pair (car (lst))) - wrong_type_error_nr (sc, sc->assoc_symbol, 2, cadr (args), - an_association_list_string); - set_car (sc->t2_2, caar (lst)); - if (is_true (sc, func (sc, sc->t2_1))) return (car (lst)); - } - return (sc->F); - } - if (closure_has_two_normal_args (sc, eq_func)) { - const s7_pointer body= closure_body (eq_func); - if (is_null (lst)) return (sc->F); - if (is_null (cdr (body))) { - s7_pfunc func; - set_curlet (sc, make_let_with_two_slots ( - sc, sc->curlet, car (closure_pars (eq_func)), - car (args), cadr (closure_pars (eq_func)), sc->F)); - func= s7_bool_optimize (sc, body); - if (func) { - s7_pointer slowp= lst; - opt_info* o = sc->opts[0]; - s7_pointer slot = next_slot (let_slots (sc->curlet)); - while (true) { - if (!is_pair (car (lst))) - wrong_type_error_nr (sc, sc->assoc_symbol, 2, cadr (args), - an_association_list_string); - slot_set_value (slot, caar (lst)); - if (q_call (o).fb (o)) return (car (lst)); - lst= cdr (lst); - if (!is_pair (lst)) return (sc->F); - if (!is_pair (car (lst))) - wrong_type_error_nr (sc, sc->assoc_symbol, 2, cadr (args), - an_association_list_string); - slot_set_value (slot, caar (lst)); - if (q_call (o).fb (o)) return (car (lst)); - lst= cdr (lst); - if (!is_pair (lst)) return (sc->F); - slowp= cdr (slowp); - if (lst == slowp) return (sc->F); - } - return (sc->F); - } - } + #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 lst = cadr(args); + if (!is_null(lst)) + { + if (!is_pair(lst)) + return(method_or_bust(sc, lst, sc->assoc_symbol, args, an_association_list_string, 2)); + if (!is_pair(car(lst))) + wrong_type_error_nr(sc, sc->assoc_symbol, 2, lst, an_association_list_string); /* we're assuming caar below so it better exist */ } + if (is_pair(cddr(args))) + { + const s7_pointer eq_func = caddr(args); + /* here we know lst is a pair, but need to protect against circular lists */ + /* I wonder if the assoc equality function should get the cons, not just caar? */ - /* 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_ppp (sc, eq_func, sc->assoc_symbol, car (args), - lst, eq_func, a_procedure_string, 3)); - if (!s7_is_aritable (sc, eq_func, 2)) - wrong_type_error_nr (sc, sc->assoc_symbol, 3, eq_func, an_eq_func_string); - if (is_null (lst)) return (sc->F); - if ((is_any_macro (eq_func)) && (!is_c_macro (eq_func))) - clear_all_optimizations (sc, closure_body (eq_func)); - { - s7_pointer func_args= list_1 (sc, copy_proper_list (sc, args)); - set_opt1_fast (func_args, lst); - set_opt2_slow (func_args, lst); - push_stack (sc, OP_ASSOC_IF, list_1_unchecked (sc, func_args), eq_func); - } - if (needs_copied_args (eq_func)) - push_stack (sc, OP_APPLY, list_2_unchecked (sc, car (args), caar (lst)), - eq_func); - else { - set_car (sc->t2_1, car (args)); - set_car (sc->t2_2, caar (lst)); - push_stack (sc, OP_APPLY, sc->t2_1, eq_func); - } - return (sc->unspecified); - } - if (is_null (lst)) return (sc->F); + if (is_safe_c_function(eq_func)) + { + const s7_function func = c_function_call(eq_func); + if (func == g_is_eq) return(is_null(lst) ? sc->F : s7_assq(sc, car(args), lst)); + if (func == g_is_eqv) return(assv_p_pp(sc, car(args), lst)); + if (!s7_is_aritable(sc, eq_func, 2)) + wrong_type_error_nr(sc, sc->assoc_symbol, 3, eq_func, an_eq_func_string); + set_car(sc->t2_1, car(args)); + for (s7_pointer slow = lst; is_pair(lst); lst = cdr(lst), slow = cdr(slow)) + { + if (!is_pair(car(lst))) wrong_type_error_nr(sc, sc->assoc_symbol, 2, cadr(args), an_association_list_string); /* not p */ + set_car(sc->t2_2, caar(lst)); + if (is_true(sc, func(sc, sc->t2_1))) return(car(lst)); + lst = cdr(lst); + if ((!is_pair(lst)) || (lst == slow)) return(sc->F); + if (!is_pair(car(lst))) wrong_type_error_nr(sc, sc->assoc_symbol, 2, cadr(args), an_association_list_string); + set_car(sc->t2_2, caar(lst)); + if (is_true(sc, func(sc, sc->t2_1))) return(car(lst)); + } + return(sc->F); + } + if (closure_has_two_normal_args(sc, eq_func)) + { + const s7_pointer body = closure_body(eq_func); + if (is_null(lst)) return(sc->F); + if (is_null(cdr(body))) + { + s7_pfunc func; + set_curlet(sc, make_let_with_two_slots(sc, sc->curlet, car(closure_pars(eq_func)), car(args), cadr(closure_pars(eq_func)), sc->F)); + func = s7_bool_optimize(sc, body); + if (func) + { + s7_pointer slowp = lst; + opt_info *o = sc->opts[0]; + s7_pointer slot = next_slot(let_slots(sc->curlet)); + while (true) + { + if (!is_pair(car(lst))) wrong_type_error_nr(sc, sc->assoc_symbol, 2, cadr(args), an_association_list_string); + slot_set_value(slot, caar(lst)); + if (q_call(o).fb(o)) return(car(lst)); + lst = cdr(lst); + if (!is_pair(lst)) return(sc->F); + if (!is_pair(car(lst))) wrong_type_error_nr(sc, sc->assoc_symbol, 2, cadr(args), an_association_list_string); + slot_set_value(slot, caar(lst)); + if (q_call(o).fb(o)) return(car(lst)); + lst = cdr(lst); + if (!is_pair(lst)) return(sc->F); + slowp = cdr(slowp); + if (lst == slowp) 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_ppp(sc, eq_func, sc->assoc_symbol, car(args), lst, eq_func, a_procedure_string, 3)); + if (!s7_is_aritable(sc, eq_func, 2)) + wrong_type_error_nr(sc, sc->assoc_symbol, 3, eq_func, an_eq_func_string); + if (is_null(lst)) return(sc->F); + if ((is_any_macro(eq_func)) && (!is_c_macro(eq_func))) + clear_all_optimizations(sc, closure_body(eq_func)); + { + s7_pointer func_args = list_1(sc, copy_proper_list(sc, args)); + set_opt1_fast(func_args, lst); + set_opt2_slow(func_args, lst); + push_stack(sc, OP_ASSOC_IF, list_1_unchecked(sc, func_args), eq_func); + } + if (needs_copied_args(eq_func)) + push_stack(sc, OP_APPLY, list_2_unchecked(sc, car(args), caar(lst)), eq_func); + else + { + set_car(sc->t2_1, car(args)); + set_car(sc->t2_2, caar(lst)); + push_stack(sc, OP_APPLY, sc->t2_1, eq_func); + } + return(sc->unspecified); + } + if (is_null(lst)) return(sc->F); { - s7_pointer obj= car (args); - if (is_simple (obj)) return (s7_assq (sc, obj, lst)); - return (assoc_1 (sc, obj, lst)); + s7_pointer obj = car(args); + if (is_simple(obj)) + return(s7_assq(sc, obj, lst)); + return(assoc_1(sc, obj, lst)); } } -static s7_pointer -assoc_p_pp (s7_scheme* sc, s7_pointer obj, s7_pointer p) { - if (!is_pair (p)) { - if (is_null (p)) return (sc->F); - return (method_or_bust (sc, p, sc->assoc_symbol, set_plist_2 (sc, obj, p), - an_association_list_string, 2)); - } - if (!is_pair (car (p))) - wrong_type_error_nr (sc, sc->assoc_symbol, 2, p, - an_association_list_string); - if (is_simple (obj)) return (s7_assq (sc, obj, p)); - return (assoc_1 (sc, obj, p)); -} - -static bool -op_assoc_if (s7_scheme* sc) { - const 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)) =) +/* assoc_p_pp migrated to s7_liii_list.c */ + +static bool op_assoc_if(s7_scheme *sc) +{ + const 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 */ - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_2 ( - sc, - wrap_string (sc, "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 (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 */ + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "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); + 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 func, int32_t args, s7_pointer expr) { - 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 (func); +static s7_pointer assoc_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + 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(func); } + /* ---------------- member, memv, memq ---------------- */ -s7_pointer -s7_memq (s7_scheme* sc, s7_pointer obj, s7_pointer lst) { - s7_pointer slow= lst; - while (true) { - LOOP_4 (if (obj == car (lst)) return (lst); lst= cdr (lst); - if (!is_pair (lst)) return (sc->F)); - slow= cdr (slow); - if (lst == slow) return (sc->F); - } - return (sc->F); -} - -static s7_pointer -memq_p_pp (s7_scheme* sc, s7_pointer obj, s7_pointer lst) { - return ((is_pair (lst)) - ? s7_memq (sc, obj, lst) - : ((is_null (lst)) - ? sc->F - : method_or_bust_pp (sc, lst, sc->memq_symbol, obj, lst, - 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 - - const s7_pointer obj= car (args), lst= cadr (args); - if (is_pair (lst)) return (s7_memq (sc, obj, lst)); - if (is_null (lst)) return (sc->F); - return ( - method_or_bust_pp (sc, lst, sc->memq_symbol, obj, lst, 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 -memq_2_p_pp (s7_scheme* sc, s7_pointer obj, s7_pointer lst) { - if (obj == car (lst)) return (lst); - return ((obj == cadr (lst)) ? cdr (lst) : sc->F); -} - -s7_pointer -s7i_memq_2_p_pp (s7_scheme* sc, s7_pointer obj, s7_pointer lst) { - return (memq_2_p_pp (sc, obj, lst)); -} - -static s7_pointer -memq_3_p_pp (s7_scheme* sc, s7_pointer obj, s7_pointer lst) { - if (obj == car (lst)) return (lst); - if (obj == cadr (lst)) return (cdr (lst)); - return ((obj == caddr (lst)) ? cddr (lst) : sc->F); -} - -static s7_pointer -g_memq_3 (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= cadr (args); - const s7_pointer obj= car (args); - while (true) { - if (obj == car (lst)) - return ( - lst); /* grandma gcc doesn't want me to include the next line here. */ - lst= cdr (lst); - if (obj == car (lst)) return (lst); - lst= cdr (lst); - if (obj == car (lst)) return (lst); - lst= cdr (lst); - if (!is_pair (lst)) return (sc->F); - } - return (sc->F); +s7_pointer s7_memq(s7_scheme *sc, s7_pointer obj, s7_pointer lst) +{ + s7_pointer slow = lst; + while (true) + { + LOOP_4(if (obj == car(lst)) return(lst); lst = cdr(lst); if (!is_pair(lst)) return(sc->F)); + slow = cdr(slow); + if (lst == slow) return(sc->F); + } + return(sc->F); } -static s7_pointer -memq_4_p_pp (s7_scheme* sc, s7_pointer obj, s7_pointer lst) { - while (true) { - LOOP_4 (if (obj == car (lst)) return (lst); lst= cdr (lst)); - if (!is_pair (lst)) return (sc->F); - } - return (sc->F); -} +/* memq_p_pp migrated to s7_liii_list.c */ -s7_pointer -s7i_memq_4_p_pp (s7_scheme* sc, s7_pointer obj, s7_pointer lst) { - return (memq_4_p_pp (sc, obj, lst)); +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 + + const s7_pointer obj = car(args), lst = cadr(args); + if (is_pair(lst)) + return(s7_memq(sc, obj, lst)); + if (is_null(lst)) + return(sc->F); + return(method_or_bust_pp(sc, lst, sc->memq_symbol, obj, lst, a_list_string, 2)); } -static s7_pointer -g_memq_any (s7_scheme* sc, s7_pointer args) { - /* no circular list check needed in this case */ - const s7_pointer obj= car (args); - s7_pointer lst= cadr (args); - while (true) { - LOOP_4 (if (obj == car (lst)) return (lst); lst= cdr (lst); - if (!is_pair (lst)) return (sc->F)); - } - return (sc->F); -} - -static s7_pointer -memq_chooser (s7_scheme* sc, s7_pointer func, int32_t unused_args, - s7_pointer expr) { - s7_pointer lst= caddr (expr); - if ((is_proper_quote (sc, lst)) && (is_pair (cadr (lst)))) { - s7_int 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); +/* 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 */ + +/* memq_2_p_pp migrated to s7_liii_list.c */ + +s7_pointer s7i_memq_2_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst) {return(memq_2_p_pp(sc, obj, lst));} + +/* memq_3_p_pp migrated to s7_liii_list.c */ + +static s7_pointer g_memq_3(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = cadr(args); + const s7_pointer obj = car(args); + while (true) + { + if (obj == car(lst)) return(lst); /* grandma gcc doesn't want me to include the next line here. */ + lst = cdr(lst); + if (obj == car(lst)) return(lst); + lst = cdr(lst); + if (obj == car(lst)) return(lst); + lst = cdr(lst); + if (!is_pair(lst)) return(sc->F); } - } - return (func); -} - -static bool -numbers_are_eqv (s7_scheme* sc, s7_pointer x, s7_pointer y) { - /* if (type(x) != type(y)) return(false); */ /* (eqv? 1 1.0) -> #f! but assume - that we've checked types - already */ - /* switch is apparently as expensive as 3-4 if's! so this only loses if every - * call involves complex numbers? */ - if (is_t_integer (x)) return (integer (x) == integer (y)); - if (is_t_real (x)) - return (real (x) == - real (y)); /* NaNs are not equal to anything including themselves */ - if (is_t_ratio (x)) - return ((numerator (x) == numerator (y)) && - (denominator (x) == denominator (y))); - if (!is_t_complex (x)) return (false); - return ((real_part (x) == real_part (y)) && (imag_part (x) == imag_part (y))); -} - -static s7_pointer -memv_number (s7_scheme* sc, s7_pointer obj, s7_pointer lst) { - s7_pointer slow = lst; - uint8_t obj_type= type (obj); - while (true) { - LOOP_4 (if ((type (car (lst)) == obj_type) && - (numbers_are_eqv (sc, obj, car (lst)))) return (lst); - lst= cdr (lst); if (!is_pair (lst)) return (sc->F)); - slow= cdr (slow); - if (lst == slow) return (sc->F); - } - return (sc->F); + return(sc->F); } -static s7_pointer -memv_p_pp (s7_scheme* sc, s7_pointer obj, s7_pointer lst) { - s7_pointer p; - if (!is_pair (lst)) { - if (is_null (lst)) return (sc->F); - if (sc->scheme_version == sc->s7_symbol) - return (method_or_bust_pp (sc, lst, sc->memv_symbol, obj, lst, - a_list_string, 2)); - return (methods_or_bust_pp (sc, lst, sc->memv_symbol, sc->memq_symbol, obj, - lst, a_list_string, 2)); - } - if (is_simple (obj)) return (s7_memq (sc, obj, lst)); - if (is_number (obj)) return (memv_number (sc, obj, lst)); +/* memq_4_p_pp migrated to s7_liii_list.c */ - p= lst; - while (true) { - if (s7_is_eqv (sc, obj, car (lst))) return (lst); - lst= cdr (lst); - if (!is_pair (lst)) return (sc->F); +s7_pointer s7i_memq_4_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst) {return(memq_4_p_pp(sc, obj, lst));} - if (s7_is_eqv (sc, obj, car (lst))) return (lst); - lst= cdr (lst); - if (!is_pair (lst)) return (sc->F); +static s7_pointer g_memq_any(s7_scheme *sc, s7_pointer args) +{ + /* no circular list check needed in this case */ + const s7_pointer obj = car(args); + s7_pointer lst = cadr(args); + while (true) {LOOP_4(if (obj == car(lst)) return(lst); lst = cdr(lst); if (!is_pair(lst)) return(sc->F));} + return(sc->F); +} - p= cdr (p); - if (p == lst) return (sc->F); - } - return (sc->F); /* not reached */ +static s7_pointer memq_chooser(s7_scheme *sc, s7_pointer func, int32_t unused_args, s7_pointer expr) +{ + s7_pointer lst = caddr(expr); + if ((is_proper_quote(sc, lst)) && + (is_pair(cadr(lst)))) + { + s7_int 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(func); } -/* g_memv migrated to s7_scheme_predicate.c */ -#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 +static bool numbers_are_eqv(s7_scheme *sc, s7_pointer x, s7_pointer y) +{ + /* if (type(x) != type(y)) return(false); */ /* (eqv? 1 1.0) -> #f! but assume that we've checked types already */ + /* switch is apparently as expensive as 3-4 if's! so this only loses if every call involves complex numbers? */ + if (is_t_integer(x)) return(integer(x) == integer(y)); + if (is_t_real(x)) return(real(x) == real(y)); /* NaNs are not equal to anything including themselves */ + if (is_t_ratio(x)) return((numerator(x) == numerator(y)) && (denominator(x) == denominator(y))); + if (!is_t_complex(x)) return(false); + return((real_part(x) == real_part(y)) && (imag_part(x) == imag_part(y))); +} -/* bridge for g_memv migration */ -s7_pointer -s7i_memv_p_pp (s7_scheme* sc, s7_pointer a, s7_pointer b) { - return (memv_p_pp (sc, a, b)); -} - -s7_pointer -s7_member (s7_scheme* sc, s7_pointer obj, s7_pointer lst) { - for (s7_pointer p= lst; is_pair (p); p= cdr (p)) - if (s7_is_equal (sc, obj, car (p))) return (p); - return (sc->F); -} - -static s7_pointer -member (s7_scheme* sc, s7_pointer obj, s7_pointer lst) { - s7_pointer slow= lst; - if (is_string (obj)) - while (true) { - if ((obj == car (lst)) || ((is_string (car (lst))) && - (scheme_strings_are_equal (obj, car (lst))))) - return (lst); - lst= cdr (lst); - if (!is_pair (lst)) return (sc->F); - - if ((obj == car (lst)) || ((is_string (car (lst))) && - (scheme_strings_are_equal (obj, car (lst))))) - return (lst); - lst= cdr (lst); - if (!is_pair (lst)) return (sc->F); - slow= cdr (slow); - if (lst == slow) return (sc->F); - } - else - while (true) { - LOOP_4 (if (s7_is_equal (sc, obj, car (lst))) return (lst); - lst= cdr (lst); if (!is_pair (lst)) return (sc->F)); - slow= cdr (slow); - if (lst == slow) return (sc->F); +static s7_pointer memv_number(s7_scheme *sc, s7_pointer obj, s7_pointer lst) +{ + s7_pointer slow = lst; + uint8_t obj_type = type(obj); + while (true) + { + LOOP_4(if ((type(car(lst)) == obj_type) && (numbers_are_eqv(sc, obj, car(lst)))) return(lst); lst = cdr(lst); if (!is_pair(lst)) return(sc->F)); + slow = cdr(slow); + if (lst == slow) return(sc->F); } - return (sc->F); + return(sc->F); } -static bool p_to_b (opt_info* p); +/* memv_p_pp migrated to s7_liii_list.c */ -static s7_pointer -g_member (s7_scheme* sc, s7_pointer args) { -#define H_member \ - "(member obj list func) looks for obj in list and returns the list from that point if it is found, otherwise #f. \ +/* g_memv migrated to s7_scheme_predicate.c */ +#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 + +/* bridge for g_memv migration */ +s7_pointer s7i_memv_p_pp(s7_scheme *sc, s7_pointer a, s7_pointer b) +{ + return(memv_p_pp(sc, a, b)); +} + + +s7_pointer s7_member(s7_scheme *sc, s7_pointer obj, s7_pointer lst) +{ + for (s7_pointer p = lst; is_pair(p); p = cdr(p)) + if (s7_is_equal(sc, obj, car(p))) + return(p); + return(sc->F); +} + +static s7_pointer member(s7_scheme *sc, s7_pointer obj, s7_pointer lst) +{ + s7_pointer slow = lst; + if (is_string(obj)) + while (true) + { + if ((obj == car(lst)) || + ((is_string(car(lst))) && + (scheme_strings_are_equal(obj, car(lst))))) + return(lst); + lst = cdr(lst); + if (!is_pair(lst)) return(sc->F); + + if ((obj == car(lst)) || + ((is_string(car(lst))) && + (scheme_strings_are_equal(obj, car(lst))))) + return(lst); + lst = cdr(lst); + if (!is_pair(lst)) return(sc->F); + slow = cdr(slow); + if (lst == slow) return(sc->F); + } + else + while (true) + { + LOOP_4(if (s7_is_equal(sc, obj, car(lst))) return(lst); lst = cdr(lst); if (!is_pair(lst)) return(sc->F)); + slow = cdr(slow); + if (lst == slow) return(sc->F); + } + return(sc->F); +} + +static bool p_to_b(opt_info *p); + +/* -------- s7i_ bridges for list p_p migration to s7_liii_list.c -------- */ +s7_pointer s7i_cons_safe(s7_scheme *sc, s7_pointer p1, s7_pointer p2) +{ + s7_pointer p; + new_cell(sc, p, T_PAIR | T_SAFE_PROCEDURE); + set_car(p, p1); + set_cdr(p, p2); + return(p); +} +s7_pointer s7i_inline_set_car(s7_scheme *sc, s7_pointer lst, s7_pointer value) {return(inline_set_car(sc, lst, value));} +s7_pointer s7i_inline_set_cdr(s7_scheme *sc, s7_pointer lst, s7_pointer value) {return(inline_set_cdr(sc, lst, value));} +bool s7i_is_simple(s7_pointer p) {return(is_simple(p));} +bool s7i_scheme_version_is_s7(s7_scheme *sc) {return(sc->scheme_version == sc->s7_symbol);} +s7_pointer s7i_methods_or_bust_pp(s7_scheme *sc, s7_pointer obj, const char *method_name1, const char *method_name2, + s7_pointer x1, s7_pointer x2, s7_pointer typ, s7_int num) +{ + return(methods_or_bust_pp(sc, obj, s7_make_symbol(sc, method_name1), s7_make_symbol(sc, method_name2), x1, x2, typ, (int32_t)num)); +} +s7_pointer s7i_assoc_1(s7_scheme *sc, s7_pointer obj, s7_pointer lst) {return(assoc_1(sc, obj, lst));} +s7_pointer s7i_memv_number(s7_scheme *sc, s7_pointer obj, s7_pointer lst) {return(memv_number(sc, obj, lst));} +s7_pointer s7i_member(s7_scheme *sc, s7_pointer obj, s7_pointer lst) {return(member(sc, obj, lst));} +s7_int s7i_tree_len(s7_scheme *sc, s7_pointer p) {return(tree_len(sc, p));} +bool s7i_tree_is_cyclic_checked(s7_scheme *sc, s7_pointer tree) {return((sc->safety > no_safety) && (tree_is_cyclic(sc, tree)));} + +static s7_pointer g_member(s7_scheme *sc, s7_pointer args) +{ + #define H_member "(member obj list func) 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) + #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 + * (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. + * 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 lst= cadr (args); - if ((!is_pair (lst)) && (!is_null (lst))) - return ( - method_or_bust (sc, lst, sc->member_symbol, args, a_list_string, 2)); - - if (is_pair (cddr (args))) { - const s7_pointer eq_func= caddr (args); - s7_pointer y; - if (is_safe_c_function (eq_func)) { - s7_function func= c_function_call (eq_func); - if (func == g_is_eq) - return (is_null (lst) ? sc->F : s7_memq (sc, car (args), lst)); - 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)) - wrong_type_error_nr (sc, sc->member_symbol, 3, eq_func, - an_eq_func_string); - set_car (sc->t2_1, car (args)); - for (s7_pointer slow= lst; is_pair (lst); - lst= cdr (lst), slow= cdr (slow)) { - set_car (sc->t2_2, car (lst)); - if (is_true (sc, func (sc, sc->t2_1))) return (lst); - if (!is_pair (cdr (lst))) return (sc->F); - lst= cdr (lst); - if (lst == slow) return (sc->F); - set_car (sc->t2_2, car (lst)); - if (is_true (sc, func (sc, sc->t2_1))) return (lst); - } - return (sc->F); - } - if (closure_has_two_normal_args (sc, eq_func)) { - const s7_pointer body= closure_body (eq_func); - if (is_null (lst)) return (sc->F); - if ((!no_bool_opt (body)) && (is_null (cdr (body)))) { - s7_pfunc func; - set_curlet (sc, make_let_with_two_slots ( - sc, sc->curlet, car (closure_pars (eq_func)), - car (args), cadr (closure_pars (eq_func)), sc->F)); - func= s7_bool_optimize (sc, body); - if (func) { - opt_info* o = sc->opts[0]; - s7_pointer slot= next_slot (let_slots (sc->curlet)); - if (q_call (o).fb == p_to_b) { - s7_pointer (*fp) (opt_info* o)= q_temp (o).fp; - for (s7_pointer slow= lst; is_pair (lst); - lst= cdr (lst), slow= cdr (slow)) { - slot_set_value (slot, car (lst)); - if (fp (o) != sc->F) return (lst); - if (!is_pair (cdr (lst))) return (sc->F); - lst= cdr (lst); - if (lst == slow) return (sc->F); - slot_set_value (slot, car (lst)); - if (fp (o) != sc->F) return (lst); - } - } - else - for (s7_pointer slow= lst; is_pair (lst); - lst= cdr (lst), slow= cdr (slow)) { - slot_set_value (slot, car (lst)); - if (q_call (o).fb (o)) return (lst); - if (!is_pair (cdr (lst))) return (sc->F); - lst= cdr (lst); - if (lst == slow) return (sc->F); - slot_set_value (slot, car (lst)); - if (q_call (o).fb (o)) return (lst); - } - return (sc->F); - } - set_no_bool_opt (body); - } + s7_pointer lst = cadr(args); + if ((!is_pair(lst)) && (!is_null(lst))) + return(method_or_bust(sc, lst, sc->member_symbol, args, a_list_string, 2)); + + if (is_pair(cddr(args))) + { + const s7_pointer eq_func = caddr(args); + s7_pointer y; + if (is_safe_c_function(eq_func)) + { + s7_function func = c_function_call(eq_func); + if (func == g_is_eq) return(is_null(lst) ? sc->F : s7_memq(sc, car(args), lst)); + 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)) + wrong_type_error_nr(sc, sc->member_symbol, 3, eq_func, an_eq_func_string); + set_car(sc->t2_1, car(args)); + for (s7_pointer slow = lst; is_pair(lst); lst = cdr(lst), slow = cdr(slow)) + { + set_car(sc->t2_2, car(lst)); + if (is_true(sc, func(sc, sc->t2_1))) return(lst); + if (!is_pair(cdr(lst))) return(sc->F); + lst = cdr(lst); + if (lst == slow) return(sc->F); + set_car(sc->t2_2, car(lst)); + if (is_true(sc, func(sc, sc->t2_1))) return(lst); + } + return(sc->F); + } + if (closure_has_two_normal_args(sc, eq_func)) + { + const s7_pointer body = closure_body(eq_func); + if (is_null(lst)) return(sc->F); + if ((!no_bool_opt(body)) && + (is_null(cdr(body)))) + { + s7_pfunc func; + set_curlet(sc, make_let_with_two_slots(sc, sc->curlet, car(closure_pars(eq_func)), car(args), cadr(closure_pars(eq_func)), sc->F)); + func = s7_bool_optimize(sc, body); + if (func) + { + opt_info *o = sc->opts[0]; + s7_pointer slot = next_slot(let_slots(sc->curlet)); + if (q_call(o).fb == p_to_b) + { + s7_pointer (*fp)(opt_info *o) = q_temp(o).fp; + for (s7_pointer slow = lst; is_pair(lst); lst = cdr(lst), slow = cdr(slow)) + { + slot_set_value(slot, car(lst)); + if (fp(o) != sc->F) return(lst); + if (!is_pair(cdr(lst))) return(sc->F); + lst = cdr(lst); + if (lst == slow) return(sc->F); + slot_set_value(slot, car(lst)); + if (fp(o) != sc->F) return(lst); + }} + else + for (s7_pointer slow = lst; is_pair(lst); lst = cdr(lst), slow = cdr(slow)) + { + slot_set_value(slot, car(lst)); + if (q_call(o).fb(o)) return(lst); + if (!is_pair(cdr(lst))) return(sc->F); + lst = cdr(lst); + if (lst == slow) return(sc->F); + slot_set_value(slot, car(lst)); + if (q_call(o).fb(o)) return(lst); + } + return(sc->F); + } + set_no_bool_opt(body); + }} + if (type(eq_func) < T_CONTINUATION) + return(method_or_bust(sc, eq_func, sc->member_symbol, args, a_procedure_string, 3)); + if (!s7_is_aritable(sc, eq_func, 2)) + wrong_type_error_nr(sc, sc->member_symbol, 3, eq_func, an_eq_func_string); + if (is_null(lst)) return(sc->F); + if ((is_any_macro(eq_func)) && (!is_c_macro(eq_func))) + clear_all_optimizations(sc, closure_body(eq_func)); + y = list_1(sc, sc->temp9 = copy_proper_list(sc, args)); /* this could probably be handled with a counter cell (cdr here is unused) */ + sc->temp9 = y; + set_opt1_fast(y, lst); + set_opt2_slow(y, lst); + begin_temp(sc->x, y); + push_stack(sc, OP_MEMBER_IF, list_1(sc, y), eq_func); + end_temp(sc->x); + sc->temp9 = sc->unused; + if (needs_copied_args(eq_func)) + push_stack(sc, OP_APPLY, list_2_unchecked(sc, car(args), car(lst)), eq_func); + else + { + set_car(sc->t2_1, car(args)); + set_car(sc->t2_2, car(lst)); + push_stack(sc, OP_APPLY, sc->t2_1, eq_func); + } + return(sc->unspecified); } - if (type (eq_func) < T_CONTINUATION) - return (method_or_bust (sc, eq_func, sc->member_symbol, args, - a_procedure_string, 3)); - if (!s7_is_aritable (sc, eq_func, 2)) - wrong_type_error_nr (sc, sc->member_symbol, 3, eq_func, - an_eq_func_string); - if (is_null (lst)) return (sc->F); - if ((is_any_macro (eq_func)) && (!is_c_macro (eq_func))) - clear_all_optimizations (sc, closure_body (eq_func)); - y= list_1 (sc, sc->temp9= copy_proper_list ( - sc, args)); /* this could probably be handled with a - counter cell (cdr here is unused) */ - sc->temp9= y; - set_opt1_fast (y, lst); - set_opt2_slow (y, lst); - begin_temp (sc->x, y); - push_stack (sc, OP_MEMBER_IF, list_1 (sc, y), eq_func); - end_temp (sc->x); - sc->temp9= sc->unused; - if (needs_copied_args (eq_func)) - push_stack (sc, OP_APPLY, list_2_unchecked (sc, car (args), car (lst)), - eq_func); - else { - set_car (sc->t2_1, car (args)); - set_car (sc->t2_2, car (lst)); - push_stack (sc, OP_APPLY, sc->t2_1, eq_func); - } - return (sc->unspecified); - } - if (is_null (lst)) return (sc->F); + if (is_null(lst)) return(sc->F); { - s7_pointer obj= car (args); - if (is_simple (obj)) return (s7_memq (sc, obj, lst)); - /* 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, lst)); - return (member (sc, obj, lst)); + s7_pointer obj = car(args); + if (is_simple(obj)) + return(s7_memq(sc, obj, lst)); + /* 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, lst)); + return(member(sc, obj, lst)); } } -static s7_pointer -member_p_pp (s7_scheme* sc, s7_pointer obj, s7_pointer lst) { - if (is_null (lst)) return (sc->F); - if (!is_pair (lst)) - return (method_or_bust (sc, lst, sc->member_symbol, - set_plist_2 (sc, obj, lst), a_list_string, 2)); - if (is_simple (obj)) return (s7_memq (sc, obj, lst)); - if (is_number (obj)) return (memv_number (sc, obj, lst)); - return (member (sc, obj, lst)); -} - -static s7_pointer -member_chooser (s7_scheme* sc, s7_pointer func, int32_t args, s7_pointer expr) { - 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)); - if (cadddr (expr) == sc->is_eqv_symbol) - return (global_value (sc->memv_symbol)); - } - return (func); +/* member_p_pp migrated to s7_liii_list.c */ + +static s7_pointer member_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + 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)); + if (cadddr(expr) == sc->is_eqv_symbol) return(global_value(sc->memv_symbol)); + } + return(func); } -static bool -op_member_if (s7_scheme* sc) { - const 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 +static bool op_member_if(s7_scheme *sc) +{ + const 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 (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 (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); + 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 -------------------------------- */ #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) +#define Q_list s7_make_circular_signature(sc, 1, 2, sc->is_proper_list_symbol, sc->T) /* g_list is now defined in s7_liii_list.c */ -static s7_pointer -list_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer unused_expr) { - 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 : func); -} - -s7_pointer -list_p_p (s7_scheme* sc, s7_pointer p1) { - return (list_1 (sc, sc->value= 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)); -} -/* if the GC sees a free cell here, protect it in the caller, not here, but - * sometimes the GC is called here! */ - -const char* ordinal[11] = {"zeroth", "first", "second", "third", - "fourth", "fifth", "sixth", "seventh", - "eighth", "ninth", "tenth"}; -const s7_int ordinal_length[11]= {6, 5, 6, 5, 6, 5, 5, 7, 6, 5, 5}; - -static void -check_list_validity (s7_scheme* sc, const char* caller, s7_pointer lst) { - s7_pointer p= lst; - for (int32_t i= 1; is_pair (p); p= cdr (p), i++) - if (!s7_is_valid (sc, car (p))) { - if (i < 11) - s7_warn (sc, 256, "the %s argument to %s: %p, is not an s7 object\n", - ordinal[i], caller, car (p)); - else - s7_warn (sc, 256, "%s: argument number %d is not an s7 object: %p\n", - caller, i, car (p)); - } + +static s7_pointer list_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr) +{ + 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 : func); } -s7_pointer -s7_list (s7_scheme* sc, s7_int num_values, ...) { - va_list ap; +s7_pointer list_p_p(s7_scheme *sc, s7_pointer p1) {return(list_1(sc, sc->value = 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));} +/* if the GC sees a free cell here, protect it in the caller, not here, but sometimes the GC is called here! */ + +const char *ordinal[11] = {"zeroth", "first", "second", "third", "fourth", "fifth", "sixth", "seventh", "eighth", "ninth", "tenth"}; +const s7_int ordinal_length[11] = {6, 5, 6, 5, 6, 5, 5, 7, 6, 5, 5}; + +static void check_list_validity(s7_scheme *sc, const char *caller, s7_pointer lst) +{ + s7_pointer p = lst; + for (int32_t i = 1; is_pair(p); p = cdr(p), i++) + if (!s7_is_valid(sc, car(p))) + { + if (i < 11) + s7_warn(sc, 256, "the %s argument to %s: %p, is not an s7 object\n", ordinal[i], caller, car(p)); + else s7_warn(sc, 256, "%s: argument number %d is not an s7 object: %p\n", caller, i, car(p)); + } +} + +s7_pointer s7_list(s7_scheme *sc, s7_int num_values, ...) +{ + va_list ap; s7_pointer p; - if (num_values == 0) return (sc->nil); - begin_temp (sc->v, p= make_list (sc, num_values, sc->unused)); - va_start (ap, num_values); - for (s7_int i= 0; 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, __func__, sc->v); - return_with_end_temp (sc->v); -} - -s7_pointer -s7_list_nl (s7_scheme* sc, s7_int num_values, - ...) /* arglist should be NULL terminated */ -{ - s7_int i= 0; - va_list ap; + if (num_values == 0) return(sc->nil); + begin_temp(sc->v, p = make_list(sc, num_values, sc->unused)); + va_start(ap, num_values); + for (s7_int i = 0; 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, __func__, sc->v); + return_with_end_temp(sc->v); +} + +s7_pointer s7_list_nl(s7_scheme *sc, s7_int num_values, ...) /* arglist should be NULL terminated */ +{ + s7_int i = 0; + va_list ap; s7_pointer p; - if (num_values == 0) return (sc->nil); - begin_temp (sc->v, make_list (sc, num_values, sc->unused)); - va_start (ap, num_values); - for (s7_pointer q= sc->v; i < num_values; i++, q= cdr (q)) { - p= va_arg (ap, s7_pointer); - if (!p) { - va_end (ap); - wrong_number_of_arguments_error_nr ( - sc, "not enough arguments for s7_list_nl: ~S", 39, - sc->v); /* ideally we'd sublist this and append extra below */ - } - set_car (q, p); - } - p= va_arg (ap, s7_pointer); - va_end (ap); - if (p) - wrong_number_of_arguments_error_nr ( - sc, "too many arguments for s7_list_nl: ~S", 37, sc->v); + if (num_values == 0) return(sc->nil); + begin_temp(sc->v, make_list(sc, num_values, sc->unused)); + va_start(ap, num_values); + for (s7_pointer q = sc->v; i < num_values; i++, q = cdr(q)) + { + p = va_arg(ap, s7_pointer); + if (!p) + { + va_end(ap); + wrong_number_of_arguments_error_nr(sc, "not enough arguments for s7_list_nl: ~S", 39, sc->v); /* ideally we'd sublist this and append extra below */ + } + set_car(q, p); + } + p = va_arg(ap, s7_pointer); + va_end(ap); + if (p) wrong_number_of_arguments_error_nr(sc, "too many arguments for s7_list_nl: ~S", 37, sc->v); - if (sc->safety > no_safety) check_list_validity (sc, __func__, sc->v); - return_with_end_temp (sc->v); + if (sc->safety > no_safety) + check_list_validity(sc, __func__, sc->v); + return_with_end_temp(sc->v); } -static s7_pointer -safe_list_1 (s7_scheme* sc) { - if (!safe_list_is_in_use (sc->safe_lists[1])) { - sc->current_safe_list= 1; - set_safe_list_in_use (sc->safe_lists[1]); +static s7_pointer safe_list_1(s7_scheme *sc) +{ + if (!safe_list_is_in_use(sc->safe_lists[1])) + { + sc->current_safe_list = 1; + set_safe_list_in_use(sc->safe_lists[1]); #if S7_DEBUGGING - sc->safe_list_uses[1]++; + sc->safe_list_uses[1]++; #endif - return (sc->safe_lists[1]); - } - return (cons (sc, sc->nil, sc->nil)); + return(sc->safe_lists[1]); + } + return(cons(sc, sc->nil, sc->nil)); } -static s7_pointer -safe_list_2 (s7_scheme* sc) { - if (!safe_list_is_in_use (sc->safe_lists[2])) { - sc->current_safe_list= 2; - set_safe_list_in_use (sc->safe_lists[2]); +static s7_pointer safe_list_2(s7_scheme *sc) +{ + if (!safe_list_is_in_use(sc->safe_lists[2])) + { + sc->current_safe_list = 2; + set_safe_list_in_use(sc->safe_lists[2]); #if S7_DEBUGGING - sc->safe_list_uses[2]++; + sc->safe_list_uses[2]++; #endif - return (sc->safe_lists[2]); - } - return (cons_unchecked (sc, sc->nil, list_1 (sc, sc->nil))); + 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) { - if (!is_pair (sc->safe_lists[num_args])) - sc->safe_lists[num_args]= semipermanent_list (sc, num_args); - if (!safe_list_is_in_use (sc->safe_lists[num_args])) { - sc->current_safe_list= num_args; - set_safe_list_in_use (sc->safe_lists[num_args]); +static s7_pointer make_safe_list(s7_scheme *sc, s7_int num_args) +{ + if (num_args < NUM_SAFE_LISTS) + { + if (!is_pair(sc->safe_lists[num_args])) + sc->safe_lists[num_args] = semipermanent_list(sc, num_args); + if (!safe_list_is_in_use(sc->safe_lists[num_args])) + { + sc->current_safe_list = num_args; + set_safe_list_in_use(sc->safe_lists[num_args]); #if S7_DEBUGGING - sc->safe_list_uses[num_args]++; + sc->safe_list_uses[num_args]++; #endif - return (sc->safe_lists[num_args]); - } - } - return (make_big_list (sc, num_args, sc->nil)); + 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) { - if (safe_list_is_in_use (sc->safe_lists[num_args])) - return (make_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) + { + if (safe_list_is_in_use(sc->safe_lists[num_args])) + return(make_list(sc, num_args, sc->nil)); - sc->current_safe_list= num_args; - set_safe_list_in_use (sc->safe_lists[num_args]); + sc->current_safe_list = num_args; + set_safe_list_in_use(sc->safe_lists[num_args]); #if S7_DEBUGGING - sc->safe_list_uses[num_args]++; + sc->safe_list_uses[num_args]++; #endif - return (sc->safe_lists[num_args]); - } - return (make_safe_list (sc, num_args)); -} - -static s7_pointer -g_list_append (s7_scheme* sc, s7_pointer args) { - s7_pointer tp= sc->nil, np= NULL, pp; - - /* 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 */ - gc_protect_via_stack (sc, args); - for (s7_pointer arglist= args; is_pair (arglist); - arglist = cdr (arglist)) /* not dotted */ - { - const s7_pointer p= car (arglist); - s7_pointer func; - if ((has_active_methods (sc, p)) && - ((func= find_method_with_let (sc, p, sc->append_symbol)) != - sc->undefined)) { - unstack_gc_protect (sc); - return (s7_apply_function ( - sc, func, (is_null (tp)) ? arglist : set_ulist_1 (sc, tp, arglist))); - } - if (is_null (cdr (arglist))) { - if (is_null (tp)) { - /* Guile: (append '() 1): 1, r7rs claims an improper list is the result, - * yet its own examples contradict that */ - unstack_gc_protect (sc); - return (p); - } - if (is_list (p)) set_cdr (np, p); - else { - s7_int len= sequence_length (sc, p); - if (len > 0) - set_cdr (np, s7_copy_1 (sc, sc->append_symbol, - set_plist_2 ( - sc, p, make_list (sc, len, sc->unused)))); - else if (len < 0) set_cdr (np, p); - } - sc->temp8= sc->unused; - unstack_gc_protect (sc); - return (tp); - } - if (!is_sequence (p)) { - unstack_gc_protect (sc); - wrong_type_error_nr (sc, sc->append_symbol, position_of (arglist, args), - p, a_sequence_string); - } - if (!sequence_is_empty (sc, p)) { - if (is_pair (p)) { - if (!s7_is_proper_list (sc, p)) { - sc->temp8= sc->unused; - unstack_gc_protect (sc); - wrong_type_error_nr (sc, sc->append_symbol, - position_of (arglist, args), p, - a_proper_list_string); - } - if (is_null (tp)) { - tp = list_1 (sc, car (p)); - np = tp; - sc->temp8= 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 { - const s7_int len= sequence_length (sc, p); - if (len > 0) { - if (is_null (tp)) { - tp= s7_copy_1 ( - sc, sc->append_symbol, - set_plist_2 (sc, p, make_list (sc, len, sc->unused))); - np = tp; - sc->temp8= tp; - } - else - set_cdr (np, - s7_copy_1 ( - sc, sc->append_symbol, - set_plist_2 (sc, p, make_list (sc, len, sc->unused)))); - for (; is_pair (cdr (np)); np= cdr (np)) - ; - } - else if (len < 0) { - unstack_gc_protect (sc); - wrong_type_error_nr (sc, sc->append_symbol, - position_of (arglist, args), p, - a_sequence_string); - } - } + return(sc->safe_lists[num_args]); } - } - unstack_gc_protect (sc); - return (tp); + return(make_safe_list(sc, num_args)); } -static s7_pointer -append_in_place (s7_scheme* sc, s7_pointer a, s7_pointer b) { +static s7_pointer g_list_append(s7_scheme *sc, s7_pointer args) +{ + s7_pointer tp = sc->nil, np = NULL, pp; + + /* 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 */ + gc_protect_via_stack(sc, args); + for (s7_pointer arglist = args; is_pair(arglist); arglist = cdr(arglist)) /* not dotted */ + { + const s7_pointer p = car(arglist); + s7_pointer func; + if ((has_active_methods(sc, p)) && + ((func = find_method_with_let(sc, p, sc->append_symbol)) != sc->undefined)) + { + unstack_gc_protect(sc); + return(s7_apply_function(sc, func, (is_null(tp)) ? arglist : set_ulist_1(sc, tp, arglist))); + } + if (is_null(cdr(arglist))) + { + if (is_null(tp)) + { + /* Guile: (append '() 1): 1, r7rs claims an improper list is the result, yet its own examples contradict that */ + unstack_gc_protect(sc); + return(p); + } + if (is_list(p)) + set_cdr(np, p); + else + { + s7_int len = sequence_length(sc, p); + if (len > 0) + set_cdr(np, s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, p, make_list(sc, len, sc->unused)))); + else + if (len < 0) + set_cdr(np, p); + } + sc->temp8 = sc->unused; + unstack_gc_protect(sc); + return(tp); + } + if (!is_sequence(p)) + { + unstack_gc_protect(sc); + wrong_type_error_nr(sc, sc->append_symbol, position_of(arglist, args), p, a_sequence_string); + } + if (!sequence_is_empty(sc, p)) + { + if (is_pair(p)) + { + if (!s7_is_proper_list(sc, p)) + { + sc->temp8 = sc->unused; + unstack_gc_protect(sc); + wrong_type_error_nr(sc, sc->append_symbol, position_of(arglist, args), p, a_proper_list_string); + } + if (is_null(tp)) + { + tp = list_1(sc, car(p)); + np = tp; + sc->temp8 = 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 + { + const s7_int len = sequence_length(sc, p); + if (len > 0) + { + if (is_null(tp)) + { + tp = s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, p, make_list(sc, len, sc->unused))); + np = tp; + sc->temp8 = tp; + } + else set_cdr(np, s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, p, make_list(sc, len, sc->unused)))); + for (; is_pair(cdr(np)); np = cdr(np)); + } + else + if (len < 0) + { + unstack_gc_protect(sc); + wrong_type_error_nr(sc, sc->append_symbol, position_of(arglist, args), p, a_sequence_string); + }}}} + unstack_gc_protect(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); + 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_complex_vector (s7_pointer p) { - return (is_complex_vector (p)); -} -bool -s7_is_int_vector (s7_pointer p) { - return (is_int_vector (p)); -} -bool -s7_is_byte_vector (s7_pointer p) { - return (is_byte_vector (p)); -} +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_complex_vector(s7_pointer p) {return(is_complex_vector(p));} +bool s7_is_int_vector(s7_pointer p) {return(is_int_vector(p));} +bool s7_is_byte_vector(s7_pointer p) {return(is_byte_vector(p));} -static bool -is_byte_vector_b_p (s7_pointer b) { - return (is_byte_vector (b)); -} +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)); -} +s7_int s7_vector_length(s7_pointer vec) {return(vector_length(vec));} -static s7_pointer -t_vector_setter (s7_scheme* sc, s7_pointer vec, s7_int loc, s7_pointer val) { - vector_element (vec, loc)= val; - return (val); +static s7_pointer t_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 vec) { - s7_pointer typer_name, typer= typed_vector_typer (vec); - if (is_c_function (typer)) return (c_function_symbol (typer)); - typer_name= find_typer (sc, typer); - return ((is_symbol (typer_name)) ? typer_name : sc->anon_symbol); +static s7_pointer typed_vector_typer_symbol(s7_scheme *sc, s7_pointer vec) +{ + s7_pointer typer_name, typer = typed_vector_typer(vec); + if (is_c_function(typer)) + return(c_function_symbol(typer)); + typer_name = find_typer(sc, typer); + return((is_symbol(typer_name)) ? typer_name : sc->anon_symbol); } -static const char* -typed_vector_typer_name (s7_scheme* sc, s7_pointer vec) { - s7_pointer typer= typed_vector_typer (vec); - return ((is_c_function (typer)) - ? c_function_name (typer) - : symbol_name (typed_vector_typer_symbol (sc, vec))); +static const char *typed_vector_typer_name(s7_scheme *sc, s7_pointer vec) +{ + s7_pointer typer = typed_vector_typer(vec); + return((is_c_function(typer)) ? c_function_name(typer) : symbol_name(typed_vector_typer_symbol(sc, vec))); } -static void -port_write_vector_typer (s7_scheme* sc, s7_pointer vect, s7_pointer port) { - const char* setter= - make_type_name (sc, typed_vector_typer_name (sc, vect), no_article); - port_write_string (port) (sc, setter, safe_strlen (setter), port); +void port_write_vector_typer(s7_scheme *sc, s7_pointer vect, s7_pointer port) +{ + const char *setter = make_type_name(sc, typed_vector_typer_name(sc, vect), no_article); + port_write_string(port)(sc, setter, safe_strlen(setter), port); } -static no_return void -typed_vector_type_error_nr (s7_scheme* sc, s7_pointer vec, s7_pointer val) { - const char* descr= typed_vector_typer_name (sc, vec); - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_3 (sc, - wrap_string (sc, - "vector-set! new value ~$ is rejected by " - "the vector's vector-typer, ~A", - 69), - val, wrap_string (sc, descr, safe_strlen (descr)))); +static no_return void typed_vector_type_error_nr(s7_scheme *sc, s7_pointer vec, s7_pointer val) +{ + const char *descr = typed_vector_typer_name(sc, vec); + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "vector-set! new value ~$ is rejected by the vector's vector-typer, ~A", 69), + val, wrap_string(sc, descr, safe_strlen(descr)))); } -static inline s7_pointer -typed_vector_setter ( - s7_scheme* sc, s7_pointer vec, s7_int loc, - s7_pointer val) /* tstr faster without inline, but tbig slower */ +static inline s7_pointer typed_vector_setter(s7_scheme *sc, s7_pointer vec, s7_int loc, s7_pointer val) /* tstr faster without inline, but tbig slower */ { if ((sc->safety >= no_safety) && /* only use of safety == -1 */ - (typed_vector_typer_call (sc, vec, set_plist_1 (sc, val)) == sc->F)) - typed_vector_type_error_nr (sc, vec, val); - vector_element (vec, loc)= val; - return (val); + (typed_vector_typer_call(sc, vec, set_plist_1(sc, val)) == sc->F)) + typed_vector_type_error_nr(sc, vec, val); + vector_element(vec, loc) = val; + return(val); } -static s7_pointer -t_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 -complex_vector_getter (s7_scheme* sc, s7_pointer vec, s7_int loc) { - return (c_complex_to_s7 (sc, complex_vector (vec, loc))); -} -static s7_pointer -byte_vector_getter (s7_scheme* sc, s7_pointer vec, s7_int loc) { - return (small_int (byte_vector (vec, loc))); -} +static s7_pointer t_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 complex_vector_getter(s7_scheme *sc, s7_pointer vec, s7_int loc) {return(c_complex_to_s7(sc, complex_vector(vec, loc)));} +static s7_pointer byte_vector_getter(s7_scheme *sc, s7_pointer vec, s7_int loc) {return(small_int(byte_vector(vec, 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_clamped_if_gmp (sc, val); - else - wrong_type_error_nr (sc, sc->int_vector_set_symbol, 3, val, - sc->type_names[T_INTEGER]); - return (val); +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_clamped_if_gmp(sc, val); + else wrong_type_error_nr(sc, sc->int_vector_set_symbol, 3, val, sc->type_names[T_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 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 -complex_vector_setter (s7_scheme* sc, s7_pointer vec, s7_int loc, - s7_pointer val) { - complex_vector (vec, loc)= s7_to_c_complex (val); - return (val); +static s7_pointer complex_vector_setter(s7_scheme *sc, s7_pointer vec, s7_int loc, s7_pointer val) +{ + complex_vector(vec, loc) = s7_to_c_complex(val); + return(val); } -static s7_pointer -byte_vector_setter (s7_scheme* sc, s7_pointer vec, s7_int loc, s7_pointer val) { +static s7_pointer byte_vector_setter(s7_scheme *sc, s7_pointer vec, s7_int loc, s7_pointer val) +{ s7_int byte; - if (!s7_is_integer (val)) - wrong_type_error_nr (sc, sc->byte_vector_set_symbol, 3, val, - sc->type_names[T_INTEGER]); - byte= s7_integer_clamped_if_gmp (sc, val); + if (!s7_is_integer(val)) + wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 3, val, sc->type_names[T_INTEGER]); + byte = s7_integer_clamped_if_gmp(sc, val); if ((byte < 0) || (byte >= 256)) - wrong_type_error_nr (sc, sc->byte_vector_set_symbol, 3, val, - wrap_string (sc, "a byte", 6)); - byte_vector (vec, loc)= (uint8_t) byte; - return (val); + wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 3, val, wrap_string(sc, "a byte", 6)); + byte_vector(vec, loc) = (uint8_t)byte; + return(val); } -static block_t* -mallocate_empty_block (s7_scheme* sc) { - block_t* b= mallocate_block (sc); +static block_t *mallocate_empty_block(s7_scheme *sc) +{ + block_t *b = mallocate_block(sc); #if S7_DEBUGGING sc->blocks_mallocated[BLOCK_LIST]++; #endif - block_data (b)= NULL; - block_info (b)= NULL; - return (b); + block_data(b) = NULL; + block_info(b) = NULL; + return(b); } -#define mallocate_vector(Sc, Len) \ - ((Len) > 0) ? inline_mallocate (Sc, Len) : mallocate_empty_block (Sc) +#define mallocate_vector(Sc, Len) ((Len) > 0) ? inline_mallocate(Sc, Len) : mallocate_empty_block(Sc) -extern inline s7_pointer -make_simple_vector (s7_scheme* sc, s7_int len) /* len >= 0 and < max */ +extern inline s7_pointer make_simple_vector(s7_scheme *sc, s7_int len) /* len >= 0 and < max */ { s7_pointer vect; - block_t* b= mallocate_vector (sc, len * sizeof (s7_pointer)); - new_cell (sc, vect, T_VECTOR | T_SAFE_PROCEDURE); - vector_length (vect) = len; - vector_block (vect) = b; - vector_elements (vect)= (s7_pointer*) block_data (b); - vector_set_dimension_info (vect, NULL); - vector_getter (vect)= t_vector_getter; - vector_setter (vect)= t_vector_setter; - add_vector (sc, vect); - return (vect); -} - -static inline s7_pointer -make_simple_float_vector (s7_scheme* sc, s7_int len) /* len >= 0 and < max */ + block_t *b = mallocate_vector(sc, len * sizeof(s7_pointer)); + new_cell(sc, vect, T_VECTOR | T_SAFE_PROCEDURE); + vector_length(vect) = len; + vector_block(vect) = b; + vector_elements(vect) = (s7_pointer *)block_data(b); + vector_set_dimension_info(vect, NULL); + vector_getter(vect) = t_vector_getter; + vector_setter(vect) = t_vector_setter; + add_vector(sc, vect); + return(vect); +} + +static inline s7_pointer make_simple_float_vector(s7_scheme *sc, s7_int len) /* len >= 0 and < max */ { s7_pointer vect; - block_t* b= mallocate_vector (sc, len * sizeof (s7_double)); - new_cell (sc, vect, T_FLOAT_VECTOR | T_SAFE_PROCEDURE); - vector_length (vect) = len; - vector_block (vect) = b; - float_vector_floats (vect)= (s7_double*) block_data (b); - vector_set_dimension_info (vect, NULL); - vector_getter (vect)= float_vector_getter; - vector_setter (vect)= float_vector_setter; - add_vector (sc, vect); - return (vect); -} - -static inline s7_pointer -make_simple_complex_vector (s7_scheme* sc, s7_int len) /* len >= 0 and < max */ + block_t *b = mallocate_vector(sc, len * sizeof(s7_double)); + new_cell(sc, vect, T_FLOAT_VECTOR | T_SAFE_PROCEDURE); + vector_length(vect) = len; + vector_block(vect) = b; + float_vector_floats(vect) = (s7_double *)block_data(b); + vector_set_dimension_info(vect, NULL); + vector_getter(vect) = float_vector_getter; + vector_setter(vect) = float_vector_setter; + add_vector(sc, vect); + return(vect); +} + +static inline s7_pointer make_simple_complex_vector(s7_scheme *sc, s7_int len) /* len >= 0 and < max */ { s7_pointer vect; - block_t* b= mallocate_vector (sc, len * sizeof (s7_complex)); - new_cell (sc, vect, T_COMPLEX_VECTOR | T_SAFE_PROCEDURE); - vector_length (vect) = len; - vector_block (vect) = b; - complex_vector_complexes (vect)= (s7_complex*) block_data (b); - vector_set_dimension_info (vect, NULL); - vector_getter (vect)= complex_vector_getter; - vector_setter (vect)= complex_vector_setter; - add_vector (sc, vect); - return (vect); -} - -static inline s7_pointer -make_simple_int_vector (s7_scheme* sc, s7_int len) /* len >= 0 and < max */ + block_t *b = mallocate_vector(sc, len * sizeof(s7_complex)); + new_cell(sc, vect, T_COMPLEX_VECTOR | T_SAFE_PROCEDURE); + vector_length(vect) = len; + vector_block(vect) = b; + complex_vector_complexes(vect) = (s7_complex *)block_data(b); + vector_set_dimension_info(vect, NULL); + vector_getter(vect) = complex_vector_getter; + vector_setter(vect) = complex_vector_setter; + add_vector(sc, vect); + return(vect); +} + +static inline s7_pointer make_simple_int_vector(s7_scheme *sc, s7_int len) /* len >= 0 and < max */ { s7_pointer vect; - block_t* b= mallocate_vector (sc, len * sizeof (s7_int)); - new_cell (sc, vect, T_INT_VECTOR | T_SAFE_PROCEDURE); - vector_length (vect) = len; - vector_block (vect) = b; - int_vector_ints (vect)= (s7_int*) block_data (b); - vector_set_dimension_info (vect, NULL); - vector_getter (vect)= int_vector_getter; - vector_setter (vect)= int_vector_setter; - add_vector (sc, vect); - return (vect); -} - -static s7_pointer -make_simple_byte_vector (s7_scheme* sc, s7_int len) { + block_t *b = mallocate_vector(sc, len * sizeof(s7_int)); + new_cell(sc, vect, T_INT_VECTOR | T_SAFE_PROCEDURE); + vector_length(vect) = len; + vector_block(vect) = b; + int_vector_ints(vect) = (s7_int *)block_data(b); + vector_set_dimension_info(vect, NULL); + vector_getter(vect) = int_vector_getter; + vector_setter(vect) = int_vector_setter; + add_vector(sc, vect); + return(vect); +} + +static s7_pointer make_simple_byte_vector(s7_scheme *sc, s7_int len) +{ s7_pointer vect; - block_t* b= - mallocate_vector (sc, len); /* not inline_mallocate because we need to set - block_data to NULL if len==0 */ - new_cell (sc, vect, T_BYTE_VECTOR | T_SAFE_PROCEDURE); - vector_block (vect) = b; - byte_vector_bytes (vect)= (uint8_t*) block_data (b); - vector_length (vect) = len; - vector_set_dimension_info (vect, NULL); - vector_getter (vect)= byte_vector_getter; - vector_setter (vect)= byte_vector_setter; - add_vector (sc, vect); - return (vect); -} - -static Vectorized void -t_vector_fill (s7_pointer vec, s7_pointer obj) { - s7_pointer* orig= vector_elements (vec); - s7_int len = vector_length (vec), i, left; + block_t *b = mallocate_vector(sc, len); /* not inline_mallocate because we need to set block_data to NULL if len==0 */ + new_cell(sc, vect, T_BYTE_VECTOR | T_SAFE_PROCEDURE); + vector_block(vect) = b; + byte_vector_bytes(vect) = (uint8_t *)block_data(b); + vector_length(vect) = len; + vector_set_dimension_info(vect, NULL); + vector_getter(vect) = byte_vector_getter; + vector_setter(vect) = byte_vector_setter; + add_vector(sc, vect); + return(vect); +} + +static Vectorized void t_vector_fill(s7_pointer vec, s7_pointer obj) +{ + s7_pointer *orig = vector_elements(vec); + 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 */ - left= len - 8; - i = 0; + /* splitting out this part made no difference in speed; type check of obj is handled elsewhere */ + left = len - 8; + i = 0; while (i <= left) - LOOP_8 (orig[i++]= obj); + LOOP_8(orig[i++] = obj); for (; i < len; i++) - orig[i]= obj; + orig[i] = obj; } -static s7_pointer -make_vector_1 (s7_scheme* sc, s7_int len, bool filled, uint8_t typ) { +static s7_pointer make_vector_1(s7_scheme *sc, s7_int len, bool filled, uint8_t typ) +{ s7_pointer vect; if (len < 0) - out_of_range_error_nr (sc, sc->make_vector_symbol, int_one, - wrap_integer (sc, len), it_is_negative_string); + out_of_range_error_nr(sc, sc->make_vector_symbol, int_one, wrap_integer(sc, len), it_is_negative_string); if (len > sc->max_vector_length) - error_nr ( - sc, sc->out_of_range_symbol, - set_elist_3 (sc, - wrap_string (sc, - "make-vector length argument ~D is greater " - "than (*s7* 'max-vector-length), ~D", - 76), - wrap_integer (sc, len), - wrap_integer (sc, sc->max_vector_length))); - - /* this has to follow the error checks! (else garbage in free_heap temps - * portion confuses GC when "vector" is finalized) */ - new_cell (sc, vect, typ | T_SAFE_PROCEDURE); - vector_length (vect)= len; - if (len == 0) { - vector_block (vect) = mallocate_empty_block (sc); - any_vector_elements (vect)= NULL; - if (typ == T_VECTOR) set_has_simple_elements (vect); - } - else if (typ == T_VECTOR) { - block_t* b = inline_mallocate (sc, len * sizeof (s7_pointer)); - vector_block (vect) = b; - vector_elements (vect)= (s7_pointer*) block_data (b); - vector_getter (vect) = t_vector_getter; - vector_setter (vect) = t_vector_setter; - if (filled) t_vector_fill (vect, sc->nil); - } - else if (typ == T_FLOAT_VECTOR) { - block_t* b = inline_mallocate (sc, len * sizeof (s7_double)); - vector_block (vect) = b; - float_vector_floats (vect)= (s7_double*) block_data (b); - if (filled) { - if (STEP_8 (len)) - memclr64 ((void*) float_vector_floats (vect), len * sizeof (s7_double)); - else - memclr ((void*) float_vector_floats (vect), len * sizeof (s7_double)); + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "make-vector length argument ~D is greater than (*s7* 'max-vector-length), ~D", 76), + wrap_integer(sc, len), wrap_integer(sc, sc->max_vector_length))); + + /* this has to follow the error checks! (else garbage in free_heap temps portion confuses GC when "vector" is finalized) */ + new_cell(sc, vect, typ | T_SAFE_PROCEDURE); + vector_length(vect) = len; + if (len == 0) + { + vector_block(vect) = mallocate_empty_block(sc); + any_vector_elements(vect) = NULL; + if (typ == T_VECTOR) set_has_simple_elements(vect); } - vector_getter (vect)= float_vector_getter; - vector_setter (vect)= float_vector_setter; - } - else if (typ == T_INT_VECTOR) { - block_t* b = inline_mallocate (sc, len * sizeof (s7_int)); - vector_block (vect) = b; - int_vector_ints (vect)= (s7_int*) block_data (b); - if (filled) { - if (STEP_8 (len)) - memclr64 ((void*) int_vector_ints (vect), len * sizeof (s7_int)); - else memclr ((void*) int_vector_ints (vect), len * sizeof (s7_int)); - } - vector_getter (vect)= int_vector_getter; - vector_setter (vect)= int_vector_setter; - } - else if (typ == T_COMPLEX_VECTOR) { - block_t* b = inline_mallocate (sc, len * sizeof (s7_complex)); - vector_block (vect)= b; - complex_vector_complexes (vect)= (s7_complex*) block_data (b); - if (filled) { - if (STEP_8 (len)) - memclr64 ((void*) complex_vector_complexes (vect), - len * sizeof (s7_complex)); + else + if (typ == T_VECTOR) + { + block_t *b = inline_mallocate(sc, len * sizeof(s7_pointer)); + vector_block(vect) = b; + vector_elements(vect) = (s7_pointer *)block_data(b); + vector_getter(vect) = t_vector_getter; + vector_setter(vect) = t_vector_setter; + if (filled) t_vector_fill(vect, sc->nil); + } + else + if (typ == T_FLOAT_VECTOR) + { + block_t *b = inline_mallocate(sc, len * sizeof(s7_double)); + vector_block(vect) = b; + float_vector_floats(vect) = (s7_double *)block_data(b); + if (filled) + { + if (STEP_8(len)) + memclr64((void *)float_vector_floats(vect), len * sizeof(s7_double)); + else memclr((void *)float_vector_floats(vect), len * sizeof(s7_double)); + } + vector_getter(vect) = float_vector_getter; + vector_setter(vect) = float_vector_setter; + } else - memclr ((void*) complex_vector_complexes (vect), - len * sizeof (s7_complex)); - } - vector_getter (vect)= complex_vector_getter; - vector_setter (vect)= complex_vector_setter; - } - else /* byte-vector */ - { - block_t* b = mallocate (sc, len); - vector_block (vect) = b; - byte_vector_bytes (vect)= (uint8_t*) block_data (b); - vector_getter (vect) = byte_vector_getter; - vector_setter (vect) = byte_vector_setter; - if (filled) { - if (STEP_64 (len)) memclr64 ((void*) (byte_vector_bytes (vect)), len); - else memclr ((void*) (byte_vector_bytes (vect)), len); - } - } - vector_set_dimension_info (vect, NULL); - return (vect); + if (typ == T_INT_VECTOR) + { + block_t *b = inline_mallocate(sc, len * sizeof(s7_int)); + vector_block(vect) = b; + int_vector_ints(vect) = (s7_int *)block_data(b); + if (filled) + { + if (STEP_8(len)) + memclr64((void *)int_vector_ints(vect), len * sizeof(s7_int)); + else memclr((void *)int_vector_ints(vect), len * sizeof(s7_int)); + } + vector_getter(vect) = int_vector_getter; + vector_setter(vect) = int_vector_setter; + } + else + if (typ == T_COMPLEX_VECTOR) + { + block_t *b = inline_mallocate(sc, len * sizeof(s7_complex)); + vector_block(vect) = b; + complex_vector_complexes(vect) = (s7_complex *)block_data(b); + if (filled) + { + if (STEP_8(len)) + memclr64((void *)complex_vector_complexes(vect), len * sizeof(s7_complex)); + else memclr((void *)complex_vector_complexes(vect), len * sizeof(s7_complex)); + } + vector_getter(vect) = complex_vector_getter; + vector_setter(vect) = complex_vector_setter; + } + else /* byte-vector */ + { + block_t *b = mallocate(sc, len); + vector_block(vect) = b; + byte_vector_bytes(vect) = (uint8_t *)block_data(b); + vector_getter(vect) = byte_vector_getter; + vector_setter(vect) = byte_vector_setter; + if (filled) + { + if (STEP_64(len)) + memclr64((void *)(byte_vector_bytes(vect)), len); + else memclr((void *)(byte_vector_bytes(vect)), len); + }} + vector_set_dimension_info(vect, NULL); + return(vect); } #define FILLED true #define NOT_FILLED false -s7_pointer -s7_make_vector (s7_scheme* sc, s7_int len) { - s7_pointer vec= make_vector_1 (sc, len, FILLED, T_VECTOR); - add_vector (sc, vec); - return (vec); +s7_pointer s7_make_vector(s7_scheme *sc, s7_int len) +{ + s7_pointer vec = make_vector_1(sc, len, FILLED, T_VECTOR); + add_vector(sc, vec); + return(vec); } -s7_pointer -s7_make_and_fill_vector (s7_scheme* sc, s7_int len, s7_pointer fill) { - s7_pointer vect= make_simple_vector (sc, len); - t_vector_fill (vect, fill); - return (vect); +s7_pointer s7_make_and_fill_vector(s7_scheme *sc, s7_int len, s7_pointer fill) +{ + s7_pointer vect = make_simple_vector(sc, len); + t_vector_fill(vect, fill); + return(vect); } -static vdims_t* -make_wrap_only (s7_scheme* sc) /* this makes sc->wrap_only */ +static vdims_t *make_wrap_only(s7_scheme *sc) /* this makes sc->wrap_only */ { - vdims_t* vd= (vdims_t*) mallocate_block (sc); + vdims_t *vd = (vdims_t *)mallocate_block(sc); #if S7_DEBUGGING sc->blocks_mallocated[BLOCK_LIST]++; #endif - vdims_original (vd) = sc->F; - vector_elements_should_be_freed (vd)= false; - vdims_rank (vd) = 1; - vdims_dims (vd) = NULL; - vdims_offsets (vd) = NULL; - return (vd); -} - -static vdims_t* -make_vdims (s7_scheme* sc, bool elements_should_be_freed, s7_int dims, - const s7_int* dim_info) { - vdims_t* vd; - if ((dims == 1) && (!elements_should_be_freed)) return (sc->wrap_only); - if (dims > 1) { - vd = (vdims_t*) mallocate (sc, dims * 2 * sizeof (s7_int)); - vdims_original (vd)= sc->F; - vector_elements_should_be_freed (vd)= elements_should_be_freed; - vdims_rank (vd) = dims; - vdims_offsets (vd) = (s7_int*) (vdims_dims (vd) + dims); - for (s7_int i= 0; i < dims; i++) - vdims_dims (vd)[i]= dim_info[i]; - for (s7_int i= dims - 1, offset= 1; i >= 0; i--) { - vdims_offsets (vd)[i]= offset; - offset*= vdims_dims (vd)[i]; - } - return (vd); - } - vd= (vdims_t*) mallocate_block (sc); + vdims_original(vd) = sc->F; + vector_elements_should_be_freed(vd) = false; + vdims_rank(vd) = 1; + vdims_dims(vd) = NULL; + vdims_offsets(vd) = NULL; + return(vd); +} + +static vdims_t *make_vdims(s7_scheme *sc, bool elements_should_be_freed, s7_int dims, const s7_int *dim_info) +{ + vdims_t *vd; + if ((dims == 1) && (!elements_should_be_freed)) + return(sc->wrap_only); + if (dims > 1) + { + vd = (vdims_t *)mallocate(sc, dims * 2 * sizeof(s7_int)); + vdims_original(vd) = sc->F; + vector_elements_should_be_freed(vd) = elements_should_be_freed; + vdims_rank(vd) = dims; + vdims_offsets(vd) = (s7_int *)(vdims_dims(vd) + dims); + for (s7_int i = 0; i < dims; i++) + vdims_dims(vd)[i] = dim_info[i]; + for (s7_int i = dims - 1, offset = 1; i >= 0; i--) + { + vdims_offsets(vd)[i] = offset; + offset *= vdims_dims(vd)[i]; + } + return(vd); + } + vd = (vdims_t *)mallocate_block(sc); #if S7_DEBUGGING sc->blocks_mallocated[BLOCK_LIST]++; #endif - vdims_original (vd) = sc->F; - vector_elements_should_be_freed (vd)= elements_should_be_freed; - vdims_rank (vd) = 1; - vdims_dims (vd) = NULL; - vdims_offsets (vd) = NULL; - return (vd); -} - -static s7_pointer -make_any_vector (s7_scheme* sc, int32_t type, s7_int len, s7_int dims, - const s7_int* dim_info) { - const s7_pointer vect= make_vector_1 (sc, len, FILLED, type); - if (dim_info) { - vector_set_dimension_info (vect, make_vdims (sc, false, dims, dim_info)); - add_multivector (sc, vect); - } - else add_vector (sc, vect); - return (vect); + vdims_original(vd) = sc->F; + vector_elements_should_be_freed(vd) = elements_should_be_freed; + vdims_rank(vd) = 1; + vdims_dims(vd) = NULL; + vdims_offsets(vd) = NULL; + return(vd); } -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_byte_vector (s7_scheme* sc, s7_int len, s7_int dims, s7_int* dim_info) { - return (make_any_vector (sc, T_BYTE_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_complex_vector (s7_scheme* sc, s7_int len, s7_int dims, - s7_int* dim_info) { - return (make_any_vector (sc, T_COMPLEX_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)); +static s7_pointer make_any_vector(s7_scheme *sc, int32_t type, s7_int len, s7_int dims, const s7_int *dim_info) +{ + const s7_pointer vect = make_vector_1(sc, len, FILLED, type); + if (dim_info) + { + vector_set_dimension_info(vect, make_vdims(sc, false, dims, dim_info)); + add_multivector(sc, vect); + } + else add_vector(sc, vect); + return(vect); } -s7_pointer -s7_make_int_vector_wrapper (s7_scheme* sc, s7_int len, s7_int* data, - s7_int dims, s7_int* dim_info, bool free_data) { +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_byte_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info) {return(make_any_vector(sc, T_BYTE_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_complex_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info) {return(make_any_vector(sc, T_COMPLEX_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_int_vector_wrapper(s7_scheme *sc, s7_int len, s7_int *data, s7_int dims, s7_int *dim_info, bool free_data) +{ /* this wraps up a C-allocated/freed int64_t array as an s7 int-vector */ s7_pointer vect; - block_t* b= mallocate_empty_block (sc); - new_cell (sc, vect, T_INT_VECTOR | T_SAFE_PROCEDURE); - vector_block (vect) = b; - int_vector_ints (vect)= data; - vector_getter (vect) = int_vector_getter; - vector_setter (vect) = int_vector_setter; - vector_length (vect) = len; - if (!dim_info) { - s7_int di[1]; - di[0]= len; - vector_set_dimension_info (vect, make_vdims (sc, free_data, 1, di)); - } - else - vector_set_dimension_info (vect, - make_vdims (sc, free_data, dims, dim_info)); - add_multivector (sc, vect); - return (vect); + block_t *b = mallocate_empty_block(sc); + new_cell(sc, vect, T_INT_VECTOR | T_SAFE_PROCEDURE); + vector_block(vect) = b; + int_vector_ints(vect) = data; + vector_getter(vect) = int_vector_getter; + vector_setter(vect) = int_vector_setter; + vector_length(vect) = len; + if (!dim_info) + { + s7_int di[1]; + di[0] = len; + vector_set_dimension_info(vect, make_vdims(sc, free_data, 1, di)); + } + else vector_set_dimension_info(vect, make_vdims(sc, free_data, dims, dim_info)); + add_multivector(sc, vect); + return(vect); } -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_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 float-vector */ s7_pointer vect; - block_t* b= mallocate_empty_block (sc); - new_cell (sc, vect, T_FLOAT_VECTOR | T_SAFE_PROCEDURE); - vector_block (vect) = b; - float_vector_floats (vect)= data; - vector_getter (vect) = float_vector_getter; - vector_setter (vect) = float_vector_setter; - vector_length (vect) = len; - if (!dim_info) { - s7_int di[1]; - di[0]= len; - vector_set_dimension_info (vect, make_vdims (sc, free_data, 1, di)); - } - else - vector_set_dimension_info (vect, - make_vdims (sc, free_data, dims, dim_info)); - add_multivector (sc, vect); - return (vect); + block_t *b = mallocate_empty_block(sc); + new_cell(sc, vect, T_FLOAT_VECTOR | T_SAFE_PROCEDURE); + vector_block(vect) = b; + float_vector_floats(vect) = data; + vector_getter(vect) = float_vector_getter; + vector_setter(vect) = float_vector_setter; + vector_length(vect) = len; + if (!dim_info) + { + s7_int di[1]; + di[0] = len; + vector_set_dimension_info(vect, make_vdims(sc, free_data, 1, di)); + } + else vector_set_dimension_info(vect, make_vdims(sc, free_data, dims, dim_info)); + add_multivector(sc, vect); + return(vect); } -s7_pointer -s7_make_complex_vector_wrapper (s7_scheme* sc, s7_int len, s7_complex* data, - s7_int dims, s7_int* dim_info, bool free_data) { +s7_pointer s7_make_complex_vector_wrapper(s7_scheme *sc, s7_int len, s7_complex *data, s7_int dims, s7_int *dim_info, bool free_data) +{ /* this wraps up a C-allocated/freed complex array as an s7 complex-vector */ s7_pointer vect; - block_t* b= mallocate_empty_block (sc); - new_cell (sc, vect, T_COMPLEX_VECTOR | T_SAFE_PROCEDURE); - vector_block (vect) = b; - complex_vector_complexes (vect)= data; - vector_getter (vect) = complex_vector_getter; - vector_setter (vect) = complex_vector_setter; - vector_length (vect) = len; - if (!dim_info) { - s7_int di[1]; - di[0]= len; - vector_set_dimension_info (vect, make_vdims (sc, free_data, 1, di)); - } - else - vector_set_dimension_info (vect, - make_vdims (sc, free_data, dims, dim_info)); - add_multivector (sc, vect); - return (vect); + block_t *b = mallocate_empty_block(sc); + new_cell(sc, vect, T_COMPLEX_VECTOR | T_SAFE_PROCEDURE); + vector_block(vect) = b; + complex_vector_complexes(vect) = data; + vector_getter(vect) = complex_vector_getter; + vector_setter(vect) = complex_vector_setter; + vector_length(vect) = len; + if (!dim_info) + { + s7_int di[1]; + di[0] = len; + vector_set_dimension_info(vect, make_vdims(sc, free_data, 1, di)); + } + else vector_set_dimension_info(vect, make_vdims(sc, free_data, dims, dim_info)); + add_multivector(sc, vect); + return(vect); } -/* -------------------------------- vector-fill! - * -------------------------------- */ -static Vectorized void -float_vector_fill (s7_pointer vec, s7_double x) { - const s7_int len= vector_length (vec); + +/* -------------------------------- vector-fill! -------------------------------- */ +static Vectorized void float_vector_fill(s7_pointer vec, s7_double x) +{ + const 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; - } + 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_pointer vec, s7_int k) { - const s7_int len= vector_length (vec); +static Vectorized void int_vector_fill(s7_pointer vec, s7_int k) +{ + const 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; - } + 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_pointer vec, uint8_t byte) { - const s7_int len= vector_length (vec); +static void byte_vector_fill(s7_pointer vec, uint8_t byte) +{ + const s7_int len = vector_length(vec); if (len == 0) return; - if (byte > 0) local_memset ((void*) (byte_vector_bytes (vec)), byte, len); + 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); + if (STEP_64(len)) + memclr64((void *)(byte_vector_bytes(vec)), len); + else memclr((void *)(byte_vector_bytes(vec)), len); } -static void -complex_vector_fill (s7_pointer vec, s7_complex x) { - const s7_int len= vector_length (vec); +static void complex_vector_fill(s7_pointer vec, s7_complex x) +{ + const s7_int len = vector_length(vec); if (len == 0) return; - if (x == 0.0) { - if (STEP_8 (len)) - memclr64 ((void*) complex_vector_complexes (vec), - len * sizeof (s7_complex)); - else - memclr ((void*) complex_vector_complexes (vec), - len * sizeof (s7_complex)); - } - else { - s7_int i= 0, left= len - 8; - s7_complex* orig= complex_vector_complexes (vec); - while (i <= left) - LOOP_8 (orig[i++]= x); - for (; i < len; i++) - orig[i]= x; - } + if (x == 0.0) + { + if (STEP_8(len)) + memclr64((void *)complex_vector_complexes(vec), len * sizeof(s7_complex)); + else memclr((void *)complex_vector_complexes(vec), len * sizeof(s7_complex)); + } + else + { + s7_int i = 0, left = len - 8; + s7_complex *orig = complex_vector_complexes(vec); + while (i <= left) + LOOP_8(orig[i++] = x); + for (; i < len; i++) + orig[i] = x; + } } -void -s7_vector_fill (s7_scheme* sc, s7_pointer vec, s7_pointer obj) { - switch (type (vec)) { - case T_FLOAT_VECTOR: - if (!is_real (obj)) - wrong_type_error_nr (sc, wrap_string (sc, "float-vector fill!", 18), 2, - obj, sc->type_names[T_REAL]); - float_vector_fill (vec, s7_real (obj)); - break; - case T_INT_VECTOR: - if (!s7_is_integer (obj)) /* possibly a bignum */ - wrong_type_error_nr (sc, wrap_string (sc, "int-vector fill!", 16), 2, obj, - sc->type_names[T_INTEGER]); - int_vector_fill (vec, s7_integer_clamped_if_gmp (sc, obj)); - break; - case T_BYTE_VECTOR: - if (!is_byte (obj)) - wrong_type_error_nr (sc, wrap_string (sc, "byte-vector fill!", 17), 2, - obj, wrap_string (sc, "a byte", 6)); - byte_vector_fill (vec, (uint8_t) s7_integer_clamped_if_gmp (sc, obj)); - break; - case T_COMPLEX_VECTOR: - if (!is_number (obj)) - wrong_type_error_nr (sc, wrap_string (sc, "complex-vector fill!", 20), 2, - obj, sc->type_names[T_COMPLEX]); - complex_vector_fill (vec, s7_to_c_complex (obj)); - break; - case T_VECTOR: - default: - t_vector_fill (vec, 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)) + wrong_type_error_nr(sc, wrap_string(sc, "float-vector fill!", 18), 2, obj, sc->type_names[T_REAL]); + float_vector_fill(vec, s7_real(obj)); + break; + case T_INT_VECTOR: + if (!s7_is_integer(obj)) /* possibly a bignum */ + wrong_type_error_nr(sc, wrap_string(sc, "int-vector fill!", 16), 2, obj, sc->type_names[T_INTEGER]); + int_vector_fill(vec, s7_integer_clamped_if_gmp(sc, obj)); + break; + case T_BYTE_VECTOR: + if (!is_byte(obj)) + wrong_type_error_nr(sc, wrap_string(sc, "byte-vector fill!", 17), 2, obj, wrap_string(sc, "a byte", 6)); + byte_vector_fill(vec, (uint8_t)s7_integer_clamped_if_gmp(sc, obj)); + break; + case T_COMPLEX_VECTOR: + if (!is_number(obj)) + wrong_type_error_nr(sc, wrap_string(sc, "complex-vector fill!", 20), 2, obj, sc->type_names[T_COMPLEX]); + complex_vector_fill(vec, s7_to_c_complex(obj)); + break; + case T_VECTOR: + default: + t_vector_fill(vec, obj); + } } -s7_pointer -s7i_make_simple_complex_vector (s7_scheme* sc, s7_int len) { - return (make_simple_complex_vector (sc, len)); +s7_pointer s7i_make_simple_complex_vector(s7_scheme *sc, s7_int len) +{ + return(make_simple_complex_vector(sc, len)); } -s7_complex -s7i_to_c_complex (s7_pointer z) { - return (s7_to_c_complex (z)); +s7_complex s7i_to_c_complex(s7_pointer z) +{ + return(s7_to_c_complex(z)); } -s7_pointer -s7i_vector_fill_1 (s7_scheme* sc, s7_pointer caller, s7_pointer args) { - const s7_pointer vect= car (args); - s7_pointer fill; +s7_pointer s7i_vector_fill_1(s7_scheme *sc, s7_pointer caller, s7_pointer args) +{ + const s7_pointer vect = car(args); + s7_pointer fill; - if (!is_any_vector (vect)) { - if_method_exists_return_value (sc, vect, 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" - */ - wrong_type_error_nr (sc, caller, 1, vect, sc->type_names[T_VECTOR]); - } - if (is_immutable_vector (vect)) - immutable_object_error_nr ( - sc, set_elist_3 (sc, immutable_error_string, caller, vect)); - - fill= cadr (args); - if ((is_typed_t_vector (vect)) && - (typed_vector_typer_call (sc, vect, set_plist_1 (sc, fill)) == sc->F)) { - const char* tstr= make_type_name (sc, typed_vector_typer_name (sc, vect), - indefinite_article); - wrong_type_error_nr (sc, wrap_string (sc, "vector fill!", 12), 2, fill, - wrap_string (sc, tstr, safe_strlen (tstr))); - } - if (is_float_vector (vect)) { - if (!is_real (fill)) /* possibly a bignum */ - return ( - method_or_bust (sc, fill, caller, args, sc->type_names[T_REAL], 2)); - } - else if ((is_int_vector (vect)) || (is_byte_vector (vect))) { - if (!s7_is_integer (fill)) - return (method_or_bust (sc, fill, caller, args, sc->type_names[T_INTEGER], - 2)); - if ((is_byte_vector (vect)) && - ((s7_integer_clamped_if_gmp (sc, fill) < 0) || - (s7_integer_clamped_if_gmp (sc, fill) > 255))) - error_nr ( - sc, sc->out_of_range_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, "~S second argument, ~S, should fit in an unsigned byte", - 54), - caller, fill)); - } - else if (is_complex_vector (vect)) { - if (!is_number (fill)) /* possibly a bignum */ - return (method_or_bust (sc, fill, caller, args, sc->type_names[T_COMPLEX], - 2)); - } - { - s7_int start= 0, end= vector_length (vect); - if (!is_null (cddr (args))) { - s7_pointer 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 (vect))) - s7_vector_fill (sc, vect, fill); - else if (is_t_vector (vect)) - for (s7_int i= start; i < end; i++) - vector_element (vect, i)= fill; - else if (is_int_vector (vect)) { - s7_int k= s7_integer_clamped_if_gmp (sc, fill); - if (k == 0) - memclr ((void*) (int_vector_ints (vect) + start), - (end - start) * sizeof (s7_int)); - else - for (s7_int i= start; i < end; i++) - int_vector (vect, i)= k; - } - else if (is_float_vector (vect)) { - const s7_double y= s7_real (fill); - if (y == 0.0) - memclr ((void*) (float_vector_floats (vect) + start), - (end - start) * sizeof (s7_double)); - else { - s7_double* orig= float_vector_floats (vect); - s7_int left= end - 8; - s7_int i = start; - while (i <= left) - LOOP_8 (orig[i++]= y); - for (; i < end; i++) - orig[i]= y; - } + if (!is_any_vector(vect)) + { + if_method_exists_return_value(sc, vect, 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" + */ + wrong_type_error_nr(sc, caller, 1, vect, sc->type_names[T_VECTOR]); } - else if (is_byte_vector (vect)) { - const uint8_t k= (uint8_t) s7_integer_clamped_if_gmp (sc, fill); - if (k == 0) - memclr ((void*) (byte_vector_bytes (vect) + start), end - start); - else - local_memset ((void*) (byte_vector_bytes (vect) + start), k, - end - start); /* unaligned */ + if (is_immutable_vector(vect)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, caller, vect)); + + fill = cadr(args); + if ((is_typed_t_vector(vect)) && + (typed_vector_typer_call(sc, vect, set_plist_1(sc, fill)) == sc->F)) + { + const char *tstr = make_type_name(sc, typed_vector_typer_name(sc, vect), indefinite_article); + wrong_type_error_nr(sc, wrap_string(sc, "vector fill!", 12), 2, fill, wrap_string(sc, tstr, safe_strlen(tstr))); } - else if (is_complex_vector (vect)) { - s7_complex cfill= s7_to_c_complex (fill); - for (s7_int i= start; i < end; i++) - complex_vector (vect, i)= cfill; + if (is_float_vector(vect)) + { + if (!is_real(fill)) /* possibly a bignum */ + return(method_or_bust(sc, fill, caller, args, sc->type_names[T_REAL], 2)); } - } - return (fill); + else + if ((is_int_vector(vect)) || (is_byte_vector(vect))) + { + if (!s7_is_integer(fill)) + return(method_or_bust(sc, fill, caller, args, sc->type_names[T_INTEGER], 2)); + if ((is_byte_vector(vect)) && + ((s7_integer_clamped_if_gmp(sc, fill) < 0) || (s7_integer_clamped_if_gmp(sc, fill) > 255))) + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "~S second argument, ~S, should fit in an unsigned byte", 54), caller, fill)); + } + else + if (is_complex_vector(vect)) + { + if (!is_number(fill)) /* possibly a bignum */ + return(method_or_bust(sc, fill, caller, args, sc->type_names[T_COMPLEX], 2)); + } + { + s7_int start = 0, end = vector_length(vect); + if (!is_null(cddr(args))) + { + s7_pointer 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(vect))) + s7_vector_fill(sc, vect, fill); + else + if (is_t_vector(vect)) + for (s7_int i = start; i < end; i++) vector_element(vect, i) = fill; + else + if (is_int_vector(vect)) + { + s7_int k = s7_integer_clamped_if_gmp(sc, fill); + if (k == 0) + memclr((void *)(int_vector_ints(vect) + start), (end - start) * sizeof(s7_int)); + else for (s7_int i = start; i < end; i++) int_vector(vect, i) = k; + } + else + if (is_float_vector(vect)) + { + const s7_double y = s7_real(fill); + if (y == 0.0) + memclr((void *)(float_vector_floats(vect) + start), (end - start) * sizeof(s7_double)); + else + { + s7_double *orig = float_vector_floats(vect); + s7_int left = end - 8; + s7_int i = start; + while (i <= left) + LOOP_8(orig[i++] = y); + for (; i < end; i++) + orig[i] = y; + }} + else + if (is_byte_vector(vect)) + { + const uint8_t k = (uint8_t)s7_integer_clamped_if_gmp(sc, fill); + if (k == 0) + memclr((void *)(byte_vector_bytes(vect) + start), end - start); + else local_memset((void *)(byte_vector_bytes(vect) + start), k, end - start); /* unaligned */ + } + else + if (is_complex_vector(vect)) + { + s7_complex cfill = s7_to_c_complex(fill); + for (s7_int i = start; i < end; i++) complex_vector(vect, i) = cfill; + }} + return(fill); } #if !WITH_PURE_S7 -/* -------------------------------- vector-fill! - * -------------------------------- */ -#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) +/* -------------------------------- vector-fill! -------------------------------- */ +#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) /* g_vector_fill is now defined in s7_liii_vector.c */ -/* -------------------------------- vector-append - * -------------------------------- */ -s7_pointer s7i_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 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= args; - 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, car (args), args)); - - for (int32_t i= 0; is_pair (p); p= cdr (p), i++) { - const s7_pointer vect= car (p); - if (!is_any_vector (vect)) { - if (has_active_methods (sc, vect)) { - const s7_pointer func= - find_method_with_let (sc, vect, sc->vector_append_symbol); - if (func != sc->undefined) { - s7_pointer lst, vec, new_vec, arglist= args; - if (i == 0) return (s7_apply_function (sc, func, args)); - sc->temp7= make_list ( - sc, i, sc->unused); /* we have to copy the arglist here */ - lst= sc->temp7; - for (int32_t k= 0; k < i; k++, arglist= cdr (arglist), lst= cdr (lst)) - set_car (lst, car (arglist)); - vec = g_vector_append (sc, sc->temp7); - new_vec= s7_apply_function (sc, func, set_ulist_1 (sc, vec, p)); - if ((S7_DEBUGGING) && (!is_pair (sc->temp7))) - fprintf (stderr, "%s[%d]: temp7: %s\n", __func__, __LINE__, - display (sc->temp7)); - sc->temp7= sc->unused; - return (new_vec); - } - } - wrong_type_error_nr (sc, sc->vector_append_symbol, i + 1, vect, - sc->type_names[T_VECTOR]); - } - } - return (s7i_vector_append (sc, args, type (car (args)), - sc->vector_append_symbol)); -} +/* -------------------------------- vector-append -------------------------------- */ +s7_pointer s7i_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 source, s7_pointer args); -static s7_pointer -vector_append_p_pp (s7_scheme* sc, s7_pointer v1, s7_pointer v2) { - s7_pointer val; - sc->temp7= list_2 (sc, v1, v2); /* ideally this list would be gc_protected, - avoiding temp7 (method call above) */ - val= g_vector_append (sc, sc->temp7); - if ((S7_DEBUGGING) && (!is_pair (sc->temp7))) - fprintf (stderr, "%s[%d]: temp7: %s\n", __func__, __LINE__, - display (sc->temp7)); - sc->temp7= sc->unused; - return (val); -} - -static s7_pointer -vector_append_p_ppp (s7_scheme* sc, s7_pointer v1, s7_pointer v2, - s7_pointer v3) { - s7_pointer val; - sc->temp7= list_3 (sc, v1, v2, v3); - val = g_vector_append (sc, sc->temp7); - if ((S7_DEBUGGING) && (!is_pair (sc->temp7))) - fprintf (stderr, "%s[%d]: temp7: %s\n", __func__, __LINE__, - display (sc->temp7)); - sc->temp7= sc->unused; - return (val); -} +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 = args; + 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, car(args), args)); + + for (int32_t i = 0; is_pair(p); p = cdr(p), i++) + { + const s7_pointer vect = car(p); + if (!is_any_vector(vect)) + { + if (has_active_methods(sc, vect)) + { + const s7_pointer func = find_method_with_let(sc, vect, sc->vector_append_symbol); + if (func != sc->undefined) + { + s7_pointer lst, vec, new_vec, arglist = args; + if (i == 0) + return(s7_apply_function(sc, func, args)); + sc->temp7 = make_list(sc, i, sc->unused); /* we have to copy the arglist here */ + lst = sc->temp7; + for (int32_t k = 0; k < i; k++, arglist = cdr(arglist), lst = cdr(lst)) + set_car(lst, car(arglist)); + vec = g_vector_append(sc, sc->temp7); + new_vec = s7_apply_function(sc, func, set_ulist_1(sc, vec, p)); + if ((S7_DEBUGGING) && (!is_pair(sc->temp7))) fprintf(stderr, "%s[%d]: temp7: %s\n", __func__, __LINE__, display(sc->temp7)); + sc->temp7 = sc->unused; + return(new_vec); + }} + wrong_type_error_nr(sc, sc->vector_append_symbol, i + 1, vect, sc->type_names[T_VECTOR]); + }} + return(s7i_vector_append(sc, args, type(car(args)), sc->vector_append_symbol)); +} + +/* vector_append_p_pp, vector_append_p_ppp migrated to s7_liii_vector.c */ #endif -/* -------------------------------- vector-ref|set! - * -------------------------------- */ -s7_pointer -s7_vector_ref (s7_scheme* sc, s7_pointer vec, s7_int index) { - if (index >= vector_length (vec)) - out_of_range_error_nr (sc, sc->vector_ref_symbol, int_two, - wrap_integer (sc, index), it_is_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 value) { - if (index >= vector_length (vec)) - out_of_range_error_nr (sc, sc->vector_set_symbol, int_two, - wrap_integer (sc, index), it_is_too_large_string); - if (is_typed_vector (vec)) - return (typed_vector_setter (sc, vec, index, value)); - vector_setter (vec) (sc, vec, index, T_Ext (value)); - return (value); +/* -------------------------------- vector-ref|set! -------------------------------- */ +s7_pointer s7_vector_ref(s7_scheme *sc, s7_pointer vec, s7_int index) +{ + if (index >= vector_length(vec)) + out_of_range_error_nr(sc, sc->vector_ref_symbol, int_two, wrap_integer(sc, index), it_is_too_large_string); + return(vector_getter(vec)(sc, vec, index)); } -s7_pointer* -s7_vector_elements (s7_pointer vec) { - return (vector_elements (vec)); +s7_pointer s7_vector_set(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value) +{ + if (index >= vector_length(vec)) + out_of_range_error_nr(sc, sc->vector_set_symbol, int_two, wrap_integer(sc, index), it_is_too_large_string); + if (is_typed_vector(vec)) + return(typed_vector_setter(sc, vec, index, value)); + vector_setter(vec)(sc, vec, index, T_Ext(value)); + return(value); } +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 (vec, index)); -} -s7_int -s7_int_vector_set (s7_pointer vec, s7_int index, s7_int value) { - int_vector (vec, index)= value; - return (value); -} +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(vec, index));} +s7_int s7_int_vector_set(s7_pointer vec, s7_int index, s7_int value) {int_vector(vec, index) = value; return(value);} -uint8_t* -s7_byte_vector_elements (s7_pointer vec) { - return (byte_vector_bytes (vec)); -} -uint8_t -s7_byte_vector_ref (s7_pointer vec, s7_int index) { - return (byte_vector (vec, index)); -} -uint8_t -s7_byte_vector_set (s7_pointer vec, s7_int index, uint8_t value) { - byte_vector (vec, index)= value; - return (value); -} +uint8_t *s7_byte_vector_elements(s7_pointer vec) {return(byte_vector_bytes(vec));} +uint8_t s7_byte_vector_ref(s7_pointer vec, s7_int index) {return(byte_vector(vec, index));} +uint8_t s7_byte_vector_set(s7_pointer vec, s7_int index, uint8_t value) {byte_vector(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 (vec, index)); -} -s7_double -s7_float_vector_set (s7_pointer vec, s7_int index, s7_double value) { - float_vector (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(vec, index));} +s7_double s7_float_vector_set(s7_pointer vec, s7_int index, s7_double value) {float_vector(vec, index) = value; return(value);} -s7_complex* -s7_complex_vector_elements (s7_pointer vec) { - return (complex_vector_complexes (vec)); -} -s7_complex -s7_complex_vector_ref (s7_pointer vec, s7_int index) { - return (complex_vector (vec, index)); -} -s7_complex -s7_complex_vector_set (s7_pointer vec, s7_int index, s7_complex value) { - complex_vector (vec, index)= value; - return (value); +s7_complex *s7_complex_vector_elements(s7_pointer vec) {return(complex_vector_complexes(vec));} +s7_complex s7_complex_vector_ref(s7_pointer vec, s7_int index) {return(complex_vector(vec, index));} +s7_complex s7_complex_vector_set(s7_pointer vec, s7_int index, s7_complex value) {complex_vector(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 lim = vector_ndims(vec); + if (lim > dims_size) lim = dims_size; + for (s7_int i = 0; i < lim; i++) dims[i] = vector_dimension(vec, i); + return(lim); + } + dims[0] = vector_length(vec); + return(1); } -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 lim= vector_ndims (vec); - if (lim > dims_size) lim= dims_size; - for (s7_int 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_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 lim = vector_ndims(vec); + if (lim > offs_size) lim = offs_size; + for (s7_int i = 0; i < lim; i++) offs[i] = vector_offset(vec, i); + return(lim); + } + offs[0] = 1; + return(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 lim= vector_ndims (vec); - if (lim > offs_size) lim= offs_size; - for (s7_int i= 0; i < lim; i++) - offs[i]= vector_offset (vec, i); - return (lim); - } - offs[0]= 1; - return (1); -} - -static s7_int -flatten_multivector_indices (s7_scheme* sc, s7_pointer vector, s7_int indices, - va_list ap) { - s7_int index; - const s7_int rank= vector_rank (vector); - if (rank != indices) { - va_end (ap); - wrong_number_of_arguments_error_nr ( - sc, "s7_vector_ref_n: wrong number of indices: ~A", 44, - wrap_integer (sc, indices)); - } - if (rank == 1) index= va_arg (ap, s7_int); - else { - s7_int i; - const s7_int* dimensions= vector_dimensions (vector); - const s7_int* offsets = vector_offsets (vector); - for (i= 0, index= 0; i < indices; i++) { - s7_int ind= va_arg (ap, s7_int); - if ((ind < 0) || (ind >= dimensions[i])) { - va_end (ap); - out_of_range_error_nr (sc, sc->vector_ref_symbol, wrap_integer (sc, i), - wrap_integer (sc, ind), - (ind < 0) ? it_is_negative_string - : it_is_too_large_string); - return (-1); - } - index+= (ind * offsets[i]); + +static s7_int flatten_multivector_indices(s7_scheme *sc, s7_pointer vector, s7_int indices, va_list ap) +{ + s7_int index; + const s7_int rank = vector_rank(vector); + if (rank != indices) + { + va_end(ap); + wrong_number_of_arguments_error_nr(sc, "s7_vector_ref_n: wrong number of indices: ~A", 44, wrap_integer(sc, indices)); } - } - va_end (ap); - return (index); + if (rank == 1) + index = va_arg(ap, s7_int); + else + { + s7_int i; + const s7_int *dimensions = vector_dimensions(vector); + const s7_int *offsets = vector_offsets(vector); + for (i = 0, index = 0; i < indices; i++) + { + s7_int ind = va_arg(ap, s7_int); + if ((ind < 0) || (ind >= dimensions[i])) + { + va_end(ap); + out_of_range_error_nr(sc, sc->vector_ref_symbol, wrap_integer(sc, i), wrap_integer(sc, ind), (ind < 0) ? it_is_negative_string : it_is_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; +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)); + 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; +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) { - const s7_int len= vector_length (vect); - if (len == 0) return (sc->nil); + 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) +{ + const s7_int len = vector_length(vect); + if (len == 0) return(sc->nil); if (len > sc->max_list_length) - error_nr (sc, sc->out_of_range_symbol, - set_elist_3 (sc, - wrap_string (sc, - "vector->list length, ~D, is greater " - "than (*s7* 'max-list-length), ~D", - 68), - wrap_integer (sc, len), - wrap_integer (sc, sc->max_list_length))); - begin_temp (sc->y, sc->nil); - gc_protect_via_stack (sc, vect); - check_free_heap_size (sc, 2 * len); - switch (type (vect)) { - case T_VECTOR: - for (s7_int i= len - 1; i >= 0; i--) - sc->y= cons_unchecked (sc, vector_element (vect, i), sc->y); - break; - case T_BYTE_VECTOR: - for (s7_int i= len - 1; i >= 0; i--) - sc->y= cons_unchecked (sc, small_int (byte_vector (vect, i)), sc->y); - break; - case T_INT_VECTOR: - for (s7_int i= len - 1; i >= 0; i--) - sc->y= cons_unchecked ( - sc, make_integer_unchecked (sc, int_vector (vect, i)), sc->y); - break; - case T_FLOAT_VECTOR: - for (s7_int i= len - 1; i >= 0; i--) - sc->y= cons_unchecked ( - sc, make_real_unchecked (sc, float_vector (vect, i)), sc->y); - break; - case T_COMPLEX_VECTOR: - for (s7_int i= len - 1; i >= 0; i--) { - s7_complex z= complex_vector (vect, i); - sc->y = cons_unchecked ( - sc, make_complex_unchecked (sc, creal (z), cimag (z)), sc->y); - } - break; - } - unstack_gc_protect (sc); - return_with_end_temp (sc->y); + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "vector->list length, ~D, is greater than (*s7* 'max-list-length), ~D", 68), + wrap_integer(sc, len), wrap_integer(sc, sc->max_list_length))); + begin_temp(sc->y, sc->nil); + gc_protect_via_stack(sc, vect); + check_free_heap_size(sc, 2 * len); + switch (type(vect)) + { + case T_VECTOR: + for (s7_int i = len - 1; i >= 0; i--) + sc->y = cons_unchecked(sc, vector_element(vect, i), sc->y); + break; + case T_BYTE_VECTOR: + for (s7_int i = len - 1; i >= 0; i--) + sc->y = cons_unchecked(sc, small_int(byte_vector(vect, i)), sc->y); + break; + case T_INT_VECTOR: + for (s7_int i = len - 1; i >= 0; i--) + sc->y = cons_unchecked(sc, make_integer_unchecked(sc, int_vector(vect, i)), sc->y); + break; + case T_FLOAT_VECTOR: + for (s7_int i = len - 1; i >= 0; i--) + sc->y = cons_unchecked(sc, make_real_unchecked(sc, float_vector(vect, i)), sc->y); + break; + case T_COMPLEX_VECTOR: + for (s7_int i = len - 1; i >= 0; i--) + { + s7_complex z = complex_vector(vect, i); + sc->y = cons_unchecked(sc, make_complex_unchecked(sc, creal(z), cimag(z)), sc->y); + } + break; + } + unstack_gc_protect(sc); + return_with_end_temp(sc->y); } -s7_pointer -s7_array_to_list (s7_scheme* sc, s7_int num_values, s7_pointer* array) { - if (num_values == 0) return (sc->nil); - begin_temp (sc->y, sc->nil); - check_free_heap_size (sc, num_values); - for (s7_int i= num_values - 1; i >= 0; i--) - sc->y= cons_unchecked (sc, array[i], sc->y); - if (sc->safety > no_safety) check_list_validity (sc, __func__, sc->y); - return_with_end_temp (sc->y); +s7_pointer s7_array_to_list(s7_scheme *sc, s7_int num_values, s7_pointer *array) +{ + if (num_values == 0) return(sc->nil); + begin_temp(sc->y, sc->nil); + check_free_heap_size(sc, num_values); + for (s7_int i = num_values - 1; i >= 0; i--) + sc->y = cons_unchecked(sc, array[i], sc->y); + if (sc->safety > no_safety) + check_list_validity(sc, __func__, sc->y); + return_with_end_temp(sc->y); } #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 start= 0, end; - const s7_pointer vec = car (args); - if (!is_any_vector (vec)) - return (sole_arg_method_or_bust (sc, vec, sc->vector_to_list_symbol, args, - sc->type_names[T_VECTOR])); - end= vector_length (vec); - if (!is_null (cdr (args))) { - s7_pointer 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); - } +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 start = 0, end; + const s7_pointer vec = car(args); + if (!is_any_vector(vec)) + return(sole_arg_method_or_bust(sc, vec, sc->vector_to_list_symbol, args, sc->type_names[T_VECTOR])); + end = vector_length(vec); + if (!is_null(cdr(args))) + { + s7_pointer 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) - error_nr ( - sc, sc->out_of_range_symbol, - set_elist_5 (sc, - wrap_string (sc, - "vector->list length ~D, (- ~D ~D), is " - "greater than (*s7* 'max-list-length), ~D", - 78), - wrap_integer (sc, end - start), wrap_integer (sc, end), - wrap_integer (sc, start), - wrap_integer (sc, sc->max_list_length))); - - check_free_heap_size (sc, end - start); - begin_temp (sc->temp6, sc->nil); - gc_protect_via_stack (sc, vec); - if (is_t_vector (vec)) - for (s7_int i= end - 1; i >= start; i--) - sc->temp6= cons_unchecked (sc, vector_element (vec, i), sc->temp6); - else - for (s7_int i= end - 1; i >= start; i--) - sc->temp6= - cons_unchecked (sc, vector_getter (vec) (sc, vec, i), sc->temp6); - unstack_gc_protect (sc); - return_with_end_temp (sc->temp6); -} - -static s7_pointer -vector_to_list_p_p (s7_scheme* sc, s7_pointer vec) { - if (!is_any_vector (vec)) - return (method_or_bust_p (sc, vec, sc->vector_to_list_symbol, - sc->type_names[T_VECTOR])); - return (s7_vector_to_list (sc, vec)); -} + error_nr(sc, sc->out_of_range_symbol, + set_elist_5(sc, wrap_string(sc, "vector->list length ~D, (- ~D ~D), is greater than (*s7* 'max-list-length), ~D", 78), + wrap_integer(sc, end - start), wrap_integer(sc, end), wrap_integer(sc, start), + wrap_integer(sc, sc->max_list_length))); + + check_free_heap_size(sc, end - start); + begin_temp(sc->temp6, sc->nil); + gc_protect_via_stack(sc, vec); + if (is_t_vector(vec)) + for (s7_int i = end - 1; i >= start; i--) sc->temp6 = cons_unchecked(sc, vector_element(vec, i), sc->temp6); + else for (s7_int i = end - 1; i >= start; i--) sc->temp6 = cons_unchecked(sc, vector_getter(vec)(sc, vec, i), sc->temp6); + unstack_gc_protect(sc); + return_with_end_temp(sc->temp6); +} + +/* vector_to_list_p_p migrated to s7_liii_vector.c */ #endif + /* -------------------------------- vector -------------------------------- */ /* g_vector, g_vector_2, g_vector_3 are now defined in s7_liii_vector.c */ -static inline s7_pointer -vector_p_pp (s7_scheme* sc, s7_pointer p1, s7_pointer p2) { - s7_pointer vec = make_simple_vector (sc, 2); - vector_element (vec, 0)= p1; - vector_element (vec, 1)= p2; - return (vec); +static inline s7_pointer vector_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) +{ + s7_pointer vec = make_simple_vector(sc, 2); + vector_element(vec, 0) = p1; + vector_element(vec, 1) = p2; + return(vec); } -static s7_pointer -vector_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer unused_expr) { - if (args == 2) return (sc->vector_2); - return ((args == 3) ? sc->vector_3 : func); +static s7_pointer vector_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr) +{ + if (args == 2) return(sc->vector_2); + return((args == 3) ? sc->vector_3 : func); } -/* -------------------------------- float-vector - * -------------------------------- */ + +/* -------------------------------- float-vector -------------------------------- */ /* g_float_vector is now defined in s7_liii_vector.c */ -static s7_pointer -float_vector_p_d (s7_scheme* sc, s7_double x) { - s7_pointer vec = make_simple_float_vector (sc, 1); - float_vector (vec, 0)= x; - return (vec); +static s7_pointer float_vector_p_d(s7_scheme *sc, s7_double x) +{ + s7_pointer vec = make_simple_float_vector(sc, 1); + float_vector(vec, 0) = x; + return(vec); } -static s7_pointer -float_vector_p_i (s7_scheme* sc, s7_int x) /* thash */ +static s7_pointer float_vector_p_i(s7_scheme *sc, s7_int x) /* thash */ { - s7_pointer vec = make_simple_float_vector (sc, 1); - float_vector (vec, 0)= (s7_double) x; - return (vec); + s7_pointer vec = make_simple_float_vector(sc, 1); + float_vector(vec, 0) = (s7_double)x; + return(vec); } /* p_dd case doesn't get any hits */ -/* -------------------------------- int-vector -------------------------------- - */ + +/* -------------------------------- int-vector -------------------------------- */ /* g_int_vector is now defined in s7_liii_vector.c */ -static s7_pointer -int_vector_p_i (s7_scheme* sc, s7_int x) { - s7_pointer vec = make_simple_int_vector (sc, 1); - int_vector (vec, 0)= x; - return (vec); +static s7_pointer int_vector_p_i(s7_scheme *sc, s7_int x) +{ + s7_pointer vec = make_simple_int_vector(sc, 1); + int_vector(vec, 0) = x; + return(vec); } /* p_ii case doesn't get any hits */ -/* -------------------------------- byte-vector -------------------------------- - */ + +/* -------------------------------- byte-vector -------------------------------- */ /* g_byte_vector is now defined in s7_liii_vector.c */ -/* -------------------------------- complex-vector - * -------------------------------- */ +/* -------------------------------- complex-vector -------------------------------- */ /* g_complex_vector is now defined in s7_liii_vector.c */ #if !WITH_PURE_S7 -/* -------------------------------- list->vector - * -------------------------------- */ +/* -------------------------------- list->vector -------------------------------- */ /* g_list_to_vector is now defined in s7_liii_vector.c */ -/* -------------------------------- vector-length - * -------------------------------- */ -/* g_vector_length, vector_length_i_7p, vector_length_p_p are now defined in - * s7_liii_vector.c */ +/* -------------------------------- vector-length -------------------------------- */ +/* g_vector_length, vector_length_i_7p, vector_length_p_p are now defined in s7_liii_vector.c */ #endif -/* -------------------------------- subvector subvector? subvector-vector - * subvector-position -------------------------------- */ -static bool -s7_is_subvector (s7_pointer vec) { - return ((is_any_vector (vec)) && (is_subvector (vec))); -} + +/* -------------------------------- subvector subvector? subvector-vector subvector-position -------------------------------- */ +static bool s7_is_subvector(s7_pointer vec) {return((is_any_vector(vec)) && (is_subvector(vec)));} /* g_is_subvector is now defined in s7_liii_vector.c */ /* g_subvector_position is now defined in s7_liii_vector.c */ /* g_subvector_vector is now defined in s7_liii_vector.c */ -static s7_pointer -subvector (s7_scheme* sc, s7_pointer vect, s7_int skip_dims, s7_int index) { - const s7_int dims= vector_ndims (vect) - skip_dims; - s7_pointer subvect; - new_cell (sc, subvect, - ((full_type (vect) & (~T_UNHEAP)) & (~T_COLLECTED)) | T_SUBVECTOR | - T_SAFE_PROCEDURE); /* no T_UNHEAP because we're new but vect - might be unheaped */ - vector_length (subvect) = 0; - vector_block (subvect) = mallocate_empty_block (sc); - any_vector_elements (subvect)= NULL; - vector_getter (subvect) = vector_getter (vect); - vector_setter (subvect) = vector_setter (vect); - if (dims > 1) { - vdims_t* vd= (vdims_t*) mallocate_block (sc); +static s7_pointer subvector(s7_scheme *sc, s7_pointer vect, s7_int skip_dims, s7_int index) +{ + const s7_int dims = vector_ndims(vect) - skip_dims; + s7_pointer subvect; + new_cell(sc, subvect, ((full_type(vect) & (~T_UNHEAP)) & (~T_COLLECTED)) | T_SUBVECTOR | T_SAFE_PROCEDURE); /* no T_UNHEAP because we're new but vect might be unheaped */ + vector_length(subvect) = 0; + vector_block(subvect) = mallocate_empty_block(sc); + any_vector_elements(subvect) = NULL; + vector_getter(subvect) = vector_getter(vect); + vector_setter(subvect) = vector_setter(vect); + if (dims > 1) + { + vdims_t *vd = (vdims_t *)mallocate_block(sc); #if S7_DEBUGGING - sc->blocks_mallocated[BLOCK_LIST]++; + sc->blocks_mallocated[BLOCK_LIST]++; #endif - vdims_rank (vd) = dims; - vdims_dims (vd) = (s7_int*) (vector_dimensions (vect) + skip_dims); - vdims_offsets (vd) = (s7_int*) (vector_offsets (vect) + skip_dims); - vdims_original (vd)= vect; - vector_elements_should_be_freed (vd)= false; - vector_set_dimension_info (subvect, vd); - } - else { - vector_set_dimension_info (subvect, NULL); - subvector_set_vector (subvect, vect); - } + vdims_rank(vd) = dims; + vdims_dims(vd) = (s7_int *)(vector_dimensions(vect) + skip_dims); + vdims_offsets(vd) = (s7_int *)(vector_offsets(vect) + skip_dims); + vdims_original(vd) = vect; + vector_elements_should_be_freed(vd) = false; + vector_set_dimension_info(subvect, vd); + } + else + { + vector_set_dimension_info(subvect, NULL); + subvector_set_vector(subvect, vect); + } - if (is_t_vector (vect)) mark_function[T_VECTOR]= mark_vector_possibly_shared; - else mark_function[type (vect)]= mark_int_or_float_vector_possibly_shared; - - vector_length (subvect)= (skip_dims > 0) ? vector_offset (vect, skip_dims - 1) - : vector_length (vect); - if (is_int_vector (vect)) - int_vector_ints (subvect)= (s7_int*) (int_vector_ints (vect) + index); - else if (is_float_vector (vect)) - float_vector_floats (subvect)= - (s7_double*) (float_vector_floats (vect) + index); - else if (is_t_vector (vect)) - vector_elements (subvect)= (s7_pointer*) (vector_elements (vect) + index); - else if (is_byte_vector (subvect)) - byte_vector_bytes (subvect)= (uint8_t*) (byte_vector_bytes (vect) + index); + if (is_t_vector(vect)) + mark_function[T_VECTOR] = mark_vector_possibly_shared; + else mark_function[type(vect)] = mark_int_or_float_vector_possibly_shared; + + vector_length(subvect) = (skip_dims > 0) ? vector_offset(vect, skip_dims - 1) : vector_length(vect); + if (is_int_vector(vect)) + int_vector_ints(subvect) = (s7_int *)(int_vector_ints(vect) + index); else - complex_vector_complexes (subvect)= - (s7_complex*) (complex_vector_complexes (vect) + index); - add_multivector (sc, subvect); - return (subvect); -} - -static inline vdims_t* -list_to_vdims (s7_scheme* sc, s7_pointer lst) { - s7_int * ds, *os; - const s7_int len= proper_list_length (lst); - vdims_t* vd = (vdims_t*) inline_mallocate (sc, len * 2 * sizeof (s7_int)); - vdims_rank (vd) = len; - vdims_offsets (vd) = (s7_int*) (vdims_dims (vd) + len); - vector_elements_should_be_freed (vd)= false; - ds = vdims_dims (vd); - os = vdims_offsets (vd); - for (s7_int i= 0; is_pair (lst); i++, lst= cdr (lst)) - ds[i]= s7_integer_clamped_if_gmp (sc, car (lst)); - for (s7_int i= len - 1, offset= 1; i >= 0; i--) { - os[i]= offset; - offset*= ds[i]; - } - return (vd); + if (is_float_vector(vect)) + float_vector_floats(subvect) = (s7_double *)(float_vector_floats(vect) + index); + else + if (is_t_vector(vect)) + vector_elements(subvect) = (s7_pointer *)(vector_elements(vect) + index); + else + if (is_byte_vector(subvect)) + byte_vector_bytes(subvect) = (uint8_t *)(byte_vector_bytes(vect) + index); + else complex_vector_complexes(subvect) = (s7_complex *)(complex_vector_complexes(vect) + index); + add_multivector(sc, subvect); + return(subvect); +} + +static inline vdims_t *list_to_vdims(s7_scheme *sc, s7_pointer lst) +{ + s7_int *ds, *os; + const s7_int len = proper_list_length(lst); + vdims_t *vd = (vdims_t *)inline_mallocate(sc, len * 2 * sizeof(s7_int)); + vdims_rank(vd) = len; + vdims_offsets(vd) = (s7_int *)(vdims_dims(vd) + len); + vector_elements_should_be_freed(vd) = false; + ds = vdims_dims(vd); + os = vdims_offsets(vd); + for (s7_int i = 0; is_pair(lst); i++, lst = cdr(lst)) + ds[i] = s7_integer_clamped_if_gmp(sc, car(lst)); + for (s7_int i = len - 1, offset = 1; i >= 0; i--) + { + os[i] = offset; + offset *= ds[i]; + } + return(vd); } -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 \ +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)) + #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)) */ - const s7_pointer orig= car (args); - vdims_t* vd = NULL; - s7_int new_len, orig_len, offset= 0; + const s7_pointer orig = car(args); + vdims_t *vd = NULL; + s7_int new_len, orig_len, offset = 0; - if (!is_any_vector (orig)) - return (method_or_bust (sc, orig, sc->subvector_symbol, args, - sc->type_names[T_VECTOR], 1)); + if (!is_any_vector(orig)) + return(method_or_bust(sc, orig, sc->subvector_symbol, args, sc->type_names[T_VECTOR], 1)); - orig_len= vector_length (orig); + orig_len = vector_length(orig); new_len = orig_len; - if (is_pair (cdr (args))) /* get start point in vector */ - { - const s7_pointer start= cadr (args); - if (!s7_is_integer (start)) - return (method_or_bust (sc, start, sc->subvector_symbol, args, - sc->type_names[T_INTEGER], 2)); - offset= s7_integer_clamped_if_gmp (sc, start); - if ((offset < 0) || (offset > orig_len)) /* we need this if, for example, - offset == 9223372036854775807 */ - out_of_range_error_nr (sc, sc->subvector_symbol, int_two, start, - (offset < 0) ? it_is_negative_string - : it_is_too_large_string); - new_len-= offset; - - if (is_pair (cddr (args))) /* get end point in vector */ - { - const s7_pointer end= caddr (args); - s7_int new_end; - if (!s7_is_integer (end)) - return (method_or_bust (sc, end, sc->subvector_symbol, args, - sc->type_names[T_INTEGER], 3)); - new_end= s7_integer_clamped_if_gmp (sc, end); - if ((new_end < 0) || (new_end > orig_len)) - out_of_range_error_nr (sc, sc->subvector_symbol, int_three, end, - (new_end < 0) ? it_is_negative_string - : it_is_too_large_string); - if (offset > new_end) - out_of_range_error_nr (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))) /* get new dimensions */ - { - const s7_pointer dims= cadddr (args); - if ((is_null (dims)) || (!s7_is_proper_list (sc, dims))) - return (method_or_bust (sc, dims, sc->subvector_symbol, args, - sc->type_names[T_PAIR], 4)); - - for (s7_pointer dim_list= dims; is_pair (dim_list); - dim_list = cdr (dim_list)) - if ((!s7_is_integer ( - car (dim_list))) || /* (subvector v '((1 2) (3 4))) */ - (s7_integer_clamped_if_gmp (sc, car (dim_list)) > orig_len) || - (s7_integer_clamped_if_gmp (sc, car (dim_list)) < 0)) - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_1 ( - sc, wrap_string ( - sc, "a subvector must fit in the original vector", - 43))); - - vd= list_to_vdims (sc, dims); - if (vdims_rank (vd) > sc->max_vector_dimensions) { - liberate (sc, vd); - error_nr ( - sc, sc->out_of_range_symbol, - set_elist_3 ( - sc, - wrap_string (sc, - "subvector specifies too many dimensions: '~S, " - "but (*s7* 'max-vector-dimensions) is ~D", - 85), - dims, wrap_integer (sc, sc->max_vector_dimensions))); - } - new_len= vdims_dims (vd)[0]; - for (s7_int i= 1; i < vdims_rank (vd); i++) - new_len*= vdims_dims (vd)[i]; - if (new_len != new_end - offset) { - liberate (sc, vd); /* 14-Sep-23 */ - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_4 ( - sc, - wrap_string (sc, - "subvector dimensional length, ~D, does not " - "match the start and end positions: ~S to ~S~%", - 88), - wrap_integer (sc, new_len), start, end)); - } - vdims_original (vd)= orig; - } - } - } - - if (is_t_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 */ + if (is_pair(cdr(args))) /* get start point in vector */ + { + const s7_pointer start = cadr(args); + if (!s7_is_integer(start)) + return(method_or_bust(sc, start, sc->subvector_symbol, args, sc->type_names[T_INTEGER], 2)); + offset = s7_integer_clamped_if_gmp(sc, start); + if ((offset < 0) || (offset > orig_len)) /* we need this if, for example, offset == 9223372036854775807 */ + out_of_range_error_nr(sc, sc->subvector_symbol, int_two, start, (offset < 0) ? it_is_negative_string : it_is_too_large_string); + new_len -= offset; + + if (is_pair(cddr(args))) /* get end point in vector */ + { + const s7_pointer end = caddr(args); + s7_int new_end; + if (!s7_is_integer(end)) + return(method_or_bust(sc, end, sc->subvector_symbol, args, sc->type_names[T_INTEGER], 3)); + new_end = s7_integer_clamped_if_gmp(sc, end); + if ((new_end < 0) || (new_end > orig_len)) + out_of_range_error_nr(sc, sc->subvector_symbol, int_three, end, (new_end < 0) ? it_is_negative_string : it_is_too_large_string); + if (offset > new_end) + out_of_range_error_nr(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))) /* get new dimensions */ + { + const s7_pointer dims = cadddr(args); + if ((is_null(dims)) || + (!s7_is_proper_list(sc, dims))) + return(method_or_bust(sc, dims, sc->subvector_symbol, args, sc->type_names[T_PAIR], 4)); + + for (s7_pointer dim_list = dims; is_pair(dim_list); dim_list = cdr(dim_list)) + if ((!s7_is_integer(car(dim_list))) || /* (subvector v '((1 2) (3 4))) */ + (s7_integer_clamped_if_gmp(sc, car(dim_list)) > orig_len) || + (s7_integer_clamped_if_gmp(sc, car(dim_list)) < 0)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_1(sc, wrap_string(sc, "a subvector must fit in the original vector", 43))); + + vd = list_to_vdims(sc, dims); + if (vdims_rank(vd) > sc->max_vector_dimensions) + { + liberate(sc, vd); + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "subvector specifies too many dimensions: '~S, but (*s7* 'max-vector-dimensions) is ~D", 85), + dims, wrap_integer(sc, sc->max_vector_dimensions))); + } + new_len = vdims_dims(vd)[0]; + for (s7_int i = 1; i < vdims_rank(vd); i++) new_len *= vdims_dims(vd)[i]; + if (new_len != new_end - offset) + { + liberate(sc, vd); /* 14-Sep-23 */ + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "subvector dimensional length, ~D, does not match the start and end positions: ~S to ~S~%", 88), + wrap_integer(sc, new_len), start, end)); + } + vdims_original(vd) = orig; + }}} + + if (is_t_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 */ { s7_pointer subvect; - new_cell (sc, subvect, - ((full_type (orig) & (~T_UNHEAP)) & (~T_COLLECTED)) | - T_SUBVECTOR | T_SAFE_PROCEDURE); - vector_block (subvect)= mallocate_empty_block (sc); - vector_set_dimension_info (subvect, vd); - if (!vd) subvector_set_vector (subvect, orig); - vector_length (subvect)= new_len; /* might be less than original length */ - if ((new_len == 0) && (is_t_vector (orig))) - set_has_simple_elements (subvect); - vector_getter (subvect)= vector_getter (orig); - vector_setter (subvect)= vector_setter (orig); - - if (is_int_vector (orig)) - int_vector_ints (subvect)= (s7_int*) (int_vector_ints (orig) + offset); - else if (is_float_vector (orig)) - float_vector_floats (subvect)= - (s7_double*) (float_vector_floats (orig) + offset); - else if (is_t_vector (orig)) - vector_elements (subvect)= - (s7_pointer*) (vector_elements (orig) + offset); - else if (is_byte_vector (orig)) - byte_vector_bytes (subvect)= - (uint8_t*) (byte_vector_bytes (orig) + offset); + new_cell(sc, subvect, ((full_type(orig) & (~T_UNHEAP)) & (~T_COLLECTED)) | T_SUBVECTOR | T_SAFE_PROCEDURE); + vector_block(subvect) = mallocate_empty_block(sc); + vector_set_dimension_info(subvect, vd); + if (!vd) subvector_set_vector(subvect, orig); + vector_length(subvect) = new_len; /* might be less than original length */ + if ((new_len == 0) && (is_t_vector(orig))) set_has_simple_elements(subvect); + vector_getter(subvect) = vector_getter(orig); + vector_setter(subvect) = vector_setter(orig); + + if (is_int_vector(orig)) + int_vector_ints(subvect) = (s7_int *)(int_vector_ints(orig) + offset); else - complex_vector_complexes (subvect)= - (s7_complex*) (complex_vector_complexes (orig) + offset); - add_multivector (sc, subvect); - return (subvect); + if (is_float_vector(orig)) + float_vector_floats(subvect) = (s7_double *)(float_vector_floats(orig) + offset); + else + if (is_t_vector(orig)) + vector_elements(subvect) = (s7_pointer *)(vector_elements(orig) + offset); + else + if (is_byte_vector(orig)) + byte_vector_bytes(subvect) = (uint8_t *)(byte_vector_bytes(orig) + offset); + else complex_vector_complexes(subvect) = (s7_complex *)(complex_vector_complexes(orig) + offset); + add_multivector(sc, subvect); + return(subvect); } } -/* -------------------------------- vector-ref -------------------------------- - */ -s7_pointer -s7i_vector_ref_1 (s7_scheme* sc, s7_pointer vect, s7_pointer indices) { - s7_int index= 0; - if (vector_length (vect) == 0) - out_of_range_error_nr (sc, sc->vector_ref_symbol, int_one, vect, - it_is_too_large_string); - - if (vector_rank (vect) > 1) { - s7_int i; - s7_pointer index_list; - for (index_list= indices, i= 0; - (is_pair (index_list)) && (i < vector_ndims (vect)); - index_list= cdr (index_list), i++) { - s7_int n; - const s7_pointer ind= car (index_list); - if (!s7_is_integer (ind)) - return (method_or_bust (sc, ind, sc->vector_ref_symbol, - set_ulist_1 (sc, vect, indices), - sc->type_names[T_INTEGER], i + 2)); - n= s7_integer_clamped_if_gmp (sc, ind); - if ((n < 0) || (n >= vector_dimension (vect, i))) - out_of_range_error_nr ( - sc, sc->vector_ref_symbol, wrap_integer (sc, i + 2), ind, - (n < 0) ? it_is_negative_string : it_is_too_large_string); - index+= n * vector_offset (vect, i); - } - if (is_not_null (index_list)) { - s7_pointer nv; - if (!is_t_vector (vect)) - error_nr (sc, sc->wrong_number_of_args_symbol, - set_elist_3 ( - sc, wrap_string (sc, "~S: too many indices: ~S", 24), - sc->vector_ref_symbol, copy_proper_list (sc, indices))); - nv= vector_element (vect, index); - return (implicit_index (sc, nv, index_list)); - } - /* if not enough indices, return a subvector covering whatever is left */ - if (i < vector_ndims (vect)) return (subvector (sc, vect, i, index)); - } - else { - const s7_pointer ind= 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 (ind)) - return (method_or_bust (sc, ind, sc->vector_ref_symbol, - set_ulist_1 (sc, vect, indices), - sc->type_names[T_INTEGER], 2)); - index= s7_integer_clamped_if_gmp (sc, ind); - if ((index < 0) || (index >= vector_length (vect))) - out_of_range_error_nr (sc, sc->vector_ref_symbol, int_two, ind, - (index < 0) ? it_is_negative_string - : it_is_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_t_vector (vect)) - error_nr (sc, sc->wrong_number_of_args_symbol, - set_elist_3 ( - sc, wrap_string (sc, "~S: too many indices: ~S", 24), - sc->vector_ref_symbol, copy_proper_list (sc, indices))); - nv= vector_element (vect, index); - return (implicit_pair_index_checked (sc, vect, nv, indices)); + +/* -------------------------------- vector-ref -------------------------------- */ +s7_pointer s7i_vector_ref_1(s7_scheme *sc, s7_pointer vect, s7_pointer indices) +{ + s7_int index = 0; + if (vector_length(vect) == 0) + out_of_range_error_nr(sc, sc->vector_ref_symbol, int_one, vect, it_is_too_large_string); + + if (vector_rank(vect) > 1) + { + s7_int i; + s7_pointer index_list; + for (index_list = indices, i = 0; (is_pair(index_list)) && (i < vector_ndims(vect)); index_list = cdr(index_list), i++) + { + s7_int n; + const s7_pointer ind = car(index_list); + if (!s7_is_integer(ind)) + return(method_or_bust(sc, ind, sc->vector_ref_symbol, set_ulist_1(sc, vect, indices), sc->type_names[T_INTEGER], i + 2)); + n = s7_integer_clamped_if_gmp(sc, ind); + if ((n < 0) || (n >= vector_dimension(vect, i))) + out_of_range_error_nr(sc, sc->vector_ref_symbol, wrap_integer(sc, i + 2), ind, (n < 0) ? it_is_negative_string : it_is_too_large_string); + index += n * vector_offset(vect, i); + } + if (is_not_null(index_list)) + { + s7_pointer nv; + if (!is_t_vector(vect)) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, wrap_string(sc, "~S: too many indices: ~S", 24), sc->vector_ref_symbol, copy_proper_list(sc, indices))); + nv = vector_element(vect, index); + return(implicit_index(sc, nv, index_list)); + } + /* if not enough indices, return a subvector covering whatever is left */ + if (i < vector_ndims(vect)) + return(subvector(sc, vect, i, index)); } - } - return ((vector_getter (vect)) (sc, vect, index)); + else + { + const s7_pointer ind = 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(ind)) + return(method_or_bust(sc, ind, sc->vector_ref_symbol, set_ulist_1(sc, vect, indices), sc->type_names[T_INTEGER], 2)); + index = s7_integer_clamped_if_gmp(sc, ind); + if ((index < 0) || (index >= vector_length(vect))) + out_of_range_error_nr(sc, sc->vector_ref_symbol, int_two, ind, (index < 0) ? it_is_negative_string : it_is_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_t_vector(vect)) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, wrap_string(sc, "~S: too many indices: ~S", 24), sc->vector_ref_symbol, copy_proper_list(sc, indices))); + nv = vector_element(vect, index); + return(implicit_pair_index_checked(sc, vect, nv, indices)); + }} + return((vector_getter(vect))(sc, vect, index)); } /* g_vector_ref is now defined in s7_liii_vector.c */ -static s7_pointer -vector_ref_p_pi (s7_scheme* sc, s7_pointer vec, s7_int index) { - if ((!is_t_vector (vec)) || (vector_rank (vec) > 1) || (index < 0) || - (index >= vector_length (vec))) - return (g_vector_ref (sc, set_plist_2 (sc, vec, make_integer (sc, index)))); - return (vector_element (vec, index)); -} +/* vector_ref_p_pi, vector_ref_p_pi_unchecked, t_vector_ref_p_pi_unchecked, + vector_ref_p_pii, vector_ref_p_pii_direct, t_vector_ref_p_pi_direct + migrated to s7_liii_vector.c */ -static s7_pointer -vector_ref_p_pi_unchecked ( - s7_scheme* sc, s7_pointer vec, - s7_int index) /* callable but just barely (tgsl.scm) */ +s7_pointer s7i_vector_ref_p_pp(s7_scheme *sc, s7_pointer vec, s7_pointer ind) { - if ((index < 0) || (index >= vector_length (vec))) - out_of_range_error_nr ( - sc, sc->vector_ref_symbol, int_two, wrap_integer (sc, index), - (index < 0) ? it_is_negative_string : it_is_too_large_string); - return (vector_getter (vec) (sc, vec, index)); + s7_int index; + if ((!is_t_vector(vec)) || + (vector_rank(vec) != 1) || + (!s7_is_integer(ind))) + return(g_vector_ref(sc, set_plist_2(sc, vec, ind))); + index = s7_integer_clamped_if_gmp(sc, ind); + if ((index < 0) || (index >= vector_length(vec))) + out_of_range_error_nr(sc, sc->vector_ref_symbol, int_two, ind, (index < 0) ? it_is_negative_string : it_is_too_large_string); + return(vector_element(vec, index)); } -static s7_pointer -t_vector_ref_p_pi_unchecked (s7_scheme* sc, s7_pointer vec, s7_int index) { - if ((index < 0) || (index >= vector_length (vec))) - out_of_range_error_nr ( - sc, sc->vector_ref_symbol, int_two, wrap_integer (sc, index), - (index < 0) ? it_is_negative_string : it_is_too_large_string); - return (vector_element (vec, index)); -} +/* g_vector_ref_2 is now defined in s7_liii_vector.c */ -static s7_pointer -vector_ref_p_pii (s7_scheme* sc, s7_pointer vec, s7_int i1, s7_int i2) { - if ((!is_any_vector (vec)) || (vector_rank (vec) != 2) || (i1 < 0) || - (i2 < 0) || (i1 >= vector_dimension (vec, 0)) || - (i2 >= vector_dimension (vec, 1))) - return (g_vector_ref (sc, set_plist_3 (sc, vec, make_integer (sc, i1), - make_integer_unchecked (sc, i2)))); - return (vector_getter (vec) (sc, vec, i2 + (i1 * vector_offset (vec, 0)))); +/* -------- s7i_ bridges for vector p_p migration to s7_liii_vector.c -------- */ +static s7_pointer g_vector_set(s7_scheme *sc, s7_pointer args); +bool s7i_is_any_vector(s7_pointer p) {return(is_any_vector(p));} +bool s7i_is_t_vector(s7_pointer p) {return(is_t_vector(p));} +bool s7i_is_typed_vector(s7_pointer p) {return(is_typed_vector(p));} +bool s7i_is_immutable_vector(s7_pointer p) {return(is_immutable_vector(p));} +s7_pointer s7i_vector_element(s7_pointer p, s7_int i) {return(vector_element(p, i));} +void s7i_vector_element_set(s7_pointer p, s7_int i, s7_pointer v) {vector_element(p, i) = v;} +s7_pointer s7i_vector_getter_ref(s7_scheme *sc, s7_pointer p, s7_int i) {return(vector_getter(p)(sc, p, i));} +s7_pointer s7i_vector_setter_set(s7_scheme *sc, s7_pointer p, s7_int i, s7_pointer v) {vector_setter(p)(sc, p, i, v);} +s7_pointer s7i_typed_vector_setter(s7_scheme *sc, s7_pointer p, s7_int i, s7_pointer v) {return(typed_vector_setter(sc, p, i, v));} +s7_int s7i_vector_offset(s7_pointer p, s7_int i) {return(vector_offset(p, i));} +s7_pointer s7i_small_int(s7_int val) {return(small_int(val));} +uint8_t s7i_byte_vector_element(s7_pointer p, s7_int i) {return(byte_vector(p, i));} +void s7i_byte_vector_element_set(s7_pointer p, s7_int i, uint8_t v) {byte_vector(p, i) = v;} +s7_pointer s7i_g_vector_set(s7_scheme *sc, s7_pointer plist) {return(g_vector_set(sc, plist));} +s7_pointer s7i_set_plist_4(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4) {return(set_plist_4(sc, x1, x2, x3, x4));} +s7_pointer s7i_vector_append_2(s7_scheme *sc, s7_pointer v1, s7_pointer v2) +{ + s7_pointer val; + sc->temp7 = list_2(sc, v1, v2); /* ideally this list would be gc_protected, avoiding temp7 (method call above) */ + val = g_vector_append(sc, sc->temp7); + sc->temp7 = sc->unused; + return(val); } - -static s7_pointer -vector_ref_p_pii_direct (s7_scheme* sc, s7_pointer vec, s7_int i1, s7_int i2) { - if ((i1 < 0) || (i2 < 0) || (i1 >= vector_dimension (vec, 0)) || - (i2 >= vector_dimension (vec, 1))) - return (g_vector_ref (sc, set_plist_3 (sc, vec, make_integer (sc, i1), - make_integer_unchecked (sc, i2)))); - return (vector_element (vec, i2 + (i1 * vector_offset (vec, 0)))); +s7_pointer s7i_vector_append_3(s7_scheme *sc, s7_pointer v1, s7_pointer v2, s7_pointer v3) +{ + s7_pointer val; + sc->temp7 = list_3(sc, v1, v2, v3); + val = g_vector_append(sc, sc->temp7); + sc->temp7 = sc->unused; + return(val); } -static s7_pointer -t_vector_ref_p_pi_direct (s7_scheme* unused_sc, s7_pointer vec, s7_int index) { - return (vector_element (vec, index)); +static s7_pointer g_vector_ref_3(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer vec = car(args); + s7_pointer 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_clamped_if_gmp(sc, i1); + iy = s7_integer_clamped_if_gmp(sc, i2); + if ((ix >= 0) && (iy >= 0) && + (ix < vector_dimension(vec, 0)) && (iy < vector_dimension(vec, 1))) + { + s7_int 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)); } -s7_pointer -s7i_vector_ref_p_pp (s7_scheme* sc, s7_pointer vec, s7_pointer ind) { - s7_int index; - if ((!is_t_vector (vec)) || (vector_rank (vec) != 1) || - (!s7_is_integer (ind))) - return (g_vector_ref (sc, set_plist_2 (sc, vec, ind))); - index= s7_integer_clamped_if_gmp (sc, ind); - if ((index < 0) || (index >= vector_length (vec))) - out_of_range_error_nr (sc, sc->vector_ref_symbol, int_two, ind, - (index < 0) ? it_is_negative_string - : it_is_too_large_string); - return (vector_element (vec, index)); +static s7_pointer vector_ref_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr) +{ + if (args == 2) + return(sc->vector_ref_2); + return((args == 3) ? sc->vector_ref_3 : func); } -/* g_vector_ref_2 is now defined in s7_liii_vector.c */ -static s7_pointer -g_vector_ref_3 (s7_scheme* sc, s7_pointer args) { - const s7_pointer vec= car (args); - s7_pointer 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_clamped_if_gmp (sc, i1); - iy= s7_integer_clamped_if_gmp (sc, i2); - if ((ix >= 0) && (iy >= 0) && (ix < vector_dimension (vec, 0)) && - (iy < vector_dimension (vec, 1))) { - s7_int 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)); -} +/* -------------------------------- 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) -static s7_pointer -vector_ref_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer unused_expr) { - if (args == 2) return (sc->vector_ref_2); - return ((args == 3) ? sc->vector_ref_3 : func); -} + const s7_pointer vec = car(args); + s7_pointer val; + s7_int index; -/* -------------------------------- 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) - - const s7_pointer vec= car (args); - s7_pointer val; - s7_int index; - - if (!is_any_vector (vec)) - return (method_or_bust (sc, vec, sc->vector_set_symbol, args, - sc->type_names[T_VECTOR], 1)); - if (is_immutable_vector (vec)) - immutable_object_error_nr (sc, set_elist_3 (sc, immutable_error_string, - sc->vector_set_symbol, vec)); - if (vector_length (vec) == 0) - out_of_range_error_nr (sc, sc->vector_set_symbol, int_one, vec, - it_is_too_large_string); - - if (vector_rank (vec) > 1) { - s7_int i; - s7_pointer index_list; - index= 0; - for (index_list= cdr (args), i= 0; - (is_pair (cdr (index_list))) && (i < vector_ndims (vec)); - index_list= cdr (index_list), i++) { - s7_int n; - const s7_pointer ind= car (index_list); - if (!s7_is_integer (ind)) - return (method_or_bust (sc, ind, sc->vector_set_symbol, args, - sc->type_names[T_INTEGER], i + 2)); - n= s7_integer_clamped_if_gmp (sc, ind); - if ((n < 0) || (n >= vector_dimension (vec, i))) - out_of_range_error_nr ( - sc, sc->vector_set_symbol, wrap_integer (sc, i + 2), ind, - (n < 0) ? it_is_negative_string : it_is_too_large_string); - index+= n * vector_offset (vec, i); - } - if (is_not_null (cdr (index_list))) - wrong_number_of_arguments_error_nr ( - sc, "too many arguments for vector-set!: ~S", 38, args); - if (i != vector_ndims (vec)) - wrong_number_of_arguments_error_nr ( - sc, "not enough arguments for vector-set!: ~S", 40, 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 (index_list); - } - else { - const s7_pointer ind= cadr (args); - if (!s7_is_integer (ind)) - return (method_or_bust (sc, ind, sc->vector_set_symbol, args, - sc->type_names[T_INTEGER], 2)); - index= s7_integer_clamped_if_gmp (sc, ind); - if ((index < 0) || (index >= vector_length (vec))) - out_of_range_error_nr (sc, sc->vector_set_symbol, int_two, ind, - (index < 0) ? it_is_negative_string - : it_is_too_large_string); - if (is_not_null (cdddr (args))) { - const s7_pointer new_vec= vector_getter (vec) (sc, vec, index); - if (!is_any_vector (new_vec)) - wrong_number_of_arguments_error_nr ( - sc, "too many arguments for vector-set!: ~S", 38, args); - return (g_vector_set (sc, set_ulist_1 (sc, new_vec, cddr (args)))); - } - val= caddr (args); - } - if (is_typed_t_vector (vec)) - return (typed_vector_setter (sc, vec, index, val)); - if (is_t_vector (vec)) vector_element (vec, index)= val; - else vector_setter (vec) (sc, vec, index, val); - return (val); -} - -static s7_pointer -vector_set_p_pip (s7_scheme* sc, s7_pointer vec, s7_int index, - s7_pointer value) /* almost never called -- see one case in - s7test.scm[13736] */ -{ - if ((!is_any_vector (vec)) || (vector_rank (vec) > 1) || (index < 0) || - (index >= vector_length (vec))) - return (g_vector_set ( - sc, set_plist_3 (sc, vec, make_integer (sc, index), value))); - if (is_t_vector (vec)) { - if (is_typed_vector (vec)) - return (typed_vector_setter (sc, vec, index, value)); - vector_element (vec, index)= value; - } - else vector_setter (vec) (sc, vec, index, value); - return (value); -} + if (!is_any_vector(vec)) + return(method_or_bust(sc, vec, sc->vector_set_symbol, args, sc->type_names[T_VECTOR], 1)); + if (is_immutable_vector(vec)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->vector_set_symbol, vec)); + if (vector_length(vec) == 0) + out_of_range_error_nr(sc, sc->vector_set_symbol, int_one, vec, it_is_too_large_string); -static s7_pointer -vector_set_p_pip_unchecked (s7_scheme* sc, s7_pointer vec, s7_int index, - s7_pointer value) { - if ((index >= 0) && (index < vector_length (vec))) - vector_element (vec, index)= value; - else - out_of_range_error_nr ( - sc, sc->vector_set_symbol, int_two, wrap_integer (sc, index), - (index < 0) ? it_is_negative_string : it_is_too_large_string); - return (value); -} - -static s7_pointer -vector_set_p_piip (s7_scheme* sc, s7_pointer vec, s7_int i1, s7_int i2, - s7_pointer value) { - if ((!is_any_vector (vec)) || (vector_rank (vec) != 2) || (i1 < 0) || - (i2 < 0) || (i1 >= vector_dimension (vec, 0)) || - (i2 >= vector_dimension (vec, 1))) - return (g_vector_set (sc, set_plist_4 (sc, vec, make_integer (sc, i1), - make_integer_unchecked (sc, i2), - value))); - if (is_t_vector (vec)) { - if (is_typed_vector (vec)) - return (typed_vector_setter (sc, vec, i2 + (i1 * vector_offset (vec, 0)), - value)); - vector_element (vec, i2 + (i1 * vector_offset (vec, 0)))= value; - } - else vector_setter (vec) (sc, vec, i2 + (i1 * vector_offset (vec, 0)), value); - return (value); -} - -static s7_pointer -vector_set_p_piip_direct (s7_scheme* sc, s7_pointer vec, s7_int i1, s7_int i2, - s7_pointer value) { - /* normal untyped vector, rank == 2 */ - if ((i1 < 0) || (i2 < 0) || (i1 >= vector_dimension (vec, 0)) || - (i2 >= vector_dimension (vec, 1))) - return (g_vector_set (sc, set_plist_4 (sc, vec, make_integer (sc, i1), - make_integer_unchecked (sc, i2), - value))); - vector_element (vec, i2 + (i1 * vector_offset (vec, 0)))= value; - return (value); -} - -static s7_pointer -typed_vector_set_p_pip_unchecked (s7_scheme* sc, s7_pointer vec, s7_int index, - s7_pointer value) { - if ((index >= 0) && (index < vector_length (vec))) - typed_vector_setter (sc, vec, index, value); + if (vector_rank(vec) > 1) + { + s7_int i; + s7_pointer index_list; + index = 0; + for (index_list = cdr(args), i = 0; (is_pair(cdr(index_list))) && (i < vector_ndims(vec)); index_list = cdr(index_list), i++) + { + s7_int n; + const s7_pointer ind = car(index_list); + if (!s7_is_integer(ind)) + return(method_or_bust(sc, ind, sc->vector_set_symbol, args, sc->type_names[T_INTEGER], i + 2)); + n = s7_integer_clamped_if_gmp(sc, ind); + if ((n < 0) || (n >= vector_dimension(vec, i))) + out_of_range_error_nr(sc, sc->vector_set_symbol, wrap_integer(sc, i + 2), ind, (n < 0) ? it_is_negative_string : it_is_too_large_string); + index += n * vector_offset(vec, i); + } + if (is_not_null(cdr(index_list))) + wrong_number_of_arguments_error_nr(sc, "too many arguments for vector-set!: ~S", 38, args); + if (i != vector_ndims(vec)) + wrong_number_of_arguments_error_nr(sc, "not enough arguments for vector-set!: ~S", 40, 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(index_list); + } else - out_of_range_error_nr ( - sc, sc->vector_set_symbol, int_two, wrap_integer (sc, index), - (index < 0) ? it_is_negative_string : it_is_too_large_string); - return (value); -} + { + const s7_pointer ind = cadr(args); + if (!s7_is_integer(ind)) + return(method_or_bust(sc, ind, sc->vector_set_symbol, args, sc->type_names[T_INTEGER], 2)); + index = s7_integer_clamped_if_gmp(sc, ind); + if ((index < 0) || (index >= vector_length(vec))) + out_of_range_error_nr(sc, sc->vector_set_symbol, int_two, ind, (index < 0) ? it_is_negative_string : it_is_too_large_string); + if (is_not_null(cdddr(args))) + { + const s7_pointer new_vec = vector_getter(vec)(sc, vec, index); + if (!is_any_vector(new_vec)) + wrong_number_of_arguments_error_nr(sc, "too many arguments for vector-set!: ~S", 38, args); + return(g_vector_set(sc, set_ulist_1(sc, new_vec, cddr(args)))); + } + val = caddr(args); + } + if (is_typed_t_vector(vec)) + return(typed_vector_setter(sc, vec, index, val)); + if (is_t_vector(vec)) + vector_element(vec, index) = val; + else vector_setter(vec)(sc, vec, index, val); + return(val); +} + +/* vector_set_p_pip, vector_set_p_pip_unchecked, vector_set_p_piip, + vector_set_p_piip_direct, typed_vector_set_p_pip_unchecked, + typed_vector_set_p_piip_direct, t_vector_set_p_pip_direct, + typed_t_vector_set_p_pip_direct migrated to s7_liii_vector.c */ + +static s7_pointer g_vector_set_3(s7_scheme *sc, s7_pointer args) +{ + /* (vector-set! vector index value) */ + const s7_pointer vec = car(args); + s7_pointer ind; + s7_int index; -static s7_pointer -typed_vector_set_p_piip_direct (s7_scheme* sc, s7_pointer vec, s7_int i1, - s7_int i2, s7_pointer value) { - if ((i1 < 0) || (i2 < 0) || (i1 >= vector_dimension (vec, 0)) || - (i2 >= vector_dimension (vec, 1))) - return (g_vector_set (sc, set_plist_4 (sc, vec, make_integer (sc, i1), - make_integer_unchecked (sc, i2), - value))); - return ( - typed_vector_setter (sc, vec, i2 + (i1 * vector_offset (vec, 0)), value)); + if (!is_any_vector(vec)) + return(g_vector_set(sc, args)); + if (is_immutable_vector(vec)) + immutable_object_error_nr(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_clamped_if_gmp(sc, ind); + if ((index < 0) || (index >= vector_length(vec))) + out_of_range_error_nr(sc, sc->vector_set_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string); + { + s7_pointer val = caddr(args); + if (is_typed_t_vector(vec)) + return(typed_vector_setter(sc, vec, index, val)); + if (is_t_vector(vec)) + vector_element(vec, index) = val; + else vector_setter(vec)(sc, vec, index, val); + return(val); + } } -static s7_pointer -t_vector_set_p_pip_direct (s7_scheme* unused_sc, s7_pointer vec, s7_int index, - s7_pointer value) { - vector_element (vec, index)= value; - return (value); -} +/* vector_set_p_ppp migrated to s7_liii_vector.c */ -static s7_pointer -typed_t_vector_set_p_pip_direct (s7_scheme* sc, s7_pointer vec, s7_int index, - s7_pointer value) { - typed_vector_setter (sc, vec, index, value); - return (value); +static s7_pointer g_vector_set_4(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer vec = car(args), ip1 = cadr(args), ip2 = caddr(args); + s7_pointer val; + s7_int i1, i2; + if ((!is_any_vector(vec)) || + (vector_rank(vec) != 2) || (is_immutable_vector(vec)) || + (!s7_is_integer(ip1)) || (!s7_is_integer(ip2))) + return(g_vector_set(sc, args)); + i1 = s7_integer_clamped_if_gmp(sc, ip1); + i2 = s7_integer_clamped_if_gmp(sc, ip2); + if ((i1 < 0) || (i2 < 0) || + (i1 >= vector_dimension(vec, 0)) || (i2 >= vector_dimension(vec, 1))) + return(g_vector_set(sc, args)); + val = cadddr(args); + if (is_typed_t_vector(vec)) + return(typed_vector_setter(sc, vec, i2 + (i1 * vector_offset(vec, 0)), val)); + if (is_t_vector(vec)) + vector_element(vec, i2 + (i1 * vector_offset(vec, 0))) = val; + else vector_setter(vec)(sc, vec, i2 + (i1 * vector_offset(vec, 0)), val); + return(val); +} + +static s7_pointer vector_set_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr) +{ + if (args == 3) return(sc->vector_set_3); + return((args == 4) ? sc->vector_set_4 : func); } -static s7_pointer -g_vector_set_3 (s7_scheme* sc, s7_pointer args) { - /* (vector-set! vector index value) */ - const s7_pointer vec= car (args); - s7_pointer ind; - s7_int index; - - if (!is_any_vector (vec)) return (g_vector_set (sc, args)); - if (is_immutable_vector (vec)) - immutable_object_error_nr (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_clamped_if_gmp (sc, ind); - if ((index < 0) || (index >= vector_length (vec))) - out_of_range_error_nr ( - sc, sc->vector_set_symbol, int_two, wrap_integer (sc, index), - (index < 0) ? it_is_negative_string : it_is_too_large_string); - { - s7_pointer val= caddr (args); - if (is_typed_t_vector (vec)) - return (typed_vector_setter (sc, vec, index, val)); - if (is_t_vector (vec)) vector_element (vec, index)= val; - else 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 ((S7_DEBUGGING) && (is_mutable(ind)) && (is_t_integer(ind))) ind = - * make_integer(sc, integer(ind)); */ - /* if ((S7_DEBUGGING) && (is_mutable(ind)) && (is_t_integer(ind))) - * fprintf(stderr, "%s[%d]: skipping make-integer\n", __func__, __LINE__); */ - - if ((!is_t_vector (vec)) || (vector_rank (vec) > 1)) - return (g_vector_set (sc, set_plist_3 (sc, vec, ind, val))); - if (is_immutable_vector (vec)) - immutable_object_error_nr (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_clamped_if_gmp (sc, ind); - if ((index < 0) || (index >= vector_length (vec))) - out_of_range_error_nr ( - sc, sc->vector_set_symbol, int_two, wrap_integer (sc, index), - (index < 0) ? it_is_negative_string : it_is_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) { - const s7_pointer vec= car (args), ip1= cadr (args), ip2= caddr (args); - s7_pointer val; - s7_int i1, i2; - if ((!is_any_vector (vec)) || (vector_rank (vec) != 2) || - (is_immutable_vector (vec)) || (!s7_is_integer (ip1)) || - (!s7_is_integer (ip2))) - return (g_vector_set (sc, args)); - i1= s7_integer_clamped_if_gmp (sc, ip1); - i2= s7_integer_clamped_if_gmp (sc, ip2); - if ((i1 < 0) || (i2 < 0) || (i1 >= vector_dimension (vec, 0)) || - (i2 >= vector_dimension (vec, 1))) - return (g_vector_set (sc, args)); - val= cadddr (args); - if (is_typed_t_vector (vec)) - return ( - typed_vector_setter (sc, vec, i2 + (i1 * vector_offset (vec, 0)), val)); - if (is_t_vector (vec)) - vector_element (vec, i2 + (i1 * vector_offset (vec, 0)))= val; - else vector_setter (vec) (sc, vec, i2 + (i1 * vector_offset (vec, 0)), val); - return (val); -} - -static s7_pointer -vector_set_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer unused_expr) { - if (args == 3) return (sc->vector_set_3); - return ((args == 4) ? sc->vector_set_4 : func); -} - -/* -------------------------------- make-vector -------------------------------- - */ -static s7_int -multivector_length (s7_scheme* sc, s7_pointer dim_list, s7_pointer caller) { - s7_int len = 1; - const s7_int num_dims= s7_list_length (sc, dim_list); - if (num_dims <= 0) /* 0 if circular, negative if dotted */ - wrong_type_error_nr (sc, caller, 1, dim_list, a_proper_list_string); +/* -------------------------------- make-vector -------------------------------- */ +static s7_int multivector_length(s7_scheme *sc, s7_pointer dim_list, s7_pointer caller) +{ + s7_int len = 1; + const s7_int num_dims = s7_list_length(sc, dim_list); + if (num_dims <= 0) /* 0 if circular, negative if dotted */ + wrong_type_error_nr(sc, caller, 1, dim_list, a_proper_list_string); if (num_dims > sc->max_vector_dimensions) - error_nr ( - sc, sc->out_of_range_symbol, - set_elist_3 (sc, - wrap_string (sc, - "~S specifies too many dimensions: '~S, but " - "(*s7* 'max-vector-dimensions) is ~D", - 78), - dim_list, wrap_integer (sc, sc->max_vector_dimensions))); - for (s7_pointer dims= dim_list; is_pair (dims); dims= cdr (dims)) { - const s7_pointer dim= car (dims); - if (!s7_is_integer (dim)) - wrong_type_error_nr (sc, caller, position_of (dims, dim_list), dim, - sc->type_names[T_INTEGER]); + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "~S specifies too many dimensions: '~S, but (*s7* 'max-vector-dimensions) is ~D", 78), + dim_list, wrap_integer(sc, sc->max_vector_dimensions))); + for (s7_pointer dims = dim_list; is_pair(dims); dims = cdr(dims)) + { + const s7_pointer dim = car(dims); + if (!s7_is_integer(dim)) + wrong_type_error_nr(sc, caller, position_of(dims, dim_list), dim, sc->type_names[T_INTEGER]); #if HAVE_OVERFLOW_CHECKS - if (multiply_overflow ( - len, s7_integer_clamped_if_gmp (sc, dim), - &len)) /* or better perhaps len > sc->max_vector_length */ - out_of_range_error_nr (sc, caller, - wrap_integer (sc, position_of (dims, dim_list)), - dim, it_is_too_large_string); + if (multiply_overflow(len, s7_integer_clamped_if_gmp(sc, dim), &len)) /* or better perhaps len > sc->max_vector_length */ + out_of_range_error_nr(sc, caller, wrap_integer(sc, position_of(dims, dim_list)), dim, it_is_too_large_string); #else - len*= s7_integer_clamped_if_gmp (sc, dim); + len *= s7_integer_clamped_if_gmp(sc, dim); #endif - if (len < 0) - wrong_type_error_nr (sc, caller, position_of (dims, dim_list), dim, - a_non_negative_integer_string); - } - return (len); -} - -static void -check_vector_typer_c_function (s7_scheme* sc, s7_pointer caller, - s7_pointer typf) { - const s7_pointer 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))))) - wrong_type_error_nr (sc, caller, 2, typf, - wrap_string (sc, "a boolean procedure", 19)); - if (!c_function_name (typf)) - wrong_type_error_nr (sc, caller, 2, typf, - wrap_string (sc, "a named function", 16)); - if (!c_function_marker (typf)) c_function_set_marker (typf, mark_vector_1); -} - -static inline s7_pointer -make_multivector (s7_scheme* sc, s7_pointer vec, s7_pointer lst) { - vdims_t* vd = list_to_vdims (sc, lst); - vdims_original (vd)= sc->F; - vector_set_dimension_info (vec, vd); - add_multivector (sc, vec); - return (vec); -} - -s7_pointer -s7i_make_vector_1 (s7_scheme* sc, s7_pointer args, s7_pointer caller) { - s7_int len; - const s7_pointer dims= car (args); - s7_pointer fill= sc->unspecified, typf= sc->T; - int32_t result_type= T_VECTOR; - - if (s7_is_integer (dims)) { - len= s7_integer_clamped_if_gmp (sc, dims); - if (len < 0) - wrong_type_error_nr (sc, caller, 1, dims, a_non_negative_integer_string); - } - else { - if (!is_pair (dims)) - return (method_or_bust ( - sc, dims, caller, args, - wrap_string (sc, "an integer or a list of integers", 32), 1)); - if (!s7_is_integer (car (dims))) - wrong_type_error_nr (sc, caller, 1, car (dims), - sc->type_names[T_INTEGER]); - len= (is_null (cdr (dims))) ? s7_integer_clamped_if_gmp (sc, car (dims)) - : multivector_length (sc, dims, 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; - else if (caller == sc->make_complex_vector_symbol) - result_type= T_COMPLEX_VECTOR; - if (is_pair (cddr (args))) { - typf= caddr (args); - if ((!is_c_function (typf)) && (!is_any_closure (typf)) && - (typf != sc->T)) /* default value */ - wrong_type_error_nr ( - 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)))) - wrong_type_error_nr (sc, caller, 3, typf, - wrap_string (sc, "a named function", 16)); - /* the name is needed primarily by the error handler: "vector-set! third - * argument, ..., is a ... but should be a <...>" */ - } - else if (is_c_function (typf)) { - if (typf == global_value (sc->is_float_symbol)) { - if (!is_real (fill)) - wrong_type_error_nr (sc, caller, 2, fill, sc->type_names[T_REAL]); - result_type= T_FLOAT_VECTOR; - } - else if (typf == global_value (sc->is_integer_symbol)) { - if (!s7_is_integer (fill)) - wrong_type_error_nr (sc, caller, 2, fill, - sc->type_names[T_INTEGER]); - result_type= T_INT_VECTOR; - } - else if (typf == global_value (sc->is_byte_symbol)) { - if (!is_byte (fill)) - wrong_type_error_nr (sc, caller, 2, fill, an_unsigned_byte_string); - result_type= T_BYTE_VECTOR; - } - else if (typf == global_value (sc->is_complex_symbol)) { - if (!is_number (fill)) - wrong_type_error_nr (sc, caller, 2, fill, - sc->type_names[T_COMPLEX]); - result_type= T_COMPLEX_VECTOR; - } - else check_vector_typer_c_function (sc, caller, typf); - } + if (len < 0) + wrong_type_error_nr(sc, caller, position_of(dims, dim_list), dim, a_non_negative_integer_string); } - } - /* 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) && (typf != sc->T) && /* default value */ - (s7_apply_function (sc, typf, set_plist_1 (sc, fill)) == sc->F)) { - const char* tstr= make_type_name ( - sc, - (is_c_function (typf)) - ? c_function_name (typf) - : symbol_name (find_closure (sc, typf, closure_let (typf))), - indefinite_article); - wrong_type_error_nr (sc, sc->make_vector_symbol, 2, fill, - wrap_string (sc, tstr, safe_strlen (tstr))); - } - { - s7_pointer vec= make_vector_1 (sc, len, NOT_FILLED, result_type); - if ((result_type == T_VECTOR) && (typf != sc->T)) /* default value */ + return(len); +} + +static void check_vector_typer_c_function(s7_scheme *sc, s7_pointer caller, s7_pointer typf) +{ + const s7_pointer 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))))) + wrong_type_error_nr(sc, caller, 2, typf, wrap_string(sc, "a boolean procedure", 19)); + if (!c_function_name(typf)) + wrong_type_error_nr(sc, caller, 2, typf, wrap_string(sc, "a named function", 16)); + if (!c_function_marker(typf)) + c_function_set_marker(typf, mark_vector_1); +} + +static inline s7_pointer make_multivector(s7_scheme *sc, s7_pointer vec, s7_pointer lst) +{ + vdims_t *vd = list_to_vdims(sc, lst); + vdims_original(vd) = sc->F; + vector_set_dimension_info(vec, vd); + add_multivector(sc, vec); + return(vec); +} + +s7_pointer s7i_make_vector_1(s7_scheme *sc, s7_pointer args, s7_pointer caller) +{ + s7_int len; + const s7_pointer dims = car(args); + s7_pointer fill = sc->unspecified, typf = sc->T; + int32_t result_type = T_VECTOR; + + if (s7_is_integer(dims)) + { + len = s7_integer_clamped_if_gmp(sc, dims); + if (len < 0) + wrong_type_error_nr(sc, caller, 1, dims, a_non_negative_integer_string); + } + else { - set_typed_vector (vec); - typed_vector_set_typer (vec, typf); + if (!is_pair(dims)) + return(method_or_bust(sc, dims, caller, args, wrap_string(sc, "an integer or a list of integers", 32), 1)); + if (!s7_is_integer(car(dims))) + wrong_type_error_nr(sc, caller, 1, car(dims), sc->type_names[T_INTEGER]); + len = (is_null(cdr(dims))) ? s7_integer_clamped_if_gmp(sc, car(dims)) : multivector_length(sc, dims, caller); + } - if ((is_c_function (typf)) && (c_function_has_simple_elements (typf))) - set_has_simple_elements (vec); + 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; + else + if (caller == sc->make_complex_vector_symbol) + result_type = T_COMPLEX_VECTOR; + if (is_pair(cddr(args))) + { + typf = caddr(args); + if ((!is_c_function(typf)) && + (!is_any_closure(typf)) && + (typf != sc->T)) /* default value */ + wrong_type_error_nr(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)))) + wrong_type_error_nr(sc, caller, 3, typf, wrap_string(sc, "a named function", 16)); + /* the name is needed primarily by the error handler: "vector-set! third argument, ..., is a ... but should be a <...>" */ + } + else + if (is_c_function(typf)) + { + if (typf == global_value(sc->is_float_symbol)) + { + if (!is_real(fill)) wrong_type_error_nr(sc, caller, 2, fill, sc->type_names[T_REAL]); + result_type = T_FLOAT_VECTOR; + } + else + if (typf == global_value(sc->is_integer_symbol)) + { + if (!s7_is_integer(fill)) wrong_type_error_nr(sc, caller, 2, fill, sc->type_names[T_INTEGER]); + result_type = T_INT_VECTOR; + } + else + if (typf == global_value(sc->is_byte_symbol)) + { + if (!is_byte(fill)) wrong_type_error_nr(sc, caller, 2, fill, an_unsigned_byte_string); + result_type = T_BYTE_VECTOR; + } + else + if (typf == global_value(sc->is_complex_symbol)) + { + if (!is_number(fill)) wrong_type_error_nr(sc, caller, 2, fill, sc->type_names[T_COMPLEX]); + result_type = T_COMPLEX_VECTOR; + } + else check_vector_typer_c_function(sc, caller, typf); + }}} + /* 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) && + (typf != sc->T) && /* default value */ + (s7_apply_function(sc, typf, set_plist_1(sc, fill)) == sc->F)) + { + const char *tstr = make_type_name(sc, (is_c_function(typf)) ? c_function_name(typf) : symbol_name(find_closure(sc, typf, closure_let(typf))), indefinite_article); + wrong_type_error_nr(sc, sc->make_vector_symbol, 2, fill, wrap_string(sc, tstr, safe_strlen(tstr))); } - s7_vector_fill (sc, vec, fill); - if ((is_pair (dims)) && (is_pair (cdr (dims)))) - return (make_multivector (sc, vec, dims)); - add_vector (sc, vec); - return (vec); + { + s7_pointer vec = make_vector_1(sc, len, NOT_FILLED, result_type); + if ((result_type == T_VECTOR) && + (typf != sc->T)) /* default value */ + { + 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(dims)) && + (is_pair(cdr(dims)))) + return(make_multivector(sc, vec, dims)); + add_vector(sc, vec); + return(vec); } } -#define H_make_vector \ - "(make-vector len (value #) type) returns a vector of len elements initialized to value. \ +#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. The 'type argument can set the element type. \ It is a function that checks the new value, returning #f if the value is not acceptable: (make-vector 8 1/2 rational?)." -#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)) /* actually #t here not boolean? */ +#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)) /* actually #t here not boolean? */ /* g_make_vector is now defined in s7_liii_vector.c */ -/* -------------------------------- 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_pointer size= car (args); /* can be a pair if multiple dimensions */ - s7_int len; - - if ((is_pair (cdr (args))) || (!s7_is_integer (size))) { - 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, - sc->type_names[T_REAL], 2)); - if (is_rational (init)) - return (s7i_make_vector_1 ( - sc, - set_plist_2 (sc, size, - wrap_real (sc, rational_to_double (sc, init))), - sc->make_float_vector_symbol)); - } - else init= real_zero; - if (s7_is_integer (size)) len= s7_integer_clamped_if_gmp (sc, size); - else { - if (!is_pair (size)) - return (method_or_bust ( - sc, size, sc->make_float_vector_symbol, args, - wrap_string (sc, "an integer or a list of integers", 32), 1)); - len= multivector_length (sc, size, sc->make_float_vector_symbol); - } - { - s7_pointer vect= make_vector_1 (sc, len, NOT_FILLED, T_FLOAT_VECTOR); - float_vector_fill (vect, s7_real (init)); - if (!s7_is_integer (size)) return (make_multivector (sc, vect, size)); - add_vector (sc, vect); - return (vect); - } - } - len= s7_integer_clamped_if_gmp (sc, size); + +/* -------------------------------- 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_pointer size = car(args); /* can be a pair if multiple dimensions */ + s7_int len; + + if ((is_pair(cdr(args))) || (!s7_is_integer(size))) + { + 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, sc->type_names[T_REAL], 2)); + if (is_rational(init)) + return(s7i_make_vector_1(sc, set_plist_2(sc, size, wrap_real(sc, rational_to_double(sc, init))), sc->make_float_vector_symbol)); + } + else init = real_zero; + if (s7_is_integer(size)) + len = s7_integer_clamped_if_gmp(sc, size); + else + { + if (!is_pair(size)) + return(method_or_bust(sc, size, sc->make_float_vector_symbol, args, wrap_string(sc, "an integer or a list of integers", 32), 1)); + len = multivector_length(sc, size, sc->make_float_vector_symbol); + } + { + s7_pointer vect = make_vector_1(sc, len, NOT_FILLED, T_FLOAT_VECTOR); + float_vector_fill(vect, s7_real(init)); + if (!s7_is_integer(size)) + return(make_multivector(sc, vect, size)); + add_vector(sc, vect); + return(vect); + }} + len = s7_integer_clamped_if_gmp(sc, size); if (len < 0) - out_of_range_error_nr (sc, sc->make_float_vector_symbol, int_one, size, - it_is_negative_string); + out_of_range_error_nr(sc, sc->make_float_vector_symbol, int_one, size, it_is_negative_string); if (len > sc->max_vector_length) - error_nr ( - sc, sc->out_of_range_symbol, - set_elist_3 (sc, - wrap_string (sc, - "make-float-vector first argument ~D is " - "greater than (*s7* 'max-vector-length), ~D", - 81), - wrap_integer (sc, len), - wrap_integer (sc, sc->max_vector_length))); + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "make-float-vector first argument ~D is greater than (*s7* 'max-vector-length), ~D", 81), + wrap_integer(sc, len), wrap_integer(sc, sc->max_vector_length))); { - block_t* arr= mallocate_vector (sc, len * sizeof (s7_double)); + block_t *arr = mallocate_vector(sc, len * sizeof(s7_double)); s7_pointer vect; - new_cell (sc, vect, T_FLOAT_VECTOR | T_SAFE_PROCEDURE); - vector_length (vect) = len; - vector_block (vect) = arr; - float_vector_floats (vect)= (s7_double*) block_data (arr); - if (len > 0) { - if (STEP_8 (len)) - memclr64 ((void*) float_vector_floats (vect), len * sizeof (s7_double)); - else - memclr ((void*) float_vector_floats (vect), len * sizeof (s7_double)); - } - vector_set_dimension_info (vect, NULL); - vector_getter (vect)= float_vector_getter; - vector_setter (vect)= float_vector_setter; - add_vector (sc, vect); - return (vect); + new_cell(sc, vect, T_FLOAT_VECTOR | T_SAFE_PROCEDURE); + vector_length(vect) = len; + vector_block(vect) = arr; + float_vector_floats(vect) = (s7_double *)block_data(arr); + if (len > 0) + { + if (STEP_8(len)) + memclr64((void *)float_vector_floats(vect), len * sizeof(s7_double)); + else memclr((void *)float_vector_floats(vect), len * sizeof(s7_double)); + } + vector_set_dimension_info(vect, NULL); + vector_getter(vect) = float_vector_getter; + vector_setter(vect) = float_vector_setter; + add_vector(sc, vect); + return(vect); } } -static s7_pointer -make_float_vector_p_pp (s7_scheme* sc, s7_pointer len, s7_pointer fill) { - if ((is_t_integer (len)) && (is_t_real (fill)) && (integer (len) >= 0) && - (integer (len) < sc->max_vector_length)) { - s7_pointer fv= make_simple_float_vector (sc, integer (len)); - float_vector_fill (fv, real (fill)); - return (fv); - } - return (g_make_float_vector (sc, set_plist_2 (sc, len, fill))); -} - -/* -------------------------------- make-complex-vector - * -------------------------------- */ -static s7_pointer -g_make_complex_vector (s7_scheme* sc, s7_pointer args) { -#define H_make_complex_vector \ - "(make-complex-vector len (init 0.0)) returns a complex-vector." -#define Q_make_complex_vector \ - s7_make_signature ( \ - sc, 3, sc->is_complex_vector_symbol, \ - s7_make_signature (sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), \ - sc->is_complex_symbol) - s7_pointer size= car (args); - s7_int len; - - if ((is_pair (cdr (args))) || (!s7_is_integer (size))) { - s7_pointer init; - if (is_pair (cdr (args))) { - init= cadr (args); - if (!is_number (init)) - return (method_or_bust (sc, init, sc->make_complex_vector_symbol, args, - sc->type_names[T_COMPLEX], 2)); - if (is_rational (init)) - return (s7i_make_vector_1 ( - sc, - set_plist_2 (sc, size, - wrap_real (sc, rational_to_double (sc, init))), - sc->make_complex_vector_symbol)); - } - else init= real_zero; - if (s7_is_integer (size)) len= s7_integer_clamped_if_gmp (sc, size); - else { - if (!is_pair (size)) - return (method_or_bust ( - sc, size, sc->make_complex_vector_symbol, args, - wrap_string (sc, "an integer or a list of integers", 32), 1)); - len= multivector_length (sc, size, sc->make_complex_vector_symbol); - } - { - s7_pointer vect= make_vector_1 (sc, len, NOT_FILLED, T_COMPLEX_VECTOR); - complex_vector_fill (vect, s7_to_c_complex (init)); - if (!s7_is_integer (size)) return (make_multivector (sc, vect, size)); - add_vector (sc, vect); - return (vect); +static s7_pointer make_float_vector_p_pp(s7_scheme *sc, s7_pointer len, s7_pointer fill) +{ + if ((is_t_integer(len)) && (is_t_real(fill)) && + (integer(len)>= 0) && (integer(len) < sc->max_vector_length)) + { + s7_pointer fv = make_simple_float_vector(sc, integer(len)); + float_vector_fill(fv, real(fill)); + return(fv); } - } - len= s7_integer_clamped_if_gmp (sc, size); + return(g_make_float_vector(sc, set_plist_2(sc, len, fill))); +} + + +/* -------------------------------- make-complex-vector -------------------------------- */ +static s7_pointer g_make_complex_vector(s7_scheme *sc, s7_pointer args) +{ + #define H_make_complex_vector "(make-complex-vector len (init 0.0)) returns a complex-vector." + #define Q_make_complex_vector s7_make_signature(sc, 3, \ + sc->is_complex_vector_symbol, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->is_complex_symbol) + s7_pointer size = car(args); + s7_int len; + + if ((is_pair(cdr(args))) || (!s7_is_integer(size))) + { + s7_pointer init; + if (is_pair(cdr(args))) + { + init = cadr(args); + if (!is_number(init)) + return(method_or_bust(sc, init, sc->make_complex_vector_symbol, args, sc->type_names[T_COMPLEX], 2)); + if (is_rational(init)) + return(s7i_make_vector_1(sc, set_plist_2(sc, size, wrap_real(sc, rational_to_double(sc, init))), sc->make_complex_vector_symbol)); + } + else init = real_zero; + if (s7_is_integer(size)) + len = s7_integer_clamped_if_gmp(sc, size); + else + { + if (!is_pair(size)) + return(method_or_bust(sc, size, sc->make_complex_vector_symbol, args, wrap_string(sc, "an integer or a list of integers", 32), 1)); + len = multivector_length(sc, size, sc->make_complex_vector_symbol); + } + { + s7_pointer vect = make_vector_1(sc, len, NOT_FILLED, T_COMPLEX_VECTOR); + complex_vector_fill(vect, s7_to_c_complex(init)); + if (!s7_is_integer(size)) + return(make_multivector(sc, vect, size)); + add_vector(sc, vect); + return(vect); + }} + len = s7_integer_clamped_if_gmp(sc, size); if (len < 0) - out_of_range_error_nr (sc, sc->make_complex_vector_symbol, int_one, size, - it_is_negative_string); + out_of_range_error_nr(sc, sc->make_complex_vector_symbol, int_one, size, it_is_negative_string); if (len > sc->max_vector_length) - error_nr ( - sc, sc->out_of_range_symbol, - set_elist_3 (sc, - wrap_string (sc, - "make-complex-vector first argument ~D is " - "greater than (*s7* 'max-vector-length), ~D", - 81), - wrap_integer (sc, len), - wrap_integer (sc, sc->max_vector_length))); + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "make-complex-vector first argument ~D is greater than (*s7* 'max-vector-length), ~D", 81), + wrap_integer(sc, len), wrap_integer(sc, sc->max_vector_length))); { - block_t* arr= mallocate_vector (sc, len * sizeof (s7_complex)); + block_t *arr = mallocate_vector(sc, len * sizeof(s7_complex)); s7_pointer vect; - new_cell (sc, vect, T_COMPLEX_VECTOR | T_SAFE_PROCEDURE); - vector_length (vect) = len; - vector_block (vect) = arr; - complex_vector_complexes (vect)= (s7_complex*) block_data (arr); - if (len > 0) { - if (STEP_8 (len)) - memclr64 ((void*) complex_vector_complexes (vect), - len * sizeof (s7_complex)); - else - memclr ((void*) complex_vector_complexes (vect), - len * sizeof (s7_complex)); - } - vector_set_dimension_info (vect, NULL); - vector_getter (vect)= complex_vector_getter; - vector_setter (vect)= complex_vector_setter; - add_vector (sc, vect); - return (vect); + new_cell(sc, vect, T_COMPLEX_VECTOR | T_SAFE_PROCEDURE); + vector_length(vect) = len; + vector_block(vect) = arr; + complex_vector_complexes(vect) = (s7_complex *)block_data(arr); + if (len > 0) + { + if (STEP_8(len)) + memclr64((void *)complex_vector_complexes(vect), len * sizeof(s7_complex)); + else memclr((void *)complex_vector_complexes(vect), len * sizeof(s7_complex)); + } + vector_set_dimension_info(vect, NULL); + vector_getter(vect) = complex_vector_getter; + vector_setter(vect) = complex_vector_setter; + add_vector(sc, vect); + return(vect); } } -/* -------------------------------- 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_pointer size= car (args); - s7_int len; - - if ((is_pair (cdr (args))) || (!s7_is_integer (size))) { - 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, - sc->type_names[T_INTEGER], 2)); - } - else init= int_zero; - if (s7_is_integer (size)) len= s7_integer_clamped_if_gmp (sc, size); - else { - if (!is_pair (size)) - return (method_or_bust ( - sc, size, sc->make_int_vector_symbol, args, - wrap_string (sc, "an integer or a list of integers", 32), 1)); - len= multivector_length (sc, size, sc->make_int_vector_symbol); - } - { - s7_pointer vect= make_vector_1 (sc, len, NOT_FILLED, T_INT_VECTOR); - int_vector_fill (vect, s7_integer_clamped_if_gmp (sc, init)); - if (!s7_is_integer (size)) return (make_multivector (sc, vect, size)); - add_vector (sc, vect); - return (vect); - } - } - len= s7_integer_clamped_if_gmp (sc, size); + +/* -------------------------------- 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_pointer size = car(args); + s7_int len; + + if ((is_pair(cdr(args))) || + (!s7_is_integer(size))) + { + 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, sc->type_names[T_INTEGER], 2)); + } + else init = int_zero; + if (s7_is_integer(size)) + len = s7_integer_clamped_if_gmp(sc, size); + else + { + if (!is_pair(size)) + return(method_or_bust(sc, size, sc->make_int_vector_symbol, args, wrap_string(sc, "an integer or a list of integers", 32), 1)); + len = multivector_length(sc, size, sc->make_int_vector_symbol); + } + { + s7_pointer vect = make_vector_1(sc, len, NOT_FILLED, T_INT_VECTOR); + int_vector_fill(vect, s7_integer_clamped_if_gmp(sc, init)); + if (!s7_is_integer(size)) + return(make_multivector(sc, vect, size)); + add_vector(sc, vect); + return(vect); + }} + len = s7_integer_clamped_if_gmp(sc, size); if (len < 0) - out_of_range_error_nr (sc, sc->make_int_vector_symbol, int_one, size, - it_is_negative_string); + out_of_range_error_nr(sc, sc->make_int_vector_symbol, int_one, size, it_is_negative_string); if (len > sc->max_vector_length) - error_nr ( - sc, sc->out_of_range_symbol, - set_elist_3 (sc, - wrap_string (sc, - "make-int-vector first argument ~D is " - "greater than (*s7* 'max-vector-length), ~D", - 79), - wrap_integer (sc, len), - wrap_integer (sc, sc->max_vector_length))); + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "make-int-vector first argument ~D is greater than (*s7* 'max-vector-length), ~D", 79), + wrap_integer(sc, len), wrap_integer(sc, sc->max_vector_length))); { - block_t* arr= mallocate_vector (sc, len * sizeof (s7_int)); + block_t *arr = mallocate_vector(sc, len * sizeof(s7_int)); s7_pointer vect; - new_cell (sc, vect, T_INT_VECTOR | T_SAFE_PROCEDURE); - vector_length (vect) = len; - vector_block (vect) = arr; - int_vector_ints (vect)= (s7_int*) block_data (arr); - if (len > 0) { - if (STEP_8 (len)) - memclr64 ((void*) int_vector_ints (vect), len * sizeof (s7_int)); - else memclr ((void*) int_vector_ints (vect), len * sizeof (s7_int)); - } - vector_set_dimension_info (vect, NULL); - vector_getter (vect)= int_vector_getter; - vector_setter (vect)= int_vector_setter; - add_vector (sc, vect); - return (vect); + new_cell(sc, vect, T_INT_VECTOR | T_SAFE_PROCEDURE); + vector_length(vect) = len; + vector_block(vect) = arr; + int_vector_ints(vect) = (s7_int *)block_data(arr); + if (len > 0) + { + if (STEP_8(len)) + memclr64((void *)int_vector_ints(vect), len * sizeof(s7_int)); + else memclr((void *)int_vector_ints(vect), len * sizeof(s7_int)); + } + vector_set_dimension_info(vect, NULL); + vector_getter(vect) = int_vector_getter; + vector_setter(vect) = int_vector_setter; + add_vector(sc, vect); + return(vect); } } -static s7_pointer -make_int_vector_p_ii (s7_scheme* sc, s7_int len, s7_int init) { - s7_pointer vec= make_vector_1 (sc, len, NOT_FILLED, T_INT_VECTOR); - int_vector_fill (vec, init); - add_vector (sc, vec); - return (vec); -} - -/* -------------------------------- 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 size= car (args), init; - - if (!is_pair (size)) { - if (!s7_is_integer (size)) - return (method_or_bust (sc, size, sc->make_byte_vector_symbol, args, - sc->type_names[T_INTEGER], 1)); - len= s7_integer_clamped_if_gmp (sc, size); - if (len < 0) - out_of_range_error_nr (sc, sc->make_byte_vector_symbol, int_one, size, - it_is_negative_string); - if (len > sc->max_vector_length) - error_nr (sc, sc->out_of_range_symbol, - set_elist_3 ( - sc, - wrap_string (sc, - "make-byte-vector first argument ~D is " - "greater than (*s7* 'max-vector-length), ~D", - 80), - wrap_integer (sc, len), - wrap_integer (sc, sc->max_vector_length))); - } - 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, - sc->type_names[T_INTEGER], 2)); - ib= s7_integer_clamped_if_gmp (sc, init); - if ((ib < 0) || (ib > 255)) - wrong_type_error_nr (sc, sc->make_byte_vector_symbol, 2, init, - an_unsigned_byte_string); - } - else init= int_zero; - - if (!s7_is_integer (size)) - return (s7i_make_vector_1 (sc, set_plist_2 (sc, size, init), - sc->make_byte_vector_symbol)); - { - s7_pointer result= make_simple_byte_vector (sc, len); - if (len > 0) /* make-byte-vector 2) should return #u(0 0) so we always need - to fill */ - local_memset ((void*) (byte_vector_bytes (result)), ib, len); - return (result); - } +static s7_pointer make_int_vector_p_ii(s7_scheme *sc, s7_int len, s7_int init) +{ + s7_pointer vec = make_vector_1(sc, len, NOT_FILLED, T_INT_VECTOR); + int_vector_fill(vec, init); + add_vector(sc, vec); + return(vec); } -static s7_pointer -make_byte_vector_p_ii (s7_scheme* sc, s7_int len, s7_int init) { + +/* -------------------------------- 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 size = car(args), init; + + if (!is_pair(size)) + { + if (!s7_is_integer(size)) + return(method_or_bust(sc, size, sc->make_byte_vector_symbol, args, sc->type_names[T_INTEGER], 1)); + len = s7_integer_clamped_if_gmp(sc, size); + if (len < 0) + out_of_range_error_nr(sc, sc->make_byte_vector_symbol, int_one, size, it_is_negative_string); + if (len > sc->max_vector_length) + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "make-byte-vector first argument ~D is greater than (*s7* 'max-vector-length), ~D", 80), + wrap_integer(sc, len), wrap_integer(sc, sc->max_vector_length))); + } + 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, sc->type_names[T_INTEGER], 2)); + ib = s7_integer_clamped_if_gmp(sc, init); + if ((ib < 0) || (ib > 255)) + wrong_type_error_nr(sc, sc->make_byte_vector_symbol, 2, init, an_unsigned_byte_string); + } + else init = int_zero; + + if (!s7_is_integer(size)) + return(s7i_make_vector_1(sc, set_plist_2(sc, size, init), sc->make_byte_vector_symbol)); + { + s7_pointer result = make_simple_byte_vector(sc, len); + if (len > 0) /* make-byte-vector 2) should return #u(0 0) so we always need to fill */ + local_memset((void *)(byte_vector_bytes(result)), ib, len); + return(result); + } +} + +static s7_pointer make_byte_vector_p_ii(s7_scheme *sc, s7_int len, s7_int init) +{ if (len < 0) - out_of_range_error_nr (sc, sc->make_byte_vector_symbol, int_one, - wrap_integer (sc, len), it_is_negative_string); + out_of_range_error_nr(sc, sc->make_byte_vector_symbol, int_one, wrap_integer(sc, len), it_is_negative_string); if (len > sc->max_vector_length) - error_nr ( - sc, sc->out_of_range_symbol, - set_elist_3 (sc, - wrap_string (sc, - "make-byte-vector first argument ~D is " - "greater than (*s7* 'max-vector-length), ~D", - 80), - wrap_integer (sc, len), - wrap_integer (sc, sc->max_vector_length))); + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "make-byte-vector first argument ~D is greater than (*s7* 'max-vector-length), ~D", 80), + wrap_integer(sc, len), wrap_integer(sc, sc->max_vector_length))); if ((init < 0) || (init > 255)) - wrong_type_error_nr (sc, sc->make_byte_vector_symbol, 2, - wrap_integer (sc, init), an_unsigned_byte_string); + wrong_type_error_nr(sc, sc->make_byte_vector_symbol, 2, wrap_integer(sc, init), an_unsigned_byte_string); { - s7_pointer bvect= make_simple_byte_vector (sc, len); - if (len > 0) local_memset ((void*) (byte_vector_bytes (bvect)), init, len); - return (bvect); + s7_pointer bvect = make_simple_byte_vector(sc, len); + if (len > 0) + local_memset((void *)(byte_vector_bytes(bvect)), init, len); + return(bvect); } } + /* -------------------------------- vector? -------------------------------- */ /* g_is_vector is now defined in s7_liii_vector.c */ -/* -------------------------------- vector-rank -------------------------------- - */ -s7_int -s7_vector_rank (s7_pointer vec) { - return ((s7_int) (vector_rank (vec))); -} + +/* -------------------------------- vector-rank -------------------------------- */ +s7_int s7_vector_rank(s7_pointer vec) {return((s7_int)(vector_rank(vec)));} /* g_vector_rank is now defined in s7_liii_vector.c */ -/* -------------------------------- vector-dimension - * -------------------------------- */ + +/* -------------------------------- vector-dimension -------------------------------- */ /* g_vector_dimension is now defined in s7_liii_vector.c */ -/* -------------------------------- vector-dimensions - * -------------------------------- */ + +/* -------------------------------- vector-dimensions -------------------------------- */ /* g_vector_dimensions is now defined in s7_liii_vector.c */ -/* -------------------------------- vector-typer - * -------------------------------- */ + +/* -------------------------------- vector-typer -------------------------------- */ /* g_vector_typer is now defined in s7_liii_vector.c */ -static s7_pointer -g_set_vector_typer (s7_scheme* sc, s7_pointer args) { - s7_pointer vec= car (args), typer= cadr (args); - - if (!is_any_vector (vec)) - wrong_type_error_nr (sc, wrap_string (sc, "set! vector-typer", 17), 1, vec, - sc->type_names[T_VECTOR]); - if (is_immutable_vector (vec)) - immutable_object_error_nr ( - sc, - set_elist_2 ( - sc, - wrap_string ( - sc, "~S is immutable so its vector-typer can't be set!", 49), - vec)); - if (!is_t_vector (vec)) { - if (((is_int_vector (vec)) && - (typer != global_value (sc->is_integer_symbol))) || - ((is_float_vector (vec)) && - (typer != global_value (sc->is_float_symbol))) || - ((is_complex_vector (vec)) && - (typer != global_value (sc->is_number_symbol))) || - ((is_byte_vector (vec)) && - (typer != global_value (sc->is_byte_symbol)))) - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_3 ( - sc, wrap_string (sc, "vector-typer can't set ~S typer to ~S", 37), - vec, typer)); - return (typer); - } - if (is_boolean (typer)) { - if (is_typed_vector (vec)) { - typed_vector_set_typer (vec, sc->F); - clear_typed_vector (vec); - clear_has_simple_elements (vec); /* 15-Oct-23 */ - } - } - else { - if (is_c_function (typer)) - check_vector_typer_c_function (sc, sc->vector_typer_symbol, - typer); /* this is just error checking */ - else { - s7_pointer typer_name; - if (!is_any_closure (typer)) - wrong_type_error_nr ( - sc, sc->vector_typer_symbol, 2, typer, - wrap_string (sc, "a built-in procedure, a closure, #f or #t", 41)); - typer_name= find_typer (sc, typer); - if (!is_symbol (typer_name)) - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_2 ( - sc, - wrap_string ( - sc, "can't set! vector-typer to ~A because it has no name", - 52), - typer)); - } - set_typed_vector (vec); - typed_vector_set_typer (vec, typer); - if ((is_c_function (typer)) && (c_function_has_simple_elements (typer))) - set_has_simple_elements (vec); - else clear_has_simple_elements (vec); /* 15-Oct-23 */ - } - return (typer); +static s7_pointer g_set_vector_typer(s7_scheme *sc, s7_pointer args) +{ + s7_pointer vec = car(args), typer = cadr(args); + + if (!is_any_vector(vec)) + wrong_type_error_nr(sc, wrap_string(sc, "set! vector-typer", 17), 1, vec, sc->type_names[T_VECTOR]); + if (is_immutable_vector(vec)) + immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "~S is immutable so its vector-typer can't be set!", 49), vec)); + if (!is_t_vector(vec)) + { + if (((is_int_vector(vec)) && (typer != global_value(sc->is_integer_symbol))) || + ((is_float_vector(vec)) && (typer != global_value(sc->is_float_symbol))) || + ((is_complex_vector(vec)) && (typer != global_value(sc->is_number_symbol))) || + ((is_byte_vector(vec)) && (typer != global_value(sc->is_byte_symbol)))) + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, wrap_string(sc, "vector-typer can't set ~S typer to ~S", 37), vec, typer)); + return(typer); + } + if (is_boolean(typer)) + { + if (is_typed_vector(vec)) + { + typed_vector_set_typer(vec, sc->F); + clear_typed_vector(vec); + clear_has_simple_elements(vec); /* 15-Oct-23 */ + }} + else + { + if (is_c_function(typer)) + check_vector_typer_c_function(sc, sc->vector_typer_symbol, typer); /* this is just error checking */ + else + { + s7_pointer typer_name; + if (!is_any_closure(typer)) + wrong_type_error_nr(sc, sc->vector_typer_symbol, 2, typer, wrap_string(sc, "a built-in procedure, a closure, #f or #t", 41)); + typer_name = find_typer(sc, typer); + if (!is_symbol(typer_name)) + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set! vector-typer to ~A because it has no name", 52), typer)); + } + set_typed_vector(vec); + typed_vector_set_typer(vec, typer); + if ((is_c_function(typer)) && + (c_function_has_simple_elements(typer))) + set_has_simple_elements(vec); + else clear_has_simple_elements(vec); /* 15-Oct-23 */ + } + return(typer); } -/* -------------------------------- multivector -------------------------------- - */ + +/* -------------------------------- multivector -------------------------------- */ #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) { +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))) + * 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_pointer vals= lst; - for (s7_int i= 0; i < sizes[dimension]; i++, vals= cdr (vals)) { - if (!is_pair (vals)) return (MULTIVECTOR_NOT_ENOUGH_ELEMENTS); - if (dimension == (dimensions - 1)) - vector_setter (vec) (sc, vec, flat_ref++, car (vals)); - else { - flat_ref= traverse_vector_data (sc, vec, flat_ref, dimension + 1, - dimensions, sizes, car (vals)); - if (flat_ref < 0) return (flat_ref); - } - } - return ((is_null (vals)) ? flat_ref : MULTIVECTOR_TOO_MANY_ELEMENTS); + s7_pointer vals = lst; + for (s7_int i = 0; i < sizes[dimension]; i++, vals = cdr(vals)) + { + if (!is_pair(vals)) + return(MULTIVECTOR_NOT_ENOUGH_ELEMENTS); + if (dimension == (dimensions - 1)) + vector_setter(vec)(sc, vec, flat_ref++, car(vals)); + else + { + flat_ref = traverse_vector_data(sc, vec, flat_ref, dimension + 1, dimensions, sizes, car(vals)); + if (flat_ref < 0) return(flat_ref); + }} + return((is_null(vals)) ? 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 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)); +s7_pointer proper_list_reverse_in_place(s7_scheme *sc, s7_pointer list) +{ + return(reverse_in_place_unchecked(sc, sc->nil, list)); } -static no_return void -multivector_error_nr (s7_scheme* sc, const char* message, s7_pointer data) { - error_nr ( - 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 no_return void multivector_error_nr(s7_scheme *sc, const char *message, s7_pointer data) +{ + error_nr(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) { +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 vals= data; - s7_int* sizes; + s7_pointer vals = data; + 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 + * #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] */ - error_nr (sc, sc->out_of_range_symbol, - set_elist_2 ( - sc, - wrap_string ( - sc, "#nD(...) dimensions, ~A, should be 1 or more", 44), - wrap_integer (sc, dims))); - - if (dims > sc->max_vector_dimensions) /* probably can't happen -- caught in - read_sharp? */ - error_nr ( - sc, sc->out_of_range_symbol, - set_elist_3 (sc, - wrap_string (sc, - "#nD(...) dimensions, ~D, should be less " - "that (*s7* 'max-vector-dimensions): ~D", - 78), - wrap_integer (sc, dims), - wrap_integer (sc, sc->max_vector_dimensions))); - if (is_null (data)) /* dims are already 0 (calloc above) */ - return ( - g_make_vector (sc, set_plist_1 (sc, make_list (sc, dims, int_zero)))); - - sc->w= sc->nil; - sizes= (s7_int*) Malloc (dims * sizeof (s7_int)); - for (s7_int i= 0; i < dims; i++) { - sizes[i]= proper_list_length (vals); - sc->w = cons (sc, make_integer (sc, sizes[i]), sc->w); - vals = car (vals); - if ((i < (dims - 1)) && (!is_pair (vals))) { - free (sizes); - multivector_error_nr ( - sc, "we need a list that fully specifies the vector's elements", - data); - } - } + if (dims <= 0) /* #0d(...) #2147483649D() [if dims is int32_t this is negative] */ + error_nr(sc, sc->out_of_range_symbol, + set_elist_2(sc, wrap_string(sc, "#nD(...) dimensions, ~A, should be 1 or more", 44), wrap_integer(sc, dims))); + + if (dims > sc->max_vector_dimensions) /* probably can't happen -- caught in read_sharp? */ + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "#nD(...) dimensions, ~D, should be less that (*s7* 'max-vector-dimensions): ~D", 78), + wrap_integer(sc, dims), wrap_integer(sc, sc->max_vector_dimensions))); + if (is_null(data)) /* dims are already 0 (calloc above) */ + return(g_make_vector(sc, set_plist_1(sc, make_list(sc, dims, int_zero)))); + + sc->w = sc->nil; + sizes = (s7_int *)Malloc(dims * sizeof(s7_int)); + for (s7_int i = 0; i < dims; i++) + { + sizes[i] = proper_list_length(vals); + sc->w = cons(sc, make_integer(sc, sizes[i]), sc->w); + vals = car(vals); + if ((i < (dims - 1)) && + (!is_pair(vals))) + { + free(sizes); + multivector_error_nr(sc, "we need a list that fully specifies the vector's elements", data); + }} { - s7_pointer vec= g_make_vector ( - sc, set_plist_1 (sc, sc->w= proper_list_reverse_in_place (sc, sc->w))); - s7_int vec_loc= gc_protect_1 (sc, vec); + s7_pointer vec = g_make_vector(sc, set_plist_1(sc, sc->w = proper_list_reverse_in_place(sc, sc->w))); + s7_int vec_loc = gc_protect_1(sc, vec); s7_int err; - sc->w= sc->unused; + sc->w = sc->unused; /* 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); + err = traverse_vector_data(sc, vec, 0, 0, dims, sizes, data); + free(sizes); + s7_gc_unprotect_at(sc, vec_loc); if (err < 0) - multivector_error_nr (sc, - (err == MULTIVECTOR_TOO_MANY_ELEMENTS) - ? "found too many elements" - : "not enough elements found", - data); - return (vec); + multivector_error_nr(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) { - s7_pointer* src; - s7_int len; - sc->value= g_multivector (sc, dims, data); - src = (s7_pointer*) vector_elements (sc->value); - len = vector_length (sc->value); - for (s7_int i= 0; i < len; i++) - if (!is_t_integer (src[i])) - wrong_type_error_nr (sc, wrap_string (sc, "#i(...)", 7), i + 1, src[i], - sc->type_names[T_INTEGER]); - sc->args= s7i_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) { - s7_pointer* src; - s7_int len; - sc->value= g_multivector (sc, dims, data); - src = (s7_pointer*) vector_elements (sc->value); - len = vector_length (sc->value); - for (s7_int i= 0; i < len; i++) - if (!is_byte (src[i])) - wrong_type_error_nr (sc, wrap_string (sc, "#u8(...)", 8), i + 1, src[i], - wrap_string (sc, "a byte", 6)); - sc->args= s7i_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) { - s7_pointer* src; - s7_int len; - sc->value= g_multivector (sc, dims, data); - src = (s7_pointer*) vector_elements (sc->value); - len = vector_length (sc->value); - for (s7_int i= 0; i < len; i++) - if (!is_real (src[i])) - wrong_type_error_nr (sc, wrap_string (sc, "#r(...)", 7), i + 1, src[i], - sc->type_names[T_REAL]); - sc->args= s7i_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 s7_pointer -g_complex_multivector (s7_scheme* sc, s7_int dims, s7_pointer data) { - s7_pointer* src; - s7_int len; - sc->value= g_multivector (sc, dims, data); - src = (s7_pointer*) vector_elements (sc->value); - len = vector_length (sc->value); - for (s7_int i= 0; i < len; i++) - if (!is_number (src[i])) - wrong_type_error_nr (sc, wrap_string (sc, "#c(...)", 7), i + 1, src[i], - sc->type_names[T_COMPLEX]); - sc->args= s7i_make_vector_1 ( - sc, - set_plist_2 (sc, g_vector_dimensions (sc, set_plist_1 (sc, sc->value)), - real_zero), - sc->make_complex_vector_symbol); - return (s7_copy_1 (sc, sc->complex_vector_symbol, - set_plist_2 (sc, sc->value, sc->args))); -} - -static Vectorized s7_pointer -s7_vector_copy_1 (s7_scheme* sc, s7_pointer old_vec) { - const s7_int len= vector_length (old_vec); - s7_pointer new_vec; - - if (is_t_vector (old_vec)) { - const s7_pointer* src= (const s7_pointer*) vector_elements (old_vec); - if ((is_typed_vector (old_vec)) && - (len > 0)) /* preserve the type info as well */ - { - if (vector_rank (old_vec) > 1) - new_vec= g_make_vector ( - sc, set_plist_3 ( - sc, g_vector_dimensions (sc, set_plist_1 (sc, old_vec)), - vector_element (old_vec, 0), typed_vector_typer (old_vec))); - else - new_vec= g_make_vector (sc, set_plist_3 (sc, make_integer (sc, len), - vector_element (old_vec, 0), - typed_vector_typer (old_vec))); - } - else if (vector_rank (old_vec) > 1) - new_vec= g_make_vector ( - sc, set_plist_1 ( - sc, g_vector_dimensions (sc, set_plist_1 (sc, old_vec)))); - else new_vec= 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) */ - { - s7_pointer* dst= (s7_pointer*) vector_elements (new_vec); - for (s7_int i= len; i > 0; i--) - *dst++= *src++; - } - return (new_vec); - } - if (is_float_vector (old_vec)) { - const s7_double* src= (s7_double*) float_vector_floats (old_vec); - s7_double* dst; - if (vector_rank (old_vec) > 1) - new_vec= s7i_make_vector_1 ( - sc, - set_plist_2 (sc, g_vector_dimensions (sc, set_plist_1 (sc, old_vec)), - real_zero), - sc->make_float_vector_symbol); - else new_vec= make_simple_float_vector (sc, len); - dst= (s7_double*) float_vector_floats (new_vec); - for (s7_int i= len; i > 0; i--) - *dst++= - *src++; /* same speed as memcpy(dst, src, len * sizeof(s7_double)); */ - return (new_vec); - } - if (is_int_vector (old_vec)) { - const s7_int* src= (s7_int*) int_vector_ints (old_vec); - s7_int* dst; - if (vector_rank (old_vec) > 1) - new_vec= s7i_make_vector_1 ( - sc, - set_plist_2 (sc, g_vector_dimensions (sc, set_plist_1 (sc, old_vec)), - int_zero), - sc->make_int_vector_symbol); - else new_vec= make_simple_int_vector (sc, len); - dst= (s7_int*) int_vector_ints (new_vec); - for (s7_int i= len; i > 0; i--) - *dst++= *src++; - return (new_vec); - } - if (is_byte_vector (old_vec)) { - const uint8_t* src= (const uint8_t*) byte_vector_bytes (old_vec); - uint8_t* dst; - if (vector_rank (old_vec) > 1) - new_vec= s7i_make_vector_1 ( - sc, - set_plist_2 (sc, g_vector_dimensions (sc, set_plist_1 (sc, old_vec)), - int_zero), - sc->make_byte_vector_symbol); - else new_vec= make_simple_byte_vector (sc, len); - dst= (uint8_t*) byte_vector_bytes (new_vec); - for (s7_int i= len; i > 0; i--) - *dst++= *src++; - return (new_vec); - } - if (is_complex_vector (old_vec)) { - const s7_complex* src= (s7_complex*) complex_vector_complexes (old_vec); - s7_complex* dst; - if (vector_rank (old_vec) > 1) - new_vec= s7i_make_vector_1 ( - sc, - set_plist_2 (sc, g_vector_dimensions (sc, set_plist_1 (sc, old_vec)), - real_zero), - sc->make_complex_vector_symbol); - else new_vec= make_simple_complex_vector (sc, len); - dst= (s7_complex*) complex_vector_complexes (new_vec); - for (s7_int i= len; i > 0; i--) - *dst++= *src++; - return (new_vec); - } - return (NULL); -} - -s7_pointer -s7_vector_copy (s7_scheme* sc, s7_pointer old_vec) { - return (s7_vector_copy_1 (sc, old_vec)); -} /* repeated for Vectorized */ - -static s7_pointer -univect_ref (s7_scheme* sc, s7_pointer args, s7_pointer caller, int32_t typ) { - const s7_pointer vec= car (args); - s7_pointer index; - s7_int ind; - - if (type (vec) != typ) - return (method_or_bust (sc, vec, caller, args, sc->type_names[typ], 1)); - - if (vector_rank (vec) == 1) { - index= cadr (args); - if (!s7_is_integer (index)) - return (method_or_bust (sc, index, caller, args, - sc->type_names[T_INTEGER], 2)); - ind= s7_integer_clamped_if_gmp (sc, index); - if ((ind < 0) || (ind >= vector_length (vec))) - sole_arg_out_of_range_error_nr (sc, caller, index, - (ind < 0) ? it_is_negative_string - : it_is_too_large_string); - if (!is_null (cddr (args))) - out_of_range_error_nr (sc, caller, int_two, cdr (args), - too_many_indices_string); - } - else { - s7_int i; - s7_pointer indices; - ind= 0; - for (indices= cdr (args), i= 0; - (is_pair (indices)) && (i < vector_ndims (vec)); - indices= cdr (indices), i++) { - s7_int n; - index= car (indices); - if (!s7_is_integer (index)) - return (method_or_bust (sc, index, caller, args, - sc->type_names[T_INTEGER], i + 2)); - n= s7_integer_clamped_if_gmp (sc, index); - if ((n < 0) || (n >= vector_dimension (vec, i))) - out_of_range_error_nr (sc, caller, wrap_integer (sc, i + 2), index, - (n < 0) ? it_is_negative_string - : it_is_too_large_string); - ind+= n * vector_offset (vec, i); - } - if (is_not_null (indices)) - out_of_range_error_nr (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 (vec)) return (subvector (sc, vec, i, ind)); - } - if (typ == T_FLOAT_VECTOR) return (make_real (sc, float_vector (vec, ind))); - if (typ == T_COMPLEX_VECTOR) - return (make_complex (sc, creal (complex_vector (vec, ind)), - cimag (complex_vector (vec, ind)))); - return ((typ == T_INT_VECTOR) ? make_integer (sc, int_vector (vec, ind)) - : small_int (byte_vector (vec, ind))); -} - -static s7_pointer -univect_set (s7_scheme* sc, s7_pointer args, s7_pointer caller, int32_t typ) { - const s7_pointer vec= car (args); - s7_pointer val, index; - s7_int ind; - - if (type (vec) != typ) - return (method_or_bust (sc, vec, caller, args, sc->type_names[typ], 1)); - if (is_immutable_vector (vec)) - immutable_object_error_nr ( - sc, set_elist_3 (sc, immutable_error_string, caller, vec)); - - if (vector_rank (vec) > 1) { - s7_int i; - s7_pointer indices; - ind= 0; - for (indices= cdr (args), i= 0; - (is_pair (cdr (indices))) && (i < vector_ndims (vec)); - indices= cdr (indices), i++) { - s7_int n; - index= car (indices); - if (!s7_is_integer (index)) - return (method_or_bust (sc, index, caller, args, - sc->type_names[T_INTEGER], i + 2)); - n= s7_integer_clamped_if_gmp (sc, index); - if ((n < 0) || (n >= vector_dimension (vec, i))) - out_of_range_error_nr (sc, caller, wrap_integer (sc, i + 2), index, - (n < 0) ? it_is_negative_string - : it_is_too_large_string); - ind+= n * vector_offset (vec, i); - } - if (is_not_null (cdr (indices))) - error_nr (sc, sc->wrong_number_of_args_symbol, - set_elist_3 ( - sc, wrap_string (sc, "too many arguments for ~A: ~S", 29), - caller, args)); - if (i != vector_ndims (vec)) - error_nr (sc, sc->wrong_number_of_args_symbol, - set_elist_3 ( - sc, wrap_string (sc, "not enough arguments for ~A: ~S", 31), - caller, args)); - val= car (indices); - } - else { - s7_pointer indices= cdr (args); - if (is_null (indices)) - error_nr (sc, sc->wrong_number_of_args_symbol, - set_elist_3 ( - sc, wrap_string (sc, "not enough arguments for ~A: ~S", 31), - caller, args)); - /* from (set! (v) val) after optimization into op_set_opsq_a which is - * completely confused -- set! gets v's setter (float-vector-set!) */ - index= car (indices); - if (!s7_is_integer (index)) - return (method_or_bust (sc, index, caller, args, - sc->type_names[T_INTEGER], 2)); - ind= s7_integer_clamped_if_gmp (sc, index); - if ((ind < 0) || (ind >= vector_length (vec))) - out_of_range_error_nr (sc, caller, int_two, index, - (ind < 0) ? it_is_negative_string - : it_is_too_large_string); - if (is_not_null (cddr (indices))) - error_nr (sc, sc->wrong_number_of_args_symbol, - set_elist_3 ( - sc, wrap_string (sc, "too many arguments for ~A: ~S", 29), - caller, args)); - val= cadr (indices); - } - - if (typ == T_FLOAT_VECTOR) { - if (!is_real (val)) - return ( - method_or_bust (sc, val, caller, args, sc->type_names[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, sc->type_names[T_INTEGER], 3)); - int_vector (vec, ind)= s7_integer_clamped_if_gmp (sc, val); - } - else if (typ == T_BYTE_VECTOR) { - if (!is_byte (val)) - return ( - method_or_bust (sc, val, caller, args, sc->type_names[T_INTEGER], 3)); - byte_vector (vec, ind)= (uint8_t) s7_integer_clamped_if_gmp (sc, val); - } - else { - if (!is_number (val)) - return ( - method_or_bust (sc, val, caller, args, sc->type_names[T_COMPLEX], 3)); - complex_vector (vec, ind)= s7_to_c_complex (val); - } - return (val); -} - -/* -------------------------------- complex-vector-ref - * -------------------------------- */ -static s7_pointer -g_complex_vector_ref (s7_scheme* sc, s7_pointer args) { -#define H_complex_vector_ref \ - "(complex-vector-ref v ...) returns an element of the complex-vector v." -#define Q_complex_vector_ref \ - s7_make_circular_signature ( \ - sc, 2, 3, \ - s7_make_signature (sc, 2, sc->is_complex_symbol, \ - sc->is_complex_vector_symbol), \ - sc->is_complex_vector_symbol, sc->is_integer_symbol) - return ( - univect_ref (sc, args, sc->complex_vector_ref_symbol, T_COMPLEX_VECTOR)); -} - -static s7_pointer -complex_vector_ref_p_pp (s7_scheme* sc, s7_pointer vec, s7_pointer index) { - if (!is_complex_vector (vec)) - return (method_or_bust_pp (sc, vec, sc->complex_vector_ref_symbol, vec, - index, sc->type_names[T_COMPLEX_VECTOR], 1)); - if (vector_rank (vec) != 1) - return (univect_ref (sc, set_plist_2 (sc, vec, index), - sc->complex_vector_ref_symbol, T_COMPLEX_VECTOR)); - if (!s7_is_integer (index)) - return (method_or_bust_pp (sc, index, sc->complex_vector_ref_symbol, vec, - index, sc->type_names[T_INTEGER], 2)); - { - s7_int ind= s7_integer_clamped_if_gmp (sc, index); - if ((ind < 0) || (ind >= vector_length (vec))) - out_of_range_error_nr (sc, sc->complex_vector_ref_symbol, int_two, index, - (ind < 0) ? it_is_negative_string - : it_is_too_large_string); - return (c_complex_to_s7 (sc, complex_vector (vec, ind))); - } +static s7_pointer g_int_multivector(s7_scheme *sc, s7_int dims, s7_pointer data) +{ + s7_pointer *src; + s7_int len; + sc->value = g_multivector(sc, dims, data); + src = (s7_pointer *)vector_elements(sc->value); + len = vector_length(sc->value); + for (s7_int i = 0; i < len; i++) + if (!is_t_integer(src[i])) + wrong_type_error_nr(sc, wrap_string(sc, "#i(...)", 7), i + 1, src[i], sc->type_names[T_INTEGER]); + sc->args = s7i_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))); } -s7_pointer -s7i_complex_vector_ref_p_pp (s7_scheme* sc, s7_pointer vec, s7_pointer index) { - return (complex_vector_ref_p_pp (sc, vec, index)); +static s7_pointer g_byte_multivector(s7_scheme *sc, s7_int dims, s7_pointer data) +{ + s7_pointer *src; + s7_int len; + sc->value = g_multivector(sc, dims, data); + src = (s7_pointer *)vector_elements(sc->value); + len = vector_length(sc->value); + for (s7_int i = 0; i < len; i++) + if (!is_byte(src[i])) + wrong_type_error_nr(sc, wrap_string(sc, "#u8(...)", 8), i + 1, src[i], wrap_string(sc, "a byte", 6)); + sc->args = s7i_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 -complex_vector_ref_p_pi (s7_scheme* sc, s7_pointer vec, s7_int index) { - if ((!is_complex_vector (vec)) || (vector_rank (vec) > 1) || (index < 0) || - (index >= vector_length (vec))) - return (g_complex_vector_ref ( - sc, set_plist_2 (sc, vec, make_integer (sc, index)))); - return (c_complex_to_s7 (sc, complex_vector (vec, index))); +static s7_pointer g_float_multivector(s7_scheme *sc, s7_int dims, s7_pointer data) +{ + s7_pointer *src; + s7_int len; + sc->value = g_multivector(sc, dims, data); + src = (s7_pointer *)vector_elements(sc->value); + len = vector_length(sc->value); + for (s7_int i = 0; i < len; i++) + if (!is_real(src[i])) + wrong_type_error_nr(sc, wrap_string(sc, "#r(...)", 7), i + 1, src[i], sc->type_names[T_REAL]); + sc->args = s7i_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 s7_pointer -complex_vector_ref_p_pi_wrapped (s7_scheme* sc, s7_pointer vec, s7_int index) { - s7_complex z; - if ((!is_complex_vector (vec)) || (vector_rank (vec) > 1) || (index < 0) || - (index >= vector_length (vec))) - return (g_complex_vector_ref ( - sc, set_plist_2 (sc, vec, make_integer (sc, index)))); - z= complex_vector (vec, index); - return (wrap_complex (sc, creal (z), cimag (z))); -} - -static s7_pointer -complex_vector_ref_p_pi_direct (s7_scheme* sc, s7_pointer vec, s7_int index) { - return (c_complex_to_s7 (sc, complex_vector (vec, index))); -} - -static s7_pointer -complex_vector_ref_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer unused_expr) { - return ((args == 2) ? sc->cv_ref_2 : func); -} - -/* -------------------------------- complex-vector-set! - * -------------------------------- */ -static s7_pointer -g_complex_vector_set (s7_scheme* sc, s7_pointer args) { -#define H_complex_vector_set \ - "(complex-vector-set! v i ... value) sets the i-th element of the " \ - "complex-vector v to value." -#define Q_complex_vector_set \ - s7_make_circular_signature ( \ - sc, 3, 4, sc->is_complex_symbol, sc->is_complex_vector_symbol, \ - sc->is_integer_symbol, sc->is_integer_or_number_at_end_symbol) - return ( - univect_set (sc, args, sc->complex_vector_set_symbol, T_COMPLEX_VECTOR)); -} - -static s7_pointer -complex_vector_set_p_pip (s7_scheme* sc, s7_pointer vec, s7_int index, - s7_pointer value) { - if ((!is_complex_vector (vec)) || (!is_number (value)) || - (vector_rank (vec) > 1) || (index < 0) || (index >= vector_length (vec))) - return (univect_set (sc, - set_plist_3 (sc, vec, make_integer (sc, index), value), - sc->complex_vector_set_symbol, T_COMPLEX_VECTOR)); - complex_vector (vec, index)= s7_to_c_complex (value); - return (value); -} - -static s7_pointer -complex_vector_set_p_pip_unchecked (s7_scheme* sc, s7_pointer vec, s7_int index, - s7_pointer value) { - if ((index >= 0) && (index < vector_length (vec))) - complex_vector (vec, index)= s7_to_c_complex (value); - else - out_of_range_error_nr ( - sc, sc->complex_vector_set_symbol, int_two, wrap_integer (sc, index), - (index < 0) ? it_is_negative_string : it_is_too_large_string); - return (value); -} - -static s7_pointer -complex_vector_set_p_pip_direct (s7_scheme* sc, s7_pointer vec, s7_int index, - s7_pointer value) { - complex_vector (vec, index)= s7_to_c_complex (value); - return (value); -} - -static s7_pointer -complex_vector_set_p_ppp (s7_scheme* sc, s7_pointer vec, s7_pointer index, - s7_pointer value) { - if (!is_complex_vector (vec)) - return (method_or_bust_ppp (sc, vec, sc->complex_vector_set_symbol, vec, - index, value, sc->type_names[T_COMPLEX_VECTOR], - 1)); - if (vector_rank (vec) != 1) - return (univect_set (sc, set_plist_3 (sc, vec, index, value), - sc->complex_vector_set_symbol, T_COMPLEX_VECTOR)); - if (is_immutable_vector (vec)) - immutable_object_error_nr (sc, set_elist_3 (sc, immutable_error_string, - sc->complex_vector_set_symbol, - vec)); - if (!s7_is_integer (index)) - return (method_or_bust_ppp (sc, index, sc->complex_vector_set_symbol, vec, - index, value, sc->type_names[T_INTEGER], 2)); - if (!s7_is_number (value)) - return (method_or_bust_ppp (sc, value, sc->complex_vector_set_symbol, vec, - index, value, sc->type_names[T_COMPLEX], 3)); - { - s7_int i= integer (index); - if ((i < 0) || (i >= vector_length (vec))) - out_of_range_error_nr (sc, sc->complex_vector_set_symbol, int_two, index, - (i < 0) ? it_is_negative_string - : it_is_too_large_string); - complex_vector (vec, i)= s7_to_c_complex (value); - } - return (value); -} - -s7_pointer -s7i_complex_vector_set_p_ppp (s7_scheme* sc, s7_pointer vec, s7_pointer index, - s7_pointer value) { - return (complex_vector_set_p_ppp (sc, vec, index, value)); -} - -/* static s7_pointer g_cv_set_3_nr(s7_scheme *sc, s7_pointer args) - * {return(complex_vector_set_p_ppp_nr(sc, car(args), cadr(args), - * caddr(args)));} */ - -static s7_pointer -complex_vector_set_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer expr) { - return ((args == 3) ? sc->cv_set_3 : func); -} - -/* -------------------------------- 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 vec, s7_pointer index) { - if (!is_float_vector (vec)) - return (method_or_bust_pp (sc, vec, sc->float_vector_ref_symbol, vec, index, - sc->type_names[T_FLOAT_VECTOR], 1)); - if (vector_rank (vec) != 1) - return (univect_ref (sc, set_plist_2 (sc, vec, 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, vec, - index, sc->type_names[T_INTEGER], 2)); - { - s7_int ind= s7_integer_clamped_if_gmp (sc, index); - if ((ind < 0) || (ind >= vector_length (vec))) - out_of_range_error_nr (sc, sc->float_vector_ref_symbol, int_two, index, - (ind < 0) ? it_is_negative_string - : it_is_too_large_string); - return (make_real (sc, float_vector (vec, ind))); - } +static s7_pointer g_complex_multivector(s7_scheme *sc, s7_int dims, s7_pointer data) +{ + s7_pointer *src; + s7_int len; + sc->value = g_multivector(sc, dims, data); + src = (s7_pointer *)vector_elements(sc->value); + len = vector_length(sc->value); + for (s7_int i = 0; i < len; i++) + if (!is_number(src[i])) + wrong_type_error_nr(sc, wrap_string(sc, "#c(...)", 7), i + 1, src[i], sc->type_names[T_COMPLEX]); + sc->args = s7i_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, sc->value)), real_zero), sc->make_complex_vector_symbol); + return(s7_copy_1(sc, sc->complex_vector_symbol, set_plist_2(sc, sc->value, sc->args))); } -s7_pointer -s7i_float_vector_ref_p_pp (s7_scheme* sc, s7_pointer vec, s7_pointer index) { - return (float_vector_ref_p_pp (sc, vec, index)); -} - -static s7_pointer -g_fv_ref_3 (s7_scheme* sc, s7_pointer args) { - const s7_pointer fv= car (args); - s7_pointer index; - s7_int ind1, ind2; - if (!is_float_vector (fv)) - return (method_or_bust (sc, fv, sc->float_vector_ref_symbol, args, - sc->type_names[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, - sc->type_names[T_INTEGER], 2)); - ind1= s7_integer_clamped_if_gmp (sc, index); - if ((ind1 < 0) || (ind1 >= vector_dimension (fv, 0))) - out_of_range_error_nr (sc, sc->float_vector_ref_symbol, int_two, index, - (ind1 < 0) ? it_is_negative_string - : it_is_too_large_string); - index= caddr (args); - if (!s7_is_integer (index)) - return (method_or_bust (sc, index, sc->float_vector_ref_symbol, args, - sc->type_names[T_INTEGER], 3)); - ind2= s7_integer_clamped_if_gmp (sc, index); - if ((ind2 < 0) || (ind2 >= vector_dimension (fv, 1))) - out_of_range_error_nr (sc, sc->float_vector_ref_symbol, int_three, index, - (ind2 < 0) ? it_is_negative_string - : it_is_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 vec, s7_int index) { - /* according to callgrind, it is faster to split out the bounds check */ - if ((index < 0) || (index >= vector_length (vec))) - out_of_range_error_nr ( - sc, sc->float_vector_ref_symbol, int_two, wrap_integer (sc, index), - (index < 0) ? it_is_negative_string : it_is_too_large_string); - return (index); -} - -static s7_pointer -float_vector_set_p_pip (s7_scheme* sc, s7_pointer vec, s7_int index, - s7_pointer value) { - if ((!is_float_vector (vec)) || (!is_real (value)) || - (vector_rank (vec) > 1) || (index < 0) || (index >= vector_length (vec))) - return (univect_set (sc, - set_plist_3 (sc, vec, make_integer (sc, index), value), - sc->float_vector_set_symbol, T_FLOAT_VECTOR)); - float_vector (vec, index)= s7_real (value); - return (value); -} - -static inline s7_double -float_vector_ref_d_7pi (s7_scheme* sc, s7_pointer vec, s7_int index) { - return (float_vector (vec, ref_check_index (sc, vec, index))); -} -static double -float_vector_ref_d_7pi_direct (s7_scheme* sc, s7_pointer vec, s7_int index) { - return (float_vector (vec, index)); -} -static s7_pointer -float_vector_ref_p_pi_direct (s7_scheme* sc, s7_pointer vec, s7_int index) { - return (make_real (sc, float_vector (vec, index))); -} -static s7_pointer -float_vector_ref_p_pi_direct_wrapped (s7_scheme* sc, s7_pointer vec, - s7_int index) { - return (wrap_real (sc, float_vector (vec, index))); -} - -static inline s7_double -float_vector_ref_d_7pii (s7_scheme* sc, s7_pointer vec, s7_int i1, s7_int i2) { - if ((i1 < 0) || (i1 >= vector_dimension (vec, 0))) - out_of_range_error_nr ( - sc, sc->float_vector_ref_symbol, int_two, wrap_integer (sc, i1), - (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i2 < 0) || (i2 >= vector_dimension (vec, 1))) - out_of_range_error_nr ( - sc, sc->float_vector_ref_symbol, int_three, wrap_integer (sc, i2), - (i2 < 0) ? it_is_negative_string : it_is_too_large_string); - return (float_vector (vec, i2 + (i1 * vector_offset (vec, 0)))); -} - -static s7_double -float_vector_ref_d_7piii (s7_scheme* sc, s7_pointer vec, s7_int i1, s7_int i2, - s7_int i3) { - if ((i1 < 0) || (i1 >= vector_dimension (vec, 0))) - out_of_range_error_nr ( - sc, sc->float_vector_ref_symbol, int_two, wrap_integer (sc, i1), - (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i2 < 0) || (i2 >= vector_dimension (vec, 1))) - out_of_range_error_nr ( - sc, sc->float_vector_ref_symbol, int_three, wrap_integer (sc, i2), - (i2 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i3 < 0) || (i3 >= vector_dimension (vec, 2))) - out_of_range_error_nr ( - sc, sc->float_vector_ref_symbol, small_int (4), wrap_integer (sc, i3), - (i3 < 0) ? it_is_negative_string : it_is_too_large_string); - return (float_vector (vec, i3 + (i2 * vector_offset (vec, 1)) + - (i1 * vector_offset (vec, 0)))); -} - -static s7_pointer -float_vector_ref_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer unused_expr) { - return ((args == 2) ? sc->fv_ref_2 : ((args == 3) ? sc->fv_ref_3 : func)); -} - -/* -------------------------------- 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) { - const s7_pointer fv= car (args); - s7_pointer index; - if (!is_float_vector (fv)) - return (method_or_bust (sc, fv, sc->float_vector_set_symbol, args, - sc->type_names[T_FLOAT_VECTOR], 1)); - if (vector_rank (fv) != 1) - return ( - univect_set (sc, args, sc->float_vector_set_symbol, T_FLOAT_VECTOR)); - if (is_immutable_vector (fv)) - immutable_object_error_nr (sc, - set_elist_3 (sc, immutable_error_string, - sc->float_vector_set_symbol, fv)); - index= cadr (args); - if (!s7_is_integer (index)) - return (method_or_bust (sc, index, sc->float_vector_set_symbol, args, - sc->type_names[T_INTEGER], 2)); - { - s7_int ind = s7_integer_clamped_if_gmp (sc, index); - s7_pointer value= caddr (args); - if ((ind < 0) || (ind >= vector_length (fv))) - out_of_range_error_nr (sc, sc->float_vector_set_symbol, int_two, index, - (ind < 0) ? it_is_negative_string - : it_is_too_large_string); - if (!is_real (value)) - return (method_or_bust (sc, value, sc->float_vector_set_symbol, args, - sc->type_names[T_REAL], 3)); - float_vector (fv, ind)= s7_real (value); - return (value); - } -} +static Vectorized s7_pointer s7_vector_copy_1(s7_scheme *sc, s7_pointer old_vec) +{ + const s7_int len = vector_length(old_vec); + s7_pointer new_vec; -static s7_pointer -g_fv_set_unchecked (s7_scheme* sc, s7_pointer args) { - const s7_pointer fv= car (args), value= caddr (args); - s7_int ind; - if (!is_real (value)) - wrong_type_error_nr (sc, sc->float_vector_set_symbol, 3, value, - sc->type_names[T_REAL]); - if (is_immutable_vector (fv)) - immutable_object_error_nr (sc, - set_elist_3 (sc, immutable_error_string, - sc->float_vector_set_symbol, fv)); - ind = s7_integer_clamped_if_gmp (sc, cadr (args)); - float_vector (fv, ind)= s7_real (value); - return (value); -} - -static bool -find_matching_ref (s7_scheme* sc, const s7_pointer getter, s7_pointer expr) { - /* expr: (*set! v i val), val exists (i.e. args=3, so cddddr is null) */ - const s7_pointer sym= cadr (expr), ind= caddr (expr); - if ((is_symbol (sym)) && (!is_pair (ind))) { - const s7_pointer val= cadddr (expr); - if (is_optimized (val)) /* includes is_pair */ - for (s7_pointer p= val; is_pair (p); p= cdr (p)) - if (is_pair (car (p))) { - const s7_pointer ref= car (p); - if (((car (ref) == getter) && /* (getter sym ind) */ - (is_proper_list_2 (sc, cdr (ref))) && (cadr (ref) == sym) && - (caddr (ref) == ind)) || - ((car (ref) == sym) && /* (sym ind) */ - (is_proper_list_1 (sc, cdr (ref))) && (cadr (ref) == ind))) - return (true); /* else keep looking */ - } - } - return (false); + if (is_t_vector(old_vec)) + { + const s7_pointer *src = (const s7_pointer *)vector_elements(old_vec); + if ((is_typed_vector(old_vec)) && (len > 0)) /* preserve the type info as well */ + { + if (vector_rank(old_vec) > 1) + new_vec = g_make_vector(sc, set_plist_3(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vec)), + vector_element(old_vec, 0), typed_vector_typer(old_vec))); + else new_vec = g_make_vector(sc, set_plist_3(sc, make_integer(sc, len), + vector_element(old_vec, 0), typed_vector_typer(old_vec))); + } + else + if (vector_rank(old_vec) > 1) + new_vec = g_make_vector(sc, set_plist_1(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vec)))); + else new_vec = 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) */ + { + s7_pointer *dst = (s7_pointer *)vector_elements(new_vec); + for (s7_int i = len; i > 0; i--) *dst++ = *src++; + } + return(new_vec); + } + if (is_float_vector(old_vec)) + { + const s7_double *src = (s7_double *)float_vector_floats(old_vec); + s7_double *dst; + if (vector_rank(old_vec) > 1) + new_vec = s7i_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vec)), real_zero), sc->make_float_vector_symbol); + else new_vec = make_simple_float_vector(sc, len); + dst = (s7_double *)float_vector_floats(new_vec); + for (s7_int i = len; i > 0; i--) *dst++ = *src++; /* same speed as memcpy(dst, src, len * sizeof(s7_double)); */ + return(new_vec); + } + if (is_int_vector(old_vec)) + { + const s7_int *src = (s7_int *)int_vector_ints(old_vec); + s7_int *dst; + if (vector_rank(old_vec) > 1) + new_vec = s7i_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vec)), int_zero), sc->make_int_vector_symbol); + else new_vec = make_simple_int_vector(sc, len); + dst = (s7_int *)int_vector_ints(new_vec); + for (s7_int i = len; i > 0; i--) *dst++ = *src++; + return(new_vec); + } + if (is_byte_vector(old_vec)) + { + const uint8_t *src = (const uint8_t *)byte_vector_bytes(old_vec); + uint8_t *dst; + if (vector_rank(old_vec) > 1) + new_vec = s7i_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vec)), int_zero), sc->make_byte_vector_symbol); + else new_vec = make_simple_byte_vector(sc, len); + dst = (uint8_t *)byte_vector_bytes(new_vec); + for (s7_int i = len; i > 0; i--) *dst++ = *src++; + return(new_vec); + } + if (is_complex_vector(old_vec)) + { + const s7_complex *src = (s7_complex *)complex_vector_complexes(old_vec); + s7_complex *dst; + if (vector_rank(old_vec) > 1) + new_vec = s7i_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vec)), real_zero), sc->make_complex_vector_symbol); + else new_vec = make_simple_complex_vector(sc, len); + dst = (s7_complex *)complex_vector_complexes(new_vec); + for (s7_int i = len; i > 0; i--) *dst++ = *src++; + return(new_vec); + } + return(NULL); } -static s7_pointer -float_vector_set_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer expr) { - if (args == 3) - return ((find_matching_ref (sc, sc->float_vector_ref_symbol, expr)) - ? sc->fv_set_unchecked - : sc->fv_set_3); - return (func); -} - -static s7_double -float_vector_set_d_7pid_direct (s7_scheme* unused_sc, s7_pointer vec, - s7_int index, s7_double x) { - float_vector (vec, index)= x; - return (x); -} - -static s7_int -set_check_index (s7_scheme* sc, s7_pointer vec, s7_int index) { - if ((index < 0) || (index >= vector_length (vec))) - out_of_range_error_nr ( - sc, sc->float_vector_set_symbol, int_two, wrap_integer (sc, index), - (index < 0) ? it_is_negative_string : it_is_too_large_string); - return (index); -} - -static s7_double -float_vector_set_d_7pid (s7_scheme* sc, s7_pointer vec, s7_int index, - s7_double x) { - float_vector (vec, set_check_index (sc, vec, index))= x; - return (x); -} - -static s7_double -float_vector_set_d_7piid (s7_scheme* sc, s7_pointer vec, s7_int i1, s7_int i2, - s7_double x) { - if ((i1 < 0) || (i1 >= vector_dimension (vec, 0))) - out_of_range_error_nr ( - sc, sc->float_vector_set_symbol, int_two, wrap_integer (sc, i1), - (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i2 < 0) || (i2 >= vector_dimension (vec, 1))) - out_of_range_error_nr ( - sc, sc->float_vector_set_symbol, int_three, wrap_integer (sc, i2), - (i2 < 0) ? it_is_negative_string : it_is_too_large_string); - float_vector (vec, i2 + (i1 * vector_offset (vec, 0)))= x; - return (x); -} - -static s7_double -float_vector_set_d_7piiid (s7_scheme* sc, s7_pointer vec, s7_int i1, s7_int i2, - s7_int i3, s7_double x) { - if ((i1 < 0) || (i1 >= vector_dimension (vec, 0))) - out_of_range_error_nr ( - sc, sc->float_vector_set_symbol, int_two, wrap_integer (sc, i1), - (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i2 < 0) || (i2 >= vector_dimension (vec, 1))) - out_of_range_error_nr ( - sc, sc->float_vector_set_symbol, int_three, wrap_integer (sc, i2), - (i2 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i3 < 0) || (i3 >= vector_dimension (vec, 2))) - out_of_range_error_nr ( - sc, sc->float_vector_set_symbol, small_int (4), wrap_integer (sc, i3), - (i3 < 0) ? it_is_negative_string : it_is_too_large_string); - float_vector (vec, i3 + (i2 * vector_offset (vec, 1)) + - (i1 * vector_offset (vec, 0)))= x; - return (x); -} - -static s7_pointer -float_vector_set_p_pip_direct (s7_scheme* sc, s7_pointer vec, s7_int index, - s7_pointer value) { - float_vector (vec, index)= real_to_double (sc, value, "float-vector-set!"); - return (value); -} - -static s7_pointer -float_vector_set_p_ppp (s7_scheme* sc, s7_pointer vec, s7_pointer ind, - s7_pointer val) { - s7_int index; - if ((!is_float_vector (vec)) || (vector_rank (vec) > 1)) - return (g_vector_set (sc, set_plist_3 (sc, vec, ind, val))); - if (is_immutable_vector (vec)) - immutable_object_error_nr (sc, - set_elist_3 (sc, immutable_error_string, - sc->float_vector_set_symbol, vec)); - if (!s7_is_integer (ind)) - return (g_vector_set (sc, set_plist_3 (sc, vec, ind, val))); - index= s7_integer_clamped_if_gmp (sc, ind); - if ((index < 0) || (index >= vector_length (vec))) - out_of_range_error_nr ( - sc, sc->float_vector_set_symbol, int_two, wrap_integer (sc, index), - (index < 0) ? it_is_negative_string : it_is_too_large_string); - if (!is_real (val)) - wrong_type_error_nr (sc, sc->float_vector_set_symbol, 3, val, - sc->type_names[T_REAL]); - float_vector (vec, index)= (is_t_real (val)) ? real (val) : s7_real (val); - return (val); -} - -/* -------------------------------- 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_i_pi_direct (s7_scheme* unused_sc, s7_pointer vec, - s7_int index) { - return (int_vector (vec, index)); -} -static s7_pointer -int_vector_ref_p_pi_direct (s7_scheme* sc, s7_pointer vec, s7_int index) { - return (make_integer (sc, int_vector (vec, index))); -} -static s7_pointer -int_vector_ref_p_pi_direct_wrapped (s7_scheme* sc, s7_pointer vec, - s7_int index) { - return (wrap_integer (sc, int_vector (vec, index))); -} - -static s7_int -int_vector_ref_i_7pi (s7_scheme* sc, s7_pointer vec, s7_int index) { - if ((index < 0) || (index >= vector_length (vec))) - out_of_range_error_nr ( - sc, sc->int_vector_ref_symbol, int_two, wrap_integer (sc, index), - (index < 0) ? it_is_negative_string : it_is_too_large_string); - return (int_vector (vec, index)); -} - -static s7_int -int_vector_ref_i_7pii (s7_scheme* sc, s7_pointer vec, s7_int i1, s7_int i2) { - if ((i1 < 0) || (i1 >= vector_dimension (vec, 0))) - out_of_range_error_nr ( - sc, sc->int_vector_ref_symbol, int_two, wrap_integer (sc, i1), - (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i2 < 0) || (i2 >= vector_dimension (vec, 1))) - out_of_range_error_nr ( - sc, sc->int_vector_ref_symbol, int_three, wrap_integer (sc, i2), - (i2 < 0) ? it_is_negative_string : it_is_too_large_string); - return (int_vector (vec, i2 + (i1 * vector_offset (vec, 0)))); -} - -static s7_int -int_vector_ref_i_7piii (s7_scheme* sc, s7_pointer vec, s7_int i1, s7_int i2, - s7_int i3) { - if ((i1 < 0) || (i1 >= vector_dimension (vec, 0))) - out_of_range_error_nr ( - sc, sc->int_vector_ref_symbol, int_two, wrap_integer (sc, i1), - (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i2 < 0) || (i2 >= vector_dimension (vec, 1))) - out_of_range_error_nr ( - sc, sc->int_vector_ref_symbol, int_three, wrap_integer (sc, i2), - (i2 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i3 < 0) || (i3 >= vector_dimension (vec, 2))) - out_of_range_error_nr ( - sc, sc->int_vector_ref_symbol, small_int (4), wrap_integer (sc, i3), - (i3 < 0) ? it_is_negative_string : it_is_too_large_string); - return (int_vector (vec, i3 + (i2 * vector_offset (vec, 1)) + - (i1 * vector_offset (vec, 0)))); -} - -static inline s7_pointer -int_vector_ref_p_pp (s7_scheme* sc, s7_pointer vec, s7_pointer index) { +s7_pointer s7_vector_copy(s7_scheme *sc, s7_pointer old_vec) {return(s7_vector_copy_1(sc, old_vec));} /* repeated for Vectorized */ + +static s7_pointer univect_ref(s7_scheme *sc, s7_pointer args, s7_pointer caller, int32_t typ) +{ + const s7_pointer vec = car(args); + s7_pointer index; s7_int ind; - if (!is_int_vector (vec)) - return (method_or_bust_pp (sc, vec, sc->int_vector_ref_symbol, vec, index, - sc->type_names[T_INT_VECTOR], 1)); - if (vector_rank (vec) != 1) - return (univect_ref (sc, set_plist_2 (sc, vec, 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, vec, index, - sc->type_names[T_INTEGER], 2)); - ind= s7_integer_clamped_if_gmp (sc, index); - if ((ind < 0) || (ind >= vector_length (vec))) - out_of_range_error_nr (sc, sc->int_vector_ref_symbol, int_two, index, - (ind < 0) ? it_is_negative_string - : it_is_too_large_string); - return (make_integer (sc, int_vector (vec, ind))); -} - -s7_pointer -s7i_int_vector_ref_p_pp (s7_scheme* sc, s7_pointer vec, s7_pointer index) { - return (int_vector_ref_p_pp (sc, vec, index)); -} - -static s7_pointer -g_iv_ref_3 (s7_scheme* sc, s7_pointer args) { - const s7_pointer ivec= car (args); - s7_pointer index; - s7_int ind1, ind2; - if (!is_int_vector (ivec)) - return (method_or_bust (sc, ivec, sc->int_vector_ref_symbol, args, - sc->type_names[T_INT_VECTOR], 1)); - if (vector_rank (ivec) != 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, - sc->type_names[T_INTEGER], 2)); - ind1= s7_integer_clamped_if_gmp (sc, index); - if ((ind1 < 0) || (ind1 >= vector_dimension (ivec, 0))) - out_of_range_error_nr (sc, sc->int_vector_ref_symbol, int_two, index, - (ind1 < 0) ? it_is_negative_string - : it_is_too_large_string); - index= caddr (args); - if (!s7_is_integer (index)) - return (method_or_bust (sc, index, sc->int_vector_ref_symbol, args, - sc->type_names[T_INTEGER], 3)); - ind2= s7_integer_clamped_if_gmp (sc, index); - if ((ind2 < 0) || (ind2 >= vector_dimension (ivec, 1))) - out_of_range_error_nr (sc, sc->int_vector_ref_symbol, int_three, index, - (ind2 < 0) ? it_is_negative_string - : it_is_too_large_string); - ind1= ind1 * vector_offset (ivec, 0) + ind2; - return (make_integer (sc, int_vector (ivec, ind1))); -} - -static s7_pointer -int_vector_ref_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer unused_expr) { - return ((args == 2) ? sc->iv_ref_2 : ((args == 3) ? sc->iv_ref_3 : func)); -} - -/* -------------------------------- 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_i_7pii_direct (s7_scheme* unused_sc, s7_pointer vec, - s7_int index, s7_int x) { - int_vector (vec, index)= x; - return (x); -} - -static s7_pointer -int_vector_set_p_pip (s7_scheme* sc, s7_pointer vec, s7_int index, - s7_pointer value) { - if ((!is_int_vector (vec)) || (!is_t_integer (value)) || - (vector_rank (vec) > 1) || (index < 0) || (index >= vector_length (vec))) - return (univect_set (sc, - set_plist_3 (sc, vec, make_integer (sc, index), value), - sc->int_vector_set_symbol, T_INT_VECTOR)); - int_vector (vec, index)= integer (value); - return (value); -} - -static s7_pointer -int_vector_set_p_pip_direct (s7_scheme* sc, s7_pointer vec, s7_int index, - s7_pointer value) { - int_vector (vec, index)= s7_integer_clamped_if_gmp (sc, value); - return (value); -} - -static s7_int -int_vector_set_i_7pii (s7_scheme* sc, s7_pointer vec, s7_int index, s7_int x) { - if ((index < 0) || (index >= vector_length (vec))) - out_of_range_error_nr ( - sc, sc->int_vector_set_symbol, int_two, wrap_integer (sc, index), - (index < 0) ? it_is_negative_string : it_is_too_large_string); - int_vector (vec, index)= x; - return (x); -} - -static s7_int -int_vector_set_i_7piii (s7_scheme* sc, s7_pointer vec, s7_int i1, s7_int i2, - s7_int i3) { - if ((i1 < 0) || (i1 >= vector_dimension (vec, 0))) - out_of_range_error_nr ( - sc, sc->int_vector_set_symbol, int_two, wrap_integer (sc, i1), - (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i2 < 0) || (i2 >= vector_dimension (vec, 1))) - out_of_range_error_nr ( - sc, sc->int_vector_set_symbol, int_three, wrap_integer (sc, i2), - (i2 < 0) ? it_is_negative_string : it_is_too_large_string); - int_vector (vec, i2 + (i1 * vector_offset (vec, 0)))= i3; - return (i3); -} - -static s7_pointer -int_vector_set_p_ppp (s7_scheme* sc, s7_pointer vec, s7_pointer index, - s7_pointer value) { - if ((is_int_vector (vec)) && (vector_rank (vec) == 1) && - (!is_immutable_vector (vec)) && (is_t_integer (index)) && - (is_t_integer (value))) { - s7_int i= integer (index); - if ((i < 0) || (i >= vector_length (vec))) - out_of_range_error_nr (sc, sc->int_vector_set_symbol, int_two, index, - (i < 0) ? it_is_negative_string - : it_is_too_large_string); - int_vector (vec, i)= integer (value); - } - else { - if (!is_int_vector (vec)) - return (method_or_bust_ppp (sc, vec, sc->int_vector_set_symbol, vec, - index, value, sc->type_names[T_INT_VECTOR], - 1)); - if (vector_rank (vec) != 1) - return (univect_set (sc, set_plist_3 (sc, vec, index, value), - sc->int_vector_set_symbol, T_INT_VECTOR)); - if (is_immutable_vector (vec)) - immutable_object_error_nr (sc, - set_elist_3 (sc, immutable_error_string, - sc->int_vector_set_symbol, vec)); - /* (int-vector-set! #i() `(x 1) (abs x)) in a do loop in a function... */ - if (!s7_is_integer (index)) - return (method_or_bust_ppp (sc, index, sc->int_vector_set_symbol, vec, - index, value, sc->type_names[T_INTEGER], 2)); - if (!s7_is_integer (value)) - return (method_or_bust_ppp (sc, value, sc->int_vector_set_symbol, vec, - index, value, sc->type_names[T_INTEGER], 3)); - if (S7_DEBUGGING) - fprintf (stderr, "fell through %s[%d]\n", __func__, __LINE__); - } - return (value); -} - -static s7_pointer -g_iv_set_3 (s7_scheme* sc, s7_pointer args) { - const s7_pointer vec= car (args); - s7_pointer index; - s7_int ind; - if (!is_int_vector (vec)) - return (method_or_bust (sc, vec, sc->int_vector_set_symbol, args, - sc->type_names[T_INT_VECTOR], 1)); - if (vector_rank (vec) != 1) - return (univect_set (sc, args, sc->int_vector_set_symbol, T_INT_VECTOR)); - if (is_immutable_vector (vec)) - immutable_object_error_nr (sc, - set_elist_3 (sc, immutable_error_string, - sc->int_vector_set_symbol, vec)); - index= cadr (args); - if (!s7_is_integer (index)) - return (method_or_bust (sc, index, sc->int_vector_set_symbol, args, - sc->type_names[T_INTEGER], 2)); - ind= s7_integer_clamped_if_gmp (sc, index); - if ((ind < 0) || (ind >= vector_length (vec))) - out_of_range_error_nr (sc, sc->int_vector_set_symbol, int_two, index, - (ind < 0) ? it_is_negative_string - : it_is_too_large_string); - { - s7_pointer value= caddr (args); - if (!s7_is_integer (value)) - return (method_or_bust (sc, value, sc->int_vector_set_symbol, args, - sc->type_names[T_INTEGER], 3)); - int_vector (vec, ind)= s7_integer_clamped_if_gmp (sc, value); - return (value); - } -} -static s7_pointer -int_vector_set_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer unused_expr) { - return ((args == 3) ? sc->iv_set_3 : func); -} - -/* -------------------------------- 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 vec, s7_int index) { - if ((index < 0) || (index >= byte_vector_length (vec))) - out_of_range_error_nr ( - sc, sc->byte_vector_ref_symbol, int_two, wrap_integer (sc, index), - (index < 0) ? it_is_negative_string : it_is_too_large_string); - return ((s7_int) ((byte_vector (vec, index)))); -} - -static s7_int -byte_vector_ref_i_7pii (s7_scheme* sc, s7_pointer vec, s7_int index1, - s7_int index2) { - if ((index1 < 0) || (index1 >= vector_dimension (vec, 0))) - out_of_range_error_nr ( - sc, sc->byte_vector_ref_symbol, int_two, wrap_integer (sc, index1), - (index1 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((index2 < 0) || (index2 >= vector_dimension (vec, 1))) - out_of_range_error_nr ( - sc, sc->byte_vector_ref_symbol, int_three, wrap_integer (sc, index2), - (index2 < 0) ? it_is_negative_string : it_is_too_large_string); - return ( - (s7_int) byte_vector (vec, index2 + (index1 * vector_offset (vec, 0)))); -} - -static s7_pointer -byte_vector_ref_p_pi_direct (s7_scheme* unused_sc, s7_pointer vec, - s7_int index) { - return (small_int ((byte_vector (vec, index)))); -} -static s7_int -byte_vector_ref_i_7pi_direct (s7_scheme* unused_sc, s7_pointer vec, - s7_int index) { - return (byte_vector (vec, index)); -} - -static s7_pointer -g_bv_ref_2 (s7_scheme* sc, s7_pointer args) { - const s7_pointer vec= car (args); - s7_pointer index; - s7_int ind; - if (!is_byte_vector (vec)) - return (method_or_bust (sc, vec, sc->byte_vector_ref_symbol, args, - sc->type_names[T_BYTE_VECTOR], 1)); - if (vector_rank (vec) != 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, - sc->type_names[T_INTEGER], 2)); - ind= s7_integer_clamped_if_gmp (sc, index); - if ((ind < 0) || (ind >= vector_length (vec))) - out_of_range_error_nr (sc, sc->byte_vector_ref_symbol, int_two, index, - (ind < 0) ? it_is_negative_string - : it_is_too_large_string); - return (small_int (byte_vector (vec, ind))); -} - -static s7_pointer -g_bv_ref_3 (s7_scheme* sc, s7_pointer args) { - const s7_pointer iv= car (args); - s7_pointer index; - s7_int ind1, ind2; - if (!is_byte_vector (iv)) - return (method_or_bust (sc, iv, sc->byte_vector_ref_symbol, args, - sc->type_names[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, - sc->type_names[T_INTEGER], 2)); - ind1= s7_integer_clamped_if_gmp (sc, index); - if ((ind1 < 0) || (ind1 >= vector_dimension (iv, 0))) - out_of_range_error_nr (sc, sc->byte_vector_ref_symbol, int_two, index, - (ind1 < 0) ? it_is_negative_string - : it_is_too_large_string); - index= caddr (args); - if (!s7_is_integer (index)) - return (method_or_bust (sc, index, sc->byte_vector_ref_symbol, args, - sc->type_names[T_INTEGER], 3)); - ind2= s7_integer_clamped_if_gmp (sc, index); - if ((ind2 < 0) || (ind2 >= vector_dimension (iv, 1))) - out_of_range_error_nr (sc, sc->byte_vector_ref_symbol, int_three, index, - (ind2 < 0) ? it_is_negative_string - : it_is_too_large_string); - ind1= ind1 * vector_offset (iv, 0) + ind2; - return (small_int (byte_vector (iv, ind1))); -} - -static s7_pointer -byte_vector_ref_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer unused_expr) { - return ((args == 2) ? sc->bv_ref_2 : ((args == 3) ? sc->bv_ref_3 : func)); -} - -/* -------------------------------- 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 vec, s7_int index, - s7_int byte) { - if (!is_byte_vector (vec)) - wrong_type_error_nr (sc, sc->byte_vector_set_symbol, 1, vec, - a_byte_vector_string); - if ((byte < 0) || (byte > 255)) - wrong_type_error_nr (sc, sc->byte_vector_set_symbol, 3, - wrap_integer (sc, byte), an_unsigned_byte_string); - if ((index < 0) || (index >= byte_vector_length (vec))) - out_of_range_error_nr ( - sc, sc->byte_vector_set_symbol, int_two, wrap_integer (sc, index), - (index < 0) ? it_is_negative_string : it_is_too_large_string); - byte_vector (vec, index)= (uint8_t) byte; - return (byte); + if (type(vec) != typ) + return(method_or_bust(sc, vec, caller, args, sc->type_names[typ], 1)); + + if (vector_rank(vec) == 1) + { + index = cadr(args); + if (!s7_is_integer(index)) + return(method_or_bust(sc, index, caller, args, sc->type_names[T_INTEGER], 2)); + ind = s7_integer_clamped_if_gmp(sc, index); + if ((ind < 0) || (ind >= vector_length(vec))) + sole_arg_out_of_range_error_nr(sc, caller, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); + if (!is_null(cddr(args))) + out_of_range_error_nr(sc, caller, int_two, cdr(args), too_many_indices_string); + } + else + { + s7_int i; + s7_pointer indices; + ind = 0; + for (indices = cdr(args), i = 0; (is_pair(indices)) && (i < vector_ndims(vec)); indices = cdr(indices), i++) + { + s7_int n; + index = car(indices); + if (!s7_is_integer(index)) + return(method_or_bust(sc, index, caller, args, sc->type_names[T_INTEGER], i + 2)); + n = s7_integer_clamped_if_gmp(sc, index); + if ((n < 0) || (n >= vector_dimension(vec, i))) + out_of_range_error_nr(sc, caller, wrap_integer(sc, i + 2), index, (n < 0) ? it_is_negative_string : it_is_too_large_string); + ind += n * vector_offset(vec, i); + } + if (is_not_null(indices)) + out_of_range_error_nr(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(vec)) + return(subvector(sc, vec, i, ind)); + } + if (typ == T_FLOAT_VECTOR) + return(make_real(sc, float_vector(vec, ind))); + if (typ == T_COMPLEX_VECTOR) + return(make_complex(sc, creal(complex_vector(vec, ind)), cimag(complex_vector(vec, ind)))); + return((typ == T_INT_VECTOR) ? make_integer(sc, int_vector(vec, ind)) : small_int(byte_vector(vec, ind))); } -static s7_int -byte_vector_set_i_7pii_direct (s7_scheme* unused_sc, s7_pointer vec, - s7_int index, s7_int byte) { - byte_vector (vec, index)= (uint8_t) byte; - return (byte); +static s7_pointer univect_set(s7_scheme *sc, s7_pointer args, s7_pointer caller, int32_t typ) +{ + const s7_pointer vec = car(args); + s7_pointer val, index; + s7_int ind; + + if (type(vec) != typ) + return(method_or_bust(sc, vec, caller, args, sc->type_names[typ], 1)); + if (is_immutable_vector(vec)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, caller, vec)); + + if (vector_rank(vec) > 1) + { + s7_int i; + s7_pointer indices; + ind = 0; + for (indices = cdr(args), i = 0; (is_pair(cdr(indices))) && (i < vector_ndims(vec)); indices = cdr(indices), i++) + { + s7_int n; + index = car(indices); + if (!s7_is_integer(index)) + return(method_or_bust(sc, index, caller, args, sc->type_names[T_INTEGER], i + 2)); + n = s7_integer_clamped_if_gmp(sc, index); + if ((n < 0) || (n >= vector_dimension(vec, i))) + out_of_range_error_nr(sc, caller, wrap_integer(sc, i + 2), index, (n < 0) ? it_is_negative_string : it_is_too_large_string); + ind += n * vector_offset(vec, i); + } + if (is_not_null(cdr(indices))) + error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, wrap_string(sc, "too many arguments for ~A: ~S", 29), caller, args)); + if (i != vector_ndims(vec)) + error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, wrap_string(sc, "not enough arguments for ~A: ~S", 31), caller, args)); + val = car(indices); + } + else + { + s7_pointer indices = cdr(args); + if (is_null(indices)) + error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, wrap_string(sc, "not enough arguments for ~A: ~S", 31), caller, args)); + /* from (set! (v) val) after optimization into op_set_opsq_a which is completely confused -- set! gets v's setter (float-vector-set!) */ + index = car(indices); + if (!s7_is_integer(index)) + return(method_or_bust(sc, index, caller, args, sc->type_names[T_INTEGER], 2)); + ind = s7_integer_clamped_if_gmp(sc, index); + if ((ind < 0) || (ind >= vector_length(vec))) + out_of_range_error_nr(sc, caller, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); + if (is_not_null(cddr(indices))) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, wrap_string(sc, "too many arguments for ~A: ~S", 29), caller, args)); + val = cadr(indices); + } + + if (typ == T_FLOAT_VECTOR) + { + if (!is_real(val)) + return(method_or_bust(sc, val, caller, args, sc->type_names[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, sc->type_names[T_INTEGER], 3)); + int_vector(vec, ind) = s7_integer_clamped_if_gmp(sc, val); + } + else + if (typ == T_BYTE_VECTOR) + { + if (!is_byte(val)) + return(method_or_bust(sc, val, caller, args, sc->type_names[T_INTEGER], 3)); + byte_vector(vec, ind) = (uint8_t)s7_integer_clamped_if_gmp(sc, val); + } + else + { + if (!is_number(val)) + return(method_or_bust(sc, val, caller, args, sc->type_names[T_COMPLEX], 3)); + complex_vector(vec, ind) = s7_to_c_complex(val); + } + return(val); } -static s7_pointer -byte_vector_set_p_pip_direct (s7_scheme* unused_sc, s7_pointer vec, - s7_int index, s7_pointer byte) { - byte_vector (vec, index)= (uint8_t) s7_integer (byte); - return (byte); + +/* -------------------------------- complex-vector-ref -------------------------------- */ +static s7_pointer g_complex_vector_ref(s7_scheme *sc, s7_pointer args) +{ + #define H_complex_vector_ref "(complex-vector-ref v ...) returns an element of the complex-vector v." + #define Q_complex_vector_ref s7_make_circular_signature(sc, 2, 3, \ + s7_make_signature(sc, 2, sc->is_complex_symbol, sc->is_complex_vector_symbol), \ + sc->is_complex_vector_symbol, sc->is_integer_symbol) + return(univect_ref(sc, args, sc->complex_vector_ref_symbol, T_COMPLEX_VECTOR)); } -static s7_int -byte_vector_set_i_7piii (s7_scheme* sc, s7_pointer vec, s7_int index1, - s7_int index2, s7_int byte) { - if ((byte < 0) || (byte > 255)) - wrong_type_error_nr (sc, sc->byte_vector_set_symbol, 4, - wrap_integer (sc, byte), an_unsigned_byte_string); - if ((index1 < 0) || (index1 >= vector_dimension (vec, 0))) - out_of_range_error_nr ( - sc, sc->int_vector_set_symbol, int_two, wrap_integer (sc, index1), - (index1 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((index2 < 0) || (index2 >= vector_dimension (vec, 1))) - out_of_range_error_nr ( - sc, sc->int_vector_set_symbol, int_three, wrap_integer (sc, index2), - (index2 < 0) ? it_is_negative_string : it_is_too_large_string); - byte_vector (vec, index2 + (index1 * vector_offset (vec, 0)))= byte; - return (byte); -} - -static s7_pointer -g_bv_set_3 (s7_scheme* sc, s7_pointer args) { - const s7_pointer vec= car (args); - s7_pointer index, value; - s7_int ind; - if (!is_byte_vector (vec)) - return (method_or_bust (sc, vec, sc->byte_vector_set_symbol, args, - sc->type_names[T_BYTE_VECTOR], 1)); - if (vector_rank (vec) != 1) - return (univect_set (sc, args, sc->byte_vector_set_symbol, T_BYTE_VECTOR)); - if (is_immutable_vector (vec)) - immutable_object_error_nr (sc, - set_elist_3 (sc, immutable_error_string, - sc->byte_vector_set_symbol, vec)); - index= cadr (args); - if (!s7_is_integer (index)) - return (method_or_bust (sc, index, sc->byte_vector_set_symbol, args, - sc->type_names[T_INTEGER], 2)); - ind= s7_integer_clamped_if_gmp (sc, index); - if ((ind < 0) || (ind >= vector_length (vec))) - out_of_range_error_nr (sc, sc->byte_vector_set_symbol, int_two, index, - (ind < 0) ? it_is_negative_string - : it_is_too_large_string); - value= caddr (args); - if (!s7_is_integer (value)) - return (method_or_bust (sc, value, sc->byte_vector_set_symbol, args, - sc->type_names[T_INTEGER], 3)); +static s7_pointer complex_vector_ref_p_pp(s7_scheme *sc, s7_pointer vec, s7_pointer index) +{ + if (!is_complex_vector(vec)) + return(method_or_bust_pp(sc, vec, sc->complex_vector_ref_symbol, vec, index, sc->type_names[T_COMPLEX_VECTOR], 1)); + if (vector_rank(vec) != 1) + return(univect_ref(sc, set_plist_2(sc, vec, index), sc->complex_vector_ref_symbol, T_COMPLEX_VECTOR)); + if (!s7_is_integer(index)) + return(method_or_bust_pp(sc, index, sc->complex_vector_ref_symbol, vec, index, sc->type_names[T_INTEGER], 2)); { - s7_int byte= s7_integer_clamped_if_gmp (sc, value); - if ((byte < 0) || (byte > 255)) - wrong_type_error_nr (sc, sc->byte_vector_set_symbol, 3, value, - an_unsigned_byte_string); - byte_vector (vec, ind)= (uint8_t) byte; + s7_int ind = s7_integer_clamped_if_gmp(sc, index); + if ((ind < 0) || (ind >= vector_length(vec))) + out_of_range_error_nr(sc, sc->complex_vector_ref_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); + return(c_complex_to_s7(sc, complex_vector(vec, ind))); } - return (value); } -static s7_pointer -byte_vector_set_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer unused_expr) { - return ((args == 3) ? sc->bv_set_3 : func); -} +s7_pointer s7i_complex_vector_ref_p_pp(s7_scheme *sc, s7_pointer vec, s7_pointer index) {return(complex_vector_ref_p_pp(sc, vec, index));} -/* -------------------------------------------------------------------------------- - */ -static bool -c_function_is_ok (s7_scheme* sc, s7_pointer x) { - s7_pointer func= lookup_unexamined ( - sc, car (x)); /* lookup_global is usually slower (faster in Snd) */ - if ((func == opt1_cfunc (x)) || - ((func) && (is_any_c_function (func)) && - (c_function_class (func) == c_function_class (opt1_cfunc (x))) && - (set_opt1_cfunc (x, func)))) - return (true); - sc->last_function= func; - 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->rest_keyword) return (true); - return (!is_null (p)); +static s7_pointer complex_vector_ref_p_pi(s7_scheme *sc, s7_pointer vec, s7_int index) +{ + if ((!is_complex_vector(vec)) || (vector_rank(vec) > 1) || (index < 0) || (index >= vector_length(vec))) + return(g_complex_vector_ref(sc, set_plist_2(sc, vec, make_integer(sc, index)))); + return(c_complex_to_s7(sc, complex_vector(vec, index))); } -/* -------------------------------- sort! -------------------------------- */ -static int32_t -dbl_less (const void* x1, const void* x2) { - if ((*((const s7_double*) x1)) < (*((const s7_double*) x2))) return (-1); - return (((*((const s7_double*) x1)) > (*((const s7_double*) x2))) ? 1 : 0); +static s7_pointer complex_vector_ref_p_pi_wrapped(s7_scheme *sc, s7_pointer vec, s7_int index) +{ + s7_complex z; + if ((!is_complex_vector(vec)) || (vector_rank(vec) > 1) || (index < 0) || (index >= vector_length(vec))) + return(g_complex_vector_ref(sc, set_plist_2(sc, vec, make_integer(sc, index)))); + z = complex_vector(vec, index); + return(wrap_complex(sc, creal(z), cimag(z))); } -static int32_t -int_less (const void* x1, const void* x2) { - if ((*((const s7_int*) x1)) < (*((const s7_int*) x2))) return (-1); - return (((*((const s7_int*) x1)) > (*((const s7_int*) x2))) ? 1 : 0); -} +static s7_pointer complex_vector_ref_p_pi_direct(s7_scheme *sc, s7_pointer vec, s7_int index) {return(c_complex_to_s7(sc, complex_vector(vec, index)));} -static int32_t -dbl_greater (const void* x1, const void* x2) { - return (-dbl_less (x1, x2)); -} -static int32_t -int_greater (const void* x1, const void* x2) { - return (-int_less (x1, x2)); +static s7_pointer complex_vector_ref_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr) +{ + return((args == 2) ? sc->cv_ref_2 : func); } -static int32_t -byte_less (const void* x1, const void* x2) { - if ((*((const uint8_t*) x1)) < (*((const uint8_t*) x2))) return (-1); - return (((*((const uint8_t*) x1)) > (*((const uint8_t*) x2))) ? 1 : 0); -} -static int32_t -byte_greater (const void* x1, const void* x2) { - return (-byte_less (x1, x2)); +/* -------------------------------- complex-vector-set! -------------------------------- */ +static s7_pointer g_complex_vector_set(s7_scheme *sc, s7_pointer args) +{ + #define H_complex_vector_set "(complex-vector-set! v i ... value) sets the i-th element of the complex-vector v to value." + #define Q_complex_vector_set s7_make_circular_signature(sc, 3, 4, \ + sc->is_complex_symbol, sc->is_complex_vector_symbol, sc->is_integer_symbol, sc->is_integer_or_number_at_end_symbol) + return(univect_set(sc, args, sc->complex_vector_set_symbol, T_COMPLEX_VECTOR)); } -static int32_t -dbl_less_2 (const void* x1, const void* x2) { - s7_double x= real (*((const s7_pointer*) x1)); - s7_double y= real (*((const s7_pointer*) x2)); - if (x < y) return (-1); - return ((x > y) ? 1 : 0); -} -static int32_t -int_less_2 (const void* x1, const void* x2) { - s7_int i1= integer (*((const s7_pointer*) x1)); - s7_int i2= integer (*((const s7_pointer*) x2)); - if (i1 < i2) return (-1); - return ((i1 > i2) ? 1 : 0); +static s7_pointer complex_vector_set_p_pip(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value) +{ + if ((!is_complex_vector(vec)) || (!is_number(value)) || (vector_rank(vec) > 1) || (index < 0) || (index >= vector_length(vec))) + return(univect_set(sc, set_plist_3(sc, vec, make_integer(sc, index), value), sc->complex_vector_set_symbol, T_COMPLEX_VECTOR)); + complex_vector(vec, index) = s7_to_c_complex(value); + return(value); } -static int32_t -dbl_greater_2 (const void* x1, const void* x2) { - return (-dbl_less_2 (x1, x2)); -} -static int32_t -int_greater_2 (const void* x1, const void* x2) { - return (-int_less_2 (x1, x2)); +static s7_pointer complex_vector_set_p_pip_unchecked(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value) +{ + if ((index >= 0) && (index < vector_length(vec))) + complex_vector(vec, index) = s7_to_c_complex(value); + else out_of_range_error_nr(sc, sc->complex_vector_set_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string); + return(value); } -static int32_t -str_less_2 (const void* s1, const void* s2) { - s7_pointer str1= (*((const s7_pointer*) s1)); - s7_pointer str2= (*((const s7_pointer*) s2)); - return (scheme_strcmp (str1, str2)); +static s7_pointer complex_vector_set_p_pip_direct(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value) +{ + complex_vector(vec, index) = s7_to_c_complex(value); + return(value); } -static int32_t -str_greater_2 (const void* s1, const void* s2) { - return (-str_less_2 (s1, s2)); +static s7_pointer complex_vector_set_p_ppp(s7_scheme *sc, s7_pointer vec, s7_pointer index, s7_pointer value) +{ + if (!is_complex_vector(vec)) + return(method_or_bust_ppp(sc, vec, sc->complex_vector_set_symbol, vec, index, value, sc->type_names[T_COMPLEX_VECTOR], 1)); + if (vector_rank(vec) != 1) + return(univect_set(sc, set_plist_3(sc, vec, index, value), sc->complex_vector_set_symbol, T_COMPLEX_VECTOR)); + if (is_immutable_vector(vec)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->complex_vector_set_symbol, vec)); + if (!s7_is_integer(index)) + return(method_or_bust_ppp(sc, index, sc->complex_vector_set_symbol, vec, index, value, sc->type_names[T_INTEGER], 2)); + if (!s7_is_number(value)) + return(method_or_bust_ppp(sc, value, sc->complex_vector_set_symbol, vec, index, value, sc->type_names[T_COMPLEX], 3)); + { + s7_int i = integer(index); + if ((i < 0) || (i >= vector_length(vec))) + out_of_range_error_nr(sc, sc->complex_vector_set_symbol, int_two, index, (i < 0) ? it_is_negative_string : it_is_too_large_string); + complex_vector(vec, i) = s7_to_c_complex(value); + } + return(value); } -static int32_t -chr_less_2 (const void* p1, const void* p2) { - uint8_t c1= character (*((const s7_pointer*) p1)); - uint8_t c2= character (*((const s7_pointer*) p2)); - if (c1 < c2) return (-1); - return ((c1 > c2) ? 1 : 0); -} +s7_pointer s7i_complex_vector_set_p_ppp(s7_scheme *sc, s7_pointer vec, s7_pointer index, s7_pointer value) {return(complex_vector_set_p_ppp(sc, vec, index, value));} -static int32_t -chr_greater_2 (const void* c1, const void* c2) { - return (-chr_less_2 (c1, c2)); +/* static s7_pointer g_cv_set_3_nr(s7_scheme *sc, s7_pointer args) {return(complex_vector_set_p_ppp_nr(sc, car(args), cadr(args), caddr(args)));} */ + +static s7_pointer complex_vector_set_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + return((args == 3) ? sc->cv_set_3 : func); } -#if MS_WINDOWS || defined(__APPLE__) || defined(__FreeBSD__) -struct sort_r_data { - void* arg; - int32_t (*compar) (const void* a1, const void* a2, void* aarg); -}; -static int32_t -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); +/* -------------------------------- 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)); } -#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. - * - * qsort_r allocates an internal array (msort.c line 221) if the original - * array is > 1024 elements (or whatever), then calls the sort comparison - * function in a loop, after which it frees its temporary array. This is an - * unavoidable memory leak if the comparison function calls s7_error (or its - * equivalent) which longjmps to the nearest catch (or, sigh, segfaults if none - * exists). I can't see any way to hack around this memory leak -- don't raise - * an error in the sort function! - */ -static void -local_qsort_r (void* base, size_t nmemb, size_t size, - int32_t (*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= (uint8_t*) base; - const uint8_t* after= (uint8_t*) (nmemb * size + array); - size_t h, t; - nmemb/= 4; - h= nmemb + 1; - for (t= 1; nmemb != 0; nmemb/= 4) - t*= 2; - do { - size_t bytes= h * size; - uint8_t* i = (uint8_t*) (array + bytes); - uint8_t* k; - do { - uint8_t* j= (uint8_t*) (i - bytes); - if (compar (j, i, arg) > 0) { - k= i; - do { - uint8_t * p1= j, *p2= k; - const uint8_t* end= (uint8_t*) (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); +static inline s7_pointer float_vector_ref_p_pp(s7_scheme *sc, s7_pointer vec, s7_pointer index) +{ + if (!is_float_vector(vec)) + return(method_or_bust_pp(sc, vec, sc->float_vector_ref_symbol, vec, index, sc->type_names[T_FLOAT_VECTOR], 1)); + if (vector_rank(vec) != 1) + return(univect_ref(sc, set_plist_2(sc, vec, 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, vec, index, sc->type_names[T_INTEGER], 2)); + { + s7_int ind = s7_integer_clamped_if_gmp(sc, index); + if ((ind < 0) || (ind >= vector_length(vec))) + out_of_range_error_nr(sc, sc->float_vector_ref_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); + return(make_real(sc, float_vector(vec, ind))); } -#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, (*(const s7_pointer*) v1), - (*(const s7_pointer*) v2))) - ? -1 - : 1); -} +s7_pointer s7i_float_vector_ref_p_pp(s7_scheme *sc, s7_pointer vec, s7_pointer index) {return(float_vector_ref_p_pp(sc, vec, index));} -static int32_t -vector_sort_lt (const void* v1, const void* v2, void* arg) /* for qsort_r */ +static s7_pointer g_fv_ref_3(s7_scheme *sc, s7_pointer args) { - s7_pointer i1= (*(const s7_pointer*) v1); - s7_pointer i2= (*(const s7_pointer*) v2); - if ((is_t_integer (i1)) && (is_t_integer (i2))) - return ((integer (i1) < integer (i2)) ? -1 : 1); - return ((lt_b_7pp ((s7_scheme*) arg, i1, i2)) ? -1 : 1); + const s7_pointer fv = car(args); + s7_pointer index; + s7_int ind1, ind2; + if (!is_float_vector(fv)) + return(method_or_bust(sc, fv, sc->float_vector_ref_symbol, args, sc->type_names[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, sc->type_names[T_INTEGER], 2)); + ind1 = s7_integer_clamped_if_gmp(sc, index); + if ((ind1 < 0) || (ind1 >= vector_dimension(fv, 0))) + out_of_range_error_nr(sc, sc->float_vector_ref_symbol, int_two, index, (ind1 < 0) ? it_is_negative_string : it_is_too_large_string); + index = caddr(args); + if (!s7_is_integer(index)) + return(method_or_bust(sc, index, sc->float_vector_ref_symbol, args, sc->type_names[T_INTEGER], 3)); + ind2 = s7_integer_clamped_if_gmp(sc, index); + if ((ind2 < 0) || (ind2 >= vector_dimension(fv, 1))) + out_of_range_error_nr(sc, sc->float_vector_ref_symbol, int_three, index, (ind2 < 0) ? it_is_negative_string : it_is_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 vec, s7_int index) +{ + /* according to callgrind, it is faster to split out the bounds check */ + if ((index < 0) || (index >= vector_length(vec))) + out_of_range_error_nr(sc, sc->float_vector_ref_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string); + return(index); } -static int32_t -vector_car_sort (const void* v1, const void* v2, void* arg) { - s7_scheme* sc= (s7_scheme*) arg; - s7_pointer a = (*(const s7_pointer*) v1); - s7_pointer b = (*(const 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 s7_pointer float_vector_set_p_pip(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value) +{ + if ((!is_float_vector(vec)) || (!is_real(value)) || (vector_rank(vec) > 1) || (index < 0) || (index >= vector_length(vec))) + return(univect_set(sc, set_plist_3(sc, vec, make_integer(sc, index), value), sc->float_vector_set_symbol, T_FLOAT_VECTOR)); + float_vector(vec, index) = s7_real(value); + return(value); } -static int32_t -vector_cdr_sort (const void* v1, const void* v2, void* arg) { - s7_scheme* sc= (s7_scheme*) arg; - s7_pointer a = (*(const s7_pointer*) v1); - s7_pointer b = (*(const 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 inline s7_double float_vector_ref_d_7pi(s7_scheme *sc, s7_pointer vec, s7_int index) {return(float_vector(vec, ref_check_index(sc, vec, index)));} +static double float_vector_ref_d_7pi_direct(s7_scheme *sc, s7_pointer vec, s7_int index) {return(float_vector(vec, index));} +static s7_pointer float_vector_ref_p_pi_direct(s7_scheme *sc, s7_pointer vec, s7_int index) {return(make_real(sc, float_vector(vec, index)));} +static s7_pointer float_vector_ref_p_pi_direct_wrapped(s7_scheme *sc, s7_pointer vec, s7_int index) {return(wrap_real(sc, float_vector(vec, index)));} -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, - (*(const s7_pointer*) v1)); /* first slot in curlet */ - slot_set_value (sc->sort_v2, - (*(const s7_pointer*) v2)); /* second slot in curlet */ - return ((sc->sort_fb (sc->sort_o)) ? -1 : 1); +static inline s7_double float_vector_ref_d_7pii(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2) +{ + if ((i1 < 0) || (i1 >= vector_dimension(vec, 0))) + out_of_range_error_nr(sc, sc->float_vector_ref_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); + if ((i2 < 0) || (i2 >= vector_dimension(vec, 1))) + out_of_range_error_nr(sc, sc->float_vector_ref_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string); + return(float_vector(vec, i2 + (i1 * vector_offset(vec, 0)))); } -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, - (*(const s7_pointer*) v1)); /* first slot in curlet */ - slot_set_value (sc->sort_v2, - (*(const s7_pointer*) v2)); /* second slot in curlet */ - return ((sc->sort_fb (sc->sort_o)) ? -1 : 1); +static s7_double float_vector_ref_d_7piii(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2, s7_int i3) +{ + if ((i1 < 0) || (i1 >= vector_dimension(vec, 0))) + out_of_range_error_nr(sc, sc->float_vector_ref_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); + if ((i2 < 0) || (i2 >= vector_dimension(vec, 1))) + out_of_range_error_nr(sc, sc->float_vector_ref_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string); + if ((i3 < 0) || (i3 >= vector_dimension(vec, 2))) + out_of_range_error_nr(sc, sc->float_vector_ref_symbol, small_int(4), wrap_integer(sc, i3), (i3 < 0) ? it_is_negative_string : it_is_too_large_string); + return(float_vector(vec, i3 + (i2 * vector_offset(vec, 1)) + (i1 * vector_offset(vec, 0)))); } -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, (*(const s7_pointer*) v1)); - slot_set_value (sc->sort_v2, (*(const s7_pointer*) v2)); - return ((q_temp (sc->opts[0]).fp (sc->opts[0]) == sc->F) ? 1 : -1); +static s7_pointer float_vector_ref_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr) +{ + return((args == 2) ? sc->fv_ref_2 : ((args == 3) ? sc->fv_ref_3 : func)); } -#define sort_o1 1 -#define q_sort(o, i) o->v[sort_o1 + i] -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, (*(const s7_pointer*) v1)); - slot_set_value (sc->sort_v2, (*(const s7_pointer*) v2)); - for (i= 0; i < sc->sort_body_len - 1; i++) { - o= q_sort (top, i).o1; - q_call (o).fp (o); - } - o= q_sort (top, i).o1; - if (int_expr) return ((q_call (o).fb (o)) ? -1 : 1); - return ((q_call (o).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, (*(const s7_pointer*) v1)); - slot_set_value (sc->sort_v2, (*(const s7_pointer*) v2)); - o= q_sort (top, 0).o1; - q_call (o).fp (o); - o= q_sort (top, 1).o1; - return ((q_call (o).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, (*(const s7_pointer*) v1)); - slot_set_value (sc->sort_v2, (*(const 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, (*(const s7_pointer*) v1)); - slot_set_value (sc->sort_v2, (*(const 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); -} - -#define OPT_PRINT 0 /* print info about the opt_* optimizations */ -static s7_b_7pp_t s7_b_7pp_function (s7_pointer f); -static opt_info* alloc_opt_info (s7_scheme* sc); -static bool bool_optimize (s7_scheme* sc, s7_pointer expr); -static bool bool_optimize_nw (s7_scheme* sc, s7_pointer expr); -#if OPT_PRINT -#define cell_optimize(Sc, Expr) cell_optimize_with_line (Sc, Expr, __LINE__) -static bool cell_optimize_with_line (s7_scheme* sc, s7_pointer expr, int line); -#else -static bool cell_optimize (s7_scheme* sc, s7_pointer expr); -#endif - -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) - - const s7_pointer data = car (args); - s7_pointer lessp= cadr (args); - int32_t (*sort_func) (const void* v1, const void* v2, void* arg); - - /* 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 */ - if (type (lessp) < T_CONTINUATION) - return (method_or_bust (sc, lessp, sc->sort_symbol, args, - a_procedure_string, 2)); - if (!s7_is_aritable (sc, lessp, 2)) - wrong_type_error_nr (sc, sc->sort_symbol, 2, lessp, an_eq_func_string); - return (sc->nil); - } - if (!is_sequence ( - data)) /* precede immutable because #f (for example) is immutable: - "can't sort #f because it is immutable" is a joke */ - wrong_type_error_nr (sc, sc->sort_symbol, 1, data, a_sequence_string); - if (is_immutable (data)) - immutable_object_error_nr ( - sc, set_elist_3 (sc, immutable_error_string, sc->sort_symbol, data)); - if (is_let (data)) - if_method_exists_return_value (sc, data, sc->sort_symbol, args); - - if (type (lessp) <= T_GOTO) - return (method_or_bust (sc, lessp, sc->sort_symbol, args, - a_procedure_string, 2)); - if (!s7_is_aritable (sc, lessp, 2)) - wrong_type_error_nr (sc, sc->sort_symbol, 2, lessp, an_eq_func_string); - if ((is_any_macro (lessp)) && (!is_c_macro (lessp))) - clear_all_optimizations (sc, closure_body (lessp)); - sort_func = NULL; - sc->sort_f= NULL; +/* -------------------------------- 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)); +} - if (is_safe_c_function (lessp)) /* (sort! a <) */ +static s7_pointer g_fv_set_3(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer fv = car(args); + s7_pointer index; + if (!is_float_vector(fv)) + return(method_or_bust(sc, fv, sc->float_vector_set_symbol, args, sc->type_names[T_FLOAT_VECTOR], 1)); + if (vector_rank(fv) != 1) + return(univect_set(sc, args, sc->float_vector_set_symbol, T_FLOAT_VECTOR)); + if (is_immutable_vector(fv)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->float_vector_set_symbol, fv)); + index = cadr(args); + if (!s7_is_integer(index)) + return(method_or_bust(sc, index, sc->float_vector_set_symbol, args, sc->type_names[T_INTEGER], 2)); { - s7_pointer sig= c_function_signature (lessp); - if ((sig) && (is_pair (sig)) && (car (sig) != sc->is_boolean_symbol)) - wrong_type_error_nr ( - 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)) { - const s7_pointer expr= car (closure_body (lessp)); - const s7_pointer pars= closure_pars (lessp); - - if ((is_pair (pars)) && /* closure args not a symbol, etc */ - (!arglist_has_rest (sc, pars))) { - 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_defined_global ( - car (expr))) && /* (sort! x (lambda (car y) (car x)...))! */ - (c_function_is_ok (sc, expr))))) { - const int32_t orig_data= optimize_op (expr); - set_optimize_op (expr, optimize_op (expr) | 1); - if ((optimize_op (expr) == HOP_SAFE_C_SS) && - (car (pars) == cadr (expr)) && (cadr (pars) == caddr (expr))) { - s7_pointer 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) { - const s7_pointer arg1= cadr (expr), arg2= caddr (expr); - if (((car (arg1) == sc->car_symbol) || - (car (arg1) == sc->cdr_symbol)) && - (car (arg1) == car (arg2)) && (car (pars) == cadr (arg1)) && - (cadr (pars) == - cadr (arg2))) /* expr: (< (car a) (car b)) etc */ - { - s7_pointer lp= lookup (sc, car (expr)); - sc->sort_f = s7_b_7pp_function (lp); - if (sc->sort_f) { - sort_func= ((car (arg1) == sc->car_symbol) ? vector_car_sort - : vector_cdr_sort); - lessp = lp; - } - } - } - set_optimize_op (expr, orig_data); - } - - if (!sort_func) { - s7_pointer init_val; - const s7_pointer old_let = sc->curlet; - const s7_pointer lessp_body= closure_body (lessp); - if (is_float_vector (data)) init_val= real_zero; - else - init_val= ((is_int_vector (data)) || (is_byte_vector (data))) - ? int_zero - : sc->F; - set_curlet (sc, inline_make_let_with_two_slots ( - sc, closure_let (lessp), car (pars), init_val, - cadr (pars), 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 (lessp_body))) { - if (!no_bool_opt (lessp_body)) { - s7_pfunc sf1= s7_bool_optimize (sc, lessp_body); - if (sf1) { - if (q_call (sc->opts[0]).fb == p_to_b) - sort_func= opt_bool_sort_p; - else { - sc->sort_o = sc->opts[0]; - sc->sort_fb= q_call (sc->sort_o).fb; - sort_func = (sc->pc == 1) ? opt_bool_sort_0 : opt_bool_sort; - } - } - else set_no_bool_opt (lessp_body); - } - } - else { - sc->sort_body_len= s7_list_length (sc, lessp_body); - if (sc->sort_body_len < (num_vunions - sort_o1)) { - s7_pointer p; - int32_t ctr; - opt_info* top; - sc->pc= 0; - top = alloc_opt_info (sc); - for (ctr= 0, p= lessp_body; is_pair (cdr (p)); - ctr++, p = cdr (p)) { - q_sort (top, ctr).o1= sc->opts[sc->pc]; - if (!cell_optimize (sc, p)) break; - } - if (is_null (cdr (p))) { - int32_t start = sc->pc; - q_sort (top, 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 { - sc->pc= start; - if (cell_optimize (sc, p)) sort_func= opt_begin_bool_sort_p; - } - } - } - } - if (!sort_func) set_curlet (sc, old_let); - } - if ((!sort_func) && - (is_safe_closure (lessp))) /* no embedded sort! or call/cc, etc */ - { - set_curlet (sc, make_let_with_two_slots (sc, closure_let (lessp), - car (pars), sc->F, - cadr (pars), 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)); - } - } - } + s7_int ind = s7_integer_clamped_if_gmp(sc, index); + s7_pointer value = caddr(args); + if ((ind < 0) || (ind >= vector_length(fv))) + out_of_range_error_nr(sc, sc->float_vector_set_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); + if (!is_real(value)) + return(method_or_bust(sc, value, sc->float_vector_set_symbol, args, sc->type_names[T_REAL], 3)); + float_vector(fv, ind) = s7_real(value); + return(value); } +} - { - s7_int len= 0; - switch (type (data)) { - case T_PAIR: - len= s7_list_length (sc, data); /* 0 here == infinite */ - if (len <= 0) - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_2 ( - sc, - wrap_string ( - sc, "sort! first argument should be a proper list: ~S", 48), - data)); - if (len < 2) return (data); - if (sort_func) { - s7_int i = 0; - s7_pointer vec = g_vector (sc, data); - s7_pointer* elements= s7_vector_elements (vec); - gc_protect_2_via_stack (sc, vec, data); - local_qsort_r ((void*) elements, len, sizeof (s7_pointer), sort_func, - (void*) sc); - for (s7_pointer p= data; i < len; i++, p= cdr (p)) { - if (is_immutable_pair (p)) - immutable_object_error_nr (sc, - set_elist_3 (sc, immutable_error_string, - sc->sort_symbol, data)); - set_car (p, elements[i]); - } - unstack_gc_protect (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; +static s7_pointer g_fv_set_unchecked(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer fv = car(args), value = caddr(args); + s7_int ind; + if (!is_real(value)) + wrong_type_error_nr(sc, sc->float_vector_set_symbol, 3, value, sc->type_names[T_REAL]); + if (is_immutable_vector(fv)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->float_vector_set_symbol, fv)); + ind = s7_integer_clamped_if_gmp(sc, cadr(args)); + float_vector(fv, ind) = s7_real(value); + return(value); +} - case T_BYTE_VECTOR: - case T_STRING: { - 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); - } - } - { - s7_pointer vec = make_simple_vector (sc, len); - s7_pointer* elements= s7_vector_elements (vec); - gc_protect_2_via_stack (sc, vec, data); - if (is_byte_vector (data)) - for (s7_int i= 0; i < len; i++) - elements[i]= small_int (chrs[i]); - else - for (s7_int i= 0; i < len; i++) - elements[i]= chars[chrs[i]]; - if (sort_func) { - local_qsort_r ((void*) elements, len, sizeof (s7_pointer), sort_func, - (void*) sc); - if (is_byte_vector (data)) - for (s7_int i= 0; i < len; i++) - chrs[i]= (char) integer (elements[i]); - else - for (s7_int i= 0; i < len; i++) - chrs[i]= character (elements[i]); - unstack_gc_protect (sc); /* not pop_stack! */ - return (data); - } - unstack_gc_protect (sc); /* not pop_stack! */ - push_stack (sc, OP_SORT_STRING_END, cons_unchecked (sc, data, lessp), - sc->code); - set_car (args, vec); - } - } break; +static bool find_matching_ref(s7_scheme *sc, const s7_pointer getter, s7_pointer expr) +{ + /* expr: (*set! v i val), val exists (i.e. args=3, so cddddr is null) */ + const s7_pointer sym = cadr(expr), ind = caddr(expr); + if ((is_symbol(sym)) && (!is_pair(ind))) + { + const s7_pointer val = cadddr(expr); + if (is_optimized(val)) /* includes is_pair */ + for (s7_pointer p = val; is_pair(p); p = cdr(p)) + if (is_pair(car(p))) + { + const s7_pointer ref = car(p); + if (((car(ref) == getter) && /* (getter sym ind) */ + (is_proper_list_2(sc, cdr(ref))) && + (cadr(ref) == sym) && + (caddr(ref) == ind)) || + ((car(ref) == sym) && /* (sym ind) */ + (is_proper_list_1(sc, cdr(ref))) && + (cadr(ref) == ind))) + return(true); /* else keep looking */ + }} + return(false); +} - case T_INT_VECTOR: - case T_FLOAT_VECTOR: - case T_COMPLEX_VECTOR: { - len= vector_length (data); - if (len < 2) return (data); - if ((is_c_function (lessp)) && - (!is_complex_vector ( - data))) /* < and > make no sense in the complex case */ - { - if (sc->sort_f == lt_b_7pp) { - if (is_float_vector (data)) - qsort ((void*) float_vector_floats (data), len, sizeof (s7_double), - dbl_less); - else - qsort ((void*) int_vector_ints (data), len, sizeof (s7_int), - int_less); - return (data); - } - if (sc->sort_f == gt_b_7pp) { - if (is_float_vector (data)) - qsort ((void*) float_vector_floats (data), len, sizeof (s7_double), - dbl_greater); - else - qsort ((void*) int_vector_ints (data), len, sizeof (s7_int), - int_greater); - return (data); - } - } - /* currently we have to make the ordinary vector here 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) - */ - { - s7_pointer 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. - */ - s7_pointer* elements= s7_vector_elements (vec); - gc_protect_2_via_stack (sc, vec, data); - add_vector (sc, vec); - check_free_heap_size (sc, len); - if (is_float_vector (data)) - for (s7_int i= 0; i < len; i++) - elements[i]= make_real_unchecked (sc, float_vector (data, i)); - else if (is_int_vector (data)) - for (s7_int i= 0; i < len; i++) - elements[i]= make_integer_unchecked (sc, int_vector (data, i)); - else - for (s7_int i= 0; i < len; i++) - elements[i]= c_complex_to_s7 (sc, complex_vector (data, i)); - if (sort_func) { - local_qsort_r ((void*) elements, len, sizeof (s7_pointer), sort_func, - (void*) sc); - if (is_float_vector (data)) - for (s7_int i= 0; i < len; i++) - float_vector (data, i)= real (elements[i]); - else if (is_int_vector (data)) - for (s7_int i= 0; i < len; i++) - int_vector (data, i)= integer (elements[i]); - else - for (s7_int i= 0; i < len; i++) - complex_vector (data, i)= s7_to_c_complex (elements[i]); - unstack_gc_protect (sc); - return (data); - } - set_car (args, vec); - begin_temp (sc->y, cons (sc, data, lessp)); - unstack_gc_protect (sc); - push_stack (sc, OP_SORT_VECTOR_END, sc->y, - sc->code); /* save and gc protect the original homogeneous - vector and func */ - end_temp (sc->y); - } - } break; +static s7_pointer float_vector_set_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + if (args == 3) + return((find_matching_ref(sc, sc->float_vector_ref_symbol, expr)) ? sc->fv_set_unchecked : sc->fv_set_3); + return(func); +} - case T_VECTOR: - len= vector_length (data); - if (len < 2) return (data); - if (sort_func) { - s7_pointer* els= s7_vector_elements (data); - int32_t typ= type (els[0]); - if ((typ == T_INTEGER) || (typ == T_REAL) || (typ == T_STRING) || - (typ == T_CHARACTER)) - for (s7_int 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; +static s7_double float_vector_set_d_7pid_direct(s7_scheme *unused_sc, s7_pointer vec, s7_int index, s7_double x) {float_vector(vec, index) = x; return(x);} - default: - return (method_or_bust (sc, data, sc->sort_symbol, args, - wrap_string (sc, "a sortable sequence", 19), 1)); - } - { - s7_int n = len - 1; - s7_int k = (n / 2) + 1; - s7_pointer lx= make_simple_vector (sc, (sc->safety <= no_safety) ? 4 : 6); - t_vector_fill (lx, sc->nil); /* make_mutable_integer below can trigger GC, - so all elements of lx must be legit */ - begin_temp (sc->y, 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_unchecked (sc, n * n); - } - push_stack (sc, OP_SORT, args, lx); - end_temp (sc->y); - } - } - 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. - */ +static s7_int set_check_index(s7_scheme *sc, s7_pointer vec, s7_int index) +{ + if ((index < 0) || (index >= vector_length(vec))) + out_of_range_error_nr(sc, sc->float_vector_set_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string); + return(index); } -/* 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) { - const s7_pointer* elements= vector_elements (vect); - const s7_int len = vector_length (vect); - s7_int i = 0; - for (s7_pointer p= lst; i < len; i++, p= cdr (p)) { - if (is_immutable_pair (p)) - immutable_object_error_nr ( - sc, set_elist_3 (sc, immutable_error_string, sc->sort_symbol, lst)); - set_car (p, elements[i]); - } - return (lst); -} +static s7_double float_vector_set_d_7pid(s7_scheme *sc, s7_pointer vec, s7_int index, s7_double x) {float_vector(vec, set_check_index(sc, vec, index)) = x; return(x);} -static s7_pointer -vector_into_fi_vector (s7_pointer source, s7_pointer dest) { - const s7_pointer* elements= vector_elements (source); - const s7_int len = vector_length (source); - if (is_float_vector (dest)) { - s7_double* flts= float_vector_floats (dest); - for (s7_int i= 0; i < len; i++) - flts[i]= real (elements[i]); - } - else { - s7_int* ints= int_vector_ints (dest); - for (s7_int i= 0; i < len; i++) - ints[i]= integer (elements[i]); - } - return (dest); +static s7_double float_vector_set_d_7piid(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2, s7_double x) +{ + if ((i1 < 0) || (i1 >= vector_dimension(vec, 0))) + out_of_range_error_nr(sc, sc->float_vector_set_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); + if ((i2 < 0) || (i2 >= vector_dimension(vec, 1))) + out_of_range_error_nr(sc, sc->float_vector_set_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string); + float_vector(vec, i2 + (i1 * vector_offset(vec, 0))) = x; + return(x); } -static s7_pointer -vector_into_string (s7_pointer vect, s7_pointer dest) { - const s7_pointer* elements= vector_elements (vect); - const s7_int len = vector_length (vect); - if (is_byte_vector (dest)) { - uint8_t* str= (uint8_t*) byte_vector_bytes (dest); - for (s7_int i= 0; i < len; i++) - str[i]= (uint8_t) integer (elements[i]); - } - else { - uint8_t* str= (uint8_t*) string_value (dest); - for (s7_int i= 0; i < len; i++) - str[i]= character (elements[i]); - } - return (dest); -} - -#define sort_n(Sc) integer (vector_element (Sc->code, 0)) -#define sort_k(Sc) integer (vector_element (Sc->code, 1)) -#define sort_j(Sc) integer (vector_element (Sc->code, 2)) -#define sort_k1(Sc) integer (vector_element (Sc->code, 3)) -#define sort_calls(Sc) integer (vector_element (Sc->code, 4)) -#define sort_stop(Sc) integer (vector_element (Sc->code, 5)) -#define sort_data(Sc, K) vector_element (car (Sc->args), K) -#define sort_lessp(Sc) cadr (Sc->args) - -static s7_pointer -op_heapsort (s7_scheme* sc) { - s7_int n= sort_n (sc), j, k= sort_k1 (sc); - 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 (sc)++; - if (sort_calls (sc) > sort_stop (sc)) - error_nr ( - sc, sc->out_of_range_symbol, - set_elist_2 ( - sc, - wrap_string ( - sc, "sort! is caught in an infinite loop, comparison: ~S", - 51), - sort_lessp (sc))); - } - j = 2 * k; - sort_j (sc)= j; - if (j < n) { - const s7_pointer lx= sort_lessp (sc); /* cadr of sc->args */ - push_stack_direct (sc, OP_SORT1); - if (needs_copied_args (lx)) - sc->args= list_2 (sc, sort_data (sc, j), sort_data (sc, j + 1)); - else sc->args= with_list_t2 (sc, sort_data (sc, j), sort_data (sc, j + 1)); - sc->code = lx; - sc->value= sc->T; /* for eval */ - } - else sc->value= sc->F; - return (NULL); +static s7_double float_vector_set_d_7piiid(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2, s7_int i3, s7_double x) +{ + if ((i1 < 0) || (i1 >= vector_dimension(vec, 0))) + out_of_range_error_nr(sc, sc->float_vector_set_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); + if ((i2 < 0) || (i2 >= vector_dimension(vec, 1))) + out_of_range_error_nr(sc, sc->float_vector_set_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string); + if ((i3 < 0) || (i3 >= vector_dimension(vec, 2))) + out_of_range_error_nr(sc, sc->float_vector_set_symbol, small_int(4), wrap_integer(sc, i3), (i3 < 0) ? it_is_negative_string : it_is_too_large_string); + float_vector(vec, i3 + (i2 * vector_offset(vec, 1)) + (i1 * vector_offset(vec, 0))) = x; + return(x); } -static void -op_sort1 (s7_scheme* sc) { - s7_int j= sort_j (sc), k= sort_k1 (sc); - s7_pointer lx= sort_lessp (sc); - if (is_true (sc, sc->value)) { - j = j + 1; - sort_j (sc)= j; - } - push_stack_direct (sc, OP_SORT2); - if (needs_copied_args (lx)) - sc->args= list_2 (sc, sort_data (sc, k), sort_data (sc, j)); - else sc->args= with_list_t2 (sc, sort_data (sc, k), sort_data (sc, j)); - sc->code= lx; -} - -static bool -op_sort2 (s7_scheme* sc) { - s7_int j= sort_j (sc), k= sort_k1 (sc); - if (j == k) return (true); - if (is_true (sc, sc->value)) { - s7_pointer lx = sort_data (sc, j); - sort_data (sc, j)= sort_data (sc, k); - sort_data (sc, k)= lx; - } - else return (true); - sort_k1 (sc)= sort_j (sc); - return (false); +static s7_pointer float_vector_set_p_pip_direct(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value) +{ + float_vector(vec, index) = real_to_double(sc, value, "float-vector-set!"); + return(value); } -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 (sc); - if (k > 0) { - sort_k (sc) = k - 1; - sort_k1 (sc)= k - 1; - push_stack_direct (sc, OP_SORT); - return (false); - } - return (true); +static s7_pointer float_vector_set_p_ppp(s7_scheme *sc, s7_pointer vec, s7_pointer ind, s7_pointer val) +{ + s7_int index; + if ((!is_float_vector(vec)) || (vector_rank(vec) > 1)) + return(g_vector_set(sc, set_plist_3(sc, vec, ind, val))); + if (is_immutable_vector(vec)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->float_vector_set_symbol, vec)); + if (!s7_is_integer(ind)) + return(g_vector_set(sc, set_plist_3(sc, vec, ind, val))); + index = s7_integer_clamped_if_gmp(sc, ind); + if ((index < 0) || (index >= vector_length(vec))) + out_of_range_error_nr(sc, sc->float_vector_set_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string); + if (!is_real(val)) + wrong_type_error_nr(sc, sc->float_vector_set_symbol, 3, val, sc->type_names[T_REAL]); + float_vector(vec, index) = (is_t_real(val)) ? real(val) : s7_real(val); + return(val); +} + +/* -------------------------------- 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 bool -op_sort3 (s7_scheme* sc) { - s7_int n= sort_n (sc); - s7_pointer lx; - if (n <= 0) { - sc->value= car (sc->args); - return (true); - } - lx = sort_data (sc, 0); - sort_data (sc, 0)= sort_data (sc, n); - sort_data (sc, n)= lx; - sort_n (sc) = n - 1; - sort_k1 (sc) = 0; - push_stack_direct (sc, OP_SORT3); - return (false); +static s7_int int_vector_ref_i_pi_direct(s7_scheme *unused_sc, s7_pointer vec, s7_int index) {return(int_vector(vec, index));} +static s7_pointer int_vector_ref_p_pi_direct(s7_scheme *sc, s7_pointer vec, s7_int index) {return(make_integer(sc, int_vector(vec, index)));} +static s7_pointer int_vector_ref_p_pi_direct_wrapped(s7_scheme *sc, s7_pointer vec, s7_int index) {return(wrap_integer(sc, int_vector(vec, index)));} + +static s7_int int_vector_ref_i_7pi(s7_scheme *sc, s7_pointer vec, s7_int index) +{ + if ((index < 0) || (index >= vector_length(vec))) + out_of_range_error_nr(sc, sc->int_vector_ref_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string); + return(int_vector(vec, index)); } -/* -------- hash tables -------- */ +static s7_int int_vector_ref_i_7pii(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2) +{ + if ((i1 < 0) || (i1 >= vector_dimension(vec, 0))) + out_of_range_error_nr(sc, sc->int_vector_ref_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); + if ((i2 < 0) || (i2 >= vector_dimension(vec, 1))) + out_of_range_error_nr(sc, sc->int_vector_ref_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string); + return(int_vector(vec, i2 + (i1 * vector_offset(vec, 0)))); +} -static void -free_hash_table (s7_scheme* sc, s7_pointer table) { - if (hash_table_entries (table) > 0) { - hash_entry_t** entries= hash_table_elements (table); - const s7_int len = (s7_int) hash_table_size (table); - for (s7_int i= 0; i < len; i++) { - hash_entry_t* n; - for (hash_entry_t* p= entries[i++]; p; p= n) { - n= hash_entry_next (p); - liberate_block (sc, p); - } - for (hash_entry_t* p= entries[i]; p; p= n) { - n= hash_entry_next (p); - liberate_block (sc, p); - } - } - } - liberate (sc, hash_table_block (table)); +static s7_int int_vector_ref_i_7piii(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2, s7_int i3) +{ + if ((i1 < 0) || (i1 >= vector_dimension(vec, 0))) + out_of_range_error_nr(sc, sc->int_vector_ref_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); + if ((i2 < 0) || (i2 >= vector_dimension(vec, 1))) + out_of_range_error_nr(sc, sc->int_vector_ref_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string); + if ((i3 < 0) || (i3 >= vector_dimension(vec, 2))) + out_of_range_error_nr(sc, sc->int_vector_ref_symbol, small_int(4), wrap_integer(sc, i3), (i3 < 0) ? it_is_negative_string : it_is_too_large_string); + return(int_vector(vec, i3 + (i2 * vector_offset(vec, 1)) + (i1 * vector_offset(vec, 0)))); } -static hash_entry_t* -make_hash_entry (s7_scheme* sc, s7_pointer key, s7_pointer value, - s7_int raw_hash) { - hash_entry_t* entry= (hash_entry_t*) mallocate_block (sc); -#if S7_DEBUGGING - sc->blocks_mallocated[BLOCK_LIST]++; -#endif - hash_entry_key (entry)= key; - hash_entry_set_value (entry, value); - hash_entry_set_raw_hash (entry, raw_hash); - return (entry); +static inline s7_pointer int_vector_ref_p_pp(s7_scheme *sc, s7_pointer vec, s7_pointer index) +{ + s7_int ind; + if (!is_int_vector(vec)) + return(method_or_bust_pp(sc, vec, sc->int_vector_ref_symbol, vec, index, sc->type_names[T_INT_VECTOR], 1)); + if (vector_rank(vec) != 1) + return(univect_ref(sc, set_plist_2(sc, vec, 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, vec, index, sc->type_names[T_INTEGER], 2)); + ind = s7_integer_clamped_if_gmp(sc, index); + if ((ind < 0) || (ind >= vector_length(vec))) + out_of_range_error_nr(sc, sc->int_vector_ref_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); + return(make_integer(sc, int_vector(vec, ind))); } -/* -------------------------------- hash-table? -------------------------------- - */ -bool -s7_is_hash_table (s7_pointer p) { - return (is_hash_table (p)); +s7_pointer s7i_int_vector_ref_p_pp(s7_scheme *sc, s7_pointer vec, s7_pointer index) {return(int_vector_ref_p_pp(sc, vec, index));} + +static s7_pointer g_iv_ref_3(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer ivec = car(args); + s7_pointer index; + s7_int ind1, ind2; + if (!is_int_vector(ivec)) + return(method_or_bust(sc, ivec, sc->int_vector_ref_symbol, args, sc->type_names[T_INT_VECTOR], 1)); + if (vector_rank(ivec) != 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, sc->type_names[T_INTEGER], 2)); + ind1 = s7_integer_clamped_if_gmp(sc, index); + if ((ind1 < 0) || (ind1 >= vector_dimension(ivec, 0))) + out_of_range_error_nr(sc, sc->int_vector_ref_symbol, int_two, index, (ind1 < 0) ? it_is_negative_string : it_is_too_large_string); + index = caddr(args); + if (!s7_is_integer(index)) + return(method_or_bust(sc, index, sc->int_vector_ref_symbol, args, sc->type_names[T_INTEGER], 3)); + ind2 = s7_integer_clamped_if_gmp(sc, index); + if ((ind2 < 0) || (ind2 >= vector_dimension(ivec, 1))) + out_of_range_error_nr(sc, sc->int_vector_ref_symbol, int_three, index, (ind2 < 0) ? it_is_negative_string : it_is_too_large_string); + ind1 = ind1 * vector_offset(ivec, 0) + ind2; + return(make_integer(sc, int_vector(ivec, ind1))); +} + +static s7_pointer int_vector_ref_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr) +{ + return((args == 2) ? sc->iv_ref_2 : ((args == 3) ? sc->iv_ref_3 : func)); } -/* g_is_hash_table is now defined in s7_liii_hash_table.c */ -s7_int -s7i_hash_table_entries (s7_pointer table) { - return (hash_table_entries (table)); -} - -s7_pointer -s7i_hash_table_key_typer (s7_scheme* sc, s7_pointer table) { - if (is_typed_hash_table (table)) return (hash_table_key_typer (table)); - return (sc->F); -} - -s7_pointer -s7i_hash_table_value_typer (s7_scheme* sc, s7_pointer table) { - if (is_typed_hash_table (table)) return (hash_table_value_typer (table)); - return (sc->F); -} - -/* -------------------------------- hash-table-entries - * -------------------------------- */ -#define H_hash_table_size \ - "(hash-table-size obj) returns the number of entries in the hash-table obj" -#define Q_hash_table_size \ - s7_make_signature (sc, 2, sc->is_integer_symbol, sc->is_hash_table_symbol) -/* g_hash_table_size and hash_table_size_i_7p are now defined in - * s7_liii_hash_table.c */ - -/* -------------------------------- hash-table-key|value-typer - * -------------------------------- */ -#define H_hash_table_key_typer \ - "(hash-table-key-typer hash) returns the hash-table's key type checking " \ - "function" -#define Q_hash_table_key_typer \ - s7_make_signature ( \ - sc, 2, \ - s7_make_signature (sc, 2, sc->not_symbol, sc->is_procedure_symbol), \ - sc->is_hash_table_symbol) -/* g_hash_table_key_typer is now defined in s7_liii_hash_table.c */ +/* -------------------------------- 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)); +} -#define H_hash_table_value_typer \ - "(hash-table-value-typer hash) returns the hash-table's value type " \ - "checking function" -#define Q_hash_table_value_typer \ - s7_make_signature ( \ - sc, 2, \ - s7_make_signature (sc, 2, sc->not_symbol, sc->is_procedure_symbol), \ - sc->is_hash_table_symbol) -/* g_hash_table_value_typer is now defined in s7_liii_hash_table.c */ +static s7_int int_vector_set_i_7pii_direct(s7_scheme *unused_sc, s7_pointer vec, s7_int index, s7_int x) {int_vector(vec, index) = x; return(x);} -bool -s7i_is_weak_hash_table (s7_pointer p) { - return (is_weak_hash_table (p)); +static s7_pointer int_vector_set_p_pip(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value) +{ + if ((!is_int_vector(vec)) || (!is_t_integer(value)) || (vector_rank(vec) > 1) || (index < 0) || (index >= vector_length(vec))) + return(univect_set(sc, set_plist_3(sc, vec, make_integer(sc, index), value), sc->int_vector_set_symbol, T_INT_VECTOR)); + int_vector(vec, index) = integer(value); + return(value); } -void -s7i_set_weak_hash_table (s7_pointer p) { - set_weak_hash_table (p); +static s7_pointer int_vector_set_p_pip_direct(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value) +{ + int_vector(vec, index) = s7_integer_clamped_if_gmp(sc, value); + return(value); } -void -s7i_set_weak_hash_table_iters (s7_pointer p, s7_int val) { - weak_hash_iters (p)= val; +static s7_int int_vector_set_i_7pii(s7_scheme *sc, s7_pointer vec, s7_int index, s7_int x) +{ + if ((index < 0) || (index >= vector_length(vec))) + out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string); + int_vector(vec, index) = x; + return(x); } -static s7_pointer -make_hash_table_procedures (s7_scheme* sc) { - s7_pointer p= cons (sc, sc->T, sc->T); /* checker, mapped */ - set_opt1_any (p, sc->T); /* key */ - set_opt2_any (p, sc->T); /* value */ - return (p); +static s7_int int_vector_set_i_7piii(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2, s7_int i3) +{ + if ((i1 < 0) || (i1 >= vector_dimension(vec, 0))) + out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); + if ((i2 < 0) || (i2 >= vector_dimension(vec, 1))) + out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string); + int_vector(vec, i2 + (i1 * vector_offset(vec, 0))) = i3; + return(i3); } -static s7_pointer -copy_hash_table_procedures (s7_scheme* sc, s7_pointer table) { - if (is_pair (hash_table_procedures (table))) { - s7_pointer p= cons (sc, hash_table_procedures_checker (table), - hash_table_procedures_mapper (table)); - set_opt1_any (p, hash_table_key_typer (table)); - set_opt2_any (p, hash_table_value_typer (table)); - return (p); - } - return (sc->nil); -} - -static void -check_hash_table_typer (s7_scheme* sc, s7_pointer caller, s7_pointer table, - s7_pointer typer) { - if (is_c_function (typer)) { - s7_pointer sig= c_function_signature (typer); - if ((sig != sc->pl_bt) && (is_pair (sig)) && - ((car (sig) != sc->is_boolean_symbol) || (cadr (sig) != sc->T) || - (!is_null (cddr (sig))))) - wrong_type_error_nr (sc, caller, 2, typer, - wrap_string (sc, "a boolean procedure", 19)); - if (!c_function_name (typer)) - wrong_type_error_nr (sc, caller, 2, typer, - wrap_string (sc, "a named function", 16)); - } - else { - s7_pointer typer_name; - if (!is_any_closure (typer)) - wrong_type_error_nr ( - sc, caller, 2, typer, - wrap_string (sc, "a built-in procedure, a closure or #t", 37)); - typer_name= find_typer (sc, typer); - if (!is_symbol (typer_name)) - wrong_type_error_nr (sc, caller, 2, typer, - wrap_string (sc, "a named function", 16)); - } - if (!s7_is_aritable (sc, typer, 1)) - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_3 (sc, - wrap_string (sc, - "~A: the second argument, ~S, (the type " - "checker) should accept one argument", - 74), - caller, typer)); - if (is_c_function (typer)) { - if (c_function_has_simple_elements (typer)) { - if (caller == sc->hash_table_value_typer_symbol) - set_has_simple_values (table); - else { - set_has_simple_keys (table); - if (symbol_type (c_function_symbol (typer)) != T_FREE) - set_has_hash_key_type (table); - } - } - } - if (is_null (hash_table_procedures (table))) - hash_table_set_procedures (table, make_hash_table_procedures (sc)); - set_is_typed_hash_table (table); -} - -static s7_pointer -g_set_hash_table_key_typer (s7_scheme* sc, s7_pointer args) { - const s7_pointer table= car (args), typer= cadr (args); - - if (!is_hash_table (table)) - wrong_type_error_nr (sc, wrap_string (sc, "set! hash_table-key-typer", 25), - 1, table, sc->type_names[T_HASH_TABLE]); - if (is_immutable_hash_table (table)) - immutable_object_error_nr ( - sc, set_elist_2 ( - sc, - wrap_string ( - sc, "~S is immutable so its key-typer can't be set!", 46), - table)); - - if (is_boolean (typer)) /* remove current typer, if any */ - { - if (is_typed_hash_table (table)) { - hash_table_set_key_typer (table, sc->T); - clear_has_simple_keys (table); - if (hash_table_value_typer (table) == sc->T) - clear_is_typed_hash_table (table); +static s7_pointer int_vector_set_p_ppp(s7_scheme *sc, s7_pointer vec, s7_pointer index, s7_pointer value) +{ + if ((is_int_vector(vec)) && (vector_rank(vec) == 1) && (!is_immutable_vector(vec)) && + (is_t_integer(index)) && (is_t_integer(value))) + { + s7_int i = integer(index); + if ((i < 0) || (i >= vector_length(vec))) + out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_two, index, (i < 0) ? it_is_negative_string : it_is_too_large_string); + int_vector(vec, i) = integer(value); } - } - else { - check_hash_table_typer (sc, sc->hash_table_key_typer_symbol, table, typer); - hash_table_set_key_typer (table, typer); - } - return (typer); -} - -static s7_pointer -g_set_hash_table_value_typer (s7_scheme* sc, s7_pointer args) { - const s7_pointer table= car (args), typer= cadr (args); - - if (!is_hash_table (table)) - wrong_type_error_nr (sc, - wrap_string (sc, "set! hash_table-value-typer", 27), 1, - table, sc->type_names[T_HASH_TABLE]); - if (is_immutable_hash_table (table)) - immutable_object_error_nr ( - sc, set_elist_2 ( - sc, - wrap_string ( - sc, "~S is immutable so its value-typer can't be set!", 48), - table)); - - if (is_boolean (typer)) /* remove current typer, if any */ + else + { + if (!is_int_vector(vec)) + return(method_or_bust_ppp(sc, vec, sc->int_vector_set_symbol, vec, index, value, sc->type_names[T_INT_VECTOR], 1)); + if (vector_rank(vec) != 1) + return(univect_set(sc, set_plist_3(sc, vec, index, value), sc->int_vector_set_symbol, T_INT_VECTOR)); + if (is_immutable_vector(vec)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->int_vector_set_symbol, vec)); + /* (int-vector-set! #i() `(x 1) (abs x)) in a do loop in a function... */ + if (!s7_is_integer(index)) + return(method_or_bust_ppp(sc, index, sc->int_vector_set_symbol, vec, index, value, sc->type_names[T_INTEGER], 2)); + if (!s7_is_integer(value)) + return(method_or_bust_ppp(sc, value, sc->int_vector_set_symbol, vec, index, value, sc->type_names[T_INTEGER], 3)); + if (S7_DEBUGGING) fprintf(stderr, "fell through %s[%d]\n", __func__, __LINE__); + } + return(value); +} + +static s7_pointer g_iv_set_3(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer vec = car(args); + s7_pointer index; + s7_int ind; + if (!is_int_vector(vec)) + return(method_or_bust(sc, vec, sc->int_vector_set_symbol, args, sc->type_names[T_INT_VECTOR], 1)); + if (vector_rank(vec) != 1) + return(univect_set(sc, args, sc->int_vector_set_symbol, T_INT_VECTOR)); + if (is_immutable_vector(vec)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->int_vector_set_symbol, vec)); + index = cadr(args); + if (!s7_is_integer(index)) + return(method_or_bust(sc, index, sc->int_vector_set_symbol, args, sc->type_names[T_INTEGER], 2)); + ind = s7_integer_clamped_if_gmp(sc, index); + if ((ind < 0) || (ind >= vector_length(vec))) + out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); { - if (is_typed_hash_table (table)) { - hash_table_set_value_typer (table, sc->T); - clear_has_simple_values (table); - if (hash_table_key_typer (table) == sc->T) - clear_is_typed_hash_table (table); - } - } - else { - check_hash_table_typer (sc, sc->hash_table_value_typer_symbol, table, - typer); - hash_table_set_value_typer (table, typer); + s7_pointer value = caddr(args); + if (!s7_is_integer(value)) + return(method_or_bust(sc, value, sc->int_vector_set_symbol, args, sc->type_names[T_INTEGER], 3)); + int_vector(vec, ind) = s7_integer_clamped_if_gmp(sc, value); + return(value); } - return (typer); } -/* ---------------- hash map and equality tables ---------------- */ -/* built in hash loc tables for eq? eqv? equal? equivalent? = string=? char=? - * (default=equal?) */ -#define hash_loc(Sc, Table, Key) \ - (*(hash_table_mapper (Table)[type (Key)])) (Sc, Table, Key) +static s7_pointer int_vector_set_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr) +{ + return((args == 3) ? sc->iv_set_3 : func); +} -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]; -/* also default_hash_map */ -/* ---------------- hash-code ---------------- */ -/* eqfunc handling which will require other dummy tables */ +/* -------------------------------- 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_pointer -make_dummy_hash_table (s7_scheme* sc) /* make the absolute minimal hash-table - that can support hash-code */ +static s7_int byte_vector_ref_i_7pi(s7_scheme *sc, s7_pointer vec, s7_int index) { - s7_pointer table= alloc_pointer (sc); - set_type_bit (table, T_IMMUTABLE | T_HASH_TABLE | T_UNHEAP); - hash_table_mapper (table)= default_hash_map; - hash_table_mask (table) = 1; /* we're lying... */ - return (table); + if ((index < 0) || (index >= byte_vector_length(vec))) + out_of_range_error_nr(sc, sc->byte_vector_ref_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string); + return((s7_int)((byte_vector(vec, index)))); } -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_int byte_vector_ref_i_7pii(s7_scheme *sc, s7_pointer vec, s7_int index1, s7_int index2) +{ + if ((index1 < 0) || (index1 >= vector_dimension(vec, 0))) + out_of_range_error_nr(sc, sc->byte_vector_ref_symbol, int_two, wrap_integer(sc, index1), (index1 < 0) ? it_is_negative_string : it_is_too_large_string); + if ((index2 < 0) || (index2 >= vector_dimension(vec, 1))) + out_of_range_error_nr(sc, sc->byte_vector_ref_symbol, int_three, wrap_integer(sc, index2), (index2 < 0) ? it_is_negative_string : it_is_too_large_string); + return((s7_int)byte_vector(vec, index2 + (index1 * vector_offset(vec, 0)))); } -#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) -/* g_hash_code is now defined in s7_liii_hash_table.c */ +/* byte_vector_ref_p_pi_direct migrated to s7_liii_vector.c */ +static s7_int byte_vector_ref_i_7pi_direct(s7_scheme *unused_sc, s7_pointer vec, s7_int index) {return(byte_vector(vec, index));} -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 s7_pointer g_bv_ref_2(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer vec = car(args); + s7_pointer index; + s7_int ind; + if (!is_byte_vector(vec)) + return(method_or_bust(sc, vec, sc->byte_vector_ref_symbol, args, sc->type_names[T_BYTE_VECTOR], 1)); + if (vector_rank(vec) != 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, sc->type_names[T_INTEGER], 2)); + ind = s7_integer_clamped_if_gmp(sc, index); + if ((ind < 0) || (ind >= vector_length(vec))) + out_of_range_error_nr(sc, sc->byte_vector_ref_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); + return(small_int(byte_vector(vec, ind))); +} + +static s7_pointer g_bv_ref_3(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer iv = car(args); + s7_pointer index; + s7_int ind1, ind2; + if (!is_byte_vector(iv)) + return(method_or_bust(sc, iv, sc->byte_vector_ref_symbol, args, sc->type_names[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, sc->type_names[T_INTEGER], 2)); + ind1 = s7_integer_clamped_if_gmp(sc, index); + if ((ind1 < 0) || (ind1 >= vector_dimension(iv, 0))) + out_of_range_error_nr(sc, sc->byte_vector_ref_symbol, int_two, index, (ind1 < 0) ? it_is_negative_string : it_is_too_large_string); + index = caddr(args); + if (!s7_is_integer(index)) + return(method_or_bust(sc, index, sc->byte_vector_ref_symbol, args, sc->type_names[T_INTEGER], 3)); + ind2 = s7_integer_clamped_if_gmp(sc, index); + if ((ind2 < 0) || (ind2 >= vector_dimension(iv, 1))) + out_of_range_error_nr(sc, sc->byte_vector_ref_symbol, int_three, index, (ind2 < 0) ? it_is_negative_string : it_is_too_large_string); + ind1 = ind1 * vector_offset(iv, 0) + ind2; + return(small_int(byte_vector(iv, ind1))); +} + +static s7_pointer byte_vector_ref_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr) +{ + return((args == 2) ? sc->bv_ref_2 : ((args == 3) ? sc->bv_ref_3 : func)); +} -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); +/* -------------------------------- 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)); } -/* ---------------- hash syntax ---------------- */ -static s7_uint -hash_map_syntax (s7_scheme* sc, s7_pointer table, s7_pointer key) { - return (pointer_map (syntax_symbol (key))); +static s7_int byte_vector_set_i_7pii(s7_scheme *sc, s7_pointer vec, s7_int index, s7_int byte) +{ + if (!is_byte_vector(vec)) + wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 1, vec, a_byte_vector_string); + if ((byte < 0) || (byte > 255)) + wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 3, wrap_integer(sc, byte), an_unsigned_byte_string); + if ((index < 0) || (index >= byte_vector_length(vec))) + out_of_range_error_nr(sc, sc->byte_vector_set_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string); + byte_vector(vec, index) = (uint8_t)byte; + return(byte); } -static hash_entry_t* -hash_equal_syntax (s7_scheme* sc, s7_pointer table, s7_pointer key) { - s7_uint loc= hash_loc (sc, table, key) % hash_table_mask (table); - for (hash_entry_t* entry= hash_table_element (table, loc); entry; - entry = hash_entry_next (entry)) - if ((is_syntax (hash_entry_key (entry))) && - (syntax_symbol (hash_entry_key (entry)) == - syntax_symbol ( - key))) /* the opcodes might differ, but the symbols should not */ - return (entry); - return (sc->unentry); +static s7_int byte_vector_set_i_7pii_direct(s7_scheme *unused_sc, s7_pointer vec, s7_int index, s7_int byte) +{ + byte_vector(vec, index) = (uint8_t)byte; + return(byte); } -/* ---------------- hash symbols ---------------- */ -static s7_uint -hash_map_symbol (s7_scheme* sc, s7_pointer table, s7_pointer key) { - return (pointer_map (key)); -} +/* byte_vector_set_p_pip_direct migrated to s7_liii_vector.c */ -static hash_entry_t* -hash_symbol (s7_scheme* sc, s7_pointer table, s7_pointer key) { - s7_uint loc= pointer_map (key) % hash_table_mask (table); - for (hash_entry_t* entry= hash_table_element (table, loc); entry; - entry = hash_entry_next (entry)) - if (key == hash_entry_key (entry)) return (entry); - return (sc->unentry); +static s7_int byte_vector_set_i_7piii(s7_scheme *sc, s7_pointer vec, s7_int index1, s7_int index2, s7_int byte) +{ + if ((byte < 0) || (byte > 255)) + wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 4, wrap_integer(sc, byte), an_unsigned_byte_string); + if ((index1 < 0) || (index1 >= vector_dimension(vec, 0))) + out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_two, wrap_integer(sc, index1), (index1 < 0) ? it_is_negative_string : it_is_too_large_string); + if ((index2 < 0) || (index2 >= vector_dimension(vec, 1))) + out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_three, wrap_integer(sc, index2), (index2 < 0) ? it_is_negative_string : it_is_too_large_string); + byte_vector(vec, index2 + (index1 * vector_offset(vec, 0))) = byte; + return(byte); } -/* ---------------- hash numbers ---------------- */ -static s7_uint -hash_map_int (s7_scheme* sc, s7_pointer table, s7_pointer key) { - s7_int k= integer (key); - return ((k >= 0) ? k : ((k == S7_INT64_MIN) ? S7_INT64_MAX : -k)); -} - -static s7_uint -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))); /* needs to be compatible with - default-hash-table-float-epsilon which is unfortunate */ +static s7_pointer g_bv_set_3(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer vec = car(args); + s7_pointer index, value; + s7_int ind; + if (!is_byte_vector(vec)) + return(method_or_bust(sc, vec, sc->byte_vector_set_symbol, args, sc->type_names[T_BYTE_VECTOR], 1)); + if (vector_rank(vec) != 1) + return(univect_set(sc, args, sc->byte_vector_set_symbol, T_BYTE_VECTOR)); + if (is_immutable_vector(vec)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->byte_vector_set_symbol, vec)); + index = cadr(args); + if (!s7_is_integer(index)) + return(method_or_bust(sc, index, sc->byte_vector_set_symbol, args, sc->type_names[T_INTEGER], 2)); + ind = s7_integer_clamped_if_gmp(sc, index); + if ((ind < 0) || (ind >= vector_length(vec))) + out_of_range_error_nr(sc, sc->byte_vector_set_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); + value = caddr(args); + if (!s7_is_integer(value)) + return(method_or_bust(sc, value, sc->byte_vector_set_symbol, args, sc->type_names[T_INTEGER], 3)); + { + s7_int byte = s7_integer_clamped_if_gmp(sc, value); + if ((byte < 0) || (byte > 255)) + wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 3, value, an_unsigned_byte_string); + byte_vector(vec, ind) = (uint8_t)byte; + } + return(value); } -static s7_uint -hash_float_location (s7_double x) { -#if 0 - s7_double dx; - if ((is_NaN(x)) || (is_inf(x))) return(0); - dx = fabs(x); - if (dx > DOUBLE_TO_INT64_LIMIT) return(0); - return((s7_int)floor(dx)); -#else - /* if ((x > 1.0e16) || (x < -1.0e16) || (is_NaN(x)) || (is_inf(x))) return(0); - */ /* log(DOUBLE_TO_INT64_LIMIT, 10) is about 16 */ - if ((is_NaN (x)) || (is_inf (x))) return (0); - return ((s7_uint) floor (fabs (x))); -#if 0 - decode_float_t num; - num.fx = x; - return((s7_uint)(num.ix)); -#endif -#endif +static s7_pointer byte_vector_set_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr) +{ + return((args == 3) ? sc->bv_set_3 : func); } -/* isnormal here in place of is_NaN and is_inf is slower. - * using x*100 to expand small float bin range runs afoul of the - * hash-table-float-epsilon bin calcs - */ -static s7_uint -hash_map_real (s7_scheme* sc, s7_pointer table, s7_pointer key) { - return (hash_float_location (real (key))); -} -static s7_uint -hash_complex_location (s7_double x) { - return ( - hash_float_location (x)); /* + hash_float_location(imag_part(key)) -- - imag-part confuses epsilon distance calcs */ +/* -------------------------------------------------------------------------------- */ +static bool c_function_is_ok(s7_scheme *sc, s7_pointer x) +{ + s7_pointer func = lookup_unexamined(sc, car(x)); /* lookup_global is usually slower (faster in Snd) */ + if ((func == opt1_cfunc(x)) || + ((func) && (is_any_c_function(func)) && (c_function_class(func) == c_function_class(opt1_cfunc(x))) && (set_opt1_cfunc(x, func)))) + return(true); + sc->last_function = func; + return(false); } -static s7_uint -hash_map_complex (s7_scheme* sc, s7_pointer table, s7_pointer key) { - return (hash_complex_location (real_part (key))); +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 hash_entry_t* -find_number_in_bin (s7_scheme* sc, hash_entry_t* bin, s7_pointer key) { - const s7_double old_eps= sc->equivalent_float_epsilon; - bool (*equiv) (s7_scheme* sc, s7_pointer x, s7_pointer y, shared_info_t* ci)= - 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); - } - /* else fprintf(stderr, "%s[%d]: %s != %s\n", __func__, __LINE__, - * display(key), display(hash_entry_key(bin))); */ - sc->equivalent_float_epsilon= old_eps; - return (NULL); +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->rest_keyword) + return(true); + return(!is_null(p)); } -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 */ - const s7_double keyval = (is_real (key)) ? s7_real (key) : real_part (key); - const s7_double fprobe = fabs (keyval); - const s7_uint iprobe = (s7_uint) floor (fprobe); - const s7_double bin_dist= fprobe - iprobe; -#ifdef __clang__ - s7_uint loc= ((is_NaN (keyval)) || (is_inf (keyval))) - ? 0 - : iprobe % hash_table_mask (table); -#else - s7_uint loc= iprobe % hash_table_mask (table); -#endif - hash_entry_t* i1= - find_number_in_bin (sc, hash_table_element (table, loc), key); - if (i1) return (i1); - - 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); -} - -static hash_entry_t* -hash_int (s7_scheme* sc, s7_pointer table, s7_pointer key) { - if (is_t_integer (key)) { - const s7_uint hash_mask= hash_table_mask (table); - hash_entry_t* entry; - const s7_int kv = integer (key); - const s7_uint loc= s7_int_abs (kv) % hash_mask; - for (entry= hash_table_element (table, loc); entry; - entry= hash_entry_next (entry)) - if (integer (hash_entry_key (entry)) == kv) return (entry); - } - 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 (is_t_real (key)) { - s7_double keyval; - s7_uint loc; - keyval= real (key); - if (is_NaN (keyval)) return (sc->unentry); - loc= hash_float_location (keyval) % hash_table_mask (table); - for (hash_entry_t* entry= hash_table_element (table, loc); entry; - entry = hash_entry_next (entry)) { - if ((is_t_real (hash_entry_key (entry))) && - (keyval == real (hash_entry_key (entry)))) - return (entry); - } - } - return (sc->unentry); -} -static hash_entry_t* -hash_num_eq (s7_scheme* sc, s7_pointer table, s7_pointer key) { - s7_uint loc= hash_loc (sc, table, key) % hash_table_mask (table); - for (hash_entry_t* entry= hash_table_element (table, loc); entry; - entry = hash_entry_next (entry)) - if (num_eq_b_7pp (sc, key, hash_entry_key (entry))) return (entry); - return (sc->unentry); +/* -------------------------------- sort! -------------------------------- */ +static int32_t dbl_less(const void *x1, const void *x2) +{ + if ((*((const s7_double *)x1)) < (*((const s7_double *)x2))) return(-1); + return(((*((const s7_double *)x1)) > (*((const s7_double *)x2))) ? 1 : 0); } -static hash_entry_t* -hash_real_num_eq (s7_scheme* sc, s7_pointer table, s7_pointer key) { - return ((is_NaN (s7_real (key))) ? sc->unentry - : hash_num_eq (sc, table, key)); +static int32_t int_less(const void *x1, const void *x2) +{ + if ((*((const s7_int *)x1)) < (*((const s7_int *)x2))) return(-1); + return(((*((const s7_int *)x1)) > (*((const s7_int *)x2))) ? 1 : 0); } -static hash_entry_t* -hash_complex_num_eq (s7_scheme* sc, s7_pointer table, s7_pointer key) { - return (((is_NaN (real_part (key))) || (is_NaN (imag_part (key)))) - ? sc->unentry - : hash_num_eq (sc, table, key)); +static int32_t dbl_greater(const void *x1, const void *x2) {return(-dbl_less(x1, x2));} +static int32_t int_greater(const void *x1, const void *x2) {return(-int_less(x1, x2));} + +static int32_t byte_less(const void *x1, const void *x2) +{ + if ((*((const uint8_t *)x1)) < (*((const uint8_t *)x2))) return(-1); + return(((*((const uint8_t *)x1)) > (*((const uint8_t *)x2))) ? 1 : 0); } -static hash_entry_t* -hash_number_num_eq (s7_scheme* sc, s7_pointer table, s7_pointer key) { - if (is_number (key)) { - const hash_map_t 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); - s7_uint loc = map (sc, table, key) % hash_table_mask (table); - for (hash_entry_t* entry= hash_table_element (table, loc); entry; - entry = hash_entry_next (entry)) - if (keyi == integer (hash_entry_key ( - entry))) /* not in gmp, hash_int as eq_func, what else - can key be but t_integer? */ - return (entry); - } - else - return ((is_real (key)) ? hash_real_num_eq (sc, table, key) - : hash_complex_num_eq (sc, table, key)); - } - return (sc->unentry); -} +static int32_t byte_greater(const void *x1, const void *x2) {return(-byte_less(x1, x2));} -/* ---------------- hash characters ---------------- */ -static s7_uint -hash_map_char (s7_scheme* sc, s7_pointer table, s7_pointer key) { - return (character (key)); +static int32_t dbl_less_2(const void *x1, const void *x2) +{ + s7_double x = real(*((const s7_pointer *)x1)); + s7_double y = real(*((const s7_pointer *)x2)); + if (x < y) return(-1); + return((x > y) ? 1 : 0); } -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. - */ - s7_uint loc= character (key) % hash_table_mask (table); - for (hash_entry_t* entry= hash_table_element (table, loc); entry; - entry = hash_entry_next (entry)) - if (key == hash_entry_key (entry)) return (entry); - } - return (sc->unentry); +static int32_t int_less_2(const void *x1, const void *x2) +{ + s7_int i1 = integer(*((const s7_pointer *)x1)); + s7_int i2 = integer(*((const s7_pointer *)x2)); + if (i1 < i2) return(-1); + return((i1 > i2) ? 1 : 0); } -/* ---------------- hash strings ---------------- */ -static s7_uint -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)) { - const s7_int key_len = string_length (key); - const s7_uint hash_mask= hash_table_mask (table); - s7_uint 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); /* keep s7_uint */ - - if (key_len <= 8) { - for (hash_entry_t* entry= hash_table_element (table, hash % hash_mask); - entry; entry = hash_entry_next (entry)) - if ((hash == string_hash (hash_entry_key (entry))) && - (key_len == string_length (hash_entry_key (entry)))) - return (entry); - } - else - for (hash_entry_t* entry= hash_table_element (table, hash % hash_mask); - entry; entry = hash_entry_next (entry)) - if ((hash == string_hash (hash_entry_key (entry))) && - (key_len == string_length (hash_entry_key ( - entry))) && /* 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 (entry)), key_len))) - return (entry); - } - return (sc->unentry); -} +static int32_t dbl_greater_2(const void *x1, const void *x2) {return(-dbl_less_2(x1, x2));} +static int32_t int_greater_2(const void *x1, const void *x2) {return(-int_less_2(x1, x2));} -#if !WITH_PURE_S7 -static s7_uint -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)) { - s7_uint hash_mask= hash_table_mask (table); - s7_uint hash = hash_map_ci_string (sc, table, key); - for (hash_entry_t* entry= hash_table_element (table, hash % hash_mask); - entry; entry = hash_entry_next (entry)) - if (scheme_strequal_ci (key, hash_entry_key (entry))) return (entry); - } - return (sc->unentry); +static int32_t str_less_2(const void *s1, const void *s2) +{ + s7_pointer str1 = (*((const s7_pointer *)s1)); + s7_pointer str2 = (*((const s7_pointer *)s2)); + return(scheme_strcmp(str1, str2)); } -#endif -/* ---------------- hash eq? ---------------- */ -static s7_uint -hash_map_nil (s7_scheme* sc, s7_pointer table, s7_pointer key) { - return (type (key)); +static int32_t str_greater_2(const void *s1, const void *s2) {return(-str_less_2(s1, s2));} + +static int32_t chr_less_2(const void *p1, const void *p2) +{ + uint8_t c1 = character(*((const s7_pointer *)p1)); + uint8_t c2 = character(*((const s7_pointer *)p2)); + if (c1 < c2) return(-1); + return((c1 > c2) ? 1 : 0); } -static s7_uint -hash_map_eq (s7_scheme* sc, s7_pointer table, s7_pointer key) { - return (pointer_map (key)); +static int32_t chr_greater_2(const void *c1, const void *c2) {return(-chr_less_2(c1, c2));} + +#if MS_WINDOWS || defined(__APPLE__) || defined(__FreeBSD__) +struct sort_r_data {void *arg; int32_t (*compar)(const void *a1, const void *a2, void *aarg);}; + +static int32_t 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 -static hash_entry_t* -hash_eq (s7_scheme* sc, s7_pointer table, s7_pointer key) { - /* explicit eq? as hash equality func for (for example) symbols as keys */ - s7_uint loc= pointer_map (key) % hash_table_mask (table); /* hash_map_eq */ - for (hash_entry_t* entry= hash_table_element (table, loc); entry; - entry = hash_entry_next (entry)) - if (key == hash_entry_key (entry)) return (entry); - return (sc->unentry); +/* 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. + * + * qsort_r allocates an internal array (msort.c line 221) if the original array is > 1024 elements (or whatever), + * then calls the sort comparison function in a loop, after which it frees its temporary array. This is an unavoidable + * memory leak if the comparison function calls s7_error (or its equivalent) which longjmps to the nearest catch + * (or, sigh, segfaults if none exists). I can't see any way to hack around this memory leak -- don't raise + * an error in the sort function! + */ +static void local_qsort_r(void *base, size_t nmemb, size_t size, int32_t (*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 = (uint8_t *)base; + const uint8_t *after = (uint8_t *)(nmemb * size + array); + size_t h, t; + nmemb /= 4; + h = nmemb + 1; + for (t = 1; nmemb != 0; nmemb /= 4) + t *= 2; + do { + size_t bytes = h * size; + uint8_t *i = (uint8_t *)(array + bytes); + uint8_t *k; + do { + uint8_t *j = (uint8_t *)(i - bytes); + if (compar(j, i, arg) > 0) + { + k = i; + do { + uint8_t *p1 = j, *p2 = k; + const uint8_t *end = (uint8_t *)(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 } -/* ---------------- hash eqv? ---------------- */ -static hash_entry_t* -hash_eqv (s7_scheme* sc, s7_pointer table, s7_pointer key) { - const s7_uint loc= hash_loc (sc, table, key) % hash_table_mask (table); - if (is_number (key)) { - uint8_t key_type= type (key); - for (hash_entry_t* entry= hash_table_element (table, loc); entry; - entry = hash_entry_next (entry)) - if ((key_type == type (hash_entry_key (entry))) && - (numbers_are_eqv (sc, key, hash_entry_key (entry)))) - return (entry); - } - else - for (hash_entry_t* entry= hash_table_element (table, loc); entry; - entry = hash_entry_next (entry)) - if (s7_is_eqv (sc, key, hash_entry_key (entry))) return (entry); - return (sc->unentry); +static int32_t vector_sort(const void *v1, const void *v2, void *arg) +{ + s7_scheme *sc = (s7_scheme *)arg; + return(((*(sc->sort_f))(sc, (*(const s7_pointer *)v1), (*(const s7_pointer *)v2))) ? -1 : 1); } -/* ---------------- hash equal? ---------------- */ -static s7_uint -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. since order doesn't matter, but equal tables need to map to - * the same bin, we can't use key's entries except when key has 1 or 2 entries - * (or 3 to be tedious). Keys are supposed to be constant while keys, so a - * hash-table shouldn't be a key of itself. - */ - const s7_int len= hash_table_entries (key); - if ((len == 0) || (len > 2) || (hash_table_size (key) > 32)) return (len); - { - s7_pointer key1= NULL, val1; - hash_entry_t** els = hash_table_elements (key); - const s7_int size= (s7_int) hash_table_size (key); - for (s7_int i= 0; i < size; i++) - for (hash_entry_t* entry= els[i]; entry; entry= hash_entry_next (entry)) { - if (len == 1) - return (((is_sequence_or_iterator (hash_entry_key (entry))) - ? 0 - : hash_loc (sc, key, hash_entry_key (entry))) + - ((is_sequence_or_iterator (hash_entry_value (entry))) - ? 0 - : hash_loc (sc, key, hash_entry_value (entry)))); - if (!key1) { - key1= hash_entry_key (entry); - val1= hash_entry_value (entry); - } - else - return ( - ((is_sequence_or_iterator (key1)) ? 0 - : hash_loc (sc, key, key1)) + - ((is_sequence_or_iterator (val1)) ? 0 - : hash_loc (sc, key, val1)) + - ((is_sequence_or_iterator (hash_entry_key (entry))) - ? 0 - : hash_loc (sc, key, hash_entry_key (entry))) + - ((is_sequence_or_iterator (hash_entry_value (entry))) - ? 0 - : hash_loc (sc, key, hash_entry_value (entry)))); - } - } - if (S7_DEBUGGING) - fprintf (stderr, "%s[%d]: we should not be here\n", __func__, __LINE__); - return (0); /* placate the compiler */ +static int32_t vector_sort_lt(const void *v1, const void *v2, void *arg) /* for qsort_r */ +{ + s7_pointer i1 = (*(const s7_pointer *)v1); + s7_pointer i2 = (*(const s7_pointer *)v2); + if ((is_t_integer(i1)) && (is_t_integer(i2))) + return((integer(i1) < integer(i2)) ? -1 : 1); + return((lt_b_7pp((s7_scheme *)arg, i1, i2)) ? -1 : 1); } -static s7_uint -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), - as long as it's consistent */ +static int32_t vector_car_sort(const void *v1, const void *v2, void *arg) +{ + s7_scheme *sc = (s7_scheme *)arg; + s7_pointer a = (*(const s7_pointer *)v1); + s7_pointer b = (*(const 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 s7_uint -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 int32_t vector_cdr_sort(const void *v1, const void *v2, void *arg) +{ + s7_scheme *sc = (s7_scheme *)arg; + s7_pointer a = (*(const s7_pointer *)v1); + s7_pointer b = (*(const 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 s7_uint -hash_map_float_vector (s7_scheme* sc, s7_pointer table, s7_pointer key) { - s7_uint loc1, loc2; - if (vector_length (key) == 0) return (0); - /* fprintf(stderr, "mask: %" lu64 ", val: %f, loc: %" lu64 "\n", mask, - * float_vector(key, 0), hash_float_location(float_vector(key, 0))); */ - loc1= hash_float_location (float_vector (key, 0)); - /* fprintf(stderr, "%s[%d]: loc1: %" lu64 "\n", __func__, __LINE__, loc1); */ - if (vector_length (key) == 1) return (loc1); - loc2= hash_float_location (float_vector (key, 1)); - return (vector_length (key) + loc1 + loc2); +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, (*(const s7_pointer *)v1)); /* first slot in curlet */ + slot_set_value(sc->sort_v2, (*(const s7_pointer *)v2)); /* second slot in curlet */ + return((sc->sort_fb(sc->sort_o)) ? -1 : 1); } -static s7_uint -hash_map_complex_vector (s7_scheme* sc, s7_pointer table, s7_pointer key) { - s7_uint loc1, loc2; - if (vector_length (key) == 0) return (0); - loc1= hash_complex_location (creal (complex_vector (key, 0))); - if (vector_length (key) == 1) return (loc1); - loc2= hash_complex_location (creal (complex_vector (key, 1))); - return (vector_length (key) + loc1 + loc2); +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, (*(const s7_pointer *)v1)); /* first slot in curlet */ + slot_set_value(sc->sort_v2, (*(const s7_pointer *)v2)); /* second slot in curlet */ + return((sc->sort_fb(sc->sort_o)) ? -1 : 1); } -static s7_uint -hash_map_vector (s7_scheme* sc, s7_pointer table, s7_pointer key) { - s7_uint loc1, loc2; - if ((vector_length (key) == 0) || - (is_sequence_or_iterator (vector_element (key, 0)))) - return (vector_length (key)); - loc1= hash_loc (sc, table, vector_element (key, 0)); - if ((vector_length (key) == 1) || - (is_sequence_or_iterator (vector_element (key, 1)))) - return (loc1); - loc2= hash_loc (sc, table, vector_element (key, 1)); - return (vector_length (key) + loc1 + loc2); -} - -static s7_uint -hash_map_closure (s7_scheme* sc, s7_pointer table, s7_pointer key) { - const s7_pointer f= hash_table_procedures_mapper (table); - if (f == sc->unused) - error_nr ( - sc, make_symbol (sc, "hash-map-recursion", 18), - set_elist_1 ( - sc, wrap_string (sc, "hash-table map function called recursively", - 42))); - /* check_stack_size(sc); -- perhaps clear typers as well here or save/restore - * hash-table-procedures */ - gc_protect_via_stack (sc, f); - hash_table_set_procedures_mapper (table, sc->F); - sc->value= s7_call (sc, f, set_plist_1 (sc, key)); - unstack_gc_protect (sc); - hash_table_set_procedures_mapper (table, f); - if (!s7_is_integer (sc->value)) - error_nr ( - 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_uint -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. equal? follows outlet, but that is ridiculous here. - */ - s7_pointer slot, slot1= NULL, slot2= NULL; - s7_int slots; +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, (*(const s7_pointer *)v1)); + slot_set_value(sc->sort_v2, (*(const s7_pointer *)v2)); + return((q_temp(sc->opts[0]).fp(sc->opts[0]) == sc->F) ? 1 : -1); +} - if ((key == sc->rootlet) || (!is_not_slot_end (let_slots (key)))) return (0); - for (slot= let_slots (key), slots= 0; is_not_slot_end (slot); - slot= next_slot (slot)) - if (!is_matched_symbol (slot_symbol (slot))) { - if (!slot1) slot1= slot; - else slot2= slot; - set_match_symbol (slot_symbol (slot)); - slots++; +#define sort_o1 1 +#define q_sort(o, i) o->v[sort_o1 + i] +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, (*(const s7_pointer *)v1)); + slot_set_value(sc->sort_v2, (*(const s7_pointer *)v2)); + for (i = 0; i < sc->sort_body_len - 1; i++) + { + o = q_sort(top, i).o1; + q_call(o).fp(o); } - for (slot= let_slots (key); is_not_slot_end (slot); slot= next_slot (slot)) - clear_match_symbol (slot_symbol (slot)); - - if (slots == 1) - return (pointer_map (slot_symbol (slot1)) + - ((is_sequence_or_iterator (slot_value (slot1))) - ? 0 - : hash_loc (sc, table, slot_value (slot1)))); - if (slots == 2) - return (pointer_map (slot_symbol (slot1)) + - ((is_sequence_or_iterator (slot_value (slot1))) - ? 0 - : hash_loc (sc, table, slot_value (slot1))) + - pointer_map (slot_symbol (slot2)) + - ((is_sequence_or_iterator (slot_value (slot2))) - ? 0 - : hash_loc (sc, table, slot_value (slot2)))); - return (slots); -} - -static hash_entry_t* -hash_equal_eq (s7_scheme* sc, s7_pointer table, s7_pointer key) { - s7_uint loc= hash_loc (sc, table, key) % hash_table_mask (table); - for (hash_entry_t* entry= hash_table_element (table, loc); entry; - entry = hash_entry_next (entry)) - if (hash_entry_key (entry) == key) return (entry); - return (sc->unentry); -} - -#define hash_int_abs(x) \ - ((x) >= 0 ? (x) : ((x == S7_INT64_MIN) ? S7_INT64_MAX : -(x))) - -static hash_entry_t* -hash_equal_integer (s7_scheme* sc, s7_pointer table, s7_pointer key) { - const s7_int keyint= integer (key); - const s7_uint loc = hash_int_abs (keyint) % - hash_table_mask (table); /* hash_loc -> hash_map_int */ - for (hash_entry_t* entry= hash_table_element (table, loc); entry; - entry = hash_entry_next (entry)) { - if ((is_t_integer (hash_entry_key (entry))) && - (keyint == integer (hash_entry_key (entry)))) - return (entry); - } - return (sc->unentry); -} - -static hash_entry_t* -hash_equal_ratio (s7_scheme* sc, s7_pointer table, s7_pointer key) { - const s7_int keynum= numerator (key), keyden= denominator (key); - const s7_uint loc= s7_int_abs (keynum / keyden) % - hash_table_mask (table); /* hash_loc -> hash_map_ratio */ - for (hash_entry_t* entry= hash_table_element (table, loc); entry; - entry = hash_entry_next (entry)) { - if ((is_t_ratio (hash_entry_key (entry))) && - (keynum == numerator (hash_entry_key (entry))) && - (keyden == denominator (hash_entry_key (entry)))) - return (entry); - } - return (sc->unentry); -} - -static hash_entry_t* -hash_equal_real (s7_scheme* sc, s7_pointer table, s7_pointer key) { - s7_uint loc; - const s7_double keydbl= real (key); - if (is_NaN (keydbl)) return (sc->unentry); - loc= hash_float_location (keydbl) % hash_table_mask (table); - for (hash_entry_t* entry= hash_table_element (table, loc); entry; - entry = hash_entry_next (entry)) { - if ((is_t_real (hash_entry_key (entry))) && - (keydbl == real (hash_entry_key (entry)))) - return (entry); - } - return (sc->unentry); -} - -static hash_entry_t* -hash_equal_complex (s7_scheme* sc, s7_pointer table, s7_pointer key) { - s7_uint loc; - const s7_double keyrl= real_part (key); - const s7_double keyim= imag_part (key); - - loc= hash_map_complex (sc, table, key) % hash_table_mask (table); - for (hash_entry_t* entry= hash_table_element (table, loc); entry; - entry = hash_entry_next (entry)) { - if ((is_t_complex (hash_entry_key (entry))) && - (keyrl == real_part (hash_entry_key (entry))) && - (keyim == imag_part (hash_entry_key (entry)))) - return (entry); - } - return (sc->unentry); -} - -static hash_entry_t* -hash_equal_any (s7_scheme* sc, s7_pointer table, s7_pointer key) { - bool (*equal) (s7_scheme* sc, s7_pointer x, s7_pointer y, shared_info_t* ci)= - equals[type (key)]; - const s7_uint hash= hash_loc (sc, table, key); - const s7_uint loc = hash % hash_table_mask (table); - for (hash_entry_t* entry= hash_table_element (table, loc); entry; - entry = hash_entry_next (entry)) - if (key == - hash_entry_key (entry)) /* avoid the equal funcs if possible -- this - saves in both hash timing tests */ - return (entry); - for (hash_entry_t* entry= hash_table_element (table, loc); entry; - entry = hash_entry_next (entry)) - if ((hash_entry_raw_hash (entry) == hash) && - (equal (sc, key, hash_entry_key (entry), NULL))) - return (entry); - return (sc->unentry); + o = q_sort(top, i).o1; + if (int_expr) + return((q_call(o).fb(o)) ? -1 : 1); + return((q_call(o).fp(o) != sc->F) ? -1 : 1); } -/* ---------------- hash c_functions ---------------- */ -static s7_uint -hash_map_c_function (s7_scheme* sc, s7_pointer table, s7_pointer key) { - s7_function f= c_function_call (hash_table_procedures_mapper (table)); - return (integer (f (sc, with_list_t1 (sc, key)))); -} +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 s7_uint -hash_map_c_pointer (s7_scheme* sc, s7_pointer table, s7_pointer key) { - return (pointer_map (c_pointer (key))); +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, (*(const s7_pointer *)v1)); + slot_set_value(sc->sort_v2, (*(const s7_pointer *)v2)); + o = q_sort(top, 0).o1; + q_call(o).fp(o); + o = q_sort(top, 1).o1; + return((q_call(o).fb(o)) ? -1 : 1); } -static s7_uint -hash_map_undefined (s7_scheme* sc, s7_pointer table, s7_pointer key) { - return (raw_string_hash ((const uint8_t*) (undefined_name (key) + 1), - undefined_name_length (key) - 1) + - undefined_name_length (key)); - /* undefined_name always starts with "#", so we omit it above */ +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, (*(const s7_pointer *)v1)); + slot_set_value(sc->sort_v2, (*(const 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 s7_uint -hash_map_iterator (s7_scheme* sc, s7_pointer table, s7_pointer key) { - /* cycles can happen here if the iterator_sequence contains the iterator and - * hash_loc checks that element */ - return (type (iterator_sequence (key)) + - hash_loc (sc, table, iterator_sequence (key))); -} - -static hash_entry_t* hash_equal (s7_scheme* sc, s7_pointer table, - s7_pointer key); - -static hash_entry_t* -hash_c_function (s7_scheme* sc, s7_pointer table, s7_pointer key) { - if (is_pair (hash_table_procedures (table))) { - const s7_function f= - c_function_call (hash_table_procedures_checker (table)); - const s7_uint hash= hash_loc (sc, table, key); - const s7_uint loc = hash % hash_table_mask (table); - set_car (sc->t2_1, key); - for (hash_entry_t* entry= hash_table_element (table, loc); entry; - entry = hash_entry_next (entry)) - if (hash_entry_raw_hash (entry) == hash) { - set_car (sc->t2_2, hash_entry_key (entry)); - if (is_true (sc, f (sc, sc->t2_1))) return (entry); - } - return (sc->unentry); - } - return (hash_equal (sc, table, key)); -} +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, (*(const s7_pointer *)v1)); + slot_set_value(sc->sort_v2, (*(const 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); +} + +#define OPT_PRINT 0 /* print info about the opt_* optimizations */ +static s7_b_7pp_t s7_b_7pp_function(s7_pointer f); +static opt_info *alloc_opt_info(s7_scheme *sc); +static bool bool_optimize(s7_scheme *sc, s7_pointer expr); +static bool bool_optimize_nw(s7_scheme *sc, s7_pointer expr); +#if OPT_PRINT +#define cell_optimize(Sc, Expr) cell_optimize_with_line(Sc, Expr, __LINE__) +static bool cell_optimize_with_line(s7_scheme *sc, s7_pointer expr, int line); +#else +static bool cell_optimize(s7_scheme *sc, s7_pointer expr); +#endif -static int32_t -len_upto_100 (s7_pointer p) { - int32_t i= 0; - for (; (is_pair (p)) && (i < 100); i++, p= cdr (p)) - ; - return (i); -} +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) -static s7_uint -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 (or tree-leaves - * == tree_len(sc, p)) with stats like symbols/pairs/constants at top level, - * then use those to spread it out over all the locs. key can be cyclic, so - * tree_len would need to check for cycles. - */ - const s7_pointer p = cdr (key); - s7_uint loc= 0; - - if (!is_sequence_or_iterator (car (key))) - loc= hash_loc (sc, table, car (key)) + 1; - else if ((is_pair (car (key))) && (!is_sequence_or_iterator (caar (key)))) - loc= hash_loc (sc, table, caar (key)) + 1; - if (is_pair (p)) { - if (!is_sequence_or_iterator (car (p))) - loc+= hash_loc (sc, table, car (p)) + 1; - else if ((is_pair (car (p))) && (!is_sequence_or_iterator (caar (p)))) - loc+= hash_loc (sc, table, caar (p)) + 1; - } - else if (!is_sequence_or_iterator (p)) /* include () */ - loc+= hash_loc (sc, table, p); - return ((loc << 3) + - len_upto_100 (key)); /* undefined sanitizer is unhappy here, hash_mask - was not a solution */ -} - -static hash_entry_t* -hash_closure (s7_scheme* sc, s7_pointer table, s7_pointer key) { - if (is_pair (hash_table_procedures (table))) { - const s7_pointer f = hash_table_procedures_checker (table); - const s7_uint hash= hash_loc (sc, table, key); - const s7_uint loc = hash % hash_table_mask (table); - for (hash_entry_t* entry= hash_table_element (table, loc); entry; - entry = hash_entry_next (entry)) - if ((hash_entry_raw_hash (entry) == hash) && - (is_true ( - sc, - s7_call (sc, f, set_plist_2 (sc, key, hash_entry_key (entry)))))) - return (entry); - return (sc->unentry); - } - return (hash_equal (sc, table, key)); -} + const s7_pointer data = car(args); + s7_pointer lessp = cadr(args); + int32_t (*sort_func)(const void *v1, const void *v2, void *arg); -static hash_entry_t* -hash_equal (s7_scheme* sc, s7_pointer table, s7_pointer key) { - return ((*(equal_hash_checks[type (key)])) (sc, table, key)); -} + /* 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 */ + if (type(lessp) < T_CONTINUATION) + return(method_or_bust(sc, lessp, sc->sort_symbol, args, a_procedure_string, 2)); + if (!s7_is_aritable(sc, lessp, 2)) + wrong_type_error_nr(sc, sc->sort_symbol, 2, lessp, an_eq_func_string); + return(sc->nil); + } + + if (!is_sequence(data)) /* precede immutable because #f (for example) is immutable: "can't sort #f because it is immutable" is a joke */ + wrong_type_error_nr(sc, sc->sort_symbol, 1, data, a_sequence_string); + if (is_immutable(data)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->sort_symbol, data)); + if (is_let(data)) + if_method_exists_return_value(sc, data, sc->sort_symbol, args); + + if (type(lessp) <= T_GOTO) + return(method_or_bust(sc, lessp, sc->sort_symbol, args, a_procedure_string, 2)); + if (!s7_is_aritable(sc, lessp, 2)) + wrong_type_error_nr(sc, sc->sort_symbol, 2, lessp, an_eq_func_string); + if ((is_any_macro(lessp)) && (!is_c_macro(lessp))) + clear_all_optimizations(sc, closure_body(lessp)); + sort_func = NULL; + sc->sort_f = NULL; -/* ---------------- hash equivalent? ---------------- */ -static hash_entry_t* -hash_equivalent (s7_scheme* sc, s7_pointer table, s7_pointer key) { - hash_entry_t* entry; - s7_uint hash, loc; - - if (is_number (key)) { - entry= hash_number_equivalent (sc, table, key); - if ((entry != sc->unentry) || (!is_nan_b_7p (sc, key))) return (entry); - for (entry= hash_table_element (table, 0); entry; - entry= hash_entry_next (entry)) /* NaN is mapped to 0 */ - if (is_nan_b_7p (sc, - hash_entry_key ( - entry))) /* all NaN's are the same to equivalent? */ - return (entry); - return (sc->unentry); - } - hash= hash_loc (sc, table, key); - loc = hash % hash_table_mask (table); - for (entry= hash_table_element (table, loc); entry; - entry= hash_entry_next (entry)) - if (hash_entry_key (entry) == key) return (entry); - - for (entry= hash_table_element (table, loc); entry; - entry= hash_entry_next (entry)) - if ((hash_entry_raw_hash (entry) == hash) && - (s7_is_equivalent (sc, hash_entry_key (entry), key))) - return (entry); - return (sc->unentry); -} - -static bool -hash_keys_not_cyclic (s7_scheme* sc, s7_pointer hash) { - return ((is_null (hash_table_procedures (hash))) && - (hash_table_mapper (hash) == default_hash_map) && - (hash_table_checker (hash) != hash_equal) && - (hash_table_checker (hash) != hash_equivalent) && - (hash_table_checker (hash) != hash_closure) && - (hash_table_checker (hash) != hash_c_function)); -} - -/* -------------------------------- make-hash-table - * -------------------------------- */ -s7_pointer -s7_make_hash_table (s7_scheme* sc, s7_int size) { - /* 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 ? */ + if (is_safe_c_function(lessp)) /* (sort! a <) */ { - size--; - size|= (size >> 1); - size|= (size >> 2); - size|= (size >> 4); - size|= (size >> 8); - size|= (size >> 16); - size|= (size >> 32); + s7_pointer sig = c_function_signature(lessp); + if ((sig) && + (is_pair(sig)) && + (car(sig) != sc->is_boolean_symbol)) + wrong_type_error_nr(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; } - size++; - } - { - s7_pointer table; - block_t* 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; - if ((S7_DEBUGGING) && (size <= 1)) - fprintf (stderr, "%s[%d]: hash-table size: %" ld64 "\n", __func__, - __LINE__, size); - hash_table_set_block (table, els); - hash_table_elements (table)= (hash_entry_t**) (block_data (els)); - 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); - } -} + else + { + if (is_closure(lessp)) + { + const s7_pointer expr = car(closure_body(lessp)); + const s7_pointer pars = closure_pars(lessp); -static bool -compatible_types (s7_scheme* sc, const s7_pointer eq_type, - const 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); -} - -s7_pointer -s7i_make_hash_table_1 (s7_scheme* sc, s7_pointer args, s7_pointer caller) { -#define H_make_hash_table \ - "(s7-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_pair (args)) { - const s7_pointer len= car (args); - if (!s7_is_integer (len)) - return ( - method_or_bust (sc, len, caller, args, sc->type_names[T_INTEGER], 1)); - size= s7_integer_clamped_if_gmp (sc, len); - if (size < 0) /* we need s7_int here to catch (make-hash-table - most-negative-fixnum) etc */ - out_of_range_error_nr ( - sc, caller, int_one, len, - wrap_string (sc, "it should be a positive integer", 31)); - if ((size > sc->max_vector_length) || - (size >= (1LL << 32))) /* s7test tests >= */ - out_of_range_error_nr (sc, caller, int_one, len, it_is_too_large_string); - if (size == 0) size= sc->default_hash_table_length; - - if (is_pair (cdr (args))) { - s7_pointer proc; - const s7_pointer table= s7_make_hash_table (sc, size); - /* check for typers */ - if (is_pair (cddr (args))) { - const s7_pointer typers= caddr (args); - if (is_pair (typers)) { - const 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)))) - wrong_type_error_nr ( - sc, caller, 3, typers, - wrap_string (sc, "(key-type . value-type)", 23)); - - if ((keyp != sc->T) && (!s7_is_aritable (sc, keyp, 1))) - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, - "~A: in the third argument, ~S, (the key/value type " - "checkers) both functions should take one argument", - 100), - caller, typers)); - hash_table_set_procedures (table, make_hash_table_procedures (sc)); - hash_table_set_key_typer (table, keyp); - hash_table_set_value_typer (table, valp); - if (is_c_function (keyp)) { - if (!c_function_name (keyp)) - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, - "~A: in the third argument, ~S, (the key/value " - "type checkers) the first function is anonymous", - 92), - caller, typers)); - if (c_function_has_simple_elements (keyp)) - set_has_simple_keys (table); - if (symbol_type (c_function_symbol (keyp)) != T_FREE) - set_has_hash_key_type (table); - /* 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= 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)))) - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_3 ( - sc, - wrap_string (sc, - "~A: in the third argument, the key " - "type function is not compatible with " - "the equality function: ~S", - 97), - caller, typers)); - } - } - else if ((is_any_closure (keyp)) && - (!is_symbol (find_closure (sc, keyp, closure_let (keyp))))) - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, - "~A: in the third argument, ~S, (the key/value type " - "checkers) the first function is anonymous", - 92), - caller, typers)); - if ((valp != sc->T) && (!s7_is_aritable (sc, valp, 1))) - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, - "~A: in the third argument, ~S, (the key/value type " - "checkers) both functions should take one argument", - 100), - caller, typers)); - if (is_c_function (valp)) { - if (!c_function_name (valp)) - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, - "~A: in the third argument, ~S, (the key/value " - "type checkers) the second function is anonymous", - 93), - caller, typers)); - if (c_function_has_simple_elements (valp)) - set_has_simple_values (table); - if (symbol_type (c_function_symbol (valp)) != T_FREE) - set_has_hash_value_type (table); - } - else if ((is_any_closure (valp)) && - (!is_symbol (find_closure (sc, valp, closure_let (valp))))) - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, - "~A: in the third argument, ~S, (the key/value type " - "checkers) the second function is anonymous", - 93), - caller, typers)); - set_is_typed_hash_table (table); - } - } - else if (typers != sc->F) - wrong_type_error_nr ( - sc, caller, 3, typers, - wrap_string ( - sc, "either #f or (cons key-type-check value-type-check)", - 51)); - } + if ((is_pair(pars)) && /* closure args not a symbol, etc */ + (!arglist_has_rest(sc, pars))) + { + 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_defined_global(car(expr))) && /* (sort! x (lambda (car y) (car x)...))! */ + (c_function_is_ok(sc, expr))))) + { + const int32_t orig_data = optimize_op(expr); + set_optimize_op(expr, optimize_op(expr) | 1); + if ((optimize_op(expr) == HOP_SAFE_C_SS) && + (car(pars) == cadr(expr)) && + (cadr(pars) == caddr(expr))) + { + s7_pointer 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) + { + const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); + if (((car(arg1) == sc->car_symbol) || (car(arg1) == sc->cdr_symbol)) && + (car(arg1) == car(arg2)) && + (car(pars) == cadr(arg1)) && + (cadr(pars) == cadr(arg2))) /* expr: (< (car a) (car b)) etc */ + { + s7_pointer lp = lookup(sc, car(expr)); + sc->sort_f = s7_b_7pp_function(lp); + if (sc->sort_f) + { + sort_func = ((car(arg1) == sc->car_symbol) ? vector_car_sort : vector_cdr_sort); + lessp = lp; + }}} + set_optimize_op(expr, orig_data); + } + + if (!sort_func) + { + s7_pointer init_val; + const s7_pointer old_let = sc->curlet; + const s7_pointer lessp_body = closure_body(lessp); + if (is_float_vector(data)) + init_val = real_zero; + else init_val = ((is_int_vector(data)) || (is_byte_vector(data))) ? int_zero : sc->F; + set_curlet(sc, inline_make_let_with_two_slots(sc, closure_let(lessp), car(pars), init_val, cadr(pars), 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(lessp_body))) + { + if (!no_bool_opt(lessp_body)) + { + s7_pfunc sf1 = s7_bool_optimize(sc, lessp_body); + if (sf1) + { + if (q_call(sc->opts[0]).fb == p_to_b) + sort_func = opt_bool_sort_p; + else + { + sc->sort_o = sc->opts[0]; + sc->sort_fb = q_call(sc->sort_o).fb; + sort_func = (sc->pc == 1) ? opt_bool_sort_0 : opt_bool_sort; + }} + else set_no_bool_opt(lessp_body); + }} + else + { + sc->sort_body_len = s7_list_length(sc, lessp_body); + if (sc->sort_body_len < (num_vunions - sort_o1)) + { + s7_pointer p; + int32_t ctr; + opt_info *top; + sc->pc = 0; + top = alloc_opt_info(sc); + for (ctr = 0, p = lessp_body; is_pair(cdr(p)); ctr++, p = cdr(p)) + { + q_sort(top, ctr).o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) + break; + } + if (is_null(cdr(p))) + { + int32_t start = sc->pc; + q_sort(top, 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 + { + sc->pc = start; + if (cell_optimize(sc, p)) + sort_func = opt_begin_bool_sort_p; + }}}} + if (!sort_func) + set_curlet(sc, old_let); + } + if ((!sort_func) && + (is_safe_closure(lessp))) /* no embedded sort! or call/cc, etc */ + { + set_curlet(sc, make_let_with_two_slots(sc, closure_let(lessp), car(pars), sc->F, cadr(pars), 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)); + }}}} - /* check eq_func */ - proc= cadr (args); - if (is_c_function (proc)) { - hash_set_chosen (table); + { + s7_int len = 0; + switch (type(data)) + { + case T_PAIR: + len = s7_list_length(sc, data); /* 0 here == infinite */ + if (len <= 0) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "sort! first argument should be a proper list: ~S", 48), data)); + if (len < 2) + return(data); + if (sort_func) + { + s7_int i = 0; + s7_pointer vec = g_vector(sc, data); + s7_pointer *elements = s7_vector_elements(vec); + gc_protect_2_via_stack(sc, vec, data); + local_qsort_r((void *)elements, len, sizeof(s7_pointer), sort_func, (void *)sc); + for (s7_pointer p = data; i < len; i++, p = cdr(p)) + { + if (is_immutable_pair(p)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->sort_symbol, data)); + set_car(p, elements[i]); + } + unstack_gc_protect(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: + { + 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); + }} + { + s7_pointer vec = make_simple_vector(sc, len); + s7_pointer *elements = s7_vector_elements(vec); + gc_protect_2_via_stack(sc, vec, data); + if (is_byte_vector(data)) + for (s7_int i = 0; i < len; i++) elements[i] = small_int(chrs[i]); + else for (s7_int i = 0; i < len; i++) elements[i] = chars[chrs[i]]; + if (sort_func) + { + local_qsort_r((void *)elements, len, sizeof(s7_pointer), sort_func, (void *)sc); + if (is_byte_vector(data)) + for (s7_int i = 0; i < len; i++) chrs[i] = (char)integer(elements[i]); + else for (s7_int i = 0; i < len; i++) chrs[i] = character(elements[i]); + unstack_gc_protect(sc); /* not pop_stack! */ + return(data); + } + unstack_gc_protect(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: case T_COMPLEX_VECTOR: + { + len = vector_length(data); + if (len < 2) + return(data); + if ((is_c_function(lessp)) && (!is_complex_vector(data))) /* < and > make no sense in the complex case */ + { + if (sc->sort_f == lt_b_7pp) + { + if (is_float_vector(data)) + qsort((void *)float_vector_floats(data), len, sizeof(s7_double), dbl_less); + else qsort((void *)int_vector_ints(data), len, sizeof(s7_int), int_less); + return(data); + } + if (sc->sort_f == gt_b_7pp) + { + if (is_float_vector(data)) + qsort((void *)float_vector_floats(data), len, sizeof(s7_double), dbl_greater); + else qsort((void *)int_vector_ints(data), len, sizeof(s7_int), int_greater); + return(data); + }} + /* currently we have to make the ordinary vector here 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) + */ + { + s7_pointer 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. + */ + s7_pointer *elements = s7_vector_elements(vec); + gc_protect_2_via_stack(sc, vec, data); + add_vector(sc, vec); + check_free_heap_size(sc, len); + if (is_float_vector(data)) + for (s7_int i = 0; i < len; i++) elements[i] = make_real_unchecked(sc, float_vector(data, i)); + else + if (is_int_vector(data)) + for (s7_int i = 0; i < len; i++) elements[i] = make_integer_unchecked(sc, int_vector(data, i)); + else for (s7_int i = 0; i < len; i++) elements[i] = c_complex_to_s7(sc, complex_vector(data, i)); + if (sort_func) + { + local_qsort_r((void *)elements, len, sizeof(s7_pointer), sort_func, (void *)sc); + if (is_float_vector(data)) + for (s7_int i = 0; i < len; i++) float_vector(data, i) = real(elements[i]); + else + if (is_int_vector(data)) + for (s7_int i = 0; i < len; i++) int_vector(data, i) = integer(elements[i]); + else for (s7_int i = 0; i < len; i++) complex_vector(data, i) = s7_to_c_complex(elements[i]); + unstack_gc_protect(sc); + return(data); + } + set_car(args, vec); + begin_temp(sc->y, cons(sc, data, lessp)); + unstack_gc_protect(sc); + push_stack(sc, OP_SORT_VECTOR_END, sc->y, sc->code); /* save and gc protect the original homogeneous vector and func */ + end_temp(sc->y); + }} + break; - if (!s7_is_aritable (sc, proc, 2)) - wrong_type_error_nr (sc, caller, 2, proc, an_eq_func_string); + case T_VECTOR: + len = vector_length(data); + if (len < 2) + return(data); + if (sort_func) + { + s7_pointer *els = s7_vector_elements(data); + int32_t typ = type(els[0]); + if ((typ == T_INTEGER) || (typ == T_REAL) || (typ == T_STRING) || (typ == T_CHARACTER)) + for (s7_int 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; - if (c_function_call (proc) == g_is_equal) { - hash_table_checker (table)= hash_equal; - return (table); - } - if (c_function_call (proc) == g_is_equivalent) { - hash_table_checker (table)= hash_equivalent; - hash_table_mapper (table)= - equivalent_hash_map; /* needed only by hash_table_equal_1 - (checker_locked looks at mapper?!) */ - return (table); - } - if (c_function_call (proc) == g_is_eq) { - hash_table_checker (table)= hash_eq; - hash_table_mapper (table) = eq_hash_map; - return (table); - } - if (c_function_call (proc) == g_strings_are_equal) { - hash_table_checker (table)= hash_string; - hash_table_mapper (table) = string_eq_hash_map; - return (table); - } - if (c_function_call (proc) == g_chars_are_equal) { - hash_table_checker (table)= hash_char; - hash_table_mapper (table) = char_eq_hash_map; - return (table); - } - if (c_function_call (proc) == g_num_eq) { - if ((is_typed_hash_table (table)) && - (hash_table_key_typer (table) == - global_value (sc->is_integer_symbol))) - hash_table_checker (table)= hash_int; - else hash_table_checker (table)= hash_number_num_eq; - return (table); - } - if (c_function_call (proc) == g_is_eqv) { - hash_table_checker (table)= hash_eqv; - return (table); - } - error_nr (sc, sc->out_of_range_symbol, - set_elist_3 (sc, - wrap_string (sc, - "~A second argument, ~S, is not a " - "built-in function it can handle", - 64), - caller, proc)); - } - /* proc not c_function */ - else { - if (is_pair (proc)) { - const s7_pointer checker= car (proc), mapper= cdr (proc); - - hash_set_chosen (table); - if (!((is_any_c_function (checker)) || (is_any_closure (checker)))) - error_nr ( - 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)))) - error_nr ( - 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)) - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, - "~A's equality function, ~A, (car of the second " - "argument) should be a function of two arguments", - 94), - caller, checker)); - if (!s7_is_aritable (sc, mapper, 1)) - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, - "~A's mapping function, ~A, (cdr of the second " - "argument) should be a function of one argument", - 92), - caller, mapper)); - - if (is_any_c_function (checker)) { - s7_pointer sig= c_function_signature (checker); - if ((sig) && (is_pair (sig)) && - (car (sig) != sc->is_boolean_symbol)) - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_3 (sc, - wrap_string (sc, - "~A checker function, ~S, should " - "return a boolean value", - 54), - caller, checker)); - hash_table_checker (table)= hash_c_function; - } - else hash_table_checker (table)= hash_closure; - - if (is_any_c_function (mapper)) { - const s7_pointer sig= c_function_signature (mapper); - if ((sig) && (is_pair (sig)) && - (car (sig) != sc->is_integer_symbol)) - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, - "~A mapper function, ~S, should return an integer", - 48), - caller, mapper)); - hash_table_mapper (table)= c_function_hash_map; - } - else hash_table_mapper (table)= closure_hash_map; - - if (is_null (hash_table_procedures (table))) - hash_table_set_procedures (table, make_hash_table_procedures (sc)); - hash_table_set_procedures_checker ( - table, car (proc)); /* proc = cadr(args) */ - hash_table_set_procedures_mapper (table, cdr (proc)); - return (table); - } - if (proc != sc->F) - wrong_type_error_nr ( - sc, caller, 2, proc, - wrap_string (sc, "either #f or (cons equality-func map-func)", - 42)); - return (table); + default: + return(method_or_bust(sc, data, sc->sort_symbol, args, wrap_string(sc, "a sortable sequence", 19), 1)); } - } - } - return (s7_make_hash_table (sc, size)); + { + s7_int n = len - 1; + s7_int k = (n / 2) + 1; + s7_pointer lx = make_simple_vector(sc, (sc->safety <= no_safety) ? 4 : 6); + t_vector_fill(lx, sc->nil); /* make_mutable_integer below can trigger GC, so all elements of lx must be legit */ + begin_temp(sc->y, 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_unchecked(sc, n * n); + } + push_stack(sc, OP_SORT, args, lx); + end_temp(sc->y); + }} + 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. + */ } -/* g_make_hash_table is now defined in s7_liii_hash_table.c */ - -/* -------------------------------- make-weak-hash-table - * -------------------------------- */ -#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)) -/* g_make_weak_hash_table is now defined in s7_liii_hash_table.c */ - -static const char* -hash_table_checker_name (s7_scheme* sc, s7_pointer table) { - if (hash_table_checker (table) == hash_equal) return ("equal?"); - if (hash_table_checker (table) == hash_equivalent) return ("equivalent?"); - if (hash_table_checker (table) == hash_eq) return ("eq?"); - if (hash_table_checker (table) == hash_eqv) return ("eqv?"); - if (hash_table_checker (table) == hash_string) return ("string=?"); -#if !WITH_PURE_S7 - if (hash_table_checker (table) == hash_ci_string) return ("string-ci=?"); -#endif - if (hash_table_checker (table) == hash_char) return ("char=?"); - if (hash_table_checker (table) == hash_number_num_eq) return ("="); - return ("#f"); +/* 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) +{ + const s7_pointer *elements = vector_elements(vect); + const s7_int len = vector_length(vect); + s7_int i = 0; + for (s7_pointer p = lst; i < len; i++, p = cdr(p)) + { + if (is_immutable_pair(p)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->sort_symbol, lst)); + set_car(p, elements[i]); + } + return(lst); } -/* -------------------------------- weak-hash-table? - * -------------------------------- */ -#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 -/* g_is_weak_hash_table is now defined in s7_liii_hash_table.c */ - -static void -init_hash_maps (void) { - for (int32_t 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; - 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_COMPLEX_VECTOR]= hash_map_complex_vector; - default_hash_map[T_LET] = hash_map_let; - default_hash_map[T_PAIR] = hash_map_pair; - default_hash_map[T_C_POINTER] = hash_map_c_pointer; - default_hash_map[T_UNDEFINED] = hash_map_undefined; - default_hash_map[T_ITERATOR] = hash_map_iterator; - for (int32_t i= T_OUTPUT_PORT; i < NUM_TYPES; i++) - default_hash_map[i]= hash_map_eq; - - 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; - 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; - - for (int32_t 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) { - const s7_int entries= hash_table_entries (table); - hash_entry_t** old_els= hash_table_elements (table); - const s7_pointer dproc = hash_table_procedures ( - table); /* new block_t so we need to pass this across */ - const s7_uint old_size= hash_table_size (table); - const s7_uint new_size= - old_size * - 4; /* perhaps (old_size < 524288) ? (old_size * 4) : (old_size * 2) */ - const s7_uint hash_mask= new_size - 1; - block_t* new_block= - (block_t*) callocate (sc, new_size * sizeof (hash_entry_t*)); - hash_entry_t** new_els = (hash_entry_t**) (block_data (new_block)); - hash_table_mask (table)= hash_mask; /* was new_size - 1 14-Jun-21 */ - for (s7_uint i= 0; i < old_size; i++) { - hash_entry_t* next; - for (hash_entry_t* entry= old_els[i]; entry; entry= next) { - s7_uint loc= hash_loc (sc, table, hash_entry_key (entry)); - hash_entry_set_raw_hash (entry, loc); - loc%= hash_mask; - next = hash_entry_next (entry); - hash_entry_next (entry)= new_els[loc]; - new_els[loc] = entry; +static s7_pointer vector_into_fi_vector(s7_pointer source, s7_pointer dest) +{ + const s7_pointer *elements = vector_elements(source); + const s7_int len = vector_length(source); + if (is_float_vector(dest)) + { + s7_double *flts = float_vector_floats(dest); + for (s7_int i = 0; i < len; i++) flts[i] = real(elements[i]); } - } - liberate (sc, hash_table_block (table)); - hash_table_set_block (table, new_block); - hash_table_elements (table)= new_els; - hash_table_set_procedures (table, dproc); - hash_table_entries (table)= entries; + else + { + s7_int *ints = int_vector_ints(dest); + for (s7_int i = 0; i < len; i++) ints[i] = integer(elements[i]); + } + return(dest); } -/* -------------------------------- 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 vector_into_string(s7_pointer vect, s7_pointer dest) +{ + const s7_pointer *elements = vector_elements(vect); + const s7_int len = vector_length(vect); + if (is_byte_vector(dest)) + { + uint8_t *str = (uint8_t *)byte_vector_bytes(dest); + for (s7_int i = 0; i < len; i++) str[i] = (uint8_t)integer(elements[i]); + } + else + { + uint8_t *str = (uint8_t *)string_value(dest); + for (s7_int i = 0; i < len; i++) str[i] = character(elements[i]); + } + return(dest); } -#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) -/* g_hash_table_ref is now defined in s7_liii_hash_table.c */ -/* g_hash_table_ref_2 is now defined in s7_liii_hash_table.c */ +#define sort_n(Sc) integer(vector_element(Sc->code, 0)) +#define sort_k(Sc) integer(vector_element(Sc->code, 1)) +#define sort_j(Sc) integer(vector_element(Sc->code, 2)) +#define sort_k1(Sc) integer(vector_element(Sc->code, 3)) +#define sort_calls(Sc) integer(vector_element(Sc->code, 4)) +#define sort_stop(Sc) integer(vector_element(Sc->code, 5)) +#define sort_data(Sc, K) vector_element(car(Sc->args), K) +#define sort_lessp(Sc) cadr(Sc->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), - sc->type_names[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 table= lookup_checked (sc, car (sc->code)); - if (!is_hash_table (table)) { - sc->last_function= table; - return (false); - } - sc->value= s7_hash_table_ref (sc, table, fx_call (sc, cdr (sc->code))); - return (true); -} - -static s7_pointer -fx_implicit_hash_table_ref_a (s7_scheme* sc, s7_pointer arg) { - s7_pointer table= lookup_checked (sc, car (arg)); - if (!is_hash_table (table)) - return ( - s7_apply_function (sc, table, list_1 (sc, fx_call (sc, cdr (arg))))); - return (s7_hash_table_ref (sc, table, fx_call (sc, cdr (arg)))); -} - -static bool -op_implicit_hash_table_ref_aa (s7_scheme* sc) { - s7_pointer in_obj, out_key; - const s7_pointer table= lookup_checked (sc, car (sc->code)); - if (!is_hash_table (table)) { - sc->last_function= table; - return (false); - } - out_key= fx_call (sc, cdr (sc->code)); - in_obj = s7_hash_table_ref (sc, table, out_key); - if (is_hash_table (in_obj)) - sc->value= s7_hash_table_ref (sc, in_obj, fx_call (sc, cddr (sc->code))); - else - sc->value= implicit_pair_index_checked ( - sc, table, in_obj, - set_plist_2 (sc, out_key, - fx_call (sc, cddr (sc->code)))); /* -> implicit_index */ - return (true); -} - -static s7_pointer -hash_table_ref_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer expr) { - if (args == 2) { - s7_pointer key= caddr (expr); - if ((is_pair (key)) && (car (key) == sc->substring_symbol) && - (is_global (sc->substring_symbol))) - set_class_and_fn_proc (key, sc->substring_uncopied); - return (sc->hash_table_ref_2); - } - return (func); -} - -/* -------------------------------- hash-table-set! - * -------------------------------- */ -static s7_pointer -remove_from_hash_table (s7_scheme* sc, s7_pointer table, - const hash_entry_t* p) { - hash_entry_t* entry; - s7_uint loc; - - if (p == sc->unentry) return (missing_key_value (sc)); - loc = hash_entry_raw_hash (p) % hash_table_mask (table); - entry= hash_table_element (table, loc); - if (entry == p) hash_table_element (table, loc)= hash_entry_next (entry); - else { - hash_entry_t* y; - for (y= entry, entry= hash_entry_next (entry); entry; - y= entry, entry= hash_entry_next (entry)) - if (entry == p) { - hash_entry_next (y)= hash_entry_next (entry); - break; - } - } - hash_table_entries (table)--; - if ((hash_table_entries (table) == 0) && - (hash_table_mapper (table) == default_hash_map)) { - hash_table_checker (table)= hash_empty; - hash_clear_chosen (table); - } - liberate_block (sc, entry); - return (sc->F); -} - -static void -cull_weak_hash_table (s7_scheme* sc, s7_pointer table) { - const s7_int len = (s7_int) hash_table_size (table); - hash_entry_t** entries= hash_table_elements (table); - for (s7_int i= 0; i < len; i++) { - hash_entry_t *nxp, *lxp= entries[i]; - for (hash_entry_t* entry= entries[i]; entry; entry= nxp) { - nxp= hash_entry_next (entry); - if (is_free_and_clear (hash_entry_key (entry))) { - if (entry == entries[i]) { - entries[i]= nxp; - lxp = nxp; - } - else hash_entry_next (lxp)= nxp; - liberate_block (sc, entry); - hash_table_entries (table)--; - if (hash_table_entries (table) == 0) { - if (hash_table_mapper (table) == default_hash_map) { - hash_table_checker (table)= hash_empty; - hash_clear_chosen (table); - } - return; - } - } - else lxp= entry; +static s7_pointer op_heapsort(s7_scheme *sc) +{ + s7_int n = sort_n(sc), j, k = sort_k1(sc); + 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(sc)++; + if (sort_calls(sc) > sort_stop(sc)) + error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "sort! is caught in an infinite loop, comparison: ~S", 51), sort_lessp(sc))); } - } + j = 2 * k; + sort_j(sc) = j; + if (j < n) + { + const s7_pointer lx = sort_lessp(sc); /* cadr of sc->args */ + push_stack_direct(sc, OP_SORT1); + if (needs_copied_args(lx)) + sc->args = list_2(sc, sort_data(sc, j), sort_data(sc, j + 1)); + else sc->args = with_list_t2(sc, sort_data(sc, j), sort_data(sc, j + 1)); + sc->code = lx; + sc->value = sc->T; /* for eval */ + } + else sc->value = sc->F; + return(NULL); } -static void -hash_table_set_default_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 void op_sort1(s7_scheme *sc) +{ + s7_int j = sort_j(sc), k = sort_k1(sc); + s7_pointer lx = sort_lessp(sc); + if (is_true(sc, sc->value)) + { + j = j + 1; + sort_j(sc) = j; } - } + push_stack_direct(sc, OP_SORT2); + if (needs_copied_args(lx)) + sc->args = list_2(sc, sort_data(sc, k), sort_data(sc, j)); + else sc->args = with_list_t2(sc, sort_data(sc, k), sort_data(sc, j)); + sc->code = lx; } -static s7_pointer -hash_table_typer_symbol (s7_scheme* sc, s7_pointer typer) { - s7_pointer typer_name; - if (typer == sc->T) return (sc->T); - if (is_c_function (typer)) return (c_function_symbol (typer)); - typer_name= find_typer (sc, typer); - return ((is_symbol (typer_name)) ? typer_name : sc->anon_symbol); +static bool op_sort2(s7_scheme *sc) +{ + s7_int j = sort_j(sc), k = sort_k1(sc); + if (j == k) return(true); + if (is_true(sc, sc->value)) + { + s7_pointer lx = sort_data(sc, j); + sort_data(sc, j) = sort_data(sc, k); + sort_data(sc, k) = lx; + } + else return(true); + sort_k1(sc) = sort_j(sc); + return(false); } -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 */ - { - const s7_pointer typer= hash_table_key_typer (table); - if ((is_c_function (typer)) && - ((uint8_t) symbol_type (c_function_symbol (typer)) != type (key))) { - const char* tstr= make_type_name ( - sc, hash_table_typer_name (sc, hash_table_key_typer (table)), - indefinite_article); - wrong_type_error_nr (sc, wrap_string (sc, "hash-table-set! key", 19), 2, - key, wrap_string (sc, tstr, safe_strlen (tstr))); - } - } - else { - const s7_pointer key_func= hash_table_key_typer (table); - if (key_func != sc->T) { - s7_pointer type_ok; - if (is_c_function (key_func)) - type_ok= c_function_call (key_func) (sc, set_plist_1 (sc, key)); - else type_ok= s7_apply_function (sc, key_func, set_plist_1 (sc, key)); - if (type_ok == sc->F) { - const char* descr= - hash_table_typer_name (sc, hash_table_key_typer (table)); - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_3 (sc, - wrap_string (sc, - "hash-table-set! key ~$ is rejected by " - "the hash-table's key-typer, ~A", - 68), - key, wrap_string (sc, descr, safe_strlen (descr)))); - } - } - } - if (has_hash_value_type (table)) { - const s7_pointer typer= hash_table_value_typer (table); - if ((is_c_function (typer)) && - ((uint8_t) symbol_type (c_function_symbol (typer)) != type (value))) { - const char* tstr= make_type_name ( - sc, hash_table_typer_name (sc, hash_table_value_typer (table)), - indefinite_article); - wrong_type_error_nr (sc, sc->hash_table_set_symbol, 3, value, - wrap_string (sc, tstr, safe_strlen (tstr))); - } - } - else { - const s7_pointer value_func= hash_table_value_typer (table); - if (value_func != sc->T) { - s7_pointer type_ok; - if (is_c_function (value_func)) - type_ok= c_function_call (value_func) (sc, set_plist_1 (sc, value)); - else type_ok= s7_apply_function (sc, value_func, set_plist_1 (sc, value)); - if (type_ok == sc->F) { - const char* descr= - hash_table_typer_name (sc, hash_table_value_typer (table)); - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_3 (sc, - wrap_string (sc, - "hash-table-set! value ~$ is rejected by " - "the hash-table's value-typer, ~A", - 72), - value, wrap_string (sc, descr, safe_strlen (descr)))); - } +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(sc); + if (k > 0) + { + sort_k(sc) = k - 1; + sort_k1(sc) = k - 1; + push_stack_direct(sc, OP_SORT); + return(false); } - } + return(true); } -static void -check_hash_table_checker (s7_scheme* sc, s7_pointer table, s7_pointer key) { - /* 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)) - error_nr (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? */ - error_nr ( - 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)))) - error_nr (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) && (!is_character (key)))) - error_nr (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_ci_string) - ? sc->string_eq_symbol - : ((hash_table_checker (table) == hash_char) - ? sc->char_eq_symbol - : sc->string_eq_symbol)))); -#endif +static bool op_sort3(s7_scheme *sc) +{ + s7_int n = sort_n(sc); + s7_pointer lx; + if (n <= 0) + { + sc->value = car(sc->args); + return(true); + } + lx = sort_data(sc, 0); + sort_data(sc, 0) = sort_data(sc, n); + sort_data(sc, n) = lx; + sort_n(sc) = n - 1; + sort_k1(sc) = 0; + push_stack_direct(sc, OP_SORT3); + return(false); } -s7_pointer -s7_hash_table_set (s7_scheme* sc, s7_pointer table, s7_pointer key, - s7_pointer value) { - hash_entry_t* entry; - - if (value == missing_key_value (sc)) /* normally #f */ - return (remove_from_hash_table ( - sc, table, (*hash_table_checker (table)) (sc, table, key))); - if ((is_typed_hash_table (table)) && - (sc->safety >= no_safety)) /* this order is faster */ - check_hash_types (sc, table, key, value); - - entry= (*hash_table_checker (table)) (sc, table, key); - if (entry != sc->unentry) { - hash_entry_set_value (entry, T_Ext (value)); - return (value); - } - /* hash_entry_raw_hash(entry) 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_default_checker ( - table, - type (key)); /* raw_hash value (hash_loc(sc, table, key)) does not - change via hash_table_set_default_checker etc */ - else if (sc->safety > no_safety) check_hash_table_checker (sc, table, key); - { - s7_uint hash_mask, loc; - entry= mallocate_block (sc); -#if S7_DEBUGGING - sc->blocks_mallocated[BLOCK_LIST]++; -#endif - hash_entry_key (entry)= key; - hash_entry_set_value (entry, T_Ext (value)); - hash_entry_set_raw_hash (entry, hash_loc (sc, table, key)); - hash_mask = hash_table_mask (table); - loc = hash_entry_raw_hash (entry) % hash_mask; - hash_entry_next (entry) = hash_table_element (table, loc); - hash_table_element (table, loc)= entry; - hash_table_entries (table)++; - if (hash_table_entries (table) > hash_mask) resize_hash_table (sc, table); - } - return (value); -} -#define H_hash_table_set \ - "(s7-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) -/* g_hash_table_set is now defined in s7_liii_hash_table.c */ +/* -------- hash tables -------- */ -static s7_pointer -hash_table_set_p_ppp (s7_scheme* sc, s7_pointer table, s7_pointer key, - s7_pointer value) { - if (!is_mutable_hash_table (table)) /* is_hash_table(table) is here */ - return (mutable_method_or_bust_ppp (sc, table, sc->hash_table_set_symbol, - table, key, value, - sc->type_names[T_HASH_TABLE], 1)); - return (s7_hash_table_set (sc, table, key, value)); -} - -static s7_pointer -hash_table_set_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer expr) { - if ((args == 3) && (optimize_op (expr) == HOP_SAFE_C_SSA)) { - const 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))) { - const s7_pointer 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)) { - const 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)) - */ - set_optimize_op (expr, HOP_HASH_TABLE_INCREMENT); - } - } - } - return (func); +static void free_hash_table(s7_scheme *sc, s7_pointer table) +{ + if (hash_table_entries(table) > 0) + { + hash_entry_t **entries = hash_table_elements(table); + const s7_int len = (s7_int)hash_table_size(table); + for (s7_int i = 0; i < len; i++) + { + hash_entry_t *n; + for (hash_entry_t *p = entries[i++]; p; p = n) + { + n = hash_entry_next(p); + liberate_block(sc, p); + } + for (hash_entry_t *p = entries[i]; p; p = n) + { + n = hash_entry_next(p); + liberate_block(sc, p); + }}} + liberate(sc, hash_table_block(table)); } -/* -------------------------------- hash-table -------------------------------- - */ -static inline s7_pointer -hash_table_add (s7_scheme* sc, s7_pointer table, s7_pointer key, - s7_pointer value) { - const s7_uint hash_mask= hash_table_mask (table); - const s7_uint hash = hash_loc (sc, table, key); - const s7_uint loc = hash % hash_mask; - hash_entry_t* entry; - - if (!hash_chosen (table)) - hash_table_set_default_checker ( - table, - type (key)); /* raw_hash value (hash_loc(sc, table, key)) does not - change via hash_table_set_default_checker etc */ - - for (entry= hash_table_element (table, loc); entry; - entry= hash_entry_next (entry)) - if ((hash_entry_raw_hash (entry) == hash) && - (s7_is_equal (sc, hash_entry_key (entry), key))) - return (value); - - entry= mallocate_block (sc); +static hash_entry_t *make_hash_entry(s7_scheme *sc, s7_pointer key, s7_pointer value, s7_int raw_hash) +{ + hash_entry_t *entry = (hash_entry_t *)mallocate_block(sc); #if S7_DEBUGGING sc->blocks_mallocated[BLOCK_LIST]++; #endif - hash_entry_key (entry)= key; - hash_entry_set_value (entry, T_Ext (value)); - hash_entry_set_raw_hash (entry, hash); - hash_entry_next (entry) = hash_table_element (table, loc); - hash_table_element (table, loc)= entry; - hash_table_entries (table)++; - if (hash_table_entries (table) > hash_mask) resize_hash_table (sc, table); - return (value); + hash_entry_key(entry) = key; + hash_entry_set_value(entry, value); + hash_entry_set_raw_hash(entry, raw_hash); + return(entry); } -s7_pointer -s7i_hash_table_add (s7_scheme* sc, s7_pointer table, s7_pointer key, - s7_pointer value) { - return (hash_table_add (sc, table, key, value)); -} -s7_pointer -s7i_hash_table_1 (s7_scheme* sc, s7_pointer args, s7_pointer caller) { - s7_int len= proper_list_length (args); - if (len & 1) - error_nr (sc, sc->wrong_number_of_args_symbol, - set_elist_3 ( - sc, - wrap_string (sc, "~A got an odd number of arguments: ~S", 37), - caller, args)); - len/= 2; - if (len > sc->max_vector_length) - error_nr (sc, sc->out_of_range_symbol, - set_elist_4 (sc, - wrap_string (sc, - "~S passed too many entries (> ~D ~D) " - "(*s7* 'max-vector-length)", - 62), - caller, wrap_integer (sc, len), - wrap_integer (sc, sc->max_vector_length))); - { - s7_pointer table= - s7_make_hash_table (sc, (len > sc->default_hash_table_length) - ? len - : sc->default_hash_table_length); - if (len > 0) - for (s7_pointer x= args, y= cdr (args); is_pair (x); - x= cddr (x), y= cdr_unchecked (cdr (y))) - if (car (y) != missing_key_value (sc)) - hash_table_add (sc, table, car (x), car (y)); - return (table); - } -} +/* -------------------------------- hash-table? -------------------------------- */ +bool s7_is_hash_table(s7_pointer p) {return(is_hash_table(p));} -#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) -/* g_hash_table is now defined in s7_liii_hash_table.c */ -/* g_hash_table_2 is now defined in s7_liii_hash_table.c */ +/* g_is_hash_table is now defined in s7_liii_hash_table.c */ -/* -------------------------------- weak-hash-table - * -------------------------------- */ -#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 -/* g_weak_hash_table is now defined in s7_liii_hash_table.c */ +s7_int s7i_hash_table_entries(s7_pointer table) {return(hash_table_entries(table));} -static s7_pointer -hash_table_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer unused_expr) { - return ((args == 2) ? sc->hash_table_2 : func); -} - -static void -check_old_table (s7_scheme* sc, s7_pointer old_table, s7_pointer new_table, - s7_int start, s7_int end) { - const s7_int old_len = (s7_int) hash_table_size (old_table); - hash_entry_t** old_lists= hash_table_elements (old_table); - for (s7_int i= 0, count= 0; i < old_len; i++) - for (hash_entry_t* entry= old_lists[i]; entry; - entry = hash_entry_next (entry)) { - if (count >= end) return; - if (count >= start) - check_hash_types (sc, new_table, hash_entry_key (entry), - hash_entry_value (entry)); - } -} - -static s7_pointer -hash_table_copy (s7_scheme* sc, s7_pointer old_table, s7_pointer new_table, - s7_int start, s7_int end) { - const s7_uint old_len = hash_table_size (old_table); - const s7_uint new_mask= hash_table_mask (new_table); - s7_int count = 0; - hash_entry_t **old_lists, **new_lists; +s7_pointer s7i_hash_table_key_typer(s7_scheme *sc, s7_pointer table) +{ + if (is_typed_hash_table(table)) return(hash_table_key_typer(table)); + return(sc->F); +} - if (is_typed_hash_table (new_table)) - check_old_table (sc, old_table, new_table, start, end); +s7_pointer s7i_hash_table_value_typer(s7_scheme *sc, s7_pointer table) +{ + if (is_typed_hash_table(table)) return(hash_table_value_typer(table)); + return(sc->F); +} - old_lists= hash_table_elements (old_table); - new_lists= hash_table_elements (new_table); +/* -------------------------------- hash-table-entries -------------------------------- */ +#define H_hash_table_size "(hash-table-size obj) returns the number of entries in the hash-table obj" +#define Q_hash_table_size s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_hash_table_symbol) +/* g_hash_table_size and hash_table_size_i_7p are now defined in s7_liii_hash_table.c */ - if (hash_table_entries (new_table) == 0) { - if ((start == 0) && ((s7_uint) end >= hash_table_entries (old_table))) { - if (old_len == hash_table_size (new_table)) { - for (s7_uint i= 0; i < old_len; i++) - for (hash_entry_t* entry= old_lists[i]; entry; - entry = hash_entry_next (entry)) { - hash_entry_t* p= (hash_entry_t*) mallocate_block (sc); -#if S7_DEBUGGING - sc->blocks_mallocated[BLOCK_LIST]++; -#endif - memcpy ((void*) p, (const void*) entry, sizeof (block_t)); - hash_entry_next (p)= new_lists[i]; - new_lists[i] = p; - } - } - else - for (s7_uint i= 0; i < old_len; i++) - for (hash_entry_t* entry= old_lists[i]; entry; - entry = hash_entry_next (entry)) { - s7_uint loc = hash_entry_raw_hash (entry) % new_mask; - hash_entry_t* p = make_hash_entry (sc, hash_entry_key (entry), - hash_entry_value (entry), - hash_entry_raw_hash (entry)); - hash_entry_next (p)= new_lists[loc]; - new_lists[loc] = p; - } - hash_table_entries (new_table)= hash_table_entries (old_table); - return (new_table); - } - for (s7_uint i= 0; i < old_len; i++) - for (hash_entry_t* entry= old_lists[i]; entry; - entry = hash_entry_next (entry)) { - if (count >= end) { - hash_table_entries (new_table)= end - start; - return (new_table); - } - if (count >= start) { - s7_uint loc = hash_entry_raw_hash (entry) % new_mask; - hash_entry_t* p = make_hash_entry (sc, hash_entry_key (entry), - hash_entry_value (entry), - hash_entry_raw_hash (entry)); - hash_entry_next (p)= new_lists[loc]; - new_lists[loc] = p; - } - count++; - } - hash_table_entries (new_table)= count - start; - return (new_table); - } - /* this can't be optimized much because we have to look for key matches (we're - * copying old_table into the existing, non-empty new_table) */ - for (s7_uint i= 0; i < old_len; i++) - for (hash_entry_t* entry= old_lists[i]; entry; - entry = hash_entry_next (entry)) { - if (count >= end) return (new_table); - if (count >= start) { - hash_entry_t* y= (*hash_table_checker (new_table)) ( - sc, new_table, hash_entry_key (entry)); - if (y != sc->unentry) - hash_entry_set_value (y, hash_entry_value (entry)); - else { - const s7_uint loc = hash_entry_raw_hash (entry) % new_mask; - hash_entry_t* p = make_hash_entry (sc, hash_entry_key (entry), - hash_entry_value (entry), - hash_entry_raw_hash (entry)); - hash_entry_next (p)= new_lists[loc]; - new_lists[loc] = p; - hash_table_entries (new_table)++; - if (!hash_chosen (new_table)) - hash_table_set_default_checker (new_table, - type (hash_entry_key (entry))); - } - } - count++; - } - return (new_table); -} - -static s7_pointer -hash_table_fill (s7_scheme* sc, s7_pointer args) { - const s7_pointer table= car (args), val= cadr (args); - if (is_immutable_hash_table (table)) - immutable_object_error_nr ( - sc, set_elist_3 (sc, immutable_error_string, sc->fill_symbol, table)); - - if (hash_table_entries (table) > 0) { - hash_entry_t** entries= hash_table_elements (table); - const s7_int len = (s7_int) hash_table_size ( - table); /* minimum len is 2 (see s7_make_hash_table) */ - if (val == - missing_key_value ( - sc)) /* hash-table-ref returns #f (the default) if it can't find a - key, so val == #f here means empty the table */ - { - hash_entry_t** hp= entries; - hash_entry_t** hn= (hash_entry_t**) (hp + len); - for (; hp < hn; hp++) { - if (*hp) { - /* save top of entry list, go to end, point end->next at block_list - * top, reset top to entry_list top -> liberate entire list */ - hash_entry_t* entry= *hp; -#if S7_DEBUGGING - sc->blocks_freed[BLOCK_LIST]++; - while (hash_entry_next (entry)) { - entry= hash_entry_next (entry); - sc->blocks_freed[BLOCK_LIST]++; - } -#else - while (hash_entry_next (entry)) - entry= hash_entry_next (entry); -#endif - hash_entry_next (entry) = sc->block_lists[BLOCK_LIST]; - sc->block_lists[BLOCK_LIST]= *hp; - } - hp++; - if (*hp) { - hash_entry_t* entry= *hp; -#if S7_DEBUGGING - sc->blocks_freed[BLOCK_LIST]++; - while (hash_entry_next (entry)) { - entry= hash_entry_next (entry); - sc->blocks_freed[BLOCK_LIST]++; - } -#else - while (hash_entry_next (entry)) - entry= hash_entry_next (entry); -#endif - hash_entry_next (entry) = 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_mapper (table) == default_hash_map) { - hash_table_checker (table)= hash_empty; - hash_clear_chosen (table); - } - hash_table_entries (table)= 0; - return (val); - } - 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)))) { - const char* tstr= make_type_name ( - sc, hash_table_typer_name (sc, hash_table_value_typer (table)), - indefinite_article); - wrong_type_error_nr (sc, sc->fill_symbol, 2, val, - wrap_string (sc, tstr, safe_strlen (tstr))); - } - for (s7_int i= 0; i < len; i++) - for (hash_entry_t* entry= entries[i]; entry; - entry = hash_entry_next (entry)) - hash_entry_set_value (entry, 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_table) { - const s7_int len = (s7_int) hash_table_size (old_table); - hash_entry_t** old_lists= hash_table_elements (old_table); - const s7_pointer new_table= s7_make_hash_table (sc, len); - gc_protect_via_stack (sc, new_table); - - /* old_table checker/mapper functions don't always make sense reversed, - * although the key/value typers might be ok */ - for (s7_int i= 0; i < len; i++) - for (hash_entry_t* entry= old_lists[i]; entry; - entry = hash_entry_next (entry)) - s7_hash_table_set (sc, new_table, hash_entry_value (entry), - hash_entry_key (entry)); - - if (is_weak_hash_table (old_table)) /* 17-May-23, not sure it makes sense to - reverse a weak-hash-table but... */ - { - set_weak_hash_table (new_table); - weak_hash_iters (new_table)= 0; - } - unstack_gc_protect (sc); - return (new_table); -} +/* -------------------------------- hash-table-key|value-typer -------------------------------- */ +#define H_hash_table_key_typer "(hash-table-key-typer hash) returns the hash-table's key type checking function" +#define Q_hash_table_key_typer s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->not_symbol, sc->is_procedure_symbol), sc->is_hash_table_symbol) +/* g_hash_table_key_typer is now defined in s7_liii_hash_table.c */ -/* -------------------------------- functions -------------------------------- - */ -bool -s7_is_function (s7_pointer p) { - return (is_c_function (p)); -} +#define H_hash_table_value_typer "(hash-table-value-typer hash) returns the hash-table's value type checking function" +#define Q_hash_table_value_typer s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->not_symbol, sc->is_procedure_symbol), sc->is_hash_table_symbol) +/* g_hash_table_value_typer is now defined in s7_liii_hash_table.c */ -static s7_pointer -fallback_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer expr) { - return (func); +bool s7i_is_weak_hash_table(s7_pointer p) +{ + return(is_weak_hash_table(p)); } -static void -s7_function_set_class (s7_scheme* sc, s7_pointer func, s7_pointer base_f) { - c_function_class (func)= c_function_class (base_f); - c_function_set_base (func, base_f); +void s7i_set_weak_hash_table(s7_pointer p) +{ + set_weak_hash_table(p); } -static c_proc_t* -alloc_semipermanent_function (s7_scheme* sc) { -#define ALLOC_FUNCTION_SIZE 256 - 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; - } -#if S7_DEBUGGING - sc->c_functions_allocated++; /* this probably is the same as sc->f_class - (c_function_class) */ -#endif - return (&(sc->alloc_function_cells[sc->alloc_function_k++])); -} - -static s7_pointer -make_c_function (s7_scheme* sc, const char* name, s7_function f, s7_int req, - s7_int opt, bool rst, - const char* doc) /* called only in s7_make_function */ -{ - const s7_pointer func= (s7_pointer) alloc_pointer (sc); - set_full_type (func, ((req == 0) && (rst)) ? T_C_RST_NO_REQ_FUNCTION - : T_C_FUNCTION); - - c_function_data (func)= alloc_semipermanent_function (sc); - c_function_call (func)= f; /* f is T_App but needs cast */ - c_function_set_base (func, func); - c_function_set_setter (func, sc->F); - if (name) { - c_function_name (func)= - name; /* (procedure-name proc) => (format #f "~A" proc) */ - c_function_name_length (func)= safe_strlen (name); - c_function_set_symbol ( - func, - make_symbol (sc, name, - c_function_name_length ( - func))); /* T_C_FUNCTION_STAR may set later to args */ - } - else { - c_function_name (func) = NULL; - c_function_name_length (func)= 0; - c_function_set_symbol (func, sc->anon_symbol); - } - c_function_documentation (func)= - (doc) ? make_semipermanent_c_string (sc, doc) : NULL; - c_function_set_signature (func, sc->F); - c_function_min_args (func) = req; - c_function_optional_args (func)= opt; /* T_C_FUNCTION_STAR type may be set - later, so T_Fst not usable here */ - c_function_max_args (func)= (rst) ? MAX_ARITY : req + opt; - c_function_class (func) = ++sc->f_class; - c_function_chooser (func) = fallback_chooser; - c_function_opt_data (func)= NULL; - c_function_marker (func) = NULL; - c_function_set_let (func, sc->rootlet); - /* this is not the same as the let in (let (...) (lambda ...)) and can't be - * used that way. The first problem is that in "f" (the s7_function above), - * there is no way to tell which "func" (the current c_function object) - * caused it to be invoked. The call is of the form - * (c_function_call(func))(sc, ...). Since this usage is very unusual, I don't - * want to glom up every c_function call with a wrapper that sets/restores the - * c_function_let. The next is that it's easy to call s7_eval_c_string(sc, - * "(let (...) (lambda ...))" creating a real closure where the let is handled - * throughout s7. The third is that if you're using this style to create - * generators, use a c-object or iterator to hold the state; the "func" - * currently is allocated in semipermanent memory (see below), so (as - * throughout c_functions), the assumption is that these are not garbage - * collected. c_function_let is for *function* (find_let) primarily. Maybe - * if let is not rootlet (see below), pass heap memory? But then we need to - * free the function data. Also if the let is local, it needs to be GC - * protected by the caller. - */ - return (func); -} - -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 func= make_c_function (sc, name, f, required_args, optional_args, - rest_arg, doc); - unheap (func); - return (func); -} - -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 func= s7_make_function (sc, name, f, required_args, optional_args, - rest_arg, doc); - set_type_bit (func, T_SAFE_PROCEDURE); - return (func); -} - -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= s7_make_function (sc, name, f, required_args, optional_args, - rest_arg, doc); - set_type_bit (func, T_SAFE_PROCEDURE); - if (signature) c_function_set_signature (func, signature); - return (func); -} - -s7_pointer -s7_make_typed_function_with_environment (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 let) { - s7_pointer func= s7_make_typed_function ( - sc, name, f, required_args, optional_args, rest_arg, doc, signature); - c_function_set_let (func, let); - return (func); -} - -/* -------------------------------- procedure? -------------------------------- - */ -bool -s7_is_procedure (s7_pointer obj) { - return (is_procedure (obj)); +void s7i_set_weak_hash_table_iters(s7_pointer p, s7_int val) +{ + weak_hash_iters(p) = val; } -/* g_is_procedure is now defined in s7_scheme_predicate.c */ -#define H_is_procedure "(procedure? obj) returns #t if obj is a procedure" -#define Q_is_procedure sc->pl_bt - -#if !DISABLE_DEPRECATED -s7_pointer -s7_closure_body (s7_scheme* sc, s7_pointer clo) { - return ((has_closure_let (clo)) ? closure_body (clo) : sc->nil); -} -s7_pointer -s7_closure_let (s7_scheme* sc, s7_pointer clo) { - return ((has_closure_let (clo)) ? closure_let (clo) : sc->rootlet); -} -s7_pointer -s7_closure_args (s7_scheme* sc, s7_pointer clo) { - return ((has_closure_let (clo)) ? closure_pars (clo) : sc->nil); -} -#endif -s7_pointer -s7_lambda_body (s7_scheme* sc, s7_pointer clo) { - return ((has_closure_let (clo)) ? closure_body (clo) : sc->nil); -} -s7_pointer -s7_lambda_let (s7_scheme* sc, s7_pointer clo) { - return ((has_closure_let (clo)) ? closure_let (clo) : sc->rootlet); -} -s7_pointer -s7_lambda_parameters (s7_scheme* sc, s7_pointer clo) { - return ((has_closure_let (clo)) ? closure_pars (clo) : sc->nil); -} - -/* -------------------------------- procedure-arglist - * -------------------------------- */ -static s7_pointer -g_procedure_arglist (s7_scheme* sc, s7_pointer args) { -#define H_procedure_arglist "(procedure-arglist func) returns func's arglist" -#define Q_procedure_arglist \ - s7_make_signature ( \ - sc, 2, \ - s7_make_signature (sc, 2, sc->is_list_symbol, sc->is_symbol_symbol), \ - s7_make_signature (sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol)) - s7_pointer func= car (args); - if (has_closure_let (func)) - return (s7_copy ( - sc, set_plist_1 ( - sc, closure_pars (func)))); /* closure_pars can be a symbol: - (define (f1 . a) a) */ - if_method_exists_return_value (sc, func, sc->procedure_arglist_symbol, - set_plist_1 (sc, func)); - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_2 ( - sc, - wrap_string ( - sc, "procedure-arglist argument, ~S, is not a scheme function", - 56), - func)); - return (sc->nil); /* never hit */ -} - -/* -------------------------------- 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); /* break; ? */ - } - return (sc->lambda_symbol); +static s7_pointer make_hash_table_procedures(s7_scheme *sc) +{ + s7_pointer p = cons(sc, sc->T, sc->T); /* checker, mapped */ + set_opt1_any(p, sc->T); /* key */ + set_opt2_any(p, sc->T); /* value */ + return(p); } -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 func= car (args); - - if ((is_symbol (func)) && - ((func= s7_symbol_value (sc, func)) == sc->undefined)) - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_2 ( - sc, - wrap_string (sc, "procedure-source arg, '~S, is unbound", 37), - func)); - if ((is_c_function (func)) || (is_c_macro (func))) return (sc->nil); - - if_method_exists_return_value (sc, func, sc->procedure_source_symbol, - set_plist_1 (sc, func)); - if (has_closure_let (func)) { - s7_pointer body= closure_body (func); - /* 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 (func)), - closure_pars (func)), - body)); - } - if (!is_procedure (func)) - sole_arg_wrong_type_error_nr (sc, sc->procedure_source_symbol, func, - a_procedure_or_a_macro_string); - return (sc->nil); - /* perhaps include file/line? perhaps some way to return comments in code -- - * source code as string exactly as in file? */ -} - -/* -------------------------------- *current-function* - * -------------------------------- */ -static s7_pointer -let_to_function (s7_scheme* sc, s7_pointer let) { - if ((!let) || (let == sc->rootlet) || (!is_let (let))) return (sc->F); - if (!((is_funclet (let)) || (is_maclet (let)))) return (sc->F); - if ((has_let_file (let)) && (let_file (let) <= (s7_int) sc->file_names_top) && - (let_line (let) > 0)) - return (list_3 (sc, funclet_function (let), sc->file_names[let_file (let)], - make_integer (sc, let_line (let)))); - return (funclet_function (let)); -} - -static s7_pointer -g_function (s7_scheme* sc, - s7_pointer args) /* does the env parameter make any sense? */ -{ -#define H_function \ - "(*function* let field) returns the current function. (*function*) is like __func__ in C. \ -If 'let is specified, *function* looks for the current function in the environment 'e. If 'field (a symbol) is given \ -a function-specific value is returned. The fields are 'name (the name of the current function), 'signature, 'arity,\ - 'documentation, 'value (the function itself), 'line and 'file (the function's definition location), 'funclet, 'source, \ -and 'arglist. (define (func x y) (*function* (curlet) 'arglist)) (func 1 2): '(x y)" - -#define Q_function \ - s7_make_signature (sc, 3, sc->T, has_let_signature (sc), sc->is_symbol_symbol) - - s7_pointer let, sym= NULL; - if (is_null (args)) /* (*function*) is akin to __func__ in C */ - { - for (let= sc->curlet; let; let= let_outlet (let)) - if ((is_funclet (let)) || (is_maclet (let))) break; - return (let_to_function (sc, let)); - } - let= car (args); - if (!is_let (let)) { - s7_pointer new_let= find_let (sc, let); /* ?? not sure this makes sense */ - if (!is_let (new_let)) - find_let_error_nr (sc, sc->_function__symbol, let, new_let, 1, args); - let= new_let; - } - if (is_pair (cdr (args))) { - sym= cadr (args); - if (!is_symbol (sym)) - wrong_type_error_nr (sc, sc->_function__symbol, 2, sym, - sc->type_names[T_SYMBOL]); - } - if (let == sc->rootlet) return (sc->F); - if (!((is_funclet (let)) || (is_maclet (let)))) let= let_outlet (let); - if (is_null (cdr (args))) return (let_to_function (sc, let)); - if ((let == sc->rootlet) || (!is_let (let))) return (sc->F); - if (!((is_funclet (let)) || (is_maclet (let)))) return (sc->F); - - if (is_keyword (sym)) sym= keyword_symbol (sym); - { - s7_pointer fname= funclet_function (let); - s7_pointer fval = s7_symbol_local_value (sc, fname, let); - - 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 (let))) - return (make_integer (sc, let_line (let))); - if ((sym == sc->file_symbol) && (has_let_file (let))) - return (sc->file_names[let_file (let)]); - if (sym == make_symbol (sc, "funclet", 7)) return (let); - if (sym == make_symbol (sc, "source", 6)) - return (g_procedure_source (sc, set_plist_1 (sc, fval))); - if ((sym == make_symbol (sc, "arglist", 7)) && - ((is_any_closure (fval)) || (is_any_macro (fval)))) - return (closure_pars (fval)); - } - return (sc->F); +static s7_pointer copy_hash_table_procedures(s7_scheme *sc, s7_pointer table) +{ + if (is_pair(hash_table_procedures(table))) + { + s7_pointer p = cons(sc, hash_table_procedures_checker(table), hash_table_procedures_mapper(table)); + set_opt1_any(p, hash_table_key_typer(table)); + set_opt2_any(p, hash_table_value_typer(table)); + return(p); + } + return(sc->nil); } -/* -------------------------------- funclet -------------------------------- */ -s7_pointer -s7_funclet (s7_scheme* sc, s7_pointer func) { - return ((has_closure_let (func)) ? closure_let (func) : sc->rootlet); -} /* c_function_let(func)?? */ - -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 func= car (args); - if (is_symbol (func)) { - if ((func= s7_symbol_value (sc, func)) == sc->undefined) - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_2 ( - sc, - wrap_string (sc, "funclet argument, '~S, is unbound", 33), - car (args))); /* not func here */ - } - if_method_exists_return_value (sc, func, sc->funclet_symbol, args); - if (!((is_any_procedure (func)) || (is_c_object (func)))) - sole_arg_wrong_type_error_nr (sc, sc->funclet_symbol, func, - a_procedure_or_a_macro_string); - return (find_let (sc, func)); +static void check_hash_table_typer(s7_scheme *sc, s7_pointer caller, s7_pointer table, s7_pointer typer) +{ + if (is_c_function(typer)) + { + s7_pointer sig = c_function_signature(typer); + if ((sig != sc->pl_bt) && + (is_pair(sig)) && + ((car(sig) != sc->is_boolean_symbol) || (cadr(sig) != sc->T) || (!is_null(cddr(sig))))) + wrong_type_error_nr(sc, caller, 2, typer, wrap_string(sc, "a boolean procedure", 19)); + if (!c_function_name(typer)) + wrong_type_error_nr(sc, caller, 2, typer, wrap_string(sc, "a named function", 16)); + } + else + { + s7_pointer typer_name; + if (!is_any_closure(typer)) + wrong_type_error_nr(sc, caller, 2, typer, wrap_string(sc, "a built-in procedure, a closure or #t", 37)); + typer_name = find_typer(sc, typer); + if (!is_symbol(typer_name)) + wrong_type_error_nr(sc, caller, 2, typer, wrap_string(sc, "a named function", 16)); + } + if (!s7_is_aritable(sc, typer, 1)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "~A: the second argument, ~S, (the type checker) should accept one argument", 74), caller, typer)); + if (is_c_function(typer)) + { + if (c_function_has_simple_elements(typer)) + { + if (caller == sc->hash_table_value_typer_symbol) + set_has_simple_values(table); + else + { + set_has_simple_keys(table); + if (symbol_type(c_function_symbol(typer)) != T_FREE) + set_has_hash_key_type(table); + }}} + if (is_null(hash_table_procedures(table))) + hash_table_set_procedures(table, make_hash_table_procedures(sc)); + set_is_typed_hash_table(table); } -/* -------------------------------- s7_define_function and friends - * -------------------------------- - * - * all c_func* are semipermanent, but they might be local: (let () (load - * "libm.scm" (curlet)) ...) - */ +static s7_pointer g_set_hash_table_key_typer(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer table = car(args), typer = cadr(args); -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= s7_make_function (sc, name, fnc, required_args, - optional_args, rest_arg, doc); - s7_pointer sym = T_Sym (c_function_symbol (func)); - s7_define (sc, sc->rootlet, 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= s7_make_safe_function (sc, name, fnc, required_args, - optional_args, rest_arg, doc); - s7_pointer sym = T_Sym (c_function_symbol (func)); - s7_define (sc, sc->rootlet, sym, func); - return (sym); -} - -s7_pointer -s7_define_typed_function (s7_scheme* sc, const char* name, - s7_function fnc, /* same as above, but include sig */ - 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= s7_make_typed_function (sc, name, fnc, required_args, - optional_args, rest_arg, doc, - signature); /* includes "safe" bit */ - s7_pointer sym = T_Sym (c_function_symbol (func)); - s7_define (sc, sc->rootlet, 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) { - const s7_pointer func= - s7_make_typed_function (sc, name, fnc, 1, optional_args, false, doc, - signature); /* includes "safe" bit */ - const s7_pointer sym= T_Sym (c_function_symbol (func)); - s7_define (sc, sc->rootlet, sym, func); - if (sym_to_type != T_FREE) symbol_set_type (sym, sym_to_type); - c_function_set_marker (func, marker); - if (simple) c_function_set_has_simple_elements (func); - { - s7_pointer bfunc= - s7_make_safe_function (sc, name, bool_setter, 2, 0, false, NULL); - c_function_set_bool_setter (func, bfunc); - c_function_set_has_bool_setter (func); - c_function_set_setter (bfunc, func); - set_is_bool_function (bfunc); - } - return (sym); -} + if (!is_hash_table(table)) + wrong_type_error_nr(sc, wrap_string(sc, "set! hash_table-key-typer", 25), 1, table, sc->type_names[T_HASH_TABLE]); + if (is_immutable_hash_table(table)) + immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "~S is immutable so its key-typer can't be set!", 46), table)); -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= s7_make_function (sc, name, fnc, required_args, - optional_args, rest_arg, doc); - s7_pointer sym = T_Sym (c_function_symbol (func)); - if (signature) c_function_set_signature (func, signature); - s7_define (sc, sc->rootlet, 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= s7_make_function (sc, name, fnc, required_args, - optional_args, rest_arg, doc); - s7_pointer sym = T_Sym (c_function_symbol (func)); - if (signature) c_function_set_signature (func, signature); - set_is_semisafe (func); - s7_define (sc, sc->rootlet, 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) { - const s7_int len= safe_strlen (arglist); - s7_pointer local_args; - s7_int gc_loc, n_args; - { - block_t* b = inline_mallocate (sc, len + 4); - char* internal_arglist= (char*) block_data (b); - internal_arglist[0] = '\''; - internal_arglist[1] = '('; - memcpy ((void*) (internal_arglist + 2), (const void*) arglist, len); - internal_arglist[len + 2]= ')'; - internal_arglist[len + 3]= '\0'; - 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; - } - { - const s7_pointer func= s7_make_function ( - sc, NULL, fnc, 0, n_args, false, - doc); /* null name to turn off the c_function_symbol stuff */ - c_function_name (func)= - name; /* (procedure-name proc) => (format #f "~A" proc) */ - c_function_name_length (func)= safe_strlen (name); - - if (n_args > 0) { - s7_pointer p= local_args; - s7_pointer* names= - (s7_pointer*) permalloc (sc, n_args * sizeof (s7_pointer)); - s7_pointer* defaults= - (s7_pointer*) permalloc (sc, n_args * sizeof (s7_pointer)); - - set_full_type (func, T_C_FUNCTION_STAR | - T_UNHEAP); /* unheap from s7_make_function */ - c_function_call_args (func) = NULL; - c_function_par_names (func) = names; - c_function_arg_defaults (func)= defaults; - c_func_set_simple_defaults ( - func); /* mark that the defaults need GC protection */ - /* (define* (f :allow-other-keys) 32) -> :allow-other-keys can't be the - * only parameter: (:allow-other-keys) */ - - for (s7_int i= 0; i < n_args; p= cdr (p), i++) { - const s7_pointer arg= car (p); - if (arg == sc->allow_other_keys_keyword) { - 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_max_args (func)= - n_args; /* apparently not counting keywords */ - } - else if (is_pair (arg)) /* there is a default */ - { - names[i]= car (arg); /* key can be passed at runtime as :key or key: - so we need both or the symbol */ - defaults[i]= cadr (arg); - remove_from_heap (sc, cadr (arg)); /* ?? this is the default expr */ - 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->rest_keyword) - s7_warn (sc, 256, - "%s :rest is not supported in C-side define*: %s\n", name, - arglist); - names[i] = arg; - defaults[i]= sc->F; - } - } + if (is_boolean(typer)) /* remove current typer, if any */ + { + if (is_typed_hash_table(table)) + { + hash_table_set_key_typer(table, sc->T); + clear_has_simple_keys(table); + if (hash_table_value_typer(table) == sc->T) clear_is_typed_hash_table(table); + }} + else + { + check_hash_table_typer(sc, sc->hash_table_key_typer_symbol, table, typer); + hash_table_set_key_typer(table, typer); } - else set_full_type (func, T_C_FUNCTION | T_UNHEAP); - s7_gc_unprotect_at (sc, gc_loc); - return (func); - } + return(typer); } -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= 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)= - semipermanent_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; - if (safe) func= s7_make_safe_function_star (sc, name, fnc, arglist, doc); - else func= s7_make_function_star (sc, name, fnc, arglist, doc); - s7_define (sc, sc->rootlet, make_symbol_with_strlen (sc, name), - func); /* can't use c_function_symbol here (clobbered by - c_function* args) */ - if (signature) c_function_set_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= s7_make_function (sc, name, fnc, required_args, - optional_args, rest_arg, doc); - s7_pointer sym = T_Sym (c_function_symbol (func)); - set_full_type (func, T_C_MACRO | T_DONT_EVAL_ARGS | - T_UNHEAP); /* s7_make_function includes T_UNHEAP */ - s7_define (sc, sc->rootlet, sym, func); - return (sym); -} - -s7_pointer -s7_define_expansion (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= s7_make_function (sc, name, fnc, required_args, - optional_args, rest_arg, doc); - s7_pointer sym = T_Sym (c_function_symbol (func)); - set_full_type (func, T_C_MACRO | T_EXPANSION | T_DONT_EVAL_ARGS | - T_UNHEAP); /* s7_make_function includes T_UNHEAP */ - s7_define (sc, sc->rootlet, sym, func); - set_full_type (sym, full_type (sym) | T_EXPANSION); - return (sym); -} +static s7_pointer g_set_hash_table_value_typer(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer table = car(args), typer = cadr(args); -/* -------------------------------- macro? -------------------------------- */ -bool -s7_is_macro (s7_scheme* sc, s7_pointer mac) { - return (is_any_macro (mac)); -} -static bool -is_macro_b (s7_pointer mac) { - return (is_any_macro (mac)); + if (!is_hash_table(table)) + wrong_type_error_nr(sc, wrap_string(sc, "set! hash_table-value-typer", 27), 1, table, sc->type_names[T_HASH_TABLE]); + if (is_immutable_hash_table(table)) + immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "~S is immutable so its value-typer can't be set!", 48), table)); + + if (is_boolean(typer)) /* remove current typer, if any */ + { + if (is_typed_hash_table(table)) + { + hash_table_set_value_typer(table, sc->T); + clear_has_simple_values(table); + if (hash_table_key_typer(table) == sc->T) clear_is_typed_hash_table(table); + }} + else + { + check_hash_table_typer(sc, sc->hash_table_value_typer_symbol, table, typer); + hash_table_set_value_typer(table, typer); + } + return(typer); } -/* g_is_macro is now defined in s7_scheme_predicate.c */ -#define H_is_macro "(macro? arg) returns #t if 'arg' is a macro or a bacro" -#define Q_is_macro sc->pl_bt -static bool closure_is_aritable (s7_scheme* sc, s7_pointer x, s7_pointer x_args, - int32_t args); +/* ---------------- hash map and equality tables ---------------- */ +/* built in hash loc tables for eq? eqv? equal? equivalent? = string=? char=? (default=equal?) */ +#define hash_loc(Sc, Table, Key) (*(hash_table_mapper(Table)[type(Key)]))(Sc, Table, Key) -static s7_pointer -s7_macroexpand (s7_scheme* sc, s7_pointer mac, s7_pointer args) { - int32_t arg_len; - if (!s7_is_proper_list (sc, args)) return (sc->F); - arg_len= proper_list_length (args); - if (!closure_is_aritable (sc, mac, closure_pars (mac), arg_len)) - return (sc->F); - push_stack_direct (sc, OP_EVAL_DONE); - sc->code= mac; - sc->args= args; - set_curlet (sc, 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 obj) { - if (is_symbol (obj)) { - if (is_keyword (obj)) return (NULL); - if (symbol_has_help (obj)) return (symbol_help (obj)); - obj= s7_symbol_value (sc, obj); /* this is needed by Snd */ - } - if ((is_any_c_function (obj)) || (is_c_macro (obj))) - return ((const char*) c_function_documentation (obj)); - if (is_syntax (obj)) return (syntax_documentation (obj)); - { - s7_pointer val= funclet_entry (sc, obj, sc->local_documentation_symbol); - if ((val) && (is_string (val))) return (string_value (val)); - if (has_closure_let (obj)) { - val= closure_body (obj); - if ((is_pair (val)) && (is_string (car (val)))) - return ((char*) string_value (car (val))); - } - } - return (NULL); -} +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]; +/* also default_hash_map */ -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 obj= car (args); - if (is_symbol (obj)) { - if ((symbol_has_help (obj)) && (is_defined_global (obj))) - return (s7_make_string (sc, symbol_help (obj))); - obj= s7_symbol_value (sc, obj); - } - /* (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 (obj)) { - s7_pointer func= funclet_entry (sc, obj, sc->documentation_symbol); - if (func) return (s7_apply_function (sc, func, args)); - func= closure_body (obj); - if ((is_pair (func)) && (is_string (car (func)))) return (car (func)); - } - /* it would be neat if this would work (define x (let ((+documentation+ - * "hio")) (vector 1 2 3))) (documentation x) */ - if_method_exists_return_value (sc, obj, sc->documentation_symbol, args); - return (s7_make_string (sc, s7_documentation (sc, obj))); -} - -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)); - add_saved_pointer (sc, symbol_help (sym)); - } - return (new_doc); +/* ---------------- hash-code ---------------- */ +/* eqfunc handling which will require other dummy tables */ + +static s7_pointer make_dummy_hash_table(s7_scheme *sc) /* make the absolute minimal hash-table that can support hash-code */ +{ + s7_pointer table = alloc_pointer(sc); + set_type_bit(table, T_IMMUTABLE | T_HASH_TABLE | T_UNHEAP); + hash_table_mapper(table) = default_hash_map; + hash_table_mask(table) = 1; /* we're lying... */ + return(table); } -/* -------------------------------- 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->starlet) - 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); +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)); } -/* g_help is now defined in s7_scheme_predicate.c */ -#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->not_symbol), \ - sc->T) +#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) +/* g_hash_code is now defined in s7_liii_hash_table.c */ -/* -------------------------------- 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->complex_vector_signature= s7_make_circular_signature ( - sc, 2, 3, sc->is_complex_symbol, sc->is_complex_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->not_symbol), \ - sc->T) - - s7_pointer obj= car (args); - switch (type (obj)) { - case T_C_FUNCTION: - case T_C_RST_NO_REQ_FUNCTION: - case T_C_FUNCTION_STAR: - case T_C_MACRO: - return ((s7_pointer) c_function_signature (obj)); - - case T_MACRO: - case T_MACRO_STAR: - case T_BACRO: - case T_BACRO_STAR: - case T_CLOSURE: - case T_CLOSURE_STAR: { - s7_pointer func= funclet_entry (sc, obj, sc->local_signature_symbol); - if (func) return (func); - func= funclet_entry (sc, obj, sc->signature_symbol); - return ((func) ? s7_apply_function (sc, func, args) : sc->F); - } +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); - case T_VECTOR: - if (vector_length (obj) == 0) - return (sc->F); /* sig () is #f so sig #() should be #f */ - if (!is_typed_vector (obj)) return (sc->vector_signature); - { - s7_pointer lst= list_3 (sc, typed_vector_typer_symbol (sc, obj), - sc->is_vector_symbol, sc->is_integer_symbol); - set_cdddr (lst, cddr (lst)); - return (lst); - } - - case T_FLOAT_VECTOR: - return ((vector_length (obj) == 0) ? sc->F : sc->float_vector_signature); - case T_COMPLEX_VECTOR: - return ((vector_length (obj) == 0) ? sc->F : sc->complex_vector_signature); - case T_INT_VECTOR: - return ((vector_length (obj) == 0) ? sc->F : sc->int_vector_signature); - case T_BYTE_VECTOR: - return ((vector_length (obj) == 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 (obj)) - return (list_3 ( - sc, hash_table_typer_symbol (sc, hash_table_value_typer (obj)), - sc->is_hash_table_symbol, - hash_table_typer_symbol (sc, hash_table_key_typer (obj)))); - return (sc->hash_table_signature); - - case T_ITERATOR: - obj= iterator_sequence (obj); - if ((is_hash_table (obj)) || - (is_let (obj))) /* cons returned -- would be nice to include the car/cdr - types if known */ - return (list_1 (sc, sc->is_pair_symbol)); - obj= g_signature (sc, set_plist_1 (sc, obj)); - return (list_1 (sc, (is_pair (obj)) ? car (obj) : sc->T)); - - case T_C_OBJECT: - if_c_object_method_exists_return_value (sc, obj, sc->signature_symbol, - args); - return (sc->c_object_signature); - - case T_LET: - if_let_method_exists_return_value (sc, obj, 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 */ - { - const s7_pointer slot= s7_slot (sc, obj); - if ((is_slot (slot)) && (slot_has_setter (slot))) { - s7_pointer setter= slot_setter (slot); - obj = g_signature (sc, set_plist_1 (sc, setter)); - if (is_pair (obj)) return (list_1 (sc, car (obj))); - } - } - break; +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); - default: - break; - } - return (sc->F); -} -s7_pointer -s7_signature (s7_scheme* sc, s7_pointer func) { - return (g_signature (sc, set_plist_1 (sc, func))); -} +/* ---------------- hash empty ---------------- */ +static hash_entry_t *hash_empty(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(sc->unentry);} -/* -------------------------------- dynamic-wind - * -------------------------------- */ -static s7_pointer -closure_or_f (s7_scheme* sc, s7_pointer obj) { - s7_pointer body; - if (!is_closure (obj)) return (obj); - body= closure_body (obj); - if (is_pair (cdr (body))) return (obj); - if (!is_pair (car (body))) return (sc->F); - return ((is_quote (sc, caar (body))) ? sc->F : obj); +/* ---------------- hash syntax ---------------- */ +static s7_uint 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) +{ + s7_uint loc = hash_loc(sc, table, key) % hash_table_mask(table); + for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if ((is_syntax(hash_entry_key(entry))) && + (syntax_symbol(hash_entry_key(entry)) == syntax_symbol(key))) /* the opcodes might differ, but the symbols should not */ + return(entry); + return(sc->unentry); } -static s7_pointer -make_baffled_closure (s7_scheme* sc, s7_pointer old_func) { - /* for dynamic-wind to protect initial and final functions from call/cc */ - s7_pointer new_func= make_closure_unchecked ( - sc, sc->nil, closure_body (old_func), type (old_func), - 0); /* always preceded by new dw cell */ - s7_pointer let= make_let ( - sc, closure_let (old_func)); /* let_outlet(let) = closure_let(old_func) */ - set_baffle_let (let); - let_set_baffle_key (let, sc->baffle_ctr++); - closure_set_let (new_func, let); - return (new_func); -} - -static bool -is_dwind_thunk (s7_scheme* sc, s7_pointer obj) { - switch (type (obj)) { - 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_pars ( - obj))); /* this case does not match is_aritable -- it could be loosened - -- arity=0 below would need fixup */ - case T_C_FUNCTION: - return (c_function_is_aritable (obj, 0)); - case T_C_MACRO: - return (c_macro_min_args (obj) == 0); - case T_C_FUNCTION_STAR: - case T_GOTO: - case T_CONTINUATION: - case T_C_RST_NO_REQ_FUNCTION: - return (true); - } - return (obj == sc->F); /* (dynamic-wind #f (lambda () 3) #f) */ +/* ---------------- hash symbols ---------------- */ +static s7_uint 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) +{ + s7_uint loc = pointer_map(key) % hash_table_mask(table); + for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if (key == hash_entry_key(entry)) + return(entry); + return(sc->unentry); } -static s7_pointer -g_dynamic_wind_unchecked (s7_scheme* sc, s7_pointer args) { - s7_pointer dw, init_func, final_func; - new_cell (sc, dw, T_DYNAMIC_WIND); /* don't mark car/cdr, don't copy */ - dynamic_wind_in (dw) = closure_or_f (sc, car (args)); - dynamic_wind_body (dw)= cadr (args); - dynamic_wind_out (dw) = closure_or_f (sc, caddr (args)); - push_stack (sc, OP_DYNAMIC_WIND, sc->nil, - dw); /* args will be the saved result, code = s7_dynwind_t obj */ - /* do this push_stack early to protect p from allocations in - * make_baffled_closure */ - init_func= dynamic_wind_in (dw); - if ((is_any_closure (init_func)) && - (!is_safe_closure ( - init_func))) /* wrap this use of init_func in a with-baffle */ - dynamic_wind_in (dw)= make_baffled_closure (sc, init_func); - - final_func= dynamic_wind_out (dw); - if ((is_any_closure (final_func)) && (!is_safe_closure (final_func))) - dynamic_wind_out (dw)= make_baffled_closure (sc, final_func); - - /* 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. - */ - if (init_func != sc->F) { - dynamic_wind_state (dw)= dwind_init; - push_stack (sc, OP_APPLY, sc->nil, dynamic_wind_in (dw)); - } - else { - dynamic_wind_state (dw)= dwind_body; - push_stack (sc, OP_APPLY, sc->nil, dynamic_wind_body (dw)); - } - return (sc->F); -} - -static s7_pointer -g_dynamic_wind_init (s7_scheme* sc, s7_pointer args) { - s7_pointer dw; - const s7_pointer init_func= closure_or_f (sc, car (args)); - new_cell (sc, dw, T_DYNAMIC_WIND); /* don't mark car/cdr, don't copy */ - dynamic_wind_in (dw) = init_func; - dynamic_wind_body (dw)= cadr (args); - dynamic_wind_out (dw) = sc->F; - if ((is_any_closure (init_func)) && - (!is_safe_closure ( - init_func))) /* wrap this use of init_func in a with-baffle */ - dynamic_wind_in (dw)= make_baffled_closure (sc, init_func); - push_stack (sc, OP_DYNAMIC_WIND, sc->nil, - dw); /* args will be the saved result, code = s7_dynwind_t obj */ - dynamic_wind_state (dw)= dwind_init; - push_stack (sc, OP_APPLY, sc->nil, dynamic_wind_in (dw)); - return (sc->F); -} - -static s7_pointer -g_dynamic_wind_body (s7_scheme* sc, s7_pointer args) { - push_stack (sc, OP_APPLY, sc->nil, cadr (args)); - 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_signature ( \ - sc, 4, sc->values_symbol, \ - s7_make_signature (sc, 2, sc->is_procedure_symbol, sc->not_symbol), \ - sc->is_procedure_symbol, \ - s7_make_signature (sc, 2, sc->is_procedure_symbol, sc->not_symbol)) - - if (!is_dwind_thunk (sc, car (args))) - return (method_or_bust (sc, car (args), sc->dynamic_wind_symbol, args, - wrap_string (sc, "a thunk or #f", 13), 1)); - if (!is_thunk (sc, cadr (args))) - return (method_or_bust (sc, cadr (args), sc->dynamic_wind_symbol, args, - a_thunk_string, 2)); - if (!is_dwind_thunk (sc, caddr (args))) - return (method_or_bust (sc, caddr (args), sc->dynamic_wind_symbol, args, - wrap_string (sc, "a thunk or #f", 13), 3)); +/* ---------------- hash numbers ---------------- */ +static s7_uint hash_map_int(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + s7_int k = integer(key); + return((k >= 0) ? k : ((k == S7_INT64_MIN) ? S7_INT64_MAX : -k)); +} - /* 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. +static s7_uint 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 (g_dynamic_wind_unchecked (sc, args)); + return(s7_int_abs(numerator(key) / denominator(key))); /* needs to be compatible with default-hash-table-float-epsilon which is unfortunate */ } -static bool -is_lambda (s7_scheme* sc, s7_pointer sym) { - return ((sym == sc->lambda_symbol) && - (is_global (sym))); /* do we need (!sc->in_with_let) ? */ +static s7_uint hash_float_location(s7_double x) +{ +#if 0 + s7_double dx; + if ((is_NaN(x)) || (is_inf(x))) return(0); + dx = fabs(x); + if (dx > DOUBLE_TO_INT64_LIMIT) return(0); + return((s7_int)floor(dx)); +#else + /* if ((x > 1.0e16) || (x < -1.0e16) || (is_NaN(x)) || (is_inf(x))) return(0); */ /* log(DOUBLE_TO_INT64_LIMIT, 10) is about 16 */ + if ((is_NaN(x)) || (is_inf(x))) return(0); + return((s7_uint)floor(fabs(x))); +#if 0 + decode_float_t num; + num.fx = x; + return((s7_uint)(num.ix)); +#endif +#endif } + /* isnormal here in place of is_NaN and is_inf is slower. + * using x*100 to expand small float bin range runs afoul of the hash-table-float-epsilon bin calcs + */ -static int32_t -is_ok_thunk (s7_scheme* sc, - s7_pointer arg) /* used only in dynamic_wind_chooser */ +static s7_uint hash_map_real(s7_scheme *sc, s7_pointer table, s7_pointer key) { - /* 0 = not ok, 1 = ok but not simple, 2 = ok body is just #f, 3 = #f */ - if (arg == sc->F) return (3); - if ((is_pair (arg)) && (is_lambda (sc, car (arg))) && (is_pair (cdr (arg))) && - (is_null (cadr (arg))) && /* (lambda () ...) */ - (is_pair (cddr (arg))) && (s7_is_proper_list (sc, cddr (arg)))) - return (((is_null (cdddr (arg))) && (caddr (arg) == sc->F)) - ? 2 - : 1); /* 2: (lambda () #f) */ - return (0); -} - -static s7_pointer -dynamic_wind_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer expr) { - if ((args == 3) && (is_ok_thunk (sc, caddr (expr)))) { - int32_t init= is_ok_thunk (sc, cadr (expr)); - int32_t end = is_ok_thunk (sc, cadddr (expr)); - if ((init > 1) && (end > 1)) return (sc->dynamic_wind_body); - if ((init > 0) && (end > 1)) return (sc->dynamic_wind_init); - if ((init > 0) && (end > 0)) return (sc->dynamic_wind_unchecked); - } - return (func); + return(hash_float_location(real(key))); } -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" */ - 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 { - s7_pointer dw; - push_stack_direct ( - sc, OP_EVAL_DONE); /* this is ok because we have called setjmp etc */ - sc->args= sc->nil; - new_cell (sc, dw, T_DYNAMIC_WIND); - dynamic_wind_in (dw) = T_Ext (init); - dynamic_wind_body (dw)= T_Ext (body); - dynamic_wind_out (dw) = T_Ext (finish); - push_stack (sc, OP_DYNAMIC_WIND, sc->nil, dw); - if (init != sc->F) { - dynamic_wind_state (dw)= dwind_init; - sc->code = init; - } - else { - dynamic_wind_state (dw)= 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); -} - -static void -op_unwind_output (s7_scheme* sc) { - const 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 s7_uint hash_complex_location(s7_double x) +{ + return(hash_float_location(x)); /* + hash_float_location(imag_part(key)) -- imag-part confuses epsilon distance calcs */ } -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 s7_uint hash_map_complex(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + return(hash_complex_location(real_part(key))); } -static bool -op_dynamic_wind (s7_scheme* sc) { - const s7_pointer dwind= T_Dyn (sc->code); - if (SHOW_EVAL_OPS) - fprintf (stderr, " %s[%d]: %s\n", __func__, __LINE__, - display_truncated (dwind)); - if (dynamic_wind_state (dwind) == dwind_init) { - dynamic_wind_state (dwind)= dwind_body; - push_stack (sc, OP_DYNAMIC_WIND, sc->nil, dwind); - sc->code= dynamic_wind_body (dwind); - sc->args= sc->nil; - return (true); /* goto apply */ - } - if (dynamic_wind_state (dwind) == dwind_body) { - dynamic_wind_state (dwind)= dwind_finish; - if (dynamic_wind_out (dwind) != sc->F) { - push_stack (sc, OP_DYNAMIC_WIND, sc->value, dwind); - sc->code= dynamic_wind_out (dwind); - sc->args= sc->nil; - return (true); - } - if (is_multiple_value (sc->value)) - sc->value= splice_in_values (sc, multiple_value (sc->value)); - return (false); /* 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 (false); -} -/* -------------------------------- c-object? -------------------------------- - */ -bool -s7_is_c_object (s7_pointer p) { - return (is_c_object (p)); +static hash_entry_t *find_number_in_bin(s7_scheme *sc, hash_entry_t *bin, s7_pointer key) +{ + const s7_double old_eps = sc->equivalent_float_epsilon; + bool (*equiv)(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) = 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); + } + /* else fprintf(stderr, "%s[%d]: %s != %s\n", __func__, __LINE__, display(key), display(hash_entry_key(bin))); */ + sc->equivalent_float_epsilon = old_eps; + return(NULL); } -/* g_is_c_object is now defined in s7_scheme_predicate.c */ -#define H_is_c_object "(c-object? obj) returns #t is obj is a c-object." -#define Q_is_c_object sc->pl_bt - -static no_return void -apply_error_nr (s7_scheme* sc, s7_pointer obj, s7_pointer args) { - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_4 ( - sc, wrap_string (sc, "attempt to apply ~A ~$ in ~S?", 29), - (is_null (obj)) ? wrap_string (sc, "nil", 3) - : ((is_symbol_and_keyword (obj)) - ? wrap_string (sc, "a keyword", 9) - : type_name_string (sc, obj)), - obj, - set_ulist_1 (sc, obj, - args))); /* was current_code(sc) which is unreliable */ -} - -static void -fallback_free (void* value) {} -static void -fallback_mark (void* value) {} - -s7_pointer -fallback_ref (s7_scheme* sc, s7_pointer args) { - apply_error_nr (sc, car (args), cdr (args)); - return (NULL); -} -static s7_pointer -fallback_set (s7_scheme* sc, s7_pointer args) { - syntax_error_nr (sc, "attempt to set ~S?", 18, car (args)); - return (NULL); -} -static s7_pointer -fallback_length (s7_scheme* sc, s7_pointer obj) { - return (sc->F); -} - -/* -------------------------------- c-object-type - * -------------------------------- */ -s7_int -s7_c_object_type (s7_pointer obj) { - return ((is_c_object (obj)) ? c_object_type (obj) : -1); +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 */ + const s7_double keyval = (is_real(key)) ? s7_real(key) : real_part(key); + const s7_double fprobe = fabs(keyval); + const s7_uint iprobe = (s7_uint)floor(fprobe); + const s7_double bin_dist = fprobe - iprobe; +#ifdef __clang__ + s7_uint loc = ((is_NaN(keyval)) || (is_inf(keyval))) ? 0 : iprobe % hash_table_mask(table); +#else + s7_uint loc = iprobe % hash_table_mask(table); +#endif + hash_entry_t *i1 = find_number_in_bin(sc, hash_table_element(table, loc), key); + if (i1) return(i1); + + 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); } -/* g_c_object_type is now defined in s7_scheme_predicate.c */ -#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_int -s7_make_c_type (s7_scheme* sc, - const char* name) /* shouldn't this be s7_make_c_object_type? */ -{ - c_object_t* c_type; - const s7_int 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 * 2; - sc->c_object_types= (c_object_t**) Realloc ((void*) (sc->c_object_types), - sc->c_object_types_size * - sizeof (c_object_t*)); +static hash_entry_t *hash_int(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + if (is_t_integer(key)) + { + const s7_uint hash_mask = hash_table_mask(table); + hash_entry_t *entry; + const s7_int kv = integer(key); + const s7_uint loc = s7_int_abs(kv) % hash_mask; + for (entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if (integer(hash_entry_key(entry)) == kv) + return(entry); } - } - c_type= (c_object_t*) Calloc ( - 1, sizeof (c_object_t)); /* Malloc+field=NULL is slightly faster here */ - sc->c_object_types[tag]= c_type; - c_type->type = tag; - c_type->scheme_name = make_permanent_string (name, safe_strlen (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); + return(sc->unentry); } -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 (*marker) (s7_scheme* sc, s7_pointer obj)) { - sc->c_object_types[tag]->gc_mark= marker; -} -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_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; +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 (is_t_real(key)) + { + s7_double keyval; + s7_uint loc; + keyval = real(key); + if (is_NaN(keyval)) return(sc->unentry); + loc = hash_float_location(keyval) % hash_table_mask(table); + for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + { + if ((is_t_real(hash_entry_key(entry))) && + (keyval == real(hash_entry_key(entry)))) + return(entry); + }} + return(sc->unentry); } -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) ? length : fallback_length; /* is_sequence(c_obj) is #t so we - need a length method */ +static hash_entry_t *hash_num_eq(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + s7_uint loc = hash_loc(sc, table, key) % hash_table_mask(table); + for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if (num_eq_b_7pp(sc, key, hash_entry_key(entry))) + return(entry); + return(sc->unentry); } -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; +static hash_entry_t *hash_real_num_eq(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + return((is_NaN(s7_real(key))) ? sc->unentry : hash_num_eq(sc, table, key)); } -/* the next three functions would ideally be deprecated, but much old code - * depends on them (they were accidentally documented forever) */ -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; +static hash_entry_t *hash_complex_num_eq(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + return(((is_NaN(real_part(key))) || (is_NaN(imag_part(key)))) ? sc->unentry : hash_num_eq(sc, table, key)); } -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) ? gc_free : fallback_free; +static hash_entry_t *hash_number_num_eq(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + if (is_number(key)) + { + const hash_map_t 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); + s7_uint loc = map(sc, table, key) % hash_table_mask(table); + for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if (keyi == integer(hash_entry_key(entry))) /* not in gmp, hash_int as eq_func, what else can key be but t_integer? */ + return(entry); + } + else + return((is_real(key)) ? hash_real_num_eq(sc, table, key) : hash_complex_num_eq(sc, table, key)); + } + return(sc->unentry); } -void -s7_c_type_set_mark (s7_scheme* sc, s7_int tag, void (*mark) (void* value)) { - sc->c_object_types[tag]->mark= (mark) ? mark : fallback_mark; -} -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) ? ref : fallback_ref; - sc->c_object_types[tag]->outer_type= - (sc->c_object_types[tag]->ref == fallback_ref) - ? T_C_OBJECT - : (T_C_OBJECT | T_SAFE_PROCEDURE); -} +/* ---------------- hash characters ---------------- */ +static s7_uint hash_map_char(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(character(key));} -void -s7_c_type_set_getter (s7_scheme* sc, s7_int tag, s7_pointer getter) { - sc->c_object_types[tag]->getter= (getter) ? T_Fnc (getter) : sc->F; +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. + */ + s7_uint loc = character(key) % hash_table_mask(table); + for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if (key == hash_entry_key(entry)) + return(entry); + } + return(sc->unentry); } -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) ? set : fallback_set; -} -void -s7_c_type_set_setter (s7_scheme* sc, s7_int tag, s7_pointer setter) { - sc->c_object_types[tag]->setter= (setter) ? T_Fnc (setter) : sc->F; +/* ---------------- hash strings ---------------- */ +static s7_uint 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)); } -/* -------------------------------- c-object-let - * -------------------------------- */ -s7_pointer -s7_c_object_let (s7_pointer obj) { - return (c_object_let (obj)); -} +static hash_entry_t *hash_string(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + if (is_string(key)) + { + const s7_int key_len = string_length(key); + const s7_uint hash_mask = hash_table_mask(table); + s7_uint hash; + const char *key_str = string_value(key); -/* g_c_object_let is now defined in s7_scheme_predicate.c */ -#define H_c_object_let \ - "(c-object-let obj) returns the c_object's local let, if any." -#define Q_c_object_let \ - s7_make_signature (sc, 2, sc->is_let_symbol, sc->is_c_object_symbol) - -s7_pointer -s7_c_object_set_let (s7_scheme* sc, s7_pointer cobj, s7_pointer let) { - if ((!is_immutable (cobj)) && (is_let (let))) c_object_set_let (cobj, let); - return (let); -} - -static s7_pointer -g_c_object_set_let (s7_scheme* sc, s7_pointer args) { - const s7_pointer cobj= car (args), let= cadr (args); - if (is_immutable (cobj)) - immutable_object_error_nr ( - sc, set_elist_2 ( - sc, wrap_string (sc, "can't set ~S's let: it is immutable", 35), - cobj)); - if (!is_let (let)) - wrong_type_error_nr (sc, make_symbol (sc, "#", 19), 2, - let, sc->type_names[T_LET]); - c_object_set_let (cobj, let); - return (let); -} - -/* -------------------------------- c-object-set - * -------------------------------- */ -static s7_pointer -g_c_object_set (s7_scheme* sc, - s7_pointer args) /* called in sc->c_object_set_function */ -{ - s7_pointer obj= car (args); - if (!is_c_object (obj)) /* (call/cc (setter (block))) will call c-object-set! - with the continuation as the argument! */ - wrong_type_error_nr (sc, make_symbol (sc, "c-object-set!", 13), 1, obj, - sc->type_names[T_C_OBJECT]); - return ((*(c_object_set (sc, obj))) (sc, args)); -} - -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 obj; - new_cell (sc, obj, sc->c_object_types[type]->outer_type); - /* c_object_info(obj) = &(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 (obj) = type; - c_object_value (obj)= value; - c_object_set_let (obj, T_Let (let)); - c_object_sc (obj)= sc; - if (with_gc) add_c_object (sc, obj); - return (obj); + if (string_hash(key) == 0) + string_hash(key) = raw_string_hash((const uint8_t *)string_value(key), string_length(key)); + hash = string_hash(key); /* keep s7_uint */ + + if (key_len <= 8) + { + for (hash_entry_t *entry = hash_table_element(table, hash % hash_mask); entry; entry = hash_entry_next(entry)) + if ((hash == string_hash(hash_entry_key(entry))) && + (key_len == string_length(hash_entry_key(entry)))) + return(entry); + } + else + for (hash_entry_t *entry = hash_table_element(table, hash % hash_mask); entry; entry = hash_entry_next(entry)) + if ((hash == string_hash(hash_entry_key(entry))) && + (key_len == string_length(hash_entry_key(entry))) && /* 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(entry)), key_len))) + return(entry); + } + return(sc->unentry); } -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)); +#if !WITH_PURE_S7 +static s7_uint 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))); } -s7_pointer -s7_make_c_object (s7_scheme* sc, s7_int type, void* value) { - return (make_c_object_with_let (sc, type, value, sc->rootlet, true)); +static hash_entry_t *hash_ci_string(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + if (is_string(key)) + { + s7_uint hash_mask = hash_table_mask(table); + s7_uint hash = hash_map_ci_string(sc, table, key); + for (hash_entry_t *entry = hash_table_element(table, hash % hash_mask); entry; entry = hash_entry_next(entry)) + if (scheme_strequal_ci(key, hash_entry_key(entry))) + return(entry); + } + return(sc->unentry); } +#endif + + +/* ---------------- hash eq? ---------------- */ +static s7_uint hash_map_nil(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(type(key));} -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->rootlet, false)); +static s7_uint 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 for (for example) symbols as keys */ + s7_uint loc = pointer_map(key) % hash_table_mask(table); /* hash_map_eq */ + for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if (key == hash_entry_key(entry)) + return(entry); + return(sc->unentry); } -static s7_pointer -c_object_length (s7_scheme* sc, s7_pointer obj) { - return ((*(c_object_len (sc, obj))) (sc, set_clist_1 (sc, obj))); +/* ---------------- hash eqv? ---------------- */ +static hash_entry_t *hash_eqv(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + const s7_uint loc = hash_loc(sc, table, key) % hash_table_mask(table); + if (is_number(key)) + { + uint8_t key_type = type(key); + for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if ((key_type == type(hash_entry_key(entry))) && + (numbers_are_eqv(sc, key, hash_entry_key(entry)))) + return(entry); + } + else + for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if (s7_is_eqv(sc, key, hash_entry_key(entry))) + return(entry); + return(sc->unentry); } -static s7_int -c_object_length_to_int (s7_scheme* sc, s7_pointer obj) { - s7_pointer result= (*(c_object_len (sc, obj))) (sc, set_clist_1 (sc, obj)); - if (s7_is_integer (result)) return (s7_integer_clamped_if_gmp (sc, result)); - return (-1); +/* ---------------- hash equal? ---------------- */ +static s7_uint 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. + * since order doesn't matter, but equal tables need to map to the same bin, we can't use key's + * entries except when key has 1 or 2 entries (or 3 to be tedious). + * Keys are supposed to be constant while keys, so a hash-table shouldn't be a key of itself. + */ + const s7_int len = hash_table_entries(key); + if ((len == 0) || (len > 2) || (hash_table_size(key) > 32)) return(len); + { + s7_pointer key1 = NULL, val1; + hash_entry_t **els = hash_table_elements(key); + const s7_int size = (s7_int)hash_table_size(key); + for (s7_int i = 0; i < size; i++) + for (hash_entry_t *entry = els[i]; entry; entry = hash_entry_next(entry)) + { + if (len == 1) + return(((is_sequence_or_iterator(hash_entry_key(entry))) ? 0 : hash_loc(sc, key, hash_entry_key(entry))) + + ((is_sequence_or_iterator(hash_entry_value(entry))) ? 0 : hash_loc(sc, key, hash_entry_value(entry)))); + if (!key1) + { + key1 = hash_entry_key(entry); + val1 = hash_entry_value(entry); + } + else + return(((is_sequence_or_iterator(key1)) ? 0 : hash_loc(sc, key, key1)) + + ((is_sequence_or_iterator(val1)) ? 0 : hash_loc(sc, key, val1)) + + ((is_sequence_or_iterator(hash_entry_key(entry))) ? 0 : hash_loc(sc, key, hash_entry_key(entry))) + + ((is_sequence_or_iterator(hash_entry_value(entry))) ? 0 : hash_loc(sc, key, hash_entry_value(entry)))); + }} + if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: we should not be here\n", __func__, __LINE__); + return(0); /* placate the compiler */ } -static s7_pointer -copy_c_object (s7_scheme* sc, s7_pointer args) { - const s7_pointer obj= car (args); - if_c_object_method_exists_return_value (sc, obj, sc->copy_symbol, args); - if (!c_object_copy (sc, obj)) - missing_method_error_nr (sc, sc->copy_symbol, obj); - return ((*(c_object_copy (sc, obj))) (sc, args)); +static s7_uint 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), as long as it's consistent */ } -static s7_pointer -c_object_type_to_let (s7_scheme* sc, s7_pointer cobj) { - const s7_int type = c_object_type (cobj); - c_object_t* c_type= sc->c_object_types[type]; - return (internal_inlet (sc, 6, sc->name_symbol, c_type->scheme_name, - make_symbol (sc, "getter", 6), - s7_object_to_string (sc, c_type->getter, false), - sc->setter_symbol, - s7_object_to_string (sc, c_type->setter, false))); - /* can't display equal et al in c_types -- maybe sc->F or the pointer? or add - * getter equivalent fields for equal et al? */ +static s7_uint 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 void -apply_c_object (s7_scheme* sc) /* -------- applicable c_object -------- */ +static s7_uint hash_map_float_vector(s7_scheme *sc, s7_pointer table, s7_pointer key) { - sc->value= (*(c_object_ref (sc, sc->code))) ( - sc, set_ulist_1 (sc, sc->code, sc->args)); - set_car (sc->u1_1, sc->F); + s7_uint loc1, loc2; + if (vector_length(key) == 0) return(0); + /* fprintf(stderr, "mask: %" lu64 ", val: %f, loc: %" lu64 "\n", mask, float_vector(key, 0), hash_float_location(float_vector(key, 0))); */ + loc1 = hash_float_location(float_vector(key, 0)); + /* fprintf(stderr, "%s[%d]: loc1: %" lu64 "\n", __func__, __LINE__, loc1); */ + if (vector_length(key) == 1) return(loc1); + loc2 = hash_float_location(float_vector(key, 1)); + return(vector_length(key) + loc1 + loc2); } -static bool -op_implicit_c_object_ref_a (s7_scheme* sc) { - const s7_pointer cobj= lookup_checked (sc, car (sc->code)); - if (!is_c_object (cobj)) { - sc->last_function= cobj; - return (false); - } - set_car (sc->t2_2, fx_call (sc, cdr (sc->code))); - set_car (sc->t2_1, cobj); /* fx_call above might use sc->t2* */ - sc->value= (*(c_object_ref (sc, cobj))) (sc, sc->t2_1); - return (true); +static s7_uint hash_map_complex_vector(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + s7_uint loc1, loc2; + if (vector_length(key) == 0) return(0); + loc1 = hash_complex_location(creal(complex_vector(key, 0))); + if (vector_length(key) == 1) return(loc1); + loc2 = hash_complex_location(creal(complex_vector(key, 1))); + return(vector_length(key) + loc1 + loc2); } -static s7_pointer -fx_implicit_c_object_ref_a (s7_scheme* sc, s7_pointer arg) { - const s7_pointer cobj= lookup_checked (sc, car (arg)); - if (!is_c_object (cobj)) - return (s7_apply_function (sc, cobj, list_1 (sc, fx_call (sc, cdr (arg))))); - set_car (sc->t2_2, fx_call (sc, cdr (arg))); - set_car (sc->t2_1, cobj); /* fx_call above might use sc->t2* */ - return ((*(c_object_ref (sc, cobj))) (sc, sc->t2_1)); +static s7_uint hash_map_vector(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + s7_uint loc1, loc2; + if ((vector_length(key) == 0) || + (is_sequence_or_iterator(vector_element(key, 0)))) + return(vector_length(key)); + loc1 = hash_loc(sc, table, vector_element(key, 0)); + if ((vector_length(key) == 1) || + (is_sequence_or_iterator(vector_element(key, 1)))) + return(loc1); + loc2 = hash_loc(sc, table, vector_element(key, 1)); + return(vector_length(key) + loc1 + loc2); } -/* We could add implicit c-pointer ref/set referring to its let, but that seems - * confusing -- c-object-ref|set! would be different */ -/* -------- dilambda -------- */ +static s7_uint hash_map_closure(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + const s7_pointer f = hash_table_procedures_mapper(table); + if (f == sc->unused) + error_nr(sc, make_symbol(sc, "hash-map-recursion", 18), + set_elist_1(sc, wrap_string(sc, "hash-table map function called recursively", 42))); + /* check_stack_size(sc); -- perhaps clear typers as well here or save/restore hash-table-procedures */ + gc_protect_via_stack(sc, f); + hash_table_set_procedures_mapper(table, sc->F); + sc->value = s7_call(sc, f, set_plist_1(sc, key)); + unstack_gc_protect(sc); + hash_table_set_procedures_mapper(table, f); + if (!s7_is_integer(sc->value)) + error_nr(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_uint 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. equal? follows outlet, but that is ridiculous here. */ + s7_pointer slot, slot1 = NULL, slot2 = NULL; + s7_int slots; -s7_pointer -s7_dilambda_with_environment ( - s7_scheme* sc, s7_pointer let, 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, name_len; - if (!name) return (sc->F); - name_len = safe_strlen (name); - len = 16 + name_len; - internal_set_name = (char*) permalloc (sc, len); - internal_set_name[0]= '\0'; - catstrs_direct (internal_set_name, "#", - (const char*) NULL); /* was using #\[, 4-June-25 */ - get_func= s7_make_safe_function (sc, name, getter, get_req_args, get_opt_args, - false, documentation); - s7_define (sc, T_Let (let), make_symbol (sc, name, name_len), get_func); - set_func= s7_make_safe_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->rootlet, 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= - s7_dilambda (sc, name, getter, get_req_args, get_opt_args, setter, - set_req_args, set_opt_args, documentation); - s7_pointer set_func= c_function_setter (get_func); - if (get_sig) c_function_set_signature (get_func, get_sig); - if (set_sig) c_function_set_signature (set_func, set_sig); - return (get_func); -} - -/* -------------------------------- dilambda? -------------------------------- - */ -bool -s7_is_dilambda (s7_pointer func) { - if (has_closure_let (func)) - return (is_any_procedure (closure_setter_or_map_list ( - func))); /* type >= T_CLOSURE (excludes goto/continuation) */ - if (is_any_c_function (func)) - return (is_any_procedure ( - c_function_setter (func))); /* type >= T_C_FUNCTION_STAR */ - if (is_c_macro (func)) return (is_any_procedure (c_macro_setter (func))); - return (false); -} + if ((key == sc->rootlet) || (!is_not_slot_end(let_slots(key)))) return(0); + for (slot = let_slots(key), slots = 0; is_not_slot_end(slot); slot = next_slot(slot)) + if (!is_matched_symbol(slot_symbol(slot))) + { + if (!slot1) slot1 = slot; else slot2 = slot; + set_match_symbol(slot_symbol(slot)); + slots++; + } + for (slot = let_slots(key); is_not_slot_end(slot); slot = next_slot(slot)) + clear_match_symbol(slot_symbol(slot)); -/* g_is_dilambda is now defined in s7_scheme_predicate.c */ -#define H_is_dilambda \ - "(dilambda? obj) returns #t if obj is a procedure with setter." -#define Q_is_dilambda sc->pl_bt + if (slots == 1) + return(pointer_map(slot_symbol(slot1)) + ((is_sequence_or_iterator(slot_value(slot1))) ? 0 : hash_loc(sc, table, slot_value(slot1)))); + if (slots == 2) + return(pointer_map(slot_symbol(slot1)) + ((is_sequence_or_iterator(slot_value(slot1))) ? 0 : hash_loc(sc, table, slot_value(slot1))) + + pointer_map(slot_symbol(slot2)) + ((is_sequence_or_iterator(slot_value(slot2))) ? 0 : hash_loc(sc, table, slot_value(slot2)))); + return(slots); +} -/* -------------------------------- 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) - - const s7_pointer getter= car (args), setter= cadr (args); - if (!is_any_procedure (getter)) - wrong_type_error_nr (sc, sc->dilambda_symbol, 1, getter, - a_procedure_or_a_macro_string); - if (!is_any_procedure (setter)) - wrong_type_error_nr (sc, sc->dilambda_symbol, 2, setter, - a_procedure_or_a_macro_string); - s7_set_setter (sc, getter, setter); - return (getter); +static hash_entry_t *hash_equal_eq(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + s7_uint loc = hash_loc(sc, table, key) % hash_table_mask(table); + for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if (hash_entry_key(entry) == key) + return(entry); + return(sc->unentry); } -/* -------------------------------- arity -------------------------------- */ -static s7_pointer -closure_arity_to_cons (s7_scheme* sc, s7_pointer clo, s7_pointer clo_args) { - /* clo_args is unprocessed -- it is exactly the list as used in the closure[*] - * definition */ - int32_t len; - if (is_symbol (clo_args)) /* any number of args is ok */ - return (cons (sc, int_zero, max_arity)); - if (closure_arity_unknown (clo)) - closure_set_arity (clo, s7_list_length (sc, clo_args)); - len= closure_arity (clo); - 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_unchecked (sc, len))); -} - -static void -closure_star_arity_1 (s7_scheme* sc, s7_pointer clo, s7_pointer args) { - if (closure_arity_unknown (clo)) { - if (is_null (args)) closure_set_arity (clo, 0); - else if ((is_symbol (args)) || (allows_other_keys (args))) - closure_set_arity (clo, -1); - else { - s7_pointer pars; - int32_t i; - for (i= 0, pars= args; is_pair (pars); i++, - pars= cdr ( - pars)) /* is_pair(pars) so (f1 a . b) will end with b not null */ - if (car (pars) == sc->rest_keyword) break; - closure_set_arity (clo, ((is_null (pars)) ? i : -1)); /* see below */ +#define hash_int_abs(x) ((x) >= 0 ? (x) : ((x == S7_INT64_MIN) ? S7_INT64_MAX : -(x))) + +static hash_entry_t *hash_equal_integer(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + const s7_int keyint = integer(key); + const s7_uint loc = hash_int_abs(keyint) % hash_table_mask(table); /* hash_loc -> hash_map_int */ + for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + { + if ((is_t_integer(hash_entry_key(entry))) && + (keyint == integer(hash_entry_key(entry)))) + return(entry); } - } + return(sc->unentry); } -static s7_pointer -closure_star_arity_to_cons (s7_scheme* sc, s7_pointer clo, - s7_pointer clo_args) { - closure_star_arity_1 (sc, clo, clo_args); - return ((closure_arity (clo) == -1) - ? cons (sc, int_zero, max_arity) - : cons (sc, int_zero, make_integer (sc, closure_arity (clo)))); +static hash_entry_t *hash_equal_ratio(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + const s7_int keynum = numerator(key), keyden = denominator(key); + const s7_uint loc = s7_int_abs(keynum / keyden) % hash_table_mask(table); /* hash_loc -> hash_map_ratio */ + for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + { + if ((is_t_ratio(hash_entry_key(entry))) && + (keynum == numerator(hash_entry_key(entry))) && + (keyden == denominator(hash_entry_key(entry)))) + return(entry); + } + return(sc->unentry); } -static int32_t -closure_arity_to_int (s7_scheme* sc, s7_pointer clo) { - /* not lambda* here */ - if (closure_arity_unknown (clo)) { - int32_t i; - s7_pointer pars= closure_pars (clo); - for (i= 0; is_pair (pars); i++, pars= cdr (pars)) { - }; - if (is_null (pars)) closure_set_arity (clo, i); - else { - if (i == 0) return (-1); - closure_set_arity (clo, -i); +static hash_entry_t *hash_equal_real(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + s7_uint loc; + const s7_double keydbl = real(key); + if (is_NaN(keydbl)) return(sc->unentry); + loc = hash_float_location(keydbl) % hash_table_mask(table); + for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + { + if ((is_t_real(hash_entry_key(entry))) && + (keydbl == real(hash_entry_key(entry)))) + return(entry); } - } - return (closure_arity (clo)); + return(sc->unentry); } -static int32_t -closure_star_arity_to_int (s7_scheme* sc, s7_pointer clo) { - /* not lambda here */ - closure_star_arity_1 (sc, clo, closure_pars (clo)); - return (closure_arity (clo)); -} - -static s7_pointer -c_object_arity_to_int (s7_scheme* sc, s7_pointer obj) { - if_c_object_method_exists_return_value (sc, obj, sc->arity_symbol, - set_plist_1 (sc, obj)); - return ((is_safe_procedure (obj)) ? cons (sc, int_zero, max_arity) : sc->F); -} - -static s7_pointer -vector_arity_to_int (s7_scheme* sc, s7_pointer obj) { - if (vector_length (obj) == 0) return (sc->F); - if (has_simple_elements (obj)) - return (cons (sc, int_one, make_integer (sc, vector_rank (obj)))); - return (cons (sc, int_one, max_arity)); -} - -static s7_pointer -syntax_arity_to_int (s7_scheme* sc, s7_pointer obj) { - return (cons (sc, small_int (syntax_min_args (obj)), - (syntax_max_args (obj) == MAX_ARITY) - ? max_arity - : small_int (syntax_max_args (obj)))); -} - -s7_pointer -s7_arity (s7_scheme* sc, s7_pointer obj) { - switch (type (obj)) { - case T_C_FUNCTION: - return (cons (sc, make_integer (sc, c_function_min_args (obj)), - make_integer_unchecked (sc, c_function_max_args (obj)))); - case T_C_RST_NO_REQ_FUNCTION: - return (cons (sc, int_zero, max_arity)); - case T_C_FUNCTION_STAR: - return (cons (sc, int_zero, make_integer (sc, c_function_max_args (obj)))); - case T_CLOSURE: - case T_MACRO: - case T_BACRO: - return (closure_arity_to_cons (sc, obj, closure_pars (obj))); - case T_CLOSURE_STAR: - case T_MACRO_STAR: - case T_BACRO_STAR: - return (closure_star_arity_to_cons (sc, obj, closure_pars (obj))); - case T_C_MACRO: - return (cons (sc, make_integer (sc, c_macro_min_args (obj)), - make_integer_unchecked (sc, c_macro_max_args (obj)))); - case T_C_OBJECT: - return (c_object_arity_to_int (sc, obj)); - 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_GOTO: - case T_CONTINUATION: - return (cons (sc, int_zero, max_arity)); - case T_STRING: - return ((string_length (obj) == 0) ? sc->F : cons (sc, int_one, int_one)); - case T_LET: - return (cons (sc, int_one, int_one)); - case T_SYNTAX: - return (syntax_arity_to_int (sc, obj)); - case T_VECTOR: - return (vector_arity_to_int (sc, obj)); - case T_INT_VECTOR: - case T_FLOAT_VECTOR: - case T_BYTE_VECTOR: - case T_COMPLEX_VECTOR: - return ((vector_length (obj) == 0) - ? sc->F - : cons (sc, int_one, make_integer (sc, vector_rank (obj)))); - } - return (sc->F); -} +static hash_entry_t *hash_equal_complex(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + s7_uint loc; + const s7_double keyrl = real_part(key); + const s7_double keyim = imag_part(key); -/* g_arity is now defined in s7_scheme_predicate.c */ -#define H_arity \ - "(arity obj) the min and max number of args that obj can be applied to. " \ - "Returns #f if the object is not applicable." -#define Q_arity \ - s7_make_signature ( \ - sc, 2, s7_make_signature (sc, 2, sc->is_pair_symbol, sc->not_symbol), \ - sc->T) - -/* -------------------------------- aritable? -------------------------------- - */ -static bool -closure_is_aritable (s7_scheme* sc, s7_pointer clo, s7_pointer clo_args, - int32_t args) { - /* clo_args is unprocessed -- it is exactly the list as used in the closure - * definition */ - s7_int len; - if (args == 0) return (!is_pair (clo_args)); - if (is_symbol (clo_args)) return (true); /* any number of args is ok */ - len= closure_arity (clo); - if (len == CLOSURE_ARITY_NOT_SET) { - len= s7_list_length (sc, clo_args); - closure_set_arity (clo, 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 */ + loc = hash_map_complex(sc, table, key) % hash_table_mask(table); + for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + { + if ((is_t_complex(hash_entry_key(entry))) && + (keyrl == real_part(hash_entry_key(entry))) && + (keyim == imag_part(hash_entry_key(entry)))) + return(entry); + } + return(sc->unentry); } -static bool -closure_star_is_aritable (s7_scheme* sc, s7_pointer clo, s7_pointer clo_args, - int32_t args) { - if (is_symbol (clo_args)) return (true); - closure_star_arity_1 (sc, clo, clo_args); - return ((closure_arity (clo) == -1) || (args <= closure_arity (clo))); +static hash_entry_t *hash_equal_any(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + bool (*equal)(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) = equals[type(key)]; + const s7_uint hash = hash_loc(sc, table, key); + const s7_uint loc = hash % hash_table_mask(table); + for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if (key == hash_entry_key(entry)) /* avoid the equal funcs if possible -- this saves in both hash timing tests */ + return(entry); + for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if ((hash_entry_raw_hash(entry) == hash) && + (equal(sc, key, hash_entry_key(entry), NULL))) + return(entry); + return(sc->unentry); } -static bool -c_object_is_aritable (s7_scheme* sc, s7_pointer clo, int32_t args) { - s7_pointer func; - if ((has_active_methods (sc, clo)) && - ((func= find_method_with_c_object (sc, clo, sc->is_aritable_symbol)) != - sc->undefined)) - return (s7_apply_function ( - sc, func, set_plist_2 (sc, clo, make_integer (sc, args))) != - sc->F); - return ((is_safe_procedure (clo)) && - (args == 1)); /* can we get the arity from clo? */ -} - -bool -s7_is_aritable (s7_scheme* sc, s7_pointer clo, s7_int args) { - switch (type (clo)) { - case T_C_FUNCTION: - return (c_function_is_aritable (clo, args)); - case T_C_RST_NO_REQ_FUNCTION: - if (has_even_args (clo)) return ((args & 1) == 0); - return (true); - case T_C_FUNCTION_STAR: - return (c_function_max_args (clo) >= args); - case T_CLOSURE: - case T_MACRO: - case T_BACRO: - return (closure_is_aritable (sc, clo, closure_pars (clo), args)); - case T_CLOSURE_STAR: - case T_MACRO_STAR: - case T_BACRO_STAR: - return (closure_star_is_aritable (sc, clo, closure_pars (clo), args)); - case T_C_MACRO: - return ((c_macro_min_args (clo) <= args) && - (c_macro_max_args (clo) >= args)); - case T_GOTO: - case T_CONTINUATION: - return (true); - case T_STRING: - return ((args == 1) && (string_length (clo) > 0)); /* ("" 0) -> error */ - case T_ITERATOR: - return (args == 0); - case T_SYNTAX: - return ((args >= syntax_min_args (clo)) && (args <= syntax_max_args (clo))); - case T_HASH_TABLE: - return (args == 1); /* refers to implicit ref (table key) */ - case T_LET: - case T_PAIR: - return (args == 1); - case T_C_OBJECT: - return (c_object_is_aritable (sc, clo, args)); - case T_VECTOR: - case T_INT_VECTOR: - case T_FLOAT_VECTOR: - case T_BYTE_VECTOR: - case T_COMPLEX_VECTOR: - return ((args > 0) && (vector_length (clo) > 0) && - (args <= vector_rank (clo))); /* (#() 0) -> error */ - } - 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 num_args= cadr (args); - s7_int num; - if (!s7_is_integer (num_args)) /* remember gmp case! */ - return (method_or_bust (sc, num_args, sc->is_aritable_symbol, args, - sc->type_names[T_INTEGER], 2)); - num= s7_integer_clamped_if_gmp (sc, num_args); - if (num < 0) - out_of_range_error_nr (sc, sc->is_aritable_symbol, int_two, num_args, - it_is_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 func, s7_pointer num_args) { - return (g_is_aritable (sc, set_plist_2 (sc, func, num_args)) != sc->F); +/* ---------------- hash c_functions ---------------- */ +static s7_uint hash_map_c_function(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + s7_function f = c_function_call(hash_table_procedures_mapper(table)); + return(integer(f(sc, with_list_t1(sc, key)))); } -static int32_t -arity_to_int (s7_scheme* sc, s7_pointer clo) { - int32_t args; - switch (type (clo)) { - case T_C_FUNCTION: - case T_C_FUNCTION_STAR: - return (c_function_max_args (clo)); - case T_C_RST_NO_REQ_FUNCTION: - return (MAX_ARITY); - case T_CLOSURE: - case T_MACRO: - case T_BACRO: - args= closure_arity_to_int (sc, clo); - return ((args < 0) ? MAX_ARITY : args); - case T_CLOSURE_STAR: - case T_MACRO_STAR: - case T_BACRO_STAR: - args= closure_star_arity_to_int (sc, clo); - return ((args < 0) ? MAX_ARITY : args); - case T_C_MACRO: - return (c_macro_max_args (clo)); - /* case T_C_OBJECT: return(MAX_ARITY); */ /* this currently can't be called - */ - /* vectors et al don't make sense here -- this is called only in - * g_set_setter below where it is restricted to is_any_procedure - * (type>=T_CLOSURE) */ - } - if (S7_DEBUGGING) fprintf (stderr, "%s -1\n", __func__); - return (-1); /* unreachable I think */ +static s7_uint hash_map_c_pointer(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + return(pointer_map(c_pointer(key))); } -/* -------------------------------- sequence? -------------------------------- - */ -/* g_is_sequence is now defined in s7_scheme_predicate.c */ -#define H_is_sequence \ - "(sequence? obj) returns #t if obj is a sequence (vector, string, pair, " \ - "etc)" -#define Q_is_sequence sc->pl_bt - -static bool -is_sequence_b (s7_pointer seq) { - return (is_simple_sequence (seq)); +static s7_uint hash_map_undefined(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + return(raw_string_hash((const uint8_t *)(undefined_name(key) + 1), undefined_name_length(key) - 1) + undefined_name_length(key)); + /* undefined_name always starts with "#", so we omit it above */ } -/* -------------------------------- setter - * ------------------------------------------------ */ -s7_pointer -b_simple_setter (s7_scheme* sc, int32_t typer, - s7_pointer args) /* see bool_defun -> define_bool_function */ +static s7_uint hash_map_iterator(s7_scheme *sc, s7_pointer table, s7_pointer key) { - if (type (cadr (args)) != typer) - error_nr (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->type_names[type (cadr (args))], - sc->type_names[typer])); - return (cadr (args)); + /* cycles can happen here if the iterator_sequence contains the iterator and hash_loc checks that element */ + return(type(iterator_sequence(key)) + hash_loc(sc, table, iterator_sequence(key))); } -/* these are for the simplified setter designation: (let ((x 1)) (set! (setter - * 'x) integer?) (set! x 3.14)) -> error */ +static hash_entry_t *hash_equal(s7_scheme *sc, s7_pointer table, s7_pointer key); -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_byte_vector_setter (s7_scheme* sc, s7_pointer args) { - return (b_simple_setter (sc, T_BYTE_VECTOR, 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_c_pointer_setter (s7_scheme* sc, s7_pointer args) { - return (b_simple_setter (sc, T_C_POINTER, 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_eof_object_setter (s7_scheme* sc, s7_pointer args) { - return (b_simple_setter (sc, T_EOF, 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_complex_vector_setter (s7_scheme* sc, s7_pointer args) { - return (b_simple_setter (sc, T_COMPLEX_VECTOR, args)); -} -static s7_pointer -b_is_goto_setter (s7_scheme* sc, s7_pointer args) { - return (b_simple_setter (sc, T_GOTO, 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_input_port_setter (s7_scheme* sc, s7_pointer args) { - return (b_simple_setter (sc, T_INPUT_PORT, 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_iterator_setter (s7_scheme* sc, s7_pointer args) { - return (b_simple_setter (sc, T_ITERATOR, 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_null_setter (s7_scheme* sc, s7_pointer args) { - return (b_simple_setter (sc, T_NIL, 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_pair_setter (s7_scheme* sc, s7_pointer args) { - return (b_simple_setter (sc, T_PAIR, 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_string_setter (s7_scheme* sc, s7_pointer args) { - return (b_simple_setter (sc, T_STRING, args)); -} -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_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 hash_entry_t *hash_c_function(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + if (is_pair(hash_table_procedures(table))) + { + const s7_function f = c_function_call(hash_table_procedures_checker(table)); + const s7_uint hash = hash_loc(sc, table, key); + const s7_uint loc = hash % hash_table_mask(table); + set_car(sc->t2_1, key); + for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if (hash_entry_raw_hash(entry) == hash) + { + set_car(sc->t2_2, hash_entry_key(entry)); + if (is_true(sc, f(sc, sc->t2_1))) + return(entry); + } + return(sc->unentry); + } + return(hash_equal(sc, table, key)); +} + +static int32_t len_upto_100(s7_pointer p) +{ + int32_t i = 0; + for (; (is_pair(p)) && (i < 100); i++, p = cdr(p)); + return(i); +} -#define b_setter(sc, typer, args, str, len) \ - do { \ - if (!typer (cadr (args))) \ - error_nr ( \ - 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->type_names[type (cadr (args))], \ - wrap_string (sc, str, len))); \ - return (cadr (args)); \ - } while (0) +static s7_uint 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 (or tree-leaves == tree_len(sc, p)) + * with stats like symbols/pairs/constants at top level, then use those to spread it out over all the locs. + * key can be cyclic, so tree_len would need to check for cycles. + */ + const s7_pointer p = cdr(key); + s7_uint loc = 0; -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_complex_setter (s7_scheme* sc, s7_pointer args) { - b_setter (sc, s7_is_complex, args, "a number", 8); -} -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_float_setter (s7_scheme* sc, s7_pointer args) { - b_setter (sc, is_t_real, args, "a float", 7); -} -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_integer_setter (s7_scheme* sc, s7_pointer args) { - b_setter (sc, s7_is_integer, args, "an integer", 10); -} -static s7_pointer -b_is_keyword_setter (s7_scheme* sc, s7_pointer args) { - b_setter (sc, is_symbol_and_keyword, args, "a keyword", 9); -} -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_macro_setter (s7_scheme* sc, s7_pointer args) { - b_setter (sc, is_any_macro, args, "a macro", 7); -} -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_openlet_setter (s7_scheme* sc, s7_pointer args) { - b_setter (sc, has_methods, args, "an open let", 11); -} -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_rational_setter (s7_scheme* sc, s7_pointer args) { - b_setter (sc, is_rational, args, "a rational", 10); -} -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_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_vector_setter (s7_scheme* sc, s7_pointer args) { - b_setter (sc, is_any_vector, args, "a vector", 8); -} -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))) - error_nr (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->type_names[type (cadr (args))], - wrap_string (sc, "a proper list", 13))); - return (cadr (args)); -} - -static s7_pointer -lambda_setter (s7_scheme* sc, s7_pointer clo) { - if (is_any_procedure ( - closure_setter_or_map_list (clo))) /* setter already known */ - return (closure_setter (clo)); - if (is_pair (closure_setter_or_map_list ( - clo))) /* it's a map_list masquerading as a setter */ - return (sc->F); - if (!closure_no_setter (clo)) { - const s7_pointer setter= funclet_entry ( - sc, clo, sc->local_setter_symbol); /* look for +setter+, save value as - closure_setter(clo) */ - if (setter) { - if (setter == sc->F) { - closure_set_no_setter (clo); - return (sc->F); - } - if (!is_any_procedure (setter)) - sole_arg_wrong_type_error_nr ( - sc, sc->setter_symbol, clo, - wrap_string (sc, "a procedure or a reasonable facsimile thereof", - 45)); - closure_set_setter (clo, setter); - return (setter); - } - /* 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 (clo); - } - return (sc->F); + if (!is_sequence_or_iterator(car(key))) + loc = hash_loc(sc, table, car(key)) + 1; + else + if ((is_pair(car(key))) && + (!is_sequence_or_iterator(caar(key)))) + loc = hash_loc(sc, table, caar(key)) + 1; + if (is_pair(p)) + { + if (!is_sequence_or_iterator(car(p))) + loc += hash_loc(sc, table, car(p)) + 1; + else + if ((is_pair(car(p))) && + (!is_sequence_or_iterator(caar(p)))) + loc += hash_loc(sc, table, caar(p)) + 1; + } + else + if (!is_sequence_or_iterator(p)) /* include () */ + loc += hash_loc(sc, table, p); + return((loc << 3) + len_upto_100(key)); /* undefined sanitizer is unhappy here, hash_mask was not a solution */ } -static s7_pointer -symbol_setter (s7_scheme* sc, s7_pointer sym, s7_pointer let) { - s7_pointer slot; - if (is_keyword (sym)) return (sc->F); - if (let == sc->rootlet) slot= global_slot (sym); - else { - s7_pointer old_let= sc->curlet; - set_curlet (sc, let); - slot= s7_slot (sc, sym); - set_curlet (sc, old_let); - } - if ((!is_slot (slot)) || (!slot_has_setter (slot))) return (sc->F); - { - s7_pointer setter= slot_setter (slot); - if ((is_any_procedure (setter)) && (is_bool_function (setter))) - return (c_function_setter (setter)); - return (setter); - } +static hash_entry_t *hash_closure(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + if (is_pair(hash_table_procedures(table))) + { + const s7_pointer f = hash_table_procedures_checker(table); + const s7_uint hash = hash_loc(sc, table, key); + const s7_uint loc = hash % hash_table_mask(table); + for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if ((hash_entry_raw_hash(entry) == hash) && + (is_true(sc, s7_call(sc, f, set_plist_2(sc, key, hash_entry_key(entry)))))) + return(entry); + return(sc->unentry); + } + return(hash_equal(sc, table, key)); } -static s7_pointer -setter_p_pp (s7_scheme* sc, s7_pointer obj, s7_pointer let) { - if (!is_let (let)) { - s7_pointer new_let= find_let (sc, let); - if ((!is_let (new_let)) || (new_let == sc->rootlet)) - find_let_error_nr (sc, sc->setter_symbol, let, new_let, 2, - set_mlist_2 (sc, obj, let)); - let= new_let; - } - 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 (lambda_setter (sc, obj)); - - case T_C_FUNCTION: - case T_C_FUNCTION_STAR: - case T_C_RST_NO_REQ_FUNCTION: - return (c_function_setter (obj)); - - case T_C_MACRO: - return (c_macro_setter (obj)); - - case T_C_OBJECT: - if_c_object_method_exists_return_value (sc, obj, sc->setter_symbol, - set_plist_2 (sc, obj, let)); - return ((c_object_set (sc, obj) == 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: - if_let_method_exists_return_value (sc, obj, sc->setter_symbol, - set_plist_2 (sc, obj, let)); - 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 (obj))) - ? closure_setter (iterator_sequence (obj)) - : sc->F); - - case T_PAIR: - return (global_value (sc->list_set_symbol)); /* or maybe initial-value? */ - 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_COMPLEX_VECTOR: - return (global_value (sc->complex_vector_set_symbol)); - case T_SLOT: - return ((slot_has_setter (obj)) ? slot_setter (obj) : sc->F); - case T_SYMBOL: - return (symbol_setter (sc, obj, let)); /* (setter symbol let) */ - } - /* wrong_type_error_nr(sc, sc->setter_symbol, 1, obj, wrap_string(sc, - * "something that might have a setter", 34)); */ /* this seems unfriendly */ - return (sc->F); +static hash_entry_t *hash_equal(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + return((*(equal_hash_checks[type(key)]))(sc, table, key)); } -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, has_let_signature (sc)) - return (setter_p_pp (sc, car (args), - (is_pair (cdr (args))) ? cadr (args) : sc->curlet)); -} +/* ---------------- hash equivalent? ---------------- */ +static hash_entry_t *hash_equivalent(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + hash_entry_t *entry; + s7_uint hash, loc; -s7_pointer -s7_setter (s7_scheme* sc, s7_pointer obj) { - return (setter_p_pp (sc, obj, sc->curlet)); + if (is_number(key)) + { + entry = hash_number_equivalent(sc, table, key); + if ((entry != sc->unentry) || (!is_nan_b_7p(sc, key))) + return(entry); + for (entry = hash_table_element(table, 0); entry; entry = hash_entry_next(entry)) /* NaN is mapped to 0 */ + if (is_nan_b_7p(sc, hash_entry_key(entry))) /* all NaN's are the same to equivalent? */ + return(entry); + return(sc->unentry); + } + hash = hash_loc(sc, table, key); + loc = hash % hash_table_mask(table); + for (entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if (hash_entry_key(entry) == key) + return(entry); + + for (entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if ((hash_entry_raw_hash(entry) == hash) && + (s7_is_equivalent(sc, hash_entry_key(entry), key))) + return(entry); + return(sc->unentry); +} + +bool hash_keys_not_cyclic(s7_scheme *sc, s7_pointer hash) +{ + return((is_null(hash_table_procedures(hash))) && + (hash_table_mapper(hash) == default_hash_map) && + (hash_table_checker(hash) != hash_equal) && + (hash_table_checker(hash) != hash_equivalent) && + (hash_table_checker(hash) != hash_closure) && + (hash_table_checker(hash) != hash_c_function)); } -s7_pointer -g_restore_setter (s7_scheme* sc, s7_pointer args) { - closure_set_setter (caar (args), cadar (args)); - return (cadar (args)); -} -/* see dynamic_unwind below -- it passes us list_2(sc, stack_args, sc->value) so - * we ignore cadr(args) */ -/* -------------------------------- set-setter -------------------------------- - */ -static void -protect_setter (s7_scheme* sc, s7_pointer sym, s7_pointer setter) { - if (sc->protected_setters_size == sc->protected_setters_loc) { - const s7_int size = sc->protected_setters_size; - const s7_int new_size= 2 * size; - block_t* old_b = vector_block ( - sc->protected_setters); /* old_b is liberated by reallocate below */ - block_t* new_b = reallocate (sc, old_b, new_size * sizeof (s7_pointer)); - block_info (new_b)= NULL; - vector_block (sc->protected_setters) = new_b; - vector_elements (sc->protected_setters)= (s7_pointer*) block_data (new_b); - vector_length (sc->protected_setters) = new_size; - - old_b= vector_block (sc->protected_setter_symbols); /* old_b is liberated by - reallocate below */ - new_b= reallocate (sc, old_b, new_size * sizeof (s7_pointer)); - vector_block (sc->protected_setter_symbols)= new_b; - vector_elements (sc->protected_setter_symbols)= - (s7_pointer*) block_data (new_b); - vector_length (sc->protected_setter_symbols)= new_size; - - for (s7_int 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; - } +/* -------------------------------- make-hash-table -------------------------------- */ +s7_pointer s7_make_hash_table(s7_scheme *sc, s7_int size) +{ + /* 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++; + } { - s7_int loc= sc->protected_setters_loc++; - vector_element (sc->protected_setters, loc)= - setter; /* has_closure => T_Prc[Clo?](setter) checked earlier */ - vector_element (sc->protected_setter_symbols, loc)= sym; - } + s7_pointer table; + block_t *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; + if ((S7_DEBUGGING) && (size <= 1)) fprintf(stderr, "%s[%d]: hash-table size: %" ld64 "\n", __func__, __LINE__, size); + hash_table_set_block(table, els); + hash_table_elements(table) = (hash_entry_t **)(block_data(els)); + 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, const s7_pointer eq_type, const 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 -symbol_set_setter (s7_scheme* sc, s7_pointer sym, s7_pointer args) { - s7_pointer func, slot; - if (is_keyword (sym)) - wrong_type_error_nr ( - sc, wrap_string (sc, "set! setter", 11), 1, sym, - wrap_string (sc, "a normal symbol (a keyword can't be set)", 40)); - - if (is_pair (cddr (args))) { - s7_pointer let= - cadr (args); /* (let ((x 1)) (set! (setter 'x (curlet)) (lambda (s v e) - ...))): args is (x (inlet 'x 1) #) */ - func= caddr (args); - if (let == sc->rootlet) slot= global_slot (sym); - else { - if (!is_let (let)) { - s7_pointer new_let= find_let (sc, let); - if ((!is_let (new_let)) || (new_let == sc->rootlet)) - find_let_error_nr (sc, wrap_string (sc, "set! setter", 11), let, - new_let, 2, args); - let= new_let; - } - slot= lookup_slot_with_let (sc, sym, let); - } - } - else { - slot= s7_slot (sc, sym); /* (set! (setter 'x) (lambda (s v) ...)): args is: - (x #) */ - func= cadr (args); - } - if (!is_slot (slot)) return (sc->F); - - if (func != sc->F) { - if (sym == sc->setter_symbol) - immutable_object_error_nr ( - sc, set_elist_2 ( - sc, wrap_string (sc, "can't set (setter 'setter) to ~S", 32), - func)); - if (is_syntax_or_qq (slot_value ( - slot))) /* (set! (setter 'begin) ...), qq is syntax sez r7rs */ - immutable_object_error_nr ( - sc, - set_elist_3 (sc, wrap_string (sc, "can't set (setter '~S) to ~S", 28), - sym, func)); - if (!is_any_procedure ( - func)) /* this will disallow continuation/goto here */ - wrong_type_error_nr (sc, wrap_string (sc, "set! setter", 11), 3, func, - wrap_string (sc, "a function or #f", 16)); - if (func == global_value (sc->values_symbol)) - error_nr ( - sc, make_symbol (sc, "invalid-setter", 14), - set_elist_2 (sc, wrap_string (sc, "~S's setter can't be values", 27), - sym)); - 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)) - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_2 ( - sc, - wrap_string ( - sc, - "symbol setter function, ~A, should take 2 or 3 arguments", - 56), - 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); - return (func); -} - -static s7_pointer -g_set_setter (s7_scheme* sc, s7_pointer args) { - const s7_pointer obj= car (args), setter= cadr (args); - if (is_symbol (obj)) /* has to precede cadr(args) checks, (set! (setter 'x - let) ...) where setter is caddr(args) */ - return (symbol_set_setter (sc, obj, args)); - if (obj == sc->starlet) - wrong_type_error_nr (sc, wrap_string (sc, "set! setter", 11), 1, obj, - wrap_string (sc, "something other than *s7*", 25)); - - if (setter != sc->F) { - if (!is_any_procedure (setter)) - wrong_type_error_nr (sc, wrap_string (sc, "set! setter", 11), 2, setter, - wrap_string (sc, "a procedure or #f", 17)); - if (arity_to_int (sc, setter) < - 1) /* we need at least an arg for the set! value */ - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_2 ( - sc, - wrap_string ( - sc, "setter function, ~A, should take at least one argument", - 54), - setter)); - if (setter == global_value (sc->values_symbol)) - error_nr ( - sc, make_symbol (sc, "invalid-setter", 14), - set_elist_2 (sc, wrap_string (sc, "~S's setter can't be values", 27), - 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: - closure_set_setter (obj, setter); - if (setter == sc->F) closure_set_no_setter (obj); - break; - - case T_C_FUNCTION: - case T_C_FUNCTION_STAR: - case T_C_RST_NO_REQ_FUNCTION: - if (obj == - global_value (sc->setter_symbol)) /* (immutable? (setter setter)) is #t, - but we aren't checking immutable? - here -- maybe we should? */ - immutable_object_error_nr ( - sc, set_elist_2 ( - sc, wrap_string (sc, "can't set (setter setter) to ~S", 31), - setter)); - if (obj == global_value ( - sc->values_symbol)) /* 6-Oct-23 (set! (setter values) ...) is - problematic, see splice_in_values */ - immutable_object_error_nr ( - sc, set_elist_2 ( - sc, wrap_string (sc, "can't set (setter values) to ~S", 31), - setter)); - c_function_set_setter (obj, setter); - /* below: not any_closure or any_macro because that include c-macros: - * twice: (catch #t (lambda () (let () (define (func) (set! (setter map) - * quasiquote)) (func))) (lambda (t i) 'error)) -> c-macro case! - */ - if (has_closure_let (setter)) add_setter (sc, obj, setter); - break; - - case T_C_MACRO: - c_macro_set_setter (obj, setter); - if (has_closure_let (setter)) add_setter (sc, obj, setter); - break; - - default: /* (set! (setter 4) ...) or p==continuation etc */ - wrong_type_error_nr ( - sc, wrap_string (sc, "set! setter", 11), 1, obj, - wrap_string (sc, "a symbol, a procedure, or a macro", 33)); - } - return (setter); -} - -s7_pointer -s7_set_setter (s7_scheme* sc, s7_pointer obj, s7_pointer setter) { - if (is_symbol (obj)) { - if (slot_has_setter (global_slot (obj))) - for (s7_int index= 0; index < sc->protected_setters_loc; index++) - if (vector_element (sc->protected_setter_symbols, index) == obj) { - const s7_pointer 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 (obj), 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 (obj)); - if (!is_c_function (setter)) - protect_setter ( - sc, obj, T_Clo (setter)); /* c_functions don't need GC protection */ - slot_set_setter (global_slot (obj), setter); - if (s7_is_aritable (sc, setter, 3)) set_has_let_arg (setter); - return (setter); - } - slot_set_setter (global_slot (obj), sc->F); - return (sc->F); - } - return (g_set_setter ( - sc, set_plist_2 (sc, obj, setter))); /* if T_Clo(setter), doesn't it need - GC protection as above? */ -} +s7_pointer s7i_make_hash_table_1(s7_scheme *sc, s7_pointer args, s7_pointer caller) +{ + #define H_make_hash_table "(s7-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; -/* (let () (define xxx 23) (define (hix) (set! xxx 24)) (hix) (set! (setter - * 'xxx) (lambda (sym val) (format *stderr* "val: ~A~%" val) val)) (hix)) which - * does not call the setter presumably because the set! has been optimized to - * ignore it -- set the setter before use! - */ + if (is_pair(args)) + { + const s7_pointer len = car(args); + if (!s7_is_integer(len)) + return(method_or_bust(sc, len, caller, args, sc->type_names[T_INTEGER], 1)); + size = s7_integer_clamped_if_gmp(sc, len); + if (size < 0) /* we need s7_int here to catch (make-hash-table most-negative-fixnum) etc */ + out_of_range_error_nr(sc, caller, int_one, len, wrap_string(sc, "it should be a positive integer", 31)); + if ((size > sc->max_vector_length) || + (size >= (1LL << 32))) /* s7test tests >= */ + out_of_range_error_nr(sc, caller, int_one, len, it_is_too_large_string); + if (size == 0) size = sc->default_hash_table_length; + + if (is_pair(cdr(args))) + { + s7_pointer proc; + const s7_pointer table = s7_make_hash_table(sc, size); + /* check for typers */ + if (is_pair(cddr(args))) + { + const s7_pointer typers = caddr(args); + if (is_pair(typers)) + { + const 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)))) + wrong_type_error_nr(sc, caller, 3, typers, wrap_string(sc, "(key-type . value-type)", 23)); + + if ((keyp != sc->T) && + (!s7_is_aritable(sc, keyp, 1))) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) both functions should take one argument", 100), + caller, typers)); + hash_table_set_procedures(table, make_hash_table_procedures(sc)); + hash_table_set_key_typer(table, keyp); + hash_table_set_value_typer(table, valp); + if (is_c_function(keyp)) + { + if (!c_function_name(keyp)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) the first function is anonymous", 92), + caller, typers)); + if (c_function_has_simple_elements(keyp)) + set_has_simple_keys(table); + if (symbol_type(c_function_symbol(keyp)) != T_FREE) + set_has_hash_key_type(table); + /* 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 = 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)))) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "~A: in the third argument, the key type function is not compatible with the equality function: ~S", 97), + caller, typers)); + }} + else + if ((is_any_closure(keyp)) && + (!is_symbol(find_closure(sc, keyp, closure_let(keyp))))) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) the first function is anonymous", 92), + caller, typers)); + if ((valp != sc->T) && + (!s7_is_aritable(sc, valp, 1))) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) both functions should take one argument", 100), + caller, typers)); + if (is_c_function(valp)) + { + if (!c_function_name(valp)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) the second function is anonymous", 93), + caller, typers)); + if (c_function_has_simple_elements(valp)) + set_has_simple_values(table); + if (symbol_type(c_function_symbol(valp)) != T_FREE) + set_has_hash_value_type(table); + } + else + if ((is_any_closure(valp)) && + (!is_symbol(find_closure(sc, valp, closure_let(valp))))) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) the second function is anonymous", 93), + caller, typers)); + set_is_typed_hash_table(table); + }} + else + if (typers != sc->F) + wrong_type_error_nr(sc, caller, 3, typers, wrap_string(sc, "either #f or (cons key-type-check value-type-check)", 51)); + } -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)) /* setter has optional third arg, the let */ - return (c_function_call (func) ( - sc, with_list_t3 (sc, symbol, new_value, sc->curlet))); - return (c_function_call (func) (sc, with_list_t2 (sc, symbol, new_value))); -} - -static s7_pointer -call_setter (s7_scheme* sc, s7_pointer slot, - s7_pointer new_value) /* see also op_set1 */ -{ - const s7_pointer func= slot_setter (slot); - if (is_c_function (func)) - return (call_c_function_setter (sc, func, slot_symbol (slot), new_value)); - if (!is_any_procedure (func)) return (new_value); - sc->temp9= (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) */ - /* the following s7_call can clobber the temp var (perhaps setter is calling - * implicit set!?) */ - { - s7_pointer result= s7_call (sc, func, sc->temp9); - sc->temp9 = sc->unused; - return (result); - } + /* check eq_func */ + proc = cadr(args); + if (is_c_function(proc)) + { + hash_set_chosen(table); + + if (!s7_is_aritable(sc, proc, 2)) + wrong_type_error_nr(sc, caller, 2, proc, an_eq_func_string); + + if (c_function_call(proc) == g_is_equal) + { + hash_table_checker(table) = hash_equal; + return(table); + } + if (c_function_call(proc) == g_is_equivalent) + { + hash_table_checker(table) = hash_equivalent; + hash_table_mapper(table) = equivalent_hash_map; /* needed only by hash_table_equal_1 (checker_locked looks at mapper?!) */ + return(table); + } + if (c_function_call(proc) == g_is_eq) + { + hash_table_checker(table) = hash_eq; + hash_table_mapper(table) = eq_hash_map; + return(table); + } + if (c_function_call(proc) == g_strings_are_equal) + { + hash_table_checker(table) = hash_string; + hash_table_mapper(table) = string_eq_hash_map; + return(table); + } + if (c_function_call(proc) == g_chars_are_equal) + { + hash_table_checker(table) = hash_char; + hash_table_mapper(table) = char_eq_hash_map; + return(table); + } + if (c_function_call(proc) == g_num_eq) + { + if ((is_typed_hash_table(table)) && + (hash_table_key_typer(table) == global_value(sc->is_integer_symbol))) + hash_table_checker(table) = hash_int; + else hash_table_checker(table) = hash_number_num_eq; + return(table); + } + if (c_function_call(proc) == g_is_eqv) + { + hash_table_checker(table) = hash_eqv; + return(table); + } + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "~A second argument, ~S, is not a built-in function it can handle", 64), caller, proc)); + } + /* proc not c_function */ + else + { + if (is_pair(proc)) + { + const s7_pointer checker = car(proc), mapper = cdr(proc); + + hash_set_chosen(table); + if (!((is_any_c_function(checker)) || (is_any_closure(checker)))) + error_nr(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)))) + error_nr(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)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "~A's equality function, ~A, (car of the second argument) should be a function of two arguments", 94), + caller, checker)); + if (!s7_is_aritable(sc, mapper, 1)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "~A's mapping function, ~A, (cdr of the second argument) should be a function of one argument", 92), + caller, mapper)); + + if (is_any_c_function(checker)) + { + s7_pointer sig = c_function_signature(checker); + if ((sig) && + (is_pair(sig)) && + (car(sig) != sc->is_boolean_symbol)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "~A checker function, ~S, should return a boolean value", 54), caller, checker)); + hash_table_checker(table) = hash_c_function; + } + else hash_table_checker(table) = hash_closure; + + if (is_any_c_function(mapper)) + { + const s7_pointer sig = c_function_signature(mapper); + if ((sig) && + (is_pair(sig)) && + (car(sig) != sc->is_integer_symbol)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "~A mapper function, ~S, should return an integer", 48), caller, mapper)); + hash_table_mapper(table) = c_function_hash_map; + } + else hash_table_mapper(table) = closure_hash_map; + + if (is_null(hash_table_procedures(table))) + hash_table_set_procedures(table, make_hash_table_procedures(sc)); + hash_table_set_procedures_checker(table, car(proc)); /* proc = cadr(args) */ + hash_table_set_procedures_mapper(table, cdr(proc)); + return(table); + } + if (proc != sc->F) + wrong_type_error_nr(sc, caller, 2, proc, wrap_string(sc, "either #f or (cons equality-func map-func)", 42)); + return(table); + }}} + return(s7_make_hash_table(sc, size)); } -static s7_pointer -bind_symbol_with_setter (s7_scheme* sc, opcode_t op, s7_pointer symbol, - s7_pointer new_value) { - const s7_pointer func= setter_p_pp (sc, symbol, sc->curlet); - if (is_c_function (func)) - return (call_c_function_setter (sc, func, symbol, new_value)); - if (!is_any_procedure (func)) return (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 */ -} +/* g_make_hash_table is now defined in s7_liii_hash_table.c */ -/* -------------------------------- 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 */ -} +/* -------------------------------- make-weak-hash-table -------------------------------- */ +#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)) +/* g_make_weak_hash_table is now defined in s7_liii_hash_table.c */ -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)))))); +const char *hash_table_checker_name(s7_scheme *sc, s7_pointer table) +{ + if (hash_table_checker(table) == hash_equal) return("equal?"); + if (hash_table_checker(table) == hash_equivalent) return("equivalent?"); + if (hash_table_checker(table) == hash_eq) return("eq?"); + if (hash_table_checker(table) == hash_eqv) return("eqv?"); + if (hash_table_checker(table) == hash_string) return("string=?"); +#if !WITH_PURE_S7 + if (hash_table_checker(table) == hash_ci_string) return("string-ci=?"); +#endif + if (hash_table_checker(table) == hash_char) return("char=?"); + if (hash_table_checker(table) == hash_number_num_eq) return("="); + return("#f"); } -/* g_is_eq migrated to s7_scheme_predicate.c */ -#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 - -bool -s7_is_eqv (s7_scheme* sc, s7_pointer x, s7_pointer y) { - if (type (x) != type (y)) return (false); - if ((x == y) && - (!is_number (x))) /* if x is NaN, x == y doesn't mean (eqv? x y) */ - return ( - true); /* x == y means (let ((x "a")) (let ((y x)) (eqv? x y))) is #t */ - if (is_number (x)) return (numbers_are_eqv (sc, x, y)); - if (is_unspecified (x)) - return (true); /* types are the same so we know y is also unspecified */ - return (false); -} -/* g_is_eqv migrated to s7_scheme_predicate.c */ -#define H_is_eqv "(eqv? obj1 obj2) returns #t if obj1 is equivalent to obj2" -#define Q_is_eqv sc->pcl_bt +/* -------------------------------- weak-hash-table? -------------------------------- */ +#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 +/* g_is_weak_hash_table is now defined in s7_liii_hash_table.c */ -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 void init_hash_maps(void) +{ + for (int32_t 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; + 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_COMPLEX_VECTOR] = hash_map_complex_vector; + default_hash_map[T_LET] = hash_map_let; + default_hash_map[T_PAIR] = hash_map_pair; + default_hash_map[T_C_POINTER] = hash_map_c_pointer; + default_hash_map[T_UNDEFINED] = hash_map_undefined; + default_hash_map[T_ITERATOR] = hash_map_iterator; + for (int32_t i = T_OUTPUT_PORT; i < NUM_TYPES; i++) + default_hash_map[i] = hash_map_eq; + + 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; + 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; + + for (int32_t 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) +{ + const s7_int entries = hash_table_entries(table); + hash_entry_t **old_els = hash_table_elements(table); + const s7_pointer dproc = hash_table_procedures(table); /* new block_t so we need to pass this across */ + const s7_uint old_size = hash_table_size(table); + const s7_uint new_size = old_size * 4; /* perhaps (old_size < 524288) ? (old_size * 4) : (old_size * 2) */ + const s7_uint hash_mask = new_size - 1; + block_t *new_block = (block_t *)callocate(sc, new_size * sizeof(hash_entry_t *)); + hash_entry_t **new_els = (hash_entry_t **)(block_data(new_block)); + hash_table_mask(table) = hash_mask; /* was new_size - 1 14-Jun-21 */ + for (s7_uint i = 0; i < old_size; i++) + { + hash_entry_t *next; + for (hash_entry_t *entry = old_els[i]; entry; entry = next) + { + s7_uint loc = hash_loc(sc, table, hash_entry_key(entry)); + hash_entry_set_raw_hash(entry, loc); + loc %= hash_mask; + next = hash_entry_next(entry); + hash_entry_next(entry) = new_els[loc]; + new_els[loc] = entry; + }} + liberate(sc, hash_table_block(table)); + hash_table_set_block(table, new_block); + hash_table_elements(table) = new_els; + 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 bool -floats_are_equivalent (s7_scheme* sc, s7_double x, s7_double y) { - s7_double diff; - if (x == y) return (true); - diff= fabs (x - y); - if (diff <= sc->equivalent_float_epsilon) return (true); - return ((is_NaN (x)) && (is_NaN (y))); -} - -static bool -eq_equal (s7_scheme* sc, s7_pointer x, s7_pointer y, shared_info_t* unused_ci) { - return (x == y); -} - -static bool -symbol_equivalent (s7_scheme* sc, s7_pointer x, s7_pointer y, - shared_info_t* ci) /* symbol equal uses eq -- should it check - keywords as below? */ -{ - if (x == y) return (true); - if (!is_symbol (y)) return (false); - if (is_keyword (y)) - return ((is_keyword (x)) && - (keyword_symbol (x) == - keyword_symbol (y))); /* (equivalent? key: :key) -> #t */ - if (is_keyword (x)) return (false); - return ( - (is_slot (global_slot (x))) && /* the optimizer can replace the original - symbol with its value */ - (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) { - return ((x == y) || - ((is_undefined (y)) && - (undefined_name_length (x) == undefined_name_length (y)) && - (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= clear_shared_info (sc->circle_info); - 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= clear_shared_info (sc->circle_info); - 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= clear_shared_info (sc->circle_info); - 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= clear_shared_info (sc->circle_info); - 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: - if (!local_strncmp ((const char*) port_filename (x), - (const char*) port_filename (y), - port_filename_length (x))) - return (false); - if (is_input_port (x)) return (port_position (x) == port_position (y)); -#if MS_WINDOWS - return (false); -#else - return (ftell (port_file (x)) == ftell (port_file (y))); -#endif - 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); +#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) +/* g_hash_table_ref is now defined in s7_liii_hash_table.c */ +/* g_hash_table_ref_2 is now defined in s7_liii_hash_table.c */ + +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), sc->type_names[T_HASH_TABLE], 1)); + return(hash_entry_value((*hash_table_checker(table))(sc, table, key))); } -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 bool op_implicit_hash_table_ref_a(s7_scheme *sc) +{ + s7_pointer table = lookup_checked(sc, car(sc->code)); + if (!is_hash_table(table)) {sc->last_function = table; return(false);} + sc->value = s7_hash_table_ref(sc, table, fx_call(sc, cdr(sc->code))); + return(true); } -static Inline bool -inline_equal_ref (s7_scheme* sc, s7_pointer x, s7_pointer y, - shared_info_t* ci) /* pair_equal:lg/list/io, [read] */ +static s7_pointer fx_implicit_hash_table_ref_a(s7_scheme *sc, s7_pointer arg) { - /* here we know x and y are pointers to the same type of structure */ - int32_t ref_y= (is_collected (y)) ? peek_shared_ref_1 (ci, y) : 0; - if (is_collected (x)) { - int32_t 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); + s7_pointer table = lookup_checked(sc, car(arg)); + if (!is_hash_table(table)) + return(s7_apply_function(sc, table, list_1(sc, fx_call(sc, cdr(arg))))); + return(s7_hash_table_ref(sc, table, fx_call(sc, cdr(arg)))); } -static bool -equal_ref (s7_scheme* sc, s7_pointer x, s7_pointer y, shared_info_t* ci) { - return (inline_equal_ref (sc, x, y, ci)); +static bool op_implicit_hash_table_ref_aa(s7_scheme *sc) +{ + s7_pointer in_obj, out_key; + const s7_pointer table = lookup_checked(sc, car(sc->code)); + if (!is_hash_table(table)) {sc->last_function = table; return(false);} + out_key = fx_call(sc, cdr(sc->code)); + in_obj = s7_hash_table_ref(sc, table, out_key); + if (is_hash_table(in_obj)) + sc->value = s7_hash_table_ref(sc, in_obj, fx_call(sc, cddr(sc->code))); + else sc->value = implicit_pair_index_checked(sc, table, in_obj, set_plist_2(sc, out_key, fx_call(sc, cddr(sc->code)))); /* -> implicit_index */ + return(true); +} + +static s7_pointer hash_table_ref_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + if (args == 2) + { + s7_pointer key = caddr(expr); + if ((is_pair(key)) && (car(key) == sc->substring_symbol) && (is_global(sc->substring_symbol))) + set_class_and_fn_proc(key, sc->substring_uncopied); + return(sc->hash_table_ref_2); + } + return(func); } -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; - 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_clist_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))); +/* -------------------------------- hash-table-set! -------------------------------- */ +static s7_pointer remove_from_hash_table(s7_scheme *sc, s7_pointer table, const hash_entry_t *p) +{ + hash_entry_t *entry; + s7_uint loc; + + if (p == sc->unentry) return(missing_key_value(sc)); + loc = hash_entry_raw_hash(p) % hash_table_mask(table); + entry = hash_table_element(table, loc); + if (entry == p) + hash_table_element(table, loc) = hash_entry_next(entry); + else + { + hash_entry_t *y; + for (y = entry, entry = hash_entry_next(entry); entry; y = entry, entry = hash_entry_next(entry)) + if (entry == p) + { + hash_entry_next(y) = hash_entry_next(entry); + break; + }} + hash_table_entries(table)--; + if ((hash_table_entries(table) == 0) && + (hash_table_mapper(table) == default_hash_map)) + { + hash_table_checker(table) = hash_empty; + hash_clear_chosen(table); + } + liberate_block(sc, entry); + return(sc->F); +} - 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= clear_shared_info (sc->circle_info); - { - s7_pointer pa= to_list (sc, set_plist_1 (sc, a)); - s7_pointer pb= to_list (sc, set_plist_1 (sc, b)); - for (; 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 */ - } +static void cull_weak_hash_table(s7_scheme *sc, s7_pointer table) +{ + const s7_int len = (s7_int)hash_table_size(table); + hash_entry_t **entries = hash_table_elements(table); + for (s7_int i = 0; i < len; i++) + { + hash_entry_t *nxp, *lxp = entries[i]; + for (hash_entry_t *entry = entries[i]; entry; entry = nxp) + { + nxp = hash_entry_next(entry); + if (is_free_and_clear(hash_entry_key(entry))) + { + if (entry == entries[i]) + { + entries[i] = nxp; + lxp = nxp; + } + else hash_entry_next(lxp) = nxp; + liberate_block(sc, entry); + hash_table_entries(table)--; + if (hash_table_entries(table) == 0) + { + if (hash_table_mapper(table) == default_hash_map) + { + hash_table_checker(table) = hash_empty; + hash_clear_chosen(table); + } + return; + }} + else lxp = entry; + }} } -#define check_equivalent_method(Sc, X, Y) \ - do { \ - if (has_active_methods (sc, X)) { \ - s7_pointer _Equal_Func_= \ - find_method_with_let (Sc, X, Sc->is_equivalent_symbol); \ - if (_Equal_Func_ != Sc->undefined) \ - return (s7_boolean (Sc, s7_apply_function (Sc, _Equal_Func_, \ - set_plist_2 (Sc, X, Y)))); \ - } \ - } while (0) +static void hash_table_set_default_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 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 len; - shared_info_t* nci= ci; - hash_check_t hash_func; - 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_mapper (x) != default_hash_map) || - (hash_table_mapper (y) != default_hash_map))) { - if (hash_table_checker (x) != hash_table_checker (y)) return (false); - if (hash_table_mapper (x) != hash_table_mapper (y)) return (false); - } +static s7_pointer hash_table_typer_symbol(s7_scheme *sc, s7_pointer typer) +{ + s7_pointer typer_name; + if (typer == sc->T) + return(sc->T); + if (is_c_function(typer)) + return(c_function_symbol(typer)); + typer_name = find_typer(sc, typer); + return((is_symbol(typer_name)) ? typer_name : sc->anon_symbol); +} - len = (s7_int) hash_table_size (x); - lists= hash_table_elements (x); - if (!nci) nci= clear_shared_info (sc->circle_info); - eqf= (equivalent) ? is_equivalent_1 : is_equal_1; - - hash_func= hash_table_checker (y); - if ((hash_func != hash_equal) && (hash_func != hash_equivalent)) { - for (s7_int i= 0; i < len; i++) - for (hash_entry_t* entry= lists[i]; entry; - entry = hash_entry_next (entry)) { - hash_entry_t* y_val= hash_func (sc, y, hash_entry_key (entry)); - if (y_val == sc->unentry) return (false); - if (!eqf (sc, hash_entry_value (entry), hash_entry_value (y_val), nci)) - return (false); +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 */ + { + const s7_pointer typer = hash_table_key_typer(table); + if ((is_c_function(typer)) && ((uint8_t)symbol_type(c_function_symbol(typer)) != type(key))) + { + const char *tstr = make_type_name(sc, hash_table_typer_name(sc, hash_table_key_typer(table)), indefinite_article); + wrong_type_error_nr(sc, wrap_string(sc, "hash-table-set! key", 19), 2, key, wrap_string(sc, tstr, safe_strlen(tstr))); + }} + else + { + const s7_pointer key_func = hash_table_key_typer(table); + if (key_func != sc->T) + { + s7_pointer type_ok; + if (is_c_function(key_func)) + type_ok = c_function_call(key_func)(sc, set_plist_1(sc, key)); + else type_ok = s7_apply_function(sc, key_func, set_plist_1(sc, key)); + if (type_ok == sc->F) + { + const char *descr = hash_table_typer_name(sc, hash_table_key_typer(table)); + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "hash-table-set! key ~$ is rejected by the hash-table's key-typer, ~A", 68), + key, wrap_string(sc, descr, safe_strlen(descr)))); + }}} + if (has_hash_value_type(table)) + { + const s7_pointer typer = hash_table_value_typer(table); + if ((is_c_function(typer)) && ((uint8_t)symbol_type(c_function_symbol(typer)) != type(value))) + { + const char *tstr = make_type_name(sc, hash_table_typer_name(sc, hash_table_value_typer(table)), indefinite_article); + wrong_type_error_nr(sc, sc->hash_table_set_symbol, 3, value, wrap_string(sc, tstr, safe_strlen(tstr))); + }} + else + { + const s7_pointer value_func = hash_table_value_typer(table); + if (value_func != sc->T) + { + s7_pointer type_ok; + if (is_c_function(value_func)) + type_ok = c_function_call(value_func)(sc, set_plist_1(sc, value)); + else type_ok = s7_apply_function(sc, value_func, set_plist_1(sc, value)); + if (type_ok == sc->F) + { + const char *descr = hash_table_typer_name(sc, hash_table_value_typer(table)); + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "hash-table-set! value ~$ is rejected by the hash-table's value-typer, ~A", 72), + value, wrap_string(sc, descr, safe_strlen(descr)))); + }}} +} + +static void check_hash_table_checker(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + /* 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)) + error_nr(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? */ + error_nr(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))); } - /* 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 hash_func? - */ - return (true); - } + else +#if WITH_PURE_S7 + if (((hash_table_checker(table) == hash_string) && (!is_string(key))) || + ((hash_table_checker(table) == hash_char) && (!is_character(key)))) + error_nr(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) && + (!is_character(key)))) + error_nr(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_ci_string) ? sc->string_eq_symbol : + ((hash_table_checker(table) == hash_char) ? sc->char_eq_symbol : sc->string_eq_symbol)))); +#endif +} - /* 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 (s7_int i= 0; i < len; i++) - for (hash_entry_t* p= lists[i]; p; - p = hash_entry_next (p)) /* entry declared below */ - { - const s7_pointer key = hash_entry_key (p); - const s7_uint hash= hash_loc (sc, y, key); - const s7_uint loc = hash % hash_table_mask (y); - hash_entry_t* entry; - - for (entry= hash_table_element (y, loc); entry; - entry= hash_entry_next (entry)) - if ((hash_entry_raw_hash (entry) == hash) && - (eqf (sc, hash_entry_key (entry), key, nci))) - break; - if (!entry) return (false); - if (!eqf (sc, hash_entry_value (p), hash_entry_value (entry), 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 x_slot, s7_pointer y_let, - shared_info_t* nci) { - for (s7_pointer e= y_let; e; e= let_outlet (e)) - for (s7_pointer y_slot= let_slots (e); is_not_slot_end (y_slot); - y_slot = next_slot (y_slot)) - if (slot_symbol (x_slot) == - slot_symbol (y_slot)) /* we know something will match */ - return (is_equal_1 (sc, slot_value (x_slot), slot_value (y_slot), nci)); - return (false); -} - -static bool -slots_equivalent_match (s7_scheme* sc, s7_pointer x_slot, s7_pointer y_let, - shared_info_t* nci) { - for (s7_pointer e= y_let; e; e= let_outlet (e)) - for (s7_pointer y_slot= let_slots (e); is_not_slot_end (y_slot); - y_slot = next_slot (y_slot)) - if (slot_symbol (x_slot) == - slot_symbol (y_slot)) /* we know something will match */ - return (is_equivalent_1 (sc, slot_value (x_slot), slot_value (y_slot), - nci)); - return (false); -} - -static bool -let_equal_1 (s7_scheme* sc, s7_pointer x_let, s7_pointer y_let, - shared_info_t* ci, bool equivalent) { - int32_t x_len, y_len; +s7_pointer s7_hash_table_set(s7_scheme *sc, s7_pointer table, s7_pointer key, s7_pointer value) +{ + hash_entry_t *entry; - if ((!is_let (y_let)) || (x_let == sc->rootlet) || - (y_let == sc->rootlet)) /* (equal? (rootlet) (rootlet)) is checked in - let_equal below */ - return (false); - - if ((ci) && (equal_ref (sc, x_let, y_let, ci))) return (true); - - clear_small_symbol_set ( - sc); /* not begin, slots_match below calls equal_1 -> let_equal_1 */ - x_len= 0; - for (s7_pointer e= x_let; e; e= let_outlet (e)) - for (s7_pointer slot= let_slots (e); is_not_slot_end (slot); - slot = next_slot (slot)) - if (!symbol_is_in_small_symbol_set (sc, slot_symbol (slot))) { - add_symbol_to_small_symbol_set (sc, slot_symbol (slot)); - x_len++; - } + if (value == missing_key_value(sc)) /* normally #f */ + return(remove_from_hash_table(sc, table, (*hash_table_checker(table))(sc, table, key))); + if ((is_typed_hash_table(table)) && (sc->safety >= no_safety)) /* this order is faster */ + check_hash_types(sc, table, key, value); - for (s7_pointer e= y_let; e; e= let_outlet (e)) - for (s7_pointer slot= let_slots (e); is_not_slot_end (slot); - slot = next_slot (slot)) - if (!symbol_is_in_small_symbol_set ( - sc, slot_symbol (slot))) /* symbol in y, not in x */ - return (false); - y_len= 0; - for (s7_pointer e= y_let; e; e= let_outlet (e)) - for (s7_pointer slot= let_slots (e); is_not_slot_end (slot); - slot = next_slot (slot)) - if (small_symbol_tag (slot_symbol (slot)) != 0) { - y_len++; - set_small_symbol_tag (slot_symbol (slot), 0); - } - if (x_len != y_len) /* symbol in x, not in y */ - return (false); + entry = (*hash_table_checker(table))(sc, table, key); + if (entry != sc->unentry) + { + hash_entry_set_value(entry, T_Ext(value)); + return(value); + } + /* hash_entry_raw_hash(entry) 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_default_checker(table, type(key)); /* raw_hash value (hash_loc(sc, table, key)) does not change via hash_table_set_default_checker etc */ + else + if (sc->safety > no_safety) + check_hash_table_checker(sc, table, key); { - shared_info_t* nci= ci; - if (!nci) nci= clear_shared_info (sc->circle_info); - for (s7_pointer e= x_let; e; e= let_outlet (e)) - for (s7_pointer slot= let_slots (e); is_not_slot_end (slot); - slot = next_slot (slot)) - if (small_symbol_tag (slot_symbol (slot)) == 0) /* unshadowed */ - { - set_small_symbol_tag (slot_symbol (slot), - sc->small_symbol_tag); /* values don't match */ - if (((!equivalent) && (!slots_match (sc, slot, y_let, nci))) || - ((equivalent) && - (!slots_equivalent_match (sc, slot, y_let, nci)))) - return (false); - } - } - return (true); -} + s7_uint hash_mask, loc; + entry = mallocate_block(sc); +#if S7_DEBUGGING + sc->blocks_mallocated[BLOCK_LIST]++; +#endif + hash_entry_key(entry) = key; + hash_entry_set_value(entry, T_Ext(value)); + hash_entry_set_raw_hash(entry, hash_loc(sc, table, key)); + hash_mask = hash_table_mask(table); + loc = hash_entry_raw_hash(entry) % hash_mask; + hash_entry_next(entry) = hash_table_element(table, loc); + hash_table_element(table, loc) = entry; + hash_table_entries(table)++; + if (hash_table_entries(table) > hash_mask) + resize_hash_table(sc, table); + } + return(value); +} + +#define H_hash_table_set "(s7-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) +/* g_hash_table_set is now defined in s7_liii_hash_table.c */ -static bool -let_equal (s7_scheme* sc, s7_pointer x_let, s7_pointer y_let, - shared_info_t* ci) { - /* x_let == y_let if all unshadowed vars match, leaving aside the rootlet, so - * that for any local variable, we get the same value in either x_let or y_let - */ - return ((x_let == y_let) || (let_equal_1 (sc, x_let, y_let, ci, false))); +static s7_pointer hash_table_set_p_ppp(s7_scheme *sc, s7_pointer table, s7_pointer key, s7_pointer value) +{ + if (!is_mutable_hash_table(table)) /* is_hash_table(table) is here */ + return(mutable_method_or_bust_ppp(sc, table, sc->hash_table_set_symbol, table, key, value, sc->type_names[T_HASH_TABLE], 1)); + return(s7_hash_table_set(sc, table, key, value)); } -/* what should these do if there are setters? */ -static bool -let_equivalent (s7_scheme* sc, s7_pointer x_let, s7_pointer y_let, - shared_info_t* ci) { - if (x_let == y_let) return (true); - if (!is_global (sc->is_equivalent_symbol)) { - check_equivalent_method (sc, x_let, y_let); - check_equivalent_method (sc, y_let, x_let); - } - return (let_equal_1 (sc, x_let, y_let, 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= - find_method (sc, closure_let (x), sc->is_equal_symbol); - if (equal_func != sc->undefined) - return (s7_boolean ( - sc, s7_apply_function (sc, 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_pars (x), closure_pars (y), ci)) && - (is_equivalent_1 (sc, closure_body (x), closure_body (y), ci))); -} +static s7_pointer hash_table_set_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + if ((args == 3) && (optimize_op(expr) == HOP_SAFE_C_SSA)) + { + const 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))) + { + const s7_pointer 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)) + { + const 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)) */ + set_optimize_op(expr, HOP_HASH_TABLE_INCREMENT); + }}} + return(func); +} + + +/* -------------------------------- hash-table -------------------------------- */ +static inline s7_pointer hash_table_add(s7_scheme *sc, s7_pointer table, s7_pointer key, s7_pointer value) +{ + const s7_uint hash_mask = hash_table_mask(table); + const s7_uint hash = hash_loc(sc, table, key); + const s7_uint loc = hash % hash_mask; + hash_entry_t *entry; -static bool -pair_equal (s7_scheme* sc, s7_pointer x, s7_pointer y, shared_info_t* ci) { - if (x == y) return (true); - if (!is_pair (y)) return (false); - if (!ci) ci= clear_shared_info (sc->circle_info); - else if (inline_equal_ref (sc, x, y, ci)) return (true); - if (!is_equal_1 (sc, car (x), car (y), ci)) return (false); - { - s7_pointer px, py; - 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 (inline_equal_ref (sc, px, py, ci)) return (true); - } - return ((px == py) || (is_equal_1 (sc, px, py, ci))); - } + if (!hash_chosen(table)) + hash_table_set_default_checker(table, type(key)); /* raw_hash value (hash_loc(sc, table, key)) does not change via hash_table_set_default_checker etc */ + + for (entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if ((hash_entry_raw_hash(entry) == hash) && + (s7_is_equal(sc, hash_entry_key(entry), key))) + return(value); + + entry = mallocate_block(sc); +#if S7_DEBUGGING + sc->blocks_mallocated[BLOCK_LIST]++; +#endif + hash_entry_key(entry) = key; + hash_entry_set_value(entry, T_Ext(value)); + hash_entry_set_raw_hash(entry, hash); + hash_entry_next(entry) = hash_table_element(table, loc); + hash_table_element(table, loc) = entry; + hash_table_entries(table)++; + if (hash_table_entries(table) > hash_mask) + resize_hash_table(sc, table); + return(value); +} + +s7_pointer s7i_hash_table_add(s7_scheme *sc, s7_pointer table, s7_pointer key, s7_pointer value) +{ + return(hash_table_add(sc, table, key, value)); } -static bool -pair_equivalent (s7_scheme* sc, s7_pointer x, s7_pointer y, shared_info_t* ci) { - if (x == y) return (true); - if (!is_pair (y)) { - check_equivalent_method (sc, y, x); - return (false); - } - if (!ci) ci= clear_shared_info (sc->circle_info); - else if (inline_equal_ref (sc, x, y, ci)) return (true); - if (!is_equivalent_1 (sc, car (x), car (y), ci)) return (false); +s7_pointer s7i_hash_table_1(s7_scheme *sc, s7_pointer args, s7_pointer caller) +{ + s7_int len = proper_list_length(args); + if (len & 1) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, wrap_string(sc, "~A got an odd number of arguments: ~S", 37), caller, args)); + len /= 2; + if (len > sc->max_vector_length) + error_nr(sc, sc->out_of_range_symbol, + set_elist_4(sc, wrap_string(sc, "~S passed too many entries (> ~D ~D) (*s7* 'max-vector-length)", 62), + caller, wrap_integer(sc, len), wrap_integer(sc, sc->max_vector_length))); { - s7_pointer px, py; - 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 (inline_equal_ref (sc, px, py, ci)) return (true); - } - return ((px == py) || ((is_equivalent_1 (sc, px, py, ci)))); + s7_pointer table = s7_make_hash_table(sc, (len > sc->default_hash_table_length) ? len : sc->default_hash_table_length); + if (len > 0) + for (s7_pointer x = args, y = cdr(args); is_pair(x); x = cddr(x), y = cdr_unchecked(cdr(y))) + if (car(y) != missing_key_value(sc)) + hash_table_add(sc, table, car(x), car(y)); + return(table); } } -static bool -vector_rank_match (s7_scheme* sc, s7_pointer x, s7_pointer y) { - s7_int x_dims; - 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 (s7_int j= 0; j < x_dims; j++) - if (vector_dimension (x, j) != vector_dimension (y, j)) return (false); - return (true); +#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) +/* g_hash_table is now defined in s7_liii_hash_table.c */ +/* g_hash_table_2 is now defined in s7_liii_hash_table.c */ + +/* -------------------------------- weak-hash-table -------------------------------- */ +#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 +/* g_weak_hash_table is now defined in s7_liii_hash_table.c */ + +static s7_pointer hash_table_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr) +{ + return((args == 2) ? sc->hash_table_2 : func); } -static bool -iv_equivalent (const s7_int* ex, const 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) { - const s7_int len= vector_length (x); - const uint8_t* xp = byte_vector_bytes (x); - const uint8_t* yp = byte_vector_bytes (y); - for (s7_int i= 0; i < len; i++) - if (xp[i] != yp[i]) return (false); - return (true); -} - -static bool -biv_equivalent (s7_pointer x, s7_pointer y) { - const s7_int len= vector_length (x); - const uint8_t* xp = byte_vector_bytes (x); - const s7_int* yp = int_vector_ints (y); - for (s7_int i= 0; i < len; i++) - if ((s7_int) (xp[i]) != yp[i]) return (false); - return (true); -} - -static bool -fv_equivalent (s7_scheme* sc, s7_pointer x, s7_pointer y, s7_int len) { - const s7_double *arr1= float_vector_floats (x), - *arr2= float_vector_floats (y); - const s7_double fudge= sc->equivalent_float_epsilon; - if (fudge == 0.0) { - for (s7_int i= 0; i < len; i++) - if ((arr1[i] != arr2[i]) && ((!is_NaN (arr1[i])) || (!is_NaN (arr2[i])))) - return (false); - } - else if ((len & 0x3) == 0) - for (s7_int i= 0; i < len;) - LOOP_4 (if (!floats_are_equivalent (sc, arr1[i], arr2[i])) return (false); - i++); - else - for (s7_int i= 0; i < len; i++) - if (!floats_are_equivalent (sc, arr1[i], arr2[i])) return (false); - return (true); +static void check_old_table(s7_scheme *sc, s7_pointer old_table, s7_pointer new_table, s7_int start, s7_int end) +{ + const s7_int old_len = (s7_int)hash_table_size(old_table); + hash_entry_t **old_lists = hash_table_elements(old_table); + for (s7_int i = 0, count = 0; i < old_len; i++) + for (hash_entry_t *entry = old_lists[i]; entry; entry = hash_entry_next(entry)) + { + if (count >= end) + return; + if (count >= start) + check_hash_types(sc, new_table, hash_entry_key(entry), hash_entry_value(entry)); + } } -static bool -cv_equivalent (s7_scheme* sc, s7_pointer x, s7_pointer y, s7_int len) { - const s7_complex *arr1= complex_vector_complexes (x), - *arr2= complex_vector_complexes (y); - const s7_double fudge = sc->equivalent_float_epsilon; - if (fudge == 0.0) { - for (s7_int i= 0; i < len; i++) - if (((creal (arr1[i]) != creal (arr2[i])) || - (cimag (arr1[i]) != cimag (arr2[i]))) && - ((!is_NaN (creal (arr1[i]))) || (!is_NaN (creal (arr2[i]))) || - (!is_NaN (cimag (arr1[i]))) || (!is_NaN (cimag (arr2[i]))))) - return (false); - } - else if ((len & 0x3) == 0) - for (s7_int i= 0; i < len;) - LOOP_4 ( - if ((!floats_are_equivalent (sc, creal (arr1[i]), creal (arr2[i]))) || - (!floats_are_equivalent (sc, cimag (arr1[i]), - cimag (arr2[i])))) return (false); - i++); - else - for (s7_int i= 0; i < len; i++) - if ((!floats_are_equivalent (sc, creal (arr1[i]), creal (arr2[i]))) || - (!floats_are_equivalent (sc, cimag (arr1[i]), cimag (arr2[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 s7_pointer hash_table_copy(s7_scheme *sc, s7_pointer old_table, s7_pointer new_table, s7_int start, s7_int end) +{ + const s7_uint old_len = hash_table_size(old_table); + const s7_uint new_mask = hash_table_mask(new_table); + s7_int count = 0; + hash_entry_t **old_lists, **new_lists; -static bool -vector_equal (s7_scheme* sc, s7_pointer x, s7_pointer y, shared_info_t* ci) { - s7_int len; - shared_info_t* nci= ci; - - if (!is_any_vector (y)) return (false); - base_vector_equal (sc, x, y); /* sets len */ - if (type (x) != type (y)) { - if ((is_int_vector (x)) && (is_byte_vector (y))) - return (biv_equivalent (y, x)); - if ((is_byte_vector (x)) && (is_int_vector (y))) - return (biv_equivalent (x, y)); - for (s7_int 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= clear_shared_info (sc->circle_info); - } - /* splitting out the typed_vector_typer case is only slightly faster (5% and - * much trickier) */ - for (s7_int i= 0; i < len; i++) - if (!is_equal_1 (sc, vector_element (x, i), vector_element (y, i), nci)) - return (false); - return (true); -} + if (is_typed_hash_table(new_table)) + check_old_table(sc, old_table, new_table, start, end); -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)); -} + old_lists = hash_table_elements(old_table); + new_lists = hash_table_elements(new_table); -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_equivalent (int_vector_ints (x), int_vector_ints (y), len)); -} + if (hash_table_entries(new_table) == 0) + { + if ((start == 0) && + ((s7_uint)end >= hash_table_entries(old_table))) + { + if (old_len == hash_table_size(new_table)) + { + for (s7_uint i = 0; i < old_len; i++) + for (hash_entry_t *entry = old_lists[i]; entry; entry = hash_entry_next(entry)) + { + hash_entry_t *p = (hash_entry_t *)mallocate_block(sc); +#if S7_DEBUGGING + sc->blocks_mallocated[BLOCK_LIST]++; +#endif + memcpy((void *)p, (const void *)entry, sizeof(block_t)); + hash_entry_next(p) = new_lists[i]; + new_lists[i] = p; + }} + else + for (s7_uint i = 0; i < old_len; i++) + for (hash_entry_t *entry = old_lists[i]; entry; entry = hash_entry_next(entry)) + { + s7_uint loc = hash_entry_raw_hash(entry) % new_mask; + hash_entry_t *p = make_hash_entry(sc, hash_entry_key(entry), hash_entry_value(entry), hash_entry_raw_hash(entry)); + hash_entry_next(p) = new_lists[loc]; + new_lists[loc] = p; + } + hash_table_entries(new_table) = hash_table_entries(old_table); + return(new_table); + } + for (s7_uint i = 0; i < old_len; i++) + for (hash_entry_t *entry = old_lists[i]; entry; entry = hash_entry_next(entry)) + { + if (count >= end) + { + hash_table_entries(new_table) = end - start; + return(new_table); + } + if (count >= start) + { + s7_uint loc = hash_entry_raw_hash(entry) % new_mask; + hash_entry_t *p = make_hash_entry(sc, hash_entry_key(entry), hash_entry_value(entry), hash_entry_raw_hash(entry)); + hash_entry_next(p) = new_lists[loc]; + new_lists[loc] = p; + } + count++; + } + hash_table_entries(new_table) = count - start; + return(new_table); + } + /* this can't be optimized much because we have to look for key matches (we're copying old_table into the existing, non-empty new_table) */ + for (s7_uint i = 0; i < old_len; i++) + for (hash_entry_t *entry = old_lists[i]; entry; entry = hash_entry_next(entry)) + { + if (count >= end) + return(new_table); + if (count >= start) + { + hash_entry_t *y = (*hash_table_checker(new_table))(sc, new_table, hash_entry_key(entry)); + if (y != sc->unentry) + hash_entry_set_value(y, hash_entry_value(entry)); + else + { + const s7_uint loc = hash_entry_raw_hash(entry) % new_mask; + hash_entry_t *p = make_hash_entry(sc, hash_entry_key(entry), hash_entry_value(entry), hash_entry_raw_hash(entry)); + hash_entry_next(p) = new_lists[loc]; + new_lists[loc] = p; + hash_table_entries(new_table)++; + if (!hash_chosen(new_table)) + hash_table_set_default_checker(new_table, type(hash_entry_key(entry))); + }} + count++; + } + return(new_table); +} + +static s7_pointer hash_table_fill(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer table = car(args), val = cadr(args); + if (is_immutable_hash_table(table)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->fill_symbol, table)); -static bool -float_vector_equal (s7_scheme* sc, s7_pointer x, s7_pointer y, - shared_info_t* ci) { - s7_int len; - if (!is_float_vector (y)) return (vector_equal (sc, x, y, ci)); - base_vector_equal (sc, x, y); - for (s7_int i= 0; i < len; i++) - if (float_vector (x, i) != float_vector (y, i)) return (false); - return (true); + if (hash_table_entries(table) > 0) + { + hash_entry_t **entries = hash_table_elements(table); + const s7_int len = (s7_int)hash_table_size(table); /* minimum len is 2 (see s7_make_hash_table) */ + if (val == missing_key_value(sc)) /* hash-table-ref returns #f (the default) if it can't find a key, so val == #f here means empty the table */ + { + hash_entry_t **hp = entries; + hash_entry_t **hn = (hash_entry_t **)(hp + len); + for (; hp < hn; hp++) + { + if (*hp) + { + /* save top of entry list, go to end, point end->next at block_list top, reset top to entry_list top -> liberate entire list */ + hash_entry_t *entry = *hp; +#if S7_DEBUGGING + sc->blocks_freed[BLOCK_LIST]++; + while (hash_entry_next(entry)) {entry = hash_entry_next(entry); sc->blocks_freed[BLOCK_LIST]++;} +#else + while (hash_entry_next(entry)) entry = hash_entry_next(entry); +#endif + hash_entry_next(entry) = sc->block_lists[BLOCK_LIST]; + sc->block_lists[BLOCK_LIST] = *hp; + } + hp++; + if (*hp) + { + hash_entry_t *entry = *hp; +#if S7_DEBUGGING + sc->blocks_freed[BLOCK_LIST]++; + while (hash_entry_next(entry)) {entry = hash_entry_next(entry); sc->blocks_freed[BLOCK_LIST]++;} +#else + while (hash_entry_next(entry)) entry = hash_entry_next(entry); +#endif + hash_entry_next(entry) = 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_mapper(table) == default_hash_map) + { + hash_table_checker(table) = hash_empty; + hash_clear_chosen(table); + } + hash_table_entries(table) = 0; + return(val); + } + 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)))) + { + const char *tstr = make_type_name(sc, hash_table_typer_name(sc, hash_table_value_typer(table)), indefinite_article); + wrong_type_error_nr(sc, sc->fill_symbol, 2, val, wrap_string(sc, tstr, safe_strlen(tstr))); + } + for (s7_int i = 0; i < len; i++) + for (hash_entry_t *entry = entries[i]; entry; entry = hash_entry_next(entry)) + hash_entry_set_value(entry, val); + /* keys haven't changed, so no need to mess with hash_table_checker */ + } + return(val); } -static bool -complex_vector_equal (s7_scheme* sc, s7_pointer x, s7_pointer y, - shared_info_t* ci) { - s7_int len; - if (!is_complex_vector (y)) return (vector_equal (sc, x, y, ci)); - base_vector_equal (sc, x, y); - for (s7_int i= 0; i < len; i++) - if (complex_vector (x, i) != complex_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 len; - 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); /* different from vector_equal, (equal? (make-vector '(0 1)) - (make-vector '(1 0))): #f, but #t if equivalent? */ - if (!vector_rank_match (sc, x, y)) return (false); +static s7_pointer hash_table_reverse(s7_scheme *sc, s7_pointer old_table) +{ + const s7_int len = (s7_int)hash_table_size(old_table); + hash_entry_t **old_lists = hash_table_elements(old_table); + const s7_pointer new_table = s7_make_hash_table(sc, len); + gc_protect_via_stack(sc, new_table); - 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_equivalent (y, x)); - if ((is_byte_vector (x)) && (is_int_vector (y))) - return (biv_equivalent (x, y)); - for (s7_int 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)) return (fv_equivalent (sc, x, y, len)); - if (is_int_vector (x)) - return (iv_equivalent (int_vector_ints (x), int_vector_ints (y), len)); - if (is_byte_vector (x)) return (byte_vector_equal_1 (sc, x, y)); - if (is_complex_vector (x)) return (cv_equivalent (sc, x, y, len)); - { - shared_info_t* nci= ci; - if (!has_simple_elements (x)) { - if (ci) { - if (equal_ref (sc, x, y, ci)) return (true); - } - else nci= clear_shared_info (sc->circle_info); + /* old_table checker/mapper functions don't always make sense reversed, although the key/value typers might be ok */ + for (s7_int i = 0; i < len; i++) + for (hash_entry_t *entry = old_lists[i]; entry; entry = hash_entry_next(entry)) + s7_hash_table_set(sc, new_table, hash_entry_value(entry), hash_entry_key(entry)); + + if (is_weak_hash_table(old_table)) /* 17-May-23, not sure it makes sense to reverse a weak-hash-table but... */ + { + set_weak_hash_table(new_table); + weak_hash_iters(new_table) = 0; } - for (s7_int i= 0; i < len; i++) - if (!is_equivalent_1 (sc, vector_element (x, i), vector_element (y, i), - nci)) - return (false); - } - return (true); + unstack_gc_protect(sc); + return(new_table); } -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; - 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: - case T_COMPLEX_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_t_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)) - : ((is_byte_vector (x_seq)) - ? (byte_vector_equal (sc, x_seq, y_seq, - ci)) - : (complex_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); - { - s7_pointer xs, ys; - 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 (x_seq == sc->rootlet) { - if (y_seq != sc->rootlet) return (false); - return (iterator_position (x) == iterator_position (y)); - } - if (x_seq == sc->starlet) { - if (y_seq != sc->starlet) return (false); - return (iterator_position (x) == iterator_position (y)); - } - 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); - - /* let_iterator_slot will be NULL at end */ - if (is_slot_end (let_iterator_slot (x))) - return (is_slot_end (let_iterator_slot (y))); - if (is_slot_end (let_iterator_slot (y))) - return (false); /* not needed but seems clearer */ - { - s7_pointer xs, ys; - for (xs= let_slots (x_seq), ys= let_slots (y_seq); - is_not_slot_end (xs) && is_not_slot_end (ys); - xs= next_slot (xs), ys= next_slot (ys)) - if (xs == let_iterator_slot (x)) return (ys == let_iterator_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); -} +/* -------------------------------- functions -------------------------------- */ +bool s7_is_function(s7_pointer p) {return(is_c_function(p));} -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)); +static s7_pointer fallback_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) {return(func);} + +static void s7_function_set_class(s7_scheme *sc, s7_pointer func, s7_pointer base_f) +{ + c_function_class(func) = c_function_class(base_f); + c_function_set_base(func, base_f); } -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)); - return (false); +static c_proc_t *alloc_semipermanent_function(s7_scheme *sc) +{ + #define ALLOC_FUNCTION_SIZE 256 + 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; + } +#if S7_DEBUGGING + sc->c_functions_allocated++; /* this probably is the same as sc->f_class (c_function_class) */ +#endif + return(&(sc->alloc_function_cells[sc->alloc_function_k++])); } -/* 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))); - 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)); - 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))); - return (false); -} - -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), - (s7_double) 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)))); - } - 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), - (s7_double) 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)))); - } - 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), (s7_double) 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)))); - } - 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), (s7_double) 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)))); - } - return (false); +static s7_pointer make_c_function(s7_scheme *sc, const char *name, s7_function f, s7_int req, s7_int opt, bool rst, const char *doc) /* called only in s7_make_function */ +{ + const s7_pointer func = (s7_pointer)alloc_pointer(sc); + set_full_type(func, ((req == 0) && (rst)) ? T_C_RST_NO_REQ_FUNCTION : T_C_FUNCTION); + + c_function_data(func) = alloc_semipermanent_function(sc); + c_function_call(func) = f; /* f is T_App but needs cast */ + c_function_set_base(func, func); + c_function_set_setter(func, sc->F); + if (name) + { + c_function_name(func) = name; /* (procedure-name proc) => (format #f "~A" proc) */ + c_function_name_length(func) = safe_strlen(name); + c_function_set_symbol(func, make_symbol(sc, name, c_function_name_length(func))); /* T_C_FUNCTION_STAR may set later to args */ + } + else + { + c_function_name(func) = NULL; + c_function_name_length(func) = 0; + c_function_set_symbol(func, sc->anon_symbol); + } + c_function_documentation(func) = (doc) ? make_semipermanent_c_string(sc, doc) : NULL; + c_function_set_signature(func, sc->F); + c_function_min_args(func) = req; + c_function_optional_args(func) = opt; /* T_C_FUNCTION_STAR type may be set later, so T_Fst not usable here */ + c_function_max_args(func) = (rst) ? MAX_ARITY : req + opt; + c_function_class(func) = ++sc->f_class; + c_function_chooser(func) = fallback_chooser; + c_function_opt_data(func) = NULL; + c_function_marker(func) = NULL; + c_function_set_let(func, sc->rootlet); + /* this is not the same as the let in (let (...) (lambda ...)) and can't be used that way. The first problem is that in "f" (the s7_function above), + * there is no way to tell which "func" (the current c_function object) caused it to be invoked. The call is of the form (c_function_call(func))(sc, ...). + * Since this usage is very unusual, I don't want to glom up every c_function call with a wrapper that sets/restores the c_function_let. + * The next is that it's easy to call s7_eval_c_string(sc, "(let (...) (lambda ...))" creating a real closure where the let is handled throughout s7. + * The third is that if you're using this style to create generators, use a c-object or iterator to hold the state; the "func" currently is allocated + * in semipermanent memory (see below), so (as throughout c_functions), the assumption is that these are not garbage collected. c_function_let is + * for *function* (find_let) primarily. Maybe if let is not rootlet (see below), pass heap memory? But then we need to free the function data. + * Also if the let is local, it needs to be GC protected by the caller. + */ + return(func); } -static bool -random_state_equal (s7_scheme* sc, s7_pointer x, s7_pointer y, - shared_info_t* ci) { - return ((x == y) || - ((is_random_state (y)) && (random_seed (x) == random_seed (y)) && - (random_carry (x) == random_carry (y)))); +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 func = make_c_function(sc, name, f, required_args, optional_args, rest_arg, doc); + unheap(func); + return(func); } -bool -c_function_equal (s7_scheme* sc, s7_pointer x, s7_pointer y, - shared_info_t* ci) { - return ((is_c_function (y)) && (c_function_data (x) == c_function_data (y))); +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 func = s7_make_function(sc, name, f, required_args, optional_args, rest_arg, doc); + set_type_bit(func, T_SAFE_PROCEDURE); + return(func); } -static bool -c_macro_equal (s7_scheme* sc, s7_pointer x, s7_pointer y, shared_info_t* ci) { - return ((is_c_macro (y)) && (c_macro_data (x) == c_macro_data (y))); + +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 = s7_make_function(sc, name, f, required_args, optional_args, rest_arg, doc); + set_type_bit(func, T_SAFE_PROCEDURE); + if (signature) c_function_set_signature(func, signature); + return(func); } -static void -init_equals (void) { - for (int32_t i= 0; i < NUM_TYPES; i++) { - equals[i] = eq_equal; - equivalents[i]= eq_equal; - } - equals[T_BACRO] = closure_equal; - equals[T_BACRO_STAR] = closure_equal; - equals[T_BYTE_VECTOR] = byte_vector_equal; - equals[T_CLOSURE] = closure_equal; - equals[T_CLOSURE_STAR] = closure_equal; - equals[T_COMPLEX] = complex_equal; - equals[T_C_MACRO] = c_macro_equal; - equals[T_C_FUNCTION] = c_function_equal; - equals[T_C_RST_NO_REQ_FUNCTION]= c_function_equal; - equals[T_C_OBJECT] = c_objects_are_equal; - equals[T_C_POINTER] = c_pointer_equal; - equals[T_FLOAT_VECTOR] = float_vector_equal; - equals[T_COMPLEX_VECTOR] = complex_vector_equal; - equals[T_HASH_TABLE] = hash_table_equal; - equals[T_INPUT_PORT] = port_equal; - equals[T_INTEGER] = integer_equal; - equals[T_INT_VECTOR] = int_vector_equal; - equals[T_ITERATOR] = iterator_equal; - equals[T_LET] = let_equal; - equals[T_MACRO] = closure_equal; - equals[T_MACRO_STAR] = closure_equal; - equals[T_OUTPUT_PORT] = port_equal; - equals[T_PAIR] = pair_equal; - equals[T_RANDOM_STATE] = random_state_equal; - equals[T_RATIO] = fraction_equal; - equals[T_REAL] = real_equal; - equals[T_STRING] = string_equal; - equals[T_SYMBOL] = eq_equal; - equals[T_SYNTAX] = syntax_equal; - equals[T_UNDEFINED] = undefined_equal; - equals[T_UNSPECIFIED] = unspecified_equal; - equals[T_VECTOR] = vector_equal; - - equivalents[T_BACRO] = closure_equivalent; - equivalents[T_BACRO_STAR] = closure_equivalent; - equivalents[T_BYTE_VECTOR] = vector_equivalent; - equivalents[T_CLOSURE] = closure_equivalent; - equivalents[T_CLOSURE_STAR] = closure_equivalent; - equivalents[T_COMPLEX] = complex_equivalent; - equivalents[T_C_MACRO] = c_macro_equal; - equivalents[T_C_FUNCTION] = c_function_equal; - equivalents[T_C_RST_NO_REQ_FUNCTION]= c_function_equal; - equivalents[T_C_OBJECT] = c_objects_are_equivalent; - equivalents[T_C_POINTER] = c_pointer_equivalent; - equivalents[T_FLOAT_VECTOR] = vector_equivalent; - equivalents[T_COMPLEX_VECTOR] = vector_equivalent; - equivalents[T_HASH_TABLE] = hash_table_equivalent; - equivalents[T_INPUT_PORT] = port_equivalent; - equivalents[T_INTEGER] = integer_equivalent; - equivalents[T_INT_VECTOR] = vector_equivalent; - equivalents[T_ITERATOR] = iterator_equivalent; - equivalents[T_LET] = let_equivalent; - equivalents[T_MACRO] = closure_equivalent; - equivalents[T_MACRO_STAR] = closure_equivalent; - equivalents[T_OUTPUT_PORT] = port_equivalent; - equivalents[T_PAIR] = pair_equivalent; - equivalents[T_RANDOM_STATE] = random_state_equal; - equivalents[T_RATIO] = fraction_equivalent; - equivalents[T_REAL] = real_equivalent; - equivalents[T_STRING] = string_equal; - equivalents[T_SYMBOL] = symbol_equivalent; - equivalents[T_SYNTAX] = syntax_equal; - equivalents[T_UNDEFINED] = undefined_equal; - equivalents[T_UNSPECIFIED] = unspecified_equal; - equivalents[T_VECTOR] = vector_equivalent; -} - -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)); +s7_pointer s7_make_typed_function_with_environment(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 let) +{ + s7_pointer func = s7_make_typed_function(sc, name, f, required_args, optional_args, rest_arg, doc, signature); + c_function_set_let(func, let); + return(func); } -/* g_is_equal and g_is_equivalent are now in s7_scheme_predicate.c */ -#define H_is_equal "(equal? obj1 obj2) returns #t if obj1 is equal to obj2" -#define Q_is_equal sc->pcl_bt -#define H_is_equivalent \ - "(equivalent? obj1 obj2) returns #t if obj1 is close enough to obj2." -#define Q_is_equivalent sc->pcl_bt -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); -} +/* -------------------------------- procedure? -------------------------------- */ +bool s7_is_procedure(s7_pointer obj) {return(is_procedure(obj));} -/* ---------------------------------------- length, copy, fill - * ---------------------------------------- */ -static s7_pointer s7_length (s7_scheme* sc, - s7_pointer lst); /* why isn't this in s7.h? */ +/* g_is_procedure is now defined in s7_scheme_predicate.c */ +#define H_is_procedure "(procedure? obj) returns #t if obj is a procedure" +#define Q_is_procedure sc->pl_bt -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); -} +#if !DISABLE_DEPRECATED +s7_pointer s7_closure_body(s7_scheme *sc, s7_pointer clo) {return((has_closure_let(clo)) ? closure_body(clo) : sc->nil);} +s7_pointer s7_closure_let(s7_scheme *sc, s7_pointer clo) {return((has_closure_let(clo)) ? closure_let(clo) : sc->rootlet);} +s7_pointer s7_closure_args(s7_scheme *sc, s7_pointer clo) {return((has_closure_let(clo)) ? closure_pars(clo) : sc->nil);} +#endif +s7_pointer s7_lambda_body(s7_scheme *sc, s7_pointer clo) {return((has_closure_let(clo)) ? closure_body(clo) : sc->nil);} +s7_pointer s7_lambda_let(s7_scheme *sc, s7_pointer clo) {return((has_closure_let(clo)) ? closure_let(clo) : sc->rootlet);} +s7_pointer s7_lambda_parameters(s7_scheme *sc, s7_pointer clo) {return((has_closure_let(clo)) ? closure_pars(clo) : sc->nil);} -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); -} -s7_pointer -v_length (s7_scheme* sc, s7_pointer vec) { - return (make_integer (sc, vector_length (vec))); -} -static s7_pointer -str_length (s7_scheme* sc, s7_pointer str) { - return (make_integer (sc, string_length (str))); -} -static s7_pointer -bv_length (s7_scheme* sc, s7_pointer bv) { - return (make_integer (sc, byte_vector_length (bv))); -} -static s7_pointer -h_length (s7_scheme* sc, s7_pointer table) { - return (make_integer (sc, hash_table_size (table))); -} -static s7_pointer -iter_length (s7_scheme* sc, s7_pointer iter) { - return (s7_length (sc, iterator_sequence (iter))); -} -static s7_pointer -rs_length (s7_scheme* sc, s7_pointer rs) { - return (int_two); +/* -------------------------------- procedure-arglist -------------------------------- */ +static s7_pointer g_procedure_arglist(s7_scheme *sc, s7_pointer args) +{ + #define H_procedure_arglist "(procedure-arglist func) returns func's arglist" + #define Q_procedure_arglist s7_make_signature(sc, 2, \ + s7_make_signature(sc, 2, sc->is_list_symbol, sc->is_symbol_symbol), \ + s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol)) + s7_pointer func = car(args); + if (has_closure_let(func)) return(s7_copy(sc, set_plist_1(sc, closure_pars(func)))); /* closure_pars can be a symbol: (define (f1 . a) a) */ + if_method_exists_return_value(sc, func, sc->procedure_arglist_symbol, set_plist_1(sc, func)); + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "procedure-arglist argument, ~S, is not a scheme function", 56), func)); + return(sc->nil); /* never hit */ } -static s7_pointer -c_obj_length (s7_scheme* sc, s7_pointer cobj) { - if (!is_global (sc->length_symbol)) - if_c_object_method_exists_return_value (sc, cobj, sc->length_symbol, - set_plist_1 (sc, cobj)); - return (c_object_length (sc, cobj)); -} -static s7_pointer -let_length_with_method (s7_scheme* sc, s7_pointer let) { - if (!is_global (sc->length_symbol)) - if_let_method_exists_return_value (sc, let, sc->length_symbol, - set_plist_1 (sc, let)); - return (make_integer (sc, let_length (sc, let))); +/* -------------------------------- 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); /* break; ? */ + } + return(sc->lambda_symbol); } -static s7_pointer -fnc_length (s7_scheme* sc, s7_pointer func) { - return ((has_active_methods (sc, func)) - ? make_integer (sc, closure_length (sc, func)) - : sc->F); -} +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 func = car(args); -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 len; - long 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) { - for (int32_t 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_COMPLEX_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] = let_length_with_method; - 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; - length_functions[T_RANDOM_STATE] = rs_length; -} - -static s7_pointer -s7_length (s7_scheme* sc, s7_pointer obj) { - return ((*length_functions[type_unchecked (obj)]) (sc, obj)); -} - -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[type_unchecked (car (args))]) (sc, car (args))); + if ((is_symbol(func)) && ((func = s7_symbol_value(sc, func)) == sc->undefined)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "procedure-source arg, '~S, is unbound", 37), func)); + if ((is_c_function(func)) || (is_c_macro(func))) + return(sc->nil); + + if_method_exists_return_value(sc, func, sc->procedure_source_symbol, set_plist_1(sc, func)); + if (has_closure_let(func)) + { + s7_pointer body = closure_body(func); + /* 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(func)), closure_pars(func)), body)); + } + if (!is_procedure(func)) + sole_arg_wrong_type_error_nr(sc, sc->procedure_source_symbol, func, a_procedure_or_a_macro_string); + return(sc->nil); + /* perhaps include file/line? perhaps some way to return comments in code -- source code as string exactly as in file? */ } -/* -------------------------------- copy -------------------------------- */ -static s7_pointer -string_setter (s7_scheme* sc, s7_pointer str, s7_int loc, s7_pointer chr) { - if (is_character (chr)) { - string_value (str)[loc]= s7_character (chr); - return (chr); + +/* -------------------------------- *current-function* -------------------------------- */ +static s7_pointer let_to_function(s7_scheme *sc, s7_pointer let) +{ + if ((!let) || (let == sc->rootlet) || (!is_let(let))) + return(sc->F); + if (!((is_funclet(let)) || (is_maclet(let)))) + return(sc->F); + if ((has_let_file(let)) && + (let_file(let) <= (s7_int)sc->file_names_top) && + (let_line(let) > 0)) + return(list_3(sc, funclet_function(let), sc->file_names[let_file(let)], make_integer(sc, let_line(let)))); + return(funclet_function(let)); +} + +static s7_pointer g_function(s7_scheme *sc, s7_pointer args) /* does the env parameter make any sense? */ +{ + #define H_function "(*function* let field) returns the current function. (*function*) is like __func__ in C. \ +If 'let is specified, *function* looks for the current function in the environment 'e. If 'field (a symbol) is given \ +a function-specific value is returned. The fields are 'name (the name of the current function), 'signature, 'arity,\ + 'documentation, 'value (the function itself), 'line and 'file (the function's definition location), 'funclet, 'source, \ +and 'arglist. (define (func x y) (*function* (curlet) 'arglist)) (func 1 2): '(x y)" + + #define Q_function s7_make_signature(sc, 3, sc->T, has_let_signature(sc), sc->is_symbol_symbol) + + s7_pointer let, sym = NULL; + if (is_null(args)) /* (*function*) is akin to __func__ in C */ + { + for (let = sc->curlet; let; let = let_outlet(let)) + if ((is_funclet(let)) || (is_maclet(let))) + break; + return(let_to_function(sc, let)); + } + let = car(args); + if (!is_let(let)) + { + s7_pointer new_let = find_let(sc, let); /* ?? not sure this makes sense */ + if (!is_let(new_let)) + find_let_error_nr(sc, sc->_function__symbol, let, new_let, 1, args); + let = new_let; + } + if (is_pair(cdr(args))) + { + sym = cadr(args); + if (!is_symbol(sym)) + wrong_type_error_nr(sc, sc->_function__symbol, 2, sym, sc->type_names[T_SYMBOL]); + } + if (let == sc->rootlet) + return(sc->F); + if (!((is_funclet(let)) || (is_maclet(let)))) + let = let_outlet(let); + if (is_null(cdr(args))) + return(let_to_function(sc, let)); + if ((let == sc->rootlet) || (!is_let(let))) + return(sc->F); + if (!((is_funclet(let)) || (is_maclet(let)))) + return(sc->F); + + if (is_keyword(sym)) + sym = keyword_symbol(sym); + { + s7_pointer fname = funclet_function(let); + s7_pointer fval = s7_symbol_local_value(sc, fname, let); + + 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(let))) return(make_integer(sc, let_line(let))); + if ((sym == sc->file_symbol) && (has_let_file(let))) return(sc->file_names[let_file(let)]); + if (sym == make_symbol(sc, "funclet", 7)) return(let); + if (sym == make_symbol(sc, "source", 6)) return(g_procedure_source(sc, set_plist_1(sc, fval))); + if ((sym == make_symbol(sc, "arglist", 7)) && ((is_any_closure(fval)) || (is_any_macro(fval)))) return(closure_pars(fval)); } - set_car (sc->elist_3, - wrap_string (sc, "~S: ~S is not a character", - 25)); /* cadr (caller) is set in s7_copy_1 */ - set_caddr (sc->elist_3, chr); - error_nr (sc, sc->wrong_type_arg_symbol, sc->elist_3); - return (NULL); + return(sc->F); } -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 */ + +/* -------------------------------- funclet -------------------------------- */ +s7_pointer s7_funclet(s7_scheme *sc, s7_pointer func) {return((has_closure_let(func)) ? closure_let(func) : sc->rootlet);} /* c_function_let(func)?? */ + +/* g_funclet moved to s7_scheme_let.c */ + #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_define_function and friends -------------------------------- + * + * all c_func* are semipermanent, but they might be local: (let () (load "libm.scm" (curlet)) ...) + */ + +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 = s7_make_function(sc, name, fnc, required_args, optional_args, rest_arg, doc); + s7_pointer sym = T_Sym(c_function_symbol(func)); + s7_define(sc, sc->rootlet, sym, func); + return(sym); } -static s7_pointer -c_object_setter (s7_scheme* sc, s7_pointer cobj, s7_int loc, s7_pointer val) { - return ((*(c_object_set (sc, cobj))) ( - sc, with_list_t3 (sc, cobj, wrap_mutable_integer (sc, loc), - val))); /* was make_integer 14-Nov-23 */ +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 = s7_make_safe_function(sc, name, fnc, required_args, optional_args, rest_arg, doc); + s7_pointer sym = T_Sym(c_function_symbol(func)); + s7_define(sc, sc->rootlet, sym, func); + return(sym); } -static s7_pointer -c_object_getter (s7_scheme* sc, s7_pointer cobj, s7_int loc) { - return ((*(c_object_ref (sc, cobj))) ( - sc, set_plist_2 (sc, cobj, - wrap_mutable_integer ( - sc, loc)))); /* was make_integer 14-Nov-23 */ +s7_pointer s7_define_typed_function(s7_scheme *sc, const char *name, s7_function fnc, /* same as above, but include sig */ + 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 = s7_make_typed_function(sc, name, fnc, required_args, optional_args, rest_arg, doc, signature); /* includes "safe" bit */ + s7_pointer sym = T_Sym(c_function_symbol(func)); + s7_define(sc, sc->rootlet, sym, func); + c_function_set_marker(func, NULL); + return(sym); } -static s7_pointer -let_setter (s7_scheme* sc, s7_pointer let, 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 let, its value is changed, otherwise a new slot is - * added to let - */ - 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, let, sym); - if (is_slot (slot)) checked_slot_set_value (sc, slot, cdr (val)); - else add_slot_checked_with_id (sc, let, 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); - error_nr (sc, sc->wrong_type_arg_symbol, sc->elist_3); - return (sc->wrong_type_arg_symbol); -} - -static s7_pointer -hash_table_setter (s7_scheme* sc, s7_pointer table, s7_int loc, - s7_pointer val) { - /* loc is irrelevant here, table is the hash-table, val has to be of the form - * (cons key value) if key is already in table, its value is changed, - * otherwise a new slot is added to table, cadr(elist_3) is caller, set in - * s7_copy_1 - */ - if (!is_pair (val)) { - set_car (sc->elist_3, - wrap_string (sc, "~S: ~S is not (cons key value)", 30)); - set_caddr (sc->elist_3, val); - error_nr (sc, sc->wrong_type_arg_symbol, sc->elist_3); - } - return (s7_hash_table_set (sc, table, car (val), cdr (val))); -} - -static s7_pointer -copy_hash_table (s7_scheme* sc, s7_pointer source) { - const s7_pointer new_table= s7_make_hash_table (sc, hash_table_size (source)); - gc_protect_via_stack (sc, new_table); - hash_table_checker (new_table)= hash_table_checker (source); - if (hash_chosen (source)) hash_set_chosen (new_table); - hash_table_mapper (new_table)= hash_table_mapper (source); - hash_table_set_procedures (new_table, - copy_hash_table_procedures (sc, source)); - hash_table_copy (sc, source, new_table, 0, hash_table_entries (source)); - if (is_typed_hash_table (source)) { - set_is_typed_hash_table (new_table); - if (has_hash_key_type (source)) set_has_hash_key_type (new_table); - if (has_hash_value_type (source)) set_has_hash_value_type (new_table); - if (has_simple_keys (source)) set_has_simple_keys (new_table); - if (has_simple_values (source)) set_has_simple_values (new_table); - } - if (is_weak_hash_table (source)) /* 16-May-23 */ +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) +{ + const s7_pointer func = s7_make_typed_function(sc, name, fnc, 1, optional_args, false, doc, signature); /* includes "safe" bit */ + const s7_pointer sym = T_Sym(c_function_symbol(func)); + s7_define(sc, sc->rootlet, sym, func); + if (sym_to_type != T_FREE) symbol_set_type(sym, sym_to_type); + c_function_set_marker(func, marker); + if (simple) c_function_set_has_simple_elements(func); { - set_weak_hash_table (new_table); - weak_hash_iters (new_table)= 0; + s7_pointer bfunc = s7_make_safe_function(sc, name, bool_setter, 2, 0, false, NULL); + c_function_set_bool_setter(func, bfunc); + c_function_set_has_bool_setter(func); + c_function_set_setter(bfunc, func); + set_is_bool_function(bfunc); } - unstack_gc_protect (sc); - return (new_table); -} - -static s7_pointer -copy_vector (s7_scheme* sc, s7_pointer source) { - const s7_int len= vector_length (source); - s7_pointer vec; - if (!is_typed_vector (source)) return (s7_vector_copy (sc, source)); - if (len == 0) return (make_simple_vector (sc, 0)); - vec= make_vector_1 (sc, len, NOT_FILLED, T_VECTOR); - set_typed_vector (vec); - typed_vector_set_typer (vec, typed_vector_typer (source)); - if (has_simple_elements (source)) set_has_simple_elements (vec); - for (s7_int i= 0; i < len; i++) - vector_element (vec, i)= vector_element (source, i); - if (vector_rank (source) > 1) - return (make_multivector ( - sc, vec, - g_vector_dimensions ( - sc, set_plist_1 (sc, source)))); /* see g_subvector to avoid - g_vector_dimensions */ - add_vector (sc, vec); - return (vec); -} - -static s7_pointer -copy_source_no_dest (s7_scheme* sc, s7_pointer source, - s7_pointer args) /* (copy str) */ + 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) { - s7_pointer dest; - switch (type (source)) { - case T_VECTOR: - return (copy_vector (sc, source)); - case T_PAIR: - return (copy_any_list (sc, source)); /* top level only, as in the other - cases, checks for circles */ - case T_HASH_TABLE: - return ( - copy_hash_table (sc, source)); /* this has to copy nearly everything */ - case T_C_OBJECT: - return (copy_c_object (sc, args)); - case T_RANDOM_STATE: - return (random_state_copy (sc, args)); - case T_ITERATOR: - return (iterator_copy (sc, source)); - - case T_INT_VECTOR: - case T_FLOAT_VECTOR: - case T_BYTE_VECTOR: - case T_COMPLEX_VECTOR: - return (s7_vector_copy (sc, source)); /* "shallow" copy */ - - case T_STRING: - if (string_length (source) == 0) return (nil_string); - return (make_string_with_length (sc, string_value (source), - string_length (source))); - - case T_LET: - if_let_method_exists_return_value (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: - if_method_exists_return_value (sc, source, sc->copy_symbol, args); - return (copy_closure (sc, source)); - - case T_INTEGER: - new_cell (sc, dest, T_INTEGER); - set_integer (dest, integer (source)); - return (dest); - case T_RATIO: - new_cell (sc, dest, T_RATIO); - set_numerator (dest, numerator (source)); - set_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); - - 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); - /* default here it to return the source without comment */ - } - return (source); + /* returns (string->symbol name), not the c_proc_t func */ + s7_pointer func = s7_make_function(sc, name, fnc, required_args, optional_args, rest_arg, doc); + s7_pointer sym = T_Sym(c_function_symbol(func)); + if (signature) c_function_set_signature(func, signature); + s7_define(sc, sc->rootlet, sym, func); + return(sym); } -static s7_pointer -copy_p_p (s7_scheme* sc, s7_pointer source) { - return (copy_source_no_dest (sc, source, set_plist_1 (sc, source))); +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 = s7_make_function(sc, name, fnc, required_args, optional_args, rest_arg, doc); + s7_pointer sym = T_Sym(c_function_symbol(func)); + if (signature) c_function_set_signature(func, signature); + set_is_semisafe(func); + s7_define(sc, sc->rootlet, sym, func); + return(sym); } -static s7_pointer -copy_c_object_to_same_type (s7_scheme* sc, s7_pointer dest, s7_pointer source, - s7_int dest_start, s7_int dest_end, - s7_int source_start) { - s7_pointer (*cref) (s7_scheme* sc, s7_pointer args)= - c_object_ref (sc, source); - s7_pointer (*cset) (s7_scheme* sc, s7_pointer args)= c_object_set (sc, dest); - if ((is_safe_c_function (c_object_getf (sc, source))) && - (is_safe_c_function ( - c_object_setf (sc, dest)))) /* maybe not worth the extra code */ +s7_pointer s7_make_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc) +{ + const s7_int len = safe_strlen(arglist); + s7_pointer local_args; + s7_int gc_loc, n_args; { - s7_pointer mi= wrap_mutable_integer (sc, 0); - s7_pointer mj= wrap_mutable_integer (sc, 0); - set_car (sc->t3_1, dest); - set_car (sc->t3_2, mj); - for (s7_int i= source_start, j= dest_start; i < dest_end; i++, j++) { - set_integer (mi, i); - set_car (sc->t3_3, cref (sc, with_list_t2 (sc, source, mi))); - set_integer (mj, j); - cset (sc, sc->t3_1); + block_t *b = inline_mallocate(sc, len + 4); + char *internal_arglist = (char *)block_data(b); + internal_arglist[0] = '\''; + internal_arglist[1] = '('; + memcpy((void *)(internal_arglist + 2), (const void *)arglist, len); + internal_arglist[len + 2] = ')'; + internal_arglist[len + 3] = '\0'; + 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; } - } - else { - s7_pointer mi = make_mutable_integer (sc, 0); - const s7_int gc_loc1= gc_protect_1 (sc, mi); - s7_pointer mj = make_mutable_integer (sc, 0); - const s7_int gc_loc2= gc_protect_1 (sc, mj); - for (s7_int i= source_start, j= dest_start; i < dest_end; i++, j++) { - set_integer (mi, i); - set_car (sc->t3_3, cref (sc, with_list_t2 (sc, source, mi))); - set_car (sc->t3_1, dest); - set_car (sc->t3_2, mj); - set_integer (mj, j); - cset (sc, sc->t3_1); - } - s7_gc_unprotect_at (sc, gc_loc1); - s7_gc_unprotect_at (sc, gc_loc2); - } - return (dest); -} - -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 */ - const s7_int source_len= dest_end - dest_start; - switch (type (source)) { - case T_PAIR: { - s7_pointer pd= dest, ps= source; - s7_int i; - for (i= 0; i < source_start; i++) - ps= cdr (ps); - for (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); - } + { + const s7_pointer func = s7_make_function(sc, NULL, fnc, 0, n_args, false, doc); /* null name to turn off the c_function_symbol stuff */ + c_function_name(func) = name; /* (procedure-name proc) => (format #f "~A" proc) */ + c_function_name_length(func) = safe_strlen(name); - case T_VECTOR: - if (is_typed_vector (dest)) { - s7_pointer* els= vector_elements (source); - for (s7_int 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_COMPLEX_VECTOR: - memcpy ((void*) ((complex_vector_complexes (dest)) + dest_start), - (void*) ((complex_vector_complexes (source)) + source_start), - source_len * sizeof (s7_complex)); - 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_RANDOM_STATE: - random_seed (dest) = random_seed (source); - random_carry (dest)= random_carry (source); - return (dest); - - case T_C_OBJECT: - return (copy_c_object_to_same_type (sc, dest, source, dest_start, dest_end, - source_start)); - - case T_LET: - return (NULL); - - case T_HASH_TABLE: { - s7_pointer new_table; - gc_protect_via_stack (sc, source); - new_table= hash_table_copy (sc, source, dest, source_start, - source_start + source_len); - unstack_gc_protect (sc); - if ((hash_table_checker (source) != hash_table_checker (dest)) && - (hash_table_mapper (dest) == default_hash_map)) { - if (hash_table_checker (dest) == hash_empty) - hash_table_checker (dest)= hash_table_checker ( - source); /* copy hash_table_procedures also? what about the mapper? - see hash_table_copy */ - else { - hash_table_checker (dest)= hash_equal; - hash_set_chosen (dest); - } - } - return (new_table); + if (n_args > 0) + { + s7_pointer p = local_args; + s7_pointer *names = (s7_pointer *)permalloc(sc, n_args * sizeof(s7_pointer)); + s7_pointer *defaults = (s7_pointer *)permalloc(sc, n_args * sizeof(s7_pointer)); + + set_full_type(func, T_C_FUNCTION_STAR | T_UNHEAP); /* unheap from s7_make_function */ + c_function_call_args(func) = NULL; + c_function_par_names(func) = names; + c_function_arg_defaults(func) = defaults; + c_func_set_simple_defaults(func); /* mark that the defaults need GC protection */ + /* (define* (f :allow-other-keys) 32) -> :allow-other-keys can't be the only parameter: (:allow-other-keys) */ + + for (s7_int i = 0; i < n_args; p = cdr(p), i++) + { + const s7_pointer arg = car(p); + if (arg == sc->allow_other_keys_keyword) + { + 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_max_args(func) = n_args; /* apparently not counting keywords */ + } + else + if (is_pair(arg)) /* there is a default */ + { + names[i] = car(arg); /* key can be passed at runtime as :key or key: so we need both or the symbol */ + defaults[i] = cadr(arg); + remove_from_heap(sc, cadr(arg)); /* ?? this is the default expr */ + 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->rest_keyword) + s7_warn(sc, 256, "%s :rest is not supported in C-side define*: %s\n", name, arglist); + names[i] = arg; + defaults[i] = sc->F; + }}} + else set_full_type(func, T_C_FUNCTION | T_UNHEAP); + s7_gc_unprotect_at(sc, gc_loc); + return(func); } +} - default: - return (dest); - } - return (NULL); -} - -static no_return void -copy_element_error_nr (s7_scheme* sc, s7_pointer caller, s7_int num, - s7_pointer element, int32_t desired_type) { - set_elist_6 ( - sc, wrap_string (sc, "~A ~:D element, ~S, is ~A but should be ~A", 42), - caller, wrap_integer (sc, num), element, type_name_string (sc, element), - sc->type_names[desired_type]); - error_nr (sc, sc->wrong_type_arg_symbol, sc->elist_6); -} - -static no_return void -copy_element_error_with_type_nr (s7_scheme* sc, s7_pointer caller, s7_int num, - s7_pointer element, s7_pointer desired_type) { - set_elist_6 ( - sc, wrap_string (sc, "~A ~:D element, ~S, is ~A but should be ~A", 42), - caller, wrap_integer (sc, num), element, type_name_string (sc, element), - desired_type); - error_nr (sc, sc->wrong_type_arg_symbol, sc->elist_6); -} - -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) - - const s7_pointer source= car (args); - s7_pointer dest; - s7_int 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; +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 = 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) = semipermanent_list(sc, c_function_optional_args(func)); + return(func); +} - if (is_null (cdr (args))) /* (copy obj) */ - return (copy_source_no_dest (sc, source, args)); - dest= T_Ext (cadr (args)); - if ((dest == sc->readable_keyword) && (!is_pair (source))) - error_nr (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->readable_keyword) && - (dest != sc->nil)) /* error_hook copies with cadr(args) :readable, so it's - currently NULL */ - wrong_type_error_nr ( - sc, caller, 2, dest, - wrap_string (sc, "a mutable object", - 16)); /* so this segfaults if not checking for :readable */ - - have_indices= (is_pair (cddr (args))); - if ((source == dest) && (!have_indices)) return (dest); - /* gc_protect_via_stack(sc, args); */ /* why is this problematic? */ - sc->w= args; - - switch (type (source)) { - case T_PAIR: - if (dest == sc->readable_keyword) /* 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... */ - error_nr ( - 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: - case T_COMPLEX_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_RANDOM_STATE: - get= random_state_getter; - end= 2; - break; - - case T_C_OBJECT: - if (c_object_copy (sc, source)) { - s7_pointer new_cobj= (*(c_object_copy (sc, source))) (sc, args); - if (new_cobj == dest) - return (dest); /* this can happen (s7test block_copy) */ - } - if_c_object_method_exists_return_value (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); - if_let_method_exists_return_value (sc, source, sc->copy_symbol, args); - if (source == sc->rootlet) - wrong_type_error_nr ( - sc, caller, 1, source, - wrap_string (sc, "a sequence other than the rootlet", 33)); - if ((!have_indices) && (is_let (dest)) && (dest != sc->starlet)) { - s7_pointer slot; - if (dest == sc->rootlet) /* (copy (inlet 'a 1) (rootlet)) */ - for (slot= let_slots (source); is_not_slot_end (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); is_not_slot_end (slot); - slot= next_slot (slot)) - if ((slot_symbol (slot) != sc->let_ref_fallback_symbol) && - (slot_symbol (slot) != sc->let_set_fallback_symbol)) - add_slot_no_local (sc, dest, slot_symbol (slot), slot_value (slot)); - } - else - /* this copies reversing the order -- if shadowing, this unshadows, tmp - * has in-order copy code, but it's too much effort */ - /* it also ignores possible slot setters */ - for (slot= let_slots (source); is_not_slot_end (slot); - slot= next_slot (slot)) - add_slot_no_local (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: - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_4 (sc, wrap_string (sc, "can't ~S ~S to ~S", 17), - caller, source, dest)); - } +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; + if (safe) + func = s7_make_safe_function_star(sc, name, fnc, arglist, doc); + else func = s7_make_function_star(sc, name, fnc, arglist, doc); + s7_define(sc, sc->rootlet, make_symbol_with_strlen(sc, name), func); /* can't use c_function_symbol here (clobbered by c_function* args) */ + if (signature) c_function_set_signature(func, signature); +} - start= 0; - if (have_indices) { - s7_pointer 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); +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); +} - source_len= end - start; - if (source_len == 0) { - if (!is_sequence (dest)) - wrong_type_error_nr (sc, caller, 2, dest, a_sequence_string); - return (dest); - } +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); +} - switch (type (dest)) { - case T_PAIR: - dest_len= source_len; - break; - - case T_INT_VECTOR: - case T_BYTE_VECTOR: - if (is_float_vector (source)) - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_4 (sc, wrap_string (sc, "can't ~S ~S to ~A", 17), - caller, source, sc->type_names[type (dest)])); - case T_FLOAT_VECTOR: - if (is_complex_vector (source)) - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_4 (sc, wrap_string (sc, "can't ~S ~S to ~A", 17), - caller, source, sc->type_names[type (dest)])); - case T_COMPLEX_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 new_cobj= (*(c_object_copy (sc, dest))) (sc, args); - if (new_cobj == dest) return (dest); - } - set = c_object_setter; - dest_len= c_object_length_to_int (sc, dest); - break; - - case T_LET: - if (dest == sc->rootlet) - wrong_type_error_nr (sc, caller, 2, dest, - wrap_string (sc, "a sequence other rootlet", 24)); - if (dest == sc->starlet) - wrong_type_error_nr (sc, caller, 2, dest, - wrap_string (sc, "a sequence other than *s7*", 26)); - 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); - - case T_RANDOM_STATE: - set = random_state_setter; - dest_len= 2; - break; - - default: - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_4 (sc, wrap_string (sc, "can't ~S ~S to ~S", 17), - caller, source, dest)); - } +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); +} - 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; - } +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 = s7_make_function(sc, name, fnc, required_args, optional_args, rest_arg, doc); + s7_pointer sym = T_Sym(c_function_symbol(func)); + set_full_type(func, T_C_MACRO | T_DONT_EVAL_ARGS | T_UNHEAP); /* s7_make_function includes T_UNHEAP */ + s7_define(sc, sc->rootlet, sym, func); + return(sym); +} - if ((source != dest) && - ((type (source) == type (dest)) || ((is_string_or_byte_vector (source)) && - (is_string_or_byte_vector (dest))))) { - s7_pointer result= - copy_to_same_type (sc, dest, source, 0, source_len, start); - if (result) return (result); - } +s7_pointer s7_define_expansion(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 = s7_make_function(sc, name, fnc, required_args, optional_args, rest_arg, doc); + s7_pointer sym = T_Sym(c_function_symbol(func)); + set_full_type(func, T_C_MACRO | T_EXPANSION | T_DONT_EVAL_ARGS | T_UNHEAP); /* s7_make_function includes T_UNHEAP */ + s7_define(sc, sc->rootlet, sym, func); + set_full_type(sym, full_type(sym) | T_EXPANSION); + return(sym); +} - switch (type (source)) { - case T_PAIR: { - s7_pointer p= source; - if (start > 0) - for (s7_int 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) { - s7_pointer dp= source; - for (s7_int 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 (s7_int i= start, j= 0; i < end; i++, j++, p= cdr (p)) { - if (!is_character (car (p))) - copy_element_error_nr (sc, caller, i + 1, car (p), T_CHARACTER); - dst[j]= character (car (p)); - } + +/* -------------------------------- macro? -------------------------------- */ +bool s7_is_macro(s7_scheme *sc, s7_pointer mac) {return(is_any_macro(mac));} +static bool is_macro_b(s7_pointer mac) {return(is_any_macro(mac));} + +/* g_is_macro is now defined in s7_scheme_predicate.c */ + #define H_is_macro "(macro? arg) returns #t if 'arg' is a macro or a bacro" + #define Q_is_macro sc->pl_bt + +static bool closure_is_aritable(s7_scheme *sc, s7_pointer x, s7_pointer x_args, int32_t args); + +static s7_pointer s7_macroexpand(s7_scheme *sc, s7_pointer mac, s7_pointer args) +{ + int32_t arg_len; + if (!s7_is_proper_list(sc, args)) + return(sc->F); + arg_len = proper_list_length(args); + if (!closure_is_aritable(sc, mac, closure_pars(mac), arg_len)) + return(sc->F); + push_stack_direct(sc, OP_EVAL_DONE); + sc->code = mac; + sc->args = args; + set_curlet(sc, 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 obj) +{ + if (is_symbol(obj)) + { + if (is_keyword(obj)) return(NULL); + if (symbol_has_help(obj)) + return(symbol_help(obj)); + obj = s7_symbol_value(sc, obj); /* this is needed by Snd */ + } + if ((is_any_c_function(obj)) || (is_c_macro(obj))) + return((const char *)c_function_documentation(obj)); + if (is_syntax(obj)) + return(syntax_documentation(obj)); + { + s7_pointer val = funclet_entry(sc, obj, sc->local_documentation_symbol); + if ((val) && (is_string(val))) + return(string_value(val)); + if (has_closure_let(obj)) + { + val = closure_body(obj); + if ((is_pair(val)) && (is_string(car(val)))) + return((char *)string_value(car(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 obj = car(args); + if (is_symbol(obj)) + { + if ((symbol_has_help(obj)) && + (is_defined_global(obj))) + return(s7_make_string(sc, symbol_help(obj))); + obj = s7_symbol_value(sc, obj); + } + /* (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(obj)) + { + s7_pointer func = funclet_entry(sc, obj, sc->documentation_symbol); + if (func) + return(s7_apply_function(sc, func, args)); + func = closure_body(obj); + if ((is_pair(func)) && (is_string(car(func)))) + return(car(func)); } - else if ((is_t_vector (dest)) && (set != typed_vector_setter)) { - s7_pointer* els= vector_elements (dest); - for (s7_int i= start, j= 0; i < end; i++, j++, p= cdr (p)) - els[j]= car (p); + /* it would be neat if this would work (define x (let ((+documentation+ "hio")) (vector 1 2 3))) (documentation x) */ + if_method_exists_return_value(sc, obj, sc->documentation_symbol, args); + return(s7_make_string(sc, s7_documentation(sc, obj))); +} + +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)); + add_saved_pointer(sc, symbol_help(sym)); } - else { - gc_protect_via_stack (sc, source); - for (s7_int i= start, j= 0; i < end; i++, j++, p= cdr (p)) - set (sc, dest, j, car (p)); - unstack_gc_protect (sc); + 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); } - return (dest); - } + if (is_any_procedure(obj)) + return(s7_documentation(sc, obj)); + if (obj == sc->starlet) + 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); +} - case T_LET: - if (source == sc->starlet) /* *s7* */ /* this could be more direct via - starlet_make_iterator, but it - hardly matters */ - { - const s7_pointer iter = s7_make_iterator (sc, sc->starlet); - const s7_int gc_loc= gc_protect_1 (sc, iter); - for (s7_int 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* ()) */ +/* g_help is now defined in s7_scheme_predicate.c */ + #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->not_symbol), sc->T) + + +/* -------------------------------- 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->complex_vector_signature = s7_make_circular_signature(sc, 2, 3, sc->is_complex_symbol, sc->is_complex_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->not_symbol), sc->T) + + s7_pointer obj = car(args); + switch (type(obj)) + { + case T_C_FUNCTION: case T_C_RST_NO_REQ_FUNCTION: + case T_C_FUNCTION_STAR: case T_C_MACRO: + return((s7_pointer)c_function_signature(obj)); + + case T_MACRO: case T_MACRO_STAR: + case T_BACRO: case T_BACRO_STAR: + case T_CLOSURE: case T_CLOSURE_STAR: { - s7_pointer p= dest; - for (s7_int i= start; (i < end) && (is_pair (p)); - i++, p= cdr (p)) /* i = start is redundant? also below */ - { - s7_pointer val= s7_iterate (sc, iter); - if (iterator_is_at_end (iter)) break; - set_car (p, val); - } - } - else - for (s7_int i= start, j= 0; i < end; i++, j++) { - s7_pointer 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 (s7_int i= 0; i < start; i++) - slot= next_slot (slot); - if (is_pair (dest)) { - s7_pointer p= dest; - check_free_heap_size (sc, end - start); - for (s7_int i= start; (i < end) && (is_pair (p)); - i++, p= cdr (p), slot= next_slot (slot)) - set_car (p, - cons_unchecked (sc, slot_symbol (slot), slot_value (slot))); + s7_pointer func = funclet_entry(sc, obj, sc->local_signature_symbol); + if (func) return(func); + func = funclet_entry(sc, obj, sc->signature_symbol); + return((func) ? s7_apply_function(sc, func, args) : sc->F); } - else if (is_let (dest)) /* this ignores slot setters */ + + case T_VECTOR: + if (vector_length(obj) == 0) return(sc->F); /* sig () is #f so sig #() should be #f */ + if (!is_typed_vector(obj)) + return(sc->vector_signature); { - if ((has_let_fallback (source)) && (has_let_fallback (dest))) { - for (slot= let_slots (source); is_not_slot_end (slot); - slot= next_slot (slot)) - if ((slot_symbol (slot) != sc->let_ref_fallback_symbol) && - (slot_symbol (slot) != sc->let_set_fallback_symbol)) - add_slot_no_local (sc, dest, slot_symbol (slot), - slot_value (slot)); - } - else - for (s7_int i= start; i < end; i++, slot= next_slot (slot)) - add_slot_no_local (sc, dest, slot_symbol (slot), slot_value (slot)); - } - else if (is_hash_table (dest)) - for (s7_int i= start; i < end; i++, slot= next_slot (slot)) - s7_hash_table_set ( - sc, dest, slot_symbol (slot), - slot_value ( - slot)); /* if value=#f, dest will not contain symbol */ - else if ((is_t_vector (dest)) && (set != typed_vector_setter)) { - s7_pointer* els= vector_elements (dest); - check_free_heap_size (sc, end - start); - for (s7_int i= start, j= 0; i < end; i++, j++, slot= next_slot (slot)) - els[j]= cons_unchecked (sc, slot_symbol (slot), slot_value (slot)); - } - else - for (s7_int 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* entry = NULL; - - while (skip > 0) { - while (!entry) - entry= elements[++loc]; - skip--; - entry= hash_entry_next (entry); - } - if (is_pair (dest)) { - s7_pointer p= dest; - check_free_heap_size (sc, end - start); - for (s7_int i= start; (i < end) && (is_pair (p)); i++, p= cdr (p)) { - while (!entry) - entry= elements[++loc]; - set_car (p, cons_unchecked (sc, hash_entry_key (entry), - hash_entry_value (entry))); - entry= hash_entry_next (entry); - } - } - else if (is_let (dest)) { - for (s7_int i= start; i < end; i++) { - s7_pointer symbol; - while (!entry) - entry= elements[++loc]; - symbol= hash_entry_key (entry); - if (!is_symbol (symbol)) - copy_element_error_nr (sc, caller, i + 1, symbol, T_SYMBOL); - if (is_constant_symbol (sc, symbol)) - error_nr ( - 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_no_local ( - sc, dest, symbol, - hash_entry_value (entry)); /* ...unchecked... if size ok */ - entry= hash_entry_next (entry); - } - } - else { - check_free_heap_size (sc, end - start); - for (s7_int i= start, j= 0; i < end; i++, j++) { - while (!entry) - entry= elements[++loc]; - set (sc, dest, j, - cons_unchecked (sc, hash_entry_key (entry), - hash_entry_value (entry))); - entry= hash_entry_next (entry); + s7_pointer lst = list_3(sc, typed_vector_typer_symbol(sc, obj), sc->is_vector_symbol, sc->is_integer_symbol); + set_cdddr(lst, cddr(lst)); + return(lst); } - } - return (dest); - } - case T_VECTOR: { - s7_pointer* vals= vector_elements (source); - if (is_float_vector (dest)) { - s7_double* dst= float_vector_floats (dest); - for (s7_int i= start, j= 0; i < end; i++, j++) - dst[j]= real_to_double (sc, vals[i], symbol_name (caller)); - return (dest); - } - if (is_int_vector (dest)) { - s7_int* dst= int_vector_ints (dest); - for (s7_int i= start, j= 0; i < end; i++, j++) { - if (!s7_is_integer (vals[i])) - copy_element_error_nr (sc, caller, i + 1, vals[i], T_INTEGER); - dst[j]= s7_integer_clamped_if_gmp (sc, vals[i]); - } - return (dest); - } - if (is_complex_vector (dest)) { - s7_complex* dst= complex_vector_complexes (dest); - for (s7_int i= start, j= 0; i < end; i++, j++) { - if (!s7_is_number (vals[i])) - copy_element_error_nr (sc, caller, i + 1, vals[i], T_COMPLEX); - dst[j]= s7_to_c_complex (vals[i]); - } - return (dest); - } - if (is_string (dest)) { - char* dst= string_value (dest); - for (s7_int i= start, j= 0; i < end; i++, j++) { - if (!is_character (vals[i])) - copy_element_error_nr (sc, caller, i + 1, 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 (s7_int i= start, j= 0; i < end; i++, j++) { - s7_int byte; - if (!s7_is_integer (vals[i])) - copy_element_error_with_type_nr (sc, caller, i + 1, vals[i], - an_unsigned_byte_string); - byte= s7_integer_clamped_if_gmp (sc, vals[i]); - if ((byte >= 0) && (byte < 256)) dst[j]= (uint8_t) byte; - else - copy_element_error_with_type_nr (sc, caller, i + 1, vals[i], - an_unsigned_byte_string); - } - return (dest); - } - } break; - - case T_COMPLEX_VECTOR: - if ((is_t_vector (dest)) && (!is_typed_vector (dest))) { - const s7_complex* src= complex_vector_complexes (source); - s7_pointer* dst= vector_elements (dest); - check_free_heap_size (sc, end - start); - for (s7_int i= start, j= 0; i < end; i++, j++) - dst[j]= c_complex_to_s7 (sc, src[i]); - return (dest); - } - break; - - case T_FLOAT_VECTOR: - /* int-vector destination can't normally work, fractional parts get rounded - * away */ - if ((is_t_vector (dest)) && (!is_typed_vector (dest))) { - const s7_double* src= float_vector_floats (source); - s7_pointer* dst= vector_elements (dest); - check_free_heap_size (sc, end - start); - for (s7_int i= start, j= 0; i < end; i++, j++) - dst[j]= make_real_unchecked (sc, src[i]); - return (dest); - } - break; - - case T_INT_VECTOR: { - const s7_int* src= int_vector_ints (source); - if (is_float_vector (dest)) { - s7_double* dst= float_vector_floats (dest); - for (s7_int i= start, j= 0; i < end; i++, j++) - dst[j]= (s7_double) (src[i]); - return (dest); - } - if ((is_t_vector (dest)) && (!is_typed_vector (dest))) { - s7_pointer* dst= vector_elements (dest); - check_free_heap_size (sc, end - start); - for (s7_int i= start, j= 0; i < end; i++, j++) - dst[j]= make_integer_unchecked (sc, src[i]); - return (dest); - } - if (is_string (dest)) { - for (s7_int i= start, j= 0; i < end; i++, j++) { - if ((src[i] < 0) || (src[i] > 255)) - copy_element_error_with_type_nr (sc, caller, i + 1, - wrap_integer (sc, src[i]), - an_unsigned_byte_string); - string_value (dest)[j]= (uint8_t) (src[i]); - } - return (dest); - } - if (is_byte_vector (dest)) { - for (s7_int i= start, j= 0; i < end; i++, j++) { - if ((src[i] < 0) || (src[i] > 255)) - copy_element_error_with_type_nr (sc, caller, i + 1, - wrap_integer (sc, src[i]), - an_unsigned_byte_string); - byte_vector (dest, j)= (uint8_t) (src[i]); - } - return (dest); - } - } break; - - case T_BYTE_VECTOR: - if ((is_t_vector (dest)) && (!is_typed_vector (dest))) { - s7_pointer* dst= vector_elements (dest); - check_free_heap_size (sc, end - start); - for (s7_int i= start, j= 0; i < end; i++, j++) - dst[j]= small_int (byte_vector (source, i)); - return (dest); - } - if (is_int_vector (dest)) { - s7_int* els= int_vector_ints (dest); - for (s7_int 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 (s7_int 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_t_vector (dest)) && (!is_typed_vector (dest))) { - s7_pointer* dst= vector_elements (dest); - for (s7_int 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 (s7_int 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 (s7_int i= start, j= 0; i < end; i++, j++) - els[j]= (s7_double) ((uint8_t) (string_value (source)[i])); - return (dest); - } - break; - /* default (random_state, simple_block etc) is to let "set" handle it below - */ - } + case T_FLOAT_VECTOR: return((vector_length(obj) == 0) ? sc->F : sc->float_vector_signature); + case T_COMPLEX_VECTOR: return((vector_length(obj) == 0) ? sc->F : sc->complex_vector_signature); + case T_INT_VECTOR: return((vector_length(obj) == 0) ? sc->F : sc->int_vector_signature); + case T_BYTE_VECTOR: return((vector_length(obj) == 0) ? sc->F : sc->byte_vector_signature); + case T_PAIR: return(sc->pair_signature); + case T_STRING: return(sc->string_signature); - if (is_pair (dest)) { - s7_pointer p= dest; - if (is_float_vector (source)) { - const s7_double* els= float_vector_floats (source); - check_free_heap_size (sc, end - start); - for (s7_int i= start; (i < end) && (is_pair (p)); i++, p= cdr (p)) - set_car (p, make_real_unchecked (sc, els[i])); - } - else if (is_int_vector (source)) { - const s7_int* els= int_vector_ints (source); - check_free_heap_size (sc, end - start); - for (s7_int i= start; (i < end) && (is_pair (p)); i++, p= cdr (p)) - set_car (p, make_integer_unchecked (sc, els[i])); + case T_HASH_TABLE: + if (is_typed_hash_table(obj)) + return(list_3(sc, + hash_table_typer_symbol(sc, hash_table_value_typer(obj)), + sc->is_hash_table_symbol, + hash_table_typer_symbol(sc, hash_table_key_typer(obj)))); + return(sc->hash_table_signature); + + case T_ITERATOR: + obj = iterator_sequence(obj); + if ((is_hash_table(obj)) || (is_let(obj))) /* cons returned -- would be nice to include the car/cdr types if known */ + return(list_1(sc, sc->is_pair_symbol)); + obj = g_signature(sc, set_plist_1(sc, obj)); + return(list_1(sc, (is_pair(obj)) ? car(obj) : sc->T)); + + case T_C_OBJECT: + if_c_object_method_exists_return_value(sc, obj, sc->signature_symbol, args); + return(sc->c_object_signature); + + case T_LET: + if_let_method_exists_return_value(sc, obj, 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 */ + { + const s7_pointer slot = s7_slot(sc, obj); + if ((is_slot(slot)) && (slot_has_setter(slot))) + { + s7_pointer setter = slot_setter(slot); + obj = g_signature(sc, set_plist_1(sc, setter)); + if (is_pair(obj)) + return(list_1(sc, car(obj))); + }} + break; + + default: break; } - else - for (s7_int i= start; (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 (s7_int 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); + return(sc->F); } -s7_pointer -s7_copy (s7_scheme* sc, s7_pointer args) { - return (s7_copy_1 (sc, sc->copy_symbol, args)); -} -#define g_copy s7_copy +s7_pointer s7_signature(s7_scheme *sc, s7_pointer func) {return(g_signature(sc, set_plist_1(sc, func)));} -s7_pointer -s7i_copy_1 (s7_scheme* sc, s7_pointer caller, s7_pointer args) { - return (s7_copy_1 (sc, caller, args)); -} -/* -------------------------------- reverse -------------------------------- */ -s7_pointer -s7_reverse (s7_scheme* sc, s7_pointer a) /* just pairs */ +/* -------------------------------- dynamic-wind -------------------------------- */ +static s7_pointer closure_or_f(s7_scheme *sc, s7_pointer obj) { - /* reverse list -- produce new list (other code assumes this function does not - * return the original!) */ - s7_pointer lst, 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 */ - begin_temp (sc->y, list_1 (sc, car (a))); - for (lst= cdr (a), p= a; is_pair (lst); lst= cdr (lst), p= cdr (p)) { - sc->y= cons (sc, car (lst), sc->y); - if (is_pair (cdr (lst))) { - lst = cdr (lst); - sc->y= cons_unchecked (sc, car (lst), sc->y); - } - if (lst == p) /* this can take awhile to notice there's a cycle, but what - does the caller expect? */ - break; - } - sc->y= (is_null (lst)) - ? sc->y - : cons (sc, lst, - sc->y); /* ?? this means that (reverse '(1 2 . 3)) returns - '(3 2 1) -- we used to return () here */ - return_with_end_temp (sc->y); + s7_pointer body; + if (!is_closure(obj)) return(obj); + body = closure_body(obj); + if (is_pair(cdr(body))) return(obj); + if (!is_pair(car(body))) return(sc->F); + return((is_quote(sc, caar(body))) ? sc->F : obj); } -/* 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 -string_reverse (s7_scheme* sc, s7_pointer str) { - const char* source = string_value (str); - const s7_int len = string_length (str); - const char* end = (char*) (source + len); - const s7_pointer new_str= make_empty_string (sc, len, '\0'); - char* dest = (char*) (string_value (new_str) + len); - while (source < end) - *(--dest)= *source++; - return (new_str); -} - -static s7_pointer -byte_vector_reverse (s7_scheme* sc, s7_pointer bv) { - const uint8_t* source= byte_vector_bytes (bv); - const s7_int len = byte_vector_length (bv); - const uint8_t* end = (const uint8_t*) (source + len); - const s7_pointer new_bv= make_simple_byte_vector (sc, len); - uint8_t* dest = (uint8_t*) (byte_vector_bytes (new_bv) + len); - while (source < end) - *(--dest)= *source++; - return (new_bv); -} - -static s7_pointer -int_vector_reverse (s7_scheme* sc, s7_pointer iv) { - s7_pointer new_iv; - s7_int* dest; - const s7_int* source= int_vector_ints (iv); - const s7_int len = vector_length (iv); - const s7_int* end = (s7_int*) (source + len); - if (vector_rank (iv) > 1) - new_iv= s7i_make_vector_1 ( - sc, - set_plist_2 (sc, g_vector_dimensions (sc, set_plist_1 (sc, iv)), - int_zero), - sc->make_int_vector_symbol); - else new_iv= make_simple_int_vector (sc, len); - dest= (s7_int*) (int_vector_ints (new_iv) + len); - while (source < end) - *(--dest)= *source++; - return (new_iv); -} - -static s7_pointer -float_vector_reverse (s7_scheme* sc, s7_pointer fv) { - s7_pointer new_fv; - s7_double* dest; - const s7_double* source= float_vector_floats (fv); - const s7_int len = vector_length (fv); - const s7_double* end = (s7_double*) (source + len); - if (vector_rank (fv) > 1) - new_fv= s7i_make_vector_1 ( - sc, - set_plist_2 (sc, g_vector_dimensions (sc, set_plist_1 (sc, fv)), - real_zero), - sc->make_float_vector_symbol); - else new_fv= make_simple_float_vector (sc, len); - dest= (s7_double*) (float_vector_floats (new_fv) + len); - while (source < end) - *(--dest)= *source++; - return (new_fv); -} - -static s7_pointer -complex_vector_reverse (s7_scheme* sc, s7_pointer cv) { - s7_pointer new_cv; - s7_complex* dest; - const s7_complex* source= complex_vector_complexes (cv); - const s7_int len = vector_length (cv); - const s7_complex* end = (s7_complex*) (source + len); - if (vector_rank (cv) > 1) - new_cv= s7i_make_vector_1 ( - sc, - set_plist_2 (sc, g_vector_dimensions (sc, set_plist_1 (sc, cv)), - real_zero), - sc->make_complex_vector_symbol); - else new_cv= make_simple_complex_vector (sc, len); - dest= (s7_complex*) (complex_vector_complexes (new_cv) + len); - while (source < end) - *(--dest)= *source++; - return (new_cv); -} - -static s7_pointer -vector_reverse (s7_scheme* sc, s7_pointer vect) { - s7_pointer new_vect; - s7_pointer* dest; - const s7_pointer* source= vector_elements (vect); - const s7_int len = vector_length (vect); - const s7_pointer* end = (s7_pointer*) (source + len); - if (vector_rank (vect) > 1) - new_vect= g_make_vector ( - sc, set_plist_1 (sc, g_vector_dimensions (sc, set_plist_1 (sc, vect)))); - else new_vect= make_simple_vector (sc, len); - dest= (s7_pointer*) (vector_elements (new_vect) + len); - while (source < end) - *(--dest)= *source++; - if (is_typed_vector (vect)) { - set_typed_vector (new_vect); - typed_vector_set_typer (new_vect, typed_vector_typer (vect)); - if (has_simple_elements (vect)) set_has_simple_elements (new_vect); - } - return (new_vect); +static s7_pointer make_baffled_closure(s7_scheme *sc, s7_pointer old_func) +{ + /* for dynamic-wind to protect initial and final functions from call/cc */ + s7_pointer new_func = make_closure_unchecked(sc, sc->nil, closure_body(old_func), type(old_func), 0); /* always preceded by new dw cell */ + s7_pointer let = make_let(sc, closure_let(old_func)); /* let_outlet(let) = closure_let(old_func) */ + set_baffle_let(let); + let_set_baffle_key(let, sc->baffle_ctr++); + closure_set_let(new_func, let); + return(new_func); } -static s7_pointer -c_object_reverse_1 (s7_scheme* sc, s7_pointer obj) { - if_c_object_method_exists_return_value (sc, obj, sc->reverse_symbol, - set_plist_1 (sc, obj)); - if (!c_object_reverse (sc, obj)) - syntax_error_nr (sc, "attempt to reverse ~S?", 22, obj); - return ((*(c_object_reverse (sc, obj))) (sc, set_plist_1 (sc, obj))); +static bool is_dwind_thunk(s7_scheme *sc, s7_pointer obj) +{ + switch (type(obj)) + { + 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_pars(obj))); /* this case does not match is_aritable -- it could be loosened -- arity=0 below would need fixup */ + case T_C_FUNCTION: + return(c_function_is_aritable(obj, 0)); + case T_C_MACRO: + return(c_macro_min_args(obj) == 0); + case T_C_FUNCTION_STAR: case T_GOTO: case T_CONTINUATION: case T_C_RST_NO_REQ_FUNCTION: + return(true); + } + return(obj == sc->F); /* (dynamic-wind #f (lambda () 3) #f) */ } -static s7_pointer -let_reverse (s7_scheme* sc, s7_pointer obj) { - if_let_method_exists_return_value (sc, obj, sc->reverse_symbol, - set_plist_1 (sc, obj)); - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_2 (sc, wrap_string (sc, "can't reverse let: ~S", 21), obj)); -#ifdef __TINYC__ - return (NULL); /* won't happen but placate tcc */ -#endif +static s7_pointer g_dynamic_wind_unchecked(s7_scheme *sc, s7_pointer args) +{ + s7_pointer dw, init_func, final_func; + + new_cell(sc, dw, T_DYNAMIC_WIND); /* don't mark car/cdr, don't copy */ + dynamic_wind_in(dw) = closure_or_f(sc, car(args)); + dynamic_wind_body(dw) = cadr(args); + dynamic_wind_out(dw) = closure_or_f(sc, caddr(args)); + push_stack(sc, OP_DYNAMIC_WIND, sc->nil, dw); /* args will be the saved result, code = s7_dynwind_t obj */ + /* do this push_stack early to protect p from allocations in make_baffled_closure */ + init_func = dynamic_wind_in(dw); + if ((is_any_closure(init_func)) && (!is_safe_closure(init_func))) /* wrap this use of init_func in a with-baffle */ + dynamic_wind_in(dw) = make_baffled_closure(sc, init_func); + + final_func = dynamic_wind_out(dw); + if ((is_any_closure(final_func)) && (!is_safe_closure(final_func))) + dynamic_wind_out(dw) = make_baffled_closure(sc, final_func); + + /* 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. + */ + if (init_func != sc->F) + { + dynamic_wind_state(dw) = dwind_init; + push_stack(sc, OP_APPLY, sc->nil, dynamic_wind_in(dw)); + } + else + { + dynamic_wind_state(dw) = dwind_body; + push_stack(sc, OP_APPLY, sc->nil, dynamic_wind_body(dw)); + } + return(sc->F); } -static s7_pointer -reverse_p_p (s7_scheme* sc, s7_pointer obj) { - sc->temp3= obj; - if (is_pair (obj)) - return (s7_reverse (sc, obj)); /* by far the most common case */ - switch (type (obj)) { - case T_NIL: - return (sc->nil); - /* case T_PAIR: return(s7_reverse(sc, obj)); */ - case T_STRING: - return (string_reverse (sc, obj)); - case T_BYTE_VECTOR: - return (byte_vector_reverse (sc, obj)); - case T_INT_VECTOR: - return (int_vector_reverse (sc, obj)); - case T_FLOAT_VECTOR: - return (float_vector_reverse (sc, obj)); - case T_COMPLEX_VECTOR: - return (complex_vector_reverse (sc, obj)); - case T_VECTOR: - return (vector_reverse (sc, obj)); - case T_HASH_TABLE: - return (hash_table_reverse (sc, obj)); - case T_C_OBJECT: - return (c_object_reverse_1 (sc, obj)); - case T_LET: - return (let_reverse (sc, obj)); - default: - return (method_or_bust_p (sc, obj, sc->reverse_symbol, a_sequence_string)); - } - return (sc->nil); +static s7_pointer g_dynamic_wind_init(s7_scheme *sc, s7_pointer args) +{ + s7_pointer dw; + const s7_pointer init_func = closure_or_f(sc, car(args)); + new_cell(sc, dw, T_DYNAMIC_WIND); /* don't mark car/cdr, don't copy */ + dynamic_wind_in(dw) = init_func; + dynamic_wind_body(dw) = cadr(args); + dynamic_wind_out(dw) = sc->F; + if ((is_any_closure(init_func)) && (!is_safe_closure(init_func))) /* wrap this use of init_func in a with-baffle */ + dynamic_wind_in(dw) = make_baffled_closure(sc, init_func); + push_stack(sc, OP_DYNAMIC_WIND, sc->nil, dw); /* args will be the saved result, code = s7_dynwind_t obj */ + dynamic_wind_state(dw) = dwind_init; + push_stack(sc, OP_APPLY, sc->nil, dynamic_wind_in(dw)); + return(sc->F); +} + +static s7_pointer g_dynamic_wind_body(s7_scheme *sc, s7_pointer args) +{ + push_stack(sc, OP_APPLY, sc->nil, cadr(args)); + return(sc->F); } -/* g_reverse is now defined in s7_scheme_predicate.c */ -#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) +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_signature(sc, 4, sc->values_symbol, \ + s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->not_symbol), \ + sc->is_procedure_symbol, \ + s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->not_symbol)) + + if (!is_dwind_thunk(sc, car(args))) + return(method_or_bust(sc, car(args), sc->dynamic_wind_symbol, args, wrap_string(sc, "a thunk or #f", 13), 1)); + if (!is_thunk(sc, cadr(args))) + return(method_or_bust(sc, cadr(args), sc->dynamic_wind_symbol, args, a_thunk_string, 2)); + if (!is_dwind_thunk(sc, caddr(args))) + return(method_or_bust(sc, caddr(args), sc->dynamic_wind_symbol, args, wrap_string(sc, "a thunk or #f", 13), 3)); -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); + /* 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 s7_pointer -string_or_byte_vector_reverse_in_place (s7_scheme* sc, s7_pointer str) { - s7_int len; - uint8_t* bytes; - if (is_string (str)) { - len = string_length (str); - bytes= (uint8_t*) string_value (str); - } - else { - len = byte_vector_length (str); - bytes= byte_vector_bytes (str); - } - if (len < 2) return (str); - if (is_immutable (str)) /* "" might be immutable but we want (reverse! "") to - return "" */ - immutable_object_error_nr ( - sc, set_elist_3 (sc, immutable_error_string, sc->reverseb_symbol, str)); +static bool is_lambda(s7_scheme *sc, s7_pointer sym) +{ + return((sym == sc->lambda_symbol) && (is_global(sym))); /* do we need (!sc->in_with_let) ? */ +} -#if (defined(__linux__)) && (defined(__GLIBC__)) /* need byteswp.h */ - /* this code (from StackOverflow with changes) is much faster: */ -#include - if ((len & 0x7f) == 0) { - 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)); - LOOP_4 (a= *src; b= *dst; *src++= bswap_32 (b); *dst--= bswap_32 (a)); - LOOP_4 (a= *src; b= *dst; *src++= bswap_32 (b); *dst--= bswap_32 (a)); - LOOP_4 (a= *src; b= *dst; *src++= bswap_32 (b); *dst--= bswap_32 (a)); +static int32_t is_ok_thunk(s7_scheme *sc, s7_pointer arg) /* used only in dynamic_wind_chooser */ +{ + /* 0 = not ok, 1 = ok but not simple, 2 = ok body is just #f, 3 = #f */ + if (arg == sc->F) return(3); + if ((is_pair(arg)) && + (is_lambda(sc, car(arg))) && + (is_pair(cdr(arg))) && + (is_null(cadr(arg))) && /* (lambda () ...) */ + (is_pair(cddr(arg))) && + (s7_is_proper_list(sc, cddr(arg)))) + return(((is_null(cdddr(arg))) && (caddr(arg) == sc->F)) ? 2 : 1); /* 2: (lambda () #f) */ + return(0); +} + +static s7_pointer dynamic_wind_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + if ((args == 3) && + (is_ok_thunk(sc, caddr(expr)))) + { + int32_t init = is_ok_thunk(sc, cadr(expr)); + int32_t end = is_ok_thunk(sc, cadddr(expr)); + if ((init > 1) && (end > 1)) return(sc->dynamic_wind_body); + if ((init > 0) && (end > 1)) return(sc->dynamic_wind_init); + if ((init > 0) && (end > 0)) return(sc->dynamic_wind_unchecked); } - } - else if ((len & 0x1f) == 0) /* 4-bytes at a time, 4 times per loop == 16 */ - { - 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)); + return(func); +} + +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" */ + 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 -#endif - { - char* s1= (char*) bytes; - char* s2= (char*) (s1 + len - 1); - while (s1 < s2) { - char c; - c = *s1; - *s1++= *s2; - *s2--= c; + { + s7_pointer dw; + push_stack_direct(sc, OP_EVAL_DONE); /* this is ok because we have called setjmp etc */ + sc->args = sc->nil; + new_cell(sc, dw, T_DYNAMIC_WIND); + dynamic_wind_in(dw) = T_Ext(init); + dynamic_wind_body(dw) = T_Ext(body); + dynamic_wind_out(dw) = T_Ext(finish); + push_stack(sc, OP_DYNAMIC_WIND, sc->nil, dw); + if (init != sc->F) + { + dynamic_wind_state(dw) = dwind_init; + sc->code = init; + } + else + { + dynamic_wind_state(dw) = dwind_body; + sc->code = body; + } + eval(sc, OP_APPLY); } - } - return (str); + 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 -int_vector_reverse_in_place (s7_scheme* sc, s7_pointer vec) { - const s7_int len= vector_length (vec); - if (len < 2) - return (vec); /* (reverse! #i()) -> #i() independent of immutable bit */ - if (is_immutable_vector (vec)) - immutable_object_error_nr ( - sc, set_elist_3 (sc, immutable_error_string, sc->reverseb_symbol, vec)); - { - s7_int* ints1= int_vector_ints (vec); - s7_int* ints2= (s7_int*) (ints1 + len - 1); - if ((len & 0x3f) == 0) /* 63 for 2 32's */ - while (ints1 < ints2) { - s7_int c; - LOOP_8 (c= *ints1; *ints1++= *ints2; *ints2--= c); - LOOP_8 (c= *ints1; *ints1++= *ints2; *ints2--= c); - LOOP_8 (c= *ints1; *ints1++= *ints2; *ints2--= c); - LOOP_8 (c= *ints1; *ints1++= *ints2; *ints2--= c); - } - else if ((len & 0xf) == 0) /* not 0x7 -- odd multiple of 8 will leave center - ints unreversed (we're moving 2 at a time) */ - while (ints1 < ints2) { - s7_int c; - LOOP_8 (c= *ints1; *ints1++= *ints2; *ints2--= c); - } - else - while (ints1 < ints2) { - s7_int c; - c = *ints1; - *ints1++= *ints2; - *ints2--= c; - } - } - return (vec); +static void op_unwind_output(s7_scheme *sc) +{ + const 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 s7_pointer -float_vector_reverse_in_place (s7_scheme* sc, s7_pointer fv) { - const s7_int len= vector_length (fv); - if (len < 2) return (fv); - if (is_immutable_vector (fv)) - immutable_object_error_nr ( - sc, set_elist_3 (sc, immutable_error_string, sc->reverseb_symbol, fv)); - { - s7_double* flts1= float_vector_floats (fv); - s7_double* flts2= (s7_double*) (flts1 + len - 1); - if ((len & 0x3f) == 0) /* 63 for 2 32's */ - while (flts1 < flts2) { - s7_double x; - LOOP_8 (x= *flts1; *flts1++= *flts2; *flts2--= x); - LOOP_8 (x= *flts1; *flts1++= *flts2; *flts2--= x); - LOOP_8 (x= *flts1; *flts1++= *flts2; *flts2--= x); - LOOP_8 (x= *flts1; *flts1++= *flts2; *flts2--= x); - } - else if ((len & 0xf) == 0) - while (flts1 < flts2) { - s7_double x; - LOOP_8 (x= *flts1; *flts1++= *flts2; *flts2--= x); - } - else - while (flts1 < flts2) { - s7_double x; - x = *flts1; - *flts1++= *flts2; - *flts2--= x; - } - } - return (fv); -} - -static s7_pointer -complex_vector_reverse_in_place (s7_scheme* sc, s7_pointer cv) { - const s7_int len = vector_length (cv); - s7_complex * cmplx1= complex_vector_complexes (cv), *cmplx2; - if (len < 2) return (cv); - if (is_immutable_vector (cv)) - immutable_object_error_nr ( - sc, set_elist_3 (sc, immutable_error_string, sc->reverseb_symbol, cv)); - cmplx2= (s7_complex*) (cmplx1 + len - 1); - while (cmplx1 < cmplx2) { - s7_complex z; - z = *cmplx1; - *cmplx1++= *cmplx2; - *cmplx2--= z; - } - return (cv); +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 s7_pointer -vector_reverse_in_place (s7_scheme* sc, s7_pointer vec) { - const s7_int len= vector_length (vec); - if (len < 2) return (vec); - if (is_immutable_vector (vec)) - immutable_object_error_nr ( - sc, set_elist_3 (sc, immutable_error_string, sc->reverseb_symbol, vec)); - { - s7_pointer* vect1= vector_elements (vec); - s7_pointer* vect2= (s7_pointer*) (vect1 + len - 1); - if ((len & 0x3f) == 0) /* 63 for 2 32's */ - while (vect1 < vect2) { - s7_pointer c; - LOOP_8 (c= *vect1; *vect1++= *vect2; *vect2--= c); - LOOP_8 (c= *vect1; *vect1++= *vect2; *vect2--= c); - LOOP_8 (c= *vect1; *vect1++= *vect2; *vect2--= c); - LOOP_8 (c= *vect1; *vect1++= *vect2; *vect2--= c); - } - else if ((len & 0xf) == 0) - while (vect1 < vect2) { - s7_pointer c; - LOOP_8 (c= *vect1; *vect1++= *vect2; *vect2--= c); - } - else - while (vect1 < vect2) { - s7_pointer c; - c = *vect1; - *vect1++= *vect2; - *vect2--= c; - } - } - return (vec); +static bool op_dynamic_wind(s7_scheme *sc) +{ + const s7_pointer dwind = T_Dyn(sc->code); + if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s\n", __func__, __LINE__, display_truncated(dwind)); + if (dynamic_wind_state(dwind) == dwind_init) + { + dynamic_wind_state(dwind) = dwind_body; + push_stack(sc, OP_DYNAMIC_WIND, sc->nil, dwind); + sc->code = dynamic_wind_body(dwind); + sc->args = sc->nil; + return(true); /* goto apply */ + } + if (dynamic_wind_state(dwind) == dwind_body) + { + dynamic_wind_state(dwind) = dwind_finish; + if (dynamic_wind_out(dwind) != sc->F) + { + push_stack(sc, OP_DYNAMIC_WIND, sc->value, dwind); + sc->code = dynamic_wind_out(dwind); + sc->args = sc->nil; + return(true); + } + if (is_multiple_value(sc->value)) + sc->value = splice_in_values(sc, multiple_value(sc->value)); + return(false); /* 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(false); } -static s7_pointer -reverse_pair_in_place (s7_scheme* sc, s7_pointer obj, s7_pointer args) { - if (is_immutable_pair (obj)) - immutable_object_error_nr ( - sc, set_elist_3 (sc, immutable_error_string, sc->reverseb_symbol, obj)); - { - s7_pointer lst= any_list_reverse_in_place (sc, sc->nil, obj); - if (is_null (lst)) { - if (!s7_is_proper_list (sc, obj)) - wrong_type_error_nr (sc, sc->reverseb_symbol, 1, car (args), - wrap_string (sc, "a proper list", 13)); - wrong_type_error_nr (sc, sc->reverseb_symbol, 1, car (args), - wrap_string (sc, "a mutable proper list", 21)); - } - return (lst); - } - /* (reverse! obj) 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! obj (reverse! obj)) 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)) - * sole_arg_wrong_type_error_nr(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 - */ + +/* -------------------------------- c-object? -------------------------------- */ +bool s7_is_c_object(s7_pointer p) {return(is_c_object(p));} + +/* g_is_c_object is now defined in s7_scheme_predicate.c */ + #define H_is_c_object "(c-object? obj) returns #t is obj is a c-object." + #define Q_is_c_object sc->pl_bt + +static no_return void apply_error_nr(s7_scheme *sc, s7_pointer obj, s7_pointer args) +{ + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "attempt to apply ~A ~$ in ~S?", 29), + (is_null(obj)) ? wrap_string(sc, "nil", 3) : ((is_symbol_and_keyword(obj)) ? wrap_string(sc, "a keyword", 9) : type_name_string(sc, obj)), + obj, + set_ulist_1(sc, obj, args))); /* was current_code(sc) which is unreliable */ } -static s7_pointer -reverse_in_place_via_method (s7_scheme* sc, s7_pointer obj) { - if (is_immutable (obj)) { - if (is_simple_sequence (obj)) - immutable_object_error_nr (sc, set_elist_3 (sc, immutable_error_string, - sc->reverseb_symbol, obj)); - sole_arg_wrong_type_error_nr (sc, sc->reverseb_symbol, obj, - a_sequence_string); - } - if ((is_simple_sequence (obj)) && (!has_active_methods (sc, obj))) - sole_arg_wrong_type_error_nr ( - sc, sc->reverseb_symbol, obj, - wrap_string (sc, "a vector, string, or list", 25)); - return (method_or_bust_p (sc, obj, sc->reverseb_symbol, a_sequence_string)); +static void fallback_free(void *value) {} +static void fallback_mark(void *value) {} + +s7_pointer fallback_ref(s7_scheme *sc, s7_pointer args) {apply_error_nr(sc, car(args), cdr(args)); return(NULL);} +static s7_pointer fallback_set(s7_scheme *sc, s7_pointer args) {syntax_error_nr(sc, "attempt to set ~S?", 18, car(args)); return(NULL);} +static s7_pointer fallback_length(s7_scheme *sc, s7_pointer obj) {return(sc->F);} + + +/* -------------------------------- c-object-type -------------------------------- */ +s7_int s7_c_object_type(s7_pointer obj) {return((is_c_object(obj)) ? c_object_type(obj) : -1);} + +/* g_c_object_type is now defined in s7_scheme_predicate.c */ +#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_int s7_make_c_type(s7_scheme *sc, const char *name) /* shouldn't this be s7_make_c_object_type? */ +{ + c_object_t *c_type; + const s7_int 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 * 2; + 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)); /* Malloc+field=NULL is slightly faster here */ + sc->c_object_types[tag] = c_type; + c_type->type = tag; + c_type->scheme_name = make_permanent_string(name, safe_strlen(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); } -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 - /* (reverse v) is only slighly faster than (reverse! (copy v)) */ - const s7_pointer obj= car (args); - - switch (type (obj)) { - case T_PAIR: - return (reverse_pair_in_place (sc, obj, args)); - case T_BYTE_VECTOR: - case T_STRING: - return (string_or_byte_vector_reverse_in_place (sc, obj)); - case T_INT_VECTOR: - return (int_vector_reverse_in_place (sc, obj)); - case T_FLOAT_VECTOR: - return (float_vector_reverse_in_place (sc, obj)); - case T_COMPLEX_VECTOR: - return (complex_vector_reverse_in_place (sc, obj)); - case T_VECTOR: - return (vector_reverse_in_place (sc, obj)); - case T_NIL: - return (sc->nil); /* (reverse! ()) -> () */ - default: - return (reverse_in_place_via_method (sc, obj)); - } - return (obj); +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 (*marker)(s7_scheme *sc, s7_pointer obj)) {sc->c_object_types[tag]->gc_mark = marker;} +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_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_length(s7_scheme *sc, s7_int tag, s7_pointer (*length)(s7_scheme *sc, s7_pointer args)) +{ + sc->c_object_types[tag]->length = (length) ? length : fallback_length; /* is_sequence(c_obj) is #t so we need a length method */ } -/* -------------------------------- fill! -------------------------------- */ -static s7_pointer -pair_fill (s7_scheme* sc, - s7_pointer args) /* args=(list tree-to-fill fill-val start end) */ +void s7_c_type_set_is_equivalent(s7_scheme *sc, s7_int tag, s7_pointer (*is_equivalent)(s7_scheme *sc, s7_pointer args)) { - /* ambiguous ("tree-fill"?) but if it's like vector-fill, we just stomp on the - * top level */ - const s7_pointer obj= car (args); - const s7_pointer val= cadr (args); - s7_int i, start= 0, end, len; + sc->c_object_types[tag]->equivalent = is_equivalent; +} -#if WITH_HISTORY - if ((is_immutable_pair (obj)) && (obj != sc->eval_history1) && - (obj != sc->eval_history2)) -#else - if (is_immutable_pair (obj)) -#endif - immutable_object_error_nr ( - sc, set_elist_3 (sc, immutable_error_string, sc->fill_symbol, obj)); - if (obj == - global_value ( - sc->features_symbol)) /* (let_id(sc->curlet) == - symbol_id(sc->features_symbol)) && (obj == - local_value(sc->features_symbol))) */ - error_nr (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)) - error_nr ( - sc, sc->out_of_range_symbol, - set_elist_1 (sc, wrap_string (sc, "can't fill! *libraries*", 23))); - - len= s7_list_length (sc, obj); - end= len; - if (end < 0) end= -end; - else { - if (end == 0) end= 123123123; - } - if (!is_null (cddr (args))) { - s7_pointer 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) { - s7_pointer p; - 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); - } - i= 0; - for (s7_pointer lst= obj, slow= obj;; i++) { - if ((end > 0) && (i >= end)) return (val); - if (i >= start) set_car (lst, val); - if (!is_pair (cdr (lst))) { - if (!is_null (cdr (lst))) set_cdr (lst, val); - return (val); - } - lst= cdr (lst); - if ((i & 1) != 0) slow= cdr (slow); - if (lst == slow) 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) - - /* individual functions below check for immutable objects (rather than - * checking once for all here) because they are used elsewhere, and there are - * complications (the history lists in pair_fill for example). However, obj - * might have a setter which disallows val -- I guess we'll run that setter - * using val, to get the fill value to use (or raise an error). But here we - * have the value not the symbol/slot! - */ - const s7_pointer obj= car (args); - switch (type (obj)) { - case T_STRING: - return (g_string_fill (sc, args)); /* redundant type check here and below */ - case T_PAIR: - return (pair_fill (sc, args)); - case T_HASH_TABLE: - return (hash_table_fill (sc, args)); - - case T_NIL: - if (!is_null (cddr (args))) /* (fill! () 1 21 #\a)? */ - syntax_error_nr (sc, "fill! () ... includes indices: ~S?", 34, - cddr (args)); - return (cadr (args)); /* this parallels the empty vector case */ - - case T_BYTE_VECTOR: - case T_INT_VECTOR: - case T_FLOAT_VECTOR: - case T_VECTOR: - case T_COMPLEX_VECTOR: - return (s7i_vector_fill_1 (sc, sc->fill_symbol, args)); - - case T_LET: - if_let_method_exists_return_value (sc, obj, sc->fill_symbol, args); - return (let_fill (sc, args)); - - case T_C_OBJECT: - if_c_object_method_exists_return_value (sc, obj, sc->fill_symbol, args); - if (!c_object_fill (sc, obj)) /* default is NULL (s7_make_c_type) */ - syntax_error_nr (sc, "attempt to fill ~S?", 19, obj); - return ((*(c_object_fill (sc, obj))) (sc, args)); - - default: - if_method_exists_return_value (sc, obj, sc->fill_symbol, args); - } - wrong_type_error_nr (sc, sc->fill_symbol, 1, obj, - a_sequence_string); /* (fill! 1 0) */ - return (NULL); +/* the next three functions would ideally be deprecated, but much old code depends on them (they were accidentally documented forever) */ +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; } -#define g_fill s7_fill - -/* -------------------------------- append -------------------------------- */ -static s7_int -total_sequence_length (s7_scheme* sc, s7_pointer args, s7_pointer caller, - uint8_t typ) { - s7_pointer seqs= args; - s7_int len = 0; - for (s7_int i= 1; is_pair (seqs); seqs= cdr (seqs), i++) { - const s7_pointer seq= car (seqs); - const s7_int 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_error_nr (sc, caller, i, seq, sc->type_names[typ]); - if (n < 0) - wrong_type_error_nr (sc, caller, i, seq, - (is_pair (seq)) ? a_proper_list_string - : a_sequence_string); - len+= n; - } - return (len); -} - -s7_pointer -s7i_vector_append (s7_scheme* sc, s7_pointer args, uint8_t typ, - s7_pointer caller) { - s7_pointer new_vec, p= args, pargs, vtyper= NULL; - s7_pointer* v_elements = NULL; - s7_double* fv_elements = NULL; - s7_complex* cv_elements = NULL; - s7_int* iv_elements = NULL; - uint8_t* byte_elements= NULL; - s7_int len; - bool typed; - - gc_protect_via_stack (sc, args); - len= total_sequence_length ( - sc, args, caller, - (typ == T_VECTOR) - ? T_FREE - : ((typ == T_COMPLEX_VECTOR) - ? T_COMPLEX - : ((typ == T_FLOAT_VECTOR) ? T_REAL : T_INTEGER))); - if (len > sc->max_vector_length) { - unstack_gc_protect (sc); - error_nr (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_integer (sc, len), - wrap_integer (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 (??) */ - typed= (typ == T_VECTOR); - set_gc_protected2 (sc, new_vec); - add_vector (sc, new_vec); - if (len == 0) { - unstack_gc_protect (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 if (typ == T_COMPLEX_VECTOR) - cv_elements= complex_vector_complexes (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); */ - set_gc_protected3 (sc, pargs); - for (s7_int i= 0; is_pair (p); - p= cdr (p)) /* in-place copy by goofing (temporarily) with new_vec's - elements pointer */ - { - const s7_pointer vec= car (p); - const s7_int n = sequence_length (sc, vec); - if (n > 0) { - if ((typed) && (is_typed_t_vector (vec))) { - if (!vtyper) vtyper= typed_vector_typer (vec); - else if (vtyper != typed_vector_typer (vec)) typed= false; - } - else typed= false; - vector_length (new_vec)= n; - set_car (pargs, vec); - 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 if (typ == T_COMPLEX_VECTOR) - complex_vector_complexes (new_vec)= (s7_complex*) (cv_elements + i); - else byte_vector_bytes (new_vec)= (uint8_t*) (byte_elements + i); - } - } - /* unstack_gc_protect(sc); */ - 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 if (typ == T_COMPLEX_VECTOR) - complex_vector_complexes (new_vec)= cv_elements; - else byte_vector_bytes (new_vec)= byte_elements; - vector_length (new_vec)= len; - if ((typed) && (vtyper)) { - set_typed_vector (new_vec); - typed_vector_set_typer (new_vec, vtyper); - } - unstack_gc_protect (sc); - return (new_vec); -} - -static s7_pointer -hash_table_append (s7_scheme* sc, s7_pointer args) { - s7_pointer new_table, key_typer= NULL, value_typer= NULL; - bool typed= true; - gc_protect_via_stack (sc, args); - check_stack_size (sc); - new_table= s7_make_hash_table (sc, sc->default_hash_table_length); - set_gc_protected2 (sc, new_table); - for (s7_pointer seqs= args; is_pair (seqs); seqs= cdr (seqs)) { - const s7_pointer seq= car (seqs); - if (!sequence_is_empty (sc, seq)) { - /* perhaps check seq-length+hash_table_entries(new_table) > - * sc->max_vector_length here? */ - s7_copy_1 (sc, sc->append_symbol, set_plist_2 (sc, seq, new_table)); - if ((typed) && (is_hash_table (seq)) && (is_typed_hash_table (seq))) { - if (!key_typer) { /* the equality/mapping procedures are either partly - implicit or in hash-table-procedures -- a bit of a - mess currently */ - key_typer = hash_table_key_typer (seq); - value_typer= hash_table_value_typer (seq); - } - else if ((hash_table_key_typer (seq) != key_typer) || - (hash_table_value_typer (seq) != value_typer)) - typed= false; - } - else typed= false; - } - } - if ((typed) && (key_typer)) { - hash_table_set_procedures (new_table, make_hash_table_procedures (sc)); - set_is_typed_hash_table (new_table); - hash_table_set_key_typer (new_table, key_typer); - hash_table_set_value_typer (new_table, value_typer); - } - if (is_weak_hash_table ( - car (args))) /* 16-May-23, args gc protected above, should we limit - weak-hash result to pure weak-hash args? */ - { - set_weak_hash_table (new_table); - weak_hash_iters (new_table)= 0; - } - set_plist_2 (sc, sc->nil, sc->nil); - unstack_gc_protect (sc); - return (new_table); -} - -static s7_pointer -let_append (s7_scheme* sc, s7_pointer args) { - s7_pointer new_let; - const s7_pointer let= car (args); - if_let_method_exists_return_value (sc, let, sc->append_symbol, args); - gc_protect_via_stack (sc, args); - new_let= make_let (sc, sc->rootlet); - set_gc_protected2 (sc, new_let); - for (s7_pointer seqs= args; is_pair (seqs); seqs= cdr (seqs)) - if (!sequence_is_empty (sc, car (seqs))) - s7_copy_1 (sc, sc->append_symbol, set_plist_2 (sc, car (seqs), new_let)); - set_plist_2 (sc, sc->nil, sc->nil); - unstack_gc_protect (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: - return (g_list_append (sc, cdr (args))); - case T_PAIR: - return (g_list_append (sc, args)); - case T_STRING: - return (s7i_string_append_1 (sc, args, sc->append_symbol)); - /* should this work in the generic append: (append "12" #\3) -- currently an - * error, (append (list 1 2) 3) -> '(1 2 . 3), but vector is error */ - 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: - case T_COMPLEX_VECTOR: - return (s7i_vector_append (sc, args, type (car (args)), sc->append_symbol)); - case T_C_OBJECT: - if_c_object_method_exists_return_value (sc, car (args), sc->append_symbol, - args); - break; - default: - if_method_exists_return_value (sc, car (args), sc->append_symbol, args); - } - wrong_type_error_nr (sc, sc->append_symbol, 1, car (args), - a_sequence_string); /* (append 1 0) */ - return (NULL); -} - -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; - if ((!is_pair (b)) && (!is_null (b))) - return (g_list_append (sc, list_2 (sc, a, b))); - sc->temp9= a; /* tempx? */ - q = list_1 (sc, car (a)); - begin_temp (sc->temp6, q); - p = cdr (a); - np= q; - for (s7_pointer op= a; (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))); - } - end_temp (sc->temp6); - if (!is_null (p)) - wrong_type_error_nr (sc, sc->append_symbol, 1, a, a_proper_list_string); - sc->temp9= sc->unused; - set_cdr (np, b); - return (q); - } - if (is_null (a)) return (b); - return (g_append (sc, set_plist_2 (sc, a, b))); +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) ? gc_free : fallback_free; } -static s7_pointer -append_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer unused_expr) { - if (args == 2) return (sc->append_2); - return (func); +void s7_c_type_set_mark(s7_scheme *sc, s7_int tag, void (*mark)(void *value)) +{ + sc->c_object_types[tag]->mark = (mark) ? mark : fallback_mark; } -/* -------------------------------- object->let -------------------------------- - */ -static s7_pointer -byte_vector_to_list (s7_scheme* sc, const uint8_t* str, s7_int len) { - if (len == 0) return (sc->nil); - check_free_heap_size (sc, len); - begin_temp (sc->y, sc->nil); - for (s7_int i= len - 1; i >= 0; i--) - sc->y= cons_unchecked (sc, small_int ((uint32_t) (str[i])), sc->y); - return_with_end_temp (sc->y); -} - -static s7_pointer -hash_table_to_list (s7_scheme* sc, s7_pointer obj) { - s7_pointer iterator; - if (hash_table_entries (obj) == 0) return (sc->nil); - iterator= s7_make_iterator (sc, obj); - gc_protect_via_stack (sc, iterator); - begin_temp (sc->y, sc->nil); - while (true) { - s7_pointer entry= s7_iterate (sc, iterator); - if (iterator_is_at_end (iterator)) break; - sc->y= cons (sc, entry, sc->y); - } - unstack_gc_protect (sc); - return_with_end_temp (sc->y); -} - -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) { - const s7_pointer val= s7_iterate (sc, obj); - if ((val == sc->iterator_at_end_value) && (iterator_is_at_end (obj))) { - if (is_pair (result)) unstack_gc_protect (sc); - 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; - } - gc_protect_via_stack (sc, result); /* unstacked above */ - } - 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); - } - } - } +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) ? ref : fallback_ref; + sc->c_object_types[tag]->outer_type = (sc->c_object_types[tag]->ref == fallback_ref) ? T_C_OBJECT : (T_C_OBJECT | T_SAFE_PROCEDURE); } -static s7_pointer -c_obj_to_list (s7_scheme* sc, - s7_pointer obj) /* "c_object_to_list" is the ->list method - mentioned below */ +void s7_c_type_set_getter(s7_scheme *sc, s7_int tag, s7_pointer getter) { - s7_int len; - s7_pointer obj_len, lst, lst2, ref_index, result; - s7_int gc_lst2; - - if (c_object_to_list (sc, obj)) - return ((*(c_object_to_list (sc, obj))) (sc, set_plist_1 (sc, obj))); - - obj_len= c_object_length (sc, obj); - if (!s7_is_integer (obj_len)) return (sc->F); - len= s7_integer_clamped_if_gmp (sc, obj_len); - if (len < 0) return (sc->F); - if (len == 0) return (sc->nil); - - result = make_list (sc, len, sc->nil); - sc->temp7= result; - ref_index= - wrap_mutable_integer (sc, 0); /* was make_mutable_integer 17-Nov-23 */ - lst2 = list_2_unchecked (sc, obj, ref_index); - gc_lst2= gc_protect_1 (sc, lst2); - lst = result; - for (s7_int i= 0; i < len; i++, lst= cdr (lst)) { - set_integer (ref_index, i); - set_car (lst, (*(c_object_ref (sc, obj))) (sc, lst2)); - } - s7_gc_unprotect_at (sc, gc_lst2); - sc->temp7= sc->unused; - 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: - case T_COMPLEX_VECTOR: - return (s7_vector_to_list (sc, obj)); - case T_LET: -#if !WITH_PURE_S7 - if_let_method_exists_return_value (sc, obj, sc->let_to_list_symbol, - set_plist_1 (sc, obj)); -#endif - return (s7_let_to_list (sc, obj)); - } - return (obj); + sc->c_object_types[tag]->getter = (getter) ? T_Fnc(getter) : sc->F; } -/* ---------------- object->let ---------------- */ -static s7_pointer -symbol_to_let (s7_scheme* sc, s7_pointer sym) { - const s7_pointer let= internal_inlet ( - sc, 4, sc->value_symbol, sym, sc->type_symbol, - (is_keyword (sym)) - ? sc->is_keyword_symbol - : ((is_gensym (sym)) ? sc->is_gensym_symbol : sc->is_symbol_symbol)); - if (!is_keyword (sym)) { - const s7_int gc_loc= gc_protect_1 (sc, let); - const s7_pointer val = s7_symbol_value (sc, sym); - if (!sc->current_value_symbol) - sc->current_value_symbol= make_symbol (sc, "current-value", 13); - s7_varlet (sc, let, sc->current_value_symbol, val); - s7_varlet (sc, let, sc->setter_symbol, setter_p_pp (sc, sym, sc->curlet)); - s7_varlet (sc, let, sc->is_mutable_symbol, - make_boolean (sc, !is_immutable_symbol (sym))); - if (!is_undefined (val)) { - const char* doc= s7_documentation (sc, sym); - if (doc) - s7_varlet (sc, let, sc->local_documentation_symbol, - s7_make_string (sc, doc)); - } - s7_gc_unprotect_at (sc, gc_loc); - } - return (let); +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) ? set : fallback_set; } -static s7_pointer -random_state_to_let (s7_scheme* sc, s7_pointer rs) { - if (!sc->seed_symbol) { - sc->seed_symbol = make_symbol (sc, "seed", 4); - sc->carry_symbol= make_symbol (sc, "carry", 5); - } - return (internal_inlet (sc, 8, sc->value_symbol, rs, sc->type_symbol, - sc->is_random_state_symbol, sc->seed_symbol, - make_integer (sc, random_seed (rs)), sc->carry_symbol, - make_integer (sc, random_carry (rs)))); +void s7_c_type_set_setter(s7_scheme *sc, s7_int tag, s7_pointer setter) +{ + sc->c_object_types[tag]->setter = (setter) ? T_Fnc(setter) : sc->F; } -static s7_pointer -vector_to_let (s7_scheme* sc, s7_pointer vec) { - s7_pointer let; - if (!sc->dimensions_symbol) - sc->dimensions_symbol= make_symbol (sc, "dimensions", 10); - if (!sc->original_vector_symbol) - sc->original_vector_symbol= make_symbol (sc, "original-vector", 15); - let= internal_inlet ( - sc, 10, sc->value_symbol, vec, sc->type_symbol, - (is_subvector (vec)) ? cons (sc, sc->is_subvector_symbol, - s7_type_of (sc, subvector_vector (vec))) - : s7_type_of (sc, vec), - sc->size_symbol, s7_length (sc, vec), sc->dimensions_symbol, - g_vector_dimensions (sc, set_plist_1 (sc, vec)), sc->is_mutable_symbol, - make_boolean (sc, !is_immutable_vector (vec))); - gc_protect_via_stack (sc, let); - if (is_subvector (vec)) { - s7_int pos= 0; - switch (type (vec)) /* 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 (vec) - - vector_elements (subvector_vector (vec)))); - break; - case T_INT_VECTOR: - pos= (s7_int) ((intptr_t) (int_vector_ints (vec) - - int_vector_ints (subvector_vector (vec)))); - break; - case T_FLOAT_VECTOR: - pos= (s7_int) ((intptr_t) (float_vector_floats (vec) - - float_vector_floats (subvector_vector (vec)))); - break; - case T_COMPLEX_VECTOR: - pos= (s7_int) (( - intptr_t) (complex_vector_complexes (vec) - - complex_vector_complexes (subvector_vector (vec)))); - break; - case T_BYTE_VECTOR: - pos= (s7_int) ((intptr_t) (byte_vector_bytes (vec) - - byte_vector_bytes (subvector_vector (vec)))); - break; - } - s7_varlet (sc, let, sc->position_symbol, make_integer (sc, pos)); - s7_varlet (sc, let, sc->original_vector_symbol, subvector_vector (vec)); - } - if (is_typed_t_vector (vec)) - s7_varlet (sc, let, sc->signature_symbol, - g_signature (sc, set_plist_1 (sc, vec))); -#if S7_DEBUGGING - if ((is_t_vector (vec)) && - (is_symbol_table (vec))) /* (object->let (symbol-table)) */ - { - s7_int max_len= 0, zeros= 0, ones= 0, twos= 0, biggies= 0; - for (s7_int i= 0; i < SYMBOL_TABLE_SIZE; i++) { - s7_int entries; - s7_pointer syms= vector_element (sc->symbol_table, i); - for (entries= 0; is_pair (syms); syms= cdr (syms), entries++) - ; - if (entries == 0) zeros++; - else if (entries == 1) ones++; - else if (entries == 2) twos++; - else biggies++; - if (entries > max_len) max_len= entries; - } - s7_varlet ( - sc, let, - make_symbol ( - sc, "symtab-stats:empty|1|2|n|most", - 29), /* "symtab-stats" to distinguish from hash-stats below */ - cons (sc, make_integer (sc, zeros), - cons (sc, make_integer (sc, ones), - cons (sc, make_integer (sc, twos), - cons (sc, make_integer (sc, biggies), - cons (sc, make_integer (sc, max_len), - sc->nil)))))); - } -#endif +/* -------------------------------- c-object-let -------------------------------- */ +s7_pointer s7_c_object_let(s7_pointer obj) {return(c_object_let(obj));} - unstack_gc_protect (sc); - return (let); -} - -static void -hash_table_checker_to_let (s7_scheme* sc, s7_pointer let, s7_pointer table) { - if ((hash_table_checker (table) == hash_eq) || - (hash_table_checker (table) == hash_c_function) || - (hash_table_checker (table) == hash_closure) || - (hash_table_checker (table) == hash_equal_eq) || - (hash_table_checker (table) == hash_equal_syntax) || - (hash_table_checker (table) == hash_symbol)) - s7_varlet (sc, let, sc->function_symbol, sc->is_eq_symbol); - else if (hash_table_checker (table) == hash_eqv) - s7_varlet (sc, let, sc->function_symbol, sc->is_eqv_symbol); - else if ((hash_table_checker (table) == hash_equal) || - (hash_table_checker (table) == hash_empty)) - s7_varlet (sc, let, sc->function_symbol, sc->is_equal_symbol); - else if (hash_table_checker (table) == hash_equivalent) - s7_varlet (sc, let, sc->function_symbol, sc->is_equivalent_symbol); - else if ((hash_table_checker (table) == hash_number_num_eq) || - (hash_table_checker (table) == hash_int) || - (hash_table_checker (table) == hash_float)) - s7_varlet (sc, let, sc->function_symbol, sc->num_eq_symbol); - else if (hash_table_checker (table) == hash_string) - s7_varlet (sc, let, sc->function_symbol, sc->string_eq_symbol); - else if (hash_table_checker (table) == hash_char) - s7_varlet (sc, let, sc->function_symbol, sc->char_eq_symbol); -} - -static s7_pointer -hash_table_to_let (s7_scheme* sc, s7_pointer table) { - s7_pointer let; - s7_int gc_loc; - if (!sc->entries_symbol) { - sc->entries_symbol= make_symbol (sc, "entries", 7); - sc->weak_symbol = make_symbol (sc, "weak", 4); - } - let = internal_inlet (sc, 10, sc->value_symbol, table, sc->type_symbol, - sc->is_hash_table_symbol, sc->size_symbol, - s7_length (sc, table), sc->entries_symbol, - make_integer (sc, hash_table_entries (table)), - sc->is_mutable_symbol, - make_boolean (sc, !is_immutable_hash_table (table))); - gc_loc= gc_protect_1 (sc, let); - if (is_weak_hash_table (table)) s7_varlet (sc, let, sc->weak_symbol, sc->T); - - if (is_typed_hash_table (table)) { - const s7_pointer checker= hash_table_procedures_checker (table); - if (checker == sc->T) /* perhaps typed because typers were set, but not - checker/mapper */ - hash_table_checker_to_let (sc, let, table); - else - s7_varlet (sc, let, sc->function_symbol, - list_2 (sc, checker, hash_table_procedures_mapper (table))); - s7_varlet ( - sc, let, sc->signature_symbol, - (is_typed_hash_table (table)) - ? list_3 ( - sc, - hash_table_typer_symbol (sc, hash_table_value_typer (table)), - sc->is_hash_table_symbol, - hash_table_typer_symbol (sc, hash_table_key_typer (table))) - : sc->hash_table_signature); - } - else hash_table_checker_to_let (sc, let, table); +/* g_c_object_let is now defined in s7_scheme_predicate.c */ +#define H_c_object_let "(c-object-let obj) returns the c_object's local let, if any." +#define Q_c_object_let s7_make_signature(sc, 2, sc->is_let_symbol, sc->is_c_object_symbol) -#if S7_DEBUGGING - if (hash_table_entries (table) > 0) { - s7_int max_len= 0, zeros= 0, ones= 0, twos= 0, biggies= 0; - const s7_int hash_len= (s7_int) hash_table_size (table); - for (s7_int i= 0; i < hash_len; i++) { - hash_entry_t* entry= hash_table_element (table, i); - s7_int entries; - for (entries= 0; entry; entry= hash_entry_next (entry), entries++) - ; - if (entries == 0) zeros++; - else if (entries == 1) ones++; - else if (entries == 2) twos++; - else biggies++; - if (entries > max_len) max_len= entries; - } - s7_varlet (sc, let, make_symbol (sc, "hash-stats:empty|1|2|n|most", 27), - cons (sc, make_integer (sc, zeros), - cons (sc, make_integer (sc, ones), - cons (sc, make_integer (sc, twos), - cons (sc, make_integer (sc, biggies), - cons (sc, make_integer (sc, max_len), - sc->nil)))))); - } -#endif - s7_gc_unprotect_at (sc, gc_loc); - return (let); +s7_pointer s7_c_object_set_let(s7_scheme *sc, s7_pointer cobj, s7_pointer let) +{ + if ((!is_immutable(cobj)) && (is_let(let))) + c_object_set_let(cobj, let); + return(let); } -static s7_pointer -iterator_to_let (s7_scheme* sc, s7_pointer iter) { - s7_pointer let; - const s7_pointer seq= iterator_sequence (iter); - if (!sc->at_end_symbol) { - sc->at_end_symbol = make_symbol (sc, "at-end", 6); - sc->sequence_symbol= make_symbol (sc, "sequence", 8); - } - let= internal_inlet (sc, 8, sc->value_symbol, iter, sc->type_symbol, - sc->is_iterator_symbol, sc->at_end_symbol, - make_boolean (sc, iterator_is_at_end (iter)), - sc->sequence_symbol, iterator_sequence (iter)); - gc_protect_via_stack (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, iter)); - 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 (iter))); - else if (is_pair (seq)) - s7_varlet (sc, let, sc->position_symbol, iterator_current (iter)); - unstack_gc_protect (sc); - return (let); -} - -static s7_pointer -let_to_let (s7_scheme* sc, s7_pointer let) { - /* 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 new_let; - s7_int gc_loc; - if (!sc->open_symbol) { - sc->open_symbol = make_symbol (sc, "open", 4); - sc->alias_symbol= make_symbol (sc, "alias", 5); - } - new_let= internal_inlet ( - sc, 12, sc->value_symbol, let, sc->type_symbol, sc->is_let_symbol, - sc->size_symbol, s7_length (sc, let), sc->open_symbol, - make_boolean (sc, is_openlet (let)), sc->outlet_symbol, - (let == sc->rootlet) ? sc->nil : let_outlet (let), sc->is_mutable_symbol, - make_boolean (sc, !is_immutable_let (let))); - gc_loc= gc_protect_1 (sc, new_let); - if (let == sc->rootlet) - s7_varlet (sc, new_let, sc->alias_symbol, sc->rootlet_symbol); - else /* owlet can't happen, I think -- it is always copied first */ - if (is_funclet (let)) { - s7_varlet (sc, new_let, sc->function_symbol, funclet_function (let)); - if ((has_let_file (let)) && - (let_file (let) <= (s7_int) sc->file_names_top) && - (let_line (let) > 0) && (let_line (let) < 1000000)) { - s7_varlet (sc, new_let, sc->file_symbol, - sc->file_names[let_file (let)]); - s7_varlet (sc, new_let, sc->line_symbol, - make_integer (sc, let_line (let))); - } - } - else if (let == sc->starlet) { - const s7_pointer iter = s7_make_iterator (sc, let); - const s7_int gc_loc1= gc_protect_1 (sc, iter); - while (true) { - s7_pointer starlet_field= s7_iterate (sc, iter); - if (iterator_is_at_end (iter)) break; - s7_varlet (sc, new_let, car (starlet_field), cdr (starlet_field)); - } - s7_gc_unprotect_at (sc, gc_loc1); - } - if (has_active_methods (sc, let)) { - s7_pointer func= find_method (sc, let, sc->object_to_let_symbol); - if (func != sc->undefined) - s7_apply_function (sc, func, set_plist_2 (sc, let, new_let)); - } - s7_gc_unprotect_at (sc, gc_loc); - return (new_let); -} - -static s7_pointer -c_object_to_let (s7_scheme* sc, s7_pointer cobj) { - s7_pointer let; - const s7_pointer clet= c_object_let (cobj); - if (!sc->class_symbol) sc->class_symbol= make_symbol (sc, "class", 5); - let= internal_inlet (sc, 8, sc->value_symbol, cobj, sc->type_symbol, - sc->is_c_object_symbol, sc->c_object_type_symbol, - make_integer (sc, c_object_type (cobj)), - sc->c_object_let_symbol, clet); - gc_protect_via_stack (sc, let); - g_varlet (sc, set_plist_3 (sc, let, sc->class_symbol, - c_object_type_to_let (sc, cobj))); - if ((is_let (clet)) && - ((has_active_methods (sc, clet)) || (has_active_methods (sc, cobj)))) { - s7_pointer func= find_method (sc, clet, sc->object_to_let_symbol); - if (func != sc->undefined) - s7_apply_function (sc, func, set_plist_2 (sc, cobj, let)); - } - unstack_gc_protect (sc); - return (let); +static s7_pointer g_c_object_set_let(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer cobj = car(args), let = cadr(args); + if (is_immutable(cobj)) + immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't set ~S's let: it is immutable", 35), cobj)); + if (!is_let(let)) + wrong_type_error_nr(sc, make_symbol(sc, "#", 19), 2, let, sc->type_names[T_LET]); + c_object_set_let(cobj, let); + return(let); } -static s7_pointer -port_to_let (s7_scheme* sc, s7_pointer port) /* note the underbars! */ + +/* -------------------------------- c-object-set -------------------------------- */ +static s7_pointer g_c_object_set(s7_scheme *sc, s7_pointer args) /* called in sc->c_object_set_function */ { - s7_pointer let; - s7_int gc_loc; - if (!sc->data_symbol) { - sc->data_symbol = make_symbol (sc, "data", 4); - sc->port_type_symbol= make_symbol (sc, "port-type", 9); - sc->closed_symbol = make_symbol (sc, "closed", 6); - sc->file_info_symbol= make_symbol (sc, "file-info", 9); - } - let= internal_inlet ( - sc, 10, sc->value_symbol, port, - /* port as 'value means it will say "(closed)" when subsequently the let - is displayed */ - sc->type_symbol, - (is_input_port (port)) ? sc->is_input_port_symbol - : sc->is_output_port_symbol, - sc->port_type_symbol, - (is_string_port (port)) - ? sc->string_symbol - : ((is_file_port (port)) ? sc->file_symbol : sc->function_symbol), - sc->closed_symbol, make_boolean (sc, port_is_closed (port)), - sc->is_mutable_symbol, make_boolean (sc, !is_immutable_port (port))); - gc_loc= gc_protect_1 (sc, let); - if (is_file_port (port)) { - s7_varlet (sc, let, sc->file_symbol, - g_port_filename (sc, set_plist_1 (sc, port))); - if (is_input_port (port)) - s7_varlet (sc, let, sc->line_symbol, - g_port_line_number (sc, set_plist_1 (sc, port))); -#if !MS_WINDOWS - if ((!port_is_closed (port)) && (port != sc->standard_error) && - (port != sc->standard_input) && (port != sc->standard_output)) { - struct stat sb; - s7_varlet (sc, let, sc->file_symbol, - make_integer (sc, fileno (port_file (port)))); - if (fstat (fileno (port_file (port)), &sb) != -1) { - char c1[64], c2[64], str[512]; - int32_t 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%u, 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 (port)) && /* file port might not have a data buffer */ - (port_data (port)) && (port_data_size (port) > 0)) { - s7_int pos= port_position (port), size= port_data_size (port); - s7_varlet (sc, let, sc->size_symbol, make_integer (sc, size)); - s7_varlet (sc, let, sc->position_symbol, make_integer (sc, pos)); - /* 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. This field is confusing; perhaps show a window around the - * current data position? - */ - { - const char* data= (const char*) port_data (port); - char data_str[24], str[24]; - int32_t i, bytes, lim= (size > 16) ? 16 : size; - for (i= 0; i < lim; i++) - data_str[i]= data[i]; - data_str[i]= '\0'; - bytes= snprintf (str, 24, "%s%s", data_str, (size > 16) ? "..." : ""); - s7_varlet (sc, let, sc->data_symbol, - make_string_with_length (sc, str, bytes)); - } - } - if (is_function_port (port)) - s7_varlet (sc, let, sc->function_symbol, port_string_or_function (port)); - s7_gc_unprotect_at (sc, gc_loc); - return (let); -} - -static s7_pointer -closure_to_let (s7_scheme* sc, s7_pointer func) { - const char* doc= s7_documentation (sc, func); - const s7_pointer sig= s7_signature (sc, func); - const s7_pointer let= internal_inlet ( - sc, 8, sc->value_symbol, func, sc->type_symbol, - (is_t_procedure (func)) ? sc->is_procedure_symbol : sc->is_macro_symbol, - sc->arity_symbol, s7_arity (sc, func), sc->is_mutable_symbol, - make_boolean (sc, !is_immutable (func))); - gc_protect_via_stack (sc, let); - if (is_pair (sig)) s7_varlet (sc, let, sc->local_signature_symbol, sig); - if (doc) - s7_varlet (sc, let, sc->local_documentation_symbol, - s7_make_string (sc, doc)); - if (is_let (closure_let (func))) { - s7_pointer flet= closure_let (func); - 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_or_map_list (func) != sc->F) - s7_varlet (sc, let, sc->local_setter_symbol, - closure_setter_or_map_list (func)); - - if (!sc->source_symbol) sc->source_symbol= make_symbol (sc, "source", 6); - s7_varlet ( - sc, let, sc->source_symbol, - append_in_place (sc, - list_2 (sc, procedure_type_to_symbol (sc, type (func)), - closure_pars (func)), - closure_body (func))); - unstack_gc_protect (sc); - return (let); -} - -static s7_pointer -c_pointer_to_let (s7_scheme* sc, s7_pointer cptr) { - /* 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", 6); - sc->info_symbol = make_symbol (sc, "info", 4); - } - if (!sc->pointer_symbol) sc->pointer_symbol= make_symbol (sc, "pointer", 7); - return ( - internal_inlet (sc, 10, sc->value_symbol, cptr, sc->type_symbol, - sc->is_c_pointer_symbol, sc->pointer_symbol, - make_integer (sc, (s7_int) ((intptr_t) c_pointer (cptr))), - sc->c_type_symbol, c_pointer_type (cptr), sc->info_symbol, - c_pointer_info (cptr))); -} - -static s7_pointer -c_function_to_let (s7_scheme* sc, s7_pointer cfunc) { - const char* doc= s7_documentation (sc, cfunc); - const s7_pointer sig= c_function_signature (cfunc); - const s7_pointer let= internal_inlet ( - sc, 8, sc->value_symbol, cfunc, sc->type_symbol, - (is_t_procedure (cfunc)) ? sc->is_procedure_symbol : sc->is_macro_symbol, - sc->arity_symbol, s7_arity (sc, cfunc), sc->is_mutable_symbol, - make_boolean (sc, !is_immutable (cfunc))); - gc_protect_via_stack (sc, let); - if (is_pair (sig)) s7_varlet (sc, let, sc->local_signature_symbol, sig); - if (doc) - s7_varlet (sc, let, sc->local_documentation_symbol, - s7_make_string (sc, doc)); - if (c_function_setter (cfunc) != - sc->F) /* c_macro_setter is the same underlying field */ - s7_varlet (sc, let, sc->local_setter_symbol, c_function_setter (cfunc)); - unstack_gc_protect (sc); - return (let); -} - -static s7_pointer -goto_to_let (s7_scheme* sc, s7_pointer go) { - /* 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", 6); - if (is_symbol (call_exit_name (go))) - return (internal_inlet (sc, 8, sc->value_symbol, go, sc->type_symbol, - sc->is_goto_symbol, sc->active_symbol, - make_boolean (sc, call_exit_active (go)), - sc->name_symbol, call_exit_name (go))); - return (internal_inlet (sc, 6, sc->value_symbol, go, sc->type_symbol, - sc->is_goto_symbol, sc->active_symbol, - make_boolean (sc, call_exit_active (go)))); -} - -static s7_pointer -object_to_let_p_p (s7_scheme* sc, s7_pointer obj) { - switch (type (obj)) { - case T_NIL: - return (internal_inlet (sc, 4, sc->value_symbol, obj, sc->type_symbol, - sc->is_null_symbol)); - case T_UNSPECIFIED: - return (internal_inlet (sc, 4, sc->value_symbol, obj, sc->type_symbol, - sc->is_unspecified_symbol)); - case T_UNDEFINED: - return (internal_inlet (sc, 4, sc->value_symbol, obj, sc->type_symbol, - sc->is_undefined_symbol)); - case T_EOF: - return (internal_inlet (sc, 4, sc->value_symbol, obj, sc->type_symbol, - sc->is_eof_object_symbol)); - case T_BOOLEAN: - return (internal_inlet (sc, 4, sc->value_symbol, obj, sc->type_symbol, - sc->is_boolean_symbol)); - case T_CHARACTER: - return (internal_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_INPUT_PORT: - case T_OUTPUT_PORT: - return (port_to_let (sc, obj)); - - case T_INTEGER: - return (internal_inlet (sc, 4, sc->value_symbol, obj, sc->type_symbol, - sc->is_integer_symbol)); - case T_RATIO: - return (internal_inlet (sc, 4, sc->value_symbol, obj, sc->type_symbol, - sc->is_rational_symbol)); - case T_REAL: - return (internal_inlet (sc, 4, sc->value_symbol, obj, sc->type_symbol, - sc->is_real_symbol)); - case T_COMPLEX: - return (internal_inlet (sc, 4, sc->value_symbol, obj, sc->type_symbol, - sc->is_complex_symbol)); - - case T_STRING: - return (internal_inlet (sc, 8, sc->value_symbol, obj, sc->type_symbol, - sc->is_string_symbol, sc->size_symbol, - str_length (sc, obj), sc->is_mutable_symbol, - make_boolean (sc, !is_immutable_string (obj)))); - case T_PAIR: - return (internal_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 (internal_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: - case T_COMPLEX_VECTOR: - return (vector_to_let (sc, obj)); - - case T_CONTINUATION: /* perhaps include the continuation-key */ - if (is_symbol (continuation_name (obj))) - return (internal_inlet (sc, 6, sc->value_symbol, obj, sc->type_symbol, - sc->is_continuation_symbol, sc->name_symbol, - continuation_name (obj))); - return (internal_inlet (sc, 4, sc->value_symbol, obj, sc->type_symbol, - sc->is_continuation_symbol)); - - 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_RST_NO_REQ_FUNCTION: - return (c_function_to_let (sc, obj)); - - default: - return (sc->F); - } - return (sc->F); + s7_pointer obj = car(args); + if (!is_c_object(obj)) /* (call/cc (setter (block))) will call c-object-set! with the continuation as the argument! */ + wrong_type_error_nr(sc, make_symbol(sc, "c-object-set!", 13), 1, obj, sc->type_names[T_C_OBJECT]); + return((*(c_object_set(sc, obj)))(sc, args)); } -/* g_object_to_let is now defined in s7_scheme_predicate.c */ -#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) +void *s7_c_object_value(s7_pointer obj) {return(c_object_value(obj));} -/* bridge functions for s7_scheme_predicate.c migration (round 2) */ -s7_pointer -s7i_c_pointer_weak1_p_p (s7_scheme* sc, s7_pointer cptr) { - return (c_pointer_weak1_p_p (sc, cptr)); +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); } -s7_pointer -s7i_c_pointer_weak2_p_p (s7_scheme* sc, s7_pointer cptr) { - return (c_pointer_weak2_p_p (sc, cptr)); + +static s7_pointer make_c_object_with_let(s7_scheme *sc, s7_int type, void *value, s7_pointer let, bool with_gc) +{ + s7_pointer obj; + new_cell(sc, obj, sc->c_object_types[type]->outer_type); + /* c_object_info(obj) = &(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(obj) = type; + c_object_value(obj) = value; + c_object_set_let(obj, T_Let(let)); + c_object_sc(obj) = sc; + if (with_gc) add_c_object(sc, obj); + return(obj); } -s7_pointer -s7i_tree_leaves_p_p (s7_scheme* sc, s7_pointer p) { - return (tree_leaves_p_p (sc, p)); + +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 -s7i_cyclic_sequences_p_p (s7_scheme* sc, s7_pointer p) { - return (cyclic_sequences_p_p (sc, p)); + +s7_pointer s7_make_c_object(s7_scheme *sc, s7_int type, void *value) +{ + return(make_c_object_with_let(sc, type, value, sc->rootlet, true)); } -s7_pointer -s7i_object_to_let_p_p (s7_scheme* sc, s7_pointer p) { - return (object_to_let_p_p (sc, p)); + +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->rootlet, false)); } -s7_pointer -s7i_pair_line_number_p_p (s7_scheme* sc, s7_pointer p) { - return (pair_line_number_p_p (sc, p)); + +static s7_pointer c_object_length(s7_scheme *sc, s7_pointer obj) +{ + return((*(c_object_len(sc, obj)))(sc, set_clist_1(sc, obj))); } -s7_pointer -s7i_reverse_p_p (s7_scheme* sc, s7_pointer p) { - return (reverse_p_p (sc, p)); + +static s7_int c_object_length_to_int(s7_scheme *sc, s7_pointer obj) +{ + s7_pointer result = (*(c_object_len(sc, obj)))(sc, set_clist_1(sc, obj)); + if (s7_is_integer(result)) + return(s7_integer_clamped_if_gmp(sc, result)); + return(-1); } -s7_pointer -s7i_port_line_number_p_p (s7_scheme* sc, s7_pointer p) { - return (port_line_number_p_p (sc, p)); + +static s7_pointer copy_c_object(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer obj = car(args); + if_c_object_method_exists_return_value(sc, obj, sc->copy_symbol, args); + if (!c_object_copy(sc, obj)) + missing_method_error_nr(sc, sc->copy_symbol, obj); + return((*(c_object_copy(sc, obj)))(sc, args)); } -bool -s7i_tree_memq_b_7pp (s7_scheme* sc, s7_pointer sym, s7_pointer tree) { - return (tree_memq_b_7pp (sc, sym, tree)); + +static s7_pointer c_object_type_to_let(s7_scheme *sc, s7_pointer cobj) +{ + const s7_int type = c_object_type(cobj); + c_object_t *c_type = sc->c_object_types[type]; + return(internal_inlet(sc, 6, + sc->name_symbol, c_type->scheme_name, + make_symbol(sc, "getter", 6), s7_object_to_string(sc, c_type->getter, false), + sc->setter_symbol, s7_object_to_string(sc, c_type->setter, false))); + /* can't display equal et al in c_types -- maybe sc->F or the pointer? or add getter equivalent fields for equal et al? */ } -bool -s7i_tree_set_memq_b_7pp (s7_scheme* sc, s7_pointer syms, s7_pointer tree) { - return (tree_set_memq_b_7pp (sc, syms, tree)); + +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); } -s7_pointer -s7i_unlet_disabled (s7_scheme* sc) { - return (sc->unlet_disabled); + +static bool op_implicit_c_object_ref_a(s7_scheme *sc) +{ + const s7_pointer cobj = lookup_checked(sc, car(sc->code)); + if (!is_c_object(cobj)) {sc->last_function = cobj; return(false);} + set_car(sc->t2_2, fx_call(sc, cdr(sc->code))); + set_car(sc->t2_1, cobj); /* fx_call above might use sc->t2* */ + sc->value = (*(c_object_ref(sc, cobj)))(sc, sc->t2_1); + return(true); } -s7_pointer -s7i_curlet (s7_scheme* sc) { - return (sc->curlet); + +static s7_pointer fx_implicit_c_object_ref_a(s7_scheme *sc, s7_pointer arg) +{ + const s7_pointer cobj = lookup_checked(sc, car(arg)); + if (!is_c_object(cobj)) + return(s7_apply_function(sc, cobj, list_1(sc, fx_call(sc, cdr(arg))))); + set_car(sc->t2_2, fx_call(sc, cdr(arg))); + set_car(sc->t2_1, cobj); /* fx_call above might use sc->t2* */ + return((*(c_object_ref(sc, cobj)))(sc, sc->t2_1)); } -void -s7i_capture_let_counter_inc (s7_scheme* sc) { - sc->capture_let_counter++; + +/* We could add implicit c-pointer ref/set referring to its let, but that seems confusing -- c-object-ref|set! would be different */ + + +/* -------- dilambda -------- */ + +s7_pointer s7_dilambda_with_environment(s7_scheme *sc, s7_pointer let, + 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, name_len; + if (!name) return(sc->F); + name_len = safe_strlen(name); + len = 16 + name_len; + internal_set_name = (char *)permalloc(sc, len); + internal_set_name[0] = '\0'; + catstrs_direct(internal_set_name, "#", (const char *)NULL); /* was using #\[, 4-June-25 */ + get_func = s7_make_safe_function(sc, name, getter, get_req_args, get_opt_args, false, documentation); + s7_define(sc, T_Let(let), make_symbol(sc, name, name_len), get_func); + set_func = s7_make_safe_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->rootlet, name, getter, get_req_args, get_opt_args, setter, set_req_args, set_opt_args, documentation)); } -bool -s7i_is_defined_in_rootlet (s7_scheme* sc, s7_pointer sym) { - return ((is_slot (global_slot (sym))) && - (global_value (sym) != sc->undefined)); + +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 = s7_dilambda(sc, name, getter, get_req_args, get_opt_args, setter, set_req_args, set_opt_args, documentation); + s7_pointer set_func = c_function_setter(get_func); + if (get_sig) c_function_set_signature(get_func, get_sig); + if (set_sig) c_function_set_signature(set_func, set_sig); + return(get_func); } -/* ---------------- stacktrace ---------------- */ -static s7_pointer -stacktrace_find_caller (s7_scheme* sc, s7_pointer let) { - if ((is_let (let)) && (let != sc->rootlet)) - return (((is_funclet (let)) || (is_maclet (let))) - ? funclet_function (let) - : stacktrace_find_caller (sc, let_outlet (let))); - return (sc->F); + +/* -------------------------------- dilambda? -------------------------------- */ +bool s7_is_dilambda(s7_pointer func) +{ + if (has_closure_let(func)) + return(is_any_procedure(closure_setter_or_map_list(func))); /* type >= T_CLOSURE (excludes goto/continuation) */ + if (is_any_c_function(func)) + return(is_any_procedure(c_function_setter(func))); /* type >= T_C_FUNCTION_STAR */ + if (is_c_macro(func)) + return(is_any_procedure(c_macro_setter(func))); + return(false); } -static bool -stacktrace_find_let (s7_scheme* sc, s7_int loc, s7_pointer let) { - return ((loc > 0) && ((stack_let (sc->stack, loc) == let) || - (stacktrace_find_let (sc, loc - 4, let)))); +/* g_is_dilambda is now defined in s7_scheme_predicate.c */ +#define H_is_dilambda "(dilambda? obj) returns #t if obj is a procedure with setter." +#define Q_is_dilambda sc->pl_bt + + +/* -------------------------------- 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) + + const s7_pointer getter = car(args), setter = cadr(args); + if (!is_any_procedure(getter)) + wrong_type_error_nr(sc, sc->dilambda_symbol, 1, getter, a_procedure_or_a_macro_string); + if (!is_any_procedure(setter)) + wrong_type_error_nr(sc, sc->dilambda_symbol, 2, setter, a_procedure_or_a_macro_string); + s7_set_setter(sc, getter, setter); + return(getter); } -static s7_int -stacktrace_find_error_hook_quit (s7_scheme* sc) { - for (s7_int op_loc= stack_top (sc) - 1; op_loc >= 3; op_loc-= 4) - if (stack_op (sc->stack, op_loc) == OP_ERROR_HOOK_QUIT) return (op_loc); - return (-1); + +/* -------------------------------- arity -------------------------------- */ +static s7_pointer closure_arity_to_cons(s7_scheme *sc, s7_pointer clo, s7_pointer clo_args) +{ + /* clo_args is unprocessed -- it is exactly the list as used in the closure[*] definition */ + int32_t len; + if (is_symbol(clo_args)) /* any number of args is ok */ + return(cons(sc, int_zero, max_arity)); + if (closure_arity_unknown(clo)) + closure_set_arity(clo, s7_list_length(sc, clo_args)); + len = closure_arity(clo); + 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_unchecked(sc, len))); } -static bool -stacktrace_in_error_handler (s7_scheme* sc, s7_int 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 void closure_star_arity_1(s7_scheme *sc, s7_pointer clo, s7_pointer args) +{ + if (closure_arity_unknown(clo)) + { + if (is_null(args)) + closure_set_arity(clo, 0); + else + if ((is_symbol(args)) || (allows_other_keys(args))) + closure_set_arity(clo, -1); + else + { + s7_pointer pars; + int32_t i; + for (i = 0, pars = args; is_pair(pars); i++, pars = cdr(pars)) /* is_pair(pars) so (f1 a . b) will end with b not null */ + if (car(pars) == sc->rest_keyword) + break; + closure_set_arity(clo, ((is_null(pars)) ? i : -1)); /* see below */ + }} +} + +static s7_pointer closure_star_arity_to_cons(s7_scheme *sc, s7_pointer clo, s7_pointer clo_args) +{ + closure_star_arity_1(sc, clo, clo_args); + return((closure_arity(clo) == -1) ? cons(sc, int_zero, max_arity) : cons(sc, int_zero, make_integer(sc, closure_arity(clo)))); } -static bool -stacktrace_error_hook_function (s7_scheme* sc, s7_pointer sym) { - if (is_symbol (sym)) { - s7_pointer func= s7_symbol_value (sc, sym); - return ((is_procedure (func)) && (hook_has_functions (sc->error_hook)) && - (direct_memq (func, s7_hook_functions (sc, sc->error_hook)))); - } - return (false); -} - -static char* -stacktrace_walker (s7_scheme* sc, s7_pointer code, s7_pointer let, 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_small_symbol_set (sc, code)) && - (!is_slot (global_slot (code)))) { - const s7_pointer val= s7_symbol_local_value (sc, code, let); - add_symbol_to_small_symbol_set (sc, code); - if ((val) && (val != sc->undefined) && (!is_any_macro (val)) && - (type (val) < T_CONTINUATION)) { - char* objstr; - s7_pointer objp; - s7_int new_note_len, notes_max; - bool new_notes_line = false; - const bool old_short_print= sc->short_print; - const s7_int old_len = sc->print_length; - s7_int objlen; - - 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) { - const char* last_newline= strrchr ( - notes, - (int) '\n'); /* returns ptr to end if none = nil if not found? */ - s7_int cur_line_len= (last_newline) - ? (strlen (notes) - strlen (last_newline)) - : strlen (notes); - new_notes_line = ((cur_line_len + new_note_len) > notes_max); - } - { - char* str; - if (new_notes_line) { - const char* spaces= " " - " "; - const s7_int spaces_len= 80; - 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) - ? (const 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), let, notes, code_cols, total_cols, - notes_start_col, as_comment, depth + 1); - return (stacktrace_walker (sc, cdr (code), let, 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 caller, s7_pointer code, - const char* errstr, char* notes, s7_int code_max, - bool as_comment) { - s7_int newlen, errlen= strlen (errstr); - char* newstr; - block_t* newp; - if ((is_symbol (caller)) && (caller != car (code))) { - newlen= symbol_name_length (caller) + errlen + 10; - newp = mallocate (sc, newlen); - newstr= (char*) block_data (newp); /* newstr[0] = '\0'; */ - errlen= catstrs_direct (newstr, symbol_name (caller), ": ", 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, (const void*) errstr, errlen); - newstr[errlen]= '\0'; - } - } - newlen= code_max + 8 + ((notes) ? strlen (notes) : 0); - { - block_t* b = mallocate (sc, newlen); - char* 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 */ - const s7_int 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 int32_t closure_arity_to_int(s7_scheme *sc, s7_pointer clo) +{ + /* not lambda* here */ + if (closure_arity_unknown(clo)) + { + int32_t i; + s7_pointer pars = closure_pars(clo); + for (i = 0; is_pair(pars); i++, pars = cdr(pars)) {}; + if (is_null(pars)) + closure_set_arity(clo, i); + else + { + if (i == 0) + return(-1); + closure_set_arity(clo, -i); + }} + return(closure_arity(clo)); } -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; - s7_int loc, frames= 0; - s7_int top= (sc->stack_end - sc->stack_start) / - 4; /* (*s7* 'stack_top), not stack_top(sc)! */ - begin_small_symbol_set (sc); - - if (stacktrace_in_error_handler (sc, top)) { - const s7_pointer err_code= slot_value (sc->error_code); - if ((is_pair (err_code)) && (!tree_is_cyclic (sc, err_code))) { - char* notes = NULL; - const s7_pointer current_let= let_outlet (sc->owlet); - const s7_pointer errstr = s7_object_to_string (sc, err_code, false); - const s7_pointer caller= - 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, caller, err_code, string_value (errstr), - notes, code_cols, as_comment); - str = (char*) block_data (strp); - if ((S7_DEBUGGING) && (notes == str)) - fprintf (stderr, "%s[%d]: notes==str\n", __func__, __LINE__); - if (notes) - free (notes); /* copied into strp, 29-Sep-23 -- see below: maybe check - that notes!=str? */ - } - loc= stacktrace_find_error_hook_quit ( - sc); /* if OP_ERROR_HOOK_QUIT is in the stack, jump past it! */ - if (loc > 0) top= (loc + 1) / 4; - } - for (loc= top - 1; loc > 0; loc--) { - const s7_int true_loc= (loc + 1) * 4 - 1; - const s7_pointer code = stack_code (sc->stack, true_loc); - if ((is_pair (code)) && (!tree_is_cyclic (sc, code))) { - const s7_pointer codep= s7_object_to_string (sc, code, false); - if (string_length (codep) > 0) { - const char* codestr= string_value (codep); - if ((!local_strcmp (codestr, "(result)")) && - (!local_strcmp (codestr, "(#f)")) && - (!strstr (codestr, "(stacktrace)")) && - (!strstr (codestr, "(stacktrace "))) { - const s7_pointer let= stack_let ( - sc->stack, - true_loc); /* might not be let (gc stack protection etc) */ - const s7_pointer func= stacktrace_find_caller (sc, let); - if (!stacktrace_error_hook_function (sc, func)) { - char * notes= NULL, *newstr, *catstr; - block_t *newp, *catp; - s7_int newlen; - - frames++; - if (frames > frames_max) { - end_small_symbol_set (sc); - return (block_to_string ( - sc, strp, safe_strlen ((char*) block_data (strp)))); - } - if ((is_let (let)) && (let != sc->rootlet)) - notes= - stacktrace_walker (sc, code, let, NULL, code_cols, total_cols, - notes_start_col, as_comment, 0); - newp = stacktrace_add_func (sc, func, code, codestr, notes, - code_cols, as_comment); - newstr= (char*) block_data (newp); - if ((S7_DEBUGGING) && (notes == newstr)) - fprintf (stderr, "%s[%d]: notes=newstr\n", __func__, __LINE__); - if ((notes) && (notes != newstr) && (is_let (let)) && - (let != 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); - } - } - } - } - } - end_small_symbol_set (sc); - 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, s7_integer_clamped_if_gmp (sc, car (sc->stacktrace_defaults)), - s7_integer_clamped_if_gmp (sc, cadr (sc->stacktrace_defaults)), - s7_integer_clamped_if_gmp (sc, caddr (sc->stacktrace_defaults)), - s7_integer_clamped_if_gmp (sc, cadddr (sc->stacktrace_defaults)), - s7_boolean (sc, s7_list_ref (sc, sc->stacktrace_defaults, 4)))); -} - -static s7_pointer -g_stacktrace (s7_scheme* sc, s7_pointer args) { -#define H_stacktrace \ - "(stacktrace (max-frames 30) (code-cols 45) (total-cols 80) (note-col 45) 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) - -/* now: 30, 45, 80, 45, #f and applied here as well as in s7_stacktrace, - * 22-Jan-25 */ -#define ST_MAX_FRAMES 30 -#define ST_CODE_COLS 45 -#define ST_TOTAL_COLS 80 -#define ST_NOTES_START_COL 45 -#define ST_AS_COMMENT false - - s7_int max_frames= - s7_integer_clamped_if_gmp (sc, car (sc->stacktrace_defaults)); - s7_int code_cols= - s7_integer_clamped_if_gmp (sc, cadr (sc->stacktrace_defaults)); - s7_int total_cols= - s7_integer_clamped_if_gmp (sc, caddr (sc->stacktrace_defaults)); - s7_int notes_start_col= - s7_integer_clamped_if_gmp (sc, cadddr (sc->stacktrace_defaults)); - bool as_comment= - s7_boolean (sc, s7_list_ref (sc, sc->stacktrace_defaults, 4)); - - if (!is_null (args)) { - if (!s7_is_integer (car (args))) - return (method_or_bust (sc, car (args), sc->stacktrace_symbol, args, - sc->type_names[T_INTEGER], 1)); - max_frames= s7_integer_clamped_if_gmp (sc, car (args)); - if ((max_frames <= 0) || (max_frames > S7_INT32_MAX)) - max_frames= ST_MAX_FRAMES; - args= cdr (args); - if (!is_null (args)) { - if (!s7_is_integer (car (args))) - wrong_type_error_nr (sc, sc->stacktrace_symbol, 2, car (args), - sc->type_names[T_INTEGER]); - code_cols= s7_integer_clamped_if_gmp (sc, car (args)); - if ((code_cols <= 8) || (code_cols > 1024)) code_cols= ST_CODE_COLS; - args= cdr (args); - if (!is_null (args)) { - if (!s7_is_integer (car (args))) - wrong_type_error_nr (sc, sc->stacktrace_symbol, 3, car (args), - sc->type_names[T_INTEGER]); - total_cols= s7_integer_clamped_if_gmp (sc, car (args)); - if ((total_cols <= code_cols) || (total_cols > S7_INT32_MAX)) - total_cols= ST_TOTAL_COLS; - args= cdr (args); - if (!is_null (args)) { - if (!s7_is_integer (car (args))) - wrong_type_error_nr (sc, sc->stacktrace_symbol, 4, car (args), - sc->type_names[T_INTEGER]); - notes_start_col= s7_integer_clamped_if_gmp (sc, car (args)); - if ((notes_start_col <= 0) || (notes_start_col > S7_INT32_MAX)) - notes_start_col= ST_NOTES_START_COL; - args= cdr (args); - if (!is_null (args)) { - if (!is_boolean (car (args))) - wrong_type_error_nr (sc, sc->stacktrace_symbol, 5, car (args), - sc->type_names[T_BOOLEAN]); - as_comment= s7_boolean (sc, car (args)); - } - } - } - } - } - return (stacktrace_1 (sc, max_frames, code_cols, total_cols, notes_start_col, - as_comment)); +static int32_t closure_star_arity_to_int(s7_scheme *sc, s7_pointer clo) +{ + /* not lambda here */ + closure_star_arity_1(sc, clo, closure_pars(clo)); + return(closure_arity(clo)); } -/* -------- s7_history, s7_add_to_history, s7_history_enabled -------- */ +static s7_pointer c_object_arity_to_int(s7_scheme *sc, s7_pointer obj) +{ + if_c_object_method_exists_return_value(sc, obj, sc->arity_symbol, set_plist_1(sc, obj)); + return((is_safe_procedure(obj)) ? cons(sc, int_zero, max_arity) : sc->F); +} -s7_pointer -s7_add_to_history (s7_scheme* sc, s7_pointer entry) { -#if WITH_HISTORY - set_current_code (sc, entry); -#endif - return (entry); +static s7_pointer vector_arity_to_int(s7_scheme *sc, s7_pointer obj) +{ + if (vector_length(obj) == 0) return(sc->F); + if (has_simple_elements(obj)) return(cons(sc, int_one, make_integer(sc, vector_rank(obj)))); + return(cons(sc, int_one, max_arity)); } -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); +static s7_pointer syntax_arity_to_int(s7_scheme *sc, s7_pointer obj) +{ + return(cons(sc, small_int(syntax_min_args(obj)), + (syntax_max_args(obj) == MAX_ARITY) ? max_arity : small_int(syntax_max_args(obj)))); } -bool -s7_history_enabled (s7_scheme* sc) { -#if WITH_HISTORY - return (sc->cur_code != sc->history_sink); -#else - return (false); -#endif +s7_pointer s7_arity(s7_scheme *sc, s7_pointer obj) +{ + switch (type(obj)) + { + case T_C_FUNCTION: return(cons(sc, make_integer(sc, c_function_min_args(obj)), make_integer_unchecked(sc, c_function_max_args(obj)))); + case T_C_RST_NO_REQ_FUNCTION: return(cons(sc, int_zero, max_arity)); + case T_C_FUNCTION_STAR: return(cons(sc, int_zero, make_integer(sc, c_function_max_args(obj)))); + case T_CLOSURE: + case T_MACRO: case T_BACRO: return(closure_arity_to_cons(sc, obj, closure_pars(obj))); + case T_CLOSURE_STAR: + case T_MACRO_STAR: case T_BACRO_STAR: return(closure_star_arity_to_cons(sc, obj, closure_pars(obj))); + case T_C_MACRO: return(cons(sc, make_integer(sc, c_macro_min_args(obj)), make_integer_unchecked(sc, c_macro_max_args(obj)))); + case T_C_OBJECT: return(c_object_arity_to_int(sc, obj)); + 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_GOTO: case T_CONTINUATION: return(cons(sc, int_zero, max_arity)); + case T_STRING: return((string_length(obj) == 0) ? sc->F : cons(sc, int_one, int_one)); + case T_LET: return(cons(sc, int_one, int_one)); + case T_SYNTAX: return(syntax_arity_to_int(sc, obj)); + case T_VECTOR: return(vector_arity_to_int(sc, obj)); + case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_BYTE_VECTOR: case T_COMPLEX_VECTOR: + return((vector_length(obj) == 0) ? sc->F : cons(sc, int_one, make_integer(sc, vector_rank(obj)))); + } + return(sc->F); } -bool -s7_set_history_enabled (s7_scheme* sc, bool enabled) { -#if WITH_HISTORY - const bool 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 +/* g_arity is now defined in s7_scheme_predicate.c */ + #define H_arity "(arity obj) the min and max number of args that obj can be applied to. Returns #f if the object is not applicable." + #define Q_arity s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol), sc->T) + + +/* -------------------------------- aritable? -------------------------------- */ +static bool closure_is_aritable(s7_scheme *sc, s7_pointer clo, s7_pointer clo_args, int32_t args) +{ + /* clo_args is unprocessed -- it is exactly the list as used in the closure definition */ + s7_int len; + if (args == 0) return(!is_pair(clo_args)); + if (is_symbol(clo_args)) return(true); /* any number of args is ok */ + len = closure_arity(clo); + if (len == CLOSURE_ARITY_NOT_SET) + { + len = s7_list_length(sc, clo_args); + closure_set_arity(clo, 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 */ } -#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_unchecked (p, args); - return (p); +static bool closure_star_is_aritable(s7_scheme *sc, s7_pointer clo, s7_pointer clo_args, int32_t args) +{ + if (is_symbol(clo_args)) + return(true); + closure_star_arity_1(sc, clo, clo_args); + return((closure_arity(clo) == -1) || (args <= closure_arity(clo))); } -#else -#define history_cons(Sc, Code, Args) Code -#endif -/* -------------------------------- profile -------------------------------- */ -static void -swap_stack (s7_scheme* sc, opcode_t new_op, s7_pointer new_code, - s7_pointer new_args) { - s7_pointer code, args, let; - opcode_t op; - sc->stack_end-= 4; - code= stack_end_code (sc); - let = stack_end_let (sc); - args= stack_end_args (sc); - op = (opcode_t) T_Op (stack_end_op (sc)); - if ((S7_DEBUGGING) && (op != OP_BEGIN_NO_HOOK) && (op != OP_BEGIN_HOOK)) - fprintf (stderr, "%s[%d]: swap %s in %s\n", __func__, __LINE__, - op_names[op], display (s7_name_to_value (sc, "estr"))); - push_stack (sc, new_op, new_args, new_code); - stack_end_code (sc)= code; - stack_end_let (sc) = let; - stack_end_args (sc)= args; - stack_end_op (sc) = (s7_pointer) op; - sc->stack_end+= 4; +static bool c_object_is_aritable(s7_scheme *sc, s7_pointer clo, int32_t args) +{ + s7_pointer func; + if ((has_active_methods(sc, clo)) && + ((func = find_method_with_c_object(sc, clo, sc->is_aritable_symbol)) != sc->undefined)) + return(s7_apply_function(sc, func, set_plist_2(sc, clo, make_integer(sc, args))) != sc->F); + return((is_safe_procedure(clo)) && (args == 1)); /* can we get the arity from clo? */ } -static s7_pointer -find_funclet (s7_scheme* sc, s7_pointer let) { - if ((let == sc->rootlet) || (!is_let (let))) return (sc->F); - if (!((is_funclet (let)) || (is_maclet (let)))) let= let_outlet (let); - if ((let == sc->rootlet) || (!is_let (let))) return (sc->F); - return (((is_funclet (let)) || (is_maclet (let))) ? let : sc->F); +bool s7_is_aritable(s7_scheme *sc, s7_pointer clo, s7_int args) +{ + switch (type(clo)) + { + case T_C_FUNCTION: return(c_function_is_aritable(clo, args)); + case T_C_RST_NO_REQ_FUNCTION: if (has_even_args(clo)) return((args & 1) == 0); return(true); + case T_C_FUNCTION_STAR: return(c_function_max_args(clo) >= args); + case T_CLOSURE: + case T_MACRO: case T_BACRO: return(closure_is_aritable(sc, clo, closure_pars(clo), args)); + case T_CLOSURE_STAR: + case T_MACRO_STAR: case T_BACRO_STAR: return(closure_star_is_aritable(sc, clo, closure_pars(clo), args)); + case T_C_MACRO: return((c_macro_min_args(clo) <= args) && (c_macro_max_args(clo) >= args)); + case T_GOTO: case T_CONTINUATION: return(true); + case T_STRING: return((args == 1) && (string_length(clo) > 0)); /* ("" 0) -> error */ + case T_ITERATOR: return(args == 0); + case T_SYNTAX: return((args >= syntax_min_args(clo)) && (args <= syntax_max_args(clo))); + case T_HASH_TABLE: return(args == 1); /* refers to implicit ref (table key) */ + case T_LET: case T_PAIR: return(args == 1); + case T_C_OBJECT: return(c_object_is_aritable(sc, clo, args)); + case T_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_BYTE_VECTOR: case T_COMPLEX_VECTOR: + return((args > 0) && (vector_length(clo) > 0) && (args <= vector_rank(clo))); /* (#() 0) -> error */ + } + 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 num_args = cadr(args); + s7_int num; + if (!s7_is_integer(num_args)) /* remember gmp case! */ + return(method_or_bust(sc, num_args, sc->is_aritable_symbol, args, sc->type_names[T_INTEGER], 2)); + num = s7_integer_clamped_if_gmp(sc, num_args); + if (num < 0) + out_of_range_error_nr(sc, sc->is_aritable_symbol, int_two, num_args, it_is_negative_string); + if (num > MAX_ARITY) num = MAX_ARITY; + return(make_boolean(sc, s7_is_aritable(sc, car(args), num))); } -#define PD_INITIAL_SIZE 16 -enum { pd_calls= 0, pd_recur, pd_start, pd_itotal, pd_etotal, pd_block_size }; +static bool is_aritable_b_7pp(s7_scheme *sc, s7_pointer func, s7_pointer num_args) {return(g_is_aritable(sc, set_plist_2(sc, func, num_args)) != sc->F);} -static s7_pointer -g_profile_out (s7_scheme* sc, s7_pointer args) { - const s7_int pos= integer (car (args)) * pd_block_size; - profile_data_t* pd = sc->profile_data; - s7_int* v = (s7_int*) (pd->timing_data + pos); - v[pd_recur]--; - if (v[pd_recur] == 0) { - const s7_int 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, 3, sc->T, sc->is_integer_symbol, sc->is_let_symbol) - - s7_pointer let; - const s7_int pos= integer (car (args)); - if (sc->profile == 0) return (sc->F); - - let= find_funclet (sc, cadr (args)); - if ((is_let (let)) && (is_symbol (funclet_function (let)))) { - const s7_pointer func_name= funclet_function (let); - s7_int* timing_data; - profile_data_t* pd= sc->profile_data; - if (pos >= pd->size) { - const s7_int new_size= 2 * pos; - pd->funcs= - (s7_pointer*) Realloc (pd->funcs, new_size * sizeof (s7_pointer)); - memclr ((void*) (pd->funcs + pd->size), - (new_size - pd->size) * sizeof (s7_pointer)); - pd->timing_data= (s7_int*) Realloc ( - pd->timing_data, new_size * pd_block_size * sizeof (s7_int)); - memclr ((void*) (pd->timing_data + (pd->size * pd_block_size)), - (new_size - pd->size) * pd_block_size * sizeof (s7_int)); - pd->let_names= - (s7_pointer*) Realloc (pd->let_names, new_size * sizeof (s7_pointer)); - memclr ((void*) (pd->let_names + pd->size), - (new_size - pd->size) * sizeof (s7_pointer)); - pd->files= - (s7_pointer*) Realloc (pd->files, new_size * sizeof (s7_pointer)); - memclr ((void*) (pd->files + pd->size), - (new_size - pd->size) * sizeof (s7_pointer)); - pd->lines= (s7_int*) Realloc (pd->lines, new_size * sizeof (s7_int)); - memclr ((void*) (pd->lines + pd->size), - (new_size - pd->size) * sizeof (s7_int)); - pd->size= new_size; - } - if (pd->funcs[pos] == NULL) { - pd->funcs[pos]= func_name; - if (is_gensym (func_name)) sc->profiling_gensyms= true; - if (pos >= pd->top) pd->top= (pos + 1); - - /* perhaps add_profile needs to reuse ints if file/line exists? */ - if (is_symbol (sc->profile_prefix)) { - s7_pointer let_name= - s7_symbol_local_value (sc, sc->profile_prefix, let); - if (is_symbol (let_name)) pd->let_names[pos]= let_name; - } - if (has_let_file (let)) { - pd->files[pos]= sc->file_names[let_file (let)]; - pd->lines[pos]= let_line (let); - } - } - timing_data= - (s7_int*) (sc->profile_data->timing_data + (pos * pd_block_size)); - timing_data[pd_calls]++; - if (timing_data[pd_recur] == 0) { - timing_data[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; +static int32_t arity_to_int(s7_scheme *sc, s7_pointer clo) +{ + int32_t args; + switch (type(clo)) + { + case T_C_FUNCTION: case T_C_FUNCTION_STAR: return(c_function_max_args(clo)); + case T_C_RST_NO_REQ_FUNCTION: return(MAX_ARITY); + case T_CLOSURE: + case T_MACRO: case T_BACRO: args = closure_arity_to_int(sc, clo); return((args < 0) ? MAX_ARITY : args); + case T_CLOSURE_STAR: + case T_MACRO_STAR: case T_BACRO_STAR: args = closure_star_arity_to_int(sc, clo); return((args < 0) ? MAX_ARITY : args); + case T_C_MACRO: return(c_macro_max_args(clo)); + /* case T_C_OBJECT: return(MAX_ARITY); */ /* this currently can't be called */ + /* vectors et al don't make sense here -- this is called only in g_set_setter below where it is restricted to is_any_procedure (type>=T_CLOSURE) */ } - timing_data[pd_recur]++; + if (S7_DEBUGGING) fprintf(stderr, "%s -1\n", __func__); + return(-1); /* unreachable I think */ +} - /* 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) - error_nr ( - sc, make_symbol (sc, "stack-too-big", 13), - set_elist_2 ( - sc, - wrap_string (sc, "profiling stack size has grown past ~D", 38), - wrap_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, car (args)); - } - return (sc->F); -} - -static s7_pointer -profile_info_out (s7_scheme* sc) { - s7_pointer new_list, vs, vi, vn, vf, vl, matches; - profile_data_t* pd= sc->profile_data; - if ((!pd) || (pd->top == 0)) return (sc->F); - new_list= make_list (sc, 7, sc->F); - set_car (sc->elist_7, new_list); /* protect new_list */ - set_car (new_list, vs= make_simple_vector (sc, pd->top)); - set_car (cdr (new_list), - vi= make_simple_int_vector (sc, pd->top * pd_block_size)); - set_car (cddr (new_list), make_integer (sc, ticks_per_second ())); - { - s7_pointer mid_list= cdddr (new_list); - set_car (mid_list, vn= make_simple_vector (sc, pd->top)); - set_car (cdr (mid_list), vf= make_simple_vector (sc, pd->top)); - set_car (cddr (mid_list), vl= make_simple_int_vector (sc, pd->top)); - matches= cdddr (mid_list); - } - set_car (matches, sc->nil); - for (s7_int i= 0; i < pd->top; i++) { - if (pd->funcs[i]) { - vector_element (vs, i)= pd->funcs[i]; - if ((is_matched_symbol (pd->funcs[i])) && /* find ambiguous names */ - (!direct_memq (pd->funcs[i], car (matches)))) - set_car (matches, cons (sc, pd->funcs[i], car (matches))); - set_match_symbol (pd->funcs[i]); - } - else vector_element (vs, i)= sc->F; - vector_element (vn, i)= (!pd->let_names[i]) ? sc->F : pd->let_names[i]; - vector_element (vf, i)= (!pd->files[i]) ? sc->F : pd->files[i]; - } - for (s7_int i= 0; i < pd->top; i++) - if (pd->funcs[i]) clear_match_symbol (pd->funcs[i]); - memcpy ((void*) int_vector_ints (vl), (void*) pd->lines, - pd->top * sizeof (s7_int)); - memcpy ((void*) int_vector_ints (vi), (void*) pd->timing_data, - pd->top * pd_block_size * sizeof (s7_int)); - set_car (sc->elist_7, sc->unused); - return (new_list); -} - -static s7_pointer -clear_profile_info (s7_scheme* sc) { - if (sc->profile_data) { - profile_data_t* pd= sc->profile_data; - memclr (pd->timing_data, pd->top * pd_block_size * sizeof (s7_int)); - memclr (pd->funcs, pd->top * sizeof (s7_pointer)); - memclr (pd->let_names, pd->top * sizeof (s7_pointer)); - memclr (pd->files, pd->top * sizeof (s7_pointer)); - memclr (pd->lines, pd->top * sizeof (s7_int)); - pd->top= 0; - for (int32_t 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= (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->let_names = (s7_pointer*) Calloc (pd->size, sizeof (s7_pointer)); - pd->files = (s7_pointer*) Calloc (pd->size, sizeof (s7_pointer)); - pd->lines = (s7_int*) Calloc (pd->size, sizeof (s7_int)); - pd->excl = (s7_int*) Calloc (pd->excl_size, sizeof (s7_int)); - pd->timing_data= - (s7_int*) Calloc (pd->size * pd_block_size, sizeof (s7_int)); - sc->profile_data= pd; - } - return (sc->F); -} - -/* -------------------------------- dynamic-unwind - * -------------------------------- */ -s7_pointer -dynamic_unwind (s7_scheme* sc, s7_pointer func, s7_pointer args) { - return (s7_apply_function ( - sc, func, - set_plist_2 (sc, args, - sc->value))); /* s7_apply_function returns sc->value */ -} - -static s7_pointer -g_dynamic_unwind (s7_scheme* sc, s7_pointer args) /* not fool-proof!! */ -{ -#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, 4, sc->is_procedure_symbol, sc->is_procedure_symbol, \ - sc->T, sc->is_boolean_symbol) - - const s7_pointer func = car (args); - const s7_pointer dw_call= (is_pair (cddr (args))) ? caddr (args) : sc->F; - if (!is_boolean (dw_call)) - wrong_type_error_nr (sc, sc->dynamic_unwind_symbol, 2, dw_call, - a_boolean_string); - if (((is_closure (func)) && (closure_arity_to_int (sc, func) == 2)) || - ((is_c_function (func)) && (c_function_is_aritable (func, 2))) || - ((is_closure_star (func)) && - (closure_star_arity_to_int (sc, func) == 2)) || - ((is_c_function_star (func)) && (c_function_max_args (func) == 2))) - swap_stack (sc, OP_DYNAMIC_UNWIND, func, copy_proper_list (sc, cdr (args))); - else - wrong_type_error_nr (sc, sc->dynamic_unwind_symbol, 1, func, - wrap_string (sc, "a procedure of two arguments", 28)); - return (cadr (args)); /* ?? */ + +/* -------------------------------- sequence? -------------------------------- */ +/* g_is_sequence is now defined in s7_scheme_predicate.c */ +#define H_is_sequence "(sequence? obj) returns #t if obj is a sequence (vector, string, pair, etc)" +#define Q_is_sequence sc->pl_bt + +static bool is_sequence_b(s7_pointer seq) {return(is_simple_sequence(seq));} + + +/* -------------------------------- setter ------------------------------------------------ */ +s7_pointer b_simple_setter(s7_scheme *sc, int32_t typer, s7_pointer args) /* see bool_defun -> define_bool_function */ +{ + if (type(cadr(args)) != typer) + error_nr(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->type_names[type(cadr(args))], sc->type_names[typer])); + return(cadr(args)); +} + +/* these are for the simplified setter designation: (let ((x 1)) (set! (setter 'x) integer?) (set! x 3.14)) -> error */ + +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_byte_vector_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_BYTE_VECTOR, 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_c_pointer_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_C_POINTER, 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_eof_object_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_EOF, 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_complex_vector_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_COMPLEX_VECTOR, args));} +static s7_pointer b_is_goto_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_GOTO, 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_input_port_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_INPUT_PORT, 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_iterator_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_ITERATOR, 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_null_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_NIL, 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_pair_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_PAIR, 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_string_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_STRING, args));} +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_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));} + +#define b_setter(sc, typer, args, str, len) \ + do { \ + if (!typer(cadr(args))) \ + error_nr(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->type_names[type(cadr(args))], wrap_string(sc, str, len))); \ + return(cadr(args)); \ + } while (0) + +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_complex_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, s7_is_complex, args, "a number", 8);} +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_float_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_t_real, args, "a float", 7);} +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_integer_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, s7_is_integer, args, "an integer", 10);} +static s7_pointer b_is_keyword_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_symbol_and_keyword, args, "a keyword", 9);} +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_macro_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_any_macro, args, "a macro", 7);} +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_openlet_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, has_methods, args, "an open let", 11);} +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_rational_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_rational, args, "a rational", 10);} +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_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_vector_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_any_vector, args, "a vector", 8);} +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))) + error_nr(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->type_names[type(cadr(args))], wrap_string(sc, "a proper list", 13))); + 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 proc, err; +static s7_pointer lambda_setter(s7_scheme *sc, s7_pointer clo) +{ + if (is_any_procedure(closure_setter_or_map_list(clo))) /* setter already known */ + return(closure_setter(clo)); + if (is_pair(closure_setter_or_map_list(clo))) /* it's a map_list masquerading as a setter */ + return(sc->F); + if (!closure_no_setter(clo)) + { + const s7_pointer setter = funclet_entry(sc, clo, sc->local_setter_symbol); /* look for +setter+, save value as closure_setter(clo) */ + if (setter) + { + if (setter == sc->F) + { + closure_set_no_setter(clo); + return(sc->F); + } + if (!is_any_procedure(setter)) + sole_arg_wrong_type_error_nr(sc, sc->setter_symbol, clo, wrap_string(sc, "a procedure or a reasonable facsimile thereof", 45)); + closure_set_setter(clo, setter); + return(setter); + } + /* 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(clo); + } + return(sc->F); +} - /* 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. I think log as the second arg is - * an outer error (we don't wait until the catch is called, then fall into the - * local error handler). - */ - /* if ((is_let(err)) && (is_openlet(err))) - * if_let_method_exists_return_value(sc, err, sc->catch_symbol, args); */ /* causes exit from s7! */ - if (SHOW_EVAL_OPS) fprintf (stderr, " %s[%d]\n", __func__, __LINE__); - - if (!is_pair (cdr ( - args))) /* (let ((mlet (openlet (inlet 'abs catch)))) (abs mlet)) -- - this is a special case, avoid calling this everywhere */ - error_nr (sc, sc->syntax_error_symbol, - set_elist_2 (sc, - wrap_string (sc, "catch: function missing: ~S", 27), - set_ulist_1 (sc, sc->catch_symbol, args))); - proc= cadr (args); - if (!is_thunk (sc, proc)) { - if (is_any_procedure (proc)) /* i.e. c_function, lambda, macro, etc */ - { - s7_pointer req_args= - wrap_integer (sc, procedure_required_args (sc, proc)); - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_4 (sc, - wrap_string (sc, - "~A requires ~D argument~P, but catch's " - "second argument should be a thunk", - 72), - proc, req_args, req_args)); - } - else wrong_type_error_nr (sc, sc->catch_symbol, 2, proc, a_thunk_string); - } - if (!is_pair (cddr (args))) - error_nr (sc, sc->syntax_error_symbol, - set_elist_2 ( - sc, wrap_string (sc, "catch: error handler missing: ~S", 32), - set_ulist_1 (sc, sc->catch_symbol, args))); - err= caddr (args); - if (!is_applicable (err)) - wrong_type_error_nr (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 - */ - { - s7_pointer new_catch; - new_cell (sc, new_catch, T_CATCH); - catch_tag (new_catch) = car (args); - catch_goto_loc (new_catch)= stack_top (sc); - catch_op_loc (new_catch) = (int32_t) (sc->op_stack_now - sc->op_stack); - catch_set_handler (new_catch, err); - catch_cstack (new_catch)= sc->goto_start; - push_stack (sc, (intptr_t) ((is_any_macro (err)) ? OP_CATCH_2 : OP_CATCH), - args, new_catch); - } - if (is_closure (proc)) /* not also lambda* here because we need to handle the - arg defaults */ +static s7_pointer symbol_setter(s7_scheme *sc, s7_pointer sym, s7_pointer let) +{ + s7_pointer slot; + if (is_keyword(sym)) return(sc->F); + if (let == sc->rootlet) + slot = global_slot(sym); + else + { + s7_pointer old_let = sc->curlet; + set_curlet(sc, let); + slot = s7_slot(sc, sym); + set_curlet(sc, old_let); + } + if ((!is_slot(slot)) || (!slot_has_setter(slot))) return(sc->F); { - /* 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_pars (proc))) - set_curlet (sc, make_let_with_slot (sc, closure_let (proc), - closure_pars (proc), sc->nil)); - else set_curlet (sc, inline_make_let (sc, closure_let (proc))); - push_stack_no_args_direct (sc, sc->begin_op); + s7_pointer setter = slot_setter(slot); + if ((is_any_procedure(setter)) && (is_bool_function(setter))) return(c_function_setter(setter)); + return(setter); } - 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 new_catch, result; - if (sc->stack_end == sc->stack_start) /* no stack! */ - push_stack_direct (sc, OP_EVAL_DONE); - - if (SHOW_EVAL_OPS) fprintf (stderr, " %s[%d]\n", __func__, __LINE__); - new_cell (sc, new_catch, T_CATCH); - catch_tag (new_catch) = tag; - catch_goto_loc (new_catch)= stack_top (sc); - catch_op_loc (new_catch) = (int32_t) (sc->op_stack_now - sc->op_stack); - catch_set_handler (new_catch, error_handler); - catch_cstack (new_catch)= sc->goto_start; - { - declare_jump_info (); - TRACK (sc); - store_jump_info (sc); - set_jump_info (sc, s7_call_set_jump); - - if (SHOW_EVAL_OPS) - fprintf (stderr, "jump_loc: %s\n", jump_string[(int) jump_loc]); - if (jump_loc == no_jump) { - catch_cstack (new_catch)= &new_goto_start; - if (SHOW_EVAL_OPS) - fprintf (stderr, " longjmp call %s\n", display_truncated (body)); - push_stack (sc, OP_CATCH, error_handler, new_catch); - result= s7_call (sc, body, sc->nil); - if (stack_top_op (sc) == OP_CATCH) sc->stack_end-= 4; +static s7_pointer setter_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer let) +{ + if (!is_let(let)) + { + s7_pointer new_let = find_let(sc, let); + if ((!is_let(new_let)) || (new_let == sc->rootlet)) + find_let_error_nr(sc, sc->setter_symbol, let, new_let, 2, set_mlist_2(sc, obj, let)); + let = new_let; } - else { - if (SHOW_EVAL_OPS) - fprintf (stderr, " jump back with %s (%d)\n", - jump_string[(int) jump_loc], - (sc->stack_end == sc->stack_start)); - if (jump_loc != error_jump) eval (sc, sc->cur_op); - if ((jump_loc == - catch_jump) && /* we're returning from an error in catch */ - ((sc->stack_end == sc->stack_start) || - (((sc->stack_end - 4) == sc->stack_start) && - (stack_top_op (sc) == - OP_GC_PROTECT)))) /* s7_apply_function probably */ - push_stack_op (sc, OP_ERROR_QUIT); - result= sc->value; - } - restore_jump_info (sc); - } - return (result); -} + 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(lambda_setter(sc, obj)); -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 new_catch, tag; - const s7_pointer ptag= cadr (sc->code), args= cddr (sc->code); + case T_C_FUNCTION: case T_C_FUNCTION_STAR: case T_C_RST_NO_REQ_FUNCTION: + return(c_function_setter(obj)); - /* defer making the error lambda */ - if (!is_pair (ptag)) /* (catch #t ...) or (catch sym ...) */ - tag= (is_symbol (ptag)) ? lookup_checked (sc, ptag) : ptag; - else tag= cadr (ptag); /* (catch 'sym ...) */ - - new_cell (sc, new_catch, T_CATCH); /* the catch object sitting on the stack */ - catch_tag (new_catch) = tag; - catch_goto_loc (new_catch)= stack_top (sc); - catch_op_loc (new_catch) = sc->op_stack_now - sc->op_stack; - catch_set_handler (new_catch, cdadr (args)); /* not yet a closure... */ - catch_cstack (new_catch)= sc->goto_start; - push_stack (sc, OP_CATCH_1, sc->code, - new_catch); /* code ignored here, except by GC */ - set_curlet (sc, inline_make_let (sc, sc->curlet)); - sc->code= T_Pair (cddar (args)); -} - -static void -op_c_catch_all (s7_scheme* sc) { - s7_pointer new_catch; - new_cell (sc, new_catch, T_CATCH); - catch_tag (new_catch) = sc->T; - catch_goto_loc (new_catch)= stack_top (sc); - catch_op_loc (new_catch) = sc->op_stack_now - sc->op_stack; - catch_set_handler (new_catch, sc->nil); - catch_cstack (new_catch)= sc->goto_start; - push_stack (sc, OP_CATCH_ALL, opt2_con (sc->code), - new_catch); /* push_stack: op args code */ - sc->code= - T_Pair (opt1_pair (cdr (sc->code))); /* the body of the first lambda (or - car of it if catch_all_o) */ -} + case T_C_MACRO: + return(c_macro_setter(obj)); -static void -op_c_catch_all_a (s7_scheme* sc) { - op_c_catch_all (sc); - sc->value= fx_call (sc, sc->code); -} + case T_C_OBJECT: + if_c_object_method_exists_return_value(sc, obj, sc->setter_symbol, set_plist_2(sc, obj, let)); + return((c_object_set(sc, obj) == 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 */ -/* -------------------------------- owlet -------------------------------- */ -/* error reporting info -- save filename and line number */ + case T_LET: + if_let_method_exists_return_value(sc, obj, sc->setter_symbol, set_plist_2(sc, obj, let)); + return(global_value(sc->let_set_symbol)); -static s7_pointer -init_owlet (s7_scheme* sc) { - s7_pointer p; /* watch out for order below */ - const s7_pointer let= make_let (sc, sc->rootlet); - begin_temp (sc->x, let); - sc->error_type= add_slot_checked_with_id ( - sc, let, make_symbol (sc, "error-type", 10), - sc->F); /* the error type or tag ('division-by-zero) */ - sc->error_data= add_slot_unchecked_with_id ( - sc, let, make_symbol (sc, "error-data", 10), - sc->F); /* the message or information passed by the error function */ - sc->error_code= add_slot_unchecked_with_id ( - sc, let, make_symbol (sc, "error-code", 10), - sc->F); /* the code that s7 thinks triggered the error */ - sc->error_line= add_slot_unchecked_with_id ( - sc, let, make_symbol (sc, "error-line", 10), - p= make_permanent_integer (0)); /* the line number of that code */ - add_saved_pointer (sc, p); - sc->error_file= - add_slot_unchecked_with_id (sc, let, make_symbol (sc, "error-file", 10), - sc->F); /* the file name of that code */ - sc->error_position= add_slot_unchecked_with_id ( - sc, let, make_symbol (sc, "error-position", 14), - p= make_permanent_integer (0)); /* file-byte position of that code */ - add_saved_pointer (sc, p); -#if WITH_HISTORY - sc->error_history= add_slot_unchecked_with_id ( - sc, let, make_symbol (sc, "error-history", 13), - sc->F); /* buffer of previous evaluations */ -#endif - end_temp (sc->x); - return (let); + case T_ITERATOR: /* (set! (iter) val) doesn't fit the other setters */ + return((is_any_closure(iterator_sequence(obj))) ? closure_setter(iterator_sequence(obj)) : sc->F); + + case T_PAIR: return(global_value(sc->list_set_symbol)); /* or maybe initial-value? */ + 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_COMPLEX_VECTOR: return(global_value(sc->complex_vector_set_symbol)); + case T_SLOT: return((slot_has_setter(obj)) ? slot_setter(obj) : sc->F); + case T_SYMBOL: return(symbol_setter(sc, obj, let)); /* (setter symbol let) */ + } + /* wrong_type_error_nr(sc, sc->setter_symbol, 1, obj, wrap_string(sc, "something that might have a setter", 34)); */ /* this seems unfriendly */ + return(sc->F); } -#if WITH_HISTORY -static s7_pointer -sanitize_history (s7_scheme* sc, s7_pointer code) { - begin_small_symbol_set ( - sc); /* make a list of words banned from the history */ - add_symbol_to_small_symbol_set (sc, sc->starlet_symbol); - add_symbol_to_small_symbol_set (sc, sc->eval_symbol); - add_symbol_to_small_symbol_set (sc, make_symbol (sc, "debug", 5)); - add_symbol_to_small_symbol_set (sc, make_symbol (sc, "trace-in", 8)); - add_symbol_to_small_symbol_set (sc, make_symbol (sc, "trace-out", 9)); - add_symbol_to_small_symbol_set (sc, sc->dynamic_unwind_symbol); - add_symbol_to_small_symbol_set (sc, make_symbol (sc, "history-enabled", 15)); - for (s7_pointer p= code; is_pair (p); p= cdr (p)) { - if ((is_pair (car (p))) && (!is_quote (sc, car (p))) && - (pair_set_memq (sc, car (p)))) - set_car (p, sc->nil); - if (cdr (p) == code) break; - } - end_small_symbol_set (sc); - return (code); +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, has_let_signature(sc)) + return(setter_p_pp(sc, car(args), (is_pair(cdr(args))) ? cadr(args) : sc->curlet)); } -#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 s7_setter(s7_scheme *sc, s7_pointer obj) {return(setter_p_pp(sc, obj, sc->curlet));} - s7_pointer let; - const bool old_gc= sc->gc_off; - if (is_pair (args)) - error_nr ( - sc, sc->wrong_number_of_args_symbol, - set_elist_3 (sc, too_many_arguments_string, sc->owlet_symbol, args)); -#if WITH_HISTORY - slot_set_value (sc->error_history, - sanitize_history (sc, slot_value (sc->error_history))); -#endif - let= let_copy (sc, sc->owlet); - gc_protect_via_stack (sc, let); - - /* make sure the pairs/reals/strings/integers are copied: should be - * error-data, error-code, and error-history */ - sc->gc_off= true; - for (s7_pointer slot= let_slots (let); is_not_slot_end (slot); - slot = next_slot (slot)) - if (is_pair (slot_value (slot))) { - const s7_pointer new_list= copy_any_list (sc, slot_value (slot)); - slot_set_value (slot, new_list); - for (s7_pointer 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= old_gc; - unstack_gc_protect (sc); - return (let); -} +s7_pointer g_restore_setter(s7_scheme *sc, s7_pointer args) {closure_set_setter(caar(args), cadar(args)); return(cadar(args));} +/* see dynamic_unwind below -- it passes us list_2(sc, stack_args, sc->value) so we ignore cadr(args) */ -/* -------- catch handlers -------- (don't free the catcher) */ -static void -load_catch_cstack (s7_scheme* sc, s7_pointer catcher) { - if (catch_cstack (catcher)) sc->goto_start= catch_cstack (catcher); -} - -static bool -catch_all_function (s7_scheme* sc, s7_int catch_loc, s7_pointer type, - s7_pointer info) { - const s7_pointer catcher= T_Cat (stack_code (sc->stack, catch_loc)); - if (SHOW_EVAL_OPS) fprintf (stderr, "catcher: %s\n", __func__); - sc->value= stack_args (sc->stack, - catch_loc); /* error result, optimize_func_three_args - -> op_c_catch_all etc */ - if (sc->value == sc->unused) sc->value= type; - sc->op_stack_now= (s7_pointer*) (sc->op_stack + catch_op_loc (catcher)); - sc->stack_end = (s7_pointer*) (sc->stack_start + catch_goto_loc (catcher)); - load_catch_cstack (sc, catcher); - pop_stack (sc); - return (true); -} - -static bool -catch_2_function (s7_scheme* sc, s7_int catch_loc, s7_pointer type, - s7_pointer info) { - /* 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)) - */ - const s7_pointer cat= T_Cat (stack_code (sc->stack, catch_loc)); - if (SHOW_EVAL_OPS) fprintf (stderr, "catcher: %s\n", __func__); - if ((catch_tag (cat) == sc->T) || (catch_tag (cat) == type) || - (type == sc->T)) { - sc->op_stack_now= (s7_pointer*) (sc->op_stack + catch_op_loc (cat)); - sc->stack_end = (s7_pointer*) (sc->stack_start + catch_goto_loc (cat)); - sc->code = catch_handler (cat); - load_catch_cstack (sc, cat); - if (needs_copied_args (sc->code)) sc->args= list_2 (sc, type, info); - else - sc->args= with_list_t2 ( - sc, type, info); /* very unlikely: need c_macro as error catcher: - (catch #t (lambda () (error 'oops)) require) */ - sc->cur_op= OP_APPLY; - return (true); - } - return (false); -} - -static bool -catch_1_function (s7_scheme* sc, s7_int catch_loc, s7_pointer type, - s7_pointer info) { - const s7_pointer catcher= T_Cat (stack_code (sc->stack, catch_loc)); - if (SHOW_EVAL_OPS) fprintf (stderr, "catcher: %s\n", __func__); - if ((catch_tag (catcher) == sc->T) || /* the normal case */ - (catch_tag (catcher) == type) || (type == sc->T)) { - const opcode_t op = stack_op (sc->stack, catch_loc); - const s7_pointer error_func= catch_handler (catcher); - const s7_uint loc = catch_goto_loc (catcher); - s7_pointer error_body, error_pars; - - begin_temp (sc->y, type); - sc->value= info; - sc->temp4= - stack_let (sc->stack, catch_loc); /* GC protect this, since we're moving - the stack top below */ - sc->op_stack_now= (s7_pointer*) (sc->op_stack + catch_op_loc (catcher)); - sc->stack_end = (s7_pointer*) (sc->stack_start + loc); - load_catch_cstack (sc, 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_pars= car (error_func); - } - else if (is_closure (error_func)) { - error_body= closure_body (error_func); - error_pars= closure_pars (error_func); - } - else { - error_body= NULL; - error_pars= NULL; - } - if ((error_body) && (is_null (cdr (error_body)))) { - s7_pointer val= NULL; - error_body = car (error_body); - if (is_pair (error_body)) { - if (is_quote (sc, car (error_body))) val= cadr (error_body); - else if ((car (error_body) == sc->car_symbol) && - (is_pair ( - cdr (error_body))) && /* catch: (lambda args (car args)) */ - (cadr (error_body) == error_pars)) - val= type; - } - else if (!is_symbol (error_body)) - val= error_body; /* not pair or symbol */ - else if (error_body == error_pars) val= list_2 (sc, type, info); - else if (is_keyword (error_body)) val= error_body; - else if ((is_pair (error_pars)) && (error_body == car (error_pars))) - val= type; - if (val) { - if ((SHOW_EVAL_OPS) && (loc > 4)) { - fprintf (stderr, " about to pop_stack: \n"); - s7_show_stack (sc); - } - 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= val; - end_temp (sc->y); - sc->temp4= sc->unused; - sc->w = sc->unused; - 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); - } +/* -------------------------------- set-setter -------------------------------- */ +static void protect_setter(s7_scheme *sc, s7_pointer sym, s7_pointer setter) +{ + if (sc->protected_setters_size == sc->protected_setters_loc) + { + const s7_int size = sc->protected_setters_size; + const s7_int new_size = 2 * size; + block_t *old_b = vector_block(sc->protected_setters); /* old_b is liberated by reallocate below */ + block_t *new_b = reallocate(sc, old_b, new_size * sizeof(s7_pointer)); + block_info(new_b) = NULL; + vector_block(sc->protected_setters) = new_b; + vector_elements(sc->protected_setters) = (s7_pointer *)block_data(new_b); + vector_length(sc->protected_setters) = new_size; + + old_b = vector_block(sc->protected_setter_symbols); /* old_b is liberated by reallocate below */ + new_b = reallocate(sc, old_b, new_size * sizeof(s7_pointer)); + vector_block(sc->protected_setter_symbols) = new_b; + vector_elements(sc->protected_setter_symbols) = (s7_pointer *)block_data(new_b); + vector_length(sc->protected_setter_symbols) = new_size; + + for (s7_int 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; } - /* here type and info need to be GC protected (new_cell below), g_throw and - * error_nr, throw sc->w for type, but error_nr nothing currently */ - if (op == OP_CATCH_1) { - s7_pointer new_func; - new_cell (sc, new_func, T_CLOSURE); - closure_set_pars (new_func, car (error_func)); - closure_set_body (new_func, cdr (error_func)); - closure_set_setter (new_func, sc->F); - closure_set_arity (new_func, CLOSURE_ARITY_NOT_SET); - closure_set_let (new_func, sc->temp4); - sc->code= new_func; - if ((S7_DEBUGGING) && (!s7_is_aritable (sc, sc->code, 2))) - fprintf (stderr, "%s[%d]: errfunc not aritable(2)!\n", __func__, - __LINE__); - } - else { - sc->code= error_func; - end_temp (sc->y); - if (!s7_is_aritable ( - sc, sc->code, - 2)) /* op_catch_1 from op_c_catch already checks this */ - wrong_number_of_arguments_error_nr ( - sc, "catch error handler should accept two arguments: ~S", 51, - sc->code); - } - sc->temp4= sc->unused; - /* 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! - */ - sc->args= list_2 ( - sc, type, - info); /* almost never able to skip this -- costs more to check! */ - sc->w= sc->unused; - end_temp (sc->y); - 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 catch_loc, s7_pointer type, - s7_pointer info) { - const s7_pointer dw= T_Dyn (stack_code (sc->stack, catch_loc)); - if (SHOW_EVAL_OPS) fprintf (stderr, "catcher: %s\n", __func__); - if (dynamic_wind_state (dw) == dwind_body) { - dynamic_wind_state (dw)= - dwind_finish; /* make sure an uncaught error in the exit thunk doesn't - cause us to loop */ - if (dynamic_wind_out (dw) != sc->F) - sc->value= s7_call (sc, dynamic_wind_out (dw), sc->nil); - } - return (false); -} - -static bool -catch_out_function (s7_scheme* sc, s7_int catch_loc, s7_pointer type, - s7_pointer info) { - s7_pointer port= T_Pro ( - stack_code (sc->stack, catch_loc)); /* "code" = port that we opened */ - if (SHOW_EVAL_OPS) fprintf (stderr, "catcher: %s\n", __func__); - s7_close_output_port (sc, port); - port= stack_args ( - sc->stack, - catch_loc); /* "args" = port that we shadowed, if not # */ - if (port != sc->unused) set_current_output_port (sc, port); - return (false); -} - -static bool -catch_in_function (s7_scheme* sc, s7_int catch_loc, s7_pointer type, - s7_pointer info) { - s7_pointer port= T_Pri ( - stack_code (sc->stack, catch_loc)); /* "code" = port that we opened */ - if (SHOW_EVAL_OPS) fprintf (stderr, "catcher: %s\n", __func__); - s7_close_input_port (sc, port); - port= stack_args ( - sc->stack, - catch_loc); /* "args" = port that we shadowed, if not # */ - if (port != sc->unused) set_current_input_port (sc, port); - return (false); -} - -static bool -catch_read_function (s7_scheme* sc, s7_int catch_loc, s7_pointer type, - s7_pointer info) { - if (SHOW_EVAL_OPS) fprintf (stderr, "catcher: %s\n", __func__); - pop_input_port (sc); - return (false); -} - -static bool -catch_eval_function (s7_scheme* sc, s7_int catch_loc, s7_pointer type, - s7_pointer info) { - if (SHOW_EVAL_OPS) fprintf (stderr, "catcher: %s\n", __func__); - 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 catch_loc, s7_pointer type, - s7_pointer - info) { /* can this happen? is it doing the right thing? - read/eval/call_begin_hook push_stack op_barrier but only - s7_read includes a port (this is not hit in s7test.scm) */ - if (SHOW_EVAL_OPS || S7_DEBUGGING) - fprintf (stderr, "catcher: %s\n", __func__); - if (is_input_port (stack_args (sc->stack, catch_loc))) { - if (current_input_port (sc) == stack_args (sc->stack, catch_loc)) - pop_input_port (sc); - s7_close_input_port (sc, stack_args (sc->stack, catch_loc)); + { + s7_int loc = sc->protected_setters_loc++; + vector_element(sc->protected_setters, loc) = setter; /* has_closure => T_Prc[Clo?](setter) checked earlier */ + vector_element(sc->protected_setter_symbols, loc) = sym; } - return (false); -} - -static bool -catch_error_hook_function (s7_scheme* sc, s7_int catch_loc, s7_pointer type, - s7_pointer info) { /* from op_error_hook_quit */ - if (SHOW_EVAL_OPS) fprintf (stderr, "catcher: %s\n", __func__); - let_set_2 (sc, closure_let (sc->error_hook), sc->body_symbol, - stack_code (sc->stack, catch_loc)); - /* apparently there was an error during *error-hook* evaluation, but Rick - * wants the hook re-established anyway */ - sc->reset_error_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 catch_loc, s7_pointer type, - s7_pointer info) { - if (SHOW_EVAL_OPS) fprintf (stderr, "catcher: %s\n", __func__); - call_exit_active (stack_args (sc->stack, catch_loc))= false; - return (false); -} +static s7_pointer symbol_set_setter(s7_scheme *sc, s7_pointer sym, s7_pointer args) +{ + s7_pointer func, slot; + if (is_keyword(sym)) + wrong_type_error_nr(sc, wrap_string(sc, "set! setter", 11), 1, sym, wrap_string(sc, "a normal symbol (a keyword can't be set)", 40)); -static bool -catch_map_unwind_function (s7_scheme* sc, s7_int catch_loc, s7_pointer type, - s7_pointer info) { - if (SHOW_EVAL_OPS) fprintf (stderr, "catcher: %s\n", __func__); - sc->map_call_ctr--; - if ((S7_DEBUGGING) && (sc->map_call_ctr < 0)) { - fprintf (stderr, "%s[%d]: map ctr: %" ld64 "\n", __func__, __LINE__, - sc->map_call_ctr); - sc->map_call_ctr= 0; - } - return (false); -} + if (is_pair(cddr(args))) + { + s7_pointer let = cadr(args); /* (let ((x 1)) (set! (setter 'x (curlet)) (lambda (s v e) ...))): args is (x (inlet 'x 1) #) */ + func = caddr(args); + if (let == sc->rootlet) + slot = global_slot(sym); + else + { + if (!is_let(let)) + { + s7_pointer new_let = find_let(sc, let); + if ((!is_let(new_let)) || (new_let == sc->rootlet)) + find_let_error_nr(sc, wrap_string(sc, "set! setter", 11), let, new_let, 2, args); + let = new_let; + } + slot = lookup_slot_with_let(sc, sym, let); + }} + else + { + slot = s7_slot(sc, sym); /* (set! (setter 'x) (lambda (s v) ...)): args is: (x #) */ + func = cadr(args); + } + if (!is_slot(slot)) + return(sc->F); -static bool -catch_let_temporarily_function (s7_scheme* sc, s7_int catch_loc, - s7_pointer type, s7_pointer info) { - if (SHOW_EVAL_OPS) fprintf (stderr, "catcher: %s\n", __func__); - let_temp_done (sc, stack_args (sc->stack, catch_loc), - T_Let (stack_let (sc->stack, catch_loc))); - return (false); -} + if (func != sc->F) + { + if (sym == sc->setter_symbol) + immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't set (setter 'setter) to ~S", 32), func)); + if (is_syntax_or_qq(slot_value(slot))) /* (set! (setter 'begin) ...), qq is syntax sez r7rs */ + immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "can't set (setter '~S) to ~S", 28), sym, func)); + if (!is_any_procedure(func)) /* this will disallow continuation/goto here */ + wrong_type_error_nr(sc, wrap_string(sc, "set! setter", 11), 3, func, wrap_string(sc, "a function or #f", 16)); + if (func == global_value(sc->values_symbol)) + error_nr(sc, make_symbol(sc, "invalid-setter", 14), + set_elist_2(sc, wrap_string(sc, "~S's setter can't be values", 27), sym)); + 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)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "symbol setter function, ~A, should take 2 or 3 arguments", 56), 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); + return(func); +} + +static s7_pointer g_set_setter(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer obj = car(args), setter = cadr(args); + if (is_symbol(obj)) /* has to precede cadr(args) checks, (set! (setter 'x let) ...) where setter is caddr(args) */ + return(symbol_set_setter(sc, obj, args)); + if (obj == sc->starlet) + wrong_type_error_nr(sc, wrap_string(sc, "set! setter", 11), 1, obj, wrap_string(sc, "something other than *s7*", 25)); -bool -catch_let_temp_unwind_function (s7_scheme* sc, s7_int catch_loc, - s7_pointer type, s7_pointer info) { - const s7_pointer slot= stack_code (sc->stack, catch_loc); - const s7_pointer val = stack_args (sc->stack, catch_loc); - if (SHOW_EVAL_OPS) - fprintf (stderr, "catcher: %s, unwind setting %s to %s\n", __func__, - display_truncated (slot), display_truncated (val)); - if (is_immutable_slot ( - slot)) /* we're already in an error/throw situation, so raising an - error here leads to an infinite loop */ - s7_warn (sc, 512, "let-temporarily can't reset %s to %s: it is immutable!", - symbol_name (slot_symbol (slot)), display (val)); - else slot_set_value (slot, val); - return (false); -} - -static bool -catch_let_temp_s7_unwind_function (s7_scheme* sc, s7_int catch_loc, - s7_pointer type, s7_pointer info) { - const s7_pointer symbol= stack_code (sc->stack, catch_loc); - if (SHOW_EVAL_OPS) fprintf (stderr, "catcher: %s\n", __func__); - if (starlet_symbol_id (symbol) != - sl_no_field) /* we could be unwinding from an error that the symbol is not - defined in *s7*! */ - starlet_set_1 (sc, symbol, stack_args (sc->stack, catch_loc)); - return (false); -} - -static bool -catch_let_temp_s7_openlets_unwind_function (s7_scheme* sc, s7_int catch_loc, - s7_pointer type, s7_pointer info) { - if (SHOW_EVAL_OPS) fprintf (stderr, "catcher: %s\n", __func__); - sc->has_openlets= (stack_args (sc->stack, catch_loc) != sc->F); - return (false); -} - -bool -catch_dynamic_unwind_function (s7_scheme* sc, s7_int catch_loc, s7_pointer type, - s7_pointer info) { - /* if func has an error, s7_error will call it as it unwinds the stack -- an - * infinite loop. So, cancel the unwind first */ - if (SHOW_EVAL_OPS) fprintf (stderr, "catcher: %s\n", __func__); - set_stack_op (sc->stack, catch_loc, 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= - lookup_slot_with_let (sc, make_symbol (sc, "*debug-spaces*", 14), - T_Let (stack_let (sc->stack, catch_loc))); - 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); -} + if (setter != sc->F) + { + if (!is_any_procedure(setter)) + wrong_type_error_nr(sc, wrap_string(sc, "set! setter", 11), 2, setter, wrap_string(sc, "a procedure or #f", 17)); + if (arity_to_int(sc, setter) < 1) /* we need at least an arg for the set! value */ + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "setter function, ~A, should take at least one argument", 54), setter)); + if (setter == global_value(sc->values_symbol)) + error_nr(sc, make_symbol(sc, "invalid-setter", 14), + set_elist_2(sc, wrap_string(sc, "~S's setter can't be values", 27), 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: + closure_set_setter(obj, setter); + if (setter == sc->F) + closure_set_no_setter(obj); + break; -static bool -catch_load_close_function (s7_scheme* sc, s7_int catch_loc, s7_pointer type, - s7_pointer info) { - if (SHOW_EVAL_OPS) fprintf (stderr, "catcher: %s\n", __func__); - if ((S7_DEBUGGING) && (!is_loader_port (current_input_port (sc)))) - fprintf (stderr, "%s[%d]: %s not loading?\n", __func__, __LINE__, - display (current_input_port (sc))); - if (SHOW_EVAL_OPS) - fprintf (stderr, "%s closing %s\n", __func__, - display (current_input_port (sc))); + case T_C_FUNCTION: case T_C_FUNCTION_STAR: case T_C_RST_NO_REQ_FUNCTION: + if (obj == global_value(sc->setter_symbol)) /* (immutable? (setter setter)) is #t, but we aren't checking immutable? here -- maybe we should? */ + immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't set (setter setter) to ~S", 31), setter)); + if (obj == global_value(sc->values_symbol)) /* 6-Oct-23 (set! (setter values) ...) is problematic, see splice_in_values */ + immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't set (setter values) to ~S", 31), setter)); + c_function_set_setter(obj, setter); + /* below: not any_closure or any_macro because that include c-macros: + * twice: (catch #t (lambda () (let () (define (func) (set! (setter map) quasiquote)) (func))) (lambda (t i) 'error)) -> c-macro case! + */ + if (has_closure_let(setter)) + add_setter(sc, obj, setter); + break; - /* this looks like catch_eval_function */ - s7_close_input_port (sc, current_input_port (sc)); - pop_input_port (sc); - /* sc->current_file = NULL; */ - return (false); -} + case T_C_MACRO: + c_macro_set_setter(obj, setter); + if (has_closure_let(setter)) + add_setter(sc, obj, setter); + break; -typedef bool (*catch_function_t) (s7_scheme* sc, s7_int catch_loc, - s7_pointer type, s7_pointer info); -static catch_function_t catchers[NUM_OPS]; + default: /* (set! (setter 4) ...) or p==continuation etc */ + wrong_type_error_nr(sc, wrap_string(sc, "set! setter", 11), 1, obj, wrap_string(sc, "a symbol, a procedure, or a macro", 33)); + } + return(setter); +} -static void -init_catchers (void) { - for (int32_t i= 0; i < NUM_OPS; i++) - catchers[i]= NULL; - catchers[OP_BARRIER] = catch_barrier_function; - catchers[OP_CATCH] = catch_1_function; - catchers[OP_CATCH_1] = catch_1_function; - catchers[OP_CATCH_2] = catch_2_function; - catchers[OP_CATCH_ALL] = catch_all_function; - catchers[OP_DEACTIVATE_GOTO] = catch_goto_function; - catchers[OP_DYNAMIC_UNWIND] = catch_dynamic_unwind_function; - catchers[OP_DYNAMIC_WIND] = catch_dynamic_wind_function; - catchers[OP_ERROR_HOOK_QUIT] = catch_error_hook_function; - catchers[OP_EVAL_STRING] = catch_eval_function; - catchers[OP_GET_OUTPUT_STRING]= catch_out_function; - catchers[OP_LET_TEMP_DONE] = catch_let_temporarily_function; - catchers[OP_LET_TEMP_S7_OPENLETS_UNWIND]= - catch_let_temp_s7_openlets_unwind_function; - catchers[OP_LET_TEMP_S7_UNWIND]= catch_let_temp_s7_unwind_function; - catchers[OP_LET_TEMP_UNWIND] = catch_let_temp_unwind_function; - catchers[OP_MAP_UNWIND] = catch_map_unwind_function; - catchers[OP_READ_DONE]= - catch_read_function; /* perhaps an error during (read) */ - catchers[OP_UNWIND_INPUT] = catch_in_function; - catchers[OP_UNWIND_OUTPUT] = catch_out_function; - catchers[OP_LOAD_CLOSE_AND_POP_IF_EOF]= catch_load_close_function; - /* do we need one for load_return_if_eof? */ +s7_pointer s7_set_setter(s7_scheme *sc, s7_pointer obj, s7_pointer setter) +{ + if (is_symbol(obj)) + { + if (slot_has_setter(global_slot(obj))) + for (s7_int index = 0; index < sc->protected_setters_loc; index++) + if (vector_element(sc->protected_setter_symbols, index) == obj) + { + const s7_pointer 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(obj), 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(obj)); + if (!is_c_function(setter)) protect_setter(sc, obj, T_Clo(setter)); /* c_functions don't need GC protection */ + slot_set_setter(global_slot(obj), setter); + if (s7_is_aritable(sc, setter, 3)) + set_has_let_arg(setter); + return(setter); + } + slot_set_setter(global_slot(obj), sc->F); + return(sc->F); + } + return(g_set_setter(sc, set_plist_2(sc, obj, setter))); /* if T_Clo(setter), doesn't it need GC protection as above? */ } -/* -------------------------------- 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 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) +/* (let () (define xxx 23) (define (hix) (set! xxx 24)) (hix) (set! (setter 'xxx) (lambda (sym val) (format *stderr* "val: ~A~%" val) val)) (hix)) + * which does not call the setter presumably because the set! has been optimized to ignore it -- set the setter before use! + */ - const s7_pointer type= car (args), info= cdr (args); - gc_protect_via_stack (sc, args); - /* type can be anything: (throw (list 1 2 3) (make-list 512)), sc->w and - * sc->value not good here for gc protection */ +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)) /* setter has optional third arg, the let */ + return(c_function_call(func)(sc, with_list_t3(sc, symbol, new_value, sc->curlet))); + return(c_function_call(func)(sc, with_list_t2(sc, symbol, new_value))); +} - for (s7_int op_loc= stack_top (sc) - 5; op_loc >= 3; - op_loc-= 4) /* look for a catcher */ +s7_pointer call_setter(s7_scheme *sc, s7_pointer slot, s7_pointer new_value) /* see also op_set1 */ +{ + const s7_pointer func = slot_setter(slot); + if (is_c_function(func)) + return(call_c_function_setter(sc, func, slot_symbol(slot), new_value)); + if (!is_any_procedure(func)) + return(new_value); + sc->temp9 = (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) */ + /* the following s7_call can clobber the temp var (perhaps setter is calling implicit set!?) */ { - catch_function_t catcher= catchers[stack_op (sc->stack, op_loc)]; - if ((catcher) && (catcher (sc, op_loc, type, info))) { - if (sc->longjmp_ok) LongJmp (*(sc->goto_start), throw_jump); - return (sc->value); - } + s7_pointer result = s7_call(sc, func, sc->temp9); + sc->temp9 = sc->unused; + return(result); } - if (is_let (car (args))) - if_let_method_exists_return_value (sc, car (args), sc->throw_symbol, args); - error_nr (sc, make_symbol (sc, "uncaught-throw", 14), - set_elist_3 ( - sc, - wrap_string (sc, "no catch found for (throw ~W~{~^ ~S~})", 38), - type, info)); - return (sc->F); } -/* -------------------------------- warn -------------------------------- */ -#if WITH_GCC -static __attribute__ ((format (printf, 3, 4))) void -s7_warn (s7_scheme* sc, s7_int len, const char* ctrl, ...) -#else -static void -s7_warn (s7_scheme* sc, s7_int len, const char* ctrl, - ...) /* len = max size of output string (for vsnprintf) */ -#endif +static s7_pointer bind_symbol_with_setter(s7_scheme *sc, opcode_t op, s7_pointer symbol, s7_pointer new_value) { - if ((current_error_port (sc) != sc->F) && (!sc->muffle_warnings)) { - int32_t bytes; - va_list ap; - block_t* b = mallocate (sc, len); - char* 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 (current_error_port (sc))) - set_current_error_port (sc, sc->standard_error); - if ((bytes > 0) && (current_error_port (sc) != sc->F)) - port_write_string (current_error_port (sc)) (sc, str, bytes, - current_error_port (sc)); - liberate (sc, b); - } + const s7_pointer func = setter_p_pp(sc, symbol, sc->curlet); + if (is_c_function(func)) + return(call_c_function_setter(sc, func, symbol, new_value)); + if (!is_any_procedure(func)) + return(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 */ } -/* -------------------------------- error -------------------------------- */ -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)))) { - set_integer (slot_value (sc->error_line), - port_line_number (current_input_port (sc))); - set_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 { - set_integer (slot_value (sc->error_line), 0); - set_integer (slot_value (sc->error_position), 0); - slot_set_value (sc->error_file, sc->F); - } -} -static void -format_to_error_port (s7_scheme* sc, const char* str, s7_pointer args, - s7_int len) { - if (current_error_port (sc) != sc->F) - format_to_port_1 (sc, current_error_port (sc), str, args, NULL, false, - true /* is_columnizing(str) */, len, NULL); - /* is_columnizing on every call is much slower than ignoring the issue */ +/* -------------------------------- 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 */ } -no_return void -error_nr (s7_scheme* sc, s7_pointer type, - s7_pointer info) { /* half the reported compute time here is in the - longjmp after the catcher runs */ - s7_pointer cur_code= current_code (sc); -#if WITH_HISTORY - if ((is_free (cur_code)) || (cur_code == sc->unused)) cur_code= sc->F; -#endif - - sc->format_depth = -1; - 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, op_?_unwind */ - sc->do_body_p= NULL; -#if S7_DEBUGGING - sc->small_symbol_set_state= set_ignore; - sc->big_symbol_set_state = set_ignore; - sc->v = sc->unused; - sc->x = sc->unused; - sc->y = sc->unused; - sc->temp3 = sc->unused; - sc->temp6 = sc->unused; - sc->temp7 = sc->unused; - sc->temp9 = sc->unused; -#endif - sc->value= info; /* feeble GC protection (otherwise info is sometimes freed in - this function), throw also protects type */ +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)))))); +} - if (sc->current_safe_list > 0) - clear_safe_list_in_use ( - sc, - sc->safe_lists[sc->current_safe_list]); /* clears current_safe_list */ - slot_set_value (sc->error_type, type); - slot_set_value (sc->error_data, info); - if (type_unchecked (sc->curlet) != T_LET) - set_curlet ( - sc, sc->rootlet); /* 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); - slot_set_value (sc->error_code, - cur_code); /* if mv here, evalable code has the mv bit set, - maybe from c-macro that uses s7_values */ +/* g_is_eq migrated to s7_scheme_predicate.c */ +#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 -#if WITH_HISTORY - slot_set_value (sc->error_history, sc->cur_code); - if (sc->cur_code != sc->history_sink) { - int32_t i = 0; - sc->cur_code= (sc->using_history1) ? sc->eval_history2 : sc->eval_history1; - sc->using_history1= (!sc->using_history1); - for (s7_pointer p= sc->cur_code; i < sc->history_size; i++, p= cdr (p)) - car (p)= sc->nil; - } -#endif - if (is_pair (cur_code)) /* not redundant -- maybe use type_unchecked here */ - { - s7_int line= -1, file, position; - if (has_location ( - cur_code)) /* ignore callgrind! this is the normal case */ - { - line = pair_line_number (cur_code); - file = pair_file_number (cur_code); - position= pair_position (cur_code); - } - else /* try to find a plausible line number! */ - for (s7_pointer p= cur_code, sp= cur_code; is_pair (p); - p= cdr (p), sp= cdr (sp)) { - if ((is_pair (car (p))) && (has_location (car (p)))) { - line = pair_line_number (car (p)); - file = pair_file_number (car (p)); - position= pair_position (car (p)); - break; - } - p= cdr (p); - if ((!is_pair (p)) || (p == sp)) break; - /* p itself never has the line/file info */ - if ((is_pair (car (p))) && (has_location (car (p)))) { - line = pair_line_number (car (p)); - file = pair_file_number (car (p)); - position= pair_position (car (p)); - break; - } - } - if ((line <= 0) || (file < 0)) fill_error_location (sc); - else { - set_integer (slot_value (sc->error_line), line); - set_integer (slot_value (sc->error_position), position); - slot_set_value (sc->error_file, sc->file_names[file]); - } - } - else fill_error_location (sc); - - /* look for a catcher, call catch*function in the error context (before - * unwinding the stack), outlet(owlet) is curlet */ - /* top is 1 past actual top, top - 1 is op, if op = OP_CATCH, top - 4 is the - * cell containing the catch struct */ - for (s7_int op_loc= stack_top (sc) - 1; op_loc >= 3; op_loc-= 4) { - catch_function_t catcher= catchers[stack_op (sc->stack, op_loc)]; - if ((SHOW_EVAL_OPS) && (catcher)) { - fprintf (stderr, "before catch:\n"); - s7_show_stack (sc); - } - if ((catcher) && (catcher (sc, op_loc, type, info))) { - if (SHOW_EVAL_OPS) { - fprintf (stderr, " after catch: \n"); - s7_show_stack (sc); - } - if ((S7_DEBUGGING) && (!sc->longjmp_ok)) - fprintf (stderr, "s7_error jump not available?\n"); - LongJmp (*(sc->goto_start), catch_jump); - } - } - /* error not caught (but catcher might have been called and returned false) */ +bool s7_is_eqv(s7_scheme *sc, s7_pointer x, s7_pointer y) +{ + if (type(x) != type(y)) return(false); + if ((x == y) && (!is_number(x))) /* if x is NaN, x == y doesn't mean (eqv? x y) */ + return(true); /* x == y means (let ((x "a")) (let ((y x)) (eqv? x y))) is #t */ + if (is_number(x)) return(numbers_are_eqv(sc, x, y)); + if (is_unspecified(x)) return(true); /* types are the same so we know y is also unspecified */ + return(false); +} - if ((!(sc->reset_error_hook)) && (hook_has_functions (sc->error_hook))) { - const s7_pointer error_hook_funcs= s7_hook_functions (sc, sc->error_hook); - /* (set! (hook-functions *error-hook*) (list (lambda (h) (format *stderr* - * "got error ~A~%" (h 'data))))) */ - let_set_2 (sc, closure_let (sc->error_hook), sc->body_symbol, sc->nil); - let_set_2 (sc, closure_let (sc->temp_error_hook), sc->body_symbol, - error_hook_funcs); - /* if the *error-hook* functions trigger an error, we had better not have - * hook_functions(*error-hook*) still set! */ - - /* here we have no catcher (anywhere!), we're headed back to the - * top-level(?), so error_hook_quit can call reset_stack? */ - push_stack (sc, OP_ERROR_HOOK_QUIT, sc->nil, - error_hook_funcs); /* restore *error-hook* upon successful (or - any!) evaluation */ - sc->code= sc->temp_error_hook; - 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. - */ - set_curlet (sc, make_let (sc, closure_let (sc->code))); - eval (sc, OP_APPLY_LAMBDA); - /* we'll longjmp below -- is that really what we want? */ - } - else { - const s7_int op= sc->print_length; - if (op < 32) sc->print_length= 32; - - if ((!is_output_port ( - current_error_port (sc))) || /* error-port can be #f */ - (port_is_closed (current_error_port (sc)))) - set_current_error_port (sc, 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! - */ +/* g_is_eqv migrated to s7_scheme_predicate.c */ +#define H_is_eqv "(eqv? obj1 obj2) returns #t if obj1 is equivalent to obj2" +#define Q_is_eqv sc->pcl_bt - if ((!is_pair (info)) || (!is_string (car (info)))) - format_to_error_port (sc, "\n;~S ~S", set_plist_2 (sc, type, info), 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)), '~'))) { - const s7_int len = string_length (car (info)) + 8; - block_t* b = mallocate (sc, len); - char* errstr = (char*) block_data (b); - s7_int str_len= catstrs_direct ( - errstr, "\n;", string_value (car (info)), (const char*) NULL); - format_to_error_port (sc, errstr, cdr (info), str_len); - liberate (sc, b); - } - else - format_to_error_port (sc, "\n;~S ~S", set_plist_2 (sc, type, info), - 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, current_error_port (sc)); - format_to_error_port ( - sc, "; ~A\n", - set_plist_1 (sc, object_to_string_truncated (sc, cur_code)), 8); - format_to_error_port (sc, "; ~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)), - 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_error_port ( - sc, "\n; ~A[~D]", - set_plist_2 ( - sc, - wrap_string (sc, filename, - port_filename_length (current_input_port (sc))), - wrap_integer (sc, line)), - 10); - else if ((line > 0) && (integer (slot_value (sc->error_line)) > 0)) - format_to_error_port (sc, "\n; line ~D", - set_plist_1 (sc, wrap_integer (sc, line)), 11); - else if (sc->input_port_stack_loc > 0) { - s7_pointer port= sc->input_port_stack[sc->input_port_stack_loc - 1]; - if ((is_input_port (port)) && (port_file (port) != stdin) && - (!port_is_closed (port))) { - filename= port_filename (port); - line = port_line_number (port); - if (filename) - format_to_error_port ( - sc, "\n; ~A[~D]", - set_plist_2 (sc, - wrap_string (sc, filename, - port_filename_length ( - current_input_port (sc))), - wrap_integer (sc, line)), - 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_error_port ( - sc, "\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_integer (sc, sc->s7_call_line)), - 13); - } - } - s7_newline (sc, current_error_port (sc)); - } - /* look for __func__ in the error environment etc */ - if (current_error_port (sc) != sc->F) { - s7_pointer errp= s7_stacktrace (sc); - if (string_length (errp) > 0) { - port_write_string (current_error_port (sc)) (sc, string_value (errp), - string_length (errp), - current_error_port (sc)); - port_write_character (current_error_port (sc)) ( - sc, '\n', current_error_port (sc)); - } - } - else if (is_pair (slot_value (sc->error_code))) { - format_to_error_port (sc, "; ~S", - set_plist_1 (sc, slot_value (sc->error_code)), 7); - s7_newline (sc, current_error_port (sc)); - } - /* 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; - sc->reset_error_hook= false; /* ?? */ - } - LongJmp (*(sc->goto_start), error_jump); -} +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)));} -s7_pointer -s7_error (s7_scheme* sc, s7_pointer type, - s7_pointer info) /* s7.h backwards compatibility */ +static bool floats_are_equivalent(s7_scheme *sc, s7_double x, s7_double y) { - error_nr (sc, type, info); - /* info is a temporary value -- do not expect it to be useful beyond the error - * handler procedure itself */ - return (type); + s7_double diff; + if (x == y) return(true); + diff = fabs(x - y); + if (diff <= sc->equivalent_float_epsilon) return(true); + return((is_NaN(x)) && (is_NaN(y))); } -static no_return void -read_error_1_nr (s7_scheme* sc, const char* errmsg, bool string_error) { - /* read 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. - */ - const s7_pointer port= 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 start, end, slen, size; - char* recent_input= NULL; - - /* we can run off the end in cases like (eval-string "(. . ,.)") or - * (eval-string " (@ . ,.)") */ - if (port_position (port) >= port_data_size (port)) - port_position (port)= port_data_size (port) - 1; - - /* start at current position and look back a few chars */ - start= port_position (port); - for (s7_int j= 0; (start > 0) && (j < QUOTE_SIZE); start--, j++) - if ((port_data (port)[start] == '\0') || - (port_data (port)[start] == '\n') || - (port_data (port)[start] == '\r')) - break; - - /* start at current position and look ahead a few chars */ - size= port_data_size (port); - end = port_position (port); - for (s7_int j= 0; (end < size) && (j < QUOTE_SIZE); end++, j++) - if ((port_data (port)[end] == '\0') || - (port_data (port)[end] == '\n') || (port_data (port)[end] == '\r')) - break; - - 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 (s7_int i= 0; i < (slen + 8); i++) - recent_input[i]= '.'; - recent_input[3] = ' '; - recent_input[slen + 4]= ' '; - for (s7_int i= 0; i < slen; i++) - recent_input[i + 4]= port_data (port)[start + i]; - } - if ((port_line_number (port) > 0) && (port_filename (port))) { - const s7_int len= safe_strlen (recent_input) + safe_strlen (errmsg) + - port_filename_length (port) + - safe_strlen (sc->current_file) + 64; - const s7_pointer str= make_empty_string (sc, len, '\0'); - char* msg= string_value (str); - string_length (str) = snprintf ( - msg, len, "%s: %s %s[%u], last top-level form at: %s[%" ld64 "]", - errmsg, (recent_input) ? recent_input : "", port_filename (port), - port_line_number (port), sc->current_file, sc->current_line); - if (recent_input) free (recent_input); - error_nr (sc, sc->read_error_symbol, set_elist_1 (sc, str)); - } - else { - const s7_int len= safe_strlen (recent_input) + safe_strlen (errmsg) + - safe_strlen (sc->current_file) + 64; - const s7_pointer str= make_empty_string (sc, len, '\0'); - char* msg= string_value (str); - if ((sc->current_file) && (sc->current_line >= 0)) - string_length (str)= snprintf ( - msg, len, "%s: %s, last top-level form at %s[%" ld64 "]", errmsg, - (recent_input) ? recent_input : "", sc->current_file, - sc->current_line); - else - string_length (str)= snprintf (msg, len, "%s: %s", errmsg, - (recent_input) ? recent_input : ""); - if (recent_input) free (recent_input); - error_nr (sc, sc->read_error_symbol, set_elist_1 (sc, str)); - } - } - } +static bool eq_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *unused_ci) {return(x == y);} - if ((port_line_number (port) > 0) && (port_filename (port))) { - s7_int nlen; - const s7_int len= safe_strlen (errmsg) + port_filename_length (port) + - safe_strlen (sc->current_file) + 128; - const s7_pointer str= make_empty_string (sc, len, '\0'); - char* msg= string_value (str); - 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 (port), port_line_number (port), - 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 (port), port_line_number (port), - sc->current_file, sc->current_line); - string_length (str)= nlen; - error_nr (sc, sc->read_error_symbol, set_elist_1 (sc, str)); - } - error_nr ( - sc, (string_error) ? sc->string_read_error_symbol : sc->read_error_symbol, - set_elist_1 (sc, s7_make_string_wrapper (sc, errmsg))); +static bool symbol_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) /* symbol equal uses eq -- should it check keywords as below? */ +{ + if (x == y) return(true); + if (!is_symbol(y)) return(false); + if (is_keyword(y)) + return((is_keyword(x)) && (keyword_symbol(x) == keyword_symbol(y))); /* (equivalent? key: :key) -> #t */ + if (is_keyword(x)) return(false); + return((is_slot(global_slot(x))) && /* the optimizer can replace the original symbol with its value */ + (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 no_return void -read_error_nr (s7_scheme* sc, const char* errmsg) { - read_error_1_nr (sc, errmsg, false); +static bool undefined_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) +{ + return((x == y) || + ((is_undefined(y)) && (undefined_name_length(x) == undefined_name_length(y)) && + (safe_strcmp(undefined_name(x), undefined_name(y))))); } -static no_return void -string_read_error_nr (s7_scheme* sc, const char* errmsg) { - read_error_1_nr (sc, errmsg, true); + +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)); } -/* g_error is now implemented in s7_scheme_base.c */ -#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) - -static char* -truncate_string (char* form, s7_int len, use_write_t use_write) { - const uint8_t* f= (uint8_t*) form; - s7_int i; - if (use_write != p_display) { - /* I guess we need to protect the outer double quotes in this case */ - for (i= len - 5; i >= (len / 2); i--) - if (is_white_space ((int32_t) f[i])) 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 { - 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 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 s7_pointer -object_to_string_truncated (s7_scheme* sc, s7_pointer obj) { - const s7_int len = sc->print_length; - const s7_int old_max_len= sc->objstr_max_len; - sc->objstr_max_len = len + 2; - { - s7_pointer result = s7_object_to_string (sc, obj, false); - sc->objstr_max_len= old_max_len; - if (string_length (result) > len) - truncate_string (string_value (result), len, - p_display); /* only use of truncate_string */ - return (result); - } +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 = clear_shared_info(sc->circle_info); + 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 = clear_shared_info(sc->circle_info); + if (!is_equivalent_1(sc, c_pointer_info(x), c_pointer_info(y), nci)) + return(false); + } + return(true); } -static s7_pointer -tree_descend (s7_scheme* sc, s7_pointer tree, uint32_t line) { - s7_pointer tp; - if (!is_pair (tree)) return (NULL); - if (has_location (tree)) { - uint32_t cur_line= (uint32_t) pair_line_number (tree); - if (cur_line > 0) { - if (line == 0) /* first line number we encounter will be the current - reader location (i.e. the end of the form) */ - line= cur_line; - else if (cur_line < line) return (tree); +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 = clear_shared_info(sc->circle_info); + if (!is_equal_1(sc, c_pointer_type(x), c_pointer_type(y), nci)) + return(false); } - } - tp= tree_descend (sc, car (tree), line); - return ((tp) ? tp : tree_descend (sc, cdr (tree), line)); + if (c_pointer_info(x) != c_pointer_info(y)) + { + if (!nci) nci = clear_shared_info(sc->circle_info); + if (!is_equal_1(sc, c_pointer_info(x), c_pointer_info(y), nci)) + return(false); + } + return(true); } -static no_return void -missing_close_paren_error_nr (s7_scheme* sc) { - char* syntax_msg= NULL; - const s7_pointer port = current_input_port (sc); +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))); +} - if (type_unchecked (sc->curlet) != T_LET) set_curlet (sc, sc->rootlet); +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))); +} - /* check *missing-close-paren-hook* */ - if (hook_has_functions (sc->missing_close_paren_hook)) { - s7_pointer result; - if ((port_line_number (port) > 0) && (port_filename (port))) { - set_integer (slot_value (sc->error_line), port_line_number (port)); - set_integer (slot_value (sc->error_position), port_position (port)); - slot_set_value ( - sc->error_file, - wrap_string (sc, port_filename (port), port_filename_length (port))); - } - result= s7_call (sc, sc->missing_close_paren_hook, sc->nil); - if (result != sc->unspecified) g_throw (sc, list_1 (sc, result)); - } - if (is_pair (sc->args)) { - const s7_pointer p= tree_descend (sc, sc->args, 0); - if ((p) && (is_pair (p)) && (has_location (p))) { - const s7_pointer strp = object_to_string_truncated (sc, p); - const char* form = string_value (strp); - const s7_int form_len= string_length (strp); - const s7_int 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 (port) > 0) && (port_filename (port))) { - s7_int nlen; - const s7_int len= port_filename_length (port) + - safe_strlen (sc->current_file) + - safe_strlen (syntax_msg) + 128; - const s7_pointer str= make_empty_string (sc, len, '\0'); - char* msg= string_value (str); - if (syntax_msg) { - nlen= snprintf ( - msg, len, - "missing close paren, %s[%u], last top-level form at %s[%" ld64 - "]\n%s", - port_filename (port), port_line_number (port), 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 (port), port_line_number (port), sc->current_file, - sc->current_line); - string_length (str)= nlen; - error_nr (sc, sc->read_error_symbol, set_elist_1 (sc, str)); - } - if (syntax_msg) { - s7_int len= safe_strlen (syntax_msg) + 128; - const s7_pointer str= make_empty_string (sc, len, '\0'); - char* msg= string_value (str); - len= catstrs (msg, len, "missing close paren\n", syntax_msg, "\n", - (char*) NULL); - free (syntax_msg); - string_length (str)= len; - error_nr (sc, sc->read_error_symbol, set_elist_1 (sc, str)); - } - if ((is_input_port (port)) && (!port_is_closed (port)) && - (port_data (port)) && (port_position (port) > 0)) { - const s7_pointer str = make_empty_string (sc, 128, '\0'); - const s7_int pos = port_position (port); - s7_int start= pos - 40; - char* msg = string_value (str); - memcpy ((void*) msg, (const void*) "missing close paren: ", 21); - if (start < 0) start= 0; - memcpy ((void*) (msg + 21), (void*) (port_data (port) + start), - pos - start); - string_length (str)= 21 + pos - start; - error_nr (sc, sc->read_error_symbol, set_elist_1 (sc, str)); - } - error_nr (sc, sc->read_error_symbol, - set_elist_1 (sc, wrap_string (sc, "missing close paren", 19))); -} +static bool port_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) {return(x == y);} -static no_return void -improper_arglist_error_nr (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= pop_op_stack (sc); - if (sc->args == sc->nil) /* (abs . 1) */ - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_3 (sc, wrap_string (sc, "attempt to evaluate (~S . ~S)?", 30), - func, sc->code)); - error_nr (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) { - let_set_2 (sc, closure_let (sc->error_hook), sc->body_symbol, - sc->code); /* restore old value */ - let_set_2 (sc, closure_let (sc->temp_error_hook), sc->body_symbol, sc->nil); - /* 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); +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: + if (!local_strncmp((const char *)port_filename(x), (const char *)port_filename(y), port_filename_length(x))) return(false); + if (is_input_port(x)) return(port_position(x) == port_position(y)); +#if MS_WINDOWS + return(false); +#else + return(ftell(port_file(x)) == ftell(port_file(y))); +#endif + 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); } -/* -------------------------------- 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)) - let_set_2 (sc, closure_let (hook), sc->body_symbol, functions); - return (functions); -} - -static s7_pointer -g_hook_functions (s7_scheme* sc, s7_pointer args) { -#define H_hook_functions \ - "(hook-functions hook) gets or sets the list of functions associated with " \ - "the hook" -#define Q_hook_functions \ - s7_make_signature (sc, 2, sc->is_list_symbol, sc->is_procedure_symbol) - s7_pointer hook= car (args), slot; - if (!is_any_closure (hook)) /* closure* -> closure if no args */ - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_2 (sc, - wrap_string (sc, - "hook-functions hook must be a " - "procedure created by make-hook: ~S", - 64), - hook)); - slot= lookup_slot_from (sc->body_symbol, closure_let (hook)); - return ((is_slot (slot)) ? slot_value (slot) : sc->nil); -} - -static s7_pointer -g_hook_set_functions (s7_scheme* sc, s7_pointer args) { - const s7_pointer hook= car (args); - s7_pointer lst, p; - if (!is_any_closure (hook)) /* closure* -> closure if no args */ - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_2 (sc, - wrap_string (sc, - "set! hook-functions hook must be a " - "procedure created by make-hook: ~S", - 69), - hook)); - lst= cadr (args); - for (p= lst; is_pair (p); p= cdr (p)) - if ((!is_any_procedure (car (p))) || (!s7_is_aritable (sc, car (p), 1))) - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_2 ( - sc, - wrap_string (sc, - "new hook-functions value must be nil or a list of " - "functions, each accepting one argument: ~S", - 92), - lst)); - if (!is_null (p)) - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_2 ( - sc, - wrap_string ( - sc, - "new hook-functions value must be nil or a a proper list: ~S", - 59), - lst)); - { - s7_pointer slot= lookup_slot_from (sc->body_symbol, closure_let (hook)); - if (is_slot (slot)) slot_set_value (slot, lst); - } - return (lst); +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; } -/* -------------------------------- begin_hook -------------------------------- - */ -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 - */ - const opcode_t op= sc->cur_op; - push_stack_direct (sc, OP_BARRIER); - sc->begin_hook (sc, &result); - if (result) { - const s7_pointer cur_code= current_code (sc); - /* 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 */ - slot_set_value (sc->error_code, cur_code); - if (has_location (cur_code)) { - set_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)]); - set_integer (slot_value (sc->error_position), - (s7_int) pair_position (cur_code)); - } - else { - set_integer (slot_value (sc->error_line), 0); - set_integer (slot_value (sc->error_position), 0); - slot_set_value (sc->error_file, sc->F); +static Inline bool inline_equal_ref(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) /* pair_equal:lg/list/io, [read] */ +{ + /* here we know x and y are pointers to the same type of structure */ + int32_t ref_y = (is_collected(y)) ? peek_shared_ref_1(ci, y) : 0; + if (is_collected(x)) + { + int32_t 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); } -#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", 20); - /* 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 syntax_error */ - return (false); + 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); } -/* -------------------------------- apply -------------------------------- */ -static s7_pointer -apply_list_star (s7_scheme* sc, s7_pointer d) { - /* we check this ahead of time: if (is_null(cdr(d))) return(car(d)); */ - s7_pointer p; - gc_protect_via_stack (sc, d); - begin_temp (sc->y, p= cons (sc, car (d), cdr (d))); - 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); - } - unstack_gc_protect (sc); - set_cdr (p, cadr (p)); - return_with_end_temp (sc->y); -} - -static no_return void -apply_list_error_nr (s7_scheme* sc, s7_pointer lst) { - error_nr ( - 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 - */ - const s7_pointer func= car (args); - if (!is_applicable (func)) apply_error_nr (sc, func, cdr (args)); - if (is_null (cdr (args))) { - push_stack (sc, OP_APPLY, sc->nil, func); - return (sc->nil); - } - if (is_safe_procedure (func)) { - s7_pointer arg, next_arg; - if (is_immutable ( - args)) /* (apply '(1) '(1)) where sc->t2_1 gets used in op_x_aa? */ - args= copy_proper_list (sc, args); - for (arg= args, next_arg= cdr (args); is_pair (cdr (next_arg)); - arg= next_arg, next_arg= cdr (next_arg)) - ; - /* 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 (next_arg))) /* (apply + #f) etc, the cycle protection here - is checked in s7test */ - apply_list_error_nr (sc, args); - set_cdr (arg, car (next_arg)); /* args affected, so don't depend on - cdr(args) from above */ - - if (is_c_function (func)) /* handle in-place to get better error messages */ - { - s7_int len; - const uint8_t typ= type (func); - if (typ == T_C_RST_NO_REQ_FUNCTION) - return (c_function_call (func) (sc, cdr (args))); - len= proper_list_length (cdr (args)); - if (c_function_max_args (func) < len) - error_nr (sc, sc->wrong_number_of_args_symbol, - set_elist_3 (sc, too_many_arguments_string, func, - set_ulist_1 (sc, sc->apply_symbol, args))); - if ((typ == T_C_FUNCTION) && (len < c_function_min_args (func))) - error_nr (sc, sc->wrong_number_of_args_symbol, - set_elist_3 (sc, not_enough_arguments_string, func, - set_ulist_1 (sc, sc->apply_symbol, args))); - return (c_function_call (func) (sc, cdr (args))); - } - push_stack (sc, OP_APPLY, cdr (args), func); - return (sc->nil); - } - sc->code= func; - sc->args= - (is_null (cddr (args))) ? cadr (args) : apply_list_star (sc, cdr (args)); - if (!s7_is_proper_list (sc, sc->args)) apply_list_error_nr (sc, sc->args); - - /* (define imp (immutable! (cons 0 (immutable! (cons 1 (immutable! (cons 2 - * ()))))))) (define (fop4 x y) (apply x y)) (display (object->string (apply - * (lambda (a . b) (cons a b)) imp) :readable)) -> (list 0 1 2) (display - * (object->string (fop4 (lambda (a . b) (cons a b)) imp) :readable)) -> (cons - * 0 (immutable! (cons 1 (immutable! (cons 2 ()) g_apply sees the first one - * and thinks the lambda arg is unsafe, apply_ss sees the second and thinks it - * is safe (hence the list is not copied), so calling sort on the first is - * fine, but on the second gets an immutable object error. - */ - if (needs_copied_args (sc->code)) sc->args= copy_proper_list (sc, 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_nr(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 -apply_method_closure (s7_scheme* sc, s7_pointer func, s7_pointer args) { - push_stack_direct (sc, OP_EVAL_DONE); - sc->code= func; - sc->args= (needs_copied_args (sc->code)) ? copy_proper_list (sc, args) : args; - set_curlet (sc, make_let (sc, closure_let (sc->code))); - eval (sc, OP_APPLY_LAMBDA); - return (sc->value); -} - -static s7_pointer apply_c_function_unopt (s7_scheme* sc, s7_pointer func, - s7_pointer args); - -static s7_pointer -implicit_index_checked (s7_scheme* sc, s7_pointer obj, s7_pointer in_obj, - s7_pointer indices) { - if (!is_applicable (in_obj)) - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_4 ( - sc, - wrap_string (sc, "~$ becomes ~$, but ~S can't take arguments", 42), - set_ulist_1 (sc, obj, indices), cons (sc, in_obj, cdr (indices)), - in_obj)); - return (implicit_index (sc, in_obj, cdr (indices))); -} - -static s7_pointer -implicit_index (s7_scheme* sc, s7_pointer obj, s7_pointer indices) { - /* (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 (s7i_vector_ref_1 (sc, obj, indices)); - - case T_FLOAT_VECTOR: { - s7_pointer result= - 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 (result); - } - case T_COMPLEX_VECTOR: { - s7_pointer result= - univect_ref (sc, set_ulist_1 (sc, obj, indices), - sc->complex_vector_ref_symbol, T_COMPLEX_VECTOR); - set_car (sc->u1_1, sc->F); - return (result); - } - case T_INT_VECTOR: { - s7_pointer result= 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 (result); - } - case T_BYTE_VECTOR: { - s7_pointer result= 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 (result); - } - case T_STRING: /* (#("12" "34") 0 1) -> #\2 */ - if (!is_null (cdr (indices))) - error_nr (sc, sc->wrong_number_of_args_symbol, - set_elist_3 (sc, too_many_arguments_string, obj, indices)); - if (!is_t_integer (car (indices))) - wrong_type_error_nr (sc, sc->string_ref_symbol, 2, car (indices), - sc->type_names[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 */ - { - s7_pointer in_obj= list_ref_1 (sc, obj, car (indices)); - if (is_pair (cdr (indices))) - return (implicit_index_checked (sc, obj, in_obj, indices)); - return (in_obj); - } - case T_HASH_TABLE: /* ((vector (hash-table '(a . 1) '(b . 2))) 0 'a) -> 1 */ +static bool equal_ref(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) {return(inline_equal_ref(sc, x, y, ci));} + +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; + + 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_clist_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 = clear_shared_info(sc->circle_info); { - s7_pointer in_obj= s7_hash_table_ref (sc, obj, car (indices)); - if (is_pair (cdr (indices))) - return (implicit_index_checked (sc, obj, in_obj, indices)); - return (in_obj); - } - case T_LET: { - s7_pointer in_obj= let_ref (sc, obj, car (indices)); - if (is_pair (cdr (indices))) - return (implicit_index_checked (sc, obj, in_obj, indices)); - return (in_obj); - } - case T_C_OBJECT: { - s7_pointer result= - (*(c_object_ref (sc, obj))) (sc, set_ulist_1 (sc, obj, indices)); - set_car (sc->u1_1, sc->F); - return (result); - } - case T_ITERATOR: /* indices is not nil, so this is an error */ - error_nr (sc, sc->wrong_number_of_args_symbol, - set_elist_3 (sc, too_many_arguments_string, obj, indices)); - - case T_CLOSURE: - case T_CLOSURE_STAR: - if (!is_safe_closure ( - obj)) /* s7_call can't work in general with unsafe stuff */ - error_nr ( - sc, - sc->syntax_error_symbol, /* ((list (lambda (x) (values x x))) 0 1) */ - set_elist_3 ( - sc, - wrap_string ( - sc, "can't call an unsafe function implicitly: ~S ~S", 47), - obj, indices)); - check_stack_size (sc); - sc->temp9 = indices; /* (needs_copied_args(obj)) ? copy_proper_list(sc, indices) : indices; */ /* s7_call copies and this is safe? 2-Oct-22 (and below) */ - sc->value= s7_call (sc, obj, sc->temp9); - if ((S7_DEBUGGING) && (!is_pair (sc->temp9))) - fprintf (stderr, "%s[%d]: temp9: %s\n", __func__, __LINE__, - display (sc->temp9)); - sc->temp9= sc->unused; - if ((S7_DEBUGGING) && (is_multiple_value (sc->value))) - fprintf (stderr, "mv: %s %s %s\n", display (obj), display (indices), - display (sc->value)); - /* if mv: sc->value = splice_in_values(sc, multiple_value(sc->value)); */ - return (sc->value); - - case T_C_FUNCTION: /* probably something like ((list abs) 0 -1) */ - return (apply_c_function_unopt (sc, obj, indices)); - - case T_C_RST_NO_REQ_FUNCTION: - if (!is_safe_procedure (obj)) /* values in particular */ - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, "can't call an unsafe procedure implicitly: ~S ~S", 48), - obj, indices)); - return (c_function_call (obj) (sc, indices)); - - default: - if (!is_applicable (obj)) /* (#2d((0 0)(0 0)) 0 0 0) */ - apply_error_nr (sc, obj, indices); - sc->temp9 = indices; /* (needs_copied_args(obj)) ? copy_proper_list(sc, indices) : indices; */ /* do not use sc->args here! */ - /* the following s7_call can clobber the temp var */ - sc->value= s7_call (sc, obj, sc->temp9); - sc->temp9= sc->unused; - if (is_multiple_value (sc->value)) - sc->value= splice_in_values (sc, multiple_value (sc->value)); - return (sc->value); - } + s7_pointer pa = to_list(sc, set_plist_1(sc, a)); + s7_pointer pb = to_list(sc, set_plist_1(sc, b)); + for (; 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_ = find_method_with_let(Sc, X, Sc->is_equivalent_symbol); \ + if (_Equal_Func_ != Sc->undefined) \ + return(s7_boolean(Sc, s7_apply_function(Sc, _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 inline void -fill_star_defaults (s7_scheme* sc, s7_pointer func, int32_t start_arg, - int32_t n_args, s7_pointer par) { - s7_pointer* df= c_function_arg_defaults (func); - if (c_func_has_simple_defaults (func)) - for (int32_t i= start_arg; i < n_args; i++, par= cdr (par)) - set_car (par, df[i]); - else - for (int32_t 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 - set_car (par, (is_pair (defval)) ? s7_eval (sc, defval, sc->rootlet) - : defval); +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 len; + shared_info_t *nci = ci; + hash_check_t hash_func; + 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_mapper(x) != default_hash_map) || (hash_table_mapper(y) != default_hash_map))) + { + if (hash_table_checker(x) != hash_table_checker(y)) + return(false); + if (hash_table_mapper(x) != hash_table_mapper(y)) + return(false); } -} -static s7_pointer -set_c_function_star_args (s7_scheme* sc) { - int32_t i; - s7_pointer arg, par, call_args; - const s7_pointer func= sc->code; - const int32_t n_args= - c_function_max_args (func); /* not counting keywords, I think, "par" and - "arg" are not used consistently here */ + len = (s7_int)hash_table_size(x); + lists = hash_table_elements(x); + if (!nci) nci = clear_shared_info(sc->circle_info); + eqf = (equivalent) ? is_equivalent_1 : is_equal_1; - if (is_safe_procedure (func)) call_args= c_function_call_args (func); - else { - call_args= make_list (sc, c_function_optional_args (func), sc->F); - gc_protect_via_stack (sc, call_args); - } - /* 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_symbol_and_keyword (car (arg))) set_car (par, car (arg)); - else { - s7_pointer kpar, karg; - int32_t ki; - s7_pointer* par_names; - /* 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_small_symbol_set + hash_func = hash_table_checker(y); + if ((hash_func != hash_equal) && (hash_func != hash_equivalent)) + { + for (s7_int i = 0; i < len; i++) + for (hash_entry_t *entry = lists[i]; entry; entry = hash_entry_next(entry)) + { + hash_entry_t *y_val = hash_func(sc, y, hash_entry_key(entry)); + if (y_val == sc->unentry) + return(false); + if (!eqf(sc, hash_entry_value(entry), 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 hash_func? */ - for (kpar= call_args; kpar != par; kpar= cdr (kpar)) - set_checked (kpar); - for (; is_pair (kpar); kpar= cdr (kpar)) - clear_checked (kpar); - par_names= c_function_par_names ( - func); /* changed to use symbols here, not keywords 2-Jan-24 */ - for (ki= i, karg= arg, kpar= par; (ki < n_args) && (is_pair (karg)); - ki++, karg= cdr (karg)) - if (!is_symbol_and_keyword (car (karg))) { - if (is_checked (kpar)) { - if (!is_safe_procedure (func)) unstack_gc_protect (sc); - error_nr (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 pars; - int32_t j; - for (j= 0, pars= call_args; j < n_args; j++, pars= cdr (pars)) - if (par_names[j] == keyword_symbol (car (karg))) break; - if (j == n_args) { - if (!c_function_allows_other_keys (func)) { - if (!is_safe_procedure (func)) unstack_gc_protect (sc); - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_2 ( - sc, - wrap_string (sc, "~A is not a parameter name?", 27), - car (karg))); - } - karg= cdr (karg); - if (is_null (karg)) /* (f :x) where f arglist includes - :allow-other-keys */ - { - if (!is_safe_procedure (func)) unstack_gc_protect (sc); - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_4 ( - sc, wrap_string (sc, "~A: key ~S, but no value: ~S", 28), - func, car (arg), sc->args)); - } - ki--; - } - else { - if (is_checked (pars)) { - if (!is_safe_procedure (func)) unstack_gc_protect (sc); - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_3 (sc, parameter_set_twice_string, car (pars), - sc->args)); - } - if (!is_pair (cdr (karg))) { - if (!is_safe_procedure (func)) unstack_gc_protect (sc); - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_4 ( - sc, wrap_string (sc, "~A: key ~S, but no value: ~S", 28), - func, car (karg), sc->args)); - } - set_checked (pars); - karg= cdr (karg); - set_car (pars, car (karg)); - kpar= cdr (kpar); - } - } - if ((!is_null (karg)) && (!c_function_allows_other_keys (func))) { - if (!is_safe_procedure (func)) unstack_gc_protect (sc); - error_nr ( - sc, sc->wrong_number_of_args_symbol, - set_elist_4 ( - sc, - wrap_string (sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), - func, func, sc->args)); - } - if (ki < n_args) { - s7_pointer* par_defaults= 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, par_defaults[ki]); - } - else - for (ki= i, kpar= par; ki < n_args; ki++, kpar= cdr (kpar)) - if (!is_checked (kpar)) { - s7_pointer defval= par_defaults[ki]; - if (is_symbol (defval)) - set_car (kpar, lookup_checked (sc, defval)); - else - set_car (kpar, (is_pair (defval)) - ? s7_eval (sc, defval, sc->rootlet) - : defval); - } - } - if (!is_safe_procedure (func)) unstack_gc_protect (sc); - return (call_args); - } - if (!is_null (arg)) { - if (!is_safe_procedure (func)) unstack_gc_protect (sc); - error_nr (sc, sc->wrong_number_of_args_symbol, - set_elist_4 ( - sc, - wrap_string (sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), - func, func, sc->args)); - } - if (i < n_args) fill_star_defaults (sc, func, i, n_args, par); - if (!is_safe_procedure (func)) unstack_gc_protect (sc); - return (call_args); -} + return(true); + } -static s7_pointer -set_c_function_star_defaults (s7_scheme* sc, int32_t num) { - s7_pointer call_args, par; - const s7_pointer func = sc->code; - const int32_t n_args= c_function_max_args (func); + /* 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 (s7_int i = 0; i < len; i++) + for (hash_entry_t *p = lists[i]; p; p = hash_entry_next(p)) /* entry declared below */ + { + const s7_pointer key = hash_entry_key(p); + const s7_uint hash = hash_loc(sc, y, key); + const s7_uint loc = hash % hash_table_mask(y); + hash_entry_t *entry; - if (is_safe_procedure (func)) call_args= c_function_call_args (func); - else { - call_args= make_list (sc, c_function_optional_args (func), sc->F); - gc_protect_via_stack (sc, call_args); - } - par= call_args; - if (num == 1) { - set_car (par, car (sc->args)); - par= cdr (par); - } - fill_star_defaults (sc, func, num, n_args, par); - if (!is_safe_procedure (func)) unstack_gc_protect (sc); - 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; /* this protection is needed, see snd-test.scm test 8 */ - sc->z = sc->code; - sc->args= T_Ext (args); - sc->code= fnc; - apply_c_function_star (sc); - sc->args= sc->w; - sc->code= sc->z; - sc->z = sc->unused; - 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); + for (entry = hash_table_element(y, loc); entry; entry = hash_entry_next(entry)) + if ((hash_entry_raw_hash(entry) == hash) && + (eqf(sc, hash_entry_key(entry), key, nci))) + break; + if (!entry) + return(false); + if (!eqf(sc, hash_entry_value(p), hash_entry_value(entry), nci)) + return(false); + } + return(true); } -/* -------------------------------- eval -------------------------------- */ -s7_pointer -s7_eval (s7_scheme* sc, s7_pointer code, s7_pointer let) { - declare_jump_info (); - TRACK (sc); - if (sc->safety > no_safety) { - if (!s7_is_valid (sc, code)) - s7_warn (sc, 256, - "the second argument to %s (the code to be evaluated): %p, is " - "not an s7 object\n", - __func__, code); - if (!s7_is_valid (sc, let)) - s7_warn (sc, 256, - "the third argument to %s (the environment): %p, is not an s7 " - "object\n", - __func__, let); - } - 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; - set_curlet (sc, (is_let (let)) ? let : sc->rootlet); - eval (sc, OP_EVAL); - } - restore_jump_info (sc); +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));} - if (is_multiple_value (sc->value)) - sc->value= splice_in_values (sc, multiple_value (sc->value)); - return (sc->value); +static bool slots_match(s7_scheme *sc, s7_pointer x_slot, s7_pointer y_let, shared_info_t *nci) +{ + for (s7_pointer e = y_let; e; e = let_outlet(e)) + for (s7_pointer y_slot = let_slots(e); is_not_slot_end(y_slot); y_slot = next_slot(y_slot)) + if (slot_symbol(x_slot) == slot_symbol(y_slot)) /* we know something will match */ + return(is_equal_1(sc, slot_value(x_slot), slot_value(y_slot), nci)); + return(false); } -s7_pointer -s7_eval_with_location (s7_scheme* sc, s7_pointer code, s7_pointer let, - 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_eval (sc, code, (let == sc->nil) ? sc->rootlet : let); - if (caller) { - sc->s7_call_name= NULL; - sc->s7_call_file= NULL; - sc->s7_call_line= -1; - } - return (result); +static bool slots_equivalent_match(s7_scheme *sc, s7_pointer x_slot, s7_pointer y_let, shared_info_t *nci) +{ + for (s7_pointer e = y_let; e; e = let_outlet(e)) + for (s7_pointer y_slot = let_slots(e); is_not_slot_end(y_slot); y_slot = next_slot(y_slot)) + if (slot_symbol(x_slot) == slot_symbol(y_slot)) /* we know something will match */ + return(is_equivalent_1(sc, slot_value(x_slot), slot_value(y_slot), nci)); + return(false); } -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, has_let_signature (sc)) - - if (is_pair (cdr (args))) { - s7_pointer let= cadr (args); - if (!is_let (let)) { - s7_pointer new_let= find_let (sc, let); - if (!is_let (new_let)) - find_let_error_nr (sc, sc->eval_symbol, let, new_let, 2, args); - let= new_let; - } - set_curlet (sc, let); - } - 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); /* clears "unsafe" ops, not all ops */ - set_current_code (sc, sc->code); - if (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) { - if (is_c_function (func)) - return (c_function_call (func) ( - sc, args)); /* no check for wrong-number-of-args -- is that reasonable? - maybe use apply_c_function(sc, func, 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_truncated (func), display_truncated (args))); - - sc->temp4= T_App (func); /* this is feeble GC protection */ - sc->temp2= T_Lst (args); /* only use of temp2 */ - 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, __func__, 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; - 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); - } -} +static bool let_equal_1(s7_scheme *sc, s7_pointer x_let, s7_pointer y_let, shared_info_t *ci, bool equivalent) +{ + int32_t x_len, y_len; -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); -} + if ((!is_let(y_let)) || (x_let == sc->rootlet) || (y_let == sc->rootlet)) /* (equal? (rootlet) (rootlet)) is checked in let_equal below */ + return(false); -/* -------------------------------- type-of -------------------------------- */ -#if !WITH_GCC -static inline bool -gen_type_match (s7_scheme* sc, s7_pointer val, - uint8_t typ) /* opt3_byte = uint8_t */ + if ((ci) && (equal_ref(sc, x_let, y_let, ci))) return(true); + + clear_small_symbol_set(sc); /* not begin, slots_match below calls equal_1 -> let_equal_1 */ + x_len = 0; + for (s7_pointer e = x_let; e; e = let_outlet(e)) + for (s7_pointer slot = let_slots(e); is_not_slot_end(slot); slot = next_slot(slot)) + if (!symbol_is_in_small_symbol_set(sc, slot_symbol(slot))) + { + add_symbol_to_small_symbol_set(sc, slot_symbol(slot)); + x_len++; + } + + for (s7_pointer e = y_let; e; e = let_outlet(e)) + for (s7_pointer slot = let_slots(e); is_not_slot_end(slot); slot = next_slot(slot)) + if (!symbol_is_in_small_symbol_set(sc, slot_symbol(slot))) /* symbol in y, not in x */ + return(false); + y_len = 0; + for (s7_pointer e = y_let; e; e = let_outlet(e)) + for (s7_pointer slot = let_slots(e); is_not_slot_end(slot); slot = next_slot(slot)) + if (small_symbol_tag(slot_symbol(slot)) != 0) + { + y_len++; + set_small_symbol_tag(slot_symbol(slot), 0); + } + if (x_len != y_len) /* symbol in x, not in y */ + return(false); + { + shared_info_t *nci = ci; + if (!nci) nci = clear_shared_info(sc->circle_info); + for (s7_pointer e = x_let; e; e = let_outlet(e)) + for (s7_pointer slot = let_slots(e); is_not_slot_end(slot); slot = next_slot(slot)) + if (small_symbol_tag(slot_symbol(slot)) == 0) /* unshadowed */ + { + set_small_symbol_tag(slot_symbol(slot), sc->small_symbol_tag); /* values don't match */ + if (((!equivalent) && (!slots_match(sc, slot, y_let, nci))) || + ((equivalent) && (!slots_equivalent_match(sc, slot, y_let, nci)))) + return(false); + }} + return(true); +} + +static bool let_equal(s7_scheme *sc, s7_pointer x_let, s7_pointer y_let, shared_info_t *ci) { - return ((type (val) == typ) || - ((has_active_methods (sc, val)) && - (apply_boolean_method (sc, val, sc->type_to_typers[typ]) != sc->F))); + /* x_let == y_let if all unshadowed vars match, leaving aside the rootlet, so that for any local variable, we get the same value in either x_let or y_let */ + return((x_let == y_let) || (let_equal_1(sc, x_let, y_let, ci, false))); } -#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_BACRO] = sc->is_macro_symbol; - sc->type_to_typers[T_BACRO_STAR] = sc->is_macro_symbol; - sc->type_to_typers[T_BOOLEAN] = sc->is_boolean_symbol; - sc->type_to_typers[T_BYTE_VECTOR] = sc->is_byte_vector_symbol; - sc->type_to_typers[T_CATCH] = sc->F; - sc->type_to_typers[T_CHARACTER] = sc->is_char_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_COMPLEX] = sc->is_complex_symbol; - sc->type_to_typers[T_CONTINUATION] = sc->is_continuation_symbol; - sc->type_to_typers[T_COUNTER] = sc->F; - sc->type_to_typers[T_FREE] = sc->error_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_MACRO] = sc->is_macro_symbol; - sc->type_to_typers[T_C_OBJECT] = sc->is_c_object_symbol; - sc->type_to_typers[T_C_POINTER] = sc->is_c_pointer_symbol; - sc->type_to_typers[T_C_RST_NO_REQ_FUNCTION]= sc->is_procedure_symbol; - sc->type_to_typers[T_DYNAMIC_WIND] = sc->F; - sc->type_to_typers[T_EOF] = sc->is_eof_object_symbol; - sc->type_to_typers[T_FLOAT_VECTOR] = sc->is_float_vector_symbol; - sc->type_to_typers[T_COMPLEX_VECTOR] = sc->is_complex_vector_symbol; - sc->type_to_typers[T_FREE] = sc->F; - sc->type_to_typers[T_GOTO] = sc->is_goto_symbol; - sc->type_to_typers[T_HASH_TABLE] = sc->is_hash_table_symbol; - sc->type_to_typers[T_INPUT_PORT] = sc->is_input_port_symbol; - sc->type_to_typers[T_INTEGER] = sc->is_integer_symbol; - sc->type_to_typers[T_INT_VECTOR] = sc->is_int_vector_symbol; - sc->type_to_typers[T_ITERATOR] = sc->is_iterator_symbol; - sc->type_to_typers[T_LET] = sc->is_let_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_NIL] = sc->is_null_symbol; - sc->type_to_typers[T_OUTPUT_PORT] = sc->is_output_port_symbol; - sc->type_to_typers[T_PAIR] = sc->is_pair_symbol; - sc->type_to_typers[T_RANDOM_STATE] = sc->is_random_state_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_SLOT] = sc->F; - sc->type_to_typers[T_STACK] = sc->F; - sc->type_to_typers[T_STRING] = sc->is_string_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_UNDEFINED] = sc->is_undefined_symbol; - sc->type_to_typers[T_UNSPECIFIED]= sc->is_unspecified_symbol; - sc->type_to_typers[T_UNUSED] = sc->F; - sc->type_to_typers[T_VECTOR] = sc->is_vector_symbol; -} - -s7_pointer -s7_type_of (s7_scheme* sc, s7_pointer arg) { - return (sc->type_to_typers[type (arg)]); +/* what should these do if there are setters? */ +static bool let_equivalent(s7_scheme *sc, s7_pointer x_let, s7_pointer y_let, shared_info_t *ci) +{ + if (x_let == y_let) return(true); + if (!is_global(sc->is_equivalent_symbol)) + { + check_equivalent_method(sc, x_let, y_let); + check_equivalent_method(sc, y_let, x_let); + } + return(let_equal_1(sc, x_let, y_let, ci, true)); } -/* g_type_of migrated to s7_scheme_predicate.c */ -#define H_type_of \ - "(type-of obj) returns a symbol describing obj's type: (type-of 1): " \ - "'integer?" -#define Q_type_of \ - s7_make_signature ( \ - sc, 2, s7_make_signature (sc, 2, sc->is_symbol_symbol, sc->not_symbol), \ - sc->T) - -/* -------------------------------- 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 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 = find_method(sc, closure_let(x), sc->is_equal_symbol); + if (equal_func != sc->undefined) + return(s7_boolean(sc, s7_apply_function(sc, equal_func, set_plist_2(sc, x, y)))); + } + return(false); } -#ifndef EXIT_SUCCESS -#define EXIT_SUCCESS 0 -#define EXIT_FAILURE 1 -#endif - -static s7_pointer -g_emergency_exit (s7_scheme* sc, s7_pointer args) { -#define H_emergency_exit \ - "(emergency-exit (obj #t)) exits s7 immediately. 'obj', the value passed " \ - "to libc's _exit, can be an integer or #t=success (0) or #f=fail (1)." -#define Q_emergency_exit s7_make_signature (sc, 2, sc->T, sc->T) - - s7_pointer obj; - if (is_null (args)) - _exit (EXIT_SUCCESS); /* r7rs spec says use _exit here (which does not call - any functions registered with atexit or on_exit */ - 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_clamped_if_gmp (sc, obj)); - return (sc->F); -} - -static gc_list_t* -call_c_object_frees (s7_scheme* sc) { - gc_list_t* gp= sc->c_objects; - for (s7_int i= 0; i < gp->loc; i++) { - s7_pointer cobj= gp->list[i]; - if (c_object_gc_free (sc, cobj)) - (*(c_object_gc_free (sc, cobj))) (sc, cobj); - else (*(c_object_free (sc, cobj))) (c_object_value (cobj)); - } - return (gp); /* for s7_free */ +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_pars(x), closure_pars(y), ci)) && + (is_equivalent_1(sc, closure_body(x), closure_body(y), ci))); } -static s7_pointer -g_exit (s7_scheme* sc, s7_pointer args) { -#define H_exit \ - "(exit obj cobj) exits s7. 'obj', the value passed to libc's exit, can be an integer or #t=success (0) or #f=fail (1). \ -'cobj' is a boolean (defaults to #f), #t causes exit to call all active c-object gc_free functions." -#define Q_exit s7_make_signature (sc, 3, sc->T, sc->T, sc->is_boolean_symbol) - - /* calling s7_eval_c_string in an atexit function seems to be problematic -- - * it works, but args can be changed? */ - /* r7rs.pdf says exit checks the stack for dynamic-winds and runs the "after" - * functions, if any, and that it allows atexit functions to be called, so we - * need to use libc's exit, not _exit -- there's an example C program at the - * end of s7test.scm. - */ - for (s7_int op_loc= stack_top (sc) - 1; op_loc > 0; op_loc-= 4) - if (stack_op (sc->stack, op_loc) == OP_DYNAMIC_WIND) { - s7_pointer dwind= T_Dyn (stack_code (sc->stack, op_loc)); - if (dynamic_wind_state (dwind) == - dwind_body) /* otherwise init func never ran? */ +static bool pair_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) +{ + if (x == y) + return(true); + if (!is_pair(y)) + return(false); + if (!ci) + ci = clear_shared_info(sc->circle_info); + else + if (inline_equal_ref(sc, x, y, ci)) + return(true); + if (!is_equal_1(sc, car(x), car(y), ci)) return(false); + { + s7_pointer px, py; + for (px = cdr(x), py = cdr(y); (is_pair(px)) && (is_pair(py)); px = cdr(px), py = cdr(py)) { - dynamic_wind_state (dwind)= dwind_finish; - if (dynamic_wind_out (dwind) != sc->F) - s7_call (sc, dynamic_wind_out (dwind), sc->nil); + if (!is_equal_1(sc, car(px), car(py), ci)) return(false); + if (inline_equal_ref(sc, px, py, ci)) return(true); } - } - /* another case that Victor Lazzarini mentioned: there's no easy way in s7 to - * ask that all c-object free methods be run before exiting. I think I'll add - * that code here under an optional second argument. - */ - if ((is_pair (args)) && (is_pair (cdr (args)))) { - s7_pointer cobj= cadr (args); - if (!is_boolean (cobj)) - wrong_type_error_nr (sc, sc->exit_symbol, 2, cobj, a_boolean_string); - if (cobj == sc->T) call_c_object_frees (sc); - } - if (hook_has_functions (sc->exit_hook)) { - s7_pointer exit_code; - if (is_null (args)) exit_code= s7_make_integer (sc, EXIT_SUCCESS); - else { - s7_pointer obj= car (args); - if (obj == sc->F) exit_code= s7_make_integer (sc, EXIT_FAILURE); - else if ((obj == sc->T) || (!s7_is_integer (obj))) - exit_code= s7_make_integer (sc, EXIT_SUCCESS); - else exit_code= obj; - } - s7_apply_function (sc, sc->exit_hook, set_plist_1 (sc, exit_code)); - } - - 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 ()); - - if (is_null (args)) exit (EXIT_SUCCESS); /* allow atexit functions etc */ - { - s7_pointer 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_clamped_if_gmp (sc, obj)); + return((px == py) || (is_equal_1(sc, px, py, ci))); } -#if __TINYC__ - return (sc->F); /* never reached, but tcc complains */ -#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 let, const char* func, s7_pointer expr, - s7_pointer var) { - if (let_slots (let) != s7_t_slot (sc, var)) { - fprintf (stderr, "%s%s %s is out of date (%s in %s -> %s)%s\n", bold_text, - func, display (expr), display (var), display (sc->curlet), - (is_not_slot_end (let_slots (let))) ? display (let_slots (let)) - : "no slots", - unbold_text); - if (sc->stop_at_error) abort (); - /* this usually signals a problem with enviroments (or arglists if - * optimize_lambda) */ +static bool pair_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) +{ + if (x == y) + return(true); + if (!is_pair(y)) + { + check_equivalent_method(sc, y, x); + return(false); + } + if (!ci) + ci = clear_shared_info(sc->circle_info); + else + if (inline_equal_ref(sc, x, y, ci)) + return(true); + if (!is_equivalent_1(sc, car(x), car(y), ci)) return(false); + { + s7_pointer px, py; + 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 (inline_equal_ref(sc, px, py, ci)) return(true); + } + return((px == py) || ((is_equivalent_1(sc, px, py, ci)))); } } -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 bool vector_rank_match(s7_scheme *sc, s7_pointer x, s7_pointer y) +{ + s7_int x_dims; + 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 (s7_int j = 0; j < x_dims; j++) + if (vector_dimension(x, j) != vector_dimension(y, j)) + return(false); + return(true); } -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 bool iv_equivalent(const s7_int *ex, const 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 void -check_u_1 (s7_scheme* sc, s7_pointer let, const char* func, s7_pointer expr, - s7_pointer var) { - if (next_slot (let_slots (let)) != s7_t_slot (sc, var)) { - fprintf (stderr, "%s%s %s is out of date (%s in %s -> %s)%s\n", bold_text, - func, display (expr), display (var), display (let), - (is_not_slot_end (next_slot (let_slots (let)))) - ? display (next_slot (let_slots (let))) - : "no next slot", - unbold_text); - if (sc->stop_at_error) abort (); - } +static bool byte_vector_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y) +{ + const s7_int len = vector_length(x); + const uint8_t *xp = byte_vector_bytes(x); + const uint8_t *yp = byte_vector_bytes(y); + for (s7_int i = 0; i < len; i++) + if (xp[i] != yp[i]) + return(false); + return(true); } -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 bool biv_equivalent(s7_pointer x, s7_pointer y) +{ + const s7_int len = vector_length(x); + const uint8_t *xp = byte_vector_bytes(x); + const s7_int *yp = int_vector_ints(y); + for (s7_int i = 0; i < len; i++) + if ((s7_int)(xp[i]) != yp[i]) + return(false); + return(true); } -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 bool fv_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_int len) +{ + const s7_double *arr1 = float_vector_floats(x), *arr2 = float_vector_floats(y); + const s7_double fudge = sc->equivalent_float_epsilon; + if (fudge == 0.0) + { + for (s7_int i = 0; i < len; i++) + if ((arr1[i] != arr2[i]) && + ((!is_NaN(arr1[i])) || (!is_NaN(arr2[i])))) + return(false); + } + else + if ((len & 0x3) == 0) + for (s7_int i = 0; i < len; ) + LOOP_4(if (!floats_are_equivalent(sc, arr1[i], arr2[i])) return(false); i++); + else + for (s7_int i = 0; i < len; i++) + if (!floats_are_equivalent(sc, arr1[i], arr2[i])) + return(false); + return(true); } -static void -check_v_1 (s7_scheme* sc, s7_pointer let, const char* func, s7_pointer expr, - s7_pointer var) { - if (next_slot (next_slot (let_slots (let))) != s7_t_slot (sc, var)) { - fprintf (stderr, "%s%s %s is out of date (%s in %s -> %s)%s\n", bold_text, - func, display (expr), display (var), display (let), - (is_not_slot_end (next_slot (next_slot (let_slots (let))))) - ? display (next_slot (next_slot (let_slots (let)))) - : "no next slot", - unbold_text); - if (sc->stop_at_error) abort (); - } -} +static bool cv_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_int len) +{ + const s7_complex *arr1 = complex_vector_complexes(x), *arr2 = complex_vector_complexes(y); + const s7_double fudge = sc->equivalent_float_epsilon; + if (fudge == 0.0) + { + for (s7_int i = 0; i < len; i++) + if (((creal(arr1[i]) != creal(arr2[i])) || (cimag(arr1[i]) != cimag(arr2[i]))) && + ((!is_NaN(creal(arr1[i]))) || (!is_NaN(creal(arr2[i]))) || (!is_NaN(cimag(arr1[i]))) || (!is_NaN(cimag(arr2[i]))))) + return(false); + } + else + if ((len & 0x3) == 0) + for (s7_int i = 0; i < len; ) + LOOP_4(if ((!floats_are_equivalent(sc, creal(arr1[i]), creal(arr2[i]))) || (!floats_are_equivalent(sc, cimag(arr1[i]), cimag(arr2[i])))) return(false); i++); + else + for (s7_int i = 0; i < len; i++) + if ((!floats_are_equivalent(sc, creal(arr1[i]), creal(arr2[i]))) || (!floats_are_equivalent(sc, cimag(arr1[i]), cimag(arr2[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 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 bool vector_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) +{ + s7_int len; + shared_info_t *nci = ci; -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)))))); + if (!is_any_vector(y)) return(false); + base_vector_equal(sc, x, y); /* sets len */ + if (type(x) != type(y)) + { + if ((is_int_vector(x)) && (is_byte_vector(y))) + return(biv_equivalent(y, x)); + if ((is_byte_vector(x)) && (is_int_vector(y))) + return(biv_equivalent(x, y)); + for (s7_int 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 = clear_shared_info(sc->circle_info); + } + /* splitting out the typed_vector_typer case is only slightly faster (5% and much trickier) */ + for (s7_int i = 0; i < len; i++) + if (!is_equal_1(sc, vector_element(x, i), vector_element(y, i), nci)) + return(false); + return(true); } -static void -check_o_1 (s7_scheme* sc, s7_pointer let, const char* func, s7_pointer expr, - s7_pointer var) { - s7_pointer slot= s7_t_slot (sc, var); - if (lookup_slot_with_let (sc, var, let) != slot) { - fprintf (stderr, "%s%s %s is out of date (%s in %s -> %s)%s\n", bold_text, - func, display (expr), display (var), display (let), - (is_not_slot_end (slot)) ? display (slot) : "undefined", - unbold_text); - if (sc->stop_at_error) abort (); - } +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 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 (inline_lookup_from (sc, symbol, let_outlet (sc->curlet))); +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_equivalent(int_vector_ints(x), int_vector_ints(y), len)); } -#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) -#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) \ - inline_lookup_from (Sc, Symbol, 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)); -} -s7_pointer -fx_unsafe_s (s7_scheme* sc, s7_pointer arg) { - return (lookup_checked (sc, T_Sym (arg))); +static bool float_vector_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) +{ + s7_int len; + if (!is_float_vector(y)) + return(vector_equal(sc, x, y, ci)); + base_vector_equal(sc, x, y); + for (s7_int i = 0; i < len; i++) + if (float_vector(x, i) != float_vector(y, i)) + return(false); + return(true); } -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_defined_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_V (s7_scheme* sc, s7_pointer arg) { - return (V_lookup (sc, T_Sym (arg), arg)); -} -static s7_pointer -fx_c_nc (s7_scheme* sc, s7_pointer arg) { - return (fn_call (sc, arg)); -} -static s7_pointer -fx_c_0c (s7_scheme* sc, s7_pointer arg) { - return (fn_proc (arg) (sc, sc->nil)); -} -static s7_pointer -fx_cons_cc (s7_scheme* sc, s7_pointer arg) { - return (cons (sc, cadr (arg), opt1_con (cdr (arg)))); -} -static s7_pointer -fx_curlet (s7_scheme* sc, s7_pointer arg) { - return (s7_curlet (sc)); +static bool complex_vector_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) +{ + s7_int len; + if (!is_complex_vector(y)) + return(vector_equal(sc, x, y, ci)); + base_vector_equal(sc, x, y); + for (s7_int i = 0; i < len; i++) + if (complex_vector(x, i) != complex_vector(y, i)) + return(false); + return(true); } -#define fx_c_any(Name, Lookup) \ - static s7_pointer Name (s7_scheme* sc, s7_pointer arg) { \ - return ( \ - fn_proc (arg) (sc, with_list_t1 (sc, Lookup (sc, cadr (arg), arg)))); \ - } +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 len; + 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); /* different from vector_equal, (equal? (make-vector '(0 1)) (make-vector '(1 0))): #f, but #t if equivalent? */ + if (!vector_rank_match(sc, x, y)) return(false); -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) fx_c_any (fx_c_V, V_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= Lookup (sc, cadr (arg), arg); \ - return ((is_pair (val)) ? car (val) : g_car (sc, set_plist_1 (sc, val))); \ + 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_equivalent(y, x)); + if ((is_byte_vector(x)) && (is_int_vector(y))) + return(biv_equivalent(x, y)); + for (s7_int 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)) + return(fv_equivalent(sc, x, y, len)); + if (is_int_vector(x)) + return(iv_equivalent(int_vector_ints(x), int_vector_ints(y), len)); + if (is_byte_vector(x)) + return(byte_vector_equal_1(sc, x, y)); + if (is_complex_vector(x)) + return(cv_equivalent(sc, x, y, len)); + { + shared_info_t *nci = ci; + if (!has_simple_elements(x)) + { + if (ci) + { + if (equal_ref(sc, x, y, ci)) return(true); + } + else nci = clear_shared_info(sc->circle_info); + } + for (s7_int i = 0; i < len; i++) + if (!is_equivalent_1(sc, vector_element(x, i), vector_element(y, i), nci)) + return(false); } -/* using car_p_p(val) here is exactly the same in speed according to callgrind, - * also opt3_sym(arg) for cadr(arg) */ - -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) fx_car_any ( - fx_car_T, T_lookup) fx_car_any (fx_car_U, U_lookup) + return(true); +} -#define fx_cdr_any(Name, Lookup) \ - static s7_pointer Name (s7_scheme* sc, s7_pointer arg) { \ - s7_pointer val= Lookup (sc, cadr (arg), arg); \ - return ((is_pair (val)) ? cdr (val) : g_cdr (sc, set_plist_1 (sc, val))); \ - } +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; - 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) fx_cdr_any (fx_cdr_T, T_lookup) - fx_cdr_any (fx_cdr_U, U_lookup) - -#define fx_cadr_any(Name, Lookup) \ - static s7_pointer Name (s7_scheme* sc, s7_pointer arg) { \ - s7_pointer val= Lookup (sc, cadr (arg), arg); \ - return (((is_pair (val)) && (is_pair (cdr (val)))) \ - ? cadr (val) \ - : g_cadr (sc, set_plist_1 (sc, val))); \ - } + if (x == y) return(true); + if (!is_iterator(y)) return(false); + x_seq = iterator_sequence(x); + y_seq = iterator_sequence(y); - 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= 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) - - 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); - default: - return (method_or_bust_pp (sc, val, sc->num_eq_symbol, val, cadr (args), - a_number_string, 1)); - } - return (sc->T); -} + 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: case T_COMPLEX_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_t_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)) : + ((is_byte_vector(x_seq)) ? (byte_vector_equal(sc, x_seq, y_seq, ci)) : + (complex_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); + { + s7_pointer xs, ys; + 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))? */ -static s7_pointer -fx_num_eq_s0f (s7_scheme* sc, s7_pointer arg) { - s7_pointer 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))); -} + 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); -#define fx_num_eq_si_any(Name, Lookup) \ - static s7_pointer Name (s7_scheme* sc, s7_pointer arg) { \ - s7_pointer args= cdr (arg); \ - s7_pointer val = Lookup (sc, car (args), arg); \ - s7_int 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))); \ - } + case T_LET: + if (!is_let(y_seq)) return(false); + if (x_seq == sc->rootlet) + { + if (y_seq != sc->rootlet) return(false); + return(iterator_position(x) == iterator_position(y)); + } + if (x_seq == sc->starlet) + { + if (y_seq != sc->starlet) return(false); + return(iterator_position(x) == iterator_position(y)); + } + 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); -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) - fx_num_eq_si_any (fx_num_eq_oi, o_lookup) - -#define fx_num_eq_s0_any(Name, Lookup) \ - static s7_pointer Name (s7_scheme* sc, s7_pointer arg) { \ - s7_pointer 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)); \ - } + /* let_iterator_slot will be NULL at end */ + if (is_slot_end(let_iterator_slot(x))) return(is_slot_end(let_iterator_slot(y))); + if (is_slot_end(let_iterator_slot(y))) return(false); /* not needed but seems clearer */ + { + s7_pointer xs, ys; + for (xs = let_slots(x_seq), ys = let_slots(y_seq); is_not_slot_end(xs) && is_not_slot_end(ys); xs = next_slot(xs), ys = next_slot(ys)) + if (xs == let_iterator_slot(x)) + return(ys == let_iterator_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)); - 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= lookup ( - sc, opt3_sym (arg)); /* opt3_sym: caddr(arg) -- this actually makes a - measurable difference in callgrind! */ - 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) { - return (make_integer (sc, (s7_int) (integer (cadr (arg)) * - next_random (sc->default_random_state)))); -} - -static s7_pointer -fx_random_i_wrapped (s7_scheme* sc, s7_pointer arg) { - return (wrap_integer (sc, (s7_int) (integer (cadr (arg)) * - next_random (sc->default_random_state)))); -} - -static s7_pointer -fx_add_i_random (s7_scheme* sc, s7_pointer arg) { - s7_int x= integer (cadr (arg)); - s7_int y= opt3_int (cdr (arg)); /* cadadr */ - return (make_integer ( - sc, - x + (s7_int) (y * next_random ( - sc->default_random_state)))); /* (+ -1 (random 1)) - -- placement of the - (s7_int) cast - matters! */ -} - -static s7_pointer -fx_add_sf (s7_scheme* sc, s7_pointer arg) { - return ( - g_add_xf (sc, lookup (sc, cadr (arg)), real (opt1_con (cdr (arg))), 1)); -} -s7_pointer -fx_add_fs (s7_scheme* sc, s7_pointer arg) { - return (g_add_xf (sc, lookup (sc, caddr (arg)), real (cadr (arg)), 2)); -} -static s7_pointer -fx_add_tf (s7_scheme* sc, s7_pointer arg) { - return (g_add_xf (sc, t_lookup (sc, cadr (arg), arg), - real (opt1_con (cdr (arg))), 1)); -} -static s7_pointer -fx_add_ft (s7_scheme* sc, s7_pointer arg) { - return (g_add_xf (sc, t_lookup (sc, caddr (arg), arg), real (cadr (arg)), 2)); -} - -#define fx_add_s1_any(Name, Lookup) \ - static s7_pointer Name (s7_scheme* sc, s7_pointer arg) { \ - s7_pointer x= Lookup (sc, cadr (arg), arg); \ - if ((is_t_integer (x))) return (make_integer (sc, integer (x) + 1)); \ - return (g_add_x1_1 (sc, x, 1)); /* arg=(+ x 1) */ \ - } + case T_CLOSURE: case T_CLOSURE_STAR: + return(x_seq == y_seq); /* or closure_equal/equivalent? */ -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_v1, v_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) - -#define fx_add_si_any(Name, Lookup) \ - static s7_pointer Name (s7_scheme* sc, s7_pointer arg) { \ - const s7_pointer x= Lookup (sc, cadr (arg), arg); \ - if ((is_t_integer (x))) { \ - if (HAVE_OVERFLOW_CHECKS) { \ - s7_int val= 0; \ - if (!add_overflow (integer (x), integer (opt1_con (cdr (arg))), &val)) \ - return (make_integer (sc, val)); \ - } \ - else \ - return ( \ - make_integer (sc, integer (x) + integer (opt1_con (cdr (arg))))); \ - } \ - return (add_p_pp (sc, x, opt1_con (cdr (arg)))); /* caddr(arg) */ \ - } + default: break; + } + return(false); +} - fx_add_si_any (fx_add_si, s_lookup) - fx_add_si_any (fx_add_ti, t_lookup) - - 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, opt1_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, opt1_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, opt1_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, opt1_sym (cdr (arg)), arg))); -} -static s7_pointer -fx_add_uv (s7_scheme* sc, s7_pointer arg) { - return (add_p_pp (sc, u_lookup (sc, cadr (arg), arg), - v_lookup (sc, opt1_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, opt1_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, opt1_sym (cdr (arg)), arg))); -} - -#define fx_subtract_s1_any(Name, Lookup) \ - static s7_pointer Name (s7_scheme* sc, s7_pointer arg) { \ - s7_pointer x= Lookup (sc, cadr (arg), arg); \ - if ((is_t_integer (x))) return (make_integer (sc, integer (x) - 1)); \ - return (minus_c1 (sc, x)); \ - } -/* overflow check here slows tleft by about 35 out of ca 750, parallel add case - * does not check (define most-negative-fixnum (*s7* 'most-negative-fixnum)) - * (display (let ((f (lambda () (let ((S (- most-negative-fixnum 1))) S)))) - * (f))) (newline) - * -> 9223372036854775807 or (checked) -9223372036854776000.0 - */ +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));} -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_v1, v_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) { \ - const s7_pointer x= Lookup (sc, cadr (arg), arg); \ - if ((is_t_integer (x))) { \ - if (HAVE_OVERFLOW_CHECKS) { \ - s7_int val= 0; \ - if (!subtract_overflow (integer (x), integer (opt1_con (cdr (arg))), \ - &val)) \ - return (make_integer (sc, val)); \ - } \ - else \ - return ( \ - make_integer (sc, integer (x) - integer (opt1_con (cdr (arg))))); \ - } \ - return (subtract_p_pp (sc, x, opt1_con (cdr (arg)))); /* caddr(arg) */ \ - } - fx_subtract_si_any (fx_subtract_si, s_lookup) - fx_subtract_si_any (fx_subtract_ti, - t_lookup) fx_subtract_si_any (fx_subtract_ui, - u_lookup) - -#define fx_subtract_sf_any(Name, Lookup) \ - static s7_pointer Name (s7_scheme* sc, s7_pointer arg) { \ - s7_pointer x= Lookup (sc, cadr (arg), arg); \ - if (is_t_real (x)) \ - return (make_real ( \ - sc, real (x) - real (opt1_con (cdr (arg))))); /* caddr(arg) */ \ - return (g_subtract_2f ( \ - sc, set_plist_2 (sc, x, opt1_con (cdr (arg))))); /* caddr(arg) */ \ - } +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)); + return(false); +} - fx_subtract_sf_any (fx_subtract_sf, s_lookup) - fx_subtract_sf_any (fx_subtract_tf, t_lookup) +/* 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))); + return(false); +} -#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, opt1_sym (cdr (arg)), arg))); \ - } +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)); + return(false); +} - 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) { - const s7_double n= real (cadr (arg)); - const s7_pointer x= lookup (sc, caddr (arg)); - switch (type (x)) { - case T_INTEGER: - return (make_real (sc, n - integer (x))); - case T_RATIO: - return (make_real (sc, n - (s7_double) 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))); - default: - return (method_or_bust_pp (sc, x, sc->subtract_symbol, cadr (arg), x, - a_number_string, 2)); - } - return (x); +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))); + return(false); } -#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) == \ - opt1_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) - fx_is_eq_sc_any (fx_is_eq_uc, u_lookup) - -#define fx_is_eq_car_sq_any(Name, Lookup) \ - static s7_pointer Name (s7_scheme* sc, s7_pointer arg) { \ - s7_pointer a = cdr (arg); \ - s7_pointer 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)))); \ - } +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), (s7_double)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)))); + } + return(false); +} - 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 a = cdr (arg); - s7_pointer 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= 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= Lookup (sc, opt3_sym (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))))); \ - } +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), (s7_double)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)))); + } + return(false); +} -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= Lookup (sc, opt3_sym (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))))); \ - } +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), (s7_double)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)))); + } + return(false); +} - 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= Lookup (sc, opt3_sym (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))))); \ - } +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), (s7_double)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)))); + } + return(false); +} - 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= Lookup (sc, opt3_sym (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))))); \ - } +static bool random_state_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) +{ + return((x == y) || + ((is_random_state(y)) && + (random_seed(x) == random_seed(y)) && + (random_carry(x) == random_carry(y)))); +} - 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= Lookup (sc, opt3_sym (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))))); \ - } +bool c_function_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) {return((is_c_function(y)) && (c_function_data(x) == c_function_data(y)));} +static bool c_macro_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) {return((is_c_macro(y)) && (c_macro_data(x) == c_macro_data(y)));} - 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) +static void init_equals(void) +{ + for (int32_t i = 0; i < NUM_TYPES; i++) {equals[i] = eq_equal; equivalents[i] = eq_equal;} + equals[T_BACRO] = closure_equal; + equals[T_BACRO_STAR] = closure_equal; + equals[T_BYTE_VECTOR] = byte_vector_equal; + equals[T_CLOSURE] = closure_equal; + equals[T_CLOSURE_STAR] = closure_equal; + equals[T_COMPLEX] = complex_equal; + equals[T_C_MACRO] = c_macro_equal; + equals[T_C_FUNCTION] = c_function_equal; + equals[T_C_RST_NO_REQ_FUNCTION] = c_function_equal; + equals[T_C_OBJECT] = c_objects_are_equal; + equals[T_C_POINTER] = c_pointer_equal; + equals[T_FLOAT_VECTOR] = float_vector_equal; + equals[T_COMPLEX_VECTOR] = complex_vector_equal; + equals[T_HASH_TABLE] = hash_table_equal; + equals[T_INPUT_PORT] = port_equal; + equals[T_INTEGER] = integer_equal; + equals[T_INT_VECTOR] = int_vector_equal; + equals[T_ITERATOR] = iterator_equal; + equals[T_LET] = let_equal; + equals[T_MACRO] = closure_equal; + equals[T_MACRO_STAR] = closure_equal; + equals[T_OUTPUT_PORT] = port_equal; + equals[T_PAIR] = pair_equal; + equals[T_RANDOM_STATE] = random_state_equal; + equals[T_RATIO] = fraction_equal; + equals[T_REAL] = real_equal; + equals[T_STRING] = string_equal; + equals[T_SYMBOL] = eq_equal; + equals[T_SYNTAX] = syntax_equal; + equals[T_UNDEFINED] = undefined_equal; + equals[T_UNSPECIFIED] = unspecified_equal; + equals[T_VECTOR] = vector_equal; + + equivalents[T_BACRO] = closure_equivalent; + equivalents[T_BACRO_STAR] = closure_equivalent; + equivalents[T_BYTE_VECTOR] = vector_equivalent; + equivalents[T_CLOSURE] = closure_equivalent; + equivalents[T_CLOSURE_STAR] = closure_equivalent; + equivalents[T_COMPLEX] = complex_equivalent; + equivalents[T_C_MACRO] = c_macro_equal; + equivalents[T_C_FUNCTION] = c_function_equal; + equivalents[T_C_RST_NO_REQ_FUNCTION] = c_function_equal; + equivalents[T_C_OBJECT] = c_objects_are_equivalent; + equivalents[T_C_POINTER] = c_pointer_equivalent; + equivalents[T_FLOAT_VECTOR] = vector_equivalent; + equivalents[T_COMPLEX_VECTOR] = vector_equivalent; + equivalents[T_HASH_TABLE] = hash_table_equivalent; + equivalents[T_INPUT_PORT] = port_equivalent; + equivalents[T_INTEGER] = integer_equivalent; + equivalents[T_INT_VECTOR] = vector_equivalent; + equivalents[T_ITERATOR] = iterator_equivalent; + equivalents[T_LET] = let_equivalent; + equivalents[T_MACRO] = closure_equivalent; + equivalents[T_MACRO_STAR] = closure_equivalent; + equivalents[T_OUTPUT_PORT] = port_equivalent; + equivalents[T_PAIR] = pair_equivalent; + equivalents[T_RANDOM_STATE] = random_state_equal; + equivalents[T_RATIO] = fraction_equivalent; + equivalents[T_REAL] = real_equivalent; + equivalents[T_STRING] = string_equal; + equivalents[T_SYMBOL] = symbol_equivalent; + equivalents[T_SYNTAX] = syntax_equal; + equivalents[T_UNDEFINED] = undefined_equal; + equivalents[T_UNSPECIFIED] = unspecified_equal; + equivalents[T_VECTOR] = vector_equivalent; +} + +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));} -#define fx_is_null_cadr_s_any(Name, Lookup) \ - static s7_pointer Name (s7_scheme* sc, s7_pointer arg) { \ - s7_pointer p= Lookup (sc, opt3_sym (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))))); \ - } +/* g_is_equal and g_is_equivalent are now in s7_scheme_predicate.c */ +#define H_is_equal "(equal? obj1 obj2) returns #t if obj1 is equal to obj2" +#define Q_is_equal sc->pcl_bt +#define H_is_equivalent "(equivalent? obj1 obj2) returns #t if obj1 is close enough to obj2." +#define Q_is_equivalent sc->pcl_bt - 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) +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);} -#define fx_is_null_cddr_s_any(Name, Lookup) \ - static s7_pointer Name (s7_scheme* sc, s7_pointer arg) { \ - s7_pointer p= Lookup (sc, opt3_sym (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= Lookup (sc, opt3_sym (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))))); \ - } +/* ---------------------------------------- length, copy, fill ---------------------------------------- */ +static s7_pointer s7_length(s7_scheme *sc, s7_pointer lst); /* why isn't this in s7.h? */ - 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 (*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 - fx_is_symbol_car_t (s7_scheme* sc, s7_pointer arg) { - s7_pointer val= t_lookup (sc, opt3_sym (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 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 -fx_floor_sqrt_s (s7_scheme* sc, s7_pointer arg) { - s7_pointer p= lookup (sc, opt3_sym (arg)); - if (!negative_b_7p (sc, p)) - return (make_integer ( - sc, (s7_int) floor (sqrt ( - s7_number_to_real_with_location (sc, p, sc->sqrt_symbol))))); - return (floor_p_p (sc, sqrt_p_p (sc, p))); -} +static s7_pointer nil_length(s7_scheme *sc, s7_pointer lst) {return(int_zero);} +s7_pointer v_length(s7_scheme *sc, s7_pointer vec) {return(make_integer(sc, vector_length(vec)));} +static s7_pointer str_length(s7_scheme *sc, s7_pointer str) {return(make_integer(sc, string_length(str)));} +static s7_pointer bv_length(s7_scheme *sc, s7_pointer bv) {return(make_integer(sc, byte_vector_length(bv)));} +static s7_pointer h_length(s7_scheme *sc, s7_pointer table) {return(make_integer(sc, hash_table_size(table)));} +static s7_pointer iter_length(s7_scheme *sc, s7_pointer iter) {return(s7_length(sc, iterator_sequence(iter)));} +static s7_pointer rs_length(s7_scheme *sc, s7_pointer rs) {return(int_two);} -static s7_pointer -fx_is_positive_u (s7_scheme* sc, s7_pointer arg) { - s7_pointer num= u_lookup (sc, cadr (arg), arg); - if (is_t_integer (num)) return (make_boolean (sc, integer (num) > 0)); - return (make_boolean (sc, positive_b_7p (sc, num))); +static s7_pointer c_obj_length(s7_scheme *sc, s7_pointer cobj) +{ + if (!is_global(sc->length_symbol)) + if_c_object_method_exists_return_value(sc, cobj, sc->length_symbol, set_plist_1(sc, cobj)); + return(c_object_length(sc, cobj)); } -static s7_pointer -fx_is_zero_u (s7_scheme* sc, s7_pointer arg) { - return (make_boolean (sc, zero_b_7p (sc, u_lookup (sc, cadr (arg), arg)))); +static s7_pointer let_length_with_method(s7_scheme *sc, s7_pointer let) +{ + if (!is_global(sc->length_symbol)) + if_let_method_exists_return_value(sc, let, sc->length_symbol, set_plist_1(sc, let)); + return(make_integer(sc, let_length(sc, let))); } -#define fx_real_part_s_any(Name, Lookup) \ - static s7_pointer Name (s7_scheme* sc, s7_pointer arg) { \ - s7_pointer x= Lookup (sc, cadr (arg), arg); \ - return ((is_t_complex (x)) ? make_real (sc, real_part (x)) \ - : real_part_p_p (sc, x)); \ - } - -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 x= Lookup (sc, cadr (arg), arg); \ - return ((is_t_complex (x)) ? make_real (sc, imag_part (x)) \ - : imag_part_p_p (sc, x)); \ - } - - 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= Lookup (sc, cadr (arg), arg); \ - if (is_iterator (iter)) return ((iterator_next (iter)) (sc, iter)); \ - return (method_or_bust_p (sc, iter, sc->iterate_symbol, \ - sc->type_names[T_ITERATOR])); \ - } - - fx_iterate_s_any (fx_iterate_s, s_lookup) - fx_iterate_s_any (fx_iterate_o, o_lookup) - fx_iterate_s_any (fx_iterate_T, T_lookup) - - static s7_pointer - fx_read_char_0 (s7_scheme* sc, s7_pointer arg) { - s7_pointer port= input_port_if_not_loading (sc); - if (!port) return (eof_object); - if (!is_input_port (port)) - return (method_or_bust_p (sc, port, sc->read_char_symbol, - an_input_port_string)); - return (chars[port_read_character (port) (sc, port)]); -} - -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 */ - const s7_int ilen= - integer (opt3_con (arg)); /* is_t_integer checked in fx_choose */ - const s7_pointer 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_size (val)) == (s7_uint) 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_ITERATOR: { - s7_pointer len= s7_length (sc, iterator_sequence (val)); - return (make_boolean (sc, (is_t_integer (len)) && (integer (len) == ilen))); - } - case T_BYTE_VECTOR: - case T_INT_VECTOR: - case T_FLOAT_VECTOR: - case T_VECTOR: - case T_COMPLEX_VECTOR: - return (make_boolean (sc, vector_length (val) == 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: - sole_arg_wrong_type_error_nr (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) { - const s7_int ilen= integer (opt3_con (arg)); /* caddr(arg) */ - const s7_pointer 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_size (val)) < - (s7_uint) 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_ITERATOR: { - s7_pointer len= s7_length (sc, iterator_sequence (val)); - return (make_boolean (sc, (is_t_integer (len)) && (integer (len) < ilen))); - } - case T_BYTE_VECTOR: - case T_INT_VECTOR: - case T_FLOAT_VECTOR: - case T_VECTOR: - case T_COMPLEX_VECTOR: - return (make_boolean (sc, vector_length (val) < 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: - sole_arg_wrong_type_error_nr ( - sc, sc->length_symbol, val, - a_sequence_string); /* no check method here because we checked above */ - } - return (sc->F); +static s7_pointer fnc_length(s7_scheme *sc, s7_pointer func) +{ + return((has_active_methods(sc, func)) ? make_integer(sc, closure_length(sc, func)) : 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)))); -} -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); -} -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_symbol_and_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); +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 len; + long 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); } -#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, opt1_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) fx_c_sc_any (fx_c_oc, o_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)), - opt1_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 (opt1_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 (opt1_con (cdr (arg))))); -} -static s7_pointer -fx_c_ti_remainder (s7_scheme* sc, s7_pointer arg) { - return (remainder_p_pi (sc, t_lookup (sc, cadr (arg), arg), - integer (opt1_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), opt1_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 (opt1_con (cdr (arg))))); -} -/* tc happens a lot, but others almost never */ - -static s7_pointer -fx_memq_sc (s7_scheme* sc, s7_pointer arg) { - return (memq_p_pp (sc, lookup (sc, cadr (arg)), opt1_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)), opt1_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), opt1_con (cdr (arg)))); -} -static s7_pointer -fx_leq_sc (s7_scheme* sc, s7_pointer arg) { - return (leq_p_pp (sc, lookup (sc, cadr (arg)), opt1_con (cdr (arg)))); -} -static s7_pointer -fx_lt_sc (s7_scheme* sc, s7_pointer arg) { - return (lt_p_pp (sc, lookup (sc, cadr (arg)), opt1_con (cdr (arg)))); -} -static s7_pointer -fx_gt_sc (s7_scheme* sc, s7_pointer arg) { - return (gt_p_pp (sc, lookup (sc, cadr (arg)), opt1_con (cdr (arg)))); -} -static s7_pointer -fx_geq_sc (s7_scheme* sc, s7_pointer arg) { - return (geq_p_pp (sc, lookup (sc, cadr (arg)), opt1_con (cdr (arg)))); -} -static s7_pointer -fx_list_sc (s7_scheme* sc, s7_pointer arg) { - return (list_2 (sc, lookup (sc, cadr (arg)), opt1_con (cdr (arg)))); -} - -#define fx_char_eq_sc_any(Name, Lookup) \ - static s7_pointer Name (s7_scheme* sc, s7_pointer arg) { \ - s7_pointer c= Lookup (sc, cadr (arg), arg); \ - if (c == opt1_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), \ - sc->type_names[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) +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 */ +} -#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, caddr (arg), arg)); \ - return (fn_proc (arg) (sc, sc->t2_1)); \ - } +static void init_length_functions(void) +{ + for (int32_t 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_COMPLEX_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] = let_length_with_method; + 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; + length_functions[T_RANDOM_STATE] = rs_length; +} + +static s7_pointer s7_length(s7_scheme *sc, s7_pointer obj) {return((*length_functions[type_unchecked(obj)])(sc, obj));} + +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[type_unchecked(car(args))])(sc, car(args))); +} - 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, caddr (arg), arg))); +/* -------------------------------- copy -------------------------------- */ +static s7_pointer string_setter(s7_scheme *sc, s7_pointer str, s7_int loc, s7_pointer chr) +{ + if (is_character(chr)) + { + string_value(str)[loc] = s7_character(chr); + return(chr); + } + set_car(sc->elist_3, wrap_string(sc, "~S: ~S is not a character", 25)); /* cadr (caller) is set in s7_copy_1 */ + set_caddr(sc->elist_3, chr); + error_nr(sc, sc->wrong_type_arg_symbol, sc->elist_3); + return(NULL); } -static s7_pointer -fx_cons_cs (s7_scheme* sc, s7_pointer arg) { - return (cons (sc, opt1_con (cdr (arg)), lookup (sc, caddr (arg)))); -} -static s7_pointer -fx_cons_ct (s7_scheme* sc, s7_pointer arg) { - return (cons (sc, opt1_con (cdr (arg)), t_lookup (sc, caddr (arg), arg))); +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 */ } -#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, opt1_sym (cdr (arg)), arg)); \ - return (fn_proc (arg) (sc, sc->t2_1)); \ - } +static s7_pointer c_object_setter(s7_scheme *sc, s7_pointer cobj, s7_int loc, s7_pointer val) +{ + return((*(c_object_set(sc, cobj)))(sc, with_list_t3(sc, cobj, wrap_mutable_integer(sc, loc), val))); /* was make_integer 14-Nov-23 */ +} -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, opt1_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, opt1_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, opt1_sym (cdr (arg))))); -} -static s7_pointer -fx_vref_ss (s7_scheme* sc, s7_pointer arg) { - return (s7i_vector_ref_p_pp (sc, lookup (sc, cadr (arg)), - lookup (sc, opt1_sym (cdr (arg))))); -} -static s7_pointer -fx_vref_st (s7_scheme* sc, s7_pointer arg) { - return (s7i_vector_ref_p_pp (sc, lookup (sc, cadr (arg)), - t_lookup (sc, opt1_sym (cdr (arg)), arg))); -} -static s7_pointer -fx_vref_ts (s7_scheme* sc, s7_pointer arg) { - return (s7i_vector_ref_p_pp (sc, t_lookup (sc, cadr (arg), arg), - s_lookup (sc, opt1_sym (cdr (arg)), arg))); -} -static s7_pointer -fx_vref_tu (s7_scheme* sc, s7_pointer arg) { - return (s7i_vector_ref_p_pp (sc, t_lookup (sc, cadr (arg), arg), - u_lookup (sc, opt1_sym (cdr (arg)), arg))); -} -static s7_pointer -fx_vref_ot (s7_scheme* sc, s7_pointer arg) { - return (s7i_vector_ref_p_pp (sc, o_lookup (sc, cadr (arg), arg), - t_lookup (sc, opt1_sym (cdr (arg)), arg))); -} -static s7_pointer -fx_vref_gt (s7_scheme* sc, s7_pointer arg) { - return (s7i_vector_ref_p_pp (sc, lookup_global (sc, cadr (arg)), - t_lookup (sc, opt1_sym (cdr (arg)), arg))); -} -static s7_pointer -fx_sref_ss (s7_scheme* sc, s7_pointer arg) { - return (string_ref_p_pp (sc, lookup (sc, cadr (arg)), - lookup (sc, opt1_sym (cdr (arg))))); -} -static s7_pointer -fx_sref_su (s7_scheme* sc, s7_pointer arg) { - return (string_ref_p_pp (sc, lookup (sc, cadr (arg)), - u_lookup (sc, opt1_sym (cdr (arg)), arg))); -} -static s7_pointer -fx_cons_ss (s7_scheme* sc, s7_pointer arg) { - return ( - cons (sc, lookup (sc, cadr (arg)), lookup (sc, opt1_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, opt1_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, opt1_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, opt1_sym (cdr (arg)), 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, opt1_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), s_lookup(sc, opt1_sym(cdr((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, opt1_sym (cdr (arg)), arg))); \ - } +static s7_pointer c_object_getter(s7_scheme *sc, s7_pointer cobj, s7_int loc) +{ + return((*(c_object_ref(sc, cobj)))(sc, set_plist_2(sc, cobj, wrap_mutable_integer(sc, loc)))); /* was make_integer 14-Nov-23 */ +} -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_tu_direct, t_lookup, u_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, opt1_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, opt1_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, - * opt1_sym(cdr(arg)))));} */ -static s7_pointer -fx_multiply_fs (s7_scheme* sc, s7_pointer arg) { - return (g_mul_xf (sc, lookup (sc, caddr (arg)), real (cadr (arg)), 2)); -} -static s7_pointer -fx_multiply_sf (s7_scheme* sc, s7_pointer arg) { - return ( - g_mul_xf (sc, lookup (sc, cadr (arg)), real (opt1_con (cdr (arg))), 1)); -} -static s7_pointer -fx_multiply_tf (s7_scheme* sc, s7_pointer arg) { - return (g_mul_xf (sc, t_lookup (sc, cadr (arg), arg), - real (opt1_con (cdr (arg))), 1)); -} -static s7_pointer -fx_multiply_si (s7_scheme* sc, s7_pointer arg) { - return (g_mul_xi (sc, lookup (sc, cadr (arg)), integer (opt1_con (cdr (arg))), - 1)); -} -static s7_pointer -fx_multiply_ti (s7_scheme* sc, s7_pointer arg) { - return (g_mul_xi (sc, t_lookup (sc, cadr (arg), arg), - integer (opt1_con (cdr (arg))), 1)); -} -static s7_pointer -fx_multiply_ui (s7_scheme* sc, s7_pointer arg) { - return (g_mul_xi (sc, u_lookup (sc, cadr (arg), arg), - integer (opt1_con (cdr (arg))), 1)); -} -static s7_pointer -fx_multiply_is (s7_scheme* sc, s7_pointer arg) { - return (g_mul_xi (sc, lookup (sc, caddr (arg)), integer (cadr (arg)), 2)); -} -static s7_pointer -fx_multiply_it (s7_scheme* sc, s7_pointer arg) { - return ( - g_mul_xi (sc, t_lookup (sc, caddr (arg), arg), integer (cadr (arg)), 2)); -} -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, opt1_sym (cdr (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))); - - 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 (make_ratio_with_div_check (sc, sc->multiply_symbol, 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 (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_pp (sc, x, sc->multiply_symbol, x, x, - a_number_string, 1)); - } - return (x); +static s7_pointer let_setter(s7_scheme *sc, s7_pointer let, 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 let, its value is changed, otherwise a new slot is added to let + */ + 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, let, sym); + if (is_slot(slot)) + checked_slot_set_value(sc, slot, cdr(val)); + else add_slot_checked_with_id(sc, let, 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); + error_nr(sc, sc->wrong_type_arg_symbol, sc->elist_3); + return(sc->wrong_type_arg_symbol); +} + +static s7_pointer hash_table_setter(s7_scheme *sc, s7_pointer table, s7_int loc, s7_pointer val) +{ + /* loc is irrelevant here, table is the hash-table, val has to be of the form (cons key value) + * if key is already in table, its value is changed, otherwise a new slot is added to table, cadr(elist_3) is caller, set in s7_copy_1 + */ + if (!is_pair(val)) + { + set_car(sc->elist_3, wrap_string(sc, "~S: ~S is not (cons key value)", 30)); + set_caddr(sc->elist_3, val); + error_nr(sc, sc->wrong_type_arg_symbol, sc->elist_3); + } + return(s7_hash_table_set(sc, table, car(val), cdr(val))); } -static s7_pointer -fx_sqr_wrapped (s7_scheme* sc, s7_pointer x) { - if (is_t_real (x)) return (wrap_real (sc, real (x) * real (x))); - if (is_t_integer (x)) - return ( - multiply_if_overflow_to_real_wrapped (sc, integer (x), integer (x))); - if (is_t_complex (x)) - return (wrap_complex ( - sc, real_part (x) * real_part (x) - imag_part (x) * imag_part (x), - 2.0 * real_part (x) * imag_part (x))); - return (fx_sqr_1 (sc, x)); -} - -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, arg=(+ (* x x) (* y y)) */ -{ - sc->temp5= fx_sqr_wrapped ( - sc, lookup (sc, car (opt1_pair (cdr (arg))))); /* cadadr(arg) */ - return (add_p_pp ( - sc, sc->temp5, - fx_sqr_wrapped (sc, - lookup (sc, car (opt3_pair (arg)))))); /* cadaddr(arg) */ -} - -static s7_pointer -fx_hypot (s7_scheme* sc, s7_pointer arg) /* (sqrt (+ (* x x) (* y y))) */ -{ - sc->temp5= fx_sqr_wrapped ( - sc, lookup (sc, opt1_sym (cdr (arg)))); /* cadadadr(arg) ! -> x */ - return (sqrt_p_p ( - sc, - add_p_pp_wrapped ( - sc, sc->temp5, - fx_sqr_wrapped ( - sc, - lookup (sc, opt3_sym (cdr (arg))))))); /* cadaddadr(arg) -> y */ -} - -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_wrapped ( - 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_wrapped ( - 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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_sym (cdr (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, opt1_sym (cdr (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, opt1_sym (cdr (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, opt1_sym (cdr (arg)), arg))); -} -static s7_pointer -fx_geq_vo (s7_scheme* sc, s7_pointer arg) { - return (geq_p_pp (sc, v_lookup (sc, cadr (arg), arg), - o_lookup (sc, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_sym (cdr (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, opt1_sym (cdr (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 (opt1_sym (cdr (arg))))); -} - -static s7_pointer -fx_gt_tT (s7_scheme* sc, s7_pointer arg) { - s7_pointer num1= t_lookup (sc, cadr (arg), arg); - s7_pointer num2= T_lookup (sc, opt1_sym (cdr (arg)), arg); - return (((is_t_integer (num1)) && (is_t_integer (num2))) - ? make_boolean (sc, integer (num1) > integer (num2)) - : gt_p_pp (sc, num1, num2)); -} - -#define fx_gt_si_any(Name, Lookup) \ - static s7_pointer Name (s7_scheme* sc, s7_pointer arg) { \ - s7_pointer x= Lookup (sc, cadr (arg), arg); \ - if (is_t_integer (x)) \ - return ( \ - make_boolean (sc, integer (x) > integer (opt1_con (cdr (arg))))); \ - if (is_t_real (x)) \ - return (make_boolean (sc, real (x) > integer (opt1_con (cdr (arg))))); \ - return (g_greater_xi ( \ - sc, set_plist_2 (sc, x, opt1_con (cdr (arg))))); /* caddr(arg) */ \ - } +static s7_pointer copy_hash_table(s7_scheme *sc, s7_pointer source) +{ + const s7_pointer new_table = s7_make_hash_table(sc, hash_table_size(source)); + gc_protect_via_stack(sc, new_table); + hash_table_checker(new_table) = hash_table_checker(source); + if (hash_chosen(source)) hash_set_chosen(new_table); + hash_table_mapper(new_table) = hash_table_mapper(source); + hash_table_set_procedures(new_table, copy_hash_table_procedures(sc, source)); + hash_table_copy(sc, source, new_table, 0, hash_table_entries(source)); + if (is_typed_hash_table(source)) + { + set_is_typed_hash_table(new_table); + if (has_hash_key_type(source)) set_has_hash_key_type(new_table); + if (has_hash_value_type(source)) set_has_hash_value_type(new_table); + if (has_simple_keys(source)) set_has_simple_keys(new_table); + if (has_simple_values(source)) set_has_simple_values(new_table); + } + if (is_weak_hash_table(source)) /* 16-May-23 */ + { + set_weak_hash_table(new_table); + weak_hash_iters(new_table) = 0; + } + unstack_gc_protect(sc); + return(new_table); +} -fx_gt_si_any (fx_gt_si, s_lookup) fx_gt_si_any (fx_gt_ti, t_lookup) - fx_gt_si_any (fx_gt_ui, u_lookup) +static s7_pointer copy_vector(s7_scheme *sc, s7_pointer source) +{ + const s7_int len = vector_length(source); + s7_pointer vec; + if (!is_typed_vector(source)) + return(s7_vector_copy(sc, source)); + if (len == 0) + return(make_simple_vector(sc, 0)); + vec = make_vector_1(sc, len, NOT_FILLED, T_VECTOR); + set_typed_vector(vec); + typed_vector_set_typer(vec, typed_vector_typer(source)); + if (has_simple_elements(source)) set_has_simple_elements(vec); + for (s7_int i = 0; i < len; i++) + vector_element(vec, i) = vector_element(source, i); + if (vector_rank(source) > 1) + return(make_multivector(sc, vec, g_vector_dimensions(sc, set_plist_1(sc, source)))); /* see g_subvector to avoid g_vector_dimensions */ + add_vector(sc, vec); + return(vec); +} + +static s7_pointer copy_source_no_dest(s7_scheme *sc, s7_pointer source, s7_pointer args) /* (copy str) */ +{ + s7_pointer dest; + switch (type(source)) + { + case T_VECTOR: return(copy_vector(sc, source)); + case T_PAIR: return(copy_any_list(sc, source)); /* top level only, as in the other cases, checks for circles */ + case T_HASH_TABLE: return(copy_hash_table(sc, source)); /* this has to copy nearly everything */ + case T_C_OBJECT: return(copy_c_object(sc, args)); + case T_RANDOM_STATE: return(random_state_copy(sc, args)); + case T_ITERATOR: return(iterator_copy(sc, source)); - static s7_pointer fx_leq_ss (s7_scheme* sc, s7_pointer arg) { - return (leq_p_pp (sc, lookup (sc, cadr (arg)), - lookup (sc, opt1_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, opt1_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, opt1_sym (cdr (arg)), arg))); -} + case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_BYTE_VECTOR: case T_COMPLEX_VECTOR: + return(s7_vector_copy(sc, source)); /* "shallow" copy */ -#define fx_leq_si_any(Name, Lookup) \ - static s7_pointer Name (s7_scheme* sc, s7_pointer arg) { \ - s7_pointer x= Lookup (sc, cadr (arg), arg); \ - if (is_t_integer (x)) \ - return ( \ - make_boolean (sc, integer (x) <= integer (opt1_con (cdr (arg))))); \ - return (g_leq_xi ( \ - sc, set_plist_2 (sc, x, opt1_con (cdr (arg))))); /* caddr(arg) */ \ - } + case T_STRING: + if (string_length(source) == 0) return(nil_string); + return(make_string_with_length(sc, string_value(source), string_length(source))); -fx_leq_si_any (fx_leq_si, s_lookup) fx_leq_si_any (fx_leq_ti, t_lookup) - fx_leq_si_any (fx_leq_ui, u_lookup) fx_leq_si_any (fx_leq_vi, v_lookup) - - static s7_pointer fx_lt_ss (s7_scheme* sc, s7_pointer arg) { - return ( - lt_p_pp (sc, lookup (sc, cadr (arg)), lookup (sc, opt1_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, opt1_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, opt1_sym (cdr (arg))))); -} - -static s7_pointer -fx_lt_gsg (s7_scheme* sc, s7_pointer arg) /* gsg is much faster than sss */ -{ - const s7_pointer x1= lookup_global (sc, cadr (arg)); - const s7_pointer x2= lookup (sc, opt1_sym (cdr (arg))); /* caddr(arg) */ - const s7_pointer x3= - lookup_global (sc, opt2_sym (cdr (arg))); /* cadddr(arg) */ - if ((is_t_integer (x1)) && (is_t_integer (x2)) && (is_t_integer (x3))) - return (make_boolean ( - sc, ((integer (x1) < integer (x2)) && (integer (x2) < integer (x3))))); - if (!is_real (x3)) - wrong_type_error_nr ( - sc, sc->lt_symbol, 3, x3, - sc->type_names[T_REAL]); /* else (< 2 1 1+i) returns #f */ - return ( - make_boolean (sc, (lt_b_7pp (sc, x1, x2)) && (lt_b_7pp (sc, x2, x3)))); -} - -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, opt1_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, opt1_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, opt1_sym (cdr (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, opt1_sym (cdr (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, opt1_sym (cdr (arg)), arg))); -} - -static s7_pointer -fx_lt_tf (s7_scheme* sc, s7_pointer arg) { - s7_pointer x= t_lookup (sc, cadr (arg), arg); - if (is_t_real (x)) - return (make_boolean (sc, real (x) < real (opt1_con (cdr (arg))))); - return (g_less_xf ( - sc, set_plist_2 (sc, x, opt1_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= Lookup (sc, cadr (arg), arg); \ - if (is_t_integer (x)) \ - return ( \ - make_boolean (sc, integer (x) < integer (opt1_con (cdr (arg))))); \ - return (g_less_xi ( \ - sc, set_plist_2 (sc, x, opt1_con (cdr (arg))))); /* caddr(arg) */ \ - } + case T_LET: + if_let_method_exists_return_value(sc, source, sc->copy_symbol, args); + return(let_copy(sc, source)); /* this copies only the local let and points to outer lets */ -fx_lt_si_any (fx_lt_si, s_lookup) fx_lt_si_any (fx_lt_ti, t_lookup) + case T_CLOSURE: case T_CLOSURE_STAR: + case T_MACRO: case T_MACRO_STAR: + case T_BACRO: case T_BACRO_STAR: + if_method_exists_return_value(sc, source, sc->copy_symbol, args); + return(copy_closure(sc, source)); - static s7_pointer fx_lt_t0 (s7_scheme* sc, s7_pointer arg) { - s7_pointer 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))); -} + case T_INTEGER: + new_cell(sc, dest, T_INTEGER); + set_integer(dest, integer(source)); + return(dest); + case T_RATIO: + new_cell(sc, dest, T_RATIO); + set_numerator(dest, numerator(source)); + set_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); -static s7_pointer -fx_lt_t1 (s7_scheme* sc, s7_pointer arg) { - s7_pointer 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))); + 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); + /* default here it to return the source without comment */ + } + return(source); } -static s7_pointer -fx_lt_t2 (s7_scheme* sc, s7_pointer arg) { - s7_pointer 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 copy_p_p(s7_scheme *sc, s7_pointer source) {return(copy_source_no_dest(sc, source, set_plist_1(sc, source)));} -static s7_pointer -fx_geq_tf (s7_scheme* sc, s7_pointer arg) { - s7_pointer x= t_lookup (sc, cadr (arg), arg); - if (is_t_real (x)) - return (make_boolean (sc, real (x) >= real (opt1_con (cdr (arg))))); - return (g_geq_xf ( - sc, set_plist_2 (sc, x, opt1_con (cdr (arg))))); /* caddr(arg) */ +static s7_pointer copy_c_object_to_same_type(s7_scheme *sc, s7_pointer dest, s7_pointer source, s7_int dest_start, s7_int dest_end, s7_int source_start) +{ + s7_pointer (*cref)(s7_scheme *sc, s7_pointer args) = c_object_ref(sc, source); + s7_pointer (*cset)(s7_scheme *sc, s7_pointer args) = c_object_set(sc, dest); + if ((is_safe_c_function(c_object_getf(sc, source))) && + (is_safe_c_function(c_object_setf(sc, dest)))) /* maybe not worth the extra code */ + { + s7_pointer mi = wrap_mutable_integer(sc, 0); + s7_pointer mj = wrap_mutable_integer(sc, 0); + set_car(sc->t3_1, dest); + set_car(sc->t3_2, mj); + for (s7_int i = source_start, j = dest_start; i < dest_end; i++, j++) + { + set_integer(mi, i); + set_car(sc->t3_3, cref(sc, with_list_t2(sc, source, mi))); + set_integer(mj, j); + cset(sc, sc->t3_1); + }} + else + { + s7_pointer mi = make_mutable_integer(sc, 0); + const s7_int gc_loc1 = gc_protect_1(sc, mi); + s7_pointer mj = make_mutable_integer(sc, 0); + const s7_int gc_loc2 = gc_protect_1(sc, mj); + for (s7_int i = source_start, j = dest_start; i < dest_end; i++, j++) + { + set_integer(mi, i); + set_car(sc->t3_3, cref(sc, with_list_t2(sc, source, mi))); + set_car(sc->t3_1, dest); + set_car(sc->t3_2, mj); + set_integer(mj, j); + cset(sc, sc->t3_1); + } + s7_gc_unprotect_at(sc, gc_loc1); + s7_gc_unprotect_at(sc, gc_loc2); + } + return(dest); } -#define fx_geq_si_any(Name, Lookup) \ - static s7_pointer Name (s7_scheme* sc, s7_pointer arg) { \ - s7_pointer x= Lookup (sc, cadr (arg), arg); \ - if (is_t_integer (x)) \ - return ( \ - make_boolean (sc, integer (x) >= integer (opt1_con (cdr (arg))))); \ - return (g_geq_xi ( \ - sc, set_plist_2 (sc, x, opt1_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 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 */ + const s7_int source_len = dest_end - dest_start; + switch (type(source)) + { + case T_PAIR: + { + s7_pointer pd = dest, ps = source; + s7_int i; + for (i = 0; i < source_start; i++) + ps = cdr(ps); + for (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); + } - static s7_pointer fx_geq_t0 (s7_scheme* sc, s7_pointer arg) { - s7_pointer 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))); -} + case T_VECTOR: + if (is_typed_vector(dest)) + { + s7_pointer *els = vector_elements(source); + for (s7_int 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); -#define fx_num_eq_ss_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name (s7_scheme* sc, s7_pointer arg) { \ - s7_pointer x= Lookup1 (sc, cadr (arg), arg); \ - s7_pointer y= Lookup2 (sc, opt1_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))); \ - } + 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_COMPLEX_VECTOR: + memcpy((void *)((complex_vector_complexes(dest)) + dest_start), (void *)((complex_vector_complexes(source)) + source_start), source_len * sizeof(s7_complex)); + 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); -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_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_tv, t_lookup, - v_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) - fx_num_eq_ss_any (fx_num_eq_uU, u_lookup, U_lookup) - fx_num_eq_ss_any (fx_num_eq_vU, v_lookup, U_lookup) - -#define fx_is_eq_ss_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name (s7_scheme* sc, s7_pointer arg) { \ - s7_pointer x= Lookup1 (sc, cadr (arg), arg); \ - s7_pointer y= Lookup2 (sc, opt1_sym (cdr (arg)), arg); \ - return (make_boolean ( \ - sc, (x == y) || ((is_unspecified (x)) && (is_unspecified (y))))); \ - } + 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); - 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= lookup (sc, opt3_sym (arg)); - s7_pointer 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= lookup (sc, opt3_sym (arg)); - s7_pointer y= opt3_con (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, opt1_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, opt1_sym (cdr (arg)), arg))); -} -static s7_pointer -fx_hash_table_ref_TV (s7_scheme* sc, s7_pointer arg) { - return (x_hash_table_ref_ss (sc, T_lookup (sc, cadr (arg), arg), - V_lookup (sc, opt1_sym (cdr (arg)), arg))); -} - -static s7_pointer -fx_hash_table_ref_car (s7_scheme* sc, s7_pointer arg) { - s7_pointer table= lookup (sc, cadr (arg)); - s7_pointer lst = lookup (sc, opt2_sym (cdr (arg))); - if (!is_pair (lst)) - sole_arg_wrong_type_error_nr (sc, sc->car_symbol, lst, - sc->type_names[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)), - sc->type_names[T_HASH_TABLE], 1)); - val= (*hash_table_checker (table)) (sc, table, key); - if (val != sc->unentry) { - if (!is_t_integer (hash_entry_value (val))) - sole_arg_wrong_type_error_nr (sc, sc->add_symbol, cadddr (arg), - sc->type_names[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); -} + case T_RANDOM_STATE: + random_seed(dest) = random_seed(source); + random_carry(dest) = random_carry(source); + return(dest); -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)); -} + case T_C_OBJECT: + return(copy_c_object_to_same_type(sc, dest, source, dest_start, dest_end, source_start)); -static s7_pointer -fx_cdr_let_ref_s (s7_scheme* sc, s7_pointer arg) { - s7_pointer sym; - s7_pointer let= s_lookup ( - sc, opt2_sym (arg), - arg); /* (var-ref local-var) -> local-var, opt_sym2(arg) == cadr(arg) */ - if (!is_pair (let)) - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_3 ( - sc, - wrap_string (sc, "~S should be (cons name let), but it is ~S", 42), - opt2_sym (arg), let)); - let= cdr (let); - if (!is_let (let)) - wrong_type_error_nr (sc, sc->let_ref_symbol, 1, let, a_let_string); - sym= opt2_sym ( - cdr (arg)); /* (let-ref (cdr v) 'ref) -> ref == - opt3_sym(cdar(closure_body(opt1_lambda(arg)))); */ - for (s7_pointer slot= let_slots (let); is_not_slot_end (slot); - slot = next_slot (slot)) - if (slot_symbol (slot) == sym) return (slot_value (slot)); - return (let_ref_p_pp (sc, let_outlet (let), sym)); -} - -static s7_pointer -fx_memq_sq_2 (s7_scheme* sc, s7_pointer arg) { - s7_pointer p = opt1_con (cdr (arg)); - s7_pointer 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) { - return ( - fn_proc (arg) (sc, with_list_t2 (sc, cadr (arg), opt2_con (cdr (arg))))); -} - -#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)); \ - } + case T_LET: + return(NULL); -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) + case T_HASH_TABLE: + { + s7_pointer new_table; + gc_protect_via_stack(sc, source); + new_table = hash_table_copy(sc, source, dest, source_start, source_start + source_len); + unstack_gc_protect(sc); + if ((hash_table_checker(source) != hash_table_checker(dest)) && + (hash_table_mapper(dest) == default_hash_map)) + { + if (hash_table_checker(dest) == hash_empty) + hash_table_checker(dest) = hash_table_checker(source); /* copy hash_table_procedures also? what about the mapper? see hash_table_copy */ + else + { + hash_table_checker(dest) = hash_equal; + hash_set_chosen(dest); + }} + return(new_table); + } - 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))))); + default: + return(dest); + } + return(NULL); } -static s7_pointer -fx_c_tuv_direct (s7_scheme* sc, s7_pointer arg) { - return (((s7_p_ppp_t) opt3_direct (cdr (arg))) ( - sc, t_lookup (sc, cadr (arg), arg), - u_lookup (sc, opt1_sym (cdr (arg)), arg), - v_lookup (sc, opt2_sym (cdr (arg)), arg))); +static no_return void copy_element_error_nr(s7_scheme *sc, s7_pointer caller, s7_int num, s7_pointer element, int32_t desired_type) +{ + set_elist_6(sc, wrap_string(sc, "~A ~:D element, ~S, is ~A but should be ~A", 42), + caller, wrap_integer(sc, num), element, type_name_string(sc, element), sc->type_names[desired_type]); + error_nr(sc, sc->wrong_type_arg_symbol, sc->elist_6); } -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 no_return void copy_element_error_with_type_nr(s7_scheme *sc, s7_pointer caller, s7_int num, s7_pointer element, s7_pointer desired_type) +{ + set_elist_6(sc, wrap_string(sc, "~A ~:D element, ~S, is ~A but should be ~A", 42), + caller, wrap_integer(sc, num), element, type_name_string(sc, element), desired_type); + error_nr(sc, sc->wrong_type_arg_symbol, sc->elist_6); } -#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)); \ - } +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) -fx_c_scs_any (fx_c_scs, s_lookup, s_lookup) - fx_c_scs_any (fx_c_tcs, t_lookup, s_lookup) + const s7_pointer source = car(args); + s7_pointer dest; + s7_int 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; -#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))); \ - } + if (is_null(cdr(args))) /* (copy obj) */ + return(copy_source_no_dest(sc, source, args)); + dest = T_Ext(cadr(args)); + if ((dest == sc->readable_keyword) && (!is_pair(source))) + error_nr(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->readable_keyword) && + (dest != sc->nil)) /* error_hook copies with cadr(args) :readable, so it's currently NULL */ + wrong_type_error_nr(sc, caller, 2, dest, wrap_string(sc, "a mutable object", 16)); /* so this segfaults if not checking for :readable */ + + have_indices = (is_pair(cddr(args))); + if ((source == dest) && (!have_indices)) return(dest); + /* gc_protect_via_stack(sc, args); */ /* why is this problematic? */ + sc->w = args; - 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) + switch (type(source)) + { + case T_PAIR: + if (dest == sc->readable_keyword) /* 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... */ + error_nr(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; - static s7_pointer fx_c_opncq (s7_scheme* sc, s7_pointer arg) { - return (fn_proc (arg) (sc, with_list_t1 (sc, fn_call (sc, cadr (arg))))); -} + case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_BYTE_VECTOR: case T_COMPLEX_VECTOR: + get = vector_getter(source); + end = vector_length(source); + break; -#define fx_c_opsq_any(Name, Lookup) \ - static s7_pointer Name (s7_scheme* sc, s7_pointer arg) { \ - s7_pointer arg1= cadr (arg); \ - set_car (sc->t1_1, \ - fn_proc (arg1) ( \ - sc, with_list_t1 (sc, Lookup (sc, cadr (arg1), arg1)))); \ - return (fn_proc (arg) (sc, sc->t1_1)); \ - } + case T_STRING: + get = string_getter; + end = string_length(source); + break; -fx_c_opsq_any (fx_c_opsq, s_lookup) fx_c_opsq_any (fx_c_optq, t_lookup) + case T_HASH_TABLE: + if (source == dest) return(dest); + end = hash_table_entries(source); + break; - 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)))); -} + case T_RANDOM_STATE: + get = random_state_getter; + end = 2; + break; -#define fx_c_car_s_any(Name, Lookup) \ - static s7_pointer Name (s7_scheme* sc, s7_pointer arg) { \ - s7_pointer val= Lookup (sc, opt3_sym (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)); \ - } + case T_C_OBJECT: + if (c_object_copy(sc, source)) + { + s7_pointer new_cobj = (*(c_object_copy(sc, source)))(sc, args); + if (new_cobj == dest) return(dest); /* this can happen (s7test block_copy) */ + } + if_c_object_method_exists_return_value(sc, source, sc->copy_symbol, args); + get = c_object_getter; + end = c_object_length_to_int(sc, source); + break; -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) + case T_LET: + if (source == dest) return(dest); + if_let_method_exists_return_value(sc, source, sc->copy_symbol, args); + if (source == sc->rootlet) + wrong_type_error_nr(sc, caller, 1, source, wrap_string(sc, "a sequence other than the rootlet", 33)); + if ((!have_indices) && (is_let(dest)) && (dest != sc->starlet)) + { + s7_pointer slot; + if (dest == sc->rootlet) /* (copy (inlet 'a 1) (rootlet)) */ + for (slot = let_slots(source); is_not_slot_end(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); is_not_slot_end(slot); slot = next_slot(slot)) + if ((slot_symbol(slot) != sc->let_ref_fallback_symbol) && + (slot_symbol(slot) != sc->let_set_fallback_symbol)) + add_slot_no_local(sc, dest, slot_symbol(slot), slot_value(slot)); + } + else + /* this copies reversing the order -- if shadowing, this unshadows, tmp has in-order copy code, but it's too much effort */ + /* it also ignores possible slot setters */ + for (slot = let_slots(source); is_not_slot_end(slot); slot = next_slot(slot)) + add_slot_no_local(sc, dest, slot_symbol(slot), slot_value(slot)); + return(dest); + } + end = let_length(sc, source); + break; -#define fx_c_cdr_s_any(Name, Lookup) \ - static s7_pointer Name (s7_scheme* sc, s7_pointer arg) { \ - s7_pointer val= Lookup (sc, opt3_sym (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)); \ - } + case T_NIL: + end = 0; + if (is_sequence(dest)) + break; - fx_c_cdr_s_any (fx_c_cdr_s, s_lookup) - fx_c_cdr_s_any (fx_c_cdr_t, t_lookup) + default: + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_4(sc, wrap_string(sc, "can't ~S ~S to ~S", 17), caller, source, dest)); + } -#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, opt3_sym (arg), arg)); \ - return ( \ - make_boolean (sc, (uint8_t) (opt3_byte (cdr (arg))) == \ - type (fn_proc (cadr (arg)) (sc, sc->t1_1)))); \ - } + start = 0; + if (have_indices) + { + s7_pointer 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); - 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= lookup (sc, opt3_sym (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 func; - const s7_pointer val= t_lookup (sc, opt3_sym (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!) */ - wrong_type_error_nr (sc, sc->car_symbol, 1, val, sc->type_names[T_PAIR]); - func= find_method_with_let (sc, val, sc->car_symbol); - if (func == sc->undefined) - wrong_type_error_nr (sc, sc->car_symbol, 1, val, sc->type_names[T_PAIR]); - return (make_boolean ( - sc, type (s7_apply_function (sc, func, set_plist_1 (sc, val))) == - (uint8_t) opt3_byte (cdr (arg)))); -} - -static s7_pointer -fx_eq_weak1_type_s (s7_scheme* sc, s7_pointer arg) { - s7_pointer func; - const s7_pointer val= lookup (sc, opt3_sym (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 */ - wrong_type_error_nr (sc, sc->c_pointer_weak1_symbol, 1, val, - sc->type_names[T_C_POINTER]); - func= find_method_with_let (sc, val, sc->c_pointer_weak1_symbol); - if (func == sc->undefined) - wrong_type_error_nr (sc, sc->c_pointer_weak1_symbol, 1, val, - sc->type_names[T_C_POINTER]); - return (make_boolean ( - sc, type (s7_apply_function (sc, func, set_plist_1 (sc, val))) == - (uint8_t) opt3_byte (cdr (arg)))); -} - -#define fx_not_opsq_any(Name, Lookup) \ - static s7_pointer Name (s7_scheme* sc, s7_pointer arg) { \ - s7_pointer arg1= cadr (arg); \ - set_car (sc->t1_1, Lookup (sc, cadr (arg1), arg)); \ - return ((fn_proc (arg1) (sc, sc->t1_1) == sc->F) ? sc->T : sc->F); \ - } + source_len = end - start; + if (source_len == 0) + { + if (!is_sequence(dest)) + wrong_type_error_nr(sc, caller, 2, dest, a_sequence_string); + return(dest); + } -fx_not_opsq_any (fx_not_opsq, s_lookup) fx_not_opsq_any (fx_not_optq, t_lookup) + switch (type(dest)) + { + case T_PAIR: + dest_len = source_len; + break; - static s7_pointer fx_not_car_t (s7_scheme* sc, s7_pointer arg) { - s7_pointer p = t_lookup (sc, opt3_sym (arg), arg); /* cadadr */ - s7_pointer result= (is_pair (p)) ? car (p) : g_car (sc, set_plist_1 (sc, p)); - return ((result == sc->F) ? sc->T : sc->F); -} + case T_INT_VECTOR: case T_BYTE_VECTOR: + if (is_float_vector(source)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "can't ~S ~S to ~A", 17), caller, source, sc->type_names[type(dest)])); + case T_FLOAT_VECTOR: + if (is_complex_vector(source)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "can't ~S ~S to ~A", 17), caller, source, sc->type_names[type(dest)])); + case T_COMPLEX_VECTOR: + set = vector_setter(dest); + dest_len = vector_length(dest); + break; -#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)); \ - return (fn_proc (arg) ( \ - sc, with_list_t1 (sc, fn_proc (cadr (arg)) (sc, sc->t2_1)))); \ - } + case T_VECTOR: + set = (is_typed_vector(dest)) ? typed_vector_setter : vector_setter(dest); + dest_len = vector_length(dest); + break; -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) + 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; -#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)))); \ - } + 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; - 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) + 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 new_cobj = (*(c_object_copy(sc, dest)))(sc, args); + if (new_cobj == dest) + return(dest); + } + set = c_object_setter; + dest_len = c_object_length_to_int(sc, dest); + break; -#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, opt1_sym (cdr (larg)), larg)); \ - return ((fn_proc (larg) (sc, sc->t2_1) == sc->F) ? sc->T : sc->F); \ - } + case T_LET: + if (dest == sc->rootlet) + wrong_type_error_nr(sc, caller, 2, dest, wrap_string(sc, "a sequence other rootlet", 24)); + if (dest == sc->starlet) + wrong_type_error_nr(sc, caller, 2, dest, wrap_string(sc, "a sequence other than *s7*", 26)); + 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; - 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 y= u_lookup (sc, opt3_sym (arg), arg); - s7_pointer 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 t= t_lookup (sc, opt1_sym (cdr (arg)), arg); - s7_pointer 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(?) */ - 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, 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 x= o_lookup (sc, opt3_sym (arg), arg); - s7_pointer y= s_lookup (sc, opt1_sym (cdr (arg)), arg); - if ((is_t_integer (x)) && (is_t_integer (y))) - return ( - make_boolean (sc, remainder_i_7ii (sc, integer (x), integer (y)) == 0)); - return (make_boolean (sc, zero_b_7p (sc, remainder_p_pp (sc, x, y)))); -} - -#define fx_c_opscq_any(Name, Lookup) \ - static s7_pointer Name (s7_scheme* sc, s7_pointer arg) { \ - const s7_pointer arg1= cadr (arg); \ - set_car (sc->t2_1, Lookup (sc, cadr (arg1), arg1)); \ - set_car (sc->t2_2, opt1_con (cdr (arg1))); \ - return ( \ - fn_proc (arg) (sc, with_list_t1 (sc, fn_proc (arg1) (sc, sc->t2_1)))); \ - } + case T_NIL: + return(sc->nil); -fx_c_opscq_any (fx_c_opscq, s_lookup) fx_c_opscq_any (fx_c_optcq, t_lookup) - - static s7_pointer fx_is_zero_remainder_ti (s7_scheme* sc, s7_pointer arg) { - const s7_pointer larg= cdadr (arg); - s7_pointer t = t_lookup (sc, car (larg), arg); - s7_int u = integer (cadr (larg)); - if (is_t_integer (t)) return (make_boolean (sc, (integer (t) % u) == 0)); - return (make_boolean (sc, zero_b_7p (sc, remainder_p_pi (sc, t, u)))); -} - -static s7_pointer -fx_not_opscq (s7_scheme* sc, s7_pointer arg) { - const s7_pointer arg1= cadr (arg); - set_car (sc->t2_1, lookup (sc, cadr (arg1))); - set_car (sc->t2_2, opt1_con (cdr (arg1))); - return ((fn_proc (arg1) (sc, sc->t2_1) == sc->F) ? sc->T : sc->F); -} - -static s7_pointer -fx_c_opcsq (s7_scheme* sc, s7_pointer arg) { - const s7_pointer arg1= cadr (arg); - set_car (sc->t2_2, lookup (sc, caddr (arg1))); - set_car (sc->t2_1, opt1_con (cdr (arg1))); /* cadr(arg1) or cadadr */ - return (fn_proc (arg) (sc, with_list_t1 (sc, fn_proc (arg1) (sc, sc->t2_1)))); -} - -static s7_pointer -fx_c_opcsq_c (s7_scheme* sc, s7_pointer arg) { - const s7_pointer arg1= cadr (arg); - set_car (sc->t2_2, lookup (sc, caddr (arg1))); - set_car (sc->t2_1, opt1_con (cdr (arg1))); /* cadr(arg1) or cadadr */ - set_car (sc->t2_1, fn_proc (arg1) (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) { - const s7_pointer arg1= cadr (arg); - set_car (sc->t2_2, lookup (sc, caddr (arg1))); - set_car (sc->t2_1, opt1_con (cdr (arg1))); /* cadr(arg1) or cadadr */ - set_car (sc->t2_1, fn_proc (arg1) (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) { - const s7_pointer arg1= cadr (arg); - set_car (sc->t2_1, lookup (sc, cadr (arg1))); - set_car (sc->t2_2, lookup (sc, opt1_sym (cdr (arg1)))); - set_car (sc->t2_1, fn_proc (arg1) (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 arg1_p= 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 (arg1_p)), - lookup (sc, opt1_sym (arg1_p))), - lookup (sc, caddr (arg)))); -} - -static s7_pointer -fx_add_mul_opssq_s (s7_scheme* sc, s7_pointer arg) { - const s7_pointer arg1_p= opt3_pair (arg); /* cdadr(arg) */ - const s7_pointer a = lookup (sc, car (arg1_p)); - const s7_pointer b = lookup (sc, opt1_sym (arg1_p)); - const s7_pointer 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_wrapped (sc, a, b), c)); -} - -static s7_pointer -fx_cons_cons_s (s7_scheme* sc, s7_pointer arg) { - s7_pointer arg1_p= opt3_pair (arg); /* cdadr(arg) */ - return (cons_unchecked ( - sc, cons (sc, lookup (sc, car (arg1_p)), lookup (sc, opt1_sym (arg1_p))), - lookup (sc, caddr (arg)))); -} - -#define fx_add_sqr_s_any(Name, Lookup) \ - static s7_pointer Name (s7_scheme* sc, s7_pointer arg) { \ - s7_pointer num1= Lookup (sc, car (opt3_pair (arg)), arg); \ - s7_pointer num2= lookup (sc, caddr (arg)); \ - if ((is_t_complex (num1)) && (is_t_complex (num2))) { \ - s7_double r= real_part (num1), i= imag_part (num1); \ - return (make_complex (sc, real_part (num2) + r * r - i * i, \ - imag_part (num2) + 2.0 * r * i)); \ - } \ - return (add_p_pp (sc, fx_sqr_wrapped (sc, num1), num2)); \ - } + case T_RANDOM_STATE: + set = random_state_setter; + dest_len = 2; + break; -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 arg1_p= opt3_pair (arg); /* cdadr(arg) */ - s7_pointer num1 = lookup (sc, car (arg1_p)); - s7_pointer num2 = lookup (sc, opt1_sym (arg1_p)); - s7_pointer num3 = lookup (sc, caddr (arg)); - if ((is_t_real (num1)) && (is_t_real (num2)) && (is_t_real (num3))) - return (make_real (sc, real (num3) + real (num1) - real (num2))); - return (add_p_pp (sc, subtract_p_pp_wrapped (sc, num1, num2), num3)); -} - -static s7_pointer -fx_add_sub_tu_s (s7_scheme* sc, s7_pointer arg) { - s7_pointer num1= t_lookup (sc, car (cdadr (arg)), arg); - s7_pointer num2= u_lookup (sc, cadr (cdadr (arg)), arg); - s7_pointer num3= lookup (sc, caddr (arg)); - if ((is_t_real (num1)) && (is_t_real (num2)) && (is_t_real (num3))) - return (make_real (sc, real (num3) + real (num1) - real (num2))); - return (add_p_pp (sc, subtract_p_pp_wrapped (sc, num1, num2), num3)); -} - -static s7_pointer -fx_gt_add_s (s7_scheme* sc, s7_pointer arg) { - s7_pointer arg1_p= opt3_pair (arg); /* cdadr(arg) */ - s7_pointer x1 = lookup (sc, car (arg1_p)); - s7_pointer x2 = lookup (sc, opt1_sym (arg1_p)); - s7_pointer 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_wrapped (sc, x1, x2), x3)); -} - -static s7_pointer -fx_gt_add_tu_s (s7_scheme* sc, s7_pointer arg) { - s7_pointer x1= t_lookup (sc, car (cdadr (arg)), arg); - s7_pointer x2= u_lookup (sc, cadr (cdadr (arg)), arg); - s7_pointer 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_wrapped (sc, x1, x2), x3)); -} - -static s7_pointer -fx_gt_vref_s (s7_scheme* sc, s7_pointer arg) { - return ( - gt_p_pp (sc, - s7i_vector_ref_p_pp (sc, lookup (sc, car (opt3_pair (arg))), - lookup (sc, opt1_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)), - s7i_vector_ref_p_pp (sc, lookup (sc, car (opt3_pair (arg))), - lookup (sc, opt1_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)) == - s7i_vector_ref_p_pp (sc, lookup (sc, car (opt3_pair (arg))), - lookup (sc, opt1_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)), - s7i_vector_ref_p_pp (sc, lookup (sc, car (opt3_pair (arg))), - lookup (sc, opt1_sym (opt3_pair (arg)))))); -} - -static s7_pointer -fx_lref_s_vref (s7_scheme* sc, s7_pointer arg) /* tbig */ -{ - return ( - let_ref (sc, lookup (sc, cadr (arg)), - s7i_vector_ref_p_pp (sc, lookup (sc, car (opt3_pair (arg))), - lookup (sc, opt1_sym (opt3_pair (arg)))))); -} - -static s7_pointer -fx_vref_s_add (s7_scheme* sc, s7_pointer arg) { - return (s7i_vector_ref_p_pp ( - sc, lookup (sc, cadr (arg)), - add_p_pp_wrapped (sc, lookup (sc, car (opt3_pair (arg))), - lookup (sc, opt1_sym (opt3_pair (arg)))))); -} - -static inline s7_pointer -fx_vref_vref_3 (s7_scheme* sc, s7_pointer vec, s7_pointer num1, - s7_pointer num2) { - if ((is_t_integer (num1)) && (is_t_integer (num2)) && - ((is_t_vector (vec)) && (vector_rank (vec) == 1))) { - const s7_int index1= integer (num1), index2= integer (num2); - if ((index1 >= 0) && (index2 >= 0) && (index1 < vector_length (vec))) { - s7_pointer vec_in_vec= vector_element (vec, index1); - if ((is_t_vector (vec_in_vec)) && (vector_rank (vec_in_vec) == 1) && - (index2 < vector_length (vec_in_vec))) - return (vector_element (vec_in_vec, index2)); + default: + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_4(sc, wrap_string(sc, "can't ~S ~S to ~S", 17), caller, source, dest)); } - } - return (s7i_vector_ref_p_pp (sc, s7i_vector_ref_p_pp (sc, vec, num1), num2)); -} - -#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, opt1_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) { - const s7_pointer arg1= cadr (arg); - set_car (sc->t2_1, lookup (sc, cadr (arg1))); - set_car (sc->t2_2, opt1_con (cdr (arg1))); - set_car (sc->t2_1, fn_proc (arg1) (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) { \ - const s7_pointer arg1= cadr (arg); \ - set_car (sc->t2_1, Lookup1 (sc, cadr (arg1), arg1)); \ - set_car (sc->t2_2, Lookup2 (sc, opt1_sym (cdr (arg1)), arg1)); \ - set_car (sc->t2_1, fn_proc (arg1) (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 arg1= cadr (arg); - return (((s7_p_pp_t) opt3_direct (arg)) ( - sc, - fn_proc (arg1) (sc, set_plist_2 (sc, lookup (sc, cadr (arg1)), - t_lookup (sc, caddr (arg1), 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 arg1= cadr (arg); \ - set_car (sc->t2_1, \ - fn_proc (arg1) ( \ - sc, with_list_t1 ( \ - sc, Lookup1 (sc, cadr (arg1), \ - arg)))); /* also opt1_sym(cdr(arg)) */ \ - 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))); \ - } + if (dest_len == 0) + return(dest); - 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) + /* end is source_len if not set explicitly */ + if (dest_len < source_len) + { + end = dest_len + start; + source_len = dest_len; + } -#define fx_cons_car_s_s_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name (s7_scheme* sc, s7_pointer arg) { \ - s7_pointer 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))); \ - } + if ((source != dest) && + ((type(source) == type(dest)) || + ((is_string_or_byte_vector(source)) && + (is_string_or_byte_vector(dest))))) + { + s7_pointer result = copy_to_same_type(sc, dest, source, 0, source_len, start); + if (result) return(result); + } - 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->t3_1, \ - fn_proc (cadr (arg)) ( \ - sc, with_list_t1 (sc, Lookup1 (sc, opt3_sym (cdr (arg)), \ - arg)))); /* cadadr(arg) */ \ - 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)); \ - } + switch (type(source)) + { + case T_PAIR: + { + s7_pointer p = source; + if (start > 0) + for (s7_int 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) + { + s7_pointer dp = source; + for (s7_int 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 (s7_int i = start, j = 0; i < end; i++, j++, p = cdr(p)) + { + if (!is_character(car(p))) + copy_element_error_nr(sc, caller, i + 1, car(p), T_CHARACTER); + dst[j] = character(car(p)); + }} + else + if ((is_t_vector(dest)) && (set != typed_vector_setter)) + { + s7_pointer *els = vector_elements(dest); + for (s7_int i = start, j = 0; i < end; i++, j++, p = cdr(p)) + els[j] = car(p); + } + else + { + gc_protect_via_stack(sc, source); + for (s7_int i = start, j = 0; i < end; i++, j++, p = cdr(p)) + set(sc, dest, j, car(p)); + unstack_gc_protect(sc); + } + return(dest); + } -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->t2_1, \ - fn_proc (cadr (arg)) ( \ - sc, with_list_t1 (sc, Lookup (sc, opt1_sym (cdr (arg)), \ - arg)))); /* cadadr */ \ - set_car (sc->t2_2, opt2_con (cdr (arg))); \ - return (fn_proc (arg) (sc, sc->t2_1)); \ - } + case T_LET: + if (source == sc->starlet) /* *s7* */ /* this could be more direct via starlet_make_iterator, but it hardly matters */ + { + const s7_pointer iter = s7_make_iterator(sc, sc->starlet); + const s7_int gc_loc = gc_protect_1(sc, iter); + for (s7_int 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 = dest; + for (s7_int i = start; (i < end) && (is_pair(p)); i++, p = cdr(p)) /* i = start is redundant? also below */ + { + s7_pointer val = s7_iterate(sc, iter); + if (iterator_is_at_end(iter)) break; + set_car(p, val); + }} + else + for (s7_int i = start, j = 0; i < end; i++, j++) + { + s7_pointer 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 (s7_int i = 0; i < start; i++) slot = next_slot(slot); + if (is_pair(dest)) + { + s7_pointer p = dest; + check_free_heap_size(sc, end - start); + for (s7_int i = start; (i < end) && (is_pair(p)); i++, p = cdr(p), slot = next_slot(slot)) + set_car(p, cons_unchecked(sc, slot_symbol(slot), slot_value(slot))); + } + else + if (is_let(dest)) /* this ignores slot setters */ + { + if ((has_let_fallback(source)) && + (has_let_fallback(dest))) + { + for (slot = let_slots(source); is_not_slot_end(slot); slot = next_slot(slot)) + if ((slot_symbol(slot) != sc->let_ref_fallback_symbol) && + (slot_symbol(slot) != sc->let_set_fallback_symbol)) + add_slot_no_local(sc, dest, slot_symbol(slot), slot_value(slot)); + } + else + for (s7_int i = start; i < end; i++, slot = next_slot(slot)) + add_slot_no_local(sc, dest, slot_symbol(slot), slot_value(slot)); + } + else + if (is_hash_table(dest)) + for (s7_int i = start; i < end; i++, slot = next_slot(slot)) + s7_hash_table_set(sc, dest, slot_symbol(slot), slot_value(slot)); /* if value=#f, dest will not contain symbol */ + else + if ((is_t_vector(dest)) && (set != typed_vector_setter)) + { + s7_pointer *els = vector_elements(dest); + check_free_heap_size(sc, end - start); + for (s7_int i = start, j = 0; i < end; i++, j++, slot = next_slot(slot)) + els[j] = cons_unchecked(sc, slot_symbol(slot), slot_value(slot)); + } + else + for (s7_int 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); - fx_c_opsq_c_any (fx_c_opsq_c, s_lookup) - fx_c_opsq_c_any (fx_c_optq_c, t_lookup) + case T_HASH_TABLE: + { + s7_int loc = -1, skip = start; + hash_entry_t **elements = hash_table_elements(source); + hash_entry_t *entry = NULL; + + while (skip > 0) + { + while (!entry) entry = elements[++loc]; + skip--; + entry = hash_entry_next(entry); + } + if (is_pair(dest)) + { + s7_pointer p = dest; + check_free_heap_size(sc, end - start); + for (s7_int i = start; (i < end) && (is_pair(p)); i++, p = cdr(p)) + { + while (!entry) entry = elements[++loc]; + set_car(p, cons_unchecked(sc, hash_entry_key(entry), hash_entry_value(entry))); + entry = hash_entry_next(entry); + }} + else + if (is_let(dest)) + { + for (s7_int i = start; i < end; i++) + { + s7_pointer symbol; + while (!entry) entry = elements[++loc]; + symbol = hash_entry_key(entry); + if (!is_symbol(symbol)) + copy_element_error_nr(sc, caller, i + 1, symbol, T_SYMBOL); + if (is_constant_symbol(sc, symbol)) + error_nr(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_no_local(sc, dest, symbol, hash_entry_value(entry)); /* ...unchecked... if size ok */ + entry = hash_entry_next(entry); + }} + else + { + check_free_heap_size(sc, end - start); + for (s7_int i = start, j = 0; i < end; i++, j++) + { + while (!entry) entry = elements[++loc]; + set(sc, dest, j, cons_unchecked(sc, hash_entry_key(entry), hash_entry_value(entry))); + entry = hash_entry_next(entry); + }} + return(dest); + } - 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)))); -} + case T_VECTOR: + { + s7_pointer *vals = vector_elements(source); + if (is_float_vector(dest)) + { + s7_double *dst = float_vector_floats(dest); + for (s7_int i = start, j = 0; i < end; i++, j++) + dst[j] = real_to_double(sc, vals[i], symbol_name(caller)); + return(dest); + } + if (is_int_vector(dest)) + { + s7_int *dst = int_vector_ints(dest); + for (s7_int i = start, j = 0; i < end; i++, j++) + { + if (!s7_is_integer(vals[i])) + copy_element_error_nr(sc, caller, i + 1, vals[i], T_INTEGER); + dst[j] = s7_integer_clamped_if_gmp(sc, vals[i]); + } + return(dest); + } + if (is_complex_vector(dest)) + { + s7_complex *dst = complex_vector_complexes(dest); + for (s7_int i = start, j = 0; i < end; i++, j++) + { + if (!s7_is_number(vals[i])) + copy_element_error_nr(sc, caller, i + 1, vals[i], T_COMPLEX); + dst[j] = s7_to_c_complex(vals[i]); + } + return(dest); + } + if (is_string(dest)) + { + char *dst = string_value(dest); + for (s7_int i = start, j = 0; i < end; i++, j++) + { + if (!is_character(vals[i])) + copy_element_error_nr(sc, caller, i + 1, 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 (s7_int i = start, j = 0; i < end; i++, j++) + { + s7_int byte; + if (!s7_is_integer(vals[i])) + copy_element_error_with_type_nr(sc, caller, i + 1, vals[i], an_unsigned_byte_string); + byte = s7_integer_clamped_if_gmp(sc, vals[i]); + if ((byte >= 0) && (byte < 256)) + dst[j] = (uint8_t)byte; + else copy_element_error_with_type_nr(sc, caller, i + 1, vals[i], an_unsigned_byte_string); + } + return(dest); + }} + break; -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))))); -} + case T_COMPLEX_VECTOR: + if ((is_t_vector(dest)) && (!is_typed_vector(dest))) + { + const s7_complex *src = complex_vector_complexes(source); + s7_pointer *dst = vector_elements(dest); + check_free_heap_size(sc, end - start); + for (s7_int i = start, j = 0; i < end; i++, j++) + dst[j] = c_complex_to_s7(sc, src[i]); + return(dest); + } + break; -static s7_pointer -fx_memq_car_s (s7_scheme* sc, s7_pointer arg) { - s7_pointer lst= opt2_con (cdr (arg)); - s7_pointer obj= lookup (sc, opt1_sym (cdr (arg))); - obj= (is_pair (obj)) ? car (obj) : g_car (sc, set_plist_1 (sc, obj)); - while (true) - LOOP_4 (if (obj == car (lst)) return (lst); lst= cdr (lst); - if (!is_pair (lst)) return (sc->F)); - return (sc->F); -} - -static s7_pointer -fx_memq_car_s_2 (s7_scheme* sc, s7_pointer arg) { - s7_pointer lst= opt2_con (cdr (arg)); - s7_pointer obj= lookup (sc, opt1_sym (cdr (arg))); - obj= (is_pair (obj)) ? car (obj) : g_car (sc, set_plist_1 (sc, obj)); - if (obj == car (lst)) return (lst); - return ((obj == cadr (lst)) ? cdr (lst) : sc->F); -} - -static s7_pointer -fx_c_s_opssq (s7_scheme* sc, s7_pointer arg) { - s7_pointer arg2= caddr (arg); - set_car ( - sc->t2_2, - fn_proc (arg2) (sc, with_list_t2 (sc, lookup (sc, cadr (arg2)), - lookup (sc, opt1_sym (cdr (arg2)))))); - 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 p_arg2= 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 (p_arg2)), \ - Lookup2 (sc, opt1_sym (p_arg2), p_arg2)))); \ - } + case T_FLOAT_VECTOR: + /* int-vector destination can't normally work, fractional parts get rounded away */ + if ((is_t_vector(dest)) && (!is_typed_vector(dest))) + { + const s7_double *src = float_vector_floats(source); + s7_pointer *dst = vector_elements(dest); + check_free_heap_size(sc, end - start); + for (s7_int i = start, j = 0; i < end; i++, j++) + dst[j] = make_real_unchecked(sc, src[i]); + return(dest); + } + break; -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 (s7i_vector_ref_p_pp ( - sc, lookup_global (sc, cadr (arg)), - s7i_vector_ref_p_pp (sc, lookup_global (sc, car (opt3_pair (arg))), - lookup (sc, opt1_sym (opt3_pair (arg)))))); -} - -static s7_pointer -fx_vref_g_vref_gt (s7_scheme* sc, s7_pointer arg) { - return (s7i_vector_ref_p_pp ( - sc, lookup_global (sc, cadr (arg)), - s7i_vector_ref_p_pp (sc, lookup_global (sc, car (opt3_pair (arg))), - t_lookup (sc, opt1_sym (opt3_pair (arg)), arg)))); -} - -static s7_pointer -fx_c_c_opssq (s7_scheme* sc, s7_pointer arg) { - s7_pointer arg2= caddr (arg); - set_car ( - sc->t2_2, - fn_proc (arg2) (sc, with_list_t2 (sc, lookup (sc, cadr (arg2)), - lookup (sc, opt1_sym (cdr (arg2)))))); - 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= ((s7_d_pd_t) opt3_direct (cdr (arg))) ( - lookup (sc, opt3_sym (arg)), - real_to_double (sc, lookup (sc, opt1_sym (cdr (arg))), __func__)); - return (((s7_p_dd_t) opt2_direct (cdr (arg))) ( - sc, real_to_double (sc, cadr (arg), __func__), x2)); -} - -static s7_pointer -fx_multiply_c_opssq (s7_scheme* sc, s7_pointer arg) /* (* c=float (* x1 x2))! */ -{ - s7_pointer x1= lookup (sc, opt3_sym (arg)); - s7_pointer 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_wrapped (sc, x1, x2))); -} - -#define fx_c_s_opscq_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name (s7_scheme* sc, s7_pointer arg) { \ - const s7_pointer arg2= caddr (arg); \ - set_car (sc->t2_1, Lookup2 (sc, cadr (arg2), arg)); \ - set_car (sc->t2_2, opt1_con (cdr (arg2))); \ - set_car (sc->t2_2, fn_proc (arg2) (sc, sc->t2_1)); \ - set_car (sc->t2_1, Lookup1 (sc, cadr (arg), arg)); \ - return (fn_proc (arg) (sc, sc->t2_1)); \ - } + case T_INT_VECTOR: + { + const s7_int *src = int_vector_ints(source); + if (is_float_vector(dest)) + { + s7_double *dst = float_vector_floats(dest); + for (s7_int i = start, j = 0; i < end; i++, j++) + dst[j] = (s7_double)(src[i]); + return(dest); + } + if ((is_t_vector(dest)) && (!is_typed_vector(dest))) + { + s7_pointer *dst = vector_elements(dest); + check_free_heap_size(sc, end - start); + for (s7_int i = start, j = 0; i < end; i++, j++) + dst[j] = make_integer_unchecked(sc, src[i]); + return(dest); + } + if (is_string(dest)) + { + for (s7_int i = start, j = 0; i < end; i++, j++) + { + if ((src[i] < 0) || (src[i] > 255)) + copy_element_error_with_type_nr(sc, caller, i + 1, wrap_integer(sc, src[i]), an_unsigned_byte_string); + string_value(dest)[j] = (uint8_t)(src[i]); + } + return(dest); + } + if (is_byte_vector(dest)) + { + for (s7_int i = start, j = 0; i < end; i++, j++) + { + if ((src[i] < 0) || (src[i] > 255)) + copy_element_error_with_type_nr(sc, caller, i + 1, wrap_integer(sc, src[i]), an_unsigned_byte_string); + byte_vector(dest, j) = (uint8_t)(src[i]); + } + return(dest); + }} + break; -fx_c_s_opscq_any (fx_c_s_opscq, s_lookup, s_lookup) - fx_c_s_opscq_any (fx_c_u_optcq, u_lookup, t_lookup) - /* also fx_c_T_optcq */ - - 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_u_optiq_direct (s7_scheme* sc, s7_pointer arg) { - return (((s7_p_pp_t) opt2_direct (cdr (arg))) ( - sc, u_lookup (sc, cadr (arg), arg), - ((s7_p_pi_t) opt3_direct (cdr (arg))) (sc, - t_lookup (sc, opt3_sym (arg), 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 ind= lookup (sc, opt3_sym (arg)); - s7_pointer vec= lookup (sc, cadr (arg)); - if ((is_t_integer (ind)) && (is_t_vector (vec)) && (vector_rank (vec) == 1)) { - s7_int index= integer (ind) + 1; - if ((index >= 0) && (vector_length (vec) > index)) - return (vector_element (vec, index)); - } - return (s7i_vector_ref_p_pp (sc, vec, g_add_xi (sc, ind, 1, 2))); -} - -static s7_pointer -fx_num_eq_add_s_si (s7_scheme* sc, s7_pointer arg) { - s7_pointer i1= lookup (sc, cadr (arg)); - s7_pointer 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))), 2)))); -} - -static s7_pointer -fx_num_eq_subtract_s_si (s7_scheme* sc, s7_pointer arg) { - s7_pointer i1= lookup (sc, cadr (arg)); - s7_pointer 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))))); \ - } + case T_BYTE_VECTOR: + if ((is_t_vector(dest)) && (!is_typed_vector(dest))) + { + s7_pointer *dst = vector_elements(dest); + check_free_heap_size(sc, end - start); + for (s7_int i = start, j = 0; i < end; i++, j++) + dst[j] = small_int(byte_vector(source, i)); + return(dest); + } + if (is_int_vector(dest)) + { + s7_int *els = int_vector_ints(dest); + for (s7_int 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 (s7_int i = start, j = 0; i < end; i++, j++) + els[j] = (s7_double)((uint8_t)(byte_vector(source, i))); + return(dest); + } + break; -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) + case T_STRING: + if ((is_t_vector(dest)) && (!is_typed_vector(dest))) + { + s7_pointer *dst = vector_elements(dest); + for (s7_int 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 (s7_int 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 (s7_int i = start, j = 0; i < end; i++, j++) + els[j] = (s7_double)((uint8_t)(string_value(source)[i])); + return(dest); + } + break; + /* default (random_state, simple_block etc) is to let "set" handle it below */ + } - static s7_pointer fx_c_s_opsq (s7_scheme* sc, s7_pointer arg) { - s7_pointer arg2= caddr (arg); - set_car (sc->t2_2, - fn_proc (arg2) (sc, with_list_t1 (sc, lookup (sc, cadr (arg2))))); - set_car (sc->t2_1, lookup (sc, cadr (arg))); - return (fn_proc (arg) (sc, sc->t2_1)); + if (is_pair(dest)) + { + s7_pointer p = dest; + if (is_float_vector(source)) + { + const s7_double *els = float_vector_floats(source); + check_free_heap_size(sc, end - start); + for (s7_int i = start; (i < end) && (is_pair(p)); i++, p = cdr(p)) + set_car(p, make_real_unchecked(sc, els[i])); + } + else + if (is_int_vector(source)) + { + const s7_int *els = int_vector_ints(source); + check_free_heap_size(sc, end - start); + for (s7_int i = start; (i < end) && (is_pair(p)); i++, p = cdr(p)) + set_car(p, make_integer_unchecked(sc, els[i])); + } + else + for (s7_int i = start; (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 (s7_int 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); } -#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_opsq_direct, t_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= 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= Lookup1 (sc, cadr (arg), arg); \ - s7_pointer val2= Lookup2 (sc, opt2_sym (cdr (arg)), arg); \ - val2= (is_pair (val2)) ? car (val2) : g_car (sc, set_plist_1 (sc, val2)); \ - return (((is_t_integer (val1)) && (is_t_integer (val2))) \ - ? make_integer (sc, integer (val1) + integer (val2)) \ - : add_p_pp (sc, val1, val2)); \ - } +s7_pointer s7_copy(s7_scheme *sc, s7_pointer args) {return(s7_copy_1(sc, sc->copy_symbol, args));} +#define g_copy s7_copy - 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= 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); - s7_pointer args = caddr (outer); - set_car (sc->t2_2, - fn_proc (args) (sc, with_list_t1 (sc, lookup (sc, cadr (args))))); - set_car (sc->t2_1, lookup (sc, cadr (outer))); - return ( - fn_proc (arg) (sc, with_list_t1 (sc, fn_proc (outer) (sc, sc->t2_1)))); -} - -static s7_pointer -fx_not_op_s_opsqq (s7_scheme* sc, s7_pointer arg) { - s7_pointer outer= cadr (arg); - s7_pointer args = caddr (outer); - set_car (sc->t2_2, - fn_proc (args) (sc, with_list_t1 (sc, lookup (sc, cadr (args))))); - 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); - s7_pointer args = cadr (outer); - set_car (sc->t2_1, - fn_proc (args) (sc, with_list_t1 (sc, lookup (sc, cadr (args))))); - set_car (sc->t2_2, lookup (sc, caddr (outer))); - return ( - fn_proc (arg) (sc, with_list_t1 (sc, fn_proc (outer) (sc, sc->t2_1)))); -} - -static s7_pointer -fx_not_op_optq_sq (s7_scheme* sc, s7_pointer arg) { - s7_pointer outer= cadr (arg); - s7_pointer args = cadr (outer); - set_car ( - sc->t2_1, - fn_proc (args) (sc, with_list_t1 (sc, t_lookup (sc, cadr (args), arg)))); - 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 arg2= opt3_pair (arg); /* caddr(arg) */ - set_car (sc->t2_2, - fn_proc (arg2) (sc, with_list_t1 (sc, lookup (sc, cadr (arg2))))); - 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)))))); +s7_pointer s7i_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args) +{ + return(s7_copy_1(sc, caller, args)); } -/* perhaps fx_c_c_opt|T|Vq_direct tlet/tmisc */ - -static s7_pointer -fx_c_opsq_opsq (s7_scheme* sc, s7_pointer arg) { - s7_pointer argp= cdr (arg); - gc_protect_via_stack ( - sc, - fn_proc (car (argp)) (sc, with_list_t1 (sc, lookup (sc, cadar (argp))))); - argp= cadr (argp); - set_car (sc->t2_2, - fn_proc (argp) (sc, with_list_t1 (sc, lookup (sc, cadr (argp))))); - set_car (sc->t2_1, gc_protected1 (sc)); - unstack_gc_protect (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= - 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= Lookup1 (sc, opt1_sym (cdr (arg)), arg); \ - s7_pointer 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= lookup (sc, opt1_sym (cdr (arg))); - s7_pointer 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= t_lookup (sc, opt1_sym (cdr (arg)), arg); - s7_pointer p2= u_lookup (sc, opt2_sym (cdr (arg)), arg); - p1 = (is_pair (p1)) ? car (p1) : g_car (sc, set_plist_1 (sc, p1)); - 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 argp= cdr (arg); - gc_protect_via_stack ( - sc, - fn_proc (car (argp)) (sc, with_list_t1 (sc, lookup (sc, cadar (argp))))); - argp= cadr (argp); - set_car (sc->t2_1, lookup (sc, cadr (argp))); - set_car (sc->t2_2, lookup (sc, opt1_sym (cdr (argp)))); /* caddr(argp) */ - set_car (sc->t2_2, fn_proc (argp) (sc, sc->t2_1)); - set_car (sc->t2_1, gc_protected1 (sc)); - unstack_gc_protect (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 argp= cdr (arg); - return (((s7_p_pp_t) opt3_direct (arg)) ( - sc, ((s7_p_p_t) opt2_direct (argp)) (sc, lookup (sc, cadar (argp))), - ((s7_p_pp_t) opt3_direct (argp)) ( - sc, t_lookup (sc, opt2_sym (cdr (argp)), arg), - u_lookup (sc, opt1_sym (argp), arg)))); -} - -static s7_pointer -fx_num_eq_car_v_add_tu (s7_scheme* sc, s7_pointer arg) { - s7_pointer num1= car_p_p (sc, v_lookup (sc, cadadr (arg), arg)); - s7_pointer num2= t_lookup (sc, opt2_sym (cddr (arg)), arg); - s7_pointer num3= u_lookup (sc, opt1_sym (cdr (arg)), arg); - if ((is_t_integer (num1)) && (is_t_integer (num2)) && (is_t_integer (num3))) - return ( - make_boolean (sc, integer (num1) == (integer (num2) + integer (num3)))); - return (make_boolean ( - sc, num_eq_b_7pp (sc, num1, add_p_pp_wrapped (sc, num2, num3)))); -} - -static s7_pointer -fx_num_eq_car_v_subtract_tu (s7_scheme* sc, s7_pointer arg) { - s7_pointer num1= car_p_p (sc, v_lookup (sc, cadadr (arg), arg)); - s7_pointer num2= t_lookup (sc, opt2_sym (cddr (arg)), arg); - s7_pointer num3= u_lookup (sc, opt1_sym (cdr (arg)), arg); - if ((is_t_integer (num1)) && (is_t_integer (num2)) && (is_t_integer (num3))) - return ( - make_boolean (sc, integer (num1) == (integer (num2) - integer (num3)))); - return (make_boolean ( - sc, num_eq_b_7pp (sc, num1, subtract_p_pp_wrapped (sc, num2, num3)))); -} - -static s7_pointer -fx_c_opssq_opsq (s7_scheme* sc, s7_pointer arg) { - s7_pointer argp= cdr (arg); - set_car (sc->t2_1, lookup (sc, cadar (argp))); - set_car (sc->t2_2, lookup (sc, opt1_sym (cdar (argp)))); - gc_protect_via_stack (sc, fn_proc (car (argp)) (sc, sc->t2_1)); - argp= cadr (argp); - set_car (sc->t2_2, - fn_proc (argp) (sc, with_list_t1 (sc, lookup (sc, cadr (argp))))); - set_car (sc->t2_1, gc_protected1 (sc)); - unstack_gc_protect (sc); - return (fn_proc (arg) (sc, sc->t2_1)); -} - -static s7_pointer -fx_c_opssq_opssq (s7_scheme* sc, s7_pointer arg) { - s7_pointer argp= cdr (arg); - set_car (sc->t2_1, lookup (sc, cadar (argp))); - set_car (sc->t2_2, lookup (sc, opt1_sym (cdar (argp)))); - gc_protect_via_stack (sc, fn_proc (car (argp)) (sc, sc->t2_1)); - argp= cadr (argp); - set_car (sc->t2_1, lookup (sc, cadr (argp))); - set_car (sc->t2_2, lookup (sc, opt1_sym (cdr (argp)))); - set_car (sc->t2_2, fn_proc (argp) (sc, sc->t2_1)); - set_car (sc->t2_1, gc_protected1 (sc)); - unstack_gc_protect (sc); - return (fn_proc (arg) (sc, sc->t2_1)); -} - -static s7_pointer -fx_sub_mul_mul (s7_scheme* sc, s7_pointer arg) /* (- (* x1 x2) (* x3 x4)) */ -{ - s7_pointer p1= opt3_pair (arg); /* cdaddr(arg) */ - s7_pointer x1= lookup (sc, car (p1)); - s7_pointer x2= lookup (sc, cadr (p1)); - s7_pointer p2= opt1_pair (cdr (arg)); - /* cdadr(arg) */ /* here and elsewhere this should be GC safe -- opssq->* - (no methods?) etc */ - s7_pointer x3= lookup (sc, car (p2)); - s7_pointer x4= lookup (sc, cadr (p2)); - if ((is_t_real (x1)) && (is_t_real (x2)) && (is_t_real (x3)) && - (is_t_real (x4))) - return (make_real (sc, (real (x3) * real (x4)) - (real (x1) * real (x2)))); - sc->temp5= multiply_p_pp_wrapped (sc, x1, x2); - return (subtract_p_pp (sc, multiply_p_pp_wrapped (sc, x3, x4), sc->temp5)); -} - -static s7_pointer -fx_add_mul_mul (s7_scheme* sc, s7_pointer arg) /* (+ (* x1 x2) (* x3 x4)) */ -{ - s7_pointer p1= opt3_pair (arg); /* cdaddr(arg) */ - s7_pointer x1= lookup (sc, car (p1)); - s7_pointer x2= lookup (sc, cadr (p1)); - s7_pointer p2= opt1_pair (cdr (arg)); /* cdadr(arg) */ - s7_pointer x3= lookup (sc, car (p2)); - s7_pointer x4= lookup (sc, cadr (p2)); - if ((is_t_real (x1)) && (is_t_real (x2)) && (is_t_real (x3)) && - (is_t_real (x4))) - return (make_real (sc, (real (x3) * real (x4)) + (real (x1) * real (x2)))); - sc->temp5= multiply_p_pp_wrapped (sc, x1, x2); - return (add_p_pp (sc, multiply_p_pp_wrapped (sc, x3, x4), sc->temp5)); -} - -static s7_pointer -fx_mul_sub_sub (s7_scheme* sc, s7_pointer arg) /* (* (- x1 x2) (- x3 x4)) */ -{ - s7_pointer p1= opt3_pair (arg); /* cdaddr(arg) */ - s7_pointer x1= lookup (sc, car (p1)); - s7_pointer x2= lookup (sc, cadr (p1)); - s7_pointer p2= opt1_pair (cdr (arg)); /* cdadr(arg) */ - s7_pointer x3= lookup (sc, car (p2)); - s7_pointer x4= lookup (sc, cadr (p2)); - if ((is_t_real (x1)) && (is_t_real (x2)) && (is_t_real (x3)) && - (is_t_real (x4))) - return (make_real (sc, (real (x3) - real (x4)) * (real (x1) - real (x2)))); - sc->temp5= subtract_p_pp_wrapped (sc, x1, x2); - return (multiply_p_pp (sc, subtract_p_pp_wrapped (sc, x3, x4), sc->temp5)); -} - -static s7_pointer -fx_lt_sub2 (s7_scheme* sc, s7_pointer arg) { - s7_pointer p1= opt3_pair (arg); /* cdaddr(arg) */ - sc->temp5= - subtract_p_pp_wrapped (sc, lookup (sc, car (p1)), lookup (sc, cadr (p1))); - p1= opt1_pair (cdr (arg)); /* cdadr(arg) */ - return (lt_p_pp ( - sc, - subtract_p_pp_wrapped (sc, lookup (sc, car (p1)), lookup (sc, cadr (p1))), - sc->temp5)); -} - -static s7_pointer -fx_sub_vref2 (s7_scheme* sc, s7_pointer arg) { - const s7_pointer arg1p= cdadr (arg); - const s7_pointer vec = lookup (sc, car (arg1p)); - const s7_pointer num1 = lookup (sc, cadr (arg1p)); - const s7_pointer num2 = lookup (sc, opt3_sym (arg)); /* caddaddr(arg) */ - if ((is_t_integer (num1)) && (is_t_integer (num2)) && - ((is_t_vector (vec)) && (vector_rank (vec) == 1))) { - s7_int index1= integer (num1), index2= integer (num2); - if ((index1 >= 0) && (index1 <= vector_length (vec)) && (index2 >= 0) && - (index2 < vector_length (vec))) - return (subtract_p_pp (sc, vector_ref_p_pi (sc, vec, index1), - vector_ref_p_pi (sc, vec, index2))); - } - return (subtract_p_pp (sc, s7i_vector_ref_p_pp (sc, vec, num1), - s7i_vector_ref_p_pp (sc, vec, num2))); -} +/* -------------------------------- 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 lst, p; -static s7_pointer -fx_c_op_opsqq (s7_scheme* sc, s7_pointer code) { - set_car (sc->t1_1, - fn_proc (opt3_pair (code)) ( - sc, with_list_t1 (sc, lookup (sc, opt3_sym (cdr (code)))))); - set_car (sc->t1_1, fn_proc (cadr (code)) (sc, sc->t1_1)); - return (fn_proc (code) (sc, sc->t1_1)); + 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 */ + begin_temp(sc->y, list_1(sc, car(a))); + for (lst = cdr(a), p = a; is_pair(lst); lst = cdr(lst), p = cdr(p)) + { + sc->y = cons(sc, car(lst), sc->y); + if (is_pair(cdr(lst))) + { + lst = cdr(lst); + sc->y = cons_unchecked(sc, car(lst), sc->y); + } + if (lst == p) /* this can take awhile to notice there's a cycle, but what does the caller expect? */ + break; + } + sc->y = (is_null(lst)) ? sc->y : cons(sc, lst, sc->y); /* ?? this means that (reverse '(1 2 . 3)) returns '(3 2 1) -- we used to return () here */ + return_with_end_temp(sc->y); } -static s7_pointer -fx_not_op_opsqq (s7_scheme* sc, s7_pointer code) { - set_car (sc->t1_1, - fn_proc (opt3_pair (code)) ( - sc, with_list_t1 (sc, lookup (sc, opt3_sym (cdr (code)))))); - return ((fn_proc (cadr (code)) (sc, sc->t1_1) == sc->F) ? sc->T : sc->F); -} +/* 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 -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 string_reverse(s7_scheme *sc, s7_pointer str) +{ + const char *source = string_value(str); + const s7_int len = string_length(str); + const char *end = (char *)(source + len); + const s7_pointer new_str = make_empty_string(sc, len, '\0'); + char *dest = (char *)(string_value(new_str) + len); + while (source < end) *(--dest) = *source++; + return(new_str); } -static s7_pointer -fx_sref_t_last (s7_scheme* sc, s7_pointer arg) { - return (string_ref_p_plast (sc, t_lookup (sc, cadr (arg), arg), int_zero)); -} /* both syms are t_lookup */ -s7_pointer -fx_c_a (s7_scheme* sc, s7_pointer arg) { - return (fn_proc (arg) (sc, with_list_t1 (sc, fx_call (sc, cdr (arg))))); -} -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 byte_vector_reverse(s7_scheme *sc, s7_pointer bv) +{ + const uint8_t *source = byte_vector_bytes(bv); + const s7_int len = byte_vector_length(bv); + const uint8_t *end = (const uint8_t *)(source + len); + const s7_pointer new_bv = make_simple_byte_vector(sc, len); + uint8_t *dest = (uint8_t *)(byte_vector_bytes(new_bv) + len); + while (source < end) *(--dest) = *source++; + return(new_bv); } -static s7_pointer -fx_c_saa (s7_scheme* sc, s7_pointer arg) { - s7_pointer result; - 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, gc_protected1 (sc)); - result= fn_proc (arg) (sc, sc->t3_1); - unstack_gc_protect (sc); - return (result); -} - -#define fx_c_ssa_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name (s7_scheme* sc, s7_pointer arg) { \ - set_car (sc->t3_3, fx_call (sc, cdr (opt3_pair (arg)))); \ - set_car (sc->t3_1, Lookup1 (sc, cadr (arg), arg)); \ - set_car (sc->t3_2, Lookup2 (sc, car (opt3_pair (arg)), arg)); \ - return (fn_proc (arg) (sc, sc->t3_1)); \ - } - -fx_c_ssa_any (fx_c_ssa, s_lookup, s_lookup) - fx_c_ssa_any (fx_c_tsa, t_lookup, s_lookup) - fx_c_ssa_any (fx_c_sta, s_lookup, t_lookup) - - 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 s7_pointer int_vector_reverse(s7_scheme *sc, s7_pointer iv) +{ + s7_pointer new_iv; + s7_int *dest; + const s7_int *source = int_vector_ints(iv); + const s7_int len = vector_length(iv); + const s7_int *end = (s7_int *)(source + len); + if (vector_rank(iv) > 1) + new_iv = s7i_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, iv)), int_zero), sc->make_int_vector_symbol); + else new_iv = make_simple_int_vector(sc, len); + dest = (s7_int *)(int_vector_ints(new_iv) + len); + while (source < end) *(--dest) = *source++; + return(new_iv); +} + +static s7_pointer float_vector_reverse(s7_scheme *sc, s7_pointer fv) +{ + s7_pointer new_fv; + s7_double *dest; + const s7_double *source = float_vector_floats(fv); + const s7_int len = vector_length(fv); + const s7_double *end = (s7_double *)(source + len); + if (vector_rank(fv) > 1) + new_fv = s7i_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, fv)), real_zero), sc->make_float_vector_symbol); + else new_fv = make_simple_float_vector(sc, len); + dest = (s7_double *)(float_vector_floats(new_fv) + len); + while (source < end) *(--dest) = *source++; + return(new_fv); +} + +static s7_pointer complex_vector_reverse(s7_scheme *sc, s7_pointer cv) +{ + s7_pointer new_cv; + s7_complex *dest; + const s7_complex *source = complex_vector_complexes(cv); + const s7_int len = vector_length(cv); + const s7_complex *end = (s7_complex *)(source + len); + if (vector_rank(cv) > 1) + new_cv = s7i_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, cv)), real_zero), sc->make_complex_vector_symbol); + else new_cv = make_simple_complex_vector(sc, len); + dest = (s7_complex *)(complex_vector_complexes(new_cv) + len); + while (source < end) *(--dest) = *source++; + return(new_cv); +} + +static s7_pointer vector_reverse(s7_scheme *sc, s7_pointer vect) +{ + s7_pointer new_vect; + s7_pointer *dest; + const s7_pointer *source = vector_elements(vect); + const s7_int len = vector_length(vect); + const s7_pointer *end = (s7_pointer *)(source + len); + if (vector_rank(vect) > 1) + new_vect = g_make_vector(sc, set_plist_1(sc, g_vector_dimensions(sc, set_plist_1(sc, vect)))); + else new_vect = make_simple_vector(sc, len); + dest = (s7_pointer *)(vector_elements(new_vect) + len); + while (source < end) *(--dest) = *source++; + if (is_typed_vector(vect)) + { + set_typed_vector(new_vect); + typed_vector_set_typer(new_vect, typed_vector_typer(vect)); + if (has_simple_elements(vect)) set_has_simple_elements(new_vect); + } + return(new_vect); } -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 c_object_reverse_1(s7_scheme *sc, s7_pointer obj) +{ + if_c_object_method_exists_return_value(sc, obj, sc->reverse_symbol, set_plist_1(sc, obj)); + if (!c_object_reverse(sc, obj)) + syntax_error_nr(sc, "attempt to reverse ~S?", 22, obj); + return((*(c_object_reverse(sc, obj)))(sc, set_plist_1(sc, obj))); } -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 let_reverse(s7_scheme *sc, s7_pointer obj) +{ + if_let_method_exists_return_value(sc, obj, sc->reverse_symbol, set_plist_1(sc, obj)); + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't reverse let: ~S", 21), obj)); +#ifdef __TINYC__ + return(NULL); /* won't happen but placate tcc */ +#endif } -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 reverse_p_p(s7_scheme *sc, s7_pointer obj) +{ + sc->temp3 = obj; + if (is_pair(obj)) return(s7_reverse(sc, obj)); /* by far the most common case */ + switch (type(obj)) + { + case T_NIL: return(sc->nil); + /* case T_PAIR: return(s7_reverse(sc, obj)); */ + case T_STRING: return(string_reverse(sc, obj)); + case T_BYTE_VECTOR: return(byte_vector_reverse(sc, obj)); + case T_INT_VECTOR: return(int_vector_reverse(sc, obj)); + case T_FLOAT_VECTOR: return(float_vector_reverse(sc, obj)); + case T_COMPLEX_VECTOR: return(complex_vector_reverse(sc, obj)); + case T_VECTOR: return(vector_reverse(sc, obj)); + case T_HASH_TABLE: return(hash_table_reverse(sc, obj)); + case T_C_OBJECT: return(c_object_reverse_1(sc, obj)); + case T_LET: return(let_reverse(sc, obj)); + default: + return(method_or_bust_p(sc, obj, sc->reverse_symbol, a_sequence_string)); + } + return(sc->nil); } -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)); -} +/* g_reverse is now defined in s7_scheme_predicate.c */ +#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) -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 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 -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 string_or_byte_vector_reverse_in_place(s7_scheme *sc, s7_pointer str) +{ + s7_int len; + uint8_t *bytes; + if (is_string(str)) + { + len = string_length(str); + bytes = (uint8_t *)string_value(str); + } + else + { + len = byte_vector_length(str); + bytes = byte_vector_bytes(str); + } + if (len < 2) return(str); + if (is_immutable(str)) /* "" might be immutable but we want (reverse! "") to return "" */ + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, str)); -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)); +#if (defined(__linux__)) && (defined(__GLIBC__)) /* need byteswp.h */ + /* this code (from StackOverflow with changes) is much faster: */ +#include + if ((len & 0x7f) == 0) + { + 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)); + LOOP_4(a = *src; b = *dst; *src++ = bswap_32(b); *dst-- = bswap_32(a)); + LOOP_4(a = *src; b = *dst; *src++ = bswap_32(b); *dst-- = bswap_32(a)); + LOOP_4(a = *src; b = *dst; *src++ = bswap_32(b); *dst-- = bswap_32(a)); + }} + else + if ((len & 0x1f) == 0) /* 4-bytes at a time, 4 times per loop == 16 */ + { + 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; + char *s2 = (char *)(s1 + len - 1); + while (s1 < s2) {char c; c = *s1; *s1++ = *s2; *s2-- = c;} + } + return(str); } -static s7_pointer -fx_c_aa (s7_scheme* sc, s7_pointer arg) { - s7_pointer result; - /* check_stack_size(sc); */ - gc_protect_2_via_stack ( - sc, fx_call (sc, cdr (arg)), - fx_call (sc, opt3_pair (arg))); /* opt3_pair = cddr(arg) */ - set_car (sc->t2_1, T_Ext (gc_protected1 (sc))); - set_car (sc->t2_2, gc_protected2 (sc)); - result= fn_proc (arg) (sc, sc->t2_1); - unstack_gc_protect (sc); - /* (define (f0) (write (vector 1.0) (openlet (inlet 'write for-each)))) or - * worse, (define L (openlet (inlet 'write for-each))) (define (f) (write - * (vector 1.0) L)) will segfault (probably) because the for-each pushes an - * operator on the stack, expecting to continue in eval, but write is a safe - * function that the optimizer thinks can ignore such stuff. s7.html warns - * about this -- the signatures should be compatible. Maybe openlet (or - * inlet?) should warn about for-each, map, member, and assoc. We could check - * first that stack_top_op == OP_GC_PROTECT and not unstack if it isn't, but - * there is nothing special to fx_c_aa in that regard. - */ - return (result); +static s7_pointer int_vector_reverse_in_place(s7_scheme *sc, s7_pointer vec) +{ + const s7_int len = vector_length(vec); + if (len < 2) + return(vec); /* (reverse! #i()) -> #i() independent of immutable bit */ + if (is_immutable_vector(vec)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, vec)); + { + s7_int *ints1 = int_vector_ints(vec); + s7_int *ints2 = (s7_int *)(ints1 + len - 1); + if ((len & 0x3f) == 0) /* 63 for 2 32's */ + while (ints1 < ints2) + { + s7_int c; + LOOP_8(c = *ints1; *ints1++ = *ints2; *ints2-- = c); + LOOP_8(c = *ints1; *ints1++ = *ints2; *ints2-- = c); + LOOP_8(c = *ints1; *ints1++ = *ints2; *ints2-- = c); + LOOP_8(c = *ints1; *ints1++ = *ints2; *ints2-- = c); + } + else + if ((len & 0xf) == 0) /* not 0x7 -- odd multiple of 8 will leave center ints unreversed (we're moving 2 at a time) */ + while (ints1 < ints2) + { + s7_int c; + LOOP_8(c = *ints1; *ints1++ = *ints2; *ints2-- = c); + } + else while (ints1 < ints2) {s7_int c; c = *ints1; *ints1++ = *ints2; *ints2-- = c;} + } + return(vec); } -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 float_vector_reverse_in_place(s7_scheme *sc, s7_pointer fv) +{ + const s7_int len = vector_length(fv); + if (len < 2) return(fv); + if (is_immutable_vector(fv)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, fv)); + { + s7_double *flts1 = float_vector_floats(fv); + s7_double *flts2 = (s7_double *)(flts1 + len - 1); + if ((len & 0x3f) == 0) /* 63 for 2 32's */ + while (flts1 < flts2) + { + s7_double x; + LOOP_8(x = *flts1; *flts1++ = *flts2; *flts2-- = x); + LOOP_8(x = *flts1; *flts1++ = *flts2; *flts2-- = x); + LOOP_8(x = *flts1; *flts1++ = *flts2; *flts2-- = x); + LOOP_8(x = *flts1; *flts1++ = *flts2; *flts2-- = x); + } + else + if ((len & 0xf) == 0) + while (flts1 < flts2) + { + s7_double x; + LOOP_8(x = *flts1; *flts1++ = *flts2; *flts2-- = x); + } + else while (flts1 < flts2) {s7_double x; x = *flts1; *flts1++ = *flts2; *flts2-- = x;} + } + return(fv); } -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 complex_vector_reverse_in_place(s7_scheme *sc, s7_pointer cv) +{ + const s7_int len = vector_length(cv); + s7_complex *cmplx1 = complex_vector_complexes(cv), *cmplx2; + if (len < 2) return(cv); + if (is_immutable_vector(cv)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, cv)); + cmplx2 = (s7_complex *)(cmplx1 + len - 1); + while (cmplx1 < cmplx2) {s7_complex z; z = *cmplx1; *cmplx1++ = *cmplx2; *cmplx2-- = z;} + return(cv); } -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_c_ai_direct (s7_scheme* sc, s7_pointer arg) { - return (((s7_p_pi_t) opt3_direct (cdr (arg))) (sc, fx_call (sc, cdr (arg)), - integer (opt3_con (arg)))); +static s7_pointer vector_reverse_in_place(s7_scheme *sc, s7_pointer vec) +{ + const s7_int len = vector_length(vec); + if (len < 2) return(vec); + if (is_immutable_vector(vec)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, vec)); + { + s7_pointer *vect1 = vector_elements(vec); + s7_pointer *vect2 = (s7_pointer *)(vect1 + len - 1); + if ((len & 0x3f) == 0) /* 63 for 2 32's */ + while (vect1 < vect2) + { + s7_pointer c; + LOOP_8(c = *vect1; *vect1++ = *vect2; *vect2-- = c); + LOOP_8(c = *vect1; *vect1++ = *vect2; *vect2-- = c); + LOOP_8(c = *vect1; *vect1++ = *vect2; *vect2-- = c); + LOOP_8(c = *vect1; *vect1++ = *vect2; *vect2-- = c); + } + else + if ((len & 0xf) == 0) + while (vect1 < vect2) + { + s7_pointer c; + LOOP_8(c = *vect1; *vect1++ = *vect2; *vect2-- = c); + } + else while (vect1 < vect2) {s7_pointer c; c = *vect1; *vect1++ = *vect2; *vect2-- = c;} + } + return(vec); } -static s7_pointer -fx_sub_a1 (s7_scheme* sc, s7_pointer arg) { - s7_pointer num= fx_call (sc, cdr (arg)); - if (is_t_integer (num)) - return (subtract_if_overflow_to_real_or_big_integer (sc, integer (num), 1)); - if (is_t_real (num)) return (make_real (sc, real (num) - 1.0)); - return (subtract_p_pp (sc, num, int_one)); +static s7_pointer reverse_pair_in_place(s7_scheme *sc, s7_pointer obj, s7_pointer args) +{ + if (is_immutable_pair(obj)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, obj)); + { + s7_pointer lst = any_list_reverse_in_place(sc, sc->nil, obj); + if (is_null(lst)) + { + if (!s7_is_proper_list(sc, obj)) + wrong_type_error_nr(sc, sc->reverseb_symbol, 1, car(args), wrap_string(sc, "a proper list", 13)); + wrong_type_error_nr(sc, sc->reverseb_symbol, 1, car(args), wrap_string(sc, "a mutable proper list", 21)); + } + return(lst); + } + /* (reverse! obj) 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! obj (reverse! obj)) + * 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)) sole_arg_wrong_type_error_nr(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 + */ } -static s7_pointer -fx_add_a1 (s7_scheme* sc, s7_pointer arg) { - s7_pointer num= fx_call (sc, cdr (arg)); - if (is_t_integer (num)) - return (add_if_overflow_to_real_or_big_integer (sc, integer (num), 1)); - if (is_t_real (num)) return (make_real (sc, real (num) + 1.0)); - return (add_p_pp (sc, num, int_one)); +static s7_pointer reverse_in_place_via_method(s7_scheme *sc, s7_pointer obj) +{ + if (is_immutable(obj)) + { + if (is_simple_sequence(obj)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, obj)); + sole_arg_wrong_type_error_nr(sc, sc->reverseb_symbol, obj, a_sequence_string); + } + if ((is_simple_sequence(obj)) && + (!has_active_methods(sc, obj))) + sole_arg_wrong_type_error_nr(sc, sc->reverseb_symbol, obj, wrap_string(sc, "a vector, string, or list", 25)); + return(method_or_bust_p(sc, obj, sc->reverseb_symbol, a_sequence_string)); } -static s7_pointer -fx_lt_ad (s7_scheme* sc, s7_pointer arg) { - s7_pointer num= fx_call (sc, cdr (arg)); - if (is_t_real (num)) - return (make_boolean (sc, real (num) < real (opt3_con (arg)))); - if (is_t_integer (num)) - return (make_boolean (sc, integer (num) < real (opt3_con (arg)))); - return (make_boolean (sc, lt_b_7pp (sc, num, opt3_con (arg)))); -} +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 + /* (reverse v) is only slighly faster than (reverse! (copy v)) */ + const s7_pointer obj = car(args); -static s7_pointer -fx_is_eq_ac (s7_scheme* sc, s7_pointer arg) { - s7_pointer y= opt3_con (arg); - s7_pointer x= fx_call (sc, cdr (arg)); - return (make_boolean ( - sc, (x == y) || ((is_unspecified (x)) && (is_unspecified (y))))); + switch (type(obj)) + { + case T_PAIR: return(reverse_pair_in_place(sc, obj, args)); + case T_BYTE_VECTOR: + case T_STRING: return(string_or_byte_vector_reverse_in_place(sc, obj)); + case T_INT_VECTOR: return(int_vector_reverse_in_place(sc, obj)); + case T_FLOAT_VECTOR: return(float_vector_reverse_in_place(sc, obj)); + case T_COMPLEX_VECTOR: return(complex_vector_reverse_in_place(sc, obj)); + case T_VECTOR: return(vector_reverse_in_place(sc, obj)); + case T_NIL: return(sc->nil); /* (reverse! ()) -> () */ + default: return(reverse_in_place_via_method(sc, obj)); + } + return(obj); } -#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) -#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) +/* -------------------------------- fill! -------------------------------- */ +static s7_pointer pair_fill(s7_scheme *sc, s7_pointer args) /* args=(list tree-to-fill fill-val start end) */ +{ + /* ambiguous ("tree-fill"?) but if it's like vector-fill, we just stomp on the top level */ + const s7_pointer obj = car(args); + const s7_pointer val = cadr(args); + s7_int i, start = 0, end, len; - 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, sc->temp3= 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, sc->temp3= 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, sc->temp3= fx_call (sc, cdr (arg)), - fx_call (sc, opt3_pair (arg)))); +#if WITH_HISTORY + if ((is_immutable_pair(obj)) && (obj != sc->eval_history1) && (obj != sc->eval_history2)) +#else + if (is_immutable_pair(obj)) +#endif + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->fill_symbol, obj)); + if (obj == global_value(sc->features_symbol)) /* (let_id(sc->curlet) == symbol_id(sc->features_symbol)) && (obj == local_value(sc->features_symbol))) */ + error_nr(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)) + error_nr(sc, sc->out_of_range_symbol, set_elist_1(sc, wrap_string(sc, "can't fill! *libraries*", 23))); + + len = s7_list_length(sc, obj); + end = len; + if (end < 0) end = -end; else {if (end == 0) end = 123123123;} + if (!is_null(cddr(args))) + { + s7_pointer 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) + { + s7_pointer p; + 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); + } + i = 0; + for (s7_pointer lst = obj, slow = obj; ; i++) + { + if ((end > 0) && (i >= end)) + return(val); + if (i >= start) set_car(lst, val); + if (!is_pair(cdr(lst))) + { + if (!is_null(cdr(lst))) + set_cdr(lst, val); + return(val); + } + lst = cdr(lst); + if ((i & 1) != 0) slow = cdr(slow); + if (lst == slow) + return(val); + } + return(val); } -#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)); \ - } +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) -fx_c_as_any (fx_c_as, s_lookup) fx_c_as_any (fx_c_at, t_lookup) + /* individual functions below check for immutable objects (rather than checking once for all here) because + * they are used elsewhere, and there are complications (the history lists in pair_fill for example). + * However, obj might have a setter which disallows val -- I guess we'll run that setter using val, + * to get the fill value to use (or raise an error). But here we have the value not the symbol/slot! + */ + const s7_pointer obj = car(args); + switch (type(obj)) + { + case T_STRING: return(g_string_fill(sc, args)); /* redundant type check here and below */ + case T_PAIR: return(pair_fill(sc, args)); + case T_HASH_TABLE: return(hash_table_fill(sc, args)); - 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)))); -} + case T_NIL: + if (!is_null(cddr(args))) /* (fill! () 1 21 #\a)? */ + syntax_error_nr(sc, "fill! () ... includes indices: ~S?", 34, cddr(args)); + return(cadr(args)); /* this parallels the empty vector case */ -static s7_pointer -fx_add_as (s7_scheme* sc, s7_pointer arg) { - s7_pointer x1= fx_call (sc, cdr (arg)); - s7_pointer 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)); -} + case T_BYTE_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_COMPLEX_VECTOR: + return(s7i_vector_fill_1(sc, sc->fill_symbol, args)); -static s7_pointer -fx_multiply_sa (s7_scheme* sc, s7_pointer arg) { - s7_pointer x1= lookup (sc, cadr (arg)); - s7_pointer 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)); -} + case T_LET: + if_let_method_exists_return_value(sc, obj, sc->fill_symbol, args); + return(let_fill(sc, args)); -static s7_pointer -fx_multiply_sa_wrapped (s7_scheme* sc, s7_pointer arg) /* experiment */ -{ - s7_pointer x1= lookup (sc, cadr (arg)); - s7_pointer x2= fx_call (sc, cddr (arg)); - if ((is_t_real (x1)) && (is_t_real (x2))) - return (wrap_real (sc, real (x1) * real (x2))); - return (multiply_p_pp_wrapped (sc, x1, x2)); -} + case T_C_OBJECT: + if_c_object_method_exists_return_value(sc, obj, sc->fill_symbol, args); + if (!c_object_fill(sc, obj)) /* default is NULL (s7_make_c_type) */ + syntax_error_nr(sc, "attempt to fill ~S?", 19, obj); + return((*(c_object_fill(sc, obj)))(sc, args)); -static s7_pointer -fx_subtract_aa (s7_scheme* sc, s7_pointer arg) { - s7_pointer x2; - s7_pointer x1= fx_call (sc, cdr (arg)); - sc->value = x1; - 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 x2; - const s7_pointer x1= fx_call (sc, cdr (arg)); - sc->value = x1; - x2 = fx_call (sc, opt3_pair (arg)); - if (is_t_real (x1)) { - if (is_t_real (x2)) return (make_real (sc, real (x1) + real (x2))); - } - else if ((is_t_integer (x1)) && - (is_t_integer ( - x2))) /* (define (func) (let ((f (lambda (a) a))) (f (+ (*s7* - 'most-positive-fixnum) (*))))) (func) */ - return (add_if_overflow_to_real_or_big_integer (sc, integer (x1), - integer (x2))); - return (add_p_pp (sc, x1, x2)); -} - -static s7_pointer -fx_multiply_aa (s7_scheme* sc, s7_pointer arg) { - s7_pointer x2; - const s7_pointer x1= fx_call (sc, cdr (arg)); - sc->value = x1; - 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) { - s7_pointer result; - /* 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, gc_protected2 (sc)); - set_car (sc->t3_1, gc_protected1 (sc)); - result= fn_proc (arg) (sc, sc->t3_1); - unstack_gc_protect (sc); - return (result); -} - -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->t2_1, fn_proc (cadr (arg)) ( - sc, with_list_t1 (sc, fx_call (sc, cdadr (arg))))); - 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->t2_2, - fn_proc (caddr (arg)) ( - sc, with_list_t1 ( - sc, fx_call (sc, opt3_pair (arg))))); /* cdaddr(arg) */ - 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 arg1= cadr (arg); - set_car (sc->t1_1, fx_call (sc, cdr (arg1))); - return (fn_proc (arg) (sc, with_list_t1 (sc, fn_proc (arg1) (sc, sc->t1_1)))); -} - -static s7_pointer -fx_c_opaaq (s7_scheme* sc, s7_pointer arg) { - const s7_pointer arg1= cadr (arg); - s7_pointer result; - /* check_stack_size(sc); */ - gc_protect_via_stack (sc, fx_call (sc, cdr (arg1))); - set_car (sc->t2_2, fx_call (sc, cddr (arg1))); - set_car (sc->t2_1, gc_protected1 (sc)); - result= fn_proc (arg1) (sc, sc->t2_1); - set_gc_protected2 ( - sc, - result); /* might be a big list etc (see s7test.scm fx_c_opaaq test) */ - result= fn_proc (arg) (sc, with_list_t1 (sc, result)); - unstack_gc_protect (sc); - return (result); -} - -static s7_pointer -fx_c_opsaq (s7_scheme* sc, s7_pointer arg) { - s7_pointer arg1= cadr (arg); - set_car (sc->t2_2, fx_call (sc, cddr (arg1))); - set_car (sc->t2_1, lookup (sc, cadr (arg1))); - return (fn_proc (arg) (sc, with_list_t1 (sc, fn_proc (arg1) (sc, sc->t2_1)))); -} - -static s7_pointer -fx_c_opaaaq (s7_scheme* sc, s7_pointer code) { - const s7_pointer arg1= cadr (code); - gc_protect_2_via_stack (sc, fx_call (sc, cdr (arg1)), - fx_call (sc, opt3_pair (arg1))); /* cddr(arg) */ - set_car (sc->t3_3, fx_call (sc, cdr (opt3_pair (arg1)))); - set_car (sc->t3_1, gc_protected1 (sc)); - set_car (sc->t3_2, gc_protected2 (sc)); - { - s7_pointer result= - fn_proc (code) (sc, with_list_t1 (sc, fn_proc (arg1) (sc, sc->t3_1))); - unstack_gc_protect (sc); - return (result); - } + default: + if_method_exists_return_value(sc, obj, sc->fill_symbol, args); + } + wrong_type_error_nr(sc, sc->fill_symbol, 1, obj, a_sequence_string); /* (fill! 1 0) */ + return(NULL); } -static s7_pointer -fx_c_s_opaaq (s7_scheme* sc, s7_pointer code) { - const s7_pointer arg2= caddr (code); - gc_protect_via_stack (sc, fx_call (sc, cdr (arg2))); - set_car (sc->t2_2, fx_call (sc, cddr (arg2))); - set_car (sc->t2_1, gc_protected1 (sc)); - set_car (sc->t2_2, fn_proc (arg2) (sc, sc->t2_1)); - set_car (sc->t2_1, lookup (sc, cadr (code))); - { - s7_pointer result= fn_proc (code) (sc, sc->t2_1); - unstack_gc_protect (sc); - return (result); - } -} +#define g_fill s7_fill -static s7_pointer -fx_c_4a (s7_scheme* sc, s7_pointer code) { - s7_pointer arg= cdr (code), result; - check_stack_size (sc); /* t718 pp cycles #f */ - gc_protect_2_via_stack (sc, fx_call (sc, arg), fx_call (sc, cdr (arg))); - arg= cddr (arg); - set_gc_protected3 (sc, fx_call (sc, arg)); - set_car (sc->t3_3, fx_call (sc, cdr (arg))); - set_car (sc->t3_2, gc_protected3 (sc)); - set_car (sc->t3_1, gc_protected2 (sc)); - set_car (sc->t4_1, gc_protected1 (sc)); - result= fn_proc (code) (sc, sc->t4_1); - unstack_gc_protect (sc); - set_car (sc->t4_1, sc->F); - return (result); -} - -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?? */ - const s7_pointer arg= cdr (code); - s7_pointer result; - set_car (sc->t4_1, fx_call (sc, arg)); - set_car (sc->t3_1, fx_call (sc, cdr (arg))); - 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) */ - result= fn_proc (code) (sc, sc->t4_1); - set_car (sc->t4_1, sc->F); - return (result); -} - -static s7_pointer -fx_c_c_opscq (s7_scheme* sc, s7_pointer arg) { - const s7_pointer arg2= caddr (arg); - set_car (sc->t2_1, lookup (sc, cadr (arg2))); - set_car (sc->t2_2, opt1_con (cdr (arg2))); - set_car (sc->t2_2, fn_proc (arg2) (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) { - const s7_pointer arg2= caddr (arg); - set_car (sc->t2_2, lookup (sc, caddr (arg2))); - set_car (sc->t2_1, opt1_con (cdr (arg2))); /* cadr(arg2) or cadadr */ - set_car (sc->t2_2, fn_proc (arg2) (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) { - const s7_pointer arg= opt1_pair (cdr (code)); - set_car (sc->t2_1, lookup (sc, cadr (arg))); - set_car (sc->t2_2, lookup (sc, opt1_sym (cdr (arg)))); - set_car (sc->t2_1, fn_proc (cadr (code)) ( - sc, with_list_t1 (sc, fn_proc (arg) (sc, sc->t2_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 result; - const s7_pointer lst= safe_list_if_possible (sc, opt3_arglen (cdr (arg))); - if (in_heap (lst)) gc_protect_via_stack (sc, lst); - for (s7_pointer args= cdr (arg), p= lst; is_pair (args); - args= cdr (args), p= cdr (p)) - set_car (p, lookup (sc, car (args))); - result= fn_proc (arg) (sc, lst); - if (in_heap (lst)) unstack_gc_protect (sc); - else clear_safe_list_in_use (sc, lst); - return (result); -} - -static s7_pointer -fx_list_ns (s7_scheme* sc, s7_pointer arg) { - s7_pointer lst= make_list (sc, opt3_arglen (cdr (arg)), sc->unused); - for (s7_pointer 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_c_all_ca (s7_scheme* sc, s7_pointer code) { - s7_pointer result; - const s7_pointer lst= safe_list_if_possible (sc, opt3_arglen (cdr (code))); - if (in_heap (lst)) gc_protect_via_stack (sc, lst); - for (s7_pointer 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)); - } - result= fn_proc (code) (sc, lst); - if (in_heap (lst)) unstack_gc_protect (sc); - else clear_safe_list_in_use (sc, lst); - return (result); -} - -static s7_pointer -fx_inlet_ca (s7_scheme* sc, s7_pointer code) { - s7_pointer new_let, last_slot= NULL; - s7_int id; - - new_cell (sc, new_let, T_LET | T_SAFE_PROCEDURE); - let_set_slots (new_let, slot_end); /* needed by add_slot_unchecked */ - let_set_outlet (new_let, sc->rootlet); - gc_protect_via_stack (sc, new_let); - - /* 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, and - * don't set local_slot until end either because fx_call might refer to - * same-name symbol in outer let. That is, symbol_id=outer_let_id so - * lookup->local_slot, so we better not set local_slot ahead of time here. - */ - for (s7_pointer lst= cdr (code); is_pair (lst); lst= cddr (lst)) { - s7_pointer symbol= car (lst), value; - symbol = (is_symbol_and_keyword (symbol)) - ? keyword_symbol (symbol) - : cadr (symbol); /* (inlet ':allow-other-keys 3) */ - if (is_constant_symbol (sc, symbol)) /* (inlet 'pi 1) */ - { - unstack_gc_protect (sc); - wrong_type_error_nr (sc, sc->inlet_symbol, 1, symbol, - a_non_constant_symbol_string); - } - value= fx_call (sc, cdr (lst)); /* it's necessary to do this first, before - add_slot_unchecked */ - if (!last_slot) - last_slot= add_slot_unchecked_no_local_slot (sc, new_let, symbol, value); - else last_slot= add_slot_at_end_no_local (sc, last_slot, symbol, value); - } - id= ++sc->let_number; - let_set_id (new_let, id); - for (s7_pointer slot= let_slots (new_let); is_not_slot_end (slot); - slot = next_slot (slot)) - symbol_set_local_slot_unincremented ( - slot_symbol (slot), id, - slot); /* was symbol_set_id(slot_symbol(slot), id) */ - unstack_gc_protect (sc); - return (new_let); -} - -static s7_pointer -fx_c_na (s7_scheme* sc, s7_pointer arg) { - s7_pointer args, p; - const s7_pointer val= safe_list_if_possible (sc, 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_gc_protect (sc); - else clear_safe_list_in_use (sc, val); - return (p); -} - -static s7_pointer -fx_vector_ns (s7_scheme* sc, s7_pointer arg) { - s7_pointer args= cdr (arg); - const s7_pointer vec = make_simple_vector (sc, opt3_arglen (cdr (arg))); - s7_pointer* els = (s7_pointer*) vector_elements (vec); - for (s7_int i= 0; is_pair (args); args= cdr (args), i++) - els[i]= lookup (sc, car (args)); - return (vec); -} - -static s7_pointer -fx_vector_na (s7_scheme* sc, s7_pointer arg) { - s7_pointer args= cdr (arg); - const s7_pointer vec= - make_simple_vector (sc, opt3_arglen (cdr (arg))); /* was s7_make_vector */ - s7_pointer* els= vector_elements (vec); - gc_protect_via_stack (sc, vec); - t_vector_fill (vec, sc->nil); /* fx_calls below can trigger GC, so all - elements of v must be legit */ - for (s7_int i= 0; is_pair (args); args= cdr (args), i++) - els[i]= fx_call (sc, args); - sc->value= vec; /* full-s7test 12262 list_p_p case */ - unstack_gc_protect (sc); - return (vec); -} - -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 */ +/* -------------------------------- append -------------------------------- */ +static s7_int total_sequence_length(s7_scheme *sc, s7_pointer args, s7_pointer caller, uint8_t typ) +{ + s7_pointer seqs = args; + s7_int len = 0; + for (s7_int i = 1; is_pair(seqs); seqs = cdr(seqs), i++) + { + const s7_pointer seq = car(seqs); + const s7_int 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_error_nr(sc, caller, i, seq, sc->type_names[typ]); + if (n < 0) + wrong_type_error_nr(sc, caller, i, seq, (is_pair(seq)) ? a_proper_list_string : a_sequence_string); + len += n; + } + return(len); +} + +s7_pointer s7i_vector_append(s7_scheme *sc, s7_pointer args, uint8_t typ, s7_pointer caller) +{ + s7_pointer new_vec, p = args, pargs, vtyper = NULL; + s7_pointer *v_elements = NULL; + s7_double *fv_elements = NULL; + s7_complex *cv_elements = NULL; + s7_int *iv_elements = NULL; + uint8_t *byte_elements = NULL; + s7_int len; + bool typed; + + gc_protect_via_stack(sc, args); + len = total_sequence_length(sc, args, caller, (typ == T_VECTOR) ? T_FREE : ((typ == T_COMPLEX_VECTOR) ? T_COMPLEX : ((typ == T_FLOAT_VECTOR) ? T_REAL : T_INTEGER))); + if (len > sc->max_vector_length) + { + unstack_gc_protect(sc); + error_nr(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_integer(sc, len), + wrap_integer(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 (??) */ + typed = (typ == T_VECTOR); + set_gc_protected2(sc, new_vec); + add_vector(sc, new_vec); + if (len == 0) + { + unstack_gc_protect(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 + if (typ == T_COMPLEX_VECTOR) + cv_elements = complex_vector_complexes(new_vec); + else byte_elements = byte_vector_bytes(new_vec); - 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))); + pargs = list_2(sc, sc->F, new_vec); /* car set below */ + /* push_stack_no_let(sc, OP_GC_PROTECT, new_vec, pargs); */ + set_gc_protected3(sc, pargs); + for (s7_int i = 0; is_pair(p); p = cdr(p)) /* in-place copy by goofing (temporarily) with new_vec's elements pointer */ + { + const s7_pointer vec = car(p); + const s7_int n = sequence_length(sc, vec); + if (n > 0) + { + if ((typed) && (is_typed_t_vector(vec))) + { + if (!vtyper) + vtyper = typed_vector_typer(vec); + else + if (vtyper != typed_vector_typer(vec)) + typed = false; + } + else typed = false; + vector_length(new_vec) = n; + set_car(pargs, vec); + 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 + if (typ == T_COMPLEX_VECTOR) + complex_vector_complexes(new_vec) = (s7_complex *)(cv_elements + i); + else byte_vector_bytes(new_vec) = (uint8_t *)(byte_elements + i); + }} + /* unstack_gc_protect(sc); */ + 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 + if (typ == T_COMPLEX_VECTOR) + complex_vector_complexes(new_vec) = cv_elements; + else byte_vector_bytes(new_vec) = byte_elements; + vector_length(new_vec) = len; + if ((typed) && (vtyper)) + { + set_typed_vector(new_vec); + typed_vector_set_typer(new_vec, vtyper); + } + unstack_gc_protect(sc); + return(new_vec); } -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 hash_table_append(s7_scheme *sc, s7_pointer args) +{ + s7_pointer new_table, key_typer = NULL, value_typer = NULL; + bool typed = true; + gc_protect_via_stack(sc, args); + check_stack_size(sc); + new_table = s7_make_hash_table(sc, sc->default_hash_table_length); + set_gc_protected2(sc, new_table); + for (s7_pointer seqs = args; is_pair(seqs); seqs = cdr(seqs)) + { + const s7_pointer seq = car(seqs); + if (!sequence_is_empty(sc, seq)) + { + /* perhaps check seq-length+hash_table_entries(new_table) > sc->max_vector_length here? */ + s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, seq, new_table)); + if ((typed) && (is_hash_table(seq)) && (is_typed_hash_table(seq))) + { + if (!key_typer) + { /* the equality/mapping procedures are either partly implicit or in hash-table-procedures -- a bit of a mess currently */ + key_typer = hash_table_key_typer(seq); + value_typer = hash_table_value_typer(seq); + } + else + if ((hash_table_key_typer(seq) != key_typer) || + (hash_table_value_typer(seq) != value_typer)) + typed = false; + } + else typed = false; + }} + if ((typed) && (key_typer)) + { + hash_table_set_procedures(new_table, make_hash_table_procedures(sc)); + set_is_typed_hash_table(new_table); + hash_table_set_key_typer(new_table, key_typer); + hash_table_set_value_typer(new_table, value_typer); + } + if (is_weak_hash_table(car(args))) /* 16-May-23, args gc protected above, should we limit weak-hash result to pure weak-hash args? */ + { + set_weak_hash_table(new_table); + weak_hash_iters(new_table) = 0; + } + set_plist_2(sc, sc->nil, sc->nil); + unstack_gc_protect(sc); + return(new_table); } -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 let_append(s7_scheme *sc, s7_pointer args) +{ + s7_pointer new_let; + const s7_pointer let = car(args); + if_let_method_exists_return_value(sc, let, sc->append_symbol, args); + gc_protect_via_stack(sc, args); + new_let = make_let(sc, sc->rootlet); + set_gc_protected2(sc, new_let); + for (s7_pointer seqs = args; is_pair(seqs); seqs = cdr(seqs)) + if (!sequence_is_empty(sc, car(seqs))) + s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, car(seqs), new_let)); + set_plist_2(sc, sc->nil, sc->nil); + unstack_gc_protect(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: return(g_list_append(sc, cdr(args))); + case T_PAIR: return(g_list_append(sc, args)); + case T_STRING: return(s7i_string_append_1(sc, args, sc->append_symbol)); + /* should this work in the generic append: (append "12" #\3) -- currently an error, (append (list 1 2) 3) -> '(1 2 . 3), but vector is error */ + 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: case T_COMPLEX_VECTOR: + return(s7i_vector_append(sc, args, type(car(args)), sc->append_symbol)); + case T_C_OBJECT: if_c_object_method_exists_return_value(sc, car(args), sc->append_symbol, args); break; + default: if_method_exists_return_value(sc, car(args), sc->append_symbol, args); + } + wrong_type_error_nr(sc, sc->append_symbol, 1, car(args), a_sequence_string); /* (append 1 0) */ + return(NULL); } -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 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; + if ((!is_pair(b)) && (!is_null(b))) + return(g_list_append(sc, list_2(sc, a, b))); + sc->temp9 = a; /* tempx? */ + sc->temp7 = b; /* GC protect b across the copy loop below (it is not otherwise protected here) */ + q = list_1(sc, car(a)); + begin_temp(sc->temp6, q); + p = cdr(a); + np = q; + for (s7_pointer op = a; (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))); + } + end_temp(sc->temp6); + sc->temp7 = sc->unused; + if (!is_null(p)) + wrong_type_error_nr(sc, sc->append_symbol, 1, a, a_proper_list_string); + sc->temp9 = sc->unused; + set_cdr(np, b); + return(q); + } + if (is_null(a)) return(b); + return(g_append(sc, set_plist_2(sc, a, b))); } -static inline s7_pointer -fx_and_2a (s7_scheme* sc, s7_pointer arg) /* arg is the full expr: (and ...) */ + +static s7_pointer append_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr) { - return ((fx_call (sc, cdr (arg)) == sc->F) ? sc->F - : fx_call (sc, cddr (arg))); + if (args == 2) return(sc->append_2); + return(func); } -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)); + +/* -------------------------------- object->let -------------------------------- */ +static s7_pointer byte_vector_to_list(s7_scheme *sc, const uint8_t *str, s7_int len) +{ + if (len == 0) return(sc->nil); + check_free_heap_size(sc, len); + begin_temp(sc->y, sc->nil); + for (s7_int i = len - 1; i >= 0; i--) + sc->y = cons_unchecked(sc, small_int((uint32_t)(str[i])), sc->y); + return_with_end_temp(sc->y); } -static s7_pointer -fx_len2_t (s7_scheme* sc, s7_pointer arg) { - s7_pointer 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 hash_table_to_list(s7_scheme *sc, s7_pointer obj) +{ + s7_pointer iterator; + if (hash_table_entries(obj) == 0) return(sc->nil); + iterator = s7_make_iterator(sc, obj); + gc_protect_via_stack(sc, iterator); + begin_temp(sc->y, sc->nil); + while (true) + { + s7_pointer entry = s7_iterate(sc, iterator); + if (iterator_is_at_end(iterator)) break; + sc->y = cons(sc, entry, sc->y); + } + unstack_gc_protect(sc); + return_with_end_temp(sc->y); } -static s7_pointer -fx_len3_t (s7_scheme* sc, s7_pointer arg) { - s7_pointer 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 iterator_to_list(s7_scheme *sc, s7_pointer obj) +{ + s7_pointer result = sc->nil, p = NULL; + s7_int results = 0; + while (true) + { + const s7_pointer val = s7_iterate(sc, obj); + if ((val == sc->iterator_at_end_value) && + (iterator_is_at_end(obj))) + { + if (is_pair(result)) unstack_gc_protect(sc); + 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; + } + gc_protect_via_stack(sc, result); /* unstacked above */ + } + 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 */ +{ + s7_int len; + s7_pointer obj_len, lst, lst2, ref_index, result; + s7_int gc_lst2; + + if (c_object_to_list(sc, obj)) + return((*(c_object_to_list(sc, obj)))(sc, set_plist_1(sc, obj))); + + obj_len = c_object_length(sc, obj); + if (!s7_is_integer(obj_len)) return(sc->F); + len = s7_integer_clamped_if_gmp(sc, obj_len); + if (len < 0) return(sc->F); + if (len == 0) return(sc->nil); + + result = make_list(sc, len, sc->nil); + sc->temp7 = result; + ref_index = wrap_mutable_integer(sc, 0); /* was make_mutable_integer 17-Nov-23 */ + lst2 = list_2_unchecked(sc, obj, ref_index); + gc_lst2 = gc_protect_1(sc, lst2); + lst = result; + for (s7_int i = 0; i < len; i++, lst = cdr(lst)) + { + set_integer(ref_index, i); + set_car(lst, (*(c_object_ref(sc, obj)))(sc, lst2)); + } + s7_gc_unprotect_at(sc, gc_lst2); + sc->temp7 = sc->unused; + return(result); } -static s7_pointer -fx_and_3a (s7_scheme* sc, s7_pointer arg) { - s7_pointer p= cdr (arg); - if (fx_call (sc, p) == sc->F) return (sc->F); - p= cdr (p); - return ((fx_call (sc, p) == sc->F) ? sc->F : fx_call (sc, cdr (p))); +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: case T_COMPLEX_VECTOR: + return(s7_vector_to_list(sc, obj)); + case T_LET: +#if !WITH_PURE_S7 + if_let_method_exists_return_value(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 -fx_and_n (s7_scheme* sc, s7_pointer arg) { - s7_pointer val= sc->T; - for (s7_pointer p= cdr (arg); (is_pair (p)) && (val != sc->F); - p = cdr (p)) /* in lg, 5/6 args appears to predominate */ - val= fx_call (sc, p); - return (val); + +/* ---------------- object->let ---------------- */ +static s7_pointer symbol_to_let(s7_scheme *sc, s7_pointer sym) +{ + const s7_pointer let = internal_inlet(sc, 4, sc->value_symbol, sym, + sc->type_symbol, (is_keyword(sym)) ? sc->is_keyword_symbol : + ((is_gensym(sym)) ? sc->is_gensym_symbol : sc->is_symbol_symbol)); + if (!is_keyword(sym)) + { + const s7_int gc_loc = gc_protect_1(sc, let); + const s7_pointer val = s7_symbol_value(sc, sym); + if (!sc->current_value_symbol) + sc->current_value_symbol = make_symbol(sc, "current-value", 13); + s7_varlet(sc, let, sc->current_value_symbol, val); + s7_varlet(sc, let, sc->setter_symbol, setter_p_pp(sc, sym, sc->curlet)); + s7_varlet(sc, let, sc->is_mutable_symbol, make_boolean(sc, !is_immutable_symbol(sym))); + if (!is_undefined(val)) + { + const char *doc = s7_documentation(sc, sym); + 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 -fx_or_2a (s7_scheme* sc, s7_pointer arg) { - s7_pointer p = cdr (arg); - s7_pointer val= fx_call (sc, p); - return ((val != sc->F) ? val : fx_call (sc, cdr (p))); +static s7_pointer random_state_to_let(s7_scheme *sc, s7_pointer rs) +{ + if (!sc->seed_symbol) + { + sc->seed_symbol = make_symbol(sc, "seed", 4); + sc->carry_symbol = make_symbol(sc, "carry", 5); + } + return(internal_inlet(sc, 8, sc->value_symbol, rs, + sc->type_symbol, sc->is_random_state_symbol, + sc->seed_symbol, make_integer(sc, random_seed(rs)), + sc->carry_symbol, make_integer(sc, random_carry(rs)))); } -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 val= fn_proc (cadr (arg)) ( - sc, - with_list_t1 (sc, lookup (sc, opt3_sym (cdr (arg))))); /* cadadr(arg) */ - return ((val != sc->F) ? val : fn_proc (caddr (arg)) (sc, sc->t1_1)); -} - -static s7_pointer -fx_or_s_type_2 (s7_scheme* sc, s7_pointer arg) { - int32_t val= type (lookup (sc, opt3_sym (cdr (arg)))); /* cadadr(arg)) */ - return (make_boolean (sc, (val == opt3_int (arg)) || - (val == opt2_int (cdr (arg))))); -} - -static s7_pointer -fx_not_symbol_or_keyword (s7_scheme* sc, s7_pointer arg) { - s7_pointer 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); - s7_pointer 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); - s7_pointer 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); - s7_pointer 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 val= sc->F; - for (s7_pointer p= cdr (arg); (is_pair (p)) && (val == sc->F); p= cdr (p)) - val= fx_call (sc, p); - return (val); -} - -static s7_pointer -fx_begin_aa (s7_scheme* sc, s7_pointer arg) { - fx_call (sc, cdr (arg)); - return (fx_call (sc, cddr (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) { - const s7_pointer func= opt1_lambda (code); - s7_pointer result; - gc_protect_via_stack (sc, sc->curlet); /* we do need to GC protect curlet here - and below (not just remember it) */ - set_curlet (sc, closure_let (func)); - result= fx_call (sc, closure_body (func)); - set_curlet (sc, gc_protected1 (sc)); - unstack_gc_protect (sc); - return (result); -} - -static s7_pointer -fx_safe_closure_s_a ( - s7_scheme* sc, - s7_pointer code) /* also called from h_safe_closure_s_a in eval */ -{ - const s7_pointer func= opt1_lambda (code); - s7_pointer result; - gc_protect_via_stack (sc, sc->curlet); - set_curlet (sc, update_let_with_slot (sc, closure_let (func), - lookup (sc, opt2_sym (code)))); - result= fx_call (sc, closure_body (func)); - set_curlet (sc, gc_protected1 (sc)); - unstack_gc_protect (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 */ -{ - const s7_pointer func= opt1_lambda (code); - set_curlet (sc, update_let_with_slot (sc, closure_let (func), - lookup (sc, opt2_sym (code)))); - return (fx_call (sc, closure_body (func))); -} - -static s7_pointer -fx_safe_closure_t_a (s7_scheme* sc, s7_pointer code) { - const s7_pointer func= opt1_lambda (code); - s7_pointer result; - gc_protect_via_stack (sc, sc->curlet); - set_curlet (sc, update_let_with_slot (sc, closure_let (func), - t_lookup (sc, opt2_sym (code), code))); - result= fx_call (sc, closure_body (func)); - set_curlet (sc, gc_protected1 (sc)); - unstack_gc_protect (sc); - return (result); -} - -static s7_pointer -fx_safe_closure_s_to_s (s7_scheme* sc, s7_pointer arg) { - return (fn_proc (car (closure_body (opt1_lambda (arg)))) ( - sc, with_list_t1 (sc, lookup (sc, opt2_sym (arg))))); -} - -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 (s7i_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= lookup (sc, opt2_sym (arg)); - if ((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= lookup (sc, opt2_sym (arg)); - if ((is_t_integer (p))) return (make_integer (sc, integer (p) + 1)); - /* better but slower: return(add_if_overflow_to_real_or_big_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) { - const s7_pointer p = cdr (arg); - const s7_pointer val= fx_proc (cdar (p)) (sc, car (p)); - sc->value = val; - set_car (sc->t2_2, fx_proc (cdadr (p)) (sc, cadr (p))); - set_car (sc->t2_1, val); - return (fn_proc (arg) (sc, sc->t2_1)); -} - -static s7_pointer -fx_safe_closure_a_to_sc (s7_scheme* sc, s7_pointer arg) { - const s7_pointer func= opt1_lambda (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 (func))) (sc, sc->t2_1)); -} - -static s7_pointer -fx_safe_closure_a_to_vref (s7_scheme* sc, s7_pointer arg) { - return ( - s7i_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 */ -{ - const s7_pointer func= opt1_lambda (code); - s7_pointer result; - gc_protect_via_stack (sc, sc->curlet); - set_curlet (sc, update_let_with_slot (sc, closure_let (func), - lookup (sc, opt2_sym (code)))); - code= cdar (closure_body (func)); - 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, gc_protected1 (sc)); - unstack_gc_protect (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 */ -{ - const s7_pointer func= opt1_lambda (code); - s7_pointer result; - gc_protect_via_stack (sc, sc->curlet); - set_curlet (sc, update_let_with_slot (sc, closure_let (func), - lookup (sc, opt2_sym (code)))); - code = cdar (closure_body (func)); - result= (is_pair (t_lookup (sc, cadar (code), code))) - ? fx_call (sc, cdr (code)) - : sc->F; /* pair? arg = func par, pair? is global, symbol_id=0 */ - set_curlet (sc, gc_protected1 (sc)); - unstack_gc_protect (sc); - return (result); -} - -static s7_pointer -fx_safe_closure_a_a (s7_scheme* sc, s7_pointer code) { - const s7_pointer func= opt1_lambda (code); - s7_pointer result; - gc_protect_via_stack (sc, sc->curlet); - set_curlet (sc, update_let_with_slot (sc, closure_let (func), - fx_call (sc, cdr (code)))); - result= fx_call (sc, closure_body (func)); - set_curlet (sc, gc_protected1 (sc)); - unstack_gc_protect (sc); - return (result); -} - -static s7_pointer -op_safe_closure_a_a (s7_scheme* sc, s7_pointer code) { - const s7_pointer func= opt1_lambda (code); - set_curlet (sc, update_let_with_slot (sc, closure_let (func), - fx_call (sc, cdr (code)))); - return (fx_call (sc, closure_body (func))); -} - -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) { - const s7_pointer func = opt1_lambda (code); - const s7_pointer and_arg= cdar (closure_body (func)); - s7_pointer result; - gc_protect_via_stack (sc, sc->curlet); - set_curlet (sc, update_let_with_slot (sc, closure_let (func), - fx_call (sc, cdr (code)))); - result= fx_call (sc, and_arg); - if (result != sc->F) result= fx_call (sc, cdr (and_arg)); - set_curlet (sc, gc_protected1 (sc)); - unstack_gc_protect (sc); - return (result); -} - -static s7_pointer -fx_safe_closure_ss_a (s7_scheme* sc, s7_pointer code) { - const s7_pointer func= opt1_lambda (code); - s7_pointer result; - gc_protect_via_stack (sc, sc->curlet); - set_curlet (sc, update_let_with_two_slots (sc, closure_let (func), - lookup (sc, cadr (code)), - lookup (sc, opt2_sym (code)))); - result= fx_call (sc, closure_body (func)); - set_curlet (sc, gc_protected1 (sc)); - unstack_gc_protect (sc); - return (result); -} - -static s7_pointer -op_safe_closure_ss_a (s7_scheme* sc, s7_pointer code) { - const s7_pointer func= opt1_lambda (code); - set_curlet (sc, update_let_with_two_slots (sc, closure_let (func), - lookup (sc, cadr (code)), - lookup (sc, opt2_sym (code)))); - return (fx_call (sc, closure_body (func))); -} - -static s7_pointer -fx_safe_closure_3s_a (s7_scheme* sc, s7_pointer code) { - const s7_pointer func= opt1_lambda (code); - s7_pointer result; - gc_protect_via_stack (sc, sc->curlet); - set_curlet (sc, update_let_with_three_slots (sc, closure_let (func), - lookup (sc, cadr (code)), - lookup (sc, opt2_sym (code)), - lookup (sc, opt3_sym (code)))); - result= fx_call (sc, closure_body (func)); - set_curlet (sc, gc_protected1 (sc)); - unstack_gc_protect (sc); - return (result); -} - -static s7_pointer -op_safe_closure_3s_a (s7_scheme* sc, s7_pointer code) { - const s7_pointer func= opt1_lambda (code); - set_curlet (sc, update_let_with_three_slots (sc, closure_let (func), - lookup (sc, cadr (code)), - lookup (sc, opt2_sym (code)), - lookup (sc, opt3_sym (code)))); - return (fx_call (sc, closure_body (func))); -} - -static s7_pointer -fx_safe_closure_aa_a (s7_scheme* sc, s7_pointer code) { - s7_pointer p = cdr (code); - const s7_pointer func= opt1_lambda (code); - check_stack_size (sc); /* lint+s7test.scm can overflow here */ - 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 */ - set_curlet (sc, - update_let_with_two_slots (sc, closure_let (func), - fx_call (sc, p), gc_protected2 (sc))); - p= fx_call (sc, closure_body (func)); - set_curlet (sc, gc_protected1 (sc)); - unstack_gc_protect (sc); - return (p); -} - -static inline s7_pointer -fx_cond_na_na (s7_scheme* sc, - s7_pointer code) /* all tests are fxable, results are all fx, no - =>, no missing results */ -{ - for (s7_pointer 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 -fx_implicit_starlet_ref_s (s7_scheme* sc, s7_pointer arg) { - return (starlet (sc, opt3_int (arg))); -} -static s7_pointer -fx_implicit_starlet_print_length (s7_scheme* sc, s7_pointer arg) { - return (make_integer (sc, sc->print_length)); -} -static s7_pointer -fx_implicit_starlet_safety (s7_scheme* sc, s7_pointer arg) { - return (make_integer (sc, sc->safety)); -} - -static s7_function* fx_function= NULL; - -static bool -is_fxable (s7_scheme* sc, s7_pointer expr) { - if (!is_pair (expr)) return (true); - if ((is_optimized ( - expr)) && /* this is needed. In check_tc, for example, is_fxable can - be confused by early optimize_op */ - (fx_function[optimize_op (expr)])) - return (true); - return (is_proper_quote (sc, expr)); -} - -static int32_t -fx_count (s7_scheme* sc, s7_pointer expr) { - int32_t count= 0; - for (s7_pointer p= cdr (expr); 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)) ? (is_quote (sc, car (p))) : (!is_normal_symbol (p))); -} - -static inline s7_pointer check_quote (s7_scheme* sc, s7_pointer code); - -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_defined_global (P)) && \ - (is_eq_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 s7_pointer vector_to_let(s7_scheme *sc, s7_pointer vec) +{ + s7_pointer let; + if (!sc->dimensions_symbol) sc->dimensions_symbol = make_symbol(sc, "dimensions", 10); + if (!sc->original_vector_symbol) sc->original_vector_symbol = make_symbol(sc, "original-vector", 15); + let = internal_inlet(sc, 10, sc->value_symbol, vec, + sc->type_symbol, (is_subvector(vec)) ? cons(sc, sc->is_subvector_symbol, s7_type_of(sc, subvector_vector(vec))) : s7_type_of(sc, vec), + sc->size_symbol, s7_length(sc, vec), + sc->dimensions_symbol, g_vector_dimensions(sc, set_plist_1(sc, vec)), + sc->is_mutable_symbol, make_boolean(sc, !is_immutable_vector(vec))); + gc_protect_via_stack(sc, let); + if (is_subvector(vec)) + { + s7_int pos = 0; + switch (type(vec)) /* 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(vec) - vector_elements(subvector_vector(vec)))); break; + case T_INT_VECTOR: pos = (s7_int)((intptr_t)(int_vector_ints(vec) - int_vector_ints(subvector_vector(vec)))); break; + case T_FLOAT_VECTOR: pos = (s7_int)((intptr_t)(float_vector_floats(vec) - float_vector_floats(subvector_vector(vec)))); break; + case T_COMPLEX_VECTOR: pos = (s7_int)((intptr_t)(complex_vector_complexes(vec) - complex_vector_complexes(subvector_vector(vec)))); break; + case T_BYTE_VECTOR: pos = (s7_int)((intptr_t)(byte_vector_bytes(vec) - byte_vector_bytes(subvector_vector(vec)))); break; + } + s7_varlet(sc, let, sc->position_symbol, make_integer(sc, pos)); + s7_varlet(sc, let, sc->original_vector_symbol, subvector_vector(vec)); + } + if (is_typed_t_vector(vec)) + s7_varlet(sc, let, sc->signature_symbol, g_signature(sc, set_plist_1(sc, vec))); + +#if S7_DEBUGGING + if ((is_t_vector(vec)) && (is_symbol_table(vec))) /* (object->let (symbol-table)) */ + { + s7_int max_len = 0, zeros = 0, ones = 0, twos = 0, biggies = 0; + for (s7_int i = 0; i < SYMBOL_TABLE_SIZE; i++) + { + s7_int entries; + s7_pointer syms = vector_element(sc->symbol_table, i); + for (entries = 0; is_pair(syms); syms = cdr(syms), entries++); + if (entries == 0) zeros++; else + if (entries == 1) ones++; else + if (entries == 2) twos++; else + biggies++; + if (entries > max_len) max_len = entries; + } + s7_varlet(sc, let, make_symbol(sc, "symtab-stats:empty|1|2|n|most", 29), /* "symtab-stats" to distinguish from hash-stats below */ + cons(sc, make_integer(sc, zeros), + cons(sc, make_integer(sc, ones), + cons(sc, make_integer(sc, twos), + cons(sc, make_integer(sc, biggies), + cons(sc, make_integer(sc, max_len), sc->nil)))))); + } +#endif -static bool -fx_matches (s7_pointer symbol, const s7_pointer target_symbol) { - return ((symbol == target_symbol) && (is_unchanged_global (symbol))); + unstack_gc_protect(sc); + return(let); } -typedef bool (safe_sym_t) (s7_scheme* sc, s7_pointer sym, s7_pointer var_list); - -/* #define fx_choose(Sc, Holder, Var_List, Checker) fx_choose_1(Sc, Holder, - * Var_List, Checker, __func__, __LINE__) */ -static s7_function -fx_choose (s7_scheme* sc, const s7_pointer holder, const s7_pointer var_list, - safe_sym_t* checker) /* , const char *func, int32_t line) */ +static void hash_table_checker_to_let(s7_scheme *sc, s7_pointer let, s7_pointer table) +{ + if ((hash_table_checker(table) == hash_eq) || + (hash_table_checker(table) == hash_c_function) || + (hash_table_checker(table) == hash_closure) || + (hash_table_checker(table) == hash_equal_eq) || + (hash_table_checker(table) == hash_equal_syntax) || + (hash_table_checker(table) == hash_symbol)) + s7_varlet(sc, let, sc->function_symbol, sc->is_eq_symbol); + else + if (hash_table_checker(table) == hash_eqv) + s7_varlet(sc, let, sc->function_symbol, sc->is_eqv_symbol); + else + if ((hash_table_checker(table) == hash_equal) || + (hash_table_checker(table) == hash_empty)) + s7_varlet(sc, let, sc->function_symbol, sc->is_equal_symbol); + else + if (hash_table_checker(table) == hash_equivalent) + s7_varlet(sc, let, sc->function_symbol, sc->is_equivalent_symbol); + else + if ((hash_table_checker(table) == hash_number_num_eq) || + (hash_table_checker(table) == hash_int) || + (hash_table_checker(table) == hash_float)) + s7_varlet(sc, let, sc->function_symbol, sc->num_eq_symbol); + else + if (hash_table_checker(table) == hash_string) + s7_varlet(sc, let, sc->function_symbol, sc->string_eq_symbol); + else + if (hash_table_checker(table) == hash_char) + s7_varlet(sc, let, sc->function_symbol, sc->char_eq_symbol); +} + +static s7_pointer hash_table_to_let(s7_scheme *sc, s7_pointer table) { - const s7_pointer arg= car (holder); + s7_pointer let; + s7_int gc_loc; + if (!sc->entries_symbol) + { + sc->entries_symbol = make_symbol(sc, "entries", 7); + sc->weak_symbol = make_symbol(sc, "weak", 4); + } + let = internal_inlet(sc, 10, sc->value_symbol, table, + sc->type_symbol, sc->is_hash_table_symbol, + sc->size_symbol, s7_length(sc, table), + sc->entries_symbol, make_integer(sc, hash_table_entries(table)), + sc->is_mutable_symbol, make_boolean(sc, !is_immutable_hash_table(table))); + gc_loc = gc_protect_1(sc, let); + if (is_weak_hash_table(table)) + s7_varlet(sc, let, sc->weak_symbol, sc->T); + + if (is_typed_hash_table(table)) + { + const s7_pointer checker = hash_table_procedures_checker(table); + if (checker == sc->T) /* perhaps typed because typers were set, but not checker/mapper */ + hash_table_checker_to_let(sc, let, table); + else s7_varlet(sc, let, sc->function_symbol, list_2(sc, checker, hash_table_procedures_mapper(table))); + s7_varlet(sc, let, sc->signature_symbol, + (is_typed_hash_table(table)) ? + list_3(sc, + hash_table_typer_symbol(sc, hash_table_value_typer(table)), + sc->is_hash_table_symbol, + hash_table_typer_symbol(sc, hash_table_key_typer(table))) : + sc->hash_table_signature); + } + else hash_table_checker_to_let(sc, let, table); + #if S7_DEBUGGING - if ((!is_let (var_list)) && (!is_list (var_list))) - fprintf (stderr, "%s[%d]: var_list: %s\n", __func__, __LINE__, - display (var_list)); + if (hash_table_entries(table) > 0) + { + s7_int max_len = 0, zeros = 0, ones = 0, twos = 0, biggies = 0; + const s7_int hash_len = (s7_int)hash_table_size(table); + for (s7_int i = 0; i < hash_len; i++) + { + hash_entry_t *entry = hash_table_element(table, i); + s7_int entries; + for (entries = 0; entry; entry = hash_entry_next(entry), entries++); + if (entries == 0) zeros++; else + if (entries == 1) ones++; else + if (entries == 2) twos++; else + biggies++; + if (entries > max_len) max_len = entries; + } + s7_varlet(sc, let, make_symbol(sc, "hash-stats:empty|1|2|n|most", 27), + cons(sc, make_integer(sc, zeros), + cons(sc, make_integer(sc, ones), + cons(sc, make_integer(sc, twos), + cons(sc, make_integer(sc, biggies), + cons(sc, make_integer(sc, max_len), sc->nil)))))); + } #endif - if (!is_pair (arg)) { - if (is_symbol (arg)) { - if (is_keyword (arg)) return (fx_c); - if ((arg == sc->else_symbol) && (is_global (sc->else_symbol))) { - if (is_let (var_list)) { - if (s7_symbol_local_value (sc, arg, var_list) == sc->else_symbol) - return (fx_c); - } - else if ((is_pair (var_list)) && (!direct_memq (arg, var_list))) - return (fx_c); /* is_pair -> not () */ - } - return ((is_defined_global (arg)) - ? fx_g - : ((checker (sc, arg, var_list)) ? fx_s : fx_unsafe_s)); + s7_gc_unprotect_at(sc, gc_loc); + return(let); +} + +static s7_pointer iterator_to_let(s7_scheme *sc, s7_pointer iter) +{ + s7_pointer let; + const s7_pointer seq = iterator_sequence(iter); + if (!sc->at_end_symbol) + { + sc->at_end_symbol = make_symbol(sc, "at-end", 6); + sc->sequence_symbol = make_symbol(sc, "sequence", 8); + } + let = internal_inlet(sc, 8, sc->value_symbol, iter, + sc->type_symbol, sc->is_iterator_symbol, + sc->at_end_symbol, make_boolean(sc, iterator_is_at_end(iter)), + sc->sequence_symbol, iterator_sequence(iter)); + gc_protect_via_stack(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, iter)); + 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(iter))); + else + if (is_pair(seq)) + s7_varlet(sc, let, sc->position_symbol, iterator_current(iter)); + unstack_gc_protect(sc); + return(let); +} + +static s7_pointer let_to_let(s7_scheme *sc, s7_pointer let) +{ + /* 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 new_let; + s7_int gc_loc; + if (!sc->open_symbol) + { + sc->open_symbol = make_symbol(sc, "open", 4); + sc->alias_symbol = make_symbol(sc, "alias", 5); + } + new_let = internal_inlet(sc, 12, sc->value_symbol, let, + sc->type_symbol, sc->is_let_symbol, + sc->size_symbol, s7_length(sc, let), + sc->open_symbol, make_boolean(sc, is_openlet(let)), + sc->outlet_symbol, (let == sc->rootlet) ? sc->nil : let_outlet(let), + sc->is_mutable_symbol, make_boolean(sc, !is_immutable_let(let))); + gc_loc = gc_protect_1(sc, new_let); + if (let == sc->rootlet) + s7_varlet(sc, new_let, sc->alias_symbol, sc->rootlet_symbol); + else /* owlet can't happen, I think -- it is always copied first */ + if (is_funclet(let)) + { + s7_varlet(sc, new_let, sc->function_symbol, funclet_function(let)); + if ((has_let_file(let)) && + (let_file(let) <= (s7_int)sc->file_names_top) && + (let_line(let) > 0) && + (let_line(let) < 1000000)) + { + s7_varlet(sc, new_let, sc->file_symbol, sc->file_names[let_file(let)]); + s7_varlet(sc, new_let, sc->line_symbol, make_integer(sc, let_line(let))); + }} + else + if (let == sc->starlet) + { + const s7_pointer iter = s7_make_iterator(sc, let); + const s7_int gc_loc1 = gc_protect_1(sc, iter); + while (true) + { + s7_pointer starlet_field = s7_iterate(sc, iter); + if (iterator_is_at_end(iter)) break; + s7_varlet(sc, new_let, car(starlet_field), cdr(starlet_field)); + } + s7_gc_unprotect_at(sc, gc_loc1); + } + if (has_active_methods(sc, let)) + { + s7_pointer func = find_method(sc, let, sc->object_to_let_symbol); + if (func != sc->undefined) + s7_apply_function(sc, func, set_plist_2(sc, let, new_let)); } - return (fx_c); - } - if (is_optimized (arg)) { - const s7_pointer head= car (arg); - switch (optimize_op (arg)) { - case HOP_SAFE_C_NC: /* includes 0-arg cases, - newline/current-input|output-port, - [make-]hash-table?, read-line, [float-]vector/list, - gensym */ - if (cdr (arg) == sc->nil) - return ((fn_proc (arg) == g_read_char) ? fx_read_char_0 : fx_c_0c); - if (fn_proc (arg) == g_add_i_random) return (fx_add_i_random); - if (fn_proc (arg) == g_cons) { - set_opt1_con (cdr (arg), caddr (arg)); - return (fx_cons_cc); - } - return ((fn_proc (arg) == g_random_i) ? fx_random_i : fx_c_nc); + s7_gc_unprotect_at(sc, gc_loc); + return(new_let); +} - case OP_OR_2A: { - const s7_pointer arg2p= cddr (arg); - if (fx_proc (arg2p) == fx_and_2a) { - set_opt3_pair (arg, cdar (arg2p)); - return (fx_or_and_2a); - } - if (fx_proc (arg2p) == fx_and_3a) { - set_opt3_pair (arg, cdar (arg2p)); - return (fx_or_and_3a); - } - if ((fx_proc (arg2p) == fx_not_is_symbol_s) && - (fx_proc (arg2p) == fx_is_keyword_s) && - (cadr (cadadr (arg)) == cadar (arg2p))) { - /* (or (not (symbol? body)) (keyword? body)) */ - set_opt3_sym (arg, cadar (arg2p)); - return (fx_not_symbol_or_keyword); - } - return (fx_or_2a); +static s7_pointer c_object_to_let(s7_scheme *sc, s7_pointer cobj) +{ + s7_pointer let; + const s7_pointer clet = c_object_let(cobj); + if (!sc->class_symbol) + sc->class_symbol = make_symbol(sc, "class", 5); + let = internal_inlet(sc, 8, sc->value_symbol, cobj, + sc->type_symbol, sc->is_c_object_symbol, + sc->c_object_type_symbol, make_integer(sc, c_object_type(cobj)), + sc->c_object_let_symbol, clet); + gc_protect_via_stack(sc, let); + g_varlet(sc, set_plist_3(sc, let, sc->class_symbol, c_object_type_to_let(sc, cobj))); + if ((is_let(clet)) && + ((has_active_methods(sc, clet)) || (has_active_methods(sc, cobj)))) + { + s7_pointer func = find_method(sc, clet, sc->object_to_let_symbol); + if (func != sc->undefined) + s7_apply_function(sc, func, set_plist_2(sc, cobj, let)); } + unstack_gc_protect(sc); + return(let); +} - case HOP_SAFE_C_S: - if (is_unchanged_global ( - head)) /* mus-copy would work here but in tgen (for example) it's - loading generators.scm with local mus-copy methods */ +static s7_pointer port_to_let(s7_scheme *sc, s7_pointer port) /* note the underbars! */ +{ + s7_pointer let; + s7_int gc_loc; + if (!sc->data_symbol) + { + sc->data_symbol = make_symbol(sc, "data", 4); + sc->port_type_symbol = make_symbol(sc, "port-type", 9); + sc->closed_symbol = make_symbol(sc, "closed", 6); + sc->file_info_symbol = make_symbol(sc, "file-info", 9); + } + let = internal_inlet(sc, 10, sc->value_symbol, port, + /* port as 'value means it will say "(closed)" when subsequently the let is displayed */ + sc->type_symbol, (is_input_port(port)) ? sc->is_input_port_symbol : sc->is_output_port_symbol, + sc->port_type_symbol, (is_string_port(port)) ? sc->string_symbol : ((is_file_port(port)) ? sc->file_symbol : sc->function_symbol), + sc->closed_symbol, make_boolean(sc, port_is_closed(port)), + sc->is_mutable_symbol, make_boolean(sc, !is_immutable_port(port))); + gc_loc = gc_protect_1(sc, let); + if (is_file_port(port)) + { + s7_varlet(sc, let, sc->file_symbol, g_port_filename(sc, set_plist_1(sc, port))); + if (is_input_port(port)) + s7_varlet(sc, let, sc->line_symbol, g_port_line_number(sc, set_plist_1(sc, port))); +#if !MS_WINDOWS + if ((!port_is_closed(port)) && (port != sc->standard_error) && (port != sc->standard_input) && (port != sc->standard_output)) + { + struct stat sb; + s7_varlet(sc, let, sc->file_symbol, make_integer(sc, fileno(port_file(port)))); + if (fstat(fileno(port_file(port)), &sb) != -1) + { + char c1[64], c2[64], str[512]; + int32_t 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%u, 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(port)) && /* file port might not have a data buffer */ + (port_data(port)) && + (port_data_size(port) > 0)) + { + s7_int pos = port_position(port), size = port_data_size(port); + s7_varlet(sc, let, sc->size_symbol, make_integer(sc, size)); + s7_varlet(sc, let, sc->position_symbol, make_integer(sc, pos)); + /* 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. + * This field is confusing; perhaps show a window around the current data position? + */ { - uint8_t typ; - if (head == sc->cdr_symbol) return (fx_cdr_s); - if (head == sc->car_symbol) return (fx_car_s); - if (head == sc->cadr_symbol) return (fx_cadr_s); - if (head == sc->cddr_symbol) return (fx_cddr_s); - if (head == sc->is_null_symbol) return (fx_is_null_s); - if (head == sc->is_pair_symbol) return (fx_is_pair_s); - if (head == sc->is_symbol_symbol) return (fx_is_symbol_s); - if (head == sc->is_eof_object_symbol) return (fx_is_eof_s); - if (head == sc->is_integer_symbol) return (fx_is_integer_s); - if (head == sc->is_string_symbol) return (fx_is_string_s); - if (head == sc->not_symbol) return (fx_not_s); - if (head == sc->is_proper_list_symbol) return (fx_is_proper_list_s); - if (head == sc->is_vector_symbol) return (fx_is_vector_s); - if (head == sc->is_keyword_symbol) return (fx_is_keyword_s); - if (head == sc->is_procedure_symbol) return (fx_is_procedure_s); - if (head == sc->length_symbol) return (fx_length_s); - /* not read_char here... */ - typ= symbol_type (head); - 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 (is_global (c_function_name_to_symbol (sc, global_value (head)))) { - s7_p_p_t func= s7_p_p_function (global_value (head)); - if (func) { - set_opt2_direct (cdr (arg), func); - if (func == real_part_p_p) return (fx_real_part_s); - if (func == imag_part_p_p) return (fx_imag_part_s); - if (func == iterate_p_p) return (fx_iterate_s); - if (func == car_p_p) - return (fx_car_s); /* can happen if (define var-name car) etc */ - return ((is_defined_global (cadr (arg))) ? fx_c_g_direct - : fx_c_s_direct); - } - } - } - return ((is_defined_global (cadr (arg))) ? fx_c_g : fx_c_s); - - case HOP_SAFE_C_SS: { - s7_function func= fn_proc (arg); - if (func == g_cons) return (fx_cons_ss); - if (fx_matches (head, sc->num_eq_symbol)) return (fx_num_eq_ss); - if (func == g_geq_2) return (fx_geq_ss); - if (func == g_greater_2) return (fx_gt_ss); - if (func == g_leq_2) return (fx_leq_ss); - if (func == g_less_2) - return ((is_defined_global (caddr (arg))) ? fx_lt_sg : fx_lt_ss); - if ((fx_matches (head, sc->multiply_symbol)) && - (cadr (arg) == caddr (arg))) - return (fx_sqr_s); - if (func == g_is_eq) return (fx_is_eq_ss); - if (func == g_multiply_2) return (fx_multiply_ss); - if (func == g_add_2) return (fx_add_ss); - if (func == g_subtract_2) return (fx_subtract_ss); - if (func == g_hash_table_ref_2) return (fx_hash_table_ref_ss); - - if (is_global_and_has_func (head, s7_p_pp_function)) { - if (head == sc->assq_symbol) return (fx_assq_ss); - if (head == sc->memq_symbol) return (fx_memq_ss); - if (head == sc->vector_ref_symbol) return (fx_vref_ss); - if (head == sc->string_ref_symbol) return (fx_sref_ss); - set_opt3_direct (cdr (arg), s7_p_pp_function (global_value (head))); - return (fx_c_ss_direct); - } + const char *data = (const char *)port_data(port); + char data_str[24], str[24]; + int32_t i, bytes, lim = (size > 16) ? 16 : size; + for (i = 0; i < lim; i++) data_str[i] = data[i]; + data_str[i] = '\0'; + bytes = snprintf(str, 24, "%s%s", data_str, (size > 16) ? "..." : ""); + s7_varlet(sc, let, sc->data_symbol, make_string_with_length(sc, str, bytes)); + }} + if (is_function_port(port)) + s7_varlet(sc, let, sc->function_symbol, port_string_or_function(port)); + s7_gc_unprotect_at(sc, gc_loc); + return(let); +} + +static s7_pointer closure_to_let(s7_scheme *sc, s7_pointer func) +{ + const char *doc = s7_documentation(sc, func); + const s7_pointer sig = s7_signature(sc, func); + const s7_pointer let = internal_inlet(sc, 8, sc->value_symbol, func, + sc->type_symbol, (is_t_procedure(func)) ? sc->is_procedure_symbol : sc->is_macro_symbol, + sc->arity_symbol, s7_arity(sc, func), + sc->is_mutable_symbol, make_boolean(sc, !is_immutable(func))); + gc_protect_via_stack(sc, let); + if (is_pair(sig)) + s7_varlet(sc, let, sc->local_signature_symbol, sig); + if (doc) + s7_varlet(sc, let, sc->local_documentation_symbol, s7_make_string(sc, doc)); + if (is_let(closure_let(func))) + { + s7_pointer flet = closure_let(func); + 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_or_map_list(func) != sc->F) + s7_varlet(sc, let, sc->local_setter_symbol, closure_setter_or_map_list(func)); + + if (!sc->source_symbol) + sc->source_symbol = make_symbol(sc, "source", 6); + s7_varlet(sc, let, sc->source_symbol, + append_in_place(sc, list_2(sc, procedure_type_to_symbol(sc, type(func)), closure_pars(func)), + closure_body(func))); + unstack_gc_protect(sc); + return(let); +} + +static s7_pointer c_pointer_to_let(s7_scheme *sc, s7_pointer cptr) +{ + /* 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", 6); + sc->info_symbol = make_symbol(sc, "info", 4); } - /* fx_c_ss_direct via b_7pp is slower than fx_c_ss + g_<> */ - return (fx_c_ss); + if (!sc->pointer_symbol) sc->pointer_symbol = make_symbol(sc, "pointer", 7); + return(internal_inlet(sc, 10, sc->value_symbol, cptr, + sc->type_symbol, sc->is_c_pointer_symbol, + sc->pointer_symbol, make_integer(sc, (s7_int)((intptr_t)c_pointer(cptr))), + sc->c_type_symbol, c_pointer_type(cptr), + sc->info_symbol, c_pointer_info(cptr))); +} - case HOP_SAFE_C_NS: - if (fn_proc (arg) == g_list) - return (fx_list_ns); /* it is no faster here to divide out the big list - cases!? */ - return ((fn_proc (arg) == g_vector) ? fx_vector_ns : fx_c_ns); +static s7_pointer c_function_to_let(s7_scheme *sc, s7_pointer cfunc) +{ + const char *doc = s7_documentation(sc, cfunc); + const s7_pointer sig = c_function_signature(cfunc); + const s7_pointer let = internal_inlet(sc, 8, sc->value_symbol, cfunc, + sc->type_symbol, (is_t_procedure(cfunc)) ? sc->is_procedure_symbol : sc->is_macro_symbol, + sc->arity_symbol, s7_arity(sc, cfunc), + sc->is_mutable_symbol, make_boolean(sc, !is_immutable(cfunc))); + gc_protect_via_stack(sc, let); + if (is_pair(sig)) + s7_varlet(sc, let, sc->local_signature_symbol, sig); + if (doc) + s7_varlet(sc, let, sc->local_documentation_symbol, s7_make_string(sc, doc)); + if (c_function_setter(cfunc) != sc->F) /* c_macro_setter is the same underlying field */ + s7_varlet(sc, let, sc->local_setter_symbol, c_function_setter(cfunc)); + unstack_gc_protect(sc); + return(let); +} - case HOP_SAFE_C_opSq_S: - if ((is_global_and_has_func (head, s7_p_pp_function)) && - (is_global_and_has_func (caadr (arg), s7_p_p_function))) { - set_opt2_direct (cdr (arg), s7_p_pp_function (global_value (head))); - set_opt3_direct (cdr (arg), - s7_p_p_function (global_value (caadr (arg)))); - return (((head == sc->cons_symbol) && (caadr (arg) == sc->car_symbol)) - ? fx_cons_car_s_s - : fx_c_opsq_s_direct); - } - return (fx_c_opsq_s); +static s7_pointer goto_to_let(s7_scheme *sc, s7_pointer go) +{ + /* 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", 6); + if (is_symbol(call_exit_name(go))) + return(internal_inlet(sc, 8, sc->value_symbol, go, sc->type_symbol, sc->is_goto_symbol, + sc->active_symbol, make_boolean(sc, call_exit_active(go)), + sc->name_symbol, call_exit_name(go))); + return(internal_inlet(sc, 6, sc->value_symbol, go, sc->type_symbol, sc->is_goto_symbol, + sc->active_symbol, make_boolean(sc, call_exit_active(go)))); +} + +static s7_pointer object_to_let_p_p(s7_scheme *sc, s7_pointer obj) +{ + switch (type(obj)) + { + case T_NIL: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_null_symbol)); + case T_UNSPECIFIED: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_unspecified_symbol)); + case T_UNDEFINED: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_undefined_symbol)); + case T_EOF: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_eof_object_symbol)); + case T_BOOLEAN: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_boolean_symbol)); + case T_CHARACTER: return(internal_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_INPUT_PORT: + case T_OUTPUT_PORT: return(port_to_let(sc, obj)); + + case T_INTEGER: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_integer_symbol)); + case T_RATIO: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_rational_symbol)); + case T_REAL: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_real_symbol)); + case T_COMPLEX: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_complex_symbol)); - case HOP_SAFE_C_SSS: - if ((fn_proc (arg) == g_less) && (is_defined_global (cadr (arg))) && - (is_defined_global (cadddr (arg)))) - return (fx_lt_gsg); - if (is_global_and_has_func (head, s7_p_ppp_function)) { - set_opt3_direct (cdr (arg), s7_p_ppp_function (global_value (head))); - return (fx_c_sss_direct); - } - return (fx_c_sss); + case T_STRING: + return(internal_inlet(sc, 8, sc->value_symbol, obj, + sc->type_symbol, sc->is_string_symbol, + sc->size_symbol, str_length(sc, obj), + sc->is_mutable_symbol, make_boolean(sc, !is_immutable_string(obj)))); + case T_PAIR: + return(internal_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(internal_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 HOP_SAFE_C_SSA: - if (is_global_and_has_func (head, s7_p_ppp_function)) { - set_opt2_direct (cdr (arg), s7_p_ppp_function (global_value (head))); - return (fx_c_ssa_direct); - } - return (fx_c_ssa); + case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_BYTE_VECTOR: case T_VECTOR: case T_COMPLEX_VECTOR: + return(vector_to_let(sc, obj)); - case HOP_SAFE_C_SCS: - if (is_global_and_has_func (head, s7_p_ppp_function)) { - set_opt3_direct (cdr (arg), s7_p_ppp_function (global_value (head))); - 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 (sc, cadr (arg))) || - (is_unquoted_pair (sc, caddr (arg))) || - (is_unquoted_pair (sc, cadddr (arg)))) - return (fx_c_aaa); - return (fx_c_3g); - - case HOP_SAFE_C_4A: - set_opt3_pair (arg, cdddr (arg)); - for (s7_pointer p= cdr (arg); is_pair (p); p= cdr (p)) - if (is_unquoted_pair (sc, car (p))) return (fx_c_4a); - return (fx_c_4g); /* fx_c_ssaa doesn't save much */ - - case HOP_SAFE_C_S_opSSq: { - const 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 (head, s7_p_pp_function)) && - (is_global_and_has_func (car (s2), s7_p_pp_function))) { - const s7_pointer arg1p= cdr (arg); - set_opt2_direct (arg1p, s7_p_pp_function (global_value (head))); - set_opt3_direct (arg1p, s7_p_pp_function (global_value (car (s2)))); - if (opt3_direct (arg1p) == (s7_pointer) add_p_pp) - set_opt3_direct (arg1p, add_p_pp_wrapped); - else if (opt3_direct (arg1p) == (s7_pointer) subtract_p_pp) - set_opt3_direct (arg1p, subtract_p_pp_wrapped); - else if (opt3_direct (arg1p) == (s7_pointer) multiply_p_pp) - set_opt3_direct (arg1p, multiply_p_pp_wrapped); - set_opt3_pair (arg, cdr (s2)); - if (car (s2) == sc->vector_ref_symbol) { - if (head == sc->geq_symbol) return (fx_geq_s_vref); /* ? */ - if (head == sc->is_eq_symbol) return (fx_is_eq_s_vref); /* ? */ - if (head == sc->hash_table_ref_symbol) - return (fx_href_s_vref); /* tbig */ - if (head == sc->let_ref_symbol) return (fx_lref_s_vref); - if ((is_defined_global (cadr (arg))) && - (is_defined_global (cadr (s2))) && - (head == sc->vector_ref_symbol)) - return (fx_vref_g_vref_gs); - } - if ((head == sc->vector_ref_symbol) && (car (s2) == sc->add_symbol)) - return (fx_vref_s_add); /* ~b */ - return (fx_c_s_opssq_direct); - } - return (fx_c_s_opssq); - } + case T_CONTINUATION: /* perhaps include the continuation-key */ + if (is_symbol(continuation_name(obj))) + return(internal_inlet(sc, 6, sc->value_symbol, obj, sc->type_symbol, sc->is_continuation_symbol, sc->name_symbol, continuation_name(obj))); + return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_continuation_symbol)); - case HOP_SAFE_C_opSSq_S: - if ((is_global_and_has_func (head, s7_p_pp_function)) && - (is_global_and_has_func (caadr (arg), s7_p_pp_function))) { - /* op_c_opgsq_t */ - const s7_pointer arg1p= cdr (arg), arg1= cadr (arg); - set_opt2_direct (arg1p, s7_p_pp_function (global_value (head))); - set_opt3_direct (arg1p, s7_p_pp_function (global_value (caar (arg1p)))); - if (opt3_direct (arg1p) == (s7_pointer) add_p_pp) - set_opt3_direct (arg1p, add_p_pp_wrapped); - else if (opt3_direct (arg1p) == (s7_pointer) subtract_p_pp) - set_opt3_direct (arg1p, subtract_p_pp_wrapped); - else if (opt3_direct (arg1p) == (s7_pointer) multiply_p_pp) - set_opt3_direct (arg1p, multiply_p_pp_wrapped); - set_opt3_pair (arg, cdar (arg1p)); - if (car (arg1) == sc->vector_ref_symbol) { - if (head == sc->gt_symbol) return (fx_gt_vref_s); /* ? */ - if (head == sc->vector_ref_symbol) return (fx_vref_vref_ss_s); /* b */ - } - if (head == sc->add_symbol) { - if ((car (arg1) == sc->multiply_symbol) && - (cadr (arg1) == caddr (arg1))) - return (fx_add_sqr_s); /* (* s s) */ - if (car (arg1) == sc->subtract_symbol) return (fx_add_sub_s); - } - if ((head == sc->cons_symbol) && (car (arg1) == sc->cons_symbol)) - return (fx_cons_cons_s); - /* also div(sub)[2] mul(div) */ - return (((head == sc->gt_symbol) && (car (arg1) == sc->add_symbol)) - ? fx_gt_add_s - : (((head == sc->add_symbol) && - (car (arg1) == sc->multiply_symbol)) - ? fx_add_mul_opssq_s - : fx_c_opssq_s_direct)); - } - return (fx_c_opssq_s); - - case HOP_SAFE_C_opSSq_opSSq: { - const s7_pointer arg1= cadr (arg), arg2= caddr (arg); - set_opt3_pair (arg, cdr (arg2)); - if ((fx_matches (car (arg1), sc->multiply_symbol)) && - (car (arg2) == sc->multiply_symbol)) { - set_opt1_pair (cdr (arg), cdr (arg1)); - if (head == sc->subtract_symbol) return (fx_sub_mul_mul); - if (head == sc->add_symbol) - return ( - ((cadr (arg1) == caddr (arg1)) && (cadr (arg2) == caddr (arg2))) - ? fx_add_sqr_sqr - : fx_add_mul_mul); - } - if ((fx_matches (car (arg1), sc->subtract_symbol)) && - (car (arg2) == sc->subtract_symbol)) { - set_opt1_pair (cdr (arg), cdr (arg1)); - if (head == sc->multiply_symbol) return (fx_mul_sub_sub); - if (head == sc->lt_symbol) return (fx_lt_sub2); - } - if ((fx_matches (head, sc->subtract_symbol)) && - (fx_matches (car (arg1), sc->vector_ref_symbol)) && - (car (arg2) == sc->vector_ref_symbol) && - (cadr (arg1) == cadr (arg2))) { - set_opt3_sym (arg, cadr (cdaddr (arg))); - return (fx_sub_vref2); - } - return (fx_c_opssq_opssq); + 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_RST_NO_REQ_FUNCTION: + return(c_function_to_let(sc, obj)); + + default: + return(sc->F); } + return(sc->F); +} - case HOP_SAFE_C_opSq: - if (is_unchanged_global (caadr (arg))) { - const s7_pointer arg_sym= cadadr (arg), arg_head= caadr (arg); - if (fx_matches (head, sc->is_pair_symbol)) { - if (arg_head == sc->car_symbol) { - set_opt3_sym (arg, arg_sym); - return (fx_is_pair_car_s); - } /* (pair? ...) is ok, so loc can be sym? 7 in lg */ - if (arg_head == sc->cdr_symbol) { - set_opt3_sym (arg, arg_sym); - return (fx_is_pair_cdr_s); - } - if (arg_head == sc->cadr_symbol) { - set_opt3_sym (arg, arg_sym); - return (fx_is_pair_cadr_s); - } - if (arg_head == sc->cddr_symbol) { - set_opt3_sym (arg, arg_sym); - return (fx_is_pair_cddr_s); - } - } - if (fx_matches (head, sc->is_null_symbol)) { - if (arg_head == sc->cdr_symbol) { - set_opt3_sym (arg, arg_sym); - return (fx_is_null_cdr_s); - } - if (arg_head == sc->cadr_symbol) { - set_opt3_sym (arg, arg_sym); - return (fx_is_null_cadr_s); - } - if (arg_head == sc->cddr_symbol) { - set_opt3_sym (arg, arg_sym); - return (fx_is_null_cddr_s); - } - } - if ((fx_matches (head, sc->is_symbol_symbol)) && - (caadr (arg) == sc->cadr_symbol)) { - set_opt3_sym (arg, arg_sym); - return (fx_is_symbol_cadr_s); - } +/* g_object_to_let is now defined in s7_scheme_predicate.c */ +#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) - if (fx_matches (head, sc->not_symbol)) { - if (arg_head == sc->is_pair_symbol) { - set_opt3_sym (arg, arg_sym); - return (fx_not_is_pair_s); - } - if (arg_head == sc->is_null_symbol) { - set_opt3_sym (arg, arg_sym); - return (fx_not_is_null_s); - } - if (arg_head == sc->is_symbol_symbol) { - set_opt3_sym (arg, arg_sym); - return (fx_not_is_symbol_s); - } - return (fx_not_opsq); - } - if ((fx_matches (head, sc->floor_symbol)) && - (arg_head == sc->sqrt_symbol)) { - set_opt3_sym (arg, arg_sym); - return (fx_floor_sqrt_s); - } - } - if (is_unchanged_global (head)) /* (? (op arg)) where (op arg) might - return a let with a ? method etc */ - { /* other possibility: fx_c_a */ - const uint8_t typ= symbol_type (head); - if (typ > 0) /* h_safe_c here so the type checker isn't shadowed */ - { - set_opt3_sym (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_opt3_sym (arg, cadadr (arg)); - return (fx_c_car_s); - } - if (fx_matches (caadr (arg), sc->cdr_symbol)) { - set_opt3_sym (arg, cadadr (arg)); - return (fx_c_cdr_s); - } - return (fx_c_opsq); - - case HOP_SAFE_C_SC: - if (is_unchanged_global (head)) { - const s7_pointer arg2= caddr (arg); - if (head == sc->add_symbol) { - if (is_t_real (arg2)) return (fx_add_sf); - if (is_t_integer (arg2)) - return ((integer (arg2) == 1) ? fx_add_s1 : fx_add_si); - } - if (head == sc->subtract_symbol) { - if (is_t_real (arg2)) return (fx_subtract_sf); - if (is_t_integer (arg2)) - return ((integer (arg2) == 1) ? fx_subtract_s1 : fx_subtract_si); - } - if (head == sc->multiply_symbol) { - if (is_t_real (arg2)) return (fx_multiply_sf); - if (is_t_integer (arg2)) return (fx_multiply_si); - } - if ((fn_proc (arg) == g_memq_2) && (is_pair (arg2))) - return (fx_memq_sq_2); - if ((fn_proc (arg) == g_is_eq) && (!is_unspecified (arg2))) - return (fx_is_eq_sc); - - if ((is_t_integer (arg2)) && (s7_p_pi_function (global_value (head)))) { - if (head == sc->num_eq_symbol) - return ((integer (arg2) == 0) ? fx_num_eq_s0 : fx_num_eq_si); - if (head == sc->lt_symbol) return (fx_lt_si); - if (head == sc->leq_symbol) return (fx_leq_si); - if (head == sc->gt_symbol) return (fx_gt_si); - if (head == sc->geq_symbol) return (fx_geq_si); - set_opt3_direct (cdr (arg), s7_p_pi_function (global_value (head))); - return (fx_c_si_direct); - } - if ((is_t_real (arg2)) && (real (arg2) == 0.0) && - (head == sc->num_eq_symbol)) - return (fx_num_eq_s0f); - if ((s7_p_pp_function (global_value (head))) && - (fn_proc (arg) != g_divide_by_2)) { - if (head == sc->memq_symbol) { - if ((is_pair (arg2)) && (is_proper_list_3 (sc, cadr (arg2)))) - return (fx_memq_sc_3); - return (fx_memq_sc); - } - if ((head == sc->char_eq_symbol) && (is_character (arg2))) - return (fx_char_eq_sc); /* maybe fx_char_eq_newline */ - if (head == sc->lt_symbol) - return (fx_lt_sc); /* integer case handled above */ - if (head == sc->leq_symbol) return (fx_leq_sc); - if (head == sc->gt_symbol) return (fx_gt_sc); - if (head == sc->geq_symbol) return (fx_geq_sc); - if (head == sc->list_symbol) return (fx_list_sc); - set_opt3_direct (cdr (arg), s7_p_pp_function (global_value (head))); - return (fx_c_sc_direct); - } - } - return (fx_c_sc); - - case HOP_SAFE_C_CS: - if (is_unchanged_global (head)) { - const s7_pointer arg1= cadr (arg), arg2= caddr (arg); - if (head == sc->cons_symbol) return (fx_cons_cs); - if ((head == sc->add_symbol) && (is_t_real (arg1))) return (fx_add_fs); - if ((head == sc->subtract_symbol) && (is_t_real (arg1))) - return (fx_subtract_fs); - if ((head == sc->num_eq_symbol) && (arg1 == int_zero)) { - set_opt3_sym (arg, - arg2); /* opt3_location is in use, but the num_eq is ok, - so only symbol might care about that info? */ - return (fx_num_eq_0s); - } - if (head == sc->multiply_symbol) { - if (is_t_real (arg1)) return (fx_multiply_fs); - if (is_t_integer (arg1)) return (fx_multiply_is); - } - } - return (fx_c_cs); - - case HOP_SAFE_C_S_opSq: { - const s7_pointer arg1p= cdr (arg), arg2= caddr (arg); - if (fx_matches (car (arg2), sc->car_symbol)) { - set_opt2_sym (arg1p, cadr (arg2)); - if (fx_matches (head, sc->hash_table_ref_symbol)) - return (fx_hash_table_ref_car); - return (fx_matches (head, sc->add_symbol) ? fx_add_s_car_s - : fx_c_s_car_s); - } - if ((is_global_and_has_func (head, s7_p_pp_function)) && - (is_global_and_has_func (car (arg2), s7_p_p_function))) { - if ((head == sc->cons_symbol) && (car (arg2) == sc->cdr_symbol)) { - set_opt2_sym (cdr (arg), cadr (arg2)); - return (fx_cons_s_cdr_s); - } - set_opt1_sym (arg1p, cadr (arg2)); - set_opt2_direct (arg1p, s7_p_pp_function (global_value (head))); - set_opt3_direct (arg1p, s7_p_p_function (global_value (car ( - arg2)))); /* arg opt3 only location, but no - change in callgrind */ - if (opt3_direct (arg1p) == (s7_pointer) random_p_p) - set_opt3_direct (cdr (arg), random_p_p_wrapped); - return (fx_c_s_opsq_direct); - } - } - return (fx_c_s_opsq); - - case HOP_SAFE_C_C_opSq: - if (is_global_and_has_func (head, s7_p_pp_function)) { - const s7_pointer arg2= caddr (arg); - if (is_global_and_has_func (car (arg2), s7_p_p_function)) { - set_opt2_direct (cdr (arg), s7_p_pp_function (global_value (head))); - set_opt3_direct (cdr (arg), - 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 (head)) { - const s7_pointer arg1p= cdr (arg), arg1= cadr (arg), arg2= caddr (arg); - if ((head == sc->memq_symbol) && - (fx_matches (car (arg1), sc->car_symbol)) && - (is_proper_quote (sc, arg2)) && (is_pair (cadr (arg2)))) - return ((s7_list_length (sc, opt2_con (arg1p)) == 2) ? fx_memq_car_s_2 - : fx_memq_car_s); - - if (head == sc->is_eq_symbol) { - if (((fx_matches (car (arg1), sc->car_symbol)) || - (fx_matches (car (arg1), sc->caar_symbol))) && - (is_proper_quote (sc, arg2))) { - set_opt3_sym (arg1p, cadr (arg1)); - set_opt2_con (arg1p, cadr (arg2)); - return ((car (arg1) == sc->car_symbol) ? fx_is_eq_car_sq - : fx_is_eq_caar_sq); - } - } - if (((head == sc->lt_symbol) || (head == sc->num_eq_symbol)) && - (is_t_integer (arg2)) && - (fx_matches (car (arg1), sc->length_symbol))) { - set_opt3_sym (arg1p, cadr (arg1)); - set_opt3_con (arg, arg2); - return ((head == 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 (head, 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 (head, sc->not_symbol)) { - if (fn_proc (cadr (arg)) == g_is_eq) { - const s7_pointer arg1= cadr (arg); - set_opt3_sym (arg, cadr (arg1)); - set_opt3_con (cdr (arg), (is_pair (caddr (arg1))) ? cadaddr (arg1) - : caddr (arg1)); - 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 (head, s7_p_pp_function)) { - const s7_pointer arg1p= cdr (arg), arg2= caddr (arg); - if ((is_global_and_has_func (car (arg2), s7_p_pi_function)) && - (is_t_integer (caddr (arg2)))) { - set_opt2_direct (arg1p, s7_p_pp_function (global_value (head))); - set_opt3_direct (arg1p, s7_p_pi_function (global_value (car (arg2)))); - set_opt3_sym (arg, cadr (arg2)); - set_opt1_con (arg1p, caddr (arg2)); - if (head == 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 ((head == 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 (arg1p, s7_p_pp_function (global_value (head))); - set_opt3_direct (arg1p, s7_p_pp_function (global_value (car (arg2)))); - set_opt3_sym (arg, cadr (arg2)); - if (opt3_direct (arg1p) == (s7_pointer) add_p_pp) - set_opt3_direct (arg1p, add_p_pp_wrapped); - else if (opt3_direct (arg1p) == (s7_pointer) subtract_p_pp) - set_opt3_direct (arg1p, subtract_p_pp_wrapped); - else if (opt3_direct (arg1p) == (s7_pointer) multiply_p_pp) - set_opt3_direct (arg1p, multiply_p_pp_wrapped); - set_opt1_con (arg1p, (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 (head, 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 (head, s7_p_p_function)) && - (is_global_and_has_func (caadr (arg), s7_p_pp_function))) { - const s7_pointer arg1p= cdr (arg); - set_opt2_direct (arg1p, s7_p_p_function (global_value (head))); - set_opt3_direct (arg1p, s7_p_pp_function (global_value (caar (arg1p)))); - if (opt3_direct (arg1p) == (s7_pointer) add_p_pp) - set_opt3_direct (arg1p, add_p_pp_wrapped); - else if (opt3_direct (arg1p) == (s7_pointer) subtract_p_pp) - set_opt3_direct (arg1p, subtract_p_pp_wrapped); - else if (opt3_direct (arg1p) == (s7_pointer) multiply_p_pp) - set_opt3_direct (arg1p, multiply_p_pp_wrapped); - return (fx_c_opssq_direct); - } - return (fx_c_opssq); - - case HOP_SAFE_C_C_opSSq: { - const s7_pointer arg1p= cdr (arg), s2= caddr (arg); - if ((fx_matches (car (s2), sc->multiply_symbol)) && - (cadr (s2) == caddr (s2))) - return (fx_c_c_sqr); - if ((is_small_real (car (arg1p))) && - (is_global_and_has_func (head, s7_p_dd_function)) && - (is_global_and_has_func ( - car (s2), - s7_d_pd_function))) /* not * currently (this is for clm) */ - { - set_opt3_direct (arg1p, s7_d_pd_function (global_value (car (s2)))); - set_opt2_direct (arg1p, s7_p_dd_function (global_value (head))); - set_opt3_sym (arg, cadr (s2)); - set_opt1_sym (arg1p, caddr (s2)); - return (fx_c_nc_opssq_direct); - } - if ((is_global_and_has_func (head, s7_p_pp_function)) && - (is_global_and_has_func (car (s2), s7_p_pp_function))) { - set_opt2_direct (arg1p, s7_p_pp_function (global_value (head))); - set_opt3_direct (arg1p, s7_p_pp_function (global_value (caaddr (arg)))); - if (opt3_direct (arg1p) == (s7_pointer) add_p_pp) - set_opt3_direct (arg1p, add_p_pp_wrapped); - else if (opt3_direct (arg1p) == (s7_pointer) subtract_p_pp) - set_opt3_direct (arg1p, subtract_p_pp_wrapped); - else if (opt3_direct (arg1p) == (s7_pointer) multiply_p_pp) - set_opt3_direct (arg1p, multiply_p_pp_wrapped); - set_opt3_sym (arg, cadr (s2)); - set_opt1_sym (arg1p, caddr (s2)); - if ((is_t_real (car (arg1p))) && (head == car (s2)) && - (head == 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: { - const s7_pointer arg1p= cdr (arg), arg1= cadr (arg), arg2= caddr (arg); - if ((is_global_and_has_func (head, s7_p_pp_function)) && - (is_global_and_has_func (car (arg1), s7_p_p_function)) && - (is_global_and_has_func (car (arg2), s7_p_p_function))) { - set_opt3_direct (arg, s7_p_pp_function (global_value (head))); - set_opt2_direct (arg1p, s7_p_p_function (global_value (car (arg1)))); - set_opt3_direct (arg1p, s7_p_p_function (global_value (car (arg2)))); - if ((car (arg1) == car (arg2)) && ((car (arg1) == sc->cdr_symbol) || - (car (arg1) == sc->car_symbol))) { - set_opt1_sym (arg1p, cadr (arg1)); - set_opt2_sym ( - arg1p, cadr (arg2)); /* usable because we know func is cdr|car */ - return ((car (arg1) == sc->cdr_symbol) ? fx_cdr_s_cdr_s - : fx_car_s_car_s); - } - set_opt1_sym (arg1p, cadr (arg2)); /* 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 (head, sc->not_symbol)) ? fx_not_op_s_opsqq - : fx_c_op_s_opsqq); - - case HOP_SAFE_C_op_opSSqq_S: { - const s7_pointer arg1p= cdr (arg), arg1= cadr (arg); - if ((is_global_and_has_func (head, s7_p_pp_function)) && - (is_global_and_has_func (car (arg1), s7_p_p_function)) && - (is_global_and_has_func (caadr (arg1), s7_p_pp_function))) { - set_opt3_direct (arg, s7_p_pp_function (global_value (head))); - set_opt2_direct (arg1p, s7_p_p_function (global_value (car (arg1)))); - set_opt3_direct (arg1p, s7_p_pp_function (global_value (caadr (arg1)))); - if (opt3_direct (arg1p) == (s7_pointer) add_p_pp) - set_opt3_direct (arg1p, add_p_pp_wrapped); - else if (opt3_direct (arg1p) == (s7_pointer) subtract_p_pp) - set_opt3_direct (arg1p, subtract_p_pp_wrapped); - else if (opt3_direct (arg1p) == (s7_pointer) multiply_p_pp) - set_opt3_direct (arg1p, multiply_p_pp_wrapped); - - return (fx_c_op_opssqq_s_direct); - } - } - return (fx_c_op_opssqq_s); - - case HOP_SAFE_C_A: - if (fx_matches (head, 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 (head, s7_p_p_function)) { - set_opt3_direct (arg, s7_p_p_function (global_value (head))); - if ((head == sc->sqrt_symbol) && - (fx_proc (cdr (arg)) == fx_add_sqr_sqr)) { - set_opt1_sym (cdr (arg), - cadr (cadr (cadr (arg)))); /* opt1_cfunc(arg) is set */ - set_opt3_sym ( - cdr (arg), - cadr (caddr (cadr (arg)))); /* opt3(arg) is sqrt_p_p but used to - be clobbered anyway */ - return (fx_hypot); - } - 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 (head, sc->is_eq_symbol)) return (fx_is_eq_ac); - if (is_global_and_has_func (head, s7_p_pp_function)) { - const s7_pointer arg1p= cdr (arg); - set_opt3_direct (arg1p, s7_p_pp_function (global_value (head))); - if ((opt3_direct (arg1p) == (s7_pointer) string_ref_p_pp) && - (is_t_integer (caddr (arg))) && (integer (caddr (arg)) == 0)) - set_opt3_direct (arg1p, string_ref_p_p0); - if (opt3_direct (arg1p) == (s7_pointer) memq_p_pp) { - if (fn_proc (arg) == g_memq_2) set_opt3_direct (arg1p, memq_2_p_pp); - else if ((is_pair (caddr (arg))) && - (is_proper_list_3 (sc, cadaddr (arg)))) - set_opt3_direct (arg1p, memq_3_p_pp); - else if (fn_proc (arg) == g_memq_4) - set_opt3_direct ( - arg1p, - memq_4_p_pp); /* this does not parallel 2 and 3 above (sigh) */ - } - else if ((is_t_real (opt3_con (arg))) && - (opt3_direct (arg1p) == (s7_pointer) lt_p_pp)) - return (fx_lt_ad); - if ((is_t_integer (opt3_con (arg))) && - (s7_p_pi_function (global_value (head)))) { - set_opt3_direct (arg1p, s7_p_pi_function (global_value (head))); - if (integer (opt3_con (arg)) == 1) { - if (opt3_direct (arg1p) == (s7_pointer) g_sub_xi) - return (fx_sub_a1); - else if (opt3_direct (arg1p) == (s7_pointer) add_p_pi) - return (fx_add_a1); - } - return (fx_c_ai_direct); - } - return (fx_c_ac_direct); - } - return (fx_c_ac); - - case HOP_SAFE_C_CA: - - if ((fx_proc (cddr (arg)) == fx_random_i)) - set_fx_direct (cddr (arg), fx_random_i_wrapped); - return ((fn_proc (arg) == g_cons) ? fx_cons_ca : fx_c_ca); +/* bridge functions for s7_scheme_predicate.c migration (round 2) */ +s7_pointer s7i_c_pointer_weak1_p_p(s7_scheme *sc, s7_pointer cptr) {return(c_pointer_weak1_p_p(sc, cptr));} +s7_pointer s7i_c_pointer_weak2_p_p(s7_scheme *sc, s7_pointer cptr) {return(c_pointer_weak2_p_p(sc, cptr));} +s7_pointer s7i_tree_leaves_p_p(s7_scheme *sc, s7_pointer p) {return(tree_leaves_p_p(sc, p));} +s7_pointer s7i_cyclic_sequences_p_p(s7_scheme *sc, s7_pointer p) {return(cyclic_sequences_p_p(sc, p));} +s7_pointer s7i_object_to_let_p_p(s7_scheme *sc, s7_pointer p) {return(object_to_let_p_p(sc, p));} +s7_pointer s7i_pair_line_number_p_p(s7_scheme *sc, s7_pointer p) {return(pair_line_number_p_p(sc, p));} +s7_pointer s7i_reverse_p_p(s7_scheme *sc, s7_pointer p) {return(reverse_p_p(sc, p));} +s7_pointer s7i_port_line_number_p_p(s7_scheme *sc, s7_pointer p) {return(port_line_number_p_p(sc, p));} +bool s7i_tree_memq_b_7pp(s7_scheme *sc, s7_pointer sym, s7_pointer tree) {return(tree_memq_b_7pp(sc, sym, tree));} +bool s7i_tree_set_memq_b_7pp(s7_scheme *sc, s7_pointer syms, s7_pointer tree) {return(tree_set_memq_b_7pp(sc, syms, tree));} +s7_pointer s7i_unlet_disabled(s7_scheme *sc) {return(sc->unlet_disabled);} +s7_pointer s7i_curlet(s7_scheme *sc) {return(sc->curlet);} +void s7i_capture_let_counter_inc(s7_scheme *sc) {sc->capture_let_counter++;} +bool s7i_is_defined_in_rootlet(s7_scheme *sc, s7_pointer sym) {return((is_slot(global_slot(sym))) && (global_value(sym) != sc->undefined));} - case HOP_SAFE_C_SA: - if ((fx_proc (cddr (arg)) == fx_random_i)) - set_fx_direct (cddr (arg), fx_random_i_wrapped); - 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 (head, s7_p_pp_function)) { - set_opt3_direct (cdr (arg), s7_p_pp_function (global_value (head))); - 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 (head, s7_p_pp_function)) { - set_opt3_direct (cdr (arg), s7_p_pp_function (global_value (head))); - 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); - 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_na : 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: { - const s7_pointer body= car (closure_body (opt1_lambda (arg))); - const s7_pointer par = car (closure_pars (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) == - par)) /* (lambda (x) (and (pair? x) (pair? (cdr x)))) */ - 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_cdr_let_ref) && - (cadadr (body) == - par)) /* (lambda (v) (cdr v)) -- many cases in lint.scm */ - { - set_opt2_sym (cdr (arg), cadaddr (body)); - return (fx_cdr_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: { - const 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); - return (fx_function[optimize_op (arg)]); - - case OP_IMPLICIT_STARLET_REF_S: - if (opt3_int (arg) == sl_print_length) - return (fx_implicit_starlet_print_length); - if (opt3_int (arg) == sl_safety) return (fx_implicit_starlet_safety); - return (fx_implicit_starlet_ref_s); - - case HOP_C: - if ((is_unchanged_global (head)) && (head == sc->curlet_symbol)) - return (fx_curlet); - /* fall through */ +/* ---------------- stacktrace ---------------- */ +static s7_pointer stacktrace_find_caller(s7_scheme *sc, s7_pointer let) +{ + if ((is_let(let)) && (let != sc->rootlet)) + return(((is_funclet(let)) || (is_maclet(let))) ? funclet_function(let) : stacktrace_find_caller(sc, let_outlet(let))); + return(sc->F); +} - default: - /* if ((S7_DEBUGGING) && (!fx_function[optimize_op(arg)]) && - * (is_h_optimized(arg))) fprintf(stderr, "fx_choose %s %s\n", - * op_names[optimize_op(arg)], display(arg)); */ - /* this includes unsafe c funcs (hop_c_a) and p-arg safe funcs - * (hop_safe_c_p) -- name needs "safe" and no "p" */ - return (fx_function[optimize_op (arg)]); - } - } /* is_optimized */ - - if (is_safe_quote (sc, car (arg))) { - check_quote (sc, arg); - return (fx_q); - } - return (NULL); +static bool stacktrace_find_let(s7_scheme *sc, s7_int loc, s7_pointer let) +{ + return((loc > 0) && + ((stack_let(sc->stack, loc) == let) || + (stacktrace_find_let(sc, loc - 4, let)))); } -#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 +static s7_int stacktrace_find_error_hook_quit(s7_scheme *sc) { - set_fx_direct (p, f); - return (true); + for (s7_int op_loc = stack_top(sc) - 1; op_loc >= 3; op_loc -= 4) + if (stack_op(sc->stack, op_loc) == OP_ERROR_HOOK_QUIT) + return(op_loc); + return(-1); } -static bool -o_var_ok (const s7_pointer p, const s7_pointer var1, const s7_pointer var2, - const s7_pointer var3) { - return ((p != var1) && (p != var2) && (p != var3)); +static bool stacktrace_in_error_handler(s7_scheme *sc, s7_int 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 -fx_tree_out (s7_scheme* sc, s7_pointer tree, const s7_pointer var1, - const s7_pointer var2, const s7_pointer var3, - bool unused_more_vars) { - const s7_pointer p = car (tree); - const s7_function pfunc= fx_proc (tree); - if (is_symbol (p)) { - if ((pfunc == fx_s) || (pfunc == fx_o)) { - 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)); +static bool stacktrace_error_hook_function(s7_scheme *sc, s7_pointer sym) +{ + if (is_symbol(sym)) + { + s7_pointer func = s7_symbol_value(sc, sym); + return((is_procedure(func)) && + (hook_has_functions(sc->error_hook)) && + (direct_memq(func, s7_hook_functions(sc, sc->error_hook)))); } - return (false); - } - if ((is_pair (p)) && (is_pair (cdr (p)))) { - const s7_pointer arg1= cadr (p); - if (arg1 == var1) { - if ((pfunc == fx_c_s) || (pfunc == fx_c_o)) - return (with_fx (tree, fx_c_T)); /* fx_c_T_direct got no hits */ - if ((pfunc == fx_car_s) || (pfunc == fx_car_o)) - return (with_fx (tree, fx_car_T)); - if ((pfunc == fx_cdr_s) || (pfunc == fx_cdr_o)) - return (with_fx (tree, fx_cdr_T)); - if (pfunc == fx_is_null_s) return (with_fx (tree, fx_is_null_T)); - if (pfunc == fx_iterate_o) return (with_fx (tree, fx_iterate_T)); - if (pfunc == fx_subtract_s1) return (with_fx (tree, fx_subtract_T1)); - if (pfunc == fx_add_s1) return (with_fx (tree, fx_add_T1)); - if (pfunc == fx_c_sca) return (with_fx (tree, fx_c_Tca)); - if ((pfunc == fx_num_eq_si) || (pfunc == fx_num_eq_s0) || - (pfunc == fx_num_eq_oi)) - return (with_fx (tree, fx_num_eq_Ti)); - /* if (pfunc == fx_cons_ss) return(with_fx(tree, fx_cons_Ts)); */ /* can - be fooled -- there is no fx_cons_us etc -- need fx_cons_os */ - /* if (pfunc == fx_multiply_ss) return(with_fx(tree, fx_multiply_Ts)); */ /* this also can be fooled? */ - if ((pfunc == fx_c_scs_direct) && (cadddr (p) == var2)) - return (with_fx (tree, fx_c_TcU_direct)); - if ((pfunc == fx_hash_table_ref_ss) && (var3 == caddr (p))) - return (with_fx (tree, fx_hash_table_ref_TV)); - if ((pfunc == fx_geq_ss) && (var2 == caddr (p))) - return (with_fx (tree, fx_geq_TU)); - } - else if (arg1 == var2) { - if (pfunc == fx_subtract_s1) return (with_fx (tree, fx_subtract_U1)); - if (pfunc == fx_add_s1) return (with_fx (tree, fx_add_U1)); - if ((pfunc == fx_car_s) || (pfunc == fx_car_o)) - return (with_fx (tree, fx_car_U)); - if ((pfunc == fx_cdr_s) || (pfunc == fx_cdr_o)) - return (with_fx (tree, fx_cdr_U)); - } - else if (arg1 == var3) { - if ((pfunc == fx_c_s) || (pfunc == fx_c_o)) - return (with_fx (tree, fx_c_V)); - if (pfunc == fx_add_s1) return (with_fx (tree, fx_add_V1)); - } - else if (is_pair (cddr (p))) { - if (caddr (p) == var1) { - if ((pfunc == fx_num_eq_ts) || (pfunc == fx_num_eq_to)) - return (with_fx (tree, fx_num_eq_tT)); - if ((pfunc == fx_gt_ts) || (pfunc == fx_gt_to)) - return (with_fx (tree, fx_gt_tT)); - if (pfunc == fx_lt_ts) return (with_fx (tree, fx_lt_tT)); - if ((pfunc == fx_geq_ts) || (pfunc == fx_geq_to)) - return (with_fx (tree, fx_geq_tT)); - } - else if (caddr (p) == var2) { - if (pfunc == fx_c_ts) return (with_fx (tree, fx_c_tU)); - if (pfunc == fx_cons_ts) return (with_fx (tree, fx_cons_tU)); - if (pfunc == fx_c_ts_direct) return (with_fx (tree, fx_c_tU_direct)); - if (pfunc == fx_lt_ts) return (with_fx (tree, fx_lt_tU)); - if (pfunc == fx_num_eq_us) return (with_fx (tree, fx_num_eq_uU)); - if (pfunc == fx_num_eq_vs) return (with_fx (tree, fx_num_eq_vU)); - } - else if ((pfunc == fx_add_sqr_s) && (cadr (arg1) == var1)) - return (with_fx (tree, fx_add_sqr_T)); + return(false); +} + +static char *stacktrace_walker(s7_scheme *sc, s7_pointer code, s7_pointer let, 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_small_symbol_set(sc, code)) && + (!is_slot(global_slot(code)))) + { + const s7_pointer val = s7_symbol_local_value(sc, code, let); + add_symbol_to_small_symbol_set(sc, code); + if ((val) && + (val != sc->undefined) && + (!is_any_macro(val)) && + (type(val) < T_CONTINUATION)) + { + char *objstr; + s7_pointer objp; + s7_int new_note_len, notes_max; + bool new_notes_line = false; + const bool old_short_print = sc->short_print; + const s7_int old_len = sc->print_length; + s7_int objlen; + + 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) + { + const char *last_newline = strrchr(notes, (int)'\n'); /* returns ptr to end if none = nil if not found? */ + s7_int cur_line_len = (last_newline) ? (strlen(notes) - strlen(last_newline)) : strlen(notes); + new_notes_line = ((cur_line_len + new_note_len) > notes_max); + } + { + char *str; + if (new_notes_line) + { + const char *spaces = " "; + const s7_int spaces_len = 80; + 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) ? (const 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), let, notes, code_cols, total_cols, notes_start_col, as_comment, depth + 1); + return(stacktrace_walker(sc, cdr(code), let, notes, code_cols, total_cols, notes_start_col, as_comment, depth + 2)); } - } - return (false); + return(notes); } -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)) || - ((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 bool -fx_tree_in (s7_scheme* sc, const s7_pointer tree, const s7_pointer var1, - const s7_pointer var2, const s7_pointer var3, bool more_vars) { - const s7_pointer p= car (tree); - s7_function pfunc; - 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_defined_global (p)) return (with_fx (tree, fx_g)); - if (!more_vars) return (with_fx (tree, fx_o)); - } - return (false); - } - if ((!is_pair (p)) || (is_fx_treed (tree)) || (!has_fx (tree))) - return (false); - set_fx_treed (tree); - pfunc= fx_proc (tree); - switch (optimize_op (p)) { - case HOP_SAFE_C_S: - if (cadr (p) == var1) { - if (pfunc == fx_c_s) return (with_fx (tree, fx_c_t)); - if (pfunc == 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 (pfunc == fx_car_s) return (with_fx (tree, fx_car_t)); - if (pfunc == fx_cdr_s) return (with_fx (tree, fx_cdr_t)); - if (pfunc == fx_cddr_s) return (with_fx (tree, fx_cddr_t)); - if (pfunc == fx_cadr_s) return (with_fx (tree, fx_cadr_t)); - if (pfunc == fx_not_s) return (with_fx (tree, fx_not_t)); - if (pfunc == fx_is_null_s) return (with_fx (tree, fx_is_null_t)); - if (pfunc == fx_is_pair_s) return (with_fx (tree, fx_is_pair_t)); - if (pfunc == fx_is_symbol_s) return (with_fx (tree, fx_is_symbol_t)); - if (pfunc == fx_is_eof_s) return (with_fx (tree, fx_is_eof_t)); - if (pfunc == fx_is_string_s) return (with_fx (tree, fx_is_string_t)); - if (pfunc == fx_is_vector_s) return (with_fx (tree, fx_is_vector_t)); - if (pfunc == fx_is_integer_s) return (with_fx (tree, fx_is_integer_t)); - if (pfunc == fx_is_procedure_s) - return (with_fx (tree, fx_is_procedure_t)); - if (pfunc == fx_is_type_s) return (with_fx (tree, fx_is_type_t)); - if (pfunc == fx_length_s) return (with_fx (tree, fx_length_t)); - if (pfunc == fx_real_part_s) return (with_fx (tree, fx_real_part_t)); - if (pfunc == fx_imag_part_s) return (with_fx (tree, fx_imag_part_t)); - return (false); - } - if (cadr (p) == var2) { - if (pfunc == fx_c_s) { - if (is_global_and_has_func (car (p), s7_p_p_function)) { - set_opt2_direct (cdr (p), 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 (pfunc == 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 (pfunc == fx_cdr_s) return (with_fx (tree, fx_cdr_u)); - if (pfunc == fx_cadr_s) return (with_fx (tree, fx_cadr_u)); - if (pfunc == fx_cddr_s) return (with_fx (tree, fx_cddr_u)); - if (pfunc == fx_car_s) return (with_fx (tree, fx_car_u)); - if (pfunc == fx_is_null_s) return (with_fx (tree, fx_is_null_u)); - if (pfunc == fx_is_type_s) return (with_fx (tree, fx_is_type_u)); - if (pfunc == fx_is_pair_s) return (with_fx (tree, fx_is_pair_u)); - if (pfunc == fx_is_symbol_s) return (with_fx (tree, fx_is_symbol_u)); - if (pfunc == fx_is_eof_s) return (with_fx (tree, fx_is_eof_u)); - return (false); - } - if (cadr (p) == var3) { - if (pfunc == fx_cdr_s) return (with_fx (tree, fx_cdr_v)); - if (pfunc == fx_is_null_s) return (with_fx (tree, fx_is_null_v)); - if (pfunc == fx_is_pair_s) return (with_fx (tree, fx_is_pair_v)); - if (pfunc == fx_c_s) return (with_fx (tree, fx_c_v)); - if (pfunc == fx_c_s_direct) return (with_fx (tree, fx_c_v_direct)); - return (false); - } - if (!more_vars) { - if (pfunc == fx_is_null_s) return (with_fx (tree, fx_is_null_o)); - if (pfunc == fx_car_s) return (with_fx (tree, fx_car_o)); - if (pfunc == fx_cdr_s) return (with_fx (tree, fx_cdr_o)); - if (pfunc == fx_cadr_s) return (with_fx (tree, fx_cadr_o)); - if (pfunc == fx_cddr_s) return (with_fx (tree, fx_cddr_o)); - if (pfunc == fx_iterate_s) return (with_fx (tree, fx_iterate_o)); - if (pfunc == fx_not_s) return (with_fx (tree, fx_not_o)); - if (pfunc == fx_c_s_direct) return (with_fx (tree, fx_c_o_direct)); - if (pfunc == fx_c_s) return (with_fx (tree, fx_c_o)); - } - break; - - case HOP_SAFE_C_SC: - if (cadr (p) == var1) { - if ((pfunc == fx_char_eq_sc) || (fn_proc (p) == g_char_equal_2)) - return (with_fx (tree, fx_char_eq_tc)); - if (pfunc == fx_c_sc) return (with_fx (tree, fx_c_tc)); - if (pfunc == 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 (pfunc == fx_leq_si) return (with_fx (tree, fx_leq_ti)); - if (pfunc == fx_gt_si) return (with_fx (tree, fx_gt_ti)); - - if (pfunc == fx_c_sc_direct) /* p_pp cases */ +static block_t *stacktrace_add_func(s7_scheme *sc, s7_pointer caller, s7_pointer code, const char *errstr, char *notes, s7_int code_max, bool as_comment) +{ + s7_int newlen, errlen = strlen(errstr); + char *newstr; + block_t *newp; + if ((is_symbol(caller)) && + (caller != car(code))) + { + newlen = symbol_name_length(caller) + errlen + 10; + newp = mallocate(sc, newlen); + newstr = (char *)block_data(newp); /* newstr[0] = '\0'; */ + errlen = catstrs_direct(newstr, symbol_name(caller), ": ", 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, (const void *)errstr, errlen); + newstr[errlen] = '\0'; + }} + newlen = code_max + 8 + ((notes) ? strlen(notes) : 0); + { + block_t *b = mallocate(sc, newlen); + char *str = (char *)block_data(b); /* str[0] = '\0'; */ + if (errlen >= code_max) { - if ((opt3_direct (cdr (p)) == (s7_pointer) s7i_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)); + 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); } - if (pfunc == fx_c_si_direct) /* p_pi cases */ + else { - 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, - (opt3_direct (cdr (p)) == (s7_pointer) remainder_p_pi) - ? fx_c_ti_remainder - : fx_c_ti_direct)); - } - if (pfunc == fx_is_eq_sc) return (with_fx (tree, fx_is_eq_tc)); - if (pfunc == fx_add_s1) return (with_fx (tree, fx_add_t1)); - if (pfunc == fx_add_si) return (with_fx (tree, fx_add_ti)); - if (pfunc == fx_subtract_s1) return (with_fx (tree, fx_subtract_t1)); - if (pfunc == fx_subtract_si) return (with_fx (tree, fx_subtract_ti)); - if (pfunc == fx_subtract_sf) return (with_fx (tree, fx_subtract_tf)); - if (pfunc == fx_multiply_sf) return (with_fx (tree, fx_multiply_tf)); - if (pfunc == fx_multiply_si) return (with_fx (tree, fx_multiply_ti)); - if (pfunc == 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 (pfunc == fx_num_eq_si) return (with_fx (tree, fx_num_eq_ti)); - if (pfunc == fx_num_eq_s0) return (with_fx (tree, fx_num_eq_t0)); - if (pfunc == fx_memq_sc) return (with_fx (tree, fx_memq_tc)); - return (false); - } - if (cadr (p) == var2) { - if (pfunc == fx_c_sc) return (with_fx (tree, fx_c_uc)); - if (pfunc == fx_num_eq_s0) return (with_fx (tree, fx_num_eq_u0)); - if (pfunc == fx_num_eq_si) return (with_fx (tree, fx_num_eq_ui)); - if (pfunc == fx_add_s1) return (with_fx (tree, fx_add_u1)); - if (pfunc == fx_subtract_s1) return (with_fx (tree, fx_subtract_u1)); - if (pfunc == fx_subtract_si) return (with_fx (tree, fx_subtract_ui)); - if (pfunc == fx_multiply_si) return (with_fx (tree, fx_multiply_ui)); - if (pfunc == fx_is_eq_sc) return (with_fx (tree, fx_is_eq_uc)); - if (pfunc == fx_leq_si) return (with_fx (tree, fx_leq_ui)); - if (pfunc == fx_gt_si) return (with_fx (tree, fx_gt_ui)); - return (false); - } - if (cadr (p) == var3) { - if (pfunc == fx_num_eq_s0) return (with_fx (tree, fx_num_eq_v0)); - if (pfunc == fx_num_eq_si) return (with_fx (tree, fx_num_eq_vi)); - if (pfunc == fx_add_s1) return (with_fx (tree, fx_add_v1)); - if (pfunc == fx_subtract_s1) return (with_fx (tree, fx_subtract_v1)); - if (pfunc == fx_leq_si) return (with_fx (tree, fx_leq_vi)); - if (pfunc == fx_c_sc) return (with_fx (tree, fx_c_vc)); - return (false); - } - if (!more_vars) { - if (pfunc == fx_num_eq_si) return (with_fx (tree, fx_num_eq_oi)); - if ((pfunc == fx_c_sc) && (o_var_ok (cadr (p), var1, var2, var3))) - return (with_fx (tree, fx_c_oc)); - } - 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 (pfunc == fx_multiply_is) return (with_fx (tree, fx_multiply_it)); - if (pfunc == fx_add_fs) return (with_fx (tree, fx_add_ft)); - if (pfunc == fx_c_cs) { - if (is_global_and_has_func (car (p), s7_p_pp_function)) { - if (fn_proc (p) == g_tree_set_memq_syms) - set_opt3_direct (cdr (p), tree_set_memq_syms_direct); - else - set_opt3_direct (cdr (p), - 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) && (pfunc == fx_c_cs)) - return (with_fx (tree, fx_c_cu)); - break; - - case HOP_SAFE_C_SS: { - const s7_pointer arg1= cadr (p), arg2= caddr (p); - if (arg1 == var1) { - if (pfunc == fx_c_ss) - return (with_fx (tree, (arg2 == var2) ? fx_c_tu : fx_c_ts)); - if (pfunc == fx_c_ss_direct) - return ( - with_fx (tree, (arg2 == var2) ? fx_c_tu_direct : fx_c_ts_direct)); - if (pfunc == fx_add_ss) - return (with_fx (tree, (arg2 == var2) ? fx_add_tu : fx_add_ts)); - if (pfunc == fx_subtract_ss) - return ( - with_fx (tree, (arg2 == var2) ? fx_subtract_tu : fx_subtract_ts)); - if (pfunc == fx_cons_ss) - return (with_fx (tree, (arg2 == var2) ? fx_cons_tu : fx_cons_ts)); - if (arg2 == var2) { - if (pfunc == fx_gt_ss) return (with_fx (tree, fx_gt_tu)); - if (pfunc == fx_lt_ss) return (with_fx (tree, fx_lt_tu)); - if (pfunc == fx_leq_ss) return (with_fx (tree, fx_leq_tu)); - if (pfunc == fx_geq_ss) return (with_fx (tree, fx_geq_tu)); - if (pfunc == fx_multiply_ss) return (with_fx (tree, fx_multiply_tu)); - if (pfunc == fx_num_eq_ss) return (with_fx (tree, fx_num_eq_tu)); - if (pfunc == fx_memq_ss) return (with_fx (tree, fx_memq_tu)); - } - if (pfunc == fx_multiply_ss) return (with_fx (tree, fx_multiply_ts)); - if (pfunc == fx_num_eq_ss) { - if (arg2 == var3) return (with_fx (tree, fx_num_eq_tv)); - if (is_defined_global (arg2)) return (with_fx (tree, fx_num_eq_tg)); - if ((!more_vars) && (o_var_ok (arg2, var1, var2, var3))) - return (with_fx (tree, fx_num_eq_to)); - return (with_fx (tree, fx_num_eq_ts)); - } - if (pfunc == fx_geq_ss) { - if ((!more_vars) && (o_var_ok (arg2, var1, var2, var3))) - return (with_fx (tree, fx_geq_to)); - return (with_fx (tree, fx_geq_ts)); - } - if (pfunc == fx_leq_ss) return (with_fx (tree, fx_leq_ts)); - if (pfunc == fx_lt_ss) return (with_fx (tree, fx_lt_ts)); - if (pfunc == fx_lt_sg) return (with_fx (tree, fx_lt_tg)); - if (pfunc == fx_gt_ss) { - if (is_defined_global (arg2)) return (with_fx (tree, fx_gt_tg)); - if ((!more_vars) && (o_var_ok (arg2, var1, var2, var3))) - return (with_fx (tree, fx_gt_to)); - return (with_fx (tree, fx_gt_ts)); - } - if (pfunc == fx_sqr_s) return (with_fx (tree, fx_sqr_t)); - if (pfunc == fx_is_eq_ss) { - if (arg2 == var2) return (with_fx (tree, fx_is_eq_tu)); - if ((!more_vars) && (arg2 != var3) && (arg2 != var1)) - return (with_fx (tree, fx_is_eq_to)); - return (with_fx (tree, fx_is_eq_ts)); - } - if (pfunc == fx_vref_ss) { - if (arg2 == var2) return (with_fx (tree, fx_vref_tu)); - return (with_fx (tree, fx_vref_ts)); - } - } - if (arg2 == var1) { - if (pfunc == fx_c_ss) return (with_fx (tree, fx_c_st)); - if (pfunc == fx_c_ss_direct) { - return (with_fx (tree, (is_defined_global (arg1)) ? fx_c_gt_direct - : fx_c_st_direct)); + /* send out newstr, pad with spaces to code_max, then notes */ + const s7_int 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); } - if (pfunc == fx_hash_table_ref_ss) - return (with_fx (tree, fx_hash_table_ref_st)); - if (pfunc == fx_cons_ss) return (with_fx (tree, fx_cons_st)); - if (pfunc == fx_vref_ss) { - if (is_defined_global (arg1)) return (with_fx (tree, fx_vref_gt)); - if ((!more_vars) && (arg1 != var2) && (arg1 != var3)) - return (with_fx (tree, fx_vref_ot)); - return (with_fx (tree, fx_vref_st)); - } - if ((pfunc == fx_gt_ss) && (arg1 == var2)) - return (with_fx (tree, fx_gt_ut)); - if ((pfunc == fx_lt_ss) && (arg1 == var2)) - return (with_fx (tree, fx_lt_ut)); - if (pfunc == fx_geq_ss) { - if ((!more_vars) && (o_var_ok (arg1, var1, var2, var3))) - return (with_fx (tree, fx_geq_ot)); - return (with_fx (tree, fx_geq_st)); - } - } - if (arg1 == var2) { - if (pfunc == fx_geq_ss) return (with_fx (tree, fx_geq_us)); - if (pfunc == fx_num_eq_ss) - return (with_fx (tree, (arg2 == var1) ? fx_num_eq_ut : fx_num_eq_us)); - if (pfunc == fx_add_ss) - return (with_fx (tree, (arg2 == var1) - ? fx_add_ut - : ((arg2 == var3) ? fx_add_uv : fx_add_us))); - if (pfunc == fx_subtract_ss) - return ( - with_fx (tree, (arg2 == var1) ? fx_subtract_ut : fx_subtract_us)); - if (arg2 == var3) return (with_fx (tree, fx_c_uv)); - } - if ((arg2 == var2) && (pfunc == fx_sref_ss)) - return (with_fx (tree, fx_sref_su)); - if (arg1 == var3) { - if (pfunc == fx_num_eq_ss) return (with_fx (tree, fx_num_eq_vs)); - if ((pfunc == fx_add_ss) && (arg2 == var2)) - return (with_fx (tree, fx_add_vu)); - if (pfunc == fx_geq_ss) - return ( - with_fx (tree, ((!more_vars) && (o_var_ok (arg2, var1, var2, var3))) - ? fx_geq_vo - : 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_sref_t_last)); - return (with_fx (tree, fx_c_ta)); - } - if (cadr (p) == var2) - return ( - with_fx (tree, (pfunc == fx_c_sa_direct) ? fx_c_ua_direct : fx_c_ua)); - break; - - case HOP_SAFE_C_SCS: - if (cadr (p) == var1) { - if (pfunc == fx_c_scs) return (with_fx (tree, fx_c_tcs)); - if (pfunc == 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) && - ((pfunc == fx_c_sss) || (pfunc == fx_c_sss_direct)))) - return (with_fx ( - tree, (cadddr (p) == var3) - ? ((pfunc == fx_c_sss_direct) ? fx_c_tuv_direct : fx_c_tuv) - : fx_c_tus)); - if (caddr (p) == var1) { - if (car (p) == sc->vector_set_symbol) - return (with_fx (tree, fx_vset_sts)); - return (with_fx (tree, fx_c_sts)); - } - break; - - case HOP_SAFE_C_SSA: - if (cadr (p) == var1) - return (with_fx (tree, fx_c_tsa)); /* tua is hit but not called much */ - if (caddr (p) == var1) return (with_fx (tree, fx_c_sta)); - break; - - case HOP_SAFE_C_opSq: - if (cadadr (p) == var1) { - if (pfunc == fx_is_pair_car_s) return (with_fx (tree, fx_is_pair_car_t)); - if (pfunc == fx_is_pair_cdr_s) return (with_fx (tree, fx_is_pair_cdr_t)); - if (pfunc == fx_is_pair_cadr_s) - return (with_fx (tree, fx_is_pair_cadr_t)); - if (pfunc == fx_is_symbol_cadr_s) - return (with_fx (tree, fx_is_symbol_cadr_t)); - if (pfunc == fx_is_pair_cddr_s) - return (with_fx (tree, fx_is_pair_cddr_t)); - if (pfunc == fx_is_null_cdr_s) return (with_fx (tree, fx_is_null_cdr_t)); - if (pfunc == fx_is_null_cadr_s) - return (with_fx (tree, fx_is_null_cadr_t)); - if (pfunc == fx_is_null_cddr_s) - return (with_fx (tree, fx_is_null_cddr_t)); - if (pfunc == fx_not_is_pair_s) return (with_fx (tree, fx_not_is_pair_t)); - if (pfunc == fx_not_is_null_s) return (with_fx (tree, fx_not_is_null_t)); - if (pfunc == fx_not_is_symbol_s) - return (with_fx (tree, fx_not_is_symbol_t)); - if (pfunc == 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 (pfunc == 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_p_p_function (global_value (car (p)))); - set_opt3_direct (cdr (p), s7_p_p_function (global_value (caadr (p)))); - return (with_fx (tree, fx_c_optq_direct)); - } - return (with_fx (tree, fx_c_optq)); - } - if (pfunc == fx_c_car_s) return (with_fx (tree, fx_c_car_t)); - if (pfunc == fx_c_cdr_s) return (with_fx (tree, fx_c_cdr_t)); - if (pfunc == fx_is_type_opsq) return (with_fx (tree, fx_is_type_optq)); - if (pfunc == fx_not_opsq) { - set_opt3_sym (p, cadadr (p)); - return (with_fx (tree, (caadr (p) == sc->car_symbol) ? fx_not_car_t - : fx_not_optq)); - } - } - if (cadadr (p) == var2) { - if (pfunc == fx_c_car_s) return (with_fx (tree, fx_c_car_u)); - if (pfunc == fx_not_is_null_s) return (with_fx (tree, fx_not_is_null_u)); - if (pfunc == fx_not_is_pair_s) return (with_fx (tree, fx_not_is_pair_u)); - if (pfunc == fx_is_pair_cdr_s) return (with_fx (tree, fx_is_pair_cdr_u)); - } - if (cadadr (p) == var3) { - if (pfunc == fx_not_is_pair_s) return (with_fx (tree, fx_not_is_pair_v)); - } - break; - - case HOP_SAFE_C_opSq_S: { - const s7_pointer arg1p= cdr (p), arg1= cadr (p), arg2= caddr (p); - if (cadr (arg1) == var1) { - if (pfunc == fx_c_opsq_s) { - if ((is_global_and_has_func (car (p), s7_p_pp_function)) && - (is_global_and_has_func (car (arg1), s7_p_p_function))) { - set_opt2_direct (arg1p, s7_p_pp_function (global_value (car (p)))); - set_opt3_direct (arg1p, s7_p_p_function (global_value (car (arg1)))); - return (with_fx (tree, fx_c_optq_s_direct)); - } - return (with_fx (tree, fx_c_optq_s)); - } - if (pfunc == fx_c_opsq_s_direct) - return (with_fx (tree, fx_c_optq_s_direct)); - if (pfunc == fx_cons_car_s_s) { - set_opt1_sym (arg1p, var1); - return ( - with_fx (tree, (arg2 == var3) ? fx_cons_car_t_v : fx_cons_car_t_s)); - } - } - if (cadr (arg1) == var2) { - if ((pfunc == fx_c_opsq_s) && (arg2 == var1)) { - if ((is_global_and_has_func (car (p), s7_p_pp_function)) && - (is_global_and_has_func ( - car (arg1), - s7_p_p_function))) /* (memq (car sequence) items) lint */ - { - set_opt2_direct (arg1p, s7_p_pp_function (global_value (car (p)))); - set_opt3_direct (arg1p, s7_p_p_function (global_value (car (arg1)))); - return (with_fx (tree, (car (p) == sc->cons_symbol) - ? ((car (arg1) == 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 (((pfunc == fx_c_opsq_s_direct) || (pfunc == fx_cons_car_s_s)) && - (arg2 == var1)) - return (with_fx (tree, - (car (p) == sc->cons_symbol) - ? ((car (arg1) == sc->car_symbol) ? fx_cons_car_u_t - : fx_cons_opuq_t) - : fx_c_opuq_t_direct)); - } - } break; - - case HOP_SAFE_C_S_opSq: { - const s7_pointer arg2_arg= cadaddr (p); - if (cadr (p) == var1) { - if (arg2_arg == var2) { - if (pfunc == fx_c_s_car_s) return (with_fx (tree, fx_c_t_car_u)); - if (pfunc == fx_c_s_opsq_direct) - return (with_fx (tree, fx_c_t_opuq_direct)); - } - if (arg2_arg == var3) { - if (pfunc == fx_add_s_car_s) return (with_fx (tree, fx_add_t_car_v)); - if (pfunc == fx_c_s_car_s) - return ( - with_fx (tree, fx_c_t_car_v)); /* ideally eq_p_pp not g_is_eq */ - } - if (pfunc == fx_c_s_opsq_direct) - return (with_fx (tree, fx_c_t_opsq_direct)); - } - if (cadr (p) == var2) { - if ((pfunc == fx_add_s_car_s) && (arg2_arg == var1)) - return (with_fx (tree, fx_add_u_car_t)); - if ((pfunc == fx_c_s_opsq_direct) && (arg2_arg == var3)) - return (with_fx (tree, fx_c_u_opvq_direct)); - } - if ((arg2_arg == var1) && (pfunc == fx_c_s_car_s)) - return (with_fx (tree, fx_c_s_car_t)); - } break; - - case HOP_SAFE_C_opSq_opSq: { - const s7_pointer arg1= cadr (p), arg2= caddr (p); - if ((pfunc == fx_c_opsq_opsq_direct) && (cadr (arg1) == var1) && - (cadr (arg2) == var1)) { - /* p: (set-car! (cadr lst) (cdr lst)), var1: lst */ - set_opt1_sym (cdr (p), cadr (arg1)); - return (with_fx (tree, fx_c_optq_optq_direct)); /* opuq got few hits */ - } - if (((pfunc == fx_c_opsq_opsq_direct) || (pfunc == fx_car_s_car_s)) && - ((car (arg1) == sc->car_symbol) && (car (arg2) == sc->car_symbol))) { - /* lt.scm: p: (list (car p) (car q)), var1: p, var2: q */ - set_opt1_sym (cdr (p), cadr (arg1)); - set_opt2_sym (cdr (p), cadr (arg2)); - return (with_fx (tree, ((cadr (arg1) == var1) && (cadr (arg2) == 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 (pfunc == fx_is_eq_car_sq) return (with_fx (tree, fx_is_eq_car_tq)); - if ((pfunc == fx_c_opsq_c) || (pfunc == fx_c_optq_c)) { - if (fn_proc (p) != g_cdr_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, memq_2_p_pp); - else set_opt3_direct (p, s7_p_pp_function (global_value (car (p)))); - set_opt3_direct (cdr (p), - 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_p_ii_function (global_value (car (p)))); - set_opt3_direct (cdr (p), - 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: { - const s7_pointer arg1= cadr (p); - if (pfunc == fx_c_opssq) { - if (caddr (arg1) == var1) return (with_fx (tree, fx_c_opstq)); - if ((cadr (arg1) == var1) && (caddr (arg1) == var2)) - return (with_fx (tree, fx_c_optuq)); - } - if (pfunc == fx_c_opssq_direct) { - if ((cadr (arg1) == var1) && (caddr (arg1) == var2)) - return (with_fx (tree, fx_c_optuq_direct)); - if (caddr (arg1) == var1) { - if ((opt2_direct (cdr (p)) == (s7_pointer) zero_p_p) && - (opt3_direct (cdr (p)) == (s7_pointer) remainder_p_pp) && - (!more_vars) && (o_var_ok (cadr (arg1), var1, var2, var3))) - return (with_fx (tree, fx_is_zero_remainder_o)); - return (with_fx (tree, fx_c_opstq_direct)); - } - } - if ((cadr (arg1) == var2) && (pfunc == fx_not_opssq) && - (caddadr (p) == var1)) { - set_fx_direct (tree, (fn_proc (arg1) == g_less_2) ? fx_not_lt_ut - : fx_not_oputq); - return (true); - } - } break; - - case HOP_SAFE_C_opSCq: - if (cadadr (p) == var1) { - if ((fn_proc (p) == g_zero) && (fn_proc (cadr (p)) == g_remainder) && - (is_t_integer (caddadr (p))) && (integer (caddadr (p)) > 1)) - return (with_fx (tree, fx_is_zero_remainder_ti)); - return (with_fx ( - tree, fx_c_optcq)); /* there currently isn't any fx_c_opscq_direct */ - } - break; - - case HOP_SAFE_C_opSSq_C: - if ((pfunc == fx_c_opssq_c) && (caddadr (p) == var1)) { - if (is_global_and_has_func (car (p), s7_p_pp_function)) { - set_opt3_direct (p, 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 (pfunc == fx_c_s_opscq_direct) - return (with_fx (tree, (cadaddr (p) == var2) ? fx_c_t_opucq_direct - : fx_c_t_opscq_direct)); - if ((pfunc == fx_c_s_opsiq_direct) && (!more_vars) && - (o_var_ok (cadaddr (p), var1, var2, var3))) - return (with_fx (tree, fx_c_t_opoiq_direct)); - } - else if ((cadr (p) == var2) && (cadaddr (p) == var1)) { - if (pfunc == fx_c_s_opsiq_direct) - return (with_fx (tree, fx_c_u_optiq_direct)); - if (pfunc == fx_c_s_opscq) return (with_fx (tree, fx_c_u_optcq)); - } - break; - - case HOP_SAFE_C_opSq_CS: - if ((cadadr (p) == var1) && (pfunc == fx_c_opsq_cs) && (cadddr (p) == var2)) - return (with_fx (tree, fx_c_optq_cu)); - break; - - case HOP_SAFE_C_opSq_opSSq: { - const s7_pointer arg1p= cdr (p), arg1= cadr (p), arg2= caddr (p); - if ((pfunc == fx_c_opsq_opssq) && (cadr (arg2) == var1) && - (caddr (arg2) == var2) && - (is_global_and_has_func (car (p), s7_p_pp_function)) && - (is_global_and_has_func (car (arg1), s7_p_p_function)) && - (is_global_and_has_func (car (arg2), s7_p_pp_function))) { - set_opt3_direct (p, s7_p_pp_function (global_value (car (p)))); - set_opt2_direct (arg1p, s7_p_p_function (global_value (car (arg1)))); - set_opt3_direct (arg1p, s7_p_pp_function (global_value (car (arg2)))); - set_opt1_sym (arg1p, var2); /* caddaddr(p) */ - set_opt2_sym (cddr (p), var1); - if ((car (p) == sc->num_eq_symbol) && (car (arg1) == sc->car_symbol) && - (cadr (arg1) == var3)) { - if (car (arg2) == sc->add_symbol) - return (with_fx (tree, fx_num_eq_car_v_add_tu)); - if (car (arg2) == sc->subtract_symbol) - 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: { - const s7_pointer s1= cadadr (p), s2= caddadr (p); - if (pfunc == fx_vref_vref_ss_s) { - s7_pointer s3= caddr (p); - if ((s3 == var1) && (is_defined_global (s1))) { - if ((!more_vars) && (o_var_ok (s2, var1, var2, var3))) - return (with_fx (tree, fx_vref_vref_go_t)); - return (with_fx (tree, fx_vref_vref_gs_t)); - } - if ((s1 == var1) && (s2 == var2) && (s3 == var3)) - return (with_fx (tree, fx_vref_vref_tu_v)); - } - if ((pfunc == fx_gt_add_s) && (s1 == var1) && (s2 == var2)) - return (with_fx (tree, fx_gt_add_tu_s)); - if ((pfunc == fx_add_sub_s) && (s1 == var1) && (s2 == var2)) - return (with_fx (tree, fx_add_sub_tu_s)); - } break; - - case HOP_SAFE_C_S_opSSq: - if (caddaddr (p) == var1) { - if ((fn_proc (p) == g_vector_ref_2) && - (is_defined_global (cadr (p)) && (is_defined_global (cadaddr (p))))) { - set_opt3_pair (p, cdaddr (p)); - return (with_fx (tree, fx_vref_g_vref_gt)); - } - if (pfunc == fx_c_s_opssq_direct) - return (with_fx (tree, fx_c_s_opstq_direct)); - } - if ((pfunc == 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 (((pfunc == fx_c_ac) || (pfunc == 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) && (pfunc == 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 ((pfunc == 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)))) { - const s7_pointer arg3p= cdddr (p); - set_opt1_sym (cdr (p), cadadr (p)); - if ((fx_proc (arg3p) == fx_is_null_cddr_t) || - (fx_proc (arg3p) == fx_is_null_cddr_s)) - return (with_fx (tree, fx_len2_t)); - if ((fx_proc (arg3p) == fx_is_pair_cddr_t) || - (fx_proc (arg3p) == fx_is_pair_cddr_s)) - return (with_fx (tree, fx_len3_t)); - } - break; - } - 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)) fprintf(stderr, "fx_tree %s %d %d\n", display(tree), - * has_fx(tree), is_syntax(car(tree))); */ - 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))) && - (is_pair (caadr (tree)))) /* (let (a) ...) */ - 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 opt_funcs_t* -alloc_semipermanent_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 base_func, opt_func_t typ, - void* opt_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_ip", - "o_d_pd", - "o_d_7p", - "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 (base_func)) { - fprintf (stderr, "%s[%d]: %s is not a c_function\n", __func__, __LINE__, - display (base_func)); - if (sc->stop_at_error) abort (); + liberate(sc, newp); + return(b); } - else if (c_function_opt_data (base_func)) - for (opt_funcs_t* p= c_function_opt_data (base_func); p; p= p->next) { - if (p->typ == typ) - fprintf (stderr, "%s[%d]: %s has a function of type %d (%s)\n", - __func__, __LINE__, display (base_func), typ, o_names[typ]); - if (p->func == opt_func) - fprintf (stderr, - "%s[%d]: %s already has this function as type %d %s (current: " - "%d %s)\n", - __func__, __LINE__, display (base_func), p->typ, - o_names[p->typ], typ, o_names[typ]); - } -#endif - op = alloc_semipermanent_opt_func (sc); - op->typ = typ; - op->func = opt_func; - op->next = c_function_opt_data (base_func); - c_function_opt_data (base_func)= op; } -static void* -opt_func (s7_pointer base_func, opt_func_t typ) { - if (is_c_function (base_func)) - for (opt_funcs_t* p= c_function_opt_data (base_func); p; p= p->next) - if (p->typ == typ) return (p->func); - return (NULL); -} +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; + s7_int loc, frames = 0; + s7_int top = (sc->stack_end - sc->stack_start) / 4; /* (*s7* 'stack_top), not stack_top(sc)! */ + begin_small_symbol_set(sc); -/* 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); -} /* mus_srate, mus_float_equal_fudge_factor clm2xen.c */ -s7_d_t -s7_d_function (s7_pointer f) { - return ((s7_d_t) opt_func (f, o_d)); + if (stacktrace_in_error_handler(sc, top)) + { + const s7_pointer err_code = slot_value(sc->error_code); + if ((is_pair(err_code)) && + (!tree_is_cyclic(sc, err_code))) + { + char *notes = NULL; + const s7_pointer current_let = let_outlet(sc->owlet); + const s7_pointer errstr = s7_object_to_string(sc, err_code, false); + const s7_pointer caller = 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, caller, err_code, string_value(errstr), notes, code_cols, as_comment); + str = (char *)block_data(strp); + if ((S7_DEBUGGING) && (notes == str)) fprintf(stderr, "%s[%d]: notes==str\n", __func__, __LINE__); + if (notes) free(notes); /* copied into strp, 29-Sep-23 -- see below: maybe check that notes!=str? */ + } + loc = stacktrace_find_error_hook_quit(sc); /* if OP_ERROR_HOOK_QUIT is in the stack, jump past it! */ + if (loc > 0) top = (loc + 1) / 4; + } + for (loc = top - 1; loc > 0; loc--) + { + const s7_int true_loc = (loc + 1) * 4 - 1; + const s7_pointer code = stack_code(sc->stack, true_loc); + if ((is_pair(code)) && + (!tree_is_cyclic(sc, code))) + { + const s7_pointer codep = s7_object_to_string(sc, code, false); + if (string_length(codep) > 0) + { + const char *codestr = string_value(codep); + if ((!local_strcmp(codestr, "(result)")) && + (!local_strcmp(codestr, "(#f)")) && + (!strstr(codestr, "(stacktrace)")) && + (!strstr(codestr, "(stacktrace "))) + { + const s7_pointer let = stack_let(sc->stack, true_loc); /* might not be let (gc stack protection etc) */ + const s7_pointer func = stacktrace_find_caller(sc, let); + if (!stacktrace_error_hook_function(sc, func)) + { + char *notes = NULL, *newstr, *catstr; + block_t *newp, *catp; + s7_int newlen; + + frames++; + if (frames > frames_max) + { + end_small_symbol_set(sc); + return(block_to_string(sc, strp, safe_strlen((char *)block_data(strp)))); + } + if ((is_let(let)) && (let != sc->rootlet)) + notes = stacktrace_walker(sc, code, let, NULL, code_cols, total_cols, notes_start_col, as_comment, 0); + newp = stacktrace_add_func(sc, func, code, codestr, notes, code_cols, as_comment); + newstr = (char *)block_data(newp); + if ((S7_DEBUGGING) && (notes == newstr)) fprintf(stderr, "%s[%d]: notes=newstr\n", __func__, __LINE__); + if ((notes) && (notes != newstr) && (is_let(let)) && (let != 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); + }}}}} + end_small_symbol_set(sc); + 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, + s7_integer_clamped_if_gmp(sc, car(sc->stacktrace_defaults)), + s7_integer_clamped_if_gmp(sc, cadr(sc->stacktrace_defaults)), + s7_integer_clamped_if_gmp(sc, caddr(sc->stacktrace_defaults)), + s7_integer_clamped_if_gmp(sc, cadddr(sc->stacktrace_defaults)), + s7_boolean(sc, s7_list_ref(sc, sc->stacktrace_defaults, 4)))); } -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)); +static s7_pointer g_stacktrace(s7_scheme *sc, s7_pointer args) +{ + #define H_stacktrace "(stacktrace (max-frames 30) (code-cols 45) (total-cols 80) (note-col 45) 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) + + /* now: 30, 45, 80, 45, #f and applied here as well as in s7_stacktrace, 22-Jan-25 */ + #define ST_MAX_FRAMES 30 + #define ST_CODE_COLS 45 + #define ST_TOTAL_COLS 80 + #define ST_NOTES_START_COL 45 + #define ST_AS_COMMENT false + + s7_int max_frames = s7_integer_clamped_if_gmp(sc, car(sc->stacktrace_defaults)); + s7_int code_cols = s7_integer_clamped_if_gmp(sc, cadr(sc->stacktrace_defaults)); + s7_int total_cols = s7_integer_clamped_if_gmp(sc, caddr(sc->stacktrace_defaults)); + s7_int notes_start_col = s7_integer_clamped_if_gmp(sc, cadddr(sc->stacktrace_defaults)); + bool as_comment = s7_boolean(sc, s7_list_ref(sc, sc->stacktrace_defaults, 4)); + + if (!is_null(args)) + { + if (!s7_is_integer(car(args))) + return(method_or_bust(sc, car(args), sc->stacktrace_symbol, args, sc->type_names[T_INTEGER], 1)); + max_frames = s7_integer_clamped_if_gmp(sc, car(args)); + if ((max_frames <= 0) || (max_frames > S7_INT32_MAX)) + max_frames = ST_MAX_FRAMES; + args = cdr(args); + if (!is_null(args)) + { + if (!s7_is_integer(car(args))) + wrong_type_error_nr(sc, sc->stacktrace_symbol, 2, car(args), sc->type_names[T_INTEGER]); + code_cols = s7_integer_clamped_if_gmp(sc, car(args)); + if ((code_cols <= 8) || (code_cols > 1024)) + code_cols = ST_CODE_COLS; + args = cdr(args); + if (!is_null(args)) + { + if (!s7_is_integer(car(args))) + wrong_type_error_nr(sc, sc->stacktrace_symbol, 3, car(args), sc->type_names[T_INTEGER]); + total_cols = s7_integer_clamped_if_gmp(sc, car(args)); + if ((total_cols <= code_cols) || (total_cols > S7_INT32_MAX)) + total_cols = ST_TOTAL_COLS; + args = cdr(args); + if (!is_null(args)) + { + if (!s7_is_integer(car(args))) + wrong_type_error_nr(sc, sc->stacktrace_symbol, 4, car(args), sc->type_names[T_INTEGER]); + notes_start_col = s7_integer_clamped_if_gmp(sc, car(args)); + if ((notes_start_col <= 0) || (notes_start_col > S7_INT32_MAX)) + notes_start_col = ST_NOTES_START_COL; + args = cdr(args); + if (!is_null(args)) + { + if (!is_boolean(car(args))) + wrong_type_error_nr(sc, sc->stacktrace_symbol, 5, car(args), sc->type_names[T_BOOLEAN]); + as_comment = s7_boolean(sc, car(args)); + }}}}} + return(stacktrace_1(sc, max_frames, code_cols, total_cols, notes_start_col, as_comment)); } -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)); -} +/* -------- s7_history, s7_add_to_history, s7_history_enabled -------- */ -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)); +s7_pointer s7_add_to_history(s7_scheme *sc, s7_pointer entry) +{ +#if WITH_HISTORY + set_current_code(sc, entry); +#endif + return(entry); } -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)); +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); } -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)); +bool s7_history_enabled(s7_scheme *sc) +{ +#if WITH_HISTORY + return(sc->cur_code != sc->history_sink); +#else + return(false); +#endif } -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)); +bool s7_set_history_enabled(s7_scheme *sc, bool enabled) +{ +#if WITH_HISTORY + const bool 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 } -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)); +#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_unchecked(p, args); + return(p); } +#else +#define history_cons(Sc, Code, Args) Code +#endif -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)); +/* -------------------------------- profile -------------------------------- */ +static void swap_stack(s7_scheme *sc, opcode_t new_op, s7_pointer new_code, s7_pointer new_args) +{ + s7_pointer code, args, let; + opcode_t op; + sc->stack_end -= 4; + code = stack_end_code(sc); + let = stack_end_let(sc); + args = stack_end_args(sc); + op = (opcode_t)T_Op(stack_end_op(sc)); + if ((S7_DEBUGGING) && (op != OP_BEGIN_NO_HOOK) && (op != OP_BEGIN_HOOK)) + fprintf(stderr, "%s[%d]: swap %s in %s\n", __func__, __LINE__, op_names[op], display(s7_name_to_value(sc, "estr"))); + push_stack(sc, new_op, new_args, new_code); + stack_end_code(sc) = code; + stack_end_let(sc) = let; + stack_end_args(sc) = args; + stack_end_op(sc) = (s7_pointer)op; + sc->stack_end += 4; } -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)); +static s7_pointer find_funclet(s7_scheme *sc, s7_pointer let) +{ + if ((let == sc->rootlet) || (!is_let(let))) return(sc->F); + if (!((is_funclet(let)) || (is_maclet(let)))) let = let_outlet(let); + if ((let == sc->rootlet) || (!is_let(let))) return(sc->F); + return(((is_funclet(let)) || (is_maclet(let))) ? let : sc->F); } -static void -s7_set_d_7p_function (s7_scheme* sc, s7_pointer f, s7_d_7p_t df) { - add_opt_func (sc, f, o_d_7p, (void*) df); -} -static s7_d_7p_t -s7_d_7p_function (s7_pointer f) { - return ((s7_d_7p_t) opt_func (f, o_d_7p)); -} +#define PD_INITIAL_SIZE 16 +enum {pd_calls = 0, pd_recur, pd_start, pd_itotal, pd_etotal, pd_block_size}; -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)); +static s7_pointer g_profile_out(s7_scheme *sc, s7_pointer args) +{ + const s7_int pos = integer(car(args)) * pd_block_size; + profile_data_t *pd = sc->profile_data; + s7_int *v = (s7_int *)(pd->timing_data + pos); + v[pd_recur]--; + if (v[pd_recur] == 0) + { + const s7_int 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); } -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 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, 3, sc->T, sc->is_integer_symbol, sc->is_let_symbol) -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)); -} + s7_pointer let; + const s7_int pos = integer(car(args)); + if (sc->profile == 0) return(sc-> F); -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)); -} + let = find_funclet(sc, cadr(args)); + if ((is_let(let)) && + (is_symbol(funclet_function(let)))) + { + const s7_pointer func_name = funclet_function(let); + s7_int *timing_data; + profile_data_t *pd = sc->profile_data; + if (pos >= pd->size) + { + const s7_int new_size = 2 * pos; + pd->funcs = (s7_pointer *)Realloc(pd->funcs, new_size * sizeof(s7_pointer)); + memclr((void *)(pd->funcs + pd->size), (new_size - pd->size) * sizeof(s7_pointer)); + pd->timing_data = (s7_int *)Realloc(pd->timing_data, new_size * pd_block_size * sizeof(s7_int)); + memclr((void *)(pd->timing_data + (pd->size * pd_block_size)), (new_size - pd->size) * pd_block_size * sizeof(s7_int)); + pd->let_names = (s7_pointer *)Realloc(pd->let_names, new_size * sizeof(s7_pointer)); + memclr((void *)(pd->let_names + pd->size), (new_size - pd->size) * sizeof(s7_pointer)); + pd->files = (s7_pointer *)Realloc(pd->files, new_size * sizeof(s7_pointer)); + memclr((void *)(pd->files + pd->size), (new_size - pd->size) * sizeof(s7_pointer)); + pd->lines = (s7_int *)Realloc(pd->lines, new_size * sizeof(s7_int)); + memclr((void *)(pd->lines + pd->size), (new_size - pd->size) * sizeof(s7_int)); + pd->size = new_size; + } + if (pd->funcs[pos] == NULL) + { + pd->funcs[pos] = func_name; + if (is_gensym(func_name)) sc->profiling_gensyms = true; + if (pos >= pd->top) pd->top = (pos + 1); -/* 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)); -} + /* perhaps add_profile needs to reuse ints if file/line exists? */ + if (is_symbol(sc->profile_prefix)) + { + s7_pointer let_name = s7_symbol_local_value(sc, sc->profile_prefix, let); + if (is_symbol(let_name)) pd->let_names[pos] = let_name; + } + if (has_let_file(let)) + { + pd->files[pos] = sc->file_names[let_file(let)]; + pd->lines[pos] = let_line(let); + }} + timing_data = (s7_int *)(sc->profile_data->timing_data + (pos * pd_block_size)); + timing_data[pd_calls]++; + if (timing_data[pd_recur] == 0) + { + timing_data[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; + } + timing_data[pd_recur]++; -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)); + /* 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) + error_nr(sc, make_symbol(sc, "stack-too-big", 13), + set_elist_2(sc, wrap_string(sc, "profiling stack size has grown past ~D", 38), wrap_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, car(args)); + } + return(sc->F); } -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)); +static s7_pointer profile_info_out(s7_scheme *sc) +{ + s7_pointer new_list, vs, vi, vn, vf, vl, matches; + profile_data_t *pd = sc->profile_data; + if ((!pd) || (pd->top == 0)) return(sc->F); + new_list = make_list(sc, 7, sc->F); + set_car(sc->elist_7, new_list); /* protect new_list */ + set_car(new_list, vs = make_simple_vector(sc, pd->top)); + set_car(cdr(new_list), vi = make_simple_int_vector(sc, pd->top * pd_block_size)); + set_car(cddr(new_list), make_integer(sc, ticks_per_second())); + { + s7_pointer mid_list = cdddr(new_list); + set_car(mid_list, vn = make_simple_vector(sc, pd->top)); + set_car(cdr(mid_list), vf = make_simple_vector(sc, pd->top)); + set_car(cddr(mid_list), vl = make_simple_int_vector(sc, pd->top)); + matches = cdddr(mid_list); + } + set_car(matches, sc->nil); + for (s7_int i = 0; i < pd->top; i++) + { + if (pd->funcs[i]) + { + vector_element(vs, i) = pd->funcs[i]; + if ((is_matched_symbol(pd->funcs[i])) && /* find ambiguous names */ + (!direct_memq(pd->funcs[i], car(matches)))) + set_car(matches, cons(sc, pd->funcs[i], car(matches))); + set_match_symbol(pd->funcs[i]); + } + else vector_element(vs, i) = sc->F; + vector_element(vn, i) = (!pd->let_names[i]) ? sc->F : pd->let_names[i]; + vector_element(vf, i) = (!pd->files[i]) ? sc->F : pd->files[i]; + } + for (s7_int i = 0; i < pd->top; i++) if (pd->funcs[i]) clear_match_symbol(pd->funcs[i]); + memcpy((void *)int_vector_ints(vl), (void *)pd->lines, pd->top * sizeof(s7_int)); + memcpy((void *)int_vector_ints(vi), (void *)pd->timing_data, pd->top * pd_block_size * sizeof(s7_int)); + set_car(sc->elist_7, sc->unused); + return(new_list); +} + +static s7_pointer clear_profile_info(s7_scheme *sc) +{ + if (sc->profile_data) + { + profile_data_t *pd = sc->profile_data; + memclr(pd->timing_data, pd->top * pd_block_size * sizeof(s7_int)); + memclr(pd->funcs, pd->top * sizeof(s7_pointer)); + memclr(pd->let_names, pd->top * sizeof(s7_pointer)); + memclr(pd->files, pd->top * sizeof(s7_pointer)); + memclr(pd->lines, pd->top * sizeof(s7_int)); + pd->top = 0; + for (int32_t 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 = (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->let_names = (s7_pointer *)Calloc(pd->size, sizeof(s7_pointer)); + pd->files = (s7_pointer *)Calloc(pd->size, sizeof(s7_pointer)); + pd->lines = (s7_int *)Calloc(pd->size, sizeof(s7_int)); + pd->excl = (s7_int *)Calloc(pd->excl_size, sizeof(s7_int)); + pd->timing_data = (s7_int *)Calloc(pd->size * pd_block_size, sizeof(s7_int)); + sc->profile_data = pd; + } + return(sc->F); } -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)); +/* -------------------------------- dynamic-unwind -------------------------------- */ +s7_pointer dynamic_unwind(s7_scheme *sc, s7_pointer func, s7_pointer args) +{ + return(s7_apply_function(sc, func, set_plist_2(sc, args, sc->value))); /* s7_apply_function returns sc->value */ } -/* 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 s7_pointer g_dynamic_unwind(s7_scheme *sc, s7_pointer args) /* not fool-proof!! */ +{ + #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, 4, sc->is_procedure_symbol, sc->is_procedure_symbol, sc->T, sc->is_boolean_symbol) -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)); + const s7_pointer func = car(args); + const s7_pointer dw_call = (is_pair(cddr(args))) ? caddr(args) : sc->F; + if (!is_boolean(dw_call)) + wrong_type_error_nr(sc, sc->dynamic_unwind_symbol, 2, dw_call, a_boolean_string); + if (((is_closure(func)) && (closure_arity_to_int(sc, func) == 2)) || + ((is_c_function(func)) && (c_function_is_aritable(func, 2))) || + ((is_closure_star(func)) && (closure_star_arity_to_int(sc, func) == 2)) || + ((is_c_function_star(func)) && (c_function_max_args(func) == 2))) + swap_stack(sc, OP_DYNAMIC_UNWIND, func, copy_proper_list(sc, cdr(args))); + else wrong_type_error_nr(sc, sc->dynamic_unwind_symbol, 1, func, wrap_string(sc, "a procedure of two arguments", 28)); + return(cadr(args)); /* ?? */ } -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)); -} +/* -------------------------------- 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 proc, err; -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); -} -static s7_i_iii_t -s7_i_iii_function (s7_pointer f) { - return ((s7_i_iii_t) opt_func (f, o_i_iii)); + /* 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. + * I think log as the second arg is an outer error (we don't wait until the catch is called, then fall into + * the local error handler). + */ + /* if ((is_let(err)) && (is_openlet(err))) if_let_method_exists_return_value(sc, err, sc->catch_symbol, args); */ /* causes exit from s7! */ + if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]\n", __func__, __LINE__); + + if (!is_pair(cdr(args))) /* (let ((mlet (openlet (inlet 'abs catch)))) (abs mlet)) -- this is a special case, avoid calling this everywhere */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_2(sc, wrap_string(sc, "catch: function missing: ~S", 27), set_ulist_1(sc, sc->catch_symbol, args))); + proc = cadr(args); + if (!is_thunk(sc, proc)) + { + if (is_any_procedure(proc)) /* i.e. c_function, lambda, macro, etc */ + { + s7_pointer req_args = wrap_integer(sc, procedure_required_args(sc, proc)); + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "~A requires ~D argument~P, but catch's second argument should be a thunk", 72), proc, req_args, req_args)); + } + else wrong_type_error_nr(sc, sc->catch_symbol, 2, proc, a_thunk_string); + } + if (!is_pair(cddr(args))) + error_nr(sc, sc->syntax_error_symbol, + set_elist_2(sc, wrap_string(sc, "catch: error handler missing: ~S", 32), set_ulist_1(sc, sc->catch_symbol, args))); + err = caddr(args); + if (!is_applicable(err)) + wrong_type_error_nr(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 + */ + { + s7_pointer new_catch; + new_cell(sc, new_catch, T_CATCH); + catch_tag(new_catch) = car(args); + catch_goto_loc(new_catch) = stack_top(sc); + catch_op_loc(new_catch) = (int32_t)(sc->op_stack_now - sc->op_stack); + catch_set_handler(new_catch, err); + catch_cstack(new_catch) = sc->goto_start; + push_stack(sc, (intptr_t)((is_any_macro(err)) ? OP_CATCH_2 : OP_CATCH), args, new_catch); + } + 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_pars(proc))) + set_curlet(sc, make_let_with_slot(sc, closure_let(proc), closure_pars(proc), sc->nil)); + else set_curlet(sc, inline_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); } -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)); -} +s7_pointer s7_call_with_catch(s7_scheme *sc, s7_pointer tag, s7_pointer body, s7_pointer error_handler) +{ + s7_pointer new_catch, result; + if (sc->stack_end == sc->stack_start) /* no stack! */ + push_stack_direct(sc, OP_EVAL_DONE); + + if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]\n", __func__, __LINE__); + new_cell(sc, new_catch, T_CATCH); + catch_tag(new_catch) = tag; + catch_goto_loc(new_catch) = stack_top(sc); + catch_op_loc(new_catch) = (int32_t)(sc->op_stack_now - sc->op_stack); + catch_set_handler(new_catch, error_handler); + catch_cstack(new_catch) = sc->goto_start; + { + declare_jump_info(); + TRACK(sc); + store_jump_info(sc); + set_jump_info(sc, s7_call_set_jump); -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)); + if (SHOW_EVAL_OPS) fprintf(stderr, "jump_loc: %s\n", jump_string[(int)jump_loc]); + if (jump_loc == no_jump) + { + catch_cstack(new_catch) = &new_goto_start; + if (SHOW_EVAL_OPS) fprintf(stderr, " longjmp call %s\n", display_truncated(body)); + push_stack(sc, OP_CATCH, error_handler, new_catch); + result = s7_call(sc, body, sc->nil); + if (stack_top_op(sc) == OP_CATCH) sc->stack_end -= 4; + } + else + { + if (SHOW_EVAL_OPS) fprintf(stderr, " jump back with %s (%d)\n", jump_string[(int)jump_loc], (sc->stack_end == sc->stack_start)); + if (jump_loc != error_jump) + eval(sc, sc->cur_op); + if ((jump_loc == catch_jump) && /* we're returning from an error in catch */ + ((sc->stack_end == sc->stack_start) || + (((sc->stack_end - 4) == sc->stack_start) && (stack_top_op(sc) == OP_GC_PROTECT)))) /* s7_apply_function probably */ + push_stack_op(sc, OP_ERROR_QUIT); + result = sc->value; + } + restore_jump_info(sc); + } + return(result); } -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 op_c_catch(s7_scheme *sc) +{ + /* (catch #t (lambda () (set! ("hi") #\a)) (lambda args args)) + * code is (catch #t (lambda () ....) (lambda args ....)) + */ + s7_pointer new_catch, tag; + const s7_pointer ptag = cadr(sc->code), args = cddr(sc->code); -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)); + /* defer making the error lambda */ + if (!is_pair(ptag)) /* (catch #t ...) or (catch sym ...) */ + tag = (is_symbol(ptag)) ? lookup_checked(sc, ptag) : ptag; + else tag = cadr(ptag); /* (catch 'sym ...) */ + + new_cell(sc, new_catch, T_CATCH); /* the catch object sitting on the stack */ + catch_tag(new_catch) = tag; + catch_goto_loc(new_catch) = stack_top(sc); + catch_op_loc(new_catch) = sc->op_stack_now - sc->op_stack; + catch_set_handler(new_catch, cdadr(args)); /* not yet a closure... */ + catch_cstack(new_catch) = sc->goto_start; + push_stack(sc, OP_CATCH_1, sc->code, new_catch); /* code ignored here, except by GC */ + set_curlet(sc, inline_make_let(sc, sc->curlet)); + sc->code = T_Pair(cddar(args)); +} + +static void op_c_catch_all(s7_scheme *sc) +{ + s7_pointer new_catch; + new_cell(sc, new_catch, T_CATCH); + catch_tag(new_catch) = sc->T; + catch_goto_loc(new_catch) = stack_top(sc); + catch_op_loc(new_catch) = sc->op_stack_now - sc->op_stack; + catch_set_handler(new_catch, sc->nil); + catch_cstack(new_catch) = sc->goto_start; + push_stack(sc, OP_CATCH_ALL, opt2_con(sc->code), new_catch); /* push_stack: op args code */ + sc->code = T_Pair(opt1_pair(cdr(sc->code))); /* the body of the first lambda (or car of it if catch_all_o) */ } -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 op_c_catch_all_a(s7_scheme *sc) +{ + op_c_catch_all(sc); + sc->value = fx_call(sc, sc->code); } -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)); -} +/* -------------------------------- owlet -------------------------------- */ +/* error reporting info -- save filename and line number */ -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 s7_pointer init_owlet(s7_scheme *sc) +{ + s7_pointer p; /* watch out for order below */ + const s7_pointer let = make_let(sc, sc->rootlet); + begin_temp(sc->x, let); + sc->error_type = add_slot_checked_with_id(sc, let, make_symbol(sc, "error-type", 10), sc->F); /* the error type or tag ('division-by-zero) */ + sc->error_data = add_slot_unchecked_with_id(sc, let, make_symbol(sc, "error-data", 10), sc->F); /* the message or information passed by the error function */ + sc->error_code = add_slot_unchecked_with_id(sc, let, make_symbol(sc, "error-code", 10), sc->F); /* the code that s7 thinks triggered the error */ + sc->error_line = add_slot_unchecked_with_id(sc, let, make_symbol(sc, "error-line", 10), p = make_permanent_integer(0)); /* the line number of that code */ + add_saved_pointer(sc, p); + sc->error_file = add_slot_unchecked_with_id(sc, let, make_symbol(sc, "error-file", 10), sc->F); /* the file name of that code */ + sc->error_position = add_slot_unchecked_with_id(sc, let, make_symbol(sc, "error-position", 14), p = make_permanent_integer(0)); /* file-byte position of that code */ + add_saved_pointer(sc, p); +#if WITH_HISTORY + sc->error_history = add_slot_unchecked_with_id(sc, let, make_symbol(sc, "error-history", 13), sc->F); /* buffer of previous evaluations */ +#endif + end_temp(sc->x); + return(let); } -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)); +#if WITH_HISTORY +s7_pointer sanitize_history(s7_scheme *sc, s7_pointer code) +{ + begin_small_symbol_set(sc); /* make a list of words banned from the history */ + add_symbol_to_small_symbol_set(sc, sc->starlet_symbol); + add_symbol_to_small_symbol_set(sc, sc->eval_symbol); + add_symbol_to_small_symbol_set(sc, make_symbol(sc, "debug", 5)); + add_symbol_to_small_symbol_set(sc, make_symbol(sc, "trace-in", 8)); + add_symbol_to_small_symbol_set(sc, make_symbol(sc, "trace-out", 9)); + add_symbol_to_small_symbol_set(sc, sc->dynamic_unwind_symbol); + add_symbol_to_small_symbol_set(sc, make_symbol(sc, "history-enabled", 15)); + for (s7_pointer p = code; is_pair(p); p = cdr(p)) + { + if ((is_pair(car(p))) && (!is_quote(sc, car(p))) && (pair_set_memq(sc, car(p)))) + set_car(p, sc->nil); + if (cdr(p) == code) break; + } + end_small_symbol_set(sc); + return(code); } +#endif -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)); -} +/* g_owlet moved to s7_scheme_let.c */ +#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) -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)); +/* -------- catch handlers -------- (don't free the catcher) */ +static void load_catch_cstack(s7_scheme *sc, s7_pointer catcher) +{ + if (catch_cstack(catcher)) + sc->goto_start = catch_cstack(catcher); } -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 bool catch_all_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info) +{ + const s7_pointer catcher = T_Cat(stack_code(sc->stack, catch_loc)); + if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__); + sc->value = stack_args(sc->stack, catch_loc); /* error result, optimize_func_three_args -> op_c_catch_all etc */ + if (sc->value == sc->unused) sc->value = type; + sc->op_stack_now = (s7_pointer *)(sc->op_stack + catch_op_loc(catcher)); + sc->stack_end = (s7_pointer *)(sc->stack_start + catch_goto_loc(catcher)); + load_catch_cstack(sc, catcher); + pop_stack(sc); + return(true); +} + +static bool catch_2_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info) +{ + /* 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)) + */ + const s7_pointer cat = T_Cat(stack_code(sc->stack, catch_loc)); + if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__); + if ((catch_tag(cat) == sc->T) || (catch_tag(cat) == type) || (type == sc->T)) + { + sc->op_stack_now = (s7_pointer *)(sc->op_stack + catch_op_loc(cat)); + sc->stack_end = (s7_pointer *)(sc->stack_start + catch_goto_loc(cat)); + sc->code = catch_handler(cat); + load_catch_cstack(sc, cat); + if (needs_copied_args(sc->code)) + sc->args = list_2(sc, type, info); + else sc->args = with_list_t2(sc, type, info); /* very unlikely: need c_macro as error catcher: (catch #t (lambda () (error 'oops)) require) */ + sc->cur_op = OP_APPLY; + return(true); + } + return(false); } -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 bool catch_1_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info) +{ + const s7_pointer catcher = T_Cat(stack_code(sc->stack, catch_loc)); + if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__); + if ((catch_tag(catcher) == sc->T) || /* the normal case */ + (catch_tag(catcher) == type) || + (type == sc->T)) + { + const opcode_t op = stack_op(sc->stack, catch_loc); + const s7_pointer error_func = catch_handler(catcher); + const s7_uint loc = catch_goto_loc(catcher); + s7_pointer error_body, error_pars; + + begin_temp(sc->y, type); + sc->value = info; + sc->temp4 = stack_let(sc->stack, catch_loc); /* GC protect this, since we're moving the stack top below */ + sc->op_stack_now = (s7_pointer *)(sc->op_stack + catch_op_loc(catcher)); + sc->stack_end = (s7_pointer *)(sc->stack_start + loc); + load_catch_cstack(sc, 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) + */ -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)); + /* 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_pars = car(error_func); + } + else + if (is_closure(error_func)) + { + error_body = closure_body(error_func); + error_pars = closure_pars(error_func); + } + else + { + error_body = NULL; + error_pars = NULL; + } + if ((error_body) && (is_null(cdr(error_body)))) + { + s7_pointer val = NULL; + error_body = car(error_body); + if (is_pair(error_body)) + { + if (is_quote(sc, car(error_body))) + val = cadr(error_body); + else + if ((car(error_body) == sc->car_symbol) && + (is_pair(cdr(error_body))) && /* catch: (lambda args (car args)) */ + (cadr(error_body) == error_pars)) + val = type; + } + else + if (!is_symbol(error_body)) + val = error_body; /* not pair or symbol */ + else + if (error_body == error_pars) + val = list_2(sc, type, info); + else + if (is_keyword(error_body)) + val = error_body; + else + if ((is_pair(error_pars)) && + (error_body == car(error_pars))) + val = type; + if (val) + { + if ((SHOW_EVAL_OPS) && (loc > 4)) {fprintf(stderr, " about to pop_stack: \n"); s7_show_stack(sc);} + 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 = val; + end_temp(sc->y); + sc->temp4 = sc->unused; + sc->w = sc->unused; + 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); + }} + /* here type and info need to be GC protected (new_cell below), g_throw and error_nr, throw sc->w for type, but error_nr nothing currently */ + if (op == OP_CATCH_1) + { + s7_pointer new_func; + new_cell(sc, new_func, T_CLOSURE); + closure_set_pars(new_func, car(error_func)); + closure_set_body(new_func, cdr(error_func)); + closure_set_setter(new_func, sc->F); + closure_set_arity(new_func, CLOSURE_ARITY_NOT_SET); + closure_set_let(new_func, sc->temp4); + sc->code = new_func; + if ((S7_DEBUGGING) && (!s7_is_aritable(sc, sc->code, 2))) fprintf(stderr, "%s[%d]: errfunc not aritable(2)!\n", __func__, __LINE__); + } + else + { + sc->code = error_func; + end_temp(sc->y); + if (!s7_is_aritable(sc, sc->code, 2)) /* op_catch_1 from op_c_catch already checks this */ + wrong_number_of_arguments_error_nr(sc, "catch error handler should accept two arguments: ~S", 51, sc->code); + } + sc->temp4 = sc->unused; + /* 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! + */ + sc->args = list_2(sc, type, info); /* almost never able to skip this -- costs more to check! */ + sc->w = sc->unused; + end_temp(sc->y); + 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); } -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); -} -s7_p_p_t -s7_p_p_function (s7_pointer f) { - return ((s7_p_p_t) opt_func (f, o_p_p)); +static bool catch_dynamic_wind_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info) +{ + const s7_pointer dw = T_Dyn(stack_code(sc->stack, catch_loc)); + if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__); + if (dynamic_wind_state(dw) == dwind_body) + { + dynamic_wind_state(dw) = dwind_finish; /* make sure an uncaught error in the exit thunk doesn't cause us to loop */ + if (dynamic_wind_out(dw) != sc->F) + sc->value = s7_call(sc, dynamic_wind_out(dw), sc->nil); + } + return(false); } -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 bool catch_out_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info) +{ + s7_pointer port = T_Pro(stack_code(sc->stack, catch_loc)); /* "code" = port that we opened */ + if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__); + s7_close_output_port(sc, port); + port = stack_args(sc->stack, catch_loc); /* "args" = port that we shadowed, if not # */ + if (port != sc->unused) + set_current_output_port(sc, port); + return(false); } -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); -} -s7_p_pp_t -s7_p_pp_function (s7_pointer f) { - return ((s7_p_pp_t) opt_func (f, o_p_pp)); +static bool catch_in_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info) +{ + s7_pointer port = T_Pri(stack_code(sc->stack, catch_loc)); /* "code" = port that we opened */ + if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__); + s7_close_input_port(sc, port); + port = stack_args(sc->stack, catch_loc); /* "args" = port that we shadowed, if not # */ + if (port != sc->unused) + set_current_input_port(sc, port); + return(false); } -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); -} -s7_p_ppp_t -s7_p_ppp_function (s7_pointer f) { - return ((s7_p_ppp_t) opt_func (f, o_p_ppp)); +static bool catch_read_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info) +{ + if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__); + pop_input_port(sc); + return(false); } -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 bool catch_eval_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info) +{ + if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__); + s7_close_input_port(sc, current_input_port(sc)); + pop_input_port(sc); + return(false); } -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 bool catch_barrier_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info) +{ /* can this happen? is it doing the right thing? read/eval/call_begin_hook push_stack op_barrier but only s7_read includes a port (this is not hit in s7test.scm) */ + if (SHOW_EVAL_OPS || S7_DEBUGGING) fprintf(stderr, "catcher: %s\n", __func__); + if (is_input_port(stack_args(sc->stack, catch_loc))) + { + if (current_input_port(sc) == stack_args(sc->stack, catch_loc)) + pop_input_port(sc); + s7_close_input_port(sc, stack_args(sc->stack, catch_loc)); + } + return(false); } -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 bool catch_error_hook_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info) +{ /* from op_error_hook_quit */ + if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__); + let_set_2(sc, closure_let(sc->error_hook), sc->body_symbol, stack_code(sc->stack, catch_loc)); + /* apparently there was an error during *error-hook* evaluation, but Rick wants the hook re-established anyway */ + sc->reset_error_hook = true; + /* avoid infinite loop -- don't try to (re-)evaluate (buggy) *error-hook*! */ + return(false); } -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 bool catch_goto_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info) +{ + if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__); + call_exit_active(stack_args(sc->stack, catch_loc)) = false; + return(false); } -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 bool catch_map_unwind_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info) +{ + if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__); + sc->map_call_ctr--; + if ((S7_DEBUGGING) && (sc->map_call_ctr < 0)) {fprintf(stderr, "%s[%d]: map ctr: %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr); sc->map_call_ctr = 0;} + return(false); } -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 bool catch_let_temporarily_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info) +{ + if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__); + let_temp_done(sc, stack_args(sc->stack, catch_loc), T_Let(stack_let(sc->stack, catch_loc))); + return(false); } -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)); +bool catch_let_temp_unwind_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info) +{ + const s7_pointer slot = stack_code(sc->stack, catch_loc); + const s7_pointer val = stack_args(sc->stack, catch_loc); + if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s, unwind setting %s to %s\n", __func__, display_truncated(slot), display_truncated(val)); + if (is_immutable_slot(slot)) /* we're already in an error/throw situation, so raising an error here leads to an infinite loop */ + s7_warn(sc, 512, "let-temporarily can't reset %s to %s: it is immutable!", symbol_name(slot_symbol(slot)), display(val)); + else slot_set_value(slot, val); + return(false); } -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 bool catch_let_temp_s7_unwind_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info) +{ + const s7_pointer symbol = stack_code(sc->stack, catch_loc); + if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__); + if (starlet_symbol_id(symbol) != sl_no_field) /* we could be unwinding from an error that the symbol is not defined in *s7*! */ + starlet_set_1(sc, symbol, stack_args(sc->stack, catch_loc)); + return(false); } -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 bool catch_let_temp_s7_openlets_unwind_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info) +{ + if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__); + sc->has_openlets = (stack_args(sc->stack, catch_loc) != sc->F); + return(false); } -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)); +bool catch_dynamic_unwind_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info) +{ + /* if func has an error, s7_error will call it as it unwinds the stack -- an infinite loop. So, cancel the unwind first */ + if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__); + set_stack_op(sc->stack, catch_loc, 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 = lookup_slot_with_let(sc, make_symbol(sc, "*debug-spaces*", 14), T_Let(stack_let(sc->stack, catch_loc))); + 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); } -static opt_info* -alloc_opt_info (s7_scheme* sc) { - opt_info* o; - if (sc->pc >= OPTS_SIZE) sc->pc= OPTS_SIZE - 1; - o = sc->opts[sc->pc++]; - q_temp (o).fd= NULL; /* see bool_optimize -- this is a kludge */ -#if S7_DEBUGGING - for (int i= 0; i < num_vunions; i++) - o->v[i].p= NULL; -#endif - return (o); +static bool catch_load_close_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info) +{ + if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__); + if ((S7_DEBUGGING) && (!is_loader_port(current_input_port(sc)))) fprintf(stderr, "%s[%d]: %s not loading?\n", __func__, __LINE__, display(current_input_port(sc))); + if (SHOW_EVAL_OPS) fprintf(stderr, "%s closing %s\n", __func__, display(current_input_port(sc))); + + /* this looks like catch_eval_function */ + s7_close_input_port(sc, current_input_port(sc)); + pop_input_port(sc); + /* sc->current_file = NULL; */ + return(false); } -#define backup_pc(sc) sc->pc-- +typedef bool (*catch_function_t)(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info); +static catch_function_t catchers[NUM_OPS]; -#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[%d]: %s\n", func, line, display_truncated (expr)); - else fprintf (stderr, " %s[%d]: false\n", func, line); - return (false); +static void init_catchers(void) +{ + for (int32_t i = 0; i < NUM_OPS; i++) catchers[i] = NULL; + catchers[OP_BARRIER] = catch_barrier_function; + catchers[OP_CATCH] = catch_1_function; + catchers[OP_CATCH_1] = catch_1_function; + catchers[OP_CATCH_2] = catch_2_function; + catchers[OP_CATCH_ALL] = catch_all_function; + catchers[OP_DEACTIVATE_GOTO] = catch_goto_function; + catchers[OP_DYNAMIC_UNWIND] = catch_dynamic_unwind_function; + catchers[OP_DYNAMIC_WIND] = catch_dynamic_wind_function; + catchers[OP_ERROR_HOOK_QUIT] = catch_error_hook_function; + catchers[OP_EVAL_STRING] = catch_eval_function; + catchers[OP_GET_OUTPUT_STRING] = catch_out_function; + catchers[OP_LET_TEMP_DONE] = catch_let_temporarily_function; + catchers[OP_LET_TEMP_S7_OPENLETS_UNWIND] = catch_let_temp_s7_openlets_unwind_function; + catchers[OP_LET_TEMP_S7_UNWIND] = catch_let_temp_s7_unwind_function; + catchers[OP_LET_TEMP_UNWIND] = catch_let_temp_unwind_function; + catchers[OP_MAP_UNWIND] = catch_map_unwind_function; + catchers[OP_READ_DONE] = catch_read_function; /* perhaps an error during (read) */ + catchers[OP_UNWIND_INPUT] = catch_in_function; + catchers[OP_UNWIND_OUTPUT] = catch_out_function; + catchers[OP_LOAD_CLOSE_AND_POP_IF_EOF] = catch_load_close_function; + /* do we need one for load_return_if_eof? */ } -#define return_true(Sc, Expr) \ - return (return_true_1 (Sc, Expr, __func__, __LINE__)) -static bool -return_true_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 blue_text, func, line, - unbold_text uncolor_text, display_truncated (expr)); - else - fprintf (stderr, " %s%s[%d]%s: true\n", blue_text, func, line, - uncolor_text); - return (true); -} - -#define return_success(Sc, P, Expr) \ - return (return_success_1 (Sc, P, Expr, __func__, __LINE__)) -static s7_pfunc -return_success_1 (s7_scheme* sc, s7_pfunc p, s7_pointer expr, const char* func, - int32_t line) { - fprintf (stderr, " %s%s[%d]%s: %s\n", bold_text green_text, func, line, - unbold_text uncolor_text, display (expr)); - 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, int32_t line) { - fprintf (stderr, " %s%s[%d]%s: %s\n %sfailure%s\n", bold_text, func, line, - unbold_text, display_truncated (expr), bold_text red_text, - unbold_text uncolor_text); - return (NULL); -} - -#define return_bool(Sc, Bool, Expr) \ - return (return_bool_1 (Sc, Bool, Expr, __func__, __LINE__)) -static bool -return_bool_1 (s7_scheme* sc, bool ok, s7_pointer expr, const char* func, - int32_t line) { - if (expr) - fprintf (stderr, " %s%s[%d]%s: %s\n", (ok) ? bold_text blue_text : "", - func, line, (ok) ? unbold_text uncolor_text : "", - display_truncated (expr)); - else - fprintf (stderr, " %s%s[%d]%s: %s\n", (ok) ? blue_text : "", func, line, - (ok) ? uncolor_text : "", (ok) ? "true" : "false"); - return (ok); +/* -------------------------------- 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 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) + + const s7_pointer type = car(args), info = cdr(args); + gc_protect_via_stack(sc, args); + /* type can be anything: (throw (list 1 2 3) (make-list 512)), sc->w and sc->value not good here for gc protection */ + + for (s7_int op_loc = stack_top(sc) - 5; op_loc >= 3; op_loc -= 4) /* look for a catcher */ + { + catch_function_t catcher = catchers[stack_op(sc->stack, op_loc)]; + if ((catcher) && + (catcher(sc, op_loc, type, info))) + { + if (sc->longjmp_ok) LongJmp(*(sc->goto_start), throw_jump); + return(sc->value); + }} + if (is_let(car(args))) + if_let_method_exists_return_value(sc, car(args), sc->throw_symbol, args); + error_nr(sc, make_symbol(sc, "uncaught-throw", 14), + set_elist_3(sc, wrap_string(sc, "no catch found for (throw ~W~{~^ ~S~})", 38), type, info)); + return(sc->F); } + + +/* -------------------------------- warn -------------------------------- */ +#if WITH_GCC +static __attribute__ ((format (printf, 3, 4))) void s7_warn(s7_scheme *sc, s7_int len, const char *ctrl, ...) #else -#define return_false(Sc, Expr) return (false) -#define return_true(Sc, Expr) return (true) -#define return_success(Sc, P, Expr) return (P) -#define return_null(Sc, Expr) return (NULL) -#define return_bool(Sc, Bool, Expr) return (Bool) +static void s7_warn(s7_scheme *sc, s7_int len, const char *ctrl, ...) /* len = max size of output string (for vsnprintf) */ #endif - -static s7_pointer -opt_integer_symbol (s7_scheme* sc, s7_pointer sym) { - if (is_symbol (sym)) { - s7_pointer slot= s7_slot (sc, sym); - if ((is_slot (slot)) && /* here and below, p can be # (if in - rootlet) */ - (is_t_integer (slot_value (slot)))) - return (slot); - } - return (NULL); +{ + if ((current_error_port(sc) != sc->F) && (!sc->muffle_warnings)) + { + int32_t bytes; + va_list ap; + block_t *b = mallocate(sc, len); + char *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(current_error_port(sc))) + set_current_error_port(sc, sc->standard_error); + if ((bytes > 0) && (current_error_port(sc) != sc->F)) + port_write_string(current_error_port(sc))(sc, str, bytes, current_error_port(sc)); + liberate(sc, b); + } } -static s7_pointer -opt_real_symbol (s7_scheme* sc, s7_pointer sym) { - if (is_symbol (sym)) { - s7_pointer slot= s7_slot (sc, sym); - if ((is_slot (slot)) && (is_small_real (slot_value (slot)))) return (slot); - } - return (NULL); -} -static s7_pointer -opt_float_symbol (s7_scheme* sc, s7_pointer sym) { - if (is_symbol (sym)) { - s7_pointer slot= s7_slot (sc, sym); - if ((is_slot (slot)) && (is_t_real (slot_value (slot)))) return (slot); - } - return (NULL); +/* -------------------------------- error -------------------------------- */ +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)))) + { + set_integer(slot_value(sc->error_line), port_line_number(current_input_port(sc))); + set_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 + { + set_integer(slot_value(sc->error_line), 0); + set_integer(slot_value(sc->error_position), 0); + slot_set_value(sc->error_file, sc->F); + } } -static s7_pointer -opt_simple_symbol (s7_scheme* sc, s7_pointer sym) { - s7_pointer slot= s7_slot (sc, sym); - if ((is_slot (slot)) && (!has_methods (slot_value (slot)))) return (slot); - return (NULL); +static void format_to_error_port(s7_scheme *sc, const char *str, s7_pointer args, s7_int len) +{ + if (current_error_port(sc) != sc->F) + format_to_port_1(sc, current_error_port(sc), str, args, NULL, false, true /* is_columnizing(str) */, len, NULL); + /* is_columnizing on every call is much slower than ignoring the issue */ } -static s7_pointer -opt_types_match (s7_scheme* sc, s7_pointer check, s7_pointer sym) { - s7_pointer checker= s7_symbol_value (sc, check); - s7_pointer slot = s7_slot (sc, sym); - if (is_slot (slot)) { - s7_pointer obj= slot_value (slot); - if (s7_apply_function (sc, checker, set_plist_1 (sc, obj)) == sc->T) - return (slot); - } - return (NULL); -} - -static s7_pointer -opt_bool_any (s7_scheme* sc) { - opt_info* o= sc->opts[0]; - return ((q_call (o).fb (o)) ? sc->T : sc->F); -} -static s7_pointer -opt_float_any_nv (s7_scheme* sc) { - opt_info* o= sc->opts[0]; - q_call (o).fd (o); - return (NULL); -} -static s7_pointer -opt_int_any_nv (s7_scheme* sc) { - opt_info* o= sc->opts[0]; - q_call (o).fi (o); - return (NULL); -} -static s7_pointer -opt_bool_any_nv (s7_scheme* sc) { - opt_info* o= sc->opts[0]; - q_call (o).fb (o); - return (NULL); -} -static s7_pointer -opt_cell_any_nv (s7_scheme* sc) { - opt_info* o= sc->opts[0]; - return (q_call (o).fp (o)); -} /* this is faster than returning null */ - -static s7_pointer -opt_make_float (s7_scheme* sc) { - opt_info* o= sc->opts[0]; - return (make_real (sc, q_call (o).fd (o))); -} -static s7_pointer -opt_make_int (s7_scheme* sc) { - opt_info* o= sc->opts[0]; - return (make_integer (sc, q_call (o).fi (o))); -} -static s7_pointer -opt_wrap_cell (s7_scheme* sc) { - opt_info* o= sc->opts[0]; - return (q_call (o).fp (o)); -} -static s7_pointer -opt_wrap_bool (s7_scheme* sc) { - opt_info* o= sc->opts[0]; - return ((q_call (o).fb (o)) ? sc->T : sc->F); -} - -static bool -p_to_b (opt_info* o) { - return (q_temp (o).fp (o) != o->sc->F); -} -static s7_pointer -d_to_p (opt_info* o) { - return (make_real (o->sc, q_temp (o).fd (o))); -} -static s7_pointer -d_to_p_nr (opt_info* o) { - q_temp (o).fd (o); - return (NULL); -} -static s7_pointer -i_to_p (opt_info* o) { - return (make_integer (o->sc, q_temp (o).fi (o))); -} -static s7_pointer -i_to_p_nr (opt_info* o) { - q_temp (o).fi (o); - return (NULL); -} - -#define q_arg1(o) o->v[1] -#define q_arg2(o) o->v[2] -#define q_arg3(o) o->v[12] -#define q_arg4(o) o->v[13] -#define q_arg5(o) o->v[14] /* 14 shared with q_temp, q_sort maybe others */ -#define q_func(o) o->v[3] -#define q_func1(o) o->v[5] -#define q_func1_arg(o) o->v[4] -#define q_func2(o) o->v[11] -#define q_func2_arg(o) o->v[10] -#define q_func3(o) o->v[9] -#define q_func3_arg(o) o->v[8] -#define q_func4(o) o->v[7] -#define q_func4_arg(o) o->v[6] - -#define q_i_func1_call(o) q_func1 (o).fi (q_func1_arg (o).o1) -#define q_d_func1_call(o) q_func1 (o).fd (q_func1_arg (o).o1) -#define q_b_func1_call(o) q_func1 (o).fb (q_func1_arg (o).o1) -#define q_p_func1_call(o) q_func1 (o).fp (q_func1_arg (o).o1) +no_return void error_nr(s7_scheme *sc, s7_pointer type, s7_pointer info) +{ /* half the reported compute time here is in the longjmp after the catcher runs */ + s7_pointer cur_code = current_code(sc); +#if WITH_HISTORY + if ((is_free(cur_code)) || (cur_code == sc->unused)) cur_code = sc->F; +#endif -#define q_i_func2_call(o) q_func2 (o).fi (q_func2_arg (o).o1) -#define q_d_func2_call(o) q_func2 (o).fd (q_func2_arg (o).o1) -#define q_b_func2_call(o) q_func2 (o).fb (q_func2_arg (o).o1) -#define q_p_func2_call(o) q_func2 (o).fp (q_func2_arg (o).o1) + sc->format_depth = -1; + 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, op_?_unwind */ + sc->do_body_p = NULL; +#if S7_DEBUGGING + sc->small_symbol_set_state = set_ignore; + sc->big_symbol_set_state = set_ignore; + sc->v = sc->unused; + sc->x = sc->unused; + sc->y = sc->unused; + sc->temp3 = sc->unused; + sc->temp6 = sc->unused; + sc->temp7 = sc->unused; + sc->temp9 = sc->unused; +#endif + sc->value = info; /* feeble GC protection (otherwise info is sometimes freed in this function), throw also protects type */ -#define q_i_func3_call(o) q_func3 (o).fi (q_func3_arg (o).o1) -#define q_d_func3_call(o) q_func3 (o).fd (q_func3_arg (o).o1) -#define q_b_func3_call(o) q_func3 (o).fb (q_func3_arg (o).o1) /* none?? */ -#define q_p_func3_call(o) q_func3 (o).fp (q_func3_arg (o).o1) + if (sc->current_safe_list > 0) + clear_safe_list_in_use(sc, sc->safe_lists[sc->current_safe_list]); /* clears current_safe_list */ + slot_set_value(sc->error_type, type); + slot_set_value(sc->error_data, info); + if (type_unchecked(sc->curlet) != T_LET) + set_curlet(sc, sc->rootlet); /* 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); + slot_set_value(sc->error_code, cur_code); /* if mv here, evalable code has the mv bit set, maybe from c-macro that uses s7_values */ -#define q_i_func4_call(o) q_func4 (o).fi (q_func4_arg (o).o1) -#define q_d_func4_call(o) q_func4 (o).fd (q_func4_arg (o).o1) -#define q_b_func4_call(o) q_func4 (o).fb (q_func4_arg (o).o1) /* none?? */ -#define q_p_func4_call(o) q_func4 (o).fp (q_func4_arg (o).o1) +#if WITH_HISTORY + slot_set_value(sc->error_history, sc->cur_code); + if (sc->cur_code != sc->history_sink) + { + int32_t i = 0; + sc->cur_code = (sc->using_history1) ? sc->eval_history2 : sc->eval_history1; + sc->using_history1 = (!sc->using_history1); + for (s7_pointer p = sc->cur_code; i < sc->history_size; i++, p = cdr(p)) car(p) = sc->nil; + } +#endif + if (is_pair(cur_code)) /* not redundant -- maybe use type_unchecked here */ + { + s7_int line = -1, file, position; + if (has_location(cur_code)) /* ignore callgrind! this is the normal case */ + { + line = pair_line_number(cur_code); + file = pair_file_number(cur_code); + position = pair_position(cur_code); + } + else /* try to find a plausible line number! */ + for (s7_pointer p = cur_code, sp = cur_code; is_pair(p); p = cdr(p), sp = cdr(sp)) + { + if ((is_pair(car(p))) && (has_location(car(p)))) + { + line = pair_line_number(car(p)); + file = pair_file_number(car(p)); + position = pair_position(car(p)); + break; + } + p = cdr(p); + if ((!is_pair(p)) || (p == sp)) break; + /* p itself never has the line/file info */ + if ((is_pair(car(p))) && (has_location(car(p)))) + { + line = pair_line_number(car(p)); + file = pair_file_number(car(p)); + position = pair_position(car(p)); + break; + }} + if ((line <= 0) || (file < 0)) + fill_error_location(sc); + else + { + set_integer(slot_value(sc->error_line), line); + set_integer(slot_value(sc->error_position), position); + slot_set_value(sc->error_file, sc->file_names[file]); + }} + else fill_error_location(sc); + + /* look for a catcher, call catch*function in the error context (before unwinding the stack), outlet(owlet) is curlet */ + /* top is 1 past actual top, top - 1 is op, if op = OP_CATCH, top - 4 is the cell containing the catch struct */ + for (s7_int op_loc = stack_top(sc) - 1; op_loc >= 3; op_loc -= 4) + { + catch_function_t catcher = catchers[stack_op(sc->stack, op_loc)]; + if ((SHOW_EVAL_OPS) && (catcher)) {fprintf(stderr, "before catch:\n"); s7_show_stack(sc);} + if ((catcher) && + (catcher(sc, op_loc, type, info))) + { + if (SHOW_EVAL_OPS) {fprintf(stderr, " after catch: \n"); s7_show_stack(sc);} + if ((S7_DEBUGGING) && (!sc->longjmp_ok)) fprintf(stderr, "s7_error jump not available?\n"); + LongJmp(*(sc->goto_start), catch_jump); + }} + /* error not caught (but catcher might have been called and returned false) */ -/* TODO: also q_func(o).call -> q_func_call(o) */ + if ((!(sc->reset_error_hook)) && + (hook_has_functions(sc->error_hook))) + { + const s7_pointer error_hook_funcs = s7_hook_functions(sc, sc->error_hook); + /* (set! (hook-functions *error-hook*) (list (lambda (h) (format *stderr* "got error ~A~%" (h 'data))))) */ + let_set_2(sc, closure_let(sc->error_hook), sc->body_symbol, sc->nil); + let_set_2(sc, closure_let(sc->temp_error_hook), sc->body_symbol, error_hook_funcs); + /* if the *error-hook* functions trigger an error, we had better not have hook_functions(*error-hook*) still set! */ + + /* here we have no catcher (anywhere!), we're headed back to the top-level(?), so error_hook_quit can call reset_stack? */ + push_stack(sc, OP_ERROR_HOOK_QUIT, sc->nil, error_hook_funcs); /* restore *error-hook* upon successful (or any!) evaluation */ + sc->code = sc->temp_error_hook; + 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. + */ + set_curlet(sc, make_let(sc, closure_let(sc->code))); + eval(sc, OP_APPLY_LAMBDA); + /* we'll longjmp below -- is that really what we want? */ + } + else + { + const s7_int op = sc->print_length; + if (op < 32) sc->print_length = 32; + + if ((!is_output_port(current_error_port(sc))) || /* error-port can be #f */ + (port_is_closed(current_error_port(sc)))) + set_current_error_port(sc, 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! + */ -/* -------------------------------- int opts -------------------------------- */ + if ((!is_pair(info)) || + (!is_string(car(info)))) + format_to_error_port(sc, "\n;~S ~S", set_plist_2(sc, type, info), 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)), '~'))) + { + const s7_int len = string_length(car(info)) + 8; + block_t *b = mallocate(sc, len); + char *errstr = (char *)block_data(b); + s7_int str_len = catstrs_direct(errstr, "\n;", string_value(car(info)), (const char *)NULL); + format_to_error_port(sc, errstr, cdr(info), str_len); + liberate(sc, b); + } + else format_to_error_port(sc, "\n;~S ~S", set_plist_2(sc, type, info), 7); /* 7 = ctrl str len */ + } + if (op < 32) sc->print_length = op; -static s7_int -opt_i_c (opt_info* o) { - return (q_arg1 (o).i); + /* now display location at end */ + if (is_string(slot_value(sc->error_file))) + { + s7_newline(sc, current_error_port(sc)); + format_to_error_port(sc, "; ~A\n", set_plist_1(sc, object_to_string_truncated(sc, cur_code)), 8); + format_to_error_port(sc, "; ~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)), 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_error_port(sc, "\n; ~A[~D]", + set_plist_2(sc, wrap_string(sc, filename, port_filename_length(current_input_port(sc))), + wrap_integer(sc, line)), 10); + else + if ((line > 0) && + (integer(slot_value(sc->error_line)) > 0)) + format_to_error_port(sc, "\n; line ~D", set_plist_1(sc, wrap_integer(sc, line)), 11); + else + if (sc->input_port_stack_loc > 0) + { + s7_pointer port = sc->input_port_stack[sc->input_port_stack_loc - 1]; + if ((is_input_port(port)) && + (port_file(port) != stdin) && + (!port_is_closed(port))) + { + filename = port_filename(port); + line = port_line_number(port); + if (filename) + format_to_error_port(sc, "\n; ~A[~D]", + set_plist_2(sc, wrap_string(sc, filename, port_filename_length(current_input_port(sc))), + wrap_integer(sc, line)), 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_error_port(sc, "\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_integer(sc, sc->s7_call_line)), 13); + }} + s7_newline(sc, current_error_port(sc)); + } + /* look for __func__ in the error environment etc */ + if (current_error_port(sc) != sc->F) + { + s7_pointer errp = s7_stacktrace(sc); + if (string_length(errp) > 0) + { + port_write_string(current_error_port(sc))(sc, string_value(errp), string_length(errp), current_error_port(sc)); + port_write_character(current_error_port(sc))(sc, '\n', current_error_port(sc)); + }} + else + if (is_pair(slot_value(sc->error_code))) + { + format_to_error_port(sc, "; ~S", set_plist_1(sc, slot_value(sc->error_code)), 7); + s7_newline(sc, current_error_port(sc)); + } + /* 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; + sc->reset_error_hook = false; /* ?? */ + } + LongJmp(*(sc->goto_start), error_jump); } -static s7_int -opt_i_s (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p))); + +s7_pointer s7_error(s7_scheme *sc, s7_pointer type, s7_pointer info) /* s7.h backwards compatibility */ +{ + error_nr(sc, type, info); + /* info is a temporary value -- do not expect it to be useful beyond the error handler procedure itself */ + return(type); } -static bool -opt_int_not_pair (s7_scheme* sc, s7_pointer expr) { - opt_info* opc; - if (is_t_integer (expr)) { - opc = alloc_opt_info (sc); - q_arg1 (opc).i = integer (expr); - q_call (opc).fi= opt_i_c; - return_true (sc, expr); - } - { - s7_pointer slot= opt_integer_symbol (sc, expr); - if (!slot) return_false (sc, expr); - opc = alloc_opt_info (sc); - q_arg1 (opc).p = slot; - q_call (opc).fi= opt_i_s; - } - return_true (sc, expr); -} +static no_return void read_error_1_nr(s7_scheme *sc, const char *errmsg, bool string_error) +{ + /* read 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. + */ + const s7_pointer port = current_input_port(sc); -/* -------- i_i|d|p -------- */ + 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 start, end, slen, size; + char *recent_input = NULL; + + /* we can run off the end in cases like (eval-string "(. . ,.)") or (eval-string " (@ . ,.)") */ + if (port_position(port) >= port_data_size(port)) + port_position(port) = port_data_size(port) - 1; + + /* start at current position and look back a few chars */ + start = port_position(port); + for (s7_int j = 0; (start > 0) && (j < QUOTE_SIZE); start--, j++) + if ((port_data(port)[start] == '\0') || (port_data(port)[start] == '\n') || (port_data(port)[start] == '\r')) + break; + + /* start at current position and look ahead a few chars */ + size = port_data_size(port); + end = port_position(port); + for (s7_int j = 0; (end < size) && (j < QUOTE_SIZE); end++, j++) + if ((port_data(port)[end] == '\0') || (port_data(port)[end] == '\n') || (port_data(port)[end] == '\r')) + break; + + 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 (s7_int i = 0; i < (slen + 8); i++) recent_input[i] = '.'; + recent_input[3] = ' '; + recent_input[slen + 4] = ' '; + for (s7_int i = 0; i < slen; i++) recent_input[i + 4] = port_data(port)[start + i]; + } -static s7_int -opt_i_i_c (opt_info* o) { - return (q_func (o).i_i_f (q_arg1 (o).i)); -} -static s7_int -opt_i_i_s (opt_info* o) { - return (q_func (o).i_i_f (integer (slot_value (q_arg1 (o).p)))); -} -static s7_int -opt_i_7i_c (opt_info* o) { - return (q_func (o).i_7i_f (o->sc, q_arg1 (o).i)); -} -static s7_int -opt_i_7i_s (opt_info* o) { - return (q_func (o).i_7i_f (o->sc, integer (slot_value (q_arg1 (o).p)))); -} -static s7_int -opt_i_7i_s_rand (opt_info* o) { - return (random_i_7i (o->sc, integer (slot_value (q_arg1 (o).p)))); -} -static s7_int -opt_i_d_c (opt_info* o) { - return (q_func (o).i_7d_f (o->sc, q_arg1 (o).x)); -} -static s7_int -opt_i_d_s (opt_info* o) { - return (q_func (o).i_7d_f (o->sc, real (slot_value (q_arg1 (o).p)))); -} - -static s7_int -opt_i_i_f (opt_info* o) { - return (q_func (o).i_i_f (q_i_func1_call (o))); -} -static s7_int -opt_i_7i_f (opt_info* o) { - return (q_func (o).i_7i_f (o->sc, q_i_func1_call (o))); -} -static s7_int -opt_i_7d_f (opt_info* o) { - return (q_func (o).i_7d_f (o->sc, q_d_func1_call (o))); -} -static s7_int -opt_i_7p_f (opt_info* o) { - return (q_func (o).i_7p_f (o->sc, q_p_func1_call (o))); -} -static s7_int -opt_i_7p_f_cint (opt_info* o) { - return (char_to_integer_i_7p (o->sc, q_p_func1_call (o))); -} /* from opt_set_p_i_f */ - -static s7_int -opt_i_i_s_abs (opt_info* o) { - return (abs_i_i (integer (slot_value (q_arg1 (o).p)))); -} -static s7_int -opt_i_i_f_abs (opt_info* o) { - return (abs_i_i (q_i_func1_call (o))); -} - -static bool int_optimize (s7_scheme* sc, s7_pointer expr); -static bool float_optimize (s7_scheme* sc, s7_pointer expr); - -static bool -i_idp_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr) { - const s7_i_i_t func = s7_i_i_function (s_func); - s7_i_7i_t func7= NULL; - s7_pointer arg1_slot; - const s7_pointer arg1 = cadr (expr); - const int32_t start= sc->pc; - q_func1_arg (opc).o1 = sc->opts[start]; - if (!func) func7= s7_i_7i_function (s_func); - if ((func) || (func7)) { - if (func) q_func (opc).i_i_f= func; - else q_func (opc).i_7i_f= func7; - if (is_t_integer (arg1)) { - if (q_func (opc).i_i_f == subtract_i_i) { - q_arg1 (opc).i = -integer (arg1); - q_call (opc).fi= opt_i_c; - } - else { - q_arg1 (opc).i = integer (arg1); - q_call (opc).fi= (func) ? opt_i_i_c : opt_i_7i_c; - } - return_true (sc, expr); - } - arg1_slot= opt_integer_symbol (sc, arg1); - if (arg1_slot) { - q_arg1 (opc).p= arg1_slot; - q_call (opc).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 (sc, expr); - } - if (int_optimize (sc, cdr (expr))) { - q_func1 (opc).fi= q_call (sc->opts[start]).fi; - q_call (opc).fi= - (func) ? ((func == abs_i_i) ? opt_i_i_f_abs : opt_i_i_f) : opt_i_7i_f; - return_true (sc, expr); - } - sc->pc= start; - } - if (!is_t_ratio (arg1)) { - const s7_i_7d_t idf= s7_i_7d_function (s_func); - if (idf) { - q_func (opc).i_7d_f= idf; - if (is_small_real (arg1)) { - q_arg1 (opc).x = s7_number_to_real (sc, arg1); - q_call (opc).fi= opt_i_d_c; - return_true (sc, expr); - } - arg1_slot= opt_float_symbol (sc, arg1); - if (arg1_slot) { - q_arg1 (opc).p = arg1_slot; - q_call (opc).fi= opt_i_d_s; - return_true (sc, expr); - } - if (float_optimize (sc, cdr (expr))) { - q_call (opc).fi = opt_i_7d_f; - q_func1 (opc).fd= q_call (sc->opts[start]).fd; - return_true (sc, expr); - } - sc->pc= start; + if ((port_line_number(port) > 0) && + (port_filename(port))) + { + const s7_int len = safe_strlen(recent_input) + safe_strlen(errmsg) + port_filename_length(port) + safe_strlen(sc->current_file) + 64; + const s7_pointer str = make_empty_string(sc, len, '\0'); + char *msg = string_value(str); + string_length(str) = snprintf(msg, len, "%s: %s %s[%u], last top-level form at: %s[%" ld64 "]", + errmsg, (recent_input) ? recent_input : "", port_filename(port), port_line_number(port), + sc->current_file, sc->current_line); + if (recent_input) free(recent_input); + error_nr(sc, sc->read_error_symbol, set_elist_1(sc, str)); + } + else + { + const s7_int len = safe_strlen(recent_input) + safe_strlen(errmsg) + safe_strlen(sc->current_file) + 64; + const s7_pointer str = make_empty_string(sc, len, '\0'); + char *msg = string_value(str); + if ((sc->current_file) && + (sc->current_line >= 0)) + string_length(str) = snprintf(msg, len, "%s: %s, last top-level form at %s[%" ld64 "]", + errmsg, (recent_input) ? recent_input : "", + sc->current_file, sc->current_line); + else string_length(str) = snprintf(msg, len, "%s: %s", errmsg, (recent_input) ? recent_input : ""); + if (recent_input) free(recent_input); + error_nr(sc, sc->read_error_symbol, set_elist_1(sc, str)); + }}} + + if ((port_line_number(port) > 0) && + (port_filename(port))) + { + s7_int nlen; + const s7_int len = safe_strlen(errmsg) + port_filename_length(port) + safe_strlen(sc->current_file) + 128; + const s7_pointer str = make_empty_string(sc, len, '\0'); + char *msg = string_value(str); + 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(port), port_line_number(port), + 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(port), port_line_number(port), + sc->current_file, sc->current_line); + string_length(str) = nlen; + error_nr(sc, sc->read_error_symbol, set_elist_1(sc, str)); + } + error_nr(sc, (string_error) ? sc->string_read_error_symbol : sc->read_error_symbol, + set_elist_1(sc, s7_make_string_wrapper(sc, errmsg))); +} + +static no_return void read_error_nr(s7_scheme *sc, const char *errmsg) {read_error_1_nr(sc, errmsg, false);} +static no_return void string_read_error_nr(s7_scheme *sc, const char *errmsg) {read_error_1_nr(sc, errmsg, true);} + +/* g_error is now implemented in s7_scheme_base.c */ +#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) + +static char *truncate_string(char *form, s7_int len, use_write_t use_write) +{ + const uint8_t *f = (uint8_t *)form; + s7_int i; + if (use_write != p_display) + { + /* I guess we need to protect the outer double quotes in this case */ + for (i = len - 5; i >= (len / 2); i--) + if (is_white_space((int32_t)f[i])) + 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 + { + 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_string_truncated(s7_scheme *sc, s7_pointer obj) +{ + const s7_int len = sc->print_length; + const s7_int old_max_len = sc->objstr_max_len; + sc->objstr_max_len = len + 2; { - s7_i_7p_t ipf= s7_i_7p_function (s_func); - if (ipf) { - q_func (opc).i_7p_f= ipf; - if (cell_optimize (sc, cdr (expr))) { - q_call (opc).fi= - (ipf == char_to_integer_i_7p) ? opt_i_7p_f_cint : opt_i_7p_f; - q_func1 (opc).fp= q_call (sc->opts[start]).fp; - return_true (sc, expr); - } - sc->pc= start; - } + s7_pointer result = s7_object_to_string(sc, obj, false); + sc->objstr_max_len = old_max_len; + if (string_length(result) > len) + truncate_string(string_value(result), len, p_display); /* only use of truncate_string */ + return(result); } - return_false (sc, expr); } -/* -------- i_pi -------- */ - -static s7_int -opt_i_7pi_ss (opt_info* o) { - return (q_func (o).i_7pi_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_int -opt_i_pi_ss_ivref (opt_info* o) { - return (int_vector (slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_int -opt_i_pi_ss_bvref (opt_info* o) { - return (byte_vector (slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_int -opt_i_7pi_sf (opt_info* o) { - return (q_func (o).i_7pi_f (o->sc, slot_value (q_arg1 (o).p), - q_i_func2_call (o))); +static s7_pointer tree_descend(s7_scheme *sc, s7_pointer tree, uint32_t line) +{ + s7_pointer tp; + if (!is_pair(tree)) return(NULL); + if (has_location(tree)) + { + uint32_t cur_line = (uint32_t)pair_line_number(tree); + if (cur_line > 0) + { + if (line == 0) /* first line number we encounter will be the current reader location (i.e. the end of the form) */ + line = cur_line; + else + if (cur_line < line) + return(tree); + }} + tp = tree_descend(sc, car(tree), line); + return((tp) ? tp : tree_descend(sc, cdr(tree), line)); } -/* how can i_7pi_ss be hit? */ +static no_return void missing_close_paren_error_nr(s7_scheme *sc) +{ + char *syntax_msg = NULL; + const s7_pointer port = current_input_port(sc); -static bool -i_7pi_ok (s7_scheme* sc, opt_info* opc, s7_pointer s_func, - const s7_pointer expr) { - s7_pointer sig; - s7_i_7pi_t pfunc= s7_i_7pi_function (s_func); - if (!pfunc) { - if ((is_eq_initial_c_function_data (sc->vector_ref_symbol, s_func)) && - (is_normal_symbol (cadr (expr)))) /* (vector-ref )? */ - { - const s7_pointer v_slot= s7_slot (sc, cadr (expr)); - if (is_slot (v_slot)) { - const s7_pointer vec= slot_value (v_slot); - if (is_int_vector (vec)) { - pfunc = int_vector_ref_i_7pi; - s_func= initial_value (sc->int_vector_ref_symbol); - /* a normal vector can have vector-typer integer? if it's set after - * vector creation, but that can't be optimized much */ - } - else if (is_byte_vector (vec)) { - pfunc = byte_vector_ref_i_7pi; - s_func= initial_value (sc->byte_vector_ref_symbol); - } - } - } - if (!pfunc) return_false (sc, expr); - } - sig= c_function_signature (s_func); - if (is_pair (sig)) { - s7_pointer slot; - const s7_pointer arg1= cadr (expr), arg2= caddr (expr); - const int32_t start= sc->pc; - if ((is_symbol (cadr (sig))) && (is_symbol (arg1)) && - (slot= opt_types_match (sc, cadr (sig), arg1))) { - s7_pointer arg2_slot; - q_arg1 (opc).p= slot; - if ((s_func == - global_value (sc->int_vector_ref_symbol)) && /* ivref etc */ - ((!is_int_vector (slot_value (slot))) || - (vector_rank (slot_value (slot)) > 1))) - return_false (sc, expr); - if ((s_func == - global_value (sc->byte_vector_ref_symbol)) && /* bvref etc */ - ((!is_byte_vector (slot_value (slot))) || - (vector_rank (slot_value (slot)) > 1))) - return_false (sc, expr); - - q_func (opc).i_7pi_f= pfunc; - arg2_slot = opt_integer_symbol (sc, arg2); - if (arg2_slot) { - q_arg2 (opc).p = arg2_slot; - q_call (opc).fi= opt_i_7pi_ss; - if ((s_func == global_value (sc->int_vector_ref_symbol)) && - (loop_end_fits (q_arg2 (opc).p, - vector_length (slot_value (q_arg1 (opc).p))))) { - q_call (opc).fi = opt_i_pi_ss_ivref; - q_func (opc).i_7pi_f= int_vector_ref_i_pi_direct; - } - else if ((s_func == global_value (sc->byte_vector_ref_symbol)) && - (loop_end_fits (q_arg2 (opc).p, vector_length (slot_value ( - q_arg1 (opc).p))))) { - q_call (opc).fi = opt_i_pi_ss_bvref; - q_func (opc).i_7pi_f= byte_vector_ref_i_7pi_direct; - } - return_true (sc, expr); - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cddr (expr))) { - q_call (opc).fi = opt_i_7pi_sf; - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; /* q_call(o1)? */ - return_true (sc, expr); - } - sc->pc= start; + if (type_unchecked(sc->curlet) != T_LET) + set_curlet(sc, sc->rootlet); + + /* check *missing-close-paren-hook* */ + if (hook_has_functions(sc->missing_close_paren_hook)) + { + s7_pointer result; + if ((port_line_number(port) > 0) && + (port_filename(port))) + { + set_integer(slot_value(sc->error_line), port_line_number(port)); + set_integer(slot_value(sc->error_position), port_position(port)); + slot_set_value(sc->error_file, wrap_string(sc, port_filename(port), port_filename_length(port))); + } + result = s7_call(sc, sc->missing_close_paren_hook, sc->nil); + if (result != sc->unspecified) + g_throw(sc, list_1(sc, result)); + } + if (is_pair(sc->args)) + { + const s7_pointer p = tree_descend(sc, sc->args, 0); + if ((p) && (is_pair(p)) && + (has_location(p))) + { + const s7_pointer strp = object_to_string_truncated(sc, p); + const char *form = string_value(strp); + const s7_int form_len = string_length(strp); + const s7_int 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(port) > 0) && + (port_filename(port))) + { + s7_int nlen; + const s7_int len = port_filename_length(port) + safe_strlen(sc->current_file) + safe_strlen(syntax_msg) + 128; + const s7_pointer str = make_empty_string(sc, len, '\0'); + char *msg = string_value(str); + if (syntax_msg) + { + nlen = snprintf(msg, len, "missing close paren, %s[%u], last top-level form at %s[%" ld64 "]\n%s", + port_filename(port), port_line_number(port), + 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(port), port_line_number(port), + sc->current_file, sc->current_line); + string_length(str) = nlen; + error_nr(sc, sc->read_error_symbol, set_elist_1(sc, str)); + } + if (syntax_msg) + { + s7_int len = safe_strlen(syntax_msg) + 128; + const s7_pointer str = make_empty_string(sc, len, '\0'); + char *msg = string_value(str); + len = catstrs(msg, len, "missing close paren\n", syntax_msg, "\n", (char *)NULL); + free(syntax_msg); + string_length(str) = len; + error_nr(sc, sc->read_error_symbol, set_elist_1(sc, str)); + } + if ((is_input_port(port)) && + (!port_is_closed(port)) && + (port_data(port)) && + (port_position(port) > 0)) + { + const s7_pointer str = make_empty_string(sc, 128, '\0'); + const s7_int pos = port_position(port); + s7_int start = pos - 40; + char *msg = string_value(str); + memcpy((void *)msg, (const void *)"missing close paren: ", 21); + if (start < 0) start = 0; + memcpy((void *)(msg + 21), (void *)(port_data(port) + start), pos - start); + string_length(str) = 21 + pos - start; + error_nr(sc, sc->read_error_symbol, set_elist_1(sc, str)); } - } - return_false (sc, expr); + error_nr(sc, sc->read_error_symbol, set_elist_1(sc, wrap_string(sc, "missing close paren", 19))); } -/* -------- i_ii -------- */ - -static s7_int -opt_i_ii_cc (opt_info* o) { - return (q_func (o).i_ii_f (q_arg1 (o).i, q_arg2 (o).i)); -} -static s7_int -opt_i_ii_cs (opt_info* o) { - return ( - q_func (o).i_ii_f (q_arg1 (o).i, integer (slot_value (q_arg2 (o).p)))); -} -static s7_int -opt_i_ii_cs_mul (opt_info* o) { - return (q_arg1 (o).i * integer (slot_value (q_arg2 (o).p))); -} -static s7_int -opt_i_ii_sc (opt_info* o) { - return ( - q_func (o).i_ii_f (integer (slot_value (q_arg1 (o).p)), q_arg2 (o).i)); -} -static s7_int -opt_i_ii_sc_add (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) + q_arg2 (o).i); -} /* +1 is not faster */ -static s7_int -opt_i_ii_sc_sub (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) - q_arg2 (o).i); -} /* -1 is not faster */ -static s7_int -opt_i_ii_ss (opt_info* o) { - return (q_func (o).i_ii_f (integer (slot_value (q_arg1 (o).p)), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_int -opt_i_ii_ss_add (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) + - integer (slot_value (q_arg2 (o).p))); -} -static s7_pointer -opt_p_ii_ss_add (opt_info* o) { - return (make_integer (o->sc, integer (slot_value (q_arg1 (o).p)) + - integer (slot_value (q_arg2 (o).p)))); -} -static s7_int -opt_i_ii_cf (opt_info* o) { - return (q_func (o).i_ii_f (q_arg1 (o).i, q_i_func2_call (o))); -} -static s7_int -opt_i_ii_cf_mul (opt_info* o) { - return (q_arg1 (o).i * q_i_func2_call (o)); -} -static s7_int -opt_i_ii_sf (opt_info* o) { - return (q_func (o).i_ii_f (integer (slot_value (q_arg1 (o).p)), - q_i_func2_call (o))); -} -static s7_int -opt_i_ii_sf_add (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) + q_i_func2_call (o)); -} -static s7_int -opt_i_ii_fc (opt_info* o) { - return (q_func (o).i_ii_f (q_i_func1_call (o), q_arg2 (o).i)); -} -static s7_int -opt_i_ii_fc_add (opt_info* o) { - return (q_i_func1_call (o) + q_arg2 (o).i); -} -static s7_int -opt_i_ii_fc_mul (opt_info* o) { - return (q_i_func1_call (o) * q_arg2 (o).i); +static no_return void improper_arglist_error_nr(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 = pop_op_stack(sc); + if (sc->args == sc->nil) /* (abs . 1) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "attempt to evaluate (~S . ~S)?", 30), func, sc->code)); + error_nr(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)); } -/* returning s7_int so overflow->real is not doable here, so - * (define (func) (do ((x 0) (i 0 (+ i 1))) ((= i 1) x) (set! x (* (lognot - * 4294967297) 4294967297)))) (func) (func) will return -12884901890 rather than - * -18446744086594454000.0, 4294967297 > sqrt(fixmost) This affects all the opt - * arithmetical functions. Unfortunately the gmp version also gets - * -12884901890! We need to make sure none of these are available in the gmp - * version. - */ -static s7_int -opt_i_ii_ff (opt_info* o) { - return (q_func (o).i_ii_f (q_i_func1_call (o), q_i_func2_call (o))); -} -static s7_int -opt_i_7ii_ff_quo (opt_info* o) { - return (quotient_i_7ii (o->sc, q_i_func1_call (o), q_i_func2_call (o))); -} -static s7_int -opt_i_7ii_fc (opt_info* o) { - return (q_func (o).i_7ii_f (o->sc, q_i_func1_call (o), q_arg2 (o).i)); -} - -static s7_int -opt_i_ii_fco (opt_info* o) { - return (q_func (o).i_ii_f ( - q_func1 (o).i_7pi_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p))), - q_arg3 (o).i)); -} - -static s7_int -opt_i_ii_fco_ivref_add (opt_info* o) { - return (int_vector_ref_i_pi_direct (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p))) + - q_arg3 (o).i); -} /* tref */ - -static s7_int -opt_i_7ii_fco (opt_info* o) { - return (q_func (o).i_7ii_f ( - o->sc, - q_func1 (o).i_7pi_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p))), - q_arg3 (o).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 ((q_call (o1).fi == opt_i_7pi_ss) || - (q_call (o1).fi == opt_i_pi_ss_ivref)) { - q_arg3 (opc).i = q_arg2 (opc).i; - q_func1 (opc).i_7pi_f= q_func (o1).i_7pi_f; - q_arg1 (opc).p = q_arg1 (o1).p; - q_arg2 (opc).p = q_arg2 (o1).p; - if (func) - q_call (opc).fi= ((q_func (opc).i_ii_f == add_i_ii) && - (q_func1 (opc).i_7pi_f == int_vector_ref_i_pi_direct)) - ? opt_i_ii_fco_ivref_add - : opt_i_ii_fco; - else q_call (opc).fi= opt_i_7ii_fco; - backup_pc (sc); - return_true (sc, NULL); - } - } - return_false (sc, NULL); +static void op_error_hook_quit(s7_scheme *sc) +{ + let_set_2(sc, closure_let(sc->error_hook), sc->body_symbol, sc->code); /* restore old value */ + let_set_2(sc, closure_let(sc->temp_error_hook), sc->body_symbol, sc->nil); + /* 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); } -static s7_int -opt_i_7ii_cc (opt_info* o) { - return (q_func (o).i_7ii_f (o->sc, q_arg1 (o).i, q_arg2 (o).i)); -} -static s7_int -opt_i_7ii_cs (opt_info* o) { - return (q_func (o).i_7ii_f (o->sc, q_arg1 (o).i, - integer (slot_value (q_arg2 (o).p)))); -} -static s7_int -opt_i_7ii_sc (opt_info* o) { - return (q_func (o).i_7ii_f (o->sc, integer (slot_value (q_arg1 (o).p)), - q_arg2 (o).i)); -} -static s7_int -opt_i_7ii_ss (opt_info* o) { - return (q_func (o).i_7ii_f (o->sc, integer (slot_value (q_arg1 (o).p)), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_int -opt_i_7ii_cf (opt_info* o) { - return (q_func (o).i_7ii_f (o->sc, q_arg1 (o).i, q_i_func2_call (o))); -} -static s7_int -opt_i_7ii_sf (opt_info* o) { - return (q_func (o).i_7ii_f (o->sc, integer (slot_value (q_arg1 (o).p)), - q_i_func2_call (o))); + +/* -------------------------------- hooks -------------------------------- */ +s7_pointer s7_hook_functions(s7_scheme *sc, s7_pointer hook) +{ + return(s7_symbol_local_value(sc, sc->body_symbol, closure_let(hook))); } -static s7_int -opt_i_7ii_ff (opt_info* o) { - s7_int i1= q_i_func1_call (o); - s7_int i2= q_i_func2_call (o); - return (q_func (o).i_7ii_f (o->sc, i1, i2)); +s7_pointer s7_hook_set_functions(s7_scheme *sc, s7_pointer hook, s7_pointer functions) +{ + if (is_list(functions)) + let_set_2(sc, closure_let(hook), sc->body_symbol, functions); + return(functions); } -static s7_int -opt_add_i_random_i (opt_info* o) { - return (q_arg1 (o).i + - (s7_int) (q_arg2 (o).i * next_random (o->sc->default_random_state))); +static s7_pointer g_hook_functions(s7_scheme *sc, s7_pointer args) +{ + #define H_hook_functions "(hook-functions hook) gets or sets the list of functions associated with the hook" + #define Q_hook_functions s7_make_signature(sc, 2, sc->is_list_symbol, sc->is_procedure_symbol) + s7_pointer hook = car(args), slot; + if (!is_any_closure(hook)) /* closure* -> closure if no args */ + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "hook-functions hook must be a procedure created by make-hook: ~S", 64), hook)); + slot = lookup_slot_from(sc->body_symbol, closure_let(hook)); + return((is_slot(slot)) ? slot_value(slot) : sc->nil); } -static s7_int -opt_subtract_random_i_i (opt_info* o) { - return ((s7_int) (q_arg1 (o).i * next_random (o->sc->default_random_state)) - - q_arg2 (o).i); + +static s7_pointer g_hook_set_functions(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer hook = car(args); + s7_pointer lst, p; + if (!is_any_closure(hook)) /* closure* -> closure if no args */ + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "set! hook-functions hook must be a procedure created by make-hook: ~S", 69), hook)); + lst = cadr(args); + for (p = lst; is_pair(p); p = cdr(p)) + if ((!is_any_procedure(car(p))) || (!s7_is_aritable(sc, car(p), 1))) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "new hook-functions value must be nil or a list of functions, each accepting one argument: ~S", 92), lst)); + if (!is_null(p)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "new hook-functions value must be nil or a a proper list: ~S", 59), lst)); + { + s7_pointer slot = lookup_slot_from(sc->body_symbol, closure_let(hook)); + if (is_slot(slot)) slot_set_value(slot, lst); + } + return(lst); } -static bool -i_ii_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr) { - const s7_i_ii_t ifunc = s7_i_ii_function (s_func); - s7_i_7ii_t ifunc7= NULL; - s7_pointer sig; - if (!ifunc) { - ifunc7= s7_i_7ii_function (s_func); - if (!ifunc7) return_false (sc, expr); - } - sig= c_function_signature (s_func); - if (is_pair (sig)) { - const s7_pointer arg1= cadr (expr), arg2= caddr (expr); - const int32_t start= sc->pc; - s7_pointer arg1_slot, arg2_slot; - if (ifunc) q_func (opc).i_ii_f= ifunc; - else q_func (opc).i_7ii_f= ifunc7; - - if (is_t_integer (arg1)) { - q_arg1 (opc).i= integer (arg1); - if (is_t_integer (arg2)) { - if (q_func (opc).i_ii_f == add_i_ii) { - q_arg1 (opc).i= - integer (arg1) + - integer (arg2); /* no overflow check for sc_add case above */ - q_call (opc).fi= opt_i_c; - } - else { - q_arg2 (opc).i = integer (arg2); - q_call (opc).fi= (ifunc) ? opt_i_ii_cc : opt_i_7ii_cc; - } - return_true (sc, expr); - } - arg2_slot= opt_integer_symbol (sc, arg2); - if (arg2_slot) { - q_arg2 (opc).p= arg2_slot; - if (ifunc) - q_call (opc).fi= (q_func (opc).i_ii_f == multiply_i_ii) - ? opt_i_ii_cs_mul - : opt_i_ii_cs; - else q_call (opc).fi= opt_i_7ii_cs; - return_true (sc, expr); - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cddr (expr))) { - if (ifunc) { - q_call (opc).fi= - opt_i_ii_cf; /* caller(sc->opts[start]).fi -> opt_i_7i_c -> - func(same_opt).i_7i_f = random_i_7i tmap */ - if ((ifunc == add_i_ii) && (opc == sc->opts[sc->pc - 2]) && - (q_call (sc->opts[start]).fi == opt_i_7i_c) && - (q_func (sc->opts[start]).i_7i_f == random_i_7i)) { - q_call (opc).fi= opt_add_i_random_i; - q_arg2 (opc).i = q_arg1 (sc->opts[start]).i; - backup_pc (sc); - } - else if (ifunc == multiply_i_ii) q_call (opc).fi= opt_i_ii_cf_mul; - } - else q_call (opc).fi= opt_i_7ii_cf; - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - return_true (sc, expr); - } - sc->pc= start; - return_false (sc, expr); - } - - /* arg1 not integer */ - arg1_slot= opt_integer_symbol (sc, arg1); - if (arg1_slot) { - q_arg1 (opc).p= arg1_slot; - if (is_t_integer (arg2)) { - q_arg2 (opc).i= integer (arg2); - if (ifunc) { - if (q_func (opc).i_ii_f == add_i_ii) q_call (opc).fi= opt_i_ii_sc_add; - else - q_call (opc).fi= (q_func (opc).i_ii_f == subtract_i_ii) - ? opt_i_ii_sc_sub - : opt_i_ii_sc; /* add1/sub1 are not faster */ - } - else q_call (opc).fi= opt_i_7ii_sc; - if ((car (expr) == sc->modulo_symbol) && (integer (arg2) > 1)) - q_func (opc).i_ii_f= modulo_i_ii_unchecked; - else { - if (car (expr) == sc->ash_symbol) { - if (q_arg2 (opc).i < 0) { - q_func (opc).i_ii_f= - (q_arg2 (opc).i == -1) ? rsh_i_i2_direct : rsh_i_ii_unchecked; - q_call (opc).fi= opt_i_ii_sc; - } - else if (q_arg2 (opc).i < S7_INT_BITS) { - q_func (opc).i_ii_f= lsh_i_ii_unchecked; - q_call (opc).fi = opt_i_ii_sc; - } - } - else if (q_arg2 (opc).i > 0) { - /* these assume vunion is a union, not a struct; i_7ii_f otherwise - * might be leftover from a previous use */ - if (q_func (opc).i_7ii_f == quotient_i_7ii) { - q_func (opc).i_ii_f= quotient_i_ii_unchecked; - q_call (opc).fi = opt_i_ii_sc; - } - else if ((q_arg2 (opc).i > 1) && - (q_func (opc).i_7ii_f == remainder_i_7ii)) { - q_func (opc).i_ii_f= remainder_i_ii_unchecked; - q_call (opc).fi = opt_i_ii_sc; - } - } - } - return_true (sc, expr); - } +/* -------------------------------- begin_hook -------------------------------- */ +void (*s7_begin_hook(s7_scheme *sc))(s7_scheme *sc, bool *val) {return(sc->begin_hook);} - /* arg2 not integer, arg1 is int symbol */ - arg2_slot= opt_integer_symbol (sc, arg2); - if (arg2_slot) { - q_arg2 (opc).p= arg2_slot; - if (ifunc) - q_call (opc).fi= - (q_func (opc).i_ii_f == add_i_ii) ? opt_i_ii_ss_add : opt_i_ii_ss; - else q_call (opc).fi= opt_i_7ii_ss; - return_true (sc, expr); - } - if (int_optimize (sc, cddr (expr))) { - q_func2_arg (opc).o1= sc->opts[start]; - q_func2 (opc).fi = q_call (sc->opts[start]).fi; - if (ifunc) - q_call (opc).fi= - (q_func (opc).i_ii_f == add_i_ii) ? opt_i_ii_sf_add : opt_i_ii_sf; - else q_call (opc).fi= opt_i_7ii_sf; - return_true (sc, expr); - } - sc->pc= start; - return_false (sc, expr); - } - - /* arg1 not int symbol */ - if (is_t_integer (arg2)) { - q_arg2 (opc).i = integer (arg2); - q_func1_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cdr (expr))) { - q_func1 (opc).fi= q_func1_arg (opc).q_call (o1).fi; - if (!i_ii_fc_combinable (sc, opc, ifunc)) { - if (ifunc) { - if (q_func (opc).i_ii_f == add_i_ii) { - q_call (opc).fi= opt_i_ii_fc_add; - return_true (sc, expr); - } - if (q_func (opc).i_ii_f == multiply_i_ii) { - q_call (opc).fi= opt_i_ii_fc_mul; - return_true (sc, expr); - } - q_call (opc).fi= opt_i_ii_fc; - - if ((q_func (opc).i_ii_f == subtract_i_ii) && - (opc == sc->opts[sc->pc - 2]) && - (q_call (sc->opts[start]).fi == opt_i_7i_c) && - (q_func (sc->opts[start]).i_7i_f == random_i_7i)) { - q_call (opc).fi= opt_subtract_random_i_i; - q_arg1 (opc).i = q_arg1 (sc->opts[start]).i; - backup_pc (sc); - } - } - else q_call (opc).fi= opt_i_7ii_fc; - if (q_arg2 (opc).i > 0) { - if (q_func (opc).i_7ii_f == quotient_i_7ii) { - q_func (opc).i_ii_f= quotient_i_ii_unchecked; - q_call (opc).fi = opt_i_ii_fc; - } - else if ((q_arg2 (opc).i > 1) && - (q_func (opc).i_7ii_f == remainder_i_7ii)) { - q_func (opc).i_ii_f= remainder_i_ii_unchecked; - q_call (opc).fi = opt_i_ii_fc; - } - } - } - return_true (sc, expr); - } - sc->pc= start; - return_false (sc, expr); - } - - /* arg1 not integer or symbol, arg2 not integer */ - q_func1_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cdr (expr))) { - q_func1 (opc).fi = q_func1_arg (opc).q_call (o1).fi; - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cddr (expr))) { - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_call (opc).fi = (ifunc) ? opt_i_ii_ff - : ((q_func (opc).i_7ii_f == quotient_i_7ii) - ? opt_i_7ii_ff_quo - : opt_i_7ii_ff); - return_true (sc, expr); - } - sc->pc= start; - } - } - return_false (sc, expr); +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; } -/* -------- i_iii -------- */ - -static s7_int -opt_i_iii_fff (opt_info* o) { - s7_int i1= q_i_func1_call (o); - s7_int i2= q_i_func2_call (o); - s7_int i3= q_i_func3_call (o); - return (q_func (o).i_iii_f (i1, i2, i3)); -} - -static bool -i_iii_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr) { - const int32_t start= sc->pc; - const s7_i_iii_t ifunc= s7_i_iii_function (s_func); - if (!ifunc) return_false (sc, expr); - q_func1_arg (opc).o1= sc->opts[start]; - if (int_optimize (sc, cdr (expr))) { - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cddr (expr))) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cdddr (expr))) { - q_func (opc).i_iii_f= ifunc; - q_call (opc).fi = opt_i_iii_fff; - q_func1 (opc).fi = q_func1_arg (opc).q_call (o1).fi; - q_func2 (opc).fi = q_func2_arg (opc).q_call (o1).fi; - q_func3 (opc).fi = q_func3_arg (opc).q_call (o1).fi; - return_true (sc, expr); - } +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 + */ + const opcode_t op = sc->cur_op; + push_stack_direct(sc, OP_BARRIER); + sc->begin_hook(sc, &result); + if (result) + { + const s7_pointer cur_code = current_code(sc); + /* 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 */ + slot_set_value(sc->error_code, cur_code); + if (has_location(cur_code)) + { + set_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)]); + set_integer(slot_value(sc->error_position), (s7_int)pair_position(cur_code)); + } + else + { + set_integer(slot_value(sc->error_line), 0); + set_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", 20); + /* 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); } - } - sc->pc= start; - return_false (sc, expr); + pop_stack_no_op(sc); + sc->cur_op = op; /* for better error handling. otherwise we get "barrier" as the offending function name in syntax_error */ + return(false); } -/* -------- i_7pii -------- */ -static s7_int -opt_i_7pii_ssf (opt_info* o) { - return (q_func (o).i_7pii_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - q_i_func1_call (o))); -} - -static s7_int -opt_i_7pii_ssf_vset (opt_info* o) { - return (int_vector_set_i_7pii_direct (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - q_i_func1_call (o))); -} - -static s7_int -opt_i_7pii_ssc (opt_info* o) { - return (q_func (o).i_7pii_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - q_arg3 (o).i)); -} - -static s7_int -opt_i_7pii_sss (opt_info* o) { - return (q_func (o).i_7pii_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - integer (slot_value (q_arg3 (o).p)))); -} - -static s7_int -opt_i_pii_sss_ivref_unchecked (opt_info* o) { - s7_pointer vec= slot_value (q_arg1 (o).p); - return (int_vector ( - vec, ((integer (slot_value (q_arg2 (o).p)) * vector_offset (vec, 0)) + - integer (slot_value (q_arg3 (o).p))))); -} - -static s7_int -opt_i_7pii_sif (opt_info* o) { - return (q_func (o).i_7pii_f (o->sc, slot_value (q_arg1 (o).p), q_arg2 (o).i, - q_i_func3_call (o))); -} - -static s7_int -opt_i_7pii_sff (opt_info* o) { - s7_int i1= q_i_func2_call (o); - s7_int i2= q_i_func3_call (o); - return (q_func (o).i_7pii_f (o->sc, slot_value (q_arg1 (o).p), i1, i2)); -} - -static bool -is_target_or_its_alias (const s7_pointer symbol, const s7_pointer symfunc, - s7_pointer target) { - return ((symbol == target) || (is_eq_initial_value (target, symfunc))); -} - -static bool opt_int_vector_set (s7_scheme* sc, int32_t otype, opt_info* opc, - s7_pointer v, s7_pointer indexp1, - s7_pointer indexp2, s7_pointer valp); - -static bool -i_7pii_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr) { - s7_pointer sig; - const s7_i_7pii_t pfunc= s7_i_7pii_function (s_func); - if (!pfunc) return_false (sc, expr); - sig= c_function_signature (s_func); - if ((is_pair (sig)) && (is_symbol (cadr (expr)))) { - s7_pointer slot, fname= car (expr); - - 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 (expr), - cddr (expr), NULL, cdddr (expr))); - - slot= opt_types_match (sc, cadr (sig), cadr (expr)); - if (slot) { - s7_pointer arg2, arg2_slot; - const int32_t start= sc->pc; - q_arg1 (opc).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, expr); - - arg2 = caddr (expr); - arg2_slot= opt_integer_symbol (sc, arg2); - if (arg2_slot) { - s7_pointer arg3_slot; - q_arg2 (opc).p= arg2_slot; - arg3_slot = opt_integer_symbol (sc, cadddr (expr)); - if (arg3_slot) { - q_arg3 (opc).p = arg3_slot; - q_func (opc).i_7pii_f= pfunc; - q_call (opc).fi = opt_i_7pii_sss; - if ((pfunc == int_vector_ref_i_7pii) && - (loop_end_fits ( - q_arg2 (opc).p, - vector_dimension (slot_value (q_arg1 (opc).p), 0))) && - (loop_end_fits ( - q_arg3 (opc).p, - vector_dimension (slot_value (q_arg1 (opc).p), 1)))) - q_call (opc).fi= opt_i_pii_sss_ivref_unchecked; - return_true (sc, expr); - } - if (int_optimize (sc, cdddr (expr))) { - q_func (opc).i_7pii_f= pfunc; - q_call (opc).fi = opt_i_7pii_ssf; - q_func1_arg (opc).o1 = sc->opts[start]; - q_func1 (opc).fi = q_call (sc->opts[start]).fi; - return_true (sc, expr); - } - return_false (sc, expr); - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cddr (expr))) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cdddr (expr))) { - q_func (opc).i_7pii_f= pfunc; - q_call (opc).fi = opt_i_7pii_sff; - q_func2 (opc).fi = q_func2_arg (opc).q_call (o1).fi; - q_func3 (opc).fi = q_func3_arg (opc).q_call (o1).fi; - return_true (sc, expr); - } - } - sc->pc= start; +/* -------------------------------- apply -------------------------------- */ +static s7_pointer apply_list_star(s7_scheme *sc, s7_pointer d) +{ + /* we check this ahead of time: if (is_null(cdr(d))) return(car(d)); */ + s7_pointer p; + gc_protect_via_stack(sc, d); + begin_temp(sc->y, p = cons(sc, car(d), cdr(d))); + 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); } - } - return_false (sc, expr); + unstack_gc_protect(sc); + set_cdr(p, cadr(p)); + return_with_end_temp(sc->y); } -/* -------- i_7piii -------- */ - -static s7_int -opt_i_7piii_sssf (opt_info* o) { - return (q_func (o).i_7piii_f ( - o->sc, slot_value (q_arg1 (o).p), integer (slot_value (q_arg2 (o).p)), - integer (slot_value (q_arg3 (o).p)), q_i_func3_call (o))); +static no_return void apply_list_error_nr(s7_scheme *sc, s7_pointer lst) +{ + error_nr(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_int -opt_i_piii_sssf_ivset_unchecked (opt_info* o) { - s7_pointer vec = slot_value (q_arg1 (o).p); - s7_int val = q_i_func3_call (o); - int_vector (vec, - ((integer (slot_value (q_arg2 (o).p)) * vector_offset (vec, 0)) + - integer (slot_value (q_arg3 (o).p))))= val; - return (val); +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 + */ + const s7_pointer func = car(args); + if (!is_applicable(func)) + apply_error_nr(sc, func, cdr(args)); + if (is_null(cdr(args))) + { + push_stack(sc, OP_APPLY, sc->nil, func); + return(sc->nil); + } + if (is_safe_procedure(func)) + { + s7_pointer arg, next_arg; + if (is_immutable(args)) /* (apply '(1) '(1)) where sc->t2_1 gets used in op_x_aa? */ + args = copy_proper_list(sc, args); + for (arg = args, next_arg = cdr(args); is_pair(cdr(next_arg)); arg = next_arg, next_arg = cdr(next_arg)); + /* 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(next_arg))) /* (apply + #f) etc, the cycle protection here is checked in s7test */ + apply_list_error_nr(sc, args); + set_cdr(arg, car(next_arg)); /* args affected, so don't depend on cdr(args) from above */ + + if (is_c_function(func)) /* handle in-place to get better error messages */ + { + s7_int len; + const uint8_t typ = type(func); + if (typ == T_C_RST_NO_REQ_FUNCTION) + return(c_function_call(func)(sc, cdr(args))); + len = proper_list_length(cdr(args)); + if (c_function_max_args(func) < len) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, too_many_arguments_string, func, set_ulist_1(sc, sc->apply_symbol, args))); + if ((typ == T_C_FUNCTION) && + (len < c_function_min_args(func))) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, not_enough_arguments_string, func, set_ulist_1(sc, sc->apply_symbol, args))); + return(c_function_call(func)(sc, cdr(args))); + } + push_stack(sc, OP_APPLY, cdr(args), func); + return(sc->nil); + } + sc->code = func; + sc->args = (is_null(cddr(args))) ? cadr(args) : apply_list_star(sc, cdr(args)); + if (!s7_is_proper_list(sc, sc->args)) + apply_list_error_nr(sc, sc->args); + + /* (define imp (immutable! (cons 0 (immutable! (cons 1 (immutable! (cons 2 ()))))))) + * (define (fop4 x y) (apply x y)) + * (display (object->string (apply (lambda (a . b) (cons a b)) imp) :readable)) -> (list 0 1 2) + * (display (object->string (fop4 (lambda (a . b) (cons a b)) imp) :readable)) -> (cons 0 (immutable! (cons 1 (immutable! (cons 2 ()) + * g_apply sees the first one and thinks the lambda arg is unsafe, apply_ss sees the second and thinks it is safe (hence the list is not copied), + * so calling sort on the first is fine, but on the second gets an immutable object error. + */ + if (needs_copied_args(sc->code)) sc->args = copy_proper_list(sc, sc->args); + push_stack_direct(sc, OP_APPLY); + return(sc->nil); } -static s7_int -opt_i_7piii_sssc (opt_info* o) { - return (q_func (o).i_7piii_f ( - o->sc, slot_value (q_arg1 (o).p), integer (slot_value (q_arg2 (o).p)), - integer (slot_value (q_arg3 (o).p)), q_arg4 (o).i)); +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_nr(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_int -opt_i_7piii_ssss (opt_info* o) { - return (q_func (o).i_7piii_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - integer (slot_value (q_arg3 (o).p)), - integer (slot_value (q_arg4 (o).p)))); +static s7_pointer apply_method_closure(s7_scheme *sc, s7_pointer func, s7_pointer args) +{ + push_stack_direct(sc, OP_EVAL_DONE); + sc->code = func; + sc->args = (needs_copied_args(sc->code)) ? copy_proper_list(sc, args) : args; + set_curlet(sc, make_let(sc, closure_let(sc->code))); + eval(sc, OP_APPLY_LAMBDA); + return(sc->value); } -static s7_int -opt_i_7piii_sfff (opt_info* o) { - s7_int i1= q_i_func2_call (o); - s7_int i2= q_i_func3_call (o); - s7_int i3= q_i_func4_call (o); - return (q_func (o).i_7piii_f (o->sc, slot_value (q_arg1 (o).p), i1, i2, i3)); +static s7_pointer apply_c_function_unopt(s7_scheme *sc, s7_pointer func, s7_pointer args); + +static s7_pointer implicit_index_checked(s7_scheme *sc, s7_pointer obj, s7_pointer in_obj, s7_pointer indices) +{ + if (!is_applicable(in_obj)) + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "~$ becomes ~$, but ~S can't take arguments", 42), + set_ulist_1(sc, obj, indices), cons(sc, in_obj, cdr(indices)), in_obj)); + return(implicit_index(sc, in_obj, cdr(indices))); } -static bool -opt_i_7piii_args (s7_scheme* sc, opt_info* opc, s7_pointer indexp1, - s7_pointer indexp2, s7_pointer valp) { - /* opc->[5] is the called function (int-vector-set! etc) */ - s7_pointer slot2= opt_integer_symbol (sc, car (indexp2)); - if (slot2) { - s7_pointer slot1; - q_arg3 (opc).p= slot2; - slot1 = opt_integer_symbol (sc, car (indexp1)); - if (slot1) { - s7_pointer slot3; - q_arg2 (opc).p= slot1; - if (is_t_integer (car (valp))) { - q_call (opc).fi= opt_i_7piii_sssc; - q_arg4 (opc).i = integer (car (valp)); - return_true (sc, NULL); +static s7_pointer implicit_index(s7_scheme *sc, s7_pointer obj, s7_pointer indices) +{ + /* (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(s7i_vector_ref_1(sc, obj, indices)); + + case T_FLOAT_VECTOR: + { + s7_pointer result = 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(result); } - slot3= opt_integer_symbol (sc, car (valp)); - if (slot3) { - q_arg4 (opc).p = slot3; - q_call (opc).fi= opt_i_7piii_ssss; - return_true (sc, NULL); + case T_COMPLEX_VECTOR: + { + s7_pointer result = univect_ref(sc, set_ulist_1(sc, obj, indices), sc->complex_vector_ref_symbol, T_COMPLEX_VECTOR); + set_car(sc->u1_1, sc->F); + return(result); } - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, valp)) { - q_func3 (opc).fi= q_func3_arg (opc).q_call (o1).fi; - q_call (opc).fi = opt_i_7piii_sssf; - if ((q_func (opc).i_7piii_f == int_vector_set_i_7piii) && - (loop_end_fits ( - q_arg2 (opc).p, - vector_dimension (slot_value (q_arg1 (opc).p), 0))) && - (loop_end_fits (q_arg3 (opc).p, - vector_dimension (slot_value (q_arg1 (opc).p), 1)))) - q_call (opc).fi= opt_i_piii_sssf_ivset_unchecked; - return_true (sc, NULL); + case T_INT_VECTOR: + { + s7_pointer result = 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(result); } - } - return_false (sc, valp); - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, indexp1)) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, indexp2)) { - q_func4_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, valp)) { - q_call (opc).fi = opt_i_7piii_sfff; - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_func3 (opc).fi= q_func3_arg (opc).q_call (o1).fi; - q_func4 (opc).fi= q_func4_arg (opc).q_call (o1).fi; - return_true (sc, NULL); + case T_BYTE_VECTOR: + { + s7_pointer result = 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(result); + } + case T_STRING: /* (#("12" "34") 0 1) -> #\2 */ + if (!is_null(cdr(indices))) + error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, too_many_arguments_string, obj, indices)); + if (!is_t_integer(car(indices))) + wrong_type_error_nr(sc, sc->string_ref_symbol, 2, car(indices), sc->type_names[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 */ + { + s7_pointer in_obj = list_ref_1(sc, obj, car(indices)); + if (is_pair(cdr(indices))) + return(implicit_index_checked(sc, obj, in_obj, indices)); + return(in_obj); } - } - } - return_false (sc, indexp1); -} - -static bool -opt_int_vector_set (s7_scheme* sc, int32_t otype, opt_info* opc, s7_pointer v, - s7_pointer indexp1, s7_pointer indexp2, s7_pointer valp) { - s7_pointer settee= s7_slot (sc, v); - if ((is_slot (settee)) && (!is_immutable (slot_value (settee)))) { - const s7_pointer vect = slot_value (settee); - const bool int_case= (is_int_vector (vect)); - q_arg1 (opc).p = settee; /* either ipii or ipiii arg1 */ - 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)) /* q_ipii case */ + case T_HASH_TABLE: /* ((vector (hash-table '(a . 1) '(b . 2))) 0 'a) -> 1 */ { - s7_pointer slot; - q_func (opc).i_7pii_f= - (int_case) ? int_vector_set_i_7pii : byte_vector_set_i_7pii; - slot= opt_integer_symbol (sc, car (indexp1)); - if (slot) { - const int32_t start= sc->pc; - q_arg2 (opc).p = slot; - if (loop_end_fits (q_arg2 (opc).p, vector_length (vect))) - q_func (opc).i_7pii_f= (int_case) ? int_vector_set_i_7pii_direct - : byte_vector_set_i_7pii_direct; - if ((is_pair (valp)) && (is_null (cdr (valp))) && - (is_t_integer (car (valp)))) { - q_arg3 (opc).i = integer (car (valp)); - q_call (opc).fi= opt_i_7pii_ssc; - return_true (sc, NULL); - } - if (!int_optimize (sc, valp)) return_false (sc, valp); - q_call (opc).fi= - (q_func (opc).i_7pii_f == int_vector_set_i_7pii_direct) - ? opt_i_7pii_ssf_vset - : opt_i_7pii_ssf; - q_func1_arg (opc).o1= sc->opts[start]; - q_func1 (opc).fi = q_call (sc->opts[start]).fi; - return_true (sc, NULL); - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, indexp1)) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, valp)) { - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_func3 (opc).fi= q_func3_arg (opc).q_call (o1).fi; - if (q_func2 (opc).fi == - opt_i_c) /* (int-vector-set! v 0 (floor (sqrt i))) */ - { - q_call (opc).fi= opt_i_7pii_sif; - q_arg2 (opc).i = q_func2_arg (opc).q_arg1 (o1).i; - } - else q_call (opc).fi= opt_i_7pii_sff; - return_true (sc, NULL); - } - } - return_false (sc, valp); + s7_pointer in_obj = s7_hash_table_ref(sc, obj, car(indices)); + if (is_pair(cdr(indices))) + return(implicit_index_checked(sc, obj, in_obj, indices)); + return(in_obj); } - if ((indexp2) && (vector_rank (vect) == 2)) /* q_ipiii case */ + case T_LET: { - q_func (opc).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)); + s7_pointer in_obj = let_ref(sc, obj, car(indices)); + if (is_pair(cdr(indices))) + return(implicit_index_checked(sc, obj, in_obj, indices)); + return(in_obj); } + case T_C_OBJECT: + { + s7_pointer result = (*(c_object_ref(sc, obj)))(sc, set_ulist_1(sc, obj, indices)); + set_car(sc->u1_1, sc->F); + return(result); + } + case T_ITERATOR: /* indices is not nil, so this is an error */ + error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, too_many_arguments_string, obj, indices)); + + case T_CLOSURE: case T_CLOSURE_STAR: + if (!is_safe_closure(obj)) /* s7_call can't work in general with unsafe stuff */ + error_nr(sc, sc->syntax_error_symbol, /* ((list (lambda (x) (values x x))) 0 1) */ + set_elist_3(sc, wrap_string(sc, "can't call an unsafe function implicitly: ~S ~S", 47), obj, indices)); + check_stack_size(sc); + sc->temp9 = indices; /* (needs_copied_args(obj)) ? copy_proper_list(sc, indices) : indices; */ /* s7_call copies and this is safe? 2-Oct-22 (and below) */ + sc->value = s7_call(sc, obj, sc->temp9); + if ((S7_DEBUGGING) && (!is_pair(sc->temp9))) fprintf(stderr, "%s[%d]: temp9: %s\n", __func__, __LINE__, display(sc->temp9)); + sc->temp9 = sc->unused; + if ((S7_DEBUGGING) && (is_multiple_value(sc->value))) fprintf(stderr, "mv: %s %s %s\n", display(obj), display(indices), display(sc->value)); + /* if mv: sc->value = splice_in_values(sc, multiple_value(sc->value)); */ + return(sc->value); + + case T_C_FUNCTION: /* probably something like ((list abs) 0 -1) */ + return(apply_c_function_unopt(sc, obj, indices)); + + case T_C_RST_NO_REQ_FUNCTION: + if (!is_safe_procedure(obj)) /* values in particular */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "can't call an unsafe procedure implicitly: ~S ~S", 48), obj, indices)); + return(c_function_call(obj)(sc, indices)); + + default: + if (!is_applicable(obj)) /* (#2d((0 0)(0 0)) 0 0 0) */ + apply_error_nr(sc, obj, indices); + sc->temp9 = indices; /* (needs_copied_args(obj)) ? copy_proper_list(sc, indices) : indices; */ /* do not use sc->args here! */ + /* the following s7_call can clobber the temp var */ + sc->value = s7_call(sc, obj, sc->temp9); + sc->temp9 = sc->unused; + if (is_multiple_value(sc->value)) + sc->value = splice_in_values(sc, multiple_value(sc->value)); + return(sc->value); } - } - return_false (sc, v); -} - -static bool -i_implicit_ok (s7_scheme* sc, s7_pointer s_slot, s7_pointer expr, int32_t len) { - const s7_pointer obj= slot_value (s_slot); - if ((is_int_vector (obj)) || (is_byte_vector (obj))) { - const bool int_case= is_int_vector (obj); - s7_pointer slot; - - if ((len == 2) && /* ipi case */ - (vector_rank (obj) == 1)) { - opt_info* opc = alloc_opt_info (sc); - q_arg1 (opc).p= s_slot; - slot = opt_integer_symbol (sc, cadr (expr)); - if (slot) { - q_call (opc).fi= opt_i_7pi_ss; - q_func (opc).i_7pi_f= - (int_case) ? int_vector_ref_i_7pi : byte_vector_ref_i_7pi; - q_arg2 (opc).p= slot; - if (loop_end_fits (q_arg2 (opc).p, vector_length (obj))) - q_func (opc).i_7pi_f= (int_case) ? int_vector_ref_i_pi_direct - : byte_vector_ref_i_7pi_direct; - /* not q_call(opc).fi = opt_i_pi_ss_ivref -- this causes a huge slowdown - * in dup.scm?? */ - return_true (sc, expr); - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (!int_optimize (sc, cdr (expr))) return_false (sc, expr); - q_call (opc).fi= opt_i_7pi_sf; - q_func (opc).i_7pi_f= - (int_case) ? int_vector_ref_i_7pi : byte_vector_ref_i_7pi; - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - return_true (sc, expr); - } - if ((len == 3) && /* ipii case */ - (vector_rank (obj) == 2)) { - opt_info* opc = alloc_opt_info (sc); - q_arg1 (opc).p= s_slot; - slot = opt_integer_symbol (sc, cadr (expr)); - if (slot) { - q_arg2 (opc).p= slot; - slot = opt_integer_symbol (sc, caddr (expr)); - if (!slot) return_false (sc, expr); - q_func (opc).i_7pii_f= - (int_case) ? int_vector_ref_i_7pii : byte_vector_ref_i_7pii; - q_arg3 (opc).p = slot; - q_call (opc).fi= opt_i_7pii_sss; - if ((int_case) && - (loop_end_fits (q_arg2 (opc).p, vector_dimension (obj, 0))) && - (loop_end_fits (q_arg3 (opc).p, vector_dimension (obj, 1)))) - q_call (opc).fi= opt_i_pii_sss_ivref_unchecked; - return_true (sc, expr); - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cdr (expr))) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cddr (expr))) { - q_func (opc).i_7pii_f= - (int_case) ? int_vector_ref_i_7pii : byte_vector_ref_i_7pii; - q_call (opc).fi = opt_i_7pii_sff; - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_func3 (opc).fi= q_func3_arg (opc).q_call (o1).fi; - return_true (sc, expr); - } +} + +static inline void fill_star_defaults(s7_scheme *sc, s7_pointer func, int32_t start_arg, int32_t n_args, s7_pointer par) +{ + s7_pointer *df = c_function_arg_defaults(func); + if (c_func_has_simple_defaults(func)) + for (int32_t i = start_arg; i < n_args; i++, par = cdr(par)) + set_car(par, df[i]); + else + for (int32_t 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 set_car(par, (is_pair(defval)) ? s7_eval(sc, defval, sc->rootlet) : defval); } +} + +static s7_pointer set_c_function_star_args(s7_scheme *sc) +{ + int32_t i; + s7_pointer arg, par, call_args; + const s7_pointer func = sc->code; + const int32_t n_args = c_function_max_args(func); /* not counting keywords, I think, "par" and "arg" are not used consistently here */ + + if (is_safe_procedure(func)) + call_args = c_function_call_args(func); + else + { + call_args = make_list(sc, c_function_optional_args(func), sc->F); + gc_protect_via_stack(sc, call_args); } - } - return_false (sc, expr); -} - -static bool -i_7piii_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr) { - const s7_i_7piii_t func= s7_i_7piii_function (s_func); - if ((func) && (is_symbol (cadr (expr)))) { - s7_pointer settee; - if ((is_target_or_its_alias (car (expr), s_func, - sc->int_vector_set_symbol)) || - (is_target_or_its_alias (car (expr), s_func, - sc->byte_vector_set_symbol))) - return (opt_int_vector_set ( - sc, (car (expr) == sc->int_vector_set_symbol) ? 1 : 0, opc, - cadr (expr), cddr (expr), cdddr (expr), cddddr (expr))); - - settee= s7_slot (sc, cadr (expr)); - if (is_slot (settee)) { - s7_pointer vect= slot_value (settee); - if ((is_int_vector (vect)) && (vector_rank (vect) == 3)) { - q_func (opc).i_7piii_f= func; - q_arg1 (opc).p = settee; - return (opt_i_7piii_args (sc, opc, cddr (expr), cdddr (expr), - cddddr (expr))); - } + /* 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_symbol_and_keyword(car(arg))) + set_car(par, car(arg)); + else + { + s7_pointer kpar, karg; + int32_t ki; + s7_pointer *par_names; + /* 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_small_symbol_set + */ + for (kpar = call_args; kpar != par; kpar = cdr(kpar)) + set_checked(kpar); + for (; is_pair(kpar); kpar = cdr(kpar)) + clear_checked(kpar); + par_names = c_function_par_names(func); /* changed to use symbols here, not keywords 2-Jan-24 */ + for (ki = i, karg = arg, kpar = par; (ki < n_args) && (is_pair(karg)); ki++, karg = cdr(karg)) + if (!is_symbol_and_keyword(car(karg))) + { + if (is_checked(kpar)) + { + if (!is_safe_procedure(func)) unstack_gc_protect(sc); + error_nr(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 pars; + int32_t j; + for (j = 0, pars = call_args; j < n_args; j++, pars = cdr(pars)) + if (par_names[j] == keyword_symbol(car(karg))) + break; + if (j == n_args) + { + if (!c_function_allows_other_keys(func)) + { + if (!is_safe_procedure(func)) unstack_gc_protect(sc); + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "~A is not a parameter name?", 27), car(karg))); + } + karg = cdr(karg); + if (is_null(karg)) /* (f :x) where f arglist includes :allow-other-keys */ + { + if (!is_safe_procedure(func)) unstack_gc_protect(sc); + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "~A: key ~S, but no value: ~S", 28), func, car(arg), sc->args)); + } + ki--; + } + else + { + if (is_checked(pars)) + { + if (!is_safe_procedure(func)) unstack_gc_protect(sc); + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, parameter_set_twice_string, car(pars), sc->args)); + } + if (!is_pair(cdr(karg))) + { + if (!is_safe_procedure(func)) unstack_gc_protect(sc); + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "~A: key ~S, but no value: ~S", 28), func, car(karg), sc->args)); + } + set_checked(pars); + karg = cdr(karg); + set_car(pars, car(karg)); + kpar = cdr(kpar); + }} + if ((!is_null(karg)) && (!c_function_allows_other_keys(func))) + { + if (!is_safe_procedure(func)) unstack_gc_protect(sc); + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_4(sc, wrap_string(sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), func, func, sc->args)); + } + if (ki < n_args) + { + s7_pointer *par_defaults = 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, par_defaults[ki]); + } + else + for (ki = i, kpar = par; ki < n_args; ki++, kpar = cdr(kpar)) + if (!is_checked(kpar)) + { + s7_pointer defval = par_defaults[ki]; + if (is_symbol(defval)) + set_car(kpar, lookup_checked(sc, defval)); + else set_car(kpar, (is_pair(defval)) ? s7_eval(sc, defval, sc->rootlet) : defval); + }} + if (!is_safe_procedure(func)) unstack_gc_protect(sc); + return(call_args); + } + if (!is_null(arg)) + { + if (!is_safe_procedure(func)) unstack_gc_protect(sc); + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_4(sc, wrap_string(sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), func, func, sc->args)); } - } - return_false (sc, expr); + if (i < n_args) + fill_star_defaults(sc, func, i, n_args, par); + if (!is_safe_procedure(func)) unstack_gc_protect(sc); + return(call_args); } -/* -------- i_add|multiply_any -------- */ +static s7_pointer set_c_function_star_defaults(s7_scheme *sc, int32_t num) +{ + s7_pointer call_args, par; + const s7_pointer func = sc->code; + const int32_t n_args = c_function_max_args(func); -#define q_i_am_args(o) o->v[1] -#define q_i_am_arg(o, i) o->v[i + 2] -#define q_i_am_func(o, i) \ - o->v[i + 6] /* the following are for the special cases (2-4 args), not \ - i_add_any_f */ -#define q_i_am_func1_arg(o) o->v[2] -#define q_i_am_func1(o) o->v[6] -#define q_i_am_func2_arg(o) o->v[3] -#define q_i_am_func2(o) o->v[7] -#define q_i_am_func3_arg(o) o->v[4] -#define q_i_am_func3(o) o->v[8] -#define q_i_am_func4_arg(o) o->v[5] -#define q_i_am_func4(o) o->v[9] - -#define q_i_am_func1_call(o) q_i_am_func1 (o).fi (q_i_am_func1_arg (o).o1) -#define q_i_am_func2_call(o) q_i_am_func2 (o).fi (q_i_am_func2_arg (o).o1) -#define q_i_am_func3_call(o) q_i_am_func3 (o).fi (q_i_am_func3_arg (o).o1) -#define q_i_am_func4_call(o) q_i_am_func4 (o).fi (q_i_am_func4_arg (o).o1) - -static s7_int -opt_i_add_any_f (opt_info* o) { - s7_int sum= 0; - for (s7_int i= 0; i < q_i_am_args (o).i; i++) { - opt_info* o1= q_i_am_arg (o, i).o1; -#if WITH_WARNINGS && HAVE_OVERFLOW_CHECKS - s7_int new_val, - val= q_call (o1).fi (o1); /* this is not worth all this bother */ - if (add_overflow (sum, val, &new_val)) { - s7_warn (o->sc, 128, "integer add overflow: (+ %" ld64 " %" ld64 ")\n", - sum, val); - return (sum); - } - sum= new_val; -#else - sum+= q_call (o1).fi (o1); -#endif - } - return (sum); + if (is_safe_procedure(func)) + call_args = c_function_call_args(func); + else + { + call_args = make_list(sc, c_function_optional_args(func), sc->F); + gc_protect_via_stack(sc, call_args); + } + par = call_args; + if (num == 1) + { + set_car(par, car(sc->args)); + par = cdr(par); + } + fill_star_defaults(sc, func, num, n_args, par); + if (!is_safe_procedure(func)) unstack_gc_protect(sc); + return(call_args); } -static s7_int -opt_i_add2 (opt_info* o) { - s7_int sum= q_i_am_func1_call (o); - return (sum + q_i_am_func2_call (o)); -} +#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)) -static s7_int -opt_i_mul2 (opt_info* o) { - s7_int sum= q_i_am_func1_call (o); - return (sum * q_i_am_func2_call (o)); +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; /* this protection is needed, see snd-test.scm test 8 */ + sc->z = sc->code; + sc->args = T_Ext(args); + sc->code = fnc; + apply_c_function_star(sc); + sc->args = sc->w; + sc->code = sc->z; + sc->z = sc->unused; + 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); } -static s7_int -opt_i_add3 (opt_info* o) { - s7_int sum= q_i_am_func1_call (o); - sum+= q_i_am_func2_call (o); - return (sum + q_i_am_func3_call (o)); -} +/* -------------------------------- eval -------------------------------- */ +s7_pointer s7_eval(s7_scheme *sc, s7_pointer code, s7_pointer let) +{ + declare_jump_info(); + TRACK(sc); + if (sc->safety > no_safety) + { + if (!s7_is_valid(sc, code)) + s7_warn(sc, 256, "the second argument to %s (the code to be evaluated): %p, is not an s7 object\n", __func__, code); + if (!s7_is_valid(sc, let)) + s7_warn(sc, 256, "the third argument to %s (the environment): %p, is not an s7 object\n", __func__, let); + } + 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; + set_curlet(sc, (is_let(let)) ? let : sc->rootlet); + eval(sc, OP_EVAL); + } + restore_jump_info(sc); -static s7_int -opt_i_mul3 (opt_info* o) { - s7_int sum= q_i_am_func1_call (o); - sum*= q_i_am_func2_call (o); - return (sum * q_i_am_func3_call (o)); + if (is_multiple_value(sc->value)) + sc->value = splice_in_values(sc, multiple_value(sc->value)); + return(sc->value); } -static s7_int -opt_i_add4 (opt_info* o) { - s7_int sum= q_i_am_func1_call (o); - sum+= q_i_am_func2_call (o); - sum+= q_i_am_func3_call (o); - return (sum + q_i_am_func4_call (o)); +s7_pointer s7_eval_with_location(s7_scheme *sc, s7_pointer code, s7_pointer let, 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_eval(sc, code, (let == sc->nil) ? sc->rootlet : let); + if (caller) + { + sc->s7_call_name = NULL; + sc->s7_call_file = NULL; + sc->s7_call_line = -1; + } + return(result); } -static s7_int -opt_i_mul4 (opt_info* o) { - s7_int sum= q_i_am_func1_call (o); - sum*= q_i_am_func2_call (o); - sum*= q_i_am_func3_call (o); - return (sum * q_i_am_func4_call (o)); +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, has_let_signature(sc)) + + if (is_pair(cdr(args))) + { + s7_pointer let = cadr(args); + if (!is_let(let)) + { + s7_pointer new_let = find_let(sc, let); + if (!is_let(new_let)) + find_let_error_nr(sc, sc->eval_symbol, let, new_let, 2, args); + let = new_let; + } + set_curlet(sc, let); + } + 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); /* clears "unsafe" ops, not all ops */ + set_current_code(sc, sc->code); + if (stack_top(sc) < 12) + push_stack_op(sc, OP_BARRIER); + push_stack_direct(sc, OP_EVAL); + return(sc->nil); } -static s7_int -opt_i_mul_any_f (opt_info* o) { - s7_int sum= 1; - for (s7_int i= 0; i < q_i_am_args (o).i; i++) { - opt_info* o1= q_i_am_arg (o, i).o1; - sum*= q_call (o1).fi (o1); - } - return (sum); -} - -static bool -i_add_any_ok (s7_scheme* sc, opt_info* opc, s7_pointer expr) { - s7_pointer p; - const s7_pointer head= car (expr); - int32_t cur_len; - const int32_t start= sc->pc; - for (cur_len= 0, p= cdr (expr); - (is_pair (p)) && (cur_len < (num_vunions - 2)); p= cdr (p), cur_len++) { - q_i_am_arg (opc, cur_len).o1= sc->opts[sc->pc]; - if (!int_optimize (sc, p)) break; - } - if (is_null (p)) { - q_i_am_args (opc).i= cur_len; - if (cur_len <= 4) - for (int32_t i= 0; i < cur_len; i++) - q_i_am_func (opc, i).fi= q_i_am_arg (opc, i).q_call (o1).fi; - if (cur_len == 2) - q_call (opc).fi= (head == sc->add_symbol) ? opt_i_add2 : opt_i_mul2; - else if (cur_len == 3) - q_call (opc).fi= (head == sc->add_symbol) ? opt_i_add3 : opt_i_mul3; - else if (cur_len == 4) - q_call (opc).fi= (head == sc->add_symbol) ? opt_i_add4 : opt_i_mul4; + +s7_pointer s7_call(s7_scheme *sc, s7_pointer func, s7_pointer args) +{ + if (is_c_function(func)) + return(c_function_call(func)(sc, args)); /* no check for wrong-number-of-args -- is that reasonable? maybe use apply_c_function(sc, func, 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_truncated(func), display_truncated(args))); + + sc->temp4 = T_App(func); /* this is feeble GC protection */ + sc->temp2 = T_Lst(args); /* only use of temp2 */ + 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 - q_call (opc).fi= - (head == sc->add_symbol) ? opt_i_add_any_f : opt_i_mul_any_f; - return_true (sc, expr); + { + if (sc->safety > no_safety) + check_list_validity(sc, __func__, 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; + 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); } - sc->pc= start; - return_false (sc, expr); } -/* -------- set_i_i -------- */ - -static s7_int -opt_set_i_i_f (opt_info* o) { - s7_int x= q_func (o).fi (q_arg2 (o).o1); - slot_set_value (q_arg1 (o).p, make_integer (o->sc, x)); - return (x); +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); } -#if S7_DEBUGGING -static void -check_mutability (s7_scheme* sc, opt_info* o, const char* func, int line) { - if (!is_mutable_number (slot_value (q_arg1 (o).p))) { - fprintf (stderr, "%s[%d]: %s value is not mutable", func, line, - display (q_arg1 (o).p)); - if (sc->stop_at_error) abort (); - } + +/* -------------------------------- 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 check_mutability(Sc, O, Func, Line) +#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 s7_int -opt_set_i_i_fm (opt_info* o) /* called in increment: (set! sum (+ sum (...))) - where all are ints */ +static void init_typers(s7_scheme *sc) { - s7_int x= q_func (o).fi (q_arg2 (o).o1); - check_mutability (o->sc, o, __func__, __LINE__); - set_integer (slot_value (q_arg1 (o).p), x); - return (x); -} + 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_BOOLEAN] = sc->is_boolean_symbol; + sc->type_to_typers[T_BYTE_VECTOR] = sc->is_byte_vector_symbol; + sc->type_to_typers[T_CATCH] = sc->F; + sc->type_to_typers[T_CHARACTER] = sc->is_char_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_COMPLEX] = sc->is_complex_symbol; + sc->type_to_typers[T_CONTINUATION] = sc->is_continuation_symbol; + sc->type_to_typers[T_COUNTER] = sc->F; + sc->type_to_typers[T_FREE] = sc->error_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_MACRO] = sc->is_macro_symbol; + sc->type_to_typers[T_C_OBJECT] = sc->is_c_object_symbol; + sc->type_to_typers[T_C_POINTER] = sc->is_c_pointer_symbol; + sc->type_to_typers[T_C_RST_NO_REQ_FUNCTION] = sc->is_procedure_symbol; + sc->type_to_typers[T_DYNAMIC_WIND] = sc->F; + sc->type_to_typers[T_EOF] = sc->is_eof_object_symbol; + sc->type_to_typers[T_FLOAT_VECTOR] = sc->is_float_vector_symbol; + sc->type_to_typers[T_COMPLEX_VECTOR] = sc->is_complex_vector_symbol; + sc->type_to_typers[T_FREE] = sc->F; + sc->type_to_typers[T_GOTO] = sc->is_goto_symbol; + sc->type_to_typers[T_HASH_TABLE] = sc->is_hash_table_symbol; + sc->type_to_typers[T_INPUT_PORT] = sc->is_input_port_symbol; + sc->type_to_typers[T_INTEGER] = sc->is_integer_symbol; + sc->type_to_typers[T_INT_VECTOR] = sc->is_int_vector_symbol; + sc->type_to_typers[T_ITERATOR] = sc->is_iterator_symbol; + sc->type_to_typers[T_LET] = sc->is_let_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_NIL] = sc->is_null_symbol; + sc->type_to_typers[T_OUTPUT_PORT] = sc->is_output_port_symbol; + sc->type_to_typers[T_PAIR] = sc->is_pair_symbol; + sc->type_to_typers[T_RANDOM_STATE] = sc->is_random_state_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_SLOT] = sc->F; + sc->type_to_typers[T_STACK] = sc->F; + sc->type_to_typers[T_STRING] = sc->is_string_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_UNDEFINED] = sc->is_undefined_symbol; + sc->type_to_typers[T_UNSPECIFIED] = sc->is_unspecified_symbol; + sc->type_to_typers[T_UNUSED] = sc->F; + sc->type_to_typers[T_VECTOR] = sc->is_vector_symbol; +} + +s7_pointer s7_type_of(s7_scheme *sc, s7_pointer arg) {return(sc->type_to_typers[type(arg)]);} + +/* g_type_of migrated to s7_scheme_predicate.c */ +#define H_type_of "(type-of obj) returns a symbol describing obj's type: (type-of 1): 'integer?" +#define Q_type_of s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->not_symbol), sc->T) + -static s7_int -opt_set_i_i_fo (opt_info* o) { - s7_int x= integer (slot_value (q_arg3 (o).p)) + q_arg2 (o).i; - slot_set_value (q_arg1 (o).p, make_integer (o->sc, x)); - return (x); +/* -------------------------------- 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_int -opt_set_i_i_fom (opt_info* o) { - s7_int x= integer (slot_value (q_arg3 (o).p)) + q_arg2 (o).i; - check_mutability (o->sc, o, __func__, __LINE__); - set_integer (slot_value (q_arg1 (o).p), x); - return (x); +#ifndef EXIT_SUCCESS + #define EXIT_SUCCESS 0 + #define EXIT_FAILURE 1 +#endif + +static s7_pointer g_emergency_exit(s7_scheme *sc, s7_pointer args) +{ + #define H_emergency_exit "(emergency-exit (obj #t)) exits s7 immediately. 'obj', the value passed to libc's _exit, can be an integer or #t=success (0) or #f=fail (1)." + #define Q_emergency_exit s7_make_signature(sc, 2, sc->T, sc->T) + + s7_pointer obj; + if (is_null(args)) _exit(EXIT_SUCCESS); /* r7rs spec says use _exit here (which does not call any functions registered with atexit or on_exit */ + 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_clamped_if_gmp(sc, obj)); + return(sc->F); } -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 (q_call (o1).fi == opt_i_ii_sc_add) { - q_arg3 (opc).p = q_arg1 (o1).p; /* i_iii, arg1(o) set earlier */ - q_arg2 (opc).i = q_arg2 (o1).i; /* i_iii */ - q_call (opc).fi= opt_set_i_i_fo; - backup_pc (sc); - return_true (sc, NULL); +static gc_list_t *call_c_object_frees(s7_scheme *sc) +{ + gc_list_t *gp = sc->c_objects; + for (s7_int i = 0; i < gp->loc; i++) + { + s7_pointer cobj = gp->list[i]; + if (c_object_gc_free(sc, cobj)) + (*(c_object_gc_free(sc, cobj)))(sc, cobj); + else (*(c_object_free(sc, cobj)))(c_object_value(cobj)); } - } - return_false (sc, NULL); + return(gp); /* for s7_free */ } -static bool -i_syntax_ok (s7_scheme* sc, s7_pointer expr, int32_t len) { - if ((car (expr) == sc->set_symbol) && (len == 3)) { - const s7_pointer arg1= cadr (expr); - opt_info* opc = alloc_opt_info (sc); - if (is_symbol (arg1)) /* (set! i 3) */ - { - s7_pointer settee; - if (is_immutable (arg1)) return_false (sc, expr); - settee= s7_slot (sc, arg1); - if ((is_slot (settee)) && (is_t_integer (slot_value (settee))) && - (!is_immutable_slot (settee)) && - ((!slot_has_setter (settee)) || - ((is_c_function (slot_setter (settee))) && - ((is_eq_initial_c_function_data (sc->is_integer_symbol, - slot_setter (settee))) || - (c_function_call (slot_setter (settee)) == b_is_integer_setter))))) - /* opt set! won't change type, and it is an integer now (and we might not - hit opt_cell_set) */ +static s7_pointer g_exit(s7_scheme *sc, s7_pointer args) +{ + #define H_exit "(exit obj cobj) exits s7. 'obj', the value passed to libc's exit, can be an integer or #t=success (0) or #f=fail (1). \ +'cobj' is a boolean (defaults to #f), #t causes exit to call all active c-object gc_free functions." + #define Q_exit s7_make_signature(sc, 3, sc->T, sc->T, sc->is_boolean_symbol) + + /* calling s7_eval_c_string in an atexit function seems to be problematic -- it works, but args can be changed? */ + /* r7rs.pdf says exit checks the stack for dynamic-winds and runs the "after" functions, if any, + * and that it allows atexit functions to be called, so we need to use libc's exit, not _exit -- + * there's an example C program at the end of s7test.scm. + */ + for (s7_int op_loc = stack_top(sc) - 1; op_loc > 0; op_loc -= 4) + if (stack_op(sc->stack, op_loc) == OP_DYNAMIC_WIND) { - opt_info* o1 = sc->opts[sc->pc]; - q_arg1 (opc).p= settee; - if (int_optimize (sc, cddr (expr))) { - if (set_i_i_f_combinable (sc, opc)) return_true (sc, expr); - q_call (opc).fi= (is_mutable_integer (slot_value (q_arg1 (opc).p))) - ? opt_set_i_i_fm - : opt_set_i_i_f; - /* only a few opt_set_i_i_f|fo's remain in valcall suite */ - q_arg2 (opc).o1= o1; - q_func (opc).fi= q_call (o1).fi; - return_true (sc, expr); - } - } - } - else if ((is_pair (arg1)) && /* if is_pair(settee) get setter */ - (is_symbol (car (arg1))) && (is_pair (cdr (arg1)))) { - if (is_null (cddr (arg1))) - return (opt_int_vector_set (sc, -1, opc, car (arg1), cdr (arg1), NULL, - cddr (expr))); - if (is_null (cdddr (arg1))) - return (opt_int_vector_set (sc, -1, opc, car (arg1), cdr (arg1), - cddr (arg1), cddr (expr))); + s7_pointer dwind = T_Dyn(stack_code(sc->stack, op_loc)); + if (dynamic_wind_state(dwind) == dwind_body) /* otherwise init func never ran? */ + { + dynamic_wind_state(dwind) = dwind_finish; + if (dynamic_wind_out(dwind) != sc->F) + s7_call(sc, dynamic_wind_out(dwind), sc->nil); + }} + /* another case that Victor Lazzarini mentioned: there's no easy way in s7 to ask that all c-object free methods be run before exiting. + * I think I'll add that code here under an optional second argument. + */ + if ((is_pair(args)) && (is_pair(cdr(args)))) + { + s7_pointer cobj = cadr(args); + if (!is_boolean(cobj)) + wrong_type_error_nr(sc, sc->exit_symbol, 2, cobj, a_boolean_string); + if (cobj == sc->T) + call_c_object_frees(sc); } + if (hook_has_functions(sc->exit_hook)) + { + s7_pointer exit_code; + if (is_null(args)) + exit_code = s7_make_integer(sc, EXIT_SUCCESS); + else + { + s7_pointer obj = car(args); + if (obj == sc->F) + exit_code = s7_make_integer(sc, EXIT_FAILURE); + else if ((obj == sc->T) || (!s7_is_integer(obj))) + exit_code = s7_make_integer(sc, EXIT_SUCCESS); + else + exit_code = obj; + } + s7_apply_function(sc, sc->exit_hook, set_plist_1(sc, exit_code)); + } + + 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()); + + if (is_null(args)) exit(EXIT_SUCCESS); /* allow atexit functions etc */ + { + s7_pointer 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_clamped_if_gmp(sc, obj)); } - return_false (sc, expr); +#if __TINYC__ + return(sc->F); /* never reached, but tcc complains */ +#endif } -/* ------------------------------------- float opts - * ------------------------------------------- */ -static s7_double -opt_d_c (opt_info* o) { - return (q_arg1 (o).x); -} -static s7_double -opt_d_s (opt_info* o) { - return (real (slot_value (q_arg1 (o).p))); -} +/* -------------------------------- 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? + */ -static s7_double -opt_D_s (opt_info* o) { - s7_pointer x= slot_value (q_arg1 (o).p); - return ((is_t_integer (x)) ? (s7_double) (integer (x)) - : s7_number_to_real (o->sc, x)); +#if S7_DEBUGGING +static void check_t_1(s7_scheme *sc, s7_pointer let, const char *func, s7_pointer expr, s7_pointer var) +{ + if (let_slots(let) != s7_t_slot(sc, var)) + { + fprintf(stderr, "%s%s %s is out of date (%s in %s -> %s)%s\n", bold_text, func, display(expr), display(var), display(sc->curlet), + (is_not_slot_end(let_slots(let))) ? display(let_slots(let)) : "no slots", unbold_text); + if (sc->stop_at_error) abort(); + /* this usually signals a problem with enviroments (or arglists if optimize_lambda) */ + } } -static bool -opt_float_not_pair (s7_scheme* sc, s7_pointer expr) { - s7_pointer slot; - if (is_small_real (expr)) { - opt_info* opc = alloc_opt_info (sc); - q_arg1 (opc).x = s7_number_to_real (sc, expr); - q_call (opc).fd= opt_d_c; - return_true (sc, expr); - } - slot= opt_real_symbol (sc, expr); - if (slot) { - opt_info* opc = alloc_opt_info (sc); - q_arg1 (opc).p = slot; - q_call (opc).fd= (is_t_real (slot_value (slot))) ? opt_d_s : opt_D_s; - return_true (sc, expr); - } - return_false (sc, expr); +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))); } -/* -------- d -------- */ -static s7_double -opt_d_f (opt_info* o) { - return (q_func (o).d_f ()); +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 bool -d_ok (s7_scheme* sc, opt_info* opc, - s7_pointer s_func) /* (f): (mus-srate), ignore damned ccpcheck! */ +static void check_u_1(s7_scheme *sc, s7_pointer let, const char *func, s7_pointer expr, s7_pointer var) { - const s7_d_t func= s7_d_function (s_func); - if (!func) return_false (sc, NULL); - q_call (opc).fd = opt_d_f; - q_func (opc).d_f= func; - return_true (sc, NULL); + if (next_slot(let_slots(let)) != s7_t_slot(sc, var)) + { + fprintf(stderr, "%s%s %s is out of date (%s in %s -> %s)%s\n", bold_text, func, display(expr), display(var), display(let), + (is_not_slot_end(next_slot(let_slots(let)))) ? display(next_slot(let_slots(let))) : "no next slot", unbold_text); + if (sc->stop_at_error) abort(); + } } -/* -------- d_d -------- */ +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_double -opt_d_d_c (opt_info* o) { - return (q_func (o).d_d_f (q_arg1 (o).x)); -} -static s7_double -opt_d_d_s (opt_info* o) { - return (q_func (o).d_d_f (real (slot_value (q_arg1 (o).p)))); -} -static s7_double -opt_d_d_s_abs (opt_info* o) { - return (abs_d_d (real (slot_value (q_arg1 (o).p)))); -} -static s7_double -opt_d_7d_c (opt_info* o) { - return (q_func (o).d_7d_f (o->sc, q_arg1 (o).x)); -} -static s7_double -opt_d_7d_s (opt_info* o) { - return (q_func (o).d_7d_f (o->sc, real (slot_value (q_arg1 (o).p)))); -} - -static s7_double -opt_d_d_f (opt_info* o) { - return (q_func (o).d_d_f (q_d_func1_call (o))); -} -static s7_double -opt_d_d_f_abs (opt_info* o) { - return (abs_d_d (q_d_func1_call (o))); -} -static s7_double -opt_d_d_f_sin (opt_info* o) { - return (sin_d_d (q_d_func1_call (o))); -} -static s7_double -opt_d_d_f_cos (opt_info* o) { - return (cos_d_d (q_d_func1_call (o))); -} -static s7_double -opt_d_7d_f (opt_info* o) { - return (q_func (o).d_7d_f (o->sc, q_d_func1_call (o))); -} -static s7_double -opt_d_7d_f_divide (opt_info* o) { - return (divide_d_7d (o->sc, q_d_func1_call (o))); -} - -static s7_double opt_abs_d_ss_fvref (opt_info* o); -static s7_double opt_d_7pi_ss_fvref_direct (opt_info* o); - -static bool -d_d_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr) { - s7_d_7d_t func7= NULL; - const int32_t start= sc->pc; - const s7_d_d_t func = s7_d_d_function (s_func); - if (!func) func7= s7_d_7d_function (s_func); - if ((func) || (func7)) { - s7_pointer arg1_slot; - const s7_pointer arg1= cadr (expr); - if (func) q_func (opc).d_d_f= func; - else q_func (opc).d_7d_f= func7; - if (is_small_real (arg1)) { - if ((!is_t_real (arg1)) && /* (random 1) != (random 1.0) */ - ((car (expr) == sc->random_symbol) || - (car (expr) == sc->sin_symbol) || (car (expr) == sc->cos_symbol))) - return_false (sc, expr); - q_arg1 (opc).x = s7_number_to_real (sc, arg1); - q_call (opc).fd= (func) ? opt_d_d_c : opt_d_7d_c; - return_true (sc, expr); - } - arg1_slot= opt_float_symbol (sc, arg1); - if ((arg1_slot) && (!has_methods (slot_value (arg1_slot)))) { - q_arg1 (opc).p= arg1_slot; - q_call (opc).fd= - (func) ? ((func == abs_d_d) ? opt_d_d_s_abs : opt_d_d_s) : opt_d_7d_s; - return_true (sc, expr); - } - q_func1_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cdr (expr))) { - q_call (opc).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); - /* if (q_call(opc).fd == opt_d_7d_f_divide) in tnum we know the arg is not - * 0.0, so it could be further optimized (but it's the loop stepper) */ - q_func1 (opc).fd= q_func1_arg (opc).q_call (o1).fd; - if ((func == abs_d_d) && (q_func1 (opc).fd == opt_d_7pi_ss_fvref_direct)) - q_call (opc).fd= opt_abs_d_ss_fvref; - return_true (sc, expr); - } - sc->pc= start; - } - return_false (sc, expr); +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))))); } -/* -------- d_v -------- */ -static s7_double -opt_d_v (opt_info* o) { - return (q_func (o).d_v_f (q_arg1 (o).gen)); -} - -static bool -d_v_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr) { - s7_pointer sig; - const s7_d_v_t flt_func= s7_d_v_function (s_func); - if (!flt_func) return_false (sc, expr); - sig= c_function_signature (s_func); - if ((is_pair (sig)) && (is_symbol (cadr (sig))) && - (is_symbol ( - cadr (expr)))) /* look for (oscil g) or (next-sample reader) */ - { - s7_pointer slot= opt_types_match (sc, cadr (sig), cadr (expr)); - if (slot) { - q_arg1 (opc).gen = (void*) c_object_value (slot_value (slot)); - q_func (opc).d_v_f= flt_func; - q_call (opc).fd = opt_d_v; - return_true (sc, expr); +static void check_v_1(s7_scheme *sc, s7_pointer let, const char *func, s7_pointer expr, s7_pointer var) +{ + if (next_slot(next_slot(let_slots(let))) != s7_t_slot(sc, var)) + { + fprintf(stderr, "%s%s %s is out of date (%s in %s -> %s)%s\n", bold_text, func, display(expr), display(var), display(let), + (is_not_slot_end(next_slot(next_slot(let_slots(let))))) ? display(next_slot(next_slot(let_slots(let)))) : "no next slot", unbold_text); + if (sc->stop_at_error) abort(); } - } - return_false (sc, expr); } -/* -------- d_p -------- */ -static s7_double -opt_d_p_s (opt_info* o) { - return (q_func (o).d_p_f (slot_value (q_arg1 (o).p))); -} -static s7_double -opt_d_p_f (opt_info* o) { - return (q_func (o).d_p_f (q_p_func1_call (o))); +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_double -opt_d_7p_s (opt_info* o) { - return (q_func (o).d_7p_f (o->sc, slot_value (q_arg1 (o).p))); + +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 s7_double -opt_d_7p_f (opt_info* o) { - return (q_func (o).d_7p_f (o->sc, q_p_func1_call (o))); + +static void check_o_1(s7_scheme *sc, s7_pointer let, const char *func, s7_pointer expr, s7_pointer var) +{ + s7_pointer slot = s7_t_slot(sc, var); + if (lookup_slot_with_let(sc, var, let) != slot) + { + fprintf(stderr, "%s%s %s is out of date (%s in %s -> %s)%s\n", bold_text, func, display(expr), display(var), display(let), + (is_not_slot_end(slot)) ? display(slot) : "undefined", unbold_text); + if (sc->stop_at_error) abort(); + } } -static bool -d_p_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr) { - const int32_t start= sc->pc; - const s7_d_p_t dpf = s7_d_p_function ( - s_func); /* mostly clm gens like one_pole (none built-in in s7) */ - s7_d_7p_t d7pf; - if (!dpf) d7pf= s7_d_7p_function (s_func); - if ((!dpf) && (!d7pf)) return_false (sc, expr); - if (dpf) q_func (opc).d_p_f= dpf; - else q_func (opc).d_7p_f= d7pf; - if (is_symbol (cadr (expr))) { - s7_pointer slot= opt_simple_symbol (sc, cadr (expr)); - if (!slot) return_false (sc, expr); - q_arg1 (opc).p = slot; - q_call (opc).fd= (dpf) ? opt_d_p_s : opt_d_7p_s; - return_true (sc, expr); - } - q_func1_arg (opc).o1= sc->opts[sc->pc]; - if (cell_optimize (sc, cdr (expr))) { - q_call (opc).fd = (dpf) ? opt_d_p_f : opt_d_7p_f; - q_func1 (opc).fp= q_func1_arg (opc).q_call (o1).fp; - return_true (sc, expr); - } - sc->pc= start; - return_false (sc, expr); +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(inline_lookup_from(sc, symbol, let_outlet(sc->curlet))); } -/* -------- d_7pi -------- */ +#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) +#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) inline_lookup_from(Sc, Symbol, let_outlet(Sc->curlet)) +#endif -static s7_double -opt_d_7pi_sc (opt_info* o) { - return (q_func (o).d_7pi_f (o->sc, slot_value (q_arg1 (o).p), q_arg2 (o).i)); -} -static s7_double -opt_d_7pi_ss (opt_info* o) { - return (q_func (o).d_7pi_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_double -opt_d_7pi_sf (opt_info* o) { - return (q_func (o).d_7pi_f (o->sc, slot_value (q_arg1 (o).p), - q_i_func2_call (o))); -} -static s7_double -opt_d_7pi_ss_fvref (opt_info* o) { - return (float_vector_ref_d_7pi (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_double -opt_d_7pi_ss_fvref_direct (opt_info* o) { - return (float_vector (slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)))); -} - -static s7_double -opt_abs_d_ss_fvref (opt_info* o) { - opt_info* o1= q_func1_arg (o).o1; - return (abs_d_d (float_vector (slot_value (q_arg1 (o1).p), - integer (slot_value (q_arg2 (o1).p))))); -} - -static s7_double -opt_d_7pi_ff (opt_info* o) /* hit only in tbig (not even s7test) */ -{ - s7_pointer seq= q_p_func1_call (o); - return (q_func (o).d_7pi_f (o->sc, seq, q_i_func2_call (o))); -} - -static bool -d_7pi_ok (s7_scheme* sc, opt_info* opc, s7_pointer s_func, - const s7_pointer expr) { - /* float-vector-ref is checked for a 1D float-vector arg, but other callers - * should do type checking */ - const int32_t start= sc->pc; - s7_d_7pi_t ifunc= s7_d_7pi_function ( - s_func); /* ifunc: float_vector_ref_d_7pi, s_func: - global_value(sc->float_vector_ref_symbol) */ - if (!ifunc) { - if ((is_eq_initial_c_function_data (sc->vector_ref_symbol, s_func)) && - (is_normal_symbol ( - cadr (expr)))) /* (vector-ref )? */ - { - const s7_pointer v_slot= s7_slot (sc, cadr (expr)); - if (is_slot (v_slot)) { - const s7_pointer vec= slot_value (v_slot); - if ((is_float_vector (vec)) || - ((is_typed_t_vector (vec)) && - (typed_vector_typer_symbol (sc, vec) == sc->is_float_symbol))) { - ifunc= float_vector_ref_d_7pi; - if (is_float_vector (vec)) - s_func= initial_value (sc->float_vector_ref_symbol); - } - } - } - if (!ifunc) return_false (sc, expr); - } - q_func (opc).d_7pi_f= ifunc; - if (is_symbol (cadr (expr))) /* (float-vector-ref v i) */ - { - s7_pointer arg2, arg2_slot, obj; - q_arg1 (opc).p= s7_slot (sc, cadr (expr)); - if (!is_slot (q_arg1 (opc).p)) return_false (sc, expr); - - obj= slot_value (q_arg1 (opc).p); - if ((is_target_or_its_alias (car (expr), s_func, - sc->float_vector_ref_symbol)) && - ((!is_float_vector (obj)) || /* if it's float-vector-ref, make sure obj - is a float-vector */ - (vector_rank (obj) > 1))) - return_false (sc, expr); /* but if it's e.g. (block-ref...), go on */ - - arg2= caddr (expr); - if (!is_pair (arg2)) { - if (is_t_integer (arg2)) { - q_arg2 (opc).i = integer (arg2); - q_call (opc).fd= opt_d_7pi_sc; - return_true (sc, expr); - } - arg2_slot= opt_integer_symbol (sc, arg2); - if (!arg2_slot) return_false (sc, expr); - q_arg2 (opc).p = arg2_slot; - q_call (opc).fd= opt_d_7pi_ss; - if (is_target_or_its_alias (car (expr), s_func, - sc->float_vector_ref_symbol)) { - q_call (opc).fd= (loop_end_fits (q_arg2 (opc).p, vector_length (obj))) - ? opt_d_7pi_ss_fvref_direct - : opt_d_7pi_ss_fvref; - if (q_call (opc).fd == opt_d_7pi_ss_fvref_direct) - q_func (opc).d_7pi_f= float_vector_ref_d_7pi_direct; - } - return_true (sc, expr); - } - if (int_optimize (sc, cddr (expr))) { - q_call (opc).fd = opt_d_7pi_sf; - q_func2_arg (opc).o1= sc->opts[start]; - q_func2 (opc).fi = q_func2_arg (opc).q_call (o1).fi; - return_true (sc, expr); - } - sc->pc= start; - return_false (sc, expr); - } +#define s_lookup(Sc, Sym, Expr) lookup(Sc, Sym) +#define g_lookup(Sc, Sym, Expr) lookup_global(Sc, Sym) - if ((is_target_or_its_alias (car (expr), s_func, - sc->float_vector_ref_symbol)) && - ((!is_float_vector (cadr (expr))) || - (vector_rank (cadr (expr)) > - 1))) /* (float-vector-ref #r2d((.1 .2) (.3 .4)) 3) */ - return_false (sc, expr); - - if (cell_optimize (sc, cdr (expr))) { - opt_info* o2= sc->opts[sc->pc]; - if (int_optimize (sc, cddr (expr))) { - q_call (opc).fd = opt_d_7pi_ff; - q_func1_arg (opc).o1= sc->opts[start]; - q_func1 (opc).fp = q_call (sc->opts[start]).fp; - q_func2_arg (opc).o1= o2; - q_func2 (opc).fi = q_call (o2).fi; - return_true (sc, expr); +/* 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));} +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_defined_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_V(s7_scheme *sc, s7_pointer arg) {return(V_lookup(sc, T_Sym(arg), arg));} +static s7_pointer fx_c_nc(s7_scheme *sc, s7_pointer arg) {return(fn_call(sc, arg));} +static s7_pointer fx_c_0c(s7_scheme *sc, s7_pointer arg) {return(fn_proc(arg)(sc, sc->nil));} +static s7_pointer fx_cons_cc(s7_scheme *sc, s7_pointer arg) {return(cons(sc, cadr(arg), opt1_con(cdr(arg))));} +static s7_pointer fx_curlet(s7_scheme *sc, s7_pointer arg) {return(s7_curlet(sc));} + +#define fx_c_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + return(fn_proc(arg)(sc, with_list_t1(sc, Lookup(sc, cadr(arg), arg)))); \ + } + +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) +fx_c_any(fx_c_V, V_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 = Lookup(sc, cadr(arg), arg); \ + return((is_pair(val)) ? car(val) : g_car(sc, set_plist_1(sc, val))); \ + } + /* using car_p_p(val) here is exactly the same in speed according to callgrind, also opt3_sym(arg) for cadr(arg) */ + +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) +fx_car_any(fx_car_T, T_lookup) +fx_car_any(fx_car_U, U_lookup) + + +#define fx_cdr_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer 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) +fx_cdr_any(fx_cdr_T, T_lookup) +fx_cdr_any(fx_cdr_U, U_lookup) + + +#define fx_cadr_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg)\ + { \ + s7_pointer 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 = 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) + + +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); + default: return(method_or_bust_pp(sc, val, sc->num_eq_symbol, val, cadr(args), a_number_string, 1)); } - } - sc->pc= start; - return_false (sc, expr); + return(sc->T); } -/* -------- d_ip -------- */ -static s7_double -opt_d_ip_ss (opt_info* o) { - return (q_func (o).d_ip_f (integer (slot_value (q_arg1 (o).p)), - slot_value (q_arg2 (o).p))); -} - -static bool -d_ip_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr) /* ina/inb clm2xen, ffitest, tgen etc */ -{ - const s7_d_ip_t pfunc= s7_d_ip_function (s_func); - if ((pfunc) && (is_symbol (caddr (expr)))) { - s7_pointer arg1_slot= opt_integer_symbol (sc, cadr (expr)); - if (arg1_slot) { - q_func (opc).d_ip_f= pfunc; - q_arg1 (opc).p = arg1_slot; - q_arg2 (opc).p = s7_t_slot (sc, caddr (expr)); - if (is_slot ( - q_arg2 (opc).p)) /* (with-sound (:reverb jc-reverb) (fm-violin 0 - .1 440 .4 :reverb-amount .5)) */ - { - q_call (opc).fd= opt_d_ip_ss; - return_true (sc, expr); - } - } - } - return_false (sc, expr); +static s7_pointer fx_num_eq_s0f(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer 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))); } -/* -------- d_pd -------- */ -static s7_double -opt_d_pd_sf (opt_info* o) { - return (q_func (o).d_pd_f (slot_value (q_arg1 (o).p), q_d_func2_call (o))); -} -static s7_double -opt_d_pd_ss (opt_info* o) { - return (q_func (o).d_pd_f (slot_value (q_arg1 (o).p), - real (slot_value (q_arg2 (o).p)))); -} - -static bool -d_pd_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr) /* none built-in, many in clm2xen but they're - almost never called */ -{ - if (is_symbol (cadr (expr))) { - const s7_d_pd_t func= s7_d_pd_function (s_func); - if (func) { - s7_pointer arg2_slot; - const s7_pointer arg2 = caddr (expr); - const int32_t start= sc->pc; - q_func (opc).d_pd_f = func; - q_arg1 (opc).p = s7_t_slot (sc, cadr (expr)); - if (!is_slot (q_arg1 (opc).p)) return_false (sc, expr); - arg2_slot= opt_float_symbol (sc, arg2); - if (arg2_slot) { - q_arg2 (opc).p = arg2_slot; - q_call (opc).fd= opt_d_pd_ss; - return_true (sc, expr); - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cddr (expr))) { - q_call (opc).fd = opt_d_pd_sf; - q_func2 (opc).fd= q_func2_arg (opc).q_call (o1).fd; - return_true (sc, expr); - } - sc->pc= start; - } - } - return_false (sc, expr); +#define fx_num_eq_si_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer args = cdr(arg); \ + s7_pointer val = Lookup(sc, car(args), arg); \ + s7_int 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))); \ } -/* -------- d_vd -------- */ - -static s7_double -opt_d_vd_c (opt_info* o) { - return (q_func (o).d_vd_f (q_arg1 (o).gen, q_arg2 (o).x)); -} -static s7_double -opt_d_vd_s (opt_info* o) { - return (q_func (o).d_vd_f (q_arg1 (o).gen, real (slot_value (q_arg2 (o).p)))); -} -static s7_double -opt_d_vd_f (opt_info* o) { - return (q_func (o).d_vd_f (q_arg1 (o).gen, q_d_func3_call (o))); -} -static s7_double -opt_d_vd_o (opt_info* o) { - return (q_func (o).d_vd_f (q_arg1 (o).gen, - q_func3 (o).d_v_f (q_func2_arg (o).gen))); -} -static s7_double -opt_d_vd_o1_mul (opt_info* o) { - return (q_func (o).d_vd_f (q_arg1 (o).gen, real (slot_value (q_arg2 (o).p)) * - q_d_func2_call (o))); -} -static s7_double -opt_d_vd_o3 (opt_info* o) { - return (q_func (o).d_vd_f ( - q_arg1 (o).gen, q_func3 (o).d_dd_f (q_func2_arg (o).x, - real (slot_value (q_arg2 (o).p))))); -} -static s7_double -opt_d_vd_ff (opt_info* o) { - return (q_func (o).d_vd_f ( - q_arg1 (o).gen, - q_func3 (o).d_vd_f (q_func3_arg (o).gen, q_d_func2_call (o)))); -} - -static s7_double -opt_d_vd_o1 (opt_info* o) { - return (q_func (o).d_vd_f ( - q_arg1 (o).gen, q_func3 (o).d_dd_f (real (slot_value (q_arg2 (o).p)), - q_d_func2_call (o)))); -} - -static s7_double -opt_d_vd_o2 (opt_info* o) { - return (q_func3 (o).d_vd_f ( - q_arg3 (o).gen, - q_func1 (o).d_vd_f (q_arg2 (o).gen, real (slot_value (q_arg4 (o).p))))); -} - -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 (q_call (o1).fd == opt_d_v) { - q_func2_arg (opc).gen= q_arg1 (o1).gen; - q_func3 (opc).d_v_f = q_func (o1).d_v_f; - q_call (opc).fd = opt_d_vd_o; - backup_pc (sc); - return_true (sc, NULL); - } - if (q_call (o1).fd == opt_d_vd_s) { - q_func3 (opc).d_vd_f= q_func (opc).d_vd_f; /* [4] <- opc[3] */ - q_arg3 (opc).gen = q_arg1 (opc).gen; /* [12] <- opc[5] */ - q_func1 (opc).d_vd_f= q_func (o1).d_vd_f; /* [5] <- o1[3] */ - q_arg2 (opc).gen = q_arg1 (o1).gen; /* [2] <- o1[5] */ - q_arg4 (opc).p = q_arg2 (o1).p; /* [13] <- o1[2] */ - q_call (opc).fd = opt_d_vd_o2; - backup_pc (sc); - return_true (sc, NULL); - } - if (q_call (o1).fd == opt_d_dd_cs) { - q_func3 (opc).d_dd_f= q_func (o1).d_dd_f; - q_func2_arg (opc).x = q_arg1 (o1).x; - /* fprintf(stderr, "arg1: %f, arg2: %s\n", q_arg1(o1).x, - * display(q_arg2(o1).p)); */ - q_arg2 (opc).p = T_Slt (q_arg2 (o1).p); - q_call (opc).fd= opt_d_vd_o3; - backup_pc (sc); - return_true (sc, NULL); - } - if ((q_call (o1).fd == opt_d_dd_sf_mul) || (q_call (o1).fd == opt_d_dd_sf) || - (q_call (o1).fd == opt_d_dd_sf_add)) { - q_arg2 (opc).p= q_arg1 (o1).p; - q_func3 (opc).d_dd_f= - q_func (o1).d_dd_f; /* unused in opt_d_vd_o1_mul (=> mul) */ - q_call (opc).fd= - (q_call (o1).fd == opt_d_dd_sf_mul) ? opt_d_vd_o1_mul : opt_d_vd_o1; - q_func2 (opc).fd = q_func1 (o1).fd; - q_func2_arg (opc).o1= q_func1_arg (o1).o1; - return_true (sc, NULL); - } - if (q_call (o1).fd == opt_d_vd_f) { - q_func3 (opc).d_vd_f = q_func (o1).d_vd_f; - q_func3_arg (opc).gen= q_arg1 (o1).gen; - q_call (opc).fd = opt_d_vd_ff; - q_func2 (opc).fd = q_func3 (o1).fd; - q_func2_arg (opc).o1 = q_func3_arg (o1).o1; - return_true (sc, NULL); - } - return_false (sc, NULL); -} +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) +fx_num_eq_si_any(fx_num_eq_oi, o_lookup) -static bool -d_vd_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr) { - s7_pointer sig; - s7_d_vd_t vfunc; - if (!is_symbol (cadr (expr))) return_false (sc, expr); - vfunc= s7_d_vd_function (s_func); - if (!vfunc) return_false (sc, expr); - sig= c_function_signature (s_func); - if ((is_pair (sig)) && (is_symbol (cadr (sig)))) { - s7_pointer slot= opt_types_match (sc, cadr (sig), cadr (expr)); - if (slot) { - const s7_pointer arg2 = caddr (expr); - const int32_t start= sc->pc; - q_func (opc).d_vd_f = vfunc; - if (!is_pair (arg2)) { - q_arg1 (opc).p = slot; - q_arg1 (opc).gen= (void*) c_object_value (slot_value (slot)); - if (is_small_real (arg2)) { - q_arg2 (opc).x = s7_number_to_real (sc, arg2); - q_call (opc).fd= opt_d_vd_c; - return_true (sc, expr); - } - q_arg2 (opc).p= s7_t_slot (sc, arg2); - if (is_slot (q_arg2 (opc).p)) { - if (is_t_real (slot_value (q_arg2 (opc).p))) { - q_call (opc).fd= opt_d_vd_s; - return_true (sc, expr); - } - if (!float_optimize (sc, cddr (expr))) return_false (sc, expr); - if (d_vd_f_combinable (sc, start)) return_true (sc, expr); - q_call (opc).fd = opt_d_vd_f; - q_func3_arg (opc).o1= sc->opts[start]; - q_func3 (opc).fd = q_call (sc->opts[start]).fd; - return_true (sc, expr); - } - } - else /* is pair arg2 */ - { - if (float_optimize (sc, cddr (expr))) { - q_arg1 (opc).gen= (void*) c_object_value (slot_value (slot)); - if (d_vd_f_combinable (sc, start)) return_true (sc, expr); - q_call (opc).fd = opt_d_vd_f; - q_func3_arg (opc).o1= sc->opts[start]; - q_func3 (opc).fd = q_call (sc->opts[start]).fd; - return_true (sc, expr); - } - sc->pc= start; - } - } +#define fx_num_eq_s0_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer 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)); \ } - return_false (sc, expr); -} -/* -------- d_id -------- */ -static s7_double -opt_d_id_ss (opt_info* o) { - return (q_func (o).d_id_f (integer (slot_value (q_arg1 (o).p)), - real (slot_value (q_arg2 (o).p)))); -} -static s7_double -opt_d_i2_mul (opt_info* o) { - s7_int p= integer (slot_value (q_arg1 (o).p)); - return (p * p); -} -static s7_double -opt_d_id_sf (opt_info* o) { - return (q_func (o).d_id_f (integer (slot_value (q_arg1 (o).p)), - q_d_func1_call (o))); -} -static s7_double -opt_d_id_sc (opt_info* o) { - return ( - q_func (o).d_id_f (integer (slot_value (q_arg1 (o).p)), q_arg2 (o).x)); -} -static s7_double -opt_d_id_cf (opt_info* o) { - return (q_func (o).d_id_f (q_arg1 (o).i, q_d_func1_call (o))); -} -static s7_double -opt_d_id_sfo1 (opt_info* o) { - return (q_func (o).d_id_f (integer (slot_value (q_arg1 (o).p)), - q_func1 (o).d_v_f (q_arg2 (o).gen))); -} - -static s7_double -opt_d_id_sfo (opt_info* o) { - return (q_func (o).d_id_f ( - integer (slot_value (q_arg1 (o).p)), - q_func1 (o).d_vd_f (q_arg3 (o).gen, real (slot_value (q_arg2 (o).p))))); -} - -static s7_double -opt_d_id_ff (opt_info* o) { - s7_int x1= q_i_func1_call (o); - return (q_func (o).d_id_f (x1, q_d_func2_call (o))); -} - -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 (q_call (o1).fd == opt_d_vd_s) { - q_arg3 (opc).gen = q_arg1 (o1).gen; - q_func1 (opc).d_vd_f= q_func (o1).d_vd_f; - q_arg2 (opc).p = q_arg2 (o1).p; - q_call (opc).fd = opt_d_id_sfo; /* not in s7test (see tgen) */ - backup_pc (sc); - return_true (sc, NULL); - } - if (q_call (o1).fd == opt_d_v) { - q_arg2 (opc).gen = q_arg1 (o1).gen; - q_func1 (opc).d_v_f= q_func (o1).d_v_f; - q_call (opc).fd = opt_d_id_sfo1; /* not in s7test (tgen) */ - backup_pc (sc); - return_true (sc, NULL); - } - } - return_false (sc, NULL); -} - -static bool -d_id_ok_1 (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr, bool expr_case) { - s7_pointer arg1_slot; - const int32_t start = sc->pc; - const s7_d_id_t flt_func= s7_d_id_function (s_func); - if (!flt_func) return_false (sc, expr); - q_func (opc).d_id_f= flt_func; - arg1_slot = opt_integer_symbol (sc, cadr (expr)); - if (arg1_slot) { - const s7_pointer arg2= caddr (expr); - s7_pointer arg2_slot; - q_arg1 (opc).p= arg1_slot; - if (is_t_real (arg2)) { - q_call (opc).fd= opt_d_id_sc; - q_arg2 (opc).x = real (arg2); - return_true (sc, expr); - } - if ((cadr (expr) == arg2) && - (flt_func == multiply_d_id)) /* cadr(expr)==arg2 if both are symbols */ - { /* (do... (set! sum 0.0) (do ((k 1 (+ k 1))) ((> k 10)) (set! sum (+ sum - (/ (* k k)))))) tnum */ - q_call (opc).fd= opt_d_i2_mul; - return_true (sc, expr); - } - arg2_slot= opt_float_symbol (sc, arg2); - if (arg2_slot) { - q_call (opc).fd= opt_d_id_ss; - q_arg2 (opc).p = arg2_slot; - return_true (sc, expr); - } - if (float_optimize (sc, cddr (expr))) { - if (d_id_sf_combinable (sc, opc)) return_true (sc, expr); - q_call (opc).fd = opt_d_id_sf; - q_func1_arg (opc).o1= sc->opts[start]; - q_func1 (opc).fd = q_call (sc->opts[start]).fd; - return_true (sc, expr); - } - sc->pc= start; - } - if (is_t_integer (cadr (expr))) { - if (float_optimize (sc, cddr (expr))) { - q_call (opc).fd = opt_d_id_cf; - q_arg1 (opc).i = integer (cadr (expr)); - q_func1_arg (opc).o1= sc->opts[start]; - q_func1 (opc).fd = q_call (sc->opts[start]).fd; - return_true (sc, expr); - } - sc->pc= start; - } - if (!expr_case) return_false (sc, expr); - q_func1_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cdr (expr))) { - q_func1 (opc).fi = q_func1_arg (opc).q_call (o1).fi; - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cddr (expr))) { - q_func2 (opc).fd= q_func2_arg (opc).q_call (o1).fd; - q_call (opc).fd = opt_d_id_ff; /* not in s7test? (once in tgsl! from - opt_d_7pid_sff_fvset (float-vector-set! v - 0 (jn (+ i 1) 1.0))) */ - return_true (sc, expr); - } - sc->pc= start; - } - return_false (sc, expr); -} +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 bool -d_id_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr) { - return (d_id_ok_1 (sc, opc, s_func, expr, true)); +static s7_pointer fx_num_eq_0s(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer val = lookup(sc, opt3_sym(arg)); /* opt3_sym: caddr(arg) -- this actually makes a measurable difference in callgrind! */ + return((is_t_integer(val)) ? make_boolean(sc, integer(val) == 0) : g_num_eq(sc, set_plist_2(sc, val, int_zero))); } -/* -------- d_dd -------- */ -static s7_double -opt_d_dd_cc (opt_info* o) { - return (q_func (o).d_dd_f (q_arg1 (o).x, q_arg2 (o).x)); -} -static s7_double -opt_d_dd_cs (opt_info* o) { - return (q_func (o).d_dd_f (q_arg1 (o).x, real (slot_value (q_arg2 (o).p)))); -} -static s7_double -opt_d_dd_sc (opt_info* o) { - return (q_func (o).d_dd_f (real (slot_value (q_arg1 (o).p)), q_arg2 (o).x)); -} -static s7_double -opt_d_dd_sc_sub (opt_info* o) { - return (real (slot_value (q_arg1 (o).p)) - q_arg2 (o).x); -} -static s7_double -opt_d_dd_ss (opt_info* o) { - return (q_func (o).d_dd_f (real (slot_value (q_arg1 (o).p)), - real (slot_value (q_arg2 (o).p)))); -} -static s7_double -opt_d_dd_ss_add (opt_info* o) { - return (real (slot_value (q_arg1 (o).p)) + real (slot_value (q_arg2 (o).p))); -} -static s7_double -opt_d_dd_ss_mul (opt_info* o) { - return (real (slot_value (q_arg1 (o).p)) * real (slot_value (q_arg2 (o).p))); +static s7_pointer fx_random_i(s7_scheme *sc, s7_pointer arg) +{ + return(make_integer(sc, (s7_int)(integer(cadr(arg)) * next_random(sc->default_random_state)))); } -static s7_double -opt_d_dd_cf (opt_info* o) { - return (q_func (o).d_dd_f (q_arg1 (o).x, q_d_func1_call (o))); -} -static s7_double -opt_d_dd_1f_subtract (opt_info* o) { - return (1.0 - q_d_func1_call (o)); -} -static s7_double -opt_d_dd_fc (opt_info* o) { - return (q_func (o).d_dd_f (q_d_func1_call (o), q_arg2 (o).x)); +static s7_pointer fx_random_i_wrapped(s7_scheme *sc, s7_pointer arg) +{ + return(wrap_integer(sc, (s7_int)(integer(cadr(arg)) * next_random(sc->default_random_state)))); } -static s7_double -opt_subtract_random_f_f (opt_info* o) { - return (q_arg1 (o).x * next_random (o->sc->default_random_state) - - q_arg2 (o).x); -} +static s7_pointer fx_add_i_random(s7_scheme *sc, s7_pointer arg) +{ + s7_int x = integer(cadr(arg)); + s7_int y = opt3_int(cdr(arg)); /* cadadr */ + return(make_integer(sc, x + (s7_int)(y * next_random(sc->default_random_state)))); /* (+ -1 (random 1)) -- placement of the (s7_int) cast matters! */ +} + +static s7_pointer fx_add_sf(s7_scheme *sc, s7_pointer arg) {return(g_add_xf(sc, lookup(sc, cadr(arg)), real(opt1_con(cdr(arg))), 1));} +s7_pointer fx_add_fs(s7_scheme *sc, s7_pointer arg) {return(g_add_xf(sc, lookup(sc, caddr(arg)), real(cadr(arg)), 2));} +static s7_pointer fx_add_tf(s7_scheme *sc, s7_pointer arg) {return(g_add_xf(sc, t_lookup(sc, cadr(arg), arg), real(opt1_con(cdr(arg))), 1));} +static s7_pointer fx_add_ft(s7_scheme *sc, s7_pointer arg) {return(g_add_xf(sc, t_lookup(sc, caddr(arg), arg), real(cadr(arg)), 2));} + + +#define fx_add_s1_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer x = Lookup(sc, cadr(arg), arg); \ + if ((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_v1, v_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) + + +#define fx_add_si_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + const s7_pointer x = Lookup(sc, cadr(arg), arg); \ + if ((is_t_integer(x))) \ + { \ + if (HAVE_OVERFLOW_CHECKS) \ + { \ + s7_int val = 0; \ + if (!add_overflow(integer(x), integer(opt1_con(cdr(arg))), &val)) \ + return(make_integer(sc, val)); \ + } \ + else return(make_integer(sc, integer(x) + integer(opt1_con(cdr(arg))))); \ + } \ + return(add_p_pp(sc, x, opt1_con(cdr(arg)))); /* caddr(arg) */ \ + } + +fx_add_si_any(fx_add_si, s_lookup) +fx_add_si_any(fx_add_ti, t_lookup) + +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, opt1_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, opt1_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, opt1_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, opt1_sym(cdr(arg)), arg)));} +static s7_pointer fx_add_uv(s7_scheme *sc, s7_pointer arg) {return(add_p_pp(sc, u_lookup(sc, cadr(arg), arg), v_lookup(sc, opt1_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, opt1_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, opt1_sym(cdr(arg)), arg)));} + +#define fx_subtract_s1_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer x = Lookup(sc, cadr(arg), arg); \ + if ((is_t_integer(x))) return(make_integer(sc, integer(x) - 1)); \ + return(minus_c1(sc, x)); \ + } +/* overflow check here slows tleft by about 35 out of ca 750, parallel add case does not check + * (define most-negative-fixnum (*s7* 'most-negative-fixnum)) + * (display (let ((f (lambda () (let ((S (- most-negative-fixnum 1))) S)))) (f))) (newline) + * -> 9223372036854775807 or (checked) -9223372036854776000.0 + */ -static s7_double -opt_d_dd_fc_add (opt_info* o) { - return (q_d_func1_call (o) + q_arg2 (o).x); -} -static s7_double -opt_d_dd_fc_fvref_add (opt_info* o) { - return (q_arg2 (o).x + float_vector (slot_value (q_arg3 (o).p), - integer (slot_value (q_arg4 (o).p)))); -} -static s7_double -opt_d_dd_fc_subtract (opt_info* o) { - return (q_d_func1_call (o) - q_arg2 (o).x); -} -static s7_double -opt_d_dd_sf (opt_info* o) { - return ( - q_func (o).d_dd_f (real (slot_value (q_arg1 (o).p)), q_d_func1_call (o))); -} -static s7_double -opt_d_dd_sf_mul (opt_info* o) { - return (real (slot_value (q_arg1 (o).p)) * q_d_func1_call (o)); -} -static s7_double -opt_d_dd_sf_add (opt_info* o) { - return (real (slot_value (q_arg1 (o).p)) + q_d_func1_call (o)); -} -static s7_double -opt_d_dd_sf_sub (opt_info* o) { - return (real (slot_value (q_arg1 (o).p)) - q_d_func1_call (o)); -} +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_v1, v_lookup) +fx_subtract_s1_any(fx_subtract_T1, T_lookup) +fx_subtract_s1_any(fx_subtract_U1, U_lookup) -static s7_double -opt_d_7dd_cc (opt_info* o) { - return (q_func (o).d_7dd_f (o->sc, q_arg1 (o).x, q_arg2 (o).x)); -} -static s7_double -opt_d_7dd_cs (opt_info* o) { - return (q_func (o).d_7dd_f (o->sc, q_arg1 (o).x, - real (slot_value (q_arg2 (o).p)))); -} -static s7_double -opt_d_7dd_sc (opt_info* o) { - return (q_func (o).d_7dd_f (o->sc, real (slot_value (q_arg1 (o).p)), - q_arg2 (o).x)); -} -static s7_double -opt_d_7dd_ss (opt_info* o) { - return (q_func (o).d_7dd_f (o->sc, real (slot_value (q_arg1 (o).p)), - real (slot_value (q_arg2 (o).p)))); -} -static s7_double -opt_d_7dd_cf (opt_info* o) { - return (q_func (o).d_7dd_f (o->sc, q_arg1 (o).x, q_d_func1_call (o))); -} -static s7_double -opt_d_7dd_fc (opt_info* o) { - return (q_func (o).d_7dd_f (o->sc, q_d_func1_call (o), q_arg2 (o).x)); -} -static s7_double -opt_d_7dd_sf (opt_info* o) { - return (q_func (o).d_7dd_f (o->sc, real (slot_value (q_arg1 (o).p)), - q_d_func1_call (o))); -} -/* arg3 is index slot from opt_d_7pii_scs, also below */ -static s7_double -opt_d_dd_sf_mul_fvref (opt_info* o) { - opt_info* o1= q_func1_arg (o).o1; - return (real (slot_value (q_arg1 (o).p)) * - float_vector_ref_d_7pii (o1->sc, slot_value (q_arg1 (o1).p), - q_arg2 (o1).i, - integer (slot_value (q_arg3 (o1).p)))); -} - -static s7_double -opt_d_dd_sfo (opt_info* o) { - return (q_func (o).d_dd_f ( - real (slot_value (q_arg1 (o).p)), - q_func1 (o).d_7pi_f (o->sc, slot_value (q_arg2 (o).p), - integer (slot_value (q_arg3 (o).p))))); -} - -static s7_double -opt_d_7dd_sfo (opt_info* o) { - return (q_func (o).d_7dd_f ( - o->sc, real (slot_value (q_arg1 (o).p)), - q_func1 (o).d_7pi_f (o->sc, slot_value (q_arg2 (o).p), - integer (slot_value (q_arg3 (o).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 ((q_call (o1).fd == opt_d_7pi_ss) || - (q_call (o1).fd == opt_d_7pi_ss_fvref) || - (q_call (o1).fd == opt_d_7pi_ss_fvref_direct)) { - if (func) { - q_func (opc).d_dd_f= q_func (opc).d_dd_f; /* need room for 3 symbols */ - q_call (opc).fd = opt_d_dd_sfo; - } - else { - q_func (opc).d_7dd_f= - q_func (opc).d_7dd_f; /* need room for 3 symbols */ - q_call (opc).fd= opt_d_7dd_sfo; - } - q_arg2 (opc).p = q_arg1 (o1).p; - q_arg3 (opc).p = q_arg2 (o1).p; - q_func1 (opc).d_7pi_f= q_func (o1).d_7pi_f; - backup_pc (sc); - return_true (sc, NULL); - } +#define fx_subtract_si_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + const s7_pointer x = Lookup(sc, cadr(arg), arg); \ + if ((is_t_integer(x))) \ + { \ + if (HAVE_OVERFLOW_CHECKS) \ + { \ + s7_int val = 0; \ + if (!subtract_overflow(integer(x), integer(opt1_con(cdr(arg))), &val)) \ + return(make_integer(sc, val)); \ + } \ + else return(make_integer(sc, integer(x) - integer(opt1_con(cdr(arg))))); \ + } \ + return(subtract_p_pp(sc, x, opt1_con(cdr(arg)))); /* caddr(arg) */ \ } - return_false (sc, NULL); -} - -static s7_double -opt_d_dd_fs (opt_info* o) { - return ( - q_func (o).d_dd_f (q_d_func1_call (o), real (slot_value (q_arg1 (o).p)))); -} -static s7_double -opt_d_dd_fs_mul (opt_info* o) { - return (q_d_func1_call (o) * real (slot_value (q_arg1 (o).p))); -} -static s7_double -opt_d_dd_fs_add (opt_info* o) { - return (q_d_func1_call (o) + real (slot_value (q_arg1 (o).p))); -} -static s7_double -opt_d_dd_fs_sub (opt_info* o) { - return (q_d_func1_call (o) - real (slot_value (q_arg1 (o).p))); -} -static s7_double -opt_d_7dd_fs (opt_info* o) { - return (q_func (o).d_7dd_f (o->sc, q_d_func1_call (o), - real (slot_value (q_arg1 (o).p)))); -} - -static s7_double -opt_d_dd_fs_add_fvref (opt_info* o) { - opt_info* o1= q_func1_arg (o).o1; - return (real (slot_value (q_arg1 (o).p)) + - float_vector_ref_d_7pii (o1->sc, slot_value (q_arg1 (o1).p), - q_arg2 (o1).i, - integer (slot_value (q_arg3 (o1).p)))); -} - -static s7_double -opt_d_dd_fso (opt_info* o) { - return (q_func (o).d_dd_f ( - q_func1 (o).d_7pi_f (o->sc, slot_value (q_arg2 (o).p), - integer (slot_value (q_arg3 (o).p))), - real (slot_value (q_arg1 (o).p)))); -} - -static s7_double -opt_d_7dd_fso (opt_info* o) { - return (q_func (o).d_7dd_f ( - o->sc, - q_func1 (o).d_7pi_f (o->sc, slot_value (q_arg2 (o).p), - integer (slot_value (q_arg3 (o).p))), - real (slot_value (q_arg1 (o).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 ((q_call (o1).fd == opt_d_7pi_ss) || - (q_call (o1).fd == opt_d_7pi_ss_fvref) || - (q_call (o1).fd == opt_d_7pi_ss_fvref_direct)) { - if (func) { - q_func (opc).d_dd_f= q_func (opc).d_dd_f; /* need room for 3 symbols */ - q_call (opc).fd = opt_d_dd_fso; - } - else { - q_func (opc).d_7dd_f= q_func (opc).d_7dd_f; - q_call (opc).fd = opt_d_7dd_fso; - } - q_arg2 (opc).p = q_arg1 (o1).p; - q_arg3 (opc).p = q_arg2 (o1).p; - q_func1 (opc).d_7pi_f= q_func (o1).d_7pi_f; - backup_pc (sc); - return_true (sc, NULL); - } + +fx_subtract_si_any(fx_subtract_si, s_lookup) +fx_subtract_si_any(fx_subtract_ti, t_lookup) +fx_subtract_si_any(fx_subtract_ui, u_lookup) + + +#define fx_subtract_sf_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer x = Lookup(sc, cadr(arg), arg); \ + if (is_t_real(x)) \ + return(make_real(sc, real(x) - real(opt1_con(cdr(arg))))); /* caddr(arg) */ \ + return(g_subtract_2f(sc, set_plist_2(sc, x, opt1_con(cdr(arg))))); /* caddr(arg) */ \ } - return_false (sc, NULL); -} -static s7_double -opt_d_dd_ff (opt_info* o) { - s7_double x1= q_d_func3_call (o); - return (q_func (o).d_dd_f (x1, q_d_func2_call (o))); -} +fx_subtract_sf_any(fx_subtract_sf, s_lookup) +fx_subtract_sf_any(fx_subtract_tf, t_lookup) -static s7_double -opt_d_dd_ff_mul (opt_info* o) { - s7_double x1= q_d_func3_call (o); - return (x1 * q_d_func2_call (o)); -} -static s7_double -opt_d_dd_ff_square (opt_info* o) { - s7_double x1= q_d_func3_call (o); - return (x1 * x1); -} +#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, opt1_sym(cdr(arg)), arg)));} -static s7_double -opt_d_dd_ff_add (opt_info* o) { - s7_double x1= q_d_func1_call (o); - return (x1 + q_d_func2_call (o)); -} +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_double -opt_d_dd_ff_add_mul (opt_info* o) { - s7_double x1= q_d_func1_call (o); - s7_double x2= q_d_func3_call (o); - return (x1 + (x2 * q_d_func2_call (o))); -} -static s7_double -opt_d_dd_ff_add_fv_ref (opt_info* o) { - s7_double x1= q_d_func1_call (o); - return (x1 + float_vector_ref_d_7pi (o->sc, slot_value (q_arg1 (o).p), - q_i_func3_call (o))); +static s7_pointer fx_subtract_fs(s7_scheme *sc, s7_pointer arg) +{ + const s7_double n = real(cadr(arg)); + const s7_pointer x = lookup(sc, caddr(arg)); + switch (type(x)) + { + case T_INTEGER: return(make_real(sc, n - integer(x))); + case T_RATIO: return(make_real(sc, n - (s7_double)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))); + default: + return(method_or_bust_pp(sc, x, sc->subtract_symbol, cadr(arg), x, a_number_string, 2)); + } + return(x); } -static s7_double -opt_d_dd_ff_sub (opt_info* o) { - s7_double x1= q_d_func1_call (o); - return (x1 - q_d_func2_call (o)); -} +#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) == opt1_con(cdr(arg)))); /* fx_choose checks that the second arg is not unspecified */ \ + } -static s7_double -opt_d_7dd_ff (opt_info* o) { - s7_double x1= q_d_func3_call (o); - return (q_func (o).d_7dd_f (o->sc, x1, q_d_func2_call (o))); -} +fx_is_eq_sc_any(fx_is_eq_sc, s_lookup) +fx_is_eq_sc_any(fx_is_eq_tc, t_lookup) +fx_is_eq_sc_any(fx_is_eq_uc, u_lookup) -static s7_double -opt_d_7dd_ff_add_div (opt_info* o) { - s7_double x1= opt_d_7pi_ss_fvref_direct (q_arg1 (o).o1); - s7_double x2= opt_d_7pi_ss_fvref_direct (q_arg2 (o).o1); - return (x1 + divide_d_7dd (o->sc, x2, opt_d_id_sf (q_arg3 (o).o1))); -} -static s7_double -opt_d_dd_ff_mul1 (opt_info* o) { - return (q_func3 (o).d_v_f (q_arg1 (o).gen) * q_d_func2_call (o)); -} +#define fx_is_eq_car_sq_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer a = cdr(arg); \ + s7_pointer 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)))); \ + } -static s7_double -opt_d_dd_ff_mul2 (opt_info* o) { - return (q_func3 (o).d_v_f (q_arg1 (o).gen) * - q_func1 (o).d_v_f (q_arg2 (o).gen)); -} +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_double -opt_d_dd_ff_mul4 (opt_info* o) { - return ( - q_func3 (o).d_v_f (q_arg1 (o).gen) * - q_func2 (o).d_vd_f (q_arg2 (o).gen, q_func1 (o).d_v_f (q_arg3 (o).gen))); + +static s7_pointer fx_is_eq_caar_sq(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer a = cdr(arg); + s7_pointer 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_double -opt_d_dd_ff_o1 (opt_info* o) { - s7_double x1= q_func3 (o).d_v_f (q_arg1 (o).gen); - return (q_func (o).d_dd_f (x1, q_d_func2_call (o))); +static s7_pointer fx_not_is_eq_car_sq(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer 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))))); } - -static s7_double -opt_d_dd_ff_o2 (opt_info* o) { - s7_double x1= q_func3 (o).d_v_f (q_arg1 (o).gen); - return (q_func (o).d_dd_f (x1, q_func1 (o).d_v_f (q_arg2 (o).gen))); -} - -static s7_double -opt_d_dd_ff_o3 (opt_info* o) { - s7_double x1= q_func3 (o).d_v_f (q_arg1 (o).gen); - return (q_func1 (o).d_dd_f ( - x1, - q_func2 (o).d_vd_f (q_arg2 (o).gen, real (slot_value (q_arg3 (o).p))))); -} - -static s7_double -opt_d_dd_ff_o4 (opt_info* o) { - s7_double x1= q_func3 (o).d_v_f (q_arg1 (o).gen); - return (q_func (o).d_dd_f ( - x1, - q_func2 (o).d_vd_f (q_arg2 (o).gen, q_func1 (o).d_v_f (q_arg3 (o).gen)))); -} - -static s7_double -opt_d_dd_fff (opt_info* o) { - s7_double x1= o->v[3 + 4].d_dd_f ( - o->v[3 + 5].d_7pi_f (o->sc, 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 */ - s7_double x2= o->v[8 + 4].d_dd_f ( - o->v[8 + 5].d_7pi_f (o->sc, 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 (q_func (o).d_dd_f (x1, x2)); -} - -static s7_double -opt_d_mm_fff (opt_info* o) { - s7_double x1= float_vector_ref_d_7pi (o->sc, slot_value (o->v[3 + 2].p), - integer (slot_value (o->v[3 + 3].p))) * - real (slot_value (o->v[3 + 1].p)); - s7_double x2= float_vector_ref_d_7pi (o->sc, slot_value (o->v[8 + 2].p), - integer (slot_value (o->v[8 + 3].p))) * - real (slot_value (o->v[8 + 1].p)); - return (q_func (o).d_dd_f (x1, x2)); -} - -static s7_double -opt_d_dd_fff_rev (opt_info* o) /* faster with o->sc? */ -{ - s7_double x1= o->v[3 + 4].d_dd_f ( - real (slot_value (o->v[3 + 1].p)), - o->v[3 + 5].d_7pi_f (o->sc, slot_value (o->v[3 + 2].p), - integer (slot_value (o->v[3 + 3].p)))); - s7_double x2= o->v[8 + 4].d_dd_f ( - real (slot_value (o->v[8 + 1].p)), - o->v[8 + 5].d_7pi_f (o->sc, slot_value (o->v[8 + 2].p), - integer (slot_value (o->v[8 + 3].p)))); - return (q_func (o).d_dd_f (x1, x2)); -} - -static s7_double -opt_d_dd_ff_mul_sss_unchecked (opt_info* o) { - opt_info* o1 = q_func3_arg (o).o1; - s7_pointer vec= slot_value (q_arg1 (o1).p); - s7_int i1 = integer (slot_value (q_arg2 (o1).p)); - s7_int i2 = integer (slot_value (q_arg3 (o1).p)); - s7_double x1 = float_vector (vec, (i1 * vector_offset (vec, 0)) + i2); - o1 = q_func2_arg (o).o1; - vec = slot_value (q_arg1 (o1).p); - i1 = integer (slot_value ( - q_arg2 (o1).p)); /* in (* (A i j) (B j k)) we could reuse - i2->i1 (flipping args below) */ - i2= integer (slot_value (q_arg3 (o1).p)); - return (x1 * float_vector (vec, (i1 * vector_offset (vec, 0)) + i2)); -} - -static bool -finish_dd_fso (opt_info* opc, opt_info* o1, opt_info* o2) { - opc->v[3 + 1].p = q_arg1 (o1).p; - opc->v[3 + 2].p = q_arg2 (o1).p; - opc->v[3 + 3].p = q_arg3 (o1).p; - opc->v[3 + 4].d_dd_f = q_func (o1).d_dd_f; - opc->v[3 + 5].d_7pi_f= q_func1 (o1).d_7pi_f; - opc->v[8 + 1].p = q_arg1 (o2).p; - opc->v[8 + 2].p = q_arg2 (o2).p; - opc->v[8 + 3].p = q_arg3 (o2).p; - opc->v[8 + 4].d_dd_f = q_func (o2).d_dd_f; - opc->v[8 + 5].d_7pi_f= q_func1 (o2).d_7pi_f; - return (true); -} - -static bool -d_dd_ff_combinable (s7_scheme* sc, opt_info* opc, int32_t start) { - opt_info *o1= q_func3_arg (opc).o1, *o2= q_func2_arg (opc).o1; - if (q_call (o1).fd == opt_d_v) { - /* q_func(opc) is in use */ - q_arg1 (opc).gen = q_arg1 (o1).gen; - q_func3 (opc).d_v_f= q_func (o1).d_v_f; - if ((q_call (o2).fd == opt_d_v) && (sc->pc == start + 2)) { - q_arg2 (opc).gen = q_arg1 (o2).gen; - q_func1 (opc).d_v_f= q_func (o2).d_v_f; - q_call (opc).fd= (q_func (opc).d_dd_f == multiply_d_dd) ? opt_d_dd_ff_mul2 - : opt_d_dd_ff_o2; - sc->pc-= 2; - return_true (sc, NULL); - } - if ((q_call (o2).fd == opt_d_vd_s) && (sc->pc == start + 2)) { - q_arg2 (opc).gen = q_arg1 (o2).gen; - q_func1 (opc).d_dd_f= q_func (opc).d_dd_f; - q_func2 (opc).d_vd_f= q_func (o2).d_vd_f; - q_arg3 (opc).p = q_arg2 (o2).p; - q_call (opc).fd = opt_d_dd_ff_o3; - sc->pc-= 2; - return_true (sc, NULL); - } - if ((q_call (o2).fd == opt_d_vd_o) && (sc->pc == start + 2)) { - q_func3 (opc).d_v_f = q_func (o1).d_v_f; - q_func2 (opc).d_vd_f= q_func (o2).d_vd_f; - q_func1 (opc).d_v_f = q_func3 (o2).d_v_f; - q_arg2 (opc).gen = q_arg1 (o2).gen; - q_arg3 (opc).gen = q_func2_arg (o2).gen; - q_call (opc).fd= (q_func (opc).d_dd_f == multiply_d_dd) ? opt_d_dd_ff_mul4 - : opt_d_dd_ff_o4; - sc->pc-= 2; - return_true (sc, NULL); - } - q_call (opc).fd= (q_func (opc).d_dd_f == multiply_d_dd) ? opt_d_dd_ff_mul1 - : opt_d_dd_ff_o1; - return_true (sc, NULL); - } - if (((q_call (o1).fd == opt_d_dd_fso) && (q_call (o2).fd == opt_d_dd_fso)) || - ((q_call (o1).fd == opt_d_dd_sfo) && (q_call (o2).fd == opt_d_dd_sfo))) { - if ((q_func (o1).d_dd_f == multiply_d_dd) && - (q_func (o2).d_dd_f == multiply_d_dd) && - ((q_func1 (o1).d_7pi_f == float_vector_ref_d_7pi) || - (q_func1 (o1).d_7pi_f == float_vector_ref_d_7pi_direct)) && - ((q_func1 (o2).d_7pi_f == float_vector_ref_d_7pi) || - (q_func1 (o2).d_7pi_f == float_vector_ref_d_7pi_direct))) - q_call (opc).fd= - opt_d_mm_fff; /* a placeholder (never called), see p_d_f_combinable */ - else - q_call (opc).fd= - (q_call (o1).fd == opt_d_dd_fso) ? opt_d_dd_fff : 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 (q_func (o).d_dd_f (q_arg1 (o).x, q_func1 (o).d_v_f (q_arg2 (o).gen))); -} -static s7_double -opt_d_7dd_cfo (opt_info* o) { - return (q_func (o).d_7dd_f (o->sc, q_arg1 (o).x, - q_func1 (o).d_v_f (q_arg2 (o).gen))); -} - -static s7_double -opt_d_dd_cfo1 (opt_info* o) { - return (q_func (o).d_dd_f ( - q_arg1 (o).x, - q_func1 (o).d_vd_f (q_arg3 (o).gen, real (slot_value (q_arg2 (o).p))))); -} -static s7_double -opt_d_7dd_cfo1 (opt_info* o) { - return (q_func (o).d_7dd_f ( - o->sc, q_arg1 (o).x, - q_func1 (o).d_vd_f (q_arg3 (o).gen, real (slot_value (q_arg2 (o).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 (q_call (o1).fd == opt_d_v) { - q_arg2 (opc).gen = q_arg1 (o1).gen; - q_func1 (opc).d_v_f= q_func (o1).d_v_f; - q_call (opc).fd = (func) ? opt_d_dd_cfo : opt_d_7dd_cfo; - backup_pc (sc); - return_true (sc, NULL); - } - if (q_call (o1).fd == opt_d_vd_s) { - q_arg3 (opc).gen = q_arg1 (o1).gen; - q_arg2 (opc).p = q_arg2 (o1).p; - q_func1 (opc).d_vd_f= q_func (o1).d_vd_f; - q_call (opc).fd = (func) ? opt_d_dd_cfo1 : opt_d_7dd_cfo1; - backup_pc (sc); - return_true (sc, NULL); - } + +#define fx_is_pair_car_s_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer p = Lookup(sc, opt3_sym(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))))); \ } - return_false (sc, NULL); -} - -static s7_double opt_d_7pii_scs (opt_info* o); -static s7_double opt_d_7pii_sss (opt_info* o); -static s7_double opt_d_7pii_sss_unchecked (opt_info* o); - -static bool -d_dd_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr) { - s7_pointer slot; - const s7_pointer arg1= cadr (expr), arg2= caddr (expr); - const int32_t start= sc->pc; - opt_info* o1; - s7_d_7dd_t func7= NULL; - s7_d_dd_t func = s7_d_dd_function (s_func); - if (!func) { - func7= s7_d_7dd_function (s_func); - if (!func7) return_false (sc, expr); + +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 = Lookup(sc, opt3_sym(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))))); \ } - if (func) q_func (opc).d_dd_f= func; - else q_func (opc).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, expr); - q_arg1 (opc).x = s7_number_to_real (sc, arg1); - q_arg2 (opc).x = s7_number_to_real (sc, arg2); - q_call (opc).fd= (func) ? opt_d_dd_cc : opt_d_7dd_cc; - return_true (sc, expr); - } - slot= opt_float_symbol (sc, arg2); - if (slot) { - q_arg1 (opc).x= s7_number_to_real (sc, arg1); - q_arg2 (opc).p= slot; - q_call (opc).fd= - (func) ? opt_d_dd_cs - : opt_d_7dd_cs; /* see opt_d_vd_o3 above which uses this */ - return_true (sc, expr); - } - if (float_optimize (sc, cddr (expr))) { - q_arg1 (opc).x= s7_number_to_real (sc, arg1); - if (d_dd_call_combinable (sc, opc, func)) return_true (sc, expr); - q_func1_arg (opc).o1= sc->opts[start]; - q_func1 (opc).fd = q_call (sc->opts[start]).fd; - q_call (opc).fd = (func) ? opt_d_dd_cf : opt_d_7dd_cf; - if ((q_arg1 (opc).x == 1.0) && (func == subtract_d_dd)) - q_call (opc).fd= opt_d_dd_1f_subtract; - return_true (sc, expr); - } - sc->pc= start; - return_false (sc, expr); +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 = Lookup(sc, opt3_sym(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))))); \ } - /* arg1 = float symbol */ - slot= opt_float_symbol (sc, arg1); - if (slot) { - q_arg1 (opc).p= slot; - if (is_small_real (arg2)) { - q_arg2 (opc).x= s7_number_to_real (sc, arg2); - if (func) - q_call (opc).fd= - (func == subtract_d_dd) ? opt_d_dd_sc_sub : opt_d_dd_sc; - else q_call (opc).fd= opt_d_7dd_sc; - return_true (sc, expr); - } - slot= opt_float_symbol (sc, arg2); - if (slot) { - q_arg2 (opc).p= slot; - if (func) { - if (func == multiply_d_dd) q_call (opc).fd= opt_d_dd_ss_mul; - else - q_call (opc).fd= (func == add_d_dd) ? opt_d_dd_ss_add : opt_d_dd_ss; - } - else q_call (opc).fd= opt_d_7dd_ss; - return_true (sc, expr); - } - if (float_optimize (sc, cddr (expr))) { - if (d_dd_sf_combinable (sc, opc, func)) return_true (sc, expr); - q_func1_arg (opc).o1= sc->opts[start]; - q_func1 (opc).fd = q_call (sc->opts[start]).fd; - if (func) { - q_call (opc).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) && (q_func1 (opc).fd == opt_d_7pii_scs)) - q_call (opc).fd= opt_d_dd_sf_mul_fvref; - } - else q_call (opc).fd= opt_d_7dd_sf; - return_true (sc, expr); - } - sc->pc= start; - return_false (sc, expr); +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 = Lookup(sc, opt3_sym(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))))); \ } - /* arg1 = float expr or non-float */ - /* first check for obvious d_id cases */ - if (((is_t_integer (arg1)) || (opt_integer_symbol (sc, arg1))) && - (s7_d_id_function (s_func))) - return (d_id_ok_1 (sc, opc, s_func, expr, false)); - - o1= sc->opts[sc->pc]; - if (float_optimize (sc, cdr (expr))) { - int32_t start2= sc->pc; - if (is_small_real (arg2)) { - q_arg2 (opc).x = s7_number_to_real (sc, arg2); - q_func1_arg (opc).o1= sc->opts[start]; - q_func1 (opc).fd = q_call (sc->opts[start]).fd; - if (func) { - if (func == add_d_dd) { - if (q_func1 (opc).fd == opt_d_7pi_ss_fvref_direct) { - q_call (opc).fd= opt_d_dd_fc_fvref_add; - q_arg3 (opc).p = q_func1_arg (opc).q_arg1 (o1).p; - q_arg4 (opc).p = q_func1_arg (opc).q_arg2 (o1).p; - } - else q_call (opc).fd= opt_d_dd_fc_add; - return_true (sc, expr); - } - if (func == subtract_d_dd) { - q_call (opc).fd= opt_d_dd_fc_subtract; - /* if q_call(o1).fd = opt_d_7d_c and its q_func(o).d_7d_f = - * random_d_7d it's (- (random f1) f2) */ - if ((opc == sc->opts[sc->pc - 2]) && - (q_call (sc->opts[start]).fd == opt_d_7d_c) && - (q_func (sc->opts[start]).d_7d_f == random_d_7d)) { - q_call (opc).fd= opt_subtract_random_f_f; - q_arg1 (opc).x = q_arg1 (sc->opts[start]).x; /* random arg */ - backup_pc (sc); - } - } - else q_call (opc).fd= opt_d_dd_fc; - } - else q_call (opc).fd= opt_d_7dd_fc; - return_true (sc, expr); - } - slot= opt_float_symbol (sc, arg2); - if (slot) { - q_arg1 (opc).p= slot; - if (d_dd_fs_combinable (sc, opc, func)) return_true (sc, expr); - q_func1_arg (opc).o1= sc->opts[start]; - q_func1 (opc).fd = q_call (sc->opts[start]).fd; - if (func) { - q_call (opc).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) && (q_func1 (opc).fd == opt_d_7pii_scs)) - q_call (opc).fd= opt_d_dd_fs_add_fvref; - } - else q_call (opc).fd= opt_d_7dd_fs; - return_true (sc, expr); - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cddr (expr))) { - opt_info* o2; - q_func3_arg (opc).o1= o1; - q_func3 (opc).fd = q_call (o1).fd; - q_func2 (opc).fd = q_func2_arg (opc).q_call (o1).fd; - if (func) { - if (d_dd_ff_combinable (sc, opc, start)) return_true (sc, expr); - q_call (opc).fd= opt_d_dd_ff; - if (func == multiply_d_dd) { - if (arg1 == arg2) q_call (opc).fd= opt_d_dd_ff_square; - else if ((q_func3 (opc).fd == opt_d_7pii_sss_unchecked) && - (q_func2 (opc).fd == opt_d_7pii_sss_unchecked) && - (q_func1 (o1).d_7pii_f == float_vector_ref_d_7pii)) - q_call (opc).fd= opt_d_dd_ff_mul_sss_unchecked; - else q_call (opc).fd= opt_d_dd_ff_mul; - return_true (sc, expr); - } - o2= sc->opts[start2]; /* this is q_func2_arg(opc).o1, v[10] */ - if (func == add_d_dd) { - if (q_call (o2).fd == opt_d_dd_ff_mul) { - q_call (opc).fd = opt_d_dd_ff_add_mul; - q_func1_arg (opc).o1= o1; /* add first arg */ - q_func1 (opc).fd = q_call (o1).fd; - q_func3_arg (opc).o1= q_func3_arg (o2).o1; /* mul first arg */ - q_func3 (opc).fd = q_func3 (o2).fd; - q_func2_arg (opc).o1= q_func2_arg (o2).o1; /* mul second arg */ - q_func2 (opc).fd = q_func2 (o2).fd; - return_true (sc, expr); - } - if ((q_call (o2).fd == opt_d_7pi_sf) && - ((q_func (o2).d_7pi_f == float_vector_ref_d_7pi) || - (q_func (o2).d_7pi_f == float_vector_ref_d_7pi_direct))) { - q_call (opc).fd= opt_d_dd_ff_add_fv_ref; - q_arg1 (opc).p = q_arg1 (o2).p; - q_func3_arg (opc).o1= - q_func2_arg (o2).o1; /* sc->opts[start2 + 1]; */ - q_func3 (opc).fi= - q_func2 (o2).fi; /* sc->opts[start2 + 1]-v[0].fi; */ - } - else { - q_call (opc).fd = opt_d_dd_ff_add; - q_func2_arg (opc).o1= o2; - q_func2 (opc).fd = q_call (o2).fd; - if ((q_call (o1).fd == opt_d_7pi_ss_fvref_direct) && - (q_func2 (opc).fd == opt_d_7dd_ff)) { - opt_info* ov= q_func2_arg (opc).o1; - if ((q_func (ov).d_7dd_f == divide_d_7dd) && - (q_func2 (ov).fd == opt_d_id_sf) && - (q_func3 (ov).fd == opt_d_7pi_ss_fvref_direct)) { - q_arg1 (opc).o1= o1; - q_arg3 (opc).o1= q_func2_arg (ov).o1; - q_arg2 (opc).o1= q_func3_arg (ov).o1; - q_call (opc).fd= opt_d_7dd_ff_add_div; - } - } - } - q_func1_arg (opc).o1= o1; /* sc->opts[start]; */ - q_func1 (opc).fd= q_call (o1).fd; /* q_call(sc->opts[start]).fd; */ - return_true (sc, expr); - } - if (func == subtract_d_dd) { - q_call (opc).fd = opt_d_dd_ff_sub; - q_func1_arg (opc).o1= o1; /* sc->opts[start]; */ - q_func1 (opc).fd= q_call (o1).fd; /* q_call(sc->opts[start]).fd; */ - q_func2_arg (opc).o1= o2; - q_func2 (opc).fd = q_call (o2).fd; - return_true (sc, expr); - } - } - else q_call (opc).fd= opt_d_7dd_ff; - return_true (sc, expr); - } - } - sc->pc= start; - return_false (sc, expr); -} +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) -/* -------- d_ddd -------- */ -static s7_double -opt_d_ddd_sss (opt_info* o) { - return (q_func (o).d_ddd_f (real (slot_value (q_arg1 (o).p)), - real (slot_value (q_arg2 (o).p)), - real (slot_value (q_arg3 (o).p)))); -} -static s7_double -opt_d_ddd_ssf (opt_info* o) { - return (q_func (o).d_ddd_f (real (slot_value (q_arg1 (o).p)), - real (slot_value (q_arg2 (o).p)), - q_d_func2_call (o))); -} - -static s7_double -opt_d_ddd_sff (opt_info* o) { - s7_double x1= q_d_func2_call (o); - s7_double x2= q_d_func3_call (o); - return (q_func (o).d_ddd_f (real (slot_value (q_arg1 (o).p)), x1, x2)); -} - -static s7_double -opt_d_ddd_fff (opt_info* o) { - s7_double x1= q_d_func2_call (o); - s7_double x2= q_d_func3_call (o); - s7_double x3= q_d_func1_call (o); - return (q_func (o).d_ddd_f (x1, x2, x3)); -} - -static s7_double -opt_d_ddd_fff1 (opt_info* o) { - s7_double x1= q_func1 (o).d_v_f (q_func1_arg (o).gen); - s7_double x2= q_func2 (o).d_v_f (q_func2_arg (o).gen); - s7_double x3= q_func3 (o).d_v_f (q_func3_arg (o).gen); - return (q_func (o).d_ddd_f (x1, x2, x3)); -} - -static s7_double -opt_d_ddd_fff2 (opt_info* o) { - s7_double x1= q_func2 (o).d_v_f (q_func2_arg (o).gen); - s7_double x2= q_d_func3_call (o); - s7_double x3= q_d_func1_call (o); - return (q_func (o).d_ddd_f (x1, x2, x3)); -} - -static s7_double -opt_d_ddd_fff_mul (opt_info* o) { - s7_double x1= opt_D_s (q_func2_arg (o).o1); - s7_double x2= opt_D_s (q_func3_arg (o).o1); - s7_double x3= opt_d_s (q_func1_arg (o).o1); - return (multiply_d_ddd (x1, x2, x3)); -} - -static bool -d_ddd_fff_combinable (s7_scheme* sc, opt_info* opc, int32_t start) { - opt_info* o1; - if (q_call (sc->opts[start]).fd != opt_d_v) return_false (sc, NULL); - o1 = sc->opts[start]; - q_func2 (opc).d_v_f = q_func (o1).d_v_f; - q_func2_arg (opc).gen= q_arg1 (o1).gen; - if ((q_call (sc->opts[start + 1]).fd == opt_d_v) && - (q_call (sc->opts[start + 2]).fd == opt_d_v)) { - opt_info* o2 = sc->opts[start + 2]; - o1 = sc->opts[start + 1]; - q_call (opc).fd = opt_d_ddd_fff1; - q_func1 (opc).d_v_f = q_func2 (opc).d_v_f; - q_func1_arg (opc).gen= q_func2_arg (opc).gen; - q_func2 (opc).d_v_f = q_func (o1).d_v_f; - q_func2_arg (opc).gen= q_arg1 (o1).gen; - q_func3 (opc).d_v_f = q_func (o2).d_v_f; - q_func3_arg (opc).gen= q_arg1 (o2).gen; - sc->pc-= 3; - return_true (sc, NULL); - } - q_call (opc).fd = opt_d_ddd_fff2; /* (* (d-v-func b) (d-v-func b) x) */ - q_func3 (opc).fd= q_func3_arg (opc).q_call (o1).fd; - q_func1 (opc).fd= q_func1_arg (opc).q_call (o1).fd; - return_true (sc, NULL); -} - -static bool -d_ddd_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr) { - const int32_t start= sc->pc; - s7_pointer arg1_slot; - const s7_pointer arg1= cadr (expr), arg2= caddr (expr); - const s7_d_ddd_t func= s7_d_ddd_function (s_func); - if (!func) return_false (sc, expr); - q_func (opc).d_ddd_f= func; - arg1_slot = opt_float_symbol (sc, arg1); - q_func2_arg (opc).o1= sc->opts[start]; - if (arg1_slot) { - s7_pointer arg2_slot; - q_arg1 (opc).p= arg1_slot; - arg2_slot = opt_float_symbol (sc, arg2); - if (arg2_slot) { - const s7_pointer arg3= cadddr (expr); - s7_pointer arg3_slot; - q_arg2 (opc).p= arg2_slot; - arg3_slot = opt_float_symbol (sc, arg3); - if (arg3_slot) { - q_arg3 (opc).p = arg3_slot; - q_call (opc).fd= opt_d_ddd_sss; - return_true (sc, expr); - } - if (float_optimize (sc, cdddr (expr))) { - q_func2 (opc).fd= q_func2_arg (opc).q_call (o1).fd; - q_call (opc).fd = opt_d_ddd_ssf; - return_true (sc, expr); - } - sc->pc= start; - } - if (float_optimize (sc, cddr (expr))) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cdddr (expr))) { - q_call (opc).fd = opt_d_ddd_sff; - q_func2 (opc).fd= q_func2_arg (opc).q_call (o1).fd; - q_func3 (opc).fd= q_func3_arg (opc).q_call (o1).fd; - return_true (sc, expr); - } - } - sc->pc= start; - } - if (float_optimize (sc, cdr (expr))) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cddr (expr))) { - q_func1_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cdddr (expr))) { - if (d_ddd_fff_combinable (sc, opc, start)) return_true (sc, expr); - q_call (opc).fd= opt_d_ddd_fff; /* tfft: (+ (* xout xin iw) (* yout yin - ih) (* zout zin id)) */ - q_func2 (opc).fd= q_func2_arg (opc).q_call (o1).fd; - q_func3 (opc).fd= q_func3_arg (opc).q_call (o1).fd; - q_func1 (opc).fd= q_func1_arg (opc).q_call (o1).fd; - if ((func == multiply_d_ddd) && (q_func2 (opc).fd == opt_D_s) && - (q_func3 (opc).fd == opt_D_s) && (q_func1 (opc).fd == opt_d_s)) - q_call (opc).fd= opt_d_ddd_fff_mul; - return_true (sc, expr); - } - } +#define fx_is_null_cdr_s_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer p = Lookup(sc, opt3_sym(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))))); \ } - sc->pc= start; - return_false (sc, expr); -} - -/* -------- d_7pid -------- */ -static s7_double -opt_d_7pid_ssf (opt_info* o) { - return (q_func (o).d_7pid_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - q_d_func2_call (o))); -} +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) -static s7_pointer -opt_d_7pid_ssf_nr (opt_info* o) { - q_func (o).d_7pid_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), q_d_func2_call (o)); - return (NULL); -} -static s7_double -opt_d_7pid_sss (opt_info* o) { - return (q_func (o).d_7pid_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - real (slot_value (q_arg3 (o).p)))); -} - -static s7_double -opt_d_7pid_ssc (opt_info* o) { - return (q_func (o).d_7pid_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - q_arg3 (o).x)); -} - -static s7_double -opt_d_7pid_sff (opt_info* o) { - s7_int pos= q_i_func2_call (o); - return (q_func (o).d_7pid_f (o->sc, slot_value (q_arg1 (o).p), pos, - q_d_func3_call (o))); -} - -static s7_double -opt_d_7pid_sff_fvset (opt_info* o) { - s7_int pos= q_i_func2_call (o); - return (float_vector_set_d_7pid (o->sc, slot_value (q_arg1 (o).p), pos, - q_d_func3_call (o))); -} - -static s7_double -opt_d_7pid_sso (opt_info* o) { - return (q_func (o).d_7pid_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - q_func1 (o).d_v_f (q_func1_arg (o).gen))); -} - -static s7_double -opt_d_7pid_ss_ss (opt_info* o) { - return (q_func (o).d_7pid_f ( - o->sc, slot_value (q_arg1 (o).p), integer (slot_value (q_arg2 (o).p)), - q_func1 (o).d_7pi_f (o->sc, slot_value (q_arg3 (o).p), - integer (slot_value (q_arg4 (o).p))))); -} - -static s7_double -opt_d_7pid_ssfo (opt_info* o) { - s7_pointer fv= slot_value (q_arg1 (o).p); - return (q_func (o).d_7pid_f ( - o->sc, fv, integer (slot_value (q_arg2 (o).p)), - q_func2 (o).d_dd_f ( - q_func1 (o).d_7pi_f (o->sc, fv, integer (slot_value (q_arg3 (o).p))), - real (slot_value (q_arg4 (o).p))))); -} - -static s7_double -opt_d_7pid_ssfo_fv (opt_info* o) { - s7_double* els= float_vector_floats (slot_value (q_arg1 (o).p)); - s7_double val= q_func2 (o).d_dd_f (els[integer (slot_value (q_arg3 (o).p))], - real (slot_value (q_arg4 (o).p))); - els[integer (slot_value (q_arg2 (o).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 (q_arg1 (o).p)); - els[integer (slot_value (q_arg2 (o).p))]= - q_func2 (o).d_dd_f (els[integer (slot_value (q_arg3 (o).p))], - real (slot_value (q_arg4 (o).p))); - return (NULL); -} - -static s7_pointer -opt_d_7pid_ssfo_fv_add_nr (opt_info* o) { - s7_double* els= float_vector_floats (slot_value (q_arg1 (o).p)); - els[integer (slot_value (q_arg2 (o).p))]= - els[integer (slot_value (q_arg3 (o).p))] + - real (slot_value (q_arg4 (o).p)); - return (NULL); -} - -static s7_pointer -opt_d_7pid_ssfo_fv_sub_nr (opt_info* o) { - s7_double* els= float_vector_floats (slot_value (q_arg1 (o).p)); - els[integer (slot_value (q_arg2 (o).p))]= - els[integer (slot_value (q_arg3 (o).p))] - - real (slot_value (q_arg4 (o).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 (q_call (o1).fd == opt_d_v) { - q_func1_arg (opc).gen= q_arg1 (o1).gen; - q_func1 (opc).d_v_f = q_func (o1).d_v_f; - q_call (opc).fd = opt_d_7pid_sso; - backup_pc (sc); - return_true (sc, NULL); - } - if ((q_call (o1).fd == opt_d_7pi_ss) || - (q_call (o1).fd == opt_d_7pi_ss_fvref) || - (q_call (o1).fd == opt_d_7pi_ss_fvref_direct)) { - q_func1 (opc).d_7pi_f= q_func (o1).d_7pi_f; - q_arg3 (opc).p = q_arg1 (o1).p; - q_arg4 (opc).p = q_arg2 (o1).p; - q_call (opc).fd = opt_d_7pid_ss_ss; - backup_pc (sc); - return_true (sc, NULL); - } - if ((q_call (o1).fd == opt_d_dd_fso) && (q_arg1 (opc).p == q_arg2 (o1).p)) { - q_func2 (opc).d_dd_f = q_func (o1).d_dd_f; - q_func1 (opc).d_7pi_f= q_func1 (o1).d_7pi_f; - q_arg3 (opc).p = q_arg3 (o1).p; - q_arg4 (opc).p = q_arg1 (o1).p; - q_call (opc).fd = opt_d_7pid_ssfo; - if (((q_func1 (opc).d_7pi_f == float_vector_ref_d_7pi) || - (q_func1 (opc).d_7pi_f == float_vector_ref_d_7pi_direct)) && - ((q_func (opc).d_7pid_f == float_vector_set_d_7pid_direct) || - (q_func (opc).d_7pid_f == float_vector_set_d_7pid))) - q_call (opc).fd= opt_d_7pid_ssfo_fv; /* actually if either is *_d, we - need to check the indices */ - backup_pc (sc); - return_true (sc, NULL); - } - } - 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, const s7_pointer s_func, - const s7_pointer expr) { - const s7_d_7pid_t func= s7_d_7pid_function (s_func); - if ((func) && (is_symbol (cadr (expr)))) { - const s7_pointer head = car (expr); - const int32_t start= sc->pc; - q_func (opc).d_7pid_f = func; - - if (is_target_or_its_alias (head, s_func, sc->float_vector_set_symbol)) - return (opt_float_vector_set (sc, opc, cadr (expr), cddr (expr), NULL, - NULL, cdddr (expr))); - - q_arg1 (opc).p= s7_slot (sc, cadr (expr)); - if (!is_slot (q_arg1 (opc).p)) return_false (sc, expr); - q_func2_arg (opc).o1= sc->opts[start]; - if (is_slot (q_arg1 (opc).p)) { - s7_pointer arg2_slot= opt_integer_symbol (sc, caddr (expr)); - if (arg2_slot) { - s7_pointer arg3_slot; - q_arg2 (opc).p= arg2_slot; - arg3_slot = opt_float_symbol (sc, cadddr (expr)); - if (arg3_slot) { - q_arg3 (opc).p = arg3_slot; - q_call (opc).fd= opt_d_7pid_sss; - return_true (sc, expr); - } - if (float_optimize (sc, cdddr (expr))) { - q_func2 (opc).fd= q_call (sc->opts[start]).fd; - if (d_7pid_ssf_combinable (sc, opc)) return_true (sc, expr); - q_call (opc).fd= opt_d_7pid_ssf; - return_true (sc, expr); - } - sc->pc= start; - } - if (int_optimize (sc, cddr (expr))) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cdddr (expr))) { - q_call (opc).fd = opt_d_7pid_sff; - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_func3 (opc).fd= q_func3_arg (opc).q_call (o1).fd; - return_true (sc, expr); - } - } - sc->pc= start; - } +#define fx_is_null_cadr_s_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer p = Lookup(sc, opt3_sym(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))))); \ } - return_false (sc, expr); -} -/* -------- 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) { - return (float_vector_ref_d_7pii (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - integer (slot_value (q_arg3 (o).p)))); -} - -static s7_double -opt_d_7pii_sss_unchecked (opt_info* o) { - s7_pointer vec= slot_value (q_arg1 (o).p); - return (float_vector ( - vec, ((integer (slot_value (q_arg2 (o).p)) * vector_offset (vec, 0)) + - integer (slot_value (q_arg3 (o).p))))); -} - -static s7_double -opt_d_7pii_scs (opt_info* o) { - return (float_vector_ref_d_7pii (o->sc, slot_value (q_arg1 (o).p), - q_arg2 (o).i, - integer (slot_value (q_arg3 (o).p)))); -} - -static s7_double -opt_d_7pii_sff (opt_info* o) { - return (float_vector_ref_d_7pii (o->sc, slot_value (q_arg1 (o).p), - q_i_func2_call (o), q_i_func3_call (o))); -} - -static bool -d_7pii_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr) { - const s7_d_7pii_t ifunc= s7_d_7pii_function (s_func); - if ((ifunc == float_vector_ref_d_7pii) && (is_symbol (cadr (expr)))) { - s7_pointer arg3_slot; - const int32_t start= sc->pc; - q_arg1 (opc).p = s7_slot (sc, cadr (expr)); - if ((!is_slot (q_arg1 (opc).p)) || - (!is_float_vector (slot_value (q_arg1 (opc).p))) || - (vector_rank (slot_value (q_arg1 (opc).p)) != 2)) - return_false (sc, expr); - - arg3_slot= opt_integer_symbol (sc, cadddr (expr)); - if (arg3_slot) { - s7_pointer arg2_slot; - q_arg3 (opc).p= arg3_slot; - arg2_slot = opt_integer_symbol (sc, caddr (expr)); - if (arg2_slot) { - q_arg2 (opc).p = arg2_slot; - q_call (opc).fd= opt_d_7pii_sss; - if ((loop_end_fits ( - q_arg2 (opc).p, - vector_dimension (slot_value (q_arg1 (opc).p), - 0))) && /* see also d_implicit_ok */ - (loop_end_fits (q_arg3 (opc).p, - vector_dimension (slot_value (q_arg1 (opc).p), 1)))) - q_call (opc).fd= opt_d_7pii_sss_unchecked; - return_true (sc, expr); - } - if (is_t_integer (caddr (expr))) { - q_arg2 (opc).i = integer (caddr (expr)); - q_call (opc).fd= opt_d_7pii_scs; - return_true (sc, expr); - } - } - q_func2_arg (opc).o1= sc->opts[start]; - if (int_optimize (sc, cddr (expr))) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cdddr (expr))) { - q_call (opc).fd = opt_d_7pii_sff; - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_func3 (opc).fi= q_func3_arg (opc).q_call (o1).fi; - return_true (sc, expr); - } - } - sc->pc= start; - } - return_false (sc, expr); -} +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) -/* -------- d_7piid -------- */ -/* currently only float_vector_set */ -static s7_double -opt_d_7piid_sssf (opt_info* o) { - return (float_vector_set_d_7piid ( - o->sc, slot_value (q_arg1 (o).p), integer (slot_value (q_arg2 (o).p)), - integer (slot_value (q_arg3 (o).p)), q_d_func3_call (o))); -} - -static s7_double -opt_d_7piid_sssc (opt_info* o) { - return (float_vector_set_d_7piid ( - o->sc, slot_value (q_arg1 (o).p), integer (slot_value (q_arg2 (o).p)), - integer (slot_value (q_arg3 (o).p)), q_arg4 (o).x)); -} - -static s7_double -opt_d_7piid_scsf (opt_info* o) { - return (float_vector_set_d_7piid ( - o->sc, slot_value (q_arg1 (o).p), q_arg2 (o).i, - integer (slot_value (q_arg3 (o).p)), q_d_func2_call (o))); -} - -static s7_double -opt_d_7piid_sfff (opt_info* o) { - s7_int i1 = q_i_func2_call (o); - s7_int i2 = q_i_func3_call (o); - s7_double val= q_d_func4_call (o); - return ( - float_vector_set_d_7piid (o->sc, slot_value (q_arg1 (o).p), i1, i2, val)); -} - -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 = integer (slot_value (q_arg2 (o).p)), - i2 = integer (slot_value (q_arg3 (o).p)); - s7_pointer vect= slot_value (q_arg1 (o).p); - s7_double val = q_d_func3_call (o); - float_vector (vect, (i1 * (vector_offset (vect, 0)) + i2))= val; - return (val); -} - -static bool -d_7piid_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr) { - const s7_d_7piid_t func= s7_d_7piid_function (s_func); - if ((func) && (is_symbol (cadr (expr)))) { - if (is_target_or_its_alias (car (expr), s_func, - sc->float_vector_set_symbol)) - return (opt_float_vector_set (sc, opc, cadr (expr), cddr (expr), - cdddr (expr), NULL, cddddr (expr))); +#define fx_is_null_cddr_s_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer p = Lookup(sc, opt3_sym(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))))); \ } - return_false (sc, expr); -} -/* -------- d_7piii -------- */ -static s7_double -opt_d_7piii_ssss (opt_info* o) { - return (float_vector_ref_d_7piii (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - integer (slot_value (q_arg3 (o).p)), - integer (slot_value (q_arg4 (o).p)))); -} - -static s7_double -opt_d_7piii_ssss_unchecked (opt_info* o) -/* not in s7test (tvect: ((do ((i 0...))) ((= i ...)) (do ((n 0 ...)) ((= n - ...)) (set! sum (+ sum (float-vector-ref v k i n)))))) */ -{ - s7_pointer vec= slot_value (q_arg1 (o).p); - s7_int i1 = integer (slot_value (q_arg2 (o).p)) * vector_offset (vec, 0); - s7_int i2 = integer (slot_value (q_arg3 (o).p)) * - vector_offset (vec, 1); /* offsets accumulate */ - return (float_vector (vec, (i1 + i2 + integer (slot_value (q_arg4 (o).p))))); -} - -static bool -d_7piii_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr) { - if ((s_func == global_value (sc->float_vector_ref_symbol)) && - (is_symbol (cadr (expr)))) { - s7_pointer arg4_slot; - q_arg1 (opc).p= s7_slot (sc, cadr (expr)); - if ((!is_slot (q_arg1 (opc).p)) || - (!is_float_vector (slot_value (q_arg1 (opc).p))) || - (vector_rank (slot_value (q_arg1 (opc).p)) != 3)) - return_false (sc, expr); - arg4_slot= opt_integer_symbol (sc, car (cddddr (expr))); - if (arg4_slot) { - s7_pointer arg3_slot; - q_arg4 (opc).p= arg4_slot; - arg3_slot = opt_integer_symbol (sc, cadddr (expr)); - if (arg3_slot) { - s7_pointer arg2_slot; - q_arg3 (opc).p= arg3_slot; - arg2_slot = opt_integer_symbol (sc, caddr (expr)); - if (arg2_slot) { - const s7_pointer vect= slot_value (q_arg1 (opc).p); - q_arg2 (opc).p = arg2_slot; - q_call (opc).fd = opt_d_7piii_ssss; - if ((loop_end_fits (q_arg2 (opc).p, vector_dimension (vect, 0))) && - (loop_end_fits (q_arg3 (opc).p, vector_dimension (vect, 1))) && - (loop_end_fits (q_arg4 (opc).p, vector_dimension (vect, 2)))) - q_call (opc).fd= opt_d_7piii_ssss_unchecked; - return_true (sc, expr); - } - } - } - } - return_false (sc, expr); -} +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) -/* -------- d_7piiid -------- */ -static s7_double -opt_d_7piiid_ssssf (opt_info* o) { - return (float_vector_set_d_7piiid ( - o->sc, slot_value (q_arg1 (o).p), integer (slot_value (q_arg2 (o).p)), - integer (slot_value (q_arg3 (o).p)), integer (slot_value (q_arg4 (o).p)), - q_d_func2_call (o))); -} - -static s7_double -opt_d_7piiid_ssssf_unchecked (opt_info* o) { - s7_pointer vect= slot_value (q_arg1 (o).p); - s7_int i1 = integer (slot_value (q_arg2 (o).p)) * vector_offset (vect, 0); - s7_int i2 = integer (slot_value (q_arg3 (o).p)) * vector_offset (vect, 1); - s7_int i3 = integer (slot_value (q_arg4 (o).p)); - s7_double val= q_d_func2_call (o); - float_vector (vect, (i1 + i2 + i3))= val; - return (val); -} - -static bool -d_7piiid_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr) { - if ((s_func == global_value (sc->float_vector_set_symbol)) && - (is_symbol (cadr (expr)))) { - if (is_target_or_its_alias (car (expr), s_func, - sc->float_vector_set_symbol)) - return (opt_float_vector_set (sc, opc, cadr (expr), cddr (expr), - cdddr (expr), cddddr (expr), - cdr (cddddr (expr)))); - } - return_false (sc, expr); -} - -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) { - const s7_pointer settee= s7_slot (sc, v); - if ((is_slot (settee)) && (!is_immutable (slot_value (settee)))) { - const s7_pointer vect = slot_value (settee); - const int32_t start= sc->pc; - q_arg1 (opc).p = settee; - if (!is_float_vector (vect)) return_false (sc, vect); - q_func2_arg (opc).o1= sc->opts[start]; - if ((!indexp2) && (vector_rank (vect) == 1)) { - s7_pointer ind1_slot; - q_func (opc).d_7pid_f= float_vector_set_d_7pid; - ind1_slot = opt_integer_symbol (sc, car (indexp1)); - if (ind1_slot) { - s7_pointer val_slot; - q_arg2 (opc).p= ind1_slot; - if (loop_end_fits (q_arg2 (opc).p, vector_length (vect))) - q_func (opc).d_7pid_f= float_vector_set_d_7pid_direct; - val_slot= opt_float_symbol (sc, car (valp)); - if (val_slot) { - q_arg3 (opc).p = val_slot; - q_call (opc).fd= opt_d_7pid_sss; - return_true (sc, NULL); - } - if (is_small_real (car (valp))) { - q_arg3 (opc).x = s7_real (car (valp)); - q_call (opc).fd= opt_d_7pid_ssc; - return_true (sc, NULL); - } - if (float_optimize (sc, valp)) { - q_func2 (opc).fd= q_call (sc->opts[start]).fd; - if (d_7pid_ssf_combinable (sc, opc)) return_true (sc, NULL); - q_call (opc).fd= opt_d_7pid_ssf; - return_true (sc, NULL); - } - sc->pc= start; - } - if (int_optimize (sc, indexp1)) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, valp)) { - q_call (opc).fd = (q_func (opc).d_7pid_f == float_vector_set_d_7pid) - ? opt_d_7pid_sff_fvset - : opt_d_7pid_sff; - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_func3 (opc).fd= q_func3_arg (opc).q_call (o1).fd; - return_true (sc, NULL); - } - } - return_false (sc, indexp1); - } - if ((indexp2) && (!indexp3) && (vector_rank (vect) == 2)) { - s7_pointer ind2_slot; - q_func1 (opc).d_7piid_f= float_vector_set_d_7piid; - /* could check for loop_end/end-ok here for both indices, but the d_7pii* - * functions currently assume fv_d_7piid perhaps set a different fd? so - * q_call(opc).fd = fvset_unchecked_d_7piid or whatever - */ - ind2_slot= opt_integer_symbol (sc, car (indexp2)); - if (ind2_slot) { - s7_pointer ind1_slot; - q_arg3 (opc).p= ind2_slot; - if (is_t_integer (car (indexp1))) { - if (!float_optimize (sc, valp)) return_false (sc, valp); - q_call (opc).fd = opt_d_7piid_scsf; - q_arg2 (opc).i = integer (car (indexp1)); - q_func2 (opc).fd= q_func2_arg (opc).q_call (o1).fd; - return_true (sc, NULL); - } - ind1_slot= opt_integer_symbol (sc, car (indexp1)); - if (ind1_slot) { - q_arg2 (opc).p= ind1_slot; - if (is_small_real (car (valp))) { - q_call (opc).fd= opt_d_7piid_sssc; - q_arg4 (opc).x = s7_real (car (valp)); - return_true (sc, NULL); - } - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, valp)) { - q_call (opc).fd = opt_d_7piid_sssf; - q_func3 (opc).fd= q_func3_arg (opc).q_call (o1).fd; - if ((loop_end_fits (q_arg2 (opc).p, vector_dimension (vect, 0))) && - (loop_end_fits (q_arg3 (opc).p, vector_dimension (vect, 1)))) - q_call (opc).fd= opt_d_7piid_sssf_unchecked; - return_true (sc, NULL); - } - sc->pc= start; - } - } - if (int_optimize (sc, indexp1)) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, indexp2)) { - q_func4_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, valp)) { - q_call (opc).fd = opt_d_7piid_sfff; - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_func3 (opc).fi= q_func3_arg (opc).q_call (o1).fi; - q_func4 (opc).fd= q_func4_arg (opc).q_call (o1).fd; - return_true (sc, NULL); - } - } - } - return_false (sc, indexp1); - } - if ((indexp3) && (vector_rank (vect) == 3)) { - s7_pointer ind3_slot; - ind3_slot= opt_integer_symbol (sc, car (indexp3)); - if (ind3_slot) { - s7_pointer ind2_slot; - q_arg4 (opc).p= ind3_slot; - ind2_slot = opt_integer_symbol (sc, car (indexp2)); - if (ind2_slot) { - s7_pointer ind1_slot; - q_arg3 (opc).p= ind2_slot; - ind1_slot = opt_integer_symbol (sc, car (indexp1)); - if (ind1_slot) { - q_arg2 (opc).p= ind1_slot; - if (float_optimize (sc, valp)) { - q_call (opc).fd = opt_d_7piiid_ssssf; - q_func2 (opc).fd= q_call (sc->opts[start]).fd; - if ((loop_end_fits (q_arg2 (opc).p, - vector_dimension (vect, 0))) && - (loop_end_fits (q_arg3 (opc).p, - vector_dimension (vect, 1))) && - (loop_end_fits (q_arg4 (opc).p, vector_dimension (vect, 2)))) - q_call (opc).fd= opt_d_7piiid_ssssf_unchecked; - return_true (sc, NULL); - } - } - } - } - } - } - return_false (sc, NULL); -} -/* -------- d_vid -------- */ -static s7_double -opt_d_vid_ssf (opt_info* o) { - return (q_func (o).d_vid_f ( - q_arg1 (o).gen, integer (slot_value (q_arg2 (o).p)), q_d_func2_call (o))); -} - -static inline s7_double -opt_fmv (opt_info* o) { - opt_info* o1 = q_arg3 (o).o1; /* opt_d_dd_ff_mul1 */ - opt_info* o2 = q_arg4 (o).o1; /* opt_d_vd_o1 */ - opt_info* o3 = q_arg5 (o).o1; /* opt_d_dd_ff_o3 */ - s7_double amp_env = q_func3 (o1).d_v_f (q_arg1 (o1).gen); - s7_double vib = real (slot_value (q_arg2 (o2).p)); - s7_double index_env= q_func3 (o3).d_v_f (q_arg1 (o3).gen); - return (q_func (o).d_vid_f ( - q_arg1 (o).gen, integer (slot_value (q_arg2 (o).p)), - amp_env * - q_func (o2).d_vd_f ( - q_arg1 (o2).gen, - vib + (index_env * q_func2 (o3).d_vd_f (q_arg2 (o3).gen, vib))))); -} - -static bool -d_vid_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr) { - if ((is_symbol (cadr (expr))) && (is_symbol (caddr (expr)))) { - s7_pointer sig; - const s7_d_vid_t flt= s7_d_vid_function (s_func); - if (!flt) return_false (sc, expr); - q_func (opc).d_vid_f= flt; - sig = c_function_signature (s_func); - if (is_pair (sig)) { - const int32_t start= sc->pc; - const s7_pointer vslot= opt_types_match (sc, cadr (sig), cadr (expr)); - if (vslot) { - s7_pointer arg2_slot; - q_call (opc).fd = opt_d_vid_ssf; - q_arg1 (opc).p = vslot; - q_func2_arg (opc).o1= sc->opts[start]; - arg2_slot = opt_integer_symbol (sc, caddr (expr)); - if ((arg2_slot) && (float_optimize (sc, cdddr (expr)))) { - opt_info* o2; - q_arg2 (opc).p = arg2_slot; - q_arg1 (opc).gen= (void*) c_object_value (slot_value (vslot)); - q_func2 (opc).fd= q_func2_arg (opc).q_call (o1).fd; - o2 = sc->opts[start]; - if (q_call (o2).fd == opt_d_dd_ff_mul1) { - opt_info* o3= sc->opts[start + 2]; - if (q_call (o3).fd == opt_d_vd_o1) { - opt_info* o1= sc->opts[start + 4]; - if ((q_call (o1).fd == opt_d_dd_ff_o3) && - (q_func1 (o1).d_dd_f == multiply_d_dd) && - (q_func3 (o3).d_dd_f == add_d_dd)) { - q_call (opc).fd= - opt_fmv; /* expr: (locsig locs i (* (env ampf) (oscil - carrier (+ vib (* (env indf1) (polywave fmosc1 - vib)))))) */ - q_arg3 (opc).o1= o2; /* opt_d_dd_ff_mul1 */ - q_arg4 (opc).o1= o3; /* opt_d_vd_o1 */ - q_arg5 (opc).o1= o1; /* opt_d_dd_ff_o3 */ - } - } - } - return_true (sc, expr); - } - } - sc->pc= start; - } +#define fx_is_symbol_cadr_s_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer p = Lookup(sc, opt3_sym(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))))); \ } - return_false (sc, expr); + +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 = t_lookup(sc, opt3_sym(arg), arg); + return(make_boolean(sc, (is_pair(val)) ? is_symbol(car(val)) : is_symbol(g_car(sc, set_plist_1(sc, val))))); } -/* -------- d_vdd -------- */ -static s7_double -opt_d_vdd_ff (opt_info* o) { - s7_double x1= q_d_func2_call (o); - s7_double x2= q_d_func3_call (o); - return (q_func (o).d_vdd_f (q_arg1 (o).gen, x1, x2)); -} - -static bool -d_vdd_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr) { - const s7_d_vdd_t flt= s7_d_vdd_function (s_func); - if (flt) { - const s7_pointer sig= c_function_signature (s_func); - q_func (opc).d_vdd_f= flt; - if (is_pair (sig)) { - const s7_pointer slot= opt_types_match (sc, cadr (sig), cadr (expr)); - if (slot) { - const int32_t start = sc->pc; - q_func2_arg (opc).o1= sc->opts[start]; - if (float_optimize (sc, cddr (expr))) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cdddr (expr))) { - q_func2 (opc).fd= q_func2_arg (opc).q_call (o1).fd; - q_func3 (opc).fd= q_func3_arg (opc).q_call (o1).fd; - q_arg1 (opc).gen= (void*) c_object_value (slot_value (slot)); - q_call (opc).fd = opt_d_vdd_ff; - return_true (sc, expr); - } - } - sc->pc= start; - } - } - } - return_false (sc, expr); +static s7_pointer fx_floor_sqrt_s(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer p = lookup(sc, opt3_sym(arg)); + if (!negative_b_7p(sc, p)) + return(make_integer(sc, (s7_int)floor(sqrt(s7_number_to_real_with_location(sc, p, sc->sqrt_symbol))))); + return(floor_p_p(sc, sqrt_p_p(sc, p))); } -/* -------- d_dddd -------- */ -static s7_double -opt_d_dddd_ffff (opt_info* o) { - s7_double x1= q_d_func1_call (o); - s7_double x2= q_d_func2_call (o); - s7_double x3= q_d_func3_call (o); - s7_double x4= q_d_func4_call (o); - return (q_func (o).d_dddd_f (x1, x2, x3, x4)); -} - -static bool -d_dddd_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr) { - const s7_d_dddd_t func= s7_d_dddd_function (s_func); - if (!func) return_false (sc, expr); - q_func1_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cdr (expr))) { - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cddr (expr))) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cdddr (expr))) { - q_func4_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cddddr (expr))) { - q_func (opc).d_dddd_f= func; - q_call (opc).fd = opt_d_dddd_ffff; - q_func1 (opc).fd = q_func1_arg (opc).q_call (o1).fd; - q_func2 (opc).fd = q_func2_arg (opc).q_call (o1).fd; - q_func3 (opc).fd = q_func3_arg (opc).q_call (o1).fd; - q_func4 (opc).fd = q_func4_arg (opc).q_call (o1).fd; - return_true (sc, expr); - } - } - } - } - return_false (sc, expr); +static s7_pointer fx_is_positive_u(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer num = u_lookup(sc, cadr(arg), arg); + if (is_t_integer(num)) return(make_boolean(sc, integer(num) > 0)); + return(make_boolean(sc, positive_b_7p(sc, num))); } -/* -------- d_add|multiply|subtract_any ------- */ -#define q_d_am_arg(o, i) o->v[i + 2] +static s7_pointer fx_is_zero_u(s7_scheme *sc, s7_pointer arg) {return(make_boolean(sc, zero_b_7p(sc, u_lookup(sc, cadr(arg), arg))));} -static s7_double -opt_d_add_any_f (opt_info* o) { - s7_double sum= 0.0; - for (s7_int i= 0; i < q_arg1 (o).i; i++) { - opt_info* o1= q_d_am_arg (o, i).o1; - sum+= q_call (o1).fd (o1); +#define fx_real_part_s_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer x = Lookup(sc, cadr(arg), arg); \ + return((is_t_complex(x)) ? make_real(sc, real_part(x)) : real_part_p_p(sc, x)); \ } - return (sum); -} -static s7_double -opt_d_multiply_any_f (opt_info* o) { - s7_double sum= 1.0; - for (s7_int i= 0; i < q_arg1 (o).i; i++) { - opt_info* o1= q_d_am_arg (o, i).o1; - sum*= q_call (o1).fd (o1); - } - return (sum); -} +fx_real_part_s_any(fx_real_part_s, s_lookup) +fx_real_part_s_any(fx_real_part_t, t_lookup) -static bool -d_add_any_ok (s7_scheme* sc, opt_info* opc, s7_pointer expr) { - const s7_pointer head = car (expr); - const 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 (expr); (is_pair (p)) && (cur_len < 12); - p= cdr (p), cur_len++) { - q_d_am_arg (opc, cur_len).o1= sc->opts[sc->pc]; - if (!float_optimize (sc, p)) break; - } - if (is_null (p)) { - q_arg1 (opc).i= cur_len; - q_call (opc).fd= - (head == sc->add_symbol) ? opt_d_add_any_f : opt_d_multiply_any_f; - return_true (sc, expr); - } +#define fx_imag_part_s_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer x = Lookup(sc, cadr(arg), arg); \ + return((is_t_complex(x)) ? make_real(sc, imag_part(x)) : imag_part_p_p(sc, x)); \ } - sc->pc= start; - return_false (sc, expr); -} -/* -------- d_syntax -------- */ -static s7_double -opt_set_d_d_f (opt_info* o) { - s7_double x= q_func (o).fd (q_arg2 (o).o1); - slot_set_value (q_arg1 (o).p, make_real (o->sc, x)); - return (x); -} - -static s7_double -opt_set_d_d_fm (opt_info* o) { - s7_double x= q_func (o).fd (q_arg2 (o).o1); - check_mutability (o->sc, o, __func__, __LINE__); - set_real (slot_value (q_arg1 (o).p), x); - return (x); -} - -static bool -d_syntax_ok (s7_scheme* sc, s7_pointer expr, int32_t len) { - if ((len == 3) && (car (expr) == sc->set_symbol)) { - const s7_pointer arg1= cadr (expr); - opt_info* opc = alloc_opt_info (sc); - if (is_symbol (arg1)) { - s7_pointer settee; - if (is_immutable (arg1)) return_false (sc, expr); - settee= s7_slot (sc, arg1); - if ((is_slot (settee)) && (is_t_real (slot_value (settee))) && - (!is_immutable_slot (settee)) && - ((!slot_has_setter (settee)) || - ((is_c_function (slot_setter (settee))) && - ((is_eq_initial_c_function_data (sc->is_float_symbol, - slot_setter (settee))) || - (c_function_call (slot_setter (settee)) == b_is_float_setter))))) { - opt_info* o1 = sc->opts[sc->pc]; - q_arg1 (opc).p= settee; - if ((!is_t_integer (caddr (expr))) && - (float_optimize ( - sc, cddr (expr)))) { /* tari: (set! rlo (min rlo (real-part (v - i)))) -- can't tell here that it is used - only in this line in the do body */ - /* PERHAPS: if tree_count(body) - tree_count(line) == 0 and no - * setters within line it's safe as mutable? use the two_sets bit as - * before? */ - /* but we also need a list of such opt_info ptrs to cancel - * mutability at the end */ - /* tall: (set! la ca)! (How?) - * (set! temp1 (one-zero dryTap0 (one-pole dryTap1 (piano-noise - * pnoise amp)))) and many more, but none will be self-contained I - * think - */ - q_call (opc).fd= (is_mutable_number (slot_value (q_arg1 (opc).p))) - ? opt_set_d_d_fm - : opt_set_d_d_f; - q_arg2 (opc).o1= o1; - q_func (opc).fd= q_call (o1).fd; - return_true (sc, expr); - } - } - } - else /* if is_pair(settee) get setter */ - if ((is_pair (arg1)) && (is_symbol (car (arg1))) && - (is_pair (cdr (arg1)))) { - if (is_null (cddr (arg1))) - return (opt_float_vector_set (sc, opc, car (arg1), cdr (arg1), NULL, - NULL, cddr (expr))); - if (is_null (cdddr (arg1))) - return (opt_float_vector_set (sc, opc, car (arg1), cdr (arg1), - cddr (arg1), NULL, cddr (expr))); - } - } - return_false (sc, expr); -} +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 */ -static bool -d_implicit_ok (s7_scheme* sc, s7_pointer s_slot, s7_pointer expr, int32_t len) { - const s7_pointer obj= slot_value (s_slot); - if (is_float_vector (obj)) { - /* implicit float-vector-ref */ - if ((len == 2) && (vector_rank (obj) == 1)) { - s7_pointer arg1_slot; - opt_info* opc = alloc_opt_info (sc); - q_arg1 (opc).p = s_slot; - q_func (opc).d_7pi_f= float_vector_ref_d_7pi; - arg1_slot = opt_integer_symbol (sc, cadr (expr)); - if (arg1_slot) { - q_arg2 (opc).p= arg1_slot; - if (loop_end_fits (q_arg2 (opc).p, vector_length (obj))) - q_call (opc).fd= opt_d_7pi_ss_fvref_direct; - else q_call (opc).fd= opt_d_7pi_ss_fvref; - return_true (sc, expr); - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (!int_optimize (sc, cdr (expr))) return_false (sc, expr); - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_call (opc).fd = opt_d_7pi_sf; - return_true (sc, expr); - } - if ((len == 3) && (vector_rank (obj) == 2)) { - s7_pointer arg1_slot; - opt_info* opc= alloc_opt_info (sc); - q_arg1 (opc).p= s_slot; - q_func1 (opc).d_7pii_f= - float_vector_ref_d_7pii; /* not used in opt_d_7pii_sss_unchecked or - opt_d_7pii_sff, but d_dd_ok checks it */ - arg1_slot= opt_integer_symbol (sc, cadr (expr)); - if (arg1_slot) { - s7_pointer arg2_slot; - q_arg2 (opc).p= arg1_slot; - arg2_slot = opt_integer_symbol (sc, caddr (expr)); - if (arg2_slot) { - q_arg3 (opc).p = arg2_slot; - q_call (opc).fd= opt_d_7pii_sss; - if ((loop_end_fits (q_arg2 (opc).p, vector_dimension (obj, 0))) && - (loop_end_fits (q_arg3 (opc).p, vector_dimension (obj, 1)))) - q_call (opc).fd= opt_d_7pii_sss_unchecked; - return_true (sc, expr); - } - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cdr (expr))) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cddr (expr))) { - q_call (opc).fd = opt_d_7pii_sff; - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_func3 (opc).fi= q_func3_arg (opc).q_call (o1).fi; - return_true (sc, expr); - } - } - } - if ((len == 4) && (vector_rank (obj) == 3)) { - s7_pointer arg1_slot; - opt_info* opc= alloc_opt_info (sc); - q_arg1 (opc).p= s_slot; - arg1_slot = opt_integer_symbol (sc, cadr (expr)); - if (arg1_slot) { - s7_pointer arg2_slot; - q_arg2 (opc).p= arg1_slot; - arg2_slot = opt_integer_symbol (sc, caddr (expr)); - if (arg2_slot) { - s7_pointer arg3_slot; - q_arg3 (opc).p= arg2_slot; - arg3_slot = opt_integer_symbol (sc, cadddr (expr)); - if (arg3_slot) { - q_arg4 (opc).p = arg3_slot; - q_call (opc).fd= opt_d_7piii_ssss; - if ((loop_end_fits (q_arg2 (opc).p, vector_dimension (obj, 0))) && - (loop_end_fits (q_arg3 (opc).p, vector_dimension (obj, 1))) && - (loop_end_fits (q_arg4 (opc).p, vector_dimension (obj, 2)))) - q_call (opc).fd= opt_d_7piii_ssss_unchecked; - return_true (sc, expr); - } - } - } - } - } - if ((is_c_object (obj)) && (len == 2)) { - const s7_pointer getf= c_object_getf (sc, obj); - if (is_c_function (getf)) /* default is #f */ - { - const s7_d_7pi_t func= s7_d_7pi_function (getf); - if (func) { - s7_pointer arg1_slot; - opt_info* opc= alloc_opt_info (sc); - q_arg1 (opc).p= s_slot; - /* opc-v[4].gen = (void *)c_object_value(obj); */ - q_func (opc).d_7pi_f= func; - arg1_slot = opt_integer_symbol (sc, cadr (expr)); - if (arg1_slot) { - q_call (opc).fd= opt_d_7pi_ss; - q_arg2 (opc).p = arg1_slot; - return_true (sc, expr); - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cdr (expr))) { - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_call (opc).fd = opt_d_7pi_sf; - return_true (sc, expr); - } - } - } +#define fx_iterate_s_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer iter = Lookup(sc, cadr(arg), arg); \ + if (is_iterator(iter)) \ + return((iterator_next(iter))(sc, iter)); \ + return(method_or_bust_p(sc, iter, sc->iterate_symbol, sc->type_names[T_ITERATOR])); \ } - return_false (sc, expr); -} -/* -------------------------------- bool opts -------------------------------- - */ +fx_iterate_s_any(fx_iterate_s, s_lookup) +fx_iterate_s_any(fx_iterate_o, o_lookup) +fx_iterate_s_any(fx_iterate_T, T_lookup) -static bool -opt_b_s (opt_info* o) { - return (slot_value (q_arg1 (o).p) != o->sc->F); +static s7_pointer fx_read_char_0(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer port = input_port_if_not_loading(sc); + if (!port) return(eof_object); + if (!is_input_port(port)) + return(method_or_bust_p(sc, port, sc->read_char_symbol, an_input_port_string)); + return(chars[port_read_character(port)(sc, port)]); } -static bool -opt_bool_not_pair (s7_scheme* sc, s7_pointer expr) { - s7_pointer slot; - if (!is_symbol (expr)) return_false (sc, expr); /* i.e. use cell_optimize */ - slot= opt_simple_symbol (sc, expr); - if ((slot) && (is_boolean (slot_value (slot)))) { - opt_info* opc = alloc_opt_info (sc); - q_arg1 (opc).p = slot; - q_call (opc).fb= opt_b_s; - return_true (sc, expr); - } - return_false (sc, expr); -} +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)));} -/* -------- b_idp -------- */ -static bool -opt_b_i_s (opt_info* o) { - return (q_func (o).b_i_f (integer (slot_value (q_arg1 (o).p)))); -} -static bool -opt_b_i_f (opt_info* o) { - return (q_func (o).b_i_f (q_i_func1_call (o))); -} -static bool -opt_b_d_s (opt_info* o) { - return (q_func (o).b_d_f (s7_real (slot_value (q_arg1 (o).p)))); -} /* not s7test tmap */ -static bool -opt_b_d_f (opt_info* o) { - return (q_func (o).b_d_f (q_d_func1_call (o))); -} -static bool -opt_b_p_s (opt_info* o) { - return (q_func (o).b_p_f (slot_value (q_arg1 (o).p))); -} -static bool -opt_b_p_f (opt_info* o) { - return (q_func (o).b_p_f (q_p_func1_call (o))); -} /* used in opt_if_nbp_s */ -static bool -opt_b_7p_s (opt_info* o) { - return (q_func (o).b_7p_f (o->sc, slot_value (q_arg1 (o).p))); -} -static bool -opt_b_7p_s_not (opt_info* o) { - return (slot_value (q_arg1 (o).p) == o->sc->F); -} /* not s7test *shoot */ -static bool -opt_b_7p_f (opt_info* o) { - return (q_func (o).b_7p_f (o->sc, q_p_func1_call (o))); -} -static bool -opt_b_d_s_is_positive (opt_info* o) { - return (real (slot_value (q_arg1 (o).p)) > 0.0); -} -static bool -opt_b_p_s_is_integer (opt_info* o) { - return (s7_is_integer (slot_value (q_arg1 (o).p))); -} /* not s7test tmap */ -static bool -opt_b_p_s_is_pair (opt_info* o) { - return (is_pair (slot_value (q_arg1 (o).p))); -} -static bool -opt_b_p_f_is_string (opt_info* o) { - return (s7_is_string (q_p_func1_call (o))); -} -static bool -opt_b_7p_s_iter_at_end (opt_info* o) { - return (iterator_is_at_end (slot_value (q_arg1 (o).p))); -} -static bool -opt_b_7p_f_not (opt_info* o) { - return ((q_p_func1_call (o)) == o->sc->F); -} - -static bool -opt_zero_mod (opt_info* o) { - s7_int x= integer (slot_value (q_arg1 (o).p)); - return ((x % q_arg2 (o).i) == 0); -} - -static bool -just_ints (s7_scheme* sc, s7_pointer form) { - if (is_pair (form)) - return ((just_ints (sc, car (form))) && (just_ints (sc, cdr (form)))); - return ((!is_number (form)) || (is_t_integer (form))); -} - -static bool -just_floats (s7_scheme* sc, s7_pointer form) { - if (is_pair (form)) - return ((just_floats (sc, car (form))) && (just_floats (sc, cdr (form)))); - return ((!is_number (form)) || (is_t_real (form))); -} - -static bool -b_idp_ok (s7_scheme* sc, const s7_pointer s_func, const s7_pointer form, - const s7_pointer arg_type) { - opt_info* opc = alloc_opt_info (sc); - const int32_t cur_index= sc->pc; - s7_pointer expr = car (form); - - if (((arg_type == sc->is_integer_symbol) || - (arg_type == sc->is_byte_symbol)) && - (just_ints (sc, form))) { - const s7_b_i_t bif= s7_b_i_function (s_func); - if (bif) { - q_func (opc).b_i_f= bif; - if (is_symbol (cadr (expr))) { - q_arg1 (opc).p = s7_t_slot (sc, cadr (expr)); - q_call (opc).fb= opt_b_i_s; - return_true (sc, expr); - } - q_func1_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cdr (expr))) { - opt_info* o1= sc->opts[sc->pc - 1]; - if ((car (expr) == sc->is_zero_symbol) && - (q_call (o1).fi == opt_i_ii_sc) && - (q_func (o1).i_ii_f == modulo_i_ii_unchecked)) { - q_call (opc).fb= opt_zero_mod; - q_arg1 (opc).p = q_arg1 (o1).p; - q_arg2 (opc).i = q_arg2 (o1).i; - backup_pc (sc); - return_true (sc, expr); - } - q_call (opc).fb = opt_b_i_f; - q_func1 (opc).fi= q_func1_arg (opc).q_call (o1).fi; - return_true (sc, expr); - } - } - } - else if ((arg_type == sc->is_float_symbol) && (just_floats (sc, form))) { - const s7_b_d_t bdf= s7_b_d_function (s_func); - if (bdf) { - q_func (opc).b_d_f= bdf; - if (is_symbol (cadr (expr))) { - q_arg1 (opc).p= s7_t_slot (sc, cadr (expr)); - q_call (opc).fb= - (bdf == positive_d) ? opt_b_d_s_is_positive : opt_b_d_s; - return_true (sc, expr); - } - q_func1_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cdr (expr))) { - q_call (opc).fb = opt_b_d_f; - q_func1 (opc).fd= q_func1_arg (opc).q_call (o1).fd; - return_true (sc, expr); - } - } - } - sc->pc= cur_index; - { - s7_b_p_t bpf = s7_b_p_function (s_func); - s7_b_7p_t bpf7= NULL; - if (!bpf) bpf7= s7_b_7p_function (s_func); - if ((bpf) || (bpf7)) { - if (bpf) q_func (opc).b_p_f= bpf; - else q_func (opc).b_7p_f= bpf7; - if (is_symbol (cadr (expr))) { - const s7_pointer slot= opt_simple_symbol (sc, cadr (expr)); - if (!slot) return_false (sc, expr); - q_arg1 (opc).p= slot; - q_call (opc).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 (slot)))) - ? opt_b_7p_s_iter_at_end - : ((bpf7 == not_b_7p) ? opt_b_7p_s_not : opt_b_7p_s)); - return_true (sc, expr); - } - q_func1_arg (opc).o1= sc->opts[sc->pc]; - if (cell_optimize (sc, cdr (expr))) { - q_call (opc).fb= - (bpf) ? ((bpf == s7_is_string) ? opt_b_p_f_is_string : opt_b_p_f) - : (bpf7 == not_b_7p) ? opt_b_7p_f_not - : opt_b_7p_f; - q_func1 (opc).fp= q_func1_arg (opc).q_call (o1).fp; - return_true (sc, expr); - } - } - } - return_false (sc, expr); -} +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 */ + const s7_int ilen = integer(opt3_con(arg)); /* is_t_integer checked in fx_choose */ + const s7_pointer val = lookup(sc, opt3_sym(cdr(arg))); -/* -------- b_pp -------- */ -static s7_pointer -opt_arg_type (s7_scheme* sc, s7_pointer argp) { - const s7_pointer arg= car (argp); - if (is_pair (arg)) { - if (is_symbol (car (arg))) { - if ((is_slot (global_slot (car (arg)))) && - ((is_global (car (arg))) || - (s7_t_slot (sc, car (arg)) == global_slot (car (arg))))) { - const s7_pointer a_func= global_value (car (arg)); - if (is_c_function (a_func)) { - const 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))))) /* multidim vector for example with - too few indices */ - 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_complex_symbol) || - ((is_pair (car (sig))) && - (direct_memq (sc->is_complex_symbol, car (sig))))) - return (sc->is_complex_symbol); - if ((car (sig) == sc->is_byte_symbol) || - ((is_pair (car (sig))) && - (direct_memq (sc->is_byte_symbol, car (sig))))) - return (sc->is_integer_symbol); /* or '(integer? byte)? */ - if ((car (sig) == sc->is_real_symbol) || - (car (sig) == sc->is_number_symbol)) { - const int32_t start= sc->pc; - if (int_optimize (sc, argp)) { - sc->pc= start; - return (sc->is_integer_symbol); - } - if (float_optimize (sc, argp)) { - sc->pc= start; - return (sc->is_float_symbol); - } - sc->pc= start; - } - if (((car (arg) == sc->vector_ref_symbol) || - (car (arg) == sc->hash_table_ref_symbol)) && - (is_pair (cdr (arg))) && - (is_normal_symbol ( - cadr (arg)))) /* (vector-ref) -> is_pair check */ - { - const s7_pointer v_slot= s7_slot ( - sc, cadr (arg)); /* (vector-ref not-a-var ...) -> is_slot - check, not # */ - if (is_slot (v_slot)) { - const s7_pointer vec= slot_value (v_slot); - if (car (arg) == sc->vector_ref_symbol) { - if (is_int_vector (vec)) return (sc->is_integer_symbol); - if (is_float_vector (vec)) return (sc->is_float_symbol); - if (is_complex_vector (vec)) return (sc->is_complex_symbol); - if (is_byte_vector (vec)) return (sc->is_byte_symbol); - if (is_typed_t_vector (vec)) - return (typed_vector_typer_symbol ( - sc, vec)); /* includes closure name ?? */ - } - else if ((is_hash_table (vec)) && (is_typed_hash_table (vec)) && - (is_c_function (hash_table_value_typer (vec)))) - return (c_function_symbol (hash_table_value_typer (vec))); - } - } - return (car ( - sig)); /* we want the function's return type in this context */ - } - return (sc->T); - } - if ((is_quote (sc, car (arg))) && (is_pair (cdr (arg)))) - return (s7_type_of (sc, cadr (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_size(val)) == (s7_uint)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_ITERATOR: { - s7_pointer arg_slot= s7_slot (sc, car (arg)); - if ((is_slot (arg_slot)) && (is_sequence (slot_value (arg_slot)))) { - s7_pointer sig= s7_signature (sc, slot_value (arg_slot)); - if (is_pair (sig)) return (car (sig)); - } - } - } - else if ((car (arg) == sc->quote_function) && (is_pair (cdr (arg)))) - return (s7_type_of (sc, cadr (arg))); - else if (is_c_function (car (arg))) { - const s7_pointer sig= c_function_signature (car (arg)); - if (is_pair (sig)) return (car (sig)); - } - return (sc->T); - } - if (is_symbol (arg)) { - s7_pointer arg_slot= opt_simple_symbol (sc, arg); - if (!arg_slot) return (sc->T); - return (s7_type_of (sc, slot_value (arg_slot))); - } - return (s7_type_of (sc, arg)); -} - -static bool -opt_b_pp_sf (opt_info* o) { - return (q_func (o).b_pp_f (slot_value (q_arg1 (o).p), q_p_func2_call (o))); -} -static bool -opt_b_pp_fs (opt_info* o) { - return (q_func (o).b_pp_f (q_p_func2_call (o), slot_value (q_arg2 (o).p))); -} -static bool -opt_b_pp_ss (opt_info* o) { - return ( - q_func (o).b_pp_f (slot_value (q_arg1 (o).p), slot_value (q_arg2 (o).p))); -} -static bool -opt_b_pp_sc (opt_info* o) { - return (q_func (o).b_pp_f (slot_value (q_arg1 (o).p), q_arg2 (o).p)); -} -static bool -opt_b_pp_sfo (opt_info* o) { - return ( - q_func (o).b_pp_f (slot_value (q_arg1 (o).p), - q_func1 (o).p_p_f (o->sc, slot_value (q_arg2 (o).p)))); -} -static bool -opt_b_7pp_sf (opt_info* o) { - return (q_func (o).b_7pp_f (o->sc, slot_value (q_arg1 (o).p), - q_p_func2_call (o))); -} -static bool -opt_b_7pp_fs (opt_info* o) { - return (q_func (o).b_7pp_f (o->sc, q_p_func2_call (o), - slot_value (q_arg2 (o).p))); -} -static bool -opt_b_7pp_ss (opt_info* o) { - return (q_func (o).b_7pp_f (o->sc, slot_value (q_arg1 (o).p), - slot_value (q_arg2 (o).p))); -} -static bool -opt_b_7pp_ss_lt (opt_info* o) { - return ( - lt_b_7pp (o->sc, slot_value (q_arg1 (o).p), slot_value (q_arg2 (o).p))); -} -static bool -opt_b_7pp_ss_gt (opt_info* o) { - return ( - gt_b_7pp (o->sc, slot_value (q_arg1 (o).p), slot_value (q_arg2 (o).p))); -} -static bool -opt_b_7pp_ss_char_lt (opt_info* o) { - return (char_lt_b_7pp (o->sc, slot_value (q_arg1 (o).p), - slot_value (q_arg2 (o).p))); -} -static bool -opt_b_7pp_sc (opt_info* o) { - return (q_func (o).b_7pp_f (o->sc, slot_value (q_arg1 (o).p), q_arg2 (o).p)); -} -static bool -opt_b_7pp_sfo (opt_info* o) { - return (q_func (o).b_7pp_f ( - o->sc, slot_value (q_arg1 (o).p), - q_func1 (o).p_p_f (o->sc, slot_value (q_arg2 (o).p)))); -} -static bool -opt_is_equal_sfo (opt_info* o) { - return (s7_is_equal (o->sc, slot_value (q_arg1 (o).p), - q_func1 (o).p_p_f (o->sc, slot_value (q_arg2 (o).p)))); -} -static bool -opt_is_equivalent_sfo (opt_info* o) { - return (is_equivalent_1 (o->sc, slot_value (q_arg1 (o).p), - q_func1 (o).p_p_f (o->sc, slot_value (q_arg2 (o).p)), - NULL)); -} -static bool -opt_b_pp_sf_char_eq (opt_info* o) { - return (slot_value (q_arg1 (o).p) == q_p_func2_call (o)); -} /* lt above checks for char args */ -static bool -opt_b_7pp_ff (opt_info* o) { - s7_pointer p= q_p_func3_call (o); - return (q_func (o).b_7pp_f (o->sc, p, q_p_func2_call (o))); -} -static bool -opt_b_pp_ff (opt_info* o) { - s7_pointer p= q_p_func3_call (o); - return (q_func (o).b_pp_f (p, q_p_func2_call (o))); -} -static bool -opt_b_pp_ff_char_eq (opt_info* o) { - return (q_p_func3_call (o) == q_p_func2_call (o)); -} -static bool -opt_b_pp_fc_char_eq (opt_info* o) { - return (q_p_func3_call (o) == q_arg1 (o).p); -} -static bool -opt_b_pp_fc (opt_info* o) { - return (q_func (o).b_pp_f (q_p_func3_call (o), q_arg1 (o).p)); -} -static bool -opt_b_7pp_fc (opt_info* o) { - return (q_func (o).b_7pp_f (o->sc, q_p_func3_call (o), q_arg1 (o).p)); -} - -static bool -opt_car_equal_sf (opt_info* o) { - s7_pointer p= slot_value (q_arg2 (o).p); - return (s7_is_equal (o->sc, slot_value (q_arg1 (o).p), - (is_pair (p)) ? car (p) - : g_car (o->sc, set_plist_1 (o->sc, p)))); -} - -static bool -opt_car_equivalent_sf (opt_info* o) { - s7_pointer p= slot_value (q_arg2 (o).p); - return (is_equivalent_1 ( - o->sc, slot_value (q_arg1 (o).p), - (is_pair (p)) ? car (p) : g_car (o->sc, set_plist_1 (o->sc, p)), NULL)); -} - -static bool -opt_b_7pp_car_sf (opt_info* o) { - s7_pointer p= slot_value (q_arg2 (o).p); - return (q_func (o).b_7pp_f ( - o->sc, slot_value (q_arg1 (o).p), - (is_pair (p)) ? car (p) : g_car (o->sc, set_plist_1 (o->sc, 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 (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - q_i_func1_call (o))); -} - -static bool -opt_substring_equal_sf (opt_info* o) { - return (scheme_strings_are_equal ( - slot_value (q_arg1 (o).p), - opt_p_substring_uncopied_ssf (q_func2_arg (o).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 (q_call (o1).fp == opt_p_p_s) { - q_arg2 (opc).p = q_arg1 (o1).p; - q_func1 (opc).p_p_f= q_func1 (o1).p_p_f; - if (bpf_case) q_call (opc).fb= opt_b_pp_sfo; - else if (q_func1 (opc).p_p_f == car_p_p) - q_call (opc).fb= ((q_func (opc).b_7pp_f == s7_is_equal) - ? opt_car_equal_sf - : ((q_func (opc).b_7pp_f == s7_is_equivalent) - ? opt_car_equivalent_sf - : opt_b_7pp_car_sf)); - else - q_call (opc).fb= ((q_func (opc).b_7pp_f == s7_is_equal) - ? opt_is_equal_sfo - : ((q_func (opc).b_7pp_f == s7_is_equivalent) - ? opt_is_equivalent_sfo - : opt_b_7pp_sfo)); - backup_pc (sc); - return_true (sc, NULL); - } - } - return_false (sc, NULL); -} - -static bool -opt_b_pp_ffo (opt_info* o) { - s7_pointer b1= q_func1 (o).p_p_f (o->sc, slot_value (q_arg1 (o).p)); - return (q_func (o).b_pp_f ( - b1, q_func2 (o).p_p_f (o->sc, slot_value (q_arg2 (o).p)))); -} - -static bool -opt_b_pp_ffo_is_eq (opt_info* o) { - s7_pointer b1= q_func1 (o).p_p_f (o->sc, slot_value (q_arg1 (o).p)); - s7_pointer b2= q_func2 (o).p_p_f (o->sc, slot_value (q_arg2 (o).p)); - return ((b1 == b2) || ((is_unspecified (b1)) && (is_unspecified (b2)))); -} - -static bool -opt_b_7pp_ffo (opt_info* o) { - s7_pointer b1= q_func1 (o).p_p_f (o->sc, slot_value (q_arg1 (o).p)); - return (q_func (o).b_7pp_f ( - o->sc, b1, q_func2 (o).p_p_f (o->sc, slot_value (q_arg2 (o).p)))); -} - -static bool -opt_b_cadr_cadr (opt_info* o) { - s7_pointer p1= slot_value (q_arg1 (o).p); - s7_pointer p2= slot_value (q_arg2 (o).p); - p1 = ((is_pair (p1)) && (is_pair (cdr (p1)))) - ? cadr (p1) - : g_cadr (o->sc, set_plist_1 (o->sc, p1)); - p2 = ((is_pair (p2)) && (is_pair (cdr (p2)))) - ? cadr (p2) - : g_cadr (o->sc, set_plist_1 (o->sc, p2)); - return (q_func (o).b_7pp_f (o->sc, 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 ((q_call (o1).fp == opt_p_p_s) && (q_call (o2).fp == opt_p_p_s)) { - q_arg1 (opc).p = q_arg1 (o1).p; - q_func1 (opc).p_p_f= q_func1 (o1).p_p_f; - q_arg2 (opc).p = q_arg1 (o2).p; - q_func2 (opc).p_p_f= q_func1 (o2).p_p_f; - q_call (opc).fb= - (bpf_case) ? ((q_func (opc).b_pp_f == s7_is_eq) ? opt_b_pp_ffo_is_eq - : opt_b_pp_ffo) - : (((q_func2 (opc).p_p_f == cadr_p_p) && - (q_func1 (opc).p_p_f == cadr_p_p)) - ? opt_b_cadr_cadr - : opt_b_7pp_ffo); - sc->pc-= 2; - return_true (sc, NULL); - } - } - return_false (sc, NULL); -} - -static void -check_b_types (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr, bool (*fb) (opt_info* o)) { - if (s7_b_pp_unchecked_function (s_func)) { - s7_pointer call_sig = c_function_signature (s_func); - s7_pointer arg1_type= opt_arg_type (sc, cdr (expr)); - s7_pointer arg2_type= opt_arg_type (sc, cddr (expr)); - if ((cadr (call_sig) == arg1_type) && /* not car(arg1_type) here: (string>? - (string) (read-line)) */ - (caddr (call_sig) == arg2_type)) { - q_call (opc).fb = fb; - q_func (opc).b_pp_f= s7_b_pp_unchecked_function (s_func); + s7_pointer len = s7_length(sc, iterator_sequence(val)); + return(make_boolean(sc, (is_t_integer(len)) && (integer(len) == ilen))); + } + case T_BYTE_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_COMPLEX_VECTOR: + return(make_boolean(sc, vector_length(val) == 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: + sole_arg_wrong_type_error_nr(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 opt_p_c (opt_info* o); - -static bool -b_pp_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr, s7_pointer arg1, s7_pointer arg2, - bool bpf_case) { - const int32_t cur_index= sc->pc; - opt_info* o1; - /* v[3] is set when we get here */ - if ((is_symbol (arg1)) && (is_symbol (arg2))) { - q_arg1 (opc).p= opt_simple_symbol (sc, arg1); - q_arg2 (opc).p= opt_simple_symbol (sc, arg2); - if ((q_arg1 (opc).p) && (q_arg2 (opc).p)) { - const s7_b_7pp_t b7f= (bpf_case) ? NULL : q_func (opc).b_7pp_f; - q_call (opc).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 (sc, expr); - } - } - if (is_symbol (arg1)) { - q_arg1 (opc).p= opt_simple_symbol (sc, arg1); - if (!q_arg1 (opc).p) return_false (sc, expr); - if ((!is_symbol (arg2)) && (!is_pair (arg2))) { - q_arg2 (opc).p = arg2; - q_call (opc).fb= (bpf_case) ? opt_b_pp_sc : opt_b_7pp_sc; - check_b_types (sc, opc, s_func, expr, opt_b_pp_sc); - return_true (sc, expr); - } - if (cell_optimize (sc, cddr (expr))) { - if (!b_pp_sf_combinable (sc, opc, bpf_case)) { - q_func2_arg (opc).o1= sc->opts[cur_index]; - q_func2 (opc).fp = q_func2_arg (opc).q_call (o1).fp; - q_call (opc).fb = (bpf_case) ? opt_b_pp_sf : opt_b_7pp_sf; - check_b_types (sc, opc, s_func, expr, - opt_b_pp_sf); /* this finds b_pp_unchecked cases */ - if ((q_func2 (opc).fp == opt_p_substring_uncopied_ssf) && - (q_func (opc).b_pp_f == string_eq_b_unchecked)) - q_call (opc).fb= opt_substring_equal_sf; /*concordance.scm */ - else if (q_func (opc).b_pp_f == char_eq_b_unchecked) - q_call (opc).fb= opt_b_pp_sf_char_eq; - } - return_true (sc, expr); - } - sc->pc= cur_index; - } - else if ((is_symbol (arg2)) && (is_pair (arg1))) { - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (cell_optimize (sc, cdr (expr))) { - q_arg2 (opc).p= s7_slot (sc, arg2); /* can be # */ - if ((!is_slot (q_arg2 (opc).p)) || - (has_methods (slot_value (q_arg2 (opc).p)))) - return_false (sc, expr); - q_func2 (opc).fp= q_func2_arg (opc).q_call (o1).fp; - q_call (opc).fb = (bpf_case) ? opt_b_pp_fs : opt_b_7pp_fs; - check_b_types (sc, opc, s_func, expr, opt_b_pp_fs); - return_true (sc, expr); - } - sc->pc= cur_index; - } - o1= sc->opts[sc->pc]; /* used below opc->[8].o1 etc */ - if (cell_optimize (sc, cdr (expr))) { - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (cell_optimize (sc, cddr (expr))) { - if (b_pp_ff_combinable (sc, opc, bpf_case)) return_true (sc, expr); - q_call (opc).fb = (bpf_case) ? opt_b_pp_ff : opt_b_7pp_ff; - q_func3_arg (opc).o1= o1; - q_func3 (opc).fp = q_call (o1).fp; - q_func2 (opc).fp = q_func2_arg (opc).q_call (o1).fp; - check_b_types (sc, opc, s_func, expr, opt_b_pp_ff); - if (q_func (opc).b_pp_f == char_eq_b_unchecked) { - if (q_func2 (opc).fp == - opt_p_c) /* q_func2(opc).fp can be opt_p_c where - q_func2_arg(opc).q_arg1(o1).p is the char */ - { - q_call (opc).fb= opt_b_pp_fc_char_eq; - q_arg1 (opc).p = q_func2_arg (opc).q_arg1 (o1).p; - } - else q_call (opc).fb= opt_b_pp_ff_char_eq; - } - else if (q_func2 (opc).fp == opt_p_c) { - q_call (opc).fb= - (q_call (opc).fb == opt_b_pp_ff) - ? opt_b_pp_fc - : opt_b_7pp_fc; /* can't use bpf_case here -- check_b_types can - use the other form */ - q_arg1 (opc).p= q_func2_arg (opc).q_arg1 (o1).p; - } - return_true (sc, expr); - } - } - return_false (sc, expr); -} +static s7_pointer fx_less_length_i(s7_scheme *sc, s7_pointer arg) +{ + const s7_int ilen = integer(opt3_con(arg)); /* caddr(arg) */ + const s7_pointer val = lookup(sc, opt3_sym(cdr(arg))); /* cadadr(arg) */ -/* -------- b_pi -------- */ + 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_size(val)) < (s7_uint)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_ITERATOR: + { + s7_pointer len = s7_length(sc, iterator_sequence(val)); + return(make_boolean(sc, (is_t_integer(len)) && (integer(len) < ilen))); + } + case T_BYTE_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_COMPLEX_VECTOR: + return(make_boolean(sc, vector_length(val) < 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: + sole_arg_wrong_type_error_nr(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))));} +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);} +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_symbol_and_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, opt1_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) +fx_c_sc_any(fx_c_oc, o_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)), opt1_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(opt1_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(opt1_con(cdr(arg)))));} +static s7_pointer fx_c_ti_remainder(s7_scheme *sc, s7_pointer arg) {return(remainder_p_pi(sc, t_lookup(sc, cadr(arg), arg), integer(opt1_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), opt1_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(opt1_con(cdr(arg)))));} + /* tc happens a lot, but others almost never */ + +static s7_pointer fx_memq_sc(s7_scheme *sc, s7_pointer arg) {return(memq_p_pp(sc, lookup(sc, cadr(arg)), opt1_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)), opt1_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), opt1_con(cdr(arg))));} +static s7_pointer fx_leq_sc(s7_scheme *sc, s7_pointer arg) {return(leq_p_pp(sc, lookup(sc, cadr(arg)), opt1_con(cdr(arg))));} +static s7_pointer fx_lt_sc(s7_scheme *sc, s7_pointer arg) {return(lt_p_pp(sc, lookup(sc, cadr(arg)), opt1_con(cdr(arg))));} +static s7_pointer fx_gt_sc(s7_scheme *sc, s7_pointer arg) {return(gt_p_pp(sc, lookup(sc, cadr(arg)), opt1_con(cdr(arg))));} +static s7_pointer fx_geq_sc(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, lookup(sc, cadr(arg)), opt1_con(cdr(arg))));} +static s7_pointer fx_list_sc(s7_scheme *sc, s7_pointer arg) {return(list_2(sc, lookup(sc, cadr(arg)), opt1_con(cdr(arg))));} + +#define fx_char_eq_sc_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer c = Lookup(sc, cadr(arg), arg); \ + if (c == opt1_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), sc->type_names[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, caddr(arg), 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, caddr(arg), arg))); +} + +static s7_pointer fx_cons_cs(s7_scheme *sc, s7_pointer arg) {return(cons(sc, opt1_con(cdr(arg)), lookup(sc, caddr(arg))));} +static s7_pointer fx_cons_ct(s7_scheme *sc, s7_pointer arg) {return(cons(sc, opt1_con(cdr(arg)), t_lookup(sc, caddr(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, opt1_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, opt1_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, opt1_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, opt1_sym(cdr(arg)))));} +static s7_pointer fx_vref_ss(s7_scheme *sc, s7_pointer arg) {return(s7i_vector_ref_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt1_sym(cdr(arg)))));} +static s7_pointer fx_vref_st(s7_scheme *sc, s7_pointer arg) {return(s7i_vector_ref_p_pp(sc, lookup(sc, cadr(arg)), t_lookup(sc, opt1_sym(cdr(arg)), arg)));} +static s7_pointer fx_vref_ts(s7_scheme *sc, s7_pointer arg) {return(s7i_vector_ref_p_pp(sc, t_lookup(sc, cadr(arg), arg), s_lookup(sc, opt1_sym(cdr(arg)), arg)));} +static s7_pointer fx_vref_tu(s7_scheme *sc, s7_pointer arg) {return(s7i_vector_ref_p_pp(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, opt1_sym(cdr(arg)), arg)));} +static s7_pointer fx_vref_ot(s7_scheme *sc, s7_pointer arg) {return(s7i_vector_ref_p_pp(sc, o_lookup(sc, cadr(arg), arg), t_lookup(sc, opt1_sym(cdr(arg)), arg)));} +static s7_pointer fx_vref_gt(s7_scheme *sc, s7_pointer arg) {return(s7i_vector_ref_p_pp(sc, lookup_global(sc, cadr(arg)), t_lookup(sc, opt1_sym(cdr(arg)), arg)));} +static s7_pointer fx_sref_ss(s7_scheme *sc, s7_pointer arg) {return(string_ref_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt1_sym(cdr(arg)))));} +static s7_pointer fx_sref_su(s7_scheme *sc, s7_pointer arg) {return(string_ref_p_pp(sc, lookup(sc, cadr(arg)), u_lookup(sc, opt1_sym(cdr(arg)), arg)));} +static s7_pointer fx_cons_ss(s7_scheme *sc, s7_pointer arg) {return(cons(sc, lookup(sc, cadr(arg)), lookup(sc, opt1_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, opt1_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, opt1_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, opt1_sym(cdr(arg)), 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, opt1_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), s_lookup(sc, opt1_sym(cdr((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, opt1_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_tu_direct, t_lookup, u_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, opt1_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, opt1_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, opt1_sym(cdr(arg)))));} */ +static s7_pointer fx_multiply_fs(s7_scheme *sc, s7_pointer arg) {return(g_mul_xf(sc, lookup(sc, caddr(arg)), real(cadr(arg)), 2));} +static s7_pointer fx_multiply_sf(s7_scheme *sc, s7_pointer arg) {return(g_mul_xf(sc, lookup(sc, cadr(arg)), real(opt1_con(cdr(arg))), 1));} +static s7_pointer fx_multiply_tf(s7_scheme *sc, s7_pointer arg) {return(g_mul_xf(sc, t_lookup(sc, cadr(arg), arg), real(opt1_con(cdr(arg))), 1));} +static s7_pointer fx_multiply_si(s7_scheme *sc, s7_pointer arg) {return(g_mul_xi(sc, lookup(sc, cadr(arg)), integer(opt1_con(cdr(arg))), 1));} +static s7_pointer fx_multiply_ti(s7_scheme *sc, s7_pointer arg) {return(g_mul_xi(sc, t_lookup(sc, cadr(arg), arg), integer(opt1_con(cdr(arg))), 1));} +static s7_pointer fx_multiply_ui(s7_scheme *sc, s7_pointer arg) {return(g_mul_xi(sc, u_lookup(sc, cadr(arg), arg), integer(opt1_con(cdr(arg))), 1));} +static s7_pointer fx_multiply_is(s7_scheme *sc, s7_pointer arg) {return(g_mul_xi(sc, lookup(sc, caddr(arg)), integer(cadr(arg)), 2));} +static s7_pointer fx_multiply_it(s7_scheme *sc, s7_pointer arg) {return(g_mul_xi(sc, t_lookup(sc, caddr(arg), arg), integer(cadr(arg)), 2));} +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, opt1_sym(cdr(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))); -static bool -opt_b_pi_fs (opt_info* o) { - return (q_func4 (o).b_pi_f (o->sc, q_p_func2_call (o), - integer (slot_value (q_arg1 (o).p)))); -} -static bool -opt_b_pi_fs_num_eq (opt_info* o) { - return (num_eq_b_pi (o->sc, q_p_func2_call (o), - integer (slot_value (q_arg1 (o).p)))); -} -static bool -opt_b_pi_fc (opt_info* o) { - return (q_func4 (o).b_pi_f (o->sc, q_p_func2_call (o), q_arg1 (o).i)); -} -static bool -opt_b_pi_ff (opt_info* o) { - s7_pointer p= q_p_func2_call (o); - return (q_func4 (o).b_pi_f (o->sc, p, q_i_func3_call (o))); -} - -static bool -b_pi_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr, s7_pointer arg2) { - const s7_b_pi_t bpif= - s7_b_pi_function (s_func); /* perhaps add vector-ref/equal? */ - if (bpif) { - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (cell_optimize (sc, cdr (expr))) { - opt_info* o1 = sc->opts[sc->pc]; - q_func4 (opc).b_pi_f= bpif; - q_func2 (opc).fp = q_func2_arg (opc).q_call (o1).fp; - if (is_symbol (arg2)) { - q_arg1 (opc).p= s7_t_slot (sc, arg2); /* slot checked in opt_arg_type */ - q_call (opc).fb= - (bpif == num_eq_b_pi) ? opt_b_pi_fs_num_eq : opt_b_pi_fs; - return_true (sc, expr); - } - if (is_t_integer (arg2)) { - q_arg1 (opc).i = integer (arg2); - q_call (opc).fb= opt_b_pi_fc; - return_true (sc, expr); + 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)); } - if (int_optimize (sc, cddr (expr))) { - q_call (opc).fb = opt_b_pi_ff; - q_func3_arg (opc).o1= o1; - q_func3 (opc).fp = q_call (o1).fp; - return_true (sc, expr); + 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(make_ratio_with_div_check(sc, sc->multiply_symbol, 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(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_pp(sc, x, sc->multiply_symbol, x, x, a_number_string, 1)); } - } - return_false (sc, expr); + return(x); } -/* -------- b_dd -------- */ -static bool -opt_b_dd_ss (opt_info* o) { - return (q_func (o).b_dd_f (real (slot_value (q_arg1 (o).p)), - real (slot_value (q_arg2 (o).p)))); -} -static bool -opt_b_dd_ss_lt (opt_info* o) { - return (real (slot_value (q_arg1 (o).p)) < real (slot_value (q_arg2 (o).p))); -} -static bool -opt_b_dd_ss_gt (opt_info* o) { - return (real (slot_value (q_arg1 (o).p)) > real (slot_value (q_arg2 (o).p))); -} - -static bool -opt_b_dd_sc (opt_info* o) { - return (q_func (o).b_dd_f (real (slot_value (q_arg1 (o).p)), q_arg2 (o).x)); -} -static bool -opt_b_dd_sc_lt (opt_info* o) { - return (real (slot_value (q_arg1 (o).p)) < q_arg2 (o).x); -} -static bool -opt_b_dd_sc_geq (opt_info* o) { - return (real (slot_value (q_arg1 (o).p)) >= q_arg2 (o).x); -} -static bool -opt_b_dd_sc_eq (opt_info* o) { - return (real (slot_value (q_arg1 (o).p)) == q_arg2 (o).x); -} - -static bool -opt_b_dd_sf (opt_info* o) { - return ( - q_func (o).b_dd_f (real (slot_value (q_arg1 (o).p)), q_d_func2_call (o))); -} -static bool -opt_b_dd_fs (opt_info* o) { - return ( - q_func (o).b_dd_f (q_d_func2_call (o), real (slot_value (q_arg2 (o).p)))); -} -static bool -opt_b_dd_fs_gt (opt_info* o) { - return (q_d_func2_call (o) > real (slot_value (q_arg2 (o).p))); -} -static bool -opt_b_dd_fc (opt_info* o) { - return (q_func (o).b_dd_f (q_d_func2_call (o), q_arg2 (o).x)); -} -static bool -opt_b_dd_fc_gt (opt_info* o) { - return (q_d_func2_call (o) > q_arg2 (o).x); -} - -static bool -opt_b_dd_ff (opt_info* o) { - s7_double x1= q_d_func2_call (o); - s7_double x2= q_d_func3_call (o); - return (q_func (o).b_dd_f (x1, x2)); -} - -static bool -b_dd_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr, s7_pointer arg1, s7_pointer arg2) { - const s7_b_dd_t bif = s7_b_dd_function (s_func); - const int32_t cur_index= sc->pc; - if (!bif) return_false (sc, expr); - q_func (opc).b_dd_f= bif; - if (is_symbol (arg1)) { - q_arg1 (opc).p= s7_t_slot (sc, arg1); - if (is_symbol (arg2)) { - q_arg2 (opc).p = s7_t_slot (sc, arg2); - q_call (opc).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 (sc, expr); - } - if (is_t_real (arg2)) { - q_arg2 (opc).x= s7_number_to_real (sc, arg2); - q_call (opc).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 (sc, expr); - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cddr (expr))) { - q_func2 (opc).fd= q_func2_arg (opc).q_call (o1).fd; - q_call (opc).fb = opt_b_dd_sf; - return_true (sc, expr); - } - } - sc->pc = cur_index; - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cdr (expr))) { - q_func2 (opc).fd= q_func2_arg (opc).q_call (o1).fd; - if (is_symbol (arg2)) { - q_arg2 (opc).p = s7_t_slot (sc, arg2); - q_call (opc).fb= (bif == gt_b_dd) ? opt_b_dd_fs_gt : opt_b_dd_fs; - return_true (sc, expr); - } - if (is_small_real (arg2)) { - q_arg2 (opc).x = s7_number_to_real (sc, arg2); - q_call (opc).fb= (bif == gt_b_dd) ? opt_b_dd_fc_gt : opt_b_dd_fc; - return_true (sc, expr); - } - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cddr (expr))) { - q_func3 (opc).fd= q_func3_arg (opc).q_call (o1).fd; - q_call (opc).fb = opt_b_dd_ff; - return_true (sc, expr); - } - } - sc->pc= cur_index; - return_false (sc, expr); +static s7_pointer fx_sqr_wrapped(s7_scheme *sc, s7_pointer x) +{ + if (is_t_real(x)) return(wrap_real(sc, real(x) * real(x))); + if (is_t_integer(x)) + return(multiply_if_overflow_to_real_wrapped(sc, integer(x), integer(x))); + if (is_t_complex(x)) + return(wrap_complex(sc, real_part(x) * real_part(x) - imag_part(x) * imag_part(x), 2.0 * real_part(x) * imag_part(x))); + return(fx_sqr_1(sc, x)); } -/* -------- b_ii -------- */ -static bool -opt_b_ii_ss (opt_info* o) { - return (q_func (o).b_ii_f (integer (slot_value (q_arg1 (o).p)), - integer (slot_value (q_arg2 (o).p)))); -} -static bool -opt_b_ii_ss_lt (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) < - integer (slot_value (q_arg2 (o).p))); -} -static bool -opt_b_ii_ss_gt (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) > - integer (slot_value (q_arg2 (o).p))); -} -static bool -opt_b_ii_ss_leq (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) <= - integer (slot_value (q_arg2 (o).p))); -} -static bool -opt_b_ii_ss_geq (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) >= - integer (slot_value (q_arg2 (o).p))); -} -static bool -opt_b_ii_ss_eq (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) == - integer (slot_value (q_arg2 (o).p))); -} -static bool -opt_b_ii_sc (opt_info* o) { - return ( - q_func (o).b_ii_f (integer (slot_value (q_arg1 (o).p)), q_arg2 (o).i)); +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, arg=(+ (* x x) (* y y)) */ +{ + sc->temp5 = fx_sqr_wrapped(sc, lookup(sc, car(opt1_pair(cdr(arg))))); /* cadadr(arg) */ + return(add_p_pp(sc, sc->temp5, fx_sqr_wrapped(sc, lookup(sc, car(opt3_pair(arg)))))); /* cadaddr(arg) */ } -static bool -opt_b_ii_sc_lt (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) < q_arg2 (o).i); -} -static bool -opt_b_ii_sc_leq (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) <= q_arg2 (o).i); -} -static bool -opt_b_ii_sc_gt (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) > q_arg2 (o).i); -} -static bool -opt_b_ii_sc_geq (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) >= q_arg2 (o).i); -} -static bool -opt_b_ii_sc_eq (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) == q_arg2 (o).i); -} -static bool -opt_b_ii_sc_lt_2 (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) < 2); -} -static bool -opt_b_ii_sc_lt_1 (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) < 1); -} -static bool -opt_b_ii_sc_lt_0 (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) < 0); -} -static bool -opt_b_ii_sc_leq_0 (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) <= 0); -} -static bool -opt_b_ii_sc_gt_0 (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) > 0); -} -static bool -opt_b_ii_sc_geq_0 (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) >= 0); -} -static bool -opt_b_ii_sc_eq_0 (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) == 0); -} -static bool -opt_b_ii_sc_eq_1 (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) == 1); -} - -static bool -opt_b_7ii_ss (opt_info* o) { - return (q_func (o).b_7ii_f (o->sc, integer (slot_value (q_arg1 (o).p)), - integer (slot_value (q_arg2 (o).p)))); -} -static bool -opt_b_7ii_sc (opt_info* o) { - return (q_func (o).b_7ii_f (o->sc, integer (slot_value (q_arg1 (o).p)), - q_arg2 (o).i)); -} -static bool -opt_b_7ii_sc_bit (opt_info* o) { - return ((integer (slot_value (q_arg1 (o).p)) & - ((s7_int) (1LL << q_arg2 (o).i))) != 0); -} - -static bool -opt_b_ii_ff (opt_info* o) { - s7_int i1= q_i_func2_call (o); - s7_int i2= q_i_func3_call (o); - return (q_func (o).b_ii_f (i1, i2)); -} - -static bool -opt_b_ii_fs (opt_info* o) { - return (q_func (o).b_ii_f (q_i_func2_call (o), - integer (slot_value (q_arg2 (o).p)))); -} -static bool -opt_b_ii_sf (opt_info* o) { - return (q_func (o).b_ii_f (integer (slot_value (q_arg1 (o).p)), - q_i_func2_call (o))); -} -static bool -opt_b_ii_sf_eq (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) == q_i_func2_call (o)); + +static s7_pointer fx_hypot(s7_scheme *sc, s7_pointer arg) /* (sqrt (+ (* x x) (* y y))) */ +{ + sc->temp5 = fx_sqr_wrapped(sc, lookup(sc, opt1_sym(cdr(arg)))); /* cadadadr(arg) ! -> x */ + return(sqrt_p_p(sc, add_p_pp_wrapped(sc, sc->temp5, fx_sqr_wrapped(sc, lookup(sc, opt3_sym(cdr(arg))))))); /* cadaddadr(arg) -> y */ } -static bool -opt_b_ii_fc (opt_info* o) { - return (q_func (o).b_ii_f (q_i_func2_call (o), q_arg2 (o).i)); + +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_wrapped(sc, lookup(sc, opt2_sym(cdr(arg))))); /* cadaddr(arg) */ + return(fn_proc(arg)(sc, sc->t2_1)); } -static bool -opt_b_ii_fc_eq (opt_info* o) { - return (q_i_func2_call (o) == q_arg2 (o).i); + +static s7_pointer fx_c_c_sqr(s7_scheme *sc, s7_pointer arg) /* fb */ +{ + set_car(sc->t2_2, fx_sqr_wrapped(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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_sym(cdr(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, opt1_sym(cdr(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, opt1_sym(cdr(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, opt1_sym(cdr(arg)), arg)));} +static s7_pointer fx_geq_vo(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, v_lookup(sc, cadr(arg), arg), o_lookup(sc, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_sym(cdr(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, opt1_sym(cdr(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(opt1_sym(cdr(arg)))));} + +static s7_pointer fx_gt_tT(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer num1 = t_lookup(sc, cadr(arg), arg); + s7_pointer num2 = T_lookup(sc, opt1_sym(cdr(arg)), arg); + return(((is_t_integer(num1)) && (is_t_integer(num2))) ? make_boolean(sc, integer(num1) > integer(num2)) : gt_p_pp(sc, num1, num2)); } -static bool -b_ii_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr, s7_pointer arg1, s7_pointer arg2) { - const s7_b_ii_t bif = s7_b_ii_function (s_func); - s7_b_7ii_t b7if= NULL; - if (!bif) { - b7if= s7_b_7ii_function (s_func); - if (!b7if) return_false (sc, expr); +#define fx_gt_si_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer x = Lookup(sc, cadr(arg), arg); \ + if (is_t_integer(x)) return(make_boolean(sc, integer(x) > integer(opt1_con(cdr(arg))))); \ + if (is_t_real(x)) return(make_boolean(sc, real(x) > integer(opt1_con(cdr(arg))))); \ + return(g_greater_xi(sc, set_plist_2(sc, x, opt1_con(cdr(arg))))); /* caddr(arg) */ \ } - if (bif) q_func (opc).b_ii_f= bif; - else q_func (opc).b_7ii_f= b7if; - if (is_symbol (arg1)) { - q_arg1 (opc).p= s7_t_slot (sc, arg1); - if (is_symbol (arg2)) { - q_arg2 (opc).p= s7_t_slot (sc, arg2); - q_call (opc).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 (sc, expr); - } - if (is_t_integer (arg2)) { - const s7_int i2= integer (arg2); - q_arg2 (opc).i = i2; - q_call (opc).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 (sc, expr); - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if ((bif) && (int_optimize (sc, cddr (expr)))) { - q_call (opc).fb = (bif == num_eq_b_ii) ? opt_b_ii_sf_eq : opt_b_ii_sf; - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - return_true (sc, expr); - } - return_false (sc, expr); - } - if (!bif) return_false (sc, expr); - - if (is_symbol (arg2)) { - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (!int_optimize (sc, cdr (expr))) return_false (sc, expr); - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_arg2 (opc).p = s7_t_slot (sc, arg2); - q_call (opc).fb = opt_b_ii_fs; - return_true (sc, expr); - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cdr (expr))) { - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - if (is_t_integer (arg2)) { - q_arg2 (opc).i = integer (arg2); - q_call (opc).fb= (bif == num_eq_b_ii) ? opt_b_ii_fc_eq : opt_b_ii_fc; - return_true (sc, expr); - } - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cddr (expr))) { - q_func3 (opc).fi= q_func3_arg (opc).q_call (o1).fi; - q_call (opc).fb = opt_b_ii_ff; - return_true (sc, expr); - } - } - return_false (sc, expr); -} -/* -------- b_or|and -------- */ -static bool -opt_and_bb (opt_info* o) { - return ((q_func (o).fb (q_arg1 (o).o1)) && (q_b_func2_call (o))); -} +fx_gt_si_any(fx_gt_si, s_lookup) +fx_gt_si_any(fx_gt_ti, t_lookup) +fx_gt_si_any(fx_gt_ui, u_lookup) -#define q_bool_call(o, i) o->v[i + 3] +static s7_pointer fx_leq_ss(s7_scheme *sc, s7_pointer arg) {return(leq_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt1_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, opt1_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, opt1_sym(cdr(arg)), arg)));} -static bool -opt_and_any_b (opt_info* o) { - for (s7_int i= 0; i < q_arg1 (o).i; i++) { - opt_info* o1= q_bool_call (o, i).o1; - if (!q_call (o1).fb (o1)) return (false); +#define fx_leq_si_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer x = Lookup(sc, cadr(arg), arg); \ + if (is_t_integer(x)) return(make_boolean(sc, integer(x) <= integer(opt1_con(cdr(arg))))); \ + return(g_leq_xi(sc, set_plist_2(sc, x, opt1_con(cdr(arg))))); /* caddr(arg) */ \ } - return (true); -} -static bool -opt_or_bb (opt_info* o) { - return ((q_func (o).fb (q_arg1 (o).o1)) || (q_b_func2_call (o))); +fx_leq_si_any(fx_leq_si, s_lookup) +fx_leq_si_any(fx_leq_ti, t_lookup) +fx_leq_si_any(fx_leq_ui, u_lookup) +fx_leq_si_any(fx_leq_vi, v_lookup) + +static s7_pointer fx_lt_ss(s7_scheme *sc, s7_pointer arg) {return(lt_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt1_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, opt1_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, opt1_sym(cdr(arg)))));} + +static s7_pointer fx_lt_gsg(s7_scheme *sc, s7_pointer arg) /* gsg is much faster than sss */ +{ + const s7_pointer x1 = lookup_global(sc, cadr(arg)); + const s7_pointer x2 = lookup(sc, opt1_sym(cdr(arg))); /* caddr(arg) */ + const s7_pointer x3 = lookup_global(sc, opt2_sym(cdr(arg))); /* cadddr(arg) */ + if ((is_t_integer(x1)) && (is_t_integer(x2)) && (is_t_integer(x3))) + return(make_boolean(sc, ((integer(x1) < integer(x2)) && (integer(x2) < integer(x3))))); + if (!is_real(x3)) + wrong_type_error_nr(sc, sc->lt_symbol, 3, x3, sc->type_names[T_REAL]); /* else (< 2 1 1+i) returns #f */ + return(make_boolean(sc, (lt_b_7pp(sc, x1, x2)) && (lt_b_7pp(sc, x2, x3)))); +} + +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, opt1_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, opt1_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, opt1_sym(cdr(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, opt1_sym(cdr(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, opt1_sym(cdr(arg)), arg)));} + +static s7_pointer fx_lt_tf(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer x = t_lookup(sc, cadr(arg), arg); + if (is_t_real(x)) return(make_boolean(sc, real(x) < real(opt1_con(cdr(arg))))); + return(g_less_xf(sc, set_plist_2(sc, x, opt1_con(cdr(arg))))); /* caddr(arg) */ } -static bool -opt_or_any_b (opt_info* o) { - for (s7_int i= 0; i < q_arg1 (o).i; i++) { - opt_info* o1= q_bool_call (o, i).o1; - if (q_call (o1).fb (o1)) return (true); - } - return (false); -} - -static bool -opt_b_or_and (s7_scheme* sc, s7_pointer expr, int32_t len, int32_t is_and) { - opt_info* opc= alloc_opt_info (sc); - s7_pointer p = cdr (expr); - if (len == 3) { - opt_info* o1= sc->opts[sc->pc]; - if (bool_optimize_nw (sc, cdr (expr))) { - opt_info* o2= sc->opts[sc->pc]; - if (bool_optimize_nw (sc, cddr (expr))) { - q_func2_arg (opc).o1= o2; - q_func2 (opc).fb = q_call (o2).fb; - q_call (opc).fb = (is_and) ? opt_and_bb : opt_or_bb; - q_arg1 (opc).o1 = o1; - q_func (opc).fb = q_call (o1).fb; - return_true (sc, expr); - } - } - return_false (sc, expr); +#define fx_lt_si_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer x = Lookup(sc, cadr(arg), arg); \ + if (is_t_integer(x)) return(make_boolean(sc, integer(x) < integer(opt1_con(cdr(arg))))); \ + return(g_less_xi(sc, set_plist_2(sc, x, opt1_con(cdr(arg))))); /* caddr(arg) */ \ } - q_arg1 (opc).i= (len - 1); - for (int32_t i= 0; (is_pair (p)) && (i < 12); i++, p= cdr (p)) { - q_bool_call (opc, i).o1= sc->opts[sc->pc]; - if (!bool_optimize_nw (sc, p)) break; - } - if (!is_null (p)) return_false (sc, expr); - q_call (opc).fb= (is_and) ? opt_and_any_b : opt_or_any_b; - return_true (sc, expr); -} -static bool -opt_b_and (s7_scheme* sc, s7_pointer expr, int32_t len) { - return (opt_b_or_and (sc, expr, len, true)); -} -static bool -opt_b_or (s7_scheme* sc, s7_pointer expr, int32_t len) { - return (opt_b_or_and (sc, expr, len, false)); +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 = 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))); } -/* ---------------------------------------- cell opts - * ---------------------------------------- */ +static s7_pointer fx_lt_t1(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer 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 -opt_p_c (opt_info* o) { - return (q_arg1 (o).p); +static s7_pointer fx_lt_t2(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer 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 -opt_p_s (opt_info* o) { - return (slot_value (q_arg1 (o).p)); + +static s7_pointer fx_geq_tf(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer x = t_lookup(sc, cadr(arg), arg); + if (is_t_real(x)) return(make_boolean(sc, real(x) >= real(opt1_con(cdr(arg))))); + return(g_geq_xf(sc, set_plist_2(sc, x, opt1_con(cdr(arg))))); /* caddr(arg) */ } -static bool -opt_cell_not_pair (s7_scheme* sc, s7_pointer expr) { - s7_pointer slot; - opt_info* opc; - if (!is_symbol (expr)) { - opc = alloc_opt_info (sc); - q_arg1 (opc).p = expr; - q_call (opc).fp= opt_p_c; - return_true (sc, expr); +#define fx_geq_si_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer x = Lookup(sc, cadr(arg), arg); \ + if (is_t_integer(x)) return(make_boolean(sc, integer(x) >= integer(opt1_con(cdr(arg))))); \ + return(g_geq_xi(sc, set_plist_2(sc, x, opt1_con(cdr(arg))))); /* caddr(arg) */ \ } - slot= opt_simple_symbol (sc, expr); - if (!slot) return_false (sc, expr); - opc = alloc_opt_info (sc); - q_arg1 (opc).p = slot; - q_call (opc).fp= opt_p_s; - return_true (sc, expr); + +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 = 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))); } -/* -------- p -------- */ -#define is_opt_safe(P) \ - ((optimize_op (P) >= OP_SAFE_C_S) && (!is_unknown_op (optimize_op (P)))) - -#define cf_call(Sc, expr, S_func, Num) \ - (((is_optimized (expr)) && (is_opt_safe (expr))) \ - ? fn_proc (expr) \ - : c_function_call (c_function_chooser (S_func) ( \ - Sc, S_func, Num, expr))) /* was ops=false 19-Mar-24 */ - -static s7_pointer -opt_p_f (opt_info* o) { - return (q_func (o).p_f (o->sc)); -} -static s7_pointer -opt_p_call (opt_info* o) { - return (q_func (o).call (o->sc, o->sc->nil)); -} - -static bool -p_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr) { - const s7_p_t func= s7_p_function (s_func); - if (func) { - q_func (opc).p_f= func; - q_call (opc).fp = opt_p_f; - return_true (sc, expr); - } - if ((is_safe_procedure (s_func)) && (c_function_min_args (s_func) == 0)) { - q_func (opc).call= cf_call (sc, expr, s_func, 0); - q_call (opc).fp = opt_p_call; - return_true (sc, expr); +#define fx_num_eq_ss_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer x = Lookup1(sc, cadr(arg), arg); \ + s7_pointer y = Lookup2(sc, opt1_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))); \ } - return_false (sc, expr); -} -/* -------- p_p -------- */ -static s7_pointer -opt_p_p_c (opt_info* o) { - return (q_func1 (o).p_p_f (o->sc, q_arg1 (o).p)); -} -static s7_pointer -opt_p_i_c (opt_info* o) { - return (make_integer (o->sc, q_func (o).i_i_f (q_arg1 (o).i))); -} -static s7_pointer -opt_p_7i_c (opt_info* o) { - return (make_integer (o->sc, q_func (o).i_7i_f (o->sc, q_arg1 (o).i))); -} -static s7_pointer -opt_p_d_c (opt_info* o) { - return (make_real (o->sc, q_func (o).d_d_f (q_arg1 (o).x))); -} -static s7_pointer -opt_p_7d_c (opt_info* o) { - return (make_real (o->sc, q_func (o).d_7d_f (o->sc, q_arg1 (o).x))); -} -static s7_pointer -opt_p_p_s (opt_info* o) { - return (q_func1 (o).p_p_f (o->sc, slot_value (q_arg1 (o).p))); -} -static s7_pointer -opt_p_p_s_abs (opt_info* o) { - return (abs_p_p (o->sc, slot_value (q_arg1 (o).p))); -} -static s7_pointer -opt_p_p_s_random (opt_info* o) { - return (random_p_p (o->sc, slot_value (q_arg1 (o).p))); -} -static s7_pointer -opt_p_p_s_random_wrapped (opt_info* o) { - return (random_p_p_wrapped (o->sc, slot_value (q_arg1 (o).p))); -} -static s7_pointer -opt_p_p_s_cdr (opt_info* o) { - s7_pointer p= slot_value (q_arg1 (o).p); - return ((is_pair (p)) ? cdr (p) : cdr_p_p (o->sc, p)); -} -static s7_pointer -opt_p_p_f (opt_info* o) { - return (q_func1 (o).p_p_f (o->sc, q_p_func2_call (o))); -} -static s7_pointer -opt_p_p_f1 (opt_info* o) { - return (q_func1 (o).p_p_f ( - o->sc, q_func (o).p_p_f (o->sc, slot_value (q_arg1 (o).p)))); -} -static s7_pointer -opt_p_p_f_exp (opt_info* o) { - return (exp_p_p (o->sc, q_p_func2_call (o))); -} -static s7_pointer -opt_p_7d_c_random (opt_info* o) { - return (make_real (o->sc, random_d_7d (o->sc, q_arg1 (o).x))); -} -static s7_pointer -opt_p_p_s_iterate (opt_info* o) { - return (iterate_p_p (o->sc, slot_value (q_arg1 (o).p))); -} -static s7_pointer -opt_p_p_f_iterate (opt_info* o) { - return (iterate_p_p (o->sc, q_p_func2_call (o))); -} -static s7_pointer -opt_p_z_f_magnitude (opt_info* o) { - return (magnitude_p_z (o->sc, q_p_func2_call (o))); -} -static s7_pointer -opt_p_p_f_string_to_number (opt_info* o) { - return (string_to_number_p_p (o->sc, q_p_func2_call (o))); -} -static s7_pointer -opt_p_p_s_iterate_unchecked (opt_info* o) { - s7_pointer iter= slot_value (q_arg1 (o).p); - return (iterator_next (iter) (o->sc, iter)); -} -/* string_iterate built-in here if iterator_sequence is a string is about 12% - * faster, but currently we can have an unchecked iterator that changes sequence - * type (via (set! L1 L2) where L1 and L2 are both iterators) - */ +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_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_tv, t_lookup, v_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) +fx_num_eq_ss_any(fx_num_eq_uU, u_lookup, U_lookup) +fx_num_eq_ss_any(fx_num_eq_vU, v_lookup, U_lookup) -static s7_pointer opt_p_pi_ss (opt_info* o); -static s7_pointer opt_p_pi_sf (opt_info* o); -static s7_pointer opt_p_pi_ss_vref_direct (opt_info* o); -static s7_pointer opt_p_pi_ss_fvref_direct (opt_info* o); -static s7_pointer opt_p_pi_ss_ivref_direct (opt_info* o); -static s7_pointer opt_p_pi_ss_fvref_direct_wrapped (opt_info* o); -static s7_pointer opt_p_pi_ss_ivref_direct_wrapped (opt_info* o); - -static s7_pointer -opt_p_p_fvref (opt_info* o) { - return (q_func1 (o).p_p_f ( - o->sc, opt_p_pi_ss_fvref_direct_wrapped (q_func2_arg (o).o1))); -} /* unwrap to fvref is not faster */ -static s7_pointer -opt_p_p_ivref (opt_info* o) { - return (q_func1 (o).p_p_f ( - o->sc, opt_p_pi_ss_ivref_direct_wrapped (q_func2_arg (o).o1))); -} /* unwrap to ivref is not faster */ -static s7_pointer -opt_p_p_vref (opt_info* o) { - return ( - q_func1 (o).p_p_f (o->sc, opt_p_pi_ss_vref_direct (q_func2_arg (o).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 (q_call (o1).fp == opt_p_p_s) { - q_func (opc).p_p_f= q_func1 (o1).p_p_f; - q_arg1 (opc).p = q_arg1 (o1).p; - q_call (opc).fp = opt_p_p_f1; - backup_pc (sc); - return_true (sc, NULL); - } - } - return_false (sc, NULL); -} - -static s7_pointer -opt_p_call_f (opt_info* o) { - return (q_func (o).call (o->sc, set_plist_1 (o->sc, q_p_func1_call (o)))); -} -static s7_pointer -opt_p_call_s (opt_info* o) { - return ( - q_func (o).call (o->sc, set_plist_1 (o->sc, slot_value (q_arg1 (o).p)))); -} -static s7_pointer -opt_p_call_c (opt_info* o) { - return (q_func (o).call (o->sc, set_plist_1 (o->sc, q_arg1 (o).p))); -} - -static bool -p_p_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr) { - s7_p_p_t ppf; - const int32_t start= sc->pc; - const s7_pointer arg1 = cadr (expr); - if (is_t_integer (arg1)) { - const s7_i_i_t iif= s7_i_i_function (s_func); - s7_i_7i_t i7if; - q_arg1 (opc).i= integer (arg1); - if (iif) { - q_func (opc).i_i_f= iif; - q_call (opc).fp = opt_p_i_c; - return_true (sc, expr); - } - i7if= s7_i_7i_function (s_func); - if (i7if) { - q_func (opc).i_7i_f= i7if; - q_call (opc).fp = opt_p_7i_c; - return_true (sc, expr); - } - } - if (is_t_real (arg1)) { - const s7_d_d_t ddf= s7_d_d_function (s_func); - s7_d_7d_t d7df; - q_arg1 (opc).x= real (arg1); - if (ddf) { - q_func (opc).d_d_f= ddf; - q_call (opc).fp = opt_p_d_c; - return_true (sc, expr); - } - d7df= s7_d_7d_function (s_func); - if (d7df) { - q_func (opc).d_7d_f= d7df; - q_call (opc).fp= (d7df == random_d_7d) ? opt_p_7d_c_random : opt_p_7d_c; - return_true (sc, expr); - } - } - ppf= s7_p_p_function (s_func); - if (ppf) { - opt_info* o1; - q_func1 (opc).p_p_f= ppf; /* TODO: func! */ - if ((ppf == symbol_to_string_p_p) && (is_optimized (expr)) && - (fn_proc (expr) == g_symbol_to_string_uncopied)) - q_func1 (opc).p_p_f= symbol_to_string_uncopied_p; - - if (is_symbol (arg1)) { - q_arg1 (opc).p= opt_simple_symbol (sc, arg1); - if (!q_arg1 (opc).p) return_false (sc, expr); - q_call (opc).fp= - (ppf == abs_p_p) - ? opt_p_p_s_abs - : ((ppf == cdr_p_p) - ? opt_p_p_s_cdr - : ((ppf == iterate_p_p) - ? ((is_iterator (slot_value (q_arg1 (opc).p))) - ? opt_p_p_s_iterate_unchecked - : opt_p_p_s_iterate) - : ((ppf == random_p_p) ? opt_p_p_s_random - : opt_p_p_s))); - return_true (sc, expr); - } - if (!is_pair (arg1)) { - if (q_func1 (opc).p_p_f == s7_length) { - q_arg1 (opc).p = s7_length (sc, arg1); - q_call (opc).fp= opt_p_c; - } - else { - q_arg1 (opc).p = arg1; - q_call (opc).fp= opt_p_p_c; /* see p_pip_ssf_combinable */ - } - return_true (sc, expr); - } - o1= sc->opts[sc->pc]; - if (cell_optimize (sc, cdr (expr))) { - if (!p_p_f_combinable (sc, opc)) { - s7_pointer (*fp) (opt_info* o); - if ((ppf == magnitude_p_p) && - ((q_call (o1).fp == opt_p_pi_ss) || - (q_call (o1).fp == opt_p_pi_sf)) && - (q_func (o1).p_pi_f == complex_vector_ref_p_pi)) { - q_func (o1).p_pi_f= complex_vector_ref_p_pi_wrapped; - q_call (opc).fp = opt_p_z_f_magnitude; - } - else - q_call (opc).fp= - (ppf == exp_p_p) - ? opt_p_p_f_exp - : ((ppf == iterate_p_p) ? opt_p_p_f_iterate - : ((ppf == string_to_number_p_p) - ? opt_p_p_f_string_to_number - : opt_p_p_f)); - q_func2_arg (opc).o1= o1; - fp = q_call (o1).fp; - q_func2 (opc).fp = fp; - if (fp == opt_p_pi_ss_fvref_direct) q_call (opc).fp= opt_p_p_fvref; - else if (fp == opt_p_pi_ss_vref_direct) q_call (opc).fp= opt_p_p_vref; - else if (fp == opt_p_pi_ss_ivref_direct) q_call (opc).fp= opt_p_p_ivref; - } - return_true (sc, expr); - } - } - sc->pc= start; - if ((is_safe_procedure (s_func)) && (c_function_is_aritable (s_func, 1))) { - q_func (opc).call= cf_call (sc, expr, s_func, 1); - if (is_symbol (arg1)) { - const s7_pointer slot= opt_simple_symbol (sc, arg1); - if (slot) { - q_arg1 (opc).p = slot; - q_call (opc).fp= opt_p_call_s; - return_true (sc, expr); - } - } - else { - opt_info* o1; - if (!is_pair (arg1)) { - q_arg1 (opc).p = arg1; - q_call (opc).fp= opt_p_call_c; - return_true (sc, expr); - } - o1= sc->opts[sc->pc]; - if (cell_optimize (sc, cdr (expr))) { - q_call (opc).fp = opt_p_call_f; - q_func1_arg (opc).o1= o1; - q_func1 (opc).fp = q_call (o1).fp; - if (q_func1 (opc).fp == opt_p_pi_ss_fvref_direct) - q_func1 (opc).fp= opt_p_pi_ss_fvref_direct_wrapped; - else if (q_func1 (opc).fp == opt_p_pi_ss_ivref_direct) - q_func1 (opc).fp= opt_p_pi_ss_ivref_direct_wrapped; - return_true (sc, expr); - } - } +#define fx_is_eq_ss_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer x = Lookup1(sc, cadr(arg), arg); \ + s7_pointer y = Lookup2(sc, opt1_sym(cdr(arg)), arg); \ + return(make_boolean(sc, (x == y) || ((is_unspecified(x)) && (is_unspecified(y))))); \ } - return_false (sc, expr); + +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 = lookup(sc, opt3_sym(arg)); + s7_pointer y = lookup(sc, opt1_sym(cdr(arg))); + return(make_boolean(sc, (x != y) && ((!is_unspecified(x)) || (!is_unspecified(y))))); } -/* -------- p_i -------- */ -static s7_pointer -opt_p_i_s (opt_info* o) { - return (q_func (o).p_i_f (o->sc, integer (slot_value (q_arg1 (o).p)))); -} /* number_to_string_p_i expanded here doesn't gain much */ -static s7_pointer -opt_p_i_f (opt_info* o) { - return (q_func (o).p_i_f (o->sc, q_i_func1_call (o))); -} -static s7_pointer -opt_p_i_f_intc (opt_info* o) { - return (integer_to_char_p_i (o->sc, q_i_func1_call (o))); -} - -static bool -p_i_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr, int32_t pstart) { - s7_pointer slot; - const s7_p_i_t ifunc= s7_p_i_function (s_func); - if (!ifunc) return_false (sc, expr); - q_func (opc).p_i_f= ifunc; - slot = opt_integer_symbol (sc, cadr (expr)); - if (slot) { - q_arg1 (opc).p = slot; - q_call (opc).fp= opt_p_i_s; - return_true (sc, expr); - } - if (int_optimize (sc, cdr (expr))) { - q_call (opc).fp= - (ifunc == integer_to_char_p_i) ? opt_p_i_f_intc : opt_p_i_f; - q_func1_arg (opc).o1= sc->opts[pstart]; - q_func1 (opc).fi = q_call (sc->opts[pstart]).fi; - return_true (sc, expr); - } - sc->pc= pstart; - return_false (sc, expr); +static s7_pointer fx_not_is_eq_sq(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer x = lookup(sc, opt3_sym(arg)); + s7_pointer y = opt3_con(cdr(arg)); + return(make_boolean(sc, (x != y) && ((!is_unspecified(x)) || (!is_unspecified(y))))); } -/* -------- p_ii -------- */ -static s7_pointer -opt_p_ii_ss (opt_info* o) { - return (q_func (o).p_ii_f (o->sc, integer (slot_value (q_arg1 (o).p)), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_pointer -opt_p_ii_fs (opt_info* o) { - return (q_func (o).p_ii_f (o->sc, q_i_func1_call (o), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_pointer -opt_p_ii_ff_divide (opt_info* o) { - return (make_ratio_with_div_check (o->sc, o->sc->divide_symbol, - q_i_func1_call (o), q_i_func2_call (o))); -} - -static s7_pointer -opt_p_ii_ff (opt_info* o) { - s7_int i1= q_i_func1_call (o); - return (q_func (o).p_ii_f (o->sc, i1, q_i_func2_call (o))); -} - -static bool -p_ii_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr, int32_t pstart) { - s7_pointer arg2_slot; - const s7_p_ii_t ifunc= s7_p_ii_function (s_func); - if (!ifunc) return_false (sc, expr); - arg2_slot= opt_integer_symbol (sc, caddr (expr)); - if (arg2_slot) { - const s7_pointer arg1_slot= opt_integer_symbol (sc, cadr (expr)); - if (arg1_slot) { - q_arg1 (opc).p = arg1_slot; - q_arg2 (opc).p = arg2_slot; - q_func (opc).p_ii_f= ifunc; - q_call (opc).fp = opt_p_ii_ss; - return_true (sc, expr); - } - q_func1_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cdr (expr))) { - q_func1 (opc).fi = q_func1_arg (opc).q_call (o1).fi; - q_arg2 (opc).p = arg2_slot; - q_func (opc).p_ii_f= ifunc; - q_call (opc).fp = opt_p_ii_fs; - return_true (sc, expr); - } - sc->pc= pstart; - return_false (sc, expr); - } - q_func1_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cdr (expr))) { - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cddr (expr))) { - q_func1 (opc).fi = q_func1_arg (opc).q_call (o1).fi; - q_func2 (opc).fi = q_func2_arg (opc).q_call (o1).fi; - q_func (opc).p_ii_f= ifunc; - q_call (opc).fp= - (ifunc == divide_p_ii) ? opt_p_ii_ff_divide : opt_p_ii_ff; - return_true (sc, expr); - } - } - sc->pc= pstart; - return_false (sc, expr); +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))); } -/* -------- p_d -------- */ -static s7_pointer -opt_p_d_s (opt_info* o) { - return (q_func (o).p_d_f ( - o->sc, real_to_double (o->sc, slot_value (q_arg2 (o).p), __func__))); -} -static s7_pointer -opt_p_d_f (opt_info* o) { - return (q_func (o).p_d_f (o->sc, q_d_func1_call (o))); -} - -static bool -p_d_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr, int32_t pstart) { - s7_pointer arg1_slot; - opt_info* o1; - const s7_p_d_t ifunc= s7_p_d_function (s_func); - if (!ifunc) return_false (sc, expr); - arg1_slot= opt_float_symbol (sc, cadr (expr)); - if (arg1_slot) { - q_arg2 (opc).p = arg1_slot; - q_func (opc).p_d_f= ifunc; - q_call (opc).fp = opt_p_d_s; - return_true (sc, expr); - } - if ((is_number (cadr (expr))) && (!is_t_real (cadr (expr)))) - return_false (sc, expr); - o1= sc->opts[sc->pc]; - if (float_optimize (sc, cdr (expr))) { - q_func (opc).p_d_f = ifunc; - q_call (opc).fp = opt_p_d_f; - q_func1_arg (opc).o1= o1; - q_func1 (opc).fd = q_call (o1).fd; - return_true (sc, expr); - } - sc->pc= pstart; - return_false (sc, expr); +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, opt1_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, opt1_sym(cdr(arg)), arg)));} +static s7_pointer fx_hash_table_ref_TV(s7_scheme *sc, s7_pointer arg) {return(x_hash_table_ref_ss(sc, T_lookup(sc, cadr(arg), arg), V_lookup(sc, opt1_sym(cdr(arg)), arg)));} + +static s7_pointer fx_hash_table_ref_car(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer table = lookup(sc, cadr(arg)); + s7_pointer lst = lookup(sc, opt2_sym(cdr(arg))); + if (!is_pair(lst)) + sole_arg_wrong_type_error_nr(sc, sc->car_symbol, lst, sc->type_names[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)))); } -/* -------- p_dd -------- */ -static s7_pointer -opt_p_dd_sc (opt_info* o) { - return (q_func (o).p_dd_f ( - o->sc, real_to_double (o->sc, slot_value (q_arg1 (o).p), __func__), - q_arg2 (o).x)); -} -static s7_pointer -opt_p_dd_cs (opt_info* o) { - return (q_func (o).p_dd_f ( - o->sc, q_arg1 (o).x, - real_to_double (o->sc, slot_value (q_arg2 (o).p), __func__))); -} -static s7_pointer -opt_p_dd_cc (opt_info* o) { - return (q_func (o).p_dd_f (o->sc, q_arg1 (o).x, q_arg2 (o).x)); -} - -static bool -p_dd_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr, int32_t pstart) { - const s7_pointer arg1= cadr (expr), arg2= caddr (expr); - const s7_p_dd_t ifunc= s7_p_dd_function (s_func); - if (!ifunc) return_false (sc, expr); - q_func (opc).p_dd_f= ifunc; - if (is_t_real (arg2)) { - s7_pointer arg1_slot; - q_arg2 (opc).x= real (arg2); - if (is_t_real (arg1)) { - q_arg1 (opc).x = real (arg1); - q_call (opc).fp= opt_p_dd_cc; - return_true (sc, expr); - } - arg1_slot= opt_real_symbol (sc, arg1); - if (arg1_slot) { - q_arg1 (opc).p = arg1_slot; - q_call (opc).fp= opt_p_dd_sc; - return_true (sc, expr); - } - } - if (is_t_real (arg1)) { - s7_pointer arg2_slot; - arg2_slot= opt_real_symbol (sc, arg2); - if (arg2_slot) { - q_arg1 (opc).x = real (arg1); - q_arg2 (opc).p = arg2_slot; - q_call (opc).fp= opt_p_dd_cs; - return_true (sc, expr); + +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)), sc->type_names[T_HASH_TABLE], 1)); + val = (*hash_table_checker(table))(sc, table, key); + if (val != sc->unentry) + { + if (!is_t_integer(hash_entry_value(val))) + sole_arg_wrong_type_error_nr(sc, sc->add_symbol, cadddr(arg), sc->type_names[T_INTEGER]); + hash_entry_set_value(val, make_integer(sc, integer(hash_entry_value(val)) + 1)); + return(hash_entry_value(val)); } - } - sc->pc= pstart; - return_false (sc, expr); + s7_hash_table_set(sc, table, key, int_one); + return(int_one); } -/* -------- p_pi -------- */ -static s7_pointer -opt_p_pi_ss (opt_info* o) { - return (q_func (o).p_pi_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_pointer -opt_p_pi_ss_sref (opt_info* o) { - return (string_ref_p_pi_unchecked (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_pointer -opt_p_pi_ss_sref_direct (opt_info* o) { - return (string_ref_p_pi_direct (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_pointer -opt_p_pi_ss_vref (opt_info* o) { - return (t_vector_ref_p_pi_unchecked (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_pointer -opt_p_pi_ss_vref_direct (opt_info* o) { - return (t_vector_ref_p_pi_direct (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_pointer -opt_p_pi_ss_fvref_direct (opt_info* o) { - return (float_vector_ref_p_pi_direct (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_pointer -opt_p_pi_ss_cvref_direct (opt_info* o) { - return (complex_vector_ref_p_pi_direct (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_pointer -opt_p_pi_ss_ivref_direct (opt_info* o) { - return (int_vector_ref_p_pi_direct (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_pointer -opt_p_pi_ss_fvref_direct_wrapped (opt_info* o) { - return (float_vector_ref_p_pi_direct_wrapped ( - o->sc, slot_value (q_arg1 (o).p), integer (slot_value (q_arg2 (o).p)))); -} -static s7_pointer -opt_p_pi_ss_ivref_direct_wrapped (opt_info* o) { - return (int_vector_ref_p_pi_direct_wrapped ( - o->sc, slot_value (q_arg1 (o).p), integer (slot_value (q_arg2 (o).p)))); -} -static s7_pointer -opt_p_pi_ss_pref (opt_info* o) { - return (list_ref_p_pi_unchecked (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_pointer -opt_p_pi_sc (opt_info* o) { - return (q_func (o).p_pi_f (o->sc, slot_value (q_arg1 (o).p), q_arg2 (o).i)); -} -static s7_pointer -opt_p_pi_sc_pref (opt_info* o) { - return ( - list_ref_p_pi_unchecked (o->sc, slot_value (q_arg1 (o).p), q_arg2 (o).i)); -} -static s7_pointer -opt_p_pi_sf (opt_info* o) { - return ( - q_func (o).p_pi_f (o->sc, slot_value (q_arg1 (o).p), q_i_func1_call (o))); -} -static s7_pointer -opt_p_pi_sf_sref (opt_info* o) { - return (string_ref_p_pi_unchecked (o->sc, slot_value (q_arg1 (o).p), - q_i_func1_call (o))); -} -static s7_pointer -opt_p_pi_sf_sref_direct (opt_info* o) { - return (string_ref_p_pi_direct (o->sc, slot_value (q_arg1 (o).p), - q_i_func1_call (o))); -} -static s7_pointer -opt_p_pi_fc (opt_info* o) { - return (q_func (o).p_pi_f (o->sc, q_p_func1_call (o), q_arg2 (o).i)); -} - -/* use a unique name (in this code) for this use of denominator -- this is a - * kludge -- we don't have anywhere in the slot to store the loop end, but the - * slot_value can be a small_int (or any unheaped integer), so we're assuming - * there aren't collisions? Each use is a single (uncomplicated) do loop, set - * up before each call? - */ -#if S7_DEBUGGING -static s7_pointer -check_loop_end_ref (s7_scheme* sc, s7_pointer p, const char* func, - int32_t line) { - uint8_t typ= type_unchecked (T_Slt (p)); - if (!has_loop_end (p)) - complain (sc, "%s%s[%d]: loop_end not set, %s (%s)%s\n", p, func, line, - typ); - return (T_Int (slot_value (p))); -} -#define loop_end(A) denominator (check_loop_end_ref (sc, A, __func__, __LINE__)) -#else -#define loop_end(A) denominator (T_Int (slot_value (A))) -#endif -#define set_loop_end(A, B) set_denominator (T_Int (slot_value (A)), B) +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 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 (q_func(o).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)) && - (loop_end (slot) <= string_length (obj))) - q_func (opc).p_pi_f= string_ref_p_pi_direct; - break; - case T_BYTE_VECTOR: - if (((!expr) || (car (expr) == sc->byte_vector_ref_symbol) || - (car (expr) == sc->vector_ref_symbol)) && - (loop_end (slot) <= byte_vector_length (obj))) - q_func (opc).p_pi_f= byte_vector_ref_p_pi_direct; - break; - case T_VECTOR: - if (((!expr) || (car (expr) == sc->vector_ref_symbol)) && - (loop_end (slot) <= vector_length (obj))) - q_func (opc).p_pi_f= t_vector_ref_p_pi_direct; - break; - case T_FLOAT_VECTOR: - if (((!expr) || (car (expr) == sc->float_vector_ref_symbol) || - (car (expr) == sc->vector_ref_symbol)) && - (loop_end (slot) <= vector_length (obj))) - q_func (opc).p_pi_f= float_vector_ref_p_pi_direct; - break; - case T_COMPLEX_VECTOR: - if (((!expr) || (car (expr) == sc->complex_vector_ref_symbol) || - (car (expr) == sc->vector_ref_symbol)) && - (loop_end (slot) <= vector_length (obj))) - q_func (opc).p_pi_f= complex_vector_ref_p_pi_direct; - break; - case T_INT_VECTOR: - if (((!expr) || (car (expr) == sc->int_vector_ref_symbol) || - (car (expr) == sc->vector_ref_symbol)) && - (loop_end (slot) <= vector_length (obj))) - q_func (opc).p_pi_f= int_vector_ref_p_pi_direct; - break; - } + +static s7_pointer fx_cdr_let_ref_s(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer sym; + s7_pointer let = s_lookup(sc, opt2_sym(arg), arg); /* (var-ref local-var) -> local-var, opt_sym2(arg) == cadr(arg) */ + if (!is_pair(let)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "~S should be (cons name let), but it is ~S", 42), opt2_sym(arg), let)); + let = cdr(let); + if (!is_let(let)) wrong_type_error_nr(sc, sc->let_ref_symbol, 1, let, a_let_string); + sym = opt2_sym(cdr(arg)); /* (let-ref (cdr v) 'ref) -> ref == opt3_sym(cdar(closure_body(opt1_lambda(arg)))); */ + for (s7_pointer slot = let_slots(let); is_not_slot_end(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == sym) + return(slot_value(slot)); + return(let_ref_p_pp(sc, let_outlet(let), sym)); +} + +static s7_pointer fx_memq_sq_2(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer p = opt1_con(cdr(arg)); + s7_pointer obj = lookup(sc, cadr(arg)); + if (obj == car(p)) return(p); + return((obj == cadr(p)) ? cdr(p) : sc->F); } -static void -fixup_p_pi_ss (opt_info* opc) { - q_call (opc).fp= - (q_func (opc).p_pi_f == string_ref_p_pi_unchecked) - ? opt_p_pi_ss_sref - : ((q_func (opc).p_pi_f == string_ref_p_pi_direct) - ? opt_p_pi_ss_sref_direct - : ((q_func (opc).p_pi_f == t_vector_ref_p_pi_unchecked) - ? opt_p_pi_ss_vref - : ((q_func (opc).p_pi_f == float_vector_ref_p_pi_direct) - ? opt_p_pi_ss_fvref_direct - : ((q_func (opc).p_pi_f == - complex_vector_ref_p_pi_direct) - ? opt_p_pi_ss_cvref_direct - : ((q_func (opc).p_pi_f == - int_vector_ref_p_pi_direct) - ? opt_p_pi_ss_ivref_direct - : ((q_func (opc).p_pi_f == - t_vector_ref_p_pi_direct) - ? opt_p_pi_ss_vref_direct - : ((q_func (opc).p_pi_f == - list_ref_p_pi_unchecked) - ? opt_p_pi_ss_pref - : opt_p_pi_ss))))))); -} - -static bool -p_pi_ok (s7_scheme* sc, opt_info* opc, s7_pointer s_func, s7_pointer sig, - s7_pointer expr) { - s7_pointer obj= NULL, arg1_slot, arg2_slot, checker= NULL; - opt_info* o1; - const s7_p_pi_t func= s7_p_pi_function (s_func); - if (!func) return_false (sc, expr); +static s7_pointer fx_c_cq(s7_scheme *sc, s7_pointer arg) {return(fn_proc(arg)(sc, with_list_t2(sc, cadr(arg), opt2_con(cdr(arg)))));} - /* here we know cadr is a symbol */ - arg1_slot= opt_simple_symbol (sc, cadr (expr)); - if (!arg1_slot) return_false (sc, expr); - if ((is_any_vector (slot_value (arg1_slot))) && - (vector_rank (slot_value (arg1_slot)) > 1)) - return_false (sc, expr); - - q_func (opc).p_pi_f= func; - q_arg1 (opc).p = arg1_slot; - - if (is_symbol (cadr (sig))) checker= cadr (sig); - - obj= slot_value (q_arg1 (opc).p); - if ((s7_p_pi_unchecked_function (s_func)) && (checker)) { - 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))) - q_func (opc).p_pi_f= (is_t_vector (obj)) - ? t_vector_ref_p_pi_unchecked - : s7_p_pi_unchecked_function (s_func); - } +#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)); \ } - arg2_slot= opt_integer_symbol (sc, caddr (expr)); - if (arg2_slot) { - q_arg2 (opc).p= arg2_slot; - if ((obj) && /* this depends above on s7_p_pi_unchecked_function, but none - of the typed vectors have one?? */ - (has_loop_end (arg2_slot))) - check_unchecked (sc, obj, arg2_slot, opc, expr); - fixup_p_pi_ss (opc); - return_true (sc, expr); - } - if (is_t_integer (caddr (expr))) { - q_arg2 (opc).i = integer (caddr (expr)); - q_call (opc).fp= (q_func (opc).p_pi_f == list_ref_p_pi_unchecked) - ? opt_p_pi_sc_pref - : opt_p_pi_sc; - return_true (sc, expr); - } - o1= sc->opts[sc->pc]; - if (int_optimize (sc, cddr (expr))) { - q_call (opc).fp = (q_func (opc).p_pi_f == string_ref_p_pi_unchecked) - ? opt_p_pi_sf_sref - : ((q_func (opc).p_pi_f == string_ref_p_pi_direct) - ? opt_p_pi_sf_sref_direct - : opt_p_pi_sf); - q_func1_arg (opc).o1= o1; - q_func1 (opc).fi = q_call (o1).fi; - return_true (sc, expr); - } - return_false (sc, expr); + +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 -opt_p_pi_fco (opt_info* o) { - return (q_func (o).p_pi_f ( - o->sc, q_func1 (o).p_p_f (o->sc, slot_value (q_arg1 (o).p)), - q_arg2 (o).i)); +static s7_pointer fx_c_tuv_direct(s7_scheme *sc, s7_pointer arg) +{ + return(((s7_p_ppp_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, opt1_sym(cdr(arg)), arg), v_lookup(sc, opt2_sym(cdr(arg)), arg))); } -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 (q_call (o1).fp == opt_p_p_s) { - q_func1 (opc).p_p_f= q_func1 (o1).p_p_f; - q_arg1 (opc).p = q_arg1 (o1).p; - q_call (opc).fp = opt_p_pi_fco; - backup_pc (sc); - return_true (sc, NULL); - } - } - return_false (sc, NULL); +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))))); } -/* -------- p_pp -------- */ -static s7_pointer -opt_p_pp_ss (opt_info* o) { - return (q_func (o).p_pp_f (o->sc, slot_value (q_arg1 (o).p), - slot_value (q_arg2 (o).p))); -} -static s7_pointer -opt_p_pp_sc (opt_info* o) { - return (q_func (o).p_pp_f (o->sc, slot_value (q_arg1 (o).p), q_arg2 (o).p)); -} -static s7_pointer -opt_p_pp_slot_ref (opt_info* o) { - return (slot_value (q_arg1 (o).p)); -} /* not in s7test timp (set! sum (+ sum (* i (L2 'a)))) */ -static s7_pointer -opt_p_pp_cs (opt_info* o) { - return (q_func (o).p_pp_f (o->sc, q_arg1 (o).p, slot_value (q_arg2 (o).p))); -} -static s7_pointer -opt_p_pp_sf (opt_info* o) { - return ( - q_func (o).p_pp_f (o->sc, slot_value (q_arg1 (o).p), q_p_func1_call (o))); -} -static s7_pointer -opt_p_pp_fs (opt_info* o) { - return ( - q_func (o).p_pp_f (o->sc, q_p_func1_call (o), slot_value (q_arg1 (o).p))); -} -static s7_pointer -opt_p_pp_fc (opt_info* o) { - return (q_func (o).p_pp_f (o->sc, q_p_func1_call (o), q_arg2 (o).p)); -} -static s7_pointer -opt_p_pp_cc (opt_info* o) { - return (q_func (o).p_pp_f (o->sc, q_arg1 (o).p, q_arg2 (o).p)); -} -static s7_pointer -opt_p_pp_cc_make_list (opt_info* o) { - return (make_list (o->sc, q_arg1 (o).i, q_arg2 (o).p)); -} -static s7_pointer -opt_set_car_pp_ss (opt_info* o) { - return (inline_set_car (o->sc, slot_value (q_arg1 (o).p), - slot_value (q_arg2 (o).p))); -} -static s7_pointer -opt_p_pp_ss_href (opt_info* o) { - return (s7_hash_table_ref (o->sc, slot_value (q_arg1 (o).p), - slot_value (q_arg2 (o).p))); -} -static s7_pointer -opt_p_pp_sf_add (opt_info* o) { - return (add_p_pp (o->sc, slot_value (q_arg1 (o).p), q_p_func1_call (o))); -} -static s7_pointer -opt_p_pp_sf_sub (opt_info* o) { - return (subtract_p_pp (o->sc, slot_value (q_arg1 (o).p), q_p_func1_call (o))); -} -static s7_pointer -opt_p_pp_sf_mul (opt_info* o) { - return (multiply_p_pp (o->sc, slot_value (q_arg1 (o).p), q_p_func1_call (o))); -} -static s7_pointer -opt_p_pp_sf_set_car (opt_info* o) { - return ( - inline_set_car (o->sc, slot_value (q_arg1 (o).p), q_p_func1_call (o))); -} -static s7_pointer -opt_p_pp_sf_set_cdr (opt_info* o) { - return ( - inline_set_cdr (o->sc, slot_value (q_arg1 (o).p), q_p_func1_call (o))); -} -static s7_pointer -opt_p_pp_sf_href (opt_info* o) { - return ( - s7_hash_table_ref (o->sc, slot_value (q_arg1 (o).p), q_p_func1_call (o))); -} -static s7_pointer -opt_p_pp_fs_vref (opt_info* o) { - return (s7i_vector_ref_p_pp (o->sc, q_p_func1_call (o), - slot_value (q_arg1 (o).p))); -} -static s7_pointer -opt_p_pp_fs_cons (opt_info* o) { - return (cons (o->sc, q_p_func1_call (o), slot_value (q_arg1 (o).p))); -} -static s7_pointer -opt_p_pp_fs_add (opt_info* o) { - return (add_p_pp (o->sc, q_p_func1_call (o), slot_value (q_arg1 (o).p))); -} -static s7_pointer -opt_p_pp_fs_sub (opt_info* o) { - return (subtract_p_pp (o->sc, q_p_func1_call (o), slot_value (q_arg1 (o).p))); -} - -static s7_pointer -opt_p_pp_ss_lref (opt_info* o) { - s7_pointer sym= slot_value (q_arg2 (o).p); - if (is_symbol (sym)) - return (let_ref_p_pp (o->sc, slot_value (q_arg1 (o).p), - (is_keyword (sym)) ? keyword_symbol (sym) : sym)); - return (let_ref (o->sc, slot_value (q_arg1 (o).p), sym)); -} - -static s7_pointer -opt_p_pp_sf_lref (opt_info* o) { - s7_pointer sym= q_p_func1_call (o); - if (is_symbol (sym)) - return (let_ref_p_pp (o->sc, slot_value (q_arg1 (o).p), - (is_keyword (sym)) ? keyword_symbol (sym) : sym)); - return (let_ref (o->sc, slot_value (q_arg1 (o).p), sym)); -} - -static s7_pointer -opt_p_pp_ff (opt_info* o) { - s7_scheme* sc= o->sc; - s7_pointer result; - gc_protect_2_via_stack_no_let ( - sc, q_p_func2_call (o), - q_p_func3_call (o)); /* we do need to protect both */ - result= q_func (o).p_pp_f (sc, gc_protected1 (sc), gc_protected2 (sc)); - unstack_gc_protect (sc); - return (result); -} - -static s7_pointer -opt_p_pp_ff_add_mul_mul_1 (opt_info* o, - bool add_case) /* (+|- (* x1 x2) (* x3 x4)) */ -{ - opt_info * o1= q_func2_arg (o).o1, *o2= q_func3_arg (o).o1; - s7_pointer x4; - s7_scheme* sc= o->sc; - const s7_pointer x1= slot_value (q_arg1 (o1).p); - s7_pointer x3= slot_value (q_arg1 (o2).p); - const s7_pointer x2= q_func1 (o1).fp (q_func1_arg (o1).o1); - if ((is_t_real (x2)) && (is_t_real (x1)) && (is_t_real (x3))) { - s7_double r2= real (x2); - x4 = q_func1 (o2).fp (q_func1_arg (o2).o1); - if (is_t_real (x4)) - return (make_real ( - sc, (add_case) ? ((real (x1) * r2) + (real (x3) * real (x4))) - : ((real (x1) * r2) - (real (x3) * real (x4))))); - gc_protect_via_stack_no_let (sc, x2); - } - else { - gc_protect_via_stack_no_let (sc, x2); - x4= q_func1 (o2).fp (q_func1_arg (o2).o1); +#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)); \ } - set_gc_protected2 (sc, x4); - set_gc_protected2 (sc, multiply_p_pp_wrapped (sc, x3, x4)); - set_gc_protected1 (sc, multiply_p_pp_wrapped (sc, x1, x2)); - x3= (add_case) ? add_p_pp (sc, gc_protected1 (sc), gc_protected2 (sc)) - : subtract_p_pp (sc, gc_protected1 (sc), gc_protected2 (sc)); - unstack_gc_protect (sc); - return (x3); -} - -static s7_pointer -opt_p_pp_ff_add_mul_mul (opt_info* o) { - return (opt_p_pp_ff_add_mul_mul_1 (o, true)); -} -static s7_pointer -opt_p_pp_ff_sub_mul_mul (opt_info* o) { - return (opt_p_pp_ff_add_mul_mul_1 (o, false)); -} - -static void -check_opc_vector_wraps (opt_info* opc) { - if (q_func3 (opc).fp == opt_p_pi_ss_ivref_direct) - q_func3 (opc).fp= opt_p_pi_ss_ivref_direct_wrapped; - if (q_func3 (opc).fp == opt_p_pi_ss_fvref_direct) - q_func3 (opc).fp= opt_p_pi_ss_fvref_direct_wrapped; - if (q_func2 (opc).fp == opt_p_pi_ss_ivref_direct) - q_func2 (opc).fp= opt_p_pi_ss_ivref_direct_wrapped; - if (q_func2 (opc).fp == opt_p_pi_ss_fvref_direct) - q_func2 (opc).fp= opt_p_pi_ss_fvref_direct_wrapped; -} - -static void -use_slot_ref (s7_scheme* sc, opt_info* opc, s7_pointer let, s7_pointer symbol) { - s7_pointer slot= symbol_to_local_slot (sc, symbol, T_Let (let)); - if (is_slot (slot)) { - q_arg1 (opc).p = slot; - q_call (opc).fp= opt_p_pp_slot_ref; + +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)); } -static s7_pointer -opt_p_unlet_ref (opt_info* o) { - return (q_arg1 (o).p); +#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 -opt_p_rootlet_ref (opt_info* o) { - return (global_value (q_arg1 (o).p)); + +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)); } -static bool -opt_unlet_rootlet_ref (s7_scheme* sc, opt_info* opc, s7_pointer arg1, - s7_pointer sym, s7_pointer expr) { - if (car (arg1) == sc->rootlet_symbol) { - if (!is_slot (global_slot (sym))) { - q_call (opc).fp= opt_p_c; - q_arg1 (opc).p = sc->undefined; - return_true (sc, expr); - } +#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)); \ } - q_call (opc).fp= - (car (arg1) == sc->rootlet_symbol) ? opt_p_rootlet_ref : opt_p_unlet_ref; - q_arg1 (opc).p= (car (arg1) == sc->unlet_symbol) ? initial_value (sym) : sym; - return_true (sc, expr); -} - -static bool -p_pp_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr, int32_t pstart) { - const s7_pointer arg1= cadr (expr), arg2= caddr (expr); - const s7_p_pp_t func= s7_p_pp_function (s_func); - if (!func) return_false (sc, expr); - q_func (opc).p_pp_f= func; - if (is_symbol (arg1)) { - s7_pointer obj; - const s7_pointer arg1_slot= opt_simple_symbol (sc, arg1); - if (!arg1_slot) { - sc->pc= pstart; - return_false (sc, expr); - } - obj= slot_value (arg1_slot); - if ((is_any_vector (obj)) && (vector_rank (obj) > 1)) { - sc->pc= pstart; - return_false (sc, expr); - } - q_arg1 (opc).p= arg1_slot; - - if ((func == hash_table_ref_p_pp) && (is_hash_table (obj))) - q_func (opc).p_pp_f= s7_hash_table_ref; - - if (is_symbol (arg2)) { - q_arg2 (opc).p= opt_simple_symbol (sc, arg2); - if (q_arg2 (opc).p) { - q_call (opc).fp= - (func == set_car_p_pp) - ? opt_set_car_pp_ss - : (((is_hash_table (obj)) && (func == hash_table_ref_p_pp)) - ? opt_p_pp_ss_href - : (((is_let (obj)) && (func == let_ref)) - ? opt_p_pp_ss_lref - : opt_p_pp_ss)); - - /* if ss = s+k use slot_ref */ - if ((q_call (opc).fp == opt_p_pp_ss_lref) && (is_keyword (arg2))) - use_slot_ref (sc, opc, obj, keyword_symbol (arg2)); - - return_true (sc, expr); - } - sc->pc= pstart; - return_false (sc, expr); - } - if ((!is_pair (arg2)) || (is_proper_quote (sc, arg2))) { - q_arg2 (opc).p = (!is_pair (arg2)) ? arg2 : cadr (arg2); - q_call (opc).fp= opt_p_pp_sc; - if ((is_pair (arg2)) && (is_symbol (q_arg2 (opc).p)) && (is_let (obj)) && - (q_func (opc).p_pp_f == let_ref)) - use_slot_ref (sc, opc, obj, - cadr (arg2)); /* expr: (let-ref L 'a), can't be keyword - here (handled above) */ - return_true (sc, expr); - } - if (cell_optimize (sc, cddr (expr))) { - q_call (opc).fp= - (func == add_p_pp) - ? opt_p_pp_sf_add - : ((func == subtract_p_pp) - ? opt_p_pp_sf_sub - : ((func == multiply_p_pp) - ? opt_p_pp_sf_mul - : ((func == set_car_p_pp) - ? opt_p_pp_sf_set_car - : ((func == set_cdr_p_pp) - ? opt_p_pp_sf_set_cdr - : (((is_hash_table (obj)) && - (q_func (opc).p_pp_f == - s7_hash_table_ref)) - ? opt_p_pp_sf_href - : (((is_let (obj)) && - (q_func (opc).p_pp_f == - let_ref)) - ? opt_p_pp_sf_lref - : opt_p_pp_sf)))))); - q_func1_arg (opc).o1= sc->opts[pstart]; - q_func1 (opc).fp = q_call (sc->opts[pstart]).fp; - if (q_func1 (opc).fp == opt_p_pi_ss_ivref_direct) - q_func1 (opc).fp= opt_p_pi_ss_ivref_direct_wrapped; - return_true (sc, expr); - } - } - else /* cadr not a symbol */ - { - opt_info* o1= sc->opts[sc->pc]; - if ((!is_pair (arg1)) || (is_proper_quote (sc, arg1))) { - q_arg1 (opc).p= (!is_pair (arg1)) ? arg1 : cadr (arg1); - if ((!is_symbol (arg2)) && - ((!is_pair (arg2)) || (is_proper_quote (sc, arg2)))) { - q_arg2 (opc).p= (!is_pair (arg2)) ? arg2 : cadr (arg2); - if ((q_func (opc).p_pp_f == make_list_p_pp) && - (is_t_integer (q_arg1 (opc).p)) && - (integer (q_arg1 (opc).p) >= 0) && - (integer (q_arg1 (opc).p) < sc->max_list_length)) { - q_call (opc).fp= opt_p_pp_cc_make_list; - q_arg1 (opc).i = integer (q_arg1 (opc).p); - } - else q_call (opc).fp= opt_p_pp_cc; - return_true (sc, expr); - } - if (is_symbol (arg2)) { - q_arg2 (opc).p= opt_simple_symbol (sc, arg2); - if (q_arg2 (opc).p) { - q_call (opc).fp= opt_p_pp_cs; - if (is_pair (slot_value (q_arg2 (opc).p))) { - if (func == assq_p_pp) q_func (opc).p_pp_f= s7_assq; - else if (func == memq_p_pp) q_func (opc).p_pp_f= s7_memq; - else if ((func == member_p_pp) && (is_simple (q_arg1 (opc).p))) - q_func (opc).p_pp_f= s7_memq; - else if (func == assoc_p_pp) { - if (is_simple (q_arg1 (opc).p)) q_func (opc).p_pp_f= s7_assq; - else if (is_pair (car (slot_value (q_arg2 (opc).p)))) - q_func (opc).p_pp_f= assoc_1; - } - } - return_true (sc, expr); - } - sc->pc= pstart; - return_false (sc, expr); - } - } - if ((car (expr) == sc->let_ref_symbol) && (is_pair (arg1)) && - ((is_symbol_and_keyword (arg2)) || ((is_quoted_symbol (sc, arg2)))) && - ((car (arg1) == sc->unlet_symbol) || - (car (arg1) == sc->rootlet_symbol) || - (car (arg1) == sc->curlet_symbol))) - return (opt_unlet_rootlet_ref ( - sc, opc, arg1, (is_pair (arg2)) ? cadr (arg2) : keyword_symbol (arg2), - expr)); - - if (cell_optimize (sc, cdr (expr))) { - if (is_symbol (arg2)) { - q_arg1 (opc).p= opt_simple_symbol (sc, arg2); - if (q_arg1 (opc).p) { - q_call (opc).fp= - (func == add_p_pp) - ? opt_p_pp_fs_add - : ((func == subtract_p_pp) - ? opt_p_pp_fs_sub - : ((func == s7i_vector_ref_p_pp) - ? opt_p_pp_fs_vref - : ((func == cons_p_pp) ? opt_p_pp_fs_cons - : opt_p_pp_fs))); - q_func1_arg (opc).o1= o1; - q_func1 (opc).fp = q_call (o1).fp; - if (q_func1 (opc).fp == opt_p_p_s_random) - q_func1 (opc).fp= opt_p_p_s_random_wrapped; - return_true (sc, expr); - } - sc->pc= pstart; - return_false (sc, expr); - } - if ((!is_pair (arg2)) || (is_proper_quote (sc, arg2))) { - if (is_t_integer (arg2)) { - const s7_p_pi_t ifunc= s7_p_pi_function (s_func); - if (ifunc) { - q_arg2 (opc).i = integer (arg2); - q_func (opc).p_pi_f= ifunc; - if (!p_pi_fc_combinable (sc, opc)) { - q_call (opc).fp = opt_p_pi_fc; - q_func1_arg (opc).o1= o1; - q_func1 (opc).fp = q_call (o1).fp; - } - return_true (sc, expr); - } - } - q_arg2 (opc).p = (!is_pair (arg2)) ? arg2 : cadr (arg2); - q_call (opc).fp = opt_p_pp_fc; - q_func1_arg (opc).o1= o1; - q_func1 (opc).fp = q_call (o1).fp; - return_true (sc, expr); - } - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (cell_optimize (sc, cddr (expr))) { - q_func2_arg (opc).o1= o1; - q_func2 (opc).fp = q_call (o1).fp; - q_func3 (opc).fp = q_func3_arg (opc).q_call (o1).fp; - q_call (opc).fp = opt_p_pp_ff; - if ((q_func3 (opc).fp == opt_p_pp_sf_mul) && - (q_func2 (opc).fp == opt_p_pp_sf_mul)) { - if (func == add_p_pp) q_call (opc).fp= opt_p_pp_ff_add_mul_mul; - else if (func == subtract_p_pp) - q_call (opc).fp= opt_p_pp_ff_sub_mul_mul; - } - check_opc_vector_wraps (opc); - return_true (sc, expr); - } - } - } - sc->pc= pstart; - return_false (sc, expr); +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) +{ + return(fn_proc(arg)(sc, with_list_t1(sc, fn_call(sc, cadr(arg))))); } -/* -------- p_call_pp -------- */ -static s7_pointer -opt_p_call_ff (opt_info* o) { - s7_pointer po2; - s7_scheme* sc= o->sc; - gc_protect_via_stack_no_let (sc, q_p_func1_call (o)); - po2= q_p_func2_call (o); - po2= q_func (o).call (sc, set_plist_2 (sc, gc_protected1 (sc), po2)); - unstack_gc_protect (sc); - return (po2); -} - -static s7_pointer -opt_p_call_fs (opt_info* o) { - s7_pointer po1= q_p_func1_call (o); - return (q_func (o).call ( - o->sc, set_plist_2 (o->sc, po1, slot_value (q_arg1 (o).p)))); -} - -static s7_pointer -opt_p_call_sf (opt_info* o) { - s7_pointer po1= q_p_func1_call (o); - return (q_func (o).call ( - o->sc, set_plist_2 (o->sc, slot_value (q_arg1 (o).p), po1))); -} - -static s7_pointer -opt_p_call_fc (opt_info* o) { - s7_pointer po1= q_p_func1_call (o); - return (q_func (o).call (o->sc, set_plist_2 (o->sc, po1, q_arg2 (o).p))); -} - -static s7_pointer -opt_p_call_cc (opt_info* o) { - return ( - q_func (o).call (o->sc, set_plist_2 (o->sc, q_arg1 (o).p, q_arg2 (o).p))); -} -static s7_pointer -opt_p_call_sc (opt_info* o) { - return (q_func (o).call ( - o->sc, set_plist_2 (o->sc, slot_value (q_arg1 (o).p), q_arg2 (o).p))); -} -static s7_pointer -opt_p_call_ss (opt_info* o) { - return (q_func (o).call (o->sc, set_plist_2 (o->sc, slot_value (q_arg1 (o).p), - slot_value (q_arg2 (o).p)))); -} - -static void -check_opc_vector_wraps_1 (opt_info* opc) { - if (q_func1 (opc).fp == opt_p_pi_ss_ivref_direct) - q_func1 (opc).fp= opt_p_pi_ss_ivref_direct_wrapped; - if (q_func1 (opc).fp == opt_p_pi_ss_fvref_direct) - q_func1 (opc).fp= opt_p_pi_ss_fvref_direct_wrapped; - if (q_func2 (opc).fp == opt_p_pi_ss_ivref_direct) - q_func2 (opc).fp= opt_p_pi_ss_ivref_direct_wrapped; - if (q_func2 (opc).fp == opt_p_pi_ss_fvref_direct) - q_func2 (opc).fp= opt_p_pi_ss_fvref_direct_wrapped; -} - -static bool -p_call_pp_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr, int32_t pstart) { - if ((is_safe_procedure (s_func)) && (c_function_is_aritable (s_func, 2))) { - const s7_pointer arg1= cadr (expr), arg2= caddr (expr); - q_func (opc).call= cf_call (sc, expr, s_func, 2); - if ((is_code_constant (sc, arg1)) && (is_code_constant (sc, arg2))) { - q_call (opc).fp= opt_p_call_cc; - q_arg1 (opc).p = (is_pair (arg1)) ? cadr (arg1) : arg1; - q_arg2 (opc).p = (is_pair (arg2)) ? cadr (arg2) : arg2; - return_true (sc, expr); - } - if (is_symbol (arg1)) { - q_arg1 (opc).p= s7_slot (sc, arg1); /* can be # */ - if ((is_slot (q_arg1 (opc).p)) && - (!has_methods (slot_value (q_arg1 (opc).p)))) { - if (is_symbol (arg2)) { - q_arg2 (opc).p= opt_simple_symbol (sc, arg2); - if (q_arg2 (opc).p) { - q_call (opc).fp= opt_p_call_ss; - return_true (sc, expr); - } - sc->pc= pstart; - return_false (sc, expr); - } - if (!is_pair (arg2)) { - q_arg2 (opc).p = arg2; - q_call (opc).fp= opt_p_call_sc; - return_true (sc, expr); - } - if (cell_optimize (sc, cddr (expr))) { - q_func1_arg (opc).o1= sc->opts[pstart]; - q_func1 (opc).fp = q_func1_arg (opc).q_call (o1).fp; - q_call (opc).fp = opt_p_call_sf; - return_true (sc, expr); - } - } - else { - sc->pc= pstart; - return_false (sc, expr); - } - } - q_func1_arg (opc).o1= sc->opts[sc->pc]; - if (cell_optimize (sc, cdr (expr))) { - q_func1 (opc).fp= q_func1_arg (opc).q_call (o1).fp; - if (is_symbol (arg2)) { - q_arg1 (opc).p= opt_simple_symbol (sc, arg2); - if (q_arg1 (opc).p) { - q_call (opc).fp= opt_p_call_fs; - return_true (sc, expr); - } - sc->pc= pstart; - return_false (sc, expr); - } - if ((!is_pair (arg2)) || - (is_proper_quote ( - sc, arg2))) /* (char-ciopts[sc->pc]; - if (cell_optimize (sc, cddr (expr))) { - q_func2 (opc).fp= q_func2_arg (opc).q_call (o1).fp; - q_call (opc).fp = opt_p_call_ff; - check_opc_vector_wraps_1 (opc); - return_true (sc, expr); - } - } +#define fx_c_opsq_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer arg1 = cadr(arg); \ + set_car(sc->t1_1, fn_proc(arg1)(sc, with_list_t1(sc, Lookup(sc, cadr(arg1), arg1)))); \ + return(fn_proc(arg)(sc, sc->t1_1)); \ } - sc->pc= pstart; - return_false (sc, expr); -} -/* -------- p_pip --------*/ +fx_c_opsq_any(fx_c_opsq, s_lookup) +fx_c_opsq_any(fx_c_optq, t_lookup) -static s7_pointer -opt_p_pip_ssf (opt_info* o) { - return (q_func (o).p_pip_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - q_p_func1_call (o))); -} - -static s7_pointer -opt_p_pip_ssf_sset (opt_info* o) { - return (string_set_p_pip_direct (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - q_p_func1_call (o))); -} - -static s7_pointer -opt_p_pip_ssf_vset (opt_info* o) { - return (vector_set_p_pip_unchecked (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - q_p_func1_call (o))); -} - -static s7_pointer -opt_p_pip_sss (opt_info* o) { - return (q_func (o).p_pip_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - slot_value (q_arg3 (o).p))); -} - -static s7_pointer -opt_p_pip_sss_vset (opt_info* o) { - return (vector_set_p_pip_unchecked (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - slot_value (q_arg3 (o).p))); -} - -static s7_pointer -opt_p_pip_ssc (opt_info* o) { - return (q_func (o).p_pip_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - q_arg3 (o).p)); -} - -static s7_pointer -opt_p_pip_sff (opt_info* o) { - s7_int i1= q_i_func2_call (o); - return (q_func (o).p_pip_f (o->sc, slot_value (q_arg1 (o).p), i1, - q_p_func3_call (o))); -} - -static s7_pointer -opt_p_pip_sff_lset (opt_info* o) { - s7_int i1= q_i_func2_call (o); - return (list_set_p_pip_unchecked (o->sc, slot_value (q_arg1 (o).p), i1, - q_p_func3_call (o))); -} - -static s7_pointer -opt_p_pip_sso (opt_info* o) { - return (q_func (o).p_pip_f ( - o->sc, slot_value (q_arg1 (o).p), integer (slot_value (q_arg2 (o).p)), - q_func3 (o).p_pi_f (o->sc, slot_value (q_arg3 (o).p), - integer (slot_value (q_arg4 (o).p))))); -} - -static s7_pointer -opt_p_pip_ssf1 (opt_info* o) { - return (q_func (o).p_pip_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - q_func1 (o).p_p_f (o->sc, q_p_func2_call (o)))); -} - -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 ((q_call (o1).fp == opt_p_pi_ss) || - (q_call (o1).fp == opt_p_pi_ss_sref) || - (q_call (o1).fp == opt_p_pi_ss_vref) || - (q_call (o1).fp == opt_p_pi_ss_sref_direct) || - (q_call (o1).fp == opt_p_pi_ss_vref_direct) || - (q_call (o1).fp == opt_p_pi_ss_fvref_direct) || - (q_call (o1).fp == opt_p_pi_ss_ivref_direct) || - (q_call (o1).fp == opt_p_pi_ss_pref)) { - q_func (opc).p_pip_f= q_func (opc).p_pip_f; - q_func3 (opc).p_pi_f= q_func (o1).p_pi_f; - q_arg3 (opc).p = q_arg1 (o1).p; - q_arg4 (opc).p = q_arg2 (o1).p; - q_call (opc).fp = opt_p_pip_sso; - backup_pc (sc); - return_true (sc, NULL); - } - } - o1= sc->opts[start]; - if (q_call (o1).fp != opt_p_p_f) return_false (sc, NULL); - q_func1 (opc).p_p_f = q_func1 (o1).p_p_f; - q_func2_arg (opc).o1= sc->opts[start + 1]; - q_func2 (opc).fp = q_call (sc->opts[start + 1]).fp; - q_call (opc).fp = opt_p_pip_ssf1; - return_true (sc, NULL); -} - -static bool -p_pip_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr) { - s7_pointer obj, arg1_slot, obj1, sig, checker= NULL, val_type; - const s7_p_pip_t func= s7_p_pip_function (s_func); - if (!func) return_false (sc, expr); - sig= c_function_signature (s_func); - if ((is_pair (sig)) && (is_pair (cdr (sig))) && (is_symbol (cadr (sig)))) - checker= cadr (sig); +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)))); +} - /* here we know cadr is a symbol */ - arg1_slot= s7_slot (sc, cadr (expr)); - if (!is_slot (arg1_slot)) return_false (sc, expr); - obj1= slot_value (arg1_slot); - if ((has_methods (obj1)) || (is_immutable (obj1))) return_false (sc, expr); - if ((is_any_vector (obj1)) && (vector_rank (obj1) > 1)) - return_false (sc, expr); - val_type = opt_arg_type (sc, cdddr (expr)); - q_arg1 (opc).p = arg1_slot; - obj = slot_value (q_arg1 (opc).p); - q_func (opc).p_pip_f= func; - if ((s7_p_pip_unchecked_function (s_func)) && (checker)) { - if ((is_t_vector (obj)) && (checker == sc->is_vector_symbol)) - q_func (opc).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? */ - q_func (opc).p_pip_f= s7_p_pip_unchecked_function (s_func); - else 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)))) - q_func (opc).p_pip_f= s7_p_pip_unchecked_function (s_func); +#define fx_c_car_s_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer val = Lookup(sc, opt3_sym(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)); \ } - if (is_symbol (caddr (expr))) { - const int32_t start = sc->pc; - const s7_pointer arg3 = cadddr (expr); /* see val_type above */ - const s7_pointer arg2_slot= opt_integer_symbol (sc, caddr (expr)); - if (arg2_slot) { - q_arg2 (opc).p= arg2_slot; - if (has_loop_end (arg2_slot)) switch (type (obj)) { - case T_VECTOR: - if (loop_end (arg2_slot) <= vector_length (obj)) - q_func (opc).p_pip_f= (is_typed_vector (obj)) - ? typed_t_vector_set_p_pip_direct - : t_vector_set_p_pip_direct; - break; - case T_BYTE_VECTOR: - if ((val_type != sc->is_integer_symbol) && - (val_type != sc->is_byte_symbol)) - return_false (sc, expr); - if (loop_end (arg2_slot) <= vector_length (obj)) - q_func (opc).p_pip_f= byte_vector_set_p_pip_direct; - break; - case T_INT_VECTOR: - if ((val_type != sc->is_integer_symbol) && - (val_type != sc->is_byte_symbol)) - return_false (sc, expr); - if (loop_end (arg2_slot) <= vector_length (obj)) - q_func (opc).p_pip_f= int_vector_set_p_pip_direct; - break; - case T_FLOAT_VECTOR: - if ((val_type != sc->is_float_symbol) && - (val_type != sc->is_real_symbol)) - return_false (sc, expr); - if (loop_end (arg2_slot) <= vector_length (obj)) - q_func (opc).p_pip_f= float_vector_set_p_pip_direct; - break; - case T_COMPLEX_VECTOR: - if ((val_type != sc->is_complex_symbol) && - (val_type != sc->is_real_symbol)) - return_false (sc, expr); - if (loop_end (arg2_slot) <= vector_length (obj)) - q_func (opc).p_pip_f= complex_vector_set_p_pip_direct; - break; - case T_STRING: - if (loop_end (arg2_slot) <= string_length (obj)) - q_func (opc).p_pip_f= string_set_p_pip_direct; - break; - } /* T_PAIR here would require list_length check which sort of defeats - the purpose */ - - if (is_symbol (arg3)) { - s7_pointer val_slot= opt_simple_symbol (sc, arg3); - /* for int|byte|float-vector and string need opt_arg_type check?? see - * val_type above, if vector-set! but have int-vector sig is wrong */ - if (val_slot) { - q_arg3 (opc).p = val_slot; - q_call (opc).fp= (q_func (opc).p_pip_f == vector_set_p_pip_unchecked) - ? opt_p_pip_sss_vset - : opt_p_pip_sss; - return_true (sc, expr); - } - } - else if ((!is_pair (arg3)) || (is_proper_quote (sc, arg3))) { - q_arg3 (opc).p = (is_pair (arg3)) ? cadr (arg3) : arg3; - q_call (opc).fp= opt_p_pip_ssc; - return_true (sc, expr); - } - if (cell_optimize (sc, cdddr (expr))) { - if (p_pip_ssf_combinable (sc, opc, start)) return_true (sc, expr); - q_call (opc).fp= - (q_func (opc).p_pip_f == string_set_p_pip_direct) - ? opt_p_pip_ssf_sset - : ((q_func (opc).p_pip_f == vector_set_p_pip_unchecked) - ? opt_p_pip_ssf_vset - : opt_p_pip_ssf); - q_func1_arg (opc).o1= sc->opts[start]; - q_func1 (opc).fp = q_call (sc->opts[start]).fp; - return_true (sc, expr); - } - } + +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 = Lookup(sc, opt3_sym(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)); \ } - else /* not symbol caddr */ - { - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cddr (expr))) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (cell_optimize (sc, cdddr (expr))) { - q_call (opc).fp = (q_func (opc).p_pip_f == list_set_p_pip_unchecked) - ? opt_p_pip_sff_lset - : opt_p_pip_sff; - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_func3 (opc).fp= q_func3_arg (opc).q_call (o1).fp; - return_true (sc, expr); - } - } + +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, opt3_sym(arg), arg)); \ + return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(fn_proc(cadr(arg))(sc, sc->t1_1)))); \ } - return_false (sc, expr); -} -/* -------- p_piip -------- */ +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 -opt_p_piip_sssf (opt_info* o) { - return (q_func (o).p_piip_f ( - o->sc, slot_value (q_arg1 (o).p), integer (slot_value (q_arg2 (o).p)), - integer (slot_value (q_arg3 (o).p)), q_p_func2_call (o))); +static s7_pointer fx_is_type_car_s(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer val = lookup(sc, opt3_sym(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 -vector_set_piip_sssf_unchecked (opt_info* o) { - s7_pointer vec= slot_value (q_arg1 (o).p); - s7_pointer val= q_p_func2_call (o); - vector_element ( - vec, ((integer (slot_value (q_arg2 (o).p)) * vector_offset (vec, 0)) + - integer (slot_value (q_arg3 (o).p))))= val; - return (val); +static s7_pointer fx_is_type_car_t(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer func; + const s7_pointer val = t_lookup(sc, opt3_sym(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!) */ + wrong_type_error_nr(sc, sc->car_symbol, 1, val, sc->type_names[T_PAIR]); + func = find_method_with_let(sc, val, sc->car_symbol); + if (func == sc->undefined) + wrong_type_error_nr(sc, sc->car_symbol, 1, val, sc->type_names[T_PAIR]); + return(make_boolean(sc, type(s7_apply_function(sc, func, set_plist_1(sc, val))) == (uint8_t)opt3_byte(cdr(arg)))); } -static s7_pointer -opt_p_piip_sssc (opt_info* o) { - return (q_func (o).p_piip_f ( - o->sc, slot_value (q_arg1 (o).p), integer (slot_value (q_arg2 (o).p)), - integer (slot_value (q_arg3 (o).p)), q_arg4 (o).p)); +static s7_pointer fx_eq_weak1_type_s(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer func; + const s7_pointer val = lookup(sc, opt3_sym(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 */ + wrong_type_error_nr(sc, sc->c_pointer_weak1_symbol, 1, val, sc->type_names[T_C_POINTER]); + func = find_method_with_let(sc, val, sc->c_pointer_weak1_symbol); + if (func == sc->undefined) + wrong_type_error_nr(sc, sc->c_pointer_weak1_symbol, 1, val, sc->type_names[T_C_POINTER]); + return(make_boolean(sc, type(s7_apply_function(sc, func, set_plist_1(sc, val))) == (uint8_t)opt3_byte(cdr(arg)))); } -static s7_pointer -opt_p_piip_sfff (opt_info* o) { - s7_int i1= q_i_func2_call (o); - s7_int i2= q_i_func3_call (o); - return (q_func (o).p_piip_f (o->sc, slot_value (q_arg1 (o).p), i1, i2, - q_p_func1_call (o))); +#define fx_not_opsq_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer arg1 = cadr(arg); \ + set_car(sc->t1_1, Lookup(sc, cadr(arg1), arg)); \ + return((fn_proc(arg1)(sc, sc->t1_1) == sc->F) ? sc->T : sc->F); \ + } + +fx_not_opsq_any(fx_not_opsq, s_lookup) +fx_not_opsq_any(fx_not_optq, t_lookup) + +static s7_pointer fx_not_car_t(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer p = t_lookup(sc, opt3_sym(arg), arg); /* cadadr */ + s7_pointer result = (is_pair(p)) ? car(p) : g_car(sc, set_plist_1(sc, p)); + return((result == sc->F) ? sc->T : sc->F); } -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 ind1_slot; - s7_pointer ind2_slot= opt_integer_symbol (sc, car (indexp2)); - if (!ind2_slot) - return_false ( - sc, indexp1); /* normally expr, indexp1 has more context than indexp2 */ - q_arg3 (opc).p= ind2_slot; - ind1_slot = opt_integer_symbol (sc, car (indexp1)); - if (ind1_slot) { - q_arg2 (opc).p= ind1_slot; - if ((is_symbol (car (valp))) || (is_unquoted_pair (sc, car (valp)))) { - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (!cell_optimize (sc, valp)) return_false (sc, indexp1); - q_func2 (opc).fp= q_func2_arg (opc).q_call (o1).fp; - q_call (opc).fp = opt_p_piip_sssf; - if ((is_t_vector (obj)) && - (loop_end_fits (q_arg2 (opc).p, vector_dimension (obj, 0))) && - (loop_end_fits (q_arg3 (opc).p, vector_dimension (obj, 1)))) - q_call (opc).fp= vector_set_piip_sssf_unchecked; - return_true (sc, NULL); - } - q_call (opc).fp= opt_p_piip_sssc; - q_arg4 (opc).p = (is_pair (car (valp))) ? cadar (valp) : car (valp); - return_true (sc, NULL); - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, indexp1)) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, indexp2)) { - q_func1_arg (opc).o1= sc->opts[sc->pc]; - if (cell_optimize (sc, valp)) { - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_func3 (opc).fi= q_func3_arg (opc).q_call (o1).fi; - q_func1 (opc).fp= q_func1_arg (opc).q_call (o1).fp; - q_call (opc).fp = opt_p_piip_sfff; - return_true (sc, NULL); - } - } + +#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)); \ + return(fn_proc(arg)(sc, with_list_t1(sc, fn_proc(cadr(arg))(sc, sc->t2_1)))); \ } - return_false (sc, indexp1); -} - -static bool -p_piip_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr) { - const s7_p_piip_t func= s7_p_piip_function (s_func); - if ((func) && (s_func == global_value (sc->vector_set_symbol)) && - (is_symbol (cadr (expr)))) { - s7_pointer obj; - const s7_pointer arg1_slot= s7_slot (sc, cadr (expr)); - if (!is_slot (arg1_slot)) return_false (sc, expr); - obj= slot_value (arg1_slot); - if ((has_methods (obj)) || (is_immutable (obj))) return_false (sc, expr); - if ((is_any_vector ( - obj)) && /* vector_set_p_piip calls vector_setter(obj) */ - (vector_rank (obj) == 2)) { - q_arg1 (opc).p = arg1_slot; - q_func (opc).p_piip_f= vector_set_p_piip; - return (p_piip_to_sx (sc, opc, cddr (expr), cdddr (expr), cddddr (expr), - obj)); - } + +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)))); \ } - return_false (sc, expr); + +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, opt1_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 y = u_lookup(sc, opt3_sym(arg), arg); + s7_pointer 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))); } -/* -------- p_pii -------- */ -static s7_pointer -opt_p_pii_sss (opt_info* o) { - return (q_func (o).p_pii_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - integer (slot_value (q_arg3 (o).p)))); -} - -static s7_pointer -opt_p_pii_sff (opt_info* o) { - s7_int i1= q_i_func2_call (o); - s7_int i2= q_i_func3_call (o); - return (q_func (o).p_pii_f (o->sc, slot_value (q_arg1 (o).p), i1, i2)); -} - -static s7_pointer -vector_ref_pii_sss_unchecked (opt_info* o) { - s7_pointer vec= slot_value (q_arg1 (o).p); - return (vector_element ( - vec, ((integer (slot_value (q_arg2 (o).p)) * vector_offset (vec, 0)) + - integer (slot_value (q_arg3 (o).p))))); -} - -static bool -p_pii_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr) { - const s7_p_pii_t func= s7_p_pii_function (s_func); - if ((func) && (is_symbol (cadr (expr)))) { - s7_pointer obj; - const s7_pointer arg1_slot= s7_slot (sc, cadr (expr)); - if (!is_slot (arg1_slot)) return_false (sc, expr); - obj= slot_value (arg1_slot); - if ((has_methods (obj)) || (is_immutable (obj))) return_false (sc, expr); - if ((is_t_vector (obj)) && (vector_rank (obj) == 2)) { - s7_pointer ind2_slot, indexp1= cddr (expr), indexp2= cdddr (expr); - q_arg1 (opc).p = arg1_slot; - q_func (opc).p_pii_f= vector_ref_p_pii; - ind2_slot = opt_integer_symbol (sc, car (indexp2)); - if (ind2_slot) { - s7_pointer ind1_slot; - q_arg3 (opc).p= ind2_slot; - ind1_slot = opt_integer_symbol (sc, car (indexp1)); - if (ind1_slot) { - q_arg2 (opc).p = ind1_slot; - q_call (opc).fp= opt_p_pii_sss; - /* normal vector rank 2 (see above) */ - if ((loop_end_fits ( - q_arg2 (opc).p, - vector_dimension (slot_value (q_arg1 (opc).p), 0))) && - (loop_end_fits ( - q_arg3 (opc).p, - vector_dimension (slot_value (q_arg1 (opc).p), 1)))) - q_call (opc).fp= vector_ref_pii_sss_unchecked; - return_true (sc, expr); - } - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, indexp1)) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, indexp2)) { - q_call (opc).fp = opt_p_pii_sff; - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_func3 (opc).fi= q_func3_arg (opc).q_call (o1).fi; - return_true (sc, expr); - } - } - } - } - return_false (sc, expr); +static s7_pointer fx_is_zero_remainder_car(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer t = t_lookup(sc, opt1_sym(cdr(arg)), arg); + s7_pointer 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(?) */ + 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, zero_b_7p(sc, remainder_p_pp(sc, u, t)))); } -/* -------- p_ppi -------- */ -static s7_pointer -opt_p_ppi_psf (opt_info* o) { - return (q_func (o).p_ppi_f (o->sc, q_arg1 (o).p, slot_value (q_arg2 (o).p), - q_i_func1_call (o))); -} -static s7_pointer -opt_p_ppi_psf_cpos (opt_info* o) { - return (char_position_p_ppi (o->sc, q_arg1 (o).p, slot_value (q_arg2 (o).p), - q_i_func1_call (o))); -} - -static bool -p_ppi_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr) { - const int32_t start= sc->pc; - const s7_p_ppi_t ifunc= s7_p_ppi_function (s_func); - if (!ifunc) return_false (sc, expr); - q_func (opc).p_ppi_f= ifunc; - if ((is_character (cadr (expr))) && (is_symbol (caddr (expr))) && - (int_optimize (sc, cdddr (expr)))) { - const s7_pointer arg2_slot= opt_simple_symbol (sc, caddr (expr)); - if (arg2_slot) { - q_arg1 (opc).p= cadr (expr); - q_arg2 (opc).p= arg2_slot; - q_call (opc).fp= - (ifunc == char_position_p_ppi) ? opt_p_ppi_psf_cpos : opt_p_ppi_psf; - q_func1_arg (opc).o1= sc->opts[start]; - q_func1 (opc).fi = q_call (sc->opts[start]).fi; - return_true (sc, expr); - } - } - sc->pc= start; - return_false (sc, expr); +static s7_pointer fx_is_zero_remainder_o(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer x = o_lookup(sc, opt3_sym(arg), arg); + s7_pointer y = s_lookup(sc, opt1_sym(cdr(arg)), arg); + if ((is_t_integer(x)) && (is_t_integer(y))) + return(make_boolean(sc, remainder_i_7ii(sc, integer(x), integer(y)) == 0)); + return(make_boolean(sc, zero_b_7p(sc, remainder_p_pp(sc, x, y)))); } -/* -------- p_ppp -------- */ +#define fx_c_opscq_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + const s7_pointer arg1 = cadr(arg); \ + set_car(sc->t2_1, Lookup(sc, cadr(arg1), arg1)); \ + set_car(sc->t2_2, opt1_con(cdr(arg1))); \ + return(fn_proc(arg)(sc, with_list_t1(sc, fn_proc(arg1)(sc, sc->t2_1)))); \ + } -static s7_pointer -opt_p_ppp_ssf (opt_info* o) { - return (q_func (o).p_ppp_f (o->sc, slot_value (q_arg1 (o).p), - slot_value (q_arg2 (o).p), q_p_func1_call (o))); -} -static s7_pointer -opt_p_ppp_hash_table_increment (opt_info* o) { - return (fx_hash_table_increment_1 (o->sc, slot_value (q_arg1 (o).p), - slot_value (q_arg2 (o).p), q_arg3 (o).p)); -} -static s7_pointer -opt_p_ppp_sfs (opt_info* o) { - return (q_func (o).p_ppp_f (o->sc, slot_value (q_arg1 (o).p), - q_p_func1_call (o), slot_value (q_arg2 (o).p))); -} -static s7_pointer -opt_p_ppp_scs (opt_info* o) { - return (q_func (o).p_ppp_f (o->sc, slot_value (q_arg1 (o).p), q_arg2 (o).p, - slot_value (q_arg3 (o).p))); -} -static s7_pointer -opt_p_ppp_sss (opt_info* o) { - return (q_func (o).p_ppp_f (o->sc, slot_value (q_arg1 (o).p), - slot_value (q_arg2 (o).p), - slot_value (q_arg3 (o).p))); -} -static s7_pointer -opt_p_ppp_sss_mul (opt_info* o) { - return (multiply_p_ppp (o->sc, slot_value (q_arg1 (o).p), - slot_value (q_arg2 (o).p), - slot_value (q_arg3 (o).p))); -} -static s7_pointer -opt_p_ppp_sss_hset (opt_info* o) { - return (s7_hash_table_set (o->sc, slot_value (q_arg1 (o).p), - slot_value (q_arg2 (o).p), - slot_value (q_arg3 (o).p))); -} -static s7_pointer -opt_p_ppp_ssc (opt_info* o) { - return (q_func (o).p_ppp_f (o->sc, slot_value (q_arg1 (o).p), - slot_value (q_arg2 (o).p), q_arg3 (o).p)); -} -static s7_pointer -opt_list_3c (opt_info* o) { - s7_scheme* sc= o->sc; - return (list_3 (sc, q_arg1 (o).p, q_arg2 (o).p, q_arg3 (o).p)); -} - -static s7_pointer -opt_p_ppp_sff (opt_info* o) { - s7_pointer result; - s7_scheme* sc= o->sc; - gc_protect_2_via_stack_no_let (sc, T_Ext (q_p_func2_call (o)), - T_Ext (q_p_func3_call (o))); - result= q_func (o).p_ppp_f (o->sc, slot_value (q_arg1 (o).p), - gc_protected1 (sc), gc_protected2 (sc)); - unstack_gc_protect (sc); - return (result); +fx_c_opscq_any(fx_c_opscq, s_lookup) +fx_c_opscq_any(fx_c_optcq, t_lookup) + +static s7_pointer fx_is_zero_remainder_ti(s7_scheme *sc, s7_pointer arg) +{ + const s7_pointer larg = cdadr(arg); + s7_pointer t = t_lookup(sc, car(larg), arg); + s7_int u = integer(cadr(larg)); + if (is_t_integer(t)) return(make_boolean(sc, (integer(t) % u) == 0)); + return(make_boolean(sc, zero_b_7p(sc, remainder_p_pi(sc, t, u)))); } -static s7_pointer -opt_p_ppp_fff (opt_info* o) { - s7_pointer result; - s7_scheme* sc= o->sc; - gc_protect_2_via_stack_no_let (sc, T_Ext (q_p_func2_call (o)), - T_Ext (q_p_func3_call (o))); - result= q_func (o).p_ppp_f (sc, gc_protected1 (sc), gc_protected2 (sc), - q_p_func1_call (o)); - unstack_gc_protect (sc); - return (result); -} - -static s7_pointer -opt_p_ppc_slot_set (opt_info* o) { - slot_set_value (q_arg2 (o).p, q_arg3 (o).p); - return (q_arg3 (o).p); -} -static s7_pointer -opt_p_pps_slot_set (opt_info* o) { - slot_set_value (q_arg2 (o).p, slot_value (q_arg3 (o).p)); - return (slot_value (q_arg3 (o).p)); -} -static s7_pointer -opt_p_ppf_slot_set (opt_info* o) { - slot_set_value (q_arg2 (o).p, q_p_func1_call (o)); - return (slot_value (q_arg2 (o).p)); -} - -static bool -use_ppc_slot_set (s7_scheme* sc, opt_info* opc, s7_pointer let, - s7_pointer symbol, s7_pointer value) /* timp tmisc */ -{ - s7_pointer slot= lookup_slot_with_let (sc, symbol, let); - if ((is_slot (slot)) && (!is_immutable (slot))) { - q_arg2 (opc).p = slot; - q_arg3 (opc).p = value; - q_call (opc).fp= opt_p_ppc_slot_set; - return (true); - } - return (false); +static s7_pointer fx_not_opscq(s7_scheme *sc, s7_pointer arg) +{ + const s7_pointer arg1 = cadr(arg); + set_car(sc->t2_1, lookup(sc, cadr(arg1))); + set_car(sc->t2_2, opt1_con(cdr(arg1))); + return((fn_proc(arg1)(sc, sc->t2_1) == sc->F) ? sc->T : sc->F); } -static bool -use_pps_slot_set (s7_scheme* sc, opt_info* opc, s7_pointer let, - s7_pointer symbol, s7_pointer val_slot) /* timp tref */ +static s7_pointer fx_c_opcsq(s7_scheme *sc, s7_pointer arg) { - s7_pointer slot= lookup_slot_with_let (sc, symbol, let); - if ((is_slot (slot)) && (!is_immutable (slot))) { - q_arg2 (opc).p = slot; - q_arg3 (opc).p = val_slot; - q_call (opc).fp= opt_p_pps_slot_set; - return (true); - } - return (false); + const s7_pointer arg1 = cadr(arg); + set_car(sc->t2_2, lookup(sc, caddr(arg1))); + set_car(sc->t2_1, opt1_con(cdr(arg1))); /* cadr(arg1) or cadadr */ + return(fn_proc(arg)(sc, with_list_t1(sc, fn_proc(arg1)(sc, sc->t2_1)))); } -static bool -use_ppf_slot_set (s7_scheme* sc, opt_info* opc, s7_pointer let, - s7_pointer symbol) /* timp */ +static s7_pointer fx_c_opcsq_c(s7_scheme *sc, s7_pointer arg) { - s7_pointer slot= lookup_slot_with_let (sc, symbol, let); - if ((is_slot (slot)) && (!is_immutable (slot))) { - q_arg2 (opc).p = slot; - q_call (opc).fp= opt_p_ppf_slot_set; - return (true); - } - return (false); -} - -static bool -p_ppp_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr) { - const s7_pointer arg1 = cadr (expr); - const s7_pointer arg2 = caddr (expr); - const s7_pointer arg3 = cadddr (expr); - const int32_t start= sc->pc; - const s7_p_ppp_t func = s7_p_ppp_function (s_func); - if (!func) return_false (sc, expr); - q_func (opc).p_ppp_f= func; - if (is_symbol (arg1)) { - s7_pointer obj; - opt_info* o1; - s7_pointer arg1_slot= s7_slot (sc, arg1); - if ((!is_slot (arg1_slot)) || (has_methods (slot_value (arg1_slot)))) - return_false (sc, expr); - - obj= slot_value (arg1_slot); - if ((is_any_vector (obj)) && (vector_rank (obj) > 1)) - return_false (sc, expr); - - if (is_target_or_its_alias (car (expr), s_func, - sc->hash_table_set_symbol)) { - if ((!is_hash_table (obj)) || (is_immutable_hash_table (obj))) - return_false (sc, expr); - } - else if ((is_target_or_its_alias (car (expr), s_func, - sc->let_set_symbol)) && - ((!is_let (obj)) || (is_immutable (obj)))) - return_false (sc, expr); - - q_arg1 (opc).p= arg1_slot; - - if ((func == hash_table_set_p_ppp) && (is_hash_table (obj))) - q_func (opc).p_ppp_f= s7_hash_table_set; - - if (is_symbol (arg2)) { - s7_pointer arg2_slot; - if ((is_keyword (arg2)) && (is_symbol (arg3)) && (is_let (obj)) && - (q_func (opc).p_ppp_f == let_set_2)) { - s7_pointer val_slot= opt_simple_symbol (sc, arg3); - if ((val_slot) && - (use_pps_slot_set (sc, opc, obj, keyword_symbol (arg2), val_slot))) - return_true (sc, expr); - } - arg2_slot= opt_simple_symbol (sc, arg2); - if (arg2_slot) { - const s7_pointer arg2_val= slot_value (arg2_slot); - q_arg2 (opc).p = arg2_slot; - if (is_symbol (arg3)) { - s7_pointer arg3_slot; - arg3_slot= opt_simple_symbol (sc, arg3); - if (arg3_slot) { - s7_p_ppp_t func1= q_func (opc).p_ppp_f; - q_arg3 (opc).p = arg3_slot; /* some other caller depends on this? - op_simple_do_1[86577]: not a slot */ - q_call (opc).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 (sc, expr); - } - } - else if ((!is_pair (arg3)) || (is_proper_quote (sc, arg3))) { - q_arg3 (opc).p = (is_pair (arg3)) ? cadr (arg3) : arg3; - q_call (opc).fp= opt_p_ppp_ssc; - if ((is_let (obj)) && (q_func (opc).p_ppp_f == let_set_2) && - (is_symbol (arg2_val))) /* (let-set! L3 :x 0) */ - use_ppc_slot_set ( - sc, opc, obj, - (is_keyword (arg2_val)) ? keyword_symbol (arg2_val) : arg2_val, - q_arg3 (opc).p); - return_true (sc, expr); - } - if (optimize_op (expr) == HOP_HASH_TABLE_INCREMENT) { - q_call (opc).fp= opt_p_ppp_hash_table_increment; - q_arg3 (opc).p = expr; - return_true (sc, expr); - } - if (cell_optimize (sc, cdddr (expr))) { - q_func1_arg (opc).o1= sc->opts[start]; - q_func1 (opc).fp = q_func1_arg (opc).q_call (o1).fp; - q_call (opc).fp = opt_p_ppp_ssf; - if ((is_let (obj)) && (is_symbol_and_keyword (arg2_val)) && - (q_func (opc).p_ppp_f == - let_set_2)) /* (let-set! L3 :x (+ (L3 'x) 1)) */ - use_ppf_slot_set (sc, opc, obj, keyword_symbol (arg2_val)); - - if ((sc->do_body_p == expr) && (is_complex_vector (obj)) && - (is_pair (arg3)) && (car (arg3) == sc->complex_symbol) && - (car (expr) == sc->complex_vector_set_symbol)) { - if (q_func1_arg (opc).q_func (o1).p_pp_f == - complex_p_pp) /* same as below but (complex d d)?? d float */ - q_func1_arg (opc).q_func (o1).p_pp_f= complex_p_pp_wrapped; - else if (q_func1_arg (opc).q_func (o1).p_dd_f == - complex_p_dd) /* same below but (complex d 1.0), d float - stepper */ - q_func1_arg (opc).q_func (o1).p_dd_f= complex_p_dd_wrapped; - else if (q_func1_arg (opc).q_func (o1).p_ii_f == - complex_p_ii) /* (complex-vector-set! cv1 i (complex i i)) - */ - q_func1_arg (opc).q_func (o1).p_ii_f= complex_p_ii_wrapped; - } - return_true (sc, expr); - } - sc->pc= start; - } - } - if ((is_proper_quote (sc, arg2)) && (is_symbol (arg3))) { - const s7_pointer val_slot= opt_simple_symbol (sc, arg3); - if (val_slot) { - q_arg2 (opc).p = cadr (arg2); - q_arg3 (opc).p = val_slot; - q_call (opc).fp= opt_p_ppp_scs; - if ((is_let (obj)) && (q_func (opc).p_ppp_f == let_set_2) && - (is_symbol (cadr (arg2)))) - use_pps_slot_set (sc, opc, obj, cadr (arg2), val_slot); - return_true (sc, expr); - } - } - o1= sc->opts[sc->pc]; - if (cell_optimize (sc, cddr (expr))) { - opt_info* o2= sc->opts[sc->pc]; - if (is_symbol (arg3)) { - const s7_pointer val_slot= opt_simple_symbol (sc, arg3); - if (val_slot) { - q_arg2 (opc).p= val_slot; - q_call (opc).fp= - opt_p_ppp_sfs; /* hset case goes through the case below */ - q_func1_arg (opc).o1= o1; - q_func1 (opc).fp = q_call (o1).fp; - return_true (sc, expr); - } - } - if ((!is_pair (arg3)) && (is_let (obj)) && - (is_quoted_symbol (sc, arg2)) && - (q_func (opc).p_ppp_f == let_set_2) && /* (let-set! L3 'x 0) */ - (use_ppc_slot_set (sc, opc, obj, cadr (arg2), arg3))) - return_true (sc, expr); - - if (cell_optimize (sc, cdddr (expr))) { - if ((is_let (obj)) && (is_quoted_symbol (sc, arg2)) && - (q_func (opc).p_ppp_f == - let_set_2) && /* (let-set! L3 'x (+ (L3 'x) 1)) */ - (use_ppf_slot_set (sc, opc, obj, cadr (arg2)))) { - q_func1_arg (opc).o1= o2; - q_func1 (opc).fp = q_func1_arg (opc).q_call (o1).fp; - return_true (sc, expr); - } - q_call (opc).fp = opt_p_ppp_sff; - q_func2_arg (opc).o1= o1; - q_func2 (opc).fp = q_call (o1).fp; - q_func3_arg (opc).o1= o2; - q_func3 (opc).fp = q_call (o2).fp; - return_true (sc, expr); - } - } - } - else /* arg1 not symbol */ - { - q_func2_arg (opc).o1= sc->opts[start]; - if (cell_optimize (sc, cdr (expr))) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (cell_optimize (sc, cddr (expr))) { - q_func1_arg (opc).o1= sc->opts[sc->pc]; - if (cell_optimize (sc, cdddr (expr))) { - q_call (opc).fp = opt_p_ppp_fff; - q_func2 (opc).fp= q_func2_arg (opc).q_call (o1).fp; - q_func3 (opc).fp= q_func3_arg (opc).q_call (o1).fp; - q_func1 (opc).fp= q_func1_arg (opc).q_call (o1).fp; - if ((q_func (opc).p_ppp_f == list_p_ppp) && - (q_func1 (opc).fp == opt_p_c) && (q_func3 (opc).fp == opt_p_c) && - (q_func2 (opc).fp == opt_p_c)) { - q_call (opc).fp= opt_list_3c; - q_arg1 (opc).p = q_func2_arg (opc).q_arg1 (o1).p; - q_arg2 (opc).p = q_func3_arg (opc).q_arg1 (o1).p; - q_arg3 (opc).p = q_func1_arg (opc).q_arg1 (o1).p; - } - return_true (sc, expr); - } - } - } - } - sc->pc= start; - return_false (sc, expr); + const s7_pointer arg1 = cadr(arg); + set_car(sc->t2_2, lookup(sc, caddr(arg1))); + set_car(sc->t2_1, opt1_con(cdr(arg1))); /* cadr(arg1) or cadadr */ + set_car(sc->t2_1, fn_proc(arg1)(sc, sc->t2_1)); + set_car(sc->t2_2, caddr(arg)); + return(fn_proc(arg)(sc, sc->t2_1)); } -/* -------- p_call_ppp -------- */ -static s7_pointer -opt_p_call_sss (opt_info* o) { - return (q_func (o).call (o->sc, set_plist_3 (o->sc, slot_value (q_arg1 (o).p), - slot_value (q_arg2 (o).p), - slot_value (q_arg3 (o).p)))); +static s7_pointer fx_c_opcsq_s(s7_scheme *sc, s7_pointer arg) +{ + const s7_pointer arg1 = cadr(arg); + set_car(sc->t2_2, lookup(sc, caddr(arg1))); + set_car(sc->t2_1, opt1_con(cdr(arg1))); /* cadr(arg1) or cadadr */ + set_car(sc->t2_1, fn_proc(arg1)(sc, sc->t2_1)); + set_car(sc->t2_2, lookup(sc, caddr(arg))); + return(fn_proc(arg)(sc, sc->t2_1)); } -static s7_pointer -opt_p_call_ccs (opt_info* o) { - return ( - q_func (o).call (o->sc, set_plist_3 (o->sc, q_arg1 (o).p, q_arg2 (o).p, - slot_value (q_arg3 (o).p)))); +static s7_pointer fx_c_opssq_s(s7_scheme *sc, s7_pointer arg) +{ + const s7_pointer arg1 = cadr(arg); + set_car(sc->t2_1, lookup(sc, cadr(arg1))); + set_car(sc->t2_2, lookup(sc, opt1_sym(cdr(arg1)))); + set_car(sc->t2_1, fn_proc(arg1)(sc, sc->t2_1)); + set_car(sc->t2_2, lookup(sc, caddr(arg))); + return(fn_proc(arg)(sc, sc->t2_1)); } -static s7_pointer -opt_p_call_scs (opt_info* o) { - return (q_func (o).call (o->sc, set_plist_3 (o->sc, slot_value (q_arg1 (o).p), - q_arg2 (o).p, - slot_value (q_arg3 (o).p)))); +static s7_pointer fx_c_opssq_s_direct(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer arg1_p = 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(arg1_p)), lookup(sc, opt1_sym(arg1_p))), + lookup(sc, caddr(arg)))); } -static s7_pointer -opt_p_call_css (opt_info* o) { - return (q_func (o).call (o->sc, set_plist_3 (o->sc, q_arg1 (o).p, - slot_value (q_arg2 (o).p), - slot_value (q_arg3 (o).p)))); +static s7_pointer fx_add_mul_opssq_s(s7_scheme *sc, s7_pointer arg) +{ + const s7_pointer arg1_p = opt3_pair(arg); /* cdadr(arg) */ + const s7_pointer a = lookup(sc, car(arg1_p)); + const s7_pointer b = lookup(sc, opt1_sym(arg1_p)); + const s7_pointer 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_wrapped(sc, a, b), c)); } -static s7_pointer -opt_p_call_ssf (opt_info* o) { - return (q_func (o).call (o->sc, set_plist_3 (o->sc, slot_value (q_arg1 (o).p), - slot_value (q_arg2 (o).p), - q_p_func1_call (o)))); +static s7_pointer fx_cons_cons_s(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer arg1_p = opt3_pair(arg); /* cdadr(arg) */ + return(cons_unchecked(sc, cons(sc, lookup(sc, car(arg1_p)), lookup(sc, opt1_sym(arg1_p))), lookup(sc, caddr(arg)))); } -static s7_pointer -opt_p_call_ppp (opt_info* o) { - s7_pointer result; - s7_scheme* sc= o->sc; - gc_protect_2_via_stack_no_let (sc, q_p_func1_call (o), q_p_func3_call (o)); - result= q_p_func2_call (o); /* not combinable into next */ - result= q_func (o).call ( - sc, set_plist_3 (sc, gc_protected1 (sc), gc_protected2 (sc), result)); - if (stack_top_op (sc) == OP_GC_PROTECT) unstack_gc_protect (sc); - return (result); -} - -static bool -p_call_ppp_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr) { - const int32_t start= sc->pc; - if ((is_safe_procedure (s_func)) && (c_function_is_aritable (s_func, 3)) && - (s_func != global_value (sc->hash_table_ref_symbol)) && - (s_func != global_value (sc->list_ref_symbol))) { - const s7_pointer arg1= cadr (expr), arg2= caddr (expr), arg3= cadddr (expr); - opt_info* o1= sc->opts[sc->pc]; - - if (!is_pair (arg1)) { - if (is_normal_symbol (arg1)) { - const s7_pointer arg1_slot= opt_simple_symbol (sc, arg1); - if (arg1_slot) { - q_arg1 (opc).p= arg1_slot; - if ((s_func == global_value (sc->vector_ref_symbol)) && - (is_t_vector (slot_value (arg1_slot))) && - (vector_rank (slot_value (arg1_slot)) != 2)) - return_false (sc, expr); - /* arg1 ok as symbol */ - if ((is_code_constant (sc, arg2)) && (is_normal_symbol (arg3))) { - const s7_pointer val_slot= opt_simple_symbol (sc, arg3); - if (val_slot) { - q_arg2 (opc).p = arg2; - q_arg3 (opc).p = val_slot; - q_func (opc).call= cf_call (sc, expr, s_func, 3); - if ((sc->do_body_p == expr) && (arg1 == sc->F) && - (car (expr) == sc->format_symbol)) - q_func (opc).call= g_format_nr; - q_call (opc).fp= opt_p_call_scs; - return_true (sc, expr); - } - } - } - else - return_false (sc, - expr); /* no need for sc->pc = start here, I think */ - } - else { - if ((is_code_constant (sc, arg1)) && (is_code_constant (sc, arg2)) && - (is_normal_symbol (arg3))) { - const s7_pointer val_slot= opt_simple_symbol (sc, arg3); - if (val_slot) { - q_arg1 (opc).p = arg1; - q_arg2 (opc).p = (is_pair (arg2)) ? cadr (arg2) : arg2; - q_arg3 (opc).p = val_slot; - q_func (opc).call= cf_call (sc, expr, s_func, 3); - if ((sc->do_body_p == expr) && (arg1 == sc->F) && - (car (expr) == sc->format_symbol)) - q_func (opc).call= g_format_nr; - q_call (opc).fp= opt_p_call_ccs; - return_true (sc, expr); - } - } - q_arg1 (opc).p= arg1; - if (s_func == global_value (sc->vector_ref_symbol)) - return_false (sc, expr); - } - if (is_normal_symbol (arg2)) { - const s7_pointer arg2_slot= opt_simple_symbol (sc, arg2); - if (arg2_slot) { - q_arg2 (opc).p= arg2_slot; - if (is_normal_symbol (arg3)) { - const s7_pointer arg3_slot= opt_simple_symbol (sc, arg3); - if (arg3_slot) { - q_arg3 (opc).p = arg3_slot; - q_func (opc).call= cf_call (sc, expr, s_func, 3); - q_call (opc).fp= - (is_slot (q_arg1 (opc).p)) ? opt_p_call_sss : opt_p_call_css; - return_true (sc, expr); - } - } - else if (is_slot (q_arg1 (opc).p)) { - const int32_t start1= sc->pc; - if ((cf_call (sc, expr, s_func, 3) == g_substring_uncopied) && - (is_t_integer (slot_value (q_arg2 (opc).p))) && - (is_string (slot_value (q_arg1 (opc).p))) && - (int_optimize (sc, cdddr (expr)))) { - q_call (opc).fp = opt_p_substring_uncopied_ssf; - q_func1_arg (opc).o1= o1; - q_func1 (opc).fi = q_call (o1).fi; - return_true (sc, expr); - } - sc->pc= start1; - if (cell_optimize (sc, cdddr (expr))) { - q_func (opc).call = cf_call (sc, expr, s_func, 3); - q_call (opc).fp = opt_p_call_ssf; - q_func1_arg (opc).o1= o1; - q_func1 (opc).fp = q_call (o1).fp; - return_true (sc, expr); - } - } - } - } - } - if (s_func == global_value (sc->vector_ref_symbol)) return_false (sc, expr); - if (cell_optimize (sc, cdr (expr))) { - opt_info* o2= sc->opts[sc->pc]; - if (cell_optimize (sc, cddr (expr))) { - opt_info* o3= sc->opts[sc->pc]; - if (cell_optimize (sc, cdddr (expr))) { - q_func (opc).call = cf_call (sc, expr, s_func, 3); - q_call (opc).fp = opt_p_call_ppp; - q_func1_arg (opc).o1= o1; - q_func1 (opc).fp = q_call (o1).fp; - q_func3_arg (opc).o1= o2; - q_func3 (opc).fp = q_call (o2).fp; - q_func2_arg (opc).o1= o3; - q_func2 (opc).fp = q_call (o3).fp; - return_true (sc, expr); - } - } - } +#define fx_add_sqr_s_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer num1 = Lookup(sc, car(opt3_pair(arg)), arg); \ + s7_pointer num2 = lookup(sc, caddr(arg)); \ + if ((is_t_complex(num1)) && (is_t_complex(num2))) \ + { \ + s7_double r = real_part(num1), i = imag_part(num1); \ + return(make_complex(sc, real_part(num2) + r * r - i * i, imag_part(num2) + 2.0 * r * i)); \ + } \ + return(add_p_pp(sc, fx_sqr_wrapped(sc, num1), num2)); \ } - sc->pc= start; - return_false (sc, expr); -} -/* -------- p_call_any -------- */ -#define p_call_o1 3 -#define q_p_call_f(o) o->v[2] -#define q_p_call_arg(o, i) o->v[i] +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 -opt_p_call_any (opt_info* o) { - s7_scheme* sc = o->sc; - s7_pointer val= safe_list_if_possible (sc, q_arg1 (o).i); - s7_pointer arg= val; - if (in_heap (val)) gc_protect_via_stack_no_let (sc, val); - for (s7_int i= 0; i < q_arg1 (o).i; i++, arg= cdr (arg)) { - opt_info* o1= q_p_call_arg (o, i + p_call_o1).o1; - set_car (arg, q_call (o1).fp (o1)); - } - arg= q_p_call_f (o).call (sc, val); - if (in_heap (val)) unstack_gc_protect (sc); - else clear_safe_list_in_use (sc, val); - return (arg); -} - -static s7_pointer -opt_p_call_4g (opt_info* o) { - s7_scheme* sc= o->sc; - opt_info* o1= q_p_call_arg (o, 0 + p_call_o1).o1; - opt_info* o2= q_p_call_arg (o, 1 + p_call_o1).o1; - opt_info* o3= q_p_call_arg (o, 2 + p_call_o1).o1; - opt_info* o4= q_p_call_arg (o, 3 + p_call_o1).o1; - return (q_p_call_f (o).call ( - o->sc, set_plist_4 (sc, q_call (o1).fp (o1), q_call (o2).fp (o2), - q_call (o3).fp (o3), q_call (o4).fp (o4)))); -} - -static bool -p_call_any_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr, int32_t len) { - if ((len < (num_vunions - p_call_o1)) && (is_safe_procedure (s_func)) && - (c_function_is_aritable (s_func, len - 1))) { - bool safe= true; - s7_pointer p= - cdr (expr); /* (vector-set! v k i 2) gets here, as does - (float-vector-set! v k i n (+ 0.0 i3 k3 n)) from tvect */ - q_arg1 (opc).i= (len - 1); /* also ccff in cb.scm I think */ - for (int32_t pctr= p_call_o1; is_pair (p); pctr++, p= cdr (p)) { - q_p_call_arg (opc, pctr).o1= sc->opts[sc->pc]; - if (!cell_optimize (sc, p)) break; - if (is_pair (car (p))) safe= false; - } - if (is_null (p)) { - q_call (opc).fp= ((len == 5) && (safe)) ? opt_p_call_4g : opt_p_call_any; - q_p_call_f (opc).call= cf_call (sc, expr, s_func, len - 1); - return_true (sc, expr); - } - } - return_false (sc, expr); +static s7_pointer fx_add_sub_s(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer arg1_p = opt3_pair(arg); /* cdadr(arg) */ + s7_pointer num1 = lookup(sc, car(arg1_p)); + s7_pointer num2 = lookup(sc, opt1_sym(arg1_p)); + s7_pointer num3 = lookup(sc, caddr(arg)); + if ((is_t_real(num1)) && (is_t_real(num2)) && (is_t_real(num3))) return(make_real(sc, real(num3) + real(num1) - real(num2))); + return(add_p_pp(sc, subtract_p_pp_wrapped(sc, num1, num2), num3)); } -/* -------- p_fx_any -------- */ - -static s7_pointer -opt_p_fx_any (opt_info* o) { - return (q_func (o).call (o->sc, q_arg1 (o).p)); +static s7_pointer fx_add_sub_tu_s(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer num1 = t_lookup(sc, car(cdadr(arg)), arg); + s7_pointer num2 = u_lookup(sc, cadr(cdadr(arg)), arg); + s7_pointer num3 = lookup(sc, caddr(arg)); + if ((is_t_real(num1)) && (is_t_real(num2)) && (is_t_real(num3))) return(make_real(sc, real(num3) + real(num1) - real(num2))); + return(add_p_pp(sc, subtract_p_pp_wrapped(sc, num1, num2), num3)); } -static void fx_annotate_arg (s7_scheme* sc, s7_pointer arg, - s7_pointer let_or_list); -static bool -p_fx_any_ok (s7_scheme* sc, opt_info* opc, s7_pointer expr) { - s7_function func= ((is_pair (car (expr))) && (has_fx (car (expr)))) - ? fx_proc (car (expr)) - : NULL; -#if 0 - /* this is slower! -- fx choices are pessimal here */ - if ((!func) && (is_fxable(sc, car(expr)))) {fx_annotate_arg(sc, expr, sc->curlet); if (has_fx(expr)) func = fx_proc(expr);} -#endif - if (!func) return_false (sc, expr); - q_call (opc).fp = opt_p_fx_any; - q_func (opc).call= func; - q_arg1 (opc).p = car (expr); - return_true (sc, expr); +static s7_pointer fx_gt_add_s(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer arg1_p = opt3_pair(arg); /* cdadr(arg) */ + s7_pointer x1 = lookup(sc, car(arg1_p)); + s7_pointer x2 = lookup(sc, opt1_sym(arg1_p)); + s7_pointer 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_wrapped(sc, x1, x2), x3)); } -/* -------- p_implicit -------- */ - -static bool -p_implicit_ok (s7_scheme* sc, s7_pointer s_slot, s7_pointer expr, int32_t len) { - const s7_pointer obj = slot_value (s_slot); - const s7_pointer arg1= (len > 1) ? cadr (expr) : sc->F; - opt_info* opc; - int32_t start; - - if ((!is_simple_sequence (obj)) || (len < 2)) /* was is_sequence? */ - return_false (sc, expr); - - opc = alloc_opt_info (sc); - q_arg1 (opc).p= s_slot; - start = sc->pc; - if (len == 2) { - switch (type (obj)) { - case T_PAIR: - q_func (opc).p_pi_f= list_ref_p_pi_unchecked; - break; - case T_HASH_TABLE: - q_func (opc).p_pp_f= s7_hash_table_ref; - break; - case T_LET: - q_func (opc).p_pp_f= let_ref; - break; - case T_STRING: - q_func (opc).p_pi_f= string_ref_p_pi_unchecked; - break; - case T_C_OBJECT: - return_false (sc, expr); /* no pi_ref because ref assumes pp */ - - case T_VECTOR: - if (vector_rank (obj) != 1) return_false (sc, expr); - q_func (opc).p_pi_f= t_vector_ref_p_pi_unchecked; - break; - - case T_BYTE_VECTOR: - case T_INT_VECTOR: - case T_FLOAT_VECTOR: - case T_COMPLEX_VECTOR: - if (vector_rank (obj) != 1) return_false (sc, expr); - q_func (opc).p_pi_f= vector_ref_p_pi_unchecked; - break; - - default: - return_false (sc, expr); - } - /* now v3.p_pi|pp.f is set */ - if (is_symbol (arg1)) { - const s7_pointer arg1_slot= s7_slot ( - sc, arg1); /* not the desired slot if let+keyword, see below */ - if (is_slot (arg1_slot)) { - q_arg2 (opc).p= arg1_slot; - if ((!is_hash_table (obj)) && /* these because opt_int below */ - (!is_let (obj))) { - if (!is_t_integer (slot_value (arg1_slot))) - return_false (sc, expr); /* I think this reflects that a non-int - index is an error for list-ref et al */ - q_call (opc).fp= opt_p_pi_ss; /* TODO: this now uses 1/2 not 2/1 */ - if (has_loop_end (q_arg2 (opc).p)) - check_unchecked (sc, obj, q_arg2 (opc).p, opc, NULL); - fixup_p_pi_ss (opc); - return_true (sc, expr); - } - q_call (opc).fp= - ((is_hash_table (obj)) && - (q_func (opc).p_pp_f == s7_hash_table_ref)) - ? opt_p_pp_ss_href - : (((is_let (obj)) && (q_func (opc).p_pp_f == let_ref)) - ? opt_p_pp_ss_lref - : opt_p_pp_ss); - if ((q_call (opc).fp == opt_p_pp_ss_lref) && (is_keyword (arg1))) - use_slot_ref ( - sc, opc, obj, - keyword_symbol ( - arg1)); /* if keyword, slot is: (L3 :x) -> # */ - return_true (sc, expr); - } - } - else /* arg1 not a symbol */ - { - if ((!is_hash_table (obj)) && (!is_let (obj))) { - opt_info* o1; - if (is_t_integer (arg1)) { - q_arg2 (opc).i = integer (arg1); - q_call (opc).fp= opt_p_pi_sc; - return_true (sc, expr); - } - o1= sc->opts[sc->pc]; - if (!int_optimize (sc, cdr (expr))) return_false (sc, expr); - q_call (opc).fp = opt_p_pi_sf; - q_func1_arg (opc).o1= o1; - q_func1 (opc).fi = q_call (o1).fi; - return_true (sc, expr); - } - if ((!is_pair (arg1)) || (is_proper_quote (sc, arg1))) { - q_arg2 (opc).p = (!is_pair (arg1)) ? arg1 : cadr (arg1); - q_call (opc).fp= opt_p_pp_sc; - if ((is_pair (arg1)) && (is_symbol (q_arg2 (opc).p)) && - (is_let (obj)) && (q_func (opc).p_pp_f == let_ref)) - use_slot_ref (sc, opc, obj, cadr (arg1)); - return_true (sc, expr); - } - if (cell_optimize (sc, cdr (expr))) { /* need both type check and func - check! (hash-table-ref or 123) */ - q_call (opc).fp= - ((is_hash_table (obj)) && - (q_func (opc).p_pp_f == s7_hash_table_ref)) - ? opt_p_pp_sf_href - : (((is_let (obj)) && (q_func (opc).p_pp_f == let_ref)) - ? opt_p_pp_sf_lref - : opt_p_pp_sf); - q_func1_arg (opc).o1= sc->opts[start]; - q_func1 (opc).fp = q_call (sc->opts[start]).fp; - return_true (sc, expr); - } - } - } /* len==2 */ - else { /* len > 2 */ - if ((is_t_vector (obj)) && (len == 3) && (vector_rank (obj) == 2)) { - const s7_pointer arg2_slot= opt_integer_symbol (sc, caddr (expr)); - if (arg2_slot) { - s7_pointer arg1_slot; - q_arg3 (opc).p= arg2_slot; - arg1_slot = opt_integer_symbol (sc, arg1); - if (arg1_slot) { - q_arg2 (opc).p = arg1_slot; - q_func (opc).p_pii_f= vector_ref_p_pii; - q_call (opc).fp = opt_p_pii_sss; - if ((loop_end_fits (q_arg2 (opc).p, vector_dimension (obj, 0))) && - (loop_end_fits (q_arg3 (opc).p, vector_dimension (obj, 1)))) - q_call (opc).fp= vector_ref_pii_sss_unchecked; - return_true (sc, expr); - } - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cdr (expr))) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cddr (expr))) { - q_call (opc).fp = opt_p_pii_sff; - q_func2 (opc).fi = q_func2_arg (opc).q_call (o1).fi; - q_func3 (opc).fi = q_func3_arg (opc).q_call (o1).fi; - q_func (opc).p_pii_f= vector_ref_p_pii_direct; - return_true (sc, expr); - } - } - sc->pc= start; - } +static s7_pointer fx_gt_add_tu_s(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer x1 = t_lookup(sc, car(cdadr(arg)), arg); + s7_pointer x2 = u_lookup(sc, cadr(cdadr(arg)), arg); + s7_pointer 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_wrapped(sc, x1, x2), x3)); +} -#define P_IMPLICIT_CALL_O1 4 - if (len < (num_vunions - P_IMPLICIT_CALL_O1)) /* mimic p_call_any_ok */ - { - s7_pointer p = expr; - q_arg1 (opc).i= len; - for (int32_t pctr= (P_IMPLICIT_CALL_O1 - 1); is_pair (p); - pctr++, p= cdr (p)) { - q_p_call_arg (opc, pctr).o1= sc->opts[sc->pc]; - if (!cell_optimize (sc, p)) break; - } - if (is_null (p)) { - /* 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, but this is called very rarely mainly - * because hi-rank implicit refs are rare, and check_type_uncertainty is - * unhappy if there are multiple sets of a var. hash-tables, lets, - * lists, and vectors with extra (implicit) args can't be handled - * because we have no way to tell what the implicit call will do, and in - * the opt_* context, everything must be "safe" (i.e. no defines or - * hidden multiple-values, etc). - */ - if ((!is_any_vector (obj)) || (vector_rank (obj) != (len - 1))) - return_false ( - sc, expr); /* (* i (P2 1 1)) in timp.scm where P2 is a list */ - q_call (opc).fp= opt_p_call_any; - switch (type (obj)) /* string can't happen here (no multidimensional - strings), for pair/hash/let see above */ - { - case T_INT_VECTOR: - q_p_call_f (opc).call= g_int_vector_ref; - break; - case T_BYTE_VECTOR: - q_p_call_f (opc).call= g_byte_vector_ref; - break; - case T_FLOAT_VECTOR: - q_p_call_f (opc).call= g_float_vector_ref; - break; - case T_COMPLEX_VECTOR: - q_p_call_f (opc).call= g_complex_vector_ref; - break; - case T_VECTOR: - q_p_call_f (opc).call= g_vector_ref; - break; - default: - return_false (sc, expr); - } - return_true (sc, expr); - } - } - } - return_false (sc, expr); +static s7_pointer fx_gt_vref_s(s7_scheme *sc, s7_pointer arg) +{ + return(gt_p_pp(sc, s7i_vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt1_sym(opt3_pair(arg)))), lookup(sc, caddr(arg)))); } -/* -------- cell_quote -------- */ -static bool -opt_cell_quote (s7_scheme* sc, s7_pointer expr) { - opt_info* opc; - if (!is_null (cddr (expr))) return_false (sc, expr); - opc = alloc_opt_info (sc); - q_arg1 (opc).p = cadr (expr); - q_call (opc).fp= opt_p_c; - return_true (sc, expr); +static s7_pointer fx_geq_s_vref(s7_scheme *sc, s7_pointer arg) +{ + return(geq_p_pp(sc, lookup(sc, cadr(arg)), s7i_vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt1_sym(opt3_pair(arg)))))); } -/* -------- cell_set -------- */ -static s7_pointer -opt_set_p_p_f (opt_info* o) { - s7_pointer val= q_p_func1_call (o); - slot_set_value (q_arg1 (o).p, val); - return (val); -} - -static s7_pointer -opt_set_p_p_f_with_setter (opt_info* o) { - s7_pointer val= q_p_func1_call (o); - call_c_function_setter (o->sc, slot_setter (q_arg1 (o).p), - slot_symbol (q_arg1 (o).p), val); - slot_set_value (q_arg1 (o).p, val); - return (val); -} - -static s7_pointer -opt_set_input_port_string_p_p_f (opt_info* o) { - s7_pointer val = q_p_func1_call (o); /* the string */ - s7_pointer port= slot_value (q_arg2 (o).p); - if (!is_input_port (port)) - wrong_type_error_nr (o->sc, o->sc->port_string_symbol, 1, port, - an_input_port_string); - set_input_port_string (o->sc, port, val); - return (val); -} - -static s7_pointer -opt_set_output_port_string_p_p_f (opt_info* o) { - s7_pointer val = q_p_func1_call (o); /* the string */ - s7_pointer port= slot_value (q_arg2 (o).p); - if (!is_output_port (port)) - wrong_type_error_nr (o->sc, o->sc->port_string_symbol, 1, port, - an_input_port_string); - set_output_port_string (o->sc, port, val); - return (val); -} - -static s7_pointer -opt_set_p_i_s (opt_info* o) { - s7_pointer val= slot_value (q_arg2 (o).p); - if (is_mutable_integer (val)) val= make_integer (o->sc, integer (val)); - slot_set_value (q_arg1 (o).p, val); - return (val); -} - -static s7_pointer -opt_set_p_i_f (opt_info* o) { - s7_pointer val= make_integer (o->sc, q_i_func1_call (o)); - slot_set_value (q_arg1 (o).p, val); - return (val); -} -/* here and below (opt_set_p_d_f), the mutable versions are not safe, and are - * very tricky to make safe. First if a variable is set twice, in the body, as - * in (do (...) (... (set! buffix (+ 1 buffix)) (if (>= buffix fftsize) (set! - * buffix 0)))) from pvoc.scm, if the first set! is opt_set_p_i_fm (see tmp) - * (buffix is assumed mutable), the second sets it to built-in immutable zero, - * so the next time around loop, the set_integer is direct so now built-in 0 == - * 128 (yet still prints itself as "0"). Also if a mutable variable is stored, - * (define (f2) (let ((v (vector 0 0 0)) (y 1.0)) (do ((i 0 (+ i 1))) ((= i 3) - * v) (set! y (+ y 1.0)) (vector-set! v i y)))) (f2) -> #(4.0 4.0 4.0). Maybe - * safe if body has just one statement? - */ +static s7_pointer fx_is_eq_s_vref(s7_scheme *sc, s7_pointer arg) +{ + return(make_boolean(sc, lookup(sc, cadr(arg)) == s7i_vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt1_sym(opt3_pair(arg)))))); +} -static s7_pointer -opt_set_p_d_s (opt_info* o) { - s7_pointer val= slot_value (q_arg2 (o).p); - if (is_mutable_number (val)) val= make_real (o->sc, real (val)); - slot_set_value (q_arg1 (o).p, val); - return (val); -} - -static s7_pointer -opt_set_p_d_f (opt_info* o) { - s7_pointer val= make_real (o->sc, q_d_func1_call (o)); - slot_set_value (q_arg1 (o).p, val); - return (val); -} - -static s7_pointer -opt_set_p_d_f_sf_add (opt_info* o) { - s7_pointer val= make_real (o->sc, opt_d_dd_sf_add (q_func1_arg (o).o1)); - slot_set_value (q_arg1 (o).p, val); - return (val); -} - -static s7_pointer -opt_set_p_d_fm_sf_add (opt_info* o) { - s7_double x1= opt_d_dd_sf_add (q_func1_arg (o).o1); - check_mutability (o->sc, o, __func__, __LINE__); - set_real (slot_value (q_arg1 (o).p), x1); - return (slot_value (q_arg1 (o).p)); -} - -static s7_pointer -opt_set_p_d_f_mm_add ( - opt_info* o) /* see set_p_d_f_combinable below, tfft for both */ -{ - s7_double x1= float_vector_ref_d_7pi (o->sc, slot_value (q_arg2 (o).p), - integer (slot_value (q_arg3 (o).p))) * - real (slot_value (q_arg1 (o).p)); - s7_double x2= - float_vector_ref_d_7pi (o->sc, slot_value (q_func2_arg (o).p), - integer (slot_value (q_func3_arg (o).p))) * - real (slot_value (q_arg4 (o).p)); - slot_set_value (q_arg1 (o).p, make_real (o->sc, x1 + x2)); - return (slot_value (q_arg1 (o).p)); -} - -static s7_pointer -opt_set_p_d_f_mm_subtract (opt_info* o) { - s7_double x1= float_vector_ref_d_7pi (o->sc, slot_value (q_arg2 (o).p), - integer (slot_value (q_arg3 (o).p))) * - real (slot_value (q_arg1 (o).p)); - s7_double x2= - float_vector_ref_d_7pi (o->sc, slot_value (q_func2_arg (o).p), - integer (slot_value (q_func3_arg (o).p))) * - real (slot_value (q_arg4 (o).p)); - slot_set_value (q_arg1 (o).p, make_real (o->sc, x1 - x2)); - return (slot_value (q_arg1 (o).p)); -} - -static s7_pointer -opt_set_p_c (opt_info* o) { - slot_set_value (q_arg1 (o).p, q_arg2 (o).p); - return (q_arg2 (o).p); -} - -static s7_pointer -opt_set_p_i_fo (opt_info* o) { - s7_int i = q_func (o).i_ii_f (integer (slot_value (q_arg2 (o).p)), - integer (slot_value (q_arg3 (o).p))); - s7_pointer val= make_integer (o->sc, i); - slot_set_value (q_arg1 (o).p, val); - return (val); -} - -static s7_pointer -opt_set_p_i_fo_add (opt_info* o) { - s7_int i= - integer (slot_value (q_arg2 (o).p)) + integer (slot_value (q_arg3 (o).p)); - s7_pointer val= make_integer (o->sc, i); - slot_set_value (q_arg1 (o).p, val); - return (val); -} - -static s7_pointer -opt_set_p_i_fo1 (opt_info* o) { - s7_int i= - q_func (o).i_ii_f (integer (slot_value (q_arg2 (o).p)), q_arg3 (o).i); - s7_pointer val= make_integer (o->sc, i); - slot_set_value (q_arg1 (o).p, val); - return (val); -} - -static s7_pointer -opt_set_p_i_fo1_add (opt_info* o) { - s7_int i = integer (slot_value (q_arg2 (o).p)) + q_arg3 (o).i; - s7_pointer val= make_integer (o->sc, i); - slot_set_value (q_arg1 (o).p, val); - return (val); -} - -static bool -set_p_i_f_combinable (s7_scheme* sc, opt_info* opc) { - /* arg1 is set already */ - if ((sc->pc > 1) && (opc == sc->opts[sc->pc - 2])) { - opt_info* o1= sc->opts[sc->pc - 1]; - if ((q_call (o1).fi == opt_i_ii_ss) || - (q_call (o1).fi == opt_i_ii_ss_add)) { - q_func (opc).i_ii_f= q_func (o1).i_ii_f; - q_arg2 (opc).p = q_arg1 (o1).p; - q_arg3 (opc).p = q_arg2 (o1).p; - q_call (opc).fp= (q_call (o1).fi == opt_i_ii_ss_add) ? opt_set_p_i_fo_add - : opt_set_p_i_fo; - backup_pc (sc); - return_true (sc, NULL); - } - if ((q_call (o1).fi == opt_i_ii_sc) || - (q_call (o1).fi == opt_i_ii_sc_add) || - (q_call (o1).fi == opt_i_ii_sc_sub)) { - q_func (opc).i_ii_f= q_func (o1).i_ii_f; - q_arg2 (opc).p = q_arg1 (o1).p; - q_arg3 (opc).i = q_arg2 (o1).i; - q_call (opc).fp= (q_call (o1).fi == opt_i_ii_sc_add) ? opt_set_p_i_fo1_add - : opt_set_p_i_fo1; - /* opt_if_nbp: opt_set_p_i_fo1_add b/shoot */ - backup_pc (sc); - return_true (sc, NULL); - } - } - 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 ((q_call (o1).fd == opt_d_mm_fff) && - ((q_func (o1).d_dd_f == add_d_dd) || - (q_func (o1).d_dd_f == subtract_d_dd))) { - opt_info* o2 = sc->opts[sc->pc - 2]; - q_call (opc).fp = (q_func (o1).d_dd_f == add_d_dd) - ? opt_set_p_d_f_mm_add - : opt_set_p_d_f_mm_subtract; - q_arg1 (opc).p = q_arg1 (o2).p; - q_arg2 (opc).p = q_arg2 (o2).p; - q_arg3 (opc).p = q_arg3 (o2).p; - o1 = sc->opts[sc->pc - 1]; - q_arg4 (opc).p = q_arg1 (o1).p; - q_func2_arg (opc).p= q_arg2 (o1).p; - q_func3_arg (opc).p= q_arg3 (o1).p; - sc->pc-= 3; - return_true (sc, NULL); - } - } - return_false (sc, NULL); +static s7_pointer fx_href_s_vref(s7_scheme *sc, s7_pointer arg) +{ + return(hash_table_ref_p_pp(sc, lookup(sc, cadr(arg)), s7i_vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt1_sym(opt3_pair(arg)))))); } -static bool -is_some_number (s7_scheme* sc, const 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_byte_symbol) || - (tp == sc->is_rational_symbol)); +static s7_pointer fx_lref_s_vref(s7_scheme *sc, s7_pointer arg) /* tbig */ +{ + return(let_ref(sc, lookup(sc, cadr(arg)), s7i_vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt1_sym(opt3_pair(arg)))))); } -static bool -check_type_uncertainty (s7_scheme* sc, s7_pointer target, s7_pointer expr, - opt_info* opc, int32_t start_pc) { - const s7_pointer code= sc->code; - /* if we're optimizing do, sc->code is (sometimes) ((vars...) (end...) expr) - * where expr is the do body, but it can also be for-each etc */ +static s7_pointer fx_vref_s_add(s7_scheme *sc, s7_pointer arg) +{ + return(s7i_vector_ref_p_pp(sc, lookup(sc, cadr(arg)), add_p_pp_wrapped(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt1_sym(opt3_pair(arg)))))); +} - /* maybe the type uncertainty is not a problem */ - if ((is_pair ( - code)) && /* t101-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 - expr -- tree_memq below for reality check */ - (is_pair (cadr (code)))) { - s7_int counts; - if ((!has_low_count (code)) && /* only set below */ - (s7_tree_memq (sc, expr, code))) { - if (is_pair (caar (code))) { - counts= tree_count (sc, target, car (code), 0) + - tree_count (sc, target, caadr (code), 0) + - tree_count (sc, target, cddr (code), 0); - for (s7_pointer vars= car (code); is_pair (vars); vars= cdr (vars)) { - const s7_pointer binding= car (vars); - if ((is_proper_list_2 (sc, binding)) && (car (binding) == 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_low_count (code); - sc->pc= start_pc; - if (cell_optimize (sc, cddr (expr))) { - /* fprintf(stderr, "%d: %s %s\n", __LINE__, display(expr), - * display(target)); */ - q_call (opc).fp = opt_set_p_p_f; - q_func1_arg (opc).o1= sc->opts[start_pc]; - q_func1 (opc).fp = q_call (sc->opts[start_pc]).fp; - return_true (sc, expr); - } - } - } - return_false (sc, expr); -} - -static s7_pointer -opt_starlet_set (opt_info* o) { - s7_pointer val= q_func (o).fp (q_arg2 (o).o1); - return (starlet_set_1 (o->sc, q_arg1 (o).p, val)); -} - -static s7_pointer -opt_starlet_set_i (opt_info* o) { - return (starlet_set_1 (o->sc, q_arg1 (o).p, q_arg2 (o).p)); -} - -static s7_pointer -list_increment_p_pip_unchecked (opt_info* o) { - s7_scheme* sc = o->sc; - s7_pointer num = slot_value (q_arg2 (o).p), lst, p; - s7_int index= integer (num); - if ((index < 0) || (index > sc->max_list_length)) - list_set_index_check_nr (sc, index); - lst= slot_value (q_arg1 (o).p); - p = lst; - for (s7_int i= 0; ((is_pair (p)) && (i < index)); i++, p= cdr (p)) - ; - if (!is_pair (p)) { - if (is_null (p)) - out_of_range_error_nr (sc, sc->list_set_symbol, int_two, - wrap_integer (sc, index), it_is_too_large_string); - wrong_type_error_nr (sc, sc->list_set_symbol, 1, lst, a_proper_list_string); - } - { - s7_pointer value= g_add_xi (sc, car (p), integer (q_arg3 (o).p), index); - set_car (p, value); - return (value); - } +static inline s7_pointer fx_vref_vref_3(s7_scheme *sc, s7_pointer vec, s7_pointer num1, s7_pointer num2) +{ + if ((is_t_integer(num1)) && (is_t_integer(num2)) && ((is_t_vector(vec)) && (vector_rank(vec) == 1))) + { + const s7_int index1 = integer(num1), index2 = integer(num2); + if ((index1 >= 0) && (index2 >= 0) && (index1 < vector_length(vec))) + { + s7_pointer vec_in_vec = vector_element(vec, index1); + if ((is_t_vector(vec_in_vec)) && (vector_rank(vec_in_vec) == 1) && (index2 < vector_length(vec_in_vec))) + return(vector_element(vec_in_vec, index2)); + }} + return(s7i_vector_ref_p_pp(sc, s7i_vector_ref_p_pp(sc, vec, num1), num2)); } -static bool -opt_cell_set (s7_scheme* sc, s7_pointer expr) /* len == 3 here (p_syntax_ok) */ -{ - opt_info* opc = alloc_opt_info (sc); - const s7_pointer target= cadr (expr); - const s7_pointer value = caddr (expr); - if (OPT_PRINT) - fprintf (stderr, " opt_cell_set[%d]: %s, target: %s\n", __LINE__, - display (expr), display (target)); - if (is_symbol (target)) { - s7_pointer settee; - if ((is_constant_symbol (sc, target)) || - ((is_slot (global_slot (target))) && - (slot_has_setter (global_slot (target))))) - return_false (sc, expr); - - settee= s7_slot (sc, target); - if ((is_slot (settee)) && (!is_immutable_slot (settee)) && - (!is_syntax (slot_value (settee)))) { - const int32_t start_pc= sc->pc; - const s7_pointer stype = s7_type_of (sc, slot_value (settee)); - s7_pointer atype; - q_arg1 (opc).p= settee; - if (slot_has_setter (settee)) { - if ((is_c_function (slot_setter (settee))) && - (is_bool_function (slot_setter (settee))) && - (stype == opt_arg_type (sc, cddr (expr))) && - (cell_optimize (sc, cddr (expr)))) { - q_call (opc).fp = opt_set_p_p_f_with_setter; - q_func1_arg (opc).o1= sc->opts[start_pc]; - q_func1 (opc).fp = q_call (sc->opts[start_pc]).fp; - return_true (sc, expr); - } - return_false (sc, expr); - } - if (stype == sc->is_integer_symbol) { - if (is_symbol (value)) { - const s7_pointer val_slot= opt_integer_symbol (sc, value); - if (val_slot) { - q_arg2 (opc).p = val_slot; - q_call (opc).fp= opt_set_p_i_s; - return_true (sc, expr); - } - } - else { - q_func1_arg (opc).o1= sc->opts[sc->pc]; - if (!int_optimize (sc, cddr (expr))) - return (check_type_uncertainty (sc, target, expr, opc, start_pc)); - if (!set_p_i_f_combinable (sc, opc)) { - q_call (opc).fp = opt_set_p_i_f; - q_func1 (opc).fi= q_func1_arg (opc).q_call (o1).fi; - } - return_true (sc, expr); - } - return_false (sc, expr); - } - if (stype == sc->is_float_symbol) { - if (is_t_real (value)) { - q_arg2 (opc).p = value; - q_call (opc).fp= opt_set_p_c; - return_true (sc, expr); - } - if (is_symbol (caddr (expr))) { - const s7_pointer val_slot= opt_float_symbol (sc, value); - if (val_slot) { - q_arg2 (opc).p = val_slot; - q_call (opc).fp= opt_set_p_d_s; - return_true (sc, expr); - } - } - else { - if ((is_pair (value)) && (float_optimize (sc, cddr (expr)))) { - if (!set_p_d_f_combinable (sc, opc)) { - q_func1_arg (opc).o1= sc->opts[start_pc]; - q_func1 (opc).fd = q_call (sc->opts[start_pc]).fd; - q_call (opc).fp = (q_func1 (opc).fd == opt_d_dd_sf_add) - ? opt_set_p_d_f_sf_add - : opt_set_p_d_f; - } - return_true (sc, expr); - } - return (check_type_uncertainty (sc, target, expr, opc, start_pc)); - } - return_false (sc, expr); - } - atype= opt_arg_type (sc, cddr (expr)); - if ((is_some_number (sc, atype)) && (!is_some_number (sc, stype))) - return_false (sc, expr); - if ((stype != atype) && (is_symbol (stype)) && - (((t_sequence_p[symbol_type (stype)]) && - (stype != sc->is_null_symbol) && (stype != sc->is_pair_symbol) && - (stype != sc->is_list_symbol) && - (stype != sc->is_proper_list_symbol)) || - (stype == sc->is_iterator_symbol))) - return_false (sc, expr); - /* TODO: here if atype is float? or integer? or boolean? we should call - * the appropriate optimizer! */ - if (cell_optimize (sc, cddr (expr))) { - /* fprintf(stderr, "%d: %s %s %s %s\n", __LINE__, display(expr), - * display(target), display(atype), display(stype)); */ - q_call (opc).fp = opt_set_p_p_f; - q_func1_arg (opc).o1= sc->opts[start_pc]; - q_func1 (opc).fp = q_call (sc->opts[start_pc]).fp; - return_true (sc, expr); - } - } - return_false (sc, expr); +#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, opt1_sym(opt3_pair(arg)), arg), Lookup3(sc, caddr(arg), arg))); \ } - 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 obj, index_type; - const s7_pointer index = cadr (target); - const s7_pointer obj_slot= s7_slot (sc, car (target)); - if (!is_slot (obj_slot)) return_false (sc, expr); - obj = slot_value (obj_slot); - q_arg1 (opc).p= obj_slot; - - if (!is_mutable_sequence ( - obj)) /* includes *s7* because *s7* itself is immutable? */ - { - /* a ridiculous experiment... */ - if ((car (target) == sc->port_string_symbol) && - (is_eq_initial_c_function_data (car (target), obj)) && - (is_normal_symbol (index)) && - (opt_arg_type (sc, cddr (expr)) == sc->is_string_symbol)) { - const s7_pointer port_type= opt_arg_type (sc, cdr (target)); - if ((port_type == sc->is_input_port_symbol) || - (port_type == sc->is_output_port_symbol)) { - const int32_t start_pc= sc->pc; - q_arg2 (opc).p = s7_t_slot (sc, index); - if ((is_slot (q_arg2 (opc).p)) && - (is_string_port (slot_value (q_arg2 (opc).p))) && - (cell_optimize (sc, cddr (expr)))) { - q_func1_arg (opc).o1= sc->opts[start_pc]; - q_func1 (opc).fp = q_call (sc->opts[start_pc]).fp; - q_call (opc).fp = (port_type == sc->is_input_port_symbol) - ? opt_set_input_port_string_p_p_f - : opt_set_output_port_string_p_p_f; - return_true (sc, expr); - } - } - } - if (obj == sc->starlet) /* *s7* is open (for let_set_fallback?) */ - { - if ((is_symbol_and_keyword (index)) || (is_quoted_symbol (sc, index))) { - s7_pointer sym= (is_quoted_symbol (sc, index)) - ? cadr (index) - : keyword_symbol (index); - if (starlet_symbol_id (sym) != sl_no_field) { - q_arg1 (opc).p= sym; - if (is_t_integer (caddr (expr))) { - q_call (opc).fp= opt_starlet_set_i; - q_arg2 (opc).p = caddr (expr); - return_true (sc, expr); - } - q_arg2 (opc).o1= sc->opts[sc->pc]; - if (cell_optimize (sc, cddr (expr))) { - q_call (opc).fp= opt_starlet_set; - q_func (opc).fp= - q_arg2 (opc).q_call (o1).fp; /* TODO: fix this! */ - return_true (sc, expr); - } - } - } - } - return_false (sc, expr); - } - index_type= opt_arg_type (sc, cdr (target)); - switch (type (obj)) { - case T_STRING: { - s7_pointer val_type; - if ((index_type != sc->is_integer_symbol) || (is_pair (cddr (target)))) - return_false (sc, expr); - val_type= opt_arg_type (sc, cddr (expr)); - if (val_type != sc->is_char_symbol) return_false (sc, expr); - q_func (opc).p_pip_f= string_set_p_pip_unchecked; - } break; - case T_VECTOR: - if (index_type != sc->is_integer_symbol) return_false (sc, expr); - if (is_null (cddr (target))) { - if (vector_rank (obj) != 1) return_false (sc, expr); - q_func (opc).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, expr); - q_func (opc).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 (expr), - 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 (expr))) { - q_temp (opc).fd= q_call (opc).fd; - q_call (opc).fp= d_to_p; - return_true (sc, expr); - } - return_false (sc, expr); - - case T_COMPLEX_VECTOR: - if (index_type != sc->is_integer_symbol) return_false (sc, expr); - if (is_null (cddr (target))) { - if (vector_rank (obj) != 1) return_false (sc, expr); - q_func (opc).p_pip_f= complex_vector_set_p_pip_unchecked; - } - else return_false (sc, expr); - break; - - 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 (expr))) { - q_temp (opc).fi= q_call (opc).fi; - q_call (opc).fp= i_to_p; - return_true (sc, expr); - } - return_false (sc, expr); - - 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 */ - const s7_d_7pid_t func= s7_d_7pid_function (c_object_setf (sc, obj)); - if (func) { - const s7_pointer slot= opt_integer_symbol (sc, index); - q_func (opc).d_7pid_f= func; - q_func2_arg (opc).o1 = sc->opts[sc->pc]; - if (slot) { - if (float_optimize (sc, cddr (expr))) { - q_temp (opc).fd= opt_d_7pid_ssf; - q_call (opc).fp= - d_to_p; /* cell_optimize, so need to return s7_pointer */ - q_arg2 (opc).p = slot; - q_func2 (opc).fd= q_func2_arg (opc).q_call (o1).fd; - return_true (sc, expr); - } - } - else if (int_optimize (sc, cdr (target))) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cddr (expr))) { - q_temp (opc).fd = opt_d_7pid_sff; - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_func3 (opc).fd= q_func3_arg (opc).q_call (o1).fd; - q_call (opc).fp = d_to_p; - return_true (sc, expr); - } - } - } - } - return_false (sc, expr); - - case T_PAIR: - if (index_type != sc->is_integer_symbol) - return_false (sc, - expr); /* (let ((tf13 '(()))) (define (f) (do ((i 0 (+ i - 1))) ((= i 1)) (set! (tf13 letrec*) 0))) (f)) */ - if (is_pair (cddr (target))) return_false (sc, expr); - q_func (opc).p_pip_f= list_set_p_pip_unchecked; - - { /* an experiment -- is this ever hit in normal code? (for tref.scm) */ - if ((is_pair (value)) && (car (value) == sc->add_symbol) && - (is_pair (cdr (value))) && (is_pair (cadr (value))) && - (is_pair (cddr (value))) && (is_t_integer (caddr (value))) && - (is_null (cdddr (value))) && (is_symbol (index)) && - (car (target) == (caadr (value))) && (is_pair (cdadr (value))) && - (is_null (cddadr (value))) && (index == cadadr (value))) { - const s7_pointer slot= opt_simple_symbol (sc, index); - if ((slot) && (is_t_integer (slot_value (slot)))) { - q_arg2 (opc).p = slot; - q_arg3 (opc).p = caddr (value); - q_call (opc).fp= list_increment_p_pip_unchecked; - return_true (sc, expr); - } - } - } - break; +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) - case T_HASH_TABLE: - if (is_pair (cddr (target))) return_false (sc, expr); - q_func (opc).p_ppp_f= s7_hash_table_set; - break; +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)))); +} - 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))) || (is_openlet (obj))) - return_false (sc, expr); - if ((is_symbol_and_keyword (index)) || ((is_quoted_symbol (sc, index)))) - q_func (opc).p_ppp_f= let_set_1; - else - q_func (opc).p_ppp_f= - let_set_p_ppp_2; /* (set! (L3 'x) (+ (L3 'x) 1)) */ - break; +static s7_pointer fx_c_opscq_c(s7_scheme *sc, s7_pointer arg) +{ + const s7_pointer arg1 = cadr(arg); + set_car(sc->t2_1, lookup(sc, cadr(arg1))); + set_car(sc->t2_2, opt1_con(cdr(arg1))); + set_car(sc->t2_1, fn_proc(arg1)(sc, sc->t2_1)); + set_car(sc->t2_2, caddr(arg)); + return(fn_proc(arg)(sc, sc->t2_1)); +} - default: - return_false (sc, expr); - } - if (is_symbol (index)) { - int32_t start = sc->pc; - const s7_pointer index_slot= opt_simple_symbol (sc, index); - if (index_slot) { - q_arg2 (opc).p= index_slot; - if ((is_t_integer (slot_value (index_slot))) && - (has_loop_end (q_arg2 (opc).p))) { - if (is_string (obj)) { - if (loop_end (q_arg2 (opc).p) <= string_length (obj)) - q_func (opc).p_pip_f= string_set_p_pip_direct; - } - else if (is_byte_vector (obj)) { - if (loop_end (q_arg2 (opc).p) <= byte_vector_length (obj)) - q_func (opc).p_pip_f= byte_vector_set_p_pip_direct; - } - else if ((is_complex_vector (obj)) && - (loop_end (q_arg2 (opc).p) <= vector_length (obj))) { - q_func (opc).p_pip_f= complex_vector_set_p_pip_direct; - } - else if (is_any_vector (obj)) /* true for all 3 vectors */ - { - if ((is_any_vector (obj)) && - (loop_end (q_arg2 (opc).p) <= vector_length (obj))) { - if (is_typed_t_vector (obj)) - q_func (opc).p_pip_f= typed_t_vector_set_p_pip_direct; - else q_func (opc).p_pip_f= t_vector_set_p_pip_direct; - } - } - } - if (is_symbol (value)) { - const s7_pointer val_slot= opt_simple_symbol (sc, value); - if (val_slot) { - s7_p_ppp_t func1; - if ((is_string (obj)) || (is_any_vector (obj)) || (is_pair (obj))) { - q_arg3 (opc).p = val_slot; - q_call (opc).fp= opt_p_pip_sss; - return_true (sc, expr); - } - if ((is_let (obj)) && (is_keyword (index)) && - (q_func (opc).p_ppp_f == let_set_1) && /* (set! (L3 :x) i) */ - (use_pps_slot_set (sc, opc, obj, keyword_symbol (index), - val_slot))) - return_true (sc, expr); - func1 = q_func (opc).p_ppp_f; - q_arg3 (opc).p= val_slot; - q_call (opc).fp= - (func1 == multiply_p_ppp) - ? opt_p_ppp_sss_mul - : (((is_hash_table (obj)) && (func1 == s7_hash_table_set)) - ? opt_p_ppp_sss_hset - : opt_p_ppp_sss); - return_true (sc, expr); - } - } - else if ((!is_pair (value)) || (is_proper_quote (sc, value))) { - q_arg3 (opc).p= (!is_pair (value)) ? value : cadr (value); - if ((is_string (obj)) || (is_any_vector (obj)) || (is_pair (obj))) { - q_call (opc).fp= opt_p_pip_ssc; - return_true (sc, expr); - } - if ((is_let (obj)) && (is_keyword (index)) && - (q_func (opc).p_ppp_f == let_set_1) && /* (set! (L3 :x) 0) */ - (use_ppc_slot_set (sc, opc, obj, keyword_symbol (index), - q_arg3 (opc).p))) - return_true (sc, expr); - q_call (opc).fp= opt_p_ppp_ssc; - return_true (sc, expr); - } - if (cell_optimize (sc, cddr (expr))) { - q_func1_arg (opc).o1= sc->opts[start]; - q_func1 (opc).fp = q_call (sc->opts[start]).fp; - if ((is_string (obj)) || (is_any_vector (obj)) || (is_pair (obj))) { - if (p_pip_ssf_combinable (sc, opc, start)) return_true (sc, expr); - q_call (opc).fp= opt_p_pip_ssf; - return_true (sc, expr); - } - if ((is_let (obj)) && (is_keyword (index)) && - (q_func (opc).p_ppp_f == - let_set_1) && /* (set! (L3 :x) (+ (L3 'x) 1)) */ - (use_ppf_slot_set (sc, opc, obj, keyword_symbol (index)))) - return_true (sc, expr); - q_call (opc).fp= opt_p_ppp_ssf; - return_true (sc, expr); - } - } - } - else /* index not a symbol */ - { - opt_info* o1; - if ((is_string (obj)) || (is_pair (obj)) || (is_any_vector (obj))) { - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cdr (target))) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (cell_optimize (sc, cddr (expr))) { - q_call (opc).fp = opt_p_pip_sff; - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_func3 (opc).fp= q_func3_arg (opc).q_call (o1).fp; - return_true (sc, expr); - } - } - return_false (sc, expr); - } - if (is_quoted_symbol (sc, index)) { - if (is_symbol (value)) { - const s7_pointer val_slot= opt_simple_symbol (sc, value); - if (val_slot) { - q_arg2 (opc).p = cadr (index); - q_arg3 (opc).p = val_slot; - q_call (opc).fp= opt_p_ppp_scs; - if ((is_let (obj)) && (q_func (opc).p_ppp_f == let_set_1)) - use_pps_slot_set (sc, opc, obj, cadr (index), val_slot); - return_true (sc, expr); - } - } - if ((!is_pair (value)) && (is_let (obj)) && - (q_func (opc).p_ppp_f == let_set_1) && - (use_ppc_slot_set (sc, opc, obj, cadr (index), value))) - return_true (sc, expr); - } - o1= sc->opts[sc->pc]; - if (cell_optimize (sc, cdr (target))) { - opt_info* o2; - if (is_symbol (value)) { - const s7_pointer val_slot= opt_simple_symbol (sc, value); - if (val_slot) { - q_arg2 (opc).p = val_slot; - q_call (opc).fp = opt_p_ppp_sfs; - q_func1_arg (opc).o1= o1; - q_func1 (opc).fp = q_call (o1).fp; - return_true (sc, expr); - } - } - o2= sc->opts[sc->pc]; - if (cell_optimize (sc, cddr (expr))) { - q_call (opc).fp= opt_p_ppp_sff; - if ((is_let (obj)) && (is_quoted_symbol (sc, index)) && - (q_func (opc).p_ppp_f == - let_set_1) && /* (set! (L3 'x) (+ (L3 'x) 1)) */ - (use_ppf_slot_set (sc, opc, obj, cadr (index)))) { - q_func1_arg (opc).o1= o2; - q_func1 (opc).fp = q_func1_arg (opc).q_call (o1).fp; - return_true (sc, expr); - } - q_func2_arg (opc).o1= o1; - q_func2 (opc).fp = q_call (o1).fp; - q_func3_arg (opc).o1= o2; - q_func3 (opc).fp = q_call (o2).fp; - return_true (sc, expr); - } - } - } +#define fx_c_opssq_c_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + const s7_pointer arg1 = cadr(arg); \ + set_car(sc->t2_1, Lookup1(sc, cadr(arg1), arg1)); \ + set_car(sc->t2_2, Lookup2(sc, opt1_sym(cdr(arg1)), arg1)); \ + set_car(sc->t2_1, fn_proc(arg1)(sc, sc->t2_1)); \ + set_car(sc->t2_2, opt3_con(cdr(arg))); /* caddr */ \ + return(fn_proc(arg)(sc, sc->t2_1)); \ } - return_false (sc, expr); -} -/* -------- cell_begin -------- */ -#define q_begin_arg(o, i) o->v[i + 2] +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 -opt_begin_p (opt_info* o) { - opt_info* o1; - s7_int i, len= q_arg1 (o).i; /* len = 1 if 2 exprs, etc */ - for (i= 0; i < len; i++) { - o1= q_begin_arg (o, i).o1; - q_call (o1).fp (o1); - } - o1= q_begin_arg (o, i).o1; - return (q_call (o1).fp (o1)); -} -static s7_pointer -opt_begin_p_1 (opt_info* o) { - q_func (o).fp (q_arg2 (o).o1); - return (q_p_func1_call (o)); +static s7_pointer fx_c_opstq_c_direct(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer arg1 = cadr(arg); + return(((s7_p_pp_t)opt3_direct(arg))(sc, fn_proc(arg1)(sc, set_plist_2(sc, lookup(sc, cadr(arg1)), t_lookup(sc, caddr(arg1), arg))), opt3_con(cdr(arg)))); } -static void -oo_idp_nr_fixup (opt_info* start) { - if (q_call (start).fp == d_to_p) { - q_call (start).fp= d_to_p_nr; - if (q_temp (start).fd == opt_d_7pid_ssf) - q_call (start).fp= opt_d_7pid_ssf_nr; - else if (q_temp (start).fd == opt_d_7pid_ssfo_fv) { - q_call (start).fp= opt_d_7pid_ssfo_fv_nr; - if (q_func2 (start).d_dd_f == add_d_dd) - q_call (start).fp= opt_d_7pid_ssfo_fv_add_nr; - else if (q_func2 (start).d_dd_f == subtract_d_dd) - q_call (start).fp= opt_d_7pid_ssfo_fv_sub_nr; - } - } - else if (q_call (start).fp == i_to_p) q_call (start).fp= i_to_p_nr; -} - -static bool -opt_cell_begin (s7_scheme* sc, s7_pointer expr, int32_t len) { - opt_info* opc; - s7_pointer p= cdr (expr); - if (len > (num_vunions - 3)) return_false (sc, expr); - opc= alloc_opt_info (sc); - for (int32_t i= 0; is_pair (p); i++, p= cdr (p)) { - opt_info* start= sc->opts[sc->pc]; - if (!cell_optimize (sc, p)) return_false (sc, expr); - if (is_pair (cdr (p))) oo_idp_nr_fixup (start); - q_begin_arg (opc, i).o1= start; - } - q_arg1 (opc).i= len - 2; - if (len == 3) { - q_call (opc).fp = opt_begin_p_1; - q_func1_arg (opc).o1= q_begin_arg (opc, 1).o1; - q_func1 (opc).fp = q_begin_arg (opc, 2).q_call (o1).fp; - q_func (opc).fp = q_begin_arg (opc, 0).q_call (o1).fp; +#define fx_c_opsq_s_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer arg1 = cadr(arg); \ + set_car(sc->t2_1, fn_proc(arg1)(sc, with_list_t1(sc, Lookup1(sc, cadr(arg1), arg)))); /* also opt1_sym(cdr(arg)) */ \ + set_car(sc->t2_2, Lookup2(sc, opt3_sym(arg), arg)); /* caddr(arg) */ \ + return(fn_proc(arg)(sc, sc->t2_1)); \ } - else q_call (opc).fp= opt_begin_p; - return_true (sc, expr); -} - -/* -------- cell_when|unless -------- */ -#define q_when_body_len(o) o->v[1] -#define q_when_test_arg(o) o->v[3] -#define q_when_test_func(o) o->v[4] -#define q_when_test_call(o) o->v[4].fb (o->v[3].o1) -#define q_when_body(o, i) o->v[i + 5] -#define q_when_p1_call(o) o->v[6].fp (o->v[5].o1) -#define q_when_p1_func(o) o->v[6] -#define q_when_p1_arg(o) o->v[5] -#define q_when_p2_call(o) o->v[8].fp (o->v[7].o1) -#define q_when_p2_func(o) o->v[8] -#define q_when_p2_arg(o) o->v[7] +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) -static s7_pointer -opt_when_p_2 (opt_info* o) { - if (q_when_test_call (o)) { - q_when_p1_call (o); - return (q_when_p2_call (o)); - } - return (o->sc->unspecified); -} -static s7_pointer -opt_when_p (opt_info* o) { - if (q_when_test_call (o)) { - s7_int i, len= q_when_body_len (o).i - 1; - opt_info* o1; - for (i= 0; i < len; i++) { - o1= q_when_body (o, i).o1; - q_call (o1).fp (o1); - } - o1= q_when_body (o, i).o1; - return (q_call (o1).fp (o1)); +#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))); \ } - return (o->sc->unspecified); -} - -static s7_pointer -opt_when_p_1 (opt_info* o) { - opt_info* o1; - if (!q_when_test_call (o)) return (o->sc->unspecified); - o1= q_when_body (o, 0).o1; - return (q_call (o1).fp (o1)); -} - -static s7_pointer -opt_unless_p (opt_info* o) { - opt_info* o1; - s7_int i, len; - if (q_when_test_call (o)) return (o->sc->unspecified); - len= q_when_body_len (o).i - 1; - for (i= 0; i < len; i++) { - o1= q_when_body (o, i).o1; - q_call (o1).fp (o1); - } - o1= q_when_body (o, i).o1; - return (q_call (o1).fp (o1)); -} -static s7_pointer -opt_unless_p_1 (opt_info* o) { - opt_info* o1; - if (q_when_test_call (o)) return (o->sc->unspecified); - o1= q_when_body (o, 0).o1; - return (q_call (o1).fp (o1)); -} +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) -static bool -opt_cell_when (s7_scheme* sc, s7_pointer expr, int32_t len) { - s7_pointer p; - int32_t k; - opt_info* opc; - if (len > (num_vunions - 6)) return_false (sc, expr); - opc = alloc_opt_info (sc); - q_when_test_arg (opc).o1= sc->opts[sc->pc]; - if (!bool_optimize (sc, cdr (expr))) return_false (sc, expr); - for (k= 0, p= cddr (expr); is_pair (p); k++, p= cdr (p)) { - opt_info* start= sc->opts[sc->pc]; - if (!cell_optimize (sc, p)) return_false (sc, expr); - if (is_pair (cdr (p))) oo_idp_nr_fixup (start); - q_when_body (opc, k).o1= start; +#define fx_cons_car_s_s_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer 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))); \ } - q_when_test_func (opc).fb= q_when_test_arg (opc).q_call (o1).fb; - q_when_body_len (opc).i = len - 2; - if (car (expr) == sc->when_symbol) { - if (len == 3) /* 1 expr */ - q_call (opc).fp= opt_when_p_1; - else if (len == 4) /* 2 exprs */ - { - q_call (opc).fp = opt_when_p_2; - q_when_p2_arg (opc).o1= q_when_body (opc, 1).o1; /* make room... */ - q_when_p2_func (opc).fp= - q_when_p2_arg (opc).q_call (o1).fp; /* order matters */ - q_when_p1_func (opc).fp= - q_when_p1_arg (opc).q_call (o1).fp; /* also q_when_body(opc, 0) */ - } - else q_call (opc).fp= opt_when_p; - } - else q_call (opc).fp= (len == 3) ? opt_unless_p_1 : opt_unless_p; - return_true (sc, expr); -} -/* -------- cell_cond -------- */ +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) -#define q_cond_o1 3 -#define q_cond_clause_o1 5 -#define q_cond_val1(o) o->v[6] -#define q_cond_val2(o) o->v[7] -#define q_cond_clause(o, i) o->v[i + q_cond_clause_o1] -#define q_cond(o, i) o->v[i + q_cond_o1] -static s7_pointer -cond_value (opt_info* o) { - opt_info* o1; - s7_int i, len= q_arg1 (o).i - 1; - for (i= 0; i < len; i++) { - o1= q_cond_clause (o, i).o1; - q_call (o1).fp (o1); - } - o1= q_cond_clause (o, i).o1; - return (q_call (o1).fp (o1)); +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))); } -static s7_pointer -opt_cond (opt_info* top) { - s7_int len= q_arg2 (top).i; - for (s7_int clause= 0; clause < len; clause++) { - opt_info* o1= q_cond (top, clause).o1; - opt_info* o2= q_func1_arg (o1).o1; - if (q_call (o2).fb (o2)) return (cond_value (o1)); - } - return (top->sc->unspecified); -} - -static s7_pointer -opt_cond_1 (opt_info* o) { - return ((q_b_func1_call (o)) ? cond_value (q_cond_val1 (o).o1) - : o->sc->unspecified); -} /* cond as when */ -static s7_pointer -opt_cond_1b (opt_info* o) { - return ((q_func1_arg (o).q_temp (o1).fp (q_func1_arg (o).o1) != o->sc->F) - ? cond_value (q_cond_val1 (o).o1) - : o->sc->unspecified); -} - -static s7_pointer -opt_cond_2 (opt_info* o) /* 2 branches, results 1 expr, else */ -{ - opt_info* o1= (q_b_func1_call (o)) ? q_cond_val1 (o).o1 : q_cond_val2 (o).o1; - return (q_call (o1).fp (o1)); -} - -static bool -opt_cell_cond (s7_scheme* sc, s7_pointer expr) { - /* 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 last_clause= NULL; - int32_t branches= 0, max_blen= 0; - opt_info* top = alloc_opt_info (sc); - const int32_t start_pc= sc->pc; - for (s7_pointer clauses= cdr (expr); is_pair (clauses); - clauses = cdr (clauses), branches++) { - opt_info* opc; - s7_pointer clause= car (clauses), cp; - int32_t blen; - if ((branches >= (num_vunions - q_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; - q_cond (top, branches).o1= sc->opts[sc->pc]; - opc = alloc_opt_info (sc); - q_func1_arg (opc).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 - q_cond_clause_o1) return_false (sc, cp); - q_cond_clause (opc, blen).o1= sc->opts[sc->pc]; - if (!cell_optimize (sc, cp)) return_false (sc, cp); - } - if (!is_null (cp)) return_false (sc, cp); - q_arg1 (opc).i= blen; - if (max_blen < blen) max_blen= blen; - q_call (opc).fp= opt_cond; /* a placeholder */ - } - if (branches == 1) { - opt_info* o1 = sc->opts[start_pc + 1]; - q_call (top).fp = (q_call (o1).fb == p_to_b) ? opt_cond_1b : opt_cond_1; - q_func1_arg (top).o1= o1; - q_func1 (top).fb = q_call (o1).fb; - q_cond_val1 (top).o1= sc->opts[start_pc]; - return_true (sc, expr); - } - if (branches == 2) { - if ((max_blen == 1) && ((car (last_clause) == sc->T) || - ((car (last_clause) == sc->else_symbol) && - (is_global (sc->else_symbol))))) { - opt_info* o1; - q_cond_val1 (top).o1= q_cond (top, 0).q_cond_clause (o1, 0).o1; - q_cond_val2 (top).o1= q_cond (top, 1).q_cond_clause (o1, 0).o1; - o1 = sc->opts[start_pc + 1]; - q_func1_arg (top).o1= o1; - q_func1 (top).fb = q_call (o1).fb; - q_call (top).fp = opt_cond_2; - return_true (sc, expr); - } +#define fx_c_opsq_cs_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + set_car(sc->t3_1, fn_proc(cadr(arg))(sc, with_list_t1(sc, Lookup1(sc, opt3_sym(cdr(arg)), arg)))); /* cadadr(arg) */ \ + 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)); \ } - q_arg2 (top).i = branches; - q_call (top).fp= opt_cond; - return_true (sc, expr); -} -/* -------- cell_and|or -------- */ -#define q_or_clause(o, i) o->v[i + 3] +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) -static s7_pointer -opt_and_pp (opt_info* o) { - return ((q_p_func2_call (o) == o->sc->F) ? o->sc->F : q_p_func3_call (o)); -} -static s7_pointer -opt_and_any_p (opt_info* o) { - s7_pointer val= o->sc->T; /* (and) -> #t */ - for (s7_int i= 0; i < q_arg1 (o).i; i++) { - opt_info* o1= q_or_clause (o, i).o1; - val = q_call (o1).fp (o1); - if (val == o->sc->F) return (o->sc->F); +#define fx_c_opsq_c_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + set_car(sc->t2_1, fn_proc(cadr(arg))(sc, with_list_t1(sc, Lookup(sc, opt1_sym(cdr(arg)), arg)))); /* cadadr */ \ + set_car(sc->t2_2, opt2_con(cdr(arg))); \ + return(fn_proc(arg)(sc, sc->t2_1)); \ } - return (val); -} -static s7_pointer -opt_or_pp (opt_info* o) { - s7_pointer val= q_p_func2_call (o); - return ((val != o->sc->F) ? val : q_p_func3_call (o)); -} +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 -opt_or_any_p (opt_info* o) { - for (s7_int i= 0; i < q_arg1 (o).i; i++) { - opt_info* o1 = q_or_clause (o, i).o1; - s7_pointer val= q_call (o1).fp (o1); - if (val != o->sc->F) return (val); - } - return (o->sc->F); -} - -static bool -opt_cell_and (s7_scheme* sc, s7_pointer expr, int32_t len) { - opt_info* opc= alloc_opt_info (sc); - if (len == 3) { - q_call (opc).fp= ((car (expr) == sc->or_symbol) ? opt_or_pp : opt_and_pp); - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (!cell_optimize (sc, cdr (expr))) return_false (sc, expr); - q_func2 (opc).fp = q_func2_arg (opc).q_call (o1).fp; - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (!cell_optimize (sc, cddr (expr))) return_false (sc, expr); - q_func3 (opc).fp= q_func3_arg (opc).q_call (o1).fp; - return_true (sc, expr); - } - if ((len > 1) && (len < (num_vunions - 4))) { - s7_pointer p = cdr (expr); - q_arg1 (opc).i= (len - 1); - q_call (opc).fp= - ((car (expr) == sc->or_symbol) ? opt_or_any_p : opt_and_any_p); - for (int32_t i= 0; is_pair (p); i++, p= cdr (p)) { - q_or_clause (opc, i).o1= sc->opts[sc->pc]; - if (!cell_optimize (sc, p)) return_false (sc, expr); - } - return_true (sc, expr); - } - return_false (sc, expr); -} -/* -------- cell_if -------- */ -static s7_pointer -opt_if_bp (opt_info* o) { - return ((q_func (o).fb (q_arg2 (o).o1)) ? q_p_func1_call (o) - : o->sc->unspecified); -} -static s7_pointer -opt_if_b7p (opt_info* o) { - return ((opt_b_7p_f (q_arg2 (o).o1)) ? q_p_func1_call (o) - : o->sc->unspecified); -} /* expanded not faster */ -static s7_pointer -opt_if_nbp (opt_info* o) { - return ((q_b_func1_call (o)) ? o->sc->unspecified : q_p_func2_call (o)); -} -static s7_pointer -opt_if_bp_and (opt_info* o) { - return ((opt_and_bb (q_arg2 (o).o1)) ? q_p_func1_call (o) - : o->sc->unspecified); +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 -opt_if_bp_pb ( - opt_info* o) /* p_to_b at outer, p_to_b expanded and moved to o[3] */ +static s7_pointer fx_c_optq_i_direct(s7_scheme *sc, s7_pointer arg) { - return ((q_func (o).fp (q_arg2 (o).o1) != o->sc->F) ? q_p_func1_call (o) - : o->sc->unspecified); + 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 -opt_if_bp_ii_fc (opt_info* o) { - return ((q_func (o).b_ii_f (q_i_func2_call (o), q_arg2 (o).i)) - ? q_p_func1_call (o) - : o->sc->unspecified); +static s7_pointer fx_memq_car_s(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer lst = opt2_con(cdr(arg)); + s7_pointer obj = lookup(sc, opt1_sym(cdr(arg))); + obj = (is_pair(obj)) ? car(obj) : g_car(sc, set_plist_1(sc, obj)); + while (true) LOOP_4(if (obj == car(lst)) return(lst); lst = cdr(lst); if (!is_pair(lst)) return(sc->F)); + return(sc->F); } -static s7_pointer -opt_if_nbp_s (opt_info* o) { - return ((q_func (o).b_p_f (slot_value (q_arg2 (o).p))) ? o->sc->unspecified - : q_p_func2_call (o)); +static s7_pointer fx_memq_car_s_2(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer lst = opt2_con(cdr(arg)); + s7_pointer obj = lookup(sc, opt1_sym(cdr(arg))); + obj = (is_pair(obj)) ? car(obj) : g_car(sc, set_plist_1(sc, obj)); + if (obj == car(lst)) return(lst); + return((obj == cadr(lst)) ? cdr(lst) : sc->F); } -static s7_pointer -opt_if_nbp_sc (opt_info* o) /* b_pp_sc */ +static s7_pointer fx_c_s_opssq(s7_scheme *sc, s7_pointer arg) { - return ((q_func (o).b_pp_f (slot_value (q_arg2 (o).p), q_arg3 (o).p)) - ? o->sc->unspecified - : q_p_func2_call (o)); + s7_pointer arg2 = caddr(arg); + set_car(sc->t2_2, fn_proc(arg2)(sc, with_list_t2(sc, lookup(sc, cadr(arg2)), lookup(sc, opt1_sym(cdr(arg2)))))); + set_car(sc->t2_1, lookup(sc, cadr(arg))); + return(fn_proc(arg)(sc, sc->t2_1)); } -static s7_pointer -opt_if_nbp_7sc (opt_info* o) /* b_7pp_sc */ +#define fx_c_s_opssq_direct_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer p_arg2 = 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(p_arg2)), Lookup2(sc, opt1_sym(p_arg2), p_arg2)))); \ + } + +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 ((q_func (o).b_7pp_f (o->sc, slot_value (q_arg2 (o).p), q_arg3 (o).p)) - ? o->sc->unspecified - : q_p_func2_call (o)); + return(s7i_vector_ref_p_pp(sc, lookup_global(sc, cadr(arg)), + s7i_vector_ref_p_pp(sc, lookup_global(sc, car(opt3_pair(arg))), lookup(sc, opt1_sym(opt3_pair(arg)))))); } -static s7_pointer -opt_if_nbp_ss (opt_info* o) /* b_ii_ss */ +static s7_pointer fx_vref_g_vref_gt(s7_scheme *sc, s7_pointer arg) { - return ((q_func (o).b_ii_f (integer (slot_value (q_arg2 (o).p)), - integer (slot_value (q_arg3 (o).p)))) - ? o->sc->unspecified - : q_p_func2_call (o)); + return(s7i_vector_ref_p_pp(sc, lookup_global(sc, cadr(arg)), + s7i_vector_ref_p_pp(sc, lookup_global(sc, car(opt3_pair(arg))), t_lookup(sc, opt1_sym(opt3_pair(arg)), arg)))); } -static s7_pointer -opt_if_num_eq_ii_ss (opt_info* o) /* b_ii_ss */ +static s7_pointer fx_c_c_opssq(s7_scheme *sc, s7_pointer arg) { - return ((integer (slot_value (q_arg2 (o).p)) == - integer (slot_value (q_arg3 (o).p))) - ? o->sc->unspecified - : q_p_func2_call (o)); + s7_pointer arg2 = caddr(arg); + set_car(sc->t2_2, fn_proc(arg2)(sc, with_list_t2(sc, lookup(sc, cadr(arg2)), lookup(sc, opt1_sym(cdr(arg2)))))); + 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 -opt_if_nbp_fs (opt_info* o) /* b_pi_fs */ +static s7_pointer fx_c_c_opssq_direct(s7_scheme *sc, s7_pointer arg) { - return ((q_func4 (o).b_pi_f (o->sc, q_p_func1_call (o), - integer (slot_value (q_arg1 (o).p)))) - ? o->sc->unspecified - : q_p_func2_call (o)); + 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 -opt_if_nbp_sf (opt_info* o) /* b_pp_sf */ +static s7_pointer fx_c_nc_opssq_direct(s7_scheme *sc, s7_pointer arg) /* clm2xen (* 1.0 (oscil g2 x2)) */ { - return ((q_func (o).b_pp_f (slot_value (q_arg1 (o).p), q_p_func1_call (o))) - ? o->sc->unspecified - : q_p_func2_call (o)); + s7_double x2 = ((s7_d_pd_t)opt3_direct(cdr(arg)))(lookup(sc, opt3_sym(arg)), real_to_double(sc, lookup(sc, opt1_sym(cdr(arg))), __func__)); + return(((s7_p_dd_t)opt2_direct(cdr(arg)))(sc, real_to_double(sc, cadr(arg), __func__), x2)); } -static s7_pointer -opt_if_nbp_7sf (opt_info* o) /* b_7pp_sf */ +static s7_pointer fx_multiply_c_opssq(s7_scheme *sc, s7_pointer arg) /* (* c=float (* x1 x2))! */ { - return ((q_func (o).b_7pp_f (o->sc, slot_value (q_arg1 (o).p), - q_p_func1_call (o))) - ? o->sc->unspecified - : q_p_func2_call (o)); + s7_pointer x1 = lookup(sc, opt3_sym(arg)); + s7_pointer 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_wrapped(sc, x1, x2))); } -static s7_pointer -opt_if_bpp (opt_info* o) { - return ((q_b_func1_call (o)) ? q_p_func3_call (o) : q_p_func2_call (o)); +#define fx_c_s_opscq_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + const s7_pointer arg2 = caddr(arg); \ + set_car(sc->t2_1, Lookup2(sc, cadr(arg2), arg)); \ + set_car(sc->t2_2, opt1_con(cdr(arg2))); \ + set_car(sc->t2_2, fn_proc(arg2)(sc, sc->t2_1)); \ + set_car(sc->t2_1, Lookup1(sc, cadr(arg), arg)); \ + return(fn_proc(arg)(sc, sc->t2_1)); \ + } + +fx_c_s_opscq_any(fx_c_s_opscq, s_lookup, s_lookup) +fx_c_s_opscq_any(fx_c_u_optcq, u_lookup, t_lookup) +/* also fx_c_T_optcq */ + +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 -opt_if_bpp_bit (opt_info* o) { - return ((opt_b_7ii_sc_bit (q_func1_arg (o).o1)) ? q_p_func3_call (o) - : q_p_func2_call (o)); + +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 bool -opt_cell_if (s7_scheme* sc, s7_pointer expr, int32_t len) { - opt_info* opc= alloc_opt_info (sc); - opt_info* bop= sc->opts[sc->pc]; - if (len == 3) { - if ((is_proper_list_2 (sc, cadr (expr))) && /* (not arg) */ - (caadr (expr) == sc->not_symbol)) { - if (bool_optimize (sc, cdadr (expr))) { - opt_info* top= sc->opts[sc->pc]; - if (cell_optimize (sc, cddr (expr))) { - q_func2_arg (opc).o1= top; - q_func2 (opc).fp = q_call (top).fp; - if (q_call (bop).fb == opt_b_p_s) { - q_func (opc).b_p_f= q_func (bop).b_p_f; - q_arg2 (opc).p = q_arg1 (bop).p; - q_call (opc).fp = opt_if_nbp_s; - return_true (sc, expr); - } - if ((q_call (bop).fb == opt_b_pi_fs) || - (q_call (bop).fb == opt_b_pi_fs_num_eq)) { - q_func4 (opc).b_pi_f= q_func4 (bop).b_pi_f; - q_arg1 (opc).p = q_arg1 (bop).p; - q_func1_arg (opc).o1= q_func2_arg (bop).o1; - q_func1 (opc).fp = q_func2 (bop).fp; - q_call (opc).fp = opt_if_nbp_fs; - return_true (sc, expr); - } - if ((q_call (bop).fb == opt_b_pp_sf) || - (q_call (bop).fb == opt_b_7pp_sf)) { - q_func1_arg (opc).o1= q_func2_arg (bop).o1; - q_func1 (opc).fp = q_func2 (bop).fp; - if (q_call (bop).fb == opt_b_pp_sf) { - q_func (opc).b_pp_f= q_func (bop).b_pp_f; - q_call (opc).fp = opt_if_nbp_sf; - } - else { - q_func (opc).b_7pp_f= q_func (bop).b_7pp_f; - q_call (opc).fp = opt_if_nbp_7sf; - } - q_arg1 (opc).p= q_arg1 (bop).p; - return_true (sc, expr); - } - if ((q_call (bop).fb == opt_b_pp_sc) || - (q_call (bop).fb == opt_b_7pp_sc)) { - if (q_call (bop).fb == opt_b_pp_sc) { - q_func (opc).b_pp_f= q_func (bop).b_pp_f; - q_call (opc).fp = opt_if_nbp_sc; - } - else { - q_func (opc).b_7pp_f= q_func (bop).b_7pp_f; - q_call (opc).fp = opt_if_nbp_7sc; - } - q_arg2 (opc).p= q_arg1 (bop).p; - q_arg3 (opc).p= q_arg2 (bop).p; - return_true (sc, expr); - } - if ((q_call (bop).fb == opt_b_ii_ss) || - (q_call (bop).fb == opt_b_ii_ss_eq) || - (q_call (bop).fb == opt_b_ii_ss_lt) || - (q_call (bop).fb == opt_b_ii_ss_gt) || - (q_call (bop).fb == opt_b_ii_ss_leq) || - (q_call (bop).fb == opt_b_ii_ss_geq)) { - q_func (opc).b_ii_f= q_func (bop).b_ii_f; - q_arg2 (opc).p = q_arg1 (bop).p; - q_arg3 (opc).p = q_arg2 (bop).p; - q_call (opc).fp = (q_func (opc).b_ii_f == num_eq_b_ii) - ? opt_if_num_eq_ii_ss - : opt_if_nbp_ss; - return_true (sc, expr); - } - q_func1_arg (opc).o1= bop; - q_func1 (opc).fb = q_call (bop).fb; - q_call (opc).fp = opt_if_nbp; - return_true (sc, expr); - } - } - } - else if (bool_optimize (sc, cdr (expr))) { - opt_info* top= sc->opts[sc->pc]; - if (cell_optimize (sc, cddr (expr))) { - q_arg2 (opc).o1 = bop; - q_func1_arg (opc).o1= top; - q_func1 (opc).fp = q_call (top).fp; - if (q_call (bop).fb == p_to_b) { - q_call (opc).fp= opt_if_bp_pb; - q_func (opc).fp= q_temp (bop).fp; - return_true (sc, expr); - } - if (q_call (bop).fb == opt_b_ii_fc) { - q_arg2 (opc).i = q_arg2 (bop).i; - q_func (opc).b_ii_f = q_func (bop).b_ii_f; - q_func2 (opc).fi = q_func2 (bop).fi; - q_func2_arg (opc).o1= q_func2_arg (bop).o1; - q_call (opc).fp = opt_if_bp_ii_fc; - return_true (sc, expr); - } - q_call (opc).fp= - (q_call (bop).fb == opt_b_7p_f) - ? opt_if_b7p - : ((q_call (bop).fb == opt_and_bb) ? opt_if_bp_and : opt_if_bp); - q_func (opc).fb= q_call (bop).fb; - return_true (sc, expr); - } - } - return_false (sc, expr); - } - if (len == 4) { - if (bool_optimize (sc, cdr (expr))) { - opt_info* top= sc->opts[sc->pc]; - if (cell_optimize (sc, cddr (expr))) { - opt_info* o3= sc->opts[sc->pc]; - q_call (opc).fp= - (q_call (bop).fb == opt_b_7ii_sc_bit) ? opt_if_bpp_bit : opt_if_bpp; - if (cell_optimize (sc, cdddr (expr))) { - q_func1_arg (opc).o1= bop; - q_func1 (opc).fb = q_call (bop).fb; - q_func3_arg (opc).o1= top; - q_func3 (opc).fp = q_call (top).fp; - q_func2_arg (opc).o1= o3; - q_func2 (opc).fp = q_call (o3).fp; - return_true (sc, expr); - } - } +static s7_pointer fx_c_u_optiq_direct(s7_scheme *sc, s7_pointer arg) +{ + return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, u_lookup(sc, cadr(arg), arg), + ((s7_p_pi_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, opt3_sym(arg), 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 ind = lookup(sc, opt3_sym(arg)); + s7_pointer vec = lookup(sc, cadr(arg)); + if ((is_t_integer(ind)) && (is_t_vector(vec)) && (vector_rank(vec) == 1)) + { + s7_int index = integer(ind) + 1; + if ((index >= 0) && (vector_length(vec) > index)) + return(vector_element(vec, index)); } - } - return_false (sc, expr); + return(s7i_vector_ref_p_pp(sc, vec, g_add_xi(sc, ind, 1, 2))); } -/* -------- cell_case -------- */ -#define q_case_start 3 -#define q_max_case_clauses (num_vunions - 4) -#define q_case_selector(o) o->v[2] -#define q_case_clause(o, i) o->v[i + 4] -#define q_case(o, i) o->v[i] -#define q_case_clause_keys(o) o->v[2] +static s7_pointer fx_num_eq_add_s_si(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer i1 = lookup(sc, cadr(arg)); + s7_pointer 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))), 2)))); +} -static s7_pointer -case_value (opt_info* o) { - opt_info* o1; - int32_t i, len= q_arg1 (o).i - 1; /* int32_t here and below seems to be faster - than s7_int (tleft.scm) */ - for (i= 0; i < len; i++) { - o1= q_case_clause (o, i).o1; - q_call (o1).fp (o1); +static s7_pointer fx_num_eq_subtract_s_si(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer i1 = lookup(sc, cadr(arg)); + s7_pointer 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))))); \ } - o1= q_case_clause (o, i).o1; - return (q_call (o1).fp (o1)); + +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 arg2 = caddr(arg); + set_car(sc->t2_2, fn_proc(arg2)(sc, with_list_t1(sc, lookup(sc, cadr(arg2))))); + set_car(sc->t2_1, lookup(sc, cadr(arg))); + return(fn_proc(arg)(sc, sc->t2_1)); } -static s7_pointer -opt_case (opt_info* o) { - opt_info* o1 = q_case_selector (o).o1; - const int32_t lim = q_arg1 (o).i; - s7_scheme* sc = o->sc; - const s7_pointer selector= q_call (o1).fp (o1); +#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_opsq_direct, t_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) - if (is_simple (selector)) { - for (int32_t ctr= q_case_start; ctr < lim; ctr++) { - s7_pointer p; - o1= q_case (o, ctr).o1; - for (p= q_case_clause_keys (o1).p; is_pair (p); p= cdr (p)) - if (selector == car (p)) return (case_value (o1)); - if (p == sc->else_symbol) return (case_value (o1)); - } +#define fx_c_s_car_s_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer 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)); \ } - else - for (int32_t ctr= q_case_start; ctr < lim; ctr++) { - s7_pointer p; - o1= q_case (o, ctr).o1; - for (p= q_case_clause_keys (o1).p; is_pair (p); p= cdr (p)) - if (s7_is_eqv (sc, selector, car (p))) return (case_value (o1)); - if (p == sc->else_symbol) return (case_value (o1)); - } - return (sc->unspecified); -} -static bool -opt_cell_case (s7_scheme* sc, s7_pointer expr) { - /* 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; - int32_t ctr; - opt_info* top = alloc_opt_info (sc); - q_case_selector (top).o1= sc->opts[sc->pc]; - if (!cell_optimize (sc, cdr (expr))) /* selector */ - return_false (sc, expr); - for (ctr= q_case_start, p= cddr (expr); (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_opt_info (sc); - q_case (top, ctr).o1= opc; - if (car (clause) == sc->else_symbol) { - if (!is_null (cdr (p))) return_false (sc, clause); - q_case_clause_keys (opc).p= sc->else_symbol; - } - else { - if (!s7_is_proper_list (sc, car (clause))) return_false (sc, clause); - q_case_clause_keys (opc).p= car (clause); - } - - for (blen= 0, cp= cdr (clause); - (is_pair (cp)) && (blen < q_max_case_clauses); blen++, cp= cdr (cp)) { - q_case_clause (opc, blen).o1= sc->opts[sc->pc]; - if (!cell_optimize (sc, cp)) return_false (sc, cp); - } - if (!is_null (cp)) return_false (sc, cp); - q_arg1 (opc).i = blen; - q_call (opc).fp= opt_case; /* just a placeholder I hope */ +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 = Lookup1(sc, cadr(arg), arg); \ + s7_pointer val2 = Lookup2(sc, opt2_sym(cdr(arg)), arg); \ + val2 = (is_pair(val2)) ? car(val2) : g_car(sc, set_plist_1(sc, val2)); \ + return(((is_t_integer(val1)) && (is_t_integer(val2))) ? make_integer(sc, integer(val1) + integer(val2)) : add_p_pp(sc, val1, val2)); \ } - if (!is_null (p)) return_false (sc, p); - q_arg1 (top).i = ctr; - q_call (top).fp= opt_case; - return_true (sc, expr); + +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 = 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)); } -/* -------- cell_let_temporarily -------- */ +static s7_pointer fx_c_op_s_opsqq(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer outer = cadr(arg); + s7_pointer args = caddr(outer); + set_car(sc->t2_2, fn_proc(args)(sc, with_list_t1(sc, lookup(sc, cadr(args))))); + set_car(sc->t2_1, lookup(sc, cadr(outer))); + return(fn_proc(arg)(sc, with_list_t1(sc, fn_proc(outer)(sc, sc->t2_1)))); +} -#define q_let_temp_o1 5 -#define q_let_temp(o, i) o->v[i + q_let_temp_o1] -#define q_let_temp_old_value(o) o->v[3] -#define q_let_temp_new_value(o) o->v[4] +static s7_pointer fx_not_op_s_opsqq(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer outer = cadr(arg); + s7_pointer args = caddr(outer); + set_car(sc->t2_2, fn_proc(args)(sc, with_list_t1(sc, lookup(sc, cadr(args))))); + 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 -opt_let_temporarily (opt_info* o) { - opt_info* new_o1= q_let_temp_new_value (o).o1; - s7_int i, len; - s7_pointer result; - s7_scheme* sc= o->sc; - - if (is_immutable_slot (q_arg1 (o).p)) - immutable_object_error_nr (sc, set_elist_3 (sc, immutable_error_string, - sc->let_temporarily_symbol, - slot_symbol (q_arg1 (o).p))); - - q_let_temp_old_value (o).p= - slot_value (q_arg1 (o).p); /* save and protect old value */ - gc_protect_via_stack (sc, q_let_temp_old_value (o).p); - slot_set_value (q_arg1 (o).p, - q_call (new_o1).fp (new_o1)); /* set new value */ - len= q_arg2 (o).i - 1; - { - opt_info* o1; - for (i= 0; i < len; i++) { - o1= q_let_temp (o, i).o1; - q_call (o1).fp (o1); - } - o1 = q_let_temp (o, i).o1; - result= q_call (o1).fp (o1); - } - slot_set_value (q_arg1 (o).p, q_let_temp_old_value (o).p); /* restore old */ - unstack_gc_protect (sc); - return (result); +static s7_pointer fx_c_op_opsq_sq(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer outer = cadr(arg); + s7_pointer args = cadr(outer); + set_car(sc->t2_1, fn_proc(args)(sc, with_list_t1(sc, lookup(sc, cadr(args))))); + set_car(sc->t2_2, lookup(sc, caddr(outer))); + return(fn_proc(arg)(sc, with_list_t1(sc, fn_proc(outer)(sc, sc->t2_1)))); } -static bool -opt_cell_let_temporarily (s7_scheme* sc, s7_pointer expr, int32_t len) { - s7_pointer vars; - if (len <= 2) return_false (sc, expr); - vars= cadr (expr); - if ((len < (num_vunions - q_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_symbol (caar (vars))) && - (!is_syntactic_symbol (caar (vars)))) { - s7_pointer p; - opt_info* opc= alloc_opt_info (sc); - q_arg1 (opc).p= s7_t_slot (sc, caaadr (expr)); - if (!is_slot (q_arg1 (opc).p)) return_false (sc, expr); - q_let_temp_new_value (opc).o1= sc->opts[sc->pc]; - if (!cell_optimize (sc, cdaadr (expr))) return_false (sc, expr); - - p= cddr (expr); - for (int32_t i= 0; is_pair (p); i++, p= cdr (p)) { - q_let_temp (opc, i).o1= sc->opts[sc->pc]; - if (!cell_optimize (sc, p)) return_false (sc, expr); - } - q_arg2 (opc).i = len - 2; - q_call (opc).fp= opt_let_temporarily; - return_true (sc, expr); - } - return_false (sc, expr); +static s7_pointer fx_not_op_optq_sq(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer outer = cadr(arg); + s7_pointer args = cadr(outer); + set_car(sc->t2_1, fn_proc(args)(sc, with_list_t1(sc, t_lookup(sc, cadr(args), arg)))); + set_car(sc->t2_2, lookup(sc, caddr(outer))); + return((fn_proc(outer)(sc, sc->t2_1) == sc->F) ? sc->T : sc->F); } -/* -------- cell_do -------- */ +static s7_pointer fx_c_c_opsq(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer arg2 = opt3_pair(arg); /* caddr(arg) */ + set_car(sc->t2_2, fn_proc(arg2)(sc, with_list_t1(sc, lookup(sc, cadr(arg2))))); + set_car(sc->t2_1, cadr(arg)); + return(fn_proc(arg)(sc, sc->t2_1)); +} -#define do_curlet(o) T_Let (q_arg2 (o).p) -#define do_curlet_unchecked(o) o->v[2].p -#define do_body_length(o) o->v[3].i -#define do_result_length(o) o->v[4].i -#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 -#define do_stepper_opt(o) o->v[9].o1 -#define do_expr(o, i) o->v[i] - -static void -let_set_has_pending_value (s7_pointer let) { - for (s7_pointer slot= let_slots (let); is_not_slot_end (slot); - slot = next_slot (slot)) - slot_set_pending_value (slot, eof_object); /* gc needs a legit value here */ -} - -static void -let_clear_has_pending_value (s7_scheme* sc, s7_pointer let) { - for (s7_pointer slot= let_slots (let); is_not_slot_end (slot); - slot = next_slot (slot)) - slot_clear_has_pending_value (slot); -} - -typedef s7_pointer (*opt_info_fp) (opt_info* o); - -static s7_pointer -opt_do_any (opt_info* o) { - opt_info* o1; - opt_info* ostart = do_any_test (o); - const opt_info* body = do_any_body (o); - const opt_info* inits = do_any_inits (o); - const opt_info* steps = do_any_steps (o); - const opt_info* results= do_any_results (o); - const int32_t len= do_body_length (o); /* len=6 tlist, 6|7 tbig, 0 tvect */ - s7_pointer slot, result; - s7_scheme* sc= o->sc; - opt_info* os[num_vunions]; - opt_info_fp fp[num_vunions]; - const s7_pointer old_let= sc->curlet; - gc_protect_via_stack (sc, old_let); - set_curlet (sc, do_curlet (o)); - /* init */ - slot= let_slots (sc->curlet); - for (int32_t k= 0; is_not_slot_end (slot); k++, slot= next_slot (slot)) { - o1= do_expr (inits, k).o1; - slot_set_value (slot, q_call (o1).fp (o1)); - } - let_set_has_pending_value (sc->curlet); - for (int32_t i= 0; i < len; i++) { - os[i]= do_expr (body, i).o1; - fp[i]= q_call (os[i]).fp; - } - while (true) { - /* end */ - if (q_call (ostart).fb (ostart)) break; - /* body */ - if (len == - 6) /* here and in opt_do_n we need a better way to unroll these loops */ - { - fp[0](os[0]); - fp[1](os[1]); - fp[2](os[2]); - fp[3](os[3]); - fp[4](os[4]); - fp[5](os[5]); - } - else if (len == 7) { - fp[0](os[0]); - fp[1](os[1]); - fp[2](os[2]); - fp[3](os[3]); - fp[4](os[4]); - fp[5](os[5]); - fp[6](os[6]); - } - else - for (int32_t i= 0; i < len; i++) - fp[i](os[i]); - /* step (let not let*) */ - slot= let_slots (sc->curlet); - for (int32_t k= 0; is_not_slot_end (slot); k++, slot= next_slot (slot)) - if (has_stepper (slot)) { - o1= do_expr (steps, k).o1; - slot_simply_set_pending_value (slot, q_call (o1).fp (o1)); - } - for (s7_pointer slot1= let_slots (sc->curlet); is_not_slot_end (slot1); - slot1 = next_slot (slot1)) - if (has_stepper (slot1)) - slot_set_value (slot1, slot_pending_value (slot1)); - } - /* result */ - result= sc->T; - for (int32_t i= 0; i < do_result_length (o); i++) { - o1 = do_expr (results, i).o1; - result= q_call (o1).fp (o1); - } - let_clear_has_pending_value (sc, sc->curlet); - unstack_gc_protect (sc); - set_curlet (sc, old_let); - return (result); +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 -opt_do_step_1 (opt_info* o) { - /* 1 stepper (multi inits perhaps), 1 body, 1 return-expr */ - opt_info* o1; - opt_info* ostart= do_any_test (o); - opt_info* ostep = do_stepper_opt (o); - const opt_info* inits = do_any_inits (o); - opt_info* body = do_any_body (o); - s7_pointer slot, result, stepper= NULL; - s7_scheme* sc = o->sc; - const s7_pointer old_let= sc->curlet; - gc_protect_via_stack (sc, old_let); - set_curlet (sc, do_curlet (o)); - slot= let_slots (sc->curlet); - for (int32_t k= 0; is_not_slot_end (slot); k++, slot= next_slot (slot)) { - o1= do_expr (inits, k).o1; - slot_set_value (slot, q_call (o1).fp (o1)); - if (has_stepper (slot)) stepper= slot; - } - while (!(q_call (ostart).fb (ostart))) { - q_call (body).fp (body); - slot_set_value (stepper, q_call (ostep).fp (ostep)); - } - o1 = do_any_results (o); - result= q_call (o1).fp (o1); - unstack_gc_protect (sc); - set_curlet (sc, old_let); - return (result); +/* perhaps fx_c_c_opt|T|Vq_direct tlet/tmisc */ + +static s7_pointer fx_c_opsq_opsq(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer argp = cdr(arg); + gc_protect_via_stack(sc, fn_proc(car(argp))(sc, with_list_t1(sc, lookup(sc, cadar(argp))))); + argp = cadr(argp); + set_car(sc->t2_2, fn_proc(argp)(sc, with_list_t1(sc, lookup(sc, cadr(argp))))); + set_car(sc->t2_1, gc_protected1(sc)); + unstack_gc_protect(sc); + return(fn_proc(arg)(sc, sc->t2_1)); } -static s7_pointer -opt_do_step_i (opt_info* o) { - /* 1 stepper (multi inits perhaps), 1 body expr, 1 return-expr */ - /* (do ((sum 0.0) (k 0 (+ k 1))) ((= k size) (set! (C i j) sum)) (set! sum - * (+ sum (* (A i k) (B k j))))) */ - opt_info* o1; - opt_info* ostart = do_any_test (o); - opt_info* ostep = do_stepper_opt (o); - const opt_info* inits = do_any_inits (o); - opt_info* body = do_any_body (o); - s7_pointer (*fp) (opt_info* o)= q_call (body).fp; - s7_pointer slot, result, stepper= NULL, si; - s7_scheme* sc= o->sc; - s7_int end, incr; - const s7_pointer old_let= sc->curlet; - gc_protect_via_stack (sc, old_let); - set_curlet (sc, do_curlet (o)); - slot= let_slots (sc->curlet); - for (int32_t k= 0; is_not_slot_end (slot); k++, slot= next_slot (slot)) { - o1= do_expr (inits, k).o1; - slot_set_value (slot, q_call (o1).fp (o1)); - if (has_stepper (slot)) stepper= slot; - } - end = integer (slot_value (q_arg2 (ostart).p)); - incr= q_arg2 (ostep).i; - si = make_mutable_integer (sc, integer (slot_value (q_arg1 (ostart).p))); - if (stepper) slot_set_value (stepper, si); - if (fp == opt_set_p_d_f_sf_add) /* ok since used only if body has one expr */ - { - fp= opt_set_p_d_fm_sf_add; - slot_set_value ( - q_arg1 (body).p, - make_mutable_real (sc, real (slot_value (q_arg1 (body).p)))); - } - while (integer (si) != end) { - fp (body); - integer (si)+= incr; - } - clear_mutable_integer (si); - if (fp == opt_set_p_d_fm_sf_add) - clear_mutable_number (slot_value (q_arg1 (body).p)); - o1 = do_any_results (o); - result= q_call (o1).fp (o1); - unstack_gc_protect (sc); - set_curlet (sc, old_let); - return (result); +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) */ } -#define do_no_vars_test(o) o->v[6].o1 -#define do_no_vars_body(o) o->v[7].o1 +static s7_pointer fx_c_optq_optq_direct(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer 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))); +} -static s7_pointer -opt_do_no_vars (opt_info* o) { - /* no vars, no return, o-v[2].p=let, o-v[3].i=body length, o-v[4].i=return - * length=0, o-v[6]=end test */ - opt_info* ostart = do_no_vars_test (o); - const int32_t len = do_body_length (o); - s7_scheme* sc = o->sc; - bool (*fb) (opt_info* o)= q_call (ostart).fb; - const s7_pointer old_let= sc->curlet; - gc_protect_via_stack (sc, old_let); - set_curlet (sc, do_curlet (o)); - if (len == 0) /* titer */ - while (!fb (ostart)) - ; - else { - const opt_info* body= do_no_vars_body (o); - while (!fb (ostart)) /* tshoot, tfft */ - for (int32_t i= 0; i < len; i++) { - opt_info* o1= do_expr (body, i).o1; - q_call (o1).fp (o1); - } +#define fx_car_s_car_s_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer p1 = Lookup1(sc, opt1_sym(cdr(arg)), arg); \ + s7_pointer 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)))); \ } - unstack_gc_protect (sc); - set_curlet (sc, old_let); - return (sc->T); + +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 = lookup(sc, opt1_sym(cdr(arg))); + s7_pointer 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)))); } -#define do_stepper_init(o) o->v[11].o1 -#define do_stepper_safe(o) o->v[8].i +static s7_pointer fx_is_eq_car_car_tu(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer p1 = t_lookup(sc, opt1_sym(cdr(arg)), arg); + s7_pointer p2 = u_lookup(sc, opt2_sym(cdr(arg)), arg); + p1 = (is_pair(p1)) ? car(p1) : g_car(sc, set_plist_1(sc, p1)); + 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 -opt_do_1 (opt_info* o) { - /* 1 var, 1 expr, no return */ - opt_info* o1 = do_stepper_init (o); - opt_info* ostart = do_any_test (o); - opt_info* ostep = do_stepper_opt (o); - opt_info* body = do_any_body (o); - s7_pointer slot = let_slots (do_curlet (o)); - s7_scheme* sc = o->sc; - const s7_pointer old_let= sc->curlet; - gc_protect_via_stack (sc, old_let); - set_curlet (sc, do_curlet (o)); - slot_set_value (slot, q_call (o1).fp (o1)); - if ((do_stepper_safe (o) == 1) && (is_t_integer (slot_value (slot)))) { - if ((q_call (ostep).fp == opt_p_ii_ss_add) || /* tmap */ - (q_call (ostep).fp == i_to_p)) { - s7_pointer step_val= - make_mutable_integer (sc, integer (slot_value (slot))); - slot_set_value (slot, step_val); - if (q_call (ostep).fp == opt_p_ii_ss_add) - while (!q_call (ostart).fb (ostart)) { - q_call (body).fp (body); - set_integer (step_val, opt_i_ii_ss_add (ostep)); - } - else - while (!q_call (ostart).fb (ostart)) { - q_call (body).fp (body); - set_integer (step_val, q_temp (ostep).fi (ostep)); - } - unstack_gc_protect (sc); - clear_mutable_integer (step_val); - set_curlet (sc, old_let); - return (sc->T); - } - do_stepper_safe (o)= 2; - } - while (!(q_call (ostart).fb (ostart))) /* s7test tref */ - { - q_call (body).fp (body); - slot_set_value (slot, q_call (ostep).fp (ostep)); - } - unstack_gc_protect (sc); - set_curlet (sc, old_let); - return (sc->T); +static s7_pointer fx_c_opsq_opssq(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer argp = cdr(arg); + gc_protect_via_stack(sc, fn_proc(car(argp))(sc, with_list_t1(sc, lookup(sc, cadar(argp))))); + argp = cadr(argp); + set_car(sc->t2_1, lookup(sc, cadr(argp))); + set_car(sc->t2_2, lookup(sc, opt1_sym(cdr(argp)))); /* caddr(argp) */ + set_car(sc->t2_2, fn_proc(argp)(sc, sc->t2_1)); + set_car(sc->t2_1, gc_protected1(sc)); + unstack_gc_protect(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 argp = cdr(arg); + return(((s7_p_pp_t)opt3_direct(arg))(sc, + ((s7_p_p_t)opt2_direct(argp))(sc, lookup(sc, cadar(argp))), + ((s7_p_pp_t)opt3_direct(argp))(sc, t_lookup(sc, opt2_sym(cdr(argp)), arg), u_lookup(sc, opt1_sym(argp), arg)))); } -#define do_n_body(o) o->v[7].o1 +static s7_pointer fx_num_eq_car_v_add_tu(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer num1 = car_p_p(sc, v_lookup(sc, cadadr(arg), arg)); + s7_pointer num2 = t_lookup(sc, opt2_sym(cddr(arg)), arg); + s7_pointer num3 = u_lookup(sc, opt1_sym(cdr(arg)), arg); + if ((is_t_integer(num1)) && (is_t_integer(num2)) && (is_t_integer(num3))) + return(make_boolean(sc, integer(num1) == (integer(num2) + integer(num3)))); + return(make_boolean(sc, num_eq_b_7pp(sc, num1, add_p_pp_wrapped(sc, num2, num3)))); +} -static s7_pointer -opt_do_n (opt_info* o) { - /* 1 var, no return */ - opt_info* o1 = do_stepper_init (o); - opt_info* ostart = do_any_test (o); - opt_info* ostep = do_stepper_opt (o); - opt_info* body = do_n_body (o); - const int32_t len = do_body_length (o); - s7_pointer slot = let_slots (do_curlet (o)); - s7_scheme* sc = o->sc; - const s7_pointer old_let= sc->curlet; - gc_protect_via_stack (sc, old_let); - set_curlet (sc, do_curlet (o)); - slot_set_value (slot, q_call (o1).fp (o1)); - if (len == 2) /* tmac tshoot */ - { - opt_info *e1= q_call (body).o1, *e2= q_arg1 (body).o1; - while (!(q_call (ostart).fb (ostart))) { - q_call (e1).fp (e1); - q_call (e2).fp (e2); - slot_set_value (slot, q_call (ostep).fp (ostep)); - } - } - else { - opt_info* os[num_vunions]; - opt_info_fp fp[num_vunions]; - for (int32_t i= 0; i < len; i++) { - os[i]= do_expr (body, i).o1; - fp[i]= q_call (os[i]).fp; - } - if (len == 7) - while (!q_call (ostart).fb ( - ostart)) /* tfft teq */ /* this is probably fft code */ - { - fp[0](os[0]); - fp[1](os[1]); - fp[2](os[2]); - fp[3](os[3]); - fp[4](os[4]); - fp[5](os[5]); - fp[6](os[6]); - slot_set_value (slot, q_call (ostep).fp (ostep)); - } - else - while (!q_call (ostart).fb (ostart)) /* tfft teq */ - { - for (int32_t i= 0; i < len; i++) - fp[i](os[i]); - slot_set_value (slot, q_call (ostep).fp (ostep)); - } - } - unstack_gc_protect (sc); - set_curlet (sc, old_let); - return (sc->T); +static s7_pointer fx_num_eq_car_v_subtract_tu(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer num1 = car_p_p(sc, v_lookup(sc, cadadr(arg), arg)); + s7_pointer num2 = t_lookup(sc, opt2_sym(cddr(arg)), arg); + s7_pointer num3 = u_lookup(sc, opt1_sym(cdr(arg)), arg); + if ((is_t_integer(num1)) && (is_t_integer(num2)) && (is_t_integer(num3))) + return(make_boolean(sc, integer(num1) == (integer(num2) - integer(num3)))); + return(make_boolean(sc, num_eq_b_7pp(sc, num1, subtract_p_pp_wrapped(sc, num2, num3)))); } -#define do_times_end(o) o->v[6] +static s7_pointer fx_c_opssq_opsq(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer argp = cdr(arg); + set_car(sc->t2_1, lookup(sc, cadar(argp))); + set_car(sc->t2_2, lookup(sc, opt1_sym(cdar(argp)))); + gc_protect_via_stack(sc, fn_proc(car(argp))(sc, sc->t2_1)); + argp = cadr(argp); + set_car(sc->t2_2, fn_proc(argp)(sc, with_list_t1(sc, lookup(sc, cadr(argp))))); + set_car(sc->t2_1, gc_protected1(sc)); + unstack_gc_protect(sc); + return(fn_proc(arg)(sc, sc->t2_1)); +} + +static s7_pointer fx_c_opssq_opssq(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer argp = cdr(arg); + set_car(sc->t2_1, lookup(sc, cadar(argp))); + set_car(sc->t2_2, lookup(sc, opt1_sym(cdar(argp)))); + gc_protect_via_stack(sc, fn_proc(car(argp))(sc, sc->t2_1)); + argp = cadr(argp); + set_car(sc->t2_1, lookup(sc, cadr(argp))); + set_car(sc->t2_2, lookup(sc, opt1_sym(cdr(argp)))); + set_car(sc->t2_2, fn_proc(argp)(sc, sc->t2_1)); + set_car(sc->t2_1, gc_protected1(sc)); + unstack_gc_protect(sc); + return(fn_proc(arg)(sc, sc->t2_1)); +} + +static s7_pointer fx_sub_mul_mul(s7_scheme *sc, s7_pointer arg) /* (- (* x1 x2) (* x3 x4)) */ +{ + s7_pointer p1 = opt3_pair(arg); /* cdaddr(arg) */ + s7_pointer x1 = lookup(sc, car(p1)); + s7_pointer x2 = lookup(sc, cadr(p1)); + s7_pointer p2 = opt1_pair(cdr(arg)); /* cdadr(arg) */ /* here and elsewhere this should be GC safe -- opssq->* (no methods?) etc */ + s7_pointer x3 = lookup(sc, car(p2)); + s7_pointer x4 = lookup(sc, cadr(p2)); + if ((is_t_real(x1)) && (is_t_real(x2)) && (is_t_real(x3)) && (is_t_real(x4))) + return(make_real(sc, (real(x3) * real(x4)) - (real(x1) * real(x2)))); + sc->temp5 = multiply_p_pp_wrapped(sc, x1, x2); + return(subtract_p_pp(sc, multiply_p_pp_wrapped(sc, x3, x4), sc->temp5)); +} + +static s7_pointer fx_add_mul_mul(s7_scheme *sc, s7_pointer arg) /* (+ (* x1 x2) (* x3 x4)) */ +{ + s7_pointer p1 = opt3_pair(arg); /* cdaddr(arg) */ + s7_pointer x1 = lookup(sc, car(p1)); + s7_pointer x2 = lookup(sc, cadr(p1)); + s7_pointer p2 = opt1_pair(cdr(arg)); /* cdadr(arg) */ + s7_pointer x3 = lookup(sc, car(p2)); + s7_pointer x4 = lookup(sc, cadr(p2)); + if ((is_t_real(x1)) && (is_t_real(x2)) && (is_t_real(x3)) && (is_t_real(x4))) + return(make_real(sc, (real(x3) * real(x4)) + (real(x1) * real(x2)))); + sc->temp5 = multiply_p_pp_wrapped(sc, x1, x2); + return(add_p_pp(sc, multiply_p_pp_wrapped(sc, x3, x4), sc->temp5)); +} + +static s7_pointer fx_mul_sub_sub(s7_scheme *sc, s7_pointer arg) /* (* (- x1 x2) (- x3 x4)) */ +{ + s7_pointer p1 = opt3_pair(arg); /* cdaddr(arg) */ + s7_pointer x1 = lookup(sc, car(p1)); + s7_pointer x2 = lookup(sc, cadr(p1)); + s7_pointer p2 = opt1_pair(cdr(arg)); /* cdadr(arg) */ + s7_pointer x3 = lookup(sc, car(p2)); + s7_pointer x4 = lookup(sc, cadr(p2)); + if ((is_t_real(x1)) && (is_t_real(x2)) && (is_t_real(x3)) && (is_t_real(x4))) + return(make_real(sc, (real(x3) - real(x4)) * (real(x1) - real(x2)))); + sc->temp5 = subtract_p_pp_wrapped(sc, x1, x2); + return(multiply_p_pp(sc, subtract_p_pp_wrapped(sc, x3, x4), sc->temp5)); +} + +static s7_pointer fx_lt_sub2(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer p1 = opt3_pair(arg); /* cdaddr(arg) */ + sc->temp5 = subtract_p_pp_wrapped(sc, lookup(sc, car(p1)), lookup(sc, cadr(p1))); + p1 = opt1_pair(cdr(arg)); /* cdadr(arg) */ + return(lt_p_pp(sc, subtract_p_pp_wrapped(sc, lookup(sc, car(p1)), lookup(sc, cadr(p1))), sc->temp5)); +} -static s7_pointer -opt_do_times (opt_info* o) { - /* 1 var, no return */ - opt_info* o1 = do_stepper_init (o); - opt_info* body = do_n_body (o); - const int32_t len = do_body_length (o); - s7_int end = (is_slot (let_dox_slot2_unchecked (do_curlet (o)))) - ? integer (slot_value (let_dox_slot2 (do_curlet (o)))) - : do_times_end (o).i; - s7_pointer slot = let_dox1_value (do_curlet (o)); - s7_scheme* sc = o->sc; - const s7_pointer old_let= sc->curlet; - gc_protect_via_stack (sc, old_let); - set_curlet (sc, do_curlet (o)); - set_integer (slot, integer (q_call (o1).fp (o1))); - if (len == 2) /* tmac tmisc */ - { - opt_info *e1= q_call (body).o1, *e2= q_arg1 (body).o1; - while (integer (slot) < end) { - q_call (e1).fp (e1); - q_call (e2).fp (e2); - integer (slot)++; - } - } - else - while (integer (slot) < end) /* tbig sg */ +static s7_pointer fx_sub_vref2(s7_scheme *sc, s7_pointer arg) +{ + const s7_pointer arg1p = cdadr(arg); + const s7_pointer vec = lookup(sc, car(arg1p)); + const s7_pointer num1 = lookup(sc, cadr(arg1p)); + const s7_pointer num2 = lookup(sc, opt3_sym(arg)); /* caddaddr(arg) */ + if ((is_t_integer(num1)) && (is_t_integer(num2)) && ((is_t_vector(vec)) && (vector_rank(vec) == 1))) { - for (int32_t i= 0; i < len; i++) { - o1= do_expr (body, i).o1; - q_call (o1).fp (o1); - } - integer (slot)++; + s7_int index1 = integer(num1), index2 = integer(num2); + if ((index1 >= 0) && (index1 <= vector_length(vec)) && (index2 >= 0) && (index2 < vector_length(vec))) + return(subtract_p_pp(sc, vector_ref_p_pi(sc, vec, index1), vector_ref_p_pi(sc, vec, index2))); } - unstack_gc_protect (sc); - set_curlet (sc, old_let); - return (sc->T); + return(subtract_p_pp(sc, s7i_vector_ref_p_pp(sc, vec, num1), s7i_vector_ref_p_pp(sc, vec, num2))); } -#define do_end(o) o->v[3] +static s7_pointer fx_c_op_opsqq(s7_scheme *sc, s7_pointer code) +{ + set_car(sc->t1_1, fn_proc(opt3_pair(code))(sc, with_list_t1(sc, lookup(sc, opt3_sym(cdr(code)))))); + set_car(sc->t1_1, fn_proc(cadr(code))(sc, sc->t1_1)); + return(fn_proc(code)(sc, sc->t1_1)); +} -static s7_pointer -opt_do_list_simple (opt_info* o) { - opt_info* o1 = do_stepper_init (o); - s7_pointer slot= let_slots (do_curlet (o)); - s7_scheme* sc = o->sc; - s7_pointer (*fp) (opt_info* o); - const s7_pointer old_let= sc->curlet; - gc_protect_via_stack (sc, old_let); - set_curlet (sc, do_curlet (o)); - slot_set_value (slot, q_call (o1).fp (o1)); - o1= do_any_body (o); - fp= q_call (o1).fp; - if (fp == opt_if_bp) - while (is_pair (slot_value (slot))) { - if (do_end (o1).fb (q_arg2 (o1).o1)) q_p_func1_call (o1); - slot_set_value (slot, cdr (slot_value (slot))); - } - else - while (!is_null (slot_value (slot))) { - fp (o1); - slot_set_value (slot, cdr (slot_value (slot))); - } - unstack_gc_protect (sc); - set_curlet (sc, old_let); - return (sc->T); +static s7_pointer fx_not_op_opsqq(s7_scheme *sc, s7_pointer code) +{ + set_car(sc->t1_1, fn_proc(opt3_pair(code))(sc, with_list_t1(sc, lookup(sc, opt3_sym(cdr(code)))))); + return((fn_proc(cadr(code))(sc, sc->t1_1) == sc->F) ? sc->T : sc->F); } -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 = do_stepper_init (o); - s7_int end= (is_slot (let_dox_slot2_unchecked (do_curlet_unchecked (o)))) - ? integer (slot_value (let_dox_slot2 (do_curlet (o)))) - : do_end (o).i; - s7_pointer vp = let_dox1_value (do_curlet (o)); - s7_pointer (*f) (opt_info* o); - s7_scheme* sc = o->sc; - const s7_pointer old_let= sc->curlet; - gc_protect_via_stack (sc, old_let); - set_curlet (sc, do_curlet (o)); - set_integer (vp, integer (q_call (o1).fp (o1))); - o1= do_any_body (o); - f = q_call (o1).fp; - if (f == opt_p_pip_ssf) /* tref.scm */ - { - opt_info* o2= o1; - o1 = q_func1_arg (o2).o1; - if (q_func (o2).p_pip_f == t_vector_set_p_pip_direct) { - s7_pointer vec= slot_value (q_arg1 (o2).p); - while (integer (vp) < end) { - t_vector_set_p_pip_direct (o2->sc, vec, - integer (slot_value (q_arg2 (o2).p)), - q_call (o1).fp (o1)); - integer (vp)++; - } - } - else - while (integer (vp) < end) { - q_func (o2).p_pip_f (o2->sc, slot_value (q_arg1 (o2).p), - integer (slot_value (q_arg2 (o2).p)), - q_call (o1).fp (o1)); - integer (vp)++; - } - } - else { - if (f == opt_p_pip_sso) /* is this code dead? does it belong above? */ - { /* vector-set from vector-ref (i.e. copy), but treating vector-* as - generic */ - if ((let_dox_slot1 (do_curlet_unchecked (o)) == q_arg2 (o1).p) && - (q_arg2 (o1).p == q_arg4 (o1).p)) { - s7_pointer (*setter) (s7_scheme* sc, s7_pointer p1, s7_int i1, - s7_pointer p2)= q_func (o1).p_pip_f; - s7_pointer (*getter) (s7_scheme* sc, s7_pointer p1, s7_int i1)= - q_func3 (o1).p_pi_f; - if (((setter == float_vector_set_p_pip_direct) && - (getter == float_vector_ref_p_pi_direct)) || - ((setter == complex_vector_set_p_pip_direct) && - (getter == complex_vector_ref_p_pi_direct)) || - ((setter == int_vector_set_p_pip_direct) && - (getter == int_vector_ref_p_pi_direct)) || - ((setter == string_set_p_pip_direct) && - (getter == string_ref_p_pi_direct)) || - ((setter == byte_vector_set_p_pip_direct) && - (getter == byte_vector_ref_p_pi_direct))) { - copy_to_same_type (sc, slot_value (q_arg1 (o1).p), - slot_value (q_arg3 (o1).p), integer (vp), end, - integer (vp)); /* TODO: q_arg1 and q_arg3 */ - unstack_gc_protect (sc); - set_curlet (sc, old_let); - return (sc->T); - } - } - while (integer (vp) < end) { - q_func (o1).p_pip_f ( - o1->sc, slot_value (q_arg1 (o1).p), - integer (slot_value (q_arg2 (o1).p)), - q_func3 (o1).p_pi_f (o1->sc, slot_value (q_arg3 (o1).p), - integer (slot_value (q_arg4 (o1).p)))); - integer (vp)++; - } - } - else if ((f == opt_set_p_i_f) && /* tvect.scm */ - (is_t_integer (slot_value (q_arg1 (o1).p))) && - (q_arg1 (o1).p != let_dox_slot1 (do_curlet (o)))) { - opt_info* o2= q_func1_arg (o1).o1; /* set_p_i_f: x = make_integer(o->sc, - o-v[6].fi(o-v[5].o1)); */ - s7_int (*fi) (opt_info* o)= q_call (o2).fi; - s7_pointer ival= - make_mutable_integer (sc, integer (slot_value (q_arg1 (o1).p))); - slot_set_value (q_arg1 (o1).p, ival); - while (integer (vp) < end) { - set_integer (ival, fi (o2)); - integer (vp)++; - } - slot_set_value (q_arg1 (o1).p, - make_integer (sc, integer (slot_value (q_arg1 (o1).p)))); - clear_mutable_integer (ival); - } - else if ((f == opt_d_7pid_ssf_nr) && /* tref.scm */ - (q_func (o1).d_7pid_f == float_vector_set_d_7pid_direct)) { - s7_pointer ind = q_arg2 (o1).p; - opt_info* o2 = do_any_body (o1); - s7_double (*fd) (opt_info* o)= q_call (o2).fd; - s7_pointer fv = slot_value (q_arg1 (o1).p); - while (integer (vp) < end) { - float_vector_set_d_7pid_direct (sc, fv, integer (slot_value (ind)), - fd (o2)); - /* weird! els[integer(slot_value(ind))] = fd(o2) is much slower - * according to callgrind? */ - integer (vp)++; - } - } - else - while (integer (vp) < end) { - f (o1); - integer (vp)++; - } - } - /* splitting out opt_set_p_d_f_sf_add here (for tgsl.scm) is marginal (time is - * in opt_d_dd_ff_mul -> opt_d_id_sf -> bessel funcs) */ - unstack_gc_protect (sc); - set_curlet (sc, old_let); - return (sc->T); +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)))))))); } -#define do_prepack_end(o) o->v[1].i -#define do_prepack_stepper(o) o->v[6].p -#define do_dpnr_func(o) o->v[7] - -static s7_pointer -opt_do_prepackaged (opt_info* o) { - opt_info* o1 = do_stepper_init (o); - s7_int end= (is_slot (let_dox_slot2_unchecked (do_curlet_unchecked (o)))) - ? integer (slot_value (let_dox_slot2 (do_curlet (o)))) - : do_end (o).i; - s7_pointer vp = let_dox1_value (do_curlet (o)); - s7_scheme* sc = o->sc; - const s7_pointer old_let= sc->curlet; - gc_protect_via_stack (sc, old_let); - set_curlet (sc, do_curlet (o)); - set_integer (vp, integer (q_call (o1).fp (o1))); - - do_prepack_stepper (o)= vp; - do_prepack_end (o) = end; - do_dpnr_func (o).fp (o); /* call opt_do_i|dpnr below */ - - unstack_gc_protect (sc); - set_curlet (sc, old_let); - return (sc->T); -} - -static s7_pointer -opt_do_dpnr (opt_info* o) { - opt_info* o1 = do_any_body (o); - s7_pointer vp = do_prepack_stepper (o); - s7_int end = do_prepack_end (o); - s7_double (*f) (opt_info* o)= q_temp (o1).fd; - while (integer (vp) < end) { - f (o1); - integer (vp)++; - } - return (NULL); -} - -static s7_pointer -opt_do_ipnr (opt_info* o) { - opt_info* o1 = do_any_body (o); - s7_pointer vp = do_prepack_stepper (o); - s7_int end = do_prepack_end (o); - s7_int (*f) (opt_info* o)= q_temp (o1).fi; - while (integer (vp) < end) { - f (o1); - integer (vp)++; - } - return (NULL); +static s7_pointer fx_sref_t_last(s7_scheme *sc, s7_pointer arg) {return(string_ref_p_plast(sc, t_lookup(sc, cadr(arg), arg), int_zero));} /* both syms are t_lookup */ +s7_pointer fx_c_a(s7_scheme *sc, s7_pointer arg) {return(fn_proc(arg)(sc, with_list_t1(sc, fx_call(sc, cdr(arg)))));} +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) +{ + s7_pointer result; + 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, gc_protected1(sc)); + result = fn_proc(arg)(sc, sc->t3_1); + unstack_gc_protect(sc); + return(result); } -static bool -stop_is_safe (s7_scheme* sc, s7_pointer stop, s7_pointer body) { - /* this could be folded into the cell_optimize traversal */ - for (s7_pointer 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) { - while (true) { - s7_pointer p= car (tree); - if (is_setter (p)) return (true); - if ((is_unquoted_pair (sc, p)) && (tree_has_setters (sc, p))) return (true); - tree= cdr (tree); - if (!is_pair (tree)) break; +#define fx_c_ssa_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg)))); \ + set_car(sc->t3_1, Lookup1(sc, cadr(arg), arg));\ + set_car(sc->t3_2, Lookup2(sc, car(opt3_pair(arg)), arg)); \ + return(fn_proc(arg)(sc, sc->t3_1));\ } - return (is_setter (tree)); + +fx_c_ssa_any(fx_c_ssa, s_lookup, s_lookup) +fx_c_ssa_any(fx_c_tsa, t_lookup, s_lookup) +fx_c_ssa_any(fx_c_sta, s_lookup, t_lookup) + +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))))); } -#define DO_PRINT 0 -#if DO_PRINT -#define do_is_safe(Sc, Body, Stepper, Var_list, Step_vars, Has_set) \ - do_is_safe_1 (Sc, Body, Stepper, Var_list, Step_vars, Has_set, __func__, \ - __LINE__) -static bool do_is_safe_1 (s7_scheme* sc, s7_pointer body, s7_pointer stepper, - s7_pointer var_list, s7_pointer step_vars, - bool* has_set, const char* funcly, int linely); -#else -static bool do_is_safe (s7_scheme* sc, s7_pointer body, s7_pointer stepper, - s7_pointer var_list, s7_pointer step_vars, - bool* has_set); -#endif +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 bool -do_passes_safety_check (s7_scheme* sc, s7_pointer body, s7_pointer stepper, - s7_pointer step_vars, 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, step_vars, has_set)) - set_unsafe_do (body); - } - return (!is_unsafe_do (body)); +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 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 (s7_t_slot (sc, car (p)))))) || - ((is_pair (car (p))) && (all_integers (sc, car (p)))))) - break; - return (is_null (p)); - } - return (false); +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 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 (s7_t_slot (sc, car (p)))))) || - ((is_pair (car (p))) && (all_floats (sc, car (p)))))) - break; - return (is_null (p)); - } - return (false); +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 bool -opt_cell_do (s7_scheme* sc, s7_pointer expr, int32_t len) { - opt_info* opc; - s7_pointer endp, let= NULL; - const s7_pointer old_let = sc->curlet; - const s7_pointer vars = (is_pair (cdr (expr))) ? cadr (expr) : sc->nil; - const int32_t body_len= len - 3; - int32_t var_len, body_index, step_len, return_exprs, step_pc, init_pc, - end_test_pc; - bool has_set= false; - opt_info *init_o[num_vunions], *step_o[num_vunions], *body_o[num_vunions], - *return_o[num_vunions]; -#if S7_DEBUGGING - for (int32_t i= 0; i < num_vunions; i++) { - body_o[i] = NULL; - init_o[i] = NULL; - step_o[i] = NULL; - return_o[i]= NULL; - } -#endif +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)); +} - if (len < 3) return_false (sc, expr); - if (body_len > num_vunions) return_false (sc, expr); - if (!s7_is_proper_list (sc, vars)) return_false (sc, expr); - var_len = proper_list_length (vars); - step_len= var_len; - endp = caddr (expr); - if (!is_pair (endp)) return_false (sc, expr); - if ((is_pair (vars)) && (is_pair (car (vars))) && (is_pair (cdar (vars))) && - (is_pair (cddar (vars)))) /* expr is the do form */ - { - const s7_pointer old_code= sc->code; - sc->code= expr; /* the do form here could be totally messed up: e.g. (do () - '2) in s7test */ - if (!do_passes_safety_check (sc, cdddr (expr), caar (vars), vars, - &has_set)) { - sc->code= old_code; - if (DO_PRINT) - fprintf (stderr, - "%s[%d]: return(false) because do_passes_safety_check is " - "unhappy: %s\n", - __func__, __LINE__, display (expr)); - return_false (sc, expr); - } - sc->code= old_code; - } +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)); +} - opc= alloc_opt_info (sc); - let= inline_make_let (sc, sc->curlet); - push_stack (sc, OP_GC_PROTECT, old_let, let); +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)); +} - /* 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)))...") +static s7_pointer fx_c_aa(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer result; + /* check_stack_size(sc); */ + gc_protect_2_via_stack(sc, fx_call(sc, cdr(arg)), fx_call(sc, opt3_pair(arg))); /* opt3_pair = cddr(arg) */ + set_car(sc->t2_1, T_Ext(gc_protected1(sc))); + set_car(sc->t2_2, gc_protected2(sc)); + result = fn_proc(arg)(sc, sc->t2_1); + unstack_gc_protect(sc); + /* (define (f0) (write (vector 1.0) (openlet (inlet 'write for-each)))) or worse, + * (define L (openlet (inlet 'write for-each))) (define (f) (write (vector 1.0) L)) + * will segfault (probably) because the for-each pushes an operator on the stack, expecting to continue in eval, but + * write is a safe function that the optimizer thinks can ignore such stuff. s7.html warns about this -- the signatures should be compatible. + * Maybe openlet (or inlet?) should warn about for-each, map, member, and assoc. + * We could check first that stack_top_op == OP_GC_PROTECT and not unstack if it isn't, but there is nothing special to fx_c_aa in that regard. */ - begin_small_symbol_set (sc); - for (s7_pointer p= vars; is_pair (p); p= cdr (p)) { - const s7_pointer var= car (p); - if ((is_pair (var)) && (is_symbol (car (var))) && (is_pair (cdr (var)))) { - const s7_pointer sym= car (var); - if (is_constant_symbol (sc, sym)) { - end_small_symbol_set (sc); - return_false (sc, expr); - } - if (symbol_is_in_small_symbol_set (sc, sym)) - syntax_error_nr (sc, "duplicate identifier in do: ~A", 30, var); - add_symbol_to_small_symbol_set (sc, sym); - add_slot (sc, let, sym, sc->undefined); - } - else { - end_small_symbol_set (sc); - return_false (sc, expr); - } - } - end_small_symbol_set (sc); - if (is_not_slot_end (let_slots (let))) - let_set_slots (let, reverse_slots (let_slots (let))); + return(result); +} - /* inits */ - { - s7_pointer slot= let_slots (let); - init_pc = sc->pc; - { - s7_pointer p= vars; - for (int32_t k= 0; (is_pair (p)) && (k < num_vunions); - k++, p= cdr (p), slot= next_slot (slot)) { - const 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, expr); - if (is_pair (cddr (var))) { - set_has_stepper (slot); - if (!is_null (cdddr (var))) return_false (sc, expr); - } - else { - step_len--; - if (!is_null (cddr (var))) return_false (sc, expr); - } - /* we can't use slot_set_value(slot, q_call(init_o[k]).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 (s7_t_slot (sc, cadr (var)))); - 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= 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 (s7_pointer p= vars; is_pair (p); p= cdr (p)) { - const s7_pointer var= car (p); - if (is_pair (cddr (var))) { - s7_pointer 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_gc_protect (sc); /* not pop_stack! */ - set_curlet (sc, old_let); - return_false (sc, expr); - } - } - } - } +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)); +} - /* end test */ - end_test_pc= sc->pc; - if (!bool_optimize_nw (sc, endp)) { - unstack_gc_protect (sc); /* not pop_stack! */ - set_curlet (sc, old_let); - return_false (sc, expr); - } - { - const s7_pointer stop= car (endp); - 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))))) { - const s7_pointer stop_slot= (is_symbol (caddr (stop))) - ? opt_integer_symbol (sc, caddr (stop)) - : sc->nil; - if (stop_slot) { - s7_int lim= (is_slot (stop_slot)) ? integer (slot_value (stop_slot)) - : integer (caddr (stop)); - bool set_stop= false; - if (car (stop) == sc->gt_symbol) lim++; - for (s7_pointer p= vars, 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)) { - const 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_has_loop_end (slot); - slot_set_value ( - slot, make_mutable_integer (sc, integer (slot_value (slot)))); - set_loop_end (slot, lim); - } - } - } +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)); +} - if (!set_stop) { - const s7_pointer slot2= opt_integer_symbol (sc, cadr (stop)); - if ((slot2) && (stop_is_safe (sc, cadr (stop), - cddr (expr)))) /* b_fft in tfft.scm */ - { - set_has_loop_end (slot2); - set_loop_end (slot2, lim); - } - } - } - } - } - - /* body */ - body_index= sc->pc; - { - s7_pointer p= cdddr (expr); - for (int32_t k= 0; k < len - 3; - k++, p= cdr (p)) /* len (from p_syntax_ok)=form length (do - body...) */ - { - opt_info* start= sc->opts[sc->pc]; - body_o[k] = start; - sc->do_body_p = car ( - p); /* a horrible kludge, but I have run out of type bits for pairs */ - /* if (i < 5) opc-v[i + 7].o1 = start; */ /* why this? */ - if (!cell_optimize (sc, p)) break; - oo_idp_nr_fixup (start); - } - sc->do_body_p= NULL; - if (!is_null (p)) { - unstack_gc_protect (sc); - set_curlet (sc, old_let); - return_false (sc, expr); - } - } +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_c_ai_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_pi_t)opt3_direct(cdr(arg)))(sc, fx_call(sc, cdr(arg)), integer(opt3_con(arg))));} - /* 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; - { - s7_pointer p= vars; - for (int32_t k= 0; is_pair (p); k++, p= cdr (p)) { - const 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_gc_protect (sc); - set_curlet (sc, old_let); - return_false (sc, expr); - } - } +static s7_pointer fx_sub_a1(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer num = fx_call(sc, cdr(arg)); + if (is_t_integer(num)) return(subtract_if_overflow_to_real_or_big_integer(sc, integer(num), 1)); + if (is_t_real(num)) return(make_real(sc, real(num) - 1.0)); + return(subtract_p_pp(sc, num, int_one)); +} - /* result */ - if (!is_list (cdr (endp))) { - unstack_gc_protect (sc); - set_curlet (sc, old_let); - return_false (sc, expr); - } - { - s7_pointer p= cdr (endp); - for (return_exprs= 0; (is_pair (p)) && (return_exprs < num_vunions); - p = cdr (p), return_exprs++) { - return_o[return_exprs]= sc->opts[sc->pc]; - if (!cell_optimize (sc, p)) break; - } - if (!is_null (p)) { - unstack_gc_protect (sc); - set_curlet (sc, old_let); - return_false (sc, expr); - } - } +static s7_pointer fx_add_a1(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer num = fx_call(sc, cdr(arg)); + if (is_t_integer(num)) return(add_if_overflow_to_real_or_big_integer(sc, integer(num), 1)); + if (is_t_real(num)) return(make_real(sc, real(num) + 1.0)); + return(add_p_pp(sc, num, int_one)); +} - do_curlet_unchecked (opc)= T_Let (let); - do_body_length (opc) = len - 3; - do_result_length (opc) = return_exprs; - do_stepper_opt (opc) = sc->opts[step_pc]; - set_curlet (sc, old_let); - - if ((var_len == 0) && (return_exprs == 0)) { - opt_info* body; - do_no_vars_test (opc)= sc->opts[end_test_pc]; - q_call (opc).fp = opt_do_no_vars; - if (body_len > 0) { - body= alloc_opt_info (sc); - for (int32_t k= 0; k < body_len; k++) - do_expr (body, k).o1= body_o[k]; - do_no_vars_body (opc)= body; - } - return_true (sc, expr); - } - do_stepper_safe (opc)= 0; - if (body_len == 1) { - const s7_pointer expr3= cadddr (expr); /* 1 expr in body */ - if ((is_pair (expr3)) && - ((is_c_function (car (expr3))) || /* (#_sqrt 2.0)?? */ - (is_safe_setter (car (expr3))) || /* (byte-vector-set! iv 1 0) */ - ((car (expr3) == sc->set_symbol) && /* (set! sum (+ sum 1)) */ - (cadr (expr3) != caar (vars))) || /* caadr: (stepper init ...) */ - ((car (expr3) == sc->vector_set_symbol) && - (is_null (cddddr (expr3))) && - (is_code_constant (sc, cadddr (expr3)))))) - do_stepper_safe (opc)= 1; /* checked in opt_do_1 */ - } - if ((var_len != 1) || (step_len != 1) || (return_exprs != 0)) { - opt_info* inits; - q_call (opc).fp= ((step_len == 1) && (body_len == 1) && (return_exprs == 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 ((q_call (opc).fp == opt_do_step_1) && - (q_call (do_stepper_opt (opc)).fp == i_to_p) && - (q_temp (do_stepper_opt (opc)).fi == opt_i_ii_sc_add) && - (q_call (do_any_test (opc)).fb == opt_b_ii_ss_eq)) - q_call (opc).fp= opt_do_step_i; - - inits= alloc_opt_info (sc); - for (int32_t k= 0; k < var_len; k++) - do_expr (inits, k).o1= init_o[k]; - do_any_inits (opc)= inits; - - if (q_call (opc).fp == opt_do_any) { - opt_info *result, *step; - opt_info* body= alloc_opt_info (sc); - - for (int32_t k= 0; k < body_len; k++) - do_expr (body, k).o1= body_o[k]; - do_any_body (opc)= body; - - result= alloc_opt_info (sc); - for (int32_t k= 0; k < return_exprs; k++) - do_expr (result, k).o1= return_o[k]; - do_any_results (opc)= result; - - step= alloc_opt_info (sc); - for (int32_t k= 0; k < var_len; k++) - do_expr (step, 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 (sc, expr); - } +static s7_pointer fx_lt_ad(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer num = fx_call(sc, cdr(arg)); + if (is_t_real(num)) return(make_boolean(sc, real(num) < real(opt3_con(arg)))); + if (is_t_integer(num)) return(make_boolean(sc, integer(num) < real(opt3_con(arg)))); + return(make_boolean(sc, lt_b_7pp(sc, num, opt3_con(arg)))); +} - q_call (opc).fp= (body_len == 1) ? opt_do_1 : opt_do_n; - { - const s7_pointer ind = caar (vars); - const s7_pointer ind_step= caddar (vars); - const s7_pointer end = caaddr (expr); - if (body_len == 1) /* opt_do_1 */ - do_any_body (opc)= sc->opts[body_index]; - else { - opt_info* body= alloc_opt_info (sc); - for (int32_t k= 0; k < body_len; k++) - do_expr (body, 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 loop_end_possible 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 (expr), ind, vars, &has_set))) { - const s7_pointer slot= let_slots (let); - let_set_dox_slot1 (let, slot); - let_set_dox_slot2_unchecked (let, - (is_symbol (caddr (end))) - ? s7_t_slot (sc, caddr (end)) - : sc->undefined); /* undefined_slot? */ - slot_set_value (slot, - make_mutable_integer (sc, integer (slot_value (slot)))); - /* do_body_start(opc).i = body_index; */ /* start point (sc->pc) for - body, apparently never used - */ - if (body_len == 1) /* opt_do_1 */ - { - const opt_info* o1= sc->opts[body_index]; - q_call (opc).fp = opt_do_very_simple; - if (is_t_integer (caddr (end))) do_end (opc).i= integer (caddr (end)); - if (q_call (o1).fp == - d_to_p_nr) /* snd-test: (do ((k 0 (+ k 1))) ((= k N)) - (float-vector-set! rl k (read-sample rd))) */ - { - q_call (opc).fp = opt_do_prepackaged; - do_dpnr_func (opc).fp= opt_do_dpnr; - } - else if (q_call (o1).fp == i_to_p_nr) { - q_call (opc).fp = opt_do_prepackaged; - do_dpnr_func (opc).fp= opt_do_ipnr; - } - } - else { - q_call (opc).fp= opt_do_times; - if (is_t_integer (caddr (end))) - do_times_end (opc).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 (expr), ind, vars, &has_set))) - q_call (opc).fp= opt_do_list_simple; - } - } - return_true (sc, expr); -} - -static bool -p_syntax_ok (s7_scheme* sc, s7_pointer expr, int32_t len) { - const s7_pointer func= lookup_global (sc, car (expr)); - opcode_t op; - if (OPT_PRINT) - fprintf (stderr, " p_syntax_ok[%d]: %s\n", __LINE__, display (expr)); - if (!is_syntax (func)) { - clear_syntactic (expr); - return_false (sc, expr); - } - /* I think this is the only case where we don't precede syntax_opcode with - * syntactic_symbol checks */ - op= syntax_opcode (func); - switch (op) { - case OP_QUOTE: - if ((is_pair (cdr (expr))) && (is_null (cddr (expr)))) - return (opt_cell_quote (sc, expr)); - break; - case OP_SET: - if (len == 3) return (opt_cell_set (sc, expr)); - break; - case OP_BEGIN: - if (len > 1) return (opt_cell_begin (sc, expr, len)); - break; - case OP_WHEN: - case OP_UNLESS: - if (len > 2) return (opt_cell_when (sc, expr, len)); - break; - case OP_COND: - if (len > 1) return (opt_cell_cond (sc, expr)); - break; - case OP_CASE: - if (len > 2) return (opt_cell_case (sc, expr)); - break; - case OP_AND: - case OP_OR: - return (opt_cell_and (sc, expr, len)); - case OP_IF: - return (opt_cell_if (sc, expr, len)); - case OP_DO: - return (opt_cell_do (sc, expr, len)); - case OP_LET_TEMPORARILY: - return (opt_cell_let_temporarily (sc, expr, len)); - default: - /* for lambda et al we'd return the new closure, but if unsafe? - * let(*) -> make the let -> body (let=99% of cases), could we use do - * (i.e. do+no steppers+no end!) or let-temp? with-let -> establish - * car(args)=let, then body macroexpand -> return the expansion define et al - * -> define + return value map and for-each are not syntax, also - * call-with*(=exit) also let-temp for vars>1 - */ - break; - } - return_false (sc, expr); +static s7_pointer fx_is_eq_ac(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer y = opt3_con(arg); + s7_pointer x = fx_call(sc, cdr(arg)); + return(make_boolean(sc, (x == y) || ((is_unspecified(x)) && (is_unspecified(y))))); } -/* -------------------------------------------------------------------------------- - */ -static bool -float_optimize_1 (s7_scheme* sc, s7_pointer form) { - const s7_pointer expr= car (form); - s7_pointer head, s_func, s_slot= NULL; - s7_int len; - if (OPT_PRINT) - fprintf (stderr, " float_optimize[%d] %s\n", __LINE__, display (form)); - - if (!is_pair (expr)) /* wrap constants/symbols */ - return_bool (sc, opt_float_not_pair (sc, expr), expr); - head= car (expr); - len = s7_list_length (sc, expr); - if (is_symbol (head)) { - if ((is_syntactic_symbol (head)) || (is_syntactic_pair (expr))) - return_bool (sc, d_syntax_ok (sc, expr, len), expr); - - s_slot= s7_slot (sc, head); - if (!is_slot (s_slot)) return_false (sc, expr); - s_func= slot_value (s_slot); +#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)); \ } - else if (is_c_function (head)) s_func= head; - else return_false (sc, expr); - - if (is_c_function (s_func)) { - opt_info* opc= alloc_opt_info (sc); - switch (len) { - case 1: - return_bool (sc, d_ok (sc, opc, s_func), expr); - case 2: /* (f v) or (f d): (env e) or (abs x) */ - return_bool (sc, - ((d_d_ok (sc, opc, s_func, expr)) || - (d_v_ok (sc, opc, s_func, expr)) || - (d_p_ok (sc, opc, s_func, expr))), - expr); - case 3: - return_bool (sc, - ((d_dd_ok (sc, opc, s_func, expr)) || - (d_id_ok (sc, opc, s_func, expr)) || - (d_vd_ok (sc, opc, s_func, expr)) || - (d_pd_ok (sc, opc, s_func, expr)) || - (d_ip_ok (sc, opc, s_func, expr)) || - (d_7pi_ok (sc, opc, s_func, expr))), - expr); - case 4: - return_bool (sc, - ((d_ddd_ok (sc, opc, s_func, expr)) || - (d_7pid_ok (sc, opc, s_func, expr)) || - (d_vid_ok (sc, opc, s_func, expr)) || - (d_vdd_ok (sc, opc, s_func, expr)) || - (d_7pii_ok (sc, opc, s_func, expr))), - expr); - case 5: - return_bool (sc, - ((d_dddd_ok (sc, opc, s_func, expr)) || - (d_7piid_ok (sc, opc, s_func, expr)) || - (d_7piii_ok (sc, opc, s_func, expr))), - expr); - case 6: - if (d_7piiid_ok (sc, opc, s_func, expr)) return_true (sc, expr); - /* fall through */ - default: - return_bool (sc, d_add_any_ok (sc, opc, expr), expr); - } - } - else { - if ((is_macro (s_func)) && (!no_cell_opt (form))) { - const s7_pointer body= closure_body (s_func); - if ((is_null (cdr (body))) && (is_pair (car (body))) && - ((caar (body) == sc->list_symbol) || - (caar (body) == sc->list_values_symbol) || - (is_eq_initial_c_function_data (sc->list_values_symbol, - caar (body))))) { - const s7_pointer result= s7_macroexpand (sc, s_func, cdar (form)); - if (result == sc->F) return_false (sc, expr); - return (float_optimize (sc, set_plist_1 (sc, result))); - } - } - if (!s_slot) return_false (sc, expr); - return_bool (sc, d_implicit_ok (sc, s_slot, expr, len), expr); - } - return_false (sc, expr); -} - -static bool -float_optimize (s7_scheme* sc, s7_pointer expr) { - return ((float_optimize_1 (sc, expr)) && (sc->pc < OPTS_SIZE)); -} -/* combining the sc->pc check into float_optimize_1 (and similarly for the other - * 3 cases) does not given any speedup */ - -static bool -int_optimize_1 (s7_scheme* sc, s7_pointer form) { - const s7_pointer expr= car (form); - s7_pointer head, s_func, s_slot= NULL; - s7_int len; - - if (OPT_PRINT) fprintf (stderr, " int_optimize %s\n", display (form)); - - if (!is_pair (expr)) /* wrap constants/symbols */ - return_bool (sc, opt_int_not_pair (sc, expr), expr); - head= car (expr); - len = s7_list_length (sc, expr); - if (is_symbol (head)) { - if ((is_syntactic_symbol (head)) || (is_syntactic_pair (expr))) - return_bool (sc, i_syntax_ok (sc, expr, len), expr); - s_slot= s7_slot (sc, head); - if (!is_slot (s_slot)) return_false (sc, expr); - s_func= slot_value (s_slot); - } - else if (is_c_function (head)) s_func= head; - else return_false (sc, expr); - - if (is_c_function (s_func)) { - opt_info* opc= alloc_opt_info (sc); - switch (len) { - case 2: - return_bool (sc, i_idp_ok (sc, opc, s_func, expr), expr); - case 3: - return_bool (sc, - ((i_ii_ok (sc, opc, s_func, expr)) || - (i_7pi_ok (sc, opc, s_func, expr))), - expr); - case 4: - return_bool (sc, - ((i_iii_ok (sc, opc, s_func, expr)) || - (i_7pii_ok (sc, opc, s_func, expr))), - expr); - case 5: { - int32_t pstart= sc->pc; - if (i_7piii_ok (sc, opc, s_func, expr)) return_true (sc, expr); - sc->pc= pstart; - } - /* fall through */ - default: - return_bool ( - sc, - (((head == sc->add_symbol) || (head == sc->multiply_symbol)) && - (i_add_any_ok (sc, opc, expr))), - expr); - } - } - else { -#if 0 - /* if (is_closure(s_func)) and body is one expr and safe, we could pull out the body, substitute pars for args, int_optimize that */ - /* check for simple args and no definers/binders first (can't int-optimize them anyway) */ - if ((is_closure(s_func)) && (is_safe_closure(s_func)) && (!no_cell_opt(form))) - { - const s7_pointer body = closure_body(s_func); - if ((is_null(cdr(body))) && (is_pair(car(body)))) /* this hits every test in s7test! */ - { - if (caar(body) != sc->let_symbol) - fprintf(stderr, "%s[%d]: %s %s\n", __func__, __LINE__, display(body), display(form)); - /* see s7test (f3 123) -- expansion can lead to funclet confusion -- same in macros? but this would not be int_optimizable */ - /* timing tests don't get many useful hits */ - }} -#endif - if ((is_macro (s_func)) && (!no_cell_opt (form))) { - const s7_pointer body= closure_body (s_func); - if ((is_null (cdr (body))) && (is_pair (car (body))) && - ((caar (body) == sc->list_symbol) || - (caar (body) == sc->list_values_symbol) || - (is_eq_initial_c_function_data (sc->list_values_symbol, - caar (body))))) { - s7_pointer result= - s7_macroexpand (sc, s_func, cdar (form)); /* cdar(form) = arglist */ - if (result == sc->F) return_false (sc, expr); - return (int_optimize (sc, set_plist_1 (sc, result))); - } - } - if (!s_slot) return_false (sc, expr); - return_bool (sc, i_implicit_ok (sc, s_slot, expr, len), expr); +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) + +#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)))); \ } - return_false (sc, expr); -} -static bool -int_optimize (s7_scheme* sc, s7_pointer expr) { - return ((int_optimize_1 (sc, expr)) && (sc->pc < OPTS_SIZE)); -} +fx_c_sa_direct_any(fx_c_sa_direct, s_lookup) +fx_c_sa_direct_any(fx_c_ua_direct, u_lookup) -/* cell_optimize... */ -static bool -p_2x_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr, int32_t pstart, s7_pointer form) { - const s7_pointer sig= c_function_signature (s_func); - if (is_symbol (cadr (expr))) { - 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, expr)) return_true (sc, expr); - - if ((car (sig) == sc->is_float_symbol) || - (car (sig) == sc->is_real_symbol)) { - const s7_d_7pi_t func= s7_d_7pi_function (s_func); - if (func) { - sc->pc= pstart - 1; - if (float_optimize (sc, form)) { - q_temp (opc).fd= q_call (opc).fd; - q_call (opc).fp= d_to_p; - return_true (sc, expr); - } - } - } - sc->pc= pstart; - } - } - { - const s7_i_ii_t ifunc= s7_i_ii_function (s_func); - sc->pc = pstart - 1; - if ((ifunc) && (int_optimize (sc, form))) { - q_temp (opc).fi= q_call (opc).fi; - q_call (opc).fp= i_to_p; - if (q_temp (opc).fi == opt_i_ii_ss_add) q_call (opc).fp= opt_p_ii_ss_add; - return_true (sc, expr); - } +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, sc->temp3 = 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, sc->temp3 = 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, sc->temp3 = 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)); \ } - sc->pc= pstart; - return_bool (sc, - ((p_ii_ok (sc, opc, s_func, expr, pstart)) || - (p_dd_ok (sc, opc, s_func, expr, pstart)) || - (p_pp_ok (sc, opc, s_func, expr, pstart)) || - (p_call_pp_ok (sc, opc, s_func, expr, pstart))), - expr); -} - -static bool -p_3x_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr, int32_t pstart) { - const s7_pointer sig= c_function_signature (s_func); - if (is_symbol (cadr (expr))) { - if ((is_pair (sig)) && (is_pair (cdr (sig))) && (is_pair (cddr (sig))) && - (caddr (sig) == sc->is_integer_symbol)) { - 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, expr))) { - /* if d_7pid is ok, we need d_to_p for cell_optimize */ - q_temp (opc).fd= q_call (opc).fd; - q_call (opc).fp= d_to_p; - return_true (sc, expr); - } - sc->pc= pstart - 1; - if ((car (sig) == sc->is_integer_symbol) && - (s7_i_7pii_function (s_func)) && - (i_7pii_ok (sc, alloc_opt_info (sc), s_func, expr))) { - q_temp (opc).fi= q_call (opc).fi; - q_call (opc).fp= i_to_p; - return_true (sc, expr); - } - sc->pc= pstart; +fx_c_as_any(fx_c_as, s_lookup) +fx_c_as_any(fx_c_at, t_lookup) - if (p_pii_ok (sc, opc, s_func, expr)) return_true (sc, expr); - if (p_pip_ok (sc, opc, s_func, expr)) return_true (sc, expr); - } - } - return_bool (sc, - ((p_ppi_ok (sc, opc, s_func, expr)) || - (p_ppp_ok (sc, opc, s_func, expr)) || - (p_call_ppp_ok (sc, opc, s_func, expr))), - expr); -} - -static bool -p_4x_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr, int32_t pstart) { - const s7_pointer head= car (expr); - const s7_int len = s7_list_length (sc, expr); - - if ((is_target_or_its_alias (head, s_func, sc->float_vector_set_symbol)) && - (d_7piid_ok (sc, opc, s_func, expr))) { - q_temp (opc).fd= q_call (opc).fd; - q_call (opc).fp= d_to_p; /* as above, if d_7piid is ok, we need d_to_p for - cell_optimize */ - return_true (sc, expr); - } - if ((is_target_or_its_alias (head, s_func, sc->float_vector_ref_symbol)) && - (d_7piii_ok (sc, opc, s_func, expr))) { - q_temp (opc).fd= q_call (opc).fd; - q_call (opc).fp= d_to_p; - return_true (sc, expr); - } - if (i_7piii_ok (sc, opc, s_func, expr)) { - q_temp (opc).fi= q_call (opc).fi; - q_call (opc).fp= i_to_p; - return_true (sc, expr); - } - if (is_target_or_its_alias (head, s_func, sc->int_vector_set_symbol)) - return_false (sc, expr); - if (p_piip_ok (sc, opc, s_func, expr)) return_true (sc, expr); - sc->pc= pstart; - if (s_func == global_value (sc->vector_ref_symbol)) { - s7_pointer obj; - if (!is_symbol (cadr (expr))) return_false (sc, expr); - obj= lookup_unexamined ( - sc, - cadr ( - expr)); /* was lookup_from (to avoid the unbound variable check) */ - if ((!obj) || (!is_any_vector (obj)) || (vector_rank (obj) != 3)) - return_false (sc, expr); - } - return_bool (sc, p_call_any_ok (sc, opc, s_func, expr, len), expr); -} - -static bool -p_5x_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr, int32_t pstart) { - const s7_pointer head= car (expr); - if ((is_target_or_its_alias (head, s_func, sc->float_vector_set_symbol)) && - (d_7piiid_ok (sc, opc, s_func, expr))) { - q_temp (opc).fd= q_call (opc).fd; - q_call (opc).fp= d_to_p; - return_true (sc, expr); - } - return_false (sc, expr); +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)))); } -#if OPT_PRINT -static bool -cell_optimize_1 (s7_scheme* sc, s7_pointer form, int line) -#else -static bool -cell_optimize_1 (s7_scheme* sc, s7_pointer form) -#endif +static s7_pointer fx_add_as(s7_scheme *sc, s7_pointer arg) { - const s7_pointer expr= car (form); - s7_pointer head, s_func, s_slot= NULL; - s7_int len; -#if OPT_PRINT /* needed due to line arg */ - fprintf (stderr, " cell_optimize[%d] %s\n", line, display (form)); -#endif - if (!is_pair (expr)) /* wrap constants/symbols */ - return (opt_cell_not_pair (sc, expr)); - - head= car (expr); - len = s7_list_length (sc, expr); - if (is_symbol (head)) { - if ((is_syntactic_symbol (head)) || - (is_syntactic_pair (expr))) /* this can be wrong! */ - return_bool (sc, p_syntax_ok (sc, expr, len), expr); - - s_slot= s7_slot (sc, head); - if (!is_slot (s_slot)) return_false (sc, expr); - s_func= slot_value (s_slot); - } - else if (is_c_function (head)) /* (#_abs -1) I think */ s_func= head; - else { /* ((let-ref L 'mult) 1 2) or 'a etc */ - if ((head == sc->quote_function) && - ((is_pair (cdr (expr))) && (is_null (cddr (expr))))) - return_bool (sc, opt_cell_quote (sc, expr), expr); - - /* if head is ([let-ref] L 'multiply), it should be accessible now, so we - * could do the lookup, set up s_func and go on */ - /* but this is not safe if there's a let-set! or (set! (let...)...) in the - * body and this let-ref is the car */ - if (is_pair (head)) { - s7_pointer let, sym; - if ((car (head) == sc->let_ref_symbol) && - (s7_list_length (sc, head) == 3)) { - let= cadr (head); - sym= caddr (head); - } - else if (s7_list_length (sc, head) == 2) { - let= car (head); - sym= cadr (head); - } - else if (((car (head) == sc->unlet_symbol) || - (car (head) == sc->rootlet_symbol)) && - (is_pair (cdr (expr)))) /* ((unlet) :abs) */ - { - sym= cadr (expr); - if ((is_symbol_and_keyword (sym)) || (is_quoted_symbol (sc, sym))) - return_bool (sc, - opt_unlet_rootlet_ref ( - sc, alloc_opt_info (sc), head, - (is_pair (sym)) ? cadr (sym) : keyword_symbol (sym), - expr), - expr); - return_false (sc, expr); - } - else return_false (sc, expr); - if ((is_symbol (let)) && - ((is_symbol_and_keyword (sym)) || (is_quoted_symbol (sc, sym)))) { - const s7_pointer slot= s7_t_slot (sc, let); - if (!is_slot (slot)) return_false (sc, expr); - let= slot_value (slot); - if ((!is_let (let)) || (has_let_ref_fallback (let))) - return_false (sc, expr); - sym = (is_pair (sym)) ? cadr (sym) : keyword_symbol (sym); - s_func= let_ref_p_pp (sc, let, sym); - } - else return_false (sc, expr); - } - else return_false (sc, expr); - } - if (is_c_function (s_func)) { - opt_info* opc= alloc_opt_info (sc); - switch (len) { - case 1: - return_bool (sc, p_ok (sc, opc, s_func, expr), expr); - case 2: - return_bool (sc, - ((p_i_ok (sc, opc, s_func, expr, sc->pc)) || - (p_d_ok (sc, opc, s_func, expr, sc->pc)) || - (p_p_ok (sc, opc, s_func, expr))), - expr); - case 3: - return_bool (sc, p_2x_ok (sc, opc, s_func, expr, sc->pc, form), expr); - case 4: - return_bool (sc, p_3x_ok (sc, opc, s_func, expr, sc->pc), expr); - case 5: - return_bool (sc, p_4x_ok (sc, opc, s_func, expr, sc->pc), expr); - case 6: - if (p_5x_ok (sc, opc, s_func, expr, sc->pc)) return_true (sc, expr); - /* fall through */ - default: - return_bool (sc, p_call_any_ok (sc, opc, s_func, expr, len), - expr); /* >3D vector-set etc */ - } - } - else { - if (is_closure (s_func)) { - opt_info* opc= alloc_opt_info (sc); - if (p_fx_any_ok (sc, opc, form)) return_true (sc, expr); - } - if (is_macro (s_func)) - return_false ( - sc, - expr); /* macroexpand+cell_optimize here restarts the optimize process - (this refers to int|float_optimize macro expansion) */ - if (!s_slot) return_false (sc, expr); - return_bool (sc, p_implicit_ok (sc, s_slot, expr, len), expr); - } - return_false (sc, expr); + s7_pointer x1 = fx_call(sc, cdr(arg)); + s7_pointer 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)); } -#if OPT_PRINT -static bool -cell_optimize_with_line (s7_scheme* sc, s7_pointer expr, int line) { - return ((cell_optimize_1 (sc, expr, line)) && (sc->pc < OPTS_SIZE)); +static s7_pointer fx_multiply_sa(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer x1 = lookup(sc, cadr(arg)); + s7_pointer 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)); } -#else -static bool -cell_optimize (s7_scheme* sc, s7_pointer expr) { - return ((cell_optimize_1 (sc, expr)) && (sc->pc < OPTS_SIZE)); + +static s7_pointer fx_multiply_sa_wrapped(s7_scheme *sc, s7_pointer arg) /* experiment */ +{ + s7_pointer x1 = lookup(sc, cadr(arg)); + s7_pointer x2 = fx_call(sc, cddr(arg)); + if ((is_t_real(x1)) && (is_t_real(x2))) return(wrap_real(sc, real(x1) * real(x2))); + return(multiply_p_pp_wrapped(sc, x1, x2)); } -#endif -static bool -bool_optimize_nw_1 (s7_scheme* sc, s7_pointer form) { - const s7_pointer expr= car (form); - s7_pointer head, s_func= NULL; - s7_int len; - if (!is_pair (expr)) /* wrap constants/symbols */ - return_bool (sc, opt_bool_not_pair (sc, expr), expr); - - head= car (expr); - len = s7_list_length (sc, expr); - if (is_symbol (head)) { - if ((is_syntactic_symbol (head)) || (is_syntactic_pair (expr))) { - if (head == sc->and_symbol) - return_bool (sc, opt_b_and (sc, expr, len), expr); - if (head == sc->or_symbol) - return_bool (sc, opt_b_or (sc, expr, len), expr); - return_false (sc, expr); - } - s_func= lookup_unexamined (sc, head); - } - else if (is_c_function (head)) s_func= head; - else return_false (sc, expr); - - if (!s_func) return_false (sc, expr); - if (is_c_function (s_func)) { - if ((is_symbol (head)) && - (!is_global (head))) /* (float-vector? (block)) -- both safe c_funcs, - but this is a method invocation */ - return_false (sc, expr); - switch (len) { - case 2: - return_bool ( - sc, b_idp_ok (sc, s_func, form, opt_arg_type (sc, cdr (expr))), form); - case 3: { - s7_pointer arg1= cadr (expr), arg2= caddr (expr); - s7_pointer sig1 = opt_arg_type (sc, cdr (expr)); - s7_pointer sig2 = opt_arg_type (sc, cddr (expr)); - opt_info* opc = alloc_opt_info (sc); - int32_t cur_index= sc->pc; - s7_b_7pp_t bpf7 = NULL; - s7_b_pp_t bpf; - - if ((sig2 == sc->is_integer_symbol) || (sig2 == sc->is_byte_symbol)) { - if (((sig1 == sc->is_integer_symbol) || (sig1 == sc->is_byte_symbol)) && - (b_ii_ok (sc, opc, s_func, expr, arg1, arg2))) - return_true (sc, expr); - sc->pc= cur_index; - if (b_pi_ok (sc, opc, s_func, expr, arg2)) return_true (sc, expr); - sc->pc= cur_index; - } +static s7_pointer fx_subtract_aa(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer x2; + s7_pointer x1 = fx_call(sc, cdr(arg)); + sc->value = x1; + 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)); +} - if ((sig1 == sc->is_float_symbol) && (sig2 == sc->is_float_symbol) && - (b_dd_ok (sc, opc, s_func, expr, arg1, arg2))) - return_true (sc, expr); - sc->pc= cur_index; - - bpf= s7_b_pp_function (s_func); - if (!bpf) bpf7= s7_b_7pp_function (s_func); - if ((bpf) || (bpf7)) { - if (bpf) q_func (opc).b_pp_f= bpf; - else q_func (opc).b_7pp_f= bpf7; - return (b_pp_ok (sc, opc, s_func, expr, arg1, arg2, bpf)); - } - } break; - default: - break; - } - } - return_false (sc, expr); +static s7_pointer fx_add_aa(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer x2; + const s7_pointer x1 = fx_call(sc, cdr(arg)); + sc->value = x1; + x2 = fx_call(sc, opt3_pair(arg)); + if (is_t_real(x1)) {if (is_t_real(x2)) return(make_real(sc, real(x1) + real(x2)));} + else + if ((is_t_integer(x1)) && (is_t_integer(x2))) /* (define (func) (let ((f (lambda (a) a))) (f (+ (*s7* 'most-positive-fixnum) (*))))) (func) */ + return(add_if_overflow_to_real_or_big_integer(sc, integer(x1), integer(x2))); + return(add_p_pp(sc, x1, x2)); } -static bool -bool_optimize_nw (s7_scheme* sc, s7_pointer expr) { - return ((bool_optimize_nw_1 (sc, expr)) && (sc->pc < OPTS_SIZE)); +static s7_pointer fx_multiply_aa(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer x2; + const s7_pointer x1 = fx_call(sc, cdr(arg)); + sc->value = x1; + 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 bool -bool_optimize (s7_scheme* sc, s7_pointer expr) { - const int32_t start= sc->pc; - opt_info* wrapper; - if (OPT_PRINT) fprintf (stderr, " bool_optimize %s\n", display (expr)); - if (bool_optimize_nw (sc, expr)) return_true (sc, expr); - sc->pc = start; - wrapper= sc->opts[start]; - if (!cell_optimize (sc, expr)) return_false (sc, expr); - if (q_temp (wrapper).fp) /* (when (+ i 1) ...) */ - return_false (sc, expr); - q_temp (wrapper).fp= q_call (wrapper).fp; - q_call (wrapper).fb= p_to_b; - return_true (sc, expr); -} - -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_success (sc, opt_bool_any, expr); - return_null (sc, expr); -} - -static s7_double -opt_float_any (s7_scheme* sc) { - return (q_call (sc->opts[0]).fd (sc->opts[0])); -} /* for snd-sig.c */ - -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); /* can't return_null(sc, expr) here due to type mismatch - (s7_pfunc vs s7_float_function) */ -} - -static s7_pfunc -s7_optimize_1 (s7_scheme* sc, s7_pointer expr, bool nv) { - if ((!is_pair (expr)) || (no_cell_opt (expr)) || (sc->debug != 0)) - return_null (sc, expr); - sc->pc= 0; - if (!no_int_opt (expr)) { - if (int_optimize (sc, expr)) - return_success (sc, (nv) ? opt_int_any_nv : opt_make_int, expr); - sc->pc= 0; - set_no_int_opt (expr); - } - if (!no_float_opt (expr)) { - if (float_optimize (sc, expr)) - return_success (sc, (nv) ? opt_float_any_nv : opt_make_float, expr); - sc->pc= 0; - set_no_float_opt (expr); - } - if (!no_bool_opt (expr)) { - if (bool_optimize_nw (sc, expr)) - return_success (sc, (nv) ? opt_bool_any_nv : opt_wrap_bool, expr); - sc->pc= 0; - set_no_bool_opt (expr); - } - if (cell_optimize (sc, expr)) - return_success (sc, (nv) ? opt_cell_any_nv : opt_wrap_cell, expr); - set_no_cell_opt (expr); /* checked above */ - return_null (sc, expr); +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)); } -s7_pfunc -s7_optimize (s7_scheme* sc, s7_pointer expr) { - return (s7_optimize_1 (sc, expr, false)); +static s7_pointer fx_c_aaa(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer result; + /* 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, gc_protected2(sc)); + set_car(sc->t3_1, gc_protected1(sc)); + result = fn_proc(arg)(sc, sc->t3_1); + unstack_gc_protect(sc); + return(result); } -static s7_pfunc -s7_optimize_nv (s7_scheme* sc, s7_pointer expr) { - return (s7_optimize_1 (sc, expr, true)); + +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 -g_optimize (s7_scheme* sc, s7_pointer args) /* s7-optimize in scheme */ +static s7_pointer fx_c_opaq_s(s7_scheme *sc, s7_pointer arg) { - s7_pfunc func; - s7_pointer code= car (args), result= sc->undefined; - gc_protect_via_stack (sc, code); - func= s7_optimize (sc, code); - if (func) result= func (sc); - if (stack_top_op (sc) == OP_GC_PROTECT) unstack_gc_protect (sc); - return (result); + set_car(sc->t2_1, fn_proc(cadr(arg))(sc, with_list_t1(sc, fx_call(sc, cdadr(arg))))); + set_car(sc->t2_2, lookup_checked(sc, caddr(arg))); + return(fn_proc(arg)(sc, sc->t2_1)); } -static s7_pfunc -s7_cell_optimize (s7_scheme* sc, s7_pointer expr, bool nv) { - if (OPT_PRINT) fprintf (stderr, " s7_cell_optimize %s\n", display (expr)); - sc->pc= 0; - if ((cell_optimize (sc, expr)) && (sc->pc < OPTS_SIZE)) - return ((nv) ? opt_cell_any_nv : opt_wrap_cell); - return_null (sc, expr); +static s7_pointer fx_c_s_opaq(s7_scheme *sc, s7_pointer arg) +{ + set_car(sc->t2_2, fn_proc(caddr(arg))(sc, with_list_t1(sc, fx_call(sc, opt3_pair(arg))))); /* cdaddr(arg) */ + set_car(sc->t2_1, lookup_checked(sc, cadr(arg))); + return(fn_proc(arg)(sc, sc->t2_1)); } -/* ---------------- bool funcs (an experiment) ---------------- */ -static void -fx_curlet_tree (s7_scheme* sc, s7_pointer code) { - s7_pointer slot1= let_slots (sc->curlet), slot3= NULL, outer_e; - bool more_vars; - s7_pointer slot2= next_slot (slot1); - if (is_not_slot_end (slot2)) slot3= next_slot (slot2); - - more_vars= (is_not_slot_end (slot3)) && (is_not_slot_end (next_slot (slot3))); - fx_tree (sc, code, slot_symbol (slot1), - (is_not_slot_end (slot2)) ? slot_symbol (slot2) : NULL, - (is_not_slot_end (slot3)) ? slot_symbol (slot3) : NULL, more_vars); - - outer_e= let_outlet (sc->curlet); - if ((!more_vars) && (is_let (outer_e)) && (!is_funclet (outer_e)) && - (is_not_slot_end (let_slots (outer_e))) && - (slot_symbol (let_slots (outer_e)) != slot_symbol (slot1))) { - slot1= let_slots (outer_e); - slot2= next_slot (slot1); - slot3= (is_not_slot_end (slot2)) ? next_slot (slot2) : NULL; - fx_tree_outer (sc, code, slot_symbol (slot1), - (is_not_slot_end (slot2)) ? slot_symbol (slot2) : NULL, - (is_not_slot_end (slot3)) ? slot_symbol (slot3) : NULL, - (is_not_slot_end (slot3)) && - (is_not_slot_end (next_slot (slot3)))); - } +static s7_pointer fx_c_opaq(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer arg1 = cadr(arg); + set_car(sc->t1_1, fx_call(sc, cdr(arg1))); + return(fn_proc(arg)(sc, with_list_t1(sc, fn_proc(arg1)(sc, sc->t1_1)))); } -static void -fx_curlet_tree_in (s7_scheme* sc, s7_pointer code) { - s7_pointer slot1= let_slots (sc->curlet), slot3= NULL; - s7_pointer slot2= next_slot (slot1); - if (is_not_slot_end (slot2)) slot3= next_slot (slot2); - fx_tree_in (sc, code, slot_symbol (slot1), - (is_not_slot_end (slot2)) ? slot_symbol (slot2) : NULL, - (is_not_slot_end (slot3)) ? slot_symbol (slot3) : NULL, - (is_not_slot_end (slot3)) && - (is_not_slot_end (next_slot (slot3)))); +static s7_pointer fx_c_opaaq(s7_scheme *sc, s7_pointer arg) +{ + const s7_pointer arg1 = cadr(arg); + s7_pointer result; + /* check_stack_size(sc); */ + gc_protect_via_stack(sc, fx_call(sc, cdr(arg1))); + set_car(sc->t2_2, fx_call(sc, cddr(arg1))); + set_car(sc->t2_1, gc_protected1(sc)); + result = fn_proc(arg1)(sc, sc->t2_1); + set_gc_protected2(sc, result); /* might be a big list etc (see s7test.scm fx_c_opaaq test) */ + result = fn_proc(arg)(sc, with_list_t1(sc, result)); + unstack_gc_protect(sc); + return(result); } -typedef bool (*s7_bfunc) (s7_scheme* sc, s7_pointer expr); /* used in eval */ - -static bool -fb_lt_ss (s7_scheme* sc, s7_pointer expr) { - s7_pointer x= lookup (sc, cadr (expr)); - s7_pointer y= lookup (sc, opt1_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_lt_ts (s7_scheme* sc, s7_pointer expr) { - s7_pointer x= t_lookup (sc, cadr (expr), expr); - s7_pointer y= lookup (sc, opt1_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= lookup (sc, cadr (expr)); - s7_pointer y= lookup (sc, opt1_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= 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= 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= t_lookup (sc, cadr (expr), expr), - y= u_lookup (sc, opt1_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= s_lookup (sc, cadr (expr), expr); - s7_pointer y= s_lookup (sc, opt1_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= s_lookup (sc, cadr (expr), expr); - s7_pointer y= s_lookup (sc, opt1_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= s_lookup (sc, cadr (expr), expr); - s7_pointer y= s_lookup (sc, opt1_sym (cdr (expr)), expr); - return (((is_t_integer (x)) && (is_t_integer (y))) - ? (integer (x) <= integer (y)) - : leq_b_7pp (sc, x, y)); -} - -static bool -fb_leq_ti (s7_scheme* sc, s7_pointer expr) { - s7_pointer x= t_lookup (sc, cadr (expr), expr); - if (is_t_integer (x)) return (integer (x) <= integer (opt1_con (cdr (expr)))); - return (g_leq_xi (sc, set_plist_2 (sc, x, opt1_con (cdr (expr))))); -} - -static bool -fb_leq_ui (s7_scheme* sc, s7_pointer expr) { - s7_pointer x= u_lookup (sc, cadr (expr), expr); - if (is_t_integer (x)) return (integer (x) <= integer (opt1_con (cdr (expr)))); - return (g_leq_xi (sc, set_plist_2 (sc, x, opt1_con (cdr (expr))))); -} - -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_lt_ts) return ((s7_pointer) fb_lt_ts); - 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_leq_ti) return ((s7_pointer) fb_leq_ti); - if (fx == fx_leq_ui) return ((s7_pointer) fb_leq_ui); - 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); -} +static s7_pointer fx_c_opsaq(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer arg1 = cadr(arg); + set_car(sc->t2_2, fx_call(sc, cddr(arg1))); + set_car(sc->t2_1, lookup(sc, cadr(arg1))); + return(fn_proc(arg)(sc, with_list_t1(sc, fn_proc(arg1)(sc, sc->t2_1)))); +} -static void -fb_annotate (s7_scheme* sc, s7_pointer form, s7_pointer fx_expr, opcode_t op) { - s7_pointer bfunc; - if ((is_fx_treeable (cdr (form))) && (curlet_has_slots (sc))) - fx_curlet_tree (sc, - cdr (form)); /* and not already treed? just the one expr? */ - bfunc= fx_to_fb (sc, fx_proc (fx_expr)); - if (bfunc) { - set_opt3_any (cdr (form), bfunc); - pair_set_syntax_op (form, op); +static s7_pointer fx_c_opaaaq(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer arg1 = cadr(code); + gc_protect_2_via_stack(sc, fx_call(sc, cdr(arg1)), fx_call(sc, opt3_pair(arg1))); /* cddr(arg) */ + set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg1)))); + set_car(sc->t3_1, gc_protected1(sc)); + set_car(sc->t3_2, gc_protected2(sc)); + { + s7_pointer result = fn_proc(code)(sc, with_list_t1(sc, fn_proc(arg1)(sc, sc->t3_1))); + unstack_gc_protect(sc); + return(result); } -#if 0 - /* fb_annotate additions? [these currently require new "B" ops] */ - else - { - fprintf(stderr, "fx: %s %s\n", ((is_pair(fx_expr)) && (is_pair(car(fx_expr)))) ? op_names[optimize_op(car(fx_expr))] : "", display_truncated(fx_expr)); - if (caar(fx_expr) == sc->num_eq_symbol) abort(); - /* [fx_leq_ti] fx_lt_t0 fx_gt_ti fx_num_eq_u0 */ - } -#endif } -/* when_b cond? do end-test? num_eq_vs|us */ - -/* ---------------------------------------- for-each - * ---------------------------------------- */ -static Inline s7_pointer -inline_make_counter ( - s7_scheme* sc, - s7_pointer iter) /* all calls are hit about the same: lg/sg */ +static s7_pointer fx_c_s_opaaq(s7_scheme *sc, s7_pointer code) { - s7_pointer new_counter; - new_cell (sc, new_counter, T_COUNTER); - counter_set_result (new_counter, sc->nil); - if ((S7_DEBUGGING) && (!is_iterator (iter)) && (!is_pair (iter))) - fprintf (stderr, "%s[%d]: %s?\n", __func__, __LINE__, display (iter)); - counter_set_list ( - new_counter, - iter); /* iterator -- here it's always either an iterator or a pair */ - counter_set_capture (new_counter, 0); /* will be capture_let_counter */ - counter_set_let (new_counter, sc->rootlet); /* will be the saved let */ - counter_set_slots (new_counter, - slot_end); /* local let slots before body is evalled */ - stack_set_has_counters (sc->stack); - return (new_counter); -} - -static s7_pointer -make_iterators (s7_scheme* sc, s7_pointer caller, s7_pointer args) { - s7_pointer p= cdr (args); - sc->temp3 = args; - sc->z= sc->nil; /* don't use sc->args here -- it needs GC protection until we - get the iterators */ - for (s7_int i= 2; is_pair (p); p= cdr (p), i++) { - s7_pointer iter= car (p); - if (!is_mappable (iter)) - wrong_type_error_nr (sc, caller, i, iter, a_sequence_string); - sc->z= (is_iterator (iter)) ? cons (sc, iter, sc->z) - : cons (sc, s7_make_iterator (sc, iter), sc->z); - } - if ((S7_DEBUGGING) && (sc->temp3 != args)) - fprintf (stderr, "%s[%d]: temp3: %s\n", __func__, __LINE__, - display (sc->temp3)); - sc->temp3= sc->unused; + const s7_pointer arg2 = caddr(code); + gc_protect_via_stack(sc, fx_call(sc, cdr(arg2))); + set_car(sc->t2_2, fx_call(sc, cddr(arg2))); + set_car(sc->t2_1, gc_protected1(sc)); + set_car(sc->t2_2, fn_proc(arg2)(sc, sc->t2_1)); + set_car(sc->t2_1, lookup(sc, cadr(code))); { - s7_pointer result= proper_list_reverse_in_place (sc, sc->z); - sc->z = sc->unused; - return (result); + s7_pointer result = fn_proc(code)(sc, sc->t2_1); + unstack_gc_protect(sc); + return(result); } } -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); +static s7_pointer fx_c_4a(s7_scheme *sc, s7_pointer code) +{ + s7_pointer arg = cdr(code), result; + check_stack_size(sc); /* t718 pp cycles #f */ + gc_protect_2_via_stack(sc, fx_call(sc, arg), fx_call(sc, cdr(arg))); + arg = cddr(arg); + set_gc_protected3(sc, fx_call(sc, arg)); + set_car(sc->t3_3, fx_call(sc, cdr(arg))); + set_car(sc->t3_2, gc_protected3(sc)); + set_car(sc->t3_1, gc_protected2(sc)); + set_car(sc->t4_1, gc_protected1(sc)); + result = fn_proc(code)(sc, sc->t4_1); + unstack_gc_protect(sc); + set_car(sc->t4_1, sc->F); + return(result); +} + +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?? */ + const s7_pointer arg = cdr(code); + s7_pointer result; + set_car(sc->t4_1, fx_call(sc, arg)); + set_car(sc->t3_1, fx_call(sc, cdr(arg))); + 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) */ + result = fn_proc(code)(sc, sc->t4_1); + set_car(sc->t4_1, sc->F); + return(result); } -#define MUTLIM \ - 32 /* was 1000, sets when (in vector-length) to start using a mutated real, \ - rather than make_real during the loop through the vector */ - -static s7_pointer -clear_for_each (s7_scheme* sc) { - sc->map_call_ctr--; - unstack_with (sc, OP_MAP_UNWIND); - return (sc->unspecified); +static s7_pointer fx_c_c_opscq(s7_scheme *sc, s7_pointer arg) +{ + const s7_pointer arg2 = caddr(arg); + set_car(sc->t2_1, lookup(sc, cadr(arg2))); + set_car(sc->t2_2, opt1_con(cdr(arg2))); + set_car(sc->t2_2, fn_proc(arg2)(sc, sc->t2_1)); + set_car(sc->t2_1, cadr(arg)); + return(fn_proc(arg)(sc, sc->t2_1)); } -static s7_pointer -g_for_each_closure (s7_scheme* sc, s7_pointer clo, - s7_pointer seq) /* one sequence arg */ +static s7_pointer fx_c_s_opcsq(s7_scheme *sc, s7_pointer arg) { - const s7_pointer body= closure_body (clo); - 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 = NULL; - const s7_pointer old_let= sc->curlet, pars= closure_pars (clo); - const s7_pointer val= seq_init (sc, seq); - s7_pointer slot, result= NULL; - - set_curlet (sc, - inline_make_let_with_slot ( - sc, closure_let (clo), - (is_pair (car (pars))) ? caar (pars) : car (pars), val)); - slot= let_slots (sc->curlet); - - if (sc->map_call_ctr == 0) { - if (is_null (cdr (body))) func= s7_optimize_nv (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 */ - } - } - - if (func) { - push_stack_no_let (sc, OP_MAP_UNWIND, clo, seq); - sc->map_call_ctr++; - if (is_pair (seq)) { - for (s7_pointer vals= seq, slow_vals= vals; is_pair (vals);) { - slot_set_value (slot, car (vals)); - func (sc); - vals= cdr (vals); - if (is_pair (vals)) { - slot_set_value (slot, car (vals)); - func (sc); - vals = cdr (vals); - slow_vals= cdr (slow_vals); - if (vals == slow_vals) break; - } - } - result= sc->unspecified; - } - else if (is_float_vector (seq)) { - const s7_double* vals= float_vector_floats (seq); - const s7_int len = vector_length (seq); - if ((len > MUTLIM) && (!tree_has_setters (sc, body))) { - const s7_pointer sv= - wrap_real (sc, 0.0); /* maybe make_mutable_real(sc, 0.0)? */ - slot_set_value (slot, sv); - if (func == opt_float_any_nv) { - opt_info* o = sc->opts[0]; - s7_double (*fd) (opt_info* o)= q_call (o).fd; - for (s7_int i= 0; i < len; i++) { - set_real (sv, vals[i]); - fd (o); - } - } - else if (func == opt_cell_any_nv) { - opt_info* o = sc->opts[0]; - opt_info* o1 = q_when_body (o, 0).o1; - s7_pointer (*fp) (opt_info* o)= q_call (o).fp; - if (fp == opt_unless_p_1) - for (s7_int i= 0; i < len; i++) { - set_real (sv, vals[i]); - if (!(q_when_test_call (o))) q_call (o1).fp (o1); - } - else - for (s7_int i= 0; i < len; i++) { - set_real (sv, vals[i]); - fp (o); - } - } - else - for (s7_int i= 0; i < len; i++) { - set_real (sv, vals[i]); - func (sc); - } - } - else - for (s7_int i= 0; i < len; i++) { - slot_set_value (slot, make_real (sc, vals[i])); - func (sc); - } - result= sc->unspecified; - } - else if (is_int_vector (seq)) { - const s7_int* vals= int_vector_ints (seq); - const s7_int len = vector_length (seq); - if ((len > MUTLIM) && (!tree_has_setters (sc, body))) { - const s7_pointer sv= wrap_mutable_integer ( - sc, 0); /* make_mutable_integer? -- can we assume c_funcs won't - use wrappers? */ - slot_set_value (slot, sv); - /* since there are no setters, the inner step is also mutable if there - * is one. func=opt_cell_any_nv, q_call(sc->opts[0]).fp(sc->opts[0]) - * fp=opt_do_1 -> mutable version - */ - if (func == opt_int_any_nv) { - opt_info* o = sc->opts[0]; - s7_int (*fi) (opt_info* o)= q_call (o).fi; - for (s7_int i= 0; i < len; i++) { - set_integer (sv, vals[i]); - fi (o); - } - } - else - for (s7_int i= 0; i < len; i++) { - set_integer (sv, vals[i]); - func (sc); - } - } - else - for (s7_int i= 0; i < len; i++) { - slot_set_value (slot, make_integer (sc, vals[i])); - func (sc); - } - result= sc->unspecified; - } - else if (is_t_vector (seq)) { - const s7_pointer* vals= vector_elements (seq); - const s7_int len = vector_length (seq); - if (func == opt_cell_any_nv) { - opt_info* o = sc->opts[0]; - s7_pointer (*fp) (opt_info* o)= q_call (o).fp; - for (s7_int i= 0; i < len; i++) { - slot_set_value (slot, vals[i]); - fp (o); - } - } - else - for (s7_int i= 0; i < len; i++) { - slot_set_value (slot, vals[i]); - func (sc); - } - result= sc->unspecified; - } - else if (is_string (seq)) { - const char* str= string_value (seq); - const s7_int len= string_length (seq); - for (s7_int i= 0; i < len; i++) { - slot_set_value (slot, chars[(uint8_t) (str[i])]); - func (sc); - } - result= sc->unspecified; - } - else if (is_byte_vector (seq)) { - const uint8_t* vals= (const uint8_t*) byte_vector_bytes (seq); - const s7_int len = vector_length (seq); - if (func == opt_int_any_nv) { - opt_info* o = sc->opts[0]; - s7_int (*fi) (opt_info* o)= q_call (o).fi; - for (s7_int i= 0; i < len; i++) { - slot_set_value (slot, small_int (vals[i])); - fi (o); - } - } - else - for (s7_int i= 0; i < len; i++) { - slot_set_value (slot, small_int (vals[i])); - func (sc); - } - result= sc->unspecified; - } - if (result) return (clear_for_each (sc)); - if (!is_mappable (seq)) - wrong_type_error_nr (sc, sc->for_each_symbol, 2, seq, - a_sequence_string); - if (!is_iterator (seq)) { - seq= s7_make_iterator (sc, seq); - set_stack_protected2 (sc, seq, OP_MAP_UNWIND); - } - /* push_stack_no_let(sc, OP_GC_PROTECT, seq, f); */ - if (func == opt_cell_any_nv) { - opt_info* o = sc->opts[0]; - s7_pointer (*fp) (opt_info* o)= q_call (o).fp; - while (true) { - slot_set_value (slot, s7_iterate (sc, seq)); - if (iterator_is_at_end (seq)) return (clear_for_each (sc)); - fp (o); - } - } - if (func == opt_int_any_nv) { - opt_info* o = sc->opts[0]; - s7_int (*fi) (opt_info* o)= q_call (o).fi; - while (true) { - slot_set_value (slot, s7_iterate (sc, seq)); - if (iterator_is_at_end (seq)) return (clear_for_each (sc)); - fi (o); - } - } - while (true) { - slot_set_value (slot, s7_iterate (sc, seq)); - if (iterator_is_at_end (seq)) return (clear_for_each (sc)); - 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_let); - } - } - - /* using op+1 to hop costs more here (and in map) than it saves */ - if ((is_null (cdr (body))) && (is_pair (seq))) { - s7_pointer c= inline_make_counter (sc, seq); - counter_set_result (c, seq); - push_stack (sc, OP_FOR_EACH_2, c, clo); - return (sc->unspecified); - } + const s7_pointer arg2 = caddr(arg); + set_car(sc->t2_2, lookup(sc, caddr(arg2))); + set_car(sc->t2_1, opt1_con(cdr(arg2))); /* cadr(arg2) or cadadr */ + set_car(sc->t2_2, fn_proc(arg2)(sc, sc->t2_1)); + set_car(sc->t2_1, lookup(sc, cadr(arg))); + return(fn_proc(arg)(sc, sc->t2_1)); +} - if (!is_mappable (seq)) - wrong_type_error_nr (sc, sc->for_each_symbol, 2, seq, a_sequence_string); - begin_temp (sc->v, (is_iterator (seq)) ? seq : s7_make_iterator (sc, seq)); - push_stack (sc, OP_FOR_EACH_1, inline_make_counter (sc, sc->v), clo); - end_temp (sc->v); - return (sc->unspecified); -} - -static void -map_or_for_each_closure_pair_2 (s7_scheme* sc, s7_pfunc func, s7_pointer seq1, - s7_pointer seq2, s7_pointer slot1, - s7_pointer slot2, bool for_each_case) { - for (s7_pointer 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)); - if (for_each_case) func (sc); - else { - s7_pointer val= func (sc); - if (val != sc->no_value) - set_map_unwind_list ( - sc, cons (sc, val, - map_unwind_list (sc))); /* see map_closure_2 below -- - gc_protected3 is our temp */ - } - 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)); - if (for_each_case) func (sc); - else { - s7_pointer val= func (sc); - if (val != sc->no_value) - set_map_unwind_list (sc, cons (sc, val, map_unwind_list (sc))); - } - } - } +static s7_pointer fx_c_op_opssqq_s(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer arg = opt1_pair(cdr(code)); + set_car(sc->t2_1, lookup(sc, cadr(arg))); + set_car(sc->t2_2, lookup(sc, opt1_sym(cdr(arg)))); + set_car(sc->t2_1, fn_proc(cadr(code))(sc, with_list_t1(sc, fn_proc(arg)(sc, sc->t2_1)))); + set_car(sc->t2_2, lookup(sc, caddr(code))); + return(fn_proc(code)(sc, sc->t2_1)); } -static void -map_or_for_each_closure_vector_2 (s7_scheme* sc, s7_pfunc func, s7_pointer seq1, - s7_pointer seq2, s7_pointer slot1, - s7_pointer slot2, bool for_each_case) { - s7_int len= vector_length (seq1); - if (len > vector_length (seq2)) len= vector_length (seq2); - for (s7_int 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)); - if (for_each_case) func (sc); - else { - s7_pointer val= func (sc); - if (val != sc->no_value) - set_map_unwind_list (sc, cons (sc, val, map_unwind_list (sc))); - } - } +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 void -map_or_for_each_closure_string_2 (s7_scheme* sc, s7_pfunc func, s7_pointer seq1, - s7_pointer seq2, s7_pointer slot1, - s7_pointer slot2, bool for_each_case) { - s7_int len= string_length (seq1); - const char *s1= string_value (seq1), *s2= string_value (seq2); - if (len > string_length (seq2)) len= string_length (seq2); - for (s7_int i= 0; i < len; i++) { - slot_set_value (slot1, chars[(uint8_t) (s1[i])]); - slot_set_value (slot2, chars[(uint8_t) (s2[i])]); - if (for_each_case) func (sc); - else { - s7_pointer val= func (sc); - if (val != sc->no_value) - set_map_unwind_list (sc, cons (sc, val, map_unwind_list (sc))); - } - } +static s7_pointer fx_c_ns(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer result; + const s7_pointer lst = safe_list_if_possible(sc, opt3_arglen(cdr(arg))); + if (in_heap(lst)) gc_protect_via_stack(sc, lst); + for (s7_pointer args = cdr(arg), p = lst; is_pair(args); args = cdr(args), p = cdr(p)) + set_car(p, lookup(sc, car(args))); + result = fn_proc(arg)(sc, lst); + if (in_heap(lst)) unstack_gc_protect(sc); + else clear_safe_list_in_use(sc, lst); + return(result); } -static s7_pointer -g_for_each_closure_2 (s7_scheme* sc, s7_pointer clo, s7_pointer seq1, - s7_pointer seq2) { - s7_pointer body= closure_body (clo); - if (!no_cell_opt (body)) { - s7_pfunc func= NULL; - const s7_pointer olde= sc->curlet, pars= closure_pars (clo); - s7_pointer slot1, slot2; - const s7_pointer val1= seq_init (sc, seq1); - const s7_pointer val2= seq_init (sc, seq2); - set_curlet (sc, make_let_with_two_slots ( - sc, closure_let (clo), - (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 (sc->map_call_ctr == 0) { - if (is_null (cdr (body))) func= s7_optimize_nv (sc, body); - 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), true); - } - } +static s7_pointer fx_list_ns(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer lst = make_list(sc, opt3_arglen(cdr(arg)), sc->unused); + for (s7_pointer args = cdr(arg), p = lst; is_pair(args); args = cdr(args), p = cdr(p)) + set_car(p, lookup(sc, car(args))); + return(lst); +} - if (func) { - s7_pointer result= NULL; - push_stack_no_let (sc, OP_MAP_UNWIND, clo, seq1); - sc->map_call_ctr++; - if ((is_pair (seq1)) && (is_pair (seq2))) { - map_or_for_each_closure_pair_2 (sc, func, seq1, seq2, slot1, slot2, - true); - result= sc->unspecified; - } - else if ((is_any_vector (seq1)) && (is_any_vector (seq2))) { - map_or_for_each_closure_vector_2 (sc, func, seq1, seq2, slot1, slot2, - true); - result= sc->unspecified; - } - else if ((is_string (seq1)) && (is_string (seq2))) { - map_or_for_each_closure_string_2 (sc, func, seq1, seq2, slot1, slot2, - true); - result= sc->unspecified; - } - sc->map_call_ctr--; - unstack_with (sc, OP_MAP_UNWIND); - set_curlet (sc, olde); - if (result) return (result); - set_no_cell_opt (body); - } - else /* not func */ +static s7_pointer fx_c_all_ca(s7_scheme *sc, s7_pointer code) +{ + s7_pointer result; + const s7_pointer lst = safe_list_if_possible(sc, opt3_arglen(cdr(code))); + if (in_heap(lst)) gc_protect_via_stack(sc, lst); + for (s7_pointer args = cdr(code), p = lst; is_pair(args); args = cdr(args), p = cddr(p)) { - set_no_cell_opt (body); - set_curlet (sc, olde); - } - } - - if (!is_mappable (seq1)) - wrong_type_error_nr ( - sc, sc->for_each_symbol, 2, seq1, - a_sequence_string); /* is_mappable includes is_iterator */ - if (!is_mappable (seq2)) - wrong_type_error_nr (sc, sc->for_each_symbol, 3, seq2, a_sequence_string); - - sc->z= (is_iterator (seq1)) ? seq1 : s7_make_iterator (sc, seq1); - sc->z= (is_iterator (seq2)) ? list_2 (sc, sc->z, seq2) - : list_2 (sc, sc->z, s7_make_iterator (sc, seq2)); - push_stack (sc, OP_FOR_EACH, - cons_unchecked (sc, sc->z, make_list (sc, 2, sc->nil)), clo); - sc->z= sc->unused; - return (sc->unspecified); -} - -static inline bool -for_each_arg_is_null (s7_scheme* sc, s7_pointer args) { - s7_pointer p = args; - bool got_nil= false; - for (s7_int i= 2; is_pair (p); p= cdr (p), i++) { - s7_pointer obj= car (p); - if (!is_mappable (obj)) { - if (is_null (obj)) got_nil= true; - else - wrong_type_error_nr (sc, sc->for_each_symbol, i, obj, - a_sequence_string); + set_car(p, opt2_con(args)); + args = cdr(args); + set_car(cdr(p), fx_call(sc, args)); } - } - return (got_nil); + result = fn_proc(code)(sc, lst); + if (in_heap(lst)) unstack_gc_protect(sc); + else clear_safe_list_in_use(sc, lst); + return(result); } -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) - - const s7_pointer clo = car (args); - const s7_int len = proper_list_length (cdr (args)); - bool arity_ok= false; +static s7_pointer fx_inlet_ca(s7_scheme *sc, s7_pointer code) +{ + s7_pointer new_let, last_slot = NULL; + s7_int id; - /* try the normal case first */ - sc->value= clo; - if (is_closure ( - clo)) /* not lambda* that might get confused about arg names */ - { - if ((len == 1) && (is_pair (closure_pars (clo))) && - (is_null (cdr (closure_pars (clo))))) - arity_ok= true; - } - else if (is_c_object (clo)) /* see note in g_map; s7_is_aritable can clobber - sc->args=plist=args */ - args= copy_proper_list (sc, args); - else if (!is_applicable (clo)) - return (method_or_bust (sc, clo, sc->for_each_symbol, args, - something_applicable_string, 1)); - - if ((!arity_ok) && (!s7_is_aritable (sc, clo, len))) - error_nr ( - sc, sc->wrong_number_of_args_symbol, - set_elist_4 ( - sc, - wrap_string ( - sc, "for-each first argument ~A called with ~D argument~P?", - 53), - clo, wrap_integer (sc, len), wrap_integer (sc, len))); - - if (for_each_arg_is_null (sc, cdr (args))) return (sc->unspecified); + new_cell(sc, new_let, T_LET | T_SAFE_PROCEDURE); + let_set_slots(new_let, slot_end); /* needed by add_slot_unchecked */ + let_set_outlet(new_let, sc->rootlet); + gc_protect_via_stack(sc, new_let); - /* if function is safe c func, do the for-each locally */ - if (is_safe_c_function (clo)) { - const s7_p_p_t fp= - s7_p_p_function (clo); /* s7_b_p_t would work if we could cast it, and - others (return value is discarded) */ - if ((fp) && (len == 1)) { - if (is_pair (cadr (args))) { - for (s7_pointer 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); - } - if (is_any_vector (cadr (args))) { - const s7_pointer vec = cadr (args); - const s7_int vlen= vector_length (vec); - if (is_float_vector (vec)) { - s7_pointer rl= - wrap_real (sc, 0.0); /* maybe make_mutable_real(sc, 0.0) -- not - sure this is safe */ - begin_temp (sc->x, rl); - for (s7_int i= 0; i < vlen; i++) { - set_real (rl, float_vector (vec, i)); - fp (sc, rl); - } - end_temp (sc->x); - } - else if (is_int_vector (vec)) { - s7_pointer iv= - wrap_mutable_integer (sc, 0); /* make_mutable_integer? */ - begin_temp (sc->x, iv); - for (s7_int i= 0; i < vlen; i++) { - set_integer (iv, int_vector (vec, i)); - fp (sc, iv); - } - end_temp (sc->x); - } - else - for (s7_int i= 0; i < vlen; i++) - fp (sc, vector_getter (vec) ( - sc, vec, i)); /* LOOP_4 here gains almost nothing */ - return (sc->unspecified); - } - if (is_string (cadr (args))) { - const s7_pointer str = cadr (args); - const char* s = string_value (str); - const s7_int slen= string_length (str); - for (s7_int i= 0; i < slen; i++) - fp (sc, chars[(uint8_t) (s[i])]); - return (sc->unspecified); - } - } + /* 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, and don't set local_slot until end either because fx_call might refer to same-name symbol in outer let. + * That is, symbol_id=outer_let_id so lookup->local_slot, so we better not set local_slot ahead of time here. + */ + for (s7_pointer lst = cdr(code); is_pair(lst); lst = cddr(lst)) { - s7_function func= c_function_call ( - clo); /* presumably this is either display/write, or method call? */ - s7_pointer iters; - sc->z= make_iterators (sc, sc->for_each_symbol, 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) { - const s7_pointer iter= caar (sc->z), fargs= cdr (sc->z); - sc->z= sc->unused; - while (true) { - set_car (fargs, s7_iterate (sc, iter)); - if (iterator_is_at_end (iter)) { - /* 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_gc_protect (sc); - sc->z= sc->unused; - return (sc->unspecified); - } - func (sc, fargs); - } - } - iters= sc->z; - sc->z= sc->unused; - while (true) { - for (s7_pointer iterp= car (iters), fargs= cdr (iters); is_pair (iterp); - iterp= cdr (iterp), fargs= cdr (fargs)) { - set_car (fargs, s7_iterate (sc, car (iterp))); - if (iterator_is_at_end (car (iterp))) { - unstack_gc_protect (sc); - return (sc->unspecified); - } - } - func (sc, cdr (iters)); - } - } - } + s7_pointer symbol = car(lst), value; + symbol = (is_symbol_and_keyword(symbol)) ? keyword_symbol(symbol) : cadr(symbol); /* (inlet ':allow-other-keys 3) */ + if (is_constant_symbol(sc, symbol)) /* (inlet 'pi 1) */ + { + unstack_gc_protect(sc); + wrong_type_error_nr(sc, sc->inlet_symbol, 1, symbol, a_non_constant_symbol_string); + } + value = fx_call(sc, cdr(lst)); /* it's necessary to do this first, before add_slot_unchecked */ + if (!last_slot) + last_slot = add_slot_unchecked_no_local_slot(sc, new_let, symbol, value); + else last_slot = add_slot_at_end_no_local(sc, last_slot, symbol, value); + } + id = ++sc->let_number; + let_set_id(new_let, id); + for (s7_pointer slot = let_slots(new_let); is_not_slot_end(slot); slot = next_slot(slot)) + symbol_set_local_slot_unincremented(slot_symbol(slot), id, slot); /* was symbol_set_id(slot_symbol(slot), id) */ + unstack_gc_protect(sc); + return(new_let); +} + +static s7_pointer fx_c_na(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer args, p; + const s7_pointer val = safe_list_if_possible(sc, 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_gc_protect(sc); + else clear_safe_list_in_use(sc, val); + return(p); +} + +static s7_pointer fx_vector_ns(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer args = cdr(arg); + const s7_pointer vec = make_simple_vector(sc, opt3_arglen(cdr(arg))); + s7_pointer *els = (s7_pointer *)vector_elements(vec); + for (s7_int i = 0; is_pair(args); args = cdr(args), i++) + els[i] = lookup(sc, car(args)); + return(vec); +} - /* if closure call is straightforward, use OP_FOR_EACH_1 */ - if ((len == 1) && - (((is_closure (clo)) && (closure_arity_to_int (sc, clo) == 1) && - (!is_constant_symbol (sc, car (closure_pars (clo))))) || - ((is_closure_star (clo)) && (closure_star_arity_to_int (sc, clo) == 1) && - (!is_constant_symbol (sc, (is_pair (car (closure_pars (clo)))) - ? caar (closure_pars (clo)) - : car (closure_pars (clo))))))) - return (g_for_each_closure (sc, clo, cadr (args))); - - push_stack (sc, OP_FOR_EACH, - cons_unchecked (sc, - make_iterators (sc, sc->for_each_symbol, args), - make_list (sc, len, sc->nil)), - clo); - sc->z= sc->unused; - return (sc->unspecified); -} - -static bool -op_for_each (s7_scheme* sc) { - const s7_pointer iterators = car (sc->args); - const s7_pointer saved_args= cdr (sc->args); - sc->temp9 = saved_args; - for (s7_pointer args= saved_args, iters= iterators; is_pair (args); - args= cdr (args), iters= cdr (iters)) { - set_car (args, s7_iterate (sc, car (iters))); - if (iterator_is_at_end (car (iters))) { - sc->value= sc->unspecified; - sc->temp9= sc->unused; - return (true); - } - } - push_stack_direct (sc, OP_FOR_EACH); - sc->args = (needs_copied_args (sc->code)) ? copy_proper_list (sc, saved_args) - : saved_args; - sc->temp9= sc->unused; - 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 a let 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 s7_pointer fx_vector_na(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer args = cdr(arg); + const s7_pointer vec = make_simple_vector(sc, opt3_arglen(cdr(arg))); /* was s7_make_vector */ + s7_pointer *els = vector_elements(vec); + gc_protect_via_stack(sc, vec); + t_vector_fill(vec, sc->nil); /* fx_calls below can trigger GC, so all elements of v must be legit */ + for (s7_int i = 0; is_pair(args); args = cdr(args), i++) + els[i] = fx_call(sc, args); + sc->value = vec; /* full-s7test 12262 list_p_p case */ + unstack_gc_protect(sc); + return(vec); +} + +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 Inline bool -inline_op_for_each_1 (s7_scheme* sc) /* called once in eval, case fb gc iter */ +static s7_pointer fx_if_not_a_a(s7_scheme *sc, s7_pointer arg) { - const s7_pointer counter= sc->args; - s7_pointer code; - const s7_pointer p = counter_list (counter); - const s7_pointer arg= s7_iterate (sc, p); - if (iterator_is_at_end (p)) { - sc->value= sc->unspecified; - return (true); - } - code= T_Clo (sc->code); - if (counter_capture (counter) != sc->capture_let_counter) { - const s7_pointer sym= car (closure_pars (code)); - set_curlet (sc, inline_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) */ - set_curlet (sc, 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); + return((is_false(sc, fx_call(sc, opt1_pair(arg)))) ? fx_call(sc, opt2_pair(arg)) : sc->unspecified); } -static Inline bool -inline_op_for_each_2 (s7_scheme* sc) /* called once in eval, lg set */ +static s7_pointer fx_if_a_a_a(s7_scheme *sc, s7_pointer arg) { - const s7_pointer counter= sc->args; - const s7_pointer lst = counter_list (counter); - if (!is_pair ( - lst)) /* '(1 2 . 3) as arg? -- counter_list can be anything here */ - { - sc->value= sc->unspecified; - return (true); - } - counter_set_list (counter, cdr (lst)); - if (sc->cur_op == OP_FOR_EACH_3) { - counter_set_result (counter, cdr (counter_result (counter))); - if (counter_result (counter) == counter_list (counter)) { - sc->value= sc->unspecified; - return (true); - } - push_stack_direct (sc, OP_FOR_EACH_2); - } - else push_stack_direct (sc, OP_FOR_EACH_3); - if (counter_capture (counter) != sc->capture_let_counter) { - const s7_pointer pars= closure_pars (sc->code); - set_curlet (sc, inline_make_let_with_slot ( - sc, closure_let (sc->code), - (is_pair (car (pars))) ? caar (pars) : car (pars), - car (lst))); - 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)); - set_curlet (sc, - update_let_with_slot (sc, counter_let (counter), car (lst))); - } - sc->code= car (closure_body (sc->code)); - return (false); -} - -/* ---------------------------------------- map - * ---------------------------------------- */ - -static s7_pointer -g_map_closure (s7_scheme* sc, s7_pointer clo, - s7_pointer seq) /* one sequence argument */ -{ - const s7_pointer body= closure_body (clo); - sc->value = clo; - - if (!no_cell_opt (body)) { - s7_pfunc func = NULL; - const s7_pointer old_let= sc->curlet, pars= closure_pars (clo); - s7_pointer slot; - set_curlet (sc, inline_make_let_with_slot ( - sc, closure_let (clo), - (is_pair (car (pars))) ? caar (pars) : car (pars), - seq_init (sc, seq))); - slot= let_slots (sc->curlet); - - if (sc->map_call_ctr == 0) { - 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 */ - } - } - if (func) { - s7_pointer val, result= NULL; /* val could be localized */ - push_stack_no_let (sc, OP_MAP_UNWIND, clo, seq); - sc->map_call_ctr++; - if (is_pair (seq)) { - set_map_unwind_list (sc, sc->nil); - for (s7_pointer fast= seq, slow= seq; is_pair (fast); - fast= cdr (fast), slow= cdr (slow)) { - slot_set_value (slot, car (fast)); - val= func (sc); - if (val != sc->no_value) - set_map_unwind_list (sc, cons (sc, val, map_unwind_list (sc))); - if (is_pair (cdr (fast))) { - fast= cdr (fast); - if (fast == slow) break; - slot_set_value (slot, car (fast)); - val= func (sc); - if (val != sc->no_value) - set_map_unwind_list (sc, cons (sc, val, map_unwind_list (sc))); - } - } - result= proper_list_reverse_in_place (sc, map_unwind_list (sc)); - } - else if (is_float_vector (seq)) { - const s7_double* vals= float_vector_floats (seq); - const s7_int len = vector_length (seq); - set_map_unwind_list (sc, sc->nil); - for (s7_int i= 0; i < len; i++) { - slot_set_value (slot, make_real (sc, vals[i])); - val= func (sc); - if (val != sc->no_value) - set_map_unwind_list (sc, cons (sc, val, map_unwind_list (sc))); - } - result= proper_list_reverse_in_place (sc, map_unwind_list (sc)); - } - else if (is_int_vector (seq)) { - const s7_int* vals= int_vector_ints (seq); - const s7_int len = vector_length (seq); - set_map_unwind_list (sc, sc->nil); - for (s7_int i= 0; i < len; i++) { - slot_set_value (slot, make_integer (sc, vals[i])); - val= func (sc); - if (val != sc->no_value) - set_map_unwind_list (sc, cons (sc, val, map_unwind_list (sc))); - } - result= proper_list_reverse_in_place (sc, map_unwind_list (sc)); - } - else if (is_complex_vector (seq)) { - const s7_complex* vals= complex_vector_complexes (seq); - const s7_int len = vector_length (seq); - set_map_unwind_list (sc, sc->nil); - for (s7_int i= 0; i < len; i++) { - slot_set_value (slot, c_complex_to_s7 (sc, vals[i])); - val= func (sc); - if (val != sc->no_value) - set_map_unwind_list (sc, cons (sc, val, map_unwind_list (sc))); - } - result= proper_list_reverse_in_place (sc, map_unwind_list (sc)); - } - else if (is_t_vector (seq)) { - const s7_pointer* vals= vector_elements (seq); - const s7_int len = vector_length (seq); - set_map_unwind_list (sc, sc->nil); - for (s7_int i= 0; i < len; i++) { - slot_set_value (slot, vals[i]); - val= func (sc); - if (val != sc->no_value) - set_map_unwind_list (sc, cons (sc, val, map_unwind_list (sc))); - } - result= proper_list_reverse_in_place (sc, map_unwind_list (sc)); - } - else if (is_string (seq)) { - const s7_int len= string_length (seq); - const char* str= string_value (seq); - set_map_unwind_list (sc, sc->nil); - for (s7_int i= 0; i < len; i++) { - slot_set_value (slot, chars[(uint8_t) (str[i])]); - val= func (sc); - if (val != sc->no_value) - set_map_unwind_list (sc, cons (sc, val, map_unwind_list (sc))); - } - result= proper_list_reverse_in_place (sc, map_unwind_list (sc)); - } - sc->map_call_ctr--; - unstack_with (sc, OP_MAP_UNWIND); - if ((S7_DEBUGGING) && (sc->map_call_ctr < 0)) { - fprintf (stderr, "%s[%d]: map ctr: %" ld64 "\n", __func__, __LINE__, - sc->map_call_ctr); - sc->map_call_ctr= 0; - } - if (result) return (result); - } - set_no_cell_opt (body); - set_curlet (sc, old_let); - } - if ((is_null (cdr (body))) && (is_pair (seq))) { - /* here we need to check for a setter, and if any, push with dynamic-unwind, - * then restore later. (let ((hk (make-hook 'x))) (define (func) (map hk - * (list 0 6))) (set! (setter hk) (lambda (y) y)) (func)) - */ - if (is_any_procedure ( - closure_setter_or_map_list (clo))) /* should we restore #f? */ - push_stack (sc, OP_DYNAMIC_UNWIND, - list_3 (sc, clo, closure_setter (clo), sc->T), - sc->restore_setter); - /* the passed list will be car(args) when dynamic_unwind calls (f . args) */ - /* all this complexity because there is no place to store the "slow" version - * of seq for circular list checks */ - closure_set_map_list (clo, seq); - push_stack (sc, OP_MAP_2, inline_make_counter (sc, seq), clo); - return (sc->unspecified); - } - if (!is_mappable (seq)) - wrong_type_error_nr (sc, sc->map_symbol, 2, seq, a_sequence_string); - begin_temp (sc->v, (is_iterator (seq)) ? seq : s7_make_iterator (sc, seq)); - push_stack (sc, OP_MAP_1, inline_make_counter (sc, sc->v), clo); - end_temp (sc->v); - return (sc->nil); -} - -static s7_pointer -g_map_closure_2 (s7_scheme* sc, s7_pointer clo, s7_pointer seq1, - s7_pointer seq2) /* two sequences */ -{ - const s7_pointer body= closure_body (clo); - if (!no_cell_opt (body)) { - s7_pfunc func = NULL; - const s7_pointer old_let= sc->curlet, pars= closure_pars (clo); - s7_pointer slot1, slot2; - const s7_pointer val1= seq_init (sc, seq1); - const s7_pointer val2= seq_init (sc, seq2); - set_curlet (sc, make_let_with_two_slots ( - sc, closure_let (clo), - (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 (sc->map_call_ctr == 0) { - 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); - } - } - if (func) { - s7_pointer result= NULL; - push_stack_no_let (sc, OP_MAP_UNWIND, clo, seq1); - sc->map_call_ctr++; - if ((is_pair (seq1)) && (is_pair (seq2))) { - set_map_unwind_list (sc, sc->nil); - map_or_for_each_closure_pair_2 ( - sc, func, seq1, seq2, slot1, slot2, - false); /* builds result on gc_protected3 */ - result= proper_list_reverse_in_place (sc, map_unwind_list (sc)); - } - else if ((is_any_vector (seq1)) && (is_any_vector (seq2))) { - set_map_unwind_list (sc, sc->nil); - map_or_for_each_closure_vector_2 (sc, func, seq1, seq2, slot1, slot2, - false); - result= proper_list_reverse_in_place (sc, map_unwind_list (sc)); - } - else if ((is_string (seq1)) && (is_string (seq2))) { - set_map_unwind_list (sc, sc->nil); - map_or_for_each_closure_string_2 (sc, func, seq1, seq2, slot1, slot2, - false); - result= proper_list_reverse_in_place (sc, map_unwind_list (sc)); - } - sc->map_call_ctr--; - unstack_with (sc, OP_MAP_UNWIND); - set_curlet (sc, old_let); - if (result) return (result); - set_no_cell_opt (body); - } - else /* not func */ - { - set_no_cell_opt (body); - set_curlet (sc, old_let); - } + 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))); \ } - if (!is_mappable (seq1)) - wrong_type_error_nr (sc, sc->for_each_symbol, 2, seq1, a_sequence_string); - if (!is_mappable (seq2)) - wrong_type_error_nr (sc, sc->for_each_symbol, 3, seq2, a_sequence_string); +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 */ - sc->z= (is_iterator (seq1)) ? seq1 : s7_make_iterator (sc, seq1); - sc->z= (is_iterator (seq2)) ? list_2 (sc, sc->z, seq2) - : list_2 (sc, sc->z, s7_make_iterator (sc, seq2)); - push_stack (sc, OP_MAP, inline_make_counter (sc, sc->z), clo); - sc->z= sc->unused; - return (sc->unspecified); +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 -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) - - /* (apply f (map ...)) e.g. f=append -> use safe_list for map output - * list here? also for ( (map...)) but less savings if mapped func - * would have used the same safe_list? - */ - const s7_pointer clo = car (args); - s7_int len = 0; - bool got_nil= false; - - for (s7_pointer p= cdr (args); is_pair (p); p= cdr (p), len++) - if (!is_mappable (car (p))) { - if (is_null (car (p))) got_nil= true; - else - wrong_type_error_nr (sc, sc->map_symbol, len + 2, car (p), - a_sequence_string); - } - - switch (type (clo)) { - case T_C_FUNCTION: - if (!c_function_is_aritable (clo, len)) - error_nr (sc, sc->wrong_number_of_args_symbol, - set_elist_4 (sc, wrap_string (sc, "map ~A: ~D argument~P?", 22), - clo, wrap_integer (sc, len), - wrap_integer (sc, len))); - case T_C_RST_NO_REQ_FUNCTION: - /* if function is safe c func, do the map locally */ - if (got_nil) return (sc->nil); - if (is_safe_procedure (clo)) { - s7_pointer val; - const s7_function func= c_function_call (clo); - if (is_pair (cadr (args))) { - if (len == 1) { - const s7_p_p_t fp= s7_p_p_function (clo); - if (fp) { - val= list_1_unchecked (sc, sc->nil); - gc_protect_via_stack (sc, val); - for (s7_pointer fast= cadr (args), slow= cadr (args); - is_pair (fast); fast= cdr (fast), slow= cdr (slow)) { - s7_pointer fval= fp (sc, car (fast)); - if (fval != sc->no_value) - set_car (val, cons (sc, fval, car (val))); - if (is_pair (cdr (fast))) { - fast= cdr (fast); - if (fast == slow) break; - fval= fp (sc, car (fast)); - if (fval != sc->no_value) - set_car (val, cons (sc, fval, car (val))); - } - } - unstack_gc_protect (sc); - return (proper_list_reverse_in_place (sc, car (val))); - } - } - if ((len == 2) && (is_pair (caddr (args)))) { - const s7_p_pp_t fp= s7_p_pp_function (clo); - if (fp) { - val= list_1_unchecked (sc, sc->nil); - gc_protect_via_stack (sc, val); - for (s7_pointer 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 fval= fp (sc, car (fast1), car (fast2)); - if (fval != sc->no_value) - set_car (val, cons (sc, fval, 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; - fval= fp (sc, car (fast1), car (fast2)); - if (fval != sc->no_value) - set_car (val, cons (sc, fval, car (val))); - } - } - unstack_gc_protect (sc); - return (proper_list_reverse_in_place (sc, car (val))); - } - } - } - if ((is_string (cadr (args))) && (len == 1)) { - const s7_p_p_t fp= s7_p_p_function (clo); - if (fp) { - s7_pointer str= cadr (args); - const char* s = string_value (str); - val = list_1_unchecked (sc, sc->nil); - gc_protect_via_stack (sc, val); - len= string_length (str); - for (s7_int i= 0; i < len; i++) { - s7_pointer fval= fp (sc, chars[(uint8_t) (s[i])]); - if (fval != sc->no_value) set_car (val, cons (sc, fval, car (val))); - } - unstack_gc_protect (sc); - return (proper_list_reverse_in_place (sc, car (val))); - } - } - if ((is_any_vector (cadr (args))) && (len == 1)) { - const s7_p_p_t fp= s7_p_p_function (clo); - if (fp) { - const s7_pointer vec= cadr (args); - val = list_1_unchecked (sc, sc->nil); - gc_protect_via_stack (sc, val); - len= vector_length (vec); - for (s7_int i= 0; i < len; i++) { - s7_pointer fval= fp (sc, vector_getter (vec) (sc, vec, i)); - if (fval != sc->no_value) set_car (val, cons (sc, fval, car (val))); - } - unstack_gc_protect (sc); - return (proper_list_reverse_in_place (sc, car (val))); - } - } +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))); +} - { - s7_pointer val1, old_args, iter_list; - sc->z = make_iterators (sc, sc->map_symbol, args); - val1 = cons_unchecked (sc, sc->z, make_list (sc, len, sc->nil)); - iter_list= sc->z; - old_args = sc->args; - 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->unused; - while (true) { - s7_pointer fval; - for (s7_pointer iters= iter_list, vals= cdr (val1); is_pair (iters); - iters= cdr (iters), vals= cdr (vals)) { - set_car (vals, s7_iterate (sc, car (iters))); - if (iterator_is_at_end (car (iters))) { - unstack_gc_protect (sc); - sc->args= T_Pos (old_args); /* can be # or # */ - return (proper_list_reverse_in_place (sc, car (val))); - } - } - fval = func(sc, cdr(val1)); /* multiple-values? values is unsafe, but s7_values used externally and claims to be safe? */ /* func = c_function_call(f) */ - if (fval != sc->no_value) set_car (val, cons (sc, fval, car (val))); - } - } - } +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));} - else /* not safe procedure */ - if ((clo == global_value (sc->values_symbol)) && (len == 1) && - (!has_methods (cadr (args)))) /* iterator should be ok here -- - object_to_list can handle it */ - { - s7_pointer p= object_to_list (sc, cadr (args)); - if (p != cadr (args)) return (p); - } - break; - - case T_CLOSURE: - case T_CLOSURE_STAR: { - const int32_t fargs= (is_closure (clo)) - ? closure_arity_to_int (sc, clo) - : closure_star_arity_to_int (sc, clo); - if ((len == 1) && (fargs == 1) && - (!is_constant_symbol (sc, (is_pair (car (closure_pars (clo)))) - ? caar (closure_pars (clo)) - : car (closure_pars (clo))))) { - if (got_nil) return (sc->nil); - if (is_closure_star (clo)) return (g_map_closure (sc, clo, cadr (args))); - - begin_temp (sc->v, (!is_iterator (cadr (args))) - ? s7_make_iterator (sc, cadr (args)) - : cadr (args)); - push_stack (sc, OP_MAP_1, inline_make_counter (sc, sc->v), clo); - end_temp (sc->v); - symbol_increment_ctr (car (closure_pars (clo))); - return (sc->nil); - } - if (((fargs >= 0) && (fargs < len)) || - ((is_closure (clo)) && (abs (fargs) > len))) - error_nr (sc, sc->wrong_number_of_args_symbol, - set_elist_4 (sc, wrap_string (sc, "map ~A: ~D argument~P?", 22), - clo, wrap_integer (sc, len), - wrap_integer (sc, len))); - if (got_nil) return (sc->nil); - } break; - - case T_C_OBJECT: - /* args if sc->args (plist + c_object) can be clobbered here by - * s7_is_aritable, so we need to protect it */ - args = copy_proper_list (sc, args); - sc->temp9= args; - - default: - if (!is_applicable (clo)) - return (method_or_bust (sc, clo, sc->map_symbol, args, - something_applicable_string, 1)); - if ((!is_pair (clo)) && (!s7_is_aritable (sc, clo, len))) - error_nr ( - sc, sc->wrong_number_of_args_symbol, - set_elist_4 (sc, wrap_string (sc, "map: ~D argument~P for ~A?", 26), - wrap_integer (sc, len), wrap_integer (sc, len), clo)); - if (got_nil) return (sc->nil); - break; - } - sc->z= make_iterators (sc, sc->map_symbol, args); - push_stack (sc, OP_MAP, inline_make_counter (sc, sc->z), clo); - sc->z= sc->unused; - return (sc->nil); -} - -static bool -op_map (s7_scheme* sc) { - const s7_pointer counter= sc->args; - sc->z= sc->nil; /* can't use preset args list here (as in for-each): (map list - '(a b c)) */ - for (s7_pointer iters= counter_list (counter); is_pair (iters); - iters = cdr (iters)) { - const s7_pointer val= s7_iterate (sc, car (iters)); - if (iterator_is_at_end (car (iters))) { - sc->value= proper_list_reverse_in_place (sc, counter_result (counter)); - sc->z = sc->unused; - return (true); - } - sc->z= cons (sc, val, sc->z); - } - push_stack_direct (sc, OP_MAP_GATHER); - sc->args= proper_list_reverse_in_place (sc, sc->z); - sc->z = sc->unused; - if (needs_copied_args (sc->code)) sc->args= copy_proper_list (sc, sc->args); - return (false); -} - -static bool -op_map_1 (s7_scheme* sc) { - const s7_pointer args= sc->args, code= sc->code; - const s7_pointer p = counter_list (args); - const s7_pointer val= s7_iterate (sc, p); - if (iterator_is_at_end (p)) { - sc->value= proper_list_reverse_in_place (sc, counter_result (args)); - return (true); - } - push_stack_direct (sc, OP_MAP_GATHER_1); - if (counter_capture (args) != sc->capture_let_counter) { - const s7_pointer pars= closure_pars (code); - set_curlet (sc, - inline_make_let_with_slot ( - sc, closure_let (code), - (is_pair (car (pars))) ? caar (pars) : car (pars), val)); - 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)); - set_curlet (sc, update_let_with_slot (sc, counter_let (args), val)); - } - sc->code= T_Pair (closure_body (code)); - return (false); +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 bool -op_map_2 (s7_scheme* sc) /* possibly inline lg */ +static inline s7_pointer fx_and_2a(s7_scheme *sc, s7_pointer arg) /* arg is the full expr: (and ...) */ { - s7_pointer cur_args; - const s7_pointer counter= sc->args, code= sc->code; - { - const s7_pointer p= counter_list (counter); - if (!is_pair (p)) { - sc->value= proper_list_reverse_in_place (sc, counter_result (counter)); - return (true); - } - cur_args= car (p); - counter_set_list (counter, 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 (counter)) { - sc->value= proper_list_reverse_in_place (sc, counter_result (counter)); - return (true); - } - push_stack_direct (sc, OP_MAP_GATHER_2); - } - else push_stack_direct (sc, OP_MAP_GATHER_3); - - if (counter_capture (counter) != sc->capture_let_counter) { - s7_pointer pars= closure_pars (code); - set_curlet (sc, inline_make_let_with_slot ( - sc, closure_let (code), - (is_pair (car (pars))) ? caar (pars) : car (pars), - cur_args)); - 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)); /* needed -- see comment under for-each above */ - set_curlet (sc, update_let_with_slot (sc, counter_let (counter), cur_args)); - } - sc->code= car (closure_body (code)); - return (false); + return((fx_call(sc, cdr(arg)) == sc->F) ? sc->F : fx_call(sc, cddr(arg))); } -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; - if (is_not_null (a)) { - a= copy_proper_list (sc, a); - do { - s7_pointer q= cdr (a); - set_cdr (a, p); - p= a; - a= q; - } while (is_pair (a)); - } - return (p); +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 Inline void -inline_op_map_gather (s7_scheme* sc) /* called thrice in eval, cb lg map */ +static s7_pointer fx_len2_t(s7_scheme *sc, s7_pointer arg) { - 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 if ((is_mutable (sc->value)) && (is_t_integer (sc->value))) - counter_set_result (sc->args, - cons (sc, make_integer (sc, integer (sc->value)), - counter_result (sc->args))); - else - counter_set_result (sc->args, - cons (sc, sc->value, counter_result (sc->args))); - } + s7_pointer 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))))); } -/* -------------------------------- multiple-values - * -------------------------------- */ - -#define stack_top4_op(Sc) \ - ((opcode_t) T_Op (Sc->stack_end[-5])) /* top4 == top - 4 */ -#define stack_top4_args(Sc) (Sc->stack_end[-6]) -/* #define stack_top4_let(Sc) (Sc->stack_end[-7]) */ -/* #define stack_top4_code(Sc) (Sc->stack_end[-8]) */ - -static void apply_c_rst_no_req_function (s7_scheme* sc); +static s7_pointer fx_len3_t(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer 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 Inline s7_pointer -apply_mv (s7_scheme* sc, bool use_safe) { - sc->code= c_function_base (opt1_cfunc (sc->code)); - if (type (sc->code) == T_C_FUNCTION) - sc->value= apply_c_function_unopt (sc, sc->code, sc->args); - else apply_c_rst_no_req_function (sc); - if (use_safe) clear_safe_list_in_use (sc, sc->args); - return (sc->value); +static s7_pointer fx_and_3a(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer p = cdr(arg); + if (fx_call(sc, p) == sc->F) return(sc->F); + p = cdr(p); + return((fx_call(sc, p) == sc->F) ? sc->F : fx_call(sc, cdr(p))); } -static Inline s7_pointer -apply_mv_no_safe_list (s7_scheme* sc) { - sc->code= c_function_base (opt1_cfunc (sc->code)); - if (type (sc->code) == T_C_FUNCTION) - sc->value= apply_c_function_unopt (sc, sc->code, sc->args); - else apply_c_rst_no_req_function (sc); - return (sc->value); +static s7_pointer fx_and_n(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer val = sc->T; + for (s7_pointer p = cdr(arg); (is_pair(p)) && (val != sc->F); p = cdr(p)) /* in lg, 5/6 args appears to predominate */ + val = fx_call(sc, p); + return(val); } -static s7_pointer -op_safe_c_p_mv (s7_scheme* sc, s7_pointer args) { - s7_pointer p; - bool use_safe= false; - sc->value = args; - pop_stack_no_op (sc); - p= cddr (sc->value); - if (is_null (p)) - sc->args= set_plist_2 (sc, car (sc->value), cadr (sc->value)); - else if (is_null (cdr (p))) - sc->args= set_plist_3 (sc, car (sc->value), cadr (sc->value), car (p)); - else { - s7_pointer lst; - const s7_int len= proper_list_length (p) + 2; - sc->args = safe_list_if_possible (sc, len); - use_safe = (!in_heap (sc->args)); - lst = sc->args; - for (s7_pointer p1= sc->value; is_pair (p1); p1= cdr (p1), lst= cdr (lst)) - set_car (lst, car (p1)); - } - return (apply_mv (sc, use_safe)); +static s7_pointer fx_or_2a(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer p = cdr(arg); + s7_pointer val = fx_call(sc, p); + return((val != sc->F) ? val : fx_call(sc, cdr(p))); } -static s7_pointer -op_safe_c_pc_mv (s7_scheme* sc, s7_pointer args) { - /* sc->value = mv vals from e.g. safe_c_pc_1 below, fn_proc = splice_in_values - * via values chooser synonym sc->values_uncopied */ - /* sc->args is the trailing constant arg (the "c" in "pc") */ - s7_pointer p; - bool use_safe= false; - sc->value = args; - pop_stack_no_op (sc); - p= cddr (sc->value); - if (is_null (p)) - sc->args= set_plist_3 (sc, car (sc->value), cadr (sc->value), sc->args); - else if (is_null (cdr (p))) - sc->args= - set_plist_4 (sc, car (sc->value), cadr (sc->value), car (p), sc->args); - else /* sc->args = pair_append(sc, sc->value, list_1(sc, sc->args)); */ /* not - plist! - sc->value - is - not - reusable - */ - { - s7_pointer lst; - const s7_pointer val= sc->args; - const s7_int len= proper_list_length (p); - sc->args = safe_list_if_possible (sc, len + 3); - use_safe = (!in_heap (sc->args)); - lst = sc->args; - for (s7_pointer p1= sc->value; is_pair (p1); p1= cdr (p1), lst= cdr (lst)) - set_car (lst, car (p1)); - set_car (lst, val); - } - return (apply_mv (sc, use_safe)); +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 val = fn_proc(cadr(arg))(sc, with_list_t1(sc, lookup(sc, opt3_sym(cdr(arg))))); /* cadadr(arg) */ + return((val != sc->F) ? val : fn_proc(caddr(arg))(sc, sc->t1_1)); } -static s7_pointer -op_safe_c_ps_mv ( - s7_scheme* sc, - s7_pointer args) /* (define (hi a) (+ (values 1 2) a)) from safe_c_ps_1 */ +static s7_pointer fx_or_s_type_2(s7_scheme *sc, s7_pointer arg) { - /* old form: sc->args = pair_append(sc, sc->value, list_1(sc, lookup(sc, - * caddr(sc->code)))); */ /* don't assume sc->value can be used as sc->args here! */ - s7_pointer p, val; - bool use_safe= false; - sc->value = args; - pop_stack_no_op (sc); - p = cddr (sc->value); - val= lookup (sc, caddr (sc->code)); - if (is_null (p)) - sc->args= set_plist_3 (sc, car (sc->value), cadr (sc->value), val); - else if (is_null (cdr (p))) - sc->args= set_plist_4 (sc, car (sc->value), cadr (sc->value), car (p), val); - else /* sc->args = pair_append(sc, sc->value, list_1(sc, val)); */ - { - s7_pointer lst; - const s7_int len= proper_list_length (p); - sc->args = safe_list_if_possible ( - sc, len + 3); /* sc->args is not clobbered by fx_call (below) */ - use_safe= (!in_heap (sc->args)); - lst = sc->args; - for (s7_pointer p1= sc->value; is_pair (p1); p1= cdr (p1), lst= cdr (lst)) - set_car (lst, car (p1)); - set_car (lst, val); - } - return (apply_mv (sc, use_safe)); + int32_t val = type(lookup(sc, opt3_sym(cdr(arg)))); /* cadadr(arg)) */ + return(make_boolean(sc, (val == opt3_int(arg)) || (val == opt2_int(cdr(arg))))); } -static s7_pointer -op_safe_c_pa_mv ( - s7_scheme* sc, - s7_pointer args) { /* (let () (define (func) (do ((x 0.0 (+ x 0.1)) (i 0 (+ - i 1))) ((>= x 0.1) (#_with-baffle (inlet (values 1 2) - (symbol? x)))))) (func)) */ - s7_pointer p; - bool use_safe= false; - sc->value = args; - pop_stack_no_op (sc); - p= cddr (sc->value); - if (is_null (p)) { - s7_pointer val1= car (sc->value), val2= cadr (sc->value); - s7_pointer val3= - fx_call (sc, cddr (sc->code)); /* is plist_3 ever clobbered by fx_call? - plist_1|2 are set */ - sc->args= set_plist_3 (sc, val1, val2, val3); - } - else if (is_null (cdr (p))) { - s7_pointer val1= car (sc->value), val2= cadr (sc->value), val3= car (p); - s7_pointer val4= fx_call (sc, cddr (sc->code)); - sc->args = set_plist_4 (sc, val1, val2, val3, val4); - } - else { - s7_pointer lst; - const s7_int len= proper_list_length (p); - sc->args = safe_list_if_possible ( - sc, len + 3); /* sc->args is not clobbered by fx_call (below) */ - use_safe= (!in_heap (sc->args)); - lst = sc->args; - for (s7_pointer p1= sc->value; is_pair (p1); p1= cdr (p1), lst= cdr (lst)) - set_car (lst, car (p1)); - set_car (lst, fx_call (sc, cddr (sc->code))); - } - return (apply_mv (sc, use_safe)); +static s7_pointer fx_not_symbol_or_keyword(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer val = lookup(sc, opt3_sym(arg)); + return(make_boolean(sc, (!is_symbol(val)) || (is_keyword(val)))); } -static s7_pointer -op_safe_c_sp_mv ( - s7_scheme* sc, - s7_pointer args) { /* (let () (define (ho a) (+ a 2)) (define (hi) (+ (ho 1) - (values 3 4))) (hi)) safe_add_sp_1 */ - s7_pointer p; - sc->value= args; - clear_multiple_value (args); /* see op_safe_c_sp_mv in s7test */ - pop_stack_no_op (sc); - p= cddr (sc->value); - if (is_null (p)) - sc->args= set_plist_3 (sc, sc->args, car (sc->value), cadr (sc->value)); - else if (is_null (cdr (p))) - sc->args= - set_plist_4 (sc, sc->args, car (sc->value), cadr (sc->value), car (p)); - else sc->args= cons (sc, sc->args, sc->value); /* not ulist */ - return (apply_mv_no_safe_list (sc)); -} - -static s7_pointer -op_safe_c_ssp_mv ( - s7_scheme* sc, - s7_pointer args) /*sc->code: (+ pi pi (values 1 2)) sc->value: '(1 2) */ -{ - sc->value= args; - pop_stack_no_op (sc); - if (is_null (cddr (sc->value))) - sc->args= set_plist_4 (sc, lookup (sc, cadr (sc->code)), - lookup (sc, caddr (sc->code)), car (sc->value), - cadr (sc->value)); - else - sc->args= cons_unchecked (sc, lookup (sc, cadr (sc->code)), - cons (sc, lookup (sc, caddr (sc->code)), - sc->value)); /* not ulist here */ - return (apply_mv_no_safe_list (sc)); +static s7_pointer fx_or_and_2a(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer p = cdr(arg); + s7_pointer 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 -op_safe_c_3p_mv (s7_scheme* sc, s7_pointer args) { - begin_temp (sc->x, copy_proper_list (sc, args)); - sc->x= cons (sc, sc->unused, sc->x); - return_with_end_temp (sc->x); +static s7_pointer fx_or_and_3a(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer p = cdr(arg); + s7_pointer 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); + s7_pointer 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 -op_c_p_mv ( - s7_scheme* sc, - s7_pointer args) /* (values (values 1 2)) or (apply (values + '(2))) */ +static s7_pointer fx_or_n(s7_scheme *sc, s7_pointer arg) { - sc->value= args; - pop_stack_no_op (sc); - sc->code= c_function_base (opt1_cfunc (sc->code)); - sc->args= copy_proper_list (sc, sc->value); - if (type (sc->code) == T_C_FUNCTION) - sc->value= apply_c_function_unopt (sc, sc->code, sc->args); - else apply_c_rst_no_req_function (sc); - return (sc->value); + s7_pointer val = sc->F; + for (s7_pointer p = cdr(arg); (is_pair(p)) && (val == sc->F); p = cdr(p)) + val = fx_call(sc, p); + return(val); } -static s7_pointer -op_c_ap_mv (s7_scheme* sc, s7_pointer args) /* (values 2 (values 3 4)) or (apply - + (values 5 '(1 2))) */ +static s7_pointer fx_begin_aa(s7_scheme *sc, s7_pointer arg) { - sc->value= args; - pop_stack_no_op (sc); - clear_multiple_value (sc->value); /* sc->value not copied? */ - sc->args= cons (sc, sc->args, sc->value); - return (apply_mv_no_safe_list (sc)); + fx_call(sc, cdr(arg)); + return(fx_call(sc, cddr(arg))); } -static s7_pointer -op_safe_c_pp_6_mv (s7_scheme* sc, s7_pointer args) /* both args mv */ +static s7_pointer fx_begin_na(s7_scheme *sc, s7_pointer arg) { s7_pointer p; - sc->value= args; - pop_stack_no_op (sc); - for (p= cdr (sc->args); is_pair (cdr (p)); p= cdr (p)) - ; /* we used to copy here: sc->args = pair_append(sc, sc->args, sc->value); - */ - set_cdr (p, 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 - * c_function_base(opt1_cfunc(sc->code)) (let () (define (hi) (+ (values 1 2) - * (values 3 4))) (hi)) -> 10 - */ - return (apply_mv_no_safe_list (sc)); + for (p = cdr(arg); is_pair(cdr(p)); p = cdr(p)) + fx_call(sc, p); + return(fx_call(sc, p)); } -s7_pointer -splice_in_values (s7_scheme* sc, s7_pointer args) { - s7_pointer arglist; - if (SHOW_EVAL_OPS) - safe_print (fprintf (stderr, " %s[%d]: splice %s %s\n", __func__, __LINE__, - (sc->stack_end > sc->stack_start) - ? op_names[stack_top_op (sc)] - : "no stack!", - display_truncated (args))); - if ((S7_DEBUGGING) && ((is_null (args)) || (is_null (cdr (args))))) - fprintf (stderr, "%s: %s\n", __func__, display (args)); - - switch (stack_top_op_unchecked ( - sc)) /* unchecked for C s7_values call at top-level -- see ffitest.c */ - { - /* 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. (let ((g-1 (lambda (x a b c) (x - * (+ a 1) (- b 1) (values c 2))))) (g-1 (lambda (b c d e) (+ b c d e)) 2 3 - * 5)) eval_args2 - */ - begin_temp (sc->y, args); - for (arglist= args; is_pair (cdr (arglist)); arglist= cdr (arglist)) - set_stack_top_args (sc, cons (sc, car (arglist), stack_top_args (sc))); - end_temp (sc->y); - return (car (arglist)); - - case OP_EVAL_ARGS5: - /* (let ((g-1 (lambda (x a b c) (x (+ a 1) (- b 1) 2 (values c 2))))) (g-1 - * (macro (x y z w) (list-values '+ x y z w)) 2 3 5)) */ - /* code = previous arg saved, args = ante-previous args reversed, we'll take - * value->code->args and reverse in args5 */ - if (is_null (args)) return (sc->unspecified); - if (is_null (cdr (args))) return (car (args)); - set_stack_top_args (sc, - cons (sc, stack_top_code (sc), stack_top_args (sc))); - for (arglist= args; is_pair (cddr (arglist)); arglist= cdr (arglist)) - set_stack_top_args (sc, cons (sc, car (arglist), stack_top_args (sc))); - set_stack_top_code (sc, car (arglist)); - return (cadr (arglist)); - - /* handle implicit set! */ - case OP_EVAL_SET1_NO_MV: /* (set! (fnc) ) where evaluation of - returned multiple values */ - case OP_EVAL_SET2_NO_MV: /* (set! (fnc ) ), = mv */ - case OP_EVAL_SET3_NO_MV: /* (define f (dilambda (lambda () 1) (lambda (x) x))) - (define (f2) (values 1 2 3)) (set! (f) (f2)) */ - syntax_error_nr (sc, "too many arguments to set!: ~S", 30, - set_ulist_1 (sc, sc->values_symbol, args)); - case OP_EVAL_SET2: /* here = args is mv */ - set_stack_top_op (sc, OP_EVAL_SET2_MV); - return (args); /* ?? */ - case OP_EVAL_SET3: /* here = args is mv */ - set_stack_top_op (sc, OP_EVAL_SET3_MV); - return (args); /* ?? */ - - case OP_ANY_CLOSURE_NP_1: - case OP_ANY_CLOSURE_NP_2: { - s7_pointer func= pop_op_stack (sc); - /* to s7test some rainy day: (fop24 (fop24-1 x) (fop24-1 (+ x 1)) x x - * (values x x)) (128 128) */ - error_nr (sc, sc->wrong_number_of_args_symbol, - set_elist_3 (sc, too_many_arguments_string, - closure_name (sc, func), - set_ulist_1 (sc, sc->value_symbol, args))); - } - case OP_ANY_C_NP_2: - set_stack_top_op (sc, OP_ANY_C_NP_MV); - goto FP_MV; - - case OP_ANY_C_NP_1: /* ((eval-string (object->string mac5 :readable)) 1 5 3 4) - */ - set_stack_top_op (sc, OP_ANY_C_NP_MV); /* ?? */ - case OP_ANY_C_NP_MV: - 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); - - /* 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_SAFE_C_SP_1: - case OP_SAFE_CONS_SP_1: - case OP_SAFE_ADD_SP_1: - case OP_SAFE_MULTIPLY_SP_1: - /* (let () (define (ho a) (+ a 2)) (define (hi) (+ (ho 1) (values 3 4))) - * (hi)) from safe_c_pp->h_c_aa? */ - return (op_safe_c_sp_mv (sc, args)); - - case OP_SAFE_C_PS_1: - return (op_safe_c_ps_mv (sc, args)); /* (define (f) (let ((d #\d)) (string - (values #\a #\b #\c) d))) (f) */ - case OP_SAFE_C_PC_1: - return (op_safe_c_pc_mv ( - sc, args)); /* (define (f) (string (values #\a #\b #\c) #\d)) (f) */ - case OP_SAFE_C_PA_1: - return (op_safe_c_pa_mv (sc, args)); - case OP_SAFE_C_SSP_1: - return (op_safe_c_ssp_mv (sc, args)); - case OP_SAFE_C_P_1: - return (op_safe_c_p_mv (sc, args)); /* (string (values #\a #\b #\c)) */ - case OP_C_P_1: - return (op_c_p_mv (sc, args)); /* (let () (define (ho a) (values a 1)) - (define (hi) (- (ho 2))) (hi)) */ - case OP_C_AP_1: - return (op_c_ap_mv (sc, args)); - case OP_SAFE_C_PP_5: - return (op_safe_c_pp_6_mv ( - sc, args)); /* (let () (define (hi) (+ (values 1 2) (values 3 4))) (hi)) - (also safe_c_pp_1) */ - - case OP_SAFE_C_PP_1: /* (define (f) (list (values 1 2) (values 3 4))) (f): - args='(1 2), top_args=# */ - set_stack_top_op (sc, OP_SAFE_C_PP_3_MV); - return (args); - - case OP_SAFE_C_3P_1: - case OP_SAFE_C_3P_2: - case OP_SAFE_C_3P_3: /* (let ((g-1 (lambda (x a b c) (x (+ a 1) (- b 1) - (values c 2))))) (g-1 + 2 3 5)) */ - set_stack_top_op (sc, stack_top_op (sc) + - 3); /* change op to parallel mv case */ - case OP_SAFE_C_3P_1_MV: - case OP_SAFE_C_3P_2_MV: - case OP_SAFE_C_3P_3_MV: /* (list-values '+ 1 (apply-values (list 2 3))) */ - return (op_safe_c_3p_mv (sc, 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_sym) */ - 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: - /* (let () (define (func) (do ((x 0.0 (+ x 0.1)) (i 0 (+ i 1))) ((>= x 0.1) - * (#_with-baffle (inlet (values 1 2) (symbol? x)))))) (func)) */ - if (is_multiple_value (sc->value)) clear_multiple_value (sc->value); - error_nr (sc, sc->wrong_number_of_args_symbol, - set_elist_3 (sc, too_many_arguments_string, stack_top_code (sc), - sc->value)); - - /* 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: /* (let-temporarily ((var (values 1 2 3))) var) */ - case OP_SET_FROM_SETTER: /* stack_top_code(sc) is slot if (set! x (set! - (setter 'x) g)) s7test.scm */ - syntax_error_with_caller_nr (sc, "set!: can't set ~A to ~S", 24, - (is_slot (stack_top_code (sc))) - ? slot_symbol (stack_top_code (sc)) - : stack_top_code (sc), - set_ulist_1 (sc, sc->values_symbol, args)); - - case OP_SET_opSAq_P_1: - case OP_SET_opSAAq_P_1: - /* we can assume here that we're dealing with the section after the target, - * (set! (target...) arg) where arg can't be (values...) (define (a3 x) x) - * (set! (setter a3) (lambda (x y z) (list x y z))) - * <11> (set! (a3 1) 2) - * error: <10>: not enough arguments: ((lambda (x y z) ...) 1 2) - * <12> (set! (a3 1) 2 3) - * error: (set! (a3 1) 2 3): too many arguments to set! - * <13> (set! (a3 1) (values 2 3)) - * (set! (a3 1) (values 2 3)): too many arguments to set! - * but (set! (a3 1 2) 3) is ok, also (set! (a3 (values 1 2)) 3) - */ - syntax_error_nr (sc, "too many arguments to set! ~S", 29, - set_ulist_1 (sc, sc->values_symbol, args)); - - case OP_LET1: /* (let ((var (values 1 2 3))) ...) */ - { - /* (let () (define (hi) (let ((x (values 1 2))) (if x (list x)))) (define - * (ho) (hi)) (catch #t (lambda () (ho)) (lambda args #f)) (ho)) */ - /* this code assumes op_let_1 is building a list of values stored in - * sc->args etc */ - s7_pointer let_code, vars, sym, p= stack_top_args (sc); - 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); - syntax_error_with_caller2_nr (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: - /* (let () (define (hi) (let ((x (values 1 2))) (display x) (if x (list - * x)))) (define (ho) (hi)) (catch #t (lambda () (ho)) (lambda args #f)) - * (ho)) */ - syntax_error_with_caller2_nr (sc, "~A: can't bind ~A to ~S", 23, - sc->let_symbol, - opt2_sym (stack_top_code (sc)), - set_ulist_1 (sc, sc->values_symbol, args)); - - case OP_LET_ONE_OLD_1: - case OP_LET_ONE_P_OLD_1: - syntax_error_with_caller2_nr ( - sc, "~A: can't bind ~A to ~S", 23, sc->let_symbol, - slot_symbol (let_slots (opt3_let (stack_top_code (sc)))), - set_ulist_1 (sc, sc->values_symbol, args)); - - case OP_LET_STAR1: /* here caar(sc->code) is bound to sc->value */ - syntax_error_with_caller2_nr ( - sc, "~A: can't bind ~A to ~S", 23, sc->let_star_symbol, - caar (stack_top_code (sc)), set_ulist_1 (sc, sc->values_symbol, args)); - - case OP_LETREC1: /* here sc->args is the slot about to receive a value */ - syntax_error_with_caller2_nr (sc, "~A: can't bind ~A to ~S", 23, - sc->letrec_symbol, - slot_symbol (stack_top_args (sc)), - set_ulist_1 (sc, sc->values_symbol, args)); - - case OP_LETREC_STAR1: - syntax_error_with_caller2_nr (sc, "~A: can't bind ~A to ~S", 23, - sc->letrec_star_symbol, - slot_symbol (stack_top_args (sc)), - 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 (arglist= args; is_pair (cdr (arglist)); arglist= cdr (arglist)) - if (car (arglist) == sc->F) return (sc->F); - return (car (arglist)); - - case OP_OR_P1: - for (arglist= args; is_pair (cdr (arglist)); arglist= cdr (arglist)) - if (car (arglist) != sc->F) return (car (arglist)); - return (car (arglist)); - - case OP_IF1: /* (if (values ...) ...) -- see s7.html at the end of the values - writeup for explanation (we're following CL here) */ - 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_I_S: - case OP_COND1: - case OP_COND1_SIMPLE: - /* (if (values 1 2) 3) */ - return (car (args)); - - case OP_IF_PN: /* (if|when (not (values...)) ...) as opposed to (if|unless - (values...)...) which follows CL and drops trailing values - */ - /* doesn't this error check happen elsewhere? */ - syntax_error_nr (sc, "too many arguments to not: ~S", 29, - set_ulist_1 (sc, sc->values_symbol, args)); - - case OP_DYNAMIC_UNWIND: - case OP_DYNAMIC_UNWIND_PROFILE: { - const s7_pointer old_value= sc->value; - const bool mv = is_multiple_value (args); - if (mv) clear_multiple_value (args); - sc->value= cons (sc, sc->values_symbol, args); - dynamic_unwind ( - sc, stack_top_code (sc), - stack_top_args ( - sc)); /* position (curlet), this applies code to sc->value */ - 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_DEACTIVATE_GOTO: /* (+ (call-with-exit (lambda (ret) (values 1 2 3)))) - */ - call_exit_active (stack_top_args (sc))= - false; /* stack_top_args(sc) is the goto */ - /* fall through */ - case OP_CATCH: - case OP_CATCH_1: - case OP_CATCH_2: - case OP_CATCH_ALL: /* (+ (catch #t (lambda () (values 3 4)) (lambda args - args))) */ - case OP_BARRIER: - pop_stack_no_op (sc); - return (splice_in_values (sc, args)); - - case OP_GC_PROTECT: - /* (test (+ (let ((x 0)) (do ((i (values 0) (+ i 1))) (((values = i 10)) - (values x 2 3)) (set! x (+ x i)))) 4) 54) ; (+ 45 2 3 4) = 54 stack: - gc_protect, sc->code: (values x 2 3), args (the "c" in c_pc_1): '(45 2 - 3), sc->value: #t safe_c_pc_1 catch let_one_p_old_1 - */ - 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: - /* 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_EVAL_MACRO_MV: /* perhaps reader-cond expansion at eval-time (not at - run-time) via ((let () reader-cond) ...)? */ - { - const opcode_t s_op= stack_top4_op (sc); - if ((S7_DEBUGGING) && - (SHOW_EVAL_OPS == 1)) /* the == 1 business is for clang++ */ - fprintf ( - stderr, - " eval_macro_mv splice %s with %s, code: %s, args: %s, value: %s\n", - display_truncated (args), op_names[s_op], - display_truncated (sc->code), display_truncated (sc->args), - display_truncated (sc->value)); - if ((s_op == OP_DO_STEP) || (s_op == OP_DEACTIVATE_GOTO) || - (s_op == OP_LET1)) - return (args); /* tricky reader-cond as macro in do body returning - values... or call-with-exit */ - - /* if eval_args2 here, how to maintain the current evaluation? - * (+ (reader-cond (#t 1 (values 2 3) 4))) -> 10 - * (+ (((vector reader-cond) 0) (#t 1 (values 2 3) 4))) -> 5 [10 if this - * block of code is included, s7test is ok with this code] - */ - if (s_op == OP_EVAL_ARGS2) { - begin_temp (sc->y, args); - for (arglist= args; is_pair (cdr (arglist)); arglist= cdr (arglist)) - stack_top4_args (sc)= cons (sc, car (arglist), stack_top4_args (sc)); - end_temp (sc->y); - if (SHOW_EVAL_OPS) - fprintf (stderr, - " eval_macro splice %s with %s, code: %s, args: %s, value: " - "%s -> %s %s\n", - display_truncated (args), op_names[s_op], - display_truncated (sc->code), display_truncated (sc->args), - display_truncated (sc->value), - display_truncated (stack_top4_args (sc)), - display_truncated (car (arglist))); - return (car (arglist)); - } - /* else fall through */ - /* safe_c_p_1 also happens and currently drops trailing arg: ((let () - * reader-cond) (#t (values 1 2) (iv))) op_eval_macro (not op_expansion) is - * called and can be included below (except it segfaults in s7test...), but - * trailing arg is still dropped because optimizer sees (reader-cond ...) -- - * one arg! (define iv (int-vector 1 2)) (define (func) (eof-object? ((let - * () reader-cond) (#t (values 1 2) (iv))))) (func) - */ - } +static s7_pointer fx_safe_thunk_a(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer func = opt1_lambda(code); + s7_pointer result; + gc_protect_via_stack(sc, sc->curlet); /* we do need to GC protect curlet here and below (not just remember it) */ + set_curlet(sc, closure_let(func)); + result = fx_call(sc, closure_body(func)); + set_curlet(sc, gc_protected1(sc)); + unstack_gc_protect(sc); + return(result); +} - 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; but it could be OP_LOAD_RETURN_IF_EOF if - * the expansion is at top level). - * (+ (reader-cond (#t 1 (values 2 3) 4))) - */ - if (SHOW_EVAL_OPS) { - s7_int old_print_length= sc->print_length; - if (old_print_length > 40) sc->print_length= 40; - fprintf (stderr, " %s[%d]: %s stack top: %" ld64 ", op: %s, args: %s\n", - __func__, __LINE__, op_names[stack_top_op (sc)], - (s7_int) (intptr_t) stack_top (sc), op_names[stack_top4_op (sc)], - display_truncated (args)); - sc->print_length= old_print_length; - } - if (stack_top4_op (sc) == OP_LOAD_RETURN_IF_EOF) { - /* expansion at top-level returned values, eval args in order */ - sc->code= args; - push_stack_no_args_direct (sc, sc->begin_op); - return (sc->code); - } - for (arglist= args; is_pair (cdr (arglist)); arglist= cdr (arglist)) - stack_top4_args (sc)= cons (sc, car (arglist), stack_top4_args (sc)); - pop_stack_no_op ( - sc); /* need GC protection in loop above, so do this afterwards */ - return (car (arglist)); /* sc->value from OP_READ_LIST point of view */ - - case OP_EVAL_DONE: /* ((lambda (w) 1) (char-ready? (open-input-function - (lambda (x) (values 1 2 3 4 5 6 7))))) */ - if (stack_top4_op (sc) == OP_NO_VALUES) - error_nr ( - sc, sc->error_symbol, - set_elist_1 ( - sc, - wrap_string ( - sc, "function-port should not return multiple-values", 47))); - set_stack_top_op (sc, - OP_SPLICE_VALUES); /* tricky -- continue from eval_done - with the current splice */ - set_stack_top_args (sc, args); - push_stack_op (sc, OP_EVAL_DONE); - return (args); - - default: - /* (let () (define (f1) (do ((i 0 (+ i 1))) ((= i 1)) (values (append "" - * (block)) 1))) (f1)) safe_dotimes_step_o */ - /* ((values memq (values #\a '(#\A 97 #\a)))) eval_args */ - if (SHOW_EVAL_OPS) - fprintf (stderr, " %s[%d]: splice gives up: %s\n", __func__, __LINE__, - op_names[stack_top_op (sc)]); - break; - } +static s7_pointer fx_safe_closure_s_a(s7_scheme *sc, s7_pointer code) /* also called from h_safe_closure_s_a in eval */ +{ + const s7_pointer func = opt1_lambda(code); + s7_pointer result; + gc_protect_via_stack(sc, sc->curlet); + set_curlet(sc, update_let_with_slot(sc, closure_let(func), lookup(sc, opt2_sym(code)))); + result = fx_call(sc, closure_body(func)); + set_curlet(sc, gc_protected1(sc)); + unstack_gc_protect(sc); + return(result); +} - /* 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); +static s7_pointer op_safe_closure_s_a(s7_scheme *sc, s7_pointer code) /* also called from h_safe_closure_s_a in eval */ +{ + const s7_pointer func = opt1_lambda(code); + set_curlet(sc, update_let_with_slot(sc, closure_let(func), lookup(sc, opt2_sym(code)))); + return(fx_call(sc, closure_body(func))); } -/* -------------------------------- values -------------------------------- */ -static s7_pointer -g_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)); -} - -s7_pointer -s7_values (s7_scheme* sc, s7_pointer args) { - if (is_null (args)) return (sc->no_value); - if (is_null (cdr (args))) return (car (args)); - if (sc->stack_start >= sc->stack_end) /* s7_values called when no s7 stack - (ffitest.c for example) */ - { - set_multiple_value (args); - return (args); - } - return (splice_in_values (sc, args)); +static s7_pointer fx_safe_closure_t_a(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer func = opt1_lambda(code); + s7_pointer result; + gc_protect_via_stack(sc, sc->curlet); + set_curlet(sc, update_let_with_slot(sc, closure_let(func), t_lookup(sc, opt2_sym(code), code))); + result = fx_call(sc, closure_body(func)); + set_curlet(sc, gc_protected1(sc)); + unstack_gc_protect(sc); + return(result); } -static s7_pointer -values_p (s7_scheme* sc) { - return (sc->no_value); +static s7_pointer fx_safe_closure_s_to_s(s7_scheme *sc, s7_pointer arg) +{ + return(fn_proc(car(closure_body(opt1_lambda(arg))))(sc, with_list_t1(sc, lookup(sc, opt2_sym(arg))))); } -static s7_pointer -values_p_p (s7_scheme* unused_sc, s7_pointer p) { - return (p); + +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 -values_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer unused_expr) { - if (args > 1) return (sc->values_uncopied); /* splice_in_values */ - return (func); +static s7_pointer fx_safe_closure_s_to_vref(s7_scheme *sc, s7_pointer arg) {return(s7i_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 = lookup(sc, opt2_sym(arg)); + if ((is_t_integer(p))) return(make_integer(sc, integer(p) - 1)); + return(minus_c1(sc, p)); } -bool -s7_is_multiple_value (s7_pointer obj) { - return (is_multiple_value (obj)); +static s7_pointer fx_safe_closure_s_to_add1(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer p = lookup(sc, opt2_sym(arg)); + if ((is_t_integer(p))) return(make_integer(sc, integer(p) + 1)); + /* better but slower: return(add_if_overflow_to_real_or_big_integer(sc, integer(p), 1)) */ + return(g_add_x1_1(sc, p, 1)); } -/* -------------------------------- list-values -------------------------------- - */ -static s7_pointer -splice_out_values (s7_scheme* sc, - s7_pointer args) { /* (list-values ... (values) ... ) removes - the (values) */ - s7_pointer tp; - while (car (args) == sc->no_value) { - args= cdr (args); - if (is_null (args)) return (sc->nil); - } - tp= list_1 (sc, car (args)); - if (is_null (cdr (args))) return (tp); - begin_temp (sc->x, tp); - for (s7_pointer 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); - } - end_temp (sc->x); - return (tp); -} - -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 */ +static s7_pointer fx_c_ff(s7_scheme *sc, s7_pointer arg) +{ + const s7_pointer p = cdr(arg); + const s7_pointer val = fx_proc(cdar(p))(sc, car(p)); + sc->value = val; + set_car(sc->t2_2, fx_proc(cdadr(p))(sc, cadr(p))); + set_car(sc->t2_1, val); + return(fn_proc(arg)(sc, sc->t2_1)); +} - s7_pointer arglist; - bool checked= false; - for (arglist= args; is_pair (arglist); arglist= cdr (arglist)) - if (is_pair (car (arglist))) { - if (is_checked (car (arglist))) checked= true; - } - else if (car (arglist) == - sc->no_value) /* car_unchecked|cdr unrolled here is not faster */ - break; - if (is_null (arglist)) { - if (!checked) /* (!tree_has_definer(sc, args)) seems to work, reduces - copy_tree calls slightly, but costs more than it saves in - tgen */ - { - for (s7_pointer p= args; is_pair (p); - p= cdr (p)) /* embedded list can be immutable, so we need to copy - (sigh) */ - if (is_immutable_pair ( - p)) /* immutable if unheaped sometimes! (tset.scm typed-let) */ - return (copy_proper_list (sc, args)); - return (args); - } - begin_temp (sc->temp6, 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 (sc, car (args))) - ? copy_tree_with_type (sc, car (args)) - : car (args), - (is_unquoted_pair (sc, 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 */ - end_temp (sc->temp6); - 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? - */ - return (splice_out_values (sc, args)); -} - -static s7_pointer -g_simple_list_values (s7_scheme* sc, s7_pointer args) { - /* if just (code-)constant/symbol, symbol->pair won't be checked (not - * optimized/re-expanded code), but might be no-values */ - for (s7_pointer p= args; is_pair (p); p= cdr (p)) - if (car (p) == sc->no_value) return (splice_out_values (sc, args)); - if (is_immutable (args)) return (copy_proper_list (sc, args)); - return (args); -} - -static s7_pointer -list_values_chooser (s7_scheme* sc, s7_pointer func, int32_t unused_args, - s7_pointer expr) { - for (s7_pointer p= cdr (expr); is_pair (p); p= cdr (p)) - if (is_unquoted_pair (sc, car (p))) return (func); - return (sc->simple_list_values); -} - -/* -------------------------------- 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 arg; /* apply-values takes 1 arg: ,@a -> (apply-values a) */ - if (is_null (args)) return (sc->no_value); - arg= car (args); - if (is_null (arg)) return (sc->no_value); - if (!s7_is_proper_list (sc, arg)) apply_list_error_nr (sc, arg); - if (is_null (cdr (arg))) - return (car (arg)); /* needs to follow previous because it might not be a - pair: (apply-values 2) */ - set_needs_copied_args (arg); - return (splice_in_values (sc, arg)); - /* return(s7_values(sc, x)); */ /* g_values == s7_values */ +static s7_pointer fx_safe_closure_a_to_sc(s7_scheme *sc, s7_pointer arg) +{ + const s7_pointer func = opt1_lambda(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(func)))(sc, sc->t2_1)); } -/* (apply values ...) replaces (unquote_splicing ...) - * (define-macro (hi a) `(+ 1 ,a) == (list '+ 1 a) - * (define-macro (hi a) `(+ 1 ,@a) == (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) but in s7 this is an error. - * also in CL the target of ,@ can apparently be a circular list - */ +static s7_pointer fx_safe_closure_a_to_vref(s7_scheme *sc, s7_pointer arg) {return(s7i_vector_ref_p_pp(sc, fx_call(sc, cdr(arg)), opt3_con(cdr(arg))));} -/* -------------------------------- 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 lst, slow; - for (lst= form, slow= form; is_pair (lst); lst= cdr (lst), slow= cdr (slow)) { - if (is_pair (car (lst))) { - if (!is_simple_code (sc, car (lst))) return (false); - } - else if (car (lst) == sc->unquote_symbol) return (false); - lst= cdr (lst); - if (!is_pair (lst)) return (is_null (lst)); - if (lst == slow) return (false); - if (is_pair (car (lst))) { - if (!is_simple_code (sc, car (lst))) return (false); - } - else if (car (lst) == sc->unquote_symbol) return (false); - } - return (is_null (lst)); +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 */ +{ + const s7_pointer func = opt1_lambda(code); + s7_pointer result; + gc_protect_via_stack(sc, sc->curlet); + set_curlet(sc, update_let_with_slot(sc, closure_let(func), lookup(sc, opt2_sym(code)))); + code = cdar(closure_body(func)); + 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, gc_protected1(sc)); + unstack_gc_protect(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 */ +{ + const s7_pointer func = opt1_lambda(code); + s7_pointer result; + gc_protect_via_stack(sc, sc->curlet); + set_curlet(sc, update_let_with_slot(sc, closure_let(func), lookup(sc, opt2_sym(code)))); + code = cdar(closure_body(func)); + result = (is_pair(t_lookup(sc, cadar(code), code))) ? fx_call(sc, cdr(code)) : sc->F; /* pair? arg = func par, pair? is global, symbol_id=0 */ + set_curlet(sc, gc_protected1(sc)); + unstack_gc_protect(sc); + return(result); } -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)." +static s7_pointer fx_safe_closure_a_a(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer func = opt1_lambda(code); + s7_pointer result; + gc_protect_via_stack(sc, sc->curlet); + set_curlet(sc, update_let_with_slot(sc, closure_let(func), fx_call(sc, cdr(code)))); + result = fx_call(sc, closure_body(func)); + set_curlet(sc, gc_protected1(sc)); + unstack_gc_protect(sc); + return(result); +} - if (!is_pair (form)) { - if (is_normal_symbol (form)) return (list_2 (sc, sc->quote_function, 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))) - syntax_error_nr (sc, "unquote: no argument, ~S", 24, form); - syntax_error_nr (sc, "unquote: stray dot, ~S", 22, form); - } - if (is_not_null (cddr (form))) - syntax_error_nr (sc, "unquote: too many arguments, ~S", 31, form); - return (cadr (form)); - } +static s7_pointer op_safe_closure_a_a(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer func = opt1_lambda(code); + set_curlet(sc, update_let_with_slot(sc, closure_let(func), fx_call(sc, cdr(code)))); + return(fx_call(sc, closure_body(func))); +} - /* 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))) - return (list_2 (sc, sc->quote_function, form)); +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))));} - { - s7_pointer orig, bq; - const s7_pointer old_scw= sc->w; /* very often, sc->w is in use here */ - bool dotted = false; - s7_int len = s7_list_length (sc, form); - if (len < 0) { - len = -len; - dotted= true; - } - gc_protect_via_stack (sc, sc->w); - - check_free_heap_size (sc, len + 1); - sc->w= sc->nil; /* temp6? */ - for (s7_int i= 0; i <= len; i++) - sc->w= cons_unchecked (sc, sc->nil, sc->w); - - set_car (sc->w, initial_value (sc->list_values_symbol)); - if (!dotted) { - s7_int i= 0; - for (orig= form, bq= cdr (sc->w); 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_gc_protect (sc); - syntax_error_nr (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, initial_value (sc->qq_append_symbol), sc->w, - caddr (orig)); /* `(f . ,(string-append "h" "i")) */ - break; - } - else set_car (bq, g_quasiquote_1 (sc, car (orig), false)); - } - else /* `(1 2 . 3) */ - { - s7_int i= 0; - len--; - for (orig= form, bq= cdr (sc->w); 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, initial_value (sc->qq_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_gc_protect (sc); - return (bq); - } +static s7_pointer fx_safe_closure_a_and_2a(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer func = opt1_lambda(code); + const s7_pointer and_arg = cdar(closure_body(func)); + s7_pointer result; + gc_protect_via_stack(sc, sc->curlet); + set_curlet(sc, update_let_with_slot(sc, closure_let(func), fx_call(sc, cdr(code)))); + result = fx_call(sc, and_arg); + if (result != sc->F) result = fx_call(sc, cdr(and_arg)); + set_curlet(sc, gc_protected1(sc)); + unstack_gc_protect(sc); + return(result); } -static s7_pointer -g_quasiquote (s7_scheme* sc, - s7_pointer args) /* this is for explicit quasiquote support, not - the backquote stuff in macros */ +static s7_pointer fx_safe_closure_ss_a(s7_scheme *sc, s7_pointer code) { - return (g_quasiquote_1 (sc, car (args), true)); + const s7_pointer func = opt1_lambda(code); + s7_pointer result; + gc_protect_via_stack(sc, sc->curlet); + set_curlet(sc, update_let_with_two_slots(sc, closure_let(func), lookup(sc, cadr(code)), lookup(sc, opt2_sym(code)))); + result = fx_call(sc, closure_body(func)); + set_curlet(sc, gc_protected1(sc)); + unstack_gc_protect(sc); + return(result); } -static s7_pointer -g_qq_append (s7_scheme* sc, s7_pointer args) { -#define H_qq_append ": CL list* (I think) for quasiquote's internal use" -#define Q_qq_append \ - s7_make_signature (sc, 3, sc->is_list_symbol, sc->is_list_symbol, sc->T) - - const s7_pointer a= car (args), b= cadr (args); - s7_pointer p, tp, np; - if (is_null (a)) return (b); - if (!is_pair (a)) /* (apply ``(x . 1) '(0 1 2)) so a=1, b=2 */ - wrong_type_error_nr (sc, sc->quasiquote_symbol, 1, a, a_list_string); - p= cdr (a); - 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_gc_protect (sc); - return (tp); +static s7_pointer op_safe_closure_ss_a(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer func = opt1_lambda(code); + set_curlet(sc, update_let_with_two_slots(sc, closure_let(func), lookup(sc, cadr(code)), lookup(sc, opt2_sym(code)))); + return(fx_call(sc, closure_body(func))); } -/* -------------------------------- 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 func= s7_make_safe_function (sc, name, f, required_args, - optional_args, rest_arg, NULL); - s7_function_set_class (sc, func, cls); - c_function_set_signature (func, c_function_signature (cls)); - return (func); -} - -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 func= s7_make_function (sc, name, f, required_args, optional_args, - rest_arg, NULL); - s7_function_set_class (sc, func, cls); - c_function_set_signature (func, c_function_signature (cls)); - return (func); -} - -static s7_pointer -set_function_chooser (s7_pointer sym, - s7_pointer (*chooser) (s7_scheme* sc, s7_pointer f, - int32_t args, s7_pointer expr)) { - s7_pointer func = global_value (sym); - c_function_chooser (func)= chooser; - return (func); -} - -static void -init_choosers (s7_scheme* sc) { - s7_pointer func; +static s7_pointer fx_safe_closure_3s_a(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer func = opt1_lambda(code); + s7_pointer result; + gc_protect_via_stack(sc, sc->curlet); + set_curlet(sc, update_let_with_three_slots(sc, closure_let(func), lookup(sc, cadr(code)), lookup(sc, opt2_sym(code)), lookup(sc, opt3_sym(code)))); + result = fx_call(sc, closure_body(func)); + set_curlet(sc, gc_protected1(sc)); + unstack_gc_protect(sc); + return(result); +} - /* + */ - func = set_function_chooser (sc->add_symbol, add_chooser); - sc->add_class= c_function_class (func); - sc->add_2 = make_function_with_class (sc, func, "+", g_add_2, 2, 0, false); - sc->add_3 = make_function_with_class (sc, func, "+", g_add_3, 3, 0, false); - sc->add_4 = make_function_with_class (sc, func, "+", g_add_4, 4, 0, false); - sc->add_1x= make_function_with_class (sc, func, "+", g_add_1x, 2, 0, false); - sc->add_x1= make_function_with_class (sc, func, "+", g_add_x1, 2, 0, false); - sc->add_i_random= - make_function_with_class (sc, func, "+", g_add_i_random, 2, 0, false); +static s7_pointer op_safe_closure_3s_a(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer func = opt1_lambda(code); + set_curlet(sc, update_let_with_three_slots(sc, closure_let(func), lookup(sc, cadr(code)), lookup(sc, opt2_sym(code)), lookup(sc, opt3_sym(code)))); + return(fx_call(sc, closure_body(func))); +} - /* - */ - func= set_function_chooser (sc->subtract_symbol, subtract_chooser); - sc->subtract_class= c_function_class (func); - sc->subtract_1= - make_function_with_class (sc, func, "-", g_subtract_1, 1, 0, false); - sc->subtract_2= - make_function_with_class (sc, func, "-", g_subtract_2, 2, 0, false); - sc->subtract_3= - make_function_with_class (sc, func, "-", g_subtract_3, 3, 0, false); - sc->subtract_x1= - make_function_with_class (sc, func, "-", g_subtract_x1, 2, 0, false); - sc->subtract_2f= - make_function_with_class (sc, func, "-", g_subtract_2f, 2, 0, false); - sc->subtract_f2= - make_function_with_class (sc, func, "-", g_subtract_f2, 2, 0, false); +static s7_pointer fx_safe_closure_aa_a(s7_scheme *sc, s7_pointer code) +{ + s7_pointer p = cdr(code); + const s7_pointer func = opt1_lambda(code); + check_stack_size(sc); /* lint+s7test.scm can overflow here */ + 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 */ + set_curlet(sc, update_let_with_two_slots(sc, closure_let(func), fx_call(sc, p), gc_protected2(sc))); + p = fx_call(sc, closure_body(func)); + set_curlet(sc, gc_protected1(sc)); + unstack_gc_protect(sc); + return(p); +} + +static inline s7_pointer fx_cond_na_na(s7_scheme *sc, s7_pointer code) /* all tests are fxable, results are all fx, no =>, no missing results */ +{ + for (s7_pointer 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); +} - /* * */ - func= set_function_chooser (sc->multiply_symbol, multiply_chooser); - sc->multiply_class= c_function_class (func); - sc->multiply_2= - make_function_with_class (sc, func, "*", g_multiply_2, 2, 0, false); - sc->multiply_3= - make_function_with_class (sc, func, "*", g_multiply_3, 3, 0, false); +static s7_pointer fx_implicit_starlet_ref_s(s7_scheme *sc, s7_pointer arg) {return(starlet(sc, opt3_int(arg)));} +static s7_pointer fx_implicit_starlet_print_length(s7_scheme *sc, s7_pointer arg) {return(make_integer(sc, sc->print_length));} +static s7_pointer fx_implicit_starlet_safety(s7_scheme *sc, s7_pointer arg) {return(make_integer(sc, sc->safety));} - /* / */ - func= set_function_chooser (sc->divide_symbol, divide_chooser); - sc->invert_1= - make_function_with_class (sc, func, "/", g_invert_1, 1, 0, false); - sc->divide_2= - make_function_with_class (sc, func, "/", g_divide_2, 2, 0, false); - sc->invert_x= - make_function_with_class (sc, func, "/", g_invert_x, 2, 0, false); - sc->divide_by_2= - make_function_with_class (sc, func, "/", g_divide_by_2, 2, 0, false); +static s7_function *fx_function = NULL; - /* = */ - func = set_function_chooser (sc->num_eq_symbol, num_eq_chooser); - sc->num_eq_class= c_function_class (func); - sc->num_eq_2= - make_function_with_class (sc, func, "=", g_num_eq_2, 2, 0, false); - sc->num_eq_xi= - make_function_with_class (sc, func, "=", g_num_eq_xi, 2, 0, false); - sc->num_eq_ix= - make_function_with_class (sc, func, "=", g_num_eq_ix, 2, 0, false); +static bool is_fxable(s7_scheme *sc, s7_pointer expr) +{ + if (!is_pair(expr)) return(true); + if ((is_optimized(expr)) && /* this is needed. In check_tc, for example, is_fxable can be confused by early optimize_op */ + (fx_function[optimize_op(expr)])) + return(true); + return(is_proper_quote(sc, expr)); +} - /* min */ - func= set_function_chooser (sc->min_symbol, min_chooser); - sc->min_2= - make_function_with_class (sc, func, "s7-min", g_min_2, 2, 0, false); - sc->min_3= - make_function_with_class (sc, func, "s7-min", g_min_3, 3, 0, false); +static int32_t fx_count(s7_scheme *sc, s7_pointer expr) +{ + int32_t count = 0; + for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p)) + if (is_fxable(sc, car(p))) + count++; + return(count); +} - /* max */ - func= set_function_chooser (sc->max_symbol, max_chooser); - sc->max_2= - make_function_with_class (sc, func, "s7-max", g_max_2, 2, 0, false); - sc->max_3= - make_function_with_class (sc, func, "s7-max", g_max_3, 3, 0, false); +static bool is_code_constant(s7_scheme *sc, s7_pointer p) {return((is_pair(p)) ? (is_quote(sc, car(p))) : (!is_normal_symbol(p)));} - /* < */ - func = set_function_chooser (sc->lt_symbol, less_chooser); - sc->less_xi= make_function_with_class (sc, func, "<", g_less_xi, 2, 0, false); - sc->less_x0= make_function_with_class (sc, func, "<", g_less_x0, 2, 0, false); - sc->less_xf= make_function_with_class (sc, func, "<", g_less_xf, 2, 0, false); - sc->less_2 = make_function_with_class (sc, func, "<", g_less_2, 2, 0, false); +static inline s7_pointer check_quote(s7_scheme *sc, s7_pointer code); - /* > */ - func= set_function_chooser (sc->gt_symbol, greater_chooser); - sc->greater_xi= - make_function_with_class (sc, func, ">", g_greater_xi, 2, 0, false); - sc->greater_xf= - make_function_with_class (sc, func, ">", g_greater_xf, 2, 0, false); - sc->greater_2= - make_function_with_class (sc, func, ">", g_greater_2, 2, 0, false); +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); - /* <= */ - func = set_function_chooser (sc->leq_symbol, leq_chooser); - sc->leq_xi= make_function_with_class (sc, func, "<=", g_leq_xi, 2, 0, false); - sc->leq_2 = make_function_with_class (sc, func, "<=", g_leq_2, 2, 0, false); - sc->leq_ixx= - make_function_with_class (sc, func, "<=", g_leq_ixx, 3, 0, false); +#define is_unchanged_global(P) ((is_symbol(P)) && (is_defined_global(P)) && (is_eq_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 */ - /* >= */ - func = set_function_chooser (sc->geq_symbol, geq_chooser); - sc->geq_xi= make_function_with_class (sc, func, ">=", g_geq_xi, 2, 0, false); - sc->geq_xf= make_function_with_class (sc, func, ">=", g_geq_xf, 2, 0, false); - sc->geq_2 = make_function_with_class (sc, func, ">=", g_geq_2, 2, 0, false); +static bool fx_matches(s7_pointer symbol, const s7_pointer target_symbol) {return((symbol == target_symbol) && (is_unchanged_global(symbol)));} - /* log */ - func= set_function_chooser (sc->log_symbol, log_chooser); - sc->int_log2= - make_function_with_class (sc, func, "log", g_int_log2, 2, 0, false); +typedef bool (safe_sym_t)(s7_scheme *sc, s7_pointer sym, s7_pointer var_list); - /* logior */ - func= set_function_chooser (sc->logior_symbol, logior_chooser); - sc->logior_2= - make_function_with_class (sc, func, "logior", g_logior_2, 2, 0, false); - sc->logior_ii= - make_function_with_class (sc, func, "logior", g_logior_ii, 2, 0, false); +/* #define fx_choose(Sc, Holder, Var_List, Checker) fx_choose_1(Sc, Holder, Var_List, Checker, __func__, __LINE__) */ +static s7_function fx_choose(s7_scheme *sc, const s7_pointer holder, const s7_pointer var_list, safe_sym_t *checker) /* , const char *func, int32_t line) */ +{ + const s7_pointer arg = car(holder); +#if S7_DEBUGGING + if ((!is_let(var_list)) && (!is_list(var_list))) fprintf(stderr, "%s[%d]: var_list: %s\n", __func__, __LINE__, display(var_list)); +#endif + if (!is_pair(arg)) + { + if (is_symbol(arg)) + { + if (is_keyword(arg)) return(fx_c); + if ((arg == sc->else_symbol) && (is_global(sc->else_symbol))) + { + if (is_let(var_list)) {if (s7_symbol_local_value(sc, arg, var_list) == sc->else_symbol) return(fx_c);} + else if ((is_pair(var_list)) && (!direct_memq(arg, var_list))) return(fx_c); /* is_pair -> not () */ + } + return((is_defined_global(arg)) ? fx_g : ((checker(sc, arg, var_list)) ? fx_s : fx_unsafe_s)); + } + return(fx_c); + } + if (is_optimized(arg)) + { + const s7_pointer head = car(arg); + switch (optimize_op(arg)) + { + case HOP_SAFE_C_NC: /* includes 0-arg cases, newline/current-input|output-port, [make-]hash-table?, read-line, [float-]vector/list, gensym */ + if (cdr(arg) == sc->nil) return((fn_proc(arg) == g_read_char) ? fx_read_char_0 : fx_c_0c); + if (fn_proc(arg) == g_add_i_random) return(fx_add_i_random); + if (fn_proc(arg) == g_cons) + { + set_opt1_con(cdr(arg), caddr(arg)); + return(fx_cons_cc); + } + return((fn_proc(arg) == g_random_i) ? fx_random_i : fx_c_nc); + + case OP_OR_2A: + { + const s7_pointer arg2p = cddr(arg); + if (fx_proc(arg2p) == fx_and_2a) {set_opt3_pair(arg, cdar(arg2p)); return(fx_or_and_2a);} + if (fx_proc(arg2p) == fx_and_3a) {set_opt3_pair(arg, cdar(arg2p)); return(fx_or_and_3a);} + if ((fx_proc(arg2p) == fx_not_is_symbol_s) && (fx_proc(arg2p) == fx_is_keyword_s) && (cadr(cadadr(arg)) == cadar(arg2p))) + { + /* (or (not (symbol? body)) (keyword? body)) */ + set_opt3_sym(arg, cadar(arg2p)); + return(fx_not_symbol_or_keyword); + } + return(fx_or_2a); + } + + case HOP_SAFE_C_S: + if (is_unchanged_global(head)) /* mus-copy would work here but in tgen (for example) it's loading generators.scm with local mus-copy methods */ + { + uint8_t typ; + if (head == sc->cdr_symbol) return(fx_cdr_s); + if (head == sc->car_symbol) return(fx_car_s); + if (head == sc->cadr_symbol) return(fx_cadr_s); + if (head == sc->cddr_symbol) return(fx_cddr_s); + if (head == sc->is_null_symbol) return(fx_is_null_s); + if (head == sc->is_pair_symbol) return(fx_is_pair_s); + if (head == sc->is_symbol_symbol) return(fx_is_symbol_s); + if (head == sc->is_eof_object_symbol) return(fx_is_eof_s); + if (head == sc->is_integer_symbol) return(fx_is_integer_s); + if (head == sc->is_string_symbol) return(fx_is_string_s); + if (head == sc->not_symbol) return(fx_not_s); + if (head == sc->is_proper_list_symbol) return(fx_is_proper_list_s); + if (head == sc->is_vector_symbol) return(fx_is_vector_s); + if (head == sc->is_keyword_symbol) return(fx_is_keyword_s); + if (head == sc->is_procedure_symbol) return(fx_is_procedure_s); + if (head == sc->length_symbol) return(fx_length_s); + /* not read_char here... */ + typ = symbol_type(head); + 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 (is_global(c_function_name_to_symbol(sc, global_value(head)))) + { + s7_p_p_t func = s7_p_p_function(global_value(head)); + if (func) + { + set_opt2_direct(cdr(arg), func); + if (func == real_part_p_p) return(fx_real_part_s); + if (func == imag_part_p_p) return(fx_imag_part_s); + if (func == iterate_p_p) return(fx_iterate_s); + if (func == car_p_p) return(fx_car_s); /* can happen if (define var-name car) etc */ + return((is_defined_global(cadr(arg))) ? fx_c_g_direct : fx_c_s_direct); + }}} + return((is_defined_global(cadr(arg))) ? fx_c_g : fx_c_s); + + case HOP_SAFE_C_SS: + { + s7_function func = fn_proc(arg); + if (func == g_cons) return(fx_cons_ss); + if (fx_matches(head, sc->num_eq_symbol)) return(fx_num_eq_ss); + if (func == g_geq_2) return(fx_geq_ss); + if (func == g_greater_2) return(fx_gt_ss); + if (func == g_leq_2) return(fx_leq_ss); + if (func == g_less_2) return((is_defined_global(caddr(arg))) ? fx_lt_sg : fx_lt_ss); + if ((fx_matches(head, sc->multiply_symbol)) && (cadr(arg) == caddr(arg))) return(fx_sqr_s); + if (func == g_is_eq) return(fx_is_eq_ss); + if (func == g_multiply_2) return(fx_multiply_ss); + if (func == g_add_2) return(fx_add_ss); + if (func == g_subtract_2) return(fx_subtract_ss); + if (func == g_hash_table_ref_2) return(fx_hash_table_ref_ss); + + if (is_global_and_has_func(head, s7_p_pp_function)) + { + if (head == sc->assq_symbol) return(fx_assq_ss); + if (head == sc->memq_symbol) return(fx_memq_ss); + if (head == sc->vector_ref_symbol) return(fx_vref_ss); + if (head == sc->string_ref_symbol) return(fx_sref_ss); + set_opt3_direct(cdr(arg), s7_p_pp_function(global_value(head))); + 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); /* it is no faster here to divide out the big list cases!? */ + return((fn_proc(arg) == g_vector) ? fx_vector_ns : fx_c_ns); + + case HOP_SAFE_C_opSq_S: + if ((is_global_and_has_func(head, s7_p_pp_function)) && + (is_global_and_has_func(caadr(arg), s7_p_p_function))) + { + set_opt2_direct(cdr(arg), s7_p_pp_function(global_value(head))); + set_opt3_direct(cdr(arg), s7_p_p_function(global_value(caadr(arg)))); + return(((head == sc->cons_symbol) && (caadr(arg) == sc->car_symbol)) ? fx_cons_car_s_s : fx_c_opsq_s_direct); + } + return(fx_c_opsq_s); - /* logand */ - func= set_function_chooser (sc->logand_symbol, logand_chooser); - sc->logand_2= - make_function_with_class (sc, func, "logand", g_logand_2, 2, 0, false); - sc->logand_ii= - make_function_with_class (sc, func, "logand", g_logand_ii, 2, 0, false); + case HOP_SAFE_C_SSS: + if ((fn_proc(arg) == g_less) && (is_defined_global(cadr(arg))) && (is_defined_global(cadddr(arg)))) return(fx_lt_gsg); + if (is_global_and_has_func(head, s7_p_ppp_function)) + { + set_opt3_direct(cdr(arg), s7_p_ppp_function(global_value(head))); + return(fx_c_sss_direct); + } + return(fx_c_sss); - /* logxor */ - func= set_function_chooser (sc->logxor_symbol, logxor_chooser); - sc->logxor_2= - make_function_with_class (sc, func, "logxor", g_logxor_2, 2, 0, false); + case HOP_SAFE_C_SSA: + if (is_global_and_has_func(head, s7_p_ppp_function)) + { + set_opt2_direct(cdr(arg), s7_p_ppp_function(global_value(head))); + return(fx_c_ssa_direct); + } + return(fx_c_ssa); - /* ash */ - func = set_function_chooser (sc->ash_symbol, ash_chooser); - sc->ash_ii= make_function_with_class (sc, func, "ash", g_ash_ii, 2, 0, false); - sc->ash_ic= make_function_with_class (sc, func, "ash", g_ash_ic, 2, 0, false); + case HOP_SAFE_C_SCS: + if (is_global_and_has_func(head, s7_p_ppp_function)) + { + set_opt3_direct(cdr(arg), s7_p_ppp_function(global_value(head))); + 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(sc, cadr(arg))) || (is_unquoted_pair(sc, caddr(arg))) || (is_unquoted_pair(sc, cadddr(arg)))) return(fx_c_aaa); + return(fx_c_3g); + + case HOP_SAFE_C_4A: + set_opt3_pair(arg, cdddr(arg)); + for (s7_pointer p = cdr(arg); is_pair(p); p = cdr(p)) + if (is_unquoted_pair(sc, car(p))) + return(fx_c_4a); + return(fx_c_4g); /* fx_c_ssaa doesn't save much */ + + case HOP_SAFE_C_S_opSSq: + { + const 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(head, s7_p_pp_function)) && + (is_global_and_has_func(car(s2), s7_p_pp_function))) + { + const s7_pointer arg1p = cdr(arg); + set_opt2_direct(arg1p, s7_p_pp_function(global_value(head))); + set_opt3_direct(arg1p, s7_p_pp_function(global_value(car(s2)))); + if (opt3_direct(arg1p) == (s7_pointer)add_p_pp) + set_opt3_direct(arg1p, add_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)subtract_p_pp) + set_opt3_direct(arg1p, subtract_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)multiply_p_pp) + set_opt3_direct(arg1p, multiply_p_pp_wrapped); + set_opt3_pair(arg, cdr(s2)); + if (car(s2) == sc->vector_ref_symbol) + { + if (head == sc->geq_symbol) return(fx_geq_s_vref); /* ? */ + if (head == sc->is_eq_symbol) return(fx_is_eq_s_vref); /* ? */ + if (head == sc->hash_table_ref_symbol) return(fx_href_s_vref); /* tbig */ + if (head == sc->let_ref_symbol) return(fx_lref_s_vref); + if ((is_defined_global(cadr(arg))) && (is_defined_global(cadr(s2))) && (head == sc->vector_ref_symbol)) return(fx_vref_g_vref_gs); + } + if ((head == sc->vector_ref_symbol) && (car(s2) == sc->add_symbol)) return(fx_vref_s_add); /* ~b */ + return(fx_c_s_opssq_direct); + } + return(fx_c_s_opssq); + } + + case HOP_SAFE_C_opSSq_S: + if ((is_global_and_has_func(head, s7_p_pp_function)) && + (is_global_and_has_func(caadr(arg), s7_p_pp_function))) + { + /* op_c_opgsq_t */ + const s7_pointer arg1p = cdr(arg), arg1 = cadr(arg); + set_opt2_direct(arg1p, s7_p_pp_function(global_value(head))); + set_opt3_direct(arg1p, s7_p_pp_function(global_value(caar(arg1p)))); + if (opt3_direct(arg1p) == (s7_pointer)add_p_pp) + set_opt3_direct(arg1p, add_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)subtract_p_pp) + set_opt3_direct(arg1p, subtract_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)multiply_p_pp) + set_opt3_direct(arg1p, multiply_p_pp_wrapped); + set_opt3_pair(arg, cdar(arg1p)); + if (car(arg1) == sc->vector_ref_symbol) + { + if (head == sc->gt_symbol) return(fx_gt_vref_s); /* ? */ + if (head == sc->vector_ref_symbol) return(fx_vref_vref_ss_s); /* b */ + } + if (head == sc->add_symbol) + { + if ((car(arg1) == sc->multiply_symbol) && (cadr(arg1) == caddr(arg1))) return(fx_add_sqr_s); /* (* s s) */ + if (car(arg1) == sc->subtract_symbol) return(fx_add_sub_s); + } + if ((head == sc->cons_symbol) && (car(arg1) == sc->cons_symbol)) return(fx_cons_cons_s); + /* also div(sub)[2] mul(div) */ + return(((head == sc->gt_symbol) && (car(arg1) == sc->add_symbol)) ? fx_gt_add_s : + (((head == sc->add_symbol) && (car(arg1) == sc->multiply_symbol)) ? fx_add_mul_opssq_s : fx_c_opssq_s_direct)); + } + return(fx_c_opssq_s); + + case HOP_SAFE_C_opSSq_opSSq: + { + const s7_pointer arg1 = cadr(arg), arg2 = caddr(arg); + set_opt3_pair(arg, cdr(arg2)); + if ((fx_matches(car(arg1), sc->multiply_symbol)) && (car(arg2) == sc->multiply_symbol)) + { + set_opt1_pair(cdr(arg), cdr(arg1)); + if (head == sc->subtract_symbol) return(fx_sub_mul_mul); + if (head == sc->add_symbol) + return(((cadr(arg1) == caddr(arg1)) && (cadr(arg2) == caddr(arg2))) ? fx_add_sqr_sqr : fx_add_mul_mul); + } + if ((fx_matches(car(arg1), sc->subtract_symbol)) && (car(arg2) == sc->subtract_symbol)) + { + set_opt1_pair(cdr(arg), cdr(arg1)); + if (head == sc->multiply_symbol) return(fx_mul_sub_sub); + if (head == sc->lt_symbol) return(fx_lt_sub2); + } + if ((fx_matches(head, sc->subtract_symbol)) && + (fx_matches(car(arg1), sc->vector_ref_symbol)) && + (car(arg2) == sc->vector_ref_symbol) && + (cadr(arg1) == cadr(arg2))) + { + 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))) + { + const s7_pointer arg_sym = cadadr(arg), arg_head = caadr(arg); + if (fx_matches(head, sc->is_pair_symbol)) + { + if (arg_head == sc->car_symbol) {set_opt3_sym(arg, arg_sym); return(fx_is_pair_car_s);} /* (pair? ...) is ok, so loc can be sym? 7 in lg */ + if (arg_head == sc->cdr_symbol) {set_opt3_sym(arg, arg_sym); return(fx_is_pair_cdr_s);} + if (arg_head == sc->cadr_symbol) {set_opt3_sym(arg, arg_sym); return(fx_is_pair_cadr_s);} + if (arg_head == sc->cddr_symbol) {set_opt3_sym(arg, arg_sym); return(fx_is_pair_cddr_s);} + } + if (fx_matches(head, sc->is_null_symbol)) + { + if (arg_head == sc->cdr_symbol) {set_opt3_sym(arg, arg_sym); return(fx_is_null_cdr_s);} + if (arg_head == sc->cadr_symbol) {set_opt3_sym(arg, arg_sym); return(fx_is_null_cadr_s);} + if (arg_head == sc->cddr_symbol) {set_opt3_sym(arg, arg_sym); return(fx_is_null_cddr_s);} + } + if ((fx_matches(head, sc->is_symbol_symbol)) && + (caadr(arg) == sc->cadr_symbol)) + {set_opt3_sym(arg, arg_sym); return(fx_is_symbol_cadr_s);} + + if (fx_matches(head, sc->not_symbol)) + { + if (arg_head == sc->is_pair_symbol) {set_opt3_sym(arg, arg_sym); return(fx_not_is_pair_s);} + if (arg_head == sc->is_null_symbol) {set_opt3_sym(arg, arg_sym); return(fx_not_is_null_s);} + if (arg_head == sc->is_symbol_symbol) {set_opt3_sym(arg, arg_sym); return(fx_not_is_symbol_s);} + return(fx_not_opsq); + } + if ((fx_matches(head, sc->floor_symbol)) && (arg_head == sc->sqrt_symbol)) + {set_opt3_sym(arg, arg_sym); return(fx_floor_sqrt_s);} + } + if (is_unchanged_global(head)) /* (? (op arg)) where (op arg) might return a let with a ? method etc */ + { /* other possibility: fx_c_a */ + const uint8_t typ = symbol_type(head); + if (typ > 0) /* h_safe_c here so the type checker isn't shadowed */ + { + set_opt3_sym(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_opt3_sym(arg, cadadr(arg)); + return(fx_c_car_s); + } + if (fx_matches(caadr(arg), sc->cdr_symbol)) + { + set_opt3_sym(arg, cadadr(arg)); + return(fx_c_cdr_s); + } + return(fx_c_opsq); - /* random */ - func= set_function_chooser (sc->random_symbol, random_chooser); - sc->random_1= - make_function_with_class (sc, func, "random", g_random_1, 1, 0, false); - sc->random_i= - make_function_with_class (sc, func, "random", g_random_i, 1, 0, false); - sc->random_f= - make_function_with_class (sc, func, "random", g_random_f, 1, 0, false); + case HOP_SAFE_C_SC: + if (is_unchanged_global(head)) + { + const s7_pointer arg2 = caddr(arg); + if (head == sc->add_symbol) + { + if (is_t_real(arg2)) return(fx_add_sf); + if (is_t_integer(arg2)) return((integer(arg2) == 1) ? fx_add_s1 : fx_add_si); + } + if (head == sc->subtract_symbol) + { + if (is_t_real(arg2)) return(fx_subtract_sf); + if (is_t_integer(arg2)) return((integer(arg2) == 1) ? fx_subtract_s1 : fx_subtract_si); + } + if (head == sc->multiply_symbol) + { + if (is_t_real(arg2)) return(fx_multiply_sf); + if (is_t_integer(arg2)) return(fx_multiply_si); + } + if ((fn_proc(arg) == g_memq_2) && (is_pair(arg2))) return(fx_memq_sq_2); + if ((fn_proc(arg) == g_is_eq) && (!is_unspecified(arg2))) return(fx_is_eq_sc); + + if ((is_t_integer(arg2)) && (s7_p_pi_function(global_value(head)))) + { + if (head == sc->num_eq_symbol) return((integer(arg2) == 0) ? fx_num_eq_s0 : fx_num_eq_si); + if (head == sc->lt_symbol) return(fx_lt_si); + if (head == sc->leq_symbol) return(fx_leq_si); + if (head == sc->gt_symbol) return(fx_gt_si); + if (head == sc->geq_symbol) return(fx_geq_si); + set_opt3_direct(cdr(arg), s7_p_pi_function(global_value(head))); + return(fx_c_si_direct); + } + if ((is_t_real(arg2)) && (real(arg2) == 0.0) && (head == sc->num_eq_symbol)) return(fx_num_eq_s0f); + if ((s7_p_pp_function(global_value(head))) && (fn_proc(arg) != g_divide_by_2)) + { + if (head == sc->memq_symbol) + { + if ((is_pair(arg2)) && (is_proper_list_3(sc, cadr(arg2)))) return(fx_memq_sc_3); + return(fx_memq_sc); + } + if ((head == sc->char_eq_symbol) && (is_character(arg2))) return(fx_char_eq_sc); /* maybe fx_char_eq_newline */ + if (head == sc->lt_symbol) return(fx_lt_sc); /* integer case handled above */ + if (head == sc->leq_symbol) return(fx_leq_sc); + if (head == sc->gt_symbol) return(fx_gt_sc); + if (head == sc->geq_symbol) return(fx_geq_sc); + if (head == sc->list_symbol) return(fx_list_sc); + set_opt3_direct(cdr(arg), s7_p_pp_function(global_value(head))); + return(fx_c_sc_direct); + }} + return(fx_c_sc); + + case HOP_SAFE_C_CS: + if (is_unchanged_global(head)) + { + const s7_pointer arg1 = cadr(arg), arg2 = caddr(arg); + if (head == sc->cons_symbol) return(fx_cons_cs); + if ((head == sc->add_symbol) && (is_t_real(arg1))) return(fx_add_fs); + if ((head == sc->subtract_symbol) && (is_t_real(arg1))) return(fx_subtract_fs); + if ((head == sc->num_eq_symbol) && (arg1 == int_zero)) + { + set_opt3_sym(arg, arg2); /* opt3_location is in use, but the num_eq is ok, so only symbol might care about that info? */ + return(fx_num_eq_0s); + } + if (head == sc->multiply_symbol) + { + if (is_t_real(arg1)) return(fx_multiply_fs); + if (is_t_integer(arg1)) return(fx_multiply_is); + }} + return(fx_c_cs); + + case HOP_SAFE_C_S_opSq: + { + const s7_pointer arg1p = cdr(arg), arg2 = caddr(arg); + if (fx_matches(car(arg2), sc->car_symbol)) + { + set_opt2_sym(arg1p, cadr(arg2)); + if (fx_matches(head, sc->hash_table_ref_symbol)) return(fx_hash_table_ref_car); + return(fx_matches(head, sc->add_symbol) ? fx_add_s_car_s : fx_c_s_car_s); + } + if ((is_global_and_has_func(head, s7_p_pp_function)) && + (is_global_and_has_func(car(arg2), s7_p_p_function))) + { + if ((head == sc->cons_symbol) && (car(arg2) == sc->cdr_symbol)) {set_opt2_sym(cdr(arg), cadr(arg2)); return(fx_cons_s_cdr_s);} + set_opt1_sym(arg1p, cadr(arg2)); + set_opt2_direct(arg1p, s7_p_pp_function(global_value(head))); + set_opt3_direct(arg1p, s7_p_p_function(global_value(car(arg2)))); /* arg opt3 only location, but no change in callgrind */ + if (opt3_direct(arg1p) == (s7_pointer)random_p_p) set_opt3_direct(cdr(arg), random_p_p_wrapped); + return(fx_c_s_opsq_direct); + }} + return(fx_c_s_opsq); + + case HOP_SAFE_C_C_opSq: + if (is_global_and_has_func(head, s7_p_pp_function)) + { + const s7_pointer arg2 = caddr(arg); + if (is_global_and_has_func(car(arg2), s7_p_p_function)) + { + set_opt2_direct(cdr(arg), s7_p_pp_function(global_value(head))); + set_opt3_direct(cdr(arg), 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(head)) + { + const s7_pointer arg1p = cdr(arg), arg1 = cadr(arg), arg2 = caddr(arg); + if ((head == sc->memq_symbol) && + (fx_matches(car(arg1), sc->car_symbol)) && + (is_proper_quote(sc, arg2)) && + (is_pair(cadr(arg2)))) + return((s7_list_length(sc, opt2_con(arg1p)) == 2) ? fx_memq_car_s_2 : fx_memq_car_s); + + if (head == sc->is_eq_symbol) + { + if (((fx_matches(car(arg1), sc->car_symbol)) || (fx_matches(car(arg1), sc->caar_symbol))) && + (is_proper_quote(sc, arg2))) + { + set_opt3_sym(arg1p, cadr(arg1)); + set_opt2_con(arg1p, cadr(arg2)); + return((car(arg1) == sc->car_symbol) ? fx_is_eq_car_sq : fx_is_eq_caar_sq); + }} + if (((head == sc->lt_symbol) || (head == sc->num_eq_symbol)) && + (is_t_integer(arg2)) && + (fx_matches(car(arg1), sc->length_symbol))) + { + set_opt3_sym(arg1p, cadr(arg1)); + set_opt3_con(arg, arg2); + return((head == 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(head, 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(head, sc->not_symbol)) + { + if (fn_proc(cadr(arg)) == g_is_eq) + { + const s7_pointer arg1 = cadr(arg); + set_opt3_sym(arg, cadr(arg1)); + set_opt3_con(cdr(arg), (is_pair(caddr(arg1))) ? cadaddr(arg1) : caddr(arg1)); + return(fx_not_is_eq_sq); + } + return(fx_not_opscq); + } + return(fx_c_opscq); - /* defined? */ - func= set_function_chooser (sc->is_defined_symbol, is_defined_chooser); - sc->is_defined_in_rootlet= make_function_with_class ( - sc, func, "defined?", g_is_defined_in_rootlet, 2, 0, false); - sc->is_defined_in_unlet= make_function_with_class ( - sc, func, "defined?", g_is_defined_in_unlet, 2, 0, false); + case HOP_SAFE_C_S_opSCq: + if (is_global_and_has_func(head, s7_p_pp_function)) + { + const s7_pointer arg1p = cdr(arg), arg2 = caddr(arg); + if ((is_global_and_has_func(car(arg2), s7_p_pi_function)) && + (is_t_integer(caddr(arg2)))) + { + set_opt2_direct(arg1p, s7_p_pp_function(global_value(head))); + set_opt3_direct(arg1p, s7_p_pi_function(global_value(car(arg2)))); + set_opt3_sym(arg, cadr(arg2)); + set_opt1_con(arg1p, caddr(arg2)); + if (head == 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 ((head == 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(arg1p, s7_p_pp_function(global_value(head))); + set_opt3_direct(arg1p, s7_p_pp_function(global_value(car(arg2)))); + set_opt3_sym(arg, cadr(arg2)); + if (opt3_direct(arg1p) == (s7_pointer)add_p_pp) + set_opt3_direct(arg1p, add_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)subtract_p_pp) + set_opt3_direct(arg1p, subtract_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)multiply_p_pp) + set_opt3_direct(arg1p, multiply_p_pp_wrapped); + set_opt1_con(arg1p, (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(head, 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(head, s7_p_p_function)) && + (is_global_and_has_func(caadr(arg), s7_p_pp_function))) + { + const s7_pointer arg1p = cdr(arg); + set_opt2_direct(arg1p, s7_p_p_function(global_value(head))); + set_opt3_direct(arg1p, s7_p_pp_function(global_value(caar(arg1p)))); + if (opt3_direct(arg1p) == (s7_pointer)add_p_pp) + set_opt3_direct(arg1p, add_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)subtract_p_pp) + set_opt3_direct(arg1p, subtract_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)multiply_p_pp) + set_opt3_direct(arg1p, multiply_p_pp_wrapped); + return(fx_c_opssq_direct); + } + return(fx_c_opssq); + + case HOP_SAFE_C_C_opSSq: + { + const s7_pointer arg1p = cdr(arg), s2 = caddr(arg); + if ((fx_matches(car(s2), sc->multiply_symbol)) && (cadr(s2) == caddr(s2))) + return(fx_c_c_sqr); + if ((is_small_real(car(arg1p))) && + (is_global_and_has_func(head, s7_p_dd_function)) && + (is_global_and_has_func(car(s2), s7_d_pd_function))) /* not * currently (this is for clm) */ + { + set_opt3_direct(arg1p, s7_d_pd_function(global_value(car(s2)))); + set_opt2_direct(arg1p, s7_p_dd_function(global_value(head))); + set_opt3_sym(arg, cadr(s2)); + set_opt1_sym(arg1p, caddr(s2)); + return(fx_c_nc_opssq_direct); + } + if ((is_global_and_has_func(head, s7_p_pp_function)) && + (is_global_and_has_func(car(s2), s7_p_pp_function))) + { + set_opt2_direct(arg1p, s7_p_pp_function(global_value(head))); + set_opt3_direct(arg1p, s7_p_pp_function(global_value(caaddr(arg)))); + if (opt3_direct(arg1p) == (s7_pointer)add_p_pp) + set_opt3_direct(arg1p, add_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)subtract_p_pp) + set_opt3_direct(arg1p, subtract_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)multiply_p_pp) + set_opt3_direct(arg1p, multiply_p_pp_wrapped); + set_opt3_sym(arg, cadr(s2)); + set_opt1_sym(arg1p, caddr(s2)); + if ((is_t_real(car(arg1p))) && (head == car(s2)) && (head == 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: + { + const s7_pointer arg1p = cdr(arg), arg1 = cadr(arg), arg2 = caddr(arg); + if ((is_global_and_has_func(head, s7_p_pp_function)) && + (is_global_and_has_func(car(arg1), s7_p_p_function)) && + (is_global_and_has_func(car(arg2), s7_p_p_function))) + { + set_opt3_direct(arg, s7_p_pp_function(global_value(head))); + set_opt2_direct(arg1p, s7_p_p_function(global_value(car(arg1)))); + set_opt3_direct(arg1p, s7_p_p_function(global_value(car(arg2)))); + if ((car(arg1) == car(arg2)) && ((car(arg1) == sc->cdr_symbol) || (car(arg1) == sc->car_symbol))) + { + set_opt1_sym(arg1p, cadr(arg1)); + set_opt2_sym(arg1p, cadr(arg2)); /* usable because we know func is cdr|car */ + return((car(arg1) == sc->cdr_symbol) ? fx_cdr_s_cdr_s : fx_car_s_car_s); + } + set_opt1_sym(arg1p, cadr(arg2)); /* 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(head, sc->not_symbol)) ? fx_not_op_s_opsqq : fx_c_op_s_opsqq); + + case HOP_SAFE_C_op_opSSqq_S: + { + const s7_pointer arg1p = cdr(arg), arg1 = cadr(arg); + if ((is_global_and_has_func(head, s7_p_pp_function)) && + (is_global_and_has_func(car(arg1), s7_p_p_function)) && + (is_global_and_has_func(caadr(arg1), s7_p_pp_function))) + { + set_opt3_direct(arg, s7_p_pp_function(global_value(head))); + set_opt2_direct(arg1p, s7_p_p_function(global_value(car(arg1)))); + set_opt3_direct(arg1p, s7_p_pp_function(global_value(caadr(arg1)))); + if (opt3_direct(arg1p) == (s7_pointer)add_p_pp) + set_opt3_direct(arg1p, add_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)subtract_p_pp) + set_opt3_direct(arg1p, subtract_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)multiply_p_pp) + set_opt3_direct(arg1p, multiply_p_pp_wrapped); + + return(fx_c_op_opssqq_s_direct); + }} + return(fx_c_op_opssqq_s); + + case HOP_SAFE_C_A: + if (fx_matches(head, 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(head, s7_p_p_function)) + { + set_opt3_direct(arg, s7_p_p_function(global_value(head))); + if ((head == sc->sqrt_symbol) && (fx_proc(cdr(arg)) == fx_add_sqr_sqr)) + { + set_opt1_sym(cdr(arg), cadr(cadr(cadr(arg)))); /* opt1_cfunc(arg) is set */ + set_opt3_sym(cdr(arg), cadr(caddr(cadr(arg)))); /* opt3(arg) is sqrt_p_p but used to be clobbered anyway */ + return(fx_hypot); + } + return(fx_c_a_direct); + } + return(fx_c_a); - /* char=? */ - func= set_function_chooser (sc->char_eq_symbol, char_equal_chooser); - sc->simple_char_eq = make_function_with_class (sc, func, "char=?", - g_simple_char_eq, 2, 0, false); - sc->simple_char_eq1= make_function_with_class ( - sc, func, "char=?", g_simple_char_eq1, 2, 0, false); - sc->simple_char_eq2= make_function_with_class ( - sc, func, "char=?", g_simple_char_eq2, 2, 0, false); - sc->char_equal_2= make_function_with_class (sc, func, "char=?", - g_char_equal_2, 2, 0, false); + case HOP_SAFE_C_AC: + if (fn_proc(arg) == g_cons) return(fx_cons_ac); + if (fx_matches(head, sc->is_eq_symbol)) return(fx_is_eq_ac); + if (is_global_and_has_func(head, s7_p_pp_function)) + { + const s7_pointer arg1p = cdr(arg); + set_opt3_direct(arg1p, s7_p_pp_function(global_value(head))); + if ((opt3_direct(arg1p) == (s7_pointer)string_ref_p_pp) && (is_t_integer(caddr(arg))) && (integer(caddr(arg)) == 0)) + set_opt3_direct(arg1p, string_ref_p_p0); + if (opt3_direct(arg1p) == (s7_pointer)memq_p_pp) + { + if (fn_proc(arg) == g_memq_2) + set_opt3_direct(arg1p, memq_2_p_pp); + else + if ((is_pair(caddr(arg))) && (is_proper_list_3(sc, cadaddr(arg)))) + set_opt3_direct(arg1p, memq_3_p_pp); + else + if (fn_proc(arg) == g_memq_4) + set_opt3_direct(arg1p, memq_4_p_pp); /* this does not parallel 2 and 3 above (sigh) */ + } + else + if ((is_t_real(opt3_con(arg))) && (opt3_direct(arg1p) == (s7_pointer)lt_p_pp)) + return(fx_lt_ad); + if ((is_t_integer(opt3_con(arg))) && (s7_p_pi_function(global_value(head)))) + { + set_opt3_direct(arg1p, s7_p_pi_function(global_value(head))); + if (integer(opt3_con(arg)) == 1) + { + if (opt3_direct(arg1p) == (s7_pointer)g_sub_xi) + return(fx_sub_a1); + else + if (opt3_direct(arg1p) == (s7_pointer)add_p_pi) + return(fx_add_a1); + } + return(fx_c_ai_direct); + } + return(fx_c_ac_direct); + } + return(fx_c_ac); - /* char>? */ - func= set_function_chooser (sc->char_gt_symbol, char_greater_chooser); - sc->char_greater_2= make_function_with_class (sc, func, "char>?", - g_char_greater_2, 2, 0, false); + case HOP_SAFE_C_CA: - /* charchar_lt_symbol, char_less_chooser); - sc->char_less_2= - make_function_with_class (sc, func, "charread_char_symbol, read_char_chooser); - sc->read_char_1= make_function_with_class (sc, func, "read-char", - g_read_char_1, 1, 0, false); + case HOP_SAFE_C_SA: + if ((fx_proc(cddr(arg)) == fx_random_i)) set_fx_direct(cddr(arg), fx_random_i_wrapped); + 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(head, s7_p_pp_function)) + { + set_opt3_direct(cdr(arg), s7_p_pp_function(global_value(head))); + return((fn_proc(arg) == g_cons) ? fx_cons_sa : fx_c_sa_direct); + } + return(fx_c_sa); - /* char-position */ - func= set_function_chooser (sc->char_position_symbol, char_position_chooser); - sc->char_position_csi= make_function_with_class ( - sc, func, "char-position", g_char_position_csi, 2, 1, false); + case HOP_SAFE_C_AS: + if (fn_proc(arg) == g_add_2) return(fx_add_as); + if (is_global_and_has_func(head, s7_p_pp_function)) + { + set_opt3_direct(cdr(arg), s7_p_pp_function(global_value(head))); + 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); + 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_na : 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: + { + const s7_pointer body = car(closure_body(opt1_lambda(arg))); + const s7_pointer par = car(closure_pars(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) == par)) /* (lambda (x) (and (pair? x) (pair? (cdr x)))) */ + 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_cdr_let_ref) && + (cadadr(body) == par)) /* (lambda (v) (cdr v)) -- many cases in lint.scm */ + { + set_opt2_sym(cdr(arg), cadaddr(body)); + return(fx_cdr_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: + { + const 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); + return(fx_function[optimize_op(arg)]); + + case OP_IMPLICIT_STARLET_REF_S: + if (opt3_int(arg) == sl_print_length) return(fx_implicit_starlet_print_length); + if (opt3_int(arg) == sl_safety) return(fx_implicit_starlet_safety); + return(fx_implicit_starlet_ref_s); + + case HOP_C: + if ((is_unchanged_global(head)) && (head == sc->curlet_symbol)) return(fx_curlet); + /* fall through */ + + default: + /* if ((S7_DEBUGGING) && (!fx_function[optimize_op(arg)]) && (is_h_optimized(arg))) fprintf(stderr, "fx_choose %s %s\n", op_names[optimize_op(arg)], display(arg)); */ + /* this includes unsafe c funcs (hop_c_a) and p-arg safe funcs (hop_safe_c_p) -- name needs "safe" and no "p" */ + return(fx_function[optimize_op(arg)]); + }} /* is_optimized */ + + if (is_safe_quote(sc, car(arg))) + { + check_quote(sc, arg); + return(fx_q); + } + return(NULL); +} - /* string=? */ - func= set_function_chooser (sc->string_eq_symbol, string_equal_chooser); - sc->string_equal_2 = make_function_with_class (sc, func, "string=?", - g_string_equal_2, 2, 0, false); - sc->string_equal_2c= make_function_with_class ( - sc, func, "string=?", g_string_equal_2c, 2, 0, false); +#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); +} - /* substring */ - /* sc->substring_uncopied = s7_make_safe_function(sc, "substring", - * g_substring_uncopied, 1, 2, false, NULL); */ /* now exported to Scheme 28-May-24 */ - sc->substring_uncopied= global_value (sc->substring_uncopied_symbol); - s7_function_set_class (sc, sc->substring_uncopied, - global_value (sc->substring_symbol)); +static bool o_var_ok(const s7_pointer p, const s7_pointer var1, const s7_pointer var2, const s7_pointer var3) {return((p != var1) && (p != var2) && (p != var3));} - /* string>? */ - func= set_function_chooser (sc->string_gt_symbol, string_greater_chooser); - sc->string_greater_2= make_function_with_class ( - sc, func, "string>?", g_string_greater_2, 2, 0, false); +static bool fx_tree_out(s7_scheme *sc, s7_pointer tree, const s7_pointer var1, const s7_pointer var2, const s7_pointer var3, bool unused_more_vars) +{ + const s7_pointer p = car(tree); + const s7_function pfunc = fx_proc(tree); + if (is_symbol(p)) + { + if ((pfunc == fx_s) || (pfunc == fx_o)) + { + 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)); + } + return(false); + } + if ((is_pair(p)) && (is_pair(cdr(p)))) + { + const s7_pointer arg1 = cadr(p); + if (arg1 == var1) + { + if ((pfunc == fx_c_s) || (pfunc == fx_c_o)) return(with_fx(tree, fx_c_T)); /* fx_c_T_direct got no hits */ + if ((pfunc == fx_car_s) || (pfunc == fx_car_o)) return(with_fx(tree, fx_car_T)); + if ((pfunc == fx_cdr_s) || (pfunc == fx_cdr_o)) return(with_fx(tree, fx_cdr_T)); + if (pfunc == fx_is_null_s) return(with_fx(tree, fx_is_null_T)); + if (pfunc == fx_iterate_o) return(with_fx(tree, fx_iterate_T)); + if (pfunc == fx_subtract_s1) return(with_fx(tree, fx_subtract_T1)); + if (pfunc == fx_add_s1) return(with_fx(tree, fx_add_T1)); + if (pfunc == fx_c_sca) return(with_fx(tree, fx_c_Tca)); + if ((pfunc == fx_num_eq_si) || (pfunc == fx_num_eq_s0) || (pfunc == fx_num_eq_oi)) return(with_fx(tree, fx_num_eq_Ti)); + /* if (pfunc == fx_cons_ss) return(with_fx(tree, fx_cons_Ts)); */ /* can be fooled -- there is no fx_cons_us etc -- need fx_cons_os */ + /* if (pfunc == fx_multiply_ss) return(with_fx(tree, fx_multiply_Ts)); */ /* this also can be fooled? */ + if ((pfunc == fx_c_scs_direct) && (cadddr(p) == var2)) return(with_fx(tree, fx_c_TcU_direct)); + if ((pfunc == fx_hash_table_ref_ss) && (var3 == caddr(p))) return(with_fx(tree, fx_hash_table_ref_TV)); + if ((pfunc == fx_geq_ss) && (var2 == caddr(p))) return(with_fx(tree, fx_geq_TU)); + } + else + if (arg1 == var2) + { + if (pfunc == fx_subtract_s1) return(with_fx(tree, fx_subtract_U1)); + if (pfunc == fx_add_s1) return(with_fx(tree, fx_add_U1)); + if ((pfunc == fx_car_s) || (pfunc == fx_car_o)) return(with_fx(tree, fx_car_U)); + if ((pfunc == fx_cdr_s) || (pfunc == fx_cdr_o)) return(with_fx(tree, fx_cdr_U)); + } + else + if (arg1 == var3) + { + if ((pfunc == fx_c_s) || (pfunc == fx_c_o)) return(with_fx(tree, fx_c_V)); + if (pfunc == fx_add_s1) return(with_fx(tree, fx_add_V1)); + } + else + if (is_pair(cddr(p))) + { + if (caddr(p) == var1) + { + if ((pfunc == fx_num_eq_ts) || (pfunc == fx_num_eq_to)) return(with_fx(tree, fx_num_eq_tT)); + if ((pfunc == fx_gt_ts) || (pfunc == fx_gt_to)) return(with_fx(tree, fx_gt_tT)); + if (pfunc == fx_lt_ts) return(with_fx(tree, fx_lt_tT)); + if ((pfunc == fx_geq_ts) || (pfunc == fx_geq_to)) return(with_fx(tree, fx_geq_tT)); + } + else + if (caddr(p) == var2) + { + if (pfunc == fx_c_ts) return(with_fx(tree, fx_c_tU)); + if (pfunc == fx_cons_ts) return(with_fx(tree, fx_cons_tU)); + if (pfunc == fx_c_ts_direct) return(with_fx(tree, fx_c_tU_direct)); + if (pfunc == fx_lt_ts) return(with_fx(tree, fx_lt_tU)); + if (pfunc == fx_num_eq_us) return(with_fx(tree, fx_num_eq_uU)); + if (pfunc == fx_num_eq_vs) return(with_fx(tree, fx_num_eq_vU)); + } + else + if ((pfunc == fx_add_sqr_s) && (cadr(arg1) == var1)) return(with_fx(tree, fx_add_sqr_T)); + }} + return(false); +} + +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)) || + ((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); +} - /* stringstring_lt_symbol, string_less_chooser); - sc->string_less_2= make_function_with_class (sc, func, "stringcddr_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 (pfunc == 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 (pfunc == fx_cdr_s) return(with_fx(tree, fx_cdr_u)); + if (pfunc == fx_cadr_s) return(with_fx(tree, fx_cadr_u)); + if (pfunc == fx_cddr_s) return(with_fx(tree, fx_cddr_u)); + if (pfunc == fx_car_s) return(with_fx(tree, fx_car_u)); + if (pfunc == fx_is_null_s) return(with_fx(tree, fx_is_null_u)); + if (pfunc == fx_is_type_s) return(with_fx(tree, fx_is_type_u)); + if (pfunc == fx_is_pair_s) return(with_fx(tree, fx_is_pair_u)); + if (pfunc == fx_is_symbol_s) return(with_fx(tree, fx_is_symbol_u)); + if (pfunc == fx_is_eof_s) return(with_fx(tree, fx_is_eof_u)); + return(false); + } + if (cadr(p) == var3) + { + if (pfunc == fx_cdr_s) return(with_fx(tree, fx_cdr_v)); + if (pfunc == fx_is_null_s) return(with_fx(tree, fx_is_null_v)); + if (pfunc == fx_is_pair_s) return(with_fx(tree, fx_is_pair_v)); + if (pfunc == fx_c_s) return(with_fx(tree, fx_c_v)); + if (pfunc == fx_c_s_direct) return(with_fx(tree, fx_c_v_direct)); + return(false); + } + if (!more_vars) + { + if (pfunc == fx_is_null_s) return(with_fx(tree, fx_is_null_o)); + if (pfunc == fx_car_s) return(with_fx(tree, fx_car_o)); + if (pfunc == fx_cdr_s) return(with_fx(tree, fx_cdr_o)); + if (pfunc == fx_cadr_s) return(with_fx(tree, fx_cadr_o)); + if (pfunc == fx_cddr_s) return(with_fx(tree, fx_cddr_o)); + if (pfunc == fx_iterate_s) return(with_fx(tree, fx_iterate_o)); + if (pfunc == fx_not_s) return(with_fx(tree, fx_not_o)); + if (pfunc == fx_c_s_direct) return(with_fx(tree, fx_c_o_direct)); + if (pfunc == fx_c_s) return(with_fx(tree, fx_c_o)); + } + break; - /* string */ - func= set_function_chooser (sc->string_symbol, string_chooser); - sc->string_c1= - make_function_with_class (sc, func, "string", s7i_string_c1, 1, 0, false); + case HOP_SAFE_C_SC: + if (cadr(p) == var1) + { + if ((pfunc == fx_char_eq_sc) || (fn_proc(p) == g_char_equal_2)) return(with_fx(tree, fx_char_eq_tc)); + if (pfunc == fx_c_sc) return(with_fx(tree, fx_c_tc)); + if (pfunc == 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 (pfunc == fx_leq_si) return(with_fx(tree, fx_leq_ti)); + if (pfunc == fx_gt_si) return(with_fx(tree, fx_gt_ti)); + + if (pfunc == fx_c_sc_direct) /* p_pp cases */ + { + if ((opt3_direct(cdr(p)) == (s7_pointer)s7i_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 (pfunc == 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, (opt3_direct(cdr(p)) == (s7_pointer)remainder_p_pi) ? fx_c_ti_remainder : fx_c_ti_direct)); + } + if (pfunc == fx_is_eq_sc) return(with_fx(tree, fx_is_eq_tc)); + if (pfunc == fx_add_s1) return(with_fx(tree, fx_add_t1)); + if (pfunc == fx_add_si) return(with_fx(tree, fx_add_ti)); + if (pfunc == fx_subtract_s1) return(with_fx(tree, fx_subtract_t1)); + if (pfunc == fx_subtract_si) return(with_fx(tree, fx_subtract_ti)); + if (pfunc == fx_subtract_sf) return(with_fx(tree, fx_subtract_tf)); + if (pfunc == fx_multiply_sf) return(with_fx(tree, fx_multiply_tf)); + if (pfunc == fx_multiply_si) return(with_fx(tree, fx_multiply_ti)); + if (pfunc == 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 (pfunc == fx_num_eq_si) return(with_fx(tree, fx_num_eq_ti)); + if (pfunc == fx_num_eq_s0) return(with_fx(tree, fx_num_eq_t0)); + if (pfunc == fx_memq_sc) return(with_fx(tree, fx_memq_tc)); + return(false); + } + if (cadr(p) == var2) + { + if (pfunc == fx_c_sc) return(with_fx(tree, fx_c_uc)); + if (pfunc == fx_num_eq_s0) return(with_fx(tree, fx_num_eq_u0)); + if (pfunc == fx_num_eq_si) return(with_fx(tree, fx_num_eq_ui)); + if (pfunc == fx_add_s1) return(with_fx(tree, fx_add_u1)); + if (pfunc == fx_subtract_s1) return(with_fx(tree, fx_subtract_u1)); + if (pfunc == fx_subtract_si) return(with_fx(tree, fx_subtract_ui)); + if (pfunc == fx_multiply_si) return(with_fx(tree, fx_multiply_ui)); + if (pfunc == fx_is_eq_sc) return(with_fx(tree, fx_is_eq_uc)); + if (pfunc == fx_leq_si) return(with_fx(tree, fx_leq_ui)); + if (pfunc == fx_gt_si) return(with_fx(tree, fx_gt_ui)); + return(false); + } + if (cadr(p) == var3) + { + if (pfunc == fx_num_eq_s0) return(with_fx(tree, fx_num_eq_v0)); + if (pfunc == fx_num_eq_si) return(with_fx(tree, fx_num_eq_vi)); + if (pfunc == fx_add_s1) return(with_fx(tree, fx_add_v1)); + if (pfunc == fx_subtract_s1) return(with_fx(tree, fx_subtract_v1)); + if (pfunc == fx_leq_si) return(with_fx(tree, fx_leq_vi)); + if (pfunc == fx_c_sc) return(with_fx(tree, fx_c_vc)); + return(false); + } + if (!more_vars) + { + if (pfunc == fx_num_eq_si) return(with_fx(tree, fx_num_eq_oi)); + if ((pfunc == fx_c_sc) && (o_var_ok(cadr(p), var1, var2, var3))) return(with_fx(tree, fx_c_oc)); + } + break; - /* string-append */ - func= set_function_chooser (sc->string_append_symbol, string_append_chooser); - sc->string_append_2= make_function_with_class ( - sc, func, "string-append", g_string_append_2, 2, 0, false); + 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 (pfunc == fx_multiply_is) return(with_fx(tree, fx_multiply_it)); + if (pfunc == fx_add_fs) return(with_fx(tree, fx_add_ft)); + if (pfunc == fx_c_cs) + { + if (is_global_and_has_func(car(p), s7_p_pp_function)) + { + if (fn_proc(p) == g_tree_set_memq_syms) + set_opt3_direct(cdr(p), tree_set_memq_syms_direct); + else set_opt3_direct(cdr(p), 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) && (pfunc == fx_c_cs)) return(with_fx(tree, fx_c_cu)); + break; - /* string-ref et al */ - set_function_chooser (sc->string_ref_symbol, string_substring_chooser); - set_function_chooser (sc->string_to_symbol_symbol, - string_substring_chooser); /* not string_to_number here - (not const char*??) */ - set_function_chooser (sc->string_to_keyword_symbol, string_substring_chooser); - set_function_chooser (sc->string_position_symbol, string_substring_chooser); - set_function_chooser (sc->string_geq_symbol, string_substring_chooser); - set_function_chooser (sc->string_leq_symbol, string_substring_chooser); - set_function_chooser (sc->string_copy_symbol, string_copy_chooser); - set_function_chooser (sc->eval_string_symbol, string_substring_chooser); - set_function_chooser (sc->symbol_symbol, string_substring_chooser); - set_function_chooser (sc->string_to_byte_vector_symbol, - string_substring_chooser); - /* if the function assumes a null-terminated string, substring needs to return - * a copy (which assume this?) */ + case HOP_SAFE_C_SS: + { + const s7_pointer arg1 = cadr(p), arg2 = caddr(p); + if (arg1 == var1) + { + if (pfunc == fx_c_ss) return(with_fx(tree, (arg2 == var2) ? fx_c_tu : fx_c_ts)); + if (pfunc == fx_c_ss_direct) return(with_fx(tree, (arg2 == var2) ? fx_c_tu_direct : fx_c_ts_direct)); + if (pfunc == fx_add_ss) return(with_fx(tree, (arg2 == var2) ? fx_add_tu : fx_add_ts)); + if (pfunc == fx_subtract_ss) return(with_fx(tree, (arg2 == var2) ? fx_subtract_tu : fx_subtract_ts)); + if (pfunc == fx_cons_ss) return(with_fx(tree, (arg2 == var2) ? fx_cons_tu : fx_cons_ts)); + if (arg2 == var2) + { + if (pfunc == fx_gt_ss) return(with_fx(tree, fx_gt_tu)); + if (pfunc == fx_lt_ss) return(with_fx(tree, fx_lt_tu)); + if (pfunc == fx_leq_ss) return(with_fx(tree, fx_leq_tu)); + if (pfunc == fx_geq_ss) return(with_fx(tree, fx_geq_tu)); + if (pfunc == fx_multiply_ss) return(with_fx(tree, fx_multiply_tu)); + if (pfunc == fx_num_eq_ss) return(with_fx(tree, fx_num_eq_tu)); + if (pfunc == fx_memq_ss) return(with_fx(tree, fx_memq_tu)); + } + if (pfunc == fx_multiply_ss) return(with_fx(tree, fx_multiply_ts)); + if (pfunc == fx_num_eq_ss) + { + if (arg2 == var3) return(with_fx(tree, fx_num_eq_tv)); + if (is_defined_global(arg2)) return(with_fx(tree, fx_num_eq_tg)); + if ((!more_vars) && (o_var_ok(arg2, var1, var2, var3))) return(with_fx(tree, fx_num_eq_to)); + return(with_fx(tree, fx_num_eq_ts)); + } + if (pfunc == fx_geq_ss) + { + if ((!more_vars) && (o_var_ok(arg2, var1, var2, var3))) return(with_fx(tree, fx_geq_to)); + return(with_fx(tree, fx_geq_ts)); + } + if (pfunc == fx_leq_ss) return(with_fx(tree, fx_leq_ts)); + if (pfunc == fx_lt_ss) return(with_fx(tree, fx_lt_ts)); + if (pfunc == fx_lt_sg) return(with_fx(tree, fx_lt_tg)); + if (pfunc == fx_gt_ss) + { + if (is_defined_global(arg2)) return(with_fx(tree, fx_gt_tg)); + if ((!more_vars) && (o_var_ok(arg2, var1, var2, var3))) return(with_fx(tree, fx_gt_to)); + return(with_fx(tree, fx_gt_ts)); + } + if (pfunc == fx_sqr_s) return(with_fx(tree, fx_sqr_t)); + if (pfunc == fx_is_eq_ss) + { + if (arg2 == var2) return(with_fx(tree, fx_is_eq_tu)); + if ((!more_vars) && (arg2 != var3) && (arg2 != var1)) return(with_fx(tree, fx_is_eq_to)); + return(with_fx(tree, fx_is_eq_ts)); + } + if (pfunc == fx_vref_ss) + { + if (arg2 == var2) return(with_fx(tree, fx_vref_tu)); + return(with_fx(tree, fx_vref_ts)); + }} + if (arg2 == var1) + { + if (pfunc == fx_c_ss) return(with_fx(tree, fx_c_st)); + if (pfunc == fx_c_ss_direct) {return(with_fx(tree, (is_defined_global(arg1)) ? fx_c_gt_direct : fx_c_st_direct));} + if (pfunc == fx_hash_table_ref_ss) return(with_fx(tree, fx_hash_table_ref_st)); + if (pfunc == fx_cons_ss) return(with_fx(tree, fx_cons_st)); + if (pfunc == fx_vref_ss) + { + if (is_defined_global(arg1)) return(with_fx(tree, fx_vref_gt)); + if ((!more_vars) && (arg1 != var2) && (arg1 != var3)) return(with_fx(tree, fx_vref_ot)); + return(with_fx(tree, fx_vref_st)); + } + if ((pfunc == fx_gt_ss) && (arg1 == var2)) return(with_fx(tree, fx_gt_ut)); + if ((pfunc == fx_lt_ss) && (arg1 == var2)) return(with_fx(tree, fx_lt_ut)); + if (pfunc == fx_geq_ss) + { + if ((!more_vars) && (o_var_ok(arg1, var1, var2, var3))) return(with_fx(tree, fx_geq_ot)); + return(with_fx(tree, fx_geq_st)); + }} + if (arg1 == var2) + { + if (pfunc == fx_geq_ss) return(with_fx(tree, fx_geq_us)); + if (pfunc == fx_num_eq_ss) return(with_fx(tree, (arg2 == var1) ? fx_num_eq_ut : fx_num_eq_us)); + if (pfunc == fx_add_ss) return(with_fx(tree, (arg2 == var1) ? fx_add_ut : ((arg2 == var3) ? fx_add_uv : fx_add_us))); + if (pfunc == fx_subtract_ss) return(with_fx(tree, (arg2 == var1) ? fx_subtract_ut : fx_subtract_us)); + if (arg2 == var3) return(with_fx(tree, fx_c_uv)); + } + if ((arg2 == var2) && (pfunc == fx_sref_ss)) return(with_fx(tree, fx_sref_su)); + if (arg1 == var3) + { + if (pfunc == fx_num_eq_ss) return(with_fx(tree, fx_num_eq_vs)); + if ((pfunc == fx_add_ss) && (arg2 == var2)) return(with_fx(tree, fx_add_vu)); + if (pfunc == fx_geq_ss) return(with_fx(tree, ((!more_vars) && (o_var_ok(arg2, var1, var2, var3))) ? fx_geq_vo : 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 - set_function_chooser (sc->string_length_symbol, string_substring_chooser); - set_function_chooser (sc->string_to_list_symbol, string_substring_chooser); + ((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_sref_t_last)); + return(with_fx(tree, fx_c_ta)); + } + if (cadr(p) == var2) return(with_fx(tree, (pfunc == fx_c_sa_direct) ? fx_c_ua_direct : fx_c_ua)); + break; - /* also: directory->list substring with-input-from-file with-input-from-string - * with-output-to-file open-output-file open-input-file system load getenv - * file-mtime gensym directory? call-with-output-file delete-file - * call-with-input-file call-with-input-string open-input-string length et al? - */ + case HOP_SAFE_C_SCS: + if (cadr(p) == var1) + { + if (pfunc == fx_c_scs) return(with_fx(tree, fx_c_tcs)); + if (pfunc == fx_c_scs_direct) return(with_fx(tree, (cadddr(p) == var2) ? fx_c_tcu_direct : fx_c_tcs_direct)); + } + break; - /* symbol->string */ - func = global_value (sc->symbol_to_string_symbol); - sc->symbol_to_string_uncopied= s7_make_safe_function ( - sc, "symbol->string", g_symbol_to_string_uncopied, 1, 0, false, NULL); - s7_function_set_class (sc, sc->symbol_to_string_uncopied, func); + case HOP_SAFE_C_SSC: + if ((cadr(p) == var1) && (caddr(p) == var2)) return(with_fx(tree, fx_c_tuc)); + break; - /* symbol->value */ - func= global_value (sc->symbol_to_value_symbol); - set_function_chooser (sc->symbol_to_value_symbol, symbol_to_value_chooser); - sc->sv_unlet_ref= make_function_with_class (sc, func, "symbol->value", - g_sv_unlet_ref, 1, 1, false); + case HOP_SAFE_C_CSS: + if ((caddr(p) == var1) && (cadddr(p) == var3)) return(with_fx(tree, fx_c_ctv)); + break; - /* display */ - func= set_function_chooser (sc->display_symbol, display_chooser); - sc->display_f= - make_function_with_class (sc, func, "display", g_display_f, 2, 0, false); - sc->display_2= - make_function_with_class (sc, func, "display", g_display_2, 2, 0, false); + case HOP_SAFE_C_SSS: + if ((cadr(p) == var1) && ((caddr(p) == var2) && ((pfunc == fx_c_sss) || (pfunc == fx_c_sss_direct)))) + return(with_fx(tree, (cadddr(p) == var3) ? ((pfunc == fx_c_sss_direct) ? fx_c_tuv_direct : fx_c_tuv) : fx_c_tus)); + if (caddr(p) == var1) + { + if (car(p) == sc->vector_set_symbol) return(with_fx(tree, fx_vset_sts)); + return(with_fx(tree, fx_c_sts)); + } + break; - /* write */ - func= set_function_chooser (sc->write_symbol, write_chooser); - sc->write_2= - make_function_with_class (sc, func, "write", g_write_2, 2, 0, false); + case HOP_SAFE_C_SSA: + if (cadr(p) == var1) return(with_fx(tree, fx_c_tsa)); /* tua is hit but not called much */ + if (caddr(p) == var1) return(with_fx(tree, fx_c_sta)); + break; - /* vector */ - func= set_function_chooser (sc->vector_symbol, vector_chooser); - sc->vector_2= - make_function_with_class (sc, func, "vector", g_vector_2, 2, 0, false); - sc->vector_3= - make_function_with_class (sc, func, "vector", g_vector_3, 3, 0, false); + case HOP_SAFE_C_opSq: + if (cadadr(p) == var1) + { + if (pfunc == fx_is_pair_car_s) return(with_fx(tree, fx_is_pair_car_t)); + if (pfunc == fx_is_pair_cdr_s) return(with_fx(tree, fx_is_pair_cdr_t)); + if (pfunc == fx_is_pair_cadr_s) return(with_fx(tree, fx_is_pair_cadr_t)); + if (pfunc == fx_is_symbol_cadr_s) return(with_fx(tree, fx_is_symbol_cadr_t)); + if (pfunc == fx_is_pair_cddr_s) return(with_fx(tree, fx_is_pair_cddr_t)); + if (pfunc == fx_is_null_cdr_s) return(with_fx(tree, fx_is_null_cdr_t)); + if (pfunc == fx_is_null_cadr_s) return(with_fx(tree, fx_is_null_cadr_t)); + if (pfunc == fx_is_null_cddr_s) return(with_fx(tree, fx_is_null_cddr_t)); + if (pfunc == fx_not_is_pair_s) return(with_fx(tree, fx_not_is_pair_t)); + if (pfunc == fx_not_is_null_s) return(with_fx(tree, fx_not_is_null_t)); + if (pfunc == fx_not_is_symbol_s) return(with_fx(tree, fx_not_is_symbol_t)); + if (pfunc == 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 (pfunc == 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_p_p_function(global_value(car(p)))); + set_opt3_direct(cdr(p), s7_p_p_function(global_value(caadr(p)))); + return(with_fx(tree, fx_c_optq_direct)); + } + return(with_fx(tree, fx_c_optq)); + } + if (pfunc == fx_c_car_s) return(with_fx(tree, fx_c_car_t)); + if (pfunc == fx_c_cdr_s) return(with_fx(tree, fx_c_cdr_t)); + if (pfunc == fx_is_type_opsq) return(with_fx(tree, fx_is_type_optq)); + if (pfunc == fx_not_opsq) + { + set_opt3_sym(p, cadadr(p)); + return(with_fx(tree, (caadr(p) == sc->car_symbol) ? fx_not_car_t : fx_not_optq)); + }} + if (cadadr(p) == var2) + { + if (pfunc == fx_c_car_s) return(with_fx(tree, fx_c_car_u)); + if (pfunc == fx_not_is_null_s) return(with_fx(tree, fx_not_is_null_u)); + if (pfunc == fx_not_is_pair_s) return(with_fx(tree, fx_not_is_pair_u)); + if (pfunc == fx_is_pair_cdr_s) return(with_fx(tree, fx_is_pair_cdr_u)); + } + if (cadadr(p) == var3) + { + if (pfunc == fx_not_is_pair_s) return(with_fx(tree, fx_not_is_pair_v)); + } + break; - /* vector-ref */ - func= set_function_chooser (sc->vector_ref_symbol, vector_ref_chooser); - sc->vector_ref_2= make_function_with_class (sc, func, "vector-ref", - g_vector_ref_2, 2, 0, false); - sc->vector_ref_3= make_function_with_class (sc, func, "vector-ref", - g_vector_ref_3, 3, 0, false); + case HOP_SAFE_C_opSq_S: + { + const s7_pointer arg1p = cdr(p), arg1 = cadr(p), arg2 = caddr(p); + if (cadr(arg1) == var1) + { + if (pfunc == fx_c_opsq_s) + { + if ((is_global_and_has_func(car(p), s7_p_pp_function)) && + (is_global_and_has_func(car(arg1), s7_p_p_function))) + { + set_opt2_direct(arg1p, s7_p_pp_function(global_value(car(p)))); + set_opt3_direct(arg1p, s7_p_p_function(global_value(car(arg1)))); + return(with_fx(tree, fx_c_optq_s_direct)); + } + return(with_fx(tree, fx_c_optq_s)); + } + if (pfunc == fx_c_opsq_s_direct) return(with_fx(tree, fx_c_optq_s_direct)); + if (pfunc == fx_cons_car_s_s) + { + set_opt1_sym(arg1p, var1); + return(with_fx(tree, (arg2 == var3) ? fx_cons_car_t_v : fx_cons_car_t_s)); + }} + if (cadr(arg1) == var2) + { + if ((pfunc == fx_c_opsq_s) && (arg2 == var1)) + { + if ((is_global_and_has_func(car(p), s7_p_pp_function)) && + (is_global_and_has_func(car(arg1), s7_p_p_function))) /* (memq (car sequence) items) lint */ + { + set_opt2_direct(arg1p, s7_p_pp_function(global_value(car(p)))); + set_opt3_direct(arg1p, s7_p_p_function(global_value(car(arg1)))); + return(with_fx(tree, (car(p) == sc->cons_symbol) ? + ((car(arg1) == 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 (((pfunc == fx_c_opsq_s_direct) || (pfunc == fx_cons_car_s_s)) && + (arg2 == var1)) + return(with_fx(tree, (car(p) == sc->cons_symbol) ? + ((car(arg1) == sc->car_symbol) ? fx_cons_car_u_t : fx_cons_opuq_t) : fx_c_opuq_t_direct)); + }} + break; - /* vector-set! */ - func= set_function_chooser (sc->vector_set_symbol, vector_set_chooser); - sc->vector_set_3= make_function_with_class (sc, func, "vector-set!", - g_vector_set_3, 3, 0, false); - sc->vector_set_4= make_function_with_class (sc, func, "vector-set!", - g_vector_set_4, 4, 0, false); + case HOP_SAFE_C_S_opSq: + { + const s7_pointer arg2_arg = cadaddr(p); + if (cadr(p) == var1) + { + if (arg2_arg == var2) + { + if (pfunc == fx_c_s_car_s) return(with_fx(tree, fx_c_t_car_u)); + if (pfunc == fx_c_s_opsq_direct) return(with_fx(tree, fx_c_t_opuq_direct)); + } + if (arg2_arg == var3) + { + if (pfunc == fx_add_s_car_s) return(with_fx(tree, fx_add_t_car_v)); + if (pfunc == fx_c_s_car_s) return(with_fx(tree, fx_c_t_car_v)); /* ideally eq_p_pp not g_is_eq */ + } + if (pfunc == fx_c_s_opsq_direct) return(with_fx(tree, fx_c_t_opsq_direct)); + } + if (cadr(p) == var2) + { + if ((pfunc == fx_add_s_car_s) && (arg2_arg == var1)) return(with_fx(tree, fx_add_u_car_t)); + if ((pfunc == fx_c_s_opsq_direct) && (arg2_arg == var3)) return(with_fx(tree, fx_c_u_opvq_direct)); + } + if ((arg2_arg == var1) && (pfunc == fx_c_s_car_s)) return(with_fx(tree, fx_c_s_car_t)); + } + break; - /* complex-vector-ref */ - func = set_function_chooser (sc->complex_vector_ref_symbol, - complex_vector_ref_chooser); - sc->cv_ref_2= make_function_with_class (sc, func, "complex-vector-ref", - g_cv_ref_2, 2, 0, false); + case HOP_SAFE_C_opSq_opSq: + { + const s7_pointer arg1 = cadr(p), arg2 = caddr(p); + if ((pfunc == fx_c_opsq_opsq_direct) && (cadr(arg1) == var1) && (cadr(arg2) == var1)) + { + /* p: (set-car! (cadr lst) (cdr lst)), var1: lst */ + set_opt1_sym(cdr(p), cadr(arg1)); + return(with_fx(tree, fx_c_optq_optq_direct)); /* opuq got few hits */ + } + if (((pfunc == fx_c_opsq_opsq_direct) || (pfunc == fx_car_s_car_s)) && + ((car(arg1) == sc->car_symbol) && (car(arg2) == sc->car_symbol))) + { + /* lt.scm: p: (list (car p) (car q)), var1: p, var2: q */ + set_opt1_sym(cdr(p), cadr(arg1)); + set_opt2_sym(cdr(p), cadr(arg2)); + return(with_fx(tree, ((cadr(arg1) == var1) && (cadr(arg2) == 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; - /* complex-vector-set */ - func = set_function_chooser (sc->complex_vector_set_symbol, - complex_vector_set_chooser); - sc->cv_set_3= make_function_with_class (sc, func, "complex-vector-set!", - g_cv_set_3, 3, 0, false); - sc->complex_wrapped= - make_function_with_class (sc, func, "complex", g_complex_wrapped, 2, 0, - false); /* not used currently? */ + case HOP_SAFE_C_opSq_C: + if (cadadr(p) == var1) + { + if (pfunc == fx_is_eq_car_sq) return(with_fx(tree, fx_is_eq_car_tq)); + if ((pfunc == fx_c_opsq_c) || (pfunc == fx_c_optq_c)) + { + if (fn_proc(p) != g_cdr_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, memq_2_p_pp); + else set_opt3_direct(p, s7_p_pp_function(global_value(car(p)))); + set_opt3_direct(cdr(p), 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_p_ii_function(global_value(car(p)))); + set_opt3_direct(cdr(p), 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; - /* float-vector-ref */ - func = set_function_chooser (sc->float_vector_ref_symbol, - float_vector_ref_chooser); - sc->fv_ref_2= make_function_with_class (sc, func, "float-vector-ref", - g_fv_ref_2, 2, 0, false); - sc->fv_ref_3= make_function_with_class (sc, func, "float-vector-ref", - g_fv_ref_3, 3, 0, false); + case HOP_SAFE_C_opSSq: + { + const s7_pointer arg1 = cadr(p); + if (pfunc == fx_c_opssq) + { + if (caddr(arg1) == var1) return(with_fx(tree, fx_c_opstq)); + if ((cadr(arg1) == var1) && (caddr(arg1) == var2)) return(with_fx(tree, fx_c_optuq)); + } + if (pfunc == fx_c_opssq_direct) + { + if ((cadr(arg1) == var1) && (caddr(arg1) == var2)) return(with_fx(tree, fx_c_optuq_direct)); + if (caddr(arg1) == var1) + { + if ((opt2_direct(cdr(p)) == (s7_pointer)zero_p_p) && (opt3_direct(cdr(p)) == (s7_pointer)remainder_p_pp) && + (!more_vars) && (o_var_ok(cadr(arg1), var1, var2, var3))) + return(with_fx(tree, fx_is_zero_remainder_o)); + return(with_fx(tree, fx_c_opstq_direct)); + }} + if ((cadr(arg1) == var2) && (pfunc == fx_not_opssq) && (caddadr(p) == var1)) + { + set_fx_direct(tree, (fn_proc(arg1) == g_less_2) ? fx_not_lt_ut : fx_not_oputq); + return(true); + }} + break; - /* float-vector-set */ - func = set_function_chooser (sc->float_vector_set_symbol, - float_vector_set_chooser); - sc->fv_set_3 = make_function_with_class (sc, func, "float-vector-set!", - g_fv_set_3, 3, 0, false); - sc->fv_set_unchecked= make_function_with_class ( - sc, func, "float-vector-set!", g_fv_set_unchecked, 3, 0, false); + case HOP_SAFE_C_opSCq: + if (cadadr(p) == var1) + { + if ((fn_proc(p) == g_zero) && (fn_proc(cadr(p)) == g_remainder) && + (is_t_integer(caddadr(p))) && (integer(caddadr(p)) > 1)) + return(with_fx(tree, fx_is_zero_remainder_ti)); + return(with_fx(tree, fx_c_optcq)); /* there currently isn't any fx_c_opscq_direct */ + } + break; - /* int-vector-ref */ - func= - set_function_chooser (sc->int_vector_ref_symbol, int_vector_ref_chooser); - sc->iv_ref_2= make_function_with_class (sc, func, "int-vector-ref", - g_iv_ref_2, 2, 0, false); - sc->iv_ref_3= make_function_with_class (sc, func, "int-vector-ref", - g_iv_ref_3, 3, 0, false); + case HOP_SAFE_C_opSSq_C: + if ((pfunc == fx_c_opssq_c) && (caddadr(p) == var1)) + { + if (is_global_and_has_func(car(p), s7_p_pp_function)) + { + set_opt3_direct(p, 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; - /* int-vector-set */ - func= - set_function_chooser (sc->int_vector_set_symbol, int_vector_set_chooser); - sc->iv_set_3= make_function_with_class (sc, func, "int-vector-set!", - g_iv_set_3, 3, 0, false); + case HOP_SAFE_C_S_opSCq: + if (cadr(p) == var1) + { + if (pfunc == fx_c_s_opscq_direct) return(with_fx(tree, (cadaddr(p) == var2) ? fx_c_t_opucq_direct : fx_c_t_opscq_direct)); + if ((pfunc == fx_c_s_opsiq_direct) && (!more_vars) && (o_var_ok(cadaddr(p), var1, var2, var3))) return(with_fx(tree, fx_c_t_opoiq_direct)); + } + else + if ((cadr(p) == var2) && (cadaddr(p) == var1)) + { + if (pfunc == fx_c_s_opsiq_direct) return(with_fx(tree, fx_c_u_optiq_direct)); + if (pfunc == fx_c_s_opscq) return(with_fx(tree, fx_c_u_optcq)); + } + break; - /* byte-vector-ref */ - func = set_function_chooser (sc->byte_vector_ref_symbol, - byte_vector_ref_chooser); - sc->bv_ref_2= make_function_with_class (sc, func, "byte-vector-ref", - g_bv_ref_2, 2, 0, false); - sc->bv_ref_3= make_function_with_class (sc, func, "byte-vector-ref", - g_bv_ref_3, 3, 0, false); + case HOP_SAFE_C_opSq_CS: + if ((cadadr(p) == var1) && (pfunc == fx_c_opsq_cs) && (cadddr(p) == var2)) return(with_fx(tree, fx_c_optq_cu)); + break; - /* byte-vector-set */ - func = set_function_chooser (sc->byte_vector_set_symbol, - byte_vector_set_chooser); - sc->bv_set_3= make_function_with_class (sc, func, "byte-vector-set!", - g_bv_set_3, 3, 0, false); + case HOP_SAFE_C_opSq_opSSq: + { + const s7_pointer arg1p = cdr(p), arg1 = cadr(p), arg2 = caddr(p); + if ((pfunc == fx_c_opsq_opssq) && (cadr(arg2) == var1) && (caddr(arg2) == var2) && + (is_global_and_has_func(car(p), s7_p_pp_function)) && + (is_global_and_has_func(car(arg1), s7_p_p_function)) && + (is_global_and_has_func(car(arg2), s7_p_pp_function))) + { + set_opt3_direct(p, s7_p_pp_function(global_value(car(p)))); + set_opt2_direct(arg1p, s7_p_p_function(global_value(car(arg1)))); + set_opt3_direct(arg1p, s7_p_pp_function(global_value(car(arg2)))); + set_opt1_sym(arg1p, var2); /* caddaddr(p) */ + set_opt2_sym(cddr(p), var1); + if ((car(p) == sc->num_eq_symbol) && (car(arg1) == sc->car_symbol) && (cadr(arg1) == var3)) + { + if (car(arg2) == sc->add_symbol) return(with_fx(tree, fx_num_eq_car_v_add_tu)); + if (car(arg2) == sc->subtract_symbol) return(with_fx(tree, fx_num_eq_car_v_subtract_tu)); + } + return(with_fx(tree, fx_c_opsq_optuq_direct)); + }} + break; - /* list-set! */ - func = set_function_chooser (sc->list_set_symbol, list_set_chooser); - sc->list_set_i= make_function_with_class (sc, func, "list-set!", g_list_set_i, - 3, 0, false); + case HOP_SAFE_C_opSSq_S: + { + const s7_pointer s1 = cadadr(p), s2 = caddadr(p); + if (pfunc == fx_vref_vref_ss_s) + { + s7_pointer s3 = caddr(p); + if ((s3 == var1) && (is_defined_global(s1))) + { + if ((!more_vars) && (o_var_ok(s2, var1, var2, var3))) return(with_fx(tree, fx_vref_vref_go_t)); + return(with_fx(tree, fx_vref_vref_gs_t)); + } + if ((s1 == var1) && (s2 == var2) && (s3 == var3)) return(with_fx(tree, fx_vref_vref_tu_v)); + } + if ((pfunc == fx_gt_add_s) && (s1 == var1) && (s2 == var2)) + return(with_fx(tree, fx_gt_add_tu_s)); + if ((pfunc == fx_add_sub_s) && (s1 == var1) && (s2 == var2)) + return(with_fx(tree, fx_add_sub_tu_s)); + } + break; - /* hash-table-ref */ - func= - set_function_chooser (sc->hash_table_ref_symbol, hash_table_ref_chooser); - sc->hash_table_ref_2= make_function_with_class ( - sc, func, "hash-table-ref", g_hash_table_ref_2, 2, 0, false); + case HOP_SAFE_C_S_opSSq: + if (caddaddr(p) == var1) + { + if ((fn_proc(p) == g_vector_ref_2) && (is_defined_global(cadr(p)) && (is_defined_global(cadaddr(p))))) + { + set_opt3_pair(p, cdaddr(p)); + return(with_fx(tree, fx_vref_g_vref_gt)); + } + if (pfunc == fx_c_s_opssq_direct) return(with_fx(tree, fx_c_s_opstq_direct)); + } + if ((pfunc == fx_c_s_opssq_direct) && (cadr(p) == var1) && (caddaddr(p) == var2)) return(with_fx(tree, fx_c_t_opsuq_direct)); + break; - /* hash-table-set! */ - set_function_chooser (sc->hash_table_set_symbol, hash_table_set_chooser); + 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; - /* hash-table */ - func= set_function_chooser (sc->hash_table_symbol, hash_table_chooser); - sc->hash_table_2= make_function_with_class (sc, func, "hash-table", - g_hash_table_2, 2, 0, false); + case HOP_SAFE_C_AC: + if (((pfunc == fx_c_ac) || (pfunc == 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; - /* format */ - func= set_function_chooser (sc->format_symbol, format_chooser); - sc->format_f= - make_function_with_class (sc, func, "format", g_format_f, 1, 0, true); - /* sc->format_nr = make_function_with_class(sc, func, "format", g_format_nr, - * 1, 0, true); */ - sc->format_no_column= make_function_with_class ( - sc, func, "format", g_format_no_column, 1, 0, true); - sc->format_just_control_string= make_function_with_class ( - sc, func, "format", g_format_just_control_string, 2, 0, false); - sc->format_as_objstr= make_function_with_class ( - sc, func, "format", g_format_as_objstr, 3, 0, true); + case HOP_SAFE_CLOSURE_S_A: + if ((cadr(p) == var1) && (pfunc == fx_safe_closure_s_a)) return(with_fx(tree, fx_safe_closure_t_a)); + break; - /* list */ - func= set_function_chooser (sc->list_symbol, list_chooser); - sc->list_0= - make_function_with_class (sc, func, "list", g_list_0, 0, 0, false); - sc->list_1= - make_function_with_class (sc, func, "list", g_list_1, 1, 0, false); - sc->list_2= - make_function_with_class (sc, func, "list", g_list_2, 2, 0, false); - sc->list_3= - make_function_with_class (sc, func, "list", g_list_3, 3, 0, false); - sc->list_4= - make_function_with_class (sc, func, "list", g_list_4, 4, 0, false); + 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; - /* append */ - func= set_function_chooser (sc->append_symbol, append_chooser); - sc->append_2= - make_function_with_class (sc, func, "append", g_append_2, 2, 0, false); + case OP_AND_3A: + if ((pfunc == 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)))) + { + const s7_pointer arg3p = cdddr(p); + set_opt1_sym(cdr(p), cadadr(p)); + if ((fx_proc(arg3p) == fx_is_null_cddr_t) || (fx_proc(arg3p) == fx_is_null_cddr_s)) + return(with_fx(tree, fx_len2_t)); + if ((fx_proc(arg3p) == fx_is_pair_cddr_t) || (fx_proc(arg3p) == fx_is_pair_cddr_s)) + return(with_fx(tree, fx_len3_t)); + } + break; + } + return(false); +} - /* list-ref */ - func= set_function_chooser (sc->list_ref_symbol, list_ref_chooser); - sc->list_ref_at_0= - make_function_with_class (sc, func, "list", g_list_ref_at_0, 2, 0, false); - sc->list_ref_at_1= - make_function_with_class (sc, func, "list", g_list_ref_at_1, 2, 0, false); - sc->list_ref_at_2= - make_function_with_class (sc, func, "list", g_list_ref_at_2, 2, 0, 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)) fprintf(stderr, "fx_tree %s %d %d\n", display(tree), has_fx(tree), is_syntax(car(tree))); */ + 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))) && (is_pair(caadr(tree)))) /* (let (a) ...) */ + 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 */ - /* assoc */ - set_function_chooser (sc->assoc_symbol, assoc_chooser); + 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); +} - /* member */ - set_function_chooser (sc->member_symbol, member_chooser); +/* -------------------------------------------------------------------------------- */ +static opt_funcs_t *alloc_semipermanent_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++])); +} - /* memq */ - func= set_function_chooser (sc->memq_symbol, - memq_chooser); /* in pure-s7, use member here */ - sc->memq_2= - make_function_with_class (sc, func, "memq", g_memq_2, 2, 0, false); - sc->memq_3= - make_function_with_class (sc, func, "memq", g_memq_3, 2, 0, false); - sc->memq_4= - make_function_with_class (sc, func, "memq", g_memq_4, 2, 0, false); - sc->memq_any= - make_function_with_class (sc, func, "memq", g_memq_any, 2, 0, false); +static void add_opt_func(s7_scheme *sc, s7_pointer base_func, opt_func_t typ, void *opt_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_ip", "o_d_pd", "o_d_7p", "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(base_func)) + { + fprintf(stderr, "%s[%d]: %s is not a c_function\n", __func__, __LINE__, display(base_func)); + if (sc->stop_at_error) abort(); + } + else + if (c_function_opt_data(base_func)) + for (opt_funcs_t *p = c_function_opt_data(base_func); p; p = p->next) + { + if (p->typ == typ) + fprintf(stderr, "%s[%d]: %s has a function of type %d (%s)\n", + __func__, __LINE__, display(base_func), typ, o_names[typ]); + if (p->func == opt_func) + fprintf(stderr, "%s[%d]: %s already has this function as type %d %s (current: %d %s)\n", + __func__, __LINE__, display(base_func), p->typ, o_names[p->typ], typ, o_names[typ]); + } +#endif + op = alloc_semipermanent_opt_func(sc); + op->typ = typ; + op->func = opt_func; + op->next = c_function_opt_data(base_func); + c_function_opt_data(base_func) = op; +} - /* tree-set-memq */ - func= set_function_chooser (sc->tree_set_memq_symbol, tree_set_memq_chooser); - sc->tree_set_memq_syms= make_function_with_class ( - sc, func, "tree-set-memq", g_tree_set_memq_syms, 2, 0, false); +static void *opt_func(s7_pointer base_func, opt_func_t typ) +{ + if (is_c_function(base_func)) + for (opt_funcs_t *p = c_function_opt_data(base_func); p; p = p->next) + if (p->typ == typ) + return(p->func); + return(NULL); +} - /* dynamic-wind */ - func= set_function_chooser (sc->dynamic_wind_symbol, dynamic_wind_chooser); - sc->dynamic_wind_unchecked= make_unsafe_function_with_class ( - sc, func, "dynamic-wind", g_dynamic_wind_unchecked, 3, 0, false); - sc->dynamic_wind_body= make_unsafe_function_with_class ( - sc, func, "dynamic-wind", g_dynamic_wind_body, 3, 0, false); - sc->dynamic_wind_init= make_unsafe_function_with_class ( - sc, func, "dynamic-wind", g_dynamic_wind_init, 3, 0, false); +/* 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);} /* mus_srate, mus_float_equal_fudge_factor clm2xen.c */ +s7_d_t s7_d_function(s7_pointer f) {return((s7_d_t)opt_func(f, o_d));} - /* unlet */ - sc->unlet_disabled= - make_function_with_class (sc, global_value (sc->unlet_symbol), "unlet", - g_unlet_disabled, 0, 0, false); +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));} - /* outlet */ - func = set_function_chooser (sc->outlet_symbol, outlet_chooser); - sc->outlet_unlet= make_function_with_class (sc, func, "outlet", - g_outlet_unlet, 1, 0, false); +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));} - /* inlet */ - func= set_function_chooser (sc->inlet_symbol, inlet_chooser); - sc->simple_inlet= - make_function_with_class (sc, func, "inlet", g_simple_inlet, 0, 0, true); +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));} - /* sublet */ - func = set_function_chooser (sc->sublet_symbol, sublet_chooser); - sc->sublet_curlet= make_function_with_class (sc, func, "sublet", - g_sublet_curlet, 3, 0, false); +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));} - /* let-ref */ - func = set_function_chooser (sc->let_ref_symbol, let_ref_chooser); - sc->cdr_let_ref= make_function_with_class (sc, func, "let-ref", g_cdr_let_ref, - 2, 0, false); - sc->starlet_ref= make_function_with_class (sc, func, "let-ref", g_starlet_ref, - 2, 0, false); - sc->rootlet_ref= make_function_with_class (sc, func, "let-ref", g_rootlet_ref, - 2, 0, false); - sc->curlet_ref= - make_function_with_class (sc, func, "let-ref", g_curlet_ref, 2, 0, false); - sc->unlet_ref= - make_function_with_class (sc, func, "let-ref", g_unlet_ref, 2, 0, false); +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));} - /* let-set */ - func = set_function_chooser (sc->let_set_symbol, let_set_chooser); - sc->cdr_let_set= make_function_with_class (sc, func, "let-set!", - g_cdr_let_set, 3, 0, false); - sc->unlet_set= - make_function_with_class (sc, func, "let-set!", g_unlet_set, 3, 0, false); - sc->starlet_set= make_function_with_class (sc, func, "let-set!", - g_starlet_set, 3, 0, false); +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));} - /* values */ - func = set_function_chooser (sc->values_symbol, values_chooser); - sc->values_uncopied= make_unsafe_function_with_class ( - sc, func, "values", splice_in_values, 0, 0, true); +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));} - /* list-values */ - func= set_function_chooser (sc->list_values_symbol, list_values_chooser); - sc->simple_list_values= make_function_with_class ( - sc, func, "list-values", g_simple_list_values, 0, 0, true); +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));} - sc->restore_setter= - s7_make_function (sc, "#", g_restore_setter, 1, 0, false, - "map closure-setter restoration (for dynamic-unwind)"); -} +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));} -/* ---------------- *unbound-variable-hook* ---------------- */ -#if !DISABLE_AUTOLOAD -static s7_pointer -loaded_library (s7_scheme* sc, const char* file) { - for (s7_pointer libs= global_value (sc->libraries_symbol); is_pair (libs); - libs = cdr (libs)) - if (local_strcmp (file, string_value (caar (libs)))) return (cdar (libs)); - return (sc->nil); -} -#endif +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));} -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 */ - } -} +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));} -#define LEVEN_MIN_LEN 2 -#define LEVEN_MAX_LEN 23 -static int32_t** original_distance; +static void s7_set_d_7p_function(s7_scheme *sc, s7_pointer f, s7_d_7p_t df) {add_opt_func(sc, f, o_d_7p, (void *)df);} +static s7_d_7p_t s7_d_7p_function(s7_pointer f) {return((s7_d_7p_t)opt_func(f, o_d_7p));} -static void -init_leven (void) { - int32_t i, j; - original_distance= - (int32_t**) malloc ((LEVEN_MAX_LEN + 1) * sizeof (int32_t*)); - for (i= 0; i <= LEVEN_MAX_LEN; i++) - original_distance[i]= - (int32_t*) calloc (LEVEN_MAX_LEN + 1, sizeof (int32_t)); - for (j= 0; j <= LEVEN_MAX_LEN; j++) - original_distance[0][j]= j; - for (i= 0; i <= LEVEN_MAX_LEN; i++) - original_distance[i][0]= i; -} - -static int32_t -levenshtein (s7_scheme* sc, const char* s1, int32_t len1, const char* s2, - int32_t len2) { - int32_t i, j; - int32_t mx= (len1 > len2) ? len1 : len2; - if ((mx > LEVEN_MAX_LEN) || (mx < LEVEN_MIN_LEN)) return (100); - for (i= 0; i <= mx; i++) - memcpy ((void*) (sc->current_distance[i]), (void*) (original_distance[i]), - mx * sizeof (int32_t)); /* TODO: (mx+1?) */ - for (i= 1; i <= len2; i++) - for (j= 1; j <= len1; j++) { - int32_t c1, c2, c3; - c1= sc->current_distance[i][j - 1] + 1; - c2= sc->current_distance[i - 1][j] + 1; - c3= sc->current_distance[i - 1][j - 1] + - ((s2[i - 1] == s1[j - 1]) ? 0 : 1); - if (c1 > c2) c1= c2; - if (c1 > c3) c1= c3; - sc->current_distance[i][j]= c1; - } - return (sc->current_distance[len2][len1]); -} - -static no_return void -unbound_variable_error_nr (s7_scheme* sc, s7_pointer sym) { - s7_pointer err_code= NULL; - if ((is_pair (current_code (sc))) && - (s7_tree_memq (sc, sym, current_code (sc)))) - err_code= current_code (sc); - else if ((is_pair (sc->code)) && (s7_tree_memq (sc, sym, sc->code))) - err_code= sc->code; -#if WITH_HISTORY - else { - s7_pointer p; - for (p= cdr (sc->cur_code); cdr (p) != sc->cur_code; p= cdr (p)) - ; - if ((is_pair (car (p))) && (s7_tree_memq (sc, sym, car (p)))) - err_code= car (p); - } -#endif +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));} - if (starlet_symbol_id (T_Sym (sym)) != sl_no_field) { - if (err_code) - error_nr ( - sc, sc->unbound_variable_symbol, - set_elist_4 ( - sc, - wrap_string ( - sc, - "unbound variable ~S in ~S, perhaps you meant (*s7* '~S)?", - 56), - sym, err_code, sym)); - error_nr ( - sc, sc->unbound_variable_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, "unbound variable ~S, perhaps you meant (*s7* '~S)?", 50), - sym, sym)); - } - /* fprintf(stderr, "%s: %s in %s %" ld64 "\n", __func__, display(sym), - * (err_code) ? display(err_code) : "no code", (err_code && - * (has_location(err_code))) ? pair_line_number(err_code) : -1); */ - { - const s7_int sym_len = symbol_name_length (sym); - int32_t min_diff= (sym_len == 1) ? 0 : ((sym_len == 2) ? 2 : 3); - if (min_diff > 0) { - /* check let chain */ - const char* sym_name= symbol_name (sym); - s7_pointer min_sym = NULL; - for (s7_pointer let= sc->curlet; let; let= let_outlet (let)) - for (s7_pointer slot= let_slots (let); is_not_slot_end (slot); - slot = next_slot (slot)) { - const s7_pointer cur_sym= slot_symbol (slot); - if (s7_int_abs (sym_len - symbol_name_length (cur_sym)) < 2) { - int32_t diff= - levenshtein (sc, sym_name, sym_len, symbol_name (cur_sym), - symbol_name_length (cur_sym)); - if (sym_name[0] != symbol_name (cur_sym)[0]) diff++; - if (diff < min_diff) { - min_diff= diff; - min_sym = cur_sym; - } - } - } - /* fprintf(stderr, "min_sym: %s, err_code: %s\n", (min_sym) ? - * display(min_sym) : "none", display(err_code)); */ - if ((!min_sym) && (err_code) && (is_pair (err_code)) && - (sym == car (err_code)) && - (sym_len < 24)) /* don't treat these as common variables */ - { /* perhaps also check that the suggested new name actually fits the rest - of err_code!: "char -> caar (char #\a)" */ -/* check main symbols, from t865.scm */ -#define MAIN_NAMES_SIZE 443 - static const char* main_names[MAIN_NAMES_SIZE]= { - "<=", - ">=", - "do", - "gc", - "if", - "or", - "pi", - "abs", - "and", - "ash", - "car", - "cdr", - "cos", - "eq?", - "exp", - "gcd", - "lcm", - "let", - "log", - "map", - "s7-max", - "s7-min", - "nan", - "not", - "sin", - "sym", - "tan", - "*s7*", - "acos", - "asin", - "assq", - "assv", - "atan", - "caar", - "cadr", - "case", - "cdar", - "cddr", - "cond", - "cons", - "copy", - "cosh", - "else", - "eqv?", - "eval", - "exit", - "expt", - "help", - "let*", - "let?", - "list", - "load", - "memq", - "memv", - "nan?", - "odd?", - "read", - "set!", - "sinh", - "sqrt", - "tanh", - "when", - "abort", - "acosh", - "angle", - "apply", - "arity", - "asinh", - "assoc", - "atanh", - "bacro", - "begin", - "byte?", - "caaar", - "caadr", - "cadar", - "caddr", - "catch", - "cdaar", - "cdadr", - "cddar", - "cdddr", - "char?", - "error", - "even?", - "fill!", - "floor", - "goto?", - "index", - "inlet", - "list?", - "macro", - "null?", - "owlet", - "pair?", - "quote", - "real?", - "s7-round", - "sort!", - "throw", - "unlet", - "write", - "zero?", - "append", - "bacro*", - "bignum", - "caaaar", - "caaadr", - "caadar", - "caaddr", - "cadaar", - "cadadr", - "caddar", - "cadddr", - "cdaaar", - "cdaadr", - "cdadar", - "cdaddr", - "cddaar", - "cddadr", - "cdddar", - "cddddr", - "char?", - "curlet", - "cutlet", - "define", - "equal?", - "exact?", - "float?", - "format", - "gensym", - "getenv", - "lambda", - "length", - "letrec", - "logand", - "logior", - "lognot", - "logxor", - "macro*", - "macro?", - "member", - "s7-modulo", - "outlet", - "random", - "setter", - "string", - "sublet", - "symbol", - "system", - "unless", - "values", - "varlet", - "vector", - "bignum?", - "call/cc", - "s7-ceiling", - "char<=?", - "char>=?", - "complex", - "define*", - "display", - "funclet", - "gensym?", - "iterate", - "lambda*", - "let-ref", - "letrec*", - "logbit?", - "newline", - "number?", - "openlet", - "provide", - "require", - "reverse", - "rootlet", - "string?", - "symbol?", - "syntax?", - "type-of", - "unquote", - "vector?", - "boolean?", - "complex?", - "coverlet", - "defined?", - "dilambda", - "for-each", - "funclet?", - "inexact?", - "integer?", - "keyword?", - "let-set!", - "list-ref", - "openlet?", - "quotient", - "reverse!", - "set-car!", - "set-cdr!", - "string?", - "s7-truncate", - "with-let", - "aritable?", - "c-object?", - "c-pointer", - "constant?", - "dilambda?", - "hash-code", - "imag-part", - "infinite?", - "iterator?", - "let->list", - "list-set!", - "list-tail", - "magnitude", - "make-hook", - "make-list", - "negative?", - "numerator", - "peek-char", - "port-file", - "positive?", - "provided?", - "rational?", - "read-byte", - "read-char", - "read-line", - "real-part", - "remainder", - "sequence?", - "signature", - "string<=?", - "string>=?", - "substring", - "subvector", - "tree-memq", - "*function*", - "c-pointer?", - "directory?", - "file-mtime", - "hash-table", - "immutable!", - "immutable?", - "int-vector", - "make-polar", - "procedure?", - "profile-in", - "quasiquote", - "stacktrace", - "string-ref", - "subvector?", - "tree-count", - "undefined?", - "vector-ref", - "write-byte", - "write-char", - "byte-vector", - "char-ready?", - "char-upcase", - "cond-expand", - "delete-file", - "denominator", - "eof-object?", - "equivalent?", - "eval-string", - "hash-table?", - "input-port?", - "int-vector?", - "list-values", - "macroexpand", - "make-string", - "make-vector", - "nan-payload", - "object->let", - "port-string", - "rationalize", - "read-string", - "reader-cond", - "string-copy", - "string-set!", - "tree-leaves", - "vector-rank", - "vector-set!", - "with-baffle", - "apply-values", - "byte-vector?", - "c-object-let", - "define-bacro", - "define-macro", - "dynamic-wind", - "file-exists?", - "float-vector", - "list->string", - "list->vector", - "output-port?", - "port-closed?", - "proper-list?", - "random-state", - "string->list", - "string-fill!", - "symbol-table", - "tree-cyclic?", - "unspecified?", - "vector->list", - "vector-fill!", - "vector-typer", - "write-string", - "c-object-type", - "char->integer", - "char-downcase", - "char-numeric?", - "char-position", - "continuation?", - "define-bacro*", - "define-macro*", - "documentation", - "float-vector?", - "integer->char", - "make-iterator", - "pair-filename", - "port-filename", - "port-position", - "random-state?", - "string-append", - "string-length", - "symbol->value", - "tree-set-memq", - "vector-append", - "vector-length", - "c-pointer-info", - "c-pointer-type", - "call-with-exit", - "complex-vector", - "dynamic-unwind", - "emergency-exit", - "exact->inexact", - "hash-table-ref", - "hook-functions", - "inexact->exact", - "int-vector-ref", - "integer-length", - "number->string", - "object->string", - "string->number", - "string->symbol", - "symbol->string", - "byte-vector-ref", - "c-pointer->list", - "c-pointer-weak1", - "c-pointer-weak2", - "complex-vector?", - "define-constant", - "directory->list", - "int-vector-set!", - "keyword->symbol", - "let-temporarily", - "make-int-vector", - "open-input-file", - "string->keyword", - "string-position", - "symbol->keyword", - "weak-hash-table", - "byte-vector-set!", - "call-with-values", - "char-alphabetic?", - "char-upper-case?", - "char-whitespace?", - "close-input-port", - "cyclic-sequences", - "define-expansion", - "float-vector-ref", - "iterator-at-end?", - "make-byte-vector", - "make-rectangular", - "open-output-file", - "pair-line-number", - "port-line-number", - "procedure-source", - "subvector-vector", - "vector-dimension", - "weak-hash-table?", - "close-output-port", - "define-expansion*", - "float-vector-set!", - "flush-output-port", - "get-output-string", - "iterator-sequence", - "make-float-vector", - "open-input-string", - "procedure-arglist", - "vector-dimensions", - "complex-vector-ref", - "current-error-port", - "current-input-port", - "hash-table-entries", - "open-output-string", - "random-state->list", - "s7-hash-table-set!", - "s7-make-hash-table", - "substring-uncopied", - "subvector-position", - "byte-vector->string", - "complex-vector-set!", - "current-output-port", - "make-complex-vector", - "multiple-value-bind", - "open-input-function", - "string->byte-vector", - "with-output-to-file", - "call-with-input-file", - "hash-table-key-typer", - "integer-decode-float", - "make-weak-hash-table", - "open-output-function", - "symbol-initial-value", - "with-input-from-file", - "call-with-output-file", - "symbol->dynamic-value", - "with-output-to-string", - "call-with-input-string", - "hash-table-value-typer", - "set-current-error-port", - "set-current-input-port", - "with-input-from-string", - "call-with-output-string", - "set-current-output-port"}; - - static const int32_t main_names_index - [LEVEN_MAX_LEN]= {0, 7, 27, 62, 103, 156, 184, 206, - 243, 265, 296, 321, 344, 361, 378, 397, - 407, 417, 425, 432, 435, 440, 442}; /* 443==NULL, - 7858 - - 3576 - bytes */ - const int32_t start= main_names_index[sym_len - 2], - end = main_names_index[sym_len - 1]; -#if 0 - { /* if above list changed, this might help: */ - const char *starts[22] = {"<=", "cos", "acos", "error", "define", "letrec*", "quotient", "substring", - "int-vector", "object->let", "float-vector", "string-append", - "hook-functions", "c-pointer-weak2", "iterator-at-end?", "open-input-string", - "open-output-string", "string->byte-vector", "with-input-from-file", - "with-output-to-string", "set-current-error-port", "set-current-output-port"}; - fprintf(stderr, "starts[22] = {"); - for (int32_t i = 0; i < 22; i++) - for (int32_t j = 0; j < MAIN_NAMES_SIZE; j++) - if (strcmp(main_names[j], starts[i]) == 0) - { - fprintf(stderr, "%d, ", j); - break; - }} - for (int32_t i = 0; i < LEVEN_MAX_LEN; i++) fprintf(stderr, "%s\n", main_names[main_names_index[i]]); -#endif - for (int32_t i= start; i < end; i++) { - /* main_names has only 430 entries but main_names_index is sized - for 443, so the length-20..23 buckets run into trailing NULL - slots; skip NULLs to avoid dereferencing them in levenshtein. */ - if (main_names[i] == NULL) continue; - int32_t diff= - levenshtein (sc, sym_name, sym_len, main_names[i], sym_len) + - 1; /* perhaps same but i+/-1 as well */ - if (sym_name[0] != main_names[i][0]) diff++; - if (diff < min_diff) { - min_diff= diff; - min_sym = make_symbol (sc, main_names[i], sym_len); - } - } - } - if (min_sym) { - if (err_code) - error_nr (sc, sc->unbound_variable_symbol, - set_elist_4 ( - sc, - wrap_string ( - sc, "unbound variable ~S in ~S, perhaps ~S?", 38), - sym, err_code, min_sym)); - error_nr (sc, sc->unbound_variable_symbol, - set_elist_3 ( - sc, - wrap_string (sc, "unbound variable ~S, perhaps ~S?", 32), - sym, min_sym)); - } - } - } +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));} - if (err_code) /* these cases look ok */ - error_nr (sc, sc->unbound_variable_symbol, - set_elist_3 (sc, - wrap_string (sc, "unbound variable ~S in ~S", 25), - sym, err_code)); - if ((symbol_name (sym)[symbol_name_length (sym) - 1] == ',') && - (lookup_unexamined (sc, make_symbol (sc, symbol_name (sym), - symbol_name_length (sym) - 1)))) - error_nr (sc, sc->unbound_variable_symbol, - set_elist_2 ( - sc, - wrap_string ( - sc, "unbound variable ~S (perhaps a stray comma?)", 44), - sym)); - error_nr (sc, sc->unbound_variable_symbol, - set_elist_2 (sc, wrap_string (sc, "unbound variable ~S", 19), sym)); -} - -static s7_pointer -check_autoload_and_error_hook (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 ((sc->curlet != sc->nil) && - (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... */ +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));} - if (sym == sc->unquote_symbol) - syntax_error_nr (sc, "unquote (',') occurred outside quasiquote: ~S", 45, - current_code (sc)); +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));} - if (safe_strcmp (symbol_name (sym), "|#")) read_error_nr (sc, "unmatched |#"); +/* 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));} - /* check *autoload*, autoload_names, then *unbound-variable-hook* */ - if ((sc->autoload_names) || (is_hash_table (sc->autoload_table)) || - ((is_procedure (sc->unbound_variable_hook)) && - (hook_has_functions (sc->unbound_variable_hook)))) { - s7_pointer cur_code = current_code (sc); - const s7_pointer value = sc->value; - const s7_pointer code = sc->code; - const s7_pointer current_let= sc->curlet; - /* 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. - */ - const s7_pointer args = (sc->args) ? sc->args : sc->nil; - s7_pointer result= sc->undefined; - sc->temp9 = cur_code; - sc->temp7 = cons_unchecked ( - sc, current_let, - cons_unchecked ( - sc, code, /* perhaps elist_7 except we use elist_3 above? */ - cons_unchecked ( - sc, args, - list_2 (sc, value, - cur_code)))); /* not s7_list (debugger checks) */ - sc->temp9= sc->unused; - 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 - if ((sc->is_autoloading) && - (sc->autoload_names)) /* created by s7_autoload_set_names which requires - alphabetization by the caller (e.g. snd-xref.c) - */ - { - bool loaded= false; - const char* file = find_autoload_name (sc, sym, &loaded, true); - if ((file) && (!loaded)) { - /* if we've already loaded this file, we can get the library (let) 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 - */ - s7_pointer let= loaded_library (sc, file); - if ((!let) || (!is_let (let))) { - if (hook_has_functions (sc->autoload_hook)) - s7_apply_function ( - sc, sc->autoload_hook, - set_plist_2 (sc, sym, s7_make_string (sc, file))); - let= 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) && (let) && (is_let (let))) { - /* the current_let refs here are trying to handle local autoloads, but - * that is problematic -- we'd need to save the autoload curlet when - * autoload is called, and hope the current reference can still access - * that let? but if the same symbol is autloaded in several lets, we - * are in trouble, and how to handle a function that has an autoload? - * I think I'll just assume rootlet, even though that is not very - * elegant. Actually in the libgsl case, we're trying to export a - * name from *libgsl* -- should that be done with define rather than - * autoload? - */ - result= let_ref_p_pp ( - sc, let, sym); /* add '(sym . result) to current_let (was sc->nil, - s7_load can set sc->curlet to sc->nil) */ - if (result != sc->undefined) s7_define (sc, sc->rootlet, 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))) { - /* 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... - */ - const s7_pointer val= s7_hash_table_ref (sc, sc->autoload_table, sym); - s7_pointer let= NULL; - 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)); - let= 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)); - let= 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 */ - if ((result == sc->undefined) && (let) && - (is_let (let))) /* added 31-Mar-23 to match sc->autoload_names case - above */ - { - result= let_ref_p_pp (sc, let, sym); - if (result != sc->undefined) - s7_define (sc, sc->rootlet, sym, - result); /* as above, was sc->nil -- s7_load above can - set sc->curlet to sc->nil */ - } - } -#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_) */ - const s7_pointer old_hook = sc->unbound_variable_hook; - const bool old_history_enabled= s7_set_history_enabled (sc, false); - gc_protect_via_stack (sc, old_hook); - sc->unbound_variable_hook= sc->nil; - result = s7_call (sc, old_hook, - set_plist_1 (sc, sym)); /* not s7_apply_function */ - if (result == sc->unspecified) result= sc->undefined; - sc->unbound_variable_hook= old_hook; - s7_set_history_enabled (sc, old_history_enabled); - unstack_gc_protect (sc); - } - } - sc->value= T_Ext (value); - sc->args = T_Pos (args); /* can be # or #! */ - sc->code = code; - set_curlet (sc, current_let); - sc->temp7= sc->unused; - return (result); - } - return (sc->undefined); -} +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));} -s7_pointer -unbound_variable (s7_scheme* sc, s7_pointer sym) { - s7_pointer result= check_autoload_and_error_hook (sc, sym); - if (result != sc->undefined) return (result); - unbound_variable_error_nr (sc, sym); - return (sc->unbound_variable_symbol); -} +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));} -#define choose_c_function(Sc, Expr, Func, Args) \ - set_class_and_fn_proc (Expr, c_function_chooser (Func) (Sc, Func, Args, Expr)) +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));} -static void -fx_annotate_arg (s7_scheme* sc, s7_pointer arg, s7_pointer let_or_list) { -#if S7_DEBUGGING - s7_function fx; - if (has_fx (arg)) return; - fx= fx_choose (sc, arg, let_or_list, - (is_list (let_or_list)) ? pair_symbol_is_safe - : let_symbol_is_safe); - if (fx) set_fx_direct (arg, fx); - /* else fprintf(stderr, "%s[%d]: no fx for %s in %s\n", __func__, __LINE__, - * display(arg), display(let_or_list)); */ -#else - if (has_fx (arg)) return; - set_fx (arg, fx_choose (sc, arg, let_or_list, - (is_list (let_or_list)) ? pair_symbol_is_safe - : let_symbol_is_safe)); -#endif -} +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);} +static 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 -fx_annotate_args (s7_scheme* sc, s7_pointer args, s7_pointer let_or_list) { - for (s7_pointer p= args; is_pair (p); p= cdr (p)) +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));} + +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);} +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));} + +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);} +s7_p_pp_t s7_p_pp_function(s7_pointer f) {return((s7_p_pp_t)opt_func(f, o_p_pp));} + +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);} +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_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_opt_info(s7_scheme *sc) +{ + opt_info *o; + if (sc->pc >= OPTS_SIZE) + sc->pc = OPTS_SIZE - 1; + o = sc->opts[sc->pc++]; + q_temp(o).fd = NULL; /* see bool_optimize -- this is a kludge */ #if S7_DEBUGGING - fx_annotate_arg (sc, p, let_or_list); /* checks has_fx */ -#else - if (!has_fx (p)) - set_fx (p, fx_choose (sc, p, let_or_list, - (is_list (let_or_list)) ? pair_symbol_is_safe - : let_symbol_is_safe)); + for (int i = 0; i < num_vunions; i++) o->v[i].p = NULL; #endif + return(o); } -static opt_t -optimize_thunk (s7_scheme* sc, s7_pointer expr, s7_pointer func, int32_t hop, - s7_pointer let_or_list) { - if (SHOW_EVAL_OPS) - fprintf (stderr, " %s[%d]: expr: %s, func: %s, hop: %d, let_or_list: %s\n", - __func__, __LINE__, display_truncated (expr), display (func), hop, - display_truncated (let_or_list)); - if ((hop != 1) && (is_constant_symbol (sc, car (expr)))) hop= 1; - if ((is_closure (func)) || (is_closure_star (func))) { - const bool safe_case= is_safe_closure (func); - const s7_pointer body = closure_body (func); - const bool one_form = is_null (cdr (body)); - - if (is_immutable (func)) hop= 1; - if (is_null (closure_pars (func))) /* no rest arg funny business */ - { - set_optimized (expr); - if ((one_form) && (safe_case) && - (is_fxable (sc, car (body)))) /* fx stuff is not set yet */ - { - fx_annotate_arg (sc, body, let_or_list); - set_optimize_op (expr, hop + OP_SAFE_THUNK_A); - set_closure_one_form_fx_arg (func); - set_opt1_lambda_add (expr, func); - return (opt_ok); - } - /* 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 - : ((one_form) ? OP_THUNK_O : OP_THUNK))); - set_opt1_lambda_add (expr, func); - return ((safe_case) ? opt_ok : opt_bad); - } - if (is_symbol (closure_pars ( - func))) /* (define* (f1 . a) ...) called (f1) -- called a closure - (not closure*) in define_unchecked */ - { - set_opt1_lambda_add (expr, func); - if (safe_case) { - if (!has_fx (body)) { - fx_annotate_args (sc, body, let_or_list); - fx_tree (sc, body, closure_pars (func), NULL, NULL, false); - } - set_safe_optimize_op (expr, hop + OP_SAFE_THUNK_ANY); - return (opt_ok); - } - set_unsafe_optimize_op ( - expr, hop + OP_THUNK_ANY); /* "thunk" because here it is called with - no args, I guess */ - return (opt_bad); - } - 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_bad); - } - if (is_c_function (func)) { - if (c_function_min_args (func) != 0) return (opt_bad); - if ((hop == 0) && (is_global (car (expr)))) - hop= 1; /* not good: (define + *) clears hop earlier */ - if ((is_safe_procedure (func)) || (c_function_call (func) == g_values)) { - set_safe_optimize_op (expr, hop + OP_SAFE_C_NC); - choose_c_function (sc, expr, func, 0); - return (opt_ok); - } - set_unsafe_optimize_op (expr, hop + OP_C); - choose_c_function (sc, expr, func, 0); - return (opt_bad); - } - if (is_c_function_star (func)) { - set_safe_optimize_op (expr, hop + OP_SAFE_C_STAR); - set_class_and_fn_proc (expr, func); - return (opt_ok); - } - return (opt_bad); +#define backup_pc(sc) sc->pc-- + +#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[%d]: %s\n", func, line, display_truncated(expr)); + else fprintf(stderr, " %s[%d]: false\n", func, line); + return(false); } -static int32_t -combine_ops (s7_scheme* sc, s7_pointer expr, combine_op_t cop, s7_pointer arg1, - s7_pointer arg2) /* sc needed for debugger stuff */ -{ /* sc arg is used if debugging (hidden in set_op2_con for example) */ - switch (cop) { - case combine_p: - switch (op_no_hop (arg1)) { - 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 (arg1)); - set_opt1_sym (cdr (expr), caddr (arg1)); - return (OP_SAFE_C_opSSq); - case OP_SAFE_C_opSq: - set_opt3_pair (expr, cadr (arg1)); - set_opt3_sym (cdr (expr), cadadr (arg1)); - return (OP_SAFE_C_op_opSqq); - case OP_SAFE_C_S_opSq: - set_opt3_pair (expr, caddr (arg1)); - return (OP_SAFE_C_op_S_opSqq); - case OP_SAFE_C_opSq_S: - set_opt3_pair (expr, cadr (arg1)); - return (OP_SAFE_C_op_opSq_Sq); - } - return (OP_SAFE_C_P); /* this splits out to A in optimize_func one_arg */ - - case combine_sp: - switch (op_no_hop (arg2)) { - 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_SC: - set_opt2_con (cdr (expr), caddr (arg2)); - 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 (arg2)); - return (OP_SAFE_C_S_opCSq); - case OP_SAFE_C_SS: /* (* a (- b c)) */ - set_opt2_sym (cdr (expr), caddr (arg2)); - 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 combine_ps: - switch (op_no_hop (arg1)) { - case OP_SAFE_C_S: - set_opt1_sym (cdr (expr), cadr (arg1)); - set_opt3_sym (expr, arg2); - 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 (arg1)); - return (OP_SAFE_C_op_opSSqq_S); - } - return (OP_SAFE_C_PS); - - case combine_pc: - switch (op_no_hop (arg1)) { - case OP_SAFE_C_S: - set_opt1_sym (cdr (expr), cadr (arg1)); - set_opt2_con (cdr (expr), arg2); - 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 combine_cp: - switch (op_no_hop (arg2)) { - case OP_SAFE_C_S: - set_opt3_pair (expr, arg2); - return (OP_SAFE_C_C_opSq); - case OP_SAFE_C_SC: - set_opt1_sym (cdr (expr), cadr (arg2)); - set_opt2_con (cdr (expr), caddr (arg2)); - return (OP_SAFE_C_C_opSCq); - case OP_SAFE_C_SS: - set_opt1_sym (cdr (expr), cadr (arg2)); - return (OP_SAFE_C_C_opSSq); - } - return (OP_SAFE_C_CP); - - case combine_pp: - switch (op_no_hop (arg2)) { - case OP_SAFE_C_S: - if (is_safe_c_s (arg1)) return (OP_SAFE_C_opSq_opSq); - if (optimize_op_match (arg1, OP_SAFE_C_SS)) return (OP_SAFE_C_opSSq_opSq); - break; - case OP_SAFE_C_SS: - if (optimize_op_match (arg1, OP_SAFE_C_SS)) - return (OP_SAFE_C_opSSq_opSSq); - if (is_safe_c_s (arg1)) return (OP_SAFE_C_opSq_opSSq); - break; - } - return (OP_SAFE_C_PP); +#define return_true(Sc, Expr) return(return_true_1(Sc, Expr, __func__, __LINE__)) +static bool return_true_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 blue_text, func, line, unbold_text uncolor_text, display_truncated(expr)); + else fprintf(stderr, " %s%s[%d]%s: true\n", blue_text, func, line, uncolor_text); + return(true); +} - default: - break; - } - return (OP_UNOPT); +#define return_success(Sc, P, Expr) return(return_success_1(Sc, P, Expr, __func__, __LINE__)) +static s7_pfunc return_success_1(s7_scheme *sc, s7_pfunc p, s7_pointer expr, const char *func, int32_t line) +{ + fprintf(stderr, " %s%s[%d]%s: %s\n", bold_text green_text, func, line, unbold_text uncolor_text, display(expr)); + return(p); } -static bool -arg_findable (s7_scheme* sc, s7_pointer arg1, s7_pointer let_or_list) { - if (pair_symbol_is_safe (sc, arg1, let_or_list)) - return (true); /* includes global_slot check */ - return ((!sc->in_with_let) && (is_bound_symbol (sc, arg1))); +#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, int32_t line) +{ + fprintf(stderr, " %s%s[%d]%s: %s\n %sfailure%s\n", bold_text, func, line, unbold_text, display_truncated(expr), bold_text red_text, unbold_text uncolor_text); + return(NULL); } -static bool -symbol_is_safe (s7_scheme* sc, s7_pointer arg, s7_pointer let_or_list) { - if (is_symbol (arg)) /* maybe normal here but check clo* key (see below) */ - { - if (is_keyword (arg)) return (true); - if (sc->in_with_let) return (pair_symbol_is_safe (sc, arg, let_or_list)); - if (is_slot (global_slot (arg))) return (true); - if ((!symbol_is_in_big_symbol_set (sc, arg)) && - (!arg_findable (sc, arg, let_or_list))) - return (false); - } - return (true); +#define return_bool(Sc, Bool, Expr) return(return_bool_1(Sc, Bool, Expr, __func__, __LINE__)) +static bool return_bool_1(s7_scheme *sc, bool ok, s7_pointer expr, const char *func, int32_t line) +{ + if (expr) + fprintf(stderr, " %s%s[%d]%s: %s\n", (ok) ? bold_text blue_text : "", func, line, (ok)? unbold_text uncolor_text : "", display_truncated(expr)); + else fprintf(stderr, " %s%s[%d]%s: %s\n", (ok) ? blue_text : "", func, line, (ok)? uncolor_text : "", (ok) ? "true" : "false"); + return(ok); } +#else +#define return_false(Sc, Expr) return(false) +#define return_true(Sc, Expr) return(true) +#define return_success(Sc, P, Expr) return(P) +#define return_null(Sc, Expr) return(NULL) +#define return_bool(Sc, Bool, Expr) return(Bool) +#endif -static bool -safe_c_aa_to_ag_ga (s7_scheme* sc, s7_pointer arg, int32_t hop) { - const s7_pointer arg1p= cdr (arg), arg2p= cddr (arg); - if (fx_proc (arg2p) == fx_s) { - set_opt3_sym (arg, car (arg2p)); - set_safe_optimize_op (arg, hop + OP_SAFE_C_AS); - return (true); - } - if (fx_proc (arg1p) == fx_s) { - set_opt3_sym (arg, car (arg1p)); - set_safe_optimize_op (arg, hop + OP_SAFE_C_SA); - return (true); - } - if (fx_proc (arg2p) == fx_c) { - set_opt3_con (arg, car (arg2p)); - set_safe_optimize_op (arg, hop + OP_SAFE_C_AC); - return (true); - } - if (fx_proc (arg1p) == fx_c) { - set_opt3_con (arg, car (arg1p)); - set_safe_optimize_op (arg, hop + OP_SAFE_C_CA); - return (true); - } - if (fx_proc (arg2p) == fx_q) { - set_opt3_con (arg, cadar (arg2p)); - set_safe_optimize_op (arg, hop + OP_SAFE_C_AC); - return (true); - } - if (fx_proc (arg1p) == fx_q) { - set_opt3_con (arg, cadar (arg1p)); - set_safe_optimize_op (arg, hop + OP_SAFE_C_CA); - return (true); - } - return (false); +static s7_pointer opt_integer_symbol(s7_scheme *sc, s7_pointer sym) +{ + if (is_symbol(sym)) + { + s7_pointer slot = s7_slot(sc, sym); + if ((is_slot(slot)) && /* here and below, p can be # (if in rootlet) */ + (is_t_integer(slot_value(slot)))) + return(slot); + } + return(NULL); } -static opt_t -check_c_aa (s7_scheme* sc, s7_pointer expr, s7_pointer func, int32_t hop, - s7_pointer let_or_list) { - fx_annotate_args (sc, cdr (expr), let_or_list); - 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_ok); -} - -static opt_t -wrap_bad_args (s7_scheme* sc, s7_pointer func, s7_pointer expr, int32_t n_args, - int32_t hop, s7_pointer let_or_list) { - set_opt3_arglen (cdr (expr), 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, let_or_list)); - } - set_class_and_fn_proc (expr, func); - return (opt_ok); - } - if ((is_closure (func)) && (!arglist_has_rest (sc, closure_pars (func)))) { - const s7_pointer body = closure_body (func); - const 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_bad); - } - if ((is_closure_star (func)) && (lambda_has_simple_defaults (func)) && - (closure_star_arity_to_int (sc, func) >= n_args) && - (!arglist_has_rest (sc, closure_pars (func)))) { - const bool safe_case= is_safe_closure (func); - set_unsafely_optimized (expr); - if (n_args == 1) - set_optimize_op ( - expr, ((safe_case) ? OP_SAFE_CLOSURE_STAR_A : OP_CLOSURE_STAR_A)); - else if (closure_star_arity_to_int (sc, func) == 2) - set_optimize_op (expr, - ((safe_case) ? ((is_null (cdr (closure_body (func)))) - ? OP_SAFE_CLOSURE_STAR_AA_O - : /* aa_a was not faster */ - OP_SAFE_CLOSURE_STAR_AA) - : OP_CLOSURE_STAR_NA)); - else - set_optimize_op (expr, (safe_case) ? OP_SAFE_CLOSURE_STAR_NA - : OP_CLOSURE_STAR_NA); - set_opt1_lambda_add (expr, func); - } - return (opt_bad); -} - -static inline s7_pointer -find_uncomplicated_symbol (s7_scheme* sc, s7_pointer symbol, - s7_pointer symbols) { - if ((symbol_is_in_big_symbol_set (sc, symbol)) && - (direct_memq (symbol, - symbols))) /* it's probably a local variable reference */ - return (sc->nil); - /* ((!symbol_is_in_big_symbol_set(sc, symbol)) && (direct_memq(symbol, - * symbols))) 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 big_symbol_set when recursive call is encountered) -- tricky to fix - */ - if (is_defined_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_big_symbol_set (sc, symbol_to_keyword (sc, symbol)))) - return (sc->nil); - { - s7_pointer let= sc->curlet; - s7_int id = symbol_id (symbol); - for (; let_id (let) > id; let= let_outlet (let)) - ; - for (; let; let= let_outlet (let)) { - if (let_id (let) == id) return (local_slot (symbol)); - for (s7_pointer slot= let_slots (let); is_not_slot_end (slot); - slot = next_slot (slot)) - if (slot_symbol (slot) == symbol) return (slot); +static s7_pointer opt_real_symbol(s7_scheme *sc, s7_pointer sym) +{ + if (is_symbol(sym)) + { + s7_pointer slot = s7_slot(sc, sym); + if ((is_slot(slot)) && + (is_small_real(slot_value(slot)))) + return(slot); } - } - return (global_slot (symbol)); /* it's no longer global perhaps (local - definition now inaccessible) */ + return(NULL); } -static bool -tree_has_escaper (s7_scheme* sc, s7_pointer tree, s7_pointer cc) { - if (is_pair (tree)) { - if (is_escaper (car (tree))) return (true); - if ((is_pair (car (tree))) && (tree_has_escaper (sc, car (tree), cc))) - return (true); - for (s7_pointer p= cdr (tree); is_pair (p); p= cdr (p)) { - if (car (p) == cc) return (true); - if ((is_pair (car (p))) && (tree_has_escaper (sc, car (p), cc))) - return (true); +static s7_pointer opt_float_symbol(s7_scheme *sc, s7_pointer sym) +{ + if (is_symbol(sym)) + { + s7_pointer slot = s7_slot(sc, sym); + if ((is_slot(slot)) && + (is_t_real(slot_value(slot)))) + return(slot); } - } - else if (tree == cc) return (true); - return (false); + return(NULL); } -static bool -is_ok_lambda (s7_scheme* sc, s7_pointer arg2) { - return ((is_pair (arg2)) && - (is_lambda (sc, car (arg2))) && /* must start (lambda ...) */ - (is_pair (cdr (arg2))) && /* must have arg(s) */ - (is_pair (cddr (arg2))) && /* must have body */ - (s7_is_proper_list (sc, cdddr (arg2)))); +static s7_pointer opt_simple_symbol(s7_scheme *sc, s7_pointer sym) +{ + s7_pointer slot = s7_slot(sc, sym); + if ((is_slot(slot)) && + (!has_methods(slot_value(slot)))) + return(slot); + return(NULL); } -static bool -hop_if_constant (s7_scheme* sc, s7_pointer sym) { - /* "sym" is a symbol here. c_functions set hop=1 in optimize_expression */ - return ( - ((!sc->in_with_let) && (!is_maybe_shadowed (sym)) && (is_global (sym))) - ? 1 - : 0); /* for with-let, see s7test atanh (77261) */ -} - -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 let_or_list) { - const s7_pointer arg1 = cadr (expr); - const bool func_is_safe= is_safe_procedure (func); - if (hop == 0) hop= hop_if_constant (sc, car (expr)); - if (SHOW_EVAL_OPS) - fprintf (stderr, " %s[%d]: %s, func_is_safe: %d, pairs: %d, hop: %d\n", - __func__, __LINE__, display_truncated (expr), func_is_safe, pairs, - hop); - if (pairs == 0) { - if ((func_is_safe) || - (c_function_call (func) == g_values)) /* 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_ok); - } - /* 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), let_or_list); - set_opt3_arglen (cdr (expr), 1); - } - 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)); +static s7_pointer opt_types_match(s7_scheme *sc, s7_pointer check, s7_pointer sym) +{ + s7_pointer checker = s7_symbol_value(sc, check); + s7_pointer slot = s7_slot(sc, sym); + if (is_slot(slot)) + { + s7_pointer obj = slot_value(slot); + if (s7_apply_function(sc, checker, set_plist_1(sc, obj)) == sc->T) + return(slot); + } + return(NULL); +} + +static s7_pointer opt_bool_any(s7_scheme *sc) {opt_info *o = sc->opts[0]; return((q_call(o).fb(o)) ? sc->T : sc->F);} +static s7_pointer opt_float_any_nv(s7_scheme *sc) {opt_info *o = sc->opts[0]; q_call(o).fd(o); return(NULL);} +static s7_pointer opt_int_any_nv(s7_scheme *sc) {opt_info *o = sc->opts[0]; q_call(o).fi(o); return(NULL);} +static s7_pointer opt_bool_any_nv(s7_scheme *sc) {opt_info *o = sc->opts[0]; q_call(o).fb(o); return(NULL);} +static s7_pointer opt_cell_any_nv(s7_scheme *sc) {opt_info *o = sc->opts[0]; return(q_call(o).fp(o));} /* this is faster than returning null */ + +static s7_pointer opt_make_float(s7_scheme *sc) {opt_info *o = sc->opts[0]; return(make_real(sc, q_call(o).fd(o)));} +static s7_pointer opt_make_int(s7_scheme *sc) {opt_info *o = sc->opts[0]; return(make_integer(sc, q_call(o).fi(o)));} +static s7_pointer opt_wrap_cell(s7_scheme *sc) {opt_info *o = sc->opts[0]; return(q_call(o).fp(o));} +static s7_pointer opt_wrap_bool(s7_scheme *sc) {opt_info *o = sc->opts[0]; return((q_call(o).fb(o)) ? sc->T : sc->F);} + +static bool p_to_b(opt_info *o) {return(q_temp(o).fp(o) != o->sc->F);} +static s7_pointer d_to_p(opt_info *o) {return(make_real(o->sc, q_temp(o).fd(o)));} +static s7_pointer d_to_p_nr(opt_info *o) {q_temp(o).fd(o); return(NULL);} +static s7_pointer i_to_p(opt_info *o) {return(make_integer(o->sc, q_temp(o).fi(o)));} +static s7_pointer i_to_p_nr(opt_info *o) {q_temp(o).fi(o); return(NULL);} + +#define q_arg1(o) o->v[1] +#define q_arg2(o) o->v[2] +#define q_arg3(o) o->v[12] +#define q_arg4(o) o->v[13] +#define q_arg5(o) o->v[14] /* 14 shared with q_temp, q_sort maybe others */ +#define q_func(o) o->v[3] +#define q_func1(o) o->v[5] +#define q_func1_arg(o) o->v[4] +#define q_func2(o) o->v[11] +#define q_func2_arg(o) o->v[10] +#define q_func3(o) o->v[9] +#define q_func3_arg(o) o->v[8] +#define q_func4(o) o->v[7] +#define q_func4_arg(o) o->v[6] + +#define q_i_func1_call(o) q_func1(o).fi(q_func1_arg(o).o1) +#define q_d_func1_call(o) q_func1(o).fd(q_func1_arg(o).o1) +#define q_b_func1_call(o) q_func1(o).fb(q_func1_arg(o).o1) +#define q_p_func1_call(o) q_func1(o).fp(q_func1_arg(o).o1) + +#define q_i_func2_call(o) q_func2(o).fi(q_func2_arg(o).o1) +#define q_d_func2_call(o) q_func2(o).fd(q_func2_arg(o).o1) +#define q_b_func2_call(o) q_func2(o).fb(q_func2_arg(o).o1) +#define q_p_func2_call(o) q_func2(o).fp(q_func2_arg(o).o1) + +#define q_i_func3_call(o) q_func3(o).fi(q_func3_arg(o).o1) +#define q_d_func3_call(o) q_func3(o).fd(q_func3_arg(o).o1) +#define q_b_func3_call(o) q_func3(o).fb(q_func3_arg(o).o1) /* none?? */ +#define q_p_func3_call(o) q_func3(o).fp(q_func3_arg(o).o1) + +#define q_i_func4_call(o) q_func4(o).fi(q_func4_arg(o).o1) +#define q_d_func4_call(o) q_func4(o).fd(q_func4_arg(o).o1) +#define q_b_func4_call(o) q_func4(o).fb(q_func4_arg(o).o1) /* none?? */ +#define q_p_func4_call(o) q_func4(o).fp(q_func4_arg(o).o1) + +/* TODO: also q_func(o).call -> q_func_call(o) */ + + +/* -------------------------------- int opts -------------------------------- */ + +static s7_int opt_i_c(opt_info *o) {return(q_arg1(o).i);} +static s7_int opt_i_s(opt_info *o) {return(integer(slot_value(q_arg1(o).p)));} + +static bool opt_int_not_pair(s7_scheme *sc, s7_pointer expr) +{ + opt_info *opc; + if (is_t_integer(expr)) + { + opc = alloc_opt_info(sc); + q_arg1(opc).i = integer(expr); + q_call(opc).fi = opt_i_c; + return_true(sc, expr); } - choose_c_function (sc, expr, func, 1); - return (opt_bad); + { + s7_pointer slot = opt_integer_symbol(sc, expr); + if (!slot) return_false(sc, expr); + opc = alloc_opt_info(sc); + q_arg1(opc).p = slot; + q_call(opc).fi = opt_i_s; } - /* pairs == 1 */ - if (bad_pairs == 0) { - if (func_is_safe) { - const int32_t op= combine_ops (sc, expr, combine_p, arg1, NULL); - if ((hop == 1) && (!op_has_hop (arg1)) && (is_symbol (car (arg1))) && - (is_maybe_shadowed ( - car (arg1)))) /* else maybe c_function with even_args bit! */ - { - hop= 0; - if (!is_symbol ( - car (expr))) /* calling op was optimized to #_ previously, but - now we notice its argument is problematic?! */ - set_car (expr, c_function_symbol (car (expr))); - /* maybe symbol_initial_value(...) -- but both can differ from - * global_value, (set! abs 32) (#_abs -1) */ - /* maybe return(opt_bad); or dependent on is_maybe_shadowed? */ - /* probably not the right way to fix this (s7test tc_or_a_and_a_a_la), - * but (define + *) needs this */ - } - set_safe_optimize_op (expr, hop + op); + return_true(sc, expr); +} - 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), let_or_list); - } - choose_c_function (sc, expr, func, 1); -#if 0 - /* works, not much impact? see check_c_aa, optimize_func_one|two|three_args for safe_c_functions */ - /* also, need wrapped field c_proc_t so this doesn't need to check each case by hand */ - if (has_fn(arg1)) +/* -------- i_i|d|p -------- */ + +static s7_int opt_i_i_c(opt_info *o) {return(q_func(o).i_i_f(q_arg1(o).i));} +static s7_int opt_i_i_s(opt_info *o) {return(q_func(o).i_i_f(integer(slot_value(q_arg1(o).p))));} +static s7_int opt_i_7i_c(opt_info *o) {return(q_func(o).i_7i_f(o->sc, q_arg1(o).i));} +static s7_int opt_i_7i_s(opt_info *o) {return(q_func(o).i_7i_f(o->sc, integer(slot_value(q_arg1(o).p))));} +static s7_int opt_i_7i_s_rand(opt_info *o) {return(random_i_7i(o->sc, integer(slot_value(q_arg1(o).p))));} +static s7_int opt_i_d_c(opt_info *o) {return(q_func(o).i_7d_f(o->sc, q_arg1(o).x));} +static s7_int opt_i_d_s(opt_info *o) {return(q_func(o).i_7d_f(o->sc, real(slot_value(q_arg1(o).p))));} + +static s7_int opt_i_i_f(opt_info *o) {return(q_func(o).i_i_f(q_i_func1_call(o)));} +static s7_int opt_i_7i_f(opt_info *o) {return(q_func(o).i_7i_f(o->sc, q_i_func1_call(o)));} +static s7_int opt_i_7d_f(opt_info *o) {return(q_func(o).i_7d_f(o->sc, q_d_func1_call(o)));} +static s7_int opt_i_7p_f(opt_info *o) {return(q_func(o).i_7p_f(o->sc, q_p_func1_call(o)));} +static s7_int opt_i_7p_f_cint(opt_info *o) {return(char_to_integer_i_7p(o->sc, q_p_func1_call(o)));} /* from opt_set_p_i_f */ + +static s7_int opt_i_i_s_abs(opt_info *o) {return(abs_i_i(integer(slot_value(q_arg1(o).p))));} +static s7_int opt_i_i_f_abs(opt_info *o) {return(abs_i_i(q_i_func1_call(o)));} + +static bool int_optimize(s7_scheme *sc, s7_pointer expr); +static bool float_optimize(s7_scheme *sc, s7_pointer expr); + +static bool i_idp_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) +{ + const s7_i_i_t func = s7_i_i_function(s_func); + s7_i_7i_t func7 = NULL; + s7_pointer arg1_slot; + const s7_pointer arg1 = cadr(expr); + const int32_t start = sc->pc; + q_func1_arg(opc).o1 = sc->opts[start]; + if (!func) + func7 = s7_i_7i_function(s_func); + if ((func) || (func7)) + { + if (func) + q_func(opc).i_i_f = func; + else q_func(opc).i_7i_f = func7; + if (is_t_integer(arg1)) + { + if (q_func(opc).i_i_f == subtract_i_i) { - if (fn_proc(arg1) == g_multiply_2) set_fn_direct(arg1, g_multiply_2_wrapped); - if (fn_proc(arg1) == g_subtract_2) set_fn_direct(arg1, g_subtract_2_wrapped); + q_arg1(opc).i = -integer(arg1); + q_call(opc).fi = opt_i_c; + } + else + { + q_arg1(opc).i = integer(arg1); + q_call(opc).fi = (func) ? opt_i_i_c : opt_i_7i_c; + } + return_true(sc, expr); + } + arg1_slot = opt_integer_symbol(sc, arg1); + if (arg1_slot) + { + q_arg1(opc).p = arg1_slot; + q_call(opc).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(sc, expr); + } + if (int_optimize(sc, cdr(expr))) + { + q_func1(opc).fi = q_call(sc->opts[start]).fi; + q_call(opc).fi = (func) ? ((func == abs_i_i) ? opt_i_i_f_abs : opt_i_i_f) : opt_i_7i_f; + return_true(sc, expr); + } + sc->pc = start; + } + if (!is_t_ratio(arg1)) + { + const s7_i_7d_t idf = s7_i_7d_function(s_func); + if (idf) + { + q_func(opc).i_7d_f = idf; + if (is_small_real(arg1)) + { + q_arg1(opc).x = s7_number_to_real(sc, arg1); + q_call(opc).fi = opt_i_d_c; + return_true(sc, expr); + } + arg1_slot = opt_float_symbol(sc, arg1); + if (arg1_slot) + { + q_arg1(opc).p = arg1_slot; + q_call(opc).fi = opt_i_d_s; + return_true(sc, expr); + } + if (float_optimize(sc, cdr(expr))) + { + q_call(opc).fi = opt_i_7d_f; + q_func1(opc).fd = q_call(sc->opts[start]).fd; + return_true(sc, expr); + } + sc->pc = start; + }} + { + s7_i_7p_t ipf = s7_i_7p_function(s_func); + if (ipf) + { + q_func(opc).i_7p_f = ipf; + if (cell_optimize(sc, cdr(expr))) + { + q_call(opc).fi = (ipf == char_to_integer_i_7p) ? opt_i_7p_f_cint : opt_i_7p_f; + q_func1(opc).fp = q_call(sc->opts[start]).fp; + return_true(sc, expr); + } + sc->pc = start; + }} + return_false(sc, expr); +} + +/* -------- i_pi -------- */ + +static s7_int opt_i_7pi_ss(opt_info *o) {return(q_func(o).i_7pi_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))));} +static s7_int opt_i_pi_ss_ivref(opt_info *o) {return(int_vector(slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))));} +static s7_int opt_i_pi_ss_bvref(opt_info *o) {return(byte_vector(slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))));} +static s7_int opt_i_7pi_sf(opt_info *o) {return(q_func(o).i_7pi_f(o->sc, slot_value(q_arg1(o).p), q_i_func2_call(o)));} + +/* how can i_7pi_ss be hit? */ + +static bool i_7pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, const s7_pointer expr) +{ + s7_pointer sig; + s7_i_7pi_t pfunc = s7_i_7pi_function(s_func); + if (!pfunc) + { + if ((is_eq_initial_c_function_data(sc->vector_ref_symbol, s_func)) && + (is_normal_symbol(cadr(expr)))) /* (vector-ref )? */ + { + const s7_pointer v_slot = s7_slot(sc, cadr(expr)); + if (is_slot(v_slot)) + { + const s7_pointer vec = slot_value(v_slot); + if (is_int_vector(vec)) + { + pfunc = int_vector_ref_i_7pi; + s_func = initial_value(sc->int_vector_ref_symbol); + /* a normal vector can have vector-typer integer? if it's set after vector creation, but that can't be optimized much */ + } + else + if (is_byte_vector(vec)) + { + pfunc = byte_vector_ref_i_7pi; + s_func = initial_value(sc->byte_vector_ref_symbol); + }}} + if (!pfunc) return_false(sc, expr); + } + sig = c_function_signature(s_func); + if (is_pair(sig)) + { + s7_pointer slot; + const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); + const int32_t start = sc->pc; + if ((is_symbol(cadr(sig))) && + (is_symbol(arg1)) && + (slot = opt_types_match(sc, cadr(sig), arg1))) + { + s7_pointer arg2_slot; + q_arg1(opc).p = slot; + if ((s_func == global_value(sc->int_vector_ref_symbol)) && /* ivref etc */ + ((!is_int_vector(slot_value(slot))) || + (vector_rank(slot_value(slot)) > 1))) + return_false(sc, expr); + if ((s_func == global_value(sc->byte_vector_ref_symbol)) && /* bvref etc */ + ((!is_byte_vector(slot_value(slot))) || + (vector_rank(slot_value(slot)) > 1))) + return_false(sc, expr); + + q_func(opc).i_7pi_f = pfunc; + arg2_slot = opt_integer_symbol(sc, arg2); + if (arg2_slot) + { + q_arg2(opc).p = arg2_slot; + q_call(opc).fi = opt_i_7pi_ss; + if ((s_func == global_value(sc->int_vector_ref_symbol)) && + (loop_end_fits(q_arg2(opc).p, vector_length(slot_value(q_arg1(opc).p))))) + { + q_call(opc).fi = opt_i_pi_ss_ivref; + q_func(opc).i_7pi_f = int_vector_ref_i_pi_direct; + } + else + if ((s_func == global_value(sc->byte_vector_ref_symbol)) && + (loop_end_fits(q_arg2(opc).p, vector_length(slot_value(q_arg1(opc).p))))) + { + q_call(opc).fi = opt_i_pi_ss_bvref; + q_func(opc).i_7pi_f = byte_vector_ref_i_7pi_direct; + } + return_true(sc, expr); + } + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + q_call(opc).fi = opt_i_7pi_sf; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; /* q_call(o1)? */ + return_true(sc, expr); + } + sc->pc = start; + }} + return_false(sc, expr); +} + +/* -------- i_ii -------- */ + +static s7_int opt_i_ii_cc(opt_info *o) {return(q_func(o).i_ii_f(q_arg1(o).i, q_arg2(o).i));} +static s7_int opt_i_ii_cs(opt_info *o) {return(q_func(o).i_ii_f(q_arg1(o).i, integer(slot_value(q_arg2(o).p))));} +static s7_int opt_i_ii_cs_mul(opt_info *o) {return(q_arg1(o).i * integer(slot_value(q_arg2(o).p)));} +static s7_int opt_i_ii_sc(opt_info *o) {return(q_func(o).i_ii_f(integer(slot_value(q_arg1(o).p)), q_arg2(o).i));} +static s7_int opt_i_ii_sc_add(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) + q_arg2(o).i);} /* +1 is not faster */ +static s7_int opt_i_ii_sc_sub(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) - q_arg2(o).i);} /* -1 is not faster */ +static s7_int opt_i_ii_ss(opt_info *o) {return(q_func(o).i_ii_f(integer(slot_value(q_arg1(o).p)), integer(slot_value(q_arg2(o).p))));} +static s7_int opt_i_ii_ss_add(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) + integer(slot_value(q_arg2(o).p)));} +static s7_pointer opt_p_ii_ss_add(opt_info *o) {return(make_integer(o->sc, integer(slot_value(q_arg1(o).p)) + integer(slot_value(q_arg2(o).p))));} +static s7_int opt_i_ii_cf(opt_info *o) {return(q_func(o).i_ii_f(q_arg1(o).i, q_i_func2_call(o)));} +static s7_int opt_i_ii_cf_mul(opt_info *o) {return(q_arg1(o).i * q_i_func2_call(o));} +static s7_int opt_i_ii_sf(opt_info *o) {return(q_func(o).i_ii_f(integer(slot_value(q_arg1(o).p)), q_i_func2_call(o)));} +static s7_int opt_i_ii_sf_add(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) + q_i_func2_call(o));} +static s7_int opt_i_ii_fc(opt_info *o) {return(q_func(o).i_ii_f(q_i_func1_call(o), q_arg2(o).i));} +static s7_int opt_i_ii_fc_add(opt_info *o) {return(q_i_func1_call(o) + q_arg2(o).i);} +static s7_int opt_i_ii_fc_mul(opt_info *o) {return(q_i_func1_call(o) * q_arg2(o).i);} +/* returning s7_int so overflow->real is not doable here, so + * (define (func) (do ((x 0) (i 0 (+ i 1))) ((= i 1) x) (set! x (* (lognot 4294967297) 4294967297)))) (func) (func) + * will return -12884901890 rather than -18446744086594454000.0, 4294967297 > sqrt(fixmost) + * This affects all the opt arithmetical functions. Unfortunately the gmp version also gets -12884901890! + * We need to make sure none of these are available in the gmp version. + */ + +static s7_int opt_i_ii_ff(opt_info *o) {return(q_func(o).i_ii_f(q_i_func1_call(o), q_i_func2_call(o)));} +static s7_int opt_i_7ii_ff_quo(opt_info *o) {return(quotient_i_7ii(o->sc, q_i_func1_call(o), q_i_func2_call(o)));} +static s7_int opt_i_7ii_fc(opt_info *o) {return(q_func(o).i_7ii_f(o->sc, q_i_func1_call(o), q_arg2(o).i));} + +static s7_int opt_i_ii_fco(opt_info *o) +{ + return(q_func(o).i_ii_f(q_func1(o).i_7pi_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))), q_arg3(o).i)); +} + +static s7_int opt_i_ii_fco_ivref_add(opt_info *o) +{ + return(int_vector_ref_i_pi_direct(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))) + q_arg3(o).i); +} /* tref */ + +static s7_int opt_i_7ii_fco(opt_info *o) +{ + return(q_func(o).i_7ii_f(o->sc, q_func1(o).i_7pi_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))), q_arg3(o).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 ((q_call(o1).fi == opt_i_7pi_ss) || (q_call(o1).fi == opt_i_pi_ss_ivref)) + { + q_arg3(opc).i = q_arg2(opc).i; + q_func1(opc).i_7pi_f = q_func(o1).i_7pi_f; + q_arg1(opc).p = q_arg1(o1).p; + q_arg2(opc).p = q_arg2(o1).p; + if (func) + q_call(opc).fi = ((q_func(opc).i_ii_f == add_i_ii) && + (q_func1(opc).i_7pi_f == int_vector_ref_i_pi_direct)) ? opt_i_ii_fco_ivref_add : opt_i_ii_fco; + else q_call(opc).fi = opt_i_7ii_fco; + backup_pc(sc); + return_true(sc, NULL); + }} + return_false(sc, NULL); +} + +static s7_int opt_i_7ii_cc(opt_info *o) {return(q_func(o).i_7ii_f(o->sc, q_arg1(o).i, q_arg2(o).i));} +static s7_int opt_i_7ii_cs(opt_info *o) {return(q_func(o).i_7ii_f(o->sc, q_arg1(o).i, integer(slot_value(q_arg2(o).p))));} +static s7_int opt_i_7ii_sc(opt_info *o) {return(q_func(o).i_7ii_f(o->sc, integer(slot_value(q_arg1(o).p)), q_arg2(o).i));} +static s7_int opt_i_7ii_ss(opt_info *o) {return(q_func(o).i_7ii_f(o->sc, integer(slot_value(q_arg1(o).p)), integer(slot_value(q_arg2(o).p))));} +static s7_int opt_i_7ii_cf(opt_info *o) {return(q_func(o).i_7ii_f(o->sc, q_arg1(o).i, q_i_func2_call(o)));} +static s7_int opt_i_7ii_sf(opt_info *o) {return(q_func(o).i_7ii_f(o->sc, integer(slot_value(q_arg1(o).p)), q_i_func2_call(o)));} + +static s7_int opt_i_7ii_ff(opt_info *o) +{ + s7_int i1 = q_i_func1_call(o); + s7_int i2 = q_i_func2_call(o); + return(q_func(o).i_7ii_f(o->sc, i1, i2)); +} + +static s7_int opt_add_i_random_i(opt_info *o) {return(q_arg1(o).i + (s7_int)(q_arg2(o).i * next_random(o->sc->default_random_state)));} +static s7_int opt_subtract_random_i_i(opt_info *o) {return((s7_int)(q_arg1(o).i * next_random(o->sc->default_random_state)) - q_arg2(o).i);} + +static bool i_ii_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) +{ + const s7_i_ii_t ifunc = s7_i_ii_function(s_func); + s7_i_7ii_t ifunc7 = NULL; + s7_pointer sig; + + if (!ifunc) + { + ifunc7 = s7_i_7ii_function(s_func); + if (!ifunc7) + return_false(sc, expr); + } + sig = c_function_signature(s_func); + if (is_pair(sig)) + { + const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); + const int32_t start = sc->pc; + s7_pointer arg1_slot, arg2_slot; + if (ifunc) + q_func(opc).i_ii_f = ifunc; + else q_func(opc).i_7ii_f = ifunc7; + + if (is_t_integer(arg1)) + { + q_arg1(opc).i = integer(arg1); + if (is_t_integer(arg2)) + { + if (q_func(opc).i_ii_f == add_i_ii) + { + q_arg1(opc).i = integer(arg1) + integer(arg2); /* no overflow check for sc_add case above */ + q_call(opc).fi = opt_i_c; + } + else + { + q_arg2(opc).i = integer(arg2); + q_call(opc).fi = (ifunc) ? opt_i_ii_cc : opt_i_7ii_cc; + } + return_true(sc, expr); + } + arg2_slot = opt_integer_symbol(sc, arg2); + if (arg2_slot) + { + q_arg2(opc).p = arg2_slot; + if (ifunc) + q_call(opc).fi = (q_func(opc).i_ii_f == multiply_i_ii) ? opt_i_ii_cs_mul : opt_i_ii_cs; + else q_call(opc).fi = opt_i_7ii_cs; + return_true(sc, expr); + } + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + if (ifunc) + { + q_call(opc).fi = opt_i_ii_cf; /* caller(sc->opts[start]).fi -> opt_i_7i_c -> func(same_opt).i_7i_f = random_i_7i tmap */ + if ((ifunc == add_i_ii) && (opc == sc->opts[sc->pc - 2]) && + (q_call(sc->opts[start]).fi == opt_i_7i_c) && + (q_func(sc->opts[start]).i_7i_f == random_i_7i)) + { + q_call(opc).fi = opt_add_i_random_i; + q_arg2(opc).i = q_arg1(sc->opts[start]).i; + backup_pc(sc); + } + else if (ifunc == multiply_i_ii) q_call(opc).fi = opt_i_ii_cf_mul; + } + else q_call(opc).fi = opt_i_7ii_cf; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + return_true(sc, expr); + } + sc->pc = start; + return_false(sc, expr); + } + + /* arg1 not integer */ + arg1_slot = opt_integer_symbol(sc, arg1); + if (arg1_slot) + { + q_arg1(opc).p = arg1_slot; + if (is_t_integer(arg2)) + { + q_arg2(opc).i = integer(arg2); + if (ifunc) + { + if (q_func(opc).i_ii_f == add_i_ii) + q_call(opc).fi = opt_i_ii_sc_add; + else q_call(opc).fi = (q_func(opc).i_ii_f == subtract_i_ii) ? opt_i_ii_sc_sub : opt_i_ii_sc; /* add1/sub1 are not faster */ + } + else q_call(opc).fi = opt_i_7ii_sc; + if ((car(expr) == sc->modulo_symbol) && + (integer(arg2) > 1)) + q_func(opc).i_ii_f = modulo_i_ii_unchecked; + else + { + if (car(expr) == sc->ash_symbol) + { + if (q_arg2(opc).i < 0) + { + q_func(opc).i_ii_f = (q_arg2(opc).i == -1) ? rsh_i_i2_direct : rsh_i_ii_unchecked; + q_call(opc).fi = opt_i_ii_sc; + } + else + if (q_arg2(opc).i < S7_INT_BITS) + { + q_func(opc).i_ii_f = lsh_i_ii_unchecked; + q_call(opc).fi = opt_i_ii_sc; + }} + else + if (q_arg2(opc).i > 0) + { + /* these assume vunion is a union, not a struct; i_7ii_f otherwise might be leftover from a previous use */ + if (q_func(opc).i_7ii_f == quotient_i_7ii) + { + q_func(opc).i_ii_f = quotient_i_ii_unchecked; + q_call(opc).fi = opt_i_ii_sc; + } + else + if ((q_arg2(opc).i > 1) && (q_func(opc).i_7ii_f == remainder_i_7ii)) + { + q_func(opc).i_ii_f = remainder_i_ii_unchecked; + q_call(opc).fi = opt_i_ii_sc; + }}} + return_true(sc, expr); + } + + /* arg2 not integer, arg1 is int symbol */ + arg2_slot = opt_integer_symbol(sc, arg2); + if (arg2_slot) + { + q_arg2(opc).p = arg2_slot; + if (ifunc) + q_call(opc).fi = (q_func(opc).i_ii_f == add_i_ii) ? opt_i_ii_ss_add : opt_i_ii_ss; + else q_call(opc).fi = opt_i_7ii_ss; + return_true(sc, expr); + } + if (int_optimize(sc, cddr(expr))) + { + q_func2_arg(opc).o1 = sc->opts[start]; + q_func2(opc).fi = q_call(sc->opts[start]).fi; + if (ifunc) + q_call(opc).fi = (q_func(opc).i_ii_f == add_i_ii) ? opt_i_ii_sf_add : opt_i_ii_sf; + else q_call(opc).fi = opt_i_7ii_sf; + return_true(sc, expr); + } + sc->pc = start; + return_false(sc, expr); + } + + /* arg1 not int symbol */ + if (is_t_integer(arg2)) + { + q_arg2(opc).i = integer(arg2); + q_func1_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(expr))) + { + q_func1(opc).fi = q_func1_arg(opc).q_call(o1).fi; + if (!i_ii_fc_combinable(sc, opc, ifunc)) + { + if (ifunc) + { + if (q_func(opc).i_ii_f == add_i_ii) {q_call(opc).fi = opt_i_ii_fc_add; return_true(sc, expr);} + if (q_func(opc).i_ii_f == multiply_i_ii) {q_call(opc).fi = opt_i_ii_fc_mul; return_true(sc, expr);} + q_call(opc).fi = opt_i_ii_fc; + + if ((q_func(opc).i_ii_f == subtract_i_ii) && (opc == sc->opts[sc->pc - 2]) && + (q_call(sc->opts[start]).fi == opt_i_7i_c) && + (q_func(sc->opts[start]).i_7i_f == random_i_7i)) + { + q_call(opc).fi = opt_subtract_random_i_i; + q_arg1(opc).i = q_arg1(sc->opts[start]).i; + backup_pc(sc); + }} + else q_call(opc).fi = opt_i_7ii_fc; + if (q_arg2(opc).i > 0) + { + if (q_func(opc).i_7ii_f == quotient_i_7ii) + { + q_func(opc).i_ii_f = quotient_i_ii_unchecked; + q_call(opc).fi = opt_i_ii_fc; + } + else + if ((q_arg2(opc).i > 1) && (q_func(opc).i_7ii_f == remainder_i_7ii)) + { + q_func(opc).i_ii_f = remainder_i_ii_unchecked; + q_call(opc).fi = opt_i_ii_fc; + }}} + return_true(sc, expr); + } + sc->pc = start; + return_false(sc, expr); + } + + /* arg1 not integer or symbol, arg2 not integer */ + q_func1_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(expr))) + { + q_func1(opc).fi = q_func1_arg(opc).q_call(o1).fi; + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_call(opc).fi = (ifunc) ? opt_i_ii_ff : ((q_func(opc).i_7ii_f == quotient_i_7ii) ? opt_i_7ii_ff_quo : opt_i_7ii_ff); + return_true(sc, expr); + } + sc->pc = start; + }} + return_false(sc, expr); +} + +/* -------- i_iii -------- */ + +static s7_int opt_i_iii_fff(opt_info *o) +{ + s7_int i1 = q_i_func1_call(o); + s7_int i2 = q_i_func2_call(o); + s7_int i3 = q_i_func3_call(o); + return(q_func(o).i_iii_f(i1, i2, i3)); +} + +static bool i_iii_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) +{ + const int32_t start = sc->pc; + const s7_i_iii_t ifunc = s7_i_iii_function(s_func); + if (!ifunc) return_false(sc, expr); + q_func1_arg(opc).o1 = sc->opts[start]; + if (int_optimize(sc, cdr(expr))) + { + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdddr(expr))) + { + q_func(opc).i_iii_f = ifunc; + q_call(opc).fi = opt_i_iii_fff; + q_func1(opc).fi = q_func1_arg(opc).q_call(o1).fi; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func3(opc).fi = q_func3_arg(opc).q_call(o1).fi; + return_true(sc, expr); + }}} + sc->pc = start; + return_false(sc, expr); +} + +/* -------- i_7pii -------- */ + +static s7_int opt_i_7pii_ssf(opt_info *o) +{ + return(q_func(o).i_7pii_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), q_i_func1_call(o))); +} + +static s7_int opt_i_7pii_ssf_vset(opt_info *o) +{ + return(int_vector_set_i_7pii_direct(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), q_i_func1_call(o))); +} + +static s7_int opt_i_7pii_ssc(opt_info *o) +{ + return(q_func(o).i_7pii_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), q_arg3(o).i)); +} + +static s7_int opt_i_7pii_sss(opt_info *o) +{ + return(q_func(o).i_7pii_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), integer(slot_value(q_arg3(o).p)))); +} + +static s7_int opt_i_pii_sss_ivref_unchecked(opt_info *o) +{ + s7_pointer vec = slot_value(q_arg1(o).p); + return(int_vector(vec, ((integer(slot_value(q_arg2(o).p)) * vector_offset(vec, 0)) + integer(slot_value(q_arg3(o).p))))); +} + +static s7_int opt_i_7pii_sif(opt_info *o) +{ + return(q_func(o).i_7pii_f(o->sc, slot_value(q_arg1(o).p), q_arg2(o).i, q_i_func3_call(o))); +} + +static s7_int opt_i_7pii_sff(opt_info *o) +{ + s7_int i1 = q_i_func2_call(o); + s7_int i2 = q_i_func3_call(o); + return(q_func(o).i_7pii_f(o->sc, slot_value(q_arg1(o).p), i1, i2)); +} + +static bool is_target_or_its_alias(const s7_pointer symbol, const s7_pointer symfunc, s7_pointer target) +{ + return((symbol == target) || (is_eq_initial_value(target, symfunc))); +} + +static bool opt_int_vector_set(s7_scheme *sc, int32_t otype, opt_info *opc, s7_pointer v, s7_pointer indexp1, s7_pointer indexp2, s7_pointer valp); + +static bool i_7pii_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) +{ + s7_pointer sig; + const s7_i_7pii_t pfunc = s7_i_7pii_function(s_func); + if (!pfunc) return_false(sc, expr); + sig = c_function_signature(s_func); + if ((is_pair(sig)) && + (is_symbol(cadr(expr)))) + { + s7_pointer slot, fname = car(expr); + + 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(expr), cddr(expr), NULL, cdddr(expr))); + + slot = opt_types_match(sc, cadr(sig), cadr(expr)); + if (slot) + { + s7_pointer arg2, arg2_slot; + const int32_t start = sc->pc; + q_arg1(opc).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, expr); + + arg2 = caddr(expr); + arg2_slot = opt_integer_symbol(sc, arg2); + if (arg2_slot) + { + s7_pointer arg3_slot; + q_arg2(opc).p = arg2_slot; + arg3_slot = opt_integer_symbol(sc, cadddr(expr)); + if (arg3_slot) + { + q_arg3(opc).p = arg3_slot; + q_func(opc).i_7pii_f = pfunc; + q_call(opc).fi = opt_i_7pii_sss; + if ((pfunc == int_vector_ref_i_7pii) && + (loop_end_fits(q_arg2(opc).p, vector_dimension(slot_value(q_arg1(opc).p), 0))) && + (loop_end_fits(q_arg3(opc).p, vector_dimension(slot_value(q_arg1(opc).p), 1)))) + q_call(opc).fi = opt_i_pii_sss_ivref_unchecked; + return_true(sc, expr); + } + if (int_optimize(sc, cdddr(expr))) + { + q_func(opc).i_7pii_f = pfunc; + q_call(opc).fi = opt_i_7pii_ssf; + q_func1_arg(opc).o1 = sc->opts[start]; + q_func1(opc).fi = q_call(sc->opts[start]).fi; + return_true(sc, expr); + } + return_false(sc, expr); + } + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdddr(expr))) + { + q_func(opc).i_7pii_f = pfunc; + q_call(opc).fi = opt_i_7pii_sff; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func3(opc).fi = q_func3_arg(opc).q_call(o1).fi; + return_true(sc, expr); + }} + sc->pc = start; + }} + return_false(sc, expr); +} + +/* -------- i_7piii -------- */ + +static s7_int opt_i_7piii_sssf(opt_info *o) +{ + return(q_func(o).i_7piii_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), + integer(slot_value(q_arg3(o).p)), q_i_func3_call(o))); +} + +static s7_int opt_i_piii_sssf_ivset_unchecked(opt_info *o) +{ + s7_pointer vec = slot_value(q_arg1(o).p); + s7_int val = q_i_func3_call(o); + int_vector(vec, ((integer(slot_value(q_arg2(o).p)) * vector_offset(vec, 0)) + integer(slot_value(q_arg3(o).p)))) = val; + return(val); +} + +static s7_int opt_i_7piii_sssc(opt_info *o) +{ + return(q_func(o).i_7piii_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), + integer(slot_value(q_arg3(o).p)), q_arg4(o).i)); +} + +static s7_int opt_i_7piii_ssss(opt_info *o) +{ + return(q_func(o).i_7piii_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), + integer(slot_value(q_arg3(o).p)), integer(slot_value(q_arg4(o).p)))); +} + +static s7_int opt_i_7piii_sfff(opt_info *o) +{ + s7_int i1 = q_i_func2_call(o); + s7_int i2 = q_i_func3_call(o); + s7_int i3 = q_i_func4_call(o); + return(q_func(o).i_7piii_f(o->sc, slot_value(q_arg1(o).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->[5] is the called function (int-vector-set! etc) */ + s7_pointer slot2 = opt_integer_symbol(sc, car(indexp2)); + if (slot2) + { + s7_pointer slot1; + q_arg3(opc).p = slot2; + slot1 = opt_integer_symbol(sc, car(indexp1)); + if (slot1) + { + s7_pointer slot3; + q_arg2(opc).p = slot1; + if (is_t_integer(car(valp))) + { + q_call(opc).fi = opt_i_7piii_sssc; + q_arg4(opc).i = integer(car(valp)); + return_true(sc, NULL); + } + slot3 = opt_integer_symbol(sc, car(valp)); + if (slot3) + { + q_arg4(opc).p = slot3; + q_call(opc).fi = opt_i_7piii_ssss; + return_true(sc, NULL); + } + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, valp)) + { + q_func3(opc).fi = q_func3_arg(opc).q_call(o1).fi; + q_call(opc).fi = opt_i_7piii_sssf; + if ((q_func(opc).i_7piii_f == int_vector_set_i_7piii) && + (loop_end_fits(q_arg2(opc).p, vector_dimension(slot_value(q_arg1(opc).p), 0))) && + (loop_end_fits(q_arg3(opc).p, vector_dimension(slot_value(q_arg1(opc).p), 1)))) + q_call(opc).fi = opt_i_piii_sssf_ivset_unchecked; + return_true(sc, NULL); + }} + return_false(sc, valp); + } + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, indexp1)) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, indexp2)) + { + q_func4_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, valp)) + { + q_call(opc).fi = opt_i_7piii_sfff; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func3(opc).fi = q_func3_arg(opc).q_call(o1).fi; + q_func4(opc).fi = q_func4_arg(opc).q_call(o1).fi; + return_true(sc, NULL); + }}} + return_false(sc, indexp1); +} + +static bool opt_int_vector_set(s7_scheme *sc, int32_t otype, opt_info *opc, s7_pointer v, s7_pointer indexp1, s7_pointer indexp2, s7_pointer valp) +{ + s7_pointer settee = s7_slot(sc, v); + if ((is_slot(settee)) && + (!is_immutable(slot_value(settee)))) + { + const s7_pointer vect = slot_value(settee); + const bool int_case = (is_int_vector(vect)); + q_arg1(opc).p = settee; /* either ipii or ipiii arg1 */ + 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)) /* q_ipii case */ + { + s7_pointer slot; + q_func(opc).i_7pii_f = (int_case) ? int_vector_set_i_7pii : byte_vector_set_i_7pii; + slot = opt_integer_symbol(sc, car(indexp1)); + if (slot) + { + const int32_t start = sc->pc; + q_arg2(opc).p = slot; + if (loop_end_fits(q_arg2(opc).p, vector_length(vect))) + q_func(opc).i_7pii_f = (int_case) ? int_vector_set_i_7pii_direct : byte_vector_set_i_7pii_direct; + if ((is_pair(valp)) && + (is_null(cdr(valp))) && + (is_t_integer(car(valp)))) + { + q_arg3(opc).i = integer(car(valp)); + q_call(opc).fi = opt_i_7pii_ssc; + return_true(sc, NULL); + } + if (!int_optimize(sc, valp)) + return_false(sc, valp); + q_call(opc).fi = (q_func(opc).i_7pii_f == int_vector_set_i_7pii_direct) ? opt_i_7pii_ssf_vset : opt_i_7pii_ssf; + q_func1_arg(opc).o1 = sc->opts[start]; + q_func1(opc).fi = q_call(sc->opts[start]).fi; + return_true(sc, NULL); + } + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, indexp1)) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, valp)) + { + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func3(opc).fi = q_func3_arg(opc).q_call(o1).fi; + if (q_func2(opc).fi == opt_i_c) /* (int-vector-set! v 0 (floor (sqrt i))) */ + { + q_call(opc).fi = opt_i_7pii_sif; + q_arg2(opc).i = q_func2_arg(opc).q_arg1(o1).i; + } + else q_call(opc).fi = opt_i_7pii_sff; + return_true(sc, NULL); + }} + return_false(sc, valp); + } + if ((indexp2) && + (vector_rank(vect) == 2)) /* q_ipiii case */ + { + q_func(opc).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 i_implicit_ok(s7_scheme *sc, s7_pointer s_slot, s7_pointer expr, int32_t len) +{ + const s7_pointer obj = slot_value(s_slot); + if ((is_int_vector(obj)) || (is_byte_vector(obj))) + { + const bool int_case = is_int_vector(obj); + s7_pointer slot; + + if ((len == 2) && /* ipi case */ + (vector_rank(obj) == 1)) + { + opt_info *opc = alloc_opt_info(sc); + q_arg1(opc).p = s_slot; + slot = opt_integer_symbol(sc, cadr(expr)); + if (slot) + { + q_call(opc).fi = opt_i_7pi_ss; + q_func(opc).i_7pi_f = (int_case) ? int_vector_ref_i_7pi : byte_vector_ref_i_7pi; + q_arg2(opc).p = slot; + if (loop_end_fits(q_arg2(opc).p, vector_length(obj))) + q_func(opc).i_7pi_f = (int_case) ? int_vector_ref_i_pi_direct : byte_vector_ref_i_7pi_direct; + /* not q_call(opc).fi = opt_i_pi_ss_ivref -- this causes a huge slowdown in dup.scm?? */ + return_true(sc, expr); + } + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (!int_optimize(sc, cdr(expr))) + return_false(sc, expr); + q_call(opc).fi = opt_i_7pi_sf; + q_func(opc).i_7pi_f = (int_case) ? int_vector_ref_i_7pi : byte_vector_ref_i_7pi; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + return_true(sc, expr); + } + if ((len == 3) && /* ipii case */ + (vector_rank(obj) == 2)) + { + opt_info *opc = alloc_opt_info(sc); + q_arg1(opc).p = s_slot; + slot = opt_integer_symbol(sc, cadr(expr)); + if (slot) + { + q_arg2(opc).p = slot; + slot = opt_integer_symbol(sc, caddr(expr)); + if (!slot) + return_false(sc, expr); + q_func(opc).i_7pii_f = (int_case) ? int_vector_ref_i_7pii : byte_vector_ref_i_7pii; + q_arg3(opc).p = slot; + q_call(opc).fi = opt_i_7pii_sss; + if ((int_case) && + (loop_end_fits(q_arg2(opc).p, vector_dimension(obj, 0))) && + (loop_end_fits(q_arg3(opc).p, vector_dimension(obj, 1)))) + q_call(opc).fi = opt_i_pii_sss_ivref_unchecked; + return_true(sc, expr); + } + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(expr))) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + q_func(opc).i_7pii_f = (int_case) ? int_vector_ref_i_7pii : byte_vector_ref_i_7pii; + q_call(opc).fi = opt_i_7pii_sff; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func3(opc).fi = q_func3_arg(opc).q_call(o1).fi; + return_true(sc, expr); + }}}} + return_false(sc, expr); +} + +static bool i_7piii_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) +{ + const s7_i_7piii_t func = s7_i_7piii_function(s_func); + if ((func) && (is_symbol(cadr(expr)))) + { + s7_pointer settee; + if ((is_target_or_its_alias(car(expr), s_func, sc->int_vector_set_symbol)) || + (is_target_or_its_alias(car(expr), s_func, sc->byte_vector_set_symbol))) + return(opt_int_vector_set(sc, (car(expr) == sc->int_vector_set_symbol) ? 1 : 0, opc, cadr(expr), cddr(expr), cdddr(expr), cddddr(expr))); + + settee = s7_slot(sc, cadr(expr)); + if (is_slot(settee)) + { + s7_pointer vect = slot_value(settee); + if ((is_int_vector(vect)) && (vector_rank(vect) == 3)) + { + q_func(opc).i_7piii_f = func; + q_arg1(opc).p = settee; + return(opt_i_7piii_args(sc, opc, cddr(expr), cdddr(expr), cddddr(expr))); + }}} + return_false(sc, expr); +} + +/* -------- i_add|multiply_any -------- */ + +#define q_i_am_args(o) o->v[1] +#define q_i_am_arg(o, i) o->v[i + 2] +#define q_i_am_func(o, i) o->v[i + 6] /* the following are for the special cases (2-4 args), not i_add_any_f */ +#define q_i_am_func1_arg(o) o->v[2] +#define q_i_am_func1(o) o->v[6] +#define q_i_am_func2_arg(o) o->v[3] +#define q_i_am_func2(o) o->v[7] +#define q_i_am_func3_arg(o) o->v[4] +#define q_i_am_func3(o) o->v[8] +#define q_i_am_func4_arg(o) o->v[5] +#define q_i_am_func4(o) o->v[9] + +#define q_i_am_func1_call(o) q_i_am_func1(o).fi(q_i_am_func1_arg(o).o1) +#define q_i_am_func2_call(o) q_i_am_func2(o).fi(q_i_am_func2_arg(o).o1) +#define q_i_am_func3_call(o) q_i_am_func3(o).fi(q_i_am_func3_arg(o).o1) +#define q_i_am_func4_call(o) q_i_am_func4(o).fi(q_i_am_func4_arg(o).o1) + +static s7_int opt_i_add_any_f(opt_info *o) +{ + s7_int sum = 0; + for (s7_int i = 0; i < q_i_am_args(o).i; i++) + { + opt_info *o1 = q_i_am_arg(o, i).o1; +#if WITH_WARNINGS && HAVE_OVERFLOW_CHECKS + s7_int new_val, val = q_call(o1).fi(o1); /* this is not worth all this bother */ + if (add_overflow(sum, val, &new_val)) + { + s7_warn(o->sc, 128, "integer add overflow: (+ %" ld64 " %" ld64 ")\n", sum, val); + return(sum); + } + sum = new_val; +#else + sum += q_call(o1).fi(o1); +#endif + } + return(sum); +} + +static s7_int opt_i_add2(opt_info *o) +{ + s7_int sum = q_i_am_func1_call(o); + return(sum + q_i_am_func2_call(o)); +} + +static s7_int opt_i_mul2(opt_info *o) +{ + s7_int sum = q_i_am_func1_call(o); + return(sum * q_i_am_func2_call(o)); +} + +static s7_int opt_i_add3(opt_info *o) +{ + s7_int sum = q_i_am_func1_call(o); + sum += q_i_am_func2_call(o); + return(sum + q_i_am_func3_call(o)); +} + +static s7_int opt_i_mul3(opt_info *o) +{ + s7_int sum = q_i_am_func1_call(o); + sum *= q_i_am_func2_call(o); + return(sum * q_i_am_func3_call(o)); +} + +static s7_int opt_i_add4(opt_info *o) +{ + s7_int sum = q_i_am_func1_call(o); + sum += q_i_am_func2_call(o); + sum += q_i_am_func3_call(o); + return(sum + q_i_am_func4_call(o)); +} + +static s7_int opt_i_mul4(opt_info *o) +{ + s7_int sum = q_i_am_func1_call(o); + sum *= q_i_am_func2_call(o); + sum *= q_i_am_func3_call(o); + return(sum * q_i_am_func4_call(o)); +} + +static s7_int opt_i_mul_any_f(opt_info *o) +{ + s7_int sum = 1; + for (s7_int i = 0; i < q_i_am_args(o).i; i++) + { + opt_info *o1 = q_i_am_arg(o, i).o1; + sum *= q_call(o1).fi(o1); + } + return(sum); +} + +static bool i_add_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer expr) +{ + s7_pointer p; + const s7_pointer head = car(expr); + int32_t cur_len; + const int32_t start = sc->pc; + for (cur_len = 0, p = cdr(expr); (is_pair(p)) && (cur_len < (num_vunions - 2)); p = cdr(p), cur_len++) + { + q_i_am_arg(opc, cur_len).o1 = sc->opts[sc->pc]; + if (!int_optimize(sc, p)) + break; + } + if (is_null(p)) + { + q_i_am_args(opc).i = cur_len; + if (cur_len <= 4) + for (int32_t i = 0; i < cur_len; i++) + q_i_am_func(opc, i).fi = q_i_am_arg(opc, i).q_call(o1).fi; + if (cur_len == 2) + q_call(opc).fi = (head == sc->add_symbol) ? opt_i_add2 : opt_i_mul2; + else + if (cur_len == 3) + q_call(opc).fi = (head == sc->add_symbol) ? opt_i_add3 : opt_i_mul3; + else + if (cur_len == 4) + q_call(opc).fi = (head == sc->add_symbol) ? opt_i_add4 : opt_i_mul4; + else q_call(opc).fi = (head == sc->add_symbol) ? opt_i_add_any_f : opt_i_mul_any_f; + return_true(sc, expr); + } + sc->pc = start; + return_false(sc, expr); +} + +/* -------- set_i_i -------- */ + +static s7_int opt_set_i_i_f(opt_info *o) +{ + s7_int x = q_func(o).fi(q_arg2(o).o1); + slot_set_value(q_arg1(o).p, make_integer(o->sc, x)); + return(x); +} + +#if S7_DEBUGGING +static void check_mutability(s7_scheme *sc, opt_info *o, const char *func, int line) +{ + if (!is_mutable_number(slot_value(q_arg1(o).p))) + { + fprintf(stderr, "%s[%d]: %s value is not mutable", func, line, display(q_arg1(o).p)); + if (sc->stop_at_error) abort(); + } +} +#else +#define check_mutability(Sc, O, Func, Line) +#endif + +static s7_int opt_set_i_i_fm(opt_info *o) /* called in increment: (set! sum (+ sum (...))) where all are ints */ +{ + s7_int x = q_func(o).fi(q_arg2(o).o1); + check_mutability(o->sc, o, __func__, __LINE__); + set_integer(slot_value(q_arg1(o).p), x); + return(x); +} + +static s7_int opt_set_i_i_fo(opt_info *o) +{ + s7_int x = integer(slot_value(q_arg3(o).p)) + q_arg2(o).i; + slot_set_value(q_arg1(o).p, make_integer(o->sc, x)); + return(x); +} + +static s7_int opt_set_i_i_fom(opt_info *o) +{ + s7_int x = integer(slot_value(q_arg3(o).p)) + q_arg2(o).i; + check_mutability(o->sc, o, __func__, __LINE__); + set_integer(slot_value(q_arg1(o).p), 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 (q_call(o1).fi == opt_i_ii_sc_add) + { + q_arg3(opc).p = q_arg1(o1).p; /* i_iii, arg1(o) set earlier */ + q_arg2(opc).i = q_arg2(o1).i; /* i_iii */ + q_call(opc).fi = opt_set_i_i_fo; + backup_pc(sc); + return_true(sc, NULL); + }} + return_false(sc, NULL); +} + +static bool i_syntax_ok(s7_scheme *sc, s7_pointer expr, int32_t len) +{ + if ((car(expr) == sc->set_symbol) && + (len == 3)) + { + const s7_pointer arg1 = cadr(expr); + opt_info *opc = alloc_opt_info(sc); + if (is_symbol(arg1)) /* (set! i 3) */ + { + s7_pointer settee; + if (is_immutable(arg1)) + return_false(sc, expr); + settee = s7_slot(sc, arg1); + if ((is_slot(settee)) && + (is_t_integer(slot_value(settee))) && + (!is_immutable_slot(settee)) && + ((!slot_has_setter(settee)) || + ((is_c_function(slot_setter(settee))) && + ((is_eq_initial_c_function_data(sc->is_integer_symbol, slot_setter(settee))) || + (c_function_call(slot_setter(settee)) == b_is_integer_setter))))) + /* opt set! won't change type, and it is an integer now (and we might not hit opt_cell_set) */ + { + opt_info *o1 = sc->opts[sc->pc]; + q_arg1(opc).p = settee; + if (int_optimize(sc, cddr(expr))) + { + if (set_i_i_f_combinable(sc, opc)) + return_true(sc, expr); + q_call(opc).fi = (is_mutable_integer(slot_value(q_arg1(opc).p))) ? opt_set_i_i_fm : opt_set_i_i_f; + /* only a few opt_set_i_i_f|fo's remain in valcall suite */ + q_arg2(opc).o1 = o1; + q_func(opc).fi = q_call(o1).fi; + return_true(sc, expr); + }}} + else + if ((is_pair(arg1)) && /* if is_pair(settee) get setter */ + (is_symbol(car(arg1))) && + (is_pair(cdr(arg1)))) + { + if (is_null(cddr(arg1))) + return(opt_int_vector_set(sc, -1, opc, car(arg1), cdr(arg1), NULL, cddr(expr))); + if (is_null(cdddr(arg1))) + return(opt_int_vector_set(sc, -1, opc, car(arg1), cdr(arg1), cddr(arg1), cddr(expr))); + }} + return_false(sc, expr); +} + + +/* ------------------------------------- float opts ------------------------------------------- */ +static s7_double opt_d_c(opt_info *o) {return(q_arg1(o).x);} +static s7_double opt_d_s(opt_info *o) {return(real(slot_value(q_arg1(o).p)));} + +static s7_double opt_D_s(opt_info *o) +{ + s7_pointer x = slot_value(q_arg1(o).p); + return((is_t_integer(x)) ? (s7_double)(integer(x)) : s7_number_to_real(o->sc, x)); +} + +static bool opt_float_not_pair(s7_scheme *sc, s7_pointer expr) +{ + s7_pointer slot; + if (is_small_real(expr)) + { + opt_info *opc = alloc_opt_info(sc); + q_arg1(opc).x = s7_number_to_real(sc, expr); + q_call(opc).fd = opt_d_c; + return_true(sc, expr); + } + slot = opt_real_symbol(sc, expr); + if (slot) + { + opt_info *opc = alloc_opt_info(sc); + q_arg1(opc).p = slot; + q_call(opc).fd = (is_t_real(slot_value(slot))) ? opt_d_s : opt_D_s; + return_true(sc, expr); + } + return_false(sc, expr); +} + +/* -------- d -------- */ +static s7_double opt_d_f(opt_info *o) {return(q_func(o).d_f());} + +static bool d_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func) /* (f): (mus-srate), ignore damned ccpcheck! */ +{ + const s7_d_t func = s7_d_function(s_func); + if (!func) return_false(sc, NULL); + q_call(opc).fd = opt_d_f; + q_func(opc).d_f = func; + return_true(sc, NULL); +} + +/* -------- d_d -------- */ + +static s7_double opt_d_d_c(opt_info *o) {return(q_func(o).d_d_f(q_arg1(o).x));} +static s7_double opt_d_d_s(opt_info *o) {return(q_func(o).d_d_f(real(slot_value(q_arg1(o).p))));} +static s7_double opt_d_d_s_abs(opt_info *o) {return(abs_d_d(real(slot_value(q_arg1(o).p))));} +static s7_double opt_d_7d_c(opt_info *o) {return(q_func(o).d_7d_f(o->sc, q_arg1(o).x));} +static s7_double opt_d_7d_s(opt_info *o) {return(q_func(o).d_7d_f(o->sc, real(slot_value(q_arg1(o).p))));} + +static s7_double opt_d_d_f(opt_info *o) {return(q_func(o).d_d_f(q_d_func1_call(o)));} +static s7_double opt_d_d_f_abs(opt_info *o) {return(abs_d_d(q_d_func1_call(o)));} +static s7_double opt_d_d_f_sin(opt_info *o) {return(sin_d_d(q_d_func1_call(o)));} +static s7_double opt_d_d_f_cos(opt_info *o) {return(cos_d_d(q_d_func1_call(o)));} +static s7_double opt_d_7d_f(opt_info *o) {return(q_func(o).d_7d_f(o->sc, q_d_func1_call(o)));} +static s7_double opt_d_7d_f_divide(opt_info *o) {return(divide_d_7d(o->sc, q_d_func1_call(o)));} + +static s7_double opt_abs_d_ss_fvref(opt_info *o); +static s7_double opt_d_7pi_ss_fvref_direct(opt_info *o); + +static bool d_d_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) +{ + s7_d_7d_t func7 = NULL; + const int32_t start = sc->pc; + const s7_d_d_t func = s7_d_d_function(s_func); + if (!func) func7 = s7_d_7d_function(s_func); + if ((func) || (func7)) + { + s7_pointer arg1_slot; + const s7_pointer arg1 = cadr(expr); + if (func) + q_func(opc).d_d_f = func; + else q_func(opc).d_7d_f = func7; + if (is_small_real(arg1)) + { + if ((!is_t_real(arg1)) && /* (random 1) != (random 1.0) */ + ((car(expr) == sc->random_symbol) || + (car(expr) == sc->sin_symbol) || (car(expr) == sc->cos_symbol))) + return_false(sc, expr); + q_arg1(opc).x = s7_number_to_real(sc, arg1); + q_call(opc).fd = (func) ? opt_d_d_c : opt_d_7d_c; + return_true(sc, expr); + } + arg1_slot = opt_float_symbol(sc, arg1); + if ((arg1_slot) && + (!has_methods(slot_value(arg1_slot)))) + { + q_arg1(opc).p = arg1_slot; + q_call(opc).fd = (func) ? ((func == abs_d_d) ? opt_d_d_s_abs : opt_d_d_s) : opt_d_7d_s; + return_true(sc, expr); + } + q_func1_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdr(expr))) + { + q_call(opc).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); + /* if (q_call(opc).fd == opt_d_7d_f_divide) in tnum we know the arg is not 0.0, so it could be further optimized (but it's the loop stepper) */ + q_func1(opc).fd = q_func1_arg(opc).q_call(o1).fd; + if ((func == abs_d_d) && (q_func1(opc).fd == opt_d_7pi_ss_fvref_direct)) + q_call(opc).fd = opt_abs_d_ss_fvref; + return_true(sc, expr); + } + sc->pc = start; + } + return_false(sc, expr); +} + +/* -------- d_v -------- */ +static s7_double opt_d_v(opt_info *o) {return(q_func(o).d_v_f(q_arg1(o).gen));} + +static bool d_v_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) +{ + s7_pointer sig; + const s7_d_v_t flt_func = s7_d_v_function(s_func); + if (!flt_func) return_false(sc, expr); + sig = c_function_signature(s_func); + if ((is_pair(sig)) && + (is_symbol(cadr(sig))) && + (is_symbol(cadr(expr)))) /* look for (oscil g) or (next-sample reader) */ + { + s7_pointer slot = opt_types_match(sc, cadr(sig), cadr(expr)); + if (slot) + { + q_arg1(opc).gen = (void *)c_object_value(slot_value(slot)); + q_func(opc).d_v_f = flt_func; + q_call(opc).fd = opt_d_v; + return_true(sc, expr); + }} + return_false(sc, expr); +} + +/* -------- d_p -------- */ +static s7_double opt_d_p_s(opt_info *o) {return(q_func(o).d_p_f(slot_value(q_arg1(o).p)));} +static s7_double opt_d_p_f(opt_info *o) {return(q_func(o).d_p_f(q_p_func1_call(o)));} +static s7_double opt_d_7p_s(opt_info *o) {return(q_func(o).d_7p_f(o->sc, slot_value(q_arg1(o).p)));} +static s7_double opt_d_7p_f(opt_info *o) {return(q_func(o).d_7p_f(o->sc, q_p_func1_call(o)));} + +static bool d_p_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) +{ + const int32_t start = sc->pc; + const s7_d_p_t dpf = s7_d_p_function(s_func); /* mostly clm gens like one_pole (none built-in in s7) */ + s7_d_7p_t d7pf; + if (!dpf) d7pf = s7_d_7p_function(s_func); + if ((!dpf) && (!d7pf)) + return_false(sc, expr); + if (dpf) q_func(opc).d_p_f = dpf; else q_func(opc).d_7p_f = d7pf; + if (is_symbol(cadr(expr))) + { + s7_pointer slot = opt_simple_symbol(sc, cadr(expr)); + if (!slot) + return_false(sc, expr); + q_arg1(opc).p = slot; + q_call(opc).fd = (dpf) ? opt_d_p_s : opt_d_7p_s; + return_true(sc, expr); + } + q_func1_arg(opc).o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdr(expr))) + { + q_call(opc).fd = (dpf) ? opt_d_p_f : opt_d_7p_f; + q_func1(opc).fp = q_func1_arg(opc).q_call(o1).fp; + return_true(sc, expr); + } + sc->pc = start; + return_false(sc, expr); +} + +/* -------- d_7pi -------- */ + +static s7_double opt_d_7pi_sc(opt_info *o) {return(q_func(o).d_7pi_f(o->sc, slot_value(q_arg1(o).p), q_arg2(o).i));} +static s7_double opt_d_7pi_ss(opt_info *o) {return(q_func(o).d_7pi_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))));} +static s7_double opt_d_7pi_sf(opt_info *o) {return(q_func(o).d_7pi_f(o->sc, slot_value(q_arg1(o).p), q_i_func2_call(o)));} +static s7_double opt_d_7pi_ss_fvref(opt_info *o) {return(float_vector_ref_d_7pi(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))));} +static s7_double opt_d_7pi_ss_fvref_direct(opt_info *o) {return(float_vector(slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))));} + +static s7_double opt_abs_d_ss_fvref(opt_info *o) +{ + opt_info *o1 = q_func1_arg(o).o1; + return(abs_d_d(float_vector(slot_value(q_arg1(o1).p), integer(slot_value(q_arg2(o1).p))))); +} + +static s7_double opt_d_7pi_ff(opt_info *o) /* hit only in tbig (not even s7test) */ +{ + s7_pointer seq = q_p_func1_call(o); + return(q_func(o).d_7pi_f(o->sc, seq, q_i_func2_call(o))); +} + +static bool d_7pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, const s7_pointer expr) +{ + /* float-vector-ref is checked for a 1D float-vector arg, but other callers should do type checking */ + const int32_t start = sc->pc; + s7_d_7pi_t ifunc = s7_d_7pi_function(s_func); /* ifunc: float_vector_ref_d_7pi, s_func: global_value(sc->float_vector_ref_symbol) */ + if (!ifunc) + { + if ((is_eq_initial_c_function_data(sc->vector_ref_symbol, s_func)) && (is_normal_symbol(cadr(expr)))) /* (vector-ref )? */ + { + const s7_pointer v_slot = s7_slot(sc, cadr(expr)); + if (is_slot(v_slot)) + { + const s7_pointer vec = slot_value(v_slot); + if ((is_float_vector(vec)) || + ((is_typed_t_vector(vec)) && (typed_vector_typer_symbol(sc, vec) == sc->is_float_symbol))) + { + ifunc = float_vector_ref_d_7pi; + if (is_float_vector(vec)) s_func = initial_value(sc->float_vector_ref_symbol); + }}} + if (!ifunc) return_false(sc, expr); + } + q_func(opc).d_7pi_f = ifunc; + if (is_symbol(cadr(expr))) /* (float-vector-ref v i) */ + { + s7_pointer arg2, arg2_slot, obj; + q_arg1(opc).p = s7_slot(sc, cadr(expr)); + if (!is_slot(q_arg1(opc).p)) return_false(sc, expr); + + obj = slot_value(q_arg1(opc).p); + if ((is_target_or_its_alias(car(expr), s_func, sc->float_vector_ref_symbol)) && + ((!is_float_vector(obj)) || /* if it's float-vector-ref, make sure obj is a float-vector */ + (vector_rank(obj) > 1))) + return_false(sc, expr); /* but if it's e.g. (block-ref...), go on */ + + arg2 = caddr(expr); + if (!is_pair(arg2)) + { + if (is_t_integer(arg2)) + { + q_arg2(opc).i = integer(arg2); + q_call(opc).fd = opt_d_7pi_sc; + return_true(sc, expr); + } + arg2_slot = opt_integer_symbol(sc, arg2); + if (!arg2_slot) + return_false(sc, expr); + q_arg2(opc).p = arg2_slot; + q_call(opc).fd = opt_d_7pi_ss; + if (is_target_or_its_alias(car(expr), s_func, sc->float_vector_ref_symbol)) + { + q_call(opc).fd = (loop_end_fits(q_arg2(opc).p, vector_length(obj))) ? opt_d_7pi_ss_fvref_direct : opt_d_7pi_ss_fvref; + if (q_call(opc).fd == opt_d_7pi_ss_fvref_direct) q_func(opc).d_7pi_f = float_vector_ref_d_7pi_direct; + } + return_true(sc, expr); + } + if (int_optimize(sc, cddr(expr))) + { + q_call(opc).fd = opt_d_7pi_sf; + q_func2_arg(opc).o1 = sc->opts[start]; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + return_true(sc, expr); + } + sc->pc = start; + return_false(sc, expr); + } + + if ((is_target_or_its_alias(car(expr), s_func, sc->float_vector_ref_symbol)) && + ((!is_float_vector(cadr(expr))) || + (vector_rank(cadr(expr)) > 1))) /* (float-vector-ref #r2d((.1 .2) (.3 .4)) 3) */ + return_false(sc, expr); + + if (cell_optimize(sc, cdr(expr))) + { + opt_info *o2 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + q_call(opc).fd = opt_d_7pi_ff; + q_func1_arg(opc).o1 = sc->opts[start]; + q_func1(opc).fp = q_call(sc->opts[start]).fp; + q_func2_arg(opc).o1 = o2; + q_func2(opc).fi = q_call(o2).fi; + return_true(sc, expr); + }} + sc->pc = start; + return_false(sc, expr); +} + +/* -------- d_ip -------- */ +static s7_double opt_d_ip_ss(opt_info *o) {return(q_func(o).d_ip_f(integer(slot_value(q_arg1(o).p)), slot_value(q_arg2(o).p)));} + +static bool d_ip_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) /* ina/inb clm2xen, ffitest, tgen etc */ +{ + const s7_d_ip_t pfunc = s7_d_ip_function(s_func); + if ((pfunc) && (is_symbol(caddr(expr)))) + { + s7_pointer arg1_slot = opt_integer_symbol(sc, cadr(expr)); + if (arg1_slot) + { + q_func(opc).d_ip_f = pfunc; + q_arg1(opc).p = arg1_slot; + q_arg2(opc).p = s7_t_slot(sc, caddr(expr)); + if (is_slot(q_arg2(opc).p)) /* (with-sound (:reverb jc-reverb) (fm-violin 0 .1 440 .4 :reverb-amount .5)) */ + { + q_call(opc).fd = opt_d_ip_ss; + return_true(sc, expr); + }}} + return_false(sc, expr); +} + +/* -------- d_pd -------- */ +static s7_double opt_d_pd_sf(opt_info *o) {return(q_func(o).d_pd_f(slot_value(q_arg1(o).p), q_d_func2_call(o)));} +static s7_double opt_d_pd_ss(opt_info *o) {return(q_func(o).d_pd_f(slot_value(q_arg1(o).p), real(slot_value(q_arg2(o).p))));} + +static bool d_pd_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) /* none built-in, many in clm2xen but they're almost never called */ +{ + if (is_symbol(cadr(expr))) + { + const s7_d_pd_t func = s7_d_pd_function(s_func); + if (func) + { + s7_pointer arg2_slot; + const s7_pointer arg2 = caddr(expr); + const int32_t start = sc->pc; + q_func(opc).d_pd_f = func; + q_arg1(opc).p = s7_t_slot(sc, cadr(expr)); + if (!is_slot(q_arg1(opc).p)) return_false(sc, expr); + arg2_slot = opt_float_symbol(sc, arg2); + if (arg2_slot) + { + q_arg2(opc).p = arg2_slot; + q_call(opc).fd = opt_d_pd_ss; + return_true(sc, expr); + } + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(expr))) + { + q_call(opc).fd = opt_d_pd_sf; + q_func2(opc).fd = q_func2_arg(opc).q_call(o1).fd; + return_true(sc, expr); + } + sc->pc = start; + }} + return_false(sc, expr); +} + +/* -------- d_vd -------- */ + +static s7_double opt_d_vd_c(opt_info *o) {return(q_func(o).d_vd_f(q_arg1(o).gen, q_arg2(o).x));} +static s7_double opt_d_vd_s(opt_info *o) {return(q_func(o).d_vd_f(q_arg1(o).gen, real(slot_value(q_arg2(o).p))));} +static s7_double opt_d_vd_f(opt_info *o) {return(q_func(o).d_vd_f(q_arg1(o).gen, q_d_func3_call(o)));} +static s7_double opt_d_vd_o(opt_info *o) {return(q_func(o).d_vd_f(q_arg1(o).gen, q_func3(o).d_v_f(q_func2_arg(o).gen)));} +static s7_double opt_d_vd_o1_mul(opt_info *o) {return(q_func(o).d_vd_f(q_arg1(o).gen, real(slot_value(q_arg2(o).p)) * q_d_func2_call(o)));} +static s7_double opt_d_vd_o3(opt_info *o) {return(q_func(o).d_vd_f(q_arg1(o).gen, q_func3(o).d_dd_f(q_func2_arg(o).x, real(slot_value(q_arg2(o).p)))));} +static s7_double opt_d_vd_ff(opt_info *o) {return(q_func(o).d_vd_f(q_arg1(o).gen, q_func3(o).d_vd_f(q_func3_arg(o).gen, q_d_func2_call(o))));} + +static s7_double opt_d_vd_o1(opt_info *o) +{ + return(q_func(o).d_vd_f(q_arg1(o).gen, q_func3(o).d_dd_f(real(slot_value(q_arg2(o).p)), q_d_func2_call(o)))); +} + +static s7_double opt_d_vd_o2(opt_info *o) +{ + return(q_func3(o).d_vd_f(q_arg3(o).gen, q_func1(o).d_vd_f(q_arg2(o).gen, real(slot_value(q_arg4(o).p))))); +} + +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 (q_call(o1).fd == opt_d_v) + { + q_func2_arg(opc).gen = q_arg1(o1).gen; + q_func3(opc).d_v_f = q_func(o1).d_v_f; + q_call(opc).fd = opt_d_vd_o; + backup_pc(sc); + return_true(sc, NULL); + } + if (q_call(o1).fd == opt_d_vd_s) + { + q_func3(opc).d_vd_f = q_func(opc).d_vd_f; /* [4] <- opc[3] */ + q_arg3(opc).gen = q_arg1(opc).gen; /* [12] <- opc[5] */ + q_func1(opc).d_vd_f = q_func(o1).d_vd_f; /* [5] <- o1[3] */ + q_arg2(opc).gen = q_arg1(o1).gen; /* [2] <- o1[5] */ + q_arg4(opc).p = q_arg2(o1).p; /* [13] <- o1[2] */ + q_call(opc).fd = opt_d_vd_o2; + backup_pc(sc); + return_true(sc, NULL); + } + if (q_call(o1).fd == opt_d_dd_cs) + { + q_func3(opc).d_dd_f = q_func(o1).d_dd_f; + q_func2_arg(opc).x = q_arg1(o1).x; + /* fprintf(stderr, "arg1: %f, arg2: %s\n", q_arg1(o1).x, display(q_arg2(o1).p)); */ + q_arg2(opc).p = T_Slt(q_arg2(o1).p); + q_call(opc).fd = opt_d_vd_o3; + backup_pc(sc); + return_true(sc, NULL); + } + if ((q_call(o1).fd == opt_d_dd_sf_mul) || (q_call(o1).fd == opt_d_dd_sf) || (q_call(o1).fd == opt_d_dd_sf_add)) + { + q_arg2(opc).p = q_arg1(o1).p; + q_func3(opc).d_dd_f = q_func(o1).d_dd_f; /* unused in opt_d_vd_o1_mul (=> mul) */ + q_call(opc).fd = (q_call(o1).fd == opt_d_dd_sf_mul) ? opt_d_vd_o1_mul : opt_d_vd_o1; + q_func2(opc).fd = q_func1(o1).fd; + q_func2_arg(opc).o1 = q_func1_arg(o1).o1; + return_true(sc, NULL); + } + if (q_call(o1).fd == opt_d_vd_f) + { + q_func3(opc).d_vd_f = q_func(o1).d_vd_f; + q_func3_arg(opc).gen = q_arg1(o1).gen; + q_call(opc).fd = opt_d_vd_ff; + q_func2(opc).fd = q_func3(o1).fd; + q_func2_arg(opc).o1 = q_func3_arg(o1).o1; + return_true(sc, NULL); + } + return_false(sc, NULL); +} + +static bool d_vd_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) +{ + s7_pointer sig; + s7_d_vd_t vfunc; + if (!is_symbol(cadr(expr))) return_false(sc, expr); + vfunc = s7_d_vd_function(s_func); + if (!vfunc) + return_false(sc, expr); + sig = c_function_signature(s_func); + if ((is_pair(sig)) && + (is_symbol(cadr(sig)))) + { + s7_pointer slot = opt_types_match(sc, cadr(sig), cadr(expr)); + if (slot) + { + const s7_pointer arg2 = caddr(expr); + const int32_t start = sc->pc; + q_func(opc).d_vd_f = vfunc; + if (!is_pair(arg2)) + { + q_arg1(opc).p = slot; + q_arg1(opc).gen = (void *)c_object_value(slot_value(slot)); + if (is_small_real(arg2)) + { + q_arg2(opc).x = s7_number_to_real(sc, arg2); + q_call(opc).fd = opt_d_vd_c; + return_true(sc, expr); + } + q_arg2( opc).p = s7_t_slot(sc, arg2); + if (is_slot(q_arg2(opc).p)) + { + if (is_t_real(slot_value(q_arg2(opc).p))) + { + q_call(opc).fd = opt_d_vd_s; + return_true(sc, expr); + } + if (!float_optimize(sc, cddr(expr))) + return_false(sc, expr); + if (d_vd_f_combinable(sc, start)) + return_true(sc, expr); + q_call(opc).fd = opt_d_vd_f; + q_func3_arg(opc).o1 = sc->opts[start]; + q_func3(opc).fd = q_call(sc->opts[start]).fd; + return_true(sc, expr); + }} + else /* is pair arg2 */ + { + if (float_optimize(sc, cddr(expr))) + { + q_arg1(opc).gen = (void *)c_object_value(slot_value(slot)); + if (d_vd_f_combinable(sc, start)) + return_true(sc, expr); + q_call(opc).fd = opt_d_vd_f; + q_func3_arg(opc).o1 = sc->opts[start]; + q_func3(opc).fd = q_call(sc->opts[start]).fd; + return_true(sc, expr); + } + sc->pc = start; + }}} + return_false(sc, expr); +} + +/* -------- d_id -------- */ +static s7_double opt_d_id_ss(opt_info *o) {return(q_func(o).d_id_f(integer(slot_value(q_arg1(o).p)), real(slot_value(q_arg2(o).p))));} +static s7_double opt_d_i2_mul(opt_info *o) {s7_int p = integer(slot_value(q_arg1(o).p)); return(p * p);} +static s7_double opt_d_id_sf(opt_info *o) {return(q_func(o).d_id_f(integer(slot_value(q_arg1(o).p)), q_d_func1_call(o)));} +static s7_double opt_d_id_sc(opt_info *o) {return(q_func(o).d_id_f(integer(slot_value(q_arg1(o).p)), q_arg2(o).x));} +static s7_double opt_d_id_cf(opt_info *o) {return(q_func(o).d_id_f(q_arg1(o).i, q_d_func1_call(o)));} +static s7_double opt_d_id_sfo1(opt_info *o) {return(q_func(o).d_id_f(integer(slot_value(q_arg1(o).p)), q_func1(o).d_v_f(q_arg2(o).gen)));} + +static s7_double opt_d_id_sfo(opt_info *o) +{ + return(q_func(o).d_id_f(integer(slot_value(q_arg1(o).p)), q_func1(o).d_vd_f(q_arg3(o).gen, real(slot_value(q_arg2(o).p))))); +} + +static s7_double opt_d_id_ff(opt_info *o) +{ + s7_int x1 = q_i_func1_call(o); + return(q_func(o).d_id_f(x1, q_d_func2_call(o))); +} + +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 (q_call(o1).fd == opt_d_vd_s) + { + q_arg3(opc).gen = q_arg1(o1).gen; + q_func1(opc).d_vd_f = q_func(o1).d_vd_f; + q_arg2(opc).p = q_arg2(o1).p; + q_call(opc).fd = opt_d_id_sfo; /* not in s7test (see tgen) */ + backup_pc(sc); + return_true(sc, NULL); + } + if (q_call(o1).fd == opt_d_v) + { + q_arg2(opc).gen = q_arg1(o1).gen; + q_func1(opc).d_v_f = q_func(o1).d_v_f; + q_call(opc).fd = opt_d_id_sfo1; /* not in s7test (tgen) */ + backup_pc(sc); + return_true(sc, NULL); + }} + return_false(sc, NULL); +} + +static bool d_id_ok_1(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr, bool expr_case) +{ + s7_pointer arg1_slot; + const int32_t start = sc->pc; + const s7_d_id_t flt_func = s7_d_id_function(s_func); + if (!flt_func) return_false(sc, expr); + q_func(opc).d_id_f = flt_func; + arg1_slot = opt_integer_symbol(sc, cadr(expr)); + if (arg1_slot) + { + const s7_pointer arg2 = caddr(expr); + s7_pointer arg2_slot; + q_arg1(opc).p = arg1_slot; + if (is_t_real(arg2)) + { + q_call(opc).fd = opt_d_id_sc; + q_arg2(opc).x = real(arg2); + return_true(sc, expr); + } + if ((cadr(expr) == arg2) && (flt_func == multiply_d_id)) /* cadr(expr)==arg2 if both are symbols */ + { /* (do... (set! sum 0.0) (do ((k 1 (+ k 1))) ((> k 10)) (set! sum (+ sum (/ (* k k)))))) tnum */ + q_call(opc).fd = opt_d_i2_mul; + return_true(sc, expr); + } + arg2_slot = opt_float_symbol(sc, arg2); + if (arg2_slot) + { + q_call(opc).fd = opt_d_id_ss; + q_arg2(opc).p = arg2_slot; + return_true(sc, expr); + } + if (float_optimize(sc, cddr(expr))) + { + if (d_id_sf_combinable(sc, opc)) + return_true(sc, expr); + q_call(opc).fd = opt_d_id_sf; + q_func1_arg(opc).o1 = sc->opts[start]; + q_func1(opc).fd = q_call(sc->opts[start]).fd; + return_true(sc, expr); + } + sc->pc = start; + } + if (is_t_integer(cadr(expr))) + { + if (float_optimize(sc, cddr(expr))) + { + q_call(opc).fd = opt_d_id_cf; + q_arg1(opc).i = integer(cadr(expr)); + q_func1_arg(opc).o1 = sc->opts[start]; + q_func1(opc).fd = q_call(sc->opts[start]).fd; + return_true(sc, expr); + } + sc->pc = start; + } + if (!expr_case) return_false(sc, expr); + q_func1_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(expr))) + { + q_func1(opc).fi = q_func1_arg(opc).q_call(o1).fi; + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(expr))) + { + q_func2(opc).fd = q_func2_arg(opc).q_call(o1).fd; + q_call(opc).fd = opt_d_id_ff; /* not in s7test? (once in tgsl! from opt_d_7pid_sff_fvset (float-vector-set! v 0 (jn (+ i 1) 1.0))) */ + return_true(sc, expr); + } + sc->pc = start; + } + return_false(sc, expr); +} + +static bool d_id_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) +{ + return(d_id_ok_1(sc, opc, s_func, expr, true)); +} + +/* -------- d_dd -------- */ + +static s7_double opt_d_dd_cc(opt_info *o) {return(q_func(o).d_dd_f(q_arg1(o).x, q_arg2(o).x));} +static s7_double opt_d_dd_cs(opt_info *o) {return(q_func(o).d_dd_f(q_arg1(o).x, real(slot_value(q_arg2(o).p))));} +static s7_double opt_d_dd_sc(opt_info *o) {return(q_func(o).d_dd_f(real(slot_value(q_arg1(o).p)), q_arg2(o).x));} +static s7_double opt_d_dd_sc_sub(opt_info *o) {return(real(slot_value(q_arg1(o).p)) - q_arg2(o).x);} +static s7_double opt_d_dd_ss(opt_info *o) {return(q_func(o).d_dd_f(real(slot_value(q_arg1(o).p)), real(slot_value(q_arg2(o).p))));} +static s7_double opt_d_dd_ss_add(opt_info *o) {return(real(slot_value(q_arg1(o).p)) + real(slot_value(q_arg2(o).p)));} +static s7_double opt_d_dd_ss_mul(opt_info *o) {return(real(slot_value(q_arg1(o).p)) * real(slot_value(q_arg2(o).p)));} + +static s7_double opt_d_dd_cf(opt_info *o) {return(q_func(o).d_dd_f(q_arg1(o).x, q_d_func1_call(o)));} +static s7_double opt_d_dd_1f_subtract(opt_info *o) {return(1.0 - q_d_func1_call(o));} +static s7_double opt_d_dd_fc(opt_info *o) {return(q_func(o).d_dd_f(q_d_func1_call(o), q_arg2(o).x));} + +static s7_double opt_subtract_random_f_f(opt_info *o) +{ + return(q_arg1(o).x * next_random(o->sc->default_random_state) - q_arg2(o).x); +} + +static s7_double opt_d_dd_fc_add(opt_info *o) {return(q_d_func1_call(o) + q_arg2(o).x);} +static s7_double opt_d_dd_fc_fvref_add(opt_info *o) {return(q_arg2(o).x + float_vector(slot_value(q_arg3(o).p), integer(slot_value(q_arg4(o).p))));} +static s7_double opt_d_dd_fc_subtract(opt_info *o) {return(q_d_func1_call(o) - q_arg2(o).x);} +static s7_double opt_d_dd_sf(opt_info *o) {return(q_func(o).d_dd_f(real(slot_value(q_arg1(o).p)), q_d_func1_call(o)));} +static s7_double opt_d_dd_sf_mul(opt_info *o) {return(real(slot_value(q_arg1(o).p)) * q_d_func1_call(o));} +static s7_double opt_d_dd_sf_add(opt_info *o) {return(real(slot_value(q_arg1(o).p)) + q_d_func1_call(o));} +static s7_double opt_d_dd_sf_sub(opt_info *o) {return(real(slot_value(q_arg1(o).p)) - q_d_func1_call(o));} + +static s7_double opt_d_7dd_cc(opt_info *o) {return(q_func(o).d_7dd_f(o->sc, q_arg1(o).x, q_arg2(o).x));} +static s7_double opt_d_7dd_cs(opt_info *o) {return(q_func(o).d_7dd_f(o->sc, q_arg1(o).x, real(slot_value(q_arg2(o).p))));} +static s7_double opt_d_7dd_sc(opt_info *o) {return(q_func(o).d_7dd_f(o->sc, real(slot_value(q_arg1(o).p)), q_arg2(o).x));} +static s7_double opt_d_7dd_ss(opt_info *o) {return(q_func(o).d_7dd_f(o->sc, real(slot_value(q_arg1(o).p)), real(slot_value(q_arg2(o).p))));} +static s7_double opt_d_7dd_cf(opt_info *o) {return(q_func(o).d_7dd_f(o->sc, q_arg1(o).x, q_d_func1_call(o)));} +static s7_double opt_d_7dd_fc(opt_info *o) {return(q_func(o).d_7dd_f(o->sc, q_d_func1_call(o), q_arg2(o).x));} +static s7_double opt_d_7dd_sf(opt_info *o) {return(q_func(o).d_7dd_f(o->sc, real(slot_value(q_arg1(o).p)), q_d_func1_call(o)));} + +/* arg3 is index slot from opt_d_7pii_scs, also below */ +static s7_double opt_d_dd_sf_mul_fvref(opt_info *o) +{ + opt_info *o1 = q_func1_arg(o).o1; + return(real(slot_value(q_arg1(o).p)) * float_vector_ref_d_7pii(o1->sc, slot_value(q_arg1(o1).p), q_arg2(o1).i, integer(slot_value(q_arg3(o1).p)))); +} + +static s7_double opt_d_dd_sfo(opt_info *o) +{ + return(q_func(o).d_dd_f(real(slot_value(q_arg1(o).p)), q_func1(o).d_7pi_f(o->sc, slot_value(q_arg2(o).p), integer(slot_value(q_arg3(o).p))))); +} + +static s7_double opt_d_7dd_sfo(opt_info *o) +{ + return(q_func(o).d_7dd_f(o->sc, real(slot_value(q_arg1(o).p)), q_func1(o).d_7pi_f(o->sc, slot_value(q_arg2(o).p), integer(slot_value(q_arg3(o).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 ((q_call(o1).fd == opt_d_7pi_ss) || (q_call(o1).fd == opt_d_7pi_ss_fvref) || (q_call(o1).fd == opt_d_7pi_ss_fvref_direct)) + { + if (func) + { + q_func(opc).d_dd_f = q_func(opc).d_dd_f; /* need room for 3 symbols */ + q_call(opc).fd = opt_d_dd_sfo; + } + else + { + q_func(opc).d_7dd_f = q_func(opc).d_7dd_f; /* need room for 3 symbols */ + q_call(opc).fd = opt_d_7dd_sfo; + } + q_arg2(opc).p = q_arg1(o1).p; + q_arg3(opc).p = q_arg2(o1).p; + q_func1(opc).d_7pi_f = q_func(o1).d_7pi_f; + backup_pc(sc); + return_true(sc, NULL); + }} + return_false(sc, NULL); +} + +static s7_double opt_d_dd_fs(opt_info *o) {return(q_func(o).d_dd_f(q_d_func1_call(o), real(slot_value(q_arg1(o).p))));} +static s7_double opt_d_dd_fs_mul(opt_info *o) {return(q_d_func1_call(o) * real(slot_value(q_arg1(o).p)));} +static s7_double opt_d_dd_fs_add(opt_info *o) {return(q_d_func1_call(o) + real(slot_value(q_arg1(o).p)));} +static s7_double opt_d_dd_fs_sub(opt_info *o) {return(q_d_func1_call(o) - real(slot_value(q_arg1(o).p)));} +static s7_double opt_d_7dd_fs(opt_info *o) {return(q_func(o).d_7dd_f(o->sc, q_d_func1_call(o), real(slot_value(q_arg1(o).p))));} + +static s7_double opt_d_dd_fs_add_fvref(opt_info *o) +{ + opt_info *o1 = q_func1_arg(o).o1; + return(real(slot_value(q_arg1(o).p)) + float_vector_ref_d_7pii(o1->sc, slot_value(q_arg1(o1).p), q_arg2(o1).i, integer(slot_value(q_arg3(o1).p)))); +} + +static s7_double opt_d_dd_fso(opt_info *o) +{ + return(q_func(o).d_dd_f(q_func1(o).d_7pi_f(o->sc, slot_value(q_arg2(o).p), integer(slot_value(q_arg3(o).p))), real(slot_value(q_arg1(o).p)))); +} + +static s7_double opt_d_7dd_fso(opt_info *o) +{ + return(q_func(o).d_7dd_f(o->sc, q_func1(o).d_7pi_f(o->sc, slot_value(q_arg2(o).p), integer(slot_value(q_arg3(o).p))), real(slot_value(q_arg1(o).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 ((q_call(o1).fd == opt_d_7pi_ss) || (q_call(o1).fd == opt_d_7pi_ss_fvref) || (q_call(o1).fd == opt_d_7pi_ss_fvref_direct)) + { + if (func) + { + q_func(opc).d_dd_f = q_func(opc).d_dd_f; /* need room for 3 symbols */ + q_call(opc).fd = opt_d_dd_fso; + } + else + { + q_func(opc).d_7dd_f = q_func(opc).d_7dd_f; + q_call(opc).fd = opt_d_7dd_fso; + } + q_arg2(opc).p = q_arg1(o1).p; + q_arg3(opc).p = q_arg2(o1).p; + q_func1(opc).d_7pi_f = q_func(o1).d_7pi_f; + backup_pc(sc); + return_true(sc, NULL); + }} + return_false(sc, NULL); +} + +static s7_double opt_d_dd_ff(opt_info *o) +{ + s7_double x1 = q_d_func3_call(o); + return(q_func(o).d_dd_f(x1, q_d_func2_call(o))); +} + +static s7_double opt_d_dd_ff_mul(opt_info *o) +{ + s7_double x1 = q_d_func3_call(o); + return(x1 * q_d_func2_call(o)); +} + +static s7_double opt_d_dd_ff_square(opt_info *o) +{ + s7_double x1 = q_d_func3_call(o); + return(x1 * x1); +} + +static s7_double opt_d_dd_ff_add(opt_info *o) +{ + s7_double x1 = q_d_func1_call(o); + return(x1 + q_d_func2_call(o)); +} + +static s7_double opt_d_dd_ff_add_mul(opt_info *o) +{ + s7_double x1 = q_d_func1_call(o); + s7_double x2 = q_d_func3_call(o); + return(x1 + (x2 * q_d_func2_call(o))); +} + +static s7_double opt_d_dd_ff_add_fv_ref(opt_info *o) +{ + s7_double x1 = q_d_func1_call(o); + return(x1 + float_vector_ref_d_7pi(o->sc, slot_value(q_arg1(o).p), q_i_func3_call(o))); +} + +static s7_double opt_d_dd_ff_sub(opt_info *o) +{ + s7_double x1 = q_d_func1_call(o); + return(x1 - q_d_func2_call(o)); +} + +static s7_double opt_d_7dd_ff(opt_info *o) +{ + s7_double x1 = q_d_func3_call(o); + return(q_func(o).d_7dd_f(o->sc, x1, q_d_func2_call(o))); +} + +static s7_double opt_d_7dd_ff_add_div(opt_info *o) +{ + s7_double x1 = opt_d_7pi_ss_fvref_direct(q_arg1(o).o1); + s7_double x2 = opt_d_7pi_ss_fvref_direct(q_arg2(o).o1); + return(x1 + divide_d_7dd(o->sc, x2, opt_d_id_sf(q_arg3(o).o1))); +} + +static s7_double opt_d_dd_ff_mul1(opt_info *o) {return(q_func3(o).d_v_f(q_arg1(o).gen) * q_d_func2_call(o));} + +static s7_double opt_d_dd_ff_mul2(opt_info *o) {return(q_func3(o).d_v_f(q_arg1(o).gen) * q_func1(o).d_v_f(q_arg2(o).gen));} + +static s7_double opt_d_dd_ff_mul4(opt_info *o) {return(q_func3(o).d_v_f(q_arg1(o).gen) * q_func2(o).d_vd_f(q_arg2(o).gen, q_func1(o).d_v_f(q_arg3(o).gen)));} + +static s7_double opt_d_dd_ff_o1(opt_info *o) +{ + s7_double x1 = q_func3(o).d_v_f(q_arg1(o).gen); + return(q_func(o).d_dd_f(x1, q_d_func2_call(o))); +} + +static s7_double opt_d_dd_ff_o2(opt_info *o) +{ + s7_double x1 = q_func3(o).d_v_f(q_arg1(o).gen); + return(q_func(o).d_dd_f(x1, q_func1(o).d_v_f(q_arg2(o).gen))); +} + +static s7_double opt_d_dd_ff_o3(opt_info *o) +{ + s7_double x1 = q_func3(o).d_v_f(q_arg1(o).gen); + return(q_func1(o).d_dd_f(x1, q_func2(o).d_vd_f(q_arg2(o).gen, real(slot_value(q_arg3(o).p))))); +} + +static s7_double opt_d_dd_ff_o4(opt_info *o) +{ + s7_double x1 = q_func3(o).d_v_f(q_arg1(o).gen); + return(q_func(o).d_dd_f(x1, q_func2(o).d_vd_f(q_arg2(o).gen, q_func1(o).d_v_f(q_arg3(o).gen)))); +} + +static s7_double opt_d_dd_fff(opt_info *o) +{ + s7_double x1 = o->v[3+4].d_dd_f(o->v[3+5].d_7pi_f(o->sc, 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 */ + s7_double x2 = o->v[8+4].d_dd_f(o->v[8+5].d_7pi_f(o->sc, 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(q_func(o).d_dd_f(x1, x2)); +} + +static s7_double opt_d_mm_fff(opt_info *o) +{ + s7_double x1 = float_vector_ref_d_7pi(o->sc, slot_value(o->v[3+2].p), integer(slot_value(o->v[3+3].p))) * real(slot_value(o->v[3+1].p)); + s7_double x2 = float_vector_ref_d_7pi(o->sc, slot_value(o->v[8+2].p), integer(slot_value(o->v[8+3].p))) * real(slot_value(o->v[8+1].p)); + return(q_func(o).d_dd_f(x1, x2)); +} + +static s7_double opt_d_dd_fff_rev(opt_info *o) /* faster with o->sc? */ +{ + s7_double x1 = o->v[3+4].d_dd_f(real(slot_value(o->v[3+1].p)), o->v[3+5].d_7pi_f(o->sc, slot_value(o->v[3+2].p), integer(slot_value(o->v[3+3].p)))); + s7_double x2 = o->v[8+4].d_dd_f(real(slot_value(o->v[8+1].p)), o->v[8+5].d_7pi_f(o->sc, slot_value(o->v[8+2].p), integer(slot_value(o->v[8+3].p)))); + return(q_func(o).d_dd_f(x1, x2)); +} + +static s7_double opt_d_dd_ff_mul_sss_unchecked(opt_info *o) +{ + opt_info *o1 = q_func3_arg(o).o1; + s7_pointer vec = slot_value(q_arg1(o1).p); + s7_int i1 = integer(slot_value(q_arg2(o1).p)); + s7_int i2 = integer(slot_value(q_arg3(o1).p)); + s7_double x1 = float_vector(vec, (i1 * vector_offset(vec, 0)) + i2); + o1 = q_func2_arg(o).o1; + vec = slot_value(q_arg1(o1).p); + i1 = integer(slot_value(q_arg2(o1).p)); /* in (* (A i j) (B j k)) we could reuse i2->i1 (flipping args below) */ + i2 = integer(slot_value(q_arg3(o1).p)); + return(x1 * float_vector(vec, (i1 * vector_offset(vec, 0)) + i2)); +} + +static bool finish_dd_fso(opt_info *opc, opt_info *o1, opt_info *o2) +{ + opc->v[3+1].p = q_arg1(o1).p; + opc->v[3+2].p = q_arg2(o1).p; + opc->v[3+3].p = q_arg3(o1).p; + opc->v[3+4].d_dd_f = q_func(o1).d_dd_f; + opc->v[3+5].d_7pi_f = q_func1(o1).d_7pi_f; + opc->v[8+1].p = q_arg1(o2).p; + opc->v[8+2].p = q_arg2(o2).p; + opc->v[8+3].p = q_arg3(o2).p; + opc->v[8+4].d_dd_f = q_func(o2).d_dd_f; + opc->v[8+5].d_7pi_f = q_func1(o2).d_7pi_f; + return(true); +} + +static bool d_dd_ff_combinable(s7_scheme *sc, opt_info *opc, int32_t start) +{ + opt_info *o1 = q_func3_arg(opc).o1, *o2 = q_func2_arg(opc).o1; + if (q_call(o1).fd == opt_d_v) + { + /* q_func(opc) is in use */ + q_arg1(opc).gen = q_arg1(o1).gen; + q_func3(opc).d_v_f = q_func(o1).d_v_f; + if ((q_call(o2).fd == opt_d_v) && + (sc->pc == start + 2)) + { + q_arg2(opc).gen = q_arg1(o2).gen; + q_func1(opc).d_v_f = q_func(o2).d_v_f; + q_call(opc).fd = (q_func(opc).d_dd_f == multiply_d_dd) ? opt_d_dd_ff_mul2 : opt_d_dd_ff_o2; + sc->pc -= 2; + return_true(sc, NULL); + } + if ((q_call(o2).fd == opt_d_vd_s) && + (sc->pc == start + 2)) + { + q_arg2(opc).gen = q_arg1(o2).gen; + q_func1(opc).d_dd_f = q_func(opc).d_dd_f; + q_func2(opc).d_vd_f = q_func(o2).d_vd_f; + q_arg3(opc).p = q_arg2(o2).p; + q_call(opc).fd = opt_d_dd_ff_o3; + sc->pc -= 2; + return_true(sc, NULL); + } + if ((q_call(o2).fd == opt_d_vd_o) && + (sc->pc == start + 2)) + { + q_func3(opc).d_v_f = q_func(o1).d_v_f; + q_func2(opc).d_vd_f = q_func(o2).d_vd_f; + q_func1(opc).d_v_f = q_func3(o2).d_v_f; + q_arg2(opc).gen = q_arg1(o2).gen; + q_arg3(opc).gen = q_func2_arg(o2).gen; + q_call(opc).fd = (q_func(opc).d_dd_f == multiply_d_dd) ? opt_d_dd_ff_mul4 : opt_d_dd_ff_o4; + sc->pc -= 2; + return_true(sc, NULL); + } + q_call(opc).fd = (q_func(opc).d_dd_f == multiply_d_dd) ? opt_d_dd_ff_mul1 : opt_d_dd_ff_o1; + return_true(sc, NULL); + } + if (((q_call(o1).fd == opt_d_dd_fso) && (q_call(o2).fd == opt_d_dd_fso)) || + ((q_call(o1).fd == opt_d_dd_sfo) && (q_call(o2).fd == opt_d_dd_sfo))) + { + if ((q_func(o1).d_dd_f == multiply_d_dd) && + (q_func(o2).d_dd_f == multiply_d_dd) && + ((q_func1(o1).d_7pi_f == float_vector_ref_d_7pi) || (q_func1(o1).d_7pi_f == float_vector_ref_d_7pi_direct)) && + ((q_func1(o2).d_7pi_f == float_vector_ref_d_7pi) || (q_func1(o2).d_7pi_f == float_vector_ref_d_7pi_direct))) + q_call(opc).fd = opt_d_mm_fff; /* a placeholder (never called), see p_d_f_combinable */ + else q_call(opc).fd = (q_call(o1).fd == opt_d_dd_fso) ? opt_d_dd_fff : 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(q_func(o).d_dd_f(q_arg1(o).x, q_func1(o).d_v_f(q_arg2(o).gen)));} +static s7_double opt_d_7dd_cfo(opt_info *o) {return(q_func(o).d_7dd_f(o->sc, q_arg1(o).x, q_func1(o).d_v_f(q_arg2(o).gen)));} + +static s7_double opt_d_dd_cfo1(opt_info *o) {return(q_func(o).d_dd_f(q_arg1(o).x, q_func1(o).d_vd_f(q_arg3(o).gen, real(slot_value(q_arg2(o).p)))));} +static s7_double opt_d_7dd_cfo1(opt_info *o){return(q_func(o).d_7dd_f(o->sc, q_arg1(o).x, q_func1(o).d_vd_f(q_arg3(o).gen, real(slot_value(q_arg2(o).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 (q_call(o1).fd == opt_d_v) + { + q_arg2(opc).gen = q_arg1(o1).gen; + q_func1(opc).d_v_f = q_func(o1).d_v_f; + q_call(opc).fd = (func) ? opt_d_dd_cfo : opt_d_7dd_cfo; + backup_pc(sc); + return_true(sc, NULL); + } + if (q_call(o1).fd == opt_d_vd_s) + { + q_arg3(opc).gen = q_arg1(o1).gen; + q_arg2(opc).p = q_arg2(o1).p; + q_func1(opc).d_vd_f = q_func(o1).d_vd_f; + q_call(opc).fd = (func) ? opt_d_dd_cfo1 : opt_d_7dd_cfo1; + backup_pc(sc); + return_true(sc, NULL); + }} + return_false(sc, NULL); +} + +static s7_double opt_d_7pii_scs(opt_info *o); +static s7_double opt_d_7pii_sss(opt_info *o); +static s7_double opt_d_7pii_sss_unchecked(opt_info *o); + +static bool d_dd_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) +{ + s7_pointer slot; + const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); + const int32_t start = sc->pc; + opt_info *o1; + s7_d_7dd_t func7 = NULL; + s7_d_dd_t func = s7_d_dd_function(s_func); + if (!func) + { + func7 = s7_d_7dd_function(s_func); + if (!func7) return_false(sc, expr); + } + if (func) + q_func(opc).d_dd_f = func; + else q_func(opc).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, expr); + q_arg1(opc).x = s7_number_to_real(sc, arg1); + q_arg2(opc).x = s7_number_to_real(sc, arg2); + q_call(opc).fd = (func) ? opt_d_dd_cc : opt_d_7dd_cc; + return_true(sc, expr); + } + slot = opt_float_symbol(sc, arg2); + if (slot) + { + q_arg1(opc).x = s7_number_to_real(sc, arg1); + q_arg2(opc).p = slot; + q_call(opc).fd = (func) ? opt_d_dd_cs : opt_d_7dd_cs; /* see opt_d_vd_o3 above which uses this */ + return_true(sc, expr); + } + if (float_optimize(sc, cddr(expr))) + { + q_arg1(opc).x = s7_number_to_real(sc, arg1); + if (d_dd_call_combinable(sc, opc, func)) + return_true(sc, expr); + q_func1_arg(opc).o1 = sc->opts[start]; + q_func1(opc).fd = q_call(sc->opts[start]).fd; + q_call(opc).fd = (func) ? opt_d_dd_cf : opt_d_7dd_cf; + if ((q_arg1(opc).x == 1.0) && (func == subtract_d_dd)) q_call(opc).fd = opt_d_dd_1f_subtract; + return_true(sc, expr); + } + sc->pc = start; + return_false(sc, expr); + } + + /* arg1 = float symbol */ + slot = opt_float_symbol(sc, arg1); + if (slot) + { + q_arg1(opc).p = slot; + if (is_small_real(arg2)) + { + q_arg2(opc).x = s7_number_to_real(sc, arg2); + if (func) + q_call(opc).fd = (func == subtract_d_dd) ? opt_d_dd_sc_sub : opt_d_dd_sc; + else q_call(opc).fd = opt_d_7dd_sc; + return_true(sc, expr); + } + slot = opt_float_symbol(sc, arg2); + if (slot) + { + q_arg2(opc).p = slot; + if (func) + { + if (func == multiply_d_dd) + q_call(opc).fd = opt_d_dd_ss_mul; + else q_call(opc).fd = (func == add_d_dd) ? opt_d_dd_ss_add : opt_d_dd_ss; + } + else q_call(opc).fd = opt_d_7dd_ss; + return_true(sc, expr); + } + if (float_optimize(sc, cddr(expr))) + { + if (d_dd_sf_combinable(sc, opc, func)) + return_true(sc, expr); + q_func1_arg(opc).o1 = sc->opts[start]; + q_func1(opc).fd = q_call(sc->opts[start]).fd; + if (func) + { + q_call(opc).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) && (q_func1(opc).fd == opt_d_7pii_scs)) + q_call(opc).fd = opt_d_dd_sf_mul_fvref; + } + else q_call(opc).fd = opt_d_7dd_sf; + return_true(sc, expr); + } + sc->pc = start; + return_false(sc, expr); + } + + /* arg1 = float expr or non-float */ + /* first check for obvious d_id cases */ + if (((is_t_integer(arg1)) || (opt_integer_symbol(sc, arg1))) && + (s7_d_id_function(s_func))) + return(d_id_ok_1(sc, opc, s_func, expr, false)); + + o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdr(expr))) + { + int32_t start2 = sc->pc; + if (is_small_real(arg2)) + { + q_arg2(opc).x = s7_number_to_real(sc, arg2); + q_func1_arg(opc).o1 = sc->opts[start]; + q_func1(opc).fd = q_call(sc->opts[start]).fd; + if (func) + { + if (func == add_d_dd) + { + if (q_func1(opc).fd == opt_d_7pi_ss_fvref_direct) + { + q_call(opc).fd = opt_d_dd_fc_fvref_add; + q_arg3(opc).p = q_func1_arg(opc).q_arg1(o1).p; + q_arg4(opc).p = q_func1_arg(opc).q_arg2(o1).p; + } + else q_call(opc).fd = opt_d_dd_fc_add; + return_true(sc, expr); + } + if (func == subtract_d_dd) + { + q_call(opc).fd = opt_d_dd_fc_subtract; + /* if q_call(o1).fd = opt_d_7d_c and its q_func(o).d_7d_f = random_d_7d it's (- (random f1) f2) */ + if ((opc == sc->opts[sc->pc - 2]) && + (q_call(sc->opts[start]).fd == opt_d_7d_c) && + (q_func(sc->opts[start]).d_7d_f == random_d_7d)) + { + q_call(opc).fd = opt_subtract_random_f_f; + q_arg1(opc).x = q_arg1(sc->opts[start]).x; /* random arg */ + backup_pc(sc); + }} + else q_call(opc).fd = opt_d_dd_fc; + } + else q_call(opc).fd = opt_d_7dd_fc; + return_true(sc, expr); + } + slot = opt_float_symbol(sc, arg2); + if (slot) + { + q_arg1(opc).p = slot; + if (d_dd_fs_combinable(sc, opc, func)) + return_true(sc, expr); + q_func1_arg(opc).o1 = sc->opts[start]; + q_func1(opc).fd = q_call(sc->opts[start]).fd; + if (func) + { + q_call(opc).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) && (q_func1(opc).fd == opt_d_7pii_scs)) + q_call(opc).fd = opt_d_dd_fs_add_fvref; + } + else q_call(opc).fd = opt_d_7dd_fs; + return_true(sc, expr); + } + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(expr))) + { + opt_info *o2; + q_func3_arg(opc).o1 = o1; + q_func3(opc).fd = q_call(o1).fd; + q_func2(opc).fd = q_func2_arg(opc).q_call(o1).fd; + if (func) + { + if (d_dd_ff_combinable(sc, opc, start)) + return_true(sc, expr); + q_call(opc).fd = opt_d_dd_ff; + if (func == multiply_d_dd) + { + if (arg1 == arg2) + q_call(opc).fd = opt_d_dd_ff_square; + else + if ((q_func3(opc).fd == opt_d_7pii_sss_unchecked) && (q_func2(opc).fd == opt_d_7pii_sss_unchecked) && + (q_func1(o1).d_7pii_f == float_vector_ref_d_7pii)) + q_call(opc).fd = opt_d_dd_ff_mul_sss_unchecked; + else q_call(opc).fd = opt_d_dd_ff_mul; + return_true(sc, expr); + } + o2 = sc->opts[start2]; /* this is q_func2_arg(opc).o1, v[10] */ + if (func == add_d_dd) + { + if (q_call(o2).fd == opt_d_dd_ff_mul) + { + q_call(opc).fd = opt_d_dd_ff_add_mul; + q_func1_arg(opc).o1 = o1; /* add first arg */ + q_func1(opc).fd = q_call(o1).fd; + q_func3_arg(opc).o1 = q_func3_arg(o2).o1; /* mul first arg */ + q_func3(opc).fd = q_func3(o2).fd; + q_func2_arg(opc).o1 = q_func2_arg(o2).o1; /* mul second arg */ + q_func2(opc).fd = q_func2(o2).fd; + return_true(sc, expr); + } + if ((q_call(o2).fd == opt_d_7pi_sf) && + ((q_func(o2).d_7pi_f == float_vector_ref_d_7pi) || (q_func(o2).d_7pi_f == float_vector_ref_d_7pi_direct))) + { + q_call(opc).fd = opt_d_dd_ff_add_fv_ref; + q_arg1(opc).p = q_arg1(o2).p; + q_func3_arg(opc).o1 = q_func2_arg(o2).o1; /* sc->opts[start2 + 1]; */ + q_func3(opc).fi = q_func2(o2).fi; /* sc->opts[start2 + 1]-v[0].fi; */ + } + else + { + q_call(opc).fd = opt_d_dd_ff_add; + q_func2_arg(opc).o1 = o2; + q_func2(opc).fd = q_call(o2).fd; + if ((q_call(o1).fd == opt_d_7pi_ss_fvref_direct) && (q_func2(opc).fd == opt_d_7dd_ff)) + { + opt_info *ov = q_func2_arg(opc).o1; + if ((q_func(ov).d_7dd_f == divide_d_7dd) && (q_func2(ov).fd == opt_d_id_sf) && (q_func3(ov).fd == opt_d_7pi_ss_fvref_direct)) + { + q_arg1(opc).o1 = o1; + q_arg3(opc).o1 = q_func2_arg(ov).o1; + q_arg2(opc).o1 = q_func3_arg(ov).o1; + q_call(opc).fd = opt_d_7dd_ff_add_div; + }}} + q_func1_arg(opc).o1 = o1; /* sc->opts[start]; */ + q_func1(opc).fd = q_call(o1).fd; /* q_call(sc->opts[start]).fd; */ + return_true(sc, expr); + } + if (func == subtract_d_dd) + { + q_call(opc).fd = opt_d_dd_ff_sub; + q_func1_arg(opc).o1 = o1; /* sc->opts[start]; */ + q_func1(opc).fd = q_call(o1).fd; /* q_call(sc->opts[start]).fd; */ + q_func2_arg(opc).o1 = o2; + q_func2(opc).fd = q_call(o2).fd; + return_true(sc, expr); + }} + else q_call(opc).fd = opt_d_7dd_ff; + return_true(sc, expr); + }} + sc->pc = start; + return_false(sc, expr); +} + +/* -------- d_ddd -------- */ + +static s7_double opt_d_ddd_sss(opt_info *o) {return(q_func(o).d_ddd_f(real(slot_value(q_arg1(o).p)), real(slot_value(q_arg2(o).p)), real(slot_value(q_arg3(o).p))));} +static s7_double opt_d_ddd_ssf(opt_info *o) +{ + return(q_func(o).d_ddd_f(real(slot_value(q_arg1(o).p)), real(slot_value(q_arg2(o).p)), q_d_func2_call(o))); +} + +static s7_double opt_d_ddd_sff(opt_info *o) +{ + s7_double x1 = q_d_func2_call(o); + s7_double x2 = q_d_func3_call(o); + return(q_func(o).d_ddd_f(real(slot_value(q_arg1(o).p)), x1, x2)); +} + +static s7_double opt_d_ddd_fff(opt_info *o) +{ + s7_double x1 = q_d_func2_call(o); + s7_double x2 = q_d_func3_call(o); + s7_double x3 = q_d_func1_call(o); + return(q_func(o).d_ddd_f(x1, x2, x3)); +} + +static s7_double opt_d_ddd_fff1(opt_info *o) +{ + s7_double x1 = q_func1(o).d_v_f(q_func1_arg(o).gen); + s7_double x2 = q_func2(o).d_v_f(q_func2_arg(o).gen); + s7_double x3 = q_func3(o).d_v_f(q_func3_arg(o).gen); + return(q_func(o).d_ddd_f(x1, x2, x3)); +} + +static s7_double opt_d_ddd_fff2(opt_info *o) +{ + s7_double x1 = q_func2(o).d_v_f(q_func2_arg(o).gen); + s7_double x2 = q_d_func3_call(o); + s7_double x3 = q_d_func1_call(o); + return(q_func(o).d_ddd_f(x1, x2, x3)); +} + +static s7_double opt_d_ddd_fff_mul(opt_info *o) +{ + s7_double x1 = opt_D_s(q_func2_arg(o).o1); + s7_double x2 = opt_D_s(q_func3_arg(o).o1); + s7_double x3 = opt_d_s(q_func1_arg(o).o1); + return(multiply_d_ddd(x1, x2, x3)); +} + +static bool d_ddd_fff_combinable(s7_scheme *sc, opt_info *opc, int32_t start) +{ + opt_info *o1; + if (q_call(sc->opts[start]).fd != opt_d_v) + return_false(sc, NULL); + o1 = sc->opts[start]; + q_func2(opc).d_v_f = q_func(o1).d_v_f; + q_func2_arg(opc).gen = q_arg1(o1).gen; + if ((q_call(sc->opts[start + 1]).fd == opt_d_v) && + (q_call(sc->opts[start + 2]).fd == opt_d_v)) + { + opt_info *o2 = sc->opts[start + 2]; + o1 = sc->opts[start + 1]; + q_call(opc).fd = opt_d_ddd_fff1; + q_func1(opc).d_v_f = q_func2(opc).d_v_f; + q_func1_arg(opc).gen = q_func2_arg(opc).gen; + q_func2(opc).d_v_f = q_func(o1).d_v_f; + q_func2_arg(opc).gen = q_arg1(o1).gen; + q_func3(opc).d_v_f = q_func(o2).d_v_f; + q_func3_arg(opc).gen = q_arg1(o2).gen; + sc->pc -= 3; + return_true(sc, NULL); + } + q_call(opc).fd = opt_d_ddd_fff2; /* (* (d-v-func b) (d-v-func b) x) */ + q_func3(opc).fd = q_func3_arg(opc).q_call(o1).fd; + q_func1(opc).fd = q_func1_arg(opc).q_call(o1).fd; + return_true(sc, NULL); +} + +static bool d_ddd_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) +{ + const int32_t start = sc->pc; + s7_pointer arg1_slot; + const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); + const s7_d_ddd_t func = s7_d_ddd_function(s_func); + if (!func) return_false(sc, expr); + q_func(opc).d_ddd_f = func; + arg1_slot = opt_float_symbol(sc, arg1); + q_func2_arg(opc).o1 = sc->opts[start]; + if (arg1_slot) + { + s7_pointer arg2_slot; + q_arg1(opc).p = arg1_slot; + arg2_slot = opt_float_symbol(sc, arg2); + if (arg2_slot) + { + const s7_pointer arg3 = cadddr(expr); + s7_pointer arg3_slot; + q_arg2(opc).p = arg2_slot; + arg3_slot = opt_float_symbol(sc, arg3); + if (arg3_slot) + { + q_arg3(opc).p = arg3_slot; + q_call(opc).fd = opt_d_ddd_sss; + return_true(sc, expr); + } + if (float_optimize(sc, cdddr(expr))) + { + q_func2(opc).fd = q_func2_arg(opc).q_call(o1).fd; + q_call(opc).fd = opt_d_ddd_ssf; + return_true(sc, expr); + } + sc->pc = start; + } + if (float_optimize(sc, cddr(expr))) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdddr(expr))) + { + q_call(opc).fd = opt_d_ddd_sff; + q_func2(opc).fd = q_func2_arg(opc).q_call(o1).fd; + q_func3(opc).fd = q_func3_arg(opc).q_call(o1).fd; + return_true(sc, expr); + }} + sc->pc = start; + } + if (float_optimize(sc, cdr(expr))) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(expr))) + { + q_func1_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdddr(expr))) + { + if (d_ddd_fff_combinable(sc, opc, start)) + return_true(sc, expr); + q_call(opc).fd = opt_d_ddd_fff; /* tfft: (+ (* xout xin iw) (* yout yin ih) (* zout zin id)) */ + q_func2(opc).fd = q_func2_arg(opc).q_call(o1).fd; + q_func3(opc).fd = q_func3_arg(opc).q_call(o1).fd; + q_func1(opc).fd = q_func1_arg(opc).q_call(o1).fd; + if ((func == multiply_d_ddd) && (q_func2(opc).fd == opt_D_s) && (q_func3(opc).fd == opt_D_s) && (q_func1(opc).fd == opt_d_s)) + q_call(opc).fd = opt_d_ddd_fff_mul; + return_true(sc, expr); + }}} + sc->pc = start; + return_false(sc, expr); +} + +/* -------- d_7pid -------- */ + +static s7_double opt_d_7pid_ssf(opt_info *o) +{ + return(q_func(o).d_7pid_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), q_d_func2_call(o))); +} + +static s7_pointer opt_d_7pid_ssf_nr(opt_info *o) +{ + q_func(o).d_7pid_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), q_d_func2_call(o)); + return(NULL); +} + +static s7_double opt_d_7pid_sss(opt_info *o) +{ + return(q_func(o).d_7pid_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), real(slot_value(q_arg3(o).p)))); +} + +static s7_double opt_d_7pid_ssc(opt_info *o) +{ + return(q_func(o).d_7pid_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), q_arg3(o).x)); +} + +static s7_double opt_d_7pid_sff(opt_info *o) +{ + s7_int pos = q_i_func2_call(o); + return(q_func(o).d_7pid_f(o->sc, slot_value(q_arg1(o).p), pos, q_d_func3_call(o))); +} + +static s7_double opt_d_7pid_sff_fvset(opt_info *o) +{ + s7_int pos = q_i_func2_call(o); + return(float_vector_set_d_7pid(o->sc, slot_value(q_arg1(o).p), pos, q_d_func3_call(o))); +} + +static s7_double opt_d_7pid_sso(opt_info *o) +{ + return(q_func(o).d_7pid_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), q_func1(o).d_v_f(q_func1_arg(o).gen))); +} + +static s7_double opt_d_7pid_ss_ss(opt_info *o) +{ + return(q_func(o).d_7pid_f(o->sc, slot_value(q_arg1(o).p), + integer(slot_value(q_arg2(o).p)), + q_func1(o).d_7pi_f(o->sc, slot_value(q_arg3(o).p), integer(slot_value(q_arg4(o).p))))); +} + +static s7_double opt_d_7pid_ssfo(opt_info *o) +{ + s7_pointer fv = slot_value(q_arg1(o).p); + return(q_func(o).d_7pid_f(o->sc, fv, integer(slot_value(q_arg2(o).p)), + q_func2(o).d_dd_f(q_func1(o).d_7pi_f(o->sc, fv, integer(slot_value(q_arg3(o).p))), real(slot_value(q_arg4(o).p))))); +} + +static s7_double opt_d_7pid_ssfo_fv(opt_info *o) +{ + s7_double *els = float_vector_floats(slot_value(q_arg1(o).p)); + s7_double val = q_func2(o).d_dd_f(els[integer(slot_value(q_arg3(o).p))], real(slot_value(q_arg4(o).p))); + els[integer(slot_value(q_arg2(o).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(q_arg1(o).p)); + els[integer(slot_value(q_arg2(o).p))] = q_func2(o).d_dd_f(els[integer(slot_value(q_arg3(o).p))], real(slot_value(q_arg4(o).p))); + return(NULL); +} + +static s7_pointer opt_d_7pid_ssfo_fv_add_nr(opt_info *o) +{ + s7_double *els = float_vector_floats(slot_value(q_arg1(o).p)); + els[integer(slot_value(q_arg2(o).p))] = els[integer(slot_value(q_arg3(o).p))] + real(slot_value(q_arg4(o).p)); + return(NULL); +} + +static s7_pointer opt_d_7pid_ssfo_fv_sub_nr(opt_info *o) +{ + s7_double *els = float_vector_floats(slot_value(q_arg1(o).p)); + els[integer(slot_value(q_arg2(o).p))] = els[integer(slot_value(q_arg3(o).p))] - real(slot_value(q_arg4(o).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 (q_call(o1).fd == opt_d_v) + { + q_func1_arg(opc).gen = q_arg1(o1).gen; + q_func1(opc).d_v_f = q_func(o1).d_v_f; + q_call(opc).fd = opt_d_7pid_sso; + backup_pc(sc); + return_true(sc, NULL); + } + if ((q_call(o1).fd == opt_d_7pi_ss) || (q_call(o1).fd == opt_d_7pi_ss_fvref) || (q_call(o1).fd == opt_d_7pi_ss_fvref_direct)) + { + q_func1(opc).d_7pi_f = q_func(o1).d_7pi_f; + q_arg3(opc).p = q_arg1(o1).p; + q_arg4(opc).p = q_arg2(o1).p; + q_call(opc).fd = opt_d_7pid_ss_ss; + backup_pc(sc); + return_true(sc, NULL); + } + if ((q_call(o1).fd == opt_d_dd_fso) && + (q_arg1(opc).p == q_arg2(o1).p)) + { + q_func2(opc).d_dd_f = q_func(o1).d_dd_f; + q_func1(opc).d_7pi_f = q_func1(o1).d_7pi_f; + q_arg3(opc).p = q_arg3(o1).p; + q_arg4(opc).p = q_arg1(o1).p; + q_call(opc).fd = opt_d_7pid_ssfo; + if (((q_func1(opc).d_7pi_f == float_vector_ref_d_7pi) || (q_func1(opc).d_7pi_f == float_vector_ref_d_7pi_direct)) && + ((q_func(opc).d_7pid_f == float_vector_set_d_7pid_direct) || (q_func(opc).d_7pid_f == float_vector_set_d_7pid))) + q_call(opc).fd = opt_d_7pid_ssfo_fv; /* actually if either is *_d, we need to check the indices */ + backup_pc(sc); + return_true(sc, NULL); + }} + 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, const s7_pointer s_func, const s7_pointer expr) +{ + const s7_d_7pid_t func = s7_d_7pid_function(s_func); + if ((func) && (is_symbol(cadr(expr)))) + { + const s7_pointer head = car(expr); + const int32_t start = sc->pc; + q_func(opc).d_7pid_f = func; + + if (is_target_or_its_alias(head, s_func, sc->float_vector_set_symbol)) + return(opt_float_vector_set(sc, opc, cadr(expr), cddr(expr), NULL, NULL, cdddr(expr))); + + q_arg1(opc).p = s7_slot(sc, cadr(expr)); + if (!is_slot(q_arg1(opc).p)) return_false(sc, expr); + q_func2_arg(opc).o1 = sc->opts[start]; + if (is_slot(q_arg1(opc).p)) + { + s7_pointer arg2_slot = opt_integer_symbol(sc, caddr(expr)); + if (arg2_slot) + { + s7_pointer arg3_slot; + q_arg2(opc).p = arg2_slot; + arg3_slot = opt_float_symbol(sc, cadddr(expr)); + if (arg3_slot) + { + q_arg3(opc).p = arg3_slot; + q_call(opc).fd = opt_d_7pid_sss; + return_true(sc, expr); + } + if (float_optimize(sc, cdddr(expr))) + { + q_func2(opc).fd = q_call(sc->opts[start]).fd; + if (d_7pid_ssf_combinable(sc, opc)) + return_true(sc, expr); + q_call(opc).fd = opt_d_7pid_ssf; + return_true(sc, expr); + } + sc->pc = start; + } + if (int_optimize(sc, cddr(expr))) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdddr(expr))) + { + q_call(opc).fd = opt_d_7pid_sff; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func3(opc).fd = q_func3_arg(opc).q_call(o1).fd; + return_true(sc, expr); + }} + sc->pc = start; + }} + return_false(sc, expr); +} + +/* -------- 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) +{ + return(float_vector_ref_d_7pii(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), integer(slot_value(q_arg3(o).p)))); +} + +static s7_double opt_d_7pii_sss_unchecked(opt_info *o) +{ + s7_pointer vec = slot_value(q_arg1(o).p); + return(float_vector(vec, ((integer(slot_value(q_arg2(o).p)) * vector_offset(vec, 0)) + integer(slot_value(q_arg3(o).p))))); +} + +static s7_double opt_d_7pii_scs(opt_info *o) +{ + return(float_vector_ref_d_7pii(o->sc, slot_value(q_arg1(o).p), q_arg2(o).i, integer(slot_value(q_arg3(o).p)))); +} + +static s7_double opt_d_7pii_sff(opt_info *o) +{ + return(float_vector_ref_d_7pii(o->sc, slot_value(q_arg1(o).p), q_i_func2_call(o), q_i_func3_call(o))); +} + +static bool d_7pii_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) +{ + const s7_d_7pii_t ifunc = s7_d_7pii_function(s_func); + if ((ifunc == float_vector_ref_d_7pii) && + (is_symbol(cadr(expr)))) + { + s7_pointer arg3_slot; + const int32_t start = sc->pc; + q_arg1(opc).p = s7_slot(sc, cadr(expr)); + if ((!is_slot(q_arg1(opc).p)) || + (!is_float_vector(slot_value(q_arg1(opc).p))) || + (vector_rank(slot_value(q_arg1(opc).p)) != 2)) + return_false(sc, expr); + + arg3_slot = opt_integer_symbol(sc, cadddr(expr)); + if (arg3_slot) + { + s7_pointer arg2_slot; + q_arg3(opc).p = arg3_slot; + arg2_slot = opt_integer_symbol(sc, caddr(expr)); + if (arg2_slot) + { + q_arg2(opc).p = arg2_slot; + q_call(opc).fd = opt_d_7pii_sss; + if ((loop_end_fits(q_arg2(opc).p, vector_dimension(slot_value(q_arg1(opc).p), 0))) && /* see also d_implicit_ok */ + (loop_end_fits(q_arg3(opc).p, vector_dimension(slot_value(q_arg1(opc).p), 1)))) + q_call(opc).fd = opt_d_7pii_sss_unchecked; + return_true(sc, expr); + } + if (is_t_integer(caddr(expr))) + { + q_arg2(opc).i = integer(caddr(expr)); + q_call(opc).fd = opt_d_7pii_scs; + return_true(sc, expr); + }} + q_func2_arg(opc).o1 = sc->opts[start]; + if (int_optimize(sc, cddr(expr))) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdddr(expr))) + { + q_call(opc).fd = opt_d_7pii_sff; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func3(opc).fi = q_func3_arg(opc).q_call(o1).fi; + return_true(sc, expr); + }} + sc->pc = start; + } + return_false(sc, expr); +} + +/* -------- d_7piid -------- */ +/* currently only float_vector_set */ + +static s7_double opt_d_7piid_sssf(opt_info *o) +{ + return(float_vector_set_d_7piid(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), integer(slot_value(q_arg3(o).p)), q_d_func3_call(o))); +} + +static s7_double opt_d_7piid_sssc(opt_info *o) +{ + return(float_vector_set_d_7piid(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), integer(slot_value(q_arg3(o).p)), q_arg4(o).x)); +} + +static s7_double opt_d_7piid_scsf(opt_info *o) +{ + return(float_vector_set_d_7piid(o->sc, slot_value(q_arg1(o).p), q_arg2(o).i, integer(slot_value(q_arg3(o).p)), q_d_func2_call(o))); +} + +static s7_double opt_d_7piid_sfff(opt_info *o) +{ + s7_int i1 = q_i_func2_call(o); + s7_int i2 = q_i_func3_call(o); + s7_double val = q_d_func4_call(o); + return(float_vector_set_d_7piid(o->sc, slot_value(q_arg1(o).p), i1, i2, val)); +} + +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 = integer(slot_value(q_arg2(o).p)), i2 = integer(slot_value(q_arg3(o).p)); + s7_pointer vect = slot_value(q_arg1(o).p); + s7_double val = q_d_func3_call(o); + float_vector(vect, (i1 * (vector_offset(vect, 0)) + i2)) = val; + return(val); +} + +static bool d_7piid_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) +{ + const s7_d_7piid_t func = s7_d_7piid_function(s_func); + if ((func) && + (is_symbol(cadr(expr)))) + { + if (is_target_or_its_alias(car(expr), s_func, sc->float_vector_set_symbol)) + return(opt_float_vector_set(sc, opc, cadr(expr), cddr(expr), cdddr(expr), NULL, cddddr(expr))); + } + return_false(sc, expr); +} + +/* -------- d_7piii -------- */ +static s7_double opt_d_7piii_ssss(opt_info *o) +{ + return(float_vector_ref_d_7piii(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), + integer(slot_value(q_arg3(o).p)), integer(slot_value(q_arg4(o).p)))); +} + +static s7_double opt_d_7piii_ssss_unchecked(opt_info *o) +/* not in s7test (tvect: ((do ((i 0...))) ((= i ...)) (do ((n 0 ...)) ((= n ...)) (set! sum (+ sum (float-vector-ref v k i n)))))) */ +{ + s7_pointer vec = slot_value(q_arg1(o).p); + s7_int i1 = integer(slot_value(q_arg2(o).p)) * vector_offset(vec, 0); + s7_int i2 = integer(slot_value(q_arg3(o).p)) * vector_offset(vec, 1); /* offsets accumulate */ + return(float_vector(vec, (i1 + i2 + integer(slot_value(q_arg4(o).p))))); +} + +static bool d_7piii_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) +{ + if ((s_func == global_value(sc->float_vector_ref_symbol)) && + (is_symbol(cadr(expr)))) + { + s7_pointer arg4_slot; + q_arg1(opc).p = s7_slot(sc, cadr(expr)); + if ((!is_slot(q_arg1(opc).p)) || + (!is_float_vector(slot_value(q_arg1(opc).p))) || + (vector_rank(slot_value(q_arg1(opc).p)) != 3)) + return_false(sc, expr); + arg4_slot = opt_integer_symbol(sc, car(cddddr(expr))); + if (arg4_slot) + { + s7_pointer arg3_slot; + q_arg4(opc).p = arg4_slot; + arg3_slot = opt_integer_symbol(sc, cadddr(expr)); + if (arg3_slot) + { + s7_pointer arg2_slot; + q_arg3(opc).p = arg3_slot; + arg2_slot = opt_integer_symbol(sc, caddr(expr)); + if (arg2_slot) + { + const s7_pointer vect = slot_value(q_arg1(opc).p); + q_arg2(opc).p = arg2_slot; + q_call(opc).fd = opt_d_7piii_ssss; + if ((loop_end_fits(q_arg2(opc).p, vector_dimension(vect, 0))) && + (loop_end_fits(q_arg3(opc).p, vector_dimension(vect, 1))) && + (loop_end_fits(q_arg4(opc).p, vector_dimension(vect, 2)))) + q_call(opc).fd = opt_d_7piii_ssss_unchecked; + return_true(sc, expr); + }}}} + return_false(sc, expr); +} + +/* -------- d_7piiid -------- */ +static s7_double opt_d_7piiid_ssssf(opt_info *o) +{ + return(float_vector_set_d_7piiid(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), + integer(slot_value(q_arg3(o).p)), integer(slot_value(q_arg4(o).p)), q_d_func2_call(o))); +} + +static s7_double opt_d_7piiid_ssssf_unchecked(opt_info *o) +{ + s7_pointer vect = slot_value(q_arg1(o).p); + s7_int i1 = integer(slot_value(q_arg2(o).p)) * vector_offset(vect, 0); + s7_int i2 = integer(slot_value(q_arg3(o).p)) * vector_offset(vect, 1); + s7_int i3 = integer(slot_value(q_arg4(o).p)); + s7_double val = q_d_func2_call(o); + float_vector(vect, (i1 + i2 + i3)) = val; + return(val); +} + +static bool d_7piiid_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) +{ + if ((s_func == global_value(sc->float_vector_set_symbol)) && + (is_symbol(cadr(expr)))) + { + if (is_target_or_its_alias(car(expr), s_func, sc->float_vector_set_symbol)) + return(opt_float_vector_set(sc, opc, cadr(expr), cddr(expr), cdddr(expr), cddddr(expr), cdr(cddddr(expr)))); + } + return_false(sc, expr); +} + +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) +{ + const s7_pointer settee = s7_slot(sc, v); + if ((is_slot(settee)) && + (!is_immutable(slot_value(settee)))) + { + const s7_pointer vect = slot_value(settee); + const int32_t start = sc->pc; + q_arg1(opc).p = settee; + if (!is_float_vector(vect)) return_false(sc, vect); + q_func2_arg(opc).o1 = sc->opts[start]; + if ((!indexp2) && + (vector_rank(vect) == 1)) + { + s7_pointer ind1_slot; + q_func(opc).d_7pid_f = float_vector_set_d_7pid; + ind1_slot = opt_integer_symbol(sc, car(indexp1)); + if (ind1_slot) + { + s7_pointer val_slot; + q_arg2(opc).p = ind1_slot; + if (loop_end_fits(q_arg2(opc).p, vector_length(vect))) + q_func(opc).d_7pid_f = float_vector_set_d_7pid_direct; + val_slot = opt_float_symbol(sc, car(valp)); + if (val_slot) + { + q_arg3(opc).p = val_slot; + q_call(opc).fd = opt_d_7pid_sss; + return_true(sc, NULL); + } + if (is_small_real(car(valp))) + { + q_arg3(opc).x = s7_real(car(valp)); + q_call(opc).fd = opt_d_7pid_ssc; + return_true(sc, NULL); + } + if (float_optimize(sc, valp)) + { + q_func2(opc).fd = q_call(sc->opts[start]).fd; + if (d_7pid_ssf_combinable(sc, opc)) + return_true(sc, NULL); + q_call(opc).fd = opt_d_7pid_ssf; + return_true(sc, NULL); + } + sc->pc = start; + } + if (int_optimize(sc, indexp1)) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, valp)) + { + q_call(opc).fd = (q_func(opc).d_7pid_f == float_vector_set_d_7pid) ? opt_d_7pid_sff_fvset : opt_d_7pid_sff; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func3(opc).fd = q_func3_arg(opc).q_call(o1).fd; + return_true(sc, NULL); + }} + return_false(sc, indexp1); + } + if ((indexp2) && (!indexp3) && + (vector_rank(vect) == 2)) + { + s7_pointer ind2_slot; + q_func1(opc).d_7piid_f = float_vector_set_d_7piid; + /* could check for loop_end/end-ok here for both indices, but the d_7pii* functions currently assume fv_d_7piid + * perhaps set a different fd? so q_call(opc).fd = fvset_unchecked_d_7piid or whatever + */ + ind2_slot = opt_integer_symbol(sc, car(indexp2)); + if (ind2_slot) + { + s7_pointer ind1_slot; + q_arg3(opc).p = ind2_slot; + if (is_t_integer(car(indexp1))) + { + if (!float_optimize(sc, valp)) + return_false(sc, valp); + q_call(opc).fd = opt_d_7piid_scsf; + q_arg2(opc).i = integer(car(indexp1)); + q_func2(opc).fd = q_func2_arg(opc).q_call(o1).fd; + return_true(sc, NULL); + } + ind1_slot = opt_integer_symbol(sc, car(indexp1)); + if (ind1_slot) + { + q_arg2(opc).p = ind1_slot; + if (is_small_real(car(valp))) + { + q_call(opc).fd = opt_d_7piid_sssc; + q_arg4(opc).x = s7_real(car(valp)); + return_true(sc, NULL); + } + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, valp)) + { + q_call(opc).fd = opt_d_7piid_sssf; + q_func3(opc).fd = q_func3_arg(opc).q_call(o1).fd; + if ((loop_end_fits(q_arg2(opc).p, vector_dimension(vect, 0))) && + (loop_end_fits(q_arg3(opc).p, vector_dimension(vect, 1)))) + q_call(opc).fd = opt_d_7piid_sssf_unchecked; + return_true(sc, NULL); + } + sc->pc = start; + }} + if (int_optimize(sc, indexp1)) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, indexp2)) + { + q_func4_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, valp)) + { + q_call(opc).fd = opt_d_7piid_sfff; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func3(opc).fi = q_func3_arg(opc).q_call(o1).fi; + q_func4(opc).fd = q_func4_arg(opc).q_call(o1).fd; + return_true(sc, NULL); + }}} + return_false(sc, indexp1); + } + if ((indexp3) && + (vector_rank(vect) == 3)) + { + s7_pointer ind3_slot; + ind3_slot = opt_integer_symbol(sc, car(indexp3)); + if (ind3_slot) + { + s7_pointer ind2_slot; + q_arg4(opc).p = ind3_slot; + ind2_slot = opt_integer_symbol(sc, car(indexp2)); + if (ind2_slot) + { + s7_pointer ind1_slot; + q_arg3(opc).p = ind2_slot; + ind1_slot = opt_integer_symbol(sc, car(indexp1)); + if (ind1_slot) + { + q_arg2(opc).p = ind1_slot; + if (float_optimize(sc, valp)) + { + q_call(opc).fd = opt_d_7piiid_ssssf; + q_func2(opc).fd = q_call(sc->opts[start]).fd; + if ((loop_end_fits(q_arg2(opc).p, vector_dimension(vect, 0))) && + (loop_end_fits(q_arg3(opc).p, vector_dimension(vect, 1))) && + (loop_end_fits(q_arg4(opc).p, vector_dimension(vect, 2)))) + q_call(opc).fd = opt_d_7piiid_ssssf_unchecked; + return_true(sc, NULL); + }}}}}} + return_false(sc, NULL); +} + + +/* -------- d_vid -------- */ +static s7_double opt_d_vid_ssf(opt_info *o) {return(q_func(o).d_vid_f(q_arg1(o).gen, integer(slot_value(q_arg2(o).p)), q_d_func2_call(o)));} + +static inline s7_double opt_fmv(opt_info *o) +{ + opt_info *o1 = q_arg3(o).o1; /* opt_d_dd_ff_mul1 */ + opt_info *o2 = q_arg4(o).o1; /* opt_d_vd_o1 */ + opt_info *o3 = q_arg5(o).o1; /* opt_d_dd_ff_o3 */ + s7_double amp_env = q_func3(o1).d_v_f(q_arg1(o1).gen); + s7_double vib = real(slot_value(q_arg2(o2).p)); + s7_double index_env = q_func3(o3).d_v_f(q_arg1(o3).gen); + return(q_func(o).d_vid_f(q_arg1(o).gen, + integer(slot_value(q_arg2(o).p)), + amp_env * q_func(o2).d_vd_f(q_arg1(o2).gen, + vib + (index_env * q_func2(o3).d_vd_f(q_arg2(o3).gen, vib))))); +} + +static bool d_vid_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) +{ + if ((is_symbol(cadr(expr))) && + (is_symbol(caddr(expr)))) + { + s7_pointer sig; + const s7_d_vid_t flt = s7_d_vid_function(s_func); + if (!flt) return_false(sc, expr); + q_func(opc).d_vid_f = flt; + sig = c_function_signature(s_func); + if (is_pair(sig)) + { + const int32_t start = sc->pc; + const s7_pointer vslot = opt_types_match(sc, cadr(sig), cadr(expr)); + if (vslot) + { + s7_pointer arg2_slot; + q_call(opc).fd = opt_d_vid_ssf; + q_arg1(opc).p = vslot; + q_func2_arg(opc).o1 = sc->opts[start]; + arg2_slot = opt_integer_symbol(sc, caddr(expr)); + if ((arg2_slot) && + (float_optimize(sc, cdddr(expr)))) + { + opt_info *o2; + q_arg2(opc).p = arg2_slot; + q_arg1(opc).gen = (void *)c_object_value(slot_value(vslot)); + q_func2(opc).fd = q_func2_arg(opc).q_call(o1).fd; + o2 = sc->opts[start]; + if (q_call(o2).fd == opt_d_dd_ff_mul1) + { + opt_info *o3 = sc->opts[start + 2]; + if (q_call(o3).fd == opt_d_vd_o1) + { + opt_info *o1 = sc->opts[start + 4]; + if ((q_call(o1).fd == opt_d_dd_ff_o3) && + (q_func1(o1).d_dd_f == multiply_d_dd) && + (q_func3(o3).d_dd_f == add_d_dd)) + { + q_call(opc).fd = opt_fmv; /* expr: (locsig locs i (* (env ampf) (oscil carrier (+ vib (* (env indf1) (polywave fmosc1 vib)))))) */ + q_arg3(opc).o1 = o2; /* opt_d_dd_ff_mul1 */ + q_arg4(opc).o1 = o3; /* opt_d_vd_o1 */ + q_arg5(opc).o1 = o1; /* opt_d_dd_ff_o3 */ + }}} + return_true(sc, expr); + }} + sc->pc = start; + }} + return_false(sc, expr); +} + +/* -------- d_vdd -------- */ +static s7_double opt_d_vdd_ff(opt_info *o) +{ + s7_double x1 = q_d_func2_call(o); + s7_double x2 = q_d_func3_call(o); + return(q_func(o).d_vdd_f(q_arg1(o).gen, x1, x2)); +} + +static bool d_vdd_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) +{ + const s7_d_vdd_t flt = s7_d_vdd_function(s_func); + if (flt) + { + const s7_pointer sig = c_function_signature(s_func); + q_func(opc).d_vdd_f = flt; + if (is_pair(sig)) + { + const s7_pointer slot = opt_types_match(sc, cadr(sig), cadr(expr)); + if (slot) + { + const int32_t start = sc->pc; + q_func2_arg(opc).o1 = sc->opts[start]; + if (float_optimize(sc, cddr(expr))) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdddr(expr))) + { + q_func2(opc).fd = q_func2_arg(opc).q_call(o1).fd; + q_func3(opc).fd = q_func3_arg(opc).q_call(o1).fd; + q_arg1(opc).gen = (void *)c_object_value(slot_value(slot)); + q_call(opc).fd = opt_d_vdd_ff; + return_true(sc, expr); + }} + sc->pc = start; + }}} + return_false(sc, expr); +} + +/* -------- d_dddd -------- */ + +static s7_double opt_d_dddd_ffff(opt_info *o) +{ + s7_double x1 = q_d_func1_call(o); + s7_double x2 = q_d_func2_call(o); + s7_double x3 = q_d_func3_call(o); + s7_double x4 = q_d_func4_call(o); + return(q_func(o).d_dddd_f(x1, x2, x3, x4)); +} + +static bool d_dddd_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) +{ + const s7_d_dddd_t func = s7_d_dddd_function(s_func); + if (!func) return_false(sc, expr); + q_func1_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdr(expr))) + { + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(expr))) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdddr(expr))) + { + q_func4_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddddr(expr))) + { + q_func(opc).d_dddd_f = func; + q_call(opc).fd = opt_d_dddd_ffff; + q_func1(opc).fd = q_func1_arg(opc).q_call(o1).fd; + q_func2(opc).fd = q_func2_arg(opc).q_call(o1).fd; + q_func3(opc).fd = q_func3_arg(opc).q_call(o1).fd; + q_func4(opc).fd = q_func4_arg(opc).q_call(o1).fd; + return_true(sc, expr); + }}}} + return_false(sc, expr); +} + +/* -------- d_add|multiply|subtract_any ------- */ +#define q_d_am_arg(o, i) o->v[i + 2] + +static s7_double opt_d_add_any_f(opt_info *o) +{ + s7_double sum = 0.0; + for (s7_int i = 0; i < q_arg1(o).i; i++) + { + opt_info *o1 = q_d_am_arg(o, i).o1; + sum += q_call(o1).fd(o1); + } + return(sum); +} + +static s7_double opt_d_multiply_any_f(opt_info *o) +{ + s7_double sum = 1.0; + for (s7_int i = 0; i < q_arg1(o).i; i++) + { + opt_info *o1 = q_d_am_arg(o, i).o1; + sum *= q_call(o1).fd(o1); + } + return(sum); +} + +static bool d_add_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer expr) +{ + const s7_pointer head = car(expr); + const 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(expr); (is_pair(p)) && (cur_len < 12); p = cdr(p), cur_len++) + { + q_d_am_arg(opc, cur_len).o1 = sc->opts[sc->pc]; + if (!float_optimize(sc, p)) + break; + } + if (is_null(p)) + { + q_arg1(opc).i = cur_len; + q_call(opc).fd = (head == sc->add_symbol) ? opt_d_add_any_f : opt_d_multiply_any_f; + return_true(sc, expr); + }} + sc->pc = start; + return_false(sc, expr); +} + +/* -------- d_syntax -------- */ +static s7_double opt_set_d_d_f(opt_info *o) +{ + s7_double x = q_func(o).fd(q_arg2(o).o1); + slot_set_value(q_arg1(o).p, make_real(o->sc, x)); + return(x); +} + +static s7_double opt_set_d_d_fm(opt_info *o) +{ + s7_double x = q_func(o).fd(q_arg2(o).o1); + check_mutability(o->sc, o, __func__, __LINE__); + set_real(slot_value(q_arg1(o).p), x); + return(x); +} + +static bool d_syntax_ok(s7_scheme *sc, s7_pointer expr, int32_t len) +{ + if ((len == 3) && + (car(expr) == sc->set_symbol)) + { + const s7_pointer arg1 = cadr(expr); + opt_info *opc = alloc_opt_info(sc); + if (is_symbol(arg1)) + { + s7_pointer settee; + if (is_immutable(arg1)) return_false(sc, expr); + settee = s7_slot(sc, arg1); + if ((is_slot(settee)) && + (is_t_real(slot_value(settee))) && + (!is_immutable_slot(settee)) && + ((!slot_has_setter(settee)) || + ((is_c_function(slot_setter(settee))) && + ((is_eq_initial_c_function_data(sc->is_float_symbol, slot_setter(settee))) || + (c_function_call(slot_setter(settee)) == b_is_float_setter))))) + { + opt_info *o1 = sc->opts[sc->pc]; + q_arg1(opc).p = settee; + if ((!is_t_integer(caddr(expr))) && + (float_optimize(sc, cddr(expr)))) + { /* tari: (set! rlo (min rlo (real-part (v i)))) -- can't tell here that it is used only in this line in the do body */ + /* PERHAPS: if tree_count(body) - tree_count(line) == 0 and no setters within line it's safe as mutable? use the two_sets bit as before? */ + /* but we also need a list of such opt_info ptrs to cancel mutability at the end */ + /* tall: (set! la ca)! (How?) + * (set! temp1 (one-zero dryTap0 (one-pole dryTap1 (piano-noise pnoise amp)))) + * and many more, but none will be self-contained I think + */ + q_call(opc).fd = (is_mutable_number(slot_value(q_arg1(opc).p))) ? opt_set_d_d_fm : opt_set_d_d_f; + q_arg2(opc).o1 = o1; + q_func(opc).fd = q_call(o1).fd; + return_true(sc, expr); + }}} + else /* if is_pair(settee) get setter */ + if ((is_pair(arg1)) && + (is_symbol(car(arg1))) && + (is_pair(cdr(arg1)))) + { + if (is_null(cddr(arg1))) + return(opt_float_vector_set(sc, opc, car(arg1), cdr(arg1), NULL, NULL, cddr(expr))); + if (is_null(cdddr(arg1))) + return(opt_float_vector_set(sc, opc, car(arg1), cdr(arg1), cddr(arg1), NULL, cddr(expr))); + }} + return_false(sc, expr); +} + +static bool d_implicit_ok(s7_scheme *sc, s7_pointer s_slot, s7_pointer expr, int32_t len) +{ + const s7_pointer obj = slot_value(s_slot); + if (is_float_vector(obj)) + { + /* implicit float-vector-ref */ + if ((len == 2) && + (vector_rank(obj) == 1)) + { + s7_pointer arg1_slot; + opt_info *opc = alloc_opt_info(sc); + q_arg1(opc).p = s_slot; + q_func(opc).d_7pi_f = float_vector_ref_d_7pi; + arg1_slot = opt_integer_symbol(sc, cadr(expr)); + if (arg1_slot) + { + q_arg2(opc).p = arg1_slot; + if (loop_end_fits(q_arg2(opc).p, vector_length(obj))) + q_call(opc).fd = opt_d_7pi_ss_fvref_direct; + else q_call(opc).fd = opt_d_7pi_ss_fvref; + return_true(sc, expr); + } + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (!int_optimize(sc, cdr(expr))) + return_false(sc, expr); + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_call(opc).fd = opt_d_7pi_sf; + return_true(sc, expr); + } + if ((len == 3) && + (vector_rank(obj) == 2)) + { + s7_pointer arg1_slot; + opt_info *opc = alloc_opt_info(sc); + q_arg1(opc).p = s_slot; + q_func1(opc).d_7pii_f = float_vector_ref_d_7pii; /* not used in opt_d_7pii_sss_unchecked or opt_d_7pii_sff, but d_dd_ok checks it */ + arg1_slot = opt_integer_symbol(sc, cadr(expr)); + if (arg1_slot) + { + s7_pointer arg2_slot; + q_arg2(opc).p = arg1_slot; + arg2_slot = opt_integer_symbol(sc, caddr(expr)); + if (arg2_slot) + { + q_arg3(opc).p = arg2_slot; + q_call(opc).fd = opt_d_7pii_sss; + if ((loop_end_fits(q_arg2(opc).p, vector_dimension(obj, 0))) && + (loop_end_fits(q_arg3(opc).p, vector_dimension(obj, 1)))) + q_call(opc).fd = opt_d_7pii_sss_unchecked; + return_true(sc, expr); + }} + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(expr))) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + q_call(opc).fd = opt_d_7pii_sff; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func3(opc).fi = q_func3_arg(opc).q_call(o1).fi; + return_true(sc, expr); + }}} + if ((len == 4) && + (vector_rank(obj) == 3)) + { + s7_pointer arg1_slot; + opt_info *opc = alloc_opt_info(sc); + q_arg1(opc).p = s_slot; + arg1_slot = opt_integer_symbol(sc, cadr(expr)); + if (arg1_slot) + { + s7_pointer arg2_slot; + q_arg2(opc).p = arg1_slot; + arg2_slot = opt_integer_symbol(sc, caddr(expr)); + if (arg2_slot) + { + s7_pointer arg3_slot; + q_arg3(opc).p = arg2_slot; + arg3_slot = opt_integer_symbol(sc, cadddr(expr)); + if (arg3_slot) + { + q_arg4(opc).p = arg3_slot; + q_call(opc).fd = opt_d_7piii_ssss; + if ((loop_end_fits(q_arg2(opc).p, vector_dimension(obj, 0))) && + (loop_end_fits(q_arg3(opc).p, vector_dimension(obj, 1))) && + (loop_end_fits(q_arg4(opc).p, vector_dimension(obj, 2)))) + q_call(opc).fd = opt_d_7piii_ssss_unchecked; + return_true(sc, expr); + }}}}} + if ((is_c_object(obj)) && + (len == 2)) + { + const s7_pointer getf = c_object_getf(sc, obj); + if (is_c_function(getf)) /* default is #f */ + { + const s7_d_7pi_t func = s7_d_7pi_function(getf); + if (func) + { + s7_pointer arg1_slot; + opt_info *opc = alloc_opt_info(sc); + q_arg1(opc).p = s_slot; + /* opc-v[4].gen = (void *)c_object_value(obj); */ + q_func(opc).d_7pi_f = func; + arg1_slot = opt_integer_symbol(sc, cadr(expr)); + if (arg1_slot) + { + q_call(opc).fd = opt_d_7pi_ss; + q_arg2(opc).p = arg1_slot; + return_true(sc, expr); + } + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(expr))) + { + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_call(opc).fd = opt_d_7pi_sf; + return_true(sc, expr); + }}}} + return_false(sc, expr); +} + +/* -------------------------------- bool opts -------------------------------- */ + +static bool opt_b_s(opt_info *o) {return(slot_value(q_arg1(o).p) != o->sc->F);} + +static bool opt_bool_not_pair(s7_scheme *sc, s7_pointer expr) +{ + s7_pointer slot; + if (!is_symbol(expr)) return_false(sc, expr); /* i.e. use cell_optimize */ + slot = opt_simple_symbol(sc, expr); + if ((slot) && + (is_boolean(slot_value(slot)))) + { + opt_info *opc = alloc_opt_info(sc); + q_arg1(opc).p = slot; + q_call(opc).fb = opt_b_s; + return_true(sc, expr); + } + return_false(sc, expr); +} + +/* -------- b_idp -------- */ +static bool opt_b_i_s(opt_info *o) {return(q_func(o).b_i_f(integer(slot_value(q_arg1(o).p))));} +static bool opt_b_i_f(opt_info *o) {return(q_func(o).b_i_f(q_i_func1_call(o)));} +static bool opt_b_d_s(opt_info *o) {return(q_func(o).b_d_f(s7_real(slot_value(q_arg1(o).p))));} /* not s7test tmap */ +static bool opt_b_d_f(opt_info *o) {return(q_func(o).b_d_f(q_d_func1_call(o)));} +static bool opt_b_p_s(opt_info *o) {return(q_func(o).b_p_f(slot_value(q_arg1(o).p)));} +static bool opt_b_p_f(opt_info *o) {return(q_func(o).b_p_f(q_p_func1_call(o)));} /* used in opt_if_nbp_s */ +static bool opt_b_7p_s(opt_info *o) {return(q_func(o).b_7p_f(o->sc, slot_value(q_arg1(o).p)));} +static bool opt_b_7p_s_not(opt_info *o) {return(slot_value(q_arg1(o).p) == o->sc->F);} /* not s7test *shoot */ +static bool opt_b_7p_f(opt_info *o) {return(q_func(o).b_7p_f(o->sc, q_p_func1_call(o)));} +static bool opt_b_d_s_is_positive(opt_info *o) {return(real(slot_value(q_arg1(o).p)) > 0.0);} +static bool opt_b_p_s_is_integer(opt_info *o) {return(s7_is_integer(slot_value(q_arg1(o).p)));} /* not s7test tmap */ +static bool opt_b_p_s_is_pair(opt_info *o) {return(is_pair(slot_value(q_arg1(o).p)));} +static bool opt_b_p_f_is_string(opt_info *o) {return(s7_is_string(q_p_func1_call(o)));} +static bool opt_b_7p_s_iter_at_end(opt_info *o) {return(iterator_is_at_end(slot_value(q_arg1(o).p)));} +static bool opt_b_7p_f_not(opt_info *o) {return((q_p_func1_call(o)) == o->sc->F);} + +static bool opt_zero_mod(opt_info *o) +{ + s7_int x = integer(slot_value(q_arg1(o).p)); + return((x % q_arg2(o).i) == 0); +} + +static bool just_ints(s7_scheme *sc, s7_pointer form) +{ + if (is_pair(form)) + return((just_ints(sc, car(form))) && + (just_ints(sc, cdr(form)))); + return((!is_number(form)) || (is_t_integer(form))); +} + +static bool just_floats(s7_scheme *sc, s7_pointer form) +{ + if (is_pair(form)) + return((just_floats(sc, car(form))) && + (just_floats(sc, cdr(form)))); + return((!is_number(form)) || (is_t_real(form))); +} + +static bool b_idp_ok(s7_scheme *sc, const s7_pointer s_func, const s7_pointer form, const s7_pointer arg_type) +{ + opt_info *opc = alloc_opt_info(sc); + const int32_t cur_index = sc->pc; + s7_pointer expr = car(form); + + if (((arg_type == sc->is_integer_symbol) || (arg_type == sc->is_byte_symbol)) && + (just_ints(sc, form))) + { + const s7_b_i_t bif = s7_b_i_function(s_func); + if (bif) + { + q_func(opc).b_i_f = bif; + if (is_symbol(cadr(expr))) + { + q_arg1(opc).p = s7_t_slot(sc, cadr(expr)); + q_call(opc).fb = opt_b_i_s; + return_true(sc, expr); + } + q_func1_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(expr))) + { + opt_info *o1 = sc->opts[sc->pc - 1]; + if ((car(expr) == sc->is_zero_symbol) && + (q_call(o1).fi == opt_i_ii_sc) && + (q_func(o1).i_ii_f == modulo_i_ii_unchecked)) + { + q_call(opc).fb = opt_zero_mod; + q_arg1(opc).p = q_arg1(o1).p; + q_arg2(opc).i = q_arg2(o1).i; + backup_pc(sc); + return_true(sc, expr); + } + q_call(opc).fb = opt_b_i_f; + q_func1(opc).fi = q_func1_arg(opc).q_call(o1).fi; + return_true(sc, expr); + }}} + else + if ((arg_type == sc->is_float_symbol) && + (just_floats(sc, form))) + { + const s7_b_d_t bdf = s7_b_d_function(s_func); + if (bdf) + { + q_func(opc).b_d_f = bdf; + if (is_symbol(cadr(expr))) + { + q_arg1(opc).p = s7_t_slot(sc, cadr(expr)); + q_call(opc).fb = (bdf == positive_d) ? opt_b_d_s_is_positive : opt_b_d_s; + return_true(sc, expr); + } + q_func1_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdr(expr))) + { + q_call(opc).fb = opt_b_d_f; + q_func1(opc).fd = q_func1_arg(opc).q_call(o1).fd; + return_true(sc, expr); + }}} + sc->pc = cur_index; + { + s7_b_p_t bpf = s7_b_p_function(s_func); + s7_b_7p_t bpf7 = NULL; + if (!bpf) bpf7 = s7_b_7p_function(s_func); + if ((bpf) || (bpf7)) + { + if (bpf) + q_func(opc).b_p_f = bpf; + else q_func(opc).b_7p_f = bpf7; + if (is_symbol(cadr(expr))) + { + const s7_pointer slot = opt_simple_symbol(sc, cadr(expr)); + if (!slot) return_false(sc, expr); + q_arg1(opc).p = slot; + q_call(opc).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(slot)))) ? opt_b_7p_s_iter_at_end : + ((bpf7 == not_b_7p) ? opt_b_7p_s_not : opt_b_7p_s)); + return_true(sc, expr); + } + q_func1_arg(opc).o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdr(expr))) + { + q_call(opc).fb = (bpf) ? ((bpf == s7_is_string) ? opt_b_p_f_is_string : opt_b_p_f) : (bpf7 == not_b_7p) ? opt_b_7p_f_not : opt_b_7p_f; + q_func1(opc).fp = q_func1_arg(opc).q_call(o1).fp; + return_true(sc, expr); + }}} + return_false(sc, expr); +} + +/* -------- b_pp -------- */ +static s7_pointer opt_arg_type(s7_scheme *sc, s7_pointer argp) +{ + const s7_pointer arg = car(argp); + if (is_pair(arg)) + { + if (is_symbol(car(arg))) + { + if ((is_slot(global_slot(car(arg)))) && + ((is_global(car(arg))) || + (s7_t_slot(sc, car(arg)) == global_slot(car(arg))))) + { + const s7_pointer a_func = global_value(car(arg)); + if (is_c_function(a_func)) + { + const 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))))) /* multidim vector for example with too few indices */ + 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_complex_symbol) || + ((is_pair(car(sig))) && (direct_memq(sc->is_complex_symbol, car(sig))))) + return(sc->is_complex_symbol); + if ((car(sig) == sc->is_byte_symbol) || + ((is_pair(car(sig))) && (direct_memq(sc->is_byte_symbol, car(sig))))) + return(sc->is_integer_symbol); /* or '(integer? byte)? */ + if ((car(sig) == sc->is_real_symbol) || + (car(sig) == sc->is_number_symbol)) + { + const int32_t start = sc->pc; + if (int_optimize(sc, argp)) + { + sc->pc = start; + return(sc->is_integer_symbol); + } + if (float_optimize(sc, argp)) + { + sc->pc = start; + return(sc->is_float_symbol); + } + sc->pc = start; + } + if (((car(arg) == sc->vector_ref_symbol) || (car(arg) == sc->hash_table_ref_symbol)) && + (is_pair(cdr(arg))) && (is_normal_symbol(cadr(arg)))) /* (vector-ref) -> is_pair check */ + { + const s7_pointer v_slot = s7_slot(sc, cadr(arg)); /* (vector-ref not-a-var ...) -> is_slot check, not # */ + if (is_slot(v_slot)) + { + const s7_pointer vec = slot_value(v_slot); + if (car(arg) == sc->vector_ref_symbol) + { + if (is_int_vector(vec)) return(sc->is_integer_symbol); + if (is_float_vector(vec)) return(sc->is_float_symbol); + if (is_complex_vector(vec)) return(sc->is_complex_symbol); + if (is_byte_vector(vec)) return(sc->is_byte_symbol); + if (is_typed_t_vector(vec)) return(typed_vector_typer_symbol(sc, vec)); /* includes closure name ?? */ + } + else + if ((is_hash_table(vec)) && (is_typed_hash_table(vec)) && (is_c_function(hash_table_value_typer(vec)))) + return(c_function_symbol(hash_table_value_typer(vec))); + }} + return(car(sig)); /* we want the function's return type in this context */ + } + return(sc->T); + } + if ((is_quote(sc, car(arg))) && (is_pair(cdr(arg)))) + return(s7_type_of(sc, cadr(arg))); + } + { + s7_pointer arg_slot = s7_slot(sc, car(arg)); + if ((is_slot(arg_slot)) && + (is_sequence(slot_value(arg_slot)))) + { + s7_pointer sig = s7_signature(sc, slot_value(arg_slot)); + if (is_pair(sig)) + return(car(sig)); + }}} + else + if ((car(arg) == sc->quote_function) && (is_pair(cdr(arg)))) + return(s7_type_of(sc, cadr(arg))); + else + if (is_c_function(car(arg))) + { + const s7_pointer sig = c_function_signature(car(arg)); + if (is_pair(sig)) + return(car(sig)); + } + return(sc->T); + } + if (is_symbol(arg)) + { + s7_pointer arg_slot = opt_simple_symbol(sc, arg); + if (!arg_slot) return(sc->T); + return(s7_type_of(sc, slot_value(arg_slot))); + } + return(s7_type_of(sc, arg)); +} + +static bool opt_b_pp_sf(opt_info *o) {return(q_func(o).b_pp_f(slot_value(q_arg1(o).p), q_p_func2_call(o)));} +static bool opt_b_pp_fs(opt_info *o) {return(q_func(o).b_pp_f(q_p_func2_call(o), slot_value(q_arg2(o).p)));} +static bool opt_b_pp_ss(opt_info *o) {return(q_func(o).b_pp_f(slot_value(q_arg1(o).p), slot_value(q_arg2(o).p)));} +static bool opt_b_pp_sc(opt_info *o) {return(q_func(o).b_pp_f(slot_value(q_arg1(o).p), q_arg2(o).p));} +static bool opt_b_pp_sfo(opt_info *o) {return(q_func(o).b_pp_f(slot_value(q_arg1(o).p), q_func1(o).p_p_f(o->sc, slot_value(q_arg2(o).p))));} +static bool opt_b_7pp_sf(opt_info *o) {return(q_func(o).b_7pp_f(o->sc, slot_value(q_arg1(o).p), q_p_func2_call(o)));} +static bool opt_b_7pp_fs(opt_info *o) {return(q_func(o).b_7pp_f(o->sc, q_p_func2_call(o), slot_value(q_arg2(o).p)));} +static bool opt_b_7pp_ss(opt_info *o) {return(q_func(o).b_7pp_f(o->sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p)));} +static bool opt_b_7pp_ss_lt(opt_info *o) {return(lt_b_7pp(o->sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p)));} +static bool opt_b_7pp_ss_gt(opt_info *o) {return(gt_b_7pp(o->sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p)));} +static bool opt_b_7pp_ss_char_lt(opt_info *o) {return(char_lt_b_7pp(o->sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p)));} +static bool opt_b_7pp_sc(opt_info *o) {return(q_func(o).b_7pp_f(o->sc, slot_value(q_arg1(o).p), q_arg2(o).p));} +static bool opt_b_7pp_sfo(opt_info *o) {return(q_func(o).b_7pp_f(o->sc, slot_value(q_arg1(o).p), q_func1(o).p_p_f(o->sc, slot_value(q_arg2(o).p))));} +static bool opt_is_equal_sfo(opt_info *o) {return(s7_is_equal(o->sc, slot_value(q_arg1(o).p), q_func1(o).p_p_f(o->sc, slot_value(q_arg2(o).p))));} +static bool opt_is_equivalent_sfo(opt_info *o) {return(is_equivalent_1(o->sc, slot_value(q_arg1(o).p), q_func1(o).p_p_f(o->sc, slot_value(q_arg2(o).p)), NULL));} +static bool opt_b_pp_sf_char_eq(opt_info *o) {return(slot_value(q_arg1(o).p) == q_p_func2_call(o));} /* lt above checks for char args */ +static bool opt_b_7pp_ff(opt_info *o) {s7_pointer p = q_p_func3_call(o); return(q_func(o).b_7pp_f(o->sc, p, q_p_func2_call(o)));} +static bool opt_b_pp_ff(opt_info *o) {s7_pointer p = q_p_func3_call(o); return(q_func(o).b_pp_f(p, q_p_func2_call(o)));} +static bool opt_b_pp_ff_char_eq(opt_info *o) {return(q_p_func3_call(o) == q_p_func2_call(o));} +static bool opt_b_pp_fc_char_eq(opt_info *o) {return(q_p_func3_call(o) == q_arg1(o).p);} +static bool opt_b_pp_fc(opt_info *o) {return(q_func(o).b_pp_f(q_p_func3_call(o), q_arg1(o).p));} +static bool opt_b_7pp_fc(opt_info *o) {return(q_func(o).b_7pp_f(o->sc, q_p_func3_call(o), q_arg1(o).p));} + +static bool opt_car_equal_sf(opt_info *o) +{ + s7_pointer p = slot_value(q_arg2(o).p); + return(s7_is_equal(o->sc, slot_value(q_arg1(o).p), (is_pair(p)) ? car(p) : g_car(o->sc, set_plist_1(o->sc, p)))); +} + +static bool opt_car_equivalent_sf(opt_info *o) +{ + s7_pointer p = slot_value(q_arg2(o).p); + return(is_equivalent_1(o->sc, slot_value(q_arg1(o).p), (is_pair(p)) ? car(p) : g_car(o->sc, set_plist_1(o->sc, p)), NULL)); +} + +static bool opt_b_7pp_car_sf(opt_info *o) +{ + s7_pointer p = slot_value(q_arg2(o).p); + return(q_func(o).b_7pp_f(o->sc, slot_value(q_arg1(o).p), (is_pair(p)) ? car(p) : g_car(o->sc, set_plist_1(o->sc, 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(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), q_i_func1_call(o))); +} + +static bool opt_substring_equal_sf(opt_info *o) {return(scheme_strings_are_equal(slot_value(q_arg1(o).p), opt_p_substring_uncopied_ssf(q_func2_arg(o).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 (q_call(o1).fp == opt_p_p_s) + { + q_arg2(opc).p = q_arg1(o1).p; + q_func1(opc).p_p_f = q_func1(o1).p_p_f; + if (bpf_case) + q_call(opc).fb = opt_b_pp_sfo; + else + if (q_func1(opc).p_p_f == car_p_p) + q_call(opc).fb = ((q_func(opc).b_7pp_f == s7_is_equal) ? opt_car_equal_sf : + ((q_func(opc).b_7pp_f == s7_is_equivalent) ? opt_car_equivalent_sf : opt_b_7pp_car_sf)); + else q_call(opc).fb = ((q_func(opc).b_7pp_f == s7_is_equal) ? opt_is_equal_sfo : + ((q_func(opc).b_7pp_f == s7_is_equivalent) ? opt_is_equivalent_sfo : opt_b_7pp_sfo)); + backup_pc(sc); + return_true(sc, NULL); + }} + return_false(sc, NULL); +} + +static bool opt_b_pp_ffo(opt_info *o) +{ + s7_pointer b1 = q_func1(o).p_p_f(o->sc, slot_value(q_arg1(o).p)); + return(q_func(o).b_pp_f(b1, q_func2(o).p_p_f(o->sc, slot_value(q_arg2(o).p)))); +} + +static bool opt_b_pp_ffo_is_eq(opt_info *o) +{ + s7_pointer b1 = q_func1(o).p_p_f(o->sc, slot_value(q_arg1(o).p)); + s7_pointer b2 = q_func2(o).p_p_f(o->sc, slot_value(q_arg2(o).p)); + return((b1 == b2) || ((is_unspecified(b1)) && (is_unspecified(b2)))); +} + +static bool opt_b_7pp_ffo(opt_info *o) +{ + s7_pointer b1 = q_func1(o).p_p_f(o->sc, slot_value(q_arg1(o).p)); + return(q_func(o).b_7pp_f(o->sc, b1, q_func2(o).p_p_f(o->sc, slot_value(q_arg2(o).p)))); +} + +static bool opt_b_cadr_cadr(opt_info *o) +{ + s7_pointer p1 = slot_value(q_arg1(o).p); + s7_pointer p2 = slot_value(q_arg2(o).p); + p1 = ((is_pair(p1)) && (is_pair(cdr(p1)))) ? cadr(p1) : g_cadr(o->sc, set_plist_1(o->sc, p1)); + p2 = ((is_pair(p2)) && (is_pair(cdr(p2)))) ? cadr(p2) : g_cadr(o->sc, set_plist_1(o->sc, p2)); + return(q_func(o).b_7pp_f(o->sc, 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 ((q_call(o1).fp == opt_p_p_s) && (q_call(o2).fp == opt_p_p_s)) + { + q_arg1(opc).p = q_arg1(o1).p; + q_func1(opc).p_p_f = q_func1(o1).p_p_f; + q_arg2(opc).p = q_arg1(o2).p; + q_func2(opc).p_p_f = q_func1(o2).p_p_f; + q_call(opc).fb = (bpf_case) ? ((q_func(opc).b_pp_f == s7_is_eq) ? opt_b_pp_ffo_is_eq : opt_b_pp_ffo) : + (((q_func2(opc).p_p_f == cadr_p_p) && (q_func1(opc).p_p_f == cadr_p_p)) ? opt_b_cadr_cadr : opt_b_7pp_ffo); + sc->pc -= 2; + return_true(sc, NULL); + }} + return_false(sc, NULL); +} + +static void check_b_types(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr, bool (*fb)(opt_info *o)) +{ + if (s7_b_pp_unchecked_function(s_func)) + { + s7_pointer call_sig = c_function_signature(s_func); + s7_pointer arg1_type = opt_arg_type(sc, cdr(expr)); + s7_pointer arg2_type = opt_arg_type(sc, cddr(expr)); + if ((cadr(call_sig) == arg1_type) && /* not car(arg1_type) here: (string>? (string) (read-line)) */ + (caddr(call_sig) == arg2_type)) + { + q_call(opc).fb = fb; + q_func(opc).b_pp_f = s7_b_pp_unchecked_function(s_func); + }} +} + +static s7_pointer opt_p_c(opt_info *o); + +static bool b_pp_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr, s7_pointer arg1, s7_pointer arg2, bool bpf_case) +{ + const int32_t cur_index = sc->pc; + opt_info *o1; + /* v[3] is set when we get here */ + if ((is_symbol(arg1)) && + (is_symbol(arg2))) + { + q_arg1(opc).p = opt_simple_symbol(sc, arg1); + q_arg2(opc).p = opt_simple_symbol(sc, arg2); + if ((q_arg1(opc).p) && (q_arg2(opc).p)) + { + const s7_b_7pp_t b7f = (bpf_case) ? NULL : q_func(opc).b_7pp_f; + q_call(opc).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(sc, expr); + }} + if (is_symbol(arg1)) + { + q_arg1(opc).p = opt_simple_symbol(sc, arg1); + if (!q_arg1(opc).p) + return_false(sc, expr); + if ((!is_symbol(arg2)) && (!is_pair(arg2))) + { + q_arg2(opc).p = arg2; + q_call(opc).fb = (bpf_case) ? opt_b_pp_sc : opt_b_7pp_sc; + check_b_types(sc, opc, s_func, expr, opt_b_pp_sc); + return_true(sc, expr); + } + if (cell_optimize(sc, cddr(expr))) + { + if (!b_pp_sf_combinable(sc, opc, bpf_case)) + { + q_func2_arg(opc).o1 = sc->opts[cur_index]; + q_func2(opc).fp = q_func2_arg(opc).q_call(o1).fp; + q_call(opc).fb = (bpf_case) ? opt_b_pp_sf : opt_b_7pp_sf; + check_b_types(sc, opc, s_func, expr, opt_b_pp_sf); /* this finds b_pp_unchecked cases */ + if ((q_func2(opc).fp == opt_p_substring_uncopied_ssf) && (q_func(opc).b_pp_f == string_eq_b_unchecked)) + q_call(opc).fb = opt_substring_equal_sf; /*concordance.scm */ + else if (q_func(opc).b_pp_f == char_eq_b_unchecked) q_call(opc).fb = opt_b_pp_sf_char_eq; + } + return_true(sc, expr); + } + sc->pc = cur_index; + } + else + if ((is_symbol(arg2)) && + (is_pair(arg1))) + { + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdr(expr))) + { + q_arg2(opc).p = s7_slot(sc, arg2); /* can be # */ + if ((!is_slot(q_arg2(opc).p)) || + (has_methods(slot_value(q_arg2(opc).p)))) + return_false(sc, expr); + q_func2(opc).fp = q_func2_arg(opc).q_call(o1).fp; + q_call(opc).fb = (bpf_case) ? opt_b_pp_fs : opt_b_7pp_fs; + check_b_types(sc, opc, s_func, expr, opt_b_pp_fs); + return_true(sc, expr); + } + sc->pc = cur_index; + } + o1 = sc->opts[sc->pc]; /* used below opc->[8].o1 etc */ + if (cell_optimize(sc, cdr(expr))) + { + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(expr))) + { + if (b_pp_ff_combinable(sc, opc, bpf_case)) + return_true(sc, expr); + q_call(opc).fb = (bpf_case) ? opt_b_pp_ff : opt_b_7pp_ff; + q_func3_arg(opc).o1 = o1; + q_func3(opc).fp = q_call(o1).fp; + q_func2(opc).fp = q_func2_arg(opc).q_call(o1).fp; + check_b_types(sc, opc, s_func, expr, opt_b_pp_ff); + if (q_func(opc).b_pp_f == char_eq_b_unchecked) + { + if (q_func2(opc).fp == opt_p_c) /* q_func2(opc).fp can be opt_p_c where q_func2_arg(opc).q_arg1(o1).p is the char */ + { + q_call(opc).fb = opt_b_pp_fc_char_eq; + q_arg1(opc).p = q_func2_arg(opc).q_arg1(o1).p; + } + else q_call(opc).fb = opt_b_pp_ff_char_eq; + } + else + if (q_func2(opc).fp == opt_p_c) + { + q_call(opc).fb = (q_call(opc).fb == opt_b_pp_ff) ? opt_b_pp_fc : opt_b_7pp_fc; /* can't use bpf_case here -- check_b_types can use the other form */ + q_arg1(opc).p = q_func2_arg(opc).q_arg1(o1).p; + } + return_true(sc, expr); + }} + return_false(sc, expr); +} + +/* -------- b_pi -------- */ + +static bool opt_b_pi_fs(opt_info *o) {return(q_func4(o).b_pi_f(o->sc, q_p_func2_call(o), integer(slot_value(q_arg1(o).p))));} +static bool opt_b_pi_fs_num_eq(opt_info *o) {return(num_eq_b_pi(o->sc, q_p_func2_call(o), integer(slot_value(q_arg1(o).p))));} +static bool opt_b_pi_fc(opt_info *o) {return(q_func4(o).b_pi_f(o->sc, q_p_func2_call(o), q_arg1(o).i));} +static bool opt_b_pi_ff(opt_info *o) {s7_pointer p = q_p_func2_call(o); return(q_func4(o).b_pi_f(o->sc, p, q_i_func3_call(o)));} + +static bool b_pi_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr, s7_pointer arg2) +{ + const s7_b_pi_t bpif = s7_b_pi_function(s_func); /* perhaps add vector-ref/equal? */ + if (bpif) + { + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdr(expr))) + { + opt_info *o1 = sc->opts[sc->pc]; + q_func4(opc).b_pi_f = bpif; + q_func2(opc).fp = q_func2_arg(opc).q_call(o1).fp; + if (is_symbol(arg2)) + { + q_arg1(opc).p = s7_t_slot(sc, arg2); /* slot checked in opt_arg_type */ + q_call(opc).fb = (bpif == num_eq_b_pi) ? opt_b_pi_fs_num_eq : opt_b_pi_fs; + return_true(sc, expr); + } + if (is_t_integer(arg2)) + { + q_arg1(opc).i = integer(arg2); + q_call(opc).fb = opt_b_pi_fc; + return_true(sc, expr); + } + if (int_optimize(sc, cddr(expr))) + { + q_call(opc).fb = opt_b_pi_ff; + q_func3_arg(opc).o1 = o1; + q_func3(opc).fp = q_call(o1).fp; + return_true(sc, expr); + }}} + return_false(sc, expr); +} + +/* -------- b_dd -------- */ +static bool opt_b_dd_ss(opt_info *o) {return(q_func(o).b_dd_f(real(slot_value(q_arg1(o).p)), real(slot_value(q_arg2(o).p))));} +static bool opt_b_dd_ss_lt(opt_info *o) {return(real(slot_value(q_arg1(o).p)) < real(slot_value(q_arg2(o).p)));} +static bool opt_b_dd_ss_gt(opt_info *o) {return(real(slot_value(q_arg1(o).p)) > real(slot_value(q_arg2(o).p)));} + +static bool opt_b_dd_sc(opt_info *o) {return(q_func(o).b_dd_f(real(slot_value(q_arg1(o).p)), q_arg2(o).x));} +static bool opt_b_dd_sc_lt(opt_info *o) {return(real(slot_value(q_arg1(o).p)) < q_arg2(o).x);} +static bool opt_b_dd_sc_geq(opt_info *o) {return(real(slot_value(q_arg1(o).p)) >= q_arg2(o).x);} +static bool opt_b_dd_sc_eq(opt_info *o) {return(real(slot_value(q_arg1(o).p)) == q_arg2(o).x);} + +static bool opt_b_dd_sf(opt_info *o) {return(q_func(o).b_dd_f(real(slot_value(q_arg1(o).p)), q_d_func2_call(o)));} +static bool opt_b_dd_fs(opt_info *o) {return(q_func(o).b_dd_f(q_d_func2_call(o), real(slot_value(q_arg2(o).p))));} +static bool opt_b_dd_fs_gt(opt_info *o) {return(q_d_func2_call(o) > real(slot_value(q_arg2(o).p)));} +static bool opt_b_dd_fc(opt_info *o) {return(q_func(o).b_dd_f(q_d_func2_call(o), q_arg2(o).x));} +static bool opt_b_dd_fc_gt(opt_info *o) {return(q_d_func2_call(o) > q_arg2(o).x);} + +static bool opt_b_dd_ff(opt_info *o) +{ + s7_double x1 = q_d_func2_call(o); + s7_double x2 = q_d_func3_call(o); + return(q_func(o).b_dd_f(x1, x2)); +} + +static bool b_dd_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr, s7_pointer arg1, s7_pointer arg2) +{ + const s7_b_dd_t bif = s7_b_dd_function(s_func); + const int32_t cur_index = sc->pc; + if (!bif) return_false(sc, expr); + q_func(opc).b_dd_f = bif; + if (is_symbol(arg1)) + { + q_arg1(opc).p = s7_t_slot(sc, arg1); + if (is_symbol(arg2)) + { + q_arg2(opc).p = s7_t_slot(sc, arg2); + q_call(opc).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(sc, expr); + } + if (is_t_real(arg2)) + { + q_arg2(opc).x = s7_number_to_real(sc, arg2); + q_call(opc).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(sc, expr); + } + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(expr))) + { + q_func2(opc).fd = q_func2_arg(opc).q_call(o1).fd; + q_call(opc).fb = opt_b_dd_sf; + return_true(sc, expr); + }} + sc->pc = cur_index; + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdr(expr))) + { + q_func2(opc).fd = q_func2_arg(opc).q_call(o1).fd; + if (is_symbol(arg2)) + { + q_arg2(opc).p = s7_t_slot(sc, arg2); + q_call(opc).fb = (bif == gt_b_dd) ? opt_b_dd_fs_gt : opt_b_dd_fs; + return_true(sc, expr); + } + if (is_small_real(arg2)) + { + q_arg2(opc).x = s7_number_to_real(sc, arg2); + q_call(opc).fb = (bif == gt_b_dd) ? opt_b_dd_fc_gt : opt_b_dd_fc; + return_true(sc, expr); + } + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(expr))) + { + q_func3(opc).fd = q_func3_arg(opc).q_call(o1).fd; + q_call(opc).fb = opt_b_dd_ff; + return_true(sc, expr); + }} + sc->pc = cur_index; + return_false(sc, expr); +} + +/* -------- b_ii -------- */ +static bool opt_b_ii_ss(opt_info *o) {return(q_func(o).b_ii_f(integer(slot_value(q_arg1(o).p)), integer(slot_value(q_arg2(o).p))));} +static bool opt_b_ii_ss_lt(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) < integer(slot_value(q_arg2(o).p)));} +static bool opt_b_ii_ss_gt(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) > integer(slot_value(q_arg2(o).p)));} +static bool opt_b_ii_ss_leq(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) <= integer(slot_value(q_arg2(o).p)));} +static bool opt_b_ii_ss_geq(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) >= integer(slot_value(q_arg2(o).p)));} +static bool opt_b_ii_ss_eq(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) == integer(slot_value(q_arg2(o).p)));} +static bool opt_b_ii_sc(opt_info *o) {return(q_func(o).b_ii_f(integer(slot_value(q_arg1(o).p)), q_arg2(o).i));} +static bool opt_b_ii_sc_lt(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) < q_arg2(o).i);} +static bool opt_b_ii_sc_leq(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) <= q_arg2(o).i);} +static bool opt_b_ii_sc_gt(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) > q_arg2(o).i);} +static bool opt_b_ii_sc_geq(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) >= q_arg2(o).i);} +static bool opt_b_ii_sc_eq(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) == q_arg2(o).i);} +static bool opt_b_ii_sc_lt_2(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) < 2);} +static bool opt_b_ii_sc_lt_1(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) < 1);} +static bool opt_b_ii_sc_lt_0(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) < 0);} +static bool opt_b_ii_sc_leq_0(opt_info *o){return(integer(slot_value(q_arg1(o).p)) <= 0);} +static bool opt_b_ii_sc_gt_0(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) > 0);} +static bool opt_b_ii_sc_geq_0(opt_info *o){return(integer(slot_value(q_arg1(o).p)) >= 0);} +static bool opt_b_ii_sc_eq_0(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) == 0);} +static bool opt_b_ii_sc_eq_1(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) == 1);} + +static bool opt_b_7ii_ss(opt_info *o) {return(q_func(o).b_7ii_f(o->sc, integer(slot_value(q_arg1(o).p)), integer(slot_value(q_arg2(o).p))));} +static bool opt_b_7ii_sc(opt_info *o) {return(q_func(o).b_7ii_f(o->sc, integer(slot_value(q_arg1(o).p)), q_arg2(o).i));} +static bool opt_b_7ii_sc_bit(opt_info *o) {return((integer(slot_value(q_arg1(o).p)) & ((s7_int)(1LL << q_arg2(o).i))) != 0);} + +static bool opt_b_ii_ff(opt_info *o) +{ + s7_int i1 = q_i_func2_call(o); + s7_int i2 = q_i_func3_call(o); + return(q_func(o).b_ii_f(i1, i2)); +} + +static bool opt_b_ii_fs(opt_info *o) {return(q_func(o).b_ii_f(q_i_func2_call(o), integer(slot_value(q_arg2(o).p))));} +static bool opt_b_ii_sf(opt_info *o) {return(q_func(o).b_ii_f(integer(slot_value(q_arg1(o).p)), q_i_func2_call(o)));} +static bool opt_b_ii_sf_eq(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) == q_i_func2_call(o));} +static bool opt_b_ii_fc(opt_info *o) {return(q_func(o).b_ii_f(q_i_func2_call(o), q_arg2(o).i));} +static bool opt_b_ii_fc_eq(opt_info *o) {return(q_i_func2_call(o) == q_arg2(o).i);} + +static bool b_ii_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr, s7_pointer arg1, s7_pointer arg2) +{ + const s7_b_ii_t bif = s7_b_ii_function(s_func); + s7_b_7ii_t b7if = NULL; + if (!bif) + { + b7if = s7_b_7ii_function(s_func); + if (!b7if) return_false(sc, expr); + } + if (bif) q_func(opc).b_ii_f = bif; else q_func(opc).b_7ii_f = b7if; + if (is_symbol(arg1)) + { + q_arg1(opc).p = s7_t_slot(sc, arg1); + if (is_symbol(arg2)) + { + q_arg2(opc).p = s7_t_slot(sc, arg2); + q_call(opc).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(sc, expr); + } + if (is_t_integer(arg2)) + { + const s7_int i2 = integer(arg2); + q_arg2(opc).i = i2; + q_call(opc).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(sc, expr); + } + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if ((bif) && (int_optimize(sc, cddr(expr)))) + { + q_call(opc).fb = (bif == num_eq_b_ii) ? opt_b_ii_sf_eq : opt_b_ii_sf; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + return_true(sc, expr); + } + return_false(sc, expr); + } + if (!bif) return_false(sc, expr); + + if (is_symbol(arg2)) + { + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (!int_optimize(sc, cdr(expr))) + return_false(sc, expr); + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_arg2(opc).p = s7_t_slot(sc, arg2); + q_call(opc).fb = opt_b_ii_fs; + return_true(sc, expr); + } + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(expr))) + { + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + if (is_t_integer(arg2)) + { + q_arg2(opc).i = integer(arg2); + q_call(opc).fb = (bif == num_eq_b_ii) ? opt_b_ii_fc_eq : opt_b_ii_fc; + return_true(sc, expr); + } + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + q_func3(opc).fi = q_func3_arg(opc).q_call(o1).fi; + q_call(opc).fb = opt_b_ii_ff; + return_true(sc, expr); + }} + return_false(sc, expr); +} + +/* -------- b_or|and -------- */ +static bool opt_and_bb(opt_info *o) {return((q_func(o).fb(q_arg1(o).o1)) && (q_b_func2_call(o)));} + +#define q_bool_call(o, i) o->v[i + 3] + +static bool opt_and_any_b(opt_info *o) +{ + for (s7_int i = 0; i < q_arg1(o).i; i++) + { + opt_info *o1 = q_bool_call(o, i).o1; + if (!q_call(o1).fb(o1)) + return(false); + } + return(true); +} + +static bool opt_or_bb(opt_info *o) {return((q_func(o).fb(q_arg1(o).o1)) || (q_b_func2_call(o)));} + +static bool opt_or_any_b(opt_info *o) +{ + for (s7_int i = 0; i < q_arg1(o).i; i++) + { + opt_info *o1 = q_bool_call(o, i).o1; + if (q_call(o1).fb(o1)) + return(true); + } + return(false); +} + +static bool opt_b_or_and(s7_scheme *sc, s7_pointer expr, int32_t len, int32_t is_and) +{ + opt_info *opc = alloc_opt_info(sc); + s7_pointer p = cdr(expr); + if (len == 3) + { + opt_info *o1 = sc->opts[sc->pc]; + if (bool_optimize_nw(sc, cdr(expr))) + { + opt_info *o2 = sc->opts[sc->pc]; + if (bool_optimize_nw(sc, cddr(expr))) + { + q_func2_arg(opc).o1 = o2; + q_func2(opc).fb = q_call(o2).fb; + q_call(opc).fb = (is_and) ? opt_and_bb : opt_or_bb; + q_arg1(opc).o1 = o1; + q_func(opc).fb = q_call(o1).fb; + return_true(sc, expr); + }} + return_false(sc, expr); + } + q_arg1(opc).i = (len - 1); + for (int32_t i = 0; (is_pair(p)) && (i < 12); i++, p = cdr(p)) + { + q_bool_call(opc, i).o1 = sc->opts[sc->pc]; + if (!bool_optimize_nw(sc, p)) + break; + } + if (!is_null(p)) + return_false(sc, expr); + q_call(opc).fb = (is_and) ? opt_and_any_b : opt_or_any_b; + return_true(sc, expr); +} + +static bool opt_b_and(s7_scheme *sc, s7_pointer expr, int32_t len) {return(opt_b_or_and(sc, expr, len, true));} +static bool opt_b_or(s7_scheme *sc, s7_pointer expr, int32_t len) {return(opt_b_or_and(sc, expr, len, false));} + +/* ---------------------------------------- cell opts ---------------------------------------- */ + +static s7_pointer opt_p_c(opt_info *o) {return(q_arg1(o).p);} +static s7_pointer opt_p_s(opt_info *o) {return(slot_value(q_arg1(o).p));} + +static bool opt_cell_not_pair(s7_scheme *sc, s7_pointer expr) +{ + s7_pointer slot; + opt_info *opc; + if (!is_symbol(expr)) + { + opc = alloc_opt_info(sc); + q_arg1(opc).p = expr; + q_call(opc).fp = opt_p_c; + return_true(sc, expr); + } + slot = opt_simple_symbol(sc, expr); + if (!slot) + return_false(sc, expr); + opc = alloc_opt_info(sc); + q_arg1(opc).p = slot; + q_call(opc).fp = opt_p_s; + return_true(sc, expr); +} + +/* -------- p -------- */ +#define is_opt_safe(P) ((optimize_op(P) >= OP_SAFE_C_S) && (!is_unknown_op(optimize_op(P)))) + +#define cf_call(Sc, expr, S_func, Num) \ + (((is_optimized(expr)) && (is_opt_safe(expr))) ? fn_proc(expr) : c_function_call(c_function_chooser(S_func)(Sc, S_func, Num, expr))) /* was ops=false 19-Mar-24 */ + +static s7_pointer opt_p_f(opt_info *o) {return(q_func(o).p_f(o->sc));} +static s7_pointer opt_p_call(opt_info *o) {return(q_func(o).call(o->sc, o->sc->nil));} + +static bool p_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) +{ + const s7_p_t func = s7_p_function(s_func); + if (func) + { + q_func(opc).p_f = func; + q_call(opc).fp = opt_p_f; + return_true(sc, expr); + } + if ((is_safe_procedure(s_func)) && + (c_function_min_args(s_func) == 0)) + { + q_func(opc).call = cf_call(sc, expr, s_func, 0); + q_call(opc).fp = opt_p_call; + return_true(sc, expr); + } + return_false(sc, expr); +} + +/* -------- p_p -------- */ +static s7_pointer opt_p_p_c(opt_info *o) {return(q_func1(o).p_p_f(o->sc, q_arg1(o).p));} +static s7_pointer opt_p_i_c(opt_info *o) {return(make_integer(o->sc, q_func(o).i_i_f(q_arg1(o).i)));} +static s7_pointer opt_p_7i_c(opt_info *o) {return(make_integer(o->sc, q_func(o).i_7i_f(o->sc, q_arg1(o).i)));} +static s7_pointer opt_p_d_c(opt_info *o) {return(make_real(o->sc, q_func(o).d_d_f(q_arg1(o).x)));} +static s7_pointer opt_p_7d_c(opt_info *o) {return(make_real(o->sc, q_func(o).d_7d_f(o->sc, q_arg1(o).x)));} +static s7_pointer opt_p_p_s(opt_info *o) {return(q_func1(o).p_p_f(o->sc, slot_value(q_arg1(o).p)));} +static s7_pointer opt_p_p_s_abs(opt_info *o) {return(abs_p_p(o->sc, slot_value(q_arg1(o).p)));} +static s7_pointer opt_p_p_s_random(opt_info *o) {return(random_p_p(o->sc, slot_value(q_arg1(o).p)));} +static s7_pointer opt_p_p_s_random_wrapped(opt_info *o) {return(random_p_p_wrapped(o->sc, slot_value(q_arg1(o).p)));} +static s7_pointer opt_p_p_s_cdr(opt_info *o) {s7_pointer p = slot_value(q_arg1(o).p); return((is_pair(p)) ? cdr(p) : cdr_p_p(o->sc, p));} +static s7_pointer opt_p_p_f(opt_info *o) {return(q_func1(o).p_p_f(o->sc, q_p_func2_call(o)));} +static s7_pointer opt_p_p_f1(opt_info *o) {return(q_func1(o).p_p_f(o->sc, q_func(o).p_p_f(o->sc, slot_value(q_arg1(o).p))));} +static s7_pointer opt_p_p_f_exp(opt_info *o) {return(exp_p_p(o->sc, q_p_func2_call(o)));} +static s7_pointer opt_p_7d_c_random(opt_info *o) {return(make_real(o->sc, random_d_7d(o->sc, q_arg1(o).x)));} +static s7_pointer opt_p_p_s_iterate(opt_info *o) {return(iterate_p_p(o->sc, slot_value(q_arg1(o).p)));} +static s7_pointer opt_p_p_f_iterate(opt_info *o) {return(iterate_p_p(o->sc, q_p_func2_call(o)));} +static s7_pointer opt_p_z_f_magnitude(opt_info *o) {return(magnitude_p_z(o->sc, q_p_func2_call(o)));} +static s7_pointer opt_p_p_f_string_to_number(opt_info *o) {return(string_to_number_p_p(o->sc, q_p_func2_call(o)));} +static s7_pointer opt_p_p_s_iterate_unchecked(opt_info *o) {s7_pointer iter = slot_value(q_arg1(o).p); return(iterator_next(iter)(o->sc, iter));} +/* string_iterate built-in here if iterator_sequence is a string is about 12% faster, but currently we can have an unchecked iterator + * that changes sequence type (via (set! L1 L2) where L1 and L2 are both iterators) + */ + +static s7_pointer opt_p_pi_ss(opt_info *o); +static s7_pointer opt_p_pi_sf(opt_info *o); +static s7_pointer opt_p_pi_ss_vref_direct(opt_info *o); +static s7_pointer opt_p_pi_ss_fvref_direct(opt_info *o); +static s7_pointer opt_p_pi_ss_ivref_direct(opt_info *o); +static s7_pointer opt_p_pi_ss_fvref_direct_wrapped(opt_info *o); +static s7_pointer opt_p_pi_ss_ivref_direct_wrapped(opt_info *o); + +static s7_pointer opt_p_p_fvref(opt_info *o) {return(q_func1(o).p_p_f(o->sc, opt_p_pi_ss_fvref_direct_wrapped(q_func2_arg(o).o1)));} /* unwrap to fvref is not faster */ +static s7_pointer opt_p_p_ivref(opt_info *o) {return(q_func1(o).p_p_f(o->sc, opt_p_pi_ss_ivref_direct_wrapped(q_func2_arg(o).o1)));} /* unwrap to ivref is not faster */ +static s7_pointer opt_p_p_vref(opt_info *o) {return(q_func1(o).p_p_f(o->sc, opt_p_pi_ss_vref_direct(q_func2_arg(o).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 (q_call(o1).fp == opt_p_p_s) + { + q_func(opc).p_p_f = q_func1(o1).p_p_f; + q_arg1(opc).p = q_arg1(o1).p; + q_call(opc).fp = opt_p_p_f1; + backup_pc(sc); + return_true(sc, NULL); + }} + return_false(sc, NULL); +} + +static s7_pointer opt_p_call_f(opt_info *o) {return(q_func(o).call(o->sc, set_plist_1(o->sc, q_p_func1_call(o))));} +static s7_pointer opt_p_call_s(opt_info *o) {return(q_func(o).call(o->sc, set_plist_1(o->sc, slot_value(q_arg1(o).p))));} +static s7_pointer opt_p_call_c(opt_info *o) {return(q_func(o).call(o->sc, set_plist_1(o->sc, q_arg1(o).p)));} + +static bool p_p_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) +{ + s7_p_p_t ppf; + const int32_t start = sc->pc; + const s7_pointer arg1 = cadr(expr); + if (is_t_integer(arg1)) + { + const s7_i_i_t iif = s7_i_i_function(s_func); + s7_i_7i_t i7if; + q_arg1(opc).i = integer(arg1); + if (iif) + { + q_func(opc).i_i_f = iif; + q_call(opc).fp = opt_p_i_c; + return_true(sc, expr); + } + i7if = s7_i_7i_function(s_func); + if (i7if) + { + q_func(opc).i_7i_f = i7if; + q_call(opc).fp = opt_p_7i_c; + return_true(sc, expr); + }} + if (is_t_real(arg1)) + { + const s7_d_d_t ddf = s7_d_d_function(s_func); + s7_d_7d_t d7df; + q_arg1(opc).x = real(arg1); + if (ddf) + { + q_func(opc).d_d_f = ddf; + q_call(opc).fp = opt_p_d_c; + return_true(sc, expr); + } + d7df = s7_d_7d_function(s_func); + if (d7df) + { + q_func(opc).d_7d_f = d7df; + q_call(opc).fp = (d7df == random_d_7d) ? opt_p_7d_c_random : opt_p_7d_c; + return_true(sc, expr); + }} + ppf = s7_p_p_function(s_func); + if (ppf) + { + opt_info *o1; + q_func1(opc).p_p_f = ppf; /* TODO: func! */ + if ((ppf == symbol_to_string_p_p) && + (is_optimized(expr)) && + (fn_proc(expr) == g_symbol_to_string_uncopied)) + q_func1(opc).p_p_f = symbol_to_string_uncopied_p; + + if (is_symbol(arg1)) + { + q_arg1(opc).p = opt_simple_symbol(sc, arg1); + if (!q_arg1(opc).p) + return_false(sc, expr); + q_call(opc).fp = (ppf == abs_p_p) ? opt_p_p_s_abs : ((ppf == cdr_p_p) ? opt_p_p_s_cdr : + ((ppf == iterate_p_p) ? ((is_iterator(slot_value(q_arg1(opc).p))) ? opt_p_p_s_iterate_unchecked : opt_p_p_s_iterate) : + ((ppf == random_p_p) ? opt_p_p_s_random : opt_p_p_s))); + return_true(sc, expr); + } + if (!is_pair(arg1)) + { + if (q_func1(opc).p_p_f == s7_length) + { + q_arg1(opc).p = s7_length(sc, arg1); + q_call(opc).fp = opt_p_c; + } + else + { + q_arg1(opc).p = arg1; + q_call(opc).fp = opt_p_p_c; /* see p_pip_ssf_combinable */ + } + return_true(sc, expr); + } + o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdr(expr))) + { + if (!p_p_f_combinable(sc, opc)) + { + s7_pointer (*fp)(opt_info *o); + if ((ppf == magnitude_p_p) && + ((q_call(o1).fp == opt_p_pi_ss) || (q_call(o1).fp == opt_p_pi_sf)) && + (q_func(o1).p_pi_f == complex_vector_ref_p_pi)) + { + q_func(o1).p_pi_f = complex_vector_ref_p_pi_wrapped; + q_call(opc).fp = opt_p_z_f_magnitude; + } + else + q_call(opc).fp = (ppf == exp_p_p) ? opt_p_p_f_exp : ((ppf == iterate_p_p) ? opt_p_p_f_iterate : + ((ppf == string_to_number_p_p) ? opt_p_p_f_string_to_number : opt_p_p_f)); + q_func2_arg(opc).o1 = o1; + fp = q_call(o1).fp; + q_func2(opc).fp = fp; + if (fp == opt_p_pi_ss_fvref_direct) q_call(opc).fp = opt_p_p_fvref; + else if (fp == opt_p_pi_ss_vref_direct) q_call(opc).fp = opt_p_p_vref; + else if (fp == opt_p_pi_ss_ivref_direct) q_call(opc).fp = opt_p_p_ivref; + } + return_true(sc, expr); + }} + + sc->pc = start; + if ((is_safe_procedure(s_func)) && (c_function_is_aritable(s_func, 1))) + { + q_func(opc).call = cf_call(sc, expr, s_func, 1); + if (is_symbol(arg1)) + { + const s7_pointer slot = opt_simple_symbol(sc, arg1); + if (slot) + { + q_arg1(opc).p = slot; + q_call(opc).fp = opt_p_call_s; + return_true(sc, expr); + }} + else + { + opt_info *o1; + if (!is_pair(arg1)) + { + q_arg1(opc).p = arg1; + q_call(opc).fp = opt_p_call_c; + return_true(sc, expr); + } + o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdr(expr))) + { + q_call(opc).fp = opt_p_call_f; + q_func1_arg(opc).o1 = o1; + q_func1(opc).fp = q_call(o1).fp; + if (q_func1(opc).fp == opt_p_pi_ss_fvref_direct) q_func1(opc).fp = opt_p_pi_ss_fvref_direct_wrapped; + else if (q_func1(opc).fp == opt_p_pi_ss_ivref_direct) q_func1(opc).fp = opt_p_pi_ss_ivref_direct_wrapped; + return_true(sc, expr); + }}} + return_false(sc, expr); +} + +/* -------- p_i -------- */ +static s7_pointer opt_p_i_s(opt_info *o) {return(q_func(o).p_i_f(o->sc, integer(slot_value(q_arg1(o).p))));} /* number_to_string_p_i expanded here doesn't gain much */ +static s7_pointer opt_p_i_f(opt_info *o) {return(q_func(o).p_i_f(o->sc, q_i_func1_call(o)));} +static s7_pointer opt_p_i_f_intc(opt_info *o) {return(integer_to_char_p_i(o->sc, q_i_func1_call(o)));} + +static bool p_i_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr, int32_t pstart) +{ + s7_pointer slot; + const s7_p_i_t ifunc = s7_p_i_function(s_func); + if (!ifunc) return_false(sc, expr); + q_func(opc).p_i_f = ifunc; + slot = opt_integer_symbol(sc, cadr(expr)); + if (slot) + { + q_arg1(opc).p = slot; + q_call(opc).fp = opt_p_i_s; + return_true(sc, expr); + } + if (int_optimize(sc, cdr(expr))) + { + q_call(opc).fp = (ifunc == integer_to_char_p_i) ? opt_p_i_f_intc : opt_p_i_f; + q_func1_arg(opc).o1 = sc->opts[pstart]; + q_func1(opc).fi = q_call(sc->opts[pstart]).fi; + return_true(sc, expr); + } + sc->pc = pstart; + return_false(sc, expr); +} + +/* -------- p_ii -------- */ +static s7_pointer opt_p_ii_ss(opt_info *o) {return(q_func(o).p_ii_f(o->sc, integer(slot_value(q_arg1(o).p)), integer(slot_value(q_arg2(o).p))));} +static s7_pointer opt_p_ii_fs(opt_info *o) {return(q_func(o).p_ii_f(o->sc, q_i_func1_call(o), integer(slot_value(q_arg2(o).p))));} +static s7_pointer opt_p_ii_ff_divide(opt_info *o) +{ + return(make_ratio_with_div_check(o->sc, o->sc->divide_symbol, q_i_func1_call(o), q_i_func2_call(o))); +} + +static s7_pointer opt_p_ii_ff(opt_info *o) +{ + s7_int i1 = q_i_func1_call(o); + return(q_func(o).p_ii_f(o->sc, i1, q_i_func2_call(o))); +} + +static bool p_ii_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr, int32_t pstart) +{ + s7_pointer arg2_slot; + const s7_p_ii_t ifunc = s7_p_ii_function(s_func); + if (!ifunc) return_false(sc, expr); + arg2_slot = opt_integer_symbol(sc, caddr(expr)); + if (arg2_slot) + { + const s7_pointer arg1_slot = opt_integer_symbol(sc, cadr(expr)); + if (arg1_slot) + { + q_arg1(opc).p = arg1_slot; + q_arg2(opc).p = arg2_slot; + q_func(opc).p_ii_f = ifunc; + q_call(opc).fp = opt_p_ii_ss; + return_true(sc, expr); + } + q_func1_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(expr))) + { + q_func1(opc).fi = q_func1_arg(opc).q_call(o1).fi; + q_arg2(opc).p = arg2_slot; + q_func(opc).p_ii_f = ifunc; + q_call(opc).fp = opt_p_ii_fs; + return_true(sc, expr); + } + sc->pc = pstart; + return_false(sc, expr); + } + q_func1_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(expr))) + { + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + q_func1(opc).fi = q_func1_arg(opc).q_call(o1).fi; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func(opc).p_ii_f = ifunc; + q_call(opc).fp = (ifunc == divide_p_ii) ? opt_p_ii_ff_divide : opt_p_ii_ff; + return_true(sc, expr); + }} + sc->pc = pstart; + return_false(sc, expr); +} + +/* -------- p_d -------- */ +static s7_pointer opt_p_d_s(opt_info *o) {return(q_func(o).p_d_f(o->sc, real_to_double(o->sc, slot_value(q_arg2(o).p), __func__)));} +static s7_pointer opt_p_d_f(opt_info *o) {return(q_func(o).p_d_f(o->sc, q_d_func1_call(o)));} + +static bool p_d_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr, int32_t pstart) +{ + s7_pointer arg1_slot; + opt_info *o1; + const s7_p_d_t ifunc = s7_p_d_function(s_func); + if (!ifunc) return_false(sc, expr); + arg1_slot = opt_float_symbol(sc, cadr(expr)); + if (arg1_slot) + { + q_arg2(opc).p = arg1_slot; + q_func(opc).p_d_f = ifunc; + q_call(opc).fp = opt_p_d_s; + return_true(sc, expr); + } + if ((is_number(cadr(expr))) && (!is_t_real(cadr(expr)))) + return_false(sc, expr); + o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdr(expr))) + { + q_func(opc).p_d_f = ifunc; + q_call(opc).fp = opt_p_d_f; + q_func1_arg(opc).o1 = o1; + q_func1(opc).fd = q_call(o1).fd; + return_true(sc, expr); + } + sc->pc = pstart; + return_false(sc, expr); +} + +/* -------- p_dd -------- */ +static s7_pointer opt_p_dd_sc(opt_info *o) {return(q_func(o).p_dd_f(o->sc, real_to_double(o->sc, slot_value(q_arg1(o).p), __func__), q_arg2(o).x));} +static s7_pointer opt_p_dd_cs(opt_info *o) {return(q_func(o).p_dd_f(o->sc, q_arg1(o).x, real_to_double(o->sc, slot_value(q_arg2(o).p), __func__)));} +static s7_pointer opt_p_dd_cc(opt_info *o) {return(q_func(o).p_dd_f(o->sc, q_arg1(o).x, q_arg2(o).x));} + +static bool p_dd_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr, int32_t pstart) +{ + const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); + const s7_p_dd_t ifunc = s7_p_dd_function(s_func); + if (!ifunc) return_false(sc, expr); + q_func(opc).p_dd_f = ifunc; + if (is_t_real(arg2)) + { + s7_pointer arg1_slot; + q_arg2(opc).x = real(arg2); + if (is_t_real(arg1)) + { + q_arg1(opc).x = real(arg1); + q_call(opc).fp = opt_p_dd_cc; + return_true(sc, expr); + } + arg1_slot = opt_real_symbol(sc, arg1); + if (arg1_slot) + { + q_arg1(opc).p = arg1_slot; + q_call(opc).fp = opt_p_dd_sc; + return_true(sc, expr); + }} + if (is_t_real(arg1)) + { + s7_pointer arg2_slot; + arg2_slot = opt_real_symbol(sc, arg2); + if (arg2_slot) + { + q_arg1(opc).x = real(arg1); + q_arg2(opc).p = arg2_slot; + q_call(opc).fp = opt_p_dd_cs; + return_true(sc, expr); + }} + sc->pc = pstart; + return_false(sc, expr); +} + +/* -------- p_pi -------- */ +static s7_pointer opt_p_pi_ss(opt_info *o) {return(q_func(o).p_pi_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))));} +static s7_pointer opt_p_pi_ss_sref(opt_info *o) {return(string_ref_p_pi_unchecked(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))));} +static s7_pointer opt_p_pi_ss_sref_direct(opt_info *o) {return(string_ref_p_pi_direct(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))));} +static s7_pointer opt_p_pi_ss_vref(opt_info *o) {return(t_vector_ref_p_pi_unchecked(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))));} +static s7_pointer opt_p_pi_ss_vref_direct(opt_info *o) {return(t_vector_ref_p_pi_direct(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))));} +static s7_pointer opt_p_pi_ss_fvref_direct(opt_info *o) {return(float_vector_ref_p_pi_direct(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))));} +static s7_pointer opt_p_pi_ss_cvref_direct(opt_info *o) {return(complex_vector_ref_p_pi_direct(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))));} +static s7_pointer opt_p_pi_ss_ivref_direct(opt_info *o) {return(int_vector_ref_p_pi_direct(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))));} +static s7_pointer opt_p_pi_ss_fvref_direct_wrapped(opt_info *o) {return(float_vector_ref_p_pi_direct_wrapped(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))));} +static s7_pointer opt_p_pi_ss_ivref_direct_wrapped(opt_info *o) {return(int_vector_ref_p_pi_direct_wrapped(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))));} +static s7_pointer opt_p_pi_ss_pref(opt_info *o) {return(list_ref_p_pi_unchecked(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))));} +static s7_pointer opt_p_pi_sc(opt_info *o) {return(q_func(o).p_pi_f(o->sc, slot_value(q_arg1(o).p), q_arg2(o).i));} +static s7_pointer opt_p_pi_sc_pref(opt_info *o) {return(list_ref_p_pi_unchecked(o->sc, slot_value(q_arg1(o).p), q_arg2(o).i));} +static s7_pointer opt_p_pi_sf(opt_info *o) {return(q_func(o).p_pi_f(o->sc, slot_value(q_arg1(o).p), q_i_func1_call(o)));} +static s7_pointer opt_p_pi_sf_sref(opt_info *o) {return(string_ref_p_pi_unchecked(o->sc, slot_value(q_arg1(o).p), q_i_func1_call(o)));} +static s7_pointer opt_p_pi_sf_sref_direct(opt_info *o) {return(string_ref_p_pi_direct(o->sc, slot_value(q_arg1(o).p), q_i_func1_call(o)));} +static s7_pointer opt_p_pi_fc(opt_info *o) {return(q_func(o).p_pi_f(o->sc, q_p_func1_call(o), q_arg2(o).i));} + +/* use a unique name (in this code) for this use of denominator -- this is a kludge -- we don't have anywhere in the slot + * to store the loop end, but the slot_value can be a small_int (or any unheaped integer), so we're assuming there + * aren't collisions? Each use is a single (uncomplicated) do loop, set up before each call? + */ +#if S7_DEBUGGING +static s7_pointer check_loop_end_ref(s7_scheme *sc, s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = type_unchecked(T_Slt(p)); + if (!has_loop_end(p)) complain(sc, "%s%s[%d]: loop_end not set, %s (%s)%s\n", p, func, line, typ); + return(T_Int(slot_value(p))); +} +#define loop_end(A) denominator(check_loop_end_ref(sc, A, __func__, __LINE__)) +#else +#define loop_end(A) denominator(T_Int(slot_value(A))) +#endif +#define set_loop_end(A, B) set_denominator(T_Int(slot_value(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 (q_func(o).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)) && (loop_end(slot) <= string_length(obj))) + q_func(opc).p_pi_f = string_ref_p_pi_direct; + break; + case T_BYTE_VECTOR: + if (((!expr) || (car(expr) == sc->byte_vector_ref_symbol) || (car(expr) == sc->vector_ref_symbol)) && + (loop_end(slot) <= byte_vector_length(obj))) + q_func(opc).p_pi_f = byte_vector_ref_p_pi_direct; + break; + case T_VECTOR: + if (((!expr) || (car(expr) == sc->vector_ref_symbol)) && (loop_end(slot) <= vector_length(obj))) + q_func(opc).p_pi_f = t_vector_ref_p_pi_direct; + break; + case T_FLOAT_VECTOR: + if (((!expr) || (car(expr) == sc->float_vector_ref_symbol) || (car(expr) == sc->vector_ref_symbol)) && + (loop_end(slot) <= vector_length(obj))) + q_func(opc).p_pi_f = float_vector_ref_p_pi_direct; + break; + case T_COMPLEX_VECTOR: + if (((!expr) || (car(expr) == sc->complex_vector_ref_symbol) || (car(expr) == sc->vector_ref_symbol)) && + (loop_end(slot) <= vector_length(obj))) + q_func(opc).p_pi_f = complex_vector_ref_p_pi_direct; + break; + case T_INT_VECTOR: + if (((!expr) || (car(expr) == sc->int_vector_ref_symbol) || (car(expr) == sc->vector_ref_symbol)) && + (loop_end(slot) <= vector_length(obj))) + q_func(opc).p_pi_f = int_vector_ref_p_pi_direct; + break; + } +} + +static void fixup_p_pi_ss(opt_info *opc) +{ + q_call(opc).fp = (q_func(opc).p_pi_f == string_ref_p_pi_unchecked) ? opt_p_pi_ss_sref : + ((q_func(opc).p_pi_f == string_ref_p_pi_direct) ? opt_p_pi_ss_sref_direct : + ((q_func(opc).p_pi_f == t_vector_ref_p_pi_unchecked) ? opt_p_pi_ss_vref : + ((q_func(opc).p_pi_f == float_vector_ref_p_pi_direct) ? opt_p_pi_ss_fvref_direct : + ((q_func(opc).p_pi_f == complex_vector_ref_p_pi_direct) ? opt_p_pi_ss_cvref_direct : + ((q_func(opc).p_pi_f == int_vector_ref_p_pi_direct) ? opt_p_pi_ss_ivref_direct : + ((q_func(opc).p_pi_f == t_vector_ref_p_pi_direct) ? opt_p_pi_ss_vref_direct : + ((q_func(opc).p_pi_f == list_ref_p_pi_unchecked) ? opt_p_pi_ss_pref : opt_p_pi_ss))))))); +} + +static bool p_pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer sig, s7_pointer expr) +{ + s7_pointer obj = NULL, arg1_slot, arg2_slot, checker = NULL; + opt_info *o1; + const s7_p_pi_t func = s7_p_pi_function(s_func); + if (!func) return_false(sc, expr); + + /* here we know cadr is a symbol */ + arg1_slot = opt_simple_symbol(sc, cadr(expr)); + if (!arg1_slot) + return_false(sc, expr); + if ((is_any_vector(slot_value(arg1_slot))) && + (vector_rank(slot_value(arg1_slot)) > 1)) + return_false(sc, expr); + + q_func(opc).p_pi_f = func; + q_arg1(opc).p = arg1_slot; + + if (is_symbol(cadr(sig))) + checker = cadr(sig); + + obj = slot_value(q_arg1(opc).p); + if ((s7_p_pi_unchecked_function(s_func)) && + (checker)) + { + 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))) + q_func(opc).p_pi_f = (is_t_vector(obj)) ? t_vector_ref_p_pi_unchecked : s7_p_pi_unchecked_function(s_func); + }} + arg2_slot = opt_integer_symbol(sc, caddr(expr)); + if (arg2_slot) + { + q_arg2(opc).p = arg2_slot; + if ((obj) && /* this depends above on s7_p_pi_unchecked_function, but none of the typed vectors have one?? */ + (has_loop_end(arg2_slot))) + check_unchecked(sc, obj, arg2_slot, opc, expr); + fixup_p_pi_ss(opc); + return_true(sc, expr); + } + if (is_t_integer(caddr(expr))) + { + q_arg2(opc).i = integer(caddr(expr)); + q_call(opc).fp = (q_func(opc).p_pi_f == list_ref_p_pi_unchecked) ? opt_p_pi_sc_pref : opt_p_pi_sc; + return_true(sc, expr); + } + o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + q_call(opc).fp = (q_func(opc).p_pi_f == string_ref_p_pi_unchecked) ? opt_p_pi_sf_sref : + ((q_func(opc).p_pi_f == string_ref_p_pi_direct) ? opt_p_pi_sf_sref_direct : opt_p_pi_sf); + q_func1_arg(opc).o1 = o1; + q_func1(opc).fi = q_call(o1).fi; + return_true(sc, expr); + } + return_false(sc, expr); +} + +static s7_pointer opt_p_pi_fco(opt_info *o) {return(q_func(o).p_pi_f(o->sc, q_func1(o).p_p_f(o->sc, slot_value(q_arg1(o).p)), q_arg2(o).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 (q_call(o1).fp == opt_p_p_s) + { + q_func1(opc).p_p_f = q_func1(o1).p_p_f; + q_arg1(opc).p = q_arg1(o1).p; + q_call(opc).fp = opt_p_pi_fco; + backup_pc(sc); + return_true(sc, NULL); + }} + return_false(sc, NULL); +} + +/* -------- p_pp -------- */ +static s7_pointer opt_p_pp_ss(opt_info *o) {return(q_func(o).p_pp_f(o->sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p)));} +static s7_pointer opt_p_pp_sc(opt_info *o) {return(q_func(o).p_pp_f(o->sc, slot_value(q_arg1(o).p), q_arg2(o).p));} +static s7_pointer opt_p_pp_slot_ref(opt_info *o) {return(slot_value(q_arg1(o).p));} /* not in s7test timp (set! sum (+ sum (* i (L2 'a)))) */ +static s7_pointer opt_p_pp_cs(opt_info *o) {return(q_func(o).p_pp_f(o->sc, q_arg1(o).p, slot_value(q_arg2(o).p)));} +static s7_pointer opt_p_pp_sf(opt_info *o) {return(q_func(o).p_pp_f(o->sc, slot_value(q_arg1(o).p), q_p_func1_call(o)));} +static s7_pointer opt_p_pp_fs(opt_info *o) {return(q_func(o).p_pp_f(o->sc, q_p_func1_call(o), slot_value(q_arg1(o).p)));} +static s7_pointer opt_p_pp_fc(opt_info *o) {return(q_func(o).p_pp_f(o->sc, q_p_func1_call(o), q_arg2(o).p));} +static s7_pointer opt_p_pp_cc(opt_info *o) {return(q_func(o).p_pp_f(o->sc, q_arg1(o).p, q_arg2(o).p));} +static s7_pointer opt_p_pp_cc_make_list(opt_info *o) {return(make_list(o->sc, q_arg1(o).i, q_arg2(o).p));} +static s7_pointer opt_set_car_pp_ss(opt_info *o) {return(inline_set_car(o->sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p)));} +static s7_pointer opt_p_pp_ss_href(opt_info *o) {return(s7_hash_table_ref(o->sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p)));} +static s7_pointer opt_p_pp_sf_add(opt_info *o) {return(add_p_pp(o->sc, slot_value(q_arg1(o).p), q_p_func1_call(o)));} +static s7_pointer opt_p_pp_sf_sub(opt_info *o) {return(subtract_p_pp(o->sc, slot_value(q_arg1(o).p), q_p_func1_call(o)));} +static s7_pointer opt_p_pp_sf_mul(opt_info *o) {return(multiply_p_pp(o->sc, slot_value(q_arg1(o).p), q_p_func1_call(o)));} +static s7_pointer opt_p_pp_sf_set_car(opt_info *o) {return(inline_set_car(o->sc, slot_value(q_arg1(o).p), q_p_func1_call(o)));} +static s7_pointer opt_p_pp_sf_set_cdr(opt_info *o) {return(inline_set_cdr(o->sc, slot_value(q_arg1(o).p), q_p_func1_call(o)));} +static s7_pointer opt_p_pp_sf_href(opt_info *o) {return(s7_hash_table_ref(o->sc, slot_value(q_arg1(o).p), q_p_func1_call(o)));} +static s7_pointer opt_p_pp_fs_vref(opt_info *o) {return(s7i_vector_ref_p_pp(o->sc, q_p_func1_call(o), slot_value(q_arg1(o).p)));} +static s7_pointer opt_p_pp_fs_cons(opt_info *o) {return(cons(o->sc, q_p_func1_call(o), slot_value(q_arg1(o).p)));} +static s7_pointer opt_p_pp_fs_add(opt_info *o) {return(add_p_pp(o->sc, q_p_func1_call(o), slot_value(q_arg1(o).p)));} +static s7_pointer opt_p_pp_fs_sub(opt_info *o) {return(subtract_p_pp(o->sc, q_p_func1_call(o), slot_value(q_arg1(o).p)));} + +static s7_pointer opt_p_pp_ss_lref(opt_info *o) +{ + s7_pointer sym = slot_value(q_arg2(o).p); + if (is_symbol(sym)) + return(let_ref_p_pp(o->sc, slot_value(q_arg1(o).p), (is_keyword(sym)) ? keyword_symbol(sym) : sym)); + return(let_ref(o->sc, slot_value(q_arg1(o).p), sym)); +} + +static s7_pointer opt_p_pp_sf_lref(opt_info *o) +{ + s7_pointer sym = q_p_func1_call(o); + if (is_symbol(sym)) + return(let_ref_p_pp(o->sc, slot_value(q_arg1(o).p), (is_keyword(sym)) ? keyword_symbol(sym) : sym)); + return(let_ref(o->sc, slot_value(q_arg1(o).p), sym)); +} + +static s7_pointer opt_p_pp_ff(opt_info *o) +{ + s7_scheme *sc = o->sc; + s7_pointer result; + gc_protect_2_via_stack_no_let(sc, q_p_func2_call(o), q_p_func3_call(o)); /* we do need to protect both */ + result = q_func(o).p_pp_f(sc, gc_protected1(sc), gc_protected2(sc)); + unstack_gc_protect(sc); + return(result); +} + +static s7_pointer opt_p_pp_ff_add_mul_mul_1(opt_info *o, bool add_case) /* (+|- (* x1 x2) (* x3 x4)) */ +{ + opt_info *o1 = q_func2_arg(o).o1, *o2 = q_func3_arg(o).o1; + s7_pointer x4; + s7_scheme *sc = o->sc; + const s7_pointer x1 = slot_value(q_arg1(o1).p); + s7_pointer x3 = slot_value(q_arg1(o2).p); + const s7_pointer x2 = q_func1(o1).fp(q_func1_arg(o1).o1); + if ((is_t_real(x2)) && (is_t_real(x1)) && (is_t_real(x3))) + { + s7_double r2 = real(x2); + x4 = q_func1(o2).fp(q_func1_arg(o2).o1); + if (is_t_real(x4)) + return(make_real(sc, (add_case) ? ((real(x1) * r2) + (real(x3) * real(x4))) : ((real(x1) * r2) - (real(x3) * real(x4))))); + gc_protect_via_stack_no_let(sc, x2); + } + else + { + gc_protect_via_stack_no_let(sc, x2); + x4 = q_func1(o2).fp(q_func1_arg(o2).o1); + } + set_gc_protected2(sc, x4); + set_gc_protected2(sc, multiply_p_pp_wrapped(sc, x3, x4)); + set_gc_protected1(sc, multiply_p_pp_wrapped(sc, x1, x2)); + x3 = (add_case) ? add_p_pp(sc, gc_protected1(sc), gc_protected2(sc)) : subtract_p_pp(sc, gc_protected1(sc), gc_protected2(sc)); + unstack_gc_protect(sc); + return(x3); +} + +static s7_pointer opt_p_pp_ff_add_mul_mul(opt_info *o) {return(opt_p_pp_ff_add_mul_mul_1(o, true));} +static s7_pointer opt_p_pp_ff_sub_mul_mul(opt_info *o) {return(opt_p_pp_ff_add_mul_mul_1(o, false));} + +static void check_opc_vector_wraps(opt_info *opc) +{ + if (q_func3(opc).fp == opt_p_pi_ss_ivref_direct) q_func3(opc).fp = opt_p_pi_ss_ivref_direct_wrapped; + if (q_func3(opc).fp == opt_p_pi_ss_fvref_direct) q_func3(opc).fp = opt_p_pi_ss_fvref_direct_wrapped; + if (q_func2(opc).fp == opt_p_pi_ss_ivref_direct) q_func2(opc).fp = opt_p_pi_ss_ivref_direct_wrapped; + if (q_func2(opc).fp == opt_p_pi_ss_fvref_direct) q_func2(opc).fp = opt_p_pi_ss_fvref_direct_wrapped; +} + +static void use_slot_ref(s7_scheme *sc, opt_info *opc, s7_pointer let, s7_pointer symbol) +{ + s7_pointer slot = symbol_to_local_slot(sc, symbol, T_Let(let)); + if (is_slot(slot)) + { + q_arg1(opc).p = slot; + q_call(opc).fp = opt_p_pp_slot_ref; + } +} + +static s7_pointer opt_p_unlet_ref(opt_info *o) {return(q_arg1(o).p);} +static s7_pointer opt_p_rootlet_ref(opt_info *o) {return(global_value(q_arg1(o).p));} + +static bool opt_unlet_rootlet_ref(s7_scheme *sc, opt_info *opc, s7_pointer arg1, s7_pointer sym, s7_pointer expr) +{ + if (car(arg1) == sc->rootlet_symbol) + { + if (!is_slot(global_slot(sym))) + { + q_call(opc).fp = opt_p_c; + q_arg1(opc).p = sc->undefined; + return_true(sc, expr); + }} + q_call(opc).fp = (car(arg1) == sc->rootlet_symbol) ? opt_p_rootlet_ref : opt_p_unlet_ref; + q_arg1(opc).p = (car(arg1) == sc->unlet_symbol) ? initial_value(sym) : sym; + return_true(sc, expr); +} + +static bool p_pp_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr, int32_t pstart) +{ + const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); + const s7_p_pp_t func = s7_p_pp_function(s_func); + if (!func) return_false(sc, expr); + q_func(opc).p_pp_f = func; + if (is_symbol(arg1)) + { + s7_pointer obj; + const s7_pointer arg1_slot = opt_simple_symbol(sc, arg1); + if (!arg1_slot) + { + sc->pc = pstart; + return_false(sc, expr); + } + obj = slot_value(arg1_slot); + if ((is_any_vector(obj)) && (vector_rank(obj) > 1)) + { + sc->pc = pstart; + return_false(sc, expr); + } + q_arg1(opc).p = arg1_slot; + + if ((func == hash_table_ref_p_pp) && (is_hash_table(obj))) + q_func(opc).p_pp_f = s7_hash_table_ref; + + if (is_symbol(arg2)) + { + q_arg2(opc).p = opt_simple_symbol(sc, arg2); + if (q_arg2(opc).p) + { + q_call(opc).fp = (func == set_car_p_pp) ? opt_set_car_pp_ss : + (((is_hash_table(obj)) && (func == hash_table_ref_p_pp)) ? opt_p_pp_ss_href : + (((is_let(obj)) && (func == let_ref)) ? opt_p_pp_ss_lref : opt_p_pp_ss)); + + /* if ss = s+k use slot_ref */ + if ((q_call(opc).fp == opt_p_pp_ss_lref) && (is_keyword(arg2))) + use_slot_ref(sc, opc, obj, keyword_symbol(arg2)); + + return_true(sc, expr); + } + sc->pc = pstart; + return_false(sc, expr); + } + if ((!is_pair(arg2)) || + (is_proper_quote(sc, arg2))) + { + q_arg2(opc).p = (!is_pair(arg2)) ? arg2 : cadr(arg2); + q_call(opc).fp = opt_p_pp_sc; + if ((is_pair(arg2)) && (is_symbol(q_arg2(opc).p)) && (is_let(obj)) && (q_func(opc).p_pp_f == let_ref)) + use_slot_ref(sc, opc, obj, cadr(arg2)); /* expr: (let-ref L 'a), can't be keyword here (handled above) */ + return_true(sc, expr); + } + if (cell_optimize(sc, cddr(expr))) + { + q_call(opc).fp = (func == add_p_pp) ? opt_p_pp_sf_add : ((func == subtract_p_pp) ? opt_p_pp_sf_sub : ((func == multiply_p_pp) ? opt_p_pp_sf_mul : + ((func == set_car_p_pp) ? opt_p_pp_sf_set_car : ((func == set_cdr_p_pp) ? opt_p_pp_sf_set_cdr : + (((is_hash_table(obj)) && (q_func(opc).p_pp_f == s7_hash_table_ref)) ? opt_p_pp_sf_href : + (((is_let(obj)) && (q_func(opc).p_pp_f == let_ref)) ? opt_p_pp_sf_lref : opt_p_pp_sf)))))); + q_func1_arg(opc).o1 = sc->opts[pstart]; + q_func1(opc).fp = q_call(sc->opts[pstart]).fp; + if (q_func1(opc).fp == opt_p_pi_ss_ivref_direct) q_func1(opc).fp = opt_p_pi_ss_ivref_direct_wrapped; + return_true(sc, expr); + }} + else /* cadr not a symbol */ + { + opt_info *o1 = sc->opts[sc->pc]; + if ((!is_pair(arg1)) || + (is_proper_quote(sc, arg1))) + { + q_arg1(opc).p = (!is_pair(arg1)) ? arg1 : cadr(arg1); + if ((!is_symbol(arg2)) && + ((!is_pair(arg2)) || + (is_proper_quote(sc, arg2)))) + { + q_arg2(opc).p = (!is_pair(arg2)) ? arg2 : cadr(arg2); + if ((q_func(opc).p_pp_f == make_list_p_pp) && + (is_t_integer(q_arg1(opc).p)) && (integer(q_arg1(opc).p) >= 0) && (integer(q_arg1(opc).p) < sc->max_list_length)) + { + q_call(opc).fp = opt_p_pp_cc_make_list; + q_arg1(opc).i = integer(q_arg1(opc).p); + } + else q_call(opc).fp = opt_p_pp_cc; + return_true(sc, expr); + } + if (is_symbol(arg2)) + { + q_arg2(opc).p = opt_simple_symbol(sc, arg2); + if (q_arg2(opc).p) + { + q_call(opc).fp = opt_p_pp_cs; + if (is_pair(slot_value(q_arg2(opc).p))) + { + if (func == assq_p_pp) q_func(opc).p_pp_f = s7_assq; + else + if (func == memq_p_pp) q_func(opc).p_pp_f = s7_memq; + else + if ((func == member_p_pp) && (is_simple(q_arg1(opc).p))) q_func(opc).p_pp_f = s7_memq; + else + if (func == assoc_p_pp) + { + if (is_simple(q_arg1(opc).p)) q_func(opc).p_pp_f = s7_assq; + else if (is_pair(car(slot_value(q_arg2(opc).p)))) q_func(opc).p_pp_f = assoc_1; + }} + return_true(sc, expr); + } + sc->pc = pstart; + return_false(sc, expr); + }} + + if ((car(expr) == sc->let_ref_symbol) && (is_pair(arg1)) && + ((is_symbol_and_keyword(arg2)) || ((is_quoted_symbol(sc, arg2)))) && + ((car(arg1) == sc->unlet_symbol) || (car(arg1) == sc->rootlet_symbol) || (car(arg1) == sc->curlet_symbol))) + return(opt_unlet_rootlet_ref(sc, opc, arg1, (is_pair(arg2)) ? cadr(arg2) : keyword_symbol(arg2), expr)); + + if (cell_optimize(sc, cdr(expr))) + { + if (is_symbol(arg2)) + { + q_arg1(opc).p = opt_simple_symbol(sc, arg2); + if (q_arg1(opc).p) + { + q_call(opc).fp = (func == add_p_pp) ? opt_p_pp_fs_add : ((func == subtract_p_pp) ? opt_p_pp_fs_sub : + ((func == s7i_vector_ref_p_pp) ? opt_p_pp_fs_vref : ((func == cons_p_pp) ? opt_p_pp_fs_cons : opt_p_pp_fs))); + q_func1_arg(opc).o1 = o1; + q_func1(opc).fp = q_call(o1).fp; + if (q_func1(opc).fp == opt_p_p_s_random) q_func1(opc).fp = opt_p_p_s_random_wrapped; + return_true(sc, expr); + } + sc->pc = pstart; + return_false(sc, expr); + } + if ((!is_pair(arg2)) || + (is_proper_quote(sc, arg2))) + { + if (is_t_integer(arg2)) + { + const s7_p_pi_t ifunc = s7_p_pi_function(s_func); + if (ifunc) + { + q_arg2(opc).i = integer(arg2); + q_func(opc).p_pi_f = ifunc; + if (!p_pi_fc_combinable(sc, opc)) + { + q_call(opc).fp = opt_p_pi_fc; + q_func1_arg(opc).o1 = o1; + q_func1(opc).fp = q_call(o1).fp; + } + return_true(sc, expr); + }} + q_arg2(opc).p = (!is_pair(arg2)) ? arg2 : cadr(arg2); + q_call(opc).fp = opt_p_pp_fc; + q_func1_arg(opc).o1 = o1; + q_func1(opc).fp = q_call(o1).fp; + return_true(sc, expr); + } + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(expr))) + { + q_func2_arg(opc).o1 = o1; + q_func2(opc).fp = q_call(o1).fp; + q_func3(opc).fp = q_func3_arg(opc).q_call(o1).fp; + q_call(opc).fp = opt_p_pp_ff; + if ((q_func3(opc).fp == opt_p_pp_sf_mul) && (q_func2(opc).fp == opt_p_pp_sf_mul)) + { + if (func == add_p_pp) q_call(opc).fp = opt_p_pp_ff_add_mul_mul; + else if (func == subtract_p_pp) q_call(opc).fp = opt_p_pp_ff_sub_mul_mul; + } + check_opc_vector_wraps(opc); + return_true(sc, expr); + }}} + sc->pc = pstart; + return_false(sc, expr); +} + +/* -------- p_call_pp -------- */ +static s7_pointer opt_p_call_ff(opt_info *o) +{ + s7_pointer po2; + s7_scheme *sc = o->sc; + gc_protect_via_stack_no_let(sc, q_p_func1_call(o)); + po2 = q_p_func2_call(o); + po2 = q_func(o).call(sc, set_plist_2(sc, gc_protected1(sc), po2)); + unstack_gc_protect(sc); + return(po2); +} + +static s7_pointer opt_p_call_fs(opt_info *o) +{ + s7_pointer po1 = q_p_func1_call(o); + return(q_func(o).call(o->sc, set_plist_2(o->sc, po1, slot_value(q_arg1(o).p)))); +} + +static s7_pointer opt_p_call_sf(opt_info *o) +{ + s7_pointer po1 = q_p_func1_call(o); + return(q_func(o).call(o->sc, set_plist_2(o->sc, slot_value(q_arg1(o).p), po1))); +} + +static s7_pointer opt_p_call_fc(opt_info *o) +{ + s7_pointer po1 = q_p_func1_call(o); + return(q_func(o).call(o->sc, set_plist_2(o->sc, po1, q_arg2(o).p))); +} + +static s7_pointer opt_p_call_cc(opt_info *o) {return(q_func(o).call(o->sc, set_plist_2(o->sc, q_arg1(o).p, q_arg2(o).p)));} +static s7_pointer opt_p_call_sc(opt_info *o) {return(q_func(o).call(o->sc, set_plist_2(o->sc, slot_value(q_arg1(o).p), q_arg2(o).p)));} +static s7_pointer opt_p_call_ss(opt_info *o) {return(q_func(o).call(o->sc, set_plist_2(o->sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p))));} + +static void check_opc_vector_wraps_1(opt_info *opc) +{ + if (q_func1(opc).fp == opt_p_pi_ss_ivref_direct) q_func1(opc).fp = opt_p_pi_ss_ivref_direct_wrapped; + if (q_func1(opc).fp == opt_p_pi_ss_fvref_direct) q_func1(opc).fp = opt_p_pi_ss_fvref_direct_wrapped; + if (q_func2(opc).fp == opt_p_pi_ss_ivref_direct) q_func2(opc).fp = opt_p_pi_ss_ivref_direct_wrapped; + if (q_func2(opc).fp == opt_p_pi_ss_fvref_direct) q_func2(opc).fp = opt_p_pi_ss_fvref_direct_wrapped; +} + +static bool p_call_pp_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr, int32_t pstart) +{ + if ((is_safe_procedure(s_func)) && (c_function_is_aritable(s_func, 2))) + { + const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); + q_func(opc).call = cf_call(sc, expr, s_func, 2); + if ((is_code_constant(sc, arg1)) && (is_code_constant(sc, arg2))) + { + q_call(opc).fp = opt_p_call_cc; + q_arg1(opc).p = (is_pair(arg1)) ? cadr(arg1) : arg1; + q_arg2(opc).p = (is_pair(arg2)) ? cadr(arg2) : arg2; + return_true(sc, expr); + } + if (is_symbol(arg1)) + { + q_arg1(opc).p = s7_slot(sc, arg1); /* can be # */ + if ((is_slot(q_arg1(opc).p)) && + (!has_methods(slot_value(q_arg1(opc).p)))) + { + if (is_symbol(arg2)) + { + q_arg2(opc).p = opt_simple_symbol(sc, arg2); + if (q_arg2(opc).p) + { + q_call(opc).fp = opt_p_call_ss; + return_true(sc, expr); + } + sc->pc = pstart; + return_false(sc, expr); + } + if (!is_pair(arg2)) + { + q_arg2(opc).p = arg2; + q_call(opc).fp = opt_p_call_sc; + return_true(sc, expr); + } + if (cell_optimize(sc, cddr(expr))) + { + q_func1_arg(opc).o1 = sc->opts[pstart]; + q_func1(opc).fp = q_func1_arg(opc).q_call(o1).fp; + q_call(opc).fp = opt_p_call_sf; + return_true(sc, expr); + }} + else + { + sc->pc = pstart; + return_false(sc, expr); + }} + q_func1_arg(opc).o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdr(expr))) + { + q_func1(opc).fp = q_func1_arg(opc).q_call(o1).fp; + if (is_symbol(arg2)) + { + q_arg1(opc).p = opt_simple_symbol(sc, arg2); + if (q_arg1(opc).p) + { + q_call(opc).fp = opt_p_call_fs; + return_true(sc, expr); + } + sc->pc = pstart; + return_false(sc, expr); + } + if ((!is_pair(arg2)) || (is_proper_quote(sc, arg2))) /* (char-ciopts[sc->pc]; + if (cell_optimize(sc, cddr(expr))) + { + q_func2(opc).fp = q_func2_arg(opc).q_call(o1).fp; + q_call(opc).fp = opt_p_call_ff; + check_opc_vector_wraps_1(opc); + return_true(sc, expr); + }}} + sc->pc = pstart; + return_false(sc, expr); +} + +/* -------- p_pip --------*/ + +static s7_pointer opt_p_pip_ssf(opt_info *o) +{ + return(q_func(o).p_pip_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), q_p_func1_call(o))); +} + +static s7_pointer opt_p_pip_ssf_sset(opt_info *o) +{ + return(string_set_p_pip_direct(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), q_p_func1_call(o))); +} + +static s7_pointer opt_p_pip_ssf_vset(opt_info *o) +{ + return(vector_set_p_pip_unchecked(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), q_p_func1_call(o))); +} + +static s7_pointer opt_p_pip_sss(opt_info *o) +{ + return(q_func(o).p_pip_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), slot_value(q_arg3(o).p))); +} + +static s7_pointer opt_p_pip_sss_vset(opt_info *o) +{ + return(vector_set_p_pip_unchecked(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), slot_value(q_arg3(o).p))); +} + +static s7_pointer opt_p_pip_ssc(opt_info *o) +{ + return(q_func(o).p_pip_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), q_arg3(o).p)); +} + +static s7_pointer opt_p_pip_sff(opt_info *o) +{ + s7_int i1 = q_i_func2_call(o); + return(q_func(o).p_pip_f(o->sc, slot_value(q_arg1(o).p), i1, q_p_func3_call(o))); +} + +static s7_pointer opt_p_pip_sff_lset(opt_info *o) +{ + s7_int i1 = q_i_func2_call(o); + return(list_set_p_pip_unchecked(o->sc, slot_value(q_arg1(o).p), i1, q_p_func3_call(o))); +} + +static s7_pointer opt_p_pip_sso(opt_info *o) +{ + return(q_func(o).p_pip_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), + q_func3(o).p_pi_f(o->sc, slot_value(q_arg3(o).p), integer(slot_value(q_arg4(o).p))))); +} + +static s7_pointer opt_p_pip_ssf1(opt_info *o) +{ + return(q_func(o).p_pip_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), q_func1(o).p_p_f(o->sc, q_p_func2_call(o)))); +} + +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 ((q_call(o1).fp == opt_p_pi_ss) || (q_call(o1).fp == opt_p_pi_ss_sref) || (q_call(o1).fp == opt_p_pi_ss_vref) || + (q_call(o1).fp == opt_p_pi_ss_sref_direct) || (q_call(o1).fp == opt_p_pi_ss_vref_direct) || (q_call(o1).fp == opt_p_pi_ss_fvref_direct) || + (q_call(o1).fp == opt_p_pi_ss_ivref_direct) || (q_call(o1).fp == opt_p_pi_ss_pref)) + { + q_func(opc).p_pip_f = q_func(opc).p_pip_f; + q_func3(opc).p_pi_f = q_func(o1).p_pi_f; + q_arg3(opc).p = q_arg1(o1).p; + q_arg4(opc).p = q_arg2(o1).p; + q_call(opc).fp = opt_p_pip_sso; + backup_pc(sc); + return_true(sc, NULL); + }} + o1 = sc->opts[start]; + if (q_call(o1).fp != opt_p_p_f) + return_false(sc, NULL); + q_func1(opc).p_p_f = q_func1(o1).p_p_f; + q_func2_arg(opc).o1 = sc->opts[start + 1]; + q_func2(opc).fp = q_call(sc->opts[start + 1]).fp; + q_call(opc).fp = opt_p_pip_ssf1; + return_true(sc, NULL); +} + +static bool p_pip_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) +{ + s7_pointer obj, arg1_slot, obj1, sig, checker = NULL, val_type; + const s7_p_pip_t func = s7_p_pip_function(s_func); + if (!func) return_false(sc, expr); + 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 */ + arg1_slot = s7_slot(sc, cadr(expr)); + if (!is_slot(arg1_slot)) return_false(sc, expr); + obj1 = slot_value(arg1_slot); + if ((has_methods(obj1)) || (is_immutable(obj1))) return_false(sc, expr); + if ((is_any_vector(obj1)) && (vector_rank(obj1) > 1)) return_false(sc, expr); + val_type = opt_arg_type(sc, cdddr(expr)); + q_arg1(opc).p = arg1_slot; + obj = slot_value(q_arg1(opc).p); + q_func(opc).p_pip_f = func; + if ((s7_p_pip_unchecked_function(s_func)) && + (checker)) + { + if ((is_t_vector(obj)) && (checker == sc->is_vector_symbol)) + q_func(opc).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? */ + q_func(opc).p_pip_f = s7_p_pip_unchecked_function(s_func); + else + 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)))) + q_func(opc).p_pip_f = s7_p_pip_unchecked_function(s_func); + } + if (is_symbol(caddr(expr))) + { + const int32_t start = sc->pc; + const s7_pointer arg3 = cadddr(expr); /* see val_type above */ + const s7_pointer arg2_slot = opt_integer_symbol(sc, caddr(expr)); + if (arg2_slot) + { + q_arg2(opc).p = arg2_slot; + if (has_loop_end(arg2_slot)) + switch (type(obj)) + { + case T_VECTOR: + if (loop_end(arg2_slot) <= vector_length(obj)) + q_func(opc).p_pip_f = (is_typed_vector(obj)) ? typed_t_vector_set_p_pip_direct : t_vector_set_p_pip_direct; + break; + case T_BYTE_VECTOR: + if ((val_type != sc->is_integer_symbol) && (val_type != sc->is_byte_symbol)) return_false(sc, expr); + if (loop_end(arg2_slot) <= vector_length(obj)) + q_func(opc).p_pip_f = byte_vector_set_p_pip_direct; + break; + case T_INT_VECTOR: + if ((val_type != sc->is_integer_symbol) && (val_type != sc->is_byte_symbol)) return_false(sc, expr); + if (loop_end(arg2_slot) <= vector_length(obj)) + q_func(opc).p_pip_f = int_vector_set_p_pip_direct; + break; + case T_FLOAT_VECTOR: + if ((val_type != sc->is_float_symbol) && (val_type != sc->is_real_symbol)) return_false(sc, expr); + if (loop_end(arg2_slot) <= vector_length(obj)) + q_func(opc).p_pip_f = float_vector_set_p_pip_direct; + break; + case T_COMPLEX_VECTOR: + if ((val_type != sc->is_complex_symbol) && (val_type != sc->is_real_symbol)) return_false(sc, expr); + if (loop_end(arg2_slot) <= vector_length(obj)) + q_func(opc).p_pip_f = complex_vector_set_p_pip_direct; + break; + case T_STRING: + if (loop_end(arg2_slot) <= string_length(obj)) + q_func(opc).p_pip_f = string_set_p_pip_direct; + break; + } /* T_PAIR here would require list_length check which sort of defeats the purpose */ + + if (is_symbol(arg3)) + { + s7_pointer val_slot = opt_simple_symbol(sc, arg3); + /* for int|byte|float-vector and string need opt_arg_type check?? see val_type above, if vector-set! but have int-vector sig is wrong */ + if (val_slot) + { + q_arg3(opc).p = val_slot; + q_call(opc).fp = (q_func(opc).p_pip_f == vector_set_p_pip_unchecked) ? opt_p_pip_sss_vset : opt_p_pip_sss; + return_true(sc, expr); + }} + else + if ((!is_pair(arg3)) || + (is_proper_quote(sc, arg3))) + { + q_arg3(opc).p = (is_pair(arg3)) ? cadr(arg3) : arg3; + q_call(opc).fp = opt_p_pip_ssc; + return_true(sc, expr); + } + if (cell_optimize(sc, cdddr(expr))) + { + if (p_pip_ssf_combinable(sc, opc, start)) + return_true(sc, expr); + q_call(opc).fp = (q_func(opc).p_pip_f == string_set_p_pip_direct) ? opt_p_pip_ssf_sset : + ((q_func(opc).p_pip_f == vector_set_p_pip_unchecked) ? opt_p_pip_ssf_vset : opt_p_pip_ssf); + q_func1_arg(opc).o1 = sc->opts[start]; + q_func1(opc).fp = q_call(sc->opts[start]).fp; + return_true(sc, expr); + }}} + else /* not symbol caddr */ + { + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdddr(expr))) + { + q_call(opc).fp = (q_func(opc).p_pip_f == list_set_p_pip_unchecked) ? opt_p_pip_sff_lset : opt_p_pip_sff; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func3(opc).fp = q_func3_arg(opc).q_call(o1).fp; + return_true(sc, expr); + }}} + return_false(sc, expr); +} + +/* -------- p_piip -------- */ + +static s7_pointer opt_p_piip_sssf(opt_info *o) +{ + return(q_func(o).p_piip_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), integer(slot_value(q_arg3(o).p)), q_p_func2_call(o))); +} + +static s7_pointer vector_set_piip_sssf_unchecked(opt_info *o) +{ + s7_pointer vec = slot_value(q_arg1(o).p); + s7_pointer val = q_p_func2_call(o); + vector_element(vec, ((integer(slot_value(q_arg2(o).p)) * vector_offset(vec, 0)) + integer(slot_value(q_arg3(o).p)))) = val; + return(val); +} + +static s7_pointer opt_p_piip_sssc(opt_info *o) +{ + return(q_func(o).p_piip_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), integer(slot_value(q_arg3(o).p)), q_arg4(o).p)); +} + +static s7_pointer opt_p_piip_sfff(opt_info *o) +{ + s7_int i1 = q_i_func2_call(o); + s7_int i2 = q_i_func3_call(o); + return(q_func(o).p_piip_f(o->sc, slot_value(q_arg1(o).p), i1, i2, q_p_func1_call(o))); +} + +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 ind1_slot; + s7_pointer ind2_slot = opt_integer_symbol(sc, car(indexp2)); + if (!ind2_slot) return_false(sc, indexp1); /* normally expr, indexp1 has more context than indexp2 */ + q_arg3(opc).p = ind2_slot; + ind1_slot = opt_integer_symbol(sc, car(indexp1)); + if (ind1_slot) + { + q_arg2(opc).p = ind1_slot; + if ((is_symbol(car(valp))) || + (is_unquoted_pair(sc, car(valp)))) + { + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, valp)) + return_false(sc, indexp1); + q_func2(opc).fp = q_func2_arg(opc).q_call(o1).fp; + q_call(opc).fp = opt_p_piip_sssf; + if ((is_t_vector(obj)) && + (loop_end_fits(q_arg2(opc).p, vector_dimension(obj, 0))) && + (loop_end_fits(q_arg3(opc).p, vector_dimension(obj, 1)))) + q_call(opc).fp = vector_set_piip_sssf_unchecked; + return_true(sc, NULL); + } + q_call(opc).fp = opt_p_piip_sssc; + q_arg4(opc).p = (is_pair(car(valp))) ? cadar(valp) : car(valp); + return_true(sc, NULL); + } + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, indexp1)) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, indexp2)) + { + q_func1_arg(opc).o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, valp)) + { + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func3(opc).fi = q_func3_arg(opc).q_call(o1).fi; + q_func1(opc).fp = q_func1_arg(opc).q_call(o1).fp; + q_call(opc).fp = opt_p_piip_sfff; + return_true(sc, NULL); + }}} + return_false(sc, indexp1); +} + +static bool p_piip_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) +{ + const s7_p_piip_t func = s7_p_piip_function(s_func); + if ((func) && (s_func == global_value(sc->vector_set_symbol)) && (is_symbol(cadr(expr)))) + { + s7_pointer obj; + const s7_pointer arg1_slot = s7_slot(sc, cadr(expr)); + if (!is_slot(arg1_slot)) + return_false(sc, expr); + obj = slot_value(arg1_slot); + if ((has_methods(obj)) || (is_immutable(obj))) + return_false(sc, expr); + if ((is_any_vector(obj)) && /* vector_set_p_piip calls vector_setter(obj) */ + (vector_rank(obj) == 2)) + { + q_arg1(opc).p = arg1_slot; + q_func(opc).p_piip_f = vector_set_p_piip; + return(p_piip_to_sx(sc, opc, cddr(expr), cdddr(expr), cddddr(expr), obj)); + }} + return_false(sc, expr); +} + +/* -------- p_pii -------- */ +static s7_pointer opt_p_pii_sss(opt_info *o) +{ + return(q_func(o).p_pii_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), integer(slot_value(q_arg3(o).p)))); +} + +static s7_pointer opt_p_pii_sff(opt_info *o) +{ + s7_int i1 = q_i_func2_call(o); + s7_int i2 = q_i_func3_call(o); + return(q_func(o).p_pii_f(o->sc, slot_value(q_arg1(o).p), i1, i2)); +} + +static s7_pointer vector_ref_pii_sss_unchecked(opt_info *o) +{ + s7_pointer vec = slot_value(q_arg1(o).p); + return(vector_element(vec, ((integer(slot_value(q_arg2(o).p)) * vector_offset(vec, 0)) + integer(slot_value(q_arg3(o).p))))); +} + +static bool p_pii_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) +{ + const s7_p_pii_t func = s7_p_pii_function(s_func); + if ((func) && + (is_symbol(cadr(expr)))) + { + s7_pointer obj; + const s7_pointer arg1_slot = s7_slot(sc, cadr(expr)); + if (!is_slot(arg1_slot)) return_false(sc, expr); + obj = slot_value(arg1_slot); + if ((has_methods(obj)) || (is_immutable(obj))) return_false(sc, expr); + if ((is_t_vector(obj)) && + (vector_rank(obj) == 2)) + { + s7_pointer ind2_slot, indexp1 = cddr(expr), indexp2 = cdddr(expr); + q_arg1(opc).p = arg1_slot; + q_func(opc).p_pii_f = vector_ref_p_pii; + ind2_slot = opt_integer_symbol(sc, car(indexp2)); + if (ind2_slot) + { + s7_pointer ind1_slot; + q_arg3(opc).p = ind2_slot; + ind1_slot = opt_integer_symbol(sc, car(indexp1)); + if (ind1_slot) + { + q_arg2(opc).p = ind1_slot; + q_call(opc).fp = opt_p_pii_sss; + /* normal vector rank 2 (see above) */ + if ((loop_end_fits(q_arg2(opc).p, vector_dimension(slot_value(q_arg1(opc).p), 0))) && + (loop_end_fits(q_arg3(opc).p, vector_dimension(slot_value(q_arg1(opc).p), 1)))) + q_call(opc).fp = vector_ref_pii_sss_unchecked; + return_true(sc, expr); + }} + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, indexp1)) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, indexp2)) + { + q_call(opc).fp = opt_p_pii_sff; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func3(opc).fi = q_func3_arg(opc).q_call(o1).fi; + return_true(sc, expr); + }}}} + return_false(sc, expr); +} + +/* -------- p_ppi -------- */ +static s7_pointer opt_p_ppi_psf(opt_info *o) {return(q_func(o).p_ppi_f(o->sc, q_arg1(o).p, slot_value(q_arg2(o).p), q_i_func1_call(o)));} +static s7_pointer opt_p_ppi_psf_cpos(opt_info *o) {return(char_position_p_ppi(o->sc, q_arg1(o).p, slot_value(q_arg2(o).p), q_i_func1_call(o)));} + +static bool p_ppi_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) +{ + const int32_t start = sc->pc; + const s7_p_ppi_t ifunc = s7_p_ppi_function(s_func); + if (!ifunc) return_false(sc, expr); + q_func(opc).p_ppi_f = ifunc; + if ((is_character(cadr(expr))) && + (is_symbol(caddr(expr))) && + (int_optimize(sc, cdddr(expr)))) + { + const s7_pointer arg2_slot = opt_simple_symbol(sc, caddr(expr)); + if (arg2_slot) + { + q_arg1(opc).p = cadr(expr); + q_arg2(opc).p = arg2_slot; + q_call(opc).fp = (ifunc == char_position_p_ppi) ? opt_p_ppi_psf_cpos : opt_p_ppi_psf; + q_func1_arg(opc).o1 = sc->opts[start]; + q_func1(opc).fi = q_call(sc->opts[start]).fi; + return_true(sc, expr); + }} + sc->pc = start; + return_false(sc, expr); +} + +/* -------- p_ppp -------- */ + +static s7_pointer opt_p_ppp_ssf(opt_info *o) {return(q_func(o).p_ppp_f(o->sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p), q_p_func1_call(o)));} +static s7_pointer opt_p_ppp_hash_table_increment(opt_info *o) {return(fx_hash_table_increment_1(o->sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p), q_arg3(o).p));} +static s7_pointer opt_p_ppp_sfs(opt_info *o) {return(q_func(o).p_ppp_f(o->sc, slot_value(q_arg1(o).p), q_p_func1_call(o), slot_value(q_arg2(o).p)));} +static s7_pointer opt_p_ppp_scs(opt_info *o) {return(q_func(o).p_ppp_f(o->sc, slot_value(q_arg1(o).p), q_arg2(o).p, slot_value(q_arg3(o).p)));} +static s7_pointer opt_p_ppp_sss(opt_info *o) {return(q_func(o).p_ppp_f(o->sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p), slot_value(q_arg3(o).p)));} +static s7_pointer opt_p_ppp_sss_mul(opt_info *o) {return(multiply_p_ppp(o->sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p), slot_value(q_arg3(o).p)));} +static s7_pointer opt_p_ppp_sss_hset(opt_info *o) {return(s7_hash_table_set(o->sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p), slot_value(q_arg3(o).p)));} +static s7_pointer opt_p_ppp_ssc(opt_info *o) {return(q_func(o).p_ppp_f(o->sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p), q_arg3(o).p));} +static s7_pointer opt_list_3c(opt_info *o) {s7_scheme *sc = o->sc; return(list_3(sc, q_arg1(o).p, q_arg2(o).p, q_arg3(o).p));} + +static s7_pointer opt_p_ppp_sff(opt_info *o) +{ + s7_pointer result; + s7_scheme *sc = o->sc; + gc_protect_2_via_stack_no_let(sc, T_Ext(q_p_func2_call(o)), T_Ext(q_p_func3_call(o))); + result = q_func(o).p_ppp_f(o->sc, slot_value(q_arg1(o).p), gc_protected1(sc), gc_protected2(sc)); + unstack_gc_protect(sc); + return(result); +} + +static s7_pointer opt_p_ppp_fff(opt_info *o) +{ + s7_pointer result; + s7_scheme *sc = o->sc; + gc_protect_2_via_stack_no_let(sc, T_Ext(q_p_func2_call(o)), T_Ext(q_p_func3_call(o))); + result = q_func(o).p_ppp_f(sc, gc_protected1(sc), gc_protected2(sc), q_p_func1_call(o)); + unstack_gc_protect(sc); + return(result); +} + +static s7_pointer opt_p_ppc_slot_set(opt_info *o) {slot_set_value(q_arg2(o).p, q_arg3(o).p); return(q_arg3(o).p);} +static s7_pointer opt_p_pps_slot_set(opt_info *o) {slot_set_value(q_arg2(o).p, slot_value(q_arg3(o).p)); return(slot_value(q_arg3(o).p));} +static s7_pointer opt_p_ppf_slot_set(opt_info *o) {slot_set_value(q_arg2(o).p, q_p_func1_call(o)); return(slot_value(q_arg2(o).p));} + +static bool use_ppc_slot_set(s7_scheme *sc, opt_info *opc, s7_pointer let, s7_pointer symbol, s7_pointer value) /* timp tmisc */ +{ + s7_pointer slot = lookup_slot_with_let(sc, symbol, let); + if ((is_slot(slot)) && (!is_immutable(slot))) + { + q_arg2(opc).p = slot; + q_arg3(opc).p = value; + q_call(opc).fp = opt_p_ppc_slot_set; + return(true); + } + return(false); +} + +static bool use_pps_slot_set(s7_scheme *sc, opt_info *opc, s7_pointer let, s7_pointer symbol, s7_pointer val_slot) /* timp tref */ +{ + s7_pointer slot = lookup_slot_with_let(sc, symbol, let); + if ((is_slot(slot)) && (!is_immutable(slot))) + { + q_arg2(opc).p = slot; + q_arg3(opc).p = val_slot; + q_call(opc).fp = opt_p_pps_slot_set; + return(true); + } + return(false); +} + +static bool use_ppf_slot_set(s7_scheme *sc, opt_info *opc, s7_pointer let, s7_pointer symbol) /* timp */ +{ + s7_pointer slot = lookup_slot_with_let(sc, symbol, let); + if ((is_slot(slot)) && (!is_immutable(slot))) + { + q_arg2(opc).p = slot; + q_call(opc).fp = opt_p_ppf_slot_set; + return(true); + } + return(false); +} + +static bool p_ppp_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) +{ + const s7_pointer arg1 = cadr(expr); + const s7_pointer arg2 = caddr(expr); + const s7_pointer arg3 = cadddr(expr); + const int32_t start = sc->pc; + const s7_p_ppp_t func = s7_p_ppp_function(s_func); + if (!func) return_false(sc, expr); + q_func(opc).p_ppp_f = func; + if (is_symbol(arg1)) + { + s7_pointer obj; + opt_info *o1; + s7_pointer arg1_slot = s7_slot(sc, arg1); + if ((!is_slot(arg1_slot)) || + (has_methods(slot_value(arg1_slot)))) + return_false(sc, expr); + + obj = slot_value(arg1_slot); + if ((is_any_vector(obj)) && + (vector_rank(obj) > 1)) + return_false(sc, expr); + + if (is_target_or_its_alias(car(expr), s_func, sc->hash_table_set_symbol)) + { + if ((!is_hash_table(obj)) || (is_immutable_hash_table(obj))) + return_false(sc, expr); + } + else + if ((is_target_or_its_alias(car(expr), s_func, sc->let_set_symbol)) && + ((!is_let(obj)) || (is_immutable(obj)))) + return_false(sc, expr); + + q_arg1(opc).p = arg1_slot; + + if ((func == hash_table_set_p_ppp) && (is_hash_table(obj))) + q_func(opc).p_ppp_f = s7_hash_table_set; + + if (is_symbol(arg2)) + { + s7_pointer arg2_slot; + if ((is_keyword(arg2)) && (is_symbol(arg3)) && (is_let(obj)) && (q_func(opc).p_ppp_f == let_set_2)) + { + s7_pointer val_slot = opt_simple_symbol(sc, arg3); + if ((val_slot) && (use_pps_slot_set(sc, opc, obj, keyword_symbol(arg2), val_slot))) + return_true(sc, expr); + } + arg2_slot = opt_simple_symbol(sc, arg2); + if (arg2_slot) + { + const s7_pointer arg2_val = slot_value(arg2_slot); + q_arg2(opc).p = arg2_slot; + if (is_symbol(arg3)) + { + s7_pointer arg3_slot; + arg3_slot = opt_simple_symbol(sc, arg3); + if (arg3_slot) + { + s7_p_ppp_t func1 = q_func(opc).p_ppp_f; + q_arg3(opc).p = arg3_slot; /* some other caller depends on this? op_simple_do_1[86577]: not a slot */ + q_call(opc).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(sc, expr); + }} + else + if ((!is_pair(arg3)) || + (is_proper_quote(sc, arg3))) + { + q_arg3(opc).p = (is_pair(arg3)) ? cadr(arg3) : arg3; + q_call(opc).fp = opt_p_ppp_ssc; + if ((is_let(obj)) && (q_func(opc).p_ppp_f == let_set_2) && (is_symbol(arg2_val))) /* (let-set! L3 :x 0) */ + use_ppc_slot_set(sc, opc, obj, (is_keyword(arg2_val)) ? keyword_symbol(arg2_val) : arg2_val, q_arg3(opc).p); + return_true(sc, expr); + } + if (optimize_op(expr) == HOP_HASH_TABLE_INCREMENT) + { + q_call(opc).fp = opt_p_ppp_hash_table_increment; + q_arg3(opc).p = expr; + return_true(sc, expr); + } + if (cell_optimize(sc, cdddr(expr))) + { + q_func1_arg(opc).o1 = sc->opts[start]; + q_func1(opc).fp = q_func1_arg(opc).q_call(o1).fp; + q_call(opc).fp = opt_p_ppp_ssf; + if ((is_let(obj)) && (is_symbol_and_keyword(arg2_val)) && (q_func(opc).p_ppp_f == let_set_2)) /* (let-set! L3 :x (+ (L3 'x) 1)) */ + use_ppf_slot_set(sc, opc, obj, keyword_symbol(arg2_val)); + + if ((sc->do_body_p == expr) && (is_complex_vector(obj)) && (is_pair(arg3)) && + (car(arg3) == sc->complex_symbol) && (car(expr) == sc->complex_vector_set_symbol)) + { + if (q_func1_arg(opc).q_func(o1).p_pp_f == complex_p_pp) /* same as below but (complex d d)?? d float */ + q_func1_arg(opc).q_func(o1).p_pp_f = complex_p_pp_wrapped; + else + if (q_func1_arg(opc).q_func(o1).p_dd_f == complex_p_dd) /* same below but (complex d 1.0), d float stepper */ + q_func1_arg(opc).q_func(o1).p_dd_f = complex_p_dd_wrapped; + else + if (q_func1_arg(opc).q_func(o1).p_ii_f == complex_p_ii) /* (complex-vector-set! cv1 i (complex i i)) */ + q_func1_arg(opc).q_func(o1).p_ii_f = complex_p_ii_wrapped; + } + return_true(sc, expr); + } + sc->pc = start; + }} + if ((is_proper_quote(sc, arg2)) && + (is_symbol(arg3))) + { + const s7_pointer val_slot = opt_simple_symbol(sc, arg3); + if (val_slot) + { + q_arg2(opc).p = cadr(arg2); + q_arg3(opc).p = val_slot; + q_call(opc).fp = opt_p_ppp_scs; + if ((is_let(obj)) && (q_func(opc).p_ppp_f == let_set_2) && (is_symbol(cadr(arg2)))) + use_pps_slot_set(sc, opc, obj, cadr(arg2), val_slot); + return_true(sc, expr); + }} + o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(expr))) + { + opt_info *o2 = sc->opts[sc->pc]; + if (is_symbol(arg3)) + { + const s7_pointer val_slot = opt_simple_symbol(sc, arg3); + if (val_slot) + { + q_arg2(opc).p = val_slot; + q_call(opc).fp = opt_p_ppp_sfs; /* hset case goes through the case below */ + q_func1_arg(opc).o1 = o1; + q_func1(opc).fp = q_call(o1).fp; + return_true(sc, expr); + }} + if ((!is_pair(arg3)) && (is_let(obj)) && (is_quoted_symbol(sc, arg2)) && + (q_func(opc).p_ppp_f == let_set_2) && /* (let-set! L3 'x 0) */ + (use_ppc_slot_set(sc, opc, obj, cadr(arg2), arg3))) + return_true(sc, expr); + + if (cell_optimize(sc, cdddr(expr))) + { + if ((is_let(obj)) && (is_quoted_symbol(sc, arg2)) && (q_func(opc).p_ppp_f == let_set_2) && /* (let-set! L3 'x (+ (L3 'x) 1)) */ + (use_ppf_slot_set(sc, opc, obj, cadr(arg2)))) + { + q_func1_arg(opc).o1 = o2; + q_func1(opc).fp = q_func1_arg(opc).q_call(o1).fp; + return_true(sc, expr); + } + q_call(opc).fp = opt_p_ppp_sff; + q_func2_arg(opc).o1 = o1; + q_func2(opc).fp = q_call(o1).fp; + q_func3_arg(opc).o1 = o2; + q_func3(opc).fp = q_call(o2).fp; + return_true(sc, expr); + }}} + else /* arg1 not symbol */ + { + q_func2_arg(opc).o1 = sc->opts[start]; + if (cell_optimize(sc, cdr(expr))) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(expr))) + { + q_func1_arg(opc).o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdddr(expr))) + { + q_call(opc).fp = opt_p_ppp_fff; + q_func2(opc).fp = q_func2_arg(opc).q_call(o1).fp; + q_func3(opc).fp = q_func3_arg(opc).q_call(o1).fp; + q_func1(opc).fp = q_func1_arg(opc).q_call(o1).fp; + if ((q_func(opc).p_ppp_f == list_p_ppp) && + (q_func1(opc).fp == opt_p_c) && (q_func3(opc).fp == opt_p_c) && (q_func2(opc).fp == opt_p_c)) + { + q_call(opc).fp = opt_list_3c; + q_arg1(opc).p = q_func2_arg(opc).q_arg1(o1).p; + q_arg2(opc).p = q_func3_arg(opc).q_arg1(o1).p; + q_arg3(opc).p = q_func1_arg(opc).q_arg1(o1).p; + } + return_true(sc, expr); + }}}} + sc->pc = start; + return_false(sc, expr); +} + +/* -------- p_call_ppp -------- */ +static s7_pointer opt_p_call_sss(opt_info *o) +{ + return(q_func(o).call(o->sc, set_plist_3(o->sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p), slot_value(q_arg3(o).p)))); +} + +static s7_pointer opt_p_call_ccs(opt_info *o) +{ + return(q_func(o).call(o->sc, set_plist_3(o->sc, q_arg1(o).p, q_arg2(o).p, slot_value(q_arg3(o).p)))); +} + +static s7_pointer opt_p_call_scs(opt_info *o) +{ + return(q_func(o).call(o->sc, set_plist_3(o->sc, slot_value(q_arg1(o).p), q_arg2(o).p, slot_value(q_arg3(o).p)))); +} + +static s7_pointer opt_p_call_css(opt_info *o) +{ + return(q_func(o).call(o->sc, set_plist_3(o->sc, q_arg1(o).p, slot_value(q_arg2(o).p), slot_value(q_arg3(o).p)))); +} + +static s7_pointer opt_p_call_ssf(opt_info *o) +{ + return(q_func(o).call(o->sc, set_plist_3(o->sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p), q_p_func1_call(o)))); +} + +static s7_pointer opt_p_call_ppp(opt_info *o) +{ + s7_pointer result; + s7_scheme *sc = o->sc; + gc_protect_2_via_stack_no_let(sc, q_p_func1_call(o), q_p_func3_call(o)); + result = q_p_func2_call(o); /* not combinable into next */ + result = q_func(o).call(sc, set_plist_3(sc, gc_protected1(sc), gc_protected2(sc), result)); + if (stack_top_op(sc) == OP_GC_PROTECT) unstack_gc_protect(sc); + return(result); +} + +static bool p_call_ppp_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) +{ + const int32_t start = sc->pc; + if ((is_safe_procedure(s_func)) && (c_function_is_aritable(s_func, 3)) && + (s_func != global_value(sc->hash_table_ref_symbol)) && (s_func != global_value(sc->list_ref_symbol))) + { + const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr), arg3 = cadddr(expr); + opt_info *o1 = sc->opts[sc->pc]; + + if (!is_pair(arg1)) + { + if (is_normal_symbol(arg1)) + { + const s7_pointer arg1_slot = opt_simple_symbol(sc, arg1); + if (arg1_slot) + { + q_arg1(opc).p = arg1_slot; + if ((s_func == global_value(sc->vector_ref_symbol)) && + (is_t_vector(slot_value(arg1_slot))) && (vector_rank(slot_value(arg1_slot)) != 2)) + return_false(sc, expr); + /* arg1 ok as symbol */ + if ((is_code_constant(sc, arg2)) && (is_normal_symbol(arg3))) + { + const s7_pointer val_slot = opt_simple_symbol(sc, arg3); + if (val_slot) + { + q_arg2(opc).p = arg2; + q_arg3(opc).p = val_slot; + q_func(opc).call = cf_call(sc, expr, s_func, 3); + if ((sc->do_body_p == expr) && (arg1 == sc->F) && (car(expr) == sc->format_symbol)) + q_func(opc).call = g_format_nr; + q_call(opc).fp = opt_p_call_scs; + return_true(sc, expr); + }}} + else return_false(sc, expr); /* no need for sc->pc = start here, I think */ + } + else + { + if ((is_code_constant(sc, arg1)) && (is_code_constant(sc, arg2)) && (is_normal_symbol(arg3))) + { + const s7_pointer val_slot = opt_simple_symbol(sc, arg3); + if (val_slot) + { + q_arg1(opc).p = arg1; + q_arg2(opc).p = (is_pair(arg2)) ? cadr(arg2) : arg2; + q_arg3(opc).p = val_slot; + q_func(opc).call = cf_call(sc, expr, s_func, 3); + if ((sc->do_body_p == expr) && (arg1 == sc->F) && (car(expr) == sc->format_symbol)) + q_func(opc).call = g_format_nr; + q_call(opc).fp = opt_p_call_ccs; + return_true(sc, expr); + }} + q_arg1(opc).p = arg1; + if (s_func == global_value(sc->vector_ref_symbol)) + return_false(sc, expr); + } + if (is_normal_symbol(arg2)) + { + const s7_pointer arg2_slot = opt_simple_symbol(sc, arg2); + if (arg2_slot) + { + q_arg2(opc).p = arg2_slot; + if (is_normal_symbol(arg3)) + { + const s7_pointer arg3_slot = opt_simple_symbol(sc, arg3); + if (arg3_slot) + { + q_arg3(opc).p = arg3_slot; + q_func(opc).call = cf_call(sc, expr, s_func, 3); + q_call(opc).fp = (is_slot(q_arg1(opc).p)) ? opt_p_call_sss : opt_p_call_css; + return_true(sc, expr); + }} + else + if (is_slot(q_arg1(opc).p)) + { + const int32_t start1 = sc->pc; + if ((cf_call(sc, expr, s_func, 3) == g_substring_uncopied) && + (is_t_integer(slot_value(q_arg2(opc).p))) && + (is_string(slot_value(q_arg1(opc).p))) && + (int_optimize(sc, cdddr(expr)))) + { + q_call(opc).fp = opt_p_substring_uncopied_ssf; + q_func1_arg(opc).o1 = o1; + q_func1(opc).fi = q_call(o1).fi; + return_true(sc, expr); + } + sc->pc = start1; + if (cell_optimize(sc, cdddr(expr))) + { + q_func(opc).call = cf_call(sc, expr, s_func, 3); + q_call(opc).fp = opt_p_call_ssf; + q_func1_arg(opc).o1 = o1; + q_func1(opc).fp = q_call(o1).fp; + return_true(sc, expr); + }}}}} + if (s_func == global_value(sc->vector_ref_symbol)) return_false(sc, expr); + if (cell_optimize(sc, cdr(expr))) + { + opt_info *o2 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(expr))) + { + opt_info *o3 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdddr(expr))) + { + q_func(opc).call = cf_call(sc, expr, s_func, 3); + q_call(opc).fp = opt_p_call_ppp; + q_func1_arg(opc).o1 = o1; + q_func1(opc).fp = q_call(o1).fp; + q_func3_arg(opc).o1 = o2; + q_func3(opc).fp = q_call(o2).fp; + q_func2_arg(opc).o1 = o3; + q_func2(opc).fp = q_call(o3).fp; + return_true(sc, expr); + }}}} + sc->pc = start; + return_false(sc, expr); +} + +/* -------- p_call_any -------- */ +#define p_call_o1 3 +#define q_p_call_f(o) o->v[2] +#define q_p_call_arg(o, i) o->v[i] + +static s7_pointer opt_p_call_any(opt_info *o) +{ + s7_scheme *sc = o->sc; + s7_pointer val = safe_list_if_possible(sc, q_arg1(o).i); + s7_pointer arg = val; + if (in_heap(val)) gc_protect_via_stack_no_let(sc, val); + for (s7_int i = 0; i < q_arg1(o).i; i++, arg = cdr(arg)) + { + opt_info *o1 = q_p_call_arg(o, i + p_call_o1).o1; + set_car(arg, q_call(o1).fp(o1)); + } + arg = q_p_call_f(o).call(sc, val); + if (in_heap(val)) unstack_gc_protect(sc); + else clear_safe_list_in_use(sc, val); + return(arg); +} + +static s7_pointer opt_p_call_4g(opt_info *o) +{ + s7_scheme *sc = o->sc; + opt_info *o1 = q_p_call_arg(o, 0 + p_call_o1).o1; + opt_info *o2 = q_p_call_arg(o, 1 + p_call_o1).o1; + opt_info *o3 = q_p_call_arg(o, 2 + p_call_o1).o1; + opt_info *o4 = q_p_call_arg(o, 3 + p_call_o1).o1; + return(q_p_call_f(o).call(o->sc, set_plist_4(sc, q_call(o1).fp(o1), q_call(o2).fp(o2), q_call(o3).fp(o3), q_call(o4).fp(o4)))); +} + +static bool p_call_any_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr, int32_t len) +{ + if ((len < (num_vunions - p_call_o1)) && + (is_safe_procedure(s_func)) && + (c_function_is_aritable(s_func, len - 1))) + { + bool safe = true; + s7_pointer p = cdr(expr); /* (vector-set! v k i 2) gets here, as does (float-vector-set! v k i n (+ 0.0 i3 k3 n)) from tvect */ + q_arg1(opc).i = (len - 1); /* also ccff in cb.scm I think */ + for (int32_t pctr = p_call_o1; is_pair(p); pctr++, p = cdr(p)) + { + q_p_call_arg(opc, pctr).o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) break; + if (is_pair(car(p))) safe = false; + } + if (is_null(p)) + { + q_call(opc).fp = ((len == 5) && (safe)) ? opt_p_call_4g : opt_p_call_any; + q_p_call_f(opc).call = cf_call(sc, expr, s_func, len - 1); + return_true(sc, expr); + }} + return_false(sc, expr); +} + +/* -------- p_fx_any -------- */ + +static s7_pointer opt_p_fx_any(opt_info *o) {return(q_func(o).call(o->sc, q_arg1(o).p));} +static void fx_annotate_arg(s7_scheme *sc, s7_pointer arg, s7_pointer let_or_list); + +static bool p_fx_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer expr) +{ + s7_function func = ((is_pair(car(expr))) && (has_fx(car(expr)))) ? fx_proc(car(expr)) : NULL; +#if 0 + /* this is slower! -- fx choices are pessimal here */ + if ((!func) && (is_fxable(sc, car(expr)))) {fx_annotate_arg(sc, expr, sc->curlet); if (has_fx(expr)) func = fx_proc(expr);} +#endif + if (!func) return_false(sc, expr); + q_call(opc).fp = opt_p_fx_any; + q_func(opc).call = func; + q_arg1(opc).p = car(expr); + return_true(sc, expr); +} + +/* -------- p_implicit -------- */ + +static bool p_implicit_ok(s7_scheme *sc, s7_pointer s_slot, s7_pointer expr, int32_t len) +{ + const s7_pointer obj = slot_value(s_slot); + const s7_pointer arg1 = (len > 1) ? cadr(expr) : sc->F; + opt_info *opc; + int32_t start; + + if ((!is_simple_sequence(obj)) || (len < 2)) /* was is_sequence? */ + return_false(sc, expr); + + opc = alloc_opt_info(sc); + q_arg1(opc).p = s_slot; + start = sc->pc; + if (len == 2) + { + switch (type(obj)) + { + case T_PAIR: q_func(opc).p_pi_f = list_ref_p_pi_unchecked; break; + case T_HASH_TABLE: q_func(opc).p_pp_f = s7_hash_table_ref; break; + case T_LET: q_func(opc).p_pp_f = let_ref; break; + case T_STRING: q_func(opc).p_pi_f = string_ref_p_pi_unchecked; break; + case T_C_OBJECT: return_false(sc, expr); /* no pi_ref because ref assumes pp */ + + case T_VECTOR: + if (vector_rank(obj) != 1) + return_false(sc, expr); + q_func(opc).p_pi_f = t_vector_ref_p_pi_unchecked; + break; + + case T_BYTE_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_COMPLEX_VECTOR: + if (vector_rank(obj) != 1) + return_false(sc, expr); + q_func(opc).p_pi_f = vector_ref_p_pi_unchecked; + break; + + default: + return_false(sc, expr); + } + /* now v3.p_pi|pp.f is set */ + if (is_symbol(arg1)) + { + const s7_pointer arg1_slot = s7_slot(sc, arg1); /* not the desired slot if let+keyword, see below */ + if (is_slot(arg1_slot)) + { + q_arg2(opc).p = arg1_slot; + if ((!is_hash_table(obj)) && /* these because opt_int below */ + (!is_let(obj))) + { + if (!is_t_integer(slot_value(arg1_slot))) + return_false(sc, expr); /* I think this reflects that a non-int index is an error for list-ref et al */ + q_call(opc).fp = opt_p_pi_ss; /* TODO: this now uses 1/2 not 2/1 */ + if (has_loop_end(q_arg2(opc).p)) + check_unchecked(sc, obj, q_arg2(opc).p, opc, NULL); + fixup_p_pi_ss(opc); + return_true(sc, expr); + } + q_call(opc).fp = ((is_hash_table(obj)) && (q_func(opc).p_pp_f == s7_hash_table_ref)) ? opt_p_pp_ss_href : + (((is_let(obj)) && (q_func(opc).p_pp_f == let_ref)) ? opt_p_pp_ss_lref : opt_p_pp_ss); + if ((q_call(opc).fp == opt_p_pp_ss_lref) && (is_keyword(arg1))) + use_slot_ref(sc, opc, obj, keyword_symbol(arg1)); /* if keyword, slot is: (L3 :x) -> # */ + return_true(sc, expr); + }} + else /* arg1 not a symbol */ + { + if ((!is_hash_table(obj)) && (!is_let(obj))) + { + opt_info *o1; + if (is_t_integer(arg1)) + { + q_arg2(opc).i = integer(arg1); + q_call(opc).fp = opt_p_pi_sc; + return_true(sc, expr); + } + o1 = sc->opts[sc->pc]; + if (!int_optimize(sc, cdr(expr))) + return_false(sc, expr); + q_call(opc).fp = opt_p_pi_sf; + q_func1_arg(opc).o1 = o1; + q_func1(opc).fi = q_call(o1).fi; + return_true(sc, expr); + } + if ((!is_pair(arg1)) || + (is_proper_quote(sc, arg1))) + { + q_arg2(opc).p = (!is_pair(arg1)) ? arg1 : cadr(arg1); + q_call(opc).fp = opt_p_pp_sc; + if ((is_pair(arg1)) && (is_symbol(q_arg2(opc).p)) && (is_let(obj)) && (q_func(opc).p_pp_f == let_ref)) + use_slot_ref(sc, opc, obj, cadr(arg1)); + return_true(sc, expr); + } + if (cell_optimize(sc, cdr(expr))) + { /* need both type check and func check! (hash-table-ref or 123) */ + q_call(opc).fp = ((is_hash_table(obj)) && (q_func(opc).p_pp_f == s7_hash_table_ref)) ? opt_p_pp_sf_href : + (((is_let(obj)) && (q_func(opc).p_pp_f == let_ref)) ? opt_p_pp_sf_lref : opt_p_pp_sf); + q_func1_arg(opc).o1 = sc->opts[start]; + q_func1(opc).fp = q_call(sc->opts[start]).fp; + return_true(sc, expr); + }}} /* len==2 */ + else + { /* len > 2 */ + if ((is_t_vector(obj)) && (len == 3) && (vector_rank(obj) == 2)) + { + const s7_pointer arg2_slot = opt_integer_symbol(sc, caddr(expr)); + if (arg2_slot) + { + s7_pointer arg1_slot; + q_arg3(opc).p = arg2_slot; + arg1_slot = opt_integer_symbol(sc, arg1); + if (arg1_slot) + { + q_arg2(opc).p = arg1_slot; + q_func(opc).p_pii_f = vector_ref_p_pii; + q_call(opc).fp = opt_p_pii_sss; + if ((loop_end_fits(q_arg2(opc).p, vector_dimension(obj, 0))) && + (loop_end_fits(q_arg3(opc).p, vector_dimension(obj, 1)))) + q_call(opc).fp = vector_ref_pii_sss_unchecked; + return_true(sc, expr); + }} + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(expr))) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + q_call(opc).fp = opt_p_pii_sff; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func3(opc).fi = q_func3_arg(opc).q_call(o1).fi; + q_func(opc).p_pii_f = vector_ref_p_pii_direct; + return_true(sc, expr); + }} + sc->pc = start; + } + + #define P_IMPLICIT_CALL_O1 4 + if (len < (num_vunions - P_IMPLICIT_CALL_O1)) /* mimic p_call_any_ok */ + { + s7_pointer p = expr; + q_arg1(opc).i = len; + for (int32_t pctr = (P_IMPLICIT_CALL_O1 - 1); is_pair(p); pctr++, p = cdr(p)) + { + q_p_call_arg(opc, pctr).o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) + break; + } + if (is_null(p)) + { + /* 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, + * but this is called very rarely mainly because hi-rank implicit refs are rare, and check_type_uncertainty is unhappy + * if there are multiple sets of a var. + * hash-tables, lets, lists, and vectors with extra (implicit) args can't be handled because we have no way to tell + * what the implicit call will do, and in the opt_* context, everything must be "safe" (i.e. no defines or + * hidden multiple-values, etc). + */ + if ((!is_any_vector(obj)) || (vector_rank(obj) != (len - 1))) return_false(sc, expr); /* (* i (P2 1 1)) in timp.scm where P2 is a list */ + q_call(opc).fp = opt_p_call_any; + switch (type(obj)) /* string can't happen here (no multidimensional strings), for pair/hash/let see above */ + { + case T_INT_VECTOR: q_p_call_f(opc).call = g_int_vector_ref; break; + case T_BYTE_VECTOR: q_p_call_f(opc).call = g_byte_vector_ref; break; + case T_FLOAT_VECTOR: q_p_call_f(opc).call = g_float_vector_ref; break; + case T_COMPLEX_VECTOR: q_p_call_f(opc).call = g_complex_vector_ref; break; + case T_VECTOR: q_p_call_f(opc).call = g_vector_ref; break; + default: return_false(sc, expr); + } + return_true(sc, expr); + }}} + return_false(sc, expr); +} + +/* -------- cell_quote -------- */ +static bool opt_cell_quote(s7_scheme *sc, s7_pointer expr) +{ + opt_info *opc; + if (!is_null(cddr(expr))) return_false(sc, expr); + opc = alloc_opt_info(sc); + q_arg1(opc).p = cadr(expr); + q_call(opc).fp = opt_p_c; + return_true(sc, expr); +} + +/* -------- cell_set -------- */ +static s7_pointer opt_set_p_p_f(opt_info *o) +{ + s7_pointer val = q_p_func1_call(o); + slot_set_value(q_arg1(o).p, val); + return(val); +} + +static s7_pointer opt_set_p_p_f_with_setter(opt_info *o) +{ + s7_pointer val = q_p_func1_call(o); + call_c_function_setter(o->sc, slot_setter(q_arg1(o).p), slot_symbol(q_arg1(o).p), val); + slot_set_value(q_arg1(o).p, val); + return(val); +} + +static s7_pointer opt_set_input_port_string_p_p_f(opt_info *o) +{ + s7_pointer val = q_p_func1_call(o); /* the string */ + s7_pointer port = slot_value(q_arg2(o).p); + if (!is_input_port(port)) wrong_type_error_nr(o->sc, o->sc->port_string_symbol, 1, port, an_input_port_string); + set_input_port_string(o->sc, port, val); + return(val); +} + +static s7_pointer opt_set_output_port_string_p_p_f(opt_info *o) +{ + s7_pointer val = q_p_func1_call(o); /* the string */ + s7_pointer port = slot_value(q_arg2(o).p); + if (!is_output_port(port)) wrong_type_error_nr(o->sc, o->sc->port_string_symbol, 1, port, an_input_port_string); + set_output_port_string(o->sc, port, val); + return(val); +} + +static s7_pointer opt_set_p_i_s(opt_info *o) +{ + s7_pointer val = slot_value(q_arg2(o).p); + if (is_mutable_integer(val)) + val = make_integer(o->sc, integer(val)); + slot_set_value(q_arg1(o).p, val); + return(val); +} + +static s7_pointer opt_set_p_i_f(opt_info *o) +{ + s7_pointer val = make_integer(o->sc, q_i_func1_call(o)); + slot_set_value(q_arg1(o).p, val); + return(val); +} +/* here and below (opt_set_p_d_f), the mutable versions are not safe, and are very tricky to make safe. First if a variable is set twice, + * in the body, as in (do (...) (... (set! buffix (+ 1 buffix)) (if (>= buffix fftsize) (set! buffix 0)))) from pvoc.scm, + * if the first set! is opt_set_p_i_fm (see tmp) (buffix is assumed mutable), the second sets it to built-in immutable zero, so the next time around loop, + * the set_integer is direct so now built-in 0 == 128 (yet still prints itself as "0"). Also if a mutable variable is stored, + * (define (f2) (let ((v (vector 0 0 0)) (y 1.0)) (do ((i 0 (+ i 1))) ((= i 3) v) (set! y (+ y 1.0)) (vector-set! v i y)))) + * (f2) -> #(4.0 4.0 4.0). Maybe safe if body has just one statement? + */ + +static s7_pointer opt_set_p_d_s(opt_info *o) +{ + s7_pointer val = slot_value(q_arg2(o).p); + if (is_mutable_number(val)) + val = make_real(o->sc, real(val)); + slot_set_value(q_arg1(o).p, val); + return(val); +} + +static s7_pointer opt_set_p_d_f(opt_info *o) +{ + s7_pointer val = make_real(o->sc, q_d_func1_call(o)); + slot_set_value(q_arg1(o).p, val); + return(val); +} + +static s7_pointer opt_set_p_d_f_sf_add(opt_info *o) +{ + s7_pointer val = make_real(o->sc, opt_d_dd_sf_add(q_func1_arg(o).o1)); + slot_set_value(q_arg1(o).p, val); + return(val); +} + +static s7_pointer opt_set_p_d_fm_sf_add(opt_info *o) +{ + s7_double x1 = opt_d_dd_sf_add(q_func1_arg(o).o1); + check_mutability(o->sc, o, __func__, __LINE__); + set_real(slot_value(q_arg1(o).p), x1); + return(slot_value(q_arg1(o).p)); +} + +static s7_pointer opt_set_p_d_f_mm_add(opt_info *o) /* see set_p_d_f_combinable below, tfft for both */ +{ + s7_double x1 = float_vector_ref_d_7pi(o->sc, slot_value(q_arg2(o).p), integer(slot_value(q_arg3(o).p))) * real(slot_value(q_arg1(o).p)); + s7_double x2 = float_vector_ref_d_7pi(o->sc, slot_value(q_func2_arg(o).p), integer(slot_value(q_func3_arg(o).p))) * real(slot_value(q_arg4(o).p)); + slot_set_value(q_arg1(o).p, make_real(o->sc, x1 + x2)); + return(slot_value(q_arg1(o).p)); +} + +static s7_pointer opt_set_p_d_f_mm_subtract(opt_info *o) +{ + s7_double x1 = float_vector_ref_d_7pi(o->sc, slot_value(q_arg2(o).p), integer(slot_value(q_arg3(o).p))) * real(slot_value(q_arg1(o).p)); + s7_double x2 = float_vector_ref_d_7pi(o->sc, slot_value(q_func2_arg(o).p), integer(slot_value(q_func3_arg(o).p))) * real(slot_value(q_arg4(o).p)); + slot_set_value(q_arg1(o).p, make_real(o->sc, x1 - x2)); + return(slot_value(q_arg1(o).p)); +} + +static s7_pointer opt_set_p_c(opt_info *o) +{ + slot_set_value(q_arg1(o).p, q_arg2(o).p); + return(q_arg2(o).p); +} + +static s7_pointer opt_set_p_i_fo(opt_info *o) +{ + s7_int i = q_func(o).i_ii_f(integer(slot_value(q_arg2(o).p)), integer(slot_value(q_arg3(o).p))); + s7_pointer val = make_integer(o->sc, i); + slot_set_value(q_arg1(o).p, val); + return(val); +} + +static s7_pointer opt_set_p_i_fo_add(opt_info *o) +{ + s7_int i = integer(slot_value(q_arg2(o).p)) + integer(slot_value(q_arg3(o).p)); + s7_pointer val = make_integer(o->sc, i); + slot_set_value(q_arg1(o).p, val); + return(val); +} + +static s7_pointer opt_set_p_i_fo1(opt_info *o) +{ + s7_int i = q_func(o).i_ii_f(integer(slot_value(q_arg2(o).p)), q_arg3(o).i); + s7_pointer val = make_integer(o->sc, i); + slot_set_value(q_arg1(o).p, val); + return(val); +} + +static s7_pointer opt_set_p_i_fo1_add(opt_info *o) +{ + s7_int i = integer(slot_value(q_arg2(o).p)) + q_arg3(o).i; + s7_pointer val = make_integer(o->sc, i); + slot_set_value(q_arg1(o).p, val); + return(val); +} + +static bool set_p_i_f_combinable(s7_scheme *sc, opt_info *opc) +{ + /* arg1 is set already */ + if ((sc->pc > 1) && + (opc == sc->opts[sc->pc - 2])) + { + opt_info *o1 = sc->opts[sc->pc - 1]; + if ((q_call(o1).fi == opt_i_ii_ss) || + (q_call(o1).fi == opt_i_ii_ss_add)) + { + q_func(opc).i_ii_f = q_func(o1).i_ii_f; + q_arg2(opc).p = q_arg1(o1).p; + q_arg3(opc).p = q_arg2(o1).p; + q_call(opc).fp = (q_call(o1).fi == opt_i_ii_ss_add) ? opt_set_p_i_fo_add : opt_set_p_i_fo; + backup_pc(sc); + return_true(sc, NULL); + } + if ((q_call(o1).fi == opt_i_ii_sc) || (q_call(o1).fi == opt_i_ii_sc_add) || (q_call(o1).fi == opt_i_ii_sc_sub)) + { + q_func(opc).i_ii_f = q_func(o1).i_ii_f; + q_arg2(opc).p = q_arg1(o1).p; + q_arg3(opc).i = q_arg2(o1).i; + q_call(opc).fp = (q_call(o1).fi == opt_i_ii_sc_add) ? opt_set_p_i_fo1_add : opt_set_p_i_fo1; + /* opt_if_nbp: opt_set_p_i_fo1_add b/shoot */ + backup_pc(sc); + return_true(sc, NULL); + }} + 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 ((q_call(o1).fd == opt_d_mm_fff) && + ((q_func(o1).d_dd_f == add_d_dd) || (q_func(o1).d_dd_f == subtract_d_dd))) + { + opt_info *o2 = sc->opts[sc->pc - 2]; + q_call(opc).fp = (q_func(o1).d_dd_f == add_d_dd) ? opt_set_p_d_f_mm_add : opt_set_p_d_f_mm_subtract; + q_arg1(opc).p = q_arg1(o2).p; + q_arg2(opc).p = q_arg2(o2).p; + q_arg3(opc).p = q_arg3(o2).p; + o1 = sc->opts[sc->pc - 1]; + q_arg4(opc).p = q_arg1(o1).p; + q_func2_arg(opc).p = q_arg2(o1).p; + q_func3_arg(opc).p = q_arg3(o1).p; + sc->pc -= 3; + return_true(sc, NULL); + }} + return_false(sc, NULL); +} + +static bool is_some_number(s7_scheme *sc, const 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_byte_symbol) || + (tp == sc->is_rational_symbol)); +} + +static bool check_type_uncertainty(s7_scheme *sc, s7_pointer target, s7_pointer expr, opt_info *opc, int32_t start_pc) +{ + const s7_pointer code = sc->code; + /* if we're optimizing do, sc->code is (sometimes) ((vars...) (end...) expr) where expr 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-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 expr -- tree_memq below for reality check */ + (is_pair(cadr(code)))) + { + s7_int counts; + if ((!has_low_count(code)) && /* only set below */ + (s7_tree_memq(sc, expr, code))) + { + if (is_pair(caar(code))) + { + counts = tree_count(sc, target, car(code), 0) + + tree_count(sc, target, caadr(code), 0) + + tree_count(sc, target, cddr(code), 0); + for (s7_pointer vars = car(code); is_pair(vars); vars = cdr(vars)) + { + const s7_pointer binding = car(vars); + if ((is_proper_list_2(sc, binding)) && + (car(binding) == 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_low_count(code); + sc->pc = start_pc; + if (cell_optimize(sc, cddr(expr))) + { + /* fprintf(stderr, "%d: %s %s\n", __LINE__, display(expr), display(target)); */ + q_call(opc).fp = opt_set_p_p_f; + q_func1_arg(opc).o1 = sc->opts[start_pc]; + q_func1(opc).fp = q_call(sc->opts[start_pc]).fp; + return_true(sc, expr); + }}} + return_false(sc, expr); +} + +static s7_pointer opt_starlet_set(opt_info *o) +{ + s7_pointer val = q_func(o).fp(q_arg2(o).o1); + return(starlet_set_1(o->sc, q_arg1(o).p, val)); +} + +static s7_pointer opt_starlet_set_i(opt_info *o) +{ + return(starlet_set_1(o->sc, q_arg1(o).p, q_arg2(o).p)); +} + +static s7_pointer list_increment_p_pip_unchecked(opt_info *o) +{ + s7_scheme *sc = o->sc; + s7_pointer num = slot_value(q_arg2(o).p), lst, p; + s7_int index = integer(num); + if ((index < 0) || (index > sc->max_list_length)) list_set_index_check_nr(sc, index); + lst = slot_value(q_arg1(o).p); + p = lst; + for (s7_int i = 0; ((is_pair(p)) && (i < index)); i++, p = cdr(p)); + if (!is_pair(p)) + { + if (is_null(p)) + out_of_range_error_nr(sc, sc->list_set_symbol, int_two, wrap_integer(sc, index), it_is_too_large_string); + wrong_type_error_nr(sc, sc->list_set_symbol, 1, lst, a_proper_list_string); + } + { + s7_pointer value = g_add_xi(sc, car(p), integer(q_arg3(o).p), index); + set_car(p, value); + return(value); + } +} + +static bool opt_cell_set(s7_scheme *sc, s7_pointer expr) /* len == 3 here (p_syntax_ok) */ +{ + opt_info *opc = alloc_opt_info(sc); + const s7_pointer target = cadr(expr); + const s7_pointer value = caddr(expr); + if (OPT_PRINT) fprintf(stderr, " opt_cell_set[%d]: %s, target: %s\n", __LINE__, display(expr), display(target)); + if (is_symbol(target)) + { + s7_pointer settee; + if ((is_constant_symbol(sc, target)) || + ((is_slot(global_slot(target))) && (slot_has_setter(global_slot(target))))) + return_false(sc, expr); + + settee = s7_slot(sc, target); + if ((is_slot(settee)) && + (!is_immutable_slot(settee)) && + (!is_syntax(slot_value(settee)))) + { + const int32_t start_pc = sc->pc; + const s7_pointer stype = s7_type_of(sc, slot_value(settee)); + s7_pointer atype; + q_arg1(opc).p = settee; + if (slot_has_setter(settee)) + { + if ((is_c_function(slot_setter(settee))) && + (is_bool_function(slot_setter(settee))) && + (stype == opt_arg_type(sc, cddr(expr))) && + (cell_optimize(sc, cddr(expr)))) + { + q_call(opc).fp = opt_set_p_p_f_with_setter; + q_func1_arg(opc).o1 = sc->opts[start_pc]; + q_func1(opc).fp = q_call(sc->opts[start_pc]).fp; + return_true(sc, expr); + } + return_false(sc, expr); + } + if (stype == sc->is_integer_symbol) + { + if (is_symbol(value)) + { + const s7_pointer val_slot = opt_integer_symbol(sc, value); + if (val_slot) + { + q_arg2(opc).p = val_slot; + q_call(opc).fp = opt_set_p_i_s; + return_true(sc, expr); + }} + else + { + q_func1_arg(opc).o1 = sc->opts[sc->pc]; + if (!int_optimize(sc, cddr(expr))) + return(check_type_uncertainty(sc, target, expr, opc, start_pc)); + if (!set_p_i_f_combinable(sc, opc)) + { + q_call(opc).fp = opt_set_p_i_f; + q_func1(opc).fi = q_func1_arg(opc).q_call(o1).fi; + } + return_true(sc, expr); + } + return_false(sc, expr); + } + if (stype == sc->is_float_symbol) + { + if (is_t_real(value)) + { + q_arg2(opc).p = value; + q_call(opc).fp = opt_set_p_c; + return_true(sc, expr); + } + if (is_symbol(caddr(expr))) + { + const s7_pointer val_slot = opt_float_symbol(sc, value); + if (val_slot) + { + q_arg2(opc).p = val_slot; + q_call(opc).fp = opt_set_p_d_s; + return_true(sc, expr); + }} + else + { + if ((is_pair(value)) && + (float_optimize(sc, cddr(expr)))) + { + if (!set_p_d_f_combinable(sc, opc)) + { + q_func1_arg(opc).o1 = sc->opts[start_pc]; + q_func1(opc).fd = q_call(sc->opts[start_pc]).fd; + q_call(opc).fp = (q_func1(opc).fd == opt_d_dd_sf_add) ? opt_set_p_d_f_sf_add : opt_set_p_d_f; + } + return_true(sc, expr); + } + return(check_type_uncertainty(sc, target, expr, opc, start_pc)); + } + return_false(sc, expr); + } + atype = opt_arg_type(sc, cddr(expr)); + if ((is_some_number(sc, atype)) && (!is_some_number(sc, stype))) + return_false(sc, expr); + if ((stype != atype) && + (is_symbol(stype)) && + (((t_sequence_p[symbol_type(stype)]) && + (stype != sc->is_null_symbol) && (stype != sc->is_pair_symbol) && + (stype != sc->is_list_symbol) && (stype != sc->is_proper_list_symbol)) || + (stype == sc->is_iterator_symbol))) + return_false(sc, expr); + /* TODO: here if atype is float? or integer? or boolean? we should call the appropriate optimizer! */ + if (cell_optimize(sc, cddr(expr))) + { + /* fprintf(stderr, "%d: %s %s %s %s\n", __LINE__, display(expr), display(target), display(atype), display(stype)); */ + q_call(opc).fp = opt_set_p_p_f; + q_func1_arg(opc).o1 = sc->opts[start_pc]; + q_func1(opc).fp = q_call(sc->opts[start_pc]).fp; + return_true(sc, expr); + }} + return_false(sc, expr); + } + 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 obj, index_type; + const s7_pointer index = cadr(target); + const s7_pointer obj_slot = s7_slot(sc, car(target)); + if (!is_slot(obj_slot)) return_false(sc, expr); + obj = slot_value(obj_slot); + q_arg1(opc).p = obj_slot; + + if (!is_mutable_sequence(obj)) /* includes *s7* because *s7* itself is immutable? */ + { + /* a ridiculous experiment... */ + if ((car(target) == sc->port_string_symbol) && + (is_eq_initial_c_function_data(car(target), obj)) && + (is_normal_symbol(index)) && + (opt_arg_type(sc, cddr(expr)) == sc->is_string_symbol)) + { + const s7_pointer port_type = opt_arg_type(sc, cdr(target)); + if ((port_type == sc->is_input_port_symbol) || (port_type == sc->is_output_port_symbol)) + { + const int32_t start_pc = sc->pc; + q_arg2(opc).p = s7_t_slot(sc, index); + if ((is_slot(q_arg2(opc).p)) && (is_string_port(slot_value(q_arg2(opc).p))) && (cell_optimize(sc, cddr(expr)))) + { + q_func1_arg(opc).o1 = sc->opts[start_pc]; + q_func1(opc).fp = q_call(sc->opts[start_pc]).fp; + q_call(opc).fp = (port_type == sc->is_input_port_symbol) ? opt_set_input_port_string_p_p_f : opt_set_output_port_string_p_p_f; + return_true(sc, expr); + }}} + if (obj == sc->starlet) /* *s7* is open (for let_set_fallback?) */ + { + if ((is_symbol_and_keyword(index)) || (is_quoted_symbol(sc, index))) + { + s7_pointer sym = (is_quoted_symbol(sc, index)) ? cadr(index) : keyword_symbol(index); + if (starlet_symbol_id(sym) != sl_no_field) + { + q_arg1(opc).p = sym; + if (is_t_integer(caddr(expr))) + { + q_call(opc).fp = opt_starlet_set_i; + q_arg2(opc).p = caddr(expr); + return_true(sc, expr); + } + q_arg2(opc).o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(expr))) + { + q_call(opc).fp = opt_starlet_set; + q_func(opc).fp = q_arg2(opc).q_call(o1).fp; /* TODO: fix this! */ + return_true(sc, expr); + }}}} + return_false(sc, expr); + } + index_type = opt_arg_type(sc, cdr(target)); + switch (type(obj)) + { + case T_STRING: + { + s7_pointer val_type; + if ((index_type != sc->is_integer_symbol) || (is_pair(cddr(target)))) return_false(sc, expr); + val_type = opt_arg_type(sc, cddr(expr)); + if (val_type != sc->is_char_symbol) + return_false(sc, expr); + q_func(opc).p_pip_f = string_set_p_pip_unchecked; + } + break; + + case T_VECTOR: + if (index_type != sc->is_integer_symbol) return_false(sc, expr); + if (is_null(cddr(target))) + { + if (vector_rank(obj) != 1) return_false(sc, expr); + q_func(opc).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, expr); + q_func(opc).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(expr), 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(expr))) + { + q_temp(opc).fd = q_call(opc).fd; + q_call(opc).fp = d_to_p; + return_true(sc, expr); + } + return_false(sc, expr); + + case T_COMPLEX_VECTOR: + if (index_type != sc->is_integer_symbol) return_false(sc, expr); + if (is_null(cddr(target))) + { + if (vector_rank(obj) != 1) return_false(sc, expr); + q_func(opc).p_pip_f = complex_vector_set_p_pip_unchecked; + } + else return_false(sc, expr); + break; + + 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(expr))) + { + q_temp(opc).fi = q_call(opc).fi; + q_call(opc).fp = i_to_p; + return_true(sc, expr); + } + return_false(sc, expr); + + 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 */ + const s7_d_7pid_t func = s7_d_7pid_function(c_object_setf(sc, obj)); + if (func) + { + const s7_pointer slot = opt_integer_symbol(sc, index); + q_func(opc).d_7pid_f = func; + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (slot) + { + if (float_optimize(sc, cddr(expr))) + { + q_temp(opc).fd = opt_d_7pid_ssf; + q_call(opc).fp = d_to_p; /* cell_optimize, so need to return s7_pointer */ + q_arg2(opc).p = slot; + q_func2(opc).fd = q_func2_arg(opc).q_call(o1).fd; + return_true(sc, expr); + }} + else + if (int_optimize(sc, cdr(target))) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(expr))) + { + q_temp(opc).fd = opt_d_7pid_sff; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func3(opc).fd = q_func3_arg(opc).q_call(o1).fd; + q_call(opc).fp = d_to_p; + return_true(sc, expr); + }}}} + return_false(sc, expr); + + case T_PAIR: + if (index_type != sc->is_integer_symbol) return_false(sc, expr); /* (let ((tf13 '(()))) (define (f) (do ((i 0 (+ i 1))) ((= i 1)) (set! (tf13 letrec*) 0))) (f)) */ + if (is_pair(cddr(target))) return_false(sc, expr); + q_func(opc).p_pip_f = list_set_p_pip_unchecked; + + { /* an experiment -- is this ever hit in normal code? (for tref.scm) */ + if ((is_pair(value)) && (car(value) == sc->add_symbol) && (is_pair(cdr(value))) && (is_pair(cadr(value))) && (is_pair(cddr(value))) && + (is_t_integer(caddr(value))) && (is_null(cdddr(value))) && (is_symbol(index)) && + (car(target) == (caadr(value))) && (is_pair(cdadr(value))) && (is_null(cddadr(value))) && (index == cadadr(value))) + { + const s7_pointer slot = opt_simple_symbol(sc, index); + if ((slot) && (is_t_integer(slot_value(slot)))) + { + q_arg2(opc).p = slot; + q_arg3(opc).p = caddr(value); + q_call(opc).fp = list_increment_p_pip_unchecked; + return_true(sc, expr); + }}} + break; + + case T_HASH_TABLE: + if (is_pair(cddr(target))) return_false(sc, expr); + q_func(opc).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))) || (is_openlet(obj))) + return_false(sc, expr); + if ((is_symbol_and_keyword(index)) || + ((is_quoted_symbol(sc, index)))) + q_func(opc).p_ppp_f = let_set_1; + else q_func(opc).p_ppp_f = let_set_p_ppp_2; /* (set! (L3 'x) (+ (L3 'x) 1)) */ + break; + + default: + return_false(sc, expr); + } + if (is_symbol(index)) + { + int32_t start = sc->pc; + const s7_pointer index_slot = opt_simple_symbol(sc, index); + if (index_slot) + { + q_arg2(opc).p = index_slot; + if ((is_t_integer(slot_value(index_slot))) && + (has_loop_end(q_arg2(opc).p))) + { + if (is_string(obj)) + { + if (loop_end(q_arg2(opc).p) <= string_length(obj)) + q_func(opc).p_pip_f = string_set_p_pip_direct; + } + else + if (is_byte_vector(obj)) + { + if (loop_end(q_arg2(opc).p) <= byte_vector_length(obj)) + q_func(opc).p_pip_f = byte_vector_set_p_pip_direct; + } + else + if ((is_complex_vector(obj)) && + (loop_end(q_arg2(opc).p) <= vector_length(obj))) + { + q_func(opc).p_pip_f = complex_vector_set_p_pip_direct; + } + else + if (is_any_vector(obj)) /* true for all 3 vectors */ + { + if ((is_any_vector(obj)) && + (loop_end(q_arg2(opc).p) <= vector_length(obj))) + { + if (is_typed_t_vector(obj)) + q_func(opc).p_pip_f = typed_t_vector_set_p_pip_direct; + else q_func(opc).p_pip_f = t_vector_set_p_pip_direct; + }}} + if (is_symbol(value)) + { + const s7_pointer val_slot = opt_simple_symbol(sc, value); + if (val_slot) + { + s7_p_ppp_t func1; + if ((is_string(obj)) || + (is_any_vector(obj)) || + (is_pair(obj))) + { + q_arg3(opc).p = val_slot; + q_call(opc).fp = opt_p_pip_sss; + return_true(sc, expr); + } + if ((is_let(obj)) && (is_keyword(index)) && (q_func(opc).p_ppp_f == let_set_1) && /* (set! (L3 :x) i) */ + (use_pps_slot_set(sc, opc, obj, keyword_symbol(index), val_slot))) + return_true(sc, expr); + func1 = q_func(opc).p_ppp_f; + q_arg3(opc).p = val_slot; + q_call(opc).fp = (func1 == multiply_p_ppp) ? opt_p_ppp_sss_mul : + (((is_hash_table(obj)) && (func1 == s7_hash_table_set)) ? opt_p_ppp_sss_hset : opt_p_ppp_sss); + return_true(sc, expr); + }} + else + if ((!is_pair(value)) || + (is_proper_quote(sc, value))) + { + q_arg3(opc).p = (!is_pair(value)) ? value : cadr(value); + if ((is_string(obj)) || + (is_any_vector(obj)) || + (is_pair(obj))) + { + q_call(opc).fp = opt_p_pip_ssc; + return_true(sc, expr); + } + if ((is_let(obj)) && (is_keyword(index)) && (q_func(opc).p_ppp_f == let_set_1) && /* (set! (L3 :x) 0) */ + (use_ppc_slot_set(sc, opc, obj, keyword_symbol(index), q_arg3(opc).p))) + return_true(sc, expr); + q_call(opc).fp = opt_p_ppp_ssc; + return_true(sc, expr); + } + if (cell_optimize(sc, cddr(expr))) + { + q_func1_arg(opc).o1 = sc->opts[start]; + q_func1(opc).fp = q_call(sc->opts[start]).fp; + if ((is_string(obj)) || + (is_any_vector(obj)) || + (is_pair(obj))) + { + if (p_pip_ssf_combinable(sc, opc, start)) + return_true(sc, expr); + q_call(opc).fp = opt_p_pip_ssf; + return_true(sc, expr); + } + if ((is_let(obj)) && (is_keyword(index)) && (q_func(opc).p_ppp_f == let_set_1) && /* (set! (L3 :x) (+ (L3 'x) 1)) */ + (use_ppf_slot_set(sc, opc, obj, keyword_symbol(index)))) + return_true(sc, expr); + q_call(opc).fp = opt_p_ppp_ssf; + return_true(sc, expr); + }}} + else /* index not a symbol */ + { + opt_info *o1; + if ((is_string(obj)) || + (is_pair(obj)) || + (is_any_vector(obj))) + { + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(target))) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(expr))) + { + q_call(opc).fp = opt_p_pip_sff; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func3(opc).fp = q_func3_arg(opc).q_call(o1).fp; + return_true(sc, expr); + }} + return_false(sc, expr); + } + if (is_quoted_symbol(sc, index)) + { + if (is_symbol(value)) + { + const s7_pointer val_slot = opt_simple_symbol(sc, value); + if (val_slot) + { + q_arg2(opc).p = cadr(index); + q_arg3(opc).p = val_slot; + q_call(opc).fp = opt_p_ppp_scs; + if ((is_let(obj)) && (q_func(opc).p_ppp_f == let_set_1)) + use_pps_slot_set(sc, opc, obj, cadr(index), val_slot); + return_true(sc, expr); + }} + if ((!is_pair(value)) && (is_let(obj)) && (q_func(opc).p_ppp_f == let_set_1) && + (use_ppc_slot_set(sc, opc, obj, cadr(index), value))) + return_true(sc, expr); + } + o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdr(target))) + { + opt_info *o2; + if (is_symbol(value)) + { + const s7_pointer val_slot = opt_simple_symbol(sc, value); + if (val_slot) + { + q_arg2(opc).p = val_slot; + q_call(opc).fp = opt_p_ppp_sfs; + q_func1_arg(opc).o1 = o1; + q_func1(opc).fp = q_call(o1).fp; + return_true(sc, expr); + }} + o2 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(expr))) + { + q_call(opc).fp = opt_p_ppp_sff; + if ((is_let(obj)) && (is_quoted_symbol(sc, index)) && (q_func(opc).p_ppp_f == let_set_1) && /* (set! (L3 'x) (+ (L3 'x) 1)) */ + (use_ppf_slot_set(sc, opc, obj, cadr(index)))) + { + q_func1_arg(opc).o1 = o2; + q_func1(opc).fp = q_func1_arg(opc).q_call(o1).fp; + return_true(sc, expr); + } + q_func2_arg(opc).o1 = o1; + q_func2(opc).fp = q_call(o1).fp; + q_func3_arg(opc).o1 = o2; + q_func3(opc).fp = q_call(o2).fp; + return_true(sc, expr); + }}}} + return_false(sc, expr); +} + + +/* -------- cell_begin -------- */ +#define q_begin_arg(o, i) o->v[i + 2] + +static s7_pointer opt_begin_p(opt_info *o) +{ + opt_info *o1; + s7_int i, len = q_arg1(o).i; /* len = 1 if 2 exprs, etc */ + for (i = 0; i < len; i++) + { + o1 = q_begin_arg(o, i).o1; + q_call(o1).fp(o1); + } + o1 = q_begin_arg(o, i).o1; + return(q_call(o1).fp(o1)); +} + +static s7_pointer opt_begin_p_1(opt_info *o) +{ + q_func(o).fp(q_arg2(o).o1); + return(q_p_func1_call(o)); +} + +static void oo_idp_nr_fixup(opt_info *start) +{ + if (q_call(start).fp == d_to_p) + { + q_call(start).fp = d_to_p_nr; + if (q_temp(start).fd == opt_d_7pid_ssf) + q_call(start).fp = opt_d_7pid_ssf_nr; + else + if (q_temp(start).fd == opt_d_7pid_ssfo_fv) + { + q_call(start).fp = opt_d_7pid_ssfo_fv_nr; + if (q_func2(start).d_dd_f == add_d_dd) + q_call(start).fp = opt_d_7pid_ssfo_fv_add_nr; + else + if (q_func2(start).d_dd_f == subtract_d_dd) + q_call(start).fp = opt_d_7pid_ssfo_fv_sub_nr; + }} + else + if (q_call(start).fp == i_to_p) + q_call(start).fp = i_to_p_nr; +} + +static bool opt_cell_begin(s7_scheme *sc, s7_pointer expr, int32_t len) +{ + opt_info *opc; + s7_pointer p = cdr(expr); + if (len > (num_vunions - 3)) return_false(sc, expr); + opc = alloc_opt_info(sc); + for (int32_t i = 0; is_pair(p); i++, p = cdr(p)) + { + opt_info *start = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) + return_false(sc, expr); + if (is_pair(cdr(p))) + oo_idp_nr_fixup(start); + q_begin_arg(opc, i).o1 = start; + } + q_arg1(opc).i = len - 2; + if (len == 3) + { + q_call(opc).fp = opt_begin_p_1; + q_func1_arg(opc).o1 = q_begin_arg(opc, 1).o1; + q_func1(opc).fp = q_begin_arg(opc, 2).q_call(o1).fp; + q_func(opc).fp = q_begin_arg(opc, 0).q_call(o1).fp; + } + else q_call(opc).fp = opt_begin_p; + return_true(sc, expr); +} + +/* -------- cell_when|unless -------- */ + +#define q_when_body_len(o) o->v[1] +#define q_when_test_arg(o) o->v[3] +#define q_when_test_func(o) o->v[4] +#define q_when_test_call(o) o->v[4].fb(o->v[3].o1) +#define q_when_body(o, i) o->v[i + 5] +#define q_when_p1_call(o) o->v[6].fp(o->v[5].o1) +#define q_when_p1_func(o) o->v[6] +#define q_when_p1_arg(o) o->v[5] +#define q_when_p2_call(o) o->v[8].fp(o->v[7].o1) +#define q_when_p2_func(o) o->v[8] +#define q_when_p2_arg(o) o->v[7] + +static s7_pointer opt_when_p_2(opt_info *o) +{ + if (q_when_test_call(o)) + { + q_when_p1_call(o); + return(q_when_p2_call(o)); + } + return(o->sc->unspecified); +} + +static s7_pointer opt_when_p(opt_info *o) +{ + if (q_when_test_call(o)) + { + s7_int i, len = q_when_body_len(o).i - 1; + opt_info *o1; + for (i = 0; i < len; i++) + { + o1 = q_when_body(o, i).o1; + q_call(o1).fp(o1); + } + o1 = q_when_body(o, i).o1; + return(q_call(o1).fp(o1)); + } + return(o->sc->unspecified); +} + +static s7_pointer opt_when_p_1(opt_info *o) +{ + opt_info *o1; + if (!q_when_test_call(o)) + return(o->sc->unspecified); + o1 = q_when_body(o, 0).o1; + return(q_call(o1).fp(o1)); +} + +static s7_pointer opt_unless_p(opt_info *o) +{ + opt_info *o1; + s7_int i, len; + if (q_when_test_call(o)) + return(o->sc->unspecified); + len = q_when_body_len(o).i - 1; + for (i = 0; i < len; i++) + { + o1 = q_when_body(o, i).o1; + q_call(o1).fp(o1); + } + o1 = q_when_body(o, i).o1; + return(q_call(o1).fp(o1)); +} + +static s7_pointer opt_unless_p_1(opt_info *o) +{ + opt_info *o1; + if (q_when_test_call(o)) + return(o->sc->unspecified); + o1 = q_when_body(o, 0).o1; + return(q_call(o1).fp(o1)); +} + +static bool opt_cell_when(s7_scheme *sc, s7_pointer expr, int32_t len) +{ + s7_pointer p; + int32_t k; + opt_info *opc; + if (len > (num_vunions - 6)) + return_false(sc, expr); + opc = alloc_opt_info(sc); + q_when_test_arg(opc).o1 = sc->opts[sc->pc]; + if (!bool_optimize(sc, cdr(expr))) + return_false(sc, expr); + for (k = 0, p = cddr(expr); is_pair(p); k++, p = cdr(p)) + { + opt_info *start = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) + return_false(sc, expr); + if (is_pair(cdr(p))) + oo_idp_nr_fixup(start); + q_when_body(opc, k).o1 = start; + } + q_when_test_func(opc).fb = q_when_test_arg(opc).q_call(o1).fb; + q_when_body_len(opc).i = len - 2; + if (car(expr) == sc->when_symbol) + { + if (len == 3) /* 1 expr */ + q_call(opc).fp = opt_when_p_1; + else + if (len == 4) /* 2 exprs */ + { + q_call(opc).fp = opt_when_p_2; + q_when_p2_arg(opc).o1 = q_when_body(opc, 1).o1; /* make room... */ + q_when_p2_func(opc).fp = q_when_p2_arg(opc).q_call(o1).fp; /* order matters */ + q_when_p1_func(opc).fp = q_when_p1_arg(opc).q_call(o1).fp; /* also q_when_body(opc, 0) */ + } + else q_call(opc).fp = opt_when_p; + } + else q_call(opc).fp = (len == 3) ? opt_unless_p_1 : opt_unless_p; + return_true(sc, expr); +} + + +/* -------- cell_cond -------- */ + +#define q_cond_o1 3 +#define q_cond_clause_o1 5 +#define q_cond_val1(o) o->v[6] +#define q_cond_val2(o) o->v[7] +#define q_cond_clause(o, i) o->v[i + q_cond_clause_o1] +#define q_cond(o, i) o->v[i + q_cond_o1] + +static s7_pointer cond_value(opt_info *o) +{ + opt_info *o1; + s7_int i, len = q_arg1(o).i - 1; + for (i = 0; i < len; i++) + { + o1 = q_cond_clause(o, i).o1; + q_call(o1).fp(o1); + } + o1 = q_cond_clause(o, i).o1; + return(q_call(o1).fp(o1)); +} + +static s7_pointer opt_cond(opt_info *top) +{ + s7_int len = q_arg2(top).i; + for (s7_int clause = 0; clause < len; clause++) + { + opt_info *o1 = q_cond(top, clause).o1; + opt_info *o2 = q_func1_arg(o1).o1; + if (q_call(o2).fb(o2)) + return(cond_value(o1)); + } + return(top->sc->unspecified); +} + +static s7_pointer opt_cond_1(opt_info *o) {return((q_b_func1_call(o)) ? cond_value(q_cond_val1(o).o1) : o->sc->unspecified);} /* cond as when */ +static s7_pointer opt_cond_1b(opt_info *o) {return((q_func1_arg(o).q_temp(o1).fp(q_func1_arg(o).o1) != o->sc->F) ? cond_value(q_cond_val1(o).o1) : o->sc->unspecified);} + +static s7_pointer opt_cond_2(opt_info *o) /* 2 branches, results 1 expr, else */ +{ + opt_info *o1 = (q_b_func1_call(o)) ? q_cond_val1(o).o1 : q_cond_val2(o).o1; + return(q_call(o1).fp(o1)); +} + +static bool opt_cell_cond(s7_scheme *sc, s7_pointer expr) +{ + /* 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 last_clause = NULL; + int32_t branches = 0, max_blen = 0; + opt_info *top = alloc_opt_info(sc); + const int32_t start_pc = sc->pc; + for (s7_pointer clauses = cdr(expr); is_pair(clauses); clauses = cdr(clauses), branches++) + { + opt_info *opc; + s7_pointer clause = car(clauses), cp; + int32_t blen; + if ((branches >= (num_vunions - q_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; + q_cond(top, branches).o1 = sc->opts[sc->pc]; + opc = alloc_opt_info(sc); + q_func1_arg(opc).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 - q_cond_clause_o1) + return_false(sc, cp); + q_cond_clause(opc, blen).o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, cp)) + return_false(sc, cp); + } + if (!is_null(cp)) + return_false(sc, cp); + q_arg1(opc).i = blen; + if (max_blen < blen) max_blen = blen; + q_call(opc).fp = opt_cond; /* a placeholder */ + } + if (branches == 1) + { + opt_info *o1 = sc->opts[start_pc + 1]; + q_call(top).fp = (q_call(o1).fb == p_to_b) ? opt_cond_1b : opt_cond_1; + q_func1_arg(top).o1 = o1; + q_func1(top).fb = q_call(o1).fb; + q_cond_val1(top).o1 = sc->opts[start_pc]; + return_true(sc, expr); + } + if (branches == 2) + { + if ((max_blen == 1) && + ((car(last_clause) == sc->T) || + ((car(last_clause) == sc->else_symbol) && (is_global(sc->else_symbol))))) + { + opt_info *o1; + q_cond_val1(top).o1 = q_cond(top, 0).q_cond_clause(o1, 0).o1; + q_cond_val2(top).o1 = q_cond(top, 1).q_cond_clause(o1, 0).o1; + o1 = sc->opts[start_pc + 1]; + q_func1_arg(top).o1 = o1; + q_func1(top).fb = q_call(o1).fb; + q_call(top).fp = opt_cond_2; + return_true(sc, expr); + }} + q_arg2(top).i = branches; + q_call(top).fp = opt_cond; + return_true(sc, expr); +} + +/* -------- cell_and|or -------- */ +#define q_or_clause(o, i) o->v[i + 3] + +static s7_pointer opt_and_pp(opt_info *o) {return((q_p_func2_call(o) == o->sc->F) ? o->sc->F : q_p_func3_call(o));} + +static s7_pointer opt_and_any_p(opt_info *o) +{ + s7_pointer val = o->sc->T; /* (and) -> #t */ + for (s7_int i = 0; i < q_arg1(o).i; i++) + { + opt_info *o1 = q_or_clause(o, i).o1; + val = q_call(o1).fp(o1); + if (val == o->sc->F) + return(o->sc->F); + } + return(val); +} + +static s7_pointer opt_or_pp(opt_info *o) +{ + s7_pointer val = q_p_func2_call(o); + return((val != o->sc->F) ? val : q_p_func3_call(o)); +} + +static s7_pointer opt_or_any_p(opt_info *o) +{ + for (s7_int i = 0; i < q_arg1(o).i; i++) + { + opt_info *o1 = q_or_clause(o, i).o1; + s7_pointer val = q_call(o1).fp(o1); + if (val != o->sc->F) + return(val); + } + return(o->sc->F); +} + +static bool opt_cell_and(s7_scheme *sc, s7_pointer expr, int32_t len) +{ + opt_info *opc = alloc_opt_info(sc); + if (len == 3) + { + q_call(opc).fp = ((car(expr) == sc->or_symbol) ? opt_or_pp : opt_and_pp); + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, cdr(expr))) + return_false(sc, expr); + q_func2(opc).fp = q_func2_arg(opc).q_call(o1).fp; + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, cddr(expr))) + return_false(sc, expr); + q_func3(opc).fp = q_func3_arg(opc).q_call(o1).fp; + return_true(sc, expr); + } + if ((len > 1) && (len < (num_vunions - 4))) + { + s7_pointer p = cdr(expr); + q_arg1(opc).i = (len - 1); + q_call(opc).fp = ((car(expr) == sc->or_symbol) ? opt_or_any_p : opt_and_any_p); + for (int32_t i = 0; is_pair(p); i++, p = cdr(p)) + { + q_or_clause(opc, i).o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) + return_false(sc, expr); + } + return_true(sc, expr); + } + return_false(sc, expr); +} + +/* -------- cell_if -------- */ +static s7_pointer opt_if_bp(opt_info *o) {return((q_func(o).fb(q_arg2(o).o1)) ? q_p_func1_call(o) : o->sc->unspecified);} +static s7_pointer opt_if_b7p(opt_info *o) {return((opt_b_7p_f(q_arg2(o).o1)) ? q_p_func1_call(o) : o->sc->unspecified);} /* expanded not faster */ +static s7_pointer opt_if_nbp(opt_info *o) {return((q_b_func1_call(o)) ? o->sc->unspecified : q_p_func2_call(o));} +static s7_pointer opt_if_bp_and(opt_info *o) {return((opt_and_bb(q_arg2(o).o1)) ? q_p_func1_call(o) : o->sc->unspecified);} + +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((q_func(o).fp(q_arg2(o).o1) != o->sc->F) ? q_p_func1_call(o) : o->sc->unspecified); +} + +static s7_pointer opt_if_bp_ii_fc(opt_info *o) +{ + return((q_func(o).b_ii_f(q_i_func2_call(o), q_arg2(o).i)) ? q_p_func1_call(o) : o->sc->unspecified); +} + +static s7_pointer opt_if_nbp_s(opt_info *o) +{ + return((q_func(o).b_p_f(slot_value(q_arg2(o).p))) ? o->sc->unspecified : q_p_func2_call(o)); +} + +static s7_pointer opt_if_nbp_sc(opt_info *o) /* b_pp_sc */ +{ + return((q_func(o).b_pp_f(slot_value(q_arg2(o).p), q_arg3(o).p)) ? o->sc->unspecified : q_p_func2_call(o)); +} + +static s7_pointer opt_if_nbp_7sc(opt_info *o) /* b_7pp_sc */ +{ + return((q_func(o).b_7pp_f(o->sc, slot_value(q_arg2(o).p), q_arg3(o).p)) ? o->sc->unspecified : q_p_func2_call(o)); +} + +static s7_pointer opt_if_nbp_ss(opt_info *o) /* b_ii_ss */ +{ + return((q_func(o).b_ii_f(integer(slot_value(q_arg2(o).p)), integer(slot_value(q_arg3(o).p)))) ? o->sc->unspecified : q_p_func2_call(o)); +} + +static s7_pointer opt_if_num_eq_ii_ss(opt_info *o) /* b_ii_ss */ +{ + return((integer(slot_value(q_arg2(o).p)) == integer(slot_value(q_arg3(o).p))) ? o->sc->unspecified : q_p_func2_call(o)); +} + +static s7_pointer opt_if_nbp_fs(opt_info *o) /* b_pi_fs */ +{ + return((q_func4(o).b_pi_f(o->sc, q_p_func1_call(o), integer(slot_value(q_arg1(o).p)))) ? o->sc->unspecified : q_p_func2_call(o)); +} + +static s7_pointer opt_if_nbp_sf(opt_info *o) /* b_pp_sf */ +{ + return((q_func(o).b_pp_f(slot_value(q_arg1(o).p), q_p_func1_call(o))) ? o->sc->unspecified : q_p_func2_call(o)); +} + +static s7_pointer opt_if_nbp_7sf(opt_info *o) /* b_7pp_sf */ +{ + return((q_func(o).b_7pp_f(o->sc, slot_value(q_arg1(o).p), q_p_func1_call(o))) ? o->sc->unspecified : q_p_func2_call(o)); +} + +static s7_pointer opt_if_bpp(opt_info *o) {return((q_b_func1_call(o)) ? q_p_func3_call(o) : q_p_func2_call(o));} +static s7_pointer opt_if_bpp_bit(opt_info *o) {return((opt_b_7ii_sc_bit(q_func1_arg(o).o1)) ? q_p_func3_call(o) : q_p_func2_call(o));} + +static bool opt_cell_if(s7_scheme *sc, s7_pointer expr, int32_t len) +{ + opt_info *opc = alloc_opt_info(sc); + opt_info *bop = sc->opts[sc->pc]; + if (len == 3) + { + if ((is_proper_list_2(sc, cadr(expr))) && /* (not arg) */ + (caadr(expr) == sc->not_symbol)) + { + if (bool_optimize(sc, cdadr(expr))) + { + opt_info *top = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(expr))) + { + q_func2_arg(opc).o1 = top; + q_func2(opc).fp = q_call(top).fp; + if (q_call(bop).fb == opt_b_p_s) + { + q_func(opc).b_p_f = q_func(bop).b_p_f; + q_arg2(opc).p = q_arg1(bop).p; + q_call(opc).fp = opt_if_nbp_s; + return_true(sc, expr); + } + if ((q_call(bop).fb == opt_b_pi_fs) || (q_call(bop).fb == opt_b_pi_fs_num_eq)) + { + q_func4(opc).b_pi_f = q_func4(bop).b_pi_f; + q_arg1(opc).p = q_arg1(bop).p; + q_func1_arg(opc).o1 = q_func2_arg(bop).o1; + q_func1(opc).fp = q_func2(bop).fp; + q_call(opc).fp = opt_if_nbp_fs; + return_true(sc, expr); + } + if ((q_call(bop).fb == opt_b_pp_sf) || + (q_call(bop).fb == opt_b_7pp_sf)) + { + q_func1_arg(opc).o1 = q_func2_arg(bop).o1; + q_func1(opc).fp = q_func2(bop).fp; + if (q_call(bop).fb == opt_b_pp_sf) + { + q_func(opc).b_pp_f = q_func(bop).b_pp_f; + q_call(opc).fp = opt_if_nbp_sf; + } + else + { + q_func(opc).b_7pp_f = q_func(bop).b_7pp_f; + q_call(opc).fp = opt_if_nbp_7sf; + } + q_arg1(opc).p = q_arg1(bop).p; + return_true(sc, expr); + } + if ((q_call(bop).fb == opt_b_pp_sc) || + (q_call(bop).fb == opt_b_7pp_sc)) + { + if (q_call(bop).fb == opt_b_pp_sc) + { + q_func(opc).b_pp_f = q_func(bop).b_pp_f; + q_call(opc).fp = opt_if_nbp_sc; + } + else + { + q_func(opc).b_7pp_f = q_func(bop).b_7pp_f; + q_call(opc).fp = opt_if_nbp_7sc; + } + q_arg2(opc).p = q_arg1(bop).p; + q_arg3(opc).p = q_arg2(bop).p; + return_true(sc, expr); + } + if ((q_call(bop).fb == opt_b_ii_ss) || (q_call(bop).fb == opt_b_ii_ss_eq) || + (q_call(bop).fb == opt_b_ii_ss_lt) || (q_call(bop).fb == opt_b_ii_ss_gt) || + (q_call(bop).fb == opt_b_ii_ss_leq) || (q_call(bop).fb == opt_b_ii_ss_geq)) + { + q_func(opc).b_ii_f = q_func(bop).b_ii_f; + q_arg2(opc).p = q_arg1(bop).p; + q_arg3(opc).p = q_arg2(bop).p; + q_call(opc).fp = (q_func(opc).b_ii_f == num_eq_b_ii) ? opt_if_num_eq_ii_ss : opt_if_nbp_ss; + return_true(sc, expr); + } + q_func1_arg(opc).o1 = bop; + q_func1(opc).fb = q_call(bop).fb; + q_call(opc).fp = opt_if_nbp; + return_true(sc, expr); + }}} + else + if (bool_optimize(sc, cdr(expr))) + { + opt_info *top = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(expr))) + { + q_arg2(opc).o1 = bop; + q_func1_arg(opc).o1 = top; + q_func1(opc).fp = q_call(top).fp; + if (q_call(bop).fb == p_to_b) + { + q_call(opc).fp = opt_if_bp_pb; + q_func(opc).fp = q_temp(bop).fp; + return_true(sc, expr); + } + if (q_call(bop).fb == opt_b_ii_fc) + { + q_arg2(opc).i = q_arg2(bop).i; + q_func(opc).b_ii_f = q_func(bop).b_ii_f; + q_func2(opc).fi = q_func2(bop).fi; + q_func2_arg(opc).o1 = q_func2_arg(bop).o1; + q_call(opc).fp = opt_if_bp_ii_fc; + return_true(sc, expr); + } + q_call(opc).fp = (q_call(bop).fb == opt_b_7p_f) ? opt_if_b7p : ((q_call(bop).fb == opt_and_bb) ? opt_if_bp_and : opt_if_bp); + q_func(opc).fb = q_call(bop).fb; + return_true(sc, expr); + }} + return_false(sc, expr); + } + if (len == 4) + { + if (bool_optimize(sc, cdr(expr))) + { + opt_info *top = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(expr))) + { + opt_info *o3 = sc->opts[sc->pc]; + q_call(opc).fp = (q_call(bop).fb == opt_b_7ii_sc_bit) ? opt_if_bpp_bit : opt_if_bpp; + if (cell_optimize(sc, cdddr(expr))) + { + q_func1_arg(opc).o1 = bop; + q_func1(opc).fb = q_call(bop).fb; + q_func3_arg(opc).o1 = top; + q_func3(opc).fp = q_call(top).fp; + q_func2_arg(opc).o1 = o3; + q_func2(opc).fp = q_call(o3).fp; + return_true(sc, expr); + }}}} + return_false(sc, expr); +} + +/* -------- cell_case -------- */ +#define q_case_start 3 +#define q_max_case_clauses (num_vunions - 4) +#define q_case_selector(o) o->v[2] +#define q_case_clause(o, i) o->v[i + 4] +#define q_case(o, i) o->v[i] +#define q_case_clause_keys(o) o->v[2] + +static s7_pointer case_value(opt_info *o) +{ + opt_info *o1; + int32_t i, len = q_arg1(o).i - 1; /* int32_t here and below seems to be faster than s7_int (tleft.scm) */ + for (i = 0; i < len; i++) + { + o1 = q_case_clause(o, i).o1; + q_call(o1).fp(o1); + } + o1 = q_case_clause(o, i).o1; + return(q_call(o1).fp(o1)); +} + +static s7_pointer opt_case(opt_info *o) +{ + opt_info *o1 = q_case_selector(o).o1; + const int32_t lim = q_arg1(o).i; + s7_scheme *sc = o->sc; + const s7_pointer selector = q_call(o1).fp(o1); + + if (is_simple(selector)) + { + for (int32_t ctr = q_case_start; ctr < lim; ctr++) + { + s7_pointer p; + o1 = q_case(o, ctr).o1; + for (p = q_case_clause_keys(o1).p; is_pair(p); p = cdr(p)) + if (selector == car(p)) + return(case_value(o1)); + if (p == sc->else_symbol) + return(case_value(o1)); + }} + else + for (int32_t ctr = q_case_start; ctr < lim; ctr++) + { + s7_pointer p; + o1 = q_case(o, ctr).o1; + for (p = q_case_clause_keys(o1).p; is_pair(p); p = cdr(p)) + if (s7_is_eqv(sc, selector, car(p))) + return(case_value(o1)); + if (p == sc->else_symbol) + return(case_value(o1)); + } + return(sc->unspecified); +} + +static bool opt_cell_case(s7_scheme *sc, s7_pointer expr) +{ + /* 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; + int32_t ctr; + opt_info *top = alloc_opt_info(sc); + q_case_selector(top).o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, cdr(expr))) /* selector */ + return_false(sc, expr); + for (ctr = q_case_start, p = cddr(expr); (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_opt_info(sc); + q_case(top, ctr).o1 = opc; + if (car(clause) == sc->else_symbol) + { + if (!is_null(cdr(p))) + return_false(sc, clause); + q_case_clause_keys(opc).p = sc->else_symbol; + } + else + { + if (!s7_is_proper_list(sc, car(clause))) + return_false(sc, clause); + q_case_clause_keys(opc).p = car(clause); + } + + for (blen = 0, cp = cdr(clause); (is_pair(cp)) && (blen < q_max_case_clauses); blen++, cp = cdr(cp)) + { + q_case_clause(opc, blen).o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, cp)) + return_false(sc, cp); + } + if (!is_null(cp)) + return_false(sc, cp); + q_arg1(opc).i = blen; + q_call(opc).fp = opt_case; /* just a placeholder I hope */ + } + if (!is_null(p)) + return_false(sc, p); + q_arg1(top).i = ctr; + q_call(top).fp = opt_case; + return_true(sc, expr); +} + +/* -------- cell_let_temporarily -------- */ + +#define q_let_temp_o1 5 +#define q_let_temp(o, i) o->v[i + q_let_temp_o1] +#define q_let_temp_old_value(o) o->v[3] +#define q_let_temp_new_value(o) o->v[4] + +static s7_pointer opt_let_temporarily(opt_info *o) +{ + opt_info *new_o1 = q_let_temp_new_value(o).o1; + s7_int i, len; + s7_pointer result; + s7_scheme *sc = o->sc; + + if (is_immutable_slot(q_arg1(o).p)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->let_temporarily_symbol, slot_symbol(q_arg1(o).p))); + + q_let_temp_old_value(o).p = slot_value(q_arg1(o).p); /* save and protect old value */ + gc_protect_via_stack(sc, q_let_temp_old_value(o).p); + slot_set_value(q_arg1(o).p, q_call(new_o1).fp(new_o1)); /* set new value */ + len = q_arg2(o).i - 1; + { + opt_info *o1; + for (i = 0; i < len; i++) + { + o1 = q_let_temp(o, i).o1; + q_call(o1).fp(o1); + } + o1 = q_let_temp(o, i).o1; + result = q_call(o1).fp(o1); + } + slot_set_value(q_arg1(o).p, q_let_temp_old_value(o).p); /* restore old */ + unstack_gc_protect(sc); + return(result); +} + +static bool opt_cell_let_temporarily(s7_scheme *sc, s7_pointer expr, int32_t len) +{ + s7_pointer vars; + if (len <= 2) return_false(sc, expr); + vars = cadr(expr); + if ((len < (num_vunions - q_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_symbol(caar(vars))) && + (!is_syntactic_symbol(caar(vars)))) + { + s7_pointer p; + opt_info *opc = alloc_opt_info(sc); + q_arg1(opc).p = s7_t_slot(sc, caaadr(expr)); + if (!is_slot(q_arg1(opc).p)) return_false(sc, expr); + q_let_temp_new_value(opc).o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, cdaadr(expr))) + return_false(sc, expr); + + p = cddr(expr); + for (int32_t i = 0; is_pair(p); i++, p = cdr(p)) + { + q_let_temp(opc, i).o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) + return_false(sc, expr); + } + q_arg2(opc).i = len - 2; + q_call(opc).fp = opt_let_temporarily; + return_true(sc, expr); + } + return_false(sc, expr); +} + +/* -------- cell_do -------- */ + +#define do_curlet(o) T_Let(q_arg2(o).p) +#define do_curlet_unchecked(o) o->v[2].p +#define do_body_length(o) o->v[3].i +#define do_result_length(o) o->v[4].i +#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 +#define do_stepper_opt(o) o->v[9].o1 +#define do_expr(o, i) o->v[i] + +static void let_set_has_pending_value(s7_pointer let) +{ + for (s7_pointer slot = let_slots(let); is_not_slot_end(slot); slot = next_slot(slot)) + slot_set_pending_value(slot, eof_object); /* gc needs a legit value here */ +} + +static void let_clear_has_pending_value(s7_scheme *sc, s7_pointer let) +{ + for (s7_pointer slot = let_slots(let); is_not_slot_end(slot); slot = next_slot(slot)) + slot_clear_has_pending_value(slot); +} + +typedef s7_pointer (*opt_info_fp)(opt_info *o); + +static s7_pointer opt_do_any(opt_info *o) +{ + opt_info *o1; + opt_info *ostart = do_any_test(o); + const opt_info *body = do_any_body(o); + const opt_info *inits = do_any_inits(o); + const opt_info *steps = do_any_steps(o); + const opt_info *results = do_any_results(o); + const int32_t len = do_body_length(o); /* len=6 tlist, 6|7 tbig, 0 tvect */ + s7_pointer slot, result; + s7_scheme *sc = o->sc; + opt_info *os[num_vunions]; + opt_info_fp fp[num_vunions]; + const s7_pointer old_let = sc->curlet; + gc_protect_via_stack(sc, old_let); + set_curlet(sc, do_curlet(o)); + /* init */ + slot = let_slots(sc->curlet); + for (int32_t k = 0; is_not_slot_end(slot); k++, slot = next_slot(slot)) + { + o1 = do_expr(inits, k).o1; + slot_set_value(slot, q_call(o1).fp(o1)); + } + let_set_has_pending_value(sc->curlet); + for (int32_t i = 0; i < len; i++) + { + os[i] = do_expr(body, i).o1; + fp[i] = q_call(os[i]).fp; + } + while (true) + { + /* end */ + if (q_call(ostart).fb(ostart)) + break; + /* body */ + if (len == 6) /* here and in opt_do_n we need a better way to unroll these loops */ + {fp[0](os[0]); fp[1](os[1]); fp[2](os[2]); fp[3](os[3]); fp[4](os[4]); fp[5](os[5]);} + else + if (len == 7) + {fp[0](os[0]); fp[1](os[1]); fp[2](os[2]); fp[3](os[3]); fp[4](os[4]); fp[5](os[5]); fp[6](os[6]);} + else for (int32_t i = 0; i < len; i++) fp[i](os[i]); + /* step (let not let*) */ + slot = let_slots(sc->curlet); + for (int32_t k = 0; is_not_slot_end(slot); k++, slot = next_slot(slot)) + if (has_stepper(slot)) + { + o1 = do_expr(steps, k).o1; + slot_simply_set_pending_value(slot, q_call(o1).fp(o1)); + } + for (s7_pointer slot1 = let_slots(sc->curlet); is_not_slot_end(slot1); slot1 = next_slot(slot1)) + if (has_stepper(slot1)) + slot_set_value(slot1, slot_pending_value(slot1)); + } + /* result */ + result = sc->T; + for (int32_t i = 0; i < do_result_length(o); i++) + { + o1 = do_expr(results, i).o1; + result = q_call(o1).fp(o1); + } + let_clear_has_pending_value(sc, sc->curlet); + unstack_gc_protect(sc); + set_curlet(sc, old_let); + return(result); +} + +static s7_pointer opt_do_step_1(opt_info *o) +{ + /* 1 stepper (multi inits perhaps), 1 body, 1 return-expr */ + opt_info *o1; + opt_info *ostart = do_any_test(o); + opt_info *ostep = do_stepper_opt(o); + const opt_info *inits = do_any_inits(o); + opt_info *body = do_any_body(o); + s7_pointer slot, result, stepper = NULL; + s7_scheme *sc = o->sc; + const s7_pointer old_let = sc->curlet; + gc_protect_via_stack(sc, old_let); + set_curlet(sc, do_curlet(o)); + slot = let_slots(sc->curlet); + for (int32_t k = 0; is_not_slot_end(slot); k++, slot = next_slot(slot)) + { + o1 = do_expr(inits, k).o1; + slot_set_value(slot, q_call(o1).fp(o1)); + if (has_stepper(slot)) stepper = slot; + } + while (!(q_call(ostart).fb(ostart))) + { + q_call(body).fp(body); + slot_set_value(stepper, q_call(ostep).fp(ostep)); + } + o1 = do_any_results(o); + result = q_call(o1).fp(o1); + unstack_gc_protect(sc); + set_curlet(sc, old_let); + return(result); +} + +static s7_pointer opt_do_step_i(opt_info *o) +{ + /* 1 stepper (multi inits perhaps), 1 body expr, 1 return-expr */ + /* (do ((sum 0.0) (k 0 (+ k 1))) ((= k size) (set! (C i j) sum)) (set! sum (+ sum (* (A i k) (B k j))))) */ + opt_info *o1; + opt_info *ostart = do_any_test(o); + opt_info *ostep = do_stepper_opt(o); + const opt_info *inits = do_any_inits(o); + opt_info *body = do_any_body(o); + s7_pointer (*fp)(opt_info *o) = q_call(body).fp; + s7_pointer slot, result, stepper = NULL, si; + s7_scheme *sc = o->sc; + s7_int end, incr; + const s7_pointer old_let = sc->curlet; + gc_protect_via_stack(sc, old_let); + set_curlet(sc, do_curlet(o)); + slot = let_slots(sc->curlet); + for (int32_t k = 0; is_not_slot_end(slot); k++, slot = next_slot(slot)) + { + o1 = do_expr(inits, k).o1; + slot_set_value(slot, q_call(o1).fp(o1)); + if (has_stepper(slot)) stepper = slot; + } + end = integer(slot_value(q_arg2(ostart).p)); + incr = q_arg2(ostep).i; + si = make_mutable_integer(sc, integer(slot_value(q_arg1(ostart).p))); + if (stepper) slot_set_value(stepper, si); + if (fp == opt_set_p_d_f_sf_add) /* ok since used only if body has one expr */ + { + fp = opt_set_p_d_fm_sf_add; + slot_set_value(q_arg1(body).p, make_mutable_real(sc, real(slot_value(q_arg1(body).p)))); + } + while (integer(si) != end) + { + fp(body); + integer(si) += incr; + } + clear_mutable_integer(si); + if (fp == opt_set_p_d_fm_sf_add) + clear_mutable_number(slot_value(q_arg1(body).p)); + o1 = do_any_results(o); + result = q_call(o1).fp(o1); + unstack_gc_protect(sc); + set_curlet(sc, old_let); + 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[3].i=body length, o-v[4].i=return length=0, o-v[6]=end test */ + opt_info *ostart = do_no_vars_test(o); + const int32_t len = do_body_length(o); + s7_scheme *sc = o->sc; + bool (*fb)(opt_info *o) = q_call(ostart).fb; + const s7_pointer old_let = sc->curlet; + gc_protect_via_stack(sc, old_let); + set_curlet(sc, do_curlet(o)); + if (len == 0) /* titer */ + while (!fb(ostart)); + else + { + const opt_info *body = do_no_vars_body(o); + while (!fb(ostart)) /* tshoot, tfft */ + for (int32_t i = 0; i < len; i++) + { + opt_info *o1 = do_expr(body, i).o1; + q_call(o1).fp(o1); + }} + unstack_gc_protect(sc); + set_curlet(sc, old_let); + return(sc->T); +} + +#define do_stepper_init(o) o->v[11].o1 +#define do_stepper_safe(o) o->v[8].i + +static s7_pointer opt_do_1(opt_info *o) +{ + /* 1 var, 1 expr, no return */ + opt_info *o1 = do_stepper_init(o); + opt_info *ostart = do_any_test(o); + opt_info *ostep = do_stepper_opt(o); + opt_info *body = do_any_body(o); + s7_pointer slot = let_slots(do_curlet(o)); + s7_scheme *sc = o->sc; + const s7_pointer old_let = sc->curlet; + gc_protect_via_stack(sc, old_let); + set_curlet(sc, do_curlet(o)); + slot_set_value(slot, q_call(o1).fp(o1)); + if ((do_stepper_safe(o) == 1) && + (is_t_integer(slot_value(slot)))) + { + if ((q_call(ostep).fp == opt_p_ii_ss_add) || /* tmap */ + (q_call(ostep).fp == i_to_p)) + { + s7_pointer step_val = make_mutable_integer(sc, integer(slot_value(slot))); + slot_set_value(slot, step_val); + if (q_call(ostep).fp == opt_p_ii_ss_add) + while (!q_call(ostart).fb(ostart)) + { + q_call(body).fp(body); + set_integer(step_val, opt_i_ii_ss_add(ostep)); + } + else + while (!q_call(ostart).fb(ostart)) + { + q_call(body).fp(body); + set_integer(step_val, q_temp(ostep).fi(ostep)); + } + unstack_gc_protect(sc); + clear_mutable_integer(step_val); + set_curlet(sc, old_let); + return(sc->T); + } + do_stepper_safe(o) = 2; + } + while (!(q_call(ostart).fb(ostart))) /* s7test tref */ + { + q_call(body).fp(body); + slot_set_value(slot, q_call(ostep).fp(ostep)); + } + unstack_gc_protect(sc); + set_curlet(sc, old_let); + 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 = do_stepper_init(o); + opt_info *ostart = do_any_test(o); + opt_info *ostep = do_stepper_opt(o); + opt_info *body = do_n_body(o); + const int32_t len = do_body_length(o); + s7_pointer slot = let_slots(do_curlet(o)); + s7_scheme *sc = o->sc; + const s7_pointer old_let = sc->curlet; + gc_protect_via_stack(sc, old_let); + set_curlet(sc, do_curlet(o)); + slot_set_value(slot, q_call(o1).fp(o1)); + if (len == 2) /* tmac tshoot */ + { + opt_info *e1 = q_call(body).o1, *e2 = q_arg1(body).o1; + while (!(q_call(ostart).fb(ostart))) + { + q_call(e1).fp(e1); + q_call(e2).fp(e2); + slot_set_value(slot, q_call(ostep).fp(ostep)); + }} + else + { + opt_info *os[num_vunions]; + opt_info_fp fp[num_vunions]; + for (int32_t i = 0; i < len; i++) + { + os[i] = do_expr(body, i).o1; + fp[i] = q_call(os[i]).fp; + } + if (len == 7) + while (!q_call(ostart).fb(ostart)) /* tfft teq */ /* this is probably fft code */ + { + fp[0](os[0]); fp[1](os[1]); fp[2](os[2]); fp[3](os[3]); fp[4](os[4]); fp[5](os[5]); fp[6](os[6]); + slot_set_value(slot, q_call(ostep).fp(ostep)); + } + else + while (!q_call(ostart).fb(ostart)) /* tfft teq */ + { + for (int32_t i = 0; i < len; i++) fp[i](os[i]); + slot_set_value(slot, q_call(ostep).fp(ostep)); + }} + unstack_gc_protect(sc); + set_curlet(sc, old_let); + return(sc->T); +} + +#define do_times_end(o) o->v[6] + +static s7_pointer opt_do_times(opt_info *o) +{ + /* 1 var, no return */ + opt_info *o1 = do_stepper_init(o); + opt_info *body = do_n_body(o); + const int32_t len = do_body_length(o); + s7_int end = (is_slot(let_dox_slot2_unchecked(do_curlet(o)))) ? integer(slot_value(let_dox_slot2(do_curlet(o)))) : do_times_end(o).i; + s7_pointer slot = let_dox1_value(do_curlet(o)); + s7_scheme *sc = o->sc; + const s7_pointer old_let = sc->curlet; + gc_protect_via_stack(sc, old_let); + set_curlet(sc, do_curlet(o)); + set_integer(slot, integer(q_call(o1).fp(o1))); + if (len == 2) /* tmac tmisc */ + { + opt_info *e1 = q_call(body).o1, *e2 = q_arg1(body).o1; + while (integer(slot) < end) + { + q_call(e1).fp(e1); + q_call(e2).fp(e2); + integer(slot)++; + }} + else + while (integer(slot) < end) /* tbig sg */ + { + for (int32_t i = 0; i < len; i++) + { + o1 = do_expr(body, i).o1; + q_call(o1).fp(o1); + } + integer(slot)++; + } + unstack_gc_protect(sc); + set_curlet(sc, old_let); + return(sc->T); +} + +#define do_end(o) o->v[3] + +static s7_pointer opt_do_list_simple(opt_info *o) +{ + opt_info *o1 = do_stepper_init(o); + s7_pointer slot = let_slots(do_curlet(o)); + s7_scheme *sc = o->sc; + s7_pointer (*fp)(opt_info *o); + const s7_pointer old_let = sc->curlet; + gc_protect_via_stack(sc, old_let); + set_curlet(sc, do_curlet(o)); + slot_set_value(slot, q_call(o1).fp(o1)); + o1 = do_any_body(o); + fp = q_call(o1).fp; + if (fp == opt_if_bp) + while (is_pair(slot_value(slot))) + { + if (do_end(o1).fb(q_arg2(o1).o1)) + q_p_func1_call(o1); + slot_set_value(slot, cdr(slot_value(slot))); + } + else + while (!is_null(slot_value(slot))) + { + fp(o1); + slot_set_value(slot, cdr(slot_value(slot))); + } + unstack_gc_protect(sc); + set_curlet(sc, old_let); + 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 = do_stepper_init(o); + s7_int end = (is_slot(let_dox_slot2_unchecked(do_curlet_unchecked(o)))) ? integer(slot_value(let_dox_slot2(do_curlet(o)))) : do_end(o).i; + s7_pointer vp = let_dox1_value(do_curlet(o)); + s7_pointer (*f)(opt_info *o); + s7_scheme *sc = o->sc; + const s7_pointer old_let = sc->curlet; + gc_protect_via_stack(sc, old_let); + set_curlet(sc, do_curlet(o)); + set_integer(vp, integer(q_call(o1).fp(o1))); + o1 = do_any_body(o); + f = q_call(o1).fp; + if (f == opt_p_pip_ssf) /* tref.scm */ + { + opt_info *o2 = o1; + o1 = q_func1_arg(o2).o1; + if (q_func(o2).p_pip_f == t_vector_set_p_pip_direct) + { + s7_pointer vec = slot_value(q_arg1(o2).p); + while (integer(vp) < end) + { + t_vector_set_p_pip_direct(o2->sc, vec, integer(slot_value(q_arg2(o2).p)), q_call(o1).fp(o1)); + integer(vp)++; + }} + else + while (integer(vp) < end) + { + q_func(o2).p_pip_f(o2->sc, slot_value(q_arg1(o2).p), integer(slot_value(q_arg2(o2).p)), q_call(o1).fp(o1)); + integer(vp)++; + }} + else + { + if (f == opt_p_pip_sso) /* is this code dead? does it belong above? */ + { /* vector-set from vector-ref (i.e. copy), but treating vector-* as generic */ + if ((let_dox_slot1(do_curlet_unchecked(o)) == q_arg2(o1).p) && (q_arg2(o1).p == q_arg4(o1).p)) + { + s7_pointer (*setter)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_pointer p2) = q_func(o1).p_pip_f; + s7_pointer (*getter)(s7_scheme *sc, s7_pointer p1, s7_int i1) = q_func3(o1).p_pi_f; + if (((setter == float_vector_set_p_pip_direct) && (getter == float_vector_ref_p_pi_direct)) || + ((setter == complex_vector_set_p_pip_direct) && (getter == complex_vector_ref_p_pi_direct)) || + ((setter == int_vector_set_p_pip_direct) && (getter == int_vector_ref_p_pi_direct)) || + ((setter == string_set_p_pip_direct) && (getter == string_ref_p_pi_direct)) || + ((setter == byte_vector_set_p_pip_direct) && (getter == byte_vector_ref_p_pi_direct))) + { + copy_to_same_type(sc, slot_value(q_arg1(o1).p), slot_value(q_arg3(o1).p), integer(vp), end, integer(vp)); /* TODO: q_arg1 and q_arg3 */ + unstack_gc_protect(sc); + set_curlet(sc, old_let); + return(sc->T); + }} + while (integer(vp) < end) + { + q_func(o1).p_pip_f(o1->sc, slot_value(q_arg1(o1).p), integer(slot_value(q_arg2(o1).p)), + q_func3(o1).p_pi_f(o1->sc, slot_value(q_arg3(o1).p), integer(slot_value(q_arg4(o1).p)))); + integer(vp)++; + }} + else + if ((f == opt_set_p_i_f) && /* tvect.scm */ + (is_t_integer(slot_value(q_arg1(o1).p))) && + (q_arg1(o1).p != let_dox_slot1(do_curlet(o)))) + { + opt_info *o2 = q_func1_arg(o1).o1; /* set_p_i_f: x = make_integer(o->sc, o-v[6].fi(o-v[5].o1)); */ + s7_int (*fi)(opt_info *o) = q_call(o2).fi; + s7_pointer ival = make_mutable_integer(sc, integer(slot_value(q_arg1(o1).p))); + slot_set_value(q_arg1(o1).p, ival); + while (integer(vp) < end) + { + set_integer(ival, fi(o2)); + integer(vp)++; + } + slot_set_value(q_arg1(o1).p, make_integer(sc, integer(slot_value(q_arg1(o1).p)))); + clear_mutable_integer(ival); + } + else + if ((f == opt_d_7pid_ssf_nr) && /* tref.scm */ + (q_func(o1).d_7pid_f == float_vector_set_d_7pid_direct)) + { + s7_pointer ind = q_arg2(o1).p; + opt_info *o2 = do_any_body(o1); + s7_double (*fd)(opt_info *o) = q_call(o2).fd; + s7_pointer fv = slot_value(q_arg1(o1).p); + while (integer(vp) < end) + { + float_vector_set_d_7pid_direct(sc, fv, integer(slot_value(ind)), fd(o2)); + /* weird! els[integer(slot_value(ind))] = fd(o2) is much slower according to callgrind? */ + integer(vp)++; + }} + else + while (integer(vp) < end) {f(o1); integer(vp)++;}} + /* splitting out opt_set_p_d_f_sf_add here (for tgsl.scm) is marginal (time is in opt_d_dd_ff_mul -> opt_d_id_sf -> bessel funcs) */ + unstack_gc_protect(sc); + set_curlet(sc, old_let); + return(sc->T); +} + +#define do_prepack_end(o) o->v[1].i +#define do_prepack_stepper(o) o->v[6].p +#define do_dpnr_func(o) o->v[7] + +static s7_pointer opt_do_prepackaged(opt_info *o) +{ + opt_info *o1 = do_stepper_init(o); + s7_int end = (is_slot(let_dox_slot2_unchecked(do_curlet_unchecked(o)))) ? integer(slot_value(let_dox_slot2(do_curlet(o)))) : do_end(o).i; + s7_pointer vp = let_dox1_value(do_curlet(o)); + s7_scheme *sc = o->sc; + const s7_pointer old_let = sc->curlet; + gc_protect_via_stack(sc, old_let); + set_curlet(sc, do_curlet(o)); + set_integer(vp, integer(q_call(o1).fp(o1))); + + do_prepack_stepper(o) = vp; + do_prepack_end(o) = end; + do_dpnr_func(o).fp(o); /* call opt_do_i|dpnr below */ + + unstack_gc_protect(sc); + set_curlet(sc, old_let); + return(sc->T); +} + +static s7_pointer opt_do_dpnr(opt_info *o) +{ + opt_info *o1 = do_any_body(o); + s7_pointer vp = do_prepack_stepper(o); + s7_int end = do_prepack_end(o); + s7_double (*f)(opt_info *o) = q_temp(o1).fd; + while (integer(vp) < end) {f(o1); integer(vp)++;} + return(NULL); +} + +static s7_pointer opt_do_ipnr(opt_info *o) +{ + opt_info *o1 = do_any_body(o); + s7_pointer vp = do_prepack_stepper(o); + s7_int end = do_prepack_end(o); + s7_int (*f)(opt_info *o) = q_temp(o1).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 traversal */ + for (s7_pointer 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) +{ + while (true) + { + s7_pointer p = car(tree); + if (is_setter(p)) return(true); + if ((is_unquoted_pair(sc, p)) && + (tree_has_setters(sc, p))) + return(true); + tree = cdr(tree); + if (!is_pair(tree)) break; + } + return(is_setter(tree)); +} + +#define DO_PRINT 0 +#if DO_PRINT +#define do_is_safe(Sc, Body, Stepper, Var_list, Step_vars, Has_set) do_is_safe_1(Sc, Body, Stepper, Var_list, Step_vars, Has_set, __func__, __LINE__) +static bool do_is_safe_1(s7_scheme *sc, s7_pointer body, s7_pointer stepper, s7_pointer var_list, s7_pointer step_vars, bool *has_set, const char *funcly, int linely); +#else +static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer stepper, s7_pointer var_list, s7_pointer step_vars, bool *has_set); +#endif + +static bool do_passes_safety_check(s7_scheme *sc, s7_pointer body, s7_pointer stepper, s7_pointer step_vars, 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, step_vars, has_set)) + set_unsafe_do(body); + } + return(!is_unsafe_do(body)); +} + +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(s7_t_slot(sc, car(p)))))) || + ((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(s7_t_slot(sc, car(p)))))) || + ((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 expr, int32_t len) +{ + opt_info *opc; + s7_pointer endp, let = NULL; + const s7_pointer old_let = sc->curlet; + const s7_pointer vars = (is_pair(cdr(expr))) ? cadr(expr) : sc->nil; + const int32_t body_len = len - 3; + int32_t var_len, body_index, step_len, return_exprs, step_pc, init_pc, end_test_pc; + bool has_set = false; + opt_info *init_o[num_vunions], *step_o[num_vunions], *body_o[num_vunions], *return_o[num_vunions]; +#if S7_DEBUGGING + for (int32_t i = 0; i < num_vunions; i++) + { + body_o[i] = NULL; + init_o[i] = NULL; + step_o[i] = NULL; + return_o[i] = NULL; + } +#endif + + if (len < 3) return_false(sc, expr); + if (body_len > num_vunions) return_false(sc, expr); + if (!s7_is_proper_list(sc, vars)) return_false(sc, expr); + var_len = proper_list_length(vars); + step_len = var_len; + endp = caddr(expr); + if (!is_pair(endp)) return_false(sc, expr); + if ((is_pair(vars)) && (is_pair(car(vars))) && (is_pair(cdar(vars))) && (is_pair(cddar(vars)))) /* expr is the do form */ + { + const s7_pointer old_code = sc->code; + sc->code = expr; /* the do form here could be totally messed up: e.g. (do () '2) in s7test */ + if (!do_passes_safety_check(sc, cdddr(expr), caar(vars), vars, &has_set)) + { + sc->code = old_code; + if (DO_PRINT) fprintf(stderr, "%s[%d]: return(false) because do_passes_safety_check is unhappy: %s\n", __func__, __LINE__, display(expr)); + return_false(sc, expr); + } + sc->code = old_code; + } + + opc = alloc_opt_info(sc); + let = inline_make_let(sc, sc->curlet); + push_stack(sc, OP_GC_PROTECT, old_let, 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)))...") + */ + begin_small_symbol_set(sc); + for (s7_pointer p = vars; is_pair(p); p = cdr(p)) + { + const s7_pointer var = car(p); + if ((is_pair(var)) && + (is_symbol(car(var))) && + (is_pair(cdr(var)))) + { + const s7_pointer sym = car(var); + if (is_constant_symbol(sc, sym)) + {end_small_symbol_set(sc); return_false(sc, expr);} + if (symbol_is_in_small_symbol_set(sc, sym)) + syntax_error_nr(sc, "duplicate identifier in do: ~A", 30, var); + add_symbol_to_small_symbol_set(sc, sym); + add_slot(sc, let, sym, sc->undefined); + } + else {end_small_symbol_set(sc); return_false(sc, expr);} + } + end_small_symbol_set(sc); + if (is_not_slot_end(let_slots(let))) + let_set_slots(let, reverse_slots(let_slots(let))); + + /* inits */ + { + s7_pointer slot = let_slots(let); + init_pc = sc->pc; + { + s7_pointer p = vars; + for (int32_t k = 0; (is_pair(p)) && (k < num_vunions); k++, p = cdr(p), slot = next_slot(slot)) + { + const 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, expr); + if (is_pair(cddr(var))) + { + set_has_stepper(slot); + if (!is_null(cdddr(var))) + return_false(sc, expr); + } + else + { + step_len--; + if (!is_null(cddr(var))) + return_false(sc, expr); + } + /* we can't use slot_set_value(slot, q_call(init_o[k]).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(s7_t_slot(sc, cadr(var)))); + 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 = 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 (s7_pointer p = vars; is_pair(p); p = cdr(p)) + { + const s7_pointer var = car(p); + if (is_pair(cddr(var))) + { + s7_pointer 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_gc_protect(sc); /* not pop_stack! */ + set_curlet(sc, old_let); + return_false(sc, expr); + }}}} + + /* end test */ + end_test_pc = sc->pc; + if (!bool_optimize_nw(sc, endp)) + { + unstack_gc_protect(sc); /* not pop_stack! */ + set_curlet(sc, old_let); + return_false(sc, expr); + } + { + const s7_pointer stop = car(endp); + 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))))) + { + const s7_pointer stop_slot = (is_symbol(caddr(stop))) ? opt_integer_symbol(sc, caddr(stop)) : sc->nil; + if (stop_slot) + { + s7_int lim = (is_slot(stop_slot)) ? integer(slot_value(stop_slot)) : integer(caddr(stop)); + bool set_stop = false; + if (car(stop) == sc->gt_symbol) lim++; + for (s7_pointer p = vars, 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)) + { + const 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_has_loop_end(slot); + slot_set_value(slot, make_mutable_integer(sc, integer(slot_value(slot)))); + set_loop_end(slot, lim); + }}} + + if (!set_stop) + { + const s7_pointer slot2 = opt_integer_symbol(sc, cadr(stop)); + if ((slot2) && + (stop_is_safe(sc, cadr(stop), cddr(expr)))) /* b_fft in tfft.scm */ + { + set_has_loop_end(slot2); + set_loop_end(slot2, lim); + }}}}} + + /* body */ + body_index = sc->pc; + { + s7_pointer p = cdddr(expr); + for (int32_t k = 0; k < len - 3; k++, p = cdr(p)) /* len (from p_syntax_ok)=form length (do body...) */ + { + opt_info *start = sc->opts[sc->pc]; + body_o[k] = start; + sc->do_body_p = car(p); /* a horrible kludge, but I have run out of type bits for pairs */ + /* if (i < 5) opc-v[i + 7].o1 = start; *//* why this? */ + if (!cell_optimize(sc, p)) + break; + oo_idp_nr_fixup(start); + } + sc->do_body_p = NULL; + if (!is_null(p)) + { + unstack_gc_protect(sc); + set_curlet(sc, old_let); + return_false(sc, expr); + }} + + /* 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; + { + s7_pointer p = vars; + for (int32_t k = 0; is_pair(p); k++, p = cdr(p)) + { + const 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_gc_protect(sc); + set_curlet(sc, old_let); + return_false(sc, expr); + }} + + /* result */ + if (!is_list(cdr(endp))) + { + unstack_gc_protect(sc); + set_curlet(sc, old_let); + return_false(sc, expr); + } + { + s7_pointer p = cdr(endp); + for (return_exprs = 0; (is_pair(p)) && (return_exprs < num_vunions); p = cdr(p), return_exprs++) + { + return_o[return_exprs] = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) + break; + } + if (!is_null(p)) + { + unstack_gc_protect(sc); + set_curlet(sc, old_let); + return_false(sc, expr); + }} + + do_curlet_unchecked(opc) = T_Let(let); + do_body_length(opc) = len - 3; + do_result_length(opc) = return_exprs; + do_stepper_opt(opc) = sc->opts[step_pc]; + set_curlet(sc, old_let); + + if ((var_len == 0) && (return_exprs == 0)) + { + opt_info *body; + do_no_vars_test(opc) = sc->opts[end_test_pc]; + q_call(opc).fp = opt_do_no_vars; + if (body_len > 0) + { + body = alloc_opt_info(sc); + for (int32_t k = 0; k < body_len; k++) + do_expr(body, k).o1 = body_o[k]; + do_no_vars_body(opc) = body; + } + return_true(sc, expr); + } + do_stepper_safe(opc) = 0; + if (body_len == 1) + { + const s7_pointer expr3 = cadddr(expr); /* 1 expr in body */ + if ((is_pair(expr3)) && + ((is_c_function(car(expr3))) || /* (#_sqrt 2.0)?? */ + (is_safe_setter(car(expr3))) || /* (byte-vector-set! iv 1 0) */ + ((car(expr3) == sc->set_symbol) && /* (set! sum (+ sum 1)) */ + (cadr(expr3) != caar(vars))) || /* caadr: (stepper init ...) */ + ((car(expr3) == sc->vector_set_symbol) && + (is_null(cddddr(expr3))) && + (is_code_constant(sc, cadddr(expr3)))))) + do_stepper_safe(opc) = 1; /* checked in opt_do_1 */ + } + if ((var_len != 1) || (step_len != 1) || (return_exprs != 0)) + { + opt_info *inits; + q_call(opc).fp = ((step_len == 1) && (body_len == 1) && (return_exprs == 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 ((q_call(opc).fp == opt_do_step_1) && + (q_call(do_stepper_opt(opc)).fp == i_to_p) && + (q_temp(do_stepper_opt(opc)).fi == opt_i_ii_sc_add) && + (q_call(do_any_test(opc)).fb == opt_b_ii_ss_eq)) + q_call(opc).fp = opt_do_step_i; + + inits = alloc_opt_info(sc); + for (int32_t k = 0; k < var_len; k++) + do_expr(inits, k).o1 = init_o[k]; + do_any_inits(opc) = inits; + + if (q_call(opc).fp == opt_do_any) + { + opt_info *result, *step; + opt_info *body = alloc_opt_info(sc); + + for (int32_t k = 0; k < body_len; k++) + do_expr(body, k).o1 = body_o[k]; + do_any_body(opc) = body; + + result = alloc_opt_info(sc); + for (int32_t k = 0; k < return_exprs; k++) + do_expr(result, k).o1 = return_o[k]; + do_any_results(opc) = result; + + step = alloc_opt_info(sc); + for (int32_t k = 0; k < var_len; k++) + do_expr(step, 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(sc, expr); + } + + q_call(opc).fp = (body_len == 1) ? opt_do_1 : opt_do_n; + { + const s7_pointer ind = caar(vars); + const s7_pointer ind_step = caddar(vars); + const s7_pointer end = caaddr(expr); + if (body_len == 1) /* opt_do_1 */ + do_any_body(opc) = sc->opts[body_index]; + else + { + opt_info *body = alloc_opt_info(sc); + for (int32_t k = 0; k < body_len; k++) + do_expr(body, 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 loop_end_possible 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(expr), ind, vars, &has_set))) + { + const s7_pointer slot = let_slots(let); + let_set_dox_slot1(let, slot); + let_set_dox_slot2_unchecked(let, (is_symbol(caddr(end))) ? s7_t_slot(sc, caddr(end)) : sc->undefined); /* undefined_slot? */ + slot_set_value(slot, make_mutable_integer(sc, integer(slot_value(slot)))); + /* do_body_start(opc).i = body_index; */ /* start point (sc->pc) for body, apparently never used */ + if (body_len == 1) /* opt_do_1 */ + { + const opt_info *o1 = sc->opts[body_index]; + q_call(opc).fp = opt_do_very_simple; + if (is_t_integer(caddr(end))) + do_end(opc).i = integer(caddr(end)); + if (q_call(o1).fp == d_to_p_nr) /* snd-test: (do ((k 0 (+ k 1))) ((= k N)) (float-vector-set! rl k (read-sample rd))) */ + { + q_call(opc).fp = opt_do_prepackaged; + do_dpnr_func(opc).fp = opt_do_dpnr; + } + else + if (q_call(o1).fp == i_to_p_nr) + { + q_call(opc).fp = opt_do_prepackaged; + do_dpnr_func(opc).fp = opt_do_ipnr; + }} + else + { + q_call(opc).fp = opt_do_times; + if (is_t_integer(caddr(end))) + do_times_end(opc).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(expr), ind, vars, &has_set))) + q_call(opc).fp = opt_do_list_simple; + }} + return_true(sc, expr); +} + +static bool p_syntax_ok(s7_scheme *sc, s7_pointer expr, int32_t len) +{ + const s7_pointer func = lookup_global(sc, car(expr)); + opcode_t op; + if (OPT_PRINT) fprintf(stderr, " p_syntax_ok[%d]: %s\n", __LINE__, display(expr)); + if (!is_syntax(func)) {clear_syntactic(expr); return_false(sc, expr);} + /* I think this is the only case where we don't precede syntax_opcode with syntactic_symbol checks */ + op = syntax_opcode(func); + switch (op) + { + case OP_QUOTE: if ((is_pair(cdr(expr))) && (is_null(cddr(expr)))) return(opt_cell_quote(sc, expr)); break; + case OP_SET: if (len == 3) return(opt_cell_set(sc, expr)); break; + case OP_BEGIN: if (len > 1) return(opt_cell_begin(sc, expr, len)); break; + case OP_WHEN: + case OP_UNLESS: if (len > 2) return(opt_cell_when(sc, expr, len)); break; + case OP_COND: if (len > 1) return(opt_cell_cond(sc, expr)); break; + case OP_CASE: if (len > 2) return(opt_cell_case(sc, expr)); break; + case OP_AND: + case OP_OR: return(opt_cell_and(sc, expr, len)); + case OP_IF: return(opt_cell_if(sc, expr, len)); + case OP_DO: return(opt_cell_do(sc, expr, len)); + case OP_LET_TEMPORARILY: return(opt_cell_let_temporarily(sc, expr, len)); + default: + /* for lambda et al we'd return the new closure, but if unsafe? + * let(*) -> make the let -> body (let=99% of cases), could we use do (i.e. do+no steppers+no end!) or let-temp? + * with-let -> establish car(args)=let, then body + * macroexpand -> return the expansion + * define et al -> define + return value + * map and for-each are not syntax, also call-with*(=exit) + * also let-temp for vars>1 + */ + break; + } + return_false(sc, expr); +} + + +/* -------------------------------------------------------------------------------- */ +static bool float_optimize_1(s7_scheme *sc, s7_pointer form) +{ + const s7_pointer expr = car(form); + s7_pointer head, s_func, s_slot = NULL; + s7_int len; + if (OPT_PRINT) fprintf(stderr, " float_optimize[%d] %s\n", __LINE__, display(form)); + + if (!is_pair(expr)) /* wrap constants/symbols */ + return_bool(sc, opt_float_not_pair(sc, expr), expr); + head = car(expr); + len = s7_list_length(sc, expr); + if (is_symbol(head)) + { + if ((is_syntactic_symbol(head)) || + (is_syntactic_pair(expr))) + return_bool(sc, d_syntax_ok(sc, expr, len), expr); + + s_slot = s7_slot(sc, head); + if (!is_slot(s_slot)) return_false(sc, expr); + s_func = slot_value(s_slot); + } + else + if (is_c_function(head)) + s_func = head; + else return_false(sc, expr); + + if (is_c_function(s_func)) + { + opt_info *opc = alloc_opt_info(sc); + switch (len) + { + case 1: + return_bool(sc, d_ok(sc, opc, s_func), expr); + case 2: /* (f v) or (f d): (env e) or (abs x) */ + return_bool(sc, ((d_d_ok(sc, opc, s_func, expr)) || + (d_v_ok(sc, opc, s_func, expr)) || + (d_p_ok(sc, opc, s_func, expr))), expr); + case 3: + return_bool(sc, ((d_dd_ok(sc, opc, s_func, expr)) || + (d_id_ok(sc, opc, s_func, expr)) || + (d_vd_ok(sc, opc, s_func, expr)) || + (d_pd_ok(sc, opc, s_func, expr)) || + (d_ip_ok(sc, opc, s_func, expr)) || + (d_7pi_ok(sc, opc, s_func, expr))), expr); + case 4: + return_bool(sc, ((d_ddd_ok(sc, opc, s_func, expr)) || + (d_7pid_ok(sc, opc, s_func, expr)) || + (d_vid_ok(sc, opc, s_func, expr)) || + (d_vdd_ok(sc, opc, s_func, expr)) || + (d_7pii_ok(sc, opc, s_func, expr))), expr); + case 5: + return_bool(sc, ((d_dddd_ok(sc, opc, s_func, expr)) || + (d_7piid_ok(sc, opc, s_func, expr)) || + (d_7piii_ok(sc, opc, s_func, expr))), expr); + case 6: + if (d_7piiid_ok(sc, opc, s_func, expr)) + return_true(sc, expr); + /* fall through */ + + default: + return_bool(sc, d_add_any_ok(sc, opc, expr), expr); + }} + else + { + if ((is_macro(s_func)) && (!no_cell_opt(form))) + { + const s7_pointer body = closure_body(s_func); + if ((is_null(cdr(body))) && (is_pair(car(body))) && + ((caar(body) == sc->list_symbol) || (caar(body) == sc->list_values_symbol) || (is_eq_initial_c_function_data(sc->list_values_symbol, caar(body))))) + { + const s7_pointer result = s7_macroexpand(sc, s_func, cdar(form)); + if (result == sc->F) return_false(sc, expr); + return(float_optimize(sc, set_plist_1(sc, result))); + }} + if (!s_slot) return_false(sc, expr); + return_bool(sc, d_implicit_ok(sc, s_slot, expr, len), expr); + } + return_false(sc, expr); +} + +static bool float_optimize(s7_scheme *sc, s7_pointer expr) {return((float_optimize_1(sc, expr)) && (sc->pc < OPTS_SIZE));} +/* combining the sc->pc check into float_optimize_1 (and similarly for the other 3 cases) does not given any speedup */ + +static bool int_optimize_1(s7_scheme *sc, s7_pointer form) +{ + const s7_pointer expr = car(form); + s7_pointer head, s_func, s_slot = NULL; + s7_int len; + + if (OPT_PRINT) fprintf(stderr, " int_optimize %s\n", display(form)); + + if (!is_pair(expr)) /* wrap constants/symbols */ + return_bool(sc, opt_int_not_pair(sc, expr), expr); + head = car(expr); + len = s7_list_length(sc, expr); + if (is_symbol(head)) + { + if ((is_syntactic_symbol(head)) || + (is_syntactic_pair(expr))) + return_bool(sc, i_syntax_ok(sc, expr, len), expr); + s_slot = s7_slot(sc, head); + if (!is_slot(s_slot)) return_false(sc, expr); + s_func = slot_value(s_slot); + } + else + if (is_c_function(head)) + s_func = head; + else return_false(sc, expr); + + if (is_c_function(s_func)) + { + opt_info *opc = alloc_opt_info(sc); + switch (len) + { + case 2: + return_bool(sc, i_idp_ok(sc, opc, s_func, expr), expr); + case 3: + return_bool(sc, ((i_ii_ok(sc, opc, s_func, expr)) || + (i_7pi_ok(sc, opc, s_func, expr))), expr); + case 4: + return_bool(sc, ((i_iii_ok(sc, opc, s_func, expr)) || + (i_7pii_ok(sc, opc, s_func, expr))), expr); + case 5: + { + int32_t pstart = sc->pc; + if (i_7piii_ok(sc, opc, s_func, expr)) + return_true(sc, expr); + sc->pc = pstart; + } + /* fall through */ + default: + return_bool(sc, (((head == sc->add_symbol) || + (head == sc->multiply_symbol)) && + (i_add_any_ok(sc, opc, expr))), expr); + }} + else + { +#if 0 + /* if (is_closure(s_func)) and body is one expr and safe, we could pull out the body, substitute pars for args, int_optimize that */ + /* check for simple args and no definers/binders first (can't int-optimize them anyway) */ + if ((is_closure(s_func)) && (is_safe_closure(s_func)) && (!no_cell_opt(form))) + { + const s7_pointer body = closure_body(s_func); + if ((is_null(cdr(body))) && (is_pair(car(body)))) /* this hits every test in s7test! */ + { + if (caar(body) != sc->let_symbol) + fprintf(stderr, "%s[%d]: %s %s\n", __func__, __LINE__, display(body), display(form)); + /* see s7test (f3 123) -- expansion can lead to funclet confusion -- same in macros? but this would not be int_optimizable */ + /* timing tests don't get many useful hits */ + }} +#endif + if ((is_macro(s_func)) && (!no_cell_opt(form))) + { + const s7_pointer body = closure_body(s_func); + if ((is_null(cdr(body))) && (is_pair(car(body))) && + ((caar(body) == sc->list_symbol) || (caar(body) == sc->list_values_symbol) || (is_eq_initial_c_function_data(sc->list_values_symbol, caar(body))))) + { + s7_pointer result = s7_macroexpand(sc, s_func, cdar(form)); /* cdar(form) = arglist */ + if (result == sc->F) return_false(sc, expr); + return(int_optimize(sc, set_plist_1(sc, result))); + }} + if (!s_slot) return_false(sc, expr); + return_bool(sc, i_implicit_ok(sc, s_slot, expr, len), expr); + } + return_false(sc, expr); +} + +static bool int_optimize(s7_scheme *sc, s7_pointer expr) {return((int_optimize_1(sc, expr)) && (sc->pc < OPTS_SIZE));} + +/* cell_optimize... */ +static bool p_2x_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr, int32_t pstart, s7_pointer form) +{ + const s7_pointer sig = c_function_signature(s_func); + if (is_symbol(cadr(expr))) + { + 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, expr)) + return_true(sc, expr); + + if ((car(sig) == sc->is_float_symbol) || + (car(sig) == sc->is_real_symbol)) + { + const s7_d_7pi_t func = s7_d_7pi_function(s_func); + if (func) + { + sc->pc = pstart - 1; + if (float_optimize(sc, form)) + { + q_temp(opc).fd = q_call(opc).fd; + q_call(opc).fp = d_to_p; + return_true(sc, expr); + }}} + sc->pc = pstart; + }} + { + const s7_i_ii_t ifunc = s7_i_ii_function(s_func); + sc->pc = pstart - 1; + if ((ifunc) && + (int_optimize(sc, form))) + { + q_temp(opc).fi = q_call(opc).fi; + q_call(opc).fp = i_to_p; + if (q_temp(opc).fi == opt_i_ii_ss_add) + q_call(opc).fp = opt_p_ii_ss_add; + return_true(sc, expr); + }} + sc->pc = pstart; + return_bool(sc, ((p_ii_ok(sc, opc, s_func, expr, pstart)) || + (p_dd_ok(sc, opc, s_func, expr, pstart)) || + (p_pp_ok(sc, opc, s_func, expr, pstart)) || + (p_call_pp_ok(sc, opc, s_func, expr, pstart))), expr); +} + +static bool p_3x_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr, int32_t pstart) +{ + const s7_pointer sig = c_function_signature(s_func); + if (is_symbol(cadr(expr))) + { + if ((is_pair(sig)) && (is_pair(cdr(sig))) && (is_pair(cddr(sig))) && + (caddr(sig) == sc->is_integer_symbol)) + { + 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, expr))) + { + /* if d_7pid is ok, we need d_to_p for cell_optimize */ + q_temp(opc).fd = q_call(opc).fd; + q_call(opc).fp = d_to_p; + return_true(sc, expr); + } + + sc->pc = pstart - 1; + if ((car(sig) == sc->is_integer_symbol) && + (s7_i_7pii_function(s_func)) && + (i_7pii_ok(sc, alloc_opt_info(sc), s_func, expr))) + { + q_temp(opc).fi = q_call(opc).fi; + q_call(opc).fp = i_to_p; + return_true(sc, expr); + } + sc->pc = pstart; + + if (p_pii_ok(sc, opc, s_func, expr)) + return_true(sc, expr); + if (p_pip_ok(sc, opc, s_func, expr)) + return_true(sc, expr); + }} + return_bool(sc, ((p_ppi_ok(sc, opc, s_func, expr)) || + (p_ppp_ok(sc, opc, s_func, expr)) || + (p_call_ppp_ok(sc, opc, s_func, expr))), expr); +} + +static bool p_4x_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr, int32_t pstart) +{ + const s7_pointer head = car(expr); + const s7_int len = s7_list_length(sc, expr); + + if ((is_target_or_its_alias(head, s_func, sc->float_vector_set_symbol)) && + (d_7piid_ok(sc, opc, s_func, expr))) + { + q_temp(opc).fd = q_call(opc).fd; + q_call(opc).fp = d_to_p; /* as above, if d_7piid is ok, we need d_to_p for cell_optimize */ + return_true(sc, expr); + } + if ((is_target_or_its_alias(head, s_func, sc->float_vector_ref_symbol)) && + (d_7piii_ok(sc, opc, s_func, expr))) + { + q_temp(opc).fd = q_call(opc).fd; + q_call(opc).fp = d_to_p; + return_true(sc, expr); + } + if (i_7piii_ok(sc, opc, s_func, expr)) + { + q_temp(opc).fi = q_call(opc).fi; + q_call(opc).fp = i_to_p; + return_true(sc, expr); + } + if (is_target_or_its_alias(head, s_func, sc->int_vector_set_symbol)) + return_false(sc, expr); + if (p_piip_ok(sc, opc, s_func, expr)) + return_true(sc, expr); + sc->pc = pstart; + if (s_func == global_value(sc->vector_ref_symbol)) + { + s7_pointer obj; + if (!is_symbol(cadr(expr))) return_false(sc, expr); + obj = lookup_unexamined(sc, cadr(expr)); /* was lookup_from (to avoid the unbound variable check) */ + if ((!obj) || (!is_any_vector(obj)) || (vector_rank(obj) != 3)) + return_false(sc, expr); + } + return_bool(sc, p_call_any_ok(sc, opc, s_func, expr, len), expr); +} + +static bool p_5x_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr, int32_t pstart) +{ + const s7_pointer head = car(expr); + if ((is_target_or_its_alias(head, s_func, sc->float_vector_set_symbol)) && + (d_7piiid_ok(sc, opc, s_func, expr))) + { + q_temp(opc).fd = q_call(opc).fd; + q_call(opc).fp = d_to_p; + return_true(sc, expr); + } + return_false(sc, expr); +} + +#if OPT_PRINT +static bool cell_optimize_1(s7_scheme *sc, s7_pointer form, int line) +#else +static bool cell_optimize_1(s7_scheme *sc, s7_pointer form) +#endif +{ + const s7_pointer expr = car(form); + s7_pointer head, s_func, s_slot = NULL; + s7_int len; +#if OPT_PRINT /* needed due to line arg */ + fprintf(stderr, " cell_optimize[%d] %s\n", line, display(form)); +#endif + if (!is_pair(expr)) /* wrap constants/symbols */ + return(opt_cell_not_pair(sc, expr)); + + head = car(expr); + len = s7_list_length(sc, expr); + if (is_symbol(head)) + { + if ((is_syntactic_symbol(head)) || + (is_syntactic_pair(expr))) /* this can be wrong! */ + return_bool(sc, p_syntax_ok(sc, expr, len), expr); + + s_slot = s7_slot(sc, head); + if (!is_slot(s_slot)) return_false(sc, expr); + s_func = slot_value(s_slot); + } + else + if (is_c_function(head)) /* (#_abs -1) I think */ + s_func = head; + else + { /* ((let-ref L 'mult) 1 2) or 'a etc */ + if ((head == sc->quote_function) && + ((is_pair(cdr(expr))) && (is_null(cddr(expr))))) + return_bool(sc, opt_cell_quote(sc, expr), expr); + + /* if head is ([let-ref] L 'multiply), it should be accessible now, so we could do the lookup, set up s_func and go on */ + /* but this is not safe if there's a let-set! or (set! (let...)...) in the body and this let-ref is the car */ + if (is_pair(head)) + { + s7_pointer let, sym; + if ((car(head) == sc->let_ref_symbol) && (s7_list_length(sc, head) == 3)) + { + let = cadr(head); + sym = caddr(head); + } + else + if (s7_list_length(sc, head) == 2) + { + let = car(head); + sym = cadr(head); + } + else + if (((car(head) == sc->unlet_symbol) || (car(head) == sc->rootlet_symbol)) && (is_pair(cdr(expr)))) /* ((unlet) :abs) */ + { + sym = cadr(expr); + if ((is_symbol_and_keyword(sym)) || (is_quoted_symbol(sc, sym))) + return_bool(sc, opt_unlet_rootlet_ref(sc, alloc_opt_info(sc), head, (is_pair(sym)) ? cadr(sym) : keyword_symbol(sym), expr), expr); + return_false(sc, expr); + } + else return_false(sc, expr); + if ((is_symbol(let)) && ((is_symbol_and_keyword(sym)) || (is_quoted_symbol(sc, sym)))) + { + const s7_pointer slot = s7_t_slot(sc, let); + if (!is_slot(slot)) return_false(sc, expr); + let = slot_value(slot); + if ((!is_let(let)) || (has_let_ref_fallback(let))) return_false(sc, expr); + sym = (is_pair(sym)) ? cadr(sym) : keyword_symbol(sym); + s_func = let_ref_p_pp(sc, let, sym); + } + else return_false(sc, expr); + } + else return_false(sc, expr); + } + if (is_c_function(s_func)) + { + opt_info *opc = alloc_opt_info(sc); + switch (len) + { + case 1: return_bool(sc, p_ok(sc, opc, s_func, expr), expr); + case 2: return_bool(sc, ((p_i_ok(sc, opc, s_func, expr, sc->pc)) || + (p_d_ok(sc, opc, s_func, expr, sc->pc)) || + (p_p_ok(sc, opc, s_func, expr))), expr); + case 3: return_bool(sc, p_2x_ok(sc, opc, s_func, expr, sc->pc, form), expr); + case 4: return_bool(sc, p_3x_ok(sc, opc, s_func, expr, sc->pc), expr); + case 5: return_bool(sc, p_4x_ok(sc, opc, s_func, expr, sc->pc), expr); + case 6: if (p_5x_ok(sc, opc, s_func, expr, sc->pc)) return_true(sc, expr); + /* fall through */ + default: return_bool(sc, p_call_any_ok(sc, opc, s_func, expr, len), expr); /* >3D vector-set etc */ + }} + else + { + if (is_closure(s_func)) + { + opt_info *opc = alloc_opt_info(sc); + if (p_fx_any_ok(sc, opc, form)) + return_true(sc, expr); + } + if (is_macro(s_func)) + return_false(sc, expr); /* macroexpand+cell_optimize here restarts the optimize process (this refers to int|float_optimize macro expansion) */ + if (!s_slot) return_false(sc, expr); + return_bool(sc, p_implicit_ok(sc, s_slot, expr, len), expr); + } + return_false(sc, expr); +} + +#if OPT_PRINT +static bool cell_optimize_with_line(s7_scheme *sc, s7_pointer expr, int line) {return((cell_optimize_1(sc, expr, line)) && (sc->pc < OPTS_SIZE));} +#else +static bool cell_optimize(s7_scheme *sc, s7_pointer expr) {return((cell_optimize_1(sc, expr)) && (sc->pc < OPTS_SIZE));} +#endif + +static bool bool_optimize_nw_1(s7_scheme *sc, s7_pointer form) +{ + const s7_pointer expr = car(form); + s7_pointer head, s_func = NULL; + s7_int len; + if (!is_pair(expr)) /* wrap constants/symbols */ + return_bool(sc, opt_bool_not_pair(sc, expr), expr); + + head = car(expr); + len = s7_list_length(sc, expr); + if (is_symbol(head)) + { + if ((is_syntactic_symbol(head)) || + (is_syntactic_pair(expr))) + { + if (head == sc->and_symbol) + return_bool(sc, opt_b_and(sc, expr, len), expr); + if (head == sc->or_symbol) + return_bool(sc, opt_b_or(sc, expr, len), expr); + return_false(sc, expr); + } + s_func = lookup_unexamined(sc, head); + } + else + if (is_c_function(head)) + s_func = head; + else return_false(sc, expr); + + if (!s_func) return_false(sc, expr); + if (is_c_function(s_func)) + { + if ((is_symbol(head)) && (!is_global(head))) /* (float-vector? (block)) -- both safe c_funcs, but this is a method invocation */ + return_false(sc, expr); + switch (len) + { + case 2: + return_bool(sc, b_idp_ok(sc, s_func, form, opt_arg_type(sc, cdr(expr))), form); + case 3: + { + s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); + s7_pointer sig1 = opt_arg_type(sc, cdr(expr)); + s7_pointer sig2 = opt_arg_type(sc, cddr(expr)); + opt_info *opc = alloc_opt_info(sc); + int32_t cur_index = sc->pc; + s7_b_7pp_t bpf7 = NULL; + s7_b_pp_t bpf; + + if ((sig2 == sc->is_integer_symbol) || (sig2 == sc->is_byte_symbol)) + { + if (((sig1 == sc->is_integer_symbol) || (sig1 == sc->is_byte_symbol)) && + (b_ii_ok(sc, opc, s_func, expr, arg1, arg2))) + return_true(sc, expr); + sc->pc = cur_index; + if (b_pi_ok(sc, opc, s_func, expr, arg2)) + return_true(sc, expr); + sc->pc = cur_index; + } + + if ((sig1 == sc->is_float_symbol) && + (sig2 == sc->is_float_symbol) && + (b_dd_ok(sc, opc, s_func, expr, arg1, arg2))) + return_true(sc, expr); + sc->pc = cur_index; + + bpf = s7_b_pp_function(s_func); + if (!bpf) bpf7 = s7_b_7pp_function(s_func); + if ((bpf) || (bpf7)) + { + if (bpf) + q_func(opc).b_pp_f = bpf; + else q_func(opc).b_7pp_f = bpf7; + return(b_pp_ok(sc, opc, s_func, expr, arg1, arg2, bpf)); + }} + break; + default: break; + }} + return_false(sc, expr); +} + +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) +{ + const int32_t start = sc->pc; + opt_info *wrapper; + if (OPT_PRINT) fprintf(stderr, " bool_optimize %s\n", display(expr)); + if (bool_optimize_nw(sc, expr)) + return_true(sc, expr); + sc->pc = start; + wrapper = sc->opts[start]; + if (!cell_optimize(sc, expr)) + return_false(sc, expr); + if (q_temp(wrapper).fp) /* (when (+ i 1) ...) */ + return_false(sc, expr); + q_temp(wrapper).fp = q_call(wrapper).fp; + q_call(wrapper).fb = p_to_b; + return_true(sc, expr); +} + +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_success(sc, opt_bool_any, expr); + return_null(sc, expr); +} + +static s7_double opt_float_any(s7_scheme *sc) {return(q_call(sc->opts[0]).fd(sc->opts[0]));} /* for snd-sig.c */ + +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); /* can't return_null(sc, expr) here due to type mismatch (s7_pfunc vs s7_float_function) */ +} + +static s7_pfunc s7_optimize_1(s7_scheme *sc, s7_pointer expr, bool nv) +{ + if ((!is_pair(expr)) || (no_cell_opt(expr)) || (sc->debug != 0)) + return_null(sc, expr); + sc->pc = 0; + if (!no_int_opt(expr)) + { + if (int_optimize(sc, expr)) + return_success(sc, (nv) ? opt_int_any_nv : opt_make_int, expr); + sc->pc = 0; + set_no_int_opt(expr); + } + if (!no_float_opt(expr)) + { + if (float_optimize(sc, expr)) + return_success(sc, (nv) ? opt_float_any_nv : opt_make_float, expr); + sc->pc = 0; + set_no_float_opt(expr); + } + if (!no_bool_opt(expr)) + { + if (bool_optimize_nw(sc, expr)) + return_success(sc, (nv) ? opt_bool_any_nv : opt_wrap_bool, expr); + sc->pc = 0; + set_no_bool_opt(expr); + } + if (cell_optimize(sc, expr)) + return_success(sc, (nv) ? opt_cell_any_nv : 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));} +static s7_pfunc s7_optimize_nv(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-optimize in scheme */ +{ + s7_pfunc func; + s7_pointer code = car(args), result = sc->undefined; + gc_protect_via_stack(sc, code); + func = s7_optimize(sc, code); + if (func) result = func(sc); + if (stack_top_op(sc) == OP_GC_PROTECT) unstack_gc_protect(sc); + return(result); +} + +static s7_pfunc s7_cell_optimize(s7_scheme *sc, s7_pointer expr, bool nv) +{ + if (OPT_PRINT) fprintf(stderr, " s7_cell_optimize %s\n", display(expr)); + sc->pc = 0; + if ((cell_optimize(sc, expr)) && (sc->pc < OPTS_SIZE)) + return((nv) ? opt_cell_any_nv : opt_wrap_cell); + return_null(sc, expr); +} + + +/* ---------------- bool funcs (an experiment) ---------------- */ +static void fx_curlet_tree(s7_scheme *sc, s7_pointer code) +{ + s7_pointer slot1 = let_slots(sc->curlet), slot3 = NULL, outer_e; + bool more_vars; + s7_pointer slot2 = next_slot(slot1); + if (is_not_slot_end(slot2)) slot3 = next_slot(slot2); + + more_vars = (is_not_slot_end(slot3)) && (is_not_slot_end(next_slot(slot3))); + fx_tree(sc, code, + slot_symbol(slot1), + (is_not_slot_end(slot2)) ? slot_symbol(slot2) : NULL, + (is_not_slot_end(slot3)) ? slot_symbol(slot3) : NULL, + more_vars); + + outer_e = let_outlet(sc->curlet); + if ((!more_vars) && + (is_let(outer_e)) && + (!is_funclet(outer_e)) && + (is_not_slot_end(let_slots(outer_e))) && + (slot_symbol(let_slots(outer_e)) != slot_symbol(slot1))) + { + slot1 = let_slots(outer_e); + slot2 = next_slot(slot1); + slot3 = (is_not_slot_end(slot2)) ? next_slot(slot2) : NULL; + fx_tree_outer(sc, code, + slot_symbol(slot1), + (is_not_slot_end(slot2)) ? slot_symbol(slot2) : NULL, + (is_not_slot_end(slot3)) ? slot_symbol(slot3) : NULL, + (is_not_slot_end(slot3)) && (is_not_slot_end(next_slot(slot3)))); + } +} + +static void fx_curlet_tree_in(s7_scheme *sc, s7_pointer code) +{ + s7_pointer slot1 = let_slots(sc->curlet), slot3 = NULL; + s7_pointer slot2 = next_slot(slot1); + if (is_not_slot_end(slot2)) slot3 = next_slot(slot2); + fx_tree_in(sc, code, + slot_symbol(slot1), + (is_not_slot_end(slot2)) ? slot_symbol(slot2) : NULL, + (is_not_slot_end(slot3)) ? slot_symbol(slot3) : NULL, + (is_not_slot_end(slot3)) && (is_not_slot_end(next_slot(slot3)))); +} + +typedef bool (*s7_bfunc)(s7_scheme *sc, s7_pointer expr); /* used in eval */ + +static bool fb_lt_ss(s7_scheme *sc, s7_pointer expr) +{ + s7_pointer x = lookup(sc, cadr(expr)); + s7_pointer y = lookup(sc, opt1_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_lt_ts(s7_scheme *sc, s7_pointer expr) +{ + s7_pointer x = t_lookup(sc, cadr(expr), expr); + s7_pointer y = lookup(sc, opt1_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 = lookup(sc, cadr(expr)); + s7_pointer y = lookup(sc, opt1_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 = 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 = 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 = t_lookup(sc, cadr(expr), expr), y = u_lookup(sc, opt1_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 = s_lookup(sc, cadr(expr), expr); + s7_pointer y = s_lookup(sc, opt1_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 = s_lookup(sc, cadr(expr), expr); + s7_pointer y = s_lookup(sc, opt1_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 = s_lookup(sc, cadr(expr), expr); + s7_pointer y = s_lookup(sc, opt1_sym(cdr(expr)), expr); + return(((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) <= integer(y)) : leq_b_7pp(sc, x, y)); +} + +static bool fb_leq_ti(s7_scheme *sc, s7_pointer expr) +{ + s7_pointer x = t_lookup(sc, cadr(expr), expr); + if (is_t_integer(x)) return(integer(x) <= integer(opt1_con(cdr(expr)))); + return(g_leq_xi(sc, set_plist_2(sc, x, opt1_con(cdr(expr))))); +} + +static bool fb_leq_ui(s7_scheme *sc, s7_pointer expr) +{ + s7_pointer x = u_lookup(sc, cadr(expr), expr); + if (is_t_integer(x)) return(integer(x) <= integer(opt1_con(cdr(expr)))); + return(g_leq_xi(sc, set_plist_2(sc, x, opt1_con(cdr(expr))))); +} + +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_lt_ts) return((s7_pointer)fb_lt_ts); + 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_leq_ti) return((s7_pointer)fb_leq_ti); + if (fx == fx_leq_ui) return((s7_pointer)fb_leq_ui); + 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); +} + +static void fb_annotate(s7_scheme *sc, s7_pointer form, s7_pointer fx_expr, opcode_t op) +{ + s7_pointer bfunc; + if ((is_fx_treeable(cdr(form))) && (curlet_has_slots(sc))) fx_curlet_tree(sc, cdr(form)); /* and not already treed? just the one expr? */ + bfunc = fx_to_fb(sc, fx_proc(fx_expr)); + if (bfunc) + { + set_opt3_any(cdr(form), bfunc); + pair_set_syntax_op(form, op); + } +#if 0 + /* fb_annotate additions? [these currently require new "B" ops] */ + else + { + fprintf(stderr, "fx: %s %s\n", ((is_pair(fx_expr)) && (is_pair(car(fx_expr)))) ? op_names[optimize_op(car(fx_expr))] : "", display_truncated(fx_expr)); + if (caar(fx_expr) == sc->num_eq_symbol) abort(); + /* [fx_leq_ti] fx_lt_t0 fx_gt_ti fx_num_eq_u0 */ + } +#endif +} + +/* when_b cond? do end-test? num_eq_vs|us */ + + +/* ---------------------------------------- for-each ---------------------------------------- */ +static Inline s7_pointer inline_make_counter(s7_scheme *sc, s7_pointer iter) /* all calls are hit about the same: lg/sg */ +{ + s7_pointer new_counter; + new_cell(sc, new_counter, T_COUNTER); + counter_set_result(new_counter, sc->nil); + if ((S7_DEBUGGING) && (!is_iterator(iter)) && (!is_pair(iter))) fprintf(stderr, "%s[%d]: %s?\n", __func__, __LINE__, display(iter)); + counter_set_list(new_counter, iter); /* iterator -- here it's always either an iterator or a pair */ + counter_set_capture(new_counter, 0); /* will be capture_let_counter */ + counter_set_let(new_counter, sc->rootlet); /* will be the saved let */ + counter_set_slots(new_counter, slot_end); /* local let slots before body is evalled */ + stack_set_has_counters(sc->stack); + return(new_counter); +} + +static s7_pointer make_iterators(s7_scheme *sc, s7_pointer caller, s7_pointer args) +{ + s7_pointer p = cdr(args); + sc->temp3 = args; + sc->z = sc->nil; /* don't use sc->args here -- it needs GC protection until we get the iterators */ + for (s7_int i = 2; is_pair(p); p = cdr(p), i++) + { + s7_pointer iter = car(p); + if (!is_mappable(iter)) wrong_type_error_nr(sc, caller, i, iter, a_sequence_string); + sc->z = (is_iterator(iter)) ? cons(sc, iter, sc->z) : cons(sc, s7_make_iterator(sc, iter), sc->z); + } + if ((S7_DEBUGGING) && (sc->temp3 != args)) fprintf(stderr, "%s[%d]: temp3: %s\n", __func__, __LINE__, display(sc->temp3)); + sc->temp3 = sc->unused; + { + s7_pointer result = proper_list_reverse_in_place(sc, sc->z); + sc->z = sc->unused; + return(result); + } +} + +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, sets when (in vector-length) to start using a mutated real, rather than make_real during the loop through the vector */ + +static s7_pointer clear_for_each(s7_scheme *sc) +{ + sc->map_call_ctr--; + unstack_with(sc, OP_MAP_UNWIND); + return(sc->unspecified); +} + +static s7_pointer g_for_each_closure(s7_scheme *sc, s7_pointer clo, s7_pointer seq) /* one sequence arg */ +{ + const s7_pointer body = closure_body(clo); + 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 = NULL; + const s7_pointer old_let = sc->curlet, pars = closure_pars(clo); + const s7_pointer val = seq_init(sc, seq); + s7_pointer slot, result = NULL; + + set_curlet(sc, inline_make_let_with_slot(sc, closure_let(clo), (is_pair(car(pars))) ? caar(pars) : car(pars), val)); + slot = let_slots(sc->curlet); + + if (sc->map_call_ctr == 0) + { + if (is_null(cdr(body))) + func = s7_optimize_nv(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 */ + }} + + if (func) + { + push_stack_no_let(sc, OP_MAP_UNWIND, clo, seq); + sc->map_call_ctr++; + if (is_pair(seq)) + { + for (s7_pointer vals = seq, slow_vals = vals; is_pair(vals); ) + { + slot_set_value(slot, car(vals)); + func(sc); + vals = cdr(vals); + if (is_pair(vals)) + { + slot_set_value(slot, car(vals)); + func(sc); + vals = cdr(vals); + slow_vals = cdr(slow_vals); + if (vals == slow_vals) break; + }} + result = sc->unspecified; + } + else + if (is_float_vector(seq)) + { + const s7_double *vals = float_vector_floats(seq); + const s7_int len = vector_length(seq); + if ((len > MUTLIM) && + (!tree_has_setters(sc, body))) + { + const s7_pointer sv = wrap_real(sc, 0.0); /* maybe make_mutable_real(sc, 0.0)? */ + slot_set_value(slot, sv); + if (func == opt_float_any_nv) + { + opt_info *o = sc->opts[0]; + s7_double (*fd)(opt_info *o) = q_call(o).fd; + for (s7_int i = 0; i < len; i++) {set_real(sv, vals[i]); fd(o);}} + else + if (func == opt_cell_any_nv) + { + opt_info *o = sc->opts[0]; + opt_info *o1 = q_when_body(o, 0).o1; + s7_pointer (*fp)(opt_info *o) = q_call(o).fp; + if (fp == opt_unless_p_1) + for (s7_int i = 0; i < len; i++) + { + set_real(sv, vals[i]); + if (!(q_when_test_call(o))) q_call(o1).fp(o1); + } + else for (s7_int i = 0; i < len; i++) {set_real(sv, vals[i]); fp(o);} + } + else for (s7_int i = 0; i < len; i++) {set_real(sv, vals[i]); func(sc);} + } + else for (s7_int i = 0; i < len; i++) {slot_set_value(slot, make_real(sc, vals[i])); func(sc);} + result = sc->unspecified; + } + else + if (is_int_vector(seq)) + { + const s7_int *vals = int_vector_ints(seq); + const s7_int len = vector_length(seq); + if ((len > MUTLIM) && + (!tree_has_setters(sc, body))) + { + const s7_pointer sv = wrap_mutable_integer(sc, 0); /* make_mutable_integer? -- can we assume c_funcs won't use wrappers? */ + slot_set_value(slot, sv); + /* since there are no setters, the inner step is also mutable if there is one. + * func=opt_cell_any_nv, q_call(sc->opts[0]).fp(sc->opts[0]) fp=opt_do_1 -> mutable version + */ + if (func == opt_int_any_nv) + { + opt_info *o = sc->opts[0]; + s7_int (*fi)(opt_info *o) = q_call(o).fi; + for (s7_int i = 0; i < len; i++) {set_integer(sv, vals[i]); fi(o);} + } + else for (s7_int i = 0; i < len; i++) {set_integer(sv, vals[i]); func(sc);} + } + else for (s7_int i = 0; i < len; i++) {slot_set_value(slot, make_integer(sc, vals[i])); func(sc);} + result = sc->unspecified; + } + else + if (is_t_vector(seq)) + { + const s7_pointer *vals = vector_elements(seq); + const s7_int len = vector_length(seq); + if (func == opt_cell_any_nv) + { + opt_info *o = sc->opts[0]; + s7_pointer (*fp)(opt_info *o) = q_call(o).fp; + for (s7_int i = 0; i < len; i++) {slot_set_value(slot, vals[i]); fp(o);}} + else for (s7_int i = 0; i < len; i++) {slot_set_value(slot, vals[i]); func(sc);} + result = sc->unspecified; + } + else + if (is_string(seq)) + { + const char *str = string_value(seq); + const s7_int len = string_length(seq); + for (s7_int i = 0; i < len; i++) {slot_set_value(slot, chars[(uint8_t)(str[i])]); func(sc);} + result = sc->unspecified; + } + else + if (is_byte_vector(seq)) + { + const uint8_t *vals = (const uint8_t *)byte_vector_bytes(seq); + const s7_int len = vector_length(seq); + if (func == opt_int_any_nv) + { + opt_info *o = sc->opts[0]; + s7_int (*fi)(opt_info *o) = q_call(o).fi; + for (s7_int i = 0; i < len; i++) {slot_set_value(slot, small_int(vals[i])); fi(o);}} + else for (s7_int i = 0; i < len; i++) {slot_set_value(slot, small_int(vals[i])); func(sc);} + result = sc->unspecified; + } + if (result) + return(clear_for_each(sc)); + if (!is_mappable(seq)) + wrong_type_error_nr(sc, sc->for_each_symbol, 2, seq, a_sequence_string); + if (!is_iterator(seq)) + { + seq = s7_make_iterator(sc, seq); + set_stack_protected2(sc, seq, OP_MAP_UNWIND); + } + /* push_stack_no_let(sc, OP_GC_PROTECT, seq, f); */ + if (func == opt_cell_any_nv) + { + opt_info *o = sc->opts[0]; + s7_pointer (*fp)(opt_info *o) = q_call(o).fp; + while (true) + { + slot_set_value(slot, s7_iterate(sc, seq)); + if (iterator_is_at_end(seq)) return(clear_for_each(sc)); + fp(o); + }} + if (func == opt_int_any_nv) + { + opt_info *o = sc->opts[0]; + s7_int (*fi)(opt_info *o) = q_call(o).fi; + while (true) + { + slot_set_value(slot, s7_iterate(sc, seq)); + if (iterator_is_at_end(seq)) return(clear_for_each(sc)); + fi(o); + }} + while (true) + { + slot_set_value(slot, s7_iterate(sc, seq)); + if (iterator_is_at_end(seq)) return(clear_for_each(sc)); + 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_let); + }} + + /* using op+1 to hop costs more here (and in map) than it saves */ + if ((is_null(cdr(body))) && + (is_pair(seq))) + { + s7_pointer c = inline_make_counter(sc, seq); + counter_set_result(c, seq); + push_stack(sc, OP_FOR_EACH_2, c, clo); + return(sc->unspecified); + } + + if (!is_mappable(seq)) + wrong_type_error_nr(sc, sc->for_each_symbol, 2, seq, a_sequence_string); + begin_temp(sc->v, (is_iterator(seq)) ? seq : s7_make_iterator(sc, seq)); + push_stack(sc, OP_FOR_EACH_1, inline_make_counter(sc, sc->v), clo); + end_temp(sc->v); + return(sc->unspecified); +} + +static void map_or_for_each_closure_pair_2(s7_scheme *sc, s7_pfunc func, s7_pointer seq1, s7_pointer seq2, s7_pointer slot1, s7_pointer slot2, bool for_each_case) +{ + for (s7_pointer 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)); + if (for_each_case) + func(sc); + else + { + s7_pointer val = func(sc); + if (val != sc->no_value) + set_map_unwind_list(sc, cons(sc, val, map_unwind_list(sc))); /* see map_closure_2 below -- gc_protected3 is our temp */ + } + 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)); + if (for_each_case) + func(sc); + else + { + s7_pointer val = func(sc); + if (val != sc->no_value) + set_map_unwind_list(sc, cons(sc, val, map_unwind_list(sc))); + }}} +} + +static void map_or_for_each_closure_vector_2(s7_scheme *sc, s7_pfunc func, s7_pointer seq1, s7_pointer seq2, s7_pointer slot1, s7_pointer slot2, bool for_each_case) +{ + s7_int len = vector_length(seq1); + if (len > vector_length(seq2)) len = vector_length(seq2); + for (s7_int 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)); + if (for_each_case) + func(sc); + else + { + s7_pointer val = func(sc); + if (val != sc->no_value) + set_map_unwind_list(sc, cons(sc, val, map_unwind_list(sc))); + }} +} + +static void map_or_for_each_closure_string_2(s7_scheme *sc, s7_pfunc func, s7_pointer seq1, s7_pointer seq2, s7_pointer slot1, s7_pointer slot2, bool for_each_case) +{ + s7_int len = string_length(seq1); + const char *s1 = string_value(seq1), *s2 = string_value(seq2); + if (len > string_length(seq2)) len = string_length(seq2); + for (s7_int i = 0; i < len; i++) + { + slot_set_value(slot1, chars[(uint8_t)(s1[i])]); + slot_set_value(slot2, chars[(uint8_t)(s2[i])]); + if (for_each_case) + func(sc); + else + { + s7_pointer val = func(sc); + if (val != sc->no_value) + set_map_unwind_list(sc, cons(sc, val, map_unwind_list(sc))); + }} +} + +static s7_pointer g_for_each_closure_2(s7_scheme *sc, s7_pointer clo, s7_pointer seq1, s7_pointer seq2) +{ + s7_pointer body = closure_body(clo); + if (!no_cell_opt(body)) + { + s7_pfunc func = NULL; + const s7_pointer olde = sc->curlet, pars = closure_pars(clo); + s7_pointer slot1, slot2; + const s7_pointer val1 = seq_init(sc, seq1); + const s7_pointer val2 = seq_init(sc, seq2); + set_curlet(sc, make_let_with_two_slots(sc, closure_let(clo), + (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 (sc->map_call_ctr == 0) + { + if (is_null(cdr(body))) + func = s7_optimize_nv(sc, body); + 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), true); + }} + + if (func) + { + s7_pointer result = NULL; + push_stack_no_let(sc, OP_MAP_UNWIND, clo, seq1); + sc->map_call_ctr++; + if ((is_pair(seq1)) && (is_pair(seq2))) + { + map_or_for_each_closure_pair_2(sc, func, seq1, seq2, slot1, slot2, true); + result = sc->unspecified; + } + else + if ((is_any_vector(seq1)) && (is_any_vector(seq2))) + { + map_or_for_each_closure_vector_2(sc, func, seq1, seq2, slot1, slot2, true); + result = sc->unspecified; + } + else + if ((is_string(seq1)) && (is_string(seq2))) + { + map_or_for_each_closure_string_2(sc, func, seq1, seq2, slot1, slot2, true); + result = sc->unspecified; + } + sc->map_call_ctr--; + unstack_with(sc, OP_MAP_UNWIND); + set_curlet(sc, olde); + if (result) return(result); + set_no_cell_opt(body); + } + else /* not func */ + { + set_no_cell_opt(body); + set_curlet(sc, olde); + }} + + if (!is_mappable(seq1)) wrong_type_error_nr(sc, sc->for_each_symbol, 2, seq1, a_sequence_string); /* is_mappable includes is_iterator */ + if (!is_mappable(seq2)) wrong_type_error_nr(sc, sc->for_each_symbol, 3, seq2, a_sequence_string); + + sc->z = (is_iterator(seq1)) ? seq1 : s7_make_iterator(sc, seq1); + sc->z = (is_iterator(seq2)) ? list_2(sc, sc->z, seq2) : list_2(sc, sc->z, s7_make_iterator(sc, seq2)); + push_stack(sc, OP_FOR_EACH, cons_unchecked(sc, sc->z, make_list(sc, 2, sc->nil)), clo); + sc->z = sc->unused; + return(sc->unspecified); +} + +static inline bool for_each_arg_is_null(s7_scheme *sc, s7_pointer args) +{ + s7_pointer p = args; + bool got_nil = false; + for (s7_int i = 2; is_pair(p); p = cdr(p), i++) + { + s7_pointer obj = car(p); + if (!is_mappable(obj)) + { + if (is_null(obj)) + got_nil = true; + else wrong_type_error_nr(sc, sc->for_each_symbol, i, 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) + + const s7_pointer clo = car(args); + const s7_int len = proper_list_length(cdr(args)); + bool arity_ok = false; + + /* try the normal case first */ + sc->value = clo; + if (is_closure(clo)) /* not lambda* that might get confused about arg names */ + { + if ((len == 1) && + (is_pair(closure_pars(clo))) && + (is_null(cdr(closure_pars(clo))))) + arity_ok = true; + } + else + if (is_c_object(clo)) /* see note in g_map; s7_is_aritable can clobber sc->args=plist=args */ + args = copy_proper_list(sc, args); + else + if (!is_applicable(clo)) + return(method_or_bust(sc, clo, sc->for_each_symbol, args, something_applicable_string, 1)); + + if ((!arity_ok) && + (!s7_is_aritable(sc, clo, len))) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_4(sc, wrap_string(sc, "for-each first argument ~A called with ~D argument~P?", 53), clo, wrap_integer(sc, len), wrap_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_safe_c_function(clo)) + { + const s7_p_p_t fp = s7_p_p_function(clo); /* s7_b_p_t would work if we could cast it, and others (return value is discarded) */ + if ((fp) && (len == 1)) + { + if (is_pair(cadr(args))) + { + for (s7_pointer 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); + } + if (is_any_vector(cadr(args))) + { + const s7_pointer vec = cadr(args); + const s7_int vlen = vector_length(vec); + if (is_float_vector(vec)) + { + s7_pointer rl = wrap_real(sc, 0.0); /* maybe make_mutable_real(sc, 0.0) -- not sure this is safe */ + begin_temp(sc->x, rl); + for (s7_int i = 0; i < vlen; i++) + { + set_real(rl, float_vector(vec, i)); + fp(sc, rl); + } + end_temp(sc->x); + } + else + if (is_int_vector(vec)) + { + s7_pointer iv = wrap_mutable_integer(sc, 0); /* make_mutable_integer? */ + begin_temp(sc->x, iv); + for (s7_int i = 0; i < vlen; i++) + { + set_integer(iv, int_vector(vec, i)); + fp(sc, iv); + } + end_temp(sc->x); + } + else + for (s7_int i = 0; i < vlen; i++) + fp(sc, vector_getter(vec)(sc, vec, i)); /* LOOP_4 here gains almost nothing */ + return(sc->unspecified); + } + if (is_string(cadr(args))) + { + const s7_pointer str = cadr(args); + const char *s = string_value(str); + const s7_int slen = string_length(str); + for (s7_int i = 0; i < slen; i++) fp(sc, chars[(uint8_t)(s[i])]); + return(sc->unspecified); + }} + { + s7_function func = c_function_call(clo); /* presumably this is either display/write, or method call? */ + s7_pointer iters; + sc->z = make_iterators(sc, sc->for_each_symbol, 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) + { + const s7_pointer iter = caar(sc->z), fargs = cdr(sc->z); + sc->z = sc->unused; + while (true) + { + set_car(fargs, s7_iterate(sc, iter)); + if (iterator_is_at_end(iter)) + { + /* 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_gc_protect(sc); + sc->z = sc->unused; + return(sc->unspecified); + } + func(sc, fargs); + }} + iters = sc->z; + sc->z = sc->unused; + while (true) + { + for (s7_pointer iterp = car(iters), fargs = cdr(iters); is_pair(iterp); iterp = cdr(iterp), fargs = cdr(fargs)) + { + set_car(fargs, s7_iterate(sc, car(iterp))); + if (iterator_is_at_end(car(iterp))) + { + unstack_gc_protect(sc); + return(sc->unspecified); + }} + func(sc, cdr(iters)); + }}} + + /* if closure call is straightforward, use OP_FOR_EACH_1 */ + if ((len == 1) && + (((is_closure(clo)) && + (closure_arity_to_int(sc, clo) == 1) && + (!is_constant_symbol(sc, car(closure_pars(clo))))) || + ((is_closure_star(clo)) && + (closure_star_arity_to_int(sc, clo) == 1) && + (!is_constant_symbol(sc, (is_pair(car(closure_pars(clo)))) ? caar(closure_pars(clo)) : car(closure_pars(clo))))))) + return(g_for_each_closure(sc, clo, cadr(args))); + + push_stack(sc, OP_FOR_EACH, cons_unchecked(sc, make_iterators(sc, sc->for_each_symbol, args), make_list(sc, len, sc->nil)), clo); + sc->z = sc->unused; + return(sc->unspecified); +} + +static bool op_for_each(s7_scheme *sc) +{ + const s7_pointer iterators = car(sc->args); + const s7_pointer saved_args = cdr(sc->args); + sc->temp9 = saved_args; + for (s7_pointer args = saved_args, iters = iterators; is_pair(args); args = cdr(args), iters = cdr(iters)) + { + set_car(args, s7_iterate(sc, car(iters))); + if (iterator_is_at_end(car(iters))) + { + sc->value = sc->unspecified; + sc->temp9 = sc->unused; + return(true); + }} + push_stack_direct(sc, OP_FOR_EACH); + sc->args = (needs_copied_args(sc->code)) ? copy_proper_list(sc, saved_args) : saved_args; + sc->temp9 = sc->unused; + 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 a let 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 inline_op_for_each_1(s7_scheme *sc) /* called once in eval, case fb gc iter */ +{ + const s7_pointer counter = sc->args; + s7_pointer code; + const s7_pointer p = counter_list(counter); + const s7_pointer arg = s7_iterate(sc, p); + if (iterator_is_at_end(p)) + { + sc->value = sc->unspecified; + return(true); + } + code = T_Clo(sc->code); + if (counter_capture(counter) != sc->capture_let_counter) + { + const s7_pointer sym = car(closure_pars(code)); + set_curlet(sc, inline_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) */ + set_curlet(sc, 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 inline_op_for_each_2(s7_scheme *sc) /* called once in eval, lg set */ +{ + const s7_pointer counter = sc->args; + const s7_pointer lst = counter_list(counter); + if (!is_pair(lst)) /* '(1 2 . 3) as arg? -- counter_list can be anything here */ + { + sc->value = sc->unspecified; + return(true); + } + counter_set_list(counter, cdr(lst)); + if (sc->cur_op == OP_FOR_EACH_3) + { + counter_set_result(counter, cdr(counter_result(counter))); + if (counter_result(counter) == counter_list(counter)) + { + sc->value = sc->unspecified; + return(true); + } + push_stack_direct(sc, OP_FOR_EACH_2); + } + else push_stack_direct(sc, OP_FOR_EACH_3); + if (counter_capture(counter) != sc->capture_let_counter) + { + const s7_pointer pars = closure_pars(sc->code); + set_curlet(sc, inline_make_let_with_slot(sc, closure_let(sc->code), (is_pair(car(pars))) ? caar(pars) : car(pars), car(lst))); + 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)); + set_curlet(sc, update_let_with_slot(sc, counter_let(counter), car(lst))); + } + sc->code = car(closure_body(sc->code)); + return(false); +} + + +/* ---------------------------------------- map ---------------------------------------- */ + +static s7_pointer g_map_closure(s7_scheme *sc, s7_pointer clo, s7_pointer seq) /* one sequence argument */ +{ + const s7_pointer body = closure_body(clo); + sc->value = clo; + + if (!no_cell_opt(body)) + { + s7_pfunc func = NULL; + const s7_pointer old_let = sc->curlet, pars = closure_pars(clo); + s7_pointer slot; + set_curlet(sc, inline_make_let_with_slot(sc, closure_let(clo), (is_pair(car(pars))) ? caar(pars) : car(pars), seq_init(sc, seq))); + slot = let_slots(sc->curlet); + + if (sc->map_call_ctr == 0) + { + 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 */ + }} + if (func) + { + s7_pointer val, result = NULL; /* val could be localized */ + push_stack_no_let(sc, OP_MAP_UNWIND, clo, seq); + sc->map_call_ctr++; + if (is_pair(seq)) + { + set_map_unwind_list(sc, sc->nil); + for (s7_pointer fast = seq, slow = seq; is_pair(fast); fast = cdr(fast), slow = cdr(slow)) + { + slot_set_value(slot, car(fast)); + val = func(sc); + if (val != sc->no_value) set_map_unwind_list(sc, cons(sc, val, map_unwind_list(sc))); + if (is_pair(cdr(fast))) + { + fast = cdr(fast); + if (fast == slow) break; + slot_set_value(slot, car(fast)); + val = func(sc); + if (val != sc->no_value) set_map_unwind_list(sc, cons(sc, val, map_unwind_list(sc))); + }} + result = proper_list_reverse_in_place(sc, map_unwind_list(sc)); + } + else + if (is_float_vector(seq)) + { + const s7_double *vals = float_vector_floats(seq); + const s7_int len = vector_length(seq); + set_map_unwind_list(sc, sc->nil); + for (s7_int i = 0; i < len; i++) + { + slot_set_value(slot, make_real(sc, vals[i])); + val = func(sc); + if (val != sc->no_value) set_map_unwind_list(sc, cons(sc, val, map_unwind_list(sc))); + } + result = proper_list_reverse_in_place(sc, map_unwind_list(sc)); + } + else + if (is_int_vector(seq)) + { + const s7_int *vals = int_vector_ints(seq); + const s7_int len = vector_length(seq); + set_map_unwind_list(sc, sc->nil); + for (s7_int i = 0; i < len; i++) + { + slot_set_value(slot, make_integer(sc, vals[i])); + val = func(sc); + if (val != sc->no_value) set_map_unwind_list(sc, cons(sc, val, map_unwind_list(sc))); + } + result = proper_list_reverse_in_place(sc, map_unwind_list(sc)); + } + else + if (is_complex_vector(seq)) + { + const s7_complex *vals = complex_vector_complexes(seq); + const s7_int len = vector_length(seq); + set_map_unwind_list(sc, sc->nil); + for (s7_int i = 0; i < len; i++) + { + slot_set_value(slot, c_complex_to_s7(sc, vals[i])); + val = func(sc); + if (val != sc->no_value) set_map_unwind_list(sc, cons(sc, val, map_unwind_list(sc))); + } + result = proper_list_reverse_in_place(sc, map_unwind_list(sc)); + } + else + if (is_t_vector(seq)) + { + const s7_pointer *vals = vector_elements(seq); + const s7_int len = vector_length(seq); + set_map_unwind_list(sc, sc->nil); + for (s7_int i = 0; i < len; i++) + { + slot_set_value(slot, vals[i]); + val = func(sc); + if (val != sc->no_value) set_map_unwind_list(sc, cons(sc, val, map_unwind_list(sc))); + } + result = proper_list_reverse_in_place(sc, map_unwind_list(sc)); + } + else + if (is_string(seq)) + { + const s7_int len = string_length(seq); + const char *str = string_value(seq); + set_map_unwind_list(sc, sc->nil); + for (s7_int i = 0; i < len; i++) + { + slot_set_value(slot, chars[(uint8_t)(str[i])]); + val = func(sc); + if (val != sc->no_value) set_map_unwind_list(sc, cons(sc, val, map_unwind_list(sc))); + } + result = proper_list_reverse_in_place(sc, map_unwind_list(sc)); + } + sc->map_call_ctr--; + unstack_with(sc, OP_MAP_UNWIND); + if ((S7_DEBUGGING) && (sc->map_call_ctr < 0)) {fprintf(stderr, "%s[%d]: map ctr: %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr); sc->map_call_ctr = 0;} + if (result) return(result); + } + set_no_cell_opt(body); + set_curlet(sc, old_let); + } + if ((is_null(cdr(body))) && + (is_pair(seq))) + { + /* here we need to check for a setter, and if any, push with dynamic-unwind, then restore later. + * (let ((hk (make-hook 'x))) (define (func) (map hk (list 0 6))) (set! (setter hk) (lambda (y) y)) (func)) + */ + if (is_any_procedure(closure_setter_or_map_list(clo))) /* should we restore #f? */ + push_stack(sc, OP_DYNAMIC_UNWIND, list_3(sc, clo, closure_setter(clo), sc->T), sc->restore_setter); + /* the passed list will be car(args) when dynamic_unwind calls (f . args) */ + /* all this complexity because there is no place to store the "slow" version of seq for circular list checks */ + closure_set_map_list(clo, seq); + push_stack(sc, OP_MAP_2, inline_make_counter(sc, seq), clo); + return(sc->unspecified); + } + if (!is_mappable(seq)) wrong_type_error_nr(sc, sc->map_symbol, 2, seq, a_sequence_string); + begin_temp(sc->v, (is_iterator(seq)) ? seq : s7_make_iterator(sc, seq)); + push_stack(sc, OP_MAP_1, inline_make_counter(sc, sc->v), clo); + end_temp(sc->v); + return(sc->nil); +} + +static s7_pointer g_map_closure_2(s7_scheme *sc, s7_pointer clo, s7_pointer seq1, s7_pointer seq2) /* two sequences */ +{ + const s7_pointer body = closure_body(clo); + if (!no_cell_opt(body)) + { + s7_pfunc func = NULL; + const s7_pointer old_let = sc->curlet, pars = closure_pars(clo); + s7_pointer slot1, slot2; + const s7_pointer val1 = seq_init(sc, seq1); + const s7_pointer val2 = seq_init(sc, seq2); + set_curlet(sc, make_let_with_two_slots(sc, closure_let(clo), + (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 (sc->map_call_ctr == 0) + { + 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); + }} + if (func) + { + s7_pointer result = NULL; + push_stack_no_let(sc, OP_MAP_UNWIND, clo, seq1); + sc->map_call_ctr++; + if ((is_pair(seq1)) && (is_pair(seq2))) + { + set_map_unwind_list(sc, sc->nil); + map_or_for_each_closure_pair_2(sc, func, seq1, seq2, slot1, slot2, false); /* builds result on gc_protected3 */ + result = proper_list_reverse_in_place(sc, map_unwind_list(sc)); + } + else + if ((is_any_vector(seq1)) && (is_any_vector(seq2))) + { + set_map_unwind_list(sc, sc->nil); + map_or_for_each_closure_vector_2(sc, func, seq1, seq2, slot1, slot2, false); + result = proper_list_reverse_in_place(sc, map_unwind_list(sc)); + } + else + if ((is_string(seq1)) && (is_string(seq2))) + { + set_map_unwind_list(sc, sc->nil); + map_or_for_each_closure_string_2(sc, func, seq1, seq2, slot1, slot2, false); + result = proper_list_reverse_in_place(sc, map_unwind_list(sc)); + } + sc->map_call_ctr--; + unstack_with(sc, OP_MAP_UNWIND); + set_curlet(sc, old_let); + if (result) return(result); + set_no_cell_opt(body); + } + else /* not func */ + { + set_no_cell_opt(body); + set_curlet(sc, old_let); + }} + + if (!is_mappable(seq1)) wrong_type_error_nr(sc, sc->for_each_symbol, 2, seq1, a_sequence_string); + if (!is_mappable(seq2)) wrong_type_error_nr(sc, sc->for_each_symbol, 3, seq2, a_sequence_string); + + sc->z = (is_iterator(seq1)) ? seq1 : s7_make_iterator(sc, seq1); + sc->z = (is_iterator(seq2)) ? list_2(sc, sc->z, seq2) : list_2(sc, sc->z, s7_make_iterator(sc, seq2)); + + push_stack(sc, OP_MAP, inline_make_counter(sc, sc->z), clo); + sc->z = sc->unused; + 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) + + /* (apply f (map ...)) e.g. f=append -> use safe_list for map output list here? also for ( (map...)) + * but less savings if mapped func would have used the same safe_list? + */ + const s7_pointer clo = car(args); + s7_int len = 0; + bool got_nil = false; + + for (s7_pointer p = cdr(args); is_pair(p); p = cdr(p), len++) + if (!is_mappable(car(p))) + { + if (is_null(car(p))) + got_nil = true; + else wrong_type_error_nr(sc, sc->map_symbol, len + 2, car(p), a_sequence_string); + } + + switch (type(clo)) + { + case T_C_FUNCTION: + if (!c_function_is_aritable(clo, len)) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_4(sc, wrap_string(sc, "map ~A: ~D argument~P?", 22), clo, wrap_integer(sc, len), wrap_integer(sc, len))); + case T_C_RST_NO_REQ_FUNCTION: + /* if function is safe c func, do the map locally */ + if (got_nil) return(sc->nil); + if (is_safe_procedure(clo)) + { + s7_pointer val; + const s7_function func = c_function_call(clo); + if (is_pair(cadr(args))) + { + if (len == 1) + { + const s7_p_p_t fp = s7_p_p_function(clo); + if (fp) + { + val = list_1_unchecked(sc, sc->nil); + gc_protect_via_stack(sc, val); + for (s7_pointer fast = cadr(args), slow = cadr(args); is_pair(fast); fast = cdr(fast), slow = cdr(slow)) + { + s7_pointer fval = fp(sc, car(fast)); + if (fval != sc->no_value) set_car(val, cons(sc, fval, car(val))); + if (is_pair(cdr(fast))) + { + fast = cdr(fast); + if (fast == slow) break; + fval = fp(sc, car(fast)); + if (fval != sc->no_value) set_car(val, cons(sc, fval, car(val))); + }} + unstack_gc_protect(sc); + return(proper_list_reverse_in_place(sc, car(val))); + }} + if ((len == 2) && (is_pair(caddr(args)))) + { + const s7_p_pp_t fp = s7_p_pp_function(clo); + if (fp) + { + val = list_1_unchecked(sc, sc->nil); + gc_protect_via_stack(sc, val); + for (s7_pointer 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 fval = fp(sc, car(fast1), car(fast2)); + if (fval != sc->no_value) set_car(val, cons(sc, fval, 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; + fval = fp(sc, car(fast1), car(fast2)); + if (fval != sc->no_value) set_car(val, cons(sc, fval, car(val))); + }} + unstack_gc_protect(sc); + return(proper_list_reverse_in_place(sc, car(val))); + }}} + if ((is_string(cadr(args))) && (len == 1)) + { + const s7_p_p_t fp = s7_p_p_function(clo); + if (fp) + { + s7_pointer str = cadr(args); + const char *s = string_value(str); + val = list_1_unchecked(sc, sc->nil); + gc_protect_via_stack(sc, val); + len = string_length(str); + for (s7_int i = 0; i < len; i++) + { + s7_pointer fval = fp(sc, chars[(uint8_t)(s[i])]); + if (fval != sc->no_value) set_car(val, cons(sc, fval, car(val))); + } + unstack_gc_protect(sc); + return(proper_list_reverse_in_place(sc, car(val))); + }} + if ((is_any_vector(cadr(args))) && (len == 1)) + { + const s7_p_p_t fp = s7_p_p_function(clo); + if (fp) + { + const s7_pointer vec = cadr(args); + val = list_1_unchecked(sc, sc->nil); + gc_protect_via_stack(sc, val); + len = vector_length(vec); + for (s7_int i = 0; i < len; i++) + { + s7_pointer fval = fp(sc, vector_getter(vec)(sc, vec, i)); + if (fval != sc->no_value) set_car(val, cons(sc, fval, car(val))); + } + unstack_gc_protect(sc); + return(proper_list_reverse_in_place(sc, car(val))); + }} + + { + s7_pointer val1, old_args, iter_list; + sc->z = make_iterators(sc, sc->map_symbol, args); + val1 = cons_unchecked(sc, sc->z, make_list(sc, len, sc->nil)); + iter_list = sc->z; + old_args = sc->args; + 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->unused; + while (true) + { + s7_pointer fval; + for (s7_pointer iters = iter_list, vals = cdr(val1); is_pair(iters); iters = cdr(iters), vals = cdr(vals)) + { + set_car(vals, s7_iterate(sc, car(iters))); + if (iterator_is_at_end(car(iters))) + { + unstack_gc_protect(sc); + sc->args = T_Pos(old_args); /* can be # or # */ + return(proper_list_reverse_in_place(sc, car(val))); + }} + fval = func(sc, cdr(val1)); /* multiple-values? values is unsafe, but s7_values used externally and claims to be safe? */ /* func = c_function_call(f) */ + if (fval != sc->no_value) + set_car(val, cons(sc, fval, car(val))); + }}} + + else /* not safe procedure */ + if ((clo == global_value(sc->values_symbol)) && + (len == 1) && + (!has_methods(cadr(args)))) /* iterator should be ok here -- object_to_list can handle it */ + { + s7_pointer p = object_to_list(sc, cadr(args)); + if (p != cadr(args)) + return(p); + } + break; + + case T_CLOSURE: case T_CLOSURE_STAR: + { + const int32_t fargs = (is_closure(clo)) ? closure_arity_to_int(sc, clo) : closure_star_arity_to_int(sc, clo); + if ((len == 1) && + (fargs == 1) && + (!is_constant_symbol(sc, (is_pair(car(closure_pars(clo)))) ? caar(closure_pars(clo)) : car(closure_pars(clo))))) + { + if (got_nil) return(sc->nil); + if (is_closure_star(clo)) + return(g_map_closure(sc, clo, cadr(args))); + + begin_temp(sc->v, (!is_iterator(cadr(args))) ? s7_make_iterator(sc, cadr(args)) : cadr(args)); + push_stack(sc, OP_MAP_1, inline_make_counter(sc, sc->v), clo); + end_temp(sc->v); + symbol_increment_ctr(car(closure_pars(clo))); + return(sc->nil); + } + if (((fargs >= 0) && (fargs < len)) || + ((is_closure(clo)) && (abs(fargs) > len))) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_4(sc, wrap_string(sc, "map ~A: ~D argument~P?", 22), clo, wrap_integer(sc, len), wrap_integer(sc, len))); + if (got_nil) return(sc->nil); + } + break; + + case T_C_OBJECT: + /* args if sc->args (plist + c_object) can be clobbered here by s7_is_aritable, so we need to protect it */ + args = copy_proper_list(sc, args); + sc->temp9 = args; + + default: + if (!is_applicable(clo)) + return(method_or_bust(sc, clo, sc->map_symbol, args, something_applicable_string, 1)); + if ((!is_pair(clo)) && + (!s7_is_aritable(sc, clo, len))) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_4(sc, wrap_string(sc, "map: ~D argument~P for ~A?", 26), wrap_integer(sc, len), wrap_integer(sc, len), clo)); + if (got_nil) return(sc->nil); + break; + } + sc->z = make_iterators(sc, sc->map_symbol, args); + push_stack(sc, OP_MAP, inline_make_counter(sc, sc->z), clo); + sc->z = sc->unused; + return(sc->nil); +} + +static bool op_map(s7_scheme *sc) +{ + const s7_pointer counter = sc->args; + sc->z = sc->nil; /* can't use preset args list here (as in for-each): (map list '(a b c)) */ + for (s7_pointer iters = counter_list(counter); is_pair(iters); iters = cdr(iters)) + { + const s7_pointer val = s7_iterate(sc, car(iters)); + if (iterator_is_at_end(car(iters))) + { + sc->value = proper_list_reverse_in_place(sc, counter_result(counter)); + sc->z = sc->unused; + return(true); + } + sc->z = cons(sc, val, sc->z); + } + push_stack_direct(sc, OP_MAP_GATHER); + sc->args = proper_list_reverse_in_place(sc, sc->z); + sc->z = sc->unused; + if (needs_copied_args(sc->code)) + sc->args = copy_proper_list(sc, sc->args); + return(false); +} + +static bool op_map_1(s7_scheme *sc) +{ + const s7_pointer args = sc->args, code = sc->code; + const s7_pointer p = counter_list(args); + const s7_pointer val = s7_iterate(sc, p); + if (iterator_is_at_end(p)) + { + sc->value = proper_list_reverse_in_place(sc, counter_result(args)); + return(true); + } + push_stack_direct(sc, OP_MAP_GATHER_1); + if (counter_capture(args) != sc->capture_let_counter) + { + const s7_pointer pars = closure_pars(code); + set_curlet(sc, inline_make_let_with_slot(sc, closure_let(code), (is_pair(car(pars))) ? caar(pars) : car(pars), val)); + 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)); + set_curlet(sc, update_let_with_slot(sc, counter_let(args), val)); + } + sc->code = T_Pair(closure_body(code)); + return(false); +} + +static bool op_map_2(s7_scheme *sc) /* possibly inline lg */ +{ + s7_pointer cur_args; + const s7_pointer counter = sc->args, code = sc->code; + { + const s7_pointer p = counter_list(counter); + if (!is_pair(p)) + { + sc->value = proper_list_reverse_in_place(sc, counter_result(counter)); + return(true); + } + cur_args = car(p); + counter_set_list(counter, 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(counter)) + { + sc->value = proper_list_reverse_in_place(sc, counter_result(counter)); + return(true); + } + push_stack_direct(sc, OP_MAP_GATHER_2); + } + else push_stack_direct(sc, OP_MAP_GATHER_3); + + if (counter_capture(counter) != sc->capture_let_counter) + { + s7_pointer pars = closure_pars(code); + set_curlet(sc, inline_make_let_with_slot(sc, closure_let(code), (is_pair(car(pars))) ? caar(pars) : car(pars), cur_args)); + 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)); /* needed -- see comment under for-each above */ + set_curlet(sc, update_let_with_slot(sc, counter_let(counter), cur_args)); + } + sc->code = car(closure_body(code)); + return(false); +} + +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; + if (is_not_null(a)) + { + a = copy_proper_list(sc, a); + do { + s7_pointer q = cdr(a); + set_cdr(a, p); + p = a; + a = q; + } while (is_pair(a)); + } + return(p); +} + +static Inline void inline_op_map_gather(s7_scheme *sc) /* called thrice in eval, cb lg map */ +{ + 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 + if ((is_mutable(sc->value)) && (is_t_integer(sc->value))) + counter_set_result(sc->args, cons(sc, make_integer(sc, integer(sc->value)), counter_result(sc->args))); + else counter_set_result(sc->args, cons(sc, sc->value, counter_result(sc->args))); + } +} + + +/* -------------------------------- multiple-values -------------------------------- */ + +#define stack_top4_op(Sc) ((opcode_t)T_Op(Sc->stack_end[-5])) /* top4 == top - 4 */ +#define stack_top4_args(Sc) (Sc->stack_end[-6]) +/* #define stack_top4_let(Sc) (Sc->stack_end[-7]) */ +/* #define stack_top4_code(Sc) (Sc->stack_end[-8]) */ + +static void apply_c_rst_no_req_function(s7_scheme *sc); + +static Inline s7_pointer apply_mv(s7_scheme *sc, bool use_safe) +{ + sc->code = c_function_base(opt1_cfunc(sc->code)); + if (type(sc->code) == T_C_FUNCTION) + sc->value = apply_c_function_unopt(sc, sc->code, sc->args); + else apply_c_rst_no_req_function(sc); + if (use_safe) clear_safe_list_in_use(sc, sc->args); + return(sc->value); +} + +static Inline s7_pointer apply_mv_no_safe_list(s7_scheme *sc) +{ + sc->code = c_function_base(opt1_cfunc(sc->code)); + if (type(sc->code) == T_C_FUNCTION) + sc->value = apply_c_function_unopt(sc, sc->code, sc->args); + else apply_c_rst_no_req_function(sc); + return(sc->value); +} + +static s7_pointer op_safe_c_p_mv(s7_scheme *sc, s7_pointer args) +{ + s7_pointer p; + bool use_safe = false; + sc->value = args; + pop_stack_no_op(sc); + p = cddr(sc->value); + if (is_null(p)) + sc->args = set_plist_2(sc, car(sc->value), cadr(sc->value)); + else + if (is_null(cdr(p))) + sc->args = set_plist_3(sc, car(sc->value), cadr(sc->value), car(p)); + else + { + s7_pointer lst; + const s7_int len = proper_list_length(p) + 2; + sc->args = safe_list_if_possible(sc, len); + use_safe = (!in_heap(sc->args)); + lst = sc->args; + for (s7_pointer p1 = sc->value; is_pair(p1); p1 = cdr(p1), lst = cdr(lst)) set_car(lst, car(p1)); + } + return(apply_mv(sc, use_safe)); +} + +static s7_pointer op_safe_c_pc_mv(s7_scheme *sc, s7_pointer args) +{ + /* sc->value = mv vals from e.g. safe_c_pc_1 below, fn_proc = splice_in_values via values chooser synonym sc->values_uncopied */ + /* sc->args is the trailing constant arg (the "c" in "pc") */ + s7_pointer p; + bool use_safe = false; + sc->value = args; + pop_stack_no_op(sc); + p = cddr(sc->value); + if (is_null(p)) + sc->args = set_plist_3(sc, car(sc->value), cadr(sc->value), sc->args); + else + if (is_null(cdr(p))) + sc->args = set_plist_4(sc, car(sc->value), cadr(sc->value), car(p), sc->args); + else /* sc->args = pair_append(sc, sc->value, list_1(sc, sc->args)); */ /* not plist! sc->value is not reusable */ + { + s7_pointer lst; + const s7_pointer val = sc->args; + const s7_int len = proper_list_length(p); + sc->args = safe_list_if_possible(sc, len + 3); + use_safe = (!in_heap(sc->args)); + lst = sc->args; + for (s7_pointer p1 = sc->value; is_pair(p1); p1 = cdr(p1), lst = cdr(lst)) set_car(lst, car(p1)); + set_car(lst, val); + } + return(apply_mv(sc, use_safe)); +} + +static s7_pointer op_safe_c_ps_mv(s7_scheme *sc, s7_pointer args) /* (define (hi a) (+ (values 1 2) a)) from safe_c_ps_1 */ +{ + /* old form: sc->args = pair_append(sc, sc->value, list_1(sc, lookup(sc, caddr(sc->code)))); */ /* don't assume sc->value can be used as sc->args here! */ + s7_pointer p, val; + bool use_safe = false; + sc->value = args; + pop_stack_no_op(sc); + p = cddr(sc->value); + val = lookup(sc, caddr(sc->code)); + if (is_null(p)) + sc->args = set_plist_3(sc, car(sc->value), cadr(sc->value), val); + else + if (is_null(cdr(p))) + sc->args = set_plist_4(sc, car(sc->value), cadr(sc->value), car(p), val); + else /* sc->args = pair_append(sc, sc->value, list_1(sc, val)); */ + { + s7_pointer lst; + const s7_int len = proper_list_length(p); + sc->args = safe_list_if_possible(sc, len + 3); /* sc->args is not clobbered by fx_call (below) */ + use_safe = (!in_heap(sc->args)); + lst = sc->args; + for (s7_pointer p1 = sc->value; is_pair(p1); p1 = cdr(p1), lst = cdr(lst)) set_car(lst, car(p1)); + set_car(lst, val); + } + return(apply_mv(sc, use_safe)); +} + +static s7_pointer op_safe_c_pa_mv(s7_scheme *sc, s7_pointer args) +{ /* (let () (define (func) (do ((x 0.0 (+ x 0.1)) (i 0 (+ i 1))) ((>= x 0.1) (#_with-baffle (inlet (values 1 2) (symbol? x)))))) (func)) */ + s7_pointer p; + bool use_safe = false; + sc->value = args; + pop_stack_no_op(sc); + p = cddr(sc->value); + if (is_null(p)) + { + s7_pointer val1 = car(sc->value), val2 = cadr(sc->value); + s7_pointer val3 = fx_call(sc, cddr(sc->code)); /* is plist_3 ever clobbered by fx_call? plist_1|2 are set */ + sc->args = set_plist_3(sc, val1, val2, val3); + } + else + if (is_null(cdr(p))) + { + s7_pointer val1 = car(sc->value), val2 = cadr(sc->value), val3 = car(p); + s7_pointer val4 = fx_call(sc, cddr(sc->code)); + sc->args = set_plist_4(sc, val1, val2, val3, val4); + } + else + { + s7_pointer lst; + const s7_int len = proper_list_length(p); + sc->args = safe_list_if_possible(sc, len + 3); /* sc->args is not clobbered by fx_call (below) */ + use_safe = (!in_heap(sc->args)); + lst = sc->args; + for (s7_pointer p1 = sc->value; is_pair(p1); p1 = cdr(p1), lst = cdr(lst)) set_car(lst, car(p1)); + set_car(lst, fx_call(sc, cddr(sc->code))); + } + return(apply_mv(sc, use_safe)); +} + +static s7_pointer op_safe_c_sp_mv(s7_scheme *sc, s7_pointer args) +{ /* (let () (define (ho a) (+ a 2)) (define (hi) (+ (ho 1) (values 3 4))) (hi)) safe_add_sp_1 */ + s7_pointer p; + sc->value = args; + clear_multiple_value(args); /* see op_safe_c_sp_mv in s7test */ + pop_stack_no_op(sc); + p = cddr(sc->value); + if (is_null(p)) + sc->args = set_plist_3(sc, sc->args, car(sc->value), cadr(sc->value)); + else + if (is_null(cdr(p))) + sc->args = set_plist_4(sc, sc->args, car(sc->value), cadr(sc->value), car(p)); + else sc->args = cons(sc, sc->args, sc->value); /* not ulist */ + return(apply_mv_no_safe_list(sc)); +} + +static s7_pointer op_safe_c_ssp_mv(s7_scheme *sc, s7_pointer args) /*sc->code: (+ pi pi (values 1 2)) sc->value: '(1 2) */ +{ + sc->value = args; + pop_stack_no_op(sc); + if (is_null(cddr(sc->value))) + sc->args = set_plist_4(sc, lookup(sc, cadr(sc->code)), lookup(sc, caddr(sc->code)), car(sc->value), cadr(sc->value)); + else sc->args = cons_unchecked(sc, lookup(sc, cadr(sc->code)), cons(sc, lookup(sc, caddr(sc->code)), sc->value)); /* not ulist here */ + return(apply_mv_no_safe_list(sc)); +} + +static s7_pointer op_safe_c_3p_mv(s7_scheme *sc, s7_pointer args) +{ + begin_temp(sc->x, copy_proper_list(sc, args)); + sc->x = cons(sc, sc->unused, sc->x); + return_with_end_temp(sc->x); +} + +static s7_pointer op_c_p_mv(s7_scheme *sc, s7_pointer args) /* (values (values 1 2)) or (apply (values + '(2))) */ +{ + sc->value = args; + pop_stack_no_op(sc); + sc->code = c_function_base(opt1_cfunc(sc->code)); + sc->args = copy_proper_list(sc, sc->value); + if (type(sc->code) == T_C_FUNCTION) + sc->value = apply_c_function_unopt(sc, sc->code, sc->args); + else apply_c_rst_no_req_function(sc); + return(sc->value); +} + +static s7_pointer op_c_ap_mv(s7_scheme *sc, s7_pointer args) /* (values 2 (values 3 4)) or (apply + (values 5 '(1 2))) */ +{ + sc->value = args; + pop_stack_no_op(sc); + clear_multiple_value(sc->value); /* sc->value not copied? */ + sc->args = cons(sc, sc->args, sc->value); + return(apply_mv_no_safe_list(sc)); +} + +static s7_pointer op_safe_c_pp_6_mv(s7_scheme *sc, s7_pointer args) /* both args mv */ +{ + s7_pointer p; + sc->value = args; + pop_stack_no_op(sc); + for (p = cdr(sc->args); is_pair(cdr(p)); p = cdr(p)); /* we used to copy here: sc->args = pair_append(sc, sc->args, sc->value); */ + set_cdr(p, 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 c_function_base(opt1_cfunc(sc->code)) + * (let () (define (hi) (+ (values 1 2) (values 3 4))) (hi)) -> 10 + */ + return(apply_mv_no_safe_list(sc)); +} + +s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) +{ + s7_pointer arglist; + if (SHOW_EVAL_OPS) + safe_print(fprintf(stderr, " %s[%d]: splice %s %s\n", __func__, __LINE__, + (sc->stack_end > sc->stack_start) ? op_names[stack_top_op(sc)] : "no stack!", display_truncated(args))); + if ((S7_DEBUGGING) && ((is_null(args)) || (is_null(cdr(args))))) fprintf(stderr, "%s: %s\n", __func__, display(args)); + + switch (stack_top_op_unchecked(sc)) /* unchecked for C s7_values call at top-level -- see ffitest.c */ + { + /* 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. + * (let ((g-1 (lambda (x a b c) (x (+ a 1) (- b 1) (values c 2))))) (g-1 (lambda (b c d e) (+ b c d e)) 2 3 5)) eval_args2 + */ + begin_temp(sc->y, args); + for (arglist = args; is_pair(cdr(arglist)); arglist = cdr(arglist)) + set_stack_top_args(sc, cons(sc, car(arglist), stack_top_args(sc))); + end_temp(sc->y); + return(car(arglist)); + + case OP_EVAL_ARGS5: + /* (let ((g-1 (lambda (x a b c) (x (+ a 1) (- b 1) 2 (values c 2))))) (g-1 (macro (x y z w) (list-values '+ x y z w)) 2 3 5)) */ + /* code = previous arg saved, args = ante-previous args reversed, we'll take value->code->args and reverse in args5 */ + if (is_null(args)) + return(sc->unspecified); + if (is_null(cdr(args))) + return(car(args)); + set_stack_top_args(sc, cons(sc, stack_top_code(sc), stack_top_args(sc))); + for (arglist = args; is_pair(cddr(arglist)); arglist = cdr(arglist)) + set_stack_top_args(sc, cons(sc, car(arglist), stack_top_args(sc))); + set_stack_top_code(sc, car(arglist)); + return(cadr(arglist)); + + /* handle implicit set! */ + case OP_EVAL_SET1_NO_MV: /* (set! (fnc) ) where evaluation of returned multiple values */ + case OP_EVAL_SET2_NO_MV: /* (set! (fnc ) ), = mv */ + case OP_EVAL_SET3_NO_MV: /* (define f (dilambda (lambda () 1) (lambda (x) x))) (define (f2) (values 1 2 3)) (set! (f) (f2)) */ + syntax_error_nr(sc, "too many arguments to set!: ~S", 30, set_ulist_1(sc, sc->values_symbol, args)); + case OP_EVAL_SET2: /* here = args is mv */ + set_stack_top_op(sc, OP_EVAL_SET2_MV); + return(args); /* ?? */ + case OP_EVAL_SET3: /* here = args is mv */ + set_stack_top_op(sc, OP_EVAL_SET3_MV); + return(args); /* ?? */ + + case OP_ANY_CLOSURE_NP_1: case OP_ANY_CLOSURE_NP_2: + { + s7_pointer func = pop_op_stack(sc); + /* to s7test some rainy day: (fop24 (fop24-1 x) (fop24-1 (+ x 1)) x x (values x x)) (128 128) */ + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, too_many_arguments_string, closure_name(sc, func), set_ulist_1(sc, sc->value_symbol, args))); + } + case OP_ANY_C_NP_2: + set_stack_top_op(sc, OP_ANY_C_NP_MV); + goto FP_MV; + + case OP_ANY_C_NP_1: /* ((eval-string (object->string mac5 :readable)) 1 5 3 4) */ + set_stack_top_op(sc, OP_ANY_C_NP_MV); /* ?? */ + case OP_ANY_C_NP_MV: + 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); + + /* 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_SAFE_C_SP_1: case OP_SAFE_CONS_SP_1: case OP_SAFE_ADD_SP_1: case OP_SAFE_MULTIPLY_SP_1: + /* (let () (define (ho a) (+ a 2)) (define (hi) (+ (ho 1) (values 3 4))) (hi)) from safe_c_pp->h_c_aa? */ + return(op_safe_c_sp_mv(sc, args)); + + case OP_SAFE_C_PS_1: return(op_safe_c_ps_mv(sc, args)); /* (define (f) (let ((d #\d)) (string (values #\a #\b #\c) d))) (f) */ + case OP_SAFE_C_PC_1: return(op_safe_c_pc_mv(sc, args)); /* (define (f) (string (values #\a #\b #\c) #\d)) (f) */ + case OP_SAFE_C_PA_1: return(op_safe_c_pa_mv(sc, args)); + case OP_SAFE_C_SSP_1: return(op_safe_c_ssp_mv(sc, args)); + case OP_SAFE_C_P_1: return(op_safe_c_p_mv(sc, args)); /* (string (values #\a #\b #\c)) */ + case OP_C_P_1: return(op_c_p_mv(sc, args)); /* (let () (define (ho a) (values a 1)) (define (hi) (- (ho 2))) (hi)) */ + case OP_C_AP_1: return(op_c_ap_mv(sc, args)); + case OP_SAFE_C_PP_5: return(op_safe_c_pp_6_mv(sc, args)); /* (let () (define (hi) (+ (values 1 2) (values 3 4))) (hi)) (also safe_c_pp_1) */ + + case OP_SAFE_C_PP_1: /* (define (f) (list (values 1 2) (values 3 4))) (f): args='(1 2), top_args=# */ + set_stack_top_op(sc, OP_SAFE_C_PP_3_MV); + return(args); + + case OP_SAFE_C_3P_1: case OP_SAFE_C_3P_2: case OP_SAFE_C_3P_3: /* (let ((g-1 (lambda (x a b c) (x (+ a 1) (- b 1) (values c 2))))) (g-1 + 2 3 5)) */ + set_stack_top_op(sc, stack_top_op(sc) + 3); /* change op to parallel mv case */ + case OP_SAFE_C_3P_1_MV: case OP_SAFE_C_3P_2_MV: case OP_SAFE_C_3P_3_MV: /* (list-values '+ 1 (apply-values (list 2 3))) */ + return(op_safe_c_3p_mv(sc, 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_sym) */ + 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: + /* (let () (define (func) (do ((x 0.0 (+ x 0.1)) (i 0 (+ i 1))) ((>= x 0.1) (#_with-baffle (inlet (values 1 2) (symbol? x)))))) (func)) */ + if (is_multiple_value(sc->value)) clear_multiple_value(sc->value); + error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, too_many_arguments_string, stack_top_code(sc), sc->value)); + + /* 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: /* (let-temporarily ((var (values 1 2 3))) var) */ + case OP_SET_FROM_SETTER: /* stack_top_code(sc) is slot if (set! x (set! (setter 'x) g)) s7test.scm */ + syntax_error_with_caller_nr(sc, "set!: can't set ~A to ~S", 24, + (is_slot(stack_top_code(sc))) ? slot_symbol(stack_top_code(sc)) : stack_top_code(sc), + set_ulist_1(sc, sc->values_symbol, args)); + + case OP_SET_opSAq_P_1: case OP_SET_opSAAq_P_1: + /* we can assume here that we're dealing with the section after the target, (set! (target...) arg) where arg can't be (values...) + * (define (a3 x) x) + * (set! (setter a3) (lambda (x y z) (list x y z))) + * <11> (set! (a3 1) 2) + * error: <10>: not enough arguments: ((lambda (x y z) ...) 1 2) + * <12> (set! (a3 1) 2 3) + * error: (set! (a3 1) 2 3): too many arguments to set! + * <13> (set! (a3 1) (values 2 3)) + * (set! (a3 1) (values 2 3)): too many arguments to set! + * but (set! (a3 1 2) 3) is ok, also (set! (a3 (values 1 2)) 3) + */ + syntax_error_nr(sc, "too many arguments to set! ~S", 29, set_ulist_1(sc, sc->values_symbol, args)); + + case OP_LET1: /* (let ((var (values 1 2 3))) ...) */ + { + /* (let () (define (hi) (let ((x (values 1 2))) (if x (list x)))) (define (ho) (hi)) (catch #t (lambda () (ho)) (lambda args #f)) (ho)) */ + /* this code assumes op_let_1 is building a list of values stored in sc->args etc */ + s7_pointer let_code, vars, sym, p = stack_top_args(sc); + 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); + syntax_error_with_caller2_nr(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: + /* (let () (define (hi) (let ((x (values 1 2))) (display x) (if x (list x)))) (define (ho) (hi)) (catch #t (lambda () (ho)) (lambda args #f)) (ho)) */ + syntax_error_with_caller2_nr(sc, "~A: can't bind ~A to ~S", 23, sc->let_symbol, + opt2_sym(stack_top_code(sc)), set_ulist_1(sc, sc->values_symbol, args)); + + case OP_LET_ONE_OLD_1: case OP_LET_ONE_P_OLD_1: + syntax_error_with_caller2_nr(sc, "~A: can't bind ~A to ~S", 23, sc->let_symbol, + slot_symbol(let_slots(opt3_let(stack_top_code(sc)))), set_ulist_1(sc, sc->values_symbol, args)); + + case OP_LET_STAR1: /* here caar(sc->code) is bound to sc->value */ + syntax_error_with_caller2_nr(sc, "~A: can't bind ~A to ~S", 23, sc->let_star_symbol, + caar(stack_top_code(sc)), set_ulist_1(sc, sc->values_symbol, args)); + + case OP_LETREC1: /* here sc->args is the slot about to receive a value */ + syntax_error_with_caller2_nr(sc, "~A: can't bind ~A to ~S", 23, sc->letrec_symbol, + slot_symbol(stack_top_args(sc)), set_ulist_1(sc, sc->values_symbol, args)); + + case OP_LETREC_STAR1: + syntax_error_with_caller2_nr(sc, "~A: can't bind ~A to ~S", 23, sc->letrec_star_symbol, + slot_symbol(stack_top_args(sc)), 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 (arglist = args; is_pair(cdr(arglist)); arglist = cdr(arglist)) + if (car(arglist) == sc->F) + return(sc->F); + return(car(arglist)); + + case OP_OR_P1: + for (arglist = args; is_pair(cdr(arglist)); arglist = cdr(arglist)) + if (car(arglist) != sc->F) + return(car(arglist)); + return(car(arglist)); + + case OP_IF1: /* (if (values ...) ...) -- see s7.html at the end of the values writeup for explanation (we're following CL here) */ + 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_I_S: + case OP_COND1: case OP_COND1_SIMPLE: + /* (if (values 1 2) 3) */ + return(car(args)); + + case OP_IF_PN: /* (if|when (not (values...)) ...) as opposed to (if|unless (values...)...) which follows CL and drops trailing values */ + /* doesn't this error check happen elsewhere? */ + syntax_error_nr(sc, "too many arguments to not: ~S", 29, set_ulist_1(sc, sc->values_symbol, args)); + + case OP_DYNAMIC_UNWIND: case OP_DYNAMIC_UNWIND_PROFILE: + { + const s7_pointer old_value = sc->value; + const bool mv = is_multiple_value(args); + if (mv) clear_multiple_value(args); + sc->value = cons(sc, sc->values_symbol, args); + dynamic_unwind(sc, stack_top_code(sc), stack_top_args(sc)); /* position (curlet), this applies code to sc->value */ + 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_DEACTIVATE_GOTO: /* (+ (call-with-exit (lambda (ret) (values 1 2 3)))) */ + call_exit_active(stack_top_args(sc)) = false; /* stack_top_args(sc) is the goto */ + /* fall through */ + case OP_CATCH: case OP_CATCH_1: case OP_CATCH_2: case OP_CATCH_ALL: /* (+ (catch #t (lambda () (values 3 4)) (lambda args args))) */ + case OP_BARRIER: + pop_stack_no_op(sc); + return(splice_in_values(sc, args)); + + case OP_GC_PROTECT: + /* (test (+ (let ((x 0)) (do ((i (values 0) (+ i 1))) (((values = i 10)) (values x 2 3)) (set! x (+ x i)))) 4) 54) ; (+ 45 2 3 4) = 54 + stack: + gc_protect, sc->code: (values x 2 3), args (the "c" in c_pc_1): '(45 2 3), sc->value: #t + safe_c_pc_1 + catch + let_one_p_old_1 + */ + 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: + /* 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_EVAL_MACRO_MV: /* perhaps reader-cond expansion at eval-time (not at run-time) via ((let () reader-cond) ...)? */ + { + const opcode_t s_op = stack_top4_op(sc); + if ((S7_DEBUGGING) && (SHOW_EVAL_OPS == 1)) /* the == 1 business is for clang++ */ + fprintf(stderr, " eval_macro_mv splice %s with %s, code: %s, args: %s, value: %s\n", + display_truncated(args), op_names[s_op], display_truncated(sc->code), display_truncated(sc->args), display_truncated(sc->value)); + if ((s_op == OP_DO_STEP) || (s_op == OP_DEACTIVATE_GOTO) || (s_op == OP_LET1)) + return(args); /* tricky reader-cond as macro in do body returning values... or call-with-exit */ + + /* if eval_args2 here, how to maintain the current evaluation? + * (+ (reader-cond (#t 1 (values 2 3) 4))) -> 10 + * (+ (((vector reader-cond) 0) (#t 1 (values 2 3) 4))) -> 5 [10 if this block of code is included, s7test is ok with this code] + */ + if (s_op == OP_EVAL_ARGS2) + { + begin_temp(sc->y, args); + for (arglist = args; is_pair(cdr(arglist)); arglist = cdr(arglist)) + stack_top4_args(sc) = cons(sc, car(arglist), stack_top4_args(sc)); + end_temp(sc->y); + if (SHOW_EVAL_OPS) + fprintf(stderr, " eval_macro splice %s with %s, code: %s, args: %s, value: %s -> %s %s\n", + display_truncated(args), op_names[s_op], display_truncated(sc->code), display_truncated(sc->args), + display_truncated(sc->value), display_truncated(stack_top4_args(sc)), display_truncated(car(arglist))); + return(car(arglist)); + } + /* else fall through */ + /* safe_c_p_1 also happens and currently drops trailing arg: ((let () reader-cond) (#t (values 1 2) (iv))) + * op_eval_macro (not op_expansion) is called and can be included below (except it segfaults in s7test...), but trailing arg + * is still dropped because optimizer sees (reader-cond ...) -- one arg! + * (define iv (int-vector 1 2)) (define (func) (eof-object? ((let () reader-cond) (#t (values 1 2) (iv))))) (func) + */ + } + + 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; but it could be OP_LOAD_RETURN_IF_EOF if the expansion is at top level). + * (+ (reader-cond (#t 1 (values 2 3) 4))) + */ + if (SHOW_EVAL_OPS) + { + s7_int old_print_length = sc->print_length; + if (old_print_length > 40) sc->print_length = 40; + fprintf(stderr, " %s[%d]: %s stack top: %" ld64 ", op: %s, args: %s\n", __func__, __LINE__, + op_names[stack_top_op(sc)], (s7_int)(intptr_t)stack_top(sc), op_names[stack_top4_op(sc)], display_truncated(args)); + sc->print_length = old_print_length; + } + if (stack_top4_op(sc) == OP_LOAD_RETURN_IF_EOF) + { + /* expansion at top-level returned values, eval args in order */ + sc->code = args; + push_stack_no_args_direct(sc, sc->begin_op); + return(sc->code); + } + for (arglist = args; is_pair(cdr(arglist)); arglist = cdr(arglist)) + stack_top4_args(sc) = cons(sc, car(arglist), stack_top4_args(sc)); + pop_stack_no_op(sc); /* need GC protection in loop above, so do this afterwards */ + return(car(arglist)); /* sc->value from OP_READ_LIST point of view */ + + case OP_EVAL_DONE: /* ((lambda (w) 1) (char-ready? (open-input-function (lambda (x) (values 1 2 3 4 5 6 7))))) */ + if (stack_top4_op(sc) == OP_NO_VALUES) + error_nr(sc, sc->error_symbol, + set_elist_1(sc, wrap_string(sc, "function-port should not return multiple-values", 47))); + set_stack_top_op(sc, OP_SPLICE_VALUES); /* tricky -- continue from eval_done with the current splice */ + set_stack_top_args(sc, args); + push_stack_op(sc, OP_EVAL_DONE); + return(args); + + default: + /* (let () (define (f1) (do ((i 0 (+ i 1))) ((= i 1)) (values (append "" (block)) 1))) (f1)) safe_dotimes_step_o */ + /* ((values memq (values #\a '(#\A 97 #\a)))) eval_args */ + if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: splice gives up: %s\n", __func__, __LINE__, op_names[stack_top_op(sc)]); + 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 -------------------------------- */ +static s7_pointer g_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)); +} + +s7_pointer s7_values(s7_scheme *sc, s7_pointer args) +{ + if (is_null(args)) + return(sc->no_value); + if (is_null(cdr(args))) + return(car(args)); + if (sc->stack_start >= sc->stack_end) /* s7_values called when no s7 stack (ffitest.c for example) */ + { + set_multiple_value(args); + return(args); + } + return(splice_in_values(sc, args)); +} + +static s7_pointer values_p(s7_scheme *sc) {return(sc->no_value);} +static s7_pointer values_p_p(s7_scheme *unused_sc, s7_pointer p) {return(p);} + +static s7_pointer values_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr) +{ + if (args > 1) return(sc->values_uncopied); /* splice_in_values */ + return(func); +} + +bool s7_is_multiple_value(s7_pointer obj) {return(is_multiple_value(obj));} + + +/* -------------------------------- list-values -------------------------------- */ +static s7_pointer splice_out_values(s7_scheme *sc, s7_pointer args) +{ /* (list-values ... (values) ... ) removes the (values) */ + s7_pointer tp; + while (car(args) == sc->no_value) {args = cdr(args); if (is_null(args)) return(sc->nil);} + tp = list_1(sc, car(args)); + if (is_null(cdr(args))) return(tp); + begin_temp(sc->x, tp); + for (s7_pointer 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); + } + end_temp(sc->x); + return(tp); +} + +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 arglist; + bool checked = false; + for (arglist = args; is_pair(arglist); arglist = cdr(arglist)) + if (is_pair(car(arglist))) + { + if (is_checked(car(arglist))) + checked = true; + } + else + if (car(arglist) == sc->no_value) /* car_unchecked|cdr unrolled here is not faster */ + break; + if (is_null(arglist)) + { + if (!checked) /* (!tree_has_definer(sc, args)) seems to work, reduces copy_tree calls slightly, but costs more than it saves in tgen */ + { + for (s7_pointer p = args; is_pair(p); p = cdr(p)) /* embedded list can be immutable, so we need to copy (sigh) */ + if (is_immutable_pair(p)) /* immutable if unheaped sometimes! (tset.scm typed-let) */ + return(copy_proper_list(sc, args)); + return(args); + } + begin_temp(sc->temp6, 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(sc, car(args))) ? copy_tree_with_type(sc, car(args)) : car(args), + (is_unquoted_pair(sc, 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 */ + end_temp(sc->temp6); + 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? + */ + return(splice_out_values(sc, args)); +} + +static s7_pointer g_simple_list_values(s7_scheme *sc, s7_pointer args) +{ + /* if just (code-)constant/symbol, symbol->pair won't be checked (not optimized/re-expanded code), but might be no-values */ + for (s7_pointer p = args; is_pair(p); p = cdr(p)) + if (car(p) == sc->no_value) + return(splice_out_values(sc, args)); + if (is_immutable(args)) + return(copy_proper_list(sc, args)); + return(args); +} + +static s7_pointer list_values_chooser(s7_scheme *sc, s7_pointer func, int32_t unused_args, s7_pointer expr) +{ + for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p)) + if (is_unquoted_pair(sc, car(p))) + return(func); + return(sc->simple_list_values); +} + + +/* -------------------------------- 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 arg; /* apply-values takes 1 arg: ,@a -> (apply-values a) */ + if (is_null(args)) return(sc->no_value); + arg = car(args); + if (is_null(arg)) return(sc->no_value); + if (!s7_is_proper_list(sc, arg)) apply_list_error_nr(sc, arg); + if (is_null(cdr(arg))) return(car(arg)); /* needs to follow previous because it might not be a pair: (apply-values 2) */ + set_needs_copied_args(arg); + return(splice_in_values(sc, arg)); + /* return(s7_values(sc, x)); *//* g_values == s7_values */ +} + +/* (apply values ...) replaces (unquote_splicing ...) + * (define-macro (hi a) `(+ 1 ,a) == (list '+ 1 a) + * (define-macro (hi a) `(+ 1 ,@a) == (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) but in s7 this is an error. + * also in CL the target of ,@ can apparently be a circular list + */ + + +/* -------------------------------- 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 lst, slow; + for (lst = form, slow = form; is_pair(lst); lst = cdr(lst), slow = cdr(slow)) + { + if (is_pair(car(lst))) + { + if (!is_simple_code(sc, car(lst))) + return(false); + } + else + if (car(lst) == sc->unquote_symbol) + return(false); + lst = cdr(lst); + if (!is_pair(lst)) return(is_null(lst)); + if (lst == slow) return(false); + if (is_pair(car(lst))) + { + if (!is_simple_code(sc, car(lst))) + return(false); + } + else + if (car(lst) == sc->unquote_symbol) + return(false); + } + return(is_null(lst)); +} + +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, sc->quote_function, 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))) + syntax_error_nr(sc, "unquote: no argument, ~S", 24, form); + syntax_error_nr(sc, "unquote: stray dot, ~S", 22, form); + } + if (is_not_null(cddr(form))) + syntax_error_nr(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))) + return(list_2(sc, sc->quote_function, form)); + + { + s7_pointer orig, bq; + const s7_pointer old_scw = sc->w; /* very often, sc->w is in use here */ + bool dotted = false; + s7_int len = s7_list_length(sc, form); + if (len < 0) + { + len = -len; + dotted = true; + } + gc_protect_via_stack(sc, sc->w); + + check_free_heap_size(sc, len + 1); + sc->w = sc->nil; /* temp6? */ + for (s7_int i = 0; i <= len; i++) + sc->w = cons_unchecked(sc, sc->nil, sc->w); + + set_car(sc->w, initial_value(sc->list_values_symbol)); + if (!dotted) + { + s7_int i = 0; + for (orig = form, bq = cdr(sc->w); 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_gc_protect(sc); + syntax_error_nr(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, initial_value(sc->qq_append_symbol), sc->w, caddr(orig)); /* `(f . ,(string-append "h" "i")) */ + break; + } + else set_car(bq, g_quasiquote_1(sc, car(orig), false)); + } + else /* `(1 2 . 3) */ + { + s7_int i = 0; + len--; + for (orig = form, bq = cdr(sc->w); 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, initial_value(sc->qq_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_gc_protect(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 */ +{ + return(g_quasiquote_1(sc, car(args), true)); +} + +static s7_pointer g_qq_append(s7_scheme *sc, s7_pointer args) +{ + #define H_qq_append ": CL list* (I think) for quasiquote's internal use" + #define Q_qq_append s7_make_signature(sc, 3, sc->is_list_symbol, sc->is_list_symbol, sc->T) + + const s7_pointer a = car(args), b = cadr(args); + s7_pointer p, tp, np; + if (is_null(a)) return(b); + if (!is_pair(a)) /* (apply ``(x . 1) '(0 1 2)) so a=1, b=2 */ + wrong_type_error_nr(sc, sc->quasiquote_symbol, 1, a, a_list_string); + p = cdr(a); + 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_gc_protect(sc); + return(tp); +} + + +/* -------------------------------- 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 func = s7_make_safe_function(sc, name, f, required_args, optional_args, rest_arg, NULL); + s7_function_set_class(sc, func, cls); + c_function_set_signature(func, c_function_signature(cls)); + return(func); +} + +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 func = s7_make_function(sc, name, f, required_args, optional_args, rest_arg, NULL); + s7_function_set_class(sc, func, cls); + c_function_set_signature(func, c_function_signature(cls)); + return(func); +} + +static s7_pointer set_function_chooser(s7_pointer sym, s7_pointer (*chooser)(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr)) +{ + s7_pointer func = global_value(sym); + c_function_chooser(func) = chooser; + return(func); +} + +static void init_choosers(s7_scheme *sc) +{ + s7_pointer func; + + /* + */ + func = set_function_chooser(sc->add_symbol, add_chooser); + sc->add_class = c_function_class(func); + sc->add_2 = make_function_with_class(sc, func, "+", g_add_2, 2, 0, false); + sc->add_3 = make_function_with_class(sc, func, "+", g_add_3, 3, 0, false); + sc->add_4 = make_function_with_class(sc, func, "+", g_add_4, 4, 0, false); + sc->add_1x = make_function_with_class(sc, func, "+", g_add_1x, 2, 0, false); + sc->add_x1 = make_function_with_class(sc, func, "+", g_add_x1, 2, 0, false); + sc->add_i_random = make_function_with_class(sc, func, "+", g_add_i_random, 2, 0, false); + + /* - */ + func = set_function_chooser(sc->subtract_symbol, subtract_chooser); + sc->subtract_class = c_function_class(func); + sc->subtract_1 = make_function_with_class(sc, func, "-", g_subtract_1, 1, 0, false); + sc->subtract_2 = make_function_with_class(sc, func, "-", g_subtract_2, 2, 0, false); + sc->subtract_3 = make_function_with_class(sc, func, "-", g_subtract_3, 3, 0, false); + sc->subtract_x1 = make_function_with_class(sc, func, "-", g_subtract_x1, 2, 0, false); + sc->subtract_2f = make_function_with_class(sc, func, "-", g_subtract_2f, 2, 0, false); + sc->subtract_f2 = make_function_with_class(sc, func, "-", g_subtract_f2, 2, 0, false); + + /* * */ + func = set_function_chooser(sc->multiply_symbol, multiply_chooser); + sc->multiply_class = c_function_class(func); + sc->multiply_2 = make_function_with_class(sc, func, "*", g_multiply_2, 2, 0, false); + sc->multiply_3 = make_function_with_class(sc, func, "*", g_multiply_3, 3, 0, false); + + /* / */ + func = set_function_chooser(sc->divide_symbol, divide_chooser); + sc->invert_1 = make_function_with_class(sc, func, "/", g_invert_1, 1, 0, false); + sc->divide_2 = make_function_with_class(sc, func, "/", g_divide_2, 2, 0, false); + sc->invert_x = make_function_with_class(sc, func, "/", g_invert_x, 2, 0, false); + sc->divide_by_2 = make_function_with_class(sc, func, "/", g_divide_by_2, 2, 0, false); + + /* = */ + func = set_function_chooser(sc->num_eq_symbol, num_eq_chooser); + sc->num_eq_class = c_function_class(func); + sc->num_eq_2 = make_function_with_class(sc, func, "=", g_num_eq_2, 2, 0, false); + sc->num_eq_xi = make_function_with_class(sc, func, "=", g_num_eq_xi, 2, 0, false); + sc->num_eq_ix = make_function_with_class(sc, func, "=", g_num_eq_ix, 2, 0, false); + + /* min */ + func = set_function_chooser(sc->min_symbol, min_chooser); + sc->min_2 = make_function_with_class(sc, func, "s7-min", g_min_2, 2, 0, false); + sc->min_3 = make_function_with_class(sc, func, "s7-min", g_min_3, 3, 0, false); + + /* max */ + func = set_function_chooser(sc->max_symbol, max_chooser); + sc->max_2 = make_function_with_class(sc, func, "s7-max", g_max_2, 2, 0, false); + sc->max_3 = make_function_with_class(sc, func, "s7-max", g_max_3, 3, 0, false); + + /* < */ + func = set_function_chooser(sc->lt_symbol, less_chooser); + sc->less_xi = make_function_with_class(sc, func, "<", g_less_xi, 2, 0, false); + sc->less_x0 = make_function_with_class(sc, func, "<", g_less_x0, 2, 0, false); + sc->less_xf = make_function_with_class(sc, func, "<", g_less_xf, 2, 0, false); + sc->less_2 = make_function_with_class(sc, func, "<", g_less_2, 2, 0, false); + + /* > */ + func = set_function_chooser(sc->gt_symbol, greater_chooser); + sc->greater_xi = make_function_with_class(sc, func, ">", g_greater_xi, 2, 0, false); + sc->greater_xf = make_function_with_class(sc, func, ">", g_greater_xf, 2, 0, false); + sc->greater_2 = make_function_with_class(sc, func, ">", g_greater_2, 2, 0, false); + + /* <= */ + func = set_function_chooser(sc->leq_symbol, leq_chooser); + sc->leq_xi = make_function_with_class(sc, func, "<=", g_leq_xi, 2, 0, false); + sc->leq_2 = make_function_with_class(sc, func, "<=", g_leq_2, 2, 0, false); + sc->leq_ixx = make_function_with_class(sc, func, "<=", g_leq_ixx, 3, 0, false); + + /* >= */ + func = set_function_chooser(sc->geq_symbol, geq_chooser); + sc->geq_xi = make_function_with_class(sc, func, ">=", g_geq_xi, 2, 0, false); + sc->geq_xf = make_function_with_class(sc, func, ">=", g_geq_xf, 2, 0, false); + sc->geq_2 = make_function_with_class(sc, func, ">=", g_geq_2, 2, 0, false); + + /* log */ + func = set_function_chooser(sc->log_symbol, log_chooser); + sc->int_log2 = make_function_with_class(sc, func, "log", g_int_log2, 2, 0, false); + + /* logior */ + func = set_function_chooser(sc->logior_symbol, logior_chooser); + sc->logior_2 = make_function_with_class(sc, func, "logior", g_logior_2, 2, 0, false); + sc->logior_ii = make_function_with_class(sc, func, "logior", g_logior_ii, 2, 0, false); + + /* logand */ + func = set_function_chooser(sc->logand_symbol, logand_chooser); + sc->logand_2 = make_function_with_class(sc, func, "logand", g_logand_2, 2, 0, false); + sc->logand_ii = make_function_with_class(sc, func, "logand", g_logand_ii, 2, 0, false); + + /* logxor */ + func = set_function_chooser(sc->logxor_symbol, logxor_chooser); + sc->logxor_2 = make_function_with_class(sc, func, "logxor", g_logxor_2, 2, 0, false); + + /* ash */ + func = set_function_chooser(sc->ash_symbol, ash_chooser); + sc->ash_ii = make_function_with_class(sc, func, "ash", g_ash_ii, 2, 0, false); + sc->ash_ic = make_function_with_class(sc, func, "ash", g_ash_ic, 2, 0, false); + + /* random */ + func = set_function_chooser(sc->random_symbol, random_chooser); + sc->random_1 = make_function_with_class(sc, func, "random", g_random_1, 1, 0, false); + sc->random_i = make_function_with_class(sc, func, "random", g_random_i, 1, 0, false); + sc->random_f = make_function_with_class(sc, func, "random", g_random_f, 1, 0, false); + + /* defined? */ + func = set_function_chooser(sc->is_defined_symbol, is_defined_chooser); + sc->is_defined_in_rootlet = make_function_with_class(sc, func, "defined?", g_is_defined_in_rootlet, 2, 0, false); + sc->is_defined_in_unlet = make_function_with_class(sc, func, "defined?", g_is_defined_in_unlet, 2, 0, false); + + /* char=? */ + func = set_function_chooser(sc->char_eq_symbol, char_equal_chooser); + sc->simple_char_eq = make_function_with_class(sc, func, "char=?", g_simple_char_eq, 2, 0, false); + sc->simple_char_eq1 = make_function_with_class(sc, func, "char=?", g_simple_char_eq1, 2, 0, false); + sc->simple_char_eq2 = make_function_with_class(sc, func, "char=?", g_simple_char_eq2, 2, 0, false); + sc->char_equal_2 = make_function_with_class(sc, func, "char=?", g_char_equal_2, 2, 0, false); + + /* char>? */ + func = set_function_chooser(sc->char_gt_symbol, char_greater_chooser); + sc->char_greater_2 = make_function_with_class(sc, func, "char>?", g_char_greater_2, 2, 0, false); + + /* charchar_lt_symbol, char_less_chooser); + sc->char_less_2 = make_function_with_class(sc, func, "charread_char_symbol, read_char_chooser); + sc->read_char_1 = make_function_with_class(sc, func, "read-char", g_read_char_1, 1, 0, false); + + /* char-position */ + func = set_function_chooser(sc->char_position_symbol, char_position_chooser); + sc->char_position_csi = make_function_with_class(sc, func, "char-position", g_char_position_csi, 2, 1, false); + + /* string=? */ + func = set_function_chooser(sc->string_eq_symbol, string_equal_chooser); + sc->string_equal_2 = make_function_with_class(sc, func, "string=?", g_string_equal_2, 2, 0, false); + sc->string_equal_2c = make_function_with_class(sc, func, "string=?", g_string_equal_2c, 2, 0, false); + + /* substring */ + /* sc->substring_uncopied = s7_make_safe_function(sc, "substring", g_substring_uncopied, 1, 2, false, NULL); */ /* now exported to Scheme 28-May-24 */ + sc->substring_uncopied = global_value(sc->substring_uncopied_symbol); + s7_function_set_class(sc, sc->substring_uncopied, global_value(sc->substring_symbol)); + + /* string>? */ + func = set_function_chooser(sc->string_gt_symbol, string_greater_chooser); + sc->string_greater_2 = make_function_with_class(sc, func, "string>?", g_string_greater_2, 2, 0, false); + + /* stringstring_lt_symbol, string_less_chooser); + sc->string_less_2 = make_function_with_class(sc, func, "stringstring_symbol, string_chooser); + sc->string_c1 = make_function_with_class(sc, func, "string", s7i_string_c1, 1, 0, false); + + /* string-append */ + func = set_function_chooser(sc->string_append_symbol, string_append_chooser); + sc->string_append_2 = make_function_with_class(sc, func, "string-append", g_string_append_2, 2, 0, false); + + /* string-ref et al */ + set_function_chooser(sc->string_ref_symbol, string_substring_chooser); + set_function_chooser(sc->string_to_symbol_symbol, string_substring_chooser); /* not string_to_number here (not const char*??) */ + set_function_chooser(sc->string_to_keyword_symbol, string_substring_chooser); + set_function_chooser(sc->string_position_symbol, string_substring_chooser); + set_function_chooser(sc->string_geq_symbol, string_substring_chooser); + set_function_chooser(sc->string_leq_symbol, string_substring_chooser); + set_function_chooser(sc->string_copy_symbol, string_copy_chooser); + set_function_chooser(sc->eval_string_symbol, string_substring_chooser); + set_function_chooser(sc->symbol_symbol, string_substring_chooser); + set_function_chooser(sc->string_to_byte_vector_symbol, string_substring_chooser); + /* if the function assumes a null-terminated string, substring needs to return a copy (which assume this?) */ +#if !WITH_PURE_S7 + set_function_chooser(sc->string_length_symbol, string_substring_chooser); + set_function_chooser(sc->string_to_list_symbol, string_substring_chooser); +#endif + + /* also: directory->list substring with-input-from-file with-input-from-string with-output-to-file open-output-file open-input-file + * system load getenv file-mtime gensym directory? call-with-output-file delete-file call-with-input-file call-with-input-string open-input-string + * length et al? + */ + + /* symbol->string */ + func = global_value(sc->symbol_to_string_symbol); + sc->symbol_to_string_uncopied = s7_make_safe_function(sc, "symbol->string", g_symbol_to_string_uncopied, 1, 0, false, NULL); + s7_function_set_class(sc, sc->symbol_to_string_uncopied, func); + + /* symbol->value */ + func = global_value(sc->symbol_to_value_symbol); + set_function_chooser(sc->symbol_to_value_symbol, symbol_to_value_chooser); + sc->sv_unlet_ref = make_function_with_class(sc, func, "symbol->value", g_sv_unlet_ref, 1, 1, false); + + /* display */ + func = set_function_chooser(sc->display_symbol, display_chooser); + sc->display_f = make_function_with_class(sc, func, "display", g_display_f, 2, 0, false); + sc->display_2 = make_function_with_class(sc, func, "display", g_display_2, 2, 0, false); + + /* write */ + func = set_function_chooser(sc->write_symbol, write_chooser); + sc->write_2 = make_function_with_class(sc, func, "write", g_write_2, 2, 0, false); + + /* vector */ + func = set_function_chooser(sc->vector_symbol, vector_chooser); + sc->vector_2 = make_function_with_class(sc, func, "vector", g_vector_2, 2, 0, false); + sc->vector_3 = make_function_with_class(sc, func, "vector", g_vector_3, 3, 0, false); + + /* vector-ref */ + func = set_function_chooser(sc->vector_ref_symbol, vector_ref_chooser); + sc->vector_ref_2 = make_function_with_class(sc, func, "vector-ref", g_vector_ref_2, 2, 0, false); + sc->vector_ref_3 = make_function_with_class(sc, func, "vector-ref", g_vector_ref_3, 3, 0, false); + + /* vector-set! */ + func = set_function_chooser(sc->vector_set_symbol, vector_set_chooser); + sc->vector_set_3 = make_function_with_class(sc, func, "vector-set!", g_vector_set_3, 3, 0, false); + sc->vector_set_4 = make_function_with_class(sc, func, "vector-set!", g_vector_set_4, 4, 0, false); + + /* complex-vector-ref */ + func = set_function_chooser(sc->complex_vector_ref_symbol, complex_vector_ref_chooser); + sc->cv_ref_2 = make_function_with_class(sc, func, "complex-vector-ref", g_cv_ref_2, 2, 0, false); + + /* complex-vector-set */ + func = set_function_chooser(sc->complex_vector_set_symbol, complex_vector_set_chooser); + sc->cv_set_3 = make_function_with_class(sc, func, "complex-vector-set!", g_cv_set_3, 3, 0, false); + sc->complex_wrapped = make_function_with_class(sc, func, "complex", g_complex_wrapped, 2, 0, false); /* not used currently? */ + + /* float-vector-ref */ + func = set_function_chooser(sc->float_vector_ref_symbol, float_vector_ref_chooser); + sc->fv_ref_2 = make_function_with_class(sc, func, "float-vector-ref", g_fv_ref_2, 2, 0, false); + sc->fv_ref_3 = make_function_with_class(sc, func, "float-vector-ref", g_fv_ref_3, 3, 0, false); + + /* float-vector-set */ + func = set_function_chooser(sc->float_vector_set_symbol, float_vector_set_chooser); + sc->fv_set_3 = make_function_with_class(sc, func, "float-vector-set!", g_fv_set_3, 3, 0, false); + sc->fv_set_unchecked = make_function_with_class(sc, func, "float-vector-set!", g_fv_set_unchecked, 3, 0, false); + + /* int-vector-ref */ + func = set_function_chooser(sc->int_vector_ref_symbol, int_vector_ref_chooser); + sc->iv_ref_2 = make_function_with_class(sc, func, "int-vector-ref", g_iv_ref_2, 2, 0, false); + sc->iv_ref_3 = make_function_with_class(sc, func, "int-vector-ref", g_iv_ref_3, 3, 0, false); + + /* int-vector-set */ + func = set_function_chooser(sc->int_vector_set_symbol, int_vector_set_chooser); + sc->iv_set_3 = make_function_with_class(sc, func, "int-vector-set!", g_iv_set_3, 3, 0, false); + + /* byte-vector-ref */ + func = set_function_chooser(sc->byte_vector_ref_symbol, byte_vector_ref_chooser); + sc->bv_ref_2 = make_function_with_class(sc, func, "byte-vector-ref", g_bv_ref_2, 2, 0, false); + sc->bv_ref_3 = make_function_with_class(sc, func, "byte-vector-ref", g_bv_ref_3, 3, 0, false); + + /* byte-vector-set */ + func = set_function_chooser(sc->byte_vector_set_symbol, byte_vector_set_chooser); + sc->bv_set_3 = make_function_with_class(sc, func, "byte-vector-set!", g_bv_set_3, 3, 0, false); + + /* list-set! */ + func = set_function_chooser(sc->list_set_symbol, list_set_chooser); + sc->list_set_i = make_function_with_class(sc, func, "list-set!", g_list_set_i, 3, 0, false); + + /* hash-table-ref */ + func = set_function_chooser(sc->hash_table_ref_symbol, hash_table_ref_chooser); + sc->hash_table_ref_2 = make_function_with_class(sc, func, "hash-table-ref", g_hash_table_ref_2, 2, 0, false); + + /* hash-table-set! */ + set_function_chooser(sc->hash_table_set_symbol, hash_table_set_chooser); + + /* hash-table */ + func = set_function_chooser(sc->hash_table_symbol, hash_table_chooser); + sc->hash_table_2 = make_function_with_class(sc, func, "hash-table", g_hash_table_2, 2, 0, false); + + /* format */ + func = set_function_chooser(sc->format_symbol, format_chooser); + sc->format_f = make_function_with_class(sc, func, "format", g_format_f, 1, 0, true); + /* sc->format_nr = make_function_with_class(sc, func, "format", g_format_nr, 1, 0, true); */ + sc->format_no_column = make_function_with_class(sc, func, "format", g_format_no_column, 1, 0, true); + sc->format_just_control_string = make_function_with_class(sc, func, "format", g_format_just_control_string, 2, 0, false); + sc->format_as_objstr = make_function_with_class(sc, func, "format", g_format_as_objstr, 3, 0, true); + + /* list */ + func = set_function_chooser(sc->list_symbol, list_chooser); + sc->list_0 = make_function_with_class(sc, func, "list", g_list_0, 0, 0, false); + sc->list_1 = make_function_with_class(sc, func, "list", g_list_1, 1, 0, false); + sc->list_2 = make_function_with_class(sc, func, "list", g_list_2, 2, 0, false); + sc->list_3 = make_function_with_class(sc, func, "list", g_list_3, 3, 0, false); + sc->list_4 = make_function_with_class(sc, func, "list", g_list_4, 4, 0, false); + + /* append */ + func = set_function_chooser(sc->append_symbol, append_chooser); + sc->append_2 = make_function_with_class(sc, func, "append", g_append_2, 2, 0, false); + + /* list-ref */ + func = set_function_chooser(sc->list_ref_symbol, list_ref_chooser); + sc->list_ref_at_0 = make_function_with_class(sc, func, "list", g_list_ref_at_0, 2, 0, false); + sc->list_ref_at_1 = make_function_with_class(sc, func, "list", g_list_ref_at_1, 2, 0, false); + sc->list_ref_at_2 = make_function_with_class(sc, func, "list", g_list_ref_at_2, 2, 0, false); + + /* assoc */ + set_function_chooser(sc->assoc_symbol, assoc_chooser); + + /* member */ + set_function_chooser(sc->member_symbol, member_chooser); + + /* memq */ + func = set_function_chooser(sc->memq_symbol, memq_chooser); /* in pure-s7, use member here */ + sc->memq_2 = make_function_with_class(sc, func, "memq", g_memq_2, 2, 0, false); + sc->memq_3 = make_function_with_class(sc, func, "memq", g_memq_3, 2, 0, false); + sc->memq_4 = make_function_with_class(sc, func, "memq", g_memq_4, 2, 0, false); + sc->memq_any = make_function_with_class(sc, func, "memq", g_memq_any, 2, 0, false); + + /* tree-set-memq */ + func = set_function_chooser(sc->tree_set_memq_symbol, tree_set_memq_chooser); + sc->tree_set_memq_syms = make_function_with_class(sc, func, "tree-set-memq", g_tree_set_memq_syms, 2, 0, false); + + /* dynamic-wind */ + func = set_function_chooser(sc->dynamic_wind_symbol, dynamic_wind_chooser); + sc->dynamic_wind_unchecked = make_unsafe_function_with_class(sc, func, "dynamic-wind", g_dynamic_wind_unchecked, 3, 0, false); + sc->dynamic_wind_body = make_unsafe_function_with_class(sc, func, "dynamic-wind", g_dynamic_wind_body, 3, 0, false); + sc->dynamic_wind_init = make_unsafe_function_with_class(sc, func, "dynamic-wind", g_dynamic_wind_init, 3, 0, false); + + /* unlet */ + sc->unlet_disabled = make_function_with_class(sc, global_value(sc->unlet_symbol), "unlet", g_unlet_disabled, 0, 0, false); + + /* outlet */ + func = set_function_chooser(sc->outlet_symbol, outlet_chooser); + sc->outlet_unlet = make_function_with_class(sc, func, "outlet", g_outlet_unlet, 1, 0, false); + + /* inlet */ + func = set_function_chooser(sc->inlet_symbol, inlet_chooser); + sc->simple_inlet = make_function_with_class(sc, func, "inlet", g_simple_inlet, 0, 0, true); + + /* sublet */ + func = set_function_chooser(sc->sublet_symbol, sublet_chooser); + sc->sublet_curlet = make_function_with_class(sc, func, "sublet", g_sublet_curlet, 3, 0, false); + + /* let-ref */ + func = set_function_chooser(sc->let_ref_symbol, let_ref_chooser); + sc->cdr_let_ref = make_function_with_class(sc, func, "let-ref", g_cdr_let_ref, 2, 0, false); + sc->starlet_ref = make_function_with_class(sc, func, "let-ref", g_starlet_ref, 2, 0, false); + sc->rootlet_ref = make_function_with_class(sc, func, "let-ref", g_rootlet_ref, 2, 0, false); + sc->curlet_ref = make_function_with_class(sc, func, "let-ref", g_curlet_ref, 2, 0, false); + sc->unlet_ref = make_function_with_class(sc, func, "let-ref", g_unlet_ref, 2, 0, false); + + /* let-set */ + func = set_function_chooser(sc->let_set_symbol, let_set_chooser); + sc->cdr_let_set = make_function_with_class(sc, func, "let-set!", g_cdr_let_set, 3, 0, false); + sc->unlet_set = make_function_with_class(sc, func, "let-set!", g_unlet_set, 3, 0, false); + sc->starlet_set = make_function_with_class(sc, func, "let-set!", g_starlet_set, 3, 0, false); + + /* values */ + func = set_function_chooser(sc->values_symbol, values_chooser); + sc->values_uncopied = make_unsafe_function_with_class(sc, func, "values", splice_in_values, 0, 0, true); + + /* list-values */ + func = set_function_chooser(sc->list_values_symbol, list_values_chooser); + sc->simple_list_values = make_function_with_class(sc, func, "list-values", g_simple_list_values, 0, 0, true); + + sc->restore_setter = s7_make_function(sc, "#", g_restore_setter, 1, 0, false, "map closure-setter restoration (for dynamic-unwind)"); +} + + +/* ---------------- *unbound-variable-hook* ---------------- */ +#if !DISABLE_AUTOLOAD +static s7_pointer loaded_library(s7_scheme *sc, const char *file) +{ + for (s7_pointer libs = global_value(sc->libraries_symbol); is_pair(libs); libs = cdr(libs)) + if (local_strcmp(file, string_value(caar(libs)))) + return(cdar(libs)); + return(sc->nil); +} +#endif + +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 */ + } +} + +#define LEVEN_MIN_LEN 2 +#define LEVEN_MAX_LEN 23 +static int32_t **original_distance; + +static void init_leven(void) +{ + int32_t i, j; + original_distance = (int32_t **)malloc((LEVEN_MAX_LEN + 1) * sizeof(int32_t *)); + for (i = 0; i <= LEVEN_MAX_LEN; i++) original_distance[i] = (int32_t *)calloc(LEVEN_MAX_LEN + 1, sizeof(int32_t)); + for (j = 0; j <= LEVEN_MAX_LEN; j++) original_distance[0][j] = j; + for (i = 0; i <= LEVEN_MAX_LEN; i++) original_distance[i][0] = i; +} + +static int32_t levenshtein(s7_scheme *sc, const char *s1, int32_t len1, const char *s2, int32_t len2) +{ + int32_t i, j; + int32_t mx = (len1 > len2) ? len1 : len2; + if ((mx > LEVEN_MAX_LEN) || (mx < LEVEN_MIN_LEN)) return(100); + for (i = 0; i <= mx; i++) + memcpy((void *)(sc->current_distance[i]), (void *)(original_distance[i]), mx * sizeof(int32_t)); /* TODO: (mx+1?) */ + for (i = 1; i <= len2; i++) + for (j = 1; j <= len1; j++) + { + int32_t c1, c2, c3; + c1 = sc->current_distance[i][j - 1] + 1; + c2 = sc->current_distance[i - 1][j] + 1; + c3 = sc->current_distance[i - 1][j - 1] + ((s2[i - 1] == s1[j - 1]) ? 0 : 1); + if (c1 > c2) c1 = c2; + if (c1 > c3) c1 = c3; + sc->current_distance[i][j] = c1; + } + return(sc->current_distance[len2][len1]); +} + +static no_return void unbound_variable_error_nr(s7_scheme *sc, s7_pointer sym) +{ + s7_pointer err_code = NULL; + if ((is_pair(current_code(sc))) && (s7_tree_memq(sc, sym, current_code(sc)))) + err_code = current_code(sc); + else + if ((is_pair(sc->code)) && (s7_tree_memq(sc, sym, sc->code))) + err_code = sc->code; +#if WITH_HISTORY + else + { + s7_pointer p; + for (p = cdr(sc->cur_code); cdr(p) != sc->cur_code; p = cdr(p)); + if ((is_pair(car(p))) && (s7_tree_memq(sc, sym, car(p)))) err_code = car(p); + } +#endif + + if (starlet_symbol_id(T_Sym(sym)) != sl_no_field) + { + if (err_code) + error_nr(sc, sc->unbound_variable_symbol, + set_elist_4(sc, wrap_string(sc, "unbound variable ~S in ~S, perhaps you meant (*s7* '~S)?", 56), sym, err_code, sym)); + error_nr(sc, sc->unbound_variable_symbol, + set_elist_3(sc, wrap_string(sc, "unbound variable ~S, perhaps you meant (*s7* '~S)?", 50), sym, sym)); + } + /* fprintf(stderr, "%s: %s in %s %" ld64 "\n", __func__, display(sym), (err_code) ? display(err_code) : "no code", (err_code && (has_location(err_code))) ? pair_line_number(err_code) : -1); */ + { + const s7_int sym_len = symbol_name_length(sym); + int32_t min_diff = (sym_len == 1) ? 0 : ((sym_len == 2) ? 2 : 3); + if (min_diff > 0) + { + /* check let chain */ + const char *sym_name = symbol_name(sym); + s7_pointer min_sym = NULL; + for (s7_pointer let = sc->curlet; let; let = let_outlet(let)) + for (s7_pointer slot = let_slots(let); is_not_slot_end(slot); slot = next_slot(slot)) + { + const s7_pointer cur_sym = slot_symbol(slot); + if (s7_int_abs(sym_len - symbol_name_length(cur_sym)) < 2) + { + int32_t diff = levenshtein(sc, sym_name, sym_len, symbol_name(cur_sym), symbol_name_length(cur_sym)); + if (sym_name[0] != symbol_name(cur_sym)[0]) diff++; + if (diff < min_diff) + { + min_diff = diff; + min_sym = cur_sym; + }}} + /* fprintf(stderr, "min_sym: %s, err_code: %s\n", (min_sym) ? display(min_sym) : "none", display(err_code)); */ + if ((!min_sym) && (err_code) && (is_pair(err_code)) && + (sym == car(err_code)) && (sym_len < 24)) /* don't treat these as common variables */ + { /* perhaps also check that the suggested new name actually fits the rest of err_code!: "char -> caar (char #\a)" */ + /* check main symbols, from t865.scm */ + #define MAIN_NAMES_SIZE 443 + static const char *main_names[MAIN_NAMES_SIZE] = { + "<=", ">=", "do", "gc", "if", "or", "pi", "abs", "and", "ash", "car", "cdr", "cos", "eq?", "exp", "gcd", + "lcm", "let", "log", "map", "s7-max", "s7-min", "nan", "not", "sin", "sym", "tan", "*s7*", "acos", "asin", + "assq", "assv", "atan", "caar", "cadr", "case", "cdar", "cddr", "cond", "cons", "copy", "cosh", "else", + "eqv?", "eval", "exit", "expt", "help", "let*", "let?", "list", "load", "memq", "memv", "nan?", "odd?", + "read", "set!", "sinh", "sqrt", "tanh", "when", "abort", "acosh", "angle", "apply", "arity", "asinh", + "assoc", "atanh", "bacro", "begin", "byte?", "caaar", "caadr", "cadar", "caddr", "catch", "cdaar", + "cdadr", "cddar", "cdddr", "char?", "error", "even?", "fill!", "floor", "goto?", "index", "inlet", + "list?", "macro", "null?", "owlet", "pair?", "quote", "real?", "s7-round", "sort!", "throw", "unlet", + "write", "zero?", "append", "bacro*", "bignum", "caaaar", "caaadr", "caadar", "caaddr", "cadaar", + "cadadr", "caddar", "cadddr", "cdaaar", "cdaadr", "cdadar", "cdaddr", "cddaar", "cddadr", "cdddar", + "cddddr", "char?", "curlet", "cutlet", "define", "equal?", "exact?", "float?", + "format", "gensym", "getenv", "lambda", "length", "letrec", "logand", "logior", "lognot", "logxor", + "macro*", "macro?", "member", "s7-modulo", "outlet", "random", "setter", "string", "sublet", "symbol", + "system", "unless", "values", "varlet", "vector", "bignum?", "call/cc", "s7-ceiling", "char<=?", + "char>=?", "complex", "define*", "display", "funclet", "gensym?", "iterate", "lambda*", "let-ref", + "letrec*", "logbit?", "newline", "number?", "openlet", "provide", "require", "reverse", "rootlet", + "string?", "symbol?", "syntax?", "type-of", "unquote", "vector?", "boolean?", "complex?", "coverlet", + "defined?", "dilambda", "for-each", "funclet?", "inexact?", "integer?", "keyword?", "let-set!", + "list-ref", "openlet?", "quotient", "reverse!", "set-car!", "set-cdr!", "string?", "s7-truncate", "with-let", "aritable?", "c-object?", "c-pointer", "constant?", "dilambda?", + "hash-code", "imag-part", "infinite?", "iterator?", "let->list", + "list-set!", "list-tail", "magnitude", "make-hook", "make-list", "negative?", "numerator", "peek-char", + "port-file", "positive?", "provided?", "rational?", "read-byte", "read-char", "read-line", "real-part", + "remainder", "sequence?", "signature", "string<=?", "string>=?", "substring", "subvector", "tree-memq", + "*function*", "c-pointer?", "directory?", "file-mtime", "hash-table", + "immutable!", "immutable?", "int-vector", "make-polar", "procedure?", "profile-in", "quasiquote", + "stacktrace", "string-ref", "subvector?", "tree-count", "undefined?", "vector-ref", "write-byte", + "write-char", "byte-vector", "char-ready?", "char-upcase", "cond-expand", "delete-file", "denominator", + "eof-object?", "equivalent?", "eval-string", "hash-table?", "input-port?", "int-vector?", + "list-values", "macroexpand", "make-string", "make-vector", "nan-payload", "object->let", + "port-string", "rationalize", "read-string", "reader-cond", "string-copy", "string-set!", + "tree-leaves", "vector-rank", "vector-set!", + "with-baffle", "apply-values", "byte-vector?", "c-object-let", "define-bacro", "define-macro", + "dynamic-wind", "file-exists?", "float-vector", "list->string", "list->vector", "output-port?", + "port-closed?", "proper-list?", "random-state", "string->list", + "string-fill!", "symbol-table", "tree-cyclic?", "unspecified?", "vector->list", "vector-fill!", + "vector-typer", "write-string", "c-object-type", "char->integer", "char-downcase", "char-numeric?", + "char-position", "continuation?", "define-bacro*", "define-macro*", "documentation", "float-vector?", + "integer->char", "make-iterator", "pair-filename", "port-filename", "port-position", "random-state?", + "string-append", "string-length", "symbol->value", "tree-set-memq", "vector-append", + "vector-length", "c-pointer-info", "c-pointer-type", "call-with-exit", "complex-vector", + "dynamic-unwind", "emergency-exit", "exact->inexact", "hash-table-ref", "hook-functions", + "inexact->exact", "int-vector-ref", "integer-length", "number->string", "object->string", + "string->number", "string->symbol", "symbol->string", "byte-vector-ref", "c-pointer->list", + "c-pointer-weak1", "c-pointer-weak2", "complex-vector?", "define-constant", "directory->list", + "int-vector-set!", "keyword->symbol", "let-temporarily", "make-int-vector", "open-input-file", + "string->keyword", "string-position", "symbol->keyword", "weak-hash-table", + "byte-vector-set!", "call-with-values", "char-alphabetic?", "char-upper-case?", "char-whitespace?", + "close-input-port", "cyclic-sequences", "define-expansion", "float-vector-ref", "iterator-at-end?", + "make-byte-vector", "make-rectangular", "open-output-file", "pair-line-number", "port-line-number", + "procedure-source", "subvector-vector", "vector-dimension", "weak-hash-table?", "close-output-port", + "define-expansion*", "float-vector-set!", "flush-output-port", "get-output-string", + "iterator-sequence", "make-float-vector", "open-input-string", "procedure-arglist", + "vector-dimensions", "complex-vector-ref", "current-error-port", "current-input-port", + "hash-table-entries", "open-output-string", "random-state->list", "s7-hash-table-set!", + "s7-make-hash-table", "substring-uncopied", "subvector-position", "byte-vector->string", + "complex-vector-set!", "current-output-port", "make-complex-vector", "multiple-value-bind", + "open-input-function", "string->byte-vector", "with-output-to-file", "call-with-input-file", + "hash-table-key-typer", "integer-decode-float", "make-weak-hash-table", "open-output-function", + "symbol-initial-value", "with-input-from-file", "call-with-output-file", "symbol->dynamic-value", + "with-output-to-string", "call-with-input-string", "hash-table-value-typer", "set-current-error-port", + "set-current-input-port", "with-input-from-string", "call-with-output-string", + "set-current-output-port" + }; + + static const int32_t main_names_index[LEVEN_MAX_LEN] = {0, 7, 27, 62, 103, 156, 184, 206, 243, 265, 296, 321, 344, 361, + 378, 397, 407, 417, 425, 432, 435, 440, 442}; /* 443==NULL, 7858 - 3576 bytes */ + const int32_t start = main_names_index[sym_len - 2], end = main_names_index[sym_len - 1]; +#if 0 + { /* if above list changed, this might help: */ + const char *starts[22] = {"<=", "cos", "acos", "error", "define", "letrec*", "quotient", "substring", + "int-vector", "object->let", "float-vector", "string-append", + "hook-functions", "c-pointer-weak2", "iterator-at-end?", "open-input-string", + "open-output-string", "string->byte-vector", "with-input-from-file", + "with-output-to-string", "set-current-error-port", "set-current-output-port"}; + fprintf(stderr, "starts[22] = {"); + for (int32_t i = 0; i < 22; i++) + for (int32_t j = 0; j < MAIN_NAMES_SIZE; j++) + if (strcmp(main_names[j], starts[i]) == 0) + { + fprintf(stderr, "%d, ", j); + break; + }} + for (int32_t i = 0; i < LEVEN_MAX_LEN; i++) fprintf(stderr, "%s\n", main_names[main_names_index[i]]); +#endif + for (int32_t i = start; i < end; i++) + { + /* main_names has only 430 entries but main_names_index is sized + for 443, so the length-20..23 buckets run into trailing NULL + slots; skip NULLs to avoid dereferencing them in levenshtein. */ + if (main_names[i] == NULL) continue; + int32_t diff = levenshtein(sc, sym_name, sym_len, main_names[i], sym_len) + 1; /* perhaps same but i+/-1 as well */ + if (sym_name[0] != main_names[i][0]) diff++; + if (diff < min_diff) + { + min_diff = diff; + min_sym = make_symbol(sc, main_names[i], sym_len); + }}} + if (min_sym) + { + if (err_code) + error_nr(sc, sc->unbound_variable_symbol, set_elist_4(sc, wrap_string(sc, "unbound variable ~S in ~S, perhaps ~S?", 38), sym, err_code, min_sym)); + error_nr(sc, sc->unbound_variable_symbol, set_elist_3(sc, wrap_string(sc, "unbound variable ~S, perhaps ~S?", 32), sym, min_sym)); + }}} + + if (err_code) /* these cases look ok */ + error_nr(sc, sc->unbound_variable_symbol, set_elist_3(sc, wrap_string(sc, "unbound variable ~S in ~S", 25), sym, err_code)); + if ((symbol_name(sym)[symbol_name_length(sym) - 1] == ',') && + (lookup_unexamined(sc, make_symbol(sc, symbol_name(sym), symbol_name_length(sym) - 1)))) + error_nr(sc, sc->unbound_variable_symbol, set_elist_2(sc, wrap_string(sc, "unbound variable ~S (perhaps a stray comma?)", 44), sym)); + error_nr(sc, sc->unbound_variable_symbol, set_elist_2(sc, wrap_string(sc, "unbound variable ~S", 19), sym)); +} + +static s7_pointer check_autoload_and_error_hook(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 ((sc->curlet != sc->nil) && + (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) + syntax_error_nr(sc, "unquote (',') occurred outside quasiquote: ~S", 45, current_code(sc)); + + if (safe_strcmp(symbol_name(sym), "|#")) + read_error_nr(sc, "unmatched |#"); + + /* check *autoload*, autoload_names, then *unbound-variable-hook* */ + if ((sc->autoload_names) || + (is_hash_table(sc->autoload_table)) || + ((is_procedure(sc->unbound_variable_hook)) && + (hook_has_functions(sc->unbound_variable_hook)))) + { + s7_pointer cur_code = current_code(sc); + const s7_pointer value = sc->value; + const s7_pointer code = sc->code; + const s7_pointer current_let = sc->curlet; + /* 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. + */ + const s7_pointer args = (sc->args) ? sc->args : sc->nil; + s7_pointer result = sc->undefined; + sc->temp9 = cur_code; + sc->temp7 = cons_unchecked(sc, current_let, cons_unchecked(sc, code, /* perhaps elist_7 except we use elist_3 above? */ + cons_unchecked(sc, args, list_2(sc, value, cur_code)))); /* not s7_list (debugger checks) */ + sc->temp9 = sc->unused; + 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 + if ((sc->is_autoloading) && + (sc->autoload_names)) /* created by s7_autoload_set_names which requires alphabetization by the caller (e.g. snd-xref.c) */ + { + bool loaded = false; + const char *file = find_autoload_name(sc, sym, &loaded, true); + if ((file) && (!loaded)) + { + /* if we've already loaded this file, we can get the library (let) 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 + */ + s7_pointer let = loaded_library(sc, file); + if ((!let) || (!is_let(let))) + { + if (hook_has_functions(sc->autoload_hook)) + s7_apply_function(sc, sc->autoload_hook, set_plist_2(sc, sym, s7_make_string(sc, file))); + let = 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) && (let) && (is_let(let))) + { + /* the current_let refs here are trying to handle local autoloads, but that is problematic -- we'd need to + * save the autoload curlet when autoload is called, and hope the current reference can still access that let? + * but if the same symbol is autloaded in several lets, we are in trouble, and how to handle a function that + * has an autoload? I think I'll just assume rootlet, even though that is not very elegant. Actually in the + * libgsl case, we're trying to export a name from *libgsl* -- should that be done with define rather than autoload? + */ + result = let_ref_p_pp(sc, let, sym); /* add '(sym . result) to current_let (was sc->nil, s7_load can set sc->curlet to sc->nil) */ + if (result != sc->undefined) + s7_define(sc, sc->rootlet, 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))) + { + /* 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... + */ + const s7_pointer val = s7_hash_table_ref(sc, sc->autoload_table, sym); + s7_pointer let = NULL; + 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)); + let = 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)); + let = 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 */ + if ((result == sc->undefined) && (let) && (is_let(let))) /* added 31-Mar-23 to match sc->autoload_names case above */ + { + result = let_ref_p_pp(sc, let, sym); + if (result != sc->undefined) + s7_define(sc, sc->rootlet, sym, result); /* as above, was sc->nil -- s7_load above can set sc->curlet to sc->nil */ + }} +#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_) */ + const s7_pointer old_hook = sc->unbound_variable_hook; + const bool old_history_enabled = s7_set_history_enabled(sc, false); + gc_protect_via_stack(sc, old_hook); + sc->unbound_variable_hook = sc->nil; + result = s7_call(sc, old_hook, set_plist_1(sc, sym)); /* not s7_apply_function */ + if (result == sc->unspecified) result = sc->undefined; + sc->unbound_variable_hook = old_hook; + s7_set_history_enabled(sc, old_history_enabled); + unstack_gc_protect(sc); + }} + sc->value = T_Ext(value); + sc->args = T_Pos(args); /* can be # or #! */ + sc->code = code; + set_curlet(sc, current_let); + sc->temp7 = sc->unused; + return(result); + } + return(sc->undefined); +} + +s7_pointer unbound_variable(s7_scheme *sc, s7_pointer sym) +{ + s7_pointer result = check_autoload_and_error_hook(sc, sym); + if (result != sc->undefined) return(result); + unbound_variable_error_nr(sc, sym); + return(sc->unbound_variable_symbol); +} + +#define choose_c_function(Sc, Expr, Func, Args) set_class_and_fn_proc(Expr, c_function_chooser(Func)(Sc, Func, Args, Expr)) + +static void fx_annotate_arg(s7_scheme *sc, s7_pointer arg, s7_pointer let_or_list) +{ +#if S7_DEBUGGING + s7_function fx; + if (has_fx(arg)) return; + fx = fx_choose(sc, arg, let_or_list, (is_list(let_or_list)) ? pair_symbol_is_safe : let_symbol_is_safe); + if (fx) set_fx_direct(arg, fx); + /* else fprintf(stderr, "%s[%d]: no fx for %s in %s\n", __func__, __LINE__, display(arg), display(let_or_list)); */ +#else + if (has_fx(arg)) return; + set_fx(arg, fx_choose(sc, arg, let_or_list, (is_list(let_or_list)) ? pair_symbol_is_safe : let_symbol_is_safe)); +#endif +} + +static void fx_annotate_args(s7_scheme *sc, s7_pointer args, s7_pointer let_or_list) +{ + for (s7_pointer p = args; is_pair(p); p = cdr(p)) +#if S7_DEBUGGING + fx_annotate_arg(sc, p, let_or_list); /* checks has_fx */ +#else + if (!has_fx(p)) + set_fx(p, fx_choose(sc, p, let_or_list, (is_list(let_or_list)) ? 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 let_or_list) +{ + if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: expr: %s, func: %s, hop: %d, let_or_list: %s\n", + __func__, __LINE__, display_truncated(expr), display(func), hop, display_truncated(let_or_list)); + if ((hop != 1) && (is_constant_symbol(sc, car(expr)))) hop = 1; + if ((is_closure(func)) || (is_closure_star(func))) + { + const bool safe_case = is_safe_closure(func); + const s7_pointer body = closure_body(func); + const bool one_form = is_null(cdr(body)); + + if (is_immutable(func)) hop = 1; + if (is_null(closure_pars(func))) /* no rest arg funny business */ + { + set_optimized(expr); + if ((one_form) && (safe_case) && (is_fxable(sc, car(body)))) /* fx stuff is not set yet */ + { + fx_annotate_arg(sc, body, let_or_list); + set_optimize_op(expr, hop + OP_SAFE_THUNK_A); + set_closure_one_form_fx_arg(func); + set_opt1_lambda_add(expr, func); + return(opt_ok); + } + /* 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 : ((one_form) ? OP_THUNK_O : OP_THUNK))); + set_opt1_lambda_add(expr, func); + return((safe_case) ? opt_ok : opt_bad); + } + if (is_symbol(closure_pars(func))) /* (define* (f1 . a) ...) called (f1) -- called a closure (not closure*) in define_unchecked */ + { + set_opt1_lambda_add(expr, func); + if (safe_case) + { + if (!has_fx(body)) + { + fx_annotate_args(sc, body, let_or_list); + fx_tree(sc, body, closure_pars(func), NULL, NULL, false); + } + set_safe_optimize_op(expr, hop + OP_SAFE_THUNK_ANY); + return(opt_ok); + } + set_unsafe_optimize_op(expr, hop + OP_THUNK_ANY); /* "thunk" because here it is called with no args, I guess */ + return(opt_bad); + } + 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_bad); + } + if (is_c_function(func)) + { + if (c_function_min_args(func) != 0) + return(opt_bad); + if ((hop == 0) && (is_global(car(expr)))) hop = 1; /* not good: (define + *) clears hop earlier */ + if ((is_safe_procedure(func)) || (c_function_call(func) == g_values)) + { + set_safe_optimize_op(expr, hop + OP_SAFE_C_NC); + choose_c_function(sc, expr, func, 0); + return(opt_ok); + } + set_unsafe_optimize_op(expr, hop + OP_C); + choose_c_function(sc, expr, func, 0); + return(opt_bad); + } + if (is_c_function_star(func)) + { + set_safe_optimize_op(expr, hop + OP_SAFE_C_STAR); + set_class_and_fn_proc(expr, func); + return(opt_ok); + } + return(opt_bad); +} + +static int32_t combine_ops(s7_scheme *sc, s7_pointer expr, combine_op_t cop, s7_pointer arg1, s7_pointer arg2) /* sc needed for debugger stuff */ +{ /* sc arg is used if debugging (hidden in set_op2_con for example) */ + switch (cop) + { + case combine_p: + switch (op_no_hop(arg1)) + { + 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(arg1)); + set_opt1_sym(cdr(expr), caddr(arg1)); + return(OP_SAFE_C_opSSq); + case OP_SAFE_C_opSq: + set_opt3_pair(expr, cadr(arg1)); + set_opt3_sym(cdr(expr), cadadr(arg1)); + return(OP_SAFE_C_op_opSqq); + case OP_SAFE_C_S_opSq: + set_opt3_pair(expr, caddr(arg1)); + return(OP_SAFE_C_op_S_opSqq); + case OP_SAFE_C_opSq_S: + set_opt3_pair(expr, cadr(arg1)); + return(OP_SAFE_C_op_opSq_Sq); + } + return(OP_SAFE_C_P); /* this splits out to A in optimize_func one_arg */ + + case combine_sp: + switch (op_no_hop(arg2)) + { + 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_SC: + set_opt2_con(cdr(expr), caddr(arg2)); + 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(arg2)); + return(OP_SAFE_C_S_opCSq); + case OP_SAFE_C_SS: /* (* a (- b c)) */ + set_opt2_sym(cdr(expr), caddr(arg2)); + 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 combine_ps: + switch (op_no_hop(arg1)) + { + case OP_SAFE_C_S: + set_opt1_sym(cdr(expr), cadr(arg1)); + set_opt3_sym(expr, arg2); + 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(arg1)); + return(OP_SAFE_C_op_opSSqq_S); + } + return(OP_SAFE_C_PS); + + case combine_pc: + switch (op_no_hop(arg1)) + { + case OP_SAFE_C_S: + set_opt1_sym(cdr(expr), cadr(arg1)); + set_opt2_con(cdr(expr), arg2); + 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 combine_cp: + switch (op_no_hop(arg2)) + { + case OP_SAFE_C_S: + set_opt3_pair(expr, arg2); + return(OP_SAFE_C_C_opSq); + case OP_SAFE_C_SC: + set_opt1_sym(cdr(expr), cadr(arg2)); + set_opt2_con(cdr(expr), caddr(arg2)); + return(OP_SAFE_C_C_opSCq); + case OP_SAFE_C_SS: + set_opt1_sym(cdr(expr), cadr(arg2)); + return(OP_SAFE_C_C_opSSq); + } + return(OP_SAFE_C_CP); + + case combine_pp: + switch (op_no_hop(arg2)) + { + case OP_SAFE_C_S: + if (is_safe_c_s(arg1)) return(OP_SAFE_C_opSq_opSq); + if (optimize_op_match(arg1, OP_SAFE_C_SS)) return(OP_SAFE_C_opSSq_opSq); + break; + case OP_SAFE_C_SS: + if (optimize_op_match(arg1, OP_SAFE_C_SS)) return(OP_SAFE_C_opSSq_opSSq); + if (is_safe_c_s(arg1)) 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 let_or_list) +{ + if (pair_symbol_is_safe(sc, arg1, let_or_list)) return(true); /* includes global_slot check */ + return((!sc->in_with_let) && + (is_bound_symbol(sc, arg1))); +} + +static bool symbol_is_safe(s7_scheme *sc, s7_pointer arg, s7_pointer let_or_list) +{ + if (is_symbol(arg)) /* maybe normal here but check clo* key (see below) */ + { + if (is_keyword(arg)) return(true); + if (sc->in_with_let) return(pair_symbol_is_safe(sc, arg, let_or_list)); + if (is_slot(global_slot(arg))) return(true); + if ((!symbol_is_in_big_symbol_set(sc, arg)) && + (!arg_findable(sc, arg, let_or_list))) + return(false); + } + return(true); +} + + +static bool safe_c_aa_to_ag_ga(s7_scheme *sc, s7_pointer arg, int32_t hop) +{ + const s7_pointer arg1p = cdr(arg), arg2p = cddr(arg); + if (fx_proc(arg2p) == fx_s) {set_opt3_sym(arg, car(arg2p)); set_safe_optimize_op(arg, hop + OP_SAFE_C_AS); return(true);} + if (fx_proc(arg1p) == fx_s) {set_opt3_sym(arg, car(arg1p)); set_safe_optimize_op(arg, hop + OP_SAFE_C_SA); return(true);} + if (fx_proc(arg2p) == fx_c) {set_opt3_con(arg, car(arg2p)); set_safe_optimize_op(arg, hop + OP_SAFE_C_AC); return(true);} + if (fx_proc(arg1p) == fx_c) {set_opt3_con(arg, car(arg1p)); set_safe_optimize_op(arg, hop + OP_SAFE_C_CA); return(true);} + if (fx_proc(arg2p) == fx_q) {set_opt3_con(arg, cadar(arg2p)); set_safe_optimize_op(arg, hop + OP_SAFE_C_AC); return(true);} + if (fx_proc(arg1p) == fx_q) {set_opt3_con(arg, cadar(arg1p)); 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 let_or_list) +{ + fx_annotate_args(sc, cdr(expr), let_or_list); + 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_ok); +} + +static opt_t wrap_bad_args(s7_scheme *sc, s7_pointer func, s7_pointer expr, int32_t n_args, int32_t hop, s7_pointer let_or_list) +{ + set_opt3_arglen(cdr(expr), 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, let_or_list)); + } + set_class_and_fn_proc(expr, func); + return(opt_ok); + } + if ((is_closure(func)) && + (!arglist_has_rest(sc, closure_pars(func)))) + { + const s7_pointer body = closure_body(func); + const 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_bad); + } + if ((is_closure_star(func)) && + (lambda_has_simple_defaults(func)) && + (closure_star_arity_to_int(sc, func) >= n_args) && + (!arglist_has_rest(sc, closure_pars(func)))) + { + const bool safe_case = is_safe_closure(func); + set_unsafely_optimized(expr); + if (n_args == 1) + set_optimize_op(expr, ((safe_case) ? OP_SAFE_CLOSURE_STAR_A : OP_CLOSURE_STAR_A)); + else + if (closure_star_arity_to_int(sc, func) == 2) + set_optimize_op(expr, ((safe_case) ? ((is_null(cdr(closure_body(func)))) ? OP_SAFE_CLOSURE_STAR_AA_O : /* aa_a was not faster */ + OP_SAFE_CLOSURE_STAR_AA) : OP_CLOSURE_STAR_NA)); + else set_optimize_op(expr, (safe_case) ? OP_SAFE_CLOSURE_STAR_NA : OP_CLOSURE_STAR_NA); + set_opt1_lambda_add(expr, func); + } + return(opt_bad); +} + +static inline s7_pointer find_uncomplicated_symbol(s7_scheme *sc, s7_pointer symbol, s7_pointer symbols) +{ + if ((symbol_is_in_big_symbol_set(sc, symbol)) && + (direct_memq(symbol, symbols))) /* it's probably a local variable reference */ + return(sc->nil); + /* ((!symbol_is_in_big_symbol_set(sc, symbol)) && (direct_memq(symbol, symbols))) 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 big_symbol_set when recursive call is encountered) -- tricky to fix + */ + if (is_defined_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_big_symbol_set(sc, symbol_to_keyword(sc, symbol)))) + return(sc->nil); + { + s7_pointer let = sc->curlet; + s7_int id = symbol_id(symbol); + for (; let_id(let) > id; let = let_outlet(let)); + for (; let; let = let_outlet(let)) + { + if (let_id(let) == id) return(local_slot(symbol)); + for (s7_pointer slot = let_slots(let); is_not_slot_end(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == symbol) + return(slot); + }} + return(global_slot(symbol)); /* it's no longer global perhaps (local definition now inaccessible) */ +} + +static bool tree_has_escaper(s7_scheme *sc, s7_pointer tree, s7_pointer cc) +{ + if (is_pair(tree)) + { + if (is_escaper(car(tree))) return(true); + if ((is_pair(car(tree))) && (tree_has_escaper(sc, car(tree), cc))) return(true); + for (s7_pointer p = cdr(tree); is_pair(p); p = cdr(p)) + { + if (car(p) == cc) return(true); + if ((is_pair(car(p))) && (tree_has_escaper(sc, car(p), cc))) return(true); + }} + else + if (tree == cc) return(true); + return(false); +} + +static bool is_ok_lambda(s7_scheme *sc, s7_pointer arg2) +{ + return((is_pair(arg2)) && + (is_lambda(sc, car(arg2))) && /* must start (lambda ...) */ + (is_pair(cdr(arg2))) && /* must have arg(s) */ + (is_pair(cddr(arg2))) && /* must have body */ + (s7_is_proper_list(sc, cdddr(arg2)))); +} + +static bool hop_if_constant(s7_scheme *sc, s7_pointer sym) +{ + /* "sym" is a symbol here. c_functions set hop=1 in optimize_expression */ + return(((!sc->in_with_let) && + (!is_maybe_shadowed(sym)) && + (is_global(sym))) ? 1 : 0); /* for with-let, see s7test atanh (77261) */ +} + +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 let_or_list) +{ + const s7_pointer arg1 = cadr(expr); + const bool func_is_safe = is_safe_procedure(func); + if (hop == 0) hop = hop_if_constant(sc, car(expr)); + if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s, func_is_safe: %d, pairs: %d, hop: %d\n", __func__, __LINE__, display_truncated(expr), func_is_safe, pairs, hop); + if (pairs == 0) + { + if ((func_is_safe) || (c_function_call(func) == g_values)) /* 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_ok); + } + /* 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), let_or_list); + set_opt3_arglen(cdr(expr), 1); + } + 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_bad); + } + /* pairs == 1 */ + if (bad_pairs == 0) + { + if (func_is_safe) + { + const int32_t op = combine_ops(sc, expr, combine_p, arg1, NULL); + if ((hop == 1) && (!op_has_hop(arg1)) && (is_symbol(car(arg1))) && (is_maybe_shadowed(car(arg1)))) /* else maybe c_function with even_args bit! */ + { + hop = 0; + if (!is_symbol(car(expr))) /* calling op was optimized to #_ previously, but now we notice its argument is problematic?! */ + set_car(expr, c_function_symbol(car(expr))); + /* maybe symbol_initial_value(...) -- but both can differ from global_value, (set! abs 32) (#_abs -1) */ + /* maybe return(opt_bad); or dependent on is_maybe_shadowed? */ + /* probably not the right way to fix this (s7test tc_or_a_and_a_a_la), but (define + *) needs this */ + } + 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), let_or_list); + } + choose_c_function(sc, expr, func, 1); +#if 0 + /* works, not much impact? see check_c_aa, optimize_func_one|two|three_args for safe_c_functions */ + /* also, need wrapped field c_proc_t so this doesn't need to check each case by hand */ + if (has_fn(arg1)) + { + if (fn_proc(arg1) == g_multiply_2) set_fn_direct(arg1, g_multiply_2_wrapped); + if (fn_proc(arg1) == g_subtract_2) set_fn_direct(arg1, g_subtract_2_wrapped); if (fn_proc(arg1) == g_add_2) set_fn_direct(arg1, g_add_2_wrapped); } #endif - return (opt_ok); + return(opt_ok); + } + 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), let_or_list); + set_opt3_arglen(cdr(expr), 1); + choose_c_function(sc, expr, func, 1); + return(opt_bad); + }} + else /* bad_pairs == 1 */ + { + if (quotes == 1) + { + fx_annotate_arg(sc, cdr(expr), let_or_list); + set_opt3_arglen(cdr(expr), 1); + if (func_is_safe) + { + set_safe_optimize_op(expr, hop + OP_SAFE_C_A); + choose_c_function(sc, expr, func, 1); + return(opt_ok); + } + set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_A : OP_C_A)); + choose_c_function(sc, expr, func, 1); + return(opt_bad); + } + /* quotes == 0 */ + if (!func_is_safe) + { + const s7_pointer lambda_expr = arg1; + if ((is_ok_lambda(sc, lambda_expr)) && + (!direct_memq(car(lambda_expr), let_or_list))) /* (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) + { + const s7_pointer arg_func = cadr(expr); + set_unsafe_optimize_op(expr, OP_CALL_CC); + /* (call/cc (lambda (return) (do ((i 0 (+ i 1))) ((= i 10)) (if (= i 3) (return 32))))) */ + + /* 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. + * But we can notice that embedded use? lambda(*)/m|bacro(*), curlet + * But just quitting on lambda seems over enthusiastic -- lambda is used for with-output-*, call/exit, dynwind etc + * see t861 for examples. + */ + if ((car(arg_func) == sc->lambda_symbol) && + (is_pair(cdr(arg_func))) && (is_pair(cadr(arg_func))) && (is_normal_symbol(caadr(arg_func)))) + { + const s7_pointer cc = caadr(arg_func); + if ((!tree_has_escaper(sc, cddr(arg_func), cc)) && + ((caddr(arg_func) != cc) || (is_pair(cdddr(arg_func))))) /* (call/cc (lambda (return) return)) */ + { + set_unsafe_optimize_op(expr, (is_null(cdddr(lambda_expr))) ? OP_CALL_WITH_EXIT_O : OP_CALL_WITH_EXIT); + /* fprintf(stderr, "call/exit: %s\n", display(expr)); */ + } + /* else fprintf(stderr, "has cc: %s\n", display(cddr(arg_func))); */ + }} + else + if (c_function_call(func) == g_call_with_exit) + set_unsafe_optimize_op(expr, (is_null(cdddr(lambda_expr))) ? OP_CALL_WITH_EXIT_O : 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_bad); + } + /* choose_c_function(sc, expr, func, 1); */ + /* clear_has_fn(expr); */ /* ??? this wipes out the choose_c_function=set_c_function call?? */ + 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_bad); + } + 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_bad); + }}}} + 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_bad); +} + +static bool walk_fxable(s7_scheme *sc, s7_pointer tree) +{ + for (s7_pointer 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, "%s[%d]: omit %s: %s\n", __func__, __LINE__, op_names[optimize_op(p)], display(p)); + return(false); +} + +static opt_t fxify_closure_s(s7_scheme *sc, s7_pointer func, s7_pointer expr, s7_pointer let_or_list, int32_t hop) +{ + const s7_pointer body = closure_body(func); + fx_annotate_arg(sc, body, let_or_list); + /* we can't currently fx_annotate_arg(sc, cdr(expr), let_or_list) here because that opt2 field is in use elsewhere (opt2_sym, not sure where it's set) */ + set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_A); + if ((is_pair(car(body))) && (is_pair(cdar(body))) && (car(closure_pars(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) + { + const 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_pars(func)), NULL, NULL, false); + return(opt_ok); +} + +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 let_or_list) +{ + if (!one_form) + set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_A : OP_CLOSURE_A)); /* fx(body) cases here are rare (make-index) */ + else + if (!safe_case) + set_optimize_op(expr, hop + OP_CLOSURE_A_O); + else + { + const s7_pointer body = closure_body(func); + if (!is_fxable(sc, car(body))) + set_optimize_op(expr, hop + OP_SAFE_CLOSURE_A_O); + else + { + fx_annotate_arg(sc, body, let_or_list); + 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_pars(func)) == cadar(body))) + { + const 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); + /* why is this setting expr whereas _s case above sets cdr(expr)? */ + 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_pars(func)), NULL, NULL, false); + return(true); + }} + return(false); +} + +static opt_t optimize_closure_sym(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, int32_t args, s7_pointer let_or_list) +{ + 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_bad); + set_opt3_arglen(cdr(expr), args); + set_opt1_lambda_add(expr, func); + fx_annotate_args(sc, cdr(expr), let_or_list); + if (is_safe_closure(func)) + { + const s7_pointer body = closure_body(func); + if (!has_fx(body)) /* does this have any effect? */ + { + fx_annotate_args(sc, body, let_or_list); + fx_tree(sc, body, closure_pars(func), NULL, NULL, false); + } + set_safe_optimize_op(expr, hop + OP_ANY_CLOSURE_SYM); + return(opt_ok); + } + set_unsafe_optimize_op(expr, hop + OP_ANY_CLOSURE_SYM); + return(opt_bad); +} + +static opt_t optimize_closure_a_sym(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, int32_t args, s7_pointer let_or_list) +{ + if (fx_count(sc, expr) != args) return(opt_bad); + set_opt3_arglen(cdr(expr), args); + set_opt1_lambda_add(expr, func); + fx_annotate_args(sc, cdr(expr), let_or_list); + if (is_safe_closure(func)) + { + const s7_pointer body = closure_body(func); + if (!has_fx(body)) /* does this have any effect? */ + { + fx_annotate_args(sc, body, let_or_list); + fx_tree(sc, body, car(closure_pars(func)), cdr(closure_pars(func)), NULL, false); + } + set_safe_optimize_op(expr, hop + OP_ANY_CLOSURE_A_SYM); + return(opt_ok); + } + set_unsafe_optimize_op(expr, hop + OP_ANY_CLOSURE_A_SYM); + return(opt_bad); +} + +static opt_t optimize_closure_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, int32_t symbols, s7_pointer let_or_list) +{ + const int32_t arit = closure_arity_to_int(sc, func); + if (arit != 1) + { + if (is_symbol(closure_pars(func))) /* (arit == -1) is ambiguous: (define (f . a)...) and (define (f a . b)...) both are -1 here */ + return(optimize_closure_sym(sc, expr, func, hop, 1, let_or_list)); + if ((arit == -1) && (is_symbol(cdr(closure_pars(func))))) + return(optimize_closure_a_sym(sc, expr, func, hop, 1, let_or_list)); + return(opt_bad); + } + { + const s7_pointer arg1 = cadr(expr); + const bool safe_case = is_safe_closure(func); + const s7_pointer body = closure_body(func); + const bool 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, let_or_list, hop)); + set_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_O); /* tleft 7638 if _O here, 7692 if not (and claims 80 in the begin setup) */ + } + 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_bad); + } + if (fx_count(sc, expr) == 1) + { + set_unsafely_optimized(expr); + set_opt1_lambda_add(expr, func); + fx_annotate_arg(sc, cdr(expr), let_or_list); + set_opt3_arglen(cdr(expr), 1); + if (fxify_closure_a(sc, func, one_form, safe_case, hop, expr, let_or_list)) return(opt_ok); + set_unsafely_optimized(expr); + return(opt_bad); + } + 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), 1); + 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), let_or_list); + }} + return(opt_bad); /* don't check is_optimized here for opt_ok */ +} + +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 let_or_list) +{ + s7_pointer arg1 = cadr(expr); + if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: expr: %s, func: %s, hop: %d, pairs: %d, symbols: %d, quotes: %d, bad_pairs: %d, let_or_list: %s\n", + __func__, __LINE__, display_truncated(expr), display(func), hop, pairs, symbols, quotes, bad_pairs, display_truncated(let_or_list)); + /* 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, let_or_list)) + return(opt_oops); + if ((bad_pairs == quotes) && + (is_symbol(car(expr))) && + (is_constant_symbol(sc, car(expr)))) + hop = 1; + } + /* need in_with_let -> search only rootlet not lookup */ + if ((symbols == 1) && + ((!symbol_is_safe(sc, arg1, let_or_list)) || (sc->in_with_let))) /* (set! (with-let ...) ...) can involve an unbound variable otherwise bound */ + { + /* 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, let_or_list)); + } + return(opt_bad); + } + + switch (type(func)) + { + case T_C_FUNCTION: /* these two happen much more than everything else put together, but splitting them out to avoid the switch doesn't gain much */ + if (!c_function_is_aritable(func, 1)) return(opt_bad); + case T_C_RST_NO_REQ_FUNCTION: + return(optimize_c_function_one_arg(sc, expr, func, hop, pairs, symbols, quotes, bad_pairs, let_or_list)); + + case T_CLOSURE: + return(optimize_closure_one_arg(sc, expr, func, hop, symbols, let_or_list)); + + case T_CLOSURE_STAR: + if (is_null(closure_pars(func))) + return(opt_bad); + if (fx_count(sc, expr) == 1) + { + const bool safe_case = is_safe_closure(func); + if (is_immutable(func)) hop = 1; + fx_annotate_arg(sc, cdr(expr), let_or_list); + set_opt1_lambda_add(expr, func); + set_opt3_arglen(cdr(expr), 1); + set_unsafely_optimized(expr); + + if ((safe_case) && (is_null(cdr(closure_pars(func))))) + set_optimize_op(expr, hop + OP_SAFE_CLOSURE_STAR_A1); + else + if (lambda_has_simple_defaults(func)) + { + if (arglist_has_rest(sc, closure_pars(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_bad); + + case T_C_FUNCTION_STAR: + if ((fx_count(sc, expr) == 1) && + (c_function_max_args(func) >= 1) && + (!is_symbol_and_keyword(arg1))) /* the only arg should not be a keyword (needs error checks later) */ + { + if ((hop == 0) && ((is_immutable(func)) || ((!sc->in_with_let) && (is_global(car(expr)))))) hop = 1; + set_safe_optimize_op(expr, hop + OP_SAFE_C_STAR_A); + fx_annotate_arg(sc, cdr(expr), let_or_list); + set_opt3_arglen(cdr(expr), 1); + set_class_and_fn_proc(expr, func); + return(opt_ok); + } + break; + + case T_PAIR: case T_VECTOR: case T_INT_VECTOR: case T_BYTE_VECTOR: case T_FLOAT_VECTOR: case T_COMPLEX_VECTOR: + if (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), let_or_list); + set_opt3_arglen(cdr(expr), 1); + return(opt_ok); + } + break; + + case T_LET: + /* implicit function/c-object -> (f 'a) if f is a function is a function call, not a funclet or c-object-let reference, ((funclet f) 'a). + * c-pointer might work, but it's too similar to c-object, and you can always use ((c-pointer-info p) 'a). + */ + if (((quotes == 1) && (is_symbol(cadr(arg1)))) || /* (e 'a) or (e ':a) */ + (is_symbol_and_keyword(arg1))) /* (e :a) */ + { + s7_pointer sym = (quotes == 1) ? cadr(arg1) : arg1; + if (is_keyword(sym)) sym = keyword_symbol(sym); + if (func == sc->starlet) /* (*s7* ...), sc->starlet is a let */ + { + set_safe_optimize_op(expr, OP_IMPLICIT_STARLET_REF_S); + set_opt3_int(expr, starlet_symbol_id(sym)); + return(opt_ok); + } + set_opt3_con(expr, sym); + set_unsafe_optimize_op(expr, OP_IMPLICIT_LET_REF_C); + return(opt_ok); + } + /* fall through */ + + case T_HASH_TABLE: case T_C_OBJECT: + if (is_fxable(sc, arg1)) + { + set_unsafe_optimize_op(expr, (type(func) == T_LET) ? OP_IMPLICIT_LET_REF_A : + ((type(func) == T_HASH_TABLE) ? OP_IMPLICIT_HASH_TABLE_REF_A : OP_IMPLICIT_C_OBJECT_REF_A)); + fx_annotate_arg(sc, cdr(expr), let_or_list); + set_opt3_arglen(cdr(expr), 1); + return(opt_ok); + } + break; + + default: + break; + } + return((is_optimized(expr)) ? opt_ok : opt_bad); +} + +static bool unsafe_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer symbols) +{ + s7_pointer slot; + if (!is_symbol(sym)) return(false); + slot = find_uncomplicated_symbol(sc, sym, symbols); /* how to catch local c-funcs here? */ + if (!is_slot(slot)) return(false); + return(is_safe_c_function(slot_value(slot))); +} + +static opt_t set_any_closure_np(s7_scheme *sc, s7_pointer func, s7_pointer expr, s7_pointer let_or_list, int32_t num_args, opcode_t op) +{ + for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p)) + set_fx(p, fx_choose(sc, p, let_or_list, (is_list(let_or_list)) ? pair_symbol_is_safe : let_symbol_is_safe)); + set_opt3_arglen(cdr(expr), num_args); + set_unsafe_optimize_op(expr, op); + set_opt1_lambda_add(expr, func); + return(opt_bad); +} + +static bool two_args_ok(s7_scheme *sc, s7_pointer expr, s7_pointer let_or_list) +{ + if ((is_symbol(car(expr))) && ((car(expr) == sc->member_symbol) || (car(expr) == sc->assoc_symbol))) return(true); + return(unsafe_is_safe(sc, cadr(expr), let_or_list)); +} + +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_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 let_or_list, int32_t num_args, opcode_t op) +{ + /* we get 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? + * or use op_stack? error clears this? op-any-c-fp: op_any_c_2p|3p|fp? -- mimic clo_3p|4p? + */ + for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p)) + set_fx(p, fx_choose(sc, p, let_or_list, (is_list(let_or_list)) ? pair_symbol_is_safe : let_symbol_is_safe)); + set_opt3_arglen(cdr(expr), 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_bad); +} + +static s7_function io_function(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 clo, s7_pointer code, int32_t hop) +{ + const int32_t arity = closure_star_arity_to_int(sc, clo); + const bool safe_case = is_safe_closure(clo); + const s7_pointer arg1 = cadr(code); + s7_pointer par1 = car(closure_pars(clo)); + if (is_pair(par1)) par1 = car(par1); + + set_opt3_arglen(cdr(code), 2); + set_unsafely_optimized(code); + + if ((arity == 1) && (is_symbol_and_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(clo)) && (arity == 2)) + set_optimize_op(code, hop + ((safe_case) ? ((is_null(cdr(closure_body(clo)))) ? OP_SAFE_CLOSURE_STAR_AA_O : OP_SAFE_CLOSURE_STAR_AA) : OP_CLOSURE_STAR_NA)); + else set_optimize_op(code, hop + ((safe_case) ? 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 let_or_list) +{ + const s7_pointer arg1p = cdr(expr), arg1 = cadr(expr), arg2 = caddr(expr); + if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: expr: %s, func: %s, hop: %d, pairs: %d, symbols: %d, quotes: %d, bad_pairs: %d, let_or_list: %s\n", + __func__, __LINE__, display_truncated(expr), display(func), hop, pairs, symbols, quotes, bad_pairs, display_truncated(let_or_list)); + if (quotes > 0) + { + if (direct_memq(sc->quote_symbol, let_or_list)) + return(opt_oops); + if ((bad_pairs == quotes) && + (is_symbol(car(expr))) && + (is_constant_symbol(sc, car(expr)))) + hop = 1; + } + if ((!symbol_is_safe(sc, arg1, let_or_list)) || + (!symbol_is_safe(sc, arg2, let_or_list))) + { + /* wrap bad args */ + if ((is_fxable(sc, arg1)) && + (is_fxable(sc, arg2)) && + (s7_is_aritable(sc, func, 2))) /* arg_findable key -> #t(?) so clo* ok */ + { + fx_annotate_args(sc, arg1p, let_or_list); + return(wrap_bad_args(sc, func, expr, 2, hop, let_or_list)); + } + return(opt_bad); + } + /* end of bad symbol wrappers */ + + if (is_c_function(func) && (c_function_is_aritable(func, 2))) + { + /* this is a mess */ + const bool func_is_safe = is_safe_procedure(func); + if (hop == 0) hop = hop_if_constant(sc, car(expr)); + if (pairs == 0) + { + if ((func_is_safe) || + ((is_maybe_safe(func)) && (two_args_ok(sc, expr, let_or_list)))) + { + /* 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_opt1_sym(arg1p, arg2); + } + else + if (is_normal_symbol(arg1)) + { + set_opt1_con(arg1p, arg2); + set_optimize_op(expr, hop + OP_SAFE_C_SC); + } + else + { + set_opt1_con(arg1p, arg1); /* set_opt2_sym(arg1p, arg2); */ + set_optimize_op(expr, hop + OP_SAFE_C_CS); + } + set_optimized(expr); + choose_c_function(sc, expr, func, 2); + return(opt_ok); + } + 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_opt1_sym(arg1p, 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 : + (((symbols == 0) && (pairs == 0) && (car(expr) == sc->values_symbol)) ? OP_C_NC : OP_C_AA))); + fx_annotate_args(sc, arg1p, let_or_list); + set_opt3_arglen(arg1p, 2); + 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_opt1_con(arg1p, arg2); + } + else + { + set_opt1_con(arg1p, arg1); /* set_opt2_sym(arg1p, arg2); */ + set_optimize_op(expr, hop + OP_SAFE_C_CS); + }} + return(opt_ok); + } + else + if ((symbols == 1) && (is_normal_symbol(arg1))) /* arg2 must be constant since pairs==0 */ + { + set_optimize_op(expr, hop + OP_C_SC); + set_opt3_con(arg1p, arg2); /* a very small optimization! */ + }} + return(opt_bad); + } + + /* pairs != 0 */ + if ((bad_pairs == 0) && + (pairs == 2)) + { + if ((func_is_safe) || + ((is_maybe_safe(func)) && (two_args_ok(sc, expr, let_or_list)))) + { + const int32_t op = combine_ops(sc, expr, combine_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_defined_global(caadr(expr))) && (is_defined_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(arg1p, 2); */ + set_safe_optimize_op(expr, HOP_SAFE_C_FF); + } + opt_sp_1(sc, c_function_call(func), expr); /* calls set_opt1_any, sets opt1(arg1p) 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, let_or_list)); /* AA case */ + set_optimize_op(expr, hop + OP_SAFE_C_AP); + fx_annotate_arg(sc, arg1p, let_or_list); + set_opt3_arglen(arg1p, 2); + } + else + if (is_fxable(sc, arg2)) + { + set_optimize_op(expr, hop + OP_SAFE_C_PA); + fx_annotate_arg(sc, cddr(expr), let_or_list); + set_opt3_arglen(arg1p, 2); + }} + choose_c_function(sc, expr, func, 2); /* this might change the op to safe_c_c, so it has to be last */ + return(opt_ok); + }} + + if ((bad_pairs == 0) && + (pairs == 1)) + { + if ((func_is_safe) || + ((is_maybe_safe(func)) && (two_args_ok(sc, expr, let_or_list)))) + { + combine_op_t orig_op; + int32_t op; + + if (is_pair(arg1)) + { + orig_op = (is_normal_symbol(arg2)) ? combine_ps : combine_pc; + op = combine_ops(sc, expr, orig_op, arg1, arg2); + } + else + { + orig_op = (is_normal_symbol(arg1)) ? combine_sp : combine_cp; + op = combine_ops(sc, expr, orig_op, arg1, arg2); + } + if ((hop == 1) && + (((is_pair(arg2)) && (!op_has_hop(arg2)) && (is_symbol(car(arg2))) && (is_maybe_shadowed(car(arg2)))) || + ((is_pair(arg1)) && (!op_has_hop(arg1)) && (is_symbol(car(arg1))) && (is_maybe_shadowed(car(arg1)))))) + { + hop = 0; + if (!is_symbol(car(expr))) + set_car(expr, c_function_symbol(car(expr))); /* maybe symbol_initial_value(...) */ + } + /* arg2 case: (let () (define (func) (let ((i 0)) (define + *) (quotient 10001 (+ i 1)))) (func)) -> division by zero error */ + /* arg1 case: (let () (define (func) (let ((i 0)) (define + *) (remainder (+ i 1) 101))) (func)) ; 0 */ + + 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, arg1p, let_or_list); + 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(arg1p, arg1); + } + else + if (op == OP_SAFE_C_PC) + set_opt3_con(arg1p, arg2); + } + choose_c_function(sc, expr, func, 2); + return(opt_ok); + }} + + if ((bad_pairs == 1) && (quotes == 1)) + { + if ((func_is_safe) || + ((is_maybe_safe(func)) && (two_args_ok(sc, expr, let_or_list)))) + { + if (symbols == 1) + { + set_optimized(expr); + if (is_normal_symbol(arg1)) + { + set_opt1_con(arg1p, cadr(arg2)); + set_optimize_op(expr, hop + OP_SAFE_C_SC); + } + else + { + set_opt1_con(arg1p, cadr(arg1)); /* set_opt2_sym(arg1p, arg2); */ + set_optimize_op(expr, hop + OP_SAFE_C_CS); + } + choose_c_function(sc, expr, func, 2); + return(opt_ok); + } + if ((pairs == 1) && (is_pair(arg2))) /* QC never happens */ + { + set_safe_optimize_op(expr, hop + OP_SAFE_C_CQ); + set_opt2_con(arg1p, cadr(arg2)); + choose_c_function(sc, expr, func, 2); + return(opt_ok); + } + if (!is_safe_c_s(arg1)) + { + if ((is_fxable(sc, arg1)) && (is_fxable(sc, arg2))) + return(check_c_aa(sc, expr, func, hop, let_or_list)); + }} + else + if (pairs == 1) + { + set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_AA : OP_C_AA)); + fx_annotate_args(sc, arg1p, let_or_list); + set_opt3_arglen(arg1p, 2); + choose_c_function(sc, expr, func, 2); + return(opt_bad); + }} + + 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(arg1p, 2); + } + fx_annotate_args(sc, arg1p, let_or_list); + choose_c_function(sc, expr, func, 2); + return((func_is_safe) ? opt_ok : opt_bad); + } + + if ((pairs == 1) && + (quotes == 0) && + ((func_is_safe) || + ((is_maybe_safe(func)) && (two_args_ok(sc, expr, let_or_list))))) + { + 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_ok); + set_unsafe(expr); + return(opt_bad); + } + if (symbols == 0) + { + set_optimized(expr); + if ((is_fxable(sc, arg1)) && (is_fxable(sc, arg2))) + return(check_c_aa(sc, expr, func, hop, let_or_list)); + if (is_pair(arg1)) + { + set_optimize_op(expr, hop + OP_SAFE_C_PC); + set_opt3_con(arg1p, arg2); + } + else + { + set_optimize_op(expr, hop + OP_SAFE_C_CP); + opt_sp_1(sc, c_function_call(func), expr); + set_opt3_any(arg1p, arg1); + } + choose_c_function(sc, expr, func, 2); + if (bad_pairs == 0) + return(opt_ok); + set_unsafe(expr); + return(opt_bad); + }} + + if ((pairs == 2) && + ((func_is_safe) || + ((is_maybe_safe(func)) && (two_args_ok(sc, expr, let_or_list))))) + { + 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 (is_safe_quote(sc, car(arg2))) + { + 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(arg1p, cadr(arg1)); + set_opt2_con(arg1p, cadr(arg2)); + choose_c_function(sc, expr, func, 2); + return(opt_ok); + }} + 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, let_or_list)); + set_optimize_op(expr, hop + OP_SAFE_C_AP); + opt_sp_1(sc, c_function_call(func), expr); + fx_annotate_arg(sc, arg1p, let_or_list); + } + else + if (is_fxable(sc, arg2)) + { + set_optimize_op(expr, hop + OP_SAFE_C_PA); + fx_annotate_arg(sc, cddr(expr), let_or_list); + } + else + { + set_optimize_op(expr, hop + OP_SAFE_C_PP); + opt_sp_1(sc, c_function_call(func), expr); + } + choose_c_function(sc, expr, func, 2); + return(opt_bad); + } + if (quotes == 1) + { + if (is_safe_quote(sc, car(arg1))) + { + 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(arg1p, cadr(arg1)); + } + else + { + set_optimize_op(expr, hop + OP_SAFE_C_PC); + set_opt3_con(arg1p, cadr(arg2)); + } + set_unsafely_optimized(expr); + choose_c_function(sc, expr, func, 2); + return(opt_bad); + }} + + if (func_is_safe) + { + if (fx_count(sc, expr) == 2) + return(check_c_aa(sc, expr, func, hop, let_or_list)); + } + 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 = 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, arg1p, let_or_list); + set_opt3_arglen(arg1p, 2); + } + 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), let_or_list))) /* 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(c_function_call(func))); + return(opt_bad); + } + 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, let_or_list))) /* 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(c_function_call(func))); + return(opt_bad); + } + set_unsafe_optimize_op(expr, hop + OP_C_AP); + fx_annotate_arg(sc, arg1p, let_or_list); + } + choose_c_function(sc, expr, func, 2); + return(opt_bad); + } + 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)) + { + fx_annotate_arg(sc, cddr(expr), let_or_list); + set_unsafe_optimize_op(expr, hop + OP_CL_FA); + check_lambda(sc, arg1, true); /* this changes small_symbol_set */ + /* 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_bad); + }} + return(set_any_c_np(sc, func, expr, let_or_list, 2, hop + OP_ANY_C_NP)); /* OP_C_PP doesn't exist, presumably OP_SAFE_C_PP was caught above? */ + } + + if (is_closure(func)) + { + bool one_form, safe_case; + s7_pointer body; + const int32_t arit = closure_arity_to_int(sc, func); + + if (arit != 2) + { + if (is_symbol(closure_pars(func))) + return(optimize_closure_sym(sc, expr, func, hop, 2, let_or_list)); + if ((arit == -1) && (is_symbol(cdr(closure_pars(func))))) /* (define (f a . b) ...) */ + return(optimize_closure_a_sym(sc, expr, func, hop, 2, let_or_list)); + return(opt_bad); + } + 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, let_or_list); + fx_tree(sc, body, car(closure_pars(func)), cadr(closure_pars(func)), NULL, false); + set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_SS_A); + /* fx_annotate_args(sc, arg1p, let_or_list); */ + set_closure_one_form_fx_arg(func); + return(opt_ok); + } + return(opt_bad); + } + 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_bad); + }} + + if ((!arglist_has_rest(sc, closure_pars(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, let_or_list); + 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, arg1p, let_or_list); + set_opt1_lambda_add(expr, func); + set_opt3_arglen(arg1p, 2); + return(opt_ok); + } + fx_annotate_args(sc, arg1p, let_or_list); + set_opt1_lambda_add(expr, func); + set_opt3_arglen(arg1p, 2); + return(opt_bad); + } + + if (is_fxable(sc, arg1)) + { + set_unsafely_optimized(expr); + fx_annotate_arg(sc, arg1p, let_or_list); + set_safe_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_AP : OP_CLOSURE_AP)); + set_opt1_lambda_add(expr, func); + set_opt3_arglen(arg1p, 2); /* for op_unknown_np */ + return(opt_bad); + } + + 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))))) + { + fx_annotate_arg(sc, cddr(expr), let_or_list); + set_opt2_pair(expr, cdr(arg1)); + set_unsafe_optimize_op(expr, hop + OP_CLOSURE_FA); + check_lambda(sc, arg1, false); + /* 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 -- see s7test intersection case 91492 */ + set_opt1_lambda_add(expr, func); + return(opt_bad); + } + + if (is_fxable(sc, arg2)) + { + set_unsafely_optimized(expr); + fx_annotate_arg(sc, cddr(expr), let_or_list); + set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_PA : OP_CLOSURE_PA)); + set_opt1_lambda_add(expr, func); + set_opt3_arglen(arg1p, 2); /* for op_unknown_np */ + return(opt_bad); + } + + if (is_safe_closure(func)) /* clo* too */ + return(set_any_closure_np(sc, func, expr, let_or_list, 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(arg1p, 2); /* for op_unknown_np */ + return(opt_bad); + } + + if (is_closure_star(func)) + { + if (!closure_star_is_aritable(sc, func, closure_pars(func), 1)) /* not 2, cadr(expr) might be keyword or pair->keyword etc */ + return(opt_oops); /* (let* cons () (lambda* (a . b) (cons a b))) so closure_pars=(), arity=0 ?? */ + if (is_immutable(func)) hop = 1; + if (fx_count(sc, expr) == 2) + { + fixup_closure_star_aa(sc, func, expr, hop); + fx_annotate_args(sc, arg1p, let_or_list); + set_opt1_lambda_add(expr, func); + return(opt_bad); + }} + + if ((is_c_function_star(func)) && + (fx_count(sc, expr) == 2) && + (c_function_max_args(func) >= 1) && + (!is_symbol_and_keyword(arg2))) + { + if ((hop == 0) && ((is_immutable(func)) || ((!sc->in_with_let) && (is_global(car(expr)))))) hop = 1; + set_optimized(expr); + set_optimize_op(expr, hop + OP_SAFE_C_STAR_AA); /* k+c? = cc */ + fx_annotate_args(sc, arg1p, let_or_list); + set_opt3_arglen(arg1p, 2); + set_class_and_fn_proc(expr, func); + return(opt_ok); + } + + if ((((is_any_vector(func)) && (vector_rank(func) == 2)) || (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, arg1p, let_or_list); + set_opt3_arglen(arg1p, 2); + return(opt_ok); + } + return((is_optimized(expr)) ? opt_ok : opt_bad); +} + +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 let_or_list) +{ + const s7_pointer arg1p = cdr(expr), 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 + { + clear_has_fx(arg1p); + if (symbols == 3) + { + set_optimize_op(expr, hop + OP_SAFE_C_SSS); + set_opt1_sym(arg1p, arg2); + set_opt2_sym(arg1p, arg3); + } + else + if (symbols == 2) + if (!is_normal_symbol(arg1)) + { + set_optimize_op(expr, hop + OP_SAFE_C_CSS); + set_opt1_sym(arg1p, arg2); + set_opt2_sym(arg1p, arg3); + } + else + if (!is_normal_symbol(arg3)) + { + set_opt2_con(arg1p, arg3); + set_opt1_sym(arg1p, arg2); + set_optimize_op(expr, hop + OP_SAFE_C_SSC); + } + else + { + set_opt1_con(arg1p, arg2); + set_opt2_sym(arg1p, arg3); + set_optimize_op(expr, hop + OP_SAFE_C_SCS); + } + else + if (is_normal_symbol(arg1)) + { + set_opt1_con(arg1p, arg2); + set_opt2_con(arg1p, arg3); + set_optimize_op(expr, hop + OP_SAFE_C_SCC); + } + else + if (is_normal_symbol(arg2)) + { + set_opt1_sym(arg1p, arg2); + set_opt2_con(arg1p, arg3); + set_opt3_con(arg1p, arg1); + set_optimize_op(expr, hop + OP_SAFE_C_CSC); + } + else + { + set_opt1_sym(arg1p, arg3); + set_opt2_con(arg1p, arg2); + set_opt3_con(arg1p, arg1); + set_optimize_op(expr, hop + OP_SAFE_C_CCS); + }} + choose_c_function(sc, expr, func, 3); + return(opt_ok); + } + + /* 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(arg1p, cadr(arg2)); /* fx_c_scs uses opt1_con */ + clear_has_fx(arg1p); /* (s7test safe_c_func_three_args) this is used above -- maybe just clear it at the top? */ + set_opt2_sym(arg1p, arg3); + set_optimize_op(expr, hop + OP_SAFE_C_SCS); /* used to be SQS */ + choose_c_function(sc, expr, func, 3); + return(opt_ok); + } + 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(arg1p, cadr(arg2)); /* opt1_con is T_Exs (unchecked) */ + set_opt2_sym(arg1p, arg3); + set_opt3_sym(arg1p, cadr(arg1)); + choose_c_function(sc, expr, func, 3); + return(opt_ok); + } + 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(arg1p, arg2); + set_opt2_con(arg1p, arg3); + set_opt3_con(arg1p, cadr(arg1)); + choose_c_function(sc, expr, func, 3); + return(opt_ok); + }}} + + fx_annotate_args(sc, arg1p, let_or_list); + set_opt3_arglen(arg1p, 3); + 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)) + { + set_optimize_op(expr, hop + OP_SAFE_C_SSA); + clear_has_fx(arg1p); /* has_fx might have been on (see s7test) */ + } + 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_ok); + } + return(opt_bad); /* 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 let_or_list) +{ + const s7_pointer arg1p = cdr(expr), arg1 = cadr(expr), arg2 = caddr(expr), arg3 = cadddr(expr); + if ((quotes > 0) && + (direct_memq(sc->quote_symbol, let_or_list))) + return(opt_oops); + if ((!symbol_is_safe(sc, arg1, let_or_list)) || + (!symbol_is_safe(sc, arg2, let_or_list)) || + (!symbol_is_safe(sc, arg3, let_or_list))) + { + /* 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, arg1p, let_or_list); + set_opt3_arglen(arg1p, 3); + if (is_c_function(func)) + { + if (is_safe_procedure(func)) + { + set_safe_optimize_op(expr, hop + OP_SAFE_C_AAA); + set_opt3_pair(arg1p, 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_class_and_fn_proc(expr, func); + return(opt_ok); + } + if ((is_closure(func)) && + (closure_arity_to_int(sc, func) == 3) && + (!arglist_has_rest(sc, closure_pars(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_bad); + } + 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_bad); + } /* 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_is_aritable(func, 3))) + { + if (hop == 0) hop = hop_if_constant(sc, car(expr)); + if ((is_safe_procedure(func)) || + ((is_maybe_safe(func)) && (unsafe_is_safe(sc, arg3, let_or_list)))) + { + if (optimize_safe_c_func_three_args(sc, expr, func, hop, pairs, symbols, quotes, let_or_list) == opt_ok) + return(opt_ok); + if ((is_normal_symbol(arg1)) && (is_normal_symbol(arg2))) + { + set_opt3_pair(expr, arg3); + set_unsafe_optimize_op(expr, hop + OP_SAFE_C_SSP); /* vector-set! in tbig apparently */ + choose_c_function(sc, expr, func, 3); + return(opt_bad); + } + return(set_any_c_np(sc, func, expr, let_or_list, 3, hop + OP_SAFE_C_3P)); + } + /* func is not safe */ + if (fx_count(sc, expr) == 3) + { + set_optimized(expr); + fx_annotate_args(sc, arg1p, let_or_list); + set_opt3_arglen(arg1p, 3); + if (is_semisafe(func)) + set_optimize_op(expr, hop + (((is_normal_symbol(arg1)) && (is_normal_symbol(arg3))) ? OP_CL_SAS : OP_CL_NA)); + else + if ((fx_proc(arg1p) == fx_c) && (fx_proc(cddr(expr)) == fx_c) && (fx_proc(cdddr(expr)) == fx_c)) + set_optimize_op(expr, hop + OP_C_NC); + else set_optimize_op(expr, hop + OP_C_NA); + choose_c_function(sc, expr, func, 3); + set_unsafe(expr); + return(opt_bad); + } + + /* (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) && (is_quote(sc, car(arg1))))) + { + const 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)) || + (is_quote(sc, car(error_result))) || /* (lambda args 'a) */ + ((car(error_result) == sc->car_symbol) && + (is_pair(cdr(error_result))) && /* (lambda (type info) (car)) */ + (cadr(error_result) == cadr(error_lambda))))) /* (lambda args (car args) -> error-type */ + { + set_optimize_op(expr, OP_C_CATCH_ALL); /* catch_all* = #t tag, error handling can skip to the simple lambda body */ + /* set_class_and_fn_proc(expr, func); */ + + if (is_pair(error_result)) + error_result = (is_quote(sc, car(error_result))) ? cadr(error_result) : sc->unused; + else + if (is_symbol(error_result)) + error_result = sc->unused; + /* clear_has_fn(expr); *//* ??? this cancels the set_c_function call?? */ + set_opt2_con(expr, error_result); /* for op_c_catch_all|_a -> stack */ + + set_opt1_pair(arg1p, cddr(body_lambda)); + if (is_null(cdddr(body_lambda))) + { + if (is_fxable(sc, caddr(body_lambda))) + { + set_optimize_op(expr, 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(arg1p, caddr(body_lambda)); + set_optimize_op(expr, OP_C_CATCH_ALL_O); + /* fn got no hits */ + }}} + else + { + set_optimize_op(expr, OP_C_CATCH); /* mainly c_catch_p, but this is not a common case */ + choose_c_function(sc, expr, func, 3); + } + return(opt_bad); + }}} + + 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_symbol(caadr(arg1))) && (!is_possibly_constant(caadr(arg1))) && /* parameter name not trouble */ + (is_symbol(cadadr(arg1))) && (!is_possibly_constant(cadadr(arg1)))) + { + fx_annotate_args(sc, cddr(expr), let_or_list); + check_lambda(sc, arg1, true); /* this changes small_symbol_set */ + 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_bad); + }} + + if ((is_safe_procedure(func)) || + ((is_semisafe(func)) && + (((car(expr) != sc->assoc_symbol) && (car(expr) != sc->member_symbol)) || + (unsafe_is_safe(sc, arg3, let_or_list))))) + return(set_any_c_np(sc, func, expr, let_or_list, 3, hop + OP_SAFE_C_3P)); + return(set_any_c_np(sc, func, expr, let_or_list, 3, hop + OP_ANY_C_NP)); + } + + /* not c func */ + if (is_closure(func)) + { + const int32_t arit = closure_arity_to_int(sc, func); + if (arit != 3) + { + if (is_symbol(closure_pars(func))) + return(optimize_closure_sym(sc, expr, func, hop, 3, let_or_list)); + return(opt_bad); + } + if (is_immutable(func)) hop = 1; + + if (symbols == 3) + { + const s7_pointer body = closure_body(func); + const bool one_form = is_null(cdr(body)); + set_opt1_lambda_add(expr, func); + set_opt3_arglen(arg1p, 3); + + if (is_safe_closure(func)) + { + if ((one_form) && + (is_fxable(sc, car(body)))) + { + set_opt2_sym(expr, arg2); + set_opt3_sym(expr, arg3); + fx_annotate_arg(sc, body, let_or_list); + fx_tree(sc, body, car(closure_pars(func)), cadr(closure_pars(func)), caddr(closure_pars(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_ok); + } + set_unsafe_optimize_op(expr, hop + ((one_form) ? OP_CLOSURE_3S_O : OP_CLOSURE_3S)); + return(opt_bad); + } + + 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 set_optimize_op(expr, hop + ((is_normal_symbol(arg2)) ? OP_CLOSURE_ASA : OP_CLOSURE_3A)); + set_unsafely_optimized(expr); + fx_annotate_args(sc, arg1p, let_or_list); + if (is_fx_treeable(arg1p)) + fx_tree(sc, closure_body(func), car(closure_pars(func)), cadr(closure_pars(func)), caddr(closure_pars(func)), false); + set_opt1_lambda_add(expr, func); + set_opt3_arglen(arg1p, 3); + return(opt_bad); + } + return(set_any_closure_np(sc, func, expr, let_or_list, 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_bad); + 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, arg1p, let_or_list); + set_opt1_lambda_add(expr, func); + set_opt3_arglen(arg1p, 3); + return(opt_bad); + }} + + if ((is_c_function_star(func)) && + (fx_count(sc, expr) == 3) && + (c_function_max_args(func) >= 2)) + { + set_safe_optimize_op(expr, hop + OP_SAFE_C_STAR_NA); + fx_annotate_args(sc, arg1p, let_or_list); + set_opt3_arglen(arg1p, 3); + set_class_and_fn_proc(expr, func); + return(opt_ok); + } + /* implicit_vector_3a doesn't happen */ + + if (bad_pairs > quotes) return(opt_bad); + return((is_optimized(expr)) ? opt_ok : opt_bad); +} + +static bool symbols_are_safe(s7_scheme *sc, s7_pointer args, s7_pointer let_or_list) +{ + for (s7_pointer p = args; is_pair(p); p = cdr(p)) + { + s7_pointer arg = car(p); + if ((is_normal_symbol(arg)) && + (!symbol_is_in_big_symbol_set(sc, arg)) && + (!arg_findable(sc, arg, let_or_list))) + 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 let_or_list) +{ + const s7_pointer arg1p = cdr(expr); + if (quotes > 0) + { + if (direct_memq(sc->quote_symbol, let_or_list)) + 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_is_aritable(func, args))) + { + if (hop == 0) hop = hop_if_constant(sc, car(expr)); + 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_ok); + } + if (symbols == args) + { + if (symbols_are_safe(sc, arg1p, let_or_list)) + 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, arg1p, let_or_list); + } + set_opt3_arglen(arg1p, args); + choose_c_function(sc, expr, func, args); + return(opt_ok); + }} + + 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, arg1p, let_or_list); + set_opt3_arglen(arg1p, args); + choose_c_function(sc, expr, func, args); + + for (p = arg1p; (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))) || (!is_quote(sc, caar(p))))) + break; + } + if (is_null(p)) + { + set_optimize_op(expr, hop + OP_SAFE_C_ALL_CA); + for (p = arg1p; is_pair(p); p = cddr(p)) + { + clear_has_fx(p); + set_opt2_con(p, (is_pair(car(p))) ? cadar(p) : car(p)); + }} + return(opt_ok); + } + return(set_any_c_np(sc, func, expr, let_or_list, args, hop + OP_ANY_C_NP)); + } + /* c_func is not safe */ + if (fx_count(sc, expr) == args) /* trigger_size doesn't matter for unsafe funcs */ + { + fx_annotate_args(sc, arg1p, let_or_list); + set_opt3_arglen(arg1p, args); + set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_NA : OP_C_NA)); + choose_c_function(sc, expr, func, args); + return(opt_bad); + } + return(set_any_c_np(sc, func, expr, let_or_list, args, hop + OP_ANY_C_NP)); /* was num_args=3! 2-Sep-20 */ + } + { + const bool func_is_closure = is_closure(func); + if (func_is_closure) + { + const int32_t arit = closure_arity_to_int(sc, func); + if (arit != args) + { + if (is_symbol(closure_pars(func))) + return(optimize_closure_sym(sc, expr, func, hop, args, let_or_list)); + return(opt_bad); + } + if (is_immutable(func)) hop = 1; + + if (fx_count(sc, expr) == args) + { + const 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, arg1p, let_or_list); + set_opt3_arglen(arg1p, args); + set_opt1_lambda_add(expr, func); + + if ((symbols == args) && + (symbols_are_safe(sc, arg1p, let_or_list))) + { + if (safe_case) + set_optimize_op(expr, hop + OP_SAFE_CLOSURE_NS); + else set_optimize_op(expr, hop + ((args == 4) ? ((is_null(cdr(closure_body(func)))) ? OP_CLOSURE_4S_O : OP_CLOSURE_4S) : + ((args == 5) ? OP_CLOSURE_5S : OP_CLOSURE_NS))); + } + return(opt_bad); + } + if (args == 4) + return(set_any_closure_np(sc, func, expr, let_or_list, 4, hop + OP_ANY_CLOSURE_4P)); + return(set_any_closure_np(sc, func, expr, let_or_list, 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_bad); + + if ((is_c_function_star(func)) && + (fx_count(sc, expr) == args) && + (c_function_max_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, arg1p, let_or_list); + set_opt3_arglen(arg1p, args); + set_class_and_fn_proc(expr, func); + return(opt_ok); + } + 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, arg1p, let_or_list); + set_opt3_arglen(arg1p, args); + set_opt1_lambda_add(expr, func); + return(opt_bad); + }} + return((is_optimized(expr)) ? opt_ok : opt_bad); +} + +static bool vars_syntax_ok(s7_pointer vars) +{ + for (s7_pointer p = vars; is_pair(p); p = cdr(p)) + { + const s7_pointer var = car(p); + if ((!is_pair(var)) || + (!is_normal_symbol(car(var))) || + (!is_pair(cdr(var))) || + (is_pair(cddr(var)))) + return(false); + } + return(true); +} + +static opt_t optimize_expression(s7_scheme *sc, s7_pointer expr, int32_t hop, s7_pointer let_or_list, bool export_ok); + +static bool vars_opt_ok(s7_scheme *sc, s7_pointer vars, int32_t hop, s7_pointer let_or_list) +{ + for (s7_pointer p = vars; is_pair(p); p = cdr(p)) + { + const s7_pointer init = cadar(p); + const s7_pointer var = caar(p); /* (define (f) (let ((+ -)) (with-let (curlet) (#_integer? (+))))) (f) */ + if ((initial_value_is_defined(sc, var)) && /* is_normal_symbol is checked above in vars_syntax_ok */ + (is_slot(global_slot(var))) && (is_c_function(global_value(var)))) + { /* this is ridiculous. vars_opt_ok needs to be smarter! */ + return(false); + } + if ((is_pair(init)) && + (!is_checked(init)) && + (optimize_expression(sc, init, hop, let_or_list, false) == opt_oops)) + return(false); + } + return(true); +} + +static void cleanup_big_symbol_set(s7_scheme *sc, s7_pointer orig_e, s7_pointer var_list) +{ + for (s7_pointer p = var_list; ((is_pair(p)) && (p != orig_e)); p = cdr(p)) + { + s7_pointer sym = car(p); + if (is_symbol(sym)) + { + if (symbol_shadows(sym) > 0) + symbol_shadows(sym)--; + else set_big_symbol_tag(sym, 0); + }} +} + +static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, s7_pointer let_or_list, bool export_ok) +{ + const opcode_t op = syntax_opcode(func); + s7_pointer body = cdr(expr), vars; + const s7_pointer init_let_or_list = let_or_list; + bool body_export_ok = true; + if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: expr: %s, func: %s, let_or_list: %s, op: %s, hop: %d, export_ok: %d\n", __func__, __LINE__, + display_truncated(expr), display(func), display(let_or_list), op_names[op], hop, export_ok); + sc->w = let_or_list; + switch (op) + { + case OP_QUOTE: + case OP_MACROEXPAND: + if (is_proper_list_1(sc, body)) + { + cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); + return(opt_bad); + } + return(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) */ + { + cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); + return(opt_bad); + } + vars = caddr(expr); + if (!is_list(vars)) return(opt_oops); + body = cdddr(expr); + } + else + { + vars = cadr(expr); + body = cddr(expr); + if (is_null(vars)) + let_or_list = cons(sc, sc->nil, let_or_list); /* () in let_or_list = 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)) + { + let_or_list = collect_variables(sc, vars, let_or_list); + if (!vars_opt_ok(sc, vars, hop, let_or_list)) + return(opt_oops); + } + else + if (op == OP_LET) + { + if (!vars_opt_ok(sc, vars, hop, let_or_list)) + return(opt_oops); + let_or_list = collect_variables(sc, vars, let_or_list); + } + else + for (s7_pointer 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, let_or_list, false) == opt_oops)) + return(opt_oops); + let_or_list = cons(sc, add_symbol_to_big_symbol_set(sc, car(var)), let_or_list); + sc->w = let_or_list; + } + if (is_symbol(cadr(expr))) + { + let_or_list = cons(sc, add_symbol_to_big_symbol_set(sc, cadr(expr)), let_or_list); + sc->w = let_or_list; + } + break; + + case OP_LET_TEMPORARILY: + vars = cadr(expr); + if (!is_list(vars)) return(opt_oops); + body = cddr(expr); + for (s7_pointer 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, let_or_list, false) == opt_oops)) + return(opt_oops); + } + /* let_or_list = cons(sc, sc->nil, let_or_list); */ /* !? 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)) + let_or_list = cons(sc, sc->nil, let_or_list); + else + if (!is_pair(vars)) + return(opt_oops); + body = cddr(expr); + + for (s7_pointer p = vars; is_pair(p); p = cdr(p)) + { + const 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, let_or_list, false) == opt_oops)) /* the init field -- locals are not defined yet */ + return(opt_oops); + } + let_or_list = collect_variables(sc, vars, let_or_list); + for (s7_pointer p = vars; is_pair(p); p = cdr(p)) + { + const s7_pointer var = cddar(p); + if ((is_pair(var)) && + (is_pair(car(var))) && + (!is_checked(car(var))) && + (optimize_expression(sc, car(var), hop, let_or_list, 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: + let_or_list = cons(sc, sc->nil, let_or_list); + break; + + case OP_DEFINE_BACRO: case OP_DEFINE_BACRO_STAR: + case OP_BACRO: case OP_BACRO_STAR: + cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); + return(opt_bad); + + 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 (let_or_list), the added name is inserted into let_or_list 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 "let_or_list", but it needs to be marked for find_uncomplicated_symbol in a way + * that can be distinguished from members of "let_or_list". 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 + * define et al here can be #_define, not the symbol 'define + */ + vars = cadr(expr); + body = cddr(expr); + if (is_pair(vars)) + { + if ((export_ok) && + (is_symbol(car(vars)))) + { + add_symbol_to_big_symbol_set(sc, car(vars)); + if ((is_pair(let_or_list)) && (car(let_or_list) != sc->if_keyword)) + set_cdr(let_or_list, cons(sc, car(vars), cdr(let_or_list))); /* export it */ + else let_or_list = cons(sc, car(vars), let_or_list); + } + let_or_list = collect_parameters(sc, cdr(vars), let_or_list); + body_export_ok = export_ok; + } + else /* vars must be a symbol */ + { + if (!is_symbol(vars)) return(opt_oops); /* (define 1 2) */ + + /* 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. + */ + if (initial_value_is_defined(sc, vars)) + { + if ((SHOW_EVAL_OPS) && (!is_maybe_shadowed(vars))) fprintf(stderr, " %s set maybe shadowed\n", display(vars)); + set_is_maybe_shadowed(vars); + } + sc->temp7 = let_or_list; + for (s7_pointer 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, let_or_list, false) == opt_oops)) /* "body" here is not body in terms of export_ok */ + { + sc->temp7 = sc->unused; + return(opt_oops); + } + sc->temp7 = sc->unused; + if (export_ok) + { + if ((is_pair(let_or_list)) && (car(let_or_list) != sc->if_keyword)) + set_cdr(let_or_list, cons(sc, vars, cdr(let_or_list))); /* export it */ + cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); + } + return(opt_bad); + } + break; + + case OP_LAMBDA: case OP_LAMBDA_STAR: + case OP_MACRO: case OP_MACRO_STAR: + vars = cadr(expr); + if (is_null(vars)) + let_or_list = cons(sc, sc->nil, let_or_list); + else + if ((!is_pair(vars)) && (!is_symbol(vars))) + return(opt_oops); + let_or_list = collect_parameters(sc, vars, let_or_list); + 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)))) + { + const bool old_in_with_let = sc->in_with_let; + set_checked(cadr(expr)); + if (caadr(expr) == sc->with_let_symbol) sc->in_with_let = true; + for (s7_pointer lp = cdadr(expr); is_pair(lp); lp = cdr(lp)) + if ((is_pair(car(lp))) && + (!is_checked(car(lp))) && + (optimize_expression(sc, car(lp), hop, let_or_list, body_export_ok) == opt_oops)) + { + sc->in_with_let = old_in_with_let; + return(opt_oops); + } + sc->in_with_let = old_in_with_let; + } + if ((is_pair(caddr(expr))) && + (!is_checked(caddr(expr))) && + (optimize_expression(sc, caddr(expr), hop, let_or_list, body_export_ok) == opt_oops)) + return(opt_oops); + + if ((is_pair(cadr(expr))) && (caadr(expr) == sc->starlet_symbol)) + { + cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); + return(opt_ok); + } + cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); + return(opt_bad); + + 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. + */ + { + const bool old_with_let = sc->in_with_let; + sc->temp9 = let_or_list; + clear_big_symbol_set(sc); + 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)); + /* not rootlet here: (let ((i 0)) (_rd3_ (with-let (rootlet) ((null? i) i)))) */ + for (s7_pointer 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; + sc->temp9 = sc->unused; + return(opt_oops); + } + sc->in_with_let = old_with_let; + cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); + sc->temp9 = sc->unused; + return(opt_bad); + } + + case OP_CASE: + if ((is_pair(cadr(expr))) && + (!is_checked(cadr(expr))) && + (optimize_expression(sc, cadr(expr), hop, let_or_list, false) == opt_oops)) + return(opt_oops); + for (s7_pointer p = cddr(expr); is_pair(p); p = cdr(p)) + if ((is_pair(car(p))) && + (is_pair(cdar(p)))) + for (s7_pointer rst = cdar(p); is_pair(rst); rst = cdr(rst)) + if ((is_pair(car(rst))) && + (!is_checked(car(rst))) && + (optimize_expression(sc, car(rst), hop, let_or_list, false) == opt_oops)) + return(opt_oops); + cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); + return(opt_bad); + + case OP_COND: /* split opt is necessary: (cond (lambda (x) ...)) */ + for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p)) + if (is_pair(car(p))) + { + const s7_pointer test = caar(p); + let_or_list = cons(sc, sc->if_keyword, let_or_list); /* 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, let_or_list, false) == opt_oops)) + return(opt_oops); + for (s7_pointer rst = cdar(p); is_pair(rst); rst = cdr(rst)) + if ((is_pair(car(rst))) && + (!is_checked(car(rst))) && + (optimize_expression(sc, car(rst), hop, let_or_list, false) == opt_oops)) + return(opt_oops); + } + { + s7_pointer p; + 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)) {cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); return(opt_bad);} + set_safe_optimize_op(expr, OP_COND_NA_NA); + } + for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p)) + { + set_fx_direct(car(p), fx_choose(sc, car(p), let_or_list, pair_symbol_is_safe)); + for (s7_pointer q = cdar(p); is_pair(q); q = cdr(q)) + set_fx_direct(q, fx_choose(sc, q, let_or_list, pair_symbol_is_safe)); + } + cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); + return(opt_ok); + + 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: + let_or_list = cons(sc, sc->if_keyword, let_or_list); + break; + + default: break; + } + + sc->temp7 = let_or_list; + for (s7_pointer 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, let_or_list, body_export_ok) == opt_oops)) + { + sc->temp7 = sc->unused; + return(opt_oops); + } + sc->temp7 = sc->unused; + + if ((hop == 1) && + ((is_syntax(car(expr))) || + (is_global(car(expr))))) + { + if (op == OP_IF) + { + const s7_pointer test = cdr(expr); + const s7_pointer b1 = cdr(test); + const s7_pointer b2 = cdr(b1); + s7_pointer p; + for (p = cdr(expr); is_pair(p); p = cdr(p)) + if (!is_fxable(sc, car(p))) + { + cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); + return(opt_bad); + } + if (!is_null(p)) return(opt_oops); + if ((is_pair(cdr(test))) && (is_pair(cddr(test))) && (!is_null(cdddr(test)))) + return(opt_oops); + + for (s7_pointer p1 = cdr(expr); is_pair(p1); p1 = cdr(p1)) + set_fx_direct(p1, fx_choose(sc, p1, let_or_list, pair_symbol_is_safe)); + + 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)); + cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); + return(opt_ok); + } + 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), let_or_list, 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)); + cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); + return(opt_ok); + } + 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); + cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); + return(opt_ok); + } + 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)); + }} + cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); + return(opt_ok); + } + else + { + if ((op == OP_OR) || (op == OP_AND)) + { + int32_t args = 0, pairs = 0; + bool c_s_is_ok = true; + { + s7_pointer p; + for (p = cdr(expr); is_pair(p); p = cdr(p)) + if (!is_fxable(sc, car(p))) + { + cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); + return(opt_bad); + } + if (!is_null(p)) return(opt_oops); + } + for (s7_pointer p1 = cdr(expr), sym = NULL; is_pair(p1); p1 = cdr(p1), args++) /* this only applies to or/and */ + if (is_pair(car(p1))) + { + pairs++; + if ((c_s_is_ok) && + ((!is_h_safe_c_s(car(p1))) || + ((sym) && (sym != cadar(p1))))) + c_s_is_ok = false; + else sym = (is_pair(cdar(p1))) ? cadar(p1) : 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_defined_global(caadr(expr))) && + ((is_symbol(caaddr(expr))) && (symbol_type(caaddr(expr)) > 0) && (is_defined_global(caaddr(expr))))) + { + set_opt3_int(expr, symbol_type(caadr(expr))); + set_opt2_int(cdr(expr), 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); + } + cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); + return(opt_ok); + } + + for (s7_pointer p1 = cdr(expr); is_pair(p1); p1 = cdr(p1)) + set_fx_direct(p1, fx_choose(sc, p1, let_or_list, 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); + } + cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); + return(opt_ok); + } + if (args == 2) + set_safe_optimize_op(expr, OP_AND_2A); + else set_safe_optimize_op(expr, (args == 3) ? OP_AND_3A : OP_AND_N); + cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); + return(opt_ok); + } + else + if (op == OP_BEGIN) + { + s7_pointer p; + if (!is_pair(cdr(expr))) {cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); return(opt_bad);} + for (p = cdr(expr); is_pair(p); p = cdr(p)) + if (!is_fxable(sc, car(p))) + { + cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); + return(opt_bad); + } + if (!is_null(p)) return(opt_oops); + for (s7_pointer p1 = cdr(expr); is_pair(p1); p1 = cdr(p1)) + set_fx_direct(p1, fx_choose(sc, p1, let_or_list, pair_symbol_is_safe)); + set_safe_optimize_op(expr, ((is_pair(cddr(expr))) && (is_null(cdddr(expr)))) ? OP_BEGIN_AA : OP_BEGIN_NA); + cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); + return(opt_ok); + }}} /* fully fxable lets don't happen much: even let-2a-a is scarcely used */ + cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); + return(opt_bad); +} + +static opt_t optimize_funcs(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, int32_t orig_hop, s7_pointer let_or_list) +{ + int32_t pairs = 0, symbols = 0, args = 0, bad_pairs = 0, quotes = 0; + s7_pointer p; + if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s, func: %s, hop: %d\n", __func__, __LINE__, display_truncated(expr), display(func), hop); + for (p = cdr(expr); is_pair(p); p = cdr(p), args++) /* check the calling expression */ + { + const s7_pointer arg = car(p); + if (is_normal_symbol(arg)) /* for opt func */ + symbols++; + else + if (is_pair(arg)) + { + pairs++; + if (!is_checked(arg)) + { + opt_t result; + if ((is_pair(car(arg))) && (caar(arg) == sc->let_symbol)) + result = opt_bad; + else result = optimize_expression(sc, arg, orig_hop, let_or_list, false); + if (result == opt_bad) + { + bad_pairs++; + if (is_proper_quote(sc, arg)) + quotes++; + } + else + if (result == opt_oops) + return(opt_oops); + } + else + if ((!is_optimized(arg)) || + (is_unsafe(arg))) + { + bad_pairs++; + if (is_proper_quote(sc, arg)) + quotes++; + }}} + if (is_null(p)) /* if not null, dotted list of args, (cons 1 . 2) etc -- error perhaps? */ + { + switch (args) + { + case 0: return(optimize_thunk(sc, expr, func, hop, let_or_list)); + case 1: return(optimize_func_one_arg(sc, expr, func, hop, pairs, symbols, quotes, bad_pairs, let_or_list)); + case 2: return(optimize_func_two_args(sc, expr, func, hop, pairs, symbols, quotes, bad_pairs, let_or_list)); + case 3: return(optimize_func_three_args(sc, expr, func, hop, pairs, symbols, quotes, bad_pairs, let_or_list)); + default: return(optimize_func_many_args(sc, expr, func, hop, args, pairs, symbols, quotes, bad_pairs, let_or_list)); + }} + return(opt_oops); /* was opt_bad, but this is always an error */ +} + +static opt_t optimize_expression(s7_scheme *sc, s7_pointer expr, int32_t hop, s7_pointer let_or_list, bool export_ok) +{ + const s7_pointer head = car(expr), args = cdr(expr); + const int32_t orig_hop = hop; + if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s, let_or_list: %s, hop: %d\n", __func__, __LINE__, display_truncated(expr), display(let_or_list), hop); + set_checked(expr); + + if (is_symbol(head)) + { + s7_pointer slot; + if (is_syntactic_symbol(head)) + { + if (!is_pair(args)) + return(opt_oops); + return(optimize_syntax(sc, expr, T_Syn(global_value(head)), hop, let_or_list, export_ok)); + } + slot = find_uncomplicated_symbol(sc, head, let_or_list); /* local vars (recursive calls too??) are considered complicated */ + if (is_slot(slot)) + { + const s7_pointer func = slot_value(slot); + if (is_syntax(func)) /* not is_syntactic -- here we have the value */ + return((is_pair(args)) ? optimize_syntax(sc, expr, func, hop, let_or_list, export_ok) : opt_oops); /* e can be extended via set-cdr! here */ + + if (is_any_macro(func)) + return(opt_bad); + + /* 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_applicable(func)) && + (is_safe_procedure(func)))) /* built-in applicable objects like vectors */ + { + /* if (is_maybe_shadowed(head)) fprintf(stderr, "%d: is_maybe_shadowed: %s in %s\n", __LINE__, display(head), display(expr)); */ + if ((hop != 0) && + ((is_maybe_shadowed(head)) || /* for globals that are possibly clobbered at run-time (i.e. not yet) */ + (((is_any_closure(func)) || /* see use-redef in s7test -- I'm not sure about this */ + ((!is_global(head)) && + ((!is_slot(global_slot(head))) || + (global_value(head) != func)))) && + (!is_immutable(head)) && /* list|apply-values -- can't depend on opt1 here because it might not be global, or might be redefined locally */ + (!is_immutable_slot(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_defined_global(head) 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, let_or_list)); + }} + else + if ((sc->undefined_identifier_warnings) && + (slot == sc->undefined) && /* head is not in let_or_list or global */ + (big_symbol_tag(head) == 0)) /* and we haven't looked it up earlier */ + { + const s7_pointer port = current_input_port(sc); + if ((is_input_port(port)) && + (port_file(port) != stdin) && + (!port_is_closed(port)) && + (port_filename(port))) + s7_warn(sc, 1024, "%s might be undefined (%s %u)\n", display(head), port_filename(port), port_line_number(port)); + else s7_warn(sc, 1024, "; %s might be undefined\n", display(head)); + set_big_symbol_tag(head, 1); /* one warning is enough */ + } + + /* head 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 = args; is_pair(p); p = cdr(p), len++) + { + const s7_pointer arg = car(p); + if (is_pair(arg)) + { + pairs++; + if ((!is_checked(arg)) && + (optimize_expression(sc, arg, hop, let_or_list, false) == opt_oops)) + return(opt_oops); + } + else + if (is_symbol(arg)) + 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_bad); + } + if (len == 1) + { + if (!is_quote(sc, head)) /* !! quote can be redefined locally, unsetting the T_SYNTACTIC flag -- can this happen elsewhere? */ + set_unsafe_optimize_op(expr, (is_normal_symbol(cadr(expr))) ? OP_UNKNOWN_S : OP_UNKNOWN_A); + fx_annotate_arg(sc, args, let_or_list); /* g->a later if closure */ + return(opt_bad); + } + if (len == 2) + { + set_unsafely_optimized(expr); + set_optimize_op(expr, OP_UNKNOWN_GG); + return(opt_bad); + } + if (len >= 3) + { + if (len == symbols) + { + set_unsafe_optimize_op(expr, OP_UNKNOWN_NS); + set_opt3_arglen(args, len); + return(opt_bad); + } + if (fx_count(sc, expr) == len) + { + set_unsafe_optimize_op(expr, OP_UNKNOWN_NA); + set_opt3_arglen(args, len); + return(opt_bad); + }}} + else /* pairs != 0 */ + { + const s7_pointer arg1 = cadr(expr); + if ((pairs == 1) && (len == 1)) + { + if ((is_quote(sc, head)) && + (direct_memq(sc->quote_symbol, let_or_list))) + return(opt_oops); + if (is_fxable(sc, arg1)) + { + set_opt3_arglen(args, 1); + fx_annotate_arg(sc, args, let_or_list); + set_unsafe_optimize_op(expr, OP_UNKNOWN_A); + return(opt_bad); + }} + 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(args, len); + if (len <= 2) fx_annotate_args(sc, args, let_or_list); + return(opt_bad); + } + set_unsafe_optimize_op(expr, OP_UNKNOWN_NP); + set_opt3_arglen(args, len); + return(opt_bad); + }}}} + 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)))) */ + + if ((head == sc->quote_function) && (is_pair(args))) /* very common */ + return(optimize_syntax(sc, expr, sc->quote_function, hop, let_or_list, export_ok)); + + if (is_c_function(head)) /* (#_abs x) etc */ + return(optimize_funcs(sc, expr, head, /* (direct_memq(c_function_symbol(head), let_or_list)) ? 0 : */ 1, orig_hop, let_or_list)); + + if (is_syntax(head)) /* (#_cond...) etc */ + { + if (!is_pair(args)) + return(opt_oops); + return(optimize_syntax(sc, expr, head, orig_hop, let_or_list, export_ok)); + } + if (is_any_macro(head)) + return(opt_bad); + + /* 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 (s7_pointer p = expr; is_pair(p); p = cdr(p)) + if (((is_symbol(car(p))) && (is_syntactic_symbol(car(p)))) || + ((is_pair(car(p))) && (!is_checked(car(p))) && + (optimize_expression(sc, car(p), hop, let_or_list, 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_bad); +} + +static opt_t optimize(s7_scheme *sc, s7_pointer code, int32_t hop, s7_pointer let_or_list) +{ + s7_pointer expr; + if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s, let_or_list: %s, hop: %d\n", __func__, __LINE__, display_truncated(code), display(let_or_list), hop); + for (expr = code; (is_pair(expr)) && (!is_checked(expr)); expr = cdr(expr)) + { + const s7_pointer obj = car(expr); + set_checked(expr); + if (is_pair(obj)) + { + if ((!is_checked(obj)) && + (optimize_expression(sc, obj, hop, let_or_list, true) == opt_oops)) + { + s7_pointer p; + for (p = cdr(expr); is_pair(p); p = cdr(p)); + if (!is_null(p)) + syntax_error_nr(sc, "stray dot in function body: ~S", 30, code); + return(opt_oops); + }} + else + if (is_symbol(obj)) + set_optimize_op(obj, (is_keyword(obj)) ? OP_CONSTANT : OP_SYMBOL); + else set_optimize_op(obj, OP_CONSTANT); + } + if (!is_list(expr)) + syntax_error_nr(sc, "stray dot in function body: ~S", 30, code); + return(opt_bad); +} + + +static s7_pointer key_or_constant_arg(s7_scheme *sc, s7_pointer arg) +{ + bool key = is_symbol_and_keyword(arg); + return(wrap_string(sc, (key) ? "keyword" : "constant", (key) ? 7 : 8)); + /* maybe better, but there is no sc->keyword_symbol: return((is_symbol_and_keyword(arg)) ? sc->keyword_symbol : sc->constant_symbol); */ +} + +static void check_lambda_args(s7_scheme *sc, s7_pointer args, int32_t *arity, s7_pointer form) +{ + int32_t i; + if (!is_list(args)) + { + if (is_constant(sc, args)) /* (lambda :a ...) or (define (f :a) ...) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_5(sc, wrap_string(sc, "~A parameter is a ~A: (~S ~S ...)", 33), + car(form), key_or_constant_arg(sc, args), car(form), cadr(form))); + /* 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; + } + begin_small_symbol_set(sc); + for (i = 0; is_pair(args); i++, args = cdr(args)) + { + const s7_pointer arg = car(args); + if (is_constant(sc, arg)) /* (lambda (pi) pi), constant here means not a symbol */ + { + if (is_pair(arg)) /* (lambda ((:hi . "hi") . "hi") 1) */ + error_nr(sc, sc->syntax_error_symbol, /* don't use ~A here or below, (lambda #\null do) for example */ + set_elist_5(sc, wrap_string(sc, "~A parameter ~S is a pair (perhaps use lambda*?): (~S ~S ...)", 61), + car(form), arg, car(form), cadr(form))); + if ((arg == sc->rest_keyword) && + ((car(form) == sc->define_symbol) || (car(form) == sc->lambda_symbol))) + error_nr(sc, sc->syntax_error_symbol, + set_elist_6(sc, wrap_string(sc, "~A parameter is ~S? (~S ~S ...), perhaps use ~S", 47), + car(form), arg, car(form), cadr(form), + (car(form) == sc->define_symbol) ? sc->define_star_symbol : sc->lambda_star_symbol)); + error_nr(sc, sc->syntax_error_symbol, /* (lambda (a :b c) 1) */ + set_elist_6(sc, wrap_string(sc, "~A parameter ~S is a ~A: (~S ~S ...)", 36), + car(form), arg, key_or_constant_arg(sc, arg), car(form), cadr(form))); + } + if (symbol_is_in_small_symbol_set(sc, arg)) + error_nr(sc, sc->syntax_error_symbol, + set_elist_5(sc, wrap_string(sc, "~A parameter ~S is used twice in the parameter list, (~S ~S ...)", 64), + car(form), arg, car(form), cadr(form))); + add_symbol_to_small_symbol_set(sc, arg); + set_local(arg); + } + if (is_not_null(args)) + { + if ((is_symbol(args)) && (symbol_is_in_small_symbol_set(sc, args))) + error_nr(sc, sc->syntax_error_symbol, set_elist_3(sc, wrap_string(sc, "~A :rest parameter ~S is used earlier in the parameter list", 59), car(form), args)); + if (is_constant(sc, args)) /* (lambda (a . 0.0) a) or (lambda (a . :b) a) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_6(sc, wrap_string(sc, "~A :rest parameter ~S is a ~A in (~S ~S ...)", 44), + car(form), args, key_or_constant_arg(sc, args), car(form), cadr(form))); + i = -i - 1; + } + end_small_symbol_set(sc); + if (arity) (*arity) = i; +} + +static s7_pointer check_lambda_star_args(s7_scheme *sc, s7_pointer args, s7_pointer body, s7_pointer form) /* checks closure*, macro*, and bacro* */ +{ + const s7_pointer top = args; + s7_pointer pars = args; + bool has_defaults = false; + + if (!is_list(args)) + { + if (is_constant(sc, args)) /* (lambda* :a ...) or (define* (f . :a) ...) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_5(sc, wrap_string(sc, "~A parameter is a ~A: (~S ~S ...)", 33), + car(form), key_or_constant_arg(sc, args), car(form), cadr(form))); + if (is_symbol(args)) set_local(args); + return(args); + } + + begin_small_symbol_set(sc); + for (s7_pointer last_pars = args; is_pair(pars); last_pars = pars, pars = cdr(pars)) + { + const s7_pointer cur_par = car(pars); + if (is_pair(cur_par)) + { + has_defaults = true; + if (is_constant(sc, car(cur_par))) /* (lambda* ((:a 1)) ...) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_6(sc, wrap_string(sc, "~A parameter ~S is a ~A: (~S ~S ...)", 36), + car(form), car(cur_par), key_or_constant_arg(sc, car(cur_par)), car(form), cadr(form))); + if (symbol_is_in_small_symbol_set(sc, car(cur_par))) + error_nr(sc, sc->syntax_error_symbol, + set_elist_5(sc, wrap_string(sc, "~A parameter ~S is used twice in the parameter list, (~S ~S ...)", 64), + car(form), car(cur_par), car(form), cadr(form))); + add_symbol_to_small_symbol_set(sc, car(cur_par)); + if (!is_pair(cdr(cur_par))) + { + if (is_null(cdr(cur_par))) /* (lambda* ((a)) ...) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_5(sc, wrap_string(sc, "~A parameter ~S default value missing in (~S ~S ...)", 52), + car(form), cur_par, car(form), cadr(form))); + error_nr(sc, sc->syntax_error_symbol, /* (lambda* ((a . 0.0)) a) */ + set_elist_5(sc, wrap_string(sc, "~A parameter ~S is a dotted pair in (~S ~S ...)", 47), + car(form), cur_par, car(form), cadr(form))); + } + if ((is_pair(cadr(cur_par))) && /* (lambda* ((a (quote . -1))) ...) */ + (s7_list_length(sc, cadr(cur_par)) < 0)) + error_nr(sc, sc->syntax_error_symbol, + set_elist_5(sc, wrap_string(sc, "~A parameter ~S default value is not a proper list in (~S ~S ...)", 65), + car(form), cur_par, car(form), cadr(form))); + if (is_not_null(cddr(cur_par))) /* (lambda* ((a 0.0 'hi)) a) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_5(sc, wrap_string(sc, "~A parameter ~S has multiple default values in (~S ~S ...)", 58), + car(form), cur_par, car(form), cadr(form))); + set_local(car(cur_par)); + } + else + if (cur_par != sc->rest_keyword) + { + if (is_constant(sc, cur_par)) + { + if (cur_par != sc->allow_other_keys_keyword) + error_nr(sc, sc->syntax_error_symbol, /* (lambda* (pi) ...) */ + set_elist_6(sc, wrap_string(sc, "~A parameter ~S is a ~A: (~S ~S ...)", 36), + car(form), cur_par, key_or_constant_arg(sc, cur_par), car(form), cadr(form))); + if (is_not_null(cdr(pars))) /* (lambda* (:allow-other-keys x) x) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, ":allow-other-keys should be the last parameter: (~S ~S ...)", 59), + car(form), cadr(form))); + if (pars == top) /* (lambda* (:allow-other-keys) 1) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, ":allow-other-keys can't be the only parameter: (~S ~S ...)", 58), + car(form), cadr(form))); + set_allow_other_keys(top); + set_cdr(last_pars, sc->nil); /* last_pars is '( :allow-other-keys) so this chops off the trailing keyword */ + } + if (symbol_is_in_small_symbol_set(sc, cur_par)) + error_nr(sc, sc->syntax_error_symbol, + set_elist_5(sc, wrap_string(sc, "~A parameter ~S is used twice in the parameter list, (~S ~S ...)", 64), + car(form), cur_par, car(form), cadr(form))); + add_symbol_to_small_symbol_set(sc, cur_par); + if (!is_keyword(cur_par)) set_local(cur_par); + } + else + { + has_defaults = true; + if (!is_pair(cdr(pars))) /* (lambda* (:rest) ...) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "~A :rest parameter missing in (~S ~S ...)", 41), + car(form), car(form), cadr(form))); + if (!is_symbol(cadr(pars))) /* (lambda* (:rest (a 1)) ...) */ + { + if (!is_pair(cadr(pars))) /* (lambda* (:rest 1) ...) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_5(sc, wrap_string(sc, "~A :rest parameter is not a symbol: ~S in (~S ~S ...)", 53), + car(form), pars, car(form), cadr(form))); + error_nr(sc, sc->syntax_error_symbol, /* (lambda* (:rest '(1 2)) 1) */ + set_elist_5(sc, wrap_string(sc, "~A :rest parameter can't have a default value: ~S in (~S ~S ...)", 64), + car(form), pars, car(form), cadr(form))); + } + if (is_constant(sc, cadr(pars))) /* (lambda* (a :rest x) ...) where x is locally a constant */ + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_5(sc, wrap_string(sc, "~A: ~S is immutable, so it can't be the :rest parameter name: (~S ~S ...)", 73), + car(form), cadr(pars), car(form), cadr(form))); + set_local(cadr(pars)); + }} + if (is_not_null(pars)) + { + if ((is_symbol(pars)) && (symbol_is_in_small_symbol_set(sc, pars))) + error_nr(sc, sc->syntax_error_symbol, set_elist_3(sc, wrap_string(sc, "~A :rest parameter ~S is used earlier in the parameter list", 59), car(form), pars)); + if (is_constant(sc, pars)) /* (lambda* (a 0.0) a) or (lambda* (a :b) a) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_6(sc, wrap_string(sc, "~A :rest parameter ~S is a ~A, (~S ~S ...)", 42), + car(form), pars, key_or_constant_arg(sc, pars), car(form), cadr(form))); + if (is_symbol(pars)) + set_local(pars); + } + else + if ((body) && (!has_defaults) && (is_pair(args))) + set_has_no_defaults(body); + end_small_symbol_set(sc); + 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 form, bool at_end) /* called only from body_is_safe */ +{ + const s7_pointer expr = car(form); + body_t result = very_safe_body; + + if (is_symbol_and_syntactic(expr)) + { + if (!is_pair(cdr(form))) return(unsafe_body); + switch (symbol_syntax_op_checked(form)) + /* symbol_syntax_op(expr) here gets tangled in fx_annotation order problems! -- fix this?!? + * it appears that safe bodies are marked unsafe because the opts are out-of-order? + */ + { + case OP_OR: case OP_AND: case OP_BEGIN: case OP_WITH_BAFFLE: + return(body_is_safe(sc, func, cdr(form), at_end)); + + case OP_MACROEXPAND: + return(unsafe_body); + + case OP_QUOTE: case OP_QUOTE_UNCHECKED: + return(((!is_pair(cdr(form))) || (!is_null(cddr(form)))) ? unsafe_body : very_safe_body); /* (quote . 1) or (quote 1 2) etc */ + + case OP_IF: + if (!is_pair(cddr(form))) return(unsafe_body); + if (is_pair(cadr(form))) + { + result = form_is_safe(sc, func, cadr(form), false); + if (result == unsafe_body) return(unsafe_body); + } + if (is_pair(caddr(form))) + { + result = min_body(result, form_is_safe(sc, func, caddr(form), at_end)); + if (result == unsafe_body) return(unsafe_body); + } + if ((is_pair(cdddr(form))) && + (is_pair(cadddr(form)))) + return(min_body(result, form_is_safe(sc, func, cadddr(form), at_end))); + return(result); + + case OP_WHEN: case OP_UNLESS: + if (!is_pair(cddr(form))) return(unsafe_body); + if (is_pair(cadr(form))) + { + result = form_is_safe(sc, func, cadr(form), false); + if (result == unsafe_body) return(unsafe_body); + } + return(min_body(result, body_is_safe(sc, func, cddr(form), at_end))); + + case OP_COND: + { + bool follow = false; + s7_pointer clauses = cdr(form); + for (s7_pointer sp = form; is_pair(clauses); clauses = cdr(clauses)) + { + const s7_pointer clause = car(clauses); + if (!is_pair(clause)) return(unsafe_body); + if (is_pair(car(clause))) + { + result = min_body(result, form_is_safe(sc, func, car(clause), false)); + if (result == unsafe_body) return(unsafe_body); + } + if (is_pair(cdr(clause))) + { + result = min_body(result, body_is_safe(sc, func, cdr(clause), at_end)); + if (result == unsafe_body) return(unsafe_body); + } + if (follow) {sp = cdr(sp); if (clauses == sp) return(unsafe_body);} + follow = (!follow); + } + return((is_null(clauses)) ? result : unsafe_body); + } + + case OP_CASE: + { + bool follow = false; + s7_pointer sp; + if (!is_pair(cddr(form))) return(unsafe_body); + if (is_pair(cadr(form))) + { + result = form_is_safe(sc, func, cadr(form), false); + if (result == unsafe_body) return(unsafe_body); + } + sp = cdr(form); + for (s7_pointer clauses = cdr(sp); is_pair(clauses); clauses = cdr(clauses)) + { + if (!is_pair(car(clauses))) return(unsafe_body); + if (is_pair(cdar(clauses))) + { + result = min_body(result, body_is_safe(sc, func, cdar(clauses), at_end)); /* null cdar(p) ok here */ + if (result == unsafe_body) return(unsafe_body); + } + if (follow) {sp = cdr(sp); if (clauses == 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(form))) return(unsafe_body); + if (cadr(form) == func) return(unsafe_body); + + /* car(form) is set!, cadr(form) is settee or obj, caddr(form) is val */ + if (is_pair(caddr(form))) + { + result = form_is_safe(sc, func, caddr(form), false); + if (result == unsafe_body) return(unsafe_body); + } + return((is_pair(cadr(form))) ? min_body(result, form_is_safe(sc, func, cadr(form), false)) : result); + /* not OP_DEFINE even in simple cases (safe_closure assumes constant funclet) */ + + case OP_WITH_LET: + if (!is_pair(cddr(form))) return(unsafe_body); + return((is_pair(cadr(form))) ? unsafe_body : min_body(body_is_safe(sc, sc->F, cddr(form), at_end), safe_body)); + /* shadowing can happen in with-let -- symbols are global so local_slots are shadowable */ + + case OP_LET_TEMPORARILY: + if (!is_pair(cadr(form))) return(unsafe_body); + for (s7_pointer vars = cadr(form); is_pair(vars); vars = cdr(vars)) + { + if ((!is_pair(car(vars))) || + (!is_pair(cdar(vars)))) + return(unsafe_body); + if (is_pair(cadar(vars))) + { + result = min_body(result, form_is_safe(sc, sc->F, cadar(vars), false)); + if (result == unsafe_body) return(unsafe_body); + }} + return(min_body(result, body_is_safe(sc, sc->F, cddr(form), 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, vars = cadr(form), body = cddr(form); + if (is_symbol(vars)) + { + if (!is_pair(body)) return(unsafe_body); /* (let name . res) */ + if (vars == func) return(unsafe_body); /* named let shadows caller */ + let_name = vars; + vars = caddr(form); + body = cdddr(form); + if (is_symbol(func)) + add_symbol_to_small_symbol_set(sc, func); + } + else let_name = func; + + for (s7_pointer sp = NULL; is_pair(vars); vars = cdr(vars)) + { + const s7_pointer let_var = car(vars); + s7_pointer 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_small_symbol_set(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(form))) return(unsafe_body); + if (is_pair(cadr(form))) + { + s7_pointer vars = cadr(form); + s7_pointer slow_vars = vars; + for (bool follow = false; is_pair(vars); vars = cdr(vars)) + { + const 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_small_symbol_set(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 (slow_vars != vars) + { + if (follow) {slow_vars = cdr(slow_vars); if (vars == slow_vars) return(unsafe_body);} + follow = (!follow); + }}} + if (is_pair(caddr(form))) + result = min_body(result, body_is_safe(sc, func, caddr(form), at_end)); + return(min_body(result, body_is_safe(sc, func, cdddr(form), 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: + /* OP_LAMBDA is major case here */ + /* 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(form) is not syntactic */ + { + if (expr == func) /* try to catch tail call, expr is car(form) */ + { + bool follow = false; + s7_pointer slow_form = form, p; + sc->got_rec = true; /* (walk (car tree)) lint and almost all others in s7test */ + set_rec_tc_args(sc, proper_list_length(cdr(form))); + if (!at_end) {result = recur_body; sc->not_tc = true;} + for (p = cdr(form); 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) {slow_form = cdr(slow_form); if (p == slow_form) 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(form))); + return(result); + } + if (result != unsafe_body) result = recur_body; + return(result); + } + if (is_symbol(expr)) /* expr=car(form) */ + { + s7_pointer head_f, f_slot; + bool c_safe; + + if (symbol_is_in_small_symbol_set(sc, expr)) return(unsafe_body); + if ((is_slot(global_slot(expr))) && (is_syntax(global_value(expr)))) + return(unsafe_body); /* syntax hidden behind some other name */ + + f_slot = s7_slot(sc, expr); + if (!is_slot(f_slot)) return(unsafe_body); + + head_f = slot_value(f_slot); + if (is_c_function(head_f)) + { + if ((expr == sc->apply_symbol) && (is_pair(cdr(form))) && (is_symbol(cadr(form)))) /* (apply ...) */ + { + s7_pointer apply_f = lookup_unexamined(sc, cadr(form)); /* "unexamined" to skip unbound_variable */ + c_safe = ((apply_f) && /* (apply_f != sc->undefined) && */ + ((is_safe_c_function(apply_f)) || + ((is_closure(apply_f)) && (is_very_safe_closure(apply_f))))); + } + else c_safe = (is_safe_or_scope_safe_procedure(head_f)); + } + else c_safe = false; + + result = ((is_simple_sequence(head_f)) || /* was is_sequence? */ + ((is_closure(head_f)) && (is_very_safe_closure(head_f))) || + ((c_safe) && ((is_immutable_slot(f_slot)) || (is_defined_global(expr))))) ? very_safe_body : safe_body; + + if ((c_safe) || + ((is_any_closure(head_f)) && (is_safe_closure(head_f))) || + (is_simple_sequence(head_f))) /* was is_sequence? */ + { + bool follow = false; + s7_pointer slow_form = form, p = cdr(form); + for (; is_pair(p); p = cdr(p)) + { + if (is_unquoted_pair(sc, 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(head_f)) && (is_scope_safe(head_f)) && + (caar(p) == sc->lambda_symbol)) + { + s7_pointer argp, lbody; + body_t lresult; + + if (!is_pair(cdar(p))) /* (lambda . /) */ + return(unsafe_body); + argp = cadar(p); + lbody = cddar(p); + for (s7_pointer q = argp; is_pair(q); q = cdr(q)) + { + if (!is_symbol(car(q))) + return(unsafe_body); + add_symbol_to_small_symbol_set(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) {slow_form = cdr(slow_form); if (p == slow_form) return(unsafe_body);} + follow = (!follow); + } + return((is_null(p)) ? result : unsafe_body); + } + if ((is_safe_quote(sc, expr)) && + (is_proper_list_1(sc, cdr(form)))) + return(result); + + if (expr == sc->values_symbol) /* (values) is safe, as is (values x) if x is: (values (define...)) */ + { + if (is_null(cdr(form))) return(result); + if ((is_pair(cdr(form))) && (is_null(cddr(form)))) + return((is_pair(cadr(form))) ? min_body(result, form_is_safe(sc, func, cadr(form), false)) : result); + }} + else + if (expr == sc->quote_function) + return(((!is_pair(cdr(form))) || (!is_null(cddr(form)))) ? unsafe_body : very_safe_body); /* (#_quote . 1) or (#_quote 1 2) etc */ + + 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 forms = body; + body_t result = very_safe_body; + for (s7_pointer slow_body = body; is_pair(forms); forms = cdr(forms)) + { + if (is_pair(car(forms))) + { + result = min_body(result, form_is_safe(sc, func, car(forms), (at_end) && (is_null(cdr(forms))))); + if (result == unsafe_body) return(unsafe_body); + } + if (forms != body) /* checking for cycles -- this can happen (t101-1.scm) */ + { + if (follow) {slow_body = cdr(slow_body); if (forms == slow_body) return(unsafe_body);} + follow = (!follow); + }} + return((is_null(forms)) ? result : unsafe_body); +} + +static body_t wrapped_body_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer body, bool at_end) +{ + body_t result; + begin_small_symbol_set(sc); + result = body_is_safe(sc, func, body, at_end); + end_small_symbol_set(sc); + return(result); +} + +static bool tree_has_definer_or_binder(s7_scheme *sc, s7_pointer tree) +{ + for (s7_pointer p = tree; is_pair(p); p = cdr(p)) + if (tree_has_definer_or_binder(sc, car(p))) + return(true); + return((is_symbol(tree)) && + (is_definer_or_binder(tree))); +} + +#define rec_test_clause(p) opt2_pair(p) +#define rec_done_clause(p) opt1_pair(p) +#define rec_call_clause(p) opt3_pair(p) +#define rec_set_test_clause(p, c) set_opt2_pair(p, T_Pair(c)) /* these check T_Lst in set_opt2_pair, but here we want pairs */ +#define rec_set_done_clause(p, c) set_opt1_pair(p, T_Pair(c)) +#define rec_set_call_clause(p, c) set_opt3_pair(p, T_Pair(c)) + +static bool check_recur_if_and_cond(s7_scheme *sc, const s7_pointer name, int32_t pars, s7_pointer args, s7_pointer body) +{ + const bool if_case = car(body) == sc->if_symbol; + const s7_pointer test = (if_case) ? cadr(body) : caadr(body); /* (if test...) or (cond ((test...))) */ + /* if ((S7_DEBUGGING) && ((pars < 1) || (pars > 3))) fprintf(stderr, "%s[%d]: pars: %d\n", __func__, __LINE__, pars); */ + if (is_fxable(sc, test)) /* pars prechecked to be 1 <= pars <= 3 */ + { + const s7_pointer true_p = (if_case) ? caddr(body) : cadr(cadr(body)); + const s7_pointer false_p = (if_case) ? cadddr(body) : cadr(caddr(body)); + int true_case = -1; + if ((!if_case) && + ((!is_proper_list_2(sc, cadr(body))) || /* if !if_case, we want (cond (a b) (else|#t c)) */ + (!is_proper_list_2(sc, caddr(body))))) + return(false); + if ((is_fxable(sc, true_p)) && (is_proper_list_3(sc, false_p)) && (is_h_optimized(false_p))) /* the c-op -- true_p is done*/ + true_case = 0; + else + if ((is_fxable(sc, false_p)) && (is_proper_list_3(sc, true_p)) && (is_h_optimized(true_p))) /* true_p is call */ + true_case = 1; + if (true_case >= 0) /* (if expr z (op (name x) (name y))) or (if expr (op (name...)...) z */ + { + const bool true_quits = (true_case == 0); + const s7_pointer calls = true_quits ? cdr(false_p) : cdr(true_p); + const s7_pointer call1 = car(calls); + const s7_pointer call2 = cadr(calls); + bool call1_fxable; + + if ((((pars == 1) && (is_proper_list_2(sc, call1)) && (is_proper_list_2(sc, call2))) || + ((pars == 2) && (is_proper_list_3(sc, call1)) && (is_proper_list_3(sc, call2))) || + ((pars == 3) && (is_proper_list_4(sc, call1)) && (is_proper_list_4(sc, call2)))) && + (car(call1) == name) && (car(call2) == name) && + (is_fxable(sc, cadr(call1))) && (is_fxable(sc, cadr(call2))) && + ((pars == 1) || ((is_fxable(sc, caddr(call1))) && (is_fxable(sc, caddr(call2))))) && + ((pars <= 2) || ((is_fxable(sc, cadddr(call1))) && (is_fxable(sc, cadddr(call2)))))) + { + rec_set_test_clause(body, (if_case) ? cdr(body) : cadr(body)); + rec_set_done_clause(body, (true_quits) ? ((if_case) ? cddr(body) : cdadr(body)) : ((if_case) ? cdddr(body) : cdaddr(body))); + rec_set_call_clause(body, car((true_quits) ? ((if_case) ? cdddr(body) : cdaddr(body)) : ((if_case) ? cddr(body) : cdadr(body)))); + if (true_quits) set_true_is_done(body); + set_safe_optimize_op(body, (pars == 1) ? OP_RECUR_IF_A_A_opLA_LAq : + ((pars == 2) ? OP_RECUR_IF_A_A_opL2A_L2Aq : OP_RECUR_IF_A_A_opL3A_L3Aq)); + fx_annotate_args(sc, cdr(call1), args); + fx_annotate_args(sc, cdr(call2), args); + fx_annotate_arg(sc, rec_test_clause(body), args); + fx_annotate_arg(sc, rec_done_clause(body), args); + fx_tree(sc, cdr(body), car(args), (pars >= 2) ? cadr(args) : NULL, (pars == 3) ? caddr(args) : NULL, false); + return(true); + } + + call1_fxable = is_fxable(sc, call1); + if (((call1_fxable) && + (((pars == 1) && (is_proper_list_2(sc, call2))) || + ((pars == 2) && (is_proper_list_3(sc, call2))) || + ((pars == 3) && (is_proper_list_4(sc, call2)))) && + (car(call2) == name) && (is_fxable(sc, cadr(call2))) && + ((pars == 1) || (is_fxable(sc, caddr(call2)))) && + ((pars <= 2) || (is_fxable(sc, cadddr(call2))))) || + ((is_fxable(sc, call2)) && + (((pars == 1) && (is_proper_list_2(sc, call1))) || + ((pars == 2) && (is_proper_list_3(sc, call1))) || + ((pars == 3) && (is_proper_list_4(sc, call1)))) && + (car(call1) == name) && (is_fxable(sc, cadr(call1))) && + ((pars == 1) || (is_fxable(sc, caddr(call1)))) && + ((pars <= 2) || (is_fxable(sc, cadddr(call1)))))) + { + rec_set_test_clause(body, (if_case) ? cdr(body) : cadr(body)); + rec_set_done_clause(body, (true_quits) ? ((if_case) ? cddr(body) : cdadr(body)) : ((if_case) ? cdddr(body) : cdaddr(body))); + rec_set_call_clause(body, car((true_quits) ? ((if_case) ? cdddr(body) : cdaddr(body)) : ((if_case) ? cddr(body) : cdadr(body)))); + rec_set_call_clause(rec_call_clause(body), (call1_fxable) ? caddr(rec_call_clause(body)) : cadr(rec_call_clause(body))); + if (call1_fxable) set_a_is_cadr(rec_call_clause(body)); + if (true_quits) set_true_is_done(body); + set_safe_optimize_op(body, (pars == 1) ? OP_RECUR_IF_A_A_opA_LAq : + ((pars == 2) ? OP_RECUR_IF_A_A_opA_L2Aq : OP_RECUR_IF_A_A_opA_L3Aq)); + fx_annotate_arg(sc, (call1_fxable) ? calls : cdr(calls), args); /* call1 == car(calls) */ + fx_annotate_args(sc, (call1_fxable) ? cdr(call2) : cdr(call1), args); + fx_annotate_arg(sc, rec_test_clause(body), args); + fx_annotate_arg(sc, rec_done_clause(body), args); + fx_tree(sc, cdr(body), car(args), (pars >= 2) ? cadr(args) : NULL, (pars == 3) ? caddr(args) : NULL, false); + return(true); + }}} + return(false); +} + +static bool check_recur_if(s7_scheme *sc, const s7_pointer name, int32_t pars, s7_pointer args, s7_pointer body) +{ + const s7_pointer test = cadr(body); + if (is_fxable(sc, test)) /* if_(A)... */ + { + const s7_pointer obody = cddr(body); + s7_pointer call = NULL; + const s7_pointer true_p = car(obody); /* if_a_(A)... */ + const s7_pointer false_p = cadr(obody); /* if_a_a_(A) */ + + if ((pars <= 3) && + (is_fxable(sc, true_p)) && + (is_proper_list_4(sc, false_p))) + { + if (car(false_p) == sc->if_symbol) /* if_a_a_(if...) */ + { + const s7_pointer test2 = cadr(false_p); + const s7_pointer true2 = caddr(false_p); + const s7_pointer false2 = cadddr(false_p); + if ((is_fxable(sc, test2)) && + (is_proper_list_3(sc, false2)) && /* opa_l2aq or opl2a_l2aq */ + (is_h_optimized(false2))) /* the c-op */ + { + const s7_pointer la1 = cadr(false2); + const s7_pointer la2 = caddr(false2); + if ((is_fxable(sc, true2)) && + (((pars == 1) && (is_proper_list_2(sc, la1)) && (is_proper_list_2(sc, la2))) || + ((pars == 2) && (is_proper_list_3(sc, la1)) && (is_proper_list_3(sc, la2))) || + ((pars == 3) && (is_proper_list_4(sc, la1)) && (is_proper_list_4(sc, la2)))) && + (car(la1) == name) && (car(la2) == name) && + (is_fxable(sc, cadr(la1))) && (is_fxable(sc, cadr(la2))) && + ((pars == 1) || ((is_fxable(sc, caddr(la1))) && (is_fxable(sc, caddr(la2))))) && + ((pars <= 2) || ((is_fxable(sc, cadddr(la1))) && (is_fxable(sc, cadddr(la2)))))) + { + set_safe_optimize_op(body, (pars == 1) ? OP_RECUR_IF_A_A_IF_A_A_opLA_LAq : + ((pars == 2) ? OP_RECUR_IF_A_A_IF_A_A_opL2A_L2Aq : OP_RECUR_IF_A_A_IF_A_A_opL3A_L3Aq)); + 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), (pars >= 2) ? cadr(args) : NULL, (pars == 3) ? caddr(args) : NULL, false); + + rec_set_done_clause(body, cdr(false_p)); /* opt1 */ + rec_set_test_clause(body, cdr(body)); /* opt2 */ + rec_set_call_clause(body, false2); /* opt3 */ + rec_set_call_clause(false2, cdr(la2)); + + return(true); + } + if ((pars == 2) && (is_fxable(sc, cadr(false2))) && + (is_proper_list_3(sc, true2)) && (car(true2) == name) && (is_fxable(sc, cadr(true2))) && (is_fxable(sc, caddr(true2))) && + (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_IF_A_A_IF_A_L2A_opA_L2Aq); + 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_l2a_op(A).. */ + fx_annotate_args(sc, cdr(la2), args); /* if_a_a_if_a_l2a_opa_l(AA)q */ + fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); + rec_set_call_clause(body, false2); + rec_set_call_clause(false2, la2); + rec_set_test_clause(body, cdr(body)); + rec_set_done_clause(body, cddr(body)); + rec_set_done_clause(cdr(body), cdr(cadddr(body))); + return(true); + }}} + + if (car(false_p) == sc->and_symbol) + { + const s7_pointer a1 = cadr(false_p); + const s7_pointer a2 = caddr(false_p); + const s7_pointer 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_L2A_L2A); + 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_l2a_l(AA) */ + fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); + rec_set_call_clause(body, false_p); + return(true); + }}} + + /* this is ok, but no cond */ + 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)))) + call = false_p; /* if_a_a_call */ + 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)))) + call = true_p; /* if_a_call_a */ + + if ((call) && (pars == 1) && (is_pair(cdddr(call))) && (is_null(cddddr(call)))) /* 3 args */ + { + const s7_pointer la1 = cadr(call); + const s7_pointer la2 = caddr(call); + const s7_pointer la3 = cadddr(call); + 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)))) + { + set_safe_optimize_op(body, OP_RECUR_IF_A_A_opLA_LA_LAq); /* these two need cond? */ + fx_annotate_arg(sc, cdr(la1), args); + } + else + if (is_fxable(sc, la1)) + { + set_safe_optimize_op(body, OP_RECUR_IF_A_A_opA_LA_LAq); + fx_annotate_arg(sc, cdr(call), args); + } + else return(false); + fx_annotate_arg(sc, cdr(body), args); /* test */ + if (call == cadddr(body)) + { + set_true_is_done(body); + fx_annotate_arg(sc, cddr(body), args); /* result */ + } + else fx_annotate_arg(sc, cdddr(body), args); + fx_annotate_arg(sc, cdr(la2), args); /* call args 2 and 3 */ + fx_annotate_arg(sc, cdr(la3), args); + fx_tree(sc, cdr(body), car(args), NULL, NULL, false); + rec_set_call_clause(body, call); + rec_set_call_clause(call, la3); + rec_set_test_clause(body, cdr(body)); + rec_set_done_clause(body, (true_is_done(body)) ? cddr(body) : cdddr(body)); + return(true); + }}} /* if (is_fxable(sc, test)) at top */ + return(false); +} + +static bool check_recur(s7_scheme *sc, s7_pointer name, int32_t pars, s7_pointer args, s7_pointer body) +{ + /* if (proper_list_length(args) != pars) return(false); */ + if ((((car(body) == sc->if_symbol) && (proper_list_length(body) == 4)) || /* (if a a opla) */ + ((car(body) == sc->cond_symbol) && (proper_list_length(body) == 3) && + ((caaddr(body) == sc->else_symbol) || (caaddr(body) == sc->T)))) && /* (cond ((a a)) (else|#t opla)) */ + (pars > 0) && (pars <= 3) && + (check_recur_if_and_cond(sc, name, pars, args, body))) + return(true); + + if ((car(body) == sc->if_symbol) && + (proper_list_length(body) == 4)) + return(check_recur_if(sc, name, pars, args, body)); + + if ((car(body) == sc->and_symbol) && + (pars == 2) && + (proper_list_length(body) == 3) && + (proper_list_length(caddr(body)) == 4) && + (caaddr(body) == sc->or_symbol) && + (is_fxable(sc, cadr(body)))) + { + const s7_pointer or_p = caddr(body); + const s7_pointer la1 = caddr(or_p); + const s7_pointer 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_L2A_L2A); + 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); + rec_set_call_clause(body, or_p); + return(true); + }} + + if (car(body) == sc->cond_symbol) + { + const s7_pointer clause = cadr(body); + s7_pointer 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); + const s7_int 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->T) || + ((car(la_clause) == sc->else_symbol) && (is_global(sc->else_symbol)))) && + (is_pair(cadr(la_clause)))) + { + la_clause = cadr(la_clause); /* (c_op arg (recur par)) or (c_op (recur) (recur)) or (op|l a l2a) */ + if (is_proper_list_2(sc, cdr(la_clause))) + { + if (is_h_optimized(la_clause)) + { + if ((is_fxable(sc, cadr(la_clause))) && + (len == 4) && (pars == 2) && + (is_proper_list_3(sc, cadr(clause2))) && + (caadr(clause2) == name)) + { + const s7_pointer la = caddr(la_clause); + if ((is_pair(la)) && (car(la) == name) && (is_pair(cdr(la))) && (is_fxable(sc, cadr(la))) && + (is_pair(cddr(la))) && (is_fxable(sc, caddr(la))) && (is_null(cdddr(la)))) + { + const s7_pointer l2a = cadr(clause2); + if ((is_fxable(sc, cadr(l2a))) && /* args to first l2a */ + (is_fxable(sc, caddr(l2a)))) + { + set_safe_optimize_op(body, OP_RECUR_IF_A_A_IF_A_L2A_opA_L2Aq); + fx_annotate_arg(sc, clause2, args); + fx_annotate_args(sc, cdr(l2a), args); + rec_set_call_clause(body, la_clause); + rec_set_test_clause(body, cadr(body)); + rec_set_done_clause(body, cdadr(body)); + rec_set_done_clause(cdr(body), caddr(body)); + } + 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), cadr(args), NULL, false); + rec_set_call_clause(la_clause, la); + return(true); + }} + else + { + if ((len == 4) && + (is_fxable(sc, cadr(clause2)))) + { + const s7_pointer la1 = cadr(la_clause); + const s7_pointer la2 = caddr(la_clause); + bool happy = false; + /* following 9 lines are copied from check_recur_if 77378 (len=body length) -- combine? */ + if ((((pars == 1) && (is_proper_list_2(sc, la1)) && (is_proper_list_2(sc, la2))) || + ((pars == 2) && (is_proper_list_3(sc, la1)) && (is_proper_list_3(sc, la2))) || + ((pars == 3) && (is_proper_list_4(sc, la1)) && (is_proper_list_4(sc, la2)))) && + (car(la1) == name) && (car(la2) == name) && + (is_fxable(sc, cadr(la1))) && (is_fxable(sc, cadr(la2))) && + ((pars == 1) || ((is_fxable(sc, caddr(la1))) && (is_fxable(sc, caddr(la2))))) && + ((pars <= 2) || ((is_fxable(sc, cadddr(la1))) && (is_fxable(sc, cadddr(la2)))))) + { + set_safe_optimize_op(body, (pars == 1) ? OP_RECUR_IF_A_A_IF_A_A_opLA_LAq : + ((pars == 2) ? OP_RECUR_IF_A_A_IF_A_A_opL2A_L2Aq : OP_RECUR_IF_A_A_IF_A_A_opL3A_L3Aq)); + fx_annotate_args(sc, cdr(la1), args); + rec_set_done_clause(body, caddr(body)); /* opt1 -- not "done" */ + rec_set_test_clause(body, cadr(body)); /* opt2 */ + happy = true; + } + else + if ((pars == 2) && (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_A_opA_L2Aq); /* see if_a_a_if_a_l2a_opa_l2a, first l2a->a */ + fx_annotate_arg(sc, cdr(la_clause), args); + happy = true; + } + if (happy) + { + 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), (pars > 1) ? cadr(args) : NULL, (pars == 3) ? caddr(args) : NULL, false); + rec_set_call_clause(body, la_clause); /* opt3 */ + rec_set_call_clause(la_clause, cdr(la2)); + return(true); + }}}} + else + { + if (clause2) + { + const s7_pointer l2a = cadr(clause2); + if ((pars == 2) && (len == 4) && + (is_proper_list_3(sc, l2a)) && (car(l2a) == name) && (is_fxable(sc, cadr(l2a))) && (is_fxable(sc, caddr(l2a)))) + { + const s7_pointer la1 = cadr(la_clause); + const s7_pointer 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_L2A_LopA_L2Aq); + fx_annotate_args(sc, clause, args); + fx_annotate_arg(sc, clause2, args); + fx_annotate_args(sc, cdr(l2a), 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); + rec_set_call_clause(body, la_clause); + rec_set_call_clause(la_clause, cdr(la2)); + return(true); + }}}}}}}} + return(false); +} + +static bool check_tc_when(s7_scheme *sc, const s7_pointer name, int32_t pars, s7_pointer args, s7_pointer body) +{ + const s7_pointer test_expr = cadr(body); /* car(body) == sc->when_symbol or sc->unless_symbol */ + 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)) && /* i.e. p is the last form in the when body */ + (is_pair(car(p))) && + (caar(p) == name)) + { + const s7_pointer l2a = car(p); + set_opt3_pair(body, p); + if ((is_pair(cdr(l2a))) && (is_fxable(sc, cadr(l2a)))) + { + if (is_null(cddr(l2a))) + { + if (pars != 1) return(false); + set_safe_optimize_op(body, OP_TC_WHEN_LA); + } + else + if (is_fxable(sc, caddr(l2a))) + { + if (is_null(cdddr(l2a))) + { + if (pars != 2) return(false); + set_safe_optimize_op(body, OP_TC_WHEN_L2A); + } + else + if ((pars == 3) && (is_fxable(sc, cadddr(l2a))) && (is_null(cddddr(l2a)))) + set_safe_optimize_op(body, OP_TC_WHEN_L3A); + else return(false); + } + if (car(body) == sc->unless_symbol) set_true_is_done(body); + fx_annotate_arg(sc, cdr(body), args); + for (s7_pointer p1 = cddr(body); is_pair(cdr(p1)); p1 = cdr(p1)) + fx_annotate_arg(sc, p1, args); + fx_annotate_args(sc, cdr(l2a), args); + fx_tree(sc, cdr(body), car(args), (pars > 1) ? cadr(args) : NULL, (pars > 2) ? caddr(args) : NULL, false); + return(true); + }}} + return(false); +} + +static bool check_tc_case(s7_scheme *sc, s7_pointer name, s7_pointer arg_names, s7_pointer body) +{ + /* pars == 1|2|3, opt1_any(clause) = key, has_tc(arg) = is tc call, opt2_any(clause) = result: has_tc(la arg) has_fx(val) or ((...)...) */ + /* it might be useful to add int keys and no-else-clause */ + s7_pointer clauses; + s7_int len; + const s7_int pars = proper_list_length(arg_names); + 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))) /* one key */ + { + if (!is_simple(caar(clause))) /* || (is_t_integer(caar(clause))))) need eqv here for ints */ + return(false); + set_opt1_any(clauses, caar(clause)); /* save clause key as opt1_any */ + } + 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, arg_names); + set_opt2_any(clauses, result); /* fx'd result expr is opt2_any */ + } + else + { + const s7_int local_pars = proper_list_length(cdar(result)); + if ((caar(result) == name) && + (((pars == 1) && (local_pars == 1)) || ((pars == 2) && (local_pars == 2)) || ((pars == 3) && (local_pars == 3))) && + (is_fxable(sc, cadar(result))) && + ((pars == 1) || (is_fxable(sc, caddar(result)))) && + ((pars <= 2) || (is_fxable(sc, car(cdddar(result)))))) + { + set_has_tc(car(result)); + set_opt2_any(clauses, car(result)); + fx_annotate_args(sc, cdar(result), arg_names); + } + 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, (pars == 1) ? OP_TC_CASE_LA : ((pars == 2) ? OP_TC_CASE_L2A : OP_TC_CASE_L3A)); + set_opt3_arglen(cdr(body), len); + fx_annotate_arg(sc, cdr(body), arg_names); + fx_tree(sc, cdr(body), car(arg_names), (pars == 1) ? NULL : cadr(arg_names), (pars <= 2) ? NULL : caddr(arg_names), false); /* check_tc limits pars to <= 3 */ + if (results_fxable) set_optimized(body); + return(results_fxable); +} + +static bool check_tc_cond_n(s7_scheme *sc, const s7_pointer name, int32_t pars, s7_pointer args, s7_pointer cond_form) +{ + bool all_fxable = true; + for (s7_pointer p = cdr(cond_form); is_pair(p); p = cdr(p)) + { + const 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->T) && + ((car(clause) != sc->else_symbol) || (!is_global(sc->else_symbol)))) || + ((tree_count(sc, name, clause, 0) == 1) && + (name != caadr(clause)))) + return(false); + result = cadr(clause); + if ((is_pair(result)) && + (car(result) == name)) /* result is recursive call */ + { + s7_int i = 0; + for (s7_pointer arg = cdr(result); is_pair(arg); i++, arg = cdr(arg)) + if (!is_fxable(sc, car(arg))) + return(false); + if (i != pars) + return(false); + }} + else return(false); + } + set_optimize_op(cond_form, OP_TC_COND_N); /* body=cond_form?? */ + set_opt3_arglen(cdr(cond_form), pars); /* same */ + for (s7_pointer p = cdr(cond_form); is_pair(p); p = cdr(p)) + { + const s7_pointer clause = car(p); + const s7_pointer result = cadr(clause); + fx_annotate_arg(sc, clause, args); + if ((is_pair(result)) && (car(result) == name)) /* pars = args checked above */ + { + 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; + if (pars > 0) + fx_tree(sc, clause, car(args), (pars > 1) ? cadr(args) : NULL, (pars > 2) ? caddr(args) : NULL, pars > 3); + } + if (all_fxable) set_optimized(cond_form); + return(all_fxable); +} + +static bool check_tc_cond(s7_scheme *sc, s7_pointer name, int32_t pars, s7_pointer args, s7_pointer body) +{ + s7_pointer p = cdr(body); + const s7_pointer clause1 = car(p); + const s7_int names = tree_count(sc, name, body, 0); + const s7_int body_len = proper_list_length(body); + + if ((!is_proper_list_2(sc, clause1)) || (!is_fxable(sc, car(clause1)))) /* cond_a... */ + return(false); + + p = cdr(p); + if ((pars < 4) && (names == 1) && (body_len == 3)) + { + if (((caar(p) == sc->T) || ((caar(p) == sc->else_symbol) && (is_global(sc->else_symbol))))) + { /* body len=3, (cond clause1 else */ + const s7_pointer else_clause = cdar(p); + if (tree_count(sc, name, body, 0) != 1) return(false); + if (is_proper_list_1(sc, else_clause)) + { + 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))) && + (((pars == 1) && (is_null(cddr(la)))) || + ((pars == 2) && (is_pair(cddr(la))) && (is_null(cdddr(la))) && (is_fxable(sc, caddr(la)))) || + ((pars == 3) && (is_pair(cddr(la))) && (is_pair(cdddr(la))) && (is_null(cdr(cdddr(la)))) && + (is_fxable(sc, caddr(la))) && (is_fxable(sc, cadddr(la)))))) + { + const bool zs_fxable = is_fxable(sc, cadr(clause1)); + set_optimize_op(body, (pars == 1) ? OP_TC_IF_A_Z_LA : ((pars == 2) ? OP_TC_IF_A_Z_L2A : OP_TC_IF_A_Z_L3A)); + if (zs_fxable) fx_annotate_arg(sc, cdr(clause1), args); + fx_annotate_args(sc, cdr(la), args); + fx_tree(sc, cdr(body), car(args), (pars < 2) ? NULL : cadr(args), (pars < 3) ? NULL : caddr(args), false); + if (zs_fxable) set_optimized(body); + rec_set_test_clause(body, cadr(body)); + rec_set_done_clause(body, cdadr(body)); + rec_set_call_clause(body, cdadr(caddr(body))); + set_true_is_done(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))) && + (((pars == 1) && (is_null(cddr(la)))) || + ((pars == 2) && (is_pair(cddr(la))) && (is_null(cdddr(la))) && (is_fxable(sc, caddr(la)))) || + ((pars == 3) && (is_pair(cddr(la))) && (is_pair(cdddr(la))) && (is_null(cdr(cdddr(la)))) && + (is_fxable(sc, caddr(la))) && (is_fxable(sc, cadddr(la)))))) + { + const bool zs_fxable = is_fxable(sc, car(else_clause)); + set_optimize_op(body, (pars == 1) ? OP_TC_IF_A_Z_LA : ((pars == 2) ? OP_TC_IF_A_Z_L2A : OP_TC_IF_A_Z_L3A)); + if (zs_fxable) fx_annotate_arg(sc, else_clause, args); + fx_annotate_args(sc, cdr(la), args); + fx_tree(sc, cdr(body), car(args), (pars < 2) ? NULL : cadr(args), (pars < 3) ? NULL : caddr(args), false); + if (zs_fxable) set_optimized(body); + rec_set_test_clause(body, cadr(body)); + rec_set_done_clause(body, cdaddr(body)); + rec_set_call_clause(body, cdadr(cadr(body))); + return(zs_fxable); + }}}} + return(false); + }} /* end body len=3, (cond clause1 else */ + + if ((pars < 4) && (body_len == 4)) + { + const s7_pointer clause2 = car(p); + if ((is_proper_list_2(sc, clause2)) && + (is_fxable(sc, car(clause2)))) + { + const s7_pointer else_p = cdr(p); + const s7_pointer else_clause = car(else_p); + + if ((is_proper_list_2(sc, else_clause)) && + ((car(else_clause) == sc->T) || ((car(else_clause) == sc->else_symbol) && (is_global(sc->else_symbol))))) + { + bool zs_fxable = true; + if ((pars == 2) && /* ...l2a_l2a 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_L2A_L2A); + 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)); /* done_clause?? */ + if (zs_fxable) set_optimized(body); + return(zs_fxable); + } + + if ((names == 1) && /* needed to filter out cond_a_a_a_l2a_opa_l2a */ + + (((is_pair(cadr(else_clause))) && (caadr(else_clause) == name) && + (is_pair(cdadr(else_clause))) && (is_fxable(sc, cadadr(else_clause))) && + (((pars == 1) && (is_null(cddadr(else_clause)))) || + ((pars == 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))) && + (((pars == 1) && (is_null(cddadr(clause2)))) || + ((pars == 2) && (is_pair(cddadr(clause2))) && (is_fxable(sc, caddadr(clause2))) && (is_null(cdddr(cadr(clause2))))))))) + { + s7_pointer test2 = clause2; + s7_pointer la_test = else_clause; + if (pars == 1) + { + if ((is_pair(cadr(else_clause))) && (caadr(else_clause) == name)) + set_optimize_op(body, OP_TC_IF_A_Z_IF_A_Z_LA); + else + { + set_optimize_op(body, OP_TC_IF_A_Z_IF_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_IF_A_Z_IF_A_Z_L2A); + } + else + { + set_optimize_op(body, OP_TC_IF_A_Z_IF_A_L2A_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), (pars == 2) ? cadr(args) : NULL, NULL, false); + if (zs_fxable) set_optimized(body); + return(zs_fxable); + }}}} + return(check_tc_cond_n(sc, name, pars, args, body)); +} + +static bool check_tc_let(s7_scheme *sc, const s7_pointer name, int32_t pars, s7_pointer args, s7_pointer body) +{ + const s7_pointer let_body = caddr(body); /* body: (let ((x (- y 1))) (if (<= x 0) 0 (f1 (- x 1)))) etc */ + if (((pars == 2) && ((car(let_body) == sc->if_symbol) || (car(let_body) == sc->when_symbol) || (car(let_body) == sc->unless_symbol))) || + ((pars == 1) && (car(let_body) == sc->if_symbol))) + { + const 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)))) + { + const s7_pointer l2a = cadddr(let_body); + if ((is_pair(l2a)) && /* else caddr is l2a and cadddr is z */ + (car(l2a) == name) && + (((pars == 1) && (is_proper_list_2(sc, l2a))) || + ((pars == 2) && (is_proper_list_3(sc, l2a)) && (is_safe_fxable(sc, caddr(l2a))))) && + (is_fxable(sc, cadr(l2a)))) + { + bool z_fxable; + set_optimize_op(body, (pars == 1) ? OP_TC_LET_IF_A_Z_LA : OP_TC_LET_IF_A_Z_L2A); + fx_annotate_arg(sc, cdaadr(body), args); /* let var binding, caadr: (x (- y 1)) etc */ + fx_tree(sc, cdaadr(body), car(args), (pars == 1) ? NULL : cadr(args), NULL, false); /* these are references to l2a args, applied to the let var binding */ + fx_annotate_arg(sc, cdr(let_body), args); /* test_expr */ + fx_annotate_args(sc, cdr(l2a), args); + z_fxable = is_fxable(sc, caddr(let_body)); + if (z_fxable) fx_annotate_arg(sc, cddr(let_body), args); + fx_tree(sc, cdr(let_body), car(caadr(body)), NULL, NULL, false); + fx_tree_outer(sc, cdr(let_body), car(args), (pars == 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)) + { + const s7_pointer l2a = car(p); + if ((is_fxable(sc, cadr(l2a))) && + (is_safe_fxable(sc, caddr(l2a)))) + { + set_optimize_op(body, OP_TC_LET_WHEN_L2A); + fx_annotate_arg(sc, cdaadr(body), args); /* outer var */ + fx_annotate_arg(sc, cdr(let_body), args); /* test */ + for (s7_pointer p1 = cddr(let_body); is_pair(cdr(p1)); p1 = cdr(p1)) + fx_annotate_arg(sc, p1, args); + fx_annotate_args(sc, cdr(l2a), 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) /* pars=#loop pars, args=names thereof (arglist) */ + { + s7_pointer var_name; + bool all_fxable = true; + for (s7_pointer p = cdr(let_body); is_pair(p); p = cdr(p)) + { + const 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->T) && + ((car(clause) != sc->else_symbol) || (!is_global(sc->else_symbol)))) + return(false); + result = cadr(clause); + if ((is_pair(result)) && + (car(result) == name)) /* result is recursive call */ + { + s7_int i = 0; + for (s7_pointer arg = cdr(result); is_pair(arg); i++, arg = cdr(arg)) + if (!is_fxable(sc, car(arg))) + return(false); + if (i != pars) + return(false); + }} + else return(false); + } + /* cond form looks ok, body here is the let form */ + set_optimize_op(body, OP_TC_LET_COND); + set_opt3_arglen(cdr(body), pars); + fx_annotate_arg(sc, cdaadr(body), args); /* let var */ + if (pars > 0) + fx_tree(sc, cdaadr(body), car(args), (pars > 1) ? cadr(args) : NULL, (pars > 2) ? caddr(args) : NULL, pars > 3); + var_name = caaadr(body); + for (s7_pointer p = cdr(let_body); is_pair(p); p = cdr(p)) + { + const s7_pointer clause = car(p); + const s7_pointer 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 (pars > 0) + fx_tree_outer(sc, clause, car(args), (pars > 1) ? cadr(args) : NULL, (pars > 2) ? caddr(args) : NULL, pars > 3); + } + if (all_fxable) set_optimized(body); + return(all_fxable); + } + return(false); +} + +/* tc lets can be let* or let+pars 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 pars, s7_pointer args, s7_pointer body) +{ + if (!is_pair(body)) return(false); + + if (((pars == 1) || (pars == 2) || (pars == 3)) && + ((car(body) == sc->and_symbol) || (car(body) == sc->or_symbol)) && + (is_pair(cdr(body))) && + (is_fxable(sc, cadr(body))) && + (is_pair(cddr(body)))) + { + const 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)))) + { + const s7_int len = proper_list_length(orx); + if ((len == 3) || + ((pars == 1) && (len == 4) && (tree_count(sc, name, orx, 0) == 1) && (is_fxable(sc, caddr(orx))))) /* the ...or|and_a_a_la case below? */ + { + const s7_pointer tc = (len == 3) ? caddr(orx) : cadddr(orx); + if ((is_pair(tc)) && + (car(tc) == name) && + (is_pair(cdr(tc))) && + (is_fxable(sc, cadr(tc))) && + (((pars == 1) && (is_null(cddr(tc)))) || + ((pars == 2) && (is_pair(cddr(tc))) && (is_null(cdddr(tc))) && (is_safe_fxable(sc, caddr(tc)))) || + ((pars == 3) && (is_pair(cddr(tc))) && (is_pair(cdddr(tc))) && (is_null(cddddr(tc))) && + (is_safe_fxable(sc, caddr(tc))) && (is_safe_fxable(sc, cadddr(tc)))))) + { + if (pars == 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 + if (pars == 2) + set_safe_optimize_op(body, (car(body) == sc->and_symbol) ? OP_TC_AND_A_OR_A_L2A : OP_TC_OR_A_AND_A_L2A); + else set_safe_optimize_op(body, (car(body) == sc->and_symbol) ? OP_TC_AND_A_OR_A_L3A : OP_TC_OR_A_AND_A_L3A); + 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), (pars == 1) ? NULL : cadr(args), (pars == 3) ? caddr(args) : NULL, false); + return(true); + }}} + else + { + if ((pars == 1) && + (car(body) == sc->or_symbol) && + (is_fxable(sc, orx)) && + (is_pair(cdddr(body))) && + (is_pair(cadddr(body)))) + { + const 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)))) + { + const 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 ((pars == 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)) + { + const bool z_first = ((is_pair(cadddr(orx))) && (car(cadddr(orx)) == name)); + const s7_pointer 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; + const s7_pointer 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 ((pars == 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)))) + { + const s7_pointer 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)))) + { + const 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 (((pars >= 1) && (pars <= 3)) && + (car(body) == sc->if_symbol) && + (proper_list_length(body) == 4)) + { + const s7_pointer test = cadr(body); + if (is_fxable(sc, test)) + { + const s7_pointer true_p = caddr(body); + const s7_pointer false_p = cadddr(body); + const s7_int true_len = proper_list_length(true_p); + const s7_int false_len = proper_list_length(false_p); + + fx_annotate_arg(sc, cdr(body), args); + + if (pars == 1) + { + if ((false_len == 2) && + (car(false_p) == name) && + (is_fxable(sc, true_p)) && (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 */ + rec_set_test_clause(body, cdr(body)); + rec_set_done_clause(body, cddr(body)); + rec_set_call_clause(body, cdar(cdddr(body))); + set_true_is_done(body); + 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, false_p)) && (is_fxable(sc, cadr(true_p)))) + { + set_optimize_op(body, OP_TC_IF_A_Z_LA); + fx_annotate_arg(sc, cdr(true_p), args); /* arg */ + rec_set_test_clause(body, cdr(body)); + rec_set_done_clause(body, cdddr(body)); + rec_set_call_clause(body, cdar(cddr(body))); + fx_annotate_arg(sc, cdddr(body), args); /* result */ + fx_tree(sc, cdr(body), car(args), NULL, NULL, false); + set_optimized(body); + return(true); + }} + + if (pars == 2) + { + if ((false_len == 3) && + (car(false_p) == name) && + (is_fxable(sc, cadr(false_p))) && + (is_fxable(sc, true_p)) && (is_safe_fxable(sc, caddr(false_p)))) + { + set_optimize_op(body, OP_TC_IF_A_Z_L2A); + fx_annotate_args(sc, cdr(false_p), args); + rec_set_test_clause(body, cdr(body)); + rec_set_done_clause(body, cddr(body)); /* body == code in op, if_true */ + rec_set_call_clause(body, cdar(cdddr(body))); /* la */ + set_true_is_done(body); + 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_fxable(sc, false_p)) && (is_safe_fxable(sc, caddr(true_p)))) + { + set_optimize_op(body, OP_TC_IF_A_Z_L2A); + fx_annotate_args(sc, cdr(true_p), args); + rec_set_test_clause(body, cdr(body)); + rec_set_done_clause(body, cdddr(body)); + rec_set_call_clause(body, cdar(cddr(body))); + fx_annotate_arg(sc, cdddr(body), args); + fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); + set_optimized(body); + return(true); + }} + + if (pars == 3) + { + if ((false_len == 4) && + (car(false_p) == name) && + (is_fxable(sc, true_p)) && (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); + rec_set_test_clause(body, cdr(body)); + rec_set_done_clause(body, cddr(body)); + rec_set_call_clause(body, cdar(cdddr(body))); + set_true_is_done(body); + 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, false_p)) && (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_Z_L3A); + fx_annotate_args(sc, cdr(true_p), args); + rec_set_test_clause(body, cdr(body)); + rec_set_done_clause(body, cdddr(body)); + rec_set_call_clause(body, cdar(cddr(body))); + 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)) + { + const s7_pointer in_test = cadr(false_p); + const s7_pointer in_true = caddr(false_p); + const s7_pointer in_false = cadddr(false_p); + if (is_fxable(sc, in_test)) + { + s7_pointer la = NULL, z = NULL; + 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) && ((pars == 3) || (!s7_tree_memq(sc, name, car(z))))) + { + if (((pars == 1) && (is_null(cddr(la)))) || + ((pars == 2) && (is_pair(cddr(la))) && (is_null(cdddr(la))) && (is_safe_fxable(sc, caddr(la)))) || + ((pars == 3) && + ((is_proper_list_4(sc, in_false)) || (is_proper_list_4(sc, in_true))) && + (is_safe_fxable(sc, caddr(la))) && (is_safe_fxable(sc, cadddr(la))) && + (((is_proper_list_4(sc, in_true)) && (car(in_true) == name) && + (is_fxable(sc, cadr(in_true))) && (is_safe_fxable(sc, caddr(in_true))) && (is_safe_fxable(sc, cadddr(in_true)))) || + (!s7_tree_memq(sc, name, in_true))))) + { + bool zs_fxable = true; + if (pars == 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 (pars == 2) + set_optimize_op(body, (la == in_false) ? OP_TC_IF_A_Z_IF_A_Z_L2A : OP_TC_IF_A_Z_IF_A_L2A_Z); + else + if (la == in_false) + set_optimize_op(body, ((is_pair(in_true)) && (car(in_true) == name)) ? OP_TC_IF_A_Z_IF_A_L3A_L3A : OP_TC_IF_A_Z_IF_A_Z_L3A); + else set_optimize_op(body, OP_TC_IF_A_Z_IF_A_L3A_Z); + + 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 (pars == 3) + { + if (optimize_op(body) != OP_TC_IF_A_Z_IF_A_L3A_Z) + fx_annotate_args(sc, cdr(in_false), args); + if (optimize_op(body) != OP_TC_IF_A_Z_IF_A_Z_L3A) + fx_annotate_args(sc, cdr(in_true), args); + } + if (optimize_op(body) != OP_TC_IF_A_Z_IF_A_L3A_L3A) + { + 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), (pars > 1) ? cadr(args) : NULL, (pars > 2) ? caddr(args) : NULL, false); + if (zs_fxable) set_optimized(body); + return(zs_fxable); + }}}} + + if ((pars == 2) && + (false_len == 3) && + (car(false_p) == sc->let_star_symbol)) + { + const s7_pointer letv = cadr(false_p); + s7_pointer letb; + if (!is_pair(letv)) return(false); + letb = caddr(false_p); + for (s7_pointer var = letv; is_pair(var); var = cdr(var)) + if (!is_fxable(sc, cadar(var))) + return(false); + if ((is_proper_list_4(sc, letb)) && + (car(letb) == sc->if_symbol) && + (is_fxable(sc, cadr(letb)))) + { + const s7_pointer l2a = cadddr(letb); + if ((car(l2a) == name) && + (is_proper_list_3(sc, l2a)) && + (is_fxable(sc, cadr(l2a))) && + (is_safe_fxable(sc, caddr(l2a)))) + { + bool zs_fxable; + set_safe_optimize_op(body, OP_TC_IF_A_Z_LET_IF_A_Z_L2A); + fx_annotate_args(sc, cdr(l2a), args); + zs_fxable = is_fxable(sc, caddr(letb)); + fx_annotate_args(sc, cdr(letb), args); + for (s7_pointer var = letv; is_pair(var); var = cdr(var)) + fx_annotate_arg(sc, cdar(var), 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(l2a), 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, pars, args, body)); + + /* cond */ + if (car(body) == sc->cond_symbol) + return(check_tc_cond(sc, name, pars, args, body)); + + /* case */ + if (((pars >= 1) && (pars <= 3)) && + (car(body) == sc->case_symbol) && + (is_pair(cdr(body))) && + (is_fxable(sc, cadr(body)))) + return(check_tc_case(sc, name, args, body)); + + /* when */ + if ((pars >= 1) && (pars <= 3) && + ((car(body) == sc->when_symbol) || (car(body) == sc->unless_symbol)) && + (is_fxable(sc, cadr(body)))) + return(check_tc_when(sc, name, pars, args, body)); + return(false); +} + +static void mark_fx_treeable(s7_scheme *sc, s7_pointer body) +{ /* it is possible to encounter a cyclic body here -- need s7test example! */ + if (is_pair(body)) /* slightly faster than the other way of writing this, checking treeable (to catch cyclic trees) slows us down by a lot! */ + { + if ((S7_DEBUGGING) && (s7_list_length(sc, body) == 0)) {fprintf(stderr, "body: %s\n", display(body)); abort();} + if (is_pair(car(body))) + { + set_is_fx_treeable(body); + mark_fx_treeable(sc, car(body)); + } + mark_fx_treeable(sc, cdr(body)); + } +} + +static void optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_pointer func, s7_pointer pars, s7_pointer body) +{ /* func is either sc->unused or a symbol */ + const s7_int len = s7_list_length(sc, body); + if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s %s %s\n", __func__, __LINE__, display(func), display(pars), display_truncated(body)); + if (len < 0) /* (define (hi) 1 . 2) */ + error_nr(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_pars; + + begin_small_symbol_set(sc); + for (p = pars; is_pair(p); p = cdr(p)) + add_symbol_to_small_symbol_set(sc, (is_symbol(car(p))) ? car(p) : caar(p)); + if (!is_null(p)) + add_symbol_to_small_symbol_set(sc, p); + sc->got_tc = false; + sc->not_tc = false; + sc->got_rec = false; + sc->rec_tc_args = -1; + /* I think cyclic code has already been caught in check_lambda et al */ + result = ((is_symbol(func)) && (symbol_is_in_small_symbol_set(sc, func))) ? unsafe_body : body_is_safe(sc, func, body, true); /* (define (f f)...) */ + end_small_symbol_set(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 (s7_pointer p1 = pars; is_pair(p1); p1 = cdr(p1)) + { + const s7_pointer par = car(p1); + if ((is_pair(par)) && /* has default value */ + (is_pair(cdr(par))) && /* is not a ridiculous improper list */ + ((is_symbol(cadr(par))) || /* if default value might involve eval in any way, it isn't simple */ + (is_unquoted_pair(sc, cadr(par))))) /* pair as default only ok if it is (quote ...) */ + { + happy = false; + if ((result > unsafe_body) && + (tree_has_definer_or_binder(sc, cadr(par)))) /* 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_big_symbol_set(sc, func)); + sc->temp1 = lst; + } + else lst = sc->nil; + + if (optimize(sc, body, 1, cleared_pars = collect_parameters(sc, pars, lst)) == opt_oops) + clear_all_optimizations(sc, body); + else + if (result >= recur_body) + { + int32_t npars; + mark_fx_treeable(sc, body); + if ((!unstarred_lambda) && (is_pair(cleared_pars))) + { + cleared_pars = proper_list_reverse_in_place(sc, cleared_pars); + /* we need pars in decl order below, else (e.g.) fx_o out-of-date because pars does not represent lambda pars (as in its let) */ + if (car(cleared_pars) == func) cleared_pars = cdr(cleared_pars); + } + else cleared_pars = pars; + for (npars = 0, p = pars; (is_pair(p)) && (!is_symbol_and_keyword(car(p))); npars++, p = cdr(p)); /* npars should not include a dotted (rest) arg */ + if ((is_null(p)) && + (npars > 0)) + { + fx_annotate_args(sc, body, cleared_pars); /* 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! */ + car(cleared_pars), + (npars > 1) ? cadr(cleared_pars) : NULL, + (npars > 2) ? caddr(cleared_pars) : NULL, + npars > 3); + } + if (((unstarred_lambda) || ((is_null(p)) && (npars == sc->rec_tc_args))) && + (is_null(cdr(body)))) + { /* (if #t|#f...) happens only rarely */ + if (sc->got_tc) + { + if (check_tc(sc, func, npars, cleared_pars, 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, npars, cleared_pars, car(body)))) + set_safe_closure_body(body); + }} + clear_big_symbol_set(sc); + if (is_symbol(func)) sc->temp1 = sc->unused; + 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))) /* this can happen (3 examples in s7test) */ + error_nr(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) */ + syntax_error_nr(sc, "lambda: no arguments? ~A", 24, form); + + body = cdr(code); + if (!is_pair(body)) /* (lambda #f) */ + syntax_error_nr(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, sc->code); + + /* 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 + */ + clear_big_symbol_set(sc); + if ((opt) || + (stack_top_op(sc) == OP_DEFINE1) || + (((sc->stack_end - sc->stack_start) > 4) && + (stack_top4_op(sc) == 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); + } + clear_big_symbol_set(sc); + 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 = 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 = (int32_t)((intptr_t)opt3_any(cdr(code))); + return(make_closure_gc_checked(sc, cadr(code), cddr(code), T_CLOSURE | ((arity < 0) ? T_COPY_ARGS : 0), arity)); +} + +static void check_lambda_star(s7_scheme *sc) +{ + const s7_pointer code = cdr(sc->code); + if ((sc->safety > no_safety) && (tree_is_cyclic(sc, sc->code))) + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "lambda*: body is cyclic: ~S", 27), sc->code)); + if ((!is_pair(code)) || + (!is_pair(cdr(code)))) /* (lambda*) or (lambda* #f) */ + syntax_error_nr(sc, "lambda*: no arguments or no body? ~A", 36, sc->code); + + set_car(code, check_lambda_star_args(sc, car(code), NULL, sc->code)); + + clear_big_symbol_set(sc); + if ((sc->safety > no_safety) || + (stack_top_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)); + clear_big_symbol_set(sc); + pair_set_syntax_op(sc->code, OP_LAMBDA_STAR_UNCHECKED); + sc->code = code; +} + + +/* -------------------------------- case -------------------------------- */ +static inline bool is_undefined_feed_to(s7_scheme *sc, const 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 bool is_all_fxable(s7_scheme *sc, s7_pointer exprs) +{ + for (s7_pointer p = exprs; is_pair(p); p = cdr(p)) + if (!is_fxable(sc, car(p))) + return(false); + return(true); +} + +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, use_fx = true; + int32_t key_type = T_FREE; + const s7_pointer code = cdr(sc->code), form = sc->code; + + if (!is_pair(code)) /* (case) or (case . 1) */ + syntax_error_nr(sc, "case has no selector: ~S", 25, form); + if (!is_pair(cdr(code))) /* (case 1) or (case 1 . 1) */ + syntax_error_nr(sc, "case has no clauses?: ~S", 25, form); + if (!is_pair(cadr(code))) /* (case 1 1) */ + syntax_error_nr(sc, "case clause is not a pair? ~S", 29, form); + set_opt3_any(code, sc->unspecified); + + { + s7_pointer clauses; + for (clauses = cdr(code); is_pair(clauses); clauses = cdr(clauses)) + { + s7_pointer keys, clause = car(clauses); + if (!is_pair(clause)) + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "case clause ~S messed up in ~A", 30), + clauses, object_to_string_truncated(sc, form))); + if (!is_list(cdr(clause))) /* (case 1 ((1))) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "case clause result ~S is messed up in ~A", 40), + clause, object_to_string_truncated(sc, form))); + if ((bodies_simple) && + ((is_null(cdr(clause))) || (!is_null(cddr(clause))))) + bodies_simple = false; + + use_fx = ((use_fx) && (is_pair(cdr(clause))) && (is_all_fxable(sc, cdr(clause)))); + keys = car(clause); + if (!is_pair(keys)) + { + if ((keys != sc->else_symbol) && /* (case 1 (2 1)) */ + ((!is_symbol(keys)) || + (s7_symbol_value(sc, keys) != sc->else_symbol))) /* "proper list" below because: (case 1 (() 2) ... */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "case clause key-list ~S in ~S is not a proper list or 'else', in ~A", 67), + keys, clause, object_to_string_truncated(sc, form))); + has_else = true; + if (is_not_null(cdr(clauses))) /* (case 1 (else 1) ((2) 1)) */ + syntax_error_nr(sc, "case 'else' clause is not the last clause: ~S", 45, clauses); + if (!is_null(cdr(clause))) /* else (else) so return selector */ + { + if (is_pair(cddr(clause))) + { + set_opt3_any(code, cdr(clause)); + bodies_simple = false; + } + else + { + set_opt3_any(code, ((bodies_simple) && (keys_single)) ? cadr(clause) : cdr(clause)); + set_opt1_clause(clauses, cadr(clause)); + }}} + else + { + if (!is_simple(car(keys))) keys_simple = false; + if (!is_null(cdr(keys))) keys_single = false; + if (key_type == T_FREE) + key_type = type(car(keys)); + else + if (key_type != type(car(keys))) + key_type = NUM_TYPES; + if (key_type == T_SYMBOL) set_case_key(car(keys)); + + for (keys = cdr(keys); is_pair(keys); keys = cdr(keys)) + { + if (!is_simple(car(keys))) + keys_simple = false; + if (key_type != type(car(keys))) + key_type = NUM_TYPES; + if (key_type == T_SYMBOL) set_case_key(car(keys)); + } + if (!is_null(keys)) /* (case () ((1 . 2) . hi) . hi) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "case key list ~S is improper, in ~A", 35), + clause, object_to_string_truncated(sc, form))); + } + if (!s7_is_proper_list(sc, cdr(clause))) /* (case 2 ((1 2) 1 . 2)) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "case: stray dot? ~S in ~A", 25), + clause, object_to_string_truncated(sc, form))); + if ((is_pair(cdr(clause))) && (is_undefined_feed_to(sc, cadr(clause)))) + { + has_feed_to = true; + if (!is_pair(cddr(clause))) /* (case 1 (else =>)) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "case: '=>' target missing: ~S in ~A", 35), + clause, object_to_string_truncated(sc, form))); + if (is_pair(cdddr(clause))) /* (case 1 (else => + - *)) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "case: '=>' has too many targets: ~S in ~A", 41), + clause, object_to_string_truncated(sc, form))); + }} + if (is_not_null(clauses)) /* (case x ((1 2)) . 1) */ + syntax_error_nr(sc, "case: stray dot? ~S", 19, form); + } + if ((keys_single) && + (bodies_simple)) + { + for (s7_pointer clauses = cdr(code); is_not_null(clauses); clauses = cdr(clauses)) + { + set_opt2_any(clauses, caar(clauses)); + if (is_pair(opt2_any(clauses))) + { + set_opt2_any(clauses, car(opt2_any(clauses))); + if (is_pair(cdar(clauses))) + set_opt1_clause(clauses, cadar(clauses)); + }}} + else + for (s7_pointer clauses = cdr(code); is_not_null(clauses); clauses = cdr(clauses)) + { + set_opt2_any(clauses, caar(clauses)); + if ((is_pair(opt2_any(clauses))) && + (is_pair(cdar(clauses)))) + set_opt1_clause(clauses, cadar(clauses)); + } + if (key_type == T_INTEGER) + set_has_integer_keys(form); + + /* X_Y_Z: X (selector): S=symbol, A=fxable, P=any, Y: E(keys simple) G(any keys) I(integer keys) , Z: S: no =>, bodies simple, keys single G: all else, -- ?? */ + pair_set_syntax_op(form, 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 */ + { + if (is_fxable(sc, car(code))) + { + pair_set_syntax_op(form, OP_CASE_A_G_G); + set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); + if ((is_fx_treeable(cdr(code))) && (curlet_has_slots(sc))) fx_curlet_tree_in(sc, code); + } + else pair_set_syntax_op(form, 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_fxable(sc, car(code))) + { + pair_set_syntax_op(form, (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)); + if ((is_fx_treeable(cdr(code))) && (curlet_has_slots(sc))) fx_curlet_tree_in(sc, code); + } + else pair_set_syntax_op(form, OP_CASE_P_E_G); + }} + else /* x_x_s */ + if (!keys_simple) /* x_g|i_s */ + { + if (is_fxable(sc, car(code))) + { + pair_set_syntax_op(form, ((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)); + if ((is_fx_treeable(cdr(code))) && (curlet_has_slots(sc))) fx_curlet_tree_in(sc, code); + } + else pair_set_syntax_op(form, ((key_type == T_INTEGER)) ? OP_CASE_P_I_S : OP_CASE_P_G_S); + } + else /* x_e_s */ + if (is_fxable(sc, car(code))) + { + pair_set_syntax_op(form, OP_CASE_A_E_S); + set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); + if ((is_fx_treeable(cdr(code))) && (curlet_has_slots(sc))) fx_curlet_tree_in(sc, code); + } + else pair_set_syntax_op(form, OP_CASE_P_E_S); + + if ((use_fx) && (has_else) && (!has_feed_to)) + { + const opcode_t op = optimize_op(form); + if ((op == OP_CASE_A_E_S) || (op == OP_CASE_A_G_S) || (op == OP_CASE_A_S_G) || ((op == OP_CASE_A_I_S))) + { + pair_set_syntax_op(form, + (op == OP_CASE_A_I_S) ? OP_CASE_A_I_S_A : + ((op == OP_CASE_A_E_S) ? OP_CASE_A_E_S_A : + ((op == OP_CASE_A_S_G) ? OP_CASE_A_S_G_A : OP_CASE_A_G_S_A))); + for (s7_pointer clauses = cdr(code); is_pair(clauses); clauses = cdr(clauses)) + { + s7_pointer clause = cdar(clauses); + fx_annotate_args(sc, clause, sc->curlet); + if ((is_fx_treeable(cdr(code))) && (curlet_has_slots(sc))) fx_curlet_tree(sc, clause); + if (is_null(cdr(clauses))) set_opt3_any(code, clause); + }}} + { + s7_pointer selector = cadr(form); + if (!is_pair(selector)) + { + sc->value = (is_symbol(selector)) ? lookup_checked(sc, selector) : selector; + return(NULL); + } + push_stack_no_args_direct(sc, OP_CASE_G_G); + sc->code = selector; + return(selector); + } +} + +static bool op_case_i_s(s7_scheme *sc) +{ + const s7_pointer selector = sc->value; + const s7_pointer else_clause = opt3_any(cdr(sc->code)); + if (else_clause != sc->unspecified) + { + if (is_t_integer(selector)) + { + const s7_int val = integer(selector); + for (s7_pointer clauses = cddr(sc->code); is_pair(cdr(clauses)); clauses = cdr(clauses)) + if (integer(opt2_any(clauses)) == val) + { + sc->code = opt1_clause(clauses); + return(false); + }} + sc->code = else_clause; + return(false); + } + if (is_t_integer(selector)) + { + const s7_int val = integer(selector); + for (s7_pointer clauses = cddr(sc->code); is_pair(clauses); clauses = cdr(clauses)) + if (integer(opt2_any(clauses)) == val) + { + sc->code = opt1_clause(clauses); + return(false); + }} + sc->value = sc->unspecified; + return(true); +} + +static inline s7_pointer fx_case_a_i_s_a(s7_scheme *sc, s7_pointer code) /* inline saves about 30 in tleft */ +{ + const s7_pointer selector = fx_call(sc, cdr(code)); + if (is_t_integer(selector)) + { + const s7_int val = integer(selector); + for (s7_pointer clauses = cddr(sc->code); is_pair(cdr(clauses)); clauses = cdr(clauses)) /* code = (case ...) */ + if (integer(opt2_any(clauses)) == val) + return(fx_call(sc, cdar(clauses))); + } + return(fx_call(sc, opt3_any(cdr(code)))); +} + +static bool op_case_e_g_1(s7_scheme *sc, const s7_pointer selector, bool ok) +{ + s7_pointer clauses; + if (ok) + { + for (clauses = cddr(sc->code); is_pair(clauses); clauses = cdr(clauses)) + { + s7_pointer keys = opt2_any(clauses); + if (!is_pair(keys)) /* i.e. else? */ + goto ELSE_CASE_1; + do { + if (car(keys) == selector) + goto ELSE_CASE_1; + keys = cdr(keys); + } while (is_pair(keys)); + } + 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: + /* clauses is the entire matching clause, (case 2 ((2) 3)), clauses: (((2) 3)) */ + sc->code = T_Lst(cdar(clauses)); + 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 inline s7_pointer fx_call_all(s7_scheme *sc, s7_pointer code) +{ + s7_pointer p; + for (p = code; is_pair(cdr(p)); p = cdr(p)) + fx_call(sc, p); + return(fx_call(sc, p)); +} + +static s7_pointer fx_case_a_s_g_a(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer selector = fx_call(sc, cdr(code)); + if (is_case_key(selector)) + for (s7_pointer clauses = cddr(sc->code); is_pair(clauses); clauses = cdr(clauses)) + { + s7_pointer keys = opt2_any(clauses); + if (!is_pair(keys)) /* i.e. else? */ + return(fx_call_all(sc, cdar(clauses))); /* else clause */ + do { + if (car(keys) == selector) + return(fx_call_all(sc, cdar(clauses))); + keys = cdr(keys); + } while (is_pair(keys)); + } + return(fx_call_all(sc, opt3_any(cdr(code)))); /* selector is not a case-key */ +} + +#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); +#define if_pair_set_up_begin_unchecked(Sc) if (is_pair(cdr(Sc->code))) push_stack_no_args(Sc, Sc->begin_op, cdr(Sc->code)); Sc->code = car(Sc->code); +/* using the one_form bit here was slower */ + +static bool op_case_g_g(s7_scheme *sc) +{ + s7_pointer clauses; + 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 + { + { + for (clauses = sc->code; is_pair(clauses); clauses = cdr(clauses)) + if (!is_pair(caar(clauses))) + goto ELSE_CASE; + sc->value = sc->unspecified; + pop_stack(sc); + return(true); + }} + for (clauses = sc->code; is_pair(clauses); clauses = cdr(clauses)) + { + s7_pointer keys = caar(clauses); + if (!is_pair(keys)) + goto ELSE_CASE; + for (; is_pair(keys); keys = cdr(keys)) + if (integer(car(keys)) == selector) + goto ELSE_CASE; + } + sc->value = sc->unspecified; + pop_stack(sc); + return(true); + } + sc->code = cddr(sc->code); + if (is_simple(sc->value)) + { + for (clauses = sc->code; is_pair(clauses); clauses = cdr(clauses)) + { + s7_pointer keys = caar(clauses); + if (!is_pair(keys)) + goto ELSE_CASE; + do { + if (car(keys) == sc->value) + goto ELSE_CASE; + keys = cdr(keys); + } while (is_pair(keys)); + } + sc->value = sc->unspecified; + pop_stack(sc); + return(true); + } + for (clauses = sc->code; is_pair(clauses); clauses = cdr(clauses)) + { + s7_pointer keys = caar(clauses); + if (!is_pair(keys)) + goto ELSE_CASE; + for (; is_pair(keys); keys = cdr(keys)) + if (s7_is_eqv(sc, car(keys), 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: + /* clauses is the entire matching clause, (case 2 ((2) 3)), clauses: (((2) 3)) */ + sc->code = T_Lst(cdar(clauses)); + 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_pair_set_up_begin_unchecked(sc); + sc->cur_op = optimize_op(sc->code); + return(true); +} + +static void op_case_e_s(s7_scheme *sc) +{ + const s7_pointer selector = sc->value; + if (is_simple(selector)) + for (s7_pointer clauses = cddr(sc->code); is_pair(clauses); clauses = cdr(clauses)) + if (opt2_any(clauses) == selector) + { + sc->code = opt1_clause(clauses); + return; + } + sc->code = opt3_any(cdr(sc->code)); +} + +static s7_pointer fx_case_a_e_s_a(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer selector = fx_call(sc, cdr(code)); + if (is_simple(selector)) + for (s7_pointer clauses = cddr(code); is_pair(clauses); clauses = cdr(clauses)) + if (opt2_any(clauses) == selector) + return(fx_call(sc, cdar(clauses))); + return(fx_call(sc, opt3_any(cdr(code)))); +} + +static void op_case_g_s(s7_scheme *sc) +{ + const s7_pointer selector = sc->value; + for (s7_pointer clauses = cddr(sc->code); is_pair(clauses); clauses = cdr(clauses)) + if (s7_is_eqv(sc, opt2_any(clauses), selector)) + { + sc->code = opt1_clause(clauses); + return; + } + sc->code = opt3_any(cdr(sc->code)); +} + +static inline s7_pointer fx_case_a_g_s_a(s7_scheme *sc, s7_pointer code) /* split into int/any cases in g_g, via has_integer_keys(sc->code) */ +{ + const s7_pointer selector = fx_call(sc, cdr(code)); + for (s7_pointer clauses = cddr(code); is_pair(clauses); clauses = cdr(clauses)) + if (s7_is_eqv(sc, opt2_any(clauses), selector)) + return(fx_call(sc, cdar(clauses))); + return(fx_call(sc, opt3_any(cdr(code)))); +} + + +/* -------------------------------- let -------------------------------- */ +static void check_let_a_body(s7_scheme *sc, s7_pointer form) +{ + const 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); + if (is_fx_treeable(cdaar(code))) fx_tree(sc, cdr(code), caaar(code), NULL, NULL, false); + } +} + +static void check_let_one_var(s7_scheme *sc, s7_pointer form, s7_pointer start) /* not a named let */ +{ + const s7_pointer binding = car(start), code = cdr(form); /* i.e. form=(let ((x '(1 2))) (list x x)), start=((x '(1 2))) */ + const s7_pointer variable = car(binding), value = cadr(binding); + if (is_pair(value)) + { + 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), variable); /* these don't collide -- cdr(code) and code */ + set_opt2_pair(code, value); + if (is_optimized(value)) + { + if ((optimize_op(value) == HOP_SAFE_C_SS) && + (fn_proc(value) == g_assq)) + { + set_opt2_sym(code, cadr(value)); + pair_set_syntax_op(form, OP_LET_opaSSq_OLD); + set_opt3_sym(cdr(code), caddr(value)); + set_opt1_sym(code, variable); + } + else + if (is_fxable(sc, value)) + { + 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_NA_OLD); /* let_a_aa_old|new is not worth the code (30 in tgc, nothing elsewhere) */ + fx_annotate_args(sc, cdr(code), set_plist_1(sc, variable)); + fx_tree(sc, cdr(code), variable, NULL, NULL, false); + return; + } + if (is_fx_treeable(cdr(code))) fx_tree(sc, cdr(code), variable, NULL, NULL, false); + }}}} + 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); + else + { + fx_annotate_args(sc, cdr(code), set_plist_1(sc, variable)); /* no effect if not syntactic -- how to fix? plist is the "let" = local varname */ + if (is_fx_treeable(cdr(code))) fx_tree(sc, cdr(code), variable, NULL, NULL, false); + }} + 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); /* not fxable body, goto eval on each */ +} + +static s7_pointer check_named_let(s7_scheme *sc, int32_t vars) +{ + const s7_pointer code = cdr(sc->code); + set_opt2_int(code, 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 + { + 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 (implicit) lambda arg list */ + + sc->args = T_Pair(safe_list_if_possible(sc, vars)); + for (s7_pointer ex = cadr(code), exp = sc->args; is_pair(ex); ex = cdr(ex), exp = cdr(exp)) + { + const s7_pointer val = cdar(ex); + s7_function fx = fx_choose(sc, val, sc->curlet, let_symbol_is_safe); + if (fx) set_fx_direct(val, fx); else fx_ok = false; + set_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_NA)); + } + optimize_lambda(sc, true, car(code), sc->args, cddr(code)); /* car(code) is the name */ + if (!in_heap(sc->args)) clear_safe_list_in_use(sc, sc->args); + sc->args = sc->nil; + } + return(code); +} + +static s7_pointer check_let(s7_scheme *sc) /* called only from op_let */ +{ + s7_pointer start; + const s7_pointer code = cdr(sc->code), form = sc->code; + bool named_let; + + if (!is_pair(code)) /* (let . 1) */ + { + if (is_null(code)) /* (let) */ + syntax_error_nr(sc, "let has no variables or body: ~A", 32, form); + syntax_error_nr(sc, "let form is an improper list? ~A", 32, form); + } + + if (!is_pair(cdr(code))) /* (let () ) or (let () . 1) */ + syntax_error_nr(sc, "let has no body: ~A", 19, form); + + if ((!is_list(car(code))) && /* (let 1 ...) */ + (!is_normal_symbol(car(code)))) + syntax_error_nr(sc, "let variable list is messed up or missing: ~A", 45, form); + + named_let = (is_symbol(car(code))); + if (named_let) + { + if (!is_list(cadr(code))) /* (let hi #t) */ + syntax_error_nr(sc, "let variable list is messed up: ~A", 34, form); + if (!is_pair(cddr(code))) /* (let hi () . =>) or (let hi () ) */ + { + if (is_null(cddr(code))) + syntax_error_nr(sc, "named let has no body: ~A", 25 , form); + syntax_error_nr(sc, "named let stray dot? ~A", 23, form); + } + if (is_constant_symbol(sc, car(code))) + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_symbol, form)); + set_local(car(code)); + start = cadr(code); + } + else start = car(code); + + begin_small_symbol_set(sc); + { + s7_pointer vars; + int32_t num_vars; + for (num_vars = 0, vars = start; is_pair(vars); num_vars++, vars = cdr(vars)) + { + s7_pointer sym; + const s7_pointer var = car(vars); + + if ((!is_pair(var)) || (is_null(cdr(var)))) /* (let ((x)) ...) or (let ((x 1) . (y 2)) ...) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "let variable declaration, but no value?: ~A in ~A", 49), + vars, object_to_string_truncated(sc, form))); + + if (!is_pair(cdr(var))) /* (let ((x . 1))...) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "let variable declaration, ~A, is not a proper list in ~A", 56), + vars, object_to_string_truncated(sc, form))); + + if (is_not_null(cddr(var))) /* (let ((x 1 2 3)) ...) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "let variable declaration, ~A, has more than one value in ~A", 59), + vars, object_to_string_truncated(sc, form))); + sym = car(var); + if (!is_symbol(sym)) + { + if (is_c_function(sym)) /* (let ((#_abs 3)) ...) */ + { + s7_pointer fsym = c_function_symbol(sym); + if (initial_value_is_defined(sc, fsym)) + error_nr(sc, sc->syntax_error_symbol, + set_elist_2(sc, wrap_string(sc, "variable name #_~S in let is a function, not a symbol", 53), fsym)); + } + error_nr(sc, sc->syntax_error_symbol, /* (let ('1) quote) -> bad variable name #_quote in let (it is syntactic, not a symbol) */ + set_elist_4(sc, wrap_string(sc, "bad variable name ~W in let (it is ~A, not a symbol) in ~A", 58), + sym, object_type_name(sc, sym), + object_to_string_truncated(sc, form))); + } + if (is_constant_symbol(sc, sym)) /* let ((pi 3)) ...) */ + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_symbol, vars)); + + /* check for name collisions -- not sure this is required by Scheme */ + if (symbol_is_in_small_symbol_set(sc, sym)) + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "duplicate identifier in let: ~S in ~S", 37), sym, form)); + add_symbol_to_small_symbol_set(sc, sym); + set_local(sym); + } + end_small_symbol_set(sc); + + if (is_not_null(vars)) /* (let* ((a 1) . b) a) */ + syntax_error_nr(sc, "let variable list improper?: ~A", 31, form); + + if (!s7_is_proper_list(sc, cdr(code))) /* (let ((a 1)) a . 1) */ + syntax_error_nr(sc, "stray dot in let body: ~S", 25, cdr(code)); + + if (named_let) + return(check_named_let(sc, num_vars)); + /* set_opt2_int(code, num_vars); */ /* maybe set on vars? */ + + if (num_vars == 0) /* !in_heap does not happen much here */ + pair_set_syntax_op(form, OP_LET_NO_VARS); + else + { + pair_set_syntax_op(form, OP_LET_UNCHECKED); + if (num_vars == 1) + check_let_one_var(sc, form, start); + else + { + /* this used to check that num_vars < gc_trigger_size, but I can't see why */ + opcode_t opt = OP_UNOPT; + for (vars = start; is_pair(vars); vars = cdr(vars)) + { + s7_pointer var = car(vars); + if (is_fxable(sc, cadr(var))) + { + set_fx_direct(cdr(var), fx_choose(sc, cdr(var), sc->curlet, let_symbol_is_safe)); + if (opt == OP_UNOPT) + opt = OP_LET_NA_OLD; + } + else opt = OP_LET_UNCHECKED; + } + pair_set_syntax_op(form, opt); + if ((opt == OP_LET_NA_OLD) && + (is_null(cddr(code)))) /* 1 form in body */ + { + if (num_vars == 2) + { + pair_set_syntax_op(form, OP_LET_2A_OLD); + set_opt1_pair(code, caar(code)); + set_opt2_pair(code, cadar(code)); + } + else + if (num_vars == 3) + { + pair_set_syntax_op(form, 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 */ + if (optimize_op(form) >= OP_LET_NA_OLD) + { + if ((!in_heap(form)) && + (wrapped_body_is_safe(sc, sc->unused, cdr(code), true) >= safe_body)) /* recur_body is apparently never hit */ + set_opt3_let(code, make_semipermanent_let(sc, car(code))); + else + { + set_optimize_op(form, optimize_op(form) + 1); /* *_old -> *_new */ + set_opt3_let(code, sc->rootlet); + }} + + /* fx_tree inits */ + if ((is_pair(code)) && + (is_fx_treeable(code)) && /* was is_funclet(sc->curlet) 27-Sep-21, but that seems too restrictive */ + (curlet_has_slots(sc))) + { + s7_pointer slot1 = let_slots(sc->curlet), slot2 = next_slot(slot1), slot3 = NULL; + bool more_vars = false; + if (is_not_slot_end(slot2)) + { + if (is_not_slot_end(next_slot(slot2))) + { + slot3 = next_slot(slot2); + more_vars = is_not_slot_end(next_slot(slot3)); + slot3 = slot_symbol(slot3); + } + slot2 = slot_symbol(slot2); + } + slot1 = slot_symbol(slot1); + for (s7_pointer p = car(code); is_pair(p); p = cdr(p)) /* var list */ + { + s7_pointer init = cdar(p); + fx_tree(sc, init, slot1, slot2, slot3, more_vars); + }} + return(code); +} + +static void op_named_let_1(s7_scheme *sc, s7_pointer args) /* sc->code = (name vars . body), args = vals in decl order */ +{ + const s7_pointer body = cddr(sc->code); + const s7_int n = opt2_int(sc->code); /* num pars, see check_named_let called in check_let, normally 1, sometimes 2..4 */ + if (n == 1) + begin_temp(sc->y, list_1(sc, caaadr(sc->code))); + else + { + begin_temp(sc->y, sc->nil); + for (s7_pointer vars = cadr(sc->code); is_pair(vars); vars = cdr(vars)) + { + sc->y = cons(sc, caar(vars), sc->y); /* this consing is not completely wasted -- it becomes the closure arg list below (why is this needed?) */ + vars = cdr(vars); + if (!is_pair(vars)) break; + sc->y = cons_unchecked(sc, caar(vars), sc->y); + } + sc->y = proper_list_reverse_in_place(sc, sc->y); /* needed for closure_pars */ + } + set_curlet(sc, make_let(sc, sc->curlet)); + begin_temp(sc->v, make_closure_unchecked(sc, sc->y, body, T_CLOSURE, n)); /* n = num pars */ + add_slot(sc, sc->curlet, car(sc->code), sc->v); + set_curlet(sc, make_let(sc, sc->curlet)); /* inner let */ + for (s7_pointer vars = sc->y; is_not_null(args); vars = cdr(vars), args = cdr(args)) + { + add_slot_unchecked_with_id(sc, sc->curlet, car(vars), car_unchecked(args)); + vars = cdr(vars); args = cdr(args); + if (is_null(args)) break; + add_slot_checked_with_id(sc, sc->curlet, car(vars), car_unchecked(args)); + } + closure_set_let(sc->v, sc->curlet); + let_set_slots(sc->curlet, reverse_slots(let_slots(sc->curlet))); + end_temp(sc->y); + end_temp(sc->v); + sc->code = T_Pair(body); +} + +static bool op_let_1(s7_scheme *sc) +{ /* op_let form: (let ((i 0) (j 1)) (+ i j)), code: ((i 0) (j 1)), value: (((i 0) (j 1)) (+ i j)), args: () + * op_named_let: (let loop ((i 0)) (if (< i 3) (loop (+ i 1)) i)), code: ((i 0)), value: (loop ((i 0)) (if (< i 3) (loop (+ i 1)) i)), args: () + * eval->op_let_unchecked: (let ((i (catch #t (lambda () 1) (lambda (t i) 'error))) (j 2)) (+ i j))) (in a function), + * code: ((j 2)), value: 1, args: ((((i (catch #t (lambda () 1) (lambda (t i) 'error))) (j 2)) (+ i j))) + */ + /* true -> BEGIN, false -> EVAL */ + while (true) + { + sc->args = cons(sc, sc->value, sc->args); /* sc->value can be a mutable number here */ + if (is_pair(sc->code)) + { + const s7_pointer val = cdar(sc->code); + if (has_fx(val)) + sc->value = fx_call(sc, val); + else + { + check_stack_size(sc); + push_stack(sc, OP_LET1, sc->args, cdr(sc->code)); /* come back here */ + sc->code = car(val); + return(false); /* goto EVAL */ + } + sc->code = cdr(sc->code); + } + else break; + } + sc->args = proper_list_reverse_in_place(sc, sc->args); + sc->code = car(sc->args); /* restore the original form */ + { + s7_pointer vals = cdr(sc->args); /* car=form */ + s7_int id; + sc->temp8 = vals; + set_curlet(sc, make_let(sc, T_Let(sc->curlet))); + if (is_symbol(car(sc->code))) + { + op_named_let_1(sc, vals); /* inner let here */ + sc->temp8 = sc->unused; + return(true); + } + id = let_id(sc->curlet); + if (is_pair(vals)) + { + s7_pointer vars = car(sc->code); + s7_pointer last_slot = add_slot_unchecked_with_id(sc, sc->curlet, caar(vars), car_unchecked(vals)); + for (vars = cdr(vars), vals = cdr(vals); is_not_null(vals); vars = cdr(vars), vals = cdr(vals)) + last_slot = add_slot_checked_at_end(sc, id, last_slot, caar(vars), car_unchecked(vals)); /* not unchecked -- tlimit.scm */ + }} + sc->code = T_Pair(cdr(sc->code)); + sc->temp8 = sc->unused; + return(true); /* goto BEGIN */ +} + +static bool op_let(s7_scheme *sc) /* from OP_LET */ +{ + /* 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; + set_curlet(sc, make_let(sc, sc->curlet)); + if (named_let) /* see also below -- there are 3 cases */ + { + const s7_pointer body = cddr(sc->code); + set_opt2_int(cdr(sc->code), 0); + begin_temp(sc->y, 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->y)); + funclet_set_function(closure_let(sc->y), car(sc->code)); + add_slot_checked(sc, sc->curlet, car(sc->code), sc->y); + set_curlet(sc, make_let(sc, sc->curlet)); /* inner let */ + sc->code = T_Pair(body); + end_temp(sc->y); + } + else sc->code = T_Pair(cdr(sc->code)); + return(true); /* goto BEGIN */ + } + sc->args = sc->nil; + /* value: (((i 0)) (+ i 1)), code: ((i 0)) */ + return(op_let_1(sc)); /* sc->code == vars, sc->value = original sc->code */ +} + +static bool op_let_unchecked(s7_scheme *sc) /* not named, but has vars, called from eval if looping via op_let->op_let_1 + unopt'd args */ +{ + const s7_pointer code = cadr(sc->code); + const s7_pointer val = cdar(code); /* next arg */ + /* value: 0, code: ((radix (+ 2 (random 15)))) from (do ((i 0 (+ i 1))) ((= i 2)) (let ((j 0) (radix (+ 2 (random 15)))) (+ j radix))) on second iteration (i == 1) */ + sc->args = list_1(sc, cdr(sc->code)); /* as if sc->value were this, then absorbed into sc->args */ + if (has_fx(val)) + sc->value = fx_call(sc, val); + else + { + push_stack(sc, OP_LET1, sc->args, cdr(code)); + sc->code = car(val); + return(false); /* goto EVAL */ + } + sc->code = cdr(code); + return(op_let_1(sc)); /* sc->args preset with code */ +} + +static bool op_named_let(s7_scheme *sc) +{ /* from eval */ + sc->args = sc->nil; + sc->value = cdr(sc->code); + sc->code = cadr(sc->value); + return(op_let_1(sc)); /* sc->args is ()? */ +} + +static void op_named_let_no_vars(s7_scheme *sc) +{ /* sc->code is full form (let name () ...) */ + const s7_pointer name = cadr(sc->code); + sc->code = opt1_pair(sc->code); /* cdddr(sc->code) == body */ + set_curlet(sc, inline_make_let(sc, sc->curlet)); + sc->args = make_closure_unchecked(sc, sc->nil, sc->code, T_CLOSURE, 0); + add_slot_checked(sc, sc->curlet, name, sc->args); /* sc->args is a temp here */ + set_curlet(sc, make_let(sc, sc->curlet)); /* inner let */ + /* goto BEGIN */ +} + +static void op_named_let_a(s7_scheme *sc) +{ /* sc->code is the full form (let name vars...), par pointers are preset in opt1|3(cdr(sc->code)) */ + const s7_pointer data = cdr(sc->code); + const s7_pointer par1 = opt1_pair(data); /* cdaadr(args) == first par */ + sc->code = cddr(data); /* (vars ...) */ + sc->args = fx_call(sc, cdr(par1)); + set_curlet(sc, make_let(sc, sc->curlet)); /* funclet(?) */ + begin_temp(sc->y, list_1_unchecked(sc, car(par1))); /* (list sym1), subsequent calls will need a normal list of pars in closure_pars */ + begin_temp(sc->v, make_closure_unchecked(sc, sc->y, sc->code, T_CLOSURE, 1)); /* picks up curlet (this is the funclet?) */ + add_slot(sc, sc->curlet, car(data), sc->v); /* car(data) == the function name */ + set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, car(sc->y), sc->args)); /* inner let */ + closure_set_let(sc->v, sc->curlet); + end_temp(sc->v); + end_temp(sc->y); + /* goto BEGIN */ +} + +static void op_named_let_aa(s7_scheme *sc) +{ /* sc->code is the full form (let name vars...), par pointers are preset in opt1|3(cdr(sc->code)) */ + const s7_pointer data = cdr(sc->code); + const s7_pointer par1 = opt1_pair(data); /* cdaadr(data) == first par */ + const s7_pointer par2 = opt3_pair(data); /* cdadadr == second */ + sc->code = cddr(data); /* (vars ...) */ + sc->args = fx_call(sc, cdr(par1)); + sc->value = fx_call(sc, cdr(par2)); + set_curlet(sc, make_let(sc, sc->curlet)); /* funclet below I think */ + begin_temp(sc->y, list_2_unchecked(sc, car(par1), car(par2))); /* (list sym1 sym2): subsequent calls will need a normal list of pars in closure_pars */ + begin_temp(sc->v, make_closure_unchecked(sc, sc->y, sc->code, T_CLOSURE, 2)); /* picks up curlet (this is the funclet?) */ + add_slot(sc, sc->curlet, car(data), sc->v); /* car(data) == the function name */ + set_curlet(sc, inline_make_let_with_two_slots(sc, sc->curlet, car(sc->y), sc->args, cadr(sc->y), sc->value)); /* inner let */ + closure_set_let(sc->v, sc->curlet); + end_temp(sc->v); + end_temp(sc->y); + /* goto BEGIN */ +} + +static void op_named_let_na(s7_scheme *sc) +{ + sc->code = cdr(sc->code); + sc->args = sc->nil; + for (s7_pointer p = cadr(sc->code); 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); + op_named_let_1(sc, sc->args); /* sc->code = (name vars . body), args = vals in decl order, op_named_let_1 handles inner let */ + /* goto BEGIN */ +} + +static void op_let_no_vars(s7_scheme *sc) +{ + set_curlet(sc, inline_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); + /* check_stack_size(sc) -- needed if we're in an infinite loop -- maybe let it trigger "stack too big" instead */ + /* e.g. (let ((set! let*)) (let* set! ((x 1234) (y 1/2)) (let ((<1> (list 1 #f))) (set! (<1> 1) ...)))) */ + 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); + check_stack_size(sc); /* hit in (lint "s7test.scm") */ + 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 = 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 = 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 inline_op_let_a_new(s7_scheme *sc) /* three calls in eval, all get hits */ +{ + sc->code = cdr(sc->code); + set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, car(opt2_pair(sc->code)), fx_call(sc, cdr(opt2_pair(sc->code))))); +} + +static Inline void inline_op_let_a_old(s7_scheme *sc) /* tset(2) fb(0) cb(4) left(2) */ +{ + 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 inline void op_let_a_old(s7_scheme *sc) {inline_op_let_a_old(sc);} + +static void op_let_a_a_new(s7_scheme *sc) +{ + s7_pointer binding, let; + sc->code = cdr(sc->code); + binding = opt2_pair(sc->code); + let = wrap_let_with_slot(sc, sc->curlet, car(binding), fx_call(sc, cdr(binding))); /* wrap maybe unsafe here (see snd-24.3/s7.c */ + set_curlet(sc, let); + sc->value = fx_call(sc, cdr(sc->code)); + let_set_slots(let, slot_end); +} + +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) */ +{ + inline_op_let_a_old(sc); + sc->value = fx_call(sc, cdr(sc->code)); +} + +static void op_let_a_na_new(s7_scheme *sc) +{ + s7_pointer binding, p; + sc->code = cdr(sc->code); + binding = opt2_pair(sc->code); + set_curlet(sc, wrap_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); +} + +/* 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_na_old(s7_scheme *sc) +{ + s7_pointer p; + inline_op_let_a_old(sc); + 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_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 inline 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 inline void op_let_opassq_new(s7_scheme *sc) +{ + op_let_opassq(sc); + set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, opt1_sym(sc->code), sc->value)); + sc->code = T_Pair(cdr(sc->code)); +} + +static Inline void inline_op_let_na_new(s7_scheme *sc) /* called once in eval, case gsl lg mock */ +{ + 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); + let_set_outlet(let, T_Let(sc->curlet)); + sc->args = let; + for (s7_pointer p = cadr(sc->code), last_slot = NULL; is_pair(p); p = cdr(p)) + { + const s7_pointer arg = cdar(p); + sc->value = fx_call(sc, arg); + if (!last_slot) + { + add_slot(sc, let, caar(p), sc->value); + last_slot = let_slots(let); + } + else last_slot = add_slot_at_end(sc, let_id(let), last_slot, caar(p), sc->value); + } + sc->let_number++; + set_curlet(sc, let); + sc->code = T_Pair(cddr(sc->code)); +} + +static void op_let_na_old(s7_scheme *sc) +{ + const s7_pointer let = opt3_let(cdr(sc->code)); + const s7_int id = ++sc->let_number; + sc->args = let; /* GC protection */ + let_set_id(let, id); + let_set_outlet(let, sc->curlet); + for (s7_pointer p = cadr(sc->code), slot = let_slots(let); is_pair(p); p = cdr(p), slot = next_slot(slot)) + { + 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 */ +{ + const s7_pointer code = cdr(sc->code); + const s7_pointer a1 = opt1_pair(code); /* caar(code) */ + const s7_pointer a2 = opt2_pair(code); /* cadar(code) */ + check_stack_size(sc); /* added 15-Jul-25 for srfi-1 filter of huge list */ + gc_protect_via_stack(sc, fx_call(sc, cdr(a1))); + set_gc_protected2(sc, fx_call(sc, cdr(a2))); + set_curlet(sc, inline_make_let_with_two_slots(sc, sc->curlet, car(a1), gc_protected1(sc), car(a2), gc_protected2(sc))); + unstack_gc_protect(sc); + sc->code = cadr(code); +} + +static inline void op_let_2a_old(s7_scheme *sc) /* 2 vars, 1 expr in body */ +{ + s7_pointer code = cdr(sc->code); + s7_pointer 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 */ +{ + const s7_pointer code = cdr(sc->code); + const s7_pointer a1 = caar(code); + const s7_pointer a2 = opt1_pair(code); /* cadar */ + const s7_pointer a3 = opt2_pair(code); /* caddar */ + gc_protect_via_stack(sc, fx_call(sc, cdr(a1))); /* fx_call might be fx_car_t (etc) so it needs to precede the new let */ + set_gc_protected2(sc, fx_call(sc, cdr(a2))); + set_curlet(sc, inline_make_let_with_two_slots(sc, sc->curlet, car(a2), gc_protected2(sc), car(a3), fx_call(sc, cdr(a3)))); + add_slot(sc, sc->curlet, car(a1), gc_protected1(sc)); + unstack_gc_protect(sc); + sc->code = cadr(code); +} + +static void op_let_3a_old(s7_scheme *sc) /* 3 vars, 1 expr in body */ +{ + const s7_pointer code = cdr(sc->code); + s7_pointer 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; + const s7_pointer form = sc->code, code = cdr(sc->code); + bool named_let, fxable = true, shadowing = false; + + if (!is_pair(code)) /* (let* . 1) */ + syntax_error_nr(sc, "let* variable list is messed up: ~A", 35, form); + if (!is_pair(cdr(code))) /* (let* ()) */ + syntax_error_nr(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) */ + syntax_error_nr(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))) + syntax_error_nr(sc, "named let* has no body: ~A", 26, form); + syntax_error_nr(sc, "named let* stray dot? ~A", 24, form); + } + if (is_constant_symbol(sc, car(code))) + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_star_symbol, form)); + set_local(car(code)); + } + else + if (!is_list(car(code))) /* (let* x ... ) */ + syntax_error_nr(sc, "let* variable declaration value is missing: ~A", 46, form); + + begin_small_symbol_set(sc); + for (vars = ((named_let) ? cadr(code) : car(code)); is_pair(vars); vars = cdr(vars)) + { + s7_pointer var; + const s7_pointer var_and_val = car(vars); + if (!is_pair(var_and_val)) /* (let* (3) ... */ + { + /* does (let* loop ((i 0) :allow-other-keys) i) make sense? + * + * (let* name ((i 0) :allow-other-keys) i) + * check_let_star[79760]: got :allow-other-keys + * let* variable list, :allow-other-keys, is messed up in (let* name ((i 0) :allow-other-keys) i) + * + * (let* name ((i 0) . others) i) + * 79802(9): let* variable list is not a proper list: others in (let* name ((i 0) . others) i) + * + * (let* name others others) + * 79738: let* variable list is messed up: (let* name others others) + * + * (let* name ((i 0) :rest b) b) + * check_let_star[79760]: got :rest + * let* variable list, :rest, is messed up in (let* name ((i 0) :rest b) b) + * + * what about (let* name ((i 0) :allow-other-keys) ... (name :x 2 3)) -- is i=3? (it is in define*: + * (define* (f (i 0) :allow-other-keys) i) (f :x 2 3): 3) -- so other-keys are completely ignored? + * but (define* (f (a 1) (b 2)) (list a b)), (f :b 12 3): parameter set twice, b in (:b 12 3) + * t_allow_other_keys is set on arglists and c_function_star (? clo*?) -- let* makes t_closure_star + */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "let* variable list, ~A, is messed up in ~A", 42), + var_and_val, object_to_string_truncated(sc, form))); + } + if (!is_pair(cdr(var_and_val))) /* (let* ((x . 1))...) */ + { + if (is_null(cdr(var_and_val))) + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "let* variable declaration, but no value?: ~A in ~A", 50), + var_and_val, object_to_string_truncated(sc, form))); + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "let* variable declaration is not a proper list: ~A in ~A", 56), + var_and_val, object_to_string_truncated(sc, form))); + } + if (!is_null(cddr(var_and_val))) /* (let* ((c 1 2)) ...) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "let* variable declaration has more than one value?: ~A in ~A", 60), + var_and_val, object_to_string_truncated(sc, form))); + var = car(var_and_val); + if (!is_symbol(var)) /* (let* ((3 1)) 1) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "bad variable name ~W in let* (it is ~A, not a symbol) in ~A", 59), + var, object_type_name(sc, var), + object_to_string_truncated(sc, form))); + if (is_constant_symbol(sc, var)) /* (let* ((pi 3)) ...) */ + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_star_symbol, var_and_val)); + + if (symbol_is_in_small_symbol_set(sc, var)) + { + if (named_let) /* (let* loop ((a 1) (a 2)) ...) -- added 2-Dec-19 */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "named let* parameter, ~A, is used twice in the parameter list in ~A", 67), + var, object_to_string_truncated(sc, form))); + /* currently (let* ((a 1) (a (+ a 1))) a) is 2, not an error */ + shadowing = true; + } + add_symbol_to_small_symbol_set(sc, var); + set_local(var); + } + end_small_symbol_set(sc); + if (!is_null(vars)) + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "let* variable list is not a proper list: ~A in ~A", 49), + vars, object_to_string_truncated(sc, form))); + if (!s7_is_proper_list(sc, cdr(code))) + syntax_error_nr(sc, "stray dot in let* body: ~S", 26, cdr(code)); + + if (shadowing) + fxable = false; + else + 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))); + } + sc->value = cdr(code); + if (is_null(car(sc->value))) /* (let* name () ... */ + { + const s7_pointer let_sym = car(code); + set_curlet(sc, make_let(sc, sc->curlet)); + sc->code = T_Pair(cdr(sc->value)); + add_slot_checked(sc, sc->curlet, let_sym, make_closure_unchecked(sc, sc->nil, sc->code, T_CLOSURE_STAR, 0)); + set_curlet(sc, make_let(sc, sc->curlet)); /* inner let */ + return(false); + } + set_curlet(sc, make_let(sc, sc->curlet)); + push_stack(sc, OP_LET_STAR1, code, cadr(code)); + sc->code = cadr(caadr(code)); /* first var val */ + return(true); + } + if (is_null(car(code))) + { + pair_set_syntax_op(form, OP_LET_NO_VARS); /* (let* () ...) */ + set_curlet(sc, make_let(sc, sc->curlet)); + sc->code = T_Pair(cdr(code)); + return(false); + } + else + if (is_null(cdar(code))) + { + check_let_one_var(sc, form, car(code)); /* (let* ((var...))...) -> (let ((var...))...) */ + if (optimize_op(form) >= OP_LET_NA_OLD) + { + if ((!in_heap(form)) && + (wrapped_body_is_safe(sc, sc->unused, cdr(code), true) >= safe_body)) + set_opt3_let(code, make_semipermanent_let(sc, car(code))); + else + { + set_optimize_op(form, optimize_op(form) + 1); /* *_old -> *_new */ + set_opt3_let(code, sc->rootlet); + }}} + else /* multiple variables */ + { + if (fxable) + { + pair_set_syntax_op(form, OP_LET_STAR_NA); + 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_NA_A); + }} + else pair_set_syntax_op(form, OP_LET_STAR2); + set_opt2_con(code, cadaar(code)); + } + push_stack(sc, ((intptr_t)((shadowing) ? OP_LET_STAR_SHADOWED : 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 bool op_let_star_shadowed(s7_scheme *sc) +{ + while (true) + { + set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, caar(sc->code), sc->value)); + sc->code = cdr(sc->code); + if (is_pair(sc->code)) + { + const s7_pointer val = cdar(sc->code); + if (has_fx(val)) + sc->value = fx_call(sc, val); + else + { + push_stack_direct(sc, OP_LET_STAR_SHADOWED); + sc->code = car(val); + return(true); + }} + else break; + } + sc->code = cdr(sc->args); /* original sc->code set in push_stack above */ + return(false); +} + +static /* inline */ bool op_let_star1(s7_scheme *sc) +{ + s7_uint let_counter = S7_INT64_MAX; + s7_pointer last_slot = NULL; + while (true) + { + if (let_counter == sc->capture_let_counter) + { + if (last_slot == NULL) + { + add_slot_checked(sc, sc->curlet, caar(sc->code), sc->value); + last_slot = let_slots(sc->curlet); + } + else last_slot = add_slot_checked_at_end(sc, let_id(sc->curlet), last_slot, caar(sc->code), sc->value); /* was unchecked */ + } + else + { + set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, caar(sc->code), sc->value)); + last_slot = let_slots(sc->curlet); + let_counter = sc->capture_let_counter; + } + sc->code = cdr(sc->code); + if (is_pair(sc->code)) + { + const s7_pointer val = cdar(sc->code); + if (has_fx(val)) + sc->value = fx_call(sc, val); + else + { + push_stack_direct(sc, OP_LET_STAR1); + sc->code = car(val); + return(true); + }} + else break; + } + sc->code = sc->args; /* original sc->code set in push_stack above */ + if (is_symbol(car(sc->code))) + { + const s7_pointer name = car(sc->code), body = cddr(sc->code), args = cadr(sc->code); + /* now we need to declare the new function (in the outer let) -- must delay this because init might reference same-name outer func */ + /* but the let name might be shadowed by a variable: (let* x ((x 1))...) so the name's symbol_id can be incorrect */ + begin_temp(sc->x, make_closure_unchecked(sc, args, body, T_CLOSURE_STAR, (is_null(args)) ? 0 : CLOSURE_ARITY_NOT_SET)); + if (symbol_id(name) > let_id(let_outlet(sc->curlet))) + { + const s7_int cur_id = symbol_id(name); + const s7_pointer cur_slot = local_slot(name); + symbol_set_id_unchecked(name, let_id(let_outlet(sc->curlet))); + add_slot_checked(sc, let_outlet(sc->curlet), name, sc->x); + symbol_set_id_unchecked(name, cur_id); + set_local_slot(name, cur_slot); + } + else add_slot_checked(sc, let_outlet(sc->curlet), name, sc->x); + end_temp(sc->x); + sc->code = body; + } + else sc->code = T_Pair(cdr(sc->code)); + return(false); +} + +static void op_let_star_na(s7_scheme *sc) +{ + /* fx safe does not mean we can dispense with the inner lets (curlet is safe for example) */ + s7_uint let_counter = S7_INT64_MAX; + sc->code = cdr(sc->code); + for (s7_pointer last_slot = NULL, vars = car(sc->code); is_pair(vars); vars = cdr(vars)) + { + const s7_pointer binding = car(vars); + const s7_pointer val = fx_call(sc, cdr(binding)); /* eval in outer let */ + if (let_counter == sc->capture_let_counter) + { + if (!last_slot) + { + add_slot_checked(sc, sc->curlet, car(binding), val); + last_slot = let_slots(sc->curlet); + } + else last_slot = add_slot_at_end(sc, let_id(sc->curlet), last_slot, car(binding), val); + } + else + { + set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, car(binding), val)); + last_slot = let_slots(sc->curlet); + let_counter = sc->capture_let_counter; + }} + sc->code = T_Pair(cdr(sc->code)); +} + +static void op_let_star_na_a(s7_scheme *sc) +{ + s7_uint let_counter = S7_INT64_MAX; + sc->code = cdr(sc->code); + for (s7_pointer last_slot = NULL, vars = car(sc->code); is_pair(vars); vars = cdr(vars)) + { + const s7_pointer binding = car(vars); + const s7_pointer val = fx_call(sc, cdr(binding)); + if (let_counter == sc->capture_let_counter) + { + if (!last_slot) + { + add_slot_checked(sc, sc->curlet, car(binding), val); + last_slot = let_slots(sc->curlet); + } + else last_slot = add_slot_at_end(sc, let_id(sc->curlet), last_slot, car(binding), val); + } + else + { + set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, car(binding), val)); + last_slot = let_slots(sc->curlet); + 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); /* code: (name vars ...) */ + set_curlet(sc, make_let(sc, sc->curlet)); + 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); + /* check_stack_size(sc); */ /* t101-42 but commented out */ + 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) +{ + const s7_pointer code = cdr(sc->code); + const s7_pointer caller = (letrec) ? sc->letrec_symbol : sc->letrec_star_symbol; + + if ((!is_pair(code)) || /* (letrec . 1) */ + (!is_list(car(code)))) /* (letrec 1 ...) */ + syntax_error_with_caller_nr(sc, "~A: variable list is messed up: ~A", 34, caller, sc->code); + + if (!is_pair(cdr(code))) /* (letrec ()) */ + syntax_error_with_caller_nr(sc, "~A has no body: ~A", 18, caller, sc->code); + + begin_small_symbol_set(sc); + for (s7_pointer vars = car(code); is_not_null(vars); vars = cdr(vars)) + { + s7_pointer sym, var; + if (!is_pair(vars)) /* (letrec ((a 1) . 2) ...) */ + syntax_error_with_caller_nr(sc, "~A: improper list of variables? ~A", 34, caller, sc->code); + + var = car(vars); + if (!is_pair(var)) /* (letrec (1 2) #t) */ + syntax_error_with_caller_nr(sc, "~A: bad variable ~S (should be a pair (name value))", 51, caller, var); + + sym = car(var); + if (!is_symbol(sym)) + error_nr(sc, sc->syntax_error_symbol, + set_elist_5(sc, wrap_string(sc, "bad variable name ~W in ~A (it is ~A, not a symbol) in ~A", 57), + sym, caller, object_type_name(sc, sym), + object_to_string_truncated(sc, sc->code))); + if (is_constant_symbol(sc, sym)) + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, caller, vars)); + + if (!is_pair(cdr(var))) /* (letrec ((x . 1))...) */ + { + if (is_null(cdr(var))) /* (letrec ((x)) x) */ + syntax_error_with_caller_nr(sc, "~A: variable declaration has no value?: ~A", 42, caller, var); + syntax_error_with_caller_nr(sc, "~A: variable declaration is not a proper list?: ~A", 50, caller, var); + } + if (is_not_null(cddr(var))) /* (letrec ((x 1 2 3)) ...) */ + syntax_error_with_caller_nr(sc, "~A: variable declaration has more than one value?: ~A", 53, caller, var); + + /* 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_small_symbol_set(sc, sym)) + syntax_error_with_caller_nr(sc, "~A: duplicate identifier: ~A", 28, caller, sym); + add_symbol_to_small_symbol_set(sc, sym); + set_local(sym); + } + end_small_symbol_set(sc); + + if (!s7_is_proper_list(sc, cdr(code))) + syntax_error_with_caller_nr(sc, "stray dot in ~A body: ~S", 24, caller, cdr(code)); + + for (s7_pointer vars = 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_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) +{ + for (s7_pointer slot = let_slots(sc->curlet); is_not_slot_end(slot); slot = next_slot(slot)) + if (is_closure(slot_value(slot))) + { + const 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_pars(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)); + } +} + +static void op_letrec2(s7_scheme *sc) +{ + for (s7_pointer slot = let_slots(sc->curlet); is_not_slot_end(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) +{ + const 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 -- it is #. + * 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) + */ + set_curlet(sc, make_let(sc, sc->curlet)); + if (is_pair(car(code))) + { + s7_pointer slot; + for (s7_pointer vars = car(code); is_not_null(vars); vars = cdr(vars)) + { + slot = add_slot_checked(sc, sc->curlet, caar(vars), sc->undefined); + slot_set_pending_value(slot, sc->undefined); + slot_set_expression(slot, cdar(vars)); + set_checked_slot(slot); + } + for (slot = let_slots(sc->curlet); is_not_slot_end(slot) && (has_fx(slot_expression(slot))); slot = next_slot(slot)) + slot_set_pending_value(slot, fx_call(sc, slot_expression(slot))); + if (is_not_slot_end(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); is_not_slot_end(slot) && (has_fx(slot_expression(slot))); slot = next_slot(slot)) + slot_set_pending_value(slot, fx_call(sc, slot_expression(slot))); + if (is_not_slot_end(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) +{ + const s7_pointer 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 + */ + set_curlet(sc, make_let(sc, sc->curlet)); + if (is_pair(car(code))) + { + s7_pointer slot; + for (s7_pointer vars = car(code); is_not_null(vars); vars = cdr(vars)) + { + slot = add_slot_checked(sc, sc->curlet, caar(vars), sc->undefined); + slot_set_expression(slot, cdar(vars)); + } + let_set_slots(sc->curlet, reverse_slots(let_slots(sc->curlet))); + + for (slot = let_slots(sc->curlet); is_not_slot_end(slot) && (has_fx(slot_expression(slot))); slot = next_slot(slot)) + slot_set_value(slot, fx_call(sc, slot_expression(slot))); + if (is_not_slot_end(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); is_not_slot_end(slot) && (has_fx(slot_expression(slot))); slot = next_slot(slot)) + slot_set_value(slot, fx_call(sc, slot_expression(slot))); + if (is_not_slot_end(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) +{ + const s7_pointer form = sc->code, code = cdr(sc->code); + bool all_fx, all_s7; + + if ((!is_pair(code)) || /* (let-temporarily . 1) */ + (!is_list(car(code)))) /* (let-temporarily 1 ...) */ + syntax_error_nr(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 (s7_pointer vars = car(code); is_not_null(vars); vars = cdr(vars)) + { + s7_pointer var, sym; + if (!is_pair(vars)) /* (let-temporarily ((a 1) . 2) ...) */ + syntax_error_nr(sc, "let-temporarily: improper list of variables? ~A", 47, form); + + var = car(vars); + if (!is_pair(var)) /* (let-temporarily (1 2) #t) */ + syntax_error_nr(sc, "let-temporarily: bad variable ~S (it should be a pair (name value))", 67, var); + + sym = car(var); + if (is_symbol(sym)) + { + if (is_constant_symbol(sc, sym)) /* (let-temporarily ((pi 3)) ...) */ + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_temporarily_symbol, vars)); + } + else + if (!is_pair(sym)) /* (let-temporarily ((1 2)) ...) */ + syntax_error_nr(sc, "let-temporarily: bad variable ~S (it should be a symbol or a pair)", 66, sym); + + if (!is_pair(cdr(var))) /* (let-temporarily ((x . 1))...) */ + syntax_error_nr(sc, "let-temporarily: variable declaration value is messed up: ~S", 60, var); + + if (is_not_null(cddr(var))) /* (let-temporarily ((x 1 2 3)) ...) */ + syntax_error_nr(sc, "let-temporarily: variable declaration has more than one value?: ~A", 66, var); + + if ((all_fx) && + ((!is_symbol(sym)) || (!is_fxable(sc, cadr(var))))) /* if all_fx, each var is (symbol fxable-expr) */ + all_fx = false; + if ((all_s7) && + ((!is_pair(sym)) || (car(sym) != sc->starlet_symbol) || + (!is_quoted_symbol(sc, cadr(sym))) || (is_keyword(cadr(cadr(sym)))) || + (!is_fxable(sc, cadr(var))))) + all_s7 = false; + } + if (!s7_is_proper_list(sc, cdr(code))) + syntax_error_nr(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_A : OP_LET_TEMP_NA) : OP_LET_TEMP_S7); + for (s7_pointer vars = car(code); is_pair(vars); vars = cdr(vars)) + fx_annotate_arg(sc, cdar(vars), sc->curlet); + + if ((optimize_op(form) == OP_LET_TEMP_A) && (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 + if (all_s7) /* not OP_LET_TEMP_NA */ + { + const s7_pointer var = caar(code); + if ((is_fxable(sc, cadr(var))) && /* code: ((((*s7* 'openlets) fxable-expr)) ...) */ + (is_null(cdar(code)))) + { + if ((is_quoted_symbol(sc, cadar(var))) && + (starlet_symbol_id(cadr(cadar(var))) == sl_openlets)) /* (cadr(cadar(var)) == make_symbol_with_strlen(sc, "openlets"))) */ + { + pair_set_syntax_op(form, OP_LET_TEMP_S7_OPENLETS); + set_opt1_pair(form, cdr(var)); + }}} + if ((is_fx_treeable(code)) && (curlet_has_slots(sc))) + { + fx_curlet_tree(sc, code); + fx_curlet_tree_in(sc, code); + }} + 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); + const s7_pointer 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)) + { + /* (let-temporarily (((setter (slot-symbol cp) (slot-env cp)) #f)) ...) reactive.scm */ + 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 void op_let_temp_init1_1(s7_scheme *sc) +{ + if ((is_symbol(sc->value)) && (is_symbol_from_symbol(sc->value))) /* (let-temporarily (((symbol ...))) ..) */ + { + clear_symbol_from_symbol(sc->value); + if (is_immutable_symbol(sc->value)) + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_temporarily_symbol, sc->value)); + sc->value = s7_symbol_value(sc, sc->value); + } + set_caddr(sc->args, cons(sc, sc->value, caddr(sc->args))); +} + +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); + const s7_pointer settee = car(binding); + const s7_pointer new_value = cadr(binding); + set_cadr(sc->args, cons(sc, settee, cadr(sc->args))); + binding = cdddr(sc->args); + set_car(binding, cons_unchecked(sc, new_value, car(binding))); + set_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))); + }} + set_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_pair, goto_do_unchecked, goto_pop_read_list, + goto_read_tok, goto_feed_to, goto_set_unchecked} 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))) + { + const s7_pointer settee = caar(sc->args), p = cdddr(sc->args); + s7_pointer slot, new_value = caar(p); + set_car(p, cdar(p)); + set_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_LET_TEMP_INIT2); + return(goto_set_unchecked); + } + slot = s7_t_slot(sc, settee); + if (!is_slot(slot)) + unbound_variable_error_nr(sc, settee); + if (is_immutable_slot(slot)) + immutable_object_error_nr(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); + slot_set_value(slot, (slot_has_setter(slot)) ? call_setter(sc, slot, new_value) : new_value); + } + set_car(sc->args, cadr(sc->args)); + /* pop_stack(sc); */ /* this clobbers sc->args! 7-May-22 */ + unstack_gc_protect(sc); /* pop_stack_no_args(sc) in effect */ + sc->code = cdr(stack_end_code(sc)); + 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); +} + +bool op_let_temp_done1(s7_scheme *sc) +{ + while (is_pair(car(sc->args))) + { + const s7_pointer settee = caar(sc->args), p = cddr(sc->args); + /* fprintf(stderr, "args: %s\n", display(sc->args)); */ + sc->value = caar(p); + set_car(p, cdar(p)); + set_car(sc->args, cdar(sc->args)); + /* fprintf(stderr, " args: %s\n", display(sc->args)); */ + + if ((is_pair(settee)) && (car(settee) == sc->starlet_symbol) && /* (let-temporarily (((*s7* (symbol "print-length")) 43))...) */ + ((is_symbol_and_keyword(cadr(settee))) || + (is_quoted_symbol(sc, cadr(settee))))) + { + s7_pointer sym = cadr(settee); + if (is_pair(sym)) sym = cadr(sym); else sym = keyword_symbol(sym); + starlet_set_1(sc, T_Sym(sym), sc->value); + /* fprintf(stderr, "sym: %s, val: %s, args: %s\n", display(sym), display(sc->value), display(sc->args)); */ + } + else + { + s7_pointer slot; + if (!is_symbol(settee)) + { + push_stack_direct(sc, OP_LET_TEMP_DONE1); /* save args and (pending) body value==sc->code */ + 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_function, sc->value)); + else sc->code = set_plist_3(sc, sc->set_symbol, settee, sc->value); + return(false); /* goto set_unchecked */ + } + slot = s7_t_slot(sc, settee); + if (is_immutable_slot(slot)) + immutable_object_error_nr(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); /* not unstack */ + 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 *starlet_immutable_field = NULL; + +static bool op_let_temp_s7(s7_scheme *sc) /* all entries are of the form ((*s7* 'field) fx-able-value) */ +{ + const s7_pointer code = cdr(sc->code); /* don't use sc->code here -- it can be changed */ + s7_pointer *end = sc->stack_end; + for (s7_pointer vars = car(code); is_pair(vars); vars = cdr(vars)) + { + s7_pointer old_value; + const s7_pointer field = cadadr(caar(vars)); /* p: (((*s7* 'expansions?) #f)) -- no keywords here (see check_let_temporarily) */ + if (starlet_immutable_field[starlet_symbol_id(field)]) + immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "let-temporarily: can't set! (*s7* '~S)", 38), field)); + old_value = starlet(sc, starlet_symbol_id(field)); + /* check_stack_size(sc); */ /* t101-42 but commented out (probably the #symbol stuff) */ + push_stack(sc, OP_LET_TEMP_S7_UNWIND, old_value, field); + } + for (s7_pointer vars = car(code); is_pair(vars); vars = cdr(vars), end += 4) + starlet_set_1(sc, T_Sym(end[0]), fx_call(sc, cdar(vars))); + sc->code = cdr(code); + return(is_pair(sc->code)); /* sc->code can be null if no body */ +} + +static void op_let_temp_s7_unwind(s7_scheme *sc) +{ + starlet_set_1(sc, T_Sym(sc->code), sc->args); + if (is_multiple_value(sc->value)) + sc->value = splice_in_values(sc, multiple_value(sc->value)); +} + +static bool op_let_temp_s7_openlets(s7_scheme *sc) +{ + s7_pointer new_val; + push_stack_no_code(sc, OP_LET_TEMP_S7_OPENLETS_UNWIND, (sc->has_openlets) ? sc->T : sc->F); + new_val = fx_call(sc, opt1_pair(sc->code)); + sc->has_openlets = (new_val != sc->F); + sc->code = cddr(sc->code); /* cddr is body of let-temp */ + return(is_pair(sc->code)); +} + +static void op_let_temp_s7_openlets_unwind(s7_scheme *sc) +{ + sc->has_openlets = (sc->args != sc->F); + if (is_multiple_value(sc->value)) + sc->value = splice_in_values(sc, multiple_value(sc->value)); +} + +void let_temp_done(s7_scheme *sc, s7_pointer args, s7_pointer let) +{ + /* called in call/cc, call-with-exit and, catch (unwind to catch) */ + check_stack_size(sc); + push_stack_direct(sc, OP_GC_PROTECT); + sc->args = T_Ext(args); + set_curlet(sc, let); + op_let_temp_done1(sc); +} + +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); +} + +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 bool op_let_temp_na(s7_scheme *sc) /* all entries are of the form (symbol fx-able-value) */ +{ + s7_pointer *end = sc->stack_end; + sc->code = cdr(sc->code); + + for (s7_pointer vars = car(sc->code); is_pair(vars); vars = cdr(vars)) + { + const s7_pointer var = car(vars); + const s7_pointer settee = car(var); + const s7_pointer slot = s7_slot(sc, settee); + if (!is_slot(slot)) unbound_variable_error_nr(sc, settee); + if (is_immutable_slot(slot)) + immutable_object_error_nr(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 (s7_pointer vars = car(sc->code); is_pair(vars); vars = cdr(vars), end += 4) + { + s7_pointer var = car(vars); + s7_pointer new_val = fx_call(sc, cdr(var)); + const s7_pointer 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_a(s7_scheme *sc) /* one entry */ +{ + s7_pointer var, settee, slot; + sc->code = cdr(sc->code); + var = caar(sc->code); + settee = car(var); + slot = s7_slot(sc, settee); + if (!is_slot(slot)) /* (define (f) (let-temporarily ((_asdf_ 32)) (+ 1 2))) (catch #t f (lambda args args)) (f) */ + unbound_variable_error_nr(sc, settee); + if (is_immutable_slot(slot)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->let_temporarily_symbol, settee)); + push_stack(sc, OP_LET_TEMP_UNWIND, slot_value(slot), slot); + { + s7_pointer 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) /* one entry, body is fx'd */ +{ + s7_pointer result; + op_let_temp_a(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; + const s7_pointer let = sc->curlet; + sc->code = cdr(sc->code); + var = caaar(sc->code); + sym = fx_call(sc, cdr(var)); + set_curlet(sc, fx_call(sc, cddr(var))); + slot = s7_t_slot(sc, sym); + set_curlet(sc, let); + 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_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))) + syntax_error_nr(sc, "quote: not enough arguments: ~A", 31, code); + syntax_error_nr(sc, "quote: stray dot?: ~A", 21, code); + } + if (is_not_null(cddr(code))) /* (quote . (1 2)) or (quote 1 1) */ + syntax_error_nr(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, check_or and check_if might not be called -- optimize_syntax can short-circuit it to return fx* choices */ + s7_pointer p; + const s7_pointer 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 = (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) */ + syntax_error_nr(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); + }} + if ((is_fx_treeable(code)) && (curlet_has_slots(sc))) fx_curlet_tree(sc, code); + set_current_code(sc, sc->code); + 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; + const s7_pointer 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 = (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)) + syntax_error_nr(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); + + if ((is_fx_treeable(code)) && (curlet_has_slots(sc))) fx_curlet_tree(sc, code); + set_current_code(sc, sc->code); + 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 fb_if_annotate(s7_scheme *sc, s7_pointer code, s7_pointer form) +{ + 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)); + fb_annotate(sc, form, code, OP_IF_B_A); + } + else fb_annotate(sc, form, code, OP_IF_B_P); + } + if (optimize_op(form) == OP_IF_A_R) + fb_annotate(sc, form, code, OP_IF_B_R); + if (optimize_op(form) == OP_IF_A_N_N) + fb_annotate(sc, form, 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, code, OP_IF_B_A_P); + } + fx_annotate_args(sc, cdr(code), sc->curlet); + } + 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)); + fb_annotate(sc, form, code, OP_IF_B_P_A); + } + else fb_annotate(sc, form, code, OP_IF_B_P_P); + } +} + +#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 */ +{ + const s7_pointer code = cdr(form); + s7_pointer test = car(code); + bool not_case = false; + + 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_nc(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)); + if ((is_fx_treeable(code)) && (curlet_has_slots(sc))) fx_curlet_tree(sc, code); + fb_if_annotate(sc, code, form); + return; + } + if ((is_h_safe_c_s(test)) && + (is_symbol(car(test)))) + { + uint8_t 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) + { + if (is_fxable(sc, caddr(code))) + { + set_opt2_pair(form, cddr(code)); + if (is_fxable(sc, cadr(code))) + { + set_opt1_pair(form, cdr(code)); + fx_annotate_args(sc, cdr(code), sc->curlet); + pair_set_syntax_op(form, OP_IF_IS_TYPE_S_A_A); + } + else + { + set_opt1_any(form, cadr(code)); + pair_set_syntax_op(form, OP_IF_IS_TYPE_S_P_A); + fx_annotate_arg(sc, cddr(code), sc->curlet); + } + if ((is_fx_treeable(code)) && (curlet_has_slots(sc))) fx_curlet_tree(sc, code); + } + else + if (is_fxable(sc, cadr(code))) + { + set_opt2_any(form, caddr(code)); + set_opt1_pair(form, cdr(code)); + fx_annotate_arg(sc, cdr(code), sc->curlet); + pair_set_syntax_op(form, OP_IF_IS_TYPE_S_A_P); + if ((is_fx_treeable(code)) && (curlet_has_slots(sc))) fx_curlet_tree(sc, code); + }}} + 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) || (optimize_op(test) == OP_AND_2A)) + { + if (optimize_op(test) == OP_OR_2A) + pair_set_syntax_op(form, choose_if_optc(IF_OR2, one_branch, reversed, not_case)); + else 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)); + fb_if_annotate(sc, code, form); + } + 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)); + } + if ((is_fx_treeable(code)) && (curlet_has_slots(sc))) + fx_curlet_tree(sc, 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(sc, 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) + { + if (is_fxable(sc, caddr(code))) + { + if ((is_fx_treeable(code)) && (curlet_has_slots(sc))) fx_curlet_tree(sc, code); + set_opt2_pair(form, cddr(code)); /* opt1_any set above to cadr(code) */ + if (is_fxable(sc, cadr(code))) + { + pair_set_syntax_op(form, OP_IF_S_A_A); + fx_annotate_args(sc, cdr(code), sc->curlet); + set_opt1_pair(form, cdr(code)); + } + else + { + pair_set_syntax_op(form, OP_IF_S_P_A); + fx_annotate_arg(sc, cddr(code), sc->curlet); + } + if ((is_fx_treeable(code)) && (curlet_has_slots(sc))) fx_curlet_tree(sc, code); + } + else + if (is_fxable(sc, cadr(code))) + { + pair_set_syntax_op(form, OP_IF_S_A_P); + fx_annotate_arg(sc, cdr(code), sc->curlet); + if ((is_fx_treeable(code)) && (curlet_has_slots(sc))) fx_curlet_tree(sc, code); + set_opt1_pair(form, cdr(code)); + set_opt2_any(form, caddr(code)); + }}} +} + +/* (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) +{ + const s7_pointer code = cdr(form); + s7_pointer cdr_code; + if (!is_pair(code)) /* (if) or (if . 1) */ + syntax_error_nr(sc, "(if): if needs at least 2 expressions: ~A", 41, form); + + cdr_code = cdr(code); + if (!is_pair(cdr_code)) /* (if 1) */ + { + if (is_null(cdr(code))) + syntax_error_nr(sc, "~S: if needs another clause", 27, form); + syntax_error_nr(sc, "~S: stray dot?", 14, form); /* (if 1 . 2) */ + } + if (is_pair(cdr(cdr_code))) + { + if (is_not_null(cddr(cdr_code))) /* (if 1 2 3 4) */ + syntax_error_nr(sc, "too many clauses for if: ~A", 27, form); + } + else + if (is_not_null(cdr(cdr_code))) /* (if 1 2 . 3) */ + syntax_error_nr(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); + set_current_code(sc, sc->code); + 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)) ? T_Pos(car(sc->code)) : T_Pos(car_unchecked(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) +{ + const s7_pointer form = sc->code, code = cdr(sc->code); + + if (!is_pair(code)) /* (when) or (when . 1) */ + syntax_error_nr(sc, "when has no expression or body: ~A", 35, form); + if (!is_pair(cdr(code))) /* (when 1) or (when 1 . 1) */ + syntax_error_nr(sc, "when has no body?: ~A", 22, form); + if (!s7_is_proper_list(sc, cddr(code))) + syntax_error_nr(sc, "when: stray dot? ~A", 19, 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 + { + const s7_pointer test = car(code); + if (is_safe_symbol(sc, 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)); + set_current_code(sc, sc->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_pair_set_up_begin_unchecked(sc); + return(false); + } + sc->value = sc->unspecified; + return(true); +} + + +/* -------------------------------- unless -------------------------------- */ +static void check_unless(s7_scheme *sc) +{ + const s7_pointer form = sc->code, code = cdr(sc->code); + + if (!is_pair(code)) /* (unless) or (unless . 1) */ + syntax_error_nr(sc, "unless has no expression or body: ~A", 37, form); + if (!is_pair(cdr(code))) /* (unless 1) or (unless 1 . 1) */ + syntax_error_nr(sc, "unless has no body?: ~A", 24, form); + if (!s7_is_proper_list(sc, cddr(code))) + syntax_error_nr(sc, "unless: stray dot? ~A", 21, 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(sc, 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)); + set_current_code(sc, sc->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_pair_set_up_begin_unchecked(sc); + return(false); + } + sc->value = sc->unspecified; + return(true); +} + + +/* -------------------------------- begin -------------------------------- */ +static bool op_begin(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer form = cdr(code); + if (!s7_is_proper_list(sc, form)) /* proper list includes () */ + syntax_error_nr(sc, "unexpected dot? ~A", 18, code); + if (is_null(form)) /* (begin) -> () */ + { + sc->value = sc->nil; + return(true); + } + pair_set_syntax_op(sc->code, ((is_pair(cdr(form))) && (is_null(cddr(form)))) ? OP_BEGIN_2_UNCHECKED : OP_BEGIN_UNCHECKED); /* begin_1 doesn't happen much */ + return(false); +} + + +/* -------------------------------- define -------------------------------- */ +static s7_pointer print_truncate(s7_scheme *sc, s7_pointer code) +{ + if (tree_len(sc, code) > sc->print_length) + { + s7_pointer obj; + const s7_int old_len = sc->print_length; + sc->print_length = old_len * 10; + obj = object_to_string_truncated(sc, code); + sc->print_length = old_len; + return(obj); + } + return(code); +} + +static void check_define(s7_scheme *sc) +{ + s7_pointer func, caller; + const s7_pointer code = cdr(sc->code); + const 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)) + syntax_error_with_caller_nr(sc, "~A: nothing to define? ~A", 25, caller, sc->code); /* (define) */ + + if (!is_pair(cdr(code))) + { + if (is_null(cdr(code))) + syntax_error_with_caller_nr(sc, "~A: no value? ~A", 16, caller, sc->code); /* (define var) */ + syntax_error_with_caller_nr(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) */ + error_nr(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) + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "~A's first argument, ~A, is ~A but should be a list: (name ...)", 63), + caller, car(code), object_type_name(sc, car(code)))); + func = car(code); + if (!is_symbol(func)) /* (define 3 a) */ + syntax_error_with_caller2_nr(sc, "~A: can't define ~W (~A); it should be a symbol or a non-nil list", 65, caller, func, object_type_name(sc, func)); + if (is_keyword(func)) /* (define :hi 1) */ + syntax_error_with_caller_nr(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, 256, "%s: syntactic keywords tend to behave badly if redefined: %s\n", display(func), display_truncated(sc->code)); + 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)) && + (is_global(caadr(code)))) + { + if ((is_defined_global(func)) && (is_immutable(global_slot(func))) && (initial_value_is_defined(sc, func))) + immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "can't ~A ~S: it is immutable", 28), caller, func)); + if (!is_pair(cdadr(code))) /* (define x (lambda . 1)) */ + syntax_error_with_caller_nr(sc, "~A: stray dot? ~A", 17, caller, sc->code); + if (!is_pair(cddr(cadr(code)))) /* (define f (lambda (arg))) */ + syntax_error_with_caller_nr(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)), cadr(code)); + else check_lambda_args(sc, cadadr(code), NULL, cadr(code)); + 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) */ + syntax_error_with_caller2_nr(sc, "~A: can't define ~S, ~A (should be a symbol or a non-nil list)", 62, caller, func, object_type_name(sc, func)); + if (is_syntactic_symbol(func)) /* (define (and a) a) */ + { + if (sc->safety > no_safety) + s7_warn(sc, 256, "%s: syntactic keywords tend to behave badly if redefined: %s\n", display(func), display_truncated(sc->code)); + set_local(func); + } + if ((is_defined_global(func)) && (is_immutable(global_slot(func))) && (initial_value_is_defined(sc, func))) /* (define (abs x) 1) after (immutable! abs) */ + immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "can't ~A ~S: it is immutable", 28), caller, func)); + if (starred) + set_cdar(code, check_lambda_star_args(sc, cdar(code), cdr(code), sc->code)); + else check_lambda_args(sc, cdar(code), NULL, sc->code); + optimize_lambda(sc, !starred, func, cdar(code), cdr(code)); + } + if (sc->cur_op == OP_DEFINE) + { + if ((is_pair(car(code))) && + (!is_possibly_constant(func))) + pair_set_syntax_op(sc->code, OP_DEFINE_FUNCHECKED); + else pair_set_syntax_op(sc->code, OP_DEFINE_UNCHECKED); + } + else pair_set_syntax_op(sc->code, (starred) ? OP_DEFINE_STAR_UNCHECKED : OP_DEFINE_CONSTANT_UNCHECKED); +} + +static bool op_define_unchecked(s7_scheme *sc) +{ + const s7_pointer code = cdr(sc->code); + s7_pointer locp; + + if ((is_pair(car(code))) && (has_location(car(code)))) + locp = car(code); + else locp = ((is_pair(cadr(code))) && (has_location(cadr(code)))) ? cadr(code) : 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))) + { + const s7_pointer definee = car(code); + sc->code = cadr(code); + if (is_pair(sc->code)) + { + push_stack_no_args(sc, OP_DEFINE1, definee); + sc->cur_op = optimize_op(sc->code); + return(true); + } + sc->value = (is_symbol(sc->code)) ? lookup_global(sc, sc->code) : sc->code; + sc->code = definee; + } + else + { + const s7_pointer 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. + */ + const s7_pointer func = 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(func), pair_location(locp)); + set_has_location(closure_body(func)); + } + sc->value = T_Ext(func); + 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, pars; + new_cell_unchecked(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); + + pars = closure_pars(new_func); + if (is_null(pars)) + { + let_set_slots(new_let, slot_end); + return(new_let); + } + if (is_safe_closure(new_func)) + { + s7_pointer last_slot = NULL; + if (is_closure(new_func)) + { + if (is_pair(pars)) + { + last_slot = make_slot(sc, car(pars), sc->nil); + slot_set_next(last_slot, slot_end); + let_set_slots(new_let, last_slot); + symbol_set_local_slot(car(pars), let_id(new_let), last_slot); + for (pars = cdr(pars); is_pair(pars); pars = cdr(pars)) + last_slot = add_slot_at_end(sc, let_id(new_let), last_slot, car(pars), sc->nil); + } + if (is_symbol(pars)) + { + if (last_slot) + last_slot = add_slot_checked_at_end(sc, let_id(new_let), last_slot, pars, sc->nil); + else + { + last_slot = make_slot(sc, pars, sc->nil); + slot_set_next(last_slot, slot_end); + let_set_slots(new_let, last_slot); + symbol_set_local_slot(pars, 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); + for (; is_pair(pars); pars = cdr(pars)) + { + s7_pointer par = car(pars); + if (is_pair(par)) + { + const 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->rest_keyword) + { + pars = cdr(pars); + slot = add_slot_checked(sc, new_let, car(pars), 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(pars)) + { + slot = add_slot_checked(sc, new_let, pars, sc->nil); /* set up rest pars */ + set_is_rest_slot(slot); + slot_set_expression(slot, sc->nil); + } + if (is_not_slot_end(let_slots(new_let))) + { + let_set_slots(new_let, reverse_slots(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); /* if unsafe closure, parameter-holding-let will be created on each call */ + return(new_let); +} + +static bool op_define_constant(s7_scheme *sc) +{ + const s7_pointer code = cdr(sc->code); + if ((!is_pair(code)) || (!is_pair(cdr(code)))) /* (define-constant) */ + syntax_error_nr(sc, "define-constant: not enough arguments: ~S", 41, sc->code); + + if (is_symbol_and_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); + } + syntax_error_with_caller_nr(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)) && + (is_global(car(code))) && /* else (let iter ... (define-constant iter iter) ...) -> segfault on later calls */ + (is_null(cddr(code)))) + { + const s7_pointer sym = car(code); + set_immutable_slot(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)) + { + const s7_pointer slot = s7_t_slot(sc, sc->code); + set_possibly_constant(sc->code); + set_immutable_slot(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) +{ + const s7_pointer code = cdr(sc->code); + const s7_pointer func_name = caar(code); + s7_pointer new_func; + + new_cell(sc, new_func, T_CLOSURE | ((!s7_is_proper_list(sc, cdar(code))) ? T_COPY_ARGS : 0)); + closure_set_pars(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, func_name, 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(func_name)) + sc->let_number++; /* dummy let, force symbol lookup */ + + /* see if func_name exists in curlet, reset its value if so */ + for (s7_pointer slot = let_slots(sc->curlet); is_not_slot_end(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == func_name) + { + if (is_immutable_slot(slot)) + syntax_error_nr(sc, "define ~S, but it is immutable", 30, func_name); + slot_set_value(slot, new_func); + symbol_set_local_slot(func_name, sc->let_number, slot); + if (sc->curlet == sc->rootlet) set_global_value(func_name, new_func); + set_local(func_name); + sc->value = new_func; + return; + } + /* else add a slot for func_name */ + if (sc->curlet == sc->rootlet) /* (let () (define (func) (with-let (rootlet) (define (f x) (+ x 1)))) (func) (func)) */ + s7_define(sc, sc->rootlet, func_name, new_func); + else add_slot_unchecked(sc, sc->curlet, func_name, new_func, sc->let_number); + sc->value = new_func; +} + +static s7_pointer check_define_macro(s7_scheme *sc, opcode_t op, s7_pointer form) +{ + s7_pointer mac_name, args; + const s7_pointer caller = cur_op_to_caller(sc, op); + + if (!is_pair(sc->code)) /* (define-macro . 1) */ + syntax_error_with_caller_nr(sc, "~A name missing (stray dot?): ~A", 32, caller, sc->code); + if (!is_pair(car(sc->code))) /* (define-macro a ...) */ + wrong_type_error_nr(sc, caller, 1, car(sc->code), wrap_string(sc, "a list: (name ...)", 18)); + + mac_name = caar(sc->code); + if (!is_symbol(mac_name)) + syntax_error_with_caller_nr(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, 256, "%s: syntactic keywords tend to behave badly if redefined: %s\n", display(mac_name), display_truncated(sc->code)); + set_local(mac_name); + } + if (is_constant_symbol(sc, mac_name)) + syntax_error_with_caller_nr(sc, "~A: ~S is constant", 18, caller, mac_name); + + if (!is_pair(cdr(sc->code))) /* (define-macro (...)) */ + syntax_error_with_caller_nr(sc, "~A ~A, but no body?", 19, caller, mac_name); + + if (s7_list_length(sc, cdr(sc->code)) < 0) /* (define-macro (hi) 1 . 2) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "~A: macro body messed up, ~A", 28), caller, sc->code)); + + args = cdar(sc->code); + if ((!is_list(args)) && + (!is_symbol(args))) + error_nr(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))) + error_nr(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, form); + } + else set_cdar(sc->code, check_lambda_star_args(sc, args, NULL, form)); + return(sc->code); +} + +static s7_pointer check_macro(s7_scheme *sc, opcode_t op, s7_pointer form) +{ + s7_pointer args; + const s7_pointer caller = cur_op_to_caller(sc, op); + + if (!is_pair(sc->code)) /* sc->code = cdr(form) */ /* (macro) or (macro . 1) */ + syntax_error_with_caller_nr(sc, "~S: ~S has no parameters or body?", 33, caller, form); + if (!is_pair(cdr(sc->code))) /* (macro (a)) */ + syntax_error_with_caller_nr(sc, "~S: ~S has no body?", 19, caller, form); + + args = car(sc->code); + if ((!is_list(args)) && + (!is_symbol(args))) + error_nr(sc, sc->syntax_error_symbol, /* (macro #(0) ...) */ + set_elist_2(sc, wrap_string(sc, "macro parameter list is ~S?", 27), args)); + + if ((op == OP_MACRO) || (op == OP_BACRO)) + { + for (; is_pair(args); args = cdr(args)) + if (!is_symbol(car(args))) + error_nr(sc, sc->syntax_error_symbol, /* (macro (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, form); + } + else set_car(sc->code, check_lambda_star_args(sc, args, NULL, form)); + if (s7_list_length(sc, cdr(sc->code)) < 0) /* (macro () 1 . 2) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "~A: macro body messed up, ~A", 28), caller, form)); + + return(sc->code); +} + +static void op_macro(s7_scheme *sc) /* (macro (x) `(+ ,x 1)) */ +{ + const s7_pointer form = sc->code; + 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, form); + set_mac_is_ok(sc->code); /* the !is_pair case raised an error in check_macro */ + } + sc->value = make_macro(sc, sc->cur_op, false); +} + +static void op_define_macro(s7_scheme *sc) +{ + const s7_pointer form = sc->code; + sc->code = cdr(sc->code); + check_define_macro(sc, sc->cur_op, form); + if ((is_immutable(sc->curlet)) && + (is_let(sc->curlet))) + syntax_error_nr(sc, "define-macro ~S: let is immutable", 33, caar(sc->code)); /* need syntax_error_any_with_caller? */ + sc->value = make_macro(sc, sc->cur_op, true); +} + +static bool unknown_any(s7_scheme *sc, s7_pointer func, s7_pointer code); + +static opcode_t fixup_macro_d(s7_scheme *sc, opcode_t op, s7_pointer mac) +{ + if (closure_arity_unknown(mac)) + closure_set_arity(mac, s7_list_length(sc, closure_pars(mac))); + return(op); +} + +static inline bool op_macro_d(s7_scheme *sc, uint8_t typ) +{ + sc->value = lookup(sc, car(sc->code)); + if (type(sc->value) != typ) /* for-each (etc) called a macro before, now it's something else -- a very rare case (ca. 20 cases in s7test.scm) */ + return(unknown_any(sc, sc->value, sc->code)); /* see m4 in tmac.scm, macro -> macro* could be handled in place: call apply_macro_star_1(sc) */ + sc->args = cdr(sc->code); /* used to copy here, but that appears to be unnecessary */ + sc->code = sc->value; /* the macro */ + check_stack_size(sc); /* (define-macro (f) (f)) (f) */ + push_stack_op_let(sc, OP_EVAL_MACRO); + set_curlet(sc, inline_make_let(sc, closure_let(sc->code))); + return(false); /* fall into apply_lambda */ +} + +static void apply_macro_star_1(s7_scheme *sc); + +static bool op_macro_star_d(s7_scheme *sc) +{ + if (op_macro_d(sc, T_MACRO_STAR)) return(true); + apply_macro_star_1(sc); + return(false); +} + +static void transfer_macro_info(s7_scheme *sc, s7_pointer mac) +{ + const 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 void check_c_macro_args(s7_scheme *sc, s7_pointer mac, s7_pointer args) +{ + const s7_int len = proper_list_length(args); + if (len < c_macro_min_args(sc->code)) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_4(sc, wrap_string(sc, "~A: not enough arguments: (~A~{~^ ~S~})", 39), sc->code, sc->code, sc->args)); + if (c_macro_max_args(sc->code) < len) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_4(sc, wrap_string(sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), sc->code, sc->code, sc->args)); +} + +static goto_t op_expansion(s7_scheme *sc) +{ + const s7_pointer caller = (is_pair(stack_top_args(sc))) ? car(stack_top_args(sc)) : sc->F; /* this can be garbage */ + if ((sc->stack_end > sc->stack_start) && /* there is a stack... */ + (stack_top_op(sc) != OP_READ_QUOTE) && /* '(expansion ...) */ + (stack_top_op(sc) != OP_READ_VECTOR) && /* #(expansion ...) */ + (!is_quote(sc, caller)) && /* (#_quote ...) */ + (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 */ + { + const s7_pointer symbol = car(sc->value); + if (!is_let(sc->curlet)) set_curlet(sc, sc->rootlet); + + if (is_symbol(symbol)) /* maybe (#_cond-expand) etc */ + { + s7_pointer slot; + if ((is_global(symbol)) || (sc->curlet == sc->nil)) + slot = global_slot(symbol); + else slot = s7_t_slot(sc, symbol); + sc->code = (is_slot(slot)) ? slot_value(slot) : sc->undefined; + } + else sc->code = symbol; + + if ((!is_any_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); + if (is_c_macro(sc->code)) + { + check_c_macro_args(sc, sc->code, sc->args); + sc->value = c_macro_call(sc->code)(sc, sc->args); + return(goto_start); + } + set_curlet(sc, 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); /* apply_lambda probably handles arg number checks */ + 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) */ +{ + check_c_macro_args(sc, 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: set_curlet(sc, make_let(sc, closure_let(sc->code))); return(goto_apply_lambda); + case T_BACRO: set_curlet(sc, make_let(sc, sc->curlet)); return(goto_apply_lambda); + case T_MACRO_STAR: set_curlet(sc, make_let(sc, closure_let(sc->code))); apply_macro_star_1(sc); return(goto_begin); + case T_BACRO_STAR: set_curlet(sc, 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: syntax_error_nr(sc, "macroexpand argument is not a macro call: ~A", 44, sc->args); /* maybe car(sc->args)? */ + } + if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: we should not be here\n", __func__, __LINE__); + return(fall_through); /* for the compiler */ +} + +static goto_t op_macroexpand(s7_scheme *sc) +{ + const 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)))) + syntax_error_nr(sc, "macroexpand argument is not a macro call: ~A", 44, form); + if (!is_null(cdr(sc->code))) + syntax_error_nr(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)) */ + syntax_error_nr(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))) + syntax_error_nr(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 (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: op: %s, value: %s\n", __func__, __LINE__, op_names[stack_top_op(sc)], display_truncated(sc->value)); + if (sc->value == sc->no_value) + { + if (stack_top_op(sc) != OP_LOAD_RETURN_IF_EOF) /* latter op if empty expansion at top-level */ + { + if (stack_top_op(sc) != OP_READ_LIST) /* OP_EVAL_STRING: (eval-string "(reader-cond...)") where reader-cond returns (values) */ + sc->value = sc->F; /* (eval-string "") -> #f, was nil_string for awhile */ + else set_stack_top_op(sc, OP_READ_NEXT); + /* OP_READ_DONE: (eval-string (object->string (with-input-from-string "(reader-cond ((provided? 'surreals) 123))" read))) */ + }} + else + if (is_pair(sc->value)) + sc->value = copy_body(sc, sc->value); +} + + +/* -------------------------------- with-let -------------------------------- */ +static s7_pointer fx_with_let_s(s7_scheme *sc, s7_pointer arg) +{ + const s7_pointer code = cdr(arg); + s7_pointer let = lookup_checked(sc, car(code)); + const s7_pointer sym = cadr(code); + s7_pointer val; + if (!is_let(let)) + { + let = find_let(sc, let); + if (!is_let(let)) + { + s7_pointer new_let = find_let(sc, let); + if ((!is_let(new_let)) || (new_let == sc->rootlet)) + find_let_error_nr(sc, sc->with_let_symbol, let, new_let, 1, set_mlist_1(sc, let)); + let = new_let; + }} + /* let here if mock-hash can be (for example) (inlet 'value (hash-table 'b 2) 'mock-type mock-hash-table?) + * mock-hash has let-ref-fallback which calls (#_hash-table-ref (env 'value) sym) -> (env 'value) is a hash-table, so returns #f (missing-key-value?) if not in table + * we go directly to this function in check_with_let to avoid this ambiguity + */ + val = let_ref(sc, let, sym); /* (with-let env s) -> (let-ref env s), "s" unevalled */ + if (val == sc->undefined) /* but sym can have the value #: (with-let (inlet 'x #) x) */ + { + if (is_slot(global_slot(sym))) /* (let () (define (func) (with-let *s7* letrec*)) (func) (func)), .5 tlet */ + return(global_value(sym)); /* used to check also that e=*s7* */ + if (is_slot(lookup_slot_with_let(sc, sym, let))) /* check for explicit # value! */ + return(sc->undefined); + unbound_variable_error_nr(sc, sym); + } + return(val); +} + +static bool check_with_let(s7_scheme *sc) +{ + const s7_pointer form = cdr(sc->code); + if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: op: %s, form: %s\n", __func__, __LINE__, op_names[stack_top_op(sc)], display_truncated(form)); + if (!is_pair(form)) /* (with-let . "hi") */ + syntax_error_nr(sc, "with-let takes a let (an environment) argument: ~A", 50, sc->code); + if (is_null(cdr(form))) /* (with-let e) */ + syntax_error_nr(sc, "with-let has no body: ~A", 24, sc->code); + if (!s7_is_proper_list(sc, cdr(form))) /* (with-let e . 3) */ + syntax_error_nr(sc, "stray dot in with-let body: ~S", 30, sc->code); + if ((sc->safety > 1) && (is_symbol(car(form))) && (is_c_function(initial_value(car(form))))) + s7_warn(sc, 256, "%s is a strange first argument to with-let\n", display(car(form))); /* (with-let curlet ...) where they probably meant (with-let (curlet) ...) */ + set_current_code(sc, sc->code); + if ((is_normal_symbol(car(form))) && + (is_normal_symbol(cadr(form))) && /* (with-let lt a) is not the same as (with-let lt :a) */ + (is_null(cddr(form)))) + { + pair_set_syntax_op(sc->code, OP_WITH_LET_S); + sc->value = fx_with_let_s(sc, sc->code); + return(false); + } + else pair_set_syntax_op(sc->code, OP_WITH_LET_UNCHECKED); + return(true); +} + +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 void activate_starlet(s7_scheme *sc) +{ + const s7_pointer new_let = let_copy(sc, sc->starlet); /* get fallback methods */ + const s7_pointer iter = s7_make_iterator(sc, sc->starlet); + gc_protect_2_via_stack(sc, new_let, iter); + iterator_carrier(iter) = cons_unchecked(sc, sc->F, sc->F); + set_has_carrier(iter); + while (true) + { + const s7_pointer field = s7_iterate(sc, iter); /* next *s7* field as '(symbol . value) */ + if (iterator_is_at_end(iter)) break; + if (lookup_unexamined(sc, car(field))) + add_slot_checked_with_id(sc, new_let, car(field), cdr(field)); + } + set_curlet(sc, new_let); + set_immutable_let(new_let); + unstack_gc_protect(sc); +} + +static void activate_with_let(s7_scheme *sc, s7_pointer let) +{ + if (!is_let(let)) /* (with-let . "hi") */ + { + const s7_pointer new_let = find_let(sc, let); /* sc->nil/rootlet here means no let found */ + if (!is_let(new_let)) + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "with-let takes a let (an environment) argument: ~A", 50), let)); + let = new_let; + } + if (let == sc->rootlet) + set_curlet(sc, let); /* (with-let (rootlet) ...) */ + else + if (let == sc->starlet) + activate_starlet(sc); + else + { + set_with_let_let(let); + let_set_id(let, ++sc->let_number); + set_curlet(sc, let); + update_symbol_ids(sc, let); + } +} + + +/* -------------------------------- cond -------------------------------- */ +static void check_cond(s7_scheme *sc) +{ + bool has_feed_to = false, result_fx = true, result_single = true; + s7_pointer clauses; + const s7_pointer code = cdr(sc->code), form = sc->code; + + if (!is_pair(code)) /* (cond) or (cond . 1) */ + syntax_error_nr(sc, "cond, but no body: ~A", 21, form); + + for (clauses = code; is_pair(clauses); clauses = cdr(clauses)) + if (!is_pair(car(clauses))) /* (cond 1) or (cond (#t 1) 3) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "every clause in cond must be a pair: ~S in ~A", 45), + car(clauses), object_to_string_truncated(sc, form))); + else + { + const s7_pointer clause = car(clauses); + if (!s7_is_proper_list(sc, cdr(clause))) /* (cond (xxx . 1)) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "stray dot? ~S in ~A", 19), + clause, object_to_string_truncated(sc, form))); + if (is_pair(cdr(clause))) + { + if (is_pair(cddr(clause))) result_single = false; + if (is_undefined_feed_to(sc, cadr(clause))) + { + has_feed_to = true; + if (!is_pair(cddr(clause))) /* (cond (#t =>)) or (cond (#t => . 1)) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "cond: '=>' target missing? ~S in ~A", 36), + clauses, object_to_string_truncated(sc, form))); + if (is_pair(cdddr(clause))) /* (cond (1 => + abs)) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "cond: '=>' has too many targets: ~S in ~A", 41), + clauses, object_to_string_truncated(sc, form))); + }} + else result_single = false; + } + if (is_not_null(clauses)) /* (cond ((1 2)) . 1) */ + error_nr(sc, sc->syntax_error_symbol, set_elist_2(sc, wrap_string(sc, "cond: stray dot? ~S", 19), form)); + + for (clauses = code; is_pair(clauses); clauses = cdr(clauses)) + { + s7_pointer clause = car(clauses); + /* clear_has_fx(clause); */ /* a kludge -- if has_fx here (and not re-fx'd below), someone messed up earlier -- but was fx_treeable set? */ + if (is_fxable(sc, car(clause))) + fx_annotate_arg(sc, clause, sc->curlet); + for (clause = cdr(clause); is_pair(clause); clause = cdr(clause)) + if (!has_fx(clause)) + { + s7_function func = fx_choose(sc, clause, sc->curlet, let_symbol_is_safe); + if (func) set_fx_direct(clause, func); else result_fx = false; + }} + if ((is_fx_treeable(code)) && (curlet_has_slots(sc))) fx_curlet_tree(sc, code); + + if (has_feed_to) + { + pair_set_syntax_op(form, OP_COND_UNCHECKED); + if (is_null(cdr(code))) + { + const s7_pointer arg2 = caddar(code); + if ((is_proper_list_3(sc, arg2)) && + (car(arg2) == sc->lambda_symbol)) + { + const s7_pointer arg = cadr(arg2); + if ((is_pair(arg)) && + (is_null(cdr(arg))) && + (is_symbol(car(arg)))) /* (define (hi) (cond (#t => (lambda (s) s)))) looking at (s) */ + { + set_opt2_lambda(code, arg2); /* (lambda ...) above */ + pair_set_syntax_op(form, OP_COND_FEED); + }}}} + else + { + s7_pointer clause; + bool xopt = true; + int32_t i; + pair_set_syntax_op(form, OP_COND_SIMPLE); + for (i = 0, clause = code; xopt && (is_pair(clause)); i++, clause = cdr(clause)) + xopt = ((has_fx(car(clause))) && (is_pair(cdar(clause)))); + if (xopt) + { + pair_set_syntax_op(form, (result_fx) ? OP_COND_NA_NA : ((result_single) ? OP_COND_NA_NP_O : OP_COND_NA_NP)); + if (result_single) + { + if (i == 2) + { + s7_pointer p = caadr(code); + if ((p == sc->T) || ((p == sc->else_symbol) && (is_global(sc->else_symbol)))) + pair_set_syntax_op(form, OP_COND_NA_2E); + } + else + if (i == 3) + { + s7_pointer p = caaddr(code); + if ((p == sc->T) || ((p == sc->else_symbol) && (is_global(sc->else_symbol)))) + pair_set_syntax_op(form, OP_COND_NA_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); + } + if ((S7_DEBUGGING) && (is_multiple_value(sc->value))) fprintf(stderr, "cond1 mv case %s\n", display(sc->value)); + pop_stack(sc); + return(true); + } + sc->code = cdr(sc->code); /* go to next clause */ + 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); + sc->code = caar(sc->code); + sc->cur_op = optimize_op(sc->code); + return(true); + }} + if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: we should not be here\n", __func__, __LINE__); + 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 ((S7_DEBUGGING) && (is_multiple_value(sc->value))) fprintf(stderr, "cond1_simple mv case %s\n", display(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_na_np(s7_scheme *sc) /* all tests are fxable, results may be a mixture, no =>, no missing results */ +{ + for (s7_pointer p = cdr(sc->code); is_pair(p); p = cdr(p)) + if (is_true(sc, fx_call(sc, car(p)))) + { + for (s7_pointer p1 = T_Lst(cdar(p)); is_pair(p1); p1 = cdr(p1)) + if (has_fx(T_Pair(p1))) + sc->value = fx_call(sc, p1); + else + { + if (is_pair(cdr(p1))) + push_stack_no_args(sc, OP_COND_NA_NP_1, cdr(p1)); + sc->code = car(p1); + return(false); + } + return(true); + } + sc->value = sc->unspecified; + return(true); +} + +static bool op_cond_na_np_1(s7_scheme *sc) /* continuing to handle a multi-statement result from cond_na_np */ +{ + for (s7_pointer 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_NA_NP_1, cdr(p)); + sc->code = car(p); + return(false); + } + return(true); +} + +static Inline bool inline_op_cond_na_np_o(s7_scheme *sc) /* all tests are fxable, results may be a mixture, no =>, no missing results, all result one expr */ +{ /* called once in eval, b case cb lg rclo str */ + for (s7_pointer args = cdr(sc->code); is_pair(args); args = cdr(args)) + if (is_true(sc, fx_call(sc, car(args)))) + { + s7_pointer p1 = cdar(args); + if (has_fx(T_Pair(p1))) + { + sc->value = fx_call(sc, p1); + return(true); + } + sc->code = car(p1); + return(false); + } + sc->value = sc->unspecified; + return(true); +} + +static inline bool fx_cond_value(s7_scheme *sc, s7_pointer args) +{ + if (has_fx(args)) + { + sc->value = fx_call(sc, args); + return(true); + } + sc->code = car(args); + return(false); +} + +static bool op_cond_na_2e(s7_scheme *sc) +{ + s7_pointer args = cdr(sc->code); + return(fx_cond_value(sc, (is_true(sc, fx_call(sc, car(args)))) ? cdar(args) : cdadr(args))); +} + +static bool op_cond_na_3e(s7_scheme *sc) +{ + s7_pointer args = cdr(sc->code); + if (is_true(sc, fx_call(sc, car(args)))) + return(fx_cond_value(sc, cdar(args))); + args = cdr(args); + return(fx_cond_value(sc, (is_true(sc, fx_call(sc, car(args)))) ? cdar(args) : cdadr(args))); +} + +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 void op_cond_feed_1(s7_scheme *sc) +{ + if ((S7_DEBUGGING) && (is_multiple_value(sc->value))) fprintf(stderr, "%s %s unexpected mv\n", __func__, display(sc->value)); + set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, caadr(opt2_lambda(sc->code)), sc->value)); + sc->code = caddr(opt2_lambda(sc->code)); +} + +static bool feed_to(s7_scheme *sc) +{ + if (is_multiple_value(sc->value)) /* (... ((values 1 2) => +)) more or less s7test.scm 29539 */ + { + 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); /* goto APPLY */ + }} + 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); + /* it would be nice to see T_C_FUNCTION here and call apply_c_function_unopt, but that requires either a switch (to continue) or putting this in the eval function */ + return(true); /* goto APPLY */ + } + 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); /* goto EVAL */ +} + + +/* -------------------------------- set! -------------------------------- */ +static void check_set(s7_scheme *sc) +{ + const s7_pointer form = sc->code, code = cdr(sc->code); + s7_pointer settee, value; + if (!is_pair(code)) + { + if (is_null(code)) /* (set!) */ + syntax_error_nr(sc, "set!: not enough arguments: ~A", 30, form); + syntax_error_nr(sc, "set!: stray dot? ~A", 19, form); /* (set! . 1) */ + } + settee = car(code); + + if (!is_pair(cdr(code))) + { + if (is_null(cdr(code))) /* (set! var) */ + syntax_error_nr(sc, "set!: not enough arguments: ~A", 30, form); + syntax_error_nr(sc, "set!: stray dot? ~A", 19, form); /* (set! var . 1) */ + } + value = cadr(code); /* the value has not yet been evaluated */ + + if ((is_not_null(cddr(code))) || /* (set! var 1 2) */ + ((is_pair(value)) && + (car(value) == sc->values_symbol) && /* (set! var (values...) but 0 or 1 arg is ok */ + (is_pair(cdr(value))) && /* this can be fooled if we rename values, etc */ + (is_pair(cddr(value))))) + syntax_error_nr(sc, "~A: too many arguments to set!", 30, form); + + if (is_pair(settee)) + { + if ((is_pair(car(settee))) && + (!is_list(cdr(settee)))) /* (set! ('(1 2) . 0) 1) */ + syntax_error_nr(sc, "improper list of arguments to set!: ~A", 38, form); + if (!s7_is_proper_list(sc, settee)) /* (set! ("hi" . 1) #\a) or (set! (#(1 2) . 1) 0) */ + syntax_error_nr(sc, "set! target is an improper list: (set! ~A ...)", 46, settee); + } + else + if (!is_symbol(settee)) /* (set! 12345 1) */ + error_nr(sc, sc->syntax_error_symbol, /* (set! #_abs 32) -> "error: set! can't change #_abs (a c-function)" */ + (is_c_function(settee)) ? set_elist_2(sc, wrap_string(sc, "set! can't change ~S (a c-function)", 35), settee) : + set_elist_4(sc, wrap_string(sc, "set! can't change ~S (~A), ~S", 29), settee, sc->type_names[type(settee)], form)); + + else + if (is_keyword(settee)) /* (set! :hi 3) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "set!: can't change keyword's value: ~S in ~S", 44), settee, form)); + + if (is_pair(settee)) /* here we have (set! (...) ...) */ + { + pair_set_syntax_op(form, OP_SET_UNCHECKED); /* if not pair car, op_set_normal below */ + if (is_symbol(car(settee))) + { + if (is_null(cdr(settee))) /* (set! (symbol) ...) */ + { + if (is_fxable(sc, value)) + { + pair_set_syntax_op(form, OP_SET_opSq_A); /* (set! (symbol) fxable) */ + fx_annotate_arg(sc, cdr(code), sc->curlet); /* cdr(code) = value */ + }} + else + if (is_null(cddr(settee))) /* we check cddr(code) above */ /* this leaves (set! (vect i j) 1) unhandled so we go to OP_SET_UNCHECKED */ + { + const s7_pointer index = cadr(settee); + if (is_fxable(sc, index)) + { + if ((car(settee) == sc->let_ref_symbol) && (!is_pair(cddr(settee)))) /* perhaps also check for hash-table-ref */ + /* (let () (define (func) (catch #t (lambda () (set! (let-ref (list 1)) 1)) (lambda args 'error))) (func) (func)) */ + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_2(sc, wrap_string(sc, "set!: not enough arguments for let-ref: ~S", 42), sc->code)); + fx_annotate_arg(sc, cdr(settee), sc->curlet); /* cdr(settee) -> index */ + if (is_fxable(sc, value)) + { + pair_set_syntax_op(form, OP_SET_opSAq_A); /* (set! (symbol fxable) fxable) */ + /* perhaps: if "S" is a known function (etc), split this -- the runtime check for a macro here is very expensive + * fprintf(stderr, "(set! %s %s)\n", display(settee), display(value)); + * S=vector[tnum]/hash-table/c_func/s7/setter[tset]/var-*[lt]/c-obj[tobj]/dilambda[tstar] + * so, if not any_macro OP_SET_opFAq_A else OP_SET_opMAq_A? or just the latter + * also (set! (car a) b) -> (set-car! a b), (set! (cfunc a) b) -> ((setter cfunc) a b) + * set_opsaq_a as "unknown" equivalent -> all the special cases which check just their case, maybe a no-parcel option + */ + fx_annotate_arg(sc, cdr(code), sc->curlet); /* cdr(code) -> value */ + + if (car(settee) == sc->starlet_symbol) /* (set! (*s7* 'field) value) */ + { + s7_pointer sym = (is_symbol(index)) ? + ((is_keyword(index)) ? keyword_symbol(index) : index) : + ((is_quoted_symbol(sc, index)) ? cadr(index) : index); + if ((is_symbol(sym)) && (starlet_symbol_id(sym) != sl_no_field)) + { + /* perhaps preset field -> op_print_length_set[misc?]|safety[tstar] etc */ + set_safe_optimize_op(form, OP_IMPLICIT_STARLET_SET_S); + set_opt3_sym(form, sym); + }}} + else pair_set_syntax_op(form, OP_SET_opSAq_P); /* (set! (symbol fxable) any) */ + }} + else + if ((is_null(cdddr(settee))) && + (car(settee) != sc->with_let_symbol)) /* (set! (with-let lt a) 32) needs to be handled by op_set_with_let_1 */ + { + const s7_pointer index1 = cadr(settee), index2 = caddr(settee); + if ((is_fxable(sc, index1)) && (is_fxable(sc, index2))) + { + fx_annotate_args(sc, cdr(settee), sc->curlet); /* cdr(settee) -> index1 and 2 */ + if (is_fxable(sc, value)) + { + pair_set_syntax_op(form, OP_SET_opSAAq_A); /* (set! (symbol fxable fxable) fxable) */ + fx_annotate_arg(sc, cdr(code), sc->curlet); /* cdr(code) -> value */ + } + else pair_set_syntax_op(form, OP_SET_opSAAq_P); /* (set! (symbol fxable fxable) any) */ + }}} + return; + } + pair_set_syntax_op(form, OP_SET_NORMAL); + if (is_symbol(settee)) + { + const s7_pointer slot = s7_slot(sc, settee); + if ((is_slot(slot)) && + (!slot_has_setter(slot)) && + (!is_immutable(slot)) && + (!is_syntactic_symbol(settee)) && + (!s7_tree_memq(sc, sc->setter_symbol, value))) /* (set! x (set! (setter 'x) ...) ...)! */ + { + if (is_normal_symbol(value)) + { + const s7_pointer slot1 = s7_slot(sc, value); + if ((is_slot(slot1)) && (!slot_has_setter(slot1))) + { + pair_set_syntax_op(form, OP_SET_S_S); + set_opt2_sym(code, value); + }} + else + if ((!is_pair(value)) || + ((is_quote(sc, car(value))) && (is_pair(cdr(value))))) /* (quote . 1) ? */ + { + pair_set_syntax_op(form, OP_SET_S_C); + set_opt1_con(code, (is_pair(value)) ? cadr(value) : value); /* collision if ((values set!) x 32) code: (x 32) value: 32, opt2: fx_s, opt1|3 is free */ + } + else + { + const s7_pointer cddr_value = (is_pair(cdr(value))) ? cddr(value) : NULL; + pair_set_syntax_op(form, OP_SET_S_P); + if (is_optimized(value)) + { + if (optimize_op(value) == HOP_SAFE_C_SS) + { + if (settee == cadr(value)) + { + pair_set_syntax_op(form, OP_INCREMENT_SS); + /* fx_annotate_arg(sc, cddr_value, sc->curlet); */ /* this sets fx_proc(cddr_value) */ + set_opt2_pair(code, cddr_value); + } + else + { + pair_set_syntax_op(form, OP_SET_S_A); + fx_annotate_arg(sc, cdr(code), sc->curlet); + }} + else + { + if (is_fxable(sc, value)) + { + pair_set_syntax_op(form, OP_SET_S_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))) + { /* a=symbol case does happen here */ + pair_set_syntax_op(form, (is_symbol(caddr(value))) ? OP_INCREMENT_SS : OP_INCREMENT_SA); + fx_annotate_arg(sc, cddr_value, sc->curlet); /* this sets fx_proc(arg) -- usually set much earlier in optimize_lambda? */ + + /* an experiment */ + if ((has_fx(cddr_value)) && (fx_proc(cddr_value) == fx_multiply_sa)) + set_fx_direct(cddr_value, fx_multiply_sa_wrapped); + + set_opt2_pair(code, cddr_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_args(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_safe_c_op(optimize_op(value))) && /* else might not be opt1_cfunc? (opt1_lambda probably) */ + (!is_unsafe(value)) && /* is_unsafe(value) can happen! */ + (!is_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(sc, cadr(value))) && + (car(value) == sc->cons_symbol)) + { + pair_set_syntax_op(form, OP_SET_CONS); + set_opt2_sym(code, cadr(value)); + }}}}}} +} + +static void op_set_s_c(s7_scheme *sc) +{ + s7_pointer slot = T_Slt(s7_t_slot(sc, cadr(sc->code))); + if (is_immutable(slot)) + immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "~S, but ~S is immutable", 23), sc->code, cadr(sc->code))); + slot_set_value(slot, sc->value = opt1_con(cdr(sc->code))); +} + +static inline void op_set_s_s(s7_scheme *sc) +{ + s7_pointer slot = T_Slt(s7_t_slot(sc, cadr(sc->code))); + if (is_immutable(slot)) + immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "~S, but ~S is immutable", 23), sc->code, cadr(sc->code))); + slot_set_value(slot, sc->value = lookup(sc, opt2_sym(cdr(sc->code)))); +} + +static Inline void op_set_s_a(s7_scheme *sc) +{ + s7_pointer slot = T_Slt(s7_t_slot(sc, cadr(sc->code))); + if (is_immutable(slot)) + immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "~S, but ~S is immutable", 23), sc->code, cadr(sc->code))); + slot_set_value(slot, sc->value = fx_call(sc, cddr(sc->code))); +} + +static void op_set_s_p(s7_scheme *sc) +{ + check_stack_size(sc); + push_stack_no_args(sc, OP_SET_SAFE, cadr(sc->code)); /* only path to op_set_safe, but we're not safe! cadr(sc->code) might be immutable */ + sc->code = caddr(sc->code); +} + +static void op_set_safe(s7_scheme *sc) /* name is misleading -- we need to check for immutable slot, but no setter */ +{ + s7_pointer slot = s7_t_slot(sc, sc->code); + if (is_slot(slot)) + { + if (is_immutable_slot(slot)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->set_symbol, sc->code)); + slot_set_value(slot, sc->value); + } + else + if ((is_let(sc->curlet)) && (has_let_set_fallback(sc->curlet))) + sc->value = call_let_set_fallback(sc, sc->curlet, sc->code, sc->value); + else unbound_variable_error_nr(sc, sc->code); +} + +static void op_set_from_let_temp(s7_scheme *sc) +{ + s7_pointer settee = sc->code; + s7_pointer slot = s7_t_slot(sc, settee); + if (!is_slot(slot)) unbound_variable_error_nr(sc, settee); + if (is_immutable_slot(slot)) + immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "let-temporarily can't reset ~S: it is immutable!", 48), settee)); + slot_set_value(slot, (slot_has_setter(slot)) ? call_setter(sc, slot, sc->value) : sc->value); +} + +static inline void op_set_cons(s7_scheme *sc) +{ + s7_pointer slot = s7_t_slot(sc, cadr(sc->code)); + 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_saa(s7_scheme *sc) +{ + s7_pointer slot, arg, val; + sc->code = cdr(sc->code); + slot = s7_t_slot(sc, car(sc->code)); + 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 = s7_t_slot(sc, car(sc->code)); + arg = opt2_pair(sc->code); /* cddr(value) */ + 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 void op_increment_ss(s7_scheme *sc) +{ + s7_pointer slot, arg; + sc->code = cdr(sc->code); + slot = s7_t_slot(sc, car(sc->code)); + arg = opt2_pair(sc->code); /* cddr(value) */ + set_car(sc->t2_2, lookup(sc, car(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 no_return void no_setter_error_nr(s7_scheme *sc, s7_pointer obj) +{ + /* sc->code here is form without set!: ((abs 1) 2) from (set! (abs 1) 2) + * but in implicit case, (let ((L (list 0))) (set! (L 0 0) 2)), code is ((0 0) 2) + * at entry to s7_error: ((0 0 2)?? but we print something from define-hook-function if in the repl + * add indices and new-value args, is unevaluated code always available? + */ + const int32_t typ = type(obj); + if (!is_pair(car(sc->code))) sc->code = cdr(sc->code); + + if (is_any_c_function(caar(sc->code))) + error_nr(sc, sc->no_setter_symbol, + set_elist_6(sc, wrap_string(sc, "~W (~A) does not have a setter: (set! (~W~{~^ ~S~}) ~S)", 55), + caar(sc->code), sc->type_names[typ], caar(sc->code), cdar(sc->code), cadr(sc->code))); + error_nr(sc, sc->no_setter_symbol, + set_elist_5(sc, wrap_string(sc, "~A (~A) does not have a setter: (set! ~S ~S)", 44), + caar(sc->code), sc->type_names[typ], + (is_pair(car(sc->code))) ? copy_any_list(sc, car(sc->code)) : car(sc->code), + (is_pair(cadr(sc->code))) ? sc->z = copy_any_list(sc, cadr(sc->code)) : cadr(sc->code))); + /* copy is necessary due to the way quoted lists|symbols are handled in op_set_with_let_1|2 and copy_tree + * copy_proper_list can fail: (let ((x #f)) (map set! `((set! x (+ x 1)) (* x 2)) (hash-table 'a 1))) + */ +} + +static bool pair3_cfunc(s7_scheme *sc, s7_pointer obj, s7_pointer setf, s7_pointer arg, s7_pointer value) +{ + if (!c_function_is_aritable(setf, 2)) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_6(sc, wrap_string(sc, "set!: two arguments? (~A ~S ~S), ~A is (setter ~A)", 50), setf, arg, value, setf, obj)); + if (!is_safe_procedure(setf)) + sc->args = list_2(sc, arg, value); + else sc->args = with_list_t2(sc, arg, value); + sc->value = c_function_call(setf)(sc, sc->args); + return(false); +} + +static bool set_pair3(s7_scheme *sc, s7_pointer obj, s7_pointer arg, s7_pointer value) +{ + switch (type(obj)) + { + case T_C_OBJECT: + sc->value = (*(c_object_set(sc, obj)))(sc, with_list_t3(sc, obj, arg, value)); + break; + + case T_FLOAT_VECTOR: + sc->value = g_fv_set_3(sc, with_list_t3(sc, obj, arg, value)); + break; + case T_COMPLEX_VECTOR: /* cfft in tcomplex hits this */ + sc->value = complex_vector_set_p_ppp(sc, obj, arg, value); + break; + case T_INT_VECTOR: + sc->value = g_iv_set_3(sc, with_list_t3(sc, obj, arg, value)); + break; + case T_BYTE_VECTOR: + sc->value = g_bv_set_3(sc, with_list_t3(sc, obj, arg, value)); + break; + case T_VECTOR: + if (vector_rank(obj) > 1) + sc->value = g_vector_set(sc, with_list_t3(sc, obj, arg, value)); + else + { + s7_int index; + if (!is_t_integer(arg)) + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "vector-set!: index must be an integer: ~S", 41), sc->code)); + index = integer(arg); + if (index < 0) + error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "vector-set!: index must not be negative: ~S", 43), sc->code)); + if (index >= vector_length(obj)) + error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "vector-set!: index must be less than vector length: ~S", 54), sc->code)); + if (is_immutable_vector(obj)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->vector_set_symbol, obj)); + if (is_typed_vector(obj)) + value = typed_vector_setter(sc, obj, index, value); + else vector_element(obj, index) = value; + sc->value = T_Ext(value); + } + break; + + case T_STRING: + { + s7_int index; + if (!is_t_integer(arg)) + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "index must be an integer: ~S", 28), sc->code)); + index = integer(arg); + if (index < 0) + error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "index must not be negative: ~S", 30), sc->code)); + if (index >= string_length(obj)) + error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "index must be less than sequence length: ~S", 43), sc->code)); + if (is_immutable_string(obj)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->string_set_symbol, obj)); + if (!is_character(value)) + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "string-set!: value must be a character: ~S", 42), sc->code)); + string_value(obj)[index] = (char)s7_character(value); + sc->value = value; + } + break; + + case T_PAIR: + sc->value = g_list_set(sc, with_list_t3(sc, obj, arg, value)); + break; + + case T_HASH_TABLE: + if (is_immutable_hash_table(obj)) /* not checked in s7_hash_table_set */ + immutable_object_error_nr(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 = let_set_2(sc, obj, arg, value); /* this checks immutable */ + break; + + case T_C_RST_NO_REQ_FUNCTION: 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_c_function(c_function_setter(obj))) + return(pair3_cfunc(sc, obj, c_function_setter(obj), arg, value)); + sc->code = c_function_setter(obj); /* closure/macro */ + sc->args = (needs_copied_args(sc->code)) ? list_2(sc, arg, value) : set_plist_2(sc, arg, value); + return(true); /* goto APPLY; not redundant -- setter type might not match getter type */ + + case T_C_MACRO: /* (set! (setter quasiquote) (lambda args args)) (define (f) (set! (quasiquote 1) (setter 'i))) (f) (f) */ + if (is_c_function(c_macro_setter(obj))) + return(pair3_cfunc(sc, obj, c_macro_setter(obj), arg, value)); + sc->code = c_macro_setter(obj); + sc->args = (needs_copied_args(sc->code)) ? list_2(sc, arg, value) : set_plist_2(sc, arg, value); + return(true); /* goto APPLY; */ + + case T_MACRO: case T_MACRO_STAR: + case T_BACRO: case T_BACRO_STAR: + case T_CLOSURE: case T_CLOSURE_STAR: + if (is_c_function(closure_setter_or_map_list(obj))) + return(pair3_cfunc(sc, obj, closure_setter(obj), arg, value)); + sc->code = closure_setter_or_map_list(obj); + sc->args = (needs_copied_args(sc->code)) ? list_2(sc, arg, value) : set_plist_2(sc, arg, value); + return(true); /* goto APPLY; */ + + default: + no_setter_error_nr(sc, obj); /* possibly a continuation/goto? */ + } + return(false); +} + +static bool op_set_opsq_a(s7_scheme *sc) /* (set! (symbol) fxable) */ +{ + s7_pointer setf, value; + const s7_pointer code = cdr(sc->code), obj = lookup_checked(sc, caar(code)); + + if ((is_sequence(obj)) && (!is_c_object(obj))) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, wrap_string(sc, "set!: not enough arguments for ~S: ~S", 37), caar(code), sc->code)); + + setf = setter_p_pp(sc, obj, sc->curlet); + if (is_any_macro(setf)) + { + sc->code = setf; + sc->args = cdr(code); + return(true); + } + value = fx_call(sc, cdr(code)); + if (is_c_function(setf)) + { + if (c_function_min_args(setf) > 1) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, wrap_string(sc, "set!: not enough arguments: (~A ~S)", 35), setf, value)); + sc->value = c_function_call(setf)(sc, with_list_t1(sc, value)); + return(false); + } + sc->code = setf; + sc->args = list_1(sc, value); + return(true); +} + +static bool op_set_opsaq_a(s7_scheme *sc) /* (set! (symbol fxable) fxable) */ +{ + s7_pointer index, value; + const s7_pointer code = cdr(sc->code), obj = lookup_checked(sc, caar(code)); + if (could_be_macro_setter(obj)) + { + const s7_pointer setf = setter_p_pp(sc, obj, sc->curlet); + if (is_any_macro(setf)) + { + sc->code = setf; + sc->args = pair_append(sc, cdar(code), cdr(code)); + return(true); /* goto APPLY (if false, continue) */ + }} + value = fx_call(sc, cdr(code)); + gc_protect_via_stack(sc, value); + if (dont_eval_args(obj)) /* this check is expensive, 8 in tstar, similar lg, but it's faster than is_any_macro */ + index = cadar(code); /* if obj is a c_macro, surely we don't want to evaluate cdar(code)? */ + else index = fx_call(sc, cdar(code)); + set_gc_protected2(sc, index); + return(set_pair3(sc, obj, index, value)); + /* set_pair3 can assume goto apply as above, and can push the setter on the stack preparing to goto apply, but that means + * we can't blithely unstack_gc_protect. + * (set! (setter for-each) map) (define (func) (set! (for-each (make-vector '(2 3 4) 1)) (vector-append))) (func) (func) + * set_pair3 -> pair3_cfunc which returns false even if it invokes map so we have no way to tell whether we can unstack. + */ +} + +static inline bool op_set_opsaq_p(s7_scheme *sc) +{ + const s7_pointer code = cdr(sc->code); + /* ([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_opSAq_P_1 and complain. + * (let () (define (hi) (let ((str "123")) (set! (str 0) (values #\a)) str)) (hi) (hi)) is "a23" + * (let ((v (make-vector '(2 3) 0))) (set! (v (values 0 1)) 23) v) -> #2D((0 23 0) (0 0 0)) + */ + const s7_pointer obj = lookup_checked(sc, caar(code)); + if (could_be_macro_setter(obj)) + { + s7_pointer setf = setter_p_pp(sc, obj, sc->curlet); + if (is_any_macro(setf)) + { + sc->code = setf; + sc->args = pair_append(sc, cdar(code), cdr(code)); + return(true); /* goto APPLY */ + }} + push_stack(sc, OP_SET_opSAq_P_1, obj, code); + sc->code = cadr(code); + return(false); /* goto EVAL */ +} + +static inline bool op_set_opsaq_p_1(s7_scheme *sc) +{ + s7_pointer value = sc->value; + s7_pointer index; + if (dont_eval_args(sc->args)) /* see above */ + index = cadar(sc->code); + else index = fx_call(sc, cdar(sc->code)); + return(set_pair3(sc, sc->args, index, value)); /* not lookup, (set! (_!asdf!_ 3) 'a) -> unbound_variable */ +} + +static bool pair4_cfunc(s7_scheme *sc, s7_pointer obj, s7_pointer setf, s7_pointer index1, s7_pointer index2, s7_pointer value) +{ + if (!c_function_is_aritable(setf, 3)) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_7(sc, wrap_string(sc, "set!: three arguments? (~A ~S ~S ~S), ~A is (setter ~A)", 55), setf, index1, index2, value, setf, obj)); + if (!is_safe_procedure(setf)) + { + sc->code = setf; + sc->args = list_3(sc, index1, index2, value); + return(true); + } + sc->value = c_function_call(setf)(sc, with_list_t3(sc, index1, index2, value)); + return(false); +} + +static bool set_pair4(s7_scheme *sc, s7_pointer obj, s7_pointer index1, s7_pointer index2, s7_pointer value) +{ + switch (type(obj)) + { + case T_C_OBJECT: + sc->value = (*(c_object_ref(sc, obj)))(sc, with_list_t2(sc, obj, index1)); + return(set_pair3(sc, sc->value, index2, value)); + + case T_FLOAT_VECTOR: + sc->value = g_float_vector_set(sc, set_plist_4(sc, obj, index1, index2, value)); + break; + case T_COMPLEX_VECTOR: + sc->value = g_complex_vector_set(sc, set_plist_4(sc, obj, index1, index2, value)); + break; + case T_INT_VECTOR: + sc->value = g_int_vector_set(sc, set_plist_4(sc, obj, index1, index2, value)); + break; + case T_BYTE_VECTOR: + sc->value = g_byte_vector_set(sc, set_plist_4(sc, obj, index1, index2, value)); + break; + case T_VECTOR: + if (vector_rank(obj) == 2) + sc->value = g_vector_set_4(sc, set_plist_4(sc, obj, index1, index2, value)); + else + { + sc->value = g_vector_ref(sc, with_list_t2(sc, obj, index1)); + return(set_pair3(sc, sc->value, index2, value)); + } + break; + + case T_PAIR: + sc->value = g_list_ref(sc, with_list_t2(sc, obj, index1)); + return(set_pair3(sc, sc->value, index2, value)); + + case T_HASH_TABLE: + sc->value = s7_hash_table_ref(sc, obj, index1); + return(set_pair3(sc, sc->value, index2, value)); + + case T_LET: + sc->value = let_ref(sc, obj, index1); + return(set_pair3(sc, sc->value, index2, value)); + + case T_C_RST_NO_REQ_FUNCTION: case T_C_FUNCTION: + case T_C_FUNCTION_STAR: /* obj here is any_c_function, but its setter could be a closure and vice versa below */ + if (is_c_function(c_function_setter(obj))) + return(pair4_cfunc(sc, obj, c_function_setter(obj), index1, index2, value)); + sc->code = c_function_setter(obj); /* closure|macro */ + sc->args = (needs_copied_args(sc->code)) ? list_3(sc, index1, index2, value) : set_plist_3(sc, index1, index2, value); + return(true); /* goto APPLY; not redundant -- setter type might not match getter type */ + + case T_C_MACRO: /* (set! (setter quasiquote) (lambda (a . b) a)) (let () (define (func) (set! (quasiquote 'a 0) 3)) (func) (func)) */ + if (is_c_function(c_macro_setter(obj))) + return(pair4_cfunc(sc, obj, c_macro_setter(obj), index1, index2, value)); + sc->code = c_macro_setter(obj); + sc->args = (needs_copied_args(sc->code)) ? list_3(sc, index1, index2, value) : set_plist_3(sc, index1, index2, value); + return(true); /* goto APPLY; */ + + case T_MACRO: case T_MACRO_STAR: + case T_BACRO: case T_BACRO_STAR: + case T_CLOSURE: case T_CLOSURE_STAR: + if (is_c_function(closure_setter_or_map_list(obj))) + return(pair4_cfunc(sc, obj, closure_setter(obj), index1, index2, value)); + sc->code = closure_setter_or_map_list(obj); + sc->args = (needs_copied_args(sc->code)) ? list_3(sc, index1, index2, value) : set_plist_3(sc, index1, index2, value); + return(true); /* goto APPLY; */ + + default: + no_setter_error_nr(sc, obj); /* possibly a continuation/goto or string */ + } + return(false); /* goto start */ +} + +static bool op_set_opsaaq_a(s7_scheme *sc) /* (set! (symbol fxable fxable) fxable) */ +{ + s7_pointer index1, value; + const s7_pointer code = cdr(sc->code), obj = lookup_checked(sc, caar(code)); + if (could_be_macro_setter(obj)) + { + const s7_pointer setf = setter_p_pp(sc, obj, sc->curlet); + if (is_any_macro(setf)) + { + sc->code = setf; + sc->args = pair_append(sc, cdar(code), cdr(code)); + return(true); + }} + value = fx_call(sc, cdr(code)); + gc_protect_via_stack(sc, value); + index1 = fx_call(sc, cdar(code)); + set_gc_protected2(sc, index1); + { + bool result = set_pair4(sc, obj, index1, fx_call(sc, cddar(code)), value); + if (!result) unstack_gc_protect(sc); /* see comment under op_set_opsaq_a above */ + return(result); + } +} + +static bool op_set_opsaaq_p(s7_scheme *sc) +{ + const s7_pointer code = cdr(sc->code), obj = lookup_checked(sc, caar(code)); + if (could_be_macro_setter(obj)) + { + const s7_pointer setf = setter_p_pp(sc, obj, sc->curlet); + if (is_any_macro(setf)) + { + sc->code = setf; + sc->args = pair_append(sc, cdar(code), cdr(code)); + return(true); + }} + push_stack(sc, OP_SET_opSAAq_P_1, obj, code); + sc->code = cadr(code); + return(false); +} + +static bool op_set_opsaaq_p_1(s7_scheme *sc) +{ + const s7_pointer value = sc->value; + bool result; + s7_pointer index1 = fx_call(sc, cdar(sc->code)); + gc_protect_via_stack(sc, index1); + result = set_pair4(sc, sc->args, index1, fx_call(sc, cddar(sc->code)), value); + if (!result) unstack_gc_protect(sc); + return(result); +} + +static bool op_set1(s7_scheme *sc) +{ + const s7_pointer sym = T_Sym(sc->code); /* protect from sc->code possible change in call_c_function_setter below */ + const s7_pointer slot = s7_slot(sc, sym); /* if unbound variable hook here, we need the binding, not the current value */ + if (is_slot(slot)) + { + if (is_immutable_slot(slot)) + { + if (s7_is_eqv(sc, slot_value(slot), sc->value)) return(true); /* (set! pi pi) -- this can be confusing! */ + /* eqv? needed here because 0 != 0 if one is int_zero and the other a mutable_integer from a loop, etc */ + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->set_symbol, sym)); + } + if (slot_has_setter(slot)) + { + const s7_pointer setter = slot_setter(slot); + if (is_c_function(setter)) + sc->value = call_c_function_setter(sc, setter, sym, sc->value); /* perhaps better: apply_c_function -- has argnum error checks */ + else + if (is_any_procedure(setter)) + { + /* don't push OP_EVAL_DONE here and call eval(sc, OP_APPLY) below -- setter might hit an error */ + /* 41297 (set! (v) val) where v=vector gets the setter, but calls vector-set! with no args */ + push_stack_no_args(sc, OP_SET_FROM_SETTER, slot); + if (has_let_arg(setter)) + sc->args = list_3(sc, sym, sc->value, sc->curlet); + else sc->args = list_2(sc, sym, sc->value); /* these lists are reused as the closure_let slots in apply_lambda via apply_closure */ + sc->code = setter; + return(false); /* goto APPLY */ + }} + slot_set_value(slot, sc->value); + symbol_increment_ctr(sym); /* see define setfib example in s7test.scm -- I'm having second thoughts about this... */ + return(true); /* continue */ + } + if ((!is_let(sc->curlet)) || /* (with-let (rootlet) (set! undef 3)) */ + (!has_let_set_fallback(sc->curlet))) /* (with-let (mock-hash-table 'b 2) (set! b 3)) */ + { + if (starlet_symbol_id(sym) != sl_no_field) + error_nr(sc, sc->unbound_variable_symbol, + set_elist_5(sc, wrap_string(sc, "unbound variable ~S in (set! ~S ~S), perhaps you meant (*s7* '~S)?", 66), sym, sym, sc->value, sym)); + error_nr(sc, sc->unbound_variable_symbol, set_elist_4(sc, wrap_string(sc, "~S is unbound in (set! ~S ~S)", 29), sym, sym, sc->value)); + } + sc->value = call_let_set_fallback(sc, sc->curlet, sym, sc->value); + return(true); +} + +static bool op_set_with_let_1(s7_scheme *sc) +{ + s7_pointer arg1, settee; + const s7_pointer val = sc->value; + /* from the T_SYNTAX branch of op_set_pair: (set! (with-let arg1 settee) val) as in let-temporarily + * here sc->value is the new value for the settee = val, args has the (as yet unevaluated) let and settee-expression. + * 'settee above can be a pair = generalized set in the 'arg1 environment. + */ + if (!is_pair(sc->args)) /* (set! (with-let) ...) */ + syntax_error_nr(sc, "with-let needs a let and a symbol: (set! (with-let) ~$)", 55, sc->value); + if (!is_pair(cdr(sc->args))) /* (set! (with-let e) ...) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "with-let in (set! (with-let ~S) ~$) has no symbol to set?", 57), car(sc->args), sc->value)); + + arg1 = car(sc->args); + settee = cadr(sc->args); + if (is_multiple_value(val)) /* (set! (with-let lt) (values 1 2)) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "can't (set! (with-let ~S ~S) (values ~{~S~^ ~})): too many values", 65), arg1, settee, val)); + if (is_symbol(arg1)) + { + if (is_symbol(settee)) + { + s7_pointer let = lookup_checked(sc, arg1); + if (!is_let(let)) + wrong_type_error_nr(sc, sc->let_set_symbol, 1, let, a_let_string); + sc->value = let_set_1(sc, let, settee, val); + pop_stack(sc); + return(true); + } + sc->value = lookup_checked(sc, arg1); + sc->code = set_plist_3(sc, sc->set_symbol, settee, ((is_symbol(val)) || (is_pair(val))) ? set_plist_2(sc, sc->quote_function, val) : val); + /* (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 = arg1; /* 'arg1 above, an expression we need to evaluate */ + sc->args = set_plist_2(sc, settee, val); /* 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 settee, val; + /* here sc->value = let, args = '(settee val) where 'settee might be a pair */ + if (!is_let(sc->value)) + wrong_type_error_nr(sc, sc->let_set_symbol, 1, sc->value, a_let_string); + settee = car(sc->args); + if ((!is_symbol(settee)) && (!is_pair(settee))) + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "can't set ~S in ~$", 18), settee, set_ulist_1(sc, global_value(sc->set_symbol), sc->args))); + val = cadr(sc->args); + if (is_symbol(settee)) /* settee is a symbol -- everything else is ready so call let-set! */ + { + sc->value = let_set_1(sc, sc->value, settee, val); + return(true); /* continue */ + } + if ((is_symbol(val)) || (is_pair(val))) /* (set! (with-let (inlet :v (vector 1 2)) (v 0)) 'a) */ + sc->code = list_3(sc, sc->set_symbol, settee, + ((is_symbol(val)) || (is_pair(val))) ? list_2(sc, sc->quote_function, val) : val); + else sc->code = cons(sc, sc->set_symbol, sc->args); /* (set! (with-let (curlet) (*s7* 'print-length)) 16), val=16 b=(*s7* 'print-length) */ + return(false); /* fall into SET_WITH_LET */ +} + +static bool op_set_normal(s7_scheme *sc) +{ + s7_pointer val; + sc->code = cdr(sc->code); + val = cadr(sc->code); + if (is_pair(val)) + { + push_stack_no_args(sc, OP_SET1, car(sc->code)); + sc->code = val; + return(true); + } + sc->value = (is_symbol(val)) ? lookup_checked(sc, val) : T_Ext(val); + sc->code = car(sc->code); + return(false); +} + +static Inline void inline_op_increment_by_1(s7_scheme *sc) /* ([set!] ctr (+ ctr 1)) -- why is this always inlined? saves 22 in concordance */ +{ + const s7_pointer slot = T_Slt(s7_t_slot(sc, cadr(sc->code))); + const s7_pointer val = slot_value(slot); + 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); + set_numerator(sc->value, numerator(val) + denominator(val)); + set_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(slot, sc->value); +} + +static void op_decrement_by_1(s7_scheme *sc) /* ([set!] ctr (- ctr 1)) */ +{ + const s7_pointer slot = T_Slt(s7_t_slot(sc, cadr(sc->code))); + const s7_pointer val = slot_value(slot); + 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); + set_numerator(sc->value, numerator(val) - denominator(val)); + set_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_2(sc, set_plist_2(sc, val, int_one)); + break; + } + slot_set_value(slot, sc->value); +} + + +/* ---------------- implicit ref/set ---------------- */ +static Inline bool inline_op_implicit_vector_ref_a(s7_scheme *sc) /* called once in eval, Inline because tnum/tmat get ridiculous call overhead (70!) */ +{ + s7_pointer ind; + const s7_pointer vec = lookup_checked(sc, car(sc->code)); + if (!is_any_vector(vec)) {sc->last_function = vec; return(false);} + ind = fx_call(sc, cdr(sc->code)); + if ((s7_is_integer(ind)) && (vector_rank(vec) == 1)) + { + s7_int index = s7_integer_clamped_if_gmp(sc, ind); + if ((index < vector_length(vec)) && (index >= 0)) + { + sc->value = (is_float_vector(vec)) ? make_real(sc, float_vector(vec, index)) : vector_getter(vec)(sc, vec, index); + return(true); + }} + sc->value = s7i_vector_ref_1(sc, vec, set_plist_1(sc, ind)); + return(true); +} + +static s7_pointer fx_implicit_vector_ref_a(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer ind; + const s7_pointer vec = lookup_checked(sc, car(arg)); + if (!is_any_vector(vec)) + return(s7_apply_function(sc, vec, list_1(sc, fx_call(sc, cdr(arg))))); + ind = fx_call(sc, cdr(arg)); + if ((s7_is_integer(ind)) && (vector_rank(vec) == 1)) + { + s7_int index = s7_integer_clamped_if_gmp(sc, ind); + if ((index < vector_length(vec)) && (index >= 0)) + return(vector_getter(vec)(sc, vec, index)); + } + return(s7i_vector_ref_1(sc, vec, set_plist_1(sc, ind))); +} + +static bool op_implicit_vector_ref_aa(s7_scheme *sc) /* tnum/tmat, neither uses fx case if available (see tmp) */ +{ + s7_pointer ind1, ind2, code; + const s7_pointer vec = lookup_checked(sc, car(sc->code)); + if (!is_any_vector(vec)) {sc->last_function = vec; return(false);} + code = cdr(sc->code); + ind1 = fx_call(sc, code); + gc_protect_via_stack(sc, ind1); + ind2 = fx_call(sc, cdr(code)); + set_gc_protected2(sc, ind2); + if ((s7_is_integer(ind1)) && (s7_is_integer(ind2)) && (vector_rank(vec) == 2)) + { + s7_int i1 = s7_integer_clamped_if_gmp(sc, ind1); + s7_int i2 = s7_integer_clamped_if_gmp(sc, ind2); + if ((i1 >= 0) && (i2 >= 0) && + (i1 < vector_dimension(vec, 0)) && (i2 < vector_dimension(vec, 1))) + { + s7_int index = (i1 * vector_offset(vec, 0)) + i2; + sc->value = (is_float_vector(vec)) ? make_real(sc, float_vector(vec, index)) : vector_getter(vec)(sc, vec, index); /* check for normal vector saves in some cases, costs in others */ + unstack_gc_protect(sc); + return(true); + }} + sc->value = s7i_vector_ref_1(sc, vec, set_plist_2(sc, ind1, ind2)); + unstack_gc_protect(sc); + return(true); +} + +static goto_t call_set_implicit(s7_scheme *sc, s7_pointer obj, s7_pointer inds, s7_pointer val, s7_pointer form); + +static void setup_eval_args_pair(s7_scheme *sc, s7_pointer obj, s7_pointer inds, s7_pointer val) +{ + push_stack(sc, OP_SET2, cdr(inds), val); + sc->code = list_2(sc, obj, car(inds)); + set_optimize_op(sc->code, OP_PAIR_ANY); /* usually an error: (#\a) etc, might be (#(0) 0) */ + sc->value = obj; + sc->code = cdr(sc->code); + push_op_stack(sc, sc->value); + if (sc->op_stack_now >= sc->op_stack_end) + resize_op_stack(sc); + sc->args = sc->nil; +} + +static goto_t set_implicit_vector(s7_scheme *sc, s7_pointer vect, s7_pointer inds, s7_pointer val, s7_pointer form) +{ + /* vect is the vector, sc->code is expr without the set!, form is the full expr, args have not been evaluated! */ + s7_pointer index; + s7_int argnum; + + if (!is_pair(inds)) + wrong_number_of_arguments_error_nr(sc, "no index for implicit vector-set!: ~S", 37, form); + if (is_immutable_vector(vect)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->vector_set_symbol, vect)); + + argnum = proper_list_length(inds); + if ((argnum > 1) && + (is_t_vector(vect)) && + (argnum != vector_rank(vect))) + { + /* this block needs to be first to handle (eg): + * (let ((v (vector (inlet 'a 0)))) (set! (v 0 'a) 32) v): #((inlet 'a 32)) + * sc->code here: ((v 0 'a) 32) + */ + if (vector_rank(vect) == 1) + { + s7_pointer ind = car(inds); + if (is_symbol(ind)) ind = lookup_checked(sc, ind); + if (is_t_integer(ind)) + { + s7_pointer obj; + const s7_int index1 = integer(ind); + if ((index1 < 0) || (index1 >= vector_length(vect))) + out_of_range_error_nr(sc, sc->vector_ref_symbol, int_two, car(inds), (index1 < 0) ? it_is_negative_string : it_is_too_large_string); + obj = vector_element(vect, index1); + if (!is_applicable(obj)) + error_nr(sc, sc->no_setter_symbol, + set_elist_5(sc, wrap_string(sc, "in ~S, (~S ~S) is ~S which can't take arguments", 47), form, vect, car(inds), obj)); + return(call_set_implicit(sc, obj, cdr(inds), val, form)); + }} + /* PERHAPS: do the loop here to collect the evaluated args, then call apply_vector */ + setup_eval_args_pair(sc, vect, inds, val); + return(goto_eval_args_pair); + } + if ((argnum > 1) || (vector_rank(vect) > 1)) + { + if ((argnum == vector_rank(vect)) && + (!is_pair(car(val)))) + { + s7_pointer p; + for (p = inds; is_pair(p); p = cdr(p)) + if (is_pair(car(p))) break; + if (is_null(p)) + { + s7_pointer pa; + const s7_pointer args = safe_list_if_possible(sc, argnum + 2); + if (in_heap(args)) gc_protect_via_stack(sc, args); + set_car(args, vect); + for (p = inds, 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)) + { + if (in_heap(args)) unstack_gc_protect(sc); + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "vector-set!: index must be an integer: ~S", 41), form)); + } + set_car(pa, index); + } + set_car(pa, car(val)); + if (is_symbol(car(pa))) + set_car(pa, lookup_checked(sc, car(pa))); + sc->value = g_vector_set(sc, args); + if (in_heap(args)) unstack_gc_protect(sc); + else clear_safe_list_in_use(sc, args); + return(goto_start); + }} + push_op_stack(sc, sc->vector_set_function); /* vector_setter(vect) has wrong args */ + sc->code = (is_null(cdr(inds))) ? val : ((is_null(cddr(inds))) ? cons(sc, cadr(inds), val) : pair_append(sc, cdr(inds), T_Lst(val))); /* i.e. rest(args) + val */ + push_stack(sc, OP_EVAL_ARGS4, list_1(sc, vect), sc->code); + sc->code = car(inds); + sc->cur_op = optimize_op(sc->code); + return(goto_top_no_pop); + } + /* one index, rank == 1 */ + index = car(inds); + if (!is_pair(index)) + { + s7_int ind; + s7_pointer value; + if (is_symbol(index)) + index = lookup_checked(sc, index); + if (!s7_is_integer(index)) + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "vector-set!: index must be an integer: ~S", 41), sc->code)); + ind = s7_integer_clamped_if_gmp(sc, index); + if ((ind < 0) || (ind >= vector_length(vect))) + out_of_range_error_nr(sc, sc->vector_set_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); + value = car(val); + if (!is_pair(value)) + { + if (is_symbol(value)) + value = lookup_checked(sc, value); + if (is_typed_t_vector(vect)) + typed_vector_setter(sc, vect, ind, value); + else vector_setter(vect)(sc, vect, ind, value); + sc->value = T_Ext(value); + return(goto_start); + } + push_op_stack(sc, sc->vector_set_function); + sc->args = list_2(sc, index, vect); + sc->code = val; + 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, vect), val); + push_op_stack(sc, sc->vector_set_function); + sc->code = car(inds); + sc->cur_op = optimize_op(sc->code); + return(goto_top_no_pop); +} + +static goto_t set_implicit_c_object(s7_scheme *sc, s7_pointer c_obj, s7_pointer inds, s7_pointer val, s7_pointer form) +{ + s7_pointer index; + /* c_obj's set! method needs to provide error checks */ + + if ((!is_pair(inds)) || (!is_null(cdr(inds)))) + { + push_op_stack(sc, sc->c_object_set_function); + if (is_null(inds)) + { + push_stack_no_code(sc, OP_EVAL_ARGS1, list_1(sc, c_obj)); + sc->code = car(val); + } + else + { + sc->code = (is_null(cdr(inds))) ? cons(sc, car(inds), val) : pair_append(sc, cdr(inds), T_Lst(val)); + push_stack(sc, OP_EVAL_ARGS4, list_1(sc, c_obj), sc->code); + sc->code = car(inds); + } + sc->cur_op = optimize_op(sc->code); + return(goto_top_no_pop); + } + index = car(inds); + if (!is_pair(index)) + { + s7_pointer value = car(val); + if (is_symbol(index)) + index = lookup_checked(sc, index); + if (!is_pair(value)) + { + if (is_symbol(value)) + value = lookup_checked(sc, value); + sc->value = (*(c_object_set(sc, c_obj)))(sc, with_list_t3(sc, c_obj, index, value)); + return(goto_start); + } + push_op_stack(sc, sc->c_object_set_function); + sc->args = list_2(sc, index, c_obj); + sc->code = val; + return(goto_eval_args); + } + push_stack(sc, OP_EVAL_ARGS4, list_1(sc, c_obj), val); + push_op_stack(sc, sc->c_object_set_function); + sc->code = car(inds); + sc->cur_op = optimize_op(sc->code); + return(goto_top_no_pop); +} + +static bool op_implicit_string_ref_a(s7_scheme *sc) +{ + s7_int index; + const s7_pointer str = lookup_checked(sc, car(sc->code)); + const s7_pointer val = fx_call(sc, cdr(sc->code)); + if (!is_string(str)) + { + sc->last_function = str; + return(false); + } + if (!s7_is_integer(val)) + { + sc->value = string_ref_1(sc, str, set_plist_1(sc, val)); + return(true); + } + index = s7_integer_clamped_if_gmp(sc, val); + if ((index < string_length(str)) && (index >= 0)) + { + sc->value = chars[((uint8_t *)string_value(str))[index]]; + return(true); + } + sc->value = string_ref_1(sc, str, val); + return(true); +} + +static goto_t set_implicit_string(s7_scheme *sc, s7_pointer str, s7_pointer inds, s7_pointer val, 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 index; + + if (!is_pair(inds)) + wrong_number_of_arguments_error_nr(sc, "no index for string set!: ~S", 28, form); + if (!is_null(cdr(inds))) + wrong_number_of_arguments_error_nr(sc, "too many indices for string set!: ~S", 36, form); + + index = car(inds); + if (!is_pair(index)) + { + s7_int ind; + if (is_symbol(index)) + index = lookup_checked(sc, index); + if (!s7_is_integer(index)) + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "index must be an integer: ~S", 28), form)); + ind = s7_integer_clamped_if_gmp(sc, index); + if ((ind < 0) || (ind >= string_length(str))) + out_of_range_error_nr(sc, sc->string_set_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); + if (is_immutable_string(str)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->string_set_symbol, str)); + + val = car(val); + if (!is_pair(val)) + { + if (is_symbol(val)) + val = lookup_checked(sc, val); + if (is_character(val)) + { + string_value(str)[ind] = character(val); + sc->value = val; + return(goto_start); + } + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "value must be a character: ~S", 29), form)); + } + /* maybe op_implicit_string_set_a as in vector someday, but this code isn't (currently) called much */ + push_op_stack(sc, sc->string_set_function); + sc->args = list_2(sc, index, str); + sc->code = cdr(sc->code); + return(goto_eval_args); + } + push_stack(sc, OP_EVAL_ARGS4, list_1(sc, str), val); /* args4 not 1 because we know cdr(sc->code) is a pair */ + push_op_stack(sc, sc->string_set_function); + sc->code = car(inds); + sc->cur_op = optimize_op(sc->code); + return(goto_top_no_pop); +} + +static goto_t set_implicit_pair(s7_scheme *sc, s7_pointer lst, s7_pointer inds, s7_pointer val, s7_pointer form) +{ + s7_pointer index, index_val = NULL; + const s7_pointer value = car(val); + + if (!is_pair(inds)) /* (!is_pair(val)) and (!is_null(cdr(val))) are apparently caught somewhere else */ + wrong_number_of_arguments_error_nr(sc, "no index for list-set!: ~S", 26, form); + + index = car(inds); + if (!is_pair(index)) + index_val = (is_normal_symbol(index)) ? lookup_checked(sc, index) : index; + + if (!is_null(cdr(inds))) + { + /* 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) */ + if (index_val) + { + s7_pointer obj = list_ref_1(sc, lst, index_val); + if (!is_applicable(obj)) + error_nr(sc, sc->no_setter_symbol, + set_elist_5(sc, wrap_string(sc, "in ~S, (~S ~$) is ~S which can't take arguments", 47), form, lst, index_val, obj)); + return(call_set_implicit(sc, obj, cdr(inds), val, form)); + } + setup_eval_args_pair(sc, lst, inds, val); /* (let ((L (list (list 1 2 3)))) (set! (L (- (length L) 1) 2) 0) L) */ + return(goto_eval_args_pair); + } + if (index_val) + { + if (!is_pair(value)) + { + set_car(sc->t2_1, index_val); + set_car(sc->t2_2, (is_symbol(value)) ? lookup_checked(sc, value) : value); + sc->value = g_list_set_1(sc, lst, sc->t2_1, 2); + return(goto_start); + } + push_op_stack(sc, sc->list_set_function); /* because cdr(inds) is nil, we're definitely calling list_set */ + sc->args = list_2(sc, index_val, lst); /* plist unsafe here */ + sc->code = val; + return(goto_eval_args); + } + push_stack(sc, OP_EVAL_ARGS4, list_1(sc, lst), val); /* plist unsafe here */ + push_op_stack(sc, sc->list_set_function); + sc->code = car(inds); + sc->cur_op = optimize_op(sc->code); + return(goto_top_no_pop); +} + +static goto_t set_implicit_hash_table(s7_scheme *sc, s7_pointer table, s7_pointer inds, s7_pointer val, s7_pointer form) +{ + s7_pointer key, keyval = NULL; + + if (!is_pair(inds)) /* (!is_pair(val)) and (!is_null(cdr(val))) are apparently caught elsewhere */ + wrong_number_of_arguments_error_nr(sc, "no key for hash-table-set!: ~S", 30, form); + if (is_immutable_hash_table(table)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->hash_table_set_symbol, table)); + + key = car(inds); + if (is_pair(key)) + { + if (is_quote(sc, car(key))) + keyval = cadr(key); + } + else keyval = (is_normal_symbol(key)) ? lookup_checked(sc, key) : key; + if (!is_null(cdr(inds))) + { + if (keyval) + { + const s7_pointer obj = s7_hash_table_ref(sc, table, keyval); + if (obj == missing_key_value(sc)) /* (let ((h (hash-table 'b 1))) (set! (h 'a 'asdf) 32)) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "in ~S, ~$ does not exist in ~S", 30), form, keyval, table)); + else + if (!is_applicable(obj)) /* (let ((h (hash-table 'b 1))) (set! (h 'b 'asdf) 32)) */ + error_nr(sc, sc->no_setter_symbol, + set_elist_5(sc, wrap_string(sc, "in ~S, (~S ~$) is ~S which can't take arguments", 47), form, table, keyval, obj)); + /* (let ((v (hash-table 'a (hash-table 'b 1)))) (set! (v 'a 'b 'b) 32) v) -> + * error: in (set! (v 'a 'b 'b) 32), ((hash-table 'b 1) 'b) is 1 which can't take arguments + * (let ((v (hash-table 'a (list 1 2)))) (set! (v 'a 1) 5)) -> code: (set! ((1 2) 1) 5) -> 5 (v: (hash-table 'a (1 5))) + */ + return(call_set_implicit(sc, obj, cdr(inds), val, form)); + } + setup_eval_args_pair(sc, table, inds, val); /* key = car(inds) */ + return(goto_eval_args_pair); + } + if (keyval) + { + const s7_pointer value = car(val); + if (is_pair(value)) + { + if (is_quote(sc, car(value))) + { + sc->value = s7_hash_table_set(sc, table, keyval, cadr(value)); + return(goto_start); + }} + else + { + sc->value = s7_hash_table_set(sc, table, keyval, (is_normal_symbol(value)) ? lookup_checked(sc, value) : value); + return(goto_start); + } + push_op_stack(sc, sc->hash_table_set_function); /* because cdr(inds) is nil, we're definitely calling hash_table_set */ + sc->args = list_2(sc, keyval, table); /* plist unsafe here */ + sc->code = val; + return(goto_eval_args); + } + push_stack(sc, OP_EVAL_ARGS4, list_1(sc, table), val); /* plist unsafe here */ + push_op_stack(sc, sc->hash_table_set_function); + sc->code = car(inds); + sc->cur_op = optimize_op(sc->code); + return(goto_top_no_pop); +} + +static goto_t set_implicit_let(s7_scheme *sc, s7_pointer let, s7_pointer inds, s7_pointer val, s7_pointer form) +{ + s7_pointer sym, symval = NULL; + + if (!is_pair(inds)) /* as above, bad val caught elsewhere */ + wrong_number_of_arguments_error_nr(sc, "no symbol (variable name) for let-set!: ~S", 42, form); + + sym = car(inds); + if (is_pair(sym)) + { + if (is_quote(sc, car(sym))) + symval = cadr(sym); + } + else symval = (is_normal_symbol(sym)) ? lookup_checked(sc, sym) : sym; + if (!is_null(cdr(inds))) + { + if (symval) + { + const s7_pointer obj = let_ref(sc, let, symval); + if (!is_applicable(obj)) /* (let ((h (hash-table 'b 1))) (set! (h 'b 'asdf) 32)) */ + error_nr(sc, sc->no_setter_symbol, + set_elist_5(sc, wrap_string(sc, "in ~S, (~S ~$) is ~S which can't take arguments", 47), form, let, symval, obj)); + return(call_set_implicit(sc, obj, cdr(inds), val, form)); + } + setup_eval_args_pair(sc, let, inds, val); + return(goto_eval_args_pair); + /* this is unnecessary: continue at eval_last_arg+ goto apply -> apply_let -> pop_stack + goto top_no_pop */ + } + if (symval) + { + s7_pointer value = car(val); + if (!is_pair(value)) + { + if (is_symbol(value)) + value = lookup_checked(sc, value); + sc->value = let_set_2(sc, let, symval, value); + return(goto_start); + } + push_op_stack(sc, sc->let_set_function); + sc->args = list_2(sc, symval, let); + sc->code = val; + return(goto_eval_args); + } + push_stack(sc, OP_EVAL_ARGS4, list_1(sc, let), val); + push_op_stack(sc, sc->let_set_function); + sc->code = car(inds); + sc->cur_op = optimize_op(sc->code); + return(goto_top_no_pop); +} + +static goto_t set_implicit_c_function(s7_scheme *sc, s7_pointer fnc) /* (let ((lst (list 1 2))) (set! (list-ref lst 0) 2) lst) */ +{ + if (!is_t_procedure(c_function_setter(fnc))) + { + if (!is_any_macro(c_function_setter(fnc))) + no_setter_error_nr(sc, fnc); + sc->args = (is_null(cdar(sc->code))) ? cdr(sc->code) : + ((is_null(cddar(sc->code))) ? cons(sc, cadar(sc->code), cdr(sc->code)) : pair_append(sc, cdar(sc->code), cdr(sc->code))); + sc->code = c_function_setter(fnc); + /* here multiple-values can't happen because we don't eval the new-value argument */ + 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_null(cdar(sc->code))) + { + push_stack(sc, OP_EVAL_SET1_NO_MV, sc->nil, c_function_setter(fnc)); + sc->code = cadr(sc->code); /* new value */ + } + else + { + if (is_null(cddar(sc->code))) /* (set! (fnc ind) val) */ + push_stack(sc, OP_EVAL_SET2, cadr(sc->code), c_function_setter(fnc)); + else + { + push_op_stack(sc, c_function_setter(fnc)); + sc->value = pair_append(sc, cddar(sc->code), cdr(sc->code)); + push_stack(sc, OP_EVAL_SET3, sc->nil, sc->value); /* args=evalled, code=unevalled */ + } + sc->code = cadar(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 fnc) +{ + s7_pointer setter = closure_setter_or_map_list(fnc); /* (set! (fnc ind...) val), sc->code = ((fnc ind...) val) */ + if ((setter == sc->F) && (!closure_no_setter(fnc))) /* maybe closure_setter hasn't been set yet: see fset3 in s7test.scm */ + setter = setter_p_pp(sc, fnc, sc->curlet); + if (!is_t_procedure(setter)) + { + if (!is_any_macro(setter)) + no_setter_error_nr(sc, fnc); + sc->args = (is_null(cdar(sc->code))) ? cdr(sc->code) : + ((is_null(cddar(sc->code))) ? cons(sc, cadar(sc->code), cdr(sc->code)) : pair_append(sc, cdar(sc->code), cdr(sc->code))); + sc->code = setter; + return(goto_apply); + } + if (is_null(cdar(sc->code))) /* (set! (fnc) val) */ + { + push_stack(sc, OP_EVAL_SET1_NO_MV, sc->nil, setter); /* args=(), code=setter */ + sc->code = cadr(sc->code); /* the value */ + } + else + { + if (is_null(cddar(sc->code))) /* (set! (fnc ind) val) */ + push_stack(sc, OP_EVAL_SET2, cadr(sc->code), setter); + else /* (set! (fnc inds ...) val) */ + { + push_op_stack(sc, setter); + sc->value = pair_append(sc, cddar(sc->code), cdr(sc->code)); + push_stack(sc, OP_EVAL_SET3, sc->nil, sc->value); /* args=evalled, code=unevalled */ + } + sc->code = cadar(sc->code); /* "ind" above */ + } + sc->cur_op = optimize_op(sc->code); + return(goto_top_no_pop); +} + +static goto_t set_implicit_iterator(s7_scheme *sc, s7_pointer iter) +{ + s7_pointer setter = iterator_sequence(iter); + + if ((is_any_closure(setter)) || (is_any_macro(setter))) + setter = closure_setter(iterator_sequence(iter)); + else no_setter_error_nr(sc, iter); + + if (!is_null(cdar(sc->code))) /* (set! (iter ...) val) but iter is a thunk */ + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, wrap_string(sc, "~S (an iterator): too many arguments: ~S", 40), iter, sc->code)); + + if (is_procedure(setter)) + { + push_op_stack(sc, setter); + push_stack_no_code(sc, OP_EVAL_ARGS1, sc->nil); + sc->code = cadr(sc->code); /* the (as yet unevaluated) value, incoming code was ((obj) val) */ + sc->cur_op = optimize_op(sc->code); + return(goto_top_no_pop); + } + sc->args = cdr(sc->code); + sc->code = setter; + return(goto_apply); +} + +static goto_t set_implicit_syntax(s7_scheme *sc, s7_pointer wlet) +{ + if (wlet != global_value(sc->with_let_symbol)) + no_setter_error_nr(sc, wlet); + + /* (set! (with-let a b) x), wlet = 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 call_set_implicit(s7_scheme *sc, s7_pointer obj, s7_pointer inds, s7_pointer val, s7_pointer form) +{ + /* these depend on sc->code making sense given obj as the sequence being set (and 99% of these cases are handled elsewhere -- this is the eval fallback code) */ + switch (type(obj)) + { + case T_STRING: return(set_implicit_string(sc, obj, inds, val, form)); + case T_PAIR: return(set_implicit_pair(sc, obj, inds, val, form)); + case T_HASH_TABLE: return(set_implicit_hash_table(sc, obj, inds, val, form)); + case T_LET: return(set_implicit_let(sc, obj, inds, val, form)); + case T_C_OBJECT: return(set_implicit_c_object(sc, obj, inds, val, form)); + case T_ITERATOR: return(set_implicit_iterator(sc, obj)); /* not sure this makes sense */ + case T_SYNTAX: return(set_implicit_syntax(sc, obj)); + + case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_BYTE_VECTOR: case T_COMPLEX_VECTOR: + return(set_implicit_vector(sc, obj, inds, val, form)); + + case T_C_MACRO: case T_C_FUNCTION_STAR: + case T_C_RST_NO_REQ_FUNCTION: case T_C_FUNCTION: + return(set_implicit_c_function(sc, obj)); /* (set! (setter...) ...) also comes here */ + + 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, obj)); + + default: /* (set! (1 2) 3) */ + if (is_applicable(obj)) + no_setter_error_nr(sc, obj); /* this is reachable if obj is a goto or continuation: (set! (go 1) 2) in s7test.scm */ + error_nr(sc, sc->no_setter_symbol, + set_elist_3(sc, wrap_string(sc, "in ~S, ~S has no setter", 23), + cons_unchecked(sc, sc->set_symbol, /* copy_tree(sc, form) also works but copies too much: we want to copy the ulists */ + cons(sc, copy_proper_list(sc, cadr(form)), cddr(form))), + obj)); + } + return(goto_top_no_pop); +} + +static goto_t set_implicit(s7_scheme *sc) /* sc->code incoming is (set! (...) ...) */ +{ + s7_pointer caar_code, obj; + const s7_pointer form = sc->code; + sc->code = cdr(sc->code); + caar_code = caar(sc->code); + if (is_symbol(caar_code)) + { + obj = s7_slot(sc, caar_code); + obj = (is_slot(obj)) ? slot_value(obj) : unbound_variable(sc, caar_code); + } + else + if (!is_pair(caar_code)) + obj = caar_code; + else + { + 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); + } + /* 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 */ + return(call_set_implicit(sc, obj, cdar(sc->code), cdr(sc->code), form)); +} + +static no_return void set_with_let_error_nr(s7_scheme *sc) +{ + s7_pointer target = cadr(sc->code), value = caddr(sc->code); + error_nr(sc, sc->no_setter_symbol, + set_elist_3(sc, wrap_string(sc, "can't set ~A in ~S", 18), target, + list_3(sc, sc->set_symbol, + (is_pair(target)) ? copy_proper_list(sc, target) : target, + (is_pair(value)) ? copy_proper_list(sc, value) : value))); +} + +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) */ + syntax_error_nr(sc, "set! target arguments are an improper list: ~A", 46, sc->args); + if (is_multiple_value(sc->value)) /* (set! ((values fnc 0)) 32) etc */ + { + if (is_null(sc->args)) + { /* can't assume we're in list-set! here -- first value is target */ + sc->code = list_3(sc, sc->set_symbol, multiple_value(sc->value), car(sc->code)); + return(goto_eval); + } + else /* this has to be at least 2 args, sc->args and sc->code make 2 more, so... */ + syntax_error_nr(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, T_Lst(sc->code))))); + } + if (is_null(sc->args)) + syntax_error_nr(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), T_Lst(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)) && + (vector_rank(sc->value) == proper_list_length(sc->args))) /* sc->code == new 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) + syntax_error_nr(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), T_Lst(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); + } + sc->code = cons_unchecked(sc, sc->set_symbol, cons(sc, set_ulist_1(sc, sc->value, sc->args), sc->code)); /* (let ((x 32)) (set! ((curlet) 'x) 3) x) */ + return(set_implicit(sc)); +} + + +/* -------------------------------- do -------------------------------- */ +static bool safe_stepper_expr(s7_scheme *sc, s7_pointer expr, const 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) && ((car(expr) != sc->set_symbol) || (!is_symbol(cadr(expr))))) 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))))); +} + +#if DO_PRINT +#define all_ints_here(Sc, Settee, Expr, Step_vars) all_ints_here_1(Sc, Settee, Expr, Step_vars, __func__, __LINE__) +#define do_return_false(body) do {if (DO_PRINT) fprintf(stderr, " %s[%d] from %s[%d]: %s\n", __func__, __LINE__, funcly, linely, display(body)); return(false);} while (0) +static bool all_ints_here_1(s7_scheme *sc, s7_pointer settee, s7_pointer expr, s7_pointer step_vars, const char *funcly, int linely) /* see also all_integers above */ +#else +#define do_return_false(body) return(false) +static bool all_ints_here(s7_scheme *sc, s7_pointer settee, s7_pointer expr, s7_pointer step_vars) /* see also all_integers above */ +#endif +{ + /* since any type change causes false return, we can accept inits across step-vars */ + s7_pointer func, sig; + if (is_number(expr)) + return(is_t_integer(expr)); + if (is_symbol(expr)) + { + if (expr == settee) return(true); + for (s7_pointer step = step_vars; is_pair(step); step = cdr(step)) + if (caar(step) == expr) + { + if (!all_ints_here(sc, caar(step), cadar(step), step_vars)) + do_return_false(expr); + if (is_pair(cddar(step))) + return(all_ints_here(sc, caar(step), caddar(step), step_vars)); + return(true); + } + { + s7_pointer val = lookup_unexamined(sc, expr); + return((val) && (is_t_integer(val))); + }} + if (!is_pair(expr)) return(false); + if (!is_symbol(car(expr))) + do_return_false(expr); + func = lookup_unexamined(sc, car(expr)); + if (!func) do_return_false(expr); + if ((is_int_vector(func)) || (is_byte_vector(func))) return(true); + + if (is_either_macro(func)) + { + if (tree_memq_1(sc, car(step_vars), expr)) + do_return_false(expr); + if (tree_including_quote_memq(sc, car(step_vars), closure_body(func))) + do_return_false(expr); + return(true); + } + if (!is_any_c_function(func)) + do_return_false(expr); + + if ((car(expr) == sc->vector_ref_symbol) && (is_pair(cdr(expr))) && (is_symbol(cadr(expr)))) + { + s7_pointer vec = lookup_unexamined(sc, cadr(expr)); + if ((vec) && ((is_int_vector(vec)) || (is_byte_vector(vec)))) return(true); + } + sig = c_function_signature(func); +#if 0 + if ((is_pair(sig)) && + ((car(sig) == sc->is_integer_symbol) || (car(sig) == sc->is_byte_symbol))) +#else + /* tvect tshoot tbig */ + if ((is_pair(sig)) && + ((car(sig) == sc->is_integer_symbol) || (car(sig) == sc->is_byte_symbol) || + ((is_pair(car(sig))) && + ((direct_memq(sc->is_integer_symbol, car(sig))) || (direct_memq(sc->is_byte_symbol, car(sig))))))) + /* maybe make int|byte_vector_ref|set explicit, or check indices=rank? + * or just use (func == sc->int_vector_ref) etc + */ +#endif + return(true); + if (!is_all_integer(car(expr))) + do_return_false(expr); + for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p)) + if (!all_ints_here(sc, settee, car(p), step_vars)) + do_return_false(expr); + return(true); +} + +#if DO_PRINT +#define do_is_safe(Sc, Body, Stepper, Var_list, Step_vars, Has_set) do_is_safe_1(Sc, Body, Stepper, Var_list, Step_vars, Has_set, __func__, __LINE__) +static bool do_is_safe_1(s7_scheme *sc, s7_pointer body, s7_pointer stepper, s7_pointer var_list, s7_pointer step_vars, bool *has_set, const char *funcly, int linely) +#else +static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer stepper, s7_pointer var_list, s7_pointer step_vars, bool *has_set) +#endif +{ + /* 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 + */ + const s7_pointer code = sc->code; /* only used once, but I worry about sc->code changing */ + for (s7_pointer exprs = body; is_pair(exprs); exprs = cdr(exprs)) + { + const s7_pointer expr = car(exprs); + if (is_pair(expr)) + { + const s7_pointer head = car(expr); + /* this used to be if (is_pair(head)) continue; */ + if ((!is_symbol(head)) && (!is_safe_c_function(head)) && (head != sc->quote_function) && (!is_pair(head))) + do_return_false(expr); + /* car(expr) ("head") 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 + */ + if (is_symbol_and_syntactic(head)) + { + const opcode_t op = syntax_opcode(global_value(head)); + switch (op) + { + case OP_MACROEXPAND: + do_return_false(expr); + + case OP_QUOTE: + if ((!is_pair(cdr(expr))) || (!is_null(cddr(expr)))) /* (quote . 1) or (quote 1 2) etc */ + do_return_false(expr); + break; + + case OP_LET: case OP_LET_STAR: + case OP_LETREC: case OP_LETREC_STAR: + { + s7_pointer cp; + if ((!is_pair(cdr(expr))) || (!is_list(cadr(expr))) || (!is_pair(cddr(expr)))) + do_return_false(expr); + cp = var_list; + begin_temp(sc->y, sc->nil); + for (s7_pointer vars = cadr(expr); is_pair(vars); vars = cdr(vars)) + { + s7_pointer var; + if (!is_pair(car(vars))) {end_temp(sc->y); do_return_false(expr);} + var = caar(vars); + if (direct_memq(var, ((op == OP_LET) || (op == OP_LETREC)) ? cp : var_list)) {end_temp(sc->y); do_return_false(expr);} + if ((!is_symbol(var)) || (is_keyword(var))) {end_temp(sc->y); do_return_false(expr);} + cp = cons(sc, var, cp); + sc->y = cp; + } + end_temp(sc->y); + if (!do_is_safe(sc, cddr(expr), stepper, cp, step_vars, has_set)) + do_return_false(expr); + } + break; + + case OP_DO: + { + s7_pointer combined_vars, cp; + if ((!is_pair(cdr(expr))) || (!is_pair(cddr(expr)))) /* (do) or (do (...)) */ + do_return_false(expr); + cp = var_list; + sc->temp5 = cp; /* this can be stepped on -- t101-12..16 */ + combined_vars = (is_pair(cadr(expr))) ? pair_append(sc, cadr(expr), step_vars) : step_vars; + sc->w = combined_vars; + for (s7_pointer vars = cadr(expr); is_pair(vars); vars = cdr(vars)) + { + s7_pointer var; + if (!is_pair(car(vars))) {end_temp(sc->w); end_temp(sc->temp5); do_return_false(expr);} + var = caar(vars); + if ((direct_memq(var, cp)) || (var == stepper)) {end_temp(sc->w); end_temp(sc->temp5); do_return_false(expr);} + cp = cons(sc, var, cp); + sc->temp5 = cp; + if ((is_pair(cdar(vars))) && + (!do_is_safe(sc, cdar(vars), stepper, cp, combined_vars, has_set))) + {end_temp(sc->temp5); end_temp(sc->w); do_return_false(expr);} + } + end_temp(sc->temp5); + end_temp(sc->w); +#if 0 + if (!do_is_safe(sc, cddr(expr), stepper, cp, combined_vars, has_set)) + do_return_false(expr); +#endif + if ((is_pair(cdddr(expr))) && + (!do_is_safe(sc, cdddr(expr), stepper, cp, combined_vars, has_set))) + do_return_false(expr); + } + break; + + case OP_SET: + { + s7_pointer settee; + if ((!is_pair(cdr(expr))) || (!is_pair(cddr(expr)))) /* (set!) or (set! x) */ + do_return_false(expr); + settee = cadr(expr); + if (!is_symbol(settee)) /* (set! (...) ...) which is tricky due to setter functions/macros */ + { + if ((!is_pair(settee)) || (!is_symbol(car(settee)))) + do_return_false(expr); + if (!direct_memq(car(settee), var_list)) /* is it a local var */ + { + const s7_pointer setv = lookup_unexamined(sc, car(settee)); + if (!((setv) && + ((is_sequence(setv)) || + ((is_c_function(setv)) && (is_safe_procedure(c_function_setter(setv))))))) + do_return_false(expr); + /* if ((has_set) && (!is_sequence(setv))) (*has_set) = true; */ + /* ^ trouble in tmock.scm (opt2_fn not set) -- apparently op_simple_do assumes has_fn which set! lacks */ + } + if (has_set) (*has_set) = true; + } + else + { + const s7_pointer end_and_result = caddr(code); /* sc->code */ + /* I think this is trying to catch (set! end i) [do-test-20 s7test] etc and needs the end-and-result form to check that */ +#if 1 + if ((is_pair(end_and_result)) && + (is_pair(car(end_and_result))) && + (!is_syntax(caar(end_and_result)))) /* 10-Jan-24 but why? */ + { + bool result; + set_match_symbol(settee); + result = tree_match(car(end_and_result)); /* (set! end ...) in some fashion */ + clear_match_symbol(settee); + if (result) + { + if (DO_PRINT) + fprintf(stderr, "%s[%d]: %s in %s\n", __func__, __LINE__, display(settee), display_truncated(end_and_result)); + do_return_false(expr); + }} +#endif + if (!direct_memq(settee, var_list)) /* is some local variable being set? */ + { + const s7_pointer val = lookup_unexamined(sc, settee); + if (has_set) (*has_set) = true; + if ((val) && (is_t_integer(val)) && (!all_ints_here(sc, settee, caddr(expr), step_vars))) + { + if (DO_PRINT) + fprintf(stderr, "%s[%d]: %s (%s) not all_ints_here in %s with %s\n", __func__, __LINE__, + display(settee), display(val), display_truncated(caddr(expr)), display(step_vars)); + do_return_false(expr); + }}} + if (!do_is_safe(sc, cddr(expr), stepper, var_list, step_vars, has_set)) + { + if (DO_PRINT) + fprintf(stderr, "%s[%d]: !do_is_safe %s %s %s %s\n", __func__, __LINE__, + display(expr), display(stepper), display(var_list), display(step_vars)); + do_return_false(expr); + } + if (!safe_stepper_expr(sc, expr, stepper)) /* is step var's value used as the stored value by set!? */ + { /* but this is safe if (set! loc i) where i is int because it checks and copies */ + if (DO_PRINT) + fprintf(stderr, " %s%s[%d]: !safe_stepper_expr %s with %s%s\n", + bold_text, __func__, __LINE__, display(expr), display(stepper), unbold_text); + do_return_false(expr); + }} + break; + + case OP_LET_TEMPORARILY: + if ((!is_pair(cdr(expr))) || + (!is_pair(cadr(expr))) || + (!is_pair(cddr(expr)))) + do_return_false(expr); + for (s7_pointer 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, step_vars, has_set))) + do_return_false(expr); + if (!do_is_safe(sc, cddr(expr), stepper, var_list, step_vars, has_set)) + do_return_false(expr); + break; + + case OP_COND: + for (s7_pointer cp = cdr(expr); is_pair(cp); cp = cdr(cp)) + if (!do_is_safe(sc, car(cp), stepper, var_list, step_vars, has_set)) + do_return_false(expr); + break; + + case OP_CASE: + if ((!is_pair(cdr(expr))) || + (!do_is_safe(sc, cadr(expr), stepper, var_list, step_vars, has_set))) + do_return_false(expr); + for (s7_pointer 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, step_vars, has_set))) + do_return_false(expr); + 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, step_vars, has_set)) + do_return_false(expr); + break; + + case OP_WITH_LET: + do_return_false(expr); /* 11-Jan-24, this was true!? */ + + default: + do_return_false(expr); + }} /* is_syntax(head=car(expr)) */ + else + if (head == sc->quote_function) + { + if ((!is_pair(cdr(expr))) || (!is_null(cddr(expr)))) /* (#_quote . 1) or (#_quote 1 2) etc */ + do_return_false(expr); + } + else + { + if ((is_pair(expr)) && (is_pair(cdr(expr)))) + { + if ((is_saver(head)) && (direct_translucent_member(stepper, cdr(expr)))) + do_return_false(expr); + if (is_setter(head)) /* tree_inspect_stepper in tmp? */ + { + s7_pointer arg; + for (arg = cdr(expr); is_pair(cdr(arg)); arg = cdr(arg)); + if ((car(arg) == stepper) || + ((is_pair(car(arg))) && + (((is_saver(caar(arg))) && (direct_memq(stepper, cdar(arg)))) || + ((is_translucent(caar(arg))) && (is_pair(cdar(arg))) && (cadar(arg) == stepper))))) /* is_pair for (write) etc */ + do_return_false(expr); + }} + + if ((is_pair(expr)) && (is_pair(cdr(expr))) && + (is_symbol(head)) && + (!initial_value_is_defined(sc, head)) && + (direct_memq(stepper, cdr(expr)))) + { + const s7_pointer slot = s7_slot(sc, head); + if ((!is_slot(slot)) || (!is_applicable(slot_value(slot)))) /* expr: '(=> () ...) */ + do_return_false(expr); + if ((is_saver(slot_value(slot))) && /* || (is_translucent(slot_value(slot)))) && */ + (direct_translucent_member(stepper, cdr(expr)))) + do_return_false(expr); + } + + { /* if a macro check both expr and the macro body for the stepper */ + const s7_pointer val = (is_symbol(head)) ? lookup_unexamined(sc, head) : head; /* head is car(expr) 200 lines back (!) */ + if ((val) && (is_either_macro(val)) && (!is_setter(val))) + { + if (tree_memq_1(sc, stepper, expr)) + do_return_false(expr); + if (tree_including_quote_memq(sc, stepper, closure_body(val))) + do_return_false(expr); + return(true); + }} + + if (!is_optimized(expr)) + do_return_false(expr); + if (optimize_op(expr) == OP_UNKNOWN_NP) /* tmac, (mx 1 (3 4 5)) */ + do_return_false(expr); + if (!do_is_safe(sc, cdr(expr), stepper, var_list, step_vars, has_set)) + do_return_false(expr); + + if (is_setter(head)) + { + /* (hash-table-set! ht i 0): caddr is being saved, so this is not safe; similarly (vector-set! v 0 i) etc */ + 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))) || + ((head == sc->hash_table_set_symbol) && (caddr(expr) == stepper)) || + (cadddr(expr) == stepper) || /* used to check is_symbol here and above but that's unnecessary */ + ((is_pair(cadddr(expr))) && (s7_tree_memq(sc, stepper, cadddr(expr)))))) + (*has_set) = true; + /* and also set stepper unsafe? and also any other steppers */ + /* need a way to lock unsafe_stepper -- maybe set safe, clear here, do not set elsewhere */ + + if (!do_is_safe(sc, cddr(expr), stepper, var_list, step_vars, has_set)) + do_return_false(expr); + if (!safe_stepper_expr(sc, expr, stepper)) + do_return_false(expr); + }}}} + return(true); +} + +static bool preserves_type(s7_scheme *sc, uint32_t ctype) +{ + return((ctype == sc->add_class) || + (ctype == sc->subtract_class) || + (ctype == sc->multiply_class)); +} + +static s7_pointer simple_stepper(s7_scheme *sc, s7_pointer var) +{ + if ((is_proper_list_3(sc, var)) && + (is_fxable(sc, cadr(var)))) + { + const s7_pointer step_expr = caddr(var); + if ((is_optimized(step_expr)) && + (((optimize_op(step_expr) == HOP_SAFE_C_SC) && (car(var) == cadr(step_expr))) || + ((is_h_safe_c_nc(step_expr)) && /* replace with is_fxable? */ + (is_pair(cdr(step_expr))) && /* ((v 0 (+))) */ + (car(var) == 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(var) == 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) +{ + const s7_pointer vars = car(code); + const s7_pointer pre_var_list = cons(sc, sc->nil, sc->nil); + gc_protect_via_stack(sc, pre_var_list); + + /* clear_big_symbol_set(sc); */ /* an experiment -- slightly slower than pre_var_list? */ + for (s7_pointer p = vars, var_list = NULL; is_pair(p); p = cdr(p)) + { + s7_function callee = NULL; + s7_pointer expr = cdar(p); /* init */ + /* add_symbol_to_big_symbol_set(sc, caar(p)); */ + 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 = cdr(expr); /* cddar(p): step */ + if (is_pair(expr)) + { + if ((is_pair(car(expr))) && + (!is_checked(car(expr)))) + { + if (!var_list) + { + begin_temp(sc->y, sc->nil); + for (var_list = vars; is_pair(var_list); var_list = cdr(var_list)) sc->y = cons(sc, caar(var_list), sc->y); + var_list = sc->y; /* only valid in step exprs, not in inits; also all vars are valid at any point in step exprs */ + end_temp(sc->y); + set_cdr(pre_var_list, var_list); /* we'll put each current var at top of this list to speed up the most likely search (arg_findable -> pair_symbol_is_safe) */ + } + set_car(pre_var_list, caar(p)); /* caar(p) == current var, highly likely it's in the step expr */ + optimize_expression(sc, car(expr), 0, pre_var_list, false); + } + callee = fx_choose(sc, expr, vars, do_symbol_is_safe); /* fx_proc can be nil! */ + if (callee) set_fx(expr, callee); + }} + unstack_gc_protect(sc); + /* clear_big_symbol_set(sc); */ + + if ((is_pair(cdr(code))) && + (is_pair(cadr(code)))) + { + s7_pointer 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)); } - 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), let_or_list); - set_opt3_arglen (cdr (expr), 1); - choose_c_function (sc, expr, func, 1); - return (opt_bad); + if (DO_PRINT) fprintf(stderr, " op: %s\n", op_names[optimize_op(sc->code)]); + return(code); +} + +static bool do_vector_has_definer(s7_pointer vec) +{ + s7_pointer *els = vector_elements(vec); + for (s7_int i = 0, len = vector_length(vec); 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); +} + +#if CYCLE_DEBUGGING + static char *base = NULL, *min_char = NULL; +#endif + +static /* inline */ bool do_tree_has_definer(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? + */ +#if CYCLE_DEBUGGING + char x; + if (!base) base = &x; + else + { + if (&x > base) base = &x; + else + { + if ((!min_char) || (&x < min_char)) + { + min_char = &x; + if ((base - min_char) > 10000) + { + fprintf(stderr, "infinite recursion? %s\n", display(tree)); + abort(); + }}}} +#endif + s7_int i = 0; + for (s7_pointer p = tree; is_pair(p); p = cdr(p), i++) + { + s7_pointer pp = car(p); + if (is_symbol(pp)) + { + if (is_definer(pp)) + { + if (pp == sc->apply_symbol) + { + s7_pointer val; + if ((!is_pair(cdr(p))) || (!is_symbol(cadr(p)))) return(true); + val = lookup_unexamined(sc, cadr(p)); + if ((!val) || (!is_c_function(val))) return(true); + } + else return(true); + }} + else + if (is_pair(pp)) + { + if (do_tree_has_definer(sc, pp)) + return(true); + } + else + if ((is_applicable(pp)) && + (((is_t_vector(pp)) && (do_vector_has_definer(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) +{ + const s7_pointer code = cdr(form); + + if ((!is_pair(code)) || /* (do . 1) */ + ((!is_pair(car(code))) && /* (do 123) */ + (is_not_null(car(code))))) /* (do () ...) is ok */ + syntax_error_nr(sc, "do: variable list is not a list: ~S", 35, form); + + if (!is_pair(cdr(code))) /* (do () . 1) */ + syntax_error_nr(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? */ + syntax_error_nr(sc, "do: end-test and end-value list is not a list: ~A", 49, form); + + if (is_pair(car(code))) + { + s7_pointer vars; + begin_small_symbol_set(sc); + for (vars = car(code); is_pair(vars); vars = cdr(vars)) + { + const s7_pointer var = car(vars); + if (!is_pair(var)) /* (do (4) (= 3)) */ + syntax_error_nr(sc, "do: variable name missing? ~A", 29, form); + + if (!is_symbol(car(var))) /* (do ((3 2)) ()) */ + syntax_error_nr(sc, "do step variable: ~S is not a symbol?", 37, var); + + if (is_constant_symbol(sc, car(var))) /* (do ((pi 3 (+ pi 1))) ((= pi 4)) pi) */ + syntax_error_nr(sc, "do step variable: ~S is immutable", 33, var); + + if (!is_pair(cdr(var))) + syntax_error_nr(sc, "do: step variable has no initial value: ~A", 42, vars); + if (!is_pair(cddr(var))) + { + if (is_not_null(cddr(var))) /* (do ((i 0 . 1)) ...) */ + syntax_error_nr(sc, "do: step variable info is an improper list?: ~A", 47, vars); + } + else + if (is_not_null(cdddr(var))) /* (do ((i 0 1 (+ i 1))) ...) */ + syntax_error_nr(sc, "do: step variable info has extra stuff after the increment: ~A", 62, vars); + set_local(car(var)); + + if (symbol_is_in_small_symbol_set(sc, car(var))) /* (do ((i 0 (+ i 1)) (i 2))...) */ + syntax_error_nr(sc, "duplicate identifier in do: ~A", 30, vars); + add_symbol_to_small_symbol_set(sc, car(var)); + } + if (is_not_null(vars)) /* (do ((i 0 i) . 1) ((= i 1))) */ + syntax_error_nr(sc, "do: list of variables is improper: ~A", 37, form); + end_small_symbol_set(sc); + } + if (is_pair(cadr(code))) + { + s7_pointer p; + for (p = cadr(code); is_pair(p); p = cdr(p)); + if (is_not_null(p)) /* (do ((i 0 (+ i 1))) ((= i 2) . 3) */ + syntax_error_nr(sc, "stray dot in do end section? ~A", 31, form); } + { + s7_pointer p; + for (p = cddr(code); is_pair(p); p = cdr(p)); /* body */ + if (is_not_null(p)) + syntax_error_nr(sc, "stray dot in do body? ~A", 24, form); } - else /* bad_pairs == 1 */ +} + +static s7_pointer do_end_bad(s7_scheme *sc, s7_pointer form) +{ + const s7_pointer code = cdr(form); + if (is_null(cddr(code))) + { + /* no body, end not fxable (if eval car(end) might be unopt) */ + for (s7_pointer vars = car(code); is_pair(vars); vars = cdr(vars)) /* gather var names */ + { + s7_pointer var = car(vars); + 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 (s7_pointer vars = car(code); is_pair(vars); vars = cdr(vars)) /* look for stuff like (do ((i 0 j) (j 0 (+ j 1))) ((= j 3) i)) */ + { + s7_pointer var = car(vars); + s7_pointer val = cddr(var); + if (is_pair(val)) + { + clear_match_symbol(car(var)); /* ignore current var */ + if (tree_match(car(val))) + { + for (s7_pointer q = car(code); is_pair(q); q = cdr(q)) + clear_match_symbol(caar(q)); + if (DO_PRINT) fprintf(stderr, " %s[%d]: bad stepper %s\n", __func__, __LINE__, display(code)); + return(code); + }} + set_match_symbol(car(var)); + } + { + s7_pointer vars; + for (vars = car(code); is_pair(vars); vars = cdr(vars)) /* clear var names */ + clear_match_symbol(caar(vars)); + if (is_null(vars)) + { + if ((is_null(cadr(code))) && /* (do () ()) or (do (fxable vars) ()) */ + (is_null(cddr(code)))) + { + if (sc->safety > no_safety) + s7_warn(sc, 256, "%s: infinite do loop: %s\n", __func__, display(form)); + if (DO_PRINT) fprintf(stderr, " %s[%d]: infinite loop %s\n", __func__, __LINE__, display(form)); + return(code); + } + fxify_step_exprs(sc, code); + for (s7_pointer vars1 = car(code); is_pair(vars1); vars1 = cdr(vars1)) + { + s7_pointer var = car(vars1); + if ((!has_fx(cdr(var))) || + ((is_pair(cddr(var))) && (!has_fx(cddr(var))))) + { + if (DO_PRINT) fprintf(stderr, " %s[%d]: bad stepper %s\n", __func__, __LINE__, display(code)); + return(code); + }} + pair_set_syntax_op(form, OP_DO_NO_BODY_NA_VARS); + if (DO_PRINT) fprintf(stderr, " %s[%d]: ok %s %s\n", __func__, __LINE__, display(form), op_names[optimize_op(form)]); + return(sc->nil); + }}} + return(fxify_step_exprs(sc, code)); +} + +static s7_pointer check_do(s7_scheme *sc) +{ + /* returns nil if optimizable, code if not(?) */ + const s7_pointer form = sc->code; + s7_pointer body, end, vars, code; + + check_do_for_obvious_errors(sc, form); + pair_set_syntax_op(form, OP_DO_UNCHECKED); + code = cdr(form); /* ok here, since check_do_for_obvious_errors will call error_nr otherwise */ + end = cadr(code); + + if ((!is_pair(end)) || (!is_fxable(sc, car(end)))) + { + if (DO_PRINT) fprintf(stderr, "%s[%d]: return do_end_bad for %s\n", __func__, __LINE__, display(form)); + return(do_end_bad(sc, form)); /* can return code (not sc->nil) */ + } + /* sc->curlet is the outer environment, local vars are in the big_symbol_set via check_do_for_obvious_errors(???), and it's only needed for fx_unsafe_s */ + 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); + if (is_fx_treeable(end)) + { + if ((is_pair(car(end))) && /* this code is repeated below */ + (has_fx(end)) && + (!is_syntax(caar(end))) && + (!((is_symbol(caar(end))) && (is_definer_or_binder(caar(end)))))) + { + s7_pointer v1 = NULL, v2 = NULL, v3 = NULL; + bool more_vs = false; + if (curlet_has_slots(sc)) /* outer vars */ + { + s7_pointer slot = let_slots(sc->curlet); + v1 = slot_symbol(slot); + slot = next_slot(slot); + if (is_not_slot_end(slot)) + { + v2 = slot_symbol(slot); + slot = next_slot(slot); + if (is_not_slot_end(slot)) + { + v3 = slot_symbol(slot); + more_vs = is_not_slot_end(next_slot(slot)); + }}} + if (v1) fx_tree_outer(sc, end, v1, v2, v3, more_vs); + }} + if (DO_PRINT) fprintf(stderr, "%s[%d]: optimizable %s\n", __func__, __LINE__, display(form)); + return(sc->nil); + } + + if ((sc->safety > no_safety) && (tree_is_cyclic(sc, form))) + { + if (DO_PRINT) fprintf(stderr, "%s[%d]: bad: cyclic for %s\n", __func__, __LINE__, display(form)); + return(form); + } + if (do_tree_has_definer(sc, form)) /* we don't want definers in body, vars, or end test */ + { + if (DO_PRINT) fprintf(stderr, "%s[%d]: return fxify_step_exprs for %s\n", __func__, __LINE__, display(form)); + return(fxify_step_exprs(sc, code)); + } + + body = cddr(code); + if ((is_pair(end)) && (is_pair(car(end))) && /* end test is a pair */ + (is_pair(vars)) && (is_null(cdr(vars))) && /* one stepper */ + (is_pair(body)) && (is_pair(car(body))) && /* body is normal-looking */ + ((is_symbol(caar(body))) || (is_safe_c_function(caar(body))))) + { + /* loop has one step variable, and normal-looking end test */ + const s7_pointer var = car(vars); + s7_pointer step_expr; + + fx_tree(sc, end, car(var), NULL, NULL, false); + if (is_fx_treeable(body)) /* this is thwarted by gotos */ + fx_tree(sc, body, car(var), NULL, NULL, false); + + step_expr = simple_stepper(sc, var); + if (step_expr) + { + const s7_pointer orig_end = end; + set_fx(cdr(var), fx_choose(sc, cdr(var), 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(var) == 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; + const bool 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_class_and_fn_proc(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(var) == cadr(step_expr)) and (car(var) == 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_clamped_if_gmp(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(var), sc->nil, vars, &has_set))) + { + const opcode_t op = optimize_op(car(body)); + pair_set_syntax_op(form, OP_SAFE_DO); /* safe_do: body is safe, step by 1 */ + /* no semipermanent let here because apparently do_is_safe accepts recursive calls? */ + + /* this code sets the hop bit in any outer safe function call. I tried a procedure (leaf_hopper in tmp) that + * walked the body setting all the hop bits; this worked in all tests, but cost as much as it saved. + * this was in the inner block below originally. + */ + if ((is_optimized(car(body))) && + ((is_safe_c_op(op)) || (is_safe_closure_op(op)) || (is_safe_closure_star_op(op))) && + (!op_has_hop(car(body)))) + set_optimize_op(car(body), op + 1); /* set hop bit if it's a safe_closure call in a safe do loop */ + + if ((!has_set) && + (c_function_class(opt1_cfunc(end)) == sc->num_eq_class)) + { + /* vars is of the form ((i 0 (+ i 1))) -- 1 var etc */ + pair_set_syntax_op(form, OP_SAFE_DOTIMES); /* safe_dotimes: end is = */ + if (is_fxable(sc, car(body))) + fx_annotate_arg(sc, body, set_plist_1(sc, caar(vars))); /* if _args, fxification ignored? (need safe_closure_s_na etc) */ + /* is this redundant? safe_closure_s_a must already have fx, and otherwise it is ignored */ + } + fx_tree(sc, body, car(var), NULL, NULL, false); + if (stack_top_op(sc) == OP_SAFE_DO_STEP) + fx_tree_outer(sc, body, caaar(stack_top_code(sc)), NULL, NULL, true); + }} + if (DO_PRINT) fprintf(stderr, "%s[%d]: optimizable %s\n", __func__, __LINE__, display(form)); + return(sc->nil); + }}} + + /* we get here if there is more than one local var or anything "non-simple" about the rest */ + for (s7_pointer p = vars; is_pair(p); p = cdr(p)) + { + const 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))))) + { + for (s7_pointer q = vars; q != p; q = cdr(q)) + clear_match_symbol(caar(q)); + if (DO_PRINT) fprintf(stderr, "%s[%d]: return fxify_step_exprs for %s\n", __func__, __LINE__, display(form)); + 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)); + } + { - if (quotes == 1) { - fx_annotate_arg (sc, cdr (expr), let_or_list); - set_opt3_arglen (cdr (expr), 1); - if (func_is_safe) { - set_safe_optimize_op (expr, hop + OP_SAFE_C_A); - choose_c_function (sc, expr, func, 1); - return (opt_ok); - } - set_unsafe_optimize_op (expr, - hop + ((is_semisafe (func)) ? OP_CL_A : OP_C_A)); - choose_c_function (sc, expr, func, 1); - return (opt_bad); - } - /* quotes == 0 */ - if (!func_is_safe) { - const s7_pointer lambda_expr= arg1; - if ((is_ok_lambda (sc, lambda_expr)) && - (!direct_memq (car (lambda_expr), - let_or_list))) /* (let ((lambda #f)) (call-with-exit - (lambda ...))) */ + s7_pointer stepper0 = NULL, stepper1 = NULL, stepper2 = NULL, stepper3 = NULL; + bool got_pending = false, outer_shadowed = false; + + for (s7_pointer p = vars; is_pair(p); p = cdr(p)) { - 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) { - const s7_pointer arg_func= cadr (expr); - set_unsafe_optimize_op (expr, OP_CALL_CC); - /* (call/cc (lambda (return) (do ((i 0 (+ i 1))) ((= i 10)) (if (= i - * 3) (return 32))))) */ - - /* 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. But we - * can notice that embedded use? lambda(*)/m|bacro(*), curlet But - * just quitting on lambda seems over enthusiastic -- lambda is used - * for with-output-*, call/exit, dynwind etc see t861 for examples. - */ - if ((car (arg_func) == sc->lambda_symbol) && - (is_pair (cdr (arg_func))) && (is_pair (cadr (arg_func))) && - (is_normal_symbol (caadr (arg_func)))) { - const s7_pointer cc= caadr (arg_func); - if ((!tree_has_escaper (sc, cddr (arg_func), cc)) && - ((caddr (arg_func) != cc) || - (is_pair (cdddr ( - arg_func))))) /* (call/cc (lambda (return) return)) */ - { - set_unsafe_optimize_op (expr, (is_null (cdddr (lambda_expr))) - ? OP_CALL_WITH_EXIT_O - : OP_CALL_WITH_EXIT); - /* fprintf(stderr, "call/exit: %s\n", display(expr)); */ - } - /* else fprintf(stderr, "has cc: %s\n", display(cddr(arg_func))); - */ - } - } - else if (c_function_call (func) == g_call_with_exit) - set_unsafe_optimize_op (expr, (is_null (cdddr (lambda_expr))) - ? OP_CALL_WITH_EXIT_O - : 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_bad); - } - /* choose_c_function(sc, expr, func, 1); */ - /* clear_has_fn(expr); */ /* ??? this wipes out the - choose_c_function=set_c_function call?? - */ - 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_bad); - } - 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_bad); - } - } + s7_pointer var = car(p); + const s7_pointer val = cddr(var); + stepper3 = stepper2; + stepper2 = stepper1; + stepper1 = stepper0; + stepper0 = car(var); + if (is_pair(val)) + { + var = car(var); + clear_match_symbol(var); /* ignore current var */ + if (tree_match(car(val))) + { + for (s7_pointer q = vars; is_pair(q); q = cdr(q)) + clear_match_symbol(caar(q)); + if (is_null(body)) + got_pending = true; + else + { + if (DO_PRINT) fprintf(stderr, "%s[%d]: return fxify_step_exprs for %s\n", __func__, __LINE__, display(form)); + return(fxify_step_exprs(sc, code)); + }} + set_match_symbol(var); + }} + + for (s7_pointer p = vars; is_pair(p); p = cdr(p)) + set_match_symbol(caar(p)); + for (s7_pointer slot = let_slots(sc->curlet); is_not_slot_end(slot); slot = next_slot(slot)) + if (is_matched_symbol(slot_symbol(slot))) + { + outer_shadowed = true; + break; + } + for (s7_pointer p = vars; is_pair(p); p = cdr(p)) + clear_match_symbol(caar(p)); + + /* end and steps look ok! */ + for (s7_pointer p = vars; is_pair(p); p = cdr(p)) + { + const 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))) + { + const 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 + { + const s7_pointer endp = car(end); + const s7_pointer var1 = car(var); + if ((!is_quote(sc, car(step_expr))) && /* 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)); + + 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_loop_end_possible(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)))) + { + const s7_pointer var = caar(vars); + s7_pointer step = cddar(vars); + set_opt3_any(code, (in_heap(code)) ? sc->F : make_semipermanent_let(sc, vars)); + if (!got_pending) + pair_set_syntax_op(form, OP_DOX_NO_BODY); + 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(code, int_one); + else + if ((car(step) == sc->subtract_symbol) && + (cadr(step) == var) && + (caddr(step) == int_one)) + set_opt2_con(code, minus_one); + else set_opt2_con(code, int_zero); + } + else set_opt2_con(code, int_zero); + } + else set_opt2_con(code, int_zero); + } + if (do_passes_safety_check(sc, body, sc->nil, vars, NULL)) + { + s7_pointer var1 = NULL, var2 = NULL, var3 = NULL; + bool more_vars = false; + if (curlet_has_slots(sc)) /* outer vars */ + { + s7_pointer slot = let_slots(sc->curlet); + var1 = slot_symbol(slot); + slot = next_slot(slot); + if (is_not_slot_end(slot)) + { + var2 = slot_symbol(slot); + slot = next_slot(slot); + if (is_not_slot_end(slot)) + { + var3 = slot_symbol(slot); + more_vars = is_not_slot_end(next_slot(slot)); + }}} + for (s7_pointer p = vars; is_pair(p); p = cdr(p)) + { + const s7_pointer var = car(p); + if (is_pair(cdr(var))) + { + if (var1) fx_tree_in(sc, cdr(var), var1, var2, var3, more_vars); /* init vals, more_vars refers to outer let, stepper3 == local let more_vars */ + if (is_pair(cddr(var))) + { + if (stepper0) fx_tree(sc, cddr(var), stepper0, stepper1, stepper2, stepper3); + if ((var1) && (!outer_shadowed) && (!stepper3)) fx_tree_outer(sc, cddr(var), var1, var2, var3, more_vars); + }}} + + if ((is_pair(cdr(end))) && + (is_null(cddr(end))) && + (has_fx(cdr(end)))) + { + if (!fx_tree_in(sc, cdr(end), stepper0, stepper1, stepper2, stepper3)) + fx_tree(sc, cadr(end), stepper0, stepper1, stepper2, stepper3); + if ((var1) && (!outer_shadowed) && (!stepper3)) fx_tree_outer(sc, cdr(end), var1, var2, var3, more_vars); + } + + if ((is_pair(car(end))) && + (has_fx(end)) && + (!is_syntax(caar(end))) && + (!((is_symbol(caar(end))) && (is_definer_or_binder(caar(end)))))) + { + if (!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 ((var1) && (!outer_shadowed) && (!stepper3)) fx_tree_outer(sc, end, var1, var2, var3, more_vars); + } + + if ((is_pair(body)) && (is_null(cdr(body))) && + (is_fxable(sc, car(body)))) + { + s7_pointer var_list; + begin_temp(sc->y, sc->nil); + for (s7_pointer e1 = vars; is_pair(e1); e1 = cdr(e1)) sc->y = cons(sc, caar(e1), sc->y); + var_list = sc->y; + end_temp(sc->y); + fx_annotate_arg(sc, body, var_list); + if (stepper0) fx_tree(sc, body, stepper0, stepper1, stepper2, stepper3); + if ((var1) && (!outer_shadowed) && (!stepper3)) fx_tree_outer(sc, body, var1, var2, var3, more_vars); + }}} + if (DO_PRINT) fprintf(stderr, "%s[%d]: optimizable %s %s %s\n", __func__, __LINE__, display(form), op_names[optimize_op(form)], op_names[optimize_op(sc->code)]); + return(sc->nil); +} + +static bool has_safe_steppers(s7_scheme *sc, s7_pointer let) +{ + for (s7_pointer slot = let_slots(let); is_not_slot_end(slot); slot = next_slot(slot)) + { + const s7_pointer val = slot_value(slot); + if (slot_has_expression(slot)) + { + const s7_pointer step_expr = T_Pair(slot_expression(slot)); + 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, make_real(sc, real(val))); /* 2-Mar-25 was mutable? this is not a stepper, just a do local with no step expr */ + else + if (is_t_integer(val)) + slot_set_value(slot, make_integer(sc, integer(val))); /* same as above */ + 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) +{ + if ((fn_proc(endp) == g_num_eq_2) && (is_symbol(cadr(endp))) && (is_symbol(caddr(endp)))) + { + s7_pointer end_slot = s7_t_slot(sc, (cadr(endp) == slot_symbol(stepper)) ? caddr(endp) : cadr(endp)); + 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 test; + const s7_pointer code = cdr(sc->code); + const s7_pointer let = inline_make_let(sc, sc->curlet); + sc->temp1 = let; + for (s7_pointer 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->unused; + 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 = fx_proc(end); + s7_pointer endp = car(end); + if ((endf == fx_c_nc) || (endf == fx_c_0c)) + { + endf = fn_proc(endp); + endp = cdr(endp); + } + if (steppers == 1) + { + s7_function func = fx_proc(slot_expression(stepper)); /* e.g. fx_add_s1 */ + s7_pointer args = car(slot_expression(stepper)); + if ((func == fx_c_nc) || (func == fx_c_0c)) + { + func = fn_proc(args); + args = cdr(args); + } + if (((func == fx_cdr_s) || (func == fx_cdr_t)) && + (cadr(args) == 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 (((func == fx_add_t1) || (func == fx_add_u1)) && (is_t_integer(slot_value(stepper)))) + { + const s7_pointer num = make_mutable_integer(sc, integer(slot_value(stepper))); + slot_set_value(stepper, num); + 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) = q_call(o).fb; + do {integer(num)++;} while (!fb(o)); /* do {integer(num)++;} while ((sc->value = optf(sc, endp)) == sc->F); */ + clear_mutable_integer(num); + sc->value = sc->T; + sc->code = cdr(end); + return(goto_do_end_clauses); + } + set_no_bool_opt(end); + } + do {integer(num)++;} while ((sc->value = endf(sc, endp)) == sc->F); + clear_mutable_integer(num); + } + else do {slot_set_value(stepper, func(sc, args));} while ((sc->value = endf(sc, endp)) == sc->F); + sc->code = cdr(end); + return(goto_do_end_clauses); + } + if ((steppers == 2) && + (!is_not_slot_end(next_slot(next_slot(slots))))) + { + s7_pointer step1 = slots; + const s7_pointer expr1 = slot_expression(step1); + const s7_pointer step2 = next_slot(step1); + const s7_pointer 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 lim = integer(caddr(endp)); + for (s7_int 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_pair(sc->code)) return(goto_start); /* no result: (define (f) (do ((x 0 (+ x 1)) (i 0 (+ i 1))) ((= i 1)))) (f) (f) */ + if ((!is_symbol(car(sc->code))) || (is_pair(cdr(sc->code)))) /* more than one result: (define (f) (do ((x 0 (+ x 1)) (i 0 (+ i 1))) ((= i 1) x 3 4))) (f) */ + return(goto_do_end_clauses); + step1 = s7_slot(sc, car(sc->code)); + if (step1 == sc->undefined) /* (let () (define (f) (do ((x 0 (+ x 1)) (i 0 (+ i 1))) ((= i 1) y))) (f)) */ + unbound_variable_error_nr(sc, car(sc->code)); + sc->value = slot_value(step1); + if (is_t_real(sc->value)) + clear_mutable_number(sc->value); + return(goto_start); + } + do { + 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 (is_not_slot_end(slot)); + } 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 + */ + s7_int id; + int32_t steppers = 0; + s7_pointer code, end, endp, stepper = NULL, slots; + const s7_pointer form = sc->code; + s7_function endf; + const s7_pointer let = inline_make_let(sc, sc->curlet); /* new let is not tied into the symbol lookup process yet */ + if (SHOW_EVAL_OPS) fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display(form)); + sc->temp1 = let; + sc->code = cdr(sc->code); + for (s7_pointer vars = car(sc->code); is_pair(vars); vars = cdr(vars)) + { + const s7_pointer expr = cdar(vars); + s7_pointer slot; + const s7_pointer val = fx_call(sc, expr); + const s7_pointer stp = cdr(expr); /* cddar(vars) */ + new_cell_unchecked(sc, slot, T_SLOT); + slot_set_symbol_and_value(slot, caar(vars), val); + 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->unused; + 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) + */ + for (s7_pointer slot = slots; is_not_slot_end(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); + + if ((loop_end_possible(end)) && (steppers == 1) && + (is_t_integer(slot_value(stepper)))) + { + const s7_pointer stop_slot = (is_symbol(caddr(endp))) ? opt_integer_symbol(sc, caddr(endp)) : sc->nil; + if (stop_slot) /* sc->nil -> it's an integer */ + { + set_has_loop_end(stepper); + set_loop_end(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? from eval call of op_dox 96130 possibly from check_do */ + { + if (DO_PRINT) fprintf(stderr, "dox %d, no body\n", __LINE__); + 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)))) + { + const s7_pointer body = car(code); + s7_pfunc bodyf = NULL; + + sc->do_body_p = body; + if ((!no_cell_opt(code)) && + (has_safe_steppers(sc, sc->curlet))) + bodyf = s7_optimize_nv(sc, code); + + if ((!bodyf) && + (is_fxable(sc, body)) && /* happens very rarely, #_* as car etc */ + (is_c_function(car(body)))) + { + if ((S7_DEBUGGING) && (lookup(sc, c_function_symbol(car(body))) != car(body))) + fprintf(stderr, "%s[%d]: replacing %s with %s -> %s in %s\n", __func__, __LINE__, + display(car(body)), + display(c_function_symbol(car(body))), + display(lookup(sc, c_function_symbol(car(body)))), + display(body)); + bodyf = s7_optimize_nv(sc, set_dlist_1(sc, set_ulist_1(sc, c_function_symbol(car(body)), cdr(body)))); /* trouble! #_xyzzy need not match xyzzy */ + } + if (bodyf) + { + if (steppers == 1) /* one expr body, 1 stepper */ + { + const s7_pointer stepa = car(slot_expression(stepper)); + const s7_function 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_nv) + { + s7_pointer (*fp)(opt_info *o) = q_call(o).fp; + if (!((fp == opt_p_pip_sso) && (q_arg2(o).p == q_arg4(o).p) && + (((q_func(o).p_pip_f == string_set_p_pip_unchecked) && (q_func3(o).p_pi_f == string_ref_p_pi_unchecked)) || + ((q_func(o).p_pip_f == string_set_p_pip_direct) && (q_func3(o).p_pi_f == string_ref_p_pi_direct)) || + ((q_func(o).p_pip_f == vector_set_p_pip_unchecked) && (q_func3(o).p_pi_f == t_vector_ref_p_pi_unchecked)) || + ((q_func(o).p_pip_f == t_vector_set_p_pip_direct) && (q_func3(o).p_pi_f == t_vector_ref_p_pi_direct)) || + ((q_func(o).p_pip_f == list_set_p_pip_unchecked) && (q_func3(o).p_pi_f == list_ref_p_pi_unchecked))) && + (copy_if_end_ok(sc, slot_value(q_arg1(o).p), slot_value(q_arg3(o).p), i, endp, stepper)))) + { + if (has_loop_end(stepper)) + { /* (do ((val 0) (i 0 (+ i 1))) ((= i 1) val) (set! val (real-part (v b1 b2)))) */ + s7_int lim = loop_end(stepper); + if ((i >= 0) && (lim < NUM_SMALL_INTS)) + do {fp(o); slot_set_value(stepper, small_int(++i));} while (i < lim); + else do {fp(o); slot_set_value(stepper, make_integer(sc, ++i));} while (i < lim); + sc->value = sc->T; + } + else + do { /* (do ((i start (+ i 1))) ((= end i)) (display i)) */ + fp(o); + slot_set_value(stepper, make_integer(sc, ++i)); + } while ((sc->value = endf(sc, endp)) == sc->F); + }} + else + if (!(((bodyf == opt_float_any_nv) && (q_call(o).fd == opt_d_7pid_ss_ss) && + (q_arg2(o).p == q_arg4(o).p) && + ((q_func(o).d_7pid_f == float_vector_set_d_7pid) || (q_func(o).d_7pid_f == float_vector_set_d_7pid_direct)) && + ((q_func1(o).d_7pi_f == float_vector_ref_d_7pi) || (q_func1(o).d_7pi_f == float_vector_ref_d_7pi_direct)) && + (copy_if_end_ok(sc, slot_value(q_arg1(o).p), slot_value(q_arg3(o).p), i, endp, stepper))) || + + ((bodyf == opt_int_any_nv) && ((q_call(o).fi == opt_i_7pii_ssf) || (q_call(o).fi == opt_i_7pii_ssf_vset)) && + (q_arg2(o).p == q_func1_arg(o).q_arg2(o1).p) && + (((q_func(o).i_7pii_f == int_vector_set_i_7pii) && (q_func1_arg(o).q_func(o1).i_7pi_f == int_vector_ref_i_7pi)) || + ((q_func(o).i_7pii_f == int_vector_set_i_7pii_direct) && (q_func1_arg(o).q_func(o1).i_7pi_f == int_vector_ref_i_pi_direct))) && + (copy_if_end_ok(sc, slot_value(q_arg1(o).p), slot_value(q_func1_arg(o).q_arg1(o1).p), i, endp, stepper))))) + /* here the has_loop_end business doesn't happen much */ + do { /* (do ((count 0) (i 7 (+ i 1))) ((= i 10) count) (set! count (quotient i 3))) */ + bodyf(sc); + slot_set_value(stepper, make_integer(sc, ++i)); + } while ((sc->value = endf(sc, endp)) == sc->F); + sc->code = cdr(end); + sc->do_body_p = NULL; + return(goto_do_end_clauses); + } + do { /* (do ((count 0.0) (i 7.0 (+ i 1.0))) ((>= i 10.0) count) (set! count (modulo i 3.0))) */ + bodyf(sc); + slot_set_value(stepper, stepf(sc, stepa)); + } while ((sc->value = endf(sc, endp)) == sc->F); + sc->code = cdr(end); + sc->do_body_p = NULL; + return(goto_do_end_clauses); + } + + if ((steppers == 2) && + (!is_not_slot_end(next_slot(next_slot(slots))))) + { + const s7_pointer slot1 = slots, slot2 = next_slot(slots); + const s7_function f1 = fx_proc(slot_expression(slot1)); + const s7_function f2 = fx_proc(slot_expression(slot2)); + const s7_pointer p1 = car(slot_expression(slot1)); + const s7_pointer p2 = car(slot_expression(slot2)); + /* split out opt_float_any_nv gained nothing (see tmp), same for opt_cell_any_nv, constant end value was never hit */ + if (bodyf == opt_cell_any_nv) + { + opt_info *o = sc->opts[0]; + s7_pointer (*fp)(opt_info *o) = q_call(o).fp; + s7_pointer slot3 = NULL; + /* thash case -- this is dumb */ + if ((f2 == fx_add_u1) && (is_t_integer(slot_value(slot2))) && (cadr(endp) == slot_symbol(slot2)) && (!s7_tree_memq(sc, cadr(endp), body)) && + (((endf == fx_num_eq_ui) && (is_t_integer(caddr(endp)))) || + ((endf == fx_num_eq_us) && (slot3 = opt_integer_symbol(sc, caddr(endp))) && (!s7_tree_memq(sc, caddr(endp), body))))) + { /* (do ((i 0 (+ i 1)) (z (random 100) (random 100))) ((= i 5000000) counts) (hash-table-set! counts z (+ (or (hash-table-ref counts z) 0) 1))) */ + s7_int i = integer(slot_value(slot2)); + s7_int endi = (is_t_integer(caddr(endp))) ? integer(caddr(endp)) : integer(slot_value(slot3)); + do { + fp(o); + slot_set_value(slot1, f1(sc, p1)); + i++; + } while (i < endi); + slot_set_value(slot2, make_integer(sc, endi)); + } + else + do { /* (do ((i 0 (+ i 1)) (lst lis (cdr lst))) ((= i (- len 1)) (reverse result)) (set! result (cons (car lst) result))) */ + fp(o); + slot_set_value(slot1, f1(sc, p1)); + slot_set_value(slot2, f2(sc, p2)); + } while ((sc->value = endf(sc, endp)) == sc->F); + } + else + do { /* (do ((i 0 (+ i 1)) (j 0 (+ j 1))) ((= i 3) x) (set! x (max x (* i j)))) */ + bodyf(sc); + slot_set_value(slot1, f1(sc, p1)); + slot_set_value(slot2, f2(sc, p2)); + } while ((sc->value = endf(sc, endp)) == sc->F); + sc->code = cdr(end); + sc->do_body_p = NULL; + return(goto_do_end_clauses); + } + if (bodyf == opt_cell_any_nv) + { /* (do ((i npats (- i 1)) (ipats ipats (cdr ipats)) (a '())) ((zero? i) a) (set! a (cons (car ipats) a))) */ + opt_info *o = sc->opts[0]; + s7_pointer (*fp)(opt_info *o) = q_call(o).fp; + do { + s7_pointer slot1 = slots; + fp(o); + do { + if (slot_has_expression(slot1)) + slot_set_value(slot1, fx_call(sc, slot_expression(slot1))); + slot1 = next_slot(slot1); + } while (is_not_slot_end(slot1)); + } while ((sc->value = endf(sc, endp)) == sc->F); + } + else + do { /* (do ((i 0 (+ i 1)) (ph 0.0 (+ ph incr)) (kph 0.0 (+ kph kincr))) ((= i 4410)) (float-vector-set! v1 i (+ (cos ph) (cos kph)))) */ + s7_pointer slot1 = slots; + bodyf(sc); + do { + if (slot_has_expression(slot1)) + slot_set_value(slot1, fx_call(sc, slot_expression(slot1))); + slot1 = next_slot(slot1); + } while (is_not_slot_end(slot1)); + } while ((sc->value = endf(sc, endp)) == sc->F); + sc->code = cdr(end); + sc->do_body_p = NULL; + return(goto_do_end_clauses); + } /* if (bodyf) ... */ + + 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), stepa; + s7_function stepf, valf; + const s7_pointer slot = s7_slot(sc, cadr(body)); + if (slot == sc->undefined) /* (let ((lim 1)) (define (f) (let ((y 1)) (do ((i 0 (+ i y))) ((= i lim)) (set! xxx 3)))) (f)) */ + unbound_variable_error_nr(sc, cadr(body)); + /* here we could jump to the end of this procedure (unsetting op_dox etc) to avoid (set! a a) as an error if 'a is immutable */ + if (is_immutable_slot(slot)) /* (let ((lim 1)) (define-constant x 1) (define (f) (let ((y 1)) (do ((i 0 (+ i y))) ((= i lim)) (set! x 3)))) (f)) */ + immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "~S is immutable in ~S", 21), cadr(body), body)); /* "x is immutable in (set! x 3)" */ + + if (!has_fx(val)) + set_fx(val, fx_choose(sc, val, sc->curlet, let_symbol_is_safe)); + valf = fx_proc(val); + val = car(val); + stepf = fx_proc(slot_expression(stepper)); + stepa = car(slot_expression(stepper)); + do { /* (do ((i 1 4)) ((> i 3)) (set! x (+ x i))) */ + 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); + }} + 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)) && + (has_safe_steppers(sc, sc->curlet))) + { + sc->pc = 0; + for (int32_t 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)) + { + 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) /* (do ((i 0 (+ 1 i))) ((= end i)) (set! end 8) (display i)) */ + { + if (use_opts) + for (int32_t i = 0; i < body_len; i++) + q_call(body[i]).fp(body[i]); + /* opt_set_p_d_f shoot: 144,186,857 => s7.c:opt_set_p_d_f (2,093,278x) (b also, big/fft as part of fft code 7M) */ + else + for (s7_pointer p1 = code; is_pair(p1); p1 = cdr(p1)) + fx_call(sc, p1); + + 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 (is_not_slot_end(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 inline bool op_dox_step_1(s7_scheme *sc) /* inline for 50 in concordance, 30 in dup */ +{ + s7_pointer slot = let_slots(sc->curlet); + do { /* every dox case has vars (else op_do_no_vars) */ + if (slot_has_expression(slot)) /* splitting out 1-slot has_expr case is not faster (not enough hits) */ + slot_set_value(slot, fx_call(sc, slot_expression(slot))); + slot = next_slot(slot); + } while (is_not_slot_end(slot)); + sc->value = fx_call(sc, cadr(sc->code)); + if (is_true(sc, sc->value)) + { + sc->code = cdadr(sc->code); + return(true); + } + return(false); +} + +static void op_dox_step(s7_scheme *sc) +{ + push_stack_no_args_direct(sc, OP_DOX_STEP); + sc->code = T_Pair(cddr(sc->code)); +} + +static void op_dox_step_o(s7_scheme *sc) +{ + push_stack_no_args_direct(sc, OP_DOX_STEP_O); + sc->code = caddr(sc->code); +} + +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 = 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 set_curlet(sc, 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)) + { + const s7_int incr = integer(opt2_con(sc->code)); + const s7_pointer istep = make_mutable_integer(sc, integer(slot_value(slot))); /* mutable integer is faster here than wrapped */ + /* 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) + { + const s7_pointer t1 = cadr(test); + const s7_pointer t2 = caddr(test); + const s7_function f1 = fx_proc(cdr(test)); + const s7_function 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); /* just clears the T_MUTABLE bit */ + sc->value = fx_call(sc, result); + } + else + { + const s7_function stepf = fx_proc(cddr(var)); + const s7_pointer step = caddr(var); + if (testf == fx_or_and_2a) + { + const s7_pointer f1_arg = cadr(test), p = opt3_pair(test); /* cdadr(p) */ + const s7_function f1 = fx_proc(cdr(test)); + const s7_pointer f2_arg = car(p); + const s7_pointer f3_arg = cadr(p); + const s7_function f2 = fx_proc(p); + const s7_function f3 = fx_proc(cdr(p)); + if (((stepf == fx_add_t1) || (stepf == fx_add_u1)) && (is_t_integer(slot_value(slot)))) + { + const s7_pointer 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); } - } - 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_bad); -} - -static bool -walk_fxable (s7_scheme* sc, s7_pointer tree) { - for (s7_pointer 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); +} + +static void op_dox_pending_no_body(s7_scheme *sc) +{ + s7_pointer test, slots; + bool all_steps = true; + const s7_pointer let = inline_make_let(sc, sc->curlet); + sc->temp1 = let; + sc->code = cdr(sc->code); + for (s7_pointer 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->unused; + test = cadr(sc->code); + + let_set_has_pending_value(sc->curlet); + if ((all_steps) && + (!is_not_slot_end(next_slot(next_slot(slots)))) && + (is_pair(cdr(test)))) + { + const s7_pointer slot1 = slots; + const s7_pointer expr1 = slot_expression(slot1); + const s7_pointer slot2 = next_slot(slot1); + const s7_pointer 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, sc->curlet); + return; } - } - return (true); + while ((sc->value = fx_call(sc, test)) == sc->F) + { + s7_pointer slot = slots; + do { + if (slot_has_expression(slot)) + slot_simply_set_pending_value(slot, fx_call(sc, slot_expression(slot))); + slot = next_slot(slot); + } while (is_not_slot_end(slot)); + slot = slots; + do { + if (slot_has_expression(slot)) + slot_set_value(slot, slot_pending_value(slot)); + slot = next_slot(slot); + } while (is_not_slot_end(slot)); + } + sc->code = cdr(test); + let_clear_has_pending_value(sc, sc->curlet); } -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, "%s[%d]: omit %s: %s\n", __func__, __LINE__, - op_names[optimize_op (p)], display (p)); - return (false); -} - -static opt_t -fxify_closure_s (s7_scheme* sc, s7_pointer func, s7_pointer expr, - s7_pointer let_or_list, int32_t hop) { - const s7_pointer body= closure_body (func); - fx_annotate_arg (sc, body, let_or_list); - /* we can't currently fx_annotate_arg(sc, cdr(expr), let_or_list) here because - * that opt2 field is in use elsewhere (opt2_sym, not sure where it's set) */ - set_safe_optimize_op (expr, hop + OP_SAFE_CLOSURE_S_A); - if ((is_pair (car (body))) && (is_pair (cdar (body))) && - (car (closure_pars (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) { - const 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); - } - } +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); } - } - set_closure_one_form_fx_arg (func); - fx_tree (sc, body, car (closure_pars (func)), NULL, NULL, false); - return (opt_ok); + push_stack_no_args_direct(sc, OP_DO_NO_VARS_NO_OPT_1); + sc->code = T_Pair(cddr(sc->code)); + return(false); } -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 let_or_list) { - if (!one_form) - set_optimize_op ( - expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_A - : OP_CLOSURE_A)); /* fx(body) cases here are - rare (make-index) */ - else if (!safe_case) set_optimize_op (expr, hop + OP_CLOSURE_A_O); - else { - const s7_pointer body= closure_body (func); - if (!is_fxable (sc, car (body))) - set_optimize_op (expr, hop + OP_SAFE_CLOSURE_A_O); - else { - fx_annotate_arg (sc, body, let_or_list); - 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_pars (func)) == cadar (body))) { - const 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); - /* why is this setting expr whereas _s case above sets cdr(expr)? */ - 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_pars (func)), NULL, NULL, false); - return (true); +static bool op_do_no_vars(s7_scheme *sc) +{ + s7_pointer p; + const s7_pointer 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; } - } - return (false); -} - -static opt_t -optimize_closure_sym (s7_scheme* sc, s7_pointer expr, s7_pointer func, - int32_t hop, int32_t args, s7_pointer let_or_list) { - 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_bad); - set_opt3_arglen (cdr (expr), args); - set_opt1_lambda_add (expr, func); - fx_annotate_args (sc, cdr (expr), let_or_list); - if (is_safe_closure (func)) { - const s7_pointer body= closure_body (func); - if (!has_fx (body)) /* does this have any effect? */ - { - fx_annotate_args (sc, body, let_or_list); - fx_tree (sc, body, closure_pars (func), NULL, NULL, false); - } - set_safe_optimize_op (expr, hop + OP_ANY_CLOSURE_SYM); - return (opt_ok); - } - set_unsafe_optimize_op (expr, hop + OP_ANY_CLOSURE_SYM); - return (opt_bad); -} - -static opt_t -optimize_closure_a_sym (s7_scheme* sc, s7_pointer expr, s7_pointer func, - int32_t hop, int32_t args, s7_pointer let_or_list) { - if (fx_count (sc, expr) != args) return (opt_bad); - set_opt3_arglen (cdr (expr), args); - set_opt1_lambda_add (expr, func); - fx_annotate_args (sc, cdr (expr), let_or_list); - if (is_safe_closure (func)) { - const s7_pointer body= closure_body (func); - if (!has_fx (body)) /* does this have any effect? */ - { - fx_annotate_args (sc, body, let_or_list); - fx_tree (sc, body, car (closure_pars (func)), cdr (closure_pars (func)), - NULL, false); - } - set_safe_optimize_op (expr, hop + OP_ANY_CLOSURE_A_SYM); - return (opt_ok); - } - set_unsafe_optimize_op (expr, hop + OP_ANY_CLOSURE_A_SYM); - return (opt_bad); -} - -static opt_t -optimize_closure_one_arg (s7_scheme* sc, s7_pointer expr, s7_pointer func, - int32_t hop, int32_t symbols, - s7_pointer let_or_list) { - const int32_t arit= closure_arity_to_int (sc, func); - if (arit != 1) { - if (is_symbol (closure_pars ( - func))) /* (arit == -1) is ambiguous: (define (f . a)...) and - (define (f a . b)...) both are -1 here */ - return (optimize_closure_sym (sc, expr, func, hop, 1, let_or_list)); - if ((arit == -1) && (is_symbol (cdr (closure_pars (func))))) - return (optimize_closure_a_sym (sc, expr, func, hop, 1, let_or_list)); - return (opt_bad); - } - { - const s7_pointer arg1 = cadr (expr); - const bool safe_case= is_safe_closure (func); - const s7_pointer body = closure_body (func); - const bool 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, let_or_list, hop)); - set_optimize_op ( - expr, - hop + - OP_SAFE_CLOSURE_S_O); /* tleft 7638 if _O here, 7692 if not - (and claims 80 in the begin setup) */ - } - else set_optimize_op (expr, hop + OP_CLOSURE_S_O); - } + if (is_null(p)) + { + const s7_pointer end = cadr(sc->code); + set_curlet(sc, inline_make_let(sc, sc->curlet)); + if (i == 1) + while ((sc->value = fx_call(sc, end)) == sc->F) q_call(body[0]).fp(body[0]); /* presetting body[0] and body[0]-v[0].fp is not faster */ else - set_optimize_op ( - expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_S : OP_CLOSURE_S)); - set_unsafely_optimized (expr); - return (opt_bad); - } - if (fx_count (sc, expr) == 1) { - set_unsafely_optimized (expr); - set_opt1_lambda_add (expr, func); - fx_annotate_arg (sc, cdr (expr), let_or_list); - set_opt3_arglen (cdr (expr), 1); - if (fxify_closure_a (sc, func, one_form, safe_case, hop, expr, - let_or_list)) - return (opt_ok); - set_unsafely_optimized (expr); - return (opt_bad); - } - 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), 1); - 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), let_or_list); + if (i == 2) + { + opt_info *o0 = body[0], *o1 = body[1]; + s7_pointer (*fp0)(opt_info *o) = q_call(o0).fp; + s7_pointer (*fp1)(opt_info *o) = q_call(o1).fp; + while ((sc->value = fx_call(sc, end)) == sc->F) {fp0(o0); fp1(o1);} + } + else + if (i == 0) /* null body! */ + { + s7_function endf = fx_proc(end); + s7_pointer endp = car(end); + while (!is_true(sc, sc->value = endf(sc, endp))); /* the assignment is (normally) in the noise */ + } + else + while ((sc->value = fx_call(sc, end)) == sc->F) + for (int32_t k = 0; k < i; k++) + q_call(body[k]).fp(body[k]); + sc->code = cdr(end); /* inner let still active during result */ + return(true); } - } - return (opt_bad); /* don't check is_optimized here for opt_ok */ + /* back out */ + pair_set_syntax_op(form, OP_DO_NO_VARS_NO_OPT); + set_curlet(sc, make_let(sc, sc->curlet)); + return(op_do_no_vars_no_opt_1(sc)); } -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 let_or_list) { - s7_pointer arg1= cadr (expr); - if (SHOW_EVAL_OPS) - fprintf (stderr, - " %s[%d]: expr: %s, func: %s, hop: %d, pairs: %d, symbols: %d, " - "quotes: %d, bad_pairs: %d, let_or_list: %s\n", - __func__, __LINE__, display_truncated (expr), display (func), hop, - pairs, symbols, quotes, bad_pairs, - display_truncated (let_or_list)); - /* 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, let_or_list)) return (opt_oops); - if ((bad_pairs == quotes) && (is_symbol (car (expr))) && - (is_constant_symbol (sc, car (expr)))) - hop= 1; - } - /* need in_with_let -> search only rootlet not lookup */ - if ((symbols == 1) && - ((!symbol_is_safe (sc, arg1, let_or_list)) || - (sc->in_with_let))) /* (set! (with-let ...) ...) can involve an unbound - variable otherwise bound */ - { - /* 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, let_or_list)); +static void op_do_no_vars_no_opt(s7_scheme *sc) +{ + sc->code = cdr(sc->code); + set_curlet(sc, inline_make_let(sc, sc->curlet)); +} + +static void op_do_no_body_na_vars(s7_scheme *sc) /* vars fxable, end-test not */ +{ + s7_pointer stepper = NULL; + s7_int steppers = 0; + const s7_pointer let = inline_make_let(sc, sc->curlet); + sc->temp1 = let; + sc->code = cdr(sc->code); + for (s7_pointer 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); } - return (opt_bad); - } + if (steppers == 1) let_set_dox_slot1(let, stepper); + set_curlet(sc, let); + sc->temp1 = sc->unused; + push_stack_no_args_direct(sc, (intptr_t)((steppers == 1) ? OP_DO_NO_BODY_NA_VARS_STEP_1 : OP_DO_NO_BODY_NA_VARS_STEP)); + sc->code = caadr(sc->code); +} - switch (type (func)) { - case T_C_FUNCTION: /* these two happen much more than everything else put - together, but splitting them out to avoid the switch - doesn't gain much */ - if (!c_function_is_aritable (func, 1)) return (opt_bad); - case T_C_RST_NO_REQ_FUNCTION: - return (optimize_c_function_one_arg (sc, expr, func, hop, pairs, symbols, - quotes, bad_pairs, let_or_list)); - - case T_CLOSURE: - return ( - optimize_closure_one_arg (sc, expr, func, hop, symbols, let_or_list)); - - case T_CLOSURE_STAR: - if (is_null (closure_pars (func))) return (opt_bad); - if (fx_count (sc, expr) == 1) { - const bool safe_case= is_safe_closure (func); - if (is_immutable (func)) hop= 1; - fx_annotate_arg (sc, cdr (expr), let_or_list); - set_opt1_lambda_add (expr, func); - set_opt3_arglen (cdr (expr), 1); - set_unsafely_optimized (expr); - - if ((safe_case) && (is_null (cdr (closure_pars (func))))) - set_optimize_op (expr, hop + OP_SAFE_CLOSURE_STAR_A1); - else if (lambda_has_simple_defaults (func)) { - if (arglist_has_rest (sc, closure_pars (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_bad); - - case T_C_FUNCTION_STAR: - if ((fx_count (sc, expr) == 1) && (c_function_max_args (func) >= 1) && - (!is_symbol_and_keyword (arg1))) /* the only arg should not be a keyword - (needs error checks later) */ - { - if ((hop == 0) && ((is_immutable (func)) || - ((!sc->in_with_let) && (is_global (car (expr)))))) - hop= 1; - set_safe_optimize_op (expr, hop + OP_SAFE_C_STAR_A); - fx_annotate_arg (sc, cdr (expr), let_or_list); - set_opt3_arglen (cdr (expr), 1); - set_class_and_fn_proc (expr, func); - return (opt_ok); - } - break; - - case T_PAIR: - case T_VECTOR: - case T_INT_VECTOR: - case T_BYTE_VECTOR: - case T_FLOAT_VECTOR: - case T_COMPLEX_VECTOR: - if (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), let_or_list); - set_opt3_arglen (cdr (expr), 1); - return (opt_ok); - } - break; - - case T_LET: - /* implicit function/c-object -> (f 'a) if f is a function is a function - * call, not a funclet or c-object-let reference, ((funclet f) 'a). - * c-pointer might work, but it's too similar to c-object, and you can - * always use ((c-pointer-info p) 'a). - */ - if (((quotes == 1) && (is_symbol (cadr (arg1)))) || /* (e 'a) or (e ':a) */ - (is_symbol_and_keyword (arg1))) /* (e :a) */ +static bool op_do_no_body_na_vars_step(s7_scheme *sc) +{ + if (sc->value != sc->F) { - s7_pointer sym= (quotes == 1) ? cadr (arg1) : arg1; - if (is_keyword (sym)) sym= keyword_symbol (sym); - if (func == sc->starlet) /* (*s7* ...), sc->starlet is a let */ - { - set_safe_optimize_op (expr, OP_IMPLICIT_STARLET_REF_S); - set_opt3_int (expr, starlet_symbol_id (sym)); - return (opt_ok); - } - set_opt3_con (expr, sym); - set_unsafe_optimize_op (expr, OP_IMPLICIT_LET_REF_C); - return (opt_ok); - } - /* fall through */ - - case T_HASH_TABLE: - case T_C_OBJECT: - if (is_fxable (sc, arg1)) { - set_unsafe_optimize_op (expr, (type (func) == T_LET) - ? OP_IMPLICIT_LET_REF_A - : ((type (func) == T_HASH_TABLE) - ? OP_IMPLICIT_HASH_TABLE_REF_A - : OP_IMPLICIT_C_OBJECT_REF_A)); - fx_annotate_arg (sc, cdr (expr), let_or_list); - set_opt3_arglen (cdr (expr), 1); - return (opt_ok); - } - break; - - default: - break; - } - return ((is_optimized (expr)) ? opt_ok : opt_bad); + sc->code = cdadr(sc->code); + return(true); + } + for (s7_pointer slot = let_slots(sc->curlet); is_not_slot_end(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_NA_VARS_STEP); + sc->code = caadr(sc->code); + return(false); } -static bool -unsafe_is_safe (s7_scheme* sc, s7_pointer sym, s7_pointer symbols) { - s7_pointer slot; - if (!is_symbol (sym)) return (false); - slot= find_uncomplicated_symbol ( - sc, sym, symbols); /* how to catch local c-funcs here? */ - if (!is_slot (slot)) return (false); - return (is_safe_c_function (slot_value (slot))); -} - -static opt_t -set_any_closure_np (s7_scheme* sc, s7_pointer func, s7_pointer expr, - s7_pointer let_or_list, int32_t num_args, opcode_t op) { - for (s7_pointer p= cdr (expr); is_pair (p); p= cdr (p)) - set_fx (p, fx_choose (sc, p, let_or_list, - (is_list (let_or_list)) ? pair_symbol_is_safe - : let_symbol_is_safe)); - set_opt3_arglen (cdr (expr), num_args); - set_unsafe_optimize_op (expr, op); - set_opt1_lambda_add (expr, func); - return (opt_bad); -} - -static bool -two_args_ok (s7_scheme* sc, s7_pointer expr, s7_pointer let_or_list) { - if ((is_symbol (car (expr))) && - ((car (expr) == sc->member_symbol) || (car (expr) == sc->assoc_symbol))) - return (true); - return (unsafe_is_safe (sc, cadr (expr), let_or_list)); -} - -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_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 let_or_list, int32_t num_args, opcode_t op) { - /* we get 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? or use op_stack? error clears - * this? op-any-c-fp: op_any_c_2p|3p|fp? -- mimic clo_3p|4p? - */ - for (s7_pointer p= cdr (expr); is_pair (p); p= cdr (p)) - set_fx (p, fx_choose (sc, p, let_or_list, - (is_list (let_or_list)) ? pair_symbol_is_safe - : let_symbol_is_safe)); - set_opt3_arglen (cdr (expr), 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_bad); -} - -static s7_function -io_function (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 clo, s7_pointer code, - int32_t hop) { - const int32_t arity = closure_star_arity_to_int (sc, clo); - const bool safe_case= is_safe_closure (clo); - const s7_pointer arg1 = cadr (code); - s7_pointer par1 = car (closure_pars (clo)); - if (is_pair (par1)) par1= car (par1); - - set_opt3_arglen (cdr (code), 2); - set_unsafely_optimized (code); - - if ((arity == 1) && (is_symbol_and_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 (clo)) && (arity == 2)) - set_optimize_op (code, - hop + ((safe_case) ? ((is_null (cdr (closure_body (clo)))) - ? OP_SAFE_CLOSURE_STAR_AA_O - : OP_SAFE_CLOSURE_STAR_AA) - : OP_CLOSURE_STAR_NA)); - else - set_optimize_op (code, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_NA_2 - : OP_CLOSURE_STAR_NA)); +static bool op_do_no_body_na_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_NA_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 */ + { + for (s7_pointer slots = sc->code; is_pair(slots); slots = cdr(slots)) /* sc->code here is the original sc->args list */ + { + const s7_pointer slot = car(slots); + if (is_immutable_slot(slot)) /* (let () (define (func) (do ((x 0) (i 0 (+ i 1))) ((= i 1) x) (set! x (immutable! 'i)))) (func)) */ + immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "~S is immutable in ~S", 21), slot_symbol(slot), car(slot_expression(slot)))); + slot_set_value(slot, slot_pending_value(slot)); + slot_clear_has_pending_value(slot); + } + pop_stack_no_op(sc); + return(true); + } + code = T_Pair(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 = T_Lst(cdr(sc->args)); /* go to next step var */ + } + else + { + push_stack_direct(sc, OP_DO_STEP2); + sc->code = car(code); + return(false); + }} } -static int32_t check_lambda (s7_scheme* sc, s7_pointer form, bool optl); +static bool op_do_step2(s7_scheme *sc) +{ + if (is_multiple_value(sc->value)) + syntax_error_nr(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 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 let_or_list) { - const s7_pointer arg1p= cdr (expr), arg1= cadr (expr), arg2= caddr (expr); - if (SHOW_EVAL_OPS) - fprintf (stderr, - " %s[%d]: expr: %s, func: %s, hop: %d, pairs: %d, symbols: %d, " - "quotes: %d, bad_pairs: %d, let_or_list: %s\n", - __func__, __LINE__, display_truncated (expr), display (func), hop, - pairs, symbols, quotes, bad_pairs, - display_truncated (let_or_list)); - if (quotes > 0) { - if (direct_memq (sc->quote_symbol, let_or_list)) return (opt_oops); - if ((bad_pairs == quotes) && (is_symbol (car (expr))) && - (is_constant_symbol (sc, car (expr)))) - hop= 1; - } - if ((!symbol_is_safe (sc, arg1, let_or_list)) || - (!symbol_is_safe (sc, arg2, let_or_list))) { - /* wrap bad args */ - if ((is_fxable (sc, arg1)) && (is_fxable (sc, arg2)) && - (s7_is_aritable (sc, func, - 2))) /* arg_findable key -> #t(?) so clo* ok */ +static bool op_do_step(s7_scheme *sc) /* called only in eval OP_DO_STEP via op_do_end_false */ +{ + /* 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>)) -- is this comment correct? + */ + push_stack_direct(sc, OP_DO_END); + sc->args = car(sc->args); /* the var data lists */ + sc->code = T_Lst(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)) { - fx_annotate_args (sc, arg1p, let_or_list); - return (wrap_bad_args (sc, func, expr, 2, hop, let_or_list)); + sc->value = fx_call(sc, sc->code); + return(goto_start); } - return (opt_bad); - } - /* end of bad symbol wrappers */ + sc->code = T_Pair(car(sc->code)); + return(goto_eval); +} - if (is_c_function (func) && (c_function_is_aritable (func, 2))) { - /* this is a mess */ - const bool func_is_safe= is_safe_procedure (func); - if (hop == 0) hop= hop_if_constant (sc, car (expr)); - if (pairs == 0) { - if ((func_is_safe) || - ((is_maybe_safe (func)) && (two_args_ok (sc, expr, let_or_list)))) { - /* 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_opt1_sym (arg1p, arg2); - } - else if (is_normal_symbol (arg1)) { - set_opt1_con (arg1p, arg2); - set_optimize_op (expr, hop + OP_SAFE_C_SC); - } - else { - set_opt1_con (arg1p, arg1); /* set_opt2_sym(arg1p, arg2); */ - set_optimize_op (expr, hop + OP_SAFE_C_CS); - } - set_optimized (expr); - choose_c_function (sc, expr, func, 2); - return (opt_ok); - } - 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_opt1_sym (arg1p, 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 - : (((symbols == 0) && (pairs == 0) && - (car (expr) == sc->values_symbol)) - ? OP_C_NC - : OP_C_AA))); - fx_annotate_args (sc, arg1p, let_or_list); - set_opt3_arglen (arg1p, 2); - 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_opt1_con (arg1p, arg2); - } - else { - set_opt1_con (arg1p, arg1); /* set_opt2_sym(arg1p, arg2); */ - set_optimize_op (expr, hop + OP_SAFE_C_CS); - } - } - return (opt_ok); - } - else if ((symbols == 1) && - (is_normal_symbol ( - arg1))) /* arg2 must be constant since pairs==0 */ - { - set_optimize_op (expr, hop + OP_C_SC); - set_opt3_con (arg1p, arg2); /* a very small optimization! */ - } - } - return (opt_bad); - } - - /* pairs != 0 */ - if ((bad_pairs == 0) && (pairs == 2)) { - if ((func_is_safe) || - ((is_maybe_safe (func)) && (two_args_ok (sc, expr, let_or_list)))) { - const int32_t op= combine_ops (sc, expr, combine_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_defined_global (caadr (expr))) && - (is_defined_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(arg1p, - 2); */ - set_safe_optimize_op (expr, HOP_SAFE_C_FF); - } - opt_sp_1 (sc, c_function_call (func), - expr); /* calls set_opt1_any, sets opt1(arg1p) 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, let_or_list)); /* AA case */ - set_optimize_op (expr, hop + OP_SAFE_C_AP); - fx_annotate_arg (sc, arg1p, let_or_list); - set_opt3_arglen (arg1p, 2); - } - else if (is_fxable (sc, arg2)) { - set_optimize_op (expr, hop + OP_SAFE_C_PA); - fx_annotate_arg (sc, cddr (expr), let_or_list); - set_opt3_arglen (arg1p, 2); - } - } - choose_c_function ( - sc, expr, func, - 2); /* this might change the op to safe_c_c, so it has to be last */ - return (opt_ok); - } - } +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); +} - if ((bad_pairs == 0) && (pairs == 1)) { - if ((func_is_safe) || - ((is_maybe_safe (func)) && (two_args_ok (sc, expr, let_or_list)))) { - combine_op_t orig_op; - int32_t op; +static bool opt_do_copy(s7_scheme *sc, opt_info *o, s7_int start, s7_int stop) +{ + s7_pointer (*fp)(opt_info *o) = q_call(o).fp; /* o-[6].p_pi_f (q_func3) is getter, o-v[5].p_pip_f (q_func) is setter */ + if (start >= stop) return(true); + if ((fp == opt_p_pip_sso) && + (type(slot_value(q_arg1(o).p)) == type(slot_value(q_arg3(o).p))) && + (q_arg2(o).p == q_arg4(o).p)) + { + s7_pointer caller = NULL; + const s7_pointer dest = slot_value(q_arg1(o).p); + const s7_pointer source = slot_value(q_arg3(o).p); + if ((is_t_vector(dest)) && + (((q_func(o).p_pip_f == vector_set_p_pip_unchecked) || (q_func(o).p_pip_f == t_vector_set_p_pip_direct)) && + ((q_func3(o).p_pi_f == t_vector_ref_p_pi_unchecked) || (q_func3(o).p_pi_f == vector_ref_p_pi_unchecked) || + (q_func3(o).p_pi_f == t_vector_ref_p_pi_direct)))) + caller = sc->vector_set_symbol; + else + if ((is_string(dest)) && + (((q_func(o).p_pip_f == string_set_p_pip_unchecked) || (q_func(o).p_pip_f == string_set_p_pip_direct)) && + ((q_func3(o).p_pi_f == string_ref_p_pi_unchecked) || (q_func3(o).p_pi_f == string_ref_p_pi_direct)))) + caller = sc->string_set_symbol; + else + if ((is_pair(dest)) && + ((q_func(o).p_pip_f == list_set_p_pip_unchecked) && (q_func3(o).p_pi_f == list_ref_p_pi_unchecked))) + caller = sc->list_set_symbol; + else return(false); + if (start < 0) + out_of_range_error_nr(sc, caller, wrap_integer(sc, 2), wrap_integer(sc, start), it_is_negative_string); + if ((stop > integer(s7_length(sc, source))) || (stop > integer(s7_length(sc, dest)))) + out_of_range_error_nr(sc, caller, wrap_integer(sc, 2), wrap_integer(sc, stop), it_is_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; - if (is_pair (arg1)) { - orig_op= (is_normal_symbol (arg2)) ? combine_ps : combine_pc; - op = combine_ops (sc, expr, orig_op, arg1, arg2); - } - else { - orig_op= (is_normal_symbol (arg1)) ? combine_sp : combine_cp; - op = combine_ops (sc, expr, orig_op, arg1, arg2); - } - if ((hop == 1) && - (((is_pair (arg2)) && (!op_has_hop (arg2)) && - (is_symbol (car (arg2))) && (is_maybe_shadowed (car (arg2)))) || - ((is_pair (arg1)) && (!op_has_hop (arg1)) && - (is_symbol (car (arg1))) && (is_maybe_shadowed (car (arg1)))))) { - hop= 0; - if (!is_symbol (car (expr))) - set_car (expr, c_function_symbol (car ( - expr))); /* maybe symbol_initial_value(...) */ - } - /* arg2 case: (let () (define (func) (let ((i 0)) (define + *) (quotient - * 10001 (+ i 1)))) (func)) -> division by zero error */ - /* arg1 case: (let () (define (func) (let ((i 0)) (define + *) - * (remainder (+ i 1) 101))) (func)) ; 0 */ - - 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, arg1p, let_or_list); - 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 (arg1p, arg1); - } - else if (op == OP_SAFE_C_PC) set_opt3_con (arg1p, arg2); - } - choose_c_function (sc, expr, func, 2); - return (opt_ok); - } + if (no_cell_opt(cddr(code))) + return(false); + sc->do_body_p = caddr(code); + func = s7_optimize_nv(sc, cddr(code)); + if (!func) + { + set_no_cell_opt(cddr(code)); + return(false); } - - if ((bad_pairs == 1) && (quotes == 1)) { - if ((func_is_safe) || - ((is_maybe_safe (func)) && (two_args_ok (sc, expr, let_or_list)))) { - if (symbols == 1) { - set_optimized (expr); - if (is_normal_symbol (arg1)) { - set_opt1_con (arg1p, cadr (arg2)); - set_optimize_op (expr, hop + OP_SAFE_C_SC); - } - else { - set_opt1_con (arg1p, cadr (arg1)); /* set_opt2_sym(arg1p, arg2); */ - set_optimize_op (expr, hop + OP_SAFE_C_CS); - } - choose_c_function (sc, expr, func, 2); - return (opt_ok); - } - if ((pairs == 1) && (is_pair (arg2))) /* QC never happens */ - { - set_safe_optimize_op (expr, hop + OP_SAFE_C_CQ); - set_opt2_con (arg1p, cadr (arg2)); - choose_c_function (sc, expr, func, 2); - return (opt_ok); - } - if (!is_safe_c_s (arg1)) { - if ((is_fxable (sc, arg1)) && (is_fxable (sc, arg2))) - return (check_c_aa (sc, expr, func, hop, let_or_list)); - } - } - else if (pairs == 1) { - set_unsafe_optimize_op ( - expr, hop + ((is_semisafe (func)) ? OP_CL_AA : OP_C_AA)); - fx_annotate_args (sc, arg1p, let_or_list); - set_opt3_arglen (arg1p, 2); - choose_c_function (sc, expr, func, 2); - return (opt_bad); - } + /* 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)))) + { + const s7_int start = integer(slot_value(ctr_slot)), stop = integer(slot_value(end_slot)); + if (func == opt_cell_any_nv) + { + opt_info *o = sc->opts[0]; + s7_pointer (*fp)(opt_info *o) = q_call(o).fp; + if ((fp == opt_p_ppp_sss) || (fp == opt_p_ppp_sss_mul) || (fp == opt_p_ppp_sss_hset)) + { /* (do ((i 0 (+ i 1))) ((= i 1) (let-ref lt 'a)) (let-set! lt sym i)) */ + s7_p_ppp_t fpt = q_func(o).p_ppp_f; + for (s7_int i = start; i < stop; i++) /* thash and below */ + { + slot_set_value(ctr_slot, make_integer(sc, i)); + fpt(sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p), slot_value(q_arg3(o).p)); + }} + else + if (fp == opt_p_ppp_sfs) + { /* (do ((i 0 (+ i 1))) ((= i 9)) (vector-set! v4 (expt 2 i) i)) */ + s7_p_ppp_t fpt = q_func(o).p_ppp_f; + for (s7_int i = start; i < stop; i++) + { + slot_set_value(ctr_slot, make_integer(sc, i)); + fpt(sc, slot_value(q_arg1(o).p), q_p_func1_call(o), slot_value(q_arg2(o).p)); + }} + else + if ((fp == opt_p_pip_sss_vset) && (start >= 0) && (stop <= vector_length(slot_value(q_arg1(o).p)))) + { /* (do ((i 0 (+ i 1))) ((= i 10) v) (vector-set! v i i)) */ + s7_pointer *vels = vector_elements(slot_value(q_arg1(o).p)); /* better in callgrind, possibly slightly slower in time */ + check_free_heap_size(sc, stop - start); + for (s7_int i = start; i < stop; i++) + { + slot_set_value(ctr_slot, make_integer_unchecked(sc, i)); + vels[integer(slot_value(q_arg2(o).p))] = slot_value(q_arg3(o).p); + }} + else /* (do ((i 0 (+ i 1))) ((= i 1) (let-ref lt 'a)) (let-set! lt 'a i)) or (do ((i 0 (+ i 1))) ((= i 10)) (list-set! lst i i)) */ + for (s7_int i = start; i < stop; i++) + { + slot_set_value(ctr_slot, make_integer(sc, i)); + fp(o); + }} + else + { /* (do ((j (+ nv k -1) (- j 1))) ((< j k)) (set! (r j) (- (r j) (* (q k) (p2 (- j k)))))) */ + /* (do ((__i__ 0 (+ __i__ 1))) ((= __i__ 1) 32.0) (b 0)) and many more, all wrap-int safe I think */ + /* splitting out opt_float_any_nv here saves almost nothing */ + for (s7_int i = start; i < stop; i++) + { + slot_set_value(ctr_slot, make_integer(sc, i)); + func(sc); + }} + sc->value = sc->T; + sc->code = cdadr(code); + sc->do_body_p = NULL; + 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)))) + { + const s7_int start = integer(slot_value(ctr_slot)), stop = integer(slot_value(end_slot)); + if (func == opt_cell_any_nv) + { + opt_info *o = sc->opts[0]; + if (!opt_do_copy(sc, o, stop, start + 1)) + { /* (do ((i 9 (- i 1))) ((< i 0) v) (vector-set! v i i)) */ + s7_pointer (*fp)(opt_info *o) = q_call(o).fp; + for (s7_int i = start; i >= stop; i--) + { + slot_set_value(ctr_slot, make_integer(sc, i)); + fp(o); + }}} + else /* (do ((i 9 (- i 1))) ((< i 0)) (set! (v i) (delay gen 0.5 i))) */ + for (s7_int i = start; i >= stop; i--) + { + slot_set_value(ctr_slot, make_integer(sc, i)); + func(sc); + } + sc->value = sc->T; + sc->code = cdadr(code); + sc->do_body_p = NULL; + return(true); + } + if ((stepf == g_add_2) && /* this was g_add_2_xi, 27-Sep-24 */ + (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)))) + { + const s7_int start = integer(slot_value(ctr_slot)), stop = integer(slot_value(end_slot)), incr = integer(caddr(step_expr)); + if (func == opt_cell_any_nv) + { /* (do ((i 0 (+ i 2))) ((= i 20)) (display (/ i 2))) */ + /* (do ((i 0 (+ i 8))) ((= i 64)) (write-byte (logand (ash int (- i)) 255))) */ + opt_info *o = sc->opts[0]; + s7_pointer (*fp)(opt_info *o) = q_call(o).fp; + for (s7_int i = start; i < stop; i += incr) + { + slot_set_value(ctr_slot, make_integer(sc, i)); + fp(o); + }} + else + for (s7_int 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); + sc->do_body_p = NULL; + return(true); + } + if (func == opt_cell_any_nv) + { + opt_info *o = sc->opts[0]; + s7_pointer (*fp)(opt_info *o) = q_call(o).fp; + if ((stepf == g_add_x1) && (is_t_integer(slot_value(ctr_slot))) && + (endf == g_greater_2) && (is_t_integer(slot_value(end_slot)))) + { + const s7_int start = integer(slot_value(ctr_slot)), stop = integer(slot_value(end_slot)); + if (fp == opt_cond_1b) + { /* (do ((i 0 (+ i 1))) ((> i a)) (cond (i i))) ! */ + s7_pointer (*test_fp)(opt_info *o) = q_func1_arg(o).q_temp(o1).fp; /* see opt_cond_1b test expr */ + opt_info *test_o1 = q_func1_arg(o).o1; + opt_info *o2 = q_cond_val1(o).o1; + for (s7_int i = start; i <= stop; i++) + { + slot_set_value(ctr_slot, make_integer(sc, i)); + if (test_fp(test_o1) != sc->F) cond_value(o2); + }} + else /* (do ((i 0 (+ i 1))) ((> i a)) (vector-set! v i 1)) */ + for (s7_int i = start; i <= stop; i++) + { + slot_set_value(ctr_slot, make_integer(sc, i)); + fp(o); + }} + else /* (do ((i 0 (+ i 1))) ((> i 10)) (display i)) */ + 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 ((i 0 (+ i 1))) ((> i 3) i) (set! i (* i 10))) */ + 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); + sc->do_body_p = NULL; + 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 */ + const s7_pointer code = cdr(sc->code); + const s7_pointer end = opt1_any(code); /* caddr(caadr(code)) */ + const s7_pointer body = cddr(code); + + set_curlet(sc, make_let(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)); + + if (is_symbol(end)) + let_set_dox_slot2(sc->curlet, s7_t_slot(sc, end)); + 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 */ } + 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 checks that stepf is reasonable? */ + (is_t_integer(caddr(opt2_pair(code)))) && + (op_simple_do_1(sc, cdr(sc->code)))) + return(true); /* goto DO_END_CLAUSES */ - 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 (arg1p, 2); - } - fx_annotate_args (sc, arg1p, let_or_list); - choose_c_function (sc, expr, func, 2); - return ((func_is_safe) ? opt_ok : opt_bad); - } - - if ((pairs == 1) && (quotes == 0) && - ((func_is_safe) || - ((is_maybe_safe (func)) && (two_args_ok (sc, expr, let_or_list))))) { - 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_ok); - set_unsafe (expr); - return (opt_bad); - } - if (symbols == 0) { - set_optimized (expr); - if ((is_fxable (sc, arg1)) && (is_fxable (sc, arg2))) - return (check_c_aa (sc, expr, func, hop, let_or_list)); - if (is_pair (arg1)) { - set_optimize_op (expr, hop + OP_SAFE_C_PC); - set_opt3_con (arg1p, arg2); - } - else { - set_optimize_op (expr, hop + OP_SAFE_C_CP); - opt_sp_1 (sc, c_function_call (func), expr); - set_opt3_any (arg1p, arg1); - } - choose_c_function (sc, expr, func, 2); - if (bad_pairs == 0) return (opt_ok); - set_unsafe (expr); - return (opt_bad); - } + 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) +{ + const s7_pointer ctr = let_dox_slot1(sc->curlet); + s7_pointer end = let_dox_slot2(sc->curlet); + const s7_pointer code = sc->code; + const s7_pointer 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 /* is_symbol(caddr(step)) I think: (+ 1 x) vs (+ x 1) */ + { + 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); +} - if ((pairs == 2) && - ((func_is_safe) || - ((is_maybe_safe (func)) && (two_args_ok (sc, expr, let_or_list))))) { - 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 (is_safe_quote (sc, car (arg2))) { - 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 (arg1p, cadr (arg1)); - set_opt2_con (arg1p, cadr (arg2)); - choose_c_function (sc, expr, func, 2); - return (opt_ok); - } - } - 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, let_or_list)); - set_optimize_op (expr, hop + OP_SAFE_C_AP); - opt_sp_1 (sc, c_function_call (func), expr); - fx_annotate_arg (sc, arg1p, let_or_list); - } - else if (is_fxable (sc, arg2)) { - set_optimize_op (expr, hop + OP_SAFE_C_PA); - fx_annotate_arg (sc, cddr (expr), let_or_list); - } - else { - set_optimize_op (expr, hop + OP_SAFE_C_PP); - opt_sp_1 (sc, c_function_call (func), expr); - } - choose_c_function (sc, expr, func, 2); - return (opt_bad); - } - if (quotes == 1) { - if (is_safe_quote (sc, car (arg1))) { - 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 (arg1p, cadr (arg1)); - } - else { - set_optimize_op (expr, hop + OP_SAFE_C_PC); - set_opt3_con (arg1p, cadr (arg2)); - } - set_unsafely_optimized (expr); - choose_c_function (sc, expr, func, 2); - return (opt_bad); - } +static bool op_safe_do_step(s7_scheme *sc) +{ + const s7_int end = integer(let_dox2_value(sc->curlet)); + const s7_pointer slot = let_dox_slot1(sc->curlet); + const s7_int 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); +} - if (func_is_safe) { - if (fx_count (sc, expr) == 2) - return (check_c_aa (sc, expr, func, hop, let_or_list)); +static bool op_safe_dotimes_step(s7_scheme *sc) +{ + const s7_pointer arg = slot_value(sc->args); + numerator(arg)++; + if (numerator(arg) == loop_end(sc->args)) + { + sc->value = sc->T; + sc->code = cdadr(sc->code); + return(true); } - 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= 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, arg1p, let_or_list); - set_opt3_arglen (arg1p, 2); - } - 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), - let_or_list))) /* 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 (c_function_call (func))); - return (opt_bad); - } - 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, - let_or_list))) /* 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 (c_function_call (func))); - return (opt_bad); - } - set_unsafe_optimize_op (expr, hop + OP_C_AP); - fx_annotate_arg (sc, arg1p, let_or_list); - } - choose_c_function (sc, expr, func, 2); - return (opt_bad); - } - 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)) { - fx_annotate_arg (sc, cddr (expr), let_or_list); - set_unsafe_optimize_op (expr, hop + OP_CL_FA); - check_lambda (sc, arg1, true); /* this changes small_symbol_set */ - /* 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_bad); - } + 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) +{ + const s7_pointer arg = slot_value(sc->args); + numerator(arg)++; + if (numerator(arg) == loop_end(sc->args)) + { + sc->value = sc->T; + sc->code = cdadr(sc->code); + return(true); /* goto DO_END_CLAUSES */ } - return ( - set_any_c_np (sc, func, expr, let_or_list, 2, - hop + OP_ANY_C_NP)); /* OP_C_PP doesn't exist, presumably - OP_SAFE_C_PP was caught above? */ - } + push_stack_direct(sc, OP_SAFE_DOTIMES_STEP_O); + sc->code = opt2_pair(sc->code); + return(false); /* goto EVAL */ +} + +static /* inline */ bool op_dotimes_step_o(s7_scheme *sc) /* called once in eval, mat(10+6), num(7+1) */ +{ + const s7_pointer ctr = let_dox_slot1(sc->curlet); + s7_pointer end = let_dox2_value(sc->curlet); + s7_pointer now = slot_value(ctr); + const s7_pointer code = sc->code; + const s7_pointer 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 + { + slot_set_value(ctr, g_add_x1(sc, with_list_t1(sc, now))); + /* (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 loop_end_ok) +{ + if (loop_end_ok) + set_safe_stepper(sc->args); + else set_safe_stepper(let_dox_slot1(sc->curlet)); + + if (is_null(cdr(code))) + { + s7_pfunc func; + if (no_cell_opt(code)) return_false(sc, code); + sc->do_body_p = car(code); + func = s7_optimize_nv(sc, code); + if (!func) + { + set_no_cell_opt(code); + return_false(sc, code); + } + if (loop_end_ok) + { + const s7_int end = loop_end(sc->args); + const s7_pointer stepper = make_mutable_integer(sc, integer(slot_value(sc->args))); + slot_set_value(sc->args, stepper); + if ((func == opt_float_any_nv) || + (func == opt_cell_any_nv)) + { + opt_info *o = sc->opts[0]; + if (func == opt_float_any_nv) + { + s7_double (*fd)(opt_info *o) = q_call(o).fd; + if ((fd == opt_d_id_sf) && /* by far the most common case in clm: (outa i ...) etc */ + (is_slot(q_arg1(o).p)) && + (stepper == slot_value(q_arg1(o).p))) + { /* (do ((i 0 (+ i 1))) ((= i len) (set! *output* #f) v1) (outa i (- (* i incr) 0.5))) */ + opt_info *o1 = sc->opts[1]; + s7_int end8 = end - 8; + s7_d_id_t f0 = q_func(o).d_id_f; + fd = q_call(o1).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 ((q_call(o).fd == opt_d_7pid_ss_ss) && (q_func(o).d_7pid_f == float_vector_set_d_7pid_direct) && + ((q_func1(o).d_7pi_f == float_vector_ref_d_7pi) || (q_func1(o).d_7pi_f == float_vector_ref_d_7pi_direct)) && + (q_arg2(o).p == q_arg4(o).p)) + copy_to_same_type(sc, slot_value(q_arg1(o).p), slot_value(q_arg3(o).p), integer(stepper), end, integer(stepper)); + else + if ((q_call(o).fd == opt_d_7pid_ssc) && + (q_func(o).d_7pid_f == float_vector_set_d_7pid_direct) && + (stepper == slot_value(q_arg2(o).p))) + s7_fill(sc, set_plist_4(sc, slot_value(q_arg1(o).p), wrap_real(sc, q_arg3(o).x), stepper, wrap_integer(sc, end))); /* wrapped 16-Nov-23 */ + else + { /* (do ((i 0 (+ i 1))) ((= i 2) fv) (float-vector-set! fv (+ i 0) (+ i 1) (* 2.0 3.0))) */ + s7_int end4 = end - 4; + while (integer(stepper) < end4) + LOOP_4(fd(o); integer(stepper)++); + for (; integer(stepper) < end; integer(stepper)++) + fd(o); + }} + else + { + s7_pointer (*fp)(opt_info *o) = q_call(o).fp; + if ((fp == opt_p_pip_ssc) && + (stepper == slot_value(q_arg2(o).p)) && /* i.e. index by do counter */ + ((q_func(o).p_pip_f == string_set_p_pip_direct) || + (q_func(o).p_pip_f == t_vector_set_p_pip_direct) || + (q_func(o).p_pip_f == list_set_p_pip_unchecked))) + s7_fill(sc, set_plist_4(sc, slot_value(q_arg1(o).p), q_arg3(o).p, stepper, wrap_integer(sc, end))); /* wrapped 16-Nov-23 */ + else + if (fp == opt_if_bp) + { /* (do ((i 0 (+ i 1))) ((= i 3) y) (if (= (+ z 1) 2.2) (display (+ z 1)))) */ + for (; integer(stepper) < end; integer(stepper)++) + if (q_func(o).fb(q_arg2(o).o1)) q_p_func1_call(o); + } + else + if (fp == opt_if_nbp_fs) + { /* (do ((i 0 (+ i 1))) ((= i len)) (if (not (= (list-ref lst i) i)) (display "oops"))) */ + for (; integer(stepper) < end; integer(stepper)++) + if (!(q_func4(o).b_pi_f(sc, q_p_func1_call(o), integer(slot_value(q_arg1(o).p))))) q_p_func2_call(o); + } + else + if (fp == opt_unless_p_1) + { /* (do ((i 0 (+ i 1))) ((= i size)) (unless (= (hash-table-ref vct-hash (float-vector i)) i) (display "oops"))) */ + opt_info *o1 = q_when_body(o, 0).o1; + for (; integer(stepper) < end; integer(stepper)++) + if (!(q_when_test_call(o))) q_call(o1).fp(o1); + } + else /* (do ((i 0 (+ i 1))) ((= i size) (vector-ref v 0)) (vector-set! v i 2)) */ + for (; integer(stepper) < end; integer(stepper)++) fp(o); + }} + else + if (func == opt_int_any_nv) + { + opt_info *o = sc->opts[0]; + s7_int (*fi)(opt_info *o) = q_call(o).fi; + if ((fi == opt_i_7pii_ssc) && (stepper == slot_value(q_arg2(o).p)) && (q_func(o).i_7pii_f == int_vector_set_i_7pii_direct)) + s7_fill(sc, set_plist_4(sc, slot_value(q_arg1(o).p), wrap_integer(sc, q_arg3(o).i), stepper, wrap_integer(sc, end))); /* wrapped 16-Nov-23 */ + else + if ((q_func(o).i_7pii_f == int_vector_set_i_7pii_direct) && (q_func1(o).fi == opt_i_pi_ss_ivref) && (q_arg2(o).p == q_func1_arg(o).q_arg2(o1).p)) + copy_to_same_type(sc, slot_value(q_arg1(o).p), slot_value(q_func1_arg(o).q_arg1(o1).p), integer(stepper), end, integer(stepper)); + else /* (do ((i 0 (+ i 1))) ((= i size) (byte-vector-ref v 0)) (byte-vector-set! v i 2)) */ + for (; integer(stepper) < end; integer(stepper)++) + fi(o); + } + else /* (do ((i 0 (+ i 1))) ((= i 1)) (char-numeric? (string-ref #u(0 1) 1))) or (logbit? i -1): kinda nutty */ + for (; integer(stepper) < end; integer(stepper)++) + func(sc); + clear_mutable_integer(stepper); + } + else + { + const s7_pointer step_slot = let_dox_slot1(sc->curlet); + const s7_pointer end_slot = let_dox_slot2(sc->curlet); + s7_int step = integer(slot_value(step_slot)); + const s7_int stop = integer(slot_value(end_slot)); + const s7_pointer step_val = slot_value(step_slot); + if (func == opt_cell_any_nv) + { + opt_info *o = sc->opts[0]; + s7_pointer (*fp)(opt_info *o) = q_call(o).fp; + if (!opt_do_copy(sc, o, step, stop)) + { + if ((step >= 0) && (stop < NUM_SMALL_INTS)) + { + if (fp == opt_when_p_2) + { /* (do ((i 0 (+ i 1))) ((= i len) (list mx loc)) (when (> (abs (vect i)) mx) (set! mx (vect i)) (set! loc i))) */ + for (; step < stop; step++) + { + slot_set_value(step_slot, small_int(step)); + if (q_when_test_call(o)) + { + q_when_p1_call(o); + q_when_p2_call(o); + }}} + else /* (do ((k 0 (+ k 1))) ((= k 10) sum) (do ((i 0 (+ i 1))) ((= i size/10)) (set! sum (+ sum (round (vector-ref v k i)))))) */ + for (; step < stop; step++) + { + slot_set_value(step_slot, small_int(step)); + fp(o); + }} + else /* (do ((i 0 (+ i 1))) ((= i len) (list mx loc)) (when (> (abs (vect i)) mx) (set! mx (vect i)) (set! loc i))) */ + for (; step < stop; step++) + { + slot_set_value(step_slot, make_integer(sc, step)); + fp(o); + }}} + else + if ((step >= 0) && (stop < NUM_SMALL_INTS)) + { /* (do ((i 0 (+ i 1))) ((= i 1) x) (set! x (+ (* x1 (block-ref b1 i)) (* x2 (block-ref b2 j))))) */ + for (; step < stop; step++) + { + slot_set_value(step_slot, small_int(step)); + func(sc); + }} + else + if (func == opt_int_any_nv) + { /* (do ((i 0 (+ i 1))) ((= i size) sum) (set! sum (+ sum (floor (vector-ref v i))))) */ + opt_info *o = sc->opts[0]; + s7_int (*fi)(opt_info *o) = q_call(o).fi; + if ((fi == opt_set_i_i_f) || (fi == opt_set_i_i_fo)) + { + slot_set_value(q_arg1(o).p, make_mutable_integer(sc, integer(slot_value(q_arg1(o).p)))); + fi = (fi == opt_set_i_i_f) ? opt_set_i_i_fm : opt_set_i_i_fom; + } + while (step < stop) + { + fi(o); + step = ++integer(step_val); + } + if ((fi == opt_set_i_i_fm) || (fi == opt_set_i_i_fom)) + clear_mutable_integer(slot_value(q_arg1(o).p)); + } + else + if (func == opt_float_any_nv) + { /* (do ((i 1 (+ i 1))) ((= i 1000)) (set! (v i) (filter f1 0.0))) */ + opt_info *o = sc->opts[0]; + s7_double (*fd)(opt_info *o) = q_call(o).fd; + if (fd == opt_set_d_d_f) + { /* (do ((i 0 (+ i 1))) ((= i 32768)) (set! sum (+ sum (float-vector-ref ndat i)))) */ + slot_set_value(q_arg1(o).p, make_mutable_real(sc, real(slot_value(q_arg1(o).p)))); + fd = opt_set_d_d_fm; + } + while (step < stop) + { + fd(o); + step = ++integer(step_val); + } + if (fd == opt_set_d_d_fm) + clear_mutable_number(slot_value(q_arg1(o).p)); + }} + /* there aren't any other possibilities */ + sc->value = sc->T; + sc->code = cdadr(scc); + sc->do_body_p = NULL; + return_true(sc, code); + } + + { /* not is_null(cdr(code)) i.e. there's more than one thing to do in the body */ + const s7_int body_len = s7_list_length(sc, code); + opt_info *body[32]; + sc->pc = 0; + if (body_len >= 32) return_false(sc, code); + + if (!no_float_opt(code)) + { + s7_pointer p = code; + for (int32_t k = 0; is_pair(p); k++, p = cdr(p)) + { + body[k] = sc->opts[sc->pc]; + if (!float_optimize(sc, p)) + break; + /* if opt_set_d_d_f -> fm mutablizing body[k]-v[1].p? see 83033 but protect against (data i) as below */ + } + if (is_pair(p)) + { + sc->pc = 0; + set_no_float_opt(code); + } + else + { + if (loop_end_ok) + { /* (do ((i start (+ i 1))) ((= i end)) (outa i (* ampa (ina i *reverb*))) (outb i (* ampb (inb i *reverb*)))) */ + const s7_int end = loop_end(sc->args); + const s7_pointer stepper = make_mutable_integer(sc, integer(slot_value(sc->args))); + slot_set_value(sc->args, stepper); + for (; integer(stepper) < end; integer(stepper)++) + for (int32_t i = 0; i < body_len; i++) q_call(body[i]).fd(body[i]); + clear_mutable_integer(stepper); + } + else + { /* (do ((i 0 (+ i 1))) ((= i 5)) (set! (data i) (delay dly1 impulse -0.4)) (set! impulse 0.0)) */ + const s7_pointer step_slot = let_dox_slot1(sc->curlet); + const s7_pointer end_slot = let_dox_slot2(sc->curlet); + const s7_int stop = integer(slot_value(end_slot)); + const s7_pointer step_val = slot_value(step_slot); + for (s7_int step = integer(step_val); step < stop; step = ++integer(step_val)) + for (int32_t i = 0; i < body_len; i++) q_call(body[i]).fd(body[i]); + /* tari[99 ff]: 4 calls here all safe (see d_syntax_ok, need to make the change and the list here dependent on two-sets bit(?) (3.3M calls) */ + /* tall: (3.3M calls) */ + } + sc->value = sc->T; + sc->code = cdadr(scc); + return_true(sc, code); + }} + { + /* not float opt */ + s7_pointer p = code; + sc->pc = 0; + for (int32_t k = 0; 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)) + { + if ((S7_DEBUGGING) && (loop_end_ok) && (!has_loop_end(sc->args))) + fprintf(stderr, "%s[%d]: loop_end_ok but not has_loop_end\n", __func__, __LINE__); + if (loop_end_ok) + { /* (do ((i 0 (+ i 1))) ((= i 1) strs) (copy (vector-ref strs i) (make-string 1)) (copy (vector-ref strs i) (make-string 0))) */ + const s7_int end = loop_end(sc->args); + const s7_pointer stepper = make_mutable_integer(sc, integer(slot_value(sc->args))); + slot_set_value(sc->args, stepper); + if ((body_len & 0x3) == 0) + for (; integer(stepper) < end; integer(stepper)++) + for (int32_t i = 0; i < body_len; ) + LOOP_4(q_call(body[i]).fp(body[i]); i++); + else + if (body_len == 1) + { + opt_info *o1 = body[0]; + for (; integer(stepper) < end; integer(stepper)++) + q_call(o1).fp(o1); + } + else + /* TODO: opt_unless_p_1_nr? */ + for (; integer(stepper) < end; integer(stepper)++) + for (int32_t i = 0; i < body_len; i++) q_call(body[i]).fp(body[i]); + clear_mutable_integer(stepper); + } + else + { /* (do ((k j (+ k 1))) ((= k len2) obj) (set! (obj n) (seq2 k)) (set! n (+ n 1))) */ + const s7_pointer step_slot = let_dox_slot1(sc->curlet); + const s7_pointer end_slot = let_dox_slot2(sc->curlet); + const s7_int stop = integer(slot_value(end_slot)); + for (s7_int step = integer(slot_value(step_slot)); step < stop; step++) + { + slot_set_value(step_slot, make_integer(sc, step)); + for (int32_t i = 0; i < body_len; i++) q_call(body[i]).fp(body[i]); + }} + sc->value = sc->T; + sc->code = cdadr(scc); + return_true(sc, code); + }}} + return_false(sc, code); +} + +static bool do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc) +{ + const s7_pointer let_code = caddr(scc); + s7_pointer let_body, let_vars, ip; + bool let_star; + s7_pointer old_let, stepper; + s7_int body_len, var_len, end; + #define O_SIZE 32 + opt_info *body[O_SIZE], *vars[O_SIZE]; + memclr((void *)body, O_SIZE * sizeof(opt_info *)); /* placate the damned compiler */ + memclr((void *)vars, O_SIZE * sizeof(opt_info *)); + + /* do_let with non-float vars doesn't get many fixable hits */ + if ((!is_pair(cdr(let_code))) || (!is_list(cadr(let_code)))) /* (do ((j 0 (+ j 1))) ((= j 1)) (let name 123)) */ + return(false); + let_body = cddr(let_code); + body_len = s7_list_length(sc, let_body); + if ((body_len <= 0) || (body_len >= 32)) return(false); + 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_let = sc->curlet; + set_curlet(sc, make_let(sc, sc->curlet)); - if (is_closure (func)) { - bool one_form, safe_case; - s7_pointer body; - const int32_t arit= closure_arity_to_int (sc, func); - - if (arit != 2) { - if (is_symbol (closure_pars (func))) - return (optimize_closure_sym (sc, expr, func, hop, 2, let_or_list)); - if ((arit == -1) && - (is_symbol (cdr (closure_pars (func))))) /* (define (f a . b) ...) */ - return (optimize_closure_a_sym (sc, expr, func, hop, 2, let_or_list)); - return (opt_bad); - } - 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, let_or_list); - fx_tree (sc, body, car (closure_pars (func)), - cadr (closure_pars (func)), NULL, false); - set_safe_optimize_op (expr, hop + OP_SAFE_CLOSURE_SS_A); - /* fx_annotate_args(sc, arg1p, let_or_list); */ - set_closure_one_form_fx_arg (func); - return (opt_ok); - } - return (opt_bad); - } - 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_bad); - } + sc->pc = 0; + var_len = 0; + for (s7_pointer 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(false); + 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_let); + return(false); + } + if (let_star) + add_slot_checked(sc, sc->curlet, caar(p), make_mutable_real(sc, 1.5)); } - if ((!arglist_has_rest (sc, closure_pars (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, let_or_list); - 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, arg1p, let_or_list); - set_opt1_lambda_add (expr, func); - set_opt3_arglen (arg1p, 2); - return (opt_ok); - } - fx_annotate_args (sc, arg1p, let_or_list); - set_opt1_lambda_add (expr, func); - set_opt3_arglen (arg1p, 2); - return (opt_bad); - } - - if (is_fxable (sc, arg1)) { - set_unsafely_optimized (expr); - fx_annotate_arg (sc, arg1p, let_or_list); - set_safe_optimize_op ( - expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_AP : OP_CLOSURE_AP)); - set_opt1_lambda_add (expr, func); - set_opt3_arglen (arg1p, 2); /* for op_unknown_np */ - return (opt_bad); - } - - 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))))) { - fx_annotate_arg (sc, cddr (expr), let_or_list); - set_opt2_pair (expr, cdr (arg1)); - set_unsafe_optimize_op (expr, hop + OP_CLOSURE_FA); - check_lambda (sc, arg1, false); - /* 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 -- see s7test intersection case 91492 */ - set_opt1_lambda_add (expr, func); - return (opt_bad); - } - - if (is_fxable (sc, arg2)) { - set_unsafely_optimized (expr); - fx_annotate_arg (sc, cddr (expr), let_or_list); - set_optimize_op ( - expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_PA : OP_CLOSURE_PA)); - set_opt1_lambda_add (expr, func); - set_opt3_arglen (arg1p, 2); /* for op_unknown_np */ - return (opt_bad); - } - - if (is_safe_closure (func)) /* clo* too */ - return (set_any_closure_np (sc, func, expr, let_or_list, 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 (arg1p, 2); /* for op_unknown_np */ - return (opt_bad); - } + if (!let_star) + for (s7_pointer p = let_vars; is_pair(p); p = cdr(p)) + add_slot_checked(sc, sc->curlet, caar(p), make_mutable_real(sc, 1.5)); - if (is_closure_star (func)) { - if (!closure_star_is_aritable ( - sc, func, closure_pars (func), - 1)) /* not 2, cadr(expr) might be keyword or pair->keyword etc */ - return (opt_oops); /* (let* cons () (lambda* (a . b) (cons a b))) so - closure_pars=(), arity=0 ?? */ - if (is_immutable (func)) hop= 1; - if (fx_count (sc, expr) == 2) { - fixup_closure_star_aa (sc, func, expr, hop); - fx_annotate_args (sc, arg1p, let_or_list); - set_opt1_lambda_add (expr, func); - return (opt_bad); - } - } + { + s7_pointer p = let_body; + for (int32_t k = 0; is_pair(p); k++, p = cdr(p)) + { + body[k] = sc->opts[sc->pc]; + if (!float_optimize(sc, p)) + { + set_curlet(sc, old_let); + return(false); + }} + if (!is_null(p)) /* no hits in s7test or snd-test */ + { + set_curlet(sc, old_let); + return(false); + }} + end = loop_end(step_slot); + let_set_slots(sc->curlet, reverse_slots(let_slots(sc->curlet))); + ip = slot_value(step_slot); + + if (body_len == 1) + { + opt_info *o = body[0]; + s7_double (*f2)(opt_info *o) = q_call(o).fd; + if (var_len == 1) + { + opt_info *first = sc->opts[0]; + const s7_pointer xp = t_lookup(sc, caar(let_vars), let_vars); + s7_double (*f1)(opt_info *o) = q_call(first).fd; + set_integer(ip, numerator(stepper)); + set_real(xp, f1(first)); + f2(o); + if ((f2 == opt_fmv) && + (f1 == opt_d_dd_ff_o2) && + (q_func(first).d_dd_f == add_d_dd) && + (slot_symbol(step_slot) == slot_symbol(q_arg2(o).p))) + { + opt_info *o1 = q_arg3(o).o1; /* opt_d_dd_ff_mul1 */ + opt_info *o2 = q_arg4(o).o1; /* opt_d_vd_o1 */ + opt_info *o3 = q_arg5(o).o1; /* opt_d_dd_ff_o3 */ + s7_d_vid_t vf7 = q_func(o).d_vid_f; /* locsig_d_vid */ + s7_d_v_t vf1 = q_func3(first).d_v_f; /* mus_triangle_wave_dv */ + s7_d_v_t vf2 = q_func1(first).d_v_f; /* mus_rand_interp_dv */ + s7_d_v_t vf3 = q_func3(o1).d_v_f; /* mus_env_dv */ + s7_d_v_t vf4 = q_func3(o3).d_v_f; /* mus_env_dv */ + s7_d_vd_t vf5 = q_func(o2).d_vd_f; /* mus_oscil_dvd */ + s7_d_vd_t vf6 = q_func2(o3).d_vd_f; /* mus_polywave_dvd */ + void *obj1 = q_arg1(first).gen; + void *obj2 = q_arg2(first).gen; + void *obj3 = q_arg1(o1).gen; + void *obj4 = q_arg1(o3).gen; + void *obj5 = q_arg1(o).gen; + void *obj6 = q_arg1(o2).gen; + void *obj7 = q_arg2(o3).gen; + for (s7_int k = numerator(stepper) + 1; k < end; k++) + { + s7_double vib = vf1(obj1) + vf2(obj2); + s7_double amp_env = vf3(obj3); + vf7(obj5, k, amp_env * vf5(obj6, vib + (vf4(obj4) * vf6(obj7, vib)))); + }} + else + for (s7_int k = numerator(stepper) + 1; k < end; k++) + { + set_integer(ip, k); + set_real(xp, f1(first)); + f2(o); + }} /* body_len == 1 and var_len == 1 */ + else + { + if (var_len == 2) + { + const s7_pointer s1 = let_slots(sc->curlet); + const s7_pointer s2 = next_slot(s1); + opt_info *v0 = vars[0], *v1 = vars[1]; + for (s7_int k = numerator(stepper); k < end; k++) + { + set_integer(ip, k); + set_real(slot_value(s1), q_call(v0).fd(v0)); + set_real(slot_value(s2), q_call(v1).fd(v1)); + f2(o); + }} /* body_len == 1 and var_len == 2 */ + else + for (s7_int k = numerator(stepper); k < end; k++) + { + s7_pointer slot = let_slots(sc->curlet); + set_integer(ip, k); + for (int32_t n = 0; is_not_slot_end(slot); n++, slot = next_slot(slot)) + set_real(slot_value(slot), q_call(vars[n]).fd(vars[n])); + f2(o); /* q_call(body[0]).fd(body[0]) is possibly slightly faster */ + }}} /* end body_len == 1 */ + else + if ((body_len == 2) && (var_len == 1)) + { + const s7_pointer s1 = let_slots(sc->curlet); + for (s7_int k = numerator(stepper); k < end; k++) + { + set_integer(ip, k); + set_real(slot_value(s1), q_call(vars[0]).fd(vars[0])); + q_call(body[0]).fd(body[0]); + q_call(body[1]).fd(body[1]); + }} + else + for (s7_int k = numerator(stepper); k < end; k++) + { + int32_t i = 0; + set_integer(ip, k); + for (s7_pointer slot = let_slots(sc->curlet); is_not_slot_end(slot); i++, slot = next_slot(slot)) + set_real(slot_value(slot), q_call(vars[i]).fd(vars[i])); + for (int32_t i1 = 0; i1 < body_len; i1++) q_call(body[i1]).fd(body[i1]); + } + set_curlet(sc, old_let); + sc->value = sc->T; + sc->code = cdadr(scc); + return(true); +} + +static bool do_let_or_dotimes(s7_scheme *sc, s7_pointer code, bool loop_end_ok) +{ + const 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)); + return(opt_dotimes(sc, cddr(code), code, loop_end_ok)); +} - if ((is_c_function_star (func)) && (fx_count (sc, expr) == 2) && - (c_function_max_args (func) >= 1) && (!is_symbol_and_keyword (arg2))) { - if ((hop == 0) && ((is_immutable (func)) || - ((!sc->in_with_let) && (is_global (car (expr)))))) - hop= 1; - set_optimized (expr); - set_optimize_op (expr, hop + OP_SAFE_C_STAR_AA); /* k+c? = cc */ - fx_annotate_args (sc, arg1p, let_or_list); - set_opt3_arglen (arg1p, 2); - set_class_and_fn_proc (expr, func); - return (opt_ok); - } +static goto_t op_safe_dotimes(s7_scheme *sc) +{ + const s7_pointer form = sc->code; + s7_pointer init_val; - if ((((is_any_vector (func)) && (vector_rank (func) == 2)) || - (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, arg1p, let_or_list); - set_opt3_arglen (arg1p, 2); - return (opt_ok); - } - return ((is_optimized (expr)) ? opt_ok : opt_bad); -} - -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 let_or_list) { - const s7_pointer arg1p= cdr (expr), 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 { - clear_has_fx (arg1p); - if (symbols == 3) { - set_optimize_op (expr, hop + OP_SAFE_C_SSS); - set_opt1_sym (arg1p, arg2); - set_opt2_sym (arg1p, arg3); - } - else if (symbols == 2) - if (!is_normal_symbol (arg1)) { - set_optimize_op (expr, hop + OP_SAFE_C_CSS); - set_opt1_sym (arg1p, arg2); - set_opt2_sym (arg1p, arg3); - } - else if (!is_normal_symbol (arg3)) { - set_opt2_con (arg1p, arg3); - set_opt1_sym (arg1p, arg2); - set_optimize_op (expr, hop + OP_SAFE_C_SSC); - } - else { - set_opt1_con (arg1p, arg2); - set_opt2_sym (arg1p, arg3); - set_optimize_op (expr, hop + OP_SAFE_C_SCS); - } - else if (is_normal_symbol (arg1)) { - set_opt1_con (arg1p, arg2); - set_opt2_con (arg1p, arg3); - set_optimize_op (expr, hop + OP_SAFE_C_SCC); - } - else if (is_normal_symbol (arg2)) { - set_opt1_sym (arg1p, arg2); - set_opt2_con (arg1p, arg3); - set_opt3_con (arg1p, arg1); - set_optimize_op (expr, hop + OP_SAFE_C_CSC); - } - else { - set_opt1_sym (arg1p, arg3); - set_opt2_con (arg1p, arg2); - set_opt3_con (arg1p, arg1); - set_optimize_op (expr, hop + OP_SAFE_C_CCS); - } - } - choose_c_function (sc, expr, func, 3); - return (opt_ok); - } + sc->code = cdr(sc->code); + init_val = fx_call(sc, cdaar(sc->code)); + if (s7_is_integer(init_val)) + { + const s7_pointer end_expr = caadr(sc->code); + const s7_pointer code = sc->code; + s7_pointer end_val = caddr(end_expr); + if (is_symbol(end_val)) + end_val = lookup_checked(sc, end_val); - /* 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 (arg1p, cadr (arg2)); /* fx_c_scs uses opt1_con */ - clear_has_fx (arg1p); /* (s7test safe_c_func_three_args) this is used - above -- maybe just clear it at the top? */ - set_opt2_sym (arg1p, arg3); - set_optimize_op (expr, hop + OP_SAFE_C_SCS); /* used to be SQS */ - choose_c_function (sc, expr, func, 3); - return (opt_ok); - } - 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 (arg1p, cadr (arg2)); /* opt1_con is T_Exs (unchecked) */ - set_opt2_sym (arg1p, arg3); - set_opt3_sym (arg1p, cadr (arg1)); - choose_c_function (sc, expr, func, 3); - return (opt_ok); - } - 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 (arg1p, arg2); - set_opt2_con (arg1p, arg3); - set_opt3_con (arg1p, cadr (arg1)); - choose_c_function (sc, expr, func, 3); - return (opt_ok); - } - } - } + if (s7_is_integer(end_val)) + { + sc->code = cddr(code); + set_curlet(sc, make_let(sc, sc->curlet)); + sc->args = add_slot_checked(sc, sc->curlet, caaar(code), make_mutable_integer(sc, s7_integer_clamped_if_gmp(sc, init_val))); + set_loop_end(sc->args, s7_integer_clamped_if_gmp(sc, end_val)); + set_has_loop_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, goto 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_clamped_if_gmp(sc, init_val) == s7_integer_clamped_if_gmp(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 (do_let_or_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 */ + { + const s7_int end = s7_integer_clamped_if_gmp(sc, end_val); + const s7_pointer body = cddr(code); + for (s7_pointer stepper = slot_value(sc->args); 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. + */ + const s7_pointer form = sc->code; + s7_pointer end, init_val, end_val, code; - fx_annotate_args (sc, arg1p, let_or_list); - set_opt3_arglen (arg1p, 3); - 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)) { - set_optimize_op (expr, hop + OP_SAFE_C_SSA); - clear_has_fx ( - arg1p); /* has_fx might have been on (see s7test) */ - } - 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); + /* 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; - choose_c_function (sc, expr, func, 3); - return (opt_ok); - } - return (opt_bad); /* 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 let_or_list) { - const s7_pointer arg1p= cdr (expr), arg1= cadr (expr), arg2= caddr (expr), - arg3= cadddr (expr); - if ((quotes > 0) && (direct_memq (sc->quote_symbol, let_or_list))) - return (opt_oops); - if ((!symbol_is_safe (sc, arg1, let_or_list)) || - (!symbol_is_safe (sc, arg2, let_or_list)) || - (!symbol_is_safe (sc, arg3, let_or_list))) { - /* 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, arg1p, let_or_list); - set_opt3_arglen (arg1p, 3); - if (is_c_function (func)) { - if (is_safe_procedure (func)) { - set_safe_optimize_op (expr, hop + OP_SAFE_C_AAA); - set_opt3_pair (arg1p, 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_class_and_fn_proc (expr, func); - return (opt_ok); - } - if ((is_closure (func)) && (closure_arity_to_int (sc, func) == 3) && - (!arglist_has_rest (sc, closure_pars (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_bad); - } - 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_bad); - } /* 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_is_aritable (func, 3))) { - if (hop == 0) hop= hop_if_constant (sc, car (expr)); - if ((is_safe_procedure (func)) || - ((is_maybe_safe (func)) && (unsafe_is_safe (sc, arg3, let_or_list)))) { - if (optimize_safe_c_func_three_args (sc, expr, func, hop, pairs, symbols, - quotes, let_or_list) == opt_ok) - return (opt_ok); - if ((is_normal_symbol (arg1)) && (is_normal_symbol (arg2))) { - set_opt3_pair (expr, arg3); - set_unsafe_optimize_op ( - expr, hop + OP_SAFE_C_SSP); /* vector-set! in tbig apparently */ - choose_c_function (sc, expr, func, 3); - return (opt_bad); - } - return ( - set_any_c_np (sc, func, expr, let_or_list, 3, hop + OP_SAFE_C_3P)); - } - /* func is not safe */ - if (fx_count (sc, expr) == 3) { - set_optimized (expr); - fx_annotate_args (sc, arg1p, let_or_list); - set_opt3_arglen (arg1p, 3); - if (is_semisafe (func)) - set_optimize_op (expr, hop + (((is_normal_symbol (arg1)) && - (is_normal_symbol (arg3))) - ? OP_CL_SAS - : OP_CL_NA)); - else if ((fx_proc (arg1p) == fx_c) && (fx_proc (cddr (expr)) == fx_c) && - (fx_proc (cdddr (expr)) == fx_c)) - set_optimize_op (expr, hop + OP_C_NC); - else set_optimize_op (expr, hop + OP_C_NA); - choose_c_function (sc, expr, func, 3); - set_unsafe (expr); - return (opt_bad); - } - - /* (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) && (is_quote (sc, car (arg1))))) { - const 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)) || - (is_quote (sc, car (error_result))) || /* (lambda args 'a) */ - ((car (error_result) == sc->car_symbol) && - (is_pair ( - cdr (error_result))) && /* (lambda (type info) (car)) */ - (cadr (error_result) == - cadr (error_lambda))))) /* (lambda args (car args) -> - error-type */ - { - set_optimize_op ( - expr, OP_C_CATCH_ALL); /* catch_all* = #t tag, error handling - can skip to the simple lambda body */ - /* set_class_and_fn_proc(expr, func); */ - - if (is_pair (error_result)) - error_result= (is_quote (sc, car (error_result))) - ? cadr (error_result) - : sc->unused; - else if (is_symbol (error_result)) error_result= sc->unused; - /* clear_has_fn(expr); */ /* ??? this cancels the set_c_function - call?? */ - set_opt2_con (expr, - error_result); /* for op_c_catch_all|_a -> stack */ - - set_opt1_pair (arg1p, cddr (body_lambda)); - if (is_null (cdddr (body_lambda))) { - if (is_fxable (sc, caddr (body_lambda))) { - set_optimize_op (expr, 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 (arg1p, caddr (body_lambda)); - set_optimize_op (expr, OP_C_CATCH_ALL_O); - /* fn got no hits */ - } - } - } - else { - set_optimize_op (expr, OP_C_CATCH); /* mainly c_catch_p, but this is - not a common case */ - choose_c_function (sc, expr, func, 3); - } - return (opt_bad); - } - } + 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)) */ + set_curlet(sc, make_let(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 ((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_symbol (caadr (arg1))) && - (!is_possibly_constant ( - caadr (arg1))) && /* parameter name not trouble */ - (is_symbol (cadadr (arg1))) && - (!is_possibly_constant (cadadr (arg1)))) { - fx_annotate_args (sc, cddr (expr), let_or_list); - check_lambda (sc, arg1, true); /* this changes small_symbol_set */ - 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_bad); - } + if ((s7_integer_clamped_if_gmp(sc, init_val) == s7_integer_clamped_if_gmp(sc, end_val)) || + ((s7_integer_clamped_if_gmp(sc, init_val) > s7_integer_clamped_if_gmp(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_safe_procedure (func)) || - ((is_semisafe (func)) && (((car (expr) != sc->assoc_symbol) && - (car (expr) != sc->member_symbol)) || - (unsafe_is_safe (sc, arg3, let_or_list))))) - return ( - set_any_c_np (sc, func, expr, let_or_list, 3, hop + OP_SAFE_C_3P)); - return (set_any_c_np (sc, func, expr, let_or_list, 3, hop + OP_ANY_C_NP)); + if (is_symbol(end)) + let_set_dox_slot2(sc->curlet, s7_t_slot(sc, end)); + 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 */ + { + const s7_pointer step_slot = let_dox_slot1(sc->curlet); + slot_set_value(step_slot, make_mutable_integer(sc, integer(slot_value(step_slot)))); + set_loop_end(step_slot, s7_integer_clamped_if_gmp(sc, end_val)); + set_has_loop_end(step_slot); } - /* not c func */ - if (is_closure (func)) { - const int32_t arit= closure_arity_to_int (sc, func); - if (arit != 3) { - if (is_symbol (closure_pars (func))) - return (optimize_closure_sym (sc, expr, func, hop, 3, let_or_list)); - return (opt_bad); - } - if (is_immutable (func)) hop= 1; - - if (symbols == 3) { - const s7_pointer body = closure_body (func); - const bool one_form= is_null (cdr (body)); - set_opt1_lambda_add (expr, func); - set_opt3_arglen (arg1p, 3); - - if (is_safe_closure (func)) { - if ((one_form) && (is_fxable (sc, car (body)))) { - set_opt2_sym (expr, arg2); - set_opt3_sym (expr, arg3); - fx_annotate_arg (sc, body, let_or_list); - fx_tree (sc, body, car (closure_pars (func)), - cadr (closure_pars (func)), caddr (closure_pars (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_ok); - } - set_unsafe_optimize_op ( - expr, hop + ((one_form) ? OP_CLOSURE_3S_O : OP_CLOSURE_3S)); - return (opt_bad); - } - - 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 - set_optimize_op ( - expr, - hop + ((is_normal_symbol (arg2)) ? OP_CLOSURE_ASA : OP_CLOSURE_3A)); - set_unsafely_optimized (expr); - fx_annotate_args (sc, arg1p, let_or_list); - if (is_fx_treeable (arg1p)) - fx_tree (sc, closure_body (func), car (closure_pars (func)), - cadr (closure_pars (func)), caddr (closure_pars (func)), - false); - set_opt1_lambda_add (expr, func); - set_opt3_arglen (arg1p, 3); - return (opt_bad); - } - return (set_any_closure_np (sc, func, expr, let_or_list, 3, - hop + OP_ANY_CLOSURE_3P)); - } + 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)) + { + sc->temp7 = sc->unused; + return(goto_safe_do_end_clauses); + } + set_curlet(sc, old_let); /* apparently s7_optimize can step on sc->curlet? */ + sc->temp7 = sc->unused; + } - 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_bad); - 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); + if (is_null(cdddr(sc->code))) /* (do ((k 0 (+ k 1))) ((= k 2)) (set! sum (+ sum 1))) */ + { + const 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)))) /* so we're (set! symbol (fxable-expr...)) */ + { + const s7_pointer step_slot = let_dox_slot1(sc->curlet); + if (slot_symbol(step_slot) != cadr(body)) /* we're not setting the stepper */ + { + const s7_int endi = integer(let_dox2_value(sc->curlet)); + const s7_pointer fx_p = cddr(body); + const s7_pointer val_slot = s7_t_slot(sc, cadr(body)); + s7_int step = integer(slot_value(step_slot)); + const s7_pointer step_val = slot_value(step_slot); + + clear_mutable_integer(step_val); + do { + slot_set_value(val_slot, fx_call(sc, fx_p)); + slot_set_value(step_slot, make_integer(sc, step = integer(slot_value(step_slot)) + 1)); + } while (step != endi); /* geq not needed here -- we're leq endi and stepping by +1 all ints */ + + sc->value = sc->T; + sc->code = cdadr(code); + return(goto_safe_do_end_clauses); + }}} + clear_mutable_number(slot_value(let_dox_slot1(sc->curlet))); + 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) +{ + const s7_pointer code = cdr(sc->code); + s7_pointer end_val, slot, old_let; + const s7_pointer end = opt1_any(code); /* caddr(opt2_pair(code)) */ + /* (do ... (set! args ...)) -- one line, syntactic */ + const s7_pointer init_val = fx_call(sc, cdaar(code)); + sc->value = init_val; + set_opt2_pair(code, caadr(code)); + if (is_symbol(end)) + { + slot = s7_t_slot(sc, end); + end_val = slot_value(slot); + } + else + { + slot = make_slot(sc, make_symbol(sc, "___end___", 9), 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_let = sc->curlet; + set_curlet(sc, make_let(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)) + { + const s7_pointer old_args = sc->args; + const s7_pointer 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_loop_end(sc->args, integer(let_dox2_value(sc->curlet))); + set_has_loop_end(sc->args); /* dotimes step is by 1 */ + sc->code = cdr(sc->code); + if (do_let_or_dotimes(sc, code, false)) + return(goto_do_end_clauses); /* not safe_do here */ + slot_set_value(sc->args, old_init); + set_curlet(sc, old_let); + 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 bool op_do_init_1(s7_scheme *sc) +{ + /* initially from do_unchecked, sc->args=(), sc->value=sc->code, sc->code=vars */ + 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) */ + 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 - set_unsafe_optimize_op ( - expr, hop + ((is_safe_closure (func) ? OP_SAFE_CLOSURE_STAR_NA - : OP_CLOSURE_STAR_NA))); - fx_annotate_args (sc, arg1p, let_or_list); - set_opt1_lambda_add (expr, func); - set_opt3_arglen (arg1p, 3); - return (opt_bad); + { + 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(true); /* goto EVAL */ + } + sc->value = (is_symbol(init)) ? lookup_checked(sc, init) : init; + } + sc->code = cdr(sc->code); } - } - - if ((is_c_function_star (func)) && (fx_count (sc, expr) == 3) && - (c_function_max_args (func) >= 2)) { - set_safe_optimize_op (expr, hop + OP_SAFE_C_STAR_NA); - fx_annotate_args (sc, arg1p, let_or_list); - set_opt3_arglen (arg1p, 3); - set_class_and_fn_proc (expr, func); - return (opt_ok); - } - /* implicit_vector_3a doesn't happen */ + /* 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 */ + sc->args = cdr(sc->args); /* init values */ + set_curlet(sc, make_let(sc, T_Let(sc->curlet))); + + /* run through sc->code and sc->args adding '( caar(car(code)) . car(args) ) to sc->curlet */ + sc->value = sc->nil; + for (s7_pointer vars = car(sc->code), inits = sc->args; is_not_null(inits); vars = cdr(vars), inits = cdr(inits)) + { + const s7_pointer slot = add_slot_unchecked_with_id(sc, sc->curlet, caar(vars), car_unchecked(inits)); + if (is_pair(cddar(vars))) /* else no incr expr, so ignore it henceforth */ + { + slot_set_expression(slot, cddar(vars)); + sc->value = cons_unchecked(sc, slot, sc->value); + }} + sc->args = cons(sc, sc->value = proper_list_reverse_in_place(sc, sc->value), cadr(sc->code)); + sc->code = cddr(sc->code); + return(false); /* fall through */ +} - if (bad_pairs > quotes) return (opt_bad); - return ((is_optimized (expr)) ? opt_ok : opt_bad); +static bool op_do_init(s7_scheme *sc) /* looping through inits via eval */ +{ + if (is_multiple_value(sc->value)) /* (do ((i (values 1 2)))...) */ + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "do: variable initial value can't be ~S", 38), + set_ulist_1(sc, sc->values_symbol, sc->value))); + return(!op_do_init_1(sc)); } -static bool -symbols_are_safe (s7_scheme* sc, s7_pointer args, s7_pointer let_or_list) { - for (s7_pointer p= args; is_pair (p); p= cdr (p)) { - s7_pointer arg= car (p); - if ((is_normal_symbol (arg)) && (!symbol_is_in_big_symbol_set (sc, arg)) && - (!arg_findable (sc, arg, let_or_list))) - 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 let_or_list) { - const s7_pointer arg1p= cdr (expr); - if (quotes > 0) { - if (direct_memq (sc->quote_symbol, let_or_list)) 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_is_aritable (func, args))) { - if (hop == 0) hop= hop_if_constant (sc, car (expr)); - 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_ok); - } - if (symbols == args) { - if (symbols_are_safe (sc, arg1p, let_or_list)) - 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, arg1p, let_or_list); - } - set_opt3_arglen (arg1p, args); - choose_c_function (sc, expr, func, args); - return (opt_ok); - } - } +static void op_do_unchecked(s7_scheme *sc) +{ + gc_protect_via_stack(sc, sc->code); + sc->code = cdr(sc->code); +} - 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, arg1p, let_or_list); - set_opt3_arglen (arg1p, args); - choose_c_function (sc, expr, func, args); - - for (p= arg1p; (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))) || (!is_quote (sc, caar (p))))) - break; - } - if (is_null (p)) { - set_optimize_op (expr, hop + OP_SAFE_C_ALL_CA); - for (p= arg1p; is_pair (p); p= cddr (p)) { - clear_has_fx (p); - set_opt2_con (p, (is_pair (car (p))) ? cadar (p) : car (p)); - } - } - return (opt_ok); - } - return ( - set_any_c_np (sc, func, expr, let_or_list, args, hop + OP_ANY_C_NP)); - } - /* c_func is not safe */ - if (fx_count (sc, expr) == - args) /* trigger_size doesn't matter for unsafe funcs */ - { - fx_annotate_args (sc, arg1p, let_or_list); - set_opt3_arglen (arg1p, args); - set_unsafe_optimize_op ( - expr, hop + ((is_semisafe (func)) ? OP_CL_NA : OP_C_NA)); - choose_c_function (sc, expr, func, args); - return (opt_bad); - } - return (set_any_c_np (sc, func, expr, let_or_list, args, - hop + OP_ANY_C_NP)); /* was num_args=3! 2-Sep-20 */ - } - { - const bool func_is_closure= is_closure (func); - if (func_is_closure) { - const int32_t arit= closure_arity_to_int (sc, func); - if (arit != args) { - if (is_symbol (closure_pars (func))) - return ( - optimize_closure_sym (sc, expr, func, hop, args, let_or_list)); - return (opt_bad); - } - if (is_immutable (func)) hop= 1; - - if (fx_count (sc, expr) == args) { - const 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, arg1p, let_or_list); - set_opt3_arglen (arg1p, args); - set_opt1_lambda_add (expr, func); - - if ((symbols == args) && (symbols_are_safe (sc, arg1p, let_or_list))) { - if (safe_case) set_optimize_op (expr, hop + OP_SAFE_CLOSURE_NS); - else - set_optimize_op ( - expr, - hop + ((args == 4) - ? ((is_null (cdr (closure_body (func)))) - ? OP_CLOSURE_4S_O - : OP_CLOSURE_4S) - : ((args == 5) ? OP_CLOSURE_5S : OP_CLOSURE_NS))); - } - return (opt_bad); - } - if (args == 4) - return (set_any_closure_np (sc, func, expr, let_or_list, 4, - hop + OP_ANY_CLOSURE_4P)); - return (set_any_closure_np (sc, func, expr, let_or_list, 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_bad); - - if ((is_c_function_star (func)) && (fx_count (sc, expr) == args) && - (c_function_max_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, arg1p, let_or_list); - set_opt3_arglen (arg1p, args); - set_class_and_fn_proc (expr, func); - return (opt_ok); - } - 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, arg1p, let_or_list); - set_opt3_arglen (arg1p, args); - set_opt1_lambda_add (expr, func); - return (opt_bad); +static bool do_unchecked(s7_scheme *sc) +{ + if (is_null(car(sc->code))) /* (do () ...) -- (let ((i 0)) (do () ((= i 1)) (set! i 1))) */ + { + set_curlet(sc, make_let(sc, sc->curlet)); + sc->args = cons_unchecked(sc, sc->nil, cadr(sc->code)); + sc->code = cddr(sc->code); + return(false); } - } - return ((is_optimized (expr)) ? opt_ok : opt_bad); + /* 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)); } -static bool -vars_syntax_ok (s7_pointer vars) { - for (s7_pointer p= vars; is_pair (p); p= cdr (p)) { - const s7_pointer var= car (p); - if ((!is_pair (var)) || (!is_normal_symbol (car (var))) || - (!is_pair (cdr (var))) || (is_pair (cddr (var)))) - return (false); - } - return (true); -} - -static opt_t optimize_expression (s7_scheme* sc, s7_pointer expr, int32_t hop, - s7_pointer let_or_list, bool export_ok); - -static bool -vars_opt_ok (s7_scheme* sc, s7_pointer vars, int32_t hop, - s7_pointer let_or_list) { - for (s7_pointer p= vars; is_pair (p); p= cdr (p)) { - const s7_pointer init= cadar (p); - const s7_pointer var = caar (p); /* (define (f) (let ((+ -)) (with-let - (curlet) (#_integer? (+))))) (f) */ - if ((initial_value_is_defined ( - sc, - var)) && /* is_normal_symbol is checked above in vars_syntax_ok */ - (is_slot (global_slot (var))) && - (is_c_function (global_value ( - var)))) { /* this is ridiculous. vars_opt_ok needs to be smarter! */ - return (false); - } - if ((is_pair (init)) && (!is_checked (init)) && - (optimize_expression (sc, init, hop, let_or_list, false) == opt_oops)) - return (false); - } - return (true); +static bool op_do_end(s7_scheme *sc) +{ + 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 void -cleanup_big_symbol_set (s7_scheme* sc, s7_pointer orig_e, s7_pointer var_list) { - for (s7_pointer p= var_list; ((is_pair (p)) && (p != orig_e)); p= cdr (p)) { - s7_pointer sym= car (p); - if (is_symbol (sym)) { - if (symbol_shadows (sym) > 0) symbol_shadows (sym)--; - else set_big_symbol_tag (sym, 0); - } - } +static goto_t op_do_end_false(s7_scheme *sc) +{ + 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 opt_t -optimize_syntax (s7_scheme* sc, s7_pointer expr, s7_pointer func, int32_t hop, - s7_pointer let_or_list, bool export_ok) { - const opcode_t op = syntax_opcode (func); - s7_pointer body = cdr (expr), vars; - const s7_pointer init_let_or_list= let_or_list; - bool body_export_ok = true; - if (SHOW_EVAL_OPS) - fprintf (stderr, - " %s[%d]: expr: %s, func: %s, let_or_list: %s, op: %s, hop: %d, " - "export_ok: %d\n", - __func__, __LINE__, display_truncated (expr), display (func), - display (let_or_list), op_names[op], hop, export_ok); - sc->w= let_or_list; - switch (op) { - case OP_QUOTE: - case OP_MACROEXPAND: - if (is_proper_list_1 (sc, body)) { - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - return (opt_bad); - } - return (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) */ - { - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - return (opt_bad); - } - vars= caddr (expr); - if (!is_list (vars)) return (opt_oops); - body= cdddr (expr); +static goto_t op_do_end_true(s7_scheme *sc) +{ + /* 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) */ + 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); } - else { - vars= cadr (expr); - body= cddr (expr); - if (is_null (vars)) - let_or_list= - cons (sc, sc->nil, let_or_list); /* () in let_or_list = empty let */ - else if (!is_pair (vars)) return (opt_oops); + /* 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_pair (body)) return (opt_oops); + 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 (!vars_syntax_ok (vars)) return (opt_oops); - if ((op == OP_LETREC) || (op == OP_LETREC_STAR)) { - let_or_list= collect_variables (sc, vars, let_or_list); - if (!vars_opt_ok (sc, vars, hop, let_or_list)) return (opt_oops); - } - else if (op == OP_LET) { - if (!vars_opt_ok (sc, vars, hop, let_or_list)) return (opt_oops); - let_or_list= collect_variables (sc, vars, let_or_list); +/* -------------------------------- apply functions -------------------------------- */ +static inline s7_pointer apply_c_function(s7_scheme *sc, s7_pointer func, s7_pointer args) /* -------- C-based function -------- */ +{ + const s7_int len = proper_list_length(args); + if (len < c_function_min_args(func)) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_4(sc, wrap_string(sc, "~A: not enough arguments: (~A~{~^ ~S~})", 39), func, func, args)); + if (c_function_max_args(func) < len) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_4(sc, wrap_string(sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), func, func, args)); + return(c_function_call(func)(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 s7_pointer apply_c_function_unopt(s7_scheme *sc, s7_pointer func, s7_pointer args) /* an experiment -- callgrind says this saves time */ +{ + const s7_int len = proper_list_length(args); + if (len < c_function_min_args(func)) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_4(sc, wrap_string(sc, "~A: not enough arguments: (~A~{~^ ~S~})", 39), func, func, args)); + if (c_function_max_args(func) < len) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_4(sc, wrap_string(sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), func, func, args)); + return(c_function_call(func)(sc, args)); +} + +static void apply_c_rst_no_req_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 -------- */ +{ + check_c_macro_args(sc, 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) + syntax_error_nr(sc, "attempt to evaluate a circular list: ~S", 39, sc->args); + if ((sc->safety > no_safety) && (tree_is_cyclic(sc, sc->args))) + error_nr(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)) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_4(sc, wrap_string(sc, "~A: not enough arguments: (~A~{~^ ~S~})", 39), sc->code, sc->code, sc->args)); + if (syntax_max_args(sc->code) < len) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_4(sc, wrap_string(sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), sc->code, sc->code, sc->args)); + sc->cur_op = 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); + set_current_code(sc, sc->code); + 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))) */ + { + if (vector_length(sc->code) == 0) /* (#()) */ + error_nr(sc, make_symbol(sc, "inapplicable-vector", 19), + set_elist_2(sc, wrap_string(sc, "(~S) can't be treated as an implicit vector application", 55), sc->code)); + wrong_number_of_arguments_error_nr(sc, "implicit vector-ref needs an index argument: (~A)", 49, sc->code); + } + if ((is_null(cdr(sc->args))) && + (s7_is_integer(car(sc->args))) && + (vector_rank(sc->code) == 1)) + { + const s7_int index = s7_integer_clamped_if_gmp(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_error_nr(sc, sc->vector_ref_symbol, int_two, car(sc->args), (index < 0) ? it_is_negative_string : it_is_too_large_string); } - else - for (s7_pointer 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, let_or_list, false) == - opt_oops)) - return (opt_oops); - let_or_list= cons (sc, add_symbol_to_big_symbol_set (sc, car (var)), - let_or_list); - sc->w = let_or_list; - } - if (is_symbol (cadr (expr))) { - let_or_list= cons (sc, add_symbol_to_big_symbol_set (sc, cadr (expr)), - let_or_list); - sc->w = let_or_list; - } - break; - - case OP_LET_TEMPORARILY: - vars= cadr (expr); - if (!is_list (vars)) return (opt_oops); - body= cddr (expr); - for (s7_pointer 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, let_or_list, false) == - opt_oops)) - return (opt_oops); - } - /* let_or_list = cons(sc, sc->nil, let_or_list); */ /* !? 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)) let_or_list= cons (sc, sc->nil, let_or_list); - else if (!is_pair (vars)) return (opt_oops); - body= cddr (expr); - - for (s7_pointer p= vars; is_pair (p); p= cdr (p)) { - const 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, let_or_list, false) == - opt_oops)) /* the init field -- locals are not defined yet */ - return (opt_oops); - } - let_or_list= collect_variables (sc, vars, let_or_list); - for (s7_pointer p= vars; is_pair (p); p= cdr (p)) { - const s7_pointer var= cddar (p); - if ((is_pair (var)) && (is_pair (car (var))) && - (!is_checked (car (var))) && - (optimize_expression (sc, car (var), hop, let_or_list, 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: - let_or_list= cons (sc, sc->nil, let_or_list); - break; - - case OP_DEFINE_BACRO: - case OP_DEFINE_BACRO_STAR: - case OP_BACRO: - case OP_BACRO_STAR: - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - return (opt_bad); - - 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 (let_or_list), the added name is - * inserted into let_or_list 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 "let_or_list", but it needs to be - * marked for find_uncomplicated_symbol in a way that can be distinguished - * from members of "let_or_list". 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 define et al here can be #_define, not the symbol 'define - */ - vars= cadr (expr); - body= cddr (expr); - if (is_pair (vars)) { - if ((export_ok) && (is_symbol (car (vars)))) { - add_symbol_to_big_symbol_set (sc, car (vars)); - if ((is_pair (let_or_list)) && (car (let_or_list) != sc->if_keyword)) - set_cdr (let_or_list, - cons (sc, car (vars), cdr (let_or_list))); /* export it */ - else let_or_list= cons (sc, car (vars), let_or_list); - } - let_or_list = collect_parameters (sc, cdr (vars), let_or_list); - body_export_ok= export_ok; + else sc->value = s7i_vector_ref_1(sc, sc->code, sc->args); +} + +static void apply_string(s7_scheme *sc) /* -------- string as applicable object -------- */ +{ + if (!is_pair(sc->args)) + { + if (string_length(sc->code) == 0) /* ("") */ + error_nr(sc, make_symbol(sc, "inapplicable-string", 19), + set_elist_2(sc, wrap_string(sc, "(~S) can't be treated as an implicit string application", 55), sc->code)); + error_nr(sc, sc->wrong_number_of_args_symbol, /* (a string") */ + set_elist_3(sc, wrap_string(sc, "impicit string-ref needs an index argument: (~S~{~^ ~S~})", 57), sc->code, sc->args)); } - else /* vars must be a symbol */ + if (!is_null(cdr(sc->args))) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, wrap_string(sc, "string ref: too many indices: (~S~{~^ ~S~})", 43), sc->code, sc->args)); + + if (s7_is_integer(car(sc->args))) { - if (!is_symbol (vars)) return (opt_oops); /* (define 1 2) */ + const s7_int index = s7_integer_clamped_if_gmp(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)); +} - /* 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. - */ - if (initial_value_is_defined (sc, vars)) { - if ((SHOW_EVAL_OPS) && (!is_maybe_shadowed (vars))) - fprintf (stderr, " %s set maybe shadowed\n", display (vars)); - set_is_maybe_shadowed (vars); - } - sc->temp7= let_or_list; - for (s7_pointer 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, let_or_list, false) == - opt_oops)) /* "body" here is not body in terms of export_ok */ - { - sc->temp7= sc->unused; - return (opt_oops); - } - sc->temp7= sc->unused; - if (export_ok) { - if ((is_pair (let_or_list)) && (car (let_or_list) != sc->if_keyword)) - set_cdr (let_or_list, - cons (sc, vars, cdr (let_or_list))); /* export it */ - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - } - return (opt_bad); - } - break; - - case OP_LAMBDA: - case OP_LAMBDA_STAR: - case OP_MACRO: - case OP_MACRO_STAR: - vars= cadr (expr); - if (is_null (vars)) let_or_list= cons (sc, sc->nil, let_or_list); - else if ((!is_pair (vars)) && (!is_symbol (vars))) return (opt_oops); - let_or_list= collect_parameters (sc, vars, let_or_list); - 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)))) { - const bool old_in_with_let= sc->in_with_let; - set_checked (cadr (expr)); - if (caadr (expr) == sc->with_let_symbol) sc->in_with_let= true; - for (s7_pointer lp= cdadr (expr); is_pair (lp); lp= cdr (lp)) - if ((is_pair (car (lp))) && (!is_checked (car (lp))) && - (optimize_expression (sc, car (lp), hop, let_or_list, - body_export_ok) == opt_oops)) { - sc->in_with_let= old_in_with_let; - return (opt_oops); - } - sc->in_with_let= old_in_with_let; +static bool apply_pair(s7_scheme *sc) /* -------- list as applicable object -------- */ +{ + if (is_multiple_value(sc->code)) /* ((values + 2 3) 4) */ + { + /* car of values can be anything, so conjure up a new expression, and apply again */ + sc->args = pair_append(sc, cdr(sc->code), T_Lst(sc->args)); /* can't use pair_append_in_place here */ + sc->code = car(sc->code); + return(false); } - if ((is_pair (caddr (expr))) && (!is_checked (caddr (expr))) && - (optimize_expression (sc, caddr (expr), hop, let_or_list, - body_export_ok) == opt_oops)) - return (opt_oops); + if (is_null(sc->args)) + wrong_number_of_arguments_error_nr(sc, "implicit list-ref needs an index argument: (~S)", 47, sc->code); + sc->value = list_ref_1(sc, sc->code, car(sc->args)); /* (L 1) */ + if (!is_null(cdr(sc->args))) + sc->value = implicit_index_checked(sc, sc->code, sc->value, sc->args); + return(true); +} - if ((is_pair (cadr (expr))) && (caadr (expr) == sc->starlet_symbol)) { - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - return (opt_ok); - } - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - return (opt_bad); +static void apply_hash_table(s7_scheme *sc) /* -------- hash-table as applicable object -------- */ +{ + if (is_null(sc->args)) + wrong_number_of_arguments_error_nr(sc, "implicit hash-table-ref needs a key to lookup: (~S)", 51, sc->code); + sc->value = s7_hash_table_ref(sc, sc->code, car(sc->args)); + if (!is_null(cdr(sc->args))) + sc->value = implicit_index_checked(sc, sc->code, sc->value, sc->args); +} - 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. - */ +static void apply_let(s7_scheme *sc) /* -------- environment as applicable object -------- */ +{ + if (is_null(sc->args)) + wrong_number_of_arguments_error_nr(sc, "implicit let-ref needs a symbol to lookup: (~S)", 47, sc->code); + sc->value = let_ref(sc, sc->code, car(sc->args)); + if (is_pair(cdr(sc->args))) + sc->value = implicit_index_checked(sc, sc->code, sc->value, 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)) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, wrap_string(sc, "iterator takes no arguments: (~A~{~^ ~S~})", 42), sc->code, sc->args)); + sc->value = s7_iterate(sc, sc->code); +} + +static Inline void inline_apply_lambda(s7_scheme *sc) /* -------- normal function (lambda), or macro --------, called once in eval */ +{ /* load up the current args into the ((args) (lambda)) layout [via the current environment] */ + s7_pointer pars, args, last_slot = slot_end; + const s7_pointer let = sc->curlet; + const s7_uint id = let_id(sc->curlet); + + for (pars = closure_pars(sc->code), args = T_Lst(sc->args); is_pair(pars); pars = cdr(pars), args = cdr(args)) /* closure_pars can be a symbol, for example */ { - const bool old_with_let= sc->in_with_let; - sc->temp9 = let_or_list; - clear_big_symbol_set (sc); - 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)); - /* not rootlet here: (let ((i 0)) (_rd3_ (with-let (rootlet) ((null? i) - * i)))) */ - for (s7_pointer 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; - sc->temp9 = sc->unused; - return (opt_oops); - } - sc->in_with_let= old_with_let; - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - sc->temp9= sc->unused; - return (opt_bad); - } - - case OP_CASE: - if ((is_pair (cadr (expr))) && (!is_checked (cadr (expr))) && - (optimize_expression (sc, cadr (expr), hop, let_or_list, false) == - opt_oops)) - return (opt_oops); - for (s7_pointer p= cddr (expr); is_pair (p); p= cdr (p)) - if ((is_pair (car (p))) && (is_pair (cdar (p)))) - for (s7_pointer rst= cdar (p); is_pair (rst); rst= cdr (rst)) - if ((is_pair (car (rst))) && (!is_checked (car (rst))) && - (optimize_expression (sc, car (rst), hop, let_or_list, false) == - opt_oops)) - return (opt_oops); - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - return (opt_bad); - - case OP_COND: /* split opt is necessary: (cond (lambda (x) ...)) */ - for (s7_pointer p= cdr (expr); is_pair (p); p= cdr (p)) - if (is_pair (car (p))) { - const s7_pointer test= caar (p); - let_or_list= - cons (sc, sc->if_keyword, - let_or_list); /* 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, let_or_list, false) == - opt_oops)) - return (opt_oops); - for (s7_pointer rst= cdar (p); is_pair (rst); rst= cdr (rst)) - if ((is_pair (car (rst))) && (!is_checked (car (rst))) && - (optimize_expression (sc, car (rst), hop, let_or_list, false) == - opt_oops)) - return (opt_oops); - } + const s7_pointer sym = car(pars); + s7_pointer slot; + if (is_null(args)) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_5(sc, wrap_string(sc, "~S: not enough arguments: ((~S ~S ...)~{~^ ~S~})", 48), + closure_name(sc, sc->code), + (is_closure(sc->code)) ? sc->lambda_symbol : ((is_bacro(sc->code)) ? sc->bacro_symbol : sc->macro_symbol), + closure_pars(sc->code), sc->args)); + slot = make_slot(sc, sym, T_Ext(car_unchecked(args))); + symbol_set_local_slot(sym, id, slot); + if (is_not_slot_end(last_slot)) + slot_set_next(last_slot, slot); + else let_set_slots(let, slot); + last_slot = slot; + slot_set_next(slot, slot_end); + } + if (is_null(pars)) { - s7_pointer p; - 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)) { - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - return (opt_bad); - } - set_safe_optimize_op (expr, OP_COND_NA_NA); - } - for (s7_pointer p= cdr (expr); is_pair (p); p= cdr (p)) { - set_fx_direct (car (p), - fx_choose (sc, car (p), let_or_list, pair_symbol_is_safe)); - for (s7_pointer q= cdar (p); is_pair (q); q= cdr (q)) - set_fx_direct (q, fx_choose (sc, q, let_or_list, pair_symbol_is_safe)); - } - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - return (opt_ok); - - 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: - let_or_list= cons (sc, sc->if_keyword, let_or_list); - break; - - default: - break; - } - - sc->temp7= let_or_list; - for (s7_pointer 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, let_or_list, body_export_ok) == - opt_oops)) { - sc->temp7= sc->unused; - return (opt_oops); - } - sc->temp7= sc->unused; - - if ((hop == 1) && ((is_syntax (car (expr))) || (is_global (car (expr))))) { - if (op == OP_IF) { - const s7_pointer test= cdr (expr); - const s7_pointer b1 = cdr (test); - const s7_pointer b2 = cdr (b1); - s7_pointer p; - for (p= cdr (expr); is_pair (p); p= cdr (p)) - if (!is_fxable (sc, car (p))) { - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - return (opt_bad); - } - if (!is_null (p)) return (opt_oops); - if ((is_pair (cdr (test))) && (is_pair (cddr (test))) && - (!is_null (cdddr (test)))) - return (opt_oops); - - for (s7_pointer p1= cdr (expr); is_pair (p1); p1= cdr (p1)) - set_fx_direct (p1, - fx_choose (sc, p1, let_or_list, pair_symbol_is_safe)); - - 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)); - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - return (opt_ok); - } - 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), let_or_list, - 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)); - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - return (opt_ok); - } - 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); - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - return (opt_ok); - } - 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)); - } - } - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - return (opt_ok); + if (is_not_null(args)) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_5(sc, wrap_string(sc, "~S: too many arguments: ((~S ~S ...)~{~^ ~S~})", 46), + closure_name(sc, sc->code), + (is_closure(sc->code)) ? sc->lambda_symbol : ((is_bacro(sc->code)) ? sc->bacro_symbol : sc->macro_symbol), + closure_pars(sc->code), sc->args)); } - else { - if ((op == OP_OR) || (op == OP_AND)) { - int32_t args= 0, pairs= 0; - bool c_s_is_ok= true; - { - s7_pointer p; - for (p= cdr (expr); is_pair (p); p= cdr (p)) - if (!is_fxable (sc, car (p))) { - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - return (opt_bad); - } - if (!is_null (p)) return (opt_oops); - } - for (s7_pointer p1= cdr (expr), sym= NULL; is_pair (p1); - p1= cdr (p1), args++) /* this only applies to or/and */ - if (is_pair (car (p1))) { - pairs++; - if ((c_s_is_ok) && - ((!is_h_safe_c_s (car (p1))) || ((sym) && (sym != cadar (p1))))) - c_s_is_ok= false; - else sym= (is_pair (cdar (p1))) ? cadar (p1) : sc->unspecified; - } + else + { + const s7_pointer slot = make_slot(sc, T_Sym(pars), args); + symbol_set_local_slot(pars, id, slot); + if (is_not_slot_end(last_slot)) + slot_set_next(last_slot, slot); + else let_set_slots(let, slot); + slot_set_next(slot, slot_end); + } + sc->code = closure_body(sc->code); +} - 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_defined_global (caadr (expr))) && - ((is_symbol (caaddr (expr))) && - (symbol_type (caaddr (expr)) > 0) && - (is_defined_global (caaddr (expr))))) { - set_opt3_int (expr, symbol_type (caadr (expr))); - set_opt2_int (cdr (expr), 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); - } - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - return (opt_ok); - } +static void op_f(s7_scheme *sc) /* sc->code: ((lambda () 32)) -> (let () 32) */ +{ + set_curlet(sc, make_let(sc, sc->curlet)); + sc->code = opt3_pair(sc->code); /* cddar */ +} - for (s7_pointer p1= cdr (expr); is_pair (p1); p1= cdr (p1)) - set_fx_direct (p1, - fx_choose (sc, p1, let_or_list, 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); - } - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - return (opt_ok); - } - if (args == 2) set_safe_optimize_op (expr, OP_AND_2A); - else set_safe_optimize_op (expr, (args == 3) ? OP_AND_3A : OP_AND_N); - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - return (opt_ok); - } - else if (op == OP_BEGIN) { - s7_pointer p; - if (!is_pair (cdr (expr))) { - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - return (opt_bad); - } - for (p= cdr (expr); is_pair (p); p= cdr (p)) - if (!is_fxable (sc, car (p))) { - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - return (opt_bad); - } - if (!is_null (p)) return (opt_oops); - for (s7_pointer p1= cdr (expr); is_pair (p1); p1= cdr (p1)) - set_fx_direct (p1, - fx_choose (sc, p1, let_or_list, pair_symbol_is_safe)); - set_safe_optimize_op ( - expr, ((is_pair (cddr (expr))) && (is_null (cdddr (expr)))) - ? OP_BEGIN_AA - : OP_BEGIN_NA); - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - return (opt_ok); - } - } - } /* fully fxable lets don't happen much: even let-2a-a is scarcely used */ - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - return (opt_bad); +static void op_f_a(s7_scheme *sc) /* sc->code: ((lambda (x) (+ x 1)) i) -> (let ((x i)) (+ x 1)) */ +{ + /* if caddar(sc->code) is fxable [(+ x 1) above], this could call fx and return to the top */ + set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, opt3_sym(cdr(sc->code)), fx_call(sc, cdr(sc->code)))); + sc->code = opt3_pair(sc->code); +} + +static void op_f_aa(s7_scheme *sc) /* sc->code: ((lambda (x y) (+ x y)) i j) -> (let ((x i) (y j)) (+ x y)) */ +{ + gc_protect_via_stack(sc, fx_call(sc, cdr(sc->code))); + set_curlet(sc, make_let_with_two_slots(sc, sc->curlet, opt3_sym(cdr(sc->code)), gc_protected1(sc), cadadr(car(sc->code)), fx_call(sc, cddr(sc->code)))); + unstack_gc_protect(sc); + sc->code = opt3_pair(sc->code); +} + +static void op_f_np(s7_scheme *sc) /* sc->code: ((lambda (x y) (+ x y)) (values i j)) -> (let ((x i) (y j)) (+ x y)) after splice */ +{ + s7_pointer pars = cadar(sc->code); + const s7_pointer let = make_let(sc, sc->curlet); + if (is_pair(pars)) + { + s7_pointer last_slot; + if (is_null(cdr(sc->code))) /* ((lambda (x) 21)) */ + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, wrap_string(sc, "not enough arguments: ((lambda ~S ...)~{~^ ~S~})", 48), + cadar(sc->code), cdr(sc->code))); + if (is_constant(sc, car(pars))) + error_nr(sc, sc->syntax_error_symbol, /* (lambda (a) 1) where 'a is immutable (locally perhaps) */ + set_elist_4(sc, wrap_string(sc, "lambda parameter ~S is a constant: ((lambda ~S ...)~{~^ ~S~})", 61), + car(pars), cadar(sc->code), cdr(sc->code))); + + last_slot = add_slot_unchecked_no_local_slot(sc, let, car(pars), sc->undefined); + for (pars = cdr(pars); is_pair(pars); pars = cdr(pars)) + last_slot = add_slot_at_end_no_local(sc, last_slot, car(pars), sc->undefined); + /* last par might be rest par (dotted) */ + if (!is_null(pars)) + { + last_slot = add_slot_at_end_no_local(sc, last_slot, pars, sc->undefined); + set_is_rest_slot(last_slot); + }} + /* check_stack_size(sc); */ + if ((sc->stack_end + 4) >= sc->stack_resize_trigger) resize_stack(sc); + push_stack(sc, OP_GC_PROTECT, let_slots(let), cddr(sc->code)); /* not for gc-protection, but as implicit loop vars */ + push_stack(sc, OP_F_NP_1, let, sc->code); + sc->code = cadr(sc->code); } -static opt_t -optimize_funcs (s7_scheme* sc, s7_pointer expr, s7_pointer func, int32_t hop, - int32_t orig_hop, s7_pointer let_or_list) { - int32_t pairs= 0, symbols= 0, args= 0, bad_pairs= 0, quotes= 0; - s7_pointer p; - if (SHOW_EVAL_OPS) - fprintf (stderr, " %s[%d]: %s, func: %s, hop: %d\n", __func__, __LINE__, - display_truncated (expr), display (func), hop); - for (p= cdr (expr); is_pair (p); - p= cdr (p), args++) /* check the calling expression */ - { - const s7_pointer arg= car (p); - if (is_normal_symbol (arg)) /* for opt func */ - symbols++; - else if (is_pair (arg)) { - pairs++; - if (!is_checked (arg)) { - opt_t result; - if ((is_pair (car (arg))) && (caar (arg) == sc->let_symbol)) - result= opt_bad; - else - result= optimize_expression (sc, arg, orig_hop, let_or_list, false); - if (result == opt_bad) { - bad_pairs++; - if (is_proper_quote (sc, arg)) quotes++; - } - else if (result == opt_oops) return (opt_oops); - } - else if ((!is_optimized (arg)) || (is_unsafe (arg))) { - bad_pairs++; - if (is_proper_quote (sc, arg)) quotes++; - } +static bool op_f_np_1(s7_scheme *sc) +{ + s7_pointer slot = gc_protected1(sc); + if (is_multiple_value(sc->value)) + { + s7_pointer p, last_slot = slot; + for (p = sc->value; (is_pair(p)) && (is_not_slot_end(slot)); p = cdr(p), last_slot = slot, slot = next_slot(slot)) + if (is_rest_slot(slot)) + { + if (slot_value(slot) == sc->undefined) + slot_set_value(slot, copy_proper_list(sc, p)); + else slot_set_value(slot, pair_append(sc, slot_value(slot), copy_proper_list(sc, p))); + p = sc->nil; + break; + } + else slot_set_value(slot, car(p)); + if (is_pair(p)) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, wrap_string(sc, "not enough arguments: ((lambda ~S ...)~{~^ ~S~})", 48), + cadar(sc->code), cdr(sc->code))); + slot = last_slot; /* snd-test 22 grani */ } - } - if (is_null (p)) /* if not null, dotted list of args, (cons 1 . 2) etc -- - error perhaps? */ + else /* not mv */ + if (!is_rest_slot(slot)) + slot_set_value(slot, sc->value); + else + if (slot_value(slot) == sc->undefined) + slot_set_value(slot, list_1(sc, sc->value)); + else slot_set_value(slot, pair_append(sc, slot_value(slot), list_1(sc, sc->value))); { - switch (args) { - case 0: - return (optimize_thunk (sc, expr, func, hop, let_or_list)); - case 1: - return (optimize_func_one_arg (sc, expr, func, hop, pairs, symbols, - quotes, bad_pairs, let_or_list)); - case 2: - return (optimize_func_two_args (sc, expr, func, hop, pairs, symbols, - quotes, bad_pairs, let_or_list)); - case 3: - return (optimize_func_three_args (sc, expr, func, hop, pairs, symbols, - quotes, bad_pairs, let_or_list)); - default: - return (optimize_func_many_args (sc, expr, func, hop, args, pairs, - symbols, quotes, bad_pairs, - let_or_list)); + const s7_pointer arg = gc_protected2(sc); + if (is_pair(arg)) + { + if ((!is_not_slot_end(next_slot(slot))) && (!is_rest_slot(slot))) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, wrap_string(sc, "too many arguments: ((lambda ~S ...)~{~^ ~S~})", 46), + cadar(sc->code), cdr(sc->code))); + set_gc_protected1(sc, (is_rest_slot(slot)) ? slot : next_slot(slot)); + set_gc_protected2(sc, cdr(arg)); + push_stack_direct(sc, OP_F_NP_1); /* sc->args=e, sc->code from start */ + sc->code = car(arg); + return(true); + }} + if (is_not_slot_end(next_slot(slot))) + { + if (!is_rest_slot(next_slot(slot))) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, wrap_string(sc, "not enough arguments: ((lambda ~S ...)~{~^ ~S~})", 48), + cadar(sc->code), cdr(sc->code))); + if (slot_value(next_slot(slot)) == sc->undefined) + slot_set_value(next_slot(slot), sc->nil); } + { + s7_pointer let = sc->args; + let_set_id(let, ++sc->let_number); + set_curlet(sc, let); + update_symbol_ids(sc, let); } - return (opt_oops); /* was opt_bad, but this is always an error */ + sc->code = cddar(sc->code); + unstack_gc_protect(sc); + return(false); } -static opt_t -optimize_expression (s7_scheme* sc, s7_pointer expr, int32_t hop, - s7_pointer let_or_list, bool export_ok) { - const s7_pointer head= car (expr), args= cdr (expr); - const int32_t orig_hop= hop; - if (SHOW_EVAL_OPS) - fprintf (stderr, " %s[%d]: %s, let_or_list: %s, hop: %d\n", __func__, - __LINE__, display_truncated (expr), display (let_or_list), hop); - set_checked (expr); - - if (is_symbol (head)) { - s7_pointer slot; - if (is_syntactic_symbol (head)) { - if (!is_pair (args)) return (opt_oops); - return (optimize_syntax (sc, expr, T_Syn (global_value (head)), hop, - let_or_list, export_ok)); - } - slot= find_uncomplicated_symbol ( - sc, head, let_or_list); /* local vars (recursive calls too??) are - considered complicated */ - if (is_slot (slot)) { - const s7_pointer func= slot_value (slot); - if (is_syntax (func)) /* not is_syntactic -- here we have the value */ - return ( - (is_pair (args)) - ? optimize_syntax (sc, expr, func, hop, let_or_list, export_ok) - : opt_oops); /* e can be extended via set-cdr! here */ - - if (is_any_macro (func)) return (opt_bad); - - /* 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_applicable (func)) && - (is_safe_procedure ( - func)))) /* built-in applicable objects like vectors */ - { - /* if (is_maybe_shadowed(head)) fprintf(stderr, "%d: is_maybe_shadowed: - * %s in %s\n", __LINE__, display(head), display(expr)); */ - if ((hop != 0) && - ((is_maybe_shadowed ( - head)) || /* for globals that are possibly clobbered at - run-time (i.e. not yet) */ - (((is_any_closure (func)) || /* see use-redef in s7test -- I'm not - sure about this */ - ((!is_global (head)) && ((!is_slot (global_slot (head))) || - (global_value (head) != func)))) && - (!is_immutable ( - head)) && /* list|apply-values -- can't depend on opt1 here - because it might not be global, or might be - redefined locally */ - (!is_immutable_slot (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_defined_global(head) 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, let_or_list)); - } - } - else if ((sc->undefined_identifier_warnings) && - (slot == - sc->undefined) && /* head is not in let_or_list or global */ - (big_symbol_tag (head) == - 0)) /* and we haven't looked it up earlier */ +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)) + error_nr(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))) + error_nr(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, const s7_pointer sym, s7_pointer val, s7_pointer slot, bool check_rest) +{ + if (val == sc->no_value) val = sc->unspecified; + if (sym == slot_symbol(slot)) + return(star_set(sc, slot, val, check_rest)); + for (s7_pointer slot1 = let_slots(sc->curlet) /* presumably the arglist */; is_not_slot_end(slot1); slot1 = next_slot(slot1)) + if (slot_symbol(slot1) == sym) + return(star_set(sc, slot1, val, check_rest)); + return(sc->no_value); +} + +static s7_pointer lambda_star_set_args(s7_scheme *sc) +{ + s7_pointer arg_vals = sc->args, rest_key = sc->nil; + const s7_pointer code = sc->code, args = sc->args; + s7_pointer slot = let_slots(sc->curlet); + s7_pointer pars = closure_pars(code); + const bool allow_other_keys = ((is_pair(pars)) && (allows_other_keys(pars))); + + while ((is_pair(pars)) && (is_pair(arg_vals))) { - const s7_pointer port= current_input_port (sc); - if ((is_input_port (port)) && (port_file (port) != stdin) && - (!port_is_closed (port)) && (port_filename (port))) - s7_warn (sc, 1024, "%s might be undefined (%s %u)\n", display (head), - port_filename (port), port_line_number (port)); - else s7_warn (sc, 1024, "; %s might be undefined\n", display (head)); - set_big_symbol_tag (head, 1); /* one warning is enough */ - } + if (car(pars) == sc->rest_keyword) /* 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 */ + pars = cdr(pars); + if ((is_symbol_and_keyword(car(arg_vals))) && + (is_pair(cdr(arg_vals))) && + (keyword_symbol(car(arg_vals)) == car(pars))) + error_nr(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(pars), cadr(arg_vals))); + lambda_star_argument_set_value(sc, car(pars), (in_heap(arg_vals)) ? arg_vals : copy_proper_list(sc, arg_vals), slot, false); /* sym5 :rest bug */ + rest_key = sc->rest_keyword; + arg_vals = cdr(arg_vals); + pars = cdr(pars); + slot = next_slot(slot); + } + else + { + const s7_pointer arg_val = car(arg_vals); + if (is_symbol_and_keyword(arg_val)) + { + if (!is_pair(cdr(arg_vals))) + { + if (!sc->accept_all_keyword_arguments) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, keyword_value_missing_string, closure_name(sc, code), arg_vals, args)); + slot_set_value(slot, arg_val); + set_checked_slot(slot); + arg_vals = cdr(arg_vals); + } + else + { + const s7_pointer sym = keyword_symbol(arg_val); + if (lambda_star_argument_set_value(sc, sym, cadr(arg_vals), 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 + */ + arg_vals = cddr(arg_vals); + else + { + if (!sc->accept_all_keyword_arguments) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "~A: unknown key: ~S in ~S", 25), closure_name(sc, code), arg_vals, args)); + slot_set_value(slot, arg_val); + set_checked_slot(slot); + arg_vals = cdr(arg_vals); + pars = cdr(pars); + slot = next_slot(slot); + } + continue; + } + arg_vals = cddr(arg_vals); + } + slot = next_slot(slot); + } + else /* not a key/value pair */ + { + if (is_checked_slot(slot)) + error_nr(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(arg_vals)); + slot = next_slot(slot); + arg_vals = cdr(arg_vals); + } + pars = cdr(pars); + }} + /* (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 */ - /* head is a symbol but it's not a built-in procedure or a safe case = - * vector etc */ + /* check for trailing args with no :rest arg */ + if (is_not_null(arg_vals)) { - /* 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= args; is_pair (p); p= cdr (p), len++) { - const s7_pointer arg= car (p); - if (is_pair (arg)) { - pairs++; - if ((!is_checked (arg)) && - (optimize_expression (sc, arg, hop, let_or_list, false) == - opt_oops)) - return (opt_oops); - } - else if (is_symbol (arg)) 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_bad); - } - if (len == 1) { - if (!is_quote ( - sc, - head)) /* !! quote can be redefined locally, unsetting the - T_SYNTACTIC flag -- can this happen elsewhere? */ - set_unsafe_optimize_op (expr, (is_normal_symbol (cadr (expr))) - ? OP_UNKNOWN_S - : OP_UNKNOWN_A); - fx_annotate_arg (sc, args, let_or_list); /* g->a later if closure */ - return (opt_bad); - } - if (len == 2) { - set_unsafely_optimized (expr); - set_optimize_op (expr, OP_UNKNOWN_GG); - return (opt_bad); - } - if (len >= 3) { - if (len == symbols) { - set_unsafe_optimize_op (expr, OP_UNKNOWN_NS); - set_opt3_arglen (args, len); - return (opt_bad); - } - if (fx_count (sc, expr) == len) { - set_unsafe_optimize_op (expr, OP_UNKNOWN_NA); - set_opt3_arglen (args, len); - return (opt_bad); - } - } - } - else /* pairs != 0 */ - { - const s7_pointer arg1= cadr (expr); - if ((pairs == 1) && (len == 1)) { - if ((is_quote (sc, head)) && - (direct_memq (sc->quote_symbol, let_or_list))) - return (opt_oops); - if (is_fxable (sc, arg1)) { - set_opt3_arglen (args, 1); - fx_annotate_arg (sc, args, let_or_list); - set_unsafe_optimize_op (expr, OP_UNKNOWN_A); - return (opt_bad); - } - } - 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 (args, len); - if (len <= 2) fx_annotate_args (sc, args, let_or_list); - return (opt_bad); - } - set_unsafe_optimize_op (expr, OP_UNKNOWN_NP); - set_opt3_arglen (args, len); - return (opt_bad); - } - } + if ((is_not_null(pars)) || + (rest_key == sc->rest_keyword)) + { + if (is_symbol(pars)) + { + if ((is_symbol_and_keyword(car(arg_vals))) && + (is_pair(cdr(arg_vals))) && + (keyword_symbol(car(arg_vals)) == pars)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "can't set rest argument ~S to ~S via keyword", 44), pars, cadr(arg_vals))); + slot_set_value(slot, (in_heap(arg_vals)) ? arg_vals : copy_proper_list(sc, arg_vals)); /* sym5 :rest bug */ + }} + else + { + if (!allow_other_keys) /* ((lambda* (a) a) :a 1 2) */ + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_4(sc, wrap_string(sc, "too many arguments: (~S ~S ...)~{~^ ~S~})", 41), + (is_closure_star(code)) ? sc->lambda_star_symbol : ((is_bacro_star(sc->code)) ? sc->bacro_star_symbol : sc->macro_star_symbol), + closure_pars(code), args)); + /* check trailing args for repeated keys or keys with no values or values with no keys */ + while (is_pair(arg_vals)) + { + if ((!is_symbol_and_keyword(car(arg_vals))) || /* ((lambda* (a :allow-other-keys) a) :a 1 :b 2 3) */ + (!is_pair(cdr(arg_vals)))) /* ((lambda* (a :allow-other-keys) a) :a 1 :b) */ + error_nr(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), arg_vals)); + slot = symbol_to_local_slot(sc, keyword_symbol(car(arg_vals)), sc->curlet); + if ((is_slot(slot)) && + (is_checked_slot(slot))) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, parameter_set_twice_string, slot_symbol(slot), sc->args)); + arg_vals = cddr(arg_vals); + }}} + return(sc->nil); +} + +static inline bool lambda_star_default(s7_scheme *sc) +{ + for (s7_pointer slot = sc->args; is_not_slot_end(slot); slot = next_slot(slot)) + { + if ((slot_value(slot) == sc->undefined) && /* trouble: (lambda* ((e #))...) */ + (slot_has_expression(slot)) && /* if default val is not a pair or a symbol, this is false */ + (!is_checked_slot(slot))) + { + const s7_pointer val = slot_expression(slot); + if (is_symbol(val)) + { + slot_set_value(slot, lookup_checked(sc, val)); + if (slot_value(slot) == 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(slot, s7_symbol_local_value(sc, val, let_outlet(sc->curlet))); + if (slot_value(slot) == sc->undefined) + syntax_error_nr(sc, "lambda* defaults: ~A is unbound", 31, slot_symbol(slot)); + }} + else + if (!is_pair(val)) + slot_set_value(slot, val); + else + if (is_quote(sc, car(val))) + { + if ((!is_pair(cdr(val))) || /* (lambda* ((a (quote))) a) or (lambda* ((a (quote 1 1))) a) etc */ + (is_pair(cddr(val)))) + syntax_error_nr(sc, "lambda* default: ~A is messed up", 32, val); + slot_set_value(slot, cadr(val)); + } + else + { + push_stack(sc, OP_LAMBDA_STAR_DEFAULT, slot, sc->code); + sc->code = val; + return(true); /* goto eval */ + }}} + return(false); /* goto BEGIN */ +} + +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)) + syntax_error_nr(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)) return(true); + pop_stack_no_op(sc); + sc->code = T_Pair(closure_body(sc->code)); + return(false); /* goto BEGIN */ +} + +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)) return(true); /* else fall_through */ + pop_stack_no_op(sc); /* get original args and code back */ } - } - 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)))) */ - - if ((head == sc->quote_function) && (is_pair (args))) /* very common */ - return (optimize_syntax (sc, expr, sc->quote_function, hop, let_or_list, - export_ok)); - - if (is_c_function (head)) /* (#_abs x) etc */ - return (optimize_funcs ( - sc, expr, head, - /* (direct_memq(c_function_symbol(head), let_or_list)) ? 0 : */ 1, - orig_hop, let_or_list)); - - if (is_syntax (head)) /* (#_cond...) etc */ - { - if (!is_pair (args)) return (opt_oops); - return ( - optimize_syntax (sc, expr, head, orig_hop, let_or_list, export_ok)); - } - if (is_any_macro (head)) return (opt_bad); - - /* 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 (s7_pointer p= expr; is_pair (p); p= cdr (p)) - if (((is_symbol (car (p))) && (is_syntactic_symbol (car (p)))) || - ((is_pair (car (p))) && (!is_checked (car (p))) && - (optimize_expression (sc, car (p), hop, let_or_list, 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_bad); + sc->code = closure_body(sc->code); + return(false); /* goto BEGIN */ } -static opt_t -optimize (s7_scheme* sc, s7_pointer code, int32_t hop, s7_pointer let_or_list) { - s7_pointer expr; - if (SHOW_EVAL_OPS) - fprintf (stderr, " %s[%d]: %s, let_or_list: %s, hop: %d\n", __func__, - __LINE__, display_truncated (code), display (let_or_list), hop); - for (expr= code; (is_pair (expr)) && (!is_checked (expr)); expr= cdr (expr)) { - const s7_pointer obj= car (expr); - set_checked (expr); - if (is_pair (obj)) { - if ((!is_checked (obj)) && - (optimize_expression (sc, obj, hop, let_or_list, true) == opt_oops)) { - s7_pointer p; - for (p= cdr (expr); is_pair (p); p= cdr (p)) - ; - if (!is_null (p)) - syntax_error_nr (sc, "stray dot in function body: ~S", 30, code); - return (opt_oops); - } +static inline bool apply_safe_closure_star_1(s7_scheme *sc) /* -------- define* (lambda*) -------- */ +{ + /* 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 (s7_pointer slot = let_slots(sc->curlet); is_not_slot_end(slot); slot = next_slot(slot)) + { + clear_checked_slot(slot); + slot_set_value(slot, 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 (s7_pointer slot = let_slots(sc->curlet); is_not_slot_end(slot); slot = next_slot(slot)) + { + clear_checked_slot(slot); + slot_set_value(slot, (slot_defaults(slot)) ? sc->undefined : slot_expression(slot)); } - else if (is_symbol (obj)) - set_optimize_op (obj, (is_keyword (obj)) ? OP_CONSTANT : OP_SYMBOL); - else set_optimize_op (obj, OP_CONSTANT); - } - if (!is_list (expr)) - syntax_error_nr (sc, "stray dot in function body: ~S", 30, code); - return (opt_bad); + return(set_star_args(sc, slot_pending_value(let_slots(sc->curlet)))); } -static s7_pointer -key_or_constant_arg (s7_scheme* sc, s7_pointer arg) { - bool key= is_symbol_and_keyword (arg); - return (wrap_string (sc, (key) ? "keyword" : "constant", (key) ? 7 : 8)); - /* maybe better, but there is no sc->keyword_symbol: - * return((is_symbol_and_keyword(arg)) ? sc->keyword_symbol : - * sc->constant_symbol); */ +static bool apply_unsafe_closure_star_1(s7_scheme *sc) +{ + s7_pointer pars, top = sc->nil; + for (pars = closure_pars(sc->code); is_pair(pars); pars = cdr(pars)) + { + const s7_pointer par = car(pars); + if (is_pair(par)) /* parameter has a default value */ + { + s7_pointer slot; + const s7_pointer val = cadr(par); + if ((!is_pair(val)) && + (!is_symbol(val))) + slot = add_slot_checked(sc, sc->curlet, car(par), val); + else + { + add_slot(sc, sc->curlet, car(par), sc->undefined); + slot = let_slots(sc->curlet); + slot_set_expression(slot, val); + } + if (is_null(top)) + top = slot; + } + else + if (!is_keyword(par)) + add_slot_checked(sc, sc->curlet, par, sc->F); /* checked tlimit */ + else + if (par == sc->rest_keyword) /* else it's :allow-other-keys? */ + { + set_is_rest_slot(add_slot_checked(sc, sc->curlet, cadr(pars), sc->nil)); + pars = cdr(pars); + }} + if (is_symbol(pars)) + set_is_rest_slot(add_slot_checked(sc, sc->curlet, pars, sc->nil)); /* set up rest arg */ + let_set_slots(sc->curlet, reverse_slots(let_slots(sc->curlet))); + return(set_star_args(sc, top)); } -static void -check_lambda_args (s7_scheme* sc, s7_pointer args, int32_t* arity, - s7_pointer form) { - int32_t i; - if (!is_list (args)) { - if (is_constant (sc, args)) /* (lambda :a ...) or (define (f :a) ...) */ - error_nr (sc, sc->syntax_error_symbol, - set_elist_5 ( - sc, - wrap_string (sc, "~A parameter is a ~A: (~S ~S ...)", 33), - car (form), key_or_constant_arg (sc, args), car (form), - cadr (form))); - /* 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; - } - begin_small_symbol_set (sc); - for (i= 0; is_pair (args); i++, args= cdr (args)) { - const s7_pointer arg= car (args); - if (is_constant ( - sc, arg)) /* (lambda (pi) pi), constant here means not a symbol */ - { - if (is_pair (arg)) /* (lambda ((:hi . "hi") . "hi") 1) */ - error_nr ( - sc, sc->syntax_error_symbol, /* don't use ~A here or below, (lambda - #\null do) for example */ - set_elist_5 (sc, - wrap_string (sc, - "~A parameter ~S is a pair (perhaps use " - "lambda*?): (~S ~S ...)", - 61), - car (form), arg, car (form), cadr (form))); - if ((arg == sc->rest_keyword) && ((car (form) == sc->define_symbol) || - (car (form) == sc->lambda_symbol))) - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_6 ( - sc, - wrap_string ( - sc, "~A parameter is ~S? (~S ~S ...), perhaps use ~S", 47), - car (form), arg, car (form), cadr (form), - (car (form) == sc->define_symbol) ? sc->define_star_symbol - : sc->lambda_star_symbol)); - error_nr ( - sc, sc->syntax_error_symbol, /* (lambda (a :b c) 1) */ - set_elist_6 ( - sc, wrap_string (sc, "~A parameter ~S is a ~A: (~S ~S ...)", 36), - car (form), arg, key_or_constant_arg (sc, arg), car (form), - cadr (form))); - } - if (symbol_is_in_small_symbol_set (sc, arg)) - error_nr (sc, sc->syntax_error_symbol, - set_elist_5 (sc, - wrap_string (sc, - "~A parameter ~S is used twice in " - "the parameter list, (~S ~S ...)", - 64), - car (form), arg, car (form), cadr (form))); - add_symbol_to_small_symbol_set (sc, arg); - set_local (arg); - } - if (is_not_null (args)) { - if ((is_symbol (args)) && (symbol_is_in_small_symbol_set (sc, args))) - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, - "~A :rest parameter ~S is used earlier in the parameter list", - 59), - car (form), args)); - if (is_constant (sc, - args)) /* (lambda (a . 0.0) a) or (lambda (a . :b) a) */ - error_nr (sc, sc->syntax_error_symbol, - set_elist_6 ( - sc, - wrap_string ( - sc, "~A :rest parameter ~S is a ~A in (~S ~S ...)", 44), - car (form), args, key_or_constant_arg (sc, args), - car (form), cadr (form))); - i= -i - 1; - } - end_small_symbol_set (sc); - if (arity) (*arity)= i; -} - -static s7_pointer -check_lambda_star_args ( - s7_scheme* sc, s7_pointer args, s7_pointer body, - s7_pointer form) /* checks closure*, macro*, and bacro* */ -{ - const s7_pointer top = args; - s7_pointer pars = args; - bool has_defaults= false; - - if (!is_list (args)) { - if (is_constant (sc, args)) /* (lambda* :a ...) or (define* (f . :a) ...) */ - error_nr (sc, sc->syntax_error_symbol, - set_elist_5 ( - sc, - wrap_string (sc, "~A parameter is a ~A: (~S ~S ...)", 33), - car (form), key_or_constant_arg (sc, args), car (form), - cadr (form))); - if (is_symbol (args)) set_local (args); - return (args); - } +static void apply_macro_star_1(s7_scheme *sc) +{ + /* here the defaults (if any) are not evalled, and there is not an existing let */ + s7_pointer pars; + for (pars = closure_pars(sc->code); is_pair(pars); pars = cdr(pars)) + { + const s7_pointer par = car(pars); + 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->rest_keyword) + { + set_is_rest_slot(add_slot_checked(sc, sc->curlet, cadr(pars), sc->nil)); + pars = cdr(pars); + }} + if (is_symbol(pars)) + set_is_rest_slot(add_slot_checked(sc, sc->curlet, pars, sc->nil)); + let_set_slots(sc->curlet, reverse_slots(let_slots(sc->curlet))); + lambda_star_set_args(sc); + sc->code = T_Pair(closure_body(sc->code)); +} - begin_small_symbol_set (sc); - for (s7_pointer last_pars= args; is_pair (pars); - last_pars= pars, pars= cdr (pars)) { - const s7_pointer cur_par= car (pars); - if (is_pair (cur_par)) { - has_defaults= true; - if (is_constant (sc, car (cur_par))) /* (lambda* ((:a 1)) ...) */ - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_6 ( - sc, - wrap_string (sc, "~A parameter ~S is a ~A: (~S ~S ...)", 36), - car (form), car (cur_par), - key_or_constant_arg (sc, car (cur_par)), car (form), - cadr (form))); - if (symbol_is_in_small_symbol_set (sc, car (cur_par))) - error_nr (sc, sc->syntax_error_symbol, - set_elist_5 (sc, - wrap_string (sc, - "~A parameter ~S is used twice in " - "the parameter list, (~S ~S ...)", - 64), - car (form), car (cur_par), car (form), - cadr (form))); - add_symbol_to_small_symbol_set (sc, car (cur_par)); - if (!is_pair (cdr (cur_par))) { - if (is_null (cdr (cur_par))) /* (lambda* ((a)) ...) */ - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_5 ( - sc, - wrap_string ( - sc, - "~A parameter ~S default value missing in (~S ~S ...)", - 52), - car (form), cur_par, car (form), cadr (form))); - error_nr ( - sc, sc->syntax_error_symbol, /* (lambda* ((a . 0.0)) a) */ - set_elist_5 ( - sc, - wrap_string ( - sc, "~A parameter ~S is a dotted pair in (~S ~S ...)", 47), - car (form), cur_par, car (form), cadr (form))); - } - if ((is_pair (cadr (cur_par))) && /* (lambda* ((a (quote . -1))) ...) */ - (s7_list_length (sc, cadr (cur_par)) < 0)) - error_nr (sc, sc->syntax_error_symbol, - set_elist_5 (sc, - wrap_string (sc, - "~A parameter ~S default value is " - "not a proper list in (~S ~S ...)", - 65), - car (form), cur_par, car (form), cadr (form))); - if (is_not_null (cddr (cur_par))) /* (lambda* ((a 0.0 'hi)) a) */ - error_nr (sc, sc->syntax_error_symbol, - set_elist_5 (sc, - wrap_string (sc, - "~A parameter ~S has multiple " - "default values in (~S ~S ...)", - 58), - car (form), cur_par, car (form), cadr (form))); - set_local (car (cur_par)); - } - else if (cur_par != sc->rest_keyword) { - if (is_constant (sc, cur_par)) { - if (cur_par != sc->allow_other_keys_keyword) - error_nr ( - sc, sc->syntax_error_symbol, /* (lambda* (pi) ...) */ - set_elist_6 ( - sc, - wrap_string (sc, "~A parameter ~S is a ~A: (~S ~S ...)", 36), - car (form), cur_par, key_or_constant_arg (sc, cur_par), - car (form), cadr (form))); - if (is_not_null (cdr (pars))) /* (lambda* (:allow-other-keys x) x) */ - error_nr (sc, sc->syntax_error_symbol, - set_elist_3 (sc, - wrap_string (sc, - ":allow-other-keys should be the " - "last parameter: (~S ~S ...)", - 59), - car (form), cadr (form))); - if (pars == top) /* (lambda* (:allow-other-keys) 1) */ - error_nr (sc, sc->syntax_error_symbol, - set_elist_3 (sc, - wrap_string (sc, - ":allow-other-keys can't be the " - "only parameter: (~S ~S ...)", - 58), - car (form), cadr (form))); - set_allow_other_keys (top); - set_cdr (last_pars, - sc->nil); /* last_pars is '( :allow-other-keys) so this - chops off the trailing keyword */ - } - if (symbol_is_in_small_symbol_set (sc, cur_par)) - error_nr (sc, sc->syntax_error_symbol, - set_elist_5 (sc, - wrap_string (sc, - "~A parameter ~S is used twice in " - "the parameter list, (~S ~S ...)", - 64), - car (form), cur_par, car (form), cadr (form))); - add_symbol_to_small_symbol_set (sc, cur_par); - if (!is_keyword (cur_par)) set_local (cur_par); - } - else { - has_defaults= true; - if (!is_pair (cdr (pars))) /* (lambda* (:rest) ...) */ - error_nr (sc, sc->syntax_error_symbol, - set_elist_4 ( - sc, - wrap_string ( - sc, "~A :rest parameter missing in (~S ~S ...)", 41), - car (form), car (form), cadr (form))); - if (!is_symbol (cadr (pars))) /* (lambda* (:rest (a 1)) ...) */ - { - if (!is_pair (cadr (pars))) /* (lambda* (:rest 1) ...) */ - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_5 ( - sc, - wrap_string ( - sc, - "~A :rest parameter is not a symbol: ~S in (~S ~S ...)", - 53), - car (form), pars, car (form), cadr (form))); - error_nr (sc, sc->syntax_error_symbol, /* (lambda* (:rest '(1 2)) 1) */ - set_elist_5 (sc, - wrap_string (sc, - "~A :rest parameter can't have a " - "default value: ~S in (~S ~S ...)", - 64), - car (form), pars, car (form), cadr (form))); - } - if (is_constant (sc, cadr (pars))) /* (lambda* (a :rest x) ...) where x is - locally a constant */ - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_5 (sc, - wrap_string (sc, - "~A: ~S is immutable, so it can't be the " - ":rest parameter name: (~S ~S ...)", - 73), - car (form), cadr (pars), car (form), cadr (form))); - set_local (cadr (pars)); +static void clear_absolutely_all_optimizations(s7_pointer p) +{ + if ((is_pair(p)) && (!is_matched_pair(p))) + { + clear_has_fx(p); + clear_optimized(p); + clear_optimize_op(p); + set_match_pair(p); + clear_absolutely_all_optimizations(cdr(p)); + clear_absolutely_all_optimizations(car(p)); } - } - if (is_not_null (pars)) { - if ((is_symbol (pars)) && (symbol_is_in_small_symbol_set (sc, pars))) - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, - "~A :rest parameter ~S is used earlier in the parameter list", - 59), - car (form), pars)); - if (is_constant (sc, pars)) /* (lambda* (a 0.0) a) or (lambda* (a :b) a) */ - error_nr (sc, sc->syntax_error_symbol, - set_elist_6 ( - sc, - wrap_string ( - sc, "~A :rest parameter ~S is a ~A, (~S ~S ...)", 42), - car (form), pars, key_or_constant_arg (sc, pars), - car (form), cadr (form))); - if (is_symbol (pars)) set_local (pars); - } - else if ((body) && (!has_defaults) && (is_pair (args))) - set_has_no_defaults (body); - end_small_symbol_set (sc); - 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; +static void clear_matches(s7_pointer p) +{ + if ((is_pair(p)) && (is_matched_pair(p))) + { + clear_match_pair(p); + clear_matches(car(p)); + clear_matches(cdr(p)); + } } -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 void apply_macro(s7_scheme *sc) /* this is not from the reader, so treat expansions here as normal macros */ +{ + check_stack_size(sc); + if (closure_arity_to_int(sc, sc->code) < 0) + { + clear_absolutely_all_optimizations(sc->args); /* desperation... */ + clear_matches(sc->args); + } + push_stack_op_let(sc, OP_EVAL_MACRO); + set_curlet(sc, inline_make_let(sc, closure_let(sc->code))); /* closure_let -> sc->curlet, sc->code is the macro */ + transfer_macro_info(sc, sc->code); } -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 form, - bool at_end) /* called only from body_is_safe */ +static void apply_bacro(s7_scheme *sc) { - const s7_pointer expr = car (form); - body_t result= very_safe_body; + check_stack_size(sc); + push_stack_op_let(sc, OP_EVAL_MACRO); + set_curlet(sc, 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); +} - if (is_symbol_and_syntactic (expr)) { - if (!is_pair (cdr (form))) return (unsafe_body); - switch (symbol_syntax_op_checked (form)) - /* symbol_syntax_op(expr) here gets tangled in fx_annotation order problems! - * -- fix this?!? it appears that safe bodies are marked unsafe because the - * opts are out-of-order? - */ - { - case OP_OR: - case OP_AND: - case OP_BEGIN: - case OP_WITH_BAFFLE: - return (body_is_safe (sc, func, cdr (form), at_end)); +static void apply_macro_star(s7_scheme *sc) +{ + check_stack_size(sc); + push_stack_op_let(sc, OP_EVAL_MACRO); + set_curlet(sc, make_let(sc, closure_let(sc->code))); + transfer_macro_info(sc, sc->code); + apply_macro_star_1(sc); +} - case OP_MACROEXPAND: - return (unsafe_body); +static void apply_bacro_star(s7_scheme *sc) +{ + check_stack_size(sc); + push_stack_op_let(sc, OP_EVAL_MACRO); + set_curlet(sc, make_let(sc, sc->curlet)); + transfer_macro_info(sc, sc->code); + apply_macro_star_1(sc); +} - case OP_QUOTE: - case OP_QUOTE_UNCHECKED: - return (((!is_pair (cdr (form))) || (!is_null (cddr (form)))) - ? unsafe_body - : very_safe_body); /* (quote . 1) or (quote 1 2) etc */ - - case OP_IF: - if (!is_pair (cddr (form))) return (unsafe_body); - if (is_pair (cadr (form))) { - result= form_is_safe (sc, func, cadr (form), false); - if (result == unsafe_body) return (unsafe_body); - } - if (is_pair (caddr (form))) { - result= - min_body (result, form_is_safe (sc, func, caddr (form), at_end)); - if (result == unsafe_body) return (unsafe_body); - } - if ((is_pair (cdddr (form))) && (is_pair (cadddr (form)))) - return ( - min_body (result, form_is_safe (sc, func, cadddr (form), at_end))); - return (result); +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 */ + check_stack_size(sc); + set_curlet(sc, inline_make_let(sc, closure_let(sc->code))); +} - case OP_WHEN: - case OP_UNLESS: - if (!is_pair (cddr (form))) return (unsafe_body); - if (is_pair (cadr (form))) { - result= form_is_safe (sc, func, cadr (form), false); - if (result == unsafe_body) return (unsafe_body); - } - return (min_body (result, body_is_safe (sc, func, cddr (form), at_end))); - - case OP_COND: { - bool follow = false; - s7_pointer clauses= cdr (form); - for (s7_pointer sp= form; is_pair (clauses); clauses= cdr (clauses)) { - const s7_pointer clause= car (clauses); - if (!is_pair (clause)) return (unsafe_body); - if (is_pair (car (clause))) { - result= - min_body (result, form_is_safe (sc, func, car (clause), false)); - if (result == unsafe_body) return (unsafe_body); - } - if (is_pair (cdr (clause))) { - result= - min_body (result, body_is_safe (sc, func, cdr (clause), at_end)); - if (result == unsafe_body) return (unsafe_body); - } - if (follow) { - sp= cdr (sp); - if (clauses == sp) return (unsafe_body); - } - follow= (!follow); - } - return ((is_null (clauses)) ? result : unsafe_body); - } +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); + set_curlet(sc, make_let(sc, closure_let(sc->code))); + return(apply_unsafe_closure_star_1(sc)); +} - case OP_CASE: { - bool follow= false; - s7_pointer sp; - if (!is_pair (cddr (form))) return (unsafe_body); - if (is_pair (cadr (form))) { - result= form_is_safe (sc, func, cadr (form), false); - if (result == unsafe_body) return (unsafe_body); - } - sp= cdr (form); - for (s7_pointer clauses= cdr (sp); is_pair (clauses); - clauses = cdr (clauses)) { - if (!is_pair (car (clauses))) return (unsafe_body); - if (is_pair (cdar (clauses))) { - result= min_body (result, - body_is_safe (sc, func, cdar (clauses), - at_end)); /* null cdar(p) ok here */ - if (result == unsafe_body) return (unsafe_body); - } - if (follow) { - sp= cdr (sp); - if (clauses == sp) return (unsafe_body); - } - follow= (!follow); - } - return (result); - } +static inline s7_pointer op_safe_closure_star_a1(s7_scheme *sc, s7_pointer code) /* called in eval and below, tlamb */ +{ + const s7_pointer func = opt1_lambda(code); + const s7_pointer val = fx_call(sc, cdr(code)); + if ((is_symbol_and_keyword(val)) && + (!sc->accept_all_keyword_arguments)) + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_4(sc, keyword_value_missing_string, closure_name(sc, func), val, sc->args)); + set_curlet(sc, update_let_with_slot(sc, closure_let(func), val)); + sc->code = T_Pair(closure_body(func)); + return(func); +} - 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 (form))) return (unsafe_body); - if (cadr (form) == func) return (unsafe_body); - - /* car(form) is set!, cadr(form) is settee or obj, caddr(form) is val */ - if (is_pair (caddr (form))) { - result= form_is_safe (sc, func, caddr (form), false); - if (result == unsafe_body) return (unsafe_body); +static void op_safe_closure_star_a(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer func = op_safe_closure_star_a1(sc, code); + s7_pointer p = cdr(closure_pars(func)); + if (is_pair(p)) + for (s7_pointer slot = next_slot(let_slots(closure_let(func))); is_pair(p); p = cdr(p), slot = next_slot(slot)) + { + if (is_pair(car(p))) + { + s7_pointer defval = cadar(p); + slot_set_value(slot, (is_pair(defval)) ? cadr(defval) : defval); + } + else slot_set_value(slot, sc->F); + symbol_set_local_slot(slot_symbol(slot), let_id(sc->curlet), slot); } - return ( - (is_pair (cadr (form))) - ? min_body (result, form_is_safe (sc, func, cadr (form), false)) - : result); - /* not OP_DEFINE even in simple cases (safe_closure assumes constant - * funclet) */ +} - case OP_WITH_LET: - if (!is_pair (cddr (form))) return (unsafe_body); - return ((is_pair (cadr (form))) - ? unsafe_body - : min_body (body_is_safe (sc, sc->F, cddr (form), at_end), - safe_body)); - /* shadowing can happen in with-let -- symbols are global so local_slots - * are shadowable */ +static void op_safe_closure_star_ka(s7_scheme *sc, s7_pointer code) /* two args, but k=arg key, key has been checked. no trailing pars */ +{ + const s7_pointer func = opt1_lambda(code); + set_curlet(sc, update_let_with_slot(sc, closure_let(func), fx_call(sc, cddr(code)))); + sc->code = T_Pair(closure_body(func)); +} - case OP_LET_TEMPORARILY: - if (!is_pair (cadr (form))) return (unsafe_body); - for (s7_pointer vars= cadr (form); is_pair (vars); vars= cdr (vars)) { - if ((!is_pair (car (vars))) || (!is_pair (cdar (vars)))) - return (unsafe_body); - if (is_pair (cadar (vars))) { - result= - min_body (result, form_is_safe (sc, sc->F, cadar (vars), false)); - if (result == unsafe_body) return (unsafe_body); - } - } - return (min_body (result, body_is_safe (sc, sc->F, cddr (form), 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, vars= cadr (form), body= cddr (form); - if (is_symbol (vars)) { - if (!is_pair (body)) return (unsafe_body); /* (let name . res) */ - if (vars == func) return (unsafe_body); /* named let shadows caller */ - let_name= vars; - vars = caddr (form); - body = cdddr (form); - if (is_symbol (func)) add_symbol_to_small_symbol_set (sc, func); - } - else let_name= func; - - for (s7_pointer sp= NULL; is_pair (vars); vars= cdr (vars)) { - const s7_pointer let_var= car (vars); - s7_pointer 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_small_symbol_set (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 (form))) return (unsafe_body); - if (is_pair (cadr (form))) { - s7_pointer vars = cadr (form); - s7_pointer slow_vars= vars; - for (bool follow= false; is_pair (vars); vars= cdr (vars)) { - const 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_small_symbol_set (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 (slow_vars != vars) { - if (follow) { - slow_vars= cdr (slow_vars); - if (vars == slow_vars) return (unsafe_body); - } - follow= (!follow); - } - } - } - if (is_pair (caddr (form))) - result= - min_body (result, body_is_safe (sc, func, caddr (form), at_end)); - return (min_body (result, body_is_safe (sc, func, cdddr (form), 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: - /* OP_LAMBDA is major case here */ - /* 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(form) is not syntactic */ - { - if (expr == func) /* try to catch tail call, expr is car(form) */ - { - bool follow = false; - s7_pointer slow_form= form, p; - sc->got_rec= - true; /* (walk (car tree)) lint and almost all others in s7test */ - set_rec_tc_args (sc, proper_list_length (cdr (form))); - if (!at_end) { - result = recur_body; - sc->not_tc= true; - } - for (p= cdr (form); 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); +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) */ + const s7_pointer func = opt1_lambda(code); + s7_pointer arg2, arg1 = fx_call(sc, cdr(code)); + sc->w = arg1; /* weak GC protection */ + arg2 = fx_call(sc, cddr(code)); - if (follow) { - slow_form= cdr (slow_form); - if (p == slow_form) 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 (form))); - return (result); - } - if (result != unsafe_body) result= recur_body; - return (result); - } - if (is_symbol (expr)) /* expr=car(form) */ + if (is_symbol_and_keyword(arg1)) { - s7_pointer head_f, f_slot; - bool c_safe; - - if (symbol_is_in_small_symbol_set (sc, expr)) return (unsafe_body); - if ((is_slot (global_slot (expr))) && (is_syntax (global_value (expr)))) - return (unsafe_body); /* syntax hidden behind some other name */ + if (keyword_symbol(arg1) == slot_symbol(let_slots(closure_let(func)))) + { + arg1 = arg2; + arg2 = cadr(closure_pars(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_pars(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) + error_nr(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_symbol_and_keyword(arg2)) && + (!sc->accept_all_keyword_arguments)) + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_4(sc, keyword_value_missing_string, closure_name(sc, func), arg2, code)); + set_curlet(sc, update_let_with_two_slots(sc, closure_let(func), arg1, arg2)); + sc->code = T_Pair(closure_body(func)); +} - f_slot= s7_slot (sc, expr); - if (!is_slot (f_slot)) return (unsafe_body); +static bool call_lambda_star(s7_scheme *sc, s7_pointer code, s7_pointer arglist) +{ + bool target; + sc->code = opt1_lambda(code); + target = apply_safe_closure_star_1(sc); + if (!in_heap(arglist)) clear_safe_list_in_use(sc, arglist); + return(target); +} - head_f= slot_value (f_slot); - if (is_c_function (head_f)) { - if ((expr == sc->apply_symbol) && (is_pair (cdr (form))) && - (is_symbol (cadr (form)))) /* (apply ...) */ - { - s7_pointer apply_f= lookup_unexamined ( - sc, cadr (form)); /* "unexamined" to skip unbound_variable */ - c_safe= - ((apply_f) && /* (apply_f != sc->undefined) && */ - ((is_safe_c_function (apply_f)) || - ((is_closure (apply_f)) && (is_very_safe_closure (apply_f))))); - } - else c_safe= (is_safe_or_scope_safe_procedure (head_f)); - } - else c_safe= false; - - result= ((is_simple_sequence (head_f)) || /* was is_sequence? */ - ((is_closure (head_f)) && (is_very_safe_closure (head_f))) || - ((c_safe) && - ((is_immutable_slot (f_slot)) || (is_defined_global (expr))))) - ? very_safe_body - : safe_body; - - if ((c_safe) || - ((is_any_closure (head_f)) && (is_safe_closure (head_f))) || - (is_simple_sequence (head_f))) /* was is_sequence? */ - { - bool follow = false; - s7_pointer slow_form= form, p= cdr (form); - for (; is_pair (p); p= cdr (p)) { - if (is_unquoted_pair (sc, 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 (head_f)) && (is_scope_safe (head_f)) && - (caar (p) == sc->lambda_symbol)) { - s7_pointer argp, lbody; - body_t lresult; - - if (!is_pair (cdar (p))) /* (lambda . /) */ - return (unsafe_body); - argp = cadar (p); - lbody= cddar (p); - for (s7_pointer q= argp; is_pair (q); q= cdr (q)) { - if (!is_symbol (car (q))) return (unsafe_body); - add_symbol_to_small_symbol_set (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); +static bool op_safe_closure_star_3a(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer func = opt1_lambda(code), arg1 = fx_call(sc, cdr(code)); + s7_pointer arg2, arg3; + gc_protect_via_stack(sc, arg1); + arg2 = fx_call(sc, cddr(code)); + set_gc_protected2(sc, arg2); + arg3 = fx_call(sc, cdddr(code)); + if ((is_symbol_and_keyword(arg1)) || (is_symbol_and_keyword(arg2)) || (is_symbol_and_keyword(arg3))) + { + s7_pointer arglist = make_safe_list(sc, 3); + sc->args = arglist; + set_car(arglist, arg1); + set_cadr(arglist, arg2); + set_caddr(arglist, arg3); + unstack_gc_protect(sc); + return(call_lambda_star(sc, code, arglist)); /* this clears safe_list_in_use */ + } + set_curlet(sc, update_let_with_three_slots(sc, closure_let(func), arg1, arg2, arg3)); + unstack_gc_protect(sc); + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin_unchecked(sc); + 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)); +} - if (follow) { - slow_form= cdr (slow_form); - if (p == slow_form) return (unsafe_body); - } - follow= (!follow); - } - return ((is_null (p)) ? result : unsafe_body); - } - if ((is_safe_quote (sc, expr)) && (is_proper_list_1 (sc, cdr (form)))) - return (result); +static bool op_safe_closure_star_na_1(s7_scheme *sc, s7_pointer code) +{ + s7_pointer arglist = safe_list_1(sc); + sc->args = arglist; + set_car(arglist, fx_call(sc, cdr(code))); + return(call_lambda_star(sc, code, arglist)); /* clears safe_list_in_use */ +} - if (expr == sc->values_symbol) /* (values) is safe, as is (values x) if x - is: (values (define...)) */ - { - if (is_null (cdr (form))) return (result); - if ((is_pair (cdr (form))) && (is_null (cddr (form)))) - return ((is_pair (cadr (form))) - ? min_body (result, - form_is_safe (sc, func, cadr (form), false)) - : result); - } - } - else if (expr == sc->quote_function) - return (((!is_pair (cdr (form))) || (!is_null (cddr (form)))) - ? unsafe_body - : very_safe_body); /* (#_quote . 1) or (#_quote 1 2) etc */ +static bool op_safe_closure_star_na_2(s7_scheme *sc, s7_pointer code) +{ + s7_pointer arglist = safe_list_2(sc); + sc->args = arglist; + set_car(arglist, fx_call(sc, cdr(code))); + set_cadr(arglist, fx_call(sc, cddr(code))); + return(call_lambda_star(sc, code, arglist)); /* clears safe_list_in_use */ +} - return (unsafe_body); /* not recur_body here if at_end -- possible defines - in body etc */ - } - return (result); +static inline bool op_safe_closure_star_na(s7_scheme *sc, s7_pointer code) /* called once in eval, clo */ +{ + s7_pointer arglist = safe_list_if_possible(sc, opt3_arglen(cdr(code))); + sc->args = arglist; + for (s7_pointer p = arglist, old_args = cdr(code); is_pair(p); p = cdr(p), old_args = cdr(old_args)) + set_car(p, fx_call(sc, old_args)); + return(call_lambda_star(sc, code, arglist)); /* clears safe_list_in_use */ } -static body_t -body_is_safe (s7_scheme* sc, s7_pointer func, s7_pointer body, bool at_end) { - bool follow= false; - s7_pointer forms = body; - body_t result= very_safe_body; - for (s7_pointer slow_body= body; is_pair (forms); forms= cdr (forms)) { - if (is_pair (car (forms))) { - result= - min_body (result, form_is_safe (sc, func, car (forms), - (at_end) && (is_null (cdr (forms))))); - if (result == unsafe_body) return (unsafe_body); - } - if (forms != body) /* checking for cycles -- this can happen (t101-1.scm) */ - { - if (follow) { - slow_body= cdr (slow_body); - if (forms == slow_body) return (unsafe_body); - } - follow= (!follow); - } - } - return ((is_null (forms)) ? result : unsafe_body); +static void op_closure_star_ka(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer func = opt1_lambda(code); + const s7_pointer par = car(closure_pars(func)); + sc->value = fx_call(sc, cddr(code)); + set_curlet(sc, inline_make_let_with_slot(sc, closure_let(func), (is_pair(par)) ? car(par) : par, sc->value)); + sc->code = T_Pair(closure_body(func)); } -static body_t -wrapped_body_is_safe (s7_scheme* sc, s7_pointer func, s7_pointer body, - bool at_end) { - body_t result; - begin_small_symbol_set (sc); - result= body_is_safe (sc, func, body, at_end); - end_small_symbol_set (sc); - return (result); -} - -static bool -tree_has_definer_or_binder (s7_scheme* sc, s7_pointer tree) { - for (s7_pointer p= tree; is_pair (p); p= cdr (p)) - if (tree_has_definer_or_binder (sc, car (p))) return (true); - return ((is_symbol (tree)) && (is_definer_or_binder (tree))); -} - -#define rec_test_clause(p) opt2_pair (p) -#define rec_done_clause(p) opt1_pair (p) -#define rec_call_clause(p) opt3_pair (p) -#define rec_set_test_clause(p, c) \ - set_opt2_pair ( \ - p, \ - T_Pair ( \ - c)) /* these check T_Lst in set_opt2_pair, but here we want pairs */ -#define rec_set_done_clause(p, c) set_opt1_pair (p, T_Pair (c)) -#define rec_set_call_clause(p, c) set_opt3_pair (p, T_Pair (c)) - -static bool -check_recur_if_and_cond (s7_scheme* sc, const s7_pointer name, int32_t pars, - s7_pointer args, s7_pointer body) { - const bool if_case= car (body) == sc->if_symbol; - const s7_pointer test= - (if_case) ? cadr (body) - : caadr (body); /* (if test...) or (cond ((test...))) */ - /* if ((S7_DEBUGGING) && ((pars < 1) || (pars > 3))) fprintf(stderr, "%s[%d]: - * pars: %d\n", __func__, __LINE__, pars); */ - if (is_fxable (sc, test)) /* pars prechecked to be 1 <= pars <= 3 */ - { - const s7_pointer true_p = (if_case) ? caddr (body) : cadr (cadr (body)); - const s7_pointer false_p = (if_case) ? cadddr (body) : cadr (caddr (body)); - int true_case= -1; - if ((!if_case) && - ((!is_proper_list_2 (sc, cadr (body))) || /* if !if_case, we want (cond - (a b) (else|#t c)) */ - (!is_proper_list_2 (sc, caddr (body))))) - return (false); - if ((is_fxable (sc, true_p)) && (is_proper_list_3 (sc, false_p)) && - (is_h_optimized (false_p))) /* the c-op -- true_p is done*/ - true_case= 0; - else if ((is_fxable (sc, false_p)) && (is_proper_list_3 (sc, true_p)) && - (is_h_optimized (true_p))) /* true_p is call */ - true_case= 1; - if (true_case >= 0) /* (if expr z (op (name x) (name y))) or (if expr (op - (name...)...) z */ - { - const bool true_quits= (true_case == 0); - const s7_pointer calls = true_quits ? cdr (false_p) : cdr (true_p); - const s7_pointer call1 = car (calls); - const s7_pointer call2 = cadr (calls); - bool call1_fxable; - - if ((((pars == 1) && (is_proper_list_2 (sc, call1)) && - (is_proper_list_2 (sc, call2))) || - ((pars == 2) && (is_proper_list_3 (sc, call1)) && - (is_proper_list_3 (sc, call2))) || - ((pars == 3) && (is_proper_list_4 (sc, call1)) && - (is_proper_list_4 (sc, call2)))) && - (car (call1) == name) && (car (call2) == name) && - (is_fxable (sc, cadr (call1))) && (is_fxable (sc, cadr (call2))) && - ((pars == 1) || ((is_fxable (sc, caddr (call1))) && - (is_fxable (sc, caddr (call2))))) && - ((pars <= 2) || ((is_fxable (sc, cadddr (call1))) && - (is_fxable (sc, cadddr (call2)))))) { - rec_set_test_clause (body, (if_case) ? cdr (body) : cadr (body)); - rec_set_done_clause ( - body, (true_quits) ? ((if_case) ? cddr (body) : cdadr (body)) - : ((if_case) ? cdddr (body) : cdaddr (body))); - rec_set_call_clause ( - body, - car ((true_quits) ? ((if_case) ? cdddr (body) : cdaddr (body)) - : ((if_case) ? cddr (body) : cdadr (body)))); - if (true_quits) set_true_is_done (body); - set_safe_optimize_op ( - body, (pars == 1) ? OP_RECUR_IF_A_A_opLA_LAq - : ((pars == 2) ? OP_RECUR_IF_A_A_opL2A_L2Aq - : OP_RECUR_IF_A_A_opL3A_L3Aq)); - fx_annotate_args (sc, cdr (call1), args); - fx_annotate_args (sc, cdr (call2), args); - fx_annotate_arg (sc, rec_test_clause (body), args); - fx_annotate_arg (sc, rec_done_clause (body), args); - fx_tree (sc, cdr (body), car (args), (pars >= 2) ? cadr (args) : NULL, - (pars == 3) ? caddr (args) : NULL, false); - return (true); - } +static void op_closure_star_a(s7_scheme *sc, s7_pointer code) +{ + s7_pointer par1; + const s7_pointer func = opt1_lambda(code); + sc->value = fx_call(sc, cdr(code)); + if ((is_symbol_and_keyword(sc->value)) && + (!sc->accept_all_keyword_arguments)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, keyword_value_missing_string, closure_name(sc, opt1_lambda(code)), sc->value, code)); + par1 = car(closure_pars(func)); + set_curlet(sc, make_let_with_slot(sc, closure_let(func), (is_pair(par1)) ? car(par1) : par1, sc->value)); + if (closure_star_arity_to_int(sc, func) > 1) + { + s7_pointer last_slot = let_slots(sc->curlet); + const s7_int id = let_id(sc->curlet); + for (s7_pointer p1 = cdr(closure_pars(func)); is_pair(p1); p1 = cdr(p1)) + { + s7_pointer par = car(p1); + if (is_pair(par)) + last_slot = add_slot_checked_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_checked_at_end(sc, id, last_slot, par, sc->F); + }} + sc->code = T_Pair(closure_body(func)); +} - call1_fxable= is_fxable (sc, call1); - if (((call1_fxable) && - (((pars == 1) && (is_proper_list_2 (sc, call2))) || - ((pars == 2) && (is_proper_list_3 (sc, call2))) || - ((pars == 3) && (is_proper_list_4 (sc, call2)))) && - (car (call2) == name) && (is_fxable (sc, cadr (call2))) && - ((pars == 1) || (is_fxable (sc, caddr (call2)))) && - ((pars <= 2) || (is_fxable (sc, cadddr (call2))))) || - ((is_fxable (sc, call2)) && - (((pars == 1) && (is_proper_list_2 (sc, call1))) || - ((pars == 2) && (is_proper_list_3 (sc, call1))) || - ((pars == 3) && (is_proper_list_4 (sc, call1)))) && - (car (call1) == name) && (is_fxable (sc, cadr (call1))) && - ((pars == 1) || (is_fxable (sc, caddr (call1)))) && - ((pars <= 2) || (is_fxable (sc, cadddr (call1)))))) { - rec_set_test_clause (body, (if_case) ? cdr (body) : cadr (body)); - rec_set_done_clause ( - body, (true_quits) ? ((if_case) ? cddr (body) : cdadr (body)) - : ((if_case) ? cdddr (body) : cdaddr (body))); - rec_set_call_clause ( - body, - car ((true_quits) ? ((if_case) ? cdddr (body) : cdaddr (body)) - : ((if_case) ? cddr (body) : cdadr (body)))); - rec_set_call_clause (rec_call_clause (body), - (call1_fxable) ? caddr (rec_call_clause (body)) - : cadr (rec_call_clause (body))); - if (call1_fxable) set_a_is_cadr (rec_call_clause (body)); - if (true_quits) set_true_is_done (body); - set_safe_optimize_op ( - body, (pars == 1) ? OP_RECUR_IF_A_A_opA_LAq - : ((pars == 2) ? OP_RECUR_IF_A_A_opA_L2Aq - : OP_RECUR_IF_A_A_opA_L3Aq)); - fx_annotate_arg (sc, (call1_fxable) ? calls : cdr (calls), - args); /* call1 == car(calls) */ - fx_annotate_args (sc, (call1_fxable) ? cdr (call2) : cdr (call1), args); - fx_annotate_arg (sc, rec_test_clause (body), args); - fx_annotate_arg (sc, rec_done_clause (body), args); - fx_tree (sc, cdr (body), car (args), (pars >= 2) ? cadr (args) : NULL, - (pars == 3) ? caddr (args) : NULL, false); - return (true); - } +static inline bool op_closure_star_na(s7_scheme *sc, s7_pointer code) +{ + /* check_stack_size(sc); */ + if (is_pair(cdr(code))) + { + sc->w = cdr(code); /* args aren't evaluated yet */ + sc->args = make_list(sc, opt3_arglen(cdr(code)), sc->unused); + for (s7_pointer 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->unused; } - } - return (false); + else sc->args = sc->nil; + sc->code = opt1_lambda(code); + set_curlet(sc, inline_make_let(sc, closure_let(sc->code))); + return(apply_unsafe_closure_star_1(sc)); +} + +static s7_pointer define1_caller(s7_scheme *sc) +{ + /* we can jump to op_define1, so this is not fool-proof */ + if (sc->cur_op == OP_DEFINE_CONSTANT) return(sc->define_constant_symbol); + if ((sc->cur_op == OP_DEFINE_STAR) || (sc->cur_op == OP_DEFINE_STAR_UNCHECKED)) return(sc->define_star_symbol); + return(sc->define_symbol); } -static bool -check_recur_if (s7_scheme* sc, const s7_pointer name, int32_t pars, - s7_pointer args, s7_pointer body) { - const s7_pointer test= cadr (body); - if (is_fxable (sc, test)) /* if_(A)... */ - { - const s7_pointer obody = cddr (body); - s7_pointer call = NULL; - const s7_pointer true_p = car (obody); /* if_a_(A)... */ - const s7_pointer false_p= cadr (obody); /* if_a_a_(A) */ - - if ((pars <= 3) && (is_fxable (sc, true_p)) && - (is_proper_list_4 (sc, false_p))) { - if (car (false_p) == sc->if_symbol) /* if_a_a_(if...) */ - { - const s7_pointer test2 = cadr (false_p); - const s7_pointer true2 = caddr (false_p); - const s7_pointer false2= cadddr (false_p); - if ((is_fxable (sc, test2)) && - (is_proper_list_3 (sc, false2)) && /* opa_l2aq or opl2a_l2aq */ - (is_h_optimized (false2))) /* the c-op */ - { - const s7_pointer la1= cadr (false2); - const s7_pointer la2= caddr (false2); - if ((is_fxable (sc, true2)) && - (((pars == 1) && (is_proper_list_2 (sc, la1)) && - (is_proper_list_2 (sc, la2))) || - ((pars == 2) && (is_proper_list_3 (sc, la1)) && - (is_proper_list_3 (sc, la2))) || - ((pars == 3) && (is_proper_list_4 (sc, la1)) && - (is_proper_list_4 (sc, la2)))) && - (car (la1) == name) && (car (la2) == name) && - (is_fxable (sc, cadr (la1))) && (is_fxable (sc, cadr (la2))) && - ((pars == 1) || ((is_fxable (sc, caddr (la1))) && - (is_fxable (sc, caddr (la2))))) && - ((pars <= 2) || ((is_fxable (sc, cadddr (la1))) && - (is_fxable (sc, cadddr (la2)))))) { - set_safe_optimize_op ( - body, (pars == 1) - ? OP_RECUR_IF_A_A_IF_A_A_opLA_LAq - : ((pars == 2) ? OP_RECUR_IF_A_A_IF_A_A_opL2A_L2Aq - : OP_RECUR_IF_A_A_IF_A_A_opL3A_L3Aq)); - 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), - (pars >= 2) ? cadr (args) : NULL, - (pars == 3) ? caddr (args) : NULL, false); - - rec_set_done_clause (body, cdr (false_p)); /* opt1 */ - rec_set_test_clause (body, cdr (body)); /* opt2 */ - rec_set_call_clause (body, false2); /* opt3 */ - rec_set_call_clause (false2, cdr (la2)); - - return (true); - } - if ((pars == 2) && (is_fxable (sc, cadr (false2))) && - (is_proper_list_3 (sc, true2)) && (car (true2) == name) && - (is_fxable (sc, cadr (true2))) && - (is_fxable (sc, caddr (true2))) && (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_IF_A_A_IF_A_L2A_opA_L2Aq); - 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_l2a_op(A).. */ - fx_annotate_args (sc, cdr (la2), - args); /* if_a_a_if_a_l2a_opa_l(AA)q */ - fx_tree (sc, cdr (body), car (args), cadr (args), NULL, false); - rec_set_call_clause (body, false2); - rec_set_call_clause (false2, la2); - rec_set_test_clause (body, cdr (body)); - rec_set_done_clause (body, cddr (body)); - rec_set_done_clause (cdr (body), cdr (cadddr (body))); - return (true); - } - } - } +static bool 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. But we want a + * warning if we got define (as opposed to the original define-constant). + */ + s7_pointer slot; + if (is_multiple_value(sc->value)) /* (define x (values 1 2)) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_5(sc, wrap_string(sc, "~A: more than one value: (~A ~A ~S)", 35), + define1_caller(sc), define1_caller(sc), sc->code, sc->value)); + if (is_constant_symbol(sc, sc->code)) /* (define pi 3) or (define (pi a) a) */ + { + slot = (is_slot(global_slot(sc->code))) ? global_slot(sc->code) : s7_t_slot(sc, sc->code); + /* local_slot can be free even if sc->code is immutable (local constant now defunct) */ + + if (!((is_slot(slot)) && + (type(sc->value) == type_unchecked(slot_value(slot))) && + (s7_is_equivalent(sc, sc->value, slot_value(slot))))) /* if value is unchanged, just ignore this (re)definition */ + syntax_error_with_caller_nr(sc, "~A: ~S is immutable", 19, define1_caller(sc), sc->code); /* can't use s7_is_equal because value might be NaN, etc */ - if (car (false_p) == sc->and_symbol) { - const s7_pointer a1= cadr (false_p); - const s7_pointer a2= caddr (false_p); - const s7_pointer 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_L2A_L2A); - 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_l2a_l(AA) */ - fx_tree (sc, cdr (body), car (args), cadr (args), NULL, false); - rec_set_call_clause (body, false_p); - return (true); - } - } + if ((sc->safety > no_safety) && /* (define-constant x 3) (define x 3)... */ + (sc->cur_op == OP_DEFINE)) + s7_warn(sc, 256, "(define %s %s), but %s is a constant\n", display(sc->code), display(sc->value), display(sc->code)); } - - /* this is ok, but no cond */ - 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)))) - call= false_p; /* if_a_a_call */ - 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)))) - call= true_p; /* if_a_call_a */ - - if ((call) && (pars == 1) && (is_pair (cdddr (call))) && - (is_null (cddddr (call)))) /* 3 args */ - { - const s7_pointer la1= cadr (call); - const s7_pointer la2= caddr (call); - const s7_pointer la3= cadddr (call); - 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)))) { - set_safe_optimize_op ( - body, OP_RECUR_IF_A_A_opLA_LA_LAq); /* these two need cond? */ - fx_annotate_arg (sc, cdr (la1), args); - } - else if (is_fxable (sc, la1)) { - set_safe_optimize_op (body, OP_RECUR_IF_A_A_opA_LA_LAq); - fx_annotate_arg (sc, cdr (call), args); - } - else return (false); - fx_annotate_arg (sc, cdr (body), args); /* test */ - if (call == cadddr (body)) { - set_true_is_done (body); - fx_annotate_arg (sc, cddr (body), args); /* result */ - } - else fx_annotate_arg (sc, cdddr (body), args); - fx_annotate_arg (sc, cdr (la2), args); /* call args 2 and 3 */ - fx_annotate_arg (sc, cdr (la3), args); - fx_tree (sc, cdr (body), car (args), NULL, NULL, false); - rec_set_call_clause (body, call); - rec_set_call_clause (call, la3); - rec_set_test_clause (body, cdr (body)); - rec_set_done_clause (body, (true_is_done (body)) ? cddr (body) - : cdddr (body)); - return (true); - } + else slot = s7_slot(sc, sc->code); + if ((is_slot(slot)) && (slot_has_setter(slot))) + { + sc->value = bind_symbol_with_setter(sc, OP_DEFINE_WITH_SETTER, sc->code, sc->value); + if (sc->value == sc->no_value) + return(true); /* goto apply, if all goes well, OP_DEFINE_WITH_SETTER will jump to DEFINE2 */ } - } /* if (is_fxable(sc, test)) at top */ - return (false); + return(false); /* fall through */ } -static bool -check_recur (s7_scheme* sc, s7_pointer name, int32_t pars, s7_pointer args, - s7_pointer body) { - /* if (proper_list_length(args) != pars) return(false); */ - if ((((car (body) == sc->if_symbol) && - (proper_list_length (body) == 4)) || /* (if a a opla) */ - ((car (body) == sc->cond_symbol) && (proper_list_length (body) == 3) && - ((caaddr (body) == sc->else_symbol) || - (caaddr (body) == sc->T)))) && /* (cond ((a a)) (else|#t opla)) */ - (pars > 0) && - (pars <= 3) && (check_recur_if_and_cond (sc, name, pars, args, body))) - return (true); - - if ((car (body) == sc->if_symbol) && (proper_list_length (body) == 4)) - return (check_recur_if (sc, name, pars, args, body)); - - if ((car (body) == sc->and_symbol) && (pars == 2) && - (proper_list_length (body) == 3) && - (proper_list_length (caddr (body)) == 4) && - (caaddr (body) == sc->or_symbol) && (is_fxable (sc, cadr (body)))) { - const s7_pointer or_p= caddr (body); - const s7_pointer la1 = caddr (or_p); - const s7_pointer 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_L2A_L2A); - 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); - rec_set_call_clause (body, or_p); - return (true); +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) + { + const s7_pointer body = closure_body(new_func); + const s7_pointer pars = closure_pars(new_func); + if ((is_pair(closure_pars(new_func))) && + (has_location(pars))) + { + let_set_file(new_let, pair_file_number(pars)); + let_set_line(new_let, pair_line_number(pars)); + } + else + if (has_location(body)) + { + let_set_file(new_let, pair_file_number(body)); + let_set_line(new_let, pair_line_number(body)); + } + else + { + s7_pointer p; + for (p = cdr(body); 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); } - } - - if (car (body) == sc->cond_symbol) { - const s7_pointer clause = cadr (body); - s7_pointer 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); - const s7_int 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->T) || - ((car (la_clause) == sc->else_symbol) && - (is_global (sc->else_symbol)))) && - (is_pair (cadr (la_clause)))) { - la_clause= cadr (la_clause); /* (c_op arg (recur par)) or (c_op (recur) - (recur)) or (op|l a l2a) */ - if (is_proper_list_2 (sc, cdr (la_clause))) { - if (is_h_optimized (la_clause)) { - if ((is_fxable (sc, cadr (la_clause))) && (len == 4) && - (pars == 2) && (is_proper_list_3 (sc, cadr (clause2))) && - (caadr (clause2) == name)) { - const s7_pointer la= caddr (la_clause); - if ((is_pair (la)) && (car (la) == name) && - (is_pair (cdr (la))) && (is_fxable (sc, cadr (la))) && - (is_pair (cddr (la))) && (is_fxable (sc, caddr (la))) && - (is_null (cdddr (la)))) { - const s7_pointer l2a= cadr (clause2); - if ((is_fxable (sc, cadr (l2a))) && /* args to first l2a */ - (is_fxable (sc, caddr (l2a)))) { - set_safe_optimize_op (body, - OP_RECUR_IF_A_A_IF_A_L2A_opA_L2Aq); - fx_annotate_arg (sc, clause2, args); - fx_annotate_args (sc, cdr (l2a), args); - rec_set_call_clause (body, la_clause); - rec_set_test_clause (body, cadr (body)); - rec_set_done_clause (body, cdadr (body)); - rec_set_done_clause (cdr (body), caddr (body)); - } - 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), cadr (args), NULL, false); - rec_set_call_clause (la_clause, la); - return (true); - } - } - else { - if ((len == 4) && (is_fxable (sc, cadr (clause2)))) { - const s7_pointer la1 = cadr (la_clause); - const s7_pointer la2 = caddr (la_clause); - bool happy= false; - /* following 9 lines are copied from check_recur_if 77378 - * (len=body length) -- combine? */ - if ((((pars == 1) && (is_proper_list_2 (sc, la1)) && - (is_proper_list_2 (sc, la2))) || - ((pars == 2) && (is_proper_list_3 (sc, la1)) && - (is_proper_list_3 (sc, la2))) || - ((pars == 3) && (is_proper_list_4 (sc, la1)) && - (is_proper_list_4 (sc, la2)))) && - (car (la1) == name) && (car (la2) == name) && - (is_fxable (sc, cadr (la1))) && - (is_fxable (sc, cadr (la2))) && - ((pars == 1) || ((is_fxable (sc, caddr (la1))) && - (is_fxable (sc, caddr (la2))))) && - ((pars <= 2) || ((is_fxable (sc, cadddr (la1))) && - (is_fxable (sc, cadddr (la2)))))) { - set_safe_optimize_op ( - body, - (pars == 1) - ? OP_RECUR_IF_A_A_IF_A_A_opLA_LAq - : ((pars == 2) ? OP_RECUR_IF_A_A_IF_A_A_opL2A_L2Aq - : OP_RECUR_IF_A_A_IF_A_A_opL3A_L3Aq)); - fx_annotate_args (sc, cdr (la1), args); - rec_set_done_clause (body, - caddr (body)); /* opt1 -- not "done" */ - rec_set_test_clause (body, cadr (body)); /* opt2 */ - happy= true; - } - else if ((pars == 2) && (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_A_opA_L2Aq); /* see - if_a_a_if_a_l2a_opa_l2a, - first l2a->a */ - fx_annotate_arg (sc, cdr (la_clause), args); - happy= true; - } - if (happy) { - 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), - (pars > 1) ? cadr (args) : NULL, - (pars == 3) ? caddr (args) : NULL, false); - rec_set_call_clause (body, la_clause); /* opt3 */ - rec_set_call_clause (la_clause, cdr (la2)); - return (true); - } - } - } - } - else { - if (clause2) { - const s7_pointer l2a= cadr (clause2); - if ((pars == 2) && (len == 4) && (is_proper_list_3 (sc, l2a)) && - (car (l2a) == name) && (is_fxable (sc, cadr (l2a))) && - (is_fxable (sc, caddr (l2a)))) { - const s7_pointer la1= cadr (la_clause); - const s7_pointer 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_L2A_LopA_L2Aq); - fx_annotate_args (sc, clause, args); - fx_annotate_arg (sc, clause2, args); - fx_annotate_args (sc, cdr (l2a), 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); - rec_set_call_clause (body, la_clause); - rec_set_call_clause (la_clause, cdr (la2)); - return (true); - } - } - } - } - } - } + else + { + let_set_file(new_let, 0); + let_set_line(new_let, 0); + clear_has_let_file(new_let); } - } - return (false); } -static bool -check_tc_when (s7_scheme* sc, const s7_pointer name, int32_t pars, - s7_pointer args, s7_pointer body) { - const s7_pointer test_expr= - cadr (body); /* car(body) == sc->when_symbol or sc->unless_symbol */ - 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)) && /* i.e. p is the last form in the when body */ - (is_pair (car (p))) && - (caar (p) == name)) { - const s7_pointer l2a= car (p); - set_opt3_pair (body, p); - if ((is_pair (cdr (l2a))) && (is_fxable (sc, cadr (l2a)))) { - if (is_null (cddr (l2a))) { - if (pars != 1) return (false); - set_safe_optimize_op (body, OP_TC_WHEN_LA); - } - else if (is_fxable (sc, caddr (l2a))) { - if (is_null (cdddr (l2a))) { - if (pars != 2) return (false); - set_safe_optimize_op (body, OP_TC_WHEN_L2A); - } - else if ((pars == 3) && (is_fxable (sc, cadddr (l2a))) && - (is_null (cddddr (l2a)))) - set_safe_optimize_op (body, OP_TC_WHEN_L3A); - else return (false); - } - if (car (body) == sc->unless_symbol) set_true_is_done (body); - fx_annotate_arg (sc, cdr (body), args); - for (s7_pointer p1= cddr (body); is_pair (cdr (p1)); p1= cdr (p1)) - fx_annotate_arg (sc, p1, args); - fx_annotate_args (sc, cdr (l2a), args); - fx_tree (sc, cdr (body), car (args), (pars > 1) ? cadr (args) : NULL, - (pars > 2) ? caddr (args) : NULL, false); - return (true); - } +static void op_define_with_setter(s7_scheme *sc) +{ + const s7_pointer code = sc->code; + if ((is_immutable(sc->curlet)) && + (is_let(sc->curlet))) /* not () */ + immutable_object_error_nr(sc, 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 */ + { + const s7_pointer new_func = sc->value; + s7_pointer 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)) && (sc->curlet != sc->rootlet)) + { + if (let_id(sc->curlet) <= symbol_id(code)) /* we're adding a later-bound symbol to an old let (?) */ + { /* was < 16-Aug-22: (let ((a 3)) (define (a) 4) (curlet)) */ + s7_pointer slot; + sc->let_number++; /* dummy let, force symbol lookup */ + for (slot = let_slots(sc->curlet); is_not_slot_end(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == code) + { + if (is_immutable_slot(slot)) + syntax_error_nr(sc, "define ~S, but it is immutable", 30, code); /* someday give the location of the immutable definition or setting */ + 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_unchecked(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_slot(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 */ + syntax_error_nr(sc, "define ~S, but it is immutable", 30, old_symbol); + } + else s7_make_slot(sc, sc->curlet, code, new_func); + } + sc->value = new_func; /* 25-Jul-14 so define returns the value not the name */ } - } - return (false); + else + { + const s7_pointer slot = symbol_to_local_slot(sc, code, sc->curlet); + if (is_slot(slot)) + { + if (is_immutable_slot(slot)) + { + s7_pointer old_value = slot_value(slot); + if ((type(old_value) != type(sc->value)) || + (!s7_is_equivalent(sc, old_value, sc->value))) /* if value is unchanged, just ignore this (re)definition */ + syntax_error_nr(sc, "define ~S, but it is immutable", 30, code); + } + else + { + slot_set_value_with_hook(slot, 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); + }} } -static bool -check_tc_case (s7_scheme* sc, s7_pointer name, s7_pointer arg_names, - s7_pointer body) { - /* pars == 1|2|3, opt1_any(clause) = key, has_tc(arg) = is tc call, - * opt2_any(clause) = result: has_tc(la arg) has_fx(val) or ((...)...) */ - /* it might be useful to add int keys and no-else-clause */ - s7_pointer clauses; - s7_int len; - const s7_int pars = proper_list_length (arg_names); - 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))) /* one key */ - { - if (!is_simple (caar (clause))) /* || (is_t_integer(caar(clause))))) need - eqv here for ints */ - return (false); - set_opt1_any (clauses, caar (clause)); /* save clause key as opt1_any */ - } - 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, arg_names); - set_opt2_any (clauses, result); /* fx'd result expr is opt2_any */ - } - else { - const s7_int local_pars= proper_list_length (cdar (result)); - if ((caar (result) == name) && - (((pars == 1) && (local_pars == 1)) || - ((pars == 2) && (local_pars == 2)) || - ((pars == 3) && (local_pars == 3))) && - (is_fxable (sc, cadar (result))) && - ((pars == 1) || (is_fxable (sc, caddar (result)))) && - ((pars <= 2) || (is_fxable (sc, car (cdddar (result)))))) { - set_has_tc (car (result)); - set_opt2_any (clauses, car (result)); - fx_annotate_args (sc, cdar (result), arg_names); - } - 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, (pars == 1) - ? OP_TC_CASE_LA - : ((pars == 2) ? OP_TC_CASE_L2A : OP_TC_CASE_L3A)); - set_opt3_arglen (cdr (body), len); - fx_annotate_arg (sc, cdr (body), arg_names); - fx_tree (sc, cdr (body), car (arg_names), - (pars == 1) ? NULL : cadr (arg_names), - (pars <= 2) ? NULL : caddr (arg_names), - false); /* check_tc limits pars to <= 3 */ - if (results_fxable) set_optimized (body); - return (results_fxable); -} - -static bool -check_tc_cond_n (s7_scheme* sc, const s7_pointer name, int32_t pars, - s7_pointer args, s7_pointer cond_form) { - bool all_fxable= true; - for (s7_pointer p= cdr (cond_form); is_pair (p); p= cdr (p)) { - const s7_pointer clause= car (p); - if ((is_proper_list_2 (sc, clause)) && - (is_fxable (sc, car (clause)))) /* test is ok */ + +/* -------------------------------- eval -------------------------------- */ +static void check_for_cyclic_code(s7_scheme *sc, s7_pointer code) +{ + if (tree_is_cyclic(sc, code)) { - s7_pointer result; - if (((!is_pair (cdr (p))) && (car (clause) != sc->T) && - ((car (clause) != sc->else_symbol) || - (!is_global (sc->else_symbol)))) || - ((tree_count (sc, name, clause, 0) == 1) && (name != caadr (clause)))) - return (false); - result= cadr (clause); - if ((is_pair (result)) && - (car (result) == name)) /* result is recursive call */ - { - s7_int i= 0; - for (s7_pointer arg= cdr (result); is_pair (arg); i++, arg= cdr (arg)) - if (!is_fxable (sc, car (arg))) return (false); - if (i != pars) return (false); - } + /* sc->stack_resize_trigger = (s7_pointer *)(sc->stack_start + (sc->stack_size - ((STACK_RESIZE_TRIGGER) / 2))); */ + syntax_error_nr(sc, "attempt to evaluate a circular list: ~A", 39, code); } - else return (false); - } - set_optimize_op (cond_form, OP_TC_COND_N); /* body=cond_form?? */ - set_opt3_arglen (cdr (cond_form), pars); /* same */ - for (s7_pointer p= cdr (cond_form); is_pair (p); p= cdr (p)) { - const s7_pointer clause= car (p); - const s7_pointer result= cadr (clause); - fx_annotate_arg (sc, clause, args); - if ((is_pair (result)) && - (car (result) == name)) /* pars = args checked above */ - { - 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; - if (pars > 0) - fx_tree (sc, clause, car (args), (pars > 1) ? cadr (args) : NULL, - (pars > 2) ? caddr (args) : NULL, pars > 3); - } - if (all_fxable) set_optimized (cond_form); - return (all_fxable); -} - -static bool -check_tc_cond (s7_scheme* sc, s7_pointer name, int32_t pars, s7_pointer args, - s7_pointer body) { - s7_pointer p = cdr (body); - const s7_pointer clause1 = car (p); - const s7_int names = tree_count (sc, name, body, 0); - const s7_int body_len= proper_list_length (body); - - if ((!is_proper_list_2 (sc, clause1)) || - (!is_fxable (sc, car (clause1)))) /* cond_a... */ - return (false); - - p= cdr (p); - if ((pars < 4) && (names == 1) && (body_len == 3)) { - if (((caar (p) == sc->T) || - ((caar (p) == sc->else_symbol) && - (is_global ( - sc->else_symbol))))) { /* body len=3, (cond clause1 else */ - const s7_pointer else_clause= cdar (p); - if (tree_count (sc, name, body, 0) != 1) return (false); - if (is_proper_list_1 (sc, else_clause)) { - 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))) && - (((pars == 1) && (is_null (cddr (la)))) || - ((pars == 2) && (is_pair (cddr (la))) && - (is_null (cdddr (la))) && (is_fxable (sc, caddr (la)))) || - ((pars == 3) && (is_pair (cddr (la))) && - (is_pair (cdddr (la))) && (is_null (cdr (cdddr (la)))) && - (is_fxable (sc, caddr (la))) && - (is_fxable (sc, cadddr (la)))))) { - const bool zs_fxable= is_fxable (sc, cadr (clause1)); - set_optimize_op (body, (pars == 1) - ? OP_TC_IF_A_Z_LA - : ((pars == 2) ? OP_TC_IF_A_Z_L2A - : OP_TC_IF_A_Z_L3A)); - if (zs_fxable) fx_annotate_arg (sc, cdr (clause1), args); - fx_annotate_args (sc, cdr (la), args); - fx_tree (sc, cdr (body), car (args), - (pars < 2) ? NULL : cadr (args), - (pars < 3) ? NULL : caddr (args), false); - if (zs_fxable) set_optimized (body); - rec_set_test_clause (body, cadr (body)); - rec_set_done_clause (body, cdadr (body)); - rec_set_call_clause (body, cdadr (caddr (body))); - set_true_is_done (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))) && - (((pars == 1) && (is_null (cddr (la)))) || - ((pars == 2) && (is_pair (cddr (la))) && - (is_null (cdddr (la))) && (is_fxable (sc, caddr (la)))) || - ((pars == 3) && (is_pair (cddr (la))) && - (is_pair (cdddr (la))) && (is_null (cdr (cdddr (la)))) && - (is_fxable (sc, caddr (la))) && - (is_fxable (sc, cadddr (la)))))) { - const bool zs_fxable= is_fxable (sc, car (else_clause)); - set_optimize_op (body, (pars == 1) - ? OP_TC_IF_A_Z_LA - : ((pars == 2) ? OP_TC_IF_A_Z_L2A - : OP_TC_IF_A_Z_L3A)); - if (zs_fxable) fx_annotate_arg (sc, else_clause, args); - fx_annotate_args (sc, cdr (la), args); - fx_tree (sc, cdr (body), car (args), - (pars < 2) ? NULL : cadr (args), - (pars < 3) ? NULL : caddr (args), false); - if (zs_fxable) set_optimized (body); - rec_set_test_clause (body, cadr (body)); - rec_set_done_clause (body, cdaddr (body)); - rec_set_call_clause (body, cdadr (cadr (body))); - return (zs_fxable); - } - } - } - } - return (false); - } - } /* end body len=3, (cond clause1 else */ - - if ((pars < 4) && (body_len == 4)) { - const s7_pointer clause2= car (p); - if ((is_proper_list_2 (sc, clause2)) && (is_fxable (sc, car (clause2)))) { - const s7_pointer else_p = cdr (p); - const s7_pointer else_clause= car (else_p); - - if ((is_proper_list_2 (sc, else_clause)) && - ((car (else_clause) == sc->T) || - ((car (else_clause) == sc->else_symbol) && - (is_global (sc->else_symbol))))) { - bool zs_fxable= true; - if ((pars == 2) && /* ...l2a_l2a 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_L2A_L2A); - 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)); /* done_clause?? */ - if (zs_fxable) set_optimized (body); - return (zs_fxable); - } + resize_stack(sc); /* we've already checked that resize_stack is needed */ +} - if ((names == 1) && /* needed to filter out cond_a_a_a_l2a_opa_l2a */ - - (((is_pair (cadr (else_clause))) && (caadr (else_clause) == name) && - (is_pair (cdadr (else_clause))) && - (is_fxable (sc, cadadr (else_clause))) && - (((pars == 1) && (is_null (cddadr (else_clause)))) || - ((pars == 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))) && - (((pars == 1) && (is_null (cddadr (clause2)))) || - ((pars == 2) && (is_pair (cddadr (clause2))) && - (is_fxable (sc, caddadr (clause2))) && - (is_null (cdddr (cadr (clause2))))))))) { - s7_pointer test2 = clause2; - s7_pointer la_test= else_clause; - if (pars == 1) { - if ((is_pair (cadr (else_clause))) && (caadr (else_clause) == name)) - set_optimize_op (body, OP_TC_IF_A_Z_IF_A_Z_LA); - else { - set_optimize_op (body, OP_TC_IF_A_Z_IF_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_IF_A_Z_IF_A_Z_L2A); - } - else { - set_optimize_op (body, OP_TC_IF_A_Z_IF_A_L2A_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), (pars == 2) ? cadr (args) : NULL, - NULL, false); - if (zs_fxable) set_optimized (body); - return (zs_fxable); - } - } - } - } - return (check_tc_cond_n (sc, name, pars, args, body)); -} - -static bool -check_tc_let (s7_scheme* sc, const s7_pointer name, int32_t pars, - s7_pointer args, s7_pointer body) { - const s7_pointer let_body= caddr ( - body); /* body: (let ((x (- y 1))) (if (<= x 0) 0 (f1 (- x 1)))) etc */ - if (((pars == 2) && ((car (let_body) == sc->if_symbol) || - (car (let_body) == sc->when_symbol) || - (car (let_body) == sc->unless_symbol))) || - ((pars == 1) && (car (let_body) == sc->if_symbol))) { - const 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)))) { - const s7_pointer l2a= cadddr (let_body); - if ((is_pair (l2a)) && /* else caddr is l2a and cadddr is z */ - (car (l2a) == name) && - (((pars == 1) && (is_proper_list_2 (sc, l2a))) || - ((pars == 2) && (is_proper_list_3 (sc, l2a)) && - (is_safe_fxable (sc, caddr (l2a))))) && - (is_fxable (sc, cadr (l2a)))) { - bool z_fxable; - set_optimize_op (body, (pars == 1) ? OP_TC_LET_IF_A_Z_LA - : OP_TC_LET_IF_A_Z_L2A); - fx_annotate_arg (sc, cdaadr (body), - args); /* let var binding, caadr: (x (- y 1)) etc */ - fx_tree (sc, cdaadr (body), car (args), - (pars == 1) ? NULL : cadr (args), NULL, - false); /* these are references to l2a args, applied to the - let var binding */ - fx_annotate_arg (sc, cdr (let_body), args); /* test_expr */ - fx_annotate_args (sc, cdr (l2a), args); - z_fxable= is_fxable (sc, caddr (let_body)); - if (z_fxable) fx_annotate_arg (sc, cddr (let_body), args); - fx_tree (sc, cdr (let_body), car (caadr (body)), NULL, NULL, false); - fx_tree_outer (sc, cdr (let_body), car (args), - (pars == 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)) { - const s7_pointer l2a= car (p); - if ((is_fxable (sc, cadr (l2a))) && - (is_safe_fxable (sc, caddr (l2a)))) { - set_optimize_op (body, OP_TC_LET_WHEN_L2A); - fx_annotate_arg (sc, cdaadr (body), args); /* outer var */ - fx_annotate_arg (sc, cdr (let_body), args); /* test */ - for (s7_pointer p1= cddr (let_body); is_pair (cdr (p1)); - p1 = cdr (p1)) - fx_annotate_arg (sc, p1, args); - fx_annotate_args (sc, cdr (l2a), 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) /* pars=#loop pars, args=names thereof (arglist) */ - { - s7_pointer var_name; - bool all_fxable= true; - for (s7_pointer p= cdr (let_body); is_pair (p); p= cdr (p)) { - const 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->T) && - ((car (clause) != sc->else_symbol) || - (!is_global (sc->else_symbol)))) - return (false); - result= cadr (clause); - if ((is_pair (result)) && - (car (result) == name)) /* result is recursive call */ - { - s7_int i= 0; - for (s7_pointer arg= cdr (result); is_pair (arg); i++, arg= cdr (arg)) - if (!is_fxable (sc, car (arg))) return (false); - if (i != pars) return (false); - } - } - else return (false); - } - /* cond form looks ok, body here is the let form */ - set_optimize_op (body, OP_TC_LET_COND); - set_opt3_arglen (cdr (body), pars); - fx_annotate_arg (sc, cdaadr (body), args); /* let var */ - if (pars > 0) - fx_tree (sc, cdaadr (body), car (args), (pars > 1) ? cadr (args) : NULL, - (pars > 2) ? caddr (args) : NULL, pars > 3); - var_name= caaadr (body); - for (s7_pointer p= cdr (let_body); is_pair (p); p= cdr (p)) { - const s7_pointer clause= car (p); - const s7_pointer 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 (pars > 0) - fx_tree_outer (sc, clause, car (args), (pars > 1) ? cadr (args) : NULL, - (pars > 2) ? caddr (args) : NULL, pars > 3); - } - if (all_fxable) set_optimized (body); - return (all_fxable); - } - return (false); +static void op_thunk(s7_scheme *sc) /* sc->code: (generate-leaves) */ +{ + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, inline_make_let(sc, closure_let(func))); + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin(sc); } -/* tc lets can be let* or let+pars that don't refer to previous names, and there - * are more cond/if choices */ +static void op_thunk_o(s7_scheme *sc) /* sc->code: (h) */ +{ + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, inline_make_let(sc, closure_let(func))); + sc->code = car(closure_body(func)); +} -static bool -check_tc (s7_scheme* sc, s7_pointer name, int32_t pars, s7_pointer args, - s7_pointer body) { - if (!is_pair (body)) return (false); +static void op_safe_thunk(s7_scheme *sc) /* no let needed, sc->code: (fc) */ +{ + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, closure_let(func)); + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin_unchecked(sc); +} - if (((pars == 1) || (pars == 2) || (pars == 3)) && - ((car (body) == sc->and_symbol) || (car (body) == sc->or_symbol)) && - (is_pair (cdr (body))) && (is_fxable (sc, cadr (body))) && - (is_pair (cddr (body)))) { - const 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)))) { - const s7_int len= proper_list_length (orx); - if ((len == 3) || - ((pars == 1) && (len == 4) && (tree_count (sc, name, orx, 0) == 1) && - (is_fxable (sc, - caddr (orx))))) /* the ...or|and_a_a_la case below? */ - { - const s7_pointer tc= (len == 3) ? caddr (orx) : cadddr (orx); - if ((is_pair (tc)) && (car (tc) == name) && (is_pair (cdr (tc))) && - (is_fxable (sc, cadr (tc))) && - (((pars == 1) && (is_null (cddr (tc)))) || - ((pars == 2) && (is_pair (cddr (tc))) && (is_null (cdddr (tc))) && - (is_safe_fxable (sc, caddr (tc)))) || - ((pars == 3) && (is_pair (cddr (tc))) && (is_pair (cdddr (tc))) && - (is_null (cddddr (tc))) && (is_safe_fxable (sc, caddr (tc))) && - (is_safe_fxable (sc, cadddr (tc)))))) { - if (pars == 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 if (pars == 2) - set_safe_optimize_op (body, (car (body) == sc->and_symbol) - ? OP_TC_AND_A_OR_A_L2A - : OP_TC_OR_A_AND_A_L2A); - else - set_safe_optimize_op (body, (car (body) == sc->and_symbol) - ? OP_TC_AND_A_OR_A_L3A - : OP_TC_OR_A_AND_A_L3A); - 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), (pars == 1) ? NULL : cadr (args), - (pars == 3) ? caddr (args) : NULL, false); - return (true); - } - } - } - else { - if ((pars == 1) && (car (body) == sc->or_symbol) && - (is_fxable (sc, orx)) && (is_pair (cdddr (body))) && - (is_pair (cadddr (body)))) { - const 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)))) { - const 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 ((pars == 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)) { - const bool z_first= - ((is_pair (cadddr (orx))) && (car (cadddr (orx)) == name)); - const s7_pointer 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; - const s7_pointer 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); - } - } - } - } - } +static s7_pointer op_safe_thunk_a(s7_scheme *sc, s7_pointer code) /* sc->code: (get-ds) */ +{ + const s7_pointer func = opt1_lambda(code); + set_curlet(sc, closure_let(func)); + return(fx_call(sc, closure_body(func))); +} - if ((pars == 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)))) { - const s7_pointer 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)))) { - const 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); - } - } - } +static void op_thunk_any(s7_scheme *sc) /* sc->code: (make-hook) */ +{ + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, make_let_with_slot(sc, closure_let(func), closure_pars(func), sc->nil)); + sc->code = closure_body(func); +} - if (((pars >= 1) && (pars <= 3)) && (car (body) == sc->if_symbol) && - (proper_list_length (body) == 4)) { - const s7_pointer test= cadr (body); - if (is_fxable (sc, test)) { - const s7_pointer true_p = caddr (body); - const s7_pointer false_p = cadddr (body); - const s7_int true_len = proper_list_length (true_p); - const s7_int false_len= proper_list_length (false_p); - - fx_annotate_arg (sc, cdr (body), args); - - if (pars == 1) { - if ((false_len == 2) && (car (false_p) == name) && - (is_fxable (sc, true_p)) && (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 */ - rec_set_test_clause (body, cdr (body)); - rec_set_done_clause (body, cddr (body)); - rec_set_call_clause (body, cdar (cdddr (body))); - set_true_is_done (body); - 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, false_p)) && (is_fxable (sc, cadr (true_p)))) { - set_optimize_op (body, OP_TC_IF_A_Z_LA); - fx_annotate_arg (sc, cdr (true_p), args); /* arg */ - rec_set_test_clause (body, cdr (body)); - rec_set_done_clause (body, cdddr (body)); - rec_set_call_clause (body, cdar (cddr (body))); - fx_annotate_arg (sc, cdddr (body), args); /* result */ - fx_tree (sc, cdr (body), car (args), NULL, NULL, false); - set_optimized (body); - return (true); - } - } +static void op_safe_thunk_any(s7_scheme *sc) /* sc->code: (m3) */ +{ + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, closure_let(func)); + slot_set_value(let_slots(sc->curlet), sc->nil); + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin_unchecked(sc); +} - if (pars == 2) { - if ((false_len == 3) && (car (false_p) == name) && - (is_fxable (sc, cadr (false_p))) && (is_fxable (sc, true_p)) && - (is_safe_fxable (sc, caddr (false_p)))) { - set_optimize_op (body, OP_TC_IF_A_Z_L2A); - fx_annotate_args (sc, cdr (false_p), args); - rec_set_test_clause (body, cdr (body)); - rec_set_done_clause (body, - cddr (body)); /* body == code in op, if_true */ - rec_set_call_clause (body, cdar (cdddr (body))); /* la */ - set_true_is_done (body); - 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_fxable (sc, false_p)) && - (is_safe_fxable (sc, caddr (true_p)))) { - set_optimize_op (body, OP_TC_IF_A_Z_L2A); - fx_annotate_args (sc, cdr (true_p), args); - rec_set_test_clause (body, cdr (body)); - rec_set_done_clause (body, cdddr (body)); - rec_set_call_clause (body, cdar (cddr (body))); - fx_annotate_arg (sc, cdddr (body), args); - fx_tree (sc, cdr (body), car (args), cadr (args), NULL, false); - set_optimized (body); - return (true); - } - } +static void op_closure_s(s7_scheme *sc) /* sc->code: (func hook) */ +{ + const s7_pointer func = opt1_lambda(sc->code); + check_stack_size(sc); + set_curlet(sc, inline_make_let_with_slot(sc, closure_let(func), car(closure_pars(func)), lookup(sc, opt2_sym(sc->code)))); + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin_unchecked(sc); +} - if (pars == 3) { - if ((false_len == 4) && (car (false_p) == name) && - (is_fxable (sc, true_p)) && (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); - rec_set_test_clause (body, cdr (body)); - rec_set_done_clause (body, cddr (body)); - rec_set_call_clause (body, cdar (cdddr (body))); - set_true_is_done (body); - 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, false_p)) && (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_Z_L3A); - fx_annotate_args (sc, cdr (true_p), args); - rec_set_test_clause (body, cdr (body)); - rec_set_done_clause (body, cdddr (body)); - rec_set_call_clause (body, cdar (cddr (body))); - fx_annotate_arg (sc, cdddr (body), args); - fx_tree (sc, cdr (body), car (args), cadr (args), caddr (args), - false); - set_optimized (body); - return (true); - } - } +static inline void op_closure_s_o(s7_scheme *sc) /* sc->code: (recompose-1 n) */ +{ + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, inline_make_let_with_slot(sc, closure_let(func), car(closure_pars(func)), lookup(sc, opt2_sym(sc->code)))); + sc->code = car(closure_body(func)); +} - if ((false_len == 4) && (car (false_p) == sc->if_symbol)) { - const s7_pointer in_test = cadr (false_p); - const s7_pointer in_true = caddr (false_p); - const s7_pointer in_false= cadddr (false_p); - if (is_fxable (sc, in_test)) { - s7_pointer la= NULL, z= NULL; - 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) && ((pars == 3) || (!s7_tree_memq (sc, name, car (z))))) { - if (((pars == 1) && (is_null (cddr (la)))) || - ((pars == 2) && (is_pair (cddr (la))) && - (is_null (cdddr (la))) && (is_safe_fxable (sc, caddr (la)))) || - ((pars == 3) && - ((is_proper_list_4 (sc, in_false)) || - (is_proper_list_4 (sc, in_true))) && - (is_safe_fxable (sc, caddr (la))) && - (is_safe_fxable (sc, cadddr (la))) && - (((is_proper_list_4 (sc, in_true)) && - (car (in_true) == name) && - (is_fxable (sc, cadr (in_true))) && - (is_safe_fxable (sc, caddr (in_true))) && - (is_safe_fxable (sc, cadddr (in_true)))) || - (!s7_tree_memq (sc, name, in_true))))) { - bool zs_fxable= true; - if (pars == 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 (pars == 2) - set_optimize_op (body, (la == in_false) - ? OP_TC_IF_A_Z_IF_A_Z_L2A - : OP_TC_IF_A_Z_IF_A_L2A_Z); - else if (la == in_false) - set_optimize_op ( - body, ((is_pair (in_true)) && (car (in_true) == name)) - ? OP_TC_IF_A_Z_IF_A_L3A_L3A - : OP_TC_IF_A_Z_IF_A_Z_L3A); - else set_optimize_op (body, OP_TC_IF_A_Z_IF_A_L3A_Z); - - 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 (pars == 3) { - if (optimize_op (body) != OP_TC_IF_A_Z_IF_A_L3A_Z) - fx_annotate_args (sc, cdr (in_false), args); - if (optimize_op (body) != OP_TC_IF_A_Z_IF_A_Z_L3A) - fx_annotate_args (sc, cdr (in_true), args); - } - if (optimize_op (body) != OP_TC_IF_A_Z_IF_A_L3A_L3A) { - 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), - (pars > 1) ? cadr (args) : NULL, - (pars > 2) ? caddr (args) : NULL, false); - if (zs_fxable) set_optimized (body); - return (zs_fxable); - } - } - } - } +static void op_safe_closure_s(s7_scheme *sc) /* sc->code: (close1 x) */ +{ + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, update_let_with_slot(sc, closure_let(func), lookup(sc, opt2_sym(sc->code)))); + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin_unchecked(sc); +} - if ((pars == 2) && (false_len == 3) && - (car (false_p) == sc->let_star_symbol)) { - const s7_pointer letv= cadr (false_p); - s7_pointer letb; - if (!is_pair (letv)) return (false); - letb= caddr (false_p); - for (s7_pointer var= letv; is_pair (var); var= cdr (var)) - if (!is_fxable (sc, cadar (var))) return (false); - if ((is_proper_list_4 (sc, letb)) && (car (letb) == sc->if_symbol) && - (is_fxable (sc, cadr (letb)))) { - const s7_pointer l2a= cadddr (letb); - if ((car (l2a) == name) && (is_proper_list_3 (sc, l2a)) && - (is_fxable (sc, cadr (l2a))) && - (is_safe_fxable (sc, caddr (l2a)))) { - bool zs_fxable; - set_safe_optimize_op (body, OP_TC_IF_A_Z_LET_IF_A_Z_L2A); - fx_annotate_args (sc, cdr (l2a), args); - zs_fxable= is_fxable (sc, caddr (letb)); - fx_annotate_args (sc, cdr (letb), args); - for (s7_pointer var= letv; is_pair (var); var= cdr (var)) - fx_annotate_arg (sc, cdar (var), 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 (l2a), 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); - } - } - } - } - } +static void op_safe_closure_s_o(s7_scheme *sc) /* sc->code: (op2 lst) */ +{ + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, update_let_with_slot(sc, closure_let(func), lookup(sc, opt2_sym(sc->code)))); + sc->code = car(closure_body(func)); +} - /* 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, pars, args, body)); +static void op_safe_closure_p(s7_scheme *sc) /* sc->code: (close1 ((lambda () (cs11 x)))) */ +{ + check_stack_size(sc); + push_stack_no_args(sc, OP_SAFE_CLOSURE_P_1, opt1_lambda(sc->code)); + sc->code = cadr(sc->code); +} - /* cond */ - if (car (body) == sc->cond_symbol) - return (check_tc_cond (sc, name, pars, args, body)); +static void op_safe_closure_p_1(s7_scheme *sc) /* sc->code: close1 */ +{ + set_curlet(sc, update_let_with_slot(sc, closure_let(sc->code), sc->value)); + sc->code = T_Pair(closure_body(sc->code)); +} - /* case */ - if (((pars >= 1) && (pars <= 3)) && (car (body) == sc->case_symbol) && - (is_pair (cdr (body))) && (is_fxable (sc, cadr (body)))) - return (check_tc_case (sc, name, args, body)); +static void op_safe_closure_p_a(s7_scheme *sc) /* sc->code: (char->digit (str j)) */ +{ + check_stack_size(sc); + push_stack_no_args_direct(sc, OP_SAFE_CLOSURE_P_A_1); + sc->code = cadr(sc->code); +} - /* when */ - if ((pars >= 1) && (pars <= 3) && - ((car (body) == sc->when_symbol) || (car (body) == sc->unless_symbol)) && - (is_fxable (sc, cadr (body)))) - return (check_tc_when (sc, name, pars, args, body)); - return (false); -} - -static void -mark_fx_treeable (s7_scheme* sc, - s7_pointer body) { /* it is possible to encounter a cyclic - body here -- need s7test example! */ - if (is_pair ( - body)) /* slightly faster than the other way of writing this, checking - treeable (to catch cyclic trees) slows us down by a lot! */ - { - if ((S7_DEBUGGING) && (s7_list_length (sc, body) == 0)) { - fprintf (stderr, "body: %s\n", display (body)); - abort (); - } - if (is_pair (car (body))) { - set_is_fx_treeable (body); - mark_fx_treeable (sc, car (body)); - } - mark_fx_treeable (sc, cdr (body)); - } +static void op_safe_closure_p_a_1(s7_scheme *sc) /* sc->code: (identity (if (= state 0) (call/cc... */ +{ + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, update_let_with_slot(sc, closure_let(func), sc->value)); + sc->value = fx_call(sc, closure_body(func)); } -static void -optimize_lambda (s7_scheme* sc, bool unstarred_lambda, s7_pointer func, - s7_pointer pars, - s7_pointer body) { /* func is either sc->unused or a symbol */ - const s7_int len= s7_list_length (sc, body); - if (SHOW_EVAL_OPS) - fprintf (stderr, " %s[%d]: %s %s %s\n", __func__, __LINE__, display (func), - display (pars), display_truncated (body)); - if (len < 0) /* (define (hi) 1 . 2) */ - error_nr ( - 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_pars; - - begin_small_symbol_set (sc); - for (p= pars; is_pair (p); p= cdr (p)) - add_symbol_to_small_symbol_set (sc, (is_symbol (car (p))) ? car (p) - : caar (p)); - if (!is_null (p)) add_symbol_to_small_symbol_set (sc, p); - sc->got_tc = false; - sc->not_tc = false; - sc->got_rec = false; - sc->rec_tc_args= -1; - /* I think cyclic code has already been caught in check_lambda et al */ - result= ((is_symbol (func)) && (symbol_is_in_small_symbol_set (sc, func))) - ? unsafe_body - : body_is_safe (sc, func, body, true); /* (define (f f)...) */ - end_small_symbol_set (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 (s7_pointer p1= pars; is_pair (p1); p1= cdr (p1)) { - const s7_pointer par= car (p1); - if ((is_pair (par)) && /* has default value */ - (is_pair (cdr (par))) && /* is not a ridiculous improper list */ - ((is_symbol (cadr (par))) || /* if default value might involve - eval in any way, it isn't simple */ - (is_unquoted_pair (sc, cadr (par))))) /* pair as default only ok - if it is (quote ...) */ - { - happy= false; - if ((result > unsafe_body) && - (tree_has_definer_or_binder ( - sc, cadr (par)))) /* 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_big_symbol_set (sc, func)); - sc->temp1= lst; - } - else lst= sc->nil; - - if (optimize (sc, body, 1, - cleared_pars= collect_parameters (sc, pars, lst)) == opt_oops) - clear_all_optimizations (sc, body); - else if (result >= recur_body) { - int32_t npars; - mark_fx_treeable (sc, body); - if ((!unstarred_lambda) && (is_pair (cleared_pars))) { - cleared_pars= proper_list_reverse_in_place (sc, cleared_pars); - /* we need pars in decl order below, else (e.g.) fx_o out-of-date - * because pars does not represent lambda pars (as in its let) */ - if (car (cleared_pars) == func) cleared_pars= cdr (cleared_pars); - } - else cleared_pars= pars; - for (npars= 0, p= pars; - (is_pair (p)) && (!is_symbol_and_keyword (car (p))); - npars++, p= cdr (p)) - ; /* npars should not include a dotted (rest) arg */ - if ((is_null (p)) && (npars > 0)) { - fx_annotate_args ( - sc, body, - cleared_pars); /* 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! */ - car (cleared_pars), (npars > 1) ? cadr (cleared_pars) : NULL, - (npars > 2) ? caddr (cleared_pars) : NULL, npars > 3); - } - if (((unstarred_lambda) || - ((is_null (p)) && (npars == sc->rec_tc_args))) && - (is_null (cdr (body)))) { /* (if #t|#f...) happens only rarely */ - if (sc->got_tc) { - if (check_tc (sc, func, npars, cleared_pars, 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, npars, cleared_pars, car (body)))) - set_safe_closure_body (body); - } - } - clear_big_symbol_set (sc); - if (is_symbol (func)) sc->temp1= sc->unused; - sc->got_tc = false; - sc->not_tc = false; - sc->got_rec= false; - } +static Inline void inline_op_closure_a(s7_scheme *sc) /* used twice in eval, sc->code: (recompose-1 (- n 1)) */ +{ + const s7_pointer func = opt1_lambda(sc->code); + sc->value = fx_call(sc, cdr(sc->code)); + set_curlet(sc, inline_make_let_with_slot(sc, closure_let(func), car(closure_pars(func)), sc->value)); + sc->code = T_Pair(closure_body(func)); } -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; +static void op_safe_closure_3s(s7_scheme *sc) /* sc->code: (number-ok? otst result oexp) */ +{ + const s7_pointer args = cddr(sc->code); + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, update_let_with_three_slots(sc, closure_let(func), lookup(sc, cadr(sc->code)), lookup(sc, car(args)), lookup(sc, cadr(args)))); + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin_unchecked(sc); +} - if ((sc->safety > no_safety) && - (tree_is_cyclic (sc, form))) /* this can happen (3 examples in s7test) */ - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_2 (sc, - wrap_string (sc, "lambda: body is cyclic: ~S", 26), - form)); +static void op_safe_closure_ssa(s7_scheme *sc) /* possibly inline b, sc->code: (transparent-memq sym var (outlet e)) */ +{ /* ssa_a is hit once, but is only about 3/4% faster -- there's the fx overhead, etc */ + const s7_pointer args = cdr(sc->code); + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, update_let_with_three_slots(sc, closure_let(func), lookup(sc, car(args)), lookup(sc, cadr(args)), fx_call(sc, cddr(args)))); + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin_unchecked(sc); +} - code= cdr (form); - if (!is_pair (code)) /* (lambda) or (lambda . 1) */ - syntax_error_nr (sc, "lambda: no arguments? ~A", 24, form); +static void op_safe_closure_saa(s7_scheme *sc) /* (not called in s7test) cb.scm: sc->code: (loop a (+ b 1) parts) */ +{ + const s7_pointer func = opt1_lambda(sc->code); + const s7_pointer args = cddr(sc->code); + const s7_pointer arg2 = lookup(sc, cadr(sc->code)); /* I don't see fx_t|u here? */ + sc->code = fx_call(sc, args); + set_curlet(sc, update_let_with_three_slots(sc, closure_let(func), arg2, sc->code, fx_call(sc, cdr(args)))); + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin_unchecked(sc); +} - body= cdr (code); - if (!is_pair (body)) /* (lambda #f) */ - syntax_error_nr (sc, "lambda: no body? ~A", 19, form); +static void op_safe_closure_agg(s7_scheme *sc) /* possibly inline tleft, sc->code: (fx2 3 #t #t) */ +{ + const s7_pointer args = cdr(sc->code); + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, update_let_with_three_slots(sc, closure_let(func), fx_call(sc, args), fx_call(sc, cdr(args)), fx_call(sc, cddr(args)))); + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin_unchecked(sc); +} - /* in many cases, this is a no-op -- we already checked at define */ - check_lambda_args (sc, car (code), &arity, sc->code); +static void op_closure_p(s7_scheme *sc) /* sc->code: (uncaller (hook 'code)) */ +{ + check_stack_size(sc); + push_stack_no_args(sc, OP_CLOSURE_P_1, opt1_lambda(sc->code)); + sc->code = cadr(sc->code); +} - /* 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 - */ - clear_big_symbol_set (sc); - if ((opt) || (stack_top_op (sc) == OP_DEFINE1) || - (((sc->stack_end - sc->stack_start) > 4) && - (stack_top4_op (sc) == 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); - } - clear_big_symbol_set (sc); - 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= 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= (int32_t) ((intptr_t) opt3_any (cdr (code))); - return (make_closure_gc_checked (sc, cadr (code), cddr (code), - T_CLOSURE | ((arity < 0) ? T_COPY_ARGS : 0), - arity)); -} - -static void -check_lambda_star (s7_scheme* sc) { - const s7_pointer code= cdr (sc->code); - if ((sc->safety > no_safety) && (tree_is_cyclic (sc, sc->code))) - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_2 (sc, - wrap_string (sc, "lambda*: body is cyclic: ~S", 27), - sc->code)); - if ((!is_pair (code)) || - (!is_pair (cdr (code)))) /* (lambda*) or (lambda* #f) */ - syntax_error_nr (sc, "lambda*: no arguments or no body? ~A", 36, sc->code); - - set_car (code, check_lambda_star_args (sc, car (code), NULL, sc->code)); - - clear_big_symbol_set (sc); - if ((sc->safety > no_safety) || (stack_top_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)); - clear_big_symbol_set (sc); - pair_set_syntax_op (sc->code, OP_LAMBDA_STAR_UNCHECKED); - sc->code= code; +static void op_closure_p_1(s7_scheme *sc) /* sc->code: symbol->object */ +{ + set_curlet(sc, inline_make_let_with_slot(sc, closure_let(sc->code), car(closure_pars(sc->code)), sc->value)); + sc->code = T_Pair(closure_body(sc->code)); } -/* -------------------------------- case -------------------------------- */ -static inline bool -is_undefined_feed_to (s7_scheme* sc, const 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 bool -is_all_fxable (s7_scheme* sc, s7_pointer exprs) { - for (s7_pointer p= exprs; is_pair (p); p= cdr (p)) - if (!is_fxable (sc, car (p))) return (false); - return (true); -} - -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, use_fx= true; - int32_t key_type= T_FREE; - const s7_pointer code= cdr (sc->code), form= sc->code; - - if (!is_pair (code)) /* (case) or (case . 1) */ - syntax_error_nr (sc, "case has no selector: ~S", 25, form); - if (!is_pair (cdr (code))) /* (case 1) or (case 1 . 1) */ - syntax_error_nr (sc, "case has no clauses?: ~S", 25, form); - if (!is_pair (cadr (code))) /* (case 1 1) */ - syntax_error_nr (sc, "case clause is not a pair? ~S", 29, form); - set_opt3_any (code, sc->unspecified); +static void op_safe_closure_a(s7_scheme *sc) /* sc->code: (loop (+ index 1)) */ +{ + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, update_let_with_slot(sc, closure_let(func), fx_call(sc, cdr(sc->code)))); + sc->code = T_Pair(closure_body(func)); + push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); + sc->code = car(sc->code); +} - { - s7_pointer clauses; - for (clauses= cdr (code); is_pair (clauses); clauses= cdr (clauses)) { - s7_pointer keys, clause= car (clauses); - if (!is_pair (clause)) - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_3 (sc, - wrap_string (sc, "case clause ~S messed up in ~A", 30), - clauses, object_to_string_truncated (sc, form))); - if (!is_list (cdr (clause))) /* (case 1 ((1))) */ - error_nr (sc, sc->syntax_error_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, "case clause result ~S is messed up in ~A", 40), - clause, object_to_string_truncated (sc, form))); - if ((bodies_simple) && - ((is_null (cdr (clause))) || (!is_null (cddr (clause))))) - bodies_simple= false; - - use_fx= ((use_fx) && (is_pair (cdr (clause))) && - (is_all_fxable (sc, cdr (clause)))); - keys = car (clause); - if (!is_pair (keys)) { - if ((keys != sc->else_symbol) && /* (case 1 (2 1)) */ - ((!is_symbol (keys)) || - (s7_symbol_value (sc, keys) != - sc->else_symbol))) /* "proper list" below because: (case 1 (() 2) - ... */ - error_nr (sc, sc->syntax_error_symbol, - set_elist_4 ( - sc, - wrap_string (sc, - "case clause key-list ~S in ~S is not a " - "proper list or 'else', in ~A", - 67), - keys, clause, object_to_string_truncated (sc, form))); - has_else= true; - if (is_not_null (cdr (clauses))) /* (case 1 (else 1) ((2) 1)) */ - syntax_error_nr (sc, "case 'else' clause is not the last clause: ~S", - 45, clauses); - if (!is_null (cdr (clause))) /* else (else) so return selector */ - { - if (is_pair (cddr (clause))) { - set_opt3_any (code, cdr (clause)); - bodies_simple= false; - } - else { - set_opt3_any (code, ((bodies_simple) && (keys_single)) - ? cadr (clause) - : cdr (clause)); - set_opt1_clause (clauses, cadr (clause)); - } - } - } - else { - if (!is_simple (car (keys))) keys_simple= false; - if (!is_null (cdr (keys))) keys_single= false; - if (key_type == T_FREE) key_type= type (car (keys)); - else if (key_type != type (car (keys))) key_type= NUM_TYPES; - if (key_type == T_SYMBOL) set_case_key (car (keys)); - - for (keys= cdr (keys); is_pair (keys); keys= cdr (keys)) { - if (!is_simple (car (keys))) keys_simple= false; - if (key_type != type (car (keys))) key_type= NUM_TYPES; - if (key_type == T_SYMBOL) set_case_key (car (keys)); - } - if (!is_null (keys)) /* (case () ((1 . 2) . hi) . hi) */ - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_3 ( - sc, - wrap_string (sc, "case key list ~S is improper, in ~A", 35), - clause, object_to_string_truncated (sc, form))); - } - if (!s7_is_proper_list (sc, cdr (clause))) /* (case 2 ((1 2) 1 . 2)) */ - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_3 (sc, wrap_string (sc, "case: stray dot? ~S in ~A", 25), - clause, object_to_string_truncated (sc, form))); - if ((is_pair (cdr (clause))) && - (is_undefined_feed_to (sc, cadr (clause)))) { - has_feed_to= true; - if (!is_pair (cddr (clause))) /* (case 1 (else =>)) */ - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_3 ( - sc, - wrap_string (sc, "case: '=>' target missing: ~S in ~A", 35), - clause, object_to_string_truncated (sc, form))); - if (is_pair (cdddr (clause))) /* (case 1 (else => + - *)) */ - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_3 ( - sc, - wrap_string (sc, "case: '=>' has too many targets: ~S in ~A", - 41), - clause, object_to_string_truncated (sc, form))); - } - } - if (is_not_null (clauses)) /* (case x ((1 2)) . 1) */ - syntax_error_nr (sc, "case: stray dot? ~S", 19, form); - } - if ((keys_single) && (bodies_simple)) { - for (s7_pointer clauses= cdr (code); is_not_null (clauses); - clauses = cdr (clauses)) { - set_opt2_any (clauses, caar (clauses)); - if (is_pair (opt2_any (clauses))) { - set_opt2_any (clauses, car (opt2_any (clauses))); - if (is_pair (cdar (clauses))) - set_opt1_clause (clauses, cadar (clauses)); - } - } - } - else - for (s7_pointer clauses= cdr (code); is_not_null (clauses); - clauses = cdr (clauses)) { - set_opt2_any (clauses, caar (clauses)); - if ((is_pair (opt2_any (clauses))) && (is_pair (cdar (clauses)))) - set_opt1_clause (clauses, cadar (clauses)); - } - if (key_type == T_INTEGER) set_has_integer_keys (form); - - /* X_Y_Z: X (selector): S=symbol, A=fxable, P=any, Y: E(keys simple) G(any - * keys) I(integer keys) , Z: S: no =>, bodies simple, keys single G: all - * else, -- ?? */ - pair_set_syntax_op (form, 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 */ - { - if (is_fxable (sc, car (code))) { - pair_set_syntax_op (form, OP_CASE_A_G_G); - set_fx_direct (code, - fx_choose (sc, code, sc->curlet, let_symbol_is_safe)); - if ((is_fx_treeable (cdr (code))) && (curlet_has_slots (sc))) - fx_curlet_tree_in (sc, code); - } - else pair_set_syntax_op (form, 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_fxable (sc, car (code))) { - pair_set_syntax_op (form, (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)); - if ((is_fx_treeable (cdr (code))) && (curlet_has_slots (sc))) - fx_curlet_tree_in (sc, code); - } - else pair_set_syntax_op (form, OP_CASE_P_E_G); - } - } - else /* x_x_s */ - if (!keys_simple) /* x_g|i_s */ - { - if (is_fxable (sc, car (code))) { - pair_set_syntax_op (form, ((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)); - if ((is_fx_treeable (cdr (code))) && (curlet_has_slots (sc))) - fx_curlet_tree_in (sc, code); - } - else - pair_set_syntax_op (form, ((key_type == T_INTEGER)) ? OP_CASE_P_I_S - : OP_CASE_P_G_S); - } - else /* x_e_s */ - if (is_fxable (sc, car (code))) { - pair_set_syntax_op (form, OP_CASE_A_E_S); - set_fx_direct (code, - fx_choose (sc, code, sc->curlet, let_symbol_is_safe)); - if ((is_fx_treeable (cdr (code))) && (curlet_has_slots (sc))) - fx_curlet_tree_in (sc, code); - } - else pair_set_syntax_op (form, OP_CASE_P_E_S); - - if ((use_fx) && (has_else) && (!has_feed_to)) { - const opcode_t op= optimize_op (form); - if ((op == OP_CASE_A_E_S) || (op == OP_CASE_A_G_S) || - (op == OP_CASE_A_S_G) || ((op == OP_CASE_A_I_S))) { - pair_set_syntax_op ( - form, (op == OP_CASE_A_I_S) - ? OP_CASE_A_I_S_A - : ((op == OP_CASE_A_E_S) - ? OP_CASE_A_E_S_A - : ((op == OP_CASE_A_S_G) ? OP_CASE_A_S_G_A - : OP_CASE_A_G_S_A))); - for (s7_pointer clauses= cdr (code); is_pair (clauses); - clauses = cdr (clauses)) { - s7_pointer clause= cdar (clauses); - fx_annotate_args (sc, clause, sc->curlet); - if ((is_fx_treeable (cdr (code))) && (curlet_has_slots (sc))) - fx_curlet_tree (sc, clause); - if (is_null (cdr (clauses))) set_opt3_any (code, clause); - } - } - } - { - s7_pointer selector= cadr (form); - if (!is_pair (selector)) { - sc->value= - (is_symbol (selector)) ? lookup_checked (sc, selector) : selector; - return (NULL); - } - push_stack_no_args_direct (sc, OP_CASE_G_G); - sc->code= selector; - return (selector); - } +static void op_safe_closure_a_o(s7_scheme *sc) /* sc->code: (butlast (cdr (car (cdr (cdr old))))) */ +{ + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, update_let_with_slot(sc, closure_let(func), fx_call(sc, cdr(sc->code)))); + sc->code = car(closure_body(func)); } -static bool -op_case_i_s (s7_scheme* sc) { - const s7_pointer selector = sc->value; - const s7_pointer else_clause= opt3_any (cdr (sc->code)); - if (else_clause != sc->unspecified) { - if (is_t_integer (selector)) { - const s7_int val= integer (selector); - for (s7_pointer clauses= cddr (sc->code); is_pair (cdr (clauses)); - clauses = cdr (clauses)) - if (integer (opt2_any (clauses)) == val) { - sc->code= opt1_clause (clauses); - return (false); - } - } - sc->code= else_clause; - return (false); - } - if (is_t_integer (selector)) { - const s7_int val= integer (selector); - for (s7_pointer clauses= cddr (sc->code); is_pair (clauses); - clauses = cdr (clauses)) - if (integer (opt2_any (clauses)) == val) { - sc->code= opt1_clause (clauses); - return (false); - } - } - sc->value= sc->unspecified; - return (true); +static void op_closure_ap(s7_scheme *sc) /* sc->code: (ack1 (- m 1) (ack1 m (- n 1))) */ +{ + const 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 inline s7_pointer -fx_case_a_i_s_a (s7_scheme* sc, - s7_pointer code) /* inline saves about 30 in tleft */ +static void op_closure_ap_1(s7_scheme *sc) /* sc->code: 1 */ { - const s7_pointer selector= fx_call (sc, cdr (code)); - if (is_t_integer (selector)) { - const s7_int val= integer (selector); - for (s7_pointer clauses= cddr (sc->code); is_pair (cdr (clauses)); - clauses = cdr (clauses)) /* code = (case ...) */ - if (integer (opt2_any (clauses)) == val) - return (fx_call (sc, cdar (clauses))); - } - return (fx_call (sc, opt3_any (cdr (code)))); + /* sc->value is presumably the "P" argument value, "A" is sc->args->sc->code above (sc->args here is opt1_lambda(original sc->code)) */ + set_curlet(sc, inline_make_let_with_two_slots(sc, closure_let(sc->args), car(closure_pars(sc->args)), sc->code, cadr(closure_pars(sc->args)), sc->value)); + sc->code = T_Pair(closure_body(sc->args)); } -static bool -op_case_e_g_1 (s7_scheme* sc, const s7_pointer selector, bool ok) { - s7_pointer clauses; - if (ok) { - for (clauses= cddr (sc->code); is_pair (clauses); clauses= cdr (clauses)) { - s7_pointer keys= opt2_any (clauses); - if (!is_pair (keys)) /* i.e. else? */ - goto ELSE_CASE_1; - do { - if (car (keys) == selector) goto ELSE_CASE_1; - keys= cdr (keys); - } while (is_pair (keys)); - } - sc->value= sc->unspecified; - pop_stack (sc); - return (true); - } +static void op_closure_pa(s7_scheme *sc) /* sc->code: (f-1 (lambda (b) (+ b 1)) 2) */ +{ + const s7_pointer code = sc->code; + sc->args = fx_call(sc, cddr(code)); + check_stack_size(sc); + 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); +} - 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); +static void op_closure_pa_1(s7_scheme *sc) /* sc->code: # */ +{ + set_curlet(sc, inline_make_let_with_two_slots(sc, closure_let(sc->code), car(closure_pars(sc->code)), sc->value, cadr(closure_pars(sc->code)), sc->args)); + sc->code = T_Pair(closure_body(sc->code)); +} -ELSE_CASE_1: - /* clauses is the entire matching clause, (case 2 ((2) 3)), clauses: (((2) 3)) - */ - sc->code= T_Lst (cdar (clauses)); - if (is_null (sc->code)) /* sc->value is already the selector */ - { - pop_stack (sc); - return (true); - } +static void op_closure_pp(s7_scheme *sc) /* sc->code: (loop (xf) (yf)) */ +{ + check_stack_size(sc); + push_stack(sc, OP_CLOSURE_PP_1, opt1_lambda(sc->code), sc->code); + sc->code = cadr(sc->code); +} -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); +static void op_closure_pp_1(s7_scheme *sc) /* sc->code: as above */ +{ + push_stack(sc, OP_CLOSURE_AP_1, sc->args, sc->value); + sc->code = caddr(sc->code); +} - 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 void op_safe_closure_ap(s7_scheme *sc) /* sc->code: (somefunc (call/cc (lambda (c1)... */ +{ + 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 inline s7_pointer -fx_call_all (s7_scheme* sc, s7_pointer code) { - s7_pointer p; - for (p= code; is_pair (cdr (p)); p= cdr (p)) - fx_call (sc, p); - return (fx_call (sc, p)); -} - -static s7_pointer -fx_case_a_s_g_a (s7_scheme* sc, s7_pointer code) { - const s7_pointer selector= fx_call (sc, cdr (code)); - if (is_case_key (selector)) - for (s7_pointer clauses= cddr (sc->code); is_pair (clauses); - clauses = cdr (clauses)) { - s7_pointer keys= opt2_any (clauses); - if (!is_pair (keys)) /* i.e. else? */ - return (fx_call_all (sc, cdar (clauses))); /* else clause */ - do { - if (car (keys) == selector) return (fx_call_all (sc, cdar (clauses))); - keys= cdr (keys); - } while (is_pair (keys)); - } - return ( - fx_call_all (sc, opt3_any (cdr (code)))); /* selector is not a case-key */ -} - -#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); -#define if_pair_set_up_begin_unchecked(Sc) \ - if (is_pair (cdr (Sc->code))) \ - push_stack_no_args (Sc, Sc->begin_op, cdr (Sc->code)); \ - Sc->code= car (Sc->code); -/* using the one_form bit here was slower */ +static void op_safe_closure_ap_1(s7_scheme *sc) /* sc->code: somefunc */ +{ + set_curlet(sc, update_let_with_two_slots(sc, closure_let(sc->code), sc->args, sc->value)); + sc->code = T_Pair(closure_body(sc->code)); +} -static bool -op_case_g_g (s7_scheme* sc) { - s7_pointer clauses; - 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 { - { - for (clauses= sc->code; is_pair (clauses); clauses= cdr (clauses)) - if (!is_pair (caar (clauses))) goto ELSE_CASE; - sc->value= sc->unspecified; - pop_stack (sc); - return (true); - } - } - for (clauses= sc->code; is_pair (clauses); clauses= cdr (clauses)) { - s7_pointer keys= caar (clauses); - if (!is_pair (keys)) goto ELSE_CASE; - for (; is_pair (keys); keys= cdr (keys)) - if (integer (car (keys)) == selector) goto ELSE_CASE; - } - sc->value= sc->unspecified; - pop_stack (sc); - return (true); - } - sc->code= cddr (sc->code); - if (is_simple (sc->value)) { - for (clauses= sc->code; is_pair (clauses); clauses= cdr (clauses)) { - s7_pointer keys= caar (clauses); - if (!is_pair (keys)) goto ELSE_CASE; - do { - if (car (keys) == sc->value) goto ELSE_CASE; - keys= cdr (keys); - } while (is_pair (keys)); - } - sc->value= sc->unspecified; - pop_stack (sc); - return (true); - } - for (clauses= sc->code; is_pair (clauses); clauses= cdr (clauses)) { - s7_pointer keys= caar (clauses); - if (!is_pair (keys)) goto ELSE_CASE; - for (; is_pair (keys); keys= cdr (keys)) - if (s7_is_eqv (sc, car (keys), 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); +static void op_safe_closure_pa(s7_scheme *sc) /* sc->code: (string-wi=? (object->string (append...) :readable)) */ +{ + 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); +} -ELSE_CASE: - /* clauses is the entire matching clause, (case 2 ((2) 3)), clauses: (((2) 3)) - */ - sc->code= T_Lst (cdar (clauses)); - 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_pair_set_up_begin_unchecked (sc); - sc->cur_op= optimize_op (sc->code); - return (true); -} - -static void -op_case_e_s (s7_scheme* sc) { - const s7_pointer selector= sc->value; - if (is_simple (selector)) - for (s7_pointer clauses= cddr (sc->code); is_pair (clauses); - clauses = cdr (clauses)) - if (opt2_any (clauses) == selector) { - sc->code= opt1_clause (clauses); - return; - } - sc->code= opt3_any (cdr (sc->code)); -} - -static s7_pointer -fx_case_a_e_s_a (s7_scheme* sc, s7_pointer code) { - const s7_pointer selector= fx_call (sc, cdr (code)); - if (is_simple (selector)) - for (s7_pointer clauses= cddr (code); is_pair (clauses); - clauses = cdr (clauses)) - if (opt2_any (clauses) == selector) return (fx_call (sc, cdar (clauses))); - return (fx_call (sc, opt3_any (cdr (code)))); -} - -static void -op_case_g_s (s7_scheme* sc) { - const s7_pointer selector= sc->value; - for (s7_pointer clauses= cddr (sc->code); is_pair (clauses); - clauses = cdr (clauses)) - if (s7_is_eqv (sc, opt2_any (clauses), selector)) { - sc->code= opt1_clause (clauses); - return; - } - sc->code= opt3_any (cdr (sc->code)); +static void op_safe_closure_pa_1(s7_scheme *sc) /* sc->code: string-wi=? */ +{ + set_curlet(sc, update_let_with_two_slots(sc, closure_let(sc->code), sc->value, sc->args)); + sc->code = T_Pair(closure_body(sc->code)); } -static inline s7_pointer -fx_case_a_g_s_a (s7_scheme* sc, - s7_pointer code) /* split into int/any cases in g_g, via - has_integer_keys(sc->code) */ +static void op_safe_closure_pp(s7_scheme *sc) /* sc->code: (somefunc (call/cc (lambda (c1)... */ { - const s7_pointer selector= fx_call (sc, cdr (code)); - for (s7_pointer clauses= cddr (code); is_pair (clauses); - clauses = cdr (clauses)) - if (s7_is_eqv (sc, opt2_any (clauses), selector)) - return (fx_call (sc, cdar (clauses))); - return (fx_call (sc, opt3_any (cdr (code)))); + check_stack_size(sc); + push_stack(sc, OP_SAFE_CLOSURE_PP_1, opt1_lambda(sc->code), sc->code); + sc->code = cadr(sc->code); } -/* -------------------------------- let -------------------------------- */ -static void -check_let_a_body (s7_scheme* sc, s7_pointer form) { - const 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); - if (is_fx_treeable (cdaar (code))) - fx_tree (sc, cdr (code), caaar (code), NULL, NULL, false); - } +static void op_safe_closure_pp_1(s7_scheme *sc) /* sc->code as above */ +{ + push_stack(sc, OP_SAFE_CLOSURE_AP_1, sc->value, sc->args); + sc->code = caddr(sc->code); } -static void -check_let_one_var (s7_scheme* sc, s7_pointer form, - s7_pointer start) /* not a named let */ -{ - const s7_pointer binding= car (start), - code= cdr (form); /* i.e. form=(let ((x '(1 2))) (list x x)), - start=((x '(1 2))) */ - const s7_pointer variable= car (binding), value= cadr (binding); - if (is_pair (value)) { - 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), - variable); /* these don't collide -- cdr(code) and code */ - set_opt2_pair (code, value); - if (is_optimized (value)) { - if ((optimize_op (value) == HOP_SAFE_C_SS) && - (fn_proc (value) == g_assq)) { - set_opt2_sym (code, cadr (value)); - pair_set_syntax_op (form, OP_LET_opaSSq_OLD); - set_opt3_sym (cdr (code), caddr (value)); - set_opt1_sym (code, variable); - } - else if (is_fxable (sc, value)) { - 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_NA_OLD); /* let_a_aa_old|new is not worth the code (30 - in tgc, nothing elsewhere) */ - fx_annotate_args (sc, cdr (code), set_plist_1 (sc, variable)); - fx_tree (sc, cdr (code), variable, NULL, NULL, false); - return; - } - if (is_fx_treeable (cdr (code))) - fx_tree (sc, cdr (code), variable, NULL, NULL, false); - } - } - } - } - 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); - else { - fx_annotate_args ( - sc, cdr (code), - set_plist_1 (sc, - variable)); /* no effect if not syntactic -- how to fix? - plist is the "let" = local varname */ - if (is_fx_treeable (cdr (code))) - fx_tree (sc, cdr (code), variable, NULL, NULL, false); +static void op_any_closure_3p(s7_scheme *sc) /* sc->code: (g-1 (lambda (b c) (+ b c)) 2 3) */ +{ + s7_pointer args = cdr(sc->code); /* sc->code: e.g. s7test (recompose 32 (lambda (a) (cons 1 a)) ()) */ + if (has_fx(args)) + { + sc->args = fx_call(sc, args); + args = cdr(args); + if (has_fx(args)) + { + stack_end_code(sc) = sc->code; /* push_stack_direct(sc, OP_ANY_CLOSURE_3P_3) here but trying to be too clever? */ + stack_end_args(sc) = sc->args; /* stack[args] == arg1 to closure) */ + stack_end_op(sc) = (s7_pointer)(opcode_t)(OP_ANY_CLOSURE_3P_3); + sc->stack_end += 4; + set_stack_protected3(sc, fx_call(sc, args), OP_ANY_CLOSURE_3P_3); /* set stack_let */ + /* (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(args); + } + else + { + push_stack_direct(sc, OP_ANY_CLOSURE_3P_2); /* arg1 == stack[args] */ + sc->code = car(args); + }} + else + { + push_stack_no_args_direct(sc, OP_ANY_CLOSURE_3P_1); + sc->code = car(args); } - } - 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); /* not fxable body, goto eval on each */ -} - -static s7_pointer -check_named_let (s7_scheme* sc, int32_t vars) { - const s7_pointer code= cdr (sc->code); - set_opt2_int (code, 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 { - 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 - * (implicit) lambda arg list */ - - sc->args= T_Pair (safe_list_if_possible (sc, vars)); - for (s7_pointer ex= cadr (code), exp= sc->args; is_pair (ex); - ex= cdr (ex), exp= cdr (exp)) { - const s7_pointer val= cdar (ex); - s7_function fx = fx_choose (sc, val, sc->curlet, let_symbol_is_safe); - if (fx) set_fx_direct (val, fx); - else fx_ok= false; - set_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_NA)); - } - optimize_lambda (sc, true, car (code), sc->args, - cddr (code)); /* car(code) is the name */ - if (!in_heap (sc->args)) clear_safe_list_in_use (sc, sc->args); - sc->args= sc->nil; - } - return (code); } -static s7_pointer -check_let (s7_scheme* sc) /* called only from op_let */ +static bool closure_3p_end(s7_scheme *sc, s7_pointer args) /* sc->code: (dpb (byte 4 5) (byte 6 7) (byte 8 9)) */ { - s7_pointer start; - const s7_pointer code= cdr (sc->code), form= sc->code; - bool named_let; - - if (!is_pair (code)) /* (let . 1) */ - { - if (is_null (code)) /* (let) */ - syntax_error_nr (sc, "let has no variables or body: ~A", 32, form); - syntax_error_nr (sc, "let form is an improper list? ~A", 32, form); - } + if (has_fx(args)) + { + const s7_pointer func = opt1_lambda(sc->code); + gc_protect_2_via_stack(sc, sc->args, sc->value); /* sc->args == arg1, sc->value == arg2 */ + set_gc_protected3(sc, fx_call(sc, args)); + if (is_safe_closure(func)) + set_curlet(sc, update_let_with_three_slots(sc, closure_let(func), gc_protected1(sc), gc_protected2(sc), gc_protected3(sc))); + else make_let_with_three_slots(sc, func, gc_protected1(sc), gc_protected2(sc), gc_protected3(sc)); + unstack_gc_protect(sc); + sc->code = T_Pair(closure_body(func)); + return(true); + } + push_stack_direct(sc, OP_ANY_CLOSURE_3P_3); + set_stack_protected3(sc, sc->value, OP_ANY_CLOSURE_3P_3); /* set stack_let, arg2 == curlet stack loc */ + sc->code = car(args); + return(false); +} + +static bool op_any_closure_3p_1(s7_scheme *sc) /* sc->code: as above */ +{ + const s7_pointer args = cddr(sc->code); + sc->args = sc->value; /* (arg1 of closure) sc->value can be clobbered by fx_call? */ + if (has_fx(args)) + { + sc->value = fx_call(sc, args); + return(closure_3p_end(sc, cdr(args))); + } + push_stack_direct(sc, OP_ANY_CLOSURE_3P_2); + sc->code = car(args); + return(false); +} - if (!is_pair (cdr (code))) /* (let () ) or (let () . 1) */ - syntax_error_nr (sc, "let has no body: ~A", 19, form); - - if ((!is_list (car (code))) && /* (let 1 ...) */ - (!is_normal_symbol (car (code)))) - syntax_error_nr (sc, "let variable list is messed up or missing: ~A", 45, - form); - - named_let= (is_symbol (car (code))); - if (named_let) { - if (!is_list (cadr (code))) /* (let hi #t) */ - syntax_error_nr (sc, "let variable list is messed up: ~A", 34, form); - if (!is_pair (cddr (code))) /* (let hi () . =>) or (let hi () ) */ - { - if (is_null (cddr (code))) - syntax_error_nr (sc, "named let has no body: ~A", 25, form); - syntax_error_nr (sc, "named let stray dot? ~A", 23, form); - } - if (is_constant_symbol (sc, car (code))) - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_3 (sc, cant_bind_immutable_string, sc->let_symbol, form)); - set_local (car (code)); - start= cadr (code); - } - else start= car (code); +static bool op_any_closure_3p_2(s7_scheme *sc) {return(closure_3p_end(sc, cdddr(sc->code)));} - begin_small_symbol_set (sc); - { - s7_pointer vars; - int32_t num_vars; - for (num_vars= 0, vars= start; is_pair (vars); - num_vars++, vars = cdr (vars)) { - s7_pointer sym; - const s7_pointer var= car (vars); - - if ((!is_pair (var)) || - (is_null ( - cdr (var)))) /* (let ((x)) ...) or (let ((x 1) . (y 2)) ...) */ - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, "let variable declaration, but no value?: ~A in ~A", - 49), - vars, object_to_string_truncated (sc, form))); - - if (!is_pair (cdr (var))) /* (let ((x . 1))...) */ - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, - "let variable declaration, ~A, is not a proper list in ~A", - 56), - vars, object_to_string_truncated (sc, form))); - - if (is_not_null (cddr (var))) /* (let ((x 1 2 3)) ...) */ - error_nr (sc, sc->syntax_error_symbol, - set_elist_3 (sc, - wrap_string (sc, - "let variable declaration, ~A, has " - "more than one value in ~A", - 59), - vars, object_to_string_truncated (sc, form))); - sym= car (var); - if (!is_symbol (sym)) { - if (is_c_function (sym)) /* (let ((#_abs 3)) ...) */ - { - s7_pointer fsym= c_function_symbol (sym); - if (initial_value_is_defined (sc, fsym)) - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_2 ( - sc, - wrap_string ( - sc, - "variable name #_~S in let is a function, not a symbol", - 53), - fsym)); - } - error_nr (sc, - sc->syntax_error_symbol, /* (let ('1) quote) -> bad variable - name #_quote in let (it is - syntactic, not a symbol) */ - set_elist_4 (sc, - wrap_string (sc, - "bad variable name ~W in let (it " - "is ~A, not a symbol) in ~A", - 58), - sym, object_type_name (sc, sym), - object_to_string_truncated (sc, form))); - } - if (is_constant_symbol (sc, sym)) /* let ((pi 3)) ...) */ - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_3 (sc, cant_bind_immutable_string, sc->let_symbol, vars)); - - /* check for name collisions -- not sure this is required by Scheme */ - if (symbol_is_in_small_symbol_set (sc, sym)) - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_3 ( - sc, - wrap_string (sc, "duplicate identifier in let: ~S in ~S", 37), - sym, form)); - add_symbol_to_small_symbol_set (sc, sym); - set_local (sym); - } - end_small_symbol_set (sc); - - if (is_not_null (vars)) /* (let* ((a 1) . b) a) */ - syntax_error_nr (sc, "let variable list improper?: ~A", 31, form); - - if (!s7_is_proper_list (sc, cdr (code))) /* (let ((a 1)) a . 1) */ - syntax_error_nr (sc, "stray dot in let body: ~S", 25, cdr (code)); - - if (named_let) return (check_named_let (sc, num_vars)); - /* set_opt2_int(code, num_vars); */ /* maybe set on vars? */ +static void op_any_closure_3p_3(s7_scheme *sc) /* sc->code: as above */ +{ + /* display(obj) will not work here because sc->curlet is being used as arg2 of the closure3 */ + const s7_pointer func = opt1_lambda(sc->code); /* incoming args (from pop_stack): sc->args, sc->curlet, and sc->value from last evaluation */ + if (is_safe_closure(func)) + set_curlet(sc, 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)); +} - if (num_vars == 0) /* !in_heap does not happen much here */ - pair_set_syntax_op (form, OP_LET_NO_VARS); - else { - pair_set_syntax_op (form, OP_LET_UNCHECKED); - if (num_vars == 1) check_let_one_var (sc, form, start); - else { - /* this used to check that num_vars < gc_trigger_size, but I can't see - * why */ - opcode_t opt= OP_UNOPT; - for (vars= start; is_pair (vars); vars= cdr (vars)) { - s7_pointer var= car (vars); - if (is_fxable (sc, cadr (var))) { - set_fx_direct (cdr (var), fx_choose (sc, cdr (var), sc->curlet, - let_symbol_is_safe)); - if (opt == OP_UNOPT) opt= OP_LET_NA_OLD; - } - else opt= OP_LET_UNCHECKED; - } - pair_set_syntax_op (form, opt); - if ((opt == OP_LET_NA_OLD) && - (is_null (cddr (code)))) /* 1 form in body */ - { - if (num_vars == 2) { - pair_set_syntax_op (form, OP_LET_2A_OLD); - set_opt1_pair (code, caar (code)); - set_opt2_pair (code, cadar (code)); - } - else if (num_vars == 3) { - pair_set_syntax_op (form, OP_LET_3A_OLD); - set_opt1_pair (code, cadar (code)); - set_opt2_pair (code, caddar (code)); - } - } - } +static void op_any_closure_4p(s7_scheme *sc) /* sc->code: (lpb -1 1 (byte 4 5) 3) */ +{ + s7_pointer args = cdr(sc->code); + check_stack_size(sc); + if (has_fx(args)) + { + gc_protect_via_stack(sc, fx_call(sc, args)); + args = cdr(args); + if (has_fx(args)) + { + set_gc_protected2(sc, fx_call(sc, args)); + args = cdr(args); + if (has_fx(args)) + { + set_gc_protected3(sc, fx_call(sc, args)); + push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_4); + sc->code = cadr(args); + } + else + { + push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_3); + sc->code = car(args); + }} + else + { + stack_end_args(sc) = sc->unused; /* copy_stack dangling pair */ + push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_2); + sc->code = car(args); + }} + else + { + push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_1); + sc->code = car(args); } - } +} - /* if safe_c or safe_closure as car(body), null cdr(body), see if only vars as - * args */ - if (optimize_op (form) >= OP_LET_NA_OLD) { - if ((!in_heap (form)) && - (wrapped_body_is_safe (sc, sc->unused, cdr (code), true) >= - safe_body)) /* recur_body is apparently never hit */ - set_opt3_let (code, make_semipermanent_let (sc, car (code))); - else { - set_optimize_op (form, optimize_op (form) + 1); /* *_old -> *_new */ - set_opt3_let (code, sc->rootlet); +static bool closure_4p_end(s7_scheme *sc, s7_pointer args) /* sc->code: as above */ +{ + if (has_fx(args)) + { + const s7_pointer func = opt1_lambda(sc->code); + sc->args = fx_call(sc, args); + if (is_safe_closure(func)) + set_curlet(sc, update_let_with_four_slots(sc, closure_let(func), gc_protected1(sc), gc_protected2(sc), gc_protected3(sc), sc->args)); + else make_let_with_four_slots(sc, func, gc_protected1(sc), gc_protected2(sc), gc_protected3(sc), sc->args); + sc->code = T_Pair(closure_body(func)); + unstack_gc_protect(sc); + return(true); } - } + push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_4); + sc->code = car(args); + return(false); +} - /* fx_tree inits */ - if ((is_pair (code)) && - (is_fx_treeable (code)) && /* was is_funclet(sc->curlet) 27-Sep-21, but - that seems too restrictive */ - (curlet_has_slots (sc))) { - s7_pointer slot1= let_slots (sc->curlet), slot2= next_slot (slot1), - slot3= NULL; - bool more_vars = false; - if (is_not_slot_end (slot2)) { - if (is_not_slot_end (next_slot (slot2))) { - slot3 = next_slot (slot2); - more_vars= is_not_slot_end (next_slot (slot3)); - slot3 = slot_symbol (slot3); - } - slot2= slot_symbol (slot2); - } - slot1= slot_symbol (slot1); - for (s7_pointer p= car (code); is_pair (p); p= cdr (p)) /* var list */ +static bool op_any_closure_4p_1(s7_scheme *sc) /* sc->code: as above */ +{ + s7_pointer args = cddr(sc->code); + gc_protect_via_stack(sc, sc->value); + if (has_fx(args)) { - s7_pointer init= cdar (p); - fx_tree (sc, init, slot1, slot2, slot3, more_vars); - } - } - return (code); -} - -static void -op_named_let_1 (s7_scheme* sc, - s7_pointer args) /* sc->code = (name vars . body), args = vals - in decl order */ -{ - const s7_pointer body= cddr (sc->code); - const s7_int n= - opt2_int (sc->code); /* num pars, see check_named_let called in check_let, - normally 1, sometimes 2..4 */ - if (n == 1) begin_temp (sc->y, list_1 (sc, caaadr (sc->code))); - else { - begin_temp (sc->y, sc->nil); - for (s7_pointer vars= cadr (sc->code); is_pair (vars); vars= cdr (vars)) { - sc->y= - cons (sc, caar (vars), - sc->y); /* this consing is not completely wasted -- it becomes - the closure arg list below (why is this needed?) */ - vars= cdr (vars); - if (!is_pair (vars)) break; - sc->y= cons_unchecked (sc, caar (vars), sc->y); - } - sc->y= - proper_list_reverse_in_place (sc, sc->y); /* needed for closure_pars */ - } - set_curlet (sc, make_let (sc, sc->curlet)); - begin_temp (sc->v, make_closure_unchecked (sc, sc->y, body, T_CLOSURE, - n)); /* n = num pars */ - add_slot (sc, sc->curlet, car (sc->code), sc->v); - set_curlet (sc, make_let (sc, sc->curlet)); /* inner let */ - for (s7_pointer vars= sc->y; is_not_null (args); - vars= cdr (vars), args= cdr (args)) { - add_slot_unchecked_with_id (sc, sc->curlet, car (vars), - car_unchecked (args)); - vars= cdr (vars); - args= cdr (args); - if (is_null (args)) break; - add_slot_checked_with_id (sc, sc->curlet, car (vars), car_unchecked (args)); - } - closure_set_let (sc->v, sc->curlet); - let_set_slots (sc->curlet, reverse_slots (let_slots (sc->curlet))); - end_temp (sc->y); - end_temp (sc->v); - sc->code= T_Pair (body); -} - -static bool -op_let_1 ( - s7_scheme* - sc) { /* op_let form: (let ((i 0) (j 1)) (+ i j)), code: ((i 0) (j 1)), - * value: (((i 0) (j 1)) (+ i j)), args: () op_named_let: (let - * loop ((i 0)) (if (< i 3) (loop (+ i 1)) i)), code: ((i 0)), - * value: (loop ((i 0)) (if (< i 3) (loop (+ i 1)) i)), args: () - * eval->op_let_unchecked: (let ((i (catch #t (lambda () 1) - * (lambda (t i) 'error))) (j 2)) (+ i j))) (in a function), code: - * ((j 2)), value: 1, args: ((((i (catch #t (lambda () 1) (lambda - * (t i) 'error))) (j 2)) (+ i j))) - */ - /* true -> BEGIN, false -> EVAL */ - while (true) { - sc->args= cons (sc, sc->value, - sc->args); /* sc->value can be a mutable number here */ - if (is_pair (sc->code)) { - const s7_pointer val= cdar (sc->code); - if (has_fx (val)) sc->value= fx_call (sc, val); - else { - check_stack_size (sc); - push_stack (sc, OP_LET1, sc->args, cdr (sc->code)); /* come back here */ - sc->code= car (val); - return (false); /* goto EVAL */ - } - sc->code= cdr (sc->code); + set_gc_protected2(sc, fx_call(sc, args)); + args = cdr(args); + if (has_fx(args)) + { + set_gc_protected3(sc, fx_call(sc, args)); + return(closure_4p_end(sc, cdr(args))); + } + push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_3); + sc->code = car(args); } - else break; - } - sc->args= proper_list_reverse_in_place (sc, sc->args); - sc->code= car (sc->args); /* restore the original form */ - { - s7_pointer vals= cdr (sc->args); /* car=form */ - s7_int id; - sc->temp8= vals; - set_curlet (sc, make_let (sc, T_Let (sc->curlet))); - if (is_symbol (car (sc->code))) { - op_named_let_1 (sc, vals); /* inner let here */ - sc->temp8= sc->unused; - return (true); - } - id= let_id (sc->curlet); - if (is_pair (vals)) { - s7_pointer vars = car (sc->code); - s7_pointer last_slot= add_slot_unchecked_with_id ( - sc, sc->curlet, caar (vars), car_unchecked (vals)); - for (vars= cdr (vars), vals= cdr (vals); is_not_null (vals); - vars= cdr (vars), vals= cdr (vals)) - last_slot= add_slot_checked_at_end ( - sc, id, last_slot, caar (vars), - car_unchecked (vals)); /* not unchecked -- tlimit.scm */ + else + { + push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_2); + sc->code = car(args); } - } - sc->code = T_Pair (cdr (sc->code)); - sc->temp8= sc->unused; - return (true); /* goto BEGIN */ + return(false); } -static bool -op_let (s7_scheme* sc) /* from OP_LET */ +static bool op_any_closure_4p_2(s7_scheme *sc) /* sc->code: as above */ { - /* 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; - set_curlet (sc, make_let (sc, sc->curlet)); - if (named_let) /* see also below -- there are 3 cases */ - { - const s7_pointer body= cddr (sc->code); - set_opt2_int (cdr (sc->code), 0); - begin_temp (sc->y, - 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->y)); - funclet_set_function (closure_let (sc->y), car (sc->code)); - add_slot_checked (sc, sc->curlet, car (sc->code), sc->y); - set_curlet (sc, make_let (sc, sc->curlet)); /* inner let */ - sc->code= T_Pair (body); - end_temp (sc->y); - } - else sc->code= T_Pair (cdr (sc->code)); - return (true); /* goto BEGIN */ - } - sc->args= sc->nil; - /* value: (((i 0)) (+ i 1)), code: ((i 0)) */ - return (op_let_1 (sc)); /* sc->code == vars, sc->value = original sc->code */ -} - -static bool -op_let_unchecked ( - s7_scheme* sc) /* not named, but has vars, called from eval if looping via - op_let->op_let_1 + unopt'd args */ -{ - const s7_pointer code= cadr (sc->code); - const s7_pointer val = cdar (code); /* next arg */ - /* value: 0, code: ((radix (+ 2 (random 15)))) from (do ((i 0 (+ i 1))) ((= i - * 2)) (let ((j 0) (radix (+ 2 (random 15)))) (+ j radix))) on second - * iteration (i == 1) */ - sc->args= list_1 (sc, cdr (sc->code)); /* as if sc->value were this, then - absorbed into sc->args */ - if (has_fx (val)) sc->value= fx_call (sc, val); - else { - push_stack (sc, OP_LET1, sc->args, cdr (code)); - sc->code= car (val); - return (false); /* goto EVAL */ - } - sc->code= cdr (code); - return (op_let_1 (sc)); /* sc->args preset with code */ + const s7_pointer args = cdddr(sc->code); + set_gc_protected2(sc, sc->value); + if (has_fx(args)) + { + set_gc_protected3(sc, fx_call(sc, args)); + return(closure_4p_end(sc, cdr(args))); + } + push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_3); + sc->code = car(args); + return(false); } -static bool -op_named_let (s7_scheme* sc) { /* from eval */ - sc->args = sc->nil; - sc->value= cdr (sc->code); - sc->code = cadr (sc->value); - return (op_let_1 (sc)); /* sc->args is ()? */ -} - -static void -op_named_let_no_vars ( - s7_scheme* sc) { /* sc->code is full form (let name () ...) */ - const s7_pointer name= cadr (sc->code); - sc->code = opt1_pair (sc->code); /* cdddr(sc->code) == body */ - set_curlet (sc, inline_make_let (sc, sc->curlet)); - sc->args= make_closure_unchecked (sc, sc->nil, sc->code, T_CLOSURE, 0); - add_slot_checked (sc, sc->curlet, name, - sc->args); /* sc->args is a temp here */ - set_curlet (sc, make_let (sc, sc->curlet)); /* inner let */ - /* goto BEGIN */ +static bool op_any_closure_4p_3(s7_scheme *sc) /* sc->code: as above */ +{ + set_gc_protected3(sc, sc->value); + return(closure_4p_end(sc, cddddr(sc->code))); } -static void -op_named_let_a ( - s7_scheme* sc) { /* sc->code is the full form (let name vars...), par - pointers are preset in opt1|3(cdr(sc->code)) */ - const s7_pointer data= cdr (sc->code); - const s7_pointer par1= opt1_pair (data); /* cdaadr(args) == first par */ - sc->code = cddr (data); /* (vars ...) */ - sc->args = fx_call (sc, cdr (par1)); - set_curlet (sc, make_let (sc, sc->curlet)); /* funclet(?) */ - begin_temp (sc->y, - list_1_unchecked ( - sc, car (par1))); /* (list sym1), subsequent calls will need a - normal list of pars in closure_pars */ - begin_temp (sc->v, make_closure_unchecked ( - sc, sc->y, sc->code, T_CLOSURE, - 1)); /* picks up curlet (this is the funclet?) */ - add_slot (sc, sc->curlet, car (data), - sc->v); /* car(data) == the function name */ - set_curlet (sc, inline_make_let_with_slot (sc, sc->curlet, car (sc->y), - sc->args)); /* inner let */ - closure_set_let (sc->v, sc->curlet); - end_temp (sc->v); - end_temp (sc->y); - /* goto BEGIN */ +static inline void op_any_closure_4p_4(s7_scheme *sc) /* sc->code: as above */ +{ + const s7_pointer func = opt1_lambda(sc->code); + if (is_safe_closure(func)) + set_curlet(sc, update_let_with_four_slots(sc, closure_let(func), gc_protected1(sc), gc_protected2(sc), gc_protected3(sc), sc->value)); + else make_let_with_four_slots(sc, func, gc_protected1(sc), gc_protected2(sc), gc_protected3(sc), sc->value); + sc->code = T_Pair(closure_body(func)); + unstack_gc_protect(sc); } -static void -op_named_let_aa ( - s7_scheme* sc) { /* sc->code is the full form (let name vars...), par - pointers are preset in opt1|3(cdr(sc->code)) */ - const s7_pointer data= cdr (sc->code); - const s7_pointer par1= opt1_pair (data); /* cdaadr(data) == first par */ - const s7_pointer par2= opt3_pair (data); /* cdadadr == second */ - sc->code = cddr (data); /* (vars ...) */ - sc->args = fx_call (sc, cdr (par1)); - sc->value = fx_call (sc, cdr (par2)); - set_curlet (sc, make_let (sc, sc->curlet)); /* funclet below I think */ - begin_temp (sc->y, - list_2_unchecked ( - sc, car (par1), - car (par2))); /* (list sym1 sym2): subsequent calls will need - a normal list of pars in closure_pars */ - begin_temp (sc->v, make_closure_unchecked ( - sc, sc->y, sc->code, T_CLOSURE, - 2)); /* picks up curlet (this is the funclet?) */ - add_slot (sc, sc->curlet, car (data), - sc->v); /* car(data) == the function name */ - set_curlet (sc, inline_make_let_with_two_slots (sc, sc->curlet, car (sc->y), - sc->args, cadr (sc->y), - sc->value)); /* inner let */ - closure_set_let (sc->v, sc->curlet); - end_temp (sc->v); - end_temp (sc->y); - /* goto BEGIN */ +static void op_safe_closure_ss(s7_scheme *sc) /* sc->code: (g x y) */ +{ + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, update_let_with_two_slots(sc, closure_let(func), lookup(sc, cadr(sc->code)), lookup(sc, opt2_sym(sc->code)))); + sc->code = T_Pair(closure_body(func)); + push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); + sc->code = car(sc->code); } -static void -op_named_let_na (s7_scheme* sc) { - sc->code= cdr (sc->code); - sc->args= sc->nil; - for (s7_pointer p= cadr (sc->code); 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); - op_named_let_1 (sc, - sc->args); /* sc->code = (name vars . body), args = vals in - decl order, op_named_let_1 handles inner let */ - /* goto BEGIN */ +static void op_safe_closure_ss_o(s7_scheme *sc) /* sc->code: (_f_aq p e) */ +{ + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, update_let_with_two_slots(sc, closure_let(func), lookup(sc, cadr(sc->code)), lookup(sc, opt2_sym(sc->code)))); + sc->code = car(closure_body(func)); } -static void -op_let_no_vars (s7_scheme* sc) { - set_curlet (sc, inline_make_let (sc, sc->curlet)); - sc->code= T_Pair (cddr (sc->code)); /* ignore the () */ +static inline void op_closure_ss(s7_scheme *sc) /* sc->code: (A k B) */ +{ + const s7_pointer func = opt1_lambda(sc->code); + check_stack_size(sc); + set_curlet(sc, inline_make_let_with_two_slots(sc, closure_let(func), + car(closure_pars(func)), lookup(sc, cadr(sc->code)), + cadr(closure_pars(func)), lookup(sc, opt2_sym(sc->code)))); + sc->code = T_Pair(closure_body(func)); + push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); + sc->code = car(sc->code); } -static void -op_let_one_new (s7_scheme* sc) { - sc->code= cdr (sc->code); - /* check_stack_size(sc) -- needed if we're in an infinite loop -- maybe let it - * trigger "stack too big" instead */ - /* e.g. (let ((set! let*)) (let* set! ((x 1234) (y 1/2)) (let ((<1> (list 1 - * #f))) (set! (<1> 1) ...)))) */ - push_stack_no_args (sc, OP_LET_ONE_NEW_1, cdr (sc->code)); - sc->code= opt2_pair (sc->code); +static inline void op_closure_ss_o(s7_scheme *sc) /* sc->code: (c1 s i) */ +{ + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, inline_make_let_with_two_slots(sc, closure_let(func), + car(closure_pars(func)), lookup(sc, cadr(sc->code)), + cadr(closure_pars(func)), lookup(sc, opt2_sym(sc->code)))); + sc->code = car(closure_body(func)); } -static void -op_let_one_p_new (s7_scheme* sc) { - sc->code= cdr (sc->code); - check_stack_size (sc); /* hit in (lint "s7test.scm") */ - 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_safe_closure_sc(s7_scheme *sc) /* sc->code: (close3 x 2) */ +{ + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, update_let_with_two_slots(sc, closure_let(func), lookup(sc, cadr(sc->code)), opt2_con(sc->code))); + sc->code = T_Pair(closure_body(func)); + push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); + sc->code = car(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_safe_closure_sc_o(s7_scheme *sc) /* sc->code: (tree-member c d) */ +{ + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, update_let_with_two_slots(sc, closure_let(func), lookup(sc, cadr(sc->code)), opt2_con(sc->code))); + sc->code = car(closure_body(func)); } -static void -op_let_one_old_1 (s7_scheme* sc) { - s7_pointer 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_closure_sc(s7_scheme *sc) /* sc->code: (read-in-radix str 32) */ +{ + const s7_pointer func = opt1_lambda(sc->code); + check_stack_size(sc); + set_curlet(sc, make_let_with_two_slots(sc, closure_let(func), car(closure_pars(func)), lookup(sc, cadr(sc->code)), + cadr(closure_pars(func)), opt2_con(sc->code))); + sc->code = T_Pair(closure_body(func)); + push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); + sc->code = car(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 inline void op_closure_sc_o(s7_scheme *sc) /* sc->code: (f-1 abs 2) */ +{ + const s7_pointer func = opt1_lambda(sc->code); + check_stack_size(sc); + set_curlet(sc, inline_make_let_with_two_slots(sc, closure_let(func), car(closure_pars(func)), lookup(sc, cadr(sc->code)), + cadr(closure_pars(func)), opt2_con(sc->code))); + sc->code = car(closure_body(func)); } -static void -op_let_one_p_old_1 (s7_scheme* sc) { - s7_pointer 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_closure_3s(s7_scheme *sc) /* sc->code: (walk-rest caller form let) */ +{ + s7_pointer args = cdr(sc->code); + const s7_pointer arg1_val = lookup(sc, car(args)); + const s7_pointer func = opt1_lambda(sc->code); + args = cdr(args); + make_let_with_three_slots(sc, func, arg1_val, lookup(sc, car(args)), lookup(sc, cadr(args))); /* sets sc->curlet */ + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin(sc); } -static Inline void -inline_op_let_a_new (s7_scheme* sc) /* three calls in eval, all get hits */ +static inline void op_closure_3s_o(s7_scheme *sc) /* sc->code: (pretty-print-1 obj port column) */ { - sc->code= cdr (sc->code); - set_curlet ( - sc, inline_make_let_with_slot (sc, sc->curlet, car (opt2_pair (sc->code)), - fx_call (sc, cdr (opt2_pair (sc->code))))); + s7_pointer args = cdr(sc->code); + const s7_pointer arg1_val = lookup(sc, car(args)); + const s7_pointer func = opt1_lambda(sc->code); + args = cdr(args); + make_let_with_three_slots(sc, func, arg1_val, lookup(sc, car(args)), lookup(sc, cadr(args))); /* sets sc->curlet */ + sc->code = car(closure_body(func)); } -static Inline void -inline_op_let_a_old (s7_scheme* sc) /* tset(2) fb(0) cb(4) left(2) */ +static void op_closure_4s(s7_scheme *sc) /* sc->code: (Cholesky:add-element P L i j) */ { - 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); + s7_pointer args = cdr(sc->code); + const s7_pointer arg1_val = lookup(sc, car(args)), arg2_val = lookup(sc, cadr(args)); + const s7_pointer func = opt1_lambda(sc->code); + args = cddr(args); + make_let_with_four_slots(sc, func, arg1_val, arg2_val, lookup(sc, car(args)), lookup(sc, cadr(args))); /* sets sc->curlet */ + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin(sc); } -static inline void -op_let_a_old (s7_scheme* sc) { - inline_op_let_a_old (sc); +static inline void op_closure_4s_o(s7_scheme *sc) /* sc->code: (make-collector into oper tail head) */ +{ + s7_pointer args = cdr(sc->code); + const s7_pointer arg1_val = lookup(sc, car(args)), arg2_val = lookup(sc, cadr(args)); + const s7_pointer func = opt1_lambda(sc->code); + args = cddr(args); + make_let_with_four_slots(sc, func, arg1_val, arg2_val, lookup(sc, car(args)), lookup(sc, cadr(args))); /* sets sc->curlet */ + sc->code = car(closure_body(func)); } -static void -op_let_a_a_new (s7_scheme* sc) { - s7_pointer binding, let; - sc->code= cdr (sc->code); - binding = opt2_pair (sc->code); - let = wrap_let_with_slot ( - sc, sc->curlet, car (binding), - fx_call (sc, - cdr (binding))); /* wrap maybe unsafe here (see snd-24.3/s7.c */ - set_curlet (sc, let); - sc->value= fx_call (sc, cdr (sc->code)); - let_set_slots (let, slot_end); +static void op_closure_5s(s7_scheme *sc) /* .1 in lg but this is marginal -- adds two ops etc, sc->code: (key-parse-clause d mode args argn user) */ +{ + s7_pointer args = cdr(sc->code); + const s7_pointer arg1_val = lookup(sc, car(args)), arg2_val = lookup(sc, cadr(args)); + const s7_pointer func = opt1_lambda(sc->code); + args = cddr(args); + make_let_with_five_slots(sc, func, arg1_val, arg2_val, lookup(sc, car(args)), lookup(sc, cadr(args)), lookup(sc, caddr(args))); /* sets sc->curlet */ + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin(sc); } -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) */ +static void op_safe_closure_aa(s7_scheme *sc) /* sc->code: (close3 1 2) */ { - inline_op_let_a_old (sc); - sc->value= fx_call (sc, cdr (sc->code)); + s7_pointer args = cdr(sc->code), body; + const s7_pointer func = opt1_lambda(sc->code); + sc->code = fx_call(sc, cdr(args)); /* fx_call can affect sc->value, but not sc->code, I think */ + set_curlet(sc, update_let_with_two_slots(sc, closure_let(func), fx_call(sc, args), sc->code)); + body = T_Pair(closure_body(func)); + /* check_stack_size(sc); */ /* pretty-print if cycles=#f? */ + push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(body))); + sc->code = car(body); } -static void -op_let_a_na_new (s7_scheme* sc) { - s7_pointer binding, p; - sc->code= cdr (sc->code); - binding = opt2_pair (sc->code); - set_curlet (sc, wrap_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); -} - -/* 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_na_old (s7_scheme* sc) { - s7_pointer p; - inline_op_let_a_old (sc); - 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_safe_closure_aa_o(s7_scheme *sc) /* sc->code: (tree-member 1 '(2 3 (4 1) 5)) */ +{ + const s7_pointer args = cdr(sc->code); + const s7_pointer func = opt1_lambda(sc->code); + sc->code = fx_call(sc, cdr(args)); + set_curlet(sc, update_let_with_two_slots(sc, closure_let(func), fx_call(sc, args), sc->code)); + sc->code = car(closure_body(func)); + /* (let values ((x 1) (y 2)) (values 1 2)): sc->code incoming is 0x7fffbf681c98 (values 1 2), car(closure_body) out is the same -> infinite loop! */ } -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_closure_aa(s7_scheme *sc) /* sc->code: (substring? "hiho" "test hih") */ +{ + s7_pointer args = cdr(sc->code), body; + const s7_pointer func = opt1_lambda(sc->code); + sc->code = fx_call(sc, cdr(args)); + sc->value = fx_call(sc, args); + set_curlet(sc, inline_make_let_with_two_slots(sc, closure_let(func), car(closure_pars(func)), sc->value, cadr(closure_pars(func)), sc->code)); + body = T_Pair(closure_body(func)); + check_stack_size(sc); + push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(body))); + sc->code = car(body); +} + +static Inline void inline_op_closure_aa_o(s7_scheme *sc) /* called once in eval, b cb left lg list, sc->code: (ack1 m (- n 1)) */ +{ + const s7_pointer args = cdr(sc->code); + const s7_pointer func = opt1_lambda(sc->code); + sc->code = fx_call(sc, cdr(args)); + sc->value = fx_call(sc, args); + set_curlet(sc, inline_make_let_with_two_slots(sc, closure_let(func), car(closure_pars(func)), sc->value, cadr(closure_pars(func)), sc->code)); + sc->code = car(closure_body(func)); } -static inline 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 /* inline */ void op_closure_fa(s7_scheme *sc) /* "inline" matters perhaps in texit.scm, sc->code: (f8 (lambda (x) (+ x 1)) 1) */ +{ + s7_pointer new_clo; + const s7_pointer code = sc->code; + const s7_pointer farg = opt2_pair(code); /* cdadr(code), '((a . b) (cons a b)) for (lambda (a . b) (cons a b)) */ + const s7_pointer aarg = fx_call(sc, cddr(code)); + const s7_pointer func = opt1_lambda(code); /* outer func */ + const s7_pointer func_pars = closure_pars(func); /* outer func pars (not the arglist of the applied func) */ + sc->value = inline_make_let_with_two_slots(sc, closure_let(func), car(func_pars), sc->F, cadr(func_pars), aarg); + new_clo = make_closure_unchecked(sc, car(farg), cdr(farg), T_CLOSURE | ((!s7_is_proper_list(sc, car(farg))) ? T_COPY_ARGS : 0), CLOSURE_ARITY_NOT_SET); + /* this is checking the called closure arglist (see op_lambda), arity<0 probably not usable since "f" in "fa" is a parameter */ + slot_set_value(let_slots(sc->value), new_clo); /* this order allows us to use make_closure_unchecked */ + set_curlet(sc, sc->value); + sc->code = car(closure_body(func)); +} + +static void op_safe_closure_ns(s7_scheme *sc) /* sc->code: (slot var expr env expr-env) */ +{ + const s7_pointer func = opt1_lambda(sc->code); + const s7_pointer let = closure_let(func); + const s7_int id = ++sc->let_number; + let_set_id(let, id); + for (s7_pointer args = cdr(sc->code), slot = let_slots(let); is_not_slot_end(slot); slot = next_slot(slot), args = cdr(args)) + { + slot_set_value(slot, lookup(sc, car(args))); + symbol_set_local_slot(slot_symbol(slot), id, slot); + } + set_curlet(sc, let); + sc->code = closure_body(func); + if_pair_set_up_begin_unchecked(sc); } -static inline void -op_let_opassq_new (s7_scheme* sc) { - op_let_opassq (sc); - set_curlet (sc, inline_make_let_with_slot (sc, sc->curlet, - opt1_sym (sc->code), sc->value)); - sc->code= T_Pair (cdr (sc->code)); +static inline void op_safe_closure_3a(s7_scheme *sc) /* sc->code: (f8 0 0 (list 1)) */ +{ + const s7_pointer args = cdr(sc->code); + const s7_pointer func = opt1_lambda(sc->code); + sc->code = fx_call(sc, cdr(args)); /* fx_call can affect sc->value, but not sc->code, I think */ + sc->args = fx_call(sc, cddr(args)); /* is sc->args safe here? */ + set_curlet(sc, update_let_with_three_slots(sc, closure_let(func), fx_call(sc, args), sc->code, sc->args)); + sc->code = closure_body(func); + if_pair_set_up_begin_unchecked(sc); } -static Inline void -inline_op_let_na_new (s7_scheme* sc) /* called once in eval, case gsl lg mock */ +static void op_safe_closure_na(s7_scheme *sc) /* sc->code: (hi 1 2 3 4) */ { 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); - let_set_outlet (let, T_Let (sc->curlet)); - sc->args= let; - for (s7_pointer p= cadr (sc->code), last_slot= NULL; is_pair (p); - p= cdr (p)) { - const s7_pointer arg= cdar (p); - sc->value = fx_call (sc, arg); - if (!last_slot) { - add_slot (sc, let, caar (p), sc->value); - last_slot= let_slots (let); + s7_int id; + sc->args = safe_list_if_possible(sc, opt3_arglen(cdr(sc->code))); + for (s7_pointer 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 (s7_pointer slot = let_slots(let), vals = sc->args; is_not_slot_end(slot); slot = next_slot(slot), vals = cdr(vals)) + { + slot_set_value(slot, car(vals)); + symbol_set_local_slot(slot_symbol(slot), id, slot); } - else - last_slot= - add_slot_at_end (sc, let_id (let), last_slot, caar (p), sc->value); - } - sc->let_number++; - set_curlet (sc, let); - sc->code= T_Pair (cddr (sc->code)); -} - -static void -op_let_na_old (s7_scheme* sc) { - const s7_pointer let= opt3_let (cdr (sc->code)); - const s7_int id = ++sc->let_number; - sc->args = let; /* GC protection */ - let_set_id (let, id); - let_set_outlet (let, sc->curlet); - for (s7_pointer p= cadr (sc->code), slot= let_slots (let); is_pair (p); - p= cdr (p), slot= next_slot (slot)) { - 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 */ -{ - const s7_pointer code= cdr (sc->code); - const s7_pointer a1 = opt1_pair (code); /* caar(code) */ - const s7_pointer a2 = opt2_pair (code); /* cadar(code) */ - check_stack_size (sc); /* added 15-Jul-25 for srfi-1 filter of huge list */ - gc_protect_via_stack (sc, fx_call (sc, cdr (a1))); - set_gc_protected2 (sc, fx_call (sc, cdr (a2))); - set_curlet (sc, inline_make_let_with_two_slots (sc, sc->curlet, car (a1), - gc_protected1 (sc), car (a2), - gc_protected2 (sc))); - unstack_gc_protect (sc); - sc->code= cadr (code); -} - -static inline void -op_let_2a_old (s7_scheme* sc) /* 2 vars, 1 expr in body */ -{ - s7_pointer code= cdr (sc->code); - s7_pointer 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 */ -{ - const s7_pointer code= cdr (sc->code); - const s7_pointer a1 = caar (code); - const s7_pointer a2 = opt1_pair (code); /* cadar */ - const s7_pointer a3 = opt2_pair (code); /* caddar */ - gc_protect_via_stack ( - sc, fx_call (sc, cdr (a1))); /* fx_call might be fx_car_t (etc) so it - needs to precede the new let */ - set_gc_protected2 (sc, fx_call (sc, cdr (a2))); - set_curlet (sc, inline_make_let_with_two_slots (sc, sc->curlet, car (a2), - gc_protected2 (sc), car (a3), - fx_call (sc, cdr (a3)))); - add_slot (sc, sc->curlet, car (a1), gc_protected1 (sc)); - unstack_gc_protect (sc); - sc->code= cadr (code); -} - -static void -op_let_3a_old (s7_scheme* sc) /* 3 vars, 1 expr in body */ -{ - const s7_pointer code= cdr (sc->code); - s7_pointer 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); + if (!in_heap(sc->args)) clear_safe_list_in_use(sc, sc->args); + set_curlet(sc, let); + sc->code = closure_body(sc->code); + if_pair_set_up_begin_unchecked(sc); } -/* -------------------------------- let* -------------------------------- */ -static bool -check_let_star (s7_scheme* sc) { - s7_pointer vars; - const s7_pointer form= sc->code, code= cdr (sc->code); - bool named_let, fxable= true, shadowing= false; - - if (!is_pair (code)) /* (let* . 1) */ - syntax_error_nr (sc, "let* variable list is messed up: ~A", 35, form); - if (!is_pair (cdr (code))) /* (let* ()) */ - syntax_error_nr (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) */ - syntax_error_nr (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))) - syntax_error_nr (sc, "named let* has no body: ~A", 26, form); - syntax_error_nr (sc, "named let* stray dot? ~A", 24, form); - } - if (is_constant_symbol (sc, car (code))) - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_3 (sc, cant_bind_immutable_string, - sc->let_star_symbol, form)); - set_local (car (code)); - } - else if (!is_list (car (code))) /* (let* x ... ) */ - syntax_error_nr (sc, "let* variable declaration value is missing: ~A", 46, - form); - - begin_small_symbol_set (sc); - for (vars= ((named_let) ? cadr (code) : car (code)); is_pair (vars); - vars= cdr (vars)) { - s7_pointer var; - const s7_pointer var_and_val= car (vars); - if (!is_pair (var_and_val)) /* (let* (3) ... */ - { - /* does (let* loop ((i 0) :allow-other-keys) i) make sense? - * - * (let* name ((i 0) :allow-other-keys) i) - * check_let_star[79760]: got :allow-other-keys - * let* variable list, :allow-other-keys, is messed up in (let* name ((i - * 0) :allow-other-keys) i) - * - * (let* name ((i 0) . others) i) - * 79802(9): let* variable list is not a proper list: others in (let* - * name ((i 0) . others) i) - * - * (let* name others others) - * 79738: let* variable list is messed up: (let* name others others) - * - * (let* name ((i 0) :rest b) b) - * check_let_star[79760]: got :rest - * let* variable list, :rest, is messed up in (let* name ((i 0) :rest b) - * b) - * - * what about (let* name ((i 0) :allow-other-keys) ... (name :x 2 3)) -- - * is i=3? (it is in define*: (define* (f (i 0) :allow-other-keys) i) (f - * :x 2 3): 3) -- so other-keys are completely ignored? but (define* (f (a - * 1) (b 2)) (list a b)), (f :b 12 3): parameter set twice, b in (:b 12 3) - * t_allow_other_keys is set on arglists and c_function_star (? clo*?) -- - * let* makes t_closure_star - */ - error_nr (sc, sc->syntax_error_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, "let* variable list, ~A, is messed up in ~A", 42), - var_and_val, object_to_string_truncated (sc, form))); - } - if (!is_pair (cdr (var_and_val))) /* (let* ((x . 1))...) */ - { - if (is_null (cdr (var_and_val))) - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, "let* variable declaration, but no value?: ~A in ~A", - 50), - var_and_val, object_to_string_truncated (sc, form))); - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, - "let* variable declaration is not a proper list: ~A in ~A", - 56), - var_and_val, object_to_string_truncated (sc, form))); - } - if (!is_null (cddr (var_and_val))) /* (let* ((c 1 2)) ...) */ - error_nr (sc, sc->syntax_error_symbol, - set_elist_3 (sc, - wrap_string (sc, - "let* variable declaration has more " - "than one value?: ~A in ~A", - 60), - var_and_val, - object_to_string_truncated (sc, form))); - var= car (var_and_val); - if (!is_symbol (var)) /* (let* ((3 1)) 1) */ - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_4 ( - sc, - wrap_string ( - sc, - "bad variable name ~W in let* (it is ~A, not a symbol) in ~A", - 59), - var, object_type_name (sc, var), - object_to_string_truncated (sc, form))); - if (is_constant_symbol (sc, var)) /* (let* ((pi 3)) ...) */ - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_3 (sc, cant_bind_immutable_string, - sc->let_star_symbol, var_and_val)); - - if (symbol_is_in_small_symbol_set (sc, var)) { - if (named_let) /* (let* loop ((a 1) (a 2)) ...) -- added 2-Dec-19 */ - error_nr (sc, sc->syntax_error_symbol, - set_elist_3 (sc, - wrap_string (sc, - "named let* parameter, ~A, is used " - "twice in the parameter list in ~A", - 67), - var, object_to_string_truncated (sc, form))); - /* currently (let* ((a 1) (a (+ a 1))) a) is 2, not an error */ - shadowing= true; - } - add_symbol_to_small_symbol_set (sc, var); - set_local (var); - } - end_small_symbol_set (sc); - if (!is_null (vars)) - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, "let* variable list is not a proper list: ~A in ~A", 49), - vars, object_to_string_truncated (sc, form))); - if (!s7_is_proper_list (sc, cdr (code))) - syntax_error_nr (sc, "stray dot in let* body: ~S", 26, cdr (code)); - - if (shadowing) fxable= false; - else - 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))); - } - sc->value= cdr (code); - if (is_null (car (sc->value))) /* (let* name () ... */ - { - const s7_pointer let_sym= car (code); - set_curlet (sc, make_let (sc, sc->curlet)); - sc->code= T_Pair (cdr (sc->value)); - add_slot_checked ( - sc, sc->curlet, let_sym, - make_closure_unchecked (sc, sc->nil, sc->code, T_CLOSURE_STAR, 0)); - set_curlet (sc, make_let (sc, sc->curlet)); /* inner let */ - return (false); - } - set_curlet (sc, make_let (sc, sc->curlet)); - push_stack (sc, OP_LET_STAR1, code, cadr (code)); - sc->code= cadr (caadr (code)); /* first var val */ - return (true); - } - if (is_null (car (code))) { - pair_set_syntax_op (form, OP_LET_NO_VARS); /* (let* () ...) */ - set_curlet (sc, make_let (sc, sc->curlet)); - sc->code= T_Pair (cdr (code)); - return (false); - } - else if (is_null (cdar (code))) { - check_let_one_var ( - sc, form, car (code)); /* (let* ((var...))...) -> (let ((var...))...) */ - if (optimize_op (form) >= OP_LET_NA_OLD) { - if ((!in_heap (form)) && - (wrapped_body_is_safe (sc, sc->unused, cdr (code), true) >= - safe_body)) - set_opt3_let (code, make_semipermanent_let (sc, car (code))); - else { - set_optimize_op (form, optimize_op (form) + 1); /* *_old -> *_new */ - set_opt3_let (code, sc->rootlet); - } - } - } - else /* multiple variables */ - { - if (fxable) { - pair_set_syntax_op (form, OP_LET_STAR_NA); - 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_NA_A); - } - } - else pair_set_syntax_op (form, OP_LET_STAR2); - set_opt2_con (code, cadaar (code)); - } - push_stack (sc, - ((intptr_t) ((shadowing) ? OP_LET_STAR_SHADOWED : 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 bool -op_let_star_shadowed (s7_scheme* sc) { - while (true) { - set_curlet (sc, inline_make_let_with_slot (sc, sc->curlet, caar (sc->code), - sc->value)); - sc->code= cdr (sc->code); - if (is_pair (sc->code)) { - const s7_pointer val= cdar (sc->code); - if (has_fx (val)) sc->value= fx_call (sc, val); - else { - push_stack_direct (sc, OP_LET_STAR_SHADOWED); - sc->code= car (val); - return (true); - } - } - else break; - } - sc->code= cdr (sc->args); /* original sc->code set in push_stack above */ - return (false); -} - -static /* inline */ bool -op_let_star1 (s7_scheme* sc) { - s7_uint let_counter= S7_INT64_MAX; - s7_pointer last_slot = NULL; - while (true) { - if (let_counter == sc->capture_let_counter) { - if (last_slot == NULL) { - add_slot_checked (sc, sc->curlet, caar (sc->code), sc->value); - last_slot= let_slots (sc->curlet); - } - else - last_slot= add_slot_checked_at_end (sc, let_id (sc->curlet), last_slot, - caar (sc->code), - sc->value); /* was unchecked */ - } - else { - set_curlet (sc, inline_make_let_with_slot (sc, sc->curlet, - caar (sc->code), sc->value)); - last_slot = let_slots (sc->curlet); - let_counter= sc->capture_let_counter; - } - sc->code= cdr (sc->code); - if (is_pair (sc->code)) { - const s7_pointer val= cdar (sc->code); - if (has_fx (val)) sc->value= fx_call (sc, val); - else { - push_stack_direct (sc, OP_LET_STAR1); - sc->code= car (val); - return (true); - } - } - else break; - } - sc->code= sc->args; /* original sc->code set in push_stack above */ - if (is_symbol (car (sc->code))) { - const s7_pointer name= car (sc->code), body= cddr (sc->code), - args= cadr (sc->code); - /* now we need to declare the new function (in the outer let) -- must delay - * this because init might reference same-name outer func */ - /* but the let name might be shadowed by a variable: (let* x ((x 1))...) - * so the name's symbol_id can be incorrect */ - begin_temp (sc->x, make_closure_unchecked ( - sc, args, body, T_CLOSURE_STAR, - (is_null (args)) ? 0 : CLOSURE_ARITY_NOT_SET)); - if (symbol_id (name) > let_id (let_outlet (sc->curlet))) { - const s7_int cur_id = symbol_id (name); - const s7_pointer cur_slot= local_slot (name); - symbol_set_id_unchecked (name, let_id (let_outlet (sc->curlet))); - add_slot_checked (sc, let_outlet (sc->curlet), name, sc->x); - symbol_set_id_unchecked (name, cur_id); - set_local_slot (name, cur_slot); - } - else add_slot_checked (sc, let_outlet (sc->curlet), name, sc->x); - end_temp (sc->x); - sc->code= body; - } - else sc->code= T_Pair (cdr (sc->code)); - return (false); -} - -static void -op_let_star_na (s7_scheme* sc) { - /* fx safe does not mean we can dispense with the inner lets (curlet is safe - * for example) */ - s7_uint let_counter= S7_INT64_MAX; - sc->code = cdr (sc->code); - for (s7_pointer last_slot= NULL, vars= car (sc->code); is_pair (vars); - vars= cdr (vars)) { - const s7_pointer binding= car (vars); - const s7_pointer val= fx_call (sc, cdr (binding)); /* eval in outer let */ - if (let_counter == sc->capture_let_counter) { - if (!last_slot) { - add_slot_checked (sc, sc->curlet, car (binding), val); - last_slot= let_slots (sc->curlet); - } - else - last_slot= add_slot_at_end (sc, let_id (sc->curlet), last_slot, - car (binding), val); - } - else { - set_curlet ( - sc, inline_make_let_with_slot (sc, sc->curlet, car (binding), val)); - last_slot = let_slots (sc->curlet); - let_counter= sc->capture_let_counter; - } - } - sc->code= T_Pair (cdr (sc->code)); -} - -static void -op_let_star_na_a (s7_scheme* sc) { - s7_uint let_counter= S7_INT64_MAX; - sc->code = cdr (sc->code); - for (s7_pointer last_slot= NULL, vars= car (sc->code); is_pair (vars); - vars= cdr (vars)) { - const s7_pointer binding= car (vars); - const s7_pointer val = fx_call (sc, cdr (binding)); - if (let_counter == sc->capture_let_counter) { - if (!last_slot) { - add_slot_checked (sc, sc->curlet, car (binding), val); - last_slot= let_slots (sc->curlet); - } - else - last_slot= add_slot_at_end (sc, let_id (sc->curlet), last_slot, - car (binding), val); - } - else { - set_curlet ( - sc, inline_make_let_with_slot (sc, sc->curlet, car (binding), val)); - last_slot = let_slots (sc->curlet); - let_counter= sc->capture_let_counter; - } - } - sc->value= fx_call (sc, cdr (sc->code)); +static /* inline */ void op_closure_ns(s7_scheme *sc) /* called once in eval, lg?, sc->code: (A k B x1 x2 x3 x4 x5) */ +{ + /* 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. + */ + s7_pointer args = cdr(sc->code), last_slot; + const s7_pointer func = opt1_lambda(sc->code); + const s7_pointer pars = closure_pars(func); + const s7_pointer let = inline_make_let(sc, closure_let(func)); + const s7_int id = let_id(let); + begin_temp(sc->y, let); + add_slot_unchecked(sc, let, car(pars), lookup(sc, car(args)), id); + last_slot = let_slots(let); + args = cdr(args); + for (s7_pointer p1 = cdr(pars); is_pair(p1); p1 = cdr(p1), args = cdr(args)) + last_slot = add_slot_at_end(sc, id, last_slot, car(p1), lookup(sc, car(args))); /* main such call in lt (fx_s is 1/2, this is 1/5 of all calls) */ + set_curlet(sc, let); + end_temp(sc->y); + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin(sc); +} + +static void op_closure_ass(s7_scheme *sc) /* possibly inline b, sc->code: (recompose 32 reverse x) */ +{ + const s7_pointer args = cdr(sc->code); + const s7_pointer func = opt1_lambda(sc->code); + make_let_with_three_slots(sc, func, fx_call(sc, args), lookup(sc, cadr(args)), lookup(sc, caddr(args))); + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin(sc); } -static void -op_named_let_star (s7_scheme* sc) { - s7_pointer code= cdr (sc->code); /* code: (name vars ...) */ - set_curlet (sc, make_let (sc, sc->curlet)); - push_stack (sc, OP_LET_STAR1, code, cadr (code)); - sc->code= opt2_con (code); +static void op_closure_aas(s7_scheme *sc) /* possibly inline b, sc->code: (recur-cond-a-a-a-a-opl3a-l3aq-23 (- x 1) (+ y 1) z) */ +{ + const s7_pointer args = cdr(sc->code); + const s7_pointer func = opt1_lambda(sc->code); + sc->z = fx_call(sc, args); + make_let_with_three_slots(sc, func, sc->z, fx_call(sc, cdr(args)), lookup(sc, caddr(args))); + sc->z = sc->unused; + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin(sc); } -static void -op_let_star2 (s7_scheme* sc) { - s7_pointer code= cdr (sc->code); - /* check_stack_size(sc); */ /* t101-42 but commented out */ - 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) { - const s7_pointer code= cdr (sc->code); - const s7_pointer caller= - (letrec) ? sc->letrec_symbol : sc->letrec_star_symbol; - - if ((!is_pair (code)) || /* (letrec . 1) */ - (!is_list (car (code)))) /* (letrec 1 ...) */ - syntax_error_with_caller_nr (sc, "~A: variable list is messed up: ~A", 34, - caller, sc->code); - - if (!is_pair (cdr (code))) /* (letrec ()) */ - syntax_error_with_caller_nr (sc, "~A has no body: ~A", 18, caller, - sc->code); - - begin_small_symbol_set (sc); - for (s7_pointer vars= car (code); is_not_null (vars); vars= cdr (vars)) { - s7_pointer sym, var; - if (!is_pair (vars)) /* (letrec ((a 1) . 2) ...) */ - syntax_error_with_caller_nr (sc, "~A: improper list of variables? ~A", 34, - caller, sc->code); - - var= car (vars); - if (!is_pair (var)) /* (letrec (1 2) #t) */ - syntax_error_with_caller_nr ( - sc, "~A: bad variable ~S (should be a pair (name value))", 51, caller, - var); - - sym= car (var); - if (!is_symbol (sym)) - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_5 ( - sc, - wrap_string ( - sc, - "bad variable name ~W in ~A (it is ~A, not a symbol) in ~A", - 57), - sym, caller, object_type_name (sc, sym), - object_to_string_truncated (sc, sc->code))); - if (is_constant_symbol (sc, sym)) - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_3 (sc, cant_bind_immutable_string, caller, vars)); - - if (!is_pair (cdr (var))) /* (letrec ((x . 1))...) */ - { - if (is_null (cdr (var))) /* (letrec ((x)) x) */ - syntax_error_with_caller_nr ( - sc, "~A: variable declaration has no value?: ~A", 42, caller, var); - syntax_error_with_caller_nr ( - sc, "~A: variable declaration is not a proper list?: ~A", 50, caller, - var); - } - if (is_not_null (cddr (var))) /* (letrec ((x 1 2 3)) ...) */ - syntax_error_with_caller_nr ( - sc, "~A: variable declaration has more than one value?: ~A", 53, - caller, var); - - /* 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_small_symbol_set (sc, sym)) - syntax_error_with_caller_nr (sc, "~A: duplicate identifier: ~A", 28, - caller, sym); - add_symbol_to_small_symbol_set (sc, sym); - set_local (sym); - } - end_small_symbol_set (sc); - - if (!s7_is_proper_list (sc, cdr (code))) - syntax_error_with_caller_nr (sc, "stray dot in ~A body: ~S", 24, caller, - cdr (code)); - - for (s7_pointer vars= 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_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) { - for (s7_pointer slot= let_slots (sc->curlet); is_not_slot_end (slot); - slot = next_slot (slot)) - if (is_closure (slot_value (slot))) { - const 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_pars (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)); - } +static void op_closure_saa(s7_scheme *sc) /* sc->code: (f h1 b1 :a) */ +{ + const s7_pointer args = cdr(sc->code); + const s7_pointer func = opt1_lambda(sc->code); + sc->z = fx_call(sc, cdr(args)); + make_let_with_three_slots(sc, func, lookup(sc, car(args)), sc->z, fx_call(sc, cddr(args))); + sc->z = sc->unused; + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin(sc); } -static void -op_letrec2 (s7_scheme* sc) { - for (s7_pointer slot= let_slots (sc->curlet); is_not_slot_end (slot); - slot = next_slot (slot)) - if (is_checked_slot (slot)) - slot_set_value (slot, slot_pending_value (slot)); - letrec_setup_closures (sc); +static void op_closure_asa(s7_scheme *sc) /* sc->code: (recompose 12 char-downcase #\A) */ +{ + const s7_pointer args = cdr(sc->code); + const s7_pointer func = opt1_lambda(sc->code); + sc->z = fx_call(sc, args); + make_let_with_three_slots(sc, func, sc->z, lookup(sc, cadr(args)), fx_call(sc, cddr(args))); + sc->z = sc->unused; + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin(sc); } -static bool -op_letrec_unchecked (s7_scheme* sc) { - const 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 -- it is #. - * 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) - */ - set_curlet (sc, make_let (sc, sc->curlet)); - if (is_pair (car (code))) { - s7_pointer slot; - for (s7_pointer vars= car (code); is_not_null (vars); vars= cdr (vars)) { - slot= add_slot_checked (sc, sc->curlet, caar (vars), sc->undefined); - slot_set_pending_value (slot, sc->undefined); - slot_set_expression (slot, cdar (vars)); - set_checked_slot (slot); - } - for (slot= let_slots (sc->curlet); - is_not_slot_end (slot) && (has_fx (slot_expression (slot))); - slot= next_slot (slot)) - slot_set_pending_value (slot, fx_call (sc, slot_expression (slot))); - if (is_not_slot_end (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 void op_closure_sas(s7_scheme *sc) /* sc->code: (parse-clauses forms () ops) */ +{ + const s7_pointer args = cdr(sc->code); + const s7_pointer func = opt1_lambda(sc->code); + make_let_with_three_slots(sc, func, lookup(sc, car(args)), fx_call(sc, cdr(args)), lookup(sc, caddr(args))); + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin(sc); } -static bool -op_letrec1 (s7_scheme* sc) { - s7_pointer slot; - slot_set_pending_value (sc->args, sc->value); - for (slot= next_slot (sc->args); - is_not_slot_end (slot) && (has_fx (slot_expression (slot))); - slot= next_slot (slot)) - slot_set_pending_value (slot, fx_call (sc, slot_expression (slot))); - if (is_not_slot_end (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 inline void op_closure_3a(s7_scheme *sc) /* if inlined, tlist -60, sc->code: (func (- a 1) (- b 1) (- c 1)) */ +{ + const s7_pointer args = cdr(sc->code); + const s7_pointer func = 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, func, gc_protected1(sc), gc_protected2(sc), fx_call(sc, cddr(args))); + unstack_gc_protect(sc); + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin(sc); } -static bool -op_letrec_star_unchecked (s7_scheme* sc) { - const s7_pointer 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 - */ - set_curlet (sc, make_let (sc, sc->curlet)); - if (is_pair (car (code))) { - s7_pointer slot; - for (s7_pointer vars= car (code); is_not_null (vars); vars= cdr (vars)) { - slot= add_slot_checked (sc, sc->curlet, caar (vars), sc->undefined); - slot_set_expression (slot, cdar (vars)); - } - let_set_slots (sc->curlet, reverse_slots (let_slots (sc->curlet))); - - for (slot= let_slots (sc->curlet); - is_not_slot_end (slot) && (has_fx (slot_expression (slot))); - slot= next_slot (slot)) - slot_set_value (slot, fx_call (sc, slot_expression (slot))); - if (is_not_slot_end (slot)) { - push_stack (sc, OP_LETREC_STAR1, slot, code); - sc->code= car (slot_expression (slot)); - return (true); +static void op_closure_4a(s7_scheme *sc) /* sass, sc->code: (reinvert 12 vector->list... */ +{ + s7_pointer args = cdr(sc->code); + const s7_pointer func = opt1_lambda(sc->code); + gc_protect_2_via_stack(sc, fx_call(sc, args), fx_call(sc, cddr(args))); + args = cdr(args); + set_gc_protected3(sc, fx_call(sc, args)); + make_let_with_four_slots(sc, func, gc_protected1(sc), gc_protected3(sc), gc_protected2(sc), fx_call(sc, cddr(args))); + unstack_gc_protect(sc); + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin(sc); +} + +static void op_closure_na(s7_scheme *sc) /* sc->code: (f1 0 "a" L1 V1 S1 H1 E1) */ +{ + const s7_pointer exprs = cdr(sc->code); /* "n" = opt3_arglen(exprs), mostly 5 in lt, 6 in tlet */ + const s7_pointer func = opt1_lambda(sc->code); + const s7_pointer pars = closure_pars(func); + const s7_pointer let = inline_make_let(sc, closure_let(func)); + s7_pointer slot, last_slot; + sc->z = let; + sc->value = fx_call(sc, exprs); + new_cell_unchecked(sc, last_slot, T_SLOT); + slot_set_symbol_and_value(last_slot, car(pars), sc->value); + slot_set_next(last_slot, let_slots(let)); /* i.e. slot_end */ + let_set_slots(let, last_slot); + for (s7_pointer par = cdr(pars), expr = cdr(exprs); is_pair(par); par = cdr(par), expr = cdr(expr)) + { + sc->value = fx_call(sc, expr); /* 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(par), 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); + slot_set_next(last_slot, slot); + last_slot = slot; + } + set_curlet(sc, let); + sc->z = sc->unused; + let_set_id(let, ++sc->let_number); + for (s7_pointer slot1 = let_slots(let); is_not_slot_end(slot1); slot1 = next_slot(slot1)) + { + symbol_set_local_slot(slot_symbol(slot1), let_id(let), slot1); + set_local(slot_symbol(slot1)); } - } - 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); - is_not_slot_end (slot) && (has_fx (slot_expression (slot))); - slot= next_slot (slot)) - slot_set_value (slot, fx_call (sc, slot_expression (slot))); - if (is_not_slot_end (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) { - const s7_pointer form= sc->code, code= cdr (sc->code); - bool all_fx, all_s7; - - if ((!is_pair (code)) || /* (let-temporarily . 1) */ - (!is_list (car (code)))) /* (let-temporarily 1 ...) */ - syntax_error_nr (sc, "let-temporarily: variable list is messed up: ~A", 47, - form); - /* cdr(code) = body can be nil */ + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin(sc); +} - all_fx= is_pair (car (code)); - all_s7= all_fx; - - for (s7_pointer vars= car (code); is_not_null (vars); vars= cdr (vars)) { - s7_pointer var, sym; - if (!is_pair (vars)) /* (let-temporarily ((a 1) . 2) ...) */ - syntax_error_nr (sc, "let-temporarily: improper list of variables? ~A", - 47, form); - - var= car (vars); - if (!is_pair (var)) /* (let-temporarily (1 2) #t) */ - syntax_error_nr ( - sc, - "let-temporarily: bad variable ~S (it should be a pair (name value))", - 67, var); - - sym= car (var); - if (is_symbol (sym)) { - if (is_constant_symbol (sc, sym)) /* (let-temporarily ((pi 3)) ...) */ - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_3 (sc, cant_bind_immutable_string, - sc->let_temporarily_symbol, vars)); - } - else if (!is_pair (sym)) /* (let-temporarily ((1 2)) ...) */ - syntax_error_nr ( - sc, - "let-temporarily: bad variable ~S (it should be a symbol or a pair)", - 66, sym); - - if (!is_pair (cdr (var))) /* (let-temporarily ((x . 1))...) */ - syntax_error_nr ( - sc, "let-temporarily: variable declaration value is messed up: ~S", - 60, var); - - if (is_not_null (cddr (var))) /* (let-temporarily ((x 1 2 3)) ...) */ - syntax_error_nr ( - sc, - "let-temporarily: variable declaration has more than one value?: ~A", - 66, var); - - if ((all_fx) && ((!is_symbol (sym)) || - (!is_fxable (sc, cadr (var))))) /* if all_fx, each var is - (symbol fxable-expr) */ - all_fx= false; - if ((all_s7) && - ((!is_pair (sym)) || (car (sym) != sc->starlet_symbol) || - (!is_quoted_symbol (sc, cadr (sym))) || - (is_keyword (cadr (cadr (sym)))) || (!is_fxable (sc, cadr (var))))) - all_s7= false; - } - if (!s7_is_proper_list (sc, cdr (code))) - syntax_error_nr (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_A : OP_LET_TEMP_NA) - : OP_LET_TEMP_S7); - for (s7_pointer vars= car (code); is_pair (vars); vars= cdr (vars)) - fx_annotate_arg (sc, cdar (vars), sc->curlet); - - if ((optimize_op (form) == OP_LET_TEMP_A) && (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 if (all_s7) /* not OP_LET_TEMP_NA */ - { - const s7_pointer var= caar (code); - if ((is_fxable ( - sc, - cadr (var))) && /* code: ((((*s7* 'openlets) fxable-expr)) ...) */ - (is_null (cdar (code)))) { - if ((is_quoted_symbol (sc, cadar (var))) && - (starlet_symbol_id (cadr (cadar (var))) == - sl_openlets)) /* (cadr(cadar(var)) == make_symbol_with_strlen(sc, - "openlets"))) */ - { - pair_set_syntax_op (form, OP_LET_TEMP_S7_OPENLETS); - set_opt1_pair (form, cdr (var)); - } - } - } - if ((is_fx_treeable (code)) && (curlet_has_slots (sc))) { - fx_curlet_tree (sc, code); - fx_curlet_tree_in (sc, code); - } - } - 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); - const s7_pointer 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)) { - /* (let-temporarily (((setter (slot-symbol cp) (slot-env cp)) #f)) ...) - * reactive.scm */ - 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 bool check_closure_sym(s7_scheme *sc, int32_t args) +{ + /* 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) || + (local_value_unchecked(car(sc->code)) != opt1_lambda_unchecked(sc->code))) + { + const s7_pointer func = lookup_unexamined(sc, car(sc->code)); + if ((func != opt1_lambda_unchecked(sc->code)) && + ((!func) || + ((low_type_bits(func) & (TYPE_MASK | T_SAFE_CLOSURE)) != T_CLOSURE) || + (((args == 1) && (!is_symbol(closure_pars(func)))) || + ((args == 2) && ((!is_pair(closure_pars(func))) || (!is_symbol(cdr(closure_pars(func))))))))) + { + sc->last_function = func; + return(false); + } + set_opt1_lambda(sc->code, func); } - } + return(true); } -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 void op_any_closure_sym(s7_scheme *sc) /* for (lambda a ...) */ +{ + const s7_pointer func = opt1_lambda(sc->code); + s7_pointer old_args = cdr(sc->code); /* args aren't evaluated yet */ + const s7_int num_args = opt3_arglen(old_args); -static void -op_let_temp_init1_1 (s7_scheme* sc) { - if ((is_symbol (sc->value)) && - (is_symbol_from_symbol ( - sc->value))) /* (let-temporarily (((symbol ...))) ..) */ - { - clear_symbol_from_symbol (sc->value); - if (is_immutable_symbol (sc->value)) - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_3 (sc, cant_bind_immutable_string, - sc->let_temporarily_symbol, sc->value)); - sc->value= s7_symbol_value (sc, sc->value); - } - set_caddr (sc->args, cons (sc, sc->value, caddr (sc->args))); -} - -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); - const s7_pointer settee = car (binding); - const s7_pointer new_value= cadr (binding); - set_cadr (sc->args, cons (sc, settee, cadr (sc->args))); - binding= cdddr (sc->args); - set_car (binding, cons_unchecked (sc, new_value, car (binding))); - set_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))); - } - } - set_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_pair, - goto_do_unchecked, - goto_pop_read_list, - goto_read_tok, - goto_feed_to, - goto_set_unchecked -} 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))) { - const s7_pointer settee= caar (sc->args), p= cdddr (sc->args); - s7_pointer slot, new_value = caar (p); - set_car (p, cdar (p)); - set_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_LET_TEMP_INIT2); - return (goto_set_unchecked); - } - slot= s7_t_slot (sc, settee); - if (!is_slot (slot)) unbound_variable_error_nr (sc, settee); - if (is_immutable_slot (slot)) - immutable_object_error_nr (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); - slot_set_value (slot, (slot_has_setter (slot)) - ? call_setter (sc, slot, new_value) - : new_value); - } - set_car (sc->args, cadr (sc->args)); - /* pop_stack(sc); */ /* this clobbers sc->args! 7-May-22 */ - unstack_gc_protect (sc); /* pop_stack_no_args(sc) in effect */ - sc->code= cdr (stack_end_code (sc)); - 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); -} - -bool -op_let_temp_done1 (s7_scheme* sc) { - while (is_pair (car (sc->args))) { - const s7_pointer settee= caar (sc->args), p= cddr (sc->args); - /* fprintf(stderr, "args: %s\n", display(sc->args)); */ - sc->value= caar (p); - set_car (p, cdar (p)); - set_car (sc->args, cdar (sc->args)); - /* fprintf(stderr, " args: %s\n", display(sc->args)); */ - - if ((is_pair (settee)) && - (car (settee) == - sc->starlet_symbol) && /* (let-temporarily (((*s7* (symbol - "print-length")) 43))...) */ - ((is_symbol_and_keyword (cadr (settee))) || - (is_quoted_symbol (sc, cadr (settee))))) { - s7_pointer sym= cadr (settee); - if (is_pair (sym)) sym= cadr (sym); - else sym= keyword_symbol (sym); - starlet_set_1 (sc, T_Sym (sym), sc->value); - /* fprintf(stderr, "sym: %s, val: %s, args: %s\n", display(sym), - * display(sc->value), display(sc->args)); */ - } - else { - s7_pointer slot; - if (!is_symbol (settee)) { - push_stack_direct (sc, OP_LET_TEMP_DONE1); /* save args and (pending) - body value==sc->code */ - 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_function, sc->value)); - else sc->code= set_plist_3 (sc, sc->set_symbol, settee, sc->value); - return (false); /* goto set_unchecked */ + if (num_args == 1) + set_curlet(sc, inline_make_let_with_slot(sc, closure_let(func), closure_pars(func), + ((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)); + set_curlet(sc, inline_make_let_with_slot(sc, closure_let(func), closure_pars(func), + ((is_safe_closure(func)) && (!sc->debug_or_profile)) ? + set_plist_2(sc, gc_protected1(sc), sc->args) : list_2(sc, gc_protected1(sc), sc->args))); + unstack_gc_protect(sc); } - slot= s7_t_slot (sc, settee); - if (is_immutable_slot (slot)) - immutable_object_error_nr (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); + else + if (num_args == 0) + set_curlet(sc, inline_make_let_with_slot(sc, closure_let(func), closure_pars(func), sc->nil)); + else + { + sc->args = make_list(sc, num_args, sc->unused); + for (s7_pointer p = sc->args; is_pair(p); p = cdr(p), old_args = cdr(old_args)) + set_car(p, fx_call(sc, old_args)); + set_curlet(sc, make_let_with_slot(sc, closure_let(func), closure_pars(func), sc->args)); + } + sc->code = T_Pair(closure_body(func)); +} + +static void op_any_closure_a_sym(s7_scheme *sc) /* for (lambda (a . b) ...) */ +{ + const s7_pointer func = opt1_lambda(sc->code); + s7_pointer old_args = cdr(sc->code); + const s7_int num_args = opt3_arglen(old_args); + const s7_pointer func_pars = closure_pars(func); + + if (num_args == 1) + set_curlet(sc, make_let_with_two_slots(sc, closure_let(func), car(func_pars), sc->value = fx_call(sc, old_args), cdr(func_pars), sc->nil)); + else + { + gc_protect_via_stack(sc, fx_call(sc, old_args)); /* not sc->value as GC protection! -- fx_call below can clobber it */ + if (num_args == 2) + { + sc->args = fx_call(sc, cdr(old_args)); + set_curlet(sc, inline_make_let_with_two_slots(sc, closure_let(func), car(func_pars), gc_protected1(sc), cdr(func_pars), list_1(sc, sc->args))); + } + else + { + sc->args = make_list(sc, num_args - 1, sc->unused); + old_args = cdr(old_args); + for (s7_pointer p = sc->args; is_pair(p); p = cdr(p), old_args = cdr(old_args)) + set_car(p, fx_call(sc, old_args)); + set_curlet(sc, make_let_with_two_slots(sc, closure_let(func), car(func_pars), gc_protected1(sc), cdr(func_pars), sc->args)); + } + unstack_gc_protect(sc); } - } - pop_stack (sc); /* not unstack */ - 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* starlet_immutable_field= NULL; - -static bool -op_let_temp_s7 (s7_scheme* sc) /* all entries are of the form ((*s7* 'field) - fx-able-value) */ -{ - const s7_pointer code= - cdr (sc->code); /* don't use sc->code here -- it can be changed */ - s7_pointer* end= sc->stack_end; - for (s7_pointer vars= car (code); is_pair (vars); vars= cdr (vars)) { - s7_pointer old_value; - const s7_pointer field= - cadadr (caar (vars)); /* p: (((*s7* 'expansions?) #f)) -- no keywords - here (see check_let_temporarily) */ - if (starlet_immutable_field[starlet_symbol_id (field)]) - immutable_object_error_nr ( - sc, - set_elist_2 ( - sc, - wrap_string (sc, "let-temporarily: can't set! (*s7* '~S)", 38), - field)); - old_value= starlet (sc, starlet_symbol_id (field)); - /* check_stack_size(sc); */ /* t101-42 but commented out (probably the - #symbol stuff) */ - push_stack (sc, OP_LET_TEMP_S7_UNWIND, old_value, field); - } - for (s7_pointer vars= car (code); is_pair (vars); vars= cdr (vars), end+= 4) - starlet_set_1 (sc, T_Sym (end[0]), fx_call (sc, cdar (vars))); - sc->code= cdr (code); - return (is_pair (sc->code)); /* sc->code can be null if no body */ + sc->code = T_Pair(closure_body(func)); } -static void -op_let_temp_s7_unwind (s7_scheme* sc) { - starlet_set_1 (sc, T_Sym (sc->code), sc->args); - if (is_multiple_value (sc->value)) - sc->value= splice_in_values (sc, multiple_value (sc->value)); + +/* ---------------- tc/rec ---------------- */ + +#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 bool -op_let_temp_s7_openlets (s7_scheme* sc) { - s7_pointer new_val; - push_stack_no_code (sc, OP_LET_TEMP_S7_OPENLETS_UNWIND, - (sc->has_openlets) ? sc->T : sc->F); - new_val = fx_call (sc, opt1_pair (sc->code)); - sc->has_openlets= (new_val != sc->F); - sc->code = cddr (sc->code); /* cddr is body of let-temp */ - return (is_pair (sc->code)); +static s7_pointer g_report_missed_calls(s7_scheme *sc, s7_pointer args) +{ + for (int32_t 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 -op_let_temp_s7_openlets_unwind (s7_scheme* sc) { - sc->has_openlets= (sc->args != sc->F); - if (is_multiple_value (sc->value)) - sc->value= splice_in_values (sc, multiple_value (sc->value)); +static void tick_tc(s7_scheme *sc, int32_t op) +{ + sc->tc_rec_calls[op]++; } +#else +#define tick_tc(Sc, Op) +#endif -void -let_temp_done (s7_scheme* sc, s7_pointer args, s7_pointer let) { - /* called in call/cc, call-with-exit and, catch (unwind to catch) */ - check_stack_size (sc); - push_stack_direct (sc, OP_GC_PROTECT); - sc->args= T_Ext (args); - set_curlet (sc, let); - op_let_temp_done1 (sc); -} - -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); +/* op_tc_case */ +static bool op_tc_case_la(s7_scheme *sc, s7_pointer code, int vars) +{ + /* opt1_any(clause) = key, has_tc(arg) = is tc call, opt2_any(clause) = result: has_tc(la arg) has_fx(val) or ((...)...) */ + #define case_clause_key(p) opt1_any(p) + #define case_clause_result(p) opt2_any(p) + const s7_pointer clauses = cddr(code), la_slot = let_slots(sc->curlet), selp = cdr(code); + s7_pointer endp; + const s7_pointer l2a_slot = (vars == 1) ? NULL : next_slot(la_slot); + const s7_pointer l3a_slot = (vars <= 2) ? NULL : next_slot(l2a_slot); + const s7_int len = opt3_arglen(cdr(code)); + tick_tc(sc, (vars == 1) ? OP_TC_CASE_LA : ((vars == 2) ? OP_TC_CASE_L2A : OP_TC_CASE_L3A)); + + if (len == 3) + { + while (true) + { + const s7_pointer selector = fx_call(sc, selp); + if (selector == case_clause_key(clauses)) + endp = case_clause_result(clauses); + else + { + s7_pointer p = cdr(clauses); + endp = (selector == case_clause_key(p)) ? case_clause_result(p) : case_clause_result(cdr(p)); /* there's always an else */ + } + if (has_tc(endp)) + { + slot_set_value(la_slot, fx_call(sc, cdr(endp))); + if (vars > 1) slot_set_value(l2a_slot, fx_call(sc, cddr(endp))); + if (vars > 2) slot_set_value(l3a_slot, fx_call(sc, cdddr(endp))); + } + else break; + }} + else + while (true) + { + const s7_pointer selector = fx_call(sc, selp); + s7_pointer p; + for (p = clauses; is_pair(cdr(p)); p = cdr(p)) + if (selector == case_clause_key(p)) {endp = case_clause_result(p); goto CASE_ALA_END;} + endp = case_clause_result(p); /* else clause */ + CASE_ALA_END: + if (has_tc(endp)) + { + slot_set_value(la_slot, fx_call(sc, cdr(endp))); + if (vars > 1) slot_set_value(l2a_slot, fx_call(sc, cddr(endp))); + if (vars > 2) slot_set_value(l3a_slot, fx_call(sc, cdddr(endp))); + } + else break; + } + if (has_fx(endp)) + { + sc->value = fx_call(sc, endp); + return(true); /* continue */ + } + sc->code = endp; + return(false); /* goto BEGIN (not like op_tc_z below) */ } -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 s7_pointer fx_tc_case_la(s7_scheme *sc, s7_pointer arg) +{ + op_tc_case_la(sc, arg, 1); + return(sc->value); } -static bool -op_let_temp_na ( - s7_scheme* sc) /* all entries are of the form (symbol fx-able-value) */ +static s7_pointer fx_tc_case_l2a(s7_scheme *sc, s7_pointer arg) { - s7_pointer* end= sc->stack_end; - sc->code = cdr (sc->code); + op_tc_case_la(sc, arg, 2); + return(sc->value); +} - for (s7_pointer vars= car (sc->code); is_pair (vars); vars= cdr (vars)) { - const s7_pointer var = car (vars); - const s7_pointer settee= car (var); - const s7_pointer slot = s7_slot (sc, settee); - if (!is_slot (slot)) unbound_variable_error_nr (sc, settee); - if (is_immutable_slot (slot)) - immutable_object_error_nr (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 (s7_pointer vars= car (sc->code); is_pair (vars); - vars = cdr (vars), end+= 4) { - s7_pointer var = car (vars); - s7_pointer new_val= fx_call (sc, cdr (var)); - const s7_pointer 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 s7_pointer fx_tc_case_l3a(s7_scheme *sc, s7_pointer arg) +{ + op_tc_case_la(sc, arg, 3); + return(sc->value); } -static bool -op_let_temp_a (s7_scheme* sc) /* one entry */ + +/* op_tc_when_la|l2a|l3a */ +static s7_pointer op_tc_when_la(s7_scheme *sc, s7_pointer code) { - s7_pointer var, settee, slot; - sc->code= cdr (sc->code); - var = caar (sc->code); - settee = car (var); - slot = s7_slot (sc, settee); - if (!is_slot (slot)) /* (define (f) (let-temporarily ((_asdf_ 32)) (+ 1 2))) - (catch #t f (lambda args args)) (f) */ - unbound_variable_error_nr (sc, settee); - if (is_immutable_slot (slot)) - immutable_object_error_nr (sc, set_elist_3 (sc, immutable_error_string, - sc->let_temporarily_symbol, - settee)); - push_stack (sc, OP_LET_TEMP_UNWIND, slot_value (slot), slot); - { - s7_pointer 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 */ + const bool when_case = (!true_is_done(code)); + const s7_pointer if_test = cadr(code), body = cddr(code), la_slot = let_slots(sc->curlet); + const s7_function tf = fx_proc(cdr(code)); + const s7_pointer la_call = opt3_pair(code); + const s7_pointer la = cdar(la_call); + tick_tc(sc, OP_TC_WHEN_LA); + while ((tf(sc, if_test) != sc->F) == when_case) + { + for (s7_pointer p = body; p != la_call; p = cdr(p)) fx_call(sc, p); + slot_set_value(la_slot, fx_call(sc, la)); + } + return(sc->unspecified); } -static s7_pointer -fx_let_temp_a_a (s7_scheme* sc, s7_pointer code) /* one entry, body is fx'd */ +static s7_pointer op_tc_when_l2a(s7_scheme *sc, s7_pointer code) { - s7_pointer result; - op_let_temp_a (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; - const s7_pointer let= sc->curlet; - sc->code = cdr (sc->code); - var = caaar (sc->code); - sym = fx_call (sc, cdr (var)); - set_curlet (sc, fx_call (sc, cddr (var))); - slot= s7_t_slot (sc, sym); - set_curlet (sc, let); - 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_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)); + const bool when_case = (!true_is_done(code)); + const s7_pointer if_test = cadr(code), body = cddr(code), la_slot = let_slots(sc->curlet); + const s7_function tf = fx_proc(cdr(code)); + const s7_pointer la_call = opt3_pair(code); + const s7_pointer la = cdar(la_call); + const s7_pointer l2a = cdr(la); + const s7_pointer l2a_slot = next_slot(la_slot); + tick_tc(sc, OP_TC_WHEN_L2A); + while ((tf(sc, if_test) != sc->F) == when_case) + { + for (s7_pointer p = body; p != la_call; p = cdr(p)) fx_call(sc, p); + sc->rec_p1 = fx_call(sc, la); + slot_set_value(l2a_slot, fx_call(sc, l2a)); + slot_set_value(la_slot, sc->rec_p1); + } + sc->rec_p1 = sc->unused; + return(sc->unspecified); } -/* -------------------------------- 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))) - syntax_error_nr (sc, "quote: not enough arguments: ~A", 31, code); - syntax_error_nr (sc, "quote: stray dot?: ~A", 21, code); - } - if (is_not_null (cddr (code))) /* (quote . (1 2)) or (quote 1 1) */ - syntax_error_nr (sc, "quote: too many arguments ~A", 28, code); - pair_set_syntax_op (code, OP_QUOTE_UNCHECKED); - return (cadr (code)); +static s7_pointer op_tc_when_l3a(s7_scheme *sc, s7_pointer code) +{ + const bool when_case = (!true_is_done(code)); + const s7_pointer if_test = cadr(code), body = cddr(code), la_slot = let_slots(sc->curlet); + const s7_function tf = fx_proc(cdr(code)); + const s7_pointer la_call = opt3_pair(code); + const s7_pointer la = cdar(la_call); + const s7_pointer l2a = cdr(la); + const s7_pointer l3a = cdr(l2a); + const s7_pointer l2a_slot = next_slot(la_slot); + const s7_pointer l3a_slot = next_slot(l2a_slot); + tick_tc(sc, OP_TC_WHEN_L3A); + while ((tf(sc, if_test) != sc->F) == when_case) + { + for (s7_pointer p = body; p != la_call; p = cdr(p)) fx_call(sc, p); + sc->rec_p1 = fx_call(sc, la); + sc->rec_p2 = fx_call(sc, l2a); + slot_set_value(l3a_slot, fx_call(sc, l3a)); + slot_set_value(l2a_slot, sc->rec_p2); + slot_set_value(la_slot, sc->rec_p1); + } + sc->rec_p1 = sc->unused; + return(sc->unspecified); } -/* -------------------------------- and -------------------------------- */ -static bool -check_and (s7_scheme* sc, s7_pointer expr) { - /* this, check_or and check_if might not be called -- optimize_syntax can - * short-circuit it to return fx* choices */ - s7_pointer p; - const s7_pointer 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= - (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) */ - syntax_error_nr (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); +static bool op_tc_z(s7_scheme *sc, s7_pointer expr) +{ + if (has_fx(expr)) + { + sc->value = fx_call(sc, expr); + return(true); } - } - if ((is_fx_treeable (code)) && (curlet_has_slots (sc))) - fx_curlet_tree (sc, code); - set_current_code (sc, sc->code); - return (false); + sc->code = car(expr); + 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); +/* tc_if_a_z_la|la2|la3 */ +static bool op_tc_if_a_z_la(s7_scheme *sc, s7_pointer code) +{ + const bool true_quits = true_is_done(code); + const s7_pointer la_slot = let_slots(sc->curlet); + const s7_pointer if_test = rec_test_clause(code); + const s7_pointer if_done = rec_done_clause(code); + const s7_pointer la = rec_call_clause(code); + tick_tc(sc, OP_TC_IF_A_Z_LA); + 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 = make_mutable_integer(sc, integer(slot_value(la_slot))); + slot_set_value(la_slot, val); + while (q_call(o).fb(o) != true_quits) {set_integer(val, q_call(o1).fi(o1));} + return(op_tc_z(sc, if_done)); + }}} + if (fx_proc(la) == fx_cdr_t) + while ((fx_call(sc, if_test) != sc->F) != true_quits) + { + if (!is_pair(slot_value(la_slot))) + sole_arg_wrong_type_error_nr(sc, sc->cdr_symbol, slot_value(la_slot), sc->type_names[T_PAIR]); + slot_set_value(la_slot, cdr(slot_value(la_slot))); + } + else while ((fx_call(sc, if_test) != sc->F) != true_quits) {slot_set_value(la_slot, fx_call(sc, la));} + return(op_tc_z(sc, if_done)); } -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 s7_pointer fx_tc_if_a_z_la(s7_scheme *sc, s7_pointer arg) +{ + op_tc_if_a_z_la(sc, arg); + return(sc->value); } -static void -op_and_safe_p1 (s7_scheme* sc) /* sc->code: (and (func...) (fx...)...) */ +static bool op_tc_if_a_z_l2a(s7_scheme *sc, s7_pointer code) { - 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); + const bool true_quits = true_is_done(code); + const s7_pointer la_slot = let_slots(sc->curlet); + s7_function tf; + s7_pointer if_test = rec_test_clause(code); + const s7_pointer if_done = rec_done_clause(code); + const s7_pointer la = rec_call_clause(code); + const s7_pointer l2a = cdr(la); + const s7_pointer l2a_slot = next_slot(la_slot); + tick_tc(sc, OP_TC_IF_A_Z_L2A); + 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; + const int32_t start_pc = sc->pc; + if ((is_t_integer(slot_value(la_slot))) && + (is_t_integer(slot_value(l2a_slot)))) + { + if (int_optimize(sc, la)) + { + o2 = sc->opts[sc->pc]; + if (int_optimize(sc, l2a)) + { + s7_int (*fi1)(opt_info *o) = q_call(o1).fi; + s7_int (*fi2)(opt_info *o) = q_call(o2).fi; + bool (*fb)(opt_info *o) = q_call(o).fb; + const s7_pointer val1 = make_mutable_integer(sc, integer(slot_value(la_slot))); + s7_pointer val2; + slot_set_value(la_slot, val1); + slot_set_value(l2a_slot, val2 = make_mutable_integer(sc, integer(slot_value(l2a_slot)))); + if ((true_quits) && + ((fb == opt_b_ii_sc_lt) || (fb == opt_b_ii_sc_lt_0)) && + (fi1 == opt_i_ii_sc_sub)) + { /* trclo: (if (< i 0) sum (loop (- i 1) (+ i sum))) */ + s7_int lim = q_arg2(o).i, m = q_arg2(o1).i; + s7_pointer slot1 = q_arg1(o).p, slot2 = q_arg1(o1).p; + while (integer(slot_value(slot1)) >= lim) + { + s7_int i1 = integer(slot_value(slot2)) - m; + set_integer(val2, fi2(o2)); + set_integer(val1, i1); + }} + else /* s7test: (let facter ((n n0) (result 1)) (if (= n 0) result (facter (- n 1) (* n result))) */ + while (fb(o) != true_quits) + { + s7_int i1 = fi1(o1); + set_integer(val2, fi2(o2)); + set_integer(val1, i1); + } + return(op_tc_z(sc, if_done)); + }}} + + if ((is_t_real(slot_value(la_slot))) && + (is_t_real(slot_value(l2a_slot)))) + { + sc->pc = start_pc; + if (float_optimize(sc, la)) + { + o2 = sc->opts[sc->pc]; + if (float_optimize(sc, l2a)) + { + s7_double (*fd1)(opt_info *o) = q_call(o1).fd; + s7_double (*fd2)(opt_info *o) = q_call(o2).fd; + bool (*fb)(opt_info *o) = q_call(o).fb; + const s7_pointer val1 = make_mutable_real(sc, real(slot_value(la_slot))); + const s7_pointer val2 = make_mutable_real(sc, real(slot_value(l2a_slot))); + slot_set_value(la_slot, val1); + slot_set_value(l2a_slot, val2); + if ((true_quits) && + (fb == opt_b_dd_sc_lt) && + (fd1 == opt_d_dd_sc_sub)) + { /* trclo: (if (< i 0.0) sum (loop (- i 1.0) (+ i sum))) */ + s7_double lim = q_arg2(o).x; + s7_double m = q_arg2(o1).x; + s7_pointer slot1 = q_arg1(o).p; + s7_pointer slot2 = q_arg1(o1).p; + while (real(slot_value(slot1)) >= lim) + { + s7_double x1 = real(slot_value(slot2)) - m; + set_real(val2, fd2(o2)); + set_real(val1, x1); + }} + else /* trclo: (if (>= i 0.0) (loop (- i 1.0) (+ i sum)) sum) */ + while (fb(o) != true_quits) + { + s7_double x1 = fd1(o1); + set_real(val2, fd2(o2)); + set_real(val1, x1); + } + clear_mutable_number(val1); + clear_mutable_number(val2); + return(op_tc_z(sc, if_done)); + }}}} + set_no_bool_opt(code); + } + tf = fx_proc(if_test); + if_test = car(if_test); + if (true_quits) + { + if ((fx_proc(la) == fx_cdr_t) && (is_pair(slot_value(la_slot)))) + { + if ((fx_proc(l2a) == 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_t_integer(slot_value(l2a_slot)))) + { /* list-tail ferchrissake */ + const s7_int end = integer(caddr(if_test)); + s7_pointer lst = slot_value(la_slot); + for (s7_int start = integer(slot_value(l2a_slot)); start > end; start--) + lst = cdr(lst); + slot_set_value(la_slot, lst); + return(op_tc_z(sc, if_done)); + } + if (tf == fx_is_null_t) + { + do { + s7_pointer p; + if (is_pair(slot_value(la_slot))) /* needed if improper list passed here */ + p = cdr(slot_value(la_slot)); + else sole_arg_wrong_type_error_nr(sc, sc->cdr_symbol, slot_value(la_slot), sc->type_names[T_PAIR]); + slot_set_value(l2a_slot, fx_call(sc, l2a)); + slot_set_value(la_slot, p); + } while (!is_null(slot_value(la_slot))); + return(op_tc_z(sc, if_done)); + }} + while (tf(sc, if_test) == sc->F) + { + sc->rec_p1 = fx_call(sc, la); + slot_set_value(l2a_slot, fx_call(sc, l2a)); + slot_set_value(la_slot, sc->rec_p1); + }} + else + { + if ((tf == fx_is_pair_t) && (fx_proc(la) == fx_cdr_t) && (is_pair(slot_value(la_slot)))) + { + /* we need to save la new value before getting the new l2a value since l2a might refer to the current la value or vice versa */ + do { + s7_pointer p = cdr(slot_value(la_slot)); + slot_set_value(l2a_slot, fx_call(sc, l2a)); + slot_set_value(la_slot, p); + } while (is_pair(slot_value(la_slot))); + return(op_tc_z(sc, if_done)); + } + while (tf(sc, if_test) != sc->F) + { + sc->rec_p1 = fx_call(sc, la); + slot_set_value(l2a_slot, fx_call(sc, l2a)); + slot_set_value(la_slot, sc->rec_p1); + }} + return(op_tc_z(sc, if_done)); } -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 s7_pointer fx_tc_if_a_z_l2a(s7_scheme *sc, s7_pointer arg) +{ + op_tc_if_a_z_l2a(sc, arg); + sc->rec_p1 = sc->unused; + return(sc->value); } -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); +static bool op_tc_if_a_z_l3a(s7_scheme *sc, s7_pointer code) +{ + const bool true_quits = true_is_done(code); + const s7_pointer la_slot = let_slots(sc->curlet); + s7_pointer if_test = rec_test_clause(code); + const s7_pointer if_done = rec_done_clause(code); + const s7_pointer la = rec_call_clause(code); + const s7_pointer l2a = cdr(la); + const s7_pointer l3a = cdr(l2a); + const s7_pointer l2a_slot = next_slot(la_slot); + const s7_pointer l3a_slot = next_slot(l2a_slot); + const s7_function tf = fx_proc(if_test); + tick_tc(sc, OP_TC_IF_A_Z_L3A); + if_test = car(if_test); + while ((tf(sc, if_test) != sc->F) != true_quits) + { + sc->rec_p1 = fx_call(sc, la); + sc->rec_p2 = fx_call(sc, l2a); + slot_set_value(l3a_slot, fx_call(sc, l3a)); + slot_set_value(l2a_slot, sc->rec_p2); + slot_set_value(la_slot, sc->rec_p1); + } + return(op_tc_z(sc, if_done)); } -/* -------------------------------- or -------------------------------- */ -static bool -check_or (s7_scheme* sc, s7_pointer expr) { - s7_pointer p; - const s7_pointer 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= (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)) syntax_error_nr (sc, "or: stray dot?: ~A", 18, expr); +static s7_pointer fx_tc_if_a_z_l3a(s7_scheme *sc, s7_pointer arg) +{ + op_tc_if_a_z_l3a(sc, arg); + sc->rec_p1 = sc->unused; + sc->rec_p2 = sc->unused; + return(sc->value); +} - 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); - if ((is_fx_treeable (code)) && (curlet_has_slots (sc))) - fx_curlet_tree (sc, code); - set_current_code (sc, sc->code); - return (false); +static s7_pointer op_tc_and_a_or_a_la(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer fx_and = cdr(code), la_slot = let_slots(sc->curlet); + const s7_pointer fx_or = cdadr(fx_and); + const s7_pointer fx_la = cdadr(fx_or); + tick_tc(sc, OP_TC_AND_A_OR_A_LA); /* cell_optimize here is slower! */ + while (true) + { + s7_pointer p; + if (fx_call(sc, fx_and) == sc->F) return(sc->F); + p = fx_call(sc, fx_or); + if (p != sc->F) return(p); + slot_set_value(la_slot, fx_call(sc, fx_la)); + } + return(sc->F); } -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); +static s7_pointer op_tc_or_a_and_a_la(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer fx_or = cdr(code), la_slot = let_slots(sc->curlet); + const s7_pointer fx_and = cdadr(fx_or); + const s7_pointer fx_la = cdadr(fx_and); + tick_tc(sc, OP_TC_OR_A_AND_A_LA); + while (true) + { + s7_pointer result = fx_call(sc, fx_or); + if (result != sc->F) return(result); + if (fx_call(sc, fx_and) == sc->F) return(sc->F); + slot_set_value(la_slot, fx_call(sc, fx_la)); + } + return(sc->F); } -/* -------------------------------- if -------------------------------- */ -static void -fb_if_annotate (s7_scheme* sc, s7_pointer code, s7_pointer form) { - 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)); - fb_annotate (sc, form, code, OP_IF_B_A); - } - else fb_annotate (sc, form, code, OP_IF_B_P); - } - if (optimize_op (form) == OP_IF_A_R) fb_annotate (sc, form, code, OP_IF_B_R); - if (optimize_op (form) == OP_IF_A_N_N) - fb_annotate (sc, form, 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, code, OP_IF_B_A_P); - } - fx_annotate_args (sc, cdr (code), sc->curlet); +static s7_pointer op_tc_and_a_or_a_a_la(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer fx_and = cdr(code), la_slot = let_slots(sc->curlet); + const s7_pointer fx_or1 = cdadr(fx_and); + const s7_pointer fx_or2 = cdr(fx_or1); + const s7_pointer fx_la = cdadr(fx_or2); + tick_tc(sc, OP_TC_AND_A_OR_A_A_LA); + while (true) + { + s7_pointer p; + if (fx_call(sc, fx_and) == sc->F) return(sc->F); + p = fx_call(sc, fx_or1); + if (p != sc->F) return(p); + p = fx_call(sc, fx_or2); + if (p != sc->F) return(p); + slot_set_value(la_slot, fx_call(sc, fx_la)); } - 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)); - fb_annotate (sc, form, code, OP_IF_B_P_A); + return(sc->F); +} + +static s7_pointer op_tc_or_a_and_a_a_la(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer fx_or = cdr(code), la_slot = let_slots(sc->curlet); + const s7_pointer fx_and1 = cdadr(fx_or); + const s7_pointer fx_and2 = cdr(fx_and1); + const s7_pointer fx_la = cdadr(fx_and2); + tick_tc(sc, OP_TC_OR_A_AND_A_A_LA); + while (true) + { + s7_pointer result = fx_call(sc, fx_or); + if (result != sc->F) return(result); + if ((fx_call(sc, fx_and1) == sc->F) || + (fx_call(sc, fx_and2) == sc->F)) + return(sc->F); + slot_set_value(la_slot, fx_call(sc, fx_la)); } - else fb_annotate (sc, form, code, OP_IF_B_P_P); - } + return(sc->F); } -#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 s7_pointer op_tc_or_a_a_and_a_a_la(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer fx_or1 = cdr(code), la_slot = let_slots(sc->curlet); + const s7_pointer fx_or2 = cdr(fx_or1); + const s7_pointer fx_and1 = cdadr(fx_or2); + const s7_pointer fx_and2 = cdr(fx_and1); + const s7_pointer fx_la = cdadr(fx_and2); + tick_tc(sc, OP_TC_OR_A_A_AND_A_A_LA); + while (true) + { + s7_pointer result = fx_call(sc, fx_or1); + if (result != sc->F) return(result); + result = fx_call(sc, fx_or2); + if (result != sc->F) return(result); + if (fx_call(sc, fx_and1) == sc->F) return(sc->F); + if (fx_call(sc, fx_and2) == sc->F) return(sc->F); + slot_set_value(la_slot, fx_call(sc, fx_la)); + } + return(sc->F); +} -static void -set_if_opts (s7_scheme* sc, s7_pointer form, bool one_branch, - bool reversed) /* cdr(form) == sc->code */ +static s7_pointer op_tc_and_a_or_a_l2a(s7_scheme *sc, s7_pointer code) { - const s7_pointer code = cdr (form); - s7_pointer test = car (code); - bool not_case= false; + const s7_pointer fx_and = cdr(code), la_slot = let_slots(sc->curlet); + const s7_pointer fx_or = cdadr(fx_and); + const s7_pointer fx_la = cdadr(fx_or); + const s7_pointer fx_l2a = cdr(fx_la); + const s7_pointer l2a_slot = next_slot(la_slot); + tick_tc(sc, OP_TC_AND_A_OR_A_L2A); + + 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_l2a) == fx_cdr_u)) + { + s7_pointer la_val = slot_value(la_slot), l2a_val = slot_value(l2a_slot); + while (true) + { + if (is_null(l2a_val)) return(sc->F); + if (is_null(la_val)) return(sc->T); + if (!is_pair(l2a_val)) sole_arg_wrong_type_error_nr(sc, sc->cdr_symbol, l2a_val, sc->type_names[T_PAIR]); + if (!is_pair(la_val)) sole_arg_wrong_type_error_nr(sc, sc->cdr_symbol, la_val, sc->type_names[T_PAIR]); + la_val = cdr(la_val); + l2a_val = cdr(l2a_val); + }} + while (true) + { + s7_pointer p; + if (fx_call(sc, fx_and) == sc->F) return(sc->F); + p = fx_call(sc, fx_or); + if (p != sc->F) return(p); + sc->rec_p1 = fx_call(sc, fx_la); + slot_set_value(l2a_slot, fx_call(sc, fx_l2a)); + slot_set_value(la_slot, sc->rec_p1); + } + return(sc->F); +} - 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); - } +static s7_pointer op_tc_or_a_and_a_l2a(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer fx_or = cdr(code), la_slot = let_slots(sc->curlet); + const s7_pointer fx_and = cdadr(fx_or); + const s7_pointer fx_la = cdadr(fx_and); + const s7_pointer fx_l2a = cdr(fx_la); + const s7_pointer l2a_slot = next_slot(la_slot); + tick_tc(sc, OP_TC_OR_A_AND_A_L2A); + while (true) + { + s7_pointer result = fx_call(sc, fx_or); + if (result != sc->F) return(result); + if (fx_call(sc, fx_and) == sc->F) return(sc->F); + sc->rec_p1 = fx_call(sc, fx_la); + slot_set_value(l2a_slot, fx_call(sc, fx_l2a)); + slot_set_value(la_slot, sc->rec_p1); + } + return(sc->F); +} - set_opt1_any (form, cadr (code)); - if (!one_branch) set_opt2_any (form, caddr (code)); +static s7_pointer op_tc_and_a_or_a_l3a(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer fx_and = cdr(code), la_slot = let_slots(sc->curlet); + const s7_pointer fx_or = cdadr(fx_and); + const s7_pointer fx_la = cdadr(fx_or); + const s7_pointer fx_l2a = cdr(fx_la); + const s7_pointer fx_l3a = cdr(fx_l2a); + const s7_pointer l2a_slot = next_slot(la_slot); + const s7_pointer l3a_slot = next_slot(l2a_slot); + tick_tc(sc, OP_TC_AND_A_OR_A_L3A); + while (true) + { + s7_pointer p; + if (fx_call(sc, fx_and) == sc->F) return(sc->F); + p = fx_call(sc, fx_or); + if (p != sc->F) return(p); + sc->rec_p1 = fx_call(sc, fx_la); + sc->rec_p2 = fx_call(sc, fx_l2a); + slot_set_value(l3a_slot, fx_call(sc, fx_l3a)); + slot_set_value(l2a_slot, sc->rec_p2); + slot_set_value(la_slot, sc->rec_p1); + } + return(sc->F); +} - if (is_pair (test)) { - if (is_optimized (test)) { - if (is_h_safe_c_nc (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)); - if ((is_fx_treeable (code)) && (curlet_has_slots (sc))) - fx_curlet_tree (sc, code); - fb_if_annotate (sc, code, form); - return; - } - if ((is_h_safe_c_s (test)) && (is_symbol (car (test)))) { - uint8_t 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) { - if (is_fxable (sc, caddr (code))) { - set_opt2_pair (form, cddr (code)); - if (is_fxable (sc, cadr (code))) { - set_opt1_pair (form, cdr (code)); - fx_annotate_args (sc, cdr (code), sc->curlet); - pair_set_syntax_op (form, OP_IF_IS_TYPE_S_A_A); - } - else { - set_opt1_any (form, cadr (code)); - pair_set_syntax_op (form, OP_IF_IS_TYPE_S_P_A); - fx_annotate_arg (sc, cddr (code), sc->curlet); - } - if ((is_fx_treeable (code)) && (curlet_has_slots (sc))) - fx_curlet_tree (sc, code); - } - else if (is_fxable (sc, cadr (code))) { - set_opt2_any (form, caddr (code)); - set_opt1_pair (form, cdr (code)); - fx_annotate_arg (sc, cdr (code), sc->curlet); - pair_set_syntax_op (form, OP_IF_IS_TYPE_S_A_P); - if ((is_fx_treeable (code)) && (curlet_has_slots (sc))) - fx_curlet_tree (sc, code); - } - } - } - 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) || - (optimize_op (test) == OP_AND_2A)) { - if (optimize_op (test) == OP_OR_2A) - pair_set_syntax_op ( - form, choose_if_optc (IF_OR2, one_branch, reversed, not_case)); - else - 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)); - fb_if_annotate (sc, code, form); - } - 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)); - } - if ((is_fx_treeable (code)) && (curlet_has_slots (sc))) - fx_curlet_tree (sc, 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)); - } - } - } +static s7_pointer op_tc_or_a_and_a_l3a(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer fx_or = cdr(code), la_slot = let_slots(sc->curlet); + const s7_pointer fx_and = cdadr(fx_or); + const s7_pointer fx_la = cdadr(fx_and); + const s7_pointer fx_l2a = cdr(fx_la); + const s7_pointer fx_l3a = cdr(fx_l2a); + const s7_pointer l2a_slot = next_slot(la_slot); + const s7_pointer l3a_slot = next_slot(l2a_slot); + tick_tc(sc, OP_TC_OR_A_AND_A_L3A); + while (true) + { + s7_pointer result = fx_call(sc, fx_or); + if (result != sc->F) return(result); + if (fx_call(sc, fx_and) == sc->F) return(sc->F); + sc->rec_p1 = fx_call(sc, fx_la); + sc->rec_p2 = fx_call(sc, fx_l2a); + slot_set_value(l3a_slot, fx_call(sc, fx_l3a)); + slot_set_value(l2a_slot, sc->rec_p2); + slot_set_value(la_slot, sc->rec_p1); } - } - else /* test is symbol or constant, but constant here is nutty */ - if (is_safe_symbol (sc, 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) { - if (is_fxable (sc, caddr (code))) { - if ((is_fx_treeable (code)) && (curlet_has_slots (sc))) - fx_curlet_tree (sc, code); - set_opt2_pair (form, - cddr (code)); /* opt1_any set above to cadr(code) */ - if (is_fxable (sc, cadr (code))) { - pair_set_syntax_op (form, OP_IF_S_A_A); - fx_annotate_args (sc, cdr (code), sc->curlet); - set_opt1_pair (form, cdr (code)); - } - else { - pair_set_syntax_op (form, OP_IF_S_P_A); - fx_annotate_arg (sc, cddr (code), sc->curlet); - } - if ((is_fx_treeable (code)) && (curlet_has_slots (sc))) - fx_curlet_tree (sc, code); - } - else if (is_fxable (sc, cadr (code))) { - pair_set_syntax_op (form, OP_IF_S_A_P); - fx_annotate_arg (sc, cdr (code), sc->curlet); - if ((is_fx_treeable (code)) && (curlet_has_slots (sc))) - fx_curlet_tree (sc, code); - set_opt1_pair (form, cdr (code)); - set_opt2_any (form, caddr (code)); - } - } + return(sc->F); +} + +static s7_pointer op_tc_or_a_and_a_a_l3a(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer fx_or = cdr(code), la_slot = let_slots(sc->curlet); + s7_pointer fx_and1 = opt3_pair(fx_or); /* (or_case) ? cdadr(fx_or) : cdaddr(fx_or); */ + s7_pointer fx_and2 = cdr(fx_and1); + const s7_pointer fx_la = cdadr(fx_and2); + const s7_pointer fx_l2a = cdr(fx_la); + const s7_pointer l2a_slot = next_slot(la_slot); + const s7_pointer fx_l3a = cdr(fx_l2a); + const s7_pointer l3a_slot = next_slot(l2a_slot); + tick_tc(sc, OP_TC_OR_A_AND_A_A_L3A); + 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 result = fx_call(sc, fx_or); + if (result != sc->F) return(result); + if ((fx_call(sc, fx_and1) != sc->F) || (fx_call(sc, fx_and2) != sc->F)) return(sc->F); + sc->rec_p1 = fx_call(sc, fx_la); + sc->rec_p2 = fx_call(sc, fx_l2a); + slot_set_value(l3a_slot, fx_call(sc, fx_l3a)); + slot_set_value(la_slot, sc->rec_p1); + slot_set_value(l2a_slot, sc->rec_p2); + }} + while (true) + { + s7_pointer result = fx_call(sc, fx_or); + if (result != sc->F) return(result); + if ((fx_call(sc, fx_and1) == sc->F) || (fx_call(sc, fx_and2) == sc->F)) return(sc->F); + sc->rec_p1 = fx_call(sc, fx_la); + sc->rec_p2 = fx_call(sc, fx_l2a); + slot_set_value(l3a_slot, fx_call(sc, fx_l3a)); + slot_set_value(la_slot, sc->rec_p1); + slot_set_value(l2a_slot, sc->rec_p2); } + return(sc->F); } -/* (cond <> (else <>)) only happens in old-fashioned code, so set_if_opts covers - * if/when/unless but not cond */ +static bool op_tc_if_a_z_if_a_z_la(s7_scheme *sc, s7_pointer code, bool z_first) +{ + s7_pointer if1_test, if1_true, if1_false, if2_test, if2_z, la, endp, la_slot = let_slots(sc->curlet); + bool tc_and = (car(code) == sc->and_symbol); + bool tc_cond = (car(code) == sc->cond_symbol); + tick_tc(sc, OP_TC_IF_A_Z_IF_A_Z_LA); + if (!tc_cond) /* code: (if a1 z1 (if a2 z2 la) or (and a1 (if a2 z la))? */ + { + if1_test = cdr(code); + if1_true = (!tc_and) ? cdr(if1_test) : sc->F; + if1_false = (!tc_and) ? cadr(if1_true) : cadr(if1_test); + if2_test = cdr(if1_false); + if2_z = (z_first) ? cdr(if2_test) : cddr(if2_test); + la = (z_first) ? cdaddr(if2_test) : cdadr(if2_test); + } + else + { + if1_test = cadr(code); /* code: (cond (a1 z1) (a2 z2|la) (else la|z3)) */ + if1_true = cdr(if1_test); + if1_false = caddr(code); /* (a2 z2|la) */ + if2_test = if1_false; + if2_z = (z_first) ? cdr(if2_test) : cdr(cadddr(code)); + la = (z_first) ? cdadr(cadddr(code)) : cdadr(caddr(code)); + } + if (is_t_integer(slot_value(la_slot))) + { + opt_info *o = sc->opts[0]; + sc->pc = 0; + if (bool_optimize_nw(sc, if1_test)) + { + opt_info *o1 = sc->opts[sc->pc]; + if (bool_optimize_nw(sc, if2_test)) + { + opt_info *o2 = sc->opts[sc->pc]; + if (int_optimize(sc, la)) + { + s7_pointer val = make_mutable_integer(sc, integer(slot_value(la_slot))); + slot_set_value(la_slot, val); + if (tc_and) + while (true) + { + if (!q_call(o).fb(o)) {sc->value = sc->F; return(true);} + if (q_call(o1).fb(o1) == z_first) {endp = if2_z; break;} + set_integer(val, q_call(o2).fi(o2)); + } + else + while (true) + { + if (q_call(o).fb(o)) {endp = if1_true; break;} + if (q_call(o1).fb(o1) == z_first) {endp = if2_z; break;} + set_integer(val, q_call(o2).fi(o2)); + } + return(op_tc_z(sc, endp)); + }}}} + while (true) + { + if ((fx_call(sc, if1_test) == sc->F) == tc_and) {if (tc_and) {sc->value = sc->F; return(true);} else {endp = if1_true; break;}} + if ((fx_call(sc, if2_test) == sc->F) != z_first) {endp = if2_z; break;} + slot_set_value(la_slot, fx_call(sc, la)); + } + return(op_tc_z(sc, endp)); +} -static s7_pointer -check_if (s7_scheme* sc, s7_pointer form) { - const s7_pointer code= cdr (form); - s7_pointer cdr_code; - if (!is_pair (code)) /* (if) or (if . 1) */ - syntax_error_nr (sc, "(if): if needs at least 2 expressions: ~A", 41, form); +static s7_pointer fx_tc_if_a_z_if_a_z_la(s7_scheme *sc, s7_pointer arg) +{ + op_tc_if_a_z_if_a_z_la(sc, arg, true); + return(sc->value); +} - cdr_code= cdr (code); - if (!is_pair (cdr_code)) /* (if 1) */ - { - if (is_null (cdr (code))) - syntax_error_nr (sc, "~S: if needs another clause", 27, form); - syntax_error_nr (sc, "~S: stray dot?", 14, form); /* (if 1 . 2) */ - } - if (is_pair (cdr (cdr_code))) { - if (is_not_null (cddr (cdr_code))) /* (if 1 2 3 4) */ - syntax_error_nr (sc, "too many clauses for if: ~A", 27, form); - } - else if (is_not_null (cdr (cdr_code))) /* (if 1 2 . 3) */ - syntax_error_nr (sc, "if: ~A has improper list?", 25, form); +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); + return(sc->value); +} - pair_set_syntax_op (form, OP_IF_UNCHECKED); - set_if_opts (sc, form, is_null (cdr (cdr_code)), false); - set_current_code (sc, sc->code); - return (code); +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); + return(sc->value); } -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 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); + return(sc->value); } -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_tc_if_a_z_if_a_z_l2a(s7_scheme *sc, s7_pointer code) +{ + const bool cond = (car(code) == sc->cond_symbol); + s7_pointer if2_test, if2_true, la, l2a, l2a_slot, endp, slot1; + const s7_pointer la_slot = let_slots(sc->curlet); + const s7_pointer if1_test = (cond) ? cadr(code) : cdr(code); + const s7_pointer if1_true = cdr(if1_test); + tick_tc(sc, OP_TC_IF_A_Z_IF_A_Z_L2A); + if2_test = (cond) ? caddr(code) : cdadr(if1_true); + if2_true = cdr(if2_test); + la = (cond) ? opt3_pair(code) : cdadr(if2_true); /* cdadr(cadddr(code)) */ + l2a = cdr(la); + l2a_slot = next_slot(la_slot); + slot1 = (fx_proc(if1_test) == fx_is_null_t) ? la_slot : ((fx_proc(if1_test) == fx_is_null_u) ? l2a_slot : NULL); + if (slot1) + { + if ((slot1 == l2a_slot) && (fx_proc(if2_test) == fx_is_null_t) && (fx_proc(la) == fx_cdr_t) && (fx_proc(l2a) == fx_cdr_u) && + (is_boolean(car(if1_true))) && (is_boolean(car(if2_true)))) + { /* ugly... */ + s7_pointer la_val = slot_value(la_slot), l2a_val = slot_value(l2a_slot); + while (true) + { + if (is_null(l2a_val)) {sc->value = car(if1_true); return(true);} + if (is_null(la_val)) {sc->value = car(if2_true); return(true);} + if (!is_pair(l2a_val)) sole_arg_wrong_type_error_nr(sc, sc->cdr_symbol, l2a_val, sc->type_names[T_PAIR]); + if (!is_pair(la_val)) sole_arg_wrong_type_error_nr(sc, sc->cdr_symbol, la_val, sc->type_names[T_PAIR]); + la_val = cdr(la_val); + l2a_val = cdr(l2a_val); + }} + while (true) + { + if (is_null(slot_value(slot1))) {endp = if1_true; break;} + if (fx_call(sc, if2_test) != sc->F) {endp = if2_true; break;} + sc->rec_p1 = fx_call(sc, la); + slot_set_value(l2a_slot, fx_call(sc, l2a)); + slot_set_value(la_slot, sc->rec_p1); + }} + else + while (true) + { + if (fx_call(sc, if1_test) != sc->F) {endp = if1_true; break;} + if (fx_call(sc, if2_test) != sc->F) {endp = if2_true; break;} + sc->rec_p1 = fx_call(sc, la); + slot_set_value(l2a_slot, fx_call(sc, l2a)); + slot_set_value(la_slot, sc->rec_p1); + } + return(op_tc_z(sc, endp)); } -static bool -op_if1 (s7_scheme* sc) { - sc->code= (is_true (sc, sc->value)) ? T_Pos (car (sc->code)) - : T_Pos (car_unchecked (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); +static s7_pointer fx_tc_if_a_z_if_a_z_l2a(s7_scheme *sc, s7_pointer arg) +{ + op_tc_if_a_z_if_a_z_l2a(sc, arg); + sc->rec_p1 = sc->unused; + return(sc->value); } -/* -------------------------------- when -------------------------------- */ -static void -check_when (s7_scheme* sc) { - const s7_pointer form= sc->code, code= cdr (sc->code); - - if (!is_pair (code)) /* (when) or (when . 1) */ - syntax_error_nr (sc, "when has no expression or body: ~A", 35, form); - if (!is_pair (cdr (code))) /* (when 1) or (when 1 . 1) */ - syntax_error_nr (sc, "when has no body?: ~A", 22, form); - if (!s7_is_proper_list (sc, cddr (code))) - syntax_error_nr (sc, "when: stray dot? ~A", 19, 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 { - const s7_pointer test= car (code); - if (is_safe_symbol (sc, test)) { - pair_set_syntax_op (form, OP_WHEN_S); - set_opt2_con (form, cadr (code)); - set_opt3_pair (form, cddr (code)); +static bool op_tc_if_a_z_if_a_l2a_z(s7_scheme *sc, s7_pointer code) +{ + bool cond = car(code) == sc->cond_symbol; + s7_pointer if2_test, if2_true, if2_false, la, l2a, l2a_slot, endp; + const s7_pointer la_slot = let_slots(sc->curlet); + const s7_pointer if1_test = (cond) ? cadr(code) : cdr(code); + const s7_pointer if1_true = cdr(if1_test); + if2_test = (cond) ? caddr(code) : cdadr(if1_true); + if2_true = cdr(if2_test); + if2_false = (cond) ? cdr(cadddr(code)) : cdr(if2_true); + la = (cond) ? opt3_pair(code) : cdar(if2_true); /* cdadr(caddr(code)) */ + l2a = cdr(la); + l2a_slot = next_slot(la_slot); + while (true) + { + if (fx_call(sc, if1_test) != sc->F) {endp = if1_true; break;} + if (fx_call(sc, if2_test) == sc->F) {endp = if2_false; break;} + sc->rec_p1 = fx_call(sc, la); + slot_set_value(l2a_slot, fx_call(sc, l2a)); + slot_set_value(la_slot, sc->rec_p1); } - 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)); - set_current_code (sc, sc->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); + return(op_tc_z(sc, endp)); } -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 s7_pointer fx_tc_if_a_z_if_a_l2a_z(s7_scheme *sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_IF_A_Z_IF_A_L2A_Z); + op_tc_if_a_z_if_a_l2a_z(sc, arg); + sc->rec_p1 = sc->unused; + return(sc->value); } -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_tc_if_a_z_if_a_l3a_l3a(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer if1_test = cdr(code); + s7_pointer endp; + const s7_pointer la_slot = let_slots(sc->curlet); + const s7_pointer if1_true = cdr(if1_test); + const s7_pointer if1_false = cadr(if1_true); + const s7_pointer if2_test = cdr(if1_false); + const s7_pointer if2_true = cdr(if2_test); + const s7_pointer if2_false = cdr(if2_true); + const s7_pointer la1 = cdar(if2_true); + const s7_pointer la2 = cdar(if2_false); + const s7_pointer l2a1 = cdr(la1); + const s7_pointer l2a2 = cdr(la2); + const s7_pointer l2a_slot = next_slot(la_slot); + const s7_pointer l3a1 = cdr(l2a1); + const s7_pointer l3a2 = cdr(l2a2); + const s7_pointer l3a_slot = next_slot(l2a_slot); + tick_tc(sc, OP_TC_IF_A_Z_IF_A_L3A_L3A); + while (true) + { + if (fx_call(sc, if1_test) != sc->F) {endp = if1_true; break;} + if (fx_call(sc, if2_test) != sc->F) + { + sc->rec_p1 = fx_call(sc, la1); + sc->rec_p2 = fx_call(sc, l2a1); + slot_set_value(l3a_slot, fx_call(sc, l3a1)); + } + else + { + sc->rec_p1 = fx_call(sc, la2); + sc->rec_p2 = fx_call(sc, l2a2); + slot_set_value(l3a_slot, fx_call(sc, l3a2)); + } + slot_set_value(l2a_slot, sc->rec_p2); + slot_set_value(la_slot, sc->rec_p1); + } + return(op_tc_z(sc, endp)); } -static bool -op_when_pp (s7_scheme* sc) { - if (is_true (sc, sc->value)) { - if_pair_set_up_begin_unchecked (sc); - return (false); - } - sc->value= sc->unspecified; - return (true); +static s7_pointer fx_tc_if_a_z_if_a_l3a_l3a(s7_scheme *sc, s7_pointer arg) +{ + op_tc_if_a_z_if_a_l3a_l3a(sc, arg); + sc->rec_p1 = sc->unused; + sc->rec_p2 = sc->unused; + return(sc->value); } -/* -------------------------------- unless -------------------------------- */ -static void -check_unless (s7_scheme* sc) { - const s7_pointer form= sc->code, code= cdr (sc->code); - - if (!is_pair (code)) /* (unless) or (unless . 1) */ - syntax_error_nr (sc, "unless has no expression or body: ~A", 37, form); - if (!is_pair (cdr (code))) /* (unless 1) or (unless 1 . 1) */ - syntax_error_nr (sc, "unless has no body?: ~A", 24, form); - if (!s7_is_proper_list (sc, cddr (code))) - syntax_error_nr (sc, "unless: stray dot? ~A", 21, 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 (sc, 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)); - set_current_code (sc, sc->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_tc_if_a_z_if_a_z_l3a(s7_scheme *sc, s7_pointer code, bool zfirst) /* zfirst: z_l3a rather than l3a_z */ +{ + const s7_pointer if1_test = cdr(code); + s7_pointer endp; + const s7_pointer la_slot = let_slots(sc->curlet); + const s7_pointer l2a_slot = next_slot(la_slot); + const s7_pointer l3a_slot = next_slot(l2a_slot); + const s7_pointer if1_true = cdr(if1_test); + const s7_pointer if1_false = cadr(if1_true); + const s7_pointer if2_test = cdr(if1_false); + const s7_pointer if2_true = cdr(if2_test); + const s7_pointer if2_false = cdr(if2_true); + const s7_pointer zendp = (zfirst) ? if2_true : if2_false; + const s7_pointer la2 = (zfirst) ? cdar(if2_false) : cdar(if2_true); + const s7_pointer l2a2 = cdr(la2); + const s7_pointer l3a2 = cdr(l2a2); + tick_tc(sc, (zfirst) ? OP_TC_IF_A_Z_IF_A_Z_L3A : OP_TC_IF_A_Z_IF_A_L3A_Z); -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); + while (true) + { + if (fx_call(sc, if1_test) != sc->F) {endp = if1_true; break;} + if ((fx_call(sc, if2_test) != sc->F) == zfirst) {endp = zendp; break;} + sc->rec_p1 = fx_call(sc, la2); + sc->rec_p2 = fx_call(sc, l2a2); + slot_set_value(l3a_slot, fx_call(sc, l3a2)); + slot_set_value(l2a_slot, sc->rec_p2); + slot_set_value(la_slot, sc->rec_p1); + } + return(op_tc_z(sc, endp)); } -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 s7_pointer fx_tc_if_a_z_if_a_z_l3a(s7_scheme *sc, s7_pointer arg) +{ + op_tc_if_a_z_if_a_z_l3a(sc, arg, true); + sc->rec_p1 = sc->unused; + sc->rec_p2 = sc->unused; + return(sc->value); } -static bool -op_unless_pp (s7_scheme* sc) { - if (is_false (sc, sc->value)) { - if_pair_set_up_begin_unchecked (sc); - return (false); - } - sc->value= sc->unspecified; - return (true); +static s7_pointer fx_tc_if_a_z_if_a_l3a_z(s7_scheme *sc, s7_pointer arg) +{ + op_tc_if_a_z_if_a_z_l3a(sc, arg, false); + sc->rec_p1 = sc->unused; + sc->rec_p2 = sc->unused; + return(sc->value); } -/* -------------------------------- begin -------------------------------- */ -static bool -op_begin (s7_scheme* sc, s7_pointer code) { - const s7_pointer form= cdr (code); - if (!s7_is_proper_list (sc, form)) /* proper list includes () */ - syntax_error_nr (sc, "unexpected dot? ~A", 18, code); - if (is_null (form)) /* (begin) -> () */ - { - sc->value= sc->nil; - return (true); - } - pair_set_syntax_op ( - sc->code, ((is_pair (cdr (form))) && (is_null (cddr (form)))) - ? OP_BEGIN_2_UNCHECKED - : OP_BEGIN_UNCHECKED); /* begin_1 doesn't happen much */ - return (false); +static bool op_tc_let_if_a_z_la(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer body = caddr(code); + const s7_pointer outer_let = sc->curlet; + const s7_pointer la_slot = let_slots(outer_let); + const s7_pointer if_test = cdr(body); + const s7_pointer if_true = cddr(body); + const bool wrappable = has_fx(if_true); + const s7_pointer if_false = cadddr(body); + const s7_pointer la = cdr(if_false); + s7_pointer let_var = caadr(code); + const s7_pointer inner_let = (wrappable) ? wrap_let_with_slot(sc, sc->curlet, car(let_var), fx_call(sc, cdr(let_var))) : + make_let_with_slot(sc, sc->curlet, car(let_var), fx_call(sc, cdr(let_var))); + const s7_pointer let_slot = let_slots(inner_let); + tick_tc(sc, OP_TC_LET_IF_A_Z_LA); + set_curlet(sc, inner_let); + if (!wrappable) gc_protect_via_stack(sc, inner_let); + let_var = cdr(let_var); + + 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); + } + if (!wrappable) unstack_gc_protect(sc); + if (!op_tc_z(sc, if_true)) return(false); + let_set_slots(inner_let, slot_end); + return(true); } -/* -------------------------------- define -------------------------------- */ -static s7_pointer -print_truncate (s7_scheme* sc, s7_pointer code) { - if (tree_len (sc, code) > sc->print_length) { - s7_pointer obj; - const s7_int old_len= sc->print_length; - sc->print_length = old_len * 10; - obj = object_to_string_truncated (sc, code); - sc->print_length = old_len; - return (obj); - } - return (code); +static s7_pointer fx_tc_let_if_a_z_la(s7_scheme *sc, s7_pointer arg) +{ + op_tc_let_if_a_z_la(sc, arg); + return(sc->value); } -static void -check_define (s7_scheme* sc) { - s7_pointer func, caller; - const s7_pointer code = cdr (sc->code); - const 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)) - syntax_error_with_caller_nr (sc, "~A: nothing to define? ~A", 25, caller, - sc->code); /* (define) */ - - if (!is_pair (cdr (code))) { - if (is_null (cdr (code))) - syntax_error_with_caller_nr (sc, "~A: no value? ~A", 16, caller, - sc->code); /* (define var) */ - syntax_error_with_caller_nr (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) */ - error_nr ( - 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) - error_nr (sc, sc->syntax_error_symbol, - set_elist_4 (sc, - wrap_string (sc, - "~A's first argument, ~A, is ~A but " - "should be a list: (name ...)", - 63), - caller, car (code), - object_type_name (sc, car (code)))); - func= car (code); - if (!is_symbol (func)) /* (define 3 a) */ - syntax_error_with_caller2_nr ( - sc, - "~A: can't define ~W (~A); it should be a symbol or a non-nil list", - 65, caller, func, object_type_name (sc, func)); - if (is_keyword (func)) /* (define :hi 1) */ - syntax_error_with_caller_nr (sc, "~A ~A: keywords are constants", 29, - caller, func); - if (is_syntactic_symbol (func)) /* (define and a) */ +static bool op_tc_let_if_a_z_l2a(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer body = caddr(code); + const s7_pointer outer_let = sc->curlet; + const s7_pointer la_slot = let_slots(outer_let); + const s7_pointer l2a_slot = next_slot(la_slot); + const s7_pointer if_test = cdr(body); + const s7_pointer if_true = cddr(body); + const bool wrappable = has_fx(if_true); + const s7_pointer if_false = cadddr(body); + const s7_pointer la = cdr(if_false); + const s7_pointer l2a = cddr(if_false); + s7_pointer let_var = caadr(code); + s7_pointer inner_let = (wrappable) ? wrap_let_with_slot(sc, sc->curlet, car(let_var), fx_call(sc, cdr(let_var))) : + make_let_with_slot(sc, sc->curlet, car(let_var), fx_call(sc, cdr(let_var))); + const s7_pointer let_slot = let_slots(inner_let); + tick_tc(sc, OP_TC_LET_IF_A_Z_L2A); + set_curlet(sc, inner_let); + if (!wrappable) gc_protect_via_stack(sc, inner_let); + let_var = cdr(let_var); + if (!no_bool_opt(code)) { - if (sc->safety > no_safety) - s7_warn ( - sc, 256, - "%s: syntactic keywords tend to behave badly if redefined: %s\n", - display (func), display_truncated (sc->code)); - 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)) && - (is_global (caadr (code)))) { - if ((is_defined_global (func)) && (is_immutable (global_slot (func))) && - (initial_value_is_defined (sc, func))) - immutable_object_error_nr ( - sc, set_elist_3 ( - sc, wrap_string (sc, "can't ~A ~S: it is immutable", 28), - caller, func)); - if (!is_pair (cdadr (code))) /* (define x (lambda . 1)) */ - syntax_error_with_caller_nr (sc, "~A: stray dot? ~A", 17, caller, - sc->code); - if (!is_pair (cddr (cadr (code)))) /* (define f (lambda (arg))) */ - syntax_error_with_caller_nr (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)), - cadr (code)); - else check_lambda_args (sc, cadadr (code), NULL, cadr (code)); - 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) */ - syntax_error_with_caller2_nr ( - sc, "~A: can't define ~S, ~A (should be a symbol or a non-nil list)", - 62, caller, func, object_type_name (sc, func)); - if (is_syntactic_symbol (func)) /* (define (and a) a) */ + sc->pc = 0; + if (bool_optimize(sc, if_test)) + { + opt_info *o = sc->opts[0]; + opt_info *o1 = sc->opts[sc->pc], *o2, *o3; + if ((is_t_integer(slot_value(la_slot))) && + (is_t_integer(slot_value(l2a_slot)))) + { + if (int_optimize(sc, la)) + { + o2 = sc->opts[sc->pc]; + if (int_optimize(sc, l2a)) + { + o3 = sc->opts[sc->pc]; + set_curlet(sc, outer_let); + if (int_optimize(sc, let_var)) + { + s7_pointer val1 = make_mutable_integer(sc, integer(slot_value(la_slot))); + s7_pointer val2 = make_mutable_integer(sc, integer(slot_value(l2a_slot))); + s7_pointer val3 = make_mutable_integer(sc, integer(slot_value(let_slot))); + set_curlet(sc, inner_let); + slot_set_value(la_slot, val1); + slot_set_value(l2a_slot, val2); + slot_set_value(let_slot, val3); + while (!(q_call(o).fb(o))) + { + s7_int i1 = q_call(o1).fi(o1); + set_integer(val2, q_call(o2).fi(o2)); + set_integer(val1, i1); + set_integer(val3, q_call(o3).fi(o3)); + } + if (!wrappable) unstack_gc_protect(sc); + if (!op_tc_z(sc, if_true)) return(false); + let_set_slots(inner_let, slot_end); + return(true); + }}}}} + set_no_bool_opt(code); + } + while (fx_call(sc, if_test) == sc->F) { - if (sc->safety > no_safety) - s7_warn ( - sc, 256, - "%s: syntactic keywords tend to behave badly if redefined: %s\n", - display (func), display_truncated (sc->code)); - set_local (func); - } - if ((is_defined_global (func)) && (is_immutable (global_slot (func))) && - (initial_value_is_defined ( - sc, func))) /* (define (abs x) 1) after (immutable! abs) */ - immutable_object_error_nr ( - sc, - set_elist_3 (sc, wrap_string (sc, "can't ~A ~S: it is immutable", 28), - caller, func)); - if (starred) - set_cdar (code, - check_lambda_star_args (sc, cdar (code), cdr (code), sc->code)); - else check_lambda_args (sc, cdar (code), NULL, sc->code); - optimize_lambda (sc, !starred, func, cdar (code), cdr (code)); - } - if (sc->cur_op == OP_DEFINE) { - if ((is_pair (car (code))) && (!is_possibly_constant (func))) - pair_set_syntax_op (sc->code, OP_DEFINE_FUNCHECKED); - else pair_set_syntax_op (sc->code, OP_DEFINE_UNCHECKED); - } - else - pair_set_syntax_op (sc->code, (starred) ? OP_DEFINE_STAR_UNCHECKED - : OP_DEFINE_CONSTANT_UNCHECKED); + sc->rec_p1 = fx_call(sc, la); + slot_set_value(l2a_slot, fx_call(sc, l2a)); + 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); + } + if (!wrappable) unstack_gc_protect(sc); + if (!op_tc_z(sc, if_true)) return(false); + let_set_slots(inner_let, slot_end); + return(true); } -static bool -op_define_unchecked (s7_scheme* sc) { - const s7_pointer code= cdr (sc->code); - s7_pointer locp; +static s7_pointer fx_tc_let_if_a_z_l2a(s7_scheme *sc, s7_pointer arg) +{ + op_tc_let_if_a_z_l2a(sc, arg); + sc->rec_p1 = sc->unused; + return(sc->value); +} - if ((is_pair (car (code))) && (has_location (car (code)))) locp= car (code); +static s7_pointer op_tc_let_when_l2a(s7_scheme *sc, s7_pointer code) +{ + s7_pointer p, la, l2a, let_var = caadr(code); + const s7_pointer body = caddr(code), outer_let = sc->curlet; + const bool when = (car(body) != sc->unless_symbol); /* can also be when or if */ + const s7_pointer if_test = cdr(body); + const s7_pointer if_true = cddr(body); + s7_pointer inner_let = wrap_let_with_slot(sc, sc->curlet, car(let_var), fx_call(sc, cdr(let_var))); + s7_pointer let_slot = let_slots(inner_let); + tick_tc(sc, OP_TC_LET_WHEN_L2A); + + set_curlet(sc, inner_let); + let_var = cdr(let_var); + for (p = if_true; is_pair(cdr(p)); p = cdr(p)); + la = cdar(p); + l2a = cddar(p); + if ((car(la) == slot_symbol(let_slots(outer_let))) && + (car(l2a) == slot_symbol(next_slot(let_slots(outer_let))))) + { + if ((cdr(if_true) == p) && (!when)) + { + s7_pointer a1 = slot_value(let_slots(outer_let)); + s7_pointer 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 = (int32_t)s7_character(slot_value(let_slots(inner_let))); + a1 = slot_value(let_slots(outer_let)); + a2 = slot_value(next_slot(let_slots(outer_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) + { + s7_pointer p2 = fx_call(sc, if_test); + if (when) {if (p2 == sc->F) break;} else {if (p2 != sc->F) break;} + for (s7_pointer p1 = if_true; is_pair(cdr(p1)); p1 = cdr(p1)) + fx_call(sc, p1); + set_curlet(sc, outer_let); + slot_set_value(let_slot, fx_call(sc, let_var)); + set_curlet(sc, inner_let); + }} else - locp= ((is_pair (cadr (code))) && (has_location (cadr (code)))) - ? cadr (code) - : 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))) { - const s7_pointer definee= car (code); - sc->code = cadr (code); - if (is_pair (sc->code)) { - push_stack_no_args (sc, OP_DEFINE1, definee); - sc->cur_op= optimize_op (sc->code); - return (true); - } - sc->value= (is_symbol (sc->code)) ? lookup_global (sc, sc->code) : sc->code; - sc->code = definee; - } - else { - const s7_pointer 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. - */ - const s7_pointer func= 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 (func), pair_location (locp)); - set_has_location (closure_body (func)); - } - sc->value= T_Ext (func); - sc->code = caar (code); - } - return (false); + { + s7_pointer la_slot = let_slots(outer_let); + s7_pointer l2a_slot = next_slot(la_slot); + while (true) + { + s7_pointer p2 = fx_call(sc, if_test); + if (when) {if (p2 == sc->F) break;} else {if (p2 != sc->F) break;} + for (s7_pointer p1 = if_true; is_pair(cdr(p1)); p1 = cdr(p1)) + fx_call(sc, p1); + sc->rec_p1 = fx_call(sc, la); + slot_set_value(l2a_slot, fx_call(sc, l2a)); + 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); + }} + return(sc->unspecified); +} + +static bool op_tc_if_a_z_let_if_a_z_l2a(s7_scheme *sc, s7_pointer code) +{ + s7_pointer endp, slot; + const s7_pointer if1_test = cdr(code), outer_let = sc->curlet, la_slot = let_slots(sc->curlet); + const s7_pointer if1_true = cdr(if1_test); /* cddr(code) */ + const s7_pointer let_expr = cadr(if1_true); /* cadddr(code) */ + const s7_pointer let_vars = cadr(let_expr); + const s7_pointer if2 = caddr(let_expr); + const s7_pointer if2_test = cdr(if2); + const s7_pointer if2_true = cdr(if2_test); /* cddr(if2) */ + const s7_pointer la = cdadr(if2_true); /* cdr(cadddr(if2)) */ + const s7_pointer l2a = cdr(la); + const s7_pointer l2a_slot = next_slot(la_slot); + const s7_pointer inner_let = inline_make_let(sc, sc->curlet); + tick_tc(sc, OP_TC_IF_A_Z_LET_IF_A_Z_L2A); + + gc_protect_via_stack(sc, inner_let); + slot = make_slot(sc, caar(let_vars), sc->F); + slot_set_next(slot, slot_end); + let_set_slots(inner_let, slot); + symbol_set_local_slot_unincremented(caar(let_vars), let_id(inner_let), slot); + for (s7_pointer 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 (s7_pointer var = cdr(let_vars), slot1 = next_slot(slot); is_pair(var); var = cdr(var), slot1 = next_slot(slot1)) + slot_set_value(slot1, 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(l2a_slot, fx_call(sc, l2a)); + slot_set_value(la_slot, sc->rec_p1); + set_curlet(sc, outer_let); + } + sc->rec_p1 = sc->unused; + unstack_gc_protect(sc); + return(op_tc_z(sc, endp)); /* might refer to inner_let slots */ } -static s7_pointer -make_funclet (s7_scheme* sc, s7_pointer new_func, s7_pointer func_name, - s7_pointer outer_let) { - s7_pointer new_let, pars; - new_cell_unchecked (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); - - pars= closure_pars (new_func); - if (is_null (pars)) { - let_set_slots (new_let, slot_end); - return (new_let); - } - if (is_safe_closure (new_func)) { - s7_pointer last_slot= NULL; - if (is_closure (new_func)) { - if (is_pair (pars)) { - last_slot= make_slot (sc, car (pars), sc->nil); - slot_set_next (last_slot, slot_end); - let_set_slots (new_let, last_slot); - symbol_set_local_slot (car (pars), let_id (new_let), last_slot); - for (pars= cdr (pars); is_pair (pars); pars= cdr (pars)) - last_slot= add_slot_at_end (sc, let_id (new_let), last_slot, - car (pars), sc->nil); - } - if (is_symbol (pars)) { - if (last_slot) - last_slot= add_slot_checked_at_end (sc, let_id (new_let), last_slot, - pars, sc->nil); - else { - last_slot= make_slot (sc, pars, sc->nil); - slot_set_next (last_slot, slot_end); - let_set_slots (new_let, last_slot); - symbol_set_local_slot (pars, let_id (new_let), last_slot); - } - set_is_rest_slot (last_slot); - } +static bool op_tc_let_cond(s7_scheme *sc, s7_pointer code) +{ + const s7_int args = opt3_arglen(cdr(code)); + s7_pointer result; + const s7_pointer outer_let = sc->curlet; + const s7_pointer slots = let_slots(outer_let); + const s7_pointer cond_body = cdaddr(code); /* code here == body in check_tc */ + s7_pointer let_var = caadr(code); + s7_function letf = fx_proc(cdr(let_var)); + const s7_pointer inner_let = make_let_with_slot(sc, sc->curlet, car(let_var), fx_call(sc, cdr(let_var))); + const s7_pointer let_slot = let_slots(inner_let); + tick_tc(sc, OP_TC_LET_COND); + + set_curlet(sc, inner_let); + gc_protect_via_stack(sc, inner_let); + let_var = cadr(let_var); + if ((letf == fx_c_s_direct) && + (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)); } - else /* closure_star */ - { - s7_pointer slot, first_default= sc->nil; - let_set_slots (new_let, slot_end); - for (; is_pair (pars); pars= cdr (pars)) { - s7_pointer par= car (pars); - if (is_pair (par)) { - const 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->rest_keyword) { - pars= cdr (pars); - slot= add_slot_checked (sc, new_let, car (pars), 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 (pars)) { - slot= add_slot_checked (sc, new_let, pars, - sc->nil); /* set up rest pars */ - set_is_rest_slot (slot); - slot_set_expression (slot, sc->nil); - } - if (is_not_slot_end (let_slots (new_let))) { - let_set_slots (new_let, reverse_slots (let_slots (new_let))); - slot_set_pending_value (let_slots (new_let), first_default); - } + /* in the named let no-var case slots may contain the let name (it's the funclet) */ + if (args < 2) + while (true) + for (s7_pointer p = cond_body; is_pair(p); p = cdr(p)) + if (fx_call(sc, car(p)) != sc->F) + { + result = cdar(p); + if (!has_tc(result)) + goto TC_LET_COND_DONE; + if (args == 1) + 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; + } + let_set_has_pending_value(outer_let); + { + bool read_case = ((letf == read_char_p_p) && (is_input_port(let_var)) && (is_string_port(let_var)) && (!port_is_closed(let_var))); + while (true) + for (s7_pointer p = cond_body; is_pair(p); p = cdr(p)) + if (fx_call(sc, car(p)) != sc->F) + { + result = cdar(p); + if (!has_tc(result)) + goto TC_LET_COND_DONE; + for (s7_pointer 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 (s7_pointer slot = slots; is_not_slot_end(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; + }} + let_clear_has_pending_value(sc, outer_let); + + TC_LET_COND_DONE: + unstack_gc_protect(sc); + if (has_fx(result)) + { + sc->value = fx_call(sc, result); + return(true); } - set_immutable_let (new_let); - } - else - let_set_slots (new_let, - slot_end); /* if unsafe closure, parameter-holding-let will - be created on each call */ - return (new_let); + sc->code = car(result); + return(false); } -static bool -op_define_constant (s7_scheme* sc) { - const s7_pointer code= cdr (sc->code); - if ((!is_pair (code)) || (!is_pair (cdr (code)))) /* (define-constant) */ - syntax_error_nr (sc, "define-constant: not enough arguments: ~S", 41, - sc->code); +static s7_pointer fx_tc_let_cond(s7_scheme *sc, s7_pointer arg) +{ + op_tc_let_cond(sc, arg); + return(sc->value); +} - if (is_symbol_and_keyword ( - car (code))) /* (define-constant :rest :allow-other-keys) */ - { - if (car (code) == cadr (code)) /* (define-constant pi pi) returns pi */ +static bool op_tc_cond_a_z_a_l2a_l2a(s7_scheme *sc, s7_pointer code) +{ + s7_pointer c1 = cadr(code); + const s7_pointer c2 = caddr(code), la_slot = let_slots(sc->curlet); + const s7_pointer la1 = cdadr(c2); + const s7_pointer l2a1 = cddadr(c2); + const s7_pointer c3 = opt3_pair(code); /* cadr(cadddr(code)) = cadr(else_clause) */ + const s7_pointer la2 = cdr(c3); + const s7_pointer l2a2 = cddr(c3); + const s7_pointer l2a_slot = next_slot(la_slot); + tick_tc(sc, OP_TC_COND_A_Z_A_L2A_L2A); + while (true) { - sc->value= car (code); - return (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(l2a_slot, fx_call(sc, l2a1)); + } + else + { + sc->rec_p1 = fx_call(sc, la2); + slot_set_value(l2a_slot, fx_call(sc, l2a2)); + } + slot_set_value(la_slot, sc->rec_p1); } - syntax_error_with_caller_nr (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)) && - (is_global (car (code))) && /* else (let iter ... (define-constant iter - iter) ...) -> segfault on later calls */ - (is_null (cddr (code)))) { - const s7_pointer sym= car (code); - set_immutable_slot (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)) { - const s7_pointer slot= s7_t_slot (sc, sc->code); - set_possibly_constant (sc->code); - set_immutable_slot (slot); - if (is_any_closure (slot_value (slot))) - set_immutable (slot_value (slot)); /* for the optimizer mainly */ - } + return(op_tc_z(sc, c1)); } -static inline void -define_funchecked (s7_scheme* sc) { - const s7_pointer code = cdr (sc->code); - const s7_pointer func_name= caar (code); - s7_pointer new_func; - - new_cell (sc, new_func, - T_CLOSURE | - ((!s7_is_proper_list (sc, cdar (code))) ? T_COPY_ARGS : 0)); - closure_set_pars (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, func_name, sc->curlet); - } - else - closure_set_let (new_func, - sc->curlet); /* unsafe closures created by other functions - do not support *function* */ +static s7_pointer fx_tc_cond_a_z_a_l2a_l2a(s7_scheme *sc, s7_pointer arg) +{ + op_tc_cond_a_z_a_l2a_l2a(sc, arg); + sc->rec_p1 = sc->unused; + return(sc->value); +} - if (let_id (sc->curlet) < symbol_id (func_name)) - sc->let_number++; /* dummy let, force symbol lookup */ +static bool op_tc_cond_n(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer let = sc->curlet; + const s7_pointer slots = let_slots(let); + const s7_int args = opt3_arglen(cdr(code)); + const s7_pointer cond_body = cdr(code); + s7_pointer result = sc->unspecified; + tick_tc(sc, OP_TC_COND_N); - /* see if func_name exists in curlet, reset its value if so */ - for (s7_pointer slot= let_slots (sc->curlet); is_not_slot_end (slot); - slot = next_slot (slot)) - if (slot_symbol (slot) == func_name) { - if (is_immutable_slot (slot)) - syntax_error_nr (sc, "define ~S, but it is immutable", 30, func_name); - slot_set_value (slot, new_func); - symbol_set_local_slot (func_name, sc->let_number, slot); - if (sc->curlet == sc->rootlet) set_global_value (func_name, new_func); - set_local (func_name); - sc->value= new_func; - return; + if (args < 2) + while (true) + for (s7_pointer p = cond_body; is_pair(p); p = cdr(p)) + if (fx_call(sc, car(p)) != sc->F) /* we got true car(clause) */ + { + result = cdar(p); + if (!has_tc(result)) + goto TC_COND_N_DONE; + if (args == 1) + slot_set_value(slots, fx_call(sc, cdar(result))); /* arg to recursion */ + break; /* tc call */ + } + let_set_has_pending_value(let); + while (true) + for (s7_pointer p = cond_body; is_pair(p); p = cdr(p)) + if (fx_call(sc, car(p)) != sc->F) + { + result = cdar(p); + if (!has_tc(result)) + goto TC_COND_N_DONE; + for (s7_pointer 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 (s7_pointer slot = slots; is_not_slot_end(slot); slot = next_slot(slot)) /* using two swapping lets instead is slightly slower */ + slot_set_value(slot, slot_pending_value(slot)); + break; + } + let_clear_has_pending_value(sc, let); + + TC_COND_N_DONE: + if (has_fx(result)) + { + sc->value = fx_call(sc, result); + return(true); } - /* else add a slot for func_name */ - if (sc->curlet == sc->rootlet) /* (let () (define (func) (with-let (rootlet) - (define (f x) (+ x 1)))) (func) (func)) */ - s7_define (sc, sc->rootlet, func_name, new_func); - else add_slot_unchecked (sc, sc->curlet, func_name, new_func, sc->let_number); - sc->value= new_func; -} - -static s7_pointer -check_define_macro (s7_scheme* sc, opcode_t op, s7_pointer form) { - s7_pointer mac_name, args; - const s7_pointer caller= cur_op_to_caller (sc, op); - - if (!is_pair (sc->code)) /* (define-macro . 1) */ - syntax_error_with_caller_nr (sc, "~A name missing (stray dot?): ~A", 32, - caller, sc->code); - if (!is_pair (car (sc->code))) /* (define-macro a ...) */ - wrong_type_error_nr (sc, caller, 1, car (sc->code), - wrap_string (sc, "a list: (name ...)", 18)); - - mac_name= caar (sc->code); - if (!is_symbol (mac_name)) - syntax_error_with_caller_nr (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, 256, - "%s: syntactic keywords tend to behave badly if redefined: %s\n", - display (mac_name), display_truncated (sc->code)); - set_local (mac_name); - } - if (is_constant_symbol (sc, mac_name)) - syntax_error_with_caller_nr (sc, "~A: ~S is constant", 18, caller, - mac_name); - - if (!is_pair (cdr (sc->code))) /* (define-macro (...)) */ - syntax_error_with_caller_nr (sc, "~A ~A, but no body?", 19, caller, - mac_name); - - if (s7_list_length (sc, cdr (sc->code)) < 0) /* (define-macro (hi) 1 . 2) */ - error_nr (sc, sc->syntax_error_symbol, - set_elist_3 (sc, - wrap_string (sc, "~A: macro body messed up, ~A", 28), - caller, sc->code)); - - args= cdar (sc->code); - if ((!is_list (args)) && (!is_symbol (args))) - error_nr ( - 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))) - error_nr ( - 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, form); - } - else set_cdar (sc->code, check_lambda_star_args (sc, args, NULL, form)); - return (sc->code); -} - -static s7_pointer -check_macro (s7_scheme* sc, opcode_t op, s7_pointer form) { - s7_pointer args; - const s7_pointer caller= cur_op_to_caller (sc, op); - - if (!is_pair ( - sc->code)) /* sc->code = cdr(form) */ /* (macro) or (macro . 1) */ - syntax_error_with_caller_nr (sc, "~S: ~S has no parameters or body?", 33, - caller, form); - if (!is_pair (cdr (sc->code))) /* (macro (a)) */ - syntax_error_with_caller_nr (sc, "~S: ~S has no body?", 19, caller, form); - - args= car (sc->code); - if ((!is_list (args)) && (!is_symbol (args))) - error_nr (sc, sc->syntax_error_symbol, /* (macro #(0) ...) */ - set_elist_2 (sc, - wrap_string (sc, "macro parameter list is ~S?", 27), - args)); - - if ((op == OP_MACRO) || (op == OP_BACRO)) { - for (; is_pair (args); args= cdr (args)) - if (!is_symbol (car (args))) - error_nr ( - sc, sc->syntax_error_symbol, /* (macro (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, form); - } - else set_car (sc->code, check_lambda_star_args (sc, args, NULL, form)); - if (s7_list_length (sc, cdr (sc->code)) < 0) /* (macro () 1 . 2) */ - error_nr (sc, sc->syntax_error_symbol, - set_elist_3 (sc, - wrap_string (sc, "~A: macro body messed up, ~A", 28), - caller, form)); - - return (sc->code); + sc->code = car(result); + return(false); } -static void -op_macro (s7_scheme* sc) /* (macro (x) `(+ ,x 1)) */ +static s7_pointer fx_tc_cond_n(s7_scheme *sc, s7_pointer arg) { - const s7_pointer form= sc->code; - 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, form); - set_mac_is_ok ( - sc->code); /* the !is_pair case raised an error in check_macro */ - } - sc->value= make_macro (sc, sc->cur_op, false); -} - -static void -op_define_macro (s7_scheme* sc) { - const s7_pointer form= sc->code; - sc->code = cdr (sc->code); - check_define_macro (sc, sc->cur_op, form); - if ((is_immutable (sc->curlet)) && (is_let (sc->curlet))) - syntax_error_nr (sc, "define-macro ~S: let is immutable", 33, - caar (sc->code)); /* need syntax_error_any_with_caller? */ - sc->value= make_macro (sc, sc->cur_op, true); -} - -static bool unknown_any (s7_scheme* sc, s7_pointer func, s7_pointer code); - -static opcode_t -fixup_macro_d (s7_scheme* sc, opcode_t op, s7_pointer mac) { - if (closure_arity_unknown (mac)) - closure_set_arity (mac, s7_list_length (sc, closure_pars (mac))); - return (op); -} - -static inline bool -op_macro_d (s7_scheme* sc, uint8_t typ) { - sc->value= lookup (sc, car (sc->code)); - if (type (sc->value) != - typ) /* for-each (etc) called a macro before, now it's something else -- a - very rare case (ca. 20 cases in s7test.scm) */ - return (unknown_any ( - sc, sc->value, - sc->code)); /* see m4 in tmac.scm, macro -> macro* could be handled in - place: call apply_macro_star_1(sc) */ - sc->args= cdr ( - sc->code); /* used to copy here, but that appears to be unnecessary */ - sc->code= sc->value; /* the macro */ - check_stack_size (sc); /* (define-macro (f) (f)) (f) */ - push_stack_op_let (sc, OP_EVAL_MACRO); - set_curlet (sc, inline_make_let (sc, closure_let (sc->code))); - return (false); /* fall into apply_lambda */ -} - -static void apply_macro_star_1 (s7_scheme* sc); - -static bool -op_macro_star_d (s7_scheme* sc) { - if (op_macro_d (sc, T_MACRO_STAR)) return (true); - apply_macro_star_1 (sc); - return (false); -} - -static void -transfer_macro_info (s7_scheme* sc, s7_pointer mac) { - const 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); - } + op_tc_cond_n(sc, arg); + return(sc->value); } -static void -check_c_macro_args (s7_scheme* sc, s7_pointer mac, s7_pointer args) { - const s7_int len= proper_list_length (args); - if (len < c_macro_min_args (sc->code)) - error_nr ( - sc, sc->wrong_number_of_args_symbol, - set_elist_4 ( - sc, wrap_string (sc, "~A: not enough arguments: (~A~{~^ ~S~})", 39), - sc->code, sc->code, sc->args)); - if (c_macro_max_args (sc->code) < len) - error_nr (sc, sc->wrong_number_of_args_symbol, - set_elist_4 ( - sc, - wrap_string (sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), - sc->code, sc->code, sc->args)); -} - -static goto_t -op_expansion (s7_scheme* sc) { - const s7_pointer caller= (is_pair (stack_top_args (sc))) - ? car (stack_top_args (sc)) - : sc->F; /* this can be garbage */ - if ((sc->stack_end > sc->stack_start) && /* there is a stack... */ - (stack_top_op (sc) != OP_READ_QUOTE) && /* '(expansion ...) */ - (stack_top_op (sc) != OP_READ_VECTOR) && /* #(expansion ...) */ - (!is_quote (sc, caller)) && /* (#_quote ...) */ - (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 */ - { - const s7_pointer symbol= car (sc->value); - if (!is_let (sc->curlet)) set_curlet (sc, sc->rootlet); +/* -------- rec -------- */ + +#ifndef INITIAL_RECUR_STACK_SIZE + #define INITIAL_RECUR_STACK_SIZE 1024 /* stack max size 39 in s7test.scm, 1001 trec, 513 c, 100 b */ +#endif - if (is_symbol (symbol)) /* maybe (#_cond-expand) etc */ +static void recur_resize(s7_scheme *sc) +{ + const s7_pointer stack = sc->rec_stack; + block_t *old_b, *new_b; + if ((sc->rec_len / 2) > sc->max_stack_size) /* /2 not *2 because the stack size refers to the 4-frame main stack */ +#if S7_DEBUGGING { - s7_pointer slot; - if ((is_global (symbol)) || (sc->curlet == sc->nil)) - slot= global_slot (symbol); - else slot= s7_t_slot (sc, symbol); - sc->code= (is_slot (slot)) ? slot_value (slot) : sc->undefined; - } - else sc->code= symbol; - - if ((!is_any_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); - if (is_c_macro (sc->code)) { - check_c_macro_args (sc, sc->code, sc->args); - sc->value= c_macro_call (sc->code) (sc, sc->args); - return (goto_start); - } - set_curlet (sc, 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); /* apply_lambda probably handles arg number checks */ - 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 - */ + fprintf(stderr, "%s%s[%d]: rec stack will be too big after resize, %" ld64 " > %u%s\n", bold_text, __func__, __LINE__, sc->rec_len / 2, sc->max_stack_size, unbold_text); + if (sc->stop_at_error) abort(); } - } - 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) */ -{ - check_c_macro_args (sc, 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: - set_curlet (sc, make_let (sc, closure_let (sc->code))); - return (goto_apply_lambda); - case T_BACRO: - set_curlet (sc, make_let (sc, sc->curlet)); - return (goto_apply_lambda); - case T_MACRO_STAR: - set_curlet (sc, make_let (sc, closure_let (sc->code))); - apply_macro_star_1 (sc); - return (goto_begin); - case T_BACRO_STAR: - set_curlet (sc, 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: - syntax_error_nr (sc, "macroexpand argument is not a macro call: ~A", 44, - sc->args); /* maybe car(sc->args)? */ - } - if (S7_DEBUGGING) - fprintf (stderr, "%s[%d]: we should not be here\n", __func__, __LINE__); - return (fall_through); /* for the compiler */ +#else + error_nr(sc, make_symbol(sc, "stack-too-big", 13), + set_elist_1(sc, wrap_string(sc, "rec stack has grown past (*s7* 'max-stack-size)", 47))); +#endif + vector_length(stack) = sc->rec_len * 2; + old_b = vector_block(stack); + new_b = reallocate(sc, old_b, vector_length(stack) * sizeof(s7_pointer)); + block_info(new_b) = NULL; + vector_block(stack) = new_b; + vector_elements(stack) = (s7_pointer *)block_data(new_b); /* GC looks only at elements within sc->rec_loc */ + sc->rec_len = vector_length(stack); + sc->rec_els = vector_elements(stack); } -static goto_t -op_macroexpand (s7_scheme* sc) { - const 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)))) - syntax_error_nr (sc, "macroexpand argument is not a macro call: ~A", 44, - form); - if (!is_null (cdr (sc->code))) - syntax_error_nr (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)) */ - syntax_error_nr ( - 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))) - syntax_error_nr (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 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 goto_t -op_macroexpand_1 (s7_scheme* sc) { - sc->args= cdar (sc->code); - sc->code= sc->value; - return (macroexpand (sc)); +static inline void recur_push_unchecked(s7_scheme *sc, s7_pointer value) +{ + if ((S7_DEBUGGING) && (sc->rec_loc == sc->rec_len)) fprintf(stderr, "%s[%d]: recur stack resize skipped\n", __func__, __LINE__); + sc->rec_els[sc->rec_loc++] = value; } -static void -op_eval_macro (s7_scheme* sc) /* after (scheme-side) macroexpansion, evaluate - the resulting expression */ +static s7_pointer recur_pop(s7_scheme *sc) {return(sc->rec_els[--sc->rec_loc]);} /* macro is not faster */ +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) { - /* (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; + sc->rec_loc -= 2; + return(sc->rec_els[sc->rec_loc + 1]); } -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 s7_pointer recur_swap(s7_scheme *sc, s7_pointer value) +{ + s7_pointer result = sc->rec_els[sc->rec_loc - 1]; + sc->rec_els[sc->rec_loc - 1] = value; + return(result); } -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 (SHOW_EVAL_OPS) - fprintf (stderr, " %s[%d]: op: %s, value: %s\n", __func__, __LINE__, - op_names[stack_top_op (sc)], display_truncated (sc->value)); - if (sc->value == sc->no_value) { - if (stack_top_op (sc) != - OP_LOAD_RETURN_IF_EOF) /* latter op if empty expansion at top-level */ - { - if (stack_top_op (sc) != - OP_READ_LIST) /* OP_EVAL_STRING: (eval-string "(reader-cond...)") - where reader-cond returns (values) */ - sc->value= - sc->F; /* (eval-string "") -> #f, was nil_string for awhile */ - else set_stack_top_op (sc, OP_READ_NEXT); - /* OP_READ_DONE: (eval-string (object->string (with-input-from-string - * "(reader-cond ((provided? 'surreals) 123))" read))) */ - } - } - else if (is_pair (sc->value)) sc->value= copy_body (sc, sc->value); +static void initialize_recur_stack(s7_scheme *sc) +{ + sc->rec_stack = make_simple_vector(sc, INITIAL_RECUR_STACK_SIZE); + sc->rec_els = vector_elements(sc->rec_stack); + sc->rec_len = INITIAL_RECUR_STACK_SIZE; + sc->rec_loc = 0; } -/* -------------------------------- with-let -------------------------------- */ -static s7_pointer -fx_with_let_s (s7_scheme* sc, s7_pointer arg) { - const s7_pointer code= cdr (arg); - s7_pointer let = lookup_checked (sc, car (code)); - const s7_pointer sym = cadr (code); - s7_pointer val; - if (!is_let (let)) { - let= find_let (sc, let); - if (!is_let (let)) { - s7_pointer new_let= find_let (sc, let); - if ((!is_let (new_let)) || (new_let == sc->rootlet)) - find_let_error_nr (sc, sc->with_let_symbol, let, new_let, 1, - set_mlist_1 (sc, let)); - let= new_let; - } - } - /* let here if mock-hash can be (for example) (inlet 'value (hash-table 'b 2) - * 'mock-type mock-hash-table?) mock-hash has let-ref-fallback which calls - * (#_hash-table-ref (env 'value) sym) -> (env 'value) is a hash-table, so - * returns #f (missing-key-value?) if not in table we go directly to this - * function in check_with_let to avoid this ambiguity - */ - val= let_ref (sc, let, - sym); /* (with-let env s) -> (let-ref env s), "s" unevalled */ - if (val == sc->undefined) /* but sym can have the value #: - (with-let (inlet 'x #) x) */ - { - if (is_slot (global_slot (sym))) /* (let () (define (func) (with-let *s7* - letrec*)) (func) (func)), .5 tlet */ - return (global_value (sym)); /* used to check also that e=*s7* */ - if (is_slot (lookup_slot_with_let ( - sc, sym, let))) /* check for explicit # value! */ - return (sc->undefined); - unbound_variable_error_nr (sc, sym); - } - return (val); -} +static void rec_set_test(s7_scheme *sc, s7_pointer p) {sc->rec_testf = fx_proc(p); sc->rec_testp = car(p);} +static void rec_set_res(s7_scheme *sc, s7_pointer p) {sc->rec_resf = fx_proc(p); sc->rec_resp = car(p);} +static void rec_set_f1(s7_scheme *sc, s7_pointer p) {sc->rec_f1f = fx_proc(p); sc->rec_f1p = car(p);} +static void rec_set_f2(s7_scheme *sc, s7_pointer p) {sc->rec_f2f = fx_proc(p); sc->rec_f2p = car(p);} +static void rec_set_f3(s7_scheme *sc, s7_pointer p) {sc->rec_f3f = fx_proc(p); sc->rec_f3p = car(p);} +static void rec_set_f4(s7_scheme *sc, s7_pointer p) {sc->rec_f4f = fx_proc(p); sc->rec_f4p = car(p);} +static void rec_set_f5(s7_scheme *sc, s7_pointer p) {sc->rec_f5f = fx_proc(p); sc->rec_f5p = car(p);} +static void rec_set_f6(s7_scheme *sc, s7_pointer p) {sc->rec_f6f = fx_proc(p); sc->rec_f6p = car(p);} +static void rec_set_f7(s7_scheme *sc, s7_pointer p) {sc->rec_f7f = fx_proc(p); sc->rec_f7p = car(p);} +static void rec_set_f8(s7_scheme *sc, s7_pointer p) {sc->rec_f8f = fx_proc(p); sc->rec_f8p = car(p);} -static bool -check_with_let (s7_scheme* sc) { - const s7_pointer form= cdr (sc->code); - if (SHOW_EVAL_OPS) - fprintf (stderr, " %s[%d]: op: %s, form: %s\n", __func__, __LINE__, - op_names[stack_top_op (sc)], display_truncated (form)); - if (!is_pair (form)) /* (with-let . "hi") */ - syntax_error_nr (sc, "with-let takes a let (an environment) argument: ~A", - 50, sc->code); - if (is_null (cdr (form))) /* (with-let e) */ - syntax_error_nr (sc, "with-let has no body: ~A", 24, sc->code); - if (!s7_is_proper_list (sc, cdr (form))) /* (with-let e . 3) */ - syntax_error_nr (sc, "stray dot in with-let body: ~S", 30, sc->code); - if ((sc->safety > 1) && (is_symbol (car (form))) && - (is_c_function (initial_value (car (form))))) - s7_warn (sc, 256, "%s is a strange first argument to with-let\n", - display (car (form))); /* (with-let curlet ...) where they probably - meant (with-let (curlet) ...) */ - set_current_code (sc, sc->code); - if ((is_normal_symbol (car (form))) && - (is_normal_symbol (cadr ( - form))) && /* (with-let lt a) is not the same as (with-let lt :a) */ - (is_null (cddr (form)))) { - pair_set_syntax_op (sc->code, OP_WITH_LET_S); - sc->value= fx_with_let_s (sc, sc->code); - return (false); - } - else pair_set_syntax_op (sc->code, OP_WITH_LET_UNCHECKED); - return (true); -} - -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 void -activate_starlet (s7_scheme* sc) { - const s7_pointer new_let= - let_copy (sc, sc->starlet); /* get fallback methods */ - const s7_pointer iter= s7_make_iterator (sc, sc->starlet); - gc_protect_2_via_stack (sc, new_let, iter); - iterator_carrier (iter)= cons_unchecked (sc, sc->F, sc->F); - set_has_carrier (iter); - while (true) { - const s7_pointer field= - s7_iterate (sc, iter); /* next *s7* field as '(symbol . value) */ - if (iterator_is_at_end (iter)) break; - if (lookup_unexamined (sc, car (field))) - add_slot_checked_with_id (sc, new_let, car (field), cdr (field)); - } - set_curlet (sc, new_let); - set_immutable_let (new_let); - unstack_gc_protect (sc); -} +typedef enum {opt_ptr, opt_int, opt_dbl, opt_int_0} opt_pid_t; -static void -activate_with_let (s7_scheme* sc, s7_pointer let) { - if (!is_let (let)) /* (with-let . "hi") */ - { - const s7_pointer new_let= - find_let (sc, let); /* sc->nil/rootlet here means no let found */ - if (!is_let (new_let)) - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_2 ( - sc, - wrap_string ( - sc, "with-let takes a let (an environment) argument: ~A", 50), - let)); - let= new_let; - } - if (let == sc->rootlet) set_curlet (sc, let); /* (with-let (rootlet) ...) */ - else if (let == sc->starlet) activate_starlet (sc); - else { - set_with_let_let (let); - let_set_id (let, ++sc->let_number); - set_curlet (sc, let); - update_symbol_ids (sc, let); - } + +/* -------- if_a_a_opla_laq and if_a_opla_laq_a -------- */ + +static opt_pid_t opinit_if_a_a_opla_laq(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer caller = rec_call_clause(code); + const s7_pointer call1 = cadr(caller); + const s7_pointer call2 = caddr(caller); + + const s7_pointer c_op = car(caller); + tick_tc(sc, OP_RECUR_IF_A_A_opLA_LAq); + if ((is_symbol(c_op)) && + ((is_slot(global_slot(c_op))) && + ((is_global(c_op)) || + (s7_t_slot(sc, c_op) == global_slot(c_op))))) + { + const s7_pointer s_func = global_value(c_op); + const s7_pointer 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, rec_test_clause(code))) + { + const 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, rec_done_clause(code)))) + { + sc->rec_a1_o = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(call1))) + { + sc->rec_a2_o = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(call2))) + { + sc->rec_bool = a_is_cadr(code); + 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); /* call1/call2 above are more complicated than (- n 1) or the like */ + sc->rec_fb1 = q_call(sc->rec_test_o).fb; + sc->rec_fi1 = q_call(sc->rec_result_o).fi; + sc->rec_fi2 = q_call(sc->rec_a1_o).fi; + sc->rec_fi3 = q_call(sc->rec_a2_o).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, rec_done_clause(code))) + { + sc->rec_a1_o = sc->opts[sc->pc]; + if (float_optimize(sc, cdr(call1))) + { + sc->rec_a2_o = sc->opts[sc->pc]; + if (float_optimize(sc, cdr(call2))) + { + sc->rec_bool = a_is_cadr(code); + sc->rec_val1 = make_mutable_real(sc, real(slot_value(slot))); + slot_set_value(slot, sc->rec_val1); + return(opt_dbl); + }}}}}}}} + tick_tc(sc, OP_RECUR_IF_A_A_opLA_LAq); + sc->rec_bool = a_is_cadr(code); + sc->rec_fn = fn_proc(caller); + rec_set_test(sc, rec_test_clause(code)); + rec_set_res(sc, rec_done_clause(code)); + rec_set_f1(sc, cdr(call1)); + rec_set_f2(sc, cdr(call2)); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_loc = 0; + return(opt_ptr); +} + +static s7_int oprec_i_if_a_a_opla_laq(s7_scheme *sc) +{ + s7_int i1, i2; + if (q_call(sc->rec_test_o).fb(sc->rec_test_o)) /* if_(A) */ + return(q_call(sc->rec_result_o).fi(sc->rec_result_o)); /* if_a_(A) */ + i1 = q_call(sc->rec_a1_o).fi(sc->rec_a1_o); /* save a1 */ + set_integer(sc->rec_val1, q_call(sc->rec_a2_o).fi(sc->rec_a2_o));/* slot1 = a2 */ + i2 = oprec_i_if_a_a_opla_laq(sc); /* save la2 */ + set_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) */ } -/* -------------------------------- cond -------------------------------- */ -static void -check_cond (s7_scheme* sc) { - bool has_feed_to= false, result_fx= true, result_single= true; - s7_pointer clauses; - const s7_pointer code= cdr (sc->code), form= sc->code; - - if (!is_pair (code)) /* (cond) or (cond . 1) */ - syntax_error_nr (sc, "cond, but no body: ~A", 21, form); - - for (clauses= code; is_pair (clauses); clauses= cdr (clauses)) - if (!is_pair (car (clauses))) /* (cond 1) or (cond (#t 1) 3) */ - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_3 ( - sc, - wrap_string (sc, "every clause in cond must be a pair: ~S in ~A", - 45), - car (clauses), object_to_string_truncated (sc, form))); - else { - const s7_pointer clause= car (clauses); - if (!s7_is_proper_list (sc, cdr (clause))) /* (cond (xxx . 1)) */ - error_nr (sc, sc->syntax_error_symbol, - set_elist_3 (sc, wrap_string (sc, "stray dot? ~S in ~A", 19), - clause, object_to_string_truncated (sc, form))); - if (is_pair (cdr (clause))) { - if (is_pair (cddr (clause))) result_single= false; - if (is_undefined_feed_to (sc, cadr (clause))) { - has_feed_to= true; - if (!is_pair ( - cddr (clause))) /* (cond (#t =>)) or (cond (#t => . 1)) */ - error_nr (sc, sc->syntax_error_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, "cond: '=>' target missing? ~S in ~A", 36), - clauses, object_to_string_truncated (sc, form))); - if (is_pair (cdddr (clause))) /* (cond (1 => + abs)) */ - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, "cond: '=>' has too many targets: ~S in ~A", 41), - clauses, object_to_string_truncated (sc, form))); - } - } - else result_single= false; - } - if (is_not_null (clauses)) /* (cond ((1 2)) . 1) */ - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_2 (sc, wrap_string (sc, "cond: stray dot? ~S", 19), form)); - - for (clauses= code; is_pair (clauses); clauses= cdr (clauses)) { - s7_pointer clause= car (clauses); - /* clear_has_fx(clause); */ /* a kludge -- if has_fx here (and not re-fx'd - below), someone messed up earlier -- but was - fx_treeable set? */ - if (is_fxable (sc, car (clause))) fx_annotate_arg (sc, clause, sc->curlet); - for (clause= cdr (clause); is_pair (clause); clause= cdr (clause)) - if (!has_fx (clause)) { - s7_function func= - fx_choose (sc, clause, sc->curlet, let_symbol_is_safe); - if (func) set_fx_direct (clause, func); - else result_fx= false; - } - } - if ((is_fx_treeable (code)) && (curlet_has_slots (sc))) - fx_curlet_tree (sc, code); - - if (has_feed_to) { - pair_set_syntax_op (form, OP_COND_UNCHECKED); - if (is_null (cdr (code))) { - const s7_pointer arg2= caddar (code); - if ((is_proper_list_3 (sc, arg2)) && (car (arg2) == sc->lambda_symbol)) { - const s7_pointer arg= cadr (arg2); - if ((is_pair (arg)) && (is_null (cdr (arg))) && - (is_symbol (car (arg)))) /* (define (hi) (cond (#t => (lambda (s) - s)))) looking at (s) */ - { - set_opt2_lambda (code, arg2); /* (lambda ...) above */ - pair_set_syntax_op (form, OP_COND_FEED); - } - } - } - } - else { - s7_pointer clause; - bool xopt= true; - int32_t i; - pair_set_syntax_op (form, OP_COND_SIMPLE); - for (i= 0, clause= code; xopt && (is_pair (clause)); - i++, clause = cdr (clause)) - xopt= ((has_fx (car (clause))) && (is_pair (cdar (clause)))); - if (xopt) { - pair_set_syntax_op ( - form, (result_fx) - ? OP_COND_NA_NA - : ((result_single) ? OP_COND_NA_NP_O : OP_COND_NA_NP)); - if (result_single) { - if (i == 2) { - s7_pointer p= caadr (code); - if ((p == sc->T) || - ((p == sc->else_symbol) && (is_global (sc->else_symbol)))) - pair_set_syntax_op (form, OP_COND_NA_2E); - } - else if (i == 3) { - s7_pointer p= caaddr (code); - if ((p == sc->T) || - ((p == sc->else_symbol) && (is_global (sc->else_symbol)))) - pair_set_syntax_op (form, OP_COND_NA_3E); - } - } +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); + set_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); + set_integer(sc->rec_val1, sc->rec_fi3(sc->rec_a2_o)); + i3 = oprec_i_if_a_a_opla_laq_0(sc); + set_integer(sc->rec_val1, i2); + i2 = sc->rec_i_ii_f(oprec_i_if_a_a_opla_laq_0(sc), i3); } - else if (result_single) pair_set_syntax_op (form, OP_COND_SIMPLE_O); - } - set_opt3_any (code, caar (code)); + set_integer(sc->rec_val1, i1); + return(sc->rec_i_ii_f(oprec_i_if_a_a_opla_laq_0(sc), i2)); } -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 s7_double oprec_d_if_a_a_opla_laq(s7_scheme *sc) +{ + s7_double x1, x2; + if (q_call(sc->rec_test_o).fb(sc->rec_test_o)) return(q_call(sc->rec_result_o).fd(sc->rec_result_o)); + x1 = q_call(sc->rec_a1_o).fd(sc->rec_a1_o); + set_real(sc->rec_val1, q_call(sc->rec_a2_o).fd(sc->rec_a2_o)); + if (q_call(sc->rec_test_o).fb(sc->rec_test_o)) + x2 = q_call(sc->rec_result_o).fd(sc->rec_result_o); + else + { + s7_double x3; + x2 = q_call(sc->rec_a1_o).fd(sc->rec_a1_o); + set_real(sc->rec_val1, q_call(sc->rec_a2_o).fd(sc->rec_a2_o)); + x3 = oprec_d_if_a_a_opla_laq(sc); + set_real(sc->rec_val1, x2); + x2 = sc->rec_d_dd_f(oprec_d_if_a_a_opla_laq(sc), x3); + } + set_real(sc->rec_val1, x1); + return(sc->rec_d_dd_f(oprec_d_if_a_a_opla_laq(sc), x2)); } -static bool -op_cond_simple (s7_scheme* sc) /* no => */ +static s7_pointer oprec_if_a_a_opla_laq(s7_scheme *sc) { - 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); + 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 bool -op_cond_simple_o (s7_scheme* sc) /* no =>, no null or multiform consequent */ +static s7_int oprec_i_if_a_opla_laq_a(s7_scheme *sc) { - 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); - } - if ((S7_DEBUGGING) && (is_multiple_value (sc->value))) - fprintf (stderr, "cond1 mv case %s\n", display (sc->value)); - pop_stack (sc); - return (true); - } - sc->code= cdr (sc->code); /* go to next clause */ - 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); - sc->code = caar (sc->code); - sc->cur_op= optimize_op (sc->code); - return (true); - } - } - if (S7_DEBUGGING) - fprintf (stderr, "%s[%d]: we should not be here\n", __func__, __LINE__); - 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 ((S7_DEBUGGING) && (is_multiple_value (sc->value))) - fprintf (stderr, "cond1_simple mv case %s\n", display (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); - } - } + s7_int i1, i2; + if (!(q_call(sc->rec_test_o).fb(sc->rec_test_o))) return(q_call(sc->rec_result_o).fi(sc->rec_result_o)); + i1 = q_call(sc->rec_a1_o).fi(sc->rec_a1_o); + set_integer(sc->rec_val1, q_call(sc->rec_a2_o).fi(sc->rec_a2_o)); + i2 = oprec_i_if_a_opla_laq_a(sc); + set_integer(sc->rec_val1, i1); + return(sc->rec_i_ii_f(oprec_i_if_a_opla_laq_a(sc), i2)); } -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 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); + set_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); + set_integer(sc->rec_val1, sc->rec_fi3(sc->rec_a2_o)); + i3 = oprec_i_if_a_opla_laq_a_0(sc); + set_integer(sc->rec_val1, i2); + i2 = sc->rec_i_ii_f(oprec_i_if_a_opla_laq_a_0(sc), i3); } - } + set_integer(sc->rec_val1, i1); + return(sc->rec_i_ii_f(oprec_i_if_a_opla_laq_a_0(sc), i2)); } -static bool -op_cond_na_np (s7_scheme* sc) /* all tests are fxable, results may be a mixture, - no =>, no missing results */ +static s7_double oprec_d_if_a_opla_laq_a(s7_scheme *sc) { - for (s7_pointer p= cdr (sc->code); is_pair (p); p= cdr (p)) - if (is_true (sc, fx_call (sc, car (p)))) { - for (s7_pointer p1= T_Lst (cdar (p)); is_pair (p1); p1= cdr (p1)) - if (has_fx (T_Pair (p1))) sc->value= fx_call (sc, p1); - else { - if (is_pair (cdr (p1))) - push_stack_no_args (sc, OP_COND_NA_NP_1, cdr (p1)); - sc->code= car (p1); - return (false); - } - return (true); - } - sc->value= sc->unspecified; - return (true); + s7_double x1, x2; + if (!(q_call(sc->rec_test_o).fb(sc->rec_test_o))) return(q_call(sc->rec_result_o).fd(sc->rec_result_o)); + x1 = q_call(sc->rec_a1_o).fd(sc->rec_a1_o); + set_real(sc->rec_val1, q_call(sc->rec_a2_o).fd(sc->rec_a2_o)); + x2 = oprec_d_if_a_opla_laq_a(sc); + set_real(sc->rec_val1, x1); + return(sc->rec_d_dd_f(oprec_d_if_a_opla_laq_a(sc), x2)); } -static bool -op_cond_na_np_1 (s7_scheme* sc) /* continuing to handle a multi-statement result - from cond_na_np */ +static s7_pointer oprec_if_a_opla_laq_a(s7_scheme *sc) { - for (s7_pointer 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_NA_NP_1, cdr (p)); - sc->code= car (p); - return (false); - } - return (true); + 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 Inline bool -inline_op_cond_na_np_o ( - s7_scheme* sc) /* all tests are fxable, results may be a mixture, no =>, no - missing results, all result one expr */ -{ /* called once in eval, b case cb lg rclo str */ - for (s7_pointer args= cdr (sc->code); is_pair (args); args= cdr (args)) - if (is_true (sc, fx_call (sc, car (args)))) { - s7_pointer p1= cdar (args); - if (has_fx (T_Pair (p1))) { - sc->value= fx_call (sc, p1); - return (true); - } - sc->code= car (p1); - return (false); +static s7_pointer op_recur_if_a_a_opla_laq(s7_scheme *sc, s7_pointer code) +{ + const opt_pid_t choice = opinit_if_a_a_opla_laq(sc, code); + const bool a_op = true_is_done(code); + tick_tc(sc, OP_RECUR_IF_A_A_opLA_LAq); + if ((choice == opt_int) || (choice == opt_int_0)) + { + if (choice == opt_int_0) + return(make_integer(sc, (a_op) ? oprec_i_if_a_a_opla_laq_0(sc) : oprec_i_if_a_opla_laq_a_0(sc))); + return(make_integer(sc, (a_op) ? oprec_i_if_a_a_opla_laq(sc) : oprec_i_if_a_opla_laq_a(sc))); } - sc->value= sc->unspecified; - return (true); + if (choice == opt_ptr) + return((a_op) ? oprec_if_a_a_opla_laq(sc) : oprec_if_a_opla_laq_a(sc)); + return(make_real(sc, (a_op) ? oprec_d_if_a_a_opla_laq(sc) : oprec_d_if_a_opla_laq_a(sc))); } -static inline bool -fx_cond_value (s7_scheme* sc, s7_pointer args) { - if (has_fx (args)) { - sc->value= fx_call (sc, args); - return (true); - } - sc->code= car (args); - return (false); -} -static bool -op_cond_na_2e (s7_scheme* sc) { - s7_pointer args= cdr (sc->code); - return (fx_cond_value (sc, (is_true (sc, fx_call (sc, car (args)))) - ? cdar (args) - : cdadr (args))); -} +/* -------- if_a_a_opl2a_l2aq -------- */ -static bool -op_cond_na_3e (s7_scheme* sc) { - s7_pointer args= cdr (sc->code); - if (is_true (sc, fx_call (sc, car (args)))) - return (fx_cond_value (sc, cdar (args))); - args= cdr (args); - return (fx_cond_value (sc, (is_true (sc, fx_call (sc, car (args)))) - ? cdar (args) - : cdadr (args))); +static void opinit_if_a_a_opl2a_l2aq(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer caller = rec_call_clause(code); /* cdddr(code) */ + const s7_pointer call1 = cadr(caller); + const s7_pointer call2 = caddr(caller); + tick_tc(sc, OP_RECUR_IF_A_A_opL2A_L2Aq); + sc->rec_fn = fn_proc(caller); + rec_set_test(sc, rec_test_clause(code)); /* cdr(code) */ + rec_set_res(sc, rec_done_clause(code)); /* cddr(code) or cdddr(code) */ + sc->rec_bool = true_is_done(code); + rec_set_f1(sc, cdr(call1)); + rec_set_f2(sc, cddr(call1)); + rec_set_f3(sc, cdr(call2)); + rec_set_f4(sc, cddr(call2)); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_slot2 = next_slot(sc->rec_slot1); + sc->rec_loc = 0; +} + +static s7_pointer oprec_if_a_a_opl2a_l2aq(s7_scheme *sc) +{ + if ((sc->rec_testf(sc, sc->rec_testp) != sc->F) == sc->rec_bool) 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_slot2, sc->rec_f4f(sc, sc->rec_f4p)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + sc->value = oprec_if_a_a_opl2a_l2aq(sc); + 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_if_a_a_opl2a_l2aq(sc)); + set_car(sc->t2_2, recur_pop(sc)); + return(sc->rec_fn(sc, sc->t2_1)); +} + +static s7_pointer op_recur_if_a_a_opl2a_l2aq(s7_scheme *sc, s7_pointer code) +{ + opinit_if_a_a_opl2a_l2aq(sc, code); + return(oprec_if_a_a_opl2a_l2aq(sc)); } -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); + +/* -------- if_a_a_opl3a_l3aq -------- */ + +static void opinit_if_a_a_opl3a_l3aq(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer caller = rec_call_clause(code); /* rec call */ + const s7_pointer call1 = cadr(caller); + const s7_pointer call2 = caddr(caller); + tick_tc(sc, OP_RECUR_IF_A_A_opL3A_L3Aq); + sc->rec_fn = fn_proc(caller); + rec_set_test(sc, rec_test_clause(code)); /* cdr(code) */ + rec_set_res(sc, rec_done_clause(code)); /* cddr(code) or cdddr(code) */ + sc->rec_bool = true_is_done(code); + rec_set_f1(sc, cdr(call1)); + rec_set_f2(sc, cddr(call1)); + rec_set_f3(sc, cdddr(call1)); + rec_set_f4(sc, cdr(call2)); + rec_set_f5(sc, cddr(call2)); + rec_set_f6(sc, cdddr(call2)); + 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_loc = 0; +} + +static s7_pointer oprec_if_a_a_opl3a_l3aq(s7_scheme *sc) +{ + if ((sc->rec_testf(sc, sc->rec_testp) != sc->F) == sc->rec_bool) 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)); + slot_set_value(sc->rec_slot3, sc->rec_f6f(sc, sc->rec_f6p)); + slot_set_value(sc->rec_slot2, recur_pop(sc)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + sc->value = oprec_if_a_a_opl3a_l3aq(sc); + slot_set_value(sc->rec_slot3, recur_pop(sc)); + 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_if_a_a_opl3a_l3aq(sc)); + set_car(sc->t2_2, recur_pop(sc)); + return(sc->rec_fn(sc, sc->t2_1)); +} + +static s7_pointer op_recur_if_a_a_opl3a_l3aq(s7_scheme *sc, s7_pointer code) +{ + opinit_if_a_a_opl3a_l3aq(sc, code); + return(oprec_if_a_a_opl3a_l3aq(sc)); } -static void -op_cond_feed_1 (s7_scheme* sc) { - if ((S7_DEBUGGING) && (is_multiple_value (sc->value))) - fprintf (stderr, "%s %s unexpected mv\n", __func__, display (sc->value)); - set_curlet (sc, inline_make_let_with_slot (sc, sc->curlet, - caadr (opt2_lambda (sc->code)), - sc->value)); - sc->code= caddr (opt2_lambda (sc->code)); + +/* -------- if_a_a_if_a_a_opla_laq -------- */ +static void opinit_if_a_a_if_a_a_opla_laq(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer caller = rec_call_clause(code); + tick_tc(sc, OP_RECUR_IF_A_A_IF_A_A_opLA_LAq); + rec_set_f1(sc, rec_done_clause(code)); + rec_set_f2(sc, cdr(rec_done_clause(code))); + rec_set_test(sc, rec_test_clause(code)); + rec_set_res(sc, cdr(rec_test_clause(code))); + rec_set_f3(sc, cdadr(caller)); + rec_set_f4(sc, rec_call_clause(caller)); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_fn = fn_proc(caller); + sc->rec_loc = 0; +} + +static inline s7_pointer oprec_if_a_a_if_a_a_opla_laq(s7_scheme *sc) /* inline = 27 in trec */ +{ + 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_if_a_a_if_a_a_opla_laq(sc))); + set_car(sc->t2_1, oprec_if_a_a_if_a_a_opla_laq(sc)); + set_car(sc->t2_2, recur_pop(sc)); + return(sc->rec_fn(sc, sc->t2_1)); } -static bool -feed_to (s7_scheme* sc) { - if (is_multiple_value (sc->value)) /* (... ((values 1 2) => +)) more or less - s7test.scm 29539 */ - { - 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); /* goto APPLY */ - } - } - 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); - /* it would be nice to see T_C_FUNCTION here and call - * apply_c_function_unopt, but that requires either a switch (to continue) - * or putting this in the eval function */ - return (true); /* goto APPLY */ - } - 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); /* goto EVAL */ +static s7_pointer op_recur_if_a_a_if_a_a_opla_laq(s7_scheme *sc, s7_pointer code) +{ + opinit_if_a_a_if_a_a_opla_laq(sc, code); + return(oprec_if_a_a_if_a_a_opla_laq(sc)); } -/* -------------------------------- set! -------------------------------- */ -static void -check_set (s7_scheme* sc) { - const s7_pointer form= sc->code, code= cdr (sc->code); - s7_pointer settee, value; - if (!is_pair (code)) { - if (is_null (code)) /* (set!) */ - syntax_error_nr (sc, "set!: not enough arguments: ~A", 30, form); - syntax_error_nr (sc, "set!: stray dot? ~A", 19, form); /* (set! . 1) */ - } - settee= car (code); - if (!is_pair (cdr (code))) { - if (is_null (cdr (code))) /* (set! var) */ - syntax_error_nr (sc, "set!: not enough arguments: ~A", 30, form); - syntax_error_nr (sc, "set!: stray dot? ~A", 19, form); /* (set! var . 1) */ - } - value= cadr (code); /* the value has not yet been evaluated */ - - if ((is_not_null (cddr (code))) || /* (set! var 1 2) */ - ((is_pair (value)) && - (car (value) == - sc->values_symbol) && /* (set! var (values...) but 0 or 1 arg is ok */ - (is_pair ( - cdr (value))) && /* this can be fooled if we rename values, etc */ - (is_pair (cddr (value))))) - syntax_error_nr (sc, "~A: too many arguments to set!", 30, form); - - if (is_pair (settee)) { - if ((is_pair (car (settee))) && - (!is_list (cdr (settee)))) /* (set! ('(1 2) . 0) 1) */ - syntax_error_nr (sc, "improper list of arguments to set!: ~A", 38, form); - if (!s7_is_proper_list ( - sc, settee)) /* (set! ("hi" . 1) #\a) or (set! (#(1 2) . 1) 0) */ - syntax_error_nr (sc, "set! target is an improper list: (set! ~A ...)", 46, - settee); - } - else if (!is_symbol (settee)) /* (set! 12345 1) */ - error_nr ( - sc, sc->syntax_error_symbol, /* (set! #_abs 32) -> "error: set! can't - change #_abs (a c-function)" */ - (is_c_function (settee)) - ? set_elist_2 ( - sc, - wrap_string (sc, "set! can't change ~S (a c-function)", 35), - settee) - : set_elist_4 ( - sc, wrap_string (sc, "set! can't change ~S (~A), ~S", 29), - settee, sc->type_names[type (settee)], form)); - - else if (is_keyword (settee)) /* (set! :hi 3) */ - error_nr (sc, sc->syntax_error_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, "set!: can't change keyword's value: ~S in ~S", 44), - settee, form)); - - if (is_pair (settee)) /* here we have (set! (...) ...) */ - { - pair_set_syntax_op ( - form, OP_SET_UNCHECKED); /* if not pair car, op_set_normal below */ - if (is_symbol (car (settee))) { - if (is_null (cdr (settee))) /* (set! (symbol) ...) */ - { - if (is_fxable (sc, value)) { - pair_set_syntax_op (form, OP_SET_opSq_A); /* (set! (symbol) fxable) */ - fx_annotate_arg (sc, cdr (code), sc->curlet); /* cdr(code) = value */ - } - } - else if (is_null (cddr ( - settee))) /* we check cddr(code) above */ /* this leaves - (set! (vect i j) - 1) unhandled so - we go to - OP_SET_UNCHECKED - */ - { - const s7_pointer index= cadr (settee); - if (is_fxable (sc, index)) { - if ((car (settee) == sc->let_ref_symbol) && - (!is_pair ( - cddr (settee)))) /* perhaps also check for hash-table-ref */ - /* (let () (define (func) (catch #t (lambda () (set! (let-ref (list - * 1)) 1)) (lambda args 'error))) (func) (func)) */ - error_nr ( - sc, sc->wrong_number_of_args_symbol, - set_elist_2 ( - sc, - wrap_string ( - sc, "set!: not enough arguments for let-ref: ~S", 42), - sc->code)); - fx_annotate_arg (sc, cdr (settee), - sc->curlet); /* cdr(settee) -> index */ - if (is_fxable (sc, value)) { - pair_set_syntax_op ( - form, OP_SET_opSAq_A); /* (set! (symbol fxable) fxable) */ - /* perhaps: if "S" is a known function (etc), split this -- the - * runtime check for a macro here is very expensive fprintf(stderr, - * "(set! %s %s)\n", display(settee), display(value)); - * S=vector[tnum]/hash-table/c_func/s7/setter[tset]/var-*[lt]/c-obj[tobj]/dilambda[tstar] - * so, if not any_macro OP_SET_opFAq_A else OP_SET_opMAq_A? or just - * the latter also (set! (car a) b) -> (set-car! a b), (set! (cfunc - * a) b) -> ((setter cfunc) a b) set_opsaq_a as "unknown" equivalent - * -> all the special cases which check just their case, maybe a - * no-parcel option - */ - fx_annotate_arg (sc, cdr (code), - sc->curlet); /* cdr(code) -> value */ - - if (car (settee) == - sc->starlet_symbol) /* (set! (*s7* 'field) value) */ - { - s7_pointer sym= - (is_symbol (index)) - ? ((is_keyword (index)) ? keyword_symbol (index) : index) - : ((is_quoted_symbol (sc, index)) ? cadr (index) : index); - if ((is_symbol (sym)) && - (starlet_symbol_id (sym) != sl_no_field)) { - /* perhaps preset field -> - * op_print_length_set[misc?]|safety[tstar] etc */ - set_safe_optimize_op (form, OP_IMPLICIT_STARLET_SET_S); - set_opt3_sym (form, sym); - } - } - } - else - pair_set_syntax_op ( - form, OP_SET_opSAq_P); /* (set! (symbol fxable) any) */ - } - } - else if ((is_null (cdddr (settee))) && - (car (settee) != - sc->with_let_symbol)) /* (set! (with-let lt a) 32) needs to be - handled by op_set_with_let_1 */ - { - const s7_pointer index1= cadr (settee), index2= caddr (settee); - if ((is_fxable (sc, index1)) && (is_fxable (sc, index2))) { - fx_annotate_args (sc, cdr (settee), - sc->curlet); /* cdr(settee) -> index1 and 2 */ - if (is_fxable (sc, value)) { - pair_set_syntax_op ( - form, - OP_SET_opSAAq_A); /* (set! (symbol fxable fxable) fxable) */ - fx_annotate_arg (sc, cdr (code), - sc->curlet); /* cdr(code) -> value */ - } - else - pair_set_syntax_op ( - form, OP_SET_opSAAq_P); /* (set! (symbol fxable fxable) any) */ - } - } - } - return; - } - pair_set_syntax_op (form, OP_SET_NORMAL); - if (is_symbol (settee)) { - const s7_pointer slot= s7_slot (sc, settee); - if ((is_slot (slot)) && (!slot_has_setter (slot)) && - (!is_immutable (slot)) && (!is_syntactic_symbol (settee)) && - (!s7_tree_memq (sc, sc->setter_symbol, - value))) /* (set! x (set! (setter 'x) ...) ...)! */ - { - if (is_normal_symbol (value)) { - const s7_pointer slot1= s7_slot (sc, value); - if ((is_slot (slot1)) && (!slot_has_setter (slot1))) { - pair_set_syntax_op (form, OP_SET_S_S); - set_opt2_sym (code, value); - } - } - else if ((!is_pair (value)) || - ((is_quote (sc, car (value))) && - (is_pair (cdr (value))))) /* (quote . 1) ? */ - { - pair_set_syntax_op (form, OP_SET_S_C); - set_opt1_con ( - code, (is_pair (value)) - ? cadr (value) - : value); /* collision if ((values set!) x 32) code: (x - 32) value: 32, opt2: fx_s, opt1|3 is free */ - } - else { - const s7_pointer cddr_value= - (is_pair (cdr (value))) ? cddr (value) : NULL; - pair_set_syntax_op (form, OP_SET_S_P); - if (is_optimized (value)) { - if (optimize_op (value) == HOP_SAFE_C_SS) { - if (settee == cadr (value)) { - pair_set_syntax_op (form, OP_INCREMENT_SS); - /* fx_annotate_arg(sc, cddr_value, sc->curlet); */ /* this sets - fx_proc(cddr_value) - */ - set_opt2_pair (code, cddr_value); - } - else { - pair_set_syntax_op (form, OP_SET_S_A); - fx_annotate_arg (sc, cdr (code), sc->curlet); - } - } - else { - if (is_fxable (sc, value)) { - pair_set_syntax_op (form, OP_SET_S_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))) { /* a=symbol case does happen here */ - pair_set_syntax_op (form, (is_symbol (caddr (value))) - ? OP_INCREMENT_SS - : OP_INCREMENT_SA); - fx_annotate_arg ( - sc, cddr_value, - sc->curlet); /* this sets fx_proc(arg) -- usually set much - earlier in optimize_lambda? */ - - /* an experiment */ - if ((has_fx (cddr_value)) && - (fx_proc (cddr_value) == fx_multiply_sa)) - set_fx_direct (cddr_value, fx_multiply_sa_wrapped); - - set_opt2_pair (code, cddr_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_args (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_safe_c_op ( - optimize_op (value))) && /* else might not be opt1_cfunc? - (opt1_lambda probably) */ - (!is_unsafe (value)) && /* is_unsafe(value) can happen! */ - (!is_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 (sc, cadr (value))) && - (car (value) == sc->cons_symbol)) { - pair_set_syntax_op (form, OP_SET_CONS); - set_opt2_sym (code, cadr (value)); - } - } - } - } - } - } +/* -------- if_a_a_if_a_a_opl2a_l2aq -------- */ +static void opinit_if_a_a_if_a_a_opl2a_l2aq(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer caller = rec_call_clause(code); + s7_pointer p; + tick_tc(sc, OP_RECUR_IF_A_A_IF_A_A_opL2A_L2Aq); + rec_set_f1(sc, rec_done_clause(code)); + rec_set_f2(sc, cdr(rec_done_clause(code))); + rec_set_test(sc, rec_test_clause(code)); + rec_set_res(sc, cdr(rec_test_clause(code))); + p = cdadr(caller); + rec_set_f3(sc, p); + rec_set_f4(sc, cdr(p)); + p = rec_call_clause(caller); + rec_set_f5(sc, p); + rec_set_f6(sc, cdr(p)); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_slot2 = next_slot(sc->rec_slot1); + sc->rec_fn = fn_proc(caller); + sc->rec_loc = 0; +} + +static s7_pointer oprec_if_a_a_if_a_a_opl2a_l2aq(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_if_a_a_if_a_a_opl2a_l2aq(sc); /* second l2a 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_if_a_a_if_a_a_opl2a_l2aq(sc)); /* first l2a arg */ + set_car(sc->t2_2, recur_pop(sc)); + return(sc->rec_fn(sc, sc->t2_1)); +} + +static s7_pointer op_recur_if_a_a_if_a_a_opl2a_l2aq(s7_scheme *sc, s7_pointer code) +{ + opinit_if_a_a_if_a_a_opl2a_l2aq(sc, code); + return(oprec_if_a_a_if_a_a_opl2a_l2aq(sc)); } -static void -op_set_s_c (s7_scheme* sc) { - s7_pointer slot= T_Slt (s7_t_slot (sc, cadr (sc->code))); - if (is_immutable (slot)) - immutable_object_error_nr ( - sc, set_elist_3 (sc, wrap_string (sc, "~S, but ~S is immutable", 23), - sc->code, cadr (sc->code))); - slot_set_value (slot, sc->value= opt1_con (cdr (sc->code))); -} - -static inline void -op_set_s_s (s7_scheme* sc) { - s7_pointer slot= T_Slt (s7_t_slot (sc, cadr (sc->code))); - if (is_immutable (slot)) - immutable_object_error_nr ( - sc, set_elist_3 (sc, wrap_string (sc, "~S, but ~S is immutable", 23), - sc->code, cadr (sc->code))); - slot_set_value (slot, sc->value= lookup (sc, opt2_sym (cdr (sc->code)))); -} - -static Inline void -op_set_s_a (s7_scheme* sc) { - s7_pointer slot= T_Slt (s7_t_slot (sc, cadr (sc->code))); - if (is_immutable (slot)) - immutable_object_error_nr ( - sc, set_elist_3 (sc, wrap_string (sc, "~S, but ~S is immutable", 23), - sc->code, cadr (sc->code))); - slot_set_value (slot, sc->value= fx_call (sc, cddr (sc->code))); -} - -static void -op_set_s_p (s7_scheme* sc) { - check_stack_size (sc); - push_stack_no_args ( - sc, OP_SET_SAFE, - cadr (sc->code)); /* only path to op_set_safe, but we're not safe! - cadr(sc->code) might be immutable */ - sc->code= caddr (sc->code); -} - -static void -op_set_safe (s7_scheme* sc) /* name is misleading -- we need to check for - immutable slot, but no setter */ -{ - s7_pointer slot= s7_t_slot (sc, sc->code); - if (is_slot (slot)) { - if (is_immutable_slot (slot)) - immutable_object_error_nr (sc, set_elist_3 (sc, immutable_error_string, - sc->set_symbol, sc->code)); - slot_set_value (slot, sc->value); - } - else if ((is_let (sc->curlet)) && (has_let_set_fallback (sc->curlet))) - sc->value= call_let_set_fallback (sc, sc->curlet, sc->code, sc->value); - else unbound_variable_error_nr (sc, sc->code); -} - -static void -op_set_from_let_temp (s7_scheme* sc) { - s7_pointer settee= sc->code; - s7_pointer slot = s7_t_slot (sc, settee); - if (!is_slot (slot)) unbound_variable_error_nr (sc, settee); - if (is_immutable_slot (slot)) - immutable_object_error_nr ( - sc, set_elist_2 ( - sc, - wrap_string ( - sc, "let-temporarily can't reset ~S: it is immutable!", 48), - settee)); - slot_set_value (slot, (slot_has_setter (slot)) - ? call_setter (sc, slot, sc->value) - : sc->value); -} - -static inline void -op_set_cons (s7_scheme* sc) { - s7_pointer slot= s7_t_slot (sc, cadr (sc->code)); - 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_saa (s7_scheme* sc) { - s7_pointer slot, arg, val; - sc->code= cdr (sc->code); - slot = s7_t_slot (sc, car (sc->code)); - 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 = s7_t_slot (sc, car (sc->code)); - arg = opt2_pair (sc->code); /* cddr(value) */ - 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 void -op_increment_ss (s7_scheme* sc) { - s7_pointer slot, arg; - sc->code= cdr (sc->code); - slot = s7_t_slot (sc, car (sc->code)); - arg = opt2_pair (sc->code); /* cddr(value) */ - set_car (sc->t2_2, lookup (sc, car (arg))); - set_car (sc->t2_1, slot_value (slot)); - slot_set_value (slot, sc->value= fn_proc (cadr (sc->code)) (sc, sc->t2_1)); +/* -------- if_a_a_if_a_a_opl3a_l3aq -------- */ +static void opinit_if_a_a_if_a_a_opl3a_l3aq(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer caller = rec_call_clause(code); + s7_pointer p; + rec_set_f1(sc, rec_done_clause(code)); + rec_set_f2(sc, cdr(rec_done_clause(code))); + rec_set_test(sc, rec_test_clause(code)); + rec_set_res(sc, cdr(rec_test_clause(code))); + tick_tc(sc, OP_RECUR_IF_A_A_IF_A_A_opL3A_L3Aq); + + p = cdadr(caller); + rec_set_f3(sc, p); + rec_set_f4(sc, cdr(p)); + rec_set_f5(sc, cddr(p)); + p = rec_call_clause(caller); + rec_set_f6(sc, p); + rec_set_f7(sc, cdr(p)); + rec_set_f8(sc, cddr(p)); + 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); + sc->rec_loc = 0; +} + +static s7_pointer oprec_if_a_a_if_a_a_opl3a_l3aq(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)); + recur_push(sc, sc->rec_f6f(sc, sc->rec_f6p)); + recur_push(sc, sc->rec_f7f(sc, sc->rec_f7p)); + slot_set_value(sc->rec_slot3, sc->rec_f8f(sc, sc->rec_f8p)); + slot_set_value(sc->rec_slot2, recur_pop(sc)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + sc->value = oprec_if_a_a_if_a_a_opl3a_l3aq(sc); /* second l3a */ + slot_set_value(sc->rec_slot3, recur_pop(sc)); + 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_if_a_a_if_a_a_opl3a_l3aq(sc)); /* first l3a */ + set_car(sc->t2_2, recur_pop(sc)); + return(sc->rec_fn(sc, sc->t2_1)); +} + +static s7_pointer op_recur_if_a_a_if_a_a_opl3a_l3aq(s7_scheme *sc, s7_pointer code) +{ + opinit_if_a_a_if_a_a_opl3a_l3aq(sc, code); + return(oprec_if_a_a_if_a_a_opl3a_l3aq(sc)); } -static no_return void -no_setter_error_nr (s7_scheme* sc, s7_pointer obj) { - /* sc->code here is form without set!: ((abs 1) 2) from (set! (abs 1) 2) - * but in implicit case, (let ((L (list 0))) (set! (L 0 0) 2)), code is ((0 - * 0) 2) at entry to s7_error: ((0 0 2)?? but we print something from - * define-hook-function if in the repl add indices and new-value args, is - * unevaluated code always available? - */ - const int32_t typ= type (obj); - if (!is_pair (car (sc->code))) sc->code= cdr (sc->code); - - if (is_any_c_function (caar (sc->code))) - error_nr ( - sc, sc->no_setter_symbol, - set_elist_6 ( - sc, - wrap_string ( - sc, "~W (~A) does not have a setter: (set! (~W~{~^ ~S~}) ~S)", - 55), - caar (sc->code), sc->type_names[typ], caar (sc->code), - cdar (sc->code), cadr (sc->code))); - error_nr ( - sc, sc->no_setter_symbol, - set_elist_5 ( - sc, - wrap_string (sc, "~A (~A) does not have a setter: (set! ~S ~S)", 44), - caar (sc->code), sc->type_names[typ], - (is_pair (car (sc->code))) ? copy_any_list (sc, car (sc->code)) - : car (sc->code), - (is_pair (cadr (sc->code))) - ? sc->z= copy_any_list (sc, cadr (sc->code)) - : cadr (sc->code))); - /* copy is necessary due to the way quoted lists|symbols are handled in - * op_set_with_let_1|2 and copy_tree copy_proper_list can fail: (let ((x #f)) - * (map set! `((set! x (+ x 1)) (* x 2)) (hash-table 'a 1))) + +/* -------- if_a_a_opa_laq and if_a_opa_laq_a -------- */ +static opt_pid_t opinit_if_a_a_opa_laq(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer caller = rec_call_clause(code); + const bool la_op = a_is_cadr(caller); + const s7_pointer c_op = car(caller); + if ((is_symbol(c_op)) && + ((is_slot(global_slot(c_op))) && + ((is_global(c_op)) || + (s7_t_slot(sc, c_op) == global_slot(c_op))))) + { + const 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, rec_test_clause(code))) /* (zero? x) */ + { + const 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, rec_done_clause(code)))) /* x as return */ + { + sc->rec_a1_o = sc->opts[sc->pc]; + if (int_optimize(sc, (la_op) ? cdr(caller) : cddr(caller))) /* x in (+ x ...) */ + { + sc->rec_a2_o = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(rec_call_clause(caller)))) /* arg of recur call: (- x 1) */ + { + sc->rec_val1 = make_mutable_integer(sc, integer(slot_value(slot))); + slot_set_value(slot, sc->rec_val1); + return(opt_int); + }}}}}}} + /* not int: a_op: (lis (cons (car lis) (copy-list-1 (cdr lis)))), + * la_op: ((car lis) (copy-list-1 (cdr lis))), + * opt3: ((cdr lis)) + * (if (not (pair? lis)) lis (cons (car lis) (copy-list (cdr lis)))) + * + * not int: a_op: (1 (lcm n (flcm (- n 1)))), + * la_op: (n (flcm (- n 1))), + * opt3: ((- n 1)) + * (if (<= n 1) 1 (lcm n (flcm (- n 1)))) 1 1 */ + rec_set_test(sc, rec_test_clause(code)); + rec_set_res(sc, rec_done_clause(code)); + rec_set_f1(sc, (la_op) ? cdr(caller) : cddr(caller)); /* a arg */ + rec_set_f2(sc, cdr(rec_call_clause(caller))); /* la arg */ + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_fn = fn_proc(caller); + sc->rec_loc = 0; + return(opt_ptr); } -static bool -pair3_cfunc (s7_scheme* sc, s7_pointer obj, s7_pointer setf, s7_pointer arg, - s7_pointer value) { - if (!c_function_is_aritable (setf, 2)) - error_nr ( - sc, sc->wrong_number_of_args_symbol, - set_elist_6 ( - sc, - wrap_string ( - sc, "set!: two arguments? (~A ~S ~S), ~A is (setter ~A)", 50), - setf, arg, value, setf, obj)); - if (!is_safe_procedure (setf)) sc->args= list_2 (sc, arg, value); - else sc->args= with_list_t2 (sc, arg, value); - sc->value= c_function_call (setf) (sc, sc->args); - return (false); -} - -static bool -set_pair3 (s7_scheme* sc, s7_pointer obj, s7_pointer arg, s7_pointer value) { - switch (type (obj)) { - case T_C_OBJECT: - sc->value= - (*(c_object_set (sc, obj))) (sc, with_list_t3 (sc, obj, arg, value)); - break; - - case T_FLOAT_VECTOR: - sc->value= g_fv_set_3 (sc, with_list_t3 (sc, obj, arg, value)); - break; - case T_COMPLEX_VECTOR: /* cfft in tcomplex hits this */ - sc->value= complex_vector_set_p_ppp (sc, obj, arg, value); - break; - case T_INT_VECTOR: - sc->value= g_iv_set_3 (sc, with_list_t3 (sc, obj, arg, value)); - break; - case T_BYTE_VECTOR: - sc->value= g_bv_set_3 (sc, with_list_t3 (sc, obj, arg, value)); - break; - case T_VECTOR: - if (vector_rank (obj) > 1) - sc->value= g_vector_set (sc, with_list_t3 (sc, obj, arg, value)); - else { - s7_int index; - if (!is_t_integer (arg)) - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_2 ( - sc, - wrap_string ( - sc, "vector-set!: index must be an integer: ~S", 41), - sc->code)); - index= integer (arg); - if (index < 0) - error_nr ( - sc, sc->out_of_range_symbol, - set_elist_2 ( - sc, - wrap_string (sc, "vector-set!: index must not be negative: ~S", - 43), - sc->code)); - if (index >= vector_length (obj)) - error_nr ( - sc, sc->out_of_range_symbol, - set_elist_2 ( - sc, - wrap_string ( - sc, - "vector-set!: index must be less than vector length: ~S", - 54), - sc->code)); - if (is_immutable_vector (obj)) - immutable_object_error_nr (sc, - set_elist_3 (sc, immutable_error_string, - sc->vector_set_symbol, obj)); - if (is_typed_vector (obj)) - value= typed_vector_setter (sc, obj, index, value); - else vector_element (obj, index)= value; - sc->value= T_Ext (value); - } - break; - - case T_STRING: { - s7_int index; - if (!is_t_integer (arg)) - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_2 (sc, wrap_string (sc, "index must be an integer: ~S", 28), - sc->code)); - index= integer (arg); - if (index < 0) - error_nr (sc, sc->out_of_range_symbol, - set_elist_2 ( - sc, wrap_string (sc, "index must not be negative: ~S", 30), - sc->code)); - if (index >= string_length (obj)) - error_nr (sc, sc->out_of_range_symbol, - set_elist_2 ( - sc, - wrap_string ( - sc, "index must be less than sequence length: ~S", 43), - sc->code)); - if (is_immutable_string (obj)) - immutable_object_error_nr (sc, set_elist_3 (sc, immutable_error_string, - sc->string_set_symbol, obj)); - if (!is_character (value)) - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_2 ( - sc, - wrap_string ( - sc, "string-set!: value must be a character: ~S", 42), - sc->code)); - string_value (obj)[index]= (char) s7_character (value); - sc->value = value; - } break; - - case T_PAIR: - sc->value= g_list_set (sc, with_list_t3 (sc, obj, arg, value)); - break; - - case T_HASH_TABLE: - if (is_immutable_hash_table (obj)) /* not checked in s7_hash_table_set */ - immutable_object_error_nr (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= let_set_2 (sc, obj, arg, value); /* this checks immutable */ - break; - - case T_C_RST_NO_REQ_FUNCTION: - 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_c_function (c_function_setter (obj))) - return (pair3_cfunc (sc, obj, c_function_setter (obj), arg, value)); - sc->code= c_function_setter (obj); /* closure/macro */ - sc->args= (needs_copied_args (sc->code)) ? list_2 (sc, arg, value) - : set_plist_2 (sc, arg, value); - return (true); /* goto APPLY; not redundant -- setter type might not match - getter type */ - - case T_C_MACRO: /* (set! (setter quasiquote) (lambda args args)) (define (f) - (set! (quasiquote 1) (setter 'i))) (f) (f) */ - if (is_c_function (c_macro_setter (obj))) - return (pair3_cfunc (sc, obj, c_macro_setter (obj), arg, value)); - sc->code= c_macro_setter (obj); - sc->args= (needs_copied_args (sc->code)) ? list_2 (sc, arg, value) - : set_plist_2 (sc, arg, value); - return (true); /* goto APPLY; */ - - case T_MACRO: - case T_MACRO_STAR: - case T_BACRO: - case T_BACRO_STAR: - case T_CLOSURE: - case T_CLOSURE_STAR: - if (is_c_function (closure_setter_or_map_list (obj))) - return (pair3_cfunc (sc, obj, closure_setter (obj), arg, value)); - sc->code= closure_setter_or_map_list (obj); - sc->args= (needs_copied_args (sc->code)) ? list_2 (sc, arg, value) - : set_plist_2 (sc, arg, value); - return (true); /* goto APPLY; */ - - default: - no_setter_error_nr (sc, obj); /* possibly a continuation/goto? */ - } - return (false); +static s7_int oprec_i_if_a_a_opa_laq(s7_scheme *sc) +{ + s7_int i1; + if (q_call(sc->rec_test_o).fb(sc->rec_test_o)) return(q_call(sc->rec_result_o).fi(sc->rec_result_o)); + i1 = q_call(sc->rec_a1_o).fi(sc->rec_a1_o); + set_integer(sc->rec_val1, q_call(sc->rec_a2_o).fi(sc->rec_a2_o)); + return(sc->rec_i_ii_f(i1, oprec_i_if_a_a_opa_laq(sc))); } -static bool -op_set_opsq_a (s7_scheme* sc) /* (set! (symbol) fxable) */ +static s7_int oprec_i_if_a_opa_laq_a(s7_scheme *sc) { - s7_pointer setf, value; - const s7_pointer code= cdr (sc->code), obj= lookup_checked (sc, caar (code)); + s7_int i1; + if (!q_call(sc->rec_test_o).fb(sc->rec_test_o)) return(q_call(sc->rec_result_o).fi(sc->rec_result_o)); + i1 = q_call(sc->rec_a1_o).fi(sc->rec_a1_o); + set_integer(sc->rec_val1, q_call(sc->rec_a2_o).fi(sc->rec_a2_o)); + return(sc->rec_i_ii_f(i1, oprec_i_if_a_opa_laq_a(sc))); +} - if ((is_sequence (obj)) && (!is_c_object (obj))) - error_nr (sc, sc->wrong_number_of_args_symbol, - set_elist_3 ( - sc, - wrap_string (sc, "set!: not enough arguments for ~S: ~S", 37), - caar (code), sc->code)); +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)); +} - setf= setter_p_pp (sc, obj, sc->curlet); - if (is_any_macro (setf)) { - sc->code= setf; - sc->args= cdr (code); - return (true); - } - value= fx_call (sc, cdr (code)); - if (is_c_function (setf)) { - if (c_function_min_args (setf) > 1) - error_nr (sc, sc->wrong_number_of_args_symbol, - set_elist_3 ( - sc, - wrap_string (sc, "set!: not enough arguments: (~A ~S)", 35), - setf, value)); - sc->value= c_function_call (setf) (sc, with_list_t1 (sc, value)); - return (false); - } - sc->code= setf; - sc->args= list_1 (sc, value); - return (true); +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 bool -op_set_opsaq_a (s7_scheme* sc) /* (set! (symbol fxable) fxable) */ +static s7_pointer oprec_if_a_opa_laq_a(s7_scheme *sc) { - s7_pointer index, value; - const s7_pointer code= cdr (sc->code), obj= lookup_checked (sc, caar (code)); - if (could_be_macro_setter (obj)) { - const s7_pointer setf= setter_p_pp (sc, obj, sc->curlet); - if (is_any_macro (setf)) { - sc->code= setf; - sc->args= pair_append (sc, cdar (code), cdr (code)); - return (true); /* goto APPLY (if false, continue) */ + 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)); } - } - value= fx_call (sc, cdr (code)); - gc_protect_via_stack (sc, value); - if (dont_eval_args (obj)) /* this check is expensive, 8 in tstar, similar lg, - but it's faster than is_any_macro */ - index= cadar (code); /* if obj is a c_macro, surely we don't want to - evaluate cdar(code)? */ - else index= fx_call (sc, cdar (code)); - set_gc_protected2 (sc, index); - return (set_pair3 (sc, obj, index, value)); - /* set_pair3 can assume goto apply as above, and can push the setter on the - * stack preparing to goto apply, but that means we can't blithely - * unstack_gc_protect. (set! (setter for-each) map) (define (func) (set! - * (for-each (make-vector '(2 3 4) 1)) (vector-append))) (func) (func) - * set_pair3 -> pair3_cfunc which returns false even if it invokes map so we - * have no way to tell whether we can unstack. - */ + set_car(sc->t2_1, recur_pop(sc)); + return(sc->rec_fn(sc, sc->t2_1)); } -static inline bool -op_set_opsaq_p (s7_scheme* sc) { - const s7_pointer code= cdr (sc->code); - /* ([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_opSAq_P_1 and - * complain. (let () (define (hi) (let ((str "123")) (set! (str 0) (values - * #\a)) str)) (hi) (hi)) is "a23" (let ((v (make-vector '(2 3) 0))) (set! (v - * (values 0 1)) 23) v) -> #2D((0 23 0) (0 0 0)) - */ - const s7_pointer obj= lookup_checked (sc, caar (code)); - if (could_be_macro_setter (obj)) { - s7_pointer setf= setter_p_pp (sc, obj, sc->curlet); - if (is_any_macro (setf)) { - sc->code= setf; - sc->args= pair_append (sc, cdar (code), cdr (code)); - return (true); /* goto APPLY */ - } - } - push_stack (sc, OP_SET_opSAq_P_1, obj, code); - sc->code= cadr (code); - return (false); /* goto EVAL */ +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 inline bool -op_set_opsaq_p_1 (s7_scheme* sc) { - s7_pointer value= sc->value; - s7_pointer index; - if (dont_eval_args (sc->args)) /* see above */ - index= cadar (sc->code); - else index= fx_call (sc, cdar (sc->code)); - return (set_pair3 ( - sc, sc->args, index, - value)); /* not lookup, (set! (_!asdf!_ 3) 'a) -> unbound_variable */ -} - -static bool -pair4_cfunc (s7_scheme* sc, s7_pointer obj, s7_pointer setf, s7_pointer index1, - s7_pointer index2, s7_pointer value) { - if (!c_function_is_aritable (setf, 3)) - error_nr ( - sc, sc->wrong_number_of_args_symbol, - set_elist_7 ( - sc, - wrap_string ( - sc, "set!: three arguments? (~A ~S ~S ~S), ~A is (setter ~A)", - 55), - setf, index1, index2, value, setf, obj)); - if (!is_safe_procedure (setf)) { - sc->code= setf; - sc->args= list_3 (sc, index1, index2, value); - return (true); - } - sc->value= - c_function_call (setf) (sc, with_list_t3 (sc, index1, index2, value)); - return (false); -} - -static bool -set_pair4 (s7_scheme* sc, s7_pointer obj, s7_pointer index1, s7_pointer index2, - s7_pointer value) { - switch (type (obj)) { - case T_C_OBJECT: - sc->value= (*(c_object_ref (sc, obj))) (sc, with_list_t2 (sc, obj, index1)); - return (set_pair3 (sc, sc->value, index2, value)); - - case T_FLOAT_VECTOR: - sc->value= - g_float_vector_set (sc, set_plist_4 (sc, obj, index1, index2, value)); - break; - case T_COMPLEX_VECTOR: - sc->value= - g_complex_vector_set (sc, set_plist_4 (sc, obj, index1, index2, value)); - break; - case T_INT_VECTOR: - sc->value= - g_int_vector_set (sc, set_plist_4 (sc, obj, index1, index2, value)); - break; - case T_BYTE_VECTOR: - sc->value= - g_byte_vector_set (sc, set_plist_4 (sc, obj, index1, index2, value)); - break; - case T_VECTOR: - if (vector_rank (obj) == 2) - sc->value= - g_vector_set_4 (sc, set_plist_4 (sc, obj, index1, index2, value)); - else { - sc->value= g_vector_ref (sc, with_list_t2 (sc, obj, index1)); - return (set_pair3 (sc, sc->value, index2, value)); - } - break; - - case T_PAIR: - sc->value= g_list_ref (sc, with_list_t2 (sc, obj, index1)); - return (set_pair3 (sc, sc->value, index2, value)); - - case T_HASH_TABLE: - sc->value= s7_hash_table_ref (sc, obj, index1); - return (set_pair3 (sc, sc->value, index2, value)); - - case T_LET: - sc->value= let_ref (sc, obj, index1); - return (set_pair3 (sc, sc->value, index2, value)); - - case T_C_RST_NO_REQ_FUNCTION: - case T_C_FUNCTION: - case T_C_FUNCTION_STAR: /* obj here is any_c_function, but its setter could be - a closure and vice versa below */ - if (is_c_function (c_function_setter (obj))) - return (pair4_cfunc (sc, obj, c_function_setter (obj), index1, index2, - value)); - sc->code= c_function_setter (obj); /* closure|macro */ - sc->args= (needs_copied_args (sc->code)) - ? list_3 (sc, index1, index2, value) - : set_plist_3 (sc, index1, index2, value); - return (true); /* goto APPLY; not redundant -- setter type might not match - getter type */ - - case T_C_MACRO: /* (set! (setter quasiquote) (lambda (a . b) a)) (let () - (define (func) (set! (quasiquote 'a 0) 3)) (func) (func)) - */ - if (is_c_function (c_macro_setter (obj))) - return ( - pair4_cfunc (sc, obj, c_macro_setter (obj), index1, index2, value)); - sc->code= c_macro_setter (obj); - sc->args= (needs_copied_args (sc->code)) - ? list_3 (sc, index1, index2, value) - : set_plist_3 (sc, index1, index2, value); - return (true); /* goto APPLY; */ - - case T_MACRO: - case T_MACRO_STAR: - case T_BACRO: - case T_BACRO_STAR: - case T_CLOSURE: - case T_CLOSURE_STAR: - if (is_c_function (closure_setter_or_map_list (obj))) - return ( - pair4_cfunc (sc, obj, closure_setter (obj), index1, index2, value)); - sc->code= closure_setter_or_map_list (obj); - sc->args= (needs_copied_args (sc->code)) - ? list_3 (sc, index1, index2, value) - : set_plist_3 (sc, index1, index2, value); - return (true); /* goto APPLY; */ - - default: - no_setter_error_nr (sc, obj); /* possibly a continuation/goto or string */ - } - return (false); /* goto start */ +static s7_pointer op_recur_if_a_a_opa_laq(s7_scheme *sc, s7_pointer code) +{ + const bool a_op = true_is_done(code); + const bool la_op = a_is_cadr(rec_call_clause(code)); + opt_pid_t choice = opinit_if_a_a_opa_laq(sc, code); + tick_tc(sc, OP_RECUR_IF_A_A_opA_LAq); + if (choice == opt_int) + return(make_integer(sc, (a_op) ? oprec_i_if_a_a_opa_laq(sc) : oprec_i_if_a_opa_laq_a(sc))); + if (a_op) + return((la_op) ? oprec_if_a_a_opa_laq(sc) : oprec_if_a_a_opla_aq(sc)); + return((la_op) ? oprec_if_a_opa_laq_a(sc) : oprec_if_a_opla_aq_a(sc)); } -static bool -op_set_opsaaq_a (s7_scheme* sc) /* (set! (symbol fxable fxable) fxable) */ + +/* -------- if_a_a_opa_l2aq -------- */ +static void opinit_if_a_a_opa_l2aq(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer caller = rec_call_clause(code); + const bool la_op = a_is_cadr(caller); + tick_tc(sc, OP_RECUR_IF_A_A_opA_L2Aq); + rec_set_test(sc, rec_test_clause(code)); + rec_set_res(sc, rec_done_clause(code)); + rec_set_f1(sc, (la_op) ? cdr(caller) : cddr(caller)); + rec_set_f2(sc, cdr(rec_call_clause(caller))); + rec_set_f3(sc, cddr(rec_call_clause(caller))); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_slot2 = next_slot(sc->rec_slot1); + sc->rec_fn = fn_proc(caller); + sc->rec_bool = true_is_done(code); + sc->rec_loc = 0; + if (la_op) {sc->rec_p1 = sc->t2_1; sc->rec_p2 = sc->t2_2;} else {sc->rec_p1 = sc->t2_2; sc->rec_p2 = sc->t2_1;} +} + +static s7_pointer oprec_if_a_a_opa_l2aq(s7_scheme *sc) { - s7_pointer index1, value; - const s7_pointer code= cdr (sc->code), obj= lookup_checked (sc, caar (code)); - if (could_be_macro_setter (obj)) { - const s7_pointer setf= setter_p_pp (sc, obj, sc->curlet); - if (is_any_macro (setf)) { - sc->code= setf; - sc->args= pair_append (sc, cdar (code), cdr (code)); - return (true); + if ((sc->rec_testf(sc, sc->rec_testp) != sc->F) == sc->rec_bool) 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) == sc->rec_bool) + set_car(sc->rec_p2, sc->rec_resf(sc, sc->rec_resp)); + else + { + recur_push_unchecked(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->rec_p2, oprec_if_a_a_opa_l2aq(sc)); + set_car(sc->rec_p1, recur_pop(sc)); + set_car(sc->rec_p2, sc->rec_fn(sc, sc->t2_1)); } - } - value= fx_call (sc, cdr (code)); - gc_protect_via_stack (sc, value); - index1= fx_call (sc, cdar (code)); - set_gc_protected2 (sc, index1); - { - bool result= set_pair4 (sc, obj, index1, fx_call (sc, cddar (code)), value); - if (!result) - unstack_gc_protect (sc); /* see comment under op_set_opsaq_a above */ - return (result); - } + set_car(sc->rec_p1, recur_pop(sc)); + return(sc->rec_fn(sc, sc->t2_1)); } -static bool -op_set_opsaaq_p (s7_scheme* sc) { - const s7_pointer code= cdr (sc->code), obj= lookup_checked (sc, caar (code)); - if (could_be_macro_setter (obj)) { - const s7_pointer setf= setter_p_pp (sc, obj, sc->curlet); - if (is_any_macro (setf)) { - sc->code= setf; - sc->args= pair_append (sc, cdar (code), cdr (code)); - return (true); - } - } - push_stack (sc, OP_SET_opSAAq_P_1, obj, code); - sc->code= cadr (code); - return (false); -} - -static bool -op_set_opsaaq_p_1 (s7_scheme* sc) { - const s7_pointer value= sc->value; - bool result; - s7_pointer index1= fx_call (sc, cdar (sc->code)); - gc_protect_via_stack (sc, index1); - result= - set_pair4 (sc, sc->args, index1, fx_call (sc, cddar (sc->code)), value); - if (!result) unstack_gc_protect (sc); - return (result); -} - -static bool -op_set1 (s7_scheme* sc) { - const s7_pointer sym= - T_Sym (sc->code); /* protect from sc->code possible change in - call_c_function_setter below */ - const s7_pointer slot= - s7_slot (sc, sym); /* if unbound variable hook here, we need the binding, - not the current value */ - if (is_slot (slot)) { - if (is_immutable_slot (slot)) { - if (s7_is_eqv (sc, slot_value (slot), sc->value)) - return (true); /* (set! pi pi) -- this can be confusing! */ - /* eqv? needed here because 0 != 0 if one is int_zero and the other a - * mutable_integer from a loop, etc */ - immutable_object_error_nr ( - sc, set_elist_3 (sc, immutable_error_string, sc->set_symbol, sym)); - } - if (slot_has_setter (slot)) { - const s7_pointer setter= slot_setter (slot); - if (is_c_function (setter)) - sc->value= call_c_function_setter ( - sc, setter, sym, sc->value); /* perhaps better: apply_c_function -- - has argnum error checks */ - else if (is_any_procedure (setter)) { - /* don't push OP_EVAL_DONE here and call eval(sc, OP_APPLY) below -- - * setter might hit an error */ - /* 41297 (set! (v) val) where v=vector gets the setter, but calls - * vector-set! with no args */ - push_stack_no_args (sc, OP_SET_FROM_SETTER, slot); - if (has_let_arg (setter)) - sc->args= list_3 (sc, sym, sc->value, sc->curlet); - else - sc->args= list_2 ( - sc, sym, sc->value); /* these lists are reused as the closure_let - slots in apply_lambda via apply_closure */ - sc->code= setter; - return (false); /* goto APPLY */ - } - } - slot_set_value (slot, sc->value); - symbol_increment_ctr (sym); /* see define setfib example in s7test.scm -- - I'm having second thoughts about this... */ - return (true); /* continue */ - } - if ((!is_let (sc->curlet)) || /* (with-let (rootlet) (set! undef 3)) */ - (!has_let_set_fallback ( - sc->curlet))) /* (with-let (mock-hash-table 'b 2) (set! b 3)) */ - { - if (starlet_symbol_id (sym) != sl_no_field) - error_nr (sc, sc->unbound_variable_symbol, - set_elist_5 (sc, - wrap_string (sc, - "unbound variable ~S in (set! ~S " - "~S), perhaps you meant (*s7* '~S)?", - 66), - sym, sym, sc->value, sym)); - error_nr ( - sc, sc->unbound_variable_symbol, - set_elist_4 (sc, wrap_string (sc, "~S is unbound in (set! ~S ~S)", 29), - sym, sym, sc->value)); - } - sc->value= call_let_set_fallback (sc, sc->curlet, sym, sc->value); - return (true); -} - -static bool -op_set_with_let_1 (s7_scheme* sc) { - s7_pointer arg1, settee; - const s7_pointer val= sc->value; - /* from the T_SYNTAX branch of op_set_pair: (set! (with-let arg1 settee) val) - * as in let-temporarily here sc->value is the new value for the settee = val, - * args has the (as yet unevaluated) let and settee-expression. 'settee above - * can be a pair = generalized set in the 'arg1 environment. - */ - if (!is_pair (sc->args)) /* (set! (with-let) ...) */ - syntax_error_nr (sc, - "with-let needs a let and a symbol: (set! (with-let) ~$)", - 55, sc->value); - if (!is_pair (cdr (sc->args))) /* (set! (with-let e) ...) */ - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, "with-let in (set! (with-let ~S) ~$) has no symbol to set?", - 57), - car (sc->args), sc->value)); - - arg1 = car (sc->args); - settee= cadr (sc->args); - if (is_multiple_value (val)) /* (set! (with-let lt) (values 1 2)) */ - error_nr (sc, sc->syntax_error_symbol, - set_elist_4 (sc, - wrap_string (sc, - "can't (set! (with-let ~S ~S) (values " - "~{~S~^ ~})): too many values", - 65), - arg1, settee, val)); - if (is_symbol (arg1)) { - if (is_symbol (settee)) { - s7_pointer let= lookup_checked (sc, arg1); - if (!is_let (let)) - wrong_type_error_nr (sc, sc->let_set_symbol, 1, let, a_let_string); - sc->value= let_set_1 (sc, let, settee, val); - pop_stack (sc); - return (true); - } - sc->value= lookup_checked (sc, arg1); - sc->code = set_plist_3 (sc, sc->set_symbol, settee, - ((is_symbol (val)) || (is_pair (val))) - ? set_plist_2 (sc, sc->quote_function, val) - : val); - /* (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= arg1; /* 'arg1 above, an expression we need to evaluate */ - sc->args= set_plist_2 (sc, settee, - val); /* 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 s7_pointer op_recur_if_a_a_opa_l2aq(s7_scheme *sc, s7_pointer code) +{ + opinit_if_a_a_opa_l2aq(sc, code); + return(oprec_if_a_a_opa_l2aq(sc)); } -static bool -op_set_with_let_2 (s7_scheme* sc) { - s7_pointer settee, val; - /* here sc->value = let, args = '(settee val) where 'settee might be a pair */ - if (!is_let (sc->value)) - wrong_type_error_nr (sc, sc->let_set_symbol, 1, sc->value, a_let_string); - settee= car (sc->args); - if ((!is_symbol (settee)) && (!is_pair (settee))) - error_nr (sc, sc->syntax_error_symbol, - set_elist_3 ( - sc, wrap_string (sc, "can't set ~S in ~$", 18), settee, - set_ulist_1 (sc, global_value (sc->set_symbol), sc->args))); - val= cadr (sc->args); - if (is_symbol (settee)) /* settee is a symbol -- everything else is ready so - call let-set! */ - { - sc->value= let_set_1 (sc, sc->value, settee, val); - return (true); /* continue */ - } - if ((is_symbol (val)) || - (is_pair (val))) /* (set! (with-let (inlet :v (vector 1 2)) (v 0)) 'a) */ - sc->code= list_3 (sc, sc->set_symbol, settee, - ((is_symbol (val)) || (is_pair (val))) - ? list_2 (sc, sc->quote_function, val) - : val); + +/* -------- if_a_a_opa_l3aq -------- */ +static void opinit_if_a_a_opa_l3aq(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer caller = rec_call_clause(code); + const bool la_op = a_is_cadr(caller); + tick_tc(sc, OP_RECUR_IF_A_A_opA_L3Aq); + rec_set_test(sc, rec_test_clause(code)); + rec_set_res(sc, rec_done_clause(code)); + rec_set_f1(sc, (la_op) ? cdr(caller) : cddr(caller)); + rec_set_f2(sc, cdr(rec_call_clause(caller))); + rec_set_f3(sc, cddr(rec_call_clause(caller))); + rec_set_f4(sc, cdddr(rec_call_clause(caller))); + 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); + sc->rec_bool = true_is_done(code); + sc->rec_loc = 0; + if (la_op) {sc->rec_p1 = sc->t2_1; sc->rec_p2 = sc->t2_2;} else {sc->rec_p1 = sc->t2_2; sc->rec_p2 = sc->t2_1;} +} + +static s7_pointer oprec_if_a_a_opa_l3aq(s7_scheme *sc) +{ + if ((sc->rec_testf(sc, sc->rec_testp) != sc->F) == sc->rec_bool) 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) == sc->rec_bool) + set_car(sc->rec_p2, sc->rec_resf(sc, sc->rec_resp)); else - sc->code= cons (sc, sc->set_symbol, - sc->args); /* (set! (with-let (curlet) (*s7* 'print-length)) - 16), val=16 b=(*s7* 'print-length) */ - return (false); /* fall into SET_WITH_LET */ + { + recur_push_unchecked(sc, sc->rec_f1f(sc, sc->rec_f1p)); + recur_push_unchecked(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->rec_p2, oprec_if_a_a_opa_l3aq(sc)); + set_car(sc->rec_p1, recur_pop(sc)); + set_car(sc->rec_p2, sc->rec_fn(sc, sc->t2_1)); + } + set_car(sc->rec_p1, recur_pop(sc)); + return(sc->rec_fn(sc, sc->t2_1)); } -static bool -op_set_normal (s7_scheme* sc) { - s7_pointer val; - sc->code= cdr (sc->code); - val = cadr (sc->code); - if (is_pair (val)) { - push_stack_no_args (sc, OP_SET1, car (sc->code)); - sc->code= val; - return (true); - } - sc->value= (is_symbol (val)) ? lookup_checked (sc, val) : T_Ext (val); - sc->code = car (sc->code); - return (false); +static s7_pointer op_recur_if_a_a_opa_l3aq(s7_scheme *sc, s7_pointer code) +{ + opinit_if_a_a_opa_l3aq(sc, code); + return(oprec_if_a_a_opa_l3aq(sc)); } -static Inline void -inline_op_increment_by_1 ( - s7_scheme* sc) /* ([set!] ctr (+ ctr 1)) -- why is this always inlined? - saves 22 in concordance */ + +/* -------- if_a_a_opa_la_laq -------- */ +static void opinit_if_a_a_opa_la_laq(s7_scheme *sc, s7_pointer code) { - const s7_pointer slot= T_Slt (s7_t_slot (sc, cadr (sc->code))); - const s7_pointer val = slot_value (slot); - 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); - set_numerator (sc->value, numerator (val) + denominator (val)); - set_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 (slot, sc->value); + const s7_pointer caller = rec_call_clause(code); + tick_tc(sc, OP_RECUR_IF_A_A_opA_LA_LAq); + rec_set_test(sc, rec_test_clause(code)); + rec_set_res(sc, rec_done_clause(code)); + rec_set_f1(sc, cdr(caller)); + rec_set_f2(sc, cdaddr(caller)); + rec_set_f3(sc, cdr(rec_call_clause(caller))); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_fn = fn_proc(caller); + sc->rec_loc = 0; + sc->rec_bool = true_is_done(code); +} + +static s7_pointer oprec_if_a_a_opa_la_laq(s7_scheme *sc) +{ + if ((sc->rec_testf(sc, sc->rec_testp) != sc->F) == sc->rec_bool) 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 op_recur_if_a_a_opa_la_laq(s7_scheme *sc, s7_pointer code) +{ + opinit_if_a_a_opa_la_laq(sc, code); + return(oprec_if_a_a_opa_la_laq(sc)); } -static void -op_decrement_by_1 (s7_scheme* sc) /* ([set!] ctr (- ctr 1)) */ + +/* -------- if_a_a_opla_la_laq -------- */ +static void opinit_if_a_a_opla_la_laq(s7_scheme *sc, s7_pointer code) { - const s7_pointer slot= T_Slt (s7_t_slot (sc, cadr (sc->code))); - const s7_pointer val = slot_value (slot); - 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); - set_numerator (sc->value, numerator (val) - denominator (val)); - set_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_2 (sc, set_plist_2 (sc, val, int_one)); - break; - } - slot_set_value (slot, sc->value); + const s7_pointer caller = rec_call_clause(code); + tick_tc(sc, OP_RECUR_IF_A_A_opLA_LA_LAq); + rec_set_test(sc, rec_test_clause(code)); + rec_set_res(sc, rec_done_clause(code)); + rec_set_f1(sc, cdadr(caller)); + rec_set_f2(sc, cdaddr(caller)); + rec_set_f3(sc, cdr(rec_call_clause(caller))); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_fn = fn_proc(caller); + sc->rec_loc = 0; + sc->rec_bool = true_is_done(code); +} + +static s7_pointer oprec_if_a_a_opla_la_laq(s7_scheme *sc) +{ + if ((sc->rec_testf(sc, sc->rec_testp) != sc->F) == sc->rec_bool) 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, s7_pointer code) +{ + opinit_if_a_a_opla_la_laq(sc, code); + return(oprec_if_a_a_opla_la_laq(sc)); } -/* ---------------- implicit ref/set ---------------- */ -static Inline bool -inline_op_implicit_vector_ref_a ( - s7_scheme* sc) /* called once in eval, Inline because tnum/tmat get - ridiculous call overhead (70!) */ -{ - s7_pointer ind; - const s7_pointer vec= lookup_checked (sc, car (sc->code)); - if (!is_any_vector (vec)) { - sc->last_function= vec; - return (false); - } - ind= fx_call (sc, cdr (sc->code)); - if ((s7_is_integer (ind)) && (vector_rank (vec) == 1)) { - s7_int index= s7_integer_clamped_if_gmp (sc, ind); - if ((index < vector_length (vec)) && (index >= 0)) { - sc->value= (is_float_vector (vec)) - ? make_real (sc, float_vector (vec, index)) - : vector_getter (vec) (sc, vec, index); - return (true); +/* -------- if_a_a_and_a_l2a_l2a -------- */ +static void opinit_if_a_a_and_a_l2a_l2a(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer caller = rec_call_clause(code); + const s7_pointer la1 = caddr(caller); + const s7_pointer la2 = cadddr(caller); + tick_tc(sc, OP_RECUR_IF_A_A_AND_A_L2A_L2A); + rec_set_test(sc, cdr(code)); + rec_set_res(sc, cddr(code)); + 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); + sc->rec_loc = 0; +} + +static s7_pointer oprec_if_a_a_and_a_l2a_l2a(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_l2a_l2a(sc) == sc->F) + { + sc->rec_loc -= 2; + return(sc->F); } - } - sc->value= s7i_vector_ref_1 (sc, vec, set_plist_1 (sc, ind)); - return (true); -} - -static s7_pointer -fx_implicit_vector_ref_a (s7_scheme* sc, s7_pointer arg) { - s7_pointer ind; - const s7_pointer vec= lookup_checked (sc, car (arg)); - if (!is_any_vector (vec)) - return (s7_apply_function (sc, vec, list_1 (sc, fx_call (sc, cdr (arg))))); - ind= fx_call (sc, cdr (arg)); - if ((s7_is_integer (ind)) && (vector_rank (vec) == 1)) { - s7_int index= s7_integer_clamped_if_gmp (sc, ind); - if ((index < vector_length (vec)) && (index >= 0)) - return (vector_getter (vec) (sc, vec, index)); - } - return (s7i_vector_ref_1 (sc, vec, set_plist_1 (sc, ind))); + slot_set_value(sc->rec_slot2, recur_pop(sc)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + recur_push_unchecked(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_l2a_l2a(sc)); } -static bool -op_implicit_vector_ref_aa ( - s7_scheme* sc) /* tnum/tmat, neither uses fx case if available (see tmp) */ +static s7_pointer op_recur_if_a_a_and_a_l2a_l2a(s7_scheme *sc, s7_pointer code) { - s7_pointer ind1, ind2, code; - const s7_pointer vec= lookup_checked (sc, car (sc->code)); - if (!is_any_vector (vec)) { - sc->last_function= vec; - return (false); - } - code= cdr (sc->code); - ind1= fx_call (sc, code); - gc_protect_via_stack (sc, ind1); - ind2= fx_call (sc, cdr (code)); - set_gc_protected2 (sc, ind2); - if ((s7_is_integer (ind1)) && (s7_is_integer (ind2)) && - (vector_rank (vec) == 2)) { - s7_int i1= s7_integer_clamped_if_gmp (sc, ind1); - s7_int i2= s7_integer_clamped_if_gmp (sc, ind2); - if ((i1 >= 0) && (i2 >= 0) && (i1 < vector_dimension (vec, 0)) && - (i2 < vector_dimension (vec, 1))) { - s7_int index= (i1 * vector_offset (vec, 0)) + i2; - sc->value = (is_float_vector (vec)) - ? make_real (sc, float_vector (vec, index)) - : vector_getter (vec) ( - sc, vec, index); /* check for normal vector saves in - some cases, costs in others */ - unstack_gc_protect (sc); - return (true); - } - } - sc->value= s7i_vector_ref_1 (sc, vec, set_plist_2 (sc, ind1, ind2)); - unstack_gc_protect (sc); - return (true); -} - -static goto_t call_set_implicit (s7_scheme* sc, s7_pointer obj, s7_pointer inds, - s7_pointer val, s7_pointer form); - -static void -setup_eval_args_pair (s7_scheme* sc, s7_pointer obj, s7_pointer inds, - s7_pointer val) { - push_stack (sc, OP_SET2, cdr (inds), val); - sc->code= list_2 (sc, obj, car (inds)); - set_optimize_op ( - sc->code, - OP_PAIR_ANY); /* usually an error: (#\a) etc, might be (#(0) 0) */ - sc->value= obj; - sc->code = cdr (sc->code); - push_op_stack (sc, sc->value); - if (sc->op_stack_now >= sc->op_stack_end) resize_op_stack (sc); - sc->args= sc->nil; -} - -static goto_t -set_implicit_vector (s7_scheme* sc, s7_pointer vect, s7_pointer inds, - s7_pointer val, s7_pointer form) { - /* vect is the vector, sc->code is expr without the set!, form is the full - * expr, args have not been evaluated! */ - s7_pointer index; - s7_int argnum; - - if (!is_pair (inds)) - wrong_number_of_arguments_error_nr ( - sc, "no index for implicit vector-set!: ~S", 37, form); - if (is_immutable_vector (vect)) - immutable_object_error_nr (sc, set_elist_3 (sc, immutable_error_string, - sc->vector_set_symbol, vect)); - - argnum= proper_list_length (inds); - if ((argnum > 1) && (is_t_vector (vect)) && (argnum != vector_rank (vect))) { - /* this block needs to be first to handle (eg): - * (let ((v (vector (inlet 'a 0)))) (set! (v 0 'a) 32) v): #((inlet 'a - * 32)) sc->code here: ((v 0 'a) 32) - */ - if (vector_rank (vect) == 1) { - s7_pointer ind= car (inds); - if (is_symbol (ind)) ind= lookup_checked (sc, ind); - if (is_t_integer (ind)) { - s7_pointer obj; - const s7_int index1= integer (ind); - if ((index1 < 0) || (index1 >= vector_length (vect))) - out_of_range_error_nr (sc, sc->vector_ref_symbol, int_two, car (inds), - (index1 < 0) ? it_is_negative_string - : it_is_too_large_string); - obj= vector_element (vect, index1); - if (!is_applicable (obj)) - error_nr ( - sc, sc->no_setter_symbol, - set_elist_5 ( - sc, - wrap_string ( - sc, "in ~S, (~S ~S) is ~S which can't take arguments", - 47), - form, vect, car (inds), obj)); - return (call_set_implicit (sc, obj, cdr (inds), val, form)); - } - } - /* PERHAPS: do the loop here to collect the evaluated args, then call - * apply_vector */ - setup_eval_args_pair (sc, vect, inds, val); - return (goto_eval_args_pair); - } - if ((argnum > 1) || (vector_rank (vect) > 1)) { - if ((argnum == vector_rank (vect)) && (!is_pair (car (val)))) { - s7_pointer p; - for (p= inds; is_pair (p); p= cdr (p)) - if (is_pair (car (p))) break; - if (is_null (p)) { - s7_pointer pa; - const s7_pointer args= safe_list_if_possible (sc, argnum + 2); - if (in_heap (args)) gc_protect_via_stack (sc, args); - set_car (args, vect); - for (p= inds, 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)) { - if (in_heap (args)) unstack_gc_protect (sc); - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_2 ( - sc, - wrap_string ( - sc, "vector-set!: index must be an integer: ~S", 41), - form)); - } - set_car (pa, index); - } - set_car (pa, car (val)); - if (is_symbol (car (pa))) set_car (pa, lookup_checked (sc, car (pa))); - sc->value= g_vector_set (sc, args); - if (in_heap (args)) unstack_gc_protect (sc); - else clear_safe_list_in_use (sc, args); - return (goto_start); - } - } - push_op_stack ( - sc, sc->vector_set_function); /* vector_setter(vect) has wrong args */ - sc->code= - (is_null (cdr (inds))) - ? val - : ((is_null (cddr (inds))) - ? cons (sc, cadr (inds), val) - : pair_append (sc, cdr (inds), - T_Lst (val))); /* i.e. rest(args) + val */ - push_stack (sc, OP_EVAL_ARGS4, list_1 (sc, vect), sc->code); - sc->code = car (inds); - sc->cur_op= optimize_op (sc->code); - return (goto_top_no_pop); - } - /* one index, rank == 1 */ - index= car (inds); - if (!is_pair (index)) { - s7_int ind; - s7_pointer value; - if (is_symbol (index)) index= lookup_checked (sc, index); - if (!s7_is_integer (index)) - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_2 ( - sc, - wrap_string (sc, "vector-set!: index must be an integer: ~S", 41), - sc->code)); - ind= s7_integer_clamped_if_gmp (sc, index); - if ((ind < 0) || (ind >= vector_length (vect))) - out_of_range_error_nr (sc, sc->vector_set_symbol, int_two, index, - (ind < 0) ? it_is_negative_string - : it_is_too_large_string); - value= car (val); - if (!is_pair (value)) { - if (is_symbol (value)) value= lookup_checked (sc, value); - if (is_typed_t_vector (vect)) typed_vector_setter (sc, vect, ind, value); - else vector_setter (vect) (sc, vect, ind, value); - sc->value= T_Ext (value); - return (goto_start); - } - push_op_stack (sc, sc->vector_set_function); - sc->args= list_2 (sc, index, vect); - sc->code= val; - 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, vect), val); - push_op_stack (sc, sc->vector_set_function); - sc->code = car (inds); - sc->cur_op= optimize_op (sc->code); - return (goto_top_no_pop); -} - -static goto_t -set_implicit_c_object (s7_scheme* sc, s7_pointer c_obj, s7_pointer inds, - s7_pointer val, s7_pointer form) { - s7_pointer index; - /* c_obj's set! method needs to provide error checks */ + opinit_if_a_a_and_a_l2a_l2a(sc, code); + return(oprec_if_a_a_and_a_l2a_l2a(sc)); +} - if ((!is_pair (inds)) || (!is_null (cdr (inds)))) { - push_op_stack (sc, sc->c_object_set_function); - if (is_null (inds)) { - push_stack_no_code (sc, OP_EVAL_ARGS1, list_1 (sc, c_obj)); - sc->code= car (val); - } - else { - sc->code= (is_null (cdr (inds))) - ? cons (sc, car (inds), val) - : pair_append (sc, cdr (inds), T_Lst (val)); - push_stack (sc, OP_EVAL_ARGS4, list_1 (sc, c_obj), sc->code); - sc->code= car (inds); - } - sc->cur_op= optimize_op (sc->code); - return (goto_top_no_pop); - } - index= car (inds); - if (!is_pair (index)) { - s7_pointer value= car (val); - if (is_symbol (index)) index= lookup_checked (sc, index); - if (!is_pair (value)) { - if (is_symbol (value)) value= lookup_checked (sc, value); - sc->value= (*(c_object_set (sc, c_obj))) ( - sc, with_list_t3 (sc, c_obj, index, value)); - return (goto_start); - } - push_op_stack (sc, sc->c_object_set_function); - sc->args= list_2 (sc, index, c_obj); - sc->code= val; - return (goto_eval_args); - } - push_stack (sc, OP_EVAL_ARGS4, list_1 (sc, c_obj), val); - push_op_stack (sc, sc->c_object_set_function); - sc->code = car (inds); - sc->cur_op= optimize_op (sc->code); - return (goto_top_no_pop); -} - -static bool -op_implicit_string_ref_a (s7_scheme* sc) { - s7_int index; - const s7_pointer str= lookup_checked (sc, car (sc->code)); - const s7_pointer val= fx_call (sc, cdr (sc->code)); - if (!is_string (str)) { - sc->last_function= str; - return (false); - } - if (!s7_is_integer (val)) { - sc->value= string_ref_1 (sc, str, set_plist_1 (sc, val)); - return (true); - } - index= s7_integer_clamped_if_gmp (sc, val); - if ((index < string_length (str)) && (index >= 0)) { - sc->value= chars[((uint8_t*) string_value (str))[index]]; - return (true); - } - sc->value= string_ref_1 (sc, str, val); - return (true); + +/* -------- cond_a_a_a_a_opa_l2aq -------- */ +static void opinit_cond_a_a_a_a_opa_l2aq(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer caller = rec_call_clause(code); + s7_pointer p; + tick_tc(sc, OP_RECUR_COND_A_A_A_A_opA_L2Aq); + rec_set_test(sc, cadr(code)); + rec_set_res(sc, cdadr(code)); + p = caddr(code); + rec_set_f1(sc, p); + rec_set_f2(sc, cdr(p)); + rec_set_f3(sc, cdr(caller)); + rec_set_f4(sc, rec_call_clause(caller)); + rec_set_f5(sc, cdr(rec_call_clause(caller))); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_slot2 = next_slot(sc->rec_slot1); + sc->rec_fn = fn_proc(caller); + sc->rec_loc = 0; +} + +static s7_pointer oprec_cond_a_a_a_a_opa_l2aq(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_l2aq(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_l2aq(s7_scheme *sc, s7_pointer code) +{ + opinit_cond_a_a_a_a_opa_l2aq(sc, code); + return(oprec_cond_a_a_a_a_opa_l2aq(sc)); } -static goto_t -set_implicit_string (s7_scheme* sc, s7_pointer str, s7_pointer inds, - s7_pointer val, 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 index; - if (!is_pair (inds)) - wrong_number_of_arguments_error_nr (sc, "no index for string set!: ~S", 28, - form); - if (!is_null (cdr (inds))) - wrong_number_of_arguments_error_nr ( - sc, "too many indices for string set!: ~S", 36, form); - - index= car (inds); - if (!is_pair (index)) { - s7_int ind; - if (is_symbol (index)) index= lookup_checked (sc, index); - if (!s7_is_integer (index)) - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_2 (sc, wrap_string (sc, "index must be an integer: ~S", 28), - form)); - ind= s7_integer_clamped_if_gmp (sc, index); - if ((ind < 0) || (ind >= string_length (str))) - out_of_range_error_nr (sc, sc->string_set_symbol, int_two, index, - (ind < 0) ? it_is_negative_string - : it_is_too_large_string); - if (is_immutable_string (str)) - immutable_object_error_nr (sc, set_elist_3 (sc, immutable_error_string, - sc->string_set_symbol, str)); - - val= car (val); - if (!is_pair (val)) { - if (is_symbol (val)) val= lookup_checked (sc, val); - if (is_character (val)) { - string_value (str)[ind]= character (val); - sc->value = val; - return (goto_start); +/* -------- cond_a_a_a_l2a_opa_l2aq -------- */ +static void opinit_cond_a_a_a_l2a_opa_l2aq(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer caller = rec_call_clause(code); /* opA_L2A */ + s7_pointer p; + tick_tc(sc, OP_RECUR_IF_A_A_IF_A_L2A_opA_L2Aq); + rec_set_test(sc, rec_test_clause(code)); + rec_set_res(sc, rec_done_clause(code)); + p = rec_done_clause(cdr(code)); /* (cond) ? caddr(code) : cdr(cadddr(code)); */ + rec_set_f1(sc, p); + p = cdadr(p); + rec_set_f2(sc, p); + rec_set_f3(sc, cdr(p)); + rec_set_f4(sc, cdr(caller)); + p = cdr(rec_call_clause(caller)); /* (L)AA */ + rec_set_f5(sc, p); + rec_set_f6(sc, cdr(p)); + sc->rec_fn = fn_proc(caller); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_slot2 = next_slot(sc->rec_slot1); + sc->rec_loc = 0; +} + +static s7_pointer oprec_cond_a_a_a_l2a_opa_l2aq(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_l2a_opa_l2aq(sc)); /* first l2a 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_unchecked(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_l2a_opa_l2aq(sc)); /* first l2a above */ } - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_2 ( - sc, wrap_string (sc, "value must be a character: ~S", 29), form)); - } - /* maybe op_implicit_string_set_a as in vector someday, but this code isn't - * (currently) called much */ - push_op_stack (sc, sc->string_set_function); - sc->args= list_2 (sc, index, str); - sc->code= cdr (sc->code); - return (goto_eval_args); - } - push_stack (sc, OP_EVAL_ARGS4, list_1 (sc, str), - val); /* args4 not 1 because we know cdr(sc->code) is a pair */ - push_op_stack (sc, sc->string_set_function); - sc->code = car (inds); - sc->cur_op= optimize_op (sc->code); - return (goto_top_no_pop); -} - -static goto_t -set_implicit_pair (s7_scheme* sc, s7_pointer lst, s7_pointer inds, - s7_pointer val, s7_pointer form) { - s7_pointer index, index_val= NULL; - const s7_pointer value= car (val); - - if (!is_pair (inds)) /* (!is_pair(val)) and (!is_null(cdr(val))) are - apparently caught somewhere else */ - wrong_number_of_arguments_error_nr (sc, "no index for list-set!: ~S", 26, - form); - - index= car (inds); - if (!is_pair (index)) - index_val= (is_normal_symbol (index)) ? lookup_checked (sc, index) : index; - - if (!is_null (cdr (inds))) { - /* 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) */ - if (index_val) { - s7_pointer obj= list_ref_1 (sc, lst, index_val); - if (!is_applicable (obj)) - error_nr ( - sc, sc->no_setter_symbol, - set_elist_5 ( - sc, - wrap_string ( - sc, "in ~S, (~S ~$) is ~S which can't take arguments", 47), - form, lst, index_val, obj)); - return (call_set_implicit (sc, obj, cdr (inds), val, form)); - } - setup_eval_args_pair (sc, lst, inds, - val); /* (let ((L (list (list 1 2 3)))) (set! (L (- - (length L) 1) 2) 0) L) */ - return (goto_eval_args_pair); - } - if (index_val) { - if (!is_pair (value)) { - set_car (sc->t2_1, index_val); - set_car (sc->t2_2, - (is_symbol (value)) ? lookup_checked (sc, value) : value); - sc->value= g_list_set_1 (sc, lst, sc->t2_1, 2); - return (goto_start); - } - push_op_stack (sc, - sc->list_set_function); /* because cdr(inds) is nil, we're - definitely calling list_set */ - sc->args= list_2 (sc, index_val, lst); /* plist unsafe here */ - sc->code= val; - return (goto_eval_args); - } - push_stack (sc, OP_EVAL_ARGS4, list_1 (sc, lst), val); /* plist unsafe here */ - push_op_stack (sc, sc->list_set_function); - sc->code = car (inds); - sc->cur_op= optimize_op (sc->code); - return (goto_top_no_pop); -} - -static goto_t -set_implicit_hash_table (s7_scheme* sc, s7_pointer table, s7_pointer inds, - s7_pointer val, s7_pointer form) { - s7_pointer key, keyval= NULL; - - if (!is_pair (inds)) /* (!is_pair(val)) and (!is_null(cdr(val))) are - apparently caught elsewhere */ - wrong_number_of_arguments_error_nr (sc, "no key for hash-table-set!: ~S", - 30, form); - if (is_immutable_hash_table (table)) - immutable_object_error_nr (sc, - set_elist_3 (sc, immutable_error_string, - sc->hash_table_set_symbol, table)); - - key= car (inds); - if (is_pair (key)) { - if (is_quote (sc, car (key))) keyval= cadr (key); - } - else keyval= (is_normal_symbol (key)) ? lookup_checked (sc, key) : key; - if (!is_null (cdr (inds))) { - if (keyval) { - const s7_pointer obj= s7_hash_table_ref (sc, table, keyval); - if (obj == - missing_key_value ( - sc)) /* (let ((h (hash-table 'b 1))) (set! (h 'a 'asdf) 32)) */ - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_4 (sc, - wrap_string (sc, "in ~S, ~$ does not exist in ~S", 30), - form, keyval, table)); - else if (!is_applicable (obj)) /* (let ((h (hash-table 'b 1))) (set! (h 'b - 'asdf) 32)) */ - error_nr ( - sc, sc->no_setter_symbol, - set_elist_5 ( - sc, - wrap_string ( - sc, "in ~S, (~S ~$) is ~S which can't take arguments", 47), - form, table, keyval, obj)); - /* (let ((v (hash-table 'a (hash-table 'b 1)))) (set! (v 'a 'b 'b) 32) v) - * -> error: in (set! (v 'a 'b 'b) 32), ((hash-table 'b 1) 'b) is 1 which - * can't take arguments (let ((v (hash-table 'a (list 1 2)))) (set! (v 'a - * 1) 5)) -> code: (set! ((1 2) 1) 5) -> 5 (v: (hash-table 'a (1 5))) - */ - return (call_set_implicit (sc, obj, cdr (inds), val, form)); - } - setup_eval_args_pair (sc, table, inds, val); /* key = car(inds) */ - return (goto_eval_args_pair); - } - if (keyval) { - const s7_pointer value= car (val); - if (is_pair (value)) { - if (is_quote (sc, car (value))) { - sc->value= s7_hash_table_set (sc, table, keyval, cadr (value)); - return (goto_start); + else + { + recur_push_unchecked(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_l2a_opa_l2aq(sc)); + set_car(sc->t2_1, recur_pop(sc)); + set_car(sc->t2_2, sc->rec_fn(sc, sc->t2_1)); } - } - else { - sc->value= s7_hash_table_set ( - sc, table, keyval, - (is_normal_symbol (value)) ? lookup_checked (sc, value) : value); - return (goto_start); - } - push_op_stack ( - sc, - sc->hash_table_set_function); /* because cdr(inds) is nil, we're - definitely calling hash_table_set */ - sc->args= list_2 (sc, keyval, table); /* plist unsafe here */ - sc->code= val; - return (goto_eval_args); - } - push_stack (sc, OP_EVAL_ARGS4, list_1 (sc, table), - val); /* plist unsafe here */ - push_op_stack (sc, sc->hash_table_set_function); - sc->code = car (inds); - sc->cur_op= optimize_op (sc->code); - return (goto_top_no_pop); -} - -static goto_t -set_implicit_let (s7_scheme* sc, s7_pointer let, s7_pointer inds, - s7_pointer val, s7_pointer form) { - s7_pointer sym, symval= NULL; - - if (!is_pair (inds)) /* as above, bad val caught elsewhere */ - wrong_number_of_arguments_error_nr ( - sc, "no symbol (variable name) for let-set!: ~S", 42, form); - - sym= car (inds); - if (is_pair (sym)) { - if (is_quote (sc, car (sym))) symval= cadr (sym); - } - else symval= (is_normal_symbol (sym)) ? lookup_checked (sc, sym) : sym; - if (!is_null (cdr (inds))) { - if (symval) { - const s7_pointer obj= let_ref (sc, let, symval); - if (!is_applicable ( - obj)) /* (let ((h (hash-table 'b 1))) (set! (h 'b 'asdf) 32)) */ - error_nr ( - sc, sc->no_setter_symbol, - set_elist_5 ( - sc, - wrap_string ( - sc, "in ~S, (~S ~$) is ~S which can't take arguments", 47), - form, let, symval, obj)); - return (call_set_implicit (sc, obj, cdr (inds), val, form)); - } - setup_eval_args_pair (sc, let, inds, val); - return (goto_eval_args_pair); - /* this is unnecessary: continue at eval_last_arg+ goto apply -> apply_let - * -> pop_stack + goto top_no_pop */ - } - if (symval) { - s7_pointer value= car (val); - if (!is_pair (value)) { - if (is_symbol (value)) value= lookup_checked (sc, value); - sc->value= let_set_2 (sc, let, symval, value); - return (goto_start); - } - push_op_stack (sc, sc->let_set_function); - sc->args= list_2 (sc, symval, let); - sc->code= val; - return (goto_eval_args); - } - push_stack (sc, OP_EVAL_ARGS4, list_1 (sc, let), val); - push_op_stack (sc, sc->let_set_function); - sc->code = car (inds); - sc->cur_op= optimize_op (sc->code); - return (goto_top_no_pop); -} - -static goto_t -set_implicit_c_function ( - s7_scheme* sc, - s7_pointer fnc) /* (let ((lst (list 1 2))) (set! (list-ref lst 0) 2) lst) */ -{ - if (!is_t_procedure (c_function_setter (fnc))) { - if (!is_any_macro (c_function_setter (fnc))) no_setter_error_nr (sc, fnc); - sc->args= (is_null (cdar (sc->code))) - ? cdr (sc->code) - : ((is_null (cddar (sc->code))) - ? cons (sc, cadar (sc->code), cdr (sc->code)) - : pair_append (sc, cdar (sc->code), cdr (sc->code))); - sc->code= c_function_setter (fnc); - /* here multiple-values can't happen because we don't eval the new-value - * argument */ - 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_null (cdar (sc->code))) { - push_stack (sc, OP_EVAL_SET1_NO_MV, sc->nil, c_function_setter (fnc)); - sc->code= cadr (sc->code); /* new value */ - } - else { - if (is_null (cddar (sc->code))) /* (set! (fnc ind) val) */ - push_stack (sc, OP_EVAL_SET2, cadr (sc->code), c_function_setter (fnc)); - else { - push_op_stack (sc, c_function_setter (fnc)); - sc->value= pair_append (sc, cddar (sc->code), cdr (sc->code)); - push_stack (sc, OP_EVAL_SET3, sc->nil, - sc->value); /* args=evalled, code=unevalled */ - } - sc->code= cadar (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 fnc) { - s7_pointer setter= closure_setter_or_map_list ( - fnc); /* (set! (fnc ind...) val), sc->code = ((fnc ind...) val) */ - if ((setter == sc->F) && - (!closure_no_setter (fnc))) /* maybe closure_setter hasn't been set yet: - see fset3 in s7test.scm */ - setter= setter_p_pp (sc, fnc, sc->curlet); - if (!is_t_procedure (setter)) { - if (!is_any_macro (setter)) no_setter_error_nr (sc, fnc); - sc->args= (is_null (cdar (sc->code))) - ? cdr (sc->code) - : ((is_null (cddar (sc->code))) - ? cons (sc, cadar (sc->code), cdr (sc->code)) - : pair_append (sc, cdar (sc->code), cdr (sc->code))); - sc->code= setter; - return (goto_apply); - } - if (is_null (cdar (sc->code))) /* (set! (fnc) val) */ - { - push_stack (sc, OP_EVAL_SET1_NO_MV, sc->nil, - setter); /* args=(), code=setter */ - sc->code= cadr (sc->code); /* the value */ - } - else { - if (is_null (cddar (sc->code))) /* (set! (fnc ind) val) */ - push_stack (sc, OP_EVAL_SET2, cadr (sc->code), setter); - else /* (set! (fnc inds ...) val) */ - { - push_op_stack (sc, setter); - sc->value= pair_append (sc, cddar (sc->code), cdr (sc->code)); - push_stack (sc, OP_EVAL_SET3, sc->nil, - sc->value); /* args=evalled, code=unevalled */ - } - sc->code= cadar (sc->code); /* "ind" above */ - } - sc->cur_op= optimize_op (sc->code); - return (goto_top_no_pop); -} - -static goto_t -set_implicit_iterator (s7_scheme* sc, s7_pointer iter) { - s7_pointer setter= iterator_sequence (iter); - - if ((is_any_closure (setter)) || (is_any_macro (setter))) - setter= closure_setter (iterator_sequence (iter)); - else no_setter_error_nr (sc, iter); - - if (!is_null ( - cdar (sc->code))) /* (set! (iter ...) val) but iter is a thunk */ - error_nr ( - sc, sc->wrong_number_of_args_symbol, - set_elist_3 ( - sc, - wrap_string (sc, "~S (an iterator): too many arguments: ~S", 40), - iter, sc->code)); - - if (is_procedure (setter)) { - push_op_stack (sc, setter); - push_stack_no_code (sc, OP_EVAL_ARGS1, sc->nil); - sc->code= cadr (sc->code); /* the (as yet unevaluated) value, incoming code - was ((obj) val) */ - sc->cur_op= optimize_op (sc->code); - return (goto_top_no_pop); - } - sc->args= cdr (sc->code); - sc->code= setter; - return (goto_apply); + set_car(sc->t2_1, recur_pop(sc)); + return(sc->rec_fn(sc, sc->t2_1)); } -static goto_t -set_implicit_syntax (s7_scheme* sc, s7_pointer wlet) { - if (wlet != global_value (sc->with_let_symbol)) no_setter_error_nr (sc, wlet); - - /* (set! (with-let a b) x), wlet = 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 -call_set_implicit (s7_scheme* sc, s7_pointer obj, s7_pointer inds, - s7_pointer val, s7_pointer form) { - /* these depend on sc->code making sense given obj as the sequence being set - * (and 99% of these cases are handled elsewhere -- this is the eval fallback - * code) */ - switch (type (obj)) { - case T_STRING: - return (set_implicit_string (sc, obj, inds, val, form)); - case T_PAIR: - return (set_implicit_pair (sc, obj, inds, val, form)); - case T_HASH_TABLE: - return (set_implicit_hash_table (sc, obj, inds, val, form)); - case T_LET: - return (set_implicit_let (sc, obj, inds, val, form)); - case T_C_OBJECT: - return (set_implicit_c_object (sc, obj, inds, val, form)); - case T_ITERATOR: - return (set_implicit_iterator (sc, obj)); /* not sure this makes sense */ - case T_SYNTAX: - return (set_implicit_syntax (sc, obj)); - - case T_INT_VECTOR: - case T_FLOAT_VECTOR: - case T_VECTOR: - case T_BYTE_VECTOR: - case T_COMPLEX_VECTOR: - return (set_implicit_vector (sc, obj, inds, val, form)); - - case T_C_MACRO: - case T_C_FUNCTION_STAR: - case T_C_RST_NO_REQ_FUNCTION: - case T_C_FUNCTION: - return (set_implicit_c_function ( - sc, obj)); /* (set! (setter...) ...) also comes here */ - - 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, obj)); - - default: /* (set! (1 2) 3) */ - if (is_applicable (obj)) - no_setter_error_nr ( - sc, obj); /* this is reachable if obj is a goto or continuation: (set! - (go 1) 2) in s7test.scm */ - error_nr ( - sc, sc->no_setter_symbol, - set_elist_3 ( - sc, wrap_string (sc, "in ~S, ~S has no setter", 23), - cons_unchecked ( - sc, sc->set_symbol, /* copy_tree(sc, form) also works but copies - too much: we want to copy the ulists */ - cons (sc, copy_proper_list (sc, cadr (form)), cddr (form))), - obj)); - } - return (goto_top_no_pop); +static s7_pointer op_recur_if_a_a_if_a_l2a_opa_l2aq(s7_scheme *sc, s7_pointer code) /* if version, same logic as cond above */ +{ + opinit_cond_a_a_a_l2a_opa_l2aq(sc, code); + return(oprec_cond_a_a_a_l2a_opa_l2aq(sc)); } -static goto_t -set_implicit (s7_scheme* sc) /* sc->code incoming is (set! (...) ...) */ -{ - s7_pointer caar_code, obj; - const s7_pointer form= sc->code; - sc->code = cdr (sc->code); - caar_code = caar (sc->code); - if (is_symbol (caar_code)) { - obj= s7_slot (sc, caar_code); - obj= (is_slot (obj)) ? slot_value (obj) : unbound_variable (sc, caar_code); - } - else if (!is_pair (caar_code)) obj= caar_code; - else { - 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); - } - /* 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 - */ - return (call_set_implicit (sc, obj, cdar (sc->code), cdr (sc->code), form)); -} - -static no_return void -set_with_let_error_nr (s7_scheme* sc) { - s7_pointer target= cadr (sc->code), value= caddr (sc->code); - error_nr ( - sc, sc->no_setter_symbol, - set_elist_3 ( - sc, wrap_string (sc, "can't set ~A in ~S", 18), target, - list_3 (sc, sc->set_symbol, - (is_pair (target)) ? copy_proper_list (sc, target) : target, - (is_pair (value)) ? copy_proper_list (sc, value) : value))); -} - -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) */ - syntax_error_nr (sc, "set! target arguments are an improper list: ~A", 46, - sc->args); - if (is_multiple_value (sc->value)) /* (set! ((values fnc 0)) 32) etc */ - { - if (is_null (sc->args)) { /* can't assume we're in list-set! here -- first - value is target */ - sc->code= list_3 (sc, sc->set_symbol, multiple_value (sc->value), - car (sc->code)); - return (goto_eval); - } - else /* this has to be at least 2 args, sc->args and sc->code make 2 more, - so... */ - syntax_error_nr ( - 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, T_Lst (sc->code))))); - } - if (is_null (sc->args)) - syntax_error_nr (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), T_Lst (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)) && - (vector_rank (sc->value) == - proper_list_length (sc->args))) /* sc->code == new value? */ +/* -------- cond_a_a_a_l2a_lopa_l2aq -------- */ + +static opt_pid_t opinit_cond_a_a_a_l2a_lopa_l2aq(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer caller = rec_call_clause(code); + tick_tc(sc, OP_RECUR_COND_A_A_A_L2A_LopA_L2Aq); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_slot2 = next_slot(sc->rec_slot1); + + 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(code))) + { + sc->rec_result_o = sc->opts[sc->pc]; + if (int_optimize(sc, cdadr(code))) + { + const s7_pointer l2a1 = caddr(code); + sc->rec_a1_o = sc->opts[sc->pc]; + if (bool_optimize(sc, l2a1)) + { + sc->rec_a2_o = sc->opts[sc->pc]; + if (int_optimize(sc, cdadr(l2a1))) + { + sc->rec_a3_o = sc->opts[sc->pc]; + if (int_optimize(sc, cddadr(l2a1))) + { + const s7_pointer l2a2 = cadr(cadddr(code)), l2a3 = caddr(l2a2); + sc->rec_a4_o = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(l2a2))) + { + sc->rec_a5_o = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(l2a3))) + { + sc->rec_a6_o = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(l2a3))) + { + 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 = q_call(sc->rec_test_o).fb; + sc->rec_fb2 = q_call(sc->rec_a1_o).fb; + sc->rec_fi1 = q_call(sc->rec_result_o).fi; + sc->rec_fi2 = q_call(sc->rec_a2_o).fi; + sc->rec_fi3 = q_call(sc->rec_a3_o).fi; + sc->rec_fi4 = q_call(sc->rec_a4_o).fi; + sc->rec_fi5 = q_call(sc->rec_a5_o).fi; + sc->rec_fi6 = q_call(sc->rec_a6_o).fi; + return(opt_int_0); + }}}}}}}}} + rec_set_test(sc, cadr(code)); + rec_set_res(sc, cdadr(code)); { - /* (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) - syntax_error_nr (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), T_Lst (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); + s7_pointer p = caddr(code); + rec_set_f1(sc, p); + p = cdadr(p); /* not sc->rec_f1p = car(caddr(code)) */ + rec_set_f2(sc, p); + rec_set_f3(sc, cdr(p)); + rec_set_f4(sc, cdr(caller)); + p = rec_call_clause(caller); + rec_set_f5(sc, p); + rec_set_f6(sc, cdr(p)); } - sc->code= cons_unchecked ( - sc, sc->set_symbol, - cons (sc, set_ulist_1 (sc, sc->value, sc->args), - sc->code)); /* (let ((x 32)) (set! ((curlet) 'x) 3) x) */ - return (set_implicit (sc)); + sc->rec_loc = 0; + return(opt_ptr); } -/* -------------------------------- do -------------------------------- */ -static bool -safe_stepper_expr (s7_scheme* sc, s7_pointer expr, const 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) && - ((car (expr) != sc->set_symbol) || (!is_symbol (cadr (expr))))) - return (false); - } - else if (p == var) return (false); - return (true); +static s7_int oprec_i_cond_a_a_a_l2a_lopa_l2aq(s7_scheme *sc) +{ + s7_int i1, i2; + if (q_call(sc->rec_test_o).fb(sc->rec_test_o)) return(q_call(sc->rec_result_o).fi(sc->rec_result_o)); + if (q_call(sc->rec_a1_o).fb(sc->rec_a1_o)) + { + i1 = q_call(sc->rec_a2_o).fi(sc->rec_a2_o); + set_integer(sc->rec_val2, q_call(sc->rec_a3_o).fi(sc->rec_a3_o)); + set_integer(sc->rec_val1, i1); + return(oprec_i_cond_a_a_a_l2a_lopa_l2aq(sc)); + } + i1 = q_call(sc->rec_a4_o).fi(sc->rec_a4_o); + i2 = q_call(sc->rec_a5_o).fi(sc->rec_a5_o); + set_integer(sc->rec_val2, q_call(sc->rec_a6_o).fi(sc->rec_a6_o)); + set_integer(sc->rec_val1, i2); + set_integer(sc->rec_val2, oprec_i_cond_a_a_a_l2a_lopa_l2aq(sc)); + set_integer(sc->rec_val1, i1); + return(oprec_i_cond_a_a_a_l2a_lopa_l2aq(sc)); } -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 s7_int oprec_i_cond_a_a_a_l2a_lopa_l2aq_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); + set_integer(sc->rec_val2, sc->rec_fi3(sc->rec_a3_o)); + set_integer(sc->rec_val1, i1); + return(oprec_i_cond_a_a_a_l2a_lopa_l2aq_0(sc)); + } + i1 = sc->rec_fi4(sc->rec_a4_o); + i2 = sc->rec_fi5(sc->rec_a5_o); + set_integer(sc->rec_val2, sc->rec_fi6(sc->rec_a6_o)); + set_integer(sc->rec_val1, i2); + set_integer(sc->rec_val2, oprec_i_cond_a_a_a_l2a_lopa_l2aq_0(sc)); + set_integer(sc->rec_val1, i1); + return(oprec_i_cond_a_a_a_l2a_lopa_l2aq_0(sc)); } -#if DO_PRINT -#define all_ints_here(Sc, Settee, Expr, Step_vars) \ - all_ints_here_1 (Sc, Settee, Expr, Step_vars, __func__, __LINE__) -#define do_return_false(body) \ - do { \ - if (DO_PRINT) \ - fprintf (stderr, " %s[%d] from %s[%d]: %s\n", __func__, __LINE__, \ - funcly, linely, display (body)); \ - return (false); \ - } while (0) -static bool -all_ints_here_1 (s7_scheme* sc, s7_pointer settee, s7_pointer expr, - s7_pointer step_vars, const char* funcly, - int linely) /* see also all_integers above */ -#else -#define do_return_false(body) return (false) -static bool -all_ints_here (s7_scheme* sc, s7_pointer settee, s7_pointer expr, - s7_pointer step_vars) /* see also all_integers above */ -#endif +static s7_pointer oprec_cond_a_a_a_l2a_lopa_l2aq(s7_scheme *sc) { - /* since any type change causes false return, we can accept inits across - * step-vars */ - s7_pointer func, sig; - if (is_number (expr)) return (is_t_integer (expr)); - if (is_symbol (expr)) { - if (expr == settee) return (true); - for (s7_pointer step= step_vars; is_pair (step); step= cdr (step)) - if (caar (step) == expr) { - if (!all_ints_here (sc, caar (step), cadar (step), step_vars)) - do_return_false (expr); - if (is_pair (cddar (step))) - return (all_ints_here (sc, caar (step), caddar (step), step_vars)); - return (true); - } + 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) { - s7_pointer val= lookup_unexamined (sc, expr); - return ((val) && (is_t_integer (val))); + 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_l2a_lopa_l2aq(sc)); } - } - if (!is_pair (expr)) return (false); - if (!is_symbol (car (expr))) do_return_false (expr); - func= lookup_unexamined (sc, car (expr)); - if (!func) do_return_false (expr); - if ((is_int_vector (func)) || (is_byte_vector (func))) return (true); - - if (is_either_macro (func)) { - if (tree_memq_1 (sc, car (step_vars), expr)) do_return_false (expr); - if (tree_including_quote_memq (sc, car (step_vars), closure_body (func))) - do_return_false (expr); - return (true); - } - if (!is_any_c_function (func)) do_return_false (expr); - - if ((car (expr) == sc->vector_ref_symbol) && (is_pair (cdr (expr))) && - (is_symbol (cadr (expr)))) { - s7_pointer vec= lookup_unexamined (sc, cadr (expr)); - if ((vec) && ((is_int_vector (vec)) || (is_byte_vector (vec)))) - return (true); - } - sig= c_function_signature (func); -#if 0 - if ((is_pair(sig)) && - ((car(sig) == sc->is_integer_symbol) || (car(sig) == sc->is_byte_symbol))) -#else - /* tvect tshoot tbig */ - if ((is_pair (sig)) && ((car (sig) == sc->is_integer_symbol) || - (car (sig) == sc->is_byte_symbol) || - ((is_pair (car (sig))) && - ((direct_memq (sc->is_integer_symbol, car (sig))) || - (direct_memq (sc->is_byte_symbol, car (sig))))))) - /* maybe make int|byte_vector_ref|set explicit, or check indices=rank? - * or just use (func == sc->int_vector_ref) etc - */ -#endif - return (true); - if (!is_all_integer (car (expr))) do_return_false (expr); - for (s7_pointer p= cdr (expr); is_pair (p); p= cdr (p)) - if (!all_ints_here (sc, settee, car (p), step_vars)) do_return_false (expr); - return (true); + 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_l2a_lopa_l2aq(sc)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + return(oprec_cond_a_a_a_l2a_lopa_l2aq(sc)); } -#if DO_PRINT -#define do_is_safe(Sc, Body, Stepper, Var_list, Step_vars, Has_set) \ - do_is_safe_1 (Sc, Body, Stepper, Var_list, Step_vars, Has_set, __func__, \ - __LINE__) -static bool -do_is_safe_1 (s7_scheme* sc, s7_pointer body, s7_pointer stepper, - s7_pointer var_list, s7_pointer step_vars, bool* has_set, - const char* funcly, int linely) -#else -static bool -do_is_safe (s7_scheme* sc, s7_pointer body, s7_pointer stepper, - s7_pointer var_list, s7_pointer step_vars, bool* has_set) -#endif +static s7_pointer op_recur_cond_a_a_a_l2a_lopa_l2aq(s7_scheme *sc, s7_pointer code) { - /* 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 - */ - const s7_pointer code= - sc->code; /* only used once, but I worry about sc->code changing */ - for (s7_pointer exprs= body; is_pair (exprs); exprs= cdr (exprs)) { - const s7_pointer expr= car (exprs); - if (is_pair (expr)) { - const s7_pointer head= car (expr); - /* this used to be if (is_pair(head)) continue; */ - if ((!is_symbol (head)) && (!is_safe_c_function (head)) && - (head != sc->quote_function) && (!is_pair (head))) - do_return_false (expr); - /* car(expr) ("head") 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 - */ - if (is_symbol_and_syntactic (head)) { - const opcode_t op= syntax_opcode (global_value (head)); - switch (op) { - case OP_MACROEXPAND: - do_return_false (expr); - - case OP_QUOTE: - if ((!is_pair (cdr (expr))) || - (!is_null (cddr (expr)))) /* (quote . 1) or (quote 1 2) etc */ - do_return_false (expr); - break; - - case OP_LET: - case OP_LET_STAR: - case OP_LETREC: - case OP_LETREC_STAR: { - s7_pointer cp; - if ((!is_pair (cdr (expr))) || (!is_list (cadr (expr))) || - (!is_pair (cddr (expr)))) - do_return_false (expr); - cp= var_list; - begin_temp (sc->y, sc->nil); - for (s7_pointer vars= cadr (expr); is_pair (vars); vars= cdr (vars)) { - s7_pointer var; - if (!is_pair (car (vars))) { - end_temp (sc->y); - do_return_false (expr); - } - var= caar (vars); - if (direct_memq (var, ((op == OP_LET) || (op == OP_LETREC)) - ? cp - : var_list)) { - end_temp (sc->y); - do_return_false (expr); - } - if ((!is_symbol (var)) || (is_keyword (var))) { - end_temp (sc->y); - do_return_false (expr); - } - cp = cons (sc, var, cp); - sc->y= cp; - } - end_temp (sc->y); - if (!do_is_safe (sc, cddr (expr), stepper, cp, step_vars, has_set)) - do_return_false (expr); - } break; - - case OP_DO: { - s7_pointer combined_vars, cp; - if ((!is_pair (cdr (expr))) || - (!is_pair (cddr (expr)))) /* (do) or (do (...)) */ - do_return_false (expr); - cp = var_list; - sc->temp5 = cp; /* this can be stepped on -- t101-12..16 */ - combined_vars= (is_pair (cadr (expr))) - ? pair_append (sc, cadr (expr), step_vars) - : step_vars; - sc->w = combined_vars; - for (s7_pointer vars= cadr (expr); is_pair (vars); vars= cdr (vars)) { - s7_pointer var; - if (!is_pair (car (vars))) { - end_temp (sc->w); - end_temp (sc->temp5); - do_return_false (expr); - } - var= caar (vars); - if ((direct_memq (var, cp)) || (var == stepper)) { - end_temp (sc->w); - end_temp (sc->temp5); - do_return_false (expr); - } - cp = cons (sc, var, cp); - sc->temp5= cp; - if ((is_pair (cdar (vars))) && - (!do_is_safe (sc, cdar (vars), stepper, cp, combined_vars, - has_set))) { - end_temp (sc->temp5); - end_temp (sc->w); - do_return_false (expr); - } - } - end_temp (sc->temp5); - end_temp (sc->w); -#if 0 - if (!do_is_safe(sc, cddr(expr), stepper, cp, combined_vars, has_set)) - do_return_false(expr); -#endif - if ((is_pair (cdddr (expr))) && - (!do_is_safe (sc, cdddr (expr), stepper, cp, combined_vars, - has_set))) - do_return_false (expr); - } break; - - case OP_SET: { - s7_pointer settee; - if ((!is_pair (cdr (expr))) || - (!is_pair (cddr (expr)))) /* (set!) or (set! x) */ - do_return_false (expr); - settee= cadr (expr); - if (!is_symbol (settee)) /* (set! (...) ...) which is tricky due to - setter functions/macros */ - { - if ((!is_pair (settee)) || (!is_symbol (car (settee)))) - do_return_false (expr); - if (!direct_memq (car (settee), var_list)) /* is it a local var */ - { - const s7_pointer setv= lookup_unexamined (sc, car (settee)); - if (!((setv) && - ((is_sequence (setv)) || - ((is_c_function (setv)) && - (is_safe_procedure (c_function_setter (setv))))))) - do_return_false (expr); - /* if ((has_set) && (!is_sequence(setv))) (*has_set) = true; */ - /* ^ trouble in tmock.scm (opt2_fn not set) -- apparently - * op_simple_do assumes has_fn which set! lacks */ - } - if (has_set) (*has_set)= true; - } - else { - const s7_pointer end_and_result= caddr (code); /* sc->code */ - /* I think this is trying to catch (set! end i) [do-test-20 s7test] - * etc and needs the end-and-result form to check that */ -#if 1 - if ((is_pair (end_and_result)) && - (is_pair (car (end_and_result))) && - (!is_syntax (caar (end_and_result)))) /* 10-Jan-24 but why? */ - { - bool result; - set_match_symbol (settee); - result= tree_match ( - car (end_and_result)); /* (set! end ...) in some fashion */ - clear_match_symbol (settee); - if (result) { - if (DO_PRINT) - fprintf (stderr, "%s[%d]: %s in %s\n", __func__, __LINE__, - display (settee), - display_truncated (end_and_result)); - do_return_false (expr); - } - } -#endif - if (!direct_memq (settee, - var_list)) /* is some local variable being set? */ - { - const s7_pointer val= lookup_unexamined (sc, settee); - if (has_set) (*has_set)= true; - if ((val) && (is_t_integer (val)) && - (!all_ints_here (sc, settee, caddr (expr), step_vars))) { - if (DO_PRINT) - fprintf (stderr, - "%s[%d]: %s (%s) not all_ints_here in %s with %s\n", - __func__, __LINE__, display (settee), display (val), - display_truncated (caddr (expr)), - display (step_vars)); - do_return_false (expr); - } - } - } - if (!do_is_safe (sc, cddr (expr), stepper, var_list, step_vars, - has_set)) { - if (DO_PRINT) - fprintf (stderr, "%s[%d]: !do_is_safe %s %s %s %s\n", __func__, - __LINE__, display (expr), display (stepper), - display (var_list), display (step_vars)); - do_return_false (expr); - } - if (!safe_stepper_expr (sc, expr, - stepper)) /* is step var's value used as the - stored value by set!? */ - { /* but this is safe if (set! loc i) where i is int because it checks - and copies */ - if (DO_PRINT) - fprintf (stderr, " %s%s[%d]: !safe_stepper_expr %s with %s%s\n", - bold_text, __func__, __LINE__, display (expr), - display (stepper), unbold_text); - do_return_false (expr); - } - } break; - - case OP_LET_TEMPORARILY: - if ((!is_pair (cdr (expr))) || (!is_pair (cadr (expr))) || - (!is_pair (cddr (expr)))) - do_return_false (expr); - for (s7_pointer 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, step_vars, - has_set))) - do_return_false (expr); - if (!do_is_safe (sc, cddr (expr), stepper, var_list, step_vars, - has_set)) - do_return_false (expr); - break; - - case OP_COND: - for (s7_pointer cp= cdr (expr); is_pair (cp); cp= cdr (cp)) - if (!do_is_safe (sc, car (cp), stepper, var_list, step_vars, - has_set)) - do_return_false (expr); - break; - - case OP_CASE: - if ((!is_pair (cdr (expr))) || - (!do_is_safe (sc, cadr (expr), stepper, var_list, step_vars, - has_set))) - do_return_false (expr); - for (s7_pointer 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, step_vars, - has_set))) - do_return_false (expr); - 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, step_vars, - has_set)) - do_return_false (expr); - break; - - case OP_WITH_LET: - do_return_false (expr); /* 11-Jan-24, this was true!? */ - - default: - do_return_false (expr); - } - } /* is_syntax(head=car(expr)) */ - else if (head == sc->quote_function) { - if ((!is_pair (cdr (expr))) || - (!is_null (cddr (expr)))) /* (#_quote . 1) or (#_quote 1 2) etc */ - do_return_false (expr); - } - else { - if ((is_pair (expr)) && (is_pair (cdr (expr)))) { - if ((is_saver (head)) && - (direct_translucent_member (stepper, cdr (expr)))) - do_return_false (expr); - if (is_setter (head)) /* tree_inspect_stepper in tmp? */ - { - s7_pointer arg; - for (arg= cdr (expr); is_pair (cdr (arg)); arg= cdr (arg)) - ; - if ((car (arg) == stepper) || - ((is_pair (car (arg))) && - (((is_saver (caar (arg))) && - (direct_memq (stepper, cdar (arg)))) || - ((is_translucent (caar (arg))) && (is_pair (cdar (arg))) && - (cadar (arg) == stepper))))) /* is_pair for (write) etc */ - do_return_false (expr); - } - } - - if ((is_pair (expr)) && (is_pair (cdr (expr))) && (is_symbol (head)) && - (!initial_value_is_defined (sc, head)) && - (direct_memq (stepper, cdr (expr)))) { - const s7_pointer slot= s7_slot (sc, head); - if ((!is_slot (slot)) || - (!is_applicable (slot_value (slot)))) /* expr: '(=> () ...) */ - do_return_false (expr); - if ((is_saver (slot_value ( - slot))) && /* || (is_translucent(slot_value(slot)))) && */ - (direct_translucent_member (stepper, cdr (expr)))) - do_return_false (expr); - } - - { /* if a macro check both expr and the macro body for the stepper */ - const s7_pointer val= - (is_symbol (head)) - ? lookup_unexamined (sc, head) - : head; /* head is car(expr) 200 lines back (!) */ - if ((val) && (is_either_macro (val)) && (!is_setter (val))) { - if (tree_memq_1 (sc, stepper, expr)) do_return_false (expr); - if (tree_including_quote_memq (sc, stepper, closure_body (val))) - do_return_false (expr); - return (true); - } - } + opt_pid_t choice = opinit_cond_a_a_a_l2a_lopa_l2aq(sc, code); + tick_tc(sc, OP_RECUR_COND_A_A_A_L2A_LopA_L2Aq); + if (choice != opt_ptr) + return(make_integer(sc, (choice == opt_int) ? oprec_i_cond_a_a_a_l2a_lopa_l2aq(sc) : oprec_i_cond_a_a_a_l2a_lopa_l2aq_0(sc))); + return(oprec_cond_a_a_a_l2a_lopa_l2aq(sc)); +} - if (!is_optimized (expr)) do_return_false (expr); - if (optimize_op (expr) == OP_UNKNOWN_NP) /* tmac, (mx 1 (3 4 5)) */ - do_return_false (expr); - if (!do_is_safe (sc, cdr (expr), stepper, var_list, step_vars, has_set)) - do_return_false (expr); - - if (is_setter (head)) { - /* (hash-table-set! ht i 0): caddr is being saved, so this is not - * safe; similarly (vector-set! v 0 i) etc */ - 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))) || - ((head == sc->hash_table_set_symbol) && - (caddr (expr) == stepper)) || - (cadddr (expr) == stepper) || /* used to check is_symbol here and - above but that's unnecessary */ - ((is_pair (cadddr (expr))) && - (s7_tree_memq (sc, stepper, cadddr (expr)))))) - (*has_set)= true; - /* and also set stepper unsafe? and also any other steppers */ - /* need a way to lock unsafe_stepper -- maybe set safe, clear here, do - * not set elsewhere */ - - if (!do_is_safe (sc, cddr (expr), stepper, var_list, step_vars, - has_set)) - do_return_false (expr); - if (!safe_stepper_expr (sc, expr, stepper)) do_return_false (expr); - } - } - } - } - return (true); -} - -static bool -preserves_type (s7_scheme* sc, uint32_t ctype) { - return ((ctype == sc->add_class) || (ctype == sc->subtract_class) || - (ctype == sc->multiply_class)); -} - -static s7_pointer -simple_stepper (s7_scheme* sc, s7_pointer var) { - if ((is_proper_list_3 (sc, var)) && (is_fxable (sc, cadr (var)))) { - const s7_pointer step_expr= caddr (var); - if ((is_optimized (step_expr)) && - (((optimize_op (step_expr) == HOP_SAFE_C_SC) && - (car (var) == cadr (step_expr))) || - ((is_h_safe_c_nc (step_expr)) && /* replace with is_fxable? */ - (is_pair (cdr (step_expr))) && /* ((v 0 (+))) */ - (car (var) == 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 (var) == 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) { - const s7_pointer vars = car (code); - const s7_pointer pre_var_list= cons (sc, sc->nil, sc->nil); - gc_protect_via_stack (sc, pre_var_list); - - /* clear_big_symbol_set(sc); */ /* an experiment -- slightly slower than - pre_var_list? */ - for (s7_pointer p= vars, var_list= NULL; is_pair (p); p= cdr (p)) { - s7_function callee= NULL; - s7_pointer expr = cdar (p); /* init */ - /* add_symbol_to_big_symbol_set(sc, caar(p)); */ - 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= cdr (expr); /* cddar(p): step */ - if (is_pair (expr)) { - if ((is_pair (car (expr))) && (!is_checked (car (expr)))) { - if (!var_list) { - begin_temp (sc->y, sc->nil); - for (var_list= vars; is_pair (var_list); var_list= cdr (var_list)) - sc->y= cons (sc, caar (var_list), sc->y); - var_list= sc->y; /* only valid in step exprs, not in inits; also all - vars are valid at any point in step exprs */ - end_temp (sc->y); - set_cdr (pre_var_list, - var_list); /* we'll put each current var at top of this list - to speed up the most likely search - (arg_findable -> pair_symbol_is_safe) */ - } - set_car (pre_var_list, caar (p)); /* caar(p) == current var, highly - likely it's in the step expr */ - optimize_expression (sc, car (expr), 0, pre_var_list, false); - } - callee= fx_choose (sc, expr, vars, - do_symbol_is_safe); /* fx_proc can be nil! */ - if (callee) set_fx (expr, callee); +/* -------- and_a_or_a_l2a_l2a -------- */ +static void opinit_and_a_or_a_l2a_l2a(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer orp = cdr(rec_call_clause(code)); + tick_tc(sc, OP_RECUR_AND_A_OR_A_L2A_L2A); + 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); + sc->rec_loc = 0; +} + +static s7_pointer oprec_and_a_or_a_l2a_l2a(s7_scheme *sc) +{ + s7_pointer result; + if (sc->rec_testf(sc, sc->rec_testp) == sc->F) return(sc->F); + result = sc->rec_resf(sc, sc->rec_resp); + if (result != sc->F) return(result); + 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)); + result = oprec_and_a_or_a_l2a_l2a(sc); + if (result != sc->F) + { + sc->rec_loc -= 2; + return(result); } - } - unstack_gc_protect (sc); - /* clear_big_symbol_set(sc); */ - - if ((is_pair (cdr (code))) && (is_pair (cadr (code)))) { - s7_pointer 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)); - } - if (DO_PRINT) - fprintf (stderr, " op: %s\n", op_names[optimize_op (sc->code)]); - return (code); + slot_set_value(sc->rec_slot2, recur_pop(sc)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + recur_push_unchecked(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_l2a_l2a(sc)); } -static bool -do_vector_has_definer (s7_pointer vec) { - s7_pointer* els= vector_elements (vec); - for (s7_int i= 0, len= vector_length (vec); 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 s7_pointer op_recur_and_a_or_a_l2a_l2a(s7_scheme *sc, s7_pointer code) +{ + opinit_and_a_or_a_l2a_l2a(sc, code); + return(oprec_and_a_or_a_l2a_l2a(sc)); } -#if CYCLE_DEBUGGING -static char *base= NULL, *min_char= NULL; -#endif -static /* inline */ bool -do_tree_has_definer (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? - */ -#if CYCLE_DEBUGGING - char x; - if (!base) base= &x; - else { - if (&x > base) base= &x; - else { - if ((!min_char) || (&x < min_char)) { - min_char= &x; - if ((base - min_char) > 10000) { - fprintf (stderr, "infinite recursion? %s\n", display (tree)); - abort (); - } - } - } - } -#endif - s7_int i= 0; - for (s7_pointer p= tree; is_pair (p); p= cdr (p), i++) { - s7_pointer pp= car (p); - if (is_symbol (pp)) { - if (is_definer (pp)) { - if (pp == sc->apply_symbol) { - s7_pointer val; - if ((!is_pair (cdr (p))) || (!is_symbol (cadr (p)))) return (true); - val= lookup_unexamined (sc, cadr (p)); - if ((!val) || (!is_c_function (val))) return (true); - } - else return (true); - } - } - else if (is_pair (pp)) { - if (do_tree_has_definer (sc, pp)) return (true); - } - else if ((is_applicable (pp)) && - (((is_t_vector (pp)) && (do_vector_has_definer (pp))) || - ((is_c_function (pp)) && (is_func_definer (pp))) || - ((is_syntax (pp)) && (is_syntax_definer (pp))))) - return (true); - } - return (false); +/* -------------------------------- */ +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 -check_do_for_obvious_errors (s7_scheme* sc, s7_pointer form) { - const s7_pointer code= cdr (form); +static void op_safe_c_p_1(s7_scheme *sc) {sc->value = fn_proc(sc->code)(sc, with_list_t1(sc, sc->value));} - if ((!is_pair (code)) || /* (do . 1) */ - ((!is_pair (car (code))) && /* (do 123) */ - (is_not_null (car (code))))) /* (do () ...) is ok */ - syntax_error_nr (sc, "do: variable list is not a list: ~S", 35, form); +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); +} - if (!is_pair (cdr (code))) /* (do () . 1) */ - syntax_error_nr (sc, "do body is messed up: ~A", 24, form); +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); +} - if ((!is_pair (cadr (code))) && /* (do ((i 0)) 123) */ - (is_not_null (cadr (code)))) /* no end-test? */ - syntax_error_nr (sc, "do: end-test and end-value list is not a list: ~A", - 49, form); +static void op_s(s7_scheme *sc) +{ + sc->code = lookup(sc, car(sc->code)); + if (!is_applicable(sc->code)) + apply_error_nr(sc, sc->code, sc->nil); + sc->args = sc->nil; /* op_s -> apply, so we'll apply sc->code to sc->args */ +} - if (is_pair (car (code))) { - s7_pointer vars; - begin_small_symbol_set (sc); - for (vars= car (code); is_pair (vars); vars= cdr (vars)) { - const s7_pointer var= car (vars); - if (!is_pair (var)) /* (do (4) (= 3)) */ - syntax_error_nr (sc, "do: variable name missing? ~A", 29, form); - - if (!is_symbol (car (var))) /* (do ((3 2)) ()) */ - syntax_error_nr (sc, "do step variable: ~S is not a symbol?", 37, var); - - if (is_constant_symbol ( - sc, car (var))) /* (do ((pi 3 (+ pi 1))) ((= pi 4)) pi) */ - syntax_error_nr (sc, "do step variable: ~S is immutable", 33, var); - - if (!is_pair (cdr (var))) - syntax_error_nr (sc, "do: step variable has no initial value: ~A", 42, - vars); - if (!is_pair (cddr (var))) { - if (is_not_null (cddr (var))) /* (do ((i 0 . 1)) ...) */ - syntax_error_nr ( - sc, "do: step variable info is an improper list?: ~A", 47, vars); - } - else if (is_not_null (cdddr (var))) /* (do ((i 0 1 (+ i 1))) ...) */ - syntax_error_nr ( - sc, - "do: step variable info has extra stuff after the increment: ~A", - 62, vars); - set_local (car (var)); - - if (symbol_is_in_small_symbol_set ( - sc, car (var))) /* (do ((i 0 (+ i 1)) (i 2))...) */ - syntax_error_nr (sc, "duplicate identifier in do: ~A", 30, vars); - add_symbol_to_small_symbol_set (sc, car (var)); - } - if (is_not_null (vars)) /* (do ((i 0 i) . 1) ((= i 1))) */ - syntax_error_nr (sc, "do: list of variables is improper: ~A", 37, form); - end_small_symbol_set (sc); - } - if (is_pair (cadr (code))) { - s7_pointer p; - for (p= cadr (code); is_pair (p); p= cdr (p)) - ; - if (is_not_null (p)) /* (do ((i 0 (+ i 1))) ((= i 2) . 3) */ - syntax_error_nr (sc, "stray dot in do end section? ~A", 31, form); - } - { - s7_pointer p; - for (p= cddr (code); is_pair (p); p= cdr (p)) - ; /* body */ - if (is_not_null (p)) - syntax_error_nr (sc, "stray dot in do body? ~A", 24, form); - } +static bool op_s_g(s7_scheme *sc) +{ + const s7_pointer code = sc->code; + sc->code = lookup_checked(sc, car(code)); + if ((is_c_function(sc->code)) && + (c_function_min_args(sc->code) == 1) && + (!needs_copied_args(sc->code))) + { + sc->value = c_function_call(sc->code)(sc, with_list_t1(sc, (is_symbol(cadr(code))) ? lookup_checked(sc, cadr(code)) : cadr(code))); + return(true); /* continue */ + } + if (!is_applicable(sc->code)) + apply_error_nr(sc, sc->code, cdr(code)); + if (dont_eval_args(sc->code)) + sc->args = cdr(code); + else + { + const s7_pointer val = (is_symbol(cadr(code))) ? lookup_checked(sc, cadr(code)) : cadr(code); + sc->args = (needs_copied_args(sc->code)) ? list_1(sc, val) : set_plist_1(sc, val); + } + return(false); } -static s7_pointer -do_end_bad (s7_scheme* sc, s7_pointer form) { - const s7_pointer code= cdr (form); - if (is_null (cddr (code))) { - /* no body, end not fxable (if eval car(end) might be unopt) */ - for (s7_pointer vars= car (code); is_pair (vars); - vars = cdr (vars)) /* gather var names */ - { - s7_pointer var= car (vars); - 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 (s7_pointer vars= car (code); is_pair (vars); - vars= cdr (vars)) /* look for stuff like (do ((i 0 j) (j 0 (+ j 1))) - ((= j 3) i)) */ - { - s7_pointer var= car (vars); - s7_pointer val= cddr (var); - if (is_pair (val)) { - clear_match_symbol (car (var)); /* ignore current var */ - if (tree_match (car (val))) { - for (s7_pointer q= car (code); is_pair (q); q= cdr (q)) - clear_match_symbol (caar (q)); - if (DO_PRINT) - fprintf (stderr, " %s[%d]: bad stepper %s\n", __func__, __LINE__, - display (code)); - return (code); - } - } - set_match_symbol (car (var)); +static bool op_x_a(s7_scheme *sc, s7_pointer func) +{ + if ((((type(func) == T_C_FUNCTION) && (c_function_is_aritable(func, 1))) || + ((type(func) == T_C_RST_NO_REQ_FUNCTION) && (!has_even_args(func)))) && + (!needs_copied_args(func))) + { + sc->value = c_function_call(func)(sc, with_list_t1(sc, fx_call(sc, cdr(sc->code)))); + return(true); } + if (is_any_vector(func)) { - s7_pointer vars; - for (vars= car (code); is_pair (vars); - vars= cdr (vars)) /* clear var names */ - clear_match_symbol (caar (vars)); - if (is_null (vars)) { - if ((is_null (cadr (code))) && /* (do () ()) or (do (fxable vars) ()) */ - (is_null (cddr (code)))) { - if (sc->safety > no_safety) - s7_warn (sc, 256, "%s: infinite do loop: %s\n", __func__, - display (form)); - if (DO_PRINT) - fprintf (stderr, " %s[%d]: infinite loop %s\n", __func__, __LINE__, - display (form)); - return (code); - } - fxify_step_exprs (sc, code); - for (s7_pointer vars1= car (code); is_pair (vars1); - vars1 = cdr (vars1)) { - s7_pointer var= car (vars1); - if ((!has_fx (cdr (var))) || - ((is_pair (cddr (var))) && (!has_fx (cddr (var))))) { - if (DO_PRINT) - fprintf (stderr, " %s[%d]: bad stepper %s\n", __func__, __LINE__, - display (code)); - return (code); - } - } - pair_set_syntax_op (form, OP_DO_NO_BODY_NA_VARS); - if (DO_PRINT) - fprintf (stderr, " %s[%d]: ok %s %s\n", __func__, __LINE__, - display (form), op_names[optimize_op (form)]); - return (sc->nil); + sc->args = set_plist_1(sc, fx_call(sc, cdr(sc->code))); + sc->code = func; + apply_vector(sc); + return(true); + } + if (!is_applicable(func)) + apply_error_nr(sc, func, cdr(sc->code)); + if (dont_eval_args(func)) + sc->args = cdr(sc->code); /* list_1(sc, cadr(sc->code)); */ + else + if (!needs_copied_args(func)) + sc->args = set_plist_1(sc, fx_call(sc, cdr(sc->code))); + else + { + sc->args = fx_call(sc, cdr(sc->code)); + sc->args = list_1(sc, sc->args); } + sc->code = func; + return(false); /* goto APPLY */ +} + +static bool op_x_sc(s7_scheme *sc, s7_pointer func) +{ + const s7_pointer code = sc->code; + if (((type(func) == T_C_FUNCTION) && (c_function_is_aritable(func, 2))) || + (type(func) == T_C_RST_NO_REQ_FUNCTION)) /* ((L 'abs) x 0.0001) where 'abs is '* in timp.scm */ + { + if (!needs_copied_args(func)) + { + sc->value = c_function_call(func)(sc, set_plist_2(sc, lookup_checked(sc, cadr(code)), caddr(code))); + return(true); + } + sc->args = list_2(sc, lookup_checked(sc, cadr(code)), caddr(code)); + sc->value = c_function_call(func)(sc, sc->args); + return(true); + } + if (!is_applicable(func)) + apply_error_nr(sc, func, cdr(code)); + if (dont_eval_args(func)) + sc->args = list_2(sc, cadr(code), caddr(code)); + else + if (!needs_copied_args(func)) + sc->args = set_plist_2(sc, lookup_checked(sc, cadr(code)), caddr(code)); + else sc->args = list_2(sc, lookup_checked(sc, cadr(code)), caddr(code)); + sc->code = func; + return(false); /* goto APPLY */ +} + +static bool op_x_aa(s7_scheme *sc, s7_pointer func) +{ + const s7_pointer code = sc->code; + if (((type(func) == T_C_FUNCTION) && (c_function_is_aritable(func, 2))) || + (type(func) == T_C_RST_NO_REQ_FUNCTION)) + { + if (!needs_copied_args(func)) + { + set_car(sc->elist_7, fx_call(sc, cdr(code))); /* heh heh... (I'm going to regret this someday) */ + sc->value = fx_call(sc, cddr(code)); + sc->value = c_function_call(func)(sc, with_list_t2(sc, car(sc->elist_7), sc->value)); + set_car(sc->elist_7, sc->F); + return(true); + } + sc->args = fx_call(sc, cddr(code)); + sc->args = list_2(sc, sc->value = fx_call(sc, cdr(code)), sc->args); + sc->value = c_function_call(func)(sc, sc->args); + return(true); + } + if (!is_applicable(func)) + apply_error_nr(sc, func, cdr(code)); + if (dont_eval_args(func)) + sc->args = list_2(sc, cadr(code), caddr(code)); + else + { + sc->args = fx_call(sc, cddr(code)); + if (!needs_copied_args(func)) + sc->args = set_plist_2(sc, fx_call(sc, cdr(code)), sc->args); + else sc->args = list_2(sc, sc->value = fx_call(sc, cdr(code)), sc->args); } - } - return (fxify_step_exprs (sc, code)); + sc->code = func; + return(false); /* goto APPLY */ } -static s7_pointer -check_do (s7_scheme* sc) { - /* returns nil if optimizable, code if not(?) */ - const s7_pointer form= sc->code; - s7_pointer body, end, vars, code; - - check_do_for_obvious_errors (sc, form); - pair_set_syntax_op (form, OP_DO_UNCHECKED); - code= cdr (form); /* ok here, since check_do_for_obvious_errors will call - error_nr otherwise */ - end= cadr (code); - - if ((!is_pair (end)) || (!is_fxable (sc, car (end)))) { - if (DO_PRINT) - fprintf (stderr, "%s[%d]: return do_end_bad for %s\n", __func__, __LINE__, - display (form)); - return (do_end_bad (sc, form)); /* can return code (not sc->nil) */ - } - /* sc->curlet is the outer environment, local vars are in the big_symbol_set - * via check_do_for_obvious_errors(???), and it's only needed for fx_unsafe_s +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. */ - 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); - if (is_fx_treeable (end)) { - if ((is_pair (car (end))) && /* this code is repeated below */ - (has_fx (end)) && (!is_syntax (caar (end))) && - (!((is_symbol (caar (end))) && - (is_definer_or_binder (caar (end)))))) { - s7_pointer v1= NULL, v2= NULL, v3= NULL; - bool more_vs= false; - if (curlet_has_slots (sc)) /* outer vars */ - { - s7_pointer slot= let_slots (sc->curlet); - v1 = slot_symbol (slot); - slot = next_slot (slot); - if (is_not_slot_end (slot)) { - v2 = slot_symbol (slot); - slot= next_slot (slot); - if (is_not_slot_end (slot)) { - v3 = slot_symbol (slot); - more_vs= is_not_slot_end (next_slot (slot)); - } - } - } - if (v1) fx_tree_outer (sc, end, v1, v2, v3, more_vs); - } + if (dont_eval_args(sc->value)) + sc->args = cdr(sc->code); + else + { + sc->args = lookup_checked(sc, cadr(sc->code)); + sc->args = (needs_copied_args(sc->value)) ? list_1(sc, sc->args) : set_plist_1(sc, sc->args); } - if (DO_PRINT) - fprintf (stderr, "%s[%d]: optimizable %s\n", __func__, __LINE__, - display (form)); - return (sc->nil); - } - - if ((sc->safety > no_safety) && (tree_is_cyclic (sc, form))) { - if (DO_PRINT) - fprintf (stderr, "%s[%d]: bad: cyclic for %s\n", __func__, __LINE__, - display (form)); - return (form); - } - if (do_tree_has_definer ( - sc, form)) /* we don't want definers in body, vars, or end test */ - { - if (DO_PRINT) - fprintf (stderr, "%s[%d]: return fxify_step_exprs for %s\n", __func__, - __LINE__, display (form)); - return (fxify_step_exprs (sc, code)); - } + sc->code = sc->value; /* goto APPLY */ +} - body= cddr (code); - if ((is_pair (end)) && (is_pair (car (end))) && /* end test is a pair */ - (is_pair (vars)) && (is_null (cdr (vars))) && /* one stepper */ - (is_pair (body)) && (is_pair (car (body))) && /* body is normal-looking */ - ((is_symbol (caar (body))) || (is_safe_c_function (caar (body))))) { - /* loop has one step variable, and normal-looking end test */ - const s7_pointer var= car (vars); - s7_pointer step_expr; - - fx_tree (sc, end, car (var), NULL, NULL, false); - if (is_fx_treeable (body)) /* this is thwarted by gotos */ - fx_tree (sc, body, car (var), NULL, NULL, false); - - step_expr= simple_stepper (sc, var); - if (step_expr) { - const s7_pointer orig_end= end; - set_fx ( - cdr (var), - fx_choose (sc, cdr (var), 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 (var) == 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; - const bool 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_class_and_fn_proc (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(var) == - cadr(step_expr)) and (car(var) == 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_clamped_if_gmp (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 (var), sc->nil, vars, &has_set))) { - const opcode_t op= optimize_op (car (body)); - pair_set_syntax_op ( - form, OP_SAFE_DO); /* safe_do: body is safe, step by 1 */ - /* no semipermanent let here because apparently do_is_safe accepts - * recursive calls? */ - - /* this code sets the hop bit in any outer safe function call. I - * tried a procedure (leaf_hopper in tmp) that walked the body - * setting all the hop bits; this worked in all tests, but cost as - * much as it saved. this was in the inner block below originally. - */ - if ((is_optimized (car (body))) && - ((is_safe_c_op (op)) || (is_safe_closure_op (op)) || - (is_safe_closure_star_op (op))) && - (!op_has_hop (car (body)))) - set_optimize_op (car (body), - op + 1); /* set hop bit if it's a safe_closure - call in a safe do loop */ - - if ((!has_set) && - (c_function_class (opt1_cfunc (end)) == sc->num_eq_class)) { - /* vars is of the form ((i 0 (+ i 1))) -- 1 var etc */ - pair_set_syntax_op (form, - OP_SAFE_DOTIMES); /* safe_dotimes: end is = */ - if (is_fxable (sc, car (body))) - fx_annotate_arg ( - sc, body, - set_plist_1 ( - sc, caar (vars))); /* if _args, fxification ignored? - (need safe_closure_s_na etc) */ - /* is this redundant? safe_closure_s_a must already have fx, and - * otherwise it is ignored */ - } - fx_tree (sc, body, car (var), NULL, NULL, false); - if (stack_top_op (sc) == OP_SAFE_DO_STEP) - fx_tree_outer (sc, body, caaar (stack_top_code (sc)), NULL, NULL, - true); - } - } - if (DO_PRINT) - fprintf (stderr, "%s[%d]: optimizable %s\n", __func__, __LINE__, - display (form)); - return (sc->nil); - } - } - } +static void op_safe_c_star_na(s7_scheme *sc) +{ + sc->args = safe_list_if_possible(sc, opt3_arglen(cdr(sc->code))); + for (s7_pointer 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); + if (!in_heap(sc->args)) clear_safe_list_in_use(sc, sc->args); +} - /* we get here if there is more than one local var or anything "non-simple" - * about the rest */ - for (s7_pointer p= vars; is_pair (p); p= cdr (p)) { - const 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))))) { - for (s7_pointer q= vars; q != p; q= cdr (q)) - clear_match_symbol (caar (q)); - if (DO_PRINT) - fprintf (stderr, "%s[%d]: return fxify_step_exprs for %s\n", __func__, - __LINE__, display (form)); - 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)); - } +static void op_safe_c_star(s7_scheme *sc) +{ + sc->code = opt1_cfunc(sc->code); + apply_c_function_star_fill_defaults(sc, 0); +} - { - s7_pointer stepper0= NULL, stepper1= NULL, stepper2= NULL, stepper3= NULL; - bool got_pending= false, outer_shadowed= false; - - for (s7_pointer p= vars; is_pair (p); p= cdr (p)) { - s7_pointer var= car (p); - const s7_pointer val= cddr (var); - stepper3 = stepper2; - stepper2 = stepper1; - stepper1 = stepper0; - stepper0 = car (var); - if (is_pair (val)) { - var= car (var); - clear_match_symbol (var); /* ignore current var */ - if (tree_match (car (val))) { - for (s7_pointer q= vars; is_pair (q); q= cdr (q)) - clear_match_symbol (caar (q)); - if (is_null (body)) got_pending= true; - else { - if (DO_PRINT) - fprintf (stderr, "%s[%d]: return fxify_step_exprs for %s\n", - __func__, __LINE__, display (form)); - return (fxify_step_exprs (sc, code)); - } - } - set_match_symbol (var); - } - } +static void op_safe_c_star_a(s7_scheme *sc) +{ + sc->args = fx_call(sc, cdr(sc->code)); + if (is_symbol_and_keyword(sc->args)) /* (blocks3 (car (list :asdf))) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "~A: keyword ~S, but no value: ~S", 32), car(sc->code), sc->args, sc->code)); + /* scheme-level define* here also gives "not a parameter name" */ + sc->args = list_1(sc, sc->args); + sc->code = opt1_cfunc(sc->code); + /* one arg, so it's not a keyword; all we need to do is fill in the defaults */ + apply_c_function_star_fill_defaults(sc, 1); +} - for (s7_pointer p= vars; is_pair (p); p= cdr (p)) - set_match_symbol (caar (p)); - for (s7_pointer slot= let_slots (sc->curlet); is_not_slot_end (slot); - slot = next_slot (slot)) - if (is_matched_symbol (slot_symbol (slot))) { - outer_shadowed= true; - break; - } - for (s7_pointer p= vars; is_pair (p); p= cdr (p)) - clear_match_symbol (caar (p)); +static void op_safe_c_star_aa(s7_scheme *sc) +{ + sc->args = fx_call(sc, cdr(sc->code)); + set_car(sc->t2_2, fx_call(sc, cddr(sc->code))); + set_car(sc->t2_1, sc->args); + sc->args = sc->t2_1; + sc->code = opt1_cfunc(sc->code); + apply_c_function_star(sc); +} - /* end and steps look ok! */ - for (s7_pointer p= vars; is_pair (p); p= cdr (p)) { - const 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))) { - const 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 { - const s7_pointer endp= car (end); - const s7_pointer var1= car (var); - if ((!is_quote (sc, - car (step_expr))) && /* 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)); - - 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_loop_end_possible (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)))) { - const s7_pointer var = caar (vars); - s7_pointer step= cddar (vars); - set_opt3_any (code, (in_heap (code)) ? sc->F - : make_semipermanent_let (sc, vars)); - if (!got_pending) pair_set_syntax_op (form, OP_DOX_NO_BODY); - 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 (code, int_one); - else if ((car (step) == sc->subtract_symbol) && - (cadr (step) == var) && (caddr (step) == int_one)) - set_opt2_con (code, minus_one); - else set_opt2_con (code, int_zero); - } - else set_opt2_con (code, int_zero); - } - else set_opt2_con (code, int_zero); - } - if (do_passes_safety_check (sc, body, sc->nil, vars, NULL)) { - s7_pointer var1= NULL, var2= NULL, var3= NULL; - bool more_vars= false; - if (curlet_has_slots (sc)) /* outer vars */ - { - s7_pointer slot= let_slots (sc->curlet); - var1 = slot_symbol (slot); - slot = next_slot (slot); - if (is_not_slot_end (slot)) { - var2= slot_symbol (slot); - slot= next_slot (slot); - if (is_not_slot_end (slot)) { - var3 = slot_symbol (slot); - more_vars= is_not_slot_end (next_slot (slot)); - } - } - } - for (s7_pointer p= vars; is_pair (p); p= cdr (p)) { - const s7_pointer var= car (p); - if (is_pair (cdr (var))) { - if (var1) - fx_tree_in (sc, cdr (var), var1, var2, var3, - more_vars); /* init vals, more_vars refers to outer let, - stepper3 == local let more_vars */ - if (is_pair (cddr (var))) { - if (stepper0) - fx_tree (sc, cddr (var), stepper0, stepper1, stepper2, stepper3); - if ((var1) && (!outer_shadowed) && (!stepper3)) - fx_tree_outer (sc, cddr (var), var1, var2, var3, more_vars); - } - } - } - if ((is_pair (cdr (end))) && (is_null (cddr (end))) && - (has_fx (cdr (end)))) { - if (!fx_tree_in (sc, cdr (end), stepper0, stepper1, stepper2, stepper3)) - fx_tree (sc, cadr (end), stepper0, stepper1, stepper2, stepper3); - if ((var1) && (!outer_shadowed) && (!stepper3)) - fx_tree_outer (sc, cdr (end), var1, var2, var3, more_vars); - } +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); +} - if ((is_pair (car (end))) && (has_fx (end)) && - (!is_syntax (caar (end))) && - (!((is_symbol (caar (end))) && - (is_definer_or_binder (caar (end)))))) { - if (!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 ((var1) && (!outer_shadowed) && (!stepper3)) - fx_tree_outer (sc, end, var1, var2, var3, more_vars); - } +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); +} - if ((is_pair (body)) && (is_null (cdr (body))) && - (is_fxable (sc, car (body)))) { - s7_pointer var_list; - begin_temp (sc->y, sc->nil); - for (s7_pointer e1= vars; is_pair (e1); e1= cdr (e1)) - sc->y= cons (sc, caar (e1), sc->y); - var_list= sc->y; - end_temp (sc->y); - fx_annotate_arg (sc, body, var_list); - if (stepper0) - fx_tree (sc, body, stepper0, stepper1, stepper2, stepper3); - if ((var1) && (!outer_shadowed) && (!stepper3)) - fx_tree_outer (sc, body, var1, var2, var3, more_vars); - } - } - } - if (DO_PRINT) - fprintf (stderr, "%s[%d]: optimizable %s %s %s\n", __func__, __LINE__, - display (form), op_names[optimize_op (form)], - op_names[optimize_op (sc->code)]); - return (sc->nil); -} - -static bool -has_safe_steppers (s7_scheme* sc, s7_pointer let) { - for (s7_pointer slot= let_slots (let); is_not_slot_end (slot); - slot = next_slot (slot)) { - const s7_pointer val= slot_value (slot); - if (slot_has_expression (slot)) { - const s7_pointer step_expr= T_Pair (slot_expression (slot)); - 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, - make_real ( - sc, - real (val))); /* 2-Mar-25 was mutable? this is not a stepper, - just a do local with no step expr */ - else if (is_t_integer (val)) - slot_set_value (slot, - make_integer (sc, integer (val))); /* same as above */ - 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) { - if ((fn_proc (endp) == g_num_eq_2) && (is_symbol (cadr (endp))) && - (is_symbol (caddr (endp)))) { - s7_pointer end_slot= - s7_t_slot (sc, (cadr (endp) == slot_symbol (stepper)) ? caddr (endp) - : cadr (endp)); - 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 test; - const s7_pointer code= cdr (sc->code); - const s7_pointer let = inline_make_let (sc, sc->curlet); - sc->temp1 = let; - for (s7_pointer 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->unused; - 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= fx_proc (end); - s7_pointer endp= car (end); - if ((endf == fx_c_nc) || (endf == fx_c_0c)) { - endf= fn_proc (endp); - endp= cdr (endp); - } - if (steppers == 1) { - s7_function func= fx_proc (slot_expression (stepper)); /* e.g. fx_add_s1 */ - s7_pointer args= car (slot_expression (stepper)); - if ((func == fx_c_nc) || (func == fx_c_0c)) { - func= fn_proc (args); - args= cdr (args); - } - if (((func == fx_cdr_s) || (func == fx_cdr_t)) && - (cadr (args) == 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 (((func == fx_add_t1) || (func == fx_add_u1)) && - (is_t_integer (slot_value (stepper)))) { - const s7_pointer num= - make_mutable_integer (sc, integer (slot_value (stepper))); - slot_set_value (stepper, num); - 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)= q_call (o).fb; - do { - integer (num)++; - } while (!fb (o)); /* do {integer(num)++;} while ((sc->value = - optf(sc, endp)) == sc->F); */ - clear_mutable_integer (num); - sc->value= sc->T; - sc->code = cdr (end); - return (goto_do_end_clauses); - } - set_no_bool_opt (end); - } - do { - integer (num)++; - } while ((sc->value= endf (sc, endp)) == sc->F); - clear_mutable_integer (num); - } - else do { - slot_set_value (stepper, func (sc, args)); - } while ((sc->value= endf (sc, endp)) == sc->F); - sc->code= cdr (end); - return (goto_do_end_clauses); - } - if ((steppers == 2) && (!is_not_slot_end (next_slot (next_slot (slots))))) { - s7_pointer step1= slots; - const s7_pointer expr1= slot_expression (step1); - const s7_pointer step2= next_slot (step1); - const s7_pointer 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 lim= integer (caddr (endp)); - for (s7_int 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_pair (sc->code)) - return (goto_start); /* no result: (define (f) (do ((x 0 (+ x 1)) (i 0 (+ - i 1))) ((= i 1)))) (f) (f) */ - if ((!is_symbol (car (sc->code))) || - (is_pair ( - cdr (sc->code)))) /* more than one result: (define (f) (do ((x 0 (+ - x 1)) (i 0 (+ i 1))) ((= i 1) x 3 4))) (f) */ - return (goto_do_end_clauses); - step1= s7_slot (sc, car (sc->code)); - if (step1 == sc->undefined) /* (let () (define (f) (do ((x 0 (+ x 1)) (i 0 - (+ i 1))) ((= i 1) y))) (f)) */ - unbound_variable_error_nr (sc, car (sc->code)); - sc->value= slot_value (step1); - if (is_t_real (sc->value)) clear_mutable_number (sc->value); - return (goto_start); - } - do { - 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 (is_not_slot_end (slot)); - } 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 - */ - s7_int id; - int32_t steppers= 0; - s7_pointer code, end, endp, stepper= NULL, slots; - const s7_pointer form= sc->code; - s7_function endf; - const s7_pointer let= inline_make_let ( - sc, - sc->curlet); /* new let is not tied into the symbol lookup process yet */ - if (SHOW_EVAL_OPS) - fprintf (stderr, "%s[%d]: %s\n", __func__, __LINE__, display (form)); - sc->temp1= let; - sc->code = cdr (sc->code); - for (s7_pointer vars= car (sc->code); is_pair (vars); vars= cdr (vars)) { - const s7_pointer expr= cdar (vars); - s7_pointer slot; - const s7_pointer val= fx_call (sc, expr); - const s7_pointer stp= cdr (expr); /* cddar(vars) */ - new_cell_unchecked (sc, slot, T_SLOT); - slot_set_symbol_and_value (slot, caar (vars), val); - 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->unused; - 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) - */ - for (s7_pointer slot= slots; is_not_slot_end (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); - - if ((loop_end_possible (end)) && (steppers == 1) && - (is_t_integer (slot_value (stepper)))) { - const s7_pointer stop_slot= (is_symbol (caddr (endp))) - ? opt_integer_symbol (sc, caddr (endp)) - : sc->nil; - if (stop_slot) /* sc->nil -> it's an integer */ - { - set_has_loop_end (stepper); - set_loop_end (stepper, (is_slot (stop_slot)) - ? integer (slot_value (stop_slot)) - : integer (caddr (endp))); - } - } +static void op_safe_c_sp(s7_scheme *sc) +{ + s7_pointer args = cdr(sc->code); + check_stack_size(sc); + push_stack(sc, (opcode_t)T_Op(opt1_any(args)), lookup(sc, car(args)), sc->code); + sc->code = cadr(args); +} - 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? from eval call of - op_dox 96130 possibly from check_do */ - { - if (DO_PRINT) fprintf (stderr, "dox %d, no body\n", __LINE__); - return (op_dox_no_body_1 (sc, slots, end, steppers, stepper)); - } +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 */ + sc->value = fn_proc(sc->code)(sc, with_list_t2(sc, sc->args, sc->value)); +} - if ((is_null (cdr (code))) && /* 1 expr, code is cdddr(form) here */ - (is_pair (car (code)))) { - const s7_pointer body = car (code); - s7_pfunc bodyf= NULL; - - sc->do_body_p= body; - if ((!no_cell_opt (code)) && (has_safe_steppers (sc, sc->curlet))) - bodyf= s7_optimize_nv (sc, code); - - if ((!bodyf) && - (is_fxable (sc, body)) && /* happens very rarely, #_* as car etc */ - (is_c_function (car (body)))) { - if ((S7_DEBUGGING) && - (lookup (sc, c_function_symbol (car (body))) != car (body))) - fprintf (stderr, "%s[%d]: replacing %s with %s -> %s in %s\n", __func__, - __LINE__, display (car (body)), - display (c_function_symbol (car (body))), - display (lookup (sc, c_function_symbol (car (body)))), - display (body)); - bodyf= s7_optimize_nv ( - sc, - set_dlist_1 ( - sc, set_ulist_1 ( - sc, c_function_symbol (car (body)), - cdr (body)))); /* trouble! #_xyzzy need not match xyzzy */ - } - if (bodyf) { - if (steppers == 1) /* one expr body, 1 stepper */ - { - const s7_pointer stepa= car (slot_expression (stepper)); - const s7_function 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_nv) { - s7_pointer (*fp) (opt_info* o)= q_call (o).fp; - if (!((fp == opt_p_pip_sso) && (q_arg2 (o).p == q_arg4 (o).p) && - (((q_func (o).p_pip_f == string_set_p_pip_unchecked) && - (q_func3 (o).p_pi_f == string_ref_p_pi_unchecked)) || - ((q_func (o).p_pip_f == string_set_p_pip_direct) && - (q_func3 (o).p_pi_f == string_ref_p_pi_direct)) || - ((q_func (o).p_pip_f == vector_set_p_pip_unchecked) && - (q_func3 (o).p_pi_f == t_vector_ref_p_pi_unchecked)) || - ((q_func (o).p_pip_f == t_vector_set_p_pip_direct) && - (q_func3 (o).p_pi_f == t_vector_ref_p_pi_direct)) || - ((q_func (o).p_pip_f == list_set_p_pip_unchecked) && - (q_func3 (o).p_pi_f == list_ref_p_pi_unchecked))) && - (copy_if_end_ok (sc, slot_value (q_arg1 (o).p), - slot_value (q_arg3 (o).p), i, endp, - stepper)))) { - if (has_loop_end ( - stepper)) { /* (do ((val 0) (i 0 (+ i 1))) ((= i 1) val) - (set! val (real-part (v b1 b2)))) */ - s7_int lim= loop_end (stepper); - if ((i >= 0) && (lim < NUM_SMALL_INTS)) do { - fp (o); - slot_set_value (stepper, small_int (++i)); - } while (i < lim); - else do { - fp (o); - slot_set_value (stepper, make_integer (sc, ++i)); - } while (i < lim); - sc->value= sc->T; - } - else do { /* (do ((i start (+ i 1))) ((= end i)) (display i)) */ - fp (o); - slot_set_value (stepper, make_integer (sc, ++i)); - } while ((sc->value= endf (sc, endp)) == sc->F); - } - } - else if (!(((bodyf == opt_float_any_nv) && - (q_call (o).fd == opt_d_7pid_ss_ss) && - (q_arg2 (o).p == q_arg4 (o).p) && - ((q_func (o).d_7pid_f == float_vector_set_d_7pid) || - (q_func (o).d_7pid_f == - float_vector_set_d_7pid_direct)) && - ((q_func1 (o).d_7pi_f == float_vector_ref_d_7pi) || - (q_func1 (o).d_7pi_f == - float_vector_ref_d_7pi_direct)) && - (copy_if_end_ok (sc, slot_value (q_arg1 (o).p), - slot_value (q_arg3 (o).p), i, endp, - stepper))) || - - ((bodyf == opt_int_any_nv) && - ((q_call (o).fi == opt_i_7pii_ssf) || - (q_call (o).fi == opt_i_7pii_ssf_vset)) && - (q_arg2 (o).p == q_func1_arg (o).q_arg2 (o1).p) && - (((q_func (o).i_7pii_f == int_vector_set_i_7pii) && - (q_func1_arg (o).q_func (o1).i_7pi_f == - int_vector_ref_i_7pi)) || - ((q_func (o).i_7pii_f == int_vector_set_i_7pii_direct) && - (q_func1_arg (o).q_func (o1).i_7pi_f == - int_vector_ref_i_pi_direct))) && - (copy_if_end_ok ( - sc, slot_value (q_arg1 (o).p), - slot_value (q_func1_arg (o).q_arg1 (o1).p), i, endp, - stepper))))) - /* here the has_loop_end business doesn't happen much */ - do { /* (do ((count 0) (i 7 (+ i 1))) ((= i 10) count) (set! count - (quotient i 3))) */ - bodyf (sc); - slot_set_value (stepper, make_integer (sc, ++i)); - } while ((sc->value= endf (sc, endp)) == sc->F); - sc->code = cdr (end); - sc->do_body_p= NULL; - return (goto_do_end_clauses); - } - do { /* (do ((count 0.0) (i 7.0 (+ i 1.0))) ((>= i 10.0) count) (set! - count (modulo i 3.0))) */ - bodyf (sc); - slot_set_value (stepper, stepf (sc, stepa)); - } while ((sc->value= endf (sc, endp)) == sc->F); - sc->code = cdr (end); - sc->do_body_p= NULL; - return (goto_do_end_clauses); - } +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); +} - if ((steppers == 2) && - (!is_not_slot_end (next_slot (next_slot (slots))))) { - const s7_pointer slot1= slots, slot2= next_slot (slots); - const s7_function f1= fx_proc (slot_expression (slot1)); - const s7_function f2= fx_proc (slot_expression (slot2)); - const s7_pointer p1= car (slot_expression (slot1)); - const s7_pointer p2= car (slot_expression (slot2)); - /* split out opt_float_any_nv gained nothing (see tmp), same for - * opt_cell_any_nv, constant end value was never hit */ - if (bodyf == opt_cell_any_nv) { - opt_info* o = sc->opts[0]; - s7_pointer (*fp) (opt_info* o)= q_call (o).fp; - s7_pointer slot3 = NULL; - /* thash case -- this is dumb */ - if ((f2 == fx_add_u1) && (is_t_integer (slot_value (slot2))) && - (cadr (endp) == slot_symbol (slot2)) && - (!s7_tree_memq (sc, cadr (endp), body)) && - (((endf == fx_num_eq_ui) && (is_t_integer (caddr (endp)))) || - ((endf == fx_num_eq_us) && - (slot3= opt_integer_symbol (sc, caddr (endp))) && - (!s7_tree_memq ( - sc, caddr (endp), - body))))) { /* (do ((i 0 (+ i 1)) (z (random 100) (random - 100))) ((= i 5000000) counts) - (hash-table-set! counts z (+ (or - (hash-table-ref counts z) 0) 1))) */ - s7_int i = integer (slot_value (slot2)); - s7_int endi= (is_t_integer (caddr (endp))) - ? integer (caddr (endp)) - : integer (slot_value (slot3)); - do { - fp (o); - slot_set_value (slot1, f1 (sc, p1)); - i++; - } while (i < endi); - slot_set_value (slot2, make_integer (sc, endi)); - } - else - do { /* (do ((i 0 (+ i 1)) (lst lis (cdr lst))) ((= i (- len 1)) - (reverse result)) (set! result (cons (car lst) result))) */ - fp (o); - slot_set_value (slot1, f1 (sc, p1)); - slot_set_value (slot2, f2 (sc, p2)); - } while ((sc->value= endf (sc, endp)) == sc->F); - } - else - do { /* (do ((i 0 (+ i 1)) (j 0 (+ j 1))) ((= i 3) x) (set! x (max x - (* i j)))) */ - bodyf (sc); - slot_set_value (slot1, f1 (sc, p1)); - slot_set_value (slot2, f2 (sc, p2)); - } while ((sc->value= endf (sc, endp)) == sc->F); - sc->code = cdr (end); - sc->do_body_p= NULL; - return (goto_do_end_clauses); - } - if (bodyf == opt_cell_any_nv) { /* (do ((i npats (- i 1)) (ipats ipats - (cdr ipats)) (a '())) ((zero? i) a) - (set! a (cons (car ipats) a))) */ - opt_info* o = sc->opts[0]; - s7_pointer (*fp) (opt_info* o)= q_call (o).fp; - do { - s7_pointer slot1= slots; - fp (o); - do { - if (slot_has_expression (slot1)) - slot_set_value (slot1, fx_call (sc, slot_expression (slot1))); - slot1= next_slot (slot1); - } while (is_not_slot_end (slot1)); - } while ((sc->value= endf (sc, endp)) == sc->F); - } - else - do { /* (do ((i 0 (+ i 1)) (ph 0.0 (+ ph incr)) (kph 0.0 (+ kph kincr))) - ((= i 4410)) (float-vector-set! v1 i (+ (cos ph) (cos kph)))) */ - s7_pointer slot1= slots; - bodyf (sc); - do { - if (slot_has_expression (slot1)) - slot_set_value (slot1, fx_call (sc, slot_expression (slot1))); - slot1= next_slot (slot1); - } while (is_not_slot_end (slot1)); - } while ((sc->value= endf (sc, endp)) == sc->F); - sc->code = cdr (end); - sc->do_body_p= NULL; - return (goto_do_end_clauses); - } /* if (bodyf) ... */ - - 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), stepa; - s7_function stepf, valf; - const s7_pointer slot= s7_slot (sc, cadr (body)); - if (slot == - sc->undefined) /* (let ((lim 1)) (define (f) (let ((y 1)) (do ((i 0 (+ - i y))) ((= i lim)) (set! xxx 3)))) (f)) */ - unbound_variable_error_nr (sc, cadr (body)); - /* here we could jump to the end of this procedure (unsetting op_dox etc) - * to avoid (set! a a) as an error if 'a is immutable */ - if (is_immutable_slot (slot)) /* (let ((lim 1)) (define-constant x 1) - (define (f) (let ((y 1)) (do ((i 0 (+ i - y))) ((= i lim)) (set! x 3)))) (f)) */ - immutable_object_error_nr ( - sc, set_elist_3 (sc, wrap_string (sc, "~S is immutable in ~S", 21), - cadr (body), - body)); /* "x is immutable in (set! x 3)" */ - - if (!has_fx (val)) - set_fx (val, fx_choose (sc, val, sc->curlet, let_symbol_is_safe)); - valf = fx_proc (val); - val = car (val); - stepf= fx_proc (slot_expression (stepper)); - stepa= car (slot_expression (stepper)); - do { /* (do ((i 1 4)) ((> i 3)) (set! x (+ x i))) */ - 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); - } - } - 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)) && (has_safe_steppers (sc, sc->curlet))) { - sc->pc= 0; - for (int32_t 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)) { - 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) /* (do ((i 0 (+ 1 i))) ((= end i)) (set! end 8) (display i)) */ - { - if (use_opts) - for (int32_t i= 0; i < body_len; i++) - q_call (body[i]).fp (body[i]); - /* opt_set_p_d_f shoot: 144,186,857 => s7.c:opt_set_p_d_f (2,093,278x) - * (b also, big/fft as part of fft code 7M) */ - else - for (s7_pointer p1= code; is_pair (p1); p1= cdr (p1)) - fx_call (sc, p1); - - 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 (is_not_slot_end (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 inline bool -op_dox_step_1 (s7_scheme* sc) /* inline for 50 in concordance, 30 in dup */ -{ - s7_pointer slot= let_slots (sc->curlet); - do { /* every dox case has vars (else op_do_no_vars) */ - if (slot_has_expression (slot)) /* splitting out 1-slot has_expr case is not - faster (not enough hits) */ - slot_set_value (slot, fx_call (sc, slot_expression (slot))); - slot= next_slot (slot); - } while (is_not_slot_end (slot)); - sc->value= fx_call (sc, cadr (sc->code)); - if (is_true (sc, sc->value)) { - sc->code= cdadr (sc->code); - return (true); - } - return (false); +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_dox_step (s7_scheme* sc) { - push_stack_no_args_direct (sc, OP_DOX_STEP); - sc->code= T_Pair (cddr (sc->code)); +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_dox_step_o (s7_scheme* sc) { - push_stack_no_args_direct (sc, OP_DOX_STEP_O); - sc->code= caddr (sc->code); +static void op_safe_c_pc_1(s7_scheme *sc) {sc->value = fn_proc(sc->code)(sc, with_list_t2(sc, sc->value, sc->args));} + +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)T_Op(opt1_any(args)), opt3_any(args), sc->code); /* to safe_add_sp_1 for example */ + sc->code = cadr(args); } -static void -op_dox_no_body (s7_scheme* sc) { - s7_pointer slot, var, test, result; - s7_function testf; +static Inline void inline_op_safe_c_s(s7_scheme *sc) /* called twice in eval c/cl_s many hits */ +{ + sc->value = fn_proc(sc->code)(sc, with_list_t1(sc, lookup(sc, cadr(sc->code)))); +} +/* if op_safe_c_t added and set in fx_tree_in, we get a few hits, but nothing significant. + * if that had worked, it would be interesting to set opt1(cdr) to the fx_tree fx_proc, (init to fx_c_s), then call that here. + * opt1(cdr) is not used here, opt3_byte happens a few times, but opt2_direct clobbers opt2_fx sometimes + * (also need fx_annotate cdr(expr) in optimize_c_function_one_arg) + */ - sc->code= cdr (sc->code); - var = caar (sc->code); - testf = fx_proc (cadr (sc->code)); - test = caadr (sc->code); - result = cdadr (sc->code); +static Inline void inline_op_safe_c_ss(s7_scheme *sc) /* called twice in eval c/cl_ss many hits */ +{ + sc->value = fn_proc(sc->code)(sc, with_list_t2(sc, lookup(sc, cadr(sc->code)), lookup(sc, opt1_sym(cdr(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= - update_let_with_slot (sc, opt3_any (sc->code), fx_call (sc, cdr (var))); - let_set_outlet (let, sc->curlet); - set_curlet (sc, let); - } +static void op_safe_c_sc(s7_scheme *sc) +{ + sc->value = fn_proc(sc->code)(sc, with_list_t2(sc, lookup(sc, cadr(sc->code)), opt1_con(cdr(sc->code)))); +} + +static void op_cl_a(s7_scheme *sc) {sc->value = fn_proc(sc->code)(sc, with_list_t1(sc, fx_call(sc, cdr(sc->code))));} + +static inline 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_Ext(gc_protected1(sc))); + unstack_gc_protect(sc); + sc->value = fn_proc(sc->code)(sc, sc->t2_1); +} + +static void op_cl_fa(s7_scheme *sc) +{ + const s7_pointer code = cdadr(sc->code); + set_car(sc->t2_2, fx_call(sc, cddr(sc->code))); + set_car(sc->t2_1, make_closure_gc_checked(sc, car(code), cdr(code), T_CLOSURE | ((!s7_is_proper_list(sc, car(sc->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) */ + /* was checking is_symbol(car(sc->code) i.e. is arglist a symbol, but we need T_COPY_ARGS if arglist is '(a . b) as well (can this happen here?) */ + sc->value = fn_proc(sc->code)(sc, sc->t2_1); +} + +static inline void op_map_for_each_fa(s7_scheme *sc) +{ + const s7_pointer code = sc->code; + sc->value = fx_call(sc, cddr(code)); + if (is_null(sc->value)) + sc->value = (fn_proc_unchecked(code)) ? sc->unspecified : sc->nil; else - set_curlet (sc, 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)) { - const s7_int incr = integer (opt2_con (sc->code)); - const s7_pointer istep= make_mutable_integer ( - sc, integer (slot_value ( - slot))); /* mutable integer is faster here than wrapped */ - /* 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) { - const s7_pointer t1= cadr (test); - const s7_pointer t2= caddr (test); - const s7_function f1= fx_proc (cdr (test)); - const s7_function 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); /* just clears the T_MUTABLE bit */ - sc->value= fx_call (sc, result); - } - else { - const s7_function stepf= fx_proc (cddr (var)); - const s7_pointer step = caddr (var); - if (testf == fx_or_and_2a) { - const s7_pointer f1_arg= cadr (test), p= opt3_pair (test); /* cdadr(p) */ - const s7_function f1 = fx_proc (cdr (test)); - const s7_pointer f2_arg= car (p); - const s7_pointer f3_arg= cadr (p); - const s7_function f2 = fx_proc (p); - const s7_function f3 = fx_proc (cdr (p)); - if (((stepf == fx_add_t1) || (stepf == fx_add_u1)) && - (is_t_integer (slot_value (slot)))) { - const s7_pointer 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)); + { + sc->code = opt3_pair(code); /* cdadr(code); */ + sc->temp8 = make_closure_gc_checked(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, sc->temp8, sc->value) : g_map_closure(sc, sc->temp8, sc->value); + sc->temp8 = sc->unused; } - 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 test, slots; - bool all_steps= true; - const s7_pointer let = inline_make_let (sc, sc->curlet); - sc->temp1 = let; - sc->code = cdr (sc->code); - for (s7_pointer 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); +static void op_map_for_each_faa(s7_scheme *sc) +{ + const s7_pointer arg2p = cddr(sc->code), code = sc->code; + sc->value = fx_call(sc, arg2p); + sc->args = fx_call(sc, cdr(arg2p)); + 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); */ + sc->temp8 = make_closure_gc_checked(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, sc->temp8, sc->value, sc->args) : g_map_closure_2(sc, sc->temp8, sc->value, sc->args); + sc->temp8 = sc->unused; } - } - slots= let_slots (let); - set_curlet (sc, let); - sc->temp1= sc->unused; - test = cadr (sc->code); - - let_set_has_pending_value (sc->curlet); - if ((all_steps) && (!is_not_slot_end (next_slot (next_slot (slots)))) && - (is_pair (cdr (test)))) { - const s7_pointer slot1= slots; - const s7_pointer expr1= slot_expression (slot1); - const s7_pointer slot2= next_slot (slot1); - const s7_pointer 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, sc->curlet); - return; - } - while ((sc->value= fx_call (sc, test)) == sc->F) { - s7_pointer slot= slots; - do { - if (slot_has_expression (slot)) - slot_simply_set_pending_value (slot, - fx_call (sc, slot_expression (slot))); - slot= next_slot (slot); - } while (is_not_slot_end (slot)); - slot= slots; - do { - if (slot_has_expression (slot)) - slot_set_value (slot, slot_pending_value (slot)); - slot= next_slot (slot); - } while (is_not_slot_end (slot)); - } - sc->code= cdr (test); - let_clear_has_pending_value (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 bool -op_do_no_vars (s7_scheme* sc) { - s7_pointer p; - const s7_pointer 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)) { - const s7_pointer end= cadr (sc->code); - set_curlet (sc, inline_make_let (sc, sc->curlet)); - if (i == 1) - while ((sc->value= fx_call (sc, end)) == sc->F) - q_call (body[0]).fp ( - body[0]); /* presetting body[0] and body[0]-v[0].fp is not faster */ - else if (i == 2) { - opt_info *o0= body[0], *o1= body[1]; - s7_pointer (*fp0) (opt_info* o)= q_call (o0).fp; - s7_pointer (*fp1) (opt_info* o)= q_call (o1).fp; - while ((sc->value= fx_call (sc, end)) == sc->F) { - fp0 (o0); - fp1 (o1); - } - } - else if (i == 0) /* null body! */ +static void op_cl_na(s7_scheme *sc) +{ + const s7_pointer val = safe_list_if_possible(sc, opt3_arglen(cdr(sc->code))); + if (in_heap(val)) gc_protect_via_stack(sc, val); + for (s7_pointer 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)) + clear_safe_list_in_use(sc, val); + else + /* the fn_proc call might push its own op (e.g. for-each/map) so we have to check for that */ + if (stack_top_op(sc) == OP_GC_PROTECT) unstack_gc_protect(sc); +} + +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 inline void op_safe_c_pp(s7_scheme *sc) +{ + s7_pointer args = cdr(sc->code); + check_stack_size(sc); + 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) +{ + push_stack(sc, (opcode_t)T_Op(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_function endf= fx_proc (end); - s7_pointer endp= car (end); - while (!is_true (sc, sc->value= endf (sc, endp))) - ; /* the assignment is (normally) in the noise */ + s7_pointer p; + for (p = sc->args; is_pair(cdr(p)); p = cdr(p)); + set_cdr(p, list_1(sc, sc->value)); } - else - while ((sc->value= fx_call (sc, end)) == sc->F) - for (int32_t k= 0; k < i; k++) - q_call (body[k]).fp (body[k]); - sc->code= cdr (end); /* inner let still active during result */ - return (true); - } - /* back out */ - pair_set_syntax_op (form, OP_DO_NO_VARS_NO_OPT); - set_curlet (sc, make_let (sc, sc->curlet)); - return (op_do_no_vars_no_opt_1 (sc)); + sc->code = c_function_base(opt1_cfunc(sc->code)); + if (type(sc->code) == T_C_FUNCTION) + sc->value = apply_c_function_unopt(sc, sc->code, sc->args); + else apply_c_rst_no_req_function(sc); } -static void -op_do_no_vars_no_opt (s7_scheme* sc) { - sc->code= cdr (sc->code); - set_curlet (sc, inline_make_let (sc, sc->curlet)); +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_do_no_body_na_vars (s7_scheme* sc) /* vars fxable, end-test not */ +static void op_safe_c_3p_1(s7_scheme *sc) { - s7_pointer stepper = NULL; - s7_int steppers= 0; - const s7_pointer let = inline_make_let (sc, sc->curlet); - sc->temp1 = let; - sc->code = cdr (sc->code); - for (s7_pointer 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->unused; - push_stack_no_args_direct (sc, (intptr_t) ((steppers == 1) - ? OP_DO_NO_BODY_NA_VARS_STEP_1 - : OP_DO_NO_BODY_NA_VARS_STEP)); - sc->code= caadr (sc->code); -} - -static bool -op_do_no_body_na_vars_step (s7_scheme* sc) { - if (sc->value != sc->F) { - sc->code= cdadr (sc->code); - return (true); - } - for (s7_pointer slot= let_slots (sc->curlet); is_not_slot_end (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_NA_VARS_STEP); - sc->code= caadr (sc->code); - return (false); -} - -static bool -op_do_no_body_na_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_NA_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 */ - { - for (s7_pointer slots= sc->code; is_pair (slots); - slots= cdr (slots)) /* sc->code here is the original sc->args list */ - { - const s7_pointer slot= car (slots); - if (is_immutable_slot ( - slot)) /* (let () (define (func) (do ((x 0) (i 0 (+ i 1))) ((= i - 1) x) (set! x (immutable! 'i)))) (func)) */ - immutable_object_error_nr ( - sc, - set_elist_3 (sc, wrap_string (sc, "~S is immutable in ~S", 21), - slot_symbol (slot), car (slot_expression (slot)))); - slot_set_value (slot, slot_pending_value (slot)); - slot_clear_has_pending_value (slot); - } - pop_stack_no_op (sc); - return (true); - } - code= T_Pair ( - 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= T_Lst (cdr (sc->args)); /* go to next step var */ - } - else { - push_stack_direct (sc, OP_DO_STEP2); - sc->code= car (code); - return (false); - } - } + sc->args = sc->value; /* possibly fx/gx? and below */ + push_stack_direct(sc, OP_SAFE_C_3P_2); + sc->code = caddr(sc->code); } -static bool -op_do_step2 (s7_scheme* sc) { - if (is_multiple_value (sc->value)) - syntax_error_nr (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 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 bool -op_do_step ( - s7_scheme* sc) /* called only in eval OP_DO_STEP via op_do_end_false */ +static void op_safe_c_3p_2(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>)) -- is this comment - * correct? - */ - push_stack_direct (sc, OP_DO_END); - sc->args= car (sc->args); /* the var data lists */ - sc->code= T_Lst (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); + gc_protect_via_stack(sc, sc->value); + check_stack_size(sc); + push_stack_direct(sc, OP_SAFE_C_3P_3); + sc->code = cadddr(sc->code); } -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 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 bool -opt_do_copy (s7_scheme* sc, opt_info* o, s7_int start, s7_int stop) { - s7_pointer (*fp) (opt_info* o)= - q_call (o).fp; /* o-[6].p_pi_f (q_func3) is getter, o-v[5].p_pip_f - (q_func) is setter */ - if (start >= stop) return (true); - if ((fp == opt_p_pip_sso) && - (type (slot_value (q_arg1 (o).p)) == type (slot_value (q_arg3 (o).p))) && - (q_arg2 (o).p == q_arg4 (o).p)) { - s7_pointer caller= NULL; - const s7_pointer dest = slot_value (q_arg1 (o).p); - const s7_pointer source= slot_value (q_arg3 (o).p); - if ((is_t_vector (dest)) && - (((q_func (o).p_pip_f == vector_set_p_pip_unchecked) || - (q_func (o).p_pip_f == t_vector_set_p_pip_direct)) && - ((q_func3 (o).p_pi_f == t_vector_ref_p_pi_unchecked) || - (q_func3 (o).p_pi_f == vector_ref_p_pi_unchecked) || - (q_func3 (o).p_pi_f == t_vector_ref_p_pi_direct)))) - caller= sc->vector_set_symbol; - else if ((is_string (dest)) && - (((q_func (o).p_pip_f == string_set_p_pip_unchecked) || - (q_func (o).p_pip_f == string_set_p_pip_direct)) && - ((q_func3 (o).p_pi_f == string_ref_p_pi_unchecked) || - (q_func3 (o).p_pi_f == string_ref_p_pi_direct)))) - caller= sc->string_set_symbol; - else if ((is_pair (dest)) && - ((q_func (o).p_pip_f == list_set_p_pip_unchecked) && - (q_func3 (o).p_pi_f == list_ref_p_pi_unchecked))) - caller= sc->list_set_symbol; - else return (false); - if (start < 0) - out_of_range_error_nr (sc, caller, wrap_integer (sc, 2), - wrap_integer (sc, start), it_is_negative_string); - if ((stop > integer (s7_length (sc, source))) || - (stop > integer (s7_length (sc, dest)))) - out_of_range_error_nr (sc, caller, wrap_integer (sc, 2), - wrap_integer (sc, stop), it_is_too_large_string); - if ((caller) && (copy_to_same_type (sc, dest, source, start, stop, start))) - return (true); - } - return (false); +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, gc_protected1(sc)); + unstack_gc_protect(sc); + sc->value = fn_proc(sc->code)(sc, sc->t3_1); } -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; - - if (no_cell_opt (cddr (code))) return (false); - sc->do_body_p= caddr (code); - func = s7_optimize_nv (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)))) { - const s7_int start= integer (slot_value (ctr_slot)), - stop = integer (slot_value (end_slot)); - if (func == opt_cell_any_nv) { - opt_info* o = sc->opts[0]; - s7_pointer (*fp) (opt_info* o)= q_call (o).fp; - if ((fp == opt_p_ppp_sss) || (fp == opt_p_ppp_sss_mul) || - (fp == opt_p_ppp_sss_hset)) { /* (do ((i 0 (+ i 1))) ((= i 1) (let-ref - lt 'a)) (let-set! lt sym i)) */ - s7_p_ppp_t fpt= q_func (o).p_ppp_f; - for (s7_int i= start; i < stop; i++) /* thash and below */ - { - slot_set_value (ctr_slot, make_integer (sc, i)); - fpt (sc, slot_value (q_arg1 (o).p), slot_value (q_arg2 (o).p), - slot_value (q_arg3 (o).p)); - } - } - else if (fp == opt_p_ppp_sfs) { /* (do ((i 0 (+ i 1))) ((= i 9)) - (vector-set! v4 (expt 2 i) i)) */ - s7_p_ppp_t fpt= q_func (o).p_ppp_f; - for (s7_int i= start; i < stop; i++) { - slot_set_value (ctr_slot, make_integer (sc, i)); - fpt (sc, slot_value (q_arg1 (o).p), q_p_func1_call (o), - slot_value (q_arg2 (o).p)); - } - } - else if ((fp == opt_p_pip_sss_vset) && (start >= 0) && - (stop <= vector_length (slot_value ( - q_arg1 (o).p)))) { /* (do ((i 0 (+ i 1))) ((= i 10) - v) (vector-set! v i i)) */ - s7_pointer* vels= vector_elements ( - slot_value (q_arg1 (o).p)); /* better in callgrind, possibly - slightly slower in time */ - check_free_heap_size (sc, stop - start); - for (s7_int i= start; i < stop; i++) { - slot_set_value (ctr_slot, make_integer_unchecked (sc, i)); - vels[integer (slot_value (q_arg2 (o).p))]= slot_value (q_arg3 (o).p); - } - } - else /* (do ((i 0 (+ i 1))) ((= i 1) (let-ref lt 'a)) (let-set! lt 'a i)) - or (do ((i 0 (+ i 1))) ((= i 10)) (list-set! lst i i)) */ - for (s7_int i= start; i < stop; i++) { - slot_set_value (ctr_slot, make_integer (sc, i)); - fp (o); - } - } - else { /* (do ((j (+ nv k -1) (- j 1))) ((< j k)) (set! (r j) (- (r j) (* (q - k) (p2 (- j k)))))) */ - /* (do ((__i__ 0 (+ __i__ 1))) ((= __i__ 1) 32.0) (b 0)) and many more, - * all wrap-int safe I think */ - /* splitting out opt_float_any_nv here saves almost nothing */ - for (s7_int i= start; i < stop; i++) { - slot_set_value (ctr_slot, make_integer (sc, i)); - func (sc); - } - } - sc->value = sc->T; - sc->code = cdadr (code); - sc->do_body_p= NULL; - 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)))) { - const s7_int start= integer (slot_value (ctr_slot)), - stop = integer (slot_value (end_slot)); - if (func == opt_cell_any_nv) { - opt_info* o= sc->opts[0]; - if (!opt_do_copy (sc, o, stop, - start + 1)) { /* (do ((i 9 (- i 1))) ((< i 0) v) - (vector-set! v i i)) */ - s7_pointer (*fp) (opt_info* o)= q_call (o).fp; - for (s7_int i= start; i >= stop; i--) { - slot_set_value (ctr_slot, make_integer (sc, i)); - fp (o); - } - } - } - else /* (do ((i 9 (- i 1))) ((< i 0)) (set! (v i) (delay gen 0.5 i))) */ - for (s7_int i= start; i >= stop; i--) { - slot_set_value (ctr_slot, make_integer (sc, i)); - func (sc); - } - sc->value = sc->T; - sc->code = cdadr (code); - sc->do_body_p= NULL; - return (true); - } - if ((stepf == g_add_2) && /* this was g_add_2_xi, 27-Sep-24 */ - (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)))) { - const s7_int start= integer (slot_value (ctr_slot)), - stop = integer (slot_value (end_slot)), - incr = integer (caddr (step_expr)); - if (func == opt_cell_any_nv) { /* (do ((i 0 (+ i 2))) ((= i 20)) (display (/ - i 2))) */ - /* (do ((i 0 (+ i 8))) ((= i 64)) (write-byte (logand (ash int (- i)) - * 255))) */ - opt_info* o = sc->opts[0]; - s7_pointer (*fp) (opt_info* o)= q_call (o).fp; - for (s7_int i= start; i < stop; i+= incr) { - slot_set_value (ctr_slot, make_integer (sc, i)); - fp (o); - } - } +static void op_safe_c_3p_3_mv(s7_scheme *sc) +{ + s7_pointer p; + const s7_pointer p1 = ((is_pair(sc->args)) && (car(sc->args) == sc->unused)) ? cdr(sc->args) : list_1(sc, sc->args); + const s7_pointer ps1 = gc_protected1(sc); + const s7_pointer p2 = ((is_pair(ps1)) && (car(ps1) == sc->unused)) ? cdr(ps1) : list_1(sc, ps1); + const s7_pointer p3 = ((is_pair(sc->value)) && (car(sc->value) == sc->unused)) ? cdr(sc->value) : list_1(sc, sc->value); + unstack_gc_protect(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)); + if (type(sc->code) == T_C_FUNCTION) + sc->value = apply_c_function_unopt(sc, sc->code, sc->args); + else apply_c_rst_no_req_function(sc); +} + +static Inline bool inline_collect_np_args(s7_scheme *sc, opcode_t op, s7_pointer args) /* called (all hits:)op_any_c_np_1/mv and eval, tlet (cb/set) */ +{ + sc->args = args; + for (s7_pointer 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 - for (s7_int 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); - sc->do_body_p= NULL; - return (true); - } - if (func == opt_cell_any_nv) { - opt_info* o = sc->opts[0]; - s7_pointer (*fp) (opt_info* o)= q_call (o).fp; - if ((stepf == g_add_x1) && (is_t_integer (slot_value (ctr_slot))) && - (endf == g_greater_2) && (is_t_integer (slot_value (end_slot)))) { - const s7_int start= integer (slot_value (ctr_slot)), - stop = integer (slot_value (end_slot)); - if (fp == - opt_cond_1b) { /* (do ((i 0 (+ i 1))) ((> i a)) (cond (i i))) ! */ - s7_pointer (*test_fp) (opt_info* o)= - q_func1_arg (o).q_temp (o1).fp; /* see opt_cond_1b test expr */ - opt_info* test_o1= q_func1_arg (o).o1; - opt_info* o2 = q_cond_val1 (o).o1; - for (s7_int i= start; i <= stop; i++) { - slot_set_value (ctr_slot, make_integer (sc, i)); - if (test_fp (test_o1) != sc->F) cond_value (o2); - } + { + push_stack(sc, op, sc->args, cdr(p)); + sc->code = T_Pair(car(p)); + return(true); } - else /* (do ((i 0 (+ i 1))) ((> i a)) (vector-set! v i 1)) */ - for (s7_int i= start; i <= stop; i++) { - slot_set_value (ctr_slot, make_integer (sc, i)); - fp (o); - } - } - else /* (do ((i 0 (+ i 1))) ((> i 10)) (display i)) */ 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 ((i 0 (+ i 1))) ((> i 3) i) (set! i (* i 10))) */ 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); - sc->do_body_p= NULL; - 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 */ - const s7_pointer code= cdr (sc->code); - const s7_pointer end = opt1_any (code); /* caddr(caadr(code)) */ - const s7_pointer body= cddr (code); - - set_curlet (sc, make_let (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)); - - if (is_symbol (end)) let_set_dox_slot2 (sc->curlet, s7_t_slot (sc, end)); - 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 */ - } - 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 checks that stepf is reasonable? */ - (is_t_integer (caddr (opt2_pair (code)))) && - (op_simple_do_1 (sc, cdr (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) { - const s7_pointer ctr = let_dox_slot1 (sc->curlet); - s7_pointer end = let_dox_slot2 (sc->curlet); - const s7_pointer code= sc->code; - const s7_pointer 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 /* is_symbol(caddr(step)) I think: (+ 1 x) vs (+ x 1) */ - { - 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); + return(false); } -static bool -op_safe_do_step (s7_scheme* sc) { - const s7_int end = integer (let_dox2_value (sc->curlet)); - const s7_pointer slot= let_dox_slot1 (sc->curlet); - const s7_int 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) { - const s7_pointer arg= slot_value (sc->args); - numerator (arg)++; - if (numerator (arg) == loop_end (sc->args)) { - 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) { - const s7_pointer arg= slot_value (sc->args); - numerator (arg)++; - if (numerator (arg) == loop_end (sc->args)) { - sc->value= sc->T; - sc->code = cdadr (sc->code); - return (true); /* goto DO_END_CLAUSES */ - } - push_stack_direct (sc, OP_SAFE_DOTIMES_STEP_O); - sc->code= opt2_pair (sc->code); - return (false); /* goto EVAL */ -} - -static /* inline */ bool -op_dotimes_step_o (s7_scheme* sc) /* called once in eval, mat(10+6), num(7+1) */ -{ - const s7_pointer ctr = let_dox_slot1 (sc->curlet); - s7_pointer end = let_dox2_value (sc->curlet); - s7_pointer now = slot_value (ctr); - const s7_pointer code = sc->code; - const s7_pointer 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); +static bool collect_np_args(s7_scheme *sc, opcode_t op, s7_pointer args) {return(inline_collect_np_args(sc, op, args));} + +static /* inline */ bool op_any_c_np(s7_scheme *sc) /* code: (func . args) where at least one arg is not fxable */ +{ + sc->args = sc->nil; + for (s7_pointer args = cdr(sc->code); is_pair(args); args = cdr(args)) + if (has_fx(args)) + sc->args = cons(sc, sc->value = fx_call(sc, args), sc->args); /* reversed before apply in OP_ANY_C_NP_1 */ + 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(args))) ? OP_ANY_C_NP_1 : OP_ANY_C_NP_2)), sc->args, cdr(args)); + sc->code = T_Pair(car(args)); + return(true); /* goto EVAL */ } + sc->args = proper_list_reverse_in_place(sc, sc->args); + sc->value = fn_proc(sc->code)(sc, sc->args); + return(false); /* continue */ +} + +static Inline bool inline_op_any_c_np_1(s7_scheme *sc) /* called once in eval, tlet (cb/set) */ +{ + /* in-coming sc->value has the current arg value, sc->args is all previous args, sc->code is on op-stack */ + if (inline_collect_np_args(sc, OP_ANY_C_NP_1, cons(sc, sc->value, sc->args))) + return(true); /* goto EVAL */ + 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); /* continue?? */ +} + +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); + /* continue */ +} + +static bool op_any_c_np_mv(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, (is_multiple_value(sc->value)) ? revappend(sc, sc->value, sc->args) : cons(sc, sc->value, sc->args))) + return(true); /* goto EVAL */ + sc->args = proper_list_reverse_in_place(sc, sc->args); + sc->code = c_function_base(opt1_cfunc(pop_op_stack(sc))); + return(false); /* goto APPLY */ +} + +static void op_any_closure_np(s7_scheme *sc) +{ + s7_pointer args = cdr(sc->code); + check_stack_size(sc); + if (sc->op_stack_now >= sc->op_stack_end) + resize_op_stack(sc); + push_op_stack(sc, sc->code); + if (has_fx(args)) + { + sc->args = fx_call(sc, args); + sc->args = list_1(sc, sc->args); + for (args = cdr(args); (is_pair(args)) && (has_fx(args)); args = cdr(args)) + sc->args = cons_unchecked(sc, fx_call(sc, args), sc->args); } - } - else { - slot_set_value (ctr, g_add_x1 (sc, with_list_t1 (sc, now))); - /* (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); + else sc->args = sc->nil; + push_stack(sc, ((intptr_t)((is_pair(cdr(args))) ? OP_ANY_CLOSURE_NP_1 : OP_ANY_CLOSURE_NP_2)), sc->args, cdr(args)); + sc->code = T_Pair(car(args)); +} + +static void op_any_closure_np_end(s7_scheme *sc) +{ + s7_pointer args, func; + sc->args = proper_list_reverse_in_place(sc, sc->args); /* needed in either case -- closure_pars(func) is not reversed */ + sc->code = pop_op_stack(sc); + func = opt1_lambda(sc->code); + if (is_safe_closure(func)) + { + s7_pointer slot; + const s7_int id = ++sc->let_number; + set_curlet(sc, closure_let(func)); + let_set_id(sc->curlet, id); + for (slot = let_slots(sc->curlet), args = sc->args; is_not_slot_end(slot); slot = next_slot(slot), args = cdr(args)) + { + slot_set_value(slot, car(args)); + symbol_set_local_slot(slot_symbol(slot), id, slot); + /* don't free sc->args -- it might be needed in the error below */ + } + if (is_not_slot_end(slot)) + error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, not_enough_arguments_string, sc->code, sc->args)); } - } - 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 loop_end_ok) { - if (loop_end_ok) set_safe_stepper (sc->args); - else set_safe_stepper (let_dox_slot1 (sc->curlet)); - - if (is_null (cdr (code))) { - s7_pfunc func; - if (no_cell_opt (code)) return_false (sc, code); - sc->do_body_p= car (code); - func = s7_optimize_nv (sc, code); - if (!func) { - set_no_cell_opt (code); - return_false (sc, code); - } - if (loop_end_ok) { - const s7_int end= loop_end (sc->args); - const s7_pointer stepper= - make_mutable_integer (sc, integer (slot_value (sc->args))); - slot_set_value (sc->args, stepper); - if ((func == opt_float_any_nv) || (func == opt_cell_any_nv)) { - opt_info* o= sc->opts[0]; - if (func == opt_float_any_nv) { - s7_double (*fd) (opt_info* o)= q_call (o).fd; - if ((fd == opt_d_id_sf) && /* by far the most common case in clm: - (outa i ...) etc */ - (is_slot (q_arg1 (o).p)) && - (stepper == - slot_value (q_arg1 (o).p))) { /* (do ((i 0 (+ i 1))) ((= i len) - (set! *output* #f) v1) (outa i - (- (* i incr) 0.5))) */ - opt_info* o1 = sc->opts[1]; - s7_int end8= end - 8; - s7_d_id_t f0 = q_func (o).d_id_f; - fd = q_call (o1).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 ((q_call (o).fd == opt_d_7pid_ss_ss) && - (q_func (o).d_7pid_f == float_vector_set_d_7pid_direct) && - ((q_func1 (o).d_7pi_f == float_vector_ref_d_7pi) || - (q_func1 (o).d_7pi_f == float_vector_ref_d_7pi_direct)) && - (q_arg2 (o).p == q_arg4 (o).p)) - copy_to_same_type (sc, slot_value (q_arg1 (o).p), - slot_value (q_arg3 (o).p), integer (stepper), - end, integer (stepper)); - else if ((q_call (o).fd == opt_d_7pid_ssc) && - (q_func (o).d_7pid_f == float_vector_set_d_7pid_direct) && - (stepper == slot_value (q_arg2 (o).p))) - s7_fill (sc, set_plist_4 ( - sc, slot_value (q_arg1 (o).p), - wrap_real (sc, q_arg3 (o).x), stepper, - wrap_integer (sc, end))); /* wrapped 16-Nov-23 */ - else { /* (do ((i 0 (+ i 1))) ((= i 2) fv) (float-vector-set! fv (+ i - 0) (+ i 1) (* 2.0 3.0))) */ - s7_int end4= end - 4; - while (integer (stepper) < end4) - LOOP_4 (fd (o); integer (stepper)++); - for (; integer (stepper) < end; integer (stepper)++) - fd (o); - } - } - else { - s7_pointer (*fp) (opt_info* o)= q_call (o).fp; - if ((fp == opt_p_pip_ssc) && - (stepper == - slot_value (q_arg2 (o).p)) && /* i.e. index by do counter */ - ((q_func (o).p_pip_f == string_set_p_pip_direct) || - (q_func (o).p_pip_f == t_vector_set_p_pip_direct) || - (q_func (o).p_pip_f == list_set_p_pip_unchecked))) - s7_fill (sc, - set_plist_4 ( - sc, slot_value (q_arg1 (o).p), q_arg3 (o).p, stepper, - wrap_integer (sc, end))); /* wrapped 16-Nov-23 */ - else if (fp == opt_if_bp) { /* (do ((i 0 (+ i 1))) ((= i 3) y) (if (= - (+ z 1) 2.2) (display (+ z 1)))) */ - for (; integer (stepper) < end; integer (stepper)++) - if (q_func (o).fb (q_arg2 (o).o1)) q_p_func1_call (o); - } - else if (fp == opt_if_nbp_fs) { /* (do ((i 0 (+ i 1))) ((= i len)) (if - (not (= (list-ref lst i) i)) - (display "oops"))) */ - for (; integer (stepper) < end; integer (stepper)++) - if (!(q_func4 (o).b_pi_f (sc, q_p_func1_call (o), - integer (slot_value (q_arg1 (o).p))))) - q_p_func2_call (o); - } - else if (fp == opt_unless_p_1) { /* (do ((i 0 (+ i 1))) ((= i size)) - (unless (= (hash-table-ref - vct-hash (float-vector i)) i) - (display "oops"))) */ - opt_info* o1= q_when_body (o, 0).o1; - for (; integer (stepper) < end; integer (stepper)++) - if (!(q_when_test_call (o))) q_call (o1).fp (o1); - } - else /* (do ((i 0 (+ i 1))) ((= i size) (vector-ref v 0)) (vector-set! - v i 2)) */ - for (; integer (stepper) < end; integer (stepper)++) - fp (o); - } - } - else if (func == opt_int_any_nv) { - opt_info* o = sc->opts[0]; - s7_int (*fi) (opt_info* o)= q_call (o).fi; - if ((fi == opt_i_7pii_ssc) && (stepper == slot_value (q_arg2 (o).p)) && - (q_func (o).i_7pii_f == int_vector_set_i_7pii_direct)) - s7_fill ( - sc, set_plist_4 (sc, slot_value (q_arg1 (o).p), - wrap_integer (sc, q_arg3 (o).i), stepper, - wrap_integer (sc, end))); /* wrapped 16-Nov-23 */ - else if ((q_func (o).i_7pii_f == int_vector_set_i_7pii_direct) && - (q_func1 (o).fi == opt_i_pi_ss_ivref) && - (q_arg2 (o).p == q_func1_arg (o).q_arg2 (o1).p)) - copy_to_same_type (sc, slot_value (q_arg1 (o).p), - slot_value (q_func1_arg (o).q_arg1 (o1).p), - integer (stepper), end, integer (stepper)); - else /* (do ((i 0 (+ i 1))) ((= i size) (byte-vector-ref v 0)) - (byte-vector-set! v i 2)) */ - for (; integer (stepper) < end; integer (stepper)++) - fi (o); - } - else /* (do ((i 0 (+ i 1))) ((= i 1)) (char-numeric? (string-ref #u(0 1) - 1))) or (logbit? i -1): kinda nutty */ - for (; integer (stepper) < end; integer (stepper)++) - func (sc); - clear_mutable_integer (stepper); - } - else { - const s7_pointer step_slot= let_dox_slot1 (sc->curlet); - const s7_pointer end_slot = let_dox_slot2 (sc->curlet); - s7_int step = integer (slot_value (step_slot)); - const s7_int stop = integer (slot_value (end_slot)); - const s7_pointer step_val = slot_value (step_slot); - if (func == opt_cell_any_nv) { - opt_info* o = sc->opts[0]; - s7_pointer (*fp) (opt_info* o)= q_call (o).fp; - if (!opt_do_copy (sc, o, step, stop)) { - if ((step >= 0) && (stop < NUM_SMALL_INTS)) { - if (fp == opt_when_p_2) { /* (do ((i 0 (+ i 1))) ((= i len) (list mx - loc)) (when (> (abs (vect i)) mx) (set! - mx (vect i)) (set! loc i))) */ - for (; step < stop; step++) { - slot_set_value (step_slot, small_int (step)); - if (q_when_test_call (o)) { - q_when_p1_call (o); - q_when_p2_call (o); - } - } - } - else /* (do ((k 0 (+ k 1))) ((= k 10) sum) (do ((i 0 (+ i 1))) ((= i - size/10)) (set! sum (+ sum (round (vector-ref v k i)))))) */ - for (; step < stop; step++) { - slot_set_value (step_slot, small_int (step)); - fp (o); - } - } - else /* (do ((i 0 (+ i 1))) ((= i len) (list mx loc)) (when (> (abs - (vect i)) mx) (set! mx (vect i)) (set! loc i))) */ - for (; step < stop; step++) { - slot_set_value (step_slot, make_integer (sc, step)); - fp (o); - } - } - } - else if ((step >= 0) && - (stop < NUM_SMALL_INTS)) { /* (do ((i 0 (+ i 1))) ((= i 1) x) - (set! x (+ (* x1 (block-ref b1 i)) - (* x2 (block-ref b2 j))))) */ - for (; step < stop; step++) { - slot_set_value (step_slot, small_int (step)); - func (sc); - } - } - else if (func == - opt_int_any_nv) { /* (do ((i 0 (+ i 1))) ((= i size) sum) (set! - sum (+ sum (floor (vector-ref v i))))) */ - opt_info* o = sc->opts[0]; - s7_int (*fi) (opt_info* o)= q_call (o).fi; - if ((fi == opt_set_i_i_f) || (fi == opt_set_i_i_fo)) { - slot_set_value ( - q_arg1 (o).p, - make_mutable_integer (sc, integer (slot_value (q_arg1 (o).p)))); - fi= (fi == opt_set_i_i_f) ? opt_set_i_i_fm : opt_set_i_i_fom; - } - while (step < stop) { - fi (o); - step= ++integer (step_val); - } - if ((fi == opt_set_i_i_fm) || (fi == opt_set_i_i_fom)) - clear_mutable_integer (slot_value (q_arg1 (o).p)); - } - else if (func == opt_float_any_nv) { /* (do ((i 1 (+ i 1))) ((= i 1000)) - (set! (v i) (filter f1 0.0))) */ - opt_info* o = sc->opts[0]; - s7_double (*fd) (opt_info* o)= q_call (o).fd; - if (fd == opt_set_d_d_f) { /* (do ((i 0 (+ i 1))) ((= i 32768)) (set! - sum (+ sum (float-vector-ref ndat i)))) */ - slot_set_value ( - q_arg1 (o).p, - make_mutable_real (sc, real (slot_value (q_arg1 (o).p)))); - fd= opt_set_d_d_fm; - } - while (step < stop) { - fd (o); - step= ++integer (step_val); - } - if (fd == opt_set_d_d_fm) - clear_mutable_number (slot_value (q_arg1 (o).p)); - } + else + { + s7_pointer pars = closure_pars(func), last_slot; + const s7_pointer let = inline_make_let(sc, closure_let(func)); + const s7_int id = let_id(let); + + begin_temp(sc->y, let); + last_slot = make_slot(sc, car(pars), car(sc->args)); + slot_set_next(last_slot, slot_end); + let_set_slots(let, last_slot); + symbol_set_local_slot(car(pars), id, last_slot); + for (pars = cdr(pars), args = cdr(sc->args); is_pair(pars); pars = cdr(pars), args = cdr(args)) + last_slot = add_slot_at_end(sc, id, last_slot, car(pars), car(args)); /* sets last_slot, don't free sc->args -- used below */ + set_curlet(sc, let); + end_temp(sc->y); +#if S7_DEBUGGING + if ((is_pair(pars)) || (is_pair(args))) + fprintf(stderr, "%s[%d]: p: %s, args: %s\n", __func__, __LINE__, display(pars), display(args)); + if (is_pair(pars)) + error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, not_enough_arguments_string, sc->code, sc->args)); +#endif } - /* there aren't any other possibilities */ - sc->value = sc->T; - sc->code = cdadr (scc); - sc->do_body_p= NULL; - return_true (sc, code); - } + if (is_pair(args)) /* these checks are needed because multiple-values might evade earlier arg num checks */ + error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, too_many_arguments_string, sc->code, sc->args)); + sc->code = closure_body(func); + if_pair_set_up_begin(sc); +} - { /* not is_null(cdr(code)) i.e. there's more than one thing to do in the body - */ - const s7_int body_len= s7_list_length (sc, code); - opt_info* body[32]; - sc->pc= 0; - if (body_len >= 32) return_false (sc, code); - - if (!no_float_opt (code)) { - s7_pointer p= code; - for (int32_t k= 0; is_pair (p); k++, p= cdr (p)) { - body[k]= sc->opts[sc->pc]; - if (!float_optimize (sc, p)) break; - /* if opt_set_d_d_f -> fm mutablizing body[k]-v[1].p? see 83033 but - * protect against (data i) as below */ - } - if (is_pair (p)) { - sc->pc= 0; - set_no_float_opt (code); - } - else { - if (loop_end_ok) { /* (do ((i start (+ i 1))) ((= i end)) (outa i (* - ampa (ina i *reverb*))) (outb i (* ampb (inb i - *reverb*)))) */ - const s7_int end= loop_end (sc->args); - const s7_pointer stepper= - make_mutable_integer (sc, integer (slot_value (sc->args))); - slot_set_value (sc->args, stepper); - for (; integer (stepper) < end; integer (stepper)++) - for (int32_t i= 0; i < body_len; i++) - q_call (body[i]).fd (body[i]); - clear_mutable_integer (stepper); - } - else { /* (do ((i 0 (+ i 1))) ((= i 5)) (set! (data i) (delay dly1 - impulse -0.4)) (set! impulse 0.0)) */ - const s7_pointer step_slot= let_dox_slot1 (sc->curlet); - const s7_pointer end_slot = let_dox_slot2 (sc->curlet); - const s7_int stop = integer (slot_value (end_slot)); - const s7_pointer step_val = slot_value (step_slot); - for (s7_int step= integer (step_val); step < stop; - step = ++integer (step_val)) - for (int32_t i= 0; i < body_len; i++) - q_call (body[i]).fd (body[i]); - /* tari[99 ff]: 4 calls here all safe (see d_syntax_ok, need to make - * the change and the list here dependent on two-sets bit(?) (3.3M - * calls) */ - /* tall: (3.3M calls) */ - } - sc->value= sc->T; - sc->code = cdadr (scc); - return_true (sc, code); - } - } +static void op_safe_c_ap(s7_scheme *sc) +{ + const s7_pointer code = cdr(sc->code); + const s7_pointer val = cdr(code); + check_stack_size(sc); + sc->args = fx_call(sc, code); + push_stack_direct(sc, (opcode_t)T_Op(opt1_any(code))); /* safe_c_sp cases, mv->safe_c_sp_mv */ + sc->code = car(val); +} + +static void op_safe_c_pa(s7_scheme *sc) +{ + const s7_pointer args = cdr(sc->code); + check_stack_size(sc); + push_stack_no_args_direct(sc, OP_SAFE_C_PA_1); + sc->code = car(args); +} + +static void op_safe_c_pa_1(s7_scheme *sc) +{ + sc->args = sc->value; /* fx* might change sc->value */ + set_car(sc->t2_2, fx_call(sc, cddr(sc->code))); + set_car(sc->t2_1, sc->args); + sc->value = fn_proc(sc->code)(sc, sc->t2_1); +} + +static void op_c_nc(s7_scheme *sc) +{ + if (car(sc->code) != sc->values_symbol) /* (define (f) (let ((val (catch #t (lambda () (error 1 2 3)) (lambda args (list 2 3 4))))) val)) (f) */ { - /* not float opt */ - s7_pointer p= code; - sc->pc = 0; - for (int32_t k= 0; 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)) { - if ((S7_DEBUGGING) && (loop_end_ok) && (!has_loop_end (sc->args))) - fprintf (stderr, "%s[%d]: loop_end_ok but not has_loop_end\n", - __func__, __LINE__); - if (loop_end_ok) { /* (do ((i 0 (+ i 1))) ((= i 1) strs) (copy - (vector-ref strs i) (make-string 1)) (copy - (vector-ref strs i) (make-string 0))) */ - const s7_int end= loop_end (sc->args); - const s7_pointer stepper= - make_mutable_integer (sc, integer (slot_value (sc->args))); - slot_set_value (sc->args, stepper); - if ((body_len & 0x3) == 0) - for (; integer (stepper) < end; integer (stepper)++) - for (int32_t i= 0; i < body_len;) - LOOP_4 (q_call (body[i]).fp (body[i]); i++); - else if (body_len == 1) { - opt_info* o1= body[0]; - for (; integer (stepper) < end; integer (stepper)++) - q_call (o1).fp (o1); - } - else /* TODO: opt_unless_p_1_nr? */ - for (; integer (stepper) < end; integer (stepper)++) - for (int32_t i= 0; i < body_len; i++) - q_call (body[i]).fp (body[i]); - clear_mutable_integer (stepper); - } - else { /* (do ((k j (+ k 1))) ((= k len2) obj) (set! (obj n) (seq2 k)) - (set! n (+ n 1))) */ - const s7_pointer step_slot= let_dox_slot1 (sc->curlet); - const s7_pointer end_slot = let_dox_slot2 (sc->curlet); - const s7_int stop = integer (slot_value (end_slot)); - for (s7_int step= integer (slot_value (step_slot)); step < stop; - step++) { - slot_set_value (step_slot, make_integer (sc, step)); - for (int32_t i= 0; i < body_len; i++) - q_call (body[i]).fp (body[i]); - } - } - sc->value= sc->T; - sc->code = cdadr (scc); - return_true (sc, code); - } + const s7_pointer new_args = make_list(sc, opt3_arglen(cdr(sc->code)), sc->unused); + for (s7_pointer args = cdr(sc->code), p = new_args; is_pair(args); args = cdr(args), p = cdr(p)) set_car(p, car(args)); + sc->temp3 = new_args; /* desperation? */ + sc->value = fn_proc(sc->code)(sc, new_args); + sc->temp3 = sc->unused; + } + else + { /* opt2 = splice_in_values */ + set_needs_copied_args(cdr(sc->code)); /* needed, see s7test, set_multiple_value which currently aborts if not a heap pointer */ + sc->value = splice_in_values(sc, cdr(sc->code)); } - } - return_false (sc, code); } -static bool -do_let (s7_scheme* sc, s7_pointer step_slot, s7_pointer scc) { - const s7_pointer let_code= caddr (scc); - s7_pointer let_body, let_vars, ip; - bool let_star; - s7_pointer old_let, stepper; - s7_int body_len, var_len, end; -#define O_SIZE 32 - opt_info *body[O_SIZE], *vars[O_SIZE]; - memclr ((void*) body, - O_SIZE * sizeof (opt_info*)); /* placate the damned compiler */ - memclr ((void*) vars, O_SIZE * sizeof (opt_info*)); +static void op_c_na(s7_scheme *sc) /* (set-cdr! lst ()) */ +{ + const s7_pointer new_args = make_list(sc, opt3_arglen(cdr(sc->code)), sc->unused); + gc_protect_via_stack(sc, new_args); + for (s7_pointer args = cdr(sc->code), p = new_args; is_pair(args); args = cdr(args), p = cdr(p)) + set_car(p, fx_call(sc, args)); + unstack_gc_protect(sc); + sc->temp3 = new_args; /* desperation? */ + sc->value = fn_proc(sc->code)(sc, new_args); + sc->temp3 = sc->unused; +} - /* do_let with non-float vars doesn't get many fixable hits */ - if ((!is_pair (cdr (let_code))) || - (!is_list ( - cadr (let_code)))) /* (do ((j 0 (+ j 1))) ((= j 1)) (let name 123)) */ - return (false); - let_body= cddr (let_code); - body_len= s7_list_length (sc, let_body); - if ((body_len <= 0) || (body_len >= 32)) return (false); - 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_let= sc->curlet; - set_curlet (sc, make_let (sc, sc->curlet)); +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); +} - sc->pc = 0; - var_len= 0; - for (s7_pointer 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 (false); - 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_let); - return (false); - } - if (let_star) - add_slot_checked (sc, sc->curlet, caar (p), make_mutable_real (sc, 1.5)); - } +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)); +} - if (!let_star) - for (s7_pointer p= let_vars; is_pair (p); p= cdr (p)) - add_slot_checked (sc, sc->curlet, caar (p), make_mutable_real (sc, 1.5)); +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); +} - { - s7_pointer p= let_body; - for (int32_t k= 0; is_pair (p); k++, p= cdr (p)) { - body[k]= sc->opts[sc->pc]; - if (!float_optimize (sc, p)) { - set_curlet (sc, old_let); - return (false); - } - } - if (!is_null (p)) /* no hits in s7test or snd-test */ - { - set_curlet (sc, old_let); - return (false); - } - } - end= loop_end (step_slot); - let_set_slots (sc->curlet, reverse_slots (let_slots (sc->curlet))); - ip= slot_value (step_slot); - - if (body_len == 1) { - opt_info* o = body[0]; - s7_double (*f2) (opt_info* o)= q_call (o).fd; - if (var_len == 1) { - opt_info* first = sc->opts[0]; - const s7_pointer xp = t_lookup (sc, caar (let_vars), let_vars); - s7_double (*f1) (opt_info* o)= q_call (first).fd; - set_integer (ip, numerator (stepper)); - set_real (xp, f1 (first)); - f2 (o); - if ((f2 == opt_fmv) && (f1 == opt_d_dd_ff_o2) && - (q_func (first).d_dd_f == add_d_dd) && - (slot_symbol (step_slot) == slot_symbol (q_arg2 (o).p))) { - opt_info* o1 = q_arg3 (o).o1; /* opt_d_dd_ff_mul1 */ - opt_info* o2 = q_arg4 (o).o1; /* opt_d_vd_o1 */ - opt_info* o3 = q_arg5 (o).o1; /* opt_d_dd_ff_o3 */ - s7_d_vid_t vf7 = q_func (o).d_vid_f; /* locsig_d_vid */ - s7_d_v_t vf1 = q_func3 (first).d_v_f; /* mus_triangle_wave_dv */ - s7_d_v_t vf2 = q_func1 (first).d_v_f; /* mus_rand_interp_dv */ - s7_d_v_t vf3 = q_func3 (o1).d_v_f; /* mus_env_dv */ - s7_d_v_t vf4 = q_func3 (o3).d_v_f; /* mus_env_dv */ - s7_d_vd_t vf5 = q_func (o2).d_vd_f; /* mus_oscil_dvd */ - s7_d_vd_t vf6 = q_func2 (o3).d_vd_f; /* mus_polywave_dvd */ - void* obj1= q_arg1 (first).gen; - void* obj2= q_arg2 (first).gen; - void* obj3= q_arg1 (o1).gen; - void* obj4= q_arg1 (o3).gen; - void* obj5= q_arg1 (o).gen; - void* obj6= q_arg1 (o2).gen; - void* obj7= q_arg2 (o3).gen; - for (s7_int k= numerator (stepper) + 1; k < end; k++) { - s7_double vib = vf1 (obj1) + vf2 (obj2); - s7_double amp_env= vf3 (obj3); - vf7 (obj5, k, - amp_env * vf5 (obj6, vib + (vf4 (obj4) * vf6 (obj7, vib)))); - } - } - else - for (s7_int k= numerator (stepper) + 1; k < end; k++) { - set_integer (ip, k); - set_real (xp, f1 (first)); - f2 (o); - } - } /* body_len == 1 and var_len == 1 */ - else { - if (var_len == 2) { - const s7_pointer s1= let_slots (sc->curlet); - const s7_pointer s2= next_slot (s1); - opt_info * v0= vars[0], *v1= vars[1]; - for (s7_int k= numerator (stepper); k < end; k++) { - set_integer (ip, k); - set_real (slot_value (s1), q_call (v0).fd (v0)); - set_real (slot_value (s2), q_call (v1).fd (v1)); - f2 (o); - } - } /* body_len == 1 and var_len == 2 */ - else - for (s7_int k= numerator (stepper); k < end; k++) { - s7_pointer slot= let_slots (sc->curlet); - set_integer (ip, k); - for (int32_t n= 0; is_not_slot_end (slot); - n++, slot= next_slot (slot)) - set_real (slot_value (slot), q_call (vars[n]).fd (vars[n])); - f2 (o); /* q_call(body[0]).fd(body[0]) is possibly slightly faster */ - } - } - } /* end body_len == 1 */ - else if ((body_len == 2) && (var_len == 1)) { - const s7_pointer s1= let_slots (sc->curlet); - for (s7_int k= numerator (stepper); k < end; k++) { - set_integer (ip, k); - set_real (slot_value (s1), q_call (vars[0]).fd (vars[0])); - q_call (body[0]).fd (body[0]); - q_call (body[1]).fd (body[1]); - } - } - else - for (s7_int k= numerator (stepper); k < end; k++) { - int32_t i= 0; - set_integer (ip, k); - for (s7_pointer slot= let_slots (sc->curlet); is_not_slot_end (slot); - i++, slot= next_slot (slot)) - set_real (slot_value (slot), q_call (vars[i]).fd (vars[i])); - for (int32_t i1= 0; i1 < body_len; i1++) - q_call (body[i1]).fd (body[i1]); - } - set_curlet (sc, old_let); - sc->value= sc->T; - sc->code = cdadr (scc); - return (true); -} - -static bool -do_let_or_dotimes (s7_scheme* sc, s7_pointer code, bool loop_end_ok) { - const 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)); - return (opt_dotimes (sc, cddr (code), code, loop_end_ok)); -} - -static goto_t -op_safe_dotimes (s7_scheme* sc) { - const s7_pointer form= sc->code; - s7_pointer init_val; - - sc->code= cdr (sc->code); - init_val= fx_call (sc, cdaar (sc->code)); - if (s7_is_integer (init_val)) { - const s7_pointer end_expr= caadr (sc->code); - const s7_pointer code = sc->code; - s7_pointer 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); - set_curlet (sc, make_let (sc, sc->curlet)); - sc->args= add_slot_checked ( - sc, sc->curlet, caaar (code), - make_mutable_integer (sc, s7_integer_clamped_if_gmp (sc, init_val))); - set_loop_end (sc->args, s7_integer_clamped_if_gmp (sc, end_val)); - set_has_loop_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, goto 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_clamped_if_gmp (sc, init_val) == - s7_integer_clamped_if_gmp (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 (do_let_or_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 */ - { - const s7_int end = s7_integer_clamped_if_gmp (sc, end_val); - const s7_pointer body= cddr (code); - for (s7_pointer stepper= slot_value (sc->args); - 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. - */ - const s7_pointer form= sc->code; - s7_pointer end, init_val, end_val, code; +static void op_c_sc(s7_scheme *sc) +{ + sc->args = list_2(sc, lookup(sc, cadr(sc->code)), opt3_con(cdr(sc->code))); /* caddr(sc->code)) */ + sc->value = fn_proc(sc->code)(sc, sc->args); +} - /* 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)) */ - set_curlet (sc, make_let (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_clamped_if_gmp (sc, init_val) == - s7_integer_clamped_if_gmp (sc, end_val)) || - ((s7_integer_clamped_if_gmp (sc, init_val) > - s7_integer_clamped_if_gmp (sc, end_val)) && - (opt1_cfunc (caadr (code)) == sc->geq_2))) { - sc->value= sc->T; - sc->code = cdadr (code); - return (goto_safe_do_end_clauses); - } +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); +} - if (is_symbol (end)) let_set_dox_slot2 (sc->curlet, s7_t_slot (sc, end)); - 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 */ - { - const s7_pointer step_slot= let_dox_slot1 (sc->curlet); - slot_set_value ( - step_slot, make_mutable_integer (sc, integer (slot_value (step_slot)))); - set_loop_end (step_slot, s7_integer_clamped_if_gmp (sc, end_val)); - set_has_loop_end (step_slot); - } +static void op_c_aa(s7_scheme *sc) +{ + gc_protect_via_stack(sc, fx_call(sc, cdr(sc->code))); + set_gc_protected2(sc, fx_call(sc, cddr(sc->code))); + sc->value = list_2(sc, gc_protected1(sc), gc_protected2(sc)); + unstack_gc_protect(sc); /* fn_proc here is unsafe so clear stack first */ + sc->value = fn_proc(sc->code)(sc, sc->value); +} - 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)) { - sc->temp7= sc->unused; - return (goto_safe_do_end_clauses); - } - set_curlet (sc, - old_let); /* apparently s7_optimize can step on sc->curlet? */ - sc->temp7= sc->unused; - } +static inline void op_c_s(s7_scheme *sc) +{ + sc->args = list_1(sc, lookup_checked(sc, cadr(sc->code))); + sc->value = fn_proc(sc->code)(sc, sc->args); +} - if (is_null (cdddr ( - sc->code))) /* (do ((k 0 (+ k 1))) ((= k 2)) (set! sum (+ sum 1))) */ - { - const 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)))) /* so we're (set! symbol (fxable-expr...)) */ - { - const s7_pointer step_slot= let_dox_slot1 (sc->curlet); - if (slot_symbol (step_slot) != - cadr (body)) /* we're not setting the stepper */ - { - const s7_int endi = integer (let_dox2_value (sc->curlet)); - const s7_pointer fx_p = cddr (body); - const s7_pointer val_slot= s7_t_slot (sc, cadr (body)); - s7_int step = integer (slot_value (step_slot)); - const s7_pointer step_val= slot_value (step_slot); - - clear_mutable_integer (step_val); - do { - slot_set_value (val_slot, fx_call (sc, fx_p)); - slot_set_value ( - step_slot, - make_integer (sc, step= integer (slot_value (step_slot)) + 1)); - } while (step != endi); /* geq not needed here -- we're leq endi and - stepping by +1 all ints */ - - sc->value= sc->T; - sc->code = cdadr (code); - return (goto_safe_do_end_clauses); - } - } - } - clear_mutable_number (slot_value (let_dox_slot1 (sc->curlet))); - 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) { - const s7_pointer code= cdr (sc->code); - s7_pointer end_val, slot, old_let; - const s7_pointer end= opt1_any (code); /* caddr(opt2_pair(code)) */ - /* (do ... (set! args ...)) -- one line, syntactic */ - const s7_pointer init_val= fx_call (sc, cdaar (code)); - sc->value = init_val; - set_opt2_pair (code, caadr (code)); - if (is_symbol (end)) { - slot = s7_t_slot (sc, end); - end_val= slot_value (slot); - } - else { - slot= make_slot (sc, make_symbol (sc, "___end___", 9), - 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_let= sc->curlet; - set_curlet (sc, make_let (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)) { - const s7_pointer old_args= sc->args; - const s7_pointer 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_loop_end (sc->args, integer (let_dox2_value (sc->curlet))); - set_has_loop_end (sc->args); /* dotimes step is by 1 */ - sc->code= cdr (sc->code); - if (do_let_or_dotimes (sc, code, false)) - return (goto_do_end_clauses); /* not safe_do here */ - slot_set_value (sc->args, old_init); - set_curlet (sc, old_let); - 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 Inline void inline_op_apply_ss(s7_scheme *sc) /* called once in eval, sg: all time spent in proper_list check */ +{ + sc->args = lookup(sc, opt2_sym(sc->code)); + if (!s7_is_proper_list(sc, sc->args)) + error_nr(sc, sc->syntax_error_symbol, set_elist_2(sc, wrap_string(sc, "apply: improper list of arguments: ~S", 37), sc->args)); + 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(sc, sc->args); } -static bool -op_do_init_1 (s7_scheme* sc) { - /* initially from do_unchecked, sc->args=(), sc->value=sc->code, sc->code=vars - */ - 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) */ - 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 (true); /* 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 */ - sc->args= cdr (sc->args); /* init values */ - set_curlet (sc, make_let (sc, T_Let (sc->curlet))); - - /* run through sc->code and sc->args adding '( caar(car(code)) . car(args) ) - * to sc->curlet */ - sc->value= sc->nil; - for (s7_pointer vars= car (sc->code), inits= sc->args; is_not_null (inits); - vars= cdr (vars), inits= cdr (inits)) { - const s7_pointer slot= add_slot_unchecked_with_id ( - sc, sc->curlet, caar (vars), car_unchecked (inits)); - if (is_pair (cddar (vars))) /* else no incr expr, so ignore it henceforth */ - { - slot_set_expression (slot, cddar (vars)); - sc->value= cons_unchecked (sc, slot, sc->value); +static void op_apply_sa(s7_scheme *sc) +{ + const s7_pointer args = cdr(sc->code); + sc->args = fx_call(sc, cdr(args)); + if (!s7_is_proper_list(sc, sc->args)) + error_nr(sc, sc->syntax_error_symbol, set_elist_2(sc, wrap_string(sc, "apply: improper list of arguments: ~S", 37), sc->args)); + sc->code = lookup_global(sc, car(args)); + if (needs_copied_args(sc->code)) + sc->args = copy_proper_list(sc, sc->args); +} + +static void op_apply_sl(s7_scheme *sc) +{ + s7_pointer args = cdr(sc->code); + sc->args = fx_call(sc, cdr(args)); + sc->code = lookup_global(sc, car(args)); +} + +static bool op_pair_pair(s7_scheme *sc) +{ + if (!is_pair(car(sc->code))) /* (for-each (macro* (a . b) `(cons ,a ,b)) #(0 1) (list '(values +) -1)) sc->code is (-1) */ + { + clear_optimize_op(sc->code); + return(false); } - } - sc->args= cons (sc, sc->value= proper_list_reverse_in_place (sc, sc->value), - cadr (sc->code)); - sc->code= cddr (sc->code); - return (false); /* fall through */ + if (sc->stack_end >= sc->stack_resize_trigger - 8) /* -8 so the next two push_stacks don't hit the resize_trigger before we can check for cyclic code */ + check_for_cyclic_code(sc, sc->code); /* calls resize_stack */ + push_stack_no_args_direct(sc, OP_EVAL_ARGS); /* eval args goes immediately to cdr(sc->code) */ + /* don't put check_stack_size here! */ + push_stack_no_args(sc, OP_EVAL_ARGS, car(sc->code)); + sc->code = caar(sc->code); + return(true); } -static bool -op_do_init (s7_scheme* sc) /* looping through inits via eval */ +static bool op_pair_sym(s7_scheme *sc) { - if (is_multiple_value (sc->value)) /* (do ((i (values 1 2)))...) */ - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_2 ( - sc, wrap_string (sc, "do: variable initial value can't be ~S", 38), - set_ulist_1 (sc, sc->values_symbol, sc->value))); - return (!op_do_init_1 (sc)); + if (!is_symbol(car(sc->code))) /* (for-each (macro* (a . b) `(cons ,a ,b)) #(0 1) (list `+ -1)) ! sc->code is (-1) */ + { + clear_optimize_op(sc->code); + return(false); + } + sc->value = lookup_global(sc, car(sc->code)); + return(true); } -static void -op_do_unchecked (s7_scheme* sc) { - gc_protect_via_stack (sc, sc->code); - sc->code= cdr (sc->code); +static void op_eval_set3(s7_scheme *sc) +{ + push_stack(sc, is_null(cdr(sc->code)) ? OP_EVAL_SET3_NO_MV : OP_EVAL_SET3, sc->args, cdr(sc->code)); + sc->code = car(sc->code); + sc->cur_op = optimize_op(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))) */ - { - set_curlet (sc, make_let (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)); +static void op_eval_set3_no_mv(s7_scheme *sc) +{ + sc->args = pair_append(sc, sc->args, list_1(sc, sc->value)); + sc->code = pop_op_stack(sc); /* args = (ind... val), code = setter */ } -static bool -op_do_end (s7_scheme* sc) { - 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 void op_eval_args1(s7_scheme *sc) +{ + /* implicit_iterator and implicit_c_object, sc->code is ignored, so we can skip to apply in eval */ + sc->code = pop_op_stack(sc); + sc->args = cons(sc, sc->value, sc->args); + sc->args = proper_list_reverse_in_place(sc, sc->args); } -static goto_t -op_do_end_false (s7_scheme* sc) { - 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_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)); + /* there's only one push of eval_args2; we could check sc->args==sc->nil there and push eval_args6, timp mv misc ? but we have to check somewhere */ } -static goto_t -op_do_end_true (s7_scheme* sc) { - /* 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) */ - 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); -} - -/* -------------------------------- apply functions - * -------------------------------- */ -static inline s7_pointer -apply_c_function (s7_scheme* sc, s7_pointer func, - s7_pointer args) /* -------- C-based function -------- */ -{ - const s7_int len= proper_list_length (args); - if (len < c_function_min_args (func)) - error_nr ( - sc, sc->wrong_number_of_args_symbol, - set_elist_4 ( - sc, wrap_string (sc, "~A: not enough arguments: (~A~{~^ ~S~})", 39), - func, func, args)); - if (c_function_max_args (func) < len) - error_nr (sc, sc->wrong_number_of_args_symbol, - set_elist_4 ( - sc, - wrap_string (sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), - func, func, args)); - return (c_function_call (func) (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 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 s7_pointer -apply_c_function_unopt ( - s7_scheme* sc, s7_pointer func, - s7_pointer args) /* an experiment -- callgrind says this saves time */ +static void op_eval_args5(s7_scheme *sc) /* sc->value is the last arg, sc->code is the previous */ { - const s7_int len= proper_list_length (args); - if (len < c_function_min_args (func)) - error_nr ( - sc, sc->wrong_number_of_args_symbol, - set_elist_4 ( - sc, wrap_string (sc, "~A: not enough arguments: (~A~{~^ ~S~})", 39), - func, func, args)); - if (c_function_max_args (func) < len) - error_nr (sc, sc->wrong_number_of_args_symbol, - set_elist_4 ( - sc, - wrap_string (sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), - func, func, args)); - return (c_function_call (func) (sc, args)); + 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 void -apply_c_rst_no_req_function ( - s7_scheme* sc) /* -------- C-based function that can take any number of - arguments -------- */ +static bool eval_args_no_eval_args(s7_scheme *sc) { - sc->value= c_function_call (sc->code) (sc, sc->args); + if (is_any_macro(sc->value)) + { + if (!s7_is_proper_list(sc, cdr(sc->code))) + error_nr(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, fixup_macro_d(sc, OP_MACRO_D, sc->value)); + else + if (is_macro_star(sc->value)) + set_optimize_op(sc->code, fixup_macro_d(sc, OP_MACRO_STAR_D, sc->value)); + } + sc->code = sc->value; + return(true); + } + if (is_syntactic_pair(sc->code)) /* (define progn begin) (progn (display "hi") (+ 1 23)) */ + sc->cur_op = optimize_op(sc->code); + else + { + sc->cur_op = syntax_opcode(sc->value); + if ((is_symbol(car(sc->code))) && /* don't opt pair to syntax op if sc->value is actually an arg not the op! ((write and)) should not be op_and */ + ((car(sc->code) == syntax_symbol(sc->value)) || (lookup_global(sc, car(sc->code)) == sc->value))) + pair_set_syntax_op(sc->code, sc->cur_op); + /* weird that sc->cur_op setting above seems ok, but OP_PAIR_PAIR hangs?? */ + } + return(false); } -static void -apply_c_macro (s7_scheme* sc) /* -------- C-based macro -------- */ +static s7_pointer unbound_last_arg(s7_scheme *sc, s7_pointer head) { - check_c_macro_args (sc, sc->code, sc->args); - sc->code= c_macro_call (sc->code) (sc, sc->args); + /* save call-state before autoload/error-hook invocations */ + const s7_int loc = port_location(current_input_port(sc)); + const s7_pointer ops = op_stack_entry(sc); + const s7_pointer args = sc->args; /* maybe GC protect? */ + const s7_pointer val = check_autoload_and_error_hook(sc, head); + if (val == sc->undefined) + { + const bool probably_in_repl = ((location_to_line(loc) == 0) || (safe_strcmp("*stdin*", string_value(sc->file_names[location_to_file(loc)])))); + sc->w = (is_null(sc->args)) ? list_1(sc, head) : proper_list_reverse_in_place(sc, cons(sc, head, args)); + sc->w = cons_unchecked(sc, ops, sc->w); + error_nr(sc, sc->unbound_variable_symbol, + (probably_in_repl) ? + set_elist_3(sc, wrap_string(sc, "'~S is unbound in ~S", 20), head, sc->w) : + set_elist_5(sc, wrap_string(sc, "'~S is unbound in ~S (~A[~D])", 29), head, sc->w, + sc->file_names[location_to_file(loc)], + wrap_integer(sc, location_to_line(loc)))); + } + return(val); } -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) - syntax_error_nr (sc, "attempt to evaluate a circular list: ~S", 39, - sc->args); - if ((sc->safety > no_safety) && (tree_is_cyclic (sc, sc->args))) - error_nr (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)) - error_nr ( - sc, sc->wrong_number_of_args_symbol, - set_elist_4 ( - sc, wrap_string (sc, "~A: not enough arguments: (~A~{~^ ~S~})", 39), - sc->code, sc->code, sc->args)); - if (syntax_max_args (sc->code) < len) - error_nr (sc, sc->wrong_number_of_args_symbol, - set_elist_4 ( - sc, - wrap_string (sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), - sc->code, sc->code, sc->args)); - sc->cur_op= - 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); - set_current_code (sc, sc->code); - pair_set_syntax_op (sc->code, sc->cur_op); -} - -static void -apply_vector (s7_scheme* sc) /* -------- vector as applicable object -------- */ +static inline void eval_last_arg(s7_scheme *sc, s7_pointer head) /* one call, eval 91557 */ { - /* sc->code is the vector, sc->args is the list of indices */ - if (is_null (sc->args)) /* (#2d((1 2) (3 4))) */ - { - if (vector_length (sc->code) == 0) /* (#()) */ - error_nr ( - sc, make_symbol (sc, "inapplicable-vector", 19), - set_elist_2 ( - sc, - wrap_string ( - sc, "(~S) can't be treated as an implicit vector application", - 55), - sc->code)); - wrong_number_of_arguments_error_nr ( - sc, "implicit vector-ref needs an index argument: (~A)", 49, sc->code); - } - if ((is_null (cdr (sc->args))) && (s7_is_integer (car (sc->args))) && - (vector_rank (sc->code) == 1)) { - const s7_int index= s7_integer_clamped_if_gmp (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_error_nr (sc, sc->vector_ref_symbol, int_two, car (sc->args), - (index < 0) ? it_is_negative_string - : it_is_too_large_string); - } - else sc->value= s7i_vector_ref_1 (sc, sc->code, sc->args); -} - -static void -apply_string (s7_scheme* sc) /* -------- string as applicable object -------- */ -{ - if (!is_pair (sc->args)) { - if (string_length (sc->code) == 0) /* ("") */ - error_nr ( - sc, make_symbol (sc, "inapplicable-string", 19), - set_elist_2 ( - sc, - wrap_string ( - sc, "(~S) can't be treated as an implicit string application", - 55), - sc->code)); - error_nr ( - sc, sc->wrong_number_of_args_symbol, /* (a string") */ - set_elist_3 ( - sc, - wrap_string ( - sc, "impicit string-ref needs an index argument: (~S~{~^ ~S~})", - 57), - sc->code, sc->args)); - } - if (!is_null (cdr (sc->args))) - error_nr ( - sc, sc->wrong_number_of_args_symbol, - set_elist_3 ( - sc, - wrap_string (sc, "string ref: too many indices: (~S~{~^ ~S~})", 43), - sc->code, sc->args)); - - if (s7_is_integer (car (sc->args))) { - const s7_int index= s7_integer_clamped_if_gmp (sc, car (sc->args)); - if ((index >= 0) && (index < string_length (sc->code))) { - sc->value= chars[((uint8_t*) string_value (sc->code))[index]]; - return; + /* here we've reached the last arg, it is not a pair */ + if (!is_null(cdr(sc->code))) + improper_arglist_error_nr(sc); + if (is_symbol(head)) + { + s7_pointer val = lookup_unexamined(sc, head); + sc->code = (val) ? val : unbound_last_arg(sc, head); } - } - sc->value= string_ref_1 (sc, sc->code, car (sc->args)); + else sc->code = head; + 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 bool -apply_pair (s7_scheme* sc) /* -------- list as applicable object -------- */ +static s7_pointer unbound_args_last_arg(s7_scheme *sc, s7_pointer head) { - if (is_multiple_value (sc->code)) /* ((values + 2 3) 4) */ - { - /* car of values can be anything, so conjure up a new expression, and apply - * again */ - sc->args= pair_append ( - sc, cdr (sc->code), - T_Lst (sc->args)); /* can't use pair_append_in_place here */ - sc->code= car (sc->code); - return (false); - } - if (is_null (sc->args)) - wrong_number_of_arguments_error_nr ( - sc, "implicit list-ref needs an index argument: (~S)", 47, sc->code); - sc->value= list_ref_1 (sc, sc->code, car (sc->args)); /* (L 1) */ - if (!is_null (cdr (sc->args))) - sc->value= implicit_index_checked (sc, sc->code, sc->value, sc->args); - return (true); -} - -static void -apply_hash_table ( - s7_scheme* sc) /* -------- hash-table as applicable object -------- */ -{ - if (is_null (sc->args)) - wrong_number_of_arguments_error_nr ( - sc, "implicit hash-table-ref needs a key to lookup: (~S)", 51, - sc->code); - sc->value= s7_hash_table_ref (sc, sc->code, car (sc->args)); - if (!is_null (cdr (sc->args))) - sc->value= implicit_index_checked (sc, sc->code, sc->value, sc->args); -} - -static void -apply_let ( - s7_scheme* sc) /* -------- environment as applicable object -------- */ -{ - if (is_null (sc->args)) - wrong_number_of_arguments_error_nr ( - sc, "implicit let-ref needs a symbol to lookup: (~S)", 47, sc->code); - sc->value= let_ref (sc, sc->code, car (sc->args)); - if (is_pair (cdr (sc->args))) - sc->value= implicit_index_checked (sc, sc->code, sc->value, 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 - */ + /* save call-state before autoload/error-hook invocations */ + const s7_int loc = port_location(current_input_port(sc)); + const s7_pointer ops = op_stack_entry(sc); + const s7_pointer args = sc->args; /* maybe GC protect? */ + const s7_pointer value = sc->value; + const s7_pointer val = check_autoload_and_error_hook(sc, head); + if (val == sc->undefined) + { + const bool probably_in_repl = ((location_to_line(loc) == 0) || (safe_strcmp("*stdin*", string_value(sc->file_names[location_to_file(loc)])))); + sc->w = cons(sc, value, args); /* GC protect this info */ + sc->w = cons_unchecked(sc, head, sc->w); + sc->w = cons_unchecked(sc, ops, proper_list_reverse_in_place(sc, sc->w)); + error_nr(sc, sc->unbound_variable_symbol, + (probably_in_repl) ? + set_elist_3(sc, wrap_string(sc, "'~S is unbound in ~S", 20), head, sc->w) : + set_elist_5(sc, wrap_string(sc, "'~S is unbound in ~S (~A[~D])", 29), head, sc->w, + sc->file_names[location_to_file(loc)], wrap_integer(sc, location_to_line(loc)))); + } + return(val); } -static void -apply_iterator ( - s7_scheme* sc) /* -------- iterator as applicable object -------- */ -{ - if (!is_null (sc->args)) - error_nr ( - sc, sc->wrong_number_of_args_symbol, - set_elist_3 ( - sc, - wrap_string (sc, "iterator takes no arguments: (~A~{~^ ~S~})", 42), - sc->code, sc->args)); - sc->value= s7_iterate (sc, sc->code); -} - -static Inline void -inline_apply_lambda (s7_scheme* sc) /* -------- normal function (lambda), or - macro --------, called once in eval */ -{ /* load up the current args into the ((args) (lambda)) layout [via the current - environment] */ - s7_pointer pars, args, last_slot= slot_end; - const s7_pointer let= sc->curlet; - const s7_uint id = let_id (sc->curlet); - - for (pars= closure_pars (sc->code), args= T_Lst (sc->args); is_pair (pars); - pars= cdr (pars), - args = cdr (args)) /* closure_pars can be a symbol, for example */ - { - const s7_pointer sym= car (pars); - s7_pointer slot; - if (is_null (args)) - error_nr ( - sc, sc->wrong_number_of_args_symbol, - set_elist_5 ( - sc, - wrap_string ( - sc, "~S: not enough arguments: ((~S ~S ...)~{~^ ~S~})", 48), - closure_name (sc, sc->code), - (is_closure (sc->code)) - ? sc->lambda_symbol - : ((is_bacro (sc->code)) ? sc->bacro_symbol - : sc->macro_symbol), - closure_pars (sc->code), sc->args)); - slot= make_slot (sc, sym, T_Ext (car_unchecked (args))); - symbol_set_local_slot (sym, id, slot); - if (is_not_slot_end (last_slot)) slot_set_next (last_slot, slot); - else let_set_slots (let, slot); - last_slot= slot; - slot_set_next (slot, slot_end); - } - if (is_null (pars)) { - if (is_not_null (args)) - error_nr ( - sc, sc->wrong_number_of_args_symbol, - set_elist_5 ( - sc, - wrap_string (sc, "~S: too many arguments: ((~S ~S ...)~{~^ ~S~})", - 46), - closure_name (sc, sc->code), - (is_closure (sc->code)) - ? sc->lambda_symbol - : ((is_bacro (sc->code)) ? sc->bacro_symbol - : sc->macro_symbol), - closure_pars (sc->code), sc->args)); - } - else { - const s7_pointer slot= make_slot (sc, T_Sym (pars), args); - symbol_set_local_slot (pars, id, slot); - if (is_not_slot_end (last_slot)) slot_set_next (last_slot, slot); - else let_set_slots (let, slot); - slot_set_next (slot, slot_end); - } - sc->code= closure_body (sc->code); -} - -static void -op_f (s7_scheme* sc) /* sc->code: ((lambda () 32)) -> (let () 32) */ -{ - set_curlet (sc, make_let (sc, sc->curlet)); - sc->code= opt3_pair (sc->code); /* cddar */ -} - -static void -op_f_a (s7_scheme* sc) /* sc->code: ((lambda (x) (+ x 1)) i) -> (let ((x i)) (+ - x 1)) */ -{ - /* if caddar(sc->code) is fxable [(+ x 1) above], this could call fx and - * return to the top */ - set_curlet (sc, inline_make_let_with_slot (sc, sc->curlet, - opt3_sym (cdr (sc->code)), - fx_call (sc, cdr (sc->code)))); - sc->code= opt3_pair (sc->code); -} - -static void -op_f_aa (s7_scheme* sc) /* sc->code: ((lambda (x y) (+ x y)) i j) -> (let ((x i) - (y j)) (+ x y)) */ -{ - gc_protect_via_stack (sc, fx_call (sc, cdr (sc->code))); - set_curlet ( - sc, make_let_with_two_slots (sc, sc->curlet, opt3_sym (cdr (sc->code)), - gc_protected1 (sc), cadadr (car (sc->code)), - fx_call (sc, cddr (sc->code)))); - unstack_gc_protect (sc); - sc->code= opt3_pair (sc->code); -} - -static void -op_f_np (s7_scheme* sc) /* sc->code: ((lambda (x y) (+ x y)) (values i j)) -> - (let ((x i) (y j)) (+ x y)) after splice */ -{ - s7_pointer pars= cadar (sc->code); - const s7_pointer let = make_let (sc, sc->curlet); - if (is_pair (pars)) { - s7_pointer last_slot; - if (is_null (cdr (sc->code))) /* ((lambda (x) 21)) */ - error_nr ( - sc, sc->wrong_number_of_args_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, "not enough arguments: ((lambda ~S ...)~{~^ ~S~})", 48), - cadar (sc->code), cdr (sc->code))); - if (is_constant (sc, car (pars))) - error_nr (sc, sc->syntax_error_symbol, /* (lambda (a) 1) where 'a is - immutable (locally perhaps) */ - set_elist_4 (sc, - wrap_string (sc, - "lambda parameter ~S is a constant: " - "((lambda ~S ...)~{~^ ~S~})", - 61), - car (pars), cadar (sc->code), cdr (sc->code))); - - last_slot= - add_slot_unchecked_no_local_slot (sc, let, car (pars), sc->undefined); - for (pars= cdr (pars); is_pair (pars); pars= cdr (pars)) - last_slot= - add_slot_at_end_no_local (sc, last_slot, car (pars), sc->undefined); - /* last par might be rest par (dotted) */ - if (!is_null (pars)) { - last_slot= add_slot_at_end_no_local (sc, last_slot, pars, sc->undefined); - set_is_rest_slot (last_slot); + +static /* inline */ bool eval_args_last_arg(s7_scheme *sc) /* inline: no diff tmisc, small diff tmac (3) */ +{ + const s7_pointer head = 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(head)) + { + 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 = head; + return(true); } - } - /* check_stack_size(sc); */ - if ((sc->stack_end + 4) >= sc->stack_resize_trigger) resize_stack (sc); - push_stack ( - sc, OP_GC_PROTECT, let_slots (let), - cddr (sc->code)); /* not for gc-protection, but as implicit loop vars */ - push_stack (sc, OP_F_NP_1, let, sc->code); - sc->code= cadr (sc->code); -} - -static bool -op_f_np_1 (s7_scheme* sc) { - s7_pointer slot= gc_protected1 (sc); - if (is_multiple_value (sc->value)) { - s7_pointer p, last_slot= slot; - for (p= sc->value; (is_pair (p)) && (is_not_slot_end (slot)); - p= cdr (p), last_slot= slot, slot= next_slot (slot)) - if (is_rest_slot (slot)) { - if (slot_value (slot) == sc->undefined) - slot_set_value (slot, copy_proper_list (sc, p)); - else - slot_set_value (slot, pair_append (sc, slot_value (slot), - copy_proper_list (sc, p))); - p= sc->nil; - break; - } - else slot_set_value (slot, car (p)); - if (is_pair (p)) - error_nr ( - sc, sc->wrong_number_of_args_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, "not enough arguments: ((lambda ~S ...)~{~^ ~S~})", 48), - cadar (sc->code), cdr (sc->code))); - slot= last_slot; /* snd-test 22 grani */ - } - else /* not mv */ - if (!is_rest_slot (slot)) slot_set_value (slot, sc->value); - else if (slot_value (slot) == sc->undefined) - slot_set_value (slot, list_1 (sc, sc->value)); - else - slot_set_value ( - slot, pair_append (sc, slot_value (slot), list_1 (sc, sc->value))); - { - const s7_pointer arg= gc_protected2 (sc); - if (is_pair (arg)) { - if ((!is_not_slot_end (next_slot (slot))) && (!is_rest_slot (slot))) - error_nr ( - sc, sc->wrong_number_of_args_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, "too many arguments: ((lambda ~S ...)~{~^ ~S~})", 46), - cadar (sc->code), cdr (sc->code))); - set_gc_protected1 (sc, (is_rest_slot (slot)) ? slot : next_slot (slot)); - set_gc_protected2 (sc, cdr (arg)); - push_stack_direct (sc, OP_F_NP_1); /* sc->args=e, sc->code from start */ - sc->code= car (arg); - return (true); + /* get the last arg */ + if (is_symbol(head)) + { + s7_pointer val = lookup_unexamined(sc, head); + sc->code = (val) ? val : unbound_args_last_arg(sc, head); } - } - if (is_not_slot_end (next_slot (slot))) { - if (!is_rest_slot (next_slot (slot))) - error_nr ( - sc, sc->wrong_number_of_args_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, "not enough arguments: ((lambda ~S ...)~{~^ ~S~})", 48), - cadar (sc->code), cdr (sc->code))); - if (slot_value (next_slot (slot)) == sc->undefined) - slot_set_value (next_slot (slot), sc->nil); - } - { - s7_pointer let= sc->args; - let_set_id (let, ++sc->let_number); - set_curlet (sc, let); - update_symbol_ids (sc, let); - } - sc->code= cddar (sc->code); - unstack_gc_protect (sc); - return (false); -} - -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->code = head; + /* 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 inline void eval_args_pair_car(s7_scheme *sc) +{ + const s7_pointer code = cdr(sc->code); + if (sc->stack_end >= sc->stack_resize_trigger) + check_for_cyclic_code(sc, sc->code); /* calls resize_stack */ + if (is_null(code)) + push_stack_no_code(sc, OP_EVAL_ARGS2, sc->args); 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)) - error_nr (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))) - error_nr (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, const s7_pointer sym, - s7_pointer val, s7_pointer slot, - bool check_rest) { - if (val == sc->no_value) val= sc->unspecified; - if (sym == slot_symbol (slot)) return (star_set (sc, slot, val, check_rest)); - for (s7_pointer slot1= let_slots (sc->curlet) /* presumably the arglist */; - is_not_slot_end (slot1); slot1= next_slot (slot1)) - if (slot_symbol (slot1) == sym) - return (star_set (sc, slot1, val, check_rest)); - return (sc->no_value); -} - -static s7_pointer -lambda_star_set_args (s7_scheme* sc) { - s7_pointer arg_vals= sc->args, rest_key= sc->nil; - const s7_pointer code= sc->code, args= sc->args; - s7_pointer slot = let_slots (sc->curlet); - s7_pointer pars = closure_pars (code); - const bool allow_other_keys= ((is_pair (pars)) && (allows_other_keys (pars))); - - while ((is_pair (pars)) && (is_pair (arg_vals))) { - if (car (pars) == - sc->rest_keyword) /* 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 */ - pars= cdr (pars); - if ((is_symbol_and_keyword (car (arg_vals))) && - (is_pair (cdr (arg_vals))) && - (keyword_symbol (car (arg_vals)) == car (pars))) - error_nr ( - 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 (pars), cadr (arg_vals))); - lambda_star_argument_set_value ( - sc, car (pars), - (in_heap (arg_vals)) ? arg_vals : copy_proper_list (sc, arg_vals), - slot, false); /* sym5 :rest bug */ - rest_key= sc->rest_keyword; - arg_vals= cdr (arg_vals); - pars = cdr (pars); - slot = next_slot (slot); - } - else { - const s7_pointer arg_val= car (arg_vals); - if (is_symbol_and_keyword (arg_val)) { - if (!is_pair (cdr (arg_vals))) { - if (!sc->accept_all_keyword_arguments) - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_4 (sc, keyword_value_missing_string, - closure_name (sc, code), arg_vals, args)); - slot_set_value (slot, arg_val); - set_checked_slot (slot); - arg_vals= cdr (arg_vals); - } - else { - const s7_pointer sym= keyword_symbol (arg_val); - if (lambda_star_argument_set_value (sc, sym, cadr (arg_vals), 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 - */ - arg_vals= cddr (arg_vals); - else { - if (!sc->accept_all_keyword_arguments) - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_4 ( - sc, - wrap_string (sc, "~A: unknown key: ~S in ~S", 25), - closure_name (sc, code), arg_vals, args)); - slot_set_value (slot, arg_val); - set_checked_slot (slot); - arg_vals= cdr (arg_vals); - pars = cdr (pars); - slot = next_slot (slot); - } - continue; - } - arg_vals= cddr (arg_vals); - } - slot= next_slot (slot); - } - else /* not a key/value pair */ - { - if (is_checked_slot (slot)) - error_nr (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 (arg_vals)); - slot = next_slot (slot); - arg_vals= cdr (arg_vals); - } - pars= cdr (pars); + { + if (!is_pair(code)) /* (= 0 '(1 . 2) . 3) */ + improper_arglist_error_nr(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); } - } - /* (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 */ + sc->code = car(sc->code); +} - /* check for trailing args with no :rest arg */ - if (is_not_null (arg_vals)) { - if ((is_not_null (pars)) || (rest_key == sc->rest_keyword)) { - if (is_symbol (pars)) { - if ((is_symbol_and_keyword (car (arg_vals))) && - (is_pair (cdr (arg_vals))) && - (keyword_symbol (car (arg_vals)) == pars)) - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, "can't set rest argument ~S to ~S via keyword", 44), - pars, cadr (arg_vals))); - slot_set_value ( - slot, (in_heap (arg_vals)) - ? arg_vals - : copy_proper_list (sc, arg_vals)); /* sym5 :rest bug */ - } +static bool eval_car_pair(s7_scheme *sc) +{ + const s7_pointer code = sc->code, head = car(sc->code); + + /* evaluate the inner list but that list can be circular: head: #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); + + if (is_symbol_and_syntactic(car(head))) + /* 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 (!no_int_opt(code)) + { + /* lambda */ + if ((car(head) == sc->lambda_symbol) && /* ((lambda ...) expr) */ + (is_pair(cddr(head))) && (s7_is_proper_list(sc, cddr(head)))) /* not dotted! */ + { + const s7_pointer args = cadr(head); + set_opt3_pair(code, cddr(head)); /* lambda body */ + if ((is_null(args)) && (is_null(cdr(code)))) + { + set_optimize_op(code, OP_F); /* ((lambda () ...)) */ + return(false); + } + if (is_pair(args)) + { + if ((is_normal_symbol(car(args))) && (!is_constant(sc, car(args))) && + (is_pair(cdr(code))) && (is_fxable(sc, cadr(code)))) + { + set_opt3_sym(cdr(code), car(args)); /* new curlet symbol #1 (first arg of lambda) */ + if ((is_null(cdr(args))) && (is_null(cddr(code)))) + { + fx_annotate_args(sc, cdr(code), sc->curlet); /* ((lambda (x) ...) expr) */ + set_optimize_op(code, OP_F_A); + return(false); + } + if ((is_pair(cdr(args))) && (is_pair(cddr(code))) && (is_fxable(sc, caddr(code))) && + (is_null(cddr(args))) && (is_null(cdddr(code))) && + (is_normal_symbol(cadr(args))) && (!is_constant(sc, cadr(args))) && (car(args) != cadr(args))) + { + fx_annotate_args(sc, cdr(code), sc->curlet); + set_optimize_op(code, OP_F_AA); /* ((lambda (x y) ...) expr expr) */ + return(false); + }} + set_optimize_op(code, OP_F_NP); + }} + set_no_int_opt(code); + } + /* ((if op1 op2) args...) is another somewhat common case */ + push_stack_no_args(sc, OP_EVAL_ARGS, code); + sc->code = head; + if (!no_cell_opt(head)) + { + /* if */ + if ((car(head) == 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, head); + if ((fx_function[optimize_op(head)]) && + (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(head)]); + if (is_null(cddr(code))) + set_optimize_op(code, OP_A_A); + else set_optimize_op(code, ((is_symbol(cadr(code))) && (!is_pair(caddr(code))) && (!is_normal_symbol(caddr(code)))) ? OP_A_SC : OP_A_AA); + return(false); /* goto eval in trailers */ + }} + set_no_cell_opt(head); + } + sc->cur_op = (opcode_t)symbol_syntax_op_checked(sc->code); + pair_set_syntax_op(sc->code, sc->cur_op); + return(true); + } + push_stack_no_args(sc, OP_EVAL_ARGS, code); + if ((is_pair(cdr(code))) && (is_optimized(head))) + { + if ((fx_function[optimize_op(head)]) && + (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(head)]); + if (is_null(cddr(code))) + set_optimize_op(code, OP_A_A); + else set_optimize_op(code, ((is_symbol(cadr(code))) && (!is_pair(caddr(code))) && (!is_normal_symbol(caddr(code)))) ? OP_A_SC : OP_A_AA); + sc->code = head; + 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)); + } + /* possible op 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 { - if (!allow_other_keys) /* ((lambda* (a) a) :a 1 2) */ - error_nr (sc, sc->wrong_number_of_args_symbol, - set_elist_4 ( - sc, - wrap_string ( - sc, "too many arguments: (~S ~S ...)~{~^ ~S~})", 41), - (is_closure_star (code)) ? sc->lambda_star_symbol - : ((is_bacro_star (sc->code)) - ? sc->bacro_star_symbol - : sc->macro_star_symbol), - closure_pars (code), args)); - /* check trailing args for repeated keys or keys with no values or values - * with no keys */ - while (is_pair (arg_vals)) { - if ((!is_symbol_and_keyword ( - car (arg_vals))) || /* ((lambda* (a :allow-other-keys) a) :a 1 - :b 2 3) */ - (!is_pair (cdr ( - arg_vals)))) /* ((lambda* (a :allow-other-keys) a) :a 1 :b) */ - error_nr ( - 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), arg_vals)); - slot= symbol_to_local_slot (sc, keyword_symbol (car (arg_vals)), - sc->curlet); - if ((is_slot (slot)) && (is_checked_slot (slot))) - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_3 (sc, parameter_set_twice_string, - slot_symbol (slot), sc->args)); - arg_vals= cddr (arg_vals); - } + else set_optimize_op(code, OP_PAIR_PAIR); + push_stack_no_args(sc, OP_EVAL_ARGS, head); + sc->code = car(head); + return(false); +} + + +/* ---------------- reader funcs for eval ---------------- */ +static void back_up_stack(s7_scheme *sc) +{ + opcode_t top_op = stack_top_op(sc); + if (top_op == OP_READ_DOT) + { + pop_stack(sc); + top_op = stack_top_op(sc); } - } - return (sc->nil); -} - -static inline bool -lambda_star_default (s7_scheme* sc) { - for (s7_pointer slot= sc->args; is_not_slot_end (slot); - slot = next_slot (slot)) { - if ((slot_value (slot) == - sc->undefined) && /* trouble: (lambda* ((e #))...) */ - (slot_has_expression (slot)) && /* if default val is not a pair or a - symbol, this is false */ - (!is_checked_slot (slot))) { - const s7_pointer val= slot_expression (slot); - if (is_symbol (val)) { - slot_set_value (slot, lookup_checked (sc, val)); - if (slot_value (slot) == 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 ( - slot, s7_symbol_local_value (sc, val, let_outlet (sc->curlet))); - if (slot_value (slot) == sc->undefined) - syntax_error_nr (sc, "lambda* defaults: ~A is unbound", 31, - slot_symbol (slot)); - } - } - else if (!is_pair (val)) slot_set_value (slot, val); - else if (is_quote (sc, car (val))) { - if ((!is_pair (cdr (val))) || /* (lambda* ((a (quote))) a) or (lambda* - ((a (quote 1 1))) a) etc */ - (is_pair (cddr (val)))) - syntax_error_nr (sc, "lambda* default: ~A is messed up", 32, val); - slot_set_value (slot, cadr (val)); + if ((top_op == OP_READ_VECTOR) || (top_op == OP_READ_BYTE_VECTOR) || (top_op == OP_READ_INT_VECTOR) || + (top_op == OP_READ_FLOAT_VECTOR) || (top_op == OP_READ_COMPLEX_VECTOR)) + { + pop_stack(sc); + top_op = stack_top_op(sc); + } + if (top_op == OP_READ_QUOTE) + pop_stack(sc); +} + +static token_t read_block_comment(s7_scheme *sc, s7_pointer port) +{ + /* block comments in #| ... |# + * since we ignore everything until the |#, internal semicolon comments are ignored, meaning that ;|# is as effective as |# + */ + if (is_file_port(port)) + { + char last_char = ' '; + while (true) + { + int32_t c = fgetc(port_file(port)); + if (c == EOF) + error_nr(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(port)++; + } + return(token(sc)); + } + { + const char *orig_str = (const char *)(port_data(port) + port_position(port)); + const char *pend = (const char *)(port_data(port) + port_data_size(port)); + const char *str = orig_str; + const char *p; + while (true) + { + p = strchr(str, (int)'|'); + if ((!p) || (p >= pend)) + { + port_position(port) = port_data_size(port); + error_nr(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(port) += (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(port)++; + str = (const char *)(p + 1); + } + else break; + }} + return(token(sc)); +} + +static token_t read_excl_comment(s7_scheme *sc, s7_pointer port) +{ + /* block comments in #! ... !# + * this is needed when an input file is treated as a script: + #!/home/bil/cl/snd + !# + (format #t "a test~%") + (exit) + */ + /* make it possible to override #! handling */ + for (s7_pointer reader = slot_value(sc->sharp_readers); is_pair(reader); reader = cdr(reader)) + if (s7_character(caar(reader)) == '!') + { + sc->strbuf[0] = (unsigned char)'!'; + return(token_sharp_const); /* next stage notices any errors */ } - else { - push_stack (sc, OP_LAMBDA_STAR_DEFAULT, slot, sc->code); - sc->code= val; - return (true); /* goto eval */ + /* not #! as block comment (for Guile I guess) */ + { + int32_t c; + char last_char = ' '; + while ((c = inchar(port)) != EOF) + { + if ((c == '#') && (last_char == '!')) break; + last_char = c; } - } - } - return (false); /* goto BEGIN */ -} - -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)) - syntax_error_nr (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)) return (true); - pop_stack_no_op (sc); - sc->code= T_Pair (closure_body (sc->code)); - return (false); /* goto BEGIN */ -} - -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)) return (true); /* else fall_through */ - pop_stack_no_op (sc); /* get original args and code back */ - } - sc->code= closure_body (sc->code); - return (false); /* goto BEGIN */ -} - -static inline bool -apply_safe_closure_star_1 ( - s7_scheme* sc) /* -------- define* (lambda*) -------- */ -{ - /* 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 (s7_pointer slot= let_slots (sc->curlet); is_not_slot_end (slot); - slot = next_slot (slot)) { - clear_checked_slot (slot); - slot_set_value (slot, 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 (s7_pointer slot= let_slots (sc->curlet); is_not_slot_end (slot); - slot = next_slot (slot)) { - clear_checked_slot (slot); - slot_set_value (slot, (slot_defaults (slot)) ? sc->undefined - : slot_expression (slot)); + if (c == EOF) + error_nr(sc, sc->read_error_symbol, + set_elist_1(sc, wrap_string(sc, "unexpected end of input while reading #!", 40))); } - return (set_star_args (sc, slot_pending_value (let_slots (sc->curlet)))); -} - -static bool -apply_unsafe_closure_star_1 (s7_scheme* sc) { - s7_pointer pars, top= sc->nil; - for (pars= closure_pars (sc->code); is_pair (pars); pars= cdr (pars)) { - const s7_pointer par= car (pars); - if (is_pair (par)) /* parameter has a default value */ - { - s7_pointer slot; - const s7_pointer val= cadr (par); - if ((!is_pair (val)) && (!is_symbol (val))) - slot= add_slot_checked (sc, sc->curlet, car (par), val); - else { - add_slot (sc, sc->curlet, car (par), sc->undefined); - slot= let_slots (sc->curlet); - slot_set_expression (slot, val); + return(token(sc)); +} + +static token_t read_sharp(s7_scheme *sc, s7_pointer port) +{ + const int32_t c = inchar(port); /* inchar can return EOF, so it can't be used directly as an index into the digits array */ + switch (c) + { + case EOF: + error_nr(sc, sc->read_error_symbol, set_elist_1(sc, wrap_string(sc, "unexpected '#' at end of input", 30))); + break; + + case '(': /* #(...) */ + sc->read_dims = int_one; /* for read_expression! */ + return(token_vector); + + case 'i': /* #i(...) */ + if (read_sharp(sc, port) == token_vector) + return(token_int_vector); + backchar('i', port); + break; + + case 'r': /* #r(...) */ + if (read_sharp(sc, port) == token_vector) + return(token_float_vector); + backchar('r', port); + break; + + case 'c': /* #c(...) */ + if (read_sharp(sc, port) == token_vector) + return(token_complex_vector); + backchar('c', port); + break; + + case 'u': /* #u(...) or #u8(...) */ + if (s7_peek_char(sc, port) == chars[(int32_t)('8')]) /* backwards compatibility: #u8(...) == #u(...) */ + { + const int32_t bc = inchar(port); + if (s7_peek_char(sc, port) == chars[(int32_t)('(')]) + { + inchar(port); + sc->read_dims = int_one; /* for read_expression! */ + return(token_byte_vector); + } + backchar(bc, port); + } + if (read_sharp(sc, port) == token_vector) + return(token_byte_vector); + backchar('u', port); + 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 = digits[c]; + int32_t d = 0, loc = 0; + sc->strbuf[loc++] = (unsigned char)c; + while (true) + { + s7_int dig; + d = inchar(port); + if (d == EOF) + error_nr(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; + error_nr(sc, sc->read_error_symbol, + set_elist_3(sc, wrap_string(sc, "reading #~A...: ~D must be a positive integer", 45), + wrap_string(sc, sc->strbuf, loc), + wrap_integer(sc, dims))); + } + if (dims > sc->max_vector_dimensions) + { + sc->strbuf[loc++] = (unsigned char)d; + sc->strbuf[loc + 1] = '\0'; + error_nr(sc, sc->read_error_symbol, + set_elist_4(sc, wrap_string(sc, "reading #~A...: ~D is too large, (*s7* 'max-vector-dimensions): ~D", 66), + wrap_string(sc, sc->strbuf, loc), + wrap_integer(sc, dims), wrap_integer(sc, sc->max_vector_dimensions))); + } + sc->strbuf[loc++] = (unsigned char)d; + } + sc->strbuf[loc++] = d; + if ((d == 'd') || (d == 'i') || (d == 'r') || (d == 'u') || (d == 'c')) + { + const int32_t chr = inchar(port); + if (chr == EOF) + error_nr(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)chr; + if (chr == '(') + { + sc->read_dims = make_integer(sc, dims); /* for read_expression! */ + if (d == 'd') return(token_vector); + if (d == 'r') return(token_float_vector); + if (d == 'c') return(token_complex_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], port); } - if (is_null (top)) top= slot; + break; + +#if !DISABLE_DEPRECATED + 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. + */ + sc->strbuf[0] = ':'; + return(token_atom); +#endif + + case '!': /* I don't think #! is special anymore -- maybe remove this code? */ + return(read_excl_comment(sc, port)); + + case '|': + return(read_block_comment(sc, port)); } - else if (!is_keyword (par)) - add_slot_checked (sc, sc->curlet, par, sc->F); /* checked tlimit */ - else if (par == sc->rest_keyword) /* else it's :allow-other-keys? */ + 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 port) +{ + /* here we probably should check for symbol names that start with "@": + (define-macro (hi @foo) `(+ ,@foo 1)): (hi 2) -> ;foo: unbound variable + but (define-macro (hi .foo) `(+ ,.foo 1)): (hi 2) -> 3 + and ambiguous: (define-macro (hi @foo . foo) `(list ,@foo)) + what about , @foo -- is the space significant? We accept ,@ foo. (Currently , @ says unbound variable @foo). + */ + const int32_t c = inchar(port); + if (c == '@') + return(token_at_mark); + if (c == EOF) { - set_is_rest_slot ( - add_slot_checked (sc, sc->curlet, cadr (pars), sc->nil)); - pars= cdr (pars); + sc->strbuf[0] = ','; /* was '@' which doesn't make any sense */ + return(token_comma); /* was token_atom, which also doesn't seem sensible */ } - } - if (is_symbol (pars)) - set_is_rest_slot ( - add_slot_checked (sc, sc->curlet, pars, sc->nil)); /* set up rest arg */ - let_set_slots (sc->curlet, reverse_slots (let_slots (sc->curlet))); - return (set_star_args (sc, top)); + backchar(c, port); + return(token_comma); } -static void -apply_macro_star_1 (s7_scheme* sc) { - /* here the defaults (if any) are not evalled, and there is not an existing - * let */ - s7_pointer pars; - for (pars= closure_pars (sc->code); is_pair (pars); pars= cdr (pars)) { - const s7_pointer par= car (pars); - 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->rest_keyword) { - set_is_rest_slot ( - add_slot_checked (sc, sc->curlet, cadr (pars), sc->nil)); - pars= cdr (pars); +static token_t read_dot(s7_scheme *sc, s7_pointer port) +{ + const int32_t c = inchar(port); + if (c != EOF) + { + backchar(c, port); + if ((!char_ok_in_a_name[c]) && (c != 0)) + return(token_dot); } - } - if (is_symbol (pars)) - set_is_rest_slot (add_slot_checked (sc, sc->curlet, pars, sc->nil)); - let_set_slots (sc->curlet, reverse_slots (let_slots (sc->curlet))); - lambda_star_set_args (sc); - sc->code= T_Pair (closure_body (sc->code)); -} - -static void -clear_absolutely_all_optimizations (s7_pointer p) { - if ((is_pair (p)) && (!is_matched_pair (p))) { - clear_has_fx (p); - clear_optimized (p); - clear_optimize_op (p); - set_match_pair (p); - clear_absolutely_all_optimizations (cdr (p)); - clear_absolutely_all_optimizations (car (p)); - } + 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 void -clear_matches (s7_pointer p) { - if ((is_pair (p)) && (is_matched_pair (p))) { - clear_match_pair (p); - clear_matches (car (p)); - clear_matches (cdr (p)); - } +static token_t token(s7_scheme *sc) /* inline here is slower */ +{ + const int32_t 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 void -apply_macro (s7_scheme* sc) /* this is not from the reader, so treat expansions - here as normal macros */ +static int32_t read_x_char(s7_scheme *sc, int32_t i, s7_pointer port) { - check_stack_size (sc); - if (closure_arity_to_int (sc, sc->code) < 0) { - clear_absolutely_all_optimizations (sc->args); /* desperation... */ - clear_matches (sc->args); - } - push_stack_op_let (sc, OP_EVAL_MACRO); - set_curlet (sc, - inline_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); - set_curlet ( - sc, - 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); - set_curlet (sc, 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); - set_curlet (sc, 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 */ - check_stack_size (sc); - set_curlet (sc, inline_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); - set_curlet (sc, make_let (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) /* called in eval and below, tlamb */ -{ - const s7_pointer func= opt1_lambda (code); - const s7_pointer val = fx_call (sc, cdr (code)); - if ((is_symbol_and_keyword (val)) && (!sc->accept_all_keyword_arguments)) - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_4 (sc, keyword_value_missing_string, - closure_name (sc, func), val, sc->args)); - set_curlet (sc, 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) { - const s7_pointer func= op_safe_closure_star_a1 (sc, code); - s7_pointer p = cdr (closure_pars (func)); - if (is_pair (p)) - for (s7_pointer slot= next_slot (let_slots (closure_let (func))); - is_pair (p); p= cdr (p), slot= next_slot (slot)) { - if (is_pair (car (p))) { - s7_pointer defval= cadar (p); - slot_set_value (slot, (is_pair (defval)) ? cadr (defval) : defval); - } - else slot_set_value (slot, sc->F); - symbol_set_local_slot (slot_symbol (slot), let_id (sc->curlet), slot); - } -} - -static void -op_safe_closure_star_ka (s7_scheme* sc, - s7_pointer code) /* two args, but k=arg key, key has - been checked. no trailing pars */ -{ - const s7_pointer func= opt1_lambda (code); - set_curlet (sc, 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) */ - const s7_pointer func= opt1_lambda (code); - s7_pointer arg2, arg1= fx_call (sc, cdr (code)); - sc->w= arg1; /* weak GC protection */ - arg2 = fx_call (sc, cddr (code)); - - if (is_symbol_and_keyword (arg1)) { - if (keyword_symbol (arg1) == slot_symbol (let_slots (closure_let (func)))) { - arg1= arg2; - arg2= cadr (closure_pars (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_pars (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) - error_nr ( - 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_symbol_and_keyword (arg2)) && - (!sc->accept_all_keyword_arguments)) - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_4 (sc, keyword_value_missing_string, - closure_name (sc, func), arg2, code)); - set_curlet (sc, - update_let_with_two_slots (sc, closure_let (func), arg1, arg2)); - sc->code= T_Pair (closure_body (func)); -} - -static bool -call_lambda_star (s7_scheme* sc, s7_pointer code, s7_pointer arglist) { - bool target; - sc->code= opt1_lambda (code); - target = apply_safe_closure_star_1 (sc); - if (!in_heap (arglist)) clear_safe_list_in_use (sc, arglist); - return (target); -} - -static bool -op_safe_closure_star_3a (s7_scheme* sc, s7_pointer code) { - const s7_pointer func= opt1_lambda (code), arg1= fx_call (sc, cdr (code)); - s7_pointer arg2, arg3; - gc_protect_via_stack (sc, arg1); - arg2= fx_call (sc, cddr (code)); - set_gc_protected2 (sc, arg2); - arg3= fx_call (sc, cdddr (code)); - if ((is_symbol_and_keyword (arg1)) || (is_symbol_and_keyword (arg2)) || - (is_symbol_and_keyword (arg3))) { - s7_pointer arglist= make_safe_list (sc, 3); - sc->args = arglist; - set_car (arglist, arg1); - set_cadr (arglist, arg2); - set_caddr (arglist, arg3); - unstack_gc_protect (sc); - return (call_lambda_star (sc, code, - arglist)); /* this clears safe_list_in_use */ - } - set_curlet (sc, update_let_with_three_slots (sc, closure_let (func), arg1, - arg2, arg3)); - unstack_gc_protect (sc); - sc->code= T_Pair (closure_body (func)); - if_pair_set_up_begin_unchecked (sc); - 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) { - s7_pointer arglist= safe_list_1 (sc); - sc->args = arglist; - set_car (arglist, fx_call (sc, cdr (code))); - return (call_lambda_star (sc, code, arglist)); /* clears safe_list_in_use */ -} - -static bool -op_safe_closure_star_na_2 (s7_scheme* sc, s7_pointer code) { - s7_pointer arglist= safe_list_2 (sc); - sc->args = arglist; - set_car (arglist, fx_call (sc, cdr (code))); - set_cadr (arglist, fx_call (sc, cddr (code))); - return (call_lambda_star (sc, code, arglist)); /* clears safe_list_in_use */ -} - -static inline bool -op_safe_closure_star_na (s7_scheme* sc, - s7_pointer code) /* called once in eval, clo */ -{ - s7_pointer arglist= safe_list_if_possible (sc, opt3_arglen (cdr (code))); - sc->args = arglist; - for (s7_pointer p= arglist, old_args= cdr (code); is_pair (p); - p= cdr (p), old_args= cdr (old_args)) - set_car (p, fx_call (sc, old_args)); - return (call_lambda_star (sc, code, arglist)); /* clears safe_list_in_use */ -} - -static void -op_closure_star_ka (s7_scheme* sc, s7_pointer code) { - const s7_pointer func= opt1_lambda (code); - const s7_pointer par = car (closure_pars (func)); - sc->value = fx_call (sc, cddr (code)); - set_curlet (sc, inline_make_let_with_slot (sc, closure_let (func), - (is_pair (par)) ? car (par) : par, - sc->value)); - sc->code= T_Pair (closure_body (func)); -} - -static void -op_closure_star_a (s7_scheme* sc, s7_pointer code) { - s7_pointer par1; - const s7_pointer func= opt1_lambda (code); - sc->value = fx_call (sc, cdr (code)); - if ((is_symbol_and_keyword (sc->value)) && - (!sc->accept_all_keyword_arguments)) - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_4 (sc, keyword_value_missing_string, - closure_name (sc, opt1_lambda (code)), sc->value, - code)); - par1= car (closure_pars (func)); - set_curlet (sc, make_let_with_slot (sc, closure_let (func), - (is_pair (par1)) ? car (par1) : par1, - sc->value)); - if (closure_star_arity_to_int (sc, func) > 1) { - s7_pointer last_slot= let_slots (sc->curlet); - const s7_int id = let_id (sc->curlet); - for (s7_pointer p1= cdr (closure_pars (func)); is_pair (p1); p1= cdr (p1)) { - s7_pointer par= car (p1); - if (is_pair (par)) - last_slot= add_slot_checked_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_checked_at_end (sc, id, last_slot, par, sc->F); + /* 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 + */ + for (int32_t c_ctr = 0; ; c_ctr++) + { + int32_t d1, d2, c = inchar(port); + if (c == '"') /* "\x" -> error, "\x44" or "\x44;" -> #\D */ + { + if (c_ctr == 0) /* "\x" */ + read_error_nr(sc, "unknown backslash usage -- perhaps you meant two backslashes?"); + backchar(c, port); /* "\x44" I think -- not sure about this -- Guile is happy but I think it contradicts r7rs.pdf */ + return(i); + } + if (c == ';') + { + if (c_ctr == 0) /* "\x;" */ + read_error_nr(sc, "unknown backslash usage -- perhaps you meant two backslashes?"); + return(i); /* "\x44;" */ + } + if (c == EOF) /* "\x */ + { + read_error_nr(sc, "# in midst of hex-char"); + return(i); + } + d1 = digits[c]; + if (d1 >= 16) /* "\x4H", also "\x44H" which Guile thinks is ok -- it apparently reads 2 digits and quits? */ + { + if (c_ctr == 0) + read_error_nr(sc, "unknown backslash usage -- perhaps you meant two backslashes?"); + backchar(c, port); + return(i); + } + /* perhaps if c_ctr==0 error else backchar + return(i??) */ + + c = inchar(port); + if (c == '"') /* "\x4" */ + { + sc->strbuf[i++] = (unsigned char)d1; + backchar((char)c, port); + return(i); + } + if (c == ';') /* "\x4;" */ + { + sc->strbuf[i++] = (unsigned char)d1; + return(i); + } + if (c == EOF) /* "\x4 */ + { + read_error_nr(sc, "# in midst of hex-char"); + return(i); + } + d2 = digits[c]; + if (d2 >= 16) + { + if (c_ctr == 0) + read_error_nr(sc, "unknown backslash usage -- perhaps you meant two backslashes?"); + backchar(c, port); + return(i); + } + sc->strbuf[i++] = (unsigned char)(16 * d1 + d2); } - } - sc->code= T_Pair (closure_body (func)); + return(i); } -static inline bool -op_closure_star_na (s7_scheme* sc, s7_pointer code) { - /* check_stack_size(sc); */ - if (is_pair (cdr (code))) { - sc->w = cdr (code); /* args aren't evaluated yet */ - sc->args= make_list (sc, opt3_arglen (cdr (code)), sc->unused); - for (s7_pointer 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->unused; - } - else sc->args= sc->nil; - sc->code= opt1_lambda (code); - set_curlet (sc, inline_make_let (sc, closure_let (sc->code))); - return (apply_unsafe_closure_star_1 (sc)); +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 = 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 -define1_caller (s7_scheme* sc) { - /* we can jump to op_define1, so this is not fool-proof */ - if (sc->cur_op == OP_DEFINE_CONSTANT) return (sc->define_constant_symbol); - if ((sc->cur_op == OP_DEFINE_STAR) || - (sc->cur_op == OP_DEFINE_STAR_UNCHECKED)) - return (sc->define_star_symbol); - return (sc->define_symbol); -} +static s7_pointer read_string_constant(s7_scheme *sc, s7_pointer port) +{ + /* sc->F => error, no check needed here for bad input port and so on */ + s7_int i = 0; /* sc->strbuf index */ + if (is_string_port(port)) + { + /* try the most common case first */ + char *s, *end, *start = (char *)(port_data(port) + port_position(port)); /* not const: C++: strpbrk(start, "\"\n\\") first arg is char* */ + if (*start == '"') + { + port_position(port)++; + return(nil_string); + } + end = (char *)(port_data(port) + port_data_size(port)); + 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 = s - start; + port_position(port) += (len + 1); + return(make_string_with_length(sc, start, len)); + } + for (; s < end; s++) + { + if (*s == '"') /* switch here no faster */ + { + s7_int len = s - start; + port_position(port) += (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") */ + const s7_int len = (s7_int)(s - start); + if (len > 0) + { + if (len >= sc->strbuf_size) + resize_strbuf(sc, len); + memcpy((void *)(sc->strbuf), (void *)(port_data(port) + port_position(port)), len); + port_position(port) += len; + } + i = len; + break; + } + else + if (*s == '\n') + port_line_number(port)++; + }} + while (true) + { + /* splitting this check out and duplicating the loop was slower?!? */ + int32_t c = port_read_character(port)(sc, port); + switch (c) + { + case '\n': + port_line_number(port)++; + sc->strbuf[i++] = (unsigned char)c; + break; -static bool -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. But we want a warning if we got define - * (as opposed to the original define-constant). - */ - s7_pointer slot; - if (is_multiple_value (sc->value)) /* (define x (values 1 2)) */ - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_5 ( - sc, wrap_string (sc, "~A: more than one value: (~A ~A ~S)", 35), - define1_caller (sc), define1_caller (sc), sc->code, sc->value)); - if (is_constant_symbol (sc, - sc->code)) /* (define pi 3) or (define (pi a) a) */ - { - slot= (is_slot (global_slot (sc->code))) ? global_slot (sc->code) - : s7_t_slot (sc, sc->code); - /* local_slot can be free even if sc->code is immutable (local constant now - * defunct) */ - - if (!((is_slot (slot)) && - (type (sc->value) == type_unchecked (slot_value (slot))) && - (s7_is_equivalent ( - sc, sc->value, - slot_value (slot))))) /* if value is unchanged, just ignore this - (re)definition */ - syntax_error_with_caller_nr (sc, "~A: ~S is immutable", 19, - define1_caller (sc), - sc->code); /* can't use s7_is_equal because - value might be NaN, etc */ - - if ((sc->safety > no_safety) && /* (define-constant x 3) (define x 3)... */ - (sc->cur_op == OP_DEFINE)) - s7_warn (sc, 256, "(define %s %s), but %s is a constant\n", - display (sc->code), display (sc->value), display (sc->code)); - } - else slot= s7_slot (sc, sc->code); - if ((is_slot (slot)) && (slot_has_setter (slot))) { - sc->value= bind_symbol_with_setter (sc, OP_DEFINE_WITH_SETTER, sc->code, - sc->value); - if (sc->value == sc->no_value) - return (true); /* goto apply, if all goes well, OP_DEFINE_WITH_SETTER will - jump to DEFINE2 */ - } - return (false); /* fall through */ -} + case EOF: + sc->strbuf[(i > 8) ? 8 : i] = '\0'; + return(sc->F); -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) { - const s7_pointer body= closure_body (new_func); - const s7_pointer pars= closure_pars (new_func); - if ((is_pair (closure_pars (new_func))) && (has_location (pars))) { - let_set_file (new_let, pair_file_number (pars)); - let_set_line (new_let, pair_line_number (pars)); - } - else if (has_location (body)) { - let_set_file (new_let, pair_file_number (body)); - let_set_line (new_let, pair_line_number (body)); - } - else { - s7_pointer p; - for (p= cdr (body); 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); - } -} + case '"': + return(make_string_with_length(sc, sc->strbuf, i)); -static void -op_define_with_setter (s7_scheme* sc) { - const s7_pointer code= sc->code; - if ((is_immutable (sc->curlet)) && (is_let (sc->curlet))) /* not () */ - immutable_object_error_nr ( - sc, - 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 */ - { - const s7_pointer new_func= sc->value; - s7_pointer 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)) && (sc->curlet != sc->rootlet)) { - if (let_id (sc->curlet) <= - symbol_id ( - code)) /* we're adding a later-bound symbol to an old let (?) */ - { /* was < 16-Aug-22: (let ((a 3)) (define (a) 4) (curlet)) */ - s7_pointer slot; - sc->let_number++; /* dummy let, force symbol lookup */ - for (slot= let_slots (sc->curlet); is_not_slot_end (slot); - slot= next_slot (slot)) - if (slot_symbol (slot) == code) { - if (is_immutable_slot (slot)) - syntax_error_nr (sc, "define ~S, but it is immutable", 30, - code); /* someday give the location of the - immutable definition or setting */ - 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_unchecked (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_slot (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 */ - syntax_error_nr (sc, "define ~S, but it is immutable", 30, - old_symbol); - } - else 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 { - const s7_pointer slot= symbol_to_local_slot (sc, code, sc->curlet); - if (is_slot (slot)) { - if (is_immutable_slot (slot)) { - s7_pointer old_value= slot_value (slot); - if ((type (old_value) != type (sc->value)) || - (!s7_is_equivalent (sc, old_value, - sc->value))) /* if value is unchanged, just - ignore this (re)definition */ - syntax_error_nr (sc, "define ~S, but it is immutable", 30, code); - } - else { - slot_set_value_with_hook (slot, 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); - } - } -} + case '\\': + c = inchar(port); + switch (c) + { + case EOF: + sc->strbuf[(i > 8) ? 8 : i] = '\0'; + return(sc->F); -/* -------------------------------- eval -------------------------------- */ -static void -check_for_cyclic_code (s7_scheme* sc, s7_pointer code) { - if (tree_is_cyclic (sc, code)) { - /* sc->stack_resize_trigger = (s7_pointer *)(sc->stack_start + - * (sc->stack_size - ((STACK_RESIZE_TRIGGER) / 2))); */ - syntax_error_nr (sc, "attempt to evaluate a circular list: ~A", 39, code); - } - resize_stack (sc); /* we've already checked that resize_stack is needed */ -} + case '\\': case '"': case '|': + sc->strbuf[i++] = (unsigned char)c; + break; -static void -op_thunk (s7_scheme* sc) /* sc->code: (generate-leaves) */ -{ - const s7_pointer func= opt1_lambda (sc->code); - set_curlet (sc, inline_make_let (sc, closure_let (func))); - sc->code= T_Pair (closure_body (func)); - if_pair_set_up_begin (sc); + 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, port); + 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 = unknown_string_constant(sc, c); + if (!is_character(result)) return(result); + sc->strbuf[i++] = character(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 -op_thunk_o (s7_scheme* sc) /* sc->code: (h) */ +static void read_double_quote(s7_scheme *sc) { - const s7_pointer func= opt1_lambda (sc->code); - set_curlet (sc, inline_make_let (sc, closure_let (func))); - sc->code= car (closure_body (func)); + 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_nr(sc, "end of input encountered while in a string"); + if (sc->value == sc->T) + read_error_nr(sc, "unknown backslash usage -- perhaps you meant two backslashes?"); + if (sc->safety > immutable_vector_safety) set_immutable_string(sc->value); } -static void -op_safe_thunk (s7_scheme* sc) /* no let needed, sc->code: (fc) */ +static /* inline */ bool read_sharp_const(s7_scheme *sc) /* tread but inline makes no difference? (it's currently inlined anyway) */ { - const s7_pointer func= opt1_lambda (sc->code); - set_curlet (sc, closure_let (func)); - sc->code= T_Pair (closure_body (func)); - if_pair_set_up_begin_unchecked (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 -op_safe_thunk_a (s7_scheme* sc, s7_pointer code) /* sc->code: (get-ds) */ +static no_return void read_expression_read_error_nr(s7_scheme *sc) { - const s7_pointer func= opt1_lambda (code); - set_curlet (sc, closure_let (func)); - return (fx_call (sc, closure_body (func))); + const s7_pointer port = current_input_port(sc); + pop_stack(sc); + if ((is_input_port(port)) && + (!port_is_closed(port)) && + (port_data(port)) && + (port_position(port) > 0)) + { + const s7_pointer str = make_empty_string(sc, 128, '\0'); + const char *msg = string_value(str); + const s7_int pos = port_position(port); + s7_int start = pos - 40; + if (start < 0) start = 0; + memcpy((void *)msg, (const void *)"at \"...", 7); + memcpy((void *)(msg + 7), (void *)(port_data(port) + start), pos - start); + memcpy((void *)(msg + 7 + pos - start), (const void *)"...", 3); + string_length(str) = 7 + pos - start + 3; + error_nr(sc, sc->read_error_symbol, set_elist_1(sc, str)); + } + read_error_nr(sc, "stray comma before ')'?"); /* '("a" "b",) */ } -static void -op_thunk_any (s7_scheme* sc) /* sc->code: (make-hook) */ +static s7_pointer read_expression(s7_scheme *sc) { - const s7_pointer func= opt1_lambda (sc->code); - set_curlet (sc, make_let_with_slot (sc, closure_let (func), - closure_pars (func), sc->nil)); - sc->code= closure_body (func); + while (true) + { + 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->read_dims); /* sc->read_dims here and below = vector dimensions (from read_sharp) -> sc->args */ + sc->tok = token_left_paren; + break; + + case token_int_vector: + push_stack_no_let_no_code(sc, OP_READ_INT_VECTOR, sc->read_dims); + sc->tok = token_left_paren; + break; + + case token_float_vector: + push_stack_no_let_no_code(sc, OP_READ_FLOAT_VECTOR, sc->read_dims); + sc->tok = token_left_paren; + break; + + case token_complex_vector: + push_stack_no_let_no_code(sc, OP_READ_COMPLEX_VECTOR, sc->read_dims); + 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->read_dims); /* sc->read_dims 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) + { + int32_t c; + back_up_stack(sc); + do {c = inchar(current_input_port(sc));} while ((c != ')') && (c != EOF)); + read_error_nr(sc, "stray dot after '('?"); /* (car '( . )) */ + } + if (sc->tok == token_eof) + missing_close_paren_error_nr(sc); + check_stack_size(sc); /* s7test, tlimit */ + push_stack_no_let_no_code(sc, OP_READ_LIST, sc->nil); /* here we need to clear args, but code is ignored */ + break; + + case token_quote: + check_stack_size(sc); /* no speed diff in tload.scm which looks like the worst case */ + 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); + if (sc->tok == token_right_paren) + read_expression_read_error_nr(sc); + if (sc->tok == token_eof) + { + pop_stack(sc); + read_error_nr(sc, "stray comma at the end of the input?"); + } + 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); + {int32_t c; do {c = inchar(current_input_port(sc));} while ((c != ')') && (c != EOF));} + read_error_nr(sc, "stray dot in list?"); /* (+ 1 . . ) */ + + case token_right_paren: /* (catch #t (lambda () '(1 2 . )) (lambda args 'hiho)) */ + back_up_stack(sc); + read_error_nr(sc, "unexpected close paren"); /* (+ 1 2)) or (+ 1 . ) */ + }} + /* we never get here */ + if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: we should not be here\n", __func__, __LINE__); + return(sc->nil); } -static void -op_safe_thunk_any (s7_scheme* sc) /* sc->code: (m3) */ +static void read_dot_and_expression(s7_scheme *sc) { - const s7_pointer func= opt1_lambda (sc->code); - set_curlet (sc, closure_let (func)); - slot_set_value (let_slots (sc->curlet), sc->nil); - sc->code= T_Pair (closure_body (func)); - if_pair_set_up_begin_unchecked (sc); + push_stack_no_let_no_code(sc, OP_READ_DOT, sc->args); + sc->tok = token(sc); + sc->value = read_expression(sc); } -static void -op_closure_s (s7_scheme* sc) /* sc->code: (func hook) */ +static void read_tok_default(s7_scheme *sc) { - const s7_pointer func= opt1_lambda (sc->code); - check_stack_size (sc); - set_curlet (sc, inline_make_let_with_slot (sc, closure_let (func), - car (closure_pars (func)), - lookup (sc, opt2_sym (sc->code)))); - sc->code= T_Pair (closure_body (func)); - if_pair_set_up_begin_unchecked (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 inline void -op_closure_s_o (s7_scheme* sc) /* sc->code: (recompose-1 n) */ +static int32_t read_atom(s7_scheme *sc, s7_pointer port) { - const s7_pointer func= opt1_lambda (sc->code); - set_curlet (sc, inline_make_let_with_slot (sc, closure_let (func), - car (closure_pars (func)), - lookup (sc, opt2_sym (sc->code)))); - sc->code= car (closure_body (func)); + push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); + /* check_stack_size(sc); */ + sc->value = port_read_name(port)(sc, port); + sc->args = list_1(sc, sc->value); + pair_set_current_input_location(sc, sc->args); + return(port_read_white_space(port)(sc, port)); } -static void -op_safe_closure_s (s7_scheme* sc) /* sc->code: (close1 x) */ +static /* inline */ int32_t read_start_list(s7_scheme *sc, s7_pointer port, int32_t c) { - const s7_pointer func= opt1_lambda (sc->code); - set_curlet (sc, update_let_with_slot (sc, closure_let (func), - lookup (sc, opt2_sym (sc->code)))); - sc->code= T_Pair (closure_body (func)); - if_pair_set_up_begin_unchecked (sc); + 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(port)(sc, port); + sc->args = list_1(sc, sc->value); + pair_set_current_input_location(sc, sc->args); + return(port_read_white_space(port)(sc, port)); } -static void -op_safe_closure_s_o (s7_scheme* sc) /* sc->code: (op2 lst) */ +static void op_read_internal(s7_scheme *sc) { - const s7_pointer func= opt1_lambda (sc->code); - set_curlet (sc, update_let_with_slot (sc, closure_let (func), - lookup (sc, opt2_sym (sc->code)))); - sc->code= car (closure_body (func)); + /* if we're loading a file, and in the file we evaluate (at top-level) something like: + * (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))) + error_nr(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, (is_loader_port(current_input_port(sc))) ? "load input port is closed!" : "read input port is closed!", 26))); + + sc->tok = token(sc); + switch (sc->tok) + { + case token_eof: break; + case token_right_paren: read_error_nr(sc, "unexpected close paren"); + case token_comma: read_error_nr(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_safe_closure_p ( - s7_scheme* sc) /* sc->code: (close1 ((lambda () (cs11 x)))) */ +static void op_read_done(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); + pop_input_port(sc); + if (sc->tok == token_eof) + sc->value = eof_object; + sc->current_file = NULL; /* this is for error handling */ } -static void -op_safe_closure_p_1 (s7_scheme* sc) /* sc->code: close1 */ +static void op_read_s(s7_scheme *sc) { - set_curlet (sc, update_let_with_slot (sc, closure_let (sc->code), sc->value)); - sc->code= T_Pair (closure_body (sc->code)); + const s7_pointer 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; + } + if (port_is_closed(port)) /* I guess the port_is_closed check is needed because we're going down a level below */ + sole_arg_wrong_type_error_nr(sc, sc->read_symbol, port, an_open_input_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); + error_nr(sc, sc->bad_result_symbol, set_elist_2(sc, wrap_string(sc, "input-function-port read returned: ~S", 37), sc->value)); + }} + else /* we used to check for string port at end here, but that is rarely true so checking takes up more time than it saves */ + { + 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; + case token_right_paren: read_error_nr(sc, "unexpected close paren"); + case token_comma: read_error_nr(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)); + }} } -static void -op_safe_closure_p_a (s7_scheme* sc) /* sc->code: (char->digit (str j)) */ +static bool op_read_quasiquote(s7_scheme *sc) { - check_stack_size (sc); - push_stack_no_args_direct (sc, OP_SAFE_CLOSURE_P_A_1); - sc->code= cadr (sc->code); + /* 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(stack_top_op(sc) != OP_READ_LIST); } -static void -op_safe_closure_p_a_1 ( - s7_scheme* sc) /* sc->code: (identity (if (= state 0) (call/cc... */ +static bool pop_read_list(s7_scheme *sc) { - const s7_pointer func= opt1_lambda (sc->code); - set_curlet (sc, update_let_with_slot (sc, closure_let (func), sc->value)); - sc->value= fx_call (sc, closure_body (func)); + /* 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 = stack_end_args(sc); + if (!is_null(sc->args)) return(false); /* fall into read_list where sc->args is placed at end of on-going list, sc->value */ + sc->args = list_1(sc, sc->value); + pair_set_current_input_location(sc, sc->args); /* uses port_location */ + return(true); } -static Inline void -inline_op_closure_a ( - s7_scheme* sc) /* used twice in eval, sc->code: (recompose-1 (- n 1)) */ +static bool op_load_return_if_eof(s7_scheme *sc) { - const s7_pointer func= opt1_lambda (sc->code); - sc->value = fx_call (sc, cdr (sc->code)); - set_curlet (sc, - inline_make_let_with_slot (sc, closure_let (func), - car (closure_pars (func)), sc->value)); - sc->code= T_Pair (closure_body (func)); + if (SHOW_EVAL_OPS) fprintf(stderr, " op_load_return_if_eof: value: %s\n", display_truncated(sc->value)); + 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 void -op_safe_closure_3s (s7_scheme* sc) /* sc->code: (number-ok? otst result oexp) */ +static bool op_load_close_and_pop_if_eof(s7_scheme *sc) { - const s7_pointer args= cddr (sc->code); - const s7_pointer func= opt1_lambda (sc->code); - set_curlet (sc, update_let_with_three_slots ( - sc, closure_let (func), lookup (sc, cadr (sc->code)), - lookup (sc, car (args)), lookup (sc, cadr (args)))); - sc->code= T_Pair (closure_body (func)); - if_pair_set_up_begin_unchecked (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[%d]: %s not loading?\n", __func__, __LINE__, display(current_input_port(sc))); + /* if *#readers* func hits error, clear_loader_port might not be undone? */ + if (SHOW_EVAL_OPS) fprintf(stderr, "%s closing %s\n", __func__, display(current_input_port(sc))); -static void -op_safe_closure_ssa (s7_scheme* sc) /* possibly inline b, sc->code: - (transparent-memq sym var (outlet e)) */ -{ /* ssa_a is hit once, but is only about 3/4% faster -- there's the fx - overhead, etc */ - const s7_pointer args= cdr (sc->code); - const s7_pointer func= opt1_lambda (sc->code); - set_curlet (sc, update_let_with_three_slots ( - sc, closure_let (func), lookup (sc, car (args)), - lookup (sc, cadr (args)), fx_call (sc, cddr (args)))); - sc->code= T_Pair (closure_body (func)); - if_pair_set_up_begin_unchecked (sc); + 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 returns (values "a-file" an-environment)? */ + sc->value = splice_in_values(sc, multiple_value(sc->value)); + return(false); } -static void -op_safe_closure_saa (s7_scheme* sc) /* (not called in s7test) cb.scm: sc->code: - (loop a (+ b 1) parts) */ +static bool op_read_apply_values(s7_scheme *sc) { - const s7_pointer func= opt1_lambda (sc->code); - const s7_pointer args= cddr (sc->code); - const s7_pointer arg2= - lookup (sc, cadr (sc->code)); /* I don't see fx_t|u here? */ - sc->code= fx_call (sc, args); - set_curlet (sc, - update_let_with_three_slots (sc, closure_let (func), arg2, - sc->code, fx_call (sc, cdr (args)))); - sc->code= T_Pair (closure_body (func)); - if_pair_set_up_begin_unchecked (sc); + sc->value = list_2_unchecked(sc, sc->unquote_symbol, list_2(sc, initial_value(sc->apply_values_symbol), sc->value)); + return(stack_top_op(sc) != OP_READ_LIST); } -static void -op_safe_closure_agg ( - s7_scheme* sc) /* possibly inline tleft, sc->code: (fx2 3 #t #t) */ +static goto_t op_read_dot(s7_scheme *sc) { - const s7_pointer args= cdr (sc->code); - const s7_pointer func= opt1_lambda (sc->code); - set_curlet (sc, update_let_with_three_slots ( - sc, closure_let (func), fx_call (sc, args), - fx_call (sc, cdr (args)), fx_call (sc, cddr (args)))); - sc->code= T_Pair (closure_body (func)); - if_pair_set_up_begin_unchecked (sc); + const token_t c = token(sc); + if (c != token_right_paren) /* '(1 . (2) 3) -> '(1 2 3), Guile says "missing close paren" */ + { + if (is_pair(sc->value)) + { + for (s7_pointer 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_nr(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((stack_top_op(sc) == OP_READ_LIST) ? goto_pop_read_list : goto_start); } -static void -op_closure_p (s7_scheme* sc) /* sc->code: (uncaller (hook 'code)) */ +static bool op_read_quote(s7_scheme *sc) /* ' -> (#_quote ) because quote is not immutable */ { - check_stack_size (sc); - push_stack_no_args (sc, OP_CLOSURE_P_1, opt1_lambda (sc->code)); - sc->code= cadr (sc->code); + /* 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->symbol_quote) ? sc->quote_symbol : sc->quote_function, sc->value); + return(stack_top_op(sc) != OP_READ_LIST); } -static void -op_closure_p_1 (s7_scheme* sc) /* sc->code: symbol->object */ +static bool op_read_unquote(s7_scheme *sc) { - set_curlet (sc, inline_make_let_with_slot (sc, closure_let (sc->code), - car (closure_pars (sc->code)), - sc->value)); - sc->code= T_Pair (closure_body (sc->code)); + /* 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(stack_top_op(sc) != OP_READ_LIST); } -static void -op_safe_closure_a (s7_scheme* sc) /* sc->code: (loop (+ index 1)) */ +/* 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 + */ +static bool op_read_vector(s7_scheme *sc) { - const s7_pointer func= opt1_lambda (sc->code); - set_curlet (sc, update_let_with_slot (sc, closure_let (func), - fx_call (sc, cdr (sc->code)))); - sc->code= T_Pair (closure_body (func)); - push_stack_no_args (sc, sc->begin_op, T_Pair (cdr (sc->code))); - sc->code= car (sc->code); + sc->value = (sc->args == int_one) ? g_vector(sc, sc->value) : g_multivector(sc, integer(sc->args), sc->value); /* sc->args was sc->read_dims 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(stack_top_op(sc) != OP_READ_LIST); } -static void -op_safe_closure_a_o ( - s7_scheme* sc) /* sc->code: (butlast (cdr (car (cdr (cdr old))))) */ +static bool op_read_int_vector(s7_scheme *sc) { - const s7_pointer func= opt1_lambda (sc->code); - set_curlet (sc, update_let_with_slot (sc, closure_let (func), - fx_call (sc, cdr (sc->code)))); - sc->code= car (closure_body (func)); + 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(stack_top_op(sc) != OP_READ_LIST); } -static void -op_closure_ap (s7_scheme* sc) /* sc->code: (ack1 (- m 1) (ack1 m (- n 1))) */ +static bool op_read_float_vector(s7_scheme *sc) { - const 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! + /* sc->value is the list of values, #r(...sc->value...), sc->args = dimensions */ + 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(stack_top_op(sc) != OP_READ_LIST); + /* should this be an error: #r(9223372036854775807): #r(9.223372036854776e+18)? + * also #r(pi)->error that pi is a symbol but #r(+nan.0 -inf.0): #r(+nan.0 -inf.0) -- should pi be a number in the same way? + */ + /* to avoid making the list: sc->floats array (growable and maybe pruned), + * token_float_vector in read_expression: sc->value = unused, push op_read_float_vector + * sc->args = dims, (read_sharp sc->read_dims = dims, read_expression push_op moves it to sc->args + * : push op_read_float_vector (no op_read_list), read, eval, + * fill sc->floats, when right-paren make new vector [for multidims, get list->frame] */ - 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->code: 1 */ +static bool op_read_complex_vector(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)) */ - set_curlet (sc, inline_make_let_with_two_slots ( - sc, closure_let (sc->args), car (closure_pars (sc->args)), - sc->code, cadr (closure_pars (sc->args)), sc->value)); - sc->code= T_Pair (closure_body (sc->args)); + /* sc->value is the list of values, #c(...sc->value...), sc->args = dimensions */ + sc->value = (sc->args == int_one) ? g_complex_vector(sc, sc->value) : g_complex_multivector(sc, integer(sc->args), sc->value); + if (sc->safety > immutable_vector_safety) set_immutable(sc->value); + return(stack_top_op(sc) != OP_READ_LIST); } -static void -op_closure_pa (s7_scheme* sc) /* sc->code: (f-1 (lambda (b) (+ b 1)) 2) */ +static bool op_read_byte_vector(s7_scheme *sc) { - const s7_pointer code= sc->code; - sc->args = fx_call (sc, cddr (code)); - check_stack_size (sc); - 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); + 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(stack_top_op(sc) != OP_READ_LIST); } -static void -op_closure_pa_1 (s7_scheme* sc) /* sc->code: # */ -{ - set_curlet (sc, inline_make_let_with_two_slots ( - sc, closure_let (sc->code), car (closure_pars (sc->code)), - sc->value, cadr (closure_pars (sc->code)), sc->args)); - sc->code= T_Pair (closure_body (sc->code)); -} -static void -op_closure_pp (s7_scheme* sc) /* sc->code: (loop (xf) (yf)) */ +/* ---------------- unknown ops ---------------- */ +static bool fixup_unknown_op(s7_scheme *sc, s7_pointer code, s7_pointer func, opcode_t op) { - check_stack_size (sc); - push_stack (sc, OP_CLOSURE_PP_1, opt1_lambda (sc->code), sc->code); - sc->code= cadr (sc->code); + set_optimize_op(code, op); + if (is_any_closure(func)) + set_opt1_lambda_add(code, func); + return(true); /* for easier break from switch */ } -static void -op_closure_pp_1 (s7_scheme* sc) /* sc->code: as above */ +static bool unknown_unknown(s7_scheme *sc, s7_pointer code, opcode_t op) { - push_stack (sc, OP_CLOSURE_AP_1, sc->args, sc->value); - sc->code= caddr (sc->code); + if ((is_symbol(car(code))) && + (!is_bound_symbol(sc, car(code)))) + unbound_variable_error_nr(sc, car(code)); + set_optimize_op(code, op); + return(true); } -static void -op_safe_closure_ap ( - s7_scheme* sc) /* sc->code: (somefunc (call/cc (lambda (c1)... */ +static bool is_immutable_and_stable(s7_scheme *sc, s7_pointer func) { - 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); + if (symbol_ctr(func) != 1) /* protect against (define-constant (p) (define-constant (p) ...)) */ + return(false); + if ((is_defined_global(func)) && (is_immutable_slot(global_slot(func)))) + return(true); + for (s7_pointer let = sc->curlet; let; let = let_outlet(let)) + if ((is_funclet(let)) && (funclet_function(let) != func)) + return(false); + return(is_immutable_slot(s7_t_slot(sc, func))); } -static void -op_safe_closure_ap_1 (s7_scheme* sc) /* sc->code: somefunc */ +static bool op_unknown(s7_scheme *sc) { - set_curlet (sc, update_let_with_two_slots (sc, closure_let (sc->code), - sc->args, sc->value)); - sc->code= T_Pair (closure_body (sc->code)); -} + const s7_pointer code = sc->code, func = sc->last_function; + if (!func) /* can be NULL if unbound variable */ + unbound_variable_error_nr(sc, car(sc->code)); + if (SHOW_EVAL_OPS) fprintf(stderr, " %s %s %s\n", __func__, display_truncated(func), s7_type_names[type(func)]); -static void -op_safe_closure_pa (s7_scheme* sc) /* sc->code: (string-wi=? (object->string - (append...) :readable)) */ -{ - 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); -} + switch (type(func)) + { + case T_CLOSURE: + case T_CLOSURE_STAR: + if (!has_methods(func)) + { + const int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; + if (is_null(closure_pars(func))) + { + const s7_pointer body = closure_body(func); + const bool one_form = is_null(cdr(body)); + const bool safe_case = is_safe_closure(func); + set_opt1_lambda_add(code, func); + if (one_form) + { + if ((safe_case) && (is_fxable(sc, car(body)))) + { + set_safe_closure(func); /* 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(func); + 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 : ((one_form) ? OP_THUNK_O : OP_THUNK))); + return(true); + } + if (is_closure_star(func)) + { + set_safe_optimize_op(code, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_NA_0 : OP_CLOSURE_STAR_NA)); + set_opt1_lambda_add(code, func); + return(true); + }} + break; -static void -op_safe_closure_pa_1 (s7_scheme* sc) /* sc->code: string-wi=? */ -{ - set_curlet (sc, update_let_with_two_slots (sc, closure_let (sc->code), - sc->value, sc->args)); - sc->code= T_Pair (closure_body (sc->code)); + case T_GOTO: return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_GOTO)); + case T_ITERATOR: return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_ITERATE)); + case T_BACRO: case T_MACRO: return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_D, func))); + case T_BACRO_STAR: case T_MACRO_STAR: return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_STAR_D, func))); + + default: + if ((is_symbol(car(code))) && + (!is_bound_symbol(sc, car(code)))) + unbound_variable_error_nr(sc, car(code)); + } + return(fixup_unknown_op(sc, code, func, OP_S)); } -static void -op_safe_closure_pp ( - s7_scheme* sc) /* sc->code: (somefunc (call/cc (lambda (c1)... */ +static bool fxify_closure_star_g(s7_scheme *sc, s7_pointer clo, s7_pointer code) { - check_stack_size (sc); - push_stack (sc, OP_SAFE_CLOSURE_PP_1, opt1_lambda (sc->code), sc->code); - sc->code= cadr (sc->code); + if ((!has_methods(clo)) && + (closure_star_arity_to_int(sc, clo) != 0)) + { + const int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; + const bool safe_case = is_safe_closure(clo); + fx_annotate_arg(sc, cdr(code), sc->curlet); + set_opt3_arglen(cdr(code), 1); + if ((safe_case) && (is_null(cdr(closure_pars(clo))))) + set_optimize_op(code, hop + OP_SAFE_CLOSURE_STAR_A1); + else + if (lambda_has_simple_defaults(clo)) + { + if (arglist_has_rest(sc, closure_pars(clo))) + fixup_unknown_op(sc, code, clo, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_NA_1 : OP_CLOSURE_STAR_NA)); + else fixup_unknown_op(sc, code, clo, hop + ((safe_case) ? + ((is_null(cdr(closure_pars(clo)))) ? OP_SAFE_CLOSURE_STAR_A1 : OP_SAFE_CLOSURE_STAR_A) : OP_CLOSURE_STAR_A)); + return(true); + } + fixup_unknown_op(sc, code, clo, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_NA_1 : OP_CLOSURE_STAR_NA)); + return(true); + } + return(false); } -static void -op_safe_closure_pp_1 (s7_scheme* sc) /* sc->code as above */ +static bool op_unknown_closure_s(s7_scheme *sc, s7_pointer clo, s7_pointer code) { - push_stack (sc, OP_SAFE_CLOSURE_AP_1, sc->value, sc->args); - sc->code= caddr (sc->code); + const s7_pointer body = closure_body(clo); + const bool one_form = is_null(cdr(body)); + const int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; + clear_has_fn(code); + set_opt2_sym(code, cadr(code)); + + /* code here might be (clo x) where clo 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_g. Ideally we'd know + * this was a parameter or whatever. The tricky case is local letrec(f) calling clo which initially + * thinks it is not safe, then later is set safe correctly, now outer func is called again, + * this time clo is safe, and we're ok from then on. + */ + if (is_unknopt(code)) + { + switch (op_no_hop(code)) + { + case OP_CLOSURE_S: + set_optimize_op(code, (is_safe_closure(clo)) ? ((one_form) ? OP_SAFE_CLOSURE_S_O : OP_SAFE_CLOSURE_S) : OP_S_G); break; + case OP_CLOSURE_S_O: + case OP_SAFE_CLOSURE_S: + set_optimize_op(code, ((one_form) ? OP_CLOSURE_S_O : 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(clo)) ? + ((one_form) ? OP_SAFE_CLOSURE_S_O : OP_SAFE_CLOSURE_S) : + ((one_form) ? OP_CLOSURE_S_O : OP_CLOSURE_S)); + break; + default: + set_optimize_op(code, OP_S_G); break; + } + set_opt1_lambda_add(code, clo); + return(true); + } + if (!is_safe_closure(clo)) + set_optimize_op(code, hop + ((one_form) ? OP_CLOSURE_S_O : OP_CLOSURE_S)); + else + if (!is_null(cdr(body))) + set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_S); + else + if (is_fxable(sc, car(body))) + fxify_closure_s(sc, clo, 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 + */ + set_is_unknopt(code); + set_opt1_lambda_add(code, clo); + return(true); } -static void -op_any_closure_3p ( - s7_scheme* sc) /* sc->code: (g-1 (lambda (b c) (+ b c)) 2 3) */ +static bool op_unknown_s(s7_scheme *sc) { - s7_pointer args= cdr (sc->code); /* sc->code: e.g. s7test (recompose 32 - (lambda (a) (cons 1 a)) ()) */ - if (has_fx (args)) { - sc->args= fx_call (sc, args); - args = cdr (args); - if (has_fx (args)) { - stack_end_code (sc)= - sc->code; /* push_stack_direct(sc, OP_ANY_CLOSURE_3P_3) here but - trying to be too clever? */ - stack_end_args (sc)= sc->args; /* stack[args] == arg1 to closure) */ - stack_end_op (sc) = (s7_pointer) (opcode_t) (OP_ANY_CLOSURE_3P_3); - sc->stack_end+= 4; - set_stack_protected3 (sc, fx_call (sc, args), - OP_ANY_CLOSURE_3P_3); /* set stack_let */ - /* (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 (args); - } - else { - push_stack_direct (sc, OP_ANY_CLOSURE_3P_2); /* arg1 == stack[args] */ - sc->code= car (args); + const s7_pointer code = sc->code, func = sc->last_function; + + if (!func) unbound_variable_error_nr(sc, car(sc->code)); + if (SHOW_EVAL_OPS) fprintf(stderr, " %s %s\n", __func__, display_truncated(func)); + if ((S7_DEBUGGING) && (!is_normal_symbol(cadr(code)))) fprintf(stderr, "%s[%d]: not a symbol: %s\n", __func__, __LINE__, display(code)); + if ((!is_any_macro(func)) && /* if func is a macro, its argument can be unbound legitimately */ + (!is_bound_symbol(sc, cadr(code)))) + return(unknown_unknown(sc, sc->code, (is_normal_symbol(cadr(sc->code))) ? OP_CLEAR_OPTS : OP_S_G)); + if ((is_unknopt(code)) && (!is_closure(func))) + return(fixup_unknown_op(sc, code, func, OP_S_G)); + + switch (type(func)) + { + case T_C_FUNCTION: + if (!c_function_is_aritable(func, 1)) break; + case T_C_RST_NO_REQ_FUNCTION: + set_class_and_fn_proc(code, func); + if ((is_safe_procedure(func)) || (c_function_call(func) == g_values)) + { + 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); + + case T_CLOSURE: + if ((!has_methods(func)) && (closure_arity_to_int(sc, func) == 1)) + return(op_unknown_closure_s(sc, func, code)); + break; + + case T_CLOSURE_STAR: + if (fxify_closure_star_g(sc, func, code)) return(true); + break; + + case T_GOTO: + fx_annotate_arg(sc, cdr(code), sc->curlet); + set_opt3_arglen(cdr(code), 1); + return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_GOTO_A)); + + case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_BYTE_VECTOR: case T_COMPLEX_VECTOR: + fx_annotate_arg(sc, cdr(code), sc->curlet); + return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_VECTOR_REF_A)); + + case T_STRING: + fx_annotate_arg(sc, cdr(code), sc->curlet); + return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_STRING_REF_A)); + + case T_PAIR: + fx_annotate_arg(sc, cdr(code), sc->curlet); + return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_PAIR_REF_A)); + + case T_C_OBJECT: + if (s7_is_aritable(sc, func, 1)) + { + fx_annotate_arg(sc, cdr(code), sc->curlet); + return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_C_OBJECT_REF_A)); + } + break; + + case T_LET: + fx_annotate_arg(sc, cdr(code), sc->curlet); + return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_LET_REF_A)); + + case T_HASH_TABLE: + fx_annotate_arg(sc, cdr(code), sc->curlet); + return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_HASH_TABLE_REF_A)); + + case T_CONTINUATION: + fx_annotate_arg(sc, cdr(code), sc->curlet); + return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_CONTINUATION_A)); + + case T_BACRO: case T_MACRO: + return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_D, func))); + case T_BACRO_STAR: case T_MACRO_STAR: + return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_STAR_D, func))); + + default: break; } - } - else { - push_stack_no_args_direct (sc, OP_ANY_CLOSURE_3P_1); - sc->code= car (args); - } + if ((is_symbol(car(code))) && + (!is_slot(s7_t_slot(sc, car(code))))) + unbound_variable_error_nr(sc, car(code)); + return(fixup_unknown_op(sc, code, func, OP_S_G)); } -static bool -closure_3p_end ( - s7_scheme* sc, - s7_pointer args) /* sc->code: (dpb (byte 4 5) (byte 6 7) (byte 8 9)) */ -{ - if (has_fx (args)) { - const s7_pointer func= opt1_lambda (sc->code); - gc_protect_2_via_stack ( - sc, sc->args, sc->value); /* sc->args == arg1, sc->value == arg2 */ - set_gc_protected3 (sc, fx_call (sc, args)); - if (is_safe_closure (func)) - set_curlet (sc, update_let_with_three_slots ( - sc, closure_let (func), gc_protected1 (sc), - gc_protected2 (sc), gc_protected3 (sc))); - else - make_let_with_three_slots (sc, func, gc_protected1 (sc), - gc_protected2 (sc), gc_protected3 (sc)); - unstack_gc_protect (sc); - sc->code= T_Pair (closure_body (func)); - return (true); - } - push_stack_direct (sc, OP_ANY_CLOSURE_3P_3); - set_stack_protected3 ( - sc, sc->value, - OP_ANY_CLOSURE_3P_3); /* set stack_let, arg2 == curlet stack loc */ - sc->code= car (args); - return (false); -} - -static bool -op_any_closure_3p_1 (s7_scheme* sc) /* sc->code: as above */ -{ - const s7_pointer args= cddr (sc->code); - sc->args= - sc->value; /* (arg1 of closure) sc->value can be clobbered by fx_call? */ - if (has_fx (args)) { - sc->value= fx_call (sc, args); - return (closure_3p_end (sc, cdr (args))); - } - push_stack_direct (sc, OP_ANY_CLOSURE_3P_2); - sc->code= car (args); - 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) /* sc->code: as above */ -{ - /* display(obj) will not work here because sc->curlet is being used as arg2 of - * the closure3 */ - const s7_pointer func= opt1_lambda ( - sc->code); /* incoming args (from pop_stack): sc->args, sc->curlet, and - sc->value from last evaluation */ - if (is_safe_closure (func)) - set_curlet (sc, - 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) /* sc->code: (lpb -1 1 (byte 4 5) 3) */ -{ - s7_pointer args= cdr (sc->code); - check_stack_size (sc); - if (has_fx (args)) { - gc_protect_via_stack (sc, fx_call (sc, args)); - args= cdr (args); - if (has_fx (args)) { - set_gc_protected2 (sc, fx_call (sc, args)); - args= cdr (args); - if (has_fx (args)) { - set_gc_protected3 (sc, fx_call (sc, args)); - push_stack_no_args_direct (sc, OP_ANY_CLOSURE_4P_4); - sc->code= cadr (args); - } - else { - push_stack_no_args_direct (sc, OP_ANY_CLOSURE_4P_3); - sc->code= car (args); +static bool op_unknown_a(s7_scheme *sc) +{ + const s7_pointer code = sc->code, func = sc->last_function; + if (!func) unbound_variable_error_nr(sc, car(sc->code)); + if (SHOW_EVAL_OPS) fprintf(stderr, " %s %s\n", __func__, display_truncated(func)); + + switch (type(func)) + { + case T_C_FUNCTION: + if (!c_function_is_aritable(func, 1)) break; + case T_C_RST_NO_REQ_FUNCTION: + clear_has_fx(code); + set_class_and_fn_proc(code, func); + if (is_safe_procedure(func)) + { + 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(func)) && + (closure_arity_to_int(sc, func) == 1)) + { + const s7_pointer body = closure_body(func); + const bool safe_case = is_safe_closure(func); + const int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; + const bool one_form = is_null(cdr(body)); + + fxify_closure_a(sc, func, one_form, safe_case, hop, code, sc->curlet); + set_opt1_lambda_add(code, func); + return(true); + } + break; + + case T_CLOSURE_STAR: + if (fxify_closure_star_g(sc, func, code)) return(true); + break; + + case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_BYTE_VECTOR: case T_COMPLEX_VECTOR: + return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_VECTOR_REF_A)); + + case T_STRING: return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_STRING_REF_A)); + case T_PAIR: return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_PAIR_REF_A)); + case T_C_OBJECT: return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_C_OBJECT_REF_A)); + case T_HASH_TABLE: return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_HASH_TABLE_REF_A)); + case T_GOTO: return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_GOTO_A)); + case T_CONTINUATION: return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_CONTINUATION_A)); + case T_BACRO: + case T_MACRO: return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_D, func))); + case T_BACRO_STAR: + case T_MACRO_STAR: return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_STAR_D, func))); + + case T_LET: + { + const s7_pointer arg1 = cadr(code); + if ((is_quoted_symbol(sc, arg1)) || (is_symbol_and_keyword(arg1))) + { + s7_pointer sym = (is_pair(arg1)) ? cadr(arg1) : arg1; + if (is_keyword(sym)) sym = keyword_symbol(sym); + set_opt3_con(code, sym); + return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_LET_REF_C)); + } + return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_LET_REF_A)); /* "A" might be a symbol */ } + + default: break; } - else { - stack_end_args (sc)= sc->unused; /* copy_stack dangling pair */ - push_stack_no_args_direct (sc, OP_ANY_CLOSURE_4P_2); - sc->code= car (args); - } - } - else { - push_stack_no_args_direct (sc, OP_ANY_CLOSURE_4P_1); - sc->code= car (args); - } + if ((is_symbol(car(code))) && + (!is_bound_symbol(sc, car(code)))) + unbound_variable_error_nr(sc, car(code)); + return(fixup_unknown_op(sc, code, func, OP_S_A)); /* closure with methods etc */ } -static bool -closure_4p_end (s7_scheme* sc, s7_pointer args) /* sc->code: as above */ +static bool op_unknown_gg(s7_scheme *sc) /* we assume in eval that this always returns true */ { - if (has_fx (args)) { - const s7_pointer func= opt1_lambda (sc->code); - sc->args = fx_call (sc, args); - if (is_safe_closure (func)) - set_curlet (sc, update_let_with_four_slots ( - sc, closure_let (func), gc_protected1 (sc), - gc_protected2 (sc), gc_protected3 (sc), sc->args)); - else - make_let_with_four_slots (sc, func, gc_protected1 (sc), - gc_protected2 (sc), gc_protected3 (sc), - sc->args); - sc->code= T_Pair (closure_body (func)); - unstack_gc_protect (sc); - return (true); - } - push_stack_no_args_direct (sc, OP_ANY_CLOSURE_4P_4); - sc->code= car (args); - return (false); -} + bool s1, s2; + const s7_pointer code = sc->code, func = sc->last_function; + if (!func) unbound_variable_error_nr(sc, car(sc->code)); + if (SHOW_EVAL_OPS) fprintf(stderr, " %s %s\n", __func__, display_truncated(func)); + + s1 = is_normal_symbol(cadr(code)); + if ((s1) && + (!is_bound_symbol(sc, cadr(code)))) + return(unknown_unknown(sc, sc->code, OP_CLEAR_OPTS)); + s2 = is_normal_symbol(caddr(code)); + if ((s2) && + (!is_bound_symbol(sc, caddr(code)))) + return(unknown_unknown(sc, sc->code, OP_CLEAR_OPTS)); + + switch (type(func)) + { + case T_C_FUNCTION: + if (!c_function_is_aritable(func, 2)) break; + case T_C_RST_NO_REQ_FUNCTION: + if (is_safe_procedure(func)) + { + if (s1) + { + set_optimize_op(code, (s2) ? OP_SAFE_C_SS : OP_SAFE_C_SC); + if (s2) + set_opt1_sym(cdr(code), caddr(code)); + else set_opt1_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(func)) ? OP_CL_NA : OP_C_NA); + fx_annotate_args(sc, cdr(code), sc->curlet); + } + set_opt3_arglen(cdr(code), 2); + set_class_and_fn_proc(code, func); + return(true); + + case T_CLOSURE: + if (has_methods(func)) break; + if (closure_arity_to_int(sc, func) == 2) + { + const s7_pointer body = closure_body(func); + const bool safe_case = is_safe_closure(func); + const int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; + const bool one_form = is_null(cdr(body)); -static bool -op_any_closure_4p_1 (s7_scheme* sc) /* sc->code: as above */ -{ - s7_pointer args= cddr (sc->code); - gc_protect_via_stack (sc, sc->value); - if (has_fx (args)) { - set_gc_protected2 (sc, fx_call (sc, args)); - args= cdr (args); - if (has_fx (args)) { - set_gc_protected3 (sc, fx_call (sc, args)); - return (closure_4p_end (sc, cdr (args))); - } - push_stack_no_args_direct (sc, OP_ANY_CLOSURE_4P_3); - sc->code= car (args); - } - else { - push_stack_no_args_direct (sc, OP_ANY_CLOSURE_4P_2); - sc->code= car (args); - } - return (false); -} + 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_pars(func)), cadr(closure_pars(func)), NULL, false); + set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_SS_A); + set_closure_one_form_fx_arg(func); + }} + 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), 2); + 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_add(code, func); + return(true); + } + break; -static bool -op_any_closure_4p_2 (s7_scheme* sc) /* sc->code: as above */ -{ - const s7_pointer args= cdddr (sc->code); - set_gc_protected2 (sc, sc->value); - if (has_fx (args)) { - set_gc_protected3 (sc, fx_call (sc, args)); - return (closure_4p_end (sc, cdr (args))); - } - push_stack_no_args_direct (sc, OP_ANY_CLOSURE_4P_3); - sc->code= car (args); - return (false); -} + case T_CLOSURE_STAR: + if ((closure_star_arity_to_int(sc, func) != 0) && + (closure_star_arity_to_int(sc, func) != 1)) + { + fx_annotate_args(sc, cdr(code), sc->curlet); + if (!has_methods(func)) + { + fixup_closure_star_aa(sc, func, code, (is_immutable_and_stable(sc, car(code))) ? 1 : 0); + set_opt1_lambda_add(code, func); + } + else set_optimize_op(code, OP_S_AA); + return(true); + } + break; -static bool -op_any_closure_4p_3 (s7_scheme* sc) /* sc->code: as above */ -{ - set_gc_protected3 (sc, sc->value); - return (closure_4p_end (sc, cddddr (sc->code))); -} + case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_BYTE_VECTOR: case T_PAIR: case T_COMPLEX_VECTOR: + set_opt3_arglen(cdr(code), 2); + fx_annotate_args(sc, cdr(code), sc->curlet); + if ((!is_pair(func)) && (vector_rank(func) != 2)) + return(fixup_unknown_op(sc, code, func, OP_S_AA)); + return(fixup_unknown_op(sc, code, func, (is_pair(func)) ? OP_IMPLICIT_PAIR_REF_AA : OP_IMPLICIT_VECTOR_REF_AA)); -static inline void -op_any_closure_4p_4 (s7_scheme* sc) /* sc->code: as above */ -{ - const s7_pointer func= opt1_lambda (sc->code); - if (is_safe_closure (func)) - set_curlet (sc, update_let_with_four_slots ( - sc, closure_let (func), gc_protected1 (sc), - gc_protected2 (sc), gc_protected3 (sc), sc->value)); - else - make_let_with_four_slots (sc, func, gc_protected1 (sc), gc_protected2 (sc), - gc_protected3 (sc), sc->value); - sc->code= T_Pair (closure_body (func)); - unstack_gc_protect (sc); -} + case T_HASH_TABLE: + fx_annotate_args(sc, cdr(code), sc->curlet); + return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_HASH_TABLE_REF_AA)); -static void -op_safe_closure_ss (s7_scheme* sc) /* sc->code: (g x y) */ -{ - const s7_pointer func= opt1_lambda (sc->code); - set_curlet (sc, update_let_with_two_slots (sc, closure_let (func), - lookup (sc, cadr (sc->code)), - lookup (sc, opt2_sym (sc->code)))); - sc->code= T_Pair (closure_body (func)); - push_stack_no_args (sc, sc->begin_op, T_Pair (cdr (sc->code))); - sc->code= car (sc->code); -} + case T_BACRO: case T_MACRO: + return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_D, func))); + case T_BACRO_STAR: case T_MACRO_STAR: + return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_STAR_D, func))); -static void -op_safe_closure_ss_o (s7_scheme* sc) /* sc->code: (_f_aq p e) */ -{ - const s7_pointer func= opt1_lambda (sc->code); - set_curlet (sc, update_let_with_two_slots (sc, closure_let (func), - lookup (sc, cadr (sc->code)), - lookup (sc, opt2_sym (sc->code)))); - sc->code= car (closure_body (func)); + default: break; + } + if ((is_symbol(car(code))) && + (!is_slot(s7_t_slot(sc, car(code))))) + unbound_variable_error_nr(sc, car(code)); + fx_annotate_args(sc, cdr(code), sc->curlet); + return(fixup_unknown_op(sc, code, func, OP_S_AA)); } -static inline void -op_closure_ss (s7_scheme* sc) /* sc->code: (A k B) */ +static bool op_unknown_ns(s7_scheme *sc) /* we assume in eval that this always returns true */ { - const s7_pointer func= opt1_lambda (sc->code); - check_stack_size (sc); - set_curlet (sc, inline_make_let_with_two_slots ( - sc, closure_let (func), car (closure_pars (func)), - lookup (sc, cadr (sc->code)), cadr (closure_pars (func)), - lookup (sc, opt2_sym (sc->code)))); - sc->code= T_Pair (closure_body (func)); - push_stack_no_args (sc, sc->begin_op, T_Pair (cdr (sc->code))); - sc->code= car (sc->code); -} + const s7_pointer code = sc->code, func = sc->last_function; + const int32_t num_args = opt3_arglen(cdr(code)); -static inline void -op_closure_ss_o (s7_scheme* sc) /* sc->code: (c1 s i) */ -{ - const s7_pointer func= opt1_lambda (sc->code); - set_curlet (sc, inline_make_let_with_two_slots ( - sc, closure_let (func), car (closure_pars (func)), - lookup (sc, cadr (sc->code)), cadr (closure_pars (func)), - lookup (sc, opt2_sym (sc->code)))); - sc->code= car (closure_body (func)); -} - -static void -op_safe_closure_sc (s7_scheme* sc) /* sc->code: (close3 x 2) */ -{ - const s7_pointer func= opt1_lambda (sc->code); - set_curlet (sc, update_let_with_two_slots (sc, closure_let (func), - lookup (sc, cadr (sc->code)), - opt2_con (sc->code))); - sc->code= T_Pair (closure_body (func)); - 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) /* sc->code: (tree-member c d) */ -{ - const s7_pointer func= opt1_lambda (sc->code); - set_curlet (sc, update_let_with_two_slots (sc, closure_let (func), - lookup (sc, cadr (sc->code)), - opt2_con (sc->code))); - sc->code= car (closure_body (func)); -} - -static void -op_closure_sc (s7_scheme* sc) /* sc->code: (read-in-radix str 32) */ -{ - const s7_pointer func= opt1_lambda (sc->code); - check_stack_size (sc); - set_curlet (sc, make_let_with_two_slots ( - sc, closure_let (func), car (closure_pars (func)), - lookup (sc, cadr (sc->code)), cadr (closure_pars (func)), - opt2_con (sc->code))); - sc->code= T_Pair (closure_body (func)); - push_stack_no_args (sc, sc->begin_op, T_Pair (cdr (sc->code))); - sc->code= car (sc->code); -} - -static inline void -op_closure_sc_o (s7_scheme* sc) /* sc->code: (f-1 abs 2) */ -{ - const s7_pointer func= opt1_lambda (sc->code); - check_stack_size (sc); - set_curlet (sc, inline_make_let_with_two_slots ( - sc, closure_let (func), car (closure_pars (func)), - lookup (sc, cadr (sc->code)), cadr (closure_pars (func)), - opt2_con (sc->code))); - sc->code= car (closure_body (func)); -} - -static void -op_closure_3s (s7_scheme* sc) /* sc->code: (walk-rest caller form let) */ -{ - s7_pointer args = cdr (sc->code); - const s7_pointer arg1_val= lookup (sc, car (args)); - const s7_pointer func = opt1_lambda (sc->code); - args = cdr (args); - make_let_with_three_slots (sc, func, arg1_val, lookup (sc, car (args)), - lookup (sc, cadr (args))); /* sets sc->curlet */ - sc->code= T_Pair (closure_body (func)); - if_pair_set_up_begin (sc); -} - -static inline void -op_closure_3s_o (s7_scheme* sc) /* sc->code: (pretty-print-1 obj port column) */ -{ - s7_pointer args = cdr (sc->code); - const s7_pointer arg1_val= lookup (sc, car (args)); - const s7_pointer func = opt1_lambda (sc->code); - args = cdr (args); - make_let_with_three_slots (sc, func, arg1_val, lookup (sc, car (args)), - lookup (sc, cadr (args))); /* sets sc->curlet */ - sc->code= car (closure_body (func)); -} - -static void -op_closure_4s (s7_scheme* sc) /* sc->code: (Cholesky:add-element P L i j) */ -{ - s7_pointer args = cdr (sc->code); - const s7_pointer arg1_val= lookup (sc, car (args)), - arg2_val= lookup (sc, cadr (args)); - const s7_pointer func = opt1_lambda (sc->code); - args = cddr (args); - make_let_with_four_slots (sc, func, arg1_val, arg2_val, - lookup (sc, car (args)), - lookup (sc, cadr (args))); /* sets sc->curlet */ - sc->code= T_Pair (closure_body (func)); - if_pair_set_up_begin (sc); -} - -static inline void -op_closure_4s_o ( - s7_scheme* sc) /* sc->code: (make-collector into oper tail head) */ -{ - s7_pointer args = cdr (sc->code); - const s7_pointer arg1_val= lookup (sc, car (args)), - arg2_val= lookup (sc, cadr (args)); - const s7_pointer func = opt1_lambda (sc->code); - args = cddr (args); - make_let_with_four_slots (sc, func, arg1_val, arg2_val, - lookup (sc, car (args)), - lookup (sc, cadr (args))); /* sets sc->curlet */ - sc->code= car (closure_body (func)); -} - -static void -op_closure_5s ( - s7_scheme* sc) /* .1 in lg but this is marginal -- adds two ops etc, - sc->code: (key-parse-clause d mode args argn user) */ -{ - s7_pointer args = cdr (sc->code); - const s7_pointer arg1_val= lookup (sc, car (args)), - arg2_val= lookup (sc, cadr (args)); - const s7_pointer func = opt1_lambda (sc->code); - args = cddr (args); - make_let_with_five_slots (sc, func, arg1_val, arg2_val, - lookup (sc, car (args)), lookup (sc, cadr (args)), - lookup (sc, caddr (args))); /* sets sc->curlet */ - sc->code= T_Pair (closure_body (func)); - if_pair_set_up_begin (sc); -} - -static void -op_safe_closure_aa (s7_scheme* sc) /* sc->code: (close3 1 2) */ -{ - s7_pointer args= cdr (sc->code), body; - const s7_pointer func= opt1_lambda (sc->code); - sc->code = fx_call ( - sc, - cdr (args)); /* fx_call can affect sc->value, but not sc->code, I think */ - set_curlet (sc, update_let_with_two_slots (sc, closure_let (func), - fx_call (sc, args), sc->code)); - body= T_Pair (closure_body (func)); - /* check_stack_size(sc); */ /* pretty-print if cycles=#f? */ - push_stack_no_args (sc, sc->begin_op, T_Pair (cdr (body))); - sc->code= car (body); -} - -static inline void -op_safe_closure_aa_o ( - s7_scheme* sc) /* sc->code: (tree-member 1 '(2 3 (4 1) 5)) */ -{ - const s7_pointer args= cdr (sc->code); - const s7_pointer func= opt1_lambda (sc->code); - sc->code = fx_call (sc, cdr (args)); - set_curlet (sc, update_let_with_two_slots (sc, closure_let (func), - fx_call (sc, args), sc->code)); - sc->code= car (closure_body (func)); - /* (let values ((x 1) (y 2)) (values 1 2)): sc->code incoming is - * 0x7fffbf681c98 (values 1 2), car(closure_body) out is the same -> infinite - * loop! */ -} - -static void -op_closure_aa (s7_scheme* sc) /* sc->code: (substring? "hiho" "test hih") */ -{ - s7_pointer args= cdr (sc->code), body; - const s7_pointer func= opt1_lambda (sc->code); - sc->code = fx_call (sc, cdr (args)); - sc->value = fx_call (sc, args); - set_curlet (sc, inline_make_let_with_two_slots ( - sc, closure_let (func), car (closure_pars (func)), - sc->value, cadr (closure_pars (func)), sc->code)); - body= T_Pair (closure_body (func)); - check_stack_size (sc); - push_stack_no_args (sc, sc->begin_op, T_Pair (cdr (body))); - sc->code= car (body); -} - -static Inline void -inline_op_closure_aa_o (s7_scheme* sc) /* called once in eval, b cb left lg - list, sc->code: (ack1 m (- n 1)) */ -{ - const s7_pointer args= cdr (sc->code); - const s7_pointer func= opt1_lambda (sc->code); - sc->code = fx_call (sc, cdr (args)); - sc->value = fx_call (sc, args); - set_curlet (sc, inline_make_let_with_two_slots ( - sc, closure_let (func), car (closure_pars (func)), - sc->value, cadr (closure_pars (func)), sc->code)); - sc->code= car (closure_body (func)); -} - -static /* inline */ void -op_closure_fa (s7_scheme* sc) /* "inline" matters perhaps in texit.scm, - sc->code: (f8 (lambda (x) (+ x 1)) 1) */ -{ - s7_pointer new_clo; - const s7_pointer code= sc->code; - const s7_pointer farg= opt2_pair (code); /* cdadr(code), '((a . b) (cons a b)) - for (lambda (a . b) (cons a b)) */ - const s7_pointer aarg = fx_call (sc, cddr (code)); - const s7_pointer func = opt1_lambda (code); /* outer func */ - const s7_pointer func_pars= closure_pars ( - func); /* outer func pars (not the arglist of the applied func) */ - sc->value= inline_make_let_with_two_slots ( - sc, closure_let (func), car (func_pars), sc->F, cadr (func_pars), aarg); - new_clo= make_closure_unchecked ( - sc, car (farg), cdr (farg), - T_CLOSURE | ((!s7_is_proper_list (sc, car (farg))) ? T_COPY_ARGS : 0), - CLOSURE_ARITY_NOT_SET); - /* this is checking the called closure arglist (see op_lambda), arity<0 - * probably not usable since "f" in "fa" is a parameter */ - slot_set_value ( - let_slots (sc->value), - new_clo); /* this order allows us to use make_closure_unchecked */ - set_curlet (sc, sc->value); - sc->code= car (closure_body (func)); -} - -static void -op_safe_closure_ns (s7_scheme* sc) /* sc->code: (slot var expr env expr-env) */ -{ - const s7_pointer func= opt1_lambda (sc->code); - const s7_pointer let = closure_let (func); - const s7_int id = ++sc->let_number; - let_set_id (let, id); - for (s7_pointer args= cdr (sc->code), slot= let_slots (let); - is_not_slot_end (slot); slot= next_slot (slot), args= cdr (args)) { - slot_set_value (slot, lookup (sc, car (args))); - symbol_set_local_slot (slot_symbol (slot), id, slot); - } - set_curlet (sc, let); - sc->code= closure_body (func); - if_pair_set_up_begin_unchecked (sc); -} + if (!func) unbound_variable_error_nr(sc, car(sc->code)); + if (SHOW_EVAL_OPS) fprintf(stderr, " %s %s\n", __func__, display_truncated(func)); -static inline void -op_safe_closure_3a (s7_scheme* sc) /* sc->code: (f8 0 0 (list 1)) */ -{ - const s7_pointer args= cdr (sc->code); - const s7_pointer func= opt1_lambda (sc->code); - sc->code = fx_call ( - sc, - cdr (args)); /* fx_call can affect sc->value, but not sc->code, I think */ - sc->args= fx_call (sc, cddr (args)); /* is sc->args safe here? */ - set_curlet (sc, update_let_with_three_slots (sc, closure_let (func), - fx_call (sc, args), sc->code, - sc->args)); - sc->code= closure_body (func); - if_pair_set_up_begin_unchecked (sc); -} + for (s7_pointer arg = cdr(code); is_pair(arg); arg = cdr(arg)) + if (!is_bound_symbol(sc, car(arg))) + unbound_variable_error_nr(sc, car(arg)); -static void -op_safe_closure_na (s7_scheme* sc) /* sc->code: (hi 1 2 3 4) */ -{ - s7_pointer let; - s7_int id; - sc->args= safe_list_if_possible (sc, opt3_arglen (cdr (sc->code))); - for (s7_pointer 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 (s7_pointer slot= let_slots (let), vals= sc->args; is_not_slot_end (slot); - slot= next_slot (slot), vals= cdr (vals)) { - slot_set_value (slot, car (vals)); - symbol_set_local_slot (slot_symbol (slot), id, slot); - } - if (!in_heap (sc->args)) clear_safe_list_in_use (sc, sc->args); - set_curlet (sc, let); - sc->code= closure_body (sc->code); - if_pair_set_up_begin_unchecked (sc); -} + switch (type(func)) + { + case T_C_FUNCTION: + if (!c_function_is_aritable(func, num_args)) break; + case T_C_RST_NO_REQ_FUNCTION: + if (is_safe_procedure(func)) + { + 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(func)) ? OP_CL_NA : OP_C_NA); + fx_annotate_args(sc, cdr(code), sc->curlet); + } + set_class_and_fn_proc(code, func); + return(true); + + case T_CLOSURE: + if ((!has_methods(func)) && + (closure_arity_to_int(sc, func) == num_args)) + { + const int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; + const bool one_form = is_null(cdr(closure_body(func))); + const bool safe_case = is_safe_closure(func); + fx_annotate_args(sc, cdr(code), sc->curlet); + if (num_args == 3) + return(fixup_unknown_op(sc, code, func, hop + ((safe_case) ? OP_SAFE_CLOSURE_3S : ((one_form) ? OP_CLOSURE_3S_O : OP_CLOSURE_3S)))); + if (num_args == 4) + return(fixup_unknown_op(sc, code, func, hop + ((safe_case) ? OP_SAFE_CLOSURE_NS : ((one_form) ? OP_CLOSURE_4S_O : OP_CLOSURE_4S)))); + return(fixup_unknown_op(sc, code, func, hop + ((safe_case) ? OP_SAFE_CLOSURE_NS : ((num_args == 5) ? OP_CLOSURE_5S : OP_CLOSURE_NS)))); + } + break; -static /* inline */ void -op_closure_ns (s7_scheme* sc) /* called once in eval, lg?, sc->code: (A k B x1 - x2 x3 x4 x5) */ -{ - /* 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. - */ - s7_pointer args= cdr (sc->code), last_slot; - const s7_pointer func= opt1_lambda (sc->code); - const s7_pointer pars= closure_pars (func); - const s7_pointer let = inline_make_let (sc, closure_let (func)); - const s7_int id = let_id (let); - begin_temp (sc->y, let); - add_slot_unchecked (sc, let, car (pars), lookup (sc, car (args)), id); - last_slot= let_slots (let); - args = cdr (args); - for (s7_pointer p1= cdr (pars); is_pair (p1); p1= cdr (p1), args= cdr (args)) - last_slot= add_slot_at_end ( - sc, id, last_slot, car (p1), - lookup (sc, car (args))); /* main such call in lt (fx_s is 1/2, this is - 1/5 of all calls) */ - set_curlet (sc, let); - end_temp (sc->y); - sc->code= T_Pair (closure_body (func)); - if_pair_set_up_begin (sc); -} - -static void -op_closure_ass ( - s7_scheme* sc) /* possibly inline b, sc->code: (recompose 32 reverse x) */ -{ - const s7_pointer args= cdr (sc->code); - const s7_pointer func= opt1_lambda (sc->code); - make_let_with_three_slots (sc, func, fx_call (sc, args), - lookup (sc, cadr (args)), - lookup (sc, caddr (args))); - sc->code= T_Pair (closure_body (func)); - if_pair_set_up_begin (sc); -} - -static void -op_closure_aas ( - s7_scheme* sc) /* possibly inline b, sc->code: - (recur-cond-a-a-a-a-opl3a-l3aq-23 (- x 1) (+ y 1) z) */ -{ - const s7_pointer args= cdr (sc->code); - const s7_pointer func= opt1_lambda (sc->code); - sc->z = fx_call (sc, args); - make_let_with_three_slots (sc, func, sc->z, fx_call (sc, cdr (args)), - lookup (sc, caddr (args))); - sc->z = sc->unused; - sc->code= T_Pair (closure_body (func)); - if_pair_set_up_begin (sc); -} - -static void -op_closure_saa (s7_scheme* sc) /* sc->code: (f h1 b1 :a) */ -{ - const s7_pointer args= cdr (sc->code); - const s7_pointer func= opt1_lambda (sc->code); - sc->z = fx_call (sc, cdr (args)); - make_let_with_three_slots (sc, func, lookup (sc, car (args)), sc->z, - fx_call (sc, cddr (args))); - sc->z = sc->unused; - sc->code= T_Pair (closure_body (func)); - if_pair_set_up_begin (sc); -} - -static void -op_closure_asa (s7_scheme* sc) /* sc->code: (recompose 12 char-downcase #\A) */ -{ - const s7_pointer args= cdr (sc->code); - const s7_pointer func= opt1_lambda (sc->code); - sc->z = fx_call (sc, args); - make_let_with_three_slots (sc, func, sc->z, lookup (sc, cadr (args)), - fx_call (sc, cddr (args))); - sc->z = sc->unused; - sc->code= T_Pair (closure_body (func)); - if_pair_set_up_begin (sc); -} - -static void -op_closure_sas (s7_scheme* sc) /* sc->code: (parse-clauses forms () ops) */ -{ - const s7_pointer args= cdr (sc->code); - const s7_pointer func= opt1_lambda (sc->code); - make_let_with_three_slots (sc, func, lookup (sc, car (args)), - fx_call (sc, cdr (args)), - lookup (sc, caddr (args))); - sc->code= T_Pair (closure_body (func)); - if_pair_set_up_begin (sc); -} - -static inline void -op_closure_3a (s7_scheme* sc) /* if inlined, tlist -60, sc->code: (func (- a 1) - (- b 1) (- c 1)) */ -{ - const s7_pointer args= cdr (sc->code); - const s7_pointer func= 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, func, gc_protected1 (sc), gc_protected2 (sc), - fx_call (sc, cddr (args))); - unstack_gc_protect (sc); - sc->code= T_Pair (closure_body (func)); - if_pair_set_up_begin (sc); -} - -static void -op_closure_4a (s7_scheme* sc) /* sass, sc->code: (reinvert 12 vector->list... */ -{ - s7_pointer args= cdr (sc->code); - const s7_pointer func= opt1_lambda (sc->code); - gc_protect_2_via_stack (sc, fx_call (sc, args), fx_call (sc, cddr (args))); - args= cdr (args); - set_gc_protected3 (sc, fx_call (sc, args)); - make_let_with_four_slots (sc, func, gc_protected1 (sc), gc_protected3 (sc), - gc_protected2 (sc), fx_call (sc, cddr (args))); - unstack_gc_protect (sc); - sc->code= T_Pair (closure_body (func)); - if_pair_set_up_begin (sc); -} - -static void -op_closure_na (s7_scheme* sc) /* sc->code: (f1 0 "a" L1 V1 S1 H1 E1) */ -{ - const s7_pointer exprs= - cdr (sc->code); /* "n" = opt3_arglen(exprs), mostly 5 in lt, 6 in tlet */ - const s7_pointer func= opt1_lambda (sc->code); - const s7_pointer pars= closure_pars (func); - const s7_pointer let = inline_make_let (sc, closure_let (func)); - s7_pointer slot, last_slot; - sc->z = let; - sc->value= fx_call (sc, exprs); - new_cell_unchecked (sc, last_slot, T_SLOT); - slot_set_symbol_and_value (last_slot, car (pars), sc->value); - slot_set_next (last_slot, let_slots (let)); /* i.e. slot_end */ - let_set_slots (let, last_slot); - for (s7_pointer par= cdr (pars), expr= cdr (exprs); is_pair (par); - par= cdr (par), expr= cdr (expr)) { - sc->value= - fx_call (sc, expr); /* 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 (par), 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); - slot_set_next (last_slot, slot); - last_slot= slot; - } - set_curlet (sc, let); - sc->z= sc->unused; - let_set_id (let, ++sc->let_number); - for (s7_pointer slot1= let_slots (let); is_not_slot_end (slot1); - slot1 = next_slot (slot1)) { - symbol_set_local_slot (slot_symbol (slot1), let_id (let), slot1); - set_local (slot_symbol (slot1)); - } - sc->code= T_Pair (closure_body (func)); - if_pair_set_up_begin (sc); -} - -static bool -check_closure_sym (s7_scheme* sc, int32_t args) { - /* 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) || - (local_value_unchecked (car (sc->code)) != - opt1_lambda_unchecked (sc->code))) { - const s7_pointer func= lookup_unexamined (sc, car (sc->code)); - if ((func != opt1_lambda_unchecked (sc->code)) && - ((!func) || - ((low_type_bits (func) & (TYPE_MASK | T_SAFE_CLOSURE)) != T_CLOSURE) || - (((args == 1) && (!is_symbol (closure_pars (func)))) || - ((args == 2) && ((!is_pair (closure_pars (func))) || - (!is_symbol (cdr (closure_pars (func))))))))) { - sc->last_function= func; - return (false); - } - set_opt1_lambda (sc->code, func); - } - return (true); -} + case T_CLOSURE_STAR: + if ((!has_methods(func)) && + ((closure_star_arity_to_int(sc, func) < 0) || ((closure_star_arity_to_int(sc, func) * 2) >= num_args))) + { + const int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; + fx_annotate_args(sc, cdr(code), sc->curlet); + if ((is_safe_closure(func)) && (num_args == 3) && (closure_star_arity_to_int(sc, func) == 3)) + return(fixup_unknown_op(sc, code, func, OP_SAFE_CLOSURE_STAR_3A)); + return(fixup_unknown_op(sc, code, func, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_NA : OP_CLOSURE_STAR_NA))); + } + break; -static void -op_any_closure_sym (s7_scheme* sc) /* for (lambda a ...) */ -{ - const s7_pointer func = opt1_lambda (sc->code); - s7_pointer old_args= cdr (sc->code); /* args aren't evaluated yet */ - const s7_int num_args= opt3_arglen (old_args); + case T_BACRO: case T_MACRO: + return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_D, func))); + case T_BACRO_STAR: case T_MACRO_STAR: + return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_STAR_D, func))); - if (num_args == 1) - set_curlet (sc, inline_make_let_with_slot ( - sc, closure_let (func), closure_pars (func), - ((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)); - set_curlet (sc, inline_make_let_with_slot ( - sc, closure_let (func), closure_pars (func), - ((is_safe_closure (func)) && (!sc->debug_or_profile)) - ? set_plist_2 (sc, gc_protected1 (sc), sc->args) - : list_2 (sc, gc_protected1 (sc), sc->args))); - unstack_gc_protect (sc); - } - else if (num_args == 0) - set_curlet (sc, inline_make_let_with_slot (sc, closure_let (func), - closure_pars (func), sc->nil)); - else { - sc->args= make_list (sc, num_args, sc->unused); - for (s7_pointer p= sc->args; is_pair (p); - p= cdr (p), old_args= cdr (old_args)) - set_car (p, fx_call (sc, old_args)); - set_curlet (sc, make_let_with_slot (sc, closure_let (func), - closure_pars (func), sc->args)); - } - sc->code= T_Pair (closure_body (func)); + /* PERHAPS: vector, but need op_implicit_vector_ns? */ + default: break; + } + return(unknown_unknown(sc, sc->code, OP_CLEAR_OPTS)); } -static void -op_any_closure_a_sym (s7_scheme* sc) /* for (lambda (a . b) ...) */ +static bool op_unknown_aa(s7_scheme *sc) /* we assume in eval that this always returns true */ { - const s7_pointer func = opt1_lambda (sc->code); - s7_pointer old_args = cdr (sc->code); - const s7_int num_args = opt3_arglen (old_args); - const s7_pointer func_pars= closure_pars (func); + const s7_pointer code = sc->code, func = sc->last_function, head = car(sc->code); - if (num_args == 1) - set_curlet (sc, make_let_with_two_slots (sc, closure_let (func), - car (func_pars), - sc->value= fx_call (sc, old_args), - cdr (func_pars), sc->nil)); - else { - gc_protect_via_stack ( - sc, fx_call (sc, old_args)); /* not sc->value as GC protection! -- - fx_call below can clobber it */ - if (num_args == 2) { - sc->args= fx_call (sc, cdr (old_args)); - set_curlet (sc, inline_make_let_with_two_slots ( - sc, closure_let (func), car (func_pars), - gc_protected1 (sc), cdr (func_pars), - list_1 (sc, sc->args))); - } - else { - sc->args= make_list (sc, num_args - 1, sc->unused); - old_args= cdr (old_args); - for (s7_pointer p= sc->args; is_pair (p); - p= cdr (p), old_args= cdr (old_args)) - set_car (p, fx_call (sc, old_args)); - set_curlet (sc, make_let_with_two_slots ( - sc, closure_let (func), car (func_pars), - gc_protected1 (sc), cdr (func_pars), sc->args)); - } - unstack_gc_protect (sc); - } - sc->code= T_Pair (closure_body (func)); -} + if (!func) unbound_variable_error_nr(sc, head); + if (SHOW_EVAL_OPS) fprintf(stderr, " %s %s\n", __func__, display_truncated(func)); -/* ---------------- tc/rec ---------------- */ + switch (type(func)) + { + case T_C_FUNCTION: + if (!c_function_is_aritable(func, 2)) break; + case T_C_RST_NO_REQ_FUNCTION: + if (is_safe_procedure(func)) /* why is this different from unknown_a and unknown_na? */ + { + 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(func)) ? OP_CL_NA : OP_C_NA); + set_class_and_fn_proc(code, func); + return(true); -#if S7_DEBUGGING -#define TC_REC_SIZE NUM_OPS -#define TC_REC_LOW_OP OP_TC_AND_A_OR_A_LA + case T_CLOSURE: + if ((!has_methods(func)) && + (closure_arity_to_int(sc, func) == 2)) + { + const s7_pointer body = closure_body(func); + const bool safe_case = is_safe_closure(func); + const int32_t hop = (is_immutable_and_stable(sc, head)) ? 1 : 0; + const bool 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(func); + } + if ((is_fx_treeable(cdr(code))) && (curlet_has_slots(sc))) fx_curlet_tree(sc, cdr(code)); + set_opt1_lambda_add(code, func); + return(true); + } + break; -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); -} + case T_CLOSURE_STAR: + if (!has_methods(func)) + { + fixup_closure_star_aa(sc, func, code, (is_immutable_and_stable(sc, head)) ? 1 : 0); + set_opt1_lambda_add(code, func); + } + else set_optimize_op(code, OP_S_AA); + return(true); -static s7_pointer -g_report_missed_calls (s7_scheme* sc, s7_pointer args) { - for (int32_t 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); -} + case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_BYTE_VECTOR: case T_COMPLEX_VECTOR: + if (vector_rank(func) != 2) + return(fixup_unknown_op(sc, code, func, OP_S_AA)); + return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_VECTOR_REF_AA)); -static void -tick_tc (s7_scheme* sc, int32_t op) { - sc->tc_rec_calls[op]++; -} -#else -#define tick_tc(Sc, Op) -#endif + case T_PAIR: return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_PAIR_REF_AA)); + case T_HASH_TABLE: return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_HASH_TABLE_REF_AA)); + case T_BACRO: case T_MACRO: return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_D, func))); + case T_BACRO_STAR: case T_MACRO_STAR: return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_STAR_D, func))); -/* op_tc_case */ -static bool -op_tc_case_la (s7_scheme* sc, s7_pointer code, int vars) { -/* opt1_any(clause) = key, has_tc(arg) = is tc call, opt2_any(clause) = result: - * has_tc(la arg) has_fx(val) or ((...)...) */ -#define case_clause_key(p) opt1_any (p) -#define case_clause_result(p) opt2_any (p) - const s7_pointer clauses= cddr (code), la_slot= let_slots (sc->curlet), - selp= cdr (code); - s7_pointer endp; - const s7_pointer l2a_slot= (vars == 1) ? NULL : next_slot (la_slot); - const s7_pointer l3a_slot= (vars <= 2) ? NULL : next_slot (l2a_slot); - const s7_int len = opt3_arglen (cdr (code)); - tick_tc (sc, (vars == 1) ? OP_TC_CASE_LA - : ((vars == 2) ? OP_TC_CASE_L2A : OP_TC_CASE_L3A)); - - if (len == 3) { - while (true) { - const s7_pointer selector= fx_call (sc, selp); - if (selector == case_clause_key (clauses)) - endp= case_clause_result (clauses); - else { - s7_pointer p= cdr (clauses); - endp = (selector == case_clause_key (p)) - ? case_clause_result (p) - : case_clause_result (cdr (p)); /* there's always an else */ - } - if (has_tc (endp)) { - slot_set_value (la_slot, fx_call (sc, cdr (endp))); - if (vars > 1) slot_set_value (l2a_slot, fx_call (sc, cddr (endp))); - if (vars > 2) slot_set_value (l3a_slot, fx_call (sc, cdddr (endp))); - } - else break; - } - } - else - while (true) { - const s7_pointer selector= fx_call (sc, selp); - s7_pointer p; - for (p= clauses; is_pair (cdr (p)); p= cdr (p)) - if (selector == case_clause_key (p)) { - endp= case_clause_result (p); - goto CASE_ALA_END; - } - endp= case_clause_result (p); /* else clause */ - CASE_ALA_END: - if (has_tc (endp)) { - slot_set_value (la_slot, fx_call (sc, cdr (endp))); - if (vars > 1) slot_set_value (l2a_slot, fx_call (sc, cddr (endp))); - if (vars > 2) slot_set_value (l3a_slot, fx_call (sc, cdddr (endp))); - } - else break; + default: break; } - if (has_fx (endp)) { - sc->value= fx_call (sc, endp); - return (true); /* continue */ - } - sc->code= endp; - return (false); /* goto BEGIN (not like op_tc_z below) */ + if ((is_symbol(head)) && + (!is_bound_symbol(sc, head))) + unbound_variable_error_nr(sc, head); + return(fixup_unknown_op(sc, code, func, OP_S_AA)); } -static s7_pointer -fx_tc_case_la (s7_scheme* sc, s7_pointer arg) { - op_tc_case_la (sc, arg, 1); - return (sc->value); +static bool is_normal_happy_symbol(s7_scheme *sc, s7_pointer sym) +{ + if (!is_normal_symbol(sym)) + return(false); + if (!is_bound_symbol(sc, sym)) unbound_variable_error_nr(sc, sym); + return(true); } -static s7_pointer -fx_tc_case_l2a (s7_scheme* sc, s7_pointer arg) { - op_tc_case_la (sc, arg, 2); - return (sc->value); -} +static bool op_unknown_na(s7_scheme *sc) /* we assume in eval that this always returns true */ +{ + const s7_pointer code = sc->code, func = sc->last_function; + const int32_t num_args = (is_pair(cdr(code))) ? opt3_arglen(cdr(code)) : 0; -static s7_pointer -fx_tc_case_l3a (s7_scheme* sc, s7_pointer arg) { - op_tc_case_la (sc, arg, 3); - return (sc->value); -} + if (!func) unbound_variable_error_nr(sc, car(sc->code)); + if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s %s\n", __func__, __LINE__, display_truncated(func), display_truncated(sc->code)); + if (num_args == 0) return(fixup_unknown_op(sc, code, func, OP_S)); /* via op_closure*-fx where original had 0 args, safe case -> op_safe_closure*_0 */ -/* op_tc_when_la|l2a|l3a */ -static s7_pointer -op_tc_when_la (s7_scheme* sc, s7_pointer code) { - const bool when_case= (!true_is_done (code)); - const s7_pointer if_test= cadr (code), body= cddr (code), - la_slot = let_slots (sc->curlet); - const s7_function tf = fx_proc (cdr (code)); - const s7_pointer la_call= opt3_pair (code); - const s7_pointer la = cdar (la_call); - tick_tc (sc, OP_TC_WHEN_LA); - while ((tf (sc, if_test) != sc->F) == when_case) { - for (s7_pointer p= body; p != la_call; p= cdr (p)) - fx_call (sc, p); - slot_set_value (la_slot, fx_call (sc, la)); - } - return (sc->unspecified); -} - -static s7_pointer -op_tc_when_l2a (s7_scheme* sc, s7_pointer code) { - const bool when_case= (!true_is_done (code)); - const s7_pointer if_test= cadr (code), body= cddr (code), - la_slot = let_slots (sc->curlet); - const s7_function tf = fx_proc (cdr (code)); - const s7_pointer la_call = opt3_pair (code); - const s7_pointer la = cdar (la_call); - const s7_pointer l2a = cdr (la); - const s7_pointer l2a_slot= next_slot (la_slot); - tick_tc (sc, OP_TC_WHEN_L2A); - while ((tf (sc, if_test) != sc->F) == when_case) { - for (s7_pointer p= body; p != la_call; p= cdr (p)) - fx_call (sc, p); - sc->rec_p1= fx_call (sc, la); - slot_set_value (l2a_slot, fx_call (sc, l2a)); - slot_set_value (la_slot, sc->rec_p1); - } - sc->rec_p1= sc->unused; - return (sc->unspecified); -} - -static s7_pointer -op_tc_when_l3a (s7_scheme* sc, s7_pointer code) { - const bool when_case= (!true_is_done (code)); - const s7_pointer if_test= cadr (code), body= cddr (code), - la_slot = let_slots (sc->curlet); - const s7_function tf = fx_proc (cdr (code)); - const s7_pointer la_call = opt3_pair (code); - const s7_pointer la = cdar (la_call); - const s7_pointer l2a = cdr (la); - const s7_pointer l3a = cdr (l2a); - const s7_pointer l2a_slot= next_slot (la_slot); - const s7_pointer l3a_slot= next_slot (l2a_slot); - tick_tc (sc, OP_TC_WHEN_L3A); - while ((tf (sc, if_test) != sc->F) == when_case) { - for (s7_pointer p= body; p != la_call; p= cdr (p)) - fx_call (sc, p); - sc->rec_p1= fx_call (sc, la); - sc->rec_p2= fx_call (sc, l2a); - slot_set_value (l3a_slot, fx_call (sc, l3a)); - slot_set_value (l2a_slot, sc->rec_p2); - slot_set_value (la_slot, sc->rec_p1); - } - sc->rec_p1= sc->unused; - return (sc->unspecified); -} + switch (type(func)) + { + case T_C_FUNCTION: + if (!c_function_is_aritable(func, num_args)) break; + case T_C_RST_NO_REQ_FUNCTION: + if (is_safe_procedure(func)) + { + if (num_args == 3) + { + int32_t pairs = 0, symbols = 0, quotes = 0; /* specialize aaa->ssc etc, this makes less difference than I expected */ + for (s7_pointer p = cdr(code); is_pair(p); p = cdr(p)) + { + const s7_pointer arg = car(p); + if (is_normal_happy_symbol(sc, arg)) + symbols++; + else + if (is_pair(arg)) + { + pairs++; + if (is_proper_quote(sc, arg)) + quotes++; + }} + if (optimize_safe_c_func_three_args(sc, code, func, 0 /* hop */, pairs, symbols, quotes, sc->curlet) == opt_ok) + 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(func)) ? OP_CL_NA : OP_C_NA); + fx_annotate_args(sc, cdr(code), sc->curlet); + set_class_and_fn_proc(code, func); + return(true); + + case T_CLOSURE: + if ((!has_methods(func)) && + (closure_arity_to_int(sc, func) == num_args)) + { + const int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; + fx_annotate_args(sc, cdr(code), sc->curlet); + if ((is_fx_treeable(cdr(code))) && (curlet_has_slots(sc))) fx_curlet_tree(sc, cdr(code)); + if (is_safe_closure(func)) + { + 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 set_safe_optimize_op(code, hop + (((!is_pair(caddr(code))) && (!is_pair(cadddr(code)))) ? OP_SAFE_CLOSURE_AGG : 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 set_safe_optimize_op(code, hop + ((is_normal_happy_symbol(sc, cadddr(code))) ? OP_CLOSURE_AAS : OP_CLOSURE_3A)); + set_opt1_lambda_add(code, func); + return(true); + } + if (is_symbol(closure_pars(func))) + { + optimize_closure_sym(sc, code, func, 0, num_args, sc->curlet); + if (optimize_op(code) == OP_ANY_CLOSURE_SYM) return(true); + } + break; -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); -} + case T_CLOSURE_STAR: + if ((!has_methods(func)) && + ((closure_star_arity_to_int(sc, func) < 0) || ((closure_star_arity_to_int(sc, func) * 2) >= num_args))) + { + const int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; + if (num_args > 0) + { + set_opt3_arglen(cdr(code), num_args); + fx_annotate_args(sc, cdr(code), sc->curlet); + if ((is_fx_treeable(cdr(code))) && (curlet_has_slots(sc))) fx_curlet_tree(sc, cdr(code)); + } + if (is_safe_closure(func)) + switch (num_args) + { + case 0: return(fixup_unknown_op(sc, code, func, hop + OP_SAFE_CLOSURE_STAR_NA_0)); + case 1: return(fixup_unknown_op(sc, code, func, hop + OP_SAFE_CLOSURE_STAR_NA_1)); + case 2: return(fixup_unknown_op(sc, code, func, hop + OP_SAFE_CLOSURE_STAR_NA_2)); + case 3: if (closure_star_arity_to_int(sc, func) == 3) return(fixup_unknown_op(sc, code, func, OP_SAFE_CLOSURE_STAR_3A)); + default: return(fixup_unknown_op(sc, code, func, hop + OP_SAFE_CLOSURE_STAR_NA)); + } + return(fixup_unknown_op(sc, code, func, hop + OP_CLOSURE_STAR_NA)); + } + break; -/* tc_if_a_z_la|la2|la3 */ -static bool -op_tc_if_a_z_la (s7_scheme* sc, s7_pointer code) { - const bool true_quits= true_is_done (code); - const s7_pointer la_slot = let_slots (sc->curlet); - const s7_pointer if_test = rec_test_clause (code); - const s7_pointer if_done = rec_done_clause (code); - const s7_pointer la = rec_call_clause (code); - tick_tc (sc, OP_TC_IF_A_Z_LA); - 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= - make_mutable_integer (sc, integer (slot_value (la_slot))); - slot_set_value (la_slot, val); - while (q_call (o).fb (o) != true_quits) { - set_integer (val, q_call (o1).fi (o1)); - } - return (op_tc_z (sc, if_done)); - } - } - } - if (fx_proc (la) == fx_cdr_t) - while ((fx_call (sc, if_test) != sc->F) != true_quits) { - if (!is_pair (slot_value (la_slot))) - sole_arg_wrong_type_error_nr (sc, sc->cdr_symbol, slot_value (la_slot), - sc->type_names[T_PAIR]); - slot_set_value (la_slot, cdr (slot_value (la_slot))); - } - else - while ((fx_call (sc, if_test) != sc->F) != true_quits) { - slot_set_value (la_slot, fx_call (sc, la)); - } - return (op_tc_z (sc, if_done)); -} - -static s7_pointer -fx_tc_if_a_z_la (s7_scheme* sc, s7_pointer arg) { - op_tc_if_a_z_la (sc, arg); - return (sc->value); -} - -static bool -op_tc_if_a_z_l2a (s7_scheme* sc, s7_pointer code) { - const bool true_quits= true_is_done (code); - const s7_pointer la_slot = let_slots (sc->curlet); - s7_function tf; - s7_pointer if_test = rec_test_clause (code); - const s7_pointer if_done = rec_done_clause (code); - const s7_pointer la = rec_call_clause (code); - const s7_pointer l2a = cdr (la); - const s7_pointer l2a_slot= next_slot (la_slot); - tick_tc (sc, OP_TC_IF_A_Z_L2A); - 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; - const int32_t start_pc= sc->pc; - if ((is_t_integer (slot_value (la_slot))) && - (is_t_integer (slot_value (l2a_slot)))) { - if (int_optimize (sc, la)) { - o2= sc->opts[sc->pc]; - if (int_optimize (sc, l2a)) { - s7_int (*fi1) (opt_info* o)= q_call (o1).fi; - s7_int (*fi2) (opt_info* o)= q_call (o2).fi; - bool (*fb) (opt_info* o) = q_call (o).fb; - const s7_pointer val1= - make_mutable_integer (sc, integer (slot_value (la_slot))); - s7_pointer val2; - slot_set_value (la_slot, val1); - slot_set_value (l2a_slot, val2= make_mutable_integer ( - sc, integer (slot_value (l2a_slot)))); - if ((true_quits) && - ((fb == opt_b_ii_sc_lt) || (fb == opt_b_ii_sc_lt_0)) && - (fi1 == opt_i_ii_sc_sub)) { /* trclo: (if (< i 0) sum (loop (- i - 1) (+ i sum))) */ - s7_int lim= q_arg2 (o).i, m= q_arg2 (o1).i; - s7_pointer slot1= q_arg1 (o).p, slot2= q_arg1 (o1).p; - while (integer (slot_value (slot1)) >= lim) { - s7_int i1= integer (slot_value (slot2)) - m; - set_integer (val2, fi2 (o2)); - set_integer (val1, i1); - } - } - else /* s7test: (let facter ((n n0) (result 1)) (if (= n 0) result - (facter (- n 1) (* n result))) */ - while (fb (o) != true_quits) { - s7_int i1= fi1 (o1); - set_integer (val2, fi2 (o2)); - set_integer (val1, i1); - } - return (op_tc_z (sc, if_done)); - } - } - } + case T_BACRO: case T_MACRO: return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_D, func))); + case T_BACRO_STAR: case T_MACRO_STAR: return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_STAR_D, func))); + /* implicit vector doesn't happen */ - if ((is_t_real (slot_value (la_slot))) && - (is_t_real (slot_value (l2a_slot)))) { - sc->pc= start_pc; - if (float_optimize (sc, la)) { - o2= sc->opts[sc->pc]; - if (float_optimize (sc, l2a)) { - s7_double (*fd1) (opt_info* o)= q_call (o1).fd; - s7_double (*fd2) (opt_info* o)= q_call (o2).fd; - bool (*fb) (opt_info* o) = q_call (o).fb; - const s7_pointer val1= - make_mutable_real (sc, real (slot_value (la_slot))); - const s7_pointer val2= - make_mutable_real (sc, real (slot_value (l2a_slot))); - slot_set_value (la_slot, val1); - slot_set_value (l2a_slot, val2); - if ((true_quits) && (fb == opt_b_dd_sc_lt) && - (fd1 == opt_d_dd_sc_sub)) { /* trclo: (if (< i 0.0) sum (loop (- - i 1.0) (+ i sum))) */ - s7_double lim = q_arg2 (o).x; - s7_double m = q_arg2 (o1).x; - s7_pointer slot1= q_arg1 (o).p; - s7_pointer slot2= q_arg1 (o1).p; - while (real (slot_value (slot1)) >= lim) { - s7_double x1= real (slot_value (slot2)) - m; - set_real (val2, fd2 (o2)); - set_real (val1, x1); - } - } - else /* trclo: (if (>= i 0.0) (loop (- i 1.0) (+ i sum)) sum) */ - while (fb (o) != true_quits) { - s7_double x1= fd1 (o1); - set_real (val2, fd2 (o2)); - set_real (val1, x1); - } - clear_mutable_number (val1); - clear_mutable_number (val2); - return (op_tc_z (sc, if_done)); - } - } - } - } - set_no_bool_opt (code); - } - tf = fx_proc (if_test); - if_test= car (if_test); - if (true_quits) { - if ((fx_proc (la) == fx_cdr_t) && (is_pair (slot_value (la_slot)))) { - if ((fx_proc (l2a) == 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_t_integer (slot_value (l2a_slot)))) { /* list-tail ferchrissake */ - const s7_int end= integer (caddr (if_test)); - s7_pointer lst= slot_value (la_slot); - for (s7_int start= integer (slot_value (l2a_slot)); start > end; - start--) - lst= cdr (lst); - slot_set_value (la_slot, lst); - return (op_tc_z (sc, if_done)); - } - if (tf == fx_is_null_t) { - do { - s7_pointer p; - if (is_pair (slot_value ( - la_slot))) /* needed if improper list passed here */ - p= cdr (slot_value (la_slot)); - else - sole_arg_wrong_type_error_nr (sc, sc->cdr_symbol, - slot_value (la_slot), - sc->type_names[T_PAIR]); - slot_set_value (l2a_slot, fx_call (sc, l2a)); - slot_set_value (la_slot, p); - } while (!is_null (slot_value (la_slot))); - return (op_tc_z (sc, if_done)); - } - } - while (tf (sc, if_test) == sc->F) { - sc->rec_p1= fx_call (sc, la); - slot_set_value (l2a_slot, fx_call (sc, l2a)); - slot_set_value (la_slot, sc->rec_p1); - } - } - else { - if ((tf == fx_is_pair_t) && (fx_proc (la) == fx_cdr_t) && - (is_pair (slot_value (la_slot)))) { - /* we need to save la new value before getting the new l2a value since l2a - * might refer to the current la value or vice versa */ - do { - s7_pointer p= cdr (slot_value (la_slot)); - slot_set_value (l2a_slot, fx_call (sc, l2a)); - slot_set_value (la_slot, p); - } while (is_pair (slot_value (la_slot))); - return (op_tc_z (sc, if_done)); + default: break; } - while (tf (sc, if_test) != sc->F) { - sc->rec_p1= fx_call (sc, la); - slot_set_value (l2a_slot, fx_call (sc, l2a)); - slot_set_value (la_slot, sc->rec_p1); - } - } - return (op_tc_z (sc, if_done)); -} - -static s7_pointer -fx_tc_if_a_z_l2a (s7_scheme* sc, s7_pointer arg) { - op_tc_if_a_z_l2a (sc, arg); - sc->rec_p1= sc->unused; - return (sc->value); -} - -static bool -op_tc_if_a_z_l3a (s7_scheme* sc, s7_pointer code) { - const bool true_quits= true_is_done (code); - const s7_pointer la_slot = let_slots (sc->curlet); - s7_pointer if_test = rec_test_clause (code); - const s7_pointer if_done = rec_done_clause (code); - const s7_pointer la = rec_call_clause (code); - const s7_pointer l2a = cdr (la); - const s7_pointer l3a = cdr (l2a); - const s7_pointer l2a_slot = next_slot (la_slot); - const s7_pointer l3a_slot = next_slot (l2a_slot); - const s7_function tf = fx_proc (if_test); - tick_tc (sc, OP_TC_IF_A_Z_L3A); - if_test= car (if_test); - while ((tf (sc, if_test) != sc->F) != true_quits) { - sc->rec_p1= fx_call (sc, la); - sc->rec_p2= fx_call (sc, l2a); - slot_set_value (l3a_slot, fx_call (sc, l3a)); - slot_set_value (l2a_slot, sc->rec_p2); - slot_set_value (la_slot, sc->rec_p1); - } - return (op_tc_z (sc, if_done)); -} - -static s7_pointer -fx_tc_if_a_z_l3a (s7_scheme* sc, s7_pointer arg) { - op_tc_if_a_z_l3a (sc, arg); - sc->rec_p1= sc->unused; - sc->rec_p2= sc->unused; - return (sc->value); -} - -static s7_pointer -op_tc_and_a_or_a_la (s7_scheme* sc, s7_pointer code) { - const s7_pointer fx_and= cdr (code), la_slot= let_slots (sc->curlet); - const s7_pointer fx_or= cdadr (fx_and); - const s7_pointer fx_la= cdadr (fx_or); - tick_tc (sc, OP_TC_AND_A_OR_A_LA); /* cell_optimize here is slower! */ - while (true) { - s7_pointer p; - if (fx_call (sc, fx_and) == sc->F) return (sc->F); - p= fx_call (sc, fx_or); - if (p != sc->F) return (p); - slot_set_value (la_slot, fx_call (sc, fx_la)); - } - return (sc->F); -} - -static s7_pointer -op_tc_or_a_and_a_la (s7_scheme* sc, s7_pointer code) { - const s7_pointer fx_or= cdr (code), la_slot= let_slots (sc->curlet); - const s7_pointer fx_and= cdadr (fx_or); - const s7_pointer fx_la = cdadr (fx_and); - tick_tc (sc, OP_TC_OR_A_AND_A_LA); - while (true) { - s7_pointer result= fx_call (sc, fx_or); - if (result != sc->F) return (result); - if (fx_call (sc, fx_and) == sc->F) return (sc->F); - slot_set_value (la_slot, fx_call (sc, fx_la)); - } - return (sc->F); + /* closure happens if wrong-number-of-args passed -- probably no need for op_s_na */ + /* PERHAPS: vector */ + return(unknown_unknown(sc, sc->code, OP_CLEAR_OPTS)); } -static s7_pointer -op_tc_and_a_or_a_a_la (s7_scheme* sc, s7_pointer code) { - const s7_pointer fx_and= cdr (code), la_slot= let_slots (sc->curlet); - const s7_pointer fx_or1= cdadr (fx_and); - const s7_pointer fx_or2= cdr (fx_or1); - const s7_pointer fx_la = cdadr (fx_or2); - tick_tc (sc, OP_TC_AND_A_OR_A_A_LA); - while (true) { - s7_pointer p; - if (fx_call (sc, fx_and) == sc->F) return (sc->F); - p= fx_call (sc, fx_or1); - if (p != sc->F) return (p); - p= fx_call (sc, fx_or2); - if (p != sc->F) return (p); - slot_set_value (la_slot, fx_call (sc, fx_la)); - } - return (sc->F); -} - -static s7_pointer -op_tc_or_a_and_a_a_la (s7_scheme* sc, s7_pointer code) { - const s7_pointer fx_or= cdr (code), la_slot= let_slots (sc->curlet); - const s7_pointer fx_and1= cdadr (fx_or); - const s7_pointer fx_and2= cdr (fx_and1); - const s7_pointer fx_la = cdadr (fx_and2); - tick_tc (sc, OP_TC_OR_A_AND_A_A_LA); - while (true) { - s7_pointer result= fx_call (sc, fx_or); - if (result != sc->F) return (result); - if ((fx_call (sc, fx_and1) == sc->F) || (fx_call (sc, fx_and2) == sc->F)) - return (sc->F); - slot_set_value (la_slot, fx_call (sc, fx_la)); - } - return (sc->F); -} - -static s7_pointer -op_tc_or_a_a_and_a_a_la (s7_scheme* sc, s7_pointer code) { - const s7_pointer fx_or1= cdr (code), la_slot= let_slots (sc->curlet); - const s7_pointer fx_or2 = cdr (fx_or1); - const s7_pointer fx_and1= cdadr (fx_or2); - const s7_pointer fx_and2= cdr (fx_and1); - const s7_pointer fx_la = cdadr (fx_and2); - tick_tc (sc, OP_TC_OR_A_A_AND_A_A_LA); - while (true) { - s7_pointer result= fx_call (sc, fx_or1); - if (result != sc->F) return (result); - result= fx_call (sc, fx_or2); - if (result != sc->F) return (result); - if (fx_call (sc, fx_and1) == sc->F) return (sc->F); - if (fx_call (sc, fx_and2) == sc->F) return (sc->F); - slot_set_value (la_slot, fx_call (sc, fx_la)); - } - return (sc->F); -} - -static s7_pointer -op_tc_and_a_or_a_l2a (s7_scheme* sc, s7_pointer code) { - const s7_pointer fx_and= cdr (code), la_slot= let_slots (sc->curlet); - const s7_pointer fx_or = cdadr (fx_and); - const s7_pointer fx_la = cdadr (fx_or); - const s7_pointer fx_l2a = cdr (fx_la); - const s7_pointer l2a_slot= next_slot (la_slot); - tick_tc (sc, OP_TC_AND_A_OR_A_L2A); - - 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_l2a) == fx_cdr_u)) { - s7_pointer la_val= slot_value (la_slot), l2a_val= slot_value (l2a_slot); - while (true) { - if (is_null (l2a_val)) return (sc->F); - if (is_null (la_val)) return (sc->T); - if (!is_pair (l2a_val)) - sole_arg_wrong_type_error_nr (sc, sc->cdr_symbol, l2a_val, - sc->type_names[T_PAIR]); - if (!is_pair (la_val)) - sole_arg_wrong_type_error_nr (sc, sc->cdr_symbol, la_val, - sc->type_names[T_PAIR]); - la_val = cdr (la_val); - l2a_val= cdr (l2a_val); - } - } - while (true) { - s7_pointer p; - if (fx_call (sc, fx_and) == sc->F) return (sc->F); - p= fx_call (sc, fx_or); - if (p != sc->F) return (p); - sc->rec_p1= fx_call (sc, fx_la); - slot_set_value (l2a_slot, fx_call (sc, fx_l2a)); - slot_set_value (la_slot, sc->rec_p1); - } - return (sc->F); -} - -static s7_pointer -op_tc_or_a_and_a_l2a (s7_scheme* sc, s7_pointer code) { - const s7_pointer fx_or= cdr (code), la_slot= let_slots (sc->curlet); - const s7_pointer fx_and = cdadr (fx_or); - const s7_pointer fx_la = cdadr (fx_and); - const s7_pointer fx_l2a = cdr (fx_la); - const s7_pointer l2a_slot= next_slot (la_slot); - tick_tc (sc, OP_TC_OR_A_AND_A_L2A); - while (true) { - s7_pointer result= fx_call (sc, fx_or); - if (result != sc->F) return (result); - if (fx_call (sc, fx_and) == sc->F) return (sc->F); - sc->rec_p1= fx_call (sc, fx_la); - slot_set_value (l2a_slot, fx_call (sc, fx_l2a)); - slot_set_value (la_slot, sc->rec_p1); - } - return (sc->F); -} - -static s7_pointer -op_tc_and_a_or_a_l3a (s7_scheme* sc, s7_pointer code) { - const s7_pointer fx_and= cdr (code), la_slot= let_slots (sc->curlet); - const s7_pointer fx_or = cdadr (fx_and); - const s7_pointer fx_la = cdadr (fx_or); - const s7_pointer fx_l2a = cdr (fx_la); - const s7_pointer fx_l3a = cdr (fx_l2a); - const s7_pointer l2a_slot= next_slot (la_slot); - const s7_pointer l3a_slot= next_slot (l2a_slot); - tick_tc (sc, OP_TC_AND_A_OR_A_L3A); - while (true) { - s7_pointer p; - if (fx_call (sc, fx_and) == sc->F) return (sc->F); - p= fx_call (sc, fx_or); - if (p != sc->F) return (p); - sc->rec_p1= fx_call (sc, fx_la); - sc->rec_p2= fx_call (sc, fx_l2a); - slot_set_value (l3a_slot, fx_call (sc, fx_l3a)); - slot_set_value (l2a_slot, sc->rec_p2); - slot_set_value (la_slot, sc->rec_p1); - } - return (sc->F); -} - -static s7_pointer -op_tc_or_a_and_a_l3a (s7_scheme* sc, s7_pointer code) { - const s7_pointer fx_or= cdr (code), la_slot= let_slots (sc->curlet); - const s7_pointer fx_and = cdadr (fx_or); - const s7_pointer fx_la = cdadr (fx_and); - const s7_pointer fx_l2a = cdr (fx_la); - const s7_pointer fx_l3a = cdr (fx_l2a); - const s7_pointer l2a_slot= next_slot (la_slot); - const s7_pointer l3a_slot= next_slot (l2a_slot); - tick_tc (sc, OP_TC_OR_A_AND_A_L3A); - while (true) { - s7_pointer result= fx_call (sc, fx_or); - if (result != sc->F) return (result); - if (fx_call (sc, fx_and) == sc->F) return (sc->F); - sc->rec_p1= fx_call (sc, fx_la); - sc->rec_p2= fx_call (sc, fx_l2a); - slot_set_value (l3a_slot, fx_call (sc, fx_l3a)); - slot_set_value (l2a_slot, sc->rec_p2); - slot_set_value (la_slot, sc->rec_p1); - } - return (sc->F); -} - -static s7_pointer -op_tc_or_a_and_a_a_l3a (s7_scheme* sc, s7_pointer code) { - const s7_pointer fx_or= cdr (code), la_slot= let_slots (sc->curlet); - s7_pointer fx_and1= - opt3_pair (fx_or); /* (or_case) ? cdadr(fx_or) : cdaddr(fx_or); */ - s7_pointer fx_and2 = cdr (fx_and1); - const s7_pointer fx_la = cdadr (fx_and2); - const s7_pointer fx_l2a = cdr (fx_la); - const s7_pointer l2a_slot= next_slot (la_slot); - const s7_pointer fx_l3a = cdr (fx_l2a); - const s7_pointer l3a_slot= next_slot (l2a_slot); - tick_tc (sc, OP_TC_OR_A_AND_A_A_L3A); - 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 result= fx_call (sc, fx_or); - if (result != sc->F) return (result); - if ((fx_call (sc, fx_and1) != sc->F) || (fx_call (sc, fx_and2) != sc->F)) - return (sc->F); - sc->rec_p1= fx_call (sc, fx_la); - sc->rec_p2= fx_call (sc, fx_l2a); - slot_set_value (l3a_slot, fx_call (sc, fx_l3a)); - slot_set_value (la_slot, sc->rec_p1); - slot_set_value (l2a_slot, sc->rec_p2); - } - } - while (true) { - s7_pointer result= fx_call (sc, fx_or); - if (result != sc->F) return (result); - if ((fx_call (sc, fx_and1) == sc->F) || (fx_call (sc, fx_and2) == sc->F)) - return (sc->F); - sc->rec_p1= fx_call (sc, fx_la); - sc->rec_p2= fx_call (sc, fx_l2a); - slot_set_value (l3a_slot, fx_call (sc, fx_l3a)); - slot_set_value (la_slot, sc->rec_p1); - slot_set_value (l2a_slot, sc->rec_p2); - } - return (sc->F); -} +static bool op_unknown_np(s7_scheme *sc) /* we assume in eval that this always returns true */ +{ + const s7_pointer code = sc->code, func = sc->last_function, head = car(sc->code); + const int32_t num_args = (is_pair(cdr(code))) ? opt3_arglen(cdr(code)) : 0; -static bool -op_tc_if_a_z_if_a_z_la (s7_scheme* sc, s7_pointer code, bool z_first) { - s7_pointer if1_test, if1_true, if1_false, if2_test, if2_z, la, endp, - la_slot = let_slots (sc->curlet); - bool tc_and = (car (code) == sc->and_symbol); - bool tc_cond= (car (code) == sc->cond_symbol); - tick_tc (sc, OP_TC_IF_A_Z_IF_A_Z_LA); - if (!tc_cond) /* code: (if a1 z1 (if a2 z2 la) or (and a1 (if a2 z la))? */ - { - if1_test = cdr (code); - if1_true = (!tc_and) ? cdr (if1_test) : sc->F; - if1_false= (!tc_and) ? cadr (if1_true) : cadr (if1_test); - if2_test = cdr (if1_false); - if2_z = (z_first) ? cdr (if2_test) : cddr (if2_test); - la = (z_first) ? cdaddr (if2_test) : cdadr (if2_test); - } - else { - if1_test = cadr (code); /* code: (cond (a1 z1) (a2 z2|la) (else la|z3)) */ - if1_true = cdr (if1_test); - if1_false= caddr (code); /* (a2 z2|la) */ - if2_test = if1_false; - if2_z = (z_first) ? cdr (if2_test) : cdr (cadddr (code)); - la = (z_first) ? cdadr (cadddr (code)) : cdadr (caddr (code)); - } - if (is_t_integer (slot_value (la_slot))) { - opt_info* o= sc->opts[0]; - sc->pc = 0; - if (bool_optimize_nw (sc, if1_test)) { - opt_info* o1= sc->opts[sc->pc]; - if (bool_optimize_nw (sc, if2_test)) { - opt_info* o2= sc->opts[sc->pc]; - if (int_optimize (sc, la)) { - s7_pointer val= - make_mutable_integer (sc, integer (slot_value (la_slot))); - slot_set_value (la_slot, val); - if (tc_and) - while (true) { - if (!q_call (o).fb (o)) { - sc->value= sc->F; - return (true); - } - if (q_call (o1).fb (o1) == z_first) { - endp= if2_z; - break; - } - set_integer (val, q_call (o2).fi (o2)); - } - else - while (true) { - if (q_call (o).fb (o)) { - endp= if1_true; - break; - } - if (q_call (o1).fb (o1) == z_first) { - endp= if2_z; - break; - } - set_integer (val, q_call (o2).fi (o2)); - } - return (op_tc_z (sc, endp)); - } - } - } - } - while (true) { - if ((fx_call (sc, if1_test) == sc->F) == tc_and) { - if (tc_and) { - sc->value= sc->F; - return (true); - } - else { - endp= if1_true; - break; - } - } - if ((fx_call (sc, if2_test) == sc->F) != z_first) { - endp= if2_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) { - op_tc_if_a_z_if_a_z_la (sc, arg, true); - 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); - 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); - 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); - return (sc->value); -} - -static bool -op_tc_if_a_z_if_a_z_l2a (s7_scheme* sc, s7_pointer code) { - const bool cond= (car (code) == sc->cond_symbol); - s7_pointer if2_test, if2_true, la, l2a, l2a_slot, endp, slot1; - const s7_pointer la_slot = let_slots (sc->curlet); - const s7_pointer if1_test= (cond) ? cadr (code) : cdr (code); - const s7_pointer if1_true= cdr (if1_test); - tick_tc (sc, OP_TC_IF_A_Z_IF_A_Z_L2A); - if2_test= (cond) ? caddr (code) : cdadr (if1_true); - if2_true= cdr (if2_test); - la = (cond) ? opt3_pair (code) : cdadr (if2_true); /* cdadr(cadddr(code)) */ - l2a= cdr (la); - l2a_slot= next_slot (la_slot); - slot1 = (fx_proc (if1_test) == fx_is_null_t) - ? la_slot - : ((fx_proc (if1_test) == fx_is_null_u) ? l2a_slot : NULL); - if (slot1) { - if ((slot1 == l2a_slot) && (fx_proc (if2_test) == fx_is_null_t) && - (fx_proc (la) == fx_cdr_t) && (fx_proc (l2a) == fx_cdr_u) && - (is_boolean (car (if1_true))) && - (is_boolean (car (if2_true)))) { /* ugly... */ - s7_pointer la_val= slot_value (la_slot), l2a_val= slot_value (l2a_slot); - while (true) { - if (is_null (l2a_val)) { - sc->value= car (if1_true); - return (true); - } - if (is_null (la_val)) { - sc->value= car (if2_true); - return (true); - } - if (!is_pair (l2a_val)) - sole_arg_wrong_type_error_nr (sc, sc->cdr_symbol, l2a_val, - sc->type_names[T_PAIR]); - if (!is_pair (la_val)) - sole_arg_wrong_type_error_nr (sc, sc->cdr_symbol, la_val, - sc->type_names[T_PAIR]); - la_val = cdr (la_val); - l2a_val= cdr (l2a_val); - } - } - while (true) { - if (is_null (slot_value (slot1))) { - endp= if1_true; - break; - } - if (fx_call (sc, if2_test) != sc->F) { - endp= if2_true; - break; - } - sc->rec_p1= fx_call (sc, la); - slot_set_value (l2a_slot, fx_call (sc, l2a)); - slot_set_value (la_slot, sc->rec_p1); - } - } - else - while (true) { - if (fx_call (sc, if1_test) != sc->F) { - endp= if1_true; - break; - } - if (fx_call (sc, if2_test) != sc->F) { - endp= if2_true; - break; - } - sc->rec_p1= fx_call (sc, la); - slot_set_value (l2a_slot, fx_call (sc, l2a)); - 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_l2a (s7_scheme* sc, s7_pointer arg) { - op_tc_if_a_z_if_a_z_l2a (sc, arg); - sc->rec_p1= sc->unused; - return (sc->value); -} - -static bool -op_tc_if_a_z_if_a_l2a_z (s7_scheme* sc, s7_pointer code) { - bool cond= car (code) == sc->cond_symbol; - s7_pointer if2_test, if2_true, if2_false, la, l2a, l2a_slot, endp; - const s7_pointer la_slot = let_slots (sc->curlet); - const s7_pointer if1_test= (cond) ? cadr (code) : cdr (code); - const s7_pointer if1_true= cdr (if1_test); - if2_test = (cond) ? caddr (code) : cdadr (if1_true); - if2_true = cdr (if2_test); - if2_false = (cond) ? cdr (cadddr (code)) : cdr (if2_true); - la = (cond) ? opt3_pair (code) : cdar (if2_true); /* cdadr(caddr(code)) */ - l2a= cdr (la); - l2a_slot= next_slot (la_slot); - while (true) { - if (fx_call (sc, if1_test) != sc->F) { - endp= if1_true; - break; - } - if (fx_call (sc, if2_test) == sc->F) { - endp= if2_false; - break; - } - sc->rec_p1= fx_call (sc, la); - slot_set_value (l2a_slot, fx_call (sc, l2a)); - slot_set_value (la_slot, sc->rec_p1); - } - return (op_tc_z (sc, endp)); -} - -static s7_pointer -fx_tc_if_a_z_if_a_l2a_z (s7_scheme* sc, s7_pointer arg) { - tick_tc (sc, OP_TC_IF_A_Z_IF_A_L2A_Z); - op_tc_if_a_z_if_a_l2a_z (sc, arg); - sc->rec_p1= sc->unused; - return (sc->value); -} - -static bool -op_tc_if_a_z_if_a_l3a_l3a (s7_scheme* sc, s7_pointer code) { - const s7_pointer if1_test= cdr (code); - s7_pointer endp; - const s7_pointer la_slot = let_slots (sc->curlet); - const s7_pointer if1_true = cdr (if1_test); - const s7_pointer if1_false= cadr (if1_true); - const s7_pointer if2_test = cdr (if1_false); - const s7_pointer if2_true = cdr (if2_test); - const s7_pointer if2_false= cdr (if2_true); - const s7_pointer la1 = cdar (if2_true); - const s7_pointer la2 = cdar (if2_false); - const s7_pointer l2a1 = cdr (la1); - const s7_pointer l2a2 = cdr (la2); - const s7_pointer l2a_slot = next_slot (la_slot); - const s7_pointer l3a1 = cdr (l2a1); - const s7_pointer l3a2 = cdr (l2a2); - const s7_pointer l3a_slot = next_slot (l2a_slot); - tick_tc (sc, OP_TC_IF_A_Z_IF_A_L3A_L3A); - while (true) { - if (fx_call (sc, if1_test) != sc->F) { - endp= if1_true; - break; - } - if (fx_call (sc, if2_test) != sc->F) { - sc->rec_p1= fx_call (sc, la1); - sc->rec_p2= fx_call (sc, l2a1); - slot_set_value (l3a_slot, fx_call (sc, l3a1)); - } - else { - sc->rec_p1= fx_call (sc, la2); - sc->rec_p2= fx_call (sc, l2a2); - slot_set_value (l3a_slot, fx_call (sc, l3a2)); - } - slot_set_value (l2a_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) { - op_tc_if_a_z_if_a_l3a_l3a (sc, arg); - sc->rec_p1= sc->unused; - sc->rec_p2= sc->unused; - return (sc->value); -} - -static bool -op_tc_if_a_z_if_a_z_l3a (s7_scheme* sc, s7_pointer code, - bool zfirst) /* zfirst: z_l3a rather than l3a_z */ -{ - const s7_pointer if1_test= cdr (code); - s7_pointer endp; - const s7_pointer la_slot = let_slots (sc->curlet); - const s7_pointer l2a_slot = next_slot (la_slot); - const s7_pointer l3a_slot = next_slot (l2a_slot); - const s7_pointer if1_true = cdr (if1_test); - const s7_pointer if1_false= cadr (if1_true); - const s7_pointer if2_test = cdr (if1_false); - const s7_pointer if2_true = cdr (if2_test); - const s7_pointer if2_false= cdr (if2_true); - const s7_pointer zendp = (zfirst) ? if2_true : if2_false; - const s7_pointer la2 = (zfirst) ? cdar (if2_false) : cdar (if2_true); - const s7_pointer l2a2 = cdr (la2); - const s7_pointer l3a2 = cdr (l2a2); - tick_tc (sc, (zfirst) ? OP_TC_IF_A_Z_IF_A_Z_L3A : OP_TC_IF_A_Z_IF_A_L3A_Z); - - while (true) { - if (fx_call (sc, if1_test) != sc->F) { - endp= if1_true; - break; - } - if ((fx_call (sc, if2_test) != sc->F) == zfirst) { - endp= zendp; - break; - } - sc->rec_p1= fx_call (sc, la2); - sc->rec_p2= fx_call (sc, l2a2); - slot_set_value (l3a_slot, fx_call (sc, l3a2)); - slot_set_value (l2a_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_z_l3a (s7_scheme* sc, s7_pointer arg) { - op_tc_if_a_z_if_a_z_l3a (sc, arg, true); - sc->rec_p1= sc->unused; - sc->rec_p2= sc->unused; - return (sc->value); -} - -static s7_pointer -fx_tc_if_a_z_if_a_l3a_z (s7_scheme* sc, s7_pointer arg) { - op_tc_if_a_z_if_a_z_l3a (sc, arg, false); - sc->rec_p1= sc->unused; - sc->rec_p2= sc->unused; - return (sc->value); -} - -static bool -op_tc_let_if_a_z_la (s7_scheme* sc, s7_pointer code) { - const s7_pointer body = caddr (code); - const s7_pointer outer_let= sc->curlet; - const s7_pointer la_slot = let_slots (outer_let); - const s7_pointer if_test = cdr (body); - const s7_pointer if_true = cddr (body); - const bool wrappable= has_fx (if_true); - const s7_pointer if_false = cadddr (body); - const s7_pointer la = cdr (if_false); - s7_pointer let_var = caadr (code); - const s7_pointer inner_let= - (wrappable) ? wrap_let_with_slot (sc, sc->curlet, car (let_var), - fx_call (sc, cdr (let_var))) - : make_let_with_slot (sc, sc->curlet, car (let_var), - fx_call (sc, cdr (let_var))); - const s7_pointer let_slot= let_slots (inner_let); - tick_tc (sc, OP_TC_LET_IF_A_Z_LA); - set_curlet (sc, inner_let); - if (!wrappable) gc_protect_via_stack (sc, inner_let); - let_var= cdr (let_var); - - 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); - } - if (!wrappable) unstack_gc_protect (sc); - if (!op_tc_z (sc, if_true)) return (false); - let_set_slots (inner_let, slot_end); - return (true); -} - -static s7_pointer -fx_tc_let_if_a_z_la (s7_scheme* sc, s7_pointer arg) { - op_tc_let_if_a_z_la (sc, arg); - return (sc->value); -} - -static bool -op_tc_let_if_a_z_l2a (s7_scheme* sc, s7_pointer code) { - const s7_pointer body = caddr (code); - const s7_pointer outer_let= sc->curlet; - const s7_pointer la_slot = let_slots (outer_let); - const s7_pointer l2a_slot = next_slot (la_slot); - const s7_pointer if_test = cdr (body); - const s7_pointer if_true = cddr (body); - const bool wrappable= has_fx (if_true); - const s7_pointer if_false = cadddr (body); - const s7_pointer la = cdr (if_false); - const s7_pointer l2a = cddr (if_false); - s7_pointer let_var = caadr (code); - s7_pointer inner_let= (wrappable) - ? wrap_let_with_slot (sc, sc->curlet, car (let_var), - fx_call (sc, cdr (let_var))) - : make_let_with_slot (sc, sc->curlet, car (let_var), - fx_call (sc, cdr (let_var))); - const s7_pointer let_slot = let_slots (inner_let); - tick_tc (sc, OP_TC_LET_IF_A_Z_L2A); - set_curlet (sc, inner_let); - if (!wrappable) gc_protect_via_stack (sc, inner_let); - let_var= cdr (let_var); - if (!no_bool_opt (code)) { - sc->pc= 0; - if (bool_optimize (sc, if_test)) { - opt_info* o = sc->opts[0]; - opt_info *o1= sc->opts[sc->pc], *o2, *o3; - if ((is_t_integer (slot_value (la_slot))) && - (is_t_integer (slot_value (l2a_slot)))) { - if (int_optimize (sc, la)) { - o2= sc->opts[sc->pc]; - if (int_optimize (sc, l2a)) { - o3= sc->opts[sc->pc]; - set_curlet (sc, outer_let); - if (int_optimize (sc, let_var)) { - s7_pointer val1= - make_mutable_integer (sc, integer (slot_value (la_slot))); - s7_pointer val2= - make_mutable_integer (sc, integer (slot_value (l2a_slot))); - s7_pointer val3= - make_mutable_integer (sc, integer (slot_value (let_slot))); - set_curlet (sc, inner_let); - slot_set_value (la_slot, val1); - slot_set_value (l2a_slot, val2); - slot_set_value (let_slot, val3); - while (!(q_call (o).fb (o))) { - s7_int i1= q_call (o1).fi (o1); - set_integer (val2, q_call (o2).fi (o2)); - set_integer (val1, i1); - set_integer (val3, q_call (o3).fi (o3)); - } - if (!wrappable) unstack_gc_protect (sc); - if (!op_tc_z (sc, if_true)) return (false); - let_set_slots (inner_let, slot_end); - return (true); - } - } - } - } - } - set_no_bool_opt (code); - } - while (fx_call (sc, if_test) == sc->F) { - sc->rec_p1= fx_call (sc, la); - slot_set_value (l2a_slot, fx_call (sc, l2a)); - 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); - } - if (!wrappable) unstack_gc_protect (sc); - if (!op_tc_z (sc, if_true)) return (false); - let_set_slots (inner_let, slot_end); - return (true); -} - -static s7_pointer -fx_tc_let_if_a_z_l2a (s7_scheme* sc, s7_pointer arg) { - op_tc_let_if_a_z_l2a (sc, arg); - sc->rec_p1= sc->unused; - return (sc->value); -} - -static s7_pointer -op_tc_let_when_l2a (s7_scheme* sc, s7_pointer code) { - s7_pointer p, la, l2a, let_var= caadr (code); - const s7_pointer body= caddr (code), outer_let= sc->curlet; - const bool when= - (car (body) != sc->unless_symbol); /* can also be when or if */ - const s7_pointer if_test = cdr (body); - const s7_pointer if_true = cddr (body); - s7_pointer inner_let= wrap_let_with_slot (sc, sc->curlet, car (let_var), - fx_call (sc, cdr (let_var))); - s7_pointer let_slot = let_slots (inner_let); - tick_tc (sc, OP_TC_LET_WHEN_L2A); - - set_curlet (sc, inner_let); - let_var= cdr (let_var); - for (p= if_true; is_pair (cdr (p)); p= cdr (p)) - ; - la = cdar (p); - l2a= cddar (p); - if ((car (la) == slot_symbol (let_slots (outer_let))) && - (car (l2a) == slot_symbol (next_slot (let_slots (outer_let))))) { - if ((cdr (if_true) == p) && (!when)) { - s7_pointer a1= slot_value (let_slots (outer_let)); - s7_pointer 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= (int32_t) s7_character (slot_value (let_slots (inner_let))); - a1 = slot_value (let_slots (outer_let)); - a2 = slot_value (next_slot (let_slots (outer_let))); - while (c != EOF) { - inline_file_write_char (sc, (uint8_t) c, a2); - c= string_read_char (sc, a1); - } - } + if (!func) unbound_variable_error_nr(sc, head); + if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s %s %s\n", + __func__, __LINE__, display_truncated(func), type_name(sc, func, no_article), display_truncated(sc->code)); + switch (type(func)) + { + case T_C_FUNCTION: + if (!c_function_is_aritable(func, num_args)) break; + case T_C_RST_NO_REQ_FUNCTION: + if (num_args == 1) + set_any_c_np(sc, func, code, sc->curlet, num_args, (is_safe_procedure(func)) ? OP_SAFE_C_P : OP_C_P); 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) { - s7_pointer p2= fx_call (sc, if_test); - if (when) { - if (p2 == sc->F) break; - } - else { - if (p2 != sc->F) break; - } - for (s7_pointer p1= if_true; is_pair (cdr (p1)); p1= cdr (p1)) - fx_call (sc, p1); - set_curlet (sc, outer_let); - slot_set_value (let_slot, fx_call (sc, let_var)); - set_curlet (sc, inner_let); - } - } - else { - s7_pointer la_slot = let_slots (outer_let); - s7_pointer l2a_slot= next_slot (la_slot); - while (true) { - s7_pointer p2= fx_call (sc, if_test); - if (when) { - if (p2 == sc->F) break; - } - else { - if (p2 != sc->F) break; - } - for (s7_pointer p1= if_true; is_pair (cdr (p1)); p1= cdr (p1)) - fx_call (sc, p1); - sc->rec_p1= fx_call (sc, la); - slot_set_value (l2a_slot, fx_call (sc, l2a)); - 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); - } - } - return (sc->unspecified); -} - -static bool -op_tc_if_a_z_let_if_a_z_l2a (s7_scheme* sc, s7_pointer code) { - s7_pointer endp, slot; - const s7_pointer if1_test= cdr (code), outer_let= sc->curlet, - la_slot = let_slots (sc->curlet); - const s7_pointer if1_true = cdr (if1_test); /* cddr(code) */ - const s7_pointer let_expr = cadr (if1_true); /* cadddr(code) */ - const s7_pointer let_vars = cadr (let_expr); - const s7_pointer if2 = caddr (let_expr); - const s7_pointer if2_test = cdr (if2); - const s7_pointer if2_true = cdr (if2_test); /* cddr(if2) */ - const s7_pointer la = cdadr (if2_true); /* cdr(cadddr(if2)) */ - const s7_pointer l2a = cdr (la); - const s7_pointer l2a_slot = next_slot (la_slot); - const s7_pointer inner_let= inline_make_let (sc, sc->curlet); - tick_tc (sc, OP_TC_IF_A_Z_LET_IF_A_Z_L2A); - - gc_protect_via_stack (sc, inner_let); - slot= make_slot (sc, caar (let_vars), sc->F); - slot_set_next (slot, slot_end); - let_set_slots (inner_let, slot); - symbol_set_local_slot_unincremented (caar (let_vars), let_id (inner_let), - slot); - for (s7_pointer 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 (s7_pointer var= cdr (let_vars), slot1= next_slot (slot); is_pair (var); - var= cdr (var), slot1= next_slot (slot1)) - slot_set_value (slot1, 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 (l2a_slot, fx_call (sc, l2a)); - slot_set_value (la_slot, sc->rec_p1); - set_curlet (sc, outer_let); - } - sc->rec_p1= sc->unused; - unstack_gc_protect (sc); - return (op_tc_z (sc, endp)); /* might refer to inner_let slots */ -} - -static bool -op_tc_let_cond (s7_scheme* sc, s7_pointer code) { - const s7_int args= opt3_arglen (cdr (code)); - s7_pointer result; - const s7_pointer outer_let= sc->curlet; - const s7_pointer slots = let_slots (outer_let); - const s7_pointer cond_body= cdaddr (code); /* code here == body in check_tc */ - s7_pointer let_var = caadr (code); - s7_function letf = fx_proc (cdr (let_var)); - const s7_pointer inner_let= make_let_with_slot (sc, sc->curlet, car (let_var), - fx_call (sc, cdr (let_var))); - const s7_pointer let_slot = let_slots (inner_let); - tick_tc (sc, OP_TC_LET_COND); - - set_curlet (sc, inner_let); - gc_protect_via_stack (sc, inner_let); - let_var= cadr (let_var); - if ((letf == fx_c_s_direct) && - (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)); - } - /* in the named let no-var case slots may contain the let name (it's the - * funclet) */ - if (args < 2) - while (true) - for (s7_pointer p= cond_body; is_pair (p); p= cdr (p)) - if (fx_call (sc, car (p)) != sc->F) { - result= cdar (p); - if (!has_tc (result)) goto TC_LET_COND_DONE; - if (args == 1) - 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; - } - let_set_has_pending_value (outer_let); - { - bool read_case= ((letf == read_char_p_p) && (is_input_port (let_var)) && - (is_string_port (let_var)) && (!port_is_closed (let_var))); - while (true) - for (s7_pointer p= cond_body; is_pair (p); p= cdr (p)) - if (fx_call (sc, car (p)) != sc->F) { - result= cdar (p); - if (!has_tc (result)) goto TC_LET_COND_DONE; - for (s7_pointer 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 (s7_pointer slot= slots; is_not_slot_end (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; - } - } - let_clear_has_pending_value (sc, outer_let); - -TC_LET_COND_DONE: - unstack_gc_protect (sc); - if (has_fx (result)) { - sc->value= fx_call (sc, result); - return (true); - } - sc->code= car (result); - return (false); -} - -static s7_pointer -fx_tc_let_cond (s7_scheme* sc, s7_pointer arg) { - op_tc_let_cond (sc, arg); - return (sc->value); -} - -static bool -op_tc_cond_a_z_a_l2a_l2a (s7_scheme* sc, s7_pointer code) { - s7_pointer c1= cadr (code); - const s7_pointer c2= caddr (code), la_slot= let_slots (sc->curlet); - const s7_pointer la1 = cdadr (c2); - const s7_pointer l2a1= cddadr (c2); - const s7_pointer c3= - opt3_pair (code); /* cadr(cadddr(code)) = cadr(else_clause) */ - const s7_pointer la2 = cdr (c3); - const s7_pointer l2a2 = cddr (c3); - const s7_pointer l2a_slot= next_slot (la_slot); - tick_tc (sc, OP_TC_COND_A_Z_A_L2A_L2A); - while (true) { - if (fx_call (sc, c1) != sc->F) { - c1= cdr (c1); + if ((num_args == 2) && (is_safe_procedure(func))) + { + set_any_c_np(sc, func, code, sc->curlet, 2, OP_SAFE_C_PP); + opt_sp_1(sc, c_function_call(func), code); + } + else + if ((num_args == 3) && + ((is_safe_procedure(func)) || + ((is_semisafe(func)) && + (((head != sc->assoc_symbol) && (head != sc->member_symbol)) || + (unsafe_is_safe(sc, cadddr(code), sc->curlet)))))) + set_any_c_np(sc, func, code, sc->curlet, 3, OP_SAFE_C_3P); + else set_any_c_np(sc, func, code, sc->curlet, num_args, OP_ANY_C_NP); + return(true); + + case T_CLOSURE: + if ((!has_methods(func)) && + (closure_arity_to_int(sc, func) == num_args)) /* if values clo as arg, we need to know how many values etc */ + { + const int32_t hop = (is_immutable_and_stable(sc, head)) ? 1 : 0; + const bool safe_case = is_safe_closure(func); + switch (num_args) + { + case 1: + if (safe_case) + { + const s7_pointer body = closure_body(func); + 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_add(code, func); /* added 8-Jun-22 */ + set_opt3_arglen(cdr(code), 1); + 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 + ((safe_case) ? 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 + ((safe_case) ? OP_SAFE_CLOSURE_PA : OP_CLOSURE_PA)); + } + else set_optimize_op(code, hop + ((safe_case) ? OP_SAFE_CLOSURE_PP : OP_CLOSURE_PP)); + set_opt1_lambda_add(code, func); /* added 8-Jun-22 */ + set_opt3_arglen(cdr(code), 2); /* for later op_unknown_np */ + set_unsafely_optimized(code); + break; + + case 3: set_any_closure_np(sc, func, code, sc->curlet, 3, hop + OP_ANY_CLOSURE_3P); break; + case 4: set_any_closure_np(sc, func, code, sc->curlet, 4, hop + OP_ANY_CLOSURE_4P); break; + default: set_any_closure_np(sc, func, code, sc->curlet, num_args, hop + OP_ANY_CLOSURE_NP); break; + } + return(true); + } break; + + /* PERHAPS: T_CLOSURE_STAR? */ + case T_BACRO: case T_MACRO: return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_D, func))); + case T_BACRO_STAR: case T_MACRO_STAR: return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_STAR_D, func))); } - if (fx_call (sc, c2) != sc->F) { - sc->rec_p1= fx_call (sc, la1); - slot_set_value (l2a_slot, fx_call (sc, l2a1)); - } - else { - sc->rec_p1= fx_call (sc, la2); - slot_set_value (l2a_slot, fx_call (sc, l2a2)); - } - slot_set_value (la_slot, sc->rec_p1); - } - return (op_tc_z (sc, c1)); + return(unknown_unknown(sc, sc->code, OP_CLEAR_OPTS)); } -static s7_pointer -fx_tc_cond_a_z_a_l2a_l2a (s7_scheme* sc, s7_pointer arg) { - op_tc_cond_a_z_a_l2a_l2a (sc, arg); - sc->rec_p1= sc->unused; - return (sc->value); +static bool unknown_any(s7_scheme *sc, s7_pointer func, s7_pointer code) +{ + sc->last_function = func; + if (is_null(cdr(code))) return(op_unknown(sc)); + if ((is_null(cddr(code))) && (is_normal_symbol(cadr(code)))) return(op_unknown_s(sc)); + set_opt3_arglen(cdr(code), proper_list_length(cdr(code))); + return(op_unknown_np(sc)); } -static bool -op_tc_cond_n (s7_scheme* sc, s7_pointer code) { - const s7_pointer let = sc->curlet; - const s7_pointer slots = let_slots (let); - const s7_int args = opt3_arglen (cdr (code)); - const s7_pointer cond_body= cdr (code); - s7_pointer result = sc->unspecified; - tick_tc (sc, OP_TC_COND_N); - if (args < 2) - while (true) - for (s7_pointer p= cond_body; is_pair (p); p= cdr (p)) - if (fx_call (sc, car (p)) != sc->F) /* we got true car(clause) */ - { - result= cdar (p); - if (!has_tc (result)) goto TC_COND_N_DONE; - if (args == 1) - slot_set_value (slots, - fx_call (sc, cdar (result))); /* arg to recursion */ - break; /* tc call */ - } - let_set_has_pending_value (let); - while (true) - for (s7_pointer p= cond_body; is_pair (p); p= cdr (p)) - if (fx_call (sc, car (p)) != sc->F) { - result= cdar (p); - if (!has_tc (result)) goto TC_COND_N_DONE; - for (s7_pointer 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 (s7_pointer slot= slots; is_not_slot_end (slot); - slot = next_slot ( - slot)) /* using two swapping lets instead is slightly slower */ - slot_set_value (slot, slot_pending_value (slot)); - break; - } - let_clear_has_pending_value (sc, let); +/* ---------------- eval type checkers ---------------- */ -TC_COND_N_DONE: - if (has_fx (result)) { - sc->value= fx_call (sc, result); - return (true); - } - sc->code= car (result); - return (false); +#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)))) + +static bool c_function_is_ok_cadr_caddr(s7_scheme *sc, s7_pointer p) +{ + return((c_function_is_ok(sc, p)) && (h_c_function_is_ok(sc, cadr(p))) && (h_c_function_is_ok(sc, caddr(p)))); } -static s7_pointer -fx_tc_cond_n (s7_scheme* sc, s7_pointer arg) { - op_tc_cond_n (sc, arg); - return (sc->value); +static bool c_function_is_ok_cadr_cadadr(s7_scheme *sc, s7_pointer p) +{ + return((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) */ } -/* -------- rec -------- */ +static bool c_function_is_ok_cadr_caddadr(s7_scheme *sc, s7_pointer p) +{ + return((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) */ +} -#ifndef INITIAL_RECUR_STACK_SIZE -#define INITIAL_RECUR_STACK_SIZE \ - 1024 /* stack max size 39 in s7test.scm, 1001 trec, 513 c, 100 b */ -#endif +/* 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 void -recur_resize (s7_scheme* sc) { - const s7_pointer stack= sc->rec_stack; - block_t * old_b, *new_b; - if ((sc->rec_len / 2) > - sc->max_stack_size) /* /2 not *2 because the stack size refers to the - 4-frame main stack */ -#if S7_DEBUGGING - { - fprintf (stderr, - "%s%s[%d]: rec stack will be too big after resize, %" ld64 - " > %u%s\n", - bold_text, __func__, __LINE__, sc->rec_len / 2, sc->max_stack_size, - unbold_text); - if (sc->stop_at_error) abort (); - } -#else - error_nr (sc, make_symbol (sc, "stack-too-big", 13), - set_elist_1 ( - sc, wrap_string ( - sc, "rec stack has grown past (*s7* 'max-stack-size)", - 47))); -#endif - vector_length (stack)= sc->rec_len * 2; - old_b = vector_block (stack); - new_b= reallocate (sc, old_b, vector_length (stack) * sizeof (s7_pointer)); - block_info (new_b) = NULL; - vector_block (stack) = new_b; - vector_elements (stack)= (s7_pointer*) block_data ( - new_b); /* 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 */ bool closure_is_ok_1(s7_scheme *sc, s7_pointer code, uint16_t type, int32_t args) +{ + const s7_pointer clo = lookup_unexamined(sc, car(code)); + if ((clo == opt1_lambda_unchecked(code)) || + ((clo) && /* this fixup check does save time (e.g. cb) */ + (low_type_bits(clo) == type) && + ((closure_arity(clo) == args) || (closure_arity_to_int(sc, clo) == args)) && /* 3 type bits to replace this but not hit enough to warrant them */ + (set_opt1_lambda(code, clo)))) + return(true); + sc->last_function = clo; + return(false); } -static inline void -recur_push_unchecked (s7_scheme* sc, s7_pointer value) { - if ((S7_DEBUGGING) && (sc->rec_loc == sc->rec_len)) - fprintf (stderr, "%s[%d]: recur stack resize skipped\n", __func__, - __LINE__); - sc->rec_els[sc->rec_loc++]= value; +static /* inline */ bool closure_is_fine_1(s7_scheme *sc, s7_pointer code, uint16_t type, int32_t args) +{ + const s7_pointer clo = lookup_unexamined(sc, car(code)); + if ((clo == opt1_lambda_unchecked(code)) || + ((clo) && + ((low_type_bits(clo) & (TYPE_MASK | T_SAFE_CLOSURE)) == type) && + ((closure_arity(clo) == args) || (closure_arity_to_int(sc, clo) == args)) && + (set_opt1_lambda(code, clo)))) + return(true); + sc->last_function = clo; + return(false); } -static s7_pointer -recur_pop (s7_scheme* sc) { - return (sc->rec_els[--sc->rec_loc]); -} /* macro is not faster */ -static s7_pointer -recur_ref (s7_scheme* sc, s7_int loc) { - return (sc->rec_els[sc->rec_loc - loc]); +static bool closure_np_is_ok_1(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer clo = lookup_unexamined(sc, car(code)); + if ((clo == opt1_lambda_unchecked(code)) || + ((clo) && + (is_closure(clo)) && + (set_opt1_lambda(code, clo)))) + return(true); + sc->last_function = clo; + return(false); } -static s7_pointer -recur_pop2 (s7_scheme* sc) { - sc->rec_loc-= 2; - return (sc->rec_els[sc->rec_loc + 1]); -} +/* 20-Jun-24 calls=closure_is_*, misses=symbol_ctr != 1 + s7test: calls: 974814, misses: 550785 + full: calls: 11433106, misses: 6406461 + tlet: calls: 3600032, misses: 1900012 + tlamb: calls: 33000005, misses: 11999999 + tset: calls: 1329500, misses: 998 + lt: calls: 1374000, misses: 232936 + tmat: calls: 222206, misses: 0 (tobj, tsort, tform, tread, tfft, thash, etc) + so symbol_ctr==1 is valuable + */ -static s7_pointer -recur_swap (s7_scheme* sc, s7_pointer value) { - s7_pointer result = sc->rec_els[sc->rec_loc - 1]; - sc->rec_els[sc->rec_loc - 1]= value; - return (result); -} +#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) ((symbol_ctr(car(Code)) == 1) || (closure_np_is_ok_1(Sc, Code))) +#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 void -initialize_recur_stack (s7_scheme* sc) { - sc->rec_stack= make_simple_vector (sc, INITIAL_RECUR_STACK_SIZE); - sc->rec_els = vector_elements (sc->rec_stack); - sc->rec_len = INITIAL_RECUR_STACK_SIZE; - sc->rec_loc = 0; +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 void -rec_set_test (s7_scheme* sc, s7_pointer p) { - sc->rec_testf= fx_proc (p); - sc->rec_testp= car (p); -} -static void -rec_set_res (s7_scheme* sc, s7_pointer p) { - sc->rec_resf= fx_proc (p); - sc->rec_resp= car (p); -} -static void -rec_set_f1 (s7_scheme* sc, s7_pointer p) { - sc->rec_f1f= fx_proc (p); - sc->rec_f1p= car (p); -} -static void -rec_set_f2 (s7_scheme* sc, s7_pointer p) { - sc->rec_f2f= fx_proc (p); - sc->rec_f2p= car (p); -} -static void -rec_set_f3 (s7_scheme* sc, s7_pointer p) { - sc->rec_f3f= fx_proc (p); - sc->rec_f3p= car (p); -} -static void -rec_set_f4 (s7_scheme* sc, s7_pointer p) { - sc->rec_f4f= fx_proc (p); - sc->rec_f4p= car (p); -} -static void -rec_set_f5 (s7_scheme* sc, s7_pointer p) { - sc->rec_f5f= fx_proc (p); - sc->rec_f5p= car (p); -} -static void -rec_set_f6 (s7_scheme* sc, s7_pointer p) { - sc->rec_f6f= fx_proc (p); - sc->rec_f6p= car (p); -} -static void -rec_set_f7 (s7_scheme* sc, s7_pointer p) { - sc->rec_f7f= fx_proc (p); - sc->rec_f7p= car (p); +static bool star_arity_is_ok(s7_scheme *sc, s7_pointer val, int32_t args) +{ + int32_t arity = closure_star_arity_to_int(sc, val); + return((arity < 0) || ((arity * 2) >= args)); } -static void -rec_set_f8 (s7_scheme* sc, s7_pointer p) { - sc->rec_f8f= fx_proc (p); - sc->rec_f8p= car (p); + +static bool closure_star_is_fine_1(s7_scheme *sc, s7_pointer code, uint16_t type, int32_t args) +{ + const s7_pointer val = lookup_unexamined(sc, car(code)); + if ((val == opt1_lambda_unchecked(code)) || + ((val) && + ((low_type_bits(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); } -typedef enum { opt_ptr, opt_int, opt_dbl, opt_int_0 } opt_pid_t; +/* closure_is_fine: */ +#define FINE_UNSAFE_CLOSURE (T_CLOSURE) +#define FINE_SAFE_CLOSURE (T_CLOSURE | T_SAFE_CLOSURE) -/* -------- if_a_a_opla_laq and if_a_opla_laq_a -------- */ +/* closure_star_is_fine: */ +#define FINE_UNSAFE_CLOSURE_STAR (T_CLOSURE_STAR) +#define FINE_SAFE_CLOSURE_STAR (T_CLOSURE_STAR | T_SAFE_CLOSURE) -static opt_pid_t -opinit_if_a_a_opla_laq (s7_scheme* sc, s7_pointer code) { - const s7_pointer caller= rec_call_clause (code); - const s7_pointer call1 = cadr (caller); - const s7_pointer call2 = caddr (caller); - - const s7_pointer c_op= car (caller); - tick_tc (sc, OP_RECUR_IF_A_A_opLA_LAq); - if ((is_symbol (c_op)) && - ((is_slot (global_slot (c_op))) && - ((is_global (c_op)) || (s7_t_slot (sc, c_op) == global_slot (c_op))))) { - const s7_pointer s_func= global_value (c_op); - const s7_pointer 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, rec_test_clause (code))) { - const 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, rec_done_clause (code)))) { - sc->rec_a1_o= sc->opts[sc->pc]; - if (int_optimize (sc, cdr (call1))) { - sc->rec_a2_o= sc->opts[sc->pc]; - if (int_optimize (sc, cdr (call2))) { - sc->rec_bool= a_is_cadr (code); - 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); /* call1/call2 above are more complicated - than (- n 1) or the like */ - sc->rec_fb1= q_call (sc->rec_test_o).fb; - sc->rec_fi1= q_call (sc->rec_result_o).fi; - sc->rec_fi2= q_call (sc->rec_a1_o).fi; - sc->rec_fi3= q_call (sc->rec_a2_o).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, rec_done_clause (code))) { - sc->rec_a1_o= sc->opts[sc->pc]; - if (float_optimize (sc, cdr (call1))) { - sc->rec_a2_o= sc->opts[sc->pc]; - if (float_optimize (sc, cdr (call2))) { - sc->rec_bool= a_is_cadr (code); - sc->rec_val1= - make_mutable_real (sc, real (slot_value (slot))); - slot_set_value (slot, sc->rec_val1); - return (opt_dbl); - } - } - } - } - } - } - } - } - tick_tc (sc, OP_RECUR_IF_A_A_opLA_LAq); - sc->rec_bool= a_is_cadr (code); - sc->rec_fn = fn_proc (caller); - rec_set_test (sc, rec_test_clause (code)); - rec_set_res (sc, rec_done_clause (code)); - rec_set_f1 (sc, cdr (call1)); - rec_set_f2 (sc, cdr (call2)); - sc->rec_slot1= let_slots (sc->curlet); - sc->rec_loc = 0; - return (opt_ptr); -} - -static s7_int -oprec_i_if_a_a_opla_laq (s7_scheme* sc) { - s7_int i1, i2; - if (q_call (sc->rec_test_o).fb (sc->rec_test_o)) /* if_(A) */ - return (q_call (sc->rec_result_o).fi (sc->rec_result_o)); /* if_a_(A) */ - i1= q_call (sc->rec_a1_o).fi (sc->rec_a1_o); /* save a1 */ - set_integer (sc->rec_val1, - q_call (sc->rec_a2_o).fi (sc->rec_a2_o)); /* slot1 = a2 */ - i2= oprec_i_if_a_a_opla_laq (sc); /* save la2 */ - set_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); - set_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); - set_integer (sc->rec_val1, sc->rec_fi3 (sc->rec_a2_o)); - i3= oprec_i_if_a_a_opla_laq_0 (sc); - set_integer (sc->rec_val1, i2); - i2= sc->rec_i_ii_f (oprec_i_if_a_a_opla_laq_0 (sc), i3); - } - set_integer (sc->rec_val1, i1); - return (sc->rec_i_ii_f (oprec_i_if_a_a_opla_laq_0 (sc), i2)); +/* 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 */ + +static no_return void eval_apply_error_nr(s7_scheme *sc) +{ + error_nr(sc, sc->syntax_error_symbol, /* apply_error_nr expanded */ + set_elist_4(sc, wrap_string(sc, "attempt to apply ~A ~$ in ~$?", 29), + ((is_symbol_and_keyword(sc->code)) ? wrap_string(sc, "a keyword", 9) : type_name_string(sc, sc->code)), + sc->code, + cons(sc, sc->code, sc->args))); } -static s7_double -oprec_d_if_a_a_opla_laq (s7_scheme* sc) { - s7_double x1, x2; - if (q_call (sc->rec_test_o).fb (sc->rec_test_o)) - return (q_call (sc->rec_result_o).fd (sc->rec_result_o)); - x1= q_call (sc->rec_a1_o).fd (sc->rec_a1_o); - set_real (sc->rec_val1, q_call (sc->rec_a2_o).fd (sc->rec_a2_o)); - if (q_call (sc->rec_test_o).fb (sc->rec_test_o)) - x2= q_call (sc->rec_result_o).fd (sc->rec_result_o); - else { - s7_double x3; - x2= q_call (sc->rec_a1_o).fd (sc->rec_a1_o); - set_real (sc->rec_val1, q_call (sc->rec_a2_o).fd (sc->rec_a2_o)); - x3= oprec_d_if_a_a_opla_laq (sc); - set_real (sc->rec_val1, x2); - x2= sc->rec_d_dd_f (oprec_d_if_a_a_opla_laq (sc), x3); - } - set_real (sc->rec_val1, x1); - return (sc->rec_d_dd_f (oprec_d_if_a_a_opla_laq (sc), x2)); -} +/* ---------------- 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 %s %s\n", + __LINE__, bold_text, op_names[first_op], unbold_text, display_truncated(sc->code), display_truncated(sc->args))); + sc->cur_op = first_op; + goto TOP_NO_POP; -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)); -} + while (true) /* "continue" in this procedure refers to this loop */ + { + pop_stack(sc); + goto TOP_NO_POP; -static s7_int -oprec_i_if_a_opla_laq_a (s7_scheme* sc) { - s7_int i1, i2; - if (!(q_call (sc->rec_test_o).fb (sc->rec_test_o))) - return (q_call (sc->rec_result_o).fi (sc->rec_result_o)); - i1= q_call (sc->rec_a1_o).fi (sc->rec_a1_o); - set_integer (sc->rec_val1, q_call (sc->rec_a2_o).fi (sc->rec_a2_o)); - i2= oprec_i_if_a_opla_laq_a (sc); - set_integer (sc->rec_val1, i1); - return (sc->rec_i_ii_f (oprec_i_if_a_opla_laq_a (sc), i2)); -} + BEGIN: + if (is_pair(cdr(sc->code))) + { + set_current_code(sc, sc->code); + push_stack_no_args(sc, sc->begin_op, cdr(sc->code)); + } + sc->code = car(sc->code); + + EVAL: + sc->cur_op = optimize_op(sc->code); /* sc->code can be anything, optimize_op examines a type field (opt_bits) */ + + TOP_NO_POP: + if (SHOW_EVAL_OPS) safe_print(fprintf(stderr, " %s%s%s (%d), code: %s\n", + bold_text, op_names[sc->cur_op], unbold_text, (int)(sc->cur_op), display_truncated(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 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 = fn_call(sc, sc->code); continue; /* continue refers to the outer while loop -- unfortunate C ambiguity */ -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); - set_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); - set_integer (sc->rec_val1, sc->rec_fi3 (sc->rec_a2_o)); - i3= oprec_i_if_a_opla_laq_a_0 (sc); - set_integer (sc->rec_val1, i2); - i2= sc->rec_i_ii_f (oprec_i_if_a_opla_laq_a_0 (sc), i3); - } - set_integer (sc->rec_val1, i1); - return (sc->rec_i_ii_f (oprec_i_if_a_opla_laq_a_0 (sc), i2)); -} + case OP_SAFE_C_S: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_s(sc)) goto EVAL; continue;} /* checking symbol_ctr(car(sc->code)) == 1 just slows us down */ + case HOP_SAFE_C_S: inline_op_safe_c_s(sc); continue; -static s7_double -oprec_d_if_a_opla_laq_a (s7_scheme* sc) { - s7_double x1, x2; - if (!(q_call (sc->rec_test_o).fb (sc->rec_test_o))) - return (q_call (sc->rec_result_o).fd (sc->rec_result_o)); - x1= q_call (sc->rec_a1_o).fd (sc->rec_a1_o); - set_real (sc->rec_val1, q_call (sc->rec_a2_o).fd (sc->rec_a2_o)); - x2= oprec_d_if_a_opla_laq_a (sc); - set_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 s7_pointer -op_recur_if_a_a_opla_laq (s7_scheme* sc, s7_pointer code) { - const opt_pid_t choice= opinit_if_a_a_opla_laq (sc, code); - const bool a_op = true_is_done (code); - tick_tc (sc, OP_RECUR_IF_A_A_opLA_LAq); - if ((choice == opt_int) || (choice == opt_int_0)) { - if (choice == opt_int_0) - return (make_integer (sc, (a_op) ? oprec_i_if_a_a_opla_laq_0 (sc) - : oprec_i_if_a_opla_laq_a_0 (sc))); - return (make_integer (sc, (a_op) ? oprec_i_if_a_a_opla_laq (sc) - : oprec_i_if_a_opla_laq_a (sc))); - } - if (choice == opt_ptr) - return ((a_op) ? oprec_if_a_a_opla_laq (sc) : oprec_if_a_opla_laq_a (sc)); - return (make_real (sc, (a_op) ? oprec_d_if_a_a_opla_laq (sc) - : oprec_d_if_a_opla_laq_a (sc))); -} + case OP_SAFE_C_SS: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_SS: inline_op_safe_c_ss(sc); continue; -/* -------- if_a_a_opl2a_l2aq -------- */ + 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; -static void -opinit_if_a_a_opl2a_l2aq (s7_scheme* sc, s7_pointer code) { - const s7_pointer caller= rec_call_clause (code); /* cdddr(code) */ - const s7_pointer call1 = cadr (caller); - const s7_pointer call2 = caddr (caller); - tick_tc (sc, OP_RECUR_IF_A_A_opL2A_L2Aq); - sc->rec_fn= fn_proc (caller); - rec_set_test (sc, rec_test_clause (code)); /* cdr(code) */ - rec_set_res (sc, rec_done_clause (code)); /* cddr(code) or cdddr(code) */ - sc->rec_bool= true_is_done (code); - rec_set_f1 (sc, cdr (call1)); - rec_set_f2 (sc, cddr (call1)); - rec_set_f3 (sc, cdr (call2)); - rec_set_f4 (sc, cddr (call2)); - sc->rec_slot1= let_slots (sc->curlet); - sc->rec_slot2= next_slot (sc->rec_slot1); - sc->rec_loc = 0; -} - -static s7_pointer -oprec_if_a_a_opl2a_l2aq (s7_scheme* sc) { - if ((sc->rec_testf (sc, sc->rec_testp) != sc->F) == sc->rec_bool) - 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_slot2, sc->rec_f4f (sc, sc->rec_f4p)); - slot_set_value (sc->rec_slot1, recur_pop (sc)); - sc->value= oprec_if_a_a_opl2a_l2aq (sc); - 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_if_a_a_opl2a_l2aq (sc)); - set_car (sc->t2_2, recur_pop (sc)); - return (sc->rec_fn (sc, sc->t2_1)); -} - -static s7_pointer -op_recur_if_a_a_opl2a_l2aq (s7_scheme* sc, s7_pointer code) { - opinit_if_a_a_opl2a_l2aq (sc, code); - return (oprec_if_a_a_opl2a_l2aq (sc)); -} + 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; -/* -------- if_a_a_opl3a_l3aq -------- */ + 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; -static void -opinit_if_a_a_opl3a_l3aq (s7_scheme* sc, s7_pointer code) { - const s7_pointer caller= rec_call_clause (code); /* rec call */ - const s7_pointer call1 = cadr (caller); - const s7_pointer call2 = caddr (caller); - tick_tc (sc, OP_RECUR_IF_A_A_opL3A_L3Aq); - sc->rec_fn= fn_proc (caller); - rec_set_test (sc, rec_test_clause (code)); /* cdr(code) */ - rec_set_res (sc, rec_done_clause (code)); /* cddr(code) or cdddr(code) */ - sc->rec_bool= true_is_done (code); - rec_set_f1 (sc, cdr (call1)); - rec_set_f2 (sc, cddr (call1)); - rec_set_f3 (sc, cdddr (call1)); - rec_set_f4 (sc, cdr (call2)); - rec_set_f5 (sc, cddr (call2)); - rec_set_f6 (sc, cdddr (call2)); - 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_loc = 0; -} - -static s7_pointer -oprec_if_a_a_opl3a_l3aq (s7_scheme* sc) { - if ((sc->rec_testf (sc, sc->rec_testp) != sc->F) == sc->rec_bool) - 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)); - slot_set_value (sc->rec_slot3, sc->rec_f6f (sc, sc->rec_f6p)); - slot_set_value (sc->rec_slot2, recur_pop (sc)); - slot_set_value (sc->rec_slot1, recur_pop (sc)); - sc->value= oprec_if_a_a_opl3a_l3aq (sc); - slot_set_value (sc->rec_slot3, recur_pop (sc)); - 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_if_a_a_opl3a_l3aq (sc)); - set_car (sc->t2_2, recur_pop (sc)); - return (sc->rec_fn (sc, sc->t2_1)); -} - -static s7_pointer -op_recur_if_a_a_opl3a_l3aq (s7_scheme* sc, s7_pointer code) { - opinit_if_a_a_opl3a_l3aq (sc, code); - return (oprec_if_a_a_opl3a_l3aq (sc)); -} + 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; -/* -------- if_a_a_if_a_a_opla_laq -------- */ -static void -opinit_if_a_a_if_a_a_opla_laq (s7_scheme* sc, s7_pointer code) { - const s7_pointer caller= rec_call_clause (code); - tick_tc (sc, OP_RECUR_IF_A_A_IF_A_A_opLA_LAq); - rec_set_f1 (sc, rec_done_clause (code)); - rec_set_f2 (sc, cdr (rec_done_clause (code))); - rec_set_test (sc, rec_test_clause (code)); - rec_set_res (sc, cdr (rec_test_clause (code))); - rec_set_f3 (sc, cdadr (caller)); - rec_set_f4 (sc, rec_call_clause (caller)); - sc->rec_slot1= let_slots (sc->curlet); - sc->rec_fn = fn_proc (caller); - sc->rec_loc = 0; -} - -static inline s7_pointer -oprec_if_a_a_if_a_a_opla_laq (s7_scheme* sc) /* inline = 27 in trec */ -{ - 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_if_a_a_if_a_a_opla_laq (sc))); - set_car (sc->t2_1, oprec_if_a_a_if_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_if_a_a_if_a_a_opla_laq (s7_scheme* sc, s7_pointer code) { - opinit_if_a_a_if_a_a_opla_laq (sc, code); - return (oprec_if_a_a_if_a_a_opla_laq (sc)); -} + case OP_SAFE_C_FF: if (!c_function_is_ok(sc, sc->code)) {op_unknown_np(sc); goto EVAL;} + case HOP_SAFE_C_FF: sc->value = fx_c_ff(sc, sc->code); continue; -/* -------- if_a_a_if_a_a_opl2a_l2aq -------- */ -static void -opinit_if_a_a_if_a_a_opl2a_l2aq (s7_scheme* sc, s7_pointer code) { - const s7_pointer caller= rec_call_clause (code); - s7_pointer p; - tick_tc (sc, OP_RECUR_IF_A_A_IF_A_A_opL2A_L2Aq); - rec_set_f1 (sc, rec_done_clause (code)); - rec_set_f2 (sc, cdr (rec_done_clause (code))); - rec_set_test (sc, rec_test_clause (code)); - rec_set_res (sc, cdr (rec_test_clause (code))); - p= cdadr (caller); - rec_set_f3 (sc, p); - rec_set_f4 (sc, cdr (p)); - p= rec_call_clause (caller); - rec_set_f5 (sc, p); - rec_set_f6 (sc, cdr (p)); - sc->rec_slot1= let_slots (sc->curlet); - sc->rec_slot2= next_slot (sc->rec_slot1); - sc->rec_fn = fn_proc (caller); - sc->rec_loc = 0; -} - -static s7_pointer -oprec_if_a_a_if_a_a_opl2a_l2aq (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_if_a_a_if_a_a_opl2a_l2aq (sc); /* second l2a 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_if_a_a_if_a_a_opl2a_l2aq (sc)); /* first l2a arg */ - set_car (sc->t2_2, recur_pop (sc)); - return (sc->rec_fn (sc, sc->t2_1)); -} - -static s7_pointer -op_recur_if_a_a_if_a_a_opl2a_l2aq (s7_scheme* sc, s7_pointer code) { - opinit_if_a_a_if_a_a_opl2a_l2aq (sc, code); - return (oprec_if_a_a_if_a_a_opl2a_l2aq (sc)); -} + 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; -/* -------- if_a_a_if_a_a_opl3a_l3aq -------- */ -static void -opinit_if_a_a_if_a_a_opl3a_l3aq (s7_scheme* sc, s7_pointer code) { - const s7_pointer caller= rec_call_clause (code); - s7_pointer p; - rec_set_f1 (sc, rec_done_clause (code)); - rec_set_f2 (sc, cdr (rec_done_clause (code))); - rec_set_test (sc, rec_test_clause (code)); - rec_set_res (sc, cdr (rec_test_clause (code))); - tick_tc (sc, OP_RECUR_IF_A_A_IF_A_A_opL3A_L3Aq); - - p= cdadr (caller); - rec_set_f3 (sc, p); - rec_set_f4 (sc, cdr (p)); - rec_set_f5 (sc, cddr (p)); - p= rec_call_clause (caller); - rec_set_f6 (sc, p); - rec_set_f7 (sc, cdr (p)); - rec_set_f8 (sc, cddr (p)); - 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); - sc->rec_loc = 0; -} - -static s7_pointer -oprec_if_a_a_if_a_a_opl3a_l3aq (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)); - recur_push (sc, sc->rec_f6f (sc, sc->rec_f6p)); - recur_push (sc, sc->rec_f7f (sc, sc->rec_f7p)); - slot_set_value (sc->rec_slot3, sc->rec_f8f (sc, sc->rec_f8p)); - slot_set_value (sc->rec_slot2, recur_pop (sc)); - slot_set_value (sc->rec_slot1, recur_pop (sc)); - sc->value= oprec_if_a_a_if_a_a_opl3a_l3aq (sc); /* second l3a */ - slot_set_value (sc->rec_slot3, recur_pop (sc)); - 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_if_a_a_if_a_a_opl3a_l3aq (sc)); /* first l3a */ - set_car (sc->t2_2, recur_pop (sc)); - return (sc->rec_fn (sc, sc->t2_1)); -} - -static s7_pointer -op_recur_if_a_a_if_a_a_opl3a_l3aq (s7_scheme* sc, s7_pointer code) { - opinit_if_a_a_if_a_a_opl3a_l3aq (sc, code); - return (oprec_if_a_a_if_a_a_opl3a_l3aq (sc)); -} + case OP_ANY_C_NP: if (!c_function_is_ok(sc, sc->code)) {op_unknown_np(sc); goto EVAL;} + case HOP_ANY_C_NP: if (op_any_c_np(sc)) goto EVAL; continue; + case OP_ANY_C_NP_1: if (inline_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: if (op_any_c_np_mv(sc)) goto EVAL; goto APPLY; -/* -------- if_a_a_opa_laq and if_a_opa_laq_a -------- */ -static opt_pid_t -opinit_if_a_a_opa_laq (s7_scheme* sc, s7_pointer code) { - const s7_pointer caller= rec_call_clause (code); - const bool la_op = a_is_cadr (caller); - const s7_pointer c_op = car (caller); - if ((is_symbol (c_op)) && - ((is_slot (global_slot (c_op))) && - ((is_global (c_op)) || (s7_t_slot (sc, c_op) == global_slot (c_op))))) { - const 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, rec_test_clause (code))) /* (zero? x) */ - { - const 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, rec_done_clause (code)))) /* x as return */ - { - sc->rec_a1_o= sc->opts[sc->pc]; - if (int_optimize (sc, (la_op) ? cdr (caller) - : cddr (caller))) /* x in (+ x ...) */ - { - sc->rec_a2_o= sc->opts[sc->pc]; - if (int_optimize (sc, - cdr (rec_call_clause ( - caller)))) /* arg of recur call: (- x 1) */ - { - sc->rec_val1= - make_mutable_integer (sc, integer (slot_value (slot))); - slot_set_value (slot, sc->rec_val1); - return (opt_int); - } - } - } - } - } - } - } - /* not int: a_op: (lis (cons (car lis) (copy-list-1 (cdr lis)))), - * la_op: ((car lis) (copy-list-1 (cdr lis))), - * opt3: ((cdr lis)) - * (if (not (pair? lis)) lis (cons (car lis) (copy-list (cdr lis)))) - * - * not int: a_op: (1 (lcm n (flcm (- n 1)))), - * la_op: (n (flcm (- n 1))), - * opt3: ((- n 1)) - * (if (<= n 1) 1 (lcm n (flcm (- n 1)))) 1 1 - */ - rec_set_test (sc, rec_test_clause (code)); - rec_set_res (sc, rec_done_clause (code)); - rec_set_f1 (sc, (la_op) ? cdr (caller) : cddr (caller)); /* a arg */ - rec_set_f2 (sc, cdr (rec_call_clause (caller))); /* la arg */ - sc->rec_slot1= let_slots (sc->curlet); - sc->rec_fn = fn_proc (caller); - sc->rec_loc = 0; - return (opt_ptr); -} - -static s7_int -oprec_i_if_a_a_opa_laq (s7_scheme* sc) { - s7_int i1; - if (q_call (sc->rec_test_o).fb (sc->rec_test_o)) - return (q_call (sc->rec_result_o).fi (sc->rec_result_o)); - i1= q_call (sc->rec_a1_o).fi (sc->rec_a1_o); - set_integer (sc->rec_val1, q_call (sc->rec_a2_o).fi (sc->rec_a2_o)); - return (sc->rec_i_ii_f (i1, oprec_i_if_a_a_opa_laq (sc))); -} + 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; -static s7_int -oprec_i_if_a_opa_laq_a (s7_scheme* sc) { - s7_int i1; - if (!q_call (sc->rec_test_o).fb (sc->rec_test_o)) - return (q_call (sc->rec_result_o).fi (sc->rec_result_o)); - i1= q_call (sc->rec_a1_o).fi (sc->rec_a1_o); - set_integer (sc->rec_val1, q_call (sc->rec_a2_o).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 s7_pointer -op_recur_if_a_a_opa_laq (s7_scheme* sc, s7_pointer code) { - const bool a_op = true_is_done (code); - const bool la_op = a_is_cadr (rec_call_clause (code)); - opt_pid_t choice= opinit_if_a_a_opa_laq (sc, code); - tick_tc (sc, OP_RECUR_IF_A_A_opA_LAq); - if (choice == opt_int) - return (make_integer (sc, (a_op) ? oprec_i_if_a_a_opa_laq (sc) - : oprec_i_if_a_opa_laq_a (sc))); - if (a_op) - return ((la_op) ? oprec_if_a_a_opa_laq (sc) : oprec_if_a_a_opla_aq (sc)); - return ((la_op) ? oprec_if_a_opa_laq_a (sc) : oprec_if_a_opla_aq_a (sc)); -} + 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; -/* -------- if_a_a_opa_l2aq -------- */ -static void -opinit_if_a_a_opa_l2aq (s7_scheme* sc, s7_pointer code) { - const s7_pointer caller= rec_call_clause (code); - const bool la_op = a_is_cadr (caller); - tick_tc (sc, OP_RECUR_IF_A_A_opA_L2Aq); - rec_set_test (sc, rec_test_clause (code)); - rec_set_res (sc, rec_done_clause (code)); - rec_set_f1 (sc, (la_op) ? cdr (caller) : cddr (caller)); - rec_set_f2 (sc, cdr (rec_call_clause (caller))); - rec_set_f3 (sc, cddr (rec_call_clause (caller))); - sc->rec_slot1= let_slots (sc->curlet); - sc->rec_slot2= next_slot (sc->rec_slot1); - sc->rec_fn = fn_proc (caller); - sc->rec_bool = true_is_done (code); - sc->rec_loc = 0; - if (la_op) { - sc->rec_p1= sc->t2_1; - sc->rec_p2= sc->t2_2; - } - else { - sc->rec_p1= sc->t2_2; - sc->rec_p2= sc->t2_1; - } -} + case OP_SAFE_C_opAq: if (!c_function_is_ok_cadr(sc, sc->code)) break; + case HOP_SAFE_C_opAq: sc->value = fx_c_opaq(sc, sc->code); continue; -static s7_pointer -oprec_if_a_a_opa_l2aq (s7_scheme* sc) { - if ((sc->rec_testf (sc, sc->rec_testp) != sc->F) == sc->rec_bool) - 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) == sc->rec_bool) - set_car (sc->rec_p2, sc->rec_resf (sc, sc->rec_resp)); - else { - recur_push_unchecked (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->rec_p2, oprec_if_a_a_opa_l2aq (sc)); - set_car (sc->rec_p1, recur_pop (sc)); - set_car (sc->rec_p2, sc->rec_fn (sc, sc->t2_1)); - } - set_car (sc->rec_p1, recur_pop (sc)); - return (sc->rec_fn (sc, sc->t2_1)); -} + case OP_SAFE_C_opAAq: if (!c_function_is_ok_cadr(sc, sc->code)) break; + case HOP_SAFE_C_opAAq: sc->value = fx_c_opaaq(sc, sc->code); continue; -static s7_pointer -op_recur_if_a_a_opa_l2aq (s7_scheme* sc, s7_pointer code) { - opinit_if_a_a_opa_l2aq (sc, code); - return (oprec_if_a_a_opa_l2aq (sc)); -} + case OP_SAFE_C_opAAAq: if (!c_function_is_ok_cadr(sc, sc->code)) break; + case HOP_SAFE_C_opAAAq: sc->value = fx_c_opaaaq(sc, sc->code); continue; -/* -------- if_a_a_opa_l3aq -------- */ -static void -opinit_if_a_a_opa_l3aq (s7_scheme* sc, s7_pointer code) { - const s7_pointer caller= rec_call_clause (code); - const bool la_op = a_is_cadr (caller); - tick_tc (sc, OP_RECUR_IF_A_A_opA_L3Aq); - rec_set_test (sc, rec_test_clause (code)); - rec_set_res (sc, rec_done_clause (code)); - rec_set_f1 (sc, (la_op) ? cdr (caller) : cddr (caller)); - rec_set_f2 (sc, cdr (rec_call_clause (caller))); - rec_set_f3 (sc, cddr (rec_call_clause (caller))); - rec_set_f4 (sc, cdddr (rec_call_clause (caller))); - 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); - sc->rec_bool = true_is_done (code); - sc->rec_loc = 0; - if (la_op) { - sc->rec_p1= sc->t2_1; - sc->rec_p2= sc->t2_2; - } - else { - sc->rec_p1= sc->t2_2; - sc->rec_p2= sc->t2_1; - } -} + case OP_SAFE_C_S_opAq: if (!c_function_is_ok_caddr(sc, sc->code)) break; + case HOP_SAFE_C_S_opAq: sc->value = fx_c_s_opaq(sc, sc->code); continue; -static s7_pointer -oprec_if_a_a_opa_l3aq (s7_scheme* sc) { - if ((sc->rec_testf (sc, sc->rec_testp) != sc->F) == sc->rec_bool) - 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) == sc->rec_bool) - set_car (sc->rec_p2, sc->rec_resf (sc, sc->rec_resp)); - else { - recur_push_unchecked (sc, sc->rec_f1f (sc, sc->rec_f1p)); - recur_push_unchecked (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->rec_p2, oprec_if_a_a_opa_l3aq (sc)); - set_car (sc->rec_p1, recur_pop (sc)); - set_car (sc->rec_p2, sc->rec_fn (sc, sc->t2_1)); - } - set_car (sc->rec_p1, recur_pop (sc)); - return (sc->rec_fn (sc, sc->t2_1)); -} + case OP_SAFE_C_opAq_S: if (!c_function_is_ok_cadr(sc, sc->code)) break; + case HOP_SAFE_C_opAq_S: sc->value = fx_c_opaq_s(sc, sc->code); continue; -static s7_pointer -op_recur_if_a_a_opa_l3aq (s7_scheme* sc, s7_pointer code) { - opinit_if_a_a_opa_l3aq (sc, code); - return (oprec_if_a_a_opa_l3aq (sc)); -} + case OP_SAFE_C_S_opAAq: if (!c_function_is_ok_caddr(sc, sc->code)) break; + case HOP_SAFE_C_S_opAAq: sc->value = fx_c_s_opaaq(sc, sc->code); continue; -/* -------- if_a_a_opa_la_laq -------- */ -static void -opinit_if_a_a_opa_la_laq (s7_scheme* sc, s7_pointer code) { - const s7_pointer caller= rec_call_clause (code); - tick_tc (sc, OP_RECUR_IF_A_A_opA_LA_LAq); - rec_set_test (sc, rec_test_clause (code)); - rec_set_res (sc, rec_done_clause (code)); - rec_set_f1 (sc, cdr (caller)); - rec_set_f2 (sc, cdaddr (caller)); - rec_set_f3 (sc, cdr (rec_call_clause (caller))); - sc->rec_slot1= let_slots (sc->curlet); - sc->rec_fn = fn_proc (caller); - sc->rec_loc = 0; - sc->rec_bool = true_is_done (code); -} - -static s7_pointer -oprec_if_a_a_opa_la_laq (s7_scheme* sc) { - if ((sc->rec_testf (sc, sc->rec_testp) != sc->F) == sc->rec_bool) - 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 -op_recur_if_a_a_opa_la_laq (s7_scheme* sc, s7_pointer code) { - opinit_if_a_a_opa_la_laq (sc, code); - return (oprec_if_a_a_opa_la_laq (sc)); -} + case OP_SAFE_C_AA: if (!c_function_is_ok(sc, sc->code)) {op_unknown_aa(sc); goto EVAL;} /* op_unknown_aa always returns true */ + case HOP_SAFE_C_AA: sc->value = fx_c_aa(sc, sc->code); continue; -/* -------- if_a_a_opla_la_laq -------- */ -static void -opinit_if_a_a_opla_la_laq (s7_scheme* sc, s7_pointer code) { - const s7_pointer caller= rec_call_clause (code); - tick_tc (sc, OP_RECUR_IF_A_A_opLA_LA_LAq); - rec_set_test (sc, rec_test_clause (code)); - rec_set_res (sc, rec_done_clause (code)); - rec_set_f1 (sc, cdadr (caller)); - rec_set_f2 (sc, cdaddr (caller)); - rec_set_f3 (sc, cdr (rec_call_clause (caller))); - sc->rec_slot1= let_slots (sc->curlet); - sc->rec_fn = fn_proc (caller); - sc->rec_loc = 0; - sc->rec_bool = true_is_done (code); -} - -static s7_pointer -oprec_if_a_a_opla_la_laq (s7_scheme* sc) { - if ((sc->rec_testf (sc, sc->rec_testp) != sc->F) == sc->rec_bool) - 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, s7_pointer code) { - opinit_if_a_a_opla_la_laq (sc, code); - return (oprec_if_a_a_opla_la_laq (sc)); -} + case OP_SAFE_C_SA: if (!c_function_is_ok(sc, sc->code)) {op_unknown_aa(sc); goto EVAL;} + case HOP_SAFE_C_SA: sc->value = fx_c_sa(sc, sc->code); continue; -/* -------- if_a_a_and_a_l2a_l2a -------- */ -static void -opinit_if_a_a_and_a_l2a_l2a (s7_scheme* sc, s7_pointer code) { - const s7_pointer caller= rec_call_clause (code); - const s7_pointer la1 = caddr (caller); - const s7_pointer la2 = cadddr (caller); - tick_tc (sc, OP_RECUR_IF_A_A_AND_A_L2A_L2A); - rec_set_test (sc, cdr (code)); - rec_set_res (sc, cddr (code)); - 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); - sc->rec_loc = 0; -} - -static s7_pointer -oprec_if_a_a_and_a_l2a_l2a (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_l2a_l2a (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_unchecked (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_l2a_l2a (sc)); -} + case OP_SAFE_C_AS: if (!c_function_is_ok(sc, sc->code)) {op_unknown_aa(sc); goto EVAL;} + case HOP_SAFE_C_AS: sc->value = fx_c_as(sc, sc->code); continue; -static s7_pointer -op_recur_if_a_a_and_a_l2a_l2a (s7_scheme* sc, s7_pointer code) { - opinit_if_a_a_and_a_l2a_l2a (sc, code); - return (oprec_if_a_a_and_a_l2a_l2a (sc)); -} + case OP_SAFE_C_CA: if (!c_function_is_ok(sc, sc->code)) {op_unknown_aa(sc); goto EVAL;} + case HOP_SAFE_C_CA: sc->value = fx_c_ca(sc, sc->code); continue; -/* -------- cond_a_a_a_a_opa_l2aq -------- */ -static void -opinit_cond_a_a_a_a_opa_l2aq (s7_scheme* sc, s7_pointer code) { - const s7_pointer caller= rec_call_clause (code); - s7_pointer p; - tick_tc (sc, OP_RECUR_COND_A_A_A_A_opA_L2Aq); - rec_set_test (sc, cadr (code)); - rec_set_res (sc, cdadr (code)); - p= caddr (code); - rec_set_f1 (sc, p); - rec_set_f2 (sc, cdr (p)); - rec_set_f3 (sc, cdr (caller)); - rec_set_f4 (sc, rec_call_clause (caller)); - rec_set_f5 (sc, cdr (rec_call_clause (caller))); - sc->rec_slot1= let_slots (sc->curlet); - sc->rec_slot2= next_slot (sc->rec_slot1); - sc->rec_fn = fn_proc (caller); - sc->rec_loc = 0; -} - -static s7_pointer -oprec_cond_a_a_a_a_opa_l2aq (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_l2aq (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_l2aq (s7_scheme* sc, s7_pointer code) { - opinit_cond_a_a_a_a_opa_l2aq (sc, code); - return (oprec_cond_a_a_a_a_opa_l2aq (sc)); -} + case OP_SAFE_C_AC: if (!c_function_is_ok(sc, sc->code)) {op_unknown_aa(sc); goto EVAL;} + case HOP_SAFE_C_AC: sc->value = fx_c_ac(sc, sc->code); continue; -/* -------- cond_a_a_a_l2a_opa_l2aq -------- */ -static void -opinit_cond_a_a_a_l2a_opa_l2aq (s7_scheme* sc, s7_pointer code) { - const s7_pointer caller= rec_call_clause (code); /* opA_L2A */ - s7_pointer p; - tick_tc (sc, OP_RECUR_IF_A_A_IF_A_L2A_opA_L2Aq); - rec_set_test (sc, rec_test_clause (code)); - rec_set_res (sc, rec_done_clause (code)); - p= rec_done_clause ( - cdr (code)); /* (cond) ? caddr(code) : cdr(cadddr(code)); */ - rec_set_f1 (sc, p); - p= cdadr (p); - rec_set_f2 (sc, p); - rec_set_f3 (sc, cdr (p)); - rec_set_f4 (sc, cdr (caller)); - p= cdr (rec_call_clause (caller)); /* (L)AA */ - rec_set_f5 (sc, p); - rec_set_f6 (sc, cdr (p)); - sc->rec_fn = fn_proc (caller); - sc->rec_slot1= let_slots (sc->curlet); - sc->rec_slot2= next_slot (sc->rec_slot1); - sc->rec_loc = 0; -} - -static s7_pointer -oprec_cond_a_a_a_l2a_opa_l2aq (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_l2a_opa_l2aq (sc)); /* first l2a 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_unchecked (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_l2a_opa_l2aq (sc)); /* first l2a above */ - } - else { - recur_push_unchecked (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_l2a_opa_l2aq (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)); -} + 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; -static s7_pointer -op_recur_if_a_a_if_a_l2a_opa_l2aq ( - s7_scheme* sc, s7_pointer code) /* if version, same logic as cond above */ -{ - opinit_cond_a_a_a_l2a_opa_l2aq (sc, code); - return (oprec_cond_a_a_a_l2a_opa_l2aq (sc)); -} + 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; -/* -------- cond_a_a_a_l2a_lopa_l2aq -------- */ + 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_HASH_TABLE_INCREMENT: sc->value = fx_hash_table_increment(sc, sc->code); continue; /* a placeholder, almost never called */ -static opt_pid_t -opinit_cond_a_a_a_l2a_lopa_l2aq (s7_scheme* sc, s7_pointer code) { - const s7_pointer caller= rec_call_clause (code); - tick_tc (sc, OP_RECUR_COND_A_A_A_L2A_LopA_L2Aq); - sc->rec_slot1= let_slots (sc->curlet); - sc->rec_slot2= next_slot (sc->rec_slot1); - - 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 (code))) { - sc->rec_result_o= sc->opts[sc->pc]; - if (int_optimize (sc, cdadr (code))) { - const s7_pointer l2a1= caddr (code); - sc->rec_a1_o = sc->opts[sc->pc]; - if (bool_optimize (sc, l2a1)) { - sc->rec_a2_o= sc->opts[sc->pc]; - if (int_optimize (sc, cdadr (l2a1))) { - sc->rec_a3_o= sc->opts[sc->pc]; - if (int_optimize (sc, cddadr (l2a1))) { - const s7_pointer l2a2= cadr (cadddr (code)), l2a3= caddr (l2a2); - sc->rec_a4_o= sc->opts[sc->pc]; - if (int_optimize (sc, cdr (l2a2))) { - sc->rec_a5_o= sc->opts[sc->pc]; - if (int_optimize (sc, cdr (l2a3))) { - sc->rec_a6_o= sc->opts[sc->pc]; - if (int_optimize (sc, cddr (l2a3))) { - 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= q_call (sc->rec_test_o).fb; - sc->rec_fb2= q_call (sc->rec_a1_o).fb; - sc->rec_fi1= q_call (sc->rec_result_o).fi; - sc->rec_fi2= q_call (sc->rec_a2_o).fi; - sc->rec_fi3= q_call (sc->rec_a3_o).fi; - sc->rec_fi4= q_call (sc->rec_a4_o).fi; - sc->rec_fi5= q_call (sc->rec_a5_o).fi; - sc->rec_fi6= q_call (sc->rec_a6_o).fi; - return (opt_int_0); - } - } - } - } - } - } - } - } - } - rec_set_test (sc, cadr (code)); - rec_set_res (sc, cdadr (code)); - { - s7_pointer p= caddr (code); - rec_set_f1 (sc, p); - p= cdadr (p); /* not sc->rec_f1p = car(caddr(code)) */ - rec_set_f2 (sc, p); - rec_set_f3 (sc, cdr (p)); - rec_set_f4 (sc, cdr (caller)); - p= rec_call_clause (caller); - rec_set_f5 (sc, p); - rec_set_f6 (sc, cdr (p)); - } - sc->rec_loc= 0; - return (opt_ptr); -} + 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; -static s7_int -oprec_i_cond_a_a_a_l2a_lopa_l2aq (s7_scheme* sc) { - s7_int i1, i2; - if (q_call (sc->rec_test_o).fb (sc->rec_test_o)) - return (q_call (sc->rec_result_o).fi (sc->rec_result_o)); - if (q_call (sc->rec_a1_o).fb (sc->rec_a1_o)) { - i1= q_call (sc->rec_a2_o).fi (sc->rec_a2_o); - set_integer (sc->rec_val2, q_call (sc->rec_a3_o).fi (sc->rec_a3_o)); - set_integer (sc->rec_val1, i1); - return (oprec_i_cond_a_a_a_l2a_lopa_l2aq (sc)); - } - i1= q_call (sc->rec_a4_o).fi (sc->rec_a4_o); - i2= q_call (sc->rec_a5_o).fi (sc->rec_a5_o); - set_integer (sc->rec_val2, q_call (sc->rec_a6_o).fi (sc->rec_a6_o)); - set_integer (sc->rec_val1, i2); - set_integer (sc->rec_val2, oprec_i_cond_a_a_a_l2a_lopa_l2aq (sc)); - set_integer (sc->rec_val1, i1); - return (oprec_i_cond_a_a_a_l2a_lopa_l2aq (sc)); -} + 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; -static s7_int -oprec_i_cond_a_a_a_l2a_lopa_l2aq_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); - set_integer (sc->rec_val2, sc->rec_fi3 (sc->rec_a3_o)); - set_integer (sc->rec_val1, i1); - return (oprec_i_cond_a_a_a_l2a_lopa_l2aq_0 (sc)); - } - i1= sc->rec_fi4 (sc->rec_a4_o); - i2= sc->rec_fi5 (sc->rec_a5_o); - set_integer (sc->rec_val2, sc->rec_fi6 (sc->rec_a6_o)); - set_integer (sc->rec_val1, i2); - set_integer (sc->rec_val2, oprec_i_cond_a_a_a_l2a_lopa_l2aq_0 (sc)); - set_integer (sc->rec_val1, i1); - return (oprec_i_cond_a_a_a_l2a_lopa_l2aq_0 (sc)); -} - -static s7_pointer -oprec_cond_a_a_a_l2a_lopa_l2aq (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_l2a_lopa_l2aq (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_l2a_lopa_l2aq (sc)); - slot_set_value (sc->rec_slot1, recur_pop (sc)); - return (oprec_cond_a_a_a_l2a_lopa_l2aq (sc)); -} - -static s7_pointer -op_recur_cond_a_a_a_l2a_lopa_l2aq (s7_scheme* sc, s7_pointer code) { - opt_pid_t choice= opinit_cond_a_a_a_l2a_lopa_l2aq (sc, code); - tick_tc (sc, OP_RECUR_COND_A_A_A_L2A_LopA_L2Aq); - if (choice != opt_ptr) - return (make_integer (sc, (choice == opt_int) - ? oprec_i_cond_a_a_a_l2a_lopa_l2aq (sc) - : oprec_i_cond_a_a_a_l2a_lopa_l2aq_0 (sc))); - return (oprec_cond_a_a_a_l2a_lopa_l2aq (sc)); -} + 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; -/* -------- and_a_or_a_l2a_l2a -------- */ -static void -opinit_and_a_or_a_l2a_l2a (s7_scheme* sc, s7_pointer code) { - const s7_pointer orp= cdr (rec_call_clause (code)); - tick_tc (sc, OP_RECUR_AND_A_OR_A_L2A_L2A); - 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); - sc->rec_loc = 0; -} - -static s7_pointer -oprec_and_a_or_a_l2a_l2a (s7_scheme* sc) { - s7_pointer result; - if (sc->rec_testf (sc, sc->rec_testp) == sc->F) return (sc->F); - result= sc->rec_resf (sc, sc->rec_resp); - if (result != sc->F) return (result); - 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)); - result= oprec_and_a_or_a_l2a_l2a (sc); - if (result != sc->F) { - sc->rec_loc-= 2; - return (result); - } - slot_set_value (sc->rec_slot2, recur_pop (sc)); - slot_set_value (sc->rec_slot1, recur_pop (sc)); - recur_push_unchecked (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_l2a_l2a (sc)); -} + 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; -static s7_pointer -op_recur_and_a_or_a_l2a_l2a (s7_scheme* sc, s7_pointer code) { - opinit_and_a_or_a_l2a_l2a (sc, code); - return (oprec_and_a_or_a_l2a_l2a (sc)); -} + 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; -/* -------------------------------- */ -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) { - sc->value= fn_proc (sc->code) (sc, with_list_t1 (sc, sc->value)); -} - -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_s (s7_scheme* sc) { - sc->code= lookup (sc, car (sc->code)); - if (!is_applicable (sc->code)) apply_error_nr (sc, sc->code, sc->nil); - sc->args= sc->nil; /* op_s -> apply, so we'll apply sc->code to sc->args */ -} - -static bool -op_s_g (s7_scheme* sc) { - const s7_pointer code= sc->code; - sc->code = lookup_checked (sc, car (code)); - if ((is_c_function (sc->code)) && (c_function_min_args (sc->code) == 1) && - (!needs_copied_args (sc->code))) { - sc->value= c_function_call (sc->code) ( - sc, with_list_t1 (sc, (is_symbol (cadr (code))) - ? lookup_checked (sc, cadr (code)) - : cadr (code))); - return (true); /* continue */ - } - if (!is_applicable (sc->code)) apply_error_nr (sc, sc->code, cdr (code)); - if (dont_eval_args (sc->code)) sc->args= cdr (code); - else { - const s7_pointer val= (is_symbol (cadr (code))) - ? lookup_checked (sc, cadr (code)) - : cadr (code); - sc->args = (needs_copied_args (sc->code)) ? list_1 (sc, val) - : set_plist_1 (sc, val); - } - return (false); -} + 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; -static bool -op_x_a (s7_scheme* sc, s7_pointer func) { - if ((((type (func) == T_C_FUNCTION) && (c_function_is_aritable (func, 1))) || - ((type (func) == T_C_RST_NO_REQ_FUNCTION) && (!has_even_args (func)))) && - (!needs_copied_args (func))) { - sc->value= c_function_call (func) ( - sc, with_list_t1 (sc, fx_call (sc, cdr (sc->code)))); - return (true); - } - if (is_any_vector (func)) { - sc->args= set_plist_1 (sc, fx_call (sc, cdr (sc->code))); - sc->code= func; - apply_vector (sc); - return (true); - } - if (!is_applicable (func)) apply_error_nr (sc, func, cdr (sc->code)); - if (dont_eval_args (func)) - sc->args= cdr (sc->code); /* list_1(sc, cadr(sc->code)); */ - else if (!needs_copied_args (func)) - sc->args= set_plist_1 (sc, fx_call (sc, cdr (sc->code))); - else { - sc->args= fx_call (sc, cdr (sc->code)); - sc->args= list_1 (sc, sc->args); - } - sc->code= func; - return (false); /* goto APPLY */ -} + 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; -static bool -op_x_sc (s7_scheme* sc, s7_pointer func) { - const s7_pointer code= sc->code; - if (((type (func) == T_C_FUNCTION) && (c_function_is_aritable (func, 2))) || - (type (func) == T_C_RST_NO_REQ_FUNCTION)) /* ((L 'abs) x 0.0001) where - 'abs is '* in timp.scm */ - { - if (!needs_copied_args (func)) { - sc->value= c_function_call (func) ( - sc, set_plist_2 (sc, lookup_checked (sc, cadr (code)), caddr (code))); - return (true); - } - sc->args = list_2 (sc, lookup_checked (sc, cadr (code)), caddr (code)); - sc->value= c_function_call (func) (sc, sc->args); - return (true); - } - if (!is_applicable (func)) apply_error_nr (sc, func, cdr (code)); - if (dont_eval_args (func)) sc->args= list_2 (sc, cadr (code), caddr (code)); - else if (!needs_copied_args (func)) - sc->args= set_plist_2 (sc, lookup_checked (sc, cadr (code)), caddr (code)); - else sc->args= list_2 (sc, lookup_checked (sc, cadr (code)), caddr (code)); - sc->code= func; - return (false); /* goto APPLY */ -} - -static bool -op_x_aa (s7_scheme* sc, s7_pointer func) { - const s7_pointer code= sc->code; - if (((type (func) == T_C_FUNCTION) && (c_function_is_aritable (func, 2))) || - (type (func) == T_C_RST_NO_REQ_FUNCTION)) { - if (!needs_copied_args (func)) { - set_car ( - sc->elist_7, - fx_call ( - sc, - cdr (code))); /* heh heh... (I'm going to regret this someday) */ - sc->value= fx_call (sc, cddr (code)); - sc->value= c_function_call (func) ( - sc, with_list_t2 (sc, car (sc->elist_7), sc->value)); - set_car (sc->elist_7, sc->F); - return (true); - } - sc->args = fx_call (sc, cddr (code)); - sc->args = list_2 (sc, sc->value= fx_call (sc, cdr (code)), sc->args); - sc->value= c_function_call (func) (sc, sc->args); - return (true); - } - if (!is_applicable (func)) apply_error_nr (sc, func, cdr (code)); - if (dont_eval_args (func)) sc->args= list_2 (sc, cadr (code), caddr (code)); - else { - sc->args= fx_call (sc, cddr (code)); - if (!needs_copied_args (func)) - sc->args= set_plist_2 (sc, fx_call (sc, cdr (code)), sc->args); - else sc->args= list_2 (sc, sc->value= fx_call (sc, cdr (code)), sc->args); - } - sc->code= func; - return (false); /* goto APPLY */ -} + 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; -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)); - sc->args= (needs_copied_args (sc->value)) ? list_1 (sc, sc->args) - : set_plist_1 (sc, sc->args); - } - sc->code= sc->value; /* goto APPLY */ -} - -static void -op_safe_c_star_na (s7_scheme* sc) { - sc->args= safe_list_if_possible (sc, opt3_arglen (cdr (sc->code))); - for (s7_pointer 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); - if (!in_heap (sc->args)) clear_safe_list_in_use (sc, 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) { - sc->args= fx_call (sc, cdr (sc->code)); - if (is_symbol_and_keyword (sc->args)) /* (blocks3 (car (list :asdf))) */ - error_nr (sc, sc->syntax_error_symbol, - set_elist_4 ( - sc, wrap_string (sc, "~A: keyword ~S, but no value: ~S", 32), - car (sc->code), sc->args, sc->code)); - /* scheme-level define* here also gives "not a parameter name" */ - sc->args= list_1 (sc, sc->args); - sc->code= opt1_cfunc (sc->code); - /* one arg, so it's not a keyword; all we need to do is fill in the defaults - */ - apply_c_function_star_fill_defaults (sc, 1); -} + 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; -static void -op_safe_c_star_aa (s7_scheme* sc) { - sc->args= fx_call (sc, cdr (sc->code)); - set_car (sc->t2_2, fx_call (sc, cddr (sc->code))); - set_car (sc->t2_1, sc->args); - sc->args= sc->t2_1; - sc->code= opt1_cfunc (sc->code); - apply_c_function_star (sc); -} + 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; -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); -} + 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; -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); -} + 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; -static void -op_safe_c_sp (s7_scheme* sc) { - s7_pointer args= cdr (sc->code); - check_stack_size (sc); - push_stack (sc, (opcode_t) T_Op (opt1_any (args)), lookup (sc, car (args)), - sc->code); - sc->code= cadr (args); -} + 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; -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 - */ - sc->value= fn_proc (sc->code) (sc, with_list_t2 (sc, sc->args, sc->value)); -} + 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; /* lg cb (splits to not) */ + + 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; /* tlet sg (splits to not) */ + + 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; /* lg cb (splits to not etc) */ + + 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_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_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_CONS_SP_1: sc->value = cons(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: op_safe_c_ap(sc); goto EVAL; + + case OP_SAFE_C_PA: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_PA: op_safe_c_pa(sc); goto EVAL; + case OP_SAFE_C_PA_1: op_safe_c_pa_1(sc); continue; + + 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; + /* mv case goes through opt_sp_1 to op_safe_c_sp_mv */ + + 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); continue; + + 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); continue; + + 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; -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); -} + 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; -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); -} + 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; -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); -} + 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; -static void -op_safe_c_pc_1 (s7_scheme* sc) { - sc->value= fn_proc (sc->code) (sc, with_list_t2 (sc, sc->value, sc->args)); -} + 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; -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) T_Op (opt1_any (args)), opt3_any (args), - sc->code); /* to safe_add_sp_1 for example */ - sc->code= cadr (args); -} + 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; -static Inline void -inline_op_safe_c_s (s7_scheme* sc) /* called twice in eval c/cl_s many hits */ -{ - sc->value= - fn_proc (sc->code) (sc, with_list_t1 (sc, lookup (sc, cadr (sc->code)))); -} -/* if op_safe_c_t added and set in fx_tree_in, we get a few hits, but nothing - * significant. if that had worked, it would be interesting to set opt1(cdr) to - * the fx_tree fx_proc, (init to fx_c_s), then call that here. opt1(cdr) is not - * used here, opt3_byte happens a few times, but opt2_direct clobbers opt2_fx - * sometimes (also need fx_annotate cdr(expr) in optimize_c_function_one_arg) - */ + 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; -static Inline void -inline_op_safe_c_ss (s7_scheme* sc) /* called twice in eval c/cl_ss many hits */ -{ - sc->value= fn_proc (sc->code) ( - sc, with_list_t2 (sc, lookup (sc, cadr (sc->code)), - lookup (sc, opt1_sym (cdr (sc->code))))); -} - -static void -op_safe_c_sc (s7_scheme* sc) { - sc->value= - fn_proc (sc->code) (sc, with_list_t2 (sc, lookup (sc, cadr (sc->code)), - opt1_con (cdr (sc->code)))); -} - -static void -op_cl_a (s7_scheme* sc) { - sc->value= - fn_proc (sc->code) (sc, with_list_t1 (sc, fx_call (sc, cdr (sc->code)))); -} - -static inline 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_Ext (gc_protected1 (sc))); - unstack_gc_protect (sc); - sc->value= fn_proc (sc->code) (sc, sc->t2_1); -} - -static void -op_cl_fa (s7_scheme* sc) { - const s7_pointer code= cdadr (sc->code); - set_car (sc->t2_2, fx_call (sc, cddr (sc->code))); - set_car (sc->t2_1, make_closure_gc_checked ( - sc, car (code), cdr (code), - T_CLOSURE | ((!s7_is_proper_list (sc, car (sc->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) */ - /* was checking is_symbol(car(sc->code) i.e. is arglist a symbol, but we need - * T_COPY_ARGS if arglist is '(a . b) as well (can this happen here?) */ - sc->value= fn_proc (sc->code) (sc, sc->t2_1); -} - -static inline void -op_map_for_each_fa (s7_scheme* sc) { - const s7_pointer code= sc->code; - sc->value = fx_call (sc, cddr (code)); - if (is_null (sc->value)) - sc->value= (fn_proc_unchecked (code)) ? sc->unspecified : sc->nil; - else { - sc->code= opt3_pair (code); /* cdadr(code); */ - sc->temp8= - make_closure_gc_checked (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, sc->temp8, sc->value) - : g_map_closure (sc, sc->temp8, sc->value); - sc->temp8= sc->unused; - } -} + 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; -static void -op_map_for_each_faa (s7_scheme* sc) { - const s7_pointer arg2p= cddr (sc->code), code= sc->code; - sc->value= fx_call (sc, arg2p); - sc->args = fx_call (sc, cdr (arg2p)); - 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); */ - sc->temp8= - make_closure_gc_checked (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, sc->temp8, sc->value, sc->args) - : g_map_closure_2 (sc, sc->temp8, sc->value, sc->args); - sc->temp8= sc->unused; - } -} + 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; -static void -op_cl_na (s7_scheme* sc) { - const s7_pointer val= - safe_list_if_possible (sc, opt3_arglen (cdr (sc->code))); - if (in_heap (val)) gc_protect_via_stack (sc, val); - for (s7_pointer 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)) clear_safe_list_in_use (sc, val); - else - /* the fn_proc call might push its own op (e.g. for-each/map) so we have to - * check for that */ - if (stack_top_op (sc) == OP_GC_PROTECT) unstack_gc_protect (sc); -} + 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; -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 inline void -op_safe_c_pp (s7_scheme* sc) { - s7_pointer args= cdr (sc->code); - check_stack_size (sc); - 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); -} + /* semisafe c_functions */ + case OP_CL_S: if (!cl_function_is_ok(sc, sc->code)) break; + case HOP_CL_S: inline_op_safe_c_s(sc); continue; -static void -op_safe_c_pp_1 (s7_scheme* sc) { - push_stack (sc, (opcode_t) T_Op (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); -} + case OP_CL_SS: if (!cl_function_is_ok(sc, sc->code)) break; + case HOP_CL_SS: inline_op_safe_c_ss(sc); continue; /* safe_c case has the code we want */ -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)); - if (type (sc->code) == T_C_FUNCTION) - sc->value= apply_c_function_unopt (sc, sc->code, sc->args); - else apply_c_rst_no_req_function (sc); -} - -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); - check_stack_size (sc); - 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, gc_protected1 (sc)); - unstack_gc_protect (sc); - sc->value= fn_proc (sc->code) (sc, sc->t3_1); -} - -static void -op_safe_c_3p_3_mv (s7_scheme* sc) { - s7_pointer p; - const s7_pointer p1 = ((is_pair (sc->args)) && (car (sc->args) == sc->unused)) - ? cdr (sc->args) - : list_1 (sc, sc->args); - const s7_pointer ps1= gc_protected1 (sc); - const s7_pointer p2 = ((is_pair (ps1)) && (car (ps1) == sc->unused)) - ? cdr (ps1) - : list_1 (sc, ps1); - const s7_pointer p3= - ((is_pair (sc->value)) && (car (sc->value) == sc->unused)) - ? cdr (sc->value) - : list_1 (sc, sc->value); - unstack_gc_protect (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)); - if (type (sc->code) == T_C_FUNCTION) - sc->value= apply_c_function_unopt (sc, sc->code, sc->args); - else apply_c_rst_no_req_function (sc); -} - -static Inline bool -inline_collect_np_args (s7_scheme* sc, opcode_t op, - s7_pointer args) /* called (all hits:)op_any_c_np_1/mv - and eval, tlet (cb/set) */ -{ - sc->args= args; - for (s7_pointer 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 { - push_stack (sc, op, sc->args, cdr (p)); - sc->code= T_Pair (car (p)); - return (true); - } - return (false); -} - -static bool -collect_np_args (s7_scheme* sc, opcode_t op, s7_pointer args) { - return (inline_collect_np_args (sc, op, args)); -} - -static /* inline */ bool -op_any_c_np (s7_scheme* sc) /* code: (func . args) where at least one arg is not - fxable */ -{ - sc->args= sc->nil; - for (s7_pointer args= cdr (sc->code); is_pair (args); args= cdr (args)) - if (has_fx (args)) - sc->args= cons (sc, sc->value= fx_call (sc, args), - sc->args); /* reversed before apply in OP_ANY_C_NP_1 */ - 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 (args))) ? OP_ANY_C_NP_1 : OP_ANY_C_NP_2)), - sc->args, cdr (args)); - sc->code= T_Pair (car (args)); - return (true); /* goto EVAL */ - } - sc->args = proper_list_reverse_in_place (sc, sc->args); - sc->value= fn_proc (sc->code) (sc, sc->args); - return (false); /* continue */ -} - -static Inline bool -inline_op_any_c_np_1 (s7_scheme* sc) /* called once in eval, tlet (cb/set) */ -{ - /* in-coming sc->value has the current arg value, sc->args is all previous - * args, sc->code is on op-stack */ - if (inline_collect_np_args (sc, OP_ANY_C_NP_1, - cons (sc, sc->value, sc->args))) - return (true); /* goto EVAL */ - 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); /* continue?? */ -} - -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); - /* 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; -static bool -op_any_c_np_mv (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, - (is_multiple_value (sc->value)) - ? revappend (sc, sc->value, sc->args) - : cons (sc, sc->value, sc->args))) - return (true); /* goto EVAL */ - sc->args= proper_list_reverse_in_place (sc, sc->args); - sc->code= c_function_base (opt1_cfunc (pop_op_stack (sc))); - return (false); /* goto APPLY */ -} - -static void -op_any_closure_np (s7_scheme* sc) { - s7_pointer args= cdr (sc->code); - check_stack_size (sc); - if (sc->op_stack_now >= sc->op_stack_end) resize_op_stack (sc); - push_op_stack (sc, sc->code); - if (has_fx (args)) { - sc->args= fx_call (sc, args); - sc->args= list_1 (sc, sc->args); - for (args= cdr (args); (is_pair (args)) && (has_fx (args)); - args= cdr (args)) - sc->args= cons_unchecked (sc, fx_call (sc, args), sc->args); - } - else sc->args= sc->nil; - push_stack (sc, - ((intptr_t) ((is_pair (cdr (args))) ? OP_ANY_CLOSURE_NP_1 - : OP_ANY_CLOSURE_NP_2)), - sc->args, cdr (args)); - sc->code= T_Pair (car (args)); -} + case OP_CL_AA: if (!cl_function_is_ok(sc, sc->code)) break; + case HOP_CL_AA: op_cl_aa(sc); continue; -static void -op_any_closure_np_end (s7_scheme* sc) { - s7_pointer args, func; - sc->args= proper_list_reverse_in_place ( - sc, sc->args); /* needed in either case -- closure_pars(func) is not - reversed */ - sc->code= pop_op_stack (sc); - func = opt1_lambda (sc->code); - if (is_safe_closure (func)) { - s7_pointer slot; - const s7_int id= ++sc->let_number; - set_curlet (sc, closure_let (func)); - let_set_id (sc->curlet, id); - for (slot= let_slots (sc->curlet), args= sc->args; is_not_slot_end (slot); - slot= next_slot (slot), args= cdr (args)) { - slot_set_value (slot, car (args)); - symbol_set_local_slot (slot_symbol (slot), id, slot); - /* don't free sc->args -- it might be needed in the error below */ - } - if (is_not_slot_end (slot)) - error_nr ( - sc, sc->wrong_number_of_args_symbol, - set_elist_3 (sc, not_enough_arguments_string, sc->code, sc->args)); - } - else { - s7_pointer pars= closure_pars (func), last_slot; - const s7_pointer let = inline_make_let (sc, closure_let (func)); - const s7_int id = let_id (let); - - begin_temp (sc->y, let); - last_slot= make_slot (sc, car (pars), car (sc->args)); - slot_set_next (last_slot, slot_end); - let_set_slots (let, last_slot); - symbol_set_local_slot (car (pars), id, last_slot); - for (pars= cdr (pars), args= cdr (sc->args); is_pair (pars); - pars= cdr (pars), args= cdr (args)) - last_slot= add_slot_at_end ( - sc, id, last_slot, car (pars), - car (args)); /* sets last_slot, don't free sc->args -- used below */ - set_curlet (sc, let); - end_temp (sc->y); -#if S7_DEBUGGING - if ((is_pair (pars)) || (is_pair (args))) - fprintf (stderr, "%s[%d]: p: %s, args: %s\n", __func__, __LINE__, - display (pars), display (args)); - if (is_pair (pars)) - error_nr ( - sc, sc->wrong_number_of_args_symbol, - set_elist_3 (sc, not_enough_arguments_string, sc->code, sc->args)); -#endif - } - if (is_pair (args)) /* these checks are needed because multiple-values might - evade earlier arg num checks */ - error_nr (sc, sc->wrong_number_of_args_symbol, - set_elist_3 (sc, too_many_arguments_string, sc->code, sc->args)); - sc->code= closure_body (func); - if_pair_set_up_begin (sc); -} - -static void -op_safe_c_ap (s7_scheme* sc) { - const s7_pointer code= cdr (sc->code); - const s7_pointer val = cdr (code); - check_stack_size (sc); - sc->args= fx_call (sc, code); - push_stack_direct (sc, (opcode_t) T_Op (opt1_any ( - code))); /* safe_c_sp cases, mv->safe_c_sp_mv */ - sc->code= car (val); -} - -static void -op_safe_c_pa (s7_scheme* sc) { - const s7_pointer args= cdr (sc->code); - check_stack_size (sc); - push_stack_no_args_direct (sc, OP_SAFE_C_PA_1); - sc->code= car (args); -} - -static void -op_safe_c_pa_1 (s7_scheme* sc) { - sc->args= sc->value; /* fx* might change sc->value */ - set_car (sc->t2_2, fx_call (sc, cddr (sc->code))); - set_car (sc->t2_1, sc->args); - sc->value= fn_proc (sc->code) (sc, sc->t2_1); -} - -static void -op_c_nc (s7_scheme* sc) { - if (car (sc->code) != - sc->values_symbol) /* (define (f) (let ((val (catch #t (lambda () (error 1 - 2 3)) (lambda args (list 2 3 4))))) val)) (f) */ - { - const s7_pointer new_args= - make_list (sc, opt3_arglen (cdr (sc->code)), sc->unused); - for (s7_pointer args= cdr (sc->code), p= new_args; is_pair (args); - args= cdr (args), p= cdr (p)) - set_car (p, car (args)); - sc->temp3= new_args; /* desperation? */ - sc->value= fn_proc (sc->code) (sc, new_args); - sc->temp3= sc->unused; - } - else { /* opt2 = splice_in_values */ - set_needs_copied_args ( - cdr (sc->code)); /* needed, see s7test, set_multiple_value which - currently aborts if not a heap pointer */ - sc->value= splice_in_values (sc, cdr (sc->code)); - } -} + case OP_CL_SAS: if (!cl_function_is_ok(sc, sc->code)) break; + case HOP_CL_SAS: op_cl_sas(sc); continue; -static void -op_c_na (s7_scheme* sc) /* (set-cdr! lst ()) */ -{ - const s7_pointer new_args= - make_list (sc, opt3_arglen (cdr (sc->code)), sc->unused); - gc_protect_via_stack (sc, new_args); - for (s7_pointer args= cdr (sc->code), p= new_args; is_pair (args); - args= cdr (args), p= cdr (p)) - set_car (p, fx_call (sc, args)); - unstack_gc_protect (sc); - sc->temp3= new_args; /* desperation? */ - sc->value= fn_proc (sc->code) (sc, new_args); - sc->temp3= sc->unused; -} - -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_sc (s7_scheme* sc) { - sc->args = list_2 (sc, lookup (sc, cadr (sc->code)), - opt3_con (cdr (sc->code))); /* 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_aa (s7_scheme* sc) { - gc_protect_via_stack (sc, fx_call (sc, cdr (sc->code))); - set_gc_protected2 (sc, fx_call (sc, cddr (sc->code))); - sc->value= list_2 (sc, gc_protected1 (sc), gc_protected2 (sc)); - unstack_gc_protect (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_checked (sc, cadr (sc->code))); - sc->value= fn_proc (sc->code) (sc, sc->args); -} - -static Inline void -inline_op_apply_ss (s7_scheme* sc) /* called once in eval, sg: all time spent in - proper_list check */ -{ - sc->args= lookup (sc, opt2_sym (sc->code)); - if (!s7_is_proper_list (sc, sc->args)) - error_nr (sc, sc->syntax_error_symbol, - set_elist_2 ( - sc, - wrap_string (sc, "apply: improper list of arguments: ~S", 37), - sc->args)); - 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 (sc, sc->args); -} - -static void -op_apply_sa (s7_scheme* sc) { - const s7_pointer args= cdr (sc->code); - sc->args = fx_call (sc, cdr (args)); - if (!s7_is_proper_list (sc, sc->args)) - error_nr (sc, sc->syntax_error_symbol, - set_elist_2 ( - sc, - wrap_string (sc, "apply: improper list of arguments: ~S", 37), - sc->args)); - sc->code= lookup_global (sc, car (args)); - if (needs_copied_args (sc->code)) sc->args= copy_proper_list (sc, sc->args); -} - -static void -op_apply_sl (s7_scheme* sc) { - s7_pointer args= cdr (sc->code); - sc->args = fx_call (sc, cdr (args)); - sc->code = lookup_global (sc, car (args)); -} - -static bool -op_pair_pair (s7_scheme* sc) { - if (!is_pair ( - car (sc->code))) /* (for-each (macro* (a . b) `(cons ,a ,b)) #(0 1) - (list '(values +) -1)) sc->code is (-1) */ - { - clear_optimize_op (sc->code); - return (false); - } - if (sc->stack_end >= - sc->stack_resize_trigger - - 8) /* -8 so the next two push_stacks don't hit the resize_trigger - before we can check for cyclic code */ - check_for_cyclic_code (sc, sc->code); /* calls resize_stack */ - push_stack_no_args_direct ( - sc, OP_EVAL_ARGS); /* eval args goes immediately to cdr(sc->code) */ - /* don't put check_stack_size here! */ - push_stack_no_args (sc, OP_EVAL_ARGS, car (sc->code)); - sc->code= caar (sc->code); - return (true); -} + case OP_CL_NA: if (!cl_function_is_ok(sc, sc->code)) break; + case HOP_CL_NA: op_cl_na(sc); continue; -static bool -op_pair_sym (s7_scheme* sc) { - if (!is_symbol (car (sc->code))) /* (for-each (macro* (a . b) `(cons ,a ,b)) - #(0 1) (list `+ -1)) ! sc->code is (-1) */ - { - clear_optimize_op (sc->code); - return (false); - } - sc->value= lookup_global (sc, car (sc->code)); - return (true); -} - -static void -op_eval_set3 (s7_scheme* sc) { - push_stack (sc, is_null (cdr (sc->code)) ? OP_EVAL_SET3_NO_MV : OP_EVAL_SET3, - sc->args, cdr (sc->code)); - sc->code = car (sc->code); - sc->cur_op= optimize_op (sc->code); -} - -static void -op_eval_set3_no_mv (s7_scheme* sc) { - sc->args= pair_append (sc, sc->args, list_1 (sc, sc->value)); - sc->code= pop_op_stack (sc); /* args = (ind... val), code = setter */ -} - -static void -op_eval_args1 (s7_scheme* sc) { - /* implicit_iterator and implicit_c_object, sc->code is ignored, so we can - * skip to apply in eval */ - sc->code= pop_op_stack (sc); - sc->args= cons (sc, sc->value, sc->args); - sc->args= proper_list_reverse_in_place (sc, sc->args); -} - -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)); - /* there's only one push of eval_args2; we could check sc->args==sc->nil there - * and push eval_args6, timp mv misc ? but we have to check somewhere */ -} - -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)) { - if (!s7_is_proper_list (sc, cdr (sc->code))) - error_nr (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, fixup_macro_d (sc, OP_MACRO_D, sc->value)); - else if (is_macro_star (sc->value)) - set_optimize_op (sc->code, - fixup_macro_d (sc, OP_MACRO_STAR_D, sc->value)); - } - sc->code= sc->value; - return (true); - } - if (is_syntactic_pair ( - sc->code)) /* (define progn begin) (progn (display "hi") (+ 1 23)) */ - sc->cur_op= optimize_op (sc->code); - else { - sc->cur_op= syntax_opcode (sc->value); - if ((is_symbol ( - car (sc->code))) && /* don't opt pair to syntax op if sc->value is - actually an arg not the op! ((write and)) - should not be op_and */ - ((car (sc->code) == syntax_symbol (sc->value)) || - (lookup_global (sc, car (sc->code)) == sc->value))) - pair_set_syntax_op (sc->code, sc->cur_op); - /* weird that sc->cur_op setting above seems ok, but OP_PAIR_PAIR hangs?? */ - } - return (false); -} + 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 + two seqs */ -static s7_pointer -unbound_last_arg (s7_scheme* sc, s7_pointer head) { - /* save call-state before autoload/error-hook invocations */ - const s7_int loc = port_location (current_input_port (sc)); - const s7_pointer ops = op_stack_entry (sc); - const s7_pointer args= sc->args; /* maybe GC protect? */ - const s7_pointer val = check_autoload_and_error_hook (sc, head); - if (val == sc->undefined) { - const bool probably_in_repl= - ((location_to_line (loc) == 0) || - (safe_strcmp ("*stdin*", - string_value (sc->file_names[location_to_file (loc)])))); - sc->w= (is_null (sc->args)) - ? list_1 (sc, head) - : proper_list_reverse_in_place (sc, cons (sc, head, args)); - sc->w= cons_unchecked (sc, ops, sc->w); - error_nr ( - sc, sc->unbound_variable_symbol, - (probably_in_repl) - ? set_elist_3 (sc, wrap_string (sc, "'~S is unbound in ~S", 20), - head, sc->w) - : set_elist_5 ( - sc, wrap_string (sc, "'~S is unbound in ~S (~A[~D])", 29), - head, sc->w, sc->file_names[location_to_file (loc)], - wrap_integer (sc, location_to_line (loc)))); - } - return (val); -} -static inline void -eval_last_arg (s7_scheme* sc, s7_pointer head) /* one call, eval 91557 */ -{ - /* here we've reached the last arg, it is not a pair */ - if (!is_null (cdr (sc->code))) improper_arglist_error_nr (sc); - if (is_symbol (head)) { - s7_pointer val= lookup_unexamined (sc, head); - sc->code = (val) ? val : unbound_last_arg (sc, head); - } - else sc->code= head; - 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); -} + /* 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; -static s7_pointer -unbound_args_last_arg (s7_scheme* sc, s7_pointer head) { - /* save call-state before autoload/error-hook invocations */ - const s7_int loc = port_location (current_input_port (sc)); - const s7_pointer ops = op_stack_entry (sc); - const s7_pointer args = sc->args; /* maybe GC protect? */ - const s7_pointer value= sc->value; - const s7_pointer val = check_autoload_and_error_hook (sc, head); - if (val == sc->undefined) { - const bool probably_in_repl= - ((location_to_line (loc) == 0) || - (safe_strcmp ("*stdin*", - string_value (sc->file_names[location_to_file (loc)])))); - sc->w= cons (sc, value, args); /* GC protect this info */ - sc->w= cons_unchecked (sc, head, sc->w); - sc->w= cons_unchecked (sc, ops, proper_list_reverse_in_place (sc, sc->w)); - error_nr ( - sc, sc->unbound_variable_symbol, - (probably_in_repl) - ? set_elist_3 (sc, wrap_string (sc, "'~S is unbound in ~S", 20), - head, sc->w) - : set_elist_5 ( - sc, wrap_string (sc, "'~S is unbound in ~S (~A[~D])", 29), - head, sc->w, sc->file_names[location_to_file (loc)], - wrap_integer (sc, location_to_line (loc)))); - } - return (val); -} - -static /* inline */ bool -eval_args_last_arg ( - s7_scheme* sc) /* inline: no diff tmisc, small diff tmac (3) */ -{ - const s7_pointer head= - 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 (head)) { - 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= head; - return (true); - } - /* get the last arg */ - if (is_symbol (head)) { - s7_pointer val= lookup_unexamined (sc, head); - sc->code = (val) ? val : unbound_args_last_arg (sc, head); - } - else sc->code= head; - /* 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); -} + case OP_C_S: if (!c_function_is_ok(sc, sc->code)) {set_optimize_op(sc->code, OP_S_G); goto EVAL;} + case HOP_C_S: op_c_s(sc); continue; -static inline void -eval_args_pair_car (s7_scheme* sc) { - const s7_pointer code= cdr (sc->code); - if (sc->stack_end >= sc->stack_resize_trigger) - check_for_cyclic_code (sc, sc->code); /* calls resize_stack */ - 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_nr (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); -} + case OP_READ_S: if (!c_function_is_ok(sc, sc->code)) {set_optimize_op(sc->code, OP_S_G); goto EVAL;} + case HOP_READ_S: op_read_s(sc); continue; -static bool -eval_car_pair (s7_scheme* sc) { - const s7_pointer code= sc->code, head= car (sc->code); + 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; - /* evaluate the inner list but that list can be circular: head: #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); + 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; - if (is_symbol_and_syntactic (car (head))) - /* 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 (!no_int_opt (code)) { - /* lambda */ - if ((car (head) == sc->lambda_symbol) && /* ((lambda ...) expr) */ - (is_pair (cddr (head))) && - (s7_is_proper_list (sc, cddr (head)))) /* not dotted! */ - { - const s7_pointer args= cadr (head); - set_opt3_pair (code, cddr (head)); /* lambda body */ - if ((is_null (args)) && (is_null (cdr (code)))) { - set_optimize_op (code, OP_F); /* ((lambda () ...)) */ - return (false); - } - if (is_pair (args)) { - if ((is_normal_symbol (car (args))) && - (!is_constant (sc, car (args))) && (is_pair (cdr (code))) && - (is_fxable (sc, cadr (code)))) { - set_opt3_sym ( - cdr (code), - car (args)); /* new curlet symbol #1 (first arg of lambda) */ - if ((is_null (cdr (args))) && (is_null (cddr (code)))) { - fx_annotate_args (sc, cdr (code), - sc->curlet); /* ((lambda (x) ...) expr) */ - set_optimize_op (code, OP_F_A); - return (false); - } - if ((is_pair (cdr (args))) && (is_pair (cddr (code))) && - (is_fxable (sc, caddr (code))) && (is_null (cddr (args))) && - (is_null (cdddr (code))) && (is_normal_symbol (cadr (args))) && - (!is_constant (sc, cadr (args))) && - (car (args) != cadr (args))) { - fx_annotate_args (sc, cdr (code), sc->curlet); - set_optimize_op (code, - OP_F_AA); /* ((lambda (x y) ...) expr expr) */ - return (false); - } - } - set_optimize_op (code, OP_F_NP); - } - } - set_no_int_opt (code); - } - /* ((if op1 op2) args...) is another somewhat common case */ - push_stack_no_args (sc, OP_EVAL_ARGS, code); - sc->code= head; - if (!no_cell_opt (head)) { - /* if */ - if ((car (head) == 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, head); - if ((fx_function[optimize_op (head)]) && - (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 (head)]); - if (is_null (cddr (code))) set_optimize_op (code, OP_A_A); - else - set_optimize_op (code, ((is_symbol (cadr (code))) && - (!is_pair (caddr (code))) && - (!is_normal_symbol (caddr (code)))) - ? OP_A_SC - : OP_A_AA); - return (false); /* goto eval in trailers */ - } - } - set_no_cell_opt (head); - } - sc->cur_op= (opcode_t) symbol_syntax_op_checked (sc->code); - pair_set_syntax_op (sc->code, sc->cur_op); - return (true); - } - push_stack_no_args (sc, OP_EVAL_ARGS, code); - if ((is_pair (cdr (code))) && (is_optimized (head))) { - if ((fx_function[optimize_op (head)]) && (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 (head)]); - if (is_null (cddr (code))) set_optimize_op (code, OP_A_A); - else - set_optimize_op (code, ((is_symbol (cadr (code))) && - (!is_pair (caddr (code))) && - (!is_normal_symbol (caddr (code)))) - ? OP_A_SC - : OP_A_AA); - sc->code= head; - 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)); - } - /* possible op 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_no_args (sc, OP_EVAL_ARGS, head); - sc->code= car (head); - return (false); -} + case OP_C_SS: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_C_SS: op_c_ss(sc); continue; -/* ---------------- reader funcs for eval ---------------- */ -static void -back_up_stack (s7_scheme* sc) { - opcode_t top_op= stack_top_op (sc); - if (top_op == OP_READ_DOT) { - pop_stack (sc); - top_op= stack_top_op (sc); - } - if ((top_op == OP_READ_VECTOR) || (top_op == OP_READ_BYTE_VECTOR) || - (top_op == OP_READ_INT_VECTOR) || (top_op == OP_READ_FLOAT_VECTOR) || - (top_op == OP_READ_COMPLEX_VECTOR)) { - pop_stack (sc); - top_op= stack_top_op (sc); - } - if (top_op == OP_READ_QUOTE) pop_stack (sc); -} + case OP_C_SC: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_C_SC: op_c_sc(sc); continue; -static token_t -read_block_comment (s7_scheme* sc, s7_pointer port) { - /* block comments in #| ... |# - * since we ignore everything until the |#, internal semicolon comments are - * ignored, meaning that ;|# is as effective as |# - */ - if (is_file_port (port)) { - char last_char= ' '; - while (true) { - int32_t c= fgetc (port_file (port)); - if (c == EOF) - error_nr ( - 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 (port)++; - } - return (token (sc)); - } - { - const char* orig_str= - (const char*) (port_data (port) + port_position (port)); - const char* pend= (const char*) (port_data (port) + port_data_size (port)); - const char* str = orig_str; - const char* p; - while (true) { - p= strchr (str, (int) '|'); - if ((!p) || (p >= pend)) { - port_position (port)= port_data_size (port); - error_nr ( - 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 (port)+= (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 (port)++; - str= (const char*) (p + 1); - } - else break; - } - } - return (token (sc)); -} + 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; -static token_t -read_excl_comment (s7_scheme* sc, s7_pointer port) { - /* block comments in #! ... !# - * this is needed when an input file is treated as a script: - #!/home/bil/cl/snd - !# - (format #t "a test~%") - (exit) - */ - /* make it possible to override #! handling */ - for (s7_pointer reader= slot_value (sc->sharp_readers); is_pair (reader); - reader = cdr (reader)) - if (s7_character (caar (reader)) == '!') { - sc->strbuf[0]= (unsigned char) '!'; - return (token_sharp_const); /* next stage notices any errors */ - } - /* not #! as block comment (for Guile I guess) */ - { - int32_t c; - char last_char= ' '; - while ((c= inchar (port)) != EOF) { - if ((c == '#') && (last_char == '!')) break; - last_char= c; - } - if (c == EOF) - error_nr ( - sc, sc->read_error_symbol, - set_elist_1 ( - sc, wrap_string (sc, "unexpected end of input while reading #!", - 40))); - } - return (token (sc)); -} - -static token_t -read_sharp (s7_scheme* sc, s7_pointer port) { - const int32_t c= - inchar (port); /* inchar can return EOF, so it can't be used directly as - an index into the digits array */ - switch (c) { - case EOF: - error_nr (sc, sc->read_error_symbol, - set_elist_1 ( - sc, wrap_string (sc, "unexpected '#' at end of input", 30))); - break; - - case '(': /* #(...) */ - sc->read_dims= int_one; /* for read_expression! */ - return (token_vector); - - case 'i': /* #i(...) */ - if (read_sharp (sc, port) == token_vector) return (token_int_vector); - backchar ('i', port); - break; - - case 'r': /* #r(...) */ - if (read_sharp (sc, port) == token_vector) return (token_float_vector); - backchar ('r', port); - break; - - case 'c': /* #c(...) */ - if (read_sharp (sc, port) == token_vector) return (token_complex_vector); - backchar ('c', port); - break; - - case 'u': /* #u(...) or #u8(...) */ - if (s7_peek_char (sc, port) == - chars[( - int32_t) ('8')]) /* backwards compatibility: #u8(...) == #u(...) */ - { - const int32_t bc= inchar (port); - if (s7_peek_char (sc, port) == chars[(int32_t) ('(')]) { - inchar (port); - sc->read_dims= int_one; /* for read_expression! */ - return (token_byte_vector); - } - backchar (bc, port); - } - if (read_sharp (sc, port) == token_vector) return (token_byte_vector); - backchar ('u', port); - 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= digits[c]; - int32_t d= 0, loc= 0; - sc->strbuf[loc++]= (unsigned char) c; - while (true) { - s7_int dig; - d= inchar (port); - if (d == EOF) - error_nr (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; - error_nr ( - sc, sc->read_error_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, "reading #~A...: ~D must be a positive integer", 45), - wrap_string (sc, sc->strbuf, loc), wrap_integer (sc, dims))); - } - if (dims > sc->max_vector_dimensions) { - sc->strbuf[loc++] = (unsigned char) d; - sc->strbuf[loc + 1]= '\0'; - error_nr (sc, sc->read_error_symbol, - set_elist_4 (sc, - wrap_string (sc, - "reading #~A...: ~D is too large, " - "(*s7* 'max-vector-dimensions): ~D", - 66), - wrap_string (sc, sc->strbuf, loc), - wrap_integer (sc, dims), - wrap_integer (sc, sc->max_vector_dimensions))); - } - sc->strbuf[loc++]= (unsigned char) d; - } - sc->strbuf[loc++]= d; - if ((d == 'd') || (d == 'i') || (d == 'r') || (d == 'u') || (d == 'c')) { - const int32_t chr= inchar (port); - if (chr == EOF) - error_nr ( - 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) chr; - if (chr == '(') { - sc->read_dims= make_integer (sc, dims); /* for read_expression! */ - if (d == 'd') return (token_vector); - if (d == 'r') return (token_float_vector); - if (d == 'c') return (token_complex_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], port); - } break; + case OP_C_AA: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_C_AA: op_c_aa(sc); continue; -#if !DISABLE_DEPRECATED - 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. - */ - sc->strbuf[0]= ':'; - return (token_atom); -#endif + case OP_C_NC: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_C_NC: op_c_nc(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 '!': /* I don't think #! is special anymore -- maybe remove this code? - */ - return (read_excl_comment (sc, port)); + case OP_APPLY_SS: inline_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 '|': - return (read_block_comment (sc, port)); - } - sc->strbuf[0]= (unsigned char) c; - return (token_sharp_const); /* next stage notices any errors */ -} + case OP_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: op_call_with_exit_o(sc); goto EVAL; + case OP_C_CATCH: op_c_catch(sc); goto BEGIN; + case OP_C_CATCH_ALL: op_c_catch_all(sc); goto BEGIN; + case OP_C_CATCH_ALL_O: op_c_catch_all(sc); goto EVAL; + case OP_C_CATCH_ALL_A: op_c_catch_all_a(sc); continue; -static token_t -read_comma (s7_scheme* sc, s7_pointer port) { - /* here we probably should check for symbol names that start with "@": - (define-macro (hi @foo) `(+ ,@foo 1)): (hi 2) -> ;foo: unbound variable - but (define-macro (hi .foo) `(+ ,.foo 1)): (hi 2) -> 3 - and ambiguous: (define-macro (hi @foo . foo) `(list ,@foo)) - what about , @foo -- is the space significant? We accept ,@ foo. - (Currently , @ says unbound variable @foo). - */ - const int32_t c= inchar (port); - if (c == '@') 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, port); - return (token_comma); -} + 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; -static token_t -read_dot (s7_scheme* sc, s7_pointer port) { - const int32_t c= inchar (port); - if (c != EOF) { - backchar (c, port); - 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 */ -{ - const int32_t 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); - } -} + 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; -static int32_t -read_x_char (s7_scheme* sc, int32_t i, s7_pointer port) { - /* 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 - */ - for (int32_t c_ctr= 0;; c_ctr++) { - int32_t d1, d2, c= inchar (port); - if (c == '"') /* "\x" -> error, "\x44" or "\x44;" -> #\D */ - { - if (c_ctr == 0) /* "\x" */ - read_error_nr ( - sc, - "unknown backslash usage -- perhaps you meant two backslashes?"); - backchar (c, port); /* "\x44" I think -- not sure about this -- Guile is - happy but I think it contradicts r7rs.pdf */ - return (i); - } - if (c == ';') { - if (c_ctr == 0) /* "\x;" */ - read_error_nr ( - sc, - "unknown backslash usage -- perhaps you meant two backslashes?"); - return (i); /* "\x44;" */ - } - if (c == EOF) /* "\x */ - { - read_error_nr (sc, "# in midst of hex-char"); - return (i); - } - d1= digits[c]; - if (d1 >= 16) /* "\x4H", also "\x44H" which Guile thinks is ok -- it - apparently reads 2 digits and quits? */ - { - if (c_ctr == 0) - read_error_nr ( - sc, - "unknown backslash usage -- perhaps you meant two backslashes?"); - backchar (c, port); - return (i); - } - /* perhaps if c_ctr==0 error else backchar + return(i??) */ - - c= inchar (port); - if (c == '"') /* "\x4" */ - { - sc->strbuf[i++]= (unsigned char) d1; - backchar ((char) c, port); - return (i); - } - if (c == ';') /* "\x4;" */ - { - sc->strbuf[i++]= (unsigned char) d1; - return (i); - } - if (c == EOF) /* "\x4 */ - { - read_error_nr (sc, "# in midst of hex-char"); - return (i); - } - d2= digits[c]; - if (d2 >= 16) { - if (c_ctr == 0) - read_error_nr ( - sc, - "unknown backslash usage -- perhaps you meant two backslashes?"); - backchar (c, port); - 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= 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); -} + case OP_F: op_f(sc); goto BEGIN; + case OP_F_A: op_f_a(sc); goto BEGIN; + case OP_F_AA: op_f_aa(sc); goto BEGIN; + case OP_F_NP: op_f_np(sc); goto EVAL; + case OP_F_NP_1: if (op_f_np_1(sc)) goto EVAL; goto BEGIN; -static s7_pointer -read_string_constant (s7_scheme* sc, s7_pointer port) { - /* sc->F => error, no check needed here for bad input port and so on */ - s7_int i= 0; /* sc->strbuf index */ - if (is_string_port (port)) { - /* try the most common case first */ - char *s, *end, - *start= - (char*) (port_data (port) + - port_position (port)); /* not const: C++: strpbrk(start, - "\"\n\\") first arg is char* */ - if (*start == '"') { - port_position (port)++; - return (nil_string); - } - end= (char*) (port_data (port) + port_data_size (port)); - 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= s - start; - port_position (port)+= (len + 1); - return (make_string_with_length (sc, start, len)); - } - for (; s < end; s++) { - if (*s == '"') /* switch here no faster */ - { - s7_int len= s - start; - port_position (port)+= (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") */ - const s7_int len= (s7_int) (s - start); - if (len > 0) { - if (len >= sc->strbuf_size) resize_strbuf (sc, len); - memcpy ((void*) (sc->strbuf), - (void*) (port_data (port) + port_position (port)), len); - port_position (port)+= len; - } - i= len; - break; - } - else if (*s == '\n') port_line_number (port)++; - } - } - while (true) { - /* splitting this check out and duplicating the loop was slower?!? */ - int32_t c= port_read_character (port) (sc, port); - switch (c) { - case '\n': - port_line_number (port)++; - sc->strbuf[i++]= (unsigned char) c; - break; + case OP_S: op_s(sc); goto APPLY; + case OP_S_G: if (op_s_g(sc)) continue; goto APPLY; + case OP_S_A: if (op_x_a(sc, lookup_checked(sc, car(sc->code)))) continue; goto APPLY; + case OP_A_A: if (op_x_a(sc, fx_call(sc, sc->code))) continue; goto APPLY; + case OP_S_AA: if (op_x_aa(sc, lookup_checked(sc, car(sc->code)))) continue; goto APPLY; + case OP_A_AA: if (op_x_aa(sc, fx_call(sc, sc->code))) continue; goto APPLY; + case OP_A_SC: if (op_x_sc(sc, fx_call(sc, sc->code))) continue; goto APPLY; + case OP_P_S: push_stack_no_args_direct(sc, OP_P_S_1); sc->code = car(sc->code); goto EVAL; + case OP_P_S_1: op_p_s_1(sc); goto APPLY; - case EOF: - sc->strbuf[(i > 8) ? 8 : i]= '\0'; - return (sc->F); + 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 '"': - return (make_string_with_length (sc, sc->strbuf, i)); + 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 '\\': - c= inchar (port); - 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, port); - 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= unknown_string_constant (sc, c); - if (!is_character (result)) return (result); - sc->strbuf[i++]= character (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; + 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; - default: - sc->strbuf[i++]= (unsigned char) c; - break; - } - if (i >= sc->strbuf_size) resize_strbuf (sc, i); - } -} + 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; -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_nr (sc, "end of input encountered while in a string"); - if (sc->value == sc->T) - read_error_nr ( - sc, "unknown backslash usage -- perhaps you meant two backslashes?"); - if (sc->safety > immutable_vector_safety) set_immutable_string (sc->value); -} - -static /* inline */ bool -read_sharp_const (s7_scheme* sc) /* tread but inline makes no difference? (it's - currently inlined anyway) */ -{ - 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 no_return void -read_expression_read_error_nr (s7_scheme* sc) { - const s7_pointer port= current_input_port (sc); - pop_stack (sc); - if ((is_input_port (port)) && (!port_is_closed (port)) && - (port_data (port)) && (port_position (port) > 0)) { - const s7_pointer str = make_empty_string (sc, 128, '\0'); - const char* msg = string_value (str); - const s7_int pos = port_position (port); - s7_int start= pos - 40; - if (start < 0) start= 0; - memcpy ((void*) msg, (const void*) "at \"...", 7); - memcpy ((void*) (msg + 7), (void*) (port_data (port) + start), pos - start); - memcpy ((void*) (msg + 7 + pos - start), (const void*) "...", 3); - string_length (str)= 7 + pos - start + 3; - error_nr (sc, sc->read_error_symbol, set_elist_1 (sc, str)); - } - read_error_nr (sc, "stray comma before ')'?"); /* '("a" "b",) */ -} - -static s7_pointer -read_expression (s7_scheme* sc) { - while (true) { - 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->read_dims); /* sc->read_dims here and below = vector dimensions - (from read_sharp) -> sc->args */ - sc->tok= token_left_paren; - break; - case token_int_vector: - push_stack_no_let_no_code (sc, OP_READ_INT_VECTOR, sc->read_dims); - sc->tok= token_left_paren; - break; + case OP_THUNK: if (!closure_is_ok(sc, sc->code, FINE_UNSAFE_CLOSURE, 0)) {if (op_unknown(sc)) goto EVAL; continue;} + case HOP_THUNK: op_thunk(sc); goto EVAL; - case token_float_vector: - push_stack_no_let_no_code (sc, OP_READ_FLOAT_VECTOR, sc->read_dims); - sc->tok= token_left_paren; - break; + case OP_THUNK_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 0)) {if (op_unknown(sc)) goto EVAL; continue;} + case HOP_THUNK_O: op_thunk_o(sc); goto EVAL; - case token_complex_vector: - push_stack_no_let_no_code (sc, OP_READ_COMPLEX_VECTOR, sc->read_dims); - sc->tok= token_left_paren; - break; + 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 token_vector: /* already read #( -- token_vector is triggered by #( */ - push_stack_no_let_no_code ( - sc, OP_READ_VECTOR, - sc->read_dims); /* sc->read_dims is the dimensions */ - /* fall through */ + 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 token_left_paren: - sc->tok= token (sc); - if (sc->tok == token_right_paren) return (sc->nil); - if (sc->tok == token_dot) { - int32_t c; - back_up_stack (sc); - do { - c= inchar (current_input_port (sc)); - } while ((c != ')') && (c != EOF)); - read_error_nr (sc, "stray dot after '('?"); /* (car '( . )) */ - } - if (sc->tok == token_eof) missing_close_paren_error_nr (sc); - check_stack_size (sc); /* s7test, tlimit */ - push_stack_no_let_no_code ( - sc, OP_READ_LIST, - sc->nil); /* here we need to clear args, but code is ignored */ - break; + case OP_SAFE_THUNK_ANY: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 1)) break; /* symbol as arglist */ + case HOP_SAFE_THUNK_ANY: op_safe_thunk_any(sc); goto EVAL; - case token_quote: - check_stack_size ( - sc); /* no speed diff in tload.scm which looks like the worst case */ - push_stack_no_let_no_code (sc, OP_READ_QUOTE, sc->nil); - sc->tok= token (sc); - break; + 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 token_back_quote: - sc->tok= token (sc); - push_stack_no_let_no_code (sc, OP_READ_QUASIQUOTE, sc->nil); - break; + case OP_CLOSURE_S: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 1)) {if (op_unknown_s(sc)) goto EVAL; continue;} + case HOP_CLOSURE_S: op_closure_s(sc); goto EVAL; - case token_comma: - push_stack_no_let_no_code (sc, OP_READ_UNQUOTE, sc->nil); - sc->tok= token (sc); - if (sc->tok == token_right_paren) read_expression_read_error_nr (sc); - if (sc->tok == token_eof) { - pop_stack (sc); - read_error_nr (sc, "stray comma at the end of the input?"); - } - break; + case OP_CLOSURE_S_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 1)) {if (op_unknown_s(sc)) goto EVAL; continue;} + case HOP_CLOSURE_S_O: op_closure_s_o(sc); goto EVAL; - case token_at_mark: - push_stack_no_let_no_code (sc, OP_READ_APPLY_VALUES, sc->nil); - sc->tok= token (sc); - break; + case OP_SAFE_CLOSURE_S: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 1)) {if (op_unknown_s(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_S: op_safe_closure_s(sc); goto EVAL; - 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 OP_SAFE_CLOSURE_S_O: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 1)) {if (op_unknown_s(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_S_O: op_safe_closure_s_o(sc); goto EVAL; - case token_double_quote: - read_double_quote (sc); - return (sc->value); + case OP_SAFE_CLOSURE_S_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 1)) {if (op_unknown_s(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_S_A: sc->value = op_safe_closure_s_a(sc, sc->code); continue; - case token_sharp_const: - return (port_read_sharp (current_input_port (sc)) ( - sc, current_input_port (sc))); + case OP_SAFE_CLOSURE_S_TO_S: if ((symbol_ctr(car(sc->code)) > 1) && (!closure_is_eq(sc))) {if (op_unknown_s(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_S_TO_S: sc->value = fx_safe_closure_s_to_s(sc, sc->code); continue; - case token_dot: /* (catch #t (lambda () (+ 1 . . )) (lambda args 'hiho)) */ - back_up_stack (sc); - { - int32_t c; - do { - c= inchar (current_input_port (sc)); - } while ((c != ')') && (c != EOF)); - } - read_error_nr (sc, "stray dot in list?"); /* (+ 1 . . ) */ + case OP_SAFE_CLOSURE_S_TO_SC: if ((symbol_ctr(car(sc->code)) > 1) && (!closure_is_eq(sc))) {if (op_unknown_s(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_S_TO_SC: sc->value = fx_proc(cdr(sc->code))(sc, sc->code); continue; - case token_right_paren: /* (catch #t (lambda () '(1 2 . )) (lambda args - 'hiho)) */ - back_up_stack (sc); - read_error_nr (sc, "unexpected close paren"); /* (+ 1 2)) or (+ 1 . ) */ - } - } - /* we never get here */ - if (S7_DEBUGGING) - fprintf (stderr, "%s[%d]: we should not be here\n", __func__, __LINE__); - return (sc->nil); -} + 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; -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); -} + case OP_CLOSURE_P: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 1)) {op_unknown_np(sc); goto EVAL;} + case HOP_CLOSURE_P: op_closure_p(sc); goto EVAL; + case OP_CLOSURE_P_1: op_closure_p_1(sc); goto BEGIN; -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 */ -} + case OP_SAFE_CLOSURE_P: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 1)) {op_unknown_np(sc); goto EVAL;} + 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; -static int32_t -read_atom (s7_scheme* sc, s7_pointer port) { - push_stack_no_let_no_code (sc, OP_READ_LIST, sc->args); - /* check_stack_size(sc); */ - sc->value= port_read_name (port) (sc, port); - sc->args = list_1 (sc, sc->value); - pair_set_current_input_location (sc, sc->args); - return (port_read_white_space (port) (sc, port)); -} - -static /* inline */ int32_t -read_start_list (s7_scheme* sc, s7_pointer port, int32_t c) { - 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 (port) (sc, port); - sc->args = list_1 (sc, sc->value); - pair_set_current_input_location (sc, sc->args); - return (port_read_white_space (port) (sc, port)); -} - -static void -op_read_internal (s7_scheme* sc) { - /* if we're loading a file, and in the file we evaluate (at top-level) - * something like: (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))) - error_nr ( - 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, - (is_loader_port (current_input_port (sc))) - ? "load input port is closed!" - : "read input port is closed!", - 26))); - - sc->tok= token (sc); - switch (sc->tok) { - case token_eof: - break; - case token_right_paren: - read_error_nr (sc, "unexpected close paren"); - case token_comma: - read_error_nr (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; - } -} + case OP_SAFE_CLOSURE_P_A: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 1)) {op_unknown_np(sc); goto EVAL;} + 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; -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 */ -} + 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: inline_op_closure_a(sc); push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); sc->code = car(sc->code); goto EVAL; -static void -op_read_s (s7_scheme* sc) { - const s7_pointer 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; - } - if (port_is_closed (port)) /* I guess the port_is_closed check is needed - because we're going down a level below */ - sole_arg_wrong_type_error_nr (sc, sc->read_symbol, port, - an_open_input_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); - error_nr ( - sc, sc->bad_result_symbol, - set_elist_2 ( - sc, wrap_string (sc, "input-function-port read returned: ~S", 37), - sc->value)); - } - } - else /* we used to check for string port at end here, but that is rarely true - so checking takes up more time than it saves */ - { - 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; - case token_right_paren: - read_error_nr (sc, "unexpected close paren"); - case token_comma: - read_error_nr (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)); - } - } -} + 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: inline_op_closure_a(sc); sc->code = car(sc->code); goto EVAL; -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 (stack_top_op (sc) != OP_READ_LIST); -} + 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; -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= stack_end_args (sc); - if (!is_null (sc->args)) - return (false); /* fall into read_list where sc->args is placed at end of - on-going list, sc->value */ - sc->args= list_1 (sc, sc->value); - pair_set_current_input_location (sc, sc->args); /* uses port_location */ - return (true); -} + 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; -static bool -op_load_return_if_eof (s7_scheme* sc) { - if (SHOW_EVAL_OPS) - fprintf (stderr, " op_load_return_if_eof: value: %s\n", - display_truncated (sc->value)); - 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[%d]: %s not loading?\n", __func__, __LINE__, - display (current_input_port (sc))); - /* if *#readers* func hits error, clear_loader_port might not be undone? */ - if (SHOW_EVAL_OPS) - fprintf (stderr, "%s closing %s\n", __func__, - display (current_input_port (sc))); - - 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 returns (values - "a-file" an-environment)? */ - 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, initial_value (sc->apply_values_symbol), sc->value)); - return (stack_top_op (sc) != OP_READ_LIST); -} - -static goto_t -op_read_dot (s7_scheme* sc) { - const token_t c= token (sc); - if (c != token_right_paren) /* '(1 . (2) 3) -> '(1 2 3), Guile says "missing - close paren" */ - { - if (is_pair (sc->value)) { - for (s7_pointer 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_nr (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 ((stack_top_op (sc) == OP_READ_LIST) ? goto_pop_read_list - : goto_start); -} + 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; -static bool -op_read_quote (s7_scheme* sc) /* ' -> (#_quote ) because quote is not immutable */ -{ - /* 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->symbol_quote) ? sc->quote_symbol : sc->quote_function, - sc->value); - return (stack_top_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 (stack_top_op (sc) != OP_READ_LIST); -} + case OP_CLOSURE_AP: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) {op_unknown_np(sc); goto EVAL;} + case HOP_CLOSURE_AP: op_closure_ap(sc); goto EVAL; + case OP_CLOSURE_AP_1: op_closure_ap_1(sc); goto BEGIN; -/* 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 - */ -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->read_dims - 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 (stack_top_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 (stack_top_op (sc) != OP_READ_LIST); -} - -static bool -op_read_float_vector (s7_scheme* sc) { - /* sc->value is the list of values, #r(...sc->value...), sc->args = dimensions - */ - 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 (stack_top_op (sc) != OP_READ_LIST); - /* should this be an error: #r(9223372036854775807): - * #r(9.223372036854776e+18)? also #r(pi)->error that pi is a symbol but - * #r(+nan.0 -inf.0): #r(+nan.0 -inf.0) -- should pi be a number in the same - * way? - */ - /* to avoid making the list: sc->floats array (growable and maybe pruned), - * token_float_vector in read_expression: sc->value = unused, push - * op_read_float_vector sc->args = dims, (read_sharp sc->read_dims = dims, - * read_expression push_op moves it to sc->args : push - * op_read_float_vector (no op_read_list), read, eval, fill sc->floats, when - * right-paren make new vector [for multidims, get list->frame] - */ -} + case OP_CLOSURE_PA: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) {op_unknown_np(sc); goto EVAL;} + case HOP_CLOSURE_PA: op_closure_pa(sc); goto EVAL; + case OP_CLOSURE_PA_1: op_closure_pa_1(sc); goto BEGIN; -static bool -op_read_complex_vector (s7_scheme* sc) { - /* sc->value is the list of values, #c(...sc->value...), sc->args = dimensions - */ - sc->value= (sc->args == int_one) - ? g_complex_vector (sc, sc->value) - : g_complex_multivector (sc, integer (sc->args), sc->value); - if (sc->safety > immutable_vector_safety) set_immutable (sc->value); - return (stack_top_op (sc) != OP_READ_LIST); -} + case OP_CLOSURE_PP: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) {op_unknown_np(sc); goto EVAL;} + case HOP_CLOSURE_PP: op_closure_pp(sc); goto EVAL; + case OP_CLOSURE_PP_1: op_closure_pp_1(sc); goto EVAL; -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 (stack_top_op (sc) != OP_READ_LIST); -} + case OP_SAFE_CLOSURE_AP: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 2)) {op_unknown_np(sc); goto EVAL;} + 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; -/* ---------------- unknown ops ---------------- */ -static bool -fixup_unknown_op (s7_scheme* sc, s7_pointer code, s7_pointer func, - opcode_t op) { - set_optimize_op (code, op); - if (is_any_closure (func)) set_opt1_lambda_add (code, func); - return (true); /* for easier break from switch */ -} - -static bool -unknown_unknown (s7_scheme* sc, s7_pointer code, opcode_t op) { - if ((is_symbol (car (code))) && (!is_bound_symbol (sc, car (code)))) - unbound_variable_error_nr (sc, car (code)); - set_optimize_op (code, op); - return (true); -} - -static bool -is_immutable_and_stable (s7_scheme* sc, s7_pointer func) { - if (symbol_ctr (func) != - 1) /* protect against (define-constant (p) (define-constant (p) ...)) */ - return (false); - if ((is_defined_global (func)) && (is_immutable_slot (global_slot (func)))) - return (true); - for (s7_pointer let= sc->curlet; let; let= let_outlet (let)) - if ((is_funclet (let)) && (funclet_function (let) != func)) return (false); - return (is_immutable_slot (s7_t_slot (sc, func))); -} - -static bool -op_unknown (s7_scheme* sc) { - const s7_pointer code= sc->code, func= sc->last_function; - if (!func) /* can be NULL if unbound variable */ - unbound_variable_error_nr (sc, car (sc->code)); - if (SHOW_EVAL_OPS) - fprintf (stderr, " %s %s %s\n", __func__, display_truncated (func), - s7_type_names[type (func)]); - - switch (type (func)) { - case T_CLOSURE: - case T_CLOSURE_STAR: - if (!has_methods (func)) { - const int32_t hop= (is_immutable_and_stable (sc, car (code))) ? 1 : 0; - if (is_null (closure_pars (func))) { - const s7_pointer body = closure_body (func); - const bool one_form = is_null (cdr (body)); - const bool safe_case= is_safe_closure (func); - set_opt1_lambda_add (code, func); - if (one_form) { - if ((safe_case) && (is_fxable (sc, car (body)))) { - set_safe_closure ( - func); /* 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 (func); - 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 - : ((one_form) ? OP_THUNK_O : OP_THUNK))); - return (true); - } - if (is_closure_star (func)) { - set_safe_optimize_op (code, hop + ((is_safe_closure (func)) - ? OP_SAFE_CLOSURE_STAR_NA_0 - : OP_CLOSURE_STAR_NA)); - set_opt1_lambda_add (code, func); - return (true); - } - } - break; - - case T_GOTO: - return (fixup_unknown_op (sc, code, func, OP_IMPLICIT_GOTO)); - case T_ITERATOR: - return (fixup_unknown_op (sc, code, func, OP_IMPLICIT_ITERATE)); - case T_BACRO: - case T_MACRO: - return (fixup_unknown_op (sc, code, func, - fixup_macro_d (sc, OP_MACRO_D, func))); - case T_BACRO_STAR: - case T_MACRO_STAR: - return (fixup_unknown_op (sc, code, func, - fixup_macro_d (sc, OP_MACRO_STAR_D, func))); - - default: - if ((is_symbol (car (code))) && (!is_bound_symbol (sc, car (code)))) - unbound_variable_error_nr (sc, car (code)); - } - return (fixup_unknown_op (sc, code, func, OP_S)); -} - -static bool -fxify_closure_star_g (s7_scheme* sc, s7_pointer clo, s7_pointer code) { - if ((!has_methods (clo)) && (closure_star_arity_to_int (sc, clo) != 0)) { - const int32_t hop = (is_immutable_and_stable (sc, car (code))) ? 1 : 0; - const bool safe_case= is_safe_closure (clo); - fx_annotate_arg (sc, cdr (code), sc->curlet); - set_opt3_arglen (cdr (code), 1); - if ((safe_case) && (is_null (cdr (closure_pars (clo))))) - set_optimize_op (code, hop + OP_SAFE_CLOSURE_STAR_A1); - else if (lambda_has_simple_defaults (clo)) { - if (arglist_has_rest (sc, closure_pars (clo))) - fixup_unknown_op (sc, code, clo, - hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_NA_1 - : OP_CLOSURE_STAR_NA)); - else - fixup_unknown_op (sc, code, clo, - hop + ((safe_case) - ? ((is_null (cdr (closure_pars (clo)))) - ? OP_SAFE_CLOSURE_STAR_A1 - : OP_SAFE_CLOSURE_STAR_A) - : OP_CLOSURE_STAR_A)); - return (true); - } - fixup_unknown_op ( - sc, code, clo, - hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_NA_1 : OP_CLOSURE_STAR_NA)); - return (true); - } - return (false); -} - -static bool -op_unknown_closure_s (s7_scheme* sc, s7_pointer clo, s7_pointer code) { - const s7_pointer body = closure_body (clo); - const bool one_form= is_null (cdr (body)); - const int32_t hop = (is_immutable_and_stable (sc, car (code))) ? 1 : 0; - clear_has_fn (code); - set_opt2_sym (code, cadr (code)); - - /* code here might be (clo x) where clo 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_g. Ideally we'd - * know this was a parameter or whatever. The tricky case is local letrec(f) - * calling clo which initially thinks it is not safe, then later is set safe - * correctly, now outer func is called again, this time clo is safe, and we're - * ok from then on. - */ - if (is_unknopt (code)) { - switch (op_no_hop (code)) { - case OP_CLOSURE_S: - set_optimize_op ( - code, (is_safe_closure (clo)) - ? ((one_form) ? OP_SAFE_CLOSURE_S_O : OP_SAFE_CLOSURE_S) - : OP_S_G); - break; - case OP_CLOSURE_S_O: - case OP_SAFE_CLOSURE_S: - set_optimize_op (code, ((one_form) ? OP_CLOSURE_S_O : 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 (clo)) - ? ((one_form) ? OP_SAFE_CLOSURE_S_O : OP_SAFE_CLOSURE_S) - : ((one_form) ? OP_CLOSURE_S_O : OP_CLOSURE_S)); - break; - default: - set_optimize_op (code, OP_S_G); - break; - } - set_opt1_lambda_add (code, clo); - return (true); - } - if (!is_safe_closure (clo)) - set_optimize_op (code, hop + ((one_form) ? OP_CLOSURE_S_O : OP_CLOSURE_S)); - else if (!is_null (cdr (body))) - set_safe_optimize_op (code, hop + OP_SAFE_CLOSURE_S); - else if (is_fxable (sc, car (body))) - fxify_closure_s (sc, clo, 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 - */ - set_is_unknopt (code); - set_opt1_lambda_add (code, clo); - return (true); -} + case OP_SAFE_CLOSURE_PA: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 2)) {op_unknown_np(sc); goto EVAL;} + 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; -static bool -op_unknown_s (s7_scheme* sc) { - const s7_pointer code= sc->code, func= sc->last_function; + case OP_SAFE_CLOSURE_PP: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 2)) {op_unknown_np(sc); goto EVAL;} + 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; - if (!func) unbound_variable_error_nr (sc, car (sc->code)); - if (SHOW_EVAL_OPS) - fprintf (stderr, " %s %s\n", __func__, display_truncated (func)); - if ((S7_DEBUGGING) && (!is_normal_symbol (cadr (code)))) - fprintf (stderr, "%s[%d]: not a symbol: %s\n", __func__, __LINE__, - display (code)); - if ((!is_any_macro (func)) && /* if func is a macro, its argument can be - unbound legitimately */ - (!is_bound_symbol (sc, cadr (code)))) - return (unknown_unknown ( - sc, sc->code, - (is_normal_symbol (cadr (sc->code))) ? OP_CLEAR_OPTS : OP_S_G)); - if ((is_unknopt (code)) && (!is_closure (func))) - return (fixup_unknown_op (sc, code, func, OP_S_G)); - - switch (type (func)) { - case T_C_FUNCTION: - if (!c_function_is_aritable (func, 1)) break; - case T_C_RST_NO_REQ_FUNCTION: - set_class_and_fn_proc (code, func); - if ((is_safe_procedure (func)) || (c_function_call (func) == g_values)) { - 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); - - case T_CLOSURE: - if ((!has_methods (func)) && (closure_arity_to_int (sc, func) == 1)) - return (op_unknown_closure_s (sc, func, code)); - break; - - case T_CLOSURE_STAR: - if (fxify_closure_star_g (sc, func, code)) return (true); - break; - - case T_GOTO: - fx_annotate_arg (sc, cdr (code), sc->curlet); - set_opt3_arglen (cdr (code), 1); - return (fixup_unknown_op (sc, code, func, OP_IMPLICIT_GOTO_A)); - - case T_INT_VECTOR: - case T_FLOAT_VECTOR: - case T_VECTOR: - case T_BYTE_VECTOR: - case T_COMPLEX_VECTOR: - fx_annotate_arg (sc, cdr (code), sc->curlet); - return (fixup_unknown_op (sc, code, func, OP_IMPLICIT_VECTOR_REF_A)); - - case T_STRING: - fx_annotate_arg (sc, cdr (code), sc->curlet); - return (fixup_unknown_op (sc, code, func, OP_IMPLICIT_STRING_REF_A)); - - case T_PAIR: - fx_annotate_arg (sc, cdr (code), sc->curlet); - return (fixup_unknown_op (sc, code, func, OP_IMPLICIT_PAIR_REF_A)); - - case T_C_OBJECT: - if (s7_is_aritable (sc, func, 1)) { - fx_annotate_arg (sc, cdr (code), sc->curlet); - return (fixup_unknown_op (sc, code, func, OP_IMPLICIT_C_OBJECT_REF_A)); - } - break; - - case T_LET: - fx_annotate_arg (sc, cdr (code), sc->curlet); - return (fixup_unknown_op (sc, code, func, OP_IMPLICIT_LET_REF_A)); - - case T_HASH_TABLE: - fx_annotate_arg (sc, cdr (code), sc->curlet); - return (fixup_unknown_op (sc, code, func, OP_IMPLICIT_HASH_TABLE_REF_A)); - - case T_CONTINUATION: - fx_annotate_arg (sc, cdr (code), sc->curlet); - return (fixup_unknown_op (sc, code, func, OP_IMPLICIT_CONTINUATION_A)); - - case T_BACRO: - case T_MACRO: - return (fixup_unknown_op (sc, code, func, - fixup_macro_d (sc, OP_MACRO_D, func))); - case T_BACRO_STAR: - case T_MACRO_STAR: - return (fixup_unknown_op (sc, code, func, - fixup_macro_d (sc, OP_MACRO_STAR_D, func))); - - default: - break; - } - if ((is_symbol (car (code))) && (!is_slot (s7_t_slot (sc, car (code))))) - unbound_variable_error_nr (sc, car (code)); - return (fixup_unknown_op (sc, code, func, OP_S_G)); -} + case OP_ANY_CLOSURE_3P: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {op_unknown_np(sc); goto EVAL;} + 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; -static bool -op_unknown_a (s7_scheme* sc) { - const s7_pointer code= sc->code, func= sc->last_function; - if (!func) unbound_variable_error_nr (sc, car (sc->code)); - if (SHOW_EVAL_OPS) - fprintf (stderr, " %s %s\n", __func__, display_truncated (func)); - - switch (type (func)) { - case T_C_FUNCTION: - if (!c_function_is_aritable (func, 1)) break; - case T_C_RST_NO_REQ_FUNCTION: - clear_has_fx (code); - set_class_and_fn_proc (code, func); - if (is_safe_procedure (func)) { - 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 (func)) && (closure_arity_to_int (sc, func) == 1)) { - const s7_pointer body = closure_body (func); - const bool safe_case= is_safe_closure (func); - const int32_t hop= (is_immutable_and_stable (sc, car (code))) ? 1 : 0; - const bool one_form= is_null (cdr (body)); - - fxify_closure_a (sc, func, one_form, safe_case, hop, code, sc->curlet); - set_opt1_lambda_add (code, func); - return (true); - } - break; - - case T_CLOSURE_STAR: - if (fxify_closure_star_g (sc, func, code)) return (true); - break; - - case T_INT_VECTOR: - case T_FLOAT_VECTOR: - case T_VECTOR: - case T_BYTE_VECTOR: - case T_COMPLEX_VECTOR: - return (fixup_unknown_op (sc, code, func, OP_IMPLICIT_VECTOR_REF_A)); - - case T_STRING: - return (fixup_unknown_op (sc, code, func, OP_IMPLICIT_STRING_REF_A)); - case T_PAIR: - return (fixup_unknown_op (sc, code, func, OP_IMPLICIT_PAIR_REF_A)); - case T_C_OBJECT: - return (fixup_unknown_op (sc, code, func, OP_IMPLICIT_C_OBJECT_REF_A)); - case T_HASH_TABLE: - return (fixup_unknown_op (sc, code, func, OP_IMPLICIT_HASH_TABLE_REF_A)); - case T_GOTO: - return (fixup_unknown_op (sc, code, func, OP_IMPLICIT_GOTO_A)); - case T_CONTINUATION: - return (fixup_unknown_op (sc, code, func, OP_IMPLICIT_CONTINUATION_A)); - case T_BACRO: - case T_MACRO: - return (fixup_unknown_op (sc, code, func, - fixup_macro_d (sc, OP_MACRO_D, func))); - case T_BACRO_STAR: - case T_MACRO_STAR: - return (fixup_unknown_op (sc, code, func, - fixup_macro_d (sc, OP_MACRO_STAR_D, func))); - - case T_LET: { - const s7_pointer arg1= cadr (code); - if ((is_quoted_symbol (sc, arg1)) || (is_symbol_and_keyword (arg1))) { - s7_pointer sym= (is_pair (arg1)) ? cadr (arg1) : arg1; - if (is_keyword (sym)) sym= keyword_symbol (sym); - set_opt3_con (code, sym); - return (fixup_unknown_op (sc, code, func, OP_IMPLICIT_LET_REF_C)); - } - return (fixup_unknown_op ( - sc, code, func, OP_IMPLICIT_LET_REF_A)); /* "A" might be a symbol */ - } + case OP_ANY_CLOSURE_4P: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 4)) {op_unknown_np(sc); goto EVAL;} + 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; - default: - break; - } - if ((is_symbol (car (code))) && (!is_bound_symbol (sc, car (code)))) - unbound_variable_error_nr (sc, car (code)); - return ( - fixup_unknown_op (sc, code, func, OP_S_A)); /* closure with methods etc */ -} + 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; -static bool -op_unknown_gg ( - s7_scheme* sc) /* we assume in eval that this always returns true */ -{ - bool s1, s2; - const s7_pointer code= sc->code, func= sc->last_function; - if (!func) unbound_variable_error_nr (sc, car (sc->code)); - if (SHOW_EVAL_OPS) - fprintf (stderr, " %s %s\n", __func__, display_truncated (func)); - - s1= is_normal_symbol (cadr (code)); - if ((s1) && (!is_bound_symbol (sc, cadr (code)))) - return (unknown_unknown (sc, sc->code, OP_CLEAR_OPTS)); - s2= is_normal_symbol (caddr (code)); - if ((s2) && (!is_bound_symbol (sc, caddr (code)))) - return (unknown_unknown (sc, sc->code, OP_CLEAR_OPTS)); - - switch (type (func)) { - case T_C_FUNCTION: - if (!c_function_is_aritable (func, 2)) break; - case T_C_RST_NO_REQ_FUNCTION: - if (is_safe_procedure (func)) { - if (s1) { - set_optimize_op (code, (s2) ? OP_SAFE_C_SS : OP_SAFE_C_SC); - if (s2) set_opt1_sym (cdr (code), caddr (code)); - else set_opt1_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 (func)) ? OP_CL_NA : OP_C_NA); - fx_annotate_args (sc, cdr (code), sc->curlet); - } - set_opt3_arglen (cdr (code), 2); - set_class_and_fn_proc (code, func); - return (true); - - case T_CLOSURE: - if (has_methods (func)) break; - if (closure_arity_to_int (sc, func) == 2) { - const s7_pointer body = closure_body (func); - const bool safe_case= is_safe_closure (func); - const int32_t hop= (is_immutable_and_stable (sc, car (code))) ? 1 : 0; - const bool one_form= is_null (cdr (body)); - - 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_pars (func)), - cadr (closure_pars (func)), NULL, false); - set_safe_optimize_op (code, hop + OP_SAFE_CLOSURE_SS_A); - set_closure_one_form_fx_arg (func); - } - } - 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), 2); - 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_add (code, func); - return (true); - } - break; - - case T_CLOSURE_STAR: - if ((closure_star_arity_to_int (sc, func) != 0) && - (closure_star_arity_to_int (sc, func) != 1)) { - fx_annotate_args (sc, cdr (code), sc->curlet); - if (!has_methods (func)) { - fixup_closure_star_aa ( - sc, func, code, (is_immutable_and_stable (sc, car (code))) ? 1 : 0); - set_opt1_lambda_add (code, func); - } - 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: - case T_COMPLEX_VECTOR: - set_opt3_arglen (cdr (code), 2); - fx_annotate_args (sc, cdr (code), sc->curlet); - if ((!is_pair (func)) && (vector_rank (func) != 2)) - return (fixup_unknown_op (sc, code, func, OP_S_AA)); - return (fixup_unknown_op (sc, code, func, - (is_pair (func)) ? OP_IMPLICIT_PAIR_REF_AA - : OP_IMPLICIT_VECTOR_REF_AA)); - - case T_HASH_TABLE: - fx_annotate_args (sc, cdr (code), sc->curlet); - return (fixup_unknown_op (sc, code, func, OP_IMPLICIT_HASH_TABLE_REF_AA)); - - case T_BACRO: - case T_MACRO: - return (fixup_unknown_op (sc, code, func, - fixup_macro_d (sc, OP_MACRO_D, func))); - case T_BACRO_STAR: - case T_MACRO_STAR: - return (fixup_unknown_op (sc, code, func, - fixup_macro_d (sc, OP_MACRO_STAR_D, func))); - - default: - break; - } - if ((is_symbol (car (code))) && (!is_slot (s7_t_slot (sc, car (code))))) - unbound_variable_error_nr (sc, car (code)); - fx_annotate_args (sc, cdr (code), sc->curlet); - return (fixup_unknown_op (sc, code, func, OP_S_AA)); -} + case OP_CLOSURE_SS: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 2)) {op_unknown_gg(sc); goto EVAL;} /* op_unknown_gg always returns true */ + case HOP_CLOSURE_SS: op_closure_ss(sc); goto EVAL; -static bool -op_unknown_ns ( - s7_scheme* sc) /* we assume in eval that this always returns true */ -{ - const s7_pointer code= sc->code, func= sc->last_function; - const int32_t num_args= opt3_arglen (cdr (code)); + case OP_CLOSURE_SS_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 2)) {op_unknown_gg(sc); goto EVAL;} + case HOP_CLOSURE_SS_O: op_closure_ss_o(sc); goto EVAL; - if (!func) unbound_variable_error_nr (sc, car (sc->code)); - if (SHOW_EVAL_OPS) - fprintf (stderr, " %s %s\n", __func__, display_truncated (func)); - - for (s7_pointer arg= cdr (code); is_pair (arg); arg= cdr (arg)) - if (!is_bound_symbol (sc, car (arg))) - unbound_variable_error_nr (sc, car (arg)); - - switch (type (func)) { - case T_C_FUNCTION: - if (!c_function_is_aritable (func, num_args)) break; - case T_C_RST_NO_REQ_FUNCTION: - if (is_safe_procedure (func)) { - 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 (func)) ? OP_CL_NA : OP_C_NA); - fx_annotate_args (sc, cdr (code), sc->curlet); - } - set_class_and_fn_proc (code, func); - return (true); - - case T_CLOSURE: - if ((!has_methods (func)) && - (closure_arity_to_int (sc, func) == num_args)) { - const int32_t hop= (is_immutable_and_stable (sc, car (code))) ? 1 : 0; - const bool one_form = is_null (cdr (closure_body (func))); - const bool safe_case= is_safe_closure (func); - fx_annotate_args (sc, cdr (code), sc->curlet); - if (num_args == 3) - return (fixup_unknown_op ( - sc, code, func, - hop + ((safe_case) - ? OP_SAFE_CLOSURE_3S - : ((one_form) ? OP_CLOSURE_3S_O : OP_CLOSURE_3S)))); - if (num_args == 4) - return (fixup_unknown_op ( - sc, code, func, - hop + ((safe_case) - ? OP_SAFE_CLOSURE_NS - : ((one_form) ? OP_CLOSURE_4S_O : OP_CLOSURE_4S)))); - return (fixup_unknown_op ( - sc, code, func, - hop + ((safe_case) - ? OP_SAFE_CLOSURE_NS - : ((num_args == 5) ? OP_CLOSURE_5S : OP_CLOSURE_NS)))); - } - break; - - case T_CLOSURE_STAR: - if ((!has_methods (func)) && - ((closure_star_arity_to_int (sc, func) < 0) || - ((closure_star_arity_to_int (sc, func) * 2) >= num_args))) { - const int32_t hop= (is_immutable_and_stable (sc, car (code))) ? 1 : 0; - fx_annotate_args (sc, cdr (code), sc->curlet); - if ((is_safe_closure (func)) && (num_args == 3) && - (closure_star_arity_to_int (sc, func) == 3)) - return (fixup_unknown_op (sc, code, func, OP_SAFE_CLOSURE_STAR_3A)); - return (fixup_unknown_op (sc, code, func, - hop + ((is_safe_closure (func)) - ? OP_SAFE_CLOSURE_STAR_NA - : OP_CLOSURE_STAR_NA))); - } - break; - - case T_BACRO: - case T_MACRO: - return (fixup_unknown_op (sc, code, func, - fixup_macro_d (sc, OP_MACRO_D, func))); - case T_BACRO_STAR: - case T_MACRO_STAR: - return (fixup_unknown_op (sc, code, func, - fixup_macro_d (sc, OP_MACRO_STAR_D, func))); - - /* PERHAPS: vector, but need op_implicit_vector_ns? */ - default: - break; - } - return (unknown_unknown (sc, sc->code, OP_CLEAR_OPTS)); -} + case OP_SAFE_CLOSURE_SS: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 2)) {op_unknown_gg(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_SS: op_safe_closure_ss(sc); goto EVAL; -static bool -op_unknown_aa ( - s7_scheme* sc) /* we assume in eval that this always returns true */ -{ - const s7_pointer code= sc->code, func= sc->last_function, - head= car (sc->code); + case OP_SAFE_CLOSURE_SS_O: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 2)) {op_unknown_gg(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_SS_O: op_safe_closure_ss_o(sc); goto EVAL; - if (!func) unbound_variable_error_nr (sc, head); - if (SHOW_EVAL_OPS) - fprintf (stderr, " %s %s\n", __func__, display_truncated (func)); - - switch (type (func)) { - case T_C_FUNCTION: - if (!c_function_is_aritable (func, 2)) break; - case T_C_RST_NO_REQ_FUNCTION: - if (is_safe_procedure ( - func)) /* why is this different from unknown_a and unknown_na? */ - { - 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 (func)) ? OP_CL_NA : OP_C_NA); - set_class_and_fn_proc (code, func); - return (true); - - case T_CLOSURE: - if ((!has_methods (func)) && (closure_arity_to_int (sc, func) == 2)) { - const s7_pointer body = closure_body (func); - const bool safe_case= is_safe_closure (func); - const int32_t hop = (is_immutable_and_stable (sc, head)) ? 1 : 0; - const bool 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 (func); - } - if ((is_fx_treeable (cdr (code))) && (curlet_has_slots (sc))) - fx_curlet_tree (sc, cdr (code)); - set_opt1_lambda_add (code, func); - return (true); - } - break; - - case T_CLOSURE_STAR: - if (!has_methods (func)) { - fixup_closure_star_aa (sc, func, code, - (is_immutable_and_stable (sc, head)) ? 1 : 0); - set_opt1_lambda_add (code, func); - } - 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_COMPLEX_VECTOR: - if (vector_rank (func) != 2) - return (fixup_unknown_op (sc, code, func, OP_S_AA)); - return (fixup_unknown_op (sc, code, func, OP_IMPLICIT_VECTOR_REF_AA)); - - case T_PAIR: - return (fixup_unknown_op (sc, code, func, OP_IMPLICIT_PAIR_REF_AA)); - case T_HASH_TABLE: - return (fixup_unknown_op (sc, code, func, OP_IMPLICIT_HASH_TABLE_REF_AA)); - case T_BACRO: - case T_MACRO: - return (fixup_unknown_op (sc, code, func, - fixup_macro_d (sc, OP_MACRO_D, func))); - case T_BACRO_STAR: - case T_MACRO_STAR: - return (fixup_unknown_op (sc, code, func, - fixup_macro_d (sc, OP_MACRO_STAR_D, func))); - - default: - break; - } - if ((is_symbol (head)) && (!is_bound_symbol (sc, head))) - unbound_variable_error_nr (sc, head); - return (fixup_unknown_op (sc, code, func, OP_S_AA)); -} + case OP_SAFE_CLOSURE_SS_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 2)) {op_unknown_gg(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_SS_A: sc->value = op_safe_closure_ss_a(sc, sc->code); continue; -static bool -is_normal_happy_symbol (s7_scheme* sc, s7_pointer sym) { - if (!is_normal_symbol (sym)) return (false); - if (!is_bound_symbol (sc, sym)) unbound_variable_error_nr (sc, sym); - return (true); -} + case OP_CLOSURE_3S: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {op_unknown_ns(sc); goto EVAL;} + case HOP_CLOSURE_3S: op_closure_3s(sc); goto EVAL; /* "fine" here means changing func (as arg) does not constantly call op_unknown_ns */ -static bool -op_unknown_na ( - s7_scheme* sc) /* we assume in eval that this always returns true */ -{ - const s7_pointer code= sc->code, func= sc->last_function; - const int32_t num_args= (is_pair (cdr (code))) ? opt3_arglen (cdr (code)) : 0; + case OP_CLOSURE_3S_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 3)) {op_unknown_ns(sc); goto EVAL;} + case HOP_CLOSURE_3S_O: op_closure_3s_o(sc); goto EVAL; - if (!func) unbound_variable_error_nr (sc, car (sc->code)); - if (SHOW_EVAL_OPS) - fprintf (stderr, " %s[%d]: %s %s\n", __func__, __LINE__, - display_truncated (func), display_truncated (sc->code)); - if (num_args == 0) - return (fixup_unknown_op ( - sc, code, func, OP_S)); /* via op_closure*-fx where original had 0 args, - safe case -> op_safe_closure*_0 */ - - switch (type (func)) { - case T_C_FUNCTION: - if (!c_function_is_aritable (func, num_args)) break; - case T_C_RST_NO_REQ_FUNCTION: - if (is_safe_procedure (func)) { - if (num_args == 3) { - int32_t pairs= 0, symbols= 0, - quotes= 0; /* specialize aaa->ssc etc, this makes less - difference than I expected */ - for (s7_pointer p= cdr (code); is_pair (p); p= cdr (p)) { - const s7_pointer arg= car (p); - if (is_normal_happy_symbol (sc, arg)) symbols++; - else if (is_pair (arg)) { - pairs++; - if (is_proper_quote (sc, arg)) quotes++; - } - } - if (optimize_safe_c_func_three_args (sc, code, func, 0 /* hop */, pairs, - symbols, quotes, - sc->curlet) == opt_ok) - 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 (func)) ? OP_CL_NA : OP_C_NA); - fx_annotate_args (sc, cdr (code), sc->curlet); - set_class_and_fn_proc (code, func); - return (true); - - case T_CLOSURE: - if ((!has_methods (func)) && - (closure_arity_to_int (sc, func) == num_args)) { - const int32_t hop= (is_immutable_and_stable (sc, car (code))) ? 1 : 0; - fx_annotate_args (sc, cdr (code), sc->curlet); - if ((is_fx_treeable (cdr (code))) && (curlet_has_slots (sc))) - fx_curlet_tree (sc, cdr (code)); - if (is_safe_closure (func)) { - 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 - set_safe_optimize_op (code, hop + (((!is_pair (caddr (code))) && - (!is_pair (cadddr (code)))) - ? OP_SAFE_CLOSURE_AGG - : 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 - set_safe_optimize_op ( - code, hop + ((is_normal_happy_symbol (sc, cadddr (code))) - ? OP_CLOSURE_AAS - : OP_CLOSURE_3A)); - set_opt1_lambda_add (code, func); - return (true); - } - if (is_symbol (closure_pars (func))) { - optimize_closure_sym (sc, code, func, 0, num_args, sc->curlet); - if (optimize_op (code) == OP_ANY_CLOSURE_SYM) return (true); - } - break; - - case T_CLOSURE_STAR: - if ((!has_methods (func)) && - ((closure_star_arity_to_int (sc, func) < 0) || - ((closure_star_arity_to_int (sc, func) * 2) >= num_args))) { - const int32_t hop= (is_immutable_and_stable (sc, car (code))) ? 1 : 0; - if (num_args > 0) { - set_opt3_arglen (cdr (code), num_args); - fx_annotate_args (sc, cdr (code), sc->curlet); - if ((is_fx_treeable (cdr (code))) && (curlet_has_slots (sc))) - fx_curlet_tree (sc, cdr (code)); - } - if (is_safe_closure (func)) switch (num_args) { - case 0: - return (fixup_unknown_op (sc, code, func, - hop + OP_SAFE_CLOSURE_STAR_NA_0)); - case 1: - return (fixup_unknown_op (sc, code, func, - hop + OP_SAFE_CLOSURE_STAR_NA_1)); - case 2: - return (fixup_unknown_op (sc, code, func, - hop + OP_SAFE_CLOSURE_STAR_NA_2)); - case 3: - if (closure_star_arity_to_int (sc, func) == 3) - return (fixup_unknown_op (sc, code, func, OP_SAFE_CLOSURE_STAR_3A)); - default: - return ( - fixup_unknown_op (sc, code, func, hop + OP_SAFE_CLOSURE_STAR_NA)); - } - return (fixup_unknown_op (sc, code, func, hop + OP_CLOSURE_STAR_NA)); - } - break; - - case T_BACRO: - case T_MACRO: - return (fixup_unknown_op (sc, code, func, - fixup_macro_d (sc, OP_MACRO_D, func))); - case T_BACRO_STAR: - case T_MACRO_STAR: - return (fixup_unknown_op (sc, code, func, - fixup_macro_d (sc, OP_MACRO_STAR_D, func))); - /* implicit vector doesn't happen */ - - default: - break; - } - /* closure happens if wrong-number-of-args passed -- probably no need for - * op_s_na */ - /* PERHAPS: vector */ - return (unknown_unknown (sc, sc->code, OP_CLEAR_OPTS)); -} + case OP_CLOSURE_4S: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 4)) {op_unknown_ns(sc); goto EVAL;} + case HOP_CLOSURE_4S: op_closure_4s(sc); goto EVAL; -static bool -op_unknown_np ( - s7_scheme* sc) /* we assume in eval that this always returns true */ -{ - const s7_pointer code= sc->code, func= sc->last_function, - head = car (sc->code); - const int32_t num_args= (is_pair (cdr (code))) ? opt3_arglen (cdr (code)) : 0; + case OP_CLOSURE_4S_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 4)) {op_unknown_ns(sc); goto EVAL;} + case HOP_CLOSURE_4S_O: op_closure_4s_o(sc); goto EVAL; - if (!func) unbound_variable_error_nr (sc, head); - if (SHOW_EVAL_OPS) - fprintf (stderr, " %s[%d]: %s %s %s\n", __func__, __LINE__, - display_truncated (func), type_name (sc, func, no_article), - display_truncated (sc->code)); - switch (type (func)) { - case T_C_FUNCTION: - if (!c_function_is_aritable (func, num_args)) break; - case T_C_RST_NO_REQ_FUNCTION: - if (num_args == 1) - set_any_c_np (sc, func, code, sc->curlet, num_args, - (is_safe_procedure (func)) ? OP_SAFE_C_P : OP_C_P); - else if ((num_args == 2) && (is_safe_procedure (func))) { - set_any_c_np (sc, func, code, sc->curlet, 2, OP_SAFE_C_PP); - opt_sp_1 (sc, c_function_call (func), code); - } - else if ((num_args == 3) && - ((is_safe_procedure (func)) || - ((is_semisafe (func)) && - (((head != sc->assoc_symbol) && (head != sc->member_symbol)) || - (unsafe_is_safe (sc, cadddr (code), sc->curlet)))))) - set_any_c_np (sc, func, code, sc->curlet, 3, OP_SAFE_C_3P); - else set_any_c_np (sc, func, code, sc->curlet, num_args, OP_ANY_C_NP); - return (true); - - case T_CLOSURE: - if ((!has_methods (func)) && (closure_arity_to_int (sc, func) == - num_args)) /* if values clo as arg, we need to - know how many values etc */ - { - const int32_t hop = (is_immutable_and_stable (sc, head)) ? 1 : 0; - const bool safe_case= is_safe_closure (func); - switch (num_args) { - case 1: - if (safe_case) { - const s7_pointer body= closure_body (func); - 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_add (code, func); /* added 8-Jun-22 */ - set_opt3_arglen (cdr (code), 1); - 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 + ((safe_case) ? 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 + ((safe_case) ? OP_SAFE_CLOSURE_PA : OP_CLOSURE_PA)); - } - else - set_optimize_op ( - code, hop + ((safe_case) ? OP_SAFE_CLOSURE_PP : OP_CLOSURE_PP)); - set_opt1_lambda_add (code, func); /* added 8-Jun-22 */ - set_opt3_arglen (cdr (code), 2); /* for later op_unknown_np */ - set_unsafely_optimized (code); - break; - - case 3: - set_any_closure_np (sc, func, code, sc->curlet, 3, - hop + OP_ANY_CLOSURE_3P); - break; - case 4: - set_any_closure_np (sc, func, code, sc->curlet, 4, - hop + OP_ANY_CLOSURE_4P); - break; - default: - set_any_closure_np (sc, func, code, sc->curlet, num_args, - hop + OP_ANY_CLOSURE_NP); - break; - } - return (true); - } - break; - - /* PERHAPS: T_CLOSURE_STAR? */ - case T_BACRO: - case T_MACRO: - return (fixup_unknown_op (sc, code, func, - fixup_macro_d (sc, OP_MACRO_D, func))); - case T_BACRO_STAR: - case T_MACRO_STAR: - return (fixup_unknown_op (sc, code, func, - fixup_macro_d (sc, OP_MACRO_STAR_D, func))); - } - return (unknown_unknown (sc, sc->code, OP_CLEAR_OPTS)); -} + case OP_CLOSURE_5S: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 5)) {op_unknown_ns(sc); goto EVAL;} + case HOP_CLOSURE_5S: op_closure_5s(sc); goto EVAL; -static bool -unknown_any (s7_scheme* sc, s7_pointer func, s7_pointer code) { - sc->last_function= func; - if (is_null (cdr (code))) return (op_unknown (sc)); - if ((is_null (cddr (code))) && (is_normal_symbol (cadr (code)))) - return (op_unknown_s (sc)); - set_opt3_arglen (cdr (code), proper_list_length (cdr (code))); - return (op_unknown_np (sc)); -} + case OP_CLOSURE_SC: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 2)) {op_unknown_gg(sc); goto EVAL;} + case HOP_CLOSURE_SC: op_closure_sc(sc); goto EVAL; -/* ---------------- eval type checkers ---------------- */ + case OP_CLOSURE_SC_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 2)) {op_unknown_gg(sc); goto EVAL;} + case HOP_CLOSURE_SC_O: op_closure_sc_o(sc); goto EVAL; -#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 + case OP_SAFE_CLOSURE_SC: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 2)) {op_unknown_gg(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_SC: op_safe_closure_sc(sc); goto EVAL; -#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)))) + case OP_SAFE_CLOSURE_SC_O: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 2)) {op_unknown_gg(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_SC_O: op_safe_closure_sc_o(sc); goto EVAL; -static bool -c_function_is_ok_cadr_caddr (s7_scheme* sc, s7_pointer p) { - return ((c_function_is_ok (sc, p)) && (h_c_function_is_ok (sc, cadr (p))) && - (h_c_function_is_ok (sc, caddr (p)))); -} + case OP_CLOSURE_AA: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 2)) {op_unknown_aa(sc); goto EVAL;} + case HOP_CLOSURE_AA: op_closure_aa(sc); goto EVAL; -static bool -c_function_is_ok_cadr_cadadr (s7_scheme* sc, s7_pointer p) { - return ((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) */ -} + case OP_CLOSURE_AA_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 2)) {op_unknown_aa(sc); goto EVAL;} + case HOP_CLOSURE_AA_O: inline_op_closure_aa_o(sc); goto EVAL; -static bool -c_function_is_ok_cadr_caddadr (s7_scheme* sc, s7_pointer p) { - return ((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) */ -} + case OP_SAFE_CLOSURE_AA: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 2)) {op_unknown_aa(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_AA: op_safe_closure_aa(sc); goto EVAL; -/* 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 - */ + case OP_SAFE_CLOSURE_AA_O: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 2)) {op_unknown_aa(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_AA_O: op_safe_closure_aa_o(sc); goto EVAL; -static /* inline */ bool -closure_is_ok_1 (s7_scheme* sc, s7_pointer code, uint16_t type, int32_t args) { - const s7_pointer clo= lookup_unexamined (sc, car (code)); - if ((clo == opt1_lambda_unchecked (code)) || - ((clo) && /* this fixup check does save time (e.g. cb) */ - (low_type_bits (clo) == type) && - ((closure_arity (clo) == args) || - (closure_arity_to_int (sc, clo) == - args)) && /* 3 type bits to replace this but not hit enough to warrant - them */ - (set_opt1_lambda (code, clo)))) - return (true); - sc->last_function= clo; - return (false); -} - -static /* inline */ bool -closure_is_fine_1 (s7_scheme* sc, s7_pointer code, uint16_t type, - int32_t args) { - const s7_pointer clo= lookup_unexamined (sc, car (code)); - if ((clo == opt1_lambda_unchecked (code)) || - ((clo) && - ((low_type_bits (clo) & (TYPE_MASK | T_SAFE_CLOSURE)) == type) && - ((closure_arity (clo) == args) || - (closure_arity_to_int (sc, clo) == args)) && - (set_opt1_lambda (code, clo)))) - return (true); - sc->last_function= clo; - return (false); -} + case OP_SAFE_CLOSURE_AA_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 2)) {op_unknown_aa(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_AA_A: sc->value = fx_safe_closure_aa_a(sc, sc->code); continue; -static bool -closure_np_is_ok_1 (s7_scheme* sc, s7_pointer code) { - const s7_pointer clo= lookup_unexamined (sc, car (code)); - if ((clo == opt1_lambda_unchecked (code)) || - ((clo) && (is_closure (clo)) && (set_opt1_lambda (code, clo)))) - return (true); - sc->last_function= clo; - return (false); -} + case OP_SAFE_CLOSURE_SSA: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {op_unknown_na(sc); goto EVAL;} /* op_unknown_na always return true */ + case HOP_SAFE_CLOSURE_SSA: op_safe_closure_ssa(sc); goto EVAL; -/* 20-Jun-24 calls=closure_is_*, misses=symbol_ctr != 1 - s7test: calls: 974814, misses: 550785 - full: calls: 11433106, misses: 6406461 - tlet: calls: 3600032, misses: 1900012 - tlamb: calls: 33000005, misses: 11999999 - tset: calls: 1329500, misses: 998 - lt: calls: 1374000, misses: 232936 - tmat: calls: 222206, misses: 0 (tobj, tsort, tform, tread, tfft, thash, - etc) so symbol_ctr==1 is valuable - */ + case OP_SAFE_CLOSURE_SAA: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {op_unknown_na(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_SAA: op_safe_closure_saa(sc); goto EVAL; -#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) \ - ((symbol_ctr (car (Code)) == 1) || (closure_np_is_ok_1 (Sc, Code))) -#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= 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) { - const s7_pointer val= lookup_unexamined (sc, car (code)); - if ((val == opt1_lambda_unchecked (code)) || - ((val) && - ((low_type_bits (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); -} + case OP_SAFE_CLOSURE_AGG: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {op_unknown_na(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_AGG: op_safe_closure_agg(sc); goto EVAL; -/* closure_is_fine: */ -#define FINE_UNSAFE_CLOSURE (T_CLOSURE) -#define FINE_SAFE_CLOSURE (T_CLOSURE | T_SAFE_CLOSURE) + case OP_SAFE_CLOSURE_3A: if (!closure_is_ok(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {op_unknown_na(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_3A: op_safe_closure_3a(sc); goto EVAL; -/* closure_star_is_fine: */ -#define FINE_UNSAFE_CLOSURE_STAR (T_CLOSURE_STAR) -#define FINE_SAFE_CLOSURE_STAR (T_CLOSURE_STAR | T_SAFE_CLOSURE) + case OP_SAFE_CLOSURE_NS: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, opt3_arglen(cdr(sc->code)))) {op_unknown_ns(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_NS: op_safe_closure_ns(sc); goto EVAL; -/* 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 */ - -static no_return void -eval_apply_error_nr (s7_scheme* sc) { - error_nr (sc, sc->syntax_error_symbol, /* apply_error_nr expanded */ - set_elist_4 (sc, - wrap_string (sc, "attempt to apply ~A ~$ in ~$?", 29), - ((is_symbol_and_keyword (sc->code)) - ? wrap_string (sc, "a keyword", 9) - : type_name_string (sc, sc->code)), - sc->code, cons (sc, sc->code, sc->args))); -} + case OP_SAFE_CLOSURE_NA: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, opt3_arglen(cdr(sc->code)))) {op_unknown_na(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_NA: op_safe_closure_na(sc); goto EVAL; -/* ---------------- 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 %s %s\n", __LINE__, - bold_text, op_names[first_op], unbold_text, - display_truncated (sc->code), - display_truncated (sc->args))); - sc->cur_op= first_op; - goto TOP_NO_POP; + case OP_SAFE_CLOSURE_3S: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {op_unknown_ns(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_3S: op_safe_closure_3s(sc); goto EVAL; - while (true) /* "continue" in this procedure refers to this loop */ - { - pop_stack (sc); - goto TOP_NO_POP; - - BEGIN: - if (is_pair (cdr (sc->code))) { - set_current_code (sc, sc->code); - push_stack_no_args (sc, sc->begin_op, cdr (sc->code)); - } - sc->code= car (sc->code); - - EVAL: - sc->cur_op= optimize_op (sc->code); /* sc->code can be anything, optimize_op - examines a type field (opt_bits) */ - - TOP_NO_POP: - if (SHOW_EVAL_OPS) - safe_print (fprintf (stderr, " %s%s%s (%d), code: %s\n", bold_text, - op_names[sc->cur_op], unbold_text, - (int) (sc->cur_op), display_truncated (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 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= fn_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_s (sc)) goto EVAL; - continue; - } /* checking symbol_ctr(car(sc->code)) == 1 just slows us down */ - case HOP_SAFE_C_S: - inline_op_safe_c_s (sc); - continue; + case OP_SAFE_CLOSURE_3S_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 3)) {op_unknown_ns(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_3S_A: sc->value = op_safe_closure_3s_a(sc, sc->code); continue; - case OP_SAFE_C_SS: - if (!c_function_is_ok (sc, sc->code)) break; - case HOP_SAFE_C_SS: - inline_op_safe_c_ss (sc); - continue; + case OP_CLOSURE_NS: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, opt3_arglen(cdr(sc->code)))) {op_unknown_ns(sc); goto EVAL;} + case HOP_CLOSURE_NS: op_closure_ns(sc); goto EVAL; - 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_CLOSURE_ASS: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {op_unknown_na(sc); goto EVAL;} + case HOP_CLOSURE_ASS: op_closure_ass(sc); goto EVAL; - 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_CLOSURE_AAS: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {op_unknown_na(sc); goto EVAL;} + case HOP_CLOSURE_AAS: op_closure_aas(sc); goto EVAL; - 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)) { - op_unknown_np (sc); - goto EVAL; - } - 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)) { - op_unknown_np (sc); - goto EVAL; - } - case HOP_ANY_C_NP: - if (op_any_c_np (sc)) goto EVAL; - continue; - case OP_ANY_C_NP_1: - if (inline_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: - if (op_any_c_np_mv (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_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_cadr (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_cadr (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_cadr (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_caddr (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_cadr (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_caddr (sc, sc->code)) break; - case HOP_SAFE_C_S_opAAq: - sc->value= fx_c_s_opaaq (sc, sc->code); - continue; - - case OP_SAFE_C_AA: - if (!c_function_is_ok (sc, sc->code)) { - op_unknown_aa (sc); - goto EVAL; - } /* op_unknown_aa always returns true */ - 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)) { - op_unknown_aa (sc); - goto EVAL; - } - case HOP_SAFE_C_SA: - sc->value= fx_c_sa (sc, sc->code); - continue; + case OP_CLOSURE_SAA: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {op_unknown_na(sc); goto EVAL;} + case HOP_CLOSURE_SAA: op_closure_saa(sc); goto EVAL; - case OP_SAFE_C_AS: - if (!c_function_is_ok (sc, sc->code)) { - op_unknown_aa (sc); - goto EVAL; - } - case HOP_SAFE_C_AS: - sc->value= fx_c_as (sc, sc->code); - continue; + case OP_CLOSURE_ASA: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {op_unknown_na(sc); goto EVAL;} + case HOP_CLOSURE_ASA: op_closure_asa(sc); goto EVAL; - case OP_SAFE_C_CA: - if (!c_function_is_ok (sc, sc->code)) { - op_unknown_aa (sc); - goto EVAL; - } - 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)) { - op_unknown_aa (sc); - goto EVAL; - } - 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_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_CLOSURE_SAS: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {op_unknown_na(sc); goto EVAL;} + case HOP_CLOSURE_SAS: op_closure_sas(sc); goto EVAL; - 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_CLOSURE_3A: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {op_unknown_na(sc); goto EVAL;} + case HOP_CLOSURE_3A: op_closure_3a(sc); goto EVAL; - 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_CLOSURE_4A: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 4)) {op_unknown_na(sc); goto EVAL;} + case HOP_CLOSURE_4A: op_closure_4a(sc); goto EVAL; - 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_CLOSURE_NA: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, opt3_arglen(cdr(sc->code)))) {op_unknown_na(sc); goto EVAL;} + case HOP_CLOSURE_NA: op_closure_na(sc); goto EVAL; - 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; /* lg cb (splits to not) */ - - 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; /* tlet sg (splits to not) */ - - 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; /* lg cb (splits to not etc) */ - - 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_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_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_CONS_SP_1: - sc->value= cons (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: - op_safe_c_ap (sc); - goto EVAL; - - case OP_SAFE_C_PA: - if (!c_function_is_ok (sc, sc->code)) break; - case HOP_SAFE_C_PA: - op_safe_c_pa (sc); - goto EVAL; - case OP_SAFE_C_PA_1: - op_safe_c_pa_1 (sc); - continue; - - 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; - /* mv case goes through opt_sp_1 to op_safe_c_sp_mv */ - - 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); - continue; - - 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); - continue; - - 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_ANY_CLOSURE_NP: if (!closure_np_is_ok(sc, sc->code)) {op_unknown_np(sc); goto EVAL;} + case HOP_ANY_CLOSURE_NP: op_any_closure_np(sc); goto EVAL; + case OP_ANY_CLOSURE_NP_1: + if (!inline_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_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_ANY_CLOSURE_SYM: if (!check_closure_sym(sc, 1)) break; /* (lambda args ...) */ + case HOP_ANY_CLOSURE_SYM: op_any_closure_sym(sc); goto BEGIN; + case OP_ANY_CLOSURE_A_SYM: if (!check_closure_sym(sc, 2)) break; /* (lambda (a . args) ...) */ + case HOP_ANY_CLOSURE_A_SYM: op_any_closure_a_sym(sc); goto BEGIN; - 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_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_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_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_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_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_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_CLOSURE_STAR_AA: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 2)) {op_unknown_aa(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_STAR_AA: op_safe_closure_star_aa(sc, sc->code); goto BEGIN; - 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_CLOSURE_STAR_AA_O: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 2)) {op_unknown_aa(sc); goto EVAL;} + 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_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_CLOSURE_STAR_3A: if (!closure_star_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE_STAR, 3)) {op_unknown_na(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_STAR_3A: if (op_safe_closure_star_3a(sc, sc->code)) goto EVAL; goto BEGIN; - 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_CLOSURE_STAR_NA: + if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, (is_pair(cdr(sc->code))) ? opt3_arglen(cdr(sc->code)) : 0)) + {op_unknown_na(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_STAR_NA: if (op_safe_closure_star_na(sc, sc->code)) goto EVAL; goto BEGIN; - 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_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_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: - inline_op_safe_c_s (sc); - continue; - - case OP_CL_SS: - if (!cl_function_is_ok (sc, sc->code)) break; - case HOP_CL_SS: - inline_op_safe_c_ss (sc); - continue; /* safe_c case has the code we want */ - - 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 + two 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_G); - 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_G); - 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_SS: - if (!c_function_is_ok (sc, sc->code)) break; - case HOP_C_SS: - op_c_ss (sc); - continue; - - case OP_C_SC: - if (!c_function_is_ok (sc, sc->code)) break; - case HOP_C_SC: - op_c_sc (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_AA: - if (!c_function_is_ok (sc, sc->code)) break; - case HOP_C_AA: - op_c_aa (sc); - continue; - - case OP_C_NC: - if (!c_function_is_ok (sc, sc->code)) break; - case HOP_C_NC: - op_c_nc (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: - inline_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: - op_call_with_exit (sc); - goto BEGIN; - case OP_CALL_CC: - op_call_cc (sc); - goto BEGIN; - case OP_CALL_WITH_EXIT_O: - op_call_with_exit_o (sc); - goto EVAL; - case OP_C_CATCH: - op_c_catch (sc); - goto BEGIN; - case OP_C_CATCH_ALL: - op_c_catch_all (sc); - goto BEGIN; - case OP_C_CATCH_ALL_O: - op_c_catch_all (sc); - goto EVAL; - case OP_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_F: - op_f (sc); - goto BEGIN; - case OP_F_A: - op_f_a (sc); - goto BEGIN; - case OP_F_AA: - op_f_aa (sc); - goto BEGIN; - case OP_F_NP: - op_f_np (sc); - goto EVAL; - case OP_F_NP_1: - if (op_f_np_1 (sc)) goto EVAL; - goto BEGIN; - - case OP_S: - op_s (sc); - goto APPLY; - case OP_S_G: - if (op_s_g (sc)) continue; - goto APPLY; - case OP_S_A: - if (op_x_a (sc, lookup_checked (sc, car (sc->code)))) continue; - goto APPLY; - case OP_A_A: - if (op_x_a (sc, fx_call (sc, sc->code))) continue; - goto APPLY; - case OP_S_AA: - if (op_x_aa (sc, lookup_checked (sc, car (sc->code)))) continue; - goto APPLY; - case OP_A_AA: - if (op_x_aa (sc, fx_call (sc, sc->code))) continue; - goto APPLY; - case OP_A_SC: - if (op_x_sc (sc, fx_call (sc, sc->code))) continue; - goto APPLY; - case OP_P_S: - push_stack_no_args_direct (sc, OP_P_S_1); - 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_ok (sc, sc->code, FINE_UNSAFE_CLOSURE, 0)) { - if (op_unknown (sc)) goto EVAL; - continue; - } - case HOP_THUNK: - op_thunk (sc); - goto EVAL; - - case OP_THUNK_O: - if (!closure_is_ok (sc, sc->code, OK_UNSAFE_CLOSURE_P, 0)) { - if (op_unknown (sc)) goto EVAL; - continue; - } - case HOP_THUNK_O: - op_thunk_o (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_ANY: - if (!closure_is_fine (sc, sc->code, FINE_SAFE_CLOSURE, 1)) - break; /* symbol as arglist */ - case HOP_SAFE_THUNK_ANY: - op_safe_thunk_any (sc); - goto EVAL; - - 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_s (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_s (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_s (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_s (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_s (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_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_S_TO_S: - if ((symbol_ctr (car (sc->code)) > 1) && (!closure_is_eq (sc))) { - if (op_unknown_s (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_s (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)) { - op_unknown_np (sc); - goto EVAL; - } - 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)) { - op_unknown_np (sc); - goto EVAL; - } - 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)) { - op_unknown_np (sc); - goto EVAL; - } - 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: - inline_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: - inline_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)) { - op_unknown_np (sc); - goto EVAL; - } - 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)) { - op_unknown_np (sc); - goto EVAL; - } - 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)) { - op_unknown_np (sc); - goto EVAL; - } - 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)) { - op_unknown_np (sc); - goto EVAL; - } - 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)) { - op_unknown_np (sc); - goto EVAL; - } - 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)) { - op_unknown_np (sc); - goto EVAL; - } - 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)) { - op_unknown_np (sc); - goto EVAL; - } - 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)) { - op_unknown_np (sc); - goto EVAL; - } - 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)) { - op_unknown_gg (sc); - goto EVAL; - } /* op_unknown_gg always returns true */ - 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)) { - op_unknown_gg (sc); - goto EVAL; - } - 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)) { - op_unknown_gg (sc); - goto EVAL; - } - 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)) { - op_unknown_gg (sc); - goto EVAL; - } - 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)) { - op_unknown_gg (sc); - goto EVAL; - } - 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)) { - op_unknown_ns (sc); - goto EVAL; - } - case HOP_CLOSURE_3S: - op_closure_3s (sc); - goto EVAL; /* "fine" here means changing func (as arg) does not constantly - call op_unknown_ns */ - - case OP_CLOSURE_3S_O: - if (!closure_is_ok (sc, sc->code, OK_UNSAFE_CLOSURE_P, 3)) { - op_unknown_ns (sc); - goto EVAL; - } - case HOP_CLOSURE_3S_O: - op_closure_3s_o (sc); - goto EVAL; - - case OP_CLOSURE_4S: - if (!closure_is_fine (sc, sc->code, FINE_UNSAFE_CLOSURE, 4)) { - op_unknown_ns (sc); - goto EVAL; - } - case HOP_CLOSURE_4S: - op_closure_4s (sc); - goto EVAL; - - case OP_CLOSURE_4S_O: - if (!closure_is_ok (sc, sc->code, OK_UNSAFE_CLOSURE_P, 4)) { - op_unknown_ns (sc); - goto EVAL; - } - case HOP_CLOSURE_4S_O: - op_closure_4s_o (sc); - goto EVAL; - - case OP_CLOSURE_5S: - if (!closure_is_fine (sc, sc->code, FINE_UNSAFE_CLOSURE, 5)) { - op_unknown_ns (sc); - goto EVAL; - } - case HOP_CLOSURE_5S: - op_closure_5s (sc); - goto EVAL; - - case OP_CLOSURE_SC: - if (!closure_is_ok (sc, sc->code, OK_UNSAFE_CLOSURE_M, 2)) { - op_unknown_gg (sc); - goto EVAL; - } - 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)) { - op_unknown_gg (sc); - goto EVAL; - } - 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)) { - op_unknown_gg (sc); - goto EVAL; - } - 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)) { - op_unknown_gg (sc); - goto EVAL; - } - 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)) { - op_unknown_aa (sc); - goto EVAL; - } - 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)) { - op_unknown_aa (sc); - goto EVAL; - } - case HOP_CLOSURE_AA_O: - inline_op_closure_aa_o (sc); - goto EVAL; - - case OP_SAFE_CLOSURE_AA: - if (!closure_is_ok (sc, sc->code, OK_SAFE_CLOSURE_M, 2)) { - op_unknown_aa (sc); - goto EVAL; - } - 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)) { - op_unknown_aa (sc); - goto EVAL; - } - 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)) { - op_unknown_aa (sc); - goto EVAL; - } - 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)) { - op_unknown_na (sc); - goto EVAL; - } /* op_unknown_na always return true */ - case HOP_SAFE_CLOSURE_SSA: - op_safe_closure_ssa (sc); - goto EVAL; - - case OP_SAFE_CLOSURE_SAA: - if (!closure_is_fine (sc, sc->code, FINE_SAFE_CLOSURE, 3)) { - op_unknown_na (sc); - goto EVAL; - } - case HOP_SAFE_CLOSURE_SAA: - op_safe_closure_saa (sc); - goto EVAL; - - case OP_SAFE_CLOSURE_AGG: - if (!closure_is_fine (sc, sc->code, FINE_SAFE_CLOSURE, 3)) { - op_unknown_na (sc); - goto EVAL; - } - case HOP_SAFE_CLOSURE_AGG: - op_safe_closure_agg (sc); - goto EVAL; - - case OP_SAFE_CLOSURE_3A: - if (!closure_is_ok (sc, sc->code, FINE_SAFE_CLOSURE, 3)) { - op_unknown_na (sc); - goto EVAL; - } - 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, - opt3_arglen (cdr (sc->code)))) { - op_unknown_ns (sc); - goto EVAL; - } - 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, - opt3_arglen (cdr (sc->code)))) { - op_unknown_na (sc); - goto EVAL; - } - 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)) { - op_unknown_ns (sc); - goto EVAL; - } - case HOP_SAFE_CLOSURE_3S: - op_safe_closure_3s (sc); - goto EVAL; - - case OP_SAFE_CLOSURE_3S_A: - if (!closure_is_ok (sc, sc->code, OK_SAFE_CLOSURE_A, 3)) { - op_unknown_ns (sc); - goto EVAL; - } - 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, - opt3_arglen (cdr (sc->code)))) { - op_unknown_ns (sc); - goto EVAL; - } - 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)) { - op_unknown_na (sc); - goto EVAL; - } - 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)) { - op_unknown_na (sc); - goto EVAL; - } - 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)) { - op_unknown_na (sc); - goto EVAL; - } - 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)) { - op_unknown_na (sc); - goto EVAL; - } - 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)) { - op_unknown_na (sc); - goto EVAL; - } - 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)) { - op_unknown_na (sc); - goto EVAL; - } - 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)) { - op_unknown_na (sc); - goto EVAL; - } - case HOP_CLOSURE_4A: - op_closure_4a (sc); - goto EVAL; - - case OP_CLOSURE_NA: - if (!closure_is_fine (sc, sc->code, FINE_UNSAFE_CLOSURE, - opt3_arglen (cdr (sc->code)))) { - op_unknown_na (sc); - goto EVAL; - } - case HOP_CLOSURE_NA: - op_closure_na (sc); - goto EVAL; - - case OP_ANY_CLOSURE_NP: - if (!closure_np_is_ok (sc, sc->code)) { - op_unknown_np (sc); - goto EVAL; - } - case HOP_ANY_CLOSURE_NP: - op_any_closure_np (sc); - goto EVAL; - case OP_ANY_CLOSURE_NP_1: - if (!inline_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_SYM: - if (!check_closure_sym (sc, 1)) break; /* (lambda args ...) */ - case HOP_ANY_CLOSURE_SYM: - op_any_closure_sym (sc); - goto BEGIN; - case OP_ANY_CLOSURE_A_SYM: - if (!check_closure_sym (sc, 2)) break; /* (lambda (a . args) ...) */ - case HOP_ANY_CLOSURE_A_SYM: - op_any_closure_a_sym (sc); - goto BEGIN; - - 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)) { - op_unknown_aa (sc); - goto EVAL; - } - 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)) { - op_unknown_aa (sc); - goto EVAL; - } - 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)) { - op_unknown_na (sc); - goto EVAL; - } - case HOP_SAFE_CLOSURE_STAR_3A: - if (op_safe_closure_star_3a (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))) ? opt3_arglen (cdr (sc->code)) : 0)) { - op_unknown_na (sc); - goto EVAL; - } - 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)) { - op_unknown_aa (sc); - goto EVAL; - } - 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)) { - op_unknown_aa (sc); - goto EVAL; - } - 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))) ? opt3_arglen (cdr (sc->code)) : 0)) { - op_unknown_na (sc); - goto EVAL; - } - case HOP_CLOSURE_STAR_NA: - if (op_closure_star_na (sc, sc->code)) goto EVAL; - goto BEGIN; - - /* these nine are ok */ - case OP_TC_CASE_LA: - if (op_tc_case_la (sc, sc->code, 1)) continue; - goto BEGIN; - case OP_TC_CASE_L2A: - if (op_tc_case_la (sc, sc->code, 2)) continue; - goto BEGIN; - case OP_TC_CASE_L3A: - if (op_tc_case_la (sc, sc->code, 3)) continue; - goto BEGIN; - case OP_TC_WHEN_LA: - sc->value= op_tc_when_la (sc, sc->code); - continue; - case OP_TC_WHEN_L2A: - sc->value= op_tc_when_l2a (sc, sc->code); - continue; - case OP_TC_WHEN_L3A: - sc->value= op_tc_when_l3a (sc, sc->code); - continue; - case OP_TC_IF_A_Z_LA: - if (op_tc_if_a_z_la (sc, sc->code)) continue; - goto EVAL; - case OP_TC_IF_A_Z_L2A: - if (op_tc_if_a_z_l2a (sc, sc->code)) continue; - goto EVAL; - case OP_TC_IF_A_Z_L3A: - if (op_tc_if_a_z_l3a (sc, sc->code)) continue; - goto EVAL; - - case OP_TC_IF_A_Z_IF_A_Z_LA: - if (op_tc_if_a_z_if_a_z_la (sc, sc->code, true)) continue; - goto EVAL; - case OP_TC_IF_A_Z_IF_A_LA_Z: - if (op_tc_if_a_z_if_a_z_la (sc, sc->code, false)) continue; - goto EVAL; - case OP_TC_AND_A_IF_A_LA_Z: - if (op_tc_if_a_z_if_a_z_la (sc, sc->code, false)) continue; - goto EVAL; - case OP_TC_AND_A_IF_A_Z_LA: - if (op_tc_if_a_z_if_a_z_la (sc, sc->code, true)) continue; - goto EVAL; - - case OP_TC_IF_A_Z_IF_A_Z_L2A: - if (op_tc_if_a_z_if_a_z_l2a (sc, sc->code)) continue; - goto EVAL; - case OP_TC_IF_A_Z_IF_A_L2A_Z: - if (op_tc_if_a_z_if_a_l2a_z (sc, sc->code)) continue; - goto EVAL; - - case OP_TC_IF_A_Z_IF_A_Z_L3A: - if (op_tc_if_a_z_if_a_z_l3a (sc, sc->code, true)) continue; - goto EVAL; - case OP_TC_IF_A_Z_IF_A_L3A_Z: - if (op_tc_if_a_z_if_a_z_l3a (sc, sc->code, false)) continue; - goto EVAL; - - case OP_TC_AND_A_OR_A_LA: - sc->value= op_tc_and_a_or_a_la (sc, sc->code); - continue; - case OP_TC_OR_A_AND_A_LA: - sc->value= op_tc_or_a_and_a_la (sc, sc->code); - continue; - case OP_TC_AND_A_OR_A_L2A: - sc->value= op_tc_and_a_or_a_l2a (sc, sc->code); - continue; - case OP_TC_OR_A_AND_A_L2A: - sc->value= op_tc_or_a_and_a_l2a (sc, sc->code); - continue; - case OP_TC_AND_A_OR_A_L3A: - sc->value= op_tc_and_a_or_a_l3a (sc, sc->code); - continue; - case OP_TC_OR_A_AND_A_L3A: - sc->value= op_tc_or_a_and_a_l3a (sc, sc->code); - continue; - case OP_TC_OR_A_AND_A_A_LA: - sc->value= op_tc_or_a_and_a_a_la (sc, sc->code); - continue; - case OP_TC_OR_A_AND_A_A_L3A: - sc->value= op_tc_or_a_and_a_a_l3a (sc, sc->code); - continue; - case OP_TC_AND_A_OR_A_A_LA: - sc->value= op_tc_and_a_or_a_a_la (sc, sc->code); - continue; - case OP_TC_OR_A_A_AND_A_A_LA: - sc->value= op_tc_or_a_a_and_a_a_la (sc, sc->code); - continue; - - case OP_TC_LET_IF_A_Z_LA: - if (op_tc_let_if_a_z_la (sc, sc->code)) continue; - goto EVAL; - case OP_TC_LET_IF_A_Z_L2A: - if (op_tc_let_if_a_z_l2a (sc, sc->code)) continue; - goto EVAL; - case OP_TC_LET_WHEN_L2A: - sc->value= op_tc_let_when_l2a (sc, sc->code); - continue; - - case OP_TC_COND_A_Z_A_L2A_L2A: - if (op_tc_cond_a_z_a_l2a_l2a (sc, sc->code)) continue; - goto EVAL; - case OP_TC_IF_A_Z_IF_A_L3A_L3A: - 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_L2A: - if (op_tc_if_a_z_let_if_a_z_l2a (sc, sc->code)) continue; - goto EVAL; - case OP_TC_LET_COND: - if (op_tc_let_cond (sc, sc->code)) continue; - goto EVAL; - case OP_TC_COND_N: - if (op_tc_cond_n (sc, sc->code)) continue; - goto EVAL; - - /* these six are ok */ - case OP_RECUR_IF_A_A_opLA_LAq: - sc->value= op_recur_if_a_a_opla_laq (sc, sc->code); - continue; - case OP_RECUR_IF_A_A_opL2A_L2Aq: - sc->value= op_recur_if_a_a_opl2a_l2aq (sc, sc->code); - continue; - case OP_RECUR_IF_A_A_opL3A_L3Aq: - sc->value= op_recur_if_a_a_opl3a_l3aq (sc, sc->code); - continue; - case OP_RECUR_IF_A_A_opA_LAq: - sc->value= op_recur_if_a_a_opa_laq (sc, sc->code); - continue; - case OP_RECUR_IF_A_A_opA_L2Aq: - sc->value= op_recur_if_a_a_opa_l2aq (sc, sc->code); - continue; - case OP_RECUR_IF_A_A_opA_L3Aq: - sc->value= op_recur_if_a_a_opa_l3aq (sc, sc->code); - continue; - - /* these 3 need 2 true_quit cases */ - case OP_RECUR_IF_A_A_IF_A_A_opLA_LAq: - sc->value= op_recur_if_a_a_if_a_a_opla_laq (sc, sc->code); - continue; - case OP_RECUR_IF_A_A_IF_A_A_opL2A_L2Aq: - sc->value= op_recur_if_a_a_if_a_a_opl2a_l2aq (sc, sc->code); - continue; - case OP_RECUR_IF_A_A_IF_A_A_opL3A_L3Aq: - sc->value= op_recur_if_a_a_if_a_a_opl3a_l3aq (sc, sc->code); - continue; - - case OP_RECUR_IF_A_A_opA_LA_LAq: - sc->value= op_recur_if_a_a_opa_la_laq (sc, sc->code); - continue; - case OP_RECUR_IF_A_A_opLA_LA_LAq: - sc->value= op_recur_if_a_a_opla_la_laq (sc, sc->code); - continue; - case OP_RECUR_IF_A_A_IF_A_L2A_opA_L2Aq: - sc->value= op_recur_if_a_a_if_a_l2a_opa_l2aq (sc, sc->code); - continue; - case OP_RECUR_COND_A_A_A_A_opA_L2Aq: - sc->value= op_recur_cond_a_a_a_a_opa_l2aq (sc, sc->code); - continue; - case OP_RECUR_COND_A_A_A_L2A_LopA_L2Aq: - sc->value= op_recur_cond_a_a_a_l2a_lopa_l2aq (sc, sc->code); - continue; - case OP_RECUR_IF_A_A_AND_A_L2A_L2A: - sc->value= op_recur_if_a_a_and_a_l2a_l2a (sc, sc->code); - continue; - case OP_RECUR_AND_A_OR_A_L2A_L2A: - sc->value= op_recur_and_a_or_a_l2a_l2a (sc, sc->code); - continue; - - case OP_IMPLICIT_VECTOR_REF_A: - if (!inline_op_implicit_vector_ref_a (sc)) { - if (op_unknown_a (sc)) goto EVAL; - } - continue; - case OP_IMPLICIT_VECTOR_REF_AA: - if (!op_implicit_vector_ref_aa (sc)) { - op_unknown_aa (sc); - goto EVAL; - } - continue; - case OP_IMPLICIT_STRING_REF_A: - if (!op_implicit_string_ref_a (sc)) { - 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_HASH_TABLE_REF_AA: - if (!op_implicit_hash_table_ref_aa (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)) { - 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_STARLET_REF_S: - sc->value= starlet (sc, opt3_int (sc->code)); - continue; - case OP_IMPLICIT_STARLET_SET_S: - sc->value= starlet_set_1 (sc, opt3_sym (sc->code), - fx_call (sc, cddr (sc->code))); - continue; - - case OP_SYMBOL: - sc->value= lookup_checked (sc, sc->code); - continue; - case OP_CONSTANT: - sc->value= sc->code; - continue; - case OP_PAIR_PAIR: - if (op_pair_pair (sc)) goto EVAL; - continue; /* car is pair ((if x car cadr) ...) */ - case OP_PAIR_ANY: - sc->value= car (sc->code); - goto EVAL_ARGS_TOP; - case OP_PAIR_SYM: - if (op_pair_sym (sc)) goto EVAL_ARGS_TOP; - continue; - - 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)); - op_unknown_ns (sc); - goto EVAL; - case OP_UNKNOWN_S: - sc->last_function= lookup_checked (sc, car (sc->code)); - if (op_unknown_s (sc)) goto EVAL; - continue; - case OP_UNKNOWN_GG: - sc->last_function= lookup_checked (sc, car (sc->code)); - op_unknown_gg (sc); - goto EVAL; - 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)); - op_unknown_aa (sc); - goto EVAL; - case OP_UNKNOWN_NA: - sc->last_function= lookup_checked (sc, car (sc->code)); - op_unknown_na (sc); - goto EVAL; - case OP_UNKNOWN_NP: - sc->last_function= lookup_checked (sc, car (sc->code)); - op_unknown_np (sc); - goto EVAL; - - case OP_EVAL_SET1_NO_MV: - sc->args= list_1 (sc, sc->value); - goto APPLY; /* args = (val), code = setter */ - - case OP_EVAL_SET2_NO_MV: - sc->args= pair_append (sc, sc->args, list_1 (sc, sc->value)); - goto APPLY; /* is a normal value */ - /* perhaps in_place is safe here: args=list_1(sc->value) if eval_set2, mv - * if eval_set2_mv */ - - case OP_EVAL_SET2_MV: /* = sc->value is a mv */ - push_stack (sc, OP_EVAL_SET2_NO_MV, sc->value, - sc->code); /* sc->value = inds */ - goto EVAL_SET2; - - case OP_EVAL_SET2: /* = sc->value is a normal value */ - push_stack (sc, OP_EVAL_SET2_NO_MV, list_1 (sc, sc->value), - sc->code); /* sc->value = ind */ - EVAL_SET2: - sc->code = sc->args; /* value */ - sc->cur_op= optimize_op (sc->code); - goto TOP_NO_POP; + case OP_SAFE_CLOSURE_STAR_NA_2: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 2)) {op_unknown_aa(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_STAR_NA_2: if (op_safe_closure_star_na_2(sc, sc->code)) goto EVAL; goto BEGIN; - case OP_EVAL_SET3_NO_MV: - op_eval_set3_no_mv (sc); - goto APPLY; /* is a normal value */ - - case OP_EVAL_SET3_MV: /* = sc->value is a mv */ - sc->args= (is_null (sc->args)) - ? sc->value - : pair_append (sc, sc->args, T_Lst (sc->value)); - goto EVAL_SET3; - - case OP_EVAL_SET3: /* = sc->value is a normal value */ - sc->args= - (is_null (sc->args)) - ? list_1 (sc, sc->value) - : pair_append (sc, sc->args, - list_1 (sc, sc->value)); /* not in_place here */ - EVAL_SET3: - op_eval_set3 (sc); - goto TOP_NO_POP; - case OP_EVAL_ARGS1: - op_eval_args1 (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 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_ARGS5: - op_eval_args5 (sc); - goto APPLY; - - 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; + 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)) {op_unknown_aa(sc); goto EVAL;} + 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))) ? opt3_arglen(cdr(sc->code)) : 0)) + {op_unknown_na(sc); goto EVAL;} + case HOP_CLOSURE_STAR_NA: if (op_closure_star_na(sc, sc->code)) goto EVAL; goto BEGIN; + + + /* these nine are ok */ + case OP_TC_CASE_LA: if (op_tc_case_la(sc, sc->code, 1)) continue; goto BEGIN; + case OP_TC_CASE_L2A: if (op_tc_case_la(sc, sc->code, 2)) continue; goto BEGIN; + case OP_TC_CASE_L3A: if (op_tc_case_la(sc, sc->code, 3)) continue; goto BEGIN; + case OP_TC_WHEN_LA: sc->value = op_tc_when_la(sc, sc->code); continue; + case OP_TC_WHEN_L2A: sc->value = op_tc_when_l2a(sc, sc->code); continue; + case OP_TC_WHEN_L3A: sc->value = op_tc_when_l3a(sc, sc->code); continue; + case OP_TC_IF_A_Z_LA: if (op_tc_if_a_z_la(sc, sc->code)) continue; goto EVAL; + case OP_TC_IF_A_Z_L2A: if (op_tc_if_a_z_l2a(sc, sc->code)) continue; goto EVAL; + case OP_TC_IF_A_Z_L3A: if (op_tc_if_a_z_l3a(sc, sc->code)) continue; goto EVAL; + + case OP_TC_IF_A_Z_IF_A_Z_LA: if (op_tc_if_a_z_if_a_z_la(sc, sc->code, true)) continue; goto EVAL; + case OP_TC_IF_A_Z_IF_A_LA_Z: if (op_tc_if_a_z_if_a_z_la(sc, sc->code, false)) continue; goto EVAL; + case OP_TC_AND_A_IF_A_LA_Z: if (op_tc_if_a_z_if_a_z_la(sc, sc->code, false)) continue; goto EVAL; + case OP_TC_AND_A_IF_A_Z_LA: if (op_tc_if_a_z_if_a_z_la(sc, sc->code, true)) continue; goto EVAL; + + case OP_TC_IF_A_Z_IF_A_Z_L2A: if (op_tc_if_a_z_if_a_z_l2a(sc, sc->code)) continue; goto EVAL; + case OP_TC_IF_A_Z_IF_A_L2A_Z: if (op_tc_if_a_z_if_a_l2a_z(sc, sc->code)) continue; goto EVAL; + + case OP_TC_IF_A_Z_IF_A_Z_L3A: if (op_tc_if_a_z_if_a_z_l3a(sc, sc->code, true)) continue; goto EVAL; + case OP_TC_IF_A_Z_IF_A_L3A_Z: if (op_tc_if_a_z_if_a_z_l3a(sc, sc->code, false)) continue; goto EVAL; + + case OP_TC_AND_A_OR_A_LA: sc->value = op_tc_and_a_or_a_la(sc, sc->code); continue; + case OP_TC_OR_A_AND_A_LA: sc->value = op_tc_or_a_and_a_la(sc, sc->code); continue; + case OP_TC_AND_A_OR_A_L2A: sc->value = op_tc_and_a_or_a_l2a(sc, sc->code); continue; + case OP_TC_OR_A_AND_A_L2A: sc->value = op_tc_or_a_and_a_l2a(sc, sc->code); continue; + case OP_TC_AND_A_OR_A_L3A: sc->value = op_tc_and_a_or_a_l3a(sc, sc->code); continue; + case OP_TC_OR_A_AND_A_L3A: sc->value = op_tc_or_a_and_a_l3a(sc, sc->code); continue; + case OP_TC_OR_A_AND_A_A_LA: sc->value = op_tc_or_a_and_a_a_la(sc, sc->code); continue; + case OP_TC_OR_A_AND_A_A_L3A: sc->value = op_tc_or_a_and_a_a_l3a(sc, sc->code); continue; + case OP_TC_AND_A_OR_A_A_LA: sc->value = op_tc_and_a_or_a_a_la(sc, sc->code); continue; + case OP_TC_OR_A_A_AND_A_A_LA: sc->value = op_tc_or_a_a_and_a_a_la(sc, sc->code); continue; + + case OP_TC_LET_IF_A_Z_LA: if (op_tc_let_if_a_z_la(sc, sc->code)) continue; goto EVAL; + case OP_TC_LET_IF_A_Z_L2A: if (op_tc_let_if_a_z_l2a(sc, sc->code)) continue; goto EVAL; + case OP_TC_LET_WHEN_L2A: sc->value = op_tc_let_when_l2a(sc, sc->code); continue; + + case OP_TC_COND_A_Z_A_L2A_L2A: if (op_tc_cond_a_z_a_l2a_l2a(sc, sc->code)) continue; goto EVAL; + case OP_TC_IF_A_Z_IF_A_L3A_L3A: 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_L2A: if (op_tc_if_a_z_let_if_a_z_l2a(sc, sc->code)) continue; goto EVAL; + case OP_TC_LET_COND: if (op_tc_let_cond(sc, sc->code)) continue; goto EVAL; + case OP_TC_COND_N: if (op_tc_cond_n(sc, sc->code)) continue; goto EVAL; + + + /* these six are ok */ + case OP_RECUR_IF_A_A_opLA_LAq: sc->value = op_recur_if_a_a_opla_laq(sc, sc->code); continue; + case OP_RECUR_IF_A_A_opL2A_L2Aq: sc->value = op_recur_if_a_a_opl2a_l2aq(sc, sc->code); continue; + case OP_RECUR_IF_A_A_opL3A_L3Aq: sc->value = op_recur_if_a_a_opl3a_l3aq(sc, sc->code); continue; + case OP_RECUR_IF_A_A_opA_LAq: sc->value = op_recur_if_a_a_opa_laq(sc, sc->code); continue; + case OP_RECUR_IF_A_A_opA_L2Aq: sc->value = op_recur_if_a_a_opa_l2aq(sc, sc->code); continue; + case OP_RECUR_IF_A_A_opA_L3Aq: sc->value = op_recur_if_a_a_opa_l3aq(sc, sc->code); continue; + + /* these 3 need 2 true_quit cases */ + case OP_RECUR_IF_A_A_IF_A_A_opLA_LAq: sc->value = op_recur_if_a_a_if_a_a_opla_laq(sc, sc->code); continue; + case OP_RECUR_IF_A_A_IF_A_A_opL2A_L2Aq: sc->value = op_recur_if_a_a_if_a_a_opl2a_l2aq(sc, sc->code); continue; + case OP_RECUR_IF_A_A_IF_A_A_opL3A_L3Aq: sc->value = op_recur_if_a_a_if_a_a_opl3a_l3aq(sc, sc->code); continue; + + case OP_RECUR_IF_A_A_opA_LA_LAq: sc->value = op_recur_if_a_a_opa_la_laq(sc, sc->code); continue; + case OP_RECUR_IF_A_A_opLA_LA_LAq: sc->value = op_recur_if_a_a_opla_la_laq(sc, sc->code); continue; + case OP_RECUR_IF_A_A_IF_A_L2A_opA_L2Aq: sc->value = op_recur_if_a_a_if_a_l2a_opa_l2aq(sc, sc->code); continue; + case OP_RECUR_COND_A_A_A_A_opA_L2Aq: sc->value = op_recur_cond_a_a_a_a_opa_l2aq(sc, sc->code); continue; + case OP_RECUR_COND_A_A_A_L2A_LopA_L2Aq: sc->value = op_recur_cond_a_a_a_l2a_lopa_l2aq(sc, sc->code); continue; + case OP_RECUR_IF_A_A_AND_A_L2A_L2A: sc->value = op_recur_if_a_a_and_a_l2a_l2a(sc, sc->code); continue; + case OP_RECUR_AND_A_OR_A_L2A_L2A: sc->value = op_recur_and_a_or_a_l2a_l2a(sc, sc->code); continue; + + + case OP_IMPLICIT_VECTOR_REF_A: if (!inline_op_implicit_vector_ref_a(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; + case OP_IMPLICIT_VECTOR_REF_AA: if (!op_implicit_vector_ref_aa(sc)) {op_unknown_aa(sc); goto EVAL;} continue; + case OP_IMPLICIT_STRING_REF_A: if (!op_implicit_string_ref_a(sc)) {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_HASH_TABLE_REF_AA: if (!op_implicit_hash_table_ref_aa(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)) {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_STARLET_REF_S: sc->value = starlet(sc, opt3_int(sc->code)); continue; + case OP_IMPLICIT_STARLET_SET_S: sc->value = starlet_set_1(sc, opt3_sym(sc->code), fx_call(sc, cddr(sc->code))); continue; + + case OP_SYMBOL: sc->value = lookup_checked(sc, sc->code); continue; + case OP_CONSTANT: sc->value = sc->code; continue; + case OP_PAIR_PAIR: if (op_pair_pair(sc)) goto EVAL; continue; /* car is pair ((if x car cadr) ...) */ + case OP_PAIR_ANY: sc->value = car(sc->code); goto EVAL_ARGS_TOP; + case OP_PAIR_SYM: if (op_pair_sym(sc)) goto EVAL_ARGS_TOP; continue; + + 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)); op_unknown_ns(sc); goto EVAL; + case OP_UNKNOWN_S: sc->last_function = lookup_checked(sc, car(sc->code)); if (op_unknown_s(sc)) goto EVAL; continue; + case OP_UNKNOWN_GG: sc->last_function = lookup_checked(sc, car(sc->code)); op_unknown_gg(sc); goto EVAL; + 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)); op_unknown_aa(sc); goto EVAL; + case OP_UNKNOWN_NA: sc->last_function = lookup_checked(sc, car(sc->code)); op_unknown_na(sc); goto EVAL; + case OP_UNKNOWN_NP: sc->last_function = lookup_checked(sc, car(sc->code)); op_unknown_np(sc); goto EVAL; + + + case OP_EVAL_SET1_NO_MV: + sc->args = list_1(sc, sc->value); + goto APPLY; /* args = (val), code = setter */ + + case OP_EVAL_SET2_NO_MV: sc->args = pair_append(sc, sc->args, list_1(sc, sc->value)); goto APPLY; /* is a normal value */ + /* perhaps in_place is safe here: args=list_1(sc->value) if eval_set2, mv if eval_set2_mv */ + + case OP_EVAL_SET2_MV: /* = sc->value is a mv */ + push_stack(sc, OP_EVAL_SET2_NO_MV, sc->value, sc->code); /* sc->value = inds */ + goto EVAL_SET2; + + case OP_EVAL_SET2: /* = sc->value is a normal value */ + push_stack(sc, OP_EVAL_SET2_NO_MV, list_1(sc, sc->value), sc->code); /* sc->value = ind */ + EVAL_SET2: + sc->code = sc->args; /* value */ + sc->cur_op = optimize_op(sc->code); + goto TOP_NO_POP; + + case OP_EVAL_SET3_NO_MV: op_eval_set3_no_mv(sc); goto APPLY; /* is a normal value */ + + case OP_EVAL_SET3_MV: /* = sc->value is a mv */ + sc->args = (is_null(sc->args)) ? sc->value : pair_append(sc, sc->args, T_Lst(sc->value)); + goto EVAL_SET3; + + case OP_EVAL_SET3: /* = sc->value is a normal value */ + sc->args = (is_null(sc->args)) ? list_1(sc, sc->value) : pair_append(sc, sc->args, list_1(sc, sc->value)); /* not in_place here */ + EVAL_SET3: + op_eval_set3(sc); + goto TOP_NO_POP; + + case OP_EVAL_ARGS1: op_eval_args1(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 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_ARGS5: op_eval_args5(sc); goto APPLY; + + 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) && (!is_safety_checked(sc->code))) + { /* this can happen */ + if (tree_is_cyclic(sc, sc->code)) + syntax_error_nr(sc, "attempt to evaluate a circular list: ~A", 39, sc->code); + set_safety_checked(sc->code); + } + EVAL_ARGS_PAIR: + if (is_pair(car(sc->code))) + { + eval_args_pair_car(sc); + goto EVAL; + } + if (is_pair(cdr(sc->code))) + { + const s7_pointer head = car(sc->code); /* not a pair */ + sc->code = cdr(sc->code); + sc->value = (is_symbol(head)) ? lookup_checked(sc, head) : T_Ext(head); + /* 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_nr(sc); + 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: + if (SHOW_EVAL_OPS) safe_print(fprintf(stderr, " %s[%d]: %sop_apply%s %s (%s) to %s\n", __func__, __LINE__, + bold_text, unbold_text, display_truncated(sc->code), s7_type_names[type(sc->code)], display_truncated(sc->args))); + /* pulling out T_C_FUNCTION (to avoid the switch) does not gain anything in the timing tests */ + switch (type(sc->code)) + { + case T_C_FUNCTION: sc->value = apply_c_function(sc, sc->code, sc->args); continue; /* only call so it does get inlined */ + case T_C_RST_NO_REQ_FUNCTION: apply_c_rst_no_req_function(sc); continue; + case T_C_FUNCTION_STAR: apply_c_function_star(sc); continue; + case T_CONTINUATION: call_with_current_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_COMPLEX_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: eval_apply_error_nr(sc); + } + + 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, T_MACRO)) goto EVAL_ARGS_TOP; /* fall through presumably */ + /* goto EVAL_ARGS_TOP if the "macro" has changed typed in midstream -- normally we fall through */ - 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) && - (!is_safety_checked (sc->code))) { /* this can happen */ - if (tree_is_cyclic (sc, sc->code)) - syntax_error_nr (sc, "attempt to evaluate a circular list: ~A", 39, - sc->code); - set_safety_checked (sc->code); - } - EVAL_ARGS_PAIR: - if (is_pair (car (sc->code))) { - eval_args_pair_car (sc); - goto EVAL; - } - if (is_pair (cdr (sc->code))) { - const s7_pointer head= car (sc->code); /* not a pair */ - sc->code = cdr (sc->code); - sc->value= - (is_symbol (head)) ? lookup_checked (sc, head) : T_Ext (head); - /* 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_nr (sc); - 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: - if (SHOW_EVAL_OPS) - safe_print (fprintf ( - stderr, " %s[%d]: %sop_apply%s %s (%s) to %s\n", __func__, - __LINE__, bold_text, unbold_text, display_truncated (sc->code), - s7_type_names[type (sc->code)], display_truncated (sc->args))); - /* pulling out T_C_FUNCTION (to avoid the switch) does not gain anything - * in the timing tests */ - switch (type (sc->code)) { - case T_C_FUNCTION: - sc->value= apply_c_function (sc, sc->code, sc->args); - continue; /* only call so it does get inlined */ - case T_C_RST_NO_REQ_FUNCTION: - apply_c_rst_no_req_function (sc); - continue; - case T_C_FUNCTION_STAR: - apply_c_function_star (sc); - continue; - case T_CONTINUATION: - call_with_current_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_COMPLEX_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: - eval_apply_error_nr (sc); - } + APPLY_LAMBDA: + case OP_APPLY_LAMBDA: + inline_apply_lambda(sc); + goto BEGIN; - 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, T_MACRO)) - goto EVAL_ARGS_TOP; /* fall through presumably */ - /* goto EVAL_ARGS_TOP if the "macro" has changed typed in midstream -- - * normally we fall through */ - - APPLY_LAMBDA: - case OP_APPLY_LAMBDA: - inline_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; - } + 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; + + 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; #if S7_DEBUGGING - case OP_MAP_UNWIND: /* this probably can't happen -- left on stack only if - opt succeeds then func called */ - fprintf (stderr, "%s[%d]: op_map_unwind %" ld64 "\n", __func__, __LINE__, - sc->map_call_ctr); - sc->map_call_ctr--; - if (sc->map_call_ctr < 0) { - fprintf (stderr, "%s[%d]: map ctr: %" ld64 "\n", __func__, __LINE__, - sc->map_call_ctr); - sc->map_call_ctr= 0; - } - continue; + case OP_MAP_UNWIND: /* this probably can't happen -- left on stack only if opt succeeds then func called */ + fprintf(stderr, "%s[%d]: op_map_unwind %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr); + sc->map_call_ctr--; + if (sc->map_call_ctr < 0) {fprintf(stderr, "%s[%d]: map ctr: %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr); sc->map_call_ctr = 0;} + continue; #endif - case OP_MAP_GATHER: - inline_op_map_gather (sc); - case OP_MAP: - if (op_map (sc)) continue; - goto APPLY; - - case OP_MAP_GATHER_1: - inline_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: - inline_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 (inline_op_for_each_1 (sc)) continue; - goto BEGIN; - - case OP_FOR_EACH_2: - case OP_FOR_EACH_3: - if (inline_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: /* gen form */ - 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_MAP_GATHER: inline_op_map_gather(sc); + case OP_MAP: if (op_map(sc)) continue; goto APPLY; - case OP_SAFE_DO: - SAFE_DO: /* from check_do */ - switch (op_safe_do (sc)) /* mat */ - { - case goto_safe_do_end_clauses: - if (is_null (sc->code)) - continue; /* multiple values (as test result) can't happen -- safe do - loops involve counters by 1 to some integer end */ - goto DO_END_CODE; - case goto_do_unchecked: - goto DO_UNCHECKED; - default: - goto BEGIN; - } + case OP_MAP_GATHER_1: inline_op_map_gather(sc); + case OP_MAP_1: if (op_map_1(sc)) continue; 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_MAP_GATHER_2: + case OP_MAP_GATHER_3: inline_op_map_gather(sc); + case OP_MAP_2: if (op_map_2(sc)) continue; goto EVAL; - case OP_DOX: - DOX: /* from check_do */ - switch (op_dox (sc)) /* lg fft exit */ - { - 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; - } + case OP_FOR_EACH: if (op_for_each(sc)) continue; goto APPLY; + case OP_FOR_EACH_1: if (inline_op_for_each_1(sc)) continue; goto BEGIN; - DO_NO_BODY: - case OP_DO_NO_BODY_NA_VARS: - op_do_no_body_na_vars (sc); - goto EVAL; - case OP_DO_NO_BODY_NA_VARS_STEP: - if (op_do_no_body_na_vars_step (sc)) goto DO_END_CLAUSES; - goto EVAL; - case OP_DO_NO_BODY_NA_VARS_STEP_1: - if (op_do_no_body_na_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_1 (sc)) goto DO_END_CLAUSES; - op_dox_step (sc); - goto BEGIN; - case OP_DOX_STEP_O: - if (op_dox_step_1 (sc)) goto DO_END_CLAUSES; - op_dox_step_o (sc); - 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; /* looping if need eval for init */ + case OP_FOR_EACH_2: + case OP_FOR_EACH_3: if (inline_op_for_each_2(sc)) continue; 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_NA_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_MEMBER_IF: + case OP_MEMBER_IF1: if (op_member_if(sc)) continue; goto APPLY; - 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: - if (is_true (sc, sc->value)) { - goto_t next= op_do_end_true (sc); - if (next == goto_start) continue; - if (next == goto_eval) goto EVAL; - goto FEED_TO; - } - else { - goto_t next= op_do_end_false (sc); - if (next == goto_begin) goto BEGIN; - if (next == goto_do_end) goto DO_END; - /* fall through */ - } + case OP_ASSOC_IF: + case OP_ASSOC_IF1: if (op_assoc_if(sc)) continue; goto APPLY; - 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: { - goto_t next= do_end_code (sc); - if (next == goto_eval) goto EVAL; - if (next == goto_start) continue; - goto FEED_TO; - } + case OP_SAFE_DOTIMES: /* gen form */ + 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_BEGIN_UNCHECKED: - set_current_code (sc, sc->code); - sc->code= T_Pair (cdr (sc->code)); - goto BEGIN; + case OP_SAFE_DO: + SAFE_DO: /* from check_do */ + switch (op_safe_do(sc)) /* mat */ + { + case goto_safe_do_end_clauses: + if (is_null(sc->code)) continue; /* multiple values (as test result) can't happen -- safe do loops involve counters by 1 to some integer end */ + goto DO_END_CODE; + case goto_do_unchecked: goto DO_UNCHECKED; + default: 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: - set_current_code ( - sc, - car (sc->code)); /* better error message if unbound variable: (define - (func) (let ((sig 0)) 0) (lcm sig)) (func) */ - 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_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_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_UNCHECKED: - push_stack_no_args (sc, OP_DEFINE_CONSTANT1, cadr (sc->code)); - goto DEFCONS; - - case OP_DEFINE_CONSTANT: - if (op_define_constant (sc)) continue; - - case OP_DEFINE_STAR: - case OP_DEFINE: - check_define (sc); - - DEFCONS: - 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; - case OP_DEFINE_WITH_SETTER: - op_define_with_setter (sc); - continue; - - case OP_SET_opSq_A: - if (op_set_opsq_a (sc)) goto APPLY; - continue; - case OP_SET_opSAq_A: - if (op_set_opsaq_a (sc)) goto APPLY; - continue; - case OP_SET_opSAq_P: - if (op_set_opsaq_p (sc)) goto APPLY; - goto EVAL; - case OP_SET_opSAq_P_1: - if (op_set_opsaq_p_1 (sc)) goto APPLY; - continue; - case OP_SET_opSAAq_A: - if (op_set_opsaaq_a (sc)) goto APPLY; - continue; - case OP_SET_opSAAq_P: - if (op_set_opsaaq_p (sc)) goto APPLY; - goto EVAL; - case OP_SET_opSAAq_P_1: - if (op_set_opsaaq_p_1 (sc)) goto APPLY; - continue; - - case OP_INCREMENT_BY_1: - inline_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_SET_S_C: - op_set_s_c (sc); - continue; - case OP_SET_S_S: - op_set_s_s (sc); - continue; - case OP_SET_S_A: - op_set_s_a (sc); - continue; - case OP_SET_S_P: - op_set_s_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)) /* imp */ - { - 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; /* goto_eval_args in funcs called by op_set2, unopt */ - } + case OP_DOX: + DOX: /* from check_do */ + switch (op_dox(sc)) /* lg fft exit */ + { + 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_NA_VARS: op_do_no_body_na_vars(sc); goto EVAL; + case OP_DO_NO_BODY_NA_VARS_STEP: if (op_do_no_body_na_vars_step(sc)) goto DO_END_CLAUSES; goto EVAL; + case OP_DO_NO_BODY_NA_VARS_STEP_1: if (op_do_no_body_na_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_1(sc)) goto DO_END_CLAUSES; op_dox_step(sc); goto BEGIN; + case OP_DOX_STEP_O: if (op_dox_step_1(sc)) goto DO_END_CLAUSES; op_dox_step_o(sc); 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; /* looping if need eval for init */ + + 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_NA_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: + if (is_true(sc, sc->value)) + { + goto_t next = op_do_end_true(sc); + if (next == goto_start) continue; + if (next == goto_eval) goto EVAL; + goto FEED_TO; + } + else + { + goto_t next = op_do_end_false(sc); + if (next == goto_begin) goto BEGIN; + if (next == goto_do_end) goto DO_END; + /* fall through */ + } - case OP_SET: - check_set (sc); - case OP_SET_UNCHECKED: - 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; - case goto_eval_args_pair: - goto EVAL_ARGS_PAIR; - default: - goto EVAL_ARGS; /* very common, op_unopt at this point */ - } - 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)) /* imp misc */ - { - case goto_top_no_pop: - goto TOP_NO_POP; - case goto_start: - continue; - case goto_apply: - goto APPLY; - case goto_eval_args_pair: - goto EVAL_ARGS_PAIR; - default: - goto EVAL_ARGS; /* unopt */ - } - set_with_let_error_nr (sc); - - 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_S_A_P: - if_s_p (sc) { - sc->value= fx_call (sc, opt1_pair (sc->code)); - continue; - } - sc->code= opt2_any (sc->code); - goto EVAL; + 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; - 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; + DO_END_CLAUSES: + if (do_end_clauses(sc)) continue; + DO_END_CODE: + { + goto_t next = do_end_code(sc); + if (next == goto_eval) goto EVAL; + if (next == goto_start) continue; + goto FEED_TO; + } - 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, opt1_pair (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; - case OP_IF_IS_TYPE_S_A_P: - if_is_type_s_p (sc) { - sc->value= fx_call (sc, opt1_pair (sc->code)); - continue; - } - sc->code= opt2_any (sc->code); - goto EVAL; - -#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_PN); - goto EVAL; - case OP_IF_P_P_P: - check_stack_size (sc); - 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_PN: - 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_BEGIN_UNCHECKED: + set_current_code(sc, sc->code); + sc->code = T_Pair(cdr(sc->code)); + goto BEGIN; - 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_COND_FEED: - if (op_cond_feed (sc)) goto EVAL; /* else fall through */ - case OP_COND_FEED_1: - if (is_true (sc, sc->value)) { - op_cond_feed_1 (sc); - goto EVAL; - } - sc->value= sc->unspecified; - 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; /* else fall through */ - 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_NA_NA: - sc->value= fx_cond_na_na (sc, sc->code); - continue; - case OP_COND_NA_NP: - if (op_cond_na_np (sc)) continue; - goto EVAL; - case OP_COND_NA_NP_1: - if (op_cond_na_np_1 (sc)) continue; - goto EVAL; - case OP_COND_NA_NP_O: - if (inline_op_cond_na_np_o (sc)) continue; - goto EVAL; - case OP_COND_NA_2E: - if (op_cond_na_2e (sc)) continue; - goto EVAL; - case OP_COND_NA_3E: - if (op_cond_na_3e (sc)) continue; - goto EVAL; + case OP_BEGIN: + if (op_begin(sc, sc->code)) continue; + sc->code = T_Pair(cdr(sc->code)); - 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)) - continue; /* this order of checks appears to be faster than any of the - alternatives */ - goto AND_P; - } - if (is_pair ( - cdr (sc->code))) /* apparently exactly as fast as is_not_null */ - push_stack_no_args (sc, OP_AND_P1, cdr (sc->code)); - sc->code= car (sc->code); - goto EVAL; + 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: + set_current_code(sc, car(sc->code)); /* better error message if unbound variable: (define (func) (let ((sig 0)) 0) (lcm sig)) (func) */ + goto BEGIN; - 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_pair (cdr (sc->code))) - push_stack_no_args ( - sc, OP_OR_P1, - cdr (sc->code)); /* might need to check stack size here */ - sc->code= car (sc->code); - goto EVAL; + case OP_BEGIN_2_UNCHECKED: + push_stack_no_args(sc, OP_EVAL, caddr(sc->code)); + sc->code = cadr(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_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_NA: - op_named_let_na (sc); - goto BEGIN; - - 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_let_1 (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_NA_OLD: - op_let_a_na_old (sc); - continue; - case OP_LET_A_NA_NEW: - op_let_a_na_new (sc); - continue; - case OP_LET_NA_OLD: - op_let_na_old (sc); - goto BEGIN; - case OP_LET_NA_NEW: - inline_op_let_na_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: - inline_op_let_a_new (sc); - sc->code= cdr (sc->code); - goto BEGIN; - case OP_LET_A_OLD_2: - inline_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: - inline_op_let_a_new (sc); - push_stack_no_args (sc, OP_EVAL, caddr (sc->code)); - sc->code= cadr (sc->code); - goto EVAL; - /* it is slower here to check if has_fx and use fx_call */ - case OP_LET_A_P_OLD: - inline_op_let_a_old (sc); - sc->code= cadr (sc->code); - goto EVAL; - case OP_LET_A_P_NEW: - inline_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: - set_curlet (sc, inline_make_let_with_slot ( - sc, sc->curlet, opt2_sym (sc->code), sc->value)); - goto BEGIN; - case OP_LET_ONE_P_NEW_1: - set_curlet (sc, inline_make_let_with_slot ( - sc, sc->curlet, opt2_sym (sc->code), sc->value)); - sc->code= car (sc->code); - 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_STAR_NA: - op_let_star_na (sc); - goto BEGIN; - case OP_LET_STAR_NA_A: - op_let_star_na_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_LET_STAR_SHADOWED: - if (op_let_star_shadowed (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_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_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: - op_let_temp_init1_1 (sc); - LET_TEMP_INIT1: - if (op_let_temp_init1 (sc)) goto EVAL; - case OP_LET_TEMP_INIT2: - switch (op_let_temp_init2 (sc)) /* let misc obj */ - { - case goto_begin: - goto BEGIN; - case goto_eval: - goto EVAL; - case goto_set_unchecked: - goto SET_UNCHECKED; - case fall_through: - default: - break; - } - case OP_LET_TEMP_DONE: - sc->code= sc->value; - push_stack (sc, OP_GC_PROTECT, sc->args, - sc->value); /* save let-temp body val as sc->code */ - case OP_LET_TEMP_DONE1: - if (op_let_temp_done1 (sc)) continue; - goto SET_UNCHECKED; - - case OP_LET_TEMP_S7: - if (op_let_temp_s7 (sc)) goto BEGIN; - sc->value= sc->nil; - continue; - case OP_LET_TEMP_S7_OPENLETS: - if (op_let_temp_s7_openlets (sc)) goto BEGIN; - sc->value= sc->nil; - continue; - case OP_LET_TEMP_NA: - if (op_let_temp_na (sc)) goto BEGIN; - sc->value= sc->nil; - continue; - case OP_LET_TEMP_A: - if (op_let_temp_a (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_S7_OPENLETS_UNWIND: - op_let_temp_s7_openlets_unwind (sc); - continue; - case OP_LET_TEMP_SETTER_UNWIND: - op_let_temp_setter_unwind (sc); - 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 - goto G_G; /* selector is a symbol or constant, stupid "else" to shut up - the compiler */ - - case OP_CASE_A_G_G: - sc->value= fx_call (sc, cdr (sc->code)); - G_G: - case OP_CASE_G_G: - if (op_case_g_g (sc)) goto TOP_NO_POP; - goto FEED_TO; - case OP_CASE_A_E_S: - sc->value= fx_call (sc, cdr (sc->code)); - case OP_CASE_E_S: - op_case_e_s (sc); - goto EVAL; - 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)); - case OP_CASE_I_S: - if (op_case_i_s (sc)) continue; - goto EVAL; - case OP_CASE_A_G_S: - sc->value= fx_call (sc, cdr (sc->code)); /* this almost never happens? */ - 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)); - 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: /* splitting this case out matters in lint */ - 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; - else 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_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_A_I_S_A: - sc->value= fx_case_a_i_s_a (sc, sc->code); - continue; - case OP_CASE_A_E_S_A: - sc->value= fx_case_a_e_s_a (sc, sc->code); - continue; - case OP_CASE_A_G_S_A: - sc->value= fx_case_a_g_s_a (sc, sc->code); - continue; - case OP_CASE_A_S_G_A: - sc->value= fx_case_a_s_g_a (sc, sc->code); - continue; - - case OP_ERROR_QUIT: - if (sc->stack_end <= sc->stack_start) - stack_reset (sc); /* sets stack_end to stack_start, then pushes - op_eval_done, (can <= be F); - - case OP_ERROR_HOOK_QUIT: - op_error_hook_quit (sc); - - 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 */ - sc->value= splice_in_values (sc, sc->args); - continue; + case OP_EVAL: goto EVAL; + case OP_EVAL_STRING: op_eval_string(sc); goto EVAL; - 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: - if (SHOW_EVAL_OPS) fprintf (stderr, " flush %s\n", op_names[sc->cur_op]); - continue; - - case OP_GET_OUTPUT_STRING: - op_get_output_string(sc); /* from call-with-output-string|with-output-to-string; return the port string directly *//* 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_PROFILE_IN: - g_profile_in (sc, set_plist_2 (sc, cadr (sc->code), sc->curlet)); - continue; - case OP_DYNAMIC_UNWIND_PROFILE: - g_profile_out (sc, set_plist_1 (sc, sc->args)); - continue; - case OP_DYNAMIC_WIND: - if (op_dynamic_wind (sc)) goto APPLY; - continue; - case OP_DEACTIVATE_GOTO: - call_exit_active (sc->args)= false; - continue; /* deactivate the exiter */ - - case OP_WITH_LET_S: - sc->value= fx_with_let_s (sc, sc->code); - continue; - case OP_WITH_LET: - if (!check_with_let (sc)) continue; - 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_QUOTE: sc->value = check_quote(sc, sc->code); continue; + case OP_QUOTE_UNCHECKED: sc->value = cadr(sc->code); 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; - const s7_pointer port= current_input_port (sc); - c = port_read_white_space (port) (sc, port); - - READ_C: - switch (c) { - case '(': - c= port_read_white_space (port) (sc, port); /* 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, port); - break; - case '\'': - sc->tok= token_quote; - break; - case ';': - sc->tok= port_read_semicolon (port) (sc, port); - break; - case '"': - sc->tok= token_double_quote; - break; - case '`': - sc->tok= token_back_quote; - break; - case ',': - sc->tok= read_comma (sc, port); - break; - case '#': - sc->tok= read_sharp (sc, port); - break; - case '\0': - case EOF: - sc->tok= token_eof; - break; - - default: /* read first element of list (ignore callgrind confusion -- - this happens a lot) */ - c= read_start_list (sc, port, c); - goto READ_C; - } - if (sc->tok == token_atom) { - c= read_atom (sc, port); - goto READ_C; - } - if (sc->tok == token_right_paren) { - sc->value= sc->nil; - goto READ_LIST; - } - if (sc->tok == token_dot) { - do { - c= inchar (port); - } while ((c != ')') && (c != EOF)); - read_error_nr (sc, "stray dot after '('?"); /* (car '( . )) */ - } - if (sc->tok == token_eof) missing_close_paren_error_nr (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 (stack_top_op (sc) == OP_READ_LIST) goto POP_READ_LIST; - continue; - - case ')': - sc->tok= token_right_paren; - break; - - case '.': - sc->tok= read_dot (sc, port); /* dot or atom */ - break; - - case '\'': - sc->tok= token_quote; - /* might need check_stack_size(sc) here */ - push_stack_no_let_no_code (sc, OP_READ_LIST, sc->args); - sc->value= read_expression (sc); - continue; - - case ';': - sc->tok= port_read_semicolon (port) (sc, port); - 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 (stack_top_op (sc) == OP_READ_LIST) goto POP_READ_LIST; - continue; - - case ',': - sc->tok= read_comma (sc, port); /* 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, port); - break; - - case '\0': - case EOF: - missing_close_paren_error_nr (sc); + case OP_DEFINE_FUNCHECKED: define_funchecked(sc); continue; + case OP_DEFINE_CONSTANT1: op_define_constant1(sc); continue; - default: - sc->strbuf[0]= (unsigned char) c; - sc->value = port_read_name (port) (sc, port); - goto READ_LIST; - } - } + case OP_DEFINE_CONSTANT_UNCHECKED: + push_stack_no_args(sc, OP_DEFINE_CONSTANT1, cadr(sc->code)); + goto DEFCONS; - 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; - case goto_start: - default: - continue; - } - break; - - case token_eof: - if (S7_DEBUGGING) - fprintf (stderr, "%s[%d]: we should not be here\n", __func__, - __LINE__); - missing_close_paren_error_nr (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 (stack_top_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_COMPLEX_VECTOR: - if (op_read_complex_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; - case OP_UNOPT: - goto UNOPT; - default: - if (S7_DEBUGGING) - fprintf (stderr, "%s[%d]: eval unknown op: %d\n", __func__, __LINE__, - (int) (sc->cur_op)); - return (sc->F); - } - - /* this code is reached from OP_CLEAR_OPTS and many others where the - * optimization has turned out to be incorrect, search for !c_function_is_ok - * -> break */ - if ((S7_DEBUGGING) && (tree_is_cyclic (sc, sc->code))) - fprintf (stderr, "%s[%d]: cyclic %s\n", __func__, __LINE__, - display (sc->code)); /* never hit? */ - clear_all_optimizations (sc, sc->code); - - UNOPT: - if (SHOW_EVAL_OPS) - fprintf (stderr, " %d: unopt trailers %s\n", __LINE__, - display_truncated (sc->code)); - set_current_code (sc, sc->code); - if (is_pair (sc->code)) { - const s7_pointer head= T_Ext (car (sc->code)); - if (is_symbol (head)) /* car is a symbol, sc->code a list */ - { - if (is_syntactic_symbol (head)) { - sc->cur_op= (opcode_t) symbol_syntax_op_checked (sc->code); - pair_set_syntax_op (sc->code, sc->cur_op); - goto TOP_NO_POP; - } - sc->value= lookup_global (sc, head); - set_optimize_op ( - sc->code, OP_PAIR_SYM); /* mostly stuff outside functions (unopt) */ - goto EVAL_ARGS_TOP; - } - if (is_pair (head)) /* ((if x y z) a b) etc */ - { - if (eval_car_pair (sc)) goto TOP_NO_POP; - goto EVAL; - } - if (is_syntax (head)) /* here we can get syntax objects like quote */ - { - sc->cur_op= syntax_opcode (head); - pair_set_syntax_op (sc->code, sc->cur_op); - goto TOP_NO_POP; - } - /* car is the function/sequence to be applied, or (for example) a syntax - * variable like quote that has been used locally */ - set_optimize_op ( - sc->code, - OP_PAIR_ANY); /* usually an error: (#\a) etc, might be (#(0) 0) */ - sc->value= head; - /* here head can be a c_function (#_list-values, #_curlet, etc), a vector - * constant (etc), a closure (etc)... */ - /* this code is rarely called, so no need to pick out these cases here - */ - /* fprintf(stderr, "%s[%d]: %s %s\n", __func__, __LINE__, - * s7_type_names[type(head)], display(sc->code)); */ - goto EVAL_ARGS_TOP; - } - if (is_normal_symbol (sc->code)) { - sc->value= lookup_checked (sc, sc->code); - set_optimize_op (sc->code, OP_SYMBOL); - } - else { - sc->value= sc->code; - set_optimize_op (sc->code, OP_CONSTANT); - } - } /* continue */ + case OP_DEFINE_CONSTANT: + if (op_define_constant(sc)) continue; - if (S7_DEBUGGING) - fprintf (stderr, "%s[%d]: we should not be here\n", __func__, __LINE__); - return (sc->F); /* this never happens (make the compiler happy) */ -} - -static s7_pointer -g_reader_cond (s7_scheme* sc, - s7_pointer args) /* (reader-cond clause . clauses) */ -{ -#define H_reader_cond "(reader-cond clauses) is a read-time cond." - for (s7_pointer clauses= args; is_pair (clauses); clauses= cdr (clauses)) { - const s7_pointer clause= car (clauses); - s7_pointer val; - if (!is_pair (clause)) - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_2 ( - sc, wrap_string (sc, "reader-cond: clause is not a pair, ~S", 37), - clause)); - val= s7_eval (sc, car (clause), sc->rootlet); - if (val != sc->F) { - if (is_null (cdr (clause))) return (val); - if (cadr (clause) == sc->feed_to_symbol) { - s7_pointer func= s7_eval (sc, caddr (clause), sc->rootlet); - return (s7_apply_function (sc, func, list_1 (sc, val))); - } - if (is_null (cddr (clause))) return (cadr (clause)); - return (g_apply_values (sc, list_1 (sc, cdr (clause)))); - } - } - return (sc->no_value); + case OP_DEFINE_STAR: case OP_DEFINE: + check_define(sc); + + DEFCONS: + 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; + case OP_DEFINE_WITH_SETTER: op_define_with_setter(sc); continue; + + case OP_SET_opSq_A: if (op_set_opsq_a(sc)) goto APPLY; continue; + case OP_SET_opSAq_A: if (op_set_opsaq_a(sc)) goto APPLY; continue; + case OP_SET_opSAq_P: if (op_set_opsaq_p(sc)) goto APPLY; goto EVAL; + case OP_SET_opSAq_P_1: if (op_set_opsaq_p_1(sc)) goto APPLY; continue; + case OP_SET_opSAAq_A: if (op_set_opsaaq_a(sc)) goto APPLY; continue; + case OP_SET_opSAAq_P: if (op_set_opsaaq_p(sc)) goto APPLY; goto EVAL; + case OP_SET_opSAAq_P_1: if (op_set_opsaaq_p_1(sc)) goto APPLY; continue; + + case OP_INCREMENT_BY_1: inline_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_SET_S_C: op_set_s_c(sc); continue; + case OP_SET_S_S: op_set_s_s(sc); continue; + case OP_SET_S_A: op_set_s_a(sc); continue; + case OP_SET_S_P: op_set_s_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)) /* imp */ + { + 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; /* goto_eval_args in funcs called by op_set2, unopt */ + } + + case OP_SET: check_set(sc); + case OP_SET_UNCHECKED: + 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; + case goto_eval_args_pair: goto EVAL_ARGS_PAIR; + default: goto EVAL_ARGS; /* very common, op_unopt at this point */ + } + 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)) /* imp misc */ + { + case goto_top_no_pop: goto TOP_NO_POP; + case goto_start: continue; + case goto_apply: goto APPLY; + case goto_eval_args_pair: goto EVAL_ARGS_PAIR; + default: goto EVAL_ARGS; /* unopt */ + } + set_with_let_error_nr(sc); + + 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_S_A_P: if_s_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: 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, opt1_pair(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; + case OP_IF_IS_TYPE_S_A_P: if_is_type_s_p(sc) {sc->value = fx_call(sc, opt1_pair(sc->code)); continue;} sc->code = opt2_any(sc->code); goto EVAL; + + #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_PN); goto EVAL; + case OP_IF_P_P_P: check_stack_size(sc); 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_PN: + 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_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_COND_FEED: if (op_cond_feed(sc)) goto EVAL; /* else fall through */ + case OP_COND_FEED_1: if (is_true(sc, sc->value)) {op_cond_feed_1(sc); goto EVAL;} sc->value = sc->unspecified; 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; /* else fall through */ + 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_NA_NA: sc->value = fx_cond_na_na(sc, sc->code); continue; + case OP_COND_NA_NP: if (op_cond_na_np(sc)) continue; goto EVAL; + case OP_COND_NA_NP_1: if (op_cond_na_np_1(sc)) continue; goto EVAL; + case OP_COND_NA_NP_O: if (inline_op_cond_na_np_o(sc)) continue; goto EVAL; + case OP_COND_NA_2E: if (op_cond_na_2e(sc)) continue; goto EVAL; + case OP_COND_NA_3E: if (op_cond_na_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)) continue; /* this order of checks appears to be faster than any of the alternatives */ + goto AND_P; + } + if (is_pair(cdr(sc->code))) /* apparently exactly as fast as is_not_null */ + 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_pair(cdr(sc->code))) + push_stack_no_args(sc, OP_OR_P1, cdr(sc->code)); /* might need to check stack size here */ + 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_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_NA: op_named_let_na(sc); goto BEGIN; + + 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_let_1(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_NA_OLD: op_let_a_na_old(sc); continue; + case OP_LET_A_NA_NEW: op_let_a_na_new(sc); continue; + case OP_LET_NA_OLD: op_let_na_old(sc); goto BEGIN; + case OP_LET_NA_NEW: inline_op_let_na_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: inline_op_let_a_new(sc); sc->code = cdr(sc->code); goto BEGIN; + case OP_LET_A_OLD_2: inline_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: inline_op_let_a_new(sc); push_stack_no_args(sc, OP_EVAL, caddr(sc->code)); sc->code = cadr(sc->code); goto EVAL; + /* it is slower here to check if has_fx and use fx_call */ + case OP_LET_A_P_OLD: inline_op_let_a_old(sc); sc->code = cadr(sc->code); goto EVAL; + case OP_LET_A_P_NEW: inline_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: set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, opt2_sym(sc->code), sc->value)); goto BEGIN; + case OP_LET_ONE_P_NEW_1: set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, opt2_sym(sc->code), sc->value)); sc->code = car(sc->code); 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_STAR_NA: op_let_star_na(sc); goto BEGIN; + case OP_LET_STAR_NA_A: op_let_star_na_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_LET_STAR_SHADOWED: if (op_let_star_shadowed(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: + op_let_temp_init1_1(sc); + LET_TEMP_INIT1: + if (op_let_temp_init1(sc)) goto EVAL; + case OP_LET_TEMP_INIT2: + switch (op_let_temp_init2(sc)) /* let misc obj */ + { + case goto_begin: goto BEGIN; + case goto_eval: goto EVAL; + case goto_set_unchecked: goto SET_UNCHECKED; + case fall_through: + default: break; + } + + case OP_LET_TEMP_DONE: + sc->code = sc->value; + push_stack(sc, OP_GC_PROTECT, sc->args, sc->value); /* save let-temp body val as sc->code */ + case OP_LET_TEMP_DONE1: + if (op_let_temp_done1(sc)) continue; + goto SET_UNCHECKED; + + case OP_LET_TEMP_S7: if (op_let_temp_s7(sc)) goto BEGIN; sc->value = sc->nil; continue; + case OP_LET_TEMP_S7_OPENLETS: if (op_let_temp_s7_openlets(sc)) goto BEGIN; sc->value = sc->nil; continue; + case OP_LET_TEMP_NA: if (op_let_temp_na(sc)) goto BEGIN; sc->value = sc->nil; continue; + case OP_LET_TEMP_A: if (op_let_temp_a(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_S7_OPENLETS_UNWIND: op_let_temp_s7_openlets_unwind(sc); continue; + case OP_LET_TEMP_SETTER_UNWIND: op_let_temp_setter_unwind(sc); 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 goto G_G; /* selector is a symbol or constant, stupid "else" to shut up the compiler */ + + case OP_CASE_A_G_G: sc->value = fx_call(sc, cdr(sc->code)); + G_G: case OP_CASE_G_G: if (op_case_g_g(sc)) goto TOP_NO_POP; goto FEED_TO; + case OP_CASE_A_E_S: sc->value = fx_call(sc, cdr(sc->code)); + case OP_CASE_E_S: op_case_e_s(sc); goto EVAL; + 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)); + case OP_CASE_I_S: if (op_case_i_s(sc)) continue; goto EVAL; + case OP_CASE_A_G_S: sc->value = fx_call(sc, cdr(sc->code)); /* this almost never happens? */ + 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)); + 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: /* splitting this case out matters in lint */ + 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; else 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_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_A_I_S_A: sc->value = fx_case_a_i_s_a(sc, sc->code); continue; + case OP_CASE_A_E_S_A: sc->value = fx_case_a_e_s_a(sc, sc->code); continue; + case OP_CASE_A_G_S_A: sc->value = fx_case_a_g_s_a(sc, sc->code); continue; + case OP_CASE_A_S_G_A: sc->value = fx_case_a_s_g_a(sc, sc->code); continue; + + + case OP_ERROR_QUIT: + if (sc->stack_end <= sc->stack_start) stack_reset(sc); /* sets stack_end to stack_start, then pushes op_eval_done, (can <= be F); + + case OP_ERROR_HOOK_QUIT: + op_error_hook_quit(sc); + + 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 */ + sc->value = 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: + if (SHOW_EVAL_OPS) fprintf(stderr, " flush %s\n", op_names[sc->cur_op]); + continue; + + case OP_GET_OUTPUT_STRING: op_get_output_string(sc); /* from call-with-output-string|with-output-to-string; return the port string directly *//* 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_PROFILE_IN: g_profile_in(sc, set_plist_2(sc, cadr(sc->code), sc->curlet)); continue; + case OP_DYNAMIC_UNWIND_PROFILE: g_profile_out(sc, set_plist_1(sc, sc->args)); continue; + case OP_DYNAMIC_WIND: if (op_dynamic_wind(sc)) goto APPLY; continue; + case OP_DEACTIVATE_GOTO: call_exit_active(sc->args) = false; continue; /* deactivate the exiter */ + + case OP_WITH_LET_S: sc->value = fx_with_let_s(sc, sc->code); continue; + case OP_WITH_LET: if (!check_with_let(sc)) continue; + 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_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; + const s7_pointer port = current_input_port(sc); + c = port_read_white_space(port)(sc, port); + + READ_C: + switch (c) + { + case '(': + c = port_read_white_space(port)(sc, port); /* 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, port); break; + case '\'': sc->tok = token_quote; break; + case ';': sc->tok = port_read_semicolon(port)(sc, port); break; + case '"': sc->tok = token_double_quote; break; + case '`': sc->tok = token_back_quote; break; + case ',': sc->tok = read_comma(sc, port); break; + case '#': sc->tok = read_sharp(sc, port); break; + case '\0': case EOF: sc->tok = token_eof; break; + + default: /* read first element of list (ignore callgrind confusion -- this happens a lot) */ + c = read_start_list(sc, port, c); + goto READ_C; + } + if (sc->tok == token_atom) + { + c = read_atom(sc, port); + goto READ_C; + } + if (sc->tok == token_right_paren) + { + sc->value = sc->nil; + goto READ_LIST; + } + if (sc->tok == token_dot) + { + do {c = inchar(port);} while ((c != ')') && (c != EOF)); + read_error_nr(sc, "stray dot after '('?"); /* (car '( . )) */ + } + if (sc->tok == token_eof) + missing_close_paren_error_nr(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 (stack_top_op(sc) == OP_READ_LIST) goto POP_READ_LIST; + continue; + + case ')': + sc->tok = token_right_paren; + break; + + case '.': + sc->tok = read_dot(sc, port); /* dot or atom */ + break; + + case '\'': + sc->tok = token_quote; + /* might need check_stack_size(sc) here */ + push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); + sc->value = read_expression(sc); + continue; + + case ';': + sc->tok = port_read_semicolon(port)(sc, port); + 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 (stack_top_op(sc) == OP_READ_LIST) goto POP_READ_LIST; + continue; + + case ',': + sc->tok = read_comma(sc, port); /* 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, port); + break; + + case '\0': + case EOF: + missing_close_paren_error_nr(sc); + + default: + sc->strbuf[0] = (unsigned char)c; + sc->value = port_read_name(port)(sc, port); + 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; + case goto_start: + default: continue; + } + break; + + case token_eof: + if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: we should not be here\n", __func__, __LINE__); + missing_close_paren_error_nr(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 (stack_top_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_COMPLEX_VECTOR: if (op_read_complex_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; + case OP_UNOPT: + goto UNOPT; + default: + if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: eval unknown op: %d\n", __func__, __LINE__, (int)(sc->cur_op)); + return(sc->F); + } + + /* this code is reached from OP_CLEAR_OPTS and many others where the optimization has turned out to be incorrect, search for !c_function_is_ok -> break */ + if ((S7_DEBUGGING) && (tree_is_cyclic(sc, sc->code))) fprintf(stderr, "%s[%d]: cyclic %s\n", __func__, __LINE__, display(sc->code)); /* never hit? */ + clear_all_optimizations(sc, sc->code); + + UNOPT: + if (SHOW_EVAL_OPS) fprintf(stderr, " %d: unopt trailers %s\n", __LINE__, display_truncated(sc->code)); + set_current_code(sc, sc->code); + if (is_pair(sc->code)) + { + const s7_pointer head = T_Ext(car(sc->code)); + if (is_symbol(head)) /* car is a symbol, sc->code a list */ + { + if (is_syntactic_symbol(head)) + { + sc->cur_op = (opcode_t)symbol_syntax_op_checked(sc->code); + pair_set_syntax_op(sc->code, sc->cur_op); + goto TOP_NO_POP; + } + sc->value = lookup_global(sc, head); + set_optimize_op(sc->code, OP_PAIR_SYM); /* mostly stuff outside functions (unopt) */ + goto EVAL_ARGS_TOP; + } + if (is_pair(head)) /* ((if x y z) a b) etc */ + { + if (eval_car_pair(sc)) goto TOP_NO_POP; + goto EVAL; + } + if (is_syntax(head)) /* here we can get syntax objects like quote */ + { + sc->cur_op = syntax_opcode(head); + pair_set_syntax_op(sc->code, sc->cur_op); + goto TOP_NO_POP; + } + /* car is the function/sequence to be applied, or (for example) a syntax variable like quote that has been used locally */ + set_optimize_op(sc->code, OP_PAIR_ANY); /* usually an error: (#\a) etc, might be (#(0) 0) */ + sc->value = head; + /* here head can be a c_function (#_list-values, #_curlet, etc), a vector constant (etc), a closure (etc)... */ + /* this code is rarely called, so no need to pick out these cases here */ + /* fprintf(stderr, "%s[%d]: %s %s\n", __func__, __LINE__, s7_type_names[type(head)], display(sc->code)); */ + goto EVAL_ARGS_TOP; + } + if (is_normal_symbol(sc->code)) + { + sc->value = lookup_checked(sc, sc->code); + set_optimize_op(sc->code, OP_SYMBOL); + } + else + { + sc->value = sc->code; + set_optimize_op(sc->code, OP_CONSTANT); + }} /* continue */ + + if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: we should not be here\n", __func__, __LINE__); + return(sc->F); /* this never happens (make the compiler happy) */ +} + +static s7_pointer g_reader_cond(s7_scheme *sc, s7_pointer args) /* (reader-cond clause . clauses) */ +{ + #define H_reader_cond "(reader-cond clauses) is a read-time cond." + for (s7_pointer clauses = args; is_pair(clauses); clauses = cdr(clauses)) + { + const s7_pointer clause = car(clauses); + s7_pointer val; + if (!is_pair(clause)) + error_nr(sc, sc->syntax_error_symbol, set_elist_2(sc, wrap_string(sc, "reader-cond: clause is not a pair, ~S", 37), clause)); + val = s7_eval(sc, car(clause), sc->rootlet); + if (val != sc->F) + { + if (is_null(cdr(clause))) + return(val); + if (cadr(clause) == sc->feed_to_symbol) + { + s7_pointer func = s7_eval(sc, caddr(clause), sc->rootlet); + return(s7_apply_function(sc, func, list_1(sc, val))); + } + if (is_null(cddr(clause))) + return(cadr(clause)); + return(g_apply_values(sc, list_1(sc, cdr(clause)))); + }} + return(sc->no_value); } #if !WITH_PURE_S7 -static s7_pointer -cond_expand_clause_to_tree (s7_scheme* sc, s7_pointer clause) { - if (is_symbol (clause)) { - if ((clause == sc->or_symbol) || (clause == sc->and_symbol) || - (clause == sc->not_symbol)) - return (clause); - return (make_boolean ( - sc, is_a_feature (clause, global_value (sc->features_symbol)))); - } - if (!is_pair (clause)) - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_2 ( - sc, - wrap_string (sc, "cond-expand car(clause) entry is unexpected: ~S", - 47), - clause)); - return (cons (sc, cond_expand_clause_to_tree (sc, car (clause)), - (is_null (cdr (clause))) - ? sc->nil - : cond_expand_clause_to_tree (sc, cdr (clause)))); -} - -static s7_pointer -g_cond_expand (s7_scheme* sc, - s7_pointer args) /* (reader-cond clause . clauses) */ -{ -#define H_cond_expand \ - "(cond-expand clauses) is a way to use cond with *features* without " \ - "writing honest Scheme code." - if (!is_pair (args)) - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_1 (sc, wrap_string (sc, "cond-expand has no clauses?", 27))); - for (s7_pointer clauses= args; is_pair (clauses); clauses= cdr (clauses)) { - const s7_pointer clause= car (clauses); - if (!is_pair (clause)) - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_2 ( - sc, wrap_string (sc, "cond-expand clause is not a pair: ~S", 36), - clause)); - if (((is_symbol (car (clause))) && - ((car (clause) == sc->else_symbol) || - (is_a_feature (car (clause), global_value (sc->features_symbol))))) || - ((is_pair (car (clause))) && - (s7_eval (sc, cond_expand_clause_to_tree (sc, car (clause)), - sc->rootlet) == sc->T))) { - if (is_null (cddr (clause))) return (cadr (clause)); - return (g_apply_values (sc, list_1 (sc, cdr (clause)))); - } - else if ((!is_pair (car (clause))) && (!is_symbol (car (clause)))) - error_nr ( - sc, sc->syntax_error_symbol, - set_elist_2 ( - sc, - wrap_string ( - sc, "cond-expand car(clause) is not a symbol or a pair: ~S", - 53), - clause)); - } - return (sc->no_value); +static s7_pointer cond_expand_clause_to_tree(s7_scheme *sc, s7_pointer clause) +{ + if (is_symbol(clause)) + { + if ((clause == sc->or_symbol) || (clause == sc->and_symbol) || (clause == sc->not_symbol)) + return(clause); + return(make_boolean(sc, is_a_feature(clause, global_value(sc->features_symbol)))); + } + if (!is_pair(clause)) + error_nr(sc, sc->syntax_error_symbol, set_elist_2(sc, wrap_string(sc, "cond-expand car(clause) entry is unexpected: ~S", 47), clause)); + return(cons(sc, cond_expand_clause_to_tree(sc, car(clause)), + (is_null(cdr(clause))) ? sc->nil : cond_expand_clause_to_tree(sc, cdr(clause)))); +} + +static s7_pointer g_cond_expand(s7_scheme *sc, s7_pointer args) /* (reader-cond clause . clauses) */ +{ + #define H_cond_expand "(cond-expand clauses) is a way to use cond with *features* without writing honest Scheme code." + if (!is_pair(args)) + error_nr(sc, sc->syntax_error_symbol, set_elist_1(sc, wrap_string(sc, "cond-expand has no clauses?", 27))); + for (s7_pointer clauses = args; is_pair(clauses); clauses = cdr(clauses)) + { + const s7_pointer clause = car(clauses); + if (!is_pair(clause)) + error_nr(sc, sc->syntax_error_symbol, set_elist_2(sc, wrap_string(sc, "cond-expand clause is not a pair: ~S", 36), clause)); + if (((is_symbol(car(clause))) && + ((car(clause) == sc->else_symbol) || + (is_a_feature(car(clause), global_value(sc->features_symbol))))) || + ((is_pair(car(clause))) && + (s7_eval(sc, cond_expand_clause_to_tree(sc, car(clause)), sc->rootlet) == sc->T))) + { + if (is_null(cddr(clause))) + return(cadr(clause)); + return(g_apply_values(sc, list_1(sc, cdr(clause)))); + } + else + if ((!is_pair(car(clause))) && (!is_symbol(car(clause)))) + error_nr(sc, sc->syntax_error_symbol, set_elist_2(sc, wrap_string(sc, "cond-expand car(clause) is not a symbol or a pair: ~S", 53), clause)); + } + return(sc->no_value); } #endif -/* -------------------------------- s7_heap_scan - * -------------------------------- */ + +/* -------------------------------- s7_heap_scan -------------------------------- */ #if S7_DEBUGGING -static void -mark_holdee (s7_pointer holder, s7_pointer holdee, const char* root) { +static void mark_holdee(s7_pointer holder, s7_pointer holdee, const char *root) +{ holdee->holders++; - if (holder) holdee->holder= holder; - if (root) holdee->root= root; -} - -static void -mark_stack_holdees (s7_scheme* sc, s7_pointer stack, s7_int top) { - if (stack_elements (stack)) { - const s7_pointer heap0= *(sc->heap); - const s7_pointer heap1= (s7_pointer) (heap0 + sc->heap_size); - for (s7_pointer *tp = (s7_pointer*) (stack_elements (stack)), - *tend= (s7_pointer*) (tp + top); - (tp < tend); tp++) { - s7_pointer x= *tp++; - if ((x >= heap0) && (x < heap1)) mark_holdee (stack, x, "stack-code"); - x= *tp++; - if ((x >= heap0) && (x < heap1)) mark_holdee (stack, x, "stack-let"); - x= *tp++; - if ((x >= heap0) && (x < heap1)) mark_holdee (stack, x, "stack-args"); - } - } + if (holder) holdee->holder = holder; + if (root) holdee->root = root; } -static void -mark_hash_table_holdees (s7_scheme* sc, s7_pointer table) { - mark_holdee (table, hash_table_procedures (table), NULL); - if (is_pair (hash_table_procedures (table))) { - mark_holdee (table, hash_table_key_typer_unchecked (table), NULL); - mark_holdee (table, hash_table_value_typer_unchecked (table), NULL); - } - if (hash_table_entries (table) > 0) { - const s7_int len = (s7_int) hash_table_size (table); - hash_entry_t** entries= hash_table_elements (table); - hash_entry_t** last = (hash_entry_t**) (entries + len); - if ((is_weak_hash_table (table)) && (weak_hash_iters (table) == 0)) - while (entries < last) { - for (hash_entry_t* xp= *entries++; xp; xp= hash_entry_next (xp)) - mark_holdee (table, hash_entry_value (xp), NULL); - } - else - while (entries < last) - for (hash_entry_t* xp= *entries++; xp; xp= hash_entry_next (xp)) { - mark_holdee (table, hash_entry_key (xp), NULL); - mark_holdee (table, hash_entry_value (xp), NULL); - } - } +static void mark_stack_holdees(s7_scheme *sc, s7_pointer stack, s7_int top) +{ + if (stack_elements(stack)) + { + const s7_pointer heap0 = *(sc->heap); + const s7_pointer heap1 = (s7_pointer)(heap0 + sc->heap_size); + for (s7_pointer *tp = (s7_pointer *)(stack_elements(stack)), *tend = (s7_pointer *)(tp + top); (tp < tend); tp++) + { + s7_pointer x = *tp++; + if ((x >= heap0) && (x < heap1)) mark_holdee(stack, x, "stack-code"); + x = *tp++; + if ((x >= heap0) && (x < heap1)) mark_holdee(stack, x, "stack-let"); + x = *tp++; + if ((x >= heap0) && (x < heap1)) mark_holdee(stack, x, "stack-args"); + }} } -static void -save_holder_data (s7_scheme* sc, s7_pointer p) { - switch (type_unchecked (p)) { - case T_PAIR: - mark_holdee (p, car (p), NULL); - mark_holdee (p, cdr (p), NULL); - break; - case T_CATCH: - mark_holdee (p, catch_tag (p), NULL); - mark_holdee (p, catch_handler (p), NULL); - break; - case T_DYNAMIC_WIND: - mark_holdee (p, dynamic_wind_in (p), NULL); - mark_holdee (p, dynamic_wind_out (p), NULL); - mark_holdee (p, dynamic_wind_body (p), NULL); - break; - case T_INPUT_PORT: - mark_holdee (p, port_string_or_function (p), NULL); - break; - case T_OUTPUT_PORT: - if (is_function_port (p)) - mark_holdee (p, port_string_or_function (p), NULL); - break; - case T_C_POINTER: - mark_holdee (p, c_pointer_type (p), NULL); - mark_holdee (p, c_pointer_info (p), NULL); - break; - case T_COUNTER: - mark_holdee (p, counter_result (p), NULL); - mark_holdee (p, counter_list (p), NULL); - mark_holdee (p, counter_let (p), NULL); - break; - case T_STACK: - mark_stack_holdees (sc, p, - (p == sc->stack) ? stack_top (sc) : temp_stack_top (p)); - break; - case T_HASH_TABLE: - mark_hash_table_holdees (sc, p); - break; - - case T_ITERATOR: - mark_holdee (p, iterator_sequence (p), NULL); - if (has_carrier (p)) mark_holdee (p, iterator_carrier (p), NULL); - break; - - case T_SLOT: - mark_holdee (p, slot_value (p), NULL); - mark_holdee (p, slot_symbol (p), NULL); - if (slot_has_setter (p)) mark_holdee (p, slot_setter (p), NULL); - if (slot_has_pending_value (p)) - mark_holdee (p, slot_pending_value (p), NULL); - break; - - case T_VECTOR: - if (is_subvector (p)) mark_holdee (p, subvector_vector (p), NULL); - for (s7_int i= 0, len= vector_length (p); i < len; - i++) /* this apparently can be a stack as a vector? */ - if (s7_is_in_heap (sc, vector_element (p, i))) - mark_holdee (p, vector_element (p, i), NULL); - break; - - case T_INT_VECTOR: - case T_FLOAT_VECTOR: - case T_BYTE_VECTOR: - case T_COMPLEX_VECTOR: - if (is_subvector (p)) mark_holdee (p, subvector_vector (p), NULL); - break; - - case T_LET: - if (p != sc->rootlet) /* do rootlet later? */ - { - for (s7_pointer slot= let_slots (p); is_not_slot_end (slot); - slot = next_slot (slot)) - mark_holdee (p, slot, NULL); - if (has_dox_slot1 (p)) mark_holdee (p, let_dox_slot1 (p), NULL); - if ((has_dox_slot2 (p)) && (is_slot (let_dox_slot2 (p)))) - mark_holdee (p, let_dox_slot2 (p), NULL); - } - break; - - case T_C_FUNCTION_STAR: - if ((!c_func_has_simple_defaults (p)) && (c_function_call_args (p))) - for (s7_pointer arg= c_function_call_args (p); is_pair (arg); - arg = cdr (arg)) - mark_holdee (p, car (arg), NULL); - break; - - case T_CLOSURE: - case T_CLOSURE_STAR: - case T_MACRO: - case T_MACRO_STAR: - case T_BACRO: - case T_BACRO_STAR: - mark_holdee (p, closure_pars (p), NULL); - mark_holdee (p, closure_body (p), NULL); - mark_holdee (p, closure_let (p), NULL); - mark_holdee (p, closure_setter_or_map_list (p), NULL); - break; - - case T_CONTINUATION: - mark_holdee (p, continuation_op_stack (p), NULL); - mark_stack_holdees (sc, continuation_stack (p), continuation_stack_top (p)); - break; - - default: - break; /* includes T_C_OBJECT */ - } +static void mark_hash_table_holdees(s7_scheme *sc, s7_pointer table) +{ + mark_holdee(table, hash_table_procedures(table), NULL); + if (is_pair(hash_table_procedures(table))) + { + mark_holdee(table, hash_table_key_typer_unchecked(table), NULL); + mark_holdee(table, hash_table_value_typer_unchecked(table), NULL); + } + if (hash_table_entries(table) > 0) + { + const s7_int len = (s7_int)hash_table_size(table); + hash_entry_t **entries = hash_table_elements(table); + hash_entry_t **last = (hash_entry_t **)(entries + len); + if ((is_weak_hash_table(table)) && (weak_hash_iters(table) == 0)) + while (entries < last) + { + for (hash_entry_t *xp = *entries++; xp; xp = hash_entry_next(xp)) + mark_holdee(table, hash_entry_value(xp), NULL); + } + else + while (entries < last) + for (hash_entry_t *xp = *entries++; xp; xp = hash_entry_next(xp)) + { + mark_holdee(table, hash_entry_key(xp), NULL); + mark_holdee(table, hash_entry_value(xp), NULL); + }} +} + +static void save_holder_data(s7_scheme *sc, s7_pointer p) +{ + switch (type_unchecked(p)) + { + case T_PAIR: mark_holdee(p, car(p), NULL); mark_holdee(p, cdr(p), NULL); break; + case T_CATCH: mark_holdee(p, catch_tag(p), NULL); mark_holdee(p, catch_handler(p), NULL); break; + case T_DYNAMIC_WIND: mark_holdee(p, dynamic_wind_in(p), NULL); mark_holdee(p, dynamic_wind_out(p), NULL); mark_holdee(p, dynamic_wind_body(p), NULL); break; + case T_INPUT_PORT: mark_holdee(p, port_string_or_function(p), NULL); break; + case T_OUTPUT_PORT: if (is_function_port(p)) mark_holdee(p, port_string_or_function(p), NULL); break; + case T_C_POINTER: mark_holdee(p, c_pointer_type(p), NULL); mark_holdee(p, c_pointer_info(p), NULL); break; + case T_COUNTER: mark_holdee(p, counter_result(p), NULL); mark_holdee(p, counter_list(p), NULL); mark_holdee(p, counter_let(p), NULL); break; + case T_STACK: mark_stack_holdees(sc, p, (p == sc->stack) ? stack_top(sc) : temp_stack_top(p)); break; + case T_HASH_TABLE: mark_hash_table_holdees(sc, p); break; + + case T_ITERATOR: + mark_holdee(p, iterator_sequence(p), NULL); + if (has_carrier(p)) mark_holdee(p, iterator_carrier(p), NULL); + break; + + case T_SLOT: + mark_holdee(p, slot_value(p), NULL); + mark_holdee(p, slot_symbol(p), NULL); + if (slot_has_setter(p)) mark_holdee(p, slot_setter(p), NULL); + if (slot_has_pending_value(p)) mark_holdee(p, slot_pending_value(p), NULL); + break; + + case T_VECTOR: + if (is_subvector(p)) mark_holdee(p, subvector_vector(p), NULL); + for (s7_int i = 0, len = vector_length(p); i < len; i++) /* this apparently can be a stack as a vector? */ + if (s7_is_in_heap(sc, vector_element(p, i))) mark_holdee(p, vector_element(p, i), NULL); + break; + + case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_BYTE_VECTOR: case T_COMPLEX_VECTOR: + if (is_subvector(p)) mark_holdee(p, subvector_vector(p), NULL); + break; + + case T_LET: + if (p != sc->rootlet) /* do rootlet later? */ + { + for (s7_pointer slot = let_slots(p); is_not_slot_end(slot); slot = next_slot(slot)) mark_holdee(p, slot, NULL); + if (has_dox_slot1(p)) mark_holdee(p, let_dox_slot1(p), NULL); + if ((has_dox_slot2(p)) && (is_slot(let_dox_slot2(p)))) mark_holdee(p, let_dox_slot2(p), NULL); + } + break; + + case T_C_FUNCTION_STAR: + if ((!c_func_has_simple_defaults(p)) && (c_function_call_args(p))) + for (s7_pointer arg = c_function_call_args(p); is_pair(arg); arg = cdr(arg)) + mark_holdee(p, car(arg), NULL); + break; + + case T_CLOSURE: case T_CLOSURE_STAR: + case T_MACRO: case T_MACRO_STAR: + case T_BACRO: case T_BACRO_STAR: + mark_holdee(p, closure_pars(p), NULL); + mark_holdee(p, closure_body(p), NULL); + mark_holdee(p, closure_let(p), NULL); + mark_holdee(p, closure_setter_or_map_list(p), NULL); + break; + + case T_CONTINUATION: + mark_holdee(p, continuation_op_stack(p), NULL); + mark_stack_holdees(sc, continuation_stack(p), continuation_stack_top(p)); + break; + + default: break; /* includes T_C_OBJECT */ + } } -void s7_heap_analyze (s7_scheme* sc); -void -s7_heap_analyze (s7_scheme* sc) { +void s7_heap_analyze(s7_scheme *sc); +void s7_heap_analyze(s7_scheme *sc) +{ /* clear possible previous data */ - for (s7_int k= 0; k < sc->heap_size; k++) { - s7_pointer obj= sc->heap[k]; - obj->root = NULL; - obj->holders = 0; - obj->holder = NULL; - } + for (s7_int k = 0; k < sc->heap_size; k++) + { + s7_pointer obj = sc->heap[k]; + obj->root = NULL; + obj->holders = 0; + obj->holder = NULL; + } /* now parcel out all the holdings */ - for (s7_int k= 0; k < sc->heap_size; k++) - save_holder_data (sc, sc->heap[k]); + for (s7_int k = 0; k < sc->heap_size; k++) + save_holder_data(sc, sc->heap[k]); { - s7_pointer* tmps = sc->free_heap_top; - s7_pointer* 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) { - s7_pointer p= *tmps++; - mark_holdee (NULL, p, "gc temp"); - } - } - mark_holdee (NULL, sc->v, "sc->v"); - mark_holdee (NULL, sc->w, "sc->w"); - mark_holdee (NULL, sc->x, "sc->x"); - mark_holdee (NULL, sc->y, "sc->y"); - mark_holdee (NULL, sc->z, "sc->z"); - mark_holdee (NULL, sc->temp1, "sc->temp1"); - mark_holdee (NULL, sc->temp2, "sc->temp2"); - mark_holdee (NULL, sc->temp3, "sc->temp3"); - mark_holdee (NULL, sc->temp4, "sc->temp4"); - mark_holdee (NULL, sc->temp5, "sc->temp5"); - mark_holdee (NULL, sc->temp6, "sc->temp6"); - mark_holdee (NULL, sc->temp7, "sc->temp7"); - mark_holdee (NULL, sc->temp8, "sc->temp8"); - mark_holdee (NULL, sc->temp9, "sc->temp9"); - mark_holdee (NULL, sc->rec_p1, "sc->rec_p1"); - mark_holdee (NULL, sc->rec_p2, "sc->rec_p2"); - mark_holdee (NULL, car (sc->t1_1), "car(sc->t1_1)"); - mark_holdee (NULL, car (sc->t2_1), "car(sc->t2_1)"); - mark_holdee (NULL, car (sc->t2_2), "car(sc->t2_2)"); - mark_holdee (NULL, car (sc->t3_1), "car(sc->t3_1)"); - mark_holdee (NULL, car (sc->t3_2), "car(sc->t3_2)"); - mark_holdee (NULL, car (sc->t3_3), "car(sc->t3_3)"); - mark_holdee (NULL, car (sc->t4_1), "car(sc->t4_1)"); - mark_holdee (NULL, car (sc->u1_1), "car(sc->u1_1)"); - mark_holdee (NULL, car (sc->plist_1), "car(sc->plist_1)"); - mark_holdee (NULL, car (sc->plist_2), "car(sc->plist_2)"); - mark_holdee (NULL, car (sc->plist_3), "car(sc->plist_3)"); - mark_holdee (NULL, car (sc->plist_4), "car(sc->plist_4)"); - mark_holdee (NULL, car (sc->qlist_2), "car(sc->qlist_2)"); - mark_holdee (NULL, car (sc->qlist_3), "car(sc->qlist_3)"); - mark_holdee (NULL, car (sc->elist_1), "car(sc->elist_1)"); - mark_holdee (NULL, car (sc->elist_2), "car(sc->elist_2)"); - mark_holdee (NULL, car (sc->elist_3), "car(sc->elist_3)"); - mark_holdee (NULL, car (sc->elist_4), "car(sc->elist_4)"); - mark_holdee (NULL, car (sc->elist_5), "car(sc->elist_5)"); - mark_holdee (NULL, car (sc->elist_6), "car(sc->elist_6)"); - mark_holdee (NULL, car (sc->elist_7), "car(sc->elist_7)"); - mark_holdee (NULL, car (sc->plist_2_2), "cadr(sc->plist_2)"); - mark_holdee (NULL, cadr (sc->plist_3), "cadr(sc->plist_3)"); - mark_holdee (NULL, cadr (sc->elist_2), "cadr(sc->elist_2)"); - mark_holdee (NULL, cadr (sc->elist_3), "cadr(sc->elist_3)"); - mark_holdee (NULL, cadr (sc->qlist_2), "cadr(sc->qlist_2)"); - mark_holdee (NULL, caddr (sc->plist_3), "caddr(sc->plist_3)"); - mark_holdee (NULL, caddr (sc->elist_3), "caddr(sc->elist_3)"); - mark_holdee (NULL, sc->code, "sc->code"); - mark_holdee (NULL, sc->value, "sc->value"); - mark_holdee (NULL, sc->args, "sc->args"); - mark_holdee (NULL, sc->curlet, "sc->curlet"); - mark_holdee (NULL, sc->stack, "sc->stack"); - mark_holdee (NULL, sc->default_random_state, "sc->default_random_state"); - mark_holdee (NULL, sc->temp_error_hook, "sc->temp_error_hook"); - mark_holdee (NULL, sc->stacktrace_defaults, "sc->stacktrace_defaults"); - mark_holdee (NULL, sc->protected_objects, "sc->protected_objects"); - mark_holdee (NULL, sc->protected_setters, "sc->protected_setters"); - mark_holdee (NULL, sc->protected_setter_symbols, - "sc->protected_setter_symbols"); - mark_holdee (NULL, sc->error_type, "sc->error_type"); - mark_holdee (NULL, sc->error_data, "sc->error_data"); - mark_holdee (NULL, sc->error_code, "sc->error_code"); - mark_holdee (NULL, sc->error_line, "sc->error_line"); - mark_holdee (NULL, sc->error_file, "sc->error_file"); - mark_holdee (NULL, sc->error_position, "sc->error_position"); + s7_pointer *tmps = sc->free_heap_top; + s7_pointer *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) + { + s7_pointer p = *tmps++; + mark_holdee(NULL, p, "gc temp"); + }} + mark_holdee(NULL, sc->v, "sc->v"); + mark_holdee(NULL, sc->w, "sc->w"); + mark_holdee(NULL, sc->x, "sc->x"); + mark_holdee(NULL, sc->y, "sc->y"); + mark_holdee(NULL, sc->z, "sc->z"); + mark_holdee(NULL, sc->temp1, "sc->temp1"); + mark_holdee(NULL, sc->temp2, "sc->temp2"); + mark_holdee(NULL, sc->temp3, "sc->temp3"); + mark_holdee(NULL, sc->temp4, "sc->temp4"); + mark_holdee(NULL, sc->temp5, "sc->temp5"); + mark_holdee(NULL, sc->temp6, "sc->temp6"); + mark_holdee(NULL, sc->temp7, "sc->temp7"); + mark_holdee(NULL, sc->temp8, "sc->temp8"); + mark_holdee(NULL, sc->temp9, "sc->temp9"); + mark_holdee(NULL, sc->rec_p1, "sc->rec_p1"); + mark_holdee(NULL, sc->rec_p2, "sc->rec_p2"); + mark_holdee(NULL, car(sc->t1_1), "car(sc->t1_1)"); + mark_holdee(NULL, car(sc->t2_1), "car(sc->t2_1)"); + mark_holdee(NULL, car(sc->t2_2), "car(sc->t2_2)"); + mark_holdee(NULL, car(sc->t3_1), "car(sc->t3_1)"); + mark_holdee(NULL, car(sc->t3_2), "car(sc->t3_2)"); + mark_holdee(NULL, car(sc->t3_3), "car(sc->t3_3)"); + mark_holdee(NULL, car(sc->t4_1), "car(sc->t4_1)"); + mark_holdee(NULL, car(sc->u1_1), "car(sc->u1_1)"); + mark_holdee(NULL, car(sc->plist_1), "car(sc->plist_1)"); + mark_holdee(NULL, car(sc->plist_2), "car(sc->plist_2)"); + mark_holdee(NULL, car(sc->plist_3), "car(sc->plist_3)"); + mark_holdee(NULL, car(sc->plist_4), "car(sc->plist_4)"); + mark_holdee(NULL, car(sc->qlist_2), "car(sc->qlist_2)"); + mark_holdee(NULL, car(sc->qlist_3), "car(sc->qlist_3)"); + mark_holdee(NULL, car(sc->elist_1), "car(sc->elist_1)"); + mark_holdee(NULL, car(sc->elist_2), "car(sc->elist_2)"); + mark_holdee(NULL, car(sc->elist_3), "car(sc->elist_3)"); + mark_holdee(NULL, car(sc->elist_4), "car(sc->elist_4)"); + mark_holdee(NULL, car(sc->elist_5), "car(sc->elist_5)"); + mark_holdee(NULL, car(sc->elist_6), "car(sc->elist_6)"); + mark_holdee(NULL, car(sc->elist_7), "car(sc->elist_7)"); + mark_holdee(NULL, car(sc->plist_2_2), "cadr(sc->plist_2)"); + mark_holdee(NULL, cadr(sc->plist_3), "cadr(sc->plist_3)"); + mark_holdee(NULL, cadr(sc->elist_2), "cadr(sc->elist_2)"); + mark_holdee(NULL, cadr(sc->elist_3), "cadr(sc->elist_3)"); + mark_holdee(NULL, cadr(sc->qlist_2), "cadr(sc->qlist_2)"); + mark_holdee(NULL, caddr(sc->plist_3), "caddr(sc->plist_3)"); + mark_holdee(NULL, caddr(sc->elist_3), "caddr(sc->elist_3)"); + mark_holdee(NULL, sc->code, "sc->code"); + mark_holdee(NULL, sc->value, "sc->value"); + mark_holdee(NULL, sc->args, "sc->args"); + mark_holdee(NULL, sc->curlet, "sc->curlet"); + mark_holdee(NULL, sc->stack, "sc->stack"); + mark_holdee(NULL, sc->default_random_state, "sc->default_random_state"); + mark_holdee(NULL, sc->temp_error_hook, "sc->temp_error_hook"); + mark_holdee(NULL, sc->stacktrace_defaults, "sc->stacktrace_defaults"); + mark_holdee(NULL, sc->protected_objects, "sc->protected_objects"); + mark_holdee(NULL, sc->protected_setters, "sc->protected_setters"); + mark_holdee(NULL, sc->protected_setter_symbols, "sc->protected_setter_symbols"); + mark_holdee(NULL, sc->error_type, "sc->error_type"); + mark_holdee(NULL, sc->error_data, "sc->error_data"); + mark_holdee(NULL, sc->error_code, "sc->error_code"); + mark_holdee(NULL, sc->error_line, "sc->error_line"); + mark_holdee(NULL, sc->error_file, "sc->error_file"); + mark_holdee(NULL, sc->error_position, "sc->error_position"); #if WITH_HISTORY - mark_holdee (NULL, sc->error_history, "sc->error_history"); + mark_holdee(NULL, sc->error_history, "sc->error_history"); #endif - for (gc_obj_t* g= sc->semipermanent_objects; g; g= (gc_obj_t*) (g->nxt)) - mark_holdee (NULL, g->p, "permanent object"); + for (gc_obj_t *g = sc->semipermanent_objects; g; g = (gc_obj_t *)(g->nxt)) + mark_holdee(NULL, g->p, "permanent object"); - for (s7_int i= 0; i < sc->protected_objects_size; i++) - if (vector_element (sc->protected_objects, i) != sc->unused) - mark_holdee (NULL, vector_element (sc->protected_objects, i), - "gc protected object"); + for (s7_int i = 0; i < sc->protected_objects_size; i++) + if (vector_element(sc->protected_objects, i) != sc->unused) + mark_holdee(NULL, vector_element(sc->protected_objects, i), "gc protected object"); - for (s7_int i= 0; i < sc->protected_setters_loc; i++) - mark_holdee (NULL, vector_element (sc->protected_setters, i), - "gc protected setter"); + for (s7_int i = 0; i < sc->protected_setters_loc; i++) + mark_holdee(NULL, vector_element(sc->protected_setters, i), "gc protected setter"); - for (s7_int i= 0; i < sc->setters_loc; i++) - mark_holdee (NULL, cdr (sc->setters[i]), "setter"); + for (s7_int i = 0; i < sc->setters_loc; i++) + mark_holdee(NULL, cdr(sc->setters[i]), "setter"); - for (s7_int i= 0; i <= sc->format_depth; i++) + for (s7_int i = 0; i <= sc->format_depth; i++) if (sc->fdats[i]) - mark_holdee (NULL, sc->fdats[i]->curly_arg, "fdat curly_arg"); + mark_holdee(NULL, sc->fdats[i]->curly_arg, "fdat curly_arg"); { - s7_pointer* tp= - (s7_pointer*) (sc->input_port_stack + sc->input_port_stack_loc); - for (s7_pointer* p= sc->input_port_stack; p < tp; p++) - mark_holdee (NULL, *p, "input stack"); + s7_pointer *tp = (s7_pointer *)(sc->input_port_stack + sc->input_port_stack_loc); + for (s7_pointer *p = sc->input_port_stack; p < tp; p++) + mark_holdee(NULL, *p, "input stack"); } { - s7_pointer* p = sc->op_stack; - s7_pointer* tp= sc->op_stack_now; - while (p < tp) { - s7_pointer x= *p++; - mark_holdee (NULL, x, "op stack"); - } + s7_pointer *p = sc->op_stack; + s7_pointer *tp = sc->op_stack_now; + while (p < tp) {s7_pointer x = *p++; mark_holdee(NULL, x, "op stack");} } if (sc->rec_stack) - for (s7_int i= 0; i < sc->rec_loc; i++) - mark_holdee (NULL, sc->rec_els[i], "sc->rec_els"); + for (s7_int i = 0; i < sc->rec_loc; i++) + mark_holdee(NULL, sc->rec_els[i], "sc->rec_els"); { - gc_list_t* gp= sc->opt1_funcs; - for (s7_int i= 0; i < gp->loc; i++) { - s7_pointer p= T_Pair (gp->list[i]); - mark_holdee (NULL, opt1_any (p), "opt1_funcs"); - } - } - for (int32_t i= 1; i < NUM_SAFE_LISTS; i++) - if ((is_pair (sc->safe_lists[i])) && - (safe_list_is_in_use (sc->safe_lists[i]))) - for (s7_pointer p= sc->safe_lists[i]; is_pair (p); p= cdr (p)) - mark_holdee (NULL, car (p), "safe_lists"); - - for (s7_pointer p= sc->wrong_type_arg_info; is_pair (p); p= cdr (p)) - mark_holdee (NULL, car (p), "wrong-type-arg"); - for (s7_pointer p= sc->sole_arg_wrong_type_info; is_pair (p); p= cdr (p)) - mark_holdee (NULL, car (p), "simple wrong-type-arg"); - for (s7_pointer p= sc->out_of_range_info; is_pair (p); p= cdr (p)) - mark_holdee (NULL, car (p), "out-of-range"); - for (s7_pointer p= sc->sole_arg_out_of_range_info; is_pair (p); p= cdr (p)) - mark_holdee (NULL, car (p), "simple out-of-range"); - for (s7_pointer slot= sc->rootlet_slots; is_not_slot_end (slot); - slot = next_slot (slot)) - mark_holdee (slot, slot_value (slot), symbol_name (slot_symbol (slot))); + gc_list_t *gp = sc->opt1_funcs; + for (s7_int i = 0; i < gp->loc; i++) + { + s7_pointer p = T_Pair(gp->list[i]); + mark_holdee(NULL, opt1_any(p), "opt1_funcs"); + }} + for (int32_t i = 1; i < NUM_SAFE_LISTS; i++) + if ((is_pair(sc->safe_lists[i])) && + (safe_list_is_in_use(sc->safe_lists[i]))) + for (s7_pointer p = sc->safe_lists[i]; is_pair(p); p = cdr(p)) + mark_holdee(NULL, car(p), "safe_lists"); + + for (s7_pointer p = sc->wrong_type_arg_info; is_pair(p); p = cdr(p)) mark_holdee(NULL, car(p), "wrong-type-arg"); + for (s7_pointer p = sc->sole_arg_wrong_type_info; is_pair(p); p = cdr(p)) mark_holdee(NULL, car(p), "simple wrong-type-arg"); + for (s7_pointer p = sc->out_of_range_info; is_pair(p); p = cdr(p)) mark_holdee(NULL, car(p), "out-of-range"); + for (s7_pointer p = sc->sole_arg_out_of_range_info; is_pair(p); p = cdr(p)) mark_holdee(NULL, car(p), "simple out-of-range"); + for (s7_pointer slot = sc->rootlet_slots; is_not_slot_end(slot); slot = next_slot(slot)) mark_holdee(slot, slot_value(slot), symbol_name(slot_symbol(slot))); #if WITH_HISTORY - for (s7_pointer p1= sc->eval_history1, p2= sc->eval_history2, - p3= sc->history_pairs; - ; p2= cdr (p2), p3= cdr (p3)) { - mark_holdee (NULL, car (p1), "eval history1"); - mark_holdee (NULL, car (p2), "eval history2"); - mark_holdee (NULL, car (p3), "eval history3"); - p1= cdr (p1); - if (p1 == sc->eval_history1) break; - } + for (s7_pointer p1 = sc->eval_history1, p2 = sc->eval_history2, p3 = sc->history_pairs; ; p2 = cdr(p2), p3 = cdr(p3)) + { + mark_holdee(NULL, car(p1), "eval history1"); + mark_holdee(NULL, car(p2), "eval history2"); + mark_holdee(NULL, car(p3), "eval history3"); + p1 = cdr(p1); + if (p1 == sc->eval_history1) break; + } #else - mark_holdee (NULL, sc->cur_code, "current code"); + mark_holdee(NULL, sc->cur_code, "current code"); #endif } -void s7_heap_scan (s7_scheme* sc, int32_t typ); -void -s7_heap_scan (s7_scheme* sc, int32_t typ) { - bool found_one= false; - for (s7_int k= 0; k < sc->heap_size; k++) { - const s7_pointer obj= sc->heap[k]; - if (type_unchecked (obj) == typ) { - found_one= true; - if (obj->holders == 0) - fprintf (stderr, "%s found no holder (alloc: %s[%d])\n", - display_truncated (obj), obj->alloc_func, obj->alloc_line); - else if (!obj->holder) - fprintf (stderr, - "%s has built-in holder (holders: %d, alloc: %s[%d])\n", - display_truncated (obj), obj->holders, obj->alloc_func, - obj->alloc_line); - else if (obj->root) - fprintf (stderr, - "%s from %s alloc: %s[%d] (%d holder%s, alloc: %s[%d])\n", - display_truncated (obj), obj->root, obj->alloc_func, - obj->alloc_line, obj->holders, (obj->holders != 1) ? "s" : "", - obj->holder->alloc_func, obj->holder->alloc_line); - else - fprintf (stderr, - "%s (%s, alloc: %s[%d], holder%s: %d %p %s alloc: %s[%d])\n", - display_truncated (obj), - s7_type_names[type_unchecked (obj->holder)], obj->alloc_func, - obj->alloc_line, (obj->holders != 1) ? "s" : "", obj->holders, - obj->holder, display (obj->holder), obj->holder->alloc_func, - obj->holder->alloc_line); - } - } - if (!found_one) - fprintf (stderr, "heap-scan: no %s found\n", s7_type_names[typ]); -} - -static s7_pointer -g_heap_scan (s7_scheme* sc, s7_pointer args) { -#define H_heap_scan \ - "(heap-scan type) scans the heap for objects of type and reports info " \ - "about them" -#define Q_heap_scan \ - s7_make_signature (sc, 2, sc->not_symbol, sc->is_integer_symbol) - const s7_pointer typ= car (args); - if (!s7_is_integer (typ)) - sole_arg_wrong_type_error_nr (sc, make_symbol (sc, "heap-scan", 9), typ, - sc->type_names[T_INTEGER]); - if ((s7_integer (typ) <= 0) || (s7_integer (typ) >= NUM_TYPES)) - sole_arg_out_of_range_error_nr (sc, make_symbol (sc, "heap-scan", 9), typ, - wrap_string (sc, "0 < type < 48", 13)); - s7_heap_scan (sc, (int32_t) s7_integer (typ)); /* 0..48 currently */ - return (sc->F); +void s7_heap_scan(s7_scheme *sc, int32_t typ); +void s7_heap_scan(s7_scheme *sc, int32_t typ) +{ + bool found_one = false; + for (s7_int k = 0; k < sc->heap_size; k++) + { + const s7_pointer obj = sc->heap[k]; + if (type_unchecked(obj) == typ) + { + found_one = true; + if (obj->holders == 0) + fprintf(stderr, "%s found no holder (alloc: %s[%d])\n", display_truncated(obj), obj->alloc_func, obj->alloc_line); + else + if (!obj->holder) + fprintf(stderr, "%s has built-in holder (holders: %d, alloc: %s[%d])\n", display_truncated(obj), obj->holders, obj->alloc_func, obj->alloc_line); + else + if (obj->root) + fprintf(stderr, "%s from %s alloc: %s[%d] (%d holder%s, alloc: %s[%d])\n", + display_truncated(obj), obj->root, obj->alloc_func, obj->alloc_line, + obj->holders, (obj->holders != 1) ? "s" : "", obj->holder->alloc_func, obj->holder->alloc_line); + else fprintf(stderr, "%s (%s, alloc: %s[%d], holder%s: %d %p %s alloc: %s[%d])\n", + display_truncated(obj), s7_type_names[type_unchecked(obj->holder)], obj->alloc_func, obj->alloc_line, + (obj->holders != 1) ? "s" : "", obj->holders, obj->holder, display(obj->holder), obj->holder->alloc_func, obj->holder->alloc_line); + }} + if (!found_one) + fprintf(stderr, "heap-scan: no %s found\n", s7_type_names[typ]); +} + +static s7_pointer g_heap_scan(s7_scheme *sc, s7_pointer args) +{ + #define H_heap_scan "(heap-scan type) scans the heap for objects of type and reports info about them" + #define Q_heap_scan s7_make_signature(sc, 2, sc->not_symbol, sc->is_integer_symbol) + const s7_pointer typ = car(args); + if (!s7_is_integer(typ)) + sole_arg_wrong_type_error_nr(sc, make_symbol(sc, "heap-scan", 9), typ, sc->type_names[T_INTEGER]); + if ((s7_integer(typ) <= 0) || (s7_integer(typ) >= NUM_TYPES)) + sole_arg_out_of_range_error_nr(sc, make_symbol(sc, "heap-scan", 9), typ, wrap_string(sc, "0 < type < 48", 13)); + s7_heap_scan(sc, (int32_t)s7_integer(typ)); /* 0..48 currently */ + return(sc->F); } /* g_heap_analyze migrated to s7_scheme_predicate.c */ #define H_heap_analyze "(heap-analyze) gets heap data for subsequent heap-scan" -#define Q_heap_analyze s7_make_signature (sc, 1, sc->not_symbol) +#define Q_heap_analyze s7_make_signature(sc, 1, sc->not_symbol) /* bridge for g_heap_analyze migration */ -void -s7i_heap_analyze (s7_scheme* sc) { - s7_heap_analyze (sc); +void s7i_heap_analyze(s7_scheme *sc) +{ + s7_heap_analyze(sc); } /* g_heap_holder migrated to s7_scheme_predicate.c */ #define H_heap_holder "(heap-holder obj) returns the object pointing to obj" -#define Q_heap_holder s7_make_signature (sc, 2, sc->T, sc->T) +#define Q_heap_holder s7_make_signature(sc, 2, sc->T, sc->T) /* bridge for g_heap_holder migration */ -s7_pointer -s7i_heap_holder_p_p (s7_scheme* sc, s7_pointer obj) { - if ((obj->holders == 0) || ((!(obj->holder)) && (!(obj->root)))) - return (sc->F); - return ((obj->holder) ? obj->holder : s7_make_string (sc, obj->root)); +s7_pointer s7i_heap_holder_p_p(s7_scheme *sc, s7_pointer obj) +{ + if ((obj->holders == 0) || ((!(obj->holder)) && (!(obj->root)))) return(sc->F); + return((obj->holder) ? obj->holder : s7_make_string(sc, obj->root)); } /* g_heap_holders migrated to s7_scheme_predicate.c */ -#define H_heap_holders \ - "(heap-holders obj) returns the number of objects pointing to obj" -#define Q_heap_holders s7_make_signature (sc, 2, sc->is_integer_symbol, sc->T) +#define H_heap_holders "(heap-holders obj) returns the number of objects pointing to obj" +#define Q_heap_holders s7_make_signature(sc, 2, sc->is_integer_symbol, sc->T) /* bridge for g_heap_holders migration */ -s7_int -s7i_heap_holders (s7_pointer obj) { - return (obj->holders); +s7_int s7i_heap_holders(s7_pointer obj) +{ + return(obj->holders); } /* random debugging stuff */ -static s7_pointer -g_show_stack (s7_scheme* sc, s7_pointer args) { -#define H_show_stack "(show-stack ((limit 20)))" -#define Q_show_stack \ - s7_make_signature (sc, 2, sc->not_symbol, sc->is_integer_symbol) - if ((!is_null (args)) && (s7_is_integer (car (args)))) { - s7_int old_limit = sc->max_show_stack_frames; - sc->max_show_stack_frames= s7_integer (car (args)); - s7_show_stack (sc); - sc->max_show_stack_frames= old_limit; - } - else s7_show_stack (sc); - return (sc->F); +static s7_pointer g_show_stack(s7_scheme *sc, s7_pointer args) +{ + #define H_show_stack "(show-stack ((limit 20)))" + #define Q_show_stack s7_make_signature(sc, 2, sc->not_symbol, sc->is_integer_symbol) + if ((!is_null(args)) && (s7_is_integer(car(args)))) + { + s7_int old_limit = sc->max_show_stack_frames; + sc->max_show_stack_frames = s7_integer(car(args)); + s7_show_stack(sc); + sc->max_show_stack_frames = old_limit; + } + else s7_show_stack(sc); + return(sc->F); } -void s7_show_op_stack (s7_scheme* sc); -void -s7_show_op_stack (s7_scheme* sc) { - if (sc->op_stack < sc->op_stack_now) { - fprintf (stderr, "op_stack:\n"); - for (s7_pointer *p= sc->op_stack, *tp= sc->op_stack_now; (p < tp); p++) - fprintf (stderr, " %s\n", display (*p)); - } - else fprintf (stderr, "op_stack is empty\n"); +void s7_show_op_stack(s7_scheme *sc); +void s7_show_op_stack(s7_scheme *sc) +{ + if (sc->op_stack < sc->op_stack_now) + { + fprintf(stderr, "op_stack:\n"); + for (s7_pointer *p = sc->op_stack, *tp = sc->op_stack_now; (p < tp); p++) + fprintf(stderr, " %s\n", display(*p)); + } + else fprintf(stderr, "op_stack is empty\n"); } /* g_show_op_stack migrated to s7_scheme_predicate.c */ #define H_show_op_stack "(show-op-stack) displays the current op_stack" -#define Q_show_op_stack s7_make_signature (sc, 1, sc->not_symbol) +#define Q_show_op_stack s7_make_signature(sc, 1, sc->not_symbol) /* bridge for g_show_op_stack migration */ -void -s7i_show_op_stack (s7_scheme* sc) { - s7_show_op_stack (sc); +void s7i_show_op_stack(s7_scheme *sc) +{ + s7_show_op_stack(sc); } /* g_is_op_stack migrated to s7_scheme_predicate.c */ -#define H_is_op_stack \ - "(op-stack?) returns #t if there are entries in the op_stack" -#define Q_is_op_stack s7_make_signature (sc, 1, sc->is_boolean_symbol) +#define H_is_op_stack "(op-stack?) returns #t if there are entries in the op_stack" +#define Q_is_op_stack s7_make_signature(sc, 1, sc->is_boolean_symbol) /* bridge for g_is_op_stack migration */ -bool -s7i_is_op_stack_active (s7_scheme* sc) { - return (sc->op_stack < sc->op_stack_now); +bool s7i_is_op_stack_active(s7_scheme *sc) +{ + return(sc->op_stack < sc->op_stack_now); } #endif + /* -------------------------------- *s7* let -------------------------------- */ -static s7_int -starlet_length (void) { - return (sl_num_fields - 1); -} - -static s7_pointer -g_starlet_set_fallback (s7_scheme* sc, s7_pointer args) { - s7_pointer sym= cadr (args); - if (!is_symbol (sym)) - sole_arg_wrong_type_error_nr (sc, sc->let_set_symbol, sym, - sc->type_names[T_SYMBOL]); - if (starlet_symbol_id (sym) == sl_no_field) - error_nr ( - 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 (starlet_set_1 (sc, sym, caddr (args))); -} - -static s7_pointer g_starlet_ref_fallback (s7_scheme* sc, s7_pointer args); - -static s7_pointer -make_starlet (s7_scheme* sc) /* *s7* is semipermanent -- 20-May-21 */ -{ - const s7_pointer slot1= make_semipermanent_slot ( - sc, sc->let_set_fallback_symbol, - s7_make_function (sc, "#<*s7*-set>", g_starlet_set_fallback, 3, 0, false, - "*s7* writer")); - const s7_pointer slot2= make_semipermanent_slot ( - sc, sc->let_ref_fallback_symbol, - s7_make_function (sc, "#<*s7*-ref>", g_starlet_ref_fallback, 2, 0, false, - "*s7* reader")); - const s7_pointer star= alloc_pointer (sc); - set_full_type (star, T_LET | T_SAFE_PROCEDURE | T_UNHEAP | T_HAS_METHODS | - T_HAS_LET_REF_FALLBACK | T_HAS_LET_SET_FALLBACK); - let_set_id (star, ++sc->let_number); - let_set_outlet (star, sc->rootlet); - symbol_set_local_slot (sc->let_set_fallback_symbol, sc->let_number, slot1); - slot_set_next (slot1, slot_end); - symbol_set_local_slot (sc->let_ref_fallback_symbol, sc->let_number, slot2); - slot_set_next (slot2, slot1); - let_set_slots (star, slot2); - set_immutable_slot ( - slot1); /* make the *s7* let-ref|set! fallbacks immutable */ - set_immutable_slot (slot2); - set_immutable_let (star); - sc->starlet_symbol= s7_define_constant ( - sc, "*s7*", - s7_openlet (sc, star)); /* define_constant returns the symbol */ - if ((S7_DEBUGGING) && (sl_num_fields >= 256)) - fprintf (stderr, "too many *s7* fields!\n"); - for (int32_t i= 1; i < (int32_t) sl_num_fields; i++) { - s7_pointer sym= make_symbol_with_strlen (sc, starlet_names[i]); - starlet_symbol_set_id (sym, (starlet_t) i); - } - return (star); +static s7_int starlet_length(void) {return(sl_num_fields - 1);} + +static s7_pointer g_starlet_set_fallback(s7_scheme *sc, s7_pointer args) +{ + s7_pointer sym = cadr(args); + if (!is_symbol(sym)) + sole_arg_wrong_type_error_nr(sc, sc->let_set_symbol, sym, sc->type_names[T_SYMBOL]); + if (starlet_symbol_id(sym) == sl_no_field) + error_nr(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(starlet_set_1(sc, sym, caddr(args))); +} + +static s7_pointer g_starlet_ref_fallback(s7_scheme *sc, s7_pointer args); + +static s7_pointer make_starlet(s7_scheme *sc) /* *s7* is semipermanent -- 20-May-21 */ +{ + const s7_pointer slot1 = make_semipermanent_slot(sc, sc->let_set_fallback_symbol, s7_make_function(sc, "#<*s7*-set>", g_starlet_set_fallback, 3, 0, false, "*s7* writer")); + const s7_pointer slot2 = make_semipermanent_slot(sc, sc->let_ref_fallback_symbol, s7_make_function(sc, "#<*s7*-ref>", g_starlet_ref_fallback, 2, 0, false, "*s7* reader")); + const s7_pointer star = alloc_pointer(sc); + set_full_type(star, T_LET | T_SAFE_PROCEDURE | T_UNHEAP | T_HAS_METHODS | T_HAS_LET_REF_FALLBACK | T_HAS_LET_SET_FALLBACK); + let_set_id(star, ++sc->let_number); + let_set_outlet(star, sc->rootlet); + symbol_set_local_slot(sc->let_set_fallback_symbol, sc->let_number, slot1); + slot_set_next(slot1, slot_end); + symbol_set_local_slot(sc->let_ref_fallback_symbol, sc->let_number, slot2); + slot_set_next(slot2, slot1); + let_set_slots(star, slot2); + set_immutable_slot(slot1); /* make the *s7* let-ref|set! fallbacks immutable */ + set_immutable_slot(slot2); + set_immutable_let(star); + sc->starlet_symbol = s7_define_constant(sc, "*s7*", s7_openlet(sc, star)); /* define_constant returns the symbol */ + if ((S7_DEBUGGING) && (sl_num_fields >= 256)) fprintf(stderr, "too many *s7* fields!\n"); + for (int32_t i = 1; i < (int32_t)sl_num_fields; i++) + { + s7_pointer sym = make_symbol_with_strlen(sc, starlet_names[i]); + starlet_symbol_set_id(sym, (starlet_t)i); + } + return(star); } -static void -add_symbol_table (s7_scheme* sc, s7_pointer mu_let) { +static void add_symbol_table(s7_scheme *sc, s7_pointer mu_let) +{ /* check the symbol table, counting gensyms etc */ - s7_int num_syms= 0, gens= 0, keys= 0, mx_list= 0, mxs= 0; - s7_pointer* els= vector_elements (sc->symbol_table); - for (s7_int i= 0; i < SYMBOL_TABLE_SIZE; i++) { - s7_int k= 0; - for (s7_pointer syms= els[i]; is_pair (syms); syms= cdr (syms), k++) { - num_syms++; - if (is_gensym (car (syms))) gens++; - if (is_keyword (car (syms))) keys++; - } - if (k > mx_list) { - mx_list= k; - mxs = 1; - } - else if (k == mx_list) mxs++; - } - add_slot_unchecked_with_id ( - sc, mu_let, sc->symbol_table_symbol, - s7_inlet ( - sc, s7_list ( - sc, 10, sc->size_symbol, make_integer (sc, SYMBOL_TABLE_SIZE), - make_symbol (sc, "max-bin", 7), - cons (sc, make_integer (sc, mx_list), make_integer (sc, mxs)), - make_symbol (sc, "symbols", 7), - cons (sc, make_integer (sc, num_syms), - make_integer (sc, num_syms - gens - keys)), - make_symbol (sc, "gensyms", 7), make_integer (sc, gens), - make_symbol (sc, "keys", 4), make_integer (sc, keys)))); -} - -static s7_pointer -kmg (s7_scheme* sc, s7_int bytes) { - block_t* b= mallocate (sc, 128); - int32_t len; + s7_int num_syms = 0, gens = 0, keys = 0, mx_list = 0, mxs = 0; + s7_pointer *els = vector_elements(sc->symbol_table); + for (s7_int i = 0; i < SYMBOL_TABLE_SIZE; i++) + { + s7_int k = 0; + for (s7_pointer syms = els[i]; is_pair(syms); syms = cdr(syms), k++) + { + num_syms++; + if (is_gensym(car(syms))) gens++; + if (is_keyword(car(syms))) keys++; + } + if (k > mx_list) {mx_list = k; mxs = 1;} + else if (k == mx_list) mxs++; + } + add_slot_unchecked_with_id(sc, mu_let, sc->symbol_table_symbol, + s7_inlet(sc, + s7_list(sc, 10, + sc->size_symbol, make_integer(sc, SYMBOL_TABLE_SIZE), + make_symbol(sc, "max-bin", 7), cons(sc, make_integer(sc, mx_list), make_integer(sc, mxs)), + make_symbol(sc, "symbols", 7), cons(sc, make_integer(sc, num_syms), make_integer(sc, num_syms - gens - keys)), + make_symbol(sc, "gensyms", 7), make_integer(sc, gens), + make_symbol(sc, "keys", 4), make_integer(sc, keys)))); +} + +static s7_pointer kmg(s7_scheme *sc, s7_int bytes) +{ + block_t *b = mallocate(sc, 128); + int32_t len; 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); + len = snprintf((char *)block_data(b), 128, "%" ld64, bytes); 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))); + 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 void -add_gc_list_sizes (s7_scheme* sc, s7_pointer mu_let) { - /* check the gc lists (finalizations), at startup there are - * strings/input-strings from the s7_eval_c_string calls for make-hook et el - */ - const s7_int 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->multivectors->size + sc->weak_refs->size + - sc->weak_hash_iterators->size + sc->opt1_funcs->size; - - const int32_t 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->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", 8), - s7_inlet ( - sc, - s7_list ( - sc, 6, make_symbol (sc, "active/total", 12), - cons (sc, make_integer (sc, loc), make_integer (sc, len)), - make_symbol (sc, "total-bytes", 11), - kmg (sc, len * sizeof (s7_pointer)), make_symbol (sc, "lists", 5), - s7_inlet ( - sc, - s7_list ( - sc, 28, sc->string_symbol, - cons (sc, make_integer (sc, sc->strings->loc), - make_integer (sc, sc->strings->size)), - sc->vector_symbol, - cons (sc, make_integer (sc, sc->vectors->loc), - make_integer (sc, sc->vectors->size)), - sc->hash_table_symbol, - cons (sc, make_integer (sc, sc->hash_tables->loc), - make_integer (sc, sc->hash_tables->size)), - make_symbol (sc, "multivector", 11), - cons (sc, make_integer (sc, sc->multivectors->loc), - make_integer (sc, sc->multivectors->size)), - make_symbol (sc, "input", 5), - cons (sc, make_integer (sc, sc->input_ports->loc), - make_integer (sc, sc->input_ports->size)), - make_symbol (sc, "output", 6), - cons (sc, make_integer (sc, sc->output_ports->loc), - make_integer (sc, sc->output_ports->size)), - make_symbol (sc, "input-string", 12), - cons (sc, make_integer (sc, sc->input_string_ports->loc), - make_integer (sc, sc->input_string_ports->size)), - make_symbol (sc, "continuation", 12), - cons (sc, make_integer (sc, sc->continuations->loc), - make_integer (sc, sc->continuations->size)), - make_symbol (sc, "c-object", 8), - cons (sc, make_integer (sc, sc->c_objects->loc), - make_integer (sc, sc->c_objects->size)), - sc->gensym_symbol, - cons (sc, make_integer (sc, sc->gensyms->loc), - make_integer (sc, sc->gensyms->size)), - make_symbol (sc, "undefined", 9), - cons (sc, make_integer (sc, sc->undefineds->loc), - make_integer (sc, sc->undefineds->size)), - make_symbol (sc, "weak-ref", 8), - cons (sc, make_integer (sc, sc->weak_refs->loc), - make_integer (sc, sc->weak_refs->size)), - make_symbol (sc, "weak-hash-iter", 14), - cons (sc, make_integer (sc, sc->weak_hash_iterators->loc), - make_integer (sc, sc->weak_hash_iterators->size)), - make_symbol (sc, "opt1-func", 9), - cons (sc, make_integer (sc, sc->opt1_funcs->loc), - make_integer (sc, sc->opt1_funcs->size))))))); -} - -/* 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. +static void add_gc_list_sizes(s7_scheme *sc, s7_pointer mu_let) +{ + /* check the gc lists (finalizations), at startup there are strings/input-strings from the s7_eval_c_string calls for make-hook et el */ + const s7_int 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->multivectors->size + sc->weak_refs->size + sc->weak_hash_iterators->size + sc->opt1_funcs->size; + + const int32_t 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->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", 8), + s7_inlet(sc, + s7_list(sc, 6, + make_symbol(sc, "active/total", 12), cons(sc, make_integer(sc, loc), make_integer(sc, len)), + make_symbol(sc, "total-bytes", 11), kmg(sc, len * sizeof(s7_pointer)), + make_symbol(sc, "lists", 5), + s7_inlet(sc, + s7_list(sc, 28, + sc->string_symbol, cons(sc, make_integer(sc, sc->strings->loc), make_integer(sc, sc->strings->size)), + sc->vector_symbol, cons(sc, make_integer(sc, sc->vectors->loc), make_integer(sc, sc->vectors->size)), + sc->hash_table_symbol, cons(sc, make_integer(sc, sc->hash_tables->loc), make_integer(sc, sc->hash_tables->size)), + make_symbol(sc, "multivector", 11), cons(sc, make_integer(sc, sc->multivectors->loc), make_integer(sc, sc->multivectors->size)), + make_symbol(sc, "input", 5), cons(sc, make_integer(sc, sc->input_ports->loc), make_integer(sc, sc->input_ports->size)), + make_symbol(sc, "output", 6), cons(sc, make_integer(sc, sc->output_ports->loc), make_integer(sc, sc->output_ports->size)), + make_symbol(sc, "input-string", 12), cons(sc, make_integer(sc, sc->input_string_ports->loc), make_integer(sc, sc->input_string_ports->size)), + make_symbol(sc, "continuation", 12), cons(sc, make_integer(sc, sc->continuations->loc), make_integer(sc, sc->continuations->size)), + make_symbol(sc, "c-object", 8), cons(sc, make_integer(sc, sc->c_objects->loc), make_integer(sc, sc->c_objects->size)), + sc->gensym_symbol, cons(sc, make_integer(sc, sc->gensyms->loc), make_integer(sc, sc->gensyms->size)), + make_symbol(sc, "undefined", 9), cons(sc, make_integer(sc, sc->undefineds->loc), make_integer(sc, sc->undefineds->size)), + make_symbol(sc, "weak-ref", 8), cons(sc, make_integer(sc, sc->weak_refs->loc), make_integer(sc, sc->weak_refs->size)), + make_symbol(sc, "weak-hash-iter", 14),cons(sc, make_integer(sc, sc->weak_hash_iterators->loc), make_integer(sc, sc->weak_hash_iterators->size)), + make_symbol(sc, "opt1-func", 9), cons(sc, make_integer(sc, sc->opt1_funcs->loc), make_integer(sc, sc->opt1_funcs->size))))))); +} + +/* 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 + #include #endif -static s7_pointer -memory_usage (s7_scheme* sc) { - s7_int len, in_use= 0, all_len= 0; - gc_list_t* gp; - s7_int ts[NUM_TYPES]; +static s7_pointer memory_usage(s7_scheme *sc) +{ + s7_int len, in_use = 0, all_len = 0; + gc_list_t *gp; + s7_int ts[NUM_TYPES]; #if !_WIN32 /* (!MS_WINDOWS) */ - struct rusage info; + struct rusage info; struct timeval ut; #endif - const s7_pointer mu_let= s7_inlet (sc, sc->nil); - const s7_int gc_loc= gc_protect_1 (sc, mu_let); + const s7_pointer mu_let = s7_inlet(sc, sc->nil); + const s7_int gc_loc = gc_protect_1(sc, mu_let); - check_free_heap_size (sc, 2048); + check_free_heap_size(sc, 2048); #if !_WIN32 /* (!MS_WINDOWS) */ - getrusage (RUSAGE_SELF, &info); + getrusage(RUSAGE_SELF, &info); #ifdef __APPLE__ - add_slot_unchecked_with_id (sc, mu_let, - make_symbol (sc, "process-resident-size", 21), - kmg (sc, info.ru_maxrss)); + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "process-resident-size", 21), 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", 21), - kmg (sc, info.ru_maxrss * 1024)); + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "process-resident-size", 21), kmg(sc, info.ru_maxrss * 1024)); /* why does this number sometimes have no relation to RES in top? */ #endif - ut= info.ru_utime; - add_slot_unchecked_with_id ( - sc, mu_let, make_symbol (sc, "process-time", 12), - make_real (sc, ut.tv_sec + (floor (ut.tv_usec / 1000.0) / 1000.0))); - add_slot_unchecked_with_id (sc, mu_let, make_symbol (sc, "IO", 2), - cons (sc, make_integer (sc, info.ru_inblock), - make_integer (sc, info.ru_oublock))); + ut = info.ru_utime; + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "process-time", 12), make_real(sc, ut.tv_sec + (floor(ut.tv_usec / 1000.0) / 1000.0))); + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "IO", 2), 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, "elapsed-time", 12), - make_real (sc, (double) (my_clock () - sc->overall_start_time) / - ticks_per_second ())); - add_slot_unchecked_with_id (sc, mu_let, make_symbol (sc, "rootlet-size", 12), - make_integer (sc, let_length (sc, sc->rootlet))); - add_slot_unchecked_with_id ( - sc, mu_let, make_symbol (sc, "heap-size", 9), - 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", 9), - make_integer (sc, sizeof (s7_cell))); - add_slot_unchecked_with_id (sc, mu_let, - make_symbol (sc, "gc-total-freed", 14), - make_integer (sc, sc->gc_total_freed)); - add_slot_unchecked_with_id ( - sc, mu_let, make_symbol (sc, "gc-total-time", 13), - make_real (sc, (double) (sc->gc_true_total_time) / ticks_per_second ())); - add_slot_unchecked_with_id (sc, mu_let, make_symbol (sc, "gc-calls", 8), - make_integer (sc, sc->gc_true_calls)); - - add_slot_unchecked_with_id ( - sc, mu_let, make_symbol (sc, "small-ints", 10), - 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", 15), - cons (sc, make_integer (sc, sc->semipermanent_cells), - kmg (sc, sc->semipermanent_cells * sizeof (s7_cell)))); + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "elapsed-time", 12), make_real(sc, (double)(my_clock() - sc->overall_start_time) / ticks_per_second())); + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "rootlet-size", 12), make_integer(sc, let_length(sc, sc->rootlet))); + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "heap-size", 9), + 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", 9), make_integer(sc, sizeof(s7_cell))); + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "gc-total-freed", 14), make_integer(sc, sc->gc_total_freed)); + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "gc-total-time", 13), make_real(sc, (double)(sc->gc_true_total_time) / ticks_per_second())); + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "gc-calls", 8), make_integer(sc, sc->gc_true_calls)); + + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "small-ints", 10), + 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", 15), + cons(sc, make_integer(sc, sc->semipermanent_cells), kmg(sc, sc->semipermanent_cells * sizeof(s7_cell)))); { - s7_int i= 0; - for (gc_obj_t* g= sc->semipermanent_objects; g; - i++, g= (gc_obj_t*) (g->nxt)) - ; - add_slot_unchecked_with_id (sc, mu_let, - make_symbol (sc, "permanent-objects", 17), - make_integer (sc, i)); + s7_int i = 0; + for (gc_obj_t *g = sc->semipermanent_objects; g; i++, g = (gc_obj_t *)(g->nxt)); + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "permanent-objects", 17), make_integer(sc, i)); } { - s7_int i= 0; - for (gc_obj_t* g= sc->semipermanent_lets; g; i++, g= (gc_obj_t*) (g->nxt)) - ; - add_slot_unchecked_with_id (sc, mu_let, - make_symbol (sc, "permanent-lets", 14), - make_integer (sc, i)); + s7_int i = 0; + for (gc_obj_t *g = sc->semipermanent_lets; g; i++, g = (gc_obj_t *)(g->nxt)); + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "permanent-lets", 14), make_integer(sc, i)); } /* safe_lists */ { - s7_int live= 0, lines_in_use= 0, line_used= 0; - for (s7_int i= 1; i < NUM_SAFE_LISTS; i++) - if (is_pair (sc->safe_lists[i])) { - live++; - if (safe_list_is_in_use (sc->safe_lists[i])) { - lines_in_use++; - line_used= i; - } - } + s7_int live = 0, lines_in_use = 0, line_used = 0; + for (s7_int i = 1; i < NUM_SAFE_LISTS; i++) + if (is_pair(sc->safe_lists[i])) + { + live++; + if (safe_list_is_in_use(sc->safe_lists[i])) {lines_in_use++; line_used = i;} + } #if S7_DEBUGGING - begin_temp (sc->y, sc->nil); - for (s7_int i= NUM_SAFE_LISTS - 1; i > 0; - i--) /* omit safe_lists[0]=() since it is never used */ - sc->y= cons (sc, make_integer (sc, sc->safe_list_uses[i]), sc->y); - add_slot_unchecked_with_id ( - sc, mu_let, make_symbol (sc, "safe-lists", 10), - (lines_in_use == 0) - ? list_3 (sc, small_int (live), int_zero, sc->y) - : list_4 (sc, small_int (live), small_int (lines_in_use), - small_int (line_used), sc->y)); - end_temp (sc->y); + begin_temp(sc->y, sc->nil); + for (s7_int i = NUM_SAFE_LISTS - 1; i > 0; i--) /* omit safe_lists[0]=() since it is never used */ + sc->y = cons(sc, make_integer(sc, sc->safe_list_uses[i]), sc->y); + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "safe-lists", 10), + (lines_in_use == 0) ? list_3(sc, small_int(live), int_zero, sc->y) : + list_4(sc, small_int(live), small_int(lines_in_use), small_int(line_used), sc->y)); + end_temp(sc->y); #else - add_slot_unchecked_with_id (sc, mu_let, make_symbol (sc, "safe-lists", 10), - (lines_in_use == 0) - ? list_2 (sc, small_int (live), int_zero) - : list_3 (sc, small_int (live), - small_int (lines_in_use), - small_int (line_used))); + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "safe-lists", 10), + (lines_in_use == 0) ? list_2(sc, small_int(live), int_zero) : + list_3(sc, small_int(live), small_int(lines_in_use), small_int(line_used))); #endif } - /* show how many active cells there are of each type (this is where all the - * memory_usage cpu time goes) */ + /* show how many active cells there are of each type (this is where all the memory_usage cpu time goes) */ if ((S7_DEBUGGING) && (sc->heap_size > sc->max_heap_size)) - fprintf (stderr, "%s[%d]: heap_size: %" ld64 ", max: %" ld64 "\n", __func__, - __LINE__, sc->heap_size, sc->max_heap_size); - for (s7_int i= 0; i < NUM_TYPES; i++) - ts[i]= 0; - for (s7_int k= 0; k < sc->heap_size; k++) - ts[type_unchecked (sc->heap[k])]++; - begin_temp (sc->y, sc->nil); - for (s7_int i= 0; i < NUM_TYPES; i++) { - if (i > 0) in_use+= ts[i]; - if (ts[i] > 0) /* was 50, 26-Sep-23 */ - { - /* can't use bare type name here ("let" is a syntactic symbol) */ - const char* tname= - (i == 0) ? "free" : type_name_from_type (i, no_article); - const s7_int tlen= safe_strlen (tname); - uint8_t name[32]; /* not 16 -- gmp overflows this buffer with - "big-complex-number", len=18 */ - memcpy ((void*) name, (const void*) tname, tlen); - name[tlen]= (uint8_t) '\0'; - name[0] = (uint8_t) toupper ((int) name[0]); - sc->y = cons_unchecked ( - sc, make_integer (sc, ts[i]), - cons (sc, make_symbol (sc, (const char*) name, tlen), sc->y)); - } - } - if (is_pair (sc->y)) - add_slot_unchecked_with_id ( - sc, mu_let, make_symbol (sc, "heap-by-type", 12), - s7_inlet (sc, proper_list_reverse_in_place (sc, sc->y))); - end_temp (sc->y); - /* same for semipermanent 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, "cells-in-use/free", 17), - cons (sc, make_integer (sc, in_use), - make_integer (sc, sc->free_heap_top - sc->free_heap))); - add_slot_unchecked_with_id ( - sc, mu_let, make_symbol (sc, "gc-protected-objects", 20), - cons (sc, - make_integer (sc, sc->protected_objects_size - 2 - - sc->protected_objects_free_list_loc), - /* -1 to make size and loc commensurable, another -1 because we're - using an element in this function (see gc_loc above) */ - make_integer (sc, sc->protected_objects_size))); - add_slot_unchecked_with_id (sc, mu_let, make_symbol (sc, "setters", 7), - make_integer (sc, sc->protected_setters_loc)); - if (S7_DEBUGGING) - add_slot_unchecked_with_id (sc, mu_let, make_symbol (sc, "classes", 7), - make_integer (sc, (s7_int) (sc->f_class))); - - add_symbol_table (sc, mu_let); - add_slot_unchecked_with_id (sc, mu_let, make_symbol (sc, "stack", 5), - cons (sc, make_integer (sc, stack_top (sc)), - make_integer (sc, sc->stack_size))); - - len= sc->autoload_names_top * - (sizeof (const char**) + sizeof (s7_int) + sizeof (bool)); - for (s7_int i= 0; i < sc->autoload_names_loc; i++) - len+= sc->autoload_names_sizes[i]; - add_slot_unchecked_with_id (sc, mu_let, sc->autoload_symbol, - make_integer (sc, len)); - - add_slot_unchecked_with_id ( - sc, mu_let, make_symbol (sc, "circle-info", 11), - make_integer ( - sc, sc->circle_info->size * - (sizeof (s7_pointer) + sizeof (int32_t) + sizeof (bool)))); - - add_gc_list_sizes (sc, mu_let); + fprintf(stderr, "%s[%d]: heap_size: %" ld64 ", max: %" ld64 "\n", __func__, __LINE__, sc->heap_size, sc->max_heap_size); + for (s7_int i = 0; i < NUM_TYPES; i++) ts[i] = 0; + for (s7_int k = 0; k < sc->heap_size; k++) + ts[type_unchecked(sc->heap[k])]++; + begin_temp(sc->y, sc->nil); + for (s7_int i = 0; i < NUM_TYPES; i++) + { + if (i > 0) in_use += ts[i]; + if (ts[i] > 0) /* was 50, 26-Sep-23 */ + { + /* can't use bare type name here ("let" is a syntactic symbol) */ + const char *tname = (i == 0) ? "free" : type_name_from_type(i, no_article); + const s7_int tlen = safe_strlen(tname); + uint8_t name[32]; /* not 16 -- gmp overflows this buffer with "big-complex-number", len=18 */ + memcpy((void *)name, (const void *)tname, tlen); + name[tlen] = (uint8_t)'\0'; + name[0] = (uint8_t)toupper((int)name[0]); + sc->y = cons_unchecked(sc, make_integer(sc, ts[i]), cons(sc, make_symbol(sc, (const char *)name, tlen), sc->y)); + }} + if (is_pair(sc->y)) + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "heap-by-type", 12), s7_inlet(sc, proper_list_reverse_in_place(sc, sc->y))); + end_temp(sc->y); + /* same for semipermanent 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, "cells-in-use/free", 17), + cons(sc, make_integer(sc, in_use), make_integer(sc, sc->free_heap_top - sc->free_heap))); + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "gc-protected-objects", 20), + cons(sc, make_integer(sc, sc->protected_objects_size - 2 - sc->protected_objects_free_list_loc), + /* -1 to make size and loc commensurable, another -1 because we're using an element in this function (see gc_loc above) */ + make_integer(sc, sc->protected_objects_size))); + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "setters", 7), make_integer(sc, sc->protected_setters_loc)); + if (S7_DEBUGGING) add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "classes", 7), make_integer(sc, (s7_int)(sc->f_class))); + + add_symbol_table(sc, mu_let); + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "stack", 5), cons(sc, make_integer(sc, stack_top(sc)), make_integer(sc, sc->stack_size))); + + len = sc->autoload_names_top * (sizeof(const char **) + sizeof(s7_int) + sizeof(bool)); + for (s7_int i = 0; i < sc->autoload_names_loc; i++) len += sc->autoload_names_sizes[i]; + add_slot_unchecked_with_id(sc, mu_let, sc->autoload_symbol, make_integer(sc, len)); + + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "circle-info", 11), + make_integer(sc, sc->circle_info->size * (sizeof(s7_pointer) + sizeof(int32_t) + sizeof(bool)))); + + add_gc_list_sizes(sc, mu_let); /* strings */ gp = sc->strings; - len= 0; - for (s7_int 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", 7), - cons (sc, make_integer (sc, gp->loc), make_integer (sc, len))); + len = 0; + for (s7_int 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", 7), cons(sc, make_integer(sc, gp->loc), make_integer(sc, len))); /* vectors */ { - s7_int vlen= 0, vs= 0, flen= 0, fvs= 0, clen= 0, cvs= 0, ilen= 0, ivs= 0, - blen= 0, bvs= 0; - gp= sc->vectors; - for (s7_int k= 0; k < 2; k++, gp= sc->multivectors) - for (s7_int i= 0; i < gp->loc; i++) { - const s7_pointer vec= gp->list[i]; - if (is_float_vector (vec)) { - fvs++; - flen+= vector_length (vec); - } - else if (is_int_vector (vec)) { - ivs++; - ilen+= vector_length (vec); - } - else if (is_complex_vector (vec)) { - cvs++; - clen+= vector_length (vec); - } - else if (is_byte_vector (vec)) { - bvs++; - blen+= vector_length (vec); - } - else { - vs++; - vlen+= vector_length (vec); - } - } - all_len+= blen + ilen * sizeof (s7_int) + flen * sizeof (s7_double) + - vlen * sizeof (s7_pointer); - add_slot_unchecked_with_id ( - sc, mu_let, make_symbol (sc, "vectors", 7), - s7_inlet ( - sc, - s7_list ( - sc, 12, make_symbol (sc, "total", 5), - make_integer (sc, sc->vectors->loc + sc->multivectors->loc), - make_symbol (sc, "normal", 6), - cons (sc, make_integer (sc, vs), make_integer (sc, vlen)), - make_symbol (sc, "float", 5), - cons (sc, make_integer (sc, fvs), make_integer (sc, flen)), - make_symbol (sc, "int", 3), - cons (sc, make_integer (sc, ivs), make_integer (sc, ilen)), - make_symbol (sc, "complex", 7), - cons (sc, make_integer (sc, cvs), make_integer (sc, clen)), - make_symbol (sc, "byte", 4), - cons (sc, make_integer (sc, bvs), make_integer (sc, blen))))); + s7_int vlen = 0, vs = 0, flen = 0, fvs = 0, clen = 0, cvs = 0, ilen = 0, ivs = 0, blen = 0, bvs = 0; + gp = sc->vectors; + for (s7_int k = 0; k < 2; k++, gp = sc->multivectors) + for (s7_int i = 0; i < gp->loc; i++) + { + const s7_pointer vec = gp->list[i]; + if (is_float_vector(vec)) + {fvs++; flen += vector_length(vec);} + else + if (is_int_vector(vec)) + {ivs++; ilen += vector_length(vec);} + else + if (is_complex_vector(vec)) + {cvs++; clen += vector_length(vec);} + else + if (is_byte_vector(vec)) + {bvs++; blen += vector_length(vec);} + else {vs++; vlen += vector_length(vec);} + } + all_len += blen + ilen * sizeof(s7_int) + flen * sizeof(s7_double) + vlen * sizeof(s7_pointer); + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "vectors", 7), + s7_inlet(sc, + s7_list(sc, 12, + make_symbol(sc, "total", 5), make_integer(sc, sc->vectors->loc + sc->multivectors->loc), + make_symbol(sc, "normal", 6), cons(sc, make_integer(sc, vs), make_integer(sc, vlen)), + make_symbol(sc, "float", 5), cons(sc, make_integer(sc, fvs), make_integer(sc, flen)), + make_symbol(sc, "int", 3), cons(sc, make_integer(sc, ivs), make_integer(sc, ilen)), + make_symbol(sc, "complex", 7), cons(sc, make_integer(sc, cvs), make_integer(sc, clen)), + make_symbol(sc, "byte", 4), cons(sc, make_integer(sc, bvs), make_integer(sc, blen))))); } /* hash-tables */ { - s7_int hlen= 0; - gp = sc->hash_tables; - for (s7_int i= 0; i < gp->loc; i++) { - const s7_pointer table= gp->list[i]; - hlen+= ((hash_table_size (table)) * sizeof (hash_entry_t*)); - hlen+= (hash_table_entries (table) * sizeof (hash_entry_t)); - } - all_len+= hlen; /* was adding all_len?? 11-Apr-25 */ - add_slot_unchecked_with_id (sc, mu_let, make_symbol (sc, "hash-tables", 11), - cons (sc, - make_integer (sc, sc->hash_tables->loc), - make_integer (sc, hlen))); + s7_int hlen = 0; + gp = sc->hash_tables; + for (s7_int i = 0; i < gp->loc; i++) + { + const s7_pointer table = gp->list[i]; + hlen += ((hash_table_size(table)) * sizeof(hash_entry_t *)); + hlen += (hash_table_entries(table) * sizeof(hash_entry_t)); + } + all_len += hlen; /* was adding all_len?? 11-Apr-25 */ + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "hash-tables", 11), + cons(sc, make_integer(sc, sc->hash_tables->loc), make_integer(sc, hlen))); } /* ports */ - add_slot_unchecked_with_id ( - sc, mu_let, make_symbol (sc, "input-port-stack", 16), - cons (sc, make_integer (sc, sc->input_port_stack_loc), - make_integer (sc, sc->input_port_stack_size))); + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "input-port-stack", 16), + cons(sc, make_integer(sc, sc->input_port_stack_loc), make_integer(sc, sc->input_port_stack_size))); gp = sc->input_ports; - len= 0; - for (s7_int i= 0; i < gp->loc; i++) { - s7_pointer port= gp->list[i]; - if (port_data (port)) len+= port_data_size (port); - } - add_slot_unchecked_with_id (sc, mu_let, make_symbol (sc, "input-ports", 11), - cons (sc, make_integer (sc, sc->input_ports->loc), - make_integer (sc, len))); + len = 0; + for (s7_int i = 0; i < gp->loc; i++) + { + s7_pointer port = gp->list[i]; + if (port_data(port)) len += port_data_size(port); + } + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "input-ports", 11), + cons(sc, make_integer(sc, sc->input_ports->loc), make_integer(sc, len))); gp = sc->input_string_ports; - len= 0; - for (s7_int i= 0; i < gp->loc; i++) { - s7_pointer port= gp->list[i]; - if (port_data (port)) len+= port_data_size (port); - } - add_slot_unchecked_with_id ( - sc, mu_let, make_symbol (sc, "input-string-ports", 18), - cons (sc, make_integer (sc, sc->input_string_ports->loc), - make_integer (sc, len))); + len = 0; + for (s7_int i = 0; i < gp->loc; i++) + { + s7_pointer port = gp->list[i]; + if (port_data(port)) len += port_data_size(port); + } + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "input-string-ports", 18), + cons(sc, make_integer(sc, sc->input_string_ports->loc), make_integer(sc, len))); { - int32_t files= 0, strings= 0, closed_strings= 0, functions= 0, unknowns= 0; + int32_t files = 0, strings = 0, closed_strings = 0, functions = 0, unknowns = 0; gp = sc->output_ports; - len= 0; - for (s7_int i= 0; i < gp->loc; i++) { - const s7_pointer port= gp->list[i]; - if (port_data (port)) len+= port_data_size (port); - if (is_string_port (port)) { - strings++; - if (port_is_closed (port)) closed_strings++; - } - else if (is_file_port (port)) files++; - else if (is_function_port (port)) functions++; - else unknowns++; - } - add_slot_unchecked_with_id ( - sc, mu_let, make_symbol (sc, "output-ports", 12), - list_3 (sc, - cons (sc, make_integer (sc, sc->output_ports->loc), - make_integer (sc, len)), - make_symbol (sc, "string/file/func/?", 18), - list_4 (sc, - cons (sc, make_integer (sc, strings), - make_integer (sc, closed_strings)), - make_integer (sc, files), make_integer (sc, functions), - make_integer (sc, unknowns)))); + len = 0; + for (s7_int i = 0; i < gp->loc; i++) + { + const s7_pointer port = gp->list[i]; + if (port_data(port)) len += port_data_size(port); + if (is_string_port(port)) + { + strings++; + if (port_is_closed(port)) closed_strings++; + } + else if (is_file_port(port)) files++; else if (is_function_port(port)) functions++; else unknowns++; + } + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "output-ports", 12), + list_3(sc, cons(sc, make_integer(sc, sc->output_ports->loc), make_integer(sc, len)), + make_symbol(sc, "string/file/func/?", 18), + list_4(sc, cons(sc, make_integer(sc, strings), make_integer(sc, closed_strings)), + make_integer(sc, files), make_integer(sc, functions), make_integer(sc, unknowns)))); } #if S7_DEBUGGING { - s7_int i= 0; - for (s7_pointer ports= sc->format_ports; ports; - i++, ports= (s7_pointer) port_next (ports)) - ; - add_slot_unchecked_with_id ( - sc, mu_let, make_symbol (sc, "format-ports-allocated/free/inuse", 33), - list_3 (sc, make_integer (sc, sc->format_ports_allocated), - make_integer (sc, i), - make_integer (sc, sc->format_ports_allocated - i))); - for (i= 0, len= 0; i < sc->file_names_top; i++) - len+= string_length (sc->file_names[i]); - add_slot_unchecked_with_id (sc, mu_let, make_symbol (sc, "file-names", 10), - cons (sc, make_integer (sc, sc->file_names_top), - make_integer (sc, len))); - add_slot_unchecked_with_id ( - sc, mu_let, make_symbol (sc, "c-functions", 11), - cons (sc, make_integer (sc, sc->c_functions_allocated), - make_integer (sc, sc->c_functions_allocated * - (sizeof (c_proc_t) + sizeof (s7_cell))))); + s7_int i = 0; + for (s7_pointer ports = sc->format_ports; ports; i++, ports = (s7_pointer)port_next(ports)); + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "format-ports-allocated/free/inuse", 33), + list_3(sc, make_integer(sc, sc->format_ports_allocated), make_integer(sc, i), make_integer(sc, sc->format_ports_allocated - i))); + for (i = 0, len = 0; i < sc->file_names_top; i++) len += string_length(sc->file_names[i]); + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "file-names", 10), + cons(sc, make_integer(sc, sc->file_names_top), make_integer(sc, len))); + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "c-functions", 11), + cons(sc, make_integer(sc, sc->c_functions_allocated), make_integer(sc, sc->c_functions_allocated * (sizeof(c_proc_t) + sizeof(s7_cell))))); } #endif /* continuations (sketchy!) */ gp = sc->continuations; - len= 0; - for (s7_int i= 0; i < gp->loc; i++) - if (is_continuation (gp->list[i])) - len+= continuation_stack_size (gp->list[i]); + len = 0; + for (s7_int i = 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", 13), - cons (sc, make_integer (sc, sc->continuations->loc), - make_integer (sc, len * sizeof (s7_pointer)))); + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "continuations", 13), + 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", 9), - make_integer (sc, sc->c_objects->loc)); + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "c-objects", 9), make_integer(sc, sc->c_objects->loc)); if (sc->num_c_object_types > 0) - add_slot_unchecked_with_id ( - sc, mu_let, make_symbol (sc, "c-types", 7), - cons (sc, make_integer (sc, sc->num_c_object_types), - make_integer ( - sc, (sc->c_object_types_size * sizeof (c_object_t*)) + - (sc->num_c_object_types * sizeof (c_object_t))))); - /* we're ignoring c_type->scheme_name: make_permanent_string(sc, name) */ + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "c-types", 7), + cons(sc, make_integer(sc, sc->num_c_object_types), + make_integer(sc, (sc->c_object_types_size * sizeof(c_object_t *)) + (sc->num_c_object_types * sizeof(c_object_t))))); + /* we're ignoring c_type->scheme_name: make_permanent_string(sc, name) */ /* free-lists (mallocate) */ { s7_int k; #if S7_DEBUGGING - s7_int num_blocks= 0; - s7_pointer ff, frees = make_big_list (sc, NUM_BLOCK_LISTS, sc->nil); - s7_pointer fa, allocs = make_big_list (sc, NUM_BLOCK_LISTS, sc->nil); - s7_pointer fb, borrows= make_big_list (sc, NUM_BLOCK_LISTS, sc->nil); - ff= frees; - fa= allocs; - fb= borrows; + s7_int num_blocks = 0; + s7_pointer ff, frees = make_big_list(sc, NUM_BLOCK_LISTS, sc->nil); + s7_pointer fa, allocs = make_big_list(sc, NUM_BLOCK_LISTS, sc->nil); + s7_pointer fb, borrows = make_big_list(sc, NUM_BLOCK_LISTS, sc->nil); + ff = frees; + fa = allocs; + fb = borrows; #endif - begin_temp (sc->y, sc->nil); - len= 0; - for (s7_int i= 0; i < TOP_BLOCK_LIST; i++) { - k= 0; - for (block_t* b= sc->block_lists[i]; b; b= block_next (b), k++) - ; /* these are the free blocks awaiting mallocate */ - sc->y= cons (sc, make_integer (sc, k), sc->y); - len+= ((sizeof (block_t) + (1LL << i)) * k); + begin_temp(sc->y, sc->nil); + len = 0; + for (s7_int i = 0; i < TOP_BLOCK_LIST; i++) + { + k = 0; + for (block_t *b = sc->block_lists[i]; b; b = block_next(b), k++); /* these are the free blocks awaiting mallocate */ + sc->y = cons(sc, make_integer(sc, k), sc->y); + len += ((sizeof(block_t) + (1LL << i)) * k); #if S7_DEBUGGING - num_blocks+= k; - set_car (ff, make_integer (sc, sc->blocks_freed[i])); - ff= cdr (ff); - set_car (fa, make_integer (sc, sc->blocks_mallocated[i])); - fa= cdr (fa); - set_car (fb, make_integer (sc, sc->blocks_borrowed[i])); - fb= cdr (fb); + num_blocks += k; + set_car(ff, make_integer(sc, sc->blocks_freed[i])); ff = cdr(ff); + set_car(fa, make_integer(sc, sc->blocks_mallocated[i])); fa = cdr(fa); + set_car(fb, make_integer(sc, sc->blocks_borrowed[i])); fb = cdr(fb); #endif - } - k= 0; - for (block_t* b= sc->block_lists[TOP_BLOCK_LIST]; b; b= block_next (b), k++) - len+= (sizeof (block_t) + block_size (b)); - sc->y= cons (sc, make_integer (sc, k), sc->y); - sc->y= proper_list_reverse_in_place (sc, sc->y); + } + k = 0; + for (block_t *b = sc->block_lists[TOP_BLOCK_LIST]; b; b = block_next(b), k++) + len += (sizeof(block_t) + block_size(b)); + sc->y = cons(sc, make_integer(sc, k), sc->y); + sc->y = proper_list_reverse_in_place(sc, sc->y); #if S7_DEBUGGING - num_blocks+= k; - set_car (ff, make_integer (sc, sc->blocks_freed[TOP_BLOCK_LIST])); - set_car (fa, make_integer (sc, sc->blocks_mallocated[TOP_BLOCK_LIST])); - set_car (fb, make_integer (sc, sc->blocks_borrowed[TOP_BLOCK_LIST])); - add_slot_unchecked_with_id ( - sc, mu_let, make_symbol (sc, "blocks-allocated/available/in-use", 33), - list_3 (sc, make_integer (sc, sc->blocks_allocated), - make_integer (sc, num_blocks), - make_integer (sc, sc->blocks_allocated - num_blocks))); - add_slot_unchecked_with_id ( - sc, mu_let, make_symbol (sc, "free-lists", 10), - s7_inlet ( - sc, - cons ( - sc, cons (sc, make_symbol (sc, "bytes", 5), kmg (sc, len)), - list_4 (sc, cons (sc, make_symbol (sc, "bins", 4), sc->y), - cons (sc, make_symbol (sc, "allocs", 6), allocs), - cons (sc, make_symbol (sc, "frees", 5), frees), - cons (sc, make_symbol (sc, "borrows", 7), borrows))))); - add_slot_unchecked_with_id ( - sc, mu_let, make_symbol (sc, "wrapper-uses", 12), - s7_inlet ( - sc, - s7_list (sc, 7, - cons (sc, make_symbol (sc, "strings", 7), - make_integer (sc, sc->string_wrapper_allocs)), - cons (sc, make_symbol (sc, "integers", 8), - make_integer (sc, sc->integer_wrapper_allocs)), - cons (sc, make_symbol (sc, "reals", 5), - make_integer (sc, sc->real_wrapper_allocs)), - cons (sc, make_symbol (sc, "complexes", 9), - make_integer (sc, sc->complex_wrapper_allocs)), - cons (sc, make_symbol (sc, "lets", 4), - make_integer (sc, sc->let_wrapper_allocs)), - cons (sc, make_symbol (sc, "slots", 5), - make_integer (sc, sc->slot_wrapper_allocs)), - cons (sc, make_symbol (sc, "c-pointers", 10), - make_integer (sc, sc->c_pointer_wrapper_allocs))))); + num_blocks += k; + set_car(ff, make_integer(sc, sc->blocks_freed[TOP_BLOCK_LIST])); + set_car(fa, make_integer(sc, sc->blocks_mallocated[TOP_BLOCK_LIST])); + set_car(fb, make_integer(sc, sc->blocks_borrowed[TOP_BLOCK_LIST])); + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "blocks-allocated/available/in-use", 33), + list_3(sc, make_integer(sc, sc->blocks_allocated), make_integer(sc, num_blocks), make_integer(sc, sc->blocks_allocated - num_blocks))); + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "free-lists", 10), + s7_inlet(sc, cons(sc, cons(sc, make_symbol(sc, "bytes", 5), kmg(sc, len)), + list_4(sc, cons(sc, make_symbol(sc, "bins", 4), sc->y), + cons(sc, make_symbol(sc, "allocs", 6), allocs), + cons(sc, make_symbol(sc, "frees", 5), frees), + cons(sc, make_symbol(sc, "borrows", 7), borrows))))); + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "wrapper-uses", 12), + s7_inlet(sc, s7_list(sc, 7, + cons(sc, make_symbol(sc, "strings", 7), make_integer(sc, sc->string_wrapper_allocs)), + cons(sc, make_symbol(sc, "integers", 8), make_integer(sc, sc->integer_wrapper_allocs)), + cons(sc, make_symbol(sc, "reals", 5), make_integer(sc, sc->real_wrapper_allocs)), + cons(sc, make_symbol(sc, "complexes", 9), make_integer(sc, sc->complex_wrapper_allocs)), + cons(sc, make_symbol(sc, "lets", 4), make_integer(sc, sc->let_wrapper_allocs)), + cons(sc, make_symbol(sc, "slots", 5), make_integer(sc, sc->slot_wrapper_allocs)), + cons(sc, make_symbol(sc, "c-pointers", 10), make_integer(sc, sc->c_pointer_wrapper_allocs))))); #else - add_slot_unchecked_with_id ( - sc, mu_let, make_symbol (sc, "free-lists", 10), - s7_inlet ( - sc, - list_2 (sc, cons (sc, make_symbol (sc, "bytes", 5), kmg (sc, len)), - cons (sc, make_symbol (sc, "bins", 4), sc->y)))); + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "free-lists", 10), + s7_inlet(sc, list_2(sc, cons(sc, make_symbol(sc, "bytes", 5), kmg(sc, len)), + cons(sc, make_symbol(sc, "bins", 4), sc->y)))); #endif - end_temp (sc->y); - add_slot_unchecked_with_id ( - sc, mu_let, make_symbol (sc, "approximate-s7-size", 19), - kmg (sc, ((sc->semipermanent_cells + NUM_SMALL_INTS + sc->heap_size) * - (sizeof (s7_pointer) + sizeof (s7_cell))) + - ((2 * sc->heap_size + SYMBOL_TABLE_SIZE + sc->stack_size) * - sizeof (s7_pointer)) + - len + all_len)); - } - s7_gc_unprotect_at (sc, gc_loc); + end_temp(sc->y); + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "approximate-s7-size", 19), + kmg(sc, ((sc->semipermanent_cells + NUM_SMALL_INTS + sc->heap_size) * (sizeof(s7_pointer) + sizeof(s7_cell))) + + ((2 * sc->heap_size + SYMBOL_TABLE_SIZE + sc->stack_size) * sizeof(s7_pointer)) + + len + all_len)); + } + s7_gc_unprotect_at(sc, gc_loc); /* sc->opts: OPTS_SIZE * sizeof(opt_info) == 32768 currently */ - return (mu_let); + return(mu_let); } -static s7_pointer -sl_c_types_to_list (s7_scheme* sc) { - begin_temp (sc->y, sc->nil); - for (int32_t i= 0; i < sc->num_c_object_types; - i++) /* c-object type (tag) is i */ - sc->y= cons (sc, sc->c_object_types[i]->scheme_name, sc->y); - sc->y= proper_list_reverse_in_place (sc, sc->y); /* so car(types) has tag 0 */ - return_with_end_temp (sc->y); +static s7_pointer sl_c_types_to_list(s7_scheme *sc) +{ + begin_temp(sc->y, sc->nil); + for (int32_t i = 0; i < sc->num_c_object_types; i++) /* c-object type (tag) is i */ + sc->y = cons(sc, sc->c_object_types[i]->scheme_name, sc->y); + sc->y = proper_list_reverse_in_place(sc, sc->y); /* so car(types) has tag 0 */ + return_with_end_temp(sc->y); } -static s7_pointer -sl_file_names_to_list (s7_scheme* sc) { - begin_temp (sc->y, sc->nil); - for (int32_t i= 0; i <= sc->file_names_top; i++) - sc->y= cons (sc, sc->file_names[i], sc->y); - sc->y= proper_list_reverse_in_place (sc, sc->y); - return_with_end_temp (sc->y); +static s7_pointer sl_file_names_to_list(s7_scheme *sc) +{ + begin_temp(sc->y, sc->nil); + for (int32_t i = 0; i <= sc->file_names_top; i++) + sc->y = cons(sc, sc->file_names[i], sc->y); + sc->y = proper_list_reverse_in_place(sc, sc->y); + return_with_end_temp(sc->y); } -static s7_pointer -sl_int_fixup (s7_scheme* sc, s7_pointer val) { - return (val); +static s7_pointer sl_int_fixup(s7_scheme *sc, s7_pointer val) +{ + return(val); } -static s7_pointer -sl_history_to_list (s7_scheme* sc) { +static s7_pointer sl_history_to_list(s7_scheme *sc) +{ #if WITH_HISTORY - return (sanitize_history (sc, (sc->cur_code == sc->history_sink) - ? sc->old_cur_code - : sc->cur_code)); + return(sanitize_history(sc, (sc->cur_code == sc->history_sink) ? sc->old_cur_code : sc->cur_code)); #else - return (sc->cur_code); + return(sc->cur_code); #endif } -static s7_pointer -sl_active_catches_to_list (s7_scheme* sc) { - s7_pointer lst= sc->nil; - for (s7_int op_loc= stack_top (sc) - 1; op_loc >= 3; op_loc-= 4) - switch (stack_op (sc->stack, op_loc)) { - case OP_CATCH_ALL: - lst= cons (sc, sc->T, lst); - break; - case OP_CATCH_2: - case OP_CATCH_1: - case OP_CATCH: - lst= cons (sc, catch_tag (stack_code (sc->stack, op_loc)), lst); - break; +static s7_pointer sl_active_catches_to_list(s7_scheme *sc) +{ + s7_pointer lst = sc->nil; + for (s7_int op_loc = stack_top(sc) - 1; op_loc >= 3; op_loc -= 4) + switch (stack_op(sc->stack, op_loc)) + { + case OP_CATCH_ALL: + lst = cons(sc, sc->T, lst); + break; + case OP_CATCH_2: case OP_CATCH_1: case OP_CATCH: + lst = cons(sc, catch_tag(stack_code(sc->stack, op_loc)), lst); + break; + } + return(reverse_in_place_unchecked(sc, sc->nil, lst)); +} + +static s7_pointer sl_stack_entries_to_list(s7_scheme *sc, s7_pointer stack, s7_int top) +{ + s7_pointer lst = sc->nil; /* the stack can contain anything (like #): this is a dangerous function */ + begin_temp(sc->y, sc->nil); + for (s7_int i = top - 1; i >= 3; i -= 4) + { + const s7_pointer func = stack_code(stack, i), args = stack_args(stack, i), let = stack_let(stack, i); + const opcode_t op = stack_op(stack, i); + s7_pointer entry = sc->nil; + if (s7_is_valid(sc, let)) entry = cons(sc, let, entry); + if (s7_is_valid(sc, args)) entry = cons_unchecked(sc, args, entry); + if (s7_is_valid(sc, func)) entry = cons_unchecked(sc, func, entry); + if ((op >= 0) && (op < NUM_OPS)) entry = cons_unchecked(sc, make_symbol_with_strlen(sc, op_names[op]), entry); + lst = cons_unchecked(sc, entry, lst); + sc->y = lst; } - return (reverse_in_place_unchecked (sc, sc->nil, lst)); -} - -static s7_pointer -sl_stack_entries_to_list (s7_scheme* sc, s7_pointer stack, s7_int top) { - s7_pointer lst= sc->nil; /* the stack can contain anything (like #): - this is a dangerous function */ - begin_temp (sc->y, sc->nil); - for (s7_int i= top - 1; i >= 3; i-= 4) { - const s7_pointer func= stack_code (stack, i), args= stack_args (stack, i), - let= stack_let (stack, i); - const opcode_t op = stack_op (stack, i); - s7_pointer entry= sc->nil; - if (s7_is_valid (sc, let)) entry= cons (sc, let, entry); - if (s7_is_valid (sc, args)) entry= cons_unchecked (sc, args, entry); - if (s7_is_valid (sc, func)) entry= cons_unchecked (sc, func, entry); - if ((op >= 0) && (op < NUM_OPS)) - entry= cons_unchecked (sc, make_symbol_with_strlen (sc, op_names[op]), - entry); - lst = cons_unchecked (sc, entry, lst); - sc->y= lst; - } - end_temp (sc->y); - return (reverse_in_place_unchecked (sc, sc->nil, lst)); -} - -static s7_pointer -sl_gc_protected_objects_to_list (s7_scheme* sc) { - const s7_pointer nv = s7_vector_copy (sc, sc->protected_objects); - s7_pointer* vals= vector_elements (nv); - const s7_int len = vector_length (nv); - for (s7_int i= 0; i < len; i++) - if (vals[i] == sc->unused) vals[i]= sc->F; - return (nv); -} - -static s7_pointer -starlet (s7_scheme* sc, s7_int choice) { - switch (choice) { - case sl_accept_all_keyword_arguments: - return (make_boolean (sc, sc->accept_all_keyword_arguments)); - case sl_autoloading: - return (make_boolean (sc, sc->is_autoloading)); - case sl_catches: - return (sl_active_catches_to_list (sc)); - case sl_cpu_time: - return (make_real ( - sc, (double) clock () / - (double) CLOCKS_PER_SEC)); /* cpu, not wall-clock time */ - case sl_c_types: - return (sl_c_types_to_list (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_random_state); - case sl_default_rationalize_error: - return (make_real (sc, sc->default_rationalize_error)); - case sl_equivalent_float_epsilon: - return (make_real (sc, sc->equivalent_float_epsilon)); - case sl_expansions: - return (make_boolean (sc, sc->is_expanding)); - case sl_file_names: - case sl_filenames: - return (sl_file_names_to_list (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_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 (sl_gc_protected_objects_to_list (sc)); - case sl_gc_resize_heap_by_4_fraction: - return (make_real (sc, sc->gc_resize_heap_by_4_fraction)); - case sl_gc_resize_heap_fraction: - return (make_real (sc, sc->gc_resize_heap_fraction)); - 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_total_freed: - return (make_integer (sc, sc->gc_total_freed)); - case sl_hash_table_float_epsilon: - return (make_real (sc, sc->hash_table_float_epsilon)); - case sl_hash_table_missing_key_value: - return (missing_key_value (sc)); - case sl_heap_size: - return (make_integer (sc, sc->heap_size)); - case sl_history: - return (sl_history_to_list (sc)); - case sl_history_enabled: - return (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_iterator_at_end_value: - return (sc->iterator_at_end_value); - case sl_major_version: - return (make_integer (sc, S7_MAJOR_VERSION)); - case sl_minor_version: - return (make_integer (sc, S7_MINOR_VERSION)); - 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_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_string_port_length: - return (make_integer (sc, sc->max_string_port_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 (make_boolean (sc, sc->muffle_warnings)); - case sl_number_separator: - return (chars[(int) (sc->number_separator)]); - case sl_openlets: - return (make_boolean (sc, sc->has_openlets)); - case sl_output_file_port_length: - return (make_integer (sc, sc->output_file_port_length)); - 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_profile_prefix: - return (sc->profile_prefix); - case sl_rootlet_size: - return (make_integer (sc, let_length (sc, sc->rootlet))); - case sl_safety: - return (make_integer (sc, sc->safety)); - case sl_scheme_version: - return (sc->scheme_version); - case sl_stack: - return (sl_stack_entries_to_list (sc, sc->stack, stack_top (sc))); - case sl_stacktrace_defaults: - return (copy_proper_list ( - sc, sc->stacktrace_defaults)); /* if not copied, we can set! entries - directly to garbage */ - 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_symbol_quote: - return (make_boolean (sc, sc->symbol_quote)); - case sl_symbol_printer: - return (sc->symbol_printer); - case sl_undefined_constant_warnings: - return (make_boolean (sc, sc->undefined_constant_warnings)); - case sl_undefined_identifier_warnings: - return (make_boolean (sc, sc->undefined_identifier_warnings)); - case sl_version: - return (s7_make_string (sc, "s7 " S7_VERSION ", " S7_DATE)); - } - if ((S7_DEBUGGING) && (choice != 0)) - fprintf (stderr, "%s[%d]: choice %" ld64 "\n", __func__, __LINE__, choice); - return (sc->undefined); /* (*s7* 'anything-else) */ + end_temp(sc->y); + return(reverse_in_place_unchecked(sc, sc->nil, lst)); } -s7_pointer -s7_starlet_ref (s7_scheme* sc, s7_pointer sym) /* s7.h, not used here */ +static s7_pointer sl_gc_protected_objects_to_list(s7_scheme *sc) { - if (is_symbol (sym)) { - if (is_keyword (sym)) sym= keyword_symbol (sym); - if (starlet_symbol_id (sym) != sl_no_field) - return (starlet (sc, starlet_symbol_id (sym))); - } - return (sc->undefined); + const s7_pointer nv = s7_vector_copy(sc, sc->protected_objects); + s7_pointer *vals = vector_elements(nv); + const s7_int len = vector_length(nv); + for (s7_int i = 0; i < len; i++) + if (vals[i] == sc->unused) + vals[i] = sc->F; + return(nv); } -s7_pointer -s7_let_field_ref (s7_scheme* sc, s7_pointer sym) { - return (s7_starlet_ref (sc, sym)); +s7_pointer starlet(s7_scheme *sc, s7_int choice) +{ + switch (choice) + { + case sl_accept_all_keyword_arguments: return(make_boolean(sc, sc->accept_all_keyword_arguments)); + case sl_autoloading: return(make_boolean(sc, sc->is_autoloading)); + case sl_catches: return(sl_active_catches_to_list(sc)); + case sl_cpu_time: return(make_real(sc, (double)clock() / (double)CLOCKS_PER_SEC)); /* cpu, not wall-clock time */ + case sl_c_types: return(sl_c_types_to_list(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_random_state); + case sl_default_rationalize_error: return(make_real(sc, sc->default_rationalize_error)); + case sl_equivalent_float_epsilon: return(make_real(sc, sc->equivalent_float_epsilon)); + case sl_expansions: return(make_boolean(sc, sc->is_expanding)); + case sl_file_names: case sl_filenames: return(sl_file_names_to_list(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_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(sl_gc_protected_objects_to_list(sc)); + case sl_gc_resize_heap_by_4_fraction: return(make_real(sc, sc->gc_resize_heap_by_4_fraction)); + case sl_gc_resize_heap_fraction: return(make_real(sc, sc->gc_resize_heap_fraction)); + 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_total_freed: return(make_integer(sc, sc->gc_total_freed)); + case sl_hash_table_float_epsilon: return(make_real(sc, sc->hash_table_float_epsilon)); + case sl_hash_table_missing_key_value: return(missing_key_value(sc)); + case sl_heap_size: return(make_integer(sc, sc->heap_size)); + case sl_history: return(sl_history_to_list(sc)); + case sl_history_enabled: return(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_iterator_at_end_value: return(sc->iterator_at_end_value); + case sl_major_version: return(make_integer(sc, S7_MAJOR_VERSION)); + case sl_minor_version: return(make_integer(sc, S7_MINOR_VERSION)); + 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_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_string_port_length: return(make_integer(sc, sc->max_string_port_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(make_boolean(sc, sc->muffle_warnings)); + case sl_number_separator: return(chars[(int)(sc->number_separator)]); + case sl_openlets: return(make_boolean(sc, sc->has_openlets)); + case sl_output_file_port_length: return(make_integer(sc, sc->output_file_port_length)); + 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_profile_prefix: return(sc->profile_prefix); + case sl_rootlet_size: return(make_integer(sc, let_length(sc, sc->rootlet))); + case sl_safety: return(make_integer(sc, sc->safety)); + case sl_scheme_version: return(sc->scheme_version); + case sl_stack: return(sl_stack_entries_to_list(sc, sc->stack, stack_top(sc))); + case sl_stacktrace_defaults: return(copy_proper_list(sc, sc->stacktrace_defaults)); /* if not copied, we can set! entries directly to garbage */ + 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_symbol_quote: return(make_boolean(sc, sc->symbol_quote)); + case sl_symbol_printer: return(sc->symbol_printer); + case sl_undefined_constant_warnings: return(make_boolean(sc, sc->undefined_constant_warnings)); + case sl_undefined_identifier_warnings: return(make_boolean(sc, sc->undefined_identifier_warnings)); + case sl_version: return(s7_make_string(sc, "s7 " S7_VERSION ", " S7_DATE)); + } + if ((S7_DEBUGGING) && (choice != 0)) fprintf(stderr, "%s[%d]: choice %" ld64 "\n", __func__, __LINE__, choice); + return(sc->undefined); /* (*s7* 'anything-else) */ +} + +s7_pointer s7_starlet_ref(s7_scheme *sc, s7_pointer sym) /* s7.h, not used here */ +{ + if (is_symbol(sym)) + { + if (is_keyword(sym)) + sym = keyword_symbol(sym); + if (starlet_symbol_id(sym) != sl_no_field) + return(starlet(sc, starlet_symbol_id(sym))); + } + return(sc->undefined); } -static s7_pointer -g_starlet_ref_fallback (s7_scheme* sc, s7_pointer args) { - s7_pointer sym= cadr (args); - if (!is_symbol (sym)) - sole_arg_wrong_type_error_nr (sc, sc->let_ref_symbol, sym, - sc->type_names[T_SYMBOL]); - if (is_keyword (sym)) sym= keyword_symbol (sym); - return (starlet (sc, starlet_symbol_id (sym))); +s7_pointer s7_let_field_ref(s7_scheme *sc, s7_pointer sym) {return(s7_starlet_ref(sc, sym));} + +static s7_pointer g_starlet_ref_fallback(s7_scheme *sc, s7_pointer args) +{ + s7_pointer sym = cadr(args); + if (!is_symbol(sym)) + sole_arg_wrong_type_error_nr(sc, sc->let_ref_symbol, sym, sc->type_names[T_SYMBOL]); + if (is_keyword(sym)) + sym = keyword_symbol(sym); + return(starlet(sc, starlet_symbol_id(sym))); } -static s7_pointer -starlet_iterate (s7_scheme* sc, s7_pointer iterator) { +static s7_pointer starlet_iterate(s7_scheme *sc, s7_pointer iterator) +{ s7_pointer symbol, value; - iterator_position (iterator)++; - if (iterator_position (iterator) >= sl_num_fields) - return (iterator_quit (sc, iterator)); - symbol= - make_symbol_with_strlen (sc, starlet_names[iterator_position (iterator)]); - - 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 { - const s7_pointer osw= sc->w; /* protect against starlet list making [sc->w - not in use here?] */ - value= starlet (sc, starlet_symbol_id (symbol)); - if ((S7_DEBUGGING) && (osw != sc->w)) - fprintf (stderr, "s7.c[%d]: osw: %s, sc->w: %s, symbol_id: %d %s\n", - __LINE__, display (osw), display (sc->w), - starlet_symbol_id (symbol), display (symbol)); - sc->w= osw; - } - if (iterator_carrier (iterator)) { - const s7_pointer carrier= iterator_carrier (iterator); - set_car (carrier, symbol); - set_cdr (carrier, value); - return (carrier); - } - return (cons (sc, symbol, value)); -} - -static s7_pointer -starlet_make_iterator (s7_scheme* sc, s7_pointer iter) { - iterator_position (iter)= sl_no_field; - iterator_next (iter) = starlet_iterate; - iterator_carrier (iter) = NULL; - return (iter); -} - -static no_return void -starlet_wrong_type_error_nr (s7_scheme* sc, s7_pointer caller, s7_pointer arg, - s7_pointer typ) { - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_5 ( - sc, - wrap_string ( - sc, "(set! (*s7* '~A) ~S): new value is ~A but should be ~A", 54), - caller, arg, object_type_name (sc, arg), typ)); -} - -static no_return void -starlet_out_of_range_error_nr (s7_scheme* sc, s7_pointer caller, s7_pointer arg, - s7_pointer descr) { - error_nr ( - sc, sc->out_of_range_symbol, - set_elist_4 ( - sc, - wrap_string ( - sc, "(set! (*s7* '~A) ~S): new value is out of range (~A)", 52), - caller, arg, descr)); -} - -static s7_double -sl_real_geq_0 (s7_scheme* sc, s7_pointer sym, s7_pointer val) { + iterator_position(iterator)++; + if (iterator_position(iterator) >= sl_num_fields) + return(iterator_quit(sc, iterator)); + symbol = make_symbol_with_strlen(sc, starlet_names[iterator_position(iterator)]); + + 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 + { + const s7_pointer osw = sc->w; /* protect against starlet list making [sc->w not in use here?] */ + value = starlet(sc, starlet_symbol_id(symbol)); + if ((S7_DEBUGGING) && (osw != sc->w)) fprintf(stderr, "s7.c[%d]: osw: %s, sc->w: %s, symbol_id: %d %s\n", + __LINE__, display(osw), display(sc->w), starlet_symbol_id(symbol), display(symbol)); + sc->w = osw; + } + if (iterator_carrier(iterator)) + { + const s7_pointer carrier = iterator_carrier(iterator); + set_car(carrier, symbol); + set_cdr(carrier, value); + return(carrier); + } + return(cons(sc, symbol, value)); +} + +static s7_pointer starlet_make_iterator(s7_scheme *sc, s7_pointer iter) +{ + iterator_position(iter) = sl_no_field; + iterator_next(iter) = starlet_iterate; + iterator_carrier(iter) = NULL; + return(iter); +} + +static no_return void starlet_wrong_type_error_nr(s7_scheme *sc, s7_pointer caller, s7_pointer arg, s7_pointer typ) +{ + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_5(sc, wrap_string(sc, "(set! (*s7* '~A) ~S): new value is ~A but should be ~A", 54), + caller, arg, object_type_name(sc, arg), typ)); +} + +static no_return void starlet_out_of_range_error_nr(s7_scheme *sc, s7_pointer caller, s7_pointer arg, s7_pointer descr) +{ + error_nr(sc, sc->out_of_range_symbol, + set_elist_4(sc, wrap_string(sc, "(set! (*s7* '~A) ~S): new value is out of range (~A)", 52), caller, arg, descr)); +} + +static s7_double sl_real_geq_0(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ s7_double fv; - if (!is_real (val)) - starlet_wrong_type_error_nr (sc, sym, val, sc->type_names[T_REAL]); - fv= s7_real (val); - if (is_NaN (fv)) - starlet_out_of_range_error_nr (sc, sym, val, - wrap_string (sc, "it can't be nan?", 16)); - if (fv < 0.0) - starlet_out_of_range_error_nr ( - sc, sym, val, wrap_string (sc, "it should not be negative", 25)); - return (fv); -} - -static s7_double -sl_real_0_to_1 (s7_scheme* sc, s7_pointer sym, s7_pointer val) { + if (!is_real(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_REAL]); + fv = s7_real(val); + if (is_NaN(fv)) starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it can't be nan?", 16)); + if (fv < 0.0) starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should not be negative", 25)); + return(fv); +} + +static s7_double sl_real_0_to_1(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ s7_double fv; - if (!is_real (val)) - starlet_wrong_type_error_nr (sc, sym, val, sc->type_names[T_REAL]); - fv= s7_real (val); - if (is_NaN (fv)) - starlet_out_of_range_error_nr (sc, sym, val, - wrap_string (sc, "it can't be nan?", 16)); - if (fv <= 0.0) - starlet_out_of_range_error_nr ( - sc, sym, val, wrap_string (sc, "it should be greater than 0.0", 29)); - if (fv > 1.0) - starlet_out_of_range_error_nr ( - sc, sym, val, - wrap_string (sc, "it should not be greater than 1.0", 33)); - return (fv); -} - -static s7_pointer -sl_integer_gt_0 (s7_scheme* sc, s7_pointer sym, s7_pointer val) { - if (!s7_is_integer (val)) - starlet_wrong_type_error_nr (sc, sym, val, sc->type_names[T_INTEGER]); - if (s7_integer_clamped_if_gmp (sc, val) <= 0) - starlet_out_of_range_error_nr ( - sc, sym, val, wrap_string (sc, "it should be greater than 0.0", 29)); - return (val); -} - -static s7_pointer -sl_integer_geq_0 (s7_scheme* sc, s7_pointer sym, s7_pointer val) { - if (!s7_is_integer (val)) - starlet_wrong_type_error_nr (sc, sym, val, sc->type_names[T_INTEGER]); - if (s7_integer_clamped_if_gmp (sc, val) < 0) - starlet_out_of_range_error_nr ( - sc, sym, val, wrap_string (sc, "it should not be negative", 25)); - return (val); -} - -static s7_pointer -sl_set_history_size (s7_scheme* sc, s7_pointer sym, s7_pointer val) { + if (!is_real(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_REAL]); + fv = s7_real(val); + if (is_NaN(fv)) starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it can't be nan?", 16)); + if (fv <= 0.0) starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should be greater than 0.0", 29)); + if (fv > 1.0) starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should not be greater than 1.0", 33)); + return(fv); +} + +static s7_pointer sl_integer_gt_0(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (!s7_is_integer(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_INTEGER]); + if (s7_integer_clamped_if_gmp(sc, val) <= 0) starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should be greater than 0.0", 29)); + return(val); +} + +static s7_pointer sl_integer_geq_0(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (!s7_is_integer(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_INTEGER]); + if (s7_integer_clamped_if_gmp(sc, val) < 0) starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should not be negative", 25)); + return(val); +} + +static s7_pointer sl_set_history_size(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ #if WITH_HISTORY s7_pointer p1, p2; - s7_int iv= s7_integer_clamped_if_gmp ( - sc, sl_integer_gt_0 (sc, sym, val)); /* was geq?!? */ - if (iv > MAX_HISTORY_SIZE) - iv= MAX_HISTORY_SIZE; /* if 1M, tests can be slow -- assume user wants one - such test */ - if (iv > sc->true_history_size) { - /* splice in the new cells, reattach the circles */ - s7_pointer p3; - const s7_pointer next1= cdr (sc->eval_history1); - const s7_pointer next2= cdr (sc->eval_history2); - const s7_pointer next3= cdr (sc->history_pairs); - set_cdr_unchecked (sc->eval_history1, - semipermanent_list (sc, iv - sc->true_history_size)); - set_cdr_unchecked (sc->eval_history2, - semipermanent_list (sc, iv - sc->true_history_size)); - set_cdr_unchecked (sc->history_pairs, - semipermanent_list (sc, iv - sc->true_history_size)); - for (p3= cdr (sc->history_pairs); is_pair (cdr (p3)); p3= cdr (p3)) - set_car (p3, semipermanent_list (sc, 1)); - set_car (p3, semipermanent_list (sc, 1)); - set_cdr_unchecked (p3, next3); - for (p1= sc->eval_history1, p2= sc->eval_history2; is_pair (cdr (p1)); - p1= cdr (p1), p2= cdr (p2)) - ; - set_cdr_unchecked (p1, next1); - set_cdr_unchecked (p2, next2); - sc->true_history_size= iv; - } - sc->history_size= iv; + s7_int iv = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); /* was geq?!? */ + if (iv > MAX_HISTORY_SIZE) iv = MAX_HISTORY_SIZE; /* if 1M, tests can be slow -- assume user wants one such test */ + if (iv > sc->true_history_size) + { + /* splice in the new cells, reattach the circles */ + s7_pointer p3; + const s7_pointer next1 = cdr(sc->eval_history1); + const s7_pointer next2 = cdr(sc->eval_history2); + const s7_pointer next3 = cdr(sc->history_pairs); + set_cdr_unchecked(sc->eval_history1, semipermanent_list(sc, iv - sc->true_history_size)); + set_cdr_unchecked(sc->eval_history2, semipermanent_list(sc, iv - sc->true_history_size)); + set_cdr_unchecked(sc->history_pairs, semipermanent_list(sc, iv - sc->true_history_size)); + for (p3 = cdr(sc->history_pairs); is_pair(cdr(p3)); p3 = cdr(p3)) set_car(p3, semipermanent_list(sc, 1)); + set_car(p3, semipermanent_list(sc, 1)); + set_cdr_unchecked(p3, next3); + for (p1 = sc->eval_history1, p2 = sc->eval_history2; is_pair(cdr(p1)); p1 = cdr(p1), p2 = cdr(p2)); + set_cdr_unchecked(p1, next1); + set_cdr_unchecked(p2, next2); + sc->true_history_size = iv; + } + sc->history_size = iv; /* clear out both buffers to avoid GC confusion */ - for (s7_pointer p11= sc->eval_history1, p22= sc->eval_history2;; - p22= cdr (p22)) { - set_car (p11, sc->nil); - set_car (p22, sc->nil); - p11= cdr (p11); - if (p11 == sc->eval_history1) break; - } + for (s7_pointer p11 = sc->eval_history1, p22 = sc->eval_history2; ; p22 = cdr(p22)) + { + set_car(p11, sc->nil); + set_car(p22, sc->nil); + p11 = cdr(p11); + if (p11 == sc->eval_history1) break; + } #else - sc->history_size= - s7_integer_clamped_if_gmp (sc, sl_integer_geq_0 (sc, sym, val)); + sc->history_size = s7_integer_clamped_if_gmp(sc, sl_integer_geq_0(sc, sym, val)); #endif - return (val); -} - -static no_return void -sl_stacktrace_wrong_type_error_nr (s7_scheme* sc, s7_int num, s7_pointer arg, - s7_pointer typ, s7_pointer val) { - set_elist_6 (sc, - wrap_string (sc, - "(set! (*s7* 'stacktrace-defaults) '~S): the ~:D " - "list element ~S is ~A but should be ~A", - 86), - val, wrap_integer (sc, num), arg, object_type_name (sc, arg), - typ); - error_nr (sc, sc->wrong_type_arg_symbol, sc->elist_6); -} - -static no_return void -sl_stacktrace_out_of_range_error_nr (s7_scheme* sc, s7_pointer accessor, - s7_pointer lst, s7_pointer arg, - s7_pointer descr) { - error_nr (sc, sc->out_of_range_symbol, - set_elist_5 (sc, - wrap_string (sc, - "(set! (*s7* 'stacktrace-defaults) '~S): " - "~S => ~S is out of range (~A)", - 69), - lst, accessor, arg, descr)); -} - -static s7_pointer -sl_set_stacktrace_defaults (s7_scheme* sc, s7_pointer sym, s7_pointer val) { + return(val); +} + + +static no_return void sl_stacktrace_wrong_type_error_nr(s7_scheme *sc, s7_int num, s7_pointer arg, s7_pointer typ, s7_pointer val) +{ + set_elist_6(sc, wrap_string(sc, "(set! (*s7* 'stacktrace-defaults) '~S): the ~:D list element ~S is ~A but should be ~A", 86), + val, wrap_integer(sc, num), arg, object_type_name(sc, arg), typ); + error_nr(sc, sc->wrong_type_arg_symbol, sc->elist_6); +} + +static no_return void sl_stacktrace_out_of_range_error_nr(s7_scheme *sc, s7_pointer accessor, s7_pointer lst, s7_pointer arg, s7_pointer descr) +{ + error_nr(sc, sc->out_of_range_symbol, + set_elist_5(sc, wrap_string(sc, "(set! (*s7* 'stacktrace-defaults) '~S): ~S => ~S is out of range (~A)", 69), lst, accessor, arg, descr)); +} + +static s7_pointer sl_set_stacktrace_defaults(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ s7_int code_cols; - if (!is_pair (val)) - starlet_wrong_type_error_nr (sc, sym, val, sc->type_names[T_PAIR]); - if (s7_list_length (sc, val) != 5) - starlet_wrong_type_error_nr (sc, sym, val, - wrap_string (sc, "a list with 5 entries", 21)); - - if (!s7_is_integer (car (val))) /* max_frames, default 30 */ - sl_stacktrace_wrong_type_error_nr ( - sc, 1, car (val), wrap_string (sc, "an integer (max stack frames)", 29), - val); + if (!is_pair(val)) + starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_PAIR]); + if (s7_list_length(sc, val) != 5) + starlet_wrong_type_error_nr(sc, sym, val, wrap_string(sc, "a list with 5 entries", 21)); + + if (!s7_is_integer(car(val))) /* max_frames, default 30 */ + sl_stacktrace_wrong_type_error_nr(sc, 1, car(val), wrap_string(sc, "an integer (max stack frames)", 29), val); { - s7_int i= s7_integer_clamped_if_gmp (sc, car (val)); - if ((i <= 0) || - (i > S7_INT32_MAX)) /* keep these in sync with g_stacktrace */ - sl_stacktrace_out_of_range_error_nr ( - sc, sc->car_symbol, val, car (val), - wrap_string (sc, "should be 0 < max-frames <= 2^32", 32)); + s7_int i = s7_integer_clamped_if_gmp(sc, car(val)); + if ((i <= 0) || (i > S7_INT32_MAX)) /* keep these in sync with g_stacktrace */ + sl_stacktrace_out_of_range_error_nr(sc, sc->car_symbol, val, car(val), wrap_string(sc, "should be 0 < max-frames <= 2^32", 32)); } - if (!s7_is_integer (cadr (val))) /* code_cols, default 45 */ - sl_stacktrace_wrong_type_error_nr ( - sc, 2, cadr (val), wrap_string (sc, "an integer (code columns)", 25), - val); - code_cols= s7_integer_clamped_if_gmp (sc, cadr (val)); + if (!s7_is_integer(cadr(val))) /* code_cols, default 45 */ + sl_stacktrace_wrong_type_error_nr(sc, 2, cadr(val), wrap_string(sc, "an integer (code columns)", 25), val); + code_cols = s7_integer_clamped_if_gmp(sc, cadr(val)); if ((code_cols <= 8) || (code_cols > 1024)) - sl_stacktrace_out_of_range_error_nr ( - sc, sc->cadr_symbol, val, cadr (val), - wrap_string (sc, "should be 8 < code-columns <= 1024", 34)); - - if (!s7_is_integer (caddr (val))) /* total_cols, default 80 */ - sl_stacktrace_wrong_type_error_nr ( - sc, 3, caddr (val), wrap_string (sc, "an integer (total columns)", 26), - val); + sl_stacktrace_out_of_range_error_nr(sc, sc->cadr_symbol, val, cadr(val), wrap_string(sc, "should be 8 < code-columns <= 1024", 34)); + + if (!s7_is_integer(caddr(val))) /* total_cols, default 80 */ + sl_stacktrace_wrong_type_error_nr(sc, 3, caddr(val), wrap_string(sc, "an integer (total columns)", 26), val); { - s7_int i= s7_integer_clamped_if_gmp (sc, caddr (val)); - if ((i <= code_cols) || (i > S7_INT32_MAX)) { - int bytes= - snprintf (sc->strbuf, sc->strbuf_size, - "should be %" ld64 " < total-columns <= 2^32", code_cols); - sl_stacktrace_out_of_range_error_nr (sc, sc->caddr_symbol, val, - caddr (val), - wrap_string (sc, sc->strbuf, bytes)); - } - } + s7_int i = s7_integer_clamped_if_gmp(sc, caddr(val)); + if ((i <= code_cols) || (i > S7_INT32_MAX)) + { + int bytes = snprintf(sc->strbuf, sc->strbuf_size, "should be %" ld64 " < total-columns <= 2^32", code_cols); + sl_stacktrace_out_of_range_error_nr(sc, sc->caddr_symbol, val, caddr(val), wrap_string(sc, sc->strbuf, bytes)); + }} - if (!s7_is_integer ( - cadddr (val))) /* notes_start_col, default max(45, code_cols) */ - sl_stacktrace_wrong_type_error_nr ( - sc, 4, cadddr (val), - wrap_string (sc, "an integer (comment position)", 29), val); + if (!s7_is_integer(cadddr(val))) /* notes_start_col, default max(45, code_cols) */ + sl_stacktrace_wrong_type_error_nr(sc, 4, cadddr(val), wrap_string(sc, "an integer (comment position)", 29), val); { - s7_int i= s7_integer_clamped_if_gmp (sc, cadddr (val)); + s7_int i = s7_integer_clamped_if_gmp(sc, cadddr(val)); if ((i <= 0) || (i > S7_INT32_MAX)) - sl_stacktrace_out_of_range_error_nr ( - sc, sc->cadddr_symbol, val, cadddr (val), - wrap_string (sc, "should be 0 < comment-position <= 2^32", 38)); + sl_stacktrace_out_of_range_error_nr(sc, sc->cadddr_symbol, val, cadddr(val), wrap_string(sc, "should be 0 < comment-position <= 2^32", 38)); } - if (!is_boolean (s7_list_ref (sc, val, 4))) /* as_comment, default #f */ - sl_stacktrace_wrong_type_error_nr ( - sc, 5, s7_list_ref (sc, val, 4), - wrap_string (sc, "a boolean (output-as-comment)", 29), val); + if (!is_boolean(s7_list_ref(sc, val, 4))) /* as_comment, default #f */ + sl_stacktrace_wrong_type_error_nr(sc, 5, s7_list_ref(sc, val, 4), wrap_string(sc, "a boolean (output-as-comment)", 29), val); - sc->stacktrace_defaults= copy_proper_list (sc, val); - return (val); + sc->stacktrace_defaults = copy_proper_list(sc, val); + return(val); } -static s7_pointer -sl_set_gc_stats (s7_scheme* sc, s7_pointer sym, s7_pointer val) { - if (is_boolean (val)) { - sc->gc_stats= ((val == sc->T) ? GC_STATS : 0); - return (val); - } - if (!s7_is_integer (val)) - starlet_wrong_type_error_nr (sc, sym, val, sc->type_names[T_BOOLEAN]); - sc->gc_stats= s7_integer_clamped_if_gmp (sc, val); +static s7_pointer sl_set_gc_stats(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (is_boolean(val)) + { + sc->gc_stats = ((val == sc->T) ? GC_STATS : 0); + return(val); + } + if (!s7_is_integer(val)) + starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + sc->gc_stats = s7_integer_clamped_if_gmp(sc, val); if (sc->gc_stats >= 16) /* gc_stats is uint32_t */ - { - sc->gc_stats= 0; - starlet_out_of_range_error_nr ( - sc, sym, val, wrap_string (sc, "it should be between 0 and 15", 29)); - } - return (val); + { + sc->gc_stats = 0; + starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should be between 0 and 15", 29)); + } + return(val); } -static s7_pointer -sl_set_gc_info (s7_scheme* sc, s7_pointer sym, - s7_pointer val) /* ticks_per_second is not settable */ +static s7_pointer sl_set_gc_info(s7_scheme *sc, s7_pointer sym, s7_pointer val) /* ticks_per_second is not settable */ { if (val == sc->F) /* for profile.scm?? seems like a bad idea! */ - { - sc->gc_total_time= 0; - sc->gc_calls = 0; - } - else if ((is_pair (val)) && (s7_is_integer (car (val))) && - (is_pair (cdr (val))) && - (s7_is_integer (cadr (val)))) /* caddr is ticks_per_second which - can't sensibly be set */ - { - sc->gc_total_time= s7_integer (car (val)); - sc->gc_calls = s7_integer (cadr (val)); - } + { + sc->gc_total_time = 0; + sc->gc_calls = 0; + } else - starlet_wrong_type_error_nr ( - sc, sym, val, - wrap_string ( - sc, "#f or a list of two or three integers (the third is ignored)", - 60)); - return (sc->F); -} - -static s7_pointer -sl_set_profile (s7_scheme* sc, s7_pointer sym, s7_pointer val) { - if (!s7_is_integer (val)) - starlet_wrong_type_error_nr (sc, sym, val, sc->type_names[T_INTEGER]); - sc->profile = s7_integer_clamped_if_gmp (sc, val); - sc->debug_or_profile= ((sc->debug > 1) || (sc->profile > 0)); - if (sc->profile > 0) { - if (!is_a_feature (make_symbol (sc, "profile.scm", 11), - 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); + if ((is_pair(val)) && (s7_is_integer(car(val))) && + (is_pair(cdr(val))) && (s7_is_integer(cadr(val)))) /* caddr is ticks_per_second which can't sensibly be set */ + { + sc->gc_total_time = s7_integer(car(val)); + sc->gc_calls = s7_integer(cadr(val)); + } + else starlet_wrong_type_error_nr(sc, sym, val, wrap_string(sc, "#f or a list of two or three integers (the third is ignored)", 60)); + return(sc->F); +} + +static s7_pointer sl_set_profile(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (!s7_is_integer(val)) + starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_INTEGER]); + sc->profile = s7_integer_clamped_if_gmp(sc, val); + sc->debug_or_profile = ((sc->debug > 1) || (sc->profile > 0)); + if (sc->profile > 0) + { + if (!is_a_feature(make_symbol(sc, "profile.scm", 11), 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); } -static s7_pointer -sl_set_debug (s7_scheme* sc, s7_pointer sym, s7_pointer val) { - sc->debug= s7_integer_clamped_if_gmp (sc, sl_integer_geq_0 (sc, sym, val)); - sc->debug_or_profile= ((sc->debug > 1) || (sc->profile > 0)); +static s7_pointer sl_set_debug(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + sc->debug = s7_integer_clamped_if_gmp(sc, sl_integer_geq_0(sc, sym, val)); + sc->debug_or_profile = ((sc->debug > 1) || (sc->profile > 0)); if ((sc->debug > 0) && - (!is_a_feature (make_symbol (sc, "debug.scm", 9), - s7_symbol_value (sc, sc->features_symbol)))) - s7_load (sc, "debug.scm"); - return (val); -} - -static s7_pointer -sl_set_number_separator (s7_scheme* sc, s7_pointer sym, s7_pointer val) { - if (!is_character (val)) - starlet_wrong_type_error_nr (sc, sym, val, sc->type_names[T_CHARACTER]); - if ((is_char_numeric (val)) || (is_char_whitespace (val)) || - (!t_number_separator_p[character (val)]) || (character (val) == 'i') || - (character (val) == 'e') || (character (val) == 'E')) - /* I guess +nan.0 and +inf.0 are not numeric literals, so we don't need to - * catch +n_a_n.0 */ - starlet_wrong_type_error_nr ( - sc, sym, val, - wrap_string (sc, "a printing, non-numeric character", 33)); - sc->number_separator= character (val); - return (val); -} - -static s7_pointer -sl_set_default_hash_table_length (s7_scheme* sc, s7_pointer sym, - s7_pointer val) { - const s7_int iv= s7_integer_clamped_if_gmp ( - sc, sl_integer_gt_0 ( - sc, sym, val)); /* protect against this being 9223372036854775807, - then being used as a hash-table's size */ - if (iv > - sc->max_vector_length) /* these range limits are from g_make_hash_table */ - error_nr ( - sc, sc->out_of_range_symbol, - set_elist_3 ( - sc, - wrap_string (sc, - "(set! (*s7* 'default-hash-table-length) ~D), which " - "is greater than (*s7* 'max-vector-length), ~D", - 96), - val, wrap_integer (sc, sc->max_vector_length))); + (!is_a_feature(make_symbol(sc, "debug.scm", 9), s7_symbol_value(sc, sc->features_symbol)))) + s7_load(sc, "debug.scm"); + return(val); +} + +static s7_pointer sl_set_number_separator(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (!is_character(val)) + starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_CHARACTER]); + if ((is_char_numeric(val)) || (is_char_whitespace(val)) || (!t_number_separator_p[character(val)]) || + (character(val) == 'i') || (character(val) == 'e') || (character(val) == 'E')) + /* I guess +nan.0 and +inf.0 are not numeric literals, so we don't need to catch +n_a_n.0 */ + starlet_wrong_type_error_nr(sc, sym, val, wrap_string(sc, "a printing, non-numeric character", 33)); + sc->number_separator = character(val); + return(val); +} + +static s7_pointer sl_set_default_hash_table_length(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + const s7_int iv = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); /* protect against this being 9223372036854775807, then being used as a hash-table's size */ + if (iv > sc->max_vector_length) /* these range limits are from g_make_hash_table */ + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "(set! (*s7* 'default-hash-table-length) ~D), which is greater than (*s7* 'max-vector-length), ~D", 96), + val, wrap_integer(sc, sc->max_vector_length))); if (iv >= (1LL << 32)) - error_nr ( - sc, sc->out_of_range_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, - "(set! (*s7* 'default-hash-table-length) ~D), which is >= ~D", - 59), - val, wrap_integer (sc, 1LL << 32))); - sc->default_hash_table_length= iv; - return (val); -} - -static s7_pointer -sl_set_symbol_printer (s7_scheme* sc, s7_pointer sym, s7_pointer val) { - if (val != sc->F) { - if (!is_any_closure (val)) - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_4 (sc, - wrap_string (sc, - "(set! (*s7* '~A) ~S): new value is " - "~A but should be a function or #f", - 68), - sym, val, object_type_name (sc, val))); - if (!s7_is_aritable (sc, val, 1)) - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_2 (sc, - wrap_string (sc, - "(*s7* 'symbol-printer) function, " - "~A, should take one argument", - 61), - val)); - } - sc->symbol_printer= val; - return (val); -} - -static s7_pointer -sl_set_symbol_quote (s7_scheme* sc, s7_pointer sym, s7_pointer val) { - if (!is_boolean (val)) - starlet_wrong_type_error_nr (sc, sym, val, sc->type_names[T_BOOLEAN]); - sc->symbol_quote= s7_boolean (sc, val); - return (val); -} - -static s7_pointer -sl_set_heap_size (s7_scheme* sc, s7_pointer sym, s7_pointer val) { - const s7_int iv= - s7_integer_clamped_if_gmp (sc, sl_integer_gt_0 (sc, sym, val)); - if (iv < sc->heap_size) /* heap can't be made smaller currently */ - starlet_out_of_range_error_nr ( - sc, sym, val, - wrap_string (sc, "it can't be less than the current heap size", 43)); + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "(set! (*s7* 'default-hash-table-length) ~D), which is >= ~D", 59), + val, wrap_integer(sc, 1LL << 32))); + sc->default_hash_table_length = iv; + return(val); +} + +static s7_pointer sl_set_symbol_printer(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (val != sc->F) + { + if (!is_any_closure(val)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "(set! (*s7* '~A) ~S): new value is ~A but should be a function or #f", 68), + sym, val, object_type_name(sc, val))); + if (!s7_is_aritable(sc, val, 1)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "(*s7* 'symbol-printer) function, ~A, should take one argument", 61), val)); + } + sc->symbol_printer = val; + return(val); +} + +static s7_pointer sl_set_symbol_quote(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (!is_boolean(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + sc->symbol_quote = s7_boolean(sc, val); + return(val); +} + +static s7_pointer sl_set_heap_size(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + const s7_int iv = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); + if (iv < sc->heap_size) /* heap can't be made smaller currently */ + starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it can't be less than the current heap size", 43)); if (iv > sc->max_heap_size) - starlet_out_of_range_error_nr ( - sc, sym, val, - wrap_string (sc, "it can't be greater than (*s7* 'max-heap-size)", 46)); - if (iv > sc->heap_size) resize_heap_to (sc, iv); - return (val); -} - -static s7_pointer -sl_set_max_heap_size (s7_scheme* sc, s7_pointer sym, s7_pointer val) { - const s7_int iv= - s7_integer_clamped_if_gmp (sc, sl_integer_gt_0 (sc, sym, val)); - if (iv < sc->heap_size) /* heap can't be made smaller currently */ - starlet_out_of_range_error_nr ( - sc, sym, val, - wrap_string (sc, "it can't be less than the current heap size", 43)); - else sc->max_heap_size= iv; /* else needed??? */ - return (val); -} - -static s7_pointer -sl_set_initial_string_port_length (s7_scheme* sc, s7_pointer sym, - s7_pointer val) { - const s7_int iv= - s7_integer_clamped_if_gmp (sc, sl_integer_gt_0 (sc, sym, val)); - if (iv > 1048576) /* just a guess, some joker might try setting this to (*s7* - 'most-positive-fixnum)... */ - starlet_out_of_range_error_nr ( - sc, sym, val, wrap_string (sc, "it doesn't need to be this big", 30)); - sc->initial_string_port_length= iv; - return (val); -} - -static s7_pointer -sl_set_max_string_port_length (s7_scheme* sc, s7_pointer sym, s7_pointer val) { - const s7_int iv= - s7_integer_clamped_if_gmp (sc, sl_integer_gt_0 (sc, sym, val)); + starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it can't be greater than (*s7* 'max-heap-size)", 46)); + if (iv > sc->heap_size) + resize_heap_to(sc, iv); + return(val); +} + +static s7_pointer sl_set_max_heap_size(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + const s7_int iv = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); + if (iv < sc->heap_size) /* heap can't be made smaller currently */ + starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it can't be less than the current heap size", 43)); + else sc->max_heap_size = iv; /* else needed??? */ + return(val); +} + +static s7_pointer sl_set_initial_string_port_length(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + const s7_int iv = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); + if (iv > 1048576) /* just a guess, some joker might try setting this to (*s7* 'most-positive-fixnum)... */ + starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it doesn't need to be this big", 30)); + sc->initial_string_port_length = iv; + return(val); +} + +static s7_pointer sl_set_max_string_port_length(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + const s7_int iv = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); if (iv < sc->initial_string_port_length) - error_nr ( - sc, sc->out_of_range_symbol, - set_elist_3 ( - sc, - wrap_string ( - sc, - "(set! (*s7* 'max-string-port-length) ~S): new value should " - "not be less than the initial string port length: ~D", - 110), - val, wrap_integer (sc, sc->initial_string_port_length))); - sc->max_string_port_length= iv; - return (val); -} - -static s7_pointer -sl_set_max_stack_size (s7_scheme* sc, s7_pointer sym, s7_pointer val) { - const s7_int iv= - s7_integer_clamped_if_gmp (sc, sl_integer_gt_0 (sc, sym, val)); + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "(set! (*s7* 'max-string-port-length) ~S): new value should not be less than the initial string port length: ~D", 110), + val, wrap_integer(sc, sc->initial_string_port_length))); + sc->max_string_port_length = iv; + return(val); +} + +static s7_pointer sl_set_max_stack_size(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + const s7_int iv = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); if (iv < INITIAL_STACK_SIZE) - error_nr ( - sc, sc->out_of_range_symbol, - set_elist_3 ( - sc, - wrap_string (sc, - "(set! (*s7* 'max-stack-size) ~S): new value should " - "not be less than the initial stack size: ~D", - 94), - val, wrap_integer (sc, INITIAL_STACK_SIZE))); + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "(set! (*s7* 'max-stack-size) ~S): new value should not be less than the initial stack size: ~D", 94), + val, wrap_integer(sc, INITIAL_STACK_SIZE))); if (iv > (1LL << 32)) /* sc->max_stack_size is uint32_t */ - error_nr ( - sc, sc->out_of_range_symbol, - set_elist_2 (sc, - wrap_string (sc, - "(set! (*s7* 'max-stack-size) ~S): new value " - "must be less than (ash 1 32) == 4294967296", - 86), - val)); - sc->max_stack_size= (uint32_t) iv; - return (val); -} - -static s7_pointer -sl_set_safety (s7_scheme* sc, s7_pointer sym, s7_pointer val) { - if (!s7_is_integer (val)) - starlet_wrong_type_error_nr (sc, sym, val, sc->type_names[T_INTEGER]); - if ((s7_integer_clamped_if_gmp (sc, val) > 2) || - (s7_integer_clamped_if_gmp (sc, val) < -1)) - starlet_out_of_range_error_nr ( - sc, sym, val, - wrap_string ( - sc, "it should be between -1 (no safety) and 2 (max safety)", 54)); - sc->safety= s7_integer_clamped_if_gmp (sc, val); - return (val); -} - -static s7_pointer -sl_set_default_random_state (s7_scheme* sc, s7_pointer sym, s7_pointer val) { - if (!is_random_state (val)) - starlet_wrong_type_error_nr (sc, sym, val, sc->type_names[T_RANDOM_STATE]); - random_seed (sc->default_random_state) = random_seed (val); - random_carry (sc->default_random_state)= random_carry (val); - return (val); -} - -static s7_pointer -sl_set_float_format_precision (s7_scheme* sc, s7_pointer sym, s7_pointer val) { - /* float-format-precision should not be huge => hangs in snprintf -- limit by - * bits in mantissa? */ - s7_int iv= s7_integer_clamped_if_gmp (sc, sl_integer_geq_0 (sc, sym, val)); - sc->float_format_precision= - (iv < MAX_FLOAT_FORMAT_PRECISION) ? iv : MAX_FLOAT_FORMAT_PRECISION; - return (val); -} - -static s7_pointer -sl_set_undefined_constant_warnings (s7_scheme* sc, s7_pointer sym, - s7_pointer val) { - if (!is_boolean (val)) - starlet_wrong_type_error_nr (sc, sym, val, sc->type_names[T_BOOLEAN]); - sc->undefined_constant_warnings= s7_boolean (sc, val); - return (val); -} - -static s7_pointer -sl_set_undefined_identifier_warnings (s7_scheme* sc, s7_pointer sym, - s7_pointer val) { - if (!is_boolean (val)) - starlet_wrong_type_error_nr (sc, sym, val, sc->type_names[T_BOOLEAN]); - sc->undefined_identifier_warnings= s7_boolean (sc, val); - return (val); -} - -static s7_pointer -sl_set_accept_all_keyword_arguments (s7_scheme* sc, s7_pointer sym, - s7_pointer val) { - if (!is_boolean (val)) - starlet_wrong_type_error_nr (sc, sym, val, sc->type_names[T_BOOLEAN]); - sc->accept_all_keyword_arguments= s7_boolean (sc, val); - return (val); -} - -static s7_pointer -sl_set_autoloading (s7_scheme* sc, s7_pointer sym, s7_pointer val) { - if (!is_boolean (val)) - starlet_wrong_type_error_nr (sc, sym, val, sc->type_names[T_BOOLEAN]); - sc->is_autoloading= s7_boolean (sc, val); - return (val); -} - -static s7_pointer -sl_set_profile_prefix (s7_scheme* sc, s7_pointer sym, s7_pointer val) { - if ((!is_symbol (val)) && (val != sc->F)) - starlet_wrong_type_error_nr (sc, sym, val, - wrap_string (sc, "a symbol or #f", 14)); - sc->profile_prefix= val; - return (val); -} - -static s7_pointer -sl_set_profile_info (s7_scheme* sc, s7_pointer sym, s7_pointer val) { - if (val != sc->F) - starlet_wrong_type_error_nr ( - sc, sym, val, wrap_string (sc, "#f (to clear the table)", 23)); - return (clear_profile_info (sc)); + error_nr(sc, sc->out_of_range_symbol, + set_elist_2(sc, wrap_string(sc, "(set! (*s7* 'max-stack-size) ~S): new value must be less than (ash 1 32) == 4294967296", 86), val)); + sc->max_stack_size = (uint32_t)iv; + return(val); +} + +static s7_pointer sl_set_safety(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (!s7_is_integer(val)) + starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_INTEGER]); + if ((s7_integer_clamped_if_gmp(sc, val) > 2) || (s7_integer_clamped_if_gmp(sc, val) < -1)) + starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should be between -1 (no safety) and 2 (max safety)", 54)); + sc->safety = s7_integer_clamped_if_gmp(sc, val); + return(val); +} + +static s7_pointer sl_set_default_random_state(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (!is_random_state(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_RANDOM_STATE]); + random_seed(sc->default_random_state) = random_seed(val); + random_carry(sc->default_random_state) = random_carry(val); + return(val); +} + +static s7_pointer sl_set_float_format_precision(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + /* float-format-precision should not be huge => hangs in snprintf -- limit by bits in mantissa? */ + s7_int iv = s7_integer_clamped_if_gmp(sc, sl_integer_geq_0(sc, sym, val)); + sc->float_format_precision = (iv < MAX_FLOAT_FORMAT_PRECISION) ? iv : MAX_FLOAT_FORMAT_PRECISION; + return(val); +} + +static s7_pointer sl_set_undefined_constant_warnings(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (!is_boolean(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + sc->undefined_constant_warnings = s7_boolean(sc, val); + return(val); +} + +static s7_pointer sl_set_undefined_identifier_warnings(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (!is_boolean(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + sc->undefined_identifier_warnings = s7_boolean(sc, val); + return(val); +} + +static s7_pointer sl_set_accept_all_keyword_arguments(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (!is_boolean(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + sc->accept_all_keyword_arguments = s7_boolean(sc, val); + return(val); +} + +static s7_pointer sl_set_autoloading(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (!is_boolean(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + sc->is_autoloading = s7_boolean(sc, val); + return(val); +} + +static s7_pointer sl_set_profile_prefix(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if ((!is_symbol(val)) && (val != sc->F)) starlet_wrong_type_error_nr(sc, sym, val, wrap_string(sc, "a symbol or #f", 14)); + sc->profile_prefix = val; + return(val); +} + +static s7_pointer sl_set_profile_info(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (val != sc->F) starlet_wrong_type_error_nr(sc, sym, val, wrap_string(sc, "#f (to clear the table)", 23)); + return(clear_profile_info(sc)); } -static s7_pointer -sl_set_muffle_warnings (s7_scheme* sc, s7_pointer sym, s7_pointer val) { - if (!is_boolean (val)) - starlet_wrong_type_error_nr (sc, sym, val, sc->type_names[T_BOOLEAN]); - sc->muffle_warnings= s7_boolean (sc, val); - return (val); +static s7_pointer sl_set_muffle_warnings(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (!is_boolean(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + sc->muffle_warnings = s7_boolean(sc, val); + return(val); } -static s7_pointer -sl_set_openlets (s7_scheme* sc, s7_pointer sym, s7_pointer val) { - if (!is_boolean (val)) - starlet_wrong_type_error_nr (sc, sym, val, sc->type_names[T_BOOLEAN]); - sc->has_openlets= s7_boolean (sc, val); - return (val); +static s7_pointer sl_set_openlets(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (!is_boolean(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + sc->has_openlets = s7_boolean(sc, val); + return(val); } -static s7_pointer -sl_set_gc_temps_size (s7_scheme* sc, s7_pointer sym, s7_pointer val) { - sc->gc_temps_size= - s7_integer_clamped_if_gmp (sc, sl_integer_gt_0 (sc, sym, val)); - if (sc->gc_temps_size > sc->heap_size) sc->gc_temps_size= sc->heap_size; - return (make_integer (sc, sc->gc_temps_size)); +static s7_pointer sl_set_gc_temps_size(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + sc->gc_temps_size = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); + if (sc->gc_temps_size > sc->heap_size) sc->gc_temps_size = sc->heap_size; + return(make_integer(sc, sc->gc_temps_size)); } -static s7_pointer -sl_set_expansions (s7_scheme* sc, s7_pointer sym, s7_pointer val) { - if (!is_boolean (val)) - starlet_wrong_type_error_nr (sc, sym, val, sc->type_names[T_BOOLEAN]); - sc->is_expanding= s7_boolean (sc, val); - return (val); +static s7_pointer sl_set_expansions(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (!is_boolean(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + sc->is_expanding = s7_boolean(sc, val); + return(val); } -static s7_pointer -sl_set_history_enabled (s7_scheme* sc, s7_pointer sym, s7_pointer val) { - if (!is_boolean (val)) - starlet_wrong_type_error_nr (sc, sym, val, sc->type_names[T_BOOLEAN]); - return (make_boolean (sc, s7_set_history_enabled (sc, s7_boolean (sc, val)))); +static s7_pointer sl_set_history_enabled(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (!is_boolean(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + return(make_boolean(sc, s7_set_history_enabled(sc, s7_boolean(sc, val)))); } #if WITH_R7RS -void -r7rs_init (s7_scheme* sc) { - sc->r7rs_inited= true; -} - -static void -change_scheme_version (s7_scheme* sc, s7_pointer val) { - if (val == sc->r7rs_symbol) { - s7_pointer args= sc->args; /* TODO: gc protect? */ - /* need to check old and new curlet and whether we're coming from s7 or r5rs - * if envs match, and if either is rootlet, more headaches */ - /* if ((!sc->r7rs_inited) || (sc->curlet != sc->rootlet)) */ /* TODO: check - multiple - threads - here, also - if not - rootlet - before and - not == now, - call - r7rs_init - again (or - don't set - flag if - local?) */ - r7rs_init (sc); - sc->args= args; - } - if ((val == sc->r7rs_symbol) || (val == sc->r5rs_symbol)) { - /* s7_eval_c_string(sc, "(begin (define eq? eqv?) (define memq memv) (define - * assq assv))"); */ /* this changes sc->args which confuses others */ - s7_define (sc, sc->curlet, sc->is_eq_symbol, - global_value (sc->is_eqv_symbol)); - s7_define (sc, sc->curlet, sc->memq_symbol, global_value (sc->memv_symbol)); - s7_define (sc, sc->curlet, sc->assq_symbol, global_value (sc->assv_symbol)); - if (sc->curlet == sc->rootlet) { - set_initial_value (sc->is_eq_symbol, initial_value (sc->is_eqv_symbol)); - set_initial_value (sc->memq_symbol, initial_value (sc->memv_symbol)); - set_initial_value (sc->assq_symbol, initial_value (sc->assv_symbol)); - } - } - if (val == sc->s7_symbol) { - if (sc->curlet == sc->rootlet) { - set_global_value (sc->is_eq_symbol, sc->global_is_eq); - set_global_value (sc->memq_symbol, sc->global_memq); - set_global_value (sc->assq_symbol, sc->global_assq); - set_initial_value (sc->is_eq_symbol, sc->initial_is_eq); - set_initial_value (sc->memq_symbol, sc->initial_memq); - set_initial_value (sc->assq_symbol, sc->initial_assq); - /* and set all r7rs to undefined if curlet == rootlet */ - } - else { - s7_define (sc, sc->curlet, sc->is_eq_symbol, sc->global_is_eq); - s7_define (sc, sc->curlet, sc->memq_symbol, sc->global_memq); - s7_define (sc, sc->curlet, sc->assq_symbol, sc->global_assq); - /* and local reference to #_eq? ?? */ +void r7rs_init(s7_scheme *sc) +{ + sc->r7rs_inited = true; +} + +static void change_scheme_version(s7_scheme *sc, s7_pointer val) +{ + if (val == sc->r7rs_symbol) + { + s7_pointer args = sc->args; /* TODO: gc protect? */ + /* need to check old and new curlet and whether we're coming from s7 or r5rs if envs match, and if either is rootlet, more headaches */ + /* if ((!sc->r7rs_inited) || (sc->curlet != sc->rootlet)) */ /* TODO: check multiple threads here, also if not rootlet before and not == now, call r7rs_init again (or don't set flag if local?) */ + r7rs_init(sc); + sc->args = args; } - } + if ((val == sc->r7rs_symbol) || (val == sc->r5rs_symbol)) + { + /* s7_eval_c_string(sc, "(begin (define eq? eqv?) (define memq memv) (define assq assv))"); */ /* this changes sc->args which confuses others */ + s7_define(sc, sc->curlet, sc->is_eq_symbol, global_value(sc->is_eqv_symbol)); + s7_define(sc, sc->curlet, sc->memq_symbol, global_value(sc->memv_symbol)); + s7_define(sc, sc->curlet, sc->assq_symbol, global_value(sc->assv_symbol)); + if (sc->curlet == sc->rootlet) + { + set_initial_value(sc->is_eq_symbol, initial_value(sc->is_eqv_symbol)); + set_initial_value(sc->memq_symbol, initial_value(sc->memv_symbol)); + set_initial_value(sc->assq_symbol, initial_value(sc->assv_symbol)); + }} + if (val == sc->s7_symbol) + { + if (sc->curlet == sc->rootlet) + { + set_global_value(sc->is_eq_symbol, sc->global_is_eq); + set_global_value(sc->memq_symbol, sc->global_memq); + set_global_value(sc->assq_symbol, sc->global_assq); + set_initial_value(sc->is_eq_symbol, sc->initial_is_eq); + set_initial_value(sc->memq_symbol, sc->initial_memq); + set_initial_value(sc->assq_symbol, sc->initial_assq); + /* and set all r7rs to undefined if curlet == rootlet */ + } + else + { + s7_define(sc, sc->curlet, sc->is_eq_symbol, sc->global_is_eq); + s7_define(sc, sc->curlet, sc->memq_symbol, sc->global_memq); + s7_define(sc, sc->curlet, sc->assq_symbol, sc->global_assq); + /* and local reference to #_eq? ?? */ + }} } #endif -static s7_pointer -sl_set_scheme_version (s7_scheme* sc, s7_pointer sym, s7_pointer val) { - /* fprintf(stderr, "%s[%d]: %s %s\n", __func__, __LINE__, display(sym), - * display(val)); */ +static s7_pointer sl_set_scheme_version(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + /* fprintf(stderr, "%s[%d]: %s %s\n", __func__, __LINE__, display(sym), display(val)); */ #if 0 /* this also needs to check curlet old and new */ s7_pointer old_version = sc->scheme_version; if (old_version == val) return(val); #endif - if (!is_symbol (val)) - starlet_wrong_type_error_nr (sc, sym, val, sc->type_names[T_SYMBOL]); - if (is_keyword (val)) val= keyword_symbol (val); - if ((val == sc->s7_symbol) || (val == sc->r5rs_symbol) || - (val == sc->r7rs_symbol)) - sc->scheme_version= val; - else - error_nr ( - sc, sc->out_of_range_symbol, - set_elist_2 ( - sc, - wrap_string ( - sc, "(set! (*s7* 'scheme-version) '~S): unknown scheme version", - 57), - val)); + if (!is_symbol(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_SYMBOL]); + if (is_keyword(val)) val = keyword_symbol(val); + if ((val == sc->s7_symbol) || (val == sc->r5rs_symbol) || (val == sc->r7rs_symbol)) + sc->scheme_version = val; + else error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "(set! (*s7* 'scheme-version) '~S): unknown scheme version", 57), val)); #if WITH_R7RS - change_scheme_version (sc, val); + change_scheme_version(sc, val); #endif - return (val); + return(val); } -static no_return void -sl_unsettable_error_nr (s7_scheme* sc, s7_pointer sym) { - immutable_object_error_nr ( - sc, set_elist_2 (sc, wrap_string (sc, "can't set (*s7* '~S)", 20), sym)); +static no_return void sl_unsettable_error_nr(s7_scheme *sc, s7_pointer sym) +{ + immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't set (*s7* '~S)", 20), sym)); } -s7_pointer -starlet_set_1 (s7_scheme* sc, s7_pointer sym, s7_pointer val) { - if (S7_DEBUGGING) { - if (!is_symbol (sym)) { - fprintf (stderr, "%s[%d]: %s is not a symbol\n", __func__, __LINE__, - display (sym)); - if (sc->stop_at_error) abort (); - } - if (is_symbol_and_keyword (sym)) { - fprintf (stderr, "%s[%d]: %s is a keyword\n", __func__, __LINE__, - display (sym)); - if (sc->stop_at_error) abort (); - } - if (starlet_symbol_id (sym) == sl_no_field) { - fprintf (stderr, "%s[%d]: %s is not an *s7* field\n", __func__, __LINE__, - display (sym)); - if (sc->stop_at_error) abort (); +s7_pointer starlet_set_1(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (S7_DEBUGGING) + { + if (!is_symbol(sym)) {fprintf(stderr, "%s[%d]: %s is not a symbol\n", __func__, __LINE__, display(sym)); if (sc->stop_at_error) abort();} + if (is_symbol_and_keyword(sym)) {fprintf(stderr, "%s[%d]: %s is a keyword\n", __func__, __LINE__, display(sym)); if (sc->stop_at_error) abort();} + if (starlet_symbol_id(sym) == sl_no_field) {fprintf(stderr, "%s[%d]: %s is not an *s7* field\n", __func__, __LINE__, display(sym)); if (sc->stop_at_error) abort();} } - } - switch (starlet_symbol_id (sym)) { - case sl_accept_all_keyword_arguments: - return (sl_set_accept_all_keyword_arguments (sc, sym, val)); - case sl_autoloading: - return (sl_set_autoloading (sc, sym, val)); - case sl_catches: - sl_unsettable_error_nr (sc, sym); - case sl_cpu_time: - sl_unsettable_error_nr (sc, sym); - case sl_c_types: - sl_unsettable_error_nr (sc, sym); - case sl_debug: - return (sl_set_debug (sc, sym, val)); - case sl_default_hash_table_length: - return (sl_set_default_hash_table_length (sc, sym, val)); - case sl_default_random_state: - return (sl_set_default_random_state (sc, sym, val)); - case sl_default_rationalize_error: - sc->default_rationalize_error= sl_real_geq_0 (sc, sym, val); - return (val); - case sl_equivalent_float_epsilon: - sc->equivalent_float_epsilon= sl_real_geq_0 (sc, sym, val); - return (val); - case sl_expansions: - return (sl_set_expansions (sc, sym, val)); - case sl_file_names: - case sl_filenames: - sl_unsettable_error_nr (sc, sym); - case sl_float_format_precision: - return (sl_set_float_format_precision (sc, sym, val)); - case sl_free_heap_size: - sl_unsettable_error_nr (sc, sym); - case sl_gc_freed: - sl_unsettable_error_nr (sc, sym); - case sl_gc_total_freed: - sl_unsettable_error_nr (sc, sym); - case sl_gc_protected_objects: - sl_unsettable_error_nr (sc, sym); - case sl_gc_temps_size: - return (sl_set_gc_temps_size (sc, sym, val)); - case sl_gc_resize_heap_fraction: - sc->gc_resize_heap_fraction= sl_real_0_to_1 (sc, sym, val); - return (val); - case sl_gc_resize_heap_by_4_fraction: - sc->gc_resize_heap_by_4_fraction= sl_real_0_to_1 (sc, sym, val); - return (val); - case sl_gc_stats: - return (sl_set_gc_stats (sc, sym, val)); - case sl_gc_info: - return (sl_set_gc_info (sc, sym, val)); - case sl_hash_table_float_epsilon: - sc->hash_table_float_epsilon= sl_real_geq_0 (sc, sym, val); - return (val); - case sl_hash_table_missing_key_value: - hash_entry_set_value (sc->unentry, val); - return (val); - case sl_heap_size: - return (sl_set_heap_size (sc, sym, val)); - case sl_history: - replace_current_code (sc, val); - return (val); - case sl_history_enabled: - return (sl_set_history_enabled (sc, sym, val)); - case sl_history_size: - return (sl_set_history_size (sc, sym, val)); - case sl_initial_string_port_length: - return (sl_set_initial_string_port_length (sc, sym, val)); - case sl_iterator_at_end_value: - sc->iterator_at_end_value= val; - return (val); - case sl_major_version: - sl_unsettable_error_nr (sc, sym); - case sl_minor_version: - sl_unsettable_error_nr (sc, sym); - case sl_max_heap_size: - return (sl_set_max_heap_size (sc, sym, val)); - case sl_max_list_length: - sc->max_list_length= - s7_integer_clamped_if_gmp (sc, sl_integer_gt_0 (sc, sym, val)); - return (val); - case sl_max_stack_size: - return (sl_set_max_stack_size (sc, sym, val)); - case sl_max_string_length: - sc->max_string_length= - s7_integer_clamped_if_gmp (sc, sl_integer_gt_0 (sc, sym, val)); - return (val); - case sl_max_string_port_length: - return (sl_set_max_string_port_length (sc, sym, val)); - case sl_max_vector_dimensions: - sc->max_vector_dimensions= - s7_integer_clamped_if_gmp (sc, sl_integer_gt_0 (sc, sym, val)); - return (val); - case sl_max_vector_length: - sc->max_vector_length= - s7_integer_clamped_if_gmp (sc, sl_integer_gt_0 (sc, sym, val)); - return (val); - case sl_memory_usage: - sl_unsettable_error_nr (sc, sym); - case sl_most_negative_fixnum: - sl_unsettable_error_nr (sc, sym); - case sl_most_positive_fixnum: - sl_unsettable_error_nr (sc, sym); - case sl_muffle_warnings: - return (sl_set_muffle_warnings (sc, sym, val)); - case sl_number_separator: - return (sl_set_number_separator ( - sc, sym, val)); /* I think no PL uses the separator in output */ - case sl_openlets: - return (sl_set_openlets (sc, sym, val)); - case sl_output_file_port_length: - sc->output_file_port_length= - s7_integer_clamped_if_gmp (sc, sl_integer_gt_0 (sc, sym, val)); - return (val); - case sl_print_length: - sc->print_length= - s7_integer_clamped_if_gmp (sc, sl_integer_geq_0 (sc, sym, val)); - return (val); - case sl_profile: - return (sl_set_profile (sc, sym, val)); - case sl_profile_info: - return (sl_set_profile_info (sc, sym, val)); - case sl_profile_prefix: - return (sl_set_profile_prefix (sc, sym, val)); - case sl_rootlet_size: - sl_unsettable_error_nr (sc, sym); - case sl_safety: - return (sl_set_safety (sc, sym, val)); - case sl_scheme_version: - return (sl_set_scheme_version (sc, sym, val)); - case sl_stacktrace_defaults: - return (sl_set_stacktrace_defaults (sc, sym, val)); - case sl_stack: - sl_unsettable_error_nr (sc, sym); - case sl_stack_size: - sl_unsettable_error_nr (sc, sym); - case sl_stack_top: - sl_unsettable_error_nr (sc, sym); - case sl_symbol_printer: - return (sl_set_symbol_printer (sc, sym, val)); - case sl_symbol_quote: - return (sl_set_symbol_quote (sc, sym, val)); - case sl_undefined_constant_warnings: - return (sl_set_undefined_constant_warnings (sc, sym, val)); - case sl_undefined_identifier_warnings: - return (sl_set_undefined_identifier_warnings (sc, sym, val)); - case sl_version: - sl_unsettable_error_nr (sc, sym); - default: - if (S7_DEBUGGING) - fprintf (stderr, "%s[%d]: we should not be here\n", __func__, __LINE__); - return (sc->undefined); /* can't happen */ - /* error_nr(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); + switch (starlet_symbol_id(sym)) + { + case sl_accept_all_keyword_arguments: return(sl_set_accept_all_keyword_arguments(sc, sym, val)); + case sl_autoloading: return(sl_set_autoloading(sc, sym, val)); + case sl_catches: sl_unsettable_error_nr(sc, sym); + case sl_cpu_time: sl_unsettable_error_nr(sc, sym); + case sl_c_types: sl_unsettable_error_nr(sc, sym); + case sl_debug: return(sl_set_debug(sc, sym, val)); + case sl_default_hash_table_length: return(sl_set_default_hash_table_length(sc, sym, val)); + case sl_default_random_state: return(sl_set_default_random_state(sc, sym, val)); + case sl_default_rationalize_error: sc->default_rationalize_error = sl_real_geq_0(sc, sym, val); return(val); + case sl_equivalent_float_epsilon: sc->equivalent_float_epsilon = sl_real_geq_0(sc, sym, val); return(val); + case sl_expansions: return(sl_set_expansions(sc, sym, val)); + case sl_file_names: case sl_filenames: sl_unsettable_error_nr(sc, sym); + case sl_float_format_precision: return(sl_set_float_format_precision(sc, sym, val)); + case sl_free_heap_size: sl_unsettable_error_nr(sc, sym); + case sl_gc_freed: sl_unsettable_error_nr(sc, sym); + case sl_gc_total_freed: sl_unsettable_error_nr(sc, sym); + case sl_gc_protected_objects: sl_unsettable_error_nr(sc, sym); + case sl_gc_temps_size: return(sl_set_gc_temps_size(sc, sym, val)); + case sl_gc_resize_heap_fraction: sc->gc_resize_heap_fraction = sl_real_0_to_1(sc, sym, val); return(val); + case sl_gc_resize_heap_by_4_fraction: sc->gc_resize_heap_by_4_fraction = sl_real_0_to_1(sc, sym, val); return(val); + case sl_gc_stats: return(sl_set_gc_stats(sc, sym, val)); + case sl_gc_info: return(sl_set_gc_info(sc, sym, val)); + case sl_hash_table_float_epsilon: sc->hash_table_float_epsilon = sl_real_geq_0(sc, sym, val); return(val); + case sl_hash_table_missing_key_value: hash_entry_set_value(sc->unentry, val); return(val); + case sl_heap_size: return(sl_set_heap_size(sc, sym, val)); + case sl_history: replace_current_code(sc, val); return(val); + case sl_history_enabled: return(sl_set_history_enabled(sc, sym, val)); + case sl_history_size: return(sl_set_history_size(sc, sym, val)); + case sl_initial_string_port_length: return(sl_set_initial_string_port_length(sc, sym, val)); + case sl_iterator_at_end_value: sc->iterator_at_end_value = val; return(val); + case sl_major_version: sl_unsettable_error_nr(sc, sym); + case sl_minor_version: sl_unsettable_error_nr(sc, sym); + case sl_max_heap_size: return(sl_set_max_heap_size(sc, sym, val)); + case sl_max_list_length: sc->max_list_length = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(val); + case sl_max_stack_size: return(sl_set_max_stack_size(sc, sym, val)); + case sl_max_string_length: sc->max_string_length = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(val); + case sl_max_string_port_length: return(sl_set_max_string_port_length(sc, sym, val)); + case sl_max_vector_dimensions: sc->max_vector_dimensions = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(val); + case sl_max_vector_length: sc->max_vector_length = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(val); + case sl_memory_usage: sl_unsettable_error_nr(sc, sym); + case sl_most_negative_fixnum: sl_unsettable_error_nr(sc, sym); + case sl_most_positive_fixnum: sl_unsettable_error_nr(sc, sym); + case sl_muffle_warnings: return(sl_set_muffle_warnings(sc, sym, val)); + case sl_number_separator: return(sl_set_number_separator(sc, sym, val)); /* I think no PL uses the separator in output */ + case sl_openlets: return(sl_set_openlets(sc, sym, val)); + case sl_output_file_port_length: sc->output_file_port_length = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(val); + case sl_print_length: sc->print_length = s7_integer_clamped_if_gmp(sc, sl_integer_geq_0(sc, sym, val)); return(val); + case sl_profile: return(sl_set_profile(sc, sym, val)); + case sl_profile_info: return(sl_set_profile_info(sc, sym, val)); + case sl_profile_prefix: return(sl_set_profile_prefix(sc, sym, val)); + case sl_rootlet_size: sl_unsettable_error_nr(sc, sym); + case sl_safety: return(sl_set_safety(sc, sym, val)); + case sl_scheme_version: return(sl_set_scheme_version(sc, sym, val)); + case sl_stacktrace_defaults: return(sl_set_stacktrace_defaults(sc, sym,val)); + case sl_stack: sl_unsettable_error_nr(sc, sym); + case sl_stack_size: sl_unsettable_error_nr(sc, sym); + case sl_stack_top: sl_unsettable_error_nr(sc, sym); + case sl_symbol_printer: return(sl_set_symbol_printer(sc, sym, val)); + case sl_symbol_quote: return(sl_set_symbol_quote(sc, sym, val)); + case sl_undefined_constant_warnings: return(sl_set_undefined_constant_warnings(sc, sym, val)); + case sl_undefined_identifier_warnings: return(sl_set_undefined_identifier_warnings(sc, sym, val)); + case sl_version: sl_unsettable_error_nr(sc, sym); + default: + if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: we should not be here\n", __func__, __LINE__); + return(sc->undefined); /* can't happen */ + /* error_nr(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_starlet_set (s7_scheme* sc, s7_pointer sym, s7_pointer new_value) { - if (is_symbol (sym)) { - if (is_keyword (sym)) sym= keyword_symbol (sym); - if (starlet_symbol_id (sym) != sl_no_field) - return (starlet_set_1 (sc, sym, new_value)); - } - return (sc->undefined); +s7_pointer s7_starlet_set(s7_scheme *sc, s7_pointer sym, s7_pointer new_value) +{ + if (is_symbol(sym)) + { + if (is_keyword(sym)) + sym = keyword_symbol(sym); + if (starlet_symbol_id(sym) != sl_no_field) + return(starlet_set_1(sc, sym, new_value)); + } + return(sc->undefined); } -s7_pointer -s7_let_field_set (s7_scheme* sc, s7_pointer sym, s7_pointer new_value) { - return (s7_starlet_set (sc, sym, new_value)); -} +s7_pointer s7_let_field_set(s7_scheme *sc, s7_pointer sym, s7_pointer new_value) {return(s7_starlet_set(sc, sym, new_value));} #define NUM_UNSETTABLE_FIELDS 19 -static void -init_starlet_immutable_field (void) { - const int32_t unsettable_fields[NUM_UNSETTABLE_FIELDS]= { - sl_catches, - sl_cpu_time, - sl_c_types, - sl_filenames, - sl_file_names, - sl_free_heap_size, - sl_gc_freed, - sl_gc_protected_objects, - sl_gc_total_freed, - sl_major_version, - sl_memory_usage, - sl_minor_version, - sl_most_negative_fixnum, - sl_most_positive_fixnum, - sl_rootlet_size, - sl_stack, - sl_stack_size, - sl_stack_top, - sl_version}; - - starlet_immutable_field= (bool*) Calloc (sl_num_fields, sizeof (bool)); - for (int32_t i= 0; i < NUM_UNSETTABLE_FIELDS; i++) - starlet_immutable_field[unsettable_fields[i]]= true; -} - -/* (let-temporarily (((*s7* 'safety) 1)) (object->string (inlet *s7*) - * :readable)): this uses :fields reversed with immutable! on the filenames */ +static void init_starlet_immutable_field(void) +{ + const int32_t unsettable_fields[NUM_UNSETTABLE_FIELDS] = { + sl_catches, sl_cpu_time, sl_c_types, sl_filenames, sl_file_names, sl_free_heap_size, sl_gc_freed, sl_gc_protected_objects, + sl_gc_total_freed, sl_major_version, sl_memory_usage, sl_minor_version, sl_most_negative_fixnum, sl_most_positive_fixnum, + sl_rootlet_size, sl_stack, sl_stack_size, sl_stack_top, sl_version}; + + starlet_immutable_field = (bool *)Calloc(sl_num_fields, sizeof(bool)); + for (int32_t i = 0; i < NUM_UNSETTABLE_FIELDS; i++) starlet_immutable_field[unsettable_fields[i]] = true; +} + +/* (let-temporarily (((*s7* 'safety) 1)) (object->string (inlet *s7*) :readable)): this uses :fields reversed with immutable! on the filenames */ + #define NUM_INTEGER_WRAPPERS 4 #define NUM_REAL_WRAPPERS 4 @@ -103821,2484 +79259,1765 @@ init_starlet_immutable_field (void) { #if !MS_WINDOWS /* s7bt, s7btfull: gdb stacktrace decoding */ -static const char* -decoded_name (s7_scheme* sc, const s7_pointer p) { - if (p == sc->value) return ("s7->value"); - if (p == sc->args) return ("s7->args"); - if (p == sc->code) return ("s7->code"); - if (p == sc->cur_code) return ("s7->cur_code"); - if (p == sc->curlet) return ("s7->curlet"); - if (p == sc->nil) return ("()"); - if (p == sc->T) return ("#t"); - if (p == sc->F) return ("#f"); - if (p == eof_object) return ("#"); - if (p == sc->undefined) return ("#"); - if (p == sc->unspecified) return ("#"); +static const char *decoded_name(s7_scheme *sc, const s7_pointer p) +{ + if (p == sc->value) return("s7->value"); + if (p == sc->args) return("s7->args"); + if (p == sc->code) return("s7->code"); + if (p == sc->cur_code) return("s7->cur_code"); + if (p == sc->curlet) return("s7->curlet"); + if (p == sc->nil) return("()"); + if (p == sc->T) return("#t"); + if (p == sc->F) return("#f"); + if (p == eof_object) return("#"); + if (p == sc->undefined) return("#"); + if (p == sc->unspecified) return("#"); #if S7_DEBUGGING - if (p == sc->no_value) return ("no_value"); + if (p == sc->no_value) return("no_value"); #endif - if (p == sc->unused) return ("#"); - if (p == sc->symbol_table) return ("s7->symbol_table"); - if (p == sc->rootlet) return ("rootlet"); - if (p == sc->starlet) return ("*s7*"); /* this is the function */ - if (p == sc->owlet) return ("owlet"); /* is this possible? */ - 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"); - if (p == current_input_port (sc)) return ("current-input-port"); - if (p == current_output_port (sc)) return ("current-output-port"); - if (p == current_error_port (sc)) return ("current-error_port"); - if ((is_let (p)) && (is_unlet (p))) return ("unlet"); + if (p == sc->unused) return("#"); + if (p == sc->symbol_table) return("s7->symbol_table"); + if (p == sc->rootlet) return("rootlet"); + if (p == sc->starlet) return("*s7*"); /* this is the function */ + if (p == sc->owlet) return("owlet"); /* is this possible? */ + 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"); + if (p == current_input_port(sc)) return("current-input-port"); + if (p == current_output_port(sc)) return("current-output-port"); + if (p == current_error_port(sc)) return("current-error_port"); + if ((is_let(p)) && (is_unlet(p))) return("unlet"); { s7_pointer wrapper; - int32_t i; - for (i= 0, wrapper= sc->string_wrappers; i < NUM_STRING_WRAPPERS; - i++, wrapper = cdr (wrapper)) - if (car (wrapper) == p) return ("string-wrapper"); - for (i= 0, wrapper= sc->integer_wrappers; i < NUM_INTEGER_WRAPPERS; - i++, wrapper = cdr (wrapper)) - if (car (wrapper) == p) return ("integer-wrapper"); - for (i= 0, wrapper= sc->real_wrappers; i < NUM_REAL_WRAPPERS; - i++, wrapper = cdr (wrapper)) - if (car (wrapper) == p) return ("real-wrapper"); - for (i= 0, wrapper= sc->complex_wrappers; i < NUM_COMPLEX_WRAPPERS; - i++, wrapper = cdr (wrapper)) - if (car (wrapper) == p) return ("complex-wrapper"); - for (i= 0, wrapper= sc->c_pointer_wrappers; i < NUM_C_POINTER_WRAPPERS; - i++, wrapper = cdr (wrapper)) - if (car (wrapper) == p) return ("c-pointer-wrapper"); - for (i= 0, wrapper= sc->let_wrappers; i < NUM_LET_WRAPPERS; - i++, wrapper = cdr (wrapper)) - if (car (wrapper) == p) return ("let-wrapper"); - for (i= 0, wrapper= sc->slot_wrappers; i < NUM_SLOT_WRAPPERS; - i++, wrapper = cdr (wrapper)) - if (car (wrapper) == p) return ("slot-wrapper"); + int32_t i; + for (i = 0, wrapper = sc->string_wrappers; i < NUM_STRING_WRAPPERS; i++, wrapper = cdr(wrapper)) if (car(wrapper) == p) return("string-wrapper"); + for (i = 0, wrapper = sc->integer_wrappers; i < NUM_INTEGER_WRAPPERS; i++, wrapper = cdr(wrapper)) if (car(wrapper) == p) return("integer-wrapper"); + for (i = 0, wrapper = sc->real_wrappers; i < NUM_REAL_WRAPPERS; i++, wrapper = cdr(wrapper)) if (car(wrapper) == p) return("real-wrapper"); + for (i = 0, wrapper = sc->complex_wrappers; i < NUM_COMPLEX_WRAPPERS; i++, wrapper = cdr(wrapper)) if (car(wrapper) == p) return("complex-wrapper"); + for (i = 0, wrapper = sc->c_pointer_wrappers; i < NUM_C_POINTER_WRAPPERS; i++, wrapper = cdr(wrapper)) if (car(wrapper) == p) return("c-pointer-wrapper"); + for (i = 0, wrapper = sc->let_wrappers; i < NUM_LET_WRAPPERS; i++, wrapper = cdr(wrapper)) if (car(wrapper) == p) return("let-wrapper"); + for (i = 0, wrapper = sc->slot_wrappers; i < NUM_SLOT_WRAPPERS; i++, wrapper = cdr(wrapper)) if (car(wrapper) == p) return("slot-wrapper"); } - return ((p == sc->stack) ? "stack" : NULL); + return((p == sc->stack) ? "stack" : NULL); } -static bool -is_decodable (s7_scheme* sc, const s7_pointer ptr) { +static bool is_decodable(s7_scheme *sc, const s7_pointer ptr) +{ /* check symbol-table */ - for (int32_t i= 0; i < SYMBOL_TABLE_SIZE; i++) - for (s7_pointer syms= vector_element (sc->symbol_table, i); is_pair (syms); - syms = cdr (syms)) { - const s7_pointer sym= car (syms); - if ((sym == ptr) || - ((is_defined_global (sym)) && (ptr == global_value (sym)))) - return (true); - } - for (int32_t i= 0; i < NUM_CHARS; i++) - if (ptr == chars[i]) return (true); - for (int32_t i= 0; i < NUM_SMALL_INTS; i++) - if (ptr == &small_ints[i]) return (true); + for (int32_t i = 0; i < SYMBOL_TABLE_SIZE; i++) + for (s7_pointer syms = vector_element(sc->symbol_table, i); is_pair(syms); syms = cdr(syms)) + { + const s7_pointer sym = car(syms); + if ((sym == ptr) || + ((is_defined_global(sym)) && (ptr == global_value(sym)))) + return(true); + } + for (int32_t i = 0; i < NUM_CHARS; i++) if (ptr == chars[i]) return(true); + for (int32_t i = 0; i < NUM_SMALL_INTS; i++) if (ptr == &small_ints[i]) return(true); { /* check the heap */ - s7_pointer* tp = sc->heap; - const s7_pointer* heap_top= (s7_pointer*) (sc->heap + sc->heap_size); + s7_pointer *tp = sc->heap; + const s7_pointer *heap_top = (s7_pointer *)(sc->heap + sc->heap_size); while (tp < heap_top) - if (ptr == (*tp++)) return (true); - } - return (false); -} - -const char* s7_decode_bt (s7_scheme* sc); -const char* -s7_decode_bt (s7_scheme* sc) { - FILE* fp= fopen ("gdb.txt", "r"); - if (fp) { - s7_int 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 (" oops "); - } - bt[size]= '\0'; - fclose (fp); - - for (s7_int 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'))))) { - s7_pointer vp; - const int32_t vals= - sscanf ((const char*) (bt + i + 1), "%p", (void**) (&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 { - const char* dname= decoded_name (sc, vp); - if (dname) { - if (bt[i + 1] == ' ') fputc (' ', stdout); - fprintf (stdout, "%s[%s]%s", bold_text, dname, unbold_text); - } - if ((dname) || (is_decodable (sc, vp))) { - if (bt[i + 1] == ' ') fputc (' ', stdout); - i= k - 1; - if (s7_is_valid (sc, vp)) { - const s7_pointer strp= object_to_string_truncated (sc, vp); - if (dname) fprintf (stdout, " "); - fprintf (stdout, "%s%s%s", bold_text, string_value (strp), - unbold_text); - if ((is_pair (vp)) && (has_location (vp))) { - uint32_t line= pair_line_number (vp), - file= pair_file_number (vp); - 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; + if (ptr == (*tp++)) + return(true); } - return (""); + return(false); +} + +const char *s7_decode_bt(s7_scheme *sc); +const char *s7_decode_bt(s7_scheme *sc) +{ + FILE *fp = fopen("gdb.txt", "r"); + if (fp) + { + s7_int 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(" oops "); + } + bt[size] = '\0'; + fclose(fp); + + for (s7_int 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'))))) + { + s7_pointer vp; + const int32_t vals = sscanf((const char *)(bt + i + 1), "%p", (void **)(&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 + { + const char *dname = decoded_name(sc, vp); + if (dname) + { + if (bt[i + 1] == ' ') fputc(' ', stdout); + fprintf(stdout, "%s[%s]%s", bold_text, dname, unbold_text); + } + if ((dname) || (is_decodable(sc, vp))) + { + if (bt[i + 1] == ' ') fputc(' ', stdout); + i = k - 1; + if (s7_is_valid(sc, vp)) + { + const s7_pointer strp = object_to_string_truncated(sc, vp); + if (dname) fprintf(stdout, " "); + fprintf(stdout, "%s%s%s", bold_text, string_value(strp), unbold_text); + if ((is_pair(vp)) && + (has_location(vp))) + { + uint32_t line = pair_line_number(vp), file = pair_file_number(vp); + 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(""); } #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; + +/* -------------------------------- 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_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_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_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_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_opAAq] = fx_c_s_opaaq; - fx_function[HOP_HASH_TABLE_INCREMENT]= fx_hash_table_increment; + 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_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_NA_NA] = fx_cond_na_na; - fx_function[OP_CASE_A_I_S_A] = fx_case_a_i_s_a; - fx_function[OP_CASE_A_E_S_A] = fx_case_a_e_s_a; - fx_function[OP_CASE_A_G_S_A] = fx_case_a_g_s_a; - fx_function[OP_CASE_A_S_G_A] = fx_case_a_s_g_a; - 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_WITH_LET_S] = fx_with_let_s; - - fx_function[OP_IMPLICIT_STARLET_REF_S] = fx_implicit_starlet_ref_s; - fx_function[OP_IMPLICIT_LET_REF_C] = fx_implicit_let_ref_c; - fx_function[OP_IMPLICIT_HASH_TABLE_REF_A]= fx_implicit_hash_table_ref_a; - fx_function[OP_IMPLICIT_PAIR_REF_A] = fx_implicit_pair_ref_a; - fx_function[OP_IMPLICIT_C_OBJECT_REF_A] = fx_implicit_c_object_ref_a; - fx_function[OP_IMPLICIT_VECTOR_REF_A] = fx_implicit_vector_ref_a; - - /* 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 */ - /* these choices make only a small difference (< 1%) in timings except in - * tclo */ - fx_function[OP_TC_AND_A_OR_A_LA] = op_tc_and_a_or_a_la; - fx_function[OP_TC_OR_A_AND_A_LA] = op_tc_or_a_and_a_la; - fx_function[OP_TC_OR_A_A_AND_A_A_LA] = op_tc_or_a_a_and_a_a_la; - fx_function[OP_TC_AND_A_OR_A_L2A] = op_tc_and_a_or_a_l2a; - fx_function[OP_TC_OR_A_AND_A_L2A] = op_tc_or_a_and_a_l2a; - fx_function[OP_TC_AND_A_OR_A_L3A] = op_tc_and_a_or_a_l3a; - fx_function[OP_TC_OR_A_AND_A_L3A] = op_tc_or_a_and_a_l3a; - fx_function[OP_TC_AND_A_OR_A_A_LA] = op_tc_and_a_or_a_a_la; - fx_function[OP_TC_OR_A_AND_A_A_LA] = op_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_Z_L2A] = fx_tc_if_a_z_l2a; - fx_function[OP_TC_IF_A_Z_L3A] = fx_tc_if_a_z_l3a; - 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_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_L2A_Z] = fx_tc_if_a_z_if_a_l2a_z; - fx_function[OP_TC_IF_A_Z_IF_A_Z_L2A] = fx_tc_if_a_z_if_a_z_l2a; - fx_function[OP_TC_IF_A_Z_IF_A_L3A_L3A]= fx_tc_if_a_z_if_a_l3a_l3a; - fx_function[OP_TC_IF_A_Z_IF_A_Z_L3A] = fx_tc_if_a_z_if_a_z_l3a; - fx_function[OP_TC_IF_A_Z_IF_A_L3A_Z] = fx_tc_if_a_z_if_a_l3a_z; - fx_function[OP_TC_CASE_LA] = fx_tc_case_la; - fx_function[OP_TC_CASE_L2A] = fx_tc_case_l2a; - fx_function[OP_TC_CASE_L3A] = fx_tc_case_l3a; - fx_function[OP_TC_OR_A_AND_A_A_L3A] = op_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_L2A] = fx_tc_let_if_a_z_l2a; - fx_function[OP_TC_LET_WHEN_L2A] = op_tc_let_when_l2a; - fx_function[OP_TC_LET_COND] = fx_tc_let_cond; - fx_function[OP_TC_COND_N] = fx_tc_cond_n; + 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_NA_NA] = fx_cond_na_na; + fx_function[OP_CASE_A_I_S_A] = fx_case_a_i_s_a; + fx_function[OP_CASE_A_E_S_A] = fx_case_a_e_s_a; + fx_function[OP_CASE_A_G_S_A] = fx_case_a_g_s_a; + fx_function[OP_CASE_A_S_G_A] = fx_case_a_s_g_a; + 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_WITH_LET_S] = fx_with_let_s; + + fx_function[OP_IMPLICIT_STARLET_REF_S] = fx_implicit_starlet_ref_s; + fx_function[OP_IMPLICIT_LET_REF_C] = fx_implicit_let_ref_c; + fx_function[OP_IMPLICIT_HASH_TABLE_REF_A] = fx_implicit_hash_table_ref_a; + fx_function[OP_IMPLICIT_PAIR_REF_A] = fx_implicit_pair_ref_a; + fx_function[OP_IMPLICIT_C_OBJECT_REF_A] = fx_implicit_c_object_ref_a; + fx_function[OP_IMPLICIT_VECTOR_REF_A] = fx_implicit_vector_ref_a; + + /* 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 */ + /* these choices make only a small difference (< 1%) in timings except in tclo */ + fx_function[OP_TC_AND_A_OR_A_LA] = op_tc_and_a_or_a_la; + fx_function[OP_TC_OR_A_AND_A_LA] = op_tc_or_a_and_a_la; + fx_function[OP_TC_OR_A_A_AND_A_A_LA] = op_tc_or_a_a_and_a_a_la; + fx_function[OP_TC_AND_A_OR_A_L2A] = op_tc_and_a_or_a_l2a; + fx_function[OP_TC_OR_A_AND_A_L2A] = op_tc_or_a_and_a_l2a; + fx_function[OP_TC_AND_A_OR_A_L3A] = op_tc_and_a_or_a_l3a; + fx_function[OP_TC_OR_A_AND_A_L3A] = op_tc_or_a_and_a_l3a; + fx_function[OP_TC_AND_A_OR_A_A_LA] = op_tc_and_a_or_a_a_la; + fx_function[OP_TC_OR_A_AND_A_A_LA] = op_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_Z_L2A] = fx_tc_if_a_z_l2a; + fx_function[OP_TC_IF_A_Z_L3A] = fx_tc_if_a_z_l3a; + 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_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_L2A_Z] = fx_tc_if_a_z_if_a_l2a_z; + fx_function[OP_TC_IF_A_Z_IF_A_Z_L2A] = fx_tc_if_a_z_if_a_z_l2a; + fx_function[OP_TC_IF_A_Z_IF_A_L3A_L3A] = fx_tc_if_a_z_if_a_l3a_l3a; + fx_function[OP_TC_IF_A_Z_IF_A_Z_L3A] = fx_tc_if_a_z_if_a_z_l3a; + fx_function[OP_TC_IF_A_Z_IF_A_L3A_Z] = fx_tc_if_a_z_if_a_l3a_z; + fx_function[OP_TC_CASE_LA] = fx_tc_case_la; + fx_function[OP_TC_CASE_L2A] = fx_tc_case_l2a; + fx_function[OP_TC_CASE_L3A] = fx_tc_case_l3a; + fx_function[OP_TC_OR_A_AND_A_A_L3A] = op_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_L2A] = fx_tc_let_if_a_z_l2a; + fx_function[OP_TC_LET_WHEN_L2A] = op_tc_let_when_l2a; + fx_function[OP_TC_LET_COND] = fx_tc_let_cond; + fx_function[OP_TC_COND_N] = fx_tc_cond_n; fx_function[OP_TC_COND_A_Z_A_L2A_L2A] = fx_tc_cond_a_z_a_l2a_l2a; - fx_function[OP_TC_WHEN_LA] = op_tc_when_la; - fx_function[OP_TC_WHEN_L2A] = op_tc_when_l2a; - fx_function[OP_TC_WHEN_L3A] = op_tc_when_l3a; - - fx_function[OP_RECUR_IF_A_A_opLA_LAq] = op_recur_if_a_a_opla_laq; - fx_function[OP_RECUR_IF_A_A_opL2A_L2Aq] = op_recur_if_a_a_opl2a_l2aq; - fx_function[OP_RECUR_IF_A_A_opL3A_L3Aq] = op_recur_if_a_a_opl3a_l3aq; - fx_function[OP_RECUR_IF_A_A_opA_LAq] = op_recur_if_a_a_opa_laq; - fx_function[OP_RECUR_IF_A_A_opA_L2Aq] = op_recur_if_a_a_opa_l2aq; - fx_function[OP_RECUR_IF_A_A_opA_L3Aq] = op_recur_if_a_a_opa_l3aq; - fx_function[OP_RECUR_IF_A_A_AND_A_L2A_L2A] = op_recur_if_a_a_and_a_l2a_l2a; - fx_function[OP_RECUR_IF_A_A_IF_A_A_opLA_LAq]= op_recur_if_a_a_if_a_a_opla_laq; - fx_function[OP_RECUR_IF_A_A_IF_A_A_opL2A_L2Aq]= - op_recur_if_a_a_if_a_a_opl2a_l2aq; - fx_function[OP_RECUR_IF_A_A_IF_A_A_opL3A_L3Aq]= - op_recur_if_a_a_if_a_a_opl3a_l3aq; - fx_function[OP_RECUR_AND_A_OR_A_L2A_L2A] = op_recur_and_a_or_a_l2a_l2a; - fx_function[OP_RECUR_IF_A_A_opLA_LA_LAq] = op_recur_if_a_a_opla_la_laq; - fx_function[OP_RECUR_IF_A_A_AND_A_L2A_L2A]= op_recur_if_a_a_and_a_l2a_l2a; - fx_function[OP_RECUR_IF_A_A_opA_LA_LAq] = op_recur_if_a_a_opa_la_laq; - fx_function[OP_RECUR_IF_A_A_IF_A_L2A_opA_L2Aq]= - op_recur_if_a_a_if_a_l2a_opa_l2aq; - fx_function[OP_RECUR_COND_A_A_A_A_opA_L2Aq]= op_recur_cond_a_a_a_a_opa_l2aq; - fx_function[OP_RECUR_COND_A_A_A_L2A_LopA_L2Aq]= - op_recur_cond_a_a_a_l2a_lopa_l2aq; -} - -static void -init_opt_functions (s7_scheme* sc) { + fx_function[OP_TC_WHEN_LA] = op_tc_when_la; + fx_function[OP_TC_WHEN_L2A] = op_tc_when_l2a; + fx_function[OP_TC_WHEN_L3A] = op_tc_when_l3a; + + fx_function[OP_RECUR_IF_A_A_opLA_LAq] = op_recur_if_a_a_opla_laq; + fx_function[OP_RECUR_IF_A_A_opL2A_L2Aq] = op_recur_if_a_a_opl2a_l2aq; + fx_function[OP_RECUR_IF_A_A_opL3A_L3Aq] = op_recur_if_a_a_opl3a_l3aq; + fx_function[OP_RECUR_IF_A_A_opA_LAq] = op_recur_if_a_a_opa_laq; + fx_function[OP_RECUR_IF_A_A_opA_L2Aq] = op_recur_if_a_a_opa_l2aq; + fx_function[OP_RECUR_IF_A_A_opA_L3Aq] = op_recur_if_a_a_opa_l3aq; + fx_function[OP_RECUR_IF_A_A_AND_A_L2A_L2A] = op_recur_if_a_a_and_a_l2a_l2a; + fx_function[OP_RECUR_IF_A_A_IF_A_A_opLA_LAq] = op_recur_if_a_a_if_a_a_opla_laq; + fx_function[OP_RECUR_IF_A_A_IF_A_A_opL2A_L2Aq] = op_recur_if_a_a_if_a_a_opl2a_l2aq; + fx_function[OP_RECUR_IF_A_A_IF_A_A_opL3A_L3Aq] = op_recur_if_a_a_if_a_a_opl3a_l3aq; + fx_function[OP_RECUR_AND_A_OR_A_L2A_L2A] = op_recur_and_a_or_a_l2a_l2a; + fx_function[OP_RECUR_IF_A_A_opLA_LA_LAq] = op_recur_if_a_a_opla_la_laq; + fx_function[OP_RECUR_IF_A_A_AND_A_L2A_L2A] = op_recur_if_a_a_and_a_l2a_l2a; + fx_function[OP_RECUR_IF_A_A_opA_LA_LAq] = op_recur_if_a_a_opa_la_laq; + fx_function[OP_RECUR_IF_A_A_IF_A_L2A_opA_L2Aq] = op_recur_if_a_a_if_a_l2a_opa_l2aq; + fx_function[OP_RECUR_COND_A_A_A_A_opA_L2Aq] = op_recur_cond_a_a_a_a_opa_l2aq; + fx_function[OP_RECUR_COND_A_A_A_L2A_LopA_L2Aq] = op_recur_cond_a_a_a_l2a_lopa_l2aq; +} + +static void init_opt_functions(s7_scheme *sc) +{ #if !WITH_PURE_S7 - 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), exact_b_7p); - s7_set_b_7p_function (sc, global_value (sc->is_inexact_symbol), inexact_b_7p); - s7_set_p_p_function (sc, global_value (sc->exact_to_inexact_symbol), - exact_to_inexact_p_p); - s7_set_p_p_function (sc, global_value (sc->inexact_to_exact_symbol), - inexact_to_exact_p_p); + 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), exact_b_7p); + s7_set_b_7p_function(sc, global_value(sc->is_inexact_symbol), inexact_b_7p); + s7_set_p_p_function(sc, global_value(sc->exact_to_inexact_symbol), exact_to_inexact_p_p); + s7_set_p_p_function(sc, global_value(sc->inexact_to_exact_symbol), inexact_to_exact_p_p); #endif - s7_set_p_pp_function (sc, global_value (sc->complex_vector_ref_symbol), - complex_vector_ref_p_pp); - s7_set_p_pi_function (sc, global_value (sc->complex_vector_ref_symbol), - complex_vector_ref_p_pi); - s7_set_p_pip_function (sc, global_value (sc->complex_vector_set_symbol), - complex_vector_set_p_pip); - s7_set_p_ppp_function (sc, global_value (sc->complex_vector_set_symbol), - complex_vector_set_p_ppp); - - 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_p_pip_function (sc, global_value (sc->float_vector_set_symbol), - float_vector_set_p_pip); - s7_set_p_ppp_function (sc, global_value (sc->float_vector_set_symbol), - float_vector_set_p_ppp); - 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_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_p_pip_function (sc, global_value (sc->int_vector_set_symbol), - int_vector_set_p_pip); - s7_set_p_ppp_function (sc, global_value (sc->int_vector_set_symbol), - int_vector_set_p_ppp); - 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), - s7i_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); - - /* experiment, don't add byte-vector -- collides here with int-vector, this - * works only for these cases */ - s7_set_i_7piii_function (sc, global_value (sc->vector_ref_symbol), - int_vector_ref_i_7piii); - s7_set_i_7piii_function (sc, global_value (sc->vector_set_symbol), - int_vector_set_i_7piii); - s7_set_d_7piid_function (sc, global_value (sc->vector_set_symbol), - float_vector_set_d_7piid); - - s7_set_p_pp_function (sc, global_value (sc->list_ref_symbol), list_ref_p_pp); - 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), let_ref); - s7_set_p_ppp_function ( - sc, global_value (sc->let_set_symbol), - let_set_2); /* originally named "let_set" but that was unsearchable */ - 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_pp_function (sc, global_value (sc->complex_symbol), complex_p_pp); - - 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->cddadr_symbol), cddadr_p_p); - s7_set_p_p_function (sc, global_value (sc->cdddar_symbol), cdddar_p_p); - s7_set_p_p_function (sc, global_value (sc->cddddr_symbol), cddddr_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_i_i_function (sc, global_value (sc->magnitude_symbol), magnitude_i_i); - s7_set_d_d_function (sc, global_value (sc->magnitude_symbol), magnitude_d_d); - s7_set_p_p_function (sc, global_value (sc->magnitude_symbol), magnitude_p_p); - - s7_set_d_d_function (sc, global_value (sc->angle_symbol), angle_d_d); - 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_d_function (sc, global_value (sc->asin_symbol), asin_p_d); - s7_set_p_p_function (sc, global_value (sc->asin_symbol), asin_p_p); - s7_set_p_d_function (sc, global_value (sc->acos_symbol), acos_p_d); - s7_set_p_p_function (sc, global_value (sc->acos_symbol), acos_p_p); - s7_set_p_p_function (sc, global_value (sc->sinh_symbol), sinh_p_p); - s7_set_p_p_function (sc, global_value (sc->cosh_symbol), cosh_p_p); - s7_set_p_p_function (sc, global_value (sc->asinh_symbol), asinh_p_p); - s7_set_p_p_function (sc, global_value (sc->acosh_symbol), acosh_p_p); - s7_set_p_p_function (sc, global_value (sc->atanh_symbol), atanh_p_p); - s7_set_p_p_function (sc, global_value (sc->tanh_symbol), tanh_p_p); - 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->asin_symbol), asin_d_d); - s7_set_d_d_function (sc, global_value (sc->acos_symbol), acos_d_d); - s7_set_d_d_function (sc, global_value (sc->sinh_symbol), sinh_d_d); - s7_set_p_d_function (sc, global_value (sc->sinh_symbol), sinh_p_d); - s7_set_d_d_function (sc, global_value (sc->cosh_symbol), cosh_d_d); - s7_set_p_d_function (sc, global_value (sc->cosh_symbol), cosh_p_d); - s7_set_d_d_function (sc, global_value (sc->exp_symbol), exp_d_d); - s7_set_p_d_function (sc, global_value (sc->exp_symbol), exp_p_d); - - 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_p_pp_function (sc, global_value (sc->expt_symbol), expt_p_pp); - /* same problem affects - * logior|logand|logxor|lcm|gcd|rationalize|remainder|modulo -- *_p_* will - * fail in gmp s7 */ - s7_set_p_d_function (sc, global_value (sc->ceiling_symbol), ceiling_p_d); - s7_set_p_d_function (sc, global_value (sc->floor_symbol), floor_p_d); - s7_set_p_d_function (sc, global_value (sc->truncate_symbol), truncate_p_d); - s7_set_p_d_function (sc, global_value (sc->round_symbol), round_p_d); - 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_ii_function (sc, global_value (sc->add_symbol), add_p_ii); - 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_pi_function (sc, global_value (sc->modulo_symbol), modulo_p_pi); - s7_set_p_pp_function (sc, global_value (sc->remainder_symbol), - remainder_p_pp); - s7_set_p_pi_function (sc, global_value (sc->remainder_symbol), - remainder_p_pi); - s7_set_p_pp_function (sc, global_value (sc->quotient_symbol), quotient_p_pp); - s7_set_p_pi_function (sc, global_value (sc->quotient_symbol), quotient_p_pi); - 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->is_even_symbol), even_p_p); - s7_set_p_p_function (sc, global_value (sc->is_odd_symbol), odd_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_p_i_function (sc, global_value (sc->float_vector_symbol), - float_vector_p_i); - s7_set_i_i_function (sc, global_value (sc->round_symbol), round_i_i); - s7_set_p_i_function (sc, global_value (sc->round_symbol), round_p_i); - s7_set_i_i_function (sc, global_value (sc->floor_symbol), floor_i_i); - s7_set_p_i_function (sc, global_value (sc->floor_symbol), floor_p_i); - s7_set_i_i_function (sc, global_value (sc->ceiling_symbol), ceiling_i_i); - s7_set_p_i_function (sc, global_value (sc->ceiling_symbol), ceiling_p_i); - s7_set_i_i_function (sc, global_value (sc->truncate_symbol), truncate_i_i); - s7_set_p_i_function (sc, global_value (sc->truncate_symbol), truncate_p_i); - - s7_set_d_d_function (sc, global_value (sc->tan_symbol), tan_d_d); - s7_set_d_d_function (sc, global_value (sc->atan_symbol), atan_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); - s7_set_i_7ii_function (sc, global_value (sc->ash_symbol), ash_i_7ii); - 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); - - 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_id_function (sc, global_value (sc->add_symbol), add_d_id); - s7_set_d_dd_function (sc, global_value (sc->subtract_symbol), subtract_d_dd); - s7_set_d_id_function (sc, global_value (sc->subtract_symbol), subtract_d_id); - s7_set_d_dd_function (sc, global_value (sc->multiply_symbol), multiply_d_dd); - s7_set_d_id_function (sc, global_value (sc->multiply_symbol), multiply_d_id); - 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_size_symbol), - hash_table_size_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_symbol), is_byte); - 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), even_b_7p); - s7_set_b_7p_function (sc, global_value (sc->is_odd_symbol), 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), - s7_is_infinite); - 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_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), zero_b_7p); - s7_set_b_7p_function (sc, global_value (sc->is_negative_symbol), - negative_b_7p); - s7_set_b_7p_function (sc, global_value (sc->is_positive_symbol), - 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), - tree_memq_b_7pp); - 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->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->reverse_symbol), reverse_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); - s7_set_p_p_function (sc, global_value (sc->make_iterator_symbol), - s7_make_iterator); - - s7_set_b_i_function (sc, global_value (sc->is_even_symbol), even_i); - s7_set_b_i_function (sc, global_value (sc->is_odd_symbol), odd_i); - s7_set_b_i_function (sc, global_value (sc->is_zero_symbol), zero_i); - s7_set_b_d_function (sc, global_value (sc->is_zero_symbol), zero_d); - s7_set_p_p_function (sc, global_value (sc->is_zero_symbol), zero_p_p); - s7_set_p_p_function (sc, global_value (sc->is_positive_symbol), positive_p_p); - s7_set_p_p_function (sc, global_value (sc->is_negative_symbol), 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_d_7p_function (sc, global_value (sc->real_part_symbol), - real_part_d_7p); - s7_set_d_7p_function (sc, global_value (sc->imag_part_symbol), - imag_part_d_7p); /* also angle, magnitude, but angle - might return int etc */ - s7_set_b_i_function (sc, global_value (sc->is_positive_symbol), positive_i); - s7_set_b_d_function (sc, global_value (sc->is_positive_symbol), positive_d); - s7_set_b_i_function (sc, global_value (sc->is_negative_symbol), negative_i); - s7_set_b_d_function (sc, global_value (sc->is_negative_symbol), 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); + s7_set_p_pp_function(sc, global_value(sc->complex_vector_ref_symbol), complex_vector_ref_p_pp); + s7_set_p_pi_function(sc, global_value(sc->complex_vector_ref_symbol), complex_vector_ref_p_pi); + s7_set_p_pip_function(sc, global_value(sc->complex_vector_set_symbol), complex_vector_set_p_pip); + s7_set_p_ppp_function(sc, global_value(sc->complex_vector_set_symbol), complex_vector_set_p_ppp); + + 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_p_pip_function(sc, global_value(sc->float_vector_set_symbol), float_vector_set_p_pip); + s7_set_p_ppp_function(sc, global_value(sc->float_vector_set_symbol), float_vector_set_p_ppp); + 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_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_p_pip_function(sc, global_value(sc->int_vector_set_symbol), int_vector_set_p_pip); + s7_set_p_ppp_function(sc, global_value(sc->int_vector_set_symbol), int_vector_set_p_ppp); + 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), s7i_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); + + /* experiment, don't add byte-vector -- collides here with int-vector, this works only for these cases */ + s7_set_i_7piii_function(sc, global_value(sc->vector_ref_symbol), int_vector_ref_i_7piii); + s7_set_i_7piii_function(sc, global_value(sc->vector_set_symbol), int_vector_set_i_7piii); + s7_set_d_7piid_function(sc, global_value(sc->vector_set_symbol), float_vector_set_d_7piid); + + s7_set_p_pp_function(sc, global_value(sc->list_ref_symbol), list_ref_p_pp); + 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), let_ref); + s7_set_p_ppp_function(sc, global_value(sc->let_set_symbol), let_set_2); /* originally named "let_set" but that was unsearchable */ + 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_pp_function(sc, global_value(sc->complex_symbol), complex_p_pp); + + 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->cddadr_symbol), cddadr_p_p); + s7_set_p_p_function(sc, global_value(sc->cdddar_symbol), cdddar_p_p); + s7_set_p_p_function(sc, global_value(sc->cddddr_symbol), cddddr_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_i_i_function(sc, global_value(sc->magnitude_symbol), magnitude_i_i); + s7_set_d_d_function(sc, global_value(sc->magnitude_symbol), magnitude_d_d); + s7_set_p_p_function(sc, global_value(sc->magnitude_symbol), magnitude_p_p); + + s7_set_d_d_function(sc, global_value(sc->angle_symbol), angle_d_d); + 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_d_function(sc, global_value(sc->asin_symbol), asin_p_d); + s7_set_p_p_function(sc, global_value(sc->asin_symbol), asin_p_p); + s7_set_p_d_function(sc, global_value(sc->acos_symbol), acos_p_d); + s7_set_p_p_function(sc, global_value(sc->acos_symbol), acos_p_p); + s7_set_p_p_function(sc, global_value(sc->sinh_symbol), sinh_p_p); + s7_set_p_p_function(sc, global_value(sc->cosh_symbol), cosh_p_p); + s7_set_p_p_function(sc, global_value(sc->asinh_symbol), asinh_p_p); + s7_set_p_p_function(sc, global_value(sc->acosh_symbol), acosh_p_p); + s7_set_p_p_function(sc, global_value(sc->atanh_symbol), atanh_p_p); + s7_set_p_p_function(sc, global_value(sc->tanh_symbol), tanh_p_p); + 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->asin_symbol), asin_d_d); + s7_set_d_d_function(sc, global_value(sc->acos_symbol), acos_d_d); + s7_set_d_d_function(sc, global_value(sc->sinh_symbol), sinh_d_d); + s7_set_p_d_function(sc, global_value(sc->sinh_symbol), sinh_p_d); + s7_set_d_d_function(sc, global_value(sc->cosh_symbol), cosh_d_d); + s7_set_p_d_function(sc, global_value(sc->cosh_symbol), cosh_p_d); + s7_set_d_d_function(sc, global_value(sc->exp_symbol), exp_d_d); + s7_set_p_d_function(sc, global_value(sc->exp_symbol), exp_p_d); + + 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_p_pp_function(sc, global_value(sc->expt_symbol), expt_p_pp); + /* same problem affects logior|logand|logxor|lcm|gcd|rationalize|remainder|modulo -- *_p_* will fail in gmp s7 */ + s7_set_p_d_function(sc, global_value(sc->ceiling_symbol), ceiling_p_d); + s7_set_p_d_function(sc, global_value(sc->floor_symbol), floor_p_d); + s7_set_p_d_function(sc, global_value(sc->truncate_symbol), truncate_p_d); + s7_set_p_d_function(sc, global_value(sc->round_symbol), round_p_d); + 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_ii_function(sc, global_value(sc->add_symbol), add_p_ii); + 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_pi_function(sc, global_value(sc->modulo_symbol), modulo_p_pi); + s7_set_p_pp_function(sc, global_value(sc->remainder_symbol), remainder_p_pp); + s7_set_p_pi_function(sc, global_value(sc->remainder_symbol), remainder_p_pi); + s7_set_p_pp_function(sc, global_value(sc->quotient_symbol), quotient_p_pp); + s7_set_p_pi_function(sc, global_value(sc->quotient_symbol), quotient_p_pi); + 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->is_even_symbol), even_p_p); + s7_set_p_p_function(sc, global_value(sc->is_odd_symbol), odd_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_p_i_function(sc, global_value(sc->float_vector_symbol), float_vector_p_i); + s7_set_i_i_function(sc, global_value(sc->round_symbol), round_i_i); + s7_set_p_i_function(sc, global_value(sc->round_symbol), round_p_i); + s7_set_i_i_function(sc, global_value(sc->floor_symbol), floor_i_i); + s7_set_p_i_function(sc, global_value(sc->floor_symbol), floor_p_i); + s7_set_i_i_function(sc, global_value(sc->ceiling_symbol), ceiling_i_i); + s7_set_p_i_function(sc, global_value(sc->ceiling_symbol), ceiling_p_i); + s7_set_i_i_function(sc, global_value(sc->truncate_symbol), truncate_i_i); + s7_set_p_i_function(sc, global_value(sc->truncate_symbol), truncate_p_i); + + s7_set_d_d_function(sc, global_value(sc->tan_symbol), tan_d_d); + s7_set_d_d_function(sc, global_value(sc->atan_symbol), atan_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); + s7_set_i_7ii_function(sc, global_value(sc->ash_symbol), ash_i_7ii); + 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); + + 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_id_function(sc, global_value(sc->add_symbol), add_d_id); + s7_set_d_dd_function(sc, global_value(sc->subtract_symbol), subtract_d_dd); + s7_set_d_id_function(sc, global_value(sc->subtract_symbol), subtract_d_id); + s7_set_d_dd_function(sc, global_value(sc->multiply_symbol), multiply_d_dd); + s7_set_d_id_function(sc, global_value(sc->multiply_symbol), multiply_d_id); + 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_size_symbol), hash_table_size_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_symbol), is_byte); + 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), even_b_7p); + s7_set_b_7p_function(sc, global_value(sc->is_odd_symbol), 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), s7_is_infinite); + 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_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), zero_b_7p); + s7_set_b_7p_function(sc, global_value(sc->is_negative_symbol), negative_b_7p); + s7_set_b_7p_function(sc, global_value(sc->is_positive_symbol), 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), tree_memq_b_7pp); + 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->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->reverse_symbol), reverse_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); + s7_set_p_p_function(sc, global_value(sc->make_iterator_symbol), s7_make_iterator); + + + s7_set_b_i_function(sc, global_value(sc->is_even_symbol), even_i); + s7_set_b_i_function(sc, global_value(sc->is_odd_symbol), odd_i); + s7_set_b_i_function(sc, global_value(sc->is_zero_symbol), zero_i); + s7_set_b_d_function(sc, global_value(sc->is_zero_symbol), zero_d); + s7_set_p_p_function(sc, global_value(sc->is_zero_symbol), zero_p_p); + s7_set_p_p_function(sc, global_value(sc->is_positive_symbol), positive_p_p); + s7_set_p_p_function(sc, global_value(sc->is_negative_symbol), 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_d_7p_function(sc, global_value(sc->real_part_symbol), real_part_d_7p); + s7_set_d_7p_function(sc, global_value(sc->imag_part_symbol), imag_part_d_7p); /* also angle, magnitude, but angle might return int etc */ + s7_set_b_i_function(sc, global_value(sc->is_positive_symbol), positive_i); + s7_set_b_d_function(sc, global_value(sc->is_positive_symbol), positive_d); + s7_set_b_i_function(sc, global_value(sc->is_negative_symbol), negative_i); + s7_set_b_d_function(sc, global_value(sc->is_negative_symbol), 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), add_p_pi); - 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), multiply_p_pi); - - 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_p_pp_function (sc, global_value (sc->make_float_vector_symbol), - make_float_vector_p_pp); - s7_set_p_pp_function (sc, global_value (sc->setter_symbol), setter_p_pp); - s7_set_p_pp_function (sc, global_value (sc->string_eq_symbol), - string_eq_p_pp); - s7_set_p_pp_function (sc, global_value (sc->string_lt_symbol), - string_lt_p_pp); - s7_set_p_pp_function (sc, global_value (sc->string_gt_symbol), - string_gt_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, "ratios"); /* changed from ratio 22-Aug-23; r7rs uses the plural */ + 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), add_p_pi); + 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), multiply_p_pi); + + 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_p_pp_function(sc, global_value(sc->make_float_vector_symbol), make_float_vector_p_pp); + s7_set_p_pp_function(sc, global_value(sc->setter_symbol), setter_p_pp); + s7_set_p_pp_function(sc, global_value(sc->string_eq_symbol), string_eq_p_pp); + s7_set_p_pp_function(sc, global_value(sc->string_lt_symbol), string_lt_p_pp); + s7_set_p_pp_function(sc, global_value(sc->string_gt_symbol), string_gt_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, "ratios"); /* changed from ratio 22-Aug-23; r7rs uses the plural */ #if HAVE_COMPLEX_NUMBERS - s7_provide (sc, "complex-numbers"); + s7_provide(sc, "complex-numbers"); #endif - s7_provide (sc, "ieee-float"); /* why would anyone care? -- this is for r7rs - -- why singular this time? */ + s7_provide(sc, "ieee-float"); /* why would anyone care? -- this is for r7rs -- why singular this time? */ #if WITH_PURE_S7 - s7_provide (sc, "pure-s7"); + s7_provide(sc, "pure-s7"); #endif #if WITH_R7RS - s7_provide (sc, "r7rs"); + s7_provide(sc, "r7rs"); #endif #if WITH_EXTRA_EXPONENT_MARKERS - s7_provide (sc, "dfls-exponents"); + s7_provide(sc, "dfls-exponents"); #endif #if HAVE_OVERFLOW_CHECKS - s7_provide (sc, "overflow-checks"); + s7_provide(sc, "overflow-checks"); #endif #if WITH_SYSTEM_EXTRAS - s7_provide (sc, "system-extras"); + s7_provide(sc, "system-extras"); #endif #if WITH_IMMUTABLE_UNQUOTE - s7_provide (sc, "immutable-unquote"); + s7_provide(sc, "immutable-unquote"); #endif #if S7_DEBUGGING - s7_provide (sc, "debugging"); + s7_provide(sc, "debugging"); #endif #if WITH_NUMBER_SEPARATOR - s7_provide (sc, "number-separator"); + s7_provide(sc, "number-separator"); #endif #if WITH_HISTORY - s7_provide (sc, "history"); + s7_provide(sc, "history"); #endif #if WITH_C_LOADER - s7_provide (sc, "dlopen"); + s7_provide(sc, "dlopen"); #endif #if !DISABLE_AUTOLOAD - s7_provide (sc, "autoload"); + s7_provide(sc, "autoload"); #endif #if !DISABLE_DEPRECATED - s7_provide (sc, "deprecated"); + s7_provide(sc, "deprecated"); #endif #if S7_ALIGNED - s7_provide (sc, "aligned"); + s7_provide(sc, "aligned"); #endif #if POINTER_32 - s7_provide (sc, "32-bit"); + s7_provide(sc, "32-bit"); #endif #if WITH_WARNINGS - s7_provide (sc, "warnings"); + s7_provide(sc, "warnings"); #endif #ifdef __APPLE__ - s7_provide (sc, "osx"); + s7_provide(sc, "osx"); #endif #ifdef __linux__ - s7_provide (sc, "linux"); + s7_provide(sc, "linux"); #endif #ifdef __OpenBSD__ - s7_provide (sc, "openbsd"); + s7_provide(sc, "openbsd"); #endif #ifdef __NetBSD__ - s7_provide (sc, "netbsd"); + s7_provide(sc, "netbsd"); #endif #ifdef __FreeBSD__ - s7_provide (sc, "freebsd"); + s7_provide(sc, "freebsd"); #endif #if MS_WINDOWS - s7_provide (sc, "windows"); + s7_provide(sc, "windows"); #endif #ifdef __bfin__ - s7_provide (sc, "blackfin"); + s7_provide(sc, "blackfin"); #endif #ifdef __ANDROID__ - s7_provide (sc, "android"); + s7_provide(sc, "android"); #endif #ifdef __MSYS__ - s7_provide (sc, "msys2"); /* from chai xiaoxiang */ + s7_provide(sc, "msys2"); /* from chai xiaoxiang */ #endif -#ifdef __MINGW32__ /* this is also defined in mingw64 */ - s7_provide (sc, "mingw"); +#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 */ + s7_provide(sc, "cygwin"); /* this is also defined in msys2 */ #endif #ifdef __hpux - s7_provide (sc, "hpux"); + s7_provide(sc, "hpux"); #endif #if defined(__sun) && defined(__SVR4) - s7_provide (sc, "solaris"); + s7_provide(sc, "solaris"); #endif #ifdef __clang__ /* this defines __GNUC__ */ - s7_provide (sc, "clang"); -#if __cplusplus - s7_provide (sc, "clang++"); /* doesn't work yet */ -#endif + s7_provide(sc, "clang"); + #if __cplusplus + s7_provide(sc, "clang++"); /* doesn't work yet */ + #endif #else -#ifdef __GNUC__ - s7_provide (sc, "gcc"); -#if __cplusplus - s7_provide (sc, "g++"); -#endif -#endif + #ifdef __GNUC__ + s7_provide(sc, "gcc"); + #if __cplusplus + s7_provide(sc, "g++"); + #endif + #endif #endif #ifdef __TINYC__ - s7_provide ( - sc, - "tcc"); /* appears to be 3-4 times slower than gcc (compilation is at - least 10 times faster however) and no complex number support */ + s7_provide(sc, "tcc"); /* appears to be 3-4 times slower than gcc (compilation is at least 10 times faster however) and no complex number support */ #endif #ifdef __EMSCRIPTEN__ - s7_provide (sc, "emscripten"); + s7_provide(sc, "emscripten"); #endif #ifdef _MSC_VER - s7_provide (sc, "msvc"); + s7_provide(sc, "msvc"); #endif } -static void -init_wrappers (s7_scheme* sc) { +static void init_wrappers(s7_scheme *sc) +{ s7_pointer cp, qp; #if S7_DEBUGGING - sc->string_wrapper_allocs = 0; - sc->integer_wrapper_allocs = 0; - sc->real_wrapper_allocs = 0; - sc->complex_wrapper_allocs = 0; - sc->c_pointer_wrapper_allocs= 0; - sc->let_wrapper_allocs = 0; - sc->slot_wrapper_allocs = 0; + sc->string_wrapper_allocs = 0; + sc->integer_wrapper_allocs = 0; + sc->real_wrapper_allocs = 0; + sc->complex_wrapper_allocs = 0; + sc->c_pointer_wrapper_allocs = 0; + sc->let_wrapper_allocs = 0; + sc->slot_wrapper_allocs = 0; #endif - sc->integer_wrappers= semipermanent_list (sc, NUM_INTEGER_WRAPPERS); - for (cp= sc->integer_wrappers, qp= sc->integer_wrappers; is_pair (cp); - qp= cp, cp= cdr (cp)) { - s7_pointer p = alloc_pointer (sc); - full_type (p)= T_INTEGER | T_UNHEAP; + sc->integer_wrappers = semipermanent_list(sc, NUM_INTEGER_WRAPPERS); + for (cp = sc->integer_wrappers, qp = sc->integer_wrappers; is_pair(cp); qp = cp, cp = cdr(cp)) + { + s7_pointer p = alloc_pointer(sc); + full_type(p) = T_INTEGER | T_UNHEAP; #if S7_DEBUGGING - p->carrier_line= __LINE__; + p->carrier_line = __LINE__; #endif - set_integer (p, 0); - set_car (cp, p); - } - set_cdr_unchecked (qp, sc->integer_wrappers); + set_integer(p, 0); + set_car(cp, p); + } + set_cdr_unchecked(qp, sc->integer_wrappers); - sc->real_wrappers= semipermanent_list (sc, NUM_REAL_WRAPPERS); - for (cp= sc->real_wrappers, qp= sc->real_wrappers; is_pair (cp); - qp= cp, cp= cdr (cp)) { - s7_pointer p = alloc_pointer (sc); - full_type (p)= T_REAL | T_UNHEAP; + sc->real_wrappers = semipermanent_list(sc, NUM_REAL_WRAPPERS); + for (cp = sc->real_wrappers, qp = sc->real_wrappers; is_pair(cp); qp = cp, cp = cdr(cp)) + { + s7_pointer p = alloc_pointer(sc); + full_type(p) = T_REAL | T_UNHEAP; #if S7_DEBUGGING - p->carrier_line= __LINE__; + p->carrier_line = __LINE__; #endif - set_real (p, 0.0); - set_car (cp, p); - } - set_cdr_unchecked (qp, sc->real_wrappers); + set_real(p, 0.0); + set_car(cp, p); + } + set_cdr_unchecked(qp, sc->real_wrappers); - sc->complex_wrappers= semipermanent_list (sc, NUM_COMPLEX_WRAPPERS); - for (cp= sc->complex_wrappers, qp= sc->complex_wrappers; is_pair (cp); - qp= cp, cp= cdr (cp)) { - s7_pointer p = alloc_pointer (sc); - full_type (p)= T_COMPLEX | T_UNHEAP; + sc->complex_wrappers = semipermanent_list(sc, NUM_COMPLEX_WRAPPERS); + for (cp = sc->complex_wrappers, qp = sc->complex_wrappers; is_pair(cp); qp = cp, cp = cdr(cp)) + { + s7_pointer p = alloc_pointer(sc); + full_type(p) = T_COMPLEX | T_UNHEAP; #if S7_DEBUGGING - p->carrier_line= __LINE__; + p->carrier_line = __LINE__; #endif - set_real_part (p, 0.0); - set_imag_part (p, 0.0); - set_car (cp, p); - } - set_cdr_unchecked (qp, sc->complex_wrappers); - - sc->string_wrappers= semipermanent_list (sc, NUM_STRING_WRAPPERS); - for (cp= sc->string_wrappers, qp= sc->string_wrappers; is_pair (cp); - qp= cp, cp= cdr (cp)) { - s7_pointer p = alloc_pointer (sc); - full_type (p) = T_STRING | T_SAFE_PROCEDURE | T_UNHEAP; - string_block (p) = NULL; - string_value (p) = NULL; - string_length (p)= 0; - string_hash (p) = 0; - set_car (cp, p); - } - set_cdr_unchecked (qp, sc->string_wrappers); - - sc->c_pointer_wrappers= semipermanent_list (sc, NUM_C_POINTER_WRAPPERS); - for (cp= sc->c_pointer_wrappers, qp= sc->c_pointer_wrappers; is_pair (cp); - qp= cp, cp= cdr (cp)) { - s7_pointer p = alloc_pointer (sc); - full_type (p) = T_C_POINTER | T_UNHEAP; - c_pointer (p) = NULL; - c_pointer_type (p) = sc->F; - c_pointer_info (p) = sc->F; - c_pointer_weak1 (p)= sc->F; - c_pointer_weak2 (p)= sc->F; - set_car (cp, p); - } - set_cdr_unchecked (qp, sc->c_pointer_wrappers); - - sc->let_wrappers= semipermanent_list (sc, NUM_LET_WRAPPERS); - for (cp= sc->let_wrappers, qp= sc->let_wrappers; is_pair (cp); - qp= cp, cp= cdr (cp)) { - s7_pointer p = alloc_pointer (sc); - full_type (p)= T_LET | T_SAFE_PROCEDURE | T_UNHEAP; - let_set_slots (p, slot_end); - let_set_outlet (p, sc->rootlet); - set_car (cp, p); - } - set_cdr_unchecked (qp, sc->let_wrappers); - - sc->slot_wrappers= semipermanent_list (sc, NUM_SLOT_WRAPPERS); - for (cp= sc->slot_wrappers, qp= sc->slot_wrappers; is_pair (cp); - qp= cp, cp= cdr (cp)) { - s7_pointer p = alloc_pointer (sc); - full_type (p)= T_SLOT | T_UNHEAP; - set_car (cp, p); - } - set_cdr_unchecked (qp, sc->slot_wrappers); -} - -static s7_pointer -syntax (s7_scheme* sc, const char* name, opcode_t op, s7_pointer min_args, - s7_pointer max_args, const char* doc) { - const s7_int len = safe_strlen (name); - const s7_uint hash = raw_string_hash ((const uint8_t*) name, len); - const uint32_t loc = hash % SYMBOL_TABLE_SIZE; - const s7_pointer symbol= new_symbol (sc, name, len, hash, loc); - const s7_pointer syn = alloc_pointer (sc); - - set_full_type (syn, T_SYNTAX | T_SYNTACTIC | T_DONT_EVAL_ARGS | T_UNHEAP); - syntax_opcode (syn)= op; - syntax_set_symbol (syn, symbol); - syntax_min_args (syn) = integer (min_args); - syntax_max_args (syn) = integer (max_args); - syntax_documentation (syn)= doc; - set_global_slot (symbol, make_semipermanent_slot (sc, symbol, syn)); - set_initial_value (symbol, syn); /* set_local_slot(x, global_slot(x)); */ - add_to_unlet (sc, symbol); - set_type_bit (symbol, T_SYMBOL | T_SYNTACTIC | T_UNHEAP); - symbol_set_local_slot_unchecked (symbol, 0LL, sc->undefined); - symbol_clear_ctr (symbol); - return (symbol); -} - -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 symbol= syntax (sc, name, op, min_args, max_args, doc); - set_syntax_is_definer (symbol); - return (symbol); -} - -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 symbol= syntax (sc, name, op, min_args, max_args, doc); - set_syntax_is_binder (symbol); - return (symbol); -} - -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 symbol= syntax (sc, name, op, min_args, max_args, doc); - s7_pointer syn = global_value (symbol); - full_type (syn)|= T_COPY_ARGS; - return (symbol); -} - -static s7_pointer -make_unique (s7_scheme* sc, const char* name, s7_uint typ) { - const s7_pointer uniq= alloc_pointer (sc); - set_full_type (uniq, typ | T_IMMUTABLE | T_UNHEAP); - if (typ != T_UNUSED) set_optimize_op (uniq, OP_CONSTANT); - if (typ == T_UNDEFINED) /* sc->undefined here to avoid the - undefined_constant_warning */ - { - undefined_set_name_length (uniq, safe_strlen (name)); - undefined_name (uniq)= - copy_string_with_length (name, undefined_name_length (uniq)); - } - else { - unique_name_length (uniq)= safe_strlen (name); - unique_name (uniq)= - copy_string_with_length (name, unique_name_length (uniq)); - add_saved_pointer (sc, (void*) unique_name (uniq)); - } - return (uniq); + set_real_part(p, 0.0); + set_imag_part(p, 0.0); + set_car(cp, p); + } + set_cdr_unchecked(qp, sc->complex_wrappers); + + sc->string_wrappers = semipermanent_list(sc, NUM_STRING_WRAPPERS); + for (cp = sc->string_wrappers, qp = sc->string_wrappers; is_pair(cp); qp = cp, cp = cdr(cp)) + { + s7_pointer p = alloc_pointer(sc); + full_type(p) = T_STRING | T_SAFE_PROCEDURE | T_UNHEAP; + string_block(p) = NULL; + string_value(p) = NULL; + string_length(p) = 0; + string_hash(p) = 0; + set_car(cp, p); + } + set_cdr_unchecked(qp, sc->string_wrappers); + + sc->c_pointer_wrappers = semipermanent_list(sc, NUM_C_POINTER_WRAPPERS); + for (cp = sc->c_pointer_wrappers, qp = sc->c_pointer_wrappers; is_pair(cp); qp = cp, cp = cdr(cp)) + { + s7_pointer p = alloc_pointer(sc); + full_type(p) = T_C_POINTER | T_UNHEAP; + c_pointer(p) = NULL; + c_pointer_type(p) = sc->F; + c_pointer_info(p) = sc->F; + c_pointer_weak1(p) = sc->F; + c_pointer_weak2(p) = sc->F; + set_car(cp, p); + } + set_cdr_unchecked(qp, sc->c_pointer_wrappers); + + sc->let_wrappers = semipermanent_list(sc, NUM_LET_WRAPPERS); + for (cp = sc->let_wrappers, qp = sc->let_wrappers; is_pair(cp); qp = cp, cp = cdr(cp)) + { + s7_pointer p = alloc_pointer(sc); + full_type(p) = T_LET | T_SAFE_PROCEDURE | T_UNHEAP; + let_set_slots(p, slot_end); + let_set_outlet(p, sc->rootlet); + set_car(cp, p); + } + set_cdr_unchecked(qp, sc->let_wrappers); + + sc->slot_wrappers = semipermanent_list(sc, NUM_SLOT_WRAPPERS); + for (cp = sc->slot_wrappers, qp = sc->slot_wrappers; is_pair(cp); qp = cp, cp = cdr(cp)) + { + s7_pointer p = alloc_pointer(sc); + full_type(p) = T_SLOT | T_UNHEAP; + set_car(cp, p); + } + set_cdr_unchecked(qp, sc->slot_wrappers); +} + +static s7_pointer syntax(s7_scheme *sc, const char *name, opcode_t op, s7_pointer min_args, s7_pointer max_args, const char *doc) +{ + const s7_int len = safe_strlen(name); + const s7_uint hash = raw_string_hash((const uint8_t *)name, len); + const uint32_t loc = hash % SYMBOL_TABLE_SIZE; + const s7_pointer symbol = new_symbol(sc, name, len, hash, loc); + const s7_pointer syn = alloc_pointer(sc); + + set_full_type(syn, T_SYNTAX | T_SYNTACTIC | T_DONT_EVAL_ARGS | T_UNHEAP); + syntax_opcode(syn) = op; + syntax_set_symbol(syn, symbol); + syntax_min_args(syn) = integer(min_args); + syntax_max_args(syn) = integer(max_args); + syntax_documentation(syn) = doc; + set_global_slot(symbol, make_semipermanent_slot(sc, symbol, syn)); + set_initial_value(symbol, syn); /* set_local_slot(x, global_slot(x)); */ + add_to_unlet(sc, symbol); + set_type_bit(symbol, T_SYMBOL | T_SYNTACTIC | T_UNHEAP); + symbol_set_local_slot_unchecked(symbol, 0LL, sc->undefined); + symbol_clear_ctr(symbol); + return(symbol); +} + +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 symbol = syntax(sc, name, op, min_args, max_args, doc); + set_syntax_is_definer(symbol); + return(symbol); +} + +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 symbol = syntax(sc, name, op, min_args, max_args, doc); + set_syntax_is_binder(symbol); + return(symbol); +} + +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 symbol = syntax(sc, name, op, min_args, max_args, doc); + s7_pointer syn = global_value(symbol); + full_type(syn) |= T_COPY_ARGS; + return(symbol); +} + +static s7_pointer make_unique(s7_scheme *sc, const char *name, s7_uint typ) +{ + const s7_pointer uniq = alloc_pointer(sc); + set_full_type(uniq, typ | T_IMMUTABLE | T_UNHEAP); + if (typ != T_UNUSED) set_optimize_op(uniq, OP_CONSTANT); + if (typ == T_UNDEFINED) /* sc->undefined here to avoid the undefined_constant_warning */ + { + undefined_set_name_length(uniq, safe_strlen(name)); + undefined_name(uniq) = copy_string_with_length(name, undefined_name_length(uniq)); + } + else + { + unique_name_length(uniq) = safe_strlen(name); + unique_name(uniq) = copy_string_with_length(name, unique_name_length(uniq)); + add_saved_pointer(sc, (void *)unique_name(uniq)); + } + return(uniq); } -static s7_pointer -symbol_set_1 (s7_scheme* sc, s7_pointer sym, s7_pointer val) { - const s7_pointer slot= s7_slot (sc, sym); - if (!is_slot (slot)) - error_nr ( - sc, sc->wrong_type_arg_symbol, - set_elist_2 (sc, wrap_string (sc, "set!: '~S is unbound", 20), sym)); - if (is_immutable_slot (slot)) - immutable_object_error_nr ( - sc, set_elist_3 (sc, immutable_error_string, sc->symbol_symbol, sym)); - slot_set_value (slot, val); - return (val); +static s7_pointer symbol_set_1(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + const s7_pointer slot = s7_slot(sc, sym); + if (!is_slot(slot)) + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "set!: '~S is unbound", 20), sym)); + if (is_immutable_slot(slot)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->symbol_symbol, sym)); + slot_set_value(slot, val); + return(val); } -static s7_pointer -g_symbol_set (s7_scheme* sc, s7_pointer args) /* (set! (symbol ) ) */ +static s7_pointer g_symbol_set(s7_scheme *sc, s7_pointer args) /* (set! (symbol ) ) */ { - s7_int len; + s7_int len; s7_pointer lst; - if (is_null (cddr (args))) - return (symbol_set_1 (sc, g_symbol (sc, set_plist_1 (sc, car (args))), - cadr (args))); - len= proper_list_length (args) - 1; - lst= safe_list_if_possible (sc, len); - if (in_heap (lst)) gc_protect_via_stack (sc, lst); + if (is_null(cddr(args))) + return(symbol_set_1(sc, g_symbol(sc, set_plist_1(sc, car(args))), cadr(args))); + len = proper_list_length(args) - 1; + lst = safe_list_if_possible(sc, len); + if (in_heap(lst)) gc_protect_via_stack(sc, lst); { - s7_int i= 0; - for (s7_pointer ap= args, lp= lst; i < len; ap= cdr (ap), lp= cdr (lp), i++) - set_car (lp, car (ap)); + s7_int i = 0; + for (s7_pointer ap = args, lp = lst; i < len; ap = cdr(ap), lp = cdr(lp), i++) set_car(lp, car(ap)); } { - s7_pointer val= - symbol_set_1 (sc, g_symbol (sc, lst), s7_list_ref (sc, args, len)); - if (in_heap (lst)) unstack_gc_protect (sc); - else clear_safe_list_in_use (sc, lst); - return (val); + s7_pointer val = symbol_set_1(sc, g_symbol(sc, lst), s7_list_ref(sc, args, len)); + if (in_heap(lst)) unstack_gc_protect(sc); else clear_safe_list_in_use(sc, lst); + return(val); } } -static void -init_setters (s7_scheme* sc) { - sc->vector_set_function= global_value (sc->vector_set_symbol); - set_is_setter (sc->vector_set_symbol); +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->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->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->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); + 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->complex_vector_set_symbol); - set_is_safe_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->complex_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_safe_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_safe_function (sc, "#", - g_set_current_output_port, 1, 0, - false, "*stdout* setter")); + c_function_set_setter(global_value(sc->current_input_port_symbol), + s7_make_safe_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_safe_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); - c_function_set_setter (global_value (sc->current_input_port_symbol), - global_value (sc->set_current_input_port_symbol)); - c_function_set_setter (global_value (sc->current_output_port_symbol), - global_value (sc->set_current_output_port_symbol)); + set_is_setter(sc->set_current_input_port_symbol); + set_is_setter(sc->set_current_output_port_symbol); + c_function_set_setter(global_value(sc->current_input_port_symbol), global_value(sc->set_current_input_port_symbol)); + c_function_set_setter(global_value(sc->current_output_port_symbol), global_value(sc->set_current_output_port_symbol)); #endif - set_is_setter (sc->set_current_error_port_symbol); - c_function_set_setter (global_value (sc->current_error_port_symbol), - global_value (sc->set_current_error_port_symbol)); - /* 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". + set_is_setter(sc->set_current_error_port_symbol); + c_function_set_setter(global_value(sc->current_error_port_symbol), global_value(sc->set_current_error_port_symbol)); + /* 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". */ - c_function_set_setter (global_value (sc->car_symbol), - global_value (sc->set_car_symbol)); - c_function_set_setter (global_value (sc->cdr_symbol), - global_value (sc->set_cdr_symbol)); - c_function_set_setter (global_value (sc->hash_table_ref_symbol), - global_value (sc->hash_table_set_symbol)); - c_function_set_setter (global_value (sc->vector_ref_symbol), - global_value (sc->vector_set_symbol)); - c_function_set_setter (global_value (sc->float_vector_ref_symbol), - global_value (sc->float_vector_set_symbol)); - c_function_set_setter (global_value (sc->complex_vector_ref_symbol), - global_value (sc->complex_vector_set_symbol)); - c_function_set_setter (global_value (sc->int_vector_ref_symbol), - global_value (sc->int_vector_set_symbol)); - c_function_set_setter (global_value (sc->byte_vector_ref_symbol), - global_value (sc->byte_vector_set_symbol)); - c_function_set_setter (global_value (sc->list_ref_symbol), - global_value (sc->list_set_symbol)); - c_function_set_setter (global_value (sc->let_ref_symbol), - global_value (sc->let_set_symbol)); - c_function_set_setter (global_value (sc->string_ref_symbol), - global_value (sc->string_set_symbol)); - c_function_set_setter (global_value (sc->outlet_symbol), - s7_make_safe_function (sc, "#", - g_set_outlet, 2, 0, false, - "outlet setter")); - c_function_set_setter (global_value (sc->port_line_number_symbol), - s7_make_safe_function (sc, "#", - g_set_port_line_number, 1, 1, - false, "port-line setter")); - c_function_set_setter (global_value (sc->port_string_symbol), - s7_make_safe_function (sc, "#", - g_set_port_string, 2, 0, false, - "port-string setter")); - c_function_set_setter (global_value (sc->port_position_symbol), - s7_make_safe_function (sc, "#", - g_set_port_position, 2, 0, - false, "port-position setter")); - c_function_set_setter (global_value (sc->vector_typer_symbol), - s7_make_safe_function (sc, "#", - g_set_vector_typer, 2, 0, false, - "vector-typer setter")); - c_function_set_setter ( - global_value (sc->hash_table_key_typer_symbol), - s7_make_safe_function (sc, "#", - g_set_hash_table_key_typer, 2, 0, false, - "hash-table-key-typer setter")); - c_function_set_setter ( - global_value (sc->hash_table_value_typer_symbol), - s7_make_safe_function (sc, "#", - g_set_hash_table_value_typer, 2, 0, false, - "hash-table-value-typer setter")); - c_function_set_setter (global_value (sc->symbol_symbol), - s7_make_safe_function (sc, "#", - g_symbol_set, 2, 0, true, - "symbol setter")); - c_function_set_setter ( - global_value (sc->symbol_initial_value_symbol), - s7_make_safe_function (sc, "#", - g_symbol_set_initial_value, 2, 0, false, - "symbol-initial-value setter")); - c_function_set_setter ( - global_value (sc->hook_functions_symbol), - s7_make_safe_function (sc, "#", g_hook_set_functions, - 2, 0, false, "hook-functions 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, \ + c_function_set_setter(global_value(sc->car_symbol), global_value(sc->set_car_symbol)); + c_function_set_setter(global_value(sc->cdr_symbol), global_value(sc->set_cdr_symbol)); + c_function_set_setter(global_value(sc->hash_table_ref_symbol), global_value(sc->hash_table_set_symbol)); + c_function_set_setter(global_value(sc->vector_ref_symbol), global_value(sc->vector_set_symbol)); + c_function_set_setter(global_value(sc->float_vector_ref_symbol), global_value(sc->float_vector_set_symbol)); + c_function_set_setter(global_value(sc->complex_vector_ref_symbol), global_value(sc->complex_vector_set_symbol)); + c_function_set_setter(global_value(sc->int_vector_ref_symbol), global_value(sc->int_vector_set_symbol)); + c_function_set_setter(global_value(sc->byte_vector_ref_symbol), global_value(sc->byte_vector_set_symbol)); + c_function_set_setter(global_value(sc->list_ref_symbol), global_value(sc->list_set_symbol)); + c_function_set_setter(global_value(sc->let_ref_symbol), global_value(sc->let_set_symbol)); + c_function_set_setter(global_value(sc->string_ref_symbol), global_value(sc->string_set_symbol)); + c_function_set_setter(global_value(sc->outlet_symbol), + s7_make_safe_function(sc, "#", g_set_outlet, 2, 0, false, "outlet setter")); + c_function_set_setter(global_value(sc->port_line_number_symbol), + s7_make_safe_function(sc, "#", g_set_port_line_number, 1, 1, false, "port-line setter")); + c_function_set_setter(global_value(sc->port_string_symbol), + s7_make_safe_function(sc, "#", g_set_port_string, 2, 0, false, "port-string setter")); + c_function_set_setter(global_value(sc->port_position_symbol), + s7_make_safe_function(sc, "#", g_set_port_position, 2, 0, false, "port-position setter")); + c_function_set_setter(global_value(sc->vector_typer_symbol), + s7_make_safe_function(sc, "#", g_set_vector_typer, 2, 0, false, "vector-typer setter")); + c_function_set_setter(global_value(sc->hash_table_key_typer_symbol), + s7_make_safe_function(sc, "#", g_set_hash_table_key_typer, 2, 0, false, "hash-table-key-typer setter")); + c_function_set_setter(global_value(sc->hash_table_value_typer_symbol), + s7_make_safe_function(sc, "#", g_set_hash_table_value_typer, 2, 0, false, "hash-table-value-typer setter")); + c_function_set_setter(global_value(sc->symbol_symbol), + s7_make_safe_function(sc, "#", g_symbol_set, 2, 0, true, "symbol setter")); + c_function_set_setter(global_value(sc->symbol_initial_value_symbol), + s7_make_safe_function(sc, "#", g_symbol_set_initial_value, 2, 0, false, "symbol-initial-value setter")); + c_function_set_setter(global_value(sc->hook_functions_symbol), + s7_make_safe_function(sc, "#", g_hook_set_functions, 2, 0, false, "hook-functions 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,\ + #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, \ + #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 \ + #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, \ + #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) \ + #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. \ + #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 \ + #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, \ + #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 \ + #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, \ + #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); - copy_initial_value (sc, sc->quote_symbol); - sc->quote_function= initial_value (sc->quote_symbol); - 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); - set_is_setter (sc->set_symbol); /* ? 26-Jan-24 */ - 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_baffle_symbol= - binder_syntax (sc, "with-baffle", OP_WITH_BAFFLE, int_zero, max_arity, - H_with_baffle); /* (with-baffle) is () */ - sc->with_let_symbol= binder_syntax (sc, "with-let", OP_WITH_LET, int_one, - max_arity, H_with_let); - set_local_slot (sc->with_let_symbol, - global_slot (sc->with_let_symbol)); /* for set_locals */ - set_immutable (sc->with_let_symbol); - set_immutable_slot (global_slot (sc->with_let_symbol)); - sc->setter_symbol= make_symbol (sc, "setter", 6); - - set_is_escaper_syntax (sc->lambda_symbol); - set_is_escaper_syntax (sc->lambda_star_symbol); - set_is_escaper_syntax (sc->macro_symbol); - set_is_escaper_syntax (sc->macro_star_symbol); - set_is_escaper_syntax (sc->bacro_symbol); - set_is_escaper_syntax (sc->bacro_star_symbol); - - sc->feed_to_symbol = make_symbol (sc, "=>", 2); - sc->body_symbol = make_symbol (sc, "body", 4); - sc->read_error_symbol = make_symbol (sc, "read-error", 10); - sc->string_read_error_symbol = make_symbol (sc, "string-read-error", 17); - sc->syntax_error_symbol = make_symbol (sc, "syntax-error", 12); - sc->unbound_variable_symbol = make_symbol (sc, "unbound-variable", 16); - sc->wrong_type_arg_symbol = make_symbol (sc, "wrong-type-arg", 14); - sc->wrong_number_of_args_symbol= make_symbol (sc, "wrong-number-of-args", 20); - sc->format_error_symbol = make_symbol (sc, "format-error", 12); - sc->autoload_error_symbol = make_symbol (sc, "autoload-error", 14); - sc->out_of_range_symbol = make_symbol (sc, "out-of-range", 12); - sc->out_of_memory_symbol = make_symbol (sc, "out-of-memory", 13); - sc->io_error_symbol = make_symbol (sc, "io-error", 8); - sc->missing_method_symbol = make_symbol (sc, "missing-method", 14); - sc->number_to_real_symbol = make_symbol (sc, "number_to_real", 14); - sc->invalid_exit_function_symbol= - make_symbol (sc, "invalid-exit-function", 21); - sc->immutable_error_symbol = make_symbol (sc, "immutable-error", 15); - sc->division_by_zero_symbol= make_symbol (sc, "division-by-zero", 16); - sc->bad_result_symbol = make_symbol (sc, "bad-result", 10); - sc->no_setter_symbol = make_symbol (sc, "no-setter", 9); - sc->baffled_symbol = make_symbol (sc, "baffled!", 8); - sc->value_symbol = make_symbol (sc, "value", 5); - sc->type_symbol = make_symbol (sc, "type", 4); - sc->position_symbol = make_symbol (sc, "position", 8); - sc->file_symbol = make_symbol (sc, "file", 4); - sc->line_symbol = make_symbol (sc, "line", 4); - sc->function_symbol = make_symbol (sc, "function", 8); - - sc->else_symbol= make_symbol (sc, "else", 4); - s7_make_slot (sc, sc->rootlet, sc->else_symbol, sc->else_symbol); - set_initial_value (sc->else_symbol, - s7_make_keyword (sc, "else")); /* 3-Oct-23 was #t */ - /* if we set #_else to 'else, it can pick up a local else value: (let ((else - * #f)) (cond (#_else 2)...)) -- #_* is read-time */ - - sc->allow_other_keys_keyword= s7_make_keyword (sc, "allow-other-keys"); - sc->rest_keyword = s7_make_keyword (sc, "rest"); - sc->if_keyword= - s7_make_keyword (sc, "if"); /* internal optimizer local-let marker */ - sc->readable_keyword= s7_make_keyword (sc, "readable"); - sc->display_keyword = s7_make_keyword (sc, "display"); - sc->write_keyword = s7_make_keyword (sc, "write"); -} - -static void -init_rootlet (s7_scheme* sc) { - /* most of init_rootlet (the built-in functions for example), could be shared - * by all s7 instances. currently, each s7_init call allocates room for them, - * then s7_free frees it -- kinda wasteful. + sc->quote_symbol = syntax(sc, "quote", OP_QUOTE, int_one, int_one, H_quote); + copy_initial_value(sc, sc->quote_symbol); + sc->quote_function = initial_value(sc->quote_symbol); + 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); + set_is_setter(sc->set_symbol); /* ? 26-Jan-24 */ + 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_baffle_symbol = binder_syntax(sc, "with-baffle", OP_WITH_BAFFLE, int_zero, max_arity, H_with_baffle); /* (with-baffle) is () */ + sc->with_let_symbol = binder_syntax(sc, "with-let", OP_WITH_LET, int_one, max_arity, H_with_let); + set_local_slot(sc->with_let_symbol, global_slot(sc->with_let_symbol)); /* for set_locals */ + set_immutable(sc->with_let_symbol); + set_immutable_slot(global_slot(sc->with_let_symbol)); + sc->setter_symbol = make_symbol(sc, "setter", 6); + + set_is_escaper_syntax(sc->lambda_symbol); + set_is_escaper_syntax(sc->lambda_star_symbol); + set_is_escaper_syntax(sc->macro_symbol); + set_is_escaper_syntax(sc->macro_star_symbol); + set_is_escaper_syntax(sc->bacro_symbol); + set_is_escaper_syntax(sc->bacro_star_symbol); + + sc->feed_to_symbol = make_symbol(sc, "=>", 2); + sc->body_symbol = make_symbol(sc, "body", 4); + sc->read_error_symbol = make_symbol(sc, "read-error", 10); + sc->string_read_error_symbol = make_symbol(sc, "string-read-error", 17); + sc->syntax_error_symbol = make_symbol(sc, "syntax-error", 12); + sc->unbound_variable_symbol = make_symbol(sc, "unbound-variable", 16); + sc->wrong_type_arg_symbol = make_symbol(sc, "wrong-type-arg", 14); + sc->wrong_number_of_args_symbol = make_symbol(sc, "wrong-number-of-args", 20); + sc->format_error_symbol = make_symbol(sc, "format-error", 12); + sc->autoload_error_symbol = make_symbol(sc, "autoload-error", 14); + sc->out_of_range_symbol = make_symbol(sc, "out-of-range", 12); + sc->out_of_memory_symbol = make_symbol(sc, "out-of-memory", 13); + sc->io_error_symbol = make_symbol(sc, "io-error", 8); + sc->missing_method_symbol = make_symbol(sc, "missing-method", 14); + sc->number_to_real_symbol = make_symbol(sc, "number_to_real", 14); + sc->invalid_exit_function_symbol = make_symbol(sc, "invalid-exit-function", 21); + sc->immutable_error_symbol = make_symbol(sc, "immutable-error", 15); + sc->division_by_zero_symbol = make_symbol(sc, "division-by-zero", 16); + sc->bad_result_symbol = make_symbol(sc, "bad-result", 10); + sc->no_setter_symbol = make_symbol(sc, "no-setter", 9); + sc->baffled_symbol = make_symbol(sc, "baffled!", 8); + sc->value_symbol = make_symbol(sc, "value", 5); + sc->type_symbol = make_symbol(sc, "type", 4); + sc->position_symbol = make_symbol(sc, "position", 8); + sc->file_symbol = make_symbol(sc, "file", 4); + sc->line_symbol = make_symbol(sc, "line", 4); + sc->function_symbol = make_symbol(sc, "function", 8); + + sc->else_symbol = make_symbol(sc, "else", 4); + s7_make_slot(sc, sc->rootlet, sc->else_symbol, sc->else_symbol); + set_initial_value(sc->else_symbol, s7_make_keyword(sc, "else")); /* 3-Oct-23 was #t */ + /* if we set #_else to 'else, it can pick up a local else value: (let ((else #f)) (cond (#_else 2)...)) -- #_* is read-time */ + + sc->allow_other_keys_keyword = s7_make_keyword(sc, "allow-other-keys"); + sc->rest_keyword = s7_make_keyword(sc, "rest"); + sc->if_keyword = s7_make_keyword(sc, "if"); /* internal optimizer local-let marker */ + sc->readable_keyword = s7_make_keyword(sc, "readable"); + sc->display_keyword = s7_make_keyword(sc, "display"); + sc->write_keyword = s7_make_keyword(sc, "write"); +} + +static void init_rootlet(s7_scheme *sc) +{ + /* most of init_rootlet (the built-in functions for example), could be shared by all s7 instances. + * currently, each s7_init call allocates room for them, then s7_free frees it -- kinda wasteful. */ - init_syntax (sc); + init_syntax(sc); - sc->owlet= init_owlet (sc); + sc->owlet = init_owlet(sc); - sc->wrong_type_arg_info= semipermanent_list (sc, 6); - set_car (sc->wrong_type_arg_info, - s7_make_semipermanent_string ( - sc, "~A ~:D argument, ~S, is ~A but should be ~A")); + sc->wrong_type_arg_info = semipermanent_list(sc, 6); + set_car(sc->wrong_type_arg_info, s7_make_semipermanent_string(sc, "~A ~:D argument, ~S, is ~A but should be ~A")); - sc->sole_arg_wrong_type_info= semipermanent_list (sc, 5); - set_car (sc->sole_arg_wrong_type_info, - s7_make_semipermanent_string ( - sc, "~A argument, ~S, is ~A but should be ~A")); + sc->sole_arg_wrong_type_info = semipermanent_list(sc, 5); + set_car(sc->sole_arg_wrong_type_info, s7_make_semipermanent_string(sc, "~A argument, ~S, is ~A but should be ~A")); - sc->out_of_range_info= semipermanent_list (sc, 5); - set_car (sc->out_of_range_info, - s7_make_semipermanent_string ( - sc, "~A ~:D argument, ~S, is out of range (~A)")); + sc->out_of_range_info = semipermanent_list(sc, 5); + set_car(sc->out_of_range_info, s7_make_semipermanent_string(sc, "~A ~:D argument, ~S, is out of range (~A)")); - sc->sole_arg_out_of_range_info= semipermanent_list (sc, 4); - set_car (sc->sole_arg_out_of_range_info, - s7_make_semipermanent_string ( - sc, "~A argument, ~S, is out of range (~A)")); + sc->sole_arg_out_of_range_info = semipermanent_list(sc, 4); + set_car(sc->sole_arg_out_of_range_info, s7_make_semipermanent_string(sc, "~A argument, ~S, is out of range (~A)")); - sc->gc_off= false; + 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 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 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 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 bool_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) + #define bool_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?", 8); - sc->pl_bt= s7_make_signature (sc, 2, sc->is_boolean_symbol, sc->T); - - sc->is_symbol_symbol= - bool_defun ("symbol?", is_symbol, 0, T_SYMBOL, mark_symbol_vector, true); - sc->is_syntax_symbol= - bool_defun ("syntax?", is_syntax, 0, T_SYNTAX, just_mark_vector, true); - sc->is_gensym_symbol= - bool_defun ("gensym?", is_gensym, 0, T_FREE, mark_symbol_vector, true); - sc->is_keyword_symbol= - bool_defun ("keyword?", is_keyword, 0, T_FREE, just_mark_vector, true); - sc->is_let_symbol= - bool_defun ("let?", is_let, 0, T_LET, mark_vector_1, false); - sc->is_openlet_symbol= - bool_defun ("openlet?", is_openlet, 0, T_FREE, mark_vector_1, false); - sc->is_iterator_symbol= bool_defun ("iterator?", is_iterator, 0, T_ITERATOR, - mark_vector_1, false); - sc->is_macro_symbol= - bool_defun ("macro?", is_macro, 0, T_FREE, mark_vector_1, false); - sc->is_c_pointer_symbol = bool_defun ("c-pointer?", is_c_pointer, 1, - T_C_POINTER, mark_vector_1, false); - sc->is_input_port_symbol= bool_defun ("input-port?", is_input_port, 0, - T_INPUT_PORT, mark_vector_1, true); - sc->is_output_port_symbol= - bool_defun ("output-port?", is_output_port, 0, T_OUTPUT_PORT, - mark_simple_vector, true); - sc->is_eof_object_symbol= bool_defun ("eof-object?", is_eof_object, 0, T_EOF, - just_mark_vector, true); - sc->is_integer_symbol = bool_defun ("integer?", is_integer, 0, T_INTEGER, - mark_simple_vector, true); - sc->is_byte_symbol= - bool_defun ("byte?", is_byte, 0, T_FREE, mark_simple_vector, true); - sc->is_number_symbol= - bool_defun ("number?", is_number, 0, T_FREE, mark_simple_vector, true); - sc->is_real_symbol= - bool_defun ("real?", is_real, 0, T_FREE, mark_simple_vector, true); - sc->is_float_symbol= - bool_defun ("float?", is_float, 0, T_FREE, mark_simple_vector, true); - sc->is_complex_symbol= - bool_defun ("complex?", is_complex, 0, T_FREE, mark_simple_vector, true); - sc->is_rational_symbol= bool_defun ("rational?", is_rational, 0, T_FREE, - mark_simple_vector, true); - sc->is_random_state_symbol= - bool_defun ("random-state?", is_random_state, 0, T_RANDOM_STATE, - mark_simple_vector, true); - sc->is_char_symbol= define_bool_function ( - sc, "char?", g_is_char, 0, "(char? obj) returns #t if obj is a character", - sc->pl_bt, T_CHARACTER, just_mark_vector, true, b_is_char_setter); - sc->is_string_symbol= - bool_defun ("string?", is_string, 0, T_STRING, mark_simple_vector, true); - sc->is_list_symbol= - bool_defun ("list?", is_list, 0, T_FREE, mark_vector_1, false); - sc->is_pair_symbol= - bool_defun ("pair?", is_pair, 0, T_PAIR, mark_vector_1, false); -#define H_is_vector "(vector? obj) returns #t if obj is a vector" -#define Q_is_vector sc->pl_bt - sc->is_vector_symbol= - bool_defun ("vector?", is_vector, 0, T_FREE, mark_vector_1, false); -#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 - sc->is_float_vector_symbol= - bool_defun ("float-vector?", is_float_vector, 0, T_FLOAT_VECTOR, - mark_simple_vector, true); -#define H_is_complex_vector \ - "(complex-vector? obj) returns #t if obj is an homogeneous complex vector" -#define Q_is_complex_vector sc->pl_bt - sc->is_complex_vector_symbol= - bool_defun ("complex-vector?", is_complex_vector, 0, T_COMPLEX_VECTOR, - mark_simple_vector, true); -#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 - sc->is_int_vector_symbol= bool_defun ("int-vector?", is_int_vector, 0, - T_INT_VECTOR, mark_simple_vector, true); -#define H_is_byte_vector "(byte-vector? obj) returns #t if obj is a byte-vector" -#define Q_is_byte_vector sc->pl_bt - sc->is_byte_vector_symbol= - bool_defun ("byte-vector?", is_byte_vector, 0, T_BYTE_VECTOR, - mark_simple_vector, true); - -#define H_is_hash_table "(hash-table? obj) returns #t if obj is a hash-table" -#define Q_is_hash_table sc->pl_bt - sc->is_hash_table_symbol = bool_defun ("hash-table?", is_hash_table, 0, - T_HASH_TABLE, mark_vector_1, false); - sc->is_continuation_symbol= bool_defun ("continuation?", is_continuation, 0, - T_CONTINUATION, mark_vector_1, false); - sc->is_procedure_symbol= - bool_defun ("procedure?", is_procedure, 0, T_FREE, mark_vector_1, false); - sc->is_dilambda_symbol= - bool_defun ("dilambda?", is_dilambda, 0, T_FREE, mark_vector_1, false); - /* set above */ bool_defun ("boolean?", is_boolean, 0, T_BOOLEAN, - just_mark_vector, true); - sc->is_proper_list_symbol= bool_defun ("proper-list?", is_proper_list, 0, - T_FREE, mark_vector_1, false); - sc->is_sequence_symbol= - bool_defun ("sequence?", is_sequence, 0, T_FREE, mark_vector_1, false); - sc->is_null_symbol= - bool_defun ("null?", is_null, 0, T_NIL, just_mark_vector, true); - sc->is_undefined_symbol = bool_defun ("undefined?", is_undefined, 0, - T_UNDEFINED, just_mark_vector, true); - sc->is_unspecified_symbol= bool_defun ("unspecified?", is_unspecified, 0, - T_UNSPECIFIED, just_mark_vector, true); - sc->is_c_object_symbol= bool_defun ("c-object?", is_c_object, 0, T_C_OBJECT, - mark_vector_1, false); -#define H_is_subvector "(subvector? obj) returns #t if obj is a subvector" -#define Q_is_subvector sc->pl_bt - sc->is_subvector_symbol= - bool_defun ("subvector?", is_subvector, 0, T_FREE, mark_vector_1, false); - sc->is_weak_hash_table_symbol= bool_defun ( - "weak-hash-table?", is_weak_hash_table, 0, T_FREE, mark_vector_1, false); - sc->is_goto_symbol= - bool_defun ("goto?", is_goto, 0, T_GOTO, mark_vector_1, true); + sc->is_boolean_symbol = make_symbol(sc, "boolean?", 8); + sc->pl_bt = s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->T); + + sc->is_symbol_symbol = bool_defun("symbol?", is_symbol, 0, T_SYMBOL, mark_symbol_vector, true); + sc->is_syntax_symbol = bool_defun("syntax?", is_syntax, 0, T_SYNTAX, just_mark_vector, true); + sc->is_gensym_symbol = bool_defun("gensym?", is_gensym, 0, T_FREE, mark_symbol_vector, true); + sc->is_keyword_symbol = bool_defun("keyword?", is_keyword, 0, T_FREE, just_mark_vector, true); + sc->is_let_symbol = bool_defun("let?", is_let, 0, T_LET, mark_vector_1, false); + sc->is_openlet_symbol = bool_defun("openlet?", is_openlet, 0, T_FREE, mark_vector_1, false); + sc->is_iterator_symbol = bool_defun("iterator?", is_iterator, 0, T_ITERATOR, mark_vector_1, false); + sc->is_macro_symbol = bool_defun("macro?", is_macro, 0, T_FREE, mark_vector_1, false); + sc->is_c_pointer_symbol = bool_defun("c-pointer?", is_c_pointer, 1, T_C_POINTER, mark_vector_1, false); + sc->is_input_port_symbol = bool_defun("input-port?", is_input_port, 0, T_INPUT_PORT, mark_vector_1, true); + sc->is_output_port_symbol = bool_defun("output-port?", is_output_port, 0, T_OUTPUT_PORT, mark_simple_vector, true); + sc->is_eof_object_symbol = bool_defun("eof-object?", is_eof_object, 0, T_EOF, just_mark_vector, true); + sc->is_integer_symbol = bool_defun("integer?", is_integer, 0, T_INTEGER, mark_simple_vector, true); + sc->is_byte_symbol = bool_defun("byte?", is_byte, 0, T_FREE, mark_simple_vector, true); + sc->is_number_symbol = bool_defun("number?", is_number, 0, T_FREE, mark_simple_vector, true); + sc->is_real_symbol = bool_defun("real?", is_real, 0, T_FREE, mark_simple_vector, true); + sc->is_float_symbol = bool_defun("float?", is_float, 0, T_FREE, mark_simple_vector, true); + sc->is_complex_symbol = bool_defun("complex?", is_complex, 0, T_FREE, mark_simple_vector, true); + sc->is_rational_symbol = bool_defun("rational?", is_rational, 0, T_FREE, mark_simple_vector, true); + sc->is_random_state_symbol = bool_defun("random-state?", is_random_state, 0, T_RANDOM_STATE, mark_simple_vector, true); + sc->is_char_symbol = define_bool_function(sc, "char?", g_is_char, 0, + "(char? obj) returns #t if obj is a character", + sc->pl_bt, T_CHARACTER, just_mark_vector, true, b_is_char_setter); + sc->is_string_symbol = bool_defun("string?", is_string, 0, T_STRING, mark_simple_vector, true); + sc->is_list_symbol = bool_defun("list?", is_list, 0, T_FREE, mark_vector_1, false); + sc->is_pair_symbol = bool_defun("pair?", is_pair, 0, T_PAIR, mark_vector_1, false); + #define H_is_vector "(vector? obj) returns #t if obj is a vector" + #define Q_is_vector sc->pl_bt + sc->is_vector_symbol = bool_defun("vector?", is_vector, 0, T_FREE, mark_vector_1, false); + #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 + sc->is_float_vector_symbol = bool_defun("float-vector?", is_float_vector, 0, T_FLOAT_VECTOR, mark_simple_vector, true); + #define H_is_complex_vector "(complex-vector? obj) returns #t if obj is an homogeneous complex vector" + #define Q_is_complex_vector sc->pl_bt + sc->is_complex_vector_symbol = bool_defun("complex-vector?", is_complex_vector, 0, T_COMPLEX_VECTOR, mark_simple_vector, true); + #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 + sc->is_int_vector_symbol = bool_defun("int-vector?", is_int_vector, 0, T_INT_VECTOR, mark_simple_vector, true); + #define H_is_byte_vector "(byte-vector? obj) returns #t if obj is a byte-vector" + #define Q_is_byte_vector sc->pl_bt + sc->is_byte_vector_symbol = bool_defun("byte-vector?", is_byte_vector, 0, T_BYTE_VECTOR, mark_simple_vector, true); + + #define H_is_hash_table "(hash-table? obj) returns #t if obj is a hash-table" + #define Q_is_hash_table sc->pl_bt + sc->is_hash_table_symbol = bool_defun("hash-table?", is_hash_table, 0, T_HASH_TABLE, mark_vector_1, false); + sc->is_continuation_symbol = bool_defun("continuation?", is_continuation, 0, T_CONTINUATION, mark_vector_1, false); + sc->is_procedure_symbol = bool_defun("procedure?", is_procedure, 0, T_FREE, mark_vector_1, false); + sc->is_dilambda_symbol = bool_defun("dilambda?", is_dilambda, 0, T_FREE, mark_vector_1, false); + /* set above */ bool_defun("boolean?", is_boolean, 0, T_BOOLEAN, just_mark_vector, true); + sc->is_proper_list_symbol = bool_defun("proper-list?", is_proper_list, 0, T_FREE, mark_vector_1, false); + sc->is_sequence_symbol = bool_defun("sequence?", is_sequence, 0, T_FREE, mark_vector_1, false); + sc->is_null_symbol = bool_defun("null?", is_null, 0, T_NIL, just_mark_vector, true); + sc->is_undefined_symbol = bool_defun("undefined?", is_undefined, 0, T_UNDEFINED, just_mark_vector, true); + sc->is_unspecified_symbol = bool_defun("unspecified?", is_unspecified, 0, T_UNSPECIFIED, just_mark_vector, true); + sc->is_c_object_symbol = bool_defun("c-object?", is_c_object, 0, T_C_OBJECT, mark_vector_1, false); + #define H_is_subvector "(subvector? obj) returns #t if obj is a subvector" + #define Q_is_subvector sc->pl_bt + sc->is_subvector_symbol = bool_defun("subvector?", is_subvector, 0, T_FREE, mark_vector_1, false); + sc->is_weak_hash_table_symbol = bool_defun("weak-hash-table?", is_weak_hash_table, 0, T_FREE, mark_vector_1, false); + sc->is_goto_symbol = bool_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?", 13); - sc->is_integer_or_number_at_end_symbol= - make_symbol (sc, "integer:number?", 15); - sc->is_integer_or_any_at_end_symbol= make_symbol (sc, "integer:any?", 12); - - 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->values_symbol= make_symbol (sc, "values", 6); - - 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->symbol_initial_value_symbol= - defun ("symbol-initial-value", symbol_initial_value, 1, 0, false); - sc->immutable_symbol= semisafe_defun ("immutable!", immutable, 1, 1, false); - set_func_is_definer (sc->immutable_symbol); - sc->is_immutable_symbol= defun ("immutable?", is_immutable, 1, 1, - false); /* added optional let arg 13-Oct-23 */ - 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); /* keyword->string is symbol->string */ - 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->curlet_symbol= - semisafe_defun ("curlet", curlet, 0, 0, false); /* was unsafe 29-Mar-25 */ - set_func_is_definer (sc->curlet_symbol); - set_is_escaper_function (sc->curlet_symbol); - set_is_saver (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); - set_immutable_slot (global_slot (sc->unlet_symbol)); - - sc->outlet_symbol = defun ("outlet", outlet, 1, 0, false); - sc->rootlet_symbol = defun ("rootlet", rootlet, 0, 0, false); - sc->is_funclet_symbol= defun ("funclet?", is_funclet, 1, 0, false); - sc->sublet_symbol = defun ("sublet", sublet, 1, 0, true); - set_is_saver (sc->sublet_symbol); - sc->varlet_symbol= semisafe_defun ("varlet", varlet, 2, 0, true); - set_func_is_definer (sc->varlet_symbol); - set_is_translucent (sc->varlet_symbol); - sc->cutlet_symbol= semisafe_defun ("cutlet", cutlet, 2, 0, true); - set_func_is_definer (sc->cutlet_symbol); - set_is_translucent (sc->cutlet_symbol); - sc->inlet_symbol= defun ("inlet", inlet, 0, 0, true); - set_is_saver (sc->inlet_symbol); - sc->owlet_symbol = defun ("owlet", owlet, 0, 0, false); - sc->coverlet_symbol= defun ("coverlet", coverlet, 1, 0, false); - set_is_translucent (sc->coverlet_symbol); - sc->openlet_symbol= semisafe_defun ("openlet", openlet, 1, 0, false); - set_is_translucent (sc->openlet_symbol); - - sc->let_ref_symbol= defun ("let-ref", let_ref, 2, 0, false); - set_immutable (sc->let_ref_symbol); - set_immutable_slot (global_slot (sc->let_ref_symbol)); - sc->let_set_symbol= defun ("let-set!", let_set, 3, 0, false); - set_immutable (sc->let_set_symbol); - set_immutable_slot (global_slot (sc->let_set_symbol)); - sc->let_ref_fallback_symbol= make_symbol (sc, "let-ref-fallback", 16); - sc->let_set_fallback_symbol= make_symbol (sc, "let-set-fallback", 16); - - 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_object_let_symbol= - defun ("c-object-let", c_object_let, 1, 0, false); /* added 3-Apr-25 */ - c_function_set_setter (global_value (sc->c_object_let_symbol), - s7_make_safe_function (sc, "#", - g_c_object_set_let, 2, 0, false, - "c-object-let setter")); - - 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_string_symbol = defun ("port-string", port_string, 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); + sc->not_symbol = defun("not", not, 1, 0, false); + sc->is_integer_or_real_at_end_symbol = make_symbol(sc, "integer:real?", 13); + sc->is_integer_or_number_at_end_symbol = make_symbol(sc, "integer:number?", 15); + sc->is_integer_or_any_at_end_symbol = make_symbol(sc, "integer:any?", 12); + + 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->values_symbol = make_symbol(sc, "values", 6); + + 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->symbol_initial_value_symbol = defun("symbol-initial-value", symbol_initial_value, 1, 0, false); + sc->immutable_symbol = semisafe_defun("immutable!",immutable, 1, 1, false); set_func_is_definer(sc->immutable_symbol); + sc->is_immutable_symbol = defun("immutable?", is_immutable, 1, 1, false); /* added optional let arg 13-Oct-23 */ + 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); /* keyword->string is symbol->string */ + 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->curlet_symbol = semisafe_defun("curlet", curlet, 0, 0, false); /* was unsafe 29-Mar-25 */ + set_func_is_definer(sc->curlet_symbol); + set_is_escaper_function(sc->curlet_symbol); + set_is_saver(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); + set_immutable_slot(global_slot(sc->unlet_symbol)); + + sc->outlet_symbol = defun("outlet", outlet, 1, 0, false); + sc->rootlet_symbol = defun("rootlet", rootlet, 0, 0, false); + sc->is_funclet_symbol = defun("funclet?", is_funclet, 1, 0, false); + sc->sublet_symbol = defun("sublet", sublet, 1, 0, true); set_is_saver(sc->sublet_symbol); + sc->varlet_symbol = semisafe_defun("varlet", varlet, 2, 0, true); + set_func_is_definer(sc->varlet_symbol); + set_is_translucent(sc->varlet_symbol); + sc->cutlet_symbol = semisafe_defun("cutlet", cutlet, 2, 0, true); + set_func_is_definer(sc->cutlet_symbol); + set_is_translucent(sc->cutlet_symbol); + sc->inlet_symbol = defun("inlet", inlet, 0, 0, true); set_is_saver(sc->inlet_symbol); + sc->owlet_symbol = defun("owlet", owlet, 0, 0, false); + sc->coverlet_symbol = defun("coverlet", coverlet, 1, 0, false); set_is_translucent(sc->coverlet_symbol); + sc->openlet_symbol = semisafe_defun("openlet", openlet, 1, 0, false); set_is_translucent(sc->openlet_symbol); + + sc->let_ref_symbol = defun("let-ref", let_ref, 2, 0, false); set_immutable(sc->let_ref_symbol); + set_immutable_slot(global_slot(sc->let_ref_symbol)); + sc->let_set_symbol = defun("let-set!", let_set, 3, 0, false); set_immutable(sc->let_set_symbol); + set_immutable_slot(global_slot(sc->let_set_symbol)); + sc->let_ref_fallback_symbol = make_symbol(sc, "let-ref-fallback", 16); + sc->let_set_fallback_symbol = make_symbol(sc, "let-set-fallback", 16); + + 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_object_let_symbol = defun("c-object-let", c_object_let, 1, 0, false); /* added 3-Apr-25 */ + c_function_set_setter(global_value(sc->c_object_let_symbol), s7_make_safe_function(sc, "#", g_c_object_set_let, 2, 0, false, "c-object-let setter")); + + 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_string_symbol = defun("port-string", port_string, 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 */ + 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_safe_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_safe_function ( - sc, "#", g_closed_input_function_port, 2, 0, false, - "input-function error"), - sc->closed_output_function= s7_make_safe_function ( - sc, "#", g_closed_output_function_port, 1, 0, - false, "output-function error"), - - sc->newline_symbol= s7_define_typed_function ( - sc, "newline", g_newline, 0, 1, false, - "(newline (port (current-output-port))) writes a carriage return to the " - "port", - s7_make_signature (sc, 2, sc->is_char_symbol, - s7_make_signature (sc, 2, sc->is_output_port_symbol, - sc->not_symbol))); - sc->write_symbol= s7_define_typed_function ( - sc, "write", g_write, 1, 1, false, - "(write obj (port (current-output-port))) writes (object->string obj) to " - "the output port", - s7_make_signature (sc, 3, sc->T, sc->T, - s7_make_signature (sc, 2, sc->is_output_port_symbol, - sc->not_symbol))); - set_is_translucent (sc->write_symbol); - sc->display_symbol= s7_define_typed_function ( - sc, "display", g_display, 1, 1, false, - "(display obj (port (current-output-port))) prints obj", - s7_make_signature (sc, 3, sc->T, sc->T, - s7_make_signature (sc, 2, sc->is_output_port_symbol, - sc->not_symbol))); - set_is_translucent (sc->display_symbol); - 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= s7_define_typed_function ( - sc, "write-char", g_write_char, 1, 1, false, - "(write-char char (port (current-output-port))) writes char to the " - "output port", - 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))); - sc->write_string_symbol= s7_define_typed_function ( - sc, "write-string", g_write_string, 1, 3, false, - "(write-string str port start end) writes str to port.", - 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)); - sc->read_byte_symbol = defun ("read-byte", read_byte, 0, 1, false); - sc->write_byte_symbol= s7_define_typed_function ( - sc, "write-byte", g_write_byte, 1, 1, false, - "(write-byte byte (port (current-output-port))): writes byte to the " - "output port", - 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))); - 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 (except gc protects), 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->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_safe_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_safe_function(sc, "#", g_closed_input_function_port, 2, 0, false, "input-function error"), + sc->closed_output_function = s7_make_safe_function(sc, "#", g_closed_output_function_port, 1, 0, false, "output-function error"), + + sc->newline_symbol = s7_define_typed_function(sc, "newline", g_newline, 0, 1, false, "(newline (port (current-output-port))) writes a carriage return to the port", s7_make_signature(sc, 2, sc->is_char_symbol, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))); + sc->write_symbol = s7_define_typed_function(sc, "write", g_write, 1, 1, false, "(write obj (port (current-output-port))) writes (object->string obj) to the output port", s7_make_signature(sc, 3, sc->T, sc->T, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))); set_is_translucent(sc->write_symbol); + sc->display_symbol = s7_define_typed_function(sc, "display", g_display, 1, 1, false, "(display obj (port (current-output-port))) prints obj", s7_make_signature(sc, 3, sc->T, sc->T, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))); set_is_translucent(sc->display_symbol); + 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 = s7_define_typed_function(sc, "write-char", g_write_char, 1, 1, false, "(write-char char (port (current-output-port))) writes char to the output port", 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))); + sc->write_string_symbol = s7_define_typed_function(sc, "write-string", g_write_string, 1, 3, false, "(write-string str port start end) writes str to port.", 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)); + sc->read_byte_symbol = defun("read-byte", read_byte, 0, 1, false); + sc->write_byte_symbol = s7_define_typed_function(sc, "write-byte", g_write_byte, 1, 1, false, "(write-byte byte (port (current-output-port))): writes byte to the output port", 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))); + 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 (except gc protects), + * 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. */ - copy_initial_value (sc, sc->read_symbol); - - 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); - - sc->real_part_symbol= s7_define_typed_function ( - sc, "real-part", g_real_part, 1, 0, false, - "(real-part num) returns the real part of num", - s7_make_signature (sc, 2, sc->is_real_symbol, sc->is_number_symbol)); - sc->imag_part_symbol= s7_define_typed_function ( - sc, "imag-part", g_imag_part, 1, 0, false, - "(imag-part num) returns the imaginary part of num", - s7_make_signature (sc, 2, sc->is_real_symbol, sc->is_number_symbol)); - sc->numerator_symbol = defun ("numerator", numerator, 1, 0, false); - sc->denominator_symbol= defun ("denominator", denominator, 1, 0, false); - sc->is_even_symbol = s7_define_typed_function ( - sc, "even?", g_even, 1, 0, false, - "(even? int) returns #t if the integer int32_t is even", - s7_make_signature (sc, 2, sc->is_boolean_symbol, sc->is_integer_symbol)); - sc->is_odd_symbol= s7_define_typed_function ( - sc, "odd?", g_odd, 1, 0, false, - "(odd? int) returns #t if the integer int32_t is odd", - s7_make_signature (sc, 2, sc->is_boolean_symbol, sc->is_integer_symbol)); - sc->is_zero_symbol= s7_define_typed_function ( - sc, "zero?", g_zero, 1, 0, false, - "(zero? num) returns #t if the number num is zero", sc->pl_bn); - sc->is_positive_symbol= s7_define_typed_function ( - sc, "positive?", g_positive, 1, 0, false, - "(positive? num) returns #t if the real number num is positive (greater " - "than 0)", - s7_make_signature (sc, 2, sc->is_boolean_symbol, sc->is_real_symbol)); - sc->is_negative_symbol= s7_define_typed_function ( - sc, "negative?", g_negative, 1, 0, false, - "(negative? num) returns #t if the real number num is negative (less " - "than 0)", - s7_make_signature (sc, 2, sc->is_boolean_symbol, sc->is_real_symbol)); - sc->is_infinite_symbol= - s7_define_typed_function (sc, "infinite?", g_is_infinite, 1, 0, false, - "(infinite? obj) returns #t if obj has an " - "infinite real or imaginary part", - sc->pl_bt); - sc->is_nan_symbol= s7_define_typed_function ( - sc, "nan?", g_is_nan, 1, 0, false, - "(nan? obj) returns #t if obj is a NaN", sc->pl_bt); - sc->complex_symbol= s7_define_typed_function ( - sc, "complex", g_complex, 2, 0, false, - "(complex x1 x2) returns a complex number with real-part x1 and " - "imaginary-part x2", - s7_make_signature (sc, 3, sc->is_number_symbol, sc->is_real_symbol, - sc->is_real_symbol)); - - 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= s7_define_typed_function ( - sc, "s7-min", g_min, 1, 0, true, - "(min ...) returns the minimum of its arguments", sc->pcl_r); - set_all_integer_and_float (sc->min_symbol); - sc->max_symbol= s7_define_typed_function ( - sc, "s7-max", g_max, 1, 0, true, - "(max ...) returns the maximum of its arguments", sc->pcl_r); - 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 ("s7-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 = s7_define_typed_function ( - sc, "gcd", g_gcd, 0, 0, true, - "(gcd ...) returns the greatest common divisor of its rational arguments", - sc->pcl_f); - sc->lcm_symbol= s7_define_typed_function ( - sc, "s7-lcm", g_lcm, 0, 0, true, - "(lcm ...) returns the least common multiple of its rational arguments", - sc->pcl_f); - sc->rationalize_symbol= s7_define_typed_function ( - sc, "rationalize", g_rationalize, 1, 1, false, - "(rationalize x err) returns the ratio with smallest denominator within " - "err of x", - s7_make_signature (sc, 3, sc->is_rational_symbol, sc->is_real_symbol, - sc->is_real_symbol)); - 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, 0, 2, false); - sc->expt_symbol = s7_define_typed_function ( - sc, "expt", g_expt, 2, 0, false, "(expt z1 z2) returns z1^z2", sc->pcl_n); - sc->log_symbol= s7_define_typed_function ( - sc, "log", g_log, 1, 1, false, - "(log z1 (z2 e)) returns log(z1) / log(z2) where z2 (the base) defaults " - "to e: (log 8 2) = 3", - sc->pcl_n); - sc->ash_symbol= s7_define_typed_function ( - sc, "ash", g_ash, 2, 0, false, - "(ash i1 i2) returns i1 shifted right or left i2 times, i1 << i2, (ash 1 " - "3) -> 8, (ash 8 -3) -> 1", - sc->pcl_i); - sc->exp_symbol= s7_define_typed_function ( - sc, "exp", g_exp, 1, 0, false, - "(exp z) returns e^z, (exp 1) is 2.718281828459", sc->pl_nn); - set_all_float (sc->exp_symbol); - sc->abs_symbol= s7_define_typed_function ( - sc, "abs", g_abs, 1, 0, false, - "(abs x) returns the absolute value of the real number x", - s7_make_signature (sc, 2, sc->is_real_symbol, sc->is_real_symbol)); - set_is_translucent (sc->abs_symbol); - sc->magnitude_symbol= s7_define_typed_function ( - sc, "magnitude", g_magnitude, 1, 0, false, - "(magnitude z) returns the magnitude of z", - s7_make_signature (sc, 2, sc->is_real_symbol, sc->is_number_symbol)); - set_all_integer_and_float (sc->magnitude_symbol); - sc->angle_symbol= s7_define_typed_function ( - sc, "angle", g_angle, 1, 0, false, "(angle z) returns the angle of z", - s7_make_signature (sc, 2, sc->is_real_symbol, sc->is_number_symbol)); - sc->sin_symbol= s7_define_typed_function ( - sc, "sin", g_sin, 1, 0, false, "(sin z) returns sin(z)", sc->pl_nn); - set_all_float (sc->sin_symbol); - sc->cos_symbol= s7_define_typed_function ( - sc, "cos", g_cos, 1, 0, false, "(cos z) returns cos(z)", sc->pl_nn); - set_all_float (sc->cos_symbol); - sc->tan_symbol= s7_define_typed_function ( - sc, "tan", g_tan, 1, 0, false, "(tan z) returns tan(z)", sc->pl_nn); - set_all_float (sc->tan_symbol); - sc->sinh_symbol= s7_define_typed_function ( - sc, "sinh", g_sinh, 1, 0, false, "(sinh z) returns sinh(z)", sc->pl_nn); - set_all_float (sc->sinh_symbol); - sc->cosh_symbol= s7_define_typed_function ( - sc, "cosh", g_cosh, 1, 0, false, "(cosh z) returns cosh(z)", sc->pl_nn); - set_all_float (sc->cosh_symbol); - sc->tanh_symbol= s7_define_typed_function ( - sc, "tanh", g_tanh, 1, 0, false, "(tanh z) returns tanh(z)", sc->pl_nn); - set_all_float (sc->tanh_symbol); - sc->asin_symbol= s7_define_typed_function ( - sc, "asin", g_asin, 1, 0, false, - "(asin z) returns asin(z); (sin (asin x)) = x", sc->pl_nn); - sc->acos_symbol= s7_define_typed_function ( - sc, "acos", g_acos, 1, 0, false, - "(acos z) returns acos(z); (cos (acos 1)) = 1", sc->pl_nn); - sc->atan_symbol= s7_define_typed_function ( - sc, "atan", g_atan, 1, 1, false, - "(atan z) returns atan(z), (atan y x) returns atan(y/x)", - s7_make_signature (sc, 3, sc->is_number_symbol, sc->is_number_symbol, - sc->is_real_symbol)); - sc->asinh_symbol= - s7_define_typed_function (sc, "asinh", g_asinh, 1, 0, false, - "(asinh z) returns asinh(z)", sc->pl_nn); - sc->acosh_symbol= - s7_define_typed_function (sc, "acosh", g_acosh, 1, 0, false, - "(acosh z) returns acosh(z)", sc->pl_nn); - sc->atanh_symbol= - s7_define_typed_function (sc, "atanh", g_atanh, 1, 0, false, - "(atanh z) returns atanh(z)", sc->pl_nn); - sc->sqrt_symbol= s7_define_typed_function ( - sc, "sqrt", g_sqrt, 1, 0, false, "(sqrt z) returns the square root of z", - sc->pl_nn); - sc->floor_symbol= s7_define_typed_function ( - sc, "s7-floor", g_floor, 1, 0, false, - "(s7-floor x) returns the integer closest to x toward -inf", - s7_make_signature (sc, 2, sc->is_integer_symbol, sc->is_real_symbol)); - set_is_translucent (sc->floor_symbol); - sc->ceiling_symbol= s7_define_typed_function ( - sc, "s7-ceiling", g_ceiling, 1, 0, false, - "(s7-ceiling x) returns the integer closest to x toward inf", - s7_make_signature (sc, 2, sc->is_integer_symbol, sc->is_real_symbol)); - set_is_translucent (sc->ceiling_symbol); - sc->truncate_symbol= s7_define_typed_function ( - sc, "s7-truncate", g_truncate, 1, 0, false, - "(truncate x) returns the integer closest to x toward 0", - s7_make_signature (sc, 2, sc->is_integer_symbol, sc->is_real_symbol)); - set_is_translucent (sc->truncate_symbol); - sc->round_symbol= s7_define_typed_function ( - sc, "s7-round", g_round, 1, 0, false, - "(round x) returns the integer closest to x", - s7_make_signature (sc, 2, sc->is_integer_symbol, sc->is_real_symbol)); - set_is_translucent (sc->round_symbol); - sc->logand_symbol= s7_define_typed_function ( - sc, "logand", g_logand, 0, 0, true, - "(logand int32_t ...) returns the AND of its integer arguments (the bits " - "that are on in every argument)", - sc->pcl_i); - sc->logior_symbol= s7_define_typed_function ( - sc, "logior", g_logior, 0, 0, true, - "(logior int32_t ...) returns the OR of its integer arguments (the bits " - "that are on in any of the arguments)", - sc->pcl_i); - sc->logxor_symbol= s7_define_typed_function ( - sc, "logxor", g_logxor, 0, 0, true, - "(logxor int32_t ...) returns the XOR of its integer arguments (the bits " - "that are on in an odd number of the arguments)", - sc->pcl_i); - sc->lognot_symbol= s7_define_typed_function ( - sc, "lognot", g_lognot, 1, 0, false, - "(lognot num) returns the negation of num (its complement, the bits that " - "are not on): (lognot 0) -> -1", - sc->pcl_i); - sc->logbit_symbol= s7_define_typed_function ( - sc, "logbit?", g_logbit, 2, 0, false, - "(logbit? int index) returns #t if the index-th bit is on in int, " - "otherwise #f.", - s7_make_circular_signature (sc, 1, 2, sc->is_boolean_symbol, - sc->is_integer_symbol)); - sc->integer_decode_float_symbol= - defun ("integer-decode-float", integer_decode_float, 1, 0, false); - sc->nan_symbol = defun ("nan", nan, 0, 1, - false); /* (nan) -> +nan.0, (nan 123) -> +nan.123 */ - sc->nan_payload_symbol= defun ("nan-payload", nan_payload, 1, 0, false); + copy_initial_value(sc, sc->read_symbol); + + 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); + + + sc->real_part_symbol = s7_define_typed_function(sc, "real-part", g_real_part, 1, 0, false, "(real-part num) returns the real part of num", s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)); + sc->imag_part_symbol = s7_define_typed_function(sc, "imag-part", g_imag_part, 1, 0, false, "(imag-part num) returns the imaginary part of num", s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)); + sc->numerator_symbol = defun("numerator", numerator, 1, 0, false); + sc->denominator_symbol = defun("denominator", denominator, 1, 0, false); + sc->is_even_symbol = s7_define_typed_function(sc, "even?", g_even, 1, 0, false, "(even? int) returns #t if the integer int32_t is even", s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_integer_symbol)); + sc->is_odd_symbol = s7_define_typed_function(sc, "odd?", g_odd, 1, 0, false, "(odd? int) returns #t if the integer int32_t is odd", s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_integer_symbol)); + sc->is_zero_symbol = s7_define_typed_function(sc, "zero?", g_zero, 1, 0, false, "(zero? num) returns #t if the number num is zero", sc->pl_bn); + sc->is_positive_symbol = s7_define_typed_function(sc, "positive?", g_positive, 1, 0, false, "(positive? num) returns #t if the real number num is positive (greater than 0)", s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_real_symbol)); + sc->is_negative_symbol = s7_define_typed_function(sc, "negative?", g_negative, 1, 0, false, "(negative? num) returns #t if the real number num is negative (less than 0)", s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_real_symbol)); + sc->is_infinite_symbol = s7_define_typed_function(sc, "infinite?", g_is_infinite, 1, 0, false, "(infinite? obj) returns #t if obj has an infinite real or imaginary part", sc->pl_bt); + sc->is_nan_symbol = s7_define_typed_function(sc, "nan?", g_is_nan, 1, 0, false, "(nan? obj) returns #t if obj is a NaN", sc->pl_bt); + sc->complex_symbol = s7_define_typed_function(sc, "complex", g_complex, 2, 0, false, "(complex x1 x2) returns a complex number with real-part x1 and imaginary-part x2", s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_real_symbol, sc->is_real_symbol)); + + 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 = s7_define_typed_function(sc, "s7-min", g_min, 1, 0, true, "(min ...) returns the minimum of its arguments", sc->pcl_r); set_all_integer_and_float(sc->min_symbol); + sc->max_symbol = s7_define_typed_function(sc, "s7-max", g_max, 1, 0, true, "(max ...) returns the maximum of its arguments", sc->pcl_r); 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("s7-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 = s7_define_typed_function(sc, "gcd", g_gcd, 0, 0, true, "(gcd ...) returns the greatest common divisor of its rational arguments", sc->pcl_f); + sc->lcm_symbol = s7_define_typed_function(sc, "s7-lcm", g_lcm, 0, 0, true, "(lcm ...) returns the least common multiple of its rational arguments", sc->pcl_f); + sc->rationalize_symbol = s7_define_typed_function(sc, "rationalize", g_rationalize, 1, 1, false, "(rationalize x err) returns the ratio with smallest denominator within err of x", s7_make_signature(sc, 3, sc->is_rational_symbol, sc->is_real_symbol, sc->is_real_symbol)); + 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, 0, 2, false); + sc->expt_symbol = s7_define_typed_function(sc, "expt", g_expt, 2, 0, false, "(expt z1 z2) returns z1^z2", sc->pcl_n); + sc->log_symbol = s7_define_typed_function(sc, "log", g_log, 1, 1, false, "(log z1 (z2 e)) returns log(z1) / log(z2) where z2 (the base) defaults to e: (log 8 2) = 3", sc->pcl_n); + sc->ash_symbol = s7_define_typed_function(sc, "ash", g_ash, 2, 0, false, "(ash i1 i2) returns i1 shifted right or left i2 times, i1 << i2, (ash 1 3) -> 8, (ash 8 -3) -> 1", sc->pcl_i); + sc->exp_symbol = s7_define_typed_function(sc, "exp", g_exp, 1, 0, false, "(exp z) returns e^z, (exp 1) is 2.718281828459", sc->pl_nn); set_all_float(sc->exp_symbol); + sc->abs_symbol = s7_define_typed_function(sc, "abs", g_abs, 1, 0, false, "(abs x) returns the absolute value of the real number x", s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_real_symbol)); set_is_translucent(sc->abs_symbol); + sc->magnitude_symbol = s7_define_typed_function(sc, "magnitude", g_magnitude, 1, 0, false, "(magnitude z) returns the magnitude of z", s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)); set_all_integer_and_float(sc->magnitude_symbol); + sc->angle_symbol = s7_define_typed_function(sc, "angle", g_angle, 1, 0, false, "(angle z) returns the angle of z", s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)); + sc->sin_symbol = s7_define_typed_function(sc, "sin", g_sin, 1, 0, false, "(sin z) returns sin(z)", sc->pl_nn); set_all_float(sc->sin_symbol); + sc->cos_symbol = s7_define_typed_function(sc, "cos", g_cos, 1, 0, false, "(cos z) returns cos(z)", sc->pl_nn); set_all_float(sc->cos_symbol); + sc->tan_symbol = s7_define_typed_function(sc, "tan", g_tan, 1, 0, false, "(tan z) returns tan(z)", sc->pl_nn); set_all_float(sc->tan_symbol); + sc->sinh_symbol = s7_define_typed_function(sc, "sinh", g_sinh, 1, 0, false, "(sinh z) returns sinh(z)", sc->pl_nn); set_all_float(sc->sinh_symbol); + sc->cosh_symbol = s7_define_typed_function(sc, "cosh", g_cosh, 1, 0, false, "(cosh z) returns cosh(z)", sc->pl_nn); set_all_float(sc->cosh_symbol); + sc->tanh_symbol = s7_define_typed_function(sc, "tanh", g_tanh, 1, 0, false, "(tanh z) returns tanh(z)", sc->pl_nn); set_all_float(sc->tanh_symbol); + sc->asin_symbol = s7_define_typed_function(sc, "asin", g_asin, 1, 0, false, "(asin z) returns asin(z); (sin (asin x)) = x", sc->pl_nn); + sc->acos_symbol = s7_define_typed_function(sc, "acos", g_acos, 1, 0, false, "(acos z) returns acos(z); (cos (acos 1)) = 1", sc->pl_nn); + sc->atan_symbol = s7_define_typed_function(sc, "atan", g_atan, 1, 1, false, "(atan z) returns atan(z), (atan y x) returns atan(y/x)", s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_number_symbol, sc->is_real_symbol)); + sc->asinh_symbol = s7_define_typed_function(sc, "asinh", g_asinh, 1, 0, false, "(asinh z) returns asinh(z)", sc->pl_nn); + sc->acosh_symbol = s7_define_typed_function(sc, "acosh", g_acosh, 1, 0, false, "(acosh z) returns acosh(z)", sc->pl_nn); + sc->atanh_symbol = s7_define_typed_function(sc, "atanh", g_atanh, 1, 0, false, "(atanh z) returns atanh(z)", sc->pl_nn); + sc->sqrt_symbol = s7_define_typed_function(sc, "sqrt", g_sqrt, 1, 0, false, "(sqrt z) returns the square root of z", sc->pl_nn); + sc->floor_symbol = s7_define_typed_function(sc, "s7-floor", g_floor, 1, 0, false, "(s7-floor x) returns the integer closest to x toward -inf", s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)); set_is_translucent(sc->floor_symbol); + sc->ceiling_symbol = s7_define_typed_function(sc, "s7-ceiling", g_ceiling, 1, 0, false, "(s7-ceiling x) returns the integer closest to x toward inf", s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)); set_is_translucent(sc->ceiling_symbol); + sc->truncate_symbol = s7_define_typed_function(sc, "s7-truncate", g_truncate, 1, 0, false, "(truncate x) returns the integer closest to x toward 0", s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)); set_is_translucent(sc->truncate_symbol); + sc->round_symbol = s7_define_typed_function(sc, "s7-round", g_round, 1, 0, false, "(round x) returns the integer closest to x", s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)); set_is_translucent(sc->round_symbol); + sc->logand_symbol = s7_define_typed_function(sc, "logand", g_logand, 0, 0, true, "(logand int32_t ...) returns the AND of its integer arguments (the bits that are on in every argument)", sc->pcl_i); + sc->logior_symbol = s7_define_typed_function(sc, "logior", g_logior, 0, 0, true, "(logior int32_t ...) returns the OR of its integer arguments (the bits that are on in any of the arguments)", sc->pcl_i); + sc->logxor_symbol = s7_define_typed_function(sc, "logxor", g_logxor, 0, 0, true, "(logxor int32_t ...) returns the XOR of its integer arguments (the bits that are on in an odd number of the arguments)", sc->pcl_i); + sc->lognot_symbol = s7_define_typed_function(sc, "lognot", g_lognot, 1, 0, false, "(lognot num) returns the negation of num (its complement, the bits that are not on): (lognot 0) -> -1", sc->pcl_i); + sc->logbit_symbol = s7_define_typed_function(sc, "logbit?", g_logbit, 2, 0, false, "(logbit? int index) returns #t if the index-th bit is on in int, otherwise #f.", s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_integer_symbol)); + sc->integer_decode_float_symbol = defun("integer-decode-float", integer_decode_float, 1, 0, false); + sc->nan_symbol = defun("nan", nan, 0, 1, false); /* (nan) -> +nan.0, (nan 123) -> +nan.123 */ + sc->nan_payload_symbol = defun("nan-payload", nan_payload, 1, 0, false); #if !WITH_PURE_S7 - sc->integer_length_symbol= - defun ("integer-length", integer_length, 1, 0, false); - sc->inexact_to_exact_symbol= s7_define_typed_function ( - sc, "inexact->exact", g_inexact_to_exact, 1, 0, false, - "(inexact->exact num) converts num to an exact number; (inexact->exact " - "1.5) = 3/2", - s7_make_signature (sc, 2, sc->is_real_symbol, sc->is_real_symbol)); - sc->exact_to_inexact_symbol= s7_define_typed_function ( - sc, "exact->inexact", g_exact_to_inexact, 1, 0, false, - "(exact->inexact num) converts num to an inexact number; (exact->inexact " - "3/2) = 1.5", - s7_make_signature (sc, 2, sc->is_number_symbol, sc->is_number_symbol)); - sc->is_exact_symbol= s7_define_typed_function ( - sc, "exact?", g_exact, 1, 0, false, - "(exact? num) returns #t if num is exact (an integer or a ratio)", - sc->pl_bn); - sc->is_inexact_symbol= - s7_define_typed_function (sc, "inexact?", g_inexact, 1, 0, false, - "(inexact? num) returns #t if num is inexact " - "(neither an integer nor a ratio)", - sc->pl_bn); - sc->make_polar_symbol= s7_define_typed_function ( - sc, "make-polar", g_make_polar, 2, 0, false, - "(make-polar magnitude angle) returns (complex (* magnitude (cos angle)) " - "(* magnitude (sin angle)))", - s7_make_signature (sc, 3, sc->is_number_symbol, sc->is_real_symbol, - sc->is_real_symbol)); + sc->integer_length_symbol = defun("integer-length", integer_length, 1, 0, false); + sc->inexact_to_exact_symbol = s7_define_typed_function(sc, "inexact->exact", g_inexact_to_exact, 1, 0, false, "(inexact->exact num) converts num to an exact number; (inexact->exact 1.5) = 3/2", s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_real_symbol)); + sc->exact_to_inexact_symbol = s7_define_typed_function(sc, "exact->inexact", g_exact_to_inexact, 1, 0, false, "(exact->inexact num) converts num to an inexact number; (exact->inexact 3/2) = 1.5", s7_make_signature(sc, 2, sc->is_number_symbol, sc->is_number_symbol)); + sc->is_exact_symbol = s7_define_typed_function(sc, "exact?", g_exact, 1, 0, false, "(exact? num) returns #t if num is exact (an integer or a ratio)", sc->pl_bn); + sc->is_inexact_symbol = s7_define_typed_function(sc, "inexact?", g_inexact, 1, 0, false, "(inexact? num) returns #t if num is inexact (neither an integer nor a ratio)", sc->pl_bn); + sc->make_polar_symbol = s7_define_typed_function(sc, "make-polar", g_make_polar, 2, 0, false, "(make-polar magnitude angle) returns (complex (* magnitude (cos angle)) (* magnitude (sin angle)))", s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_real_symbol, sc->is_real_symbol)); #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_to_integer_symbol= s7_define_typed_function ( - sc, "char->integer", g_char_to_integer, 1, 0, false, - "(char->integer c) converts the character c to an integer", - s7_make_signature (sc, 2, sc->is_integer_symbol, sc->is_char_symbol)); - sc->integer_to_char_symbol= s7_define_typed_function ( - sc, "integer->char", g_integer_to_char, 1, 0, false, - "(integer->char i) converts the non-negative integer i to a character", - s7_make_signature (sc, 2, sc->is_char_symbol, sc->is_integer_symbol)); - - sc->char_eq_symbol= s7_define_typed_function ( - sc, "char=?", g_chars_are_equal, 2, 0, true, - "(char=? char ...) returns #t if all the character arguments are equal", - sc->pcl_bc); - sc->char_lt_symbol= - s7_define_typed_function (sc, "charpcl_bc); - sc->char_gt_symbol= - s7_define_typed_function (sc, "char>?", g_chars_are_greater, 2, 0, true, - "(char>? char ...) returns #t if all the " - "character arguments are decreasing", - sc->pcl_bc); - sc->char_leq_symbol= - s7_define_typed_function (sc, "char<=?", g_chars_are_leq, 2, 0, true, - "(char<=? char ...) returns #t if all the " - "character arguments are equal or increasing", - sc->pcl_bc); - sc->char_geq_symbol= - s7_define_typed_function (sc, "char>=?", g_chars_are_geq, 2, 0, true, - "(char>=? char ...) returns #t if all the " - "character arguments are equal or decreasing", - sc->pcl_bc); - sc->char_position_symbol= s7_define_typed_function ( - sc, "char-position", g_char_position, 2, 1, false, - "(char-position char-or-str str (start 0)) returns the position of the " - "first occurrence of char in str, or #f", - 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)); - 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 = s7_define_typed_function ( - sc, "string-ref", g_string_ref, 2, 0, false, - "(string-ref str index) returns the character at the index-th element of " - "the string str", - s7_make_signature (sc, 3, sc->is_char_symbol, sc->is_string_symbol, - sc->is_integer_symbol)); - sc->string_set_symbol= s7_define_typed_function ( - sc, "string-set!", g_string_set, 3, 0, false, - "(string-set! str index chr) sets the index-th element of the string str " - "to the character chr", - s7_make_signature (sc, 4, sc->is_char_symbol, sc->is_string_symbol, - sc->is_integer_symbol, sc->is_char_symbol)); - - 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); + 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_to_integer_symbol = s7_define_typed_function(sc, "char->integer", g_char_to_integer, 1, 0, false, + "(char->integer c) converts the character c to an integer", + s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_char_symbol)); + sc->integer_to_char_symbol = s7_define_typed_function(sc, "integer->char", g_integer_to_char, 1, 0, false, + "(integer->char i) converts the non-negative integer i to a character", + s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_integer_symbol)); + + + sc->char_eq_symbol = s7_define_typed_function(sc, "char=?", g_chars_are_equal, 2, 0, true, + "(char=? char ...) returns #t if all the character arguments are equal", sc->pcl_bc); + sc->char_lt_symbol = s7_define_typed_function(sc, "charpcl_bc); + sc->char_gt_symbol = s7_define_typed_function(sc, "char>?", g_chars_are_greater, 2, 0, true, + "(char>? char ...) returns #t if all the character arguments are decreasing", sc->pcl_bc); + sc->char_leq_symbol = s7_define_typed_function(sc, "char<=?", g_chars_are_leq, 2, 0, true, + "(char<=? char ...) returns #t if all the character arguments are equal or increasing", sc->pcl_bc); + sc->char_geq_symbol = s7_define_typed_function(sc, "char>=?", g_chars_are_geq, 2, 0, true, + "(char>=? char ...) returns #t if all the character arguments are equal or decreasing", sc->pcl_bc); + sc->char_position_symbol = s7_define_typed_function(sc, "char-position", g_char_position, 2, 1, false, + "(char-position char-or-str str (start 0)) returns the position of the first occurrence of char in str, or #f", + 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)); + 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 = s7_define_typed_function(sc, "string-ref", g_string_ref, 2, 0, false, + "(string-ref str index) returns the character at the index-th element of the string str", + s7_make_signature(sc, 3, sc->is_char_symbol, sc->is_string_symbol, sc->is_integer_symbol)); + sc->string_set_symbol = s7_define_typed_function(sc, "string-set!", g_string_set, 3, 0, false, + "(string-set! str index chr) sets the index-th element of the string str to the character chr", + s7_make_signature(sc, 4, sc->is_char_symbol, sc->is_string_symbol, sc->is_integer_symbol, sc->is_char_symbol)); + + 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->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= s7_define_typed_function ( - sc, "string-length", g_string_length, 1, 0, false, - "(string-length str) returns the length of str.", - s7_make_signature (sc, 2, sc->is_integer_symbol, sc->is_string_symbol)); - sc->string_to_list_symbol= - defun ("string->list", string_to_list, 1, 2, false); + 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 = s7_define_typed_function(sc, "string-length", g_string_length, 1, 0, false, "(string-length str) returns the length of str.", s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_string_symbol)); + 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_append_symbol= defun ("string-append", string_append, 0, 0, true); - sc->substring_symbol = defun ("substring", substring, 1, 2, false); - sc->substring_uncopied_symbol= - defun ("substring-uncopied", substring_uncopied, 1, 2, false); - sc->string_symbol= defun ("string", string, 0, 0, true); - sc->object_to_string_symbol= - defun ("object->string", object_to_string, 1, 2, false); - -#define H_format \ - "(format out str . args) substitutes args into str sending the result to out. Most of \ + sc->string_copy_symbol = defun("string-copy", string_copy, 1, 3, false); + + sc->string_append_symbol = defun("string-append", string_append, 0, 0, true); + sc->substring_symbol = defun("substring", substring, 1, 2, false); + sc->substring_uncopied_symbol = defun("substring-uncopied",substring_uncopied, 1, 2, false); + sc->string_symbol = defun("string", string, 0, 0, true); + sc->object_to_string_symbol = defun("object->string", object_to_string, 1, 2, false); + + #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, \ @@ -106317,1090 +81036,876 @@ spacing (and spacing character) and precision. ~{ starts an embedded format dir If the 'out' argument is not an output port (i.e. #f, #t, or ()), 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, sc->is_string_symbol, \ - s7_make_signature (sc, 3, sc->is_output_port_symbol, \ - sc->is_boolean_symbol, sc->is_null_symbol), \ - sc->T) - - 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); - set_is_saver (sc->cons_symbol); - 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); - set_is_saver (sc->list_symbol); - 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); - set_is_saver (sc->make_list_symbol); - -#define H_filter \ - "(g_filter pred lst) returns a list of the elements of lst for which (pred " \ - "element) is not #f" -#define Q_filter \ - s7_make_signature (sc, 3, sc->is_list_symbol, sc->is_procedure_symbol, \ - sc->is_list_symbol) - s7_define_semisafe_typed_function (sc, "g_filter", g_filter, 2, 0, false, - H_filter, Q_filter); - -#define H_take "(g_take lst k) returns a list of the first k elements of lst" -#define Q_take \ - s7_make_signature (sc, 3, sc->is_list_symbol, sc->is_list_symbol, \ - sc->is_integer_symbol) - s7_define_semisafe_typed_function (sc, "g_take", g_take, 2, 0, false, H_take, - Q_take); - -/* take-right can return the non-pair tail of a dotted list, hence the #t return - * signature */ -#define H_take_right "(g_take_right lst k) returns the last k elements of lst" -#define Q_take_right \ - s7_make_signature (sc, 3, sc->T, sc->is_list_symbol, sc->is_integer_symbol) - s7_define_semisafe_typed_function (sc, "g_take_right", g_take_right, 2, 0, - false, H_take_right, Q_take_right); - -#define H_drop_right \ - "(g_drop_right lst k) returns a list of all but the last k elements of lst" -#define Q_drop_right \ - s7_make_signature (sc, 3, sc->is_list_symbol, sc->is_list_symbol, \ - sc->is_integer_symbol) - s7_define_semisafe_typed_function (sc, "g_drop_right", g_drop_right, 2, 0, - false, H_drop_right, Q_drop_right); - - 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); + #define Q_format s7_make_circular_signature(sc, 2, 3, \ + sc->is_string_symbol, s7_make_signature(sc, 3, sc->is_output_port_symbol, sc->is_boolean_symbol, sc->is_null_symbol), sc->T) + + 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); set_is_saver(sc->cons_symbol); + 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); set_is_saver(sc->list_symbol); + 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); set_is_saver(sc->make_list_symbol); + + #define H_filter "(g_filter pred lst) returns a list of the elements of lst for which (pred element) is not #f" + #define Q_filter s7_make_signature(sc, 3, sc->is_list_symbol, sc->is_procedure_symbol, sc->is_list_symbol) + s7_define_semisafe_typed_function(sc, "g_filter", g_filter, 2, 0, false, H_filter, Q_filter); + + #define H_find "(g_find pred lst) returns the first element of lst for which (pred element) is not #f, or #f if there is no such element" + #define Q_find s7_make_signature(sc, 3, sc->T, sc->is_procedure_symbol, sc->is_list_symbol) + s7_define_semisafe_typed_function(sc, "g_find", g_find, 2, 0, false, H_find, Q_find); + + #define H_any "(g_any pred lst) returns #t if (pred element) is not #f for some element of lst, otherwise #f" + #define Q_any s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->is_procedure_symbol, sc->is_list_symbol) + s7_define_semisafe_typed_function(sc, "g_any", g_any, 2, 0, false, H_any, Q_any); + + #define H_every "(g_every pred lst) returns #t if (pred element) is not #f for every element of lst, otherwise #f" + #define Q_every s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->is_procedure_symbol, sc->is_list_symbol) + s7_define_semisafe_typed_function(sc, "g_every", g_every, 2, 0, false, H_every, Q_every); + + #define H_count "(g_count pred clist1 clist2 ...) returns the number of element tuples for which (pred elem1 elem2 ...) is not #f, stopping at the end of the shortest list" + #define Q_count s7_make_circular_signature(sc, 2, 3, sc->is_integer_symbol, sc->is_procedure_symbol, sc->is_list_symbol) + s7_define_semisafe_typed_function(sc, "g_count", g_count, 2, 0, true, H_count, Q_count); + + #define H_list_index "(g_list_index pred clist1 clist2 ...) returns the index of the first element tuple for which (pred elem1 elem2 ...) is not #f, or #f if there is none, stopping at the end of the shortest list" + #define Q_list_index s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_procedure_symbol, sc->is_list_symbol) + s7_define_semisafe_typed_function(sc, "g_list_index", g_list_index, 2, 0, true, H_list_index, Q_list_index); + + #define H_fold "(g_fold f init lst) folds f over the elements of lst: (f elem acc)" + #define Q_fold s7_make_signature(sc, 4, sc->T, sc->is_procedure_symbol, sc->T, sc->is_list_symbol) + s7_define_semisafe_typed_function(sc, "g_fold", g_fold, 3, 0, false, H_fold, Q_fold); + + #define H_fold_right "(g_fold_right f init lst) folds f from the right over the elements of lst: (f elem acc)" + #define Q_fold_right s7_make_signature(sc, 4, sc->T, sc->is_procedure_symbol, sc->T, sc->is_list_symbol) + s7_define_semisafe_typed_function(sc, "g_fold_right", g_fold_right, 3, 0, false, H_fold_right, Q_fold_right); + + #define H_take "(g_take lst k) returns a list of the first k elements of lst" + #define Q_take s7_make_signature(sc, 3, sc->is_list_symbol, sc->is_list_symbol, sc->is_integer_symbol) + s7_define_semisafe_typed_function(sc, "g_take", g_take, 2, 0, false, H_take, Q_take); + + /* take-right can return the non-pair tail of a dotted list, hence the #t return signature */ + #define H_take_right "(g_take_right lst k) returns the last k elements of lst" + #define Q_take_right s7_make_signature(sc, 3, sc->T, sc->is_list_symbol, sc->is_integer_symbol) + s7_define_semisafe_typed_function(sc, "g_take_right", g_take_right, 2, 0, false, H_take_right, Q_take_right); + + #define H_drop_right "(g_drop_right lst k) returns a list of all but the last k elements of lst" + #define Q_drop_right s7_make_signature(sc, 3, sc->is_list_symbol, sc->is_list_symbol, sc->is_integer_symbol) + s7_define_semisafe_typed_function(sc, "g_drop_right", g_drop_right, 2, 0, false, H_drop_right, Q_drop_right); + + #define H_vector_filter "(g_vector_filter pred vec) returns a vector of the elements of vec for which (pred element) is not #f" + #define Q_vector_filter s7_make_signature(sc, 3, sc->is_vector_symbol, sc->is_procedure_symbol, sc->is_vector_symbol) + s7_define_semisafe_typed_function(sc, "g_vector_filter", g_vector_filter, 2, 0, false, H_vector_filter, Q_vector_filter); + + 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); -#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) - 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); -#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) - 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); + sc->vector_append_symbol = defun("vector-append", vector_append, 0, 0, true); + #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) + 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); + #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) + 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; + sc->vector_append_symbol = sc->append_symbol; + sc->vector_fill_symbol = sc->fill_symbol; + sc->string_fill_symbol = sc->fill_symbol; #endif -#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) - sc->vector_ref_symbol= defun ("vector-ref", vector_ref, 2, 0, true); - sc->vector_set_symbol= defun ("vector-set!", vector_set, 3, 0, true); -#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) - sc->vector_dimension_symbol= - defun ("vector-dimension", vector_dimension, 2, 0, false); -#define H_vector_dimensions \ - "(vector-dimensions vect) returns a list of vect's dimensions" -#define Q_vector_dimensions \ - s7_make_signature (sc, 2, sc->is_pair_symbol, sc->is_vector_symbol) - sc->vector_dimensions_symbol= - defun ("vector-dimensions", vector_dimensions, 1, 0, false); -#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) - sc->vector_rank_symbol= defun ("vector-rank", vector_rank, 1, 0, false); - sc->make_vector_symbol= defun ("make-vector", make_vector, 1, 2, false); - set_is_saver (sc->make_vector_symbol); -#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) - sc->vector_symbol= defun ("vector", vector, 0, 0, true); - set_is_saver (sc->vector_symbol); -#define H_vector_typer \ - "(vector-typer vect) returns the vector's element type checking function" -#define Q_vector_typer \ - s7_make_signature ( \ - sc, 2, \ - s7_make_signature (sc, 2, sc->not_symbol, sc->is_procedure_symbol), \ - sc->is_vector_symbol) - sc->vector_typer_symbol= defun ("vector-typer", vector_typer, 1, 0, false); - - sc->subvector_symbol= defun ("subvector", subvector, 1, 3, false); - set_is_saver (sc->subvector_symbol); -#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) - sc->subvector_position_symbol= - defun ("subvector-position", subvector_position, 1, 0, false); -#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) - sc->subvector_vector_symbol= - defun ("subvector-vector", subvector_vector, 1, 0, false); - -#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) - 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); - -#define H_complex_vector \ - "(complex-vector ...) returns an homogeneous complex vector whose elements " \ - "are the arguments" -#define Q_complex_vector \ - s7_make_circular_signature (sc, 1, 2, sc->is_complex_vector_symbol, \ - sc->is_complex_symbol) - sc->complex_vector_symbol= - defun ("complex-vector", complex_vector, 0, 0, true); - sc->make_complex_vector_symbol= - defun ("make-complex-vector", make_complex_vector, 1, 1, false); - sc->complex_vector_set_symbol= - defun ("complex-vector-set!", complex_vector_set, 3, 0, true); - sc->complex_vector_ref_symbol= - defun ("complex-vector-ref", complex_vector_ref, 2, 0, true); - -#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) - 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); - -#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) - 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); -#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) - sc->string_to_byte_vector_symbol= - defun ("string->byte-vector", string_to_byte_vector, 1, 0, false); -#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) - 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); - set_has_even_args (global_value (sc->hash_table_symbol)); - set_is_saver (sc->hash_table_symbol); - sc->make_hash_table_symbol= - defun ("s7-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); - set_has_even_args (global_value (sc->weak_hash_table_symbol)); - set_is_saver (sc->weak_hash_table_symbol); - sc->hash_table_ref_symbol= - defun ("hash-table-ref", hash_table_ref, 2, 0, true); - sc->hash_table_set_symbol= - defun ("s7-hash-table-set!", hash_table_set, 3, 0, false); - sc->hash_table_size_symbol= - defun ("hash-table-size", hash_table_size, 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->hash_table_key_typer_symbol= - defun ("hash-table-key-typer", hash_table_key_typer, 1, 0, false); - sc->hash_table_value_typer_symbol= - defun ("hash-table-value-typer", hash_table_value_typer, 1, 0, false); - - 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); - sc->call_with_current_continuation_symbol= - semisafe_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); /* semisafe: see t101-6.scm, apply on stack */ - - sc->load_symbol= semisafe_defun ("load", load, 1, 1, false); -#define H_autoload \ - "(autoload symbol file-or-function) adds the symbol to its table of autoloadable symbols. \ + #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) + sc->vector_ref_symbol = defun("vector-ref", vector_ref, 2, 0, true); + sc->vector_set_symbol = defun("vector-set!", vector_set, 3, 0, true); + #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) + sc->vector_dimension_symbol = defun("vector-dimension", vector_dimension, 2, 0, false); + #define H_vector_dimensions "(vector-dimensions vect) returns a list of vect's dimensions" + #define Q_vector_dimensions s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_vector_symbol) + sc->vector_dimensions_symbol = defun("vector-dimensions", vector_dimensions, 1, 0, false); + #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) + sc->vector_rank_symbol = defun("vector-rank", vector_rank, 1, 0, false); + sc->make_vector_symbol = defun("make-vector", make_vector, 1, 2, false); set_is_saver(sc->make_vector_symbol); + #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) + sc->vector_symbol = defun("vector", vector, 0, 0, true); set_is_saver(sc->vector_symbol); + #define H_vector_typer "(vector-typer vect) returns the vector's element type checking function" + #define Q_vector_typer s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->not_symbol, sc->is_procedure_symbol), sc->is_vector_symbol) + sc->vector_typer_symbol = defun("vector-typer", vector_typer, 1, 0, false); + + sc->subvector_symbol = defun("subvector", subvector, 1, 3, false); set_is_saver(sc->subvector_symbol); + #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) + sc->subvector_position_symbol = defun("subvector-position", subvector_position, 1, 0, false); + #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) + sc->subvector_vector_symbol = defun("subvector-vector", subvector_vector, 1, 0, false); + + #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) + 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); + + #define H_complex_vector "(complex-vector ...) returns an homogeneous complex vector whose elements are the arguments" + #define Q_complex_vector s7_make_circular_signature(sc, 1, 2, sc->is_complex_vector_symbol, sc->is_complex_symbol) + sc->complex_vector_symbol = defun("complex-vector", complex_vector, 0, 0, true); + sc->make_complex_vector_symbol = defun("make-complex-vector", make_complex_vector, 1, 1, false); + sc->complex_vector_set_symbol = defun("complex-vector-set!", complex_vector_set, 3, 0, true); + sc->complex_vector_ref_symbol = defun("complex-vector-ref", complex_vector_ref, 2, 0, true); + + #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) + 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); + + #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) + 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); + #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) + sc->string_to_byte_vector_symbol = defun("string->byte-vector", string_to_byte_vector, 1, 0, false); + #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) + 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); + set_has_even_args(global_value(sc->hash_table_symbol)); + set_is_saver(sc->hash_table_symbol); + sc->make_hash_table_symbol = defun("s7-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); + set_has_even_args(global_value(sc->weak_hash_table_symbol)); + set_is_saver(sc->weak_hash_table_symbol); + sc->hash_table_ref_symbol = defun("hash-table-ref", hash_table_ref, 2, 0, true); + sc->hash_table_set_symbol = defun("s7-hash-table-set!", hash_table_set, 3, 0, false); + sc->hash_table_size_symbol = defun("hash-table-size", hash_table_size, 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->hash_table_key_typer_symbol = defun("hash-table-key-typer", hash_table_key_typer, 1, 0, false); + sc->hash_table_value_typer_symbol = defun("hash-table-value-typer", hash_table_value_typer, 1, 0, false); + + 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); + sc->call_with_current_continuation_symbol = semisafe_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); /* semisafe: see t101-6.scm, apply on stack */ + + sc->load_symbol = semisafe_defun("load", load, 1, 1, false); + #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) - sc->autoload_symbol= defun ("autoload", autoload, 2, 0, false); - sc->eval_symbol = semisafe_defun ("eval", eval, 1, 1, false); - 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 */ - 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 + #define Q_autoload s7_make_signature(sc, 3, sc->T, sc->is_symbol_symbol, sc->T) + sc->autoload_symbol = defun("autoload", autoload, 2, 0, false); + sc->eval_symbol = semisafe_defun("eval", eval, 1, 1, false); 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 */ + 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, 1, false); - sc->catch_symbol= semisafe_defun ("catch", catch, 3, 0, false); - sc->throw_symbol= semisafe_defun ( - "throw", throw, 1, 0, true); /* was unsafe 29-Mar-25 (also error) */ - sc->error_symbol= - semisafe_defun ("error", error, 1, 0, true); /* was 0,0 -- 1-Aug-22 */ - /* unsafe example: 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); - set_is_saver (sc->values_symbol); - /* calling values a saver rather than translucent slows down tmv.scm by about - * 6% */ - /* values_symbol set above for signatures, not semisafe! -- many errors in - * s7test */ - /* set_immutable(c_function_setter(global_value(sc->values_symbol))); */ /* not - needed, - I - think - */ + 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, 1, false); + sc->catch_symbol = semisafe_defun("catch", catch, 3, 0, false); + sc->throw_symbol = semisafe_defun("throw", throw, 1, 0, true); /* was unsafe 29-Mar-25 (also error) */ + sc->error_symbol = semisafe_defun("error", error, 1, 0, true); /* was 0,0 -- 1-Aug-22 */ + /* unsafe example: 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); set_is_saver(sc->values_symbol); + /* calling values a saver rather than translucent slows down tmv.scm by about 6% */ + /* values_symbol set above for signatures, not semisafe! -- many errors in s7test */ + /* set_immutable(c_function_setter(global_value(sc->values_symbol))); */ /* not needed, I think */ /* quasiquote helper funcs */ #if WITH_IMMUTABLE_UNQUOTE - sc->unquote_symbol= make_symbol (sc, "", 9); - set_immutable (sc->unquote_symbol); + sc->unquote_symbol = make_symbol(sc, "", 9); set_immutable(sc->unquote_symbol); #else - sc->unquote_symbol= make_symbol (sc, "unquote", 7); + sc->unquote_symbol = make_symbol(sc, "unquote", 7); #endif - sc->qq_append_symbol= defun ("", qq_append, 2, 0, false); - set_is_saver (sc->qq_append_symbol); /* occurs via quasiquote as #_ */ - sc->apply_values_symbol= - unsafe_defun ("apply-values", apply_values, 0, 1, false); - set_is_saver (sc->apply_values_symbol); - sc->list_values_symbol= defun ("list-values", list_values, 0, 0, true); - set_is_saver (sc->list_values_symbol); - copy_initial_value (sc, sc->apply_values_symbol); - copy_initial_value (sc, sc->list_values_symbol); + sc->qq_append_symbol = defun("", qq_append, 2, 0, false); set_is_saver(sc->qq_append_symbol); /* occurs via quasiquote as #_ */ + sc->apply_values_symbol = unsafe_defun("apply-values", apply_values, 0, 1, false); set_is_saver(sc->apply_values_symbol); + sc->list_values_symbol = defun("list-values", list_values, 0, 0, true); set_is_saver(sc->list_values_symbol); + copy_initial_value(sc, sc->apply_values_symbol); + copy_initial_value(sc, sc->list_values_symbol); /* are these three names necessary? */ - 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->procedure_arglist_symbol= - defun ("procedure-arglist", procedure_arglist, 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); + 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->procedure_arglist_symbol = defun("procedure-arglist", procedure_arglist, 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_pointer get_func; - get_func= s7_typed_dilambda (sc, "setter", g_setter, 1, 1, g_set_setter, 2, - 1, H_setter, Q_setter, NULL); - set_immutable (c_function_setter (get_func)); + get_func = s7_typed_dilambda(sc, "setter", g_setter, 1, 1, g_set_setter, 2, 1, H_setter, Q_setter, NULL); + set_immutable(c_function_setter(get_func)); } - sc->arity_symbol = defun ("arity", arity, 1, 0, false); - sc->is_aritable_symbol= defun ("aritable?", is_aritable, 2, 0, false); + 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->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, 2, 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, 2, false); #if WITH_GCC - s7_define_function (sc, "abort", g_abort, 0, 0, false, - "drop into gdb I hope"); + s7_define_function(sc, "abort", g_abort, 0, 0, false, "drop into gdb I hope"); #endif #if S7_DEBUGGING - defun ("heap-scan", heap_scan, 1, 0, false); - defun ("heap-analyze", heap_analyze, 0, 0, false); - defun ("heap-holder", heap_holder, 1, 0, false); - defun ("heap-holders", heap_holders, 1, 0, false); - - defun ("show-stack", show_stack, 0, 1, false); - defun ("show-op-stack", show_op_stack, 0, 0, false); - defun ("op-stack?", is_op_stack, 0, 0, false); + defun("heap-scan", heap_scan, 1, 0, false); + defun("heap-analyze", heap_analyze, 0, 0, false); + defun("heap-holder", heap_holder, 1, 0, false); + defun("heap-holders", heap_holders, 1, 0, false); + + defun("show-stack", show_stack, 0, 1, false); + defun("show-op-stack", show_op_stack, 0, 0, false); + defun("op-stack?", is_op_stack, 0, 0, false); #endif - s7_define_function (sc, "s7-optimize", g_optimize, 1, 0, false, - "short-term debugging aid"); - sc->c_object_set_function= s7_make_safe_function ( - sc, "#", g_c_object_set, 1, 0, true, "c-object setter"); - /* c_function_set_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->hook_functions_symbol= - defun ("hook-functions", hook_functions, 1, 0, false); - - sc->quasiquote_symbol= - s7_define_macro (sc, "quasiquote", g_quasiquote, 1, 0, false, - H_quasiquote); /* is this considered syntax? r7rs says - yes; also unquote */ - copy_initial_value (sc, sc->quasiquote_symbol); - sc->quasiquote_function= initial_value (sc->quasiquote_symbol); - - sc->reader_cond_symbol= s7_define_expansion (sc, "reader-cond", g_reader_cond, - 1, 0, true, H_reader_cond); + s7_define_function(sc, "s7-optimize", g_optimize, 1, 0, false, "short-term debugging aid"); + sc->c_object_set_function = s7_make_safe_function(sc, "#", g_c_object_set, 1, 0, true, "c-object setter"); + /* c_function_set_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->hook_functions_symbol = defun("hook-functions", hook_functions, 1, 0, false); + + sc->quasiquote_symbol = s7_define_macro(sc, "quasiquote", g_quasiquote, 1, 0, false, H_quasiquote); /* is this considered syntax? r7rs says yes; also unquote */ + copy_initial_value(sc, sc->quasiquote_symbol); + sc->quasiquote_function = initial_value(sc->quasiquote_symbol); + + sc->reader_cond_symbol = s7_define_expansion(sc, "reader-cond", g_reader_cond, 1, 0, true, H_reader_cond); #if !WITH_PURE_S7 - sc->cond_expand_symbol= s7_define_expansion (sc, "cond-expand", g_cond_expand, - 1, 0, true, H_cond_expand); + sc->cond_expand_symbol = s7_define_expansion(sc, "cond-expand", g_cond_expand, 1, 0, true, H_cond_expand); #endif #if WITH_R7RS - sc->r7rs_inited= false; - sc->global_is_eq= - global_value (sc->is_eq_symbol); /* for later restore ('r7rs -> 's7) */ - sc->global_memq = global_value (sc->memq_symbol); - sc->global_assq = global_value (sc->assq_symbol); - sc->initial_is_eq= initial_value (sc->is_eq_symbol); - sc->initial_memq = initial_value (sc->memq_symbol); - sc->initial_assq = initial_value (sc->assq_symbol); + sc->r7rs_inited = false; + sc->global_is_eq = global_value(sc->is_eq_symbol); /* for later restore ('r7rs -> 's7) */ + sc->global_memq = global_value(sc->memq_symbol); + sc->global_assq = global_value(sc->assq_symbol); + sc->initial_is_eq = initial_value(sc->is_eq_symbol); + sc->initial_memq = initial_value(sc->memq_symbol); + sc->initial_assq = initial_value(sc->assq_symbol); #endif - sc->profile_in_symbol= unsafe_defun ("profile-in", profile_in, 2, 0, - false); /* calls dynamic-unwind */ - sc->profile_out = NULL; + sc->profile_in_symbol = unsafe_defun("profile-in", profile_in, 2, 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, - sc->features_setter= s7_make_safe_function ( - sc, "#", g_features_set, 2, 0, false, - "*features* setter")); + 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, sc->features_setter = s7_make_safe_function(sc, "#", g_features_set, 2, 0, false, "*features* setter")); /* -------- *load-path* -------- */ - sc->load_path_symbol= s7_define_variable_with_documentation ( - sc, "*load-path*", sc->nil, - /* list_1(sc, make_string_with_length(sc, ".", 1)), */ /* 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_safe_function (sc, "#", - g_load_path_set, 2, 0, false, - "*load-path* setter")); + sc->load_path_symbol = s7_define_variable_with_documentation(sc, "*load-path*", sc->nil, /* list_1(sc, make_string_with_length(sc, ".", 1)), */ /* 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_safe_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); + 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); + sc->cload_directory_symbol = s7_define_variable(sc, "*cload-directory*", nil_string); #endif - s7_set_setter (sc, sc->cload_directory_symbol, - s7_make_safe_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 */ -#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) - 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_safe_function (sc, "#", - g_libraries_set, 2, 0, false, - "*libraries* setter")); - - s7_autoload (sc, make_symbol (sc, "cload.scm", 9), - s7_make_semipermanent_string (sc, "cload.scm")); - s7_autoload (sc, make_symbol (sc, "lint.scm", 8), - s7_make_semipermanent_string (sc, "lint.scm")); - s7_autoload (sc, make_symbol (sc, "stuff.scm", 9), - s7_make_semipermanent_string (sc, "stuff.scm")); - s7_autoload (sc, make_symbol (sc, "mockery.scm", 11), - s7_make_semipermanent_string (sc, "mockery.scm")); - s7_autoload (sc, make_symbol (sc, "write.scm", 9), - s7_make_semipermanent_string (sc, "write.scm")); - s7_autoload (sc, make_symbol (sc, "reactive.scm", 12), - s7_make_semipermanent_string (sc, "reactive.scm")); - s7_autoload (sc, make_symbol (sc, "repl.scm", 8), - s7_make_semipermanent_string (sc, "repl.scm")); - s7_autoload (sc, make_symbol (sc, "r7rs.scm", 8), - s7_make_semipermanent_string (sc, "r7rs.scm")); - s7_autoload (sc, make_symbol (sc, "profile.scm", 11), - s7_make_semipermanent_string (sc, "profile.scm")); - s7_autoload (sc, make_symbol (sc, "debug.scm", 9), - s7_make_semipermanent_string (sc, "debug.scm")); - s7_autoload (sc, make_symbol (sc, "case.scm", 8), - s7_make_semipermanent_string (sc, "case.scm")); - - s7_autoload (sc, make_symbol (sc, "libc.scm", 8), - s7_make_semipermanent_string (sc, "libc.scm")); - s7_autoload ( - sc, make_symbol (sc, "libm.scm", 8), - s7_make_semipermanent_string (sc, "libm.scm")); /* repl.scm adds *libm* */ - s7_autoload (sc, make_symbol (sc, "libdl.scm", 9), - s7_make_semipermanent_string (sc, "libdl.scm")); - s7_autoload (sc, make_symbol (sc, "libgsl.scm", 10), - s7_make_semipermanent_string ( - sc, "libgsl.scm")); /* repl.scm adds *libgsl* -- why? */ - s7_autoload (sc, make_symbol (sc, "libgdbm.scm", 11), - s7_make_semipermanent_string (sc, "libgdbm.scm")); - s7_autoload (sc, make_symbol (sc, "libutf8proc.scm", 15), - s7_make_semipermanent_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, small_int (ST_MAX_FRAMES), small_int (ST_CODE_COLS), - small_int (ST_TOTAL_COLS), small_int (ST_NOTES_START_COL), - (ST_AS_COMMENT) ? sc->T : sc->F); + s7_set_setter(sc, sc->cload_directory_symbol, + s7_make_safe_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 */ + #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) + 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_safe_function(sc, "#", g_libraries_set, 2, 0, false, "*libraries* setter")); + + s7_autoload(sc, make_symbol(sc, "cload.scm", 9), s7_make_semipermanent_string(sc, "cload.scm")); + s7_autoload(sc, make_symbol(sc, "lint.scm", 8), s7_make_semipermanent_string(sc, "lint.scm")); + s7_autoload(sc, make_symbol(sc, "stuff.scm", 9), s7_make_semipermanent_string(sc, "stuff.scm")); + s7_autoload(sc, make_symbol(sc, "mockery.scm", 11), s7_make_semipermanent_string(sc, "mockery.scm")); + s7_autoload(sc, make_symbol(sc, "write.scm", 9), s7_make_semipermanent_string(sc, "write.scm")); + s7_autoload(sc, make_symbol(sc, "reactive.scm", 12), s7_make_semipermanent_string(sc, "reactive.scm")); + s7_autoload(sc, make_symbol(sc, "repl.scm", 8), s7_make_semipermanent_string(sc, "repl.scm")); + s7_autoload(sc, make_symbol(sc, "r7rs.scm", 8), s7_make_semipermanent_string(sc, "r7rs.scm")); + s7_autoload(sc, make_symbol(sc, "profile.scm", 11), s7_make_semipermanent_string(sc, "profile.scm")); + s7_autoload(sc, make_symbol(sc, "debug.scm", 9), s7_make_semipermanent_string(sc, "debug.scm")); + s7_autoload(sc, make_symbol(sc, "case.scm", 8), s7_make_semipermanent_string(sc, "case.scm")); + + s7_autoload(sc, make_symbol(sc, "libc.scm", 8), s7_make_semipermanent_string(sc, "libc.scm")); + s7_autoload(sc, make_symbol(sc, "libm.scm", 8), s7_make_semipermanent_string(sc, "libm.scm")); /* repl.scm adds *libm* */ + s7_autoload(sc, make_symbol(sc, "libdl.scm", 9), s7_make_semipermanent_string(sc, "libdl.scm")); + s7_autoload(sc, make_symbol(sc, "libgsl.scm", 10), s7_make_semipermanent_string(sc, "libgsl.scm")); /* repl.scm adds *libgsl* -- why? */ + s7_autoload(sc, make_symbol(sc, "libgdbm.scm", 11), s7_make_semipermanent_string(sc, "libgdbm.scm")); + s7_autoload(sc, make_symbol(sc, "libutf8proc.scm", 15), s7_make_semipermanent_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, small_int(ST_MAX_FRAMES), small_int(ST_CODE_COLS), + small_int(ST_TOTAL_COLS), small_int(ST_NOTES_START_COL), (ST_AS_COMMENT) ? sc->T : sc->F); /* -------- *#readers* -------- */ { - s7_pointer 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_safe_function (sc, "#", - g_sharp_readers_set, 2, 0, false, - "*#readers* setter")); + s7_pointer 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_safe_function(sc, "#", g_sharp_readers_set, 2, 0, false, "*#readers* setter")); } - sc->local_documentation_symbol= make_symbol (sc, "+documentation+", 15); - sc->local_signature_symbol = make_symbol (sc, "+signature+", 11); - sc->local_setter_symbol = make_symbol (sc, "+setter+", 8); - sc->local_iterator_symbol = make_symbol (sc, "+iterator+", 10); + sc->local_documentation_symbol = make_symbol(sc, "+documentation+", 15); + sc->local_signature_symbol = make_symbol(sc, "+signature+", 11); + sc->local_setter_symbol = make_symbol(sc, "+setter+", 8); + sc->local_iterator_symbol = make_symbol(sc, "+iterator+", 10); - init_features (sc); - init_setters (sc); + init_features(sc); + init_setters(sc); } #if !MS_WINDOWS -static pthread_mutex_t init_lock= PTHREAD_MUTEX_INITIALIZER; +static pthread_mutex_t init_lock = PTHREAD_MUTEX_INITIALIZER; #endif -s7_scheme* -s7_init (void) { - s7_scheme* sc; - static bool already_inited= false; +s7_scheme *s7_init(void) +{ + 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); + 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_scheme_char_tables (); - init_chars (); - init_strings (); - init_fx_function (); - init_catchers (); - init_starlet_immutable_field (); - init_leven (); - already_inited= true; - } + 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_scheme_char_tables(); + init_chars(); + init_strings(); + init_fx_function(); + init_catchers(); + init_starlet_immutable_field(); + init_leven(); + already_inited = true; + } #if S7_DEBUGGING - init_never_unheaped (); + init_never_unheaped(); #endif #if !MS_WINDOWS - pthread_mutex_unlock (&init_lock); + pthread_mutex_unlock(&init_lock); #endif - sc= (s7_scheme*) Calloc (1, sizeof (s7_scheme)); /* not malloc! */ + sc = (s7_scheme *)Calloc(1, sizeof(s7_scheme)); /* not malloc! */ #if S7_DEBUGGING || ((DISABLE_FILE_OUTPUT || POINTER_32) && (!WITH_GCC)) - if (!cur_sc) original_cur_sc= sc; - cur_sc= sc; + if (!cur_sc) original_cur_sc = sc; + cur_sc = sc; #endif - sc->overall_start_time= my_clock (); - sc->gc_off= true; /* sc->args and so on are not set yet, so a gc during init - -> segfault */ - sc->gc_in_progress= false; - sc->gc_stats = 0; - - sc->saved_pointers= - (void**) Malloc (INITIAL_SAVED_POINTERS_SIZE * sizeof (void*)); + sc->overall_start_time = my_clock(); + sc->gc_off = true; /* sc->args and so on are not set yet, so a gc during init -> segfault */ + sc->gc_in_progress = false; + 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->semipermanent_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_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->do_body_p = NULL; - sc->object_out_locked = false; - sc->has_openlets = true; - sc->is_expanding = true; - sc->accept_all_keyword_arguments= false; - sc->muffle_warnings = false; - sc->symbol_quote = 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->stop_at_error = true; - sc->reset_error_hook = false; - sc->current_distance= - (int32_t**) malloc ((LEVEN_MAX_LEN + 1) * sizeof (int32_t*)); - for (int32_t i= 0; i <= LEVEN_MAX_LEN; i++) - sc->current_distance[i]= - (int32_t*) malloc ((LEVEN_MAX_LEN + 1) * sizeof (int32_t)); - - 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, (SHOW_EVAL_OPS || S7_DEBUGGING) ? "#" : "#", - T_UNSPECIFIED); - - unique_car (sc->nil) = sc->unspecified; /* see op_if1 */ - unique_cdr (sc->nil) = sc->unspecified; - unique_cdr (sc->unspecified)= sc->unspecified; - - sc->t1_1= semipermanent_cons (sc, sc->unused, sc->nil, T_PAIR | T_IMMUTABLE); - sc->t2_2= semipermanent_cons (sc, sc->unused, sc->nil, T_PAIR | T_IMMUTABLE); - sc->t2_1= semipermanent_cons (sc, sc->unused, sc->t2_2, T_PAIR | T_IMMUTABLE); - sc->t3_3= semipermanent_cons (sc, sc->unused, sc->nil, T_PAIR | T_IMMUTABLE); - sc->t3_2= semipermanent_cons (sc, sc->unused, sc->t3_3, T_PAIR | T_IMMUTABLE); - sc->t3_1= semipermanent_cons (sc, sc->unused, sc->t3_2, T_PAIR | T_IMMUTABLE); - sc->t4_1= semipermanent_cons (sc, sc->unused, sc->t3_1, T_PAIR | T_IMMUTABLE); - sc->u1_1= semipermanent_cons (sc, sc->unused, sc->nil, - T_PAIR | T_IMMUTABLE); /* ulist */ - - sc->safe_lists[0]= sc->nil; - for (int32_t i= 1; i < NUM_SAFE_PRELISTS; i++) - sc->safe_lists[i]= semipermanent_list (sc, i); - for (int32_t i= NUM_SAFE_PRELISTS; i < NUM_SAFE_LISTS; i++) - sc->safe_lists[i]= sc->nil; - sc->current_safe_list= 0; + sc->saved_pointers_size = INITIAL_SAVED_POINTERS_SIZE; + + init_gc_caches(sc); + sc->semipermanent_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_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->do_body_p = NULL; + sc->object_out_locked = false; + sc->has_openlets = true; + sc->is_expanding = true; + sc->accept_all_keyword_arguments = false; + sc->muffle_warnings = false; + sc->symbol_quote = 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->stop_at_error = true; + sc->reset_error_hook = false; + sc->current_distance = (int32_t **)malloc((LEVEN_MAX_LEN + 1) * sizeof(int32_t *)); + for (int32_t i = 0; i <= LEVEN_MAX_LEN; i++) + sc->current_distance[i] = (int32_t *)malloc((LEVEN_MAX_LEN + 1) * sizeof(int32_t)); + + 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, (SHOW_EVAL_OPS || S7_DEBUGGING) ? "#" : "#", T_UNSPECIFIED); + + unique_car(sc->nil) = sc->unspecified; /* see op_if1 */ + unique_cdr(sc->nil) = sc->unspecified; + unique_cdr(sc->unspecified) = sc->unspecified; + + sc->t1_1 = semipermanent_cons(sc, sc->unused, sc->nil, T_PAIR | T_IMMUTABLE); + sc->t2_2 = semipermanent_cons(sc, sc->unused, sc->nil, T_PAIR | T_IMMUTABLE); + sc->t2_1 = semipermanent_cons(sc, sc->unused, sc->t2_2, T_PAIR | T_IMMUTABLE); + sc->t3_3 = semipermanent_cons(sc, sc->unused, sc->nil, T_PAIR | T_IMMUTABLE); + sc->t3_2 = semipermanent_cons(sc, sc->unused, sc->t3_3, T_PAIR | T_IMMUTABLE); + sc->t3_1 = semipermanent_cons(sc, sc->unused, sc->t3_2, T_PAIR | T_IMMUTABLE); + sc->t4_1 = semipermanent_cons(sc, sc->unused, sc->t3_1, T_PAIR | T_IMMUTABLE); + sc->u1_1 = semipermanent_cons(sc, sc->unused, sc->nil, T_PAIR | T_IMMUTABLE); /* ulist */ + + sc->safe_lists[0] = sc->nil; + for (int32_t i = 1; i < NUM_SAFE_PRELISTS; i++) + sc->safe_lists[i] = semipermanent_list(sc, i); + for (int32_t i = NUM_SAFE_PRELISTS; i < NUM_SAFE_LISTS; i++) + sc->safe_lists[i] = sc->nil; + sc->current_safe_list = 0; #if S7_DEBUGGING - local_memset ((void*) (sc->safe_list_uses), 0, NUM_SAFE_LISTS); + local_memset((void *)(sc->safe_list_uses), 0, NUM_SAFE_LISTS); #endif - 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->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; + sc->code = sc->nil; #if WITH_HISTORY - sc->eval_history1= semipermanent_list (sc, DEFAULT_HISTORY_SIZE); - sc->eval_history2= semipermanent_list (sc, DEFAULT_HISTORY_SIZE); - sc->history_pairs= semipermanent_list (sc, DEFAULT_HISTORY_SIZE); - sc->history_sink = semipermanent_list (sc, 1); - set_cdr_unchecked (sc->history_sink, sc->history_sink); + sc->eval_history1 = semipermanent_list(sc, DEFAULT_HISTORY_SIZE); + sc->eval_history2 = semipermanent_list(sc, DEFAULT_HISTORY_SIZE); + sc->history_pairs = semipermanent_list(sc, DEFAULT_HISTORY_SIZE); + sc->history_sink = semipermanent_list(sc, 1); + set_cdr_unchecked(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, semipermanent_list (sc, 1)); - set_car (p3, semipermanent_list (sc, 1)); - set_cdr_unchecked (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_unchecked (p1, sc->eval_history1); - set_cdr_unchecked (p2, sc->eval_history2); - sc->cur_code = sc->eval_history1; - sc->using_history1= true; - sc->old_cur_code = sc->cur_code; + for (p3 = sc->history_pairs; is_pair(cdr(p3)); p3 = cdr(p3)) set_car(p3, semipermanent_list(sc, 1)); + set_car(p3, semipermanent_list(sc, 1)); + set_cdr_unchecked(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_unchecked(p1, sc->eval_history1); + set_cdr_unchecked(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; + sc->cur_code = sc->F; #endif - sc->args = sc->nil; - sc->value = sc->nil; - sc->v = sc->unused; - sc->w = sc->unused; - sc->x = sc->unused; - sc->y = sc->unused; - sc->z = sc->unused; - sc->temp1 = sc->unused; - sc->temp2 = sc->unused; - sc->temp3 = sc->unused; - sc->temp4 = sc->unused; - sc->temp5 = sc->unused; - sc->temp6 = sc->unused; - sc->temp7 = sc->unused; - sc->temp8 = sc->unused; - sc->temp9 = sc->unused; - sc->rec_p1 = sc->unused; - sc->rec_p2 = sc->unused; - sc->read_dims= int_zero; - - 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; + sc->args = sc->nil; + sc->value = sc->nil; + sc->v = sc->unused; + sc->w = sc->unused; + sc->x = sc->unused; + sc->y = sc->unused; + sc->z = sc->unused; + sc->temp1 = sc->unused; + sc->temp2 = sc->unused; + sc->temp3 = sc->unused; + sc->temp4 = sc->unused; + sc->temp5 = sc->unused; + sc->temp6 = sc->unused; + sc->temp7 = sc->unused; + sc->temp8 = sc->unused; + sc->temp9 = sc->unused; + sc->rec_p1 = sc->unused; + sc->rec_p2 = sc->unused; + sc->read_dims = int_zero; + + 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 /* might not be defined, so we can't play games */ - sc->is_autoloading= false; + sc->is_autoloading = false; #else - sc->is_autoloading= true; + sc->is_autoloading = true; #endif - sc->max_show_stack_frames= 20; + sc->max_show_stack_frames = 20; - sc->heap_size= (INITIAL_HEAP_SIZE > 0) ? INITIAL_HEAP_SIZE : 64000; + sc->heap_size = (INITIAL_HEAP_SIZE > 0) ? INITIAL_HEAP_SIZE : 64000; if ((sc->heap_size % 32) != 0) - sc->heap_size= 32 * (s7_int) 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 + sc->heap_size); - sc->free_heap_trigger = (s7_cell**) (sc->free_heap + GC_TRIGGER_SIZE); - sc->previous_free_heap_top= sc->free_heap_top; + sc->heap_size = 32 * (s7_int)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 + sc->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= (s7_cell*) Malloc ( - sc->heap_size * sizeof (s7_cell)); /* was calloc 14-Apr-22 */ - add_saved_pointer (sc, (void*) cells); - for (int32_t i= 0; i < sc->heap_size; i++) /* LOOP_4 here is slower! */ - { - sc->heap[i] = &cells[i]; - sc->free_heap[i]= sc->heap[i]; + s7_cell *cells = (s7_cell *)Malloc(sc->heap_size * sizeof(s7_cell)); /* was calloc 14-Apr-22 */ + add_saved_pointer(sc, (void *)cells); + for (int32_t i = 0; i < sc->heap_size; i++) /* LOOP_4 here is slower! */ + { + sc->heap[i] = &cells[i]; + sc->free_heap[i] = sc->heap[i]; #if S7_DEBUGGING - sc->heap[i]->debugger_bits= 0; - sc->heap[i]->gc_line = 0; - sc->heap[i]->gc_func = NULL; - sc->heap[i]->uses = 0; + sc->heap[i]->debugger_bits = 0; sc->heap[i]->gc_line = 0; sc->heap[i]->gc_func = NULL; sc->heap[i]->uses = 0; #endif - clear_type (sc->heap[i]); /* type(sc->heap[i]) = T_FREE */ - i++; - sc->heap[i] = &cells[i]; - sc->free_heap[i]= sc->heap[i]; + clear_type(sc->heap[i]); /* type(sc->heap[i]) = T_FREE */ + i++; + sc->heap[i] = &cells[i]; + sc->free_heap[i] = sc->heap[i]; #if S7_DEBUGGING - sc->heap[i]->debugger_bits= 0; - sc->heap[i]->gc_line = 0; - sc->heap[i]->gc_func = NULL; - sc->heap[i]->uses = 0; + sc->heap[i]->debugger_bits = 0; sc->heap[i]->gc_line = 0; sc->heap[i]->gc_func = NULL; sc->heap[i]->uses = 0; #endif - clear_type (sc->heap[i]); - } - /* memcpy((void *)(sc->free_heap), (const void *)(sc->heap), - * sizeof(s7_pointer) * sc->heap_size); */ - /* weird that this memcpy (without the equivalent sets above) is much - * slower */ - 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 > 0) ? GC_TEMPS_SIZE : 256; - 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 << 45); - sc->gc_calls = 0; - sc->gc_true_calls = 0; - sc->gc_total_time = 0; - sc->gc_true_total_time = 0; - /* unvectorize free-heap? t_free obj nxt -> next in list, - * free_heap_top|length; get free: obj=free_heap_top; top=nxt; len-- push: - * cur->nxt=top, top=cur len++; trigger when lenheap[i]); + } + /* memcpy((void *)(sc->free_heap), (const void *)(sc->heap), sizeof(s7_pointer) * sc->heap_size); */ + /* weird that this memcpy (without the equivalent sets above) is much slower */ + 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 > 0) ? GC_TEMPS_SIZE : 256; + 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 << 45); + sc->gc_calls = 0; + sc->gc_true_calls = 0; + sc->gc_total_time = 0; + sc->gc_true_total_time = 0; + /* unvectorize free-heap? t_free obj nxt -> next in list, free_heap_top|length; get free: obj=free_heap_top; top=nxt; len-- + * push: cur->nxt=top, top=cur len++; trigger when lenmax_string_port_length = (1LL << 45); - sc->output_file_port_length= OUTPUT_FILE_PORT_LENGTH; + sc->output_file_port_length = OUTPUT_FILE_PORT_LENGTH; { - s7_int size= (INITIAL_PROTECTED_OBJECTS_SIZE > 0) - ? INITIAL_PROTECTED_OBJECTS_SIZE - : 2; - /* this has to precede s7_make_* allocations, need to protect against 0 here - * else segfault in g_multivector->gc_protect_2 */ - sc->protected_setters_size = size; - sc->protected_setters_loc = 0; - sc->protected_setters = make_vector_1 (sc, size, FILLED, T_VECTOR); - sc->protected_setter_symbols= make_vector_1 (sc, size, FILLED, T_VECTOR); - - sc->protected_objects_size = size; - sc->protected_objects_free_list= (s7_int*) Malloc (size * sizeof (s7_int)); - sc->protected_objects_free_list_loc= size - 1; - sc->protected_objects= make_vector_1 (sc, size, FILLED, T_VECTOR); - for (int32_t i= 0; i < 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->protected_objects_free_list[i] = i; - } - } - - sc->stack= make_vector_1 (sc, INITIAL_STACK_SIZE, FILLED, T_VECTOR); - /* if not_filled, segfault in gc_mark in mark_stack_1 after size check? - * probably unfilled OP_BARRIER etc? */ - sc->stack_start= vector_elements (sc->stack); /* stack type set below */ - sc->stack_end = sc->stack_start; + s7_int size = (INITIAL_PROTECTED_OBJECTS_SIZE > 0) ? INITIAL_PROTECTED_OBJECTS_SIZE : 2; + /* this has to precede s7_make_* allocations, need to protect against 0 here else segfault in g_multivector->gc_protect_2 */ + sc->protected_setters_size = size; + sc->protected_setters_loc = 0; + sc->protected_setters = make_vector_1(sc, size, FILLED, T_VECTOR); + sc->protected_setter_symbols = make_vector_1(sc, size, FILLED, T_VECTOR); + + sc->protected_objects_size = size; + sc->protected_objects_free_list = (s7_int *)Malloc(size * sizeof(s7_int)); + sc->protected_objects_free_list_loc = size - 1; + sc->protected_objects = make_vector_1(sc, size, FILLED, T_VECTOR); + for (int32_t i = 0; i < 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->protected_objects_free_list[i] = i; + }} + + sc->stack = make_vector_1(sc, INITIAL_STACK_SIZE, FILLED, T_VECTOR); + /* if not_filled, segfault in gc_mark in mark_stack_1 after size check? probably unfilled OP_BARRIER etc? */ + sc->stack_start = vector_elements(sc->stack); /* stack type set below */ + sc->stack_end = sc->stack_start; if (STACK_RESIZE_TRIGGER <= (INITIAL_STACK_SIZE / 2)) - sc->stack_size= INITIAL_STACK_SIZE; - else sc->stack_size= STACK_RESIZE_TRIGGER * 2; - 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); - initialize_recur_stack (sc); + sc->stack_size = INITIAL_STACK_SIZE; + else sc->stack_size = STACK_RESIZE_TRIGGER * 2; + 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); + initialize_recur_stack(sc); /* keep the symbol table out of the heap */ - sc->symbol_table= - (s7_pointer) Malloc (sizeof (s7_cell)); /* was calloc 14-Apr-22 */ - full_type (sc->symbol_table) = T_VECTOR | T_UNHEAP | T_SYMBOL_TABLE; - 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)= t_vector_getter; - vector_setter (sc->symbol_table)= t_vector_setter; - t_vector_fill (sc->symbol_table, sc->nil); + sc->symbol_table = (s7_pointer)Malloc(sizeof(s7_cell)); /* was calloc 14-Apr-22 */ + full_type(sc->symbol_table) = T_VECTOR | T_UNHEAP | T_SYMBOL_TABLE; + 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) = t_vector_getter; + vector_setter(sc->symbol_table) = t_vector_setter; + t_vector_fill(sc->symbol_table, sc->nil); { /* sc->opts */ - opt_info* os= (opt_info*) Malloc ( - OPTS_SIZE * sizeof (opt_info)); /* was calloc, 17-Oct-21 */ - add_saved_pointer (sc, os); - for (int32_t i= 0; i < OPTS_SIZE; i++) { - opt_info* o= &os[i]; - sc->opts[i]= o; - o->sc = sc; - } - } + opt_info *os = (opt_info *)Malloc(OPTS_SIZE * sizeof(opt_info)); /* was calloc, 17-Oct-21 */ + add_saved_pointer(sc, os); + for (int32_t i = 0; i < OPTS_SIZE; i++) + { + opt_info *o = &os[i]; + sc->opts[i] = o; + o->sc = sc; + }} - for (int32_t i= 0; i < NUM_TYPES; i++) - sc->type_names[i]= s7_make_semipermanent_string ( - sc, (const char*) type_name_from_type (i, indefinite_article)); + for (int32_t i = 0; i < NUM_TYPES; i++) + sc->type_names[i] = s7_make_semipermanent_string(sc, (const char *)type_name_from_type(i, indefinite_article)); #if WITH_MULTITHREAD_CHECKS - sc->lock_count= 0; + 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); + 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->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->number_separator = '\0'; - sc->default_hash_table_length= 8; - sc->iterator_at_end_value = eof_object; - sc->scheme_version = make_symbol (sc, "s7", 2); - sc->gensym_counter = 0; - sc->capture_let_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->profile_position = 0; - sc->debug_or_profile = false; - sc->profiling_gensyms = false; - sc->profile_data = NULL; - sc->profile_prefix = sc->F; - sc->print_length = DEFAULT_PRINT_LENGTH; - sc->history_size = DEFAULT_HISTORY_SIZE; - sc->true_history_size = DEFAULT_HISTORY_SIZE; - sc->baffle_ctr = 0; - sc->map_call_ctr = 0; - sc->big_symbol_tag = 0; - sc->small_symbol_tag = 1; + sc->float_format_precision = WRITE_REAL_PRECISION; + sc->number_separator = '\0'; + sc->default_hash_table_length = 8; + sc->iterator_at_end_value = eof_object; + sc->scheme_version = make_symbol(sc, "s7", 2); + sc->gensym_counter = 0; + sc->capture_let_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->profile_position = 0; + sc->debug_or_profile = false; + sc->profiling_gensyms = false; + sc->profile_data = NULL; + sc->profile_prefix = sc->F; + sc->print_length = DEFAULT_PRINT_LENGTH; + sc->history_size = DEFAULT_HISTORY_SIZE; + sc->true_history_size = DEFAULT_HISTORY_SIZE; + sc->baffle_ctr = 0; + sc->map_call_ctr = 0; + sc->big_symbol_tag = 0; + sc->small_symbol_tag = 1; #if S7_DEBUGGING - sc->big_symbol_set_state = set_ignore; - sc->small_symbol_set_state= set_ignore; - sc->y_line = 0; - sc->v_line = 0; + sc->big_symbol_set_state = set_ignore; + sc->small_symbol_set_state = set_ignore; + sc->y_line = 0; + sc->v_line = 0; sc->c_functions_allocated = 0; #endif - sc->symbol_printer = sc->F; - sc->class_name_symbol= make_symbol (sc, "class-name", 10); - sc->name_symbol = make_symbol (sc, "name", 4); - sc->trace_in_symbol = make_symbol (sc, "trace-in", 8); - sc->size_symbol = make_symbol (sc, "size", 4); - sc->is_mutable_symbol= make_symbol (sc, "mutable?", 8); - sc->file__symbol = make_symbol (sc, "FILE*", 5); - sc->circle_info = make_shared_info (sc); - sc->fdats = (format_data_t**) Malloc (8 * sizeof (format_data_t*)); - sc->num_fdats = 8; - for (int32_t k= 0; k < 8; k++) - sc->fdats[k]= make_fdat (sc); - sc->mlist_1 = semipermanent_list (sc, 1); - sc->mlist_2 = semipermanent_list (sc, 2); - sc->plist_1 = semipermanent_list (sc, 1); - sc->plist_2 = semipermanent_list (sc, 2); - sc->plist_2_2= cdr (sc->plist_2); - sc->plist_3 = semipermanent_list (sc, 3); - sc->plist_4= - semipermanent_cons (sc, sc->unused, sc->plist_3, T_PAIR | T_IMMUTABLE); - sc->qlist_2= semipermanent_list (sc, 2); - sc->qlist_3= - semipermanent_cons (sc, sc->unused, sc->qlist_2, T_PAIR | T_IMMUTABLE); - sc->clist_1= semipermanent_list (sc, 1); - sc->clist_2= semipermanent_list (sc, 2); - sc->dlist_1= semipermanent_list (sc, 1); - sc->elist_1= semipermanent_cons (sc, sc->unused, sc->nil, - T_PAIR | T_IMMUTABLE | T_IS_ELIST); - sc->elist_2= semipermanent_list (sc, 2); - set_is_elist (sc->elist_2); - sc->elist_3= semipermanent_list (sc, 3); - set_is_elist (sc->elist_3); - sc->elist_4= semipermanent_cons (sc, sc->unused, sc->elist_3, - T_PAIR | T_IMMUTABLE | T_IS_ELIST); - sc->elist_5= semipermanent_cons (sc, sc->unused, sc->elist_4, - T_PAIR | T_IMMUTABLE | T_IS_ELIST); - sc->elist_6= semipermanent_cons (sc, sc->unused, sc->elist_5, - T_PAIR | T_IMMUTABLE | T_IS_ELIST); - sc->elist_7= semipermanent_cons (sc, sc->unused, sc->elist_6, - T_PAIR | T_IMMUTABLE | T_IS_ELIST); - 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->symbol_printer = sc->F; + sc->class_name_symbol = make_symbol(sc, "class-name", 10); + sc->name_symbol = make_symbol(sc, "name", 4); + sc->trace_in_symbol = make_symbol(sc, "trace-in", 8); + sc->size_symbol = make_symbol(sc, "size", 4); + sc->is_mutable_symbol = make_symbol(sc, "mutable?", 8); + sc->file__symbol = make_symbol(sc, "FILE*", 5); + sc->circle_info = make_shared_info(sc); + sc->fdats = (format_data_t **)Malloc(8 * sizeof(format_data_t *)); + sc->num_fdats = 8; + for (int32_t k = 0; k < 8; k++) sc->fdats[k] = make_fdat(sc); + sc->mlist_1 = semipermanent_list(sc, 1); + sc->mlist_2 = semipermanent_list(sc, 2); + sc->plist_1 = semipermanent_list(sc, 1); + sc->plist_2 = semipermanent_list(sc, 2); + sc->plist_2_2 = cdr(sc->plist_2); + sc->plist_3 = semipermanent_list(sc, 3); + sc->plist_4 = semipermanent_cons(sc, sc->unused, sc->plist_3, T_PAIR | T_IMMUTABLE); + sc->qlist_2 = semipermanent_list(sc, 2); + sc->qlist_3 = semipermanent_cons(sc, sc->unused, sc->qlist_2, T_PAIR | T_IMMUTABLE); + sc->clist_1 = semipermanent_list(sc, 1); + sc->clist_2 = semipermanent_list(sc, 2); + sc->dlist_1 = semipermanent_list(sc, 1); + sc->elist_1 = semipermanent_cons(sc, sc->unused, sc->nil, T_PAIR | T_IMMUTABLE | T_IS_ELIST); + sc->elist_2 = semipermanent_list(sc, 2); set_is_elist(sc->elist_2); + sc->elist_3 = semipermanent_list(sc, 3); set_is_elist(sc->elist_3); + sc->elist_4 = semipermanent_cons(sc, sc->unused, sc->elist_3, T_PAIR | T_IMMUTABLE | T_IS_ELIST); + sc->elist_5 = semipermanent_cons(sc, sc->unused, sc->elist_4, T_PAIR | T_IMMUTABLE | T_IS_ELIST); + sc->elist_6 = semipermanent_cons(sc, sc->unused, sc->elist_5, T_PAIR | T_IMMUTABLE | T_IS_ELIST); + sc->elist_7 = semipermanent_cons(sc, sc->unused, sc->elist_6, T_PAIR | T_IMMUTABLE | T_IS_ELIST); + 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->objstr_max_len = S7_INT64_MAX; - sc->temp_error_hook = sc->nil; - sc->anon_symbol = make_symbol (sc, "anonymous-lambda", 16); - - sc->s7_symbol = make_symbol (sc, "s7", 2); - sc->r5rs_symbol= make_symbol (sc, "r5rs", 4); - sc->r7rs_symbol= make_symbol (sc, "r7rs", 4); - - sc->rootlet= alloc_pointer (sc); - set_full_type (sc->rootlet, T_LET | T_SAFE_PROCEDURE | T_UNHEAP); - let_set_id (sc->rootlet, -1); - let_set_outlet (sc->rootlet, NULL); - let_set_slots (sc->rootlet, slot_end); - add_semipermanent_let_or_slot (sc, sc->rootlet); - sc->rootlet_slots= slot_end; - set_curlet (sc, sc->rootlet); - sc->shadow_rootlet= sc->rootlet; + sc->objstr_max_len = S7_INT64_MAX; + sc->temp_error_hook = sc->nil; + sc->anon_symbol = make_symbol(sc, "anonymous-lambda", 16); + + sc->s7_symbol = make_symbol(sc, "s7", 2); + sc->r5rs_symbol = make_symbol(sc, "r5rs", 4); + sc->r7rs_symbol = make_symbol(sc, "r7rs", 4); + + sc->rootlet = alloc_pointer(sc); + set_full_type(sc->rootlet, T_LET | T_SAFE_PROCEDURE | T_UNHEAP); + let_set_id(sc->rootlet, -1); + let_set_outlet(sc->rootlet, NULL); + let_set_slots(sc->rootlet, slot_end); + add_semipermanent_let_or_slot(sc, sc->rootlet); + sc->rootlet_slots = slot_end; + set_curlet(sc, sc->rootlet); + sc->shadow_rootlet = sc->rootlet; sc->unlet_entries = NULL; - init_wrappers (sc); - init_standard_ports (sc); - init_rootlet (sc); - init_open_input_function_choices (sc); + init_wrappers(sc); + init_standard_ports(sc); + init_rootlet(sc); + init_open_input_function_choices(sc); { s7_pointer rs; - new_cell (sc, rs, T_RANDOM_STATE); /* s7_set_default_random_state might set - sc->default_random_state, so this - shouldn't be permanent */ - sc->default_random_state= rs; - random_seed (rs) = (uint64_t) - my_clock (); /* used to be time(NULL), but that means separate threads - can get the same random number sequence */ - random_carry (rs)= 1675393560; - } - - sc->pi_symbol= s7_define_constant (sc, "pi", real_pi); - - for (int32_t 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); + new_cell(sc, rs, T_RANDOM_STATE); /* s7_set_default_random_state might set sc->default_random_state, so this shouldn't be permanent */ + sc->default_random_state = rs; + random_seed(rs) = (uint64_t)my_clock(); /* used to be time(NULL), but that means separate threads can get the same random number sequence */ + random_carry(rs) = 1675393560; + } + + sc->pi_symbol = s7_define_constant(sc, "pi", real_pi); + + for (int32_t 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); #if S7_DEBUGGING - init_tc_rec (sc); + init_tc_rec(sc); #endif - s7_set_history_enabled (sc, false); /* see below */ - init_signatures (sc); /* depends on procedure symbols */ - sc->starlet= make_starlet (sc); - s7_set_history_enabled (sc, true); - - s7_eval_c_string ( - sc, - "(define make-hook \n\ + s7_set_history_enabled(sc, false); /* see below */ + init_signatures(sc); /* depends on procedure symbols */ + sc->starlet = make_starlet(sc); + s7_set_history_enabled(sc, true); + + s7_eval_c_string(sc, "(define make-hook \n\ (let ((+documentation+ \"(make-hook . pars) returns a new hook (a function) that passes that hook to each function in its function list.\")) \n\ (lambda hook-args \n\ (let ((body ())) ; list of functions \n\ @@ -107409,116 +81914,79 @@ s7_init (void) { (let ((hook (openlet (sublet (curlet) 'let-ref-fallback #)))) \n\ (for-each (lambda (func) (func hook)) body) \n\ result))))))))"); - /* (procedure-source (make-hook 'x 'y)): (lambda* (x y) (let ((result - * #)) ... result)), see stuff.scm for commentary - * '((when (pair? body) ...) at start might be a good idea -- depends on how - * often an empty hook is called moving make-hook to C (see tmphook) was a lot - * of code and did not save anything at start-up (20/1750 in callgrind, ca 1%) + /* (procedure-source (make-hook 'x 'y)): (lambda* (x y) (let ((result #)) ... result)), see stuff.scm for commentary + * '((when (pair? body) ...) at start might be a good idea -- depends on how often an empty hook is called + * moving make-hook to C (see tmphook) was a lot of code and did not save anything at start-up (20/1750 in callgrind, ca 1%) */ /* -------- *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)."); + 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"); + 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"); /* -------- *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)."); + 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)."); /* -------- *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)"); + 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))"); + 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))"); /* -------- *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)."); + 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)."); + 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)."); /* -------- *exit-hook* -------- */ - sc->exit_hook= s7_eval_c_string (sc, "(make-hook 'code)"); - s7_define_constant_with_documentation ( - sc, "*exit-hook*", sc->exit_hook, - "*exit-hook* functions are called when exit is invoked, passed the exit " - "code as (hook 'code)."); + sc->exit_hook = s7_eval_c_string(sc, "(make-hook 'code)"); + s7_define_constant_with_documentation(sc, "*exit-hook*", sc->exit_hook, + "*exit-hook* functions are called when exit is invoked, passed the exit code as (hook 'code)."); - sc->temp_error_hook= s7_eval_c_string (sc, "(make-hook 'type 'data)"); - /* internal; this is holding error-hook functions during an evaluation where - * error-hook is temporarily nil -- do we actually need a hook for this? */ + sc->temp_error_hook = s7_eval_c_string(sc, "(make-hook 'type 'data)"); + /* internal; this is holding error-hook functions during an evaluation where error-hook is temporarily nil -- do we actually need a hook for this? */ #if !WITH_PURE_S7 { - s7_pointer rs= s7_define_variable (sc, "make-rectangular", - global_value (sc->complex_symbol)); - set_initial_value ( - rs, initial_value (sc->complex_symbol)); /* for #_make-rectangular */ + s7_pointer rs = s7_define_variable(sc, "make-rectangular", global_value(sc->complex_symbol)); + set_initial_value(rs, initial_value(sc->complex_symbol)); /* for #_make-rectangular */ } - 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 (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) (list (cons 'lambda (cons vars body)) expression))"); + s7_eval_c_string(sc, "(define-macro (multiple-value-bind vars expression . body) (list (cons 'lambda (cons vars body)) expression))"); - /* call-with-values, make-hook and multiple-value-bind can't set the - * initial_value to the global_value so that #_... can be used because the - * global_value is not semipermanent, but could it be made so? (via - * remove_from_heap?) or set it anyway, and assume user won't set! the global - * value causing the initial-value to be GC'd + /* call-with-values, make-hook and multiple-value-bind can't set the initial_value to the global_value + * so that #_... can be used because the global_value is not semipermanent, but could it be made so? (via remove_from_heap?) + * or set it anyway, and assume user won't set! the global value causing the initial-value to be GC'd */ #endif #if S7_DEBUGGING - s7_define_function (sc, "report-missed-calls", g_report_missed_calls, 0, 0, - false, NULL); /* tc/recur tests in s7test.scm */ - 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 != 913) - 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)); + s7_define_function(sc, "report-missed-calls", g_report_missed_calls, 0, 0, false, NULL); /* tc/recur tests in s7test.scm */ + 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 != 913) 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 */ - if (!s7_type_names[0]) { - fprintf (stderr, "no type_names\n"); - gdb_break (); - } /* squelch very stupid warnings! */ - if (POINTER_32) fprintf (stderr, "pointer 32!?\n"); + if (!s7_type_names[0]) {fprintf(stderr, "no type_names\n"); gdb_break();} /* squelch very stupid warnings! */ + if (POINTER_32) fprintf(stderr, "pointer 32!?\n"); #endif #if 0 /* sizes: c_proc_t 104, c_object_t[i.e. type, not the c_object] 160, vunion: 8, port_t 88, block_t 40, port_functions_t 80, s7_cell 48/120, s7 11440/12280, opt_info 128 */ @@ -107527,279 +81995,252 @@ s7_init (void) { (int)sizeof(block_t), (int)sizeof(port_functions_t), (int)sizeof(s7_cell), (int)sizeof(s7_scheme), (int)sizeof(opt_info)); #endif - return (sc); + return(sc); } + /* -------------------------------- s7_free -------------------------------- */ -static void -gc_list_free (gc_list_t* g) { - free (g->list); - free (g); +static void gc_list_free(gc_list_t *g) +{ + free(g->list); + free(g); } -static void -big_block_free (s7_scheme* sc, block_t* block) { - if ((block_index (block) == TOP_BLOCK_LIST) && (block_data (block))) { - free (block_data (block)); - block_data (block)= NULL; - } +static void big_block_free(s7_scheme *sc, block_t *block) +{ + if ((block_index(block) == TOP_BLOCK_LIST) && (block_data(block))) + { + free(block_data(block)); + block_data(block) = NULL; + } } -void -s7_free (s7_scheme* sc) { - /* free the memory associated with sc (not globals since we might have - * multiple s7 interpreters running) 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=no - * --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 +void s7_free(s7_scheme *sc) +{ + /* free the memory associated with sc (not globals since we might have multiple s7 interpreters running) + * 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=no --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 */ - gc_list_t* gp; + gc_list_t *gp; /* g_gc(sc, sc->nil); */ /* probably not needed (my simple tests work fine if the gc call is omitted) */ /* removed 14-Apr-22 */ - /* s7_quit(sc); */ /* not always needed -- will clean up the C stack if - we haven't returned to the top level */ - - gp= call_c_object_frees ( - sc); /* do this first since they might involve gc_unprotect etc */ - gc_list_free (gp); - - gp= sc->vectors; - for (s7_int i= 0; i < gp->loc; i++) - if (block_index (vector_block_unchecked (gp->list[i])) == TOP_BLOCK_LIST) - free (block_data (vector_block_unchecked (gp->list[i]))); - gc_list_free (gp); - gc_list_free (sc->multivectors); /* I assume vector_dimension_info won't need - 131072 bytes */ - - gp= sc->strings; - for (s7_int i= 0; i < gp->loc; i++) - if (block_index (string_block_unchecked (gp->list[i])) == TOP_BLOCK_LIST) - free (block_data (string_block_unchecked (gp->list[i]))); - gc_list_free (gp); - - gp= sc->output_ports; - for (s7_int i= 0; i < gp->loc; i++) { - if ((port_data_block_unchecked (gp->list[i])) && - (block_index (port_data_block_unchecked (gp->list[i])) == - TOP_BLOCK_LIST)) - free (block_data (port_data_block_unchecked ( - 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])); - } - gc_list_free (gp); - - gp= sc->input_ports; - for (s7_int i= 0; i < gp->loc; i++) - if ((port_data_block_unchecked (gp->list[i])) && - (block_index (port_data_block_unchecked (gp->list[i])) == - TOP_BLOCK_LIST)) - free (block_data (port_data_block_unchecked ( - gp->list[i]))); /* the file contents, port_block is other stuff */ - gc_list_free (gp); - gc_list_free (sc->input_string_ports); /* port_data_block is null, port_block - is the const char *data, so I assume - it is handled elsewhere */ - - gp= sc->hash_tables; - for (s7_int i= 0; i < gp->loc; i++) - if (block_index (hash_table_block_unchecked (gp->list[i])) == - TOP_BLOCK_LIST) - free (block_data (hash_table_block_unchecked (gp->list[i]))); - gc_list_free (gp); - - free (undefined_name (sc->undefined)); - gp= sc->undefineds; - for (s7_int i= 0; i < gp->loc; i++) - free (undefined_name (gp->list[i])); - gc_list_free (gp); - - gc_list_free (sc->gensyms); - gc_list_free (sc->continuations); /* stack is simple vector (handled above) */ - gc_list_free (sc->weak_refs); - gc_list_free (sc->weak_hash_iterators); - gc_list_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) { - for (s7_int i= 0; i < sc->autoload_names_loc; i++) - if (sc->autoloaded_already[i]) free (sc->autoloaded_already[i]); - free (sc->autoloaded_already); - } - for (block_t* top= sc->block_lists[TOP_BLOCK_LIST]; top; - top = block_next (top)) - if (block_data (top)) free (block_data (top)); - - big_block_free (sc, stack_block (sc->stack)); - big_block_free (sc, vector_block (sc->protected_objects)); - for (s7_int i= 0; i < sc->saved_pointers_loc; i++) - free (sc->saved_pointers[i]); - free (sc->saved_pointers); - { - gc_obj_t* gnxt; - heap_block_t* hpnxt; - for (gc_obj_t* g= sc->semipermanent_lets; g; g= gnxt) { - gnxt= g->nxt; - free (g); - } - for (gc_obj_t* g= sc->semipermanent_objects; g; g= gnxt) { - gnxt= g->nxt; - free (g); - } - for (heap_block_t* hp= sc->heap_blocks; hp; hp= hpnxt) { - hpnxt= hp->next; - free (hp); + /* s7_quit(sc); */ /* not always needed -- will clean up the C stack if we haven't returned to the top level */ + + gp = call_c_object_frees(sc); /* do this first since they might involve gc_unprotect etc */ + gc_list_free(gp); + + gp = sc->vectors; + for (s7_int i = 0; i < gp->loc; i++) + if (block_index(vector_block_unchecked(gp->list[i])) == TOP_BLOCK_LIST) + free(block_data(vector_block_unchecked(gp->list[i]))); + gc_list_free(gp); + gc_list_free(sc->multivectors); /* I assume vector_dimension_info won't need 131072 bytes */ + + gp = sc->strings; + for (s7_int i = 0; i < gp->loc; i++) + if (block_index(string_block_unchecked(gp->list[i])) == TOP_BLOCK_LIST) + free(block_data(string_block_unchecked(gp->list[i]))); + gc_list_free(gp); + + gp = sc->output_ports; + for (s7_int i = 0; i < gp->loc; i++) + { + if ((port_data_block_unchecked(gp->list[i])) && + (block_index(port_data_block_unchecked(gp->list[i])) == TOP_BLOCK_LIST)) + free(block_data(port_data_block_unchecked(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])); } - } + gc_list_free(gp); - 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->setters); - free (sc->op_stack); - if (sc->tree_pointers) free (sc->tree_pointers); - free (sc->num_to_str); - free (sc->protected_objects_free_list); - if (sc->read_line_buf) free (sc->read_line_buf); - free (sc->strbuf); - free_shared_info (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 (s7_int i= 0; i <= LEVEN_MAX_LEN; i++) - free (sc->current_distance[i]); - free (sc->current_distance); - - for (s7_int 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->let_names); - free (sc->profile_data->files); - free (sc->profile_data->lines); - free (sc->profile_data->excl); - free (sc->profile_data->timing_data); - free (sc->profile_data); - } - if (sc->c_object_types) { - for (s7_int i= 0; i < sc->num_c_object_types; i++) { - c_object_t* c_type= sc->c_object_types[i]; - if (c_type->scheme_name) { - free (c_type->scheme_name); - c_type->scheme_name= NULL; + gp = sc->input_ports; + for (s7_int i = 0; i < gp->loc; i++) + if ((port_data_block_unchecked(gp->list[i])) && + (block_index(port_data_block_unchecked(gp->list[i])) == TOP_BLOCK_LIST)) + free(block_data(port_data_block_unchecked(gp->list[i]))); /* the file contents, port_block is other stuff */ + gc_list_free(gp); + gc_list_free(sc->input_string_ports); /* port_data_block is null, port_block is the const char *data, so I assume it is handled elsewhere */ + + gp = sc->hash_tables; + for (s7_int i = 0; i < gp->loc; i++) + if (block_index(hash_table_block_unchecked(gp->list[i])) == TOP_BLOCK_LIST) + free(block_data(hash_table_block_unchecked(gp->list[i]))); + gc_list_free(gp); + + + free(undefined_name(sc->undefined)); + gp = sc->undefineds; + for (s7_int i = 0; i < gp->loc; i++) + free(undefined_name(gp->list[i])); + gc_list_free(gp); + + gc_list_free(sc->gensyms); + gc_list_free(sc->continuations); /* stack is simple vector (handled above) */ + gc_list_free(sc->weak_refs); + gc_list_free(sc->weak_hash_iterators); + gc_list_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) + { + for (s7_int i = 0; i < sc->autoload_names_loc; i++) + if (sc->autoloaded_already[i]) free(sc->autoloaded_already[i]); + free(sc->autoloaded_already); + } + for (block_t *top = sc->block_lists[TOP_BLOCK_LIST]; top; top = block_next(top)) + if (block_data(top)) + free(block_data(top)); + + big_block_free(sc, stack_block(sc->stack)); + big_block_free(sc, vector_block(sc->protected_objects)); + for (s7_int i = 0; i < sc->saved_pointers_loc; i++) + free(sc->saved_pointers[i]); + free(sc->saved_pointers); + { + gc_obj_t *gnxt; + heap_block_t *hpnxt; + for (gc_obj_t *g = sc->semipermanent_lets; g; g = gnxt) {gnxt = g->nxt; free(g);} + for (gc_obj_t *g = sc->semipermanent_objects; g; g = gnxt) {gnxt = g->nxt; free(g);} + for (heap_block_t *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->setters); + free(sc->op_stack); + if (sc->tree_pointers) free(sc->tree_pointers); + free(sc->num_to_str); + free(sc->protected_objects_free_list); + if (sc->read_line_buf) free(sc->read_line_buf); + free(sc->strbuf); + free_shared_info(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 (s7_int i = 0; i <= LEVEN_MAX_LEN; i++) free(sc->current_distance[i]); + free(sc->current_distance); + + for (s7_int 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 (c_type); + free(sc->fdats); + + if (sc->profile_data) + { + free(sc->profile_data->funcs); + free(sc->profile_data->let_names); + free(sc->profile_data->files); + free(sc->profile_data->lines); + free(sc->profile_data->excl); + free(sc->profile_data->timing_data); + free(sc->profile_data); + } + if (sc->c_object_types) + { + for (s7_int i = 0; i < sc->num_c_object_types; i++) + { + c_object_t *c_type = sc->c_object_types[i]; + if (c_type->scheme_name) {free(c_type->scheme_name); c_type->scheme_name = NULL;} + free(c_type); + } + free(sc->c_object_types); } - free (sc->c_object_types); - } #if S7_DEBUGGING || ((DISABLE_FILE_OUTPUT || POINTER_32) && (!WITH_GCC)) - if (sc == cur_sc) cur_sc= original_cur_sc; + if (sc == cur_sc) cur_sc = original_cur_sc; #endif - free (sc); + free(sc); } + /* -------------------------------- repl -------------------------------- */ #ifndef USE_SND -#define USE_SND 0 + #define USE_SND 0 #endif #ifndef WITH_MAIN -#define WITH_MAIN 0 + #define WITH_MAIN 0 #endif #if WITH_MAIN && WITH_NOTCURSES -#include "nrepl.c" -/* gcc -o nrepl s7.c -O2 -I. -Wl,-export-dynamic -lm -ldl -DWITH_MAIN - * -DWITH_NOTCURSES -lnotcurses-core */ + #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"); +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) { +void s7_repl(s7_scheme *sc) +{ #if !WITH_C_LOADER - dumb_repl (sc); + dumb_repl(sc); #else #if WITH_NOTCURSES - s7_load (sc, "nrepl.scm"); + s7_load(sc, "nrepl.scm"); #else /* 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 + * otherwise repl.scm will try to load libc.scm which will try to build libc_s7.so locally, but that requires s7.h */ #if WITH_SYSTEM_EXTRAS - bool repl_loaded= false; + bool repl_loaded = false; #endif - const s7_pointer let= - s7_inlet (sc, set_clist_2 (sc, make_symbol (sc, "init_func", 9), - make_symbol (sc, "libc_s7_init", 12))); - const s7_int gc_loc= gc_protect_1 (sc, let); - const s7_pointer old_let= - s7_set_curlet (sc, let); /* let is now (curlet) so loaded names from libc - will be placed there, not in (rootlet) */ - const s7_pointer val= s7_load_with_environment (sc, "libc_s7.so", let); - if (val) { - s7_pointer libs= global_slot (sc->libraries_symbol); - s7_uint hash= - raw_string_hash ((const uint8_t*) "*libc*", - 6); /* hack around an idiotic gcc 10.2.1 warning */ - s7_define (sc, sc->rootlet, - new_symbol (sc, "*libc*", 6, hash, hash % SYMBOL_TABLE_SIZE), - let); - slot_set_value ( - libs, - cons (sc, cons (sc, s7_make_semipermanent_string (sc, "libc.scm"), let), - slot_value (libs))); - } - s7_set_curlet (sc, old_let); /* restore incoming (curlet) */ - s7_gc_unprotect_at (sc, gc_loc); + const s7_pointer let = s7_inlet(sc, set_clist_2(sc, make_symbol(sc, "init_func", 9), make_symbol(sc, "libc_s7_init", 12))); + const s7_int gc_loc = gc_protect_1(sc, let); + const s7_pointer old_let = s7_set_curlet(sc, let); /* let is now (curlet) so loaded names from libc will be placed there, not in (rootlet) */ + const s7_pointer val = s7_load_with_environment(sc, "libc_s7.so", let); + if (val) + { + s7_pointer libs = global_slot(sc->libraries_symbol); + s7_uint hash = raw_string_hash((const uint8_t *)"*libc*", 6); /* hack around an idiotic gcc 10.2.1 warning */ + s7_define(sc, sc->rootlet, new_symbol(sc, "*libc*", 6, hash, hash % SYMBOL_TABLE_SIZE), let); + slot_set_value(libs, cons(sc, cons(sc, s7_make_semipermanent_string(sc, "libc.scm"), let), slot_value(libs))); + } + s7_set_curlet(sc, old_let); /* restore incoming (curlet) */ + s7_gc_unprotect_at(sc, gc_loc); #if !WITH_SYSTEM_EXTRAS - dumb_repl (sc); /* repl.scm uses file-exists? et al */ + dumb_repl(sc); /* repl.scm uses file-exists? et al */ #else if (!val) /* s7_load was unable to find/load libc_s7.so */ - dumb_repl (sc); - else { + dumb_repl(sc); + else + { #if S7_DEBUGGING - s7_autoload (sc, make_symbol (sc, "compare-calls", 13), - s7_make_string (sc, "compare-calls.scm")); - s7_autoload (sc, make_symbol (sc, "get-overheads", 13), - s7_make_string (sc, "compare-calls.scm")); + s7_autoload(sc, make_symbol(sc, "compare-calls", 13), s7_make_string(sc, "compare-calls.scm")); + s7_autoload(sc, make_symbol(sc, "get-overheads", 13), 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))"); - } + s7_provide(sc, "libc.scm"); + if (!repl_loaded) s7_load(sc, "repl.scm"); + s7_eval_c_string(sc, "((*repl* 'run))"); + } #endif /* S7_DEBUGGING */ #endif /* WITH_NOTCURSES */ #endif /* WITH_C_LOADER */ @@ -107808,91 +82249,83 @@ s7_repl (s7_scheme* sc) { #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. +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 (!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); + 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= s7_init (); - fprintf (stderr, "s7: %s\n", S7_DATE); +int main(int argc, char **argv) +{ + s7_scheme *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); + 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 - char* dir= realdir (argv[0]); - if (dir) { - s7_add_to_load_path (sc, dir); - free (dir); - } -#endif - s7_repl (sc); + #ifdef S7_LOAD_PATH + s7_add_to_load_path(sc, S7_LOAD_PATH); + #else + char *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 ; also need libc.scm cload.scm repl.scm to get a decent - * repl in *BSD: gcc s7.c -o repl -DWITH_MAIN -I. -O2 -g -lm - * -Wl,-export-dynamic in OSX: clang s7.c -o repl -DWITH_MAIN -I. -O2 -g -lm - * in msys2: gcc s7.c -o s7 -DWITH_MAIN -I. -O2 -g -ldl -lm - * -Wl,-export-all-symbols,--out-implib,s7.lib for tcc: tcc -o s7 s7.c -I. -lm - * -DWITH_MAIN -ldl -rdynamic -DWITH_C_LOADER for nrepl: gcc s7.c -o repl - * -DWITH_MAIN -DWITH_NOTCURSES -I. -O2 -g -lnotcurses-core -ldl -lm - * -Wl,-export-dynamic according to callgrind, clang is noticeably slower than - * gcc + } + return(0); +} + +/* in Linux: gcc s7.c -o repl -DWITH_MAIN -I. -O2 -g -ldl -lm -Wl,-export-dynamic ; also need libc.scm cload.scm repl.scm to get a decent repl + * in *BSD: gcc s7.c -o repl -DWITH_MAIN -I. -O2 -g -lm -Wl,-export-dynamic + * in OSX: clang s7.c -o repl -DWITH_MAIN -I. -O2 -g -lm + * in msys2: gcc s7.c -o s7 -DWITH_MAIN -I. -O2 -g -ldl -lm -Wl,-export-all-symbols,--out-implib,s7.lib + * for tcc: tcc -o s7 s7.c -I. -lm -DWITH_MAIN -ldl -rdynamic -DWITH_C_LOADER + * for nrepl: gcc s7.c -o repl -DWITH_MAIN -DWITH_NOTCURSES -I. -O2 -g -lnotcurses-core -ldl -lm -Wl,-export-dynamic + * according to callgrind, clang is noticeably slower than gcc * * (s7.c compile time 49 secs on x86 Linux, 16 secs on M4 OSX) - * musl works, but there is some problem in libgsl.scm with gsl/gsl_blas.h I - * think + * musl works, but there is some problem in libgsl.scm with gsl/gsl_blas.h I think * - * g++ s7.c -c -I. -g -O2 -Wall -Wextra -Wno-unused-parameter - * -Wno-implicit-fallthrough valgrind --leak-check=full --show-reachable=no - * --suppressions=/home/bil/cl/free.supp repl s7test.scm addr2line -e repl - * 0xd7237 -> s7.c:29697 6-May-25: cloc: blank 8773, comment 4007, code 88585, - * [gmp: ~5600, s7_debugging: ~2900 see search.scm] -> ca 80000 lines of code - * normally + * g++ s7.c -c -I. -g -O2 -Wall -Wextra -Wno-unused-parameter -Wno-implicit-fallthrough + * valgrind --leak-check=full --show-reachable=no --suppressions=/home/bil/cl/free.supp repl s7test.scm + * addr2line -e repl 0xd7237 -> s7.c:29697 + * 6-May-25: cloc: blank 8773, comment 4007, code 88585, [gmp: ~5600, s7_debugging: ~2900 see search.scm] -> ca 80000 lines of code normally */ #endif #endif @@ -107935,10 +82368,12 @@ main (int argc, char** argv) { * tnum 6013 5396 5402 5394 * concordance 10.0 6095 5165 5345 5422 * tlist 9219 7546 6240 5770 5793 - * tari 14.3 12.5 6662 6292 5997 6085 [gc opt_if_b7p - * opt_p_pi_ss_fvref_direct] trec 19.6 6980 6656 6015 6074 tgsl - * 7802 6282 6208 6221 tset 6260 6278 6284 tleft - * 12.2 9753 7331 6393 6419 tmisc 7614 7130 7131 + * tari 14.3 12.5 6662 6292 5997 6085 [gc opt_if_b7p opt_p_pi_ss_fvref_direct] + * trec 19.6 6980 6656 6015 6074 + * tgsl 7802 6282 6208 6221 + * tset 6260 6278 6284 + * tleft 12.2 9753 7331 6393 6419 + * tmisc 7614 7130 7131 * tgc 10.4 7579 7619 7659 * tclo 8025 8809 7627 7657 * tlamb 8003 7920 7926 @@ -107950,416 +82385,161 @@ main (int argc, char** argv) { * tall 15.9 15.6 15.6 15.1 15.1 * timp 24.4 19.6 15.5 15.6 * tmv 21.9 20.7 16.6 17.7 - * calls 37.5 37.5 37.1 37.4 38.4 [unknown: mus_tap_dpd - * negate_p_p mus_rand_interp mus_table_lookup_dv -> 0] sg - * 55.8 55.3 55.4 56.4 [same?] tbig 175.8 148.1 145.5 145.2 + * calls 37.5 37.5 37.1 37.4 38.4 [unknown: mus_tap_dpd negate_p_p mus_rand_interp mus_table_lookup_dv -> 0] + * sg 55.8 55.3 55.4 56.4 [same?] + * tbig 175.8 148.1 145.5 145.2 * ---------------------------------------------- * * t883 -> s7test: - * (define (f11) (do ((x 3) (y 2) (i 0 (+ i 1))) ((= i 2) x) (set! x - * (make-int-vector x y)))): opt_p_ii_ss not an integer but an int-vector - * (debugger), but if run #i(2 2 2)!! type mixup above to t725, if loop_end - * large -> opt? maybe no b_i_s if func not restricted to int arg, or if only - * ints in expr (b_d_s -> b_D_s if float+int as above) + * (define (f11) (do ((x 3) (y 2) (i 0 (+ i 1))) ((= i 2) x) (set! x (make-int-vector x y)))): opt_p_ii_ss + * not an integer but an int-vector (debugger), but if run #i(2 2 2)!! + * type mixup above to t725, if loop_end large -> opt? + * maybe no b_i_s if func not restricted to int arg, or if only ints in expr (b_d_s -> b_D_s if float+int as above) * - * if safe func + s7_value -> sc->code clobbered error -- can we use this to - * warn user? this is misleading -- not itself a bug (apply_mv). in s7test we're - * using unsafe functions here even though they claim to be safe, why does the - * safe case work? bits for values/eval/eval_c/load_c + flag set if encountered, - * report if safe_proc (see unsafe-s7.c) but how to avoid check if s7_eval from - * scheme eval? use wrappers + * if safe func + s7_value -> sc->code clobbered error -- can we use this to warn user? this is misleading -- not itself a bug (apply_mv). + * in s7test we're using unsafe functions here even though they claim to be safe, why does the safe case work? + * bits for values/eval/eval_c/load_c + flag set if encountered, report if safe_proc (see unsafe-s7.c) but how to avoid check if s7_eval from scheme eval? + * use wrappers * * tmethod? why the (quote ...) in t725 output (not '...) * - * (*s7* scheme-version) possible unnecessary load_string/inits, check #_ funcs - * via t884, lint r7rs: string-copy needs to be protected/restored, as does - * delay, rtst->s7test problematic: guard (wrong return type) promise.scm has - * tests, provide for local? - * #;<> is supposed to return nothing(?), what is #;#;? #;3 reads more - * than it should + * (*s7* scheme-version) possible unnecessary load_string/inits, check #_ funcs via t884, lint + * r7rs: string-copy needs to be protected/restored, as does delay, rtst->s7test + * problematic: guard (wrong return type) + * promise.scm has tests, provide for local? + * #;<> is supposed to return nothing(?), what is #;#;? #;3 reads more than it should * - * build-in a repl as in nrepl, so WITH_MAIN is less stupid, maybe nrepl if not - * too onerous repl.scm is ca 4 times bigger, and will require libc -> s7.c for - * shell control etc + * build-in a repl as in nrepl, so WITH_MAIN is less stupid, maybe nrepl if not too onerous + * repl.scm is ca 4 times bigger, and will require libc -> s7.c for shell control etc * * [do_tree again -- instrumented...] * * old, maybe someday: - * fx_chooser can't depend on is_defined_global because it sees args before - * possible local bindings, get rid of these if possible the fx_tree->fx_tree_in - * etc routes are a mess (redundant and flags get set at pessimal times) use - * optn pointers for if branches (also on existing cases -- many ops can be - * removed) the rec_p1 swap can collapse funcs in oprec_if_a_opla_aq_a and - * presumably elsewhere extend oprec_i* and also to oprec_p[air]* where base p - * is protected but locals need not be? tc_if_a_z_la et al in check_tc_cond et - * al need code merge recur_if_a_a_if_a_a_la_la needs the 3 other choices - * (true_quits etc) and combined op_recur_if_a_a_opa_la_laq - * op_recur_if_a_a_opla_la_laq can use existing if_and_cond blocks, need cond - * cases see s7-ffi.html 2631 -- needs rewrite! unsafe: apply-values values - * sort! apply [maybe because fx* does not protect against values, sc->code - * change in apply syntax etc] unsafe: s7_apply_function s7_values s7_call - * s7_eval s7_eval_c_string, only phase-vocoder is unsafe in clm2xen.c ffitest - * examples of unsafe funcs, for-each/map/member/assoc with push? t101-5|6|13|16 - * trouble fx_safe_thunk_a opt_p_pp_ff etc if unsafe->semisafe or safe (see - * 29-Mar) tree_set_memq et al with #_*? also begin_set* [search is done by hand - * -- can c_funcs have a tag? what about big_symbol tag] there's room for - * int32_t in cell func + * fx_chooser can't depend on is_defined_global because it sees args before possible local bindings, get rid of these if possible + * the fx_tree->fx_tree_in etc routes are a mess (redundant and flags get set at pessimal times) + * use optn pointers for if branches (also on existing cases -- many ops can be removed) + * the rec_p1 swap can collapse funcs in oprec_if_a_opla_aq_a and presumably elsewhere + * extend oprec_i* and also to oprec_p[air]* where base p is protected but locals need not be? + * tc_if_a_z_la et al in check_tc_cond et al need code merge + * recur_if_a_a_if_a_a_la_la needs the 3 other choices (true_quits etc) and combined + * op_recur_if_a_a_opa_la_laq op_recur_if_a_a_opla_la_laq can use existing if_and_cond blocks, need cond cases + * see s7-ffi.html 2631 -- needs rewrite! + * unsafe: apply-values values sort! apply [maybe because fx* does not protect against values, sc->code change in apply syntax etc] + * unsafe: s7_apply_function s7_values s7_call s7_eval s7_eval_c_string, only phase-vocoder is unsafe in clm2xen.c + * ffitest examples of unsafe funcs, for-each/map/member/assoc with push? + * t101-5|6|13|16 trouble fx_safe_thunk_a opt_p_pp_ff etc if unsafe->semisafe or safe (see 29-Mar) + * tree_set_memq et al with #_*? also begin_set* [search is done by hand -- can c_funcs have a tag? what about big_symbol tag] + * there's room for int32_t in cell func */ -/* ========================================== format bridge functions - * ========================================== */ -void -s7i_add_format_column (s7_scheme* sc, s7_int val) { - sc->format_column+= val; -} -s7_int -s7i_format_column (s7_scheme* sc) { - return sc->format_column; -} -void -s7i_set_format_column (s7_scheme* sc, s7_int val) { - sc->format_column= val; -} -void -s7i_inc_format_column (s7_scheme* sc) { - sc->format_column++; -} +/* ========================================== format bridge functions ========================================== */ -s7_int -s7i_format_depth (s7_scheme* sc) { - return sc->format_depth; -} -void -s7i_inc_format_depth (s7_scheme* sc) { - sc->format_depth++; -} -void -s7i_dec_format_depth (s7_scheme* sc) { - sc->format_depth--; -} +void s7i_add_format_column(s7_scheme *sc, s7_int val) { sc->format_column += val; } +s7_int s7i_format_column(s7_scheme *sc) { return sc->format_column; } +void s7i_set_format_column(s7_scheme *sc, s7_int val) { sc->format_column = val; } +void s7i_inc_format_column(s7_scheme *sc) { sc->format_column++; } -int32_t -s7i_num_fdats (s7_scheme* sc) { - return sc->num_fdats; -} -void -s7i_set_num_fdats (s7_scheme* sc, int32_t val) { - sc->num_fdats= val; -} +s7_int s7i_format_depth(s7_scheme *sc) { return sc->format_depth; } +void s7i_inc_format_depth(s7_scheme *sc) { sc->format_depth++; } +void s7i_dec_format_depth(s7_scheme *sc) { sc->format_depth--; } -format_data_t** -s7i_fdats (s7_scheme* sc) { - return sc->fdats; -} -void -s7i_set_fdats (s7_scheme* sc, format_data_t** val) { - sc->fdats= val; -} +int32_t s7i_num_fdats(s7_scheme *sc) { return sc->num_fdats; } +void s7i_set_num_fdats(s7_scheme *sc, int32_t val) { sc->num_fdats = val; } -bool -s7i_has_openlets (s7_scheme* sc) { - return sc->has_openlets; -} -void -s7i_set_has_openlets (s7_scheme* sc, bool val) { - sc->has_openlets= val; -} +format_data_t **s7i_fdats(s7_scheme *sc) { return sc->fdats; } +void s7i_set_fdats(s7_scheme *sc, format_data_t **val) { sc->fdats = val; } -s7_int -s7i_print_length (s7_scheme* sc) { - return sc->print_length; -} +bool s7i_has_openlets(s7_scheme *sc) { return sc->has_openlets; } +void s7i_set_has_openlets(s7_scheme *sc, bool val) { sc->has_openlets = val; } -char* -s7i_strbuf (s7_scheme* sc) { - return sc->strbuf; -} -s7_int -s7i_strbuf_size (s7_scheme* sc) { - return sc->strbuf_size; -} +s7_int s7i_print_length(s7_scheme *sc) { return sc->print_length; } -s7_pointer -s7i_F (s7_scheme* sc) { - return sc->F; -} -s7_pointer -s7i_T (s7_scheme* sc) { - return sc->T; -} -s7_pointer -s7i_nil (s7_scheme* sc) { - return sc->nil; -} -s7_pointer -s7i_undefined (s7_scheme* sc) { - return sc->undefined; -} +char *s7i_strbuf(s7_scheme *sc) { return sc->strbuf; } +s7_int s7i_strbuf_size(s7_scheme *sc) { return sc->strbuf_size; } -s7_pointer -s7i_format_symbol (s7_scheme* sc) { - return sc->format_symbol; -} -s7_pointer -s7i_format_error_symbol (s7_scheme* sc) { - return sc->format_error_symbol; -} -s7_pointer -s7i_format_f (s7_scheme* sc) { - return sc->format_f; -} -s7_pointer -s7i_format_as_objstr (s7_scheme* sc) { - return sc->format_as_objstr; -} -s7_pointer -s7i_format_just_control_string (s7_scheme* sc) { - return sc->format_just_control_string; -} -s7_pointer -s7i_format_no_column (s7_scheme* sc) { - return sc->format_no_column; -} +s7_pointer s7i_F(s7_scheme *sc) { return sc->F; } +s7_pointer s7i_T(s7_scheme *sc) { return sc->T; } +s7_pointer s7i_nil(s7_scheme *sc) { return sc->nil; } +s7_pointer s7i_undefined(s7_scheme *sc) { return sc->undefined; } -s7_pointer -s7i_an_output_port_string (void) { - return an_output_port_string; -} -s7_pointer -s7i_a_format_port_string (void) { - return a_format_port_string; -} +s7_pointer s7i_format_symbol(s7_scheme *sc) { return sc->format_symbol; } +s7_pointer s7i_format_error_symbol(s7_scheme *sc) { return sc->format_error_symbol; } +s7_pointer s7i_format_f(s7_scheme *sc) { return sc->format_f; } +s7_pointer s7i_format_as_objstr(s7_scheme *sc) { return sc->format_as_objstr; } +s7_pointer s7i_format_just_control_string(s7_scheme *sc) { return sc->format_just_control_string; } +s7_pointer s7i_format_no_column(s7_scheme *sc) { return sc->format_no_column; } -s7_int -s7i_FORMAT_PORT_LENGTH (void) { - return FORMAT_PORT_LENGTH; -} +s7_pointer s7i_an_output_port_string(void) { return an_output_port_string; } +s7_pointer s7i_a_format_port_string(void) { return a_format_port_string; } -const int32_t* -s7i_digits (void) { - return digits; -} -const bool* -s7i_white_space (void) { - return white_space; -} +s7_int s7i_FORMAT_PORT_LENGTH(void) { return FORMAT_PORT_LENGTH; } -s7_pointer -s7i_format_string_1 (s7_scheme* sc) { - (void) sc; - return format_string_1; -} -s7_pointer -s7i_format_string_2 (s7_scheme* sc) { - (void) sc; - return format_string_2; -} -s7_pointer -s7i_format_string_3 (s7_scheme* sc) { - (void) sc; - return format_string_3; -} -s7_pointer -s7i_format_string_4 (s7_scheme* sc) { - (void) sc; - return format_string_4; -} +const int32_t *s7i_digits(void) { return digits; } +const bool *s7i_white_space(void) { return white_space; } -bool -s7i_is_string_port (s7_pointer port) { - return is_string_port (port); -} -s7_int -s7i_port_position (s7_pointer port) { - return port_position (port); -} -void -s7i_set_port_position (s7_pointer port, s7_int val) { - port_position (port)= val; -} -s7_int -s7i_port_data_size (s7_pointer port) { - return port_data_size (port); -} -void -s7i_set_port_data_size (s7_pointer port, s7_int val) { - port_data_size (port)= val; -} -uint8_t* -s7i_port_data (s7_pointer port) { - return port_data (port); -} -void -s7i_set_port_data (s7_pointer port, uint8_t* val) { - port_data (port)= val; -} -block_t* -s7i_port_data_block (s7_pointer port) { - return port_data_block (port); -} -void -s7i_set_port_data_block (s7_pointer port, block_t* val) { - port_data_block (port)= val; -} +s7_pointer s7i_format_string_1(s7_scheme *sc) { (void)sc; return format_string_1; } +s7_pointer s7i_format_string_2(s7_scheme *sc) { (void)sc; return format_string_2; } +s7_pointer s7i_format_string_3(s7_scheme *sc) { (void)sc; return format_string_3; } +s7_pointer s7i_format_string_4(s7_scheme *sc) { (void)sc; return format_string_4; } -int32_t -s7i_type (s7_pointer p) { - return type (p); -} -int32_t -s7i_T_INTEGER (void) { - return T_INTEGER; -} -int32_t -s7i_T_RATIO (void) { - return T_RATIO; -} -int32_t -s7i_T_STRING (void) { - return T_STRING; -} +bool s7i_is_string_port(s7_pointer port) { return is_string_port(port); } +s7_int s7i_port_position(s7_pointer port) { return port_position(port); } +void s7i_set_port_position(s7_pointer port, s7_int val) { port_position(port) = val; } +s7_int s7i_port_data_size(s7_pointer port) { return port_data_size(port); } +void s7i_set_port_data_size(s7_pointer port, s7_int val) { port_data_size(port) = val; } +uint8_t *s7i_port_data(s7_pointer port) { return port_data(port); } +void s7i_set_port_data(s7_pointer port, uint8_t *val) { port_data(port) = val; } +block_t *s7i_port_data_block(s7_pointer port) { return port_data_block(port); } +void s7i_set_port_data_block(s7_pointer port, block_t *val) { port_data_block(port) = val; } -s7_int -s7i_string_length (s7_pointer str) { - return string_length (str); -} -void -s7i_set_string_length (s7_pointer str, s7_int len) { - string_length (str)= len; -} -const char* -s7i_string_value (s7_pointer str) { - return string_value (str); -} -s7_int -s7i_safe_strlen (const char* str) { - return safe_strlen (str); -} -void* -s7i_block_data (block_t* b) { - return block_data (b); -} +int32_t s7i_type(s7_pointer p) { return type(p); } +int32_t s7i_T_INTEGER(void) { return T_INTEGER; } +int32_t s7i_T_RATIO(void) { return T_RATIO; } +int32_t s7i_T_STRING(void) { return T_STRING; } -s7_pointer -s7i_current_output_port (s7_scheme* sc) { - return current_output_port (sc); -} -void -s7i_close_format_port (s7_scheme* sc, s7_pointer port) { - close_format_port (sc, port); -} +s7_int s7i_string_length(s7_pointer str) { return string_length(str); } +void s7i_set_string_length(s7_pointer str, s7_int len) { string_length(str) = len; } +const char *s7i_string_value(s7_pointer str) { return string_value(str); } +s7_int s7i_safe_strlen(const char *str) { return safe_strlen(str); } +void *s7i_block_data(block_t *b) { return block_data(b); } -void -s7i_error_nr (s7_scheme* sc, s7_pointer type, s7_pointer info) { - error_nr (sc, type, info); -} -s7_pointer -s7i_wrap_string (s7_scheme* sc, const char* str, s7_int len) { - return wrap_string (sc, str, len); -} -s7_pointer -s7i_wrap_integer (s7_scheme* sc, s7_int n) { - return wrap_integer (sc, n); -} +s7_pointer s7i_current_output_port(s7_scheme *sc) { return current_output_port(sc); } +void s7i_close_format_port(s7_scheme *sc, s7_pointer port) { close_format_port(sc, port); } -s7_pointer -s7i_set_elist_2 (s7_scheme* sc, s7_pointer x1, s7_pointer x2) { - return set_elist_2 (sc, x1, x2); -} -s7_pointer -s7i_set_elist_3 (s7_scheme* sc, s7_pointer x1, s7_pointer x2, s7_pointer x3) { - return set_elist_3 (sc, x1, x2, x3); -} -s7_pointer -s7i_set_elist_4 (s7_scheme* sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, - s7_pointer x4) { - return set_elist_4 (sc, x1, x2, x3, x4); -} -s7_pointer -s7i_set_elist_5 (s7_scheme* sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, - s7_pointer x4, s7_pointer x5) { - return set_elist_5 (sc, x1, x2, x3, x4, x5); -} -s7_pointer -s7i_set_plist_3 (s7_scheme* sc, s7_pointer x1, s7_pointer x2, s7_pointer x3) { - return set_plist_3 (sc, x1, x2, x3); -} +void s7i_error_nr(s7_scheme *sc, s7_pointer type, s7_pointer info) { error_nr(sc, type, info); } +s7_pointer s7i_wrap_string(s7_scheme *sc, const char *str, s7_int len) { return wrap_string(sc, str, len); } +s7_pointer s7i_wrap_integer(s7_scheme *sc, s7_int n) { return wrap_integer(sc, n); } -bool -s7i_is_elist (s7_scheme* sc, s7_pointer p) { - (void) sc; - return is_elist (p); -} -bool -s7i_is_one (s7_pointer x) { - return is_one (x); -} -bool -s7i_digitp (int32_t c) { - return digitp (c); -} +s7_pointer s7i_set_elist_2(s7_scheme *sc, s7_pointer x1, s7_pointer x2) { return set_elist_2(sc, x1, x2); } +s7_pointer s7i_set_elist_3(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3) { return set_elist_3(sc, x1, x2, x3); } +s7_pointer s7i_set_elist_4(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4) { return set_elist_4(sc, x1, x2, x3, x4); } +s7_pointer s7i_set_elist_5(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4, s7_pointer x5) { return set_elist_5(sc, x1, x2, x3, x4, x5); } +s7_pointer s7i_set_plist_3(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3) { return set_plist_3(sc, x1, x2, x3); } -void -s7i_resize_port_data (s7_scheme* sc, s7_pointer port, s7_int len) { - resize_port_data (sc, port, len); -} -block_t* -s7i_mallocate (s7_scheme* sc, s7_int size) { - return mallocate (sc, size); -} -void -s7i_liberate (s7_scheme* sc, block_t* b) { - liberate (sc, b); -} +bool s7i_is_elist(s7_scheme *sc, s7_pointer p) { (void)sc; return is_elist(p); } +bool s7i_is_one(s7_pointer x) { return is_one(x); } +bool s7i_digitp(int32_t c) { return digitp(c); } -s7_pointer -s7i_object_to_list (s7_scheme* sc, s7_pointer obj) { - return object_to_list (sc, obj); -} -s7_pointer -s7i_inline_block_to_string (s7_scheme* sc, block_t* block, s7_int len) { - return inline_block_to_string (sc, block, len); -} -block_t* -s7i_inline_mallocate (s7_scheme* sc, s7_int size) { - return inline_mallocate (sc, size); -} +void s7i_resize_port_data(s7_scheme *sc, s7_pointer port, s7_int len) { resize_port_data(sc, port, len); } +block_t *s7i_mallocate(s7_scheme *sc, s7_int size) { return mallocate(sc, size); } +void s7i_liberate(s7_scheme *sc, block_t *b) { liberate(sc, b); } -s7_pointer -s7i_make_string_with_length (s7_scheme* sc, const char* str, s7_int len) { - return make_string_with_length (sc, str, len); -} +s7_pointer s7i_object_to_list(s7_scheme *sc, s7_pointer obj) { return object_to_list(sc, obj); } +s7_pointer s7i_inline_block_to_string(s7_scheme *sc, block_t *block, s7_int len) { return inline_block_to_string(sc, block, len); } +block_t *s7i_inline_mallocate(s7_scheme *sc, s7_int size) { return inline_mallocate(sc, size); } -s7_int -s7i_integer_clamped_if_gmp (s7_scheme* sc, s7_pointer p) { - (void) sc; - return s7_integer (p); -} +s7_pointer s7i_make_string_with_length(s7_scheme *sc, const char *str, s7_int len) { return make_string_with_length(sc, str, len); } -const char* -s7i_integer_to_string (s7_scheme* sc, s7_int num, s7_int* nlen) { - return integer_to_string (sc, num, nlen); -} +s7_int s7i_integer_clamped_if_gmp(s7_scheme *sc, s7_pointer p) { (void)sc; return s7_integer(p); } -char* -s7i_number_to_string_base_10 (s7_scheme* sc, s7_pointer obj, s7_int width, - s7_int precision, char float_choice, s7_int* nlen, - s7i_use_write_t choice) { - return number_to_string_base_10 (sc, obj, width, precision, float_choice, - nlen, (use_write_t) choice); -} +const char *s7i_integer_to_string(s7_scheme *sc, s7_int num, s7_int *nlen) { return integer_to_string(sc, num, nlen); } -block_t* -s7i_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) { - return number_to_string_with_radix (sc, obj, radix, width, precision, - float_choice, nlen); -} +char *s7i_number_to_string_base_10(s7_scheme *sc, s7_pointer obj, s7_int width, s7_int precision, char float_choice, s7_int *nlen, s7i_use_write_t choice) +{ return number_to_string_base_10(sc, obj, width, precision, float_choice, nlen, (use_write_t)choice); } -s7_pointer -s7i_open_format_port (s7_scheme* sc) { - return open_format_port (sc); -} +block_t *s7i_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) +{ return number_to_string_with_radix(sc, obj, radix, width, precision, float_choice, nlen); } + +s7_pointer s7i_open_format_port(s7_scheme *sc) { return open_format_port(sc); } /* ========================================== */ diff --git a/TeXmacs/plugins/goldfish/src/s7_internal.h b/TeXmacs/plugins/goldfish/src/s7_internal.h index 8a0be92e04..a53bd37f85 100644 --- a/TeXmacs/plugins/goldfish/src/s7_internal.h +++ b/TeXmacs/plugins/goldfish/src/s7_internal.h @@ -149,7 +149,11 @@ /* ---------------- initial sizes ---------------- */ #ifndef INITIAL_HEAP_SIZE - #define INITIAL_HEAP_SIZE 64000 /* 29-Jul-21 -- seems faster */ + #ifdef __EMSCRIPTEN__ + #define INITIAL_HEAP_SIZE 64000 /* wasm 内存受限，保持小堆 */ + #else + #define INITIAL_HEAP_SIZE 256000 /* [0137] 更大的初始堆减少 GC 频率，read 密集负载约快 12% */ + #endif #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 hardware cache size probably matters more). @@ -1086,7 +1090,7 @@ typedef struct heap_block_t { struct heap_block_t *next; } heap_block_t; -typedef struct { +typedef struct shared_info { s7_pointer *objs; int32_t size, top, ref, size2; bool has_hits; @@ -2029,6 +2033,50 @@ s7_pointer lookup_1(s7_scheme *sc, const s7_pointer symbol); /* type predicates tables (decls) */ extern bool t_procedure_p[NUM_TYPES]; +extern bool t_structure_p[NUM_TYPES]; +extern bool t_sequence_p[NUM_TYPES]; +extern bool t_vector_p[NUM_TYPES]; + +void memclr(void *s, size_t n); + +/* function decls for s7_scheme_write.c (object->port), definitions live in s7.c */ +extern inline void liberate(s7_scheme *sc, block_t *blk); +char *pos_int_to_str(s7_scheme *sc, s7_int num, s7_int *len, char endc); +char *pos_int_to_str_direct(s7_scheme *sc, s7_int num); +char *pos_int_to_str_direct_1(s7_scheme *sc, s7_int num); +void print_debugging_state(s7_scheme *sc, s7_pointer obj, s7_pointer port); +s7_pointer wrap_real(s7_scheme *sc, s7_double x); +s7_pointer set_dlist_1(s7_scheme *sc, s7_pointer x1); +const char *type_name(s7_scheme *sc, s7_pointer arg, article_t article); +bool tree_is_cyclic(s7_scheme *sc, s7_pointer tree); +const char *integer_to_string(s7_scheme *sc, s7_int num, s7_int *nlen); +const char *integer_to_string_no_length(s7_scheme *sc, s7_int num); +char *floatify(char *str, s7_int *nlen); +void insert_spaces(s7_scheme *sc, const char *src, s7_int width, s7_int len); +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); +void resize_port_data(s7_scheme *sc, s7_pointer port, s7_int new_size); +void string_write_string_resized(s7_scheme *sc, const char *str, s7_int len, s7_pointer port); +void port_write_unicode_char(s7_scheme *sc, uint32_t c, s7_pointer port); +s7_pointer hash_table_iterate(s7_scheme *sc, s7_pointer iterator); +void port_write_vector_typer(s7_scheme *sc, s7_pointer vect, s7_pointer port); +const char *hash_table_checker_name(s7_scheme *sc, s7_pointer table); + +/* more decls for the object->port printer */ +extern const char dignum[]; +extern s7_pointer *chars; +extern bool t_number_p[NUM_TYPES]; +block_t *callocate(s7_scheme *sc, s7_int bytes); +s7_pointer pair_append(s7_scheme *sc, s7_pointer a, s7_pointer b); +#if !DISABLE_DEPRECATED + #define c_object_print(Sc, p) c_object_info(Sc, p)->print +#endif +#if S7_DEBUGGING + #define T_Itr_Pos(p) titr_pos(sc, T_Itr(p), __func__, __LINE__) + #define T_Itr_Let(p) titr_let(sc, T_Itr(p), __func__, __LINE__) +#else + #define T_Itr_Pos(p) p + #define T_Itr_Let(p) p +#endif extern bool t_any_closure_p[NUM_TYPES]; extern s7_pointer a_procedure_string; @@ -2248,4 +2296,472 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot #define is_safe_closure_star_op(op) ((op >= OP_SAFE_CLOSURE_STAR_A) && (op < OP_C_SS)) #define is_unknown_op(op) ((op >= OP_UNKNOWN) && (op <= OP_UNKNOWN_NP)) +/* ---- macros copied from s7.c for s7_scheme_let.c (keep in sync!) ---- */ +#define caadr(p) car(car(cdr(p))) +#define cadar(p) car(cdr(car(p))) +#define cadddr(p) car(cdr(cdr(cdr(p)))) +#define cdar(p) cdr(car(p)) +#define clear_has_methods(p) clear_mid_type_bit(T_Met(p), T_MID_HAS_METHODS) +#if S7_DEBUGGING +#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 +#define gc_protect_via_stack(Sc, Obj) push_stack_no_code(Sc, OP_GC_PROTECT, Obj) +#define global_slot(p) T_Sld((T_Sym(p))->object.sym.global_slot) +#define global_value(p) slot_value(global_slot(T_Sym(p))) +#define has_active_methods(Sc, p) ((has_mid_type_bit(T_Ext(p), T_MID_HAS_METHODS)) && (Sc->has_openlets)) /* g_char # */ +#define has_let_fallback(p) has_mid_type_bit(T_Let(p), (T_MID_HAS_LET_REF_FALLBACK | T_MID_HAS_LET_SET_FALLBACK)) +#define has_let_ref_fallback(p) ((mid_type(T_Let(p)) & (T_MID_HAS_LET_REF_FALLBACK | T_MID_HAS_METHODS)) == (T_MID_HAS_LET_REF_FALLBACK | T_MID_HAS_METHODS)) +#define has_let_set_fallback(p) ((mid_type(T_Let(p)) & (T_MID_HAS_LET_SET_FALLBACK | T_MID_HAS_METHODS)) == (T_MID_HAS_LET_SET_FALLBACK | T_MID_HAS_METHODS)) +#define has_methods(p) has_mid_type_bit(T_Exs(p), T_MID_HAS_METHODS) /* display slot hits T_Ext here */ +#define if_let_method_exists_return_value(Sc, Let, Method, Args) \ + { \ + s7_pointer _Func_; \ + if ((has_active_methods(Sc, T_Let(Let))) && \ + ((_Func_ = find_method(Sc, Let, Method)) != Sc->undefined)) \ + return(s7_apply_function(Sc, _Func_, Args)); \ + } +#define initial_value(p) symbol_info(p)->ex.ex_ptr +#define integer(p) (T_Int(p))->object.number.integer_value +#define is_any_procedure(P) (type(P) >= T_CLOSURE) +#define is_applicable(P) (t_applicable_p[type(P)]) +#define is_boolean(p) (type(p) == T_BOOLEAN) +#define is_bound_symbol(Sc, p) (is_slot(s7_slot(Sc, p))) /* (s7_slot(Sc, p) != Sc->undefined) is the same speed apparently */ +#define is_c_object(p) (type(p) == T_C_OBJECT) +#define is_defined_global(p) ((is_slot(global_slot(p))) && (symbol_id(p) == 0)) +#define is_global(p) (symbol_id(p) == 0) +#define is_immutable_let(p) has_mid_type_bit(T_Let(p), T_MID_IMMUTABLE) +#define is_immutable_slot(p) has_mid_type_bit(T_Slt(p), T_MID_IMMUTABLE) +#define is_keyword(p) has_high_type_bit(T_Sym(p), T_SHORT_KEYWORD) +#define is_let(p) (type(p) == T_LET) +#define is_let_unchecked(p) (type_unchecked(p) == T_LET) +#if S7_DEBUGGING + #define is_not_slot_end(p) ((p) && (T_Slt(p))) +#else + #define is_not_slot_end(p) (p) /* used for loop through let slots which end in null, not for general slot recognition */ +#endif +#define is_openlet(p) has_mid_type_bit(T_Let(p), T_MID_HAS_METHODS) +#define is_possibly_constant(p) has_high_type_bit(T_Sym(p), T_SYMCONS) +#define is_quoted_symbol(Sc, p) ((is_quoted_pair(Sc, p)) && (is_pair(cdr(p))) && (is_symbol(cadr(p)))) +#define is_safe_quoted_pair(Sc, p) ((is_pair(p)) && (is_safe_quote(Sc, car(p)))) +#define is_quoted_pair(Sc, p) ((is_pair(p)) && (is_quote(Sc, car(p)))) +#define is_slot(p) (type(p) == T_SLOT) +#define is_string(p) (type(p) == T_STRING) +#define is_symbol_and_keyword(p) ((is_symbol(p)) && (is_keyword(p))) +#define is_syntactic_symbol(p) has_low_type_bit(T_Sym(p), T_SYNTACTIC) +#define is_syntax(p) (type(p) == T_SYNTAX) +#define is_syntax_or_qq(p) ((is_syntax(p)) || ((p) == sc->quasiquote_function)) /* qq is from s7_define_macro -> T_C_MACRO */ +#define is_t_integer(p) (type(p) == T_INTEGER) +#define is_t_real(p) (type(p) == T_REAL) +#define is_unlet(p) has_high_type_bit(T_Let(p), T_UNLET) +#define iterator_carrier(p) (T_Itr(p))->object.iter.cur +#define iterator_is_at_end(p) (!iter_ok(p)) /* ((full_type(T_Itr(p)) & T_ITER_OK) == 0) */ +#define keyword_symbol(p) symbol_info(T_Key(p))->nx.ksym /* keyword only, so does not collide with documentation */ +#define let_id(p) (T_Let(p))->object.let.id +#if S7_DEBUGGING + #define let_set_id(p, Id) do {(T_Let(p))->object.let.id = Id; if ((p == sc->rootlet) && (Id != -1)) {fprintf(stderr, "%s[%d]: rootlet id: %" ld64 "\n", __func__, __LINE__, (s7_int)Id); if (sc->stop_at_error) abort();}} while (0) +#else + #define let_set_id(p, Id) (T_Let(p))->object.let.id = Id +#endif +#define let_set_outlet(p, ol) (T_Let(p))->object.let.nxt = T_Out(ol) +#if S7_DEBUGGING + #define let_set_slots(p, Slot) check_let_set_slots(sc, p, Slot, __func__, __LINE__) +#else + #define let_set_slots(p, Slot) (T_Let(p))->object.let.slots = T_Sln(Slot) +#endif +#define let_slots(p) T_Sln((T_Let(p))->object.let.slots) +#define local_slot(p) T_Slt((T_Sym(p))->object.sym.local_slot) /* was T_Sld 1-Aug-25 */ +#define local_value(p) slot_value(local_slot(T_Sym(p))) + #define make_boolean(Sc, Val) ((Val) ? Sc->T : Sc->F) +/* make_integer/make_real fast paths depend on s7.c's static small_ints array; + * s7_scheme_let.c defines them as s7_make_integer/s7_make_real wrappers. */ +#define next_slot(p) T_Sln((T_Slt(p))->object.slt.nxt) +#define optimize_op(P) (T_Ext(P))->tf.bits.opt_bits +#if S7_DEBUGGING +#define push_stack_no_let(Sc, Op, Args, Code) push_stack(Sc, Op, Args, Code) +#else +#define push_stack_no_let(Sc, Op, Args, Code) \ + do { \ + stack_end_code(Sc) = Code; \ + stack_end_args(Sc) = Args; \ + stack_end_op(Sc) = (s7_pointer)(opcode_t)(Op); \ + Sc->stack_end += 4; \ + } while (0) +#endif +#if S7_DEBUGGING +#define push_stack_no_code(Sc, Op, Args) push_stack(Sc, Op, Args, Sc->unused) +#else +#define push_stack_no_code(Sc, Op, Args) \ + do { \ + stack_end_let(Sc) = Sc->curlet; \ + stack_end_args(Sc) = Args; \ + stack_end_op(Sc) = (s7_pointer)(opcode_t)(Op); \ + Sc->stack_end += 4; \ + } while (0) +#endif +#define real(p) (T_Rel(p))->object.number.real_value +#define set_all_methods(p, Let) mid_type(T_Let(p)) |= (mid_type(Let) & (T_MID_HAS_METHODS | T_MID_HAS_LET_REF_FALLBACK | T_MID_HAS_LET_SET_FALLBACK)) +#define set_car(p, Val) car(p) = Val /* can be a slot or # or # etc */ +#define set_fn_direct(f, X) do {set_opt2(f, (s7_pointer)(X), OPT2_FN); set_has_fn(f);} while (0) +#define set_global_value(p, Val) slot_set_value(global_slot(T_Sym(p)), Val) /* slot_set_value checks T_Ext */ +#if S7_DEBUGGING + #define set_has_carrier(p) do {set_mid_type_bit(T_Itr(p), T_MARK_SEQ); p->carrier_line = __LINE__;} while (0) +#else + #define set_has_carrier(p) set_mid_type_bit(T_Itr(p), T_MARK_SEQ) +#endif +#define set_has_let_ref_fallback(p) set_mid_type_bit(T_Let(p), T_MID_HAS_LET_REF_FALLBACK) +#define set_has_let_set_fallback(p) set_mid_type_bit(T_Let(p), T_MID_HAS_LET_SET_FALLBACK) +#define set_has_methods(p) set_mid_type_bit(T_Met(p), T_MID_HAS_METHODS) +#define set_is_unlet(p) set_high_type_bit(T_Let(p), T_UNLET) +#if REPORT_ROOTLET_REDEF + #define set_local(Symbol) set_local_1(sc, T_Sym(Symbol), __func__, __LINE__) +#else + #define set_local(p) full_type(T_Sym(p)) &= ~(T_DONT_EVAL_ARGS | T_SYNTACTIC) +#endif +#if !S7_DEBUGGING +#define set_opt2(p, x, r) (p)->object.cons.o2.opt2 = (s7_pointer)(x) +#else +#define set_opt2(p, x, Role) set_opt2_1(sc, T_Pair(p), (s7_pointer)(x), Role, __func__, __LINE__) +#endif +#if !S7_DEBUGGING +#define set_opt3(p, x, r) do {(p)->object.cons.o3.opt3 = x; clear_type_bit(p, T_LOCATION);} while (0) +#else +#define set_opt3(p, x, Role) set_opt3_1(T_Pair(p), x, Role) +#endif +#define set_opt3_sym(P, X) set_opt3(P, T_Sym(X), OPT3_SYM) +#define slot_end NULL +#define slot_has_setter(p) has_mid_type_bit(T_Slt(p), T_HAS_SETTER) +#define slot_set_has_setter(p) set_mid_type_bit(T_Slt(p), T_HAS_SETTER) +#define slot_set_next(p, Val) (T_Slt(p))->object.slt.nxt = T_Sln(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_setter(p) T_Prc((T_Slt(p)->object.slt.pending_value)) +#if S7_DEBUGGING +#define slot_set_value(slot, value) \ + do { \ + if (is_immutable_slot(slot)) fprintf(stderr, "%s[%d]: setting immutable slot %s\n", __func__, __LINE__, symbol_name(slot_symbol(slot))); \ + (T_Slt(slot))->object.slt.val = T_Nmv(value); \ + } while (0) +#else +#define slot_set_value(p, Val) (T_Slt(p))->object.slt.val = T_Nmv(Val) +#endif +#define slot_set_value_with_hook(Slot, Value) \ + do {if (hook_has_functions(sc->rootlet_redefinition_hook)) slot_set_value_with_hook_1(sc, T_Slt(Slot), T_Nmv(Value)); else slot_set_value(T_Slt(Slot), T_Nmv(Value));} while (0) +#define slot_symbol(p) T_Sym((T_Slt(p))->object.slt.sym) +#define slot_value(p) T_Nmv((T_Slt(p))->object.slt.val) +#define starlet_symbol_id(p) ((uint8_t)((block_size(symbol_info(p)) >> 8) & 0xff)) /* *s7* id -- can be gensym, eval unopt section */ +#define string_length(p) (T_Str(p))->object.string.length +#define symbol_id(p) (T_Sym(p))->object.sym.id +#define symbol_increment_ctr(p) (T_Sym(p))->object.sym.ctr++ /* despite this expense, ctr does save a lot overall */ +#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) +#if S7_DEBUGGING +#define unstack_gc_protect(Sc) unstack_with(Sc, OP_GC_PROTECT) +#else +#define unstack_gc_protect(Sc) Sc->stack_end -= 4 +#endif +#if S7_DEBUGGING +#define unstack_with(Sc, Op) unstack_1(Sc, Op, __func__, __LINE__) +#else +#define unstack_with(Sc, op) Sc->stack_end -= 4 +#endif +#define is_any_macro(P) t_any_macro_p[type(P)] +#define has_closure_let(P) t_has_closure_let[type(P)] +#define closure_let(p) T_Let((T_Clo(p))->object.func.let) +#define funclet_function(p) T_Sym((C_Let(p, L_FUNC))->object.let.edat.efnc.function) +#define has_let_file(p) has_high_type_bit(T_Let(p), T_HAS_LET_FILE) +#define let_line(p) (C_Let(p, L_FUNC))->object.let.edat.efnc.line +#define let_file(p) (C_Let(p, L_FUNC))->object.let.edat.efnc.file +#define mid_type(p) (p)->tf.bits.mid_bits +#define symbol_info(p) (symbol_name_cell(p))->object.string.block +#define is_quote(Sc, p) (((p) == Sc->quote_symbol) || ((p) == Sc->quote_function)) /* order here apparently does not matter */ +#define is_safe_quote(Sc, p) ((((p) == Sc->quote_symbol) && (is_global(Sc->quote_symbol))) || ((p) == Sc->quote_function)) +#define set_has_fn(p) set_high_type_bit(T_Pair(p), T_HAS_FN) +#if S7_DEBUGGING + #define C_Let(p, role) check_let_ref(p, role, __func__, __LINE__) +#else + #define C_Let(p, role) p +#endif +#define iter_ok(p) has_mid_type_bit(T_Itr(p), T_MID_ITER_OK) +#define T_SAFE_PROCEDURE (1 << (16 + 5)) +#define T_UNLET T_SYMCONS +#define T_MID_HAS_LET_REF_FALLBACK T_MID_MUTABLE +#define T_MID_HAS_LET_SET_FALLBACK T_MID_SAFE_STEPPER +#define T_HAS_SETTER T_MID_LOCATION +#define T_MARK_SEQ T_MID_MUTABLE +#define T_SYMCONS (1 << 0) +#define T_SHORT_KEYWORD (1 << 7) +#define T_HAS_LET_FILE (1 << 1) +#define OPT2_FN (1 << 19) /* fn (s7_function) func (sc, arglist) */ +#define OPT3_SYM (1 << 23) /* expression symbol access */ +#define L_FUNC (1LL << 41) +#define T_HAS_FN (1 << 13) + +/* ---- extern globals from s7.c for s7_scheme_let.c ---- */ +extern bool t_any_macro_p[NUM_TYPES], t_any_closure_p[NUM_TYPES], t_has_closure_let[NUM_TYPES], t_applicable_p[NUM_TYPES]; +extern s7_pointer too_many_arguments_string, a_boolean_string, a_let_string, a_non_constant_symbol_string, + a_procedure_or_a_macro_string, a_symbol_string, immutable_error_string; + +/* sl_no_field and friends (starlet field ids), copied from s7.c */ +typedef enum {sl_no_field=0, sl_accept_all_keyword_arguments, sl_autoloading, sl_catches, sl_cpu_time, sl_c_types, + sl_debug, sl_default_hash_table_length, sl_default_random_state, sl_default_rationalize_error, sl_equivalent_float_epsilon, + sl_expansions, sl_filenames, sl_file_names, sl_float_format_precision, sl_free_heap_size, sl_gc_freed, sl_gc_info, + sl_gc_protected_objects, sl_gc_resize_heap_by_4_fraction, sl_gc_resize_heap_fraction, sl_gc_stats, sl_gc_temps_size, + sl_gc_total_freed, sl_hash_table_float_epsilon, sl_hash_table_missing_key_value, sl_heap_size, sl_history, sl_history_enabled, + sl_history_size, sl_initial_string_port_length, sl_iterator_at_end_value, sl_major_version, sl_max_heap_size, sl_max_list_length, + sl_max_stack_size, sl_max_string_length, sl_max_string_port_length, sl_max_vector_dimensions, sl_max_vector_length, + sl_memory_usage, sl_minor_version, sl_most_negative_fixnum, sl_most_positive_fixnum, sl_muffle_warnings, + sl_number_separator, sl_openlets, sl_output_file_port_length, sl_print_length, sl_profile, sl_profile_info, + sl_profile_prefix, sl_rootlet_size, sl_safety, sl_scheme_version, sl_stack, sl_stacktrace_defaults, sl_stack_size, sl_stack_top, + sl_symbol_quote, sl_symbol_printer, sl_undefined_constant_warnings, sl_undefined_identifier_warnings, sl_version, + sl_num_fields} starlet_t; + +/* ---- function declarations (defined in s7.c) for s7_scheme_let.c ---- */ +s7_pointer add_slot_at_end(s7_scheme *sc, s7_uint id, s7_pointer last_slot, s7_pointer symbol, s7_pointer value); +s7_pointer add_slot_checked_at_end(s7_scheme *sc, s7_uint id, s7_pointer last_slot, s7_pointer symbol, s7_pointer value); +s7_pointer add_slot_checked_with_id(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value); +void add_slot_unchecked(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value, s7_uint id); +s7_pointer call_setter(s7_scheme *sc, s7_pointer slot, s7_pointer old_value); +s7_pointer checked_slot_set_value(s7_scheme *sc, s7_pointer slot, s7_pointer value); +s7_pointer find_let(s7_scheme *sc, s7_pointer obj); +no_return void find_let_error_nr(s7_scheme *sc, s7_pointer caller, s7_pointer let, s7_pointer new_let, int32_t arg_num, s7_pointer args); +s7_pointer find_method(s7_scheme *sc, s7_pointer let, s7_pointer symbol); +bool is_constant_symbol(s7_scheme *sc, s7_pointer sym); +bool is_eq_initial_value(s7_pointer symbol, s7_pointer other); +bool is_proper_quote(s7_scheme *sc, s7_pointer p); +s7_pointer make_string_with_length(s7_scheme *sc, const char *str, s7_int len); +s7_pointer make_symbol(s7_scheme *sc, const char *name, s7_int len); +s7_pointer method_or_bust(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer args, s7_pointer typ, int32_t position); +s7_pointer object_type_name(s7_scheme *sc, s7_pointer obj); +int32_t position_of(const s7_pointer p, s7_pointer args); +s7_pointer proper_list_reverse_in_place(s7_scheme *sc, s7_pointer list); +s7_pointer set_elist_3(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3); +s7_pointer set_elist_4(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4); +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 set_mlist_1(s7_scheme *sc, s7_pointer x1); +s7_pointer set_mlist_2(s7_scheme *sc, s7_pointer x1, s7_pointer x2); +s7_pointer set_plist_2(s7_scheme *sc, s7_pointer x1, s7_pointer x2); +s7_pointer set_plist_3(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3); +s7_pointer set_qlist_2(s7_scheme *sc, s7_pointer x1, s7_pointer x2); +s7_pointer set_qlist_3(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3); +s7_pointer set_ulist_1(s7_scheme *sc, s7_pointer x1, s7_pointer x2); +void slot_set_setter(s7_pointer slot, s7_pointer val); +s7_pointer starlet(s7_scheme *sc, s7_int choice); +s7_pointer starlet_set_1(s7_scheme *sc, s7_pointer sym, s7_pointer val); +s7_pointer symbol_to_local_slot(s7_scheme *sc, s7_pointer symbol, s7_pointer let); +s7_pointer copy_any_list(s7_scheme *sc, s7_pointer a); +s7_pointer g_procedure_source(s7_scheme *sc, s7_pointer args); +#if WITH_HISTORY +s7_pointer sanitize_history(s7_scheme *sc, s7_pointer code); +#endif + +#define clear_mid_type_bit(p, b) (p)->tf.bits.mid_bits &= (~(b)) +#define hook_has_functions(p) (is_pair(s7_hook_functions(sc, T_Clo(p)))) +#define set_integer(p, x) integer(p) = x +#define set_local_slot(p, Val) (T_Sym(p))->object.sym.local_slot = T_Slt(Val) +#define slot_set_symbol(p, Sym) (T_Slt(p))->object.slt.sym = T_Sym(Sym) +#define symbol_name_cell(p) T_Str((T_Sym(p))->object.sym.name) +#define symbol_name(p) string_value(symbol_name_cell(p)) +#if S7_DEBUGGING +void check_let_set_slots(s7_scheme *sc, s7_pointer let, s7_pointer slot, const char *func, int32_t line); +void set_opt2_1(s7_scheme *sc, s7_pointer p, s7_pointer x, s7_uint role, const char *func, int32_t line); +void set_opt3_1(s7_pointer p, s7_pointer x, s7_uint role); +s7_int gc_protect_2(s7_scheme *sc, s7_pointer x, int32_t line); +void unstack_1(s7_scheme *sc, opcode_t op, const char *func, int32_t line); +#endif +#define set_real(p, x) real(p) = x +#define T_MID_LOCATION (1 << 2) +#define T_MID_MUTABLE (1 << 10) +#define T_MID_SAFE_STEPPER (1 << 11) +#define T_MID_ITER_OK (1 << 15) +#define T_DONT_EVAL_ARGS (1 << (8 + 5)) +#define T_LOCATION (1 << (16 + 2)) + +/* more decls for s7_scheme_let.c */ +#if S7_DEBUGGING +void symbol_set_id(s7_pointer sym, s7_int id); +#else +#define symbol_set_id(p, X) (T_Sym(p))->object.sym.id = X +#endif +void slot_set_value_with_hook_1(s7_scheme *sc, s7_pointer slot, s7_pointer value); +no_return void wrong_type_error_nr(s7_scheme *sc, s7_pointer caller, s7_int arg_num, s7_pointer arg, s7_pointer typ); +void immutable_object_error_nr(s7_scheme *sc, s7_pointer info); + +/* macros mirrored from s7.c for split-out modules */ +#define Calloc(N, Size) calloc(N, Size) +#define Malloc(Size) malloc(Size) +#define NO_SYMBOLS false +#define OPT1_ANY (1 << 11) /* anything -- deliberate unchecked case */ +#define Realloc(Ptr, Size) realloc(Ptr, Size) +#define T_ALLOW_OTHER_KEYS (1 << 9) +#define T_CLEAN_SYMBOL T_MID_UNSAFE +#define T_COLLECTED (1 << (16 + 1)) +#define T_CYCLIC (1LL << (48 + 5)) +#define T_CYCLIC_SET (1LL << (48 + 6)) +#define T_DEFINER (1 << 2) +#define T_EXPANSION (1 << (8 + 6)) +#define T_HASH_CHOSEN T_MID_GENSYM +#define T_INITIAL_VALUE T_MID_LOW_COUNT +#define T_MACLET T_DEFINER +#define T_MID_COLLECTED (1 << 1) +#define T_MID_FUNCLET T_MID_GENSYM +#define T_MID_GENSYM (1 << 13) +#define T_MID_LOW_COUNT (1 << 4) +#define T_MID_SHARED (1 << 3) +#define T_MID_UNSAFE (1 << 7) +#define T_PAIR_MACRO T_MID_SAFE_STEPPER +#define T_SHARED (1 << (16 + 3)) +#define T_SHORT_CYCLIC (1 << 5) +#define T_SHORT_CYCLIC_SET (1 << 6) +#define T_SIMPLE_ELEMENTS (1 << 8) +#define T_TYPED_HASH_TABLE T_HAS_LET_FILE +#define T_TYPED_VECTOR T_HAS_LET_FILE +#define T_WEAK_HASH T_MID_SAFE_STEPPER +#define WITHOUT_OVERFLOW_ERROR false +#if S7_DEBUGGING +void *Malloc(size_t bytes); +void *Calloc(size_t nmemb, size_t size); +void *Realloc(void *ptr, size_t size); +#else +#define Calloc(N, Size) calloc(N, Size) +#define Malloc(Size) malloc(Size) +#define Realloc(Ptr, Size) realloc(Ptr, Size) +#endif +#define allows_other_keys(p) has_mid_type_bit(T_Pair(p), T_ALLOW_OTHER_KEYS) +#define byte_vector(p, i) ((T_BVc(p))->object.vector.elements.bytes[i]) +#define byte_vector_bytes(p) (T_BVc(p))->object.vector.elements.bytes +#define c_function_data(f) (T_Fnc(f))->object.fnc.c_proc /* not T_CFn -- this also applies to T_C_MACROs */ +#define c_function_name(f) c_function_data(f)->name /* const char* */ +#define c_function_name_length(f) c_function_data(f)->name_length /* int32_t */ +#define c_macro_data(f) (T_CMac(f))->object.fnc.c_proc +#define c_macro_name(f) c_macro_data(f)->name +#define c_macro_name_length(f) c_macro_data(f)->name_length +#define c_object_info(Sc, p) Sc->c_object_types[c_object_type(T_Obj(p))] +#define c_object_scheme_name(Sc, p) T_Str(c_object_info(Sc, p)->scheme_name) +#define c_object_set(Sc, p) c_object_info(Sc, p)->set +#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_type(p) (T_Obj(p))->object.c_obj.type +#define c_object_value(p) (T_Obj(p))->object.c_obj.value +#define c_pointer(p) (T_Ptr(p))->object.cptr.c_pointer +#define c_pointer_info(p) (T_Ptr(p))->object.cptr.info +#define c_pointer_type(p) (T_Ptr(p))->object.cptr.c_type +#define catch_tag(p) (T_Cat(p))->object.rcatch.tag +#define character(p) (T_Chr(p))->object.chr.c +#define character_name(p) (T_Chr(p))->object.chr.c_name +#define character_name_length(p) (T_Chr(p))->object.chr.length +#define check_stack_size(Sc) do {if (Sc->stack_end >= Sc->stack_resize_trigger) resize_stack(Sc);} while (0) +#define clamp_length(NLen, Len) (((NLen) < (Len)) ? (NLen) : (Len)) +#define clear_collected_and_shared(p) clear_mid_type_bit(T_Seq(p), T_MID_COLLECTED | T_MID_SHARED) /* this can clear free cells = calloc */ +#define clear_cyclic_bits(p) clear_type_bit(p, T_COLLECTED | T_SHARED | T_CYCLIC | T_CYCLIC_SET) /* not T_Seq, p can be free(!) */ +#define closure_body(p) (T_Pair((T_Clo(p))->object.func.body)) +#define closure_setter(p) (T_Prc((T_Clo(p))->object.func.setter)) +#define complex_vector_complexes(p) (T_Cvc(p))->object.vector.elements.complexes +#define current_code(Sc) car(Sc->cur_code) +#define eof_name(p) (T_Eof(p))->object.eof.name +#define eof_name_length(p) (T_Eof(p))->object.eof.len +#define float_vector_floats(p) (T_Fvc(p))->object.vector.elements.floats +#define gc_protected_at(Sc, Loc) vector_element(Sc->protected_objects, Loc) +#define has_pair_macro(p) has_mid_type_bit(T_Mac(p), T_PAIR_MACRO) +#define has_simple_elements(p) has_high_type_bit(T_Nvc(p), T_SIMPLE_ELEMENTS) +#define has_structure(P) ((t_structure_p[type(P)]) && ((!is_t_vector(P)) || (!has_simple_elements(P)))) +#define hash_chosen(p) has_mid_type_bit(T_Hsh(p), T_HASH_CHOSEN) +#define hash_table_block(p) (T_Hsh(p))->object.hasher.block +#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_uint +#define hash_table_key_typer(p) T_Prc(opt1_any(hash_table_procedures(p))) +#define hash_table_procedures(p) T_Lst(hash_table_block(p)->ex.ex_ptr) +#define hash_table_procedures_checker(p) T_Prc(car(hash_table_procedures(p))) +#define hash_table_procedures_mapper(p) T_Prc(cdr(hash_table_procedures(p))) +#define hash_table_size(p) ((T_Hsh(p))->object.hasher.mask + 1) +#define hash_table_value_typer(p) T_Prc(opt2_any(hash_table_procedures(p))) +#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_any_vector(p) t_vector_p[type(p)] +#define is_bacro_star(p) (type(p) == T_BACRO_STAR) +#define is_byte_vector(p) (type(p) == T_BYTE_VECTOR) +#define is_c_pointer(p) (type(p) == T_C_POINTER) +#define is_clean_symbol(p) has_mid_type_bit(T_Sym(p), T_CLEAN_SYMBOL) +#define is_collected(p) has_mid_type_bit(T_Seq(p), T_MID_COLLECTED) +#define is_collected_or_shared(p) has_mid_type_bit(T_Seq(p), T_MID_COLLECTED | T_MID_SHARED) +#define is_collected_unchecked(p) has_mid_type_bit(p, T_MID_COLLECTED) +#define is_complex_vector(p) (type(p) == T_COMPLEX_VECTOR) +#define is_cyclic(p) has_high_type_bit(T_Seq(p), T_SHORT_CYCLIC) +#define is_cyclic_set(p) has_high_type_bit(T_Seq(p), T_SHORT_CYCLIC_SET) +#define is_either_macro(p) ((is_macro(p)) || (is_macro_star(p))) +#define is_expansion(p) has_low_type_bit(T_Ext(p), T_EXPANSION) +#define is_file_port(p) (port_type(p) == file_port) +#define is_float_vector(p) (type(p) == T_FLOAT_VECTOR) +#define is_free(p) (type_unchecked(p) == T_FREE) +#define is_funclet(p) has_mid_type_bit(T_Let(p), T_MID_FUNCLET) +#define is_function_port(p) (port_type(p) == function_port) +#define is_hash_table(p) (type(p) == T_HASH_TABLE) +#define is_immutable_hash_table(p) has_mid_type_bit(T_Hsh(p), T_MID_IMMUTABLE) +#define is_immutable_pair(p) has_mid_type_bit(T_Pair(p), T_MID_IMMUTABLE) +#define is_immutable_string(p) has_mid_type_bit(T_Str(p), T_MID_IMMUTABLE) +#define is_immutable_vector(p) has_mid_type_bit(T_Vec(p), T_MID_IMMUTABLE) +#define is_initial_value(p) has_mid_type_bit(p, T_INITIAL_VALUE) +#define is_int_vector(p) (type(p) == T_INT_VECTOR) +#define is_iterator(p) (type(p) == T_ITERATOR) +#define is_maclet(p) has_high_type_bit(T_Let(p), T_MACLET) +#define is_macro(p) (type(p) == T_MACRO) +#define is_macro_star(p) (type(p) == T_MACRO_STAR) +#define is_multiple_value(p) has_low_type_bit(T_Exs(p), T_MULTIPLE_VALUE) /* not T_Ext -- can be a slot */ +#define is_normal_symbol(p) ((is_symbol(p)) && (!is_keyword(p))) /* ((full_type(p) & (0xff | T_KEYWORD)) == T_SYMBOL) is exactly the same speed */ +#define is_not_null(p) ((T_Exs(p)) != sc->nil) +#define is_number(P) t_number_p[type(P)] +#define is_sequence(P) ((t_sequence_p[type(P)]) || (has_methods(P))) +#define is_shared(p) has_mid_type_bit(T_Seq(p), T_MID_SHARED) +#define is_string_port(p) (port_type(p) == string_port) +#define is_t_vector(p) (type(p) == T_VECTOR) +#define is_typed_hash_table(p) has_high_type_bit(T_Hsh(p), T_TYPED_HASH_TABLE) +#define is_typed_vector(p) has_high_type_bit(T_Nvc(p), T_TYPED_VECTOR) +#define is_unquoted_pair(Sc, p) ((is_pair(p)) && (!is_quote(Sc, car(p)))) +#define is_weak_hash_table(p) has_mid_type_bit(T_Hsh(p), T_WEAK_HASH) +#define iterator_current(p) (T_Itr(p))->object.iter.cur +#define iterator_position(p) (T_Itr_Pos(p))->object.iter.lc.loc +#define iterator_sequence(p) (T_Itr(p))->object.iter.seq +#define let_iterator_slot(p) T_Sln((T_Itr_Let(p))->object.iter.lc.slot) /* applies only to lets */ +#define opt1(p, r) ((p)->object.cons.opt1) +#define opt1_any(P) opt1(P, OPT1_ANY) /* can be free in closure_is_ok */ +#define opt2_any(P) opt2(P, OPT2_KEY) +#define opt2_sym(P) T_Sym(opt2(P, OPT2_SYM)) +#define pair_macro(P) opt2_sym(P) +#define port_data(p) (T_Prt(p))->object.prt.data +#define port_data_size(p) (T_Prt(p))->object.prt.size +#define port_display(p) port_port(p)->pf->displayer +#define port_filename(p) port_port(p)->filename +#define port_filename_length(p) port_port(p)->filename_length +#define port_is_closed(p) port_port(p)->is_closed +#define port_position(p) (T_Prt(p))->object.prt.point +#define port_type(p) port_port(p)->ptype +#define random_carry(p) (T_Ran(p))->object.rng.carry +#define random_seed(p) (T_Ran(p))->object.rng.seed +#if S7_DEBUGGING + #define resize_stack(Sc) resize_stack_1(Sc, __func__, __LINE__) + void resize_stack_1(s7_scheme *sc, const char *func, int line); +#else + void resize_stack(s7_scheme *sc); +#endif +#define return_with_end_temp(Temp) do {s7_pointer Result = Temp; end_temp(Temp); return(Result);} while (0) +#define set_clean_symbol(p) set_mid_type_bit(T_Sym(p), T_CLEAN_SYMBOL) +#define set_collected(p) set_mid_type_bit(T_Seq(p), T_MID_COLLECTED) +#define set_cyclic(p) set_high_type_bit(T_Seq(p), T_SHORT_CYCLIC) +#define set_cyclic_set(p) set_high_type_bit(T_Seq(p), T_SHORT_CYCLIC_SET) +#define set_shared(p) set_mid_type_bit(T_Seq(p), T_MID_SHARED) +#define symbol_name_length(p) string_length(symbol_name_cell(p)) +#define syntax_symbol(p) T_Sym((T_Syn(p))->object.syn.symbol) +#define undefined_name(p) (T_Undf(p))->object.undef.name +#define undefined_name_length(p) (T_Undf(p))->object.undef.len +#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 vector_dimension(p, i) vdims_dims(vector_dimension_info(p))[i] +#define vector_dimension_info(p) ((vdims_t *)(T_Vec(p))->object.vector.block->ex.ex_info) +#define vector_element(p, i) ((T_Nvc(p))->object.vector.elements.objects[i]) +#define vector_getter(p) (T_Vec(p))->object.vector.vget +#define vector_ndims(p) vdims_rank(vector_dimension_info(p)) +#define vector_rank(p) ((vector_dimension_info(p)) ? vector_ndims(p) : 1) + #endif /* S7_INTERNAL_H */ diff --git a/TeXmacs/plugins/goldfish/src/s7_internal_helpers.h b/TeXmacs/plugins/goldfish/src/s7_internal_helpers.h index 9826a2f9eb..437792c6d7 100644 --- a/TeXmacs/plugins/goldfish/src/s7_internal_helpers.h +++ b/TeXmacs/plugins/goldfish/src/s7_internal_helpers.h @@ -78,6 +78,7 @@ bool s7i_has_active_methods(s7_scheme *sc, s7_pointer obj); /* boolean method dispatch for type predicate migration */ s7_pointer s7i_apply_boolean_method(s7_scheme *sc, s7_pointer obj, s7_pointer method); void s7i_wrong_type_error_nr(s7_scheme *sc, s7_pointer caller, s7_int arg_num, s7_pointer arg, s7_pointer typ); +void sole_arg_wrong_type_error_nr(s7_scheme *sc, s7_pointer caller, s7_pointer arg, s7_pointer typ); s7_pointer s7i_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args); s7_pointer s7i_copy_proper_list(s7_scheme *sc, s7_pointer lst); s7_int s7i_position_of(const s7_pointer p, s7_pointer args); @@ -107,6 +108,44 @@ bool s7i_is_string_via_method(s7_scheme *sc, s7_pointer obj); s7_pointer s7i_method_or_bust_sym(s7_scheme *sc, s7_pointer obj, s7_pointer method_sym, s7_pointer args, s7_pointer typ, s7_int arg_pos); s7_pointer s7i_set_plist_1(s7_scheme *sc, s7_pointer x1); s7_pointer s7i_string_type_name(s7_scheme *sc); +s7_pointer s7i_character_type_name(s7_scheme *sc); +no_return void out_of_range_error_nr(s7_scheme *sc, s7_pointer caller, s7_pointer arg_n, s7_pointer arg, s7_pointer descr); +void s7i_check_free_heap_size(s7_scheme *sc, s7_int size); +s7_pointer cons_unchecked(s7_scheme *sc, s7_pointer a, s7_pointer b); +no_return void immutable_object_error_nr(s7_scheme *sc, s7_pointer info); + +/* vector bridges for s7_liii_vector.c migration */ +bool s7i_is_any_vector(s7_pointer p); +bool s7i_is_t_vector(s7_pointer p); +bool s7i_is_typed_vector(s7_pointer p); +bool s7i_is_immutable_vector(s7_pointer p); +s7_pointer s7i_vector_element(s7_pointer p, s7_int i); +void s7i_vector_element_set(s7_pointer p, s7_int i, s7_pointer v); +s7_pointer s7i_vector_getter_ref(s7_scheme *sc, s7_pointer p, s7_int i); +s7_pointer s7i_vector_setter_set(s7_scheme *sc, s7_pointer p, s7_int i, s7_pointer v); +s7_pointer s7i_typed_vector_setter(s7_scheme *sc, s7_pointer p, s7_int i, s7_pointer v); +s7_int s7i_vector_offset(s7_pointer p, s7_int i); +s7_pointer s7i_small_int(s7_int val); +uint8_t s7i_byte_vector_element(s7_pointer p, s7_int i); +void s7i_byte_vector_element_set(s7_pointer p, s7_int i, uint8_t v); +s7_pointer s7i_g_vector_set(s7_scheme *sc, s7_pointer plist); +s7_pointer s7i_set_plist_4(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4); +s7_pointer s7i_vector_append_2(s7_scheme *sc, s7_pointer v1, s7_pointer v2); +s7_pointer s7i_vector_append_3(s7_scheme *sc, s7_pointer v1, s7_pointer v2, s7_pointer v3); + +/* list bridges for s7_liii_list.c migration */ +s7_pointer s7i_cons_safe(s7_scheme *sc, s7_pointer p1, s7_pointer p2); +s7_pointer s7i_inline_set_car(s7_scheme *sc, s7_pointer lst, s7_pointer value); +s7_pointer s7i_inline_set_cdr(s7_scheme *sc, s7_pointer lst, s7_pointer value); +bool s7i_is_simple(s7_pointer p); +bool s7i_scheme_version_is_s7(s7_scheme *sc); +s7_pointer s7i_methods_or_bust_pp(s7_scheme *sc, s7_pointer obj, const char *method_name1, const char *method_name2, + s7_pointer x1, s7_pointer x2, s7_pointer typ, s7_int num); +s7_pointer s7i_assoc_1(s7_scheme *sc, s7_pointer obj, s7_pointer lst); +s7_pointer s7i_memv_number(s7_scheme *sc, s7_pointer obj, s7_pointer lst); +s7_pointer s7i_member(s7_scheme *sc, s7_pointer obj, s7_pointer lst); +s7_int s7i_tree_len(s7_scheme *sc, s7_pointer p); +bool s7i_tree_is_cyclic_checked(s7_scheme *sc, s7_pointer tree); s7_pointer s7i_string_eq_symbol(s7_scheme *sc); s7_pointer s7i_string_lt_symbol(s7_scheme *sc); s7_pointer s7i_string_gt_symbol(s7_scheme *sc); @@ -355,6 +394,22 @@ s7_pointer s7i_multiply_p_ppp_wrapped(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_pointer s7i_invert_p_p(s7_scheme *sc, s7_pointer x); s7_pointer s7i_divide_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y); +/* bridge functions for s7_scheme_read.c (reader migration) */ +int32_t s7i_token(s7_scheme *sc); +s7_pointer s7i_make_sharp_constant(s7_scheme *sc, const char *name, bool with_error, s7_pointer port, bool error_if_bad_number); +void s7i_resize_strbuf(s7_scheme *sc, s7_int needed_size); +void s7i_backchar(char c, s7_pointer port); +bool s7i_is_loader_port(s7_pointer p); +s7_pointer s7i_an_input_port_string_obj(void); +s7_pointer s7i_an_open_input_port_string_obj(void); +s7_pointer s7i_eval(s7_scheme *sc, s7_int op); +block_t *s7i_mallocate_port(s7_scheme *sc); +void s7i_port_set_filename(s7_scheme *sc, s7_pointer port, const char *name, s7_int len); +void push_input_port(s7_scheme *sc, s7_pointer new_port); +bool hash_keys_not_cyclic(s7_scheme *sc, s7_pointer hash); +/* method_or_bust/_p/_pp take s7_pointer symbols; declared in s7_scheme_read.c only + * (s7_liii_string.c has its own same-named static helpers, so they can't live in a shared header) */ + #ifdef __cplusplus } #endif diff --git a/TeXmacs/plugins/goldfish/src/s7_liii_list.c b/TeXmacs/plugins/goldfish/src/s7_liii_list.c index b0cf1c5e76..e4c0f33f81 100644 --- a/TeXmacs/plugins/goldfish/src/s7_liii_list.c +++ b/TeXmacs/plugins/goldfish/src/s7_liii_list.c @@ -9,801 +9,1345 @@ #include -s7_pointer -g_is_null (s7_scheme* sc, s7_pointer args) { - s7_pointer p= s7_car (args); - if (s7_is_null (sc, p)) return (s7_t (sc)); +s7_pointer g_is_null(s7_scheme *sc, s7_pointer args) +{ + s7_pointer p = s7_car(args); + if (s7_is_null(sc, p)) return(s7_t(sc)); { - s7_pointer func= s7_method (sc, p, s7_make_symbol (sc, "null?")); - if (func == s7_undefined (sc)) return (s7_f (sc)); - return (s7_apply_function (sc, func, s7_cons (sc, p, s7_nil (sc)))); + s7_pointer func = s7_method(sc, p, s7_make_symbol(sc, "null?")); + if (func == s7_undefined(sc)) return(s7_f(sc)); + return(s7_apply_function(sc, func, s7_cons(sc, p, s7_nil(sc)))); } } /* -------------------------------- pair? -------------------------------- */ -s7_pointer -g_is_pair (s7_scheme* sc, s7_pointer args) { - s7_pointer p= s7_car (args); - if (s7_is_pair (p)) return (s7_t (sc)); - if (!s7i_has_active_methods (sc, p)) return (s7_f (sc)); +s7_pointer g_is_pair(s7_scheme *sc, s7_pointer args) +{ + s7_pointer p = s7_car(args); + if (s7_is_pair(p)) return(s7_t(sc)); + if (!s7i_has_active_methods(sc, p)) return(s7_f(sc)); { - s7_pointer sym = s7_make_symbol (sc, "pair?"); - s7_pointer func= s7i_find_method_with_let (sc, p, sym); - if (func == s7_undefined (sc)) return (s7_f (sc)); - return (s7_apply_function (sc, func, s7_cons (sc, p, s7_nil (sc)))); + s7_pointer sym = s7_make_symbol(sc, "pair?"); + s7_pointer func = s7i_find_method_with_let(sc, p, sym); + if (func == s7_undefined(sc)) return(s7_f(sc)); + return(s7_apply_function(sc, func, s7_cons(sc, p, s7_nil(sc)))); } } /* -------------------------------- list? -------------------------------- */ -s7_pointer -g_is_list (s7_scheme* sc, s7_pointer args) { - s7_pointer p= s7_car (args); - if (s7_is_list (sc, p)) return (s7_t (sc)); - if (!s7i_has_active_methods (sc, p)) return (s7_f (sc)); +s7_pointer g_is_list(s7_scheme *sc, s7_pointer args) +{ + s7_pointer p = s7_car(args); + if (s7_is_list(sc, p)) return(s7_t(sc)); + if (!s7i_has_active_methods(sc, p)) return(s7_f(sc)); { - s7_pointer sym = s7_make_symbol (sc, "list?"); - s7_pointer func= s7i_find_method_with_let (sc, p, sym); - if (func == s7_undefined (sc)) return (s7_f (sc)); - return (s7_apply_function (sc, func, s7_cons (sc, p, s7_nil (sc)))); + s7_pointer sym = s7_make_symbol(sc, "list?"); + s7_pointer func = s7i_find_method_with_let(sc, p, sym); + if (func == s7_undefined(sc)) return(s7_f(sc)); + return(s7_apply_function(sc, func, s7_cons(sc, p, s7_nil(sc)))); } } -/* -------------------------------- proper-list? - * -------------------------------- */ - -s7_pointer -g_is_proper_list (s7_scheme* sc, s7_pointer args) { - return (s7_make_boolean (sc, s7_is_proper_list (sc, s7_car (args)))); -} - -s7_pointer -g_car (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - if (s7_is_pair (lst)) return (s7_car (lst)); - return (s7i_sole_arg_method_or_bust (sc, lst, "car", args, "a pair")); -} - -s7_pointer -g_cdr (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - if (s7_is_pair (lst)) return (s7_cdr (lst)); - return (s7i_sole_arg_method_or_bust (sc, lst, "cdr", args, "a pair")); -} - -s7_pointer -g_caar (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - if (!s7_is_pair (lst)) - return (s7i_sole_arg_method_or_bust (sc, lst, "caar", args, "a pair")); - if (!s7_is_pair (s7_car (lst))) - return (s7_wrong_type_arg_error (sc, "caar", 1, lst, - "a pair whose car is also a pair")); - return (s7_caar (lst)); -} - -s7_pointer -g_cadr (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - if (!s7_is_pair (lst)) - return (s7i_sole_arg_method_or_bust (sc, lst, "cadr", args, "a pair")); - if (!s7_is_pair (s7_cdr (lst))) - return (s7_wrong_type_arg_error (sc, "cadr", 1, lst, - "a pair whose cdr is also a pair")); - return (s7_cadr (lst)); -} - -s7_pointer -g_cdar (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - if (!s7_is_pair (lst)) - return (s7i_sole_arg_method_or_bust (sc, lst, "cdar", args, "a pair")); - if (!s7_is_pair (s7_car (lst))) - return (s7_wrong_type_arg_error (sc, "cdar", 1, lst, - "a pair whose car is also a pair")); - return (s7_cdar (lst)); -} - -s7_pointer -g_cddr (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - if (!s7_is_pair (lst)) - return (s7i_sole_arg_method_or_bust (sc, lst, "cddr", args, "a pair")); - if (!s7_is_pair (s7_cdr (lst))) - return (s7_wrong_type_arg_error (sc, "cddr", 1, lst, - "a pair whose cdr is also a pair")); - return (s7_cddr (lst)); -} - -/* -------------------------------- 3-level cxxxr - * -------------------------------- */ - -s7_pointer -g_caaar (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - if (!s7_is_pair (lst)) - return (s7i_sole_arg_method_or_bust (sc, lst, "caaar", args, "a pair")); - if (!s7_is_pair (s7_car (lst))) - return (s7_wrong_type_arg_error (sc, "caaar", 1, lst, - "a pair whose car is also a pair")); - if (!s7_is_pair (s7_caar (lst))) - return (s7_wrong_type_arg_error (sc, "caaar", 1, lst, - "a pair whose caar is also a pair")); - return (s7_caaar (lst)); -} - -s7_pointer -g_caadr (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - if (!s7_is_pair (lst)) - return (s7i_sole_arg_method_or_bust (sc, lst, "caadr", args, "a pair")); - if (!s7_is_pair (s7_cdr (lst))) - return (s7_wrong_type_arg_error (sc, "caadr", 1, lst, - "a pair whose cdr is also a pair")); - if (!s7_is_pair (s7_cadr (lst))) - return (s7_wrong_type_arg_error (sc, "caadr", 1, lst, - "a pair whose cadr is also a pair")); - return (s7_caadr (lst)); -} - -s7_pointer -g_cadar (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - if (!s7_is_pair (lst)) - return (s7i_sole_arg_method_or_bust (sc, lst, "cadar", args, "a pair")); - if (!s7_is_pair (s7_car (lst))) - return (s7_wrong_type_arg_error (sc, "cadar", 1, lst, - "a pair whose car is also a pair")); - if (!s7_is_pair (s7_cdar (lst))) - return (s7_wrong_type_arg_error (sc, "cadar", 1, lst, - "a pair whose cdar is also a pair")); - return (s7_cadar (lst)); -} - -s7_pointer -g_caddr (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - if (!s7_is_pair (lst)) - return (s7i_sole_arg_method_or_bust (sc, lst, "caddr", args, "a pair")); - if (!s7_is_pair (s7_cdr (lst))) - return (s7_wrong_type_arg_error (sc, "caddr", 1, lst, - "a pair whose cdr is also a pair")); - if (!s7_is_pair (s7_cddr (lst))) - return (s7_wrong_type_arg_error (sc, "caddr", 1, lst, - "a pair whose cddr is also a pair")); - return (s7_caddr (lst)); -} - -s7_pointer -g_cdaar (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - if (!s7_is_pair (lst)) - return (s7i_sole_arg_method_or_bust (sc, lst, "cdaar", args, "a pair")); - if (!s7_is_pair (s7_car (lst))) - return (s7_wrong_type_arg_error (sc, "cdaar", 1, lst, - "a pair whose car is also a pair")); - if (!s7_is_pair (s7_caar (lst))) - return (s7_wrong_type_arg_error (sc, "cdaar", 1, lst, - "a pair whose caar is also a pair")); - return (s7_cdaar (lst)); -} - -s7_pointer -g_cdddr (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - if (!s7_is_pair (lst)) - return (s7i_sole_arg_method_or_bust (sc, lst, "cdddr", args, "a pair")); - if (!s7_is_pair (s7_cdr (lst))) - return (s7_wrong_type_arg_error (sc, "cdddr", 1, lst, - "a pair whose cdr is also a pair")); - if (!s7_is_pair (s7_cddr (lst))) - return (s7_wrong_type_arg_error (sc, "cdddr", 1, lst, - "a pair whose cddr is also a pair")); - return (s7_cdddr (lst)); -} - -s7_pointer -g_cdadr (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - if (!s7_is_pair (lst)) - return (s7i_sole_arg_method_or_bust (sc, lst, "cdadr", args, "a pair")); - if (!s7_is_pair (s7_cdr (lst))) - return (s7_wrong_type_arg_error (sc, "cdadr", 1, lst, - "a pair whose cdr is also a pair")); - if (!s7_is_pair (s7_cadr (lst))) - return (s7_wrong_type_arg_error (sc, "cdadr", 1, lst, - "a pair whose cadr is also a pair")); - return (s7_cdadr (lst)); -} - -s7_pointer -g_cddar (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - if (!s7_is_pair (lst)) - return (s7i_sole_arg_method_or_bust (sc, lst, "cddar", args, "a pair")); - if (!s7_is_pair (s7_car (lst))) - return (s7_wrong_type_arg_error (sc, "cddar", 1, lst, - "a pair whose car is also a pair")); - if (!s7_is_pair (s7_cdar (lst))) - return (s7_wrong_type_arg_error (sc, "cddar", 1, lst, - "a pair whose cdar is also a pair")); - return (s7_cddar (lst)); -} - -/* -------------------------------- 4-level cxxxr - * -------------------------------- */ - -s7_pointer -g_caaaar (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - if (!s7_is_pair (lst)) - return (s7i_sole_arg_method_or_bust (sc, lst, "caaaar", args, "a pair")); - if (!s7_is_pair (s7_car (lst))) - return (s7_wrong_type_arg_error (sc, "caaaar", 1, lst, - "a pair whose car is also a pair")); - if (!s7_is_pair (s7_caar (lst))) - return (s7_wrong_type_arg_error (sc, "caaaar", 1, lst, - "a pair whose caar is also a pair")); - if (!s7_is_pair (s7_caaar (lst))) - return (s7_wrong_type_arg_error (sc, "caaaar", 1, lst, - "a pair whose caaar is also a pair")); - return (s7_caaaar (lst)); -} - -s7_pointer -g_caaadr (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - if (!s7_is_pair (lst)) - return (s7i_sole_arg_method_or_bust (sc, lst, "caaadr", args, "a pair")); - if (!s7_is_pair (s7_cdr (lst))) - return (s7_wrong_type_arg_error (sc, "caaadr", 1, lst, - "a pair whose cdr is also a pair")); - if (!s7_is_pair (s7_cadr (lst))) - return (s7_wrong_type_arg_error (sc, "caaadr", 1, lst, - "a pair whose cadr is also a pair")); - if (!s7_is_pair (s7_caadr (lst))) - return (s7_wrong_type_arg_error (sc, "caaadr", 1, lst, - "a pair whose caadr is also a pair")); - return (s7_caaadr (lst)); -} - -s7_pointer -g_caadar (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - if (!s7_is_pair (lst)) - return (s7i_sole_arg_method_or_bust (sc, lst, "caadar", args, "a pair")); - if (!s7_is_pair (s7_car (lst))) - return (s7_wrong_type_arg_error (sc, "caadar", 1, lst, - "a pair whose car is also a pair")); - if (!s7_is_pair (s7_cdar (lst))) - return (s7_wrong_type_arg_error (sc, "caadar", 1, lst, - "a pair whose cdar is also a pair")); - if (!s7_is_pair (s7_cadar (lst))) - return (s7_wrong_type_arg_error (sc, "caadar", 1, lst, - "a pair whose cadar is also a pair")); - return (s7_caadar (lst)); -} - -s7_pointer -g_cadaar (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - if (!s7_is_pair (lst)) - return (s7i_sole_arg_method_or_bust (sc, lst, "cadaar", args, "a pair")); - if (!s7_is_pair (s7_car (lst))) - return (s7_wrong_type_arg_error (sc, "cadaar", 1, lst, - "a pair whose car is also a pair")); - if (!s7_is_pair (s7_caar (lst))) - return (s7_wrong_type_arg_error (sc, "cadaar", 1, lst, - "a pair whose caar is also a pair")); - if (!s7_is_pair (s7_cdaar (lst))) - return (s7_wrong_type_arg_error (sc, "cadaar", 1, lst, - "a pair whose cdaar is also a pair")); - return (s7_cadaar (lst)); -} - -s7_pointer -g_caaddr (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - if (!s7_is_pair (lst)) - return (s7i_sole_arg_method_or_bust (sc, lst, "caaddr", args, "a pair")); - if (!s7_is_pair (s7_cdr (lst))) - return (s7_wrong_type_arg_error (sc, "caaddr", 1, lst, - "a pair whose cdr is also a pair")); - if (!s7_is_pair (s7_cddr (lst))) - return (s7_wrong_type_arg_error (sc, "caaddr", 1, lst, - "a pair whose cddr is also a pair")); - if (!s7_is_pair (s7_caddr (lst))) - return (s7_wrong_type_arg_error (sc, "caaddr", 1, lst, - "a pair whose caddr is also a pair")); - return (s7_caaddr (lst)); -} - -s7_pointer -g_cadddr (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - if (!s7_is_pair (lst)) - return (s7i_sole_arg_method_or_bust (sc, lst, "cadddr", args, "a pair")); - if (!s7_is_pair (s7_cdr (lst))) - return (s7_wrong_type_arg_error (sc, "cadddr", 1, lst, - "a pair whose cdr is also a pair")); - if (!s7_is_pair (s7_cddr (lst))) - return (s7_wrong_type_arg_error (sc, "cadddr", 1, lst, - "a pair whose cddr is also a pair")); - if (!s7_is_pair (s7_cdddr (lst))) - return (s7_wrong_type_arg_error (sc, "cadddr", 1, lst, - "a pair whose cdddr is also a pair")); - return (s7_cadddr (lst)); -} - -s7_pointer -g_cadadr (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - if (!s7_is_pair (lst)) - return (s7i_sole_arg_method_or_bust (sc, lst, "cadadr", args, "a pair")); - if (!s7_is_pair (s7_cdr (lst))) - return (s7_wrong_type_arg_error (sc, "cadadr", 1, lst, - "a pair whose cdr is also a pair")); - if (!s7_is_pair (s7_cadr (lst))) - return (s7_wrong_type_arg_error (sc, "cadadr", 1, lst, - "a pair whose cadr is also a pair")); - if (!s7_is_pair (s7_cdadr (lst))) - return (s7_wrong_type_arg_error (sc, "cadadr", 1, lst, - "a pair whose cdadr is also a pair")); - return (s7_cadadr (lst)); -} - -s7_pointer -g_caddar (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - if (!s7_is_pair (lst)) - return (s7i_sole_arg_method_or_bust (sc, lst, "caddar", args, "a pair")); - if (!s7_is_pair (s7_car (lst))) - return (s7_wrong_type_arg_error (sc, "caddar", 1, lst, - "a pair whose car is also a pair")); - if (!s7_is_pair (s7_cdar (lst))) - return (s7_wrong_type_arg_error (sc, "caddar", 1, lst, - "a pair whose cdar is also a pair")); - if (!s7_is_pair (s7_cddar (lst))) - return (s7_wrong_type_arg_error (sc, "caddar", 1, lst, - "a pair whose cddar is also a pair")); - return (s7_caddar (lst)); -} - -s7_pointer -g_cdaaar (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - if (!s7_is_pair (lst)) - return (s7i_sole_arg_method_or_bust (sc, lst, "cdaaar", args, "a pair")); - if (!s7_is_pair (s7_car (lst))) - return (s7_wrong_type_arg_error (sc, "cdaaar", 1, lst, - "a pair whose car is also a pair")); - if (!s7_is_pair (s7_caar (lst))) - return (s7_wrong_type_arg_error (sc, "cdaaar", 1, lst, - "a pair whose caar is also a pair")); - if (!s7_is_pair (s7_caaar (lst))) - return (s7_wrong_type_arg_error (sc, "cdaaar", 1, lst, - "a pair whose caaar is also a pair")); - return (s7_cdaaar (lst)); -} - -s7_pointer -g_cdaadr (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - if (!s7_is_pair (lst)) - return (s7i_sole_arg_method_or_bust (sc, lst, "cdaadr", args, "a pair")); - if (!s7_is_pair (s7_cdr (lst))) - return (s7_wrong_type_arg_error (sc, "cdaadr", 1, lst, - "a pair whose cdr is also a pair")); - if (!s7_is_pair (s7_cadr (lst))) - return (s7_wrong_type_arg_error (sc, "cdaadr", 1, lst, - "a pair whose cadr is also a pair")); - if (!s7_is_pair (s7_caadr (lst))) - return (s7_wrong_type_arg_error (sc, "cdaadr", 1, lst, - "a pair whose caadr is also a pair")); - return (s7_cdaadr (lst)); -} - -s7_pointer -g_cdadar (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - if (!s7_is_pair (lst)) - return (s7i_sole_arg_method_or_bust (sc, lst, "cdadar", args, "a pair")); - if (!s7_is_pair (s7_car (lst))) - return (s7_wrong_type_arg_error (sc, "cdadar", 1, lst, - "a pair whose car is also a pair")); - if (!s7_is_pair (s7_cdar (lst))) - return (s7_wrong_type_arg_error (sc, "cdadar", 1, lst, - "a pair whose cdar is also a pair")); - if (!s7_is_pair (s7_cadar (lst))) - return (s7_wrong_type_arg_error (sc, "cdadar", 1, lst, - "a pair whose cadar is also a pair")); - return (s7_cdadar (lst)); -} - -s7_pointer -g_cddaar (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - if (!s7_is_pair (lst)) - return (s7i_sole_arg_method_or_bust (sc, lst, "cddaar", args, "a pair")); - if (!s7_is_pair (s7_car (lst))) - return (s7_wrong_type_arg_error (sc, "cddaar", 1, lst, - "a pair whose car is also a pair")); - if (!s7_is_pair (s7_caar (lst))) - return (s7_wrong_type_arg_error (sc, "cddaar", 1, lst, - "a pair whose caar is also a pair")); - if (!s7_is_pair (s7_cdaar (lst))) - return (s7_wrong_type_arg_error (sc, "cddaar", 1, lst, - "a pair whose cdaar is also a pair")); - return (s7_cddaar (lst)); -} - -s7_pointer -g_cdaddr (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - if (!s7_is_pair (lst)) - return (s7i_sole_arg_method_or_bust (sc, lst, "cdaddr", args, "a pair")); - if (!s7_is_pair (s7_cdr (lst))) - return (s7_wrong_type_arg_error (sc, "cdaddr", 1, lst, - "a pair whose cdr is also a pair")); - if (!s7_is_pair (s7_cddr (lst))) - return (s7_wrong_type_arg_error (sc, "cdaddr", 1, lst, - "a pair whose cddr is also a pair")); - if (!s7_is_pair (s7_caddr (lst))) - return (s7_wrong_type_arg_error (sc, "cdaddr", 1, lst, - "a pair whose caddr is also a pair")); - return (s7_cdaddr (lst)); -} - -s7_pointer -g_cddddr (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - if (!s7_is_pair (lst)) - return (s7i_sole_arg_method_or_bust (sc, lst, "cddddr", args, "a pair")); - if (!s7_is_pair (s7_cdr (lst))) - return (s7_wrong_type_arg_error (sc, "cddddr", 1, lst, - "a pair whose cdr is also a pair")); - if (!s7_is_pair (s7_cddr (lst))) - return (s7_wrong_type_arg_error (sc, "cddddr", 1, lst, - "a pair whose cddr is also a pair")); - if (!s7_is_pair (s7_cdddr (lst))) - return (s7_wrong_type_arg_error (sc, "cddddr", 1, lst, - "a pair whose cdddr is also a pair")); - return (s7_cddddr (lst)); -} - -s7_pointer -g_cddadr (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - if (!s7_is_pair (lst)) - return (s7i_sole_arg_method_or_bust (sc, lst, "cddadr", args, "a pair")); - if (!s7_is_pair (s7_cdr (lst))) - return (s7_wrong_type_arg_error (sc, "cddadr", 1, lst, - "a pair whose cdr is also a pair")); - if (!s7_is_pair (s7_cadr (lst))) - return (s7_wrong_type_arg_error (sc, "cddadr", 1, lst, - "a pair whose cadr is also a pair")); - if (!s7_is_pair (s7_cdadr (lst))) - return (s7_wrong_type_arg_error (sc, "cddadr", 1, lst, - "a pair whose cdadr is also a pair")); - return (s7_cddadr (lst)); -} - -s7_pointer -g_cdddar (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - if (!s7_is_pair (lst)) - return (s7i_sole_arg_method_or_bust (sc, lst, "cdddar", args, "a pair")); - if (!s7_is_pair (s7_car (lst))) - return (s7_wrong_type_arg_error (sc, "cdddar", 1, lst, - "a pair whose car is also a pair")); - if (!s7_is_pair (s7_cdar (lst))) - return (s7_wrong_type_arg_error (sc, "cdddar", 1, lst, - "a pair whose cdar is also a pair")); - if (!s7_is_pair (s7_cddar (lst))) - return (s7_wrong_type_arg_error (sc, "cdddar", 1, lst, - "a pair whose cddar is also a pair")); - return (s7_cdddar (lst)); -} - -s7_pointer -g_set_car (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - s7_pointer val= s7_cadr (args); - if (s7_is_pair (lst) && !s7_is_immutable (lst)) - return (s7_set_car (lst, val)); - if (!s7_is_pair (lst)) - return (s7_wrong_type_arg_error (sc, "set-car!", 1, lst, "a pair")); - return (s7_wrong_type_arg_error (sc, "set-car!", 1, lst, "a mutable pair")); -} - -s7_pointer -g_set_cdr (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - s7_pointer val= s7_cadr (args); - if (s7_is_pair (lst) && !s7_is_immutable (lst)) - return (s7_set_cdr (lst, val)); - if (!s7_is_pair (lst)) - return (s7_wrong_type_arg_error (sc, "set-cdr!", 1, lst, "a pair")); - return (s7_wrong_type_arg_error (sc, "set-cdr!", 1, lst, "a mutable pair")); -} - -s7_pointer -g_list_ref (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - s7_pointer ind= s7_cadr (args); - if (!s7_is_pair (lst)) - return (s7i_method_or_bust (sc, lst, "list-ref", args, "a pair", 1)); - if (!s7_is_integer (ind)) - return (s7i_method_or_bust (sc, ind, "list-ref", args, "an integer", 2)); - s7_int index= s7_integer (ind); +/* -------------------------------- proper-list? -------------------------------- */ + +s7_pointer g_is_proper_list(s7_scheme *sc, s7_pointer args) +{ + return(s7_make_boolean(sc, s7_is_proper_list(sc, s7_car(args)))); +} + +s7_pointer g_car(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + if (s7_is_pair(lst)) return(s7_car(lst)); + return(s7i_sole_arg_method_or_bust(sc, lst, "car", args, "a pair")); +} + +s7_pointer g_cdr(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + if (s7_is_pair(lst)) return(s7_cdr(lst)); + return(s7i_sole_arg_method_or_bust(sc, lst, "cdr", args, "a pair")); +} + +s7_pointer g_caar(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + if (!s7_is_pair(lst)) + return(s7i_sole_arg_method_or_bust(sc, lst, "caar", args, "a pair")); + if (!s7_is_pair(s7_car(lst))) + return(s7_wrong_type_arg_error(sc, "caar", 1, lst, "a pair whose car is also a pair")); + return(s7_caar(lst)); +} + +s7_pointer g_cadr(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + if (!s7_is_pair(lst)) + return(s7i_sole_arg_method_or_bust(sc, lst, "cadr", args, "a pair")); + if (!s7_is_pair(s7_cdr(lst))) + return(s7_wrong_type_arg_error(sc, "cadr", 1, lst, "a pair whose cdr is also a pair")); + return(s7_cadr(lst)); +} + +s7_pointer g_cdar(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + if (!s7_is_pair(lst)) + return(s7i_sole_arg_method_or_bust(sc, lst, "cdar", args, "a pair")); + if (!s7_is_pair(s7_car(lst))) + return(s7_wrong_type_arg_error(sc, "cdar", 1, lst, "a pair whose car is also a pair")); + return(s7_cdar(lst)); +} + +s7_pointer g_cddr(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + if (!s7_is_pair(lst)) + return(s7i_sole_arg_method_or_bust(sc, lst, "cddr", args, "a pair")); + if (!s7_is_pair(s7_cdr(lst))) + return(s7_wrong_type_arg_error(sc, "cddr", 1, lst, "a pair whose cdr is also a pair")); + return(s7_cddr(lst)); +} + +/* -------------------------------- 3-level cxxxr -------------------------------- */ + +s7_pointer g_caaar(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + if (!s7_is_pair(lst)) + return(s7i_sole_arg_method_or_bust(sc, lst, "caaar", args, "a pair")); + if (!s7_is_pair(s7_car(lst))) + return(s7_wrong_type_arg_error(sc, "caaar", 1, lst, "a pair whose car is also a pair")); + if (!s7_is_pair(s7_caar(lst))) + return(s7_wrong_type_arg_error(sc, "caaar", 1, lst, "a pair whose caar is also a pair")); + return(s7_caaar(lst)); +} + +s7_pointer g_caadr(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + if (!s7_is_pair(lst)) + return(s7i_sole_arg_method_or_bust(sc, lst, "caadr", args, "a pair")); + if (!s7_is_pair(s7_cdr(lst))) + return(s7_wrong_type_arg_error(sc, "caadr", 1, lst, "a pair whose cdr is also a pair")); + if (!s7_is_pair(s7_cadr(lst))) + return(s7_wrong_type_arg_error(sc, "caadr", 1, lst, "a pair whose cadr is also a pair")); + return(s7_caadr(lst)); +} + +s7_pointer g_cadar(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + if (!s7_is_pair(lst)) + return(s7i_sole_arg_method_or_bust(sc, lst, "cadar", args, "a pair")); + if (!s7_is_pair(s7_car(lst))) + return(s7_wrong_type_arg_error(sc, "cadar", 1, lst, "a pair whose car is also a pair")); + if (!s7_is_pair(s7_cdar(lst))) + return(s7_wrong_type_arg_error(sc, "cadar", 1, lst, "a pair whose cdar is also a pair")); + return(s7_cadar(lst)); +} + +s7_pointer g_caddr(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + if (!s7_is_pair(lst)) + return(s7i_sole_arg_method_or_bust(sc, lst, "caddr", args, "a pair")); + if (!s7_is_pair(s7_cdr(lst))) + return(s7_wrong_type_arg_error(sc, "caddr", 1, lst, "a pair whose cdr is also a pair")); + if (!s7_is_pair(s7_cddr(lst))) + return(s7_wrong_type_arg_error(sc, "caddr", 1, lst, "a pair whose cddr is also a pair")); + return(s7_caddr(lst)); +} + +s7_pointer g_cdaar(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + if (!s7_is_pair(lst)) + return(s7i_sole_arg_method_or_bust(sc, lst, "cdaar", args, "a pair")); + if (!s7_is_pair(s7_car(lst))) + return(s7_wrong_type_arg_error(sc, "cdaar", 1, lst, "a pair whose car is also a pair")); + if (!s7_is_pair(s7_caar(lst))) + return(s7_wrong_type_arg_error(sc, "cdaar", 1, lst, "a pair whose caar is also a pair")); + return(s7_cdaar(lst)); +} + +s7_pointer g_cdddr(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + if (!s7_is_pair(lst)) + return(s7i_sole_arg_method_or_bust(sc, lst, "cdddr", args, "a pair")); + if (!s7_is_pair(s7_cdr(lst))) + return(s7_wrong_type_arg_error(sc, "cdddr", 1, lst, "a pair whose cdr is also a pair")); + if (!s7_is_pair(s7_cddr(lst))) + return(s7_wrong_type_arg_error(sc, "cdddr", 1, lst, "a pair whose cddr is also a pair")); + return(s7_cdddr(lst)); +} + +s7_pointer g_cdadr(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + if (!s7_is_pair(lst)) + return(s7i_sole_arg_method_or_bust(sc, lst, "cdadr", args, "a pair")); + if (!s7_is_pair(s7_cdr(lst))) + return(s7_wrong_type_arg_error(sc, "cdadr", 1, lst, "a pair whose cdr is also a pair")); + if (!s7_is_pair(s7_cadr(lst))) + return(s7_wrong_type_arg_error(sc, "cdadr", 1, lst, "a pair whose cadr is also a pair")); + return(s7_cdadr(lst)); +} + +s7_pointer g_cddar(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + if (!s7_is_pair(lst)) + return(s7i_sole_arg_method_or_bust(sc, lst, "cddar", args, "a pair")); + if (!s7_is_pair(s7_car(lst))) + return(s7_wrong_type_arg_error(sc, "cddar", 1, lst, "a pair whose car is also a pair")); + if (!s7_is_pair(s7_cdar(lst))) + return(s7_wrong_type_arg_error(sc, "cddar", 1, lst, "a pair whose cdar is also a pair")); + return(s7_cddar(lst)); +} + +/* -------------------------------- 4-level cxxxr -------------------------------- */ + +s7_pointer g_caaaar(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + if (!s7_is_pair(lst)) + return(s7i_sole_arg_method_or_bust(sc, lst, "caaaar", args, "a pair")); + if (!s7_is_pair(s7_car(lst))) + return(s7_wrong_type_arg_error(sc, "caaaar", 1, lst, "a pair whose car is also a pair")); + if (!s7_is_pair(s7_caar(lst))) + return(s7_wrong_type_arg_error(sc, "caaaar", 1, lst, "a pair whose caar is also a pair")); + if (!s7_is_pair(s7_caaar(lst))) + return(s7_wrong_type_arg_error(sc, "caaaar", 1, lst, "a pair whose caaar is also a pair")); + return(s7_caaaar(lst)); +} + +s7_pointer g_caaadr(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + if (!s7_is_pair(lst)) + return(s7i_sole_arg_method_or_bust(sc, lst, "caaadr", args, "a pair")); + if (!s7_is_pair(s7_cdr(lst))) + return(s7_wrong_type_arg_error(sc, "caaadr", 1, lst, "a pair whose cdr is also a pair")); + if (!s7_is_pair(s7_cadr(lst))) + return(s7_wrong_type_arg_error(sc, "caaadr", 1, lst, "a pair whose cadr is also a pair")); + if (!s7_is_pair(s7_caadr(lst))) + return(s7_wrong_type_arg_error(sc, "caaadr", 1, lst, "a pair whose caadr is also a pair")); + return(s7_caaadr(lst)); +} + +s7_pointer g_caadar(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + if (!s7_is_pair(lst)) + return(s7i_sole_arg_method_or_bust(sc, lst, "caadar", args, "a pair")); + if (!s7_is_pair(s7_car(lst))) + return(s7_wrong_type_arg_error(sc, "caadar", 1, lst, "a pair whose car is also a pair")); + if (!s7_is_pair(s7_cdar(lst))) + return(s7_wrong_type_arg_error(sc, "caadar", 1, lst, "a pair whose cdar is also a pair")); + if (!s7_is_pair(s7_cadar(lst))) + return(s7_wrong_type_arg_error(sc, "caadar", 1, lst, "a pair whose cadar is also a pair")); + return(s7_caadar(lst)); +} + +s7_pointer g_cadaar(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + if (!s7_is_pair(lst)) + return(s7i_sole_arg_method_or_bust(sc, lst, "cadaar", args, "a pair")); + if (!s7_is_pair(s7_car(lst))) + return(s7_wrong_type_arg_error(sc, "cadaar", 1, lst, "a pair whose car is also a pair")); + if (!s7_is_pair(s7_caar(lst))) + return(s7_wrong_type_arg_error(sc, "cadaar", 1, lst, "a pair whose caar is also a pair")); + if (!s7_is_pair(s7_cdaar(lst))) + return(s7_wrong_type_arg_error(sc, "cadaar", 1, lst, "a pair whose cdaar is also a pair")); + return(s7_cadaar(lst)); +} + +s7_pointer g_caaddr(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + if (!s7_is_pair(lst)) + return(s7i_sole_arg_method_or_bust(sc, lst, "caaddr", args, "a pair")); + if (!s7_is_pair(s7_cdr(lst))) + return(s7_wrong_type_arg_error(sc, "caaddr", 1, lst, "a pair whose cdr is also a pair")); + if (!s7_is_pair(s7_cddr(lst))) + return(s7_wrong_type_arg_error(sc, "caaddr", 1, lst, "a pair whose cddr is also a pair")); + if (!s7_is_pair(s7_caddr(lst))) + return(s7_wrong_type_arg_error(sc, "caaddr", 1, lst, "a pair whose caddr is also a pair")); + return(s7_caaddr(lst)); +} + +s7_pointer g_cadddr(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + if (!s7_is_pair(lst)) + return(s7i_sole_arg_method_or_bust(sc, lst, "cadddr", args, "a pair")); + if (!s7_is_pair(s7_cdr(lst))) + return(s7_wrong_type_arg_error(sc, "cadddr", 1, lst, "a pair whose cdr is also a pair")); + if (!s7_is_pair(s7_cddr(lst))) + return(s7_wrong_type_arg_error(sc, "cadddr", 1, lst, "a pair whose cddr is also a pair")); + if (!s7_is_pair(s7_cdddr(lst))) + return(s7_wrong_type_arg_error(sc, "cadddr", 1, lst, "a pair whose cdddr is also a pair")); + return(s7_cadddr(lst)); +} + +s7_pointer g_cadadr(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + if (!s7_is_pair(lst)) + return(s7i_sole_arg_method_or_bust(sc, lst, "cadadr", args, "a pair")); + if (!s7_is_pair(s7_cdr(lst))) + return(s7_wrong_type_arg_error(sc, "cadadr", 1, lst, "a pair whose cdr is also a pair")); + if (!s7_is_pair(s7_cadr(lst))) + return(s7_wrong_type_arg_error(sc, "cadadr", 1, lst, "a pair whose cadr is also a pair")); + if (!s7_is_pair(s7_cdadr(lst))) + return(s7_wrong_type_arg_error(sc, "cadadr", 1, lst, "a pair whose cdadr is also a pair")); + return(s7_cadadr(lst)); +} + +s7_pointer g_caddar(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + if (!s7_is_pair(lst)) + return(s7i_sole_arg_method_or_bust(sc, lst, "caddar", args, "a pair")); + if (!s7_is_pair(s7_car(lst))) + return(s7_wrong_type_arg_error(sc, "caddar", 1, lst, "a pair whose car is also a pair")); + if (!s7_is_pair(s7_cdar(lst))) + return(s7_wrong_type_arg_error(sc, "caddar", 1, lst, "a pair whose cdar is also a pair")); + if (!s7_is_pair(s7_cddar(lst))) + return(s7_wrong_type_arg_error(sc, "caddar", 1, lst, "a pair whose cddar is also a pair")); + return(s7_caddar(lst)); +} + +s7_pointer g_cdaaar(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + if (!s7_is_pair(lst)) + return(s7i_sole_arg_method_or_bust(sc, lst, "cdaaar", args, "a pair")); + if (!s7_is_pair(s7_car(lst))) + return(s7_wrong_type_arg_error(sc, "cdaaar", 1, lst, "a pair whose car is also a pair")); + if (!s7_is_pair(s7_caar(lst))) + return(s7_wrong_type_arg_error(sc, "cdaaar", 1, lst, "a pair whose caar is also a pair")); + if (!s7_is_pair(s7_caaar(lst))) + return(s7_wrong_type_arg_error(sc, "cdaaar", 1, lst, "a pair whose caaar is also a pair")); + return(s7_cdaaar(lst)); +} + +s7_pointer g_cdaadr(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + if (!s7_is_pair(lst)) + return(s7i_sole_arg_method_or_bust(sc, lst, "cdaadr", args, "a pair")); + if (!s7_is_pair(s7_cdr(lst))) + return(s7_wrong_type_arg_error(sc, "cdaadr", 1, lst, "a pair whose cdr is also a pair")); + if (!s7_is_pair(s7_cadr(lst))) + return(s7_wrong_type_arg_error(sc, "cdaadr", 1, lst, "a pair whose cadr is also a pair")); + if (!s7_is_pair(s7_caadr(lst))) + return(s7_wrong_type_arg_error(sc, "cdaadr", 1, lst, "a pair whose caadr is also a pair")); + return(s7_cdaadr(lst)); +} + +s7_pointer g_cdadar(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + if (!s7_is_pair(lst)) + return(s7i_sole_arg_method_or_bust(sc, lst, "cdadar", args, "a pair")); + if (!s7_is_pair(s7_car(lst))) + return(s7_wrong_type_arg_error(sc, "cdadar", 1, lst, "a pair whose car is also a pair")); + if (!s7_is_pair(s7_cdar(lst))) + return(s7_wrong_type_arg_error(sc, "cdadar", 1, lst, "a pair whose cdar is also a pair")); + if (!s7_is_pair(s7_cadar(lst))) + return(s7_wrong_type_arg_error(sc, "cdadar", 1, lst, "a pair whose cadar is also a pair")); + return(s7_cdadar(lst)); +} + +s7_pointer g_cddaar(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + if (!s7_is_pair(lst)) + return(s7i_sole_arg_method_or_bust(sc, lst, "cddaar", args, "a pair")); + if (!s7_is_pair(s7_car(lst))) + return(s7_wrong_type_arg_error(sc, "cddaar", 1, lst, "a pair whose car is also a pair")); + if (!s7_is_pair(s7_caar(lst))) + return(s7_wrong_type_arg_error(sc, "cddaar", 1, lst, "a pair whose caar is also a pair")); + if (!s7_is_pair(s7_cdaar(lst))) + return(s7_wrong_type_arg_error(sc, "cddaar", 1, lst, "a pair whose cdaar is also a pair")); + return(s7_cddaar(lst)); +} + +s7_pointer g_cdaddr(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + if (!s7_is_pair(lst)) + return(s7i_sole_arg_method_or_bust(sc, lst, "cdaddr", args, "a pair")); + if (!s7_is_pair(s7_cdr(lst))) + return(s7_wrong_type_arg_error(sc, "cdaddr", 1, lst, "a pair whose cdr is also a pair")); + if (!s7_is_pair(s7_cddr(lst))) + return(s7_wrong_type_arg_error(sc, "cdaddr", 1, lst, "a pair whose cddr is also a pair")); + if (!s7_is_pair(s7_caddr(lst))) + return(s7_wrong_type_arg_error(sc, "cdaddr", 1, lst, "a pair whose caddr is also a pair")); + return(s7_cdaddr(lst)); +} + +s7_pointer g_cddddr(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + if (!s7_is_pair(lst)) + return(s7i_sole_arg_method_or_bust(sc, lst, "cddddr", args, "a pair")); + if (!s7_is_pair(s7_cdr(lst))) + return(s7_wrong_type_arg_error(sc, "cddddr", 1, lst, "a pair whose cdr is also a pair")); + if (!s7_is_pair(s7_cddr(lst))) + return(s7_wrong_type_arg_error(sc, "cddddr", 1, lst, "a pair whose cddr is also a pair")); + if (!s7_is_pair(s7_cdddr(lst))) + return(s7_wrong_type_arg_error(sc, "cddddr", 1, lst, "a pair whose cdddr is also a pair")); + return(s7_cddddr(lst)); +} + +s7_pointer g_cddadr(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + if (!s7_is_pair(lst)) + return(s7i_sole_arg_method_or_bust(sc, lst, "cddadr", args, "a pair")); + if (!s7_is_pair(s7_cdr(lst))) + return(s7_wrong_type_arg_error(sc, "cddadr", 1, lst, "a pair whose cdr is also a pair")); + if (!s7_is_pair(s7_cadr(lst))) + return(s7_wrong_type_arg_error(sc, "cddadr", 1, lst, "a pair whose cadr is also a pair")); + if (!s7_is_pair(s7_cdadr(lst))) + return(s7_wrong_type_arg_error(sc, "cddadr", 1, lst, "a pair whose cdadr is also a pair")); + return(s7_cddadr(lst)); +} + +s7_pointer g_cdddar(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + if (!s7_is_pair(lst)) + return(s7i_sole_arg_method_or_bust(sc, lst, "cdddar", args, "a pair")); + if (!s7_is_pair(s7_car(lst))) + return(s7_wrong_type_arg_error(sc, "cdddar", 1, lst, "a pair whose car is also a pair")); + if (!s7_is_pair(s7_cdar(lst))) + return(s7_wrong_type_arg_error(sc, "cdddar", 1, lst, "a pair whose cdar is also a pair")); + if (!s7_is_pair(s7_cddar(lst))) + return(s7_wrong_type_arg_error(sc, "cdddar", 1, lst, "a pair whose cddar is also a pair")); + return(s7_cdddar(lst)); +} + +s7_pointer g_set_car(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + s7_pointer val = s7_cadr(args); + if (s7_is_pair(lst) && !s7_is_immutable(lst)) + return(s7_set_car(lst, val)); + if (!s7_is_pair(lst)) + return(s7_wrong_type_arg_error(sc, "set-car!", 1, lst, "a pair")); + return(s7_wrong_type_arg_error(sc, "set-car!", 1, lst, "a mutable pair")); +} + +s7_pointer g_set_cdr(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + s7_pointer val = s7_cadr(args); + if (s7_is_pair(lst) && !s7_is_immutable(lst)) + return(s7_set_cdr(lst, val)); + if (!s7_is_pair(lst)) + return(s7_wrong_type_arg_error(sc, "set-cdr!", 1, lst, "a pair")); + return(s7_wrong_type_arg_error(sc, "set-cdr!", 1, lst, "a mutable pair")); +} + +s7_pointer g_list_ref(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + s7_pointer ind = s7_cadr(args); + if (!s7_is_pair(lst)) + return(s7i_method_or_bust(sc, lst, "list-ref", args, "a pair", 1)); + if (!s7_is_integer(ind)) + return(s7i_method_or_bust(sc, ind, "list-ref", args, "an integer", 2)); + s7_int index = s7_integer(ind); if (index < 0) - return (s7_out_of_range_error (sc, "list-ref", 2, ind, "it is negative")); - s7_pointer p= lst; - for (s7_int i= 0; (i < index) && s7_is_pair (p); i++) - p= s7_cdr (p); - if (!s7_is_pair (p)) - return (s7_out_of_range_error (sc, "list-ref", 2, ind, "it is too large")); - return (s7_car (p)); -} - -s7_pointer -g_list_tail (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - s7_pointer ind= s7_cadr (args); - if (!s7_is_integer (ind)) - return (s7i_method_or_bust (sc, ind, "list-tail", args, "an integer", 2)); - if (!s7_is_pair (lst) && !s7_is_null (sc, lst)) - return (s7i_method_or_bust (sc, lst, "list-tail", args, "a list", 1)); - s7_int index= s7_integer (ind); + return(s7_out_of_range_error(sc, "list-ref", 2, ind, "it is negative")); + s7_pointer p = lst; + for (s7_int i = 0; (i < index) && s7_is_pair(p); i++) + p = s7_cdr(p); + if (!s7_is_pair(p)) + return(s7_out_of_range_error(sc, "list-ref", 2, ind, "it is too large")); + return(s7_car(p)); +} + +s7_pointer g_list_tail(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + s7_pointer ind = s7_cadr(args); + if (!s7_is_integer(ind)) + return(s7i_method_or_bust(sc, ind, "list-tail", args, "an integer", 2)); + if (!s7_is_pair(lst) && !s7_is_null(sc, lst)) + return(s7i_method_or_bust(sc, lst, "list-tail", args, "a list", 1)); + s7_int index = s7_integer(ind); if (index < 0) - return (s7_out_of_range_error (sc, "list-tail", 2, ind, "it is negative")); - s7_pointer p= lst; - s7_int i; - for (i= 0; (i < index) && s7_is_pair (p); i++) - p= s7_cdr (p); + return(s7_out_of_range_error(sc, "list-tail", 2, ind, "it is negative")); + s7_pointer p = lst; + s7_int i; + for (i = 0; (i < index) && s7_is_pair(p); i++) + p = s7_cdr(p); if (i < index) - return (s7_out_of_range_error (sc, "list-tail", 2, ind, "it is too large")); - return (p); + return(s7_out_of_range_error(sc, "list-tail", 2, ind, "it is too large")); + return(p); } -s7_pointer -g_cons (s7_scheme* sc, s7_pointer args) { - return (s7_cons (sc, s7_car (args), s7_cadr (args))); +s7_pointer g_cons(s7_scheme *sc, s7_pointer args) +{ + return(s7_cons(sc, s7_car(args), s7_cadr(args))); } /* -------------------------------- filter -------------------------------- */ -s7_pointer -g_filter (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_cadr (args); - if (!s7_is_pair (lst)) { - if (s7_is_null (sc, lst)) return (s7_nil (sc)); - return (s7_wrong_type_arg_error (sc, "filter", 2, lst, "a proper list")); - } - /* args may live in evaluator-recycled cells, so keep pred and lst in our own - * pairs. anchor = ((pred lst) . work), work's car holds the reversed kept - * elements before the current all-passing run, work's cdr later holds the - * result; one protected pair keeps everything GC-reachable while pred runs */ - s7_pointer keep= s7_cons (sc, s7_car (args), s7_cons (sc, lst, s7_nil (sc))); - s7_pointer anchor= s7_cons (sc, keep, s7_cons (sc, s7_nil (sc), s7_nil (sc))); - s7_gc_protect_via_stack (sc, anchor); - s7_pointer work = s7_cdr (anchor); - s7_pointer pred = s7_car (keep); - s7_pointer run_start= NULL; - s7_pointer p = lst; - while (s7_is_pair (p)) { - if (s7i_is_true (sc, s7_apply_function ( - sc, pred, s7i_set_plist_1 (sc, s7_car (p))))) { - if (!run_start) run_start= p; - } - else { - if (run_start) { - for (s7_pointer q= run_start; q != p; q= s7_cdr (q)) - s7_set_car (work, s7_cons (sc, s7_car (q), s7_car (work))); - run_start= NULL; - } - } - p= s7_cdr (p); - } - if (!s7_is_null (sc, p)) { - s7_gc_unprotect_via_stack (sc, anchor); - return (s7_wrong_type_arg_error (sc, "filter", 2, lst, "a proper list")); - } +s7_pointer g_filter(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_cadr(args); + if (!s7_is_pair(lst)) + { + if (s7_is_null(sc, lst)) return(s7_nil(sc)); + return(s7_wrong_type_arg_error(sc, "filter", 2, lst, "a proper list")); + } + /* args may live in evaluator-recycled cells, so keep pred and lst in our own pairs. + * anchor = ((pred lst) . work), work's car holds the reversed kept elements before + * the current all-passing run, work's cdr later holds the result; one protected + * pair keeps everything GC-reachable while pred runs */ + s7_pointer keep = s7_cons(sc, s7_car(args), s7_cons(sc, lst, s7_nil(sc))); + s7_pointer anchor = s7_cons(sc, keep, s7_cons(sc, s7_nil(sc), s7_nil(sc))); + s7_gc_protect_via_stack(sc, anchor); + s7_pointer work = s7_cdr(anchor); + s7_pointer pred = s7_car(keep); + s7_pointer run_start = NULL; + s7_pointer p = lst; + while (s7_is_pair(p)) + { + if (s7i_is_true(sc, s7_apply_function(sc, pred, s7i_set_plist_1(sc, s7_car(p))))) + { + if (!run_start) run_start = p; + } + else + { + if (run_start) + { + for (s7_pointer q = run_start; q != p; q = s7_cdr(q)) + s7_set_car(work, s7_cons(sc, s7_car(q), s7_car(work))); + run_start = NULL; + } + } + p = s7_cdr(p); + } + if (!s7_is_null(sc, p)) + { + s7_gc_unprotect_via_stack(sc, anchor); + return(s7_wrong_type_arg_error(sc, "filter", 2, lst, "a proper list")); + } /* share the longest all-passing suffix, like the reference implementation */ - s7_pointer result= (run_start) ? run_start : s7_nil (sc); - s7_set_cdr (work, result); - for (s7_pointer q= s7_car (work); s7_is_pair (q); q= s7_cdr (q)) { - result= s7_cons (sc, s7_car (q), result); - s7_set_cdr (work, result); - } - s7_gc_unprotect_via_stack (sc, anchor); - return (result); + s7_pointer result = (run_start) ? run_start : s7_nil(sc); + s7_set_cdr(work, result); + for (s7_pointer q = s7_car(work); s7_is_pair(q); q = s7_cdr(q)) + { + result = s7_cons(sc, s7_car(q), result); + s7_set_cdr(work, result); + } + s7_gc_unprotect_via_stack(sc, anchor); + return(result); +} + +/* -------------------------------- find -------------------------------- */ + +s7_pointer g_find(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_cadr(args); + /* args may live in evaluator-recycled cells, so keep pred and lst in our own + * protected pair; the walking pointer and the current element stay + * GC-reachable through lst while pred runs */ + s7_pointer keep = s7_cons(sc, s7_car(args), s7_cons(sc, lst, s7_nil(sc))); + s7_gc_protect_via_stack(sc, keep); + s7_pointer pred = s7_car(keep); + s7_pointer p = lst; + while (s7_is_pair(p)) + { + s7_pointer elem = s7_car(p); + if (s7i_is_true(sc, s7_apply_function(sc, pred, s7i_set_plist_1(sc, elem)))) + { + s7_gc_unprotect_via_stack(sc, keep); + return(elem); + } + p = s7_cdr(p); + } + s7_gc_unprotect_via_stack(sc, keep); + if (!s7_is_null(sc, p)) + return(s7_wrong_type_arg_error(sc, "find", 2, lst, "a proper list")); + return(s7_f(sc)); +} + +/* -------------------------------- any -------------------------------- */ + +s7_pointer g_any(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_cadr(args); + /* same GC pattern as g_find: keep pred and lst anchored in our own + * protected pair while pred runs */ + s7_pointer keep = s7_cons(sc, s7_car(args), s7_cons(sc, lst, s7_nil(sc))); + s7_gc_protect_via_stack(sc, keep); + s7_pointer pred = s7_car(keep); + s7_pointer p = lst; + while (s7_is_pair(p)) + { + if (s7i_is_true(sc, s7_apply_function(sc, pred, s7i_set_plist_1(sc, s7_car(p))))) + { + s7_gc_unprotect_via_stack(sc, keep); + return(s7_t(sc)); + } + p = s7_cdr(p); + } + s7_gc_unprotect_via_stack(sc, keep); + if (!s7_is_null(sc, p)) + return(s7_wrong_type_arg_error(sc, "any", 2, lst, "a proper list")); + return(s7_f(sc)); +} + +/* -------------------------------- every -------------------------------- */ + +s7_pointer g_every(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_cadr(args); + /* same GC pattern as g_find: keep pred and lst anchored in our own + * protected pair while pred runs */ + s7_pointer keep = s7_cons(sc, s7_car(args), s7_cons(sc, lst, s7_nil(sc))); + s7_gc_protect_via_stack(sc, keep); + s7_pointer pred = s7_car(keep); + s7_pointer p = lst; + while (s7_is_pair(p)) + { + if (!s7i_is_true(sc, s7_apply_function(sc, pred, s7i_set_plist_1(sc, s7_car(p))))) + { + s7_gc_unprotect_via_stack(sc, keep); + return(s7_f(sc)); + } + p = s7_cdr(p); + } + s7_gc_unprotect_via_stack(sc, keep); + if (!s7_is_null(sc, p)) + return(s7_wrong_type_arg_error(sc, "every", 2, lst, "a proper list")); + return(s7_t(sc)); +} + +/* -------------------------------- count -------------------------------- */ + +s7_pointer g_count(s7_scheme *sc, s7_pointer args) +{ + /* (count pred clist1 clist2 ...) applies pred to one element of each list + * per iteration and returns the number of true results; the walk stops at + * the end of the shortest list */ + s7_pointer pred = s7_car(args); + if (!s7_is_procedure(pred)) + return(s7_wrong_type_arg_error(sc, "count", 1, pred, "a procedure")); + + s7_pointer rest = s7_cdr(args); /* (clist1 clist2 ...) */ + + if (s7_is_null(sc, s7_cdr(rest))) + { + /* single-list case: same GC pattern as g_any -- keep pred and lst + * anchored in our own protected pair while pred runs */ + s7_pointer lst = s7_car(rest); + s7_pointer keep = s7_cons(sc, pred, s7_cons(sc, lst, s7_nil(sc))); + s7_gc_protect_via_stack(sc, keep); + s7_pointer p = lst; + s7_int i = 0; + while (s7_is_pair(p)) + { + if (s7i_is_true(sc, s7_apply_function(sc, s7_car(keep), s7i_set_plist_1(sc, s7_car(p))))) + i++; + p = s7_cdr(p); + } + s7_gc_unprotect_via_stack(sc, keep); + if (!s7_is_null(sc, p)) + return(s7_wrong_type_arg_error(sc, "count", 2, lst, "a proper list")); + return(s7_make_integer(sc, i)); + } + + /* multi-list case: check properness up front (no Scheme callbacks here, so + * no GC concerns), then walk all lists in lockstep */ + for (s7_pointer lp = rest; s7_is_pair(lp); lp = s7_cdr(lp)) + if (!s7_is_proper_list(sc, s7_car(lp))) + return(s7_wrong_type_arg_error(sc, "count", 2, s7_car(lp), "a proper list")); + + /* keep pred, a slot for the current call args, and one "current position" + * cell per list (in argument order) in our own protected cells: the args + * cells may be recycled by the evaluator while pred runs; the slot sits at + * cadr so the position-cell walk below starts after it */ + s7_pointer anchor = s7_cons(sc, pred, s7_cons(sc, s7_cons(sc, s7_nil(sc), s7_nil(sc)), s7_nil(sc))); + s7_gc_protect_via_stack(sc, anchor); + s7_pointer tail = s7_cdr(anchor); /* (call-args-slot) */ + for (s7_pointer lp = rest; s7_is_pair(lp); lp = s7_cdr(lp)) + { + s7_set_cdr(tail, s7_cons(sc, s7_car(lp), s7_nil(sc))); + tail = s7_cdr(tail); + } + s7_pointer args_slot = s7_car(s7_cdr(anchor)); + + s7_int i = 0; + while (true) + { + /* build the call args from the current heads, linking each new pair + * into args_slot right after s7_cons so the growing list stays + * GC-reachable; advance the position cells in the same pass */ + s7_set_car(args_slot, s7_nil(sc)); + s7_pointer prev = NULL; + bool shortest_ended = false; + for (s7_pointer cell = s7_cdr(s7_cdr(anchor)); s7_is_pair(cell); cell = s7_cdr(cell)) + { + s7_pointer cur = s7_car(cell); + if (!s7_is_pair(cur)) + { + /* pre-checked above, so the shortest list just ended */ + shortest_ended = true; + break; + } + s7_pointer node = s7_cons(sc, s7_car(cur), s7_nil(sc)); + if (prev == NULL) + s7_set_car(args_slot, node); + else + s7_set_cdr(prev, node); + prev = node; + s7_set_car(cell, s7_cdr(cur)); + } + if (shortest_ended) + break; + if (s7i_is_true(sc, s7_apply_function(sc, s7_car(anchor), s7_car(args_slot)))) + i++; + } + s7_gc_unprotect_via_stack(sc, anchor); + return(s7_make_integer(sc, i)); +} + +/* ------------------------------ list-index ------------------------------ */ + +s7_pointer g_list_index(s7_scheme *sc, s7_pointer args) +{ + /* (list-index pred clist1 clist2 ...) applies pred to one element of each + * list per iteration and returns the index of the first true result, or #f; + * the walk stops at the end of the shortest list */ + s7_pointer pred = s7_car(args); + if (!s7_is_procedure(pred)) + return(s7_wrong_type_arg_error(sc, "list-index", 1, pred, "a procedure")); + + s7_pointer rest = s7_cdr(args); /* (clist1 clist2 ...) */ + + if (s7_is_null(sc, s7_cdr(rest))) + { + /* single-list case: same GC pattern as g_count -- keep pred and lst + * anchored in our own protected pair while pred runs; properness is + * checked lazily, so an early match returns without touching the tail */ + s7_pointer lst = s7_car(rest); + s7_pointer keep = s7_cons(sc, pred, s7_cons(sc, lst, s7_nil(sc))); + s7_gc_protect_via_stack(sc, keep); + s7_pointer p = lst; + s7_int i = 0; + while (s7_is_pair(p)) + { + if (s7i_is_true(sc, s7_apply_function(sc, s7_car(keep), s7i_set_plist_1(sc, s7_car(p))))) + { + s7_gc_unprotect_via_stack(sc, keep); + return(s7_make_integer(sc, i)); + } + i++; + p = s7_cdr(p); + } + s7_gc_unprotect_via_stack(sc, keep); + if (!s7_is_null(sc, p)) + return(s7_wrong_type_arg_error(sc, "list-index", 2, lst, "a proper list")); + return(s7_f(sc)); + } + + /* multi-list case: check properness up front (no Scheme callbacks here, so + * no GC concerns), then walk all lists in lockstep */ + for (s7_pointer lp = rest; s7_is_pair(lp); lp = s7_cdr(lp)) + if (!s7_is_proper_list(sc, s7_car(lp))) + return(s7_wrong_type_arg_error(sc, "list-index", 2, s7_car(lp), "a proper list")); + + /* same anchor layout as g_count: pred, a slot for the current call args, + * then one "current position" cell per list in argument order */ + s7_pointer anchor = s7_cons(sc, pred, s7_cons(sc, s7_cons(sc, s7_nil(sc), s7_nil(sc)), s7_nil(sc))); + s7_gc_protect_via_stack(sc, anchor); + s7_pointer tail = s7_cdr(anchor); /* (call-args-slot) */ + for (s7_pointer lp = rest; s7_is_pair(lp); lp = s7_cdr(lp)) + { + s7_set_cdr(tail, s7_cons(sc, s7_car(lp), s7_nil(sc))); + tail = s7_cdr(tail); + } + s7_pointer args_slot = s7_car(s7_cdr(anchor)); + + s7_int i = 0; + while (true) + { + /* build the call args from the current heads, linking each new pair + * into args_slot right after s7_cons so the growing list stays + * GC-reachable; advance the position cells in the same pass */ + s7_set_car(args_slot, s7_nil(sc)); + s7_pointer prev = NULL; + bool shortest_ended = false; + for (s7_pointer cell = s7_cdr(s7_cdr(anchor)); s7_is_pair(cell); cell = s7_cdr(cell)) + { + s7_pointer cur = s7_car(cell); + if (!s7_is_pair(cur)) + { + /* pre-checked above, so the shortest list just ended */ + shortest_ended = true; + break; + } + s7_pointer node = s7_cons(sc, s7_car(cur), s7_nil(sc)); + if (prev == NULL) + s7_set_car(args_slot, node); + else + s7_set_cdr(prev, node); + prev = node; + s7_set_car(cell, s7_cdr(cur)); + } + if (shortest_ended) + break; + if (s7i_is_true(sc, s7_apply_function(sc, s7_car(anchor), s7_car(args_slot)))) + { + s7_gc_unprotect_via_stack(sc, anchor); + return(s7_make_integer(sc, i)); + } + i++; + } + s7_gc_unprotect_via_stack(sc, anchor); + return(s7_f(sc)); +} + +/* -------------------------------- fold / fold-right -------------------------------- */ + +s7_pointer g_fold(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_caddr(args); + if (!s7_is_pair(lst)) + { + if (s7_is_null(sc, lst)) return(s7_cadr(args)); + return(s7_wrong_type_arg_error(sc, "fold", 3, lst, "a proper list")); + } + /* args may live in evaluator-recycled cells: keep f and lst in our own pairs, + * and the accumulator in a dedicated cell we rewrite each iteration, so every + * intermediate value stays GC-reachable while f runs */ + s7_pointer keep = s7_cons(sc, s7_car(args), lst); + s7_pointer anchor = s7_cons(sc, keep, s7_cons(sc, s7_cadr(args), s7_nil(sc))); + s7_gc_protect_via_stack(sc, anchor); + s7_pointer f = s7_car(keep); + s7_pointer acc_cell = s7_cdr(anchor); + s7_pointer p = lst; + while (s7_is_pair(p)) + { + s7_set_car(acc_cell, s7_apply_function(sc, f, s7i_set_plist_2(sc, s7_car(p), s7_car(acc_cell)))); + p = s7_cdr(p); + } + if (!s7_is_null(sc, p)) + { + s7_gc_unprotect_via_stack(sc, anchor); + return(s7_wrong_type_arg_error(sc, "fold", 3, lst, "a proper list")); + } + s7_pointer result = s7_car(acc_cell); + s7_gc_unprotect_via_stack(sc, anchor); + return(result); +} + +s7_pointer g_fold_right(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_caddr(args); + if (!s7_is_pair(lst)) + { + if (s7_is_null(sc, lst)) return(s7_cadr(args)); + return(s7_wrong_type_arg_error(sc, "fold-right", 3, lst, "a proper list")); + } + /* fold-right(f, init, (e1 ... en)) applies f from the right: + * f(e1, f(e2, ... f(en, init))), i.e. acc = f(elem, acc) walking elements + * in reverse; first copy the elements into a reversed list so the walk + * needs no Scheme-stack recursion */ + s7_pointer keep = s7_cons(sc, s7_car(args), lst); + s7_pointer anchor = s7_cons(sc, keep, s7_cons(sc, s7_cadr(args), s7_nil(sc))); + s7_gc_protect_via_stack(sc, anchor); + s7_pointer rev = s7_nil(sc); + s7_set_cdr(s7_cdr(anchor), rev); + s7_pointer p = lst; + while (s7_is_pair(p)) + { + rev = s7_cons(sc, s7_car(p), rev); + s7_set_cdr(s7_cdr(anchor), rev); + p = s7_cdr(p); + } + if (!s7_is_null(sc, p)) + { + s7_gc_unprotect_via_stack(sc, anchor); + return(s7_wrong_type_arg_error(sc, "fold-right", 3, lst, "a proper list")); + } + s7_pointer f = s7_car(keep); + s7_pointer acc_cell = s7_cdr(anchor); + while (s7_is_pair(rev)) + { + s7_set_car(acc_cell, s7_apply_function(sc, f, s7i_set_plist_2(sc, s7_car(rev), s7_car(acc_cell)))); + rev = s7_cdr(rev); + } + s7_pointer result = s7_car(acc_cell); + s7_gc_unprotect_via_stack(sc, anchor); + return(result); } /* -------------------------------- take -------------------------------- */ -s7_pointer -g_take (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - s7_pointer k = s7_cadr (args); - if (!s7_is_integer (k)) - return (s7_wrong_type_arg_error (sc, "take", 2, k, "an integer")); - s7_int n= s7_integer (k); +s7_pointer g_take(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + s7_pointer k = s7_cadr(args); + if (!s7_is_integer(k)) + return(s7_wrong_type_arg_error(sc, "take", 2, k, "an integer")); + s7_int n = s7_integer(k); if (n < 0) - return ( - s7_wrong_type_arg_error (sc, "take", 2, k, "a non-negative integer")); - if (n == 0) return (s7_nil (sc)); + return(s7_wrong_type_arg_error(sc, "take", 2, k, "a non-negative integer")); + if (n == 0) return(s7_nil(sc)); /* no Scheme callbacks here, so args stay put; only the result being built * needs a GC anchor, with each new pair linked in right after s7_cons */ - s7_pointer head= s7_cons (sc, s7_nil (sc), s7_nil (sc)); - s7_gc_protect_via_stack (sc, head); - s7_pointer tail= head; - s7_pointer p = lst; - for (s7_int i= 0; i < n; i++) { - if (!s7_is_pair (p)) { - s7_gc_unprotect_via_stack (sc, head); - return (s7_wrong_type_arg_error (sc, "take", 1, lst, - "a list of sufficient length")); - } - s7_set_cdr (tail, s7_cons (sc, s7_car (p), s7_nil (sc))); - tail= s7_cdr (tail); - p = s7_cdr (p); - } - s7_gc_unprotect_via_stack (sc, head); - return (s7_cdr (head)); + s7_pointer head = s7_cons(sc, s7_nil(sc), s7_nil(sc)); + s7_gc_protect_via_stack(sc, head); + s7_pointer tail = head; + s7_pointer p = lst; + for (s7_int i = 0; i < n; i++) + { + if (!s7_is_pair(p)) + { + s7_gc_unprotect_via_stack(sc, head); + return(s7_wrong_type_arg_error(sc, "take", 1, lst, "a list of sufficient length")); + } + s7_set_cdr(tail, s7_cons(sc, s7_car(p), s7_nil(sc))); + tail = s7_cdr(tail); + p = s7_cdr(p); + } + s7_gc_unprotect_via_stack(sc, head); + return(s7_cdr(head)); } -/* -------------------------------- take-right / drop-right - * -------------------------------- */ +/* -------------------------------- take-right / drop-right -------------------------------- */ /* shared lead walk: returns NULL on success (lead advanced n pairs), * otherwise the error object to return */ -static s7_pointer -take_right_lead (s7_scheme* sc, const char* name, s7_pointer lst, s7_pointer k, - s7_int n, s7_pointer* lead) { - if (!s7_is_integer (k)) - return (s7_wrong_type_arg_error (sc, name, 2, k, "an integer")); - if (n < 0) return (s7_out_of_range_error (sc, name, 2, k, "it is negative")); - if (!s7_is_pair (lst) && !s7_is_null (sc, lst)) - return (s7_wrong_type_arg_error (sc, name, 1, lst, "a list")); - s7_pointer p= lst; - for (s7_int i= 0; i < n; i++) { - if (!s7_is_pair (p)) - return (s7_out_of_range_error (sc, name, 2, k, "it is too large")); - p= s7_cdr (p); - } - (*lead)= p; - return (NULL); +static s7_pointer take_right_lead(s7_scheme *sc, const char *name, s7_pointer lst, s7_pointer k, s7_int n, s7_pointer *lead) +{ + if (!s7_is_integer(k)) + return(s7_wrong_type_arg_error(sc, name, 2, k, "an integer")); + if (n < 0) + return(s7_out_of_range_error(sc, name, 2, k, "it is negative")); + if (!s7_is_pair(lst) && !s7_is_null(sc, lst)) + return(s7_wrong_type_arg_error(sc, name, 1, lst, "a list")); + s7_pointer p = lst; + for (s7_int i = 0; i < n; i++) + { + if (!s7_is_pair(p)) + return(s7_out_of_range_error(sc, name, 2, k, "it is too large")); + p = s7_cdr(p); + } + (*lead) = p; + return(NULL); } -s7_pointer -g_take_right (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - s7_pointer k = s7_cadr (args); +s7_pointer g_take_right(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + s7_pointer k = s7_cadr(args); s7_pointer lead; - s7_pointer err= take_right_lead ( - sc, "take-right", lst, k, s7_is_integer (k) ? s7_integer (k) : 0, &lead); - if (err) return (err); + s7_pointer err = take_right_lead(sc, "take-right", lst, k, s7_is_integer(k) ? s7_integer(k) : 0, &lead); + if (err) return(err); /* no allocation and no Scheme callbacks: result is a sublist of lst */ - s7_pointer lag= lst; - while (s7_is_pair (lead)) { - lag = s7_cdr (lag); - lead= s7_cdr (lead); - } - return (lag); + s7_pointer lag = lst; + while (s7_is_pair(lead)) + { + lag = s7_cdr(lag); + lead = s7_cdr(lead); + } + return(lag); } -s7_pointer -g_drop_right (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - s7_pointer k = s7_cadr (args); +s7_pointer g_drop_right(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + s7_pointer k = s7_cadr(args); s7_pointer lead; - s7_pointer err= take_right_lead ( - sc, "drop-right", lst, k, s7_is_integer (k) ? s7_integer (k) : 0, &lead); - if (err) return (err); + s7_pointer err = take_right_lead(sc, "drop-right", lst, k, s7_is_integer(k) ? s7_integer(k) : 0, &lead); + if (err) return(err); /* dummy head anchor, same GC pattern as g_take */ - s7_pointer head= s7_cons (sc, s7_nil (sc), s7_nil (sc)); - s7_gc_protect_via_stack (sc, head); - s7_pointer tail= head; + s7_pointer head = s7_cons(sc, s7_nil(sc), s7_nil(sc)); + s7_gc_protect_via_stack(sc, head); + s7_pointer tail = head; s7_pointer lag = lst; - while (s7_is_pair (lead)) { - s7_set_cdr (tail, s7_cons (sc, s7_car (lag), s7_nil (sc))); - tail= s7_cdr (tail); - lag = s7_cdr (lag); - lead= s7_cdr (lead); - } - s7_gc_unprotect_via_stack (sc, head); - return (s7_cdr (head)); -} - -s7_pointer -g_list (s7_scheme* sc, s7_pointer args) { - return (s7i_copy_proper_list (sc, args)); -} - -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) - - s7_int index; - s7_pointer p= lst, ind; - - if (!s7_is_pair (lst) || s7_is_immutable (lst)) - return ( - s7_wrong_type_arg_error (sc, "list-set!", 1, lst, "a mutable pair")); - ind= s7_car (args); - if ((arg_num > 2) && s7_is_null (sc, s7_cdr (args))) { - s7_set_car (lst, ind); - return (ind); - } - if (!s7_is_integer (ind)) { - s7_pointer full_args= s7_cons (sc, lst, args); - return ( - s7i_method_or_bust (sc, ind, "list-set!", full_args, "an integer", 2)); - } - index= s7_integer (ind); + while (s7_is_pair(lead)) + { + s7_set_cdr(tail, s7_cons(sc, s7_car(lag), s7_nil(sc))); + tail = s7_cdr(tail); + lag = s7_cdr(lag); + lead = s7_cdr(lead); + } + s7_gc_unprotect_via_stack(sc, head); + return(s7_cdr(head)); +} + +s7_pointer g_list(s7_scheme *sc, s7_pointer args) +{ + return(s7i_copy_proper_list(sc, args)); +} + +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) + + s7_int index; + s7_pointer p = lst, ind; + + if (!s7_is_pair(lst) || s7_is_immutable(lst)) + return(s7_wrong_type_arg_error(sc, "list-set!", 1, lst, "a mutable pair")); + ind = s7_car(args); + if ((arg_num > 2) && s7_is_null(sc, s7_cdr(args))) + { + s7_set_car(lst, ind); + return(ind); + } + if (!s7_is_integer(ind)) + { + s7_pointer full_args = s7_cons(sc, lst, args); + return(s7i_method_or_bust(sc, ind, "list-set!", full_args, "an integer", 2)); + } + index = s7_integer(ind); if (index < 0) - return (s7_out_of_range_error (sc, "list-set!", arg_num, ind, - "it is negative")); - if (index > s7i_max_list_length (sc)) - return (s7_out_of_range_error (sc, "list-set!", arg_num, ind, - "it is too large")); + return(s7_out_of_range_error(sc, "list-set!", arg_num, ind, "it is negative")); + if (index > s7i_max_list_length(sc)) + return(s7_out_of_range_error(sc, "list-set!", arg_num, ind, "it is too large")); - for (s7_int i= 0; (i < index) && s7_is_pair (p); i++, p= s7_cdr (p)) { - } - if (!s7_is_pair (p)) { - if (s7_is_null (sc, p)) - return (s7_out_of_range_error (sc, "list-set!", arg_num, ind, - "it is too large")); - return (s7_wrong_type_arg_error (sc, "list-set!", 1, lst, "a proper list")); - } - if (s7_is_null (sc, s7_cddr (args))) s7_set_car (p, s7_cadr (args)); - else { - if (!s7_is_pair (s7_car (p))) - return (s7_wrong_number_of_args_error (sc, "list-set!", args)); - return (g_list_set_1 (sc, s7_car (p), s7_cdr (args), arg_num + 1)); - } - return (s7_cadr (args)); + for (s7_int i = 0; (i < index) && s7_is_pair(p); i++, p = s7_cdr(p)) {} + if (!s7_is_pair(p)) + { + if (s7_is_null(sc, p)) + return(s7_out_of_range_error(sc, "list-set!", arg_num, ind, "it is too large")); + return(s7_wrong_type_arg_error(sc, "list-set!", 1, lst, "a proper list")); + } + if (s7_is_null(sc, s7_cddr(args))) + s7_set_car(p, s7_cadr(args)); + else + { + if (!s7_is_pair(s7_car(p))) + return(s7_wrong_number_of_args_error(sc, "list-set!", args)); + return(g_list_set_1(sc, s7_car(p), s7_cdr(args), arg_num + 1)); + } + return(s7_cadr(args)); } -s7_pointer -g_list_set (s7_scheme* sc, s7_pointer args) { - return (g_list_set_1 (sc, s7_car (args), s7_cdr (args), 2)); +s7_pointer g_list_set(s7_scheme *sc, s7_pointer args) +{ + return(g_list_set_1(sc, s7_car(args), s7_cdr(args), 2)); } -s7_pointer -g_list_set_i (s7_scheme* sc, s7_pointer args) { - s7_pointer lst= s7_car (args); - s7_pointer p = lst; - s7_int index; - if (!s7_is_pair (lst) || s7_is_immutable (lst)) - return ( - s7_wrong_type_arg_error (sc, "list-set!", 1, lst, "a mutable pair")); - index= s7_integer (s7_cadr (args)); - if ((index < 0) || (index > s7i_max_list_length (sc))) - return (s7_out_of_range_error (sc, "list-set!", 2, - s7_make_integer (sc, index), - "it is negative or too large")); +s7_pointer g_list_set_i(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = s7_car(args); + s7_pointer p = lst; + s7_int index; + if (!s7_is_pair(lst) || s7_is_immutable(lst)) + return(s7_wrong_type_arg_error(sc, "list-set!", 1, lst, "a mutable pair")); + index = s7_integer(s7_cadr(args)); + if ((index < 0) || (index > s7i_max_list_length(sc))) + return(s7_out_of_range_error(sc, "list-set!", 2, s7_make_integer(sc, index), "it is negative or too large")); - for (s7_int i= 0; (i < index) && s7_is_pair (p); i++, p= s7_cdr (p)) { - } - if (!s7_is_pair (p)) { - if (s7_is_null (sc, p)) - return (s7_out_of_range_error ( - sc, "list-set!", 2, s7_make_integer (sc, index), "it is too large")); - return (s7_wrong_type_arg_error (sc, "list-set!", 1, lst, "a proper list")); - } + for (s7_int i = 0; (i < index) && s7_is_pair(p); i++, p = s7_cdr(p)) {} + if (!s7_is_pair(p)) + { + if (s7_is_null(sc, p)) + return(s7_out_of_range_error(sc, "list-set!", 2, s7_make_integer(sc, index), "it is too large")); + return(s7_wrong_type_arg_error(sc, "list-set!", 1, lst, "a proper list")); + } { - s7_pointer val= s7_caddr (args); - s7_set_car (p, val); - return (val); + s7_pointer val = s7_caddr(args); + s7_set_car(p, val); + return(val); } } + +/* -------- optimizer typed-arg (p_p) functions, migrated from s7.c -------- */ + +/* the optimizer compares these function pointers directly + (e.g. q_func1(opc).p_p_f == car_p_p), so each must have a single + extern definition in this compilation unit */ + +/* Externally defined in s7.c - permanent type/error description strings */ +extern s7_pointer a_list_string, an_association_list_string, a_proper_list_string; +extern s7_pointer it_is_negative_string, it_is_too_large_string; + +s7_pointer tree_leaves_p_p(s7_scheme *sc, s7_pointer tree) +{ + if (s7_is_list(sc, tree)) + { + if (s7i_tree_is_cyclic_checked(sc, tree)) + s7i_error_nr(sc, s7_make_symbol(sc, "wrong-type-arg"), + s7i_set_elist_2(sc, s7i_wrap_string(sc, "tree-leaves: tree is cyclic: ~S", 31), tree)); + return(s7_make_integer(sc, s7i_tree_len(sc, tree))); + } + return(s7i_method_or_bust_p(sc, tree, "tree-leaves", "a list")); +} + +s7_pointer tree_set_memq_p_pp(s7_scheme *sc, s7_pointer syms, s7_pointer tree) +{ + return(s7_make_boolean(sc, s7i_tree_set_memq_b_7pp(sc, syms, tree))); +} + +s7_pointer is_proper_list_p_p(s7_scheme *sc, s7_pointer arg) {return(s7_make_boolean(sc, s7_is_proper_list(sc, arg)));} + +s7_pointer make_list_p_pp(s7_scheme *sc, s7_pointer n, s7_pointer init) +{ + s7_int len; + if (!s7_is_integer(n)) + return(s7i_method_or_bust(sc, n, "make-list", s7i_set_plist_2(sc, n, init), "integer", 1)); + + len = s7i_integer_clamped_if_gmp(sc, n); + if (len == 0) return(s7_nil(sc)); /* what about (make-list 0 123)? */ + if (len < 0) + out_of_range_error_nr(sc, s7_make_symbol(sc, "make-list"), s7i_wrap_integer(sc, 1), n, it_is_negative_string); + if (len > s7i_max_list_length(sc)) + s7i_error_nr(sc, s7_make_symbol(sc, "out-of-range"), + s7i_set_elist_3(sc, s7i_wrap_string(sc, "make-list length argument ~D is greater than (*s7* 'max-list-length), ~D", 72), + s7i_wrap_integer(sc, len), s7i_wrap_integer(sc, s7i_max_list_length(sc)))); + return(s7_make_list(sc, len, init)); +} + +s7_pointer list_ref_p_pi_unchecked(s7_scheme *sc, s7_pointer lst, s7_int index) +{ + s7_pointer p = lst; + if (index < 0) + out_of_range_error_nr(sc, s7_make_symbol(sc, "list-ref"), s7i_wrap_integer(sc, 2), s7i_wrap_integer(sc, index), it_is_negative_string); + if (index > s7i_max_list_length(sc)) + s7i_error_nr(sc, s7_make_symbol(sc, "out-of-range"), + s7i_set_elist_3(sc, s7i_wrap_string(sc, "list-ref index ~D is too large, (*s7* 'max-list-length) is ~D", 61), + s7i_wrap_integer(sc, index), s7i_wrap_integer(sc, s7i_max_list_length(sc)))); + for (s7_int i = 0; ((s7_is_pair(p)) && (i < index)); i++, p = s7_cdr(p)); + if (!s7_is_pair(p)) + { + if (s7_is_null(sc, p)) + out_of_range_error_nr(sc, s7_make_symbol(sc, "list-ref"), s7i_wrap_integer(sc, 2), s7i_wrap_integer(sc, index), it_is_too_large_string); + sole_arg_wrong_type_error_nr(sc, s7_make_symbol(sc, "list-ref"), lst, a_proper_list_string); + } + return(s7_car(p)); +} + +s7_pointer list_ref_p_pi(s7_scheme *sc, s7_pointer lst, s7_int index) +{ + if (!s7_is_pair(lst)) + sole_arg_wrong_type_error_nr(sc, s7_make_symbol(sc, "list-ref"), lst, s7i_wrap_string(sc, "pair", 4)); + return(list_ref_p_pi_unchecked(sc, lst, index)); +} + +s7_pointer list_ref_p_pp(s7_scheme *sc, s7_pointer lst, s7_pointer index) +{ + if (!s7_is_pair(lst)) + return(g_list_ref(sc, s7i_set_plist_2(sc, lst, index))); + if (!s7_is_integer(index)) + sole_arg_wrong_type_error_nr(sc, s7_make_symbol(sc, "list-ref"), index, s7i_wrap_string(sc, "integer", 7)); + return(list_ref_p_pi_unchecked(sc, lst, s7i_integer_clamped_if_gmp(sc, index))); +} + +no_return void list_set_index_check_nr(s7_scheme *sc, s7_int index) +{ + if (index < 0) + out_of_range_error_nr(sc, s7_make_symbol(sc, "list-set!"), s7i_wrap_integer(sc, 2), s7i_wrap_integer(sc, index), it_is_negative_string); + s7i_error_nr(sc, s7_make_symbol(sc, "out-of-range"), + s7i_set_elist_3(sc, s7i_wrap_string(sc, "list-set! index ~D is too large, (*s7* 'max-list-length) is ~D", 62), + s7i_wrap_integer(sc, index), s7i_wrap_integer(sc, s7i_max_list_length(sc)))); +} + +s7_pointer list_set_p_pip_unchecked(s7_scheme *sc, s7_pointer lst, s7_int index, s7_pointer value) +{ + s7_pointer p = lst; + if ((index < 0) || (index > s7i_max_list_length(sc))) list_set_index_check_nr(sc, index); + for (s7_int i = 0; ((s7_is_pair(p)) && (i < index)); i++, p = s7_cdr(p)); + if (!s7_is_pair(p)) + { + if (s7_is_null(sc, p)) + out_of_range_error_nr(sc, s7_make_symbol(sc, "list-set!"), s7i_wrap_integer(sc, 2), s7i_wrap_integer(sc, index), it_is_too_large_string); + sole_arg_wrong_type_error_nr(sc, s7_make_symbol(sc, "list-set!"), lst, a_proper_list_string); + } + s7_set_car(p, value); + return(value); +} + +s7_pointer list_set_p_pip(s7_scheme *sc, s7_pointer lst, s7_int index, s7_pointer value) /* called in t101-12|14... */ +{ + if (!s7_is_pair(lst)) + sole_arg_wrong_type_error_nr(sc, s7_make_symbol(sc, "list-set!"), lst, s7i_wrap_string(sc, "pair", 4)); + return(list_set_p_pip_unchecked(sc, lst, index, value)); +} + +s7_pointer list_tail_p_pp(s7_scheme *sc, s7_pointer lst, s7_pointer ind) +{ + s7_int i, index; + if (!s7_is_integer(ind)) + return(s7i_method_or_bust_pp(sc, ind, "list-tail", lst, ind, "integer", 2)); + index = s7i_integer_clamped_if_gmp(sc, ind); + + if (!s7_is_list(sc, lst)) /* (list-tail () 0) -> () */ + return(s7i_method_or_bust_pp(sc, lst, "list-tail", lst, ind, "a list", 1)); + if (index < 0) + out_of_range_error_nr(sc, s7_make_symbol(sc, "list-tail"), s7i_wrap_integer(sc, 2), s7i_wrap_integer(sc, index), it_is_negative_string); + if (index > s7i_max_list_length(sc)) + s7i_error_nr(sc, s7_make_symbol(sc, "out-of-range"), + s7i_set_elist_3(sc, s7i_wrap_string(sc, "list-tail index ~D is too large, (*s7* 'max-list-length) is ~D", 62), + s7i_wrap_integer(sc, index), s7i_wrap_integer(sc, s7i_max_list_length(sc)))); + + for (i = 0; (i < index) && (s7_is_pair(lst)); i++, lst = s7_cdr(lst)) {} + if (i < index) + out_of_range_error_nr(sc, s7_make_symbol(sc, "list-tail"), s7i_wrap_integer(sc, 2), s7i_wrap_integer(sc, index), it_is_too_large_string); + return(lst); +} + +s7_pointer cons_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) +{ + return(s7i_cons_safe(sc, p1, p2)); +} + +s7_pointer car_p_p(s7_scheme *sc, s7_pointer lst) +{ + if (s7_is_pair(lst)) + return(s7_car(lst)); + return(s7i_sole_arg_method_or_bust(sc, lst, "car", s7i_set_plist_1(sc, lst), "pair")); +} + +s7_pointer set_car_p_pp(s7_scheme *sc, s7_pointer lst, s7_pointer value) {return(s7i_inline_set_car(sc, lst, value));} + +s7_pointer cdr_p_p(s7_scheme *sc, s7_pointer lst) +{ + if (s7_is_pair(lst)) + return(s7_cdr(lst)); + return(s7i_sole_arg_method_or_bust(sc, lst, "cdr", s7i_set_plist_1(sc, lst), "pair")); +} + +s7_pointer set_cdr_p_pp(s7_scheme *sc, s7_pointer lst, s7_pointer value) {return(s7i_inline_set_cdr(sc, lst, value));} + +s7_pointer assq_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst) +{ + return((s7_is_pair(lst)) ? s7_assq(sc, obj, lst) : + ((s7_is_null(sc, lst)) ? s7_f(sc) : + s7i_method_or_bust_pp(sc, lst, "assq", obj, lst, "an association list", 2))); +} + +s7_pointer assv_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst) +{ + s7_pointer slow; + if (!s7_is_pair(lst)) + { + if (s7_is_null(sc, lst)) return(s7_f(sc)); + if (s7i_scheme_version_is_s7(sc)) + return(s7i_method_or_bust_pp(sc, lst, "assv", obj, lst, "an association list", 2)); + return(s7i_methods_or_bust_pp(sc, lst, "assv", "assq", obj, lst, an_association_list_string, 2)); + } + if (s7i_is_simple(obj)) + return(s7_assq(sc, obj, lst)); + + slow = lst; + while (true) + { + /* here we can't play the assq == game because s7_is_eqv thinks it's getting a legit s7 object */ + if ((s7_is_pair(s7_car(lst))) && (s7_is_eqv(sc, obj, s7_caar(lst)))) return(s7_car(lst)); + lst = s7_cdr(lst); + if (!s7_is_pair(lst)) return(s7_f(sc)); + + if ((s7_is_pair(s7_car(lst))) && (s7_is_eqv(sc, obj, s7_caar(lst)))) return(s7_car(lst)); + lst = s7_cdr(lst); + if (!s7_is_pair(lst)) return(s7_f(sc)); + + slow = s7_cdr(slow); + if (slow == lst) return(s7_f(sc)); + } + return(s7_f(sc)); /* not reached */ +} + +s7_pointer assoc_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer p) +{ + if (!s7_is_pair(p)) + { + if (s7_is_null(sc, p)) return(s7_f(sc)); + return(s7i_method_or_bust(sc, p, "assoc", s7i_set_plist_2(sc, obj, p), "an association list", 2)); + } + if (!s7_is_pair(s7_car(p))) sole_arg_wrong_type_error_nr(sc, s7_make_symbol(sc, "assoc"), p, an_association_list_string); + if (s7i_is_simple(obj)) return(s7_assq(sc, obj, p)); + return(s7i_assoc_1(sc, obj, p)); +} + +s7_pointer memq_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst) +{ + return((s7_is_pair(lst)) ? s7_memq(sc, obj, lst) : + ((s7_is_null(sc, lst)) ? s7_f(sc) : s7i_method_or_bust_pp(sc, lst, "memq", obj, lst, "a list", 2))); +} + +s7_pointer memq_2_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst) +{ + if (obj == s7_car(lst)) return(lst); + return((obj == s7_cadr(lst)) ? s7_cdr(lst) : s7_f(sc)); +} + +s7_pointer memq_3_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst) +{ + if (obj == s7_car(lst)) return(lst); + if (obj == s7_cadr(lst)) return(s7_cdr(lst)); + return((obj == s7_caddr(lst)) ? s7_cddr(lst) : s7_f(sc)); +} + +s7_pointer memq_4_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst) +{ + while (true) + { + for (int32_t k = 0; k < 4; k++) + { + if (obj == s7_car(lst)) return(lst); + lst = s7_cdr(lst); + } + if (!s7_is_pair(lst)) return(s7_f(sc)); + } + return(s7_f(sc)); /* not reached */ +} + +s7_pointer memv_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst) +{ + s7_pointer p; + if (!s7_is_pair(lst)) + { + if (s7_is_null(sc, lst)) return(s7_f(sc)); + if (s7i_scheme_version_is_s7(sc)) + return(s7i_method_or_bust_pp(sc, lst, "memv", obj, lst, "a list", 2)); + return(s7i_methods_or_bust_pp(sc, lst, "memv", "memq", obj, lst, a_list_string, 2)); + } + if (s7i_is_simple(obj)) return(s7_memq(sc, obj, lst)); + if (s7_is_number(obj)) return(s7i_memv_number(sc, obj, lst)); + + p = lst; + while (true) + { + if (s7_is_eqv(sc, obj, s7_car(lst))) return(lst); + lst = s7_cdr(lst); + if (!s7_is_pair(lst)) return(s7_f(sc)); + + if (s7_is_eqv(sc, obj, s7_car(lst))) return(lst); + lst = s7_cdr(lst); + if (!s7_is_pair(lst)) return(s7_f(sc)); + + p = s7_cdr(p); + if (p == lst) return(s7_f(sc)); + } + return(s7_f(sc)); /* not reached */ +} + +s7_pointer member_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst) +{ + if (s7_is_null(sc, lst)) return(s7_f(sc)); + if (!s7_is_pair(lst)) return(s7i_method_or_bust(sc, lst, "member", s7i_set_plist_2(sc, obj, lst), "a list", 2)); + if (s7i_is_simple(obj)) return(s7_memq(sc, obj, lst)); + if (s7_is_number(obj)) return(s7i_memv_number(sc, obj, lst)); + return(s7i_member(sc, obj, lst)); +} diff --git a/TeXmacs/plugins/goldfish/src/s7_liii_list.h b/TeXmacs/plugins/goldfish/src/s7_liii_list.h index c3909caea5..b7e08abe0f 100644 --- a/TeXmacs/plugins/goldfish/src/s7_liii_list.h +++ b/TeXmacs/plugins/goldfish/src/s7_liii_list.h @@ -13,59 +13,94 @@ extern "C" { #endif -s7_pointer g_is_null (s7_scheme* sc, s7_pointer args); -s7_pointer g_is_pair (s7_scheme* sc, s7_pointer args); -s7_pointer g_is_list (s7_scheme* sc, s7_pointer args); -s7_pointer g_is_proper_list (s7_scheme* sc, s7_pointer args); -s7_pointer g_car (s7_scheme* sc, s7_pointer args); -s7_pointer g_cdr (s7_scheme* sc, s7_pointer args); -s7_pointer g_caar (s7_scheme* sc, s7_pointer args); -s7_pointer g_cadr (s7_scheme* sc, s7_pointer args); -s7_pointer g_cdar (s7_scheme* sc, s7_pointer args); -s7_pointer g_cddr (s7_scheme* sc, s7_pointer args); -s7_pointer g_caaar (s7_scheme* sc, s7_pointer args); -s7_pointer g_caadr (s7_scheme* sc, s7_pointer args); -s7_pointer g_cadar (s7_scheme* sc, s7_pointer args); -s7_pointer g_caddr (s7_scheme* sc, s7_pointer args); -s7_pointer g_cdaar (s7_scheme* sc, s7_pointer args); -s7_pointer g_cdddr (s7_scheme* sc, s7_pointer args); -s7_pointer g_cdadr (s7_scheme* sc, s7_pointer args); -s7_pointer g_cddar (s7_scheme* sc, s7_pointer args); +s7_pointer g_is_null(s7_scheme *sc, s7_pointer args); +s7_pointer g_is_pair(s7_scheme *sc, s7_pointer args); +s7_pointer g_is_list(s7_scheme *sc, s7_pointer args); +s7_pointer g_is_proper_list(s7_scheme *sc, s7_pointer args); +s7_pointer g_car(s7_scheme *sc, s7_pointer args); +s7_pointer g_cdr(s7_scheme *sc, s7_pointer args); +s7_pointer g_caar(s7_scheme *sc, s7_pointer args); +s7_pointer g_cadr(s7_scheme *sc, s7_pointer args); +s7_pointer g_cdar(s7_scheme *sc, s7_pointer args); +s7_pointer g_cddr(s7_scheme *sc, s7_pointer args); +s7_pointer g_caaar(s7_scheme *sc, s7_pointer args); +s7_pointer g_caadr(s7_scheme *sc, s7_pointer args); +s7_pointer g_cadar(s7_scheme *sc, s7_pointer args); +s7_pointer g_caddr(s7_scheme *sc, s7_pointer args); +s7_pointer g_cdaar(s7_scheme *sc, s7_pointer args); +s7_pointer g_cdddr(s7_scheme *sc, s7_pointer args); +s7_pointer g_cdadr(s7_scheme *sc, s7_pointer args); +s7_pointer g_cddar(s7_scheme *sc, s7_pointer args); -s7_pointer g_caaaar (s7_scheme* sc, s7_pointer args); -s7_pointer g_caaadr (s7_scheme* sc, s7_pointer args); -s7_pointer g_caadar (s7_scheme* sc, s7_pointer args); -s7_pointer g_cadaar (s7_scheme* sc, s7_pointer args); -s7_pointer g_caaddr (s7_scheme* sc, s7_pointer args); -s7_pointer g_cadddr (s7_scheme* sc, s7_pointer args); -s7_pointer g_cadadr (s7_scheme* sc, s7_pointer args); -s7_pointer g_caddar (s7_scheme* sc, s7_pointer args); -s7_pointer g_cdaaar (s7_scheme* sc, s7_pointer args); -s7_pointer g_cdaadr (s7_scheme* sc, s7_pointer args); -s7_pointer g_cdadar (s7_scheme* sc, s7_pointer args); -s7_pointer g_cddaar (s7_scheme* sc, s7_pointer args); -s7_pointer g_cdaddr (s7_scheme* sc, s7_pointer args); -s7_pointer g_cddddr (s7_scheme* sc, s7_pointer args); -s7_pointer g_cddadr (s7_scheme* sc, s7_pointer args); -s7_pointer g_cdddar (s7_scheme* sc, s7_pointer args); +s7_pointer g_caaaar(s7_scheme *sc, s7_pointer args); +s7_pointer g_caaadr(s7_scheme *sc, s7_pointer args); +s7_pointer g_caadar(s7_scheme *sc, s7_pointer args); +s7_pointer g_cadaar(s7_scheme *sc, s7_pointer args); +s7_pointer g_caaddr(s7_scheme *sc, s7_pointer args); +s7_pointer g_cadddr(s7_scheme *sc, s7_pointer args); +s7_pointer g_cadadr(s7_scheme *sc, s7_pointer args); +s7_pointer g_caddar(s7_scheme *sc, s7_pointer args); +s7_pointer g_cdaaar(s7_scheme *sc, s7_pointer args); +s7_pointer g_cdaadr(s7_scheme *sc, s7_pointer args); +s7_pointer g_cdadar(s7_scheme *sc, s7_pointer args); +s7_pointer g_cddaar(s7_scheme *sc, s7_pointer args); +s7_pointer g_cdaddr(s7_scheme *sc, s7_pointer args); +s7_pointer g_cddddr(s7_scheme *sc, s7_pointer args); +s7_pointer g_cddadr(s7_scheme *sc, s7_pointer args); +s7_pointer g_cdddar(s7_scheme *sc, s7_pointer args); -s7_pointer g_set_car (s7_scheme* sc, s7_pointer args); -s7_pointer g_set_cdr (s7_scheme* sc, s7_pointer args); +s7_pointer g_set_car(s7_scheme *sc, s7_pointer args); +s7_pointer g_set_cdr(s7_scheme *sc, s7_pointer args); -s7_pointer g_list_ref (s7_scheme* sc, s7_pointer args); -s7_pointer g_list_tail (s7_scheme* sc, s7_pointer args); +s7_pointer g_list_ref(s7_scheme *sc, s7_pointer args); +s7_pointer g_list_tail(s7_scheme *sc, s7_pointer args); -s7_pointer g_cons (s7_scheme* sc, s7_pointer args); -s7_pointer g_list (s7_scheme* sc, s7_pointer args); -s7_pointer g_filter (s7_scheme* sc, s7_pointer args); -s7_pointer g_take (s7_scheme* sc, s7_pointer args); -s7_pointer g_take_right (s7_scheme* sc, s7_pointer args); -s7_pointer g_drop_right (s7_scheme* sc, s7_pointer args); +s7_pointer g_cons(s7_scheme *sc, s7_pointer args); +s7_pointer g_list(s7_scheme *sc, s7_pointer args); +s7_pointer g_filter(s7_scheme *sc, s7_pointer args); +s7_pointer g_find(s7_scheme *sc, s7_pointer args); +s7_pointer g_any(s7_scheme *sc, s7_pointer args); +s7_pointer g_every(s7_scheme *sc, s7_pointer args); +s7_pointer g_count(s7_scheme *sc, s7_pointer args); +s7_pointer g_list_index(s7_scheme *sc, s7_pointer args); +s7_pointer g_fold(s7_scheme *sc, s7_pointer args); +s7_pointer g_fold_right(s7_scheme *sc, s7_pointer args); +s7_pointer g_take(s7_scheme *sc, s7_pointer args); +s7_pointer g_take_right(s7_scheme *sc, s7_pointer args); +s7_pointer g_drop_right(s7_scheme *sc, s7_pointer args); -s7_pointer g_list_set (s7_scheme* sc, s7_pointer args); -s7_pointer g_list_set_i (s7_scheme* sc, s7_pointer args); -s7_pointer g_list_set_1 (s7_scheme* sc, s7_pointer lst, s7_pointer args, - int32_t arg_num); +s7_pointer g_list_set(s7_scheme *sc, s7_pointer args); +s7_pointer g_list_set_i(s7_scheme *sc, s7_pointer args); +s7_pointer g_list_set_1(s7_scheme *sc, s7_pointer lst, s7_pointer args, int32_t arg_num); + +/* optimizer typed-arg (p_p) functions, migrated from s7.c; + the optimizer compares these pointers, so each has a single + extern definition in s7_liii_list.c */ +s7_pointer tree_leaves_p_p(s7_scheme *sc, s7_pointer tree); +s7_pointer tree_set_memq_p_pp(s7_scheme *sc, s7_pointer syms, s7_pointer tree); +s7_pointer is_proper_list_p_p(s7_scheme *sc, s7_pointer arg); +s7_pointer make_list_p_pp(s7_scheme *sc, s7_pointer n, s7_pointer init); +s7_pointer list_ref_p_pi_unchecked(s7_scheme *sc, s7_pointer lst, s7_int index); +s7_pointer list_ref_p_pi(s7_scheme *sc, s7_pointer lst, s7_int index); +s7_pointer list_ref_p_pp(s7_scheme *sc, s7_pointer lst, s7_pointer index); +s7_pointer list_set_p_pip(s7_scheme *sc, s7_pointer lst, s7_int index, s7_pointer value); +s7_pointer list_set_p_pip_unchecked(s7_scheme *sc, s7_pointer lst, s7_int index, s7_pointer value); +void list_set_index_check_nr(s7_scheme *sc, s7_int index); +s7_pointer list_tail_p_pp(s7_scheme *sc, s7_pointer lst, s7_pointer ind); +s7_pointer cons_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2); +s7_pointer car_p_p(s7_scheme *sc, s7_pointer lst); +s7_pointer set_car_p_pp(s7_scheme *sc, s7_pointer lst, s7_pointer value); +s7_pointer cdr_p_p(s7_scheme *sc, s7_pointer lst); +s7_pointer set_cdr_p_pp(s7_scheme *sc, s7_pointer lst, s7_pointer value); +s7_pointer assq_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst); +s7_pointer assv_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst); +s7_pointer assoc_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer p); +s7_pointer memq_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst); +s7_pointer memq_2_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst); +s7_pointer memq_3_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst); +s7_pointer memq_4_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst); +s7_pointer memv_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst); +s7_pointer member_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst); #ifdef __cplusplus } diff --git a/TeXmacs/plugins/goldfish/src/s7_liii_record.c b/TeXmacs/plugins/goldfish/src/s7_liii_record.c new file mode 100644 index 0000000000..29a331d3a4 --- /dev/null +++ b/TeXmacs/plugins/goldfish/src/s7_liii_record.c @@ -0,0 +1,189 @@ +// +// Copyright (C) 2026 The Goldfish Scheme Authors +// +// Licensed under the Apache License, Version 2.0 (the "License"); +// you may not use this file except in compliance with the License. +// You may obtain a copy of the License at +// +// http://www.apache.org/licenses/LICENSE-2.0 +// +// Unless required by applicable law or agreed to in writing, software +// distributed under the License is distributed on an "AS IS" BASIS, +// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See +// the License for the specific language governing permissions and limitations +// under the License. +// + +/* s7_liii_record.c - C implementation of define-record-type (SRFI-9 / R7RS) + * + * The macro is implemented in C to avoid the expansion-time cost of the old + * define-macro version (Scheme-level map/memq/quasiquote for every record + * type at library load time). The generated expansion is intentionally the + * same let-based one the Scheme macro produced: s7 heavily optimizes inlet + * and let-ref with constant keys, so the let representation is faster at run + * time than a vector-based one (see devel/0116.md for the benchmarks). + * Keeping the let representation also means zero observable behavior change: + * records are still lets, print the same, and let?/let-ref keep working on + * them. + */ + +#include "s7_liii_record.h" + +static s7_pointer +record_error (s7_scheme* sc, const char* msg, s7_pointer arg) { + return s7_error (sc, s7_make_symbol (sc, "wrong-type-arg"), s7_list (sc, 2, s7_make_string (sc, msg), arg)); +} + +static bool +record_symbol_list (s7_scheme* sc, s7_pointer lst) { + if (s7_list_length (sc, lst) < 0) return false; /* improper or circular */ + for (s7_pointer p= lst; s7_is_pair (p); p= s7_cdr (p)) + if (!s7_is_symbol (s7_car (p))) return false; + return true; +} + +static bool +record_memq_sym (s7_pointer sym, s7_pointer lst) { + for (s7_pointer p= lst; s7_is_pair (p); p= s7_cdr (p)) + if (s7_car (p) == sym) return true; /* symbols: pointer equality */ + return false; +} + +/* append form to the tail of the list headed by *tail (update *tail) */ +static void +record_append (s7_scheme* sc, s7_pointer* tail, s7_pointer form) { + s7_pointer cell= s7_cons (sc, form, s7_nil (sc)); + s7_set_cdr (*tail, cell); + *tail= cell; +} + +/* (define-record-type type-name (constructor field ...) predicate + * (field-name accessor [modifier]) ...) + * + * expands to + * (begin + * (define (predicate obj) + * (and (let? obj) (eq? (let-ref obj 'typ) 'type-name))) + * (define (constructor arg ...) + * (inlet 'typ 'type-name 'field value ...)) + * (define (accessor obj) (let-ref obj 'field)) + * (define (modifier obj val) (let-set! obj 'field val)) + * ... + * 'type-name) + * where obj and typ are fresh gensyms and the constructor values are given in + * field declaration order (constructor arguments are reordered as needed, + * fields missing from the constructor spec default to #f). + */ +s7_pointer +g_define_record_type (s7_scheme* sc, s7_pointer args) { + s7_gc_protect_via_stack (sc, args); + + s7_pointer type_name= s7_car (args); + s7_pointer ctor_spec= s7_cadr (args); + s7_pointer pred_name= s7_caddr (args); + s7_pointer fields = s7_cdddr (args); + + if (!s7_is_symbol (type_name)) { + s7_gc_unprotect_via_stack (sc, args); + return record_error (sc, "define-record-type: type name should be a symbol, but got ~S", type_name); + } + if ((!s7_is_pair (ctor_spec)) || (!s7_is_symbol (s7_car (ctor_spec))) || + (!record_symbol_list (sc, s7_cdr (ctor_spec)))) { + s7_gc_unprotect_via_stack (sc, args); + return record_error (sc, "define-record-type: constructor spec should be (name field ...), but got ~S", ctor_spec); + } + if (!s7_is_symbol (pred_name)) { + s7_gc_unprotect_via_stack (sc, args); + return record_error (sc, "define-record-type: predicate name should be a symbol, but got ~S", pred_name); + } + if (s7_list_length (sc, fields) < 0) { + s7_gc_unprotect_via_stack (sc, args); + return record_error (sc, "define-record-type: field specs should be a proper list, but got ~S", fields); + } + for (s7_pointer p= fields; s7_is_pair (p); p= s7_cdr (p)) { + s7_pointer spec = s7_car (p); + s7_int rest_len= (s7_is_pair (spec)) ? s7_list_length (sc, s7_cdr (spec)) : -1; + if ((!s7_is_pair (spec)) || (!s7_is_symbol (s7_car (spec))) || (rest_len < 0) || (rest_len > 2) || + (!record_symbol_list (sc, s7_cdr (spec)))) { + s7_gc_unprotect_via_stack (sc, args); + return record_error (sc, "define-record-type: field spec should be (name [accessor [modifier]]), but got ~S", + spec); + } + } + + s7_pointer begin_sym = s7_make_symbol (sc, "begin"); + s7_pointer define_sym = s7_make_symbol (sc, "define"); + s7_pointer lambda_sym = s7_make_symbol (sc, "lambda"); + s7_pointer quote_sym = s7_make_symbol (sc, "quote"); + s7_pointer and_sym = s7_make_symbol (sc, "and"); + s7_pointer eq_sym = s7_make_symbol (sc, "eq?"); + s7_pointer is_let_sym = s7_make_symbol (sc, "let?"); + s7_pointer let_ref_sym= s7_make_symbol (sc, "let-ref"); + s7_pointer let_set_sym= s7_make_symbol (sc, "let-set!"); + s7_pointer inlet_sym = s7_make_symbol (sc, "inlet"); + s7_pointer obj_sym = s7_gensym (sc, "obj"); + s7_pointer typ_sym = s7_gensym (sc, "typ"); + s7_pointer val_sym = s7_make_symbol (sc, "val"); + + /* nested s7_list builds are covered by s7's GC_TEMPS lag (see s7.h): a + * freshly created object cannot be collected before several further + * allocations, and each form is attached to the protected result list + * immediately after being built */ + s7_gc_protect_via_stack (sc, obj_sym); + s7_gc_protect_via_stack (sc, typ_sym); + s7_pointer result= s7_gc_protect_via_stack (sc, s7_list (sc, 1, begin_sym)); + s7_pointer tail = result; + + /* predicate: (define (pred obj) (and (let? obj) (eq? (let-ref obj 'typ) 'type))) */ + record_append (sc, &tail, + s7_list (sc, 3, define_sym, s7_list (sc, 2, pred_name, obj_sym), + s7_list (sc, 3, and_sym, s7_list (sc, 2, is_let_sym, obj_sym), + s7_list (sc, 3, eq_sym, + s7_list (sc, 3, let_ref_sym, obj_sym, s7_list (sc, 2, quote_sym, typ_sym)), + s7_list (sc, 2, quote_sym, type_name))))); + + /* constructor: (define (ctor arg ...) (inlet 'typ 'type 'field value ...)) + * with values in field declaration order */ + { + s7_pointer call= s7_gc_protect_via_stack ( + sc, s7_list (sc, 3, inlet_sym, s7_list (sc, 2, quote_sym, typ_sym), s7_list (sc, 2, quote_sym, type_name))); + s7_pointer ctail= s7_cdr (s7_cdr (call)); + for (s7_pointer p= fields; s7_is_pair (p); p= s7_cdr (p)) { + s7_pointer field_name= s7_car (s7_car (p)); + s7_pointer value = (record_memq_sym (field_name, s7_cdr (ctor_spec))) ? field_name : s7_f (sc); + record_append (sc, &ctail, s7_list (sc, 2, quote_sym, field_name)); + record_append (sc, &ctail, value); + } + record_append (sc, &tail, s7_list (sc, 3, define_sym, ctor_spec, call)); + s7_gc_unprotect_via_stack (sc, call); + } + + /* accessors and modifiers */ + for (s7_pointer p= fields; s7_is_pair (p); p= s7_cdr (p)) { + s7_pointer rest= s7_cdr (s7_car (p)); + if (!s7_is_pair (rest)) continue; + record_append (sc, &tail, + s7_list (sc, 3, define_sym, s7_list (sc, 2, s7_car (rest), obj_sym), + s7_list (sc, 3, let_ref_sym, obj_sym, s7_list (sc, 2, quote_sym, s7_car (s7_car (p)))))); + if (s7_is_pair (s7_cdr (rest))) + record_append ( + sc, &tail, + s7_list (sc, 3, define_sym, s7_list (sc, 3, s7_cadr (rest), obj_sym, val_sym), + s7_list (sc, 4, let_set_sym, obj_sym, s7_list (sc, 2, quote_sym, s7_car (s7_car (p))), val_sym))); + } + + record_append (sc, &tail, s7_list (sc, 2, quote_sym, type_name)); + + s7_gc_unprotect_via_stack (sc, result); + s7_gc_unprotect_via_stack (sc, typ_sym); + s7_gc_unprotect_via_stack (sc, obj_sym); + s7_gc_unprotect_via_stack (sc, args); + return result; +} + +void +glue_liii_record (s7_scheme* sc) { + s7_define_macro (sc, "define-record-type", g_define_record_type, 3, 0, true, + "(define-record-type type-name (constructor field ...) predicate (field-name accessor " + "[modifier]) ...) defines a new record type"); +} diff --git a/TeXmacs/plugins/goldfish/src/s7_liii_record.h b/TeXmacs/plugins/goldfish/src/s7_liii_record.h new file mode 100644 index 0000000000..c1ea015d88 --- /dev/null +++ b/TeXmacs/plugins/goldfish/src/s7_liii_record.h @@ -0,0 +1,34 @@ +// +// Copyright (C) 2026 The Goldfish Scheme Authors +// +// Licensed under the Apache License, Version 2.0 (the "License"); +// you may not use this file except in compliance with the License. +// You may obtain a copy of the License at +// +// http://www.apache.org/licenses/LICENSE-2.0 +// +// Unless required by applicable law or agreed to in writing, software +// distributed under the License is distributed on an "AS IS" BASIS, +// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the +// License for the specific language governing permissions and limitations +// under the License. +// + +#ifndef S7_LIII_RECORD_H +#define S7_LIII_RECORD_H + +#include "s7.h" + +#ifdef __cplusplus +extern "C" { +#endif + +s7_pointer g_define_record_type (s7_scheme* sc, s7_pointer args); + +void glue_liii_record (s7_scheme* sc); + +#ifdef __cplusplus +} +#endif + +#endif /* S7_LIII_RECORD_H */ diff --git a/TeXmacs/plugins/goldfish/src/s7_liii_string.c b/TeXmacs/plugins/goldfish/src/s7_liii_string.c index 139bc438c3..73f26ab938 100644 --- a/TeXmacs/plugins/goldfish/src/s7_liii_string.c +++ b/TeXmacs/plugins/goldfish/src/s7_liii_string.c @@ -16,6 +16,9 @@ /* Externally defined in s7.c - character cache */ extern s7_pointer *chars; +/* Externally defined in s7.c - permanent error description strings */ +extern s7_pointer it_is_negative_string, it_is_too_large_string, it_is_too_small_string; + /* Helper function for out-of-range errors */ static s7_pointer string_ref_out_of_range(s7_scheme *sc, s7_int index, bool is_negative) { @@ -453,6 +456,154 @@ s7_pointer g_substring_uncopied(s7_scheme *sc, s7_pointer args) } #if !WITH_PURE_S7 +/* -------- optimizer typed-arg (p_p) functions, migrated from s7.c -------- */ + +/* the optimizer compares these function pointers directly + (e.g. q_func(opc).p_pi_f == string_ref_p_pi_unchecked), so each must + have a single extern definition in this compilation unit */ + +s7_pointer string_ref_p_pi(s7_scheme *sc, s7_pointer str, s7_int index) +{ + if (!s7_is_string(str)) + return(s7i_method_or_bust(sc, str, "string-ref", s7i_set_plist_2(sc, str, s7_make_integer(sc, index)), "string", 1)); + if ((index < 0) || (index >= s7_string_length(str))) + out_of_range_error_nr(sc, s7_make_symbol(sc, "string-ref"), s7i_wrap_integer(sc, 2), s7i_wrap_integer(sc, index), + (index < 0) ? it_is_negative_string : it_is_too_large_string); + return(chars[((uint8_t *)s7_string(str))[index]]); +} + +s7_pointer string_ref_p_pp(s7_scheme *sc, s7_pointer str, s7_pointer index) +{ + s7_int ind; + if (!s7_is_string(str)) + return(s7i_method_or_bust_pp(sc, str, "string-ref", str, index, "string", 1)); + if (!s7_is_integer(index)) + return(s7i_method_or_bust_pp(sc, index, "string-ref", str, index, "integer", 2)); + ind = s7i_integer_clamped_if_gmp(sc, index); + if (ind < 0) + out_of_range_error_nr(sc, s7_make_symbol(sc, "string-ref"), s7i_wrap_integer(sc, 2), index, it_is_negative_string); + if (ind >= s7_string_length(str)) + out_of_range_error_nr(sc, s7_make_symbol(sc, "string-ref"), s7i_wrap_integer(sc, 2), index, it_is_too_large_string); + return(chars[((uint8_t *)s7_string(str))[ind]]); +} + +s7_pointer string_ref_p_p0(s7_scheme *sc, s7_pointer str, s7_pointer unused_index) +{ + if (!s7_is_string(str)) + return(s7i_method_or_bust_pp(sc, str, "string-ref", str, s7i_wrap_integer(sc, 0), "string", 1)); + if (s7_string_length(str) <= 0) + out_of_range_error_nr(sc, s7_make_symbol(sc, "string-ref"), s7i_wrap_integer(sc, 2), s7i_wrap_integer(sc, 0), it_is_too_large_string); + return(chars[((uint8_t *)s7_string(str))[0]]); +} + +static s7_pointer string_plast_via_method(s7_scheme *sc, s7_pointer str) /* tmock */ +{ + s7_pointer len = s7i_method_or_bust_p(sc, str, "length", "string"); + return(s7i_method_or_bust_pp(sc, str, "string-ref", str, s7_make_integer(sc, s7_integer(len) - 1), "string", 1)); +} + +s7_pointer string_ref_p_plast(s7_scheme *sc, s7_pointer str, s7_pointer unused_index) +{ + if (!s7_is_string(str)) + return(string_plast_via_method(sc, str)); + if (s7_string_length(str) <= 0) + out_of_range_error_nr(sc, s7_make_symbol(sc, "string-ref"), s7i_wrap_integer(sc, 2), + s7i_wrap_integer(sc, s7_string_length(str) - 1), it_is_too_large_string); + return(chars[((uint8_t *)s7_string(str))[s7_string_length(str) - 1]]); +} + +s7_pointer string_ref_p_pi_unchecked(s7_scheme *sc, s7_pointer str, s7_int index) +{ + if ((index < 0) || (index >= s7_string_length(str))) + out_of_range_error_nr(sc, s7_make_symbol(sc, "string-ref"), s7i_wrap_integer(sc, 2), s7i_wrap_integer(sc, index), + (index < 0) ? it_is_negative_string : it_is_too_large_string); + return(chars[((uint8_t *)s7_string(str))[index]]); +} + +s7_pointer string_ref_p_pi_direct(s7_scheme *unused_sc, s7_pointer str, s7_int index) +{ + return(chars[((uint8_t *)s7_string(str))[index]]); +} + +s7_pointer string_set_p_pip(s7_scheme *sc, s7_pointer str, s7_int index, s7_pointer chr) +{ + if (!s7_is_string(str)) + s7i_wrong_type_error_nr(sc, s7_make_symbol(sc, "string-set!"), 1, str, s7i_string_type_name(sc)); + if (!s7_is_character(chr)) + s7i_wrong_type_error_nr(sc, s7_make_symbol(sc, "string-set!"), 2, chr, s7i_character_type_name(sc)); + if (s7_character(chr) > 0xFF) + { + const char *hint = "string-set! only accepts characters in range #x00..#xFF; use utf8-string-set! for Unicode characters"; + out_of_range_error_nr(sc, s7_make_symbol(sc, "string-set!"), s7i_wrap_integer(sc, 2), chr, + s7i_wrap_string(sc, hint, (s7_int)strlen(hint))); + } + if ((index >= 0) && (index < s7_string_length(str))) + ((char *)s7_string(str))[index] = (char)s7_character(chr); + else out_of_range_error_nr(sc, s7_make_symbol(sc, "string-set!"), s7i_wrap_integer(sc, 2), s7i_wrap_integer(sc, index), + (index < 0) ? it_is_negative_string : it_is_too_large_string); + return(chr); +} + +s7_pointer string_set_p_pip_unchecked(s7_scheme *sc, s7_pointer str, s7_int index, s7_pointer chr) +{ + if ((index >= 0) && (index < s7_string_length(str))) + ((char *)s7_string(str))[index] = (char)s7_character(chr); + else out_of_range_error_nr(sc, s7_make_symbol(sc, "string-set!"), s7i_wrap_integer(sc, 2), s7i_wrap_integer(sc, index), + (index < 0) ? it_is_negative_string : it_is_too_large_string); + return(chr); +} + +s7_pointer string_set_p_pip_direct(s7_scheme *unused_sc, s7_pointer str, s7_int index, s7_pointer chr) +{ + ((char *)s7_string(str))[index] = (char)s7_character(chr); + return(chr); +} + +s7_pointer substring_uncopied_p_pii(s7_scheme *sc, s7_pointer str, s7_int start, s7_int end) +{ + /* is_string(arg1) already checked in opt */ + if ((end < start) || (end > s7_string_length(str))) + out_of_range_error_nr(sc, s7_make_symbol(sc, "substring-uncopied"), s7i_wrap_integer(sc, 3), s7i_wrap_integer(sc, end), + (end < start) ? it_is_too_small_string : it_is_too_large_string); + if (start < 0) + out_of_range_error_nr(sc, s7_make_symbol(sc, "substring-uncopied"), s7i_wrap_integer(sc, 2), s7i_wrap_integer(sc, start), it_is_negative_string); + return(s7i_wrap_string(sc, s7_string(str) + start, end - start)); +} + +s7_pointer string_p_p(s7_scheme *sc, s7_pointer c) +{ + s7_pointer str; + const char *unicode_string_hint = "string only accepts characters in range #x00..#xFF; use utf8-string for Unicode characters"; + if (!s7_is_character(c)) return(s7i_string_1(sc, s7i_set_plist_1(sc, c), s7_make_symbol(sc, "string"))); + if (s7_character(c) > 0xFF) + out_of_range_error_nr(sc, s7_make_symbol(sc, "string"), s7i_wrap_integer(sc, 1), c, + s7i_wrap_string(sc, unicode_string_hint, (s7_int)strlen(unicode_string_hint))); + str = s7i_make_empty_string(sc, 1, '\0'); + s7i_string_value_ptr(str)[0] = (char)s7_character(c); + return(str); +} + +s7_pointer string_to_list_p_p(s7_scheme *sc, s7_pointer str) +{ + s7_int len; + const uint8_t *val; + if (!s7_is_string(str)) + return(s7i_sole_arg_method_or_bust(sc, str, "string->list", s7i_set_plist_1(sc, str), "string")); + len = s7_string_length(str); + if (len == 0) return(s7_nil(sc)); + if (len > s7i_max_list_length(sc)) + s7i_error_nr(sc, s7_make_symbol(sc, "out-of-range"), + s7i_set_elist_3(sc, s7i_wrap_string(sc, "string->list length, ~D, is greater than (*s7* 'max-list-length), ~D", 68), + s7i_wrap_integer(sc, len), s7i_wrap_integer(sc, s7i_max_list_length(sc)))); + s7i_check_free_heap_size(sc, len); + val = (const uint8_t *)s7_string(str); + { + s7_pointer result = s7_nil(sc); + for (s7_int i = len - 1; i >= 0; i--) result = cons_unchecked(sc, chars[val[i]], result); + return(result); + } +} + s7_pointer g_list_to_string(s7_scheme *sc, s7_pointer args) { if (s7_is_null(sc, s7_car(args))) diff --git a/TeXmacs/plugins/goldfish/src/s7_liii_string.h b/TeXmacs/plugins/goldfish/src/s7_liii_string.h index 99e16e0ab5..9dace899a5 100644 --- a/TeXmacs/plugins/goldfish/src/s7_liii_string.h +++ b/TeXmacs/plugins/goldfish/src/s7_liii_string.h @@ -34,6 +34,22 @@ s7_pointer string_append_p_pp(s7_scheme *sc, s7_pointer s1, s7_pointer s2); s7_pointer g_string(s7_scheme *sc, s7_pointer args); s7_pointer g_substring_uncopied(s7_scheme *sc, s7_pointer args); +/* optimizer typed-arg (p_p) functions, migrated from s7.c; + the optimizer compares these pointers, so each has a single + extern definition in s7_liii_string.c */ +s7_pointer string_ref_p_pi(s7_scheme *sc, s7_pointer str, s7_int index); +s7_pointer string_ref_p_pp(s7_scheme *sc, s7_pointer str, s7_pointer index); +s7_pointer string_ref_p_p0(s7_scheme *sc, s7_pointer str, s7_pointer unused_index); +s7_pointer string_ref_p_plast(s7_scheme *sc, s7_pointer str, s7_pointer unused_index); +s7_pointer string_ref_p_pi_unchecked(s7_scheme *sc, s7_pointer str, s7_int index); +s7_pointer string_ref_p_pi_direct(s7_scheme *sc, s7_pointer str, s7_int index); +s7_pointer string_set_p_pip(s7_scheme *sc, s7_pointer str, s7_int index, s7_pointer chr); +s7_pointer string_set_p_pip_unchecked(s7_scheme *sc, s7_pointer str, s7_int index, s7_pointer chr); +s7_pointer string_set_p_pip_direct(s7_scheme *sc, s7_pointer str, s7_int index, s7_pointer chr); +s7_pointer substring_uncopied_p_pii(s7_scheme *sc, s7_pointer str, s7_int start, s7_int end); +s7_pointer string_p_p(s7_scheme *sc, s7_pointer c); +s7_pointer string_to_list_p_p(s7_scheme *sc, s7_pointer str); + s7_pointer g_is_string(s7_scheme *sc, s7_pointer args); s7_pointer g_char_position(s7_scheme *sc, s7_pointer args); diff --git a/TeXmacs/plugins/goldfish/src/s7_liii_vector.c b/TeXmacs/plugins/goldfish/src/s7_liii_vector.c index 5a85b12c93..415b57cc80 100644 --- a/TeXmacs/plugins/goldfish/src/s7_liii_vector.c +++ b/TeXmacs/plugins/goldfish/src/s7_liii_vector.c @@ -10,6 +10,9 @@ #include "s7_internal_helpers.h" #include +/* Externally defined in s7.c - permanent error description strings */ +extern s7_pointer it_is_negative_string, it_is_too_large_string, it_is_too_small_string, immutable_error_string; + #ifndef WITH_PURE_S7 #define WITH_PURE_S7 0 s7_pointer g_make_vector(s7_scheme *sc, s7_pointer args) @@ -354,6 +357,41 @@ s7_pointer g_list_to_vector(s7_scheme *sc, s7_pointer args) return(g_vector(sc, lst)); } +s7_pointer g_vector_filter(s7_scheme *sc, s7_pointer args) +{ + s7_pointer pred = s7_car(args); + s7_pointer vec = s7_cadr(args); + if (!s7_is_procedure(pred)) + return(s7_wrong_type_arg_error(sc, "vector-filter", 1, pred, "a procedure")); + if (!s7_is_vector(vec)) + return(s7_wrong_type_arg_error(sc, "vector-filter", 2, vec, "a vector")); + /* args may live in evaluator-recycled cells, so keep pred and vec in our own + * pair, with the result vector as the anchor's cdr; everything stays + * GC-reachable while pred runs */ + s7_pointer anchor = s7_cons(sc, s7_cons(sc, pred, vec), s7_make_vector(sc, s7_vector_length(vec))); + s7_gc_protect_via_stack(sc, anchor); + s7_pointer result = s7_cdr(anchor); + s7_int len = s7_vector_length(vec); + s7_int count = 0; + for (s7_int i = 0; i < len; i++) + { + s7_pointer elem = s7_vector_ref(sc, vec, i); + if (s7i_is_true(sc, s7_apply_function(sc, pred, s7i_set_plist_1(sc, elem)))) + { + s7_vector_set(sc, result, count, elem); + count++; + } + } + s7_gc_unprotect_via_stack(sc, anchor); + if (count == len) return(result); + { + s7_pointer exact = s7_make_vector(sc, count); + for (s7_int i = 0; i < count; i++) + s7_vector_set(sc, exact, i, s7_vector_ref(sc, result, i)); + return(exact); + } +} + #if !WITH_PURE_S7 s7_pointer g_vector_length(s7_scheme *sc, s7_pointer args) @@ -378,4 +416,181 @@ s7_pointer vector_length_p_p(s7_scheme *sc, s7_pointer vec) return(s7_make_integer(sc, s7_vector_length(vec))); } +/* -------- optimizer typed-arg (p_p) functions, migrated from s7.c -------- */ + +/* the optimizer compares these function pointers directly + (e.g. q_func(opc).p_pi_f == vector_ref_p_pi_unchecked), so each must + have a single extern definition in this compilation unit */ + +s7_pointer vector_append_p_pp(s7_scheme *sc, s7_pointer v1, s7_pointer v2) +{ + return(s7i_vector_append_2(sc, v1, v2)); +} + +s7_pointer vector_append_p_ppp(s7_scheme *sc, s7_pointer v1, s7_pointer v2, s7_pointer v3) +{ + return(s7i_vector_append_3(sc, v1, v2, v3)); +} + +s7_pointer vector_to_list_p_p(s7_scheme *sc, s7_pointer vec) +{ + if (!s7i_is_any_vector(vec)) + return(s7i_method_or_bust_p(sc, vec, "vector->list", "vector")); + return(s7_vector_to_list(sc, vec)); +} + +s7_pointer vector_ref_p_pi(s7_scheme *sc, s7_pointer vec, s7_int index) +{ + if ((!s7i_is_t_vector(vec)) || + (s7_vector_rank(vec) > 1) || + (index < 0) || (index >= s7_vector_length(vec))) + return(g_vector_ref(sc, s7i_set_plist_2(sc, vec, s7_make_integer(sc, index)))); + return(s7i_vector_element(vec, index)); +} + +s7_pointer vector_ref_p_pi_unchecked(s7_scheme *sc, s7_pointer vec, s7_int index) /* callable but just barely (tgsl.scm) */ +{ + if ((index < 0) || (index >= s7_vector_length(vec))) + out_of_range_error_nr(sc, s7_make_symbol(sc, "vector-ref"), s7i_wrap_integer(sc, 2), s7i_wrap_integer(sc, index), + (index < 0) ? it_is_negative_string : it_is_too_large_string); + return(s7i_vector_getter_ref(sc, vec, index)); +} + +s7_pointer t_vector_ref_p_pi_unchecked(s7_scheme *sc, s7_pointer vec, s7_int index) +{ + if ((index < 0) || (index >= s7_vector_length(vec))) + out_of_range_error_nr(sc, s7_make_symbol(sc, "vector-ref"), s7i_wrap_integer(sc, 2), s7i_wrap_integer(sc, index), + (index < 0) ? it_is_negative_string : it_is_too_large_string); + return(s7i_vector_element(vec, index)); +} + +s7_pointer vector_ref_p_pii(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2) +{ + if ((!s7i_is_any_vector(vec)) || + (s7_vector_rank(vec) != 2) || + (i1 < 0) || (i2 < 0) || + (i1 >= s7_vector_dimension(vec, 0)) || (i2 >= s7_vector_dimension(vec, 1))) + return(g_vector_ref(sc, s7i_set_plist_3(sc, vec, s7_make_integer(sc, i1), s7_make_integer(sc, i2)))); + return(s7i_vector_getter_ref(sc, vec, i2 + (i1 * s7i_vector_offset(vec, 0)))); +} + +s7_pointer vector_ref_p_pii_direct(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2) +{ + if ((i1 < 0) || (i2 < 0) || + (i1 >= s7_vector_dimension(vec, 0)) || (i2 >= s7_vector_dimension(vec, 1))) + return(g_vector_ref(sc, s7i_set_plist_3(sc, vec, s7_make_integer(sc, i1), s7_make_integer(sc, i2)))); + return(s7i_vector_element(vec, i2 + (i1 * s7i_vector_offset(vec, 0)))); +} + +s7_pointer t_vector_ref_p_pi_direct(s7_scheme *unused_sc, s7_pointer vec, s7_int index) {return(s7i_vector_element(vec, index));} + +s7_pointer vector_set_p_pip(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value) /* almost never called -- see one case in s7test.scm[13736] */ +{ + if ((!s7i_is_any_vector(vec)) || (s7_vector_rank(vec) > 1) || (index < 0) || (index >= s7_vector_length(vec))) + return(s7i_g_vector_set(sc, s7i_set_plist_3(sc, vec, s7_make_integer(sc, index), value))); + if (s7i_is_t_vector(vec)) + { + if (s7i_is_typed_vector(vec)) return(s7i_typed_vector_setter(sc, vec, index, value)); + s7i_vector_element_set(vec, index, value); + } + else s7i_vector_setter_set(sc, vec, index, value); + return(value); +} + +s7_pointer vector_set_p_pip_unchecked(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value) +{ + if ((index >= 0) && (index < s7_vector_length(vec))) + s7i_vector_element_set(vec, index, value); + else out_of_range_error_nr(sc, s7_make_symbol(sc, "vector-set!"), s7i_wrap_integer(sc, 2), s7i_wrap_integer(sc, index), + (index < 0) ? it_is_negative_string : it_is_too_large_string); + return(value); +} + +s7_pointer vector_set_p_piip(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2, s7_pointer value) +{ + if ((!s7i_is_any_vector(vec)) || + (s7_vector_rank(vec) != 2) || + (i1 < 0) || (i2 < 0) || + (i1 >= s7_vector_dimension(vec, 0)) || (i2 >= s7_vector_dimension(vec, 1))) + return(s7i_g_vector_set(sc, s7i_set_plist_4(sc, vec, s7_make_integer(sc, i1), s7_make_integer(sc, i2), value))); + if (s7i_is_t_vector(vec)) + { + if (s7i_is_typed_vector(vec)) + return(s7i_typed_vector_setter(sc, vec, i2 + (i1 * s7i_vector_offset(vec, 0)), value)); + s7i_vector_element_set(vec, i2 + (i1 * s7i_vector_offset(vec, 0)), value); + } + else s7i_vector_setter_set(sc, vec, i2 + (i1 * s7i_vector_offset(vec, 0)), value); + return(value); +} + +s7_pointer vector_set_p_piip_direct(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2, s7_pointer value) +{ + /* normal untyped vector, rank == 2 */ + if ((i1 < 0) || (i2 < 0) || + (i1 >= s7_vector_dimension(vec, 0)) || (i2 >= s7_vector_dimension(vec, 1))) + return(s7i_g_vector_set(sc, s7i_set_plist_4(sc, vec, s7_make_integer(sc, i1), s7_make_integer(sc, i2), value))); + s7i_vector_element_set(vec, i2 + (i1 * s7i_vector_offset(vec, 0)), value); + return(value); +} + +s7_pointer typed_vector_set_p_pip_unchecked(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value) +{ + if ((index >= 0) && (index < s7_vector_length(vec))) + s7i_typed_vector_setter(sc, vec, index, value); + else out_of_range_error_nr(sc, s7_make_symbol(sc, "vector-set!"), s7i_wrap_integer(sc, 2), s7i_wrap_integer(sc, index), + (index < 0) ? it_is_negative_string : it_is_too_large_string); + return(value); +} + +s7_pointer typed_vector_set_p_piip_direct(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2, s7_pointer value) +{ + if ((i1 < 0) || (i2 < 0) || + (i1 >= s7_vector_dimension(vec, 0)) || (i2 >= s7_vector_dimension(vec, 1))) + return(s7i_g_vector_set(sc, s7i_set_plist_4(sc, vec, s7_make_integer(sc, i1), s7_make_integer(sc, i2), value))); + return(s7i_typed_vector_setter(sc, vec, i2 + (i1 * s7i_vector_offset(vec, 0)), value)); +} + +s7_pointer t_vector_set_p_pip_direct(s7_scheme *unused_sc, s7_pointer vec, s7_int index, s7_pointer value) +{ + s7i_vector_element_set(vec, index, value); + return(value); +} + +s7_pointer typed_t_vector_set_p_pip_direct(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value) +{ + s7i_typed_vector_setter(sc, vec, index, value); + return(value); +} + +s7_pointer vector_set_p_ppp(s7_scheme *sc, s7_pointer vec, s7_pointer ind, s7_pointer val) +{ + s7_int index; + if ((!s7i_is_t_vector(vec)) || (s7_vector_rank(vec) > 1)) + return(s7i_g_vector_set(sc, s7i_set_plist_3(sc, vec, ind, val))); + if (s7i_is_immutable_vector(vec)) + immutable_object_error_nr(sc, s7i_set_elist_3(sc, immutable_error_string, s7_make_symbol(sc, "vector-set!"), vec)); + if (!s7_is_integer(ind)) + return(s7i_g_vector_set(sc, s7i_set_plist_3(sc, vec, ind, val))); + index = s7i_integer_clamped_if_gmp(sc, ind); + if ((index < 0) || (index >= s7_vector_length(vec))) + out_of_range_error_nr(sc, s7_make_symbol(sc, "vector-set!"), s7i_wrap_integer(sc, 2), s7i_wrap_integer(sc, index), + (index < 0) ? it_is_negative_string : it_is_too_large_string); + + if (s7i_is_typed_vector(vec)) + return(s7i_typed_vector_setter(sc, vec, index, val)); + s7i_vector_element_set(vec, index, val); + return(val); +} + +s7_pointer byte_vector_ref_p_pi_direct(s7_scheme *unused_sc, s7_pointer vec, s7_int index) +{ + return(s7i_small_int(s7i_byte_vector_element(vec, index))); +} + +s7_pointer byte_vector_set_p_pip_direct(s7_scheme *unused_sc, s7_pointer vec, s7_int index, s7_pointer byte) +{ + s7i_byte_vector_element_set(vec, index, (uint8_t)s7_integer(byte)); + return(byte); +} + #endif diff --git a/TeXmacs/plugins/goldfish/src/s7_liii_vector.h b/TeXmacs/plugins/goldfish/src/s7_liii_vector.h index 5e348941dc..32cdf34d89 100644 --- a/TeXmacs/plugins/goldfish/src/s7_liii_vector.h +++ b/TeXmacs/plugins/goldfish/src/s7_liii_vector.h @@ -42,6 +42,7 @@ s7_pointer g_cv_ref_2(s7_scheme *sc, s7_pointer args); s7_pointer g_fv_ref_2(s7_scheme *sc, s7_pointer args); s7_pointer g_iv_ref_2(s7_scheme *sc, s7_pointer args); s7_pointer g_cv_set_3(s7_scheme *sc, s7_pointer args); +s7_pointer g_vector_filter(s7_scheme *sc, s7_pointer args); #if !WITH_PURE_S7 s7_pointer g_list_to_vector(s7_scheme *sc, s7_pointer args); @@ -50,6 +51,30 @@ s7_pointer g_make_vector(s7_scheme *sc, s7_pointer args); s7_pointer g_vector_fill(s7_scheme *sc, s7_pointer args); s7_int vector_length_i_7p(s7_scheme *sc, s7_pointer vec); s7_pointer vector_length_p_p(s7_scheme *sc, s7_pointer vec); + +/* optimizer typed-arg (p_p) functions, migrated from s7.c; + the optimizer compares these pointers, so each has a single + extern definition in s7_liii_vector.c */ +s7_pointer vector_append_p_pp(s7_scheme *sc, s7_pointer v1, s7_pointer v2); +s7_pointer vector_append_p_ppp(s7_scheme *sc, s7_pointer v1, s7_pointer v2, s7_pointer v3); +s7_pointer vector_to_list_p_p(s7_scheme *sc, s7_pointer vec); +s7_pointer vector_ref_p_pi(s7_scheme *sc, s7_pointer vec, s7_int index); +s7_pointer vector_ref_p_pi_unchecked(s7_scheme *sc, s7_pointer vec, s7_int index); +s7_pointer t_vector_ref_p_pi_unchecked(s7_scheme *sc, s7_pointer vec, s7_int index); +s7_pointer vector_ref_p_pii(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2); +s7_pointer vector_ref_p_pii_direct(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2); +s7_pointer t_vector_ref_p_pi_direct(s7_scheme *sc, s7_pointer vec, s7_int index); +s7_pointer vector_set_p_pip(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value); +s7_pointer vector_set_p_pip_unchecked(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value); +s7_pointer vector_set_p_piip(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2, s7_pointer value); +s7_pointer vector_set_p_piip_direct(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2, s7_pointer value); +s7_pointer typed_vector_set_p_pip_unchecked(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value); +s7_pointer typed_vector_set_p_piip_direct(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2, s7_pointer value); +s7_pointer t_vector_set_p_pip_direct(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value); +s7_pointer typed_t_vector_set_p_pip_direct(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value); +s7_pointer vector_set_p_ppp(s7_scheme *sc, s7_pointer vec, s7_pointer ind, s7_pointer val); +s7_pointer byte_vector_ref_p_pi_direct(s7_scheme *sc, s7_pointer vec, s7_int index); +s7_pointer byte_vector_set_p_pip_direct(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer byte); #endif #ifdef __cplusplus diff --git a/TeXmacs/plugins/goldfish/src/s7_r7rs_library.c b/TeXmacs/plugins/goldfish/src/s7_r7rs_library.c new file mode 100644 index 0000000000..854c19bba8 --- /dev/null +++ b/TeXmacs/plugins/goldfish/src/s7_r7rs_library.c @@ -0,0 +1,784 @@ +// +// Copyright (C) 2026 The Goldfish Scheme Authors +// +// Licensed under the Apache License, Version 2.0 (the "License"); +// you may not use this file except in compliance with the License. +// You may obtain a copy of the License at +// +// http://www.apache.org/licenses/LICENSE-2.0 +// +// Unless required by applicable law or agreed to in writing, software +// distributed under the License is distributed on an "AS IS" BASIS, +// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the +// License for the specific language governing permissions and limitations +// under the License. +// + +/* s7_r7rs_library.c - R7RS library registry for Goldfish Scheme + * + * The registry maps an R7RS library name (a proper list of symbols and + * non-negative integers, e.g. (liii base)) to the let environment holding + * the library's exported bindings. It lives in the rootlet variable + * *r7rs-libraries* so that it is reachable by the garbage collector. + */ + +#include "s7_r7rs_library.h" + +#include +#include +#include +#include + +#define R7RS_LIBRARIES_NAME "*r7rs-libraries*" + +static s7_pointer +r7rs_library_error (s7_scheme* sc, const char* kind, const char* msg, s7_pointer arg) { + return s7_error (sc, s7_make_symbol (sc, kind), s7_list (sc, 2, s7_make_string (sc, msg), arg)); +} + +static s7_pointer +r7rs_library_registry (s7_scheme* sc) { + return s7_name_to_value (sc, R7RS_LIBRARIES_NAME); +} + +/* R7RS: a library name is a proper list whose elements are symbols or + * exact non-negative integers. Returns true iff name is valid. */ +static bool +r7rs_library_name_valid (s7_scheme* sc, s7_pointer name) { + if ((!s7_is_null (sc, name)) && (!s7_is_pair (name))) return false; /* not a list at all */ + if (s7_list_length (sc, name) < 0) return false; /* improper or circular list */ + for (s7_pointer p= name; s7_is_pair (p); p= s7_cdr (p)) { + s7_pointer elt= s7_car (p); + if (s7_is_symbol (elt)) continue; + if (s7_is_integer (elt) && s7_integer (elt) >= 0) continue; + return false; + } + return true; +} + +static s7_pointer +r7rs_library_check_name (s7_scheme* sc, const char* caller, s7_pointer name) { + if (!r7rs_library_name_valid (sc, name)) + return r7rs_library_error (sc, "wrong-type-arg", + "library name should be a proper list of symbols or non-negative integers, but got ~S", + name); + return NULL; +} + +static s7_pointer +g_library_defined_p (s7_scheme* sc, s7_pointer args) { + s7_pointer name= s7_car (args); + s7_pointer err = r7rs_library_check_name (sc, "g_library-defined?", name); + if (err) return err; + return s7_make_boolean (sc, s7_is_let (s7_hash_table_ref (sc, r7rs_library_registry (sc), name))); +} + +static s7_pointer +g_library_ref (s7_scheme* sc, s7_pointer args) { + s7_pointer name= s7_car (args); + s7_pointer err = r7rs_library_check_name (sc, "g_library-ref", name); + if (err) return err; + s7_pointer env= s7_hash_table_ref (sc, r7rs_library_registry (sc), name); + return s7_is_let (env) ? env : s7_f (sc); +} + +static s7_pointer +g_library_register (s7_scheme* sc, s7_pointer args) { + s7_pointer name= s7_car (args); + s7_pointer err = r7rs_library_check_name (sc, "g_library-register!", name); + if (err) return err; + s7_pointer env= s7_cadr (args); + if (!s7_is_let (env)) + return r7rs_library_error (sc, "wrong-type-arg", "library environment should be a let, but got ~S", env); + s7_hash_table_set (sc, r7rs_library_registry (sc), name, env); + return env; +} + +static s7_pointer +g_library_unregister (s7_scheme* sc, s7_pointer args) { + s7_pointer name= s7_car (args); + s7_pointer err = r7rs_library_check_name (sc, "g_library-unregister!", name); + if (err) return err; + /* s7 hash tables have no delete; storing #f marks the entry as absent + * (g_library-defined?/g_library-ref only accept let values). */ + s7_hash_table_set (sc, r7rs_library_registry (sc), name, s7_f (sc)); + return s7_unspecified (sc); +} + +/* -------- define-library helpers (defined below) -------- */ + +static bool r7rs_decl_named (s7_pointer decl, const char* name); +static s7_pointer r7rs_export_spec_names (s7_scheme* sc, s7_pointer spec, s7_pointer* internal); +static s7_pointer r7rs_entries_find (s7_pointer entries, s7_pointer sym); +static char* r7rs_library_name_to_path (s7_scheme* sc, s7_pointer libname); + +/* -------- cond-expand (library declarations) -------- */ + +/* is the library available: registered, or present as a file in some *load-path* directory? */ +static bool +r7rs_library_available (s7_scheme* sc, s7_pointer libname) { + if (s7_is_let (s7_hash_table_ref (sc, r7rs_library_registry (sc), libname))) return true; + char* relpath = r7rs_library_name_to_path (sc, libname); + bool found = false; + s7_pointer load_path= s7_name_to_value (sc, "*load-path*"); + for (s7_pointer p= load_path; (s7_is_pair (p)) && (!found); p= s7_cdr (p)) { + if (!s7_is_string (s7_car (p))) continue; + const char* dir= s7_string (s7_car (p)); + size_t n = strlen (dir) + strlen (relpath) + 2; + char* full= (char*) malloc (n); + snprintf (full, n, "%s/%s", dir, relpath); + FILE* fp= fopen (full, "r"); + if (fp) { + fclose (fp); + found= true; + } + free (full); + } + free (relpath); + return found; +} + +/* evaluate an R7RS feature requirement: a feature identifier, (library name), + * or (and/or/not ...) compositions */ +static bool +r7rs_feature_satisfied (s7_scheme* sc, s7_pointer req) { + if (s7_is_symbol (req)) return s7_is_provided (sc, s7_symbol_name (req)); + if (!s7_is_pair (req)) { + r7rs_library_error (sc, "syntax-error", "cond-expand: invalid feature requirement ~S", req); + return false; + } + s7_pointer head= s7_car (req); + if (!s7_is_symbol (head)) { + r7rs_library_error (sc, "syntax-error", "cond-expand: invalid feature requirement ~S", req); + return false; + } + const char* op= s7_symbol_name (head); + if (strcmp (op, "library") == 0) { + if ((s7_list_length (sc, req) != 2) || (!r7rs_library_name_valid (sc, s7_cadr (req)))) { + r7rs_library_error (sc, "syntax-error", "cond-expand: malformed (library ...) requirement ~S", req); + return false; + } + return r7rs_library_available (sc, s7_cadr (req)); + } + if (strcmp (op, "and") == 0) { + for (s7_pointer p= s7_cdr (req); s7_is_pair (p); p= s7_cdr (p)) + if (!r7rs_feature_satisfied (sc, s7_car (p))) return false; + return true; + } + if (strcmp (op, "or") == 0) { + for (s7_pointer p= s7_cdr (req); s7_is_pair (p); p= s7_cdr (p)) + if (r7rs_feature_satisfied (sc, s7_car (p))) return true; + return false; + } + if (strcmp (op, "not") == 0) { + if (s7_list_length (sc, req) != 2) { + r7rs_library_error (sc, "syntax-error", "cond-expand: (not ...) takes exactly one requirement, got ~S", req); + return false; + } + return !r7rs_feature_satisfied (sc, s7_cadr (req)); + } + r7rs_library_error (sc, "syntax-error", "cond-expand: unknown feature requirement ~S", req); + return false; +} + +/* choose the body (a list of declarations) of the first matching clause of a + * cond-expand declaration; returns NULL (no allocation) if nothing matches */ +static s7_pointer +r7rs_cond_expand_choose (s7_scheme* sc, s7_pointer clauses) { + for (s7_pointer p= clauses; s7_is_pair (p); p= s7_cdr (p)) { + s7_pointer clause= s7_car (p); + if (!s7_is_pair (clause)) { + r7rs_library_error (sc, "syntax-error", "cond-expand: clause is not a list: ~S", clause); + return NULL; + } + s7_pointer req= s7_car (clause); + if ((s7_is_symbol (req)) && (strcmp (s7_symbol_name (req), "else") == 0)) return s7_cdr (clause); + if (r7rs_feature_satisfied (sc, req)) return s7_cdr (clause); + } + return NULL; +} + +/* R7RS cond-expand, replacing s7's built-in read-time expansion (which neither + * supports (library ...) requirements nor clauses with multiple body forms). + * Registered as a plain c-macro, so the reader no longer expands cond-expand + * forms and define-library bodies can process them as declarations. */ +static s7_pointer +g_cond_expand_r7rs (s7_scheme* sc, s7_pointer args) { + s7_gc_protect_via_stack (sc, args); + s7_pointer chosen = r7rs_cond_expand_choose (sc, args); + s7_pointer expansion= + chosen ? s7_cons (sc, s7_make_symbol (sc, "begin"), chosen) : s7_unspecified (sc); + s7_gc_unprotect_via_stack (sc, args); + return expansion; +} + +/* -------- define-library passes -------- */ + +enum { R7RS_PASS_EVAL, R7RS_PASS_VALIDATE, R7RS_PASS_POPULATE }; + +typedef struct { + s7_pointer lib_env; + s7_pointer entries; + s7_pointer export_env; + bool saw_export; +} r7rs_define_library_ctx; + +static void r7rs_walk_library_decls (s7_scheme* sc, s7_pointer decls, int mode, r7rs_define_library_ctx* ctx); + +/* -------- include -------- */ + +static bool +r7rs_file_readable (const char* path) { + FILE* fp= fopen (path, "r"); + if (!fp) return false; + fclose (fp); + return true; +} + +static char* +r7rs_str_dup (const char* s) { + size_t n= strlen (s) + 1; + char* r= (char*) malloc (n); + memcpy (r, s, n); + return r; +} + +/* resolve an include file: first relative to the directory of the file + * currently being loaded, then each *load-path* directory, then the name + * as-is. Returns a malloc'd path, or NULL if not found. */ +static char* +r7rs_find_include_file (s7_scheme* sc, const char* name) { + s7_pointer port= s7_current_input_port (sc); + const char* current= s7_port_filename (sc, port); + if (current) { + const char* sep= strrchr (current, '/'); + if (!sep) sep= strrchr (current, '\\'); + if (sep) { + size_t dir_len= (size_t) (sep - current); + char* candidate= (char*) malloc (dir_len + 1 + strlen (name) + 1); + memcpy (candidate, current, dir_len); + candidate[dir_len]= '/'; + strcpy (candidate + dir_len + 1, name); + if (r7rs_file_readable (candidate)) return candidate; + free (candidate); + } + } + s7_pointer load_path= s7_name_to_value (sc, "*load-path*"); + for (s7_pointer p= load_path; s7_is_pair (p); p= s7_cdr (p)) { + if (!s7_is_string (s7_car (p))) continue; + const char* dir= s7_string (s7_car (p)); + size_t n = strlen (dir) + strlen (name) + 2; + char* candidate= (char*) malloc (n); + snprintf (candidate, n, "%s/%s", dir, name); + if (r7rs_file_readable (candidate)) return candidate; + free (candidate); + } + if (r7rs_file_readable (name)) return r7rs_str_dup (name); + return NULL; +} + +/* read an entire file; returns a malloc'd NUL-terminated string, or NULL */ +static char* +r7rs_read_file_text (const char* path) { + FILE* fp= fopen (path, "rb"); + if (!fp) return NULL; + fseek (fp, 0, SEEK_END); + long size= ftell (fp); + if (size < 0) { + fclose (fp); + return NULL; + } + rewind (fp); + char* text= (char*) malloc ((size_t) size + 1); + size_t got= fread (text, 1, (size_t) size, fp); + fclose (fp); + text[got]= '\0'; + return text; +} + +/* validate the filename arguments of an include declaration */ +static s7_pointer +r7rs_include_check_files (s7_scheme* sc, s7_pointer files) { + for (s7_pointer p= files; s7_is_pair (p); p= s7_cdr (p)) + if (!s7_is_string (s7_car (p))) + return r7rs_library_error (sc, "wrong-type-arg", "include: filename should be a string, got ~S", s7_car (p)); + return NULL; +} + +/* (include "file" ...) / (include-ci "file" ...): the file contents are library + * body forms, as if wrapped in begin. Note: the s7 reader has no case-folding + * mode, so include-ci currently behaves exactly like include. */ +static void +r7rs_include_files (s7_scheme* sc, s7_pointer files, s7_pointer lib_env) { + s7_pointer err= r7rs_include_check_files (sc, files); + if (err) return; + for (s7_pointer p= files; s7_is_pair (p); p= s7_cdr (p)) { + s7_pointer name= s7_car (p); + char* path= r7rs_find_include_file (sc, s7_string (name)); + if (!path) { + r7rs_library_error (sc, "io-error", "include: cannot find file ~S", name); + return; + } + char* text= r7rs_read_file_text (path); + free (path); + if (!text) { + r7rs_library_error (sc, "io-error", "include: cannot read file ~S", name); + return; + } + s7_pointer port= s7_open_input_string (sc, text); /* the port references text */ + s7_gc_protect_via_stack (sc, port); + s7_pointer eof= s7_eof_object (sc); + s7_pointer form; + while ((form= s7_read (sc, port)) != eof) + s7_eval (sc, form, lib_env); + s7_gc_unprotect_via_stack (sc, port); + free (text); + } +} + +/* (include-library-declarations "file" ...): the file contents are library + * declarations, spliced into the declaration stream */ +static void +r7rs_include_library_declarations (s7_scheme* sc, s7_pointer files, int mode, r7rs_define_library_ctx* ctx) { + s7_pointer err= r7rs_include_check_files (sc, files); + if (err) return; + for (s7_pointer p= files; s7_is_pair (p); p= s7_cdr (p)) { + s7_pointer name= s7_car (p); + char* path= r7rs_find_include_file (sc, s7_string (name)); + if (!path) { + r7rs_library_error (sc, "io-error", "include-library-declarations: cannot find file ~S", name); + return; + } + char* text= r7rs_read_file_text (path); + free (path); + if (!text) { + r7rs_library_error (sc, "io-error", "include-library-declarations: cannot read file ~S", name); + return; + } + s7_pointer port= s7_open_input_string (sc, text); /* the port references text */ + s7_gc_protect_via_stack (sc, port); + s7_pointer eof = s7_eof_object (sc); + s7_pointer forms= s7_nil (sc); + s7_gc_protect_via_stack (sc, forms); + s7_pointer form; + while ((form= s7_read (sc, port)) != eof) { + s7_gc_protect_via_stack (sc, form); + forms= s7_cons (sc, form, forms); /* reversed */ + s7_gc_unprotect_via_stack (sc, form); + s7_gc_unprotect_via_stack (sc, forms); + s7_gc_protect_via_stack (sc, forms); + } + /* reverse in place (no allocation, so no GC risk): restore source order */ + s7_pointer rev= s7_nil (sc); + for (s7_pointer q= forms; s7_is_pair (q);) { + s7_pointer next= s7_cdr (q); + s7_set_cdr (q, rev); + rev= q; + q = next; + } + /* the last cons cell (old head) is still on the protect stack and anchors + * the whole chain, which now starts at rev */ + r7rs_walk_library_decls (sc, rev, mode, ctx); + s7_gc_unprotect_via_stack (sc, forms); + s7_gc_unprotect_via_stack (sc, port); + free (text); + } +} + +/* pass 2 helper: every export spec must be well-formed and name a binding of the + * library body, or a binding that falls through to the rootlet */ +static void +r7rs_validate_export_decl (s7_scheme* sc, s7_pointer decl, s7_pointer entries) { + for (s7_pointer specs= s7_cdr (decl); s7_is_pair (specs); specs= s7_cdr (specs)) { + s7_pointer internal= NULL; + r7rs_export_spec_names (sc, s7_car (specs), &internal); + if ((!r7rs_entries_find (entries, internal)) && (!s7_is_defined (sc, s7_symbol_name (internal)))) + r7rs_library_error (sc, "unbound-variable", "define-library: cannot export ~S: it is not defined in " + "the library body", + internal); + } +} + +/* pass 3 helper: materialize the exported bindings into export_env */ +static void +r7rs_populate_export_decl (s7_scheme* sc, s7_pointer decl, s7_pointer entries, s7_pointer export_env, s7_pointer lib_env) { + for (s7_pointer specs= s7_cdr (decl); s7_is_pair (specs); specs= s7_cdr (specs)) { + s7_pointer internal= NULL; + s7_pointer external= r7rs_export_spec_names (sc, s7_car (specs), &internal); + s7_pointer entry = r7rs_entries_find (entries, internal); + /* only the library body's own bindings are materialized in the export + * environment. Names that fall through to the rootlet (pass 2 allows + * them, e.g. (scheme base) re-exporting eqv?) stay virtual: the export + * environment's outlet chain resolves them, exactly like the old + * Scheme implementation. Copying hundreds of rootlet bindings into + * every export environment (and from there into every importer) would + * be a measurable slowdown. */ + if (entry) s7_varlet (sc, export_env, external, s7_cdr (entry)); + else + if (external != internal) { + /* a renamed rootlet re-export (export (rename eqv? same?)): the new + * name does not exist in the rootlet, so it must be materialized */ + s7_pointer value= s7_let_ref (sc, lib_env, internal); + /* syntactic rootlet bindings (define* etc.) cannot be let slots in s7; + * skip them, matching the old Scheme implementation */ + if (!s7_is_syntax (value)) s7_varlet (sc, export_env, external, value); + } + } +} + +static void +r7rs_walk_library_decls (s7_scheme* sc, s7_pointer decls, int mode, r7rs_define_library_ctx* ctx) { + for (s7_pointer p= decls; s7_is_pair (p); p= s7_cdr (p)) { + s7_pointer decl= s7_car (p); + if (r7rs_decl_named (decl, "cond-expand")) { + s7_pointer chosen= r7rs_cond_expand_choose (sc, s7_cdr (decl)); + if (chosen) r7rs_walk_library_decls (sc, chosen, mode, ctx); + continue; + } + /* include-library-declarations splices declarations: handle in every pass */ + if (r7rs_decl_named (decl, "include-library-declarations")) { + r7rs_include_library_declarations (sc, s7_cdr (decl), mode, ctx); + continue; + } + /* include/include-ci splice body forms: only the eval pass cares */ + if ((r7rs_decl_named (decl, "include")) || (r7rs_decl_named (decl, "include-ci"))) { + if (mode == R7RS_PASS_EVAL) r7rs_include_files (sc, s7_cdr (decl), ctx->lib_env); + continue; + } + switch (mode) { + case R7RS_PASS_EVAL: + if (!r7rs_decl_named (decl, "export")) s7_eval (sc, decl, ctx->lib_env); + break; + case R7RS_PASS_VALIDATE: + if (r7rs_decl_named (decl, "export")) { + ctx->saw_export= true; + r7rs_validate_export_decl (sc, decl, ctx->entries); + } + break; + case R7RS_PASS_POPULATE: + if (r7rs_decl_named (decl, "export")) + r7rs_populate_export_decl (sc, decl, ctx->entries, ctx->export_env, ctx->lib_env); + break; + } + } +} + +static bool +r7rs_decl_named (s7_pointer decl, const char* name) { + return (s7_is_pair (decl)) && (s7_is_symbol (s7_car (decl))) && + (strcmp (s7_symbol_name (s7_car (decl)), name) == 0); +} + +/* An export spec is either a symbol (external == internal) or (rename old new). + * On success stores the internal name in *internal and returns the external name; + * on a malformed spec an error is signalled. */ +static s7_pointer +r7rs_export_spec_names (s7_scheme* sc, s7_pointer spec, s7_pointer* internal) { + if (s7_is_symbol (spec)) { + *internal= spec; + return spec; + } + if ((s7_is_pair (spec)) && (r7rs_decl_named (spec, "rename")) && (s7_list_length (sc, spec) == 3) && + (s7_is_symbol (s7_cadr (spec))) && (s7_is_symbol (s7_caddr (spec)))) { + *internal= s7_cadr (spec); + return s7_caddr (spec); + } + return r7rs_library_error (sc, "syntax-error", "define-library: invalid export spec ~S", spec); +} + +/* Find the binding entry (a (symbol . value) pair of s7_let_to_list) for sym + * among the own slots of env, or NULL if sym is not bound in env itself + * (outlets are deliberately not searched: only definitions and imports of the + * library body count). */ +static s7_pointer +r7rs_entries_find (s7_pointer entries, s7_pointer sym) { + for (s7_pointer p= entries; s7_is_pair (p); p= s7_cdr (p)) { + s7_pointer entry= s7_car (p); + if (s7_car (entry) == sym) return entry; + } + return NULL; +} + +static s7_pointer +g_define_library (s7_scheme* sc, s7_pointer args) { + s7_gc_protect_via_stack (sc, args); + s7_pointer libname= s7_car (args); + if (!r7rs_library_name_valid (sc, libname)) + return r7rs_library_error (sc, "wrong-type-arg", + "define-library: invalid library name ~S (a proper list of symbols or non-negative " + "integers expected)", + libname); + + r7rs_define_library_ctx ctx; + ctx.saw_export= false; + + /* the working environment: definitions and imports of the library body land here */ + ctx.lib_env= s7_sublet (sc, s7_rootlet (sc), s7_nil (sc)); + s7_gc_protect_via_stack (sc, ctx.lib_env); + + /* pass 1: evaluate every declaration except export in lib_env + * (cond-expand clauses are resolved and recursed into by the walker) */ + r7rs_walk_library_decls (sc, s7_cdr (args), R7RS_PASS_EVAL, &ctx); + + /* the own slots of lib_env, as (symbol . value) entries */ + ctx.entries= s7_let_to_list (sc, ctx.lib_env); + s7_gc_protect_via_stack (sc, ctx.entries); + + /* pass 2: validate export specs before mutating any visible state */ + r7rs_walk_library_decls (sc, s7_cdr (args), R7RS_PASS_VALIDATE, &ctx); + + ctx.export_env= s7_inlet (sc, s7_nil (sc)); + s7_gc_protect_via_stack (sc, ctx.export_env); + + /* make the library reachable before populating it: the registry entry and the + * compatibility global symbol (used by the Scheme import implementation) */ + s7_hash_table_set (sc, r7rs_library_registry (sc), libname, ctx.export_env); + char* name_str= s7_object_to_c_string (sc, libname); + s7_define (sc, s7_rootlet (sc), s7_make_symbol (sc, name_str), ctx.export_env); + free (name_str); + + /* populate: with no export declaration every binding is exported */ + if (!ctx.saw_export) { + for (s7_pointer p= ctx.entries; s7_is_pair (p); p= s7_cdr (p)) { + s7_pointer entry= s7_car (p); + s7_varlet (sc, ctx.export_env, s7_car (entry), s7_cdr (entry)); + } + } + else r7rs_walk_library_decls (sc, s7_cdr (args), R7RS_PASS_POPULATE, &ctx); + + s7_gc_unprotect_via_stack (sc, ctx.export_env); + s7_gc_unprotect_via_stack (sc, ctx.entries); + s7_gc_unprotect_via_stack (sc, ctx.lib_env); + s7_gc_unprotect_via_stack (sc, args); + return s7_t (sc); +} + +/* -------- import -------- */ + +/* map a library name (liii base) to the file path "liii/base.scm" */ +static char* +r7rs_library_name_to_path (s7_scheme* sc, s7_pointer libname) { + size_t len= 1; /* NUL */ + for (s7_pointer p= libname; s7_is_pair (p); p= s7_cdr (p)) { + s7_pointer elt= s7_car (p); + len+= (s7_is_symbol (elt) ? strlen (s7_symbol_name (elt)) : 24) + 1; /* '/' or ".scm" */ + } + char* path= (char*) malloc (len + 4); + char* w = path; + for (s7_pointer p= libname; s7_is_pair (p); p= s7_cdr (p)) { + s7_pointer elt= s7_car (p); + if (w != path) *w++= '/'; + if (s7_is_symbol (elt)) { + size_t n= strlen (s7_symbol_name (elt)); + memcpy (w, s7_symbol_name (elt), n); + w+= n; + } + else w+= sprintf (w, "%lld", (long long) s7_integer (elt)); + } + memcpy (w, ".scm", 5); /* with NUL */ + return path; +} + +/* return the exported environment of libname, loading its file on first use */ +static s7_pointer +r7rs_library_env (s7_scheme* sc, s7_pointer libname) { + s7_pointer env= s7_hash_table_ref (sc, r7rs_library_registry (sc), libname); + if (s7_is_let (env)) return env; + char* path= r7rs_library_name_to_path (sc, libname); + s7_load (sc, path); /* errors if the file cannot be found */ + free (path); + env= s7_hash_table_ref (sc, r7rs_library_registry (sc), libname); + if (!s7_is_let (env)) + return r7rs_library_error (sc, "unbound-variable", "import: loading did not define the library ~S", libname); + return env; +} + +static s7_pointer r7rs_import_set_env (s7_scheme* sc, s7_pointer iset); + +/* is sym a member of the symbol list names? */ +static bool +r7rs_symbol_member (s7_pointer names, s7_pointer sym) { + for (s7_pointer p= names; s7_is_pair (p); p= s7_cdr (p)) + if (s7_car (p) == sym) return true; + return false; +} + +static s7_pointer +r7rs_import_check_names (s7_scheme* sc, s7_pointer names) { + for (s7_pointer p= names; s7_is_pair (p); p= s7_cdr (p)) + if (!s7_is_symbol (s7_car (p))) + return r7rs_library_error (sc, "wrong-type-arg", "import: expected an identifier, got ~S", s7_car (p)); + return NULL; +} + +/* (only import-set identifier ...) */ +static s7_pointer +r7rs_import_only (s7_scheme* sc, s7_pointer iset) { + s7_pointer rest= s7_cdr (iset); + if (!s7_is_pair (rest)) + return r7rs_library_error (sc, "syntax-error", "import: (only ...) needs an import set, got ~S", iset); + s7_pointer err= r7rs_import_check_names (sc, s7_cdr (rest)); + if (err) return err; + s7_pointer sub= r7rs_import_set_env (sc, s7_car (rest)); + s7_gc_protect_via_stack (sc, sub); + s7_pointer env= s7_inlet (sc, s7_nil (sc)); + s7_gc_protect_via_stack (sc, env); + for (s7_pointer names= s7_cdr (rest); s7_is_pair (names); names= s7_cdr (names)) { + s7_pointer name= s7_car (names); + s7_varlet (sc, env, name, s7_let_ref (sc, sub, name)); /* let-ref errors if name is missing */ + } + s7_gc_unprotect_via_stack (sc, env); + s7_gc_unprotect_via_stack (sc, sub); + return env; +} + +/* (except import-set identifier ...) */ +static s7_pointer +r7rs_import_except (s7_scheme* sc, s7_pointer iset) { + s7_pointer rest= s7_cdr (iset); + if (!s7_is_pair (rest)) + return r7rs_library_error (sc, "syntax-error", "import: (except ...) needs an import set, got ~S", iset); + s7_pointer err= r7rs_import_check_names (sc, s7_cdr (rest)); + if (err) return err; + s7_pointer sub= r7rs_import_set_env (sc, s7_car (rest)); + s7_gc_protect_via_stack (sc, sub); + s7_pointer env= s7_inlet (sc, s7_nil (sc)); + s7_gc_protect_via_stack (sc, env); + s7_pointer entries= s7_let_to_list (sc, sub); + s7_gc_protect_via_stack (sc, entries); + s7_pointer names= s7_cdr (rest); + for (s7_pointer p= entries; s7_is_pair (p); p= s7_cdr (p)) { + s7_pointer entry= s7_car (p); + if (!r7rs_symbol_member (names, s7_car (entry))) s7_varlet (sc, env, s7_car (entry), s7_cdr (entry)); + } + s7_gc_unprotect_via_stack (sc, entries); + s7_gc_unprotect_via_stack (sc, env); + s7_gc_unprotect_via_stack (sc, sub); + return env; +} + +/* (prefix import-set prefix-identifier) */ +static s7_pointer +r7rs_import_prefix (s7_scheme* sc, s7_pointer iset) { + if ((s7_list_length (sc, iset) != 3) || (!s7_is_symbol (s7_caddr (iset)))) + return r7rs_library_error (sc, "syntax-error", + "import: (prefix ...) needs an import set and a prefix identifier, got ~S", iset); + s7_pointer sub= r7rs_import_set_env (sc, s7_cadr (iset)); + s7_gc_protect_via_stack (sc, sub); + s7_pointer env= s7_inlet (sc, s7_nil (sc)); + s7_gc_protect_via_stack (sc, env); + s7_pointer entries= s7_let_to_list (sc, sub); + s7_gc_protect_via_stack (sc, entries); + const char* pre= s7_symbol_name (s7_caddr (iset)); + size_t pre_len= strlen (pre); + for (s7_pointer p= entries; s7_is_pair (p); p= s7_cdr (p)) { + s7_pointer entry= s7_car (p); + const char* name = s7_symbol_name (s7_car (entry)); + size_t name_len= strlen (name); + char* buf= (char*) malloc (pre_len + name_len + 1); + memcpy (buf, pre, pre_len); + memcpy (buf + pre_len, name, name_len + 1); + s7_varlet (sc, env, s7_make_symbol (sc, buf), s7_cdr (entry)); + free (buf); + } + s7_gc_unprotect_via_stack (sc, entries); + s7_gc_unprotect_via_stack (sc, env); + s7_gc_unprotect_via_stack (sc, sub); + return env; +} + +/* (rename import-set (old new) ...) */ +static s7_pointer +r7rs_import_rename (s7_scheme* sc, s7_pointer iset) { + s7_pointer rest= s7_cdr (iset); + if (!s7_is_pair (rest)) + return r7rs_library_error (sc, "syntax-error", "import: (rename ...) needs an import set, got ~S", iset); + for (s7_pointer specs= s7_cdr (rest); s7_is_pair (specs); specs= s7_cdr (specs)) { + s7_pointer spec= s7_car (specs); + if ((s7_list_length (sc, spec) != 2) || (!s7_is_symbol (s7_car (spec))) || (!s7_is_symbol (s7_cadr (spec)))) + return r7rs_library_error (sc, "syntax-error", "import: rename expects (old new) pairs, got ~S", spec); + } + s7_pointer sub= r7rs_import_set_env (sc, s7_car (rest)); + s7_gc_protect_via_stack (sc, sub); + s7_pointer env= s7_inlet (sc, s7_nil (sc)); + s7_gc_protect_via_stack (sc, env); + s7_pointer entries= s7_let_to_list (sc, sub); + s7_gc_protect_via_stack (sc, entries); + s7_pointer specs= s7_cdr (rest); + for (s7_pointer p= entries; s7_is_pair (p); p= s7_cdr (p)) { + s7_pointer entry= s7_car (p); + s7_pointer name = s7_car (entry); + for (s7_pointer q= specs; s7_is_pair (q); q= s7_cdr (q)) { + s7_pointer spec= s7_car (q); + if (s7_car (spec) == name) { + name= s7_cadr (spec); + break; + } + } + s7_varlet (sc, env, name, s7_cdr (entry)); + } + s7_gc_unprotect_via_stack (sc, entries); + s7_gc_unprotect_via_stack (sc, env); + s7_gc_unprotect_via_stack (sc, sub); + return env; +} + +/* resolve an import set to the environment of bindings it denotes */ +static s7_pointer +r7rs_import_set_env (s7_scheme* sc, s7_pointer iset) { + if (r7rs_decl_named (iset, "only")) return r7rs_import_only (sc, iset); + if (r7rs_decl_named (iset, "except")) return r7rs_import_except (sc, iset); + if (r7rs_decl_named (iset, "prefix")) return r7rs_import_prefix (sc, iset); + if (r7rs_decl_named (iset, "rename")) return r7rs_import_rename (sc, iset); + /* plain library name */ + if (!r7rs_library_name_valid (sc, iset)) + return r7rs_library_error (sc, "wrong-type-arg", "import: invalid import set ~S", iset); + return r7rs_library_env (sc, iset); +} + +static s7_pointer +g_import (s7_scheme* sc, s7_pointer args) { + s7_gc_protect_via_stack (sc, args); + /* s7 applies a c-macro without changing sc->curlet, so the current let is + * exactly the environment in which the import form appears. */ + s7_pointer target= s7_curlet (sc); + for (s7_pointer sets= args; s7_is_pair (sets); sets= s7_cdr (sets)) { + s7_pointer env= r7rs_import_set_env (sc, s7_car (sets)); + s7_gc_protect_via_stack (sc, env); + s7_pointer entries= s7_let_to_list (sc, env); + s7_gc_protect_via_stack (sc, entries); + /* varlet prepends slots, so bindings of later import sets shadow earlier ones */ + for (s7_pointer p= entries; s7_is_pair (p); p= s7_cdr (p)) { + s7_pointer entry= s7_car (p); + s7_varlet (sc, target, s7_car (entry), s7_cdr (entry)); + } + s7_gc_unprotect_via_stack (sc, entries); + s7_gc_unprotect_via_stack (sc, env); + } + s7_gc_unprotect_via_stack (sc, args); + return s7_t (sc); /* the "expansion" #t evaluates to itself */ +} + +void +glue_r7rs_library (s7_scheme* sc) { + s7_define_variable (sc, R7RS_LIBRARIES_NAME, s7_make_hash_table (sc, 64)); + s7_define_safe_function (sc, "g_library-defined?", g_library_defined_p, 1, 0, false, + "(g_library-defined? libname) returns #t if the R7RS library named libname is registered"); + s7_define_safe_function (sc, "g_library-ref", g_library_ref, 1, 0, false, + "(g_library-ref libname) returns the exported environment of the R7RS library named libname, " + "or #f if it is not registered"); + s7_define_safe_function (sc, "g_library-register!", g_library_register, 2, 0, false, + "(g_library-register! libname env) registers env as the exported environment of the R7RS " + "library named libname, replacing any previous registration"); + s7_define_safe_function (sc, "g_library-unregister!", g_library_unregister, 1, 0, false, + "(g_library-unregister! libname) removes the R7RS library named libname from the registry"); + s7_define_macro (sc, "define-library", g_define_library, 1, 0, true, + "(define-library libname decl ...) defines the R7RS library libname from the given declarations " + "(export, import, begin, ...) and registers its exported environment"); + s7_define_macro (sc, "import", g_import, 0, 0, true, + "(import import-set ...) imports the bindings denoted by each import set (a library name, " + "optionally modified by only/except/prefix/rename) into the current environment"); + s7_define_macro (sc, "cond-expand", g_cond_expand_r7rs, 0, 0, true, + "(cond-expand clause ...) chooses the first clause whose feature requirement (a feature " + "identifier, (library name), or an and/or/not composition) is satisfied"); +} diff --git a/TeXmacs/plugins/goldfish/src/s7_r7rs_library.h b/TeXmacs/plugins/goldfish/src/s7_r7rs_library.h new file mode 100644 index 0000000000..7753ef7b58 --- /dev/null +++ b/TeXmacs/plugins/goldfish/src/s7_r7rs_library.h @@ -0,0 +1,32 @@ +// +// Copyright (C) 2026 The Goldfish Scheme Authors +// +// Licensed under the Apache License, Version 2.0 (the "License"); +// you may not use this file except in compliance with the License. +// You may obtain a copy of the License at +// +// http://www.apache.org/licenses/LICENSE-2.0 +// +// Unless required by applicable law or agreed to in writing, software +// distributed under the License is distributed on an "AS IS" BASIS, +// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the +// License for the specific language governing permissions and limitations +// under the License. +// + +#ifndef S7_R7RS_LIBRARY_H +#define S7_R7RS_LIBRARY_H + +#include "s7.h" + +#ifdef __cplusplus +extern "C" { +#endif + +void glue_r7rs_library (s7_scheme* sc); + +#ifdef __cplusplus +} +#endif + +#endif /* S7_R7RS_LIBRARY_H */ diff --git a/TeXmacs/plugins/goldfish/src/s7_scheme_cxr.c b/TeXmacs/plugins/goldfish/src/s7_scheme_cxr.c new file mode 100644 index 0000000000..845274c963 --- /dev/null +++ b/TeXmacs/plugins/goldfish/src/s7_scheme_cxr.c @@ -0,0 +1,218 @@ +/* s7_scheme_cxr.c - c[ad]+r optimizer function implementations for s7 Scheme interpreter + * + * derived from s7, a Scheme interpreter + * SPDX-License-Identifier: 0BSD + * + * Bill Schottstaedt, bil@ccrma.stanford.edu + */ + +#include "s7_scheme_cxr.h" +#include "s7_internal_helpers.h" + +#include + +/* the corresponding g_caar etc are in s7_liii_list.c; these are the + typed-arg (pl_p) versions used by the optimizer */ + +#define CXR_A_LIST_STRING(sc, nm) \ + s7i_wrap_string (sc, "a pair whose " nm " is also a pair", (s7_int) (28 + sizeof (nm) - 1)) +#define CXR_METHOD_OR_BUST(sc, nm, lst) s7i_sole_arg_method_or_bust (sc, lst, nm, s7i_set_plist_1 (sc, lst), "a pair") +#define CXR_WRONG_TYPE_ERROR_NR(sc, nm, lst) \ + sole_arg_wrong_type_error_nr (sc, s7_make_symbol (sc, nm), lst, CXR_A_LIST_STRING (sc, nm)) + +/* -------- caar -------- */ + +s7_pointer +caar_p_p (s7_scheme* sc, s7_pointer lst) { + if ((s7_is_pair (lst)) && (s7_is_pair (s7_car (lst)))) return (s7_caar (lst)); + if (s7_is_pair (lst)) CXR_WRONG_TYPE_ERROR_NR (sc, "caar", lst); + return (CXR_METHOD_OR_BUST (sc, "caar", lst)); +} + +/* -------- cadr -------- */ + +s7_pointer +cadr_p_p (s7_scheme* sc, s7_pointer lst) { + if ((s7_is_pair (lst)) && (s7_is_pair (s7_cdr (lst)))) return (s7_cadr (lst)); + if (s7_is_pair (lst)) CXR_WRONG_TYPE_ERROR_NR (sc, "cdr", lst); + return (CXR_METHOD_OR_BUST (sc, "cadr", lst)); +} + +/* -------- cdar -------- */ + +s7_pointer +cdar_p_p (s7_scheme* sc, s7_pointer lst) { + if ((s7_is_pair (lst)) && (s7_is_pair (s7_car (lst)))) return (s7_cdar (lst)); + if (!s7_is_pair (lst)) CXR_WRONG_TYPE_ERROR_NR (sc, "car", lst); + return (CXR_METHOD_OR_BUST (sc, "cdar", lst)); +} + +/* -------- cddr -------- */ + +s7_pointer +cddr_p_p (s7_scheme* sc, s7_pointer lst) { + if ((s7_is_pair (lst)) && (s7_is_pair (s7_cdr (lst)))) return (s7_cddr (lst)); + if (s7_is_pair (lst)) CXR_WRONG_TYPE_ERROR_NR (sc, "cdr", lst); + return (CXR_METHOD_OR_BUST (sc, "cddr", lst)); +} + +/* -------- caaar -------- */ + +s7_pointer +caaar_p_p (s7_scheme* sc, s7_pointer lst) { + if (!s7_is_pair (lst)) return (CXR_METHOD_OR_BUST (sc, "caaar", lst)); + if (!s7_is_pair (s7_car (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "car", lst); + if (!s7_is_pair (s7_caar (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "caar", lst); + if (!s7_is_pair (s7_caar (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "caar", lst); + return (s7_caaar (lst)); +} + +/* -------- caadr -------- */ + +s7_pointer +caadr_p_p (s7_scheme* sc, s7_pointer lst) { + if ((s7_is_pair (lst)) && (s7_is_pair (s7_cdr (lst))) && (s7_is_pair (s7_cadr (lst)))) return (s7_caadr (lst)); + if (!s7_is_pair (lst)) return (CXR_METHOD_OR_BUST (sc, "caadr", lst)); + if (!s7_is_pair (s7_cdr (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "cdr", lst); + CXR_WRONG_TYPE_ERROR_NR (sc, "cadr", lst); + return (NULL); +} + +/* -------- cadar -------- */ + +s7_pointer +cadar_p_p (s7_scheme* sc, s7_pointer lst) { + if ((s7_is_pair (lst)) && (s7_is_pair (s7_car (lst))) && (s7_is_pair (s7_cdar (lst)))) return (s7_cadar (lst)); + if (!s7_is_pair (lst)) return (CXR_METHOD_OR_BUST (sc, "cadar", lst)); + if (!s7_is_pair (s7_car (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "car", lst); + CXR_WRONG_TYPE_ERROR_NR (sc, "cdar", lst); + return (NULL); +} + +/* -------- cdaar -------- */ + +s7_pointer +cdaar_p_p (s7_scheme* sc, s7_pointer lst) { + if (!s7_is_pair (lst)) return (CXR_METHOD_OR_BUST (sc, "cdaar", lst)); + if (!s7_is_pair (s7_car (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "car", lst); + if (!s7_is_pair (s7_caar (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "caar", lst); + return (s7_cdaar (lst)); +} + +/* -------- caddr -------- */ + +s7_pointer +caddr_p_p (s7_scheme* sc, s7_pointer lst) { + if ((s7_is_pair (lst)) && (s7_is_pair (s7_cdr (lst))) && (s7_is_pair (s7_cddr (lst)))) return (s7_caddr (lst)); + if (!s7_is_pair (lst)) return (CXR_METHOD_OR_BUST (sc, "caddr", lst)); + if (!s7_is_pair (s7_cdr (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "cdr", lst); + CXR_WRONG_TYPE_ERROR_NR (sc, "cddr", lst); + return (NULL); +} + +/* -------- cdddr -------- */ + +s7_pointer +cdddr_p_p (s7_scheme* sc, s7_pointer lst) { + if (!s7_is_pair (lst)) return (CXR_METHOD_OR_BUST (sc, "cdddr", lst)); + if (!s7_is_pair (s7_cdr (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "cdr", lst); + if (!s7_is_pair (s7_cddr (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "cddr", lst); + return (s7_cdddr (lst)); +} + +/* -------- cdadr -------- */ + +s7_pointer +cdadr_p_p (s7_scheme* sc, s7_pointer lst) { + if (!s7_is_pair (lst)) return (CXR_METHOD_OR_BUST (sc, "cdadr", lst)); + if (!s7_is_pair (s7_cdr (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "cdr", lst); + if (!s7_is_pair (s7_cadr (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "cadr", lst); + return (s7_cdadr (lst)); +} + +/* -------- cddar -------- */ + +s7_pointer +cddar_p_p (s7_scheme* sc, s7_pointer lst) { + if (!s7_is_pair (lst)) return (CXR_METHOD_OR_BUST (sc, "cddar", lst)); + if (!s7_is_pair (s7_car (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "car", lst); + if (!s7_is_pair (s7_cdar (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "cdar", lst); + return (s7_cddar (lst)); +} + +/* -------- caaddr -------- */ + +s7_pointer +caaddr_p_p (s7_scheme* sc, s7_pointer lst) { + if (!s7_is_pair (lst)) return (CXR_METHOD_OR_BUST (sc, "caaddr", lst)); + if (!s7_is_pair (s7_cdr (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "cdr", lst); + if (!s7_is_pair (s7_cddr (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "cddr", lst); + if (!s7_is_pair (s7_caddr (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "caddr", lst); + return (s7_caaddr (lst)); +} + +/* -------- cadddr -------- */ + +s7_pointer +cadddr_p_p (s7_scheme* sc, s7_pointer lst) { + if (!s7_is_pair (lst)) return (CXR_METHOD_OR_BUST (sc, "cadddr", lst)); + if (!s7_is_pair (s7_cdr (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "cdr", lst); + if (!s7_is_pair (s7_cddr (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "cddr", lst); + if (!s7_is_pair (s7_cdddr (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "cdddr", lst); + return (s7_cadddr (lst)); +} + +/* -------- cadadr -------- */ + +s7_pointer +cadadr_p_p (s7_scheme* sc, s7_pointer lst) { + if (!s7_is_pair (lst)) return (CXR_METHOD_OR_BUST (sc, "cadadr", lst)); + if (!s7_is_pair (s7_cdr (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "cdr", lst); + if (!s7_is_pair (s7_cadr (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "cadr", lst); + if (!s7_is_pair (s7_cdadr (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "cdadr", lst); + return (s7_cadadr (lst)); +} + +/* -------- caddar -------- */ + +s7_pointer +caddar_p_p (s7_scheme* sc, s7_pointer lst) { + if (!s7_is_pair (lst)) return (CXR_METHOD_OR_BUST (sc, "caddar", lst)); + if (!s7_is_pair (s7_car (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "car", lst); + if (!s7_is_pair (s7_cdar (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "cdar", lst); + if (!s7_is_pair (s7_cddar (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "cddar", lst); + return (s7_caddar (lst)); +} + +/* -------- cddddr -------- */ + +s7_pointer +cddddr_p_p (s7_scheme* sc, s7_pointer lst) { + if (!s7_is_pair (lst)) return (CXR_METHOD_OR_BUST (sc, "cddddr", lst)); + if (!s7_is_pair (s7_cdr (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "cdr", lst); + if (!s7_is_pair (s7_cddr (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "cddr", lst); + if (!s7_is_pair (s7_cdddr (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "cdddr", lst); + return (s7_cddddr (lst)); +} + +/* -------- cddadr -------- */ + +s7_pointer +cddadr_p_p (s7_scheme* sc, s7_pointer lst) { + if (!s7_is_pair (lst)) return (CXR_METHOD_OR_BUST (sc, "cddadr", lst)); + if (!s7_is_pair (s7_cdr (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "cdr", lst); + if (!s7_is_pair (s7_cadr (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "cadr", lst); + if (!s7_is_pair (s7_cdadr (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "cdadr", lst); + return (s7_cddadr (lst)); +} + +/* -------- cdddar -------- */ + +s7_pointer +cdddar_p_p (s7_scheme* sc, s7_pointer lst) { + if (!s7_is_pair (lst)) return (CXR_METHOD_OR_BUST (sc, "cdddar", lst)); + if (!s7_is_pair (s7_car (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "car", lst); + if (!s7_is_pair (s7_cdar (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "cdar", lst); + if (!s7_is_pair (s7_cddar (lst))) CXR_WRONG_TYPE_ERROR_NR (sc, "cddar", lst); + return (s7_cdddar (lst)); +} diff --git a/TeXmacs/plugins/goldfish/src/s7_scheme_cxr.h b/TeXmacs/plugins/goldfish/src/s7_scheme_cxr.h new file mode 100644 index 0000000000..f31f70c0fc --- /dev/null +++ b/TeXmacs/plugins/goldfish/src/s7_scheme_cxr.h @@ -0,0 +1,48 @@ +/* s7_scheme_cxr.h - c[ad]+r optimizer function declarations for s7 Scheme interpreter + * + * derived from s7, a Scheme interpreter + * SPDX-License-Identifier: 0BSD + * + * Bill Schottstaedt, bil@ccrma.stanford.edu + */ + +#ifndef S7_SCHEME_CXR_H +#define S7_SCHEME_CXR_H + +#include "s7.h" + +#ifdef __cplusplus +extern "C" { +#endif + +/* typed-arg (pl_p) versions of the c[ad]+r functions, used by the + s7 optimizer via function pointer comparison, so they must be + extern (single definition in s7_scheme_cxr.c) */ + +s7_pointer caar_p_p(s7_scheme *sc, s7_pointer lst); +s7_pointer cadr_p_p(s7_scheme *sc, s7_pointer lst); +s7_pointer cdar_p_p(s7_scheme *sc, s7_pointer lst); +s7_pointer cddr_p_p(s7_scheme *sc, s7_pointer lst); + +s7_pointer caaar_p_p(s7_scheme *sc, s7_pointer lst); +s7_pointer caadr_p_p(s7_scheme *sc, s7_pointer lst); +s7_pointer cadar_p_p(s7_scheme *sc, s7_pointer lst); +s7_pointer cdaar_p_p(s7_scheme *sc, s7_pointer lst); +s7_pointer caddr_p_p(s7_scheme *sc, s7_pointer lst); +s7_pointer cdddr_p_p(s7_scheme *sc, s7_pointer lst); +s7_pointer cdadr_p_p(s7_scheme *sc, s7_pointer lst); +s7_pointer cddar_p_p(s7_scheme *sc, s7_pointer lst); + +s7_pointer caaddr_p_p(s7_scheme *sc, s7_pointer lst); +s7_pointer cadddr_p_p(s7_scheme *sc, s7_pointer lst); +s7_pointer cadadr_p_p(s7_scheme *sc, s7_pointer lst); +s7_pointer caddar_p_p(s7_scheme *sc, s7_pointer lst); +s7_pointer cddddr_p_p(s7_scheme *sc, s7_pointer lst); +s7_pointer cddadr_p_p(s7_scheme *sc, s7_pointer lst); +s7_pointer cdddar_p_p(s7_scheme *sc, s7_pointer lst); + +#ifdef __cplusplus +} +#endif + +#endif /* S7_SCHEME_CXR_H */ diff --git a/TeXmacs/plugins/goldfish/src/s7_scheme_let.c b/TeXmacs/plugins/goldfish/src/s7_scheme_let.c new file mode 100644 index 0000000000..a16e0f2546 --- /dev/null +++ b/TeXmacs/plugins/goldfish/src/s7_scheme_let.c @@ -0,0 +1,1359 @@ +/* s7_scheme_let.c - let (environment) function implementations for s7 Scheme interpreter + * + * derived from s7, a Scheme interpreter + * SPDX-License-Identifier: 0BSD + */ + +#include "s7_internal.h" +#include "s7_scheme_let.h" +#include "s7_scheme_base.h" + +/* s7.c's make_integer/make_real fast-path macros depend on the static small_ints array; + * the s7_make_* functions contain the same fast path internally. */ +#define make_integer(Sc, N) s7_make_integer(Sc, N) +#define make_real(Sc, X) s7_make_real(Sc, X) + +/* ---------------------------------------- unlet ---------------------------------------- */ +s7_pointer g_unlet(s7_scheme *sc, s7_pointer unused_args) +{ + /* add sc->unlet bindings to the current environment */ + + const s7_pointer result = make_let(sc, sc->curlet); + begin_temp(sc->y, result); + set_is_unlet(result); + if (global_value(sc->else_symbol) != sc->else_symbol) + add_slot_checked_with_id(sc, result, sc->else_symbol, initial_value(sc->else_symbol)); + for (unlet_entry_t *p = sc->unlet_entries; p; p = p->next) + { + s7_pointer sym = p->symbol; + if ((!is_eq_initial_value(sym, 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, result, sym, initial_value(sym)); + } + end_temp(sc->y); + return(result); +} + + +/* ---------------------------------------- openlet? ---------------------------------------- */ +bool s7_is_openlet(s7_pointer let) {return(has_methods(let));} + + +/* ---------------------------------------- openlet ---------------------------------------- */ +s7_pointer s7_openlet(s7_scheme *sc, s7_pointer let) +{ + /* if e is not a let, the openlet bit is still set on it (c-pointer etc) */ + set_has_methods(let); + return(let); +} + + +s7_pointer g_openlet(s7_scheme *sc, s7_pointer args) +{ + + const s7_pointer let = car(args); + s7_pointer new_let, func; + if (!is_let(let)) + { + new_let = find_let(sc, let); + if ((!is_let(new_let)) || (new_let == sc->rootlet)) + find_let_error_nr(sc, sc->openlet_symbol, let, new_let, 1, args); + } + else new_let = let; + if ((new_let == sc->rootlet) || (new_let == sc->starlet)) + error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "can't openlet ~S", 17), let)); + if (is_unlet(new_let)) /* protect against infinite loop: (let () (define + -) (with-let (unlet) (+ (openlet (unlet)) 2))) */ + error_nr(sc, sc->out_of_range_symbol, set_elist_1(sc, wrap_string(sc, "can't openlet unlet", 19))); + if ((has_active_methods(sc, let)) && + ((func = find_method(sc, new_let, sc->openlet_symbol)) != sc->undefined)) + return(s7_apply_function(sc, func, args)); + set_has_methods(let); + return(let); /* openlet and coverlet return their argument */ +} + + +/* ---------------------------------------- coverlet ---------------------------------------- */ +s7_pointer g_coverlet(s7_scheme *sc, s7_pointer args) +{ + + const s7_pointer let = car(args); + s7_pointer new_let, func; + if (!is_let(let)) + { + new_let = find_let(sc, let); + if ((!is_let(new_let)) || (new_let == sc->rootlet)) + find_let_error_nr(sc, sc->coverlet_symbol, let, new_let, 1, args); + } + else new_let = let; + if ((new_let == sc->rootlet) || (new_let == sc->starlet)) + error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "can't coverlet ~S", 17), let)); + if (is_unlet(new_let)) + error_nr(sc, sc->out_of_range_symbol, set_elist_1(sc, wrap_string(sc, "can't coverlet unlet", 20))); + if ((has_active_methods(sc, let)) && + ((func = find_method(sc, new_let, sc->coverlet_symbol)) != sc->undefined)) + return(s7_apply_function(sc, func, args)); + clear_has_methods(let); + return(let); /* mimic openlet in everything */ +} + + +/* ---------------------------------------- varlet ---------------------------------------- */ +static void check_let_fallback(s7_scheme *sc, const s7_pointer symbol, s7_pointer let) +{ + if (symbol == sc->let_ref_fallback_symbol) + set_has_let_ref_fallback(let); + else + if (symbol == sc->let_set_fallback_symbol) + set_has_let_set_fallback(let); +} + + +static void append_let(s7_scheme *sc, s7_pointer new_let, s7_pointer old_let) +{ + if (new_let == sc->rootlet) + for (s7_pointer slot = let_slots(old_let); is_not_slot_end(slot); slot = next_slot(slot)) + { + s7_pointer sym = slot_symbol(slot), val = slot_value(slot); + if (is_slot(global_slot(sym))) + set_global_value(sym, val); + else s7_make_slot(sc, sc->rootlet, sym, val); + } + else + if (old_let == sc->starlet) + { + const s7_pointer iter = s7_make_iterator(sc, sc->starlet); + const s7_int gc_loc = gc_protect_1(sc, iter); + iterator_carrier(iter) = cons_unchecked(sc, sc->F, sc->F); + set_has_carrier(iter); /* so carrier is GC protected by mark_iterator */ + while (true) + { + s7_pointer field = s7_iterate(sc, iter); + if (iterator_is_at_end(iter)) break; + add_slot_checked_with_id(sc, new_let, car(field), cdr(field)); + } + s7_gc_unprotect_at(sc, gc_loc); + } + else + for (s7_pointer slot = let_slots(old_let); is_not_slot_end(slot); slot = next_slot(slot)) + add_slot_checked_with_id(sc, new_let, slot_symbol(slot), slot_value(slot)); /* not add_slot here because it might run off the free heap end */ +} + + +s7_pointer s7_varlet(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) +{ + if (!is_let(let)) + wrong_type_error_nr(sc, sc->varlet_symbol, 1, let, a_let_string); + if (!is_symbol(symbol)) + wrong_type_error_nr(sc, sc->varlet_symbol, 2, symbol, a_symbol_string); + if ((is_slot(global_slot(symbol))) && + (is_syntax(global_value(symbol)))) + wrong_type_error_nr(sc, sc->varlet_symbol, 2, symbol, wrap_string(sc, "a non-syntactic symbol", 22)); + + if (let == sc->rootlet) + { + if (is_slot(global_slot(symbol))) + set_global_value(symbol, value); + else s7_make_slot(sc, sc->rootlet, symbol, value); + } + else + { + add_slot_checked_with_id(sc, let, symbol, value); + check_let_fallback(sc, symbol, let); + } + return(value); +} + + +s7_pointer g_varlet(s7_scheme *sc, s7_pointer args) /* varlet = with-let + define */ +{ + s7_pointer let = car(args); + if (!is_let(let)) + { + s7_pointer new_let = find_let(sc, let); + if ((!is_let(new_let)) || (new_let == sc->rootlet)) + find_let_error_nr(sc, sc->varlet_symbol, let, new_let, 1, args); + let = new_let; + } + if ((is_immutable_let(let)) || (let == sc->starlet)) + immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "can't (varlet ~{~S~^ ~}), ~S is immutable", 41), args, let)); + + for (s7_pointer arglist = cdr(args); is_pair(arglist); arglist = cdr(arglist)) + { + s7_pointer sym, val; + const s7_pointer arg = car(arglist); + if (is_symbol(arg)) + { + sym = (is_keyword(arg)) ? keyword_symbol(arg) : arg; + if (!is_pair(cdr(arglist))) + error_nr(sc, sc->syntax_error_symbol, set_elist_3(sc, wrap_string(sc, "varlet: symbol ~S, but no value: ~S", 35), arg, args)); + if (is_constant_symbol(sc, sym)) + wrong_type_error_nr(sc, sc->varlet_symbol, position_of(arglist, args), sym, a_non_constant_symbol_string); + arglist = cdr(arglist); + val = car(arglist); + } + else + if (is_let(arg)) + { + if ((arg != sc->rootlet) && (let != sc->starlet)) /* (varlet (inlet 'a 1) (rootlet)) is trouble */ + { + append_let(sc, let, arg); + if (has_let_set_fallback(arg)) set_has_let_set_fallback(let); + if (has_let_ref_fallback(arg)) set_has_let_ref_fallback(let); + } + continue; + } + else + if (is_pair(arg)) + { + sym = car(arg); + if (!is_symbol(sym)) + wrong_type_error_nr(sc, sc->varlet_symbol, position_of(arglist, args), arg, a_symbol_string); + if (is_constant_symbol(sc, sym)) + wrong_type_error_nr(sc, sc->varlet_symbol, position_of(arglist, args), sym, a_non_constant_symbol_string); + val = cdr(arg); + } + else wrong_type_error_nr(sc, sc->varlet_symbol, position_of(arglist, args), arg, wrap_string(sc, "a symbol, let, or cons", 22)); + + if (let == sc->rootlet) + { + s7_pointer gslot = global_slot(sym); + if (is_slot(gslot)) + { + if (is_immutable(gslot)) /* (immutable! 'abs) (varlet (rootlet) 'abs 1) */ + immutable_object_error_nr(sc, set_elist_5(sc, wrap_string(sc, "~S is immutable in (varlet ~S '~S ~S)", 37), sym, car(args), arg, val)); + slot_set_value_with_hook(global_slot(sym), val); + } + else s7_make_slot(sc, sc->rootlet, sym, val); + } + else + { + check_let_fallback(sc, sym, let); + add_slot_checked_with_id(sc, let, 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(let); +} + + +/* ---------------------------------------- cutlet ---------------------------------------- */ +s7_pointer g_cutlet(s7_scheme *sc, s7_pointer args) +{ + + s7_pointer let = car(args); + s7_int the_un_id; + if (let != sc->rootlet) + { + if_method_exists_return_value(sc, let, sc->cutlet_symbol, args); + if (!is_let(let)) + { + s7_pointer new_let = find_let(sc, let); + if ((!is_let(new_let)) || (new_let == sc->rootlet)) + find_let_error_nr(sc, sc->cutlet_symbol, let, new_let, 1, args); + let = new_let; + }} + if ((is_immutable_let(let)) || (let == sc->starlet)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->cutlet_symbol, let)); + + /* 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! So use the next (unused) id. + * (let ((b 1)) (let ((b 2)) (cutlet (curlet) 'b)) b) + */ + the_un_id = ++sc->let_number; + + for (s7_pointer syms = cdr(args); is_pair(syms); syms = cdr(syms)) + { + s7_pointer sym = car(syms); + if (!is_symbol(sym)) + wrong_type_error_nr(sc, sc->cutlet_symbol, position_of(syms, args), sym, a_symbol_string); + if (is_keyword(sym)) + sym = keyword_symbol(sym); + + if (let == sc->rootlet) + { + if (!is_slot(global_slot(sym))) + error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "cutlet can't remove ~S", 22), sym)); + if (is_immutable(global_slot(sym))) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->cutlet_symbol, sym)); + symbol_set_id(sym, the_un_id); + set_global_value(sym, sc->undefined); + /* here we need to at least clear bits: syntactic binder clean-symbol(?) etc, maybe also locally */ + } + else + { + s7_pointer slot; + if ((has_let_fallback(let)) && + ((sym == sc->let_ref_fallback_symbol) || (sym == sc->let_set_fallback_symbol))) + error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "cutlet can't remove ~S", 22), sym)); + slot = let_slots(let); + if (is_not_slot_end(slot)) + { + if (slot_symbol(slot) == sym) + { + if (is_immutable_slot(slot)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->cutlet_symbol, sym)); + let_set_slots(let, next_slot(let_slots(let))); + symbol_set_id(sym, the_un_id); + } + else + { + s7_pointer last_slot = slot; + for (slot = next_slot(let_slots(let)); is_not_slot_end(slot); last_slot = slot, slot = next_slot(slot)) + if (slot_symbol(slot) == sym) + { + if (is_immutable_slot(slot)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->cutlet_symbol, sym)); + symbol_set_id(sym, the_un_id); + slot_set_next(last_slot, next_slot(slot)); + break; + }}}}} + return(let); +} + + +/* ---------------------------------------- sublet ---------------------------------------- */ +static s7_pointer sublet_1(s7_scheme *sc, s7_pointer let, s7_pointer bindings, s7_pointer caller) +{ + const s7_pointer new_let = make_let(sc, let); + set_all_methods(new_let, let); + + if (!is_null(bindings)) + { + sc->temp3 = new_let; + for (s7_pointer slot = NULL, entries = bindings; is_pair(entries); entries = cdr(entries)) + { + s7_pointer entry = car(entries), sym, val; + + switch (type(entry)) + { + case T_SYMBOL: + sym = (is_keyword(entry)) ? keyword_symbol(entry) : entry; + if (!is_pair(cdr(entries))) + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "~A: entry ~S, but no value: ~S", 30), caller, entry, bindings)); + entries = cdr(entries); + val = car(entries); + break; + + case T_PAIR: /* (cons sym val) */ + sym = car(entry); + if (!is_symbol(sym)) + wrong_type_error_nr(sc, caller, 1 + position_of(entries, bindings), entry, a_symbol_string); + if (is_keyword(sym)) + sym = keyword_symbol(sym); + val = cdr(entry); + break; + + case T_LET: + if ((entry == sc->rootlet) || (new_let == sc->starlet)) continue; + append_let(sc, new_let, entry); + if (is_pair(cdr(entries))) /* only need tail if more entries follow */ + { + if (is_not_slot_end(let_slots(new_let))) /* make sure the end slot (slot) is correct */ + for (slot = let_slots(new_let); is_not_slot_end(next_slot(slot)); slot = next_slot(slot)); /* slot can't be local -- see below */ + } + continue; + + default: + wrong_type_error_nr(sc, caller, 1 + position_of(entries, bindings), entry, a_symbol_string); + } + if (is_constant_symbol(sc, sym)) + wrong_type_error_nr(sc, caller, 1 + position_of(entries, bindings), sym, a_non_constant_symbol_string); +#if 0 + if ((is_slot(global_slot(sym))) && + (is_syntax_or_qq(global_value(sym)))) + wrong_type_error_nr(sc, caller, 2, sym, wrap_string(sc, "a non-syntactic symbol", 22)); + /* this is a local redefinition which we accept elsewhere: (let ((if 3)) if) -> 3 */ + /* so s7_inlet (which calls sublet) differs from g_inlet? which is correct? */ + /* (define (f1) (with-let (sublet (curlet)) (inlet 'quasiquote 1))) (f1) */ + +#endif + /* here we know new_let is a let and is not rootlet */ + if (!slot) + slot = add_slot_checked_with_id(sc, new_let, sym, val); + else + { + /* if (sc->free_heap_top <= sc->free_heap_trigger) try_to_call_gc(sc);*/ /* or maybe add add_slot_at_end_checked? */ + slot = add_slot_checked_at_end(sc, let_id(new_let), slot, sym, val); + set_local(sym); /* ? */ + } + check_let_fallback(sc, sym, new_let); + } + if ((S7_DEBUGGING) && (sc->temp3 != new_let)) fprintf(stderr, "%s[%d]: temp3: %s\n", __func__, __LINE__, display(sc->temp3)); + sc->temp3 = sc->unused; + } + return(new_let); +} + + +s7_pointer s7_sublet(s7_scheme *sc, s7_pointer let, s7_pointer bindings) {return(sublet_1(sc, let, bindings, sc->sublet_symbol));} + + +s7_pointer g_sublet(s7_scheme *sc, s7_pointer args) +{ + + s7_pointer let = car(args); + if (!is_let(let)) + { + s7_pointer new_let = find_let(sc, let); + if ((!is_let(new_let)) || (new_let == sc->rootlet)) + find_let_error_nr(sc, sc->sublet_symbol, let, new_let, 1, args); + let = new_let; + } + return(sublet_1(sc, let, cdr(args), sc->sublet_symbol)); +} + + +s7_pointer g_sublet_curlet(s7_scheme *sc, s7_pointer args) +{ + s7_pointer sym = cadr(args), new_let; + if_let_method_exists_return_value(sc, sc->curlet, sc->sublet_symbol, args); /* curlet is a let so... */ + new_let = inline_make_let_with_slot(sc, sc->curlet, sym, caddr(args)); + set_all_methods(new_let, sc->curlet); + check_let_fallback(sc, sym, new_let); + return(new_let); +} + + +s7_pointer sublet_chooser(s7_scheme *sc, s7_pointer func, int32_t num_args, s7_pointer expr) +{ + if (num_args == 3) + { + s7_pointer args = cdr(expr); + if ((is_pair(car(args))) && (caar(args) == sc->curlet_symbol) && (is_null(cdar(args))) && + (is_quoted_symbol(sc, cadr(args)))) + return(sc->sublet_curlet); + } + return(func); +} + + +/* ---------------------------------------- inlet ---------------------------------------- */ +s7_pointer s7_inlet(s7_scheme *sc, s7_pointer args) +{ + if (args == sc->nil) + return(make_let(sc, sc->rootlet)); + return(sublet_1(sc, sc->rootlet, args, sc->inlet_symbol)); +} + + +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, no syntax, etc */ + const s7_pointer new_let = make_let(sc, sc->rootlet); + const s7_int id = let_id(new_let); + + begin_temp(sc->temp6, new_let); + for (s7_pointer x = args, last_slot = NULL; 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) */ + { + end_temp(sc->temp6); + wrong_type_error_nr(sc, sc->inlet_symbol, 1, symbol, a_non_constant_symbol_string); + } + if (!last_slot) + { + add_slot_unchecked(sc, new_let, symbol, cadr(x), id); + last_slot = let_slots(new_let); + } + else last_slot = add_slot_checked_at_end(sc, id, last_slot, symbol, cadr(x)); + } + end_temp(sc->temp6); + return(new_let); +} + + +s7_pointer inlet_p_pp(s7_scheme *sc, s7_pointer symbol, s7_pointer value) +{ + if (!is_symbol(symbol)) + return(sublet_1(sc, sc->rootlet, set_plist_2(sc, symbol, value), sc->inlet_symbol)); + if (is_keyword(symbol)) + symbol = keyword_symbol(symbol); + if (is_constant_symbol(sc, symbol)) + wrong_type_error_nr(sc, sc->inlet_symbol, 1, symbol, a_non_constant_symbol_string); + if ((is_defined_global(symbol)) && + (is_syntax_or_qq(global_value(symbol)))) + wrong_type_error_nr(sc, sc->inlet_symbol, 1, symbol, wrap_string(sc, "a non-syntactic symbol", 22)); + { + s7_pointer new_let; + new_cell(sc, new_let, T_LET | T_SAFE_PROCEDURE); + begin_temp(sc->x, new_let); + let_set_id(new_let, ++sc->let_number); + let_set_outlet(new_let, sc->rootlet); + let_set_slots(new_let, slot_end); + add_slot_unchecked(sc, new_let, symbol, value, let_id(new_let)); + end_temp(sc->x); + return(new_let); + } +} + + +s7_pointer internal_inlet(s7_scheme *sc, s7_int num_args, ...) /* used in *->let */ +{ + va_list ap; + const s7_pointer new_let = make_let(sc, sc->rootlet); + const s7_int id = let_id(new_let); + s7_pointer last_slot = NULL; + + begin_temp(sc->x, new_let); + va_start(ap, num_args); + for (s7_int i = 0; i < num_args; i += 2) + { + s7_pointer symbol = T_Sym(va_arg(ap, s7_pointer)); + s7_pointer value = T_Ext(va_arg(ap, s7_pointer)); + if (!last_slot) + { + add_slot_unchecked(sc, new_let, symbol, value, id); + last_slot = let_slots(new_let); + } + else last_slot = add_slot_at_end(sc, id, last_slot, symbol, value); + } + va_end(ap); + end_temp(sc->x); + return(new_let); +} + + +s7_pointer inlet_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + if ((args > 0) && ((args % 2) == 0)) + { + for (s7_pointer p = cdr(expr); is_pair(p); p = cddr(p)) + { + s7_pointer sym; + if (is_symbol_and_keyword(car(p))) /* (inlet :if ...) */ + sym = keyword_symbol(car(p)); + else + { + if (!is_proper_quote(sc, car(p))) return(func); /* (inlet abs ...) */ + sym = cadar(p); /* looking for (inlet 'a ...) */ + if (!is_symbol(sym)) return(func); /* (inlet '(a . 3) ...) */ + if (is_keyword(sym)) sym = keyword_symbol(sym); /* (inlet ':abs ...) */ + } + if ((is_possibly_constant(sym)) || /* (inlet 'define-constant ...) or (inlet 'pi ...) */ + (is_syntactic_symbol(sym)) || /* (inlet 'if 3) */ + ((is_slot(global_slot(sym))) && + (is_syntax_or_qq(global_value(sym)))) || /* (inlet 'quasiquote 1) */ + (sym == sc->let_ref_fallback_symbol) || + (sym == sc->let_set_fallback_symbol)) + return(func); + } + return(sc->simple_inlet); + } + return(func); +} + + +/* ---------------------------------------- let->list ---------------------------------------- */ +static s7_pointer abbreviate_let(s7_scheme *sc, s7_pointer val) +{ + if (is_let(val)) + return(make_symbol(sc, "", 11)); + return(val); +} + + +s7_pointer s7_let_to_list(s7_scheme *sc, s7_pointer let) +{ + if (let == sc->rootlet) + { + begin_temp(sc->temp6, sc->nil); + for (s7_pointer lib = global_value(sc->libraries_symbol); is_pair(lib); lib = cdr(lib)) + sc->temp6 = cons(sc, caar(lib), sc->temp6); + sc->temp6 = cons(sc, cons(sc, sc->libraries_symbol, sc->temp6), sc->nil); + for (s7_pointer slot = sc->rootlet_slots; is_not_slot_end(slot); slot = next_slot(slot)) + if (slot_symbol(slot) != sc->libraries_symbol) + sc->temp6 = cons_unchecked(sc, cons(sc, slot_symbol(slot), abbreviate_let(sc, slot_value(slot))), sc->temp6); + { + s7_pointer result = proper_list_reverse_in_place(sc, sc->temp6); + end_temp(sc->temp6); + return(result); + }} + else + { + s7_pointer iter, func; + s7_int gc_loc = -1; + /* need to check make-iterator method before dropping into let->list */ + sc->temp3 = sc->w; + sc->w = sc->nil; + + if ((has_active_methods(sc, let)) && + ((func = find_method(sc, let, sc->make_iterator_symbol)) != sc->undefined)) + iter = s7_apply_function(sc, func, set_plist_1(sc, let)); + else + if (let == sc->starlet) /* (let->list *s7*) via starlet_make_iterator */ + { + iter = s7_make_iterator(sc, let); + gc_loc = gc_protect_1(sc, iter); + } + else iter = sc->nil; + + if (is_null(iter)) + for (s7_pointer slot = let_slots(let); is_not_slot_end(slot); slot = next_slot(slot)) + sc->w = cons_unchecked(sc, cons(sc, slot_symbol(slot), slot_value(slot)), sc->w); + else + /* (begin (load "mockery.scm") (let ((lt ((*mock-pair* 'mock-pair) 1 2 3))) (format *stderr* "~{~A ~}" lt))) */ + while (true) + { + s7_pointer val = s7_iterate(sc, iter); + if (iterator_is_at_end(iter)) break; + sc->w = cons(sc, val, sc->w); + } + sc->w = proper_list_reverse_in_place(sc, sc->w); + if (gc_loc != -1) + s7_gc_unprotect_at(sc, gc_loc); + { + s7_pointer result = sc->w; + sc->w = sc->temp3; + sc->temp3 = sc->unused; + return(result); + }} +} + + +#if !WITH_PURE_S7 +s7_pointer g_let_to_list(s7_scheme *sc, s7_pointer args) +{ + + s7_pointer let = car(args); + if_method_exists_return_value(sc, let, sc->let_to_list_symbol, args); + if (!is_let(let)) + { + s7_pointer new_let = find_let(sc, let); + if ((!is_let(new_let)) || (new_let == sc->rootlet)) + find_let_error_nr(sc, sc->let_to_list_symbol, let, new_let, 1, args); + /* this is not (let->list (rootlet)) but (say) (let->list func) which defaults in find_let to rootlet */ + let = new_let; + } + return(s7_let_to_list(sc, let)); +} +/* *s7* in gdb: p display(s7_let_to_list(sc, sc->starlet)) */ +#endif + + +/* ---------------------------------------- let-ref ---------------------------------------- */ +s7_pointer call_let_ref_fallback(s7_scheme *sc, s7_pointer let, s7_pointer symbol) +{ + s7_pointer result; + const s7_pointer val = find_method(sc, let, sc->let_ref_fallback_symbol); + /* (let ((x #f)) (let begin ((x 1234)) (begin 1) 2)) -> stack overflow eventually, but should we try to catch it? */ + if (!is_applicable(val)) return(val); + push_stack_no_let(sc, OP_GC_PROTECT, sc->value, sc->code); + result = s7_apply_function(sc, val, set_qlist_2(sc, let, symbol)); + unstack_gc_protect(sc); + sc->code = T_Pos(stack_end_code(sc)); /* can be # */ + sc->value = T_Ext(stack_end_args(sc)); + return(result); +} + + +s7_pointer call_let_set_fallback(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) +{ + s7_pointer result; + push_stack_no_let(sc, OP_GC_PROTECT, sc->value, sc->code); + result = s7_apply_function(sc, find_method(sc, let, sc->let_set_fallback_symbol), set_qlist_3(sc, let, symbol, value)); + unstack_gc_protect(sc); + sc->code = T_Pos(stack_end_code(sc)); + sc->value = T_Ext(stack_end_args(sc)); + return(result); +} + + +s7_pointer let_ref(s7_scheme *sc, s7_pointer let, s7_pointer symbol) +{ + /* (let ((a 1)) ((curlet) 'a)) or ((rootlet) 'abs) */ + if (!is_let(let)) + { + s7_pointer new_let; + if (let == sc->unlet_disabled) return(initial_value(symbol)); + new_let = find_let(sc, let); + if ((!is_let(new_let)) || (new_let == sc->rootlet)) + find_let_error_nr(sc, sc->let_ref_symbol, let, new_let, 1, set_mlist_2(sc, let, symbol)); + let = new_let; + } + if (!is_symbol(symbol)) + { + if ((let != sc->rootlet) && (has_let_ref_fallback(let))) /* let-ref|set-fallback refer to (explicit) let-ref in various forms, not the method lookup process */ + return(call_let_ref_fallback(sc, let, symbol)); + wrong_type_error_nr(sc, sc->let_ref_symbol, 2, symbol, a_symbol_string); + } + /* 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. + * What about other let-as-first-arg funcs? + */ + + if (let_id(let) == symbol_id(symbol)) + return(local_value(symbol)); /* this has to follow the rootlet check(?) */ + + if (is_keyword(symbol)) + symbol = keyword_symbol(symbol); + if (let == sc->rootlet) + return((is_slot(global_slot(symbol))) ? global_value(symbol) : sc->undefined); + + for (s7_pointer e = let; e; e = let_outlet(e)) + for (s7_pointer slot = let_slots(e); is_not_slot_end(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == symbol) + return(slot_value(slot)); + + if (is_openlet(let)) + { + /* 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)); + } + return((is_slot(global_slot(symbol))) ? global_value(symbol) : sc->undefined); /* (let () ((curlet) 'pi)) */ +} + + +s7_pointer s7_let_ref(s7_scheme *sc, s7_pointer let, s7_pointer symbol) {return(let_ref(sc, let, symbol));} + + +s7_pointer g_let_ref(s7_scheme *sc, s7_pointer args) +{ + if (!is_pair(cdr(args))) + error_nr(sc, sc->syntax_error_symbol, + set_elist_2(sc, wrap_string(sc, "let-ref: symbol missing: ~S", 27), set_ulist_1(sc, sc->let_ref_symbol, args))); + return(let_ref(sc, car(args), cadr(args))); +} + + +s7_pointer slot_in_let(s7_scheme *sc, s7_pointer let, const s7_pointer sym) +{ + for (s7_pointer slot = let_slots(let); is_not_slot_end(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == sym) + return(slot); + return(sc->undefined); +} + + +s7_pointer let_ref_p_pp(s7_scheme *sc, s7_pointer let, s7_pointer sym) +{ + if (let_id(let) == symbol_id(sym)) + return(local_value(sym)); /* see add in tlet! */ + if (let == sc->rootlet) /* op_implicit_let_ref_c can pass rootlet */ + return((is_slot(global_slot(sym))) ? global_value(sym) : sc->undefined); + for (s7_pointer e = let; e; e = let_outlet(e)) + for (s7_pointer slot = let_slots(e); is_not_slot_end(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == sym) + return(slot_value(slot)); + if (has_let_ref_fallback(let)) + return(call_let_ref_fallback(sc, let, sym)); + return((is_slot(global_slot(sym))) ? global_value(sym) : sc->undefined); +} + + +s7_pointer g_cdr_let_ref(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer let = car(args), sym = cadr(args); + if (!is_let(let)) + wrong_type_error_nr(sc, sc->let_ref_symbol, 1, let, a_let_string); + if (let_id(let) == symbol_id(sym)) + return(local_value(sym)); + if (let == sc->rootlet) + return((is_slot(global_slot(sym))) ? global_value(sym) : sc->undefined); + for (s7_pointer slot = let_slots(let); is_not_slot_end(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == sym) + return(slot_value(slot)); + return(let_ref_p_pp(sc, let_outlet(let), sym)); +} + + +s7_pointer g_starlet_ref(s7_scheme *sc, s7_pointer args) {return(starlet(sc, starlet_symbol_id(cadr(args))));} + + +s7_pointer g_rootlet_ref(s7_scheme *sc, s7_pointer args) +{ + s7_pointer sym = cadr(args); + return((is_slot(global_slot(sym))) ? global_value(sym) : sc->undefined); +} + + +s7_pointer let_ref_chooser(s7_scheme *sc, s7_pointer func, int32_t unused_args, s7_pointer expr) +{ + const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); + if ((is_quoted_symbol(sc, arg2)) && (!is_keyword(cadr(arg2)))) + { + if (is_pair(arg1)) + { + if ((optimize_op(expr) == HOP_SAFE_C_opSq_C) && (car(arg1) == sc->cdr_symbol)) + { + set_opt3_sym(cdr(expr), cadr(arg2)); + return(sc->cdr_let_ref); + } + if (car(arg1) == sc->rootlet_symbol) return(sc->rootlet_ref); + if (car(arg1) == sc->curlet_symbol) return(sc->curlet_ref); + if (car(arg1) == sc->unlet_symbol) + { + set_fn_direct(arg1, g_unlet_disabled); + return(sc->unlet_ref); + }} + if (arg1 == sc->starlet_symbol) return(sc->starlet_ref); /* should *curlet* be added? */ + } + return(func); +} + + +/* ---------------------------------------- let-set! ---------------------------------------- */ +s7_pointer let_set_1(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) +{ + if (is_keyword(symbol)) + symbol = keyword_symbol(symbol); + + if (let == sc->rootlet) + { + s7_pointer slot; + if (is_constant_symbol(sc, symbol)) /* (let-set! (rootlet) 'pi #f) */ + wrong_type_error_nr(sc, sc->let_set_symbol, 2, symbol, a_non_constant_symbol_string); + /* it would be nice if safety>0 to add an error check for bad arity if a built-in method is set (set! (lt 'write) hash-table-set!), + * built_in being (initial_value_is_defined(sc, sym)), but this function is called a ton, and this error can't easily be + * checked by the optimizer (we see the names, but not the values, so bad arity check requires assumptions about those values). + */ + slot = global_slot(symbol); + if (!is_slot(slot)) + error_nr(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(slot))) + wrong_type_error_nr(sc, sc->let_set_symbol, 2, symbol, wrap_string(sc, "a non-syntactic symbol", 22)); + if (is_immutable(slot)) + immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "~S is immutable in (rootlet)", 28), symbol)); /* also (set! (with-let...)...) */ + symbol_increment_ctr(symbol); + slot_set_value(slot, (slot_has_setter(slot)) ? call_setter(sc, slot, value) : value); + return(slot_value(slot)); + } + if (is_unlet(let)) + immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "~S is immutable in (unlet)", 26), symbol)); + if (let_id(let) == symbol_id(symbol)) + { + s7_pointer slot = local_slot(symbol); + if (is_slot(slot)) + { + symbol_increment_ctr(symbol); + return(checked_slot_set_value(sc, slot, value)); + }} + for (s7_pointer e = let; e; e = let_outlet(e)) + for (s7_pointer slot = let_slots(e); is_not_slot_end(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == symbol) + { + symbol_increment_ctr(symbol); + return(checked_slot_set_value(sc, slot, value)); + } + if (!has_let_set_fallback(let)) + error_nr(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? */ + return(call_let_set_fallback(sc, let, symbol, value)); +} + + +s7_pointer let_set_2(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) +{ + if (!is_let(let)) + { + s7_pointer new_let = find_let(sc, let); + if (!is_let(new_let)) + find_let_error_nr(sc, sc->let_set_symbol, let, new_let, 1, set_plist_3(sc, let, symbol, value)); + let = new_let; + } + if (!is_symbol(symbol)) + { + if ((let != sc->rootlet) && (has_let_set_fallback(let))) + return(call_let_set_fallback(sc, let, symbol, value)); + wrong_type_error_nr(sc, sc->let_set_symbol, 2, symbol, a_symbol_string); + } + /* currently let-set! is immutable, so we don't have to check for a let-set! method (so let_set! is always global) */ + return(let_set_1(sc, let, symbol, value)); +} + + +s7_pointer s7_let_set(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) {return(let_set_2(sc, let, symbol, value));} + + +s7_pointer g_let_set(s7_scheme *sc, s7_pointer args) +{ + /* (let ((a 1)) (set! ((curlet) 'a) 32) a) */ + + if (!is_pair(cdr(args))) /* (let ((a 123.0)) (define (f) (set! (let-ref) a)) (catch #t f (lambda args #f)) (f)) */ + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, wrap_string(sc, "~S: not enough arguments: ~S", 28), sc->let_set_symbol, sc->code)); + + return(let_set_2(sc, car(args), cadr(args), caddr(args))); +} + + +s7_pointer let_set_p_ppp_2(s7_scheme *sc, s7_pointer let, s7_pointer sym, s7_pointer val) +{ + if (!is_symbol(sym)) + wrong_type_error_nr(sc, sc->let_set_symbol, 2, sym, a_symbol_string); + return(let_set_1(sc, let, sym, val)); +} + + +s7_pointer g_cdr_let_set(s7_scheme *sc, s7_pointer args) +{ + s7_pointer let = car(args); + const s7_pointer sym = cadr(args), val = caddr(args); + if (!is_let(let)) + { + s7_pointer new_let = find_let(sc, let); + if (!is_let(new_let)) + find_let_error_nr(sc, sc->let_set_symbol, let, new_let, 1, args); + let = new_let; + } + if (let != sc->rootlet) + { + for (s7_pointer e = let; e; e = let_outlet(e)) + for (s7_pointer slot = let_slots(e); is_not_slot_end(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == sym) + { + slot_set_value(slot, (slot_has_setter(slot)) ? call_setter(sc, slot, val) : val); + return(slot_value(slot)); + } + if ((let != sc->rootlet) && (has_let_set_fallback(let))) + return(call_let_set_fallback(sc, let, sym, val)); + } + { + s7_pointer slot = global_slot(sym); + if (!is_slot(slot)) + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, wrap_string(sc, "let-set!: ~A is not defined in ~A", 33), sym, let)); + slot_set_value(slot, (slot_has_setter(slot)) ? call_setter(sc, slot, val) : val); + return(slot_value(slot)); + } +} + + +s7_pointer g_starlet_set(s7_scheme *sc, s7_pointer args) +{ + s7_pointer sym = cadr(args); + if (!is_symbol(sym)) /* (let () (define (func) (let-set! *s7* '(1 . 2) (hash-table))) (func) (func)) */ + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "(let-set! *s7* ~A ...) second argument is ~A but should be a symbol", 67), + sym, object_type_name(sc, sym))); + if (is_keyword(sym)) + sym = keyword_symbol(sym); + if (starlet_symbol_id(sym) == sl_no_field) + error_nr(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(starlet_set_1(sc, sym, caddr(args))); +} + + +s7_pointer g_unlet_set(s7_scheme *sc, s7_pointer args) +{ + immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "~S is immutable in (unlet)", 26), cadr(args))); + return(sc->F); +} + + +s7_pointer let_set_chooser(s7_scheme *sc, s7_pointer func, int32_t unused_args, s7_pointer expr) +{ + const s7_pointer arg1 = cadr(expr); + if (optimize_op(expr) == HOP_SAFE_C_opSq_CS) + { + const s7_pointer arg2 = caddr(expr), arg3 = cadddr(expr); + if ((car(arg1) == sc->cdr_symbol) && + (is_quoted_symbol(sc, arg2)) && + (!is_possibly_constant(cadr(arg2))) && /* assumes T_Sym */ + (!is_possibly_constant(arg3))) + return(sc->cdr_let_set); + if (car(arg1) == sc->unlet_symbol) + { + set_fn_direct(arg1, g_unlet_disabled); + return(sc->unlet_set); + }} + if (arg1 == sc->starlet_symbol) return(sc->starlet_set); + return(func); +} + + +/* ---------------------------------------- let copy helpers ---------------------------------------- */ +s7_pointer reverse_slots(s7_pointer let_slots) +{ + s7_pointer slot = let_slots, result = slot_end; + while (is_not_slot_end(slot)) + { + s7_pointer nextslot = next_slot(slot); + slot_set_next(slot, result); + result = slot; + slot = nextslot; + } + return(result); +} + + +s7_pointer let_copy(s7_scheme *sc, s7_pointer let) +{ + s7_pointer new_let; + if (T_Let(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_let = make_let(sc, let_outlet(let)); + set_all_methods(new_let, let); + begin_temp(sc->x, new_let); + if (is_not_slot_end(let_slots(let))) + { + const s7_int id = let_id(new_let); + for (s7_pointer last_slot = NULL, slot = let_slots(let); is_not_slot_end(slot); slot = next_slot(slot)) + { + s7_pointer new_slot; + new_cell(sc, new_slot, T_SLOT); + slot_set_symbol_and_value(new_slot, slot_symbol(slot), slot_value(slot)); + if (symbol_id(slot_symbol(new_slot)) != id) /* keep shadowing intact */ + symbol_set_local_slot(slot_symbol(slot), id, new_slot); + if (slot_has_setter(slot)) + { + slot_set_setter(new_slot, slot_setter(slot)); + slot_set_has_setter(new_slot); + } + if (last_slot) + slot_set_next(last_slot, new_slot); + else let_set_slots(new_let, new_slot); + slot_set_next(new_slot, slot_end); /* in case GC runs during this loop */ + last_slot = new_slot; + }} + /* 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))))) + */ + end_temp(sc->x); + return(new_let); +} + + +s7_pointer s7_rootlet(s7_scheme *sc) {return(sc->rootlet);} + + +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 */ +} + + +s7_pointer s7_curlet(s7_scheme *sc) /* see also fx_curlet */ +{ + sc->capture_let_counter++; + return(sc->curlet); +} + + +void update_symbol_ids(s7_scheme *sc, s7_pointer let) +{ + for (s7_pointer slot = let_slots(let); is_not_slot_end(slot); slot = next_slot(slot)) + { + s7_pointer sym = slot_symbol(slot); + if (symbol_id(sym) != sc->let_number) + symbol_set_local_slot_unincremented(sym, sc->let_number, slot); + } +} + + +s7_pointer s7_set_curlet(s7_scheme *sc, s7_pointer let) +{ + const s7_pointer old_let = sc->curlet; + if (is_let(let)) + { + set_curlet(sc, let); + if (let_id(let) > 0) + { + let_set_id(let, ++sc->let_number); + update_symbol_ids(sc, let); + }} + return(old_let); +} + + +s7_pointer s7_outlet(s7_scheme *sc, s7_pointer let) {return(let_outlet(let));} + + +s7_pointer outlet_p_p(s7_scheme *sc, s7_pointer let) +{ + if (!is_let(let)) + { + s7_pointer new_let = find_let(sc, let); + if (!is_let(new_let)) + find_let_error_nr(sc, sc->outlet_symbol, let, new_let, 1, set_mlist_1(sc, let)); + let = new_let; + } + return((let == sc->rootlet) ? sc->rootlet : let_outlet(let)); /* rootlet check is needed(!) */ +} + + +s7_pointer s7i_outlet_p_p(s7_scheme *sc, s7_pointer let) {return(outlet_p_p(sc, let));} + + +s7_pointer outlet_chooser(s7_scheme *sc, s7_pointer func, int32_t num_args, s7_pointer expr) +{ + if ((num_args == 1) && (is_pair(cadr(expr))) && (caadr(expr) == sc->unlet_symbol)) + { + set_fn_direct(cadr(expr), g_unlet_disabled); + return(sc->outlet_unlet); + } + return(func); +} + + +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)) + { + s7_pointer new_let = find_let(sc, let); + if (!is_let(new_let)) + find_let_error_nr(sc, wrap_string(sc, "set! outlet", 11), let, new_let, 1, args); + let = new_let; + } + if (let == sc->starlet) + error_nr(sc, sc->out_of_range_symbol, set_elist_1(sc, wrap_string(sc, "can't set! (outlet *s7*)", 24))); + if (is_immutable_let(let)) + immutable_object_error_nr(sc, set_elist_4(sc, wrap_string(sc, "can't (set! (outlet ~S) ~S), ~S is immutable", 44), let, cadr(args), let)); + new_outer = cadr(args); + if (!is_let(new_outer)) + { + s7_pointer new_let = find_let(sc, new_outer); + if (!is_let(new_let)) + find_let_error_nr(sc, wrap_string(sc, "set! outlet", 11), new_outer, new_let, 2, args); + new_outer = new_let; + } + if (let != sc->rootlet) + { + /* here it's possible to get cyclic let chains; maybe do this check only if safety>0 */ + for (s7_pointer new_let = new_outer; new_let; new_let = let_outlet(new_let)) + if (let == new_let) + error_nr(sc, make_symbol(sc, "cyclic-let", 10), + set_elist_2(sc, wrap_string(sc, "set! (outlet ~A) creates a cyclic let chain", 43), let)); + let_set_outlet(let, new_outer); + } + return(new_outer); +} + + +/* ---------------------------------------- symbol->value ---------------------------------------- */ +s7_pointer g_symbol_to_value(s7_scheme *sc, s7_pointer args) +{ + + const s7_pointer sym = car(args); + if (!is_symbol(sym)) + return(method_or_bust(sc, sym, sc->symbol_to_value_symbol, args, sc->type_names[T_SYMBOL], 1)); + if (is_keyword(sym)) + { + if ((is_pair(cdr(args))) && (!is_let(cadr(args))) && (!is_let(find_let(sc, cadr(args))))) + wrong_type_error_nr(sc, sc->symbol_to_value_symbol, 2, cadr(args), sc->type_names[T_LET]); + return(sym); + } + if (is_pair(cdr(args))) + { + s7_pointer local_let = cadr(args); + if (!is_let(local_let)) + { + local_let = find_let(sc, local_let); + if (!is_let(local_let)) + return(method_or_bust(sc, cadr(args), sc->symbol_to_value_symbol, args, a_let_string, 2)); /* not local_let */ + } + if (local_let == sc->rootlet) return((is_slot(global_slot(sym))) ? global_value(sym) : sc->undefined); + if (is_unlet(local_let)) return(initial_value(sym)); + if (local_let == sc->starlet) return(starlet(sc, starlet_symbol_id(sym))); + return(s7_symbol_local_value(sc, sym, local_let)); + } + if (is_defined_global(sym)) + return(global_value(sym)); + return(s7_symbol_value(sc, sym)); +} + + +s7_pointer symbol_to_value_chooser(s7_scheme *sc, s7_pointer func, int32_t unused_args, s7_pointer expr) +{ + s7_pointer arg1 = cadr(expr), arg2 = (is_pair(cddr(expr))) ? caddr(expr) : sc->F; + if ((is_quoted_symbol(sc, arg1)) && (!is_keyword(cadr(arg1))) && (is_pair(arg2)) && (car(arg2) == sc->unlet_symbol)) /* old-style (obsolete) unlet as third arg(!) */ + { + set_fn_direct(arg2, g_unlet_disabled); + return(sc->sv_unlet_ref); + } + return(func); +} + + +/* ---------------------------------------- symbol->dynamic-value ---------------------------------------- */ +static s7_pointer find_dynamic_value(s7_scheme *sc, s7_pointer let, s7_pointer sym, s7_int *id) +{ + for (; let_id(let) > symbol_id(sym); let = let_outlet(let)); + if (let_id(let) == symbol_id(sym)) + { + (*id) = let_id(let); + return(local_value(sym)); + } + for (; (let) && (let_id(let) > (*id)); let = let_outlet(let)) + for (s7_pointer slot = let_slots(let); is_not_slot_end(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == sym) + { + (*id) = let_id(let); + return(slot_value(slot)); + } + return(sc->unused); +} + + +s7_pointer g_symbol_to_dynamic_value(s7_scheme *sc, s7_pointer args) +{ + + const s7_pointer sym = car(args); + s7_pointer val; + s7_int top_id = -1; + + if (!is_symbol(sym)) + return(method_or_bust(sc, sym, sc->symbol_to_dynamic_value_symbol, args, sc->type_names[T_SYMBOL], 1)); + + if (is_defined_global(sym)) + return(global_value(sym)); + + if (let_id(sc->curlet) == symbol_id(sym)) + return(local_value(sym)); + + val = find_dynamic_value(sc, sc->curlet, sym, &top_id); + if (top_id == symbol_id(sym)) + return(val); + + for (s7_int op_loc = stack_top(sc) - 1; op_loc > 0; op_loc -= 4) + if (is_let_unchecked(stack_let(sc->stack, op_loc))) /* OP_GC_PROTECT let slot can be anything (even free) */ + { + s7_pointer cur_val = find_dynamic_value(sc, stack_let(sc->stack, op_loc), sym, &top_id); + if (cur_val != sc->unused) + val = cur_val; + if (top_id == symbol_id(sym)) + return(val); + } + /* what about call/cc stacks? */ + return((val == sc->unused) ? s7_symbol_value(sc, sym) : val); +} + + +/* ---------------------------------------- defined? ---------------------------------------- */ +s7_pointer g_is_defined(s7_scheme *sc, s7_pointer args) +{ + /* 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, sc->type_names[T_SYMBOL], 1)); + + if (is_pair(cdr(args))) + { + s7_pointer let = cadr(args); + const s7_pointer ignore_globals = (is_pair(cddr(args))) ? caddr(args) : sc->F; + if (!is_let(let)) + { + const s7_pointer new_let = find_let(sc, let); /* returns () if none */ + if (!is_let(new_let)) + find_let_error_nr(sc, sc->is_defined_symbol, let, new_let, 2, args); + if ((new_let == sc->rootlet) && (is_pair(cddr(args))) && (ignore_globals != sc->F)) + { + if (ignore_globals != sc->T) /* signature claims this should be a boolean */ + return(method_or_bust(sc, ignore_globals, sc->is_defined_symbol, args, a_boolean_string, 3)); + return(sc->F); + } + let = new_let; + } + /* if (is_unlet(let)) return(make_boolean(sc, initial_value_is_defined(sc, sym))); */ + /* this ^ is wrong: (with-let (unlet) (define xx 1) (list (defined? 'xx) (defined? 'xx (curlet)))) should be (#t #t) */ + + if (is_keyword(sym)) /* if no "let", is global -> #t */ + { /* we're treating :x as 'x outside rootlet, but consider all keywords defined (as themselves) in rootlet? */ + if (let == sc->rootlet) return(sc->T); /* (defined? x (rootlet)) where x value is a keyword */ + sym = keyword_symbol(sym); /* (defined? :print-length *s7*) */ + } + if (let == sc->starlet) + return(make_boolean(sc, starlet_symbol_id(sym) != sl_no_field)); + if (!is_boolean(ignore_globals)) + return(method_or_bust(sc, ignore_globals, sc->is_defined_symbol, args, a_boolean_string, 3)); + if (let == sc->rootlet) /* we checked (let? let) above */ + { + if (ignore_globals == sc->F) + return(make_boolean(sc, is_slot(global_slot(sym)))); /* new_symbol and gensym initialize global_slot to # */ + return(sc->F); + } + if (is_slot(symbol_to_local_slot(sc, sym, T_Let(let)))) return(sc->T); + return((ignore_globals == sc->T) ? sc->F : make_boolean(sc, is_slot(global_slot(sym)))); + } + return((is_defined_global(sym)) ? sc->T : make_boolean(sc, is_bound_symbol(sc, sym))); +} + + +/* ---------------------------------------- funclet ---------------------------------------- */ +s7_pointer g_funclet(s7_scheme *sc, s7_pointer args) +{ + s7_pointer func = car(args); + if (is_symbol(func)) + { + if ((func = s7_symbol_value(sc, func)) == sc->undefined) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "funclet argument, '~S, is unbound", 33), car(args))); /* not func here */ + } + if_method_exists_return_value(sc, func, sc->funclet_symbol, args); + if (!((is_any_procedure(func)) || (is_c_object(func)))) + sole_arg_wrong_type_error_nr(sc, sc->funclet_symbol, func, a_procedure_or_a_macro_string); + return(find_let(sc, func)); +} + + +/* ---------------------------------------- owlet ---------------------------------------- */ +s7_pointer g_owlet(s7_scheme *sc, s7_pointer args) +{ + /* if owlet is not copied, (define e (owlet)), e changes as owlet does! */ + + s7_pointer let; + const bool old_gc = sc->gc_off; + if (is_pair(args)) + error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, too_many_arguments_string, sc->owlet_symbol, args)); +#if WITH_HISTORY + slot_set_value(sc->error_history, sanitize_history(sc, slot_value(sc->error_history))); +#endif + let = let_copy(sc, sc->owlet); + gc_protect_via_stack(sc, let); + + /* make sure the pairs/reals/strings/integers are copied: should be error-data, error-code, and error-history */ + sc->gc_off = true; + for (s7_pointer slot = let_slots(let); is_not_slot_end(slot); slot = next_slot(slot)) + if (is_pair(slot_value(slot))) + { + const s7_pointer new_list = copy_any_list(sc, slot_value(slot)); + slot_set_value(slot, new_list); + for (s7_pointer 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 = old_gc; + unstack_gc_protect(sc); + return(let); +} diff --git a/TeXmacs/plugins/goldfish/src/s7_scheme_let.h b/TeXmacs/plugins/goldfish/src/s7_scheme_let.h new file mode 100644 index 0000000000..5ba92249a3 --- /dev/null +++ b/TeXmacs/plugins/goldfish/src/s7_scheme_let.h @@ -0,0 +1,64 @@ +/* s7_scheme_let.h - let (environment) function declarations for s7 Scheme interpreter + * + * derived from s7, a Scheme interpreter + * SPDX-License-Identifier: 0BSD + */ + +#ifndef S7_SCHEME_LET_H +#define S7_SCHEME_LET_H + +#include "s7.h" + +#ifdef __cplusplus +extern "C" { +#endif + +s7_pointer g_unlet(s7_scheme *sc, s7_pointer unused_args); +s7_pointer g_openlet(s7_scheme *sc, s7_pointer args); +s7_pointer g_coverlet(s7_scheme *sc, s7_pointer args); +s7_pointer g_varlet(s7_scheme *sc, s7_pointer args); +s7_pointer g_cutlet(s7_scheme *sc, s7_pointer args); +s7_pointer g_sublet(s7_scheme *sc, s7_pointer args); +s7_pointer g_sublet_curlet(s7_scheme *sc, s7_pointer args); +s7_pointer sublet_chooser(s7_scheme *sc, s7_pointer func, int32_t num_args, s7_pointer expr); +s7_pointer g_simple_inlet(s7_scheme *sc, s7_pointer args); +s7_pointer inlet_p_pp(s7_scheme *sc, s7_pointer symbol, s7_pointer value); +s7_pointer internal_inlet(s7_scheme *sc, s7_int num_args, ...); +s7_pointer inlet_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr); +s7_pointer g_let_to_list(s7_scheme *sc, s7_pointer args); +s7_pointer call_let_ref_fallback(s7_scheme *sc, s7_pointer let, s7_pointer symbol); +s7_pointer call_let_set_fallback(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value); +s7_pointer let_ref(s7_scheme *sc, s7_pointer let, s7_pointer symbol); +s7_pointer g_let_ref(s7_scheme *sc, s7_pointer args); +s7_pointer slot_in_let(s7_scheme *sc, s7_pointer let, const s7_pointer sym); +s7_pointer let_ref_p_pp(s7_scheme *sc, s7_pointer let, s7_pointer sym); +s7_pointer g_cdr_let_ref(s7_scheme *sc, s7_pointer args); +s7_pointer g_starlet_ref(s7_scheme *sc, s7_pointer args); +s7_pointer g_rootlet_ref(s7_scheme *sc, s7_pointer args); +s7_pointer let_ref_chooser(s7_scheme *sc, s7_pointer func, int32_t unused_args, s7_pointer expr); +s7_pointer let_set_1(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value); +s7_pointer let_set_2(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value); +s7_pointer g_let_set(s7_scheme *sc, s7_pointer args); +s7_pointer let_set_p_ppp_2(s7_scheme *sc, s7_pointer let, s7_pointer sym, s7_pointer val); +s7_pointer g_cdr_let_set(s7_scheme *sc, s7_pointer args); +s7_pointer g_starlet_set(s7_scheme *sc, s7_pointer args); +s7_pointer g_unlet_set(s7_scheme *sc, s7_pointer args); +s7_pointer let_set_chooser(s7_scheme *sc, s7_pointer func, int32_t unused_args, s7_pointer expr); +s7_pointer reverse_slots(s7_pointer let_slots); +s7_pointer let_copy(s7_scheme *sc, s7_pointer let); +void update_symbol_ids(s7_scheme *sc, s7_pointer let); +s7_pointer outlet_p_p(s7_scheme *sc, s7_pointer let); +s7_pointer outlet_chooser(s7_scheme *sc, s7_pointer func, int32_t num_args, s7_pointer expr); +s7_pointer g_set_outlet(s7_scheme *sc, s7_pointer args); +s7_pointer g_symbol_to_value(s7_scheme *sc, s7_pointer args); +s7_pointer symbol_to_value_chooser(s7_scheme *sc, s7_pointer func, int32_t unused_args, s7_pointer expr); +s7_pointer g_symbol_to_dynamic_value(s7_scheme *sc, s7_pointer args); +s7_pointer g_is_defined(s7_scheme *sc, s7_pointer args); +s7_pointer g_funclet(s7_scheme *sc, s7_pointer args); +s7_pointer g_owlet(s7_scheme *sc, s7_pointer args); + +#ifdef __cplusplus +} +#endif + +#endif /* S7_SCHEME_LET_H */ diff --git a/TeXmacs/plugins/goldfish/src/s7_scheme_read.c b/TeXmacs/plugins/goldfish/src/s7_scheme_read.c new file mode 100644 index 0000000000..1409da6faa --- /dev/null +++ b/TeXmacs/plugins/goldfish/src/s7_scheme_read.c @@ -0,0 +1,906 @@ +#include "s7_internal.h" +#include "s7_scheme_read.h" +#include "s7_ctables.h" +#include +#include +#include + +/* -------- local macros (mirrors of s7.c internals, via s7_internal.h types) -------- */ + +#ifndef port_file + #define port_file(p) port_port(p)->file +#endif +#ifndef port_data + #define port_data(p) (T_Prt(p))->object.prt.data +#endif +#ifndef port_data_size + #define port_data_size(p) (T_Prt(p))->object.prt.size +#endif +#ifndef port_position + #define port_position(p) (T_Prt(p))->object.prt.point +#endif +#ifndef port_block + #define port_block(p) (T_Prt(p))->object.prt.block +#endif +#ifndef port_data_block + #define port_data_block(p) port_port(p)->block +#endif +#ifndef port_type + #define port_type(p) port_port(p)->ptype +#endif +#ifndef port_line_number + #define port_line_number(p) port_port(p)->line_number +#endif +#ifndef port_file_number + #define port_file_number(p) port_port(p)->file_number +#endif +#ifndef port_filename + #define port_filename(p) port_port(p)->filename +#endif +#ifndef port_filename_length + #define port_filename_length(p) port_port(p)->filename_length +#endif +#ifndef port_needs_free + #define port_needs_free(p) port_port(p)->needs_free +#endif +#ifndef port_set_closed + #define port_set_closed(p, Val) port_port(p)->is_closed = Val +#endif +#ifndef port_set_string_or_function + #define port_set_string_or_function(p, S) port_port(p)->orig_str = S +#endif +#ifndef port_input_function + #define port_input_function(p) port_port(p)->input_function +#endif +#ifndef port_is_closed + #define port_is_closed(p) port_port(p)->is_closed +#endif +#ifndef port_read_character + #define port_read_character(p) port_port(p)->pf->read_character +#endif +#ifndef port_read_line + #define port_read_line(p) port_port(p)->pf->read_line +#endif +#ifndef port_read_white_space + #define port_read_white_space(p) port_port(p)->pf->read_white_space +#endif + +#ifndef is_input_port + #define is_input_port(p) (type(p) == T_INPUT_PORT) +#endif +#ifndef is_string_port + #define is_string_port(p) (port_type(p) == string_port) +#endif +#ifndef is_function_port + #define is_function_port(p) (port_type(p) == function_port) +#endif +#ifndef is_file_port + #define is_file_port(p) (port_type(p) == file_port) +#endif +#ifndef is_character + #define is_character(p) (type(p) == T_CHARACTER) +#endif +#ifndef character + #define character(p) (T_Chr(p))->object.chr.c +#endif +#ifndef is_multiple_value + #define is_multiple_value(p) has_low_type_bit(T_Exs(p), T_MULTIPLE_VALUE) +#endif +#ifndef clear_multiple_value + #define clear_multiple_value(p) clear_low_type_bit(T_Pair(p), T_MULTIPLE_VALUE) +#endif +#ifndef is_white_space + #define is_white_space(C) white_space[C] +#endif +#ifndef is_eof + #define is_eof(p) ((T_Ext(p)) == eof_object) +#endif +#ifndef current_input_port + #define current_input_port(Sc) T_Pri(Sc->input_port) +#endif + +#ifndef push_stack_direct + #define push_stack_direct(Sc, Op) \ + do { \ + Sc->cur_op = Op; \ + memcpy((void *)(Sc->stack_end), (void *)Sc, 4 * sizeof(s7_pointer)); \ + Sc->stack_end += 4; \ + } while (0) +#endif +#ifndef stack_top_op + #define stack_top_op(Sc) ((opcode_t)T_Op(Sc->stack_end[-1])) +#endif + +#ifndef clamp_length + #define clamp_length(NLen, Len) (((NLen) < (Len)) ? (NLen) : (Len)) +#endif + +#ifndef SYMBOL_OK + #define SYMBOL_OK true +#endif +#ifndef WITH_OVERFLOW_ERROR + #define WITH_OVERFLOW_ERROR true +#endif + +#ifndef add_input_port + #define add_input_port(sc, p) add_to_gc_list(sc, sc->input_ports, p) +#endif + +/* s7.c exports (not in a shared header: s7_liii_string.c defines its own same-named helpers) */ +s7_pointer method_or_bust(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer args, s7_pointer typ, int32_t num); +s7_pointer method_or_bust_p(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer typ); +s7_pointer method_or_bust_pp(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer x1, s7_pointer x2, s7_pointer typ, int32_t num); + +#define declare_jump_info() bool old_longjmp; setjmp_loc_t old_jump_loc; jump_loc_t jump_loc; Jmp_Buf *old_goto_start; Jmp_Buf new_goto_start + +#define store_jump_info(Sc) \ + do { \ + old_longjmp = Sc->longjmp_ok; \ + old_jump_loc = Sc->setjmp_loc; \ + old_goto_start = Sc->goto_start; \ + } while (0) + +#define restore_jump_info(Sc) \ + do { \ + Sc->longjmp_ok = old_longjmp; \ + Sc->setjmp_loc = old_jump_loc; \ + Sc->goto_start = old_goto_start; \ + 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 = (jump_loc_t)SetJmp(new_goto_start, 1); \ + Sc->goto_start = &new_goto_start; \ + } while (0) + + +/* -------- read character functions -------- */ + +int32_t file_read_char(s7_scheme *sc, s7_pointer port) +{ + int32_t c = fgetc(port_file(port)); + if ((c == (int32_t)'\n') && (!s7i_is_loader_port(port))) port_line_number(port)++; + return(c); +} + +int32_t function_read_char(s7_scheme *sc, s7_pointer port) +{ + const s7_pointer result = (*(port_input_function(port)))(sc, S7_READ_CHAR, port); + if (is_eof(result)) return(EOF); + if (!is_character(result)) /* port_input_function might return some non-character */ + { + if (is_multiple_value(result)) + { + clear_multiple_value(result); + s7i_error_nr(sc, sc->bad_result_symbol, s7i_set_elist_2(sc, s7i_wrap_string(sc, "input-function-port read-char returned: ~S", 42), result)); + } + s7i_error_nr(sc, sc->wrong_type_arg_symbol, s7i_set_elist_2(sc, s7i_wrap_string(sc, "input-function-port read-char returned: ~S", 42), result)); + } + return((int32_t)character(result)); /* kinda nutty -- we return chars[this] in g_read_char! */ +} + +int32_t string_read_char(s7_scheme *sc, s7_pointer port) +{ + uint8_t c; + if (port_data_size(port) <= port_position(port)) return(EOF); + c = (uint8_t)port_data(port)[port_position(port)++]; /* port_string_length is 0 if no port string, port_data is uint8_t* */ + if ((c == (uint8_t)'\n') && (!s7i_is_loader_port(port))) port_line_number(port)++; + return(c); +} + +int32_t output_read_char(s7_scheme *sc, s7_pointer port) /* not reachable I think */ +{ + sole_arg_wrong_type_error_nr(sc, sc->read_char_symbol, port, s7i_an_input_port_string_obj()); + return(0); +} + +int32_t closed_port_read_char(s7_scheme *sc, s7_pointer port) +{ + sole_arg_wrong_type_error_nr(sc, sc->read_char_symbol, port, s7i_an_open_input_port_string_obj()); + return(0); +} + + +/* -------- read line functions -------- */ + +s7_pointer output_read_line(s7_scheme *sc, s7_pointer port, bool with_eol) /* not reachable I think */ +{ + sole_arg_wrong_type_error_nr(sc, sc->read_line_symbol, port, s7i_an_input_port_string_obj()); + return(NULL); +} + +s7_pointer closed_port_read_line(s7_scheme *sc, s7_pointer port, bool with_eol) +{ + sole_arg_wrong_type_error_nr(sc, sc->read_line_symbol, port, s7i_an_open_input_port_string_obj()); + return(NULL); +} + +s7_pointer function_read_line(s7_scheme *sc, s7_pointer port, bool with_eol) +{ + s7_pointer result = (*(port_input_function(port)))(sc, S7_READ_LINE, port); + if (is_multiple_value(result)) + { + clear_multiple_value(result); + s7i_error_nr(sc, sc->bad_result_symbol, s7i_set_elist_2(sc, s7i_wrap_string(sc, "input-function-port read-line returned: ~S", 42), result)); + } + return(result); +} + +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(eof_object); +} + +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; + const char *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(s7i_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(s7i_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); +} + +s7_pointer string_read_line(s7_scheme *sc, s7_pointer port, bool with_eol) +{ + s7_int i; + const char *port_str = (const char *)port_data(port); + const s7_int port_start = port_position(port); + const char *start = port_str + port_start; + const char *cur = (const char *)strchr(start, (int)'\n'); /* this can run off the end making valgrind unhappy, but I think it's innocuous */ + if (cur) + { + s7_int len; + port_line_number(port)++; + i = cur - port_str; + port_position(port) = i + 1; + len = ((with_eol) ? i + 1 : i) - port_start; + if (len == 0) return(s7i_nil_string()); + return(s7i_make_string_with_length(sc, start, len)); + } + 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(s7i_make_string_with_length(sc, start, i - port_start)); +} + + +/* -------- skip to newline readers -------- */ + +token_t file_read_semicolon(s7_scheme *sc, s7_pointer port) +{ + int32_t c; + do (c = fgetc(port_file(port))); while ((c != '\n') && (c != EOF)); + port_line_number(port)++; + return((c == EOF) ? token_eof : s7i_token(sc)); +} + +token_t string_read_semicolon(s7_scheme *sc, s7_pointer port) +{ + const char *str = (const char *)(port_data(port) + port_position(port)); + const char *orig_str = strchr(str, (int)'\n'); + if (!orig_str) + { + port_position(port) = port_data_size(port); + return(token_eof); + } + port_position(port) += (orig_str - str + 1); /* + 1 because strchr leaves orig_str pointing at the newline */ + port_line_number(port)++; + return(s7i_token(sc)); +} + + +/* -------- white space readers -------- */ + +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); +} + +int32_t terminated_string_read_white_space(s7_scheme *sc, s7_pointer port) +{ + const uint8_t *str = (const uint8_t *)(port_data(port) + port_position(port)); + uint8_t c; + /* here we know we have null termination and white_space[#\null] is false */ + while (white_space[c = *str++]) /* 255 is not -1 = EOF */ + if (c == '\n') + port_line_number(port)++; + port_position(port) = (c) ? str - port_data(port) : port_data_size(port); + return((int32_t)c); +} + + +/* -------- name readers -------- */ +#define BASE_10 10 + +static s7_pointer file_read_name_or_sharp(s7_scheme *sc, s7_pointer port, 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(port)); /* might return EOF */ + if (c == '\n') + port_line_number(port)++; + + sc->strbuf[i++] = (unsigned char)c; + if (i >= sc->strbuf_size) + s7i_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(port)--; + ungetc(c, port_file(port)); + } + sc->strbuf[i - 1] = '\0'; + } + if (atom_case) + return(make_atom(sc, sc->strbuf, BASE_10, SYMBOL_OK, WITH_OVERFLOW_ERROR)); + return(s7i_make_sharp_constant(sc, sc->strbuf, WITH_OVERFLOW_ERROR, port, true)); +} + +s7_pointer file_read_name(s7_scheme *sc, s7_pointer port) {return(file_read_name_or_sharp(sc, port, true));} +s7_pointer file_read_sharp(s7_scheme *sc, s7_pointer port) {return(file_read_name_or_sharp(sc, port, false));} + +s7_pointer string_read_name_no_free(s7_scheme *sc, s7_pointer port) +{ + /* sc->strbuf[0] has the first char of the string we're reading */ + const uint8_t *str = (uint8_t *)(port_data(port) + port_position(port)); + + if (char_ok_in_a_name[*str]) + { + s7_int k; + const uint8_t *orig_str = str - 1; + str++; + while (char_ok_in_a_name[*str]) str++; + k = str - orig_str; + if (*str != 0) + port_position(port) += (k - 1); + else port_position(port) = port_data_size(port); + /* 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[*orig_str]) + return(s7i_make_symbol_with_length(sc, (const char *)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) + s7i_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)); + } + { + s7_pointer result = sc->singletons[(uint8_t)(sc->strbuf[0])]; + if (!result) + { + sc->strbuf[1] = '\0'; + result = s7_make_symbol(sc, sc->strbuf); + sc->singletons[(uint8_t)(sc->strbuf[0])] = result; + } + return(result); + } +} + +s7_pointer string_read_sharp(s7_scheme *sc, s7_pointer port) +{ + /* 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 = (char *)(port_data(port) + port_position(port)); + if (char_ok_in_a_name[(uint8_t)*str]) + { + s7_int k; + const char *orig_str = (char *)(str - 1); + str++; + while (char_ok_in_a_name[(uint8_t)(*str)]) {str++;} + k = str - orig_str; + port_position(port) += (k - 1); + if ((k + 1) >= sc->strbuf_size) + s7i_resize_strbuf(sc, k + 1); + memcpy((void *)(sc->strbuf), (void *)orig_str, k); + sc->strbuf[k] = '\0'; + return(s7i_make_sharp_constant(sc, sc->strbuf, WITH_OVERFLOW_ERROR, port, 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(port)++; + } + else sc->strbuf[1] = '\0'; + return(s7i_make_sharp_constant(sc, sc->strbuf, WITH_OVERFLOW_ERROR, port, true)); +} + +s7_pointer string_read_name(s7_scheme *sc, s7_pointer port) +{ + /* port_string was allocated (and read from a file) so we can mess with it directly */ + s7_pointer result; + uint8_t *str = (uint8_t *)(port_data(port) + port_position(port)); + if (char_ok_in_a_name[*str]) + { + s7_int k; + uint8_t endc; + const uint8_t *orig_str = str - 1; + str++; + while (char_ok_in_a_name[*str]) str++; + k = str - orig_str; + port_position(port) += (k - 1); + if (!number_table[*orig_str]) + return(s7i_make_symbol_with_length(sc, (const char *)orig_str, k)); + endc = *str; + *str = 0; /* temp end for make_atom */ + result = make_atom(sc, (char *)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 = s7_make_symbol(sc, sc->strbuf); + sc->singletons[(uint8_t)(sc->strbuf[0])] = result; + } + return(result); +} + + +/* -------- file port creation -------- */ + +s7_pointer read_file(s7_scheme *sc, FILE *fp, const char *name, s7_int max_size, const char *caller) +{ + s7_pointer port; + s7_int size; + block_t *b = s7i_mallocate_port(sc); + new_cell(sc, port, T_INPUT_PORT); + gc_protect_via_stack(sc, port); + port_block(port) = b; + port_port(port) = (port_t *)s7i_block_data(b); + port_set_closed(port, false); + port_set_string_or_function(port, sc->nil); + port_filename_length(port) = s7i_safe_strlen(name); + s7i_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 + /* MS C's fseek/ftell truncate large files: use the 64-bit-safe variants */ + if ((_fseeki64(fp, 0, SEEK_END) != 0) || + ((size = _ftelli64(fp)) < 0)) + size = 0; + rewind(fp); +#else + fseek(fp, 0, SEEK_END); + size = ftell(fp); + rewind(fp); +#endif + /* 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 */ + { + block_t *block = s7i_mallocate(sc, size + 2); + uint8_t *content = (uint8_t *)(s7i_block_data(block)); + const size_t bytes = fread(content, sizeof(uint8_t), size, fp); + if (bytes != (size_t)size) + { + /* in MS Windows text mode, CRLF -> LF translation makes the read size smaller than the file size */ + if (ferror(fp) || (bytes == 0)) + { + if (s7i_current_output_port(sc) != sc->F) + { + char tmp[256]; + int32_t len = snprintf(tmp, 256, "(%s \"%s\") read %ld bytes of an expected %" ld64 "?", caller, name, (long)bytes, size); + port_write_string(s7i_current_output_port(sc))(sc, tmp, clamp_length(len, 256), s7i_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 = s7i_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 = s7i_input_file_functions(); + } + unstack_gc_protect(sc); + return(port); +} + + +/* -------- current-input-port handling -------- */ + +s7_pointer input_port_if_not_loading(s7_scheme *sc) +{ + const s7_pointer port = current_input_port(sc); + int32_t c; + if (!s7i_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 */ + { + s7i_backchar(c, port); + return(NULL); + } + return(sc->standard_input); +} + +s7_pointer s7i_input_port_if_not_loading(s7_scheme *sc) +{ + return(input_port_if_not_loading(sc)); +} + +s7_pointer s7i_port_read_line(s7_scheme *sc, s7_pointer port, bool with_eol) +{ + return(port_read_line(port)(sc, port, with_eol)); +} + + +/* -------------------------------- read-char -------------------------------- */ +s7_pointer s7_read_char(s7_scheme *sc, s7_pointer port) +{ + int32_t c = port_read_character(port)(sc, port); + return((c == EOF) ? eof_object : chars[c]); +} + +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_pair(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_p(sc, port, sc->read_char_symbol, s7i_an_input_port_string_obj())); + return(chars[port_read_character(port)(sc, port)]); +} + +s7_pointer read_char_p_p(s7_scheme *sc, s7_pointer port) +{ + if (!is_input_port(port)) + return(method_or_bust_p(sc, port, sc->read_char_symbol, s7i_an_input_port_string_obj())); + return(chars[port_read_character(port)(sc, port)]); +} + +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_p(sc, port, sc->read_char_symbol, s7i_an_input_port_string_obj())); + return(chars[port_read_character(port)(sc, port)]); +} + +s7_pointer read_char_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr) +{ + return((args == 1) ? sc->read_char_1 : func); +} + + +/* -------------------------------- 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)) ? eof_object : chars[(uint8_t)port_data(port)[port_position(port)]]); + c = port_read_character(port)(sc, port); + if (c == EOF) return(eof_object); + s7i_backchar(c, port); + return(chars[c]); +} + +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 result; + const s7_pointer port = (is_pair(args)) ? car(args) : current_input_port(sc); + if (!is_input_port(port)) + return(method_or_bust_p(sc, port, sc->peek_char_symbol, s7i_an_input_port_string_obj())); + if (port_is_closed(port)) + sole_arg_wrong_type_error_nr(sc, sc->peek_char_symbol, port, s7i_an_open_input_port_string_obj()); + if (!is_function_port(port)) + return(s7_peek_char(sc, port)); + + result = (*(port_input_function(port)))(sc, S7_PEEK_CHAR, port); + if (is_multiple_value(result)) + { + clear_multiple_value(result); + s7i_error_nr(sc, sc->bad_result_symbol, + s7i_set_elist_2(sc, s7i_wrap_string(sc, "input-function-port peek-char returned multiple values: ~S", 58), result)); + } + if (!is_character(result)) + s7i_error_nr(sc, sc->wrong_type_arg_symbol, + s7i_set_elist_2(sc, s7i_wrap_string(sc, "input-function-port peek-char returned: ~S", 42), result)); + return(result); +} + + +/* -------------------------------- read-byte -------------------------------- */ +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_pair(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_p(sc, port, sc->read_byte_symbol, s7i_an_input_port_string_obj())); + if (port_is_closed(port)) /* avoid reporting caller here as read-char */ + sole_arg_wrong_type_error_nr(sc, sc->read_byte_symbol, port, s7i_an_open_input_port_string_obj()); + c = port_read_character(port)(sc, port); + return((c == EOF) ? eof_object : s7i_small_int(c)); +} + + +/* -------------------------------- read-line -------------------------------- */ +/* g_read_line is now implemented in s7_scheme_base.c */ + +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_pp(sc, port, sc->read_line_symbol, port, with_eol, s7i_an_input_port_string_obj(), 1)); + if (!is_boolean(with_eol)) + s7_wrong_type_arg_error(sc, "read-line", 2, with_eol, s7i_a_boolean_string()); + return(port_read_line(port)(sc, port, with_eol != sc->F)); +} + +s7_pointer read_line_p_p(s7_scheme *sc, s7_pointer port) +{ + if (!is_input_port(port)) + return(method_or_bust_p(sc, port, sc->read_line_symbol, s7i_an_input_port_string_obj())); + return(port_read_line(port)(sc, port, false)); /* with_eol default is #f */ +} + + +/* -------------------------------- read-string -------------------------------- */ +#define READ_STRING_LINE_NUMBERS 0 /* 1 adds port-line-number support to read-string, doubling the time it takes */ + +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. + * should this worry about newlines? read-char and read-line keep port-line-number up to date, + * but here we'd need to scan the new string (via strchr?) or xor with \n\n\n\n... up to 8-at-a-time, and count zeros. + */ + #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) + const s7_pointer k = car(args); + s7_pointer port, str; + s7_int nchars; + uint8_t *str_chars; + + if (!s7_is_integer(k)) + return(method_or_bust(sc, k, sc->read_string_symbol, args, sc->type_names[T_INTEGER], 1)); + nchars = s7i_integer_clamped_if_gmp(sc, k); + if (nchars < 0) + s7_out_of_range_error(sc, "read-string", 1, k, "it is negative"); + if (nchars > sc->max_string_length) + s7i_error_nr(sc, sc->out_of_range_symbol, + s7i_set_elist_3(sc, s7i_wrap_string(sc, "read-string first argument ~D is greater than (*s7* 'max-string-length), ~D", 75), + s7i_wrap_integer(sc, nchars), s7i_wrap_integer(sc, sc->max_string_length))); + 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_pp(sc, port, sc->read_string_symbol, k, port, s7i_an_input_port_string_obj(), 2)); + if (port_is_closed(port)) + sole_arg_wrong_type_error_nr(sc, sc->read_string_symbol, port, s7i_an_open_input_port_string_obj()); + + str = s7i_make_empty_string(sc, nchars, '\0'); + if (nchars == 0) return(str); + str_chars = (uint8_t *)s7i_string_value(str); + if (is_string_port(port)) + { + const s7_int pos = port_position(port); + const s7_int end = port_data_size(port); + s7_int len = end - pos; + if (len > nchars) len = nchars; + if (len <= 0) return(eof_object); + memcpy((void *)str_chars, (void *)(port_data(port) + pos), len); + s7i_set_string_length(str, len); + str_chars[len] = '\0'; + port_position(port) += len; +#if READ_STRING_LINE_NUMBERS + for (s7_int i = 0; i < len; i++) if (str_chars[i] == '\n') port_line_number(port)++; +#endif + return(str); + } + if (is_file_port(port)) + { + const s7_int len = (s7_int)fread((void *)str_chars, 1, nchars, port_file(port)); + str_chars[len] = '\0'; + s7i_set_string_length(str, len); +#if READ_STRING_LINE_NUMBERS + for (s7_int i = 0; i < len; i++) if (str_chars[i] == '\n') port_line_number(port)++; +#endif + return(str); + } + for (s7_int i = 0; i < nchars; i++) + { + const int32_t c = port_read_character(port)(sc, port); + if (c == EOF) + { + if (i == 0) + return(eof_object); + s7i_set_string_length(str, i); + return(str); + } + str_chars[i] = (uint8_t)c; +#if READ_STRING_LINE_NUMBERS + if (c == '\n') port_line_number(port)++; +#endif + } + return(str); +} + + +/* -------------------------------- read -------------------------------- */ +s7_pointer s7_read(s7_scheme *sc, s7_pointer port) +{ + if (!is_input_port(port)) + sole_arg_wrong_type_error_nr(sc, sc->read_symbol, port, s7i_an_input_port_string_obj()); + { + const s7_pointer old_let = sc->curlet; + declare_jump_info(); + set_curlet(sc, sc->rootlet); + 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) + s7i_eval(sc, sc->cur_op); + } + else + { + push_stack_no_let_no_code(sc, OP_BARRIER, port); + push_stack_direct(sc, OP_EVAL_DONE); + s7i_eval(sc, OP_READ_INTERNAL); + if (sc->tok == token_eof) + sc->value = eof_object; + if ((sc->cur_op == OP_EVAL_DONE) && /* pushed above */ + (stack_top_op(sc) == OP_BARRIER)) + pop_stack(sc); + } + pop_input_port(sc); + set_curlet(sc, old_let); + restore_jump_info(sc); + return(sc->value); + } +} + +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_pair(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_p(sc, port, sc->read_symbol, s7i_an_input_port_string_obj())); + + if (is_function_port(port)) + { + s7_pointer result = (*(port_input_function(port)))(sc, S7_READ, port); + if (is_multiple_value(result)) + { + clear_multiple_value(result); + s7i_error_nr(sc, sc->bad_result_symbol, s7i_set_elist_2(sc, s7i_wrap_string(sc, "input-function-port read returned: ~S", 37), result)); + } + return(result); + } + 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); +} diff --git a/TeXmacs/plugins/goldfish/src/s7_scheme_read.h b/TeXmacs/plugins/goldfish/src/s7_scheme_read.h new file mode 100644 index 0000000000..4e7d4e43e7 --- /dev/null +++ b/TeXmacs/plugins/goldfish/src/s7_scheme_read.h @@ -0,0 +1,85 @@ +/* s7_scheme_read.h - read function declarations for s7 Scheme interpreter + * + * derived from s7, a Scheme interpreter + * SPDX-License-Identifier: 0BSD + * + * Bill Schottstaedt, bil@ccrma.stanford.edu + */ + +#ifndef S7_SCHEME_READ_H +#define S7_SCHEME_READ_H + +#include "s7.h" +#include + +#ifdef __cplusplus +extern "C" { +#endif + +/* globals defined in s7.c (chars[EOF] is #) */ +extern s7_pointer *chars; +extern s7_pointer eof_object; + +/* port read primitives (referenced by the port_functions_t tables in s7.c) */ +int32_t file_read_char(s7_scheme *sc, s7_pointer port); +int32_t function_read_char(s7_scheme *sc, s7_pointer port); +int32_t string_read_char(s7_scheme *sc, s7_pointer port); +int32_t output_read_char(s7_scheme *sc, s7_pointer port); +int32_t closed_port_read_char(s7_scheme *sc, s7_pointer port); + +s7_pointer output_read_line(s7_scheme *sc, s7_pointer port, bool with_eol); +s7_pointer closed_port_read_line(s7_scheme *sc, s7_pointer port, bool with_eol); +s7_pointer function_read_line(s7_scheme *sc, s7_pointer port, bool with_eol); +s7_pointer stdin_read_line(s7_scheme *sc, s7_pointer port, bool with_eol); +s7_pointer file_read_line(s7_scheme *sc, s7_pointer port, bool with_eol); +s7_pointer string_read_line(s7_scheme *sc, s7_pointer port, bool with_eol); + +#ifdef S7_INTERNAL_H +/* token_t is defined in s7_internal.h (s7.c has its own copy and declares these itself) */ +token_t file_read_semicolon(s7_scheme *sc, s7_pointer port); +token_t string_read_semicolon(s7_scheme *sc, s7_pointer port); +const port_functions_t *s7i_input_file_functions(void); +const port_functions_t *s7i_input_string_functions_1(void); +#endif + +int32_t file_read_white_space(s7_scheme *sc, s7_pointer port); +int32_t terminated_string_read_white_space(s7_scheme *sc, s7_pointer port); + +s7_pointer file_read_name(s7_scheme *sc, s7_pointer port); +s7_pointer file_read_sharp(s7_scheme *sc, s7_pointer port); +s7_pointer string_read_name_no_free(s7_scheme *sc, s7_pointer port); +s7_pointer string_read_sharp(s7_scheme *sc, s7_pointer port); +s7_pointer string_read_name(s7_scheme *sc, s7_pointer port); + +/* file port creation */ +s7_pointer read_file(s7_scheme *sc, FILE *fp, const char *name, s7_int max_size, const char *caller); + +/* Public API implementations */ +s7_pointer s7_read(s7_scheme *sc, 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); + +/* Scheme accessible functions */ +s7_pointer g_read(s7_scheme *sc, s7_pointer args); +s7_pointer g_read_char(s7_scheme *sc, s7_pointer args); +s7_pointer g_read_char_1(s7_scheme *sc, s7_pointer args); +s7_pointer g_peek_char(s7_scheme *sc, s7_pointer args); +s7_pointer g_read_byte(s7_scheme *sc, s7_pointer args); +s7_pointer g_read_string(s7_scheme *sc, s7_pointer args); + +/* Optimizer helpers */ +s7_pointer read_char_p_p(s7_scheme *sc, s7_pointer port); +s7_pointer read_char_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr); +s7_pointer read_line_p_p(s7_scheme *sc, s7_pointer port); +s7_pointer read_line_p_pp(s7_scheme *sc, s7_pointer port, s7_pointer with_eol); + +/* Export helpers */ +s7_pointer input_port_if_not_loading(s7_scheme *sc); +s7_pointer s7i_port_read_line(s7_scheme *sc, s7_pointer port, bool with_eol); +s7_pointer s7i_input_port_if_not_loading(s7_scheme *sc); + +#ifdef __cplusplus +} +#endif + +#endif /* S7_SCHEME_READ_H */ diff --git a/TeXmacs/plugins/goldfish/src/s7_scheme_write.c b/TeXmacs/plugins/goldfish/src/s7_scheme_write.c index 6d0f6614a5..7350e5950b 100644 --- a/TeXmacs/plugins/goldfish/src/s7_scheme_write.c +++ b/TeXmacs/plugins/goldfish/src/s7_scheme_write.c @@ -6,8 +6,10 @@ * Bill Schottstaedt, bil@ccrma.stanford.edu */ +#include "s7_internal.h" #include "s7_scheme_write.h" -#include "s7_internal_helpers.h" +#include "s7_scheme_let.h" +#include "s7_continuation.h" #define IF_METHOD_EXISTS_RETURN_VALUE(Sc, Obj, Method_name, Args) \ do { \ @@ -18,6 +20,3401 @@ } \ } while (0) +/* -------- cycles -------- */ + +#define INITIAL_SHARED_INFO_SIZE 8 + +int32_t shared_ref(shared_info_t *ci, const s7_pointer p) +{ + /* from print after collecting refs, not called by equality check, only called in object_to_port_with_circle_check_1 */ + s7_pointer *objs = ci->objs; + for (int32_t 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); +} + +void flip_ref(shared_info_t *ci, const s7_pointer p) +{ + s7_pointer *objs = ci->objs; + for (int32_t i = 0; i < ci->top; i++) + if (objs[i] == p) + { + ci->refs[i] = -ci->refs[i]; + break; + } +} + +int32_t peek_shared_ref_1(shared_info_t *ci, const s7_pointer p) +{ + /* returns 0 if not found, otherwise the ref value for p */ + s7_pointer *objs = ci->objs; + for (int32_t i = 0; i < ci->top; i++) + if (objs[i] == p) + return(ci->refs[i]); + return(0); +} + +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); +} + +void enlarge_shared_info(shared_info_t *ci) +{ + 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, memclr is not faster */ + for (int32_t i = ci->top; i < ci->size; i++) + { + ci->refs[i] = 0; + ci->objs[i] = NULL; + } +} + +static bool check_collected(s7_pointer top, shared_info_t *ci) +{ + const s7_pointer *objs_end = (s7_pointer *)(ci->objs + ci->top); + for (s7_pointer *p = ci->objs; p < objs_end; p++) + if ((*p) == top) + { + int32_t 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 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 (s7_int i = 0; i < plen; i++) + { + const s7_pointer vel = vector_element_unchecked(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); +} + +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; + 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 (s7_pointer 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 (s7_pointer 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) + { + const s7_int len = (s7_int)hash_table_size(top); + hash_entry_t **entries = hash_table_elements(top); + const bool keys_safe = hash_keys_not_cyclic(sc, top); + for (s7_int i = 0; i < len; i++) + for (hash_entry_t *entry = entries[i]; entry; entry = hash_entry_next(entry)) + { + if ((!keys_safe) && + (has_structure(hash_entry_key(entry))) && + (collect_shared_info(sc, ci, hash_entry_key(entry), stop_at_print_length))) + top_cyclic = true; + if ((has_structure(hash_entry_value(entry))) && + (collect_shared_info(sc, ci, hash_entry_value(entry), stop_at_print_length))) + { + if ((is_c_pointer(hash_entry_value(entry))) || + (is_iterator(hash_entry_value(entry))) || + (is_c_object(hash_entry_value(entry)))) + 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 + for (s7_pointer let = top; let; let = let_outlet(let)) + for (s7_pointer slot = let_slots(let); is_not_slot_end(slot); slot = next_slot(slot)) + if ((has_structure(slot_value(slot))) && + (collect_shared_info(sc, ci, slot_value(slot), stop_at_print_length))) + { + top_cyclic = true; + if ((is_c_pointer(slot_value(slot))) || + (is_iterator(slot_value(slot))) || + (is_c_object(slot_value(slot)))) + 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); +} + +shared_info_t *make_shared_info(s7_scheme *sc) +{ + shared_info_t *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); +} + +void free_shared_info(shared_info_t *ci) +{ + if (ci) + { + free(ci->objs); + free(ci->refs); + free(ci->defined); + free(ci); + } +} + +shared_info_t *clear_shared_info(shared_info_t *ci) +{ + if (ci->top > 0) + { + memclr((void *)(ci->refs), ci->top * sizeof(int32_t)); + memclr((void *)(ci->defined), ci->top * sizeof(bool)); + for (int32_t 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; + ci->ctr = 0; + return(ci); +} + +shared_info_t *load_shared_info(s7_scheme *sc, s7_pointer top, bool stop_at_print_length, shared_info_t *ci) +{ + /* for the printer, here only if is_structure(top) and top is not sc->rootlet */ + bool no_problem = true; + s7_int stop_len; + + /* check for simple cases first */ + if (is_pair(top)) + { + s7_pointer p = top; + if (stop_at_print_length) + { + s7_pointer slow = top; + stop_len = sc->print_length; + for (s7_int k = 0; k < stop_len; k += 2) + { + if (!is_pair(p)) break; + if (has_structure(car(p))) {no_problem = false; break;} + p = cdr(p); + if (!is_pair(p)) break; + if (has_structure(car(p))) {no_problem = false; break;} + p = cdr(p); + slow = cdr(slow); + if (p == 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(p); p = cdr(p)) + if (has_structure(car(p))) {no_problem = false; break;} /* perhaps (and (length > 0 via sequence_is_empty)) or vector typer etc */ + if ((no_problem) && + (!is_null(p)) && (has_structure(p))) + no_problem = false; + if (no_problem) return(NULL); + } + else + if (is_t_vector(top)) /* any other vector can't happen */ + { + stop_len = vector_length(top); + if ((stop_at_print_length) && + (stop_len > sc->print_length)) + stop_len = sc->print_length; + for (s7_int k = 0; k < stop_len; k++) + if (has_structure(vector_element(top, k))) {no_problem = false; break;} + if (no_problem) return(NULL); + } + + else /* added these 19-Oct-22 -- helps in tgc, but not much elsewhere */ + if ((is_let(top)) && (top != sc->rootlet)) + { + for (s7_pointer let = top; (no_problem) && (let); let = let_outlet(let)) + for (s7_pointer slot = let_slots(let); is_not_slot_end(slot); slot = next_slot(slot)) + if (has_structure(slot_value(slot))) /* slot_symbol need not be checked? */ + {no_problem = false; break;} + if (no_problem) return(NULL); + } + else + if (is_hash_table(top)) + { + hash_entry_t **entries = hash_table_elements(top); + bool keys_safe = hash_keys_not_cyclic(sc, top); + if (hash_table_entries(top) == 0) return(NULL); + for (s7_int len = (s7_int)hash_table_size(top), i = 0; i < len; i++) + for (hash_entry_t *entry = entries[i]; entry; entry = hash_entry_next(entry)) + if (((!keys_safe) && (has_structure(hash_entry_key(entry)))) || (has_structure(hash_entry_value(entry)))) + {no_problem = false; break;} + if (no_problem) return(NULL); + } + + if ((S7_DEBUGGING) && (is_any_vector(top)) && (!is_t_vector(top))) fprintf(stderr, "%s[%d]: got abnormal vector\n", __func__, __LINE__); + clear_shared_info(ci); + { + /* collect all pointers associated with top */ + const bool cyclic = collect_shared_info(sc, ci, top, stop_at_print_length); + s7_pointer *ci_objs = ci->objs; + int32_t *ci_refs = ci->refs; + int32_t refs = 0; + + for (int32_t i = 0; i < ci->top; i++) + clear_collected_and_shared(ci_objs[i]); + if (!cyclic) + return(NULL); + if (!(ci->has_hits)) + return(NULL); + + /* 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 (int32_t i = 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 -------------------------------- */ +s7_pointer cyclic_sequences_p_p(s7_scheme *sc, s7_pointer obj) +{ + if (has_structure(obj)) + { + shared_info_t *ci = (sc->object_out_locked) ? sc->circle_info : load_shared_info(sc, obj, false, sc->circle_info); /* false=don't stop at print length (vectors etc) */ + if (ci) + { + s7i_check_free_heap_size(sc, ci->top); + begin_temp(sc->y, sc->nil); + for (int32_t i = 0; i < ci->top; i++) + sc->y = cons_unchecked(sc, ci->objs[i], sc->y); + return_with_end_temp(sc->y); + }} + return(sc->nil); +} + + +/* -------------------------------- object->port (display format etc) -------------------------------- */ +int32_t circular_list_entries(s7_pointer lst) +{ + int32_t i = 1; + for (s7_pointer x = cdr(lst); ; i++, x = cdr(x)) + { + int32_t j = 0; + for (s7_pointer y = lst; 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[type_unchecked(Obj)])(Sc, Obj, Port, Use_Write, Ci) + +static bool string_needs_slashification(const uint8_t *str, s7_int len) +{ + /* we have to go by len (str len) not *s==0 because s7 strings can have embedded nulls */ + for (const uint8_t *p = str, *pend = (const uint8_t *)(str + len); 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) +{ + const uint8_t *pcur, *pend, *pstart = NULL; + if (len == 0) + { + if (quoted) + port_write_string(port)(sc, "\"\"", 2, port); + return; + } + pend = (const 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) 12 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 = (const uint8_t *)p; pcur < pend; pcur++) + if (slashify_table[*pcur]) + { + if (pstart) pstart++; else pstart = (const uint8_t *)p; + if (pstart != pcur) + { + port_write_string(port)(sc, (const 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 '\n': port_write_character(port)(sc, 'n', port); break; /* added 17-Sep-25 for r7rs */ + 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, (const char *)p, len, port); + else + { + pstart++; + if (pstart != pcur) + port_write_string(port)(sc, (const 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 *unused_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 = (int32_t)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 *unused_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 = (int32_t)catstrs(str, 256, "(open-input-file \"", port_filename(obj), "\")", (char *)NULL); + port_write_string(port)(sc, str, nlen, port); + } + else + { + const s7_int data_len = port_data_size(obj) - port_position(obj); + if (data_len > 100) + { + const char *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 = (int32_t)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 = (int32_t)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 = (int32_t)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, "#", 9, port); + else port_write_character(port)(sc, '>', port); + } +} + +static bool symbol_needs_slashification(s7_scheme *sc, s7_pointer obj) +{ + uint8_t *pend; + char *str = symbol_name(obj); /* not const for make_atom */ + s7_int len; + + if ((str[0] == '#') || (str[0] == '\'') || (str[0] == ',')) + return(true); + if (is_number(make_atom(sc, str, 10, NO_SYMBOLS, WITHOUT_OVERFLOW_ERROR))) + return(true); + + len = symbol_name_length(obj); + pend = (uint8_t *)(str + len); + for (uint8_t *p = (uint8_t *)str; p < pend; p++) + if (symbol_slashify_table[*p]) + return(true); + set_clean_symbol(obj); + return(false); +} + +void symbol_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) +{ + /* I think this is the only place we print a symbol's name */ + if ((!is_clean_symbol(obj)) && + (symbol_needs_slashification(sc, obj))) + { + /* this can't work in general if use_write == p_readable: + * (define f (apply lambda (list () (list 'let (list (list (symbol "a b") 3)) (symbol "a b"))))) ; (f) -> 3 + * prints "readably" as "(lambda () (let (((symbol \"a b\") 3)) (symbol \"a b\")))" + * so, 30-May-24 added (*s7* 'symbol-printer). + */ + if (is_any_procedure(sc->symbol_printer)) /* we see p_write here */ + { + const s7_pointer printer = sc->symbol_printer; + s7_pointer result; + sc->symbol_printer = sc->F; /* avoid infinite recursion */ + result = s7_call(sc, printer, set_plist_1(sc, obj)); + if (!is_string(result)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "(*s7* 'symbol-printer) should return a string: ~S", 49), result)); + /* if we restore symbol-printer before the error, and the printer function stupidly returned the bad symbol, infinite loop */ + sc->symbol_printer = printer; + port_write_string(port)(sc, string_value(result), string_length(result), port); + } + else + { + 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) || (use_write == p_code)) + { + if (!is_keyword(obj)) c = '\''; + } + else if ((use_write == p_key) && (!is_keyword(obj))) c = ':'; + if (is_string_port(port)) + { + s7_int 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 = vector_dimension(vect, cur_dim); + s7_int 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_1(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) +{ + if (use_write != p_readable) + { + if (*last) + port_write_string(port)(sc, " (", 2, port); + else port_write_character(port)(sc, '(', port); + (*last) = false; + } + for (int32_t 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_1(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 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, + use_write_t use_write, shared_info_t *ci) +{ + bool last = false; + return(multivector_to_port_1(sc, vec, port, out_len, flat_ref, dimension, dimensions, &last, use_write, ci)); +} + +static void make_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port) +{ + const s7_int vlen = vector_length(vect); + 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-"; + else + if (is_complex_vector(vect)) + vtyp = "complex-"; + + if (vector_rank(vect) == 1) + { + plen = (int32_t)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 = (int32_t)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 = (int32_t)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 = (int32_t)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)) + { + const s7_int vlen = vector_length(vect); + s7_pointer *els = vector_elements(vect); + const s7_pointer 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); + if (is_typed_vector(vect)) + { + port_write_character(port)(sc, ' ', port); + port_write_vector_typer(sc, vect, port); + } + port_write_character(port)(sc, ')', port); + return; + }} + check_stack_size(sc); + 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_gc_protect(sc); + return; + } + + if (is_typed_vector(vect)) + port_write_string(port)(sc, "(let (( ", 11, port); + 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])) + { + int32_t eref = peek_shared_ref(ci, els[i]); + port_write_string(port)(sc, " #f", 3, port); + if (eref != 0) + { + if (eref < 0) eref = -eref; + if (vector_rank(vect) > 1) + { + const s7_int dimension = vector_rank(vect) - 1; + const int32_t str_len = (dimension < 8) ? 128 : ((dimension + 1) * 16); + block_t *b = callocate(sc, str_len); + char *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 = 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) + { + const s7_int dimension = vector_rank(vect) - 1; + const int32_t str_len = (dimension < 8) ? 128 : ((dimension + 1) * 16); + block_t *b = callocate(sc, str_len); + char *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 = 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); + } + if (is_typed_vector(vect)) + { + port_write_string(port)(sc, ")) (set! (vector-typer ) ", 28, port); + port_write_vector_typer(sc, vect, port); + port_write_string(port)(sc, ") )", 6, port); + }} + else + { + if (is_typed_vector(vect)) + port_write_string(port)(sc, "(let (( ", 11, port); + /* (let ((v (make-vector 3 'a symbol?))) (object->string v :readable)): "(let (( (vector 'a 'a 'a))) (set! (vector-typer ) symbol?) )" */ + + 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) /* subvector above */ + { + 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); + } + if (is_typed_vector(vect)) + { + port_write_string(port)(sc, ")) (set! (vector-typer ) ", 28, port); + port_write_vector_typer(sc, vect, port); + port_write_string(port)(sc, ") )", 6, port); + }}} + else /* not readable write */ + { + if (vector_rank(vect) > 1) /* if rank>1, ndims exists */ + { + 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); + multivector_to_port(sc, vect, port, len, 0, 0, vector_ndims(vect), 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_gc_protect(sc); +} + +static s7_int print_vector_length(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_write_t use_write) +{ + const s7_int len = vector_length(vect); + const char *vtype = "r"; /* "const" here for g++ */ + + if (is_int_vector(vect)) vtype = "i"; + else if (is_complex_vector(vect)) vtype = "c"; + else if (is_byte_vector(vect)) vtype = "u"; + if (len == 0) + { + char buf[128]; + s7_int plen; + if (vector_rank(vect) > 1) + plen = (s7_int)catstrs_direct(buf, "#", vtype, pos_int_to_str_direct(sc, vector_ndims(vect)), "d()", (const char *)(const char *)NULL); + else plen = (s7_int)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) + { + char buf[128]; + s7_int plen = (s7_int)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 + if (is_byte_vector(vect)) + port_write_string(port)(sc, "#u8(...)", 8, port); + else port_write_string(port)(sc, "#c(...)", 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 *unused_ci) +{ + s7_int plen; + bool too_long; + char buf[128]; + const char *str; + const s7_int len = print_vector_length(sc, vect, port, use_write); + if (len < 0) return; /* actually -1, see above -- this means there's nothing more to print */ + 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 i; + const s7_int vlen = vector_length(vect); + const s7_int *els = int_vector_ints(vect); + s7_int first = els[0]; + for (i = 1; i < vlen; i++) + if (els[i] != first) + break; + if (i == vlen) + { + make_vector_to_port(sc, vect, port); + str = integer_to_string(sc, int_vector(vect, 0), &plen); + port_write_string(port)(sc, str, 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)) + { + str = integer_to_string(sc, int_vector(vect, 0), &plen); + port_write_string(port)(sc, str, plen, port); + for (s7_int 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); + s7_int 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); + } + str = integer_to_string(sc, int_vector(vect, 0), &plen); + memcpy((void *)(dbuf + new_len), (const void *)str, plen); + new_len += plen; + for (s7_int 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 + { + 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); + gc_protect_via_stack(sc, vect); + multivector_to_port(sc, vect, port, len, 0, 0, vector_ndims(vect), p_display, NULL); + unstack_gc_protect(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 *unused_ci) +{ + #define FV_BUFSIZE 512 /* some floats can take around 312 bytes */ + char buf[FV_BUFSIZE]; + s7_int plen; + bool too_long; + const s7_double *els = float_vector_floats(vect); + const s7_int 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 i; + const s7_int vlen = vector_length(vect); + const 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 (s7_int 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 + { + 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); + gc_protect_via_stack(sc, vect); + multivector_to_port(sc, vect, port, len, 0, 0, vector_ndims(vect), p_display, NULL); + unstack_gc_protect(sc); + } + if ((use_write == p_readable) && + (is_immutable_vector(vect))) + port_write_character(port)(sc, ')', port); +} + +static char *complex_to_string_base_10(s7_scheme *sc, s7_complex obj, s7_int width, s7_int precision, + char float_choice, s7_int *nlen, use_write_t choice) +{ + char *imag; + s7_int 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; + } + sc->num_to_str[0] = '\0'; + imag = copy_string(number_to_string_base_10(sc, wrap_real(sc, cimag(obj)), 0, precision, float_choice, &len, choice)); + sc->num_to_str[0] = '\0'; + number_to_string_base_10(sc, wrap_real(sc, creal(obj)), 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) + { + 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); +} + +static void complex_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) +{ + #define CV_BUFSIZE 1024 /* some floats can take around 312 bytes */ + bool too_long; + const s7_complex *els = complex_vector_complexes(vect); + s7_int 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 i; + const s7_int vlen = vector_length(vect); + const s7_complex first = els[0]; + for (i = 1; i < vlen; i++) + if (els[i] != first) + break; + if (i == vlen) + { + s7_int plen; + char *num = complex_to_string_base_10(sc, first, 0, sc->float_format_precision, 'g', &plen, use_write); + make_vector_to_port(sc, vect, port); + port_write_string(port)(sc, num, clamp_length(plen, CV_BUFSIZE), 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) + { + s7_int plen; + char *num = complex_to_string_base_10(sc, els[0], 0, sc->float_format_precision, 'g', &plen, use_write); + port_write_string(port)(sc, "#c(", 3, port); + port_write_string(port)(sc, num, clamp_length(plen, CV_BUFSIZE), port); + for (s7_int i = 1; i < len; i++) + { + num = complex_to_string_base_10(sc, els[i], 0, sc->float_format_precision, 'g', &plen, use_write); + port_write_character(port)(sc, ' ', port); + port_write_string(port)(sc, num, clamp_length(plen, CV_BUFSIZE), port); + } + if (too_long) + port_write_string(port)(sc, " ...)", 5, port); + else port_write_character(port)(sc, ')', port); + } + else + { + char buf[CV_BUFSIZE]; + s7_int plen = catstrs_direct(buf, "#c", pos_int_to_str_direct(sc, vector_ndims(vect)), "d", (const char *)NULL); + port_write_string(port)(sc, buf, plen, port); + gc_protect_via_stack(sc, vect); + multivector_to_port(sc, vect, port, len, 0, 0, vector_ndims(vect), p_display, NULL); + unstack_gc_protect(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 *unused_ci) +{ + bool too_long; + const s7_int 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 i; + const s7_int vlen = vector_length(vect); + const uint8_t *els = byte_vector_bytes(vect); + uint8_t first = els[0]; + for (i = 1; i < vlen; i++) + if (els[i] != first) + break; + if (i == vlen) + { + s7_int plen; + const char *str; /* const for integer_to_string */ + make_vector_to_port(sc, vect, port); + str = integer_to_string(sc, byte_vector(vect, 0), &plen); /* only 0..10 start out with names: init_small_ints */ + port_write_string(port)(sc, str, 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) + { + s7_int plen; + const char *str; + port_write_string(port)(sc, "#u8(", 4, port); + str = integer_to_string(sc, byte_vector(vect, 0), &plen); + port_write_string(port)(sc, str, plen, port); + for (s7_int i = 1; i < len; i++) + { + char buf[128]; + 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 + { + char buf[128]; + s7_int plen = catstrs_direct(buf, "#u8", 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), 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 *unused_ci) +{ + bool 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)) + { + const s7_pointer c = chars[(int32_t)((uint8_t)(buf[0]))]; + const int32_t nlen = (int32_t)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((const uint8_t *)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 s7_int list_length_with_immutable_check(s7_scheme *sc, s7_pointer a, bool *immutable) +{ + s7_pointer slow = a, fast = a; + for (s7_int i = 0; ; i += 2) + { + if (!is_pair(fast)) return((is_null(fast)) ? i : -i); + if (is_immutable_pair(fast)) *immutable = true; + fast = cdr(fast); + if (!is_pair(fast)) return((is_null(fast)) ? (i + 1) : (-i - 1)); + if (is_immutable_pair(fast)) *immutable = true; + fast = cdr(fast); + slow = cdr(slow); + if (fast == slow) return(0); + } + return(0); +} + +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, bool immutable) +{ + /* the easier cases: no circles or shared refs to patch up */ + if ((true_len > 0) && (!immutable)) + { + port_write_string(port)(sc, "list", 4, port); + for (s7_pointer p = lst; is_pair(p); p = cdr(p)) + { + port_write_character(port)(sc, ' ', port); + object_to_port_with_circle_check(sc, car(p), port, p_readable, ci); + } + port_write_character(port)(sc, ')', port); + } + else + { + s7_pointer p; + s7_int immutable_ctr = 0; + if (is_immutable_pair(lst)) + { + port_write_string(port)(sc, "immutable! (cons ", 17, port); + immutable_ctr++; + } + else port_write_string(port)(sc, "cons ", 5, port); + object_to_port_with_circle_check(sc, car(lst), port, p_readable, ci); + + for (p = cdr(lst); is_pair(p); p = cdr(p)) + { + if (is_immutable_pair(p)) + { + port_write_string(port)(sc, " (immutable! (cons ", 19, port); + immutable_ctr++; + } + else port_write_string(port)(sc, " (cons ", 7, port); + object_to_port_with_circle_check(sc, car(p), port, p_readable, ci); + } + if (is_null(p)) + port_write_string(port)(sc, " ()", 3, port); + else + { + port_write_character(port)(sc, ' ', port); + object_to_port_with_circle_check(sc, p, port, p_readable, ci); + } + for (s7_int i = (true_len <= 0) ? 1 : 0; i < len; i++) + port_write_character(port)(sc, ')', port); + for (s7_int i = 0; i < immutable_ctr; i++) + 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_int len; + bool immutable = false; + const s7_int true_len = list_length_with_immutable_check(sc, lst, &immutable); + 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 = 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 = (int32_t)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_function) || (car(lst) == sc->quote_symbol)) && + (true_len == 2)) + { + const bool need_new_ci = ((!ci) && (is_pair(cadr(lst)))); + shared_info_t *new_ci = NULL, *temp_ci = NULL; + const bool old_locked = sc->object_out_locked; + /* true_len == 2 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 + */ + if (car(lst) == sc->quote_symbol) + port_write_string(port)(sc, "(quote ", 7, port); + else port_write_character(port)(sc, '\'', port); + if (need_new_ci) + { + new_ci = make_shared_info(sc); + /* clear_shared_info(new_ci); */ + temp_ci = load_shared_info(sc, cadr(lst), false, new_ci); /* temp_ci can be NULL! */ + } + else temp_ci = ci; + if (need_new_ci) sc->object_out_locked = true; + object_to_port_with_circle_check(sc, cadr(lst), port, p_write, temp_ci); + if (need_new_ci) + { + sc->object_out_locked = old_locked; + free_shared_info(new_ci); + } + if (car(lst) == sc->quote_symbol) + port_write_character(port)(sc, ')', port); + return; + } +#if WITH_IMMUTABLE_UNQUOTE + if ((car(lst) == sc->unquote_symbol) && (true_len == 2)) + { + port_write_character(port)(sc, ',', port); + object_to_port_with_circle_check(sc, cadr(lst), port, p_write, ci); + return; + } +#endif + + if (is_multiple_value(lst)) + port_write_string(port)(sc, "(values ", 8, port); + else port_write_character(port)(sc, '(', port); + + if (use_write == p_readable) + { + if (!is_cyclic(lst)) + { + /* here (and in the cyclic case) we need to handle immutable pairs -- this requires using cons rather than list etc */ + simple_list_readable_display(sc, lst, true_len, len, port, ci, immutable); + return; + } + if (ci) + { + int32_t plen; + s7_pointer p, local_port; + char buf[128], lst_name[128]; + bool lst_local = false; + int32_t lst_ref = peek_shared_ref(ci, lst); + if (lst_ref == 0) + { + 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, immutable); + 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 */ + } + p = lst; + for (s7_int i = 0; (i < len) && (is_pair(p)); p = cdr(p), i++) + { + if ((has_structure(car(p))) && + (is_cyclic(car(p)))) + port_write_string(port)(sc, " #f", 3, port); + else + { + port_write_character(port)(sc, ' ', port); + object_to_port_with_circle_check(sc, car(p), port, use_write, ci); + } + if ((is_pair(cdr(p))) && + (peek_shared_ref(ci, cdr(p)) != 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 `(p . 1) (signature (int-vector))) :readable) */ + p = lst; + for (s7_int i = 0; (i < len) && (is_pair(p)); p = cdr(p), i++) + { + int32_t lref; + if ((has_structure(car(p))) && + (is_cyclic(car(p)))) + { + if (i == 0) + plen = (int32_t)catstrs_direct(buf, " (set-car! ", lst_name, " ", (const char *)NULL); + else plen = (int32_t)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(p)); + if (lref == 0) + object_to_port_with_circle_check(sc, car(p), local_port, use_write, ci); + else + { + if (lref < 0) lref = -lref; + plen = (int32_t)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(p))) && + ((lref = peek_shared_ref(ci, cdr(p))) != 0)) + { + if (lref < 0) lref = -lref; + if (i == 0) + plen = (int32_t)catstrs_direct(buf, (lst_local) ? " " : " ", + "(set-cdr! ", lst_name, " <", pos_int_to_str_direct(sc, lref), ">) ", (const char *)NULL); + else + if (i == 1) + plen = (int32_t)catstrs_direct(buf, (lst_local) ? " " : " ", + "(set-cdr! (cdr ", lst_name, ") <", pos_int_to_str_direct(sc, lref), ">) ", (const char *)NULL); + else plen = (int32_t)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_p; + for (end_p = lst; is_pair(end_p); end_p = cdr(end_p)); /* or maybe faster, start at p? */ + /* we can't depend on the loops above to set p to the last element because they sometimes break out */ + if (true_len == -1) /* cons cell */ + plen = (int32_t)catstrs_direct(buf, (lst_local) ? " " : " ", "(set-cdr! ", lst_name, " ", (const char *)NULL); + else + if (true_len == -2) + plen = (int32_t)catstrs_direct(buf, (lst_local) ? " " : " ", "(set-cdr! (cdr ", lst_name, ") ", (const char *)NULL); + else plen = (int32_t)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_p, 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, immutable); + } + else /* not :readable */ + { + const s7_int 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 */ + return; + } + if (ci) + { + s7_pointer p; + s7_int i; + for (p = lst, i = 0; (is_pair(p)) && (i < plen) && ((i == 0) || (peek_shared_ref(ci, p) == 0)); i++, p = cdr(p)) + { + ci->ctr++; + if (ci->ctr > sc->print_length) + { + port_write_string(port)(sc, " ...)", 5, port); + return; + } + object_to_port_with_circle_check(sc, car(p), port, not_p_display(use_write), ci); + if (i < (len - 1)) + port_write_character(port)(sc, ' ', port); + } + if (is_not_null(p)) + { + 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, p, port, not_p_display(use_write), ci); + }} + port_write_character(port)(sc, ')', port); + } + else + { + s7_pointer p = lst; + const s7_int len1 = plen - 1; + if (is_string_port(port)) + { + for (s7_int i = 0; (is_pair(p)) && (i < len1); i++, p = cdr(p)) + { + object_to_port(sc, car(p), port, not_p_display(use_write), ci); + if (port_position(port) >= sc->objstr_max_len) + 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 (s7_int i = 0; (is_pair(p)) && (i < len1); i++, p = cdr(p)) + { + object_to_port(sc, car(p), port, not_p_display(use_write), ci); /* lst free here if unprotected */ + port_write_character(port)(sc, ' ', port); + } + if (is_pair(p)) + { + object_to_port(sc, car(p), port, not_p_display(use_write), ci); + p = cdr(p); + } + if (is_not_null(p)) + { + if (plen < len) + port_write_string(port)(sc, " ...", 4, port); + else + { + port_write_string(port)(sc, ". ", 2, port); + object_to_port(sc, p, port, not_p_display(use_write), ci); + }} + port_write_character(port)(sc, ')', port); + }} +} + +s7_pointer find_closure(s7_scheme *sc, s7_pointer closure, s7_pointer current_let); + +s7_pointer find_typer(s7_scheme *sc, s7_pointer typer) +{ + s7_pointer sym = find_closure(sc, typer, closure_let(typer)); + if (!is_symbol(sym)) + sym = find_closure(sc, typer, sc->curlet); + return(sym); +} + +const char *hash_table_typer_name(s7_scheme *sc, s7_pointer typer) +{ + if (is_c_function(typer)) return(c_function_name(typer)); + if (is_boolean(typer)) return("#t"); +#if S7_DEBUGGING /* I don't think this happens anymore */ + if (typer == sc->unused) + { + fprintf(stderr, "%s[%d]: hash typer is #\n", __func__, __LINE__); + return("#"); /* mapper can be sc->unused briefly -- where? */ + } +#endif + { + s7_pointer sym = find_typer(sc, typer); + return((is_symbol(sym)) ? symbol_name(sym) : NULL); /* see below in hash_table_procedures_to_port */ + } +} + +static void hash_typers_to_port(s7_scheme *sc, s7_pointer hash, s7_pointer port) +{ + if (((is_typed_hash_table(hash)) || (is_pair(hash_table_procedures(hash)))) && + ((!is_boolean(hash_table_key_typer(hash))) || (!is_boolean(hash_table_value_typer(hash))))) + { + const char *typer = hash_table_typer_name(sc, hash_table_key_typer(hash)); + port_write_string(port)(sc, " (cons ", 7, port); + port_write_string(port)(sc, typer, safe_strlen(typer), port); + port_write_character(port)(sc, ' ', port); + typer = hash_table_typer_name(sc, hash_table_value_typer(hash)); + port_write_string(port)(sc, typer, safe_strlen(typer), port); + port_write_string(port)(sc, "))", 2, port); + } + else port_write_character(port)(sc, ')', port); +} + +static void hash_table_procedures_to_port(s7_scheme *sc, s7_pointer hash, s7_pointer port, bool closed, shared_info_t *ci) +{ + const char *typer = hash_table_checker_name(sc, hash); + if ((closed) && (is_immutable_hash_table(hash))) + port_write_string(port)(sc, "(immutable! ", 12, port); + + if (typer[0] == '#') /* #f */ + { + if (is_pair(hash_table_procedures(hash))) + { + s7_int nlen = 0; + const char *str = (const char *)integer_to_string(sc, hash_table_size(hash), &nlen); + const char *checker = hash_table_typer_name(sc, hash_table_procedures_checker(hash)); + const char *mapper = hash_table_typer_name(sc, hash_table_procedures_mapper(hash)); + if (is_weak_hash_table(hash)) + port_write_string(port)(sc, "(make-weak-hash-table ", 22, port); + else port_write_string(port)(sc, "(make-hash-table ", 17, port); + port_write_string(port)(sc, str, nlen, port); + if ((checker) && (mapper)) + { + if ((is_boolean(hash_table_procedures_checker(hash))) && (is_boolean(hash_table_procedures_mapper(hash)))) + port_write_string(port)(sc, " #f", 3, port); /* no checker/mapper set? */ + else + { + port_write_string(port)(sc, " (cons ", 7, port); + port_write_string(port)(sc, checker, safe_strlen(checker), port); + port_write_character(port)(sc, ' ', port); + port_write_string(port)(sc, mapper, safe_strlen(mapper), port); + port_write_character(port)(sc, ')', port); + }} + else + if ((is_any_closure(hash_table_procedures_checker(hash))) || + (is_any_closure(hash_table_procedures_mapper(hash)))) + { + port_write_string(port)(sc, " (cons ", 7, port); + if (is_any_closure(hash_table_procedures_checker(hash))) + object_to_port_with_circle_check(sc, hash_table_procedures_checker(hash), port, p_readable, ci); + else port_write_string(port)(sc, checker, safe_strlen(checker), port); + port_write_character(port)(sc, ' ', port); + if (is_any_closure(hash_table_procedures_mapper(hash))) + object_to_port_with_circle_check(sc, hash_table_procedures_mapper(hash), port, p_readable, ci); + else port_write_string(port)(sc, mapper, safe_strlen(mapper), port); + port_write_character(port)(sc, ')', port); + } + else port_write_string(port)(sc, " #f", 3, port); /* no checker/mapper set? */ + hash_typers_to_port(sc, hash, port); + } + else + 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); + } + else + { + s7_int nlen = 0; + const char *str = integer_to_string(sc, hash_table_size(hash), &nlen); + if (is_weak_hash_table(hash)) + port_write_string(port)(sc, "(make-weak-hash-table ", 22, port); + else port_write_string(port)(sc, "(make-hash-table ", 17, port); + port_write_string(port)(sc, str, nlen, port); + port_write_character(port)(sc, ' ', port); + port_write_string(port)(sc, typer, safe_strlen(typer), port); + hash_typers_to_port(sc, hash, port); + } + if (is_immutable_hash_table(hash)) + port_write_character(port)(sc, ')', port); +} + +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 gc_iter, len = hash_table_entries(hash); + bool too_long = false, hash_cyclic = false, copied = false, immut = false, letd = false; + s7_pointer iterator; + int32_t href = -1; + + if (len == 0) + { + if (use_write == p_readable) + hash_table_procedures_to_port(sc, hash, port, true, ci); + else + { + 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 = 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); + iterator_carrier(iterator) = cons_unchecked(sc, sc->F, sc->F); + set_has_carrier(iterator); + hash_cyclic = ((ci) && (is_cyclic(hash)) && ((href = peek_shared_ref(ci, hash)) != 0)); + + if (use_write == p_readable) + { + if ((is_typed_hash_table(hash)) || (is_pair(hash_table_procedures(hash))) || (hash_chosen(hash))) + { + port_write_string(port)(sc, "(let (( ", 11, port); + letd = true; + } + else + if ((is_immutable_hash_table(hash)) && (!hash_cyclic)) + { + port_write_string(port)(sc, "(immutable! ", 12, port); + immut = true; + }} + + if ((use_write == p_readable) && + (hash_cyclic)) + { + if (href < 0) href = -href; + if ((!is_typed_hash_table(hash)) && (!is_pair(hash_table_procedures(hash))) && (!hash_chosen(hash))) + { + 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 */ + } + else + { + hash_table_procedures_to_port(sc, hash, port, true, ci); + port_write_character(port)(sc, ')', port); + } + + /* output here is deferred via ci->cycle_port until later in cyclic_out */ + for (s7_int i = 0; i < len; i++) + { + const s7_pointer key_val = hash_table_iterate(sc, iterator); + if (key_val == sc->iterator_at_end_value) break; /* key_val can be # if hash is a weak-hash-table, and a GC happens during this loop */ + { + const s7_pointer key = car(key_val); + const s7_pointer val = cdr(key_val); + char buf[128]; + int32_t eref = peek_shared_ref(ci, val); + int32_t kref = peek_shared_ref(ci, key); + int32_t 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 + { + if (((!is_typed_hash_table(hash)) && (!is_pair(hash_table_procedures(hash))) && (!hash_chosen(hash))) || (use_write != p_readable)) + { + 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); + } + else + { + hash_table_procedures_to_port(sc, hash, port, true, ci); + port_write_character(port)(sc, ')', port); + port_write_string(port)(sc, ") (copy (hash-table", 19, port); + copied = true; + } + for (s7_int i = 0; i < len; i++) + { + const s7_pointer key_val = hash_table_iterate(sc, iterator); + if (key_val == sc->iterator_at_end_value) break; /* key_val can be # if hash is a weak-hash-table, and a GC happens during this loop */ + port_write_character(port)(sc, ' ', port); + if ((use_write != p_readable) && (use_write != p_code) && (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 (use_write != p_readable) + { + if (too_long) + port_write_string(port)(sc, " ...)", 5, port); + else port_write_character(port)(sc, ')', port); + }} + + if (use_write == p_readable) + { + if (copied) + { + if (!letd) + { + char buf[128]; + int32_t plen = catstrs_direct(buf, ") <", pos_int_to_str_direct(sc, href), ">", (const char *)NULL); + port_write_string(port)(sc, buf, plen, port); + } + else port_write_string(port)(sc, ") ))", 7, port); + } + else + if (letd) + port_write_string(port)(sc, ") )", 6, port); + else port_write_character(port)(sc, ')', port); + + if ((is_immutable_hash_table(hash)) && (!hash_cyclic) && (!is_typed_hash_table(hash))) + port_write_character(port)(sc, ')', port); + + if ((!immut) && (is_immutable_hash_table(hash)) && (!hash_cyclic)) + port_write_string(port)(sc, ") (immutable! ))", 19, port); + } + s7_gc_unprotect_at(sc, gc_iter); + iterator_carrier(iterator) = sc->nil; +} + +static void slot_list_to_port(s7_scheme *sc, s7_pointer slot, s7_pointer port, shared_info_t *ci, bool bindings) /* bindings=let/inlet choice */ +{ + bool first_time = true; + for (; is_not_slot_end(slot); slot = next_slot(slot)) + { + if (bindings) + { + if (first_time) + { + port_write_character(port)(sc, '(', port); + first_time = false; + } + else port_write_string(port)(sc, " (", 2, port); + } + else port_write_character(port)(sc, ' ', port); + symbol_to_port(sc, slot_symbol(slot), port, (bindings) ? p_display : p_key, NULL); /* (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) +{ + bool first_time = true; + for (; is_not_slot_end(slot); slot = next_slot(slot)) + { + const s7_pointer sym = slot_symbol(slot), val = slot_value(slot); + if (bindings) + { + if (first_time) + { + port_write_character(port)(sc, '(', port); + first_time = false; + } + else port_write_string(port)(sc, " (", 2, port); + } + else port_write_character(port)(sc, ' ', port); + symbol_to_port(sc, sym, port, (bindings) ? p_display : p_key, NULL); + if (has_structure(val)) + { + char buf[128]; + int32_t symref; + int32_t len = catstrs_direct(buf, " (set! (<", pos_int_to_str_direct(sc, -peek_shared_ref(ci, obj)), "> ", (const char *)NULL); + port_write_string(port)(sc, " #f", 3, port); + port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); + symbol_to_port(sc, sym, ci->cycle_port, p_key, NULL); + + 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 = 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) +{ + for (s7_pointer slot = let_slots(obj); is_not_slot_end(slot); slot = next_slot(slot)) + if ((slot_has_setter(slot)) || (is_immutable_slot(slot))) + return(true); + return(false); +} + +static bool slot_setters_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, shared_info_t *ci) +{ + bool spaced_out = false; + for (s7_pointer slot = let_slots(obj); is_not_slot_end(slot); slot = next_slot(slot)) + if (slot_has_setter(slot)) + { + if (spaced_out) port_write_character(port)(sc, ' ', port); else spaced_out = true; + port_write_string(port)(sc, "(set! (setter '", 15, port); + symbol_to_port(sc, slot_symbol(slot), port, p_display, NULL); + 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); + } + return(spaced_out); +} + +static void immutable_slots_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, bool spaced_out) +{ + for (s7_pointer slot = let_slots(obj); is_not_slot_end(slot); slot = next_slot(slot)) + if (is_immutable_slot(slot)) + { + if (spaced_out) port_write_character(port)(sc, ' ', port); else spaced_out = true; + port_write_string(port)(sc, "(immutable! '", 13, port); + symbol_to_port(sc, slot_symbol(slot), port, p_display, NULL); + port_write_character(port)(sc, ')', 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, NULL); + port_write_character(port)(sc, ' ', port); + object_to_port_with_circle_check(sc, slot_value(obj), port, use_write, ci); +} + +static void internal_slot_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci) +{ + /* here we're displaying a slot in the debugger -- T_SLOT objects are not directly accessible in scheme */ + port_write_string(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 let points to (say) method list, the object needs to specialize object->string itself */ + if ((!sc->short_print) && (has_active_methods(sc, obj))) /* short_print 14-Dec-24 from stacktrace (see below) */ + { + const s7_pointer print_func = find_method(sc, obj, sc->object_to_string_symbol); + if (print_func != sc->undefined) + { + s7_pointer str; + /* what needs to be protected here? for one, the function might not return a string! */ + + clear_has_methods(obj); + if ((use_write == p_write) || (use_write == p_code)) + str = s7_apply_function(sc, print_func, set_plist_1(sc, obj)); + else str = s7_apply_function(sc, print_func, set_plist_2(sc, obj, (use_write == p_display) ? sc->F : sc->readable_keyword)); + set_has_methods(obj); + + if ((is_string(str)) && + (string_length(str) > 0)) + port_write_string(port)(sc, string_value(str), string_length(str), port); + return; + }} + if (obj == sc->rootlet) {port_write_string(port)(sc, "(rootlet)", 9, port); return;} + if (obj == sc->starlet) {port_write_string(port)(sc, "*s7*", 4, port); return;} + /* if (is_unlet(obj)) {port_write_string(port)(sc, "(unlet)", 7, port); return;} */ /* this is the let created by (unlet), not sc->unlet_entries */ + if (sc->short_print) {port_write_string(port)(sc, "#", 6, port); return;} + + /* circles can happen here: (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 = (int32_t)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->rootlet) + { + char buf[128]; + int32_t len = (int32_t)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 (is_openlet(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)) /* both explicit setters and immutable slots */ + { + 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); + immutable_slots_to_port(sc, obj, 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 (is_openlet(obj)) + port_write_character(port)(sc, ')', port); + } + else + { + if (is_openlet(obj)) + port_write_string(port)(sc, "(openlet ", 9, port); + if (is_immutable_let(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); + immutable_slots_to_port(sc, obj, 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->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 = (int32_t)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 = let_ref_p_pp(sc, obj, sc->class_name_symbol); + if (is_symbol(name)) + symbol_to_port(sc, name, port, p_display, NULL); + 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_let(obj)) + port_write_character(port)(sc, ')', port); + if (is_openlet(obj)) + port_write_character(port)(sc, ')', port); + }} + else /* not readable write */ + { + s7_pointer slot = let_slots(obj); + port_write_string(port)(sc, "(inlet", 6, port); + for (int32_t i = 1; is_not_slot_end(slot); i++, slot = next_slot(slot)) + { + port_write_character(port)(sc, ' ', port); + slot_to_port(sc, slot, port, use_write, ci); + if ((is_not_slot_end(next_slot(slot))) && (i == sc->print_length)) + { + port_write_string(port)(sc, " ...", 4, port); + break; + }} + port_write_character(port)(sc, ')', port); + } +} + +static void write_macro_readably(s7_scheme *sc, s7_pointer obj, s7_pointer port) +{ + const s7_pointer body = closure_body(obj), parlist = closure_pars(obj); + /* this doesn't handle recursive macros well -- we need letrec or the equivalent as in write_closure_readably */ + /* (letrec ((m2 (macro (x) `(if (> ,x 0) (m2 (- ,x 1)) 32)))) (object->string m2 :readable)) */ + + 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(parlist)) + { + port_write_character(port)(sc, ' ', port); + port_write_string(port)(sc, symbol_name(parlist), symbol_name_length(parlist), port); + port_write_character(port)(sc, ' ', port); + } + else + if (is_pair(parlist)) + { + s7_pointer pars; + port_write_string(port)(sc, " (", 2, port); + for (pars = parlist; is_pair(pars); pars = cdr(pars)) + { + object_to_port(sc, car(pars), port, p_write, NULL); + if (is_pair(cdr(pars))) + port_write_character(port)(sc, ' ', port); + } + if (!is_null(pars)) + { + port_write_string(port)(sc, " . ", 3, port); + object_to_port(sc, pars, port, p_write, NULL); + } + port_write_string(port)(sc, ") ", 2, port); + } + else port_write_string(port)(sc, " () ", 4, port); + + for (s7_pointer 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(const s7_pointer symbol, s7_pointer let) +{ + for (s7_pointer le = let; le; le = let_outlet(le)) + for (s7_pointer slot = let_slots(le); is_not_slot_end(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == symbol) + return(slot); + return(NULL); +} + +static bool slot_memq(const s7_pointer symbol, s7_pointer symbols) +{ + for (s7_pointer syms = symbols; is_pair(syms); syms = cdr(syms)) + if (slot_symbol(car(syms)) == symbol) + return(true); + return(false); +} + +static bool arg_memq(const s7_pointer symbol, s7_pointer args) +{ + for (s7_pointer p = args; is_pair(p); p = cdr(p)) + if ((car(p) == symbol) || + ((is_pair(car(p))) && + (caar(p) == symbol))) + return(true); + return(false); +} + +static void collect_symbol(s7_scheme *sc, s7_pointer sym, s7_pointer let, 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 = match_symbol(sym, let); + 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 let, s7_pointer args, s7_int gc_loc) /* currently called only in write_closure_readably */ +{ + if (is_unquoted_pair(sc, body)) + { + collect_locals(sc, car(body), let, args, gc_loc); + collect_locals(sc, cdr(body), let, args, gc_loc); + } + else + if (is_symbol(body)) + collect_symbol(sc, body, let, args, gc_loc); +} + +static void collect_specials(s7_scheme *sc, s7_pointer let, s7_pointer args, s7_int gc_loc) +{ + collect_symbol(sc, sc->local_signature_symbol, let, args, gc_loc); + collect_symbol(sc, sc->local_setter_symbol, let, args, gc_loc); + collect_symbol(sc, sc->local_documentation_symbol, let, args, gc_loc); + collect_symbol(sc, sc->local_iterator_symbol, let, args, gc_loc); +} + +s7_pointer find_closure(s7_scheme *sc, s7_pointer closure, s7_pointer current_let) +{ + for (s7_pointer let = current_let; let; let = let_outlet(let)) + { + if ((is_funclet(let)) || (is_maclet(let))) + { + s7_pointer sym = funclet_function(let); + s7_pointer func = s7_symbol_local_value(sc, sym, let); + if (func == closure) + return(sym); + } + for (s7_pointer slot = let_slots(let); is_not_slot_end(slot); slot = next_slot(slot)) + if (slot_value(slot) == closure) + return(slot_symbol(slot)); + } + 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 sym = find_closure(sc, closure, closure_let(closure)); + if (is_symbol(sym)) + { + port_write_string(port)(sc, symbol_name(sym), symbol_name_length(sym), port); + return; + }} + switch (type(closure)) + { + case T_CLOSURE: port_write_string(port)(sc, "#", 3, port); + else + { + s7_pointer pars = closure_pars(closure); + if (is_symbol(pars)) + { + port_write_string(port)(sc, symbol_name(pars), symbol_name_length(pars), port); + port_write_character(port)(sc, '>', port); /* (lambda a a) -> # */ + } + else + { + s7_pointer sym = car(pars); + if (is_pair(sym)) sym = car(sym); + port_write_character(port)(sc, '(', port); + port_write_string(port)(sc, symbol_name(sym), symbol_name_length(sym), port); + if (!is_null(cdr(pars))) + { + s7_pointer par; + port_write_character(port)(sc, ' ', port); + if (is_pair(cdr(pars))) + { + par = cadr(pars); + if (is_pair(par)) + par = car(par); + else + if (par == sc->rest_keyword) + { + port_write_string(port)(sc, ":rest ", 6, port); + pars = cdr(pars); + par = cadr(pars); + if (is_pair(par)) par = car(par); + }} + else + { + port_write_string(port)(sc, ". ", 2, port); + par = cdr(pars); + } + port_write_string(port)(sc, symbol_name(par), symbol_name_length(par), port); + if ((is_pair(cdr(pars))) && + (!is_null(cddr(pars)))) + port_write_string(port)(sc, " ...", 4, port); + } + port_write_string(port)(sc, ")>", 2, port); + }} +} + +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 sym = find_closure(sc, closure, sc->curlet); + if (is_symbol(sym)) + return(sym); + 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 void write_closure_readably_1(s7_scheme *sc, s7_pointer obj, s7_pointer arglist, s7_pointer body, s7_pointer port) +{ + const s7_int old_print_length = sc->print_length; + + 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->temp7 = (is_null(cdr(arglist))) ? set_plist_2(sc, car(arglist), sc->allow_other_keys_keyword) : + ((is_null(cddr(arglist))) ? set_plist_3(sc, car(arglist), cadr(arglist), sc->allow_other_keys_keyword) : + pair_append(sc, arglist, list_1(sc, sc->allow_other_keys_keyword))); + object_to_port(sc, sc->temp7, port, p_write, NULL); + sc->temp7 = sc->unused; + } + else object_to_port(sc, arglist, port, p_write, NULL); /* here we just want the straight output (a b) not (list 'a 'b) */ + + sc->print_length = 1048576; + for (s7_pointer 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) +{ + const s7_pointer body = closure_body(obj); + s7_pointer parlist = closure_pars(obj); + s7_pointer pe, local_slots, setter = NULL, obj_slot = NULL; + s7_int gc_loc; + bool sent_let = false, sent_letrec = false; + + if (sc->safety > no_safety) + { + if (tree_is_cyclic(sc, body)) + { + port_write_string(port)(sc, "#", 41, port); /* not s7_error here! */ + return; + } + if ((!ci) && (is_pair(parlist))) + { /* (format #f "~W" (make-hook (let ((cp (list 1))) (set-cdr! cp cp) (list 'quote cp)))) */ + shared_info_t *new_ci = make_shared_info(sc); + clear_shared_info(new_ci); + if (collect_shared_info(sc, new_ci, parlist, false)) + { + free_shared_info(new_ci); + port_write_string(port)(sc, "#", 51, port); /* not s7_error here! */ + return; + } + free_shared_info(new_ci); + }} + if (is_symbol(parlist)) parlist = set_dlist_1(sc, parlist); + pe = closure_let(obj); + + gc_loc = gc_protect_1(sc, sc->nil); + collect_locals(sc, body, pe, parlist, gc_loc); /* collect locals used only here (and below) */ + collect_specials(sc, pe, parlist, gc_loc); + + if (s7_is_dilambda(obj)) + { + setter = closure_setter(obj); + if (has_closure_let(setter)) /* collect args etc so need the parameter list */ + { + parlist = closure_pars(setter); + if (is_symbol(parlist)) parlist = set_dlist_1(sc, parlist); + collect_locals(sc, closure_body(setter), pe, parlist, gc_loc); + }} + + local_slots = T_Lst(gc_protected_at(sc, gc_loc)); /* possibly a list of slots */ + if (!is_null(local_slots)) + { + /* if (let|letrec ((f (lambda () f))) (object->string f :readable)), local_slots: ('f f) */ + /* but we can't handle it below because that leads to an infinite loop */ + for (s7_pointer slots = local_slots; is_pair(slots); slots = cdr(slots)) + { + const s7_pointer slot = car(slots); + 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))) + { + if (!sent_let) + { + port_write_string(port)(sc, "(let (", 6, port); + sent_let = true; + } + 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(slots))) + port_write_character(port)(sc, ')', port); + else port_write_string(port)(sc, ") ", 2, port); + }} + if (sent_let) port_write_string(port)(sc, ") ", 2, port); + } + + /* now we need to know if obj is in the closure_let via letrec, and if so, send out letrec+obj name+def below, then close it with obj-name?? + * the two cases are: (let ((f (lambda () f)))...) which is ok now, and (letrec ((f (lambda () f)))...) which needs the letrec + */ + if (!is_null(local_slots)) + for (s7_pointer slots = local_slots; is_pair(slots); slots = cdr(slots)) + { + const s7_pointer slot = car(slots); + if ((is_any_closure(slot_value(slot))) && + (slot_value(slot) == obj)) + { + port_write_string(port)(sc, "(letrec ((", 10, port); /* (letrec ((f (lambda () f))) f) */ + sent_letrec = true; + port_write_string(port)(sc, symbol_name(slot_symbol(slot)), symbol_name_length(slot_symbol(slot)), port); + port_write_character(port)(sc, ' ', port); + obj_slot = slot; + break; + }} + + if (setter) + port_write_string(port)(sc, "(dilambda ", 10, port); + write_closure_readably_1(sc, obj, closure_pars(obj), body, port); + if (setter) + { + port_write_character(port)(sc, ' ', port); + if (has_closure_let(setter)) + write_closure_readably_1(sc, setter, closure_pars(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 (sent_letrec) + { + port_write_string(port)(sc, ")) ", 3, port); + port_write_string(port)(sc, symbol_name(slot_symbol(obj_slot)), symbol_name_length(slot_symbol(obj_slot)), port); + port_write_character(port)(sc, ')', port); + } + if (sent_let) + port_write_character(port)(sc, ')', port); + s7_gc_unprotect_at(sc, gc_loc); +} + +static void iterator_hash_table_to_port(s7_scheme *sc, s7_pointer port, s7_pointer table) +{ + if (is_weak_hash_table(table)) + port_write_string(port)(sc, "(make-iterator (weak-hash-table))", 33, port); + else port_write_string(port)(sc, "(make-iterator (hash-table))", 28, port); +} + +static void iterator_to_port(s7_scheme *sc, s7_pointer iter, s7_pointer port, use_write_t use_write, shared_info_t *ci) +{ + if (use_write == p_readable) + { + if (iterator_is_at_end(iter)) + { + switch (type(iterator_sequence(iter))) + { + 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_COMPLEX_VECTOR: port_write_string(port)(sc, "(make-iterator #c())", 20, port); break; + case T_LET: port_write_string(port)(sc, "(make-iterator (inlet))", 23, port); break; + case T_HASH_TABLE: iterator_hash_table_to_port(sc, port, iterator_sequence(iter)); break; + default: + port_write_string(port)(sc, "(make-iterator ())", 18, port); + break; /* c-object?? function? */ + }} + else + { + const s7_pointer seq = iterator_sequence(iter); + int32_t iter_ref; + if ((ci) && + (is_cyclic(iter)) && + ((iter_ref = peek_shared_ref(ci, iter)) != 0)) + { + /* basically the same as c_pointer_to_port */ + if (!is_cyclic_set(iter)) + { + 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 = (int32_t)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(iter); + return; + }} + + if (is_string(seq)) + { + const s7_int len = string_length(seq) - iterator_position(iter); + if (len == 0) + port_write_string(port)(sc, "(make-iterator \"\")", 18, port); + else + { + const char *iter_str = (const char *)(string_value(seq) + iterator_position(iter)); + port_write_string(port)(sc, "(make-iterator \"", 16, port); + if (!string_needs_slashification((const uint8_t *)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(iter), port, use_write, ci); + port_write_character(port)(sc, ')', port); + } + else + { + if ((is_let(seq)) && (seq != sc->rootlet) && (seq != sc->starlet)) + { + 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 (s7_pointer slot = let_slots(seq); slot != let_iterator_slot(iter); slot = next_slot(slot)) + port_write_string(port)(sc, "(iter) ", 7, port); + port_write_string(port)(sc, "iter)", 5, port); + } + else + { + if (iterator_position(iter) > 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(iter) > 0) + { + if (iterator_position(iter) == 1) + port_write_string(port)(sc, "))) (iter) iter)", 16, port); + else + { + char str[128]; + int32_t nlen = (int32_t)catstrs_direct(str, "))) (do ((i 0 (+ i 1))) ((= i ", + pos_int_to_str_direct(sc, iterator_position(iter)), + ") 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(iter))) && (is_weak_hash_table(iterator_sequence(iter)))) + str = "weak-hash-table"; + else + if (iterator_sequence(iter) == sc->starlet) + str = "*s7*"; + else str = type_name(sc, iterator_sequence(iter), no_article); + port_write_string(port)(sc, "#', port); + } +} + +static void c_pointer_to_port(s7_scheme *sc, s7_pointer cptr, s7_pointer port, use_write_t use_write, shared_info_t *ci) +{ + #define CP_BUFSIZE 128 + char buf[CP_BUFSIZE]; + int32_t nlen; + if (use_write == p_readable) + { + int32_t ref; + if ((ci) && + (is_cyclic(cptr)) && + ((ref = peek_shared_ref(ci, cptr)) != 0)) + { + port_write_string(port)(sc, "#f", 2, port); + if (!is_cyclic_set(cptr)) + { + 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(cptr)); + port_write_string(ci->init_port)(sc, buf, nlen, ci->init_port); + + if ((c_pointer_type(cptr) != sc->F) || + (c_pointer_info(cptr) != sc->F)) + { + flip_ref(ci, c_pointer_type(cptr)); + + port_write_character(ci->init_port)(sc, ' ', ci->init_port); + object_to_port_with_circle_check(sc, c_pointer_type(cptr), ci->init_port, use_write, ci); + + flip_ref(ci, c_pointer_type(cptr)); + flip_ref(ci, c_pointer_info(cptr)); + + port_write_character(ci->init_port)(sc, ' ', ci->init_port); + object_to_port_with_circle_check(sc, c_pointer_info(cptr), ci->init_port, use_write, ci); + + flip_ref(ci, c_pointer_info(cptr)); + } + port_write_string(ci->init_port)(sc, "))\n", 3, ci->init_port); + set_cyclic_set(cptr); + }} + else + { + nlen = snprintf(buf, CP_BUFSIZE, "(c-pointer %" p64, (intptr_t)c_pointer(cptr)); + port_write_string(port)(sc, buf, clamp_length(nlen, CP_BUFSIZE), port); + if ((c_pointer_type(cptr) != sc->F) || + (c_pointer_info(cptr) != sc->F)) + { + port_write_character(port)(sc, ' ', port); + object_to_port_with_circle_check(sc, c_pointer_type(cptr), port, use_write, ci); + port_write_character(port)(sc, ' ', port); + object_to_port_with_circle_check(sc, c_pointer_info(cptr), port, use_write, ci); + } + port_write_character(port)(sc, ')', port); + }} + else + { + if ((is_symbol(c_pointer_type(cptr))) && + (symbol_name_length(c_pointer_type(cptr)) < (CP_BUFSIZE / 2))) + nlen = snprintf(buf, CP_BUFSIZE, "#<%s %p>", symbol_name(c_pointer_type(cptr)), c_pointer(cptr)); + else nlen = snprintf(buf, CP_BUFSIZE, "#", c_pointer(cptr)); + port_write_string(port)(sc, buf, clamp_length(nlen, CP_BUFSIZE), port); + } +} + +static void random_state_to_port(s7_scheme *sc, s7_pointer rs, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) +{ + #define B_BUFSIZE 128 + char buf[B_BUFSIZE]; + int32_t nlen; + if (use_write == p_readable) + nlen = snprintf(buf, B_BUFSIZE, "(random-state %" PRIu64 " %" PRIu64 ")", random_seed(rs), random_carry(rs)); + else nlen = snprintf(buf, B_BUFSIZE, "#", random_seed(rs), random_carry(rs)); + port_write_string(port)(sc, buf, clamp_length(nlen, B_BUFSIZE), port); +} + +static void display_fallback(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci) +{ +#if S7_DEBUGGING + print_debugging_state(sc, obj, port); +#else + if (is_free(obj)) + port_write_string(port)(sc, "", 12, port); + else port_write_string(port)(sc, "", 17, port); +#endif +} + +static void unique_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_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 *unused_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 *unused_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 unused_obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_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 unused_use_write, shared_info_t *unused_ci) +{ + /* killer overhead here; breaking it into named/unnamed funcs helps only slightly -- still ridiculous overhead according to callgrind */ + const s7_int num = integer(obj); + if ((num < 10) && (num >= 0)) + { + static const char *ones[10] = {"0", "1", "2", "3", "4", "5", "6", "7", "8", "9"}; + if (is_string_port(port)) + { + if (port_position(port) + 1 < port_data_size(port)) + { + memcpy((void *)(port_data(port) + port_position(port)), (void *)ones[num], 1); + port_position(port) += 1; + } + else string_write_string_resized(sc, ones[num], 1, port); + } + else port_write_string(port)(sc, ones[num], 1, port); + } + else + { + s7_int nlen = 0; + const char *str = integer_to_string(sc, integer(obj), &nlen); + port_write_string(port)(sc, str, nlen, port); + } +} + +static void number_to_port(s7_scheme *sc, s7_pointer num, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) +{ + s7_int nlen = 0; + char *str = number_to_string_base_10(sc, num, 0, sc->float_format_precision, 'g', &nlen, use_write); /* was 14 */ + port_write_string(port)(sc, str, nlen, port); +} + + +static void syntax_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci) +{ + if (is_initial_value(obj)) + port_write_string(port)(sc, "#_", 2, port); + port_display(port)(sc, symbol_name(syntax_symbol(obj)), port); +} + +static void character_to_port(s7_scheme *sc, s7_pointer c, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) +{ + if (use_write == p_display) + port_write_unicode_char(sc, character(c), port); + else port_write_string(port)(sc, character_name(c), character_name_length(c), port); +} + +static void closure_to_port(s7_scheme *sc, s7_pointer func, s7_pointer port, use_write_t use_write, shared_info_t *ci) +{ + if (has_active_methods(sc, func)) + { + /* 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. + */ + const s7_pointer print_func = find_method(sc, closure_let(func), sc->object_to_string_symbol); + if (print_func != sc->undefined) + { + s7_pointer str = s7_apply_function(sc, print_func, set_plist_1(sc, func)); + if (string_length(str) > 0) + port_write_string(port)(sc, string_value(str), string_length(str), port); + return; + }} + if (use_write == p_readable) + write_closure_readably(sc, func, port, ci); + else write_closure_name(sc, func, port); +} + +static void macro_to_port(s7_scheme *sc, s7_pointer func, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) +{ + if (has_active_methods(sc, func)) + { + const s7_pointer print_func = find_method(sc, closure_let(func), sc->object_to_string_symbol); + if (print_func != sc->undefined) + { + s7_pointer str = s7_apply_function(sc, print_func, set_plist_1(sc, func)); + if (string_length(str) > 0) + port_write_string(port)(sc, string_value(str), string_length(str), port); + return; + }} + if (use_write == p_readable) + write_macro_readably(sc, func, port); + else write_closure_name(sc, func, port); +} + +static void c_function_to_port(s7_scheme *sc, s7_pointer func, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) +{ /* includes c_function_star, so c_function_symbol can't be used */ + const s7_int len = c_function_name_length(func); + + if (is_string_port(port)) /* expand port_write_string -> string_write_string, 15 in tauto */ + { + if (len > 0) + { + if (port_position(port) + len + 2 < port_data_size(port)) + { + if (is_initial_value(func)) + port_write_string(port)(sc, "#_", 2, port); + memcpy((void *)(port_data(port) + port_position(port)), (const void *)c_function_name(func), len); + port_position(port) += len; + } + else string_write_string_resized(sc, c_function_name(func), len, port); + } + else port_write_string(port)(sc, "#", 13, port); + } + else + if (len > 0) + { + if (is_initial_value(func)) + port_write_string(port)(sc, "#_", 2, port); + port_write_string(port)(sc, c_function_name(func), len, port); + } + else port_write_string(port)(sc, "#", 13, port); +} + +static void c_macro_to_port(s7_scheme *sc, s7_pointer func, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci) +{ + if (c_macro_name_length(func) > 0) + { + if (is_initial_value(func)) + port_write_string(port)(sc, "#_", 2, port); + port_write_string(port)(sc, c_macro_name(func), c_macro_name_length(func), port); + } + else port_write_string(port)(sc, "#", 10, port); +} + +/* (eval-string (object->string (call-with-exit (lambda (go) go)) :readable)) should at least be readable if use_write == p_readable, + * but the normal form "#" gives a read-error due to the embedded space. So if :readable, we return "#" which + * isn't going to do "the right thing", but at least it doesn't raise a read-error. + */ + + +static void goto_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_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, "#', port); +} + +static void dynamic_wind_to_port(s7_scheme *sc, s7_pointer unused_obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_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 = ((*(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)) /* plist here and below can clobber args if SHOW_EVAL_ARGS */ + { + set_mlist_2(sc, obj, (use_write == p_readable) ? sc->readable_keyword : ((use_write == p_write) ? sc->T : sc->F)); + port_display(port)(sc, s7_string((*(c_object_to_string(sc, obj)))(sc, sc->mlist_2)), 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))) + { + int32_t href; + const s7_pointer old_w = sc->w; + const s7_pointer obj_list = ((*(c_object_to_list(sc, obj)))(sc, set_mlist_1(sc, obj))); + sc->w = obj_list; + if ((ci) && + (is_cyclic(obj)) && + ((href = peek_shared_ref(ci, obj)) != 0)) + { + s7_pointer p = obj_list; + if (href < 0) href = -href; + if ((ci->defined[href]) || (port == ci->cycle_port)) + { + char buf[128]; + int32_t 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 (int32_t i = 0; is_pair(p); i++, p = cdr(p)) + { + s7_pointer val = car(p); + if (has_structure(val)) + { + char buf[128]; + int32_t symref; + int32_t len = (int32_t)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(port)(sc, " #f", 3, port); + 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 = (int32_t)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 (s7_pointer p = obj_list; is_pair(p); p = cdr(p)) + { + s7_pointer 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 stack_to_port(s7_scheme *sc, const s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci) +{ + if (obj == sc->stack) + port_write_string(port)(sc, "#", 16, port); + else port_write_string(port)(sc, "#", 8, port); +} + +void init_display_functions(void) +{ + for (int32_t i = 0; i < 256; i++) display_functions[i] = display_fallback; + display_functions[T_BACRO] = macro_to_port; + display_functions[T_BACRO_STAR] = macro_to_port; + display_functions[T_BOOLEAN] = unique_to_port; + display_functions[T_BYTE_VECTOR] = byte_vector_to_port; + display_functions[T_CATCH] = catch_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_COMPLEX] = number_to_port; + display_functions[T_COMPLEX_VECTOR] = complex_vector_to_port; + display_functions[T_CONTINUATION] = continuation_to_port; + display_functions[T_COUNTER] = counter_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_OBJECT] = c_object_to_port; + display_functions[T_C_POINTER] = c_pointer_to_port; + display_functions[T_C_RST_NO_REQ_FUNCTION] = c_function_to_port; + display_functions[T_DYNAMIC_WIND] = dynamic_wind_to_port; + display_functions[T_EOF] = eof_to_port; + display_functions[T_FLOAT_VECTOR] = float_vector_to_port; + display_functions[T_GOTO] = goto_to_port; + display_functions[T_HASH_TABLE] = hash_table_to_port; + display_functions[T_INPUT_PORT] = input_port_to_port; + display_functions[T_INTEGER] = integer_to_port; + display_functions[T_INT_VECTOR] = int_vector_to_port; + display_functions[T_ITERATOR] = iterator_to_port; + display_functions[T_LET] = let_to_port; + display_functions[T_MACRO] = macro_to_port; + display_functions[T_MACRO_STAR] = macro_to_port; + display_functions[T_NIL] = unique_to_port; + display_functions[T_OUTPUT_PORT] = output_port_to_port; + display_functions[T_PAIR] = pair_to_port; + display_functions[T_RANDOM_STATE] = random_state_to_port; + display_functions[T_RATIO] = number_to_port; + display_functions[T_REAL] = number_to_port; + display_functions[T_SLOT] = internal_slot_to_port; + display_functions[T_STACK] = stack_to_port; + display_functions[T_STRING] = string_to_port; + display_functions[T_SYMBOL] = symbol_to_port; + display_functions[T_SYNTAX] = syntax_to_port; + display_functions[T_UNDEFINED] = undefined_to_port; + display_functions[T_UNSPECIFIED] = unique_to_port; + display_functions[T_UNUSED] = unique_to_port; + display_functions[T_VECTOR] = vector_to_port; +} + +static void object_to_port_with_circle_check_1(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci) +{ + const int32_t ref = (is_collected(obj)) ? shared_ref(ci, obj) : 0; + if (ref == 0) + object_to_port(sc, obj, port, use_write, ci); + else + { + char buf[32]; + int32_t nlen; + if (ref > 0) + { + if (use_write == p_readable) + { + if (ci->defined[ref]) + { + flip_ref(ci, obj); + nlen = (int32_t)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, obj, port, p_readable, ci); + } + else + { /* "normal" printout involving #n= and #n# */ + s7_int len = 0; + char *p = pos_int_to_str(sc, (s7_int)ref, &len, '='); + *--p = '#'; + port_write_string(port)(sc, p, len, port); + object_to_port(sc, obj, port, not_p_display(use_write), ci); + }} + else + if (use_write == p_readable) + { + nlen = (int32_t)catstrs_direct(buf, "<", pos_int_to_str_direct(sc, -ref), ">", (const char *)NULL); + port_write_string(port)(sc, buf, nlen, port); + } + else + { + s7_int len = 0; + char *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 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 (int32_t 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 = (int32_t)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 = (int32_t)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_Pos(obj), strport, choice, sc->circle_info); + else + { + shared_info_t *ci = load_shared_info(sc, T_Pos(obj), choice != p_readable, sc->circle_info); + 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, T_Pos(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); +} + +s7_pointer s7i_object_out(s7_scheme *sc, s7_pointer obj, s7_pointer port, s7i_use_write_t choice) +{ + return object_out(sc, obj, port, (use_write_t)choice); +} + + /* -------------------------------- newline -------------------------------- */ void s7_newline(s7_scheme *sc, s7_pointer port) diff --git a/TeXmacs/plugins/goldfish/src/s7_scheme_write.h b/TeXmacs/plugins/goldfish/src/s7_scheme_write.h index b2513439a6..305afffb8f 100644 --- a/TeXmacs/plugins/goldfish/src/s7_scheme_write.h +++ b/TeXmacs/plugins/goldfish/src/s7_scheme_write.h @@ -11,10 +11,35 @@ #include "s7.h" +#include +#include + #ifdef __cplusplus extern "C" { #endif +/* cycles / shared-info: circular reference detection for the printer */ +struct shared_info; +int32_t shared_ref(struct shared_info *ci, s7_pointer p); +void flip_ref(struct shared_info *ci, s7_pointer p); +int32_t peek_shared_ref_1(struct shared_info *ci, s7_pointer p); +int32_t peek_shared_ref(struct shared_info *ci, s7_pointer p); +void enlarge_shared_info(struct shared_info *ci); +struct shared_info *make_shared_info(s7_scheme *sc); +void free_shared_info(struct shared_info *ci); +struct shared_info *clear_shared_info(struct shared_info *ci); +struct shared_info *load_shared_info(s7_scheme *sc, s7_pointer top, bool stop_at_print_length, struct shared_info *ci); +bool collect_shared_info(s7_scheme *sc, struct shared_info *ci, s7_pointer top, bool stop_at_print_length); +s7_pointer cyclic_sequences_p_p(s7_scheme *sc, s7_pointer obj); + +/* object->port printer: entries used by s7.c */ +int32_t circular_list_entries(s7_pointer lst); +s7_pointer find_closure(s7_scheme *sc, s7_pointer closure, s7_pointer current_let); +s7_pointer find_typer(s7_scheme *sc, s7_pointer typer); +const char *hash_table_typer_name(s7_scheme *sc, s7_pointer typer); +s7_pointer closure_name(s7_scheme *sc, s7_pointer closure); +void init_display_functions(void); + /* Public API implementations */ void s7_newline(s7_scheme *sc, s7_pointer port); s7_pointer s7_write(s7_scheme *sc, s7_pointer obj, s7_pointer port); diff --git a/TeXmacs/plugins/html/progs/convert/data/css.scm b/TeXmacs/plugins/html/progs/convert/data/css.scm deleted file mode 100644 index ae45554c37..0000000000 --- a/TeXmacs/plugins/html/progs/convert/data/css.scm +++ /dev/null @@ -1,72 +0,0 @@ - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : css.scm -;; DESCRIPTION : tools for manipulation of CSS attributes -;; COPYRIGHT : (C) 2020 Joris van der Hoeven -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (convert data css) - (:use (convert data sxml))) - -(define (css-style-item->pair s) - (with l (string-tokenize-by-char s #\:) - (and (== (length l) 2) - (cons (tm-string-trim-both (car l)) - (tm-string-trim-both (cadr l)))))) - -(define (css-style->assoc s) - (let* ((l1 (string-tokenize-by-char s #\;)) - (l2 (map css-style-item->pair l1))) - (list-filter l2 (lambda (x) x)))) - -(define (pair->css-style-item p) - (string-append (car p) ": " (cdr p))) - -(define (assoc->css-style a) - (with l (map pair->css-style-item a) - (string-recompose l "; "))) - -(define (css-max l1 l2) - (if (and (length? l1) (length? l2)) - (length-max l1 l2) - l2)) - -(define (css-add l1 l2) - (if (and (length? l1) (length? l2)) - (length-add l1 l2) - l2)) - -(define (assoc-change a k v) - (cond ((null? a) a) - ((== (caar a) k) (cons (cons k v) (cdr a))) - (else (cons (car a) (assoc-change (cdr a) k v))))) - -(define (css-merge-attrs a1 a2) - (cond ((null? a1) a2) - ((not (assoc-ref a2 (caar a1))) - (cons (car a1) (css-merge-attrs (cdr a1) a2))) - ((in? (caar a1) '("margin-top" "margin-bottom" - "padding-top" "padding-bottom")) - (let* ((k (caar a1)) - (v (css-max (assoc-ref a1 k) (assoc-ref a2 k))) - (a2* (assoc-change a2 k v))) - (css-merge-attrs (cdr a1) a2*))) - ((in? (caar a1) '("margin-left" "margin-right" - "padding-left" "padding-right")) - (let* ((k (caar a1)) - (v (css-add (assoc-ref a1 k) (assoc-ref a2 k))) - (a2* (assoc-change a2 k v))) - (css-merge-attrs (cdr a1) a2*))) - (else (cons (car a1) (css-merge-attrs (cdr a1) a2))))) - -(tm-define (css-merge-styles s1 s2) - (let* ((a1 (css-style->assoc s1)) - (a2 (css-style->assoc s2)) - (a (css-merge-attrs a1 a2))) - (assoc->css-style a))) diff --git a/TeXmacs/plugins/html/progs/convert/data/sxhtml.scm b/TeXmacs/plugins/html/progs/convert/data/sxhtml.scm deleted file mode 100644 index 863426acf3..0000000000 --- a/TeXmacs/plugins/html/progs/convert/data/sxhtml.scm +++ /dev/null @@ -1,275 +0,0 @@ - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : sxhtml.scm -;; DESCRIPTION : Utilities for HTML in SXML format -;; COPYRIGHT : (C) 2002 David Allouche -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (convert data sxhtml) - (:use (convert data sxml))) - -;; TODO: rewrite the predicates using DRD -;; TODO: consolidate with htmltm dispatch DRD - -;; Is the node x a HTML element whose name is a given set? -;; (tm-define sxhtml-heading? (ntype-names?? '(h:h1 h:h2 h:h3 h:h4 h:h5 h:h6))) -;; NOTE: outcommented in order to keep inline nature of h5 and h6 -(tm-define sxhtml-heading? (ntype-names?? '(h:h1 h:h2 h:h3 h:h4))) -(tm-define sxhtml-list? (ntype-names?? '(h:ul h:ol h:dl))) -(tm-define sxhtml-table? (ntype-names?? '(h:table))) - -(tm-define (sxhtml-label? x) - ;; Is the node x a h:a element with an id attribute? - (and (sxml-element? x) - (eq? 'h:a (sxml-name x)) - (sxml-attr x 'id))) - -(tm-define (sxhtml-glue-label x label) - ;; Set the id attribute of element x from the id of element label. - (sxml-set-attr x (list 'id (sxml-attr label 'id)))) - -(define table-kid? - (ntype-names?? '(h:tr h:td h:th h:col h:colgroup h:tbody h:thead h:tfoot))) -(define row-group-kid? (ntype-names?? '(h:tr h:td h:th))) -(define row-group? (ntype-names?? '(h:tbody h:thead h:tfoot))) -(define tfoot? (ntype-names?? '(h:tfoot))) -(define col-data? (ntype-names?? '(h:col h:colgroup))) -(define row? (ntype-names?? '(h:tr))) -(define cell? (ntype-names?? '(h:td h:th))) - -(define (shtml-attr-number as name) - (and-let* ((x (shtml-attr-non-null as name))) - (string->number x))) - -(define (shtml-attr-positive-integer as name) - (and-let* ((n (shtml-attr-number as name))) - (if (< n 0) #f (inexact->exact n)))) - -(tm-define (shtml-decode-span as name) - ;; FIXME: zero spans (until end of group) are not supported - (let ((n (shtml-attr-positive-integer as name))) - (cond ((not n) 1) ((zero? n) 1) (else n)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Correct invalid element nesting in HTML tables -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; A correct TABLE contains only COL, COLGROUP, THEAD, TFOOT and TBODY -;; elements. THEAD, TFOOT and TBODY (row groups) contains only TR elements. TR -;; elements contain only TD elements. -;; -;; Correcting a table is inferring TBODY and TR elements when they are missing -;; and filtering illegal nodes out. -;; -;; TODO: filter contents of COLGROUP elements. - -(tm-define (sxhtml-correct-table x) - ;; Correct all TABLEs in postorder in the sxml tree @x. - (let sub ((x x)) - (cond ((sxhtml-table? x) - (correct-table (sxml-set-content x (map sub (sxml-content x))))) - ((sxml-element? x) - (sxml-set-content x (map sub (sxml-content x)))) - (else x)))) - -(define (correct-table e) - ;; @e must be a h:table element (ns-prefixes must be normalized) - ;; Make TBODY elements explicit. - ;; Collect lone TD elements in TR. - ;; Drop table data not in TD. - (correct-table-content e table-kid? - (lambda (tr tbody) (cons `(h:tr ,@tr) tbody)) - (lambda (tbody kdr) (cons `(h:tbody ,@tbody) kdr)))) - -(define (correct-row-group e) - ;; Collect lone TD elements in TR inside of @e. - ;; Drop table data not in TD. - (correct-table-content e row-group-kid? - (lambda (tr tbody) (cons `(h:tr ,@tr) tbody)) - (lambda (tbody kdr) tbody))) - -(define (correct-row e) - ;; Drop everything but TD elements. - (sxml-set-content e (list-filter (sxml-content e) cell? ))) - -(define (correct-table-content e accept? make-tr make-tbody) - (sxml-set-content - e ((cut <> #f) (list-fold-right - (lambda (kar kdr) (kdr kar)) - (cut correct-table-content/step - accept? make-tr make-tbody <> '() '() '()) - (sxml-content e))))) - -(define (correct-table-content/step accept? cons-tr cons-tbody - kar tr tbody kdr) - (define (state kar tr tbody kdr) - (correct-table-content/step accept? cons-tr cons-tbody kar tr tbody kdr)) - (define (flush-tr curry-tbody-kdr) - ;; curry-tbody-kdr: (proc tbody -> state) - ;; curries @proc like (cut proc <> tbody kdr) with an updated @tbody. - (curry-tbody-kdr (cut state <> '() <> <>) - (if (null? tr) tbody (cons-tr tr tbody)))) - (define (flush-tbody curry-kdr) - ;; curry-kdr: (proc kdr -> state) - ;; curries @proc like (cut proc <> kdr) with an updated @kdr. - (flush-tr - (lambda (proc tbody) - (curry-kdr (cut proc <> '() <>) - (if (null? tbody) kdr (cons-tbody tbody kdr)))))) - (cond ((not kar) (flush-tbody (lambda (proc kdr) kdr))) - ((not (accept? kar)) (cut state <> tr tbody kdr)) - ((cell? kar) (cut state <> (cons kar tr) tbody kdr)) - ((row? kar) - (flush-tr (lambda (proc tbody) - (cut proc <> (cons (correct-row kar) tbody) kdr)))) - ((row-group? kar) - (flush-tbody (lambda (proc kdr) - (cut proc <> (cons (correct-row-group kar) kdr))))) - ((col-data? kar) - (flush-tbody (lambda (proc kdr) (cut proc <> (cons kar kdr))))) - ;; no "else" clause needed (assuming @accept is correct) - )) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Table iterator -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Iterating over cells of a table while maintaining the coordinates of the -;; current cell is a complex operation because table positions which are -;; covered by spanned cells are not represented by cell elements in HTML. -;; Also, the TFOOT element is present before TBODY element but is logically -;; located at the end of the table. - -;;;; MISSING FEATURE ;;;; -;; HTML-4.01 says that ROWSPAN=0 or COLSPAN=0 spans the cell to the end of its -;; containing group (colgroup, tbody, thead, tfoot). However, neither -;; Mozilla-1.4 nor Konqueror 3.1.3 implement this part of the specification. -;; Since this feature also requires a significant added complexity, it is left -;; out. - -(tm-define (sxhtml-table-fold kons knil table) - ;; Fundamental HTML table content iterator. - ;; knil: T - ;; kons: symbol (int @i) (int @j) sxml T -> T - ;; table: sxml - ;; Fold @kons over elements of @table, with (@i @j) the cell position. - ;; - ;; @kons is applied in the following modes: - ;; Entering a row-group : (kons :in-row-group i #f row-group kdr) - ;; Entering a row : (kons :in-row i #f row kdr) - ;; (possible extension: entering a colgroup and iterating over a col) - ;; Leaving a row-group : (kons :out-row-group nrows #f #f kdr) - ;; Leaving a row : (kons :out-row #f ncols #f kdr) - ;; Iterating over a cell : (kons :cell i j cell kdr) - ((cut <> #f) (list-fold (lambda (kar kdr) (kdr kar)) - (cut table-fold/table <> 0 '() '() kons knil) - (sxml-content table)))) - -(define (table-fold/table kar i rowspans footers kons kdr) - ;; @kar is a child element of the TABLE element. - (cond ((not kar) - (if (not footers) kdr - ((cut <> #f) - (list-fold (lambda (kar kdr) (kdr kar)) - (cut table-fold/table <> i rowspans #f kons kdr) - (reverse! footers))))) - ((and footers (tfoot? kar)) - (cut table-fold/table <> i rowspans (cons kar footers) kons kdr)) - ((row-group? kar) - ((cut <> #f) - (list-fold (lambda (kar kdr) (kdr kar)) - (cut table-fold/group <> i i rowspans footers kons - (kons :in-row-group i #f kar kdr)) - (sxml-content kar)))) - ;; ELSE clause for col-data elements. - ;; NOTE: could be extended to support parsing of col-data - (else (cut table-fold/table <> i rowspans footers kons kdr)))) - -(define (table-fold/group kar i0 i rowspans footers kons kdr) - ;; @kar is a child element of a THEAD, TBODY or TFOOT element. - (cond ((not kar) (cut table-fold/table <> i rowspans footers kons - (kons :out-row-group (- i i0) #f #f kdr))) - ((row? kar) - ((cut <> #f) - (list-fold (lambda (kar kdr) (kdr kar)) - (cut table-fold/row <> i0 i 0 rowspans footers kons - (kons :in-row i #f kar kdr)) - (sxml-content kar)))) - ;; ELSE clause should never be reached (the table is corrected). - (else (cut table-fold/group <> i0 i rowspans footers kons kdr)))) - -(define (table-fold/row kar i0 i j rowspans footers kons kdr) - ;; @kar is a child element of a TR element. - (cond ((not kar) - (cut table-fold/group <> i0 (1+ i) (next-rowspans rowspans) footers - kons (kons :out-row #f (skip-spanned-cols j rowspans) #f kdr))) - ((cell? kar) - (let ((j (skip-spanned-cols j rowspans)) - (a (sxml-attr-list kar))) - (let ((rspan (shtml-decode-span a 'rowspan)) - (cspan (shtml-decode-span a 'colspan))) - (cut table-fold/row <> i0 i (+ j cspan) - (if (= 1 rspan) rowspans - (add-rowspan rowspans j rspan cspan)) - footers kons (kons :cell i j kar kdr))))) - ;; ELSE clause should never be reached (the table is corrected). - (else (cut table-fold/row <> i0 i j rowspans footers kons kdr)))) - -;(set-trace-level! sxhtml-table-fold -; table-fold/table table-fold/group table-fold/row) - -;; Columns on which a cell is spanned are remember in a sorted ROWSPANS list. -;; Items of ROWSPANS are lists (J SPAN) where: -;; J : column number (zero-based). ROWSPANS is sorted by ascending J. -;; SPAN : count of additional rows (incl. the current row) where this column -;; is occupied by a spanned cell. - -(define (skip-spanned-cols j rowspans) - (let next ((j j) (rowspans rowspans)) - (cond ((null? rowspans) j) - ((< j (first (car rowspans))) j) - ((= j (first (car rowspans))) (next (1+ j) (cdr rowspans))) - (else (next j (cdr rowspans)))))) - -(define (add-rowspan rowspans j rspan cspan) - (let next ((rowspans rowspans) (j j) (cspan cspan)) - (cond ((zero? cspan) rowspans) - ((null? rowspans) - (cons (list j rspan) (next '() (1+ j) (1- cspan)))) - ((< j (first (car rowspans))) - (cons (list j rspan) (next rowspans (1+ j) (1- cspan)))) - ((= j (first (car rowspans))) - ;; This can only happen with some very vicious incorrect HTML. - (cons (list j (max rspan (second (car rowspans)))) - (next (cdr rowspans) (1+ j) (1- cspan)))) - (else (cons (car rowspans) - (next (cdr rowspans) (1+ j) (1- cspan))))))) - -(define (next-rowspans rowspans) - (reverse! (list-fold (lambda (kar kdr) - (with (col old-span) kar - (let ((span (1- old-span))) - (if (zero? span) - kdr - (cons (list col span) kdr))))) - '() rowspans))) - -;(set-trace-level! skip-spanned-cols add-rowspan next-rowspans) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Table iterator applications -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(tm-define (sxhtml-table-dimension table) - (sxhtml-table-fold - (lambda (msg i j kar kdr) - (with (nrows ncols) kdr - (list (if (eq? msg :out-row-group) (+ nrows i) nrows) - (if (eq? msg :out-row) (max ncols j) ncols)))) - '(0 0) table)) diff --git a/TeXmacs/plugins/html/progs/convert/data/sxml.scm b/TeXmacs/plugins/html/progs/convert/data/sxml.scm deleted file mode 100644 index c069b3acc7..0000000000 --- a/TeXmacs/plugins/html/progs/convert/data/sxml.scm +++ /dev/null @@ -1,199 +0,0 @@ - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : sxml.scm -;; DESCRIPTION : XML data as S-expressions -;; COPYRIGHT : (C) 2002 David Allouche -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (convert data sxml)) - -(define (as-string s) - (cond ((symbol? s) (symbol->string s)) - ((number? s) (number->string s)) - ((string? s) s) - (else ""))) - -;; Fundamental acessors -(tm-define sxml-name car) -(define sxml-attr-list! cdadr) - -(tm-define (sxml-has-attr-list? e) - ;; Has the element e an attribute node? - (and (pair? (cdr e)) - (pair? (cadr e)) - (eq? '@ (caadr e)))) - -(tm-define (sxml-element-head e) - ;; Element name and attributes (if present). - (if (sxml-has-attr-list? e) - (list (car e) (cadr e)) - (list (car e)))) - -(tm-define (sxml-content e) - ;; Complement function of sxml-element-head. - (if (sxml-has-attr-list? e) (cddr e) (cdr e))) - -(tm-define (sxml-set-name e name) - ;; Set the name of the sxml element e. - ;; Name is the new element name as a string. - (cons (string->symbol name) (cdr e))) - -(tm-define (sxml-set-content e content) - ;; Replace the subnodes of e with the node-set content. - (append (sxml-element-head e) content)) - -(tm-define (sxml-prepend e l) - ;; Prepend a node set l to the content of an element e. - (append (sxml-element-head e) l - (sxml-content e))) - -(define (sxml-attr-list? e) - ;; Return the attribute list of element e or #f. - (and (sxml-has-attr-list? e) - (sxml-attr-list! e))) - -(tm-define (sxml-attr-list e) - ;; Return the attribute list of element e or empty list. - (or (sxml-attr-list? e) '())) - -(tm-define (shtml-attr-non-null as att) - ;; Get an HTML attribute or false if the attribute is absent, is not set, or - ;; is set to the empty string. - ;; FIXME: this is ugly - (and-let* ((l (assoc att as)) - ((list-length=2? l)) - ((not (string-null? (second l))))) - (second l))) - -(define (sxml-named-attr obj attr-name) - ;; Named attribute of element e or #f. - (and-let* ((l (sxml-attr-list? obj))) - (assq attr-name l))) - -(tm-define (sxml-attr obj attr-name) - ;; Value of a named attribute of element e or #f. - (and-let* ((x (sxml-named-attr obj attr-name))) - (cadr x))) - -(tm-define (sxml-set-attr e attr) - ;; Set an attribute of an element e. Attr is a list (symbol? string?). - ;; Create the attribute list or the attribute if necessary. - (let ((attr-name (car attr))) - `(,(sxml-name e) - (@ ,attr ,@(list-filter (sxml-attr-list e) - (lambda (x) (not (eq? x attr-name))))) - ,@(sxml-content e)))) - -(tm-define (sxml-set-attrs e attrs) - ;; Set several attributes of an element e. Attrs is a list of attributes. - ;; Create the attribute list or attributes if necessary. - (let rec ((e e) (attrs attrs)) - (if (null? attrs) e - (rec (sxml-set-attr e (car attrs)) (cdr attrs))))) - -(tm-define (sxml-set-attrlist e attrs) - ;; Replace the attribute list of @obj by @attrs. - ;; If @attrs is #f, remove the attribute node. - `(,(sxml-name e) - ,@(if attrs `((@ ,@attrs)) '()) - ,@(sxml-content e))) - -(define-macro (sxml-find-name-separator len) - ;; optimized (string-rindex name #\:) - ;; returns position of a separator between namespace-id and LocalName - ;; (copied from sxml-tools) - `(let rpt ((pos (1- ,len))) - (cond - ((negative? pos) #f) - ((char=? #\: (string-ref name pos)) pos) - (else (rpt (1- pos)))))) - -(tm-define (sxml-ncname obj) - ;; Returns Local Part of Qualified Name (Namespaces in XML production [6]) - ;; for given obj, which is ":"-separated suffix of its Qualified Name - ;; If a name of a node given is NCName (Namespaces in XML production [4]), - ;; then it is returned as is. - ;; Please note that while SXML name is a symbol this function returns a - ;; string. - ;; (copied from sxml-tools) - (sxml-name->ncname (sxml-name obj))) - -(tm-define (sxml-name->ncname sxml-name) - (let* ((name (as-string sxml-name)) - (len (string-length name))) - (cond - ((sxml-find-name-separator len) - => (lambda (pos) - (substring name (+ pos 1) len))) - (else name)))) - -(tm-define (sxml-name->ns-id sxml-name) - ;; Returns namespace-id part of given name, or #f if it's LocalName - ;; (copied from sxml-tools) - (let* ((name (as-string sxml-name))) - (cond - ((sxml-find-name-separator (string-length name)) - => (lambda (pos) - (substring name 0 pos))) - (else #f)))) - -(tm-define (sxml-split-name sxml-name) - (let* ((name (as-string sxml-name)) - (len (string-length name))) - (cond - ((sxml-find-name-separator len) - => (lambda (pos) - (values (substring name 0 pos) - (substring name (+ pos 1) len)))) - (else (values #f name))))) - -(tm-define (sxml-strip-ns-prefix prefix x) - ;; Remove a given namespace prefix wherever it appears in element names. - ;; Prefix must be the ns-prefix as a string, and x a document fragment. - (let rec ((x x)) - (if (string? x) x - (sxml-set-content - (if (== prefix (sxml-name->ns-id (sxml-name x))) - (sxml-set-name x (sxml-ncname x)) - x) - (map rec (sxml-content x)))))) - -(tm-define (sxml-set-ns-prefix p x) - (sxml-set-name x (string-append p ":" (sxml-ncname x)))) - -; Predicate which returns #t if is SXML element, otherwise returns #f. -; NOTE: *TOP* is a special element. All element operations are applicable. -(tm-define (sxml-element? obj) - (and (pair? obj) - (symbol? (car obj)) - (not (memq (car obj) - '(@ @@ *PI* *COMMENT* *ENTITY*))))) - -; The function ntype-names?? takes a list of acceptable node names as a -; criterion and returns a function, which, when applied to a node, -; will return #t if the node name is present in criterion list and #f -; othervise. -; ntype-names?? :: ListOfNames -> Node -> Boolean -(tm-define (ntype-names?? crit) - (lambda(node) - (and (pair? node) - (memq (car node) crit)))) - -(tm-define (sxml-control-node? x) - (and (nstring? x) - (let ((name (as-string (sxml-name x)))) - (and (string-starts? name "*") - (string-ends? name "*"))))) - -(tm-define (sxml-top-node? x) - (and (nstring? x) - (== '*TOP* (car x)))) - -(tm-define (sxml-filter-element-content l) - (list-filter l nstring?)) diff --git a/TeXmacs/plugins/html/progs/convert/html/htmlout.scm b/TeXmacs/plugins/html/progs/convert/html/htmlout.scm deleted file mode 100644 index 45935dc37f..0000000000 --- a/TeXmacs/plugins/html/progs/convert/html/htmlout.scm +++ /dev/null @@ -1,170 +0,0 @@ - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : htmlout.scm -;; DESCRIPTION : generation of Html from scheme expressions -;; COPYRIGHT : (C) 2002 Joris van der Hoeven -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (convert html htmlout) - (:use (convert tools output))) - -(define preformatted? #f) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Data -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(logic-group htmlout-big-all% - ;; Both the tag and the children are displayed in multi-line format. - html head style body table tr ul ol dl - ;; and for MathML - mtable mtr) - -(logic-group htmlout-big-tag% - ;; The tag is displayed in multi-line format. - div p li dt dd center blockquote) - -(logic-rule (htmlout-big-tag% 'x) (htmlout-big-all% 'x)) - -(define (htmlout-big-all? op) - (logic-in? op htmlout-big-all%)) - -(define (htmlout-big-tag? op) - (logic-in? op htmlout-big-tag%)) - -(define (htmlout-big? x) - (and (pair? x) - (or (htmlout-big-all? (car x)) - (and (htmlout-big-tag? (car x)) - (list-any - (lambda (x) (and (pair? x) (htmlout-big-tag? (car x)))) - (cdr x)))))) - -(define (htmlout-p-simplify? x) - ;; FIXME: font should not really be in the list here - (and (func? x 'p 1) (pair? (cadr x)) - (in? (caadr x) '(div p li dt dd center blockquote ul ol dl)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Outputting main flow -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (htmlout-indent* s plus close?) - (if (not preformatted?) - (cond ((htmlout-big-tag? s) - (output-indent plus) - (output-lf)) - ((== s 'pre) - (if (not close?) (output-lf-verbatim)))))) - -(define (htmlout-indent s plus) (htmlout-indent* s plus #f)) -(define (htmlout-indent-close s plus) (htmlout-indent* s plus #t)) - -(define (htmlout-text . ss) - (if preformatted? - (apply output-verbatim ss) - (apply output-text ss))) - -(define (htmlout-open s) - (htmlout-text "<" (symbol->string s) ">") - (htmlout-indent s 2)) - -(define (htmlout-tag x) - (if (== (cadr x) "") - (output-text " " (symbol->string (car x))) - (begin - (output-text " " (symbol->string (car x)) "=") - (output-verbatim "\"" (cadr x) "\"")))) - -(define (htmlout-open-tags s l) - (with ll (ahash-table->list (list->ahash-table l)) - (htmlout-text "<" (symbol->string s)) - (for-each htmlout-tag ll) - ;; If tag is a self-closing (void) element according to HTML5 spec, close it with "/>" - ;; "Void elements only have a start tag; end tags must not be specified for void elements." - ;; Reference: HTML5 spec, section 13.1.2 - Elements (https://html.spec.whatwg.org/multipage/syntax.html#void-elements) - (if (member s '(area base br col embed hr img input link meta source track wbr)) - (htmlout-text " />") - (htmlout-text ">")) - (htmlout-indent s 2))) - -(define (htmlout-close s) - ;; Do not close the tag if it is a self-closing (void) element - ;; Reference: HTML5 spec, section 13.1.2 - Elements (https://html.spec.whatwg.org/multipage/syntax.html#void-elements) - (if (not (member s '(area base br col embed hr img input link meta source track wbr))) - (begin - (htmlout-indent-close s -2) - (htmlout-text "string s) ">")))) - -(define (htmlout-args-sub l big?) - (if (nnull? l) - (begin - (htmlout (car l)) - (if (and big? (nnull? (cdr l))) (output-lf)) - (htmlout-args-sub (cdr l) big?)))) - -(define (htmlout-args s l) - (with big? (htmlout-big? (cons s l)) - (htmlout-args-sub l big?))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Main output routines -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (htmlout-doctype l) - (output-lf-verbatim "") ; change to HTML5 Header - (output-lf)) - -(define (htmlout x) - (cond ((string? x) (htmlout-text x)) - ((null? x) (noop)) - ((or (func? x '!concat) (func? x '*TOP*)) - (for-each htmlout (cdr x))) - ((htmlout-p-simplify? x) - (htmlout (cadr x))) - ((func? x '*PI*) - (output-lf-verbatim "string (cadr x)) " " (caddr x) "?>") - (output-lf)) - ((func? x '*DOCTYPE*) - (htmlout-doctype (cdr x))) - ((== x '(br)) - (htmlout-text "
")) - ((null? (cdr x)) - (htmlout-open (car x)) - (htmlout-close (car x))) - ((not (func? (cadr x) '@)) - (htmlout-open (car x)) - (htmlout-args (car x) (cdr x)) - (htmlout-close (car x))) - (else - (htmlout-open-tags (car x) (cdadr x)) - (update-preformatted - (cdadr x) - (cut htmlout-args (car x) (cddr x))) - (htmlout-close (car x))))) - -(define (update-preformatted atts thunk) - (let ((saved-preformatted preformatted?) - (new-preformatted - (cond ((assoc 'xml:space atts) => - (lambda (att) - (cond ((== (second att) "preserve") #t) - ((== (second att) "default") #f) - (else preformatted?)))) - (else preformatted?)))) - (if (== new-preformatted saved-preformatted) - (thunk) - (dynamic-wind - (lambda () (set! preformatted? new-preformatted)) - thunk - (lambda () (set! preformatted? saved-preformatted)))))) - -(tm-define (serialize-html x) - (htmlout x) - (output-produce)) diff --git a/TeXmacs/plugins/html/progs/convert/html/tmhtml-expand.scm b/TeXmacs/plugins/html/progs/convert/html/tmhtml-expand.scm deleted file mode 100644 index 6dae357493..0000000000 --- a/TeXmacs/plugins/html/progs/convert/html/tmhtml-expand.scm +++ /dev/null @@ -1,118 +0,0 @@ - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : tmhtml-expand.scm -;; DESCRIPTION : environment patch for expanding the document before conversion -;; COPYRIGHT : (C) 2002 Joris van der Hoeven -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (convert html tmhtml-expand)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; "identity" macros -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (tmhtml-env-macro name) - `(associate ,(symbol->string name) (xmacro "x" (eval-args "x"))) -) ;define - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Interface -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(tm-define (tmhtml-env-patch) - ;; FIXME: we should use the DRD here - `(collection ,@(map tmhtml-env-macro - '(TeXmacs TeX - LaTeX - shown - hrule - item - chapter-title - section-title - subsection-title - subsubsection-title - paragraph-title - subparagraph-title - itemize - itemize-minus - itemize-dot - itemize-arrow - enumerate - enumerate-numeric - enumerate-numeric-bracket - enumerate-numeric-paren - enumerate-roman - enumerate-roman-bracket - enumerate-roman-paren - enumerate-Roman - enumerate-alpha - enumerate-alpha-bracket - enumerate-alpha-full-paren - enumerate-Alpha - enumerate-circle - enumerate-hanzi - description - description-compact - description-dash - description-aligned - description-long - description-paragraphs - item* - strong - em - dfn - code* - samp - kbd - var - abbr - acronym - verbatim - code - tt - underline - overline - strike-through - deleted - marked - fill-out - hidden-title - doc-title-block - equation* - equation-lab - equations-base - wide-float - draw-over - draw-under - html-tag - html-attr - html-div-style - html-div-class - html-style - html-class - html-javascript - html-javascript-src - html-video - web-title - tmdoc-title - tmdoc-flag - tmdoc-license - tmdoc-title* - tmdoc-title** - tmdoc-copyright - hlink - action - hyper-link - mouse-over-balloon - mouse-over-balloon*)) - ;; FIXME: should apply 'filter_style' to the environment - ;; in an appropriate way to avoid adding the primitives below - ,@(map tmhtml-env-macro - '(shrink-inline binom tbinom dbinom choose ontop bmod pmod pod))) -) ;tm-define diff --git a/TeXmacs/plugins/html/progs/convert/mathml/mathml-drd.scm b/TeXmacs/plugins/html/progs/convert/mathml/mathml-drd.scm deleted file mode 100644 index 7639544fe9..0000000000 --- a/TeXmacs/plugins/html/progs/convert/mathml/mathml-drd.scm +++ /dev/null @@ -1,680 +0,0 @@ - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : mathml-drd.scm -;; DESCRIPTION : DRD properties for MathML -;; COPYRIGHT : (C) 2004 Joris van der Hoeven -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(texmacs-module (convert mathml mathml-drd)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Ordinary symbols -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(logic-table tm->mathml-constant% - ("" "C") - ("" "e") - ("" "&eulergamma;") - ("" "ⅈ") - ("" "π")) - -(logic-table mathml-constant->tm% - ("&eulergamma;" "") - ("ⅈ" "") - ("ⅈ" "") - ("π" "") - ("&true;" "true") - ("&false;" "false") - ("ϕ" "") - ("ℓ" "") - ("ℂ" "") - ("ℚ" "") - ("ℤ" "") - ("ℝ" "")) - -(logic-table tm->mathml-operator% - ("&" "&") - ("" "<") - ("*" "⁢") - (" " "⁡")) - -(logic-table mathml-operator->tm% - ("⁢" "*") ;U+2062 Invisible Times - ("*" "*") - ("−" "-") ;U+2212 minus - ("⃛" "") ;U+20DB - ("˚" "") - ("´" "") - ("`" "") - ("¯" "¯" ) ;U+00AF - ("‾" "¯") ; U+203E - ("̲" "¯") ;U+0332 - ("⃗" "") - ("̑" "") - ("ˇ" "") - ("˘" "") - ("⏞" "") ;U+23DE - ("︷" "") ;U+FE37 - ("⏟" "") ;U+23DE - ("︸" "") ;U+FE38 - ("⎴" "") ;U+23B4 - ("﹇" "") ;U+FE47 - ("﹈" "") ;U+FE48 - ("⎵" "") ;U+23B5 - ("⏜" "") ;U+23DC - ("︵" "") ;U+FE35 - ("⏝" "") ;U+23DD - ("︶" "") ;U+FE36 - ("︿" "^") ;U+FE3F - ("﹀" "") ;U+FE40 - - ("⁢" "*") - ("±" "") - ("⁢" "*") - ("≤" "") - ("≥" "") - ("→" "") - ("‾" "¯") - -;below a selection of html math entities (there are so many, and redundant ones) -;with unicode equivalent (data from the web), or equivalent texmacs code -;note that when Firefox saves an html file, it replaces &entities by utf8 characters -;can be a workaround for missing entities - - ("ⅆ" "") ; was ⅆ U+02146 - ("∑" "") ; was ∑ U+02211 - ("ϕ" "") ; was ϕ U+003D5 - ("∂" "") ; was ∂ U+02202 - ("⏟" "") ; was ⏟ U+023DF - ("⏞" "") ; was ⏞ U+023DE - ("ⅇ" "") ; was ⅇ U+2147 Double-Struck Italic Small E - ("+" "+") ; + U+002B Plus Sign - ("−" "-") ; − U+2212 Minus Sign - ("×" "") ; × U+00D7 Multiplication Sign - ("÷" "
") ; ÷ U+00F7 Division Sign - ("=" "=") ; = U+003D Equals Sign - ("≠" "") ; ≠ U+2260 Not Equal To - ("±" "") ; ± U+00B1 Plus minus symbol - ("¬" "") ; ¬ U+00AC Not Sign - (">" "") ; > U+003E Greater-Than Sign - ("°" "<#00B0>") ; ° U+00B0 Degree Sign - ("⋃" (big "cup")) ; ⋃ U+022C3 - ("⋂" (big "cap")) ; ⋂ U+022C2 - ("∫" (big "int")) ; ∫ U+0222B - ("ℋ" "<#210B>") ; ℋ U+210B Script Capital H - ("ℎ" "<#210E>") ; ℎ U+210E Planck Constant - ("ℏ" "") ; ℏ U+210F Planck Constant Over Two Pi - ("ℑ" "<#2111>") ; ℑ U+2111 Black-Letter Capital I - ("℘" "<#2118>") ; ℘ U+2118 Script Capital P - ("ℜ" "<#211C>") ; ℜ U+211C Black-Letter Capital R - ("℧" "<#2127>") ; ℧ U+2127 Inverted Ohm Sign - ("℩" "<#2129>") ; ℩ U+2129 Turned Greek Small Letter Iota - ("ℬ" "<#212C>") ; ℬ U+212C Script Capital B - ("ℵ" "<#2135>") ; ℵ U+2135 Alef Symbol - ("ℶ" "<#2136>") ; ℶ U+2136 Bet Symbol - ("ℷ" "<#2137>") ; ℷ U+2137 Gimel Symbol - ("ℸ" "<#2138>") ; ℸ U+2138 Dalet Symbol - ("ⅅ" "") ; ⅅ U+2145 Double-Struck Italic Capital D - ("ⅆ" "") ; ⅆ U+2146 Double-Struck Italic Small D - ("★" "<#2605>") ; ★ U+2605 Black Star - ("☆" "<#2606>") ; ☆ U+2606 White Star - ("◊" "<#25CA>") ; ◊ U+25CA Lozenge - ("♪" "<#266A>") ; ♪ U+266A Eighth Note - ("♭" "<#266D>") ; ♭ U+266D Music Flat Sign - ("♮" "<#266E>") ; ♮ U+266E Music Natural Sign - ("♯" "<#266F>") ; ♯ U+266F Music Sharp Sign - ("✓" "<#2713>") ; ✓ U+2713 Check Mark - ("✗" "<#2717>") ; ✗ U+2717 Ballot X - ("✠" "<#2720>") ; ✠ U+2720 Maltese Cross - ("✶" "<#2736>") ; ✶ U+2736 Six Pointed Black Star - ("❘" "<#2758>") ; ❘ U+2758 Light Vertical Bar - ("!" "<#0021>") ; ! U+0021 Exclamation Mark - ("#" "<#0023>") ; # U+0023 Number Sign - ("%" "<#0025>") ; % U+0025 Percent Sign - ("(" "<#0028>") ; ( U+0028 Left Parenthesis - (")" "<#0029>") ; ) U+0029 Right Parenthesis - ("*" "<#002A>") ; * U+002A Asterisk - ("," "<#002C>") ; , U+002C Comma - ("." "<#002E>") ; . U+002E Full Stop - ("/" "<#002F>") ; / U+002F Solidus - (":" "<#003A>") ; : U+003A Colon - (";" "<#003B>") ; ; U+003B Semicolon - ("?" "<#003F>") ; ? U+003F Question Mark - ("[" "<#005B>") ; [ U+005B Left Square Bracket - ("\" "<#005C>") ; \ U+005C Reverse Solidus - ("]" "<#005D>") ; ] U+005D Right Square Bracket - ("^" "<#005E>") ; ^ U+005E Circumflex Accent - ("_" "<#005F>") ; _ U+005F Low Line - ("`" "<#0060>") ; ` U+0060 Grave Accent - ("{" "<#007B>") ; { U+007B Left Curly Bracket - ("|" "<#007C>") ; | U+007C Vertical Line - ("}" "<#007D>") ; } U+007D Right Curly Bracket - ("˜" "<#007E>") ; ~ U+007E Tilde - ("ˆ" "<#02C6>") ; ˆ U+02C6 Modifier Letter Circumflex Accent - (" " "<#00A0>") ;   U+00A0 No-Break Space - (" " "<#2002>") ;   U+2002 En Space - (" " "<#2003>") ;   U+2003 Em Space - (" " "<#2009>") ;   U+2009 Thin Space - ("‌" "<#200C>") ; ‌ U+200C Zero Width Non-Joiner - ("‍" "<#200D>") ; ‍ U+200D Zero Width Joiner - ;("‎" "<#200E>") ; ‎ U+200E Left-To-Right Mark - ("¡" "<#00A1>") ; ¡ U+00A1 Inverted Exclamation Mark - ("¦" "<#00A6>") ; ¦ U+00A6 Broken Bar - ("§" "<#00A7>") ; § U+00A7 Section Sign - ("¨" "<#00A8>") ; ¨ U+00A8 Diaeresis - ("ª" "<#00AA>") ; ª U+00AA Feminine Ordinal Indicator - ("­" "<#00AD>") ; ­ U+00AD Soft Hyphen - ("¯" "<#00AF>") ; ¯ U+00AF Macron - ("´" "<#00B4>") ; ´ U+00B4 Acute Accent - ("µ" "<#00B5>") ; µ U+00B5 Micro Sign - ("¶" "<#00B6>") ; ¶ U+00B6 Pilcrow Sign - ("·" "<#00B7>") ; · U+00B7 Middle Dot - ("¸" "<#00B8>") ; ¸ U+00B8 Cedilla - ("º" "<#00BA>") ; º U+00BA Masculine Ordinal Indicator - ("¿" "<#00BF>") ; ¿ U+00BF Inverted Question Mark - ("‐" "<#2010>") ; ‐ U+2010 Hyphen - ("–" "<#2013>") ; – U+2013 En Dash - ("—" "<#2014>") ; — U+2014 Em Dash - ("―" "<#2015>") ; ― U+2015 Horizontal Bar - ("‖" "<#2016>") ; ‖ U+2016 Double Vertical Line - ("†" "<#2020>") ; † U+2020 Dagger - ("‡" "<#2021>") ; ‡ U+2021 Double Dagger - ("•" "<#2022>") ; • U+2022 Bullet - ("‥" "<#2025>") ; ‥ U+2025 Two Dot Leader - ("…" "<#2026>") ; … U+2026 Horizontal Ellipsis - ("‰" "<#2030>") ; ‰ U+2030 Per Mille Sign - ("‱" "<#2031>") ; ‱ U+2031 Per Ten Thousand Sign - ("′" "<#2032>") ; ′ U+2032 Prime - ("″" "<#2033>") ; ″ U+2033 Double Prime - ("‴" "<#2034>") ; ‴ U+2034 Triple Prime - ("‵" "<#2035>") ; ‵ U+2035 Reversed Prime - ("‾" "¯") ; ‾ U+203E Overline - ("⁁" "<#2041>") ; ⁁ U+2041 Caret Insertion Point - ("⁃" "<#2043>") ; ⁃ U+2043 Hyphen Bullet - ("⁄" "/") ; ⁄ U+2044 Fraction Slash - ("¹" "<#00B9>") ; ¹ U+00B9 Superscript One - ("²" "<#00B2>") ; ² U+00B2 Superscript Two - ("³" "<#00B3>") ; ³ U+00B3 Superscript Three - ("ƒ" "<#0192>") ; ƒ U+0192 Latin Small Letter F with Hook - ("%" "<#0025>") ; % U+0025 Percent Sign - ("‰" "<#2030>") ; ‰ U+2030 Character Tabulation with Justification - ("‱" "<#2031>") ; ‱ U+2031 Per Ten Thousand Sign - ("∀" "<#2200>") ; ∀ U+2200 For All - ("∁" "<#2201>") ; ∁ U+2201 Complement - ("∂" "") ; ∂ U+2202 Partial Differential - ("∃" "<#2203>") ; ∃ U+2203 There Exists - ("∄" "<#2204>") ; ∄ U+2204 There Does Not Exist - ("∅" "<#2205>") ; ∅ U+2205 Empty Set - ("∇" "<#2207>") ; ∇ U+2207 Nabla - ("∈" "<#2208>") ; ∈ U+2208 Element Of - ("∉" "<#2209>") ; ∉ U+2209 Not an Element Of - ("∋" "<#220B>") ; ∋ U+220B Contains As Member - ("∌" "<#220C>") ; ∌ U+220C Does Not Contain As Member - ("∏" (big "prod")) ; ∏ U+220F N-Ary Product - ("∐" (big "amalg")) ; ∐ U+2210 N-Ary Coproduct - ("∑" (big "sum")) ; ∑ U+2211 N-Ary Summation - ("∓" ) ; ∓ U+2213 Minus-or-Plus Sign - ("∖" "<#2216>") ; ∖ U+2216 Set Minus - ("∗" "<#2217>") ; ∗ U+2217 Asterisk Operator - ("∘" "") ; ∘ U+2218 Ring Operator - ("√" "<#221A>") ; √ U+221A Square Root - ("∝" "<#221D>") ; ∝ U+221D Proportional To - ("∞" "<#221E>") ; ∞ U+221E Infinity - ("∟" "<#221F>") ; ∟ U+221F Right Angle - ("∠" "<#2220>") ; ∠ U+2220 Angle - ("∣" "<#2223>") ; ∣ U+2223 Divides - ("∥" "<#2225>") ; ∥ U+2225 Parallel To - ("∧" "<#2227>") ; ∧ U+2227 Logical And - ("∨" "<#2228>") ; ∨ U+2228 Logical Or - ("∩" "<#2229>") ; ∩ U+2229 Intersection - ("∪" "<#222A>") ; ∪ U+222A Union - ("∫" "<#222B>") ; ∫ U+222B Integral - ("∬" "<#222C>") ; ∬ U+222C Double Integral - ("∭" "<#222D>") ; ∭ U+222D Triple Integral - ("∮" "<#222E>") ; ∮ U+222E Contour Integral - ("∯" "<#222F>") ; ∯ U+222F Surface Integral - ("∰" "<#2230>") ; ∰ U+2230 Volume Integral - ("∴" "<#2234>") ; ∴ U+2234 Therefore - ("∵" "<#2235>") ; ∵ U+2235 Because - ("∶" "<#2236>") ; ∶ U+2236 Ratio - ("∷" "<#2237>") ; ∷ U+2237 Proportion - ("∻" "<#223B>") ; ∻ U+223B Homothetic - ("∼" "<#223C>") ; ∼ U+223C Tilde Operator - ("∽" "<#223D>") ; ∽ U+223D Reversed Tilde - ("∾" "<#223E>") ; ∾ U+223E Inverted Lazy S - ("∿" "<#223F>") ; ∿ U+223F Sine Wave - ("≃" "<#2243>") ; ≃ U+2243 Asymptotically Equal To - ("≄" "<#2244>") ; ≄ U+2244 Not Asymptotically Equal To - ("≅" "<#2245>") ; ≅ U+2245 Approximately Equal To - ("≆" "<#2246>") ; ≆ U+2246 Approximately But Not Actually Equal To - ("≇" "<#2247>") ; ≇ U+2247 Neither Approximately nor Actually Equal To - ("≈" "<#2248>") ; ≈ U+2248 Almost Equal To - ("≉" "<#2249>") ; ≉ U+2249 Not Almost Equal To - ("≊" "<#224A>") ; ≊ U+224A Almost Equal or Equal To - ("≍" "<#224D>") ; ≍ U+224D Equivalent To - ("≎" "<#224E>") ; ≎ U+224E Geometrically Equivalent To - ("≏" "<#224F>") ; ≏ U+224F Difference Between - ("≖" "<#2256>") ; ≖ U+2256 Ring In Equal To - ("≗" "<#2257>") ; ≗ U+2257 Ring Equal To - ("≡" "<#2261>") ; ≡ U+2261 Identical To - ("≢" "<#2262>") ; ≢ U+2262 Not Identical To - ("≤" "<#2264>") ; ≤ U+2264 Less-Than or Equal To - ("≥" "<#2265>") ; ≥ U+2265 Greater-Than or Equal To - ("≦" "<#2266>") ; ≦ U+2266 Less-Than Over Equal To - ("≧" "<#2267>") ; ≧ U+2267 Greater-Than Over Equal To - ("≨" "<#2268>") ; ≨ U+2268 Less-Than But Not Equal To - ("≩" "<#2269>") ; ≩ U+2269 Greater-Than But Not Equal To - ("≪" "<#226A>") ; ≪ U+226A Much Less-Than - ("≫" "<#226B>") ; ≫ U+226B Much Greater-Than - ("≭" "<#226D>") ; ≭ U+226D Not Equivalent To - ("≮" "<#226E>") ; ≮ U+226E Not Less-Than - ("≯" "<#226F>") ; ≯ U+226F Not Greater-Than - ("≰" "<#2270>") ; ≰ U+2270 Neither Less-Than nor Equal To - ("≱" "<#2271>") ; ≱ U+2271 Neither Greater-Than nor Equal To - ("≲" "<#2272>") ; ≲ U+2272 Less-Than or Equivalent To - ("≳" "<#2273>") ; ≳ U+2273 Greater-Than or Equivalent To - ("≴" "<#2274>") ; ≴ U+2274 Neither Less-Than nor Equivalent To - ("≵" "<#2275>") ; ≵ U+2275 Neither Greater-Than nor Equivalent To - ("≺" "<#227A>") ; ≺ U+227A Precedes - ("≻" "<#227B>") ; ≻ U+227B Succeeds - ("≼" "<#227C>") ; ≼ U+227C Precedes or Equal To - ("≽" "<#227D>") ; ≽ U+227D Succeeds or Equal To - ("≾" "<#227E>") ; ≾ U+227E Precedes or Equivalent To - ("≿" "<#227F>") ; ≿ U+227F Succeeds or Equivalent To - ("⊀" "<#2280>") ; ⊀ U+2280 Does Not Precede - ("⊁" "<#2281>") ; ⊁ U+2281 Does Not Succeed - ("⊂" "<#2282>") ; ⊂ U+2282 Subset Of - ("⊃" "<#2283>") ; ⊃ U+2283 Superset Of - ("⊄" "<#2284>") ; ⊄ U+2284 Not a Subset Of - ("⊅" "<#2285>") ; ⊅ U+2285 Not a Superset Of - ("⊆" "<#2286>") ; ⊆ U+2286 Subset of or Equal To - ("⊇" "<#2287>") ; ⊇ U+2287 Superset of or Equal To - ("⊈" "<#2288>") ; ⊈ U+2288 Neither a Subset of nor Equal To - ("⊉" "<#2289>") ; ⊉ U+2289 Neither a Superset of nor Equal To - ("⊊" "<#228A>") ; ⊊ U+228A Subset of with Not Equal To - ("⊋" "<#228B>") ; ⊋ U+228B Superset of with Not Equal To - ("⊎" "<#228E>") ; ⊎ U+228E Multiset Union - ("⊏" "<#228F>") ; ⊏ U+228F Square Image Of - ("⊐" "<#2290>") ; ⊐ U+2290 Square Original Of - ("⊑" "<#2291>") ; ⊑ U+2291 Square Image of or Equal To - ("⊒" "<#2292>") ; ⊒ U+2292 Square Original of or Equal To - ("⊓" "<#2293>") ; ⊓ U+2293 Square Cap - ("⊔" "<#2294>") ; ⊔ U+2294 Square Cup - ("⊕" "<#2295>") ; ⊕ U+2295 Circled Plus - ("⊖" "<#2296>") ; ⊖ U+2296 Circled Minus - ("⊗" "<#2297>") ; ⊗ U+2297 Circled Times - ("⊘" "<#2298>") ; ⊘ U+2298 Circled Division Slash - ("⊙" "<#2299>") ; ⊙ U+2299 Circled Dot Operator - ("⊚" "<#229A>") ; ⊚ U+229A Circled Ring Operator - ("⊛" "<#229B>") ; ⊛ U+229B Circled Asterisk Operator - ("⊝" "<#229D>") ; ⊝ U+229D Circled Dash - ("⊞" "<#229E>") ; ⊞ U+229E Squared Plus - ("⊟" "<#229F>") ; ⊟ U+229F Squared Minus - ("⊠" "<#22A0>") ; ⊠ U+22A0 Squared Times - ("⊡" "<#22A1>") ; ⊡ U+22A1 Squared Dot Operator - ("⊢" "<#22A2>") ; ⊢ U+22A2 Right Tack - ("⊣" "<#22A3>") ; ⊣ U+22A3 Left Tack - ("⊤" "<#22A4>") ; ⊤ U+22A4 Down Tack - ("⊥" "<#22A5>") ; ⊥ U+22A5 Up Tack - ("⊧" "<#22A7>") ; ⊧ U+22A7 Models - ("⊨" "<#22A8>") ; ⊨ U+22A8 True - ("⊩" "<#22A9>") ; ⊩ U+22A9 Forces - ("⊪" "<#22AA>") ; ⊪ U+22AA Triple Vertical Bar Right Turnstile - ("⊰" "<#22B0>") ; ⊰ U+22B0 Precedes Under Relation - ("⊲" "<#22B2>") ; ⊲ U+22B2 Normal Subgroup Of - ("⊳" "<#22B3>") ; ⊳ U+22B3 Contains As Normal Subgroup - ("⊴" "<#22B4>") ; ⊴ U+22B4 Normal Subgroup of or Equal To - ("⊵" "<#22B5>") ; ⊵ U+22B5 Contains As Normal Subgroup or Equal To - ("⊹" "<#22B9>") ; ⊹ U+22B9 Hermitian Conjugate Matrix - ("⋀" "<#22C0>") ; ⋀ U+22C0 N-Ary Logical And - ("⋁" "<#22C1>") ; ⋁ U+22C1 N-Ary Logical Or - ("⋂" "<#22C2>") ; ⋂ U+22C2 N-Ary Intersection - ("⋃" "<#22C3>") ; ⋃ U+22C3 N-Ary Union - ("⋄" "<#22C4>") ; ⋄ U+22C4 Diamond Operator - ("⋅" "<#22C5>") ; ⋅ U+22C5 Dot Operator - ("⋆" "<#22C6>") ; ⋆ U+22C6 Star Operator - ("⋉" "<#22C9>") ; ⋉ U+22C9 Left Normal Factor Semidirect Product - ("⋊" "<#22CA>") ; ⋊ U+22CA Right Normal Factor Semidirect Product - ("⋋" "<#22CB>") ; ⋋ U+22CB Left Semidirect Product - ("⋌" "<#22CC>") ; ⋌ U+22CC Right Semidirect Product - ("⋍" "<#22CD>") ; ⋍ U+22CD Reversed Tilde Equals - ("⋎" "<#22CE>") ; ⋎ U+22CE Curly Logical Or - ("⋏" "<#22CF>") ; ⋏ U+22CF Curly Logical And - ("⋐" "<#22D0>") ; ⋐ U+22D0 Double Subset - ("⋑" "<#22D1>") ; ⋑ U+22D1 Double Superset - ("⋒" "<#22D2>") ; ⋒ U+22D2 Double Intersection - ("⋓" "<#22D3>") ; ⋓ U+22D3 Double Union - ("⋘" "<#22D8>") ; ⋘ U+22D8 Very Much Less-Than - ("⋙" "<#22D9>") ; ⋙ U+22D9 Very Much Greater-Than - ("⋞" "<#22DE>") ; ⋞ U+22DE Equal To or Precedes - ("⋟" "<#22DF>") ; ⋟ U+22DF Equal To or Succeeds - ("⋠" "<#22E0>") ; ⋠ U+22E0 Does Not Precede or Equal - ("⋡" "<#22E1>") ; ⋡ U+22E1 Does Not Succeed or Equal - ("⋢" "<#22E2>") ; ⋢ U+22E2 Not Square Image of or Equal To - ("⋣" "<#22E3>") ; ⋣ U+22E3 Not Square Original of or Equal To - ("⋦" "<#22E6>") ; ⋦ U+22E6 Less-Than But Not Equivalent To - ("⋧" "<#22E7>") ; ⋧ U+22E7 Greater-Than But Not Equivalent To - ("⋨" "<#22E8>") ; ⋨ U+22E8 Precedes But Not Equivalent To - ("⋩" "<#22E9>") ; ⋩ U+22E9 Succeeds But Not Equivalent To - ("⋪" "<#22EA>") ; ⋪ U+22EA Not Normal Subgroup Of - ("⋫" "<#22EB>") ; ⋫ U+22EB Does Not Contain As Normal Subgroup - ("⋬" "<#22EC>") ; ⋬ U+22EC Not Normal Subgroup of or Equal To - ("⋭" "<#22ED>") ; ⋭ U+22ED Does Not Contain As Normal Subgroup or Equal - ("⋮" "<#22EE>") ; ⋮ U+22EE Vertical Ellipsis - ("⋯" "<#22EF>") ; ⋯ U+22EF Midline Horizontal Ellipsis - ("⋰" "<#22F0>") ; ⋰ U+22F0 Up Right Diagonal Ellipsis - ("⋱" "<#22F1>") ; ⋱ U+22F1 Down Right Diagonal Ellipsis - ("⋲" "<#22F2>") ; ⋲ U+22F2 Element of with Long Horizontal Stroke - ("⌈" "<#2308>") ; ⌈ U+2308 Left Ceiling - ("⌉" "<#2309>") ; ⌉ U+2309 Right Ceiling - ("⌊" "<#230A>") ; ⌊ U+230A Left Floor - ("⌋" "<#230B>") ; ⌋ U+230B Right Floor - ("⟨" "<#2329>") ; 〈 U+2329 Left-Pointing Angle Bracket - ("⟩" "<#232A>") ; 〉 U+232A Right-Pointing Angle Bracket - ("Α" "<#0391>") ; Α U+0391 Greek Capital Letter Alpha - ("Β" "<#0392>") ; Β U+0392 Greek Capital Letter Beta - ("Γ" "<#0393>") ; Γ U+0393 Greek Capital Letter Gamma - ("Δ" "<#0394>") ; Δ U+0394 Greek Capital Letter Delta - ("Ε" "<#0395>") ; Ε U+0395 Greek Capital Letter Epsilon - ("Ζ" "<#0396>") ; Ζ U+0396 Greek Capital Letter Zeta - ("Η" "<#0397>") ; Η U+0397 Greek Capital Letter Eta - ("Θ" "<#0398>") ; Θ U+0398 Greek Capital Letter Theta - ("Ι" "<#0399>") ; Ι U+0399 Greek Capital Letter Iota - ("Κ" "<#039A>") ; Κ U+039A Greek Capital Letter Kappa - ("Λ" "<#039B>") ; Λ U+039B Greek Capital Letter Lamda - ("Μ" "<#039C>") ; Μ U+039C Greek Capital Letter Mu - ("Ν" "<#039D>") ; Ν U+039D Greek Capital Letter Nu - ("Ξ" "<#039E>") ; Ξ U+039E Greek Capital Letter Xi - ("Ο" "<#039F>") ; Ο U+039F Greek Capital Letter Omicron - ("Π" "<#03A0>") ; Π U+03A0 Greek Capital Letter Pi - ("Ρ" "<#03A1>") ; Ρ U+03A1 Greek Capital Letter Rho - ("Σ" "<#03A3>") ; Σ U+03A3 Greek Capital Letter Sigma - ("Τ" "<#03A4>") ; Τ U+03A4 Greek Capital Letter Tau - ("Υ" "<#03A5>") ; Υ U+03A5 Greek Capital Letter Upsilon - ("Φ" "<#03A6>") ; Φ U+03A6 Greek Capital Letter Phi - ("Χ" "<#03A7>") ; Χ U+03A7 Greek Capital Letter Chi - ("Ψ" "<#03A8>") ; Ψ U+03A8 Greek Capital Letter Psi - ("Ω" "<#03A9>") ; Ω U+03A9 Greek Capital Letter Omega - ("α" "<#03B1>") ; α U+03B1 Greek Small Letter Alpha - ("β" "<#03B2>") ; β U+03B2 Greek Small Letter Beta - ("γ" "<#03B3>") ; γ U+03B3 Greek Small Letter Gamma - ("δ" "<#03B4>") ; δ U+03B4 Greek Small Letter Delta - ("ε" "<#03B5>") ; ε U+03B5 Greek Small Letter Epsilon - ("ζ" "<#03B6>") ; ζ U+03B6 Greek Small Letter Zeta - ("η" "<#03B7>") ; η U+03B7 Greek Small Letter Eta - ("θ" "<#03B8>") ; θ U+03B8 Greek Small Letter Theta - ("ι" "<#03B9>") ; ι U+03B9 Greek Small Letter Iota - ("κ" "<#03BA>") ; κ U+03BA Greek Small Letter Kappa - ("λ" "<#03BB>") ; λ U+03BB Greek Small Letter Lamda - ("μ" "<#03BC>") ; μ U+03BC Greek Small Letter Mu - ("ν" "<#03BD>") ; ν U+03BD Greek Small Letter Nu - ("ξ" "<#03BE>") ; ξ U+03BE Greek Small Letter Xi - ("ο" "<#03BF>") ; ο U+03BF Greek Small Letter Omicron - ("ρ" "<#03C1>") ; ρ U+03C1 Greek Small Letter Rho - ("ς" "<#03C2>") ; ς U+03C2 Greek Small Letter Final Sigma - ("σ" "<#03C3>") ; σ U+03C3 Greek Small Letter Sigma - ("τ" "<#03C4>") ; τ U+03C4 Greek Small Letter Tau - ("υ" "<#03C5>") ; υ U+03C5 Greek Small Letter Upsilon - ("φ" "<#03C6>") ; φ U+03C6 Greek Small Letter Phi - ("χ" "<#03C7>") ; χ U+03C7 Greek Small Letter Chi - ("ψ" "<#03C8>") ; ψ U+03C8 Greek Small Letter Psi - ("ω" "<#03C9>") ; ω U+03C9 Greek Small Letter Omega - ("ϑ" "<#03D1>") ; ϑ U+03D1 Greek Theta Symbol - ("ϒ" "<#03D2>") ; ϒ U+03D2 Greek Upsilon with Hook Symbol - ("ϖ" "<#03D6>") ; ϖ U+03D6 Greek Pi Symbol - ("↺" "<#21BA>") ; ↺ U+21BA Anticlockwise Open Circle Arrow - ("↻" "<#21BB>") ; ↻ U+21BB Clockwise Open Circle Arrow - ("↼" "<#21BC>") ; ↼ U+21BC Leftwards Harpoon with Barb Upwards - ("↽" "<#21BD>") ; ↽ U+21BD Leftwards Harpoon with Barb Downwards - ("↾" "<#21BE>") ; ↾ U+21BE Upwards Harpoon with Barb Rightwards - ("↿" "<#21BF>") ; ↿ U+21BF Upwards Harpoon with Barb Leftwards - ("⇀" "<#21C0>") ; ⇀ U+21C0 Rightwards Harpoon with Barb Upwards - ("⇁" "<#21C1>") ; ⇁ U+21C1 Rightwards Harpoon with Barb Downwards - ("⇂" "<#21C2>") ; ⇂ U+21C2 Downwards Harpoon with Barb Rightwards - ("⇃" "<#21C3>") ; ⇃ U+21C3 Downwards Harpoon with Barb Leftwards - ("⇄" "<#21C4>") ; ⇄ U+21C4 Rightwards Arrow Over Leftwards Arrow - ("⇅" "<#21C5>") ; ⇅ U+21C5 Upwards Arrow Leftwards of Downwards Arrow - ("⇆" "<#21C6>") ; ⇆ U+21C6 Leftwards Arrow Over Rightwards Arrow - ("⇇" "<#21C7>") ; ⇇ U+21C7 Leftwards Paired Arrows - ("⇈" "<#21C8>") ; ⇈ U+21C8 Upwards Paired Arrows - ("⇉" "<#21C9>") ; ⇉ U+21C9 Rightwards Paired Arrows - ("⇊" "<#21CA>") ; ⇊ U+21CA Downwards Paired Arrows - ("⇋" "<#21CB>") ; ⇋ U+21CB Leftwards Harpoon Over Rightwards Harpoon - ("⇌" "<#21CC>") ; ⇌ U+21CC Rightwards Harpoon Over Leftwards Harpoon - ("⇐" "<#21D0>") ; ⇐ U+21D0 Leftwards Double Arrow - ("⇑" "<#21D1>") ; ⇑ U+21D1 Upwards Double Arrow - ("⇒" "<#21D2>") ; ⇒ U+21D2 Rightwards Double Arrow - ("⇓" "<#21D3>") ; ⇓ U+21D3 Downwards Double Arrow - ("⇔" "<#21D4>") ; ⇔ U+21D4 Left Right Double Arrow - ("⇕" "<#21D5>") ; ⇕ U+21D5 Up Down Double Arrow - ("⇖" "<#21D6>") ; ⇖ U+21D6 North West Double Arrow - ("⇗" "<#21D7>") ; ⇗ U+21D7 North East Double Arrow - ("⇘" "<#21D8>") ; ⇘ U+21D8 South East Double Arrow - ("⇙" "<#21D9>") ; ⇙ U+21D9 South West Double Arrow - ("⇚" "<#21DA>") ; ⇚ U+21DA Leftwards Triple Arrow - ("⇛" "<#21DB>") ; ⇛ U+21DB Rightwards Triple Arrow - ("&ziglarr;" "<#21DC>") ; ⇜ U+21DC Leftwards Squiggle Arrow - ("⇝" "<#21DD>") ; ⇝ U+21DD Rightwards Squiggle Arrow - ("⇤" "<#21E4>") ; ⇤ U+21E4 Leftwards Arrow To Bar - ("⇥" "<#21E5>") ; ⇥ U+21E5 Rightwards Arrow To Bar - ("⇵" "<#21F5>") ; ⇵ U+21F5 Downwards Arrow Leftwards of Upwards Arrow - ("⟵" "<#27F5>") ; ⟵ U+27F5 Long Leftwards Arrow - ("⟶" "<#27F6>") ; ⟶ U+27F6 Long Rightwards Arrow - ("⟷" "<#27F7>") ; ⟷ U+27F7 Long Left Right Arrow - ("⟸" "<#27F8>") ; ⟸ U+27F8 Long Leftwards Double Arrow - ("⟹" "<#27F9>") ; ⟹ U+27F9 Long Rightwards Double Arrow - ("⟺" "<#27FA>") ; ⟺ U+27FA Long Left Right Double Arrow - ("⟿" "<#27FF>") ; ⟿ U+27FF Long Rightwards Squiggle Arrow - ("⟼" "<#27FC>") ; ⟼ U+27FC Long Rightwards Arrow from Bar - ("⥊" "<#294A>") ; ⥊ U+294A Left Barb Up Right Barb Down Harpoon - ("⥋" "<#294B>") ; ⥋ U+294B Left Barb Down Right Barb Up Harpoon - ("⥏" "<#294F>") ; ⥏ U+294F Up Barb Right Down Barb Right Harpoon - ("⥐" "<#2950>") ; ⥐ U+2950 Left Barb Down Right Barb Down Harpoon - ("⥑" "<#2951>") ; ⥑ U+2951 Up Barb Left Down Barb Left Harpoon - ("⥮" "<#296E>") ; ⥮ U+296E Upwards Harpoon with Barb Left Beside Downwards Harpoon with Barb Right - ("⥯" "<#296F>") ; ⥯ U+296F Downwards Harpoon with Barb Left Beside Upwards Harpoon with Barb Right - ("ð" "<#00F0>") ; ð U+00F0 Latin Small Letter Eth - ("þ" "<#00FE>") ; þ U+00FE Latin Small Letter Thorn - ("Đ" "<#0110>") ; Đ U+0110 Latin Capital Letter D with Stroke - ("đ" "<#0111>") ; đ U+0111 Latin Small Letter D with Stroke - ("Ħ" "<#0126>") ; Ħ U+0126 Latin Capital Letter H with Stroke - ("ħ" "<#0127>") ; ħ U+0127 Latin Small Letter H with Stroke - ("ı" "<#0131>") ; ı U+0131 Latin Small Letter Dotless I - ("ĸ" "<#0138>") ; ĸ U+0138 Latin Small Letter Kra - ("Ł" "<#0141>") ; Ł U+0141 Latin Capital Letter L with Stroke - ("ł" "<#0142>") ; ł U+0142 Latin Small Letter L with Stroke - ("Ŋ" "<#014A>") ; Ŋ U+014A Latin Capital Letter Eng - ("ŋ" "<#014B>") ; ŋ U+014B Latin Small Letter Eng - ("Ŧ" "<#0166>") ; Ŧ U+0166 Latin Capital Letter T with Stroke - ("ŧ" "<#0167>") ; ŧ U+0167 Latin Small Letter T with Stroke - ("̑" "<#0311>") ; ̑ U+0311 Combining Inverted Breve - ("♀" "<#02640>") ; ♀ U+02640 female - ("♂" "<#02642>") ; ♂ U+02642 male - ("⟺" "<#027FA>") ; ⟺ U+027FA - ("⇒" "<#021D2>") ; ⇒ U+021D2 - ("⟶" "<#027F6>") ; ⟶ U+027F6 - ("ℵ" "<#02135>") ; ℵ U+02135 - ("↑" "<#02191>") ; ↑ U+02191 - ("∏" "<#0220F>") ; ∏ U+0220F - ("ⅇ" "") ; ⅇ U+02147 - - ) - -(logic-table mathml-symbol->tm% - ("…" "") - (" " (hspace "0.1666667em")) - (" " (hspace "0.2222222em")) - ("  " (hspace "0.2777778em")) - (" " (hspace "1em")) - (" " (hspace "1en"))) - -; when in mover or munder, the decorations in the 3 logic-tables below, -; automatically become wide, irrespective of the "stretchy" attribute -(logic-table mathml-above->tm% - ("" "") - ("" "") - ("" "") - ("" "") - ("" "") - ("" "")) - -(logic-table mathml-below->tm% - ("" "") - ("" "") - ("" "") - ("" "") - ("" "") - ("" "")) - -(logic-table mathml-above-below->tm% - ("" "") - ("" "") - ("" "") - ("^" "^") - ("~" "~") - ("¯" "") - ("" "") - ("" "") - ("" "") - ("" "") - ("" "") - ) - - - -(logic-rules - ((mathml-operator->tm% 'x 'y) (tm->mathml-operator% 'y 'x)) - ((mathml-symbol->tm% 'x 'y) (mathml-constant->tm% 'x 'y)) - ((mathml-symbol->tm% 'x 'y) (mathml-operator->tm% 'x 'y)) - ((mathml-below->tm% 'x 'y) (mathml-above-below->tm% 'x 'y)) - ((mathml-above->tm% 'x 'y) (mathml-above-below->tm% 'x 'y))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Special symbols -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(logic-table tm->mathml-left% - ("(" "(") - ("[" "[") - ("{" "{") - ("langle" "⟨") - ("lfloor" "⌊") - ("lceil" "⌈") - ("llbracket" "⟦") - ("/" "/")) - -(logic-table tmtm-left% - ;; For HTML entities ⌊, &lceil, etc. - ("" "lfloor") - ("" "lceil") - ("" "langle")) - -(logic-table tm->mathml-right% - (")" ")") - ("]" "]") - ("}" "}") - ("rangle" "⟩") - ("rfloor" "⌋") - ("rceil" "⌉") - ("rrbracket" "⟧") - ("\\\\" "∖")) - -(logic-table tmtm-right% - ;; For HTML entities ⌋, &rceil, etc. - ("" "rfloor") - ("" "rceil") - ("" "rangle")) - -(logic-table tm->mathml-big% - ("sum" "∑") - ("prod" "∏") - ("int" "∫") - ("iint" "∬") - ("iiint" "∭") - ("oiint" "∯") - ("oiiint" "∰") - ("oint" "∮") - ("amalg" "∐") - ("cap" "⋂") - ("cup" "⋃") - ("wedge" "⋀") - ("vee" "⋁") - ("odot" "⊙") - ("oplus" "⊕") - ("otimes" "⊗") - ("sqcap" "⊓") ;; FIXME: displayed too small - ("sqcup" "⊔") ;; FIXME: displayed too small - ;;("curlywedge" "&CurlyWedge;") - ;;("curlyvee" "&CurlyVee;") - ;;("triangleup" "&TriangleUp;") - ;;("triangledown" "&TriangleDown;") - ;;("box" "&Box;") - ("pluscup" "⊎") - ;;("parallel" "&Parallel;") - ;;("interleave" "&Interleave;") -) - -(logic-table tmtm-big% - ;; For HTML entities ∑, ∏, etc. - ("" "sum") - ("" "prod") - ("" "int")) - -(logic-table tm->mathml-above-below% - ("^" "^") - ("~" "∼") - ("" "‾") - ("" "⇀") - ("" "ˇ") - ("" "˘") - ("" "̑") ; combining inverted breve - ("" "´") - ("" "`") - ("" "˙") - ("" "¨") -;; ("" "&AboveRing;") - ("" "→") - ("" "←")) - -(logic-table tm->mathml-only-above% - ("" "⏞") - ("" "⏟") - ("" "⏜") - ("" "⏝") - ("" "⎴") - ("" "⎵")) - -(logic-table tm->mathml-only-below% - ("" "⏞") - ("" "⏟") - ("" "⏜") - ("" "⏝") - ("" "⎴") - ("" "⎵")) - -(logic-rules - ((tm->mathml-large% 'x 'y) (tm->mathml-left% 'x 'y)) - ((tm->mathml-large% 'x 'y) (tm->mathml-right% 'x 'y)) - ((mathml-left->tm% 'x 'y) (tm->mathml-left% 'y 'x)) - ((mathml-right->tm% 'x 'y) (tm->mathml-right% 'y 'x)) - ((mathml-large->tm% 'x 'y) (mathml-left->tm% 'x 'y)) - ((mathml-large->tm% 'x 'y) (mathml-right->tm% 'x 'y)) - ((mathml-big->tm% 'x 'y) (tm->mathml-big% 'y 'x)) - ((tm->mathml-above% 'x 'y) (tm->mathml-only-above% 'x 'y)) - ((tm->mathml-above% 'x 'y) (tm->mathml-above-below% 'x 'y)) - ((tm->mathml-below% 'x 'y) (tm->mathml-only-below% 'x 'y)) - ((tm->mathml-below% 'x 'y) (tm->mathml-above-below% 'x 'y)) - ((tm->mathml-wide*% 'x 'y) (tm->mathml-only-below% 'x 'y)) - ((tm->mathml-wide*% 'x 'y) (tm->mathml-only-above% 'x 'y)) - ((tm->mathml-wide*% 'x 'y) (tm->mathml-above-below% 'x 'y)) - ((tm->mathml-wide% 'x 'y) (tm->mathml-wide*% 'x 'y)) - ((tm->mathml-wide% "" "‾")) - ((mathml-above->tm% 'x 'y) (tm->mathml-above% 'y 'x)) - ((mathml-below->tm% 'x 'y) (tm->mathml-below% 'y 'x)) - ((mathml-wide->tm% 'x 'y) (tm->mathml-wide*% 'y 'x))) diff --git a/TeXmacs/plugins/html/progs/convert/mathml/mathtm.scm b/TeXmacs/plugins/html/progs/convert/mathml/mathtm.scm deleted file mode 100644 index a439fa8124..0000000000 --- a/TeXmacs/plugins/html/progs/convert/mathml/mathtm.scm +++ /dev/null @@ -1,646 +0,0 @@ - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; MODULE : mathtm.scm -;; DESCRIPTION : conversion of MathML trees to TeXmacs trees -;; COPYRIGHT : (C) 2002, 2005 Joris van der Hoeven and David Allouche -;; -;; This software falls under the GNU general public license version 3 or later. -;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE -;; in the root directory or . -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; -- MathML notes -- -;; -;; . Linking is defined by XLink. -;; . mtr and mtd may be inferred for compat with MathML1 -;; . transfinite symbols are U+2135-U+2138 -;; . how to render empty tokens? -;; . how to render whitespace in tokens? - -;; . mathvariant affect comparison of chars corresponding to SMP conterparts - -;; . slanting rules of match rules of texmacs -;; . ... might be rendered as ldots, check if it is a MathML char -;; . only a very reduced subset of can be natively supported -;; . containing text cannot be supported -;; . nesting of can denote range of delimiters in -;; . texmacs cannot do \widearrow (script under extensible arrow) -;; . containing text may be rendered as nested text delimited by spaces -;; (see 3.2.6.4) - -;; !!! Check semantic of mathvariant on multiple symbols !!! - -(texmacs-module (convert mathml mathtm) - (:use (convert tools tmtable) - (convert data sxml) - (convert data xmltm) - (convert mathml mathml-drd))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Special -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (mathtm-math env a c) - (let* ((m (mathtm-args-serial env c)) - (r (tree->stree (upgrade-mathml m))) - (r (replace-symbol-in-stree r 'around 'around*)) - (displayed? (attribute-is? a 'display "block"))) - ; according to https://developer.mozilla.org/en-US/docs/Web/MathML/Element/math - (if displayed? - `((document (equation* ,r))) - `((math ,r))))) - -(define (attribute-is? a key value) - (if (null? a) - #f - (if (and (pair? (car a)) - (func? (car a) key 1) - (== (cadar a) value)) - #t - (attribute-is? (cdr a) key value)))) - -(define (attribute-val a key) - (if (null? a) - #f - (if (and (pair? (car a)) - (func? (car a) key 1)) - (cadar a) - (attribute-val (cdr a) key)))) - -;copied from htmltm.scm -(define (replace-symbol-in-stree st from to) - (cond ((== st from) to) - ((list? st) (map (lambda (x) (replace-symbol-in-stree x from to)) st)) - (else st))) - - -(define (mathtm-none env a c) - '()) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Literals -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (mathtm-string env s) - ;; FIXME: use translators or parser for this!!! - ;; TODO: learn when the trailing ';' is optional - (cond ((logic-ref mathml-symbol->tm% s) => identity) - ((string-starts? s "&") (entity->tm s)) - (else (xmltm-text s)))) - -(define (mathtm-mo env a c) - (cond ((null? c) '()) - ((or (nnull? (cdr c)) (nstring? (car c))) - (list (mathtm-args-serial env c))) - (else - (let* ((s (car c)) - (r (xmltm-text s))) - (cond ((logic-ref mathml-left->tm% s) => (lambda (x) `((left ,x)))) - ((logic-ref mathml-right->tm% s) => (lambda (x) `((right ,x)))) - ((logic-ref mathml-big->tm% s) => (lambda (x) `((big ,x)))) - ((logic-ref mathml-symbol->tm% s) => (lambda (x) `(,x))) - ((logic-ref tmtm-left% r) => (lambda (x) `((left ,x)))) - ((logic-ref tmtm-right% r) => (lambda (x) `((right ,x)))) - ((logic-ref tmtm-big% r) => (lambda (x) `((big ,x)))) - ((string-starts? s "&") `(,(entity->tm s))) - (else (list r))))))) - -(define (entity->tm s) - (let* ((l (string-length s)) - (typ (cond - ((and (== l 6) (== (string-take-right s 4) "opf;")) "") - s))) - -(define (mathtm-mtext env a c) - `((with "mode" "text" ,(mathtm-args-serial env c)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Simple mathematical constructs -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (mathtm-mfrac env a c) - (if (== (length c) 2) - (with lt (attribute-val a 'linethickness) - (if (and lt (length-zero? lt)) - `((stack (tformat (table - (row (cell ,(mathtm-as-serial env (first c)))) - (row (cell ,(mathtm-as-serial env (second c)))))))) - `((frac - ,(mathtm-as-serial env (first c)) - ,(mathtm-as-serial env (second c)))))) - (mathtm-error "bad mfrac"))) - -(define (mathtm-msqrt env a c) - `((sqrt ,(mathtm-args-serial env c)))) - -(define (mathtm-mroot env a c) - (if (== (length c) 2) - `((sqrt - ,(mathtm-as-serial env (first c)) - ,(mathtm-as-serial env (second c)))) - (mathtm-error "bad mroot"))) - -(define (mathtm-error message) - `((with "color" "red" ,message))) - -(define (mathtm-merror env a c) - (matthtm-error (mathtm-mrow env a c))) - -;(define (mathtm-mstyle env a c) -; (let* ((attrs (mathtm-style a)) -; (l (mathtm-args env c))) -; (if (null? attrs) l `((with ,@attrs ,(mathtm-serial env l)))))) - -(define (mathtm-mphantom env a c) - `((phantom ,(mathtm-args-serial env c)))) - -(define (mathtm-sep-list l seps) - (cond ((null? l) l) - ((null? seps) l) - (else (cons* (car l) `(m:mo ,(car seps)) - (mathtm-sep-list (cdr l) (cdr seps)))))) - -(define (mathtm-mfenced env a c) - (let* ((open (car (or (assoc-ref a 'open) '("(")))) - (close (car (or (assoc-ref a 'close) '(")")))) - (seps (string-tokenize-by-char - (car (or (assoc-ref a 'separators) '(""))) - #\space))) - (if (== seps '("")) (set! seps '())) - (mathtm env `(m:mrow (m:mo ,open) - ,@(mathtm-sep-list c seps) - (m:mo ,close))))) - -(define (mathtm-menclose env a c) - (let* ((args (mathtm-args env c)) - (notation (car (or (assoc-ref a 'notation) '("")))) - (l (if (== notation "") '() - (string-tokenize-by-char notation #\space)))) - (if (in? "updiagonalstrike" l) - `((neg ,(mathtm-serial env args))) - args))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Scripts -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (mathtm-prime-sub? s) - (or (== s "'") (== s "`") (== s "") )) - -(define (mathtm-prime? s) - (and (string? s) - (list-every mathtm-prime-sub? (tmconcat-tokenize-math s)))) - -(define (mathtm-superscript type1 type2 sup) - (if (mathtm-prime? sup) - (list type2 sup) - (list type1 sup))) - -(define (mathtm-scripts base lsub lsup rsub rsup) - (if lsub (set! base (cons `(lsub ,lsub) base))) - (if lsup (set! base (cons (mathtm-superscript `lsup `lprime lsup) base))) - (if rsub (set! base (rcons base `(rsub ,rsub)))) - (if rsup (set! base (rcons base (mathtm-superscript `rsup `rprime rsup)))) - base) - -(define (mathtm-mo-string t) - (if (and (list? t) (or (func? t 'mo) (func? t 'm:mo))) - (with c (sxml-content t) - (if (and (list-1? c) (string? (car c))) (car c) #f)) - #f)) - -(define (mathtm-opening-delimiter? t) - (in? (mathtm-mo-string t) '("(" "[" "{"))) - -(define (mathtm-closing-delimiter? t) - (in? (mathtm-mo-string t) '(")" "]" "}"))) - -(define (mathtm-delimited-script? l) - (and (nnull? l) - (mathtm-opening-delimiter? (car l)) - (mathtm-closing-delimiter? (last l)))) - -(define (mathtm-msubsup-split l) - (let ((n (length l))) - (cond ((== n 2) (values (list (first l)) (list (second l)))) - ((mathtm-delimited-script? (cdr l)) - (values (list (first l)) (cdr l))) - (else - (values (sublist l 0 (- n 1)) - (sublist l (- n 1) n)))))) - -(define (mathtm-msub env a c) - (if (>= (length c) 2) - (let ((base (mathtm env (first c))) - (sub (mathtm-args-serial env (cdr c)))) - (mathtm-scripts base #f #f sub #f)) - (mathtm-error "bad msub"))) - -(define (mathtm-msup env a c) - (if (>= (length c) 2) - (let ((base (mathtm env (first c))) - (sup (mathtm-args-serial env (cdr c)))) - (mathtm-scripts base #f #f #f sup)) - (mathtm-error "bad msup"))) - -(define (mathtm-msubsup env a c) - (if (>= (length c) 3) - (let ((base (mathtm env (first c)))) - (receive (sub-c sup-c) (mathtm-msubsup-split (cdr c)) - (let ((sub (mathtm-args-serial env sub-c)) - (sup (mathtm-args-serial env sup-c))) - (mathtm-scripts base #f #f sub sup)))) - (mathtm-error "bad msubsup"))) - -(define (mathtm-mmultiscripts-sub env l right?) - (cond ((or (null? l) (null? (cdr l))) (values '() '() '() '())) - ((or (func? (car l) 'mprescripts) (func? (car l) 'm:mprescripts)) - (mathtm-mmultiscripts-sub env (cdr l) #f)) - (else (receive (lsub lsup rsub rsup) - (mathtm-mmultiscripts-sub env (cddr l) right?) - (let ((sub (mathtm env (car l))) - (sup (mathtm env (cadr l)))) - (if right? - (values lsub lsup - (append rsub sub) (append rsup sup)) - (values (append sub lsub) - (append sup lsup) rsub rsup))))))) - -(define (mathtm-multiscript env l) - (if (null? l) #f - (mathtm-serial env l))) - -(define (mathtm-mmultiscripts env a c) - (if (> (length c) 0) - (with base (mathtm env (first c)) - (receive (lsub lsup rsub rsup) - (mathtm-mmultiscripts-sub env (cdr c) #t) - (mathtm-scripts base - (mathtm-multiscript env lsub) - (mathtm-multiscript env lsup) - (mathtm-multiscript env rsub) - (mathtm-multiscript env rsup)))) - (mathtm-error "bad mmultiscripts"))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Under and over scripts and wide accents -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (mathtm-below base sub) - (cond ((logic-ref mathml-below->tm% sub) => - (lambda (x) `((wide* ,base ,x)))) - (else `((below ,base ,sub))))) - -(define (mathtm-above base sup) - (cond ((logic-ref mathml-above->tm% sup) => - (lambda (x) `((wide ,base ,x)))) - (else `((above ,base ,sup))))) - -(define (stretchy? src dest) - (and (string? dest) - (string-starts? dest "<") - (string-ends? dest ">") - (or (func? src 'm:mo) (func? src 'mo)) - (>= (length src) 3) - (func? (cadr src) '@) - (attribute-is? (cdadr src) 'stretchy "true"))) - -(define (rubberify arrow) - (string-append "tm% (second sub) )) - ;widenable-decoration, but inverted order - `((below ,(car (mathtm-below base (second sub))) ,(third sub)))) - ((stretchy? (first c) base) - `((long-arrow ,(rubberify base) "" ,sub))) - (else (mathtm-below base sub)))) - (mathtm-error "bad munder"))) - -(define (mathtm-mover env a c) - (if (== (length c) 2) - (let ((base (mathtm-as-serial env (first c))) - (sup (mathtm-as-serial env (second c)))) - (cond - ((and (list? sup) (== (first sup) 'above) (logic-ref mathml-above->tm% (second sup) )) - ;inverted over - `((above ,(car (mathtm-above base (second sup))) ,(third sup)))) - ((stretchy? (first c) base) - `((long-arrow ,(rubberify base) ,sup))) - (else (mathtm-above base sup)))) - (mathtm-error "bad mover"))) - -(define (mathtm-munderover env a c) - (if (== (length c) 3) - (let ((base (mathtm-as-serial env (first c))) - (sub (mathtm-as-serial env (second c))) - (sup (mathtm-as-serial env (third c)))) - (if (stretchy? (first c) base) - `((long-arrow ,(rubberify base) ,sup ,sub)) - (mathtm-above (car (mathtm-below base sub)) sup))) - (mathtm-error "bad munderover"))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Tables -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (mathml-func? x y) - (and (list? x) - (or (== (car x) y) - (== (car x) (symbol-append 'm: y))))) - -(define (mathml-func-in? x l) - (list-or (map (cut mathml-func? x <>) l))) - -(define (mathtm-halign s) - (cond ((== s "left") "l") - ((== s "center") "c") - ((== s "right") "r") - (else #f))) - -(define (mathtm-valign s) - (cond ((== s "bottom") "b") - ((== s "baseline") "B") - ((== s "axis") "f") - ((== s "center") "c") - ((== s "top") "t") - (else #f))) - -(define (mathtm-cell-format a) - (with sa (mathtm-style (list a)) - (if (nnull? sa) ;styling attributes? - (map (lambda (x) `(cwith ,(first x) ,(second x))) - (split-by sa 2)) - (cond ((and (func? a 'columnalign) (mathtm-halign (cadr a))) - `((cwith "cell-halign" ,(mathtm-halign (cadr a))))) - ((and (func? a 'rowalign) (mathtm-valign (cadr a))) - `((cwith "cell-valign" ,(mathtm-valign (cadr a))))) - (else '())) - ))) - -(define (mathtm-mtd env a c) - (let ((fm (append-map mathtm-cell-format a)) - (c `(cell ,(mathtm-serial env (mathtm-pass env a c))))) - (if (null? fm) `(,c) `((tformat ,@fm ,c))))) - -(define (mathtm-row-halign l nr) - (if (null? l) '() - (let* ((h (mathtm-halign (car l))) - (r (mathtm-row-halign (cdr l) (+ nr 1))) - (s (number->string nr)) - (c `(cwith ,s ,s "cell-halign" ,h))) - (if h (cons c r) r)))) - -(define (mathtm-row-format a) - (with sa (mathtm-style (list a)) - (if (nnull? sa) ;styling attributes? - (map (lambda (x) `(cwith "1" "-1" ,(first x) ,(second x))) - (split-by sa 2)) - (cond ((func? a 'columnalign) - (with l (string-tokenize-by-char (cadr a) #\space) - (mathtm-row-halign l 1))) - ((and (func? a 'rowalign) (mathtm-valign (cadr a))) - `((cwith "1" "-1" "cell-valign" ,(mathtm-valign (cadr a))))) - (else '())) - ))) - -(define (split-by lst n) - (if (not (null? lst)) - (cons (list-take lst n) (split-by (list-drop lst n) n)) - '() )) - -(define (mathtm-mtr env a c) - (let* ((cell? (lambda (x) (mathml-func? x 'mtd))) - (c2 (map (lambda (x) (if (cell? x) x `(m:mtd ,x))) c)) - (r `(row ,@(map (cut mathtm-as-serial env <>) c2))) - (fm (append-map mathtm-row-format a))) - (if (null? fm) `(,r) `((tformat ,@fm ,r))))) - -(define (mathtm-mlabeledtr env a c) - ;; row label is ignored (not MathML Core spec) - (if (null? c) '((row)) - (mathtm-mtr env a (cdr c)))) - -(define (mathtm-table-halign l nr) - (if (null? l) '() - (let* ((h (mathtm-halign (car l))) - (r (mathtm-table-halign (cdr l) (+ nr 1))) - (s (number->string nr)) - (c `(cwith "1" "-1" ,s ,s "cell-halign" ,h))) - (if h (cons c r) r)))) - -(define (mathtm-table-valign l nr) - (if (null? l) '() - (let* ((h (mathtm-valign (car l))) - (r (mathtm-table-valign (cdr l) (+ nr 1))) - (s (number->string nr)) - (c `(cwith ,s ,s "1" "-1" "cell-valign" ,h))) - (if h (cons c r) r)))) - -(define (mathtm-table-format a) - (with sa (mathtm-style (list a)) - (if (nnull? sa) ;styling attributes? - (map (lambda (x) `(cwith "1" "-1" "1" "-1" ,(first x) ,(second x))) - (split-by sa 2)) - (cond ((func? a 'columnalign) - (with l (string-tokenize-by-char (cadr a) #\space) - (mathtm-table-halign l 1))) - ((func? a 'rowalign) - (with l (string-tokenize-by-char (cadr a) #\space) - (mathtm-table-valign l 1))) - (else '())) - ))) - -(define (mathtm-mtable env a c) - (let* ((row? (lambda (x) (mathml-func-in? x '(mtr mlabeledtr)))) - (c2 (map (lambda (x) (if (row? x) x `(m:mtr ,x))) c)) - (l (map (cut mathtm-as-serial env <>) c2)) - (fm (append-map mathtm-table-format a)) - (t (tmtable-complete `(tformat ,@fm (table ,@l))))) - (set! t (tmtable-format-up t)) - (if (func? t 'tformat 1) (set! t (cAr t))) - `((tabular ,t)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Further features used by wikipedia & LibreOffice Math -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (mathtm-semantics env a c) - (or (and (list>1? c) - (== (get-preference "mathml->texmacs:latex-annotations") "on") - (mathtm-annotation env a (cdr c))) - (mathtm env (first c)))) - -(define (mathtm-annotation env a l) ; -;there may be more than one annotation, scan them all - (with r (and (list>1? l) (mathtm-annotation env a cdr (l))) - (or r - (let* ((an (car l)) - (enc (and (func? an 'm:annotation 2) - (func? (second an) '@) (shtml-attr-non-null (cdr (second an)) 'encoding)))) - (cond - ((and enc (in? enc '("application/x-tex" "TeX"))) - (let* ((s (third an)) - (lat (parse-latex (string-append "$" s "$"))) - (str (latex->texmacs lat))) - (list str))) - ((and enc (string-starts? enc "StarMath")) ;ignore - #f) - (else - (debug-message "debug-convert" (string-append "Mathml contains an unknown annotation type \"" enc "\"\n with value: \n" (third an) "\nTeXmacs is not using it\n")) - #f) - ))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; mathml tags can all handle the same set of (so-called "global") styling attributes -;; -> handle them with a single function (except for table tags, treated differently) -;; If attributes can be interpreted, wrap the result of the tag procedure -;; in the appropriate '(with ...) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (mathtm-globattr env a c tagproc) - (with res (tagproc env a c) - (cond - ((null? res) res) - ((null? a) res) - (else - (with attrs (mathtm-style a) - (if (null? attrs) res - `((with ,@attrs ,(car res))))))))) - -(define (mathtm-style l) -;note that it does not hurt handling tag-specific attributes here - (if (null? l) l - (let* ((h (car l)) - (r (mathtm-style (cdr l)))) - (cond ((or (func? h 'mathcolor) (func? h 'color)) - (cons* "color" (cadr h) r)) - ((func? h 'displaystyle) - (cons* "math-display" (cadr h) r)) - ((or (== h '(mathvariant "bold")) - (== h '(mathvariant "bold-italic"))) - (cons* "math-font-series" "bold" r)) - ((or (== h '(mathvariant "sans-serif")) - (== h '(mathvariant "sans-serif--italic"))) - (cons* "math-font-family" "ms" r)) - ((== h '(mathvariant "monospace")) - (cons* "math-font-family" "mt" r)) - ((func? h 'mathsize) - (cons* "font-base-size" (cadr h) r)) - ((func? h 'scriptlevel) - (with sl (string->number (cadr h)) - (cond - ((and sl (>= sl 0)) - (cons* "math-level" (cadr h) r)) - ((== sl -1) - (cons* "font-size" "1.189" r)) ;std large - ((== sl -2) - (cons* "font-size" "1.414" r)) ;std very-large - ((== sl -3) - (cons* "font-size" "1.682" r)) ;std huge - ((< sl -3) - (cons* "font-size" "2" r)) ;std really huge - (else r)))) - ((func? h 'style) ;css styling string, expand to attributes - (append - (mathtm-style - (map (lambda (l) (list (string->symbol (car l)) (cAr l))) - (filter list-2? - (map (lambda (x) (map string-trim (string-tokenize-by-char x #\:))) - (string-tokenize-by-char (cadr h) #\;))))) - r)) - (else r))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Main translation -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (mathtm-drop env a c) '()) - -(define (mathtm-pass env a c) - ;; TODO: consolidate with htmltm-pass - (let ((l (mathtm-args env c))) - (if (and (null? l) (not (assoc 'id a))) '() - (list (xmltm-label-decorate a 'id (mathtm-serial env l)))))) - -(define (mathtm-args env l) - ;; TODO: consolidate with htmltm-args - (append-map (lambda (x) (mathtm env x)) l)) - -(define (mathtm-args-serial env l) - ;; FIXME: mathml must not be affected by xml:space (html 
 mode)
-  (mathtm-serial env (mathtm-args env l)))
-
-(define (mathtm env t)
-  (sxml-dispatch (lambda (env t) (list (mathtm-string env t)))
-		 mathtm-pass env t))
-
-(tm-define mathtm-as-serial
-  ;; TODO: replace #f by 'environment' object, see htmltm-as-serial
-  (case-lambda
-    ((t) (mathtm-as-serial #f t))
-    ((env t) (mathtm-serial env (mathtm env t)))))
-
-(logic-dispatcher mathtm-methods%
-  ;;; Interface
-  (math (mathtm-handler :element mathtm-math mathtm-globattr))
-  (none (mathtm-handler :mixed mathtm-none mathtm-globattr))
-  ;;; Presentation
-  ;; Token
-  ;; presentation tokens contain CDATA, MathML entities, align marks, or glyphs
-  (mi (mathtm-handler :mixed mathtm-pass mathtm-globattr))
-  (mn (mathtm-handler :mixed mathtm-pass mathtm-globattr))
-  (mo (mathtm-handler :mixed mathtm-mo mathtm-globattr))
-  (mtext (mathtm-handler :mixed mathtm-mtext mathtm-globattr))
-  (mspace (mathtm-handler :mixed mathtm-drop mathtm-globattr))
-  (ms (mathtm-handler :mixed mathtm-mtext mathtm-globattr))
-  (mglyph (mathtm-handler :empty mathtm-drop mathtm-globattr))
-  ;; General layout
-  (mrow (mathtm-handler :mixed mathtm-pass mathtm-globattr)) ;was :element, now more tolerant with malformed xml  
-  (mfrac (mathtm-handler :element mathtm-mfrac mathtm-globattr))
-  (msqrt (mathtm-handler :element mathtm-msqrt mathtm-globattr))
-  (mroot (mathtm-handler :element mathtm-mroot mathtm-globattr))
-  ;(mstyle (mathtm-handler :element mathtm-mstyle))
-  (mstyle (mathtm-handler :element mathtm-pass mathtm-globattr))
-  ;  is now just equivalent to an 
-  (merror (mathtm-handler :element mathtm-merror mathtm-globattr))
-  (mpadded (mathtm-handler :element mathtm-pass mathtm-globattr))
-  (mphantom (mathtm-handler :element mathtm-mphantom mathtm-globattr))
-  (mfenced (mathtm-handler :element mathtm-mfenced mathtm-globattr))
-  (menclose (mathtm-handler :element mathtm-menclose mathtm-globattr))
-  ;; Script and limits
-  (msub (mathtm-handler :element mathtm-msub mathtm-globattr))
-  (msup (mathtm-handler :element mathtm-msup mathtm-globattr))
-  (msubsup (mathtm-handler :element mathtm-msubsup mathtm-globattr))
-  (munder (mathtm-handler :element mathtm-munder mathtm-globattr))
-  (mover (mathtm-handler :element mathtm-mover mathtm-globattr))
-  (munderover (mathtm-handler :element mathtm-munderover mathtm-globattr))
-  (mmultiscripts (mathtm-handler :element mathtm-mmultiscripts mathtm-globattr))
-  ;; Tables
-  (mtable (mathtm-handler :element mathtm-mtable))
-  (mtr (mathtm-handler :element mathtm-mtr))
-  (mlabeledtr (mathtm-handler :element mathtm-mlabeledtr))
-  (mtd (mathtm-handler :element mathtm-mtd))
-  ;; Actions
-  (maction (mathtm-handler :element mathtm-pass mathtm-globattr))
-  ;; Further features used by wikipedia
-  (semantics (mathtm-handler :element mathtm-semantics mathtm-globattr)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Interface
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (mathml->tree s)
-  (:synopsis "Convert the MathML @s into a document fragment.")
-  (mathtm-as-serial (parse-xml s)))
diff --git a/TeXmacs/plugins/html/progs/convert/mathml/tmmath.scm b/TeXmacs/plugins/html/progs/convert/mathml/tmmath.scm
deleted file mode 100644
index 38569904d1..0000000000
--- a/TeXmacs/plugins/html/progs/convert/mathml/tmmath.scm
+++ /dev/null
@@ -1,420 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : tmmath.scm
-;; DESCRIPTION : conversion of TeXmacs trees into MathML trees
-;; COPYRIGHT   : (C) 2004  Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (convert mathml tmmath)
-  (:use (convert tools tmconcat)
-	(convert tools tmtable)
-	(convert mathml mathml-drd)
-	(convert rewrite tmtm-brackets)))
-
-(define tmmath-env (make-ahash-table))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Horizontal concatenations
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (tmmath-concat-explode x)
-  (if (string? x)
-      (tmconcat-tokenize-math x)
-      (list x)))
-
-(define (tmmath-concat l)
-  (let* ((l2 (apply append (map tmmath-concat-explode l)))
-	 (l3 (tmconcat-structure-brackets l2)))
-    (tmmath (cons 'concat! l3))))
-
-(define (cork->utf8* x)
-  (with y (cork->utf8 x)
-    (if (and (== x y) (== (string-ref y 0) #\<)) "?" y)))
-
-(define (tmmath-concat-item x)
-  (if (string? x)
-      (with type (math-symbol-type x)
-	(cond ((string-number? x) `(m:mn ,x))
-	      ((logic-ref tm->mathml-constant% x) => (lambda (y) `(m:mn ,y)))
-	      ((logic-ref tm->mathml-operator% x) => (lambda (y) `(m:mo ,y)))
-              ((and (string-starts? x ""))
-               (let* ((n (string-length x))
-                      (char (substring x (- n 2) (- n 1))))
-                 `(m:mi (@ (mathvariant "script")) ,char)))
-              ((and (or (string-starts? x ""))
-               (let* ((n (string-length x))
-                      (char (substring x (- n 2) (- n 1))))
-                 `(m:mi (@ (mathvariant "bold-script")) ,char)))
-              ((and (string-starts? x ""))
-               (let* ((n (string-length x))
-                      (char (substring x (- n 2) (- n 1))))
-                 `(m:mi (@ (mathvariant "fraktur")) ,char)))
-              ((and (string-starts? x ""))
-               (let* ((n (string-length x))
-                      (char (substring x (- n 2) (- n 1))))
-                 `(m:mi (@ (mathvariant "bold-fraktur")) ,char)))
-              ((and (or (string-starts? x ""))
-               (let* ((n (string-length x))
-                      (char (substring x (- n 2) (- n 1))))
-                 `(m:mi (@ (mathvariant "double-struck")) ,char)))
-	      ((in? type '("unknown" "symbol")) `(m:mi ,(cork->utf8* x)))
-	      (else `(m:mo ,(cork->utf8* x)))))
-      (tmmath x)))
-
-(define (tmmath-concat! l)
-  (with r (map tmmath-concat-item (tmconcat-structure-scripts l))
-    (set! r (list-filter r (lambda (x) (!= x ""))))
-    (cond ((null? r) '(m:mrow))
-	  ((null? (cdr r)) (car r))
-	  (else `(m:mrow ,@r)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Mathematics
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (tmmath-rigid l)
-  `(m:mrow ,(tmmath (car l))))
-
-(define (convert-around x)
-  (with d (downgrade-brackets x)
-    (tmmath-concat (if (pair? d) (cdr d) (list d)))))
-
-(define (tmmath-around l)
-  (convert-around (cons 'around l)))
-
-(define (tmmath-around* l)
-  (convert-around (cons 'around* l)))
-
-(define (tmmath-big-around l)
-  (convert-around (cons 'big-around l)))
-
-(define (tmmath-large x)
-  (with y (logic-ref tm->mathml-large% x)
-    (if y y (cork->utf8 x))))
-
-(define (tmmath-left l) `(m:mo (@ (form "prefix") (stretchy "true")) ,(tmmath-large (car l))))
-(define (tmmath-mid l) `(m:mo (@ (stretchy "true")) ,(tmmath-large (car l))))
-(define (tmmath-right l) `(m:mo (@ (form "postfix") (stretchy "true")) ,(tmmath-large (car l))))
-
-(define (tmmath-big l)
-  (cond ((== (car l) ".") "")
-	((logic-ref tm->mathml-big% (car l)) => (lambda (y) `(m:mo ,y)))
-	(else `(m:mo ,(car l)))))
-
-(define (tmmath-lsub l) (tmmath-concat `((lsub ,(car l)))))
-(define (tmmath-lsup l) (tmmath-concat `((lsup ,(car l)))))
-(define (tmmath-rsub l) (tmmath-concat `((rsub ,(car l)))))
-(define (tmmath-rsup l) (tmmath-concat `((rsup ,(car l)))))
-
-(define (tmmath-lscript base sub sup)
-  (if (and (pair? base) (in? (car base) '(m:msub m:msup m:msubsup)))
-      (let ((nbase (cadr base))
-	    (rsub '(m:none))
-	    (rsup '(m:none)))
-	(if (func? base 'm:msub) (set! rsub (caddr base)))
-	(if (func? base 'm:msup) (set! rsup (caddr base)))
-	(if (func? base 'm:msubsup) (set! rsub (caddr base)))
-	(if (func? base 'm:msubsup) (set! rsup (cadddr base)))
-	`(m:mmultiscripts ,nbase ,rsub ,rsup (m:mprescripts) ,sub ,sup))
-      `(m:mmultiscripts ,base (m:mprescripts) ,sub ,sup)))
-
-(define (tmmath-lsub! l)
-  (tmmath-lscript (tmmath (car l)) (tmmath (cadr l)) '(m:none)))
-
-(define (tmmath-lsup! l)
-  (tmmath-lscript (tmmath (car l)) '(m:none) (tmmath (cadr l))))
-
-(define (tmmath-lsubsup! l)
-  (tmmath-lscript (tmmath (car l)) (tmmath (cadr l)) (tmmath (caddr l))))
-
-(define (tmmath-with-limits? x)
-  (and (func? x 'big)
-       (== (ahash-ref tmmath-env "math-display") "true")))
-
-(define (tmmath-rsub! l)
-  (with op (if (tmmath-with-limits? (car l)) 'm:munder 'm:msub)
-    (list op (tmmath (car l)) (tmmath (cadr l)))))
-
-(define (tmmath-rsup! l)
-  (with op (if (tmmath-with-limits? (car l)) 'm:mover 'm:msup)
-    (list op (tmmath (car l)) (tmmath (cadr l)))))
-
-(define (tmmath-rsubsup! l)
-  (with op (if (tmmath-with-limits? (car l)) 'm:munderover 'm:msubsup)
-    (list op (tmmath (car l)) (tmmath (cadr l)) (tmmath (caddr l)))))
-
-(define (tmmath-frac l)
-  `(m:mfrac ,(tmmath (car l)) ,(tmmath (cadr l))))
-
-(define (tmmath-sqrt l)
-  (if (null? (cdr l))
-      `(m:msqrt ,(tmmath (car l)))
-      `(m:mroot ,(tmmath (car l)) ,(tmmath (cadr l)))))
-
-(define (tmmath-wide l)
-  (with acc (or (logic-ref tm->mathml-wide% (cadr l)) "")
-    `(m:mover ,(tmmath (car l)) (m:mo ,acc))))
-
-(define (tmmath-wide* l)
-  (with acc (or (logic-ref tm->mathml-wide% (cadr l)) "")
-    `(m:munder ,(tmmath (car l)) (m:mo ,acc))))
-
-(define (tmmath-long-arrow l)
-  (let* ((a (car l))
-         (above (if (>= (length l) 2) (cadr l) ""))
-         (below (if (>= (length l) 3) (caddr l) "")))
-    (when (and (string? a) (string-starts? a "string len)) "*" ""))
-         (s* (if (string->number s) (string-append s "em") s)))
-    `(m:mspace (@ (width ,s*)))))
-
-(define (tmmath-first l)
-  (tmmath (car l)))
-
-(define (tmmath-last l)
-  (tmmath (cAr l)))
-
-(define (tmmath-surround l)
-  (tmmath-concat (list (car l) (caddr l) (cadr l))))
-
-(define (tmmath-attr x)
-  (with (var val) x
-    (cond ((== var "color") (list 'mathcolor val))
-	  ((== x '("math-font-series" "medium")) (list 'mathvariant "normal"))
-	  ((== x '("math-font-series" "bold")) (list 'mathvariant "bold"))
-	  ((== x '("math-font-series" "bold")) (list 'mathvariant "bold"))
-	  ((== var "math-level") (list 'scriptlevel val))
-	  ((== var "math-display") (list 'displaystyle val))
-	  (else #f))))
-
-(define (list-two-by-two l)
-  (if (null? l) l
-      (cons (list (car l) (cadr l)) (list-two-by-two (cddr l)))))
-
-(define (tmmath-with-sub attrs body)
-  (if (null? attrs) (tmmath body)
-      (with (var val) (car attrs)
-	(ahash-with tmmath-env var val
-	  (tmmath-with-sub (cdr attrs) body)))))
-
-(define (tmmath-with l)
-  (let* ((attrs-1 (list-two-by-two (cDr l)))
-	 (attrs-2 (map tmmath-attr attrs-1))
-	 (attrs-3 (list-filter attrs-2 identity))
-	 (body (tmmath-with-sub attrs-1 (cAr l))))
-    (if (null? attrs-3) body
-	`(m:mstyle (@ ,@attrs-3) ,body))))
-
-(define (tmmath-text x)
-  ;; we protect via non-breaking spaces the initial and final whitespaces 
-  ;; which are otherwise stripped by the MathML processor from  tags
-  ;; see https://www.xmlmind.com/tutorials/MathML/
-  (let* ((s (texmacs->code x  "utf-8"))
-         (s (if (string-starts? s " ") 
-            (string-append "  " (substring s 1 (string-length s))) s))
-         (s (if (string-ends? s " ") 
-            (string-append (substring s 0 (- (string-length s) 1)) "  ") s)))
-    `(m:mtext ,s)))
-       
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Main conversion routines
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (tmmath-dispatch htable l)
-  (let ((x (logic-ref ,htable (car l))))
-    (and (procedure? x)
-	 (x (cdr l)))))
-
-(define (tmmath x)
-  (if (!= (ahash-ref tmmath-env "mode") "math")
-      (cond ((string? x) (tmmath-text x))
-            ((== (car x) 'with) (tmmath-with (cdr x)))
-            (else `(m:mrow ,@(map tmmath (cdr x)))))
-      (cond ((string? x) (tmmath-concat (list x)))
-            (else (or (tmmath-dispatch 'tmmath-primitives% x) "")))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Dispatching
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-dispatcher tmmath-primitives%
-  ;; Mathematics
-  (concat tmmath-concat)
-  (concat! tmmath-concat!)
-  (rigid tmmath-rigid)
-  (around tmmath-around)
-  (around* tmmath-around*)
-  (big-around tmmath-big-around)
-  (left tmmath-left)
-  (mid tmmath-mid)
-  (right tmmath-right)
-  (big tmmath-big)
-  (long-arrow tmmath-long-arrow)
-  (lprime tmmath-lsup)
-  (rprime tmmath-rsup)
-  (below tmmath-below)
-  (above tmmath-above)
-  (lsub tmmath-lsub)
-  (lsup tmmath-lsup)
-  (rsub tmmath-rsub)
-  (rsup tmmath-rsup)
-  (lsub! tmmath-lsub!)
-  (lsup! tmmath-lsup!)
-  (lsubsup! tmmath-lsubsup!)
-  (rsub! tmmath-rsub!)
-  (rsup! tmmath-rsup!)
-  (rsubsup! tmmath-rsubsup!)
-  (frac tmmath-frac)
-  (sqrt tmmath-sqrt)
-  (wide tmmath-wide)
-  (wide* tmmath-wide*)
-  (neg tmmath-neg)
-  (tree tmmath-noop)
-  (syntax tmmath-first)
-
-  ;; Tabular markup
-  (tformat tmmath-tformat)
-  (table tmmath-table)
-  (row tmmath-concat)
-  (cell tmmath-concat)
-  (tabular tmmath-first)
-  (tabular* tmmath-first)
-  (block tmmath-first)
-  (block* tmmath-first)
-
-  ;; Other markup
-  (space tmmath-hspace)
-  (hspace tmmath-hspace)
-  (htab tmmath-hspace)
-  (document tmmath-concat)
-  (para tmmath-concat)
-  (surround tmmath-surround)
-  (move tmmath-first)
-  (resize tmmath-first)
-  (with tmmath-with))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Interface
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (texmacs->mathml x . opt-env)
-  (if (nnull? opt-env) (set! tmmath-env (car opt-env)))
-  (ahash-with tmmath-env "mode" "math"
-    (tmmath x)))
-
-;(display-err* "x= " x "\n")
-;(with y (tmmath x)
-;(display-err* "y= " y "\n")
-;y)))
diff --git a/TeXmacs/plugins/html/progs/data/html.scm b/TeXmacs/plugins/html/progs/data/html.scm
deleted file mode 100644
index 8a9af3e46a..0000000000
--- a/TeXmacs/plugins/html/progs/data/html.scm
+++ /dev/null
@@ -1,353 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : init-html.scm
-;; DESCRIPTION : setup html converters
-;; COPYRIGHT   : (C) 2003  Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (data html))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Html
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; HTML 标签/属性名都是 ASCII，用 safe-ascii-string-downcase 做 ASCII-only
-;; 大小写折叠可避免对含损坏 UTF-8 字节的输入触发 string->utf8 整段校验而崩溃。
-
-(define html-detected-limit 1000)
-
-;; 按行分割文本
-
-(define (html-string-split-lines s)
-  (let ((len (if (>= (string-length s) html-detected-limit)
-               html-detected-limit
-               (string-length s)
-             ) ;if
-        ) ;len
-       ) ;
-    (let loop
-      ((i 0) (start 0) (result '()))
-      (cond ((>= i len) (reverse (cons (substring s start i) result)))
-            ((char=? (string-ref s i) #\newline)
-             (loop (+ i 1) (+ i 1) (cons (substring s start i) result))
-            ) ;
-            (else (loop (+ i 1) start result))
-      ) ;cond
-    ) ;let
-  ) ;let
-) ;define
-
-;; 某个字符在文本中的含量
-
-(define (character-from-string s ch)
-  (if (not (string-null? s))
-    (let* ((len (string-length s))
-           (limit (if (>= len html-detected-limit) html-detected-limit len))
-          ) ;
-      (let loop
-        ((ref 0) (count 0))
-        (if (>= ref limit)
-          (/ count len)
-          (loop (+ ref 1) (if (char=? (string-ref s ref) ch) (+ count 1) count))
-        ) ;if
-      ) ;let
-    ) ;let*
-    #f
-  ) ;if
-) ;define
-
-;; 计算一个子串在文本中的含量，计算的是子串的字符数，而不是个数
-
-(define (html-string-count-substring s sub)
-  (let ((sub-len (string-length sub)))
-    (if (zero? sub-len)
-      0
-      (let loop
-        ((i 0) (count 0))
-        (if (>= i (- (string-length s) sub-len -1))
-          count
-          (if (string=? (substring s i (+ i sub-len)) sub)
-            (loop (+ i sub-len) (+ count 1))
-            (loop (+ i 1) count)
-          ) ;if
-        ) ;if
-      ) ;let
-    ) ;if
-  ) ;let
-) ;define
-
-;; < 和 > 的含量
-
-(define (html-angle-bracket-density s)
-  (if (string-null? s)
-    0
-    (let* ((len (string-length s))
-           (limit (if (>= len html-detected-limit) html-detected-limit len))
-           (substr (substring s 0 limit))
-          ) ;
-      (/ (+ (character-from-string substr #\<) (character-from-string substr #\>))
-        len
-      ) ;/
-    ) ;let*
-  ) ;if
-) ;define
-
-;; 完整的tag子串在文本中的字符含量
-
-(define (html-tag-density s)
-  (if (string-null? s)
-    0
-    (let* ((len (string-length s))
-           (limit (if (>= len html-detected-limit) html-detected-limit len))
-           (substr (substring s 0 limit))
-           (lc-substr (safe-ascii-string-downcase substr))
-          ) ;
-      (let ((count (+ (html-string-count-substring lc-substr "= len html-detected-limit) html-detected-limit len))
-           (substr (substring s 0 limit))
-          ) ;
-      (/ (+ (character-from-string substr #\=) (character-from-string substr #\"))
-        len
-      ) ;/
-    ) ;let*
-  ) ;if
-) ;define
-
-(define (html-line-contains-features? line)
-  (let ((lc-line (safe-ascii-string-downcase line)))
-    (or (> (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line "/>") 0)
-      (> (html-string-count-substring lc-line " (html-string-count-substring lc-line " total 0) (/ count total) 0)
-          (let ((line (car remaining)))
-            (loop (cdr remaining)
-              (if (html-line-contains-features? line) (+ count 1) count)
-              (+ total 1)
-            ) ;loop
-          ) ;let
-        ) ;if
-      ) ;let
-    ) ;if
-  ) ;let
-) ;define
-
-(define (html-structure-balanced? s)
-  (let* ((lc-s (safe-ascii-string-downcase s))
-         (open-tags (html-string-count-substring lc-s " open-tags 0) (> close-tags 0) (<= (abs (- open-tags close-tags)) 2))
-  ) ;let*
-) ;define
-
-(define (determine-short-html-string s)
-  (let* ((len (string-length s)))
-    (cond ((or (and (> (character-from-string s #\<) 0)
-                 (> (character-from-string s #\>) 0)
-                 (> (html-string-count-substring s " (html-string-count-substring (safe-ascii-string-downcase s) "class=") 0)
-             (> (html-string-count-substring (safe-ascii-string-downcase s) "id=") 0)
-             (> (html-string-count-substring (safe-ascii-string-downcase s) "style=") 0)
-             (> (html-string-count-substring (safe-ascii-string-downcase s) "href=") 0)
-             (> (html-string-count-substring (safe-ascii-string-downcase s) "src=") 0)
-           ) ;or
-           #t
-          ) ;
-          ((>= (html-angle-bracket-density s) 0.03) #t)
-          (else #f)
-    ) ;cond
-  ) ;let*
-) ;define
-
-(define (is-short-html-string? s)
-  (if (<= (string-length s) 100) (determine-short-html-string s) #f)
-) ;define
-
-(define (is-html-string? s)
-  (let* ((angle-density (html-angle-bracket-density s))
-         (tag-density (html-tag-density s))
-         (attr-density (html-attribute-density s))
-         (feature-line-density (html-feature-line-density s))
-         (balanced? (html-structure-balanced? s))
-        ) ;
-    (cond ((and (>= angle-density 0.02)
-             (>= tag-density 0.01)
-             (>= feature-line-density 0.25)
-           ) ;and
-           #t
-          ) ;
-          ((and (>= angle-density 0.015)
-             (or (>= tag-density 0.005) (>= attr-density 0.01))
-             (>= feature-line-density 0.15)
-           ) ;and
-           #t
-          ) ;
-          ((and balanced? (>= angle-density 0.01) (>= feature-line-density 0.1)) #t)
-          ((>= angle-density 0.03) #t)
-          (else #f)
-    ) ;cond
-  ) ;let*
-) ;define
-
-(define (html-recognizes-at? s pos)
-  (set! pos (format-skip-spaces s pos))
-  (cond ((format-test? s pos "") #t)
-        ((format-test? s pos "texmacs:latex-annotations" "off")
-) ;define-format
-(lazy-define (convert html htmltm) parse-html-snippet)
-(lazy-define (convert html htmltm) parse-html-document)
-(lazy-define (convert html htmltm) html->texmacs)
-(lazy-define (convert html htmlout) serialize-html)
-(lazy-define (convert html tmhtml) texmacs->html)
-(converter html-document html-stree (:function parse-html-document))
-(converter html-stree html-document (:function serialize-html))
-(converter html-snippet html-stree (:function parse-html-snippet))
-(converter html-stree html-snippet (:function serialize-html))
-(converter html-stree texmacs-stree (:function html->texmacs))
-(converter texmacs-stree
-  html-stree
-  (:function-with-options texmacs->html)
-  (:option "texmacs->html:css" "on")
-  (:option "texmacs->html:mathjax" "off")
-  (:option "texmacs->html:mathml" "on")
-  (:option "texmacs->html:images" "off")
-  (:option "texmacs->html:css-stylesheet" "---")
-) ;converter
diff --git a/TeXmacs/plugins/html/progs/html/css.scm b/TeXmacs/plugins/html/progs/html/css.scm
new file mode 100644
index 0000000000..89da78a9d4
--- /dev/null
+++ b/TeXmacs/plugins/html/progs/html/css.scm
@@ -0,0 +1,86 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : css.scm
+;; DESCRIPTION : tools for manipulation of CSS attributes
+;; COPYRIGHT   : (C) 2020  Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (html css) (:use (html sxml)))
+
+(define (css-style-item->pair s)
+  (with l
+    (string-tokenize-by-char s #\:)
+    (and (== (length l) 2)
+      (cons (tm-string-trim-both (car l)) (tm-string-trim-both (cadr l)))
+    ) ;and
+  ) ;with
+) ;define
+
+(define (css-style->assoc s)
+  (let* ((l1 (string-tokenize-by-char s #\;)) (l2 (map css-style-item->pair l1)))
+    (list-filter l2 (lambda (x) x))
+  ) ;let*
+) ;define
+
+(define (pair->css-style-item p)
+  (string-append (car p) ": " (cdr p))
+) ;define
+
+(define (assoc->css-style a)
+  (with l (map pair->css-style-item a) (string-join l "; "))
+) ;define
+
+(define (css-max l1 l2)
+  (if (and (length? l1) (length? l2)) (length-max l1 l2) l2)
+) ;define
+
+(define (css-add l1 l2)
+  (if (and (length? l1) (length? l2)) (length-add l1 l2) l2)
+) ;define
+
+(define (assoc-change a k v)
+  (cond ((null? a) a)
+        ((== (caar a) k) (cons (cons k v) (cdr a)))
+        (else (cons (car a) (assoc-change (cdr a) k v)))
+  ) ;cond
+) ;define
+
+(define (css-merge-attrs a1 a2)
+  (cond ((null? a1) a2)
+        ((not (assoc-ref a2 (caar a1))) (cons (car a1) (css-merge-attrs (cdr a1) a2)))
+        ((in? (caar a1) '("margin-top" "margin-bottom" "padding-top"
+                          "padding-bottom"))
+         (let* ((k (caar a1))
+                (v (css-max (assoc-ref a1 k) (assoc-ref a2 k)))
+                (a2* (assoc-change a2 k v))
+               ) ;
+           (css-merge-attrs (cdr a1) a2*)
+         ) ;let*
+        ) ;
+        ((in? (caar a1) '("margin-left" "margin-right" "padding-left"
+                          "padding-right"))
+         (let* ((k (caar a1))
+                (v (css-add (assoc-ref a1 k) (assoc-ref a2 k)))
+                (a2* (assoc-change a2 k v))
+               ) ;
+           (css-merge-attrs (cdr a1) a2*)
+         ) ;let*
+        ) ;
+        (else (cons (car a1) (css-merge-attrs (cdr a1) a2)))
+  ) ;cond
+) ;define
+
+(tm-define (css-merge-styles s1 s2)
+  (let* ((a1 (css-style->assoc s1))
+         (a2 (css-style->assoc s2))
+         (a (css-merge-attrs a1 a2))
+        ) ;
+    (assoc->css-style a)
+  ) ;let*
+) ;tm-define
diff --git a/TeXmacs/plugins/html/progs/html/html-format.scm b/TeXmacs/plugins/html/progs/html/html-format.scm
new file mode 100644
index 0000000000..74f1cb4bf0
--- /dev/null
+++ b/TeXmacs/plugins/html/progs/html/html-format.scm
@@ -0,0 +1,353 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : init-html.scm
+;; DESCRIPTION : setup html converters
+;; COPYRIGHT   : (C) 2003  Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (html html-format))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Html
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; HTML 标签/属性名都是 ASCII，用 safe-ascii-string-downcase 做 ASCII-only
+;; 大小写折叠可避免对含损坏 UTF-8 字节的输入触发 string->utf8 整段校验而崩溃。
+
+(define html-detected-limit 1000)
+
+;; 按行分割文本
+
+(define (html-string-split-lines s)
+  (let ((len (if (>= (string-length s) html-detected-limit)
+               html-detected-limit
+               (string-length s)
+             ) ;if
+        ) ;len
+       ) ;
+    (let loop
+      ((i 0) (start 0) (result '()))
+      (cond ((>= i len) (reverse (cons (substring s start i) result)))
+            ((char=? (string-ref s i) #\newline)
+             (loop (+ i 1) (+ i 1) (cons (substring s start i) result))
+            ) ;
+            (else (loop (+ i 1) start result))
+      ) ;cond
+    ) ;let
+  ) ;let
+) ;define
+
+;; 某个字符在文本中的含量
+
+(define (character-from-string s ch)
+  (if (not (string-null? s))
+    (let* ((len (string-length s))
+           (limit (if (>= len html-detected-limit) html-detected-limit len))
+          ) ;
+      (let loop
+        ((ref 0) (count 0))
+        (if (>= ref limit)
+          (/ count len)
+          (loop (+ ref 1) (if (char=? (string-ref s ref) ch) (+ count 1) count))
+        ) ;if
+      ) ;let
+    ) ;let*
+    #f
+  ) ;if
+) ;define
+
+;; 计算一个子串在文本中的含量，计算的是子串的字符数，而不是个数
+
+(define (html-string-count-substring s sub)
+  (let ((sub-len (string-length sub)))
+    (if (zero? sub-len)
+      0
+      (let loop
+        ((i 0) (count 0))
+        (if (>= i (- (string-length s) sub-len -1))
+          count
+          (if (string=? (substring s i (+ i sub-len)) sub)
+            (loop (+ i sub-len) (+ count 1))
+            (loop (+ i 1) count)
+          ) ;if
+        ) ;if
+      ) ;let
+    ) ;if
+  ) ;let
+) ;define
+
+;; < 和 > 的含量
+
+(define (html-angle-bracket-density s)
+  (if (string-null? s)
+    0
+    (let* ((len (string-length s))
+           (limit (if (>= len html-detected-limit) html-detected-limit len))
+           (substr (substring s 0 limit))
+          ) ;
+      (/ (+ (character-from-string substr #\<) (character-from-string substr #\>))
+        len
+      ) ;/
+    ) ;let*
+  ) ;if
+) ;define
+
+;; 完整的tag子串在文本中的字符含量
+
+(define (html-tag-density s)
+  (if (string-null? s)
+    0
+    (let* ((len (string-length s))
+           (limit (if (>= len html-detected-limit) html-detected-limit len))
+           (substr (substring s 0 limit))
+           (lc-substr (safe-ascii-string-downcase substr))
+          ) ;
+      (let ((count (+ (html-string-count-substring lc-substr "= len html-detected-limit) html-detected-limit len))
+           (substr (substring s 0 limit))
+          ) ;
+      (/ (+ (character-from-string substr #\=) (character-from-string substr #\"))
+        len
+      ) ;/
+    ) ;let*
+  ) ;if
+) ;define
+
+(define (html-line-contains-features? line)
+  (let ((lc-line (safe-ascii-string-downcase line)))
+    (or (> (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line " (html-string-count-substring lc-line "/>") 0)
+      (> (html-string-count-substring lc-line " (html-string-count-substring lc-line " total 0) (/ count total) 0)
+          (let ((line (car remaining)))
+            (loop (cdr remaining)
+              (if (html-line-contains-features? line) (+ count 1) count)
+              (+ total 1)
+            ) ;loop
+          ) ;let
+        ) ;if
+      ) ;let
+    ) ;if
+  ) ;let
+) ;define
+
+(define (html-structure-balanced? s)
+  (let* ((lc-s (safe-ascii-string-downcase s))
+         (open-tags (html-string-count-substring lc-s " open-tags 0) (> close-tags 0) (<= (abs (- open-tags close-tags)) 2))
+  ) ;let*
+) ;define
+
+(define (determine-short-html-string s)
+  (let* ((len (string-length s)))
+    (cond ((or (and (> (character-from-string s #\<) 0)
+                 (> (character-from-string s #\>) 0)
+                 (> (html-string-count-substring s " (html-string-count-substring (safe-ascii-string-downcase s) "class=") 0)
+             (> (html-string-count-substring (safe-ascii-string-downcase s) "id=") 0)
+             (> (html-string-count-substring (safe-ascii-string-downcase s) "style=") 0)
+             (> (html-string-count-substring (safe-ascii-string-downcase s) "href=") 0)
+             (> (html-string-count-substring (safe-ascii-string-downcase s) "src=") 0)
+           ) ;or
+           #t
+          ) ;
+          ((>= (html-angle-bracket-density s) 0.03) #t)
+          (else #f)
+    ) ;cond
+  ) ;let*
+) ;define
+
+(define (is-short-html-string? s)
+  (if (<= (string-length s) 100) (determine-short-html-string s) #f)
+) ;define
+
+(define (is-html-string? s)
+  (let* ((angle-density (html-angle-bracket-density s))
+         (tag-density (html-tag-density s))
+         (attr-density (html-attribute-density s))
+         (feature-line-density (html-feature-line-density s))
+         (balanced? (html-structure-balanced? s))
+        ) ;
+    (cond ((and (>= angle-density 0.02)
+             (>= tag-density 0.01)
+             (>= feature-line-density 0.25)
+           ) ;and
+           #t
+          ) ;
+          ((and (>= angle-density 0.015)
+             (or (>= tag-density 0.005) (>= attr-density 0.01))
+             (>= feature-line-density 0.15)
+           ) ;and
+           #t
+          ) ;
+          ((and balanced? (>= angle-density 0.01) (>= feature-line-density 0.1)) #t)
+          ((>= angle-density 0.03) #t)
+          (else #f)
+    ) ;cond
+  ) ;let*
+) ;define
+
+(define (html-recognizes-at? s pos)
+  (set! pos (format-skip-spaces s pos))
+  (cond ((format-test? s pos "") #t)
+        ((format-test? s pos "texmacs:latex-annotations" "off")
+) ;define-format
+(lazy-define (html htmltm) parse-html-snippet)
+(lazy-define (html htmltm) parse-html-document)
+(lazy-define (html htmltm) html->texmacs)
+(lazy-define (html htmlout) serialize-html)
+(lazy-define (html tmhtml) texmacs->html)
+(converter html-document html-stree (:function parse-html-document))
+(converter html-stree html-document (:function serialize-html))
+(converter html-snippet html-stree (:function parse-html-snippet))
+(converter html-stree html-snippet (:function serialize-html))
+(converter html-stree texmacs-stree (:function html->texmacs))
+(converter texmacs-stree
+  html-stree
+  (:function-with-options texmacs->html)
+  (:option "texmacs->html:css" "on")
+  (:option "texmacs->html:mathjax" "off")
+  (:option "texmacs->html:mathml" "on")
+  (:option "texmacs->html:images" "off")
+  (:option "texmacs->html:css-stylesheet" "---")
+) ;converter
diff --git a/TeXmacs/plugins/html/progs/html/htmlout.scm b/TeXmacs/plugins/html/progs/html/htmlout.scm
new file mode 100644
index 0000000000..d6410b16b4
--- /dev/null
+++ b/TeXmacs/plugins/html/progs/html/htmlout.scm
@@ -0,0 +1,218 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : htmlout.scm
+;; DESCRIPTION : generation of Html from scheme expressions
+;; COPYRIGHT   : (C) 2002  Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (html htmlout) (:use (convert tools output)))
+
+(define preformatted? #f)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Data
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-group htmlout-big-all%
+  ;; Both the tag and the children are displayed in multi-line format.
+  html
+  head
+  style
+  body
+  table
+  tr
+  ul
+  ol
+  dl
+  ;; and for MathML
+  mtable
+  mtr
+) ;logic-group
+
+(logic-group htmlout-big-tag%
+  ;; The tag is displayed in multi-line format.
+  div
+  p
+  li
+  dt
+  dd
+  center
+  blockquote
+) ;logic-group
+
+(logic-rule (htmlout-big-tag% 'x) (htmlout-big-all% 'x))
+
+(define (htmlout-big-all? op)
+  (logic-in? op htmlout-big-all%)
+) ;define
+
+(define (htmlout-big-tag? op)
+  (logic-in? op htmlout-big-tag%)
+) ;define
+
+(define (htmlout-big? x)
+  (and (pair? x)
+    (or (htmlout-big-all? (car x))
+      (and (htmlout-big-tag? (car x))
+        (list-any (lambda (x) (and (pair? x) (htmlout-big-tag? (car x)))) (cdr x))
+      ) ;and
+    ) ;or
+  ) ;and
+) ;define
+
+(define (htmlout-p-simplify? x)
+  ;; FIXME: font should not really be in the list here
+  (and (func? x 'p 1)
+    (pair? (cadr x))
+    (in? (caadr x) '(div p li dt dd center blockquote ul ol dl))
+  ) ;and
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Outputting main flow
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (htmlout-indent* s plus close?)
+  (if (not preformatted?)
+    (cond ((htmlout-big-tag? s) (output-indent plus) (output-lf))
+          ((== s 'pre) (if (not close?) (output-lf-verbatim)))
+    ) ;cond
+  ) ;if
+) ;define
+
+(define (htmlout-indent s plus)
+  (htmlout-indent* s plus #f)
+) ;define
+
+(define (htmlout-indent-close s plus)
+  (htmlout-indent* s plus #t)
+) ;define
+
+(define (htmlout-text . ss)
+  (if preformatted? (apply output-verbatim ss) (apply output-text ss))
+) ;define
+
+(define (htmlout-open s)
+  (htmlout-text "<" (symbol->string s) ">")
+  (htmlout-indent s 2)
+) ;define
+
+(define (htmlout-tag x)
+  (if (== (cadr x) "")
+    (output-text " " (symbol->string (car x)))
+    (begin
+      (output-text " " (symbol->string (car x)) "=")
+      (output-verbatim "\"" (cadr x) "\"")
+    ) ;begin
+  ) ;if
+) ;define
+
+(define (htmlout-open-tags s l)
+  (with ll
+    (ahash-table->list (list->ahash-table l))
+    (htmlout-text "<" (symbol->string s))
+    (for-each htmlout-tag ll)
+    ;; If tag is a self-closing (void) element according to HTML5 spec, close it with "/>"
+    ;; "Void elements only have a start tag; end tags must not be specified for void elements."
+    ;; Reference: HTML5 spec, section 13.1.2 - Elements (https://html.spec.whatwg.org/multipage/syntax.html#void-elements)
+    (if (member s '(area base br col embed hr img input link meta source track
+                     wbr))
+      (htmlout-text " />")
+      (htmlout-text ">")
+    ) ;if
+    (htmlout-indent s 2)
+  ) ;with
+) ;define
+
+(define (htmlout-close s)
+  ;; Do not close the tag if it is a self-closing (void) element
+  ;; Reference: HTML5 spec, section 13.1.2 - Elements (https://html.spec.whatwg.org/multipage/syntax.html#void-elements)
+  (if (not (member s '(area base br col embed hr img input link meta source
+                        track wbr))
+      ) ;not
+    (begin
+      (htmlout-indent-close s -2)
+      (htmlout-text "string s) ">")
+    ) ;begin
+  ) ;if
+) ;define
+
+(define (htmlout-args-sub l big?)
+  (if (nnull? l)
+    (begin
+      (htmlout (car l))
+      (if (and big? (nnull? (cdr l))) (output-lf))
+      (htmlout-args-sub (cdr l) big?)
+    ) ;begin
+  ) ;if
+) ;define
+
+(define (htmlout-args s l)
+  (with big? (htmlout-big? (cons s l)) (htmlout-args-sub l big?))
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Main output routines
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (htmlout-doctype l)
+  (output-lf-verbatim "")
+  (output-lf)
+) ;define
+
+(define (htmlout x)
+  (cond ((string? x) (htmlout-text x))
+        ((null? x) (noop))
+        ((or (func? x '!concat) (func? x '*TOP*)) (for-each htmlout (cdr x)))
+        ((htmlout-p-simplify? x) (htmlout (cadr x)))
+        ((func? x '*PI*)
+         (output-lf-verbatim "string (cadr x)) " " (caddr x) "?>")
+         (output-lf)
+        ) ;
+        ((func? x '*DOCTYPE*) (htmlout-doctype (cdr x)))
+        ((== x '(br)) (htmlout-text "
"))
+        ((null? (cdr x)) (htmlout-open (car x)) (htmlout-close (car x)))
+        ((not (func? (cadr x) '@))
+         (htmlout-open (car x))
+         (htmlout-args (car x) (cdr x))
+         (htmlout-close (car x))
+        ) ;
+        (else (htmlout-open-tags (car x) (cdadr x))
+          (update-preformatted (cdadr x) (cut htmlout-args (car x) (cddr x)))
+          (htmlout-close (car x))
+        ) ;else
+  ) ;cond
+) ;define
+
+(define (update-preformatted atts thunk)
+  (let ((saved-preformatted preformatted?)
+        (new-preformatted (cond ((assoc 'xml:space atts)
+                                 =>
+                                 (lambda (att)
+                                   (cond ((== (second att) "preserve") #t)
+                                         ((== (second att) "default") #f)
+                                         (else preformatted?)
+                                   ) ;cond
+                                 ) ;lambda
+                                ) ;
+                                (else preformatted?)
+                          ) ;cond
+        ) ;new-preformatted
+       ) ;
+    (if (== new-preformatted saved-preformatted)
+      (thunk)
+      (dynamic-wind (lambda () (set! preformatted? new-preformatted))
+        thunk
+        (lambda () (set! preformatted? saved-preformatted))
+      ) ;dynamic-wind
+    ) ;if
+  ) ;let
+) ;define
+
+(tm-define (serialize-html x) (htmlout x) (output-produce))
diff --git a/TeXmacs/plugins/html/progs/convert/html/htmltm.scm b/TeXmacs/plugins/html/progs/html/htmltm.scm
similarity index 94%
rename from TeXmacs/plugins/html/progs/convert/html/htmltm.scm
rename to TeXmacs/plugins/html/progs/html/htmltm.scm
index e413dd9a04..5be1a889e7 100644
--- a/TeXmacs/plugins/html/progs/convert/html/htmltm.scm
+++ b/TeXmacs/plugins/html/progs/html/htmltm.scm
@@ -11,16 +11,16 @@
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(texmacs-module (convert html htmltm)
+(texmacs-module (html htmltm)
   (:use (convert tools tmlength)
     (convert tools tmcolor)
     (convert tools old-tmtable)
     (convert tools stm)
-    (convert data sxml)
-    (convert data sxhtml)
+    (html sxml)
+    (html sxhtml)
     (convert tools environment)
-    (convert data xmltm)
-    (convert mathml mathtm)
+    (html xmltm)
+    (html mathtm)
   ) ;:use
 ) ;texmacs-module
 
@@ -200,14 +200,10 @@
       (,"rhs" ,(delay (format-frame "table-rborder")))
       (,"vsides" ,(delay (format-frame "table-lborder" "table-rborder")))
       (,"box"
-       ,(delay (format-frame "table-tborder"
-                 "table-bborder"
-                 "table-lborder"
+       ,(delay (format-frame "table-tborder" "table-bborder" "table-lborder"
                  "table-rborder")))
       (,"border"
-       ,(delay (format-frame "table-tborder"
-                 "table-bborder"
-                 "table-lborder"
+       ,(delay (format-frame "table-tborder" "table-bborder" "table-lborder"
                  "table-rborder"))))
   ) ;define
   (define rules-values-alist
@@ -641,6 +637,23 @@
   ) ;let*
 ) ;define
 
+;; ChatGPT 行间公式判定：style 含 display:block，或首个子节点为 katex-display
+;;
+;; ChatGPT 新版前端（KaTeX 客户端布局）不再输出 katex-mathml / MathML，
+;; LaTeX 源码改放在 role="math" 节点的 data-math-source 属性（aria-label 兜底）；
+;; 源码不含定界符，htmltm-span 按行内/行间包上 \( \) 或 \[ \] 后走标准 LaTeX 导入
+
+(define (htmltm-chatgpt-display? a c)
+  (let ((style (string-replace (or (shtml-attr-non-null a 'style) "") " " "")))
+    (or (string-contains? style "display:block")
+      (and (pair? c)
+        (func? (car c) 'h:span)
+        (== (shtml-attr-non-null (sxml-attr-list (car c)) 'class) "katex-display")
+      ) ;and
+    ) ;or
+  ) ;let
+) ;define
+
 (define (htmltm-span env a c)
   (with class-value
     (shtml-attr-non-null a 'class)
@@ -663,6 +676,25 @@
            ) ;begin
           ) ;
 
+          ((and (== (shtml-attr-non-null a 'role) "math")
+             (or (shtml-attr-non-null a 'data-math-source)
+               (shtml-attr-non-null a 'aria-label)
+             ) ;or
+           ) ;and
+           (let* ((latex-src (or (shtml-attr-non-null a 'data-math-source)
+                               (shtml-attr-non-null a 'aria-label)
+                             ) ;or
+                  ) ;latex-src
+                  (wrapped (if (htmltm-chatgpt-display? a c)
+                             (string-append "\\[ " latex-src " \\]")
+                             (string-append "\\( " latex-src " \\)")
+                           ) ;if
+                  ) ;wrapped
+                 ) ;
+             (list (tm->stree (latex->texmacs (parse-latex wrapped))))
+           ) ;let*
+          ) ;
+
           ((and (== class-value "ztext-math"))
            (begin
              (let ((parsed-formula (tm->stree (latex->texmacs (parse-latex (shtml-attr-non-null a 'data-tex))))
diff --git a/TeXmacs/plugins/html/progs/html/mathml-drd.scm b/TeXmacs/plugins/html/progs/html/mathml-drd.scm
new file mode 100644
index 0000000000..fd98f3a7b9
--- /dev/null
+++ b/TeXmacs/plugins/html/progs/html/mathml-drd.scm
@@ -0,0 +1,688 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : mathml-drd.scm
+;; DESCRIPTION : DRD properties for MathML
+;; COPYRIGHT   : (C) 2004  Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (html mathml-drd))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Ordinary symbols
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-table tm->mathml-constant%
+ ("" "C")
+ ("" "e")
+ ("" "&eulergamma;")
+ ("" "ⅈ")
+ ("" "π")
+) ;logic-table
+
+(logic-table mathml-constant->tm%
+ ("&eulergamma;" "")
+ ("ⅈ" "")
+ ("ⅈ" "")
+ ("π" "")
+ ("&true;" "true")
+ ("&false;" "false")
+ ("ϕ" "")
+ ("ℓ" "")
+ ("ℂ" "")
+ ("ℚ" "")
+ ("ℤ" "")
+ ("ℝ" "")
+) ;logic-table
+
+(logic-table tm->mathml-operator%
+ ("&" "&")
+ ("" "<")
+ ("*" "⁢")
+ (" " "⁡")
+) ;logic-table
+
+(logic-table mathml-operator->tm%
+ ("⁢" "*")
+ ("*" "*")
+ ("−" "-")
+ ("⃛" "")
+ ("˚" "")
+ ("´" "")
+ ("`" "")
+ ("¯" "¯")
+ ("‾" "¯")
+ ("̲" "¯")
+ ("⃗" "")
+ ("̑" "")
+ ("ˇ" "")
+ ("˘" "")
+ ("⏞" "")
+ ("︷" "")
+ ("⏟" "")
+ ("︸" "")
+ ("⎴" "")
+ ("﹇" "")
+ ("﹈" "")
+ ("⎵" "")
+ ("⏜" "")
+ ("︵" "")
+ ("⏝" "")
+ ("︶" "")
+ ("︿" "^")
+ ("﹀" "")
+
+ ("⁢" "*")
+ ("±" "")
+ ("⁢" "*")
+ ("≤" "")
+ ("≥" "")
+ ("→" "")
+ ("‾" "¯")
+
+ ("ⅆ" "")
+ ("∑" "")
+ ("ϕ" "")
+ ("∂" "")
+ ("⏟" "")
+ ("⏞" "")
+ ("ⅇ" "")
+ ("+" "+")
+ ("−" "-")
+ ("×" "")
+ ("÷" "
")
+ ("=" "=")
+ ("≠" "")
+ ("±" "")
+ ("¬" "")
+ (">" "")
+ ("°" "<#00B0>")
+ ("⋃" (big "cup"))
+ ("⋂" (big "cap"))
+ ("∫" (big "int"))
+ ("ℋ" "<#210B>")
+ ("ℎ" "<#210E>")
+ ("ℏ" "")
+ ("ℑ" "<#2111>")
+ ("℘" "<#2118>")
+ ("ℜ" "<#211C>")
+ ("℧" "<#2127>")
+ ("℩" "<#2129>")
+ ("ℬ" "<#212C>")
+ ("ℵ" "<#2135>")
+ ("ℶ" "<#2136>")
+ ("ℷ" "<#2137>")
+ ("ℸ" "<#2138>")
+ ("ⅅ" "")
+ ("ⅆ" "")
+ ("★" "<#2605>")
+ ("☆" "<#2606>")
+ ("◊" "<#25CA>")
+ ("♪" "<#266A>")
+ ("♭" "<#266D>")
+ ("♮" "<#266E>")
+ ("♯" "<#266F>")
+ ("✓" "<#2713>")
+ ("✗" "<#2717>")
+ ("✠" "<#2720>")
+ ("✶" "<#2736>")
+ ("❘" "<#2758>")
+ ("!" "<#0021>")
+ ("#" "<#0023>")
+ ("%" "<#0025>")
+ ("(" "<#0028>")
+ (")" "<#0029>")
+ ("*" "<#002A>")
+ ("," "<#002C>")
+ ("." "<#002E>")
+ ("/" "<#002F>")
+ (":" "<#003A>")
+ (";" "<#003B>")
+ ("?" "<#003F>")
+ ("[" "<#005B>")
+ ("\" "<#005C>")
+ ("]" "<#005D>")
+ ("^" "<#005E>")
+ ("_" "<#005F>")
+ ("`" "<#0060>")
+ ("{" "<#007B>")
+ ("|" "<#007C>")
+ ("}" "<#007D>")
+ ("˜" "<#007E>")
+ ("ˆ" "<#02C6>")
+ (" " "<#00A0>")
+ (" " "<#2002>")
+ (" " "<#2003>")
+ (" " "<#2009>")
+ ("‌" "<#200C>")
+ ("‍" "<#200D>")
+ ("¡" "<#00A1>")
+ ("¦" "<#00A6>")
+ ("§" "<#00A7>")
+ ("¨" "<#00A8>")
+ ("ª" "<#00AA>")
+ ("­" "<#00AD>")
+ ("¯" "<#00AF>")
+ ("´" "<#00B4>")
+ ("µ" "<#00B5>")
+ ("¶" "<#00B6>")
+ ("·" "<#00B7>")
+ ("¸" "<#00B8>")
+ ("º" "<#00BA>")
+ ("¿" "<#00BF>")
+ ("‐" "<#2010>")
+ ("–" "<#2013>")
+ ("—" "<#2014>")
+ ("―" "<#2015>")
+ ("‖" "<#2016>")
+ ("†" "<#2020>")
+ ("‡" "<#2021>")
+ ("•" "<#2022>")
+ ("‥" "<#2025>")
+ ("…" "<#2026>")
+ ("‰" "<#2030>")
+ ("‱" "<#2031>")
+ ("′" "<#2032>")
+ ("″" "<#2033>")
+ ("‴" "<#2034>")
+ ("‵" "<#2035>")
+ ("‾" "¯")
+ ("⁁" "<#2041>")
+ ("⁃" "<#2043>")
+ ("⁄" "/")
+ ("¹" "<#00B9>")
+ ("²" "<#00B2>")
+ ("³" "<#00B3>")
+ ("ƒ" "<#0192>")
+ ("%" "<#0025>")
+ ("‰" "<#2030>")
+ ("‱" "<#2031>")
+ ("∀" "<#2200>")
+ ("∁" "<#2201>")
+ ("∂" "")
+ ("∃" "<#2203>")
+ ("∄" "<#2204>")
+ ("∅" "<#2205>")
+ ("∇" "<#2207>")
+ ("∈" "<#2208>")
+ ("∉" "<#2209>")
+ ("∋" "<#220B>")
+ ("∌" "<#220C>")
+ ("∏" (big "prod"))
+ ("∐" (big "amalg"))
+ ("∑" (big "sum"))
+ ("∓" )
+ ("∖" "<#2216>")
+ ("∗" "<#2217>")
+ ("∘" "")
+ ("√" "<#221A>")
+ ("∝" "<#221D>")
+ ("∞" "<#221E>")
+ ("∟" "<#221F>")
+ ("∠" "<#2220>")
+ ("∣" "<#2223>")
+ ("∥" "<#2225>")
+ ("∧" "<#2227>")
+ ("∨" "<#2228>")
+ ("∩" "<#2229>")
+ ("∪" "<#222A>")
+ ("∫" "<#222B>")
+ ("∬" "<#222C>")
+ ("∭" "<#222D>")
+ ("∮" "<#222E>")
+ ("∯" "<#222F>")
+ ("∰" "<#2230>")
+ ("∴" "<#2234>")
+ ("∵" "<#2235>")
+ ("∶" "<#2236>")
+ ("∷" "<#2237>")
+ ("∻" "<#223B>")
+ ("∼" "<#223C>")
+ ("∽" "<#223D>")
+ ("∾" "<#223E>")
+ ("∿" "<#223F>")
+ ("≃" "<#2243>")
+ ("≄" "<#2244>")
+ ("≅" "<#2245>")
+ ("≆" "<#2246>")
+ ("≇" "<#2247>")
+ ("≈" "<#2248>")
+ ("≉" "<#2249>")
+ ("≊" "<#224A>")
+ ("≍" "<#224D>")
+ ("≎" "<#224E>")
+ ("≏" "<#224F>")
+ ("≖" "<#2256>")
+ ("≗" "<#2257>")
+ ("≡" "<#2261>")
+ ("≢" "<#2262>")
+ ("≤" "<#2264>")
+ ("≥" "<#2265>")
+ ("≦" "<#2266>")
+ ("≧" "<#2267>")
+ ("≨" "<#2268>")
+ ("≩" "<#2269>")
+ ("≪" "<#226A>")
+ ("≫" "<#226B>")
+ ("≭" "<#226D>")
+ ("≮" "<#226E>")
+ ("≯" "<#226F>")
+ ("≰" "<#2270>")
+ ("≱" "<#2271>")
+ ("≲" "<#2272>")
+ ("≳" "<#2273>")
+ ("≴" "<#2274>")
+ ("≵" "<#2275>")
+ ("≺" "<#227A>")
+ ("≻" "<#227B>")
+ ("≼" "<#227C>")
+ ("≽" "<#227D>")
+ ("≾" "<#227E>")
+ ("≿" "<#227F>")
+ ("⊀" "<#2280>")
+ ("⊁" "<#2281>")
+ ("⊂" "<#2282>")
+ ("⊃" "<#2283>")
+ ("⊄" "<#2284>")
+ ("⊅" "<#2285>")
+ ("⊆" "<#2286>")
+ ("⊇" "<#2287>")
+ ("⊈" "<#2288>")
+ ("⊉" "<#2289>")
+ ("⊊" "<#228A>")
+ ("⊋" "<#228B>")
+ ("⊎" "<#228E>")
+ ("⊏" "<#228F>")
+ ("⊐" "<#2290>")
+ ("⊑" "<#2291>")
+ ("⊒" "<#2292>")
+ ("⊓" "<#2293>")
+ ("⊔" "<#2294>")
+ ("⊕" "<#2295>")
+ ("⊖" "<#2296>")
+ ("⊗" "<#2297>")
+ ("⊘" "<#2298>")
+ ("⊙" "<#2299>")
+ ("⊚" "<#229A>")
+ ("⊛" "<#229B>")
+ ("⊝" "<#229D>")
+ ("⊞" "<#229E>")
+ ("⊟" "<#229F>")
+ ("⊠" "<#22A0>")
+ ("⊡" "<#22A1>")
+ ("⊢" "<#22A2>")
+ ("⊣" "<#22A3>")
+ ("⊤" "<#22A4>")
+ ("⊥" "<#22A5>")
+ ("⊧" "<#22A7>")
+ ("⊨" "<#22A8>")
+ ("⊩" "<#22A9>")
+ ("⊪" "<#22AA>")
+ ("⊰" "<#22B0>")
+ ("⊲" "<#22B2>")
+ ("⊳" "<#22B3>")
+ ("⊴" "<#22B4>")
+ ("⊵" "<#22B5>")
+ ("⊹" "<#22B9>")
+ ("⋀" "<#22C0>")
+ ("⋁" "<#22C1>")
+ ("⋂" "<#22C2>")
+ ("⋃" "<#22C3>")
+ ("⋄" "<#22C4>")
+ ("⋅" "<#22C5>")
+ ("⋆" "<#22C6>")
+ ("⋉" "<#22C9>")
+ ("⋊" "<#22CA>")
+ ("⋋" "<#22CB>")
+ ("⋌" "<#22CC>")
+ ("⋍" "<#22CD>")
+ ("⋎" "<#22CE>")
+ ("⋏" "<#22CF>")
+ ("⋐" "<#22D0>")
+ ("⋑" "<#22D1>")
+ ("⋒" "<#22D2>")
+ ("⋓" "<#22D3>")
+ ("⋘" "<#22D8>")
+ ("⋙" "<#22D9>")
+ ("⋞" "<#22DE>")
+ ("⋟" "<#22DF>")
+ ("⋠" "<#22E0>")
+ ("⋡" "<#22E1>")
+ ("⋢" "<#22E2>")
+ ("⋣" "<#22E3>")
+ ("⋦" "<#22E6>")
+ ("⋧" "<#22E7>")
+ ("⋨" "<#22E8>")
+ ("⋩" "<#22E9>")
+ ("⋪" "<#22EA>")
+ ("⋫" "<#22EB>")
+ ("⋬" "<#22EC>")
+ ("⋭" "<#22ED>")
+ ("⋮" "<#22EE>")
+ ("⋯" "<#22EF>")
+ ("⋰" "<#22F0>")
+ ("⋱" "<#22F1>")
+ ("⋲" "<#22F2>")
+ ("⌈" "<#2308>")
+ ("⌉" "<#2309>")
+ ("⌊" "<#230A>")
+ ("⌋" "<#230B>")
+ ("⟨" "<#2329>")
+ ("⟩" "<#232A>")
+ ("Α" "<#0391>")
+ ("Β" "<#0392>")
+ ("Γ" "<#0393>")
+ ("Δ" "<#0394>")
+ ("Ε" "<#0395>")
+ ("Ζ" "<#0396>")
+ ("Η" "<#0397>")
+ ("Θ" "<#0398>")
+ ("Ι" "<#0399>")
+ ("Κ" "<#039A>")
+ ("Λ" "<#039B>")
+ ("Μ" "<#039C>")
+ ("Ν" "<#039D>")
+ ("Ξ" "<#039E>")
+ ("Ο" "<#039F>")
+ ("Π" "<#03A0>")
+ ("Ρ" "<#03A1>")
+ ("Σ" "<#03A3>")
+ ("Τ" "<#03A4>")
+ ("Υ" "<#03A5>")
+ ("Φ" "<#03A6>")
+ ("Χ" "<#03A7>")
+ ("Ψ" "<#03A8>")
+ ("Ω" "<#03A9>")
+ ("α" "<#03B1>")
+ ("β" "<#03B2>")
+ ("γ" "<#03B3>")
+ ("δ" "<#03B4>")
+ ("ε" "<#03B5>")
+ ("ζ" "<#03B6>")
+ ("η" "<#03B7>")
+ ("θ" "<#03B8>")
+ ("ι" "<#03B9>")
+ ("κ" "<#03BA>")
+ ("λ" "<#03BB>")
+ ("μ" "<#03BC>")
+ ("ν" "<#03BD>")
+ ("ξ" "<#03BE>")
+ ("ο" "<#03BF>")
+ ("ρ" "<#03C1>")
+ ("ς" "<#03C2>")
+ ("σ" "<#03C3>")
+ ("τ" "<#03C4>")
+ ("υ" "<#03C5>")
+ ("φ" "<#03C6>")
+ ("χ" "<#03C7>")
+ ("ψ" "<#03C8>")
+ ("ω" "<#03C9>")
+ ("ϑ" "<#03D1>")
+ ("ϒ" "<#03D2>")
+ ("ϖ" "<#03D6>")
+ ("↺" "<#21BA>")
+ ("↻" "<#21BB>")
+ ("↼" "<#21BC>")
+ ("↽" "<#21BD>")
+ ("↾" "<#21BE>")
+ ("↿" "<#21BF>")
+ ("⇀" "<#21C0>")
+ ("⇁" "<#21C1>")
+ ("⇂" "<#21C2>")
+ ("⇃" "<#21C3>")
+ ("⇄" "<#21C4>")
+ ("⇅" "<#21C5>")
+ ("⇆" "<#21C6>")
+ ("⇇" "<#21C7>")
+ ("⇈" "<#21C8>")
+ ("⇉" "<#21C9>")
+ ("⇊" "<#21CA>")
+ ("⇋" "<#21CB>")
+ ("⇌" "<#21CC>")
+ ("⇐" "<#21D0>")
+ ("⇑" "<#21D1>")
+ ("⇒" "<#21D2>")
+ ("⇓" "<#21D3>")
+ ("⇔" "<#21D4>")
+ ("⇕" "<#21D5>")
+ ("⇖" "<#21D6>")
+ ("⇗" "<#21D7>")
+ ("⇘" "<#21D8>")
+ ("⇙" "<#21D9>")
+ ("⇚" "<#21DA>")
+ ("⇛" "<#21DB>")
+ ("&ziglarr;" "<#21DC>")
+ ("⇝" "<#21DD>")
+ ("⇤" "<#21E4>")
+ ("⇥" "<#21E5>")
+ ("⇵" "<#21F5>")
+ ("⟵" "<#27F5>")
+ ("⟶" "<#27F6>")
+ ("⟷" "<#27F7>")
+ ("⟸" "<#27F8>")
+ ("⟹" "<#27F9>")
+ ("⟺" "<#27FA>")
+ ("⟿" "<#27FF>")
+ ("⟼" "<#27FC>")
+ ("⥊" "<#294A>")
+ ("⥋" "<#294B>")
+ ("⥏" "<#294F>")
+ ("⥐" "<#2950>")
+ ("⥑" "<#2951>")
+ ("⥮" "<#296E>")
+ ("⥯" "<#296F>")
+ ("ð" "<#00F0>")
+ ("þ" "<#00FE>")
+ ("Đ" "<#0110>")
+ ("đ" "<#0111>")
+ ("Ħ" "<#0126>")
+ ("ħ" "<#0127>")
+ ("ı" "<#0131>")
+ ("ĸ" "<#0138>")
+ ("Ł" "<#0141>")
+ ("ł" "<#0142>")
+ ("Ŋ" "<#014A>")
+ ("ŋ" "<#014B>")
+ ("Ŧ" "<#0166>")
+ ("ŧ" "<#0167>")
+ ("̑" "<#0311>")
+ ("♀" "<#02640>")
+ ("♂" "<#02642>")
+ ("⟺" "<#027FA>")
+ ("⇒" "<#021D2>")
+ ("⟶" "<#027F6>")
+ ("ℵ" "<#02135>")
+ ("↑" "<#02191>")
+ ("∏" "<#0220F>")
+ ("ⅇ" "")
+
+) ;logic-table
+
+(logic-table mathml-symbol->tm%
+ ("…" "")
+ (" " (hspace "0.1666667em"))
+ (" " (hspace "0.2222222em"))
+ ("  " (hspace "0.2777778em"))
+ (" " (hspace "1em"))
+ (" " (hspace "1en"))
+) ;logic-table
+
+(logic-table mathml-above->tm%
+ ("" "")
+ ("" "")
+ ("" "")
+ ("" "")
+ ("" "")
+ ("" "")
+) ;logic-table
+
+(logic-table mathml-below->tm%
+ ("" "")
+ ("" "")
+ ("" "")
+ ("" "")
+ ("" "")
+ ("" "")
+) ;logic-table
+
+(logic-table mathml-above-below->tm%
+ ("" "")
+ ("" "")
+ ("" "")
+ ("^" "^")
+ ("~" "~")
+ ("¯" "")
+ ("" "")
+ ("" "")
+ ("" "")
+ ("" "")
+ ("" "")
+) ;logic-table
+
+
+
+(logic-rules ((mathml-operator->tm% 'x 'y) (tm->mathml-operator% 'y 'x))
+ ((mathml-symbol->tm% 'x 'y) (mathml-constant->tm% 'x 'y))
+ ((mathml-symbol->tm% 'x 'y) (mathml-operator->tm% 'x 'y))
+ ((mathml-below->tm% 'x 'y) (mathml-above-below->tm% 'x 'y))
+ ((mathml-above->tm% 'x 'y) (mathml-above-below->tm% 'x 'y))
+) ;logic-rules
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Special symbols
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-table tm->mathml-left%
+ ("(" "(")
+ ("[" "[")
+ ("{" "{")
+ ("langle" "⟨")
+ ("lfloor" "⌊")
+ ("lceil" "⌈")
+ ("llbracket" "⟦")
+ ("/" "/")
+) ;logic-table
+
+(logic-table tmtm-left%
+  ;; For HTML entities ⌊, &lceil, etc.
+  ("" "lfloor")
+  ("" "lceil")
+  ("" "langle")
+) ;logic-table
+
+(logic-table tm->mathml-right%
+ (")" ")")
+ ("]" "]")
+ ("}" "}")
+ ("rangle" "⟩")
+ ("rfloor" "⌋")
+ ("rceil" "⌉")
+ ("rrbracket" "⟧")
+ ("\\\\" "∖")
+) ;logic-table
+
+(logic-table tmtm-right%
+  ;; For HTML entities ⌋, &rceil, etc.
+  ("" "rfloor")
+  ("" "rceil")
+  ("" "rangle")
+) ;logic-table
+
+(logic-table tm->mathml-big%
+ ("sum" "∑")
+ ("prod" "∏")
+ ("int" "∫")
+ ("iint" "∬")
+ ("iiint" "∭")
+ ("oiint" "∯")
+ ("oiiint" "∰")
+ ("oint" "∮")
+ ("amalg" "∐")
+ ("cap" "⋂")
+ ("cup" "⋃")
+ ("wedge" "⋀")
+ ("vee" "⋁")
+ ("odot" "⊙")
+ ("oplus" "⊕")
+ ("otimes" "⊗")
+ ("sqcap" "⊓")
+ ;; FIXME: displayed too small
+ ("sqcup" "⊔")
+ ;; FIXME: displayed too small
+ ;; ("curlywedge" "&CurlyWedge;")
+ ;; ("curlyvee" "&CurlyVee;")
+ ;; ("triangleup" "&TriangleUp;")
+ ;; ("triangledown" "&TriangleDown;")
+ ;; ("box" "&Box;")
+ ("pluscup" "⊎")
+ ;; ("parallel" "&Parallel;")
+ ;; ("interleave" "&Interleave;")
+) ;logic-table
+
+(logic-table tmtm-big%
+  ;; For HTML entities ∑, ∏, etc.
+  ("" "sum")
+  ("" "prod")
+  ("" "int")
+) ;logic-table
+
+(logic-table tm->mathml-above-below%
+ ("^" "^")
+ ("~" "∼")
+ ("" "‾")
+ ("" "⇀")
+ ("" "ˇ")
+ ("" "˘")
+ ("" "̑")
+ ("" "´")
+ ("" "`")
+ ("" "˙")
+ ("" "¨")
+ ;;  ("" "&AboveRing;")
+ ("" "→")
+ ("" "←")
+) ;logic-table
+
+(logic-table tm->mathml-only-above%
+ ("" "⏞")
+ ("" "⏟")
+ ("" "⏜")
+ ("" "⏝")
+ ("" "⎴")
+ ("" "⎵")
+) ;logic-table
+
+(logic-table tm->mathml-only-below%
+ ("" "⏞")
+ ("" "⏟")
+ ("" "⏜")
+ ("" "⏝")
+ ("" "⎴")
+ ("" "⎵")
+) ;logic-table
+
+(logic-rules ((tm->mathml-large% 'x 'y) (tm->mathml-left% 'x 'y))
+ ((tm->mathml-large% 'x 'y) (tm->mathml-right% 'x 'y))
+ ((mathml-left->tm% 'x 'y) (tm->mathml-left% 'y 'x))
+ ((mathml-right->tm% 'x 'y) (tm->mathml-right% 'y 'x))
+ ((mathml-large->tm% 'x 'y) (mathml-left->tm% 'x 'y))
+ ((mathml-large->tm% 'x 'y) (mathml-right->tm% 'x 'y))
+ ((mathml-big->tm% 'x 'y) (tm->mathml-big% 'y 'x))
+ ((tm->mathml-above% 'x 'y) (tm->mathml-only-above% 'x 'y))
+ ((tm->mathml-above% 'x 'y) (tm->mathml-above-below% 'x 'y))
+ ((tm->mathml-below% 'x 'y) (tm->mathml-only-below% 'x 'y))
+ ((tm->mathml-below% 'x 'y) (tm->mathml-above-below% 'x 'y))
+ ((tm->mathml-wide*% 'x 'y) (tm->mathml-only-below% 'x 'y))
+ ((tm->mathml-wide*% 'x 'y) (tm->mathml-only-above% 'x 'y))
+ ((tm->mathml-wide*% 'x 'y) (tm->mathml-above-below% 'x 'y))
+ ((tm->mathml-wide% 'x 'y) (tm->mathml-wide*% 'x 'y))
+ ((tm->mathml-wide% "" "‾"))
+ ((mathml-above->tm% 'x 'y) (tm->mathml-above% 'y 'x))
+ ((mathml-below->tm% 'x 'y) (tm->mathml-below% 'y 'x))
+ ((mathml-wide->tm% 'x 'y) (tm->mathml-wide*% 'y 'x))
+) ;logic-rules
diff --git a/TeXmacs/plugins/html/progs/convert/mathml/mathtm-test.scm b/TeXmacs/plugins/html/progs/html/mathtm-test.scm
similarity index 94%
rename from TeXmacs/plugins/html/progs/convert/mathml/mathtm-test.scm
rename to TeXmacs/plugins/html/progs/html/mathtm-test.scm
index 17b72320c5..21742dd2c1 100644
--- a/TeXmacs/plugins/html/progs/convert/mathml/mathtm-test.scm
+++ b/TeXmacs/plugins/html/progs/html/mathtm-test.scm
@@ -11,7 +11,7 @@
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(texmacs-module (convert mathml mathtm-test) (:use (convert html htmltm)))
+(texmacs-module (html mathtm-test) (:use (html htmltm)))
 
 (import (liii check))
 
diff --git a/TeXmacs/plugins/html/progs/html/mathtm.scm b/TeXmacs/plugins/html/progs/html/mathtm.scm
new file mode 100644
index 0000000000..ed13ae329b
--- /dev/null
+++ b/TeXmacs/plugins/html/progs/html/mathtm.scm
@@ -0,0 +1,790 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : mathtm.scm
+;; DESCRIPTION : conversion of MathML trees to TeXmacs trees
+;; COPYRIGHT   : (C) 2002, 2005 Joris van der Hoeven and David Allouche
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; -- MathML notes --
+;;
+;; . Linking is defined by XLink.
+;; . mtr and mtd may be inferred for compat with MathML1
+;; . transfinite symbols are U+2135-U+2138
+;; . how to render empty tokens?
+;; . how to render whitespace in tokens?
+
+;; . mathvariant affect comparison of chars corresponding to SMP conterparts
+
+;; . slanting rules of  match rules of texmacs
+;; . ... might be rendered as ldots, check if it is a MathML char
+;; . only a very reduced subset of  can be natively supported
+;; .  containing text cannot be supported
+;; . nesting of  can denote range of delimiters in 
+;; . texmacs cannot do \widearrow (script under extensible arrow)
+;; .  containing text may be rendered as nested text delimited by spaces
+;;   (see 3.2.6.4)
+
+;; !!! Check semantic of mathvariant on multiple symbols !!!
+
+(texmacs-module (html mathtm)
+  (:use (convert tools tmtable) (html sxml) (html xmltm) (html mathml-drd))
+) ;texmacs-module
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Special
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (mathtm-math env a c)
+  (let* ((m (mathtm-args-serial env c))
+         (r (tree->stree (upgrade-mathml m)))
+         (r (replace-symbol-in-stree r 'around 'around*))
+         (displayed? (attribute-is? a 'display "block"))
+        ) ;
+    (if displayed? `((document (equation* ,r))) `((math ,r)))
+  ) ;let*
+) ;define
+
+(define (attribute-is? a key value)
+  (if (null? a)
+    #f
+    (if (and (pair? (car a)) (func? (car a) key 1) (== (cadar a) value))
+      #t
+      (attribute-is? (cdr a) key value)
+    ) ;if
+  ) ;if
+) ;define
+
+(define (attribute-val a key)
+  (if (null? a)
+    #f
+    (if (and (pair? (car a)) (func? (car a) key 1))
+      (cadar a)
+      (attribute-val (cdr a) key)
+    ) ;if
+  ) ;if
+) ;define
+
+(define (replace-symbol-in-stree st from to)
+  (cond ((== st from) to)
+        ((list? st) (map (lambda (x) (replace-symbol-in-stree x from to)) st))
+        (else st)
+  ) ;cond
+) ;define
+
+
+(define (mathtm-none env a c)
+  '()
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Literals
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (mathtm-string env s)
+  ;; FIXME: use translators or parser for this!!!
+  ;; TODO: learn when the trailing ';' is optional
+  (cond ((logic-ref mathml-symbol->tm% s) => identity)
+        ((string-starts? s "&") (entity->tm s))
+        (else (xmltm-text s))
+  ) ;cond
+) ;define
+
+(define (mathtm-mo env a c)
+  (cond ((null? c) '())
+        ((or (nnull? (cdr c)) (nstring? (car c))) (list (mathtm-args-serial env c)))
+        (else (let* ((s (car c)) (r (xmltm-text s)))
+                (cond ((logic-ref mathml-left->tm% s) => (lambda (x) `((left ,x))))
+                      ((logic-ref mathml-right->tm% s) => (lambda (x) `((right ,x))))
+                      ((logic-ref mathml-big->tm% s) => (lambda (x) `((big ,x))))
+                      ((logic-ref mathml-symbol->tm% s) => (lambda (x) `(,x)))
+                      ((logic-ref tmtm-left% r) => (lambda (x) `((left ,x))))
+                      ((logic-ref tmtm-right% r) => (lambda (x) `((right ,x))))
+                      ((logic-ref tmtm-big% r) => (lambda (x) `((big ,x))))
+                      ((string-starts? s "&") `(,(entity->tm s)))
+                      (else (list r))
+                ) ;cond
+              ) ;let*
+        ) ;else
+  ) ;cond
+) ;define
+
+(define (entity->tm s)
+  (let* ((l (string-length s))
+         (typ (cond ((and (== l 6) (== (string-take-right s 4) "opf;")) "") s)
+  ) ;let*
+) ;define
+
+(define (mathtm-mtext env a c)
+  `((with ,"mode" ,"text" ,(mathtm-args-serial env c)))
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Simple mathematical constructs
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (mathtm-mfrac env a c)
+  (if (== (length c) 2)
+    (with lt
+      (attribute-val a 'linethickness)
+      (if (and lt (length-zero? lt))
+        `((stack (tformat (table (row (cell ,(mathtm-as-serial env (first c))))
+                            (row (cell ,(mathtm-as-serial env (second c))))))))
+        `((frac ,(mathtm-as-serial env (first c))
+            ,(mathtm-as-serial env (second c))))
+      ) ;if
+    ) ;with
+    (mathtm-error "bad mfrac")
+  ) ;if
+) ;define
+
+(define (mathtm-msqrt env a c)
+  `((sqrt ,(mathtm-args-serial env c)))
+) ;define
+
+(define (mathtm-mroot env a c)
+  (if (== (length c) 2)
+    `((sqrt ,(mathtm-as-serial env (first c))
+        ,(mathtm-as-serial env (second c))))
+    (mathtm-error "bad mroot")
+  ) ;if
+) ;define
+
+(define (mathtm-error message)
+  `((with ,"color" ,"red" ,message))
+) ;define
+
+(define (mathtm-merror env a c)
+  (matthtm-error (mathtm-mrow env a c))
+) ;define
+
+
+(define (mathtm-mphantom env a c)
+  `((phantom ,(mathtm-args-serial env c)))
+) ;define
+
+(define (mathtm-sep-list l seps)
+  (cond ((null? l) l)
+        ((null? seps) l)
+        (else (cons* (car l) `(m:mo ,(car seps)) (mathtm-sep-list (cdr l) (cdr seps))))
+  ) ;cond
+) ;define
+
+(define (mathtm-mfenced env a c)
+  (let* ((open (car (or (assoc-ref a 'open) '("("))))
+         (close (car (or (assoc-ref a 'close) '(")"))))
+         (seps (string-tokenize-by-char (car (or (assoc-ref a 'separators) '(""))) #\space)
+         ) ;seps
+        ) ;
+    (if (== seps '("")) (set! seps '()))
+    (mathtm env `(m:mrow (m:mo ,open) ,@(mathtm-sep-list c seps) (m:mo ,close)))
+  ) ;let*
+) ;define
+
+(define (mathtm-menclose env a c)
+  (let* ((args (mathtm-args env c))
+         (notation (car (or (assoc-ref a 'notation) '(""))))
+         (l (if (== notation "") '() (string-tokenize-by-char notation #\space)))
+        ) ;
+    (if (in? "updiagonalstrike" l) `((neg ,(mathtm-serial env args))) args)
+  ) ;let*
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Scripts
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (mathtm-prime-sub? s)
+  (or (== s "'") (== s "`") (== s ""))
+) ;define
+
+(define (mathtm-prime? s)
+  (and (string? s) (list-every mathtm-prime-sub? (tmconcat-tokenize-math s)))
+) ;define
+
+(define (mathtm-superscript type1 type2 sup)
+  (if (mathtm-prime? sup) (list type2 sup) (list type1 sup))
+) ;define
+
+(define (mathtm-scripts base lsub lsup rsub rsup)
+  (if lsub (set! base (cons `(lsub ,lsub) base)))
+  (if lsup (set! base (cons (mathtm-superscript 'lsup 'lprime lsup) base)))
+  (if rsub (set! base (rcons base `(rsub ,rsub))))
+  (if rsup (set! base (rcons base (mathtm-superscript 'rsup 'rprime rsup))))
+  base
+) ;define
+
+(define (mathtm-mo-string t)
+  (if (and (list? t) (or (func? t 'mo) (func? t 'm:mo)))
+    (with c (sxml-content t) (if (and (list-1? c) (string? (car c))) (car c) #f))
+    #f
+  ) ;if
+) ;define
+
+(define (mathtm-opening-delimiter? t)
+  (in? (mathtm-mo-string t) '("(" "[" "{"))
+) ;define
+
+(define (mathtm-closing-delimiter? t)
+  (in? (mathtm-mo-string t) '(")" "]" "}"))
+) ;define
+
+(define (mathtm-delimited-script? l)
+  (and (nnull? l)
+    (mathtm-opening-delimiter? (car l))
+    (mathtm-closing-delimiter? (last l))
+  ) ;and
+) ;define
+
+(define (mathtm-msubsup-split l)
+  (let ((n (length l)))
+    (cond ((== n 2) (values (list (first l)) (list (second l))))
+          ((mathtm-delimited-script? (cdr l)) (values (list (first l)) (cdr l)))
+          (else (values (sublist l 0 (- n 1)) (sublist l (- n 1) n)))
+    ) ;cond
+  ) ;let
+) ;define
+
+(define (mathtm-msub env a c)
+  (if (>= (length c) 2)
+    (let ((base (mathtm env (first c))) (sub (mathtm-args-serial env (cdr c))))
+      (mathtm-scripts base #f #f sub #f)
+    ) ;let
+    (mathtm-error "bad msub")
+  ) ;if
+) ;define
+
+(define (mathtm-msup env a c)
+  (if (>= (length c) 2)
+    (let ((base (mathtm env (first c))) (sup (mathtm-args-serial env (cdr c))))
+      (mathtm-scripts base #f #f #f sup)
+    ) ;let
+    (mathtm-error "bad msup")
+  ) ;if
+) ;define
+
+(define (mathtm-msubsup env a c)
+  (if (>= (length c) 3)
+    (let ((base (mathtm env (first c))))
+      (receive (sub-c sup-c)
+        (mathtm-msubsup-split (cdr c))
+        (let ((sub (mathtm-args-serial env sub-c)) (sup (mathtm-args-serial env sup-c)))
+          (mathtm-scripts base #f #f sub sup)
+        ) ;let
+      ) ;receive
+    ) ;let
+    (mathtm-error "bad msubsup")
+  ) ;if
+) ;define
+
+(define (mathtm-mmultiscripts-sub env l right?)
+  (cond ((or (null? l) (null? (cdr l))) (values '() '() '() '()))
+        ((or (func? (car l) 'mprescripts) (func? (car l) 'm:mprescripts))
+         (mathtm-mmultiscripts-sub env (cdr l) #f)
+        ) ;
+        (else (receive (lsub lsup rsub rsup)
+                (mathtm-mmultiscripts-sub env (cddr l) right?)
+                (let ((sub (mathtm env (car l))) (sup (mathtm env (cadr l))))
+                  (if right?
+                    (values lsub lsup (append rsub sub) (append rsup sup))
+                    (values (append sub lsub) (append sup lsup) rsub rsup)
+                  ) ;if
+                ) ;let
+              ) ;receive
+        ) ;else
+  ) ;cond
+) ;define
+
+(define (mathtm-multiscript env l)
+  (if (null? l) #f (mathtm-serial env l))
+) ;define
+
+(define (mathtm-mmultiscripts env a c)
+  (if (> (length c) 0)
+    (with base
+      (mathtm env (first c))
+      (receive (lsub lsup rsub rsup)
+        (mathtm-mmultiscripts-sub env (cdr c) #t)
+        (mathtm-scripts base
+          (mathtm-multiscript env lsub)
+          (mathtm-multiscript env lsup)
+          (mathtm-multiscript env rsub)
+          (mathtm-multiscript env rsup)
+        ) ;mathtm-scripts
+      ) ;receive
+    ) ;with
+    (mathtm-error "bad mmultiscripts")
+  ) ;if
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Under and over scripts and wide accents
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (mathtm-below base sub)
+  (cond ((logic-ref mathml-below->tm% sub) => (lambda (x) `((wide* ,base ,x))))
+        (else `((below ,base ,sub)))
+  ) ;cond
+) ;define
+
+(define (mathtm-above base sup)
+  (cond ((logic-ref mathml-above->tm% sup) => (lambda (x) `((wide ,base ,x))))
+        (else `((above ,base ,sup)))
+  ) ;cond
+) ;define
+
+(define (stretchy? src dest)
+  (and (string? dest)
+    (string-starts? dest "<")
+    (string-ends? dest ">")
+    (or (func? src 'm:mo) (func? src 'mo))
+    (>= (length src) 3)
+    (func? (cadr src) '@)
+    (attribute-is? (cdadr src) 'stretchy "true")
+  ) ;and
+) ;define
+
+(define (rubberify arrow)
+  (string-append "tm% (second sub))
+             ) ;and
+             `((below ,(car (mathtm-below base (second sub))) ,(third sub)))
+            ) ;
+            ((stretchy? (first c) base) `((long-arrow ,(rubberify base)
+                                            ,""
+                                            ,sub)))
+            (else (mathtm-below base sub))
+      ) ;cond
+    ) ;let
+    (mathtm-error "bad munder")
+  ) ;if
+) ;define
+
+(define (mathtm-mover env a c)
+  (if (== (length c) 2)
+    (let ((base (mathtm-as-serial env (first c)))
+          (sup (mathtm-as-serial env (second c)))
+         ) ;
+      (cond ((and (list? sup)
+               (== (first sup) 'above)
+               (logic-ref mathml-above->tm% (second sup))
+             ) ;and
+             `((above ,(car (mathtm-above base (second sup))) ,(third sup)))
+            ) ;
+            ((stretchy? (first c) base) `((long-arrow ,(rubberify base) ,sup)))
+            (else (mathtm-above base sup))
+      ) ;cond
+    ) ;let
+    (mathtm-error "bad mover")
+  ) ;if
+) ;define
+
+(define (mathtm-munderover env a c)
+  (if (== (length c) 3)
+    (let ((base (mathtm-as-serial env (first c)))
+          (sub (mathtm-as-serial env (second c)))
+          (sup (mathtm-as-serial env (third c)))
+         ) ;
+      (if (stretchy? (first c) base)
+        `((long-arrow ,(rubberify base) ,sup ,sub))
+        (mathtm-above (car (mathtm-below base sub)) sup)
+      ) ;if
+    ) ;let
+    (mathtm-error "bad munderover")
+  ) ;if
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Tables
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (mathml-func? x y)
+  (and (list? x) (or (== (car x) y) (== (car x) (symbol-append 'm: y))))
+) ;define
+
+(define (mathml-func-in? x l)
+  (list-or (map (cut mathml-func? x <>) l))
+) ;define
+
+(define (mathtm-halign s)
+  (cond ((== s "left") "l")
+        ((== s "center") "c")
+        ((== s "right") "r")
+        (else #f)
+  ) ;cond
+) ;define
+
+(define (mathtm-valign s)
+  (cond ((== s "bottom") "b")
+        ((== s "baseline") "B")
+        ((== s "axis") "f")
+        ((== s "center") "c")
+        ((== s "top") "t")
+        (else #f)
+  ) ;cond
+) ;define
+
+(define (mathtm-cell-format a)
+  (with sa
+    (mathtm-style (list a))
+    (if (nnull? sa)
+      (map (lambda (x) `(cwith ,(first x) ,(second x))) (split-by sa 2))
+      (cond ((and (func? a 'columnalign) (mathtm-halign (cadr a)))
+             `((cwith ,"cell-halign" ,(mathtm-halign (cadr a))))
+            ) ;
+            ((and (func? a 'rowalign) (mathtm-valign (cadr a)))
+             `((cwith ,"cell-valign" ,(mathtm-valign (cadr a))))
+            ) ;
+            (else '())
+      ) ;cond
+    ) ;if
+  ) ;with
+) ;define
+
+(define (mathtm-mtd env a c)
+  (let ((fm (append-map mathtm-cell-format a))
+        (c `(cell ,(mathtm-serial env (mathtm-pass env a c))))
+       ) ;
+    (if (null? fm) `(,c) `((tformat ,@fm ,c)))
+  ) ;let
+) ;define
+
+(define (mathtm-row-halign l nr)
+  (if (null? l)
+    '()
+    (let* ((h (mathtm-halign (car l)))
+           (r (mathtm-row-halign (cdr l) (+ nr 1)))
+           (s (number->string nr))
+           (c `(cwith ,s ,s ,"cell-halign" ,h))
+          ) ;
+      (if h (cons c r) r)
+    ) ;let*
+  ) ;if
+) ;define
+
+(define (mathtm-row-format a)
+  (with sa
+    (mathtm-style (list a))
+    (if (nnull? sa)
+      (map (lambda (x) `(cwith ,"1" ,"-1" ,(first x) ,(second x))) (split-by sa 2))
+      (cond ((func? a 'columnalign)
+             (with l (string-tokenize-by-char (cadr a) #\space) (mathtm-row-halign l 1))
+            ) ;
+            ((and (func? a 'rowalign) (mathtm-valign (cadr a)))
+             `((cwith ,"1" ,"-1" ,"cell-valign" ,(mathtm-valign (cadr a))))
+            ) ;
+            (else '())
+      ) ;cond
+    ) ;if
+  ) ;with
+) ;define
+
+(define (split-by lst n)
+  (if (not (null? lst))
+    (cons (list-take lst n) (split-by (list-drop lst n) n))
+    '()
+  ) ;if
+) ;define
+
+(define (mathtm-mtr env a c)
+  (let* ((cell? (lambda (x) (mathml-func? x 'mtd)))
+         (c2 (map (lambda (x) (if (cell? x) x `(m:mtd ,x))) c))
+         (r `(row ,@(map (cut mathtm-as-serial env <>) c2)))
+         (fm (append-map mathtm-row-format a))
+        ) ;
+    (if (null? fm) `(,r) `((tformat ,@fm ,r)))
+  ) ;let*
+) ;define
+
+(define (mathtm-mlabeledtr env a c)
+  ;; row label is ignored (not MathML Core spec)
+  (if (null? c) '((row)) (mathtm-mtr env a (cdr c)))
+) ;define
+
+(define (mathtm-table-halign l nr)
+  (if (null? l)
+    '()
+    (let* ((h (mathtm-halign (car l)))
+           (r (mathtm-table-halign (cdr l) (+ nr 1)))
+           (s (number->string nr))
+           (c `(cwith ,"1" ,"-1" ,s ,s ,"cell-halign" ,h))
+          ) ;
+      (if h (cons c r) r)
+    ) ;let*
+  ) ;if
+) ;define
+
+(define (mathtm-table-valign l nr)
+  (if (null? l)
+    '()
+    (let* ((h (mathtm-valign (car l)))
+           (r (mathtm-table-valign (cdr l) (+ nr 1)))
+           (s (number->string nr))
+           (c `(cwith ,s ,s ,"1" ,"-1" ,"cell-valign" ,h))
+          ) ;
+      (if h (cons c r) r)
+    ) ;let*
+  ) ;if
+) ;define
+
+(define (mathtm-table-format a)
+  (with sa
+    (mathtm-style (list a))
+    (if (nnull? sa)
+      (map (lambda (x) `(cwith ,"1" ,"-1" ,"1" ,"-1" ,(first x) ,(second x)))
+        (split-by sa 2)
+      ) ;map
+      (cond ((func? a 'columnalign)
+             (with l (string-tokenize-by-char (cadr a) #\space) (mathtm-table-halign l 1))
+            ) ;
+            ((func? a 'rowalign)
+             (with l (string-tokenize-by-char (cadr a) #\space) (mathtm-table-valign l 1))
+            ) ;
+            (else '())
+      ) ;cond
+    ) ;if
+  ) ;with
+) ;define
+
+(define (mathtm-mtable env a c)
+  (let* ((row? (lambda (x) (mathml-func-in? x '(mtr mlabeledtr))))
+         (c2 (map (lambda (x) (if (row? x) x `(m:mtr ,x))) c))
+         (l (map (cut mathtm-as-serial env <>) c2))
+         (fm (append-map mathtm-table-format a))
+         (t (tmtable-complete `(tformat ,@fm (table ,@l))))
+        ) ;
+    (set! t (tmtable-format-up t))
+    (if (func? t 'tformat 1) (set! t (cAr t)))
+    `((tabular ,t))
+  ) ;let*
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Further features used by wikipedia & LibreOffice Math
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (mathtm-semantics env a c)
+  (or (and (list>1? c)
+        (== (get-preference "mathml->texmacs:latex-annotations") "on")
+        (mathtm-annotation env a (cdr c))
+      ) ;and
+    (mathtm env (first c))
+  ) ;or
+) ;define
+
+(define (mathtm-annotation env a l)
+  (with r
+    (and (list>1? l) (mathtm-annotation env a cdr (l)))
+    (or r
+      (let* ((an (car l))
+             (enc (and (func? an 'm:annotation 2)
+                    (func? (second an) '@)
+                    (shtml-attr-non-null (cdr (second an)) 'encoding)
+                  ) ;and
+             ) ;enc
+            ) ;
+        (cond ((and enc (in? enc '("application/x-tex" "TeX")))
+               (let* ((s (third an))
+                      (lat (parse-latex (string-append "$" s "$")))
+                      (str (latex->texmacs lat))
+                     ) ;
+                 (list str)
+               ) ;let*
+              ) ;
+              ((and enc (string-starts? enc "StarMath")) #f)
+              (else (debug-message "debug-convert"
+                      (string-append "Mathml contains an unknown annotation type \""
+                        enc
+                        "\"\n with value: \n"
+                        (third an)
+                        "\nTeXmacs is not using it\n"
+                      ) ;string-append
+                    ) ;debug-message
+                #f
+              ) ;else
+        ) ;cond
+      ) ;let*
+    ) ;or
+  ) ;with
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; mathml tags can all handle the same set of (so-called "global") styling attributes
+;; -> handle them with a single function (except for table tags, treated differently)
+;; If attributes can be interpreted, wrap the result of the tag procedure
+;; in the appropriate '(with ...)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (mathtm-globattr env a c tagproc)
+  (with res
+    (tagproc env a c)
+    (cond ((null? res) res)
+          ((null? a) res)
+          (else (with attrs
+                  (mathtm-style a)
+                  (if (null? attrs) res `((with ,@attrs ,(car res))))
+                ) ;with
+          ) ;else
+    ) ;cond
+  ) ;with
+) ;define
+
+(define (mathtm-style l)
+  (if (null? l)
+    l
+    (let* ((h (car l)) (r (mathtm-style (cdr l))))
+      (cond ((or (func? h 'mathcolor) (func? h 'color)) (cons* "color" (cadr h) r))
+            ((func? h 'displaystyle) (cons* "math-display" (cadr h) r))
+            ((or (== h '(mathvariant "bold")) (== h '(mathvariant "bold-italic")))
+             (cons* "math-font-series" "bold" r)
+            ) ;
+            ((or (== h '(mathvariant "sans-serif"))
+               (== h '(mathvariant "sans-serif--italic"))
+             ) ;or
+             (cons* "math-font-family" "ms" r)
+            ) ;
+            ((== h '(mathvariant "monospace")) (cons* "math-font-family" "mt" r))
+            ((func? h 'mathsize) (cons* "font-base-size" (cadr h) r))
+            ((func? h 'scriptlevel)
+             (with sl
+               (string->number (cadr h))
+               (cond ((and sl (>= sl 0)) (cons* "math-level" (cadr h) r))
+                     ((== sl -1) (cons* "font-size" "1.189" r))
+                     ((== sl -2) (cons* "font-size" "1.414" r))
+                     ((== sl -3) (cons* "font-size" "1.682" r))
+                     ((< sl -3) (cons* "font-size" "2" r))
+                     (else r)
+               ) ;cond
+             ) ;with
+            ) ;
+            ((func? h 'style)
+             (append (mathtm-style (map (lambda (l) (list (string->symbol (car l)) (cAr l)))
+                                     (filter list-2?
+                                       (map (lambda (x) (map string-trim (string-tokenize-by-char x #\:)))
+                                         (string-tokenize-by-char (cadr h) #\;)
+                                       ) ;map
+                                     ) ;filter
+                                   ) ;map
+                     ) ;mathtm-style
+               r
+             ) ;append
+            ) ;
+            (else r)
+      ) ;cond
+    ) ;let*
+  ) ;if
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Main translation
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (mathtm-drop env a c)
+  '()
+) ;define
+
+(define (mathtm-pass env a c)
+  ;; TODO: consolidate with htmltm-pass
+  (let ((l (mathtm-args env c)))
+    (if (and (null? l) (not (assoc 'id a)))
+      '()
+      (list (xmltm-label-decorate a 'id (mathtm-serial env l)))
+    ) ;if
+  ) ;let
+) ;define
+
+(define (mathtm-args env l)
+  ;; TODO: consolidate with htmltm-args
+  (append-map (lambda (x) (mathtm env x)) l)
+) ;define
+
+(define (mathtm-args-serial env l)
+  ;; FIXME: mathml must not be affected by xml:space (html 
 mode)
+  (mathtm-serial env (mathtm-args env l))
+) ;define
+
+(define (mathtm env t)
+  (sxml-dispatch (lambda (env t) (list (mathtm-string env t))) mathtm-pass env t)
+) ;define
+
+(tm-define mathtm-as-serial
+  ;; TODO: replace #f by 'environment' object, see htmltm-as-serial
+  (case-lambda
+   ((t) (mathtm-as-serial #f t))
+   ((env t) (mathtm-serial env (mathtm env t)))
+  ) ;case-lambda
+) ;tm-define
+
+(logic-dispatcher mathtm-methods%
+  ;;; Interface
+  (math (mathtm-handler :element mathtm-math mathtm-globattr))
+  (none (mathtm-handler :mixed mathtm-none mathtm-globattr))
+  ;;; Presentation
+  ;; Token
+  ;; presentation tokens contain CDATA, MathML entities, align marks, or glyphs
+  (mi (mathtm-handler :mixed mathtm-pass mathtm-globattr))
+  (mn (mathtm-handler :mixed mathtm-pass mathtm-globattr))
+  (mo (mathtm-handler :mixed mathtm-mo mathtm-globattr))
+  (mtext (mathtm-handler :mixed mathtm-mtext mathtm-globattr))
+  (mspace (mathtm-handler :mixed mathtm-drop mathtm-globattr))
+  (ms (mathtm-handler :mixed mathtm-mtext mathtm-globattr))
+  (mglyph (mathtm-handler :empty mathtm-drop mathtm-globattr))
+  ;; General layout
+  (mrow (mathtm-handler :mixed mathtm-pass mathtm-globattr))
+  (mfrac (mathtm-handler :element mathtm-mfrac mathtm-globattr))
+  (msqrt (mathtm-handler :element mathtm-msqrt mathtm-globattr))
+  (mroot (mathtm-handler :element mathtm-mroot mathtm-globattr))
+  (mstyle (mathtm-handler :element mathtm-pass mathtm-globattr))
+  (merror (mathtm-handler :element mathtm-merror mathtm-globattr))
+  (mpadded (mathtm-handler :element mathtm-pass mathtm-globattr))
+  (mphantom (mathtm-handler :element mathtm-mphantom mathtm-globattr))
+  (mfenced (mathtm-handler :element mathtm-mfenced mathtm-globattr))
+  (menclose (mathtm-handler :element mathtm-menclose mathtm-globattr))
+  ;; Script and limits
+  (msub (mathtm-handler :element mathtm-msub mathtm-globattr))
+  (msup (mathtm-handler :element mathtm-msup mathtm-globattr))
+  (msubsup (mathtm-handler :element mathtm-msubsup mathtm-globattr))
+  (munder (mathtm-handler :element mathtm-munder mathtm-globattr))
+  (mover (mathtm-handler :element mathtm-mover mathtm-globattr))
+  (munderover (mathtm-handler :element mathtm-munderover mathtm-globattr))
+  (mmultiscripts (mathtm-handler :element mathtm-mmultiscripts mathtm-globattr))
+  ;; Tables
+  (mtable (mathtm-handler :element mathtm-mtable))
+  (mtr (mathtm-handler :element mathtm-mtr))
+  (mlabeledtr (mathtm-handler :element mathtm-mlabeledtr))
+  (mtd (mathtm-handler :element mathtm-mtd))
+  ;; Actions
+  (maction (mathtm-handler :element mathtm-pass mathtm-globattr))
+  ;; Further features used by wikipedia
+  (semantics (mathtm-handler :element mathtm-semantics mathtm-globattr))
+) ;logic-dispatcher
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Interface
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (mathml->tree s)
+  (:synopsis "Convert the MathML @s into a document fragment.")
+  (mathtm-as-serial (parse-xml s))
+) ;tm-define
diff --git a/TeXmacs/plugins/html/progs/html/sxhtml.scm b/TeXmacs/plugins/html/progs/html/sxhtml.scm
new file mode 100644
index 0000000000..bfb0d265a1
--- /dev/null
+++ b/TeXmacs/plugins/html/progs/html/sxhtml.scm
@@ -0,0 +1,374 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : sxhtml.scm
+;; DESCRIPTION : Utilities for HTML in SXML format
+;; COPYRIGHT   : (C) 2002  David Allouche
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (html sxhtml) (:use (html sxml)))
+
+;; TODO: rewrite the predicates using DRD
+;; TODO: consolidate with htmltm dispatch DRD
+
+;; Is the node x a HTML element whose name is a given set?
+;; (tm-define sxhtml-heading? (ntype-names?? '(h:h1 h:h2 h:h3 h:h4 h:h5 h:h6)))
+;; NOTE: outcommented in order to keep inline nature of h5 and h6
+(tm-define sxhtml-heading? (ntype-names?? '(h:h1 h:h2 h:h3 h:h4)))
+(tm-define sxhtml-list? (ntype-names?? '(h:ul h:ol h:dl)))
+(tm-define sxhtml-table? (ntype-names?? '(h:table)))
+
+(tm-define (sxhtml-label? x)
+  ;; Is the node x a h:a element with an id attribute?
+  (and (sxml-element? x) (eq? 'h:a (sxml-name x)) (sxml-attr x 'id))
+) ;tm-define
+
+(tm-define (sxhtml-glue-label x label)
+  ;; Set the id attribute of element x from the id of element label.
+  (sxml-set-attr x (list 'id (sxml-attr label 'id)))
+) ;tm-define
+
+(define table-kid?
+  (ntype-names?? '(h:tr h:td h:th h:col h:colgroup h:tbody h:thead h:tfoot))
+) ;define
+
+(define row-group-kid? (ntype-names?? '(h:tr h:td h:th)))
+
+(define row-group? (ntype-names?? '(h:tbody h:thead h:tfoot)))
+
+(define tfoot? (ntype-names?? '(h:tfoot)))
+
+(define col-data? (ntype-names?? '(h:col h:colgroup)))
+
+(define row? (ntype-names?? '(h:tr)))
+
+(define cell? (ntype-names?? '(h:td h:th)))
+
+(define (shtml-attr-number as name)
+  (and-let* ((x (shtml-attr-non-null as name))) (string->number x))
+) ;define
+
+(define (shtml-attr-positive-integer as name)
+  (and-let* ((n (shtml-attr-number as name))) (if (< n 0) #f (inexact->exact n)))
+) ;define
+
+(tm-define (shtml-decode-span as name)
+  ;; FIXME: zero spans (until end of group) are not supported
+  (let ((n (shtml-attr-positive-integer as name)))
+    (cond ((not n) 1)
+          ((zero? n) 1)
+          (else n)
+    ) ;cond
+  ) ;let
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Correct invalid element nesting in HTML tables
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; A correct TABLE contains only COL, COLGROUP, THEAD, TFOOT and TBODY
+;; elements. THEAD, TFOOT and TBODY (row groups) contains only TR elements. TR
+;; elements contain only TD elements.
+;;
+;; Correcting a table is inferring TBODY and TR elements when they are missing
+;; and filtering illegal nodes out.
+;;
+;; TODO: filter contents of COLGROUP elements.
+
+(tm-define (sxhtml-correct-table x)
+  ;; Correct all TABLEs in postorder in the sxml tree @x.
+  (let sub
+    ((x x))
+    (cond ((sxhtml-table? x)
+           (correct-table (sxml-set-content x (map sub (sxml-content x))))
+          ) ;
+          ((sxml-element? x) (sxml-set-content x (map sub (sxml-content x))))
+          (else x)
+    ) ;cond
+  ) ;let
+) ;tm-define
+
+(define (correct-table e)
+  ;; @e must be a h:table element (ns-prefixes must be normalized)
+  ;; Make TBODY elements explicit.
+  ;; Collect lone TD elements in TR.
+  ;; Drop table data not in TD.
+  (correct-table-content e
+    table-kid?
+    (lambda (tr tbody) (cons `(h:tr ,@tr) tbody))
+    (lambda (tbody kdr) (cons `(h:tbody ,@tbody) kdr))
+  ) ;correct-table-content
+) ;define
+
+(define (correct-row-group e)
+  ;; Collect lone TD elements in TR inside of @e.
+  ;; Drop table data not in TD.
+  (correct-table-content e
+    row-group-kid?
+    (lambda (tr tbody) (cons `(h:tr ,@tr) tbody))
+    (lambda (tbody kdr) tbody)
+  ) ;correct-table-content
+) ;define
+
+(define (correct-row e)
+  ;; Drop everything but TD elements.
+  (sxml-set-content e (list-filter (sxml-content e) cell?))
+) ;define
+
+(define (correct-table-content e accept? make-tr make-tbody)
+  (sxml-set-content e
+   ((cut <> #f)
+    (list-fold-right (lambda (kar kdr) (kdr kar))
+      (cut correct-table-content/step accept? make-tr make-tbody <> '() '() '())
+      (sxml-content e)
+    ) ;list-fold-right
+   ) ;
+  ) ;sxml-set-content
+) ;define
+
+(define (correct-table-content/step accept? cons-tr cons-tbody kar tr tbody kdr)
+  (define (state kar tr tbody kdr)
+    (correct-table-content/step accept? cons-tr cons-tbody kar tr tbody kdr)
+  ) ;define
+  (define (flush-tr curry-tbody-kdr)
+    ;; curry-tbody-kdr: (proc tbody -> state)
+    ;; curries @proc like (cut proc <> tbody kdr) with an updated @tbody.
+    (curry-tbody-kdr (cut state <> '() <> <>)
+      (if (null? tr) tbody (cons-tr tr tbody))
+    ) ;curry-tbody-kdr
+  ) ;define
+  (define (flush-tbody curry-kdr)
+    ;; curry-kdr: (proc kdr -> state)
+    ;; curries @proc like (cut proc <> kdr) with an updated @kdr.
+    (flush-tr (lambda (proc tbody)
+                (curry-kdr (cut proc <> '() <>) (if (null? tbody) kdr (cons-tbody tbody kdr)))
+              ) ;lambda
+    ) ;flush-tr
+  ) ;define
+  (cond ((not kar) (flush-tbody (lambda (proc kdr) kdr)))
+        ((not (accept? kar)) (cut state <> tr tbody kdr))
+        ((cell? kar) (cut state <> (cons kar tr) tbody kdr))
+        ((row? kar)
+         (flush-tr (lambda (proc tbody) (cut proc <> (cons (correct-row kar) tbody) kdr))
+         ) ;flush-tr
+        ) ;
+        ((row-group? kar)
+         (flush-tbody (lambda (proc kdr) (cut proc <> (cons (correct-row-group kar) kdr)))
+         ) ;flush-tbody
+        ) ;
+        ((col-data? kar) (flush-tbody (lambda (proc kdr) (cut proc <> (cons kar kdr)))))
+        ;; no "else" clause needed (assuming @accept is correct)
+  ) ;cond
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Table iterator
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Iterating over cells of a table while maintaining the coordinates of the
+;; current cell is a complex operation because table positions which are
+;; covered by spanned cells are not represented by cell elements in HTML.
+;; Also, the TFOOT element is present before TBODY element but is logically
+;; located at the end of the table.
+
+;;;; MISSING FEATURE ;;;;
+;; HTML-4.01 says that ROWSPAN=0 or COLSPAN=0 spans the cell to the end of its
+;; containing group (colgroup, tbody, thead, tfoot). However, neither
+;; Mozilla-1.4 nor Konqueror 3.1.3 implement this part of the specification.
+;; Since this feature also requires a significant added complexity, it is left
+;; out.
+
+(tm-define (sxhtml-table-fold kons knil table)
+  ;; Fundamental HTML table content iterator.
+  ;; knil: T
+  ;; kons: symbol (int @i) (int @j) sxml T -> T
+  ;; table: sxml
+  ;; Fold @kons over elements of @table, with (@i @j) the cell position.
+  ;;
+  ;; @kons is applied in the following modes:
+  ;;   Entering a row-group  : (kons :in-row-group i #f row-group kdr)
+  ;;   Entering a row        : (kons :in-row i #f row kdr)
+  ;;   (possible extension: entering a colgroup and iterating over a col)
+  ;;   Leaving a row-group   : (kons :out-row-group nrows #f #f kdr)
+  ;;   Leaving a row         : (kons :out-row #f ncols #f kdr)
+  ;;   Iterating over a cell : (kons :cell i j cell kdr)
+  ((cut <> #f)
+   (list-fold (lambda (kar kdr) (kdr kar))
+     (cut table-fold/table <> 0 '() '() kons knil)
+     (sxml-content table)
+   ) ;list-fold
+  ) ;
+) ;tm-define
+
+(define (table-fold/table kar i rowspans footers kons kdr)
+  ;; @kar is a child element of the TABLE element.
+  (cond ((not kar)
+         (if (not footers)
+           kdr
+           ((cut <> #f)
+            (list-fold (lambda (kar kdr) (kdr kar))
+              (cut table-fold/table <> i rowspans #f kons kdr)
+              (reverse! footers)
+            ) ;list-fold
+           ) ;
+         ) ;if
+        ) ;
+        ((and footers (tfoot? kar))
+         (cut table-fold/table <> i rowspans (cons kar footers) kons kdr)
+        ) ;
+        ((row-group? kar)
+         ((cut <> #f)
+          (list-fold (lambda (kar kdr) (kdr kar))
+            (cut table-fold/group
+              <>
+              i
+              i
+              rowspans
+              footers
+              kons
+              (kons :in-row-group i #f kar kdr)
+            ) ;cut
+            (sxml-content kar)
+          ) ;list-fold
+         ) ;
+        ) ;
+        ;; ELSE clause for col-data elements.
+        ;; NOTE: could be extended to support parsing of col-data
+        (else (cut table-fold/table <> i rowspans footers kons kdr))
+  ) ;cond
+) ;define
+
+(define (table-fold/group kar i0 i rowspans footers kons kdr)
+  ;; @kar is a child element of a THEAD, TBODY or TFOOT element.
+  (cond ((not kar)
+         (cut table-fold/table
+           <>
+           i
+           rowspans
+           footers
+           kons
+           (kons :out-row-group (- i i0) #f #f kdr)
+         ) ;cut
+        ) ;
+        ((row? kar)
+         ((cut <> #f)
+          (list-fold (lambda (kar kdr) (kdr kar))
+            (cut table-fold/row <> i0 i 0 rowspans footers kons (kons :in-row i #f kar kdr))
+            (sxml-content kar)
+          ) ;list-fold
+         ) ;
+        ) ;
+        ;; ELSE clause should never be reached (the table is corrected).
+        (else (cut table-fold/group <> i0 i rowspans footers kons kdr))
+  ) ;cond
+) ;define
+
+(define (table-fold/row kar i0 i j rowspans footers kons kdr)
+  ;; @kar is a child element of a TR element.
+  (cond ((not kar)
+         (cut table-fold/group
+           <>
+           i0
+           (1+ i)
+           (next-rowspans rowspans)
+           footers
+           kons
+           (kons :out-row #f (skip-spanned-cols j rowspans) #f kdr)
+         ) ;cut
+        ) ;
+        ((cell? kar)
+         (let ((j (skip-spanned-cols j rowspans)) (a (sxml-attr-list kar)))
+           (let ((rspan (shtml-decode-span a 'rowspan)) (cspan (shtml-decode-span a 'colspan)))
+             (cut table-fold/row
+               <>
+               i0
+               i
+               (+ j cspan)
+               (if (= 1 rspan) rowspans (add-rowspan rowspans j rspan cspan))
+               footers
+               kons
+               (kons :cell i j kar kdr)
+             ) ;cut
+           ) ;let
+         ) ;let
+        ) ;
+        ;; ELSE clause should never be reached (the table is corrected).
+        (else (cut table-fold/row <> i0 i j rowspans footers kons kdr))
+  ) ;cond
+) ;define
+
+
+;; Columns on which a cell is spanned are remember in a sorted ROWSPANS list.
+;; Items of ROWSPANS are lists (J SPAN) where:
+;;   J    : column number (zero-based). ROWSPANS is sorted by ascending J.
+;;   SPAN : count of additional rows (incl. the current row) where this column
+;;          is occupied by a spanned cell.
+
+(define (skip-spanned-cols j rowspans)
+  (let next
+    ((j j) (rowspans rowspans))
+    (cond ((null? rowspans) j)
+          ((< j (first (car rowspans))) j)
+          ((= j (first (car rowspans))) (next (1+ j) (cdr rowspans)))
+          (else (next j (cdr rowspans)))
+    ) ;cond
+  ) ;let
+) ;define
+
+(define (add-rowspan rowspans j rspan cspan)
+  (let next
+    ((rowspans rowspans) (j j) (cspan cspan))
+    (cond ((zero? cspan) rowspans)
+          ((null? rowspans) (cons (list j rspan) (next '() (1+ j) (1- cspan))))
+          ((< j (first (car rowspans)))
+           (cons (list j rspan) (next rowspans (1+ j) (1- cspan)))
+          ) ;
+          ((= j (first (car rowspans)))
+           ;; This can only happen with some very vicious incorrect HTML.
+           (cons (list j (max rspan (second (car rowspans))))
+             (next (cdr rowspans) (1+ j) (1- cspan))
+           ) ;cons
+          ) ;
+          (else (cons (car rowspans) (next (cdr rowspans) (1+ j) (1- cspan))))
+    ) ;cond
+  ) ;let
+) ;define
+
+(define (next-rowspans rowspans)
+  (reverse! (list-fold (lambda (kar kdr)
+                         (with (col old-span)
+                           kar
+                           (let ((span (1- old-span)))
+                             (if (zero? span) kdr (cons (list col span) kdr))
+                           ) ;let
+                         ) ;with
+                       ) ;lambda
+              '()
+              rowspans
+            ) ;list-fold
+  ) ;reverse!
+) ;define
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Table iterator applications
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (sxhtml-table-dimension table)
+  (sxhtml-table-fold (lambda (msg i j kar kdr)
+                       (with (nrows ncols)
+                         kdr
+                         (list (if (eq? msg :out-row-group) (+ nrows i) nrows)
+                           (if (eq? msg :out-row) (max ncols j) ncols)
+                         ) ;list
+                       ) ;with
+                     ) ;lambda
+    '(0 0)
+    table
+  ) ;sxhtml-table-fold
+) ;tm-define
diff --git a/TeXmacs/plugins/html/progs/html/sxml.scm b/TeXmacs/plugins/html/progs/html/sxml.scm
new file mode 100644
index 0000000000..7eb26bf279
--- /dev/null
+++ b/TeXmacs/plugins/html/progs/html/sxml.scm
@@ -0,0 +1,214 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : sxml.scm
+;; DESCRIPTION : XML data as S-expressions
+;; COPYRIGHT   : (C) 2002  David Allouche
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (html sxml))
+
+(define (as-string s)
+  (cond ((symbol? s) (symbol->string s))
+        ((number? s) (number->string s))
+        ((string? s) s)
+        (else "")
+  ) ;cond
+) ;define
+
+;; Fundamental acessors
+(tm-define sxml-name car)
+
+(define sxml-attr-list! cdadr)
+
+(tm-define (sxml-has-attr-list? e)
+  ;; Has the element e an attribute node?
+  (and (pair? (cdr e)) (pair? (cadr e)) (eq? '@ (caadr e)))
+) ;tm-define
+
+(tm-define (sxml-element-head e)
+  ;; Element name and attributes (if present).
+  (if (sxml-has-attr-list? e) (list (car e) (cadr e)) (list (car e)))
+) ;tm-define
+
+(tm-define (sxml-content e)
+  ;; Complement function of sxml-element-head.
+  (if (sxml-has-attr-list? e) (cddr e) (cdr e))
+) ;tm-define
+
+(tm-define (sxml-set-name e name)
+  ;; Set the name of the sxml element e.
+  ;; Name is the new element name as a string.
+  (cons (string->symbol name) (cdr e))
+) ;tm-define
+
+(tm-define (sxml-set-content e content)
+  ;; Replace the subnodes of e with the node-set content.
+  (append (sxml-element-head e) content)
+) ;tm-define
+
+(tm-define (sxml-prepend e l)
+  ;; Prepend a node set l to the content of an element e.
+  (append (sxml-element-head e) l (sxml-content e))
+) ;tm-define
+
+(define (sxml-attr-list? e)
+  ;; Return the attribute list of element e or #f.
+  (and (sxml-has-attr-list? e) (sxml-attr-list! e))
+) ;define
+
+(tm-define (sxml-attr-list e)
+  ;; Return the attribute list of element e or empty list.
+  (or (sxml-attr-list? e) '())
+) ;tm-define
+
+(tm-define (shtml-attr-non-null as att)
+  ;; Get an HTML attribute or false if the attribute is absent, is not set, or
+  ;; is set to the empty string.
+  ;; FIXME: this is ugly
+  (and-let* ((l (assoc att as)) ((list-length=2? l)) ((not (string-null? (second l)))))
+    (second l)
+  ) ;and-let*
+) ;tm-define
+
+(define (sxml-named-attr obj attr-name)
+  ;; Named attribute of element e or #f.
+  (and-let* ((l (sxml-attr-list? obj))) (assq attr-name l))
+) ;define
+
+(tm-define (sxml-attr obj attr-name)
+  ;; Value of a named attribute of element e or #f.
+  (and-let* ((x (sxml-named-attr obj attr-name))) (cadr x))
+) ;tm-define
+
+(tm-define (sxml-set-attr e attr)
+  ;; Set an attribute of an element e. Attr is a list (symbol? string?).
+  ;; Create the attribute list or the attribute if necessary.
+  (let ((attr-name (car attr)))
+    `(,(sxml-name e)
+      (@ ,attr
+        ,@(list-filter (sxml-attr-list e) (lambda (x) (not (eq? x attr-name)))))
+      ,@(sxml-content e))
+  ) ;let
+) ;tm-define
+
+(tm-define (sxml-set-attrs e attrs)
+  ;; Set several attributes of an element e. Attrs is a list of attributes.
+  ;; Create the attribute list or attributes if necessary.
+  (let rec
+    ((e e) (attrs attrs))
+    (if (null? attrs) e (rec (sxml-set-attr e (car attrs)) (cdr attrs)))
+  ) ;let
+) ;tm-define
+
+(tm-define (sxml-set-attrlist e attrs)
+  ;; Replace the attribute list of @obj by @attrs.
+  ;; If @attrs is #f, remove the attribute node.
+  `(,(sxml-name e) ,@(if attrs `((@ ,@attrs)) '()) ,@(sxml-content e))
+) ;tm-define
+
+(define-macro (sxml-find-name-separator len)
+  ;; optimized (string-rindex name #\:)
+  ;; returns position of a separator between namespace-id and LocalName
+  ;; (copied from sxml-tools)
+  `(let rpt
+     ((pos (1- ,len)))
+     (cond ((negative? pos) #f)
+           ((char=? #\: (string-ref name pos)) pos)
+           (else (rpt (1- pos)))))
+) ;define-macro
+
+(tm-define (sxml-ncname obj)
+  ;; Returns Local Part of Qualified Name (Namespaces in XML production [6])
+  ;; for given obj, which is ":"-separated suffix of its Qualified Name
+  ;; If a name of a node given is NCName (Namespaces in XML production [4]),
+  ;; then it is returned as is.
+  ;; Please note that while SXML name is a symbol this function returns a
+  ;; string.
+  ;; (copied from sxml-tools)
+  (sxml-name->ncname (sxml-name obj))
+) ;tm-define
+
+(tm-define (sxml-name->ncname sxml-name)
+  (let* ((name (as-string sxml-name)) (len (string-length name)))
+    (cond ((sxml-find-name-separator len)
+           =>
+           (lambda (pos) (substring name (+ pos 1) len))
+          ) ;
+          (else name)
+    ) ;cond
+  ) ;let*
+) ;tm-define
+
+(tm-define (sxml-name->ns-id sxml-name)
+  ;; Returns namespace-id part of given name, or #f if it's LocalName
+  ;; (copied from sxml-tools)
+  (let* ((name (as-string sxml-name)))
+    (cond ((sxml-find-name-separator (string-length name))
+           =>
+           (lambda (pos) (substring name 0 pos))
+          ) ;
+          (else #f)
+    ) ;cond
+  ) ;let*
+) ;tm-define
+
+(tm-define (sxml-split-name sxml-name)
+  (let* ((name (as-string sxml-name)) (len (string-length name)))
+    (cond ((sxml-find-name-separator len)
+           =>
+           (lambda (pos) (values (substring name 0 pos) (substring name (+ pos 1) len)))
+          ) ;
+          (else (values #f name))
+    ) ;cond
+  ) ;let*
+) ;tm-define
+
+(tm-define (sxml-strip-ns-prefix prefix x)
+  ;; Remove a given namespace prefix wherever it appears in element names.
+  ;; Prefix must be the ns-prefix as a string, and x a document fragment.
+  (let rec
+    ((x x))
+    (if (string? x)
+      x
+      (sxml-set-content (if (== prefix (sxml-name->ns-id (sxml-name x)))
+                          (sxml-set-name x (sxml-ncname x))
+                          x
+                        ) ;if
+        (map rec (sxml-content x))
+      ) ;sxml-set-content
+    ) ;if
+  ) ;let
+) ;tm-define
+
+(tm-define (sxml-set-ns-prefix p x)
+  (sxml-set-name x (string-append p ":" (sxml-ncname x)))
+) ;tm-define
+
+(tm-define (sxml-element? obj)
+  (and (pair? obj)
+    (symbol? (car obj))
+    (not (memq (car obj) '(@ @@ *PI* *COMMENT* *ENTITY*)))
+  ) ;and
+) ;tm-define
+
+(tm-define (ntype-names?? crit)
+  (lambda (node) (and (pair? node) (memq (car node) crit)))
+) ;tm-define
+
+(tm-define (sxml-control-node? x)
+  (and (nstring? x)
+    (let ((name (as-string (sxml-name x))))
+      (and (string-starts? name "*") (string-ends? name "*"))
+    ) ;let
+  ) ;and
+) ;tm-define
+
+(tm-define (sxml-top-node? x) (and (nstring? x) (== '*TOP* (car x))))
+
+(tm-define (sxml-filter-element-content l) (list-filter l nstring?))
diff --git a/TeXmacs/plugins/html/progs/html/tmhtml-expand.scm b/TeXmacs/plugins/html/progs/html/tmhtml-expand.scm
new file mode 100644
index 0000000000..ce90c1999c
--- /dev/null
+++ b/TeXmacs/plugins/html/progs/html/tmhtml-expand.scm
@@ -0,0 +1,56 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : tmhtml-expand.scm
+;; DESCRIPTION : environment patch for expanding the document before conversion
+;; COPYRIGHT   : (C) 2002  Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (html tmhtml-expand))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; "identity" macros
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (tmhtml-env-macro name)
+  `(associate ,(symbol->string name) (xmacro "x" (eval-args "x")))
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Interface
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmhtml-env-patch)
+  ;; FIXME: we should use the DRD here
+  `(collection ,@(map tmhtml-env-macro
+                   '(TeXmacs TeX LaTeX shown hrule item chapter-title
+                      section-title subsection-title subsubsection-title
+                      paragraph-title subparagraph-title itemize itemize-minus
+                      itemize-dot itemize-arrow enumerate enumerate-numeric
+                      enumerate-numeric-bracket enumerate-numeric-paren
+                      enumerate-roman enumerate-roman-bracket
+                      enumerate-roman-paren enumerate-Roman enumerate-alpha
+                      enumerate-alpha-bracket enumerate-alpha-full-paren
+                      enumerate-Alpha enumerate-circle enumerate-hanzi
+                      description description-compact description-dash
+                      description-aligned description-long
+                      description-paragraphs item* strong em dfn code* samp kbd
+                      var abbr acronym verbatim code tt underline overline
+                      strike-through deleted marked fill-out hidden-title
+                      doc-title-block equation* equation-lab equations-base
+                      wide-float draw-over draw-under html-tag html-attr
+                      html-div-style html-div-class html-style html-class
+                      html-javascript html-javascript-src html-video web-title
+                      tmdoc-title tmdoc-flag tmdoc-license tmdoc-title*
+                      tmdoc-title** tmdoc-copyright hlink action hyper-link
+                      mouse-over-balloon mouse-over-balloon*))
+     ;; FIXME: should apply 'filter_style' to the environment
+     ;; in an appropriate way to avoid adding the primitives below
+     ,@(map tmhtml-env-macro
+         '(shrink-inline binom tbinom dbinom choose ontop bmod pmod pod)))
+) ;tm-define
diff --git a/TeXmacs/plugins/html/progs/convert/html/tmhtml.scm b/TeXmacs/plugins/html/progs/html/tmhtml.scm
similarity index 95%
rename from TeXmacs/plugins/html/progs/convert/html/tmhtml.scm
rename to TeXmacs/plugins/html/progs/html/tmhtml.scm
index 360d53098c..3fc03bc51a 100644
--- a/TeXmacs/plugins/html/progs/convert/html/tmhtml.scm
+++ b/TeXmacs/plugins/html/progs/html/tmhtml.scm
@@ -11,17 +11,17 @@
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(texmacs-module (convert html tmhtml)
+(texmacs-module (html tmhtml)
   (:use (convert tools tmconcat)
-    (convert mathml tmmath)
+    (html tmmath)
     (convert tools stm)
     (convert tools tmlength)
     (convert tools tmtable)
     (convert tools old-tmtable)
-    (convert data sxml)
-    (convert data sxhtml)
-    (convert data css)
-    (convert html htmlout)
+    (html sxml)
+    (html sxhtml)
+    (html css)
+    (html htmlout)
   ) ;:use
 ) ;texmacs-module
 
@@ -206,8 +206,7 @@
                 " display: none; } "
                 ".balloon-anchor: hover [hidden] { position: absolute; left: 1em;"
                 " top: 2em; z-index: 99; margin-left: 0;"
-                " width: 500px; display: inline-block; } "
-                ".balloon-body { } "
+                " width: 500px; display: inline-block; } " ".balloon-body { } "
                 ".ornament { border-width: 1px; border-style: solid;"
                 " border-color: black; display: inline-block; padding: 0.2em; } "
                 ".right-tab { float: right; position: relative; top: -1em; } "
@@ -531,15 +530,7 @@
 ) ;define
 
 (define (force-block? x)
-  (or (and (tm-in? x '(h:p h:div
-                        h:pre
-                        h:h1
-                        h:h2
-                        h:h3
-                        h:h4
-                        h:ol
-                        h:ul
-                        h:dl
+  (or (and (tm-in? x '(h:p h:div h:pre h:h1 h:h2 h:h3 h:h4 h:ol h:ul h:dl
                         h:table))
         (not (and-with style (sxml-attr x 'style) (string-contains? style "display: inline"))
         ) ;not
@@ -1731,21 +1722,21 @@
 (tm-define (tmhtml-read-binary-file file-url)
   (import (liii path))
   (let* ((p (url->string (url-concretize file-url))))
-    (if (file-exists? p)
-      (path-read-bytes p)
-      #u8()
-    ) ;if
+    (if (file-exists? p) (path-read-bytes p) #u8())
   ) ;let*
 ) ;tm-define
 
 (tm-define (tmhtml-write-binary-file file-url data)
   (import (liii path))
   (let* ((p (cond ((string? file-url) file-url)
-                  (else (url->string (url-concretize file-url))))))
-    (cond ((byte-vector? data)
-           (path-write-bytes p data))
-          (else #f))
-    ) ;let*
+                  (else (url->string (url-concretize file-url)))
+            ) ;cond
+         ) ;p
+        ) ;
+    (cond ((byte-vector? data) (path-write-bytes p data))
+          (else #f)
+    ) ;cond
+  ) ;let*
 ) ;tm-define
 
 (define (tmhtml-png y)
@@ -1794,24 +1785,10 @@
                  (tmar (number->htmlstring (- y2 y4)))
                  (valign (number->htmlstring (- y3 (- y3 y1))))
                  (height (number->htmlstring (- y4 y3)))
-                 (style (string-append "margin-left: "
-                          lmar
-                          "em; "
-                          "margin-bottom: "
-                          bmar
-                          "em; "
-                          "margin-right: "
-                          rmar
-                          "em; "
-                          "margin-top: "
-                          tmar
-                          "em; "
-                          "vertical-align: "
-                          valign
-                          "em; "
-                          "height: "
-                          height
-                          "em"
+                 (style (string-append "margin-left: " lmar "em; "
+                          "margin-bottom: " bmar "em; " "margin-right: " rmar
+                          "em; " "margin-top: " tmar "em; " "vertical-align: "
+                          valign "em; " "height: " height "em"
                         ) ;string-append
                  ) ;style
                  (attrs (if tmhtml-base64?
@@ -1991,55 +1968,54 @@
                          (if (string? raw)
                            (let ((s (url-suffix raw)))
                              (if (== s "")
-                               (if (or (string-contains? raw "/")
-                                       (string-contains? raw "\\"))
-                                 "png"
-                                 raw)
-                               s))
-                           "")))
-                  )
-              (if tmhtml-base64?
-                (if (in? ext (list "ps" "eps" "pdf" "tif"))
-                  ;; Convert to PNG first, then inline as Base64
-                  (receive (name-url name-string)
-                    (tmhtml-image-names ext)
-                    (let* ((abs-url (url-concretize name-url))
-                           (abs-string abs-url))
-                      (tmhtml-write-binary-file abs-url data)
-                      (let ((res (tmhtml-png (cons 'image (cons abs-string (cdr l))))))
-                        (when (url-exists? abs-url)
-                          (url-remove abs-url))
-                        res
-                      ) ;let
-                    ) ;let*
-                  ) ;receive
-                  ;; Direct Base64 inline for native image formats
-                  (let* ((b64-str (begin
-                                     (import (liii base64))
-                                     (utf8->string (bytevector-base64-encode data))
-                                   ) ;begin
-                           ) ;b64-str
-                           (src-uri (string-append "data:image/" ext ";base64," b64-str))
-                           (w (if (>= (length l) 2) (tmlength->htmllength (second l) #f) #f))
-                           (h (if (>= (length l) 3) (tmlength->htmllength (third l) #f) #f))
-                          ) ;let*
-                    `((h:img (@ (class "image")
-                               (src ,src-uri)
-                               ,@(if w `((width ,w)) '())
-                               ,@(if h `((height ,h)) '()))))
-                  ) ;if
-                ) ;if
-                (receive (name-url name-string)
-                  (tmhtml-image-names ext)
-                  (let* ((abs-url (url-concretize name-url)) (abs-string (url->unix abs-url)))
-                    (tmhtml-write-binary-file abs-url data)
-                    (with res
-                      (tmhtml-image (cons abs-string (cdr l)))
-                      res
-                    ) ;with
-                  ) ;let*
-                ) ;receive
-              ) ;if
+                               (if (or (string-contains? raw "/") (string-contains? raw "\\")) "png" raw)
+                               s
+                             ) ;if
+                           ) ;let
+                           ""
+                         ) ;if
+                       ) ;let
+                  ) ;ext
+                 ) ;
+             (if tmhtml-base64?
+               (if (in? ext (list "ps" "eps" "pdf" "tif"))
+                 ;; Convert to PNG first, then inline as Base64
+                 (receive (name-url name-string)
+                   (tmhtml-image-names ext)
+                   (let* ((abs-url (url-concretize name-url)) (abs-string abs-url))
+                     (tmhtml-write-binary-file abs-url data)
+                     (let ((res (tmhtml-png (cons 'image (cons abs-string (cdr l))))))
+                       (when (url-exists? abs-url)
+                         (url-remove abs-url)
+                       ) ;when
+                       res
+                     ) ;let
+                   ) ;let*
+                 ) ;receive
+                 ;; Direct Base64 inline for native image formats
+                 (let* ((b64-str (begin
+                                   (import (liii base64))
+                                   (utf8->string (bytevector-base64-encode data))
+                                 ) ;begin
+                        ) ;b64-str
+                        (src-uri (string-append "data:image/" ext ";base64," b64-str))
+                        (w (if (>= (length l) 2) (tmlength->htmllength (second l) #f) #f))
+                        (h (if (>= (length l) 3) (tmlength->htmllength (third l) #f) #f))
+                       ) ;
+                   `((h:img (@ (class "image")
+                              (src ,src-uri)
+                              ,@(if w `((width ,w)) '())
+                              ,@(if h `((height ,h)) '()))))
+                 ) ;let*
+               ) ;if
+               (receive (name-url name-string)
+                 (tmhtml-image-names ext)
+                 (let* ((abs-url (url-concretize name-url)) (abs-string (url->unix abs-url)))
+                   (tmhtml-write-binary-file abs-url data)
+                   (with res (tmhtml-image (cons abs-string (cdr l))) res)
+                 ) ;let*
+               ) ;receive
+             ) ;if
            ) ;let*
          ) ;with
         ) ;
@@ -2827,48 +2803,15 @@
   (include tmhtml-include)
   (use-package tmhtml-noop)
 
-  ((:or or
-     xor
-     and
-     not
-     plus
-     minus
-     times
-     over
-     div
-     mod
-     merge
-     length
-     range
-     number
-     date
-     translate
-     is-tuple
-     look-up
-     equal
-     unequal
-     less
-     lesseq
-     greater
-     greatereq
-     if
-     case
-     while
-     extern
-     authorize
+  ((:or or xor and not plus minus times over div mod merge length range number
+     date translate is-tuple look-up equal unequal less lesseq greater greatereq
+     if case while extern authorize
    ) ;:or
    tmhtml-noop
   ) ;
 
-  ((:or style-with
-     style-with*
-     style-only
-     style-only*
-     active
-     active*
-     inactive
-     inactive*
-     rewrite-inactive
+  ((:or style-with style-with* style-only style-only* active active* inactive
+     inactive* rewrite-inactive
    ) ;:or
    tmhtml-noop
   ) ;
@@ -2921,29 +2864,16 @@
   (subparagraph-title (h:h6))
   ;; Lists
   ((:or itemize itemize-minus itemize-dot itemize-arrow) ,tmhtml-itemize)
-  ((:or enumerate
-     enumerate-numeric
-     enumerate-numeric-bracket
-     enumerate-numeric-paren
-     enumerate-roman
-     enumerate-roman-bracket
-     enumerate-roman-paren
-     enumerate-Roman
-     enumerate-alpha
-     enumerate-alpha-bracket
-     enumerate-alpha-full-paren
-     enumerate-Alpha
-     enumerate-circle
-     enumerate-hanzi
+  ((:or enumerate enumerate-numeric enumerate-numeric-bracket
+     enumerate-numeric-paren enumerate-roman enumerate-roman-bracket
+     enumerate-roman-paren enumerate-Roman enumerate-alpha
+     enumerate-alpha-bracket enumerate-alpha-full-paren enumerate-Alpha
+     enumerate-circle enumerate-hanzi
    ) ;:or
    ,tmhtml-enumerate
   ) ;
-  ((:or description
-     description-compact
-     description-dash
-     description-aligned
-     description-long
-     description-paragraphs
+  ((:or description description-compact description-dash description-aligned
+     description-long description-paragraphs
    ) ;:or
    ,tmhtml-description
   ) ;
diff --git a/TeXmacs/plugins/html/progs/html/tmmath.scm b/TeXmacs/plugins/html/progs/html/tmmath.scm
new file mode 100644
index 0000000000..09899caf78
--- /dev/null
+++ b/TeXmacs/plugins/html/progs/html/tmmath.scm
@@ -0,0 +1,548 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : tmmath.scm
+;; DESCRIPTION : conversion of TeXmacs trees into MathML trees
+;; COPYRIGHT   : (C) 2004  Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (html tmmath)
+  (:use (convert tools tmconcat)
+    (convert tools tmtable)
+    (html mathml-drd)
+    (convert rewrite tmtm-brackets)
+  ) ;:use
+) ;texmacs-module
+
+(define tmmath-env (make-ahash-table))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Horizontal concatenations
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (tmmath-concat-explode x)
+  (if (string? x) (tmconcat-tokenize-math x) (list x))
+) ;define
+
+(define (tmmath-concat l)
+  (let* ((l2 (apply append (map tmmath-concat-explode l)))
+         (l3 (tmconcat-structure-brackets l2))
+        ) ;
+    (tmmath (cons 'concat! l3))
+  ) ;let*
+) ;define
+
+(define (cork->utf8* x)
+  (with y (cork->utf8 x) (if (and (== x y) (== (string-ref y 0) #\<)) "?" y))
+) ;define
+
+(define (tmmath-concat-item x)
+  (if (string? x)
+    (with type
+      (math-symbol-type x)
+      (cond ((string-number? x) `(m:mn ,x))
+            ((logic-ref tm->mathml-constant% x) => (lambda (y) `(m:mn ,y)))
+            ((logic-ref tm->mathml-operator% x) => (lambda (y) `(m:mo ,y)))
+            ((and (string-starts? x "")
+             ) ;and
+             (let* ((n (string-length x)) (char (substring x (- n 2) (- n 1))))
+               `(m:mi (@ (mathvariant "script")) ,char)
+             ) ;let*
+            ) ;
+            ((and (or (string-starts? x "")
+             ) ;and
+             (let* ((n (string-length x)) (char (substring x (- n 2) (- n 1))))
+               `(m:mi (@ (mathvariant "bold-script")) ,char)
+             ) ;let*
+            ) ;
+            ((and (string-starts? x ""))
+             (let* ((n (string-length x)) (char (substring x (- n 2) (- n 1))))
+               `(m:mi (@ (mathvariant "fraktur")) ,char)
+             ) ;let*
+            ) ;
+            ((and (string-starts? x ""))
+             (let* ((n (string-length x)) (char (substring x (- n 2) (- n 1))))
+               `(m:mi (@ (mathvariant "bold-fraktur")) ,char)
+             ) ;let*
+            ) ;
+            ((and (or (string-starts? x "")
+             ) ;and
+             (let* ((n (string-length x)) (char (substring x (- n 2) (- n 1))))
+               `(m:mi (@ (mathvariant "double-struck")) ,char)
+             ) ;let*
+            ) ;
+            ((in? type '("unknown" "symbol")) `(m:mi ,(cork->utf8* x)))
+            (else `(m:mo ,(cork->utf8* x)))
+      ) ;cond
+    ) ;with
+    (tmmath x)
+  ) ;if
+) ;define
+
+(define (tmmath-concat! l)
+  (with r
+    (map tmmath-concat-item (tmconcat-structure-scripts l))
+    (set! r (list-filter r (lambda (x) (!= x ""))))
+    (cond ((null? r) '(m:mrow))
+          ((null? (cdr r)) (car r))
+          (else `(m:mrow ,@r))
+    ) ;cond
+  ) ;with
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Mathematics
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (tmmath-rigid l)
+  `(m:mrow ,(tmmath (car l)))
+) ;define
+
+(define (convert-around x)
+  (with d (downgrade-brackets x) (tmmath-concat (if (pair? d) (cdr d) (list d))))
+) ;define
+
+(define (tmmath-around l)
+  (convert-around (cons 'around l))
+) ;define
+
+(define (tmmath-around* l)
+  (convert-around (cons 'around* l))
+) ;define
+
+(define (tmmath-big-around l)
+  (convert-around (cons 'big-around l))
+) ;define
+
+(define (tmmath-large x)
+  (with y (logic-ref tm->mathml-large% x) (if y y (cork->utf8 x)))
+) ;define
+
+(define (tmmath-left l)
+  `(m:mo (@ (form "prefix") (stretchy "true")) ,(tmmath-large (car l)))
+) ;define
+
+(define (tmmath-mid l)
+  `(m:mo (@ (stretchy "true")) ,(tmmath-large (car l)))
+) ;define
+
+(define (tmmath-right l)
+  `(m:mo (@ (form "postfix") (stretchy "true")) ,(tmmath-large (car l)))
+) ;define
+
+(define (tmmath-big l)
+  (cond ((== (car l) ".") "")
+        ((logic-ref tm->mathml-big% (car l)) => (lambda (y) `(m:mo ,y)))
+        (else `(m:mo ,(car l)))
+  ) ;cond
+) ;define
+
+(define (tmmath-lsub l)
+  (tmmath-concat `((lsub ,(car l))))
+) ;define
+
+(define (tmmath-lsup l)
+  (tmmath-concat `((lsup ,(car l))))
+) ;define
+
+(define (tmmath-rsub l)
+  (tmmath-concat `((rsub ,(car l))))
+) ;define
+
+(define (tmmath-rsup l)
+  (tmmath-concat `((rsup ,(car l))))
+) ;define
+
+(define (tmmath-lscript base sub sup)
+  (if (and (pair? base) (in? (car base) '(m:msub m:msup m:msubsup)))
+    (let ((nbase (cadr base)) (rsub '(m:none)) (rsup '(m:none)))
+      (if (func? base 'm:msub) (set! rsub (caddr base)))
+      (if (func? base 'm:msup) (set! rsup (caddr base)))
+      (if (func? base 'm:msubsup) (set! rsub (caddr base)))
+      (if (func? base 'm:msubsup) (set! rsup (cadddr base)))
+      `(m:mmultiscripts ,nbase ,rsub ,rsup (m:mprescripts) ,sub ,sup)
+    ) ;let
+    `(m:mmultiscripts ,base (m:mprescripts) ,sub ,sup)
+  ) ;if
+) ;define
+
+(define (tmmath-lsub! l)
+  (tmmath-lscript (tmmath (car l)) (tmmath (cadr l)) '(m:none))
+) ;define
+
+(define (tmmath-lsup! l)
+  (tmmath-lscript (tmmath (car l)) '(m:none) (tmmath (cadr l)))
+) ;define
+
+(define (tmmath-lsubsup! l)
+  (tmmath-lscript (tmmath (car l)) (tmmath (cadr l)) (tmmath (caddr l)))
+) ;define
+
+(define (tmmath-with-limits? x)
+  (and (func? x 'big) (== (ahash-ref tmmath-env "math-display") "true"))
+) ;define
+
+(define (tmmath-rsub! l)
+  (with op
+    (if (tmmath-with-limits? (car l)) 'm:munder 'm:msub)
+    (list op (tmmath (car l)) (tmmath (cadr l)))
+  ) ;with
+) ;define
+
+(define (tmmath-rsup! l)
+  (with op
+    (if (tmmath-with-limits? (car l)) 'm:mover 'm:msup)
+    (list op (tmmath (car l)) (tmmath (cadr l)))
+  ) ;with
+) ;define
+
+(define (tmmath-rsubsup! l)
+  (with op
+    (if (tmmath-with-limits? (car l)) 'm:munderover 'm:msubsup)
+    (list op (tmmath (car l)) (tmmath (cadr l)) (tmmath (caddr l)))
+  ) ;with
+) ;define
+
+(define (tmmath-frac l)
+  `(m:mfrac ,(tmmath (car l)) ,(tmmath (cadr l)))
+) ;define
+
+(define (tmmath-sqrt l)
+  (if (null? (cdr l))
+    `(m:msqrt ,(tmmath (car l)))
+    `(m:mroot ,(tmmath (car l)) ,(tmmath (cadr l)))
+  ) ;if
+) ;define
+
+(define (tmmath-wide l)
+  (with acc
+    (or (logic-ref tm->mathml-wide% (cadr l)) "")
+    `(m:mover ,(tmmath (car l)) (m:mo ,acc))
+  ) ;with
+) ;define
+
+(define (tmmath-wide* l)
+  (with acc
+    (or (logic-ref tm->mathml-wide% (cadr l)) "")
+    `(m:munder ,(tmmath (car l)) (m:mo ,acc))
+  ) ;with
+) ;define
+
+(define (tmmath-long-arrow l)
+  (let* ((a (car l))
+         (above (if (>= (length l) 2) (cadr l) ""))
+         (below (if (>= (length l) 3) (caddr l) ""))
+        ) ;
+    (when (and (string? a) (string-starts? a "string len)) "*" ""))
+         (s* (if (string->number s) (string-append s "em") s))
+        ) ;
+    `(m:mspace (@ (width ,s*)))
+  ) ;let*
+) ;define
+
+(define (tmmath-first l)
+  (tmmath (car l))
+) ;define
+
+(define (tmmath-last l)
+  (tmmath (cAr l))
+) ;define
+
+(define (tmmath-surround l)
+  (tmmath-concat (list (car l) (caddr l) (cadr l)))
+) ;define
+
+(define (tmmath-attr x)
+  (with (var val)
+    x
+    (cond ((== var "color") (list 'mathcolor val))
+          ((== x '("math-font-series" "medium")) (list 'mathvariant "normal"))
+          ((== x '("math-font-series" "bold")) (list 'mathvariant "bold"))
+          ((== x '("math-font-series" "bold")) (list 'mathvariant "bold"))
+          ((== var "math-level") (list 'scriptlevel val))
+          ((== var "math-display") (list 'displaystyle val))
+          (else #f)
+    ) ;cond
+  ) ;with
+) ;define
+
+(define (list-two-by-two l)
+  (if (null? l) l (cons (list (car l) (cadr l)) (list-two-by-two (cddr l))))
+) ;define
+
+(define (tmmath-with-sub attrs body)
+  (if (null? attrs)
+    (tmmath body)
+    (with (var val)
+      (car attrs)
+      (ahash-with tmmath-env var val (tmmath-with-sub (cdr attrs) body))
+    ) ;with
+  ) ;if
+) ;define
+
+(define (tmmath-with l)
+  (let* ((attrs-1 (list-two-by-two (cDr l)))
+         (attrs-2 (map tmmath-attr attrs-1))
+         (attrs-3 (list-filter attrs-2 identity))
+         (body (tmmath-with-sub attrs-1 (cAr l)))
+        ) ;
+    (if (null? attrs-3) body `(m:mstyle (@ ,@attrs-3) ,body))
+  ) ;let*
+) ;define
+
+(define (tmmath-text x)
+  ;; we protect via non-breaking spaces the initial and final whitespaces
+  ;; which are otherwise stripped by the MathML processor from  tags
+  ;; see https://www.xmlmind.com/tutorials/MathML/
+  (let* ((s (texmacs->code x "utf-8"))
+         (s (if (string-starts? s " ")
+              (string-append "  " (substring s 1 (string-length s)))
+              s
+            ) ;if
+         ) ;s
+         (s (if (string-ends? s " ")
+              (string-append (substring s 0 (- (string-length s) 1)) "  ")
+              s
+            ) ;if
+         ) ;s
+        ) ;
+    `(m:mtext ,s)
+  ) ;let*
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Main conversion routines
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (tmmath-dispatch htable l)
+  (let ((x (logic-ref ,htable (car l))))
+    (and (procedure? x) (x (cdr l)))
+  ) ;let
+) ;define
+
+(define (tmmath x)
+  (if (!= (ahash-ref tmmath-env "mode") "math")
+    (cond ((string? x) (tmmath-text x))
+          ((== (car x) 'with) (tmmath-with (cdr x)))
+          (else `(m:mrow ,@(map tmmath (cdr x))))
+    ) ;cond
+    (cond ((string? x) (tmmath-concat (list x)))
+          (else (or (tmmath-dispatch 'tmmath-primitives% x) ""))
+    ) ;cond
+  ) ;if
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Dispatching
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-dispatcher tmmath-primitives%
+  ;; Mathematics
+  (concat tmmath-concat)
+  (concat! tmmath-concat!)
+  (rigid tmmath-rigid)
+  (around tmmath-around)
+  (around* tmmath-around*)
+  (big-around tmmath-big-around)
+  (left tmmath-left)
+  (mid tmmath-mid)
+  (right tmmath-right)
+  (big tmmath-big)
+  (long-arrow tmmath-long-arrow)
+  (lprime tmmath-lsup)
+  (rprime tmmath-rsup)
+  (below tmmath-below)
+  (above tmmath-above)
+  (lsub tmmath-lsub)
+  (lsup tmmath-lsup)
+  (rsub tmmath-rsub)
+  (rsup tmmath-rsup)
+  (lsub! tmmath-lsub!)
+  (lsup! tmmath-lsup!)
+  (lsubsup! tmmath-lsubsup!)
+  (rsub! tmmath-rsub!)
+  (rsup! tmmath-rsup!)
+  (rsubsup! tmmath-rsubsup!)
+  (frac tmmath-frac)
+  (sqrt tmmath-sqrt)
+  (wide tmmath-wide)
+  (wide* tmmath-wide*)
+  (neg tmmath-neg)
+  (tree tmmath-noop)
+  (syntax tmmath-first)
+
+  ;; Tabular markup
+  (tformat tmmath-tformat)
+  (table tmmath-table)
+  (row tmmath-concat)
+  (cell tmmath-concat)
+  (tabular tmmath-first)
+  (tabular* tmmath-first)
+  (block tmmath-first)
+  (block* tmmath-first)
+
+  ;; Other markup
+  (space tmmath-hspace)
+  (hspace tmmath-hspace)
+  (htab tmmath-hspace)
+  (document tmmath-concat)
+  (para tmmath-concat)
+  (surround tmmath-surround)
+  (move tmmath-first)
+  (resize tmmath-first)
+  (with tmmath-with)
+) ;logic-dispatcher
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Interface
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (texmacs->mathml x . opt-env)
+  (if (nnull? opt-env) (set! tmmath-env (car opt-env)))
+  (ahash-with tmmath-env "mode" "math" (tmmath x))
+) ;tm-define
diff --git a/TeXmacs/plugins/html/progs/convert/data/xmltm.scm b/TeXmacs/plugins/html/progs/html/xmltm.scm
similarity index 97%
rename from TeXmacs/plugins/html/progs/convert/data/xmltm.scm
rename to TeXmacs/plugins/html/progs/html/xmltm.scm
index e8a600ccd9..3358e21805 100644
--- a/TeXmacs/plugins/html/progs/convert/data/xmltm.scm
+++ b/TeXmacs/plugins/html/progs/html/xmltm.scm
@@ -11,9 +11,9 @@
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(texmacs-module (convert data xmltm)
+(texmacs-module (html xmltm)
   (:use (convert tools stm)
-    (convert data sxml)
+    (html sxml)
     (convert tools environment)
     (convert tools tmconcat)
   ) ;:use
@@ -481,22 +481,15 @@
                ) ;cond
         ) ;clean
         (proc-alist (cond ((eq? kind :inline)
-                           `((,:procedure
-                              unquote
-                              htmltm-handler/procedure/inline)
+                           `((,:procedure . ,htmltm-handler/procedure/inline)
                              (,:environment
-                              unquote
-                              htmltm-handler/environment/inline)
-                             (,:literal unquote htmltm-handler/literal/inline))
+                              . ,htmltm-handler/environment/inline)
+                             (,:literal . ,htmltm-handler/literal/inline))
                           ) ;
                           ((eq? kind :block)
-                           `((,:procedure
-                              unquote
-                              htmltm-handler/procedure/block)
-                             (,:environment
-                              unquote
-                              htmltm-handler/environment/block)
-                             (,:literal unquote htmltm-handler/literal/block))
+                           `((,:procedure . ,htmltm-handler/procedure/block)
+                             (,:environment . ,htmltm-handler/environment/block)
+                             (,:literal . ,htmltm-handler/literal/block))
                           ) ;
                           (error "Bad kind: " kind)
                     ) ;cond
diff --git a/TeXmacs/plugins/image/progs/image/gif.scm b/TeXmacs/plugins/image/progs/image/gif.scm
index 97be9e6d24..988cb76103 100644
--- a/TeXmacs/plugins/image/progs/image/gif.scm
+++ b/TeXmacs/plugins/image/progs/image/gif.scm
@@ -14,5 +14,4 @@
 
 (texmacs-module (image gif))
 
-(converter gif-file postscript-document
-  (:function image->psdoc))
+(converter gif-file postscript-document (:function image->psdoc))
diff --git a/TeXmacs/plugins/image/progs/image/jpeg.scm b/TeXmacs/plugins/image/progs/image/jpeg.scm
index fbde4232b3..baa4c1fb5c 100644
--- a/TeXmacs/plugins/image/progs/image/jpeg.scm
+++ b/TeXmacs/plugins/image/progs/image/jpeg.scm
@@ -14,5 +14,4 @@
 
 (texmacs-module (image jpeg))
 
-(converter jpeg-file postscript-document
-  (:function image->psdoc))
+(converter jpeg-file postscript-document (:function image->psdoc))
diff --git a/TeXmacs/plugins/image/progs/image/pdf.scm b/TeXmacs/plugins/image/progs/image/pdf.scm
index bb54e62ac6..55b4fde5aa 100644
--- a/TeXmacs/plugins/image/progs/image/pdf.scm
+++ b/TeXmacs/plugins/image/progs/image/pdf.scm
@@ -13,34 +13,42 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (texmacs-module (image pdf)
-  (:use (binary convert)
-        (binary gs)
-        (binary pdftocairo)))
+  (:use (binary convert) (binary gs) (binary pdftocairo))
+) ;texmacs-module
 
-(converter pdf-file svg-file
+(converter pdf-file
+  svg-file
   (:require (url-exists-in-path? "pdf2svg"))
-  (:shell "pdf2svg" from to))
+  (:shell "pdf2svg" from to)
+) ;converter
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Convert PDF to other formats via pdftocairo
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(converter pdf-file svg-file
+(converter pdf-file
+  svg-file
   (:require (has-binary-pdftocairo?))
-  (:shell ,(url->system (find-binary-pdftocairo)) "-origpagesizes -nocrop -nocenter -svg" from to))
+  (:shell ,(url->system (find-binary-pdftocairo))
+    "-origpagesizes -nocrop -nocenter -svg"
+    from
+    to
+  ) ;:shell
+) ;converter
 
 
-(converter pdf-file jpeg-file
+(converter pdf-file
+  jpeg-file
   (:require (has-binary-pdftocairo?))
   (:function-with-options pdf-file->pdftocairo-raster)
-  ;;(:option "texmacs->image:raster-resolution" "300")
-  )
+  ;; (:option "texmacs->image:raster-resolution" "300")
+) ;converter
 
-;;(converter pdf-file postscript-document
+;; (converter pdf-file postscript-document
 ;;  (:require (has-pdftocairo?))
 ;;  (:shell "pdftocairo" "-eps" from to))
 ;;
-;;(converter pdf-file postscript-file
+;; (converter pdf-file postscript-file
 ;;  (:require (has-pdftocairo?))
 ;;  (:shell "pdftocairo" "-eps" from to))
 
@@ -48,43 +56,38 @@
 ;; Convert PDF to other formats via ImageMagick
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(converter pdf-file jpeg-file
+(converter pdf-file
+  jpeg-file
   (:require (has-binary-convert?))
   (:function-with-options pdf-file->imagemagick-raster)
-  ;;(:option "texmacs->image:raster-resolution" "300")
-  )
- 
-(converter pdf-file tif-file
+  ;; (:option "texmacs->image:raster-resolution" "300")
+) ;converter
+
+(converter pdf-file
+  tif-file
   (:require (has-binary-convert?))
   (:function-with-options pdf-file->imagemagick-raster)
-  ;;(:option "texmacs->image:raster-resolution" "300")
-  )
+  ;; (:option "texmacs->image:raster-resolution" "300")
+) ;converter
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Convert PDF to other formats via Ghostscript
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-; 
-; (converter pdf-file jpeg-file
-;   (:require (has-binary-gs?))
-;   (:function-with-options pdf-file->gs-raster))
-; 
-; (converter pdf-file tif-file
-;   (:require (has-binary-gs?))
-;   (:function-with-options pdf-file->gs-raster))
-; 
-; (converter pdf-file postscript-file
-;   (:require (has-binary-gs?))
-;   (:function-with-options gs-convert))
 
-; pdf -> png (the latter one works)
-(converter pdf-file png-file
+(converter pdf-file
+  png-file
   (:require (has-binary-convert?))
-  (:function-with-options pdf-file->imagemagick-raster))
-  
-(converter pdf-file png-file
+  (:function-with-options pdf-file->imagemagick-raster)
+) ;converter
+
+(converter pdf-file
+  png-file
   (:require (has-binary-pdftocairo?))
-  (:function-with-options pdf-file->pdftocairo-raster))
+  (:function-with-options pdf-file->pdftocairo-raster)
+) ;converter
 
-(converter pdf-file png-file
+(converter pdf-file
+  png-file
   (:require (has-binary-gs?))
-  (:function-with-options gs-pdf-to-png))
+  (:function-with-options gs-pdf-to-png)
+) ;converter
diff --git a/TeXmacs/plugins/image/progs/image/png.scm b/TeXmacs/plugins/image/progs/image/png.scm
index a1c6d7136c..6ddb5c6df7 100644
--- a/TeXmacs/plugins/image/progs/image/png.scm
+++ b/TeXmacs/plugins/image/progs/image/png.scm
@@ -12,19 +12,19 @@
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(texmacs-module (image png)
-  (:use (binary inkscape)
-        (binary convert)))
+(texmacs-module (image png) (:use (binary inkscape) (binary convert)))
 
 ;; png -> postscript (the latter one which meets the requirements will work)
-(converter png-file postscript-file
+(converter png-file
+  postscript-file
   (:require (has-binary-convert?))
-  (:shell ,(url->system (find-binary-convert)) from to))
+  (:shell ,(url->system (find-binary-convert)) from to)
+) ;converter
 
-; open a png image via inkscape manually and check `do not ask`
-; in this way, inkscape will not ask you when trying to import png
-(converter png-file postscript-file
+(converter png-file
+  postscript-file
   (:require (has-binary-inkscape?))
-  (:shell ,(url->system (find-binary-inkscape)) from "-o" to))
+  (:shell ,(url->system (find-binary-inkscape)) from "-o" to)
+) ;converter
 
 ;; we do not need png -> pdf, because the hummus pdfwriter supports png image
diff --git a/TeXmacs/plugins/image/progs/image/postscript.scm b/TeXmacs/plugins/image/progs/image/postscript.scm
index 54ba042c2a..48c31dcb32 100644
--- a/TeXmacs/plugins/image/progs/image/postscript.scm
+++ b/TeXmacs/plugins/image/progs/image/postscript.scm
@@ -12,19 +12,22 @@
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(texmacs-module (image postscript)
-  (:use (binary convert)
-        (binary gs)))
+(texmacs-module (image postscript) (:use (binary convert) (binary gs)))
 
-(converter postscript-file pdf-file
+(converter postscript-file
+  pdf-file
   (:require (has-binary-gs?))
-  (:function-with-options gs-eps-to-pdf))
+  (:function-with-options gs-eps-to-pdf)
+) ;converter
 
-; eps -> png (the latter one works)
-(converter postscript-file png-file
+(converter postscript-file
+  png-file
   (:require (has-binary-convert?))
-  (:shell ,(url->system (find-binary-convert)) from to))
+  (:shell ,(url->system (find-binary-convert)) from to)
+) ;converter
 
-(converter postscript-file png-file
+(converter postscript-file
+  png-file
   (:require (has-binary-gs?))
-  (:function-with-options gs-eps-to-png))
+  (:function-with-options gs-eps-to-png)
+) ;converter
diff --git a/TeXmacs/plugins/image/progs/image/svg.scm b/TeXmacs/plugins/image/progs/image/svg.scm
index 33cbadfe5f..791a216d9b 100644
--- a/TeXmacs/plugins/image/progs/image/svg.scm
+++ b/TeXmacs/plugins/image/progs/image/svg.scm
@@ -13,32 +13,50 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (texmacs-module (image svg)
-  (:use (binary rsvg-convert)
-        (binary inkscape)
-        (binary convert)))
+  (:use (binary rsvg-convert) (binary inkscape) (binary convert))
+) ;texmacs-module
 
-(converter svg-file png-file
+(converter svg-file
+  png-file
   (:require (has-binary-inkscape?))
-  (:shell ,(url->system (find-binary-inkscape)) "-z" "-d" "600" from "--export-png" to))
-
-(converter svg-file png-file
+  (:shell ,(url->system (find-binary-inkscape))
+    "-z"
+    "-d"
+    "600"
+    from
+    "--export-png"
+    to
+  ) ;:shell
+) ;converter
+
+(converter svg-file
+  png-file
   (:require (has-binary-rsvg-convert?))
-    (:function-with-options svg2png-by-rsvg-convert))
+  (:function-with-options svg2png-by-rsvg-convert)
+) ;converter
 
 ;; svg -> pdf (the latter one which meets the requirements will work)
-(converter svg-file pdf-file
+(converter svg-file
+  pdf-file
   (:require (has-binary-rsvg-convert?))
-  (:shell ,(url->system (find-binary-rsvg-convert)) "-f pdf" "-o" to from ))
+  (:shell ,(url->system (find-binary-rsvg-convert)) "-f pdf" "-o" to from)
+) ;converter
 
-(converter svg-file pdf-file
+(converter svg-file
+  pdf-file
   (:require (has-binary-inkscape?))
-  (:shell ,(url->system (find-binary-inkscape)) from "-o" to))
+  (:shell ,(url->system (find-binary-inkscape)) from "-o" to)
+) ;converter
 
 ;; svg -> postscript (the latter one which meets the requirements will work)
-(converter svg-file postscript-file
+(converter svg-file
+  postscript-file
   (:require (has-binary-rsvg-convert?))
-  (:shell ,(url->system (find-binary-rsvg-convert)) "-f eps" "-o" to from ))
+  (:shell ,(url->system (find-binary-rsvg-convert)) "-f eps" "-o" to from)
+) ;converter
 
-(converter svg-file postscript-file
+(converter svg-file
+  postscript-file
   (:require (has-binary-inkscape?))
-  (:shell ,(url->system (find-binary-inkscape)) from "-o" to))
+  (:shell ,(url->system (find-binary-inkscape)) from "-o" to)
+) ;converter
diff --git a/TeXmacs/plugins/image/progs/image/tif.scm b/TeXmacs/plugins/image/progs/image/tif.scm
index dad9f933a5..38827787d7 100644
--- a/TeXmacs/plugins/image/progs/image/tif.scm
+++ b/TeXmacs/plugins/image/progs/image/tif.scm
@@ -14,5 +14,4 @@
 
 (texmacs-module (image tif))
 
-(converter tif-file postscript-document
-  (:function image->psdoc))
+(converter tif-file postscript-document (:function image->psdoc))
diff --git a/TeXmacs/plugins/image/progs/image/webp.scm b/TeXmacs/plugins/image/progs/image/webp.scm
index ff1208f270..369bb45795 100644
--- a/TeXmacs/plugins/image/progs/image/webp.scm
+++ b/TeXmacs/plugins/image/progs/image/webp.scm
@@ -11,15 +11,17 @@
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(texmacs-module (image webp)
-  (:use (binary inkscape)
-        (binary convert)))
+(texmacs-module (image webp) (:use (binary inkscape) (binary convert)))
 
 ;; webp -> postscript (the latter one which meets the requirements will work)
-(converter webp-file postscript-file
+(converter webp-file
+  postscript-file
   (:require (has-binary-convert?))
-  (:shell ,(url->system (find-binary-convert)) from to))
+  (:shell ,(url->system (find-binary-convert)) from to)
+) ;converter
 
-(converter webp-file postscript-file
+(converter webp-file
+  postscript-file
   (:require (has-binary-inkscape?))
-  (:shell ,(url->system (find-binary-inkscape)) from "-o" to))
+  (:shell ,(url->system (find-binary-inkscape)) from "-o" to)
+) ;converter
diff --git a/TeXmacs/plugins/image_xmgrace/progs/image/xmgrace.scm b/TeXmacs/plugins/image/progs/image/xmgrace.scm
similarity index 80%
rename from TeXmacs/plugins/image_xmgrace/progs/image/xmgrace.scm
rename to TeXmacs/plugins/image/progs/image/xmgrace.scm
index e87ea2caff..2e548c62ce 100644
--- a/TeXmacs/plugins/image_xmgrace/progs/image/xmgrace.scm
+++ b/TeXmacs/plugins/image/progs/image/xmgrace.scm
@@ -13,14 +13,16 @@
 
 (texmacs-module (image xmgrace))
 
-(define-format xmgrace
-  (:name "Xmgrace")
-  (:suffix "agr" "xmgr"))
+(define-format xmgrace (:name "Xmgrace") (:suffix "agr" "xmgr"))
 
-(converter xmgrace-file postscript-document
+(converter xmgrace-file
+  postscript-document
   (:require (url-exists-in-path? "xmgrace"))
-  (:shell "xmgrace" "-noask -hardcopy -hdevice EPS -printfile" to from))
+  (:shell "xmgrace" "-noask -hardcopy -hdevice EPS -printfile" to from)
+) ;converter
 
-(converter xmgrace-file png-file
+(converter xmgrace-file
+  png-file
   (:require (url-exists-in-path? "xmgrace"))
-  (:shell "xmgrace" "-noask -hardcopy -hdevice PNG -printfile" to from))
+  (:shell "xmgrace" "-noask -hardcopy -hdevice PNG -printfile" to from)
+) ;converter
diff --git a/TeXmacs/plugins/image/progs/init-image.scm b/TeXmacs/plugins/image/progs/init-image.scm
index 32594d3105..3c9d616f5e 100644
--- a/TeXmacs/plugins/image/progs/init-image.scm
+++ b/TeXmacs/plugins/image/progs/init-image.scm
@@ -13,10 +13,13 @@
 
 (texmacs-module (image)
   (:use (image gif)
-        (image jpeg)
-        (image pdf)
-        (image png)
-        (image postscript)
-        (image svg)
-        (image tif)
-        (image webp)))
+    (image jpeg)
+    (image pdf)
+    (image png)
+    (image postscript)
+    (image svg)
+    (image tif)
+    (image webp)
+    (image xmgrace)
+  ) ;:use
+) ;texmacs-module
diff --git a/TeXmacs/plugins/image_xmgrace/progs/init-image_xmgrace.scm b/TeXmacs/plugins/image_xmgrace/progs/init-image_xmgrace.scm
deleted file mode 100644
index f8b08b80fc..0000000000
--- a/TeXmacs/plugins/image_xmgrace/progs/init-image_xmgrace.scm
+++ /dev/null
@@ -1,15 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : init-xmgrace.scm
-;; DESCRIPTION : xmgrace Image plugin
-;; COPYRIGHT   : (C) 2024  Darcy Shen
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-(lazy-format (image xmgrace) xmgrace)
diff --git a/TeXmacs/plugins/java/packages/code/java.stem b/TeXmacs/plugins/java/packages/code/java.stem
new file mode 100644
index 0000000000..af611dfe61
--- /dev/null
+++ b/TeXmacs/plugins/java/packages/code/java.stem
@@ -0,0 +1,32 @@
+(document (TeXmacs "2.1.2")
+  (style (tuple "source" "std"))
+  (body (document (active* (src-title (document (compound "src-package" "java" "1.0")
+                                        (src-purpose (document "java Language"))
+                                        (src-copyright "2020-2024" "Darcy Shen")
+                                        (src-license (document (concat "This software falls under the "
+                                                                 (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE")
+                                                                 ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see "
+                                                                 (hlink "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                   "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                 ) ;hlink
+                                                                 "."
+                                                               ) ;concat
+                                                     ) ;document
+                                        ) ;src-license
+                                      ) ;document
+                           ) ;src-title
+                  ) ;active*
+          (use-module "(java java-format)")
+          (use-module "(java java-edit)")
+          (assign "java"
+            (macro "body"
+              (with "mode" "prog" "prog-language" "java" "font-family" "rm" (arg "body"))
+            ) ;macro
+          ) ;assign
+          (assign "java-code"
+            (macro "body" (document (pseudo-code (document (java (arg "body"))))))
+          ) ;assign
+        ) ;document
+  ) ;body
+  (initial (collection (associate "preamble" "true") (associate "sfactor" "5")))
+) ;document
diff --git a/TeXmacs/plugins/java/packages/code/java.ts b/TeXmacs/plugins/java/packages/code/java.ts
deleted file mode 100644
index bbd7e2b9d5..0000000000
--- a/TeXmacs/plugins/java/packages/code/java.ts
+++ /dev/null
@@ -1,41 +0,0 @@
-
-
->
-
-<\body>
-  
-    
-
-    <\src-purpose>
-      java Language
-    
-
-    
-
-    <\src-license>
-      This software falls under the . It comes WITHOUT ANY
-      WARRANTY WHATSOEVER. You should have received a copy of the license
-      which the software. If not, see .
-    
-  >
-
-  
-
-  
-
-  >>>
-
-  
-    <\pseudo-code>
-      >
-    
-  >
-
-
-<\initial>
-  <\collection>
-    
-    
-  
-
diff --git a/TeXmacs/plugins/java/progs/code/java-edit.scm b/TeXmacs/plugins/java/progs/code/java-edit.scm
deleted file mode 100644
index 05b20c1c28..0000000000
--- a/TeXmacs/plugins/java/progs/code/java-edit.scm
+++ /dev/null
@@ -1,33 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : java-edit.scm
-;; DESCRIPTION : editing Java programs
-;; COPYRIGHT   : (C) 2019  Darcy Shen
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (code java-edit)
-  (:use (prog prog-edit)))
-
-(tm-define (get-tabstop)
-  (:mode in-prog-java?)
-  4)
-
-(tm-define (kbd-paste)
-  (:mode in-prog-java?)
-  (clipboard-paste-import "java" "primary"))
-
-(kbd-map
-  (:mode in-prog-java?)
-  ("p s v m var"
-   (begin
-    (insert "public static void main(String[] args) {}")
-    (go-to-previous)
-    (insert-return)
-    (insert-raw-return)
-    (go-to-previous))))
diff --git a/TeXmacs/plugins/java/progs/code/java-lang.scm b/TeXmacs/plugins/java/progs/code/java-lang.scm
deleted file mode 100644
index 3388586ac6..0000000000
--- a/TeXmacs/plugins/java/progs/code/java-lang.scm
+++ /dev/null
@@ -1,73 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : java-lang.scm
-;; DESCRIPTION : Java Language
-;; COPYRIGHT   : (C) 2019-2020  Darcy Shen
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (code java-lang)
-  (:use (prog default-lang)))
-
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "java") (== key "keyword")))
-  `(,(string->symbol key)
-    (constant
-      "false" "true" "null"
-      "boolean" "byte" "char" "double" "float" "int" "long" "short" "void"
-      "IllegalArgumentException" "NullPointerException" "Exception" "RuntimeException")
-    (declare_type "class" "interface" "enum")
-    (declare_identifier "val" "var")
-    (declare_module "package" "import")
-    (keyword
-      "new" "extends" "implements" "super" "this" "instanceof" ;; Object Oriented
-      "default" "native" "abstract" "final" "static" "volatile" "transient";; Local Modifiers
-      "private" "protected" "public";; Access Modifiers
-      "throws" "synchronized")
-    (keyword_conditional
-      "break" "continue" "do" "else" "for" "if" "while" "goto" "switch" "case")
-    (keyword_control
-      "throw" "catch" "finally" "return" "try" "yield")))
-
-
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "java") (== key "operator")))
-  `(,(string->symbol key)
-    (operator
-      "+" "-" "/" "*" "%" ;; Arith
-      "|" "&" "^" ;; Bit
-      "<<" ">>" 
-      "<" ">" "<=" ">=" "&&" "||" "!" "==" "!=" ;; Boolean
-      "+=" "-=" "/=" "*=" "%=" "|=" "&=" "^=" ;; Assignment
-      "=" ":" ";")
-    (operator_special "->")
-    (operator_decoration "@")
-    (operator_field "." "::")
-    (operator_openclose "{" "[" "(" ")" "]" "}")))
-
-(define (java-number-suffix)
-  `(suffix
-    (long "l" "L")
-    (double "d" "D")
-    (float "f" "F")))
-
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "java") (== key "number")))
-  `(,(string->symbol key)
-    (bool_features
-      "prefix_0x" "prefix_0b"
-      "sci_notation")
-    ,(java-number-suffix)))
-
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "java") (== key "string")))
-  `(,(string->symbol key)
-    (bool_features
-     "hex_with_8_bits" "hex_with_16_bits"
-     "hex_with_32_bits" "octal_upto_3_digits")
-    (escape_sequences "\\" "\"" "'" "b" "f" "n" "r" "t")))
diff --git a/TeXmacs/plugins/java/progs/data/java.scm b/TeXmacs/plugins/java/progs/data/java.scm
deleted file mode 100644
index 876c1a7af9..0000000000
--- a/TeXmacs/plugins/java/progs/data/java.scm
+++ /dev/null
@@ -1,43 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : java.scm
-;; DESCRIPTION : prog format for Java
-;; COPYRIGHT   : (C) 2022  Darcy Shen, Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (data java))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Java source files
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define-format java
-  (:name "Java source code")
-  (:suffix "java"))
-
-(define (texmacs->java x . opts)
-  (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '())))
-
-(define (java->texmacs x . opts)
-  (code->texmacs x))
-
-(define (java-snippet->texmacs x . opts)
-  (code-snippet->texmacs x))
-
-(converter texmacs-tree java-document
-  (:function texmacs->java))
-
-(converter java-document texmacs-tree
-  (:function java->texmacs))
-  
-(converter texmacs-tree java-snippet
-  (:function texmacs->java))
-
-(converter java-snippet texmacs-tree
-  (:function java-snippet->texmacs))
diff --git a/TeXmacs/plugins/java/progs/java/java-edit.scm b/TeXmacs/plugins/java/progs/java/java-edit.scm
new file mode 100644
index 0000000000..ca0e9efb2b
--- /dev/null
+++ b/TeXmacs/plugins/java/progs/java/java-edit.scm
@@ -0,0 +1,33 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : java-edit.scm
+;; DESCRIPTION : editing Java programs
+;; COPYRIGHT   : (C) 2019  Darcy Shen
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (java java-edit) (:use (prog prog-edit)))
+
+(tm-define (get-tabstop) (:mode in-prog-java?) 4)
+
+(tm-define (kbd-paste)
+  (:mode in-prog-java?)
+  (clipboard-paste-import "java" "primary")
+) ;tm-define
+
+(kbd-map (:mode in-prog-java?)
+ ("p s v m var"
+   (begin
+     (insert "public static void main(String[] args) {}")
+     (go-to-previous)
+     (insert-return)
+     (insert-raw-return)
+     (go-to-previous)
+   ) ;begin
+ ) ;
+) ;kbd-map
diff --git a/TeXmacs/plugins/java/progs/java/java-format.scm b/TeXmacs/plugins/java/progs/java/java-format.scm
new file mode 100644
index 0000000000..7b4dde73c8
--- /dev/null
+++ b/TeXmacs/plugins/java/progs/java/java-format.scm
@@ -0,0 +1,40 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : java.scm
+;; DESCRIPTION : prog format for Java
+;; COPYRIGHT   : (C) 2022  Darcy Shen, Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (java java-format))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Java source files
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-format java (:name "Java source code") (:suffix "java"))
+
+(define (texmacs->java x . opts)
+  (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '()))
+) ;define
+
+(define (java->texmacs x . opts)
+  (code->texmacs x)
+) ;define
+
+(define (java-snippet->texmacs x . opts)
+  (code-snippet->texmacs x)
+) ;define
+
+(converter texmacs-tree java-document (:function texmacs->java))
+
+(converter java-document texmacs-tree (:function java->texmacs))
+
+(converter texmacs-tree java-snippet (:function texmacs->java))
+
+(converter java-snippet texmacs-tree (:function java-snippet->texmacs))
diff --git a/TeXmacs/plugins/java/progs/java/java-lang.scm b/TeXmacs/plugins/java/progs/java/java-lang.scm
new file mode 100644
index 0000000000..bec329e71c
--- /dev/null
+++ b/TeXmacs/plugins/java/progs/java/java-lang.scm
@@ -0,0 +1,112 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : java-lang.scm
+;; DESCRIPTION : Java Language
+;; COPYRIGHT   : (C) 2019-2020  Darcy Shen
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (java java-lang) (:use (prog default-lang)))
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "java") (== key "keyword")))
+  `(,(string->symbol key)
+    (constant "false" "true" "null" "boolean" "byte" "char" "double" "float"
+      "int" "long" "short" "void" "IllegalArgumentException"
+      "NullPointerException" "Exception" "RuntimeException")
+    (declare_type "class" "interface" "enum")
+    (declare_identifier "val" "var")
+    (declare_module "package" "import")
+    (keyword "new"
+      "extends"
+      "implements"
+      "super"
+      "this"
+      "instanceof"
+      ;; Object Oriented
+      "default"
+      "native"
+      "abstract"
+      "final"
+      "static"
+      "volatile"
+      "transient"
+      ;; Local Modifiers
+      "private"
+      "protected"
+      "public"
+      ;; Access Modifiers
+      "throws"
+      "synchronized")
+    (keyword_conditional "break" "continue" "do" "else" "for" "if" "while"
+      "goto" "switch" "case")
+    (keyword_control "throw" "catch" "finally" "return" "try" "yield"))
+) ;tm-define
+
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "java") (== key "operator")))
+  `(,(string->symbol key)
+    (operator "+"
+      "-"
+      "/"
+      "*"
+      "%"
+      ;; Arith
+      "|"
+      "&"
+      "^"
+      ;; Bit
+      "<<"
+      ">>"
+      "<"
+      ">"
+      "<="
+      ">="
+      "&&"
+      "||"
+      "!"
+      "=="
+      "!="
+      ;; Boolean
+      "+="
+      "-="
+      "/="
+      "*="
+      "%="
+      "|="
+      "&="
+      "^="
+      ;; Assignment
+      "="
+      ":"
+      ";")
+    (operator_special "->")
+    (operator_decoration "@")
+    (operator_field "." "::")
+    (operator_openclose "{" "[" "(" ")" "]" "}"))
+) ;tm-define
+
+(define (java-number-suffix)
+  '(suffix (long "l" "L") (double "d" "D") (float "f" "F"))
+) ;define
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "java") (== key "number")))
+  `(,(string->symbol key)
+    (bool_features "prefix_0x" "prefix_0b" "sci_notation")
+    ,(java-number-suffix))
+) ;tm-define
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "java") (== key "string")))
+  `(,(string->symbol key)
+    (bool_features "hex_with_8_bits" "hex_with_16_bits" "hex_with_32_bits"
+      "octal_upto_3_digits")
+    (escape_sequences "\\" "\"" "'" "b" "f" "n" "r" "t"))
+) ;tm-define
diff --git a/TeXmacs/plugins/javascript/packages/code/javascript.stem b/TeXmacs/plugins/javascript/packages/code/javascript.stem
new file mode 100644
index 0000000000..3a8c29caf2
--- /dev/null
+++ b/TeXmacs/plugins/javascript/packages/code/javascript.stem
@@ -0,0 +1,38 @@
+(document (TeXmacs "2.1.2")
+  (style (tuple "source" "std"))
+  (body (document (active* (src-title (document (compound "src-package" "javascript" "1.0")
+                                        (src-purpose (document "JavaScript Language"))
+                                        (src-copyright "2020-2024" "Darcy Shen")
+                                        (src-license (document (concat "This software falls under the "
+                                                                 (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE")
+                                                                 ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see "
+                                                                 (hlink "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                   "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                 ) ;hlink
+                                                                 "."
+                                                               ) ;concat
+                                                     ) ;document
+                                        ) ;src-license
+                                      ) ;document
+                           ) ;src-title
+                  ) ;active*
+          (use-module "(javascript javascript-format)")
+          (assign "javascript"
+            (macro "body"
+              (with "mode"
+                "prog"
+                "prog-language"
+                "javascript"
+                "font-family"
+                "rm"
+                (arg "body")
+              ) ;with
+            ) ;macro
+          ) ;assign
+          (assign "javascript-code"
+            (macro "body" (document (pseudo-code (document (javascript (arg "body"))))))
+          ) ;assign
+        ) ;document
+  ) ;body
+  (initial (collection (associate "preamble" "true") (associate "sfactor" "5")))
+) ;document
diff --git a/TeXmacs/plugins/javascript/packages/code/javascript.ts b/TeXmacs/plugins/javascript/packages/code/javascript.ts
deleted file mode 100644
index f7713544f3..0000000000
--- a/TeXmacs/plugins/javascript/packages/code/javascript.ts
+++ /dev/null
@@ -1,39 +0,0 @@
-
-
->
-
-<\body>
-  
-    
-
-    <\src-purpose>
-      JavaScript Language
-    
-
-    
-
-    <\src-license>
-      This software falls under the . It comes WITHOUT ANY
-      WARRANTY WHATSOEVER. You should have received a copy of the license
-      which the software. If not, see .
-    
-  >
-
-  
-
-  >>>
-
-  
-    <\pseudo-code>
-      >
-    
-  >
-
-
-<\initial>
-  <\collection>
-    
-    
-  
-
\ No newline at end of file
diff --git a/TeXmacs/plugins/javascript/progs/code/javascript-lang.scm b/TeXmacs/plugins/javascript/progs/code/javascript-lang.scm
deleted file mode 100644
index 242633b1c5..0000000000
--- a/TeXmacs/plugins/javascript/progs/code/javascript-lang.scm
+++ /dev/null
@@ -1,78 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : javascript-lang.scm
-;; DESCRIPTION : JavaScript Language
-;; COPYRIGHT   : (C) 2020  Darcy Shen
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (code javascript-lang)
-  (:use (prog default-lang)))
-
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "javascript") (== key "keyword")))
-  `(,(string->symbol key)
-    (constant
-      "false" "true" "null" "undefined" "NaN" "Infinity"
-      "void" "Array" "Boolean" "BigInt" "Map" "Object" "String" "Set")
-    (declare_type "class" "interface" "enum")
-    (declare_identifier "let" "var")
-    (declare_module "as" "default" "export" "from" "import" "package")
-    (keyword
-      "new" "extends" "implements" "super" "this" "instanceof" ;; Object Oriented
-      "abstract" "const" "static" "private" "protected" "public" ;; Modifiers
-      "function" "delete" "in" "arguments" "async" "await")
-    (keyword_conditional
-      "else"  "if" "goto" "switch" "case")
-    (keyword_control
-      "await" "break" "catch" "continue" "debugger" "do"
-      "for" "finally" "return" "throw" "try" "while" "with")))
-
-;; Ref: https://ecma-international.org/ecma-262/10.0/index.html#sec-update-expressions
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "javascript") (== key "operator")))
-  `(,(string->symbol key)
-    (operator
-      "++" "--" ;; Update Expressions
-      "+" "-" "~" "!" ;; Unary Operators
-      "**" ;; Exponentiation Operator
-      "/" "*" "%" ;; Multiplicative Operators
-      ;; Additive Operators (already in Unary Operators)
-      "<<" ">>" ">>>" ;; Bitwise Shift Operators
-      "<" ">" "<=" ">=" "instanceof" "in" ;; Relational Operators
-      ;; Assignment Operators
-      "="
-      "+=" "-=" "/=" "*=" "%="  "**="
-      "&=" "^=" "|="
-      "<<=" ">>=" ">>>="
-      "==" "!=" "===" "!==" ;; Equality Operators
-      "|" "&" "^" ;; Binary Bitwise Operators
-      "&&" "||" "!" ;; Binary Logical Operators
-      "?" ":" ;; Conditional Operator
-      "," ;; Comma Operator
-      ";")
-    (operator_special "->")
-    (operator_decoration "@")
-    (operator_field "." "::")
-    (operator_openclose "{" "[" "(" ")" "]" "}")))
-
-;; Ref: https://ecma-international.org/ecma-262/10.0/index.html#sec-literals-numeric-literals
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "javascript") (== key "number")))
-  `(,(string->symbol key)
-    (bool_features
-      "prefix_0x" "prefix_0b" "prefix_0o"
-      "sci_notation")))
-
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "javascript") (== key "string")))
-  `(,(string->symbol key)
-    (bool_features
-     "hex_with_8_bits" "hex_with_16_bits"
-     "hex_with_32_bits" "octal_upto_3_digits")
-    (escape_sequences "\\" "\"" "'" "b" "f" "n" "r" "v" "t")))
diff --git a/TeXmacs/plugins/javascript/progs/data/javascript.scm b/TeXmacs/plugins/javascript/progs/data/javascript.scm
deleted file mode 100644
index 214390dfb4..0000000000
--- a/TeXmacs/plugins/javascript/progs/data/javascript.scm
+++ /dev/null
@@ -1,43 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : init-prog_javascript.scm
-;; DESCRIPTION : prog format for Javascript
-;; COPYRIGHT   : (C) 2023  Darcy Shen, Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (data javascript))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Javascript source files
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define-format javascript
-  (:name "Javascript source code")
-  (:suffix "js"))
-  
-(define (texmacs->javascript x . opts)
-  (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '())))
-
-(define (javascript->texmacs x . opts)
-  (code->texmacs x))
-
-(define (javascript-snippet->texmacs x . opts)
-  (code-snippet->texmacs x))
-
-(converter texmacs-tree javascript-document
-  (:function texmacs->javascript))
-
-(converter javascript-document texmacs-tree
-  (:function javascript->texmacs))
-  
-(converter texmacs-tree javascript-snippet
-  (:function texmacs->javascript))
-
-(converter javascript-snippet texmacs-tree
-  (:function javascript-snippet->texmacs))
diff --git a/TeXmacs/plugins/javascript/progs/javascript/javascript-format.scm b/TeXmacs/plugins/javascript/progs/javascript/javascript-format.scm
new file mode 100644
index 0000000000..b9f2d15111
--- /dev/null
+++ b/TeXmacs/plugins/javascript/progs/javascript/javascript-format.scm
@@ -0,0 +1,43 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : init-prog_javascript.scm
+;; DESCRIPTION : prog format for Javascript
+;; COPYRIGHT   : (C) 2023  Darcy Shen, Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (javascript javascript-format))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Javascript source files
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-format javascript (:name "Javascript source code") (:suffix "js"))
+
+(define (texmacs->javascript x . opts)
+  (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '()))
+) ;define
+
+(define (javascript->texmacs x . opts)
+  (code->texmacs x)
+) ;define
+
+(define (javascript-snippet->texmacs x . opts)
+  (code-snippet->texmacs x)
+) ;define
+
+(converter texmacs-tree javascript-document (:function texmacs->javascript))
+
+(converter javascript-document texmacs-tree (:function javascript->texmacs))
+
+(converter texmacs-tree javascript-snippet (:function texmacs->javascript))
+
+(converter javascript-snippet
+  texmacs-tree
+  (:function javascript-snippet->texmacs)
+) ;converter
diff --git a/TeXmacs/plugins/javascript/progs/javascript/javascript-lang.scm b/TeXmacs/plugins/javascript/progs/javascript/javascript-lang.scm
new file mode 100644
index 0000000000..a554ef03f3
--- /dev/null
+++ b/TeXmacs/plugins/javascript/progs/javascript/javascript-lang.scm
@@ -0,0 +1,131 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : javascript-lang.scm
+;; DESCRIPTION : JavaScript Language
+;; COPYRIGHT   : (C) 2020  Darcy Shen
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (javascript javascript-lang) (:use (prog default-lang)))
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "javascript") (== key "keyword")))
+  `(,(string->symbol key)
+    (constant "false" "true" "null" "undefined" "NaN" "Infinity" "void" "Array"
+      "Boolean" "BigInt" "Map" "Object" "String" "Set")
+    (declare_type "class" "interface" "enum")
+    (declare_identifier "let" "var")
+    (declare_module "as" "default" "export" "from" "import" "package")
+    (keyword "new"
+      "extends"
+      "implements"
+      "super"
+      "this"
+      "instanceof"
+      ;; Object Oriented
+      "abstract"
+      "const"
+      "static"
+      "private"
+      "protected"
+      "public"
+      ;; Modifiers
+      "function"
+      "delete"
+      "in"
+      "arguments"
+      "async"
+      "await")
+    (keyword_conditional "else" "if" "goto" "switch" "case")
+    (keyword_control "await" "break" "catch" "continue" "debugger" "do" "for"
+      "finally" "return" "throw" "try" "while" "with"))
+) ;tm-define
+
+;; Ref: https://ecma-international.org/ecma-262/10.0/index.html#sec-update-expressions
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "javascript") (== key "operator")))
+  `(,(string->symbol key)
+    (operator "++"
+      "--"
+      ;; Update Expressions
+      "+"
+      "-"
+      "~"
+      "!"
+      ;; Unary Operators
+      "**"
+      ;; Exponentiation Operator
+      "/"
+      "*"
+      "%"
+      ;; Multiplicative Operators
+      ;; Additive Operators (already in Unary Operators)
+      "<<"
+      ">>"
+      ">>>"
+      ;; Bitwise Shift Operators
+      "<"
+      ">"
+      "<="
+      ">="
+      "instanceof"
+      "in"
+      ;; Relational Operators
+      ;; Assignment Operators
+      "="
+      "+="
+      "-="
+      "/="
+      "*="
+      "%="
+      "**="
+      "&="
+      "^="
+      "|="
+      "<<="
+      ">>="
+      ">>>="
+      "=="
+      "!="
+      "==="
+      "!=="
+      ;; Equality Operators
+      "|"
+      "&"
+      "^"
+      ;; Binary Bitwise Operators
+      "&&"
+      "||"
+      "!"
+      ;; Binary Logical Operators
+      "?"
+      ":"
+      ;; Conditional Operator
+      ","
+      ;; Comma Operator
+      ";")
+    (operator_special "->")
+    (operator_decoration "@")
+    (operator_field "." "::")
+    (operator_openclose "{" "[" "(" ")" "]" "}"))
+) ;tm-define
+
+;; Ref: https://ecma-international.org/ecma-262/10.0/index.html#sec-literals-numeric-literals
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "javascript") (== key "number")))
+  `(,(string->symbol key)
+    (bool_features "prefix_0x" "prefix_0b" "prefix_0o" "sci_notation"))
+) ;tm-define
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "javascript") (== key "string")))
+  `(,(string->symbol key)
+    (bool_features "hex_with_8_bits" "hex_with_16_bits" "hex_with_32_bits"
+      "octal_upto_3_digits")
+    (escape_sequences "\\" "\"" "'" "b" "f" "n" "r" "v" "t"))
+) ;tm-define
diff --git a/TeXmacs/plugins/json/packages/code/json.stem b/TeXmacs/plugins/json/packages/code/json.stem
new file mode 100644
index 0000000000..3f246ae23f
--- /dev/null
+++ b/TeXmacs/plugins/json/packages/code/json.stem
@@ -0,0 +1,44 @@
+(document (TeXmacs "2.1.4")
+  (style (tuple "source" "std"))
+  (body (document (active* (src-title (document (compound "src-package" "json" "1.0")
+                                        (src-purpose (document "json Language"))
+                                        (src-copyright "2020-2024" "Darcy Shen")
+                                        (src-license (document (concat "This software falls under the "
+                                                                 (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE")
+                                                                 ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see "
+                                                                 (hlink "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                   "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                 ) ;hlink
+                                                                 "."
+                                                               ) ;concat
+                                                     ) ;document
+                                        ) ;src-license
+                                      ) ;document
+                           ) ;src-title
+                  ) ;active*
+          (use-module "(json json-format)")
+          (assign "json"
+            (macro "body"
+              (with "mode" "prog" "prog-language" "json" "font-family" "rm" (arg "body"))
+            ) ;macro
+          ) ;assign
+          (assign "json-code"
+            (macro "body" (document (pseudo-code (document (json (arg "body"))))))
+          ) ;assign
+          (assign "json-chunk"
+            (macro "name"
+              "prev"
+              "next"
+              "body"
+              (document (generic-chunk (arg "name")
+                          (arg "prev")
+                          (arg "next")
+                          (document (json (document (arg "body"))))
+                        ) ;generic-chunk
+              ) ;document
+            ) ;macro
+          ) ;assign
+        ) ;document
+  ) ;body
+  (initial (collection (associate "preamble" "true") (associate "sfactor" "5")))
+) ;document
diff --git a/TeXmacs/plugins/json/packages/code/json.ts b/TeXmacs/plugins/json/packages/code/json.ts
deleted file mode 100644
index 1431b5e24c..0000000000
--- a/TeXmacs/plugins/json/packages/code/json.ts
+++ /dev/null
@@ -1,47 +0,0 @@
-
-
->
-
-<\body>
-  
-    
-
-    <\src-purpose>
-      json Language
-    
-
-    
-
-    <\src-license>
-      This software falls under the . It comes WITHOUT ANY
-      WARRANTY WHATSOEVER. You should have received a copy of the license
-      which the software. If not, see .
-    
-  >
-
-  
-
-  >>>
-
-  
-    <\pseudo-code>
-      >
-    
-  >
-
-  
-    <\generic-chunk|||>
-      <\json>
-        
-      
-    
-  >
-
-
-<\initial>
-  <\collection>
-    
-    
-  
-
\ No newline at end of file
diff --git a/TeXmacs/plugins/json/progs/data/json.scm b/TeXmacs/plugins/json/progs/data/json.scm
deleted file mode 100644
index d702b6d701..0000000000
--- a/TeXmacs/plugins/json/progs/data/json.scm
+++ /dev/null
@@ -1,44 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : init-data_json.scm
-;; DESCRIPTION : json data format
-;; COPYRIGHT   : (C) 2022  Darcy Shen, Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (data json))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; JSON source files
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define-format json
-  (:name "JSON")
-  (:suffix "json"))
-
-(define (texmacs->json x . opts)
-  (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '())))
-
-(define (json->texmacs x . opts)
-  (code->texmacs x))
-
-(define (json-snippet->texmacs x . opts)
-  (code-snippet->texmacs x))
-
-(converter texmacs-tree json-document
-  (:function texmacs->json))
-
-(converter json-document texmacs-tree
-  (:function json->texmacs))
-  
-(converter texmacs-tree json-snippet
-  (:function texmacs->json))
-
-(converter json-snippet texmacs-tree
-  (:function json-snippet->texmacs))
-
diff --git a/TeXmacs/plugins/json/progs/init-json.scm b/TeXmacs/plugins/json/progs/init-json.scm
index 43a93534fc..f198960c21 100644
--- a/TeXmacs/plugins/json/progs/init-json.scm
+++ b/TeXmacs/plugins/json/progs/init-json.scm
@@ -11,4 +11,4 @@
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(lazy-format (data json) json)
+(lazy-format (json json-format) json)
diff --git a/TeXmacs/plugins/json/progs/json/json-format.scm b/TeXmacs/plugins/json/progs/json/json-format.scm
new file mode 100644
index 0000000000..ab7e62b195
--- /dev/null
+++ b/TeXmacs/plugins/json/progs/json/json-format.scm
@@ -0,0 +1,40 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : init-data_json.scm
+;; DESCRIPTION : json data format
+;; COPYRIGHT   : (C) 2022  Darcy Shen, Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (json json-format))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; JSON source files
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-format json (:name "JSON") (:suffix "json"))
+
+(define (texmacs->json x . opts)
+  (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '()))
+) ;define
+
+(define (json->texmacs x . opts)
+  (code->texmacs x)
+) ;define
+
+(define (json-snippet->texmacs x . opts)
+  (code-snippet->texmacs x)
+) ;define
+
+(converter texmacs-tree json-document (:function texmacs->json))
+
+(converter json-document texmacs-tree (:function json->texmacs))
+
+(converter texmacs-tree json-snippet (:function texmacs->json))
+
+(converter json-snippet texmacs-tree (:function json-snippet->texmacs))
diff --git a/TeXmacs/plugins/json/progs/code/json-lang.scm b/TeXmacs/plugins/json/progs/json/json-lang.scm
similarity index 75%
rename from TeXmacs/plugins/json/progs/code/json-lang.scm
rename to TeXmacs/plugins/json/progs/json/json-lang.scm
index f557f6e667..6f83fed124 100644
--- a/TeXmacs/plugins/json/progs/code/json-lang.scm
+++ b/TeXmacs/plugins/json/progs/json/json-lang.scm
@@ -11,31 +11,30 @@
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(texmacs-module (code json-lang)
-  (:use (prog default-lang)))
+(texmacs-module (json json-lang) (:use (prog default-lang)))
 
 (tm-define (parser-feature lan key)
   (:require (and (== lan "json") (== key "keyword")))
-  `(,(string->symbol key)
-    (constant
-      "false" "true" "null")))
+  `(,(string->symbol key) (constant "false" "true" "null"))
+) ;tm-define
 
 ;; Ref: https://ecma-international.org/ecma-262/10.0/index.html#sec-update-expressions
 (tm-define (parser-feature lan key)
   (:require (and (== lan "json") (== key "operator")))
   `(,(string->symbol key)
     (operator "+" "-" ":" ",")
-    (operator_openclose "{" "[" "(" ")" "]" "}")))
+    (operator_openclose "{" "[" "(" ")" "]" "}"))
+) ;tm-define
 
 ;; Ref: https://ecma-international.org/ecma-262/10.0/index.html#sec-literals-numeric-literals
 (tm-define (parser-feature lan key)
   (:require (and (== lan "json") (== key "number")))
-  `(,(string->symbol key)
-    (bool_features
-      "sci_notation")))
+  `(,(string->symbol key) (bool_features "sci_notation"))
+) ;tm-define
 
 (tm-define (parser-feature lan key)
   (:require (and (== lan "json") (== key "string")))
   `(,(string->symbol key)
-    (bool_features )
-    (escape_sequences "\\" "/" "\"" "b" "f" "n" "r" "t")))
+    (bool_features)
+    (escape_sequences "\\" "/" "\"" "b" "f" "n" "r" "t"))
+) ;tm-define
diff --git a/TeXmacs/plugins/julia/packages/code/julia.stem b/TeXmacs/plugins/julia/packages/code/julia.stem
new file mode 100644
index 0000000000..6729f36991
--- /dev/null
+++ b/TeXmacs/plugins/julia/packages/code/julia.stem
@@ -0,0 +1,31 @@
+(document (TeXmacs "2.1.2")
+  (style (tuple "source" "std"))
+  (body (document (active* (src-title (document (compound "src-package" "julia" "1.0")
+                                        (src-purpose (document "julia Language"))
+                                        (src-copyright "2020-2024" "Darcy Shen")
+                                        (src-license (document (concat "This software falls under the "
+                                                                 (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE")
+                                                                 ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see "
+                                                                 (hlink "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                   "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                 ) ;hlink
+                                                                 "."
+                                                               ) ;concat
+                                                     ) ;document
+                                        ) ;src-license
+                                      ) ;document
+                           ) ;src-title
+                  ) ;active*
+          (use-module "(julia julia-format)")
+          (assign "julia"
+            (macro "body"
+              (with "mode" "prog" "prog-language" "julia" "font-family" "rm" (arg "body"))
+            ) ;macro
+          ) ;assign
+          (assign "julia-code"
+            (macro "body" (document (pseudo-code (document (julia (arg "body"))))))
+          ) ;assign
+        ) ;document
+  ) ;body
+  (initial (collection (associate "preamble" "true") (associate "sfactor" "5")))
+) ;document
diff --git a/TeXmacs/plugins/julia/packages/code/julia.ts b/TeXmacs/plugins/julia/packages/code/julia.ts
deleted file mode 100644
index 3c2c017358..0000000000
--- a/TeXmacs/plugins/julia/packages/code/julia.ts
+++ /dev/null
@@ -1,39 +0,0 @@
-
-
->
-
-<\body>
-  
-    
-
-    <\src-purpose>
-      julia Language
-    
-
-    
-
-    <\src-license>
-      This software falls under the . It comes WITHOUT ANY
-      WARRANTY WHATSOEVER. You should have received a copy of the license
-      which the software. If not, see .
-    
-  >
-
-  
-
-  >>>
-
-  
-    <\pseudo-code>
-      >
-    
-  >
-
-
-<\initial>
-  <\collection>
-    
-    
-  
-
diff --git a/TeXmacs/plugins/julia/progs/code/julia-lang.scm b/TeXmacs/plugins/julia/progs/code/julia-lang.scm
deleted file mode 100644
index 55024da704..0000000000
--- a/TeXmacs/plugins/julia/progs/code/julia-lang.scm
+++ /dev/null
@@ -1,168 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : julia-lang.scm
-;; DESCRIPTION : Julia Language
-;; COPYRIGHT   : (C) 2021 Jeroen Wouters
-;; COPYRIGHT   : (C) 2026 AcceleratorX
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; https://docs.julialang.org/en/v1/base/base/#Keywords
-; This is the list of reserved keywords in Julia: baremodule, begin, break, catch, const, 
-; continue, do, else, elseif, end, export, false, finally, for, function, global, if, 
-; import, let, local, macro, module, quote, return, struct, true, try, using, while.
-; Those keywords are not allowed to be used as variable names.
-; 
-; The following two-word sequences are reserved: abstract type, mutable struct, 
-; primitive type. However, you can create variables with names: abstract, mutable,
-; primitive and type.
-; 
-; Finally, where is parsed as an infix operator for writing parametric method and 
-; type definitions. Also in and isa are parsed as infix operators. Creation of a 
-; variable named where, in or isa is allowed though.
-; 
-; Since Julia 1.11, public is parsed as a keyword when beginning a toplevel statement;
-; outer is parsed as a keyword when used to modify the scope of a variable in a for loop;
-; and as is used as a keyword to rename an identifier brought into scope by import or using.
-
-
-(texmacs-module (code julia-lang)
-  (:use (prog default-lang)))
-
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "julia") (== key "keyword")))
-  `(,(string->symbol key)
-    (constant
-      "true" "false" "nothing" "missing" "undef" "im" "NaN" "Inf" "pi" "ℯ")
-    (constant_type
-      "Any" "Nothing" "Missing" "Bool" "Char" "String" "Symbol"
-      "Int" "Int8" "Int16" "Int32" "Int64" "Int128"
-      "UInt" "UInt8" "UInt16" "UInt32" "UInt64" "UInt128"
-      "Float16" "Float32" "Float64" "Complex" "Rational"
-      "BigInt" "BigFloat" "Signed" "Unsigned" "AbstractIrrational"
-      "Array" "Vector" "Matrix" "Dict" "Set" "Tuple" "NamedTuple"
-      "Pair" "SubString" "Regex" "AbstractRange" "UnitRange" "StepRange"
-      "LinRange" "AbstractSet"
-      "Type" "Function" "Module" "Number" "Real" "Integer"
-      "AbstractFloat" "AbstractArray" "AbstractVector" "AbstractMatrix"
-      "AbstractDict" "AbstractString" "AbstractChar"
-      "Val" "Vararg" "Union" "UnionAll" "Some"
-      "Exception")
-    (declare_function "function" "do")
-    (declare_module "import" "using" "module" "baremodule" "export" "public")
-    (declare_type "struct" "abstract type" "mutable struct"
-      "primitive type")
-    (keyword
-      "let" "local" "global" "const" "end" "macro" "quote" "in" "isa" "where"
-      "outer" "as")
-    (keyword_conditional
-      "break" "continue" "elseif" "else" "for" "if" "while")
-    (keyword_control
-      "begin" "try" "catch" "return" "finally")))
-
-
-;; https://docs.julialang.org/en/v1/manual/mathematical-operations/
-;; arithm. operators: +, -, *, /, ÷, \, ^, %
-;; boolean operators: !, &&, ||
-;; bitwise operators: ~, &, |, ⊻, ⊼, ⊽, >>>, >>, <<
-;; updating operators: +=  -=  *=  /=  //=  \=  ÷=  %=  ^=  &=  |=  ⊻=  >>>=  >>=  <<=
-;; dot operators: . before operator
-;; numeric comparison: ==, !=, ≠, ===, !==, ≡, ≢, <, <=, ≤, >, >=, ≥
-;; approximate comparison: ≈, ≉
-;; membership: ∈, ∉, ∋, ∌
-;; roots: √, ∛, ∜
-;; adjoint (suffix): '
-
-;; https://docs.julialang.org/en/v1/base/punctuation/
-;; string and expression interpolation (prefix): $
-;; macro (prefix): @
-;; pipe operators: <|, |>
-;; subtype / supertype operators: <:, >:
-;; rational division: //
-;; function composition: ∘
-;; splat operator: ...
-;; type annotation / assert: ::
-;; dictionary pair: =>
-;; anonymous function: ->
-;; ternary conditional: ?
-;; broadcasted in-place assignment: .=
-
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "julia") (== key "operator")))
-  `(,(string->symbol key)
-    (operator
-      "+" "-" "*" "/" "÷" "\\" "^" "%" "!" "&&" "||"
-      "~" "&" "|" "⊻" "⊼" "⊽" ">>>" ">>" "<<" "+=" "-=" "*="
-      "/=" "\\=" "÷=" "%=" "^=" "&=" "|=" "⊻=" ">>>="
-      ">>=" "<<=" "==" "!=" "≠" "===" "!==" "≡" "≢" "<" "<=" "≤" ">" ">=" "≥" "√"
-      "∛" "∜" "≈" "≉" "∈" "∉" "∋" "∌" "<:" ">:" "<|" "|>" "∘"
-      "..." "::" "=>" "->" "?" ".=" "//" "//="
-      )
-    (operator_special ":")
-    (operator_decoration "@" "$")
-    (operator_field ".")
-    (operator_openclose "{" "[" "(" ")" "]" "}")))
-
-;; https://docs.julialang.org/en/v1/manual/complex-and-rational-numbers/#Rational-Numbers
-(define (julia-number-suffix)
-   `(suffix
-     (imaginary "im")))
-
-;; https://docs.julialang.org/en/v1/manual/integers-and-floating-point-numbers/
-(tm-define (parser-feature lan key)
- (:require (and (== lan "julia") (== key "number")))
- `(,(string->symbol key)
-  (bool_features
-    "prefix_0x" "prefix_0b" "prefix_0o" "no_suffix_with_box"
-    "sci_notation")
-  ,(julia-number-suffix)
-  (separator "_")))
-  
-  (tm-define (parser-feature lan key)
-    (:require (and (== lan "julia") (== key "string")))
-    `(,(string->symbol key)
-      (bool_features 
-       "hex_with_8_bits" "hex_with_16_bits"
-       "hex_with_32_bits" "octal_upto_3_digits")
-      (escape_sequences "\\" "\"" "'" "a" "b" "f" "n" "r" "t" "v" "newline")
-      (pairs "\"" "\"\"\"")))
-
-;; Julia also supports nestable multiline comments (#= ... =#), but the current
-;; Mogan comment parser only handles single-line inline comments.
-
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "julia") (== key "comment")))
-  `(,(string->symbol key)
-    (inline "#")))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Preferences for syntax highlighting
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (notify-julia-syntax var val)
-  (syntax-read-preferences "julia"))
-
-(define-preferences
-  ("syntax:julia:none" "red" notify-julia-syntax)
-  ("syntax:julia:comment" "brown" notify-julia-syntax)
-  ("syntax:julia:error" "dark red" notify-julia-syntax)
-  ("syntax:julia:constant" "#4040c0" notify-julia-syntax)
-  ("syntax:julia:constant_type" "#4040c0" notify-julia-syntax)
-  ("syntax:julia:constant_number" "#4040c0" notify-julia-syntax)
-  ("syntax:julia:constant_string" "dark grey" notify-julia-syntax)
-  ("syntax:julia:constant_char" "#333333" notify-julia-syntax)
-  ("syntax:julia:declare_function" "#0000c0" notify-julia-syntax)
-  ("syntax:julia:declare_module" "#0000c0" notify-julia-syntax)
-  ("syntax:julia:declare_type" "#0000c0" notify-julia-syntax)
-  ("syntax:julia:operator" "#8b008b" notify-julia-syntax)
-  ("syntax:julia:operator_openclose" "#B02020" notify-julia-syntax)
-  ("syntax:julia:operator_field" "#888888" notify-julia-syntax)
-  ("syntax:julia:operator_special" "orange" notify-julia-syntax)
-  ("syntax:julia:keyword" "#309090" notify-julia-syntax)
-  ("syntax:julia:keyword_conditional" "#309090" notify-julia-syntax)
-  ("syntax:julia:keyword_control" "#309090" notify-julia-syntax))
diff --git a/TeXmacs/plugins/julia/progs/data/julia.scm b/TeXmacs/plugins/julia/progs/data/julia.scm
deleted file mode 100644
index bc40bf9c51..0000000000
--- a/TeXmacs/plugins/julia/progs/data/julia.scm
+++ /dev/null
@@ -1,44 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : init-prog_julia.scm
-;; DESCRIPTION : prog format for Julia
-;; COPYRIGHT   : (C) 2022  Darcy Shen, Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (data julia))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Julia source files
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define-format julia
-  (:name "Julia source code")
-  (:suffix "jl"))
-  
-(define (texmacs->julia x . opts)
-  (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '())))
-
-(define (julia->texmacs x . opts)
-  (code->texmacs x))
-
-(define (julia-snippet->texmacs x . opts)
-  (code-snippet->texmacs x))
-
-(converter texmacs-tree julia-document
-  (:function texmacs->julia))
-
-(converter julia-document texmacs-tree
-  (:function julia->texmacs))
-  
-(converter texmacs-tree julia-snippet
-  (:function texmacs->julia))
-
-(converter julia-snippet texmacs-tree
-  (:function julia-snippet->texmacs))
-
diff --git a/TeXmacs/plugins/julia/progs/init-julia.scm b/TeXmacs/plugins/julia/progs/init-julia.scm
index e59d316063..a00655724f 100644
--- a/TeXmacs/plugins/julia/progs/init-julia.scm
+++ b/TeXmacs/plugins/julia/progs/init-julia.scm
@@ -11,34 +11,44 @@
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(use-modules (dynamic session-edit) (binary julia))
+(use-modules (julia julia-binary))
+
+(lazy-format (julia julia-format) julia)
 
 (define (julia-serialize lan t)
-  (let* ((u (pre-serialize lan t))
-         (s (texmacs->utf8raw (stree->tree u))))
-    (string-append s "\n\n")))
+  (with u
+    (pre-serialize lan t)
+    (with s (texmacs->utf8raw (stree->tree u)) (string-append s "\n\n"))
+  ) ;with
+) ;define
 
 (define (julia-entry)
-  (url->system (string->url
-    (if (url-exists? "$TEXMACS_HOME_PATH/plugins/julia/bin/julia.jl")
-        "$TEXMACS_HOME_PATH/plugins/julia/bin/julia.jl"
-        "$TEXMACS_PATH/plugins/julia/bin/julia.jl"))))
+  (url->system (string->url (if (url-exists? "$TEXMACS_HOME_PATH/plugins/julia/bin/julia.jl")
+                              "$TEXMACS_HOME_PATH/plugins/julia/bin/julia.jl"
+                              "$TEXMACS_PATH/plugins/julia/bin/julia.jl"
+                            ) ;if
+               ) ;string->url
+  ) ;url->system
+) ;define
 
 (define (julia-launcher)
-  (let* ((boot (string-quote (julia-entry)))
-         (cmd  (url->system (find-binary-julia))))
-    (if (or (os-win32?) (os-mingw?))
-        (string-append cmd " " boot)
-        (string-append "env -u LD_LIBRARY_PATH -u QT_PLUGIN_PATH " cmd " " boot))))
+  (let* ((boot (string-quote (julia-entry))) (cmd (url->system (find-binary-julia))))
+    (if (os-windows?)
+      (string-append cmd " " boot)
+      (string-append "env -u LD_LIBRARY_PATH -u QT_PLUGIN_PATH " cmd " " boot)
+    ) ;if
+  ) ;let*
+) ;define
 
 (plugin-configure julia
   (:require (has-binary-julia?))
   (:serializer ,julia-serialize)
   (:launch ,(julia-launcher))
   (:tab-completion #t)
-  (:session "Julia"))
-
-(lazy-format (data julia) julia)
+  (:session "Julia")
+) ;plugin-configure
 
 (when (supports-julia?)
-  (plugin-input-converters julia))
+  (use-modules (utils plugins plugin-convert))
+  (plugin-input-converters julia)
+) ;when
diff --git a/TeXmacs/plugins/julia/progs/julia/julia-binary.scm b/TeXmacs/plugins/julia/progs/julia/julia-binary.scm
new file mode 100644
index 0000000000..ab299e0c2d
--- /dev/null
+++ b/TeXmacs/plugins/julia/progs/julia/julia-binary.scm
@@ -0,0 +1,38 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : julia.scm
+;; DESCRIPTION : julia Binary plugin
+;; COPYRIGHT   : (C) 2026 Tianyou Liu
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (julia julia-binary) (:use (binary common)))
+
+(define (julia-binary-candidates)
+  (cond ((os-macos?)
+         (list "/Applications/Julia-*.app/Contents/Resources/julia/bin/julia"
+           "$HOME/Applications/Julia-*.app/Contents/Resources/julia/bin/julia"
+           "/opt/homebrew/bin/julia" "/usr/local/bin/julia"
+         ) ;list
+        ) ;
+        ((os-windows?)
+         (list "$LOCALAPPDATA/Programs/Julia*/bin/julia.exe"
+           "C:\\Program Files*\\Julia*\\bin\\julia.exe"
+         ) ;list
+        ) ;
+        (else (list "/usr/bin/julia"))
+  ) ;cond
+) ;define
+
+(tm-define (find-binary-julia)
+  (:synopsis "Find the url to the julia binary, return (url-none) if not found")
+  (find-binary (julia-binary-candidates) "julia")
+) ;tm-define
+
+(tm-define (has-binary-julia?) (not (url-none? (find-binary-julia))))
+
+(tm-define (version-binary-julia) (version-binary (find-binary-julia)))
diff --git a/TeXmacs/plugins/julia/progs/julia/julia-format.scm b/TeXmacs/plugins/julia/progs/julia/julia-format.scm
new file mode 100644
index 0000000000..0bb926fd70
--- /dev/null
+++ b/TeXmacs/plugins/julia/progs/julia/julia-format.scm
@@ -0,0 +1,40 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : init-prog_julia.scm
+;; DESCRIPTION : prog format for Julia
+;; COPYRIGHT   : (C) 2022  Darcy Shen, Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (julia julia-format))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Julia source files
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-format julia (:name "Julia source code") (:suffix "jl"))
+
+(define (texmacs->julia x . opts)
+  (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '()))
+) ;define
+
+(define (julia->texmacs x . opts)
+  (code->texmacs x)
+) ;define
+
+(define (julia-snippet->texmacs x . opts)
+  (code-snippet->texmacs x)
+) ;define
+
+(converter texmacs-tree julia-document (:function texmacs->julia))
+
+(converter julia-document texmacs-tree (:function julia->texmacs))
+
+(converter texmacs-tree julia-snippet (:function texmacs->julia))
+
+(converter julia-snippet texmacs-tree (:function julia-snippet->texmacs))
diff --git a/TeXmacs/plugins/julia/progs/julia/julia-lang.scm b/TeXmacs/plugins/julia/progs/julia/julia-lang.scm
new file mode 100644
index 0000000000..b0bae8744e
--- /dev/null
+++ b/TeXmacs/plugins/julia/progs/julia/julia-lang.scm
@@ -0,0 +1,144 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : julia-lang.scm
+;; DESCRIPTION : Julia Language
+;; COPYRIGHT   : (C) 2021 Jeroen Wouters
+;; COPYRIGHT   : (C) 2026 AcceleratorX
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; https://docs.julialang.org/en/v1/base/base/#Keywords
+
+
+(texmacs-module (julia julia-lang) (:use (prog default-lang)))
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "julia") (== key "keyword")))
+  `(,(string->symbol key)
+    (constant "true" "false" "nothing" "missing" "undef" "im" "NaN" "Inf" "pi"
+      "ℯ")
+    (constant_type "Any" "Nothing" "Missing" "Bool" "Char" "String" "Symbol"
+      "Int" "Int8" "Int16" "Int32" "Int64" "Int128" "UInt" "UInt8" "UInt16"
+      "UInt32" "UInt64" "UInt128" "Float16" "Float32" "Float64" "Complex"
+      "Rational" "BigInt" "BigFloat" "Signed" "Unsigned" "AbstractIrrational"
+      "Array" "Vector" "Matrix" "Dict" "Set" "Tuple" "NamedTuple" "Pair"
+      "SubString" "Regex" "AbstractRange" "UnitRange" "StepRange" "LinRange"
+      "AbstractSet" "Type" "Function" "Module" "Number" "Real" "Integer"
+      "AbstractFloat" "AbstractArray" "AbstractVector" "AbstractMatrix"
+      "AbstractDict" "AbstractString" "AbstractChar" "Val" "Vararg" "Union"
+      "UnionAll" "Some" "Exception")
+    (declare_function "function" "do")
+    (declare_module "import" "using" "module" "baremodule" "export" "public")
+    (declare_type "struct" "abstract type" "mutable struct" "primitive type")
+    (keyword "let" "local" "global" "const" "end" "macro" "quote" "in" "isa"
+      "where" "outer" "as")
+    (keyword_conditional "break" "continue" "elseif" "else" "for" "if" "while")
+    (keyword_control "begin" "try" "catch" "return" "finally"))
+) ;tm-define
+
+
+;; https://docs.julialang.org/en/v1/manual/mathematical-operations/
+;; arithm. operators: +, -, *, /, ÷, \, ^, %
+;; boolean operators: !, &&, ||
+;; bitwise operators: ~, &, |, ⊻, ⊼, ⊽, >>>, >>, <<
+;; updating operators: +=  -=  *=  /=  //=  \=  ÷=  %=  ^=  &=  |=  ⊻=  >>>=  >>=  <<=
+;; dot operators: . before operator
+;; numeric comparison: ==, !=, ≠, ===, !==, ≡, ≢, <, <=, ≤, >, >=, ≥
+;; approximate comparison: ≈, ≉
+;; membership: ∈, ∉, ∋, ∌
+;; roots: √, ∛, ∜
+;; adjoint (suffix): '
+
+;; https://docs.julialang.org/en/v1/base/punctuation/
+;; string and expression interpolation (prefix): $
+;; macro (prefix): @
+;; pipe operators: <|, |>
+;; subtype / supertype operators: <:, >:
+;; rational division: //
+;; function composition: ∘
+;; splat operator: ...
+;; type annotation / assert: ::
+;; dictionary pair: =>
+;; anonymous function: ->
+;; ternary conditional: ?
+;; broadcasted in-place assignment: .=
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "julia") (== key "operator")))
+  `(,(string->symbol key)
+    (operator "+" "-" "*" "/" "÷" "\\" "^" "%" "!" "&&" "||" "~" "&" "|" "⊻"
+      "⊼" "⊽" ">>>" ">>" "<<" "+=" "-=" "*=" "/=" "\\=" "÷=" "%=" "^=" "&="
+      "|=" "⊻=" ">>>=" ">>=" "<<=" "==" "!=" "≠" "===" "!==" "≡" "≢" "<"
+      "<=" "≤" ">" ">=" "≥" "√" "∛" "∜" "≈" "≉" "∈" "∉" "∋"
+      "∌" "<:" ">:" "<|" "|>" "∘" "..." "::" "=>" "->" "?" ".=" "//" "//=")
+    (operator_special ":")
+    (operator_decoration "@" "$")
+    (operator_field ".")
+    (operator_openclose "{" "[" "(" ")" "]" "}"))
+) ;tm-define
+
+;; https://docs.julialang.org/en/v1/manual/complex-and-rational-numbers/#Rational-Numbers
+
+(define (julia-number-suffix)
+  '(suffix (imaginary "im"))
+) ;define
+
+;; https://docs.julialang.org/en/v1/manual/integers-and-floating-point-numbers/
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "julia") (== key "number")))
+  `(,(string->symbol key)
+    (bool_features "prefix_0x" "prefix_0b" "prefix_0o" "no_suffix_with_box"
+      "sci_notation")
+    ,(julia-number-suffix)
+    (separator "_"))
+) ;tm-define
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "julia") (== key "string")))
+  `(,(string->symbol key)
+    (bool_features "hex_with_8_bits" "hex_with_16_bits" "hex_with_32_bits"
+      "octal_upto_3_digits")
+    (escape_sequences "\\" "\"" "'" "a" "b" "f" "n" "r" "t" "v" "newline")
+    (pairs "\"" "\"\"\""))
+) ;tm-define
+
+;; Julia also supports nestable multiline comments (#= ... =#), but the current
+;; Mogan comment parser only handles single-line inline comments.
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "julia") (== key "comment")))
+  `(,(string->symbol key) (inline "#"))
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Preferences for syntax highlighting
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (notify-julia-syntax var val)
+  (syntax-read-preferences "julia")
+) ;define
+
+(define-preferences ("syntax:julia:none" "red" notify-julia-syntax)
+ ("syntax:julia:comment" "brown" notify-julia-syntax)
+ ("syntax:julia:error" "dark red" notify-julia-syntax)
+ ("syntax:julia:constant" "#4040c0" notify-julia-syntax)
+ ("syntax:julia:constant_type" "#4040c0" notify-julia-syntax)
+ ("syntax:julia:constant_number" "#4040c0" notify-julia-syntax)
+ ("syntax:julia:constant_string" "dark grey" notify-julia-syntax)
+ ("syntax:julia:constant_char" "#333333" notify-julia-syntax)
+ ("syntax:julia:declare_function" "#0000c0" notify-julia-syntax)
+ ("syntax:julia:declare_module" "#0000c0" notify-julia-syntax)
+ ("syntax:julia:declare_type" "#0000c0" notify-julia-syntax)
+ ("syntax:julia:operator" "#8b008b" notify-julia-syntax)
+ ("syntax:julia:operator_openclose" "#B02020" notify-julia-syntax)
+ ("syntax:julia:operator_field" "#888888" notify-julia-syntax)
+ ("syntax:julia:operator_special" "orange" notify-julia-syntax)
+ ("syntax:julia:keyword" "#309090" notify-julia-syntax)
+ ("syntax:julia:keyword_conditional" "#309090" notify-julia-syntax)
+ ("syntax:julia:keyword_control" "#309090" notify-julia-syntax)
+) ;define-preferences
diff --git a/TeXmacs/plugins/kde/progs/init-kde.scm b/TeXmacs/plugins/kde/progs/init-kde.scm
new file mode 100644
index 0000000000..141d151612
--- /dev/null
+++ b/TeXmacs/plugins/kde/progs/init-kde.scm
@@ -0,0 +1,63 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : init-kde.scm
+;; DESCRIPTION : Initialize the 'kde' plugin (KDE look and feel keymap)
+;; COPYRIGHT   : (C) 1999  Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(when (like-kde?)
+  (kbd-map (:profile kde)
+
+    ;; standard KDE shortcuts
+    ("kde d" (remove-text #t))
+    ("kde k" (kill-paragraph))
+    ("kde r" (interactive-replace))
+    ("kde left" (traverse-left))
+    ("kde right" (traverse-right))
+    ("kde home" (go-start))
+    ("kde end" (go-end))
+    ("kde S-left" (kbd-select traverse-left))
+    ("kde S-right" (kbd-select traverse-right))
+    ("kde S-home" (kbd-select go-start))
+    ("kde S-end" (kbd-select go-end))
+
+    ("search F3" (search-next-match #t))
+    ("search S-F3" (search-next-match #f))
+
+    ;; not yet implemented
+    ;; ("kde N" (add-tab))
+    ;; ("kde delete" (delete-end-word))
+    ;; ("kde backspace" (delete-start-word))
+    ;; ("forward" (next-tab))
+    ;; ("back" (previous-tab))
+
+    ;; further shortcuts for KDE look and feel
+    ("kde g" (selection-cancel))
+    ("kde l" (refresh-window))
+    ("kde F" (interactive-search))
+
+    ("cmd q" (make 'symbol))
+    ("altcmd g" (kbd-cancel))
+    ("altcmd x" (interactive footer-eval))
+    ("A-x" (interactive exec-interactive-command))
+    ("altcmd $" (interactive-spell))
+
+    ("C-P" (toggle-preamble-mode))
+    ("C-O" (toggle-source-mode))
+
+    ("structured:cmd left" (kbd-select-if-active traverse-left))
+    ("structured:cmd right" (kbd-select-if-active traverse-right))
+  ) ;kbd-map
+
+  (kbd-map (:profile kde)
+    (:require (and (not (in-prog?)) (not (in-verbatim?))))
+    ("M-space" (make-space "0.2spc"))
+    ("M-S-space" (make-space "-0.2spc"))
+  ) ;kbd-map
+) ;when
diff --git a/TeXmacs/plugins/keyboard/progs/init-keyboard.scm b/TeXmacs/plugins/keyboard/progs/init-keyboard.scm
index 2fc0084e89..1a4e0dadb3 100644
--- a/TeXmacs/plugins/keyboard/progs/init-keyboard.scm
+++ b/TeXmacs/plugins/keyboard/progs/init-keyboard.scm
@@ -14,13 +14,9 @@
 
 (lazy-keyboard (utils automate auto-kbd) in-auto?)
 (lazy-keyboard (texmacs keyboard prefix-kbd) always?)
-(lazy-keyboard (generic generic-kbd) always?)
 (lazy-keyboard (generic search-kbd))
 (lazy-keyboard (text text-kbd) in-text?)
 (lazy-keyboard (keyboard text-kbd-utf8) in-text?)
-(lazy-keyboard (math math-kbd) in-math?)
-(lazy-keyboard (math math-sem-edit) in-sem-math?)
-(lazy-keyboard (prog prog-kbd) in-prog?)
 (lazy-keyboard (source source-kbd) always?)
 (lazy-keyboard (table table-kbd) in-table?)
 (lazy-keyboard (graphics graphics-kbd) in-active-graphics?)
@@ -35,6 +31,19 @@
 
 (lazy-keyboard-force #t)
 
+;; 默认关闭；开启时才加载 (keyboard emoji) 注册 emoji kbd-map
+
+(define (notify-emoji-keyboard var val)
+  (when (== val "on")
+    (when (not (defined? 'enable-emoji-keyboard))
+      (use-modules (keyboard emoji))
+    ) ;when
+    (enable-emoji-keyboard)
+  ) ;when
+) ;define
+
+(define-preferences ("emoji keyboard" "off" notify-emoji-keyboard))
+
 (delayed (:idle 0)
   (kbd-map (:require (or (full-screen?) (full-screen-edit?)))
    ("escape" (exit-fullscreen) "Exit full screen")
diff --git a/TeXmacs/plugins/keyboard/progs/keyboard/emoji.scm b/TeXmacs/plugins/keyboard/progs/keyboard/emoji.scm
new file mode 100644
index 0000000000..3c7288384c
--- /dev/null
+++ b/TeXmacs/plugins/keyboard/progs/keyboard/emoji.scm
@@ -0,0 +1,815 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : emoji.scm
+;; DESCRIPTION : emoji shortcuts (: smile : -> U+1F604 etc.)
+;; COPYRIGHT   : (C) 2024  Darcy Shen
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (keyboard emoji))
+
+(tm-define (enable-emoji-keyboard)
+  (debug-message "keyboard" "(keyboard emoji): registering emoji kbd-map ...\n")
+  (delayed-kbd-map (": + 1 :" "<#1F44D>")
+   (": - 1 :" "<#1F44E>")
+   (": 1 0 0 :" "<#1F4AF>")
+   (": 1 2 3 4 :" "<#1F522>")
+   (": 8 b a l l :" "<#1F3B1>")
+   (": a b c :" "<#1F524>")
+   (": a b c d :" "<#1F521>")
+   (": a e r i a l t r a m w a y :" "<#1F6A1>")
+   (": a i r p l a n e :" "<#2708>")
+   (": a l i e n :" "<#1F47D>")
+   (": a m b u l a n c e :" "<#1F691>")
+   (": a n c h o r :" "<#2693>")
+   (": a n g e l :" "<#1F47C>")
+   (": a n g e r :" "<#1F4A2>")
+   (": a n g r y :" "<#1F620>")
+   (": a n g u i s h e d :" "<#1F627>")
+   (": a n t :" "<#1F41C>")
+   (": a p p l e :" "<#1F34E>")
+   (": a q u a r i u s :" "<#2652>")
+   (": a r i e s :" "<#2648>")
+   (": a r r o w b a c k w a r d :" "<#25C0>")
+   (": a r r o w d o w n :" "<#2B07>")
+   (": a r r o w d o w n s m a l l :" "<#1F53D>")
+   (": a r r o w f o r w a r d :" "<#25B6>")
+   (": a r r o w h e a d i n g d o w n :" "<#2935>")
+   (": a r r o w h e a d i n g u p :" "<#2934>")
+   (": a r r o w l e f t :" "<#2B05>")
+   (": a r r o w l o w e r l e f t :" "<#2199>")
+   (": a r r o w l o w e r r i g h t :" "<#2198>")
+   (": a r r o w r i g h t :" "<#27A1>")
+   (": a r r o w r i g h t h o o k :" "<#21AA>")
+   (": a r r o w u p :" "<#2B06>")
+   (": a r r o w u p d o w n :" "<#2195>")
+   (": a r r o w u p s m a l l :" "<#1F53C>")
+   (": a r r o w u p p e r l e f t :" "<#2196>")
+   (": a r r o w u p p e r r i g h t :" "<#2197>")
+   (": a r r o w s c l o c k w i s e :" "<#1F503>")
+   (": a r r o w s c o u n t e r c l o c k w i s e :" "<#1F504>")
+   (": a r t :" "<#1F3A8>")
+   (": a r t i c u l a t e d l o r r y :" "<#1F69B>")
+   (": a s t o n i s h e d :" "<#1F632>")
+   (": a t m :" "<#1F3E7>")
+   (": b a b y :" "<#1F476>")
+   (": b a b y b o t t l e :" "<#1F37C>")
+   (": b a b y c h i c k :" "<#1F424>")
+   (": b a b y s y m b o l :" "<#1F6BC>")
+   (": b a g g a g e c l a i m :" "<#1F6C4>")
+   (": b a l l o o n :" "<#1F388>")
+   (": b a l l o t b o x w i t h c h e c k :" "<#2611>")
+   (": b a m b o o :" "<#1F38D>")
+   (": b a n a n a :" "<#1F34C>")
+   (": b a n g b a n g :" "<#203C>")
+   (": b a n k :" "<#1F3E6>")
+   (": b a r c h a r t :" "<#1F4CA>")
+   (": b a r b e r :" "<#1F488>")
+   (": b a s e b a l l :" "<#26BE>")
+   (": b a s k e t b a l l :" "<#1F3C0>")
+   (": b a t h :" "<#1F6C0>")
+   (": b a t h t u b :" "<#1F6C1>")
+   (": b a t t e r y :" "<#1F50B>")
+   (": b e a r :" "<#1F43B>")
+   (": b e e r :" "<#1F37A>")
+   (": b e e r s :" "<#1F37B>")
+   (": b e e t l e :" "<#1FAB2>")
+   (": b e g i n n e r :" "<#1F530>")
+   (": b e l l :" "<#1F514>")
+   (": b e n t o :" "<#1F371>")
+   (": b i c y c l i s t :" "<#1F6B4>")
+   (": b i k e :" "<#1F6B2>")
+   (": b i k i n i :" "<#1F459>")
+   (": b i r d :" "<#1F426>")
+   (": b i r t h d a y :" "<#1F382>")
+   (": b l a c k c i r c l e :" "<#26AB>")
+   (": b l a c k n i b :" "<#2712>")
+   (": b l a c k s q u a r e b u t t o n :" "<#1F532>")
+   (": b l o s s o m :" "<#1F33C>")
+   (": b l o w f i s h :" "<#1F421>")
+   (": b l u e b o o k :" "<#1F4D8>")
+   (": b l u e c a r :" "<#1F699>")
+   (": b l u e h e a r t :" "<#1F499>")
+   (": b l u s h :" "<#1F60A>")
+   (": b o a r :" "<#1F417>")
+   (": b o a t :" "<#26F5>")
+   (": b o m b :" "<#1F4A3>")
+   (": b o o k :" "<#1F4D6>")
+   (": b o o k m a r k :" "<#1F516>")
+   (": b o o k m a r k t a b s :" "<#1F4D1>")
+   (": b o o k s :" "<#1F4DA>")
+   (": b o o m :" "<#1F4A5>")
+   (": b o o t :" "<#1F462>")
+   (": b o u q u e t :" "<#1F490>")
+   (": b o w :" "<#1F647>")
+   (": b o w l i n g :" "<#1F3B3>")
+   (": b o y :" "<#1F466>")
+   (": b r e a d :" "<#1F35E>")
+   (": b r i d e w i t h v e i l :" "<#1F470>")
+   (": b r i d g e a t n i g h t :" "<#1F309>")
+   (": b r i e f c a s e :" "<#1F4BC>")
+   (": b r o k e n h e a r t :" "<#1F494>")
+   (": b u g :" "<#1F41B>")
+   (": b u l b :" "<#1F4A1>")
+   (": b u l l e t t r a i n f r o n t :" "<#1F685>")
+   (": b u l l e t t r a i n s i d e :" "<#1F684>")
+   (": b u s :" "<#1F68C>")
+   (": b u s s t o p :" "<#1F68F>")
+   (": b u s t i n s i l h o u e t t e :" "<#1F464>")
+   (": b u s t s i n s i l h o u e t t e :" "<#1F465>")
+   (": c a c t u s :" "<#1F335>")
+   (": c a k e :" "<#1F370>")
+   (": c a l e n d a r :" "<#1F4C6>")
+   (": c a l l i n g :" "<#1F4F2>")
+   (": c a m e l :" "<#1F42B>")
+   (": c a m e r a :" "<#1F4F7>")
+   (": c a n c e r :" "<#264B>")
+   (": c a n d y :" "<#1F36C>")
+   (": c a p i t a l a b c d :" "<#1F520>")
+   (": c a p r i c o r n :" "<#2651>")
+   (": c a r :" "<#1F697>")
+   (": c a r d i n d e x :" "<#1F4C7>")
+   (": c a r o u s e l h o r s e :" "<#1F3A0>")
+   (": c a t :" "<#1F431>")
+   (": c a t 2 :" "<#1F408>")
+   (": c d :" "<#1F4BF>")
+   (": c h a r t :" "<#1F4B9>")
+   (": c h a r t w i t h d o w n w a r d s t r e n d :" "<#1F4C9>")
+   (": c h a r t w i t h u p w a r d s t r e n d :" "<#1F4C8>")
+   (": c h e c k e r e d f l a g :" "<#1F3C1>")
+   (": c h e r r i e s :" "<#1F352>")
+   (": c h e r r y b l o s s o m :" "<#1F338>")
+   (": c h e s t n u t :" "<#1F330>")
+   (": c h i c k e n :" "<#1F414>")
+   (": c h i l d r e n c r o s s i n g :" "<#1F6B8>")
+   (": c h o c o l a t e b a r :" "<#1F36B>")
+   (": c h r i s t m a s t r e e :" "<#1F384>")
+   (": c h u r c h :" "<#26EA>")
+   (": c i n e m a :" "<#1F3A6>")
+   (": c i r c u s t e n t :" "<#1F3AA>")
+   (": c i t y s u n r i s e :" "<#1F307>")
+   (": c i t y s u n s e t :" "<#1F306>")
+   (": c l a p :" "<#1F44F>")
+   (": c l a p p e r :" "<#1F3AC>")
+   (": c l i p b o a r d :" "<#1F4CB>")
+   (": c l o c k 1 :" "<#1F550>")
+   (": c l o c k 1 0 :" "<#1F559>")
+   (": c l o c k 1 0 3 0 :" "<#1F565>")
+   (": c l o c k 1 1 :" "<#1F55A>")
+   (": c l o c k 1 1 3 0 :" "<#1F566>")
+   (": c l o c k 1 2 :" "<#1F55B>")
+   (": c l o c k 1 2 3 0 :" "<#1F567>")
+   (": c l o c k 1 3 0 :" "<#1F55C>")
+   (": c l o c k 2 :" "<#1F551>")
+   (": c l o c k 2 3 0 :" "<#1F55D>")
+   (": c l o c k 3 :" "<#1F552>")
+   (": c l o c k 3 3 0 :" "<#1F55E>")
+   (": c l o c k 4 :" "<#1F553>")
+   (": c l o c k 4 3 0 :" "<#1F55F>")
+   (": c l o c k 5 :" "<#1F554>")
+   (": c l o c k 5 3 0 :" "<#1F560>")
+   (": c l o c k 6 :" "<#1F555>")
+   (": c l o c k 6 3 0 :" "<#1F561>")
+   (": c l o c k 7 :" "<#1F556>")
+   (": c l o c k 7 3 0 :" "<#1F562>")
+   (": c l o c k 8 :" "<#1F557>")
+   (": c l o c k 8 3 0 :" "<#1F563>")
+   (": c l o c k 9 :" "<#1F558>")
+   (": c l o c k 9 3 0 :" "<#1F564>")
+   (": c l o s e d b o o k :" "<#1F4D5>")
+   (": c l o s e d l o c k w i t h k e y :" "<#1F510>")
+   (": c l o s e d u m b r e l l a :" "<#1F302>")
+   (": c l o u d :" "<#2601>")
+   (": c l u b s :" "<#2663>")
+   (": c n :" "<#1F1E8>")
+   (": c o c k t a i l :" "<#1F378>")
+   (": c o f f e e :" "<#2615>")
+   (": c o l d s w e a t :" "<#1F630>")
+   (": c o l l i s i o n :" "<#1F4A5>")
+   (": c o m p u t e r :" "<#1F4BB>")
+   (": c o n f e t t i b a l l :" "<#1F38A>")
+   (": c o n f o u n d e d :" "<#1F616>")
+   (": c o n f u s e d :" "<#1F615>")
+   (": c o n s t r u c t i o n :" "<#1F6A7>")
+   (": c o n s t r u c t i o n w o r k e r :" "<#1F477>")
+   (": c o n v e n i e n c e s t o r e :" "<#1F3EA>")
+   (": c o o k i e :" "<#1F36A>")
+   (": c o p :" "<#1F46E>")
+   (": c o p y r i g h t :" "<#00A9>")
+   (": c o r n :" "<#1F33D>")
+   (": c o u p l e :" "<#1F46B>")
+   (": c o u p l e w i t h h e a r t :" "<#1F491>")
+   (": c o u p l e k i s s :" "<#1F48F>")
+   (": c o w :" "<#1F42E>")
+   (": c o w 2 :" "<#1F404>")
+   (": c r e d i t c a r d :" "<#1F4B3>")
+   (": c r o c o d i l e :" "<#1F40A>")
+   (": c r o s s e d f l a g s :" "<#1F38C>")
+   (": c r o w n :" "<#1F451>")
+   (": c r y :" "<#1F622>")
+   (": c r y i n g c a t f a c e :" "<#1F63F>")
+   (": c r y s t a l b a l l :" "<#1F52E>")
+   (": c u p i d :" "<#1F498>")
+   (": c u r l y l o o p :" "<#27B0>")
+   (": c u r r e n c y e x c h a n g e :" "<#1F4B1>")
+   (": c u r r y :" "<#1F35B>")
+   (": c u s t a r d :" "<#1F36E>")
+   (": c u s t o m s :" "<#1F6C3>")
+   (": c y c l o n e :" "<#1F300>")
+   (": d a n c e r :" "<#1F483>")
+   (": d a n c e r s :" "<#1F46F>")
+   (": d a n g o :" "<#1F361>")
+   (": d a r t :" "<#1F3AF>")
+   (": d a s h :" "<#1F4A8>")
+   (": d a t e :" "<#1F4C5>")
+   (": d e :" "<#1F1E9>")
+   (": d e c i d u o u s t r e e :" "<#1F333>")
+   (": d e p a r t m e n t s t o r e :" "<#1F3EC>")
+   (": d i a m o n d s h a p e w i t h a d o t i n s i d e :" "<#1F4A0>")
+   (": d i a m o n d s :" "<#2666>")
+   (": d i s a p p o i n t e d :" "<#1F61E>")
+   (": d i s a p p o i n t e d r e l i e v e d :" "<#1F625>")
+   (": d i z z y :" "<#1F4AB>")
+   (": d i z z y f a c e :" "<#1F635>")
+   (": d o n o t l i t t e r :" "<#1F6AF>")
+   (": d o g :" "<#1F436>")
+   (": d o g 2 :" "<#1F415>")
+   (": d o l l a r :" "<#1F4B5>")
+   (": d o l l s :" "<#1F38E>")
+   (": d o l p h i n :" "<#1F42C>")
+   (": d o o r :" "<#1F6AA>")
+   (": d o u g h n u t :" "<#1F369>")
+   (": d r a g o n :" "<#1F409>")
+   (": d r a g o n f a c e :" "<#1F432>")
+   (": d r e s s :" "<#1F457>")
+   (": d r o m e d a r y c a m e l :" "<#1F42A>")
+   (": d r o p l e t :" "<#1F4A7>")
+   (": d v d :" "<#1F4C0>")
+   (": e m a i l :" "<#1F4E7>")
+   (": e a r :" "<#1F442>")
+   (": e a r o f r i c e :" "<#1F33E>")
+   (": e a r t h a f r i c a :" "<#1F30D>")
+   (": e a r t h a m e r i c a s :" "<#1F30E>")
+   (": e a r t h a s i a :" "<#1F30F>")
+   (": e g g :" "<#1F95A>")
+   (": e g g p l a n t :" "<#1F346>")
+   (": e i g h t p o i n t e d b l a c k s t a r :" "<#2734>")
+   (": e i g h t s p o k e d a s t e r i s k :" "<#2733>")
+   (": e l e c t r i c p l u g :" "<#1F50C>")
+   (": e l e p h a n t :" "<#1F418>")
+   (": e m a i l :" "<#1F4E7>")
+   (": e n d :" "<#1F51A>")
+   (": e n v e l o p e :" "<#2709>")
+   (": e s :" "<#1F1EA>")
+   (": e u r o :" "<#1F4B6>")
+   (": e u r o p e a n c a s t l e :" "<#1F3F0>")
+   (": e u r o p e a n p o s t o f f i c e :" "<#1F3E4>")
+   (": e v e r g r e e n t r e e :" "<#1F332>")
+   (": e x c l a m a t i o n :" "<#2757>")
+   (": e x p r e s s i o n l e s s :" "<#1F611>")
+   (": e y e g l a s s e s :" "<#1F453>")
+   (": e y e s :" "<#1F440>")
+   (": f a c e p u n c h :" "<#1F44A>")
+   (": f a c t o r y :" "<#1F3ED>")
+   (": f a l l e n l e a f :" "<#1F342>")
+   (": f a m i l y :" "<#1F46A>")
+   (": f a x :" "<#1F4E0>")
+   (": f e a r f u l :" "<#1F628>")
+   (": f e e t :" "<#1F43E>")
+   (": f e r r i s w h e e l :" "<#1F3A1>")
+   (": f i l e f o l d e r :" "<#1F4C1>")
+   (": f i r e :" "<#1F525>")
+   (": f i r e e n g i n e :" "<#1F692>")
+   (": f i r e w o r k s :" "<#1F386>")
+   (": f i r s t q u a r t e r m o o n :" "<#1F313>")
+   (": f i r s t q u a r t e r m o o n w i t h f a c e :" "<#1F31B>")
+   (": f i s h :" "<#1F41F>")
+   (": f i s h c a k e :" "<#1F365>")
+   (": f i s h i n g p o l e a n d f i s h :" "<#1F3A3>")
+   (": f i s t :" "<#270A>")
+   (": f l a g s :" "<#1F38F>")
+   (": f l a s h l i g h t :" "<#1F526>")
+   (": f l o p p y d i s k :" "<#1F4BE>")
+   (": f l o w e r p l a y i n g c a r d s :" "<#1F3B4>")
+   (": f l u s h e d :" "<#1F633>")
+   (": f o g g y :" "<#1F301>")
+   (": f o o t b a l l :" "<#1F3C8>")
+   (": f o r k a n d k n i f e :" "<#1F374>")
+   (": f o u n t a i n :" "<#26F2>")
+   (": f o u r l e a f c l o v e r :" "<#1F340>")
+   (": f r :" "<#1F1EB>")
+   (": f r i e d s h r i m p :" "<#1F364>")
+   (": f r i e s :" "<#1F35F>")
+   (": f r o g :" "<#1F438>")
+   (": f r o w n i n g :" "<#1F626>")
+   (": f u :" "<#1F595>")
+   (": f u e l p u m p :" "<#26FD>")
+   (": f u l l m o o n :" "<#1F315>")
+   (": f u l l m o o n w i t h f a c e :" "<#1F31D>")
+   (": g a m e d i e :" "<#1F3B2>")
+   (": g b :" "<#1F1EC>")
+   (": g e m :" "<#1F48E>")
+   (": g e m i n i :" "<#264A>")
+   (": g h o s t :" "<#1F47B>")
+   (": g i f t :" "<#1F381>")
+   (": g i f t h e a r t :" "<#1F49D>")
+   (": g i r l :" "<#1F467>")
+   (": g l o b e w i t h m e r i d i a n s :" "<#1F310>")
+   (": g o a t :" "<#1F410>")
+   (": g o l f :" "<#26F3>")
+   (": g r a p e s :" "<#1F347>")
+   (": g r e e n a p p l e :" "<#1F34F>")
+   (": g r e e n b o o k :" "<#1F4D7>")
+   (": g r e e n h e a r t :" "<#1F49A>")
+   (": g r e y e x c l a m a t i o n :" "<#2755>")
+   (": g r e y q u e s t i o n :" "<#2754>")
+   (": g r i m a c i n g :" "<#1F62C>")
+   (": g r i n :" "<#1F601>")
+   (": g r i n n i n g :" "<#1F600>")
+   (": g u a r d s m a n :" "<#1F482>")
+   (": g u i t a r :" "<#1F3B8>")
+   (": g u n :" "<#1F52B>")
+   (": h a i r c u t :" "<#1F487>")
+   (": h a m b u r g e r :" "<#1F354>")
+   (": h a m m e r :" "<#1F528>")
+   (": h a m s t e r :" "<#1F439>")
+   (": h a n d :" "<#270B>")
+   (": h a n d b a g :" "<#1F45C>")
+   (": h a n k e y :" "<#1F4A9>")
+   (": h a s h :" "<#0023>")
+   (": h a t c h e d c h i c k :" "<#1F425>")
+   (": h a t c h i n g c h i c k :" "<#1F423>")
+   (": h e a d p h o n e s :" "<#1F3A7>")
+   (": h e a r n o e v i l :" "<#1F649>")
+   (": h e a r t :" "<#2764>")
+   (": h e a r t d e c o r a t i o n :" "<#1F49F>")
+   (": h e a r t e y e s :" "<#1F60D>")
+   (": h e a r t e y e s c a t :" "<#1F63B>")
+   (": h e a r t b e a t :" "<#1F493>")
+   (": h e a r t p u l s e :" "<#1F497>")
+   (": h e a r t s :" "<#2665>")
+   (": h e a v y c h e c k m a r k :" "<#2714>")
+   (": h e a v y d i v i s i o n s i g n :" "<#2797>")
+   (": h e a v y d o l l a r s i g n :" "<#1F4B2>")
+   (": h e a v y e x c l a m a t i o n m a r k :" "<#2757>")
+   (": h e a v y m i n u s s i g n :" "<#2796>")
+   (": h e a v y m u l t i p l i c a t i o n x :" "<#2716>")
+   (": h e a v y p l u s s i g n :" "<#2795>")
+   (": h e l i c o p t e r :" "<#1F681>")
+   (": h e r b :" "<#1F33F>")
+   (": h i b i s c u s :" "<#1F33A>")
+   (": h i g h b r i g h t n e s s :" "<#1F506>")
+   (": h i g h h e e l :" "<#1F460>")
+   (": h o c h o :" "<#1F52A>")
+   (": h o n e y p o t :" "<#1F36F>")
+   (": h o n e y b e e :" "<#1F41D>")
+   (": h o r s e :" "<#1F434>")
+   (": h o r s e r a c i n g :" "<#1F3C7>")
+   (": h o s p i t a l :" "<#1F3E5>")
+   (": h o t e l :" "<#1F3E8>")
+   (": h o t s p r i n g s :" "<#2668>")
+   (": h o u r g l a s s :" "<#231B>")
+   (": h o u s e :" "<#1F3E0>")
+   (": h o u s e w i t h g a r d e n :" "<#1F3E1>")
+   (": h u s h e d :" "<#1F62F>")
+   (": i c e c r e a m :" "<#1F368>")
+   (": i c e c r e a m :" "<#1F366>")
+   (": i m p :" "<#1F47F>")
+   (": i n b o x t r a y :" "<#1F4E5>")
+   (": i n c o m i n g e n v e l o p e :" "<#1F4E8>")
+   (": i n f o r m a t i o n d e s k p e r s o n :" "<#1F481>")
+   (": i n f o r m a t i o n s o u r c e :" "<#2139>")
+   (": i n n o c e n t :" "<#1F607>")
+   (": i n t e r r o b a n g :" "<#2049>")
+   (": i p h o n e :" "<#1F4F1>")
+   (": i t :" "<#1F1EE>")
+   (": i z a k a y a l a n t e r n :" "<#1F3EE>")
+   (": j a c k o l a n t e r n :" "<#1F383>")
+   (": j a p a n :" "<#1F5FE>")
+   (": j a p a n e s e c a s t l e :" "<#1F3EF>")
+   (": j a p a n e s e g o b l i n :" "<#1F47A>")
+   (": j a p a n e s e o g r e :" "<#1F479>")
+   (": j e a n s :" "<#1F456>")
+   (": j o y :" "<#1F602>")
+   (": j o y c a t :" "<#1F639>")
+   (": j p :" "<#1F1EF>")
+   (": k e y :" "<#1F511>")
+   (": k e y c a p t e n :" "<#1F51F>")
+   (": k i m o n o :" "<#1F458>")
+   (": k i s s :" "<#1F48B>")
+   (": k i s s i n g :" "<#1F617>")
+   (": k i s s i n g c a t :" "<#1F63D>")
+   (": k i s s i n g c l o s e d e y e s :" "<#1F61A>")
+   (": k i s s i n g h e a r t :" "<#1F618>")
+   (": k i s s i n g s m i l i n g e y e s :" "<#1F619>")
+   (": k o a l a :" "<#1F428>")
+   (": k r :" "<#1F1F0>")
+   (": l a r g e b l u e c i r c l e :" "<#1F535>")
+   (": l a r g e b l u e d i a m o n d :" "<#1F537>")
+   (": l a r g e o r a n g e d i a m o n d :" "<#1F536>")
+   (": l a s t q u a r t e r m o o n :" "<#1F317>")
+   (": l a s t q u a r t e r m o o n w i t h f a c e :" "<#1F31C>")
+   (": l a u g h i n g :" "<#1F606>")
+   (": l e a v e s :" "<#1F343>")
+   (": l e d g e r :" "<#1F4D2>")
+   (": l e f t l u g g a g e :" "<#1F6C5>")
+   (": l e f t r i g h t a r r o w :" "<#2194>")
+   (": l e f t w a r d s a r r o w w i t h h o o k :" "<#21A9>")
+   (": l e m o n :" "<#1F34B>")
+   (": l e o :" "<#264C>")
+   (": l e o p a r d :" "<#1F406>")
+   (": l i b r a :" "<#264E>")
+   (": l i g h t r a i l :" "<#1F688>")
+   (": l i n k :" "<#1F517>")
+   (": l i p s :" "<#1F444>")
+   (": l i p s t i c k :" "<#1F484>")
+   (": l o c k :" "<#1F512>")
+   (": l o c k w i t h i n k p e n :" "<#1F50F>")
+   (": l o l l i p o p :" "<#1F36D>")
+   (": l o o p :" "<#27BF>")
+   (": l o u d s p e a k e r :" "<#1F4E2>")
+   (": l o v e h o t e l :" "<#1F3E9>")
+   (": l o v e l e t t e r :" "<#1F48C>")
+   (": l o w b r i g h t n e s s :" "<#1F505>")
+   (": m :" "<#24C2>")
+   (": m a g :" "<#1F50D>")
+   (": m a g r i g h t :" "<#1F50E>")
+   (": m a i l b o x :" "<#1F4EB>")
+   (": m a i l b o x c l o s e d :" "<#1F4EA>")
+   (": m a i l b o x w i t h m a i l :" "<#1F4EC>")
+   (": m a i l b o x w i t h n o m a i l :" "<#1F4ED>")
+   (": m a n :" "<#1F468>")
+   (": m a n w i t h g u a p i m a o :" "<#1F472>")
+   (": m a n w i t h t u r b a n :" "<#1F473>")
+   (": m a n s s h o e :" "<#1F45E>")
+   (": m a p l e l e a f :" "<#1F341>")
+   (": m a s k :" "<#1F637>")
+   (": m a s s a g e :" "<#1F486>")
+   (": m e a t o n b o n e :" "<#1F356>")
+   (": m e g a :" "<#1F4E3>")
+   (": m e l o n :" "<#1F348>")
+   (": m e m o :" "<#1F4DD>")
+   (": m e n s :" "<#1F6B9>")
+   (": m e t a l :" "<#1F918>")
+   (": m e t r o :" "<#1F687>")
+   (": m i c r o p h o n e :" "<#1F3A4>")
+   (": m i c r o s c o p e :" "<#1F52C>")
+   (": m i l k y w a y :" "<#1F30C>")
+   (": m i n i b u s :" "<#1F690>")
+   (": m i n i d i s c :" "<#1F4BD>")
+   (": m o b i l e p h o n e o f f :" "<#1F4F4>")
+   (": m o n e y w i t h w i n g s :" "<#1F4B8>")
+   (": m o n e y b a g :" "<#1F4B0>")
+   (": m o n k e y :" "<#1F412>")
+   (": m o n k e y f a c e :" "<#1F435>")
+   (": m o n o r a i l :" "<#1F69D>")
+   (": m o o n :" "<#1F314>")
+   (": m o r t a r b o a r d :" "<#1F393>")
+   (": m o u n t f u j i :" "<#1F5FB>")
+   (": m o u n t a i n b i c y c l i s t :" "<#1F6B5>")
+   (": m o u n t a i n c a b l e w a y :" "<#1F6A0>")
+   (": m o u n t a i n r a i l w a y :" "<#1F69E>")
+   (": m o u s e :" "<#1F42D>")
+   (": m o u s e 2 :" "<#1F401>")
+   (": m o v i e c a m e r a :" "<#1F3A5>")
+   (": m o y a i :" "<#1F5FF>")
+   (": m u s c l e :" "<#1F4AA>")
+   (": m u s h r o o m :" "<#1F344>")
+   (": m u s i c a l k e y b o a r d :" "<#1F3B9>")
+   (": m u s i c a l n o t e :" "<#1F3B5>")
+   (": m u s i c a l s c o r e :" "<#1F3BC>")
+   (": m u t e :" "<#1F507>")
+   (": n a i l c a r e :" "<#1F485>")
+   (": n a m e b a d g e :" "<#1F4DB>")
+   (": n e c k t i e :" "<#1F454>")
+   (": n e g a t i v e s q u a r e d c r o s s m a r k :" "<#274E>")
+   (": n e u t r a l f a c e :" "<#1F610>")
+   (": n e w m o o n :" "<#1F311>")
+   (": n e w m o o n w i t h f a c e :" "<#1F31A>")
+   (": n e w s p a p e r :" "<#1F4F0>")
+   (": n o b e l l :" "<#1F515>")
+   (": n o b i c y c l e s :" "<#1F6B3>")
+   (": n o e n t r y :" "<#26D4>")
+   (": n o e n t r y s i g n :" "<#1F6AB>")
+   (": n o g o o d :" "<#1F645>")
+   (": n o m o b i l e p h o n e s :" "<#1F4F5>")
+   (": n o m o u t h :" "<#1F636>")
+   (": n o p e d e s t r i a n s :" "<#1F6B7>")
+   (": n o s m o k i n g :" "<#1F6AD>")
+   (": n o n p o t a b l e w a t e r :" "<#1F6B1>")
+   (": n o s e :" "<#1F443>")
+   (": n o t e b o o k :" "<#1F4D3>")
+   (": n o t e b o o k w i t h d e c o r a t i v e c o v e r :" "<#1F4D4>")
+   (": n o t e s :" "<#1F3B6>")
+   (": n u t a n d b o l t :" "<#1F529>")
+   (": o c e a n :" "<#1F30A>")
+   (": o c t o p u s :" "<#1F419>")
+   (": o d e n :" "<#1F362>")
+   (": o f f i c e :" "<#1F3E2>")
+   (": o k h a n d :" "<#1F44C>")
+   (": o k w o m a n :" "<#1F646>")
+   (": o l d e r m a n :" "<#1F474>")
+   (": o l d e r w o m a n :" "<#1F475>")
+   (": o n :" "<#1F51B>")
+   (": o n c o m i n g a u t o m o b i l e :" "<#1F698>")
+   (": o n c o m i n g b u s :" "<#1F68D>")
+   (": o n c o m i n g p o l i c e c a r :" "<#1F694>")
+   (": o n c o m i n g t a x i :" "<#1F696>")
+   (": o p e n f i l e f o l d e r :" "<#1F4C2>")
+   (": o p e n h a n d s :" "<#1F450>")
+   (": o p e n m o u t h :" "<#1F62E>")
+   (": o p h i u c h u s :" "<#26CE>")
+   (": o r a n g e b o o k :" "<#1F4D9>")
+   (": o u t b o x t r a y :" "<#1F4E4>")
+   (": o x :" "<#1F402>")
+   (": p a g e f a c i n g u p :" "<#1F4C4>")
+   (": p a g e w i t h c u r l :" "<#1F4C3>")
+   (": p a g e r :" "<#1F4DF>")
+   (": p a l m t r e e :" "<#1F334>")
+   (": p a n d a f a c e :" "<#1F43C>")
+   (": p a p e r c l i p :" "<#1F4CE>")
+   (": p a r t a l t e r n a t i o n m a r k :" "<#303D>")
+   (": p a r t l y s u n n y :" "<#26C5>")
+   (": p a s s p o r t c o n t r o l :" "<#1F6C2>")
+   (": p a w p r i n t s :" "<#1F43E>")
+   (": p e a c h :" "<#1F351>")
+   (": p e a r :" "<#1F350>")
+   (": p e n c i l :" "<#1F4DD>")
+   (": p e n c i l 2 :" "<#270F>")
+   (": p e n g u i n :" "<#1F427>")
+   (": p e n s i v e :" "<#1F614>")
+   (": p e r f o r m i n g a r t s :" "<#1F3AD>")
+   (": p e r s e v e r e :" "<#1F623>")
+   (": p h o n e :" "<#260E>")
+   (": p i g :" "<#1F437>")
+   (": p i g 2 :" "<#1F416>")
+   (": p i g n o s e :" "<#1F43D>")
+   (": p i l l :" "<#1F48A>")
+   (": p i n e a p p l e :" "<#1F34D>")
+   (": p i s c e s :" "<#2653>")
+   (": p i z z a :" "<#1F355>")
+   (": p o i n t d o w n :" "<#1F447>")
+   (": p o i n t l e f t :" "<#1F448>")
+   (": p o i n t r i g h t :" "<#1F449>")
+   (": p o i n t u p :" "<#261D>")
+   (": p o i n t u p 2 :" "<#1F446>")
+   (": p o l i c e c a r :" "<#1F693>")
+   (": p o o d l e :" "<#1F429>")
+   (": p o o p :" "<#1F4A9>")
+   (": p o s t o f f i c e :" "<#1F3E3>")
+   (": p o s t a l h o r n :" "<#1F4EF>")
+   (": p o s t b o x :" "<#1F4EE>")
+   (": p o t a b l e w a t e r :" "<#1F6B0>")
+   (": p o u c h :" "<#1F45D>")
+   (": p o u l t r y l e g :" "<#1F357>")
+   (": p o u n d :" "<#1F4B7>")
+   (": p o u t i n g c a t :" "<#1F63E>")
+   (": p r a y :" "<#1F64F>")
+   (": p r i n c e s s :" "<#1F478>")
+   (": p u n c h :" "<#1F44A>")
+   (": p u r p l e h e a r t :" "<#1F49C>")
+   (": p u r s e :" "<#1F45B>")
+   (": p u s h p i n :" "<#1F4CC>")
+   (": p u t l i t t e r i n i t s p l a c e :" "<#1F6AE>")
+   (": q u e s t i o n :" "<#2753>")
+   (": r a b b i t :" "<#1F430>")
+   (": r a b b i t 2 :" "<#1F407>")
+   (": r a c e h o r s e :" "<#1F40E>")
+   (": r a d i o :" "<#1F4FB>")
+   (": r a d i o b u t t o n :" "<#1F518>")
+   (": r a g e :" "<#1F621>")
+   (": r a i l w a y c a r :" "<#1F683>")
+   (": r a i n b o w :" "<#1F308>")
+   (": r a i s e d h a n d :" "<#270B>")
+   (": r a i s e d h a n d s :" "<#1F64C>")
+   (": r a i s i n g h a n d :" "<#1F64B>")
+   (": r a m :" "<#1F40F>")
+   (": r a m e n :" "<#1F35C>")
+   (": r a t :" "<#1F400>")
+   (": r e c y c l e :" "<#267B>")
+   (": r e d c a r :" "<#1F697>")
+   (": r e d c i r c l e :" "<#1F534>")
+   (": r e g i s t e r e d :" "<#00AE>")
+   (": r e l a x e d :" "<#263A>")
+   (": r e l i e v e d :" "<#1F60C>")
+   (": r e p e a t :" "<#1F501>")
+   (": r e p e a t o n e :" "<#1F502>")
+   (": r e s t r o o m :" "<#1F6BB>")
+   (": r e v o l v i n g h e a r t s :" "<#1F49E>")
+   (": r i b b o n :" "<#1F380>")
+   (": r i c e :" "<#1F35A>")
+   (": r i c e b a l l :" "<#1F359>")
+   (": r i c e c r a c k e r :" "<#1F358>")
+   (": r i c e s c e n e :" "<#1F391>")
+   (": r i n g :" "<#1F48D>")
+   (": r o c k e t :" "<#1F680>")
+   (": r o l l e r c o a s t e r :" "<#1F3A2>")
+   (": r o o s t e r :" "<#1F413>")
+   (": r o s e :" "<#1F339>")
+   (": r o t a t i n g l i g h t :" "<#1F6A8>")
+   (": r o u n d p u s h p i n :" "<#1F4CD>")
+   (": r o w b o a t :" "<#1F6A3>")
+   (": r u :" "<#1F1F7>")
+   (": r u g b y f o o t b a l l :" "<#1F3C9>")
+   (": r u n n e r :" "<#1F3C3>")
+   (": r u n n i n g :" "<#1F3C3>")
+   (": r u n n i n g s h i r t w i t h s a s h :" "<#1F3BD>")
+   (": s a g i t t a r i u s :" "<#2650>")
+   (": s a i l b o a t :" "<#26F5>")
+   (": s a k e :" "<#1F376>")
+   (": s a n d a l :" "<#1F461>")
+   (": s a n t a :" "<#1F385>")
+   (": s a t e l l i t e :" "<#1F4E1>")
+   (": s a t i s f i e d :" "<#1F606>")
+   (": s a x o p h o n e :" "<#1F3B7>")
+   (": s c h o o l :" "<#1F3EB>")
+   (": s c h o o l s a t c h e l :" "<#1F392>")
+   (": s c i s s o r s :" "<#2702>")
+   (": s c o r p i u s :" "<#264F>")
+   (": s c r e a m :" "<#1F631>")
+   (": s c r e a m c a t :" "<#1F640>")
+   (": s c r o l l :" "<#1F4DC>")
+   (": s e a t :" "<#1F4BA>")
+   (": s e e n o e v i l :" "<#1F648>")
+   (": s e e d l i n g :" "<#1F331>")
+   (": s h a v e d i c e :" "<#1F367>")
+   (": s h e e p :" "<#1F411>")
+   (": s h e l l :" "<#1F41A>")
+   (": s h i p :" "<#1F6A2>")
+   (": s h i r t :" "<#1F455>")
+   (": s h i t :" "<#1F4A9>")
+   (": s h o e :" "<#1F45E>")
+   (": s h o w e r :" "<#1F6BF>")
+   (": s i g n a l s t r e n g t h :" "<#1F4F6>")
+   (": s i x p o i n t e d s t a r :" "<#1F52F>")
+   (": s k i :" "<#1F3BF>")
+   (": s k u l l :" "<#1F480>")
+   (": s l e e p i n g :" "<#1F634>")
+   (": s l e e p y :" "<#1F62A>")
+   (": s l o t m a c h i n e :" "<#1F3B0>")
+   (": s m a l l b l u e d i a m o n d :" "<#1F539>")
+   (": s m a l l o r a n g e d i a m o n d :" "<#1F538>")
+   (": s m a l l r e d t r i a n g l e :" "<#1F53A>")
+   (": s m a l l r e d t r i a n g l e d o w n :" "<#1F53B>")
+   (": s m i l e :" "<#1F604>")
+   (": s m i l e c a t :" "<#1F638>")
+   (": s m i l e y :" "<#1F603>")
+   (": s m i l e y c a t :" "<#1F63A>")
+   (": s m i l i n g i m p :" "<#1F608>")
+   (": s m i r k :" "<#1F60F>")
+   (": s m i r k c a t :" "<#1F63C>")
+   (": s m o k i n g :" "<#1F6AC>")
+   (": s n a i l :" "<#1F40C>")
+   (": s n a k e :" "<#1F40D>")
+   (": s n o w b o a r d e r :" "<#1F3C2>")
+   (": s n o w f l a k e :" "<#2744>")
+   (": s n o w m a n :" "<#26C4>")
+   (": s o b :" "<#1F62D>")
+   (": s o c c e r :" "<#26BD>")
+   (": s o o n :" "<#1F51C>")
+   (": s o u n d :" "<#1F509>")
+   (": s p a c e i n v a d e r :" "<#1F47E>")
+   (": s p a d e s :" "<#2660>")
+   (": s p a g h e t t i :" "<#1F35D>")
+   (": s p a r k l e r :" "<#1F387>")
+   (": s p a r k l e s :" "<#2728>")
+   (": s p a r k l i n g h e a r t :" "<#1F496>")
+   (": s p e a k n o e v i l :" "<#1F64A>")
+   (": s p e a k e r :" "<#1F508>")
+   (": s p e e c h b a l l o o n :" "<#1F4AC>")
+   (": s p e e d b o a t :" "<#1F6A4>")
+   (": s t a r :" "<#2B50>")
+   (": s t a r 2 :" "<#1F31F>")
+   (": s t a r s :" "<#1F320>")
+   (": s t a t i o n :" "<#1F689>")
+   (": s t a t u e o f l i b e r t y :" "<#1F5FD>")
+   (": s t e a m l o c o m o t i v e :" "<#1F682>")
+   (": s t e w :" "<#1F372>")
+   (": s t r a i g h t r u l e r :" "<#1F4CF>")
+   (": s t r a w b e r r y :" "<#1F353>")
+   (": s t u c k o u t t o n g u e :" "<#1F61B>")
+   (": s t u c k o u t t o n g u e c l o s e d e y e s :" "<#1F61D>")
+   (": s t u c k o u t t o n g u e w i n k i n g e y e :" "<#1F61C>")
+   (": s u n w i t h f a c e :" "<#1F31E>")
+   (": s u n f l o w e r :" "<#1F33B>")
+   (": s u n g l a s s e s :" "<#1F60E>")
+   (": s u n n y :" "<#2600>")
+   (": s u n r i s e :" "<#1F305>")
+   (": s u n r i s e o v e r m o u n t a i n s :" "<#1F304>")
+   (": s u r f e r :" "<#1F3C4>")
+   (": s u s h i :" "<#1F363>")
+   (": s u s p e n s i o n r a i l w a y :" "<#1F69F>")
+   (": s w e a t :" "<#1F613>")
+   (": s w e a t d r o p s :" "<#1F4A6>")
+   (": s w e a t s m i l e :" "<#1F605>")
+   (": s w e e t p o t a t o :" "<#1F360>")
+   (": s w i m m e r :" "<#1F3CA>")
+   (": s y m b o l s :" "<#1F523>")
+   (": s y r i n g e :" "<#1F489>")
+   (": t a d a :" "<#1F389>")
+   (": t a n a b a t a t r e e :" "<#1F38B>")
+   (": t a n g e r i n e :" "<#1F34A>")
+   (": t a u r u s :" "<#2649>")
+   (": t a x i :" "<#1F695>")
+   (": t e a :" "<#1F375>")
+   (": t e l e p h o n e :" "<#260E>")
+   (": t e l e p h o n e r e c e i v e r :" "<#1F4DE>")
+   (": t e l e s c o p e :" "<#1F52D>")
+   (": t e n n i s :" "<#1F3BE>")
+   (": t e n t :" "<#26FA>")
+   (": t h o u g h t b a l l o o n :" "<#1F4AD>")
+   (": t h u m b s d o w n :" "<#1F44E>")
+   (": t h u m b s u p :" "<#1F44D>")
+   (": t i c k e t :" "<#1F3AB>")
+   (": t i g e r :" "<#1F42F>")
+   (": t i g e r 2 :" "<#1F405>")
+   (": t i r e d f a c e :" "<#1F62B>")
+   (": t m :" "<#2122>")
+   (": t o i l e t :" "<#1F6BD>")
+   (": t o k y o t o w e r :" "<#1F5FC>")
+   (": t o m a t o :" "<#1F345>")
+   (": t o n g u e :" "<#1F445>")
+   (": t o p :" "<#1F51D>")
+   (": t o p h a t :" "<#1F3A9>")
+   (": t r a c t o r :" "<#1F69C>")
+   (": t r a f f i c l i g h t :" "<#1F6A5>")
+   (": t r a i n :" "<#1F68B>")
+   (": t r a i n 2 :" "<#1F686>")
+   (": t r a m :" "<#1F68A>")
+   (": t r i a n g u l a r f l a g o n p o s t :" "<#1F6A9>")
+   (": t r i a n g u l a r r u l e r :" "<#1F4D0>")
+   (": t r i d e n t :" "<#1F531>")
+   (": t r i u m p h :" "<#1F624>")
+   (": t r o l l e y b u s :" "<#1F68E>")
+   (": t r o p h y :" "<#1F3C6>")
+   (": t r o p i c a l d r i n k :" "<#1F379>")
+   (": t r o p i c a l f i s h :" "<#1F420>")
+   (": t r u c k :" "<#1F69A>")
+   (": t r u m p e t :" "<#1F3BA>")
+   (": t s h i r t :" "<#1F455>")
+   (": t u l i p :" "<#1F337>")
+   (": t u r t l e :" "<#1F422>")
+   (": t v :" "<#1F4FA>")
+   (": t w i s t e d r i g h t w a r d s a r r o w s :" "<#1F500>")
+   (": t w o h e a r t s :" "<#1F495>")
+   (": t w o m e n h o l d i n g h a n d s :" "<#1F46C>")
+   (": t w o w o m e n h o l d i n g h a n d s :" "<#1F46D>")
+   (": u k :" "<#1F1EC>")
+   (": u m b r e l l a :" "<#2614>")
+   (": u n a m u s e d :" "<#1F612>")
+   (": u n d e r a g e :" "<#1F51E>")
+   (": u n l o c k :" "<#1F513>")
+   (": u s :" "<#1F1FA>")
+   (": v :" "<#270C>")
+   (": v e r t i c a l t r a f f i c l i g h t :" "<#1F6A6>")
+   (": v h s :" "<#1F4FC>")
+   (": v i b r a t i o n m o d e :" "<#1F4F3>")
+   (": v i d e o c a m e r a :" "<#1F4F9>")
+   (": v i d e o g a m e :" "<#1F3AE>")
+   (": v i o l i n :" "<#1F3BB>")
+   (": v i r g o :" "<#264D>")
+   (": v o l c a n o :" "<#1F30B>")
+   (": w a l k i n g :" "<#1F6B6>")
+   (": w a n i n g c r e s c e n t m o o n :" "<#1F318>")
+   (": w a n i n g g i b b o u s m o o n :" "<#1F316>")
+   (": w a r n i n g :" "<#26A0>")
+   (": w a t c h :" "<#231A>")
+   (": w a t e r b u f f a l o :" "<#1F403>")
+   (": w a t e r m e l o n :" "<#1F349>")
+   (": w a v e :" "<#1F44B>")
+   (": w a v y d a s h :" "<#3030>")
+   (": w a x i n g c r e s c e n t m o o n :" "<#1F312>")
+   (": w a x i n g g i b b o u s m o o n :" "<#1F314>")
+   (": w c :" "<#1F6BE>")
+   (": w e a r y :" "<#1F629>")
+   (": w e d d i n g :" "<#1F492>")
+   (": w h a l e :" "<#1F433>")
+   (": w h a l e 2 :" "<#1F40B>")
+   (": w h e e l c h a i r :" "<#267F>")
+   (": w h i t e c h e c k m a r k :" "<#2705>")
+   (": w h i t e c i r c l e :" "<#26AA>")
+   (": w h i t e f l o w e r :" "<#1F4AE>")
+   (": w h i t e s q u a r e b u t t o n :" "<#1F533>")
+   (": w i n d c h i m e :" "<#1F390>")
+   (": w i n e g l a s s :" "<#1F377>")
+   (": w i n k :" "<#1F609>")
+   (": w o l f :" "<#1F43A>")
+   (": w o m a n :" "<#1F469>")
+   (": w o m a n s c l o t h e s :" "<#1F45A>")
+   (": w o m a n s h a t :" "<#1F452>")
+   (": w o m e n s :" "<#1F6BA>")
+   (": w o r r i e d :" "<#1F61F>")
+   (": w r e n c h :" "<#1F527>")
+   (": x :" "<#274C>")
+   (": y e l l o w h e a r t :" "<#1F49B>")
+   (": y e n :" "<#1F4B4>")
+   (": y u m :" "<#1F60B>")
+   (": z a p :" "<#26A1>")
+   (": z z z :" "<#1F4A4>")
+  ) ;delayed-kbd-map
+  (debug-message "keyboard" "(keyboard emoji): emoji kbd-map registered\n")
+) ;tm-define
diff --git a/TeXmacs/plugins/keyboard/progs/keyboard/text-kbd-utf8.scm b/TeXmacs/plugins/keyboard/progs/keyboard/text-kbd-utf8.scm
index 3949749ca9..d4cdf82444 100644
--- a/TeXmacs/plugins/keyboard/progs/keyboard/text-kbd-utf8.scm
+++ b/TeXmacs/plugins/keyboard/progs/keyboard/text-kbd-utf8.scm
@@ -15,10 +15,11 @@
   (:use (generic generic-kbd)
     (utils edit auto-close)
     (text text-edit)
-    (various comment-edit)
-    (various comment-widgets)
+    (comment comment-edit)
+    (comment comment-widgets)
   ) ;:use
 ) ;texmacs-module
+(debug-message "keyboard" "(keyboard text-kbd-utf8): registering kbd-map ...\n")
 
 (kbd-map (:mode in-text?)
  ("<" "")
@@ -122,3 +123,4 @@
  ("std ;" (make-folded-comment "comment"))
  ("std /" (make-unfolded-comment "comment"))
 ) ;kbd-map
+(debug-message "keyboard" "(keyboard text-kbd-utf8): kbd-map registered\n")
diff --git a/TeXmacs/plugins/lang/dic/en_US/uk_UA.scm b/TeXmacs/plugins/lang/dic/en_US/uk_UA.scm
index 71b907dd5d..9f53b0bd47 100644
--- a/TeXmacs/plugins/lang/dic/en_US/uk_UA.scm
+++ b/TeXmacs/plugins/lang/dic/en_US/uk_UA.scm
@@ -3000,7 +3000,7 @@
 ("solutions" "рішення")
 ("sound" "звук")
 ("source code" "джерельний код")
-("source directory:" каталог джерела:")
+("source directory:" "каталог джерела:")
 ("source macros tool" "інструмент джерел макросів")
 ("source tags" "джерельні теги")
 ("source" "джерело")
diff --git a/TeXmacs/plugins/lang/dic/en_US/zh_CN.scm b/TeXmacs/plugins/lang/dic/en_US/zh_CN.scm
index 7f12bb316d..9afc7247a6 100644
--- a/TeXmacs/plugins/lang/dic/en_US/zh_CN.scm
+++ b/TeXmacs/plugins/lang/dic/en_US/zh_CN.scm
@@ -17,16 +17,24 @@
 (" (length: " "（长度为")
 ("1.5 line spacing" "1.5 倍行距")
 ("Upgrade VIP" "升级会员")
-("Upgrade to unlock AI writing, MathOCR, and more advanced features." "开通会员，立即解锁 AI 写作、MathOCR 等高阶功能。")
-("Liii STEM can make mistakes. Check important info." "内容由 AI 生成，请仔细甄别")
-("Does the current AI chat support images?" "当前 AI 对话是否支持图片？")
+("Upgrade to unlock AI writing, MathOCR, and more advanced features."
+  "开通会员，立即解锁 AI 写作、MathOCR 等高阶功能。"
+) ;
+("Liii STEM can make mistakes. Check important info."
+  "内容由 AI 生成，请仔细甄别"
+) ;
+("Does the current AI chat support images?"
+  "当前 AI 对话是否支持图片？"
+) ;
 ("No, it does not." "不支持。")
 ("All" "全部")
 ("Advanced footer" "高级页脚")
 ("Advanced header" "高级页眉")
 ("Advanced page numbering" "高级页码")
 ("Allow multiple spaces" "允许多个空格")
-("A leading % on the first line starts a chat command." "首行的第一个字符是 %，表示这是对话指令。")
+("A leading % on the first line starts a chat command."
+  "首行的第一个字符是 %，表示这是对话指令。"
+) ;
 ("Angle brackets ⟨ ⟩" "尖括号 ⟨ ⟩")
 ("Applying to" "应用到")
 ("Archive" "归档")
@@ -67,20 +75,32 @@
 ("Empty brackets . ." "空括号 . .")
 ("Empty PDF data received" "收到的PDF数据为空")
 ("End::keyboard" "End")
-("Expand TeXmacs macros with no LaTeX equivalents" "展开没有 LaTeX 等价项的 TeXmacs 宏")
-("Experimental features (to be used with care)" "实验性功能（请谨慎使用）")
+("Expand TeXmacs macros with no LaTeX equivalents"
+  "展开没有 LaTeX 等价项的 TeXmacs 宏"
+) ;
+("Experimental features (to be used with care)"
+  "实验性功能（请谨慎使用）"
+) ;
 ("expired" "到期")
 ("Expired" "已过期")
+("Export" "导出")
+("Export as PDF" "导出为PDF")
+("Export as PDF..." "导出为PDF...")
 ("Export mathematical formulas as MathJax" "将数学公式导出为 MathJax")
 ("Export mathematical formulas as MathML" "将数学公式导出为MathML")
+("Export to" "导出到")
 ("Exporting" "导出中")
 ("Failed to download template: %1" "下载模板失败: %1")
 ("Failed to load image data" "无法加载图片数据")
 ("Failed to save" "无法保存")
 ("Floor brackets ⌊ ⌋" "下取整括号 ⌊ ⌋")
 ("GNU FDL" "GNU自由文档许可证")
-("GNU TeXmacs comes without any form of legal warranty" "GNU TeXmacs 无任何形式的法律保证")
-("GNU TeXmacs falls under the GNU general public license" "GNU TeXmacs 使用 GNU 通用公共许可授权")
+("GNU TeXmacs comes without any form of legal warranty"
+  "GNU TeXmacs 无任何形式的法律保证"
+) ;
+("GNU TeXmacs falls under the GNU general public license"
+  "GNU TeXmacs 使用 GNU 通用公共许可授权"
+) ;
 ("Glue multiple spaces" "粘合多个空格")
 ("Home::keyboard" "Home")
 ("Image download failed: %1" "图片下载失败: %1")
@@ -90,17 +110,25 @@
 ("Keep track of source code" "保持源代码追踪")
 ("Log in Now!" "现在登录！")
 ("Lab Report" "实验报告")
-("Merge lines into paragraphs unless separated by blank lines" "无空行分隔时自动合并多行为段落")
+("Merge lines into paragraphs unless separated by blank lines"
+  "无空行分隔时自动合并多行为段落"
+) ;
 ("Math Modeling" "数学建模")
 ("Multi-select" "多选")
 ("No matching command found!" "未找到匹配指令！")
 ("No multiple spaces" "不允许多个空格")
 ("NSFC Young Scientists Fund" "国自然基金青年基金申请模板")
-("NSFC Young Scientists Fund (Category C) Application" "国家自然科学基金青年科学基金项目（C类）申请书")
+("NSFC Young Scientists Fund (Category C) Application"
+  "国家自然科学基金青年科学基金项目（C类）申请书"
+) ;
 ("New conversation" "新会话")
 ("Only convert changes when re-importing" "仅在重新导入时转换更改")
-("Only convert changes with respect to imported version" "仅转换相较于已导入版本的更改")
-("Only convert changes with respect to tracked version" "仅转换相较于已追踪版本的更改")
+("Only convert changes with respect to imported version"
+  "仅转换相较于已导入版本的更改"
+) ;
+("Only convert changes with respect to tracked version"
+  "仅转换相较于已追踪版本的更改"
+) ;
 ("Only show paragraphs with hits" "仅显示包含匹配项的段落")
 ("Open PDF?" "PDF导出完成，是否要打开文件？")
 ("PageDown::keyboard" "PageDown")
@@ -118,8 +146,36 @@
 ("Prompt on scripts" "每次接受脚本时都询问")
 ("Reasoning" "推理中")
 ("Rename" "重命名")
-("Replace TeXmacs styles with no LaTeX equivalents" "替换没有 LaTeX 等价项的 TeXmacs 样式")
-("Restart TeXmacs in order to let changes take effect" "重启TeXmacs以使您的更改生效")
+("Replace TeXmacs styles with no LaTeX equivalents"
+  "替换没有 LaTeX 等价项的 TeXmacs 样式"
+) ;
+("Restart TeXmacs in order to let changes take effect"
+  "重启TeXmacs以使您的更改生效"
+) ;
+("Restart" "重启")
+("Channel switched; the next release on this channel will be offered"
+  "已切换更新通道，该通道发布新版本后将自动提供更新"
+) ;
+("Switch to the Beta update channel? Beta releases may be unstable."
+  "切换到测试版（Beta）更新通道？测试版本可能不稳定。"
+) ;
+("Switch back to the Stable update channel? The latest stable version may be older than the current one."
+  "切回稳定版（Stable）更新通道？稳定版最新版本可能低于当前版本。"
+) ;
+("The application will check for updates on the new channel and restart to apply. Continue?"
+  "应用将在新通道检查更新并重启以应用。是否继续？"
+) ;
+("The update is ready. Restart now to apply it?"
+  "更新已下载完成，是否立即重启以应用更新？"
+) ;
+("The update will be applied the next time you start the application"
+  "更新将在下次启动应用时自动应用"
+) ;
+("Downloading the update..." "正在下载更新，请稍候...")
+("Timed out waiting for the update check" "等待更新检查超时")
+("Timed out waiting for the previous update task"
+  "等待上一个更新任务超时"
+) ;
 ("Restore" "恢复")
 ("Return::keyboard" "Return")
 ("Save change to" "保存文档到")
@@ -129,7 +185,9 @@
 ("Scale of the graphical user interface" "图形界面显示比例")
 ("Scan disk for fonts" "扫描磁盘查找字体")
 ("Search conversations..." "搜索会话...")
-("See Help -> Plugins -> LLM for command documentation." "请查看 帮助 -> 插件 -> LLM 以获得所有指令的文档。")
+("See Help -> Plugins -> LLM for command documentation."
+  "请查看 帮助 -> 插件 -> LLM 以获得所有指令的文档。"
+) ;
 ("Select all" "全选")
 ("Shape::ornament:" "形状:")
 ("SimFang" "仿宋")
@@ -143,35 +201,58 @@
 ("Space::keyboard" "Space")
 ("Sprout User" "发芽用户")
 ("Start an AI interactive session" "AI功能")
-("Store tracking information in LaTeX files" "在 LaTeX 文件中保存追踪信息")
+("Store tracking information in LaTeX files"
+  "在 LaTeX 文件中保存追踪信息"
+) ;
 ("Style for seminar" "研讨会样式")
 ("Style parameters" "样式参数")
 ("System prompt updated. Length: " "系统提示词已设置，长度为")
-("Switching non-empty documents to Beamer style is not supported" "不支持非空文档切换到beamer样式")
+("Switching non-empty documents to Beamer style is not supported"
+  "不支持非空文档切换到beamer样式"
+) ;
 ("Tab::keyboard" "Tab")
 ("Tag Image File Format" "标记图像文件格式")
 ("Taiwan" "中国台湾")
 ("TeXmacs macro" "TeXmacs宏")
 ("TeXmacs online docs" "TeXmacs在线文档")
-("The target file is not writable. Save as a different file?" "目标文件不可写，是否另存为？")
-("The specified file does not exist. File path: " "您指定的文件不存在。文件路径为：")
-("The current document or its directory has read-only attributes." "当前文档或文档所在目录为只读属性，")
+("The target file is not writable. Save as a different file?"
+  "目标文件不可写，是否另存为？"
+) ;
+("The specified file does not exist. File path: "
+  "您指定的文件不存在。文件路径为："
+) ;
+("The current document or its directory has read-only attributes."
+  "当前文档或文档所在目录为只读属性，"
+) ;
 ("Thinking" "思考中")
 ("University Thesis" "学位论文")
-("Unable to include file from another drive: " "无法包含另一个盘的文件：")
-("Unable to link images from another drive: " "无法链接另一个盘的图片：")
-("Unable to make animation from another drive: " "无法创建另一个盘的动画：")
-("Unable to make sound from another drive: " "无法创建另一个盘的声音：")
+("Unable to include file from another drive: "
+  "无法包含另一个盘的文件："
+) ;
+("Unable to link images from another drive: "
+  "无法链接另一个盘的图片："
+) ;
+("Unable to make animation from another drive: "
+  "无法创建另一个盘的动画："
+) ;
+("Unable to make sound from another drive: "
+  "无法创建另一个盘的声音："
+) ;
 ("Unable to make sound which url is none: " "无法创建空 URL 的声音：")
-("Unable to make thumbnail from another drive: " "无法创建另一个盘的缩略图：")
+("Unable to make thumbnail from another drive: "
+  "无法创建另一个盘的缩略图："
+) ;
 ("United Kingdom" "英国")
 ("United States" "美国")
-("Use CSS for more advanced formatting" "使用 CSS 进行更高级的格式化")
+("Use CSS for more advanced formatting"
+  "使用 CSS 进行更高级的格式化"
+) ;
 ("Use high resolution icons" "使用高分辨率图标")
-("Use line wrapping for lines which are longer than 80 characters" "自动换行超过 80 个字符的行")
+("Use line wrapping for lines which are longer than 80 characters"
+  "自动换行超过 80 个字符的行"
+) ;
 ("Use relative path" "使用相对路径")
 ("Use retina fonts" "使用适配视网膜屏的字体")
-("Use the Formatted Mogan Scheme" "使用格式化后的 Mogan Scheme")
 ("View reasoning" "查看推理")
 ("Windows Bitmap" "Windows位图")
 ("Writing" "生成回复")
@@ -206,6 +287,7 @@
 ("add style package" "增加宏包")
 ("add switch after" "")
 ("add switch before" "")
+("add color" "添加颜色")
 ("add" "新增")
 ("address block" "地址栏")
 ("address" "地址")
@@ -336,6 +418,7 @@
 ("base" "基线")
 ("baseline" "基线")
 ("bashkirian" "巴什基尔语")
+("basic colors" "基本颜色")
 ("basic communication using pipes" "基本管道通信")
 ("basic data types" "基本数据类型")
 ("basic types" "基本型态")
@@ -404,6 +487,7 @@
 ("browse symbols documentation" "浏览符号的文档")
 ("browse web" "浏览网页")
 ("browse" "浏览")
+("Browse" "浏览")
 ("browser" "浏览器")
 ("buffer management" "标签页管理")
 ("buffer" "文档")
@@ -452,7 +536,9 @@
 ("character expansion" "字符扩展")
 ("character contraction" "字符收缩")
 ("cjk spacing" "CJK 字间距")
-("check exported Pdf files for correctness" "检查导出的PDF文件的正确性")
+("check exported Pdf files for correctness"
+  "检查导出的PDF文件的正确性"
+) ;
 ("check for automatic updates" "检测自动更新")
 ("check for updates" "检查更新")
 ("check text for spelling errors" "检查拼写")
@@ -460,8 +546,10 @@
 ("chinese character" "中文字符")
 ("chinese" "中文")
 ("choice" "选择")
+("choose background" "选择背景")
+("choose color" "选择颜色")
 ("Choose source directory" "选择源目录")
-("Choose destination directory"   "选择目标目录")
+("Choose destination directory" "选择目标目录")
 ("Choose binary file" "选择可执行文件")
 ("circle" "圆圈")
 ("citation" "引用")
@@ -469,7 +557,9 @@
 ("cite" "引文")
 ("class" "类")
 ("clear all fields" "清除全部区域")
-("clear font cache under TEXMACS_HOME_PATH and local cache path" "清除TEXMACS_HOME_PATH和系统本地缓存路径下的字体缓存")
+("clear font cache under TEXMACS_HOME_PATH and local cache path"
+  "清除TEXMACS_HOME_PATH和系统本地缓存路径下的字体缓存"
+) ;
 ("clear font cache" "清除字体缓存")
 ("Clear list" "清空列表")
 ("clear menu" "清除列表")
@@ -498,7 +588,9 @@
 ("closing style" "结束风格")
 ("closing" "")
 ("code" "代码")
-("Color formulas and several other basic tags" "着色公式和一些基础标记")
+("Color formulas and several other basic tags"
+  "着色公式和一些基础标记"
+) ;
 ("color of the axes" "坐标轴颜色")
 ("color of the subunits" "子单元颜色")
 ("color of the units" "单元颜色")
@@ -589,6 +681,10 @@
 ("curve points" "曲线点")
 ("curve" "曲线")
 ("custom" "自定义")
+("custom colors" "自定义颜色")
+("custom colors are full, delete one first"
+  "自定义颜色已满，请先删除一个颜色"
+) ;
 ("custom tab" "自定义制表符")
 ("custom tab" "自定义制表符")
 ("customizations" "定制")
@@ -614,6 +710,7 @@
 ("dash unit" "短线单位")
 ("dash" "短线")
 ("dashes" "短线")
+("Draft" "草稿")
 ("data conversion" "数据转换")
 ("data format" "数据格式")
 ("data" "数据")
@@ -638,6 +735,7 @@
 ("definition of" "查看定义:")
 ("definition" "定义")
 ("delete column" "删除此行")
+("delete color" "删除颜色")
 ("delete documentation cache" "删除文档缓存")
 ("delete row" "删除此列")
 ("delete" "删除")
@@ -666,6 +764,7 @@
 ("diamond" "菱形")
 ("directory" "目录")
 ("disable case sensitivity" "忽略大小写")
+("disable emoji shortcuts" "关闭 Emoji 快捷键")
 ("disable first indentation after" "")
 ("disable first indentation before" "")
 ("disable first indentation" "禁用首段缩进")
@@ -707,7 +806,9 @@
 ("dot" "点")
 ("dots" "点")
 ("double stroke" "")
-("Double the zoom factor for TeXmacs documents" "将TeXmacs文档的显示放大两倍")
+("Double the zoom factor for TeXmacs documents"
+  "将TeXmacs文档的显示放大两倍"
+) ;
 ("down" "下")
 ("Done" "完成")
 ("download" "下载")
@@ -750,6 +851,8 @@
 ("elsevier" "爱思唯尔")
 ("email" "电子邮件")
 ("Email not set" "未绑定邮箱")
+("Embed source document" "将源文档作为附件嵌入PDF")
+("emoji shortcuts" "Emoji 快捷键")
 ("emphasize text" "强调文本")
 ("emphasize" "强调")
 ("empty box" "空白的区域")
@@ -874,7 +977,9 @@
 ("field" "区域")
 ("figure" "图")
 ("file name" "文件名")
-("File not found, removed from recent list" "文件未找到，已从最近列表中移除")
+("File not found, removed from recent list"
+  "文件未找到，已从最近列表中移除"
+) ;
 ("file not found" "无此文件")
 ("file type" "文件类型")
 ("file" "文件")
@@ -984,7 +1089,9 @@
 ("Global hide section numbers" "全局隐藏节编号")
 ("Global hide subsection numbers" "全局隐藏小节编号")
 ("Global hide subsubsection numbers" "全局隐藏子节编号")
-("Global numbering is hidden, toggle has no effect" "已设置全局隐藏编号，此处切换不生效")
+("Global numbering is hidden, toggle has no effect"
+  "已设置全局隐藏编号，此处切换不生效"
+) ;
 ("global history" "全局历史")
 ("global status" "全局状态")
 ("glossary entry" "术语项")
@@ -1005,6 +1112,7 @@
 ("graphical effects" "图形效果")
 ("graphical interface" "图形界面")
 ("ghost lines" "智能标尺")
+("Ghost text" "幽灵文本补全")
 ("graphics geometry" "画布设置")
 ("graphics grids" "网格设置")
 ("graphics overlay" "图形图层")
@@ -1055,8 +1163,12 @@
 ("high resolution settings" "高分屏设置")
 ("highlight errors" "高亮错误")
 ("history" "历史")
-("hold down CTRL and click the mouse to follow the link" "按住CTRL并单击鼠标以跟踪链接")
-("hold down COMMAND and click the mouse to follow the link" "按住COMMAND并单击鼠标以跟踪链接")
+("hold down CTRL and click the mouse to follow the link"
+  "按住CTRL并单击鼠标以跟踪链接"
+) ;
+("hold down COMMAND and click the mouse to follow the link"
+  "按住COMMAND并单击鼠标以跟踪链接"
+) ;
 ("home" "主页")
 ("homepage" "主页")
 ("homoglyph correct" "同形异义字修正")
@@ -1091,15 +1203,29 @@
 ("import font" "导入字体")
 ("import selections as" "导入到选中区域")
 ("import sessions" "导入会话")
-("import sophisticated objects as pictures" "将复杂的对象作为图片导入")
+("import sophisticated objects as pictures"
+  "将复杂的对象作为图片导入"
+) ;
 ("import" "导入")
 ("improving the current implementation" "改进当前的实作")
-("Insert clipboard content as 'HTML'" "以“HTML”形式插入剪贴板的内容")
-("Insert clipboard content as 'LaTeX'" "以“LaTeX”形式插入剪贴板的内容")
-("Insert clipboard content as 'Markdown'" "以“Markdown”形式插入剪贴板的内容")
-("Insert clipboard content as 'MathML'" "以“MathML”形式插入剪贴板的内容")
-("insert clipboard content as 'plain text'" "以“纯文本”形式插入剪贴板的内容")
-("Insert clipboard content as 'code'" "以“代码”形式插入剪贴板的内容")
+("Insert clipboard content as 'HTML'"
+  "以“HTML”形式插入剪贴板的内容"
+) ;
+("Insert clipboard content as 'LaTeX'"
+  "以“LaTeX”形式插入剪贴板的内容"
+) ;
+("Insert clipboard content as 'Markdown'"
+  "以“Markdown”形式插入剪贴板的内容"
+) ;
+("Insert clipboard content as 'MathML'"
+  "以“MathML”形式插入剪贴板的内容"
+) ;
+("insert clipboard content as 'plain text'"
+  "以“纯文本”形式插入剪贴板的内容"
+) ;
+("Insert clipboard content as 'code'"
+  "以“代码”形式插入剪贴板的内容"
+) ;
 ("in popup windows" "在弹出窗口")
 ("inactive" "")
 ("inanimated" "无动画")
@@ -1291,10 +1417,16 @@
 ("insert title" "插入标题")
 ("insert value" "")
 ("insert" "插入")
-("Insert the recognized LaTeX code into the document" "仅将识别后的LaTeX代码插入文档")
-("Insert the image and the recognized LaTeX code into the document" "将图片与识别后的LaTeX代码插入文档")
+("Insert the recognized LaTeX code into the document"
+  "仅将识别后的LaTeX代码插入文档"
+) ;
+("Insert the image and the recognized LaTeX code into the document"
+  "将图片与识别后的LaTeX代码插入文档"
+) ;
 ("Insert only the picture into the document" "仅将图片插入文档")
-("Inserting bibliography in the current document" "在当前文件插入参考文献")
+("Inserting bibliography in the current document"
+  "在当前文件插入参考文献"
+) ;
 ("insertion" "嵌入")
 ("inside mathematics" "在数学模式中")
 ("interactive command" "")
@@ -1458,9 +1590,13 @@
 ("logarithmic" "对数坐标")
 ("logarithms" "对数")
 ("Log In" "登录")
-("Log in and enjoy seamless Markdown import." "登录即享Markdown无缝导入")
+("Log in and enjoy seamless Markdown import."
+  "登录即享Markdown无缝导入"
+) ;
 ("Log in to chat with the AI." "登录即可与AI进行对话")
-("Log in to sync settings and access all features" "登录即可同步设置并访问所有功能。")
+("Log in to sync settings and access all features"
+  "登录即可同步设置并访问所有功能。"
+) ;
 ("Log in to use the latest OCR model." "登录即用OCR最新模型")
 ("login" "登录")
 ("Login error, please log in again." "登录有误，请重新登录")
@@ -1532,7 +1668,7 @@
 ("math font" "")
 ("math symbols" "数学符号")
 ("math" "数学")
-("Math mode" "数学模式") 
+("Math mode" "数学模式")
 ("mathematical and customized input" "数学和定制的输入")
 ("mathematical font" "数学字体")
 ("mathematical formulas" "数学公式")
@@ -1581,7 +1717,9 @@
 ("mode dependent icons" "模式工具栏")
 ("mode" "模式")
 ("modifier" "")
-("Modifying bibliography in the current document" "在当前文件修改参考文献")
+("Modifying bibliography in the current document"
+  "在当前文件修改参考文献"
+) ;
 ("modify bibliography" "修改参考文献")
 ("modify cell alignment" "改变单元格对齐")
 ("modify cell border" "")
@@ -1591,10 +1729,11 @@
 ("modify table padding" "")
 ("modify" "修改")
 ("mogan" "墨干")
-("mogan scheme" "Mogan Scheme")
 ("mongolian" "")
 ("month" "月")
-("more information about GNU TeXmacs can be found in the Help" "更多关于 GNU TeXmacs 的信息可查看帮助")
+("more information about GNU TeXmacs can be found in the Help"
+  "更多关于 GNU TeXmacs 的信息可查看帮助"
+) ;
 ("mosaic" "")
 ("motif" "主题")
 ("move down" "")
@@ -1695,6 +1834,13 @@
 ("notification" "提示")
 ("november" "")
 ("number equation" "编号方程")
+("Monday" "周一")
+("Tuesday" "周二")
+("Wednesday" "周三")
+("Thursday" "周四")
+("Friday" "周五")
+("Saturday" "周六")
+("Sunday" "周日")
 ("number of columns" "栏数")
 ("number of polar steps" "极坐标步数")
 ("number of subunit steps" "子单元步数")
@@ -1865,6 +2011,7 @@
 ("philosophy" "哲学")
 ("phoenician" "")
 ("phonetic" "")
+("pick screen color" "拾取屏幕颜色")
 ("picture" "图片")
 ("pictures" "图片")
 ("pink" "粉红")
@@ -1880,7 +2027,9 @@
 ("Please close the auxiliary window first" "请先关闭辅助窗口")
 ("Please login to view your account information." "请登录查看账户信息")
 ("Please pick one style" "请选择一种样式")
-("Please restart Mogan to apply the changes." "请重启Mogan以应用更改。")
+("Please restart Mogan to apply the changes."
+  "请重启Mogan以应用更改。"
+) ;
 ("plot" "描画图形")
 ("plug-ins" "插件")
 ("plugin" "插件")
@@ -1911,7 +2060,9 @@
 ("preferences for tag" "全局设置")
 ("preferences" "首选项")
 ("prefix by section number" "以章节号为前缀")
-("Prepend chapter number prefix for section numbers" "节编号显示章编号的前缀")
+("Prepend chapter number prefix for section numbers"
+  "节编号显示章编号的前缀"
+) ;
 ("presentation mode" "演讲模式")
 ("Presentation slides" "演示文稿")
 ("Preview" "预览")
@@ -1948,7 +2099,9 @@
 ("printing command" "打印程序")
 ("problem" "题目")
 ("produce Pdf using native export filter" "使用原生的PDF导出工具")
-("produce Postscript using native export filter" "使用原生的Postscript导出工具")
+("produce Postscript using native export filter"
+  "使用原生的Postscript导出工具"
+) ;
 ("professional" "专业")
 ("prog font family" "")
 ("prog font series" "")
@@ -2061,7 +2214,7 @@
 ("remove" "删除")
 ("rename" "重命名")
 ("rendering options for tag" "局部设置")
-("Register now and receive a 7-day membership." "注册即送7天会员")
+("Register now and receive a 3-day membership." "注册即送3天会员")
 ("Renew" "续费")
 ("Renew Early" "提前续费")
 ("Renew Now" "续费会员")
@@ -2076,8 +2229,12 @@
 ("replace toolbar" "替换工具栏")
 ("replace unrecognized styles" "替换无法识别的样式")
 ("replace one occurrence (Enter)" "替换一个匹配项 (Enter)")
-("replace all further occurrences (Ctrl+Enter)" "替换所有后续匹配项 (Ctrl+Enter)")
-("Replace all further occurrences (Command+Enter)" "替换所有后续匹配项 (Command+Enter)")
+("replace all further occurrences (Ctrl+Enter)"
+  "替换所有后续匹配项 (Ctrl+Enter)"
+) ;
+("Replace all further occurrences (Command+Enter)"
+  "替换所有后续匹配项 (Command+Enter)"
+) ;
 ("replace" "替换")
 ("replaced one occurrence" "")
 ("replaced" "")
@@ -2160,6 +2317,12 @@
 ("scheme developers guide" "Scheme 开发指南")
 ("scheme extensions" "扩展语言")
 ("scheme interface for the graphical mode" "图形模式的 Scheme 接口")
+("screen color picking is unavailable in this session"
+  "当前会话不支持屏幕取色"
+) ;
+("screen color picking requires the screen recording permission: allow it in System Settings and restart the app"
+  "屏幕取色需要「屏幕录制」权限：请在系统设置中允许后重启应用"
+) ;
 ("screen layout" "")
 ("screen margins" "")
 ("screen" "屏幕")
@@ -2448,7 +2611,9 @@
 ("tabular" "无框表格")
 ("tags with special rendering" "具有特殊渲染的标签")
 ("teXmacs as an interface" "TeXmacs 的交互式界面")
-("teXmacs extensions to scheme and utilities" "对 Scheme 的扩展和实用工具")
+("teXmacs extensions to scheme and utilities"
+  "对 Scheme 的扩展和实用工具"
+) ;
 ("teXmacs fonts" "TeXmacs 字体")
 ("teXmacs notice" "")
 ("teXmacs plug-ins" "TeXmacs 的插件")
@@ -2458,7 +2623,6 @@
 ("texmacs → Html" "TeXmacs → Html")
 ("texmacs → Image" "TeXmacs → Image")
 ("texmacs → LaTeX" "TeXmacs → LaTeX")
-("texmacs → Mogan Scheme" "TeXmacs → Mogan Scheme")
 ("texmacs → Pdf / Postscript" "TeXmacs → PDF / Postscript")
 ("texmacs → Verbatim" "TeXmacs → 纯文本")
 ("template" "模板")
@@ -2502,23 +2666,43 @@
 ("the graphical user interface" "图形用户界面")
 ("the leaves of TeXmacs trees" "")
 ("the mycas example" "")
-("The OCR feature requires logging in to use..."  "OCR功能需要登录才能使用...")
+("The OCR feature requires logging in to use..."
+  "OCR功能需要登录才能使用..."
+) ;
 ("Sign In" "去登录")
 ("Sign in to start using OCR." "登录后即可开始使用 OCR 识别。")
 ("Sign in to use OCR" "登录后即可使用 OCR 识别")
-("Sign up now and get 7 days of membership for free!" "现在注册还送7天会员资格！")
-("The OCR feature requires an internet connection to use..." "OCR功能需要连接网络才能使用...")
-("Connect to the network to enjoy convenient and fast OCR features!" "连接网络享受方便又快捷的OCR功能！")
+("Sign up now and get 3 days of membership for free!"
+  "现在注册还送3天会员资格！"
+) ;
+("The OCR feature requires an internet connection to use..."
+  "OCR功能需要连接网络才能使用..."
+) ;
+("Connect to the network to enjoy convenient and fast OCR features!"
+  "连接网络享受方便又快捷的OCR功能！"
+) ;
 ("You have reached the limit of free uses..." "免费次数已达到上限...")
 ("Daily OCR limit reached" "今日 OCR 识别额度已用完")
-("Use your invite code to bring a friend, and get rewards together!" "使用邀请码邀请好友，两人均可获得会员奖励！")
-("Buy it! Convenient and fast OCR features!" "快来买！方便又快捷的OCR功能！")
+("Use your invite code to bring a friend, and get rewards together!"
+  "使用邀请码邀请好友，两人均可获得会员奖励！"
+) ;
+("Buy it! Convenient and fast OCR features!"
+  "快来买！方便又快捷的OCR功能！"
+) ;
 ("Upgrade" "升级会员")
-("Upgrade to continue using OCR." "升级会员后可继续使用 OCR 识别。")
+("Upgrade to continue using OCR."
+  "升级会员后可继续使用 OCR 识别。"
+) ;
 ("Daily AI chat limit reached" "今日 AI 聊天次数已达上限")
-("Upgrade to continue using AI chat." "升级会员后可继续使用 AI 聊天。")
-("Copy the image and press Ctrl+Shift+v to paste the OCR recognition result" "复制图片，按 Ctrl+Shift+V 粘贴OCR识别结果")
-("Copy the image and press Command+Shift+v to paste the OCR recognition result" "复制图片，按 Command+Shift+v 粘贴OCR识别结果")
+("Upgrade to continue using AI chat."
+  "升级会员后可继续使用 AI 聊天。"
+) ;
+("Copy the image and press Ctrl+Shift+v to paste the OCR recognition result"
+  "复制图片，按 Ctrl+Shift+V 粘贴OCR识别结果"
+) ;
+("Copy the image and press Command+Shift+v to paste the OCR recognition result"
+  "复制图片，按 Command+Shift+v 粘贴OCR识别结果"
+) ;
 ("An error occurred..." "出错了...")
 ("the primitive TeXmacs constructs" "")
 ("the standard TeXmacs styles" "TeXmacs 的标准样式")
@@ -2530,8 +2714,12 @@
 ("this document has been produced using" "此文档撰写于")
 ("this document has not been saved" "现工作的暂存区信息尚未保存")
 ("this line" "")
-("this change requires restarting Mogan STEM to take full effect." "此更改需要重新启动 Mogan STEM 才能完全生效。")
-("this change requires restarting Liii STEM to take full effect." "此更改需要重新启动 Liii STEM 才能完全生效。")
+("this change requires restarting Mogan STEM to take full effect."
+  "此更改需要重新启动 Mogan STEM 才能完全生效。"
+) ;
+("this change requires restarting Liii STEM to take full effect."
+  "此更改需要重新启动 Liii STEM 才能完全生效。"
+) ;
 ("this page footer" "当前页页脚")
 ("this page header" "当前页页眉")
 ("this page" "")
@@ -2553,13 +2741,23 @@
 ("to the right" "")
 ("today" "今天")
 ("toggle cell wrapping mode" "切换单元格换行模式")
-("toggle the preamble mode for the document" "切换到当前文档的导言模式")
-("toggle the visibility of the window's footer" "切换窗口底部状态栏的可见性")
-("toggle using current buffer as master file of project" "是否切换当前文档为项目的主文件")
+("toggle the preamble mode for the document"
+  "切换到当前文档的导言模式"
+) ;
+("toggle the visibility of the window's footer"
+  "切换窗口底部状态栏的可见性"
+) ;
+("toggle using current buffer as master file of project"
+  "是否切换当前文档为项目的主文件"
+) ;
 ("toggle whether we save auxiliary data" "切换是否存储辅助数据")
 ("toggle whether we show keyboard presses" "切换是否显示键盘按键")
-("Toggle mode for using reduced margins to save paper" "切换窄边距模式以节省纸张")
-("Toggle mode for using special margins for screen editing" "切换屏幕编辑专用边距模式")
+("Toggle mode for using reduced margins to save paper"
+  "切换窄边距模式以节省纸张"
+) ;
+("Toggle mode for using special margins for screen editing"
+  "切换屏幕编辑专用边距模式"
+) ;
 ("Toggle mode for using standard page numbering" "切换是否显示页码")
 ("toggling enables related fields" "切换会启用相关字段")
 ("tools" "工具")
@@ -2585,11 +2783,19 @@
 ("Trial Member" "体验会员")
 ("triangle" "三角形")
 ("trigonometry" "三角函数")
-("try to import formulas using LaTeX annotations" "尝试使用 LaTeX 注释导入公式")
-("Try Command+Shift+v, auto-detects format." "试试Command+Shift+v，自动识别格式。")
-("Try Ctrl+Shift+v, auto-detects format." "试试Ctrl+Shift+v，自动识别格式。")
+("try to import formulas using LaTeX annotations"
+  "尝试使用 LaTeX 注释导入公式"
+) ;
+("Try Command+Shift+v, auto-detects format."
+  "试试Command+Shift+v，自动识别格式。"
+) ;
+("Try Ctrl+Shift+v, auto-detects format."
+  "试试Ctrl+Shift+v，自动识别格式。"
+) ;
 ("Try now" "立即体验")
-("Wrong result? Use Selective Paste here." "结果不准确？请用此处的选择性粘贴。")
+("Wrong result? Use Selective Paste here."
+  "结果不准确？请用此处的选择性粘贴。"
+) ;
 ("tuple" "元组")
 ("turkish" "土耳其文")
 ("tutorial" "入门教程")
@@ -2629,6 +2835,8 @@
 ("up" "")
 ("up" "上")
 ("Update buffer" "更新缓冲区")
+("Update channel" "更新通道")
+("Update check failed: " "更新检查失败：")
 ("Update now" "立即更新")
 ("update from web" "")
 ("update image links" "")
@@ -2794,8 +3002,12 @@
 ("your document is back in its original state" "")
 ("your first interface" "")
 ("your language" "使用语言")
-("Your membership has expired. Renew to continue using AI, MathOCR, and other member features" "会员已到期，续费后可继续使用 AI、MathOCR 等会员功能")
-("Your membership will expire within 7 days. Renew early for more savings" "会员将在 7 天内到期，提前续费享更多优惠")
+("Your membership has expired. Renew to continue using AI, MathOCR, and other member features"
+  "会员已到期，续费后可继续使用 AI、MathOCR 等会员功能"
+) ;
+("Your membership will expire within 7 days. Renew early for more savings"
+  "会员将在 7 天内到期，提前续费享更多优惠"
+) ;
 ("zigzag" "之字形")
 ("zoom factor" "缩放比例")
 ("zoom in" "放大")
@@ -2803,23 +3015,41 @@
 ("zoom" "缩放")
 ("zoom/unzoom objects" "放大/缩小对象")
 ("zoom/unzoom" "放大/缩小")
-("You are currently in guest mode, login to enable AI, MathOCR,and other features" "您当前处于访客状态，登录激活AI和公式识别等功能")
-("You are using v%1, and the latest stable version is v%2." "您正在使用 v%1，当前最新稳定版是 v%2。")
-("You are using v%1, and the latest stable version is v%2. Please click OK to visit the official website to download the latest stable version." "您正在使用 v%1，当前最新稳定版是 v%2。请点击确认前往官网下载最新稳定版。")
-("You are using v%1.\nThe latest stable version of Mogan STEM is v%2, and the latest stable version of Liii STEM is v%3." "您正在使用 v%1。\nMogan STEM 的最新稳定版是 v%2，Liii STEM 的最新稳定版是 v%3。")
-("You are using v%1.\nThe latest stable version of Mogan STEM is v%2, and the latest stable version of Liii STEM is v%3.\nPlease click OK to visit the official website to download the latest stable version." "您正在使用 v%1。\nMogan STEM 的最新稳定版是 v%2，Liii STEM 的最新稳定版是 v%3。\n请点击确认前往官网下载最新稳定版。")
-("You are using v%1, and the latest stable version of Liii STEM is v%2." "您正在使用 v%1，Liii STEM 的最新稳定版是 v%2。")
-("You are using v%1, and the latest stable version of Liii STEM is v%2.\nPlease click OK to visit the official website to download the latest stable version." "您正在使用 v%1，Liii STEM 的最新稳定版是 v%2。\n请点击确认前往官网下载最新稳定版。")
+("You are currently in guest mode, login to enable AI, MathOCR,and other features"
+  "您当前处于访客状态，登录激活AI和公式识别等功能"
+) ;
+("You are using v%1, and the latest stable version is v%2."
+  "您正在使用 v%1，当前最新稳定版是 v%2。"
+) ;
+("You are using v%1, and the latest stable version is v%2. Please click OK to visit the official website to download the latest stable version."
+  "您正在使用 v%1，当前最新稳定版是 v%2。请点击确认前往官网下载最新稳定版。"
+) ;
+("You are using v%1.\nThe latest stable version of Mogan STEM is v%2, and the latest stable version of Liii STEM is v%3."
+  "您正在使用 v%1。\nMogan STEM 的最新稳定版是 v%2，Liii STEM 的最新稳定版是 v%3。"
+) ;
+("You are using v%1.\nThe latest stable version of Mogan STEM is v%2, and the latest stable version of Liii STEM is v%3.\nPlease click OK to visit the official website to download the latest stable version."
+  "您正在使用 v%1。\nMogan STEM 的最新稳定版是 v%2，Liii STEM 的最新稳定版是 v%3。\n请点击确认前往官网下载最新稳定版。"
+) ;
+("You are using v%1, and the latest stable version of Liii STEM is v%2."
+  "您正在使用 v%1，Liii STEM 的最新稳定版是 v%2。"
+) ;
+("You are using v%1, and the latest stable version of Liii STEM is v%2.\nPlease click OK to visit the official website to download the latest stable version."
+  "您正在使用 v%1，Liii STEM 的最新稳定版是 v%2。\n请点击确认前往官网下载最新稳定版。"
+) ;
 ("Login Now" "立即登录")
 ("User Center" "用户中心")
 ("Use extensible brackets" "使用可伸缩括号")
-("Use \\space (eg. 1cm) in order to insert a blank with specified width" "使用 \\space（例如 1cm）来插入指定宽度的空白")
+("Use \\space (eg. 1cm) in order to insert a blank with specified width"
+  "使用 \\space（例如 1cm）来插入指定宽度的空白"
+) ;
 ("Style options" "样式选项")
 ("Framed input fields" "带框输入字段")
 ("Ring binder notebook style" "活页夹笔记本样式")
 ("Do not break up large formulas" "不拆分大型公式")
 ("Please log in to use Magic Paste" "请登录后使用魔法粘贴")
-("Daily Magic Paste limit reached. Upgrade for unlimited access." "今日魔法粘贴次数已达上限，升级会员可无限使用")
+("Daily Magic Paste limit reached. Upgrade for unlimited access."
+  "今日魔法粘贴次数已达上限，升级会员可无限使用"
+) ;
 ("Magic paste shortcut" "魔法粘贴快捷键")
 ("Login" "登录")
 ("Upgrade" "升级")
diff --git a/TeXmacs/plugins/lang/progs/lang/chinese-kbd.scm b/TeXmacs/plugins/lang/progs/lang/chinese-kbd.scm
index 32cf626bfa..2e331f820a 100644
--- a/TeXmacs/plugins/lang/progs/lang/chinese-kbd.scm
+++ b/TeXmacs/plugins/lang/progs/lang/chinese-kbd.scm
@@ -11,9 +11,9 @@
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(texmacs-module (lang chinese-kbd) (:use (text text-kbd)))
+(texmacs-module (lang chinese-kbd))
 
-(kbd-map (:mode in-chinese?)
+(delayed-kbd-map (:mode in-chinese?)
  ("\x10;" "<#201C>")
  ("\x11;" "<#201D>")
  ("\x16;" "<#2014>")
@@ -135,4 +135,4 @@
  ("i 5 0 0 var" "<#217E>")
  ("i 1 0 0 0 var" "<#217F>")
  ("C-m" (kbd-select-enlarge))
-) ;kbd-map
+) ;delayed-kbd-map
diff --git a/TeXmacs/plugins/lang/progs/lang/dutch-kbd.scm b/TeXmacs/plugins/lang/progs/lang/dutch-kbd.scm
new file mode 100644
index 0000000000..03e4c1ed24
--- /dev/null
+++ b/TeXmacs/plugins/lang/progs/lang/dutch-kbd.scm
@@ -0,0 +1,48 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : dutch-kbd.scm
+;; DESCRIPTION : keystrokes for the Dutch language
+;; COPYRIGHT   : (C) 2026  Da Shen
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (lang dutch-kbd) (:use (math math-kbd)))
+
+(kbd-map (:mode in-math-dutch?)
+  ;; ("e n" (make 'infix-and))
+  ;; ("e n space" (make 'infix-and))
+  ("space e" " e")
+  ("space e var" (begin (kbd-space) (insert "")))
+  ("space e var var" (begin (kbd-space) (insert "")))
+  ("space e var var var" (begin (kbd-space) (insert "")))
+  ("space e var var var var" (begin (kbd-space) (insert "")))
+  ("space e n" (make 'infix-and))
+  ("space e n space" (make 'infix-and))
+  ;; ("e n var" "en")
+  ;; ("o f" (make 'infix-or))
+  ;; ("o f space" (make 'infix-or))
+  ("space o" " o")
+  ("space o var" (begin (kbd-space) (insert "")))
+  ("space o f" (make 'infix-or))
+  ("space o f space" (make 'infix-or))
+  ;; ("o f var" "of")
+  ;; ("d e s d a" (make 'infix-iff))
+  ;; ("d e s d a space" (make 'infix-iff))
+  ("space d" " d")
+  ("space d var" (begin (kbd-space) (insert "")))
+  ("space d var var" (begin (kbd-space) (insert "")))
+  ("space d var var var" (begin (kbd-space) (insert "")))
+  ("space d e" " de")
+  ("space d e s" " des")
+  ("space d e s d" " desd")
+  ("space d e s d a" (make 'infix-iff))
+  ("space d e s d a space" (make 'infix-iff))
+  ;; ("d e s d a var" "desda")
+  ("v o o r space" "voor ")
+  ("v o o r space a l l e" (make 'prefix-for-all))
+  ("v o o r space a l l e space" (make 'prefix-for-all))
+) ;kbd-map
diff --git a/TeXmacs/plugins/lang/progs/lang/esperanto-kbd.scm b/TeXmacs/plugins/lang/progs/lang/esperanto-kbd.scm
index 488a9c6957..9c7ea9fc2b 100644
--- a/TeXmacs/plugins/lang/progs/lang/esperanto-kbd.scm
+++ b/TeXmacs/plugins/lang/progs/lang/esperanto-kbd.scm
@@ -11,7 +11,7 @@
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(texmacs-module (lang esperanto-kbd) (:use (text text-kbd)))
+(texmacs-module (lang esperanto-kbd))
 
 (kbd-map (:mode in-esperanto?)
  ("c var" "<#109>")
diff --git a/TeXmacs/plugins/lang/progs/lang/french-kbd.scm b/TeXmacs/plugins/lang/progs/lang/french-kbd.scm
new file mode 100644
index 0000000000..aa84a48157
--- /dev/null
+++ b/TeXmacs/plugins/lang/progs/lang/french-kbd.scm
@@ -0,0 +1,45 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : french-kbd.scm
+;; DESCRIPTION : keystrokes for the French language
+;; COPYRIGHT   : (C) 2026  Da Shen
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (lang french-kbd) (:use (math math-kbd)))
+
+(kbd-map (:mode in-math-french?)
+  ;; ("e t" (make 'infix-and))
+  ;; ("e t space" (make 'infix-and))
+  ("space e" " e")
+  ("space e var" (begin (kbd-space) (insert "")))
+  ("space e var var" (begin (kbd-space) (insert "")))
+  ("space e var var var" (begin (kbd-space) (insert "")))
+  ("space e var var var var" (begin (kbd-space) (insert "")))
+  ("space e t" (make 'infix-and))
+  ("space e t space" (make 'infix-and))
+  ;; ("e t var" "et")
+  ;; ("o u" (make 'infix-or))
+  ;; ("o u space" (make 'infix-or))
+  ("space o" " o")
+  ("space o var" (begin (kbd-space) (insert "")))
+  ("space o u" (make 'infix-or))
+  ("space o u space" (make 'infix-or))
+  ;; ("o u var" "ou")
+  ;; ("s s i" (make 'infix-iff))
+  ;; ("s s i space" (make 'infix-iff))
+  ("space s" " s")
+  ("space s var" (begin (kbd-space) (insert "")))
+  ("space s var var" (begin (kbd-space) (insert "")))
+  ("space s s" " ss")
+  ("space s s i" (make 'infix-iff))
+  ("space s s i space" (make 'infix-iff))
+  ;; ("s s i var" "ssi")
+  ("p o u r space" "pour ")
+  ("p o u r space t o u t" (make 'prefix-for-all))
+  ("p o u r space t o u t space" (make 'prefix-for-all))
+) ;kbd-map
diff --git a/TeXmacs/plugins/lang/progs/lang/german-kbd.scm b/TeXmacs/plugins/lang/progs/lang/german-kbd.scm
new file mode 100644
index 0000000000..32f479bf3a
--- /dev/null
+++ b/TeXmacs/plugins/lang/progs/lang/german-kbd.scm
@@ -0,0 +1,48 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : german-kbd.scm
+;; DESCRIPTION : keystrokes for the German language
+;; COPYRIGHT   : (C) 2026  Da Shen
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (lang german-kbd) (:use (math math-kbd)))
+
+(kbd-map (:mode in-math-german?)
+  ;; ("u n d" (make 'infix-and))
+  ;; ("u n d space" (make 'infix-and))
+  ("space u" " u")
+  ("space u var" (begin (kbd-space) (insert "")))
+  ("space u n" " un")
+  ("space u n d" (make 'infix-and))
+  ("space u n d space" (make 'infix-and))
+  ;; ("u n d var" "und")
+  ;; ("o d e r" (make 'infix-or))
+  ;; ("o d e r space" (make 'infix-or))
+  ("space o" " o")
+  ("space o var" (begin (kbd-space) (insert "")))
+  ("space o d" " od")
+  ("space o d e" " ode")
+  ("space o d e r" (make 'infix-or))
+  ("space o d e r space" (make 'infix-or))
+  ;; ("o d e r var" "oder")
+  ;; ("g d w" (make 'infix-iff))
+  ;; ("g d w space" (make 'infix-iff))
+  ("space g" " g")
+  ("space g var" (begin (kbd-space) (insert "")))
+  ("space g var var" (begin (kbd-space) (insert "")))
+  ("space g d" " gd")
+  ("space g d w" (make 'infix-iff))
+  ("space g d w space" (make 'infix-iff))
+  ;; ("g d w var" "gdw")
+  ("f u r space" "fur ")
+  ("f u r space a l l e" (make 'prefix-for-all))
+  ("f u r space a l l e space" (make 'prefix-for-all))
+  ("f u e r space" "fuer ")
+  ("f u e r space a l l e" (make 'prefix-for-all))
+  ("f u e r space a l l e space" (make 'prefix-for-all))
+) ;kbd-map
diff --git a/TeXmacs/plugins/lang/progs/lang/polish-kbd.scm b/TeXmacs/plugins/lang/progs/lang/polish-kbd.scm
index 248ce7cf74..dddce3c030 100644
--- a/TeXmacs/plugins/lang/progs/lang/polish-kbd.scm
+++ b/TeXmacs/plugins/lang/progs/lang/polish-kbd.scm
@@ -11,7 +11,7 @@
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(texmacs-module (lang polish-kbd) (:use (text text-kbd)))
+(texmacs-module (lang polish-kbd))
 
 ;; 迁移自 text-kbd.scm 的 in-polish? kbd-map（原 cork 字节 RHS 已用
 ;; <#XXXX> unicode 转义重建，cork↔utf8 字节契约由 tests/1159.scm 钉死）。
diff --git a/TeXmacs/plugins/lang/progs/lang/spanish-kbd.scm b/TeXmacs/plugins/lang/progs/lang/spanish-kbd.scm
index ab13a6a763..1190336407 100644
--- a/TeXmacs/plugins/lang/progs/lang/spanish-kbd.scm
+++ b/TeXmacs/plugins/lang/progs/lang/spanish-kbd.scm
@@ -11,7 +11,7 @@
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(texmacs-module (lang spanish-kbd) (:use (text text-kbd)))
+(texmacs-module (lang spanish-kbd))
 
 (kbd-map (:mode in-spanish?)
  ("! var" "<#A1>")
diff --git a/TeXmacs/plugins/lang/progs/lang/yawerty-kbd.scm b/TeXmacs/plugins/lang/progs/lang/yawerty-kbd.scm
index 1b6d426574..72db23beb5 100644
--- a/TeXmacs/plugins/lang/progs/lang/yawerty-kbd.scm
+++ b/TeXmacs/plugins/lang/progs/lang/yawerty-kbd.scm
@@ -11,7 +11,7 @@
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(texmacs-module (lang yawerty-kbd) (:use (text text-kbd)))
+(texmacs-module (lang yawerty-kbd))
 
 (kbd-map (:mode in-cyrillic-yawerty?)
 
diff --git a/TeXmacs/plugins/latex/progs/bibtex/abbrv.scm b/TeXmacs/plugins/latex/progs/bibtex/abbrv.scm
deleted file mode 100644
index b2d6d2ce39..0000000000
--- a/TeXmacs/plugins/latex/progs/bibtex/abbrv.scm
+++ /dev/null
@@ -1,25 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : abbrv.scm
-;; DESCRIPTION : abbrv style for BibTeX files
-;; COPYRIGHT   : (C) 2010, 2015  David MICHEL, Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (bibtex abbrv)
-  (:use (bibtex bib-utils) (bibtex plain)))
-
-(bib-define-style "abbrv" "plain")
-
-(tm-define (bib-format-first-name x)
-  (:mode bib-abbrv?)
-  (if (bib-null? (list-ref x 1)) ""
-      (with f (bib-abbreviate (list-ref x 1) "." `(nbsp))
-        (if (bib-name-ends? f ".")
-            (tmconcat f '(nbsp))
-            (tmconcat f " ")))))
diff --git a/TeXmacs/plugins/latex/progs/bibtex/abstract.scm b/TeXmacs/plugins/latex/progs/bibtex/abstract.scm
deleted file mode 100644
index 0269c7d434..0000000000
--- a/TeXmacs/plugins/latex/progs/bibtex/abstract.scm
+++ /dev/null
@@ -1,21 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : abstract.scm
-;; DESCRIPTION : abstract style for BibTeX files
-;; COPYRIGHT   : (C) 2017  Philippe Joyez
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (bibtex abstract)
-  (:use (bibtex bib-utils) (bibtex plain)))
-
-(bib-define-style "abstract" "plain")
-
-(tm-define (bib-format-bibitem n x)
-  (:mode bib-abstract?)
-  `(bibitem* ,(list-ref x 2)))
diff --git a/TeXmacs/plugins/latex/progs/bibtex/acm.scm b/TeXmacs/plugins/latex/progs/bibtex/acm.scm
deleted file mode 100644
index 53d7482fd0..0000000000
--- a/TeXmacs/plugins/latex/progs/bibtex/acm.scm
+++ /dev/null
@@ -1,294 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : acm.scm
-;; DESCRIPTION : acm style for BibTeX files
-;; COPYRIGHT   : (C) 2010, 2015  David MICHEL, Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (bibtex acm)
-  (:use (bibtex bib-utils) (bibtex plain)))
-
-(bib-define-style "acm" "plain")
-
-(tm-define (bib-format-name x)
-  (:mode bib-acm?)
-  (let* ((f (if (bib-null? (list-ref x 1)) ""
-		`(concat ", " ,(bib-abbreviate (list-ref x 1) "." `(nbsp)))))
-	 (vv (if (bib-null? (list-ref x 2)) ""
-                 `(concat ,(list-ref x 2) (nbsp))))
-	 (ll (if (bib-null? (list-ref x 3)) ""
-                 (bib-purify (list-ref x 3))))
-	 (jj (if (bib-null? (list-ref x 4)) ""
-                 `(concat ", " ,(list-ref x 4)))))
-    `(with "font-shape" "small-caps" (concat ,vv ,ll ,jj ,f))))
-
-(tm-define (bib-format-editor x)
-  (:mode bib-acm?)
-  (let* ((a (bib-field x "editor")))
-    (if (or (bib-null? a) (nlist? a))
-	""
-	(if (equal? (length a) 2)
-	    `(concat ,(bib-format-names a) ,(bib-translate ", Ed."))
-	    `(concat ,(bib-format-names a) ,(bib-translate ", Eds."))))))
-
-(tm-define (bib-format-date x)
-  (:mode bib-acm?)
-  (let* ((y (bib-field x "year"))
-	 (m (bib-field x "month")))
-    (if (bib-null? y)
-	(if (bib-null? m) "" m)
-	(if (bib-null? m) y `(concat ,m " " ,y)))))
-
-(tm-define (bib-format-in-ed-booktitle x)
-  (:mode bib-acm?)
-  (let* ((b (bib-field x "booktitle"))
-	 (a (bib-field x "address"))
-	 (cl `(concat " (" ,(bib-new-list ", " `(,a ,(bib-format-date x))) ")")))
-    (if (bib-null? b)
-	""
-	`(concat
-	  ,(bib-translate "in ")
-	  (with "font-shape" "italic" ,b) ,cl))))
-
-(define (bib-format-volume-or-number x)
-  (let* ((v (bib-field x "volume"))
-	 (n (bib-field x "number"))
-	 (s (bib-field x "series")))
-    (if (bib-null? v)
-	(if (bib-null? n)
-	    (if (bib-null? s) "" s)
-	    (let ((series (if (bib-null? s)
-			      ""
-			      `(concat ,(bib-translate " in ") ,s)))
-		  (sep (if (< (bib-text-length n) 3) `(nbsp) " ")))
-	      `(concat "no." ,sep ,n ,series)))
-	(let ((series (if (bib-null? s)
-			  ""
-			  `(concat ,(bib-translate " of ")
-				   (with "font-shape" "italic" ,s))))
-	      (sep (if (< (bib-text-length v) 3) `(nbsp) " ")))
-	  `(concat "vol." ,sep ,v ,series)))))
-
-(tm-define (bib-format-pages x)
-  (:mode bib-acm?)
-  (let* ((p (bib-field x "pages")))
-    (cond
-      ((or (bib-null? p) (nlist? p)) "")
-      ((== (length p) 1) "")
-      ((== (length p) 2) (list-ref p 1))
-      (else `(concat ,(list-ref p 1) ,bib-range-symbol ,(list-ref p 2))))))
-
-(tm-define (bib-format-chapter-pages x)
-  (:mode bib-acm?)
-  (let* ((c (bib-field x "chapter"))
-	 (t (bib-field x "type")))
-    (if (bib-null? c)
-	(bib-format-pages x)
-	(let ((type (if (bib-null? t)
-			(bib-translate "chapter")
-			(bib-locase t)))
-	      (pages `(concat ", " ,(bib-format-pages x))))
-	  `(concat ,type " " ,c ,pages)))))
-
-(tm-define (bib-format-tr-number x)
-  (:mode bib-acm?)
-  (let* ((t (bib-field x "type"))
-	 (n (bib-field x "number"))
-	 (type (if (bib-null? t) (bib-translate "Technical Report") t))
-	 (number (if (bib-null? n) "" n))
-	 (sep (if (< (bib-text-length n) 3) `(nbsp) " ")))
-    (if (bib-null? n) type
-        `(concat ,type ,sep ,number))))
-
-(define (bib-format-edition x)
-  (let* ((e (bib-field x "edition")))
-    (if (bib-null? e) "" `(concat ,e " ed."))))
-
-(tm-define (bib-format-bibitem n x)
-  (:mode bib-acm?)
-  `(bibitem* ,(number->string n)))
-
-(define (bib-format-journal-volume-date x)
-  (bib-new-sentence
-   `((concat ,(bib-emphasize
-               `(concat ,(bib-format-field x "journal")
-                        ,(if (bib-null? (bib-field x "volume")) "" " ")
-                        ,(bib-format-field x "volume")))
-             " (" ,(bib-format-date x) ")")
-     ,(bib-format-pages x))))
-
-(define (bib-format-journal-volume-number-date x)
-  (bib-new-sentence
-   `(,(bib-emphasize
-       `(concat ,(bib-format-field x "journal")
-                ,(if (bib-null? (bib-field x "volume")) "" " ")
-                ,(bib-format-field x "volume")))
-     (concat ,(bib-format-field x "number")
-             " (" ,(bib-format-date x) ")")
-     ,(bib-format-pages x))))
-
-(tm-define (bib-format-article n x)
-  (:mode bib-acm?)
-  `(concat ,(bib-format-bibitem n x)
-	   ,(bib-label (list-ref x 2))
-	   ,(bib-new-list-spc
-	     `(,(bib-new-block (bib-format-author x))
-	       ,(bib-new-block (bib-format-field-Locase x "title"))
-	       ,(bib-new-block
-		 (if (bib-empty? x "crossref")
-                     (if (bib-null? (bib-field x "number"))
-                         (bib-format-journal-volume-date x)
-                         (bib-format-journal-volume-number-date x))
-		     (bib-new-sentence
-		      `((concat ,(bib-translate "in ")
-				(cite ,(bib-field x "crossref")))
-			,(bib-format-pages x)))))
-	       ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-book n x)
-  (:mode bib-acm?)
-  `(concat ,(bib-format-bibitem n x)
-	   ,(bib-label (list-ref x 2))
-	   ,(bib-new-list-spc
-	     `(,(bib-new-block (if (bib-empty? x "author")
-			       (bib-format-editor x)
-			       (bib-format-author x)))
-	       ,(bib-new-block
-		 (bib-new-sentence
-		  `(,(bib-emphasize (bib-format-field x "title"))
-		    ,(bib-format-edition x))))
-	       ,(bib-new-block
-		 (if (bib-empty? x "crossref")
-		     (bib-new-list-spc
-		      `(,(bib-new-sentence `(,(bib-format-number-series x)))
-			,(bib-new-sentence
-			  `(,(bib-format-field x "publisher")
-			    ,(bib-format-field x "address")
-			    ,(bib-format-date x)))))
-		     (bib-new-sentence
-		      `((concat ,(bib-translate "in ")
-				(cite ,(bib-field x "crossref")))
-			,(bib-format-field x "edition")
-			,(bib-format-date x)))))
-	       ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-inbook n x)
-  (:mode bib-acm?)
-  `(concat ,(bib-format-bibitem n x)
-	   ,(bib-label (list-ref x 2))
-	   ,(bib-new-list-spc
-	     `(,(bib-new-block (if (bib-empty? x "author")
-			       (bib-format-editor x)
-			       (bib-format-author x)))
-	       ,(bib-new-block
-		 (bib-new-sentence
-		  `(,(bib-emphasize (bib-format-field x "title")))))
-	       ,(bib-new-block
-		 (if (bib-empty? x "crossref")
-		     (bib-new-list-spc
-		      `(,(bib-new-sentence `(,(bib-format-number-series x)))
-			,(bib-new-sentence
-			  `(,(bib-format-field x "publisher")
-			    ,(bib-format-field x "address")
-			    ,(bib-format-date x)
-			    ,(bib-format-chapter-pages x)))))
-		     (bib-new-sentence
-		      `((concat ,(bib-translate "in ")
-				(cite ,(bib-field x "crossref")))
-			,(bib-format-field x "edition")
-			,(bib-format-date x)))))
-	       ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-incollection n x)
-  (:mode bib-acm?)
-  `(concat ,(bib-format-bibitem n x)
-	   ,(bib-label (list-ref x 2))
-	   ,(bib-new-list-spc
-	     `(,(bib-new-block (bib-format-author x))
-	       ,(bib-new-block (bib-format-field-Locase x "title"))
-	       ,(bib-new-block
-		 (if (bib-empty? x "crossref")
-		     (bib-new-list-spc
-		      `(,(bib-new-sentence
-			  `((concat ,(bib-translate "in ")
-				    ,(bib-emphasize (bib-format-field x "booktitle")))
-			    ,(bib-format-editor x)
-			    ,(bib-format-edition x)
-			    ,(bib-format-volume-or-number x)))
-			,(bib-new-sentence
-			  `(,(bib-format-field x "publisher")
-			    ,(bib-format-field x "address")
-			    ,(bib-format-date x)
-			    ,(bib-format-chapter-pages x)))))
-		     (bib-new-sentence
-		      `((concat ,(bib-translate "in ")
-				(cite ,(bib-field x "crossref")))
-			,(bib-format-chapter-pages x)))))
-	       ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-inproceedings n x)
-  (:mode bib-acm?)
-  `(concat ,(bib-format-bibitem n x)
-	   ,(bib-label (list-ref x 2))
-	   ,(bib-new-list-spc
-	     `(,(bib-new-block (bib-format-author x))
-	       ,(bib-new-block (bib-format-field-Locase x "title"))
-	       ,(bib-new-block
-		 (if (bib-empty? x "crossref")
-		     (bib-new-list-spc
-		      `(,(bib-new-sentence
-			  `(,(bib-format-in-ed-booktitle x)
-			    ,(bib-format-editor x)
-			    ,(bib-format-volume-or-number x)
-			    ,(bib-format-field x "organization")
-			    ,(bib-format-field x "publisher")
-			    ,(bib-format-pages x)))))
-		     (bib-new-sentence
-		      `((concat ,(bib-translate "in ")
-				(cite ,(bib-field x "crossref")))
-			,(bib-format-pages x)))))
-	       ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-manual n x)
-  (:mode bib-acm?)
-  `(concat ,(bib-format-bibitem n x)
-	   ,(bib-label (list-ref x 2))
-	   ,(bib-new-list-spc
-	     `(,(bib-new-block (bib-format-author x))
-	       ,(bib-new-block
-		 (bib-new-sentence
-		  `(,(bib-emphasize (bib-format-field x "title"))
-		    ,(bib-format-edition x)
-		    ,(bib-format-field x "organization")
-		    ,(bib-format-field x "address")
-		    ,(bib-format-date x))))
-	       ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-proceedings n x)
-  (:mode bib-acm?)
-  `(concat ,(bib-format-bibitem n x)
-	   ,(bib-label (list-ref x 2))
-	   ,(bib-new-list-spc
-	     `(,(bib-new-block
-		 (if (bib-empty? x "editor")
-		     (bib-format-field x "organization")
-		     (bib-format-editor x)))
-	       ,(bib-new-block
-		 (bib-new-sentence
-		  `((concat ,(bib-emphasize (bib-format-field x "title"))
-			    " ("
-			    ,(bib-new-list ", "
-				       `(,(bib-format-field x "address")
-					 ,(bib-format-date x)))
-			    ")")
-		    ,(bib-format-volume-or-number x)
-		    ,(bib-format-field x "organization")
-		    ,(bib-format-field x "publisher"))))
-	       ,(bib-new-block (bib-format-field x "note"))))))
-
diff --git a/TeXmacs/plugins/latex/progs/bibtex/alpha.scm b/TeXmacs/plugins/latex/progs/bibtex/alpha.scm
deleted file mode 100644
index 7acb2af291..0000000000
--- a/TeXmacs/plugins/latex/progs/bibtex/alpha.scm
+++ /dev/null
@@ -1,124 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : alpha.scm
-;; DESCRIPTION : alpha style for BibTeX files
-;; COPYRIGHT   : (C) 2010  David MICHEL
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (bibtex alpha)
-  (:use (bibtex bib-utils) (bibtex plain)))
-
-(bib-define-style "alpha" "plain")
-
-(define (bib-format-label-year x)
-  (if (bib-empty? x "year") ""
-      (let* ((y (bib-field x "year"))
-             (l (string-length y)))
-            (if (<= l 2) y (substring y (- l 2) l)))))
-
-(define (bib-format-label-names a)
-  (if (or (bib-null? a) (nlist? a)) ""
-    (let* ((n (length a))
-         (pre (cond
-                ((equal? n 2)
-                 (with von (bib-purify (bib-abbreviate
-                                        (list-ref (list-ref a 1) 2) "" ""))
-                   (if (bib-null? von)
-                       (bib-prefix (list-ref (list-ref a 1) 3) 3)
-                       (string-append von (bib-prefix
-                                           (list-ref (list-ref a 1) 3) 1)))))
-                (else
-                  (with lab ""
-                    (do
-                        ((i 1 (+ 1 i)))
-                        ((>= i (min n (if (= 5 n) 5 4))))
-                      (with von (bib-purify (bib-abbreviate
-                                             (list-ref (list-ref a i) 2)
-                                             "" ""))
-                        (set! lab (string-append
-                                   lab von (bib-prefix
-                                            (list-ref (list-ref a i) 3) 1)))))
-                     lab)))))
-      (if (> n 5) (string-append pre "+") pre))))
-
-(define (bib-format-book-inbook-label n x)
-  (with key (list-ref x 2)
-    (if (bib-empty? x "author")
-      (if (bib-empty? x "editor")
-        (if (bib-null? key)
-          (number->string n)
-        (bib-prefix key 3))
-            (bib-format-label-names (bib-field x "editor")))
-    (bib-format-label-names (bib-field x "author")))))
-    
-(define (bib-format-proceedings-misc-label ae n x)
-  (with key (list-ref x 2)
-    (if (bib-empty? x ae)
-        (if (bib-null? key)
-            (number->string n)
-            (bib-prefix key 3))
-        (bib-format-label-names (bib-field x ae)))))
-
-(define (bib-format-label-prefix n x)
-  (let* ((doctype (list-ref x 1))
-         (pre (cond
-                ((or (equal? doctype "book") (equal? doctype "inbook"))
-                 (bib-format-book-inbook-label n x))
-                ((equal? doctype "proceedings")
-                 (bib-format-proceedings-misc-label "editor" n x))
-                (else (bib-format-proceedings-misc-label "author" n x)))))
-    (string-append pre (bib-format-label-year x))))
-
-(define bib-label-table `())
-(define bib-key-table `())
-
-(tm-define (bib-preprocessing t)
-  (:mode bib-alpha?)
-  (set! bib-label-table (s7-make-hash-table 100))
-  (set! bib-key-table (s7-make-hash-table 100))
-  (do ((entry t (cdr entry)) (n 1 (+ n 1)))
-      ((null? entry))
-      (if (func? (car entry) 'bib-entry)
-          (let* ((label (bib-format-label-prefix 0 (car entry)))
-                 (num (ahash-ref bib-label-table label)))
-            (ahash-set! bib-key-table (list-ref (car entry) 2) label)
-            (if num
-                (ahash-set! bib-label-table label
-                           (if (equal? num `()) `(1 2) 
-                               `(,@num ,(+ 1 (length num)))))
-                (ahash-set! bib-label-table label `()))))))
-
-(define (bib-format-label n x)
-  (let* ((pre (ahash-ref bib-key-table (list-ref x 2)))
-         (num (ahash-ref bib-label-table pre)))
-    (if (null? num) pre
-        (with n (car num)
-          (ahash-set! bib-label-table pre (cdr num))
-          (string-append pre (string (integer->char (+ 96 n))))))))
-
-(tm-define (bib-format-bibitem n x)
-  (:mode bib-alpha?)
-  `(bibitem* ,(bib-format-label n x)))
-
-(define (invert-label l)
-  (with invert (lambda (c)
-                 (cond
-                   ((char-upper-case? c) (char-downcase c))
-                   ((char-lower-case? c) (char-upcase c))
-                   (else c)))
-    (string-map invert l)))
-
-(tm-define (bib-sort-key x)
-  (:mode bib-alpha?)
-  (let* ((auths (bib-format-label-names (bib-field x "author")))
-         (label (ahash-ref bib-key-table (list-ref x 2)))
-         (year (bib-field x "year"))
-               (lplain (bib-with-style "plain" bib-sort-key x)))
-    (string-append (string-upcase (if (bib-null? auths) label auths))
-                   (if (bib-null? year) "" year) "    " lplain)))
diff --git a/TeXmacs/plugins/latex/progs/bibtex/bib-complete.scm b/TeXmacs/plugins/latex/progs/bibtex/bib-complete.scm
deleted file mode 100644
index 345925ebac..0000000000
--- a/TeXmacs/plugins/latex/progs/bibtex/bib-complete.scm
+++ /dev/null
@@ -1,67 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : bib-complete.scm
-;; DESCRIPTION : Autocompletion of bibtex citekeys 
-;; COPYRIGHT   : (C) 2013 Miguel de Benito Delgado
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (bibtex bib-complete)
-  (:use (utils library ptrees)))
-
-(define parse-times (make-ahash-table))
-(define parse-results (make-ahash-table))
-(define bib-files-cache (make-ahash-table))
-(define bib-styles-cache (make-ahash-table))
-
-(define (get-citekeys-list l)
-  (list-fold
-   (lambda (entry rest) 
-     (if (tm-func? entry 'bib-entry) (cons (caddr entry) rest) rest))
-   '() l))
-
-(define (get-citekeys-pt u)
-  (let ((mod-time (url-last-modified u))
-        (parse-time (or (ahash-ref parse-times u) 0)))
-    (if (> mod-time parse-time) ; handy: false also if url invalid
-        (begin
-          (ahash-set! parse-times u mod-time)
-          (ahash-set! parse-results u
-           (pt-add-list (make-ptree)
-             (get-citekeys-list
-              (tree->stree (parse-bib (string-load u))))))))
-    (ahash-ref parse-results u)))
-
-; FIXME: if the user changes the bibliography file we still retrieve from cache
-(tm-define (current-bib-file usecache?)
-  (:synopsis "Returns the (cached) name of the bibliography file")
-  (with u (current-buffer-url)
-    (or (and usecache? (ahash-ref bib-files-cache u))
-        (with l (select (buffer-tree) '(:* bibliography))
-          (if (nnull? l)
-              (ahash-set! bib-files-cache u
-               (url-append (url-head u) (tm->string (tree-ref (car l) 2))))
-              (url-none))))))
-
-(tm-define (current-bib-style usecache?)
-  (:synopsis "Returns the (cached) style of the bibliography")
-  (with u (current-buffer-url)
-    (or (and usecache? (ahash-ref bib-styles-cache u))
-        (with l (select (buffer-tree) '(:* bibliography))
-          (if (nnull? l)
-              (ahash-set! bib-styles-cache u (tm->string (tree-ref (car l) 1)))
-              "tm-plain")))))
-
-(tm-define (citekey-list u s)
-  (:synopsis "Completions for @s in the bibtex file @u as a list")
-  (if (url-none? u) '()
-      (pt-words-below (pt-find (get-citekeys-pt u) s))))
-
-(tm-define (citekey-completions u t)
-  (:synopsis "Completions for @t in the bibtex file @u for custom-complete")
-  `(tuple ,t
-     ,@(map string->tmstring (citekey-list u (tree->string t)))))
diff --git a/TeXmacs/plugins/latex/progs/bibtex/bib-utils.scm b/TeXmacs/plugins/latex/progs/bibtex/bib-utils.scm
deleted file mode 100644
index 19525ab29f..0000000000
--- a/TeXmacs/plugins/latex/progs/bibtex/bib-utils.scm
+++ /dev/null
@@ -1,192 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : bib-utils.scm
-;; DESCRIPTION : helper functions for BibTeX styles
-;; COPYRIGHT   : (C) 2010, 2015  David MICHEL, Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (bibtex bib-utils))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Private administrative functions
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define bib-current-prefix "bib")
-(tm-define bib-style "plain")
-(tm-define bib-default-style "plain")
-
-(tm-define (bib-label what)
-  `(label ,(string-append bib-current-prefix "-" what)))
-
-(tm-define (bib-preprocessing t)
-  (noop))
-
-(tm-define (bib-sort-key x)
-  "")
-
-(tm-define (bib-mode? s)
-  (or (equal? bib-style s) (equal? bib-default-style s)))
-
-(define (format-entries n x)
-  (if (and (list? x) (nnull? x))
-      (cons (bib-format-entry n (car x)) (format-entries (+ n 1) (cdr x)))
-      `()))
-
-(define (bib-with-sort-key t)
-  (if (null? t) `()
-      (cons `(,(bib-sort-key (car t)) ,(car t)) (bib-with-sort-key (cdr t)))))
-
-(define (bib-without-sort-key t)
-  (if (null? t) `()
-      (cons (cadar t) (bib-without-sort-key (cdr t)))))
-
-(define (bib-compare x y)
-  (tmstring-before? (car x) (car y)))
-
-(tm-define (bib-sorted-entries l)
-  ;; redefine when (e.g.) sorting should be disabled
-  (with is-entry? (lambda (x) (func? x 'bib-entry))
-    (with l1 (list-filter l is-entry?)
-      (with l2 (list-sort (bib-with-sort-key l1) bib-compare)
-        (bib-without-sort-key l2)))))
-
-(tm-define (bib-process prefix style t)
-  (set! bib-current-prefix prefix)
-  (set! bib-style style)
-  (bib-preprocessing (cdr t))
-  (if (and (list? t) (func? t 'document))
-      (with ts (bib-sorted-entries (cdr t))
-	(bib-simplify
-	 `(bib-list
-	   ,(number->string (length ts))
-	   (document ,@(format-entries 1 ts)))))))
-
-(tm-define bib-functions-table (s7-make-hash-table 100))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Public functions
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (bib-standard-styles)
-  (list "tm-plain" "tm-abbrv" "tm-abstract" "tm-acm" "tm-alpha" "tm-elsart-num"
-        "tm-ieeetr" "tm-siam" "tm-unsrt" "tm-gbt7714-2015" "tm-gbt7714-2015-author-year"))
-
-(tm-define-macro (bib-define-style s d)
-  (if (equal? s d)
-      `(begin
-	 (set! bib-default-style ,s)
-	 (texmacs-modes (,(string->symbol (string-append "bib-" s "%"))
-			 (bib-mode? ,s))))
-      `(begin
-	 (set! bib-default-style ,d)
-	 (texmacs-modes (,(string->symbol (string-append "bib-" s "%"))
-			 (bib-mode? ,s)
-			 ,(string->symbol (string-append "bib-" d "%")))))))
-
-(tm-define (bib-with-style s f . args)
-  (with tmp-s bib-style
-    (set! bib-style s)
-    (with res (apply f args)
-      (set! bib-style tmp-s)
-      res)))
-
-(tm-define (bib-car x)
-  (if (pair? x) (car x) ""))
-
-(tm-define (bib-cdr x)
-  (if (pair? x) (cdr x) ""))
-
-(tm-define (bib-null? x)
-  (cond
-    ((tm-func? x 'with) (bib-null? (tm-ref x :last)))
-    ((list? x) (equal? x `()))
-    ((string? x) (equal? x ""))
-    ((symbol? x) (equal? (symbol->string x) ""))
-    (else #f)))
-
-(tm-define (bib-simplify x)
-  (tree->stree (tree-simplify (stree->tree x))))
-
-(tm-define (bib-new-block x)
-  (if (bib-null? x) ""
-      `(concat ,(bib-add-period (bib-upcase-first x)) (newblock))))
-
-(tm-define (bib-new-case-preserved-block x)
-  (if (bib-null? x) ""
-      `(concat ,(bib-add-period x) (newblock))))
-
-(define (elim-empty x)
-  (if (bib-null? x) `()
-      (if (bib-null? (car x)) (elim-empty (cdr x))
-	  `(,(car x) ,@(elim-empty (cdr x))))))
-
-(tm-define (new-list-rec s x)
-  ;; redefined in ieeetr.scm
-  (cond ((bib-null? x) "")
-        ((bib-null? (car x)) (new-list-rec s (cdr x)))
-        ((null? (cdr x)) `(concat ,(car x)))
-        ((and (tm-func? (car x) 'concat) (== (cAr (car x)) `(newblock)))
-         `(concat ,(cDr (car x)) ,s (newblock) ,(new-list-rec s (cdr x))))
-        (else `(concat ,(car x) ,s ,(new-list-rec s (cdr x))))))
-
-(tm-define (bib-new-list-spc x)
-  (new-list-rec " " (elim-empty x)))
-
-(tm-define (bib-new-list c x)
-  (new-list-rec c (elim-empty x)))
-
-(tm-define (bib-new-case-preserved-sentence x)
-  (bib-add-period (bib-new-list ", " x)))
-
-(tm-define (bib-new-sentence x)
-  (bib-add-period (bib-upcase-first (bib-new-list ", " x))))
-
-(tm-define (bib-default-field x s)
-  (with e (bib-field x s)
-    (if (bib-null? e) e (bib-default-upcase-first e))))
-
-(tm-define (bib-format-field x s)
-  (with e (bib-field x s)
-    (if (bib-null? e) "" (bib-default-upcase-first e))))
-
-(tm-define (bib-format-field-preserve-case x s)
-  (with e (bib-field x s)
-    (if (bib-null? e) "" (bib-default-preserve-case e))))
-
-(tm-define (bib-format-field-locase-first x s)
-  (with e (bib-field x s)
-    (if (bib-null? e) "" (bib-locase-first e))))
-
-(tm-define (bib-format-field-Locase x s)
-  (with e (bib-field x s)
-    (if (bib-null? e) "" (bib-upcase-first (bib-locase e)))))
-
-(tm-define (bib-emphasize x)
-  `(with "font-shape" "italic" ,x))
-
-(tm-define (bib-translate s)
-  (if (== (get-env "bib-no-translate") "true")
-      s
-      `(localize ,s)))
-
-(tm-define bib-range-symbol "-")
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Sample function
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (ext-first-last t)
-  (:secure #t)
-  (if (tree-compound? t) t
-      (let* ((s (tree->string t))
-	     (i (string-search-forwards " " 0 s))
-	     (m (number->string i))
-	     (e (number->string (string-length s))))
-	(if (< i 0) t
-	    `(concat (range ,t "0" ,m) (name (range ,t ,m ,e)))))))
diff --git a/TeXmacs/plugins/latex/progs/bibtex/bib-widgets.scm b/TeXmacs/plugins/latex/progs/bibtex/bib-widgets.scm
deleted file mode 100644
index 43dda1a141..0000000000
--- a/TeXmacs/plugins/latex/progs/bibtex/bib-widgets.scm
+++ /dev/null
@@ -1,168 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : bib-widgets.scm
-;; DESCRIPTION : Widgets for bibliography
-;; COPYRIGHT   : (C) 2014 Miguel de Benito Delgado
-;;                   2026 Yuki Lu
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; TODO:
-;;  - Handle external BibTeX.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (bibtex bib-widgets)
-  (:use (bibtex bib-complete) (bibtex bib-utils) (generic document-edit)))
-
-(define bibwid-url (string->url ""))
-(define bibwid-style "tm-plain")
-(define bibwid-default-style "tm-plain")
-(define bibwid-use-relative? #t)
-(define bibwid-update-buffer? #t)
-(define bibwid-buffer (string->url ""))
-
-(define (bibwid-set-url u)
-  (cond ((and (== bibwid-use-relative? #t) (url-rooted? u))
-         (set! bibwid-url (url-delta bibwid-buffer u)))
-        ((and (== bibwid-use-relative? #f) (not (url-rooted? u)))
-         (set! bibwid-url (url-append (url-head bibwid-buffer) u)))
-        (else (set! bibwid-url u))))
-
-(define (safe-bib-standard-styles)
-  (catch #t (lambda () (bib-standard-styles))
-         (lambda (key . args) '("tm-plain"))))
-
-(define (bibwid-set-style answer)
-  (let ((styles (safe-bib-standard-styles)))
-    (if (and (string? answer) (in? answer styles))
-        (set! bibwid-style answer)
-        (set! bibwid-style bibwid-default-style)))
-  (refresh-now "bibwid-preview"))
-
-(define (bibwid-preview-bg-color)
-  (if (== (get-preference "gui theme") "liii-night") "#202020" "#ffffff"))
-
-(define (bibwid-preview-fg-color)
-  (if (== (get-preference "gui theme") "liii-night") "#ffffff" "#000000"))
-
-(define (bibwid-output-content t style)
-  (if (tree-is? t 'string) 
-      `(with "bg-color" ,(bibwid-preview-bg-color)
-         "color" ,(bibwid-preview-fg-color)
-         (mini-paragraph "1250px"
-           (document ,(replace "Please choose a valid %1 file" "BibTeX"))))
-      `(with "bg-color" ,(bibwid-preview-bg-color)
-         "color" ,(bibwid-preview-fg-color)
-         (mini-paragraph "1250px" ,(bib-process "bib" style (tree->stree t))))))
-
-(define (bibwid-output)
-  (with style (if (and (>= (string-length bibwid-style) 3)
-                       (== "tm-" (string-take bibwid-style 3)))
-                  (string-drop bibwid-style 3)
-                  bibwid-style)
-    (when (== style "")
-      (set! style bibwid-default-style))
-    (catch #t (lambda () (eval `(use-modules (bibtex ,(string->symbol style)))))
-           (lambda (key . args) (noop)))
-    (with u (if (and bibwid-use-relative? (not (url-rooted? bibwid-url)))
-                (url-append (url-head bibwid-buffer) bibwid-url)
-                bibwid-url)
-      (with t (if (url-exists? u)
-                  (parse-bib (string-load u))
-                  (tree ""))
-        (stree->tree (bibwid-output-content t style))))))
-
-(define (bibwid-insert doit?)
-  (when doit?
-    (if (not (make-return-after))
-        (insert 
-         (list 'bibliography "bib" bibwid-style (url->string bibwid-url)
-               '(document ""))))
-    (if bibwid-update-buffer? (update-document "bibliography"))))
-
-(define (bibwid-modify doit?)
-  (when doit?
-    (with l (select (buffer-tree) '(:* bibliography))
-      (when (> (length l) 0)
-        (with t (car l)
-          (tree-set! t 1 bibwid-style)
-          (tree-set! t 2 (url->string bibwid-url))
-          (if bibwid-update-buffer? (update-document "bibliography")))))))
-
-(define (bibwid-set-filename u)
-  (bibwid-set-url u)
-  (refresh-now "bibwid-file-input")
-  (refresh-now "bibwid-preview"))
-
-(define (bibwid-set-relative val)
-  (set! bibwid-use-relative? val)
-  (bibwid-set-filename bibwid-url))
-
-(tm-widget (bibwid-preview)
-  (resize '("520px" "520px" "9999px") '("100px" "100px" "9999px")
-    (scrollable
-      (refreshable "bibwid-preview"
-        (texmacs-output
-         (bibwid-output)
-         '(style "generic"))))))
-
-(tm-widget ((bibliography-widget modify? msg) cmd)
-  (padded
-    (hlist >>> (text msg) >>>)
-    ===
-    (hlist 
-      (text "File:") // //
-      (refreshable "bibwid-file-input"
-        (hlist
-          (input (when (and answer (!= answer (url->string bibwid-url)))
-                   (bibwid-set-url (string->url answer))
-                   (refresh-now "bibwid-preview"))
-                 "file" (list (url->string bibwid-url)) "40em")
-          // //
-          (explicit-buttons 
-            ("" (choose-file bibwid-set-filename "Choose" "tmbib"))))))
-    ===
-    (hlist
-      (text "Use relative path:") //
-      (toggle (bibwid-set-relative answer)
-              bibwid-use-relative?)
-      // //
-      (text "Update buffer:") //
-      (toggle (set! bibwid-update-buffer? answer)
-              bibwid-update-buffer?)
-      // //
-      (text "Style:") // //
-      (verb (enum (bibwid-set-style answer) (safe-bib-standard-styles)
-            bibwid-style "10em")))
-    ===
-    (hlist // (dynamic (bibwid-preview)) //)
-    ===
-    (bottom-buttons >>>
-      ("Cancel" (cmd #f)) // //
-      (if modify? ("Modify" (cmd #t)))
-      (if (not modify?) ("Insert" (cmd #t))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Interface
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (open-bibliography-inserter)
-  (set! bibwid-buffer (current-buffer))
-  (let ((u (current-bib-file #f))
-        (s (current-bib-style #f)))
-    (if (and (not (url-none? u)) (!= s ""))
-        (with msg (translate "Modifying bibliography in the current document")
-          (bibwid-set-url u)
-          (set! bibwid-style s)
-          (dialogue-window (bibliography-widget #t msg)
-                           bibwid-modify "Modify bibliography"))
-        (with msg (translate "Inserting bibliography in the current document")
-          (bibwid-set-url (string->url ""))
-          (set! bibwid-style "tm-plain")
-          (dialogue-window (bibliography-widget #f msg)
-                           bibwid-insert "Insert bibliography")))))
diff --git a/TeXmacs/plugins/latex/progs/bibtex/elsart-num.scm b/TeXmacs/plugins/latex/progs/bibtex/elsart-num.scm
deleted file mode 100644
index 69d7cde405..0000000000
--- a/TeXmacs/plugins/latex/progs/bibtex/elsart-num.scm
+++ /dev/null
@@ -1,306 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : elsart-num.scm
-;; DESCRIPTION : elsart-num style for BibTeX files
-;; COPYRIGHT   : (C) 2010, 2015  David MICHEL, Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (bibtex elsart-num)
-  (:use (bibtex bib-utils) (bibtex plain)))
-
-(bib-define-style "elsart-num" "plain")
-
-(tm-define (bib-sorted-entries l)
-  (:mode bib-elsart-num?)
-	(with is-entry? (lambda (x) (func? x 'bib-entry))
-		(list-filter l is-entry?)))
-
-(tm-define (bib-format-name x)
-  (:mode bib-elsart-num?)
-  (let* ((f (if (bib-null? (list-ref x 1)) ""
-		`(concat ,(bib-abbreviate (list-ref x 1) "." `(nbsp)) (nbsp))))
-	 (vv (if (bib-null? (list-ref x 2)) ""
-                 `(concat ,(list-ref x 2) (nbsp))))
-	 (ll (if (bib-null? (list-ref x 3)) ""
-                 (bib-purify (list-ref x 3))))
-	 (jj (if (bib-null? (list-ref x 4)) ""
-                 `(concat ", " ,(list-ref x 4)))))
-    `(concat ,f ,vv ,ll ,jj)))
-
-(tm-define (bib-last-name-sep a)
-  (:mode bib-elsart-num?)
-  ", ")
-
-(tm-define (bib-format-editor x)
-  (:mode bib-elsart-num?)
-  (let* ((a (bib-field x "editor")))
-    (if (or (bib-null? a) (nlist? a))
-	""
-	(if (equal? (length a) 2)
-	    `(concat ,(bib-format-names a) ,(bib-translate " (Ed.)"))
-	    `(concat ,(bib-format-names a) ,(bib-translate " (Eds.)"))))))
-
-(define (bib-format-edition x)
-  (let* ((e (bib-field x "edition")))
-    (if (bib-null? e) "" `(concat ,e " Edition"))))
-
-(define (bib-format-volume-or-number x)
-  (let* ((v (bib-field x "volume"))
-	 (n (bib-field x "number"))
-	 (s (bib-field x "series")))
-    (if (bib-null? v)
-	(if (bib-null? n)
-	    (if (bib-null? s) "" s)
-	    (let ((series (if (bib-null? s)
-			      ""
-			      `(concat ,(bib-translate " in ") ,s)))
-		  (sep (if (< (bib-text-length n) 3) `(nbsp) " ")))
-	      `(concat "No." ,sep ,n ,series)))
-	(let ((series (if (bib-null? s)
-			  ""
-			  `(concat ,(bib-translate " of ") ,s)))
-	      (sep (if (< (bib-text-length v) 3) `(nbsp) " ")))
-	  `(concat "Vol." ,sep ,v ,series)))))
-
-(tm-define (bib-format-pages x)
-  (:mode bib-elsart-num?)
-  (let* ((p (bib-field x "pages")))
-    (cond
-      ((or (bib-null? p) (nlist? p)) "")
-      ((== (length p) 1) "")
-      ((== (length p) 2)
-       `(concat ,(bib-translate "p.") (nbsp) ,(list-ref p 1)))
-      (else `(concat ,(bib-translate "pp.") (nbsp)
-                     ,(list-ref p 1) ,bib-range-symbol ,(list-ref p 2))))))
-
-(tm-define (bib-format-vol-num-pages x)
-  (:mode bib-elsart-num?)
-  (let* ((j (bib-field x "journal"))
-	 (v (bib-field x "volume"))
-	 (n (bib-field x "number"))
-	 (y `(concat "(" ,(bib-field x "year") ")"))
-	 (p (let* ((pp (bib-field x "pages")))
-	      (cond
-               ((or (bib-null? pp) (nlist? pp)) "")
-	       ((equal? 1 (length pp)) "")
-	       ((equal? 2 (length pp)) (list-ref pp 1))
-	       (else `(concat ,(list-ref pp 1) ,bib-range-symbol
-                              ,(list-ref pp 2)))))))
-    (when (not (bib-null? n))
-      (set! v `(concat ,v (nbsp) "(" ,n ")")))
-    (bib-new-list " " `(,j ,v ,y ,p))))
-
-(define (bib-format-note x)
-  (bib-format-field-locase-first x "note"))
-
-(tm-define (bib-format-article n x)
-  (:mode bib-elsart-num?)
-  `(concat ,(bib-format-bibitem n x)
-	   ,(bib-label (list-ref x 2))
-	   ,(bib-new-block
-	     (bib-new-sentence
-	      `(,(bib-format-author x)
-		,(bib-format-field-Locase x "title")
-		,@(if (bib-empty? x "crossref")
-		      `(,(bib-format-vol-num-pages x))
-		      `((concat ,(bib-translate "in ")
-				(cite ,(bib-field x "crossref")))
-			,(bib-format-pages x)))
-		,(bib-format-note x))))))
-
-(tm-define (bib-format-book n x)
-  (:mode bib-elsart-num?)
-  `(concat ,(bib-format-bibitem n x)
-	   ,(bib-label (list-ref x 2))
-	   ,(bib-new-block
-	     (bib-new-sentence
-	      `(,(if (bib-empty? x "author")
-		     (bib-format-editor x)
-		     (bib-format-author x))
-		,(bib-format-field x "title")
-		,(bib-format-edition x)
-		,@(if (bib-empty? x "crossref")
-		      `(,(bib-format-volume-or-number x)
-			,(bib-format-field x "publisher")
-			,(bib-format-field x "address"))
-		      `((concat ,(bib-translate "in ")
-				(cite ,(bib-field x "crossref")))
-			,(bib-format-edition x )))
-		,(bib-format-field x "year")
-		,(bib-format-note x))))))
-
-(tm-define (bib-format-booklet n x)
-  (:mode bib-elsart-num?)
-  `(concat ,(bib-format-bibitem n x)
-	   ,(bib-label (list-ref x 2))
-	   ,(bib-new-block
-	     (bib-new-case-preserved-sentence
-	      `(,(bib-format-author x)
-		,(bib-format-field-Locase x "title")
-		,(bib-format-field-preserve-case x "howpublished")
-		,(bib-format-field x "address")
-		(concat ,(if (bib-empty? x "note")
-			     ""
-			     `(concat ,(bib-format-note x) " "))
-			"(" ,(bib-format-date x) ")"))))))
-
-(tm-define (bib-format-inbook n x)
-  (:mode bib-elsart-num?)
-  `(concat ,(bib-format-bibitem n x)
-	   ,(bib-label (list-ref x 2))
-	   ,(bib-new-block
-	     (bib-new-sentence
-	      `(,(if (bib-empty? x "author")
-		     (bib-format-editor x)
-		     (bib-format-author x))
-		,(bib-format-field x "title")
-		,@(if (bib-empty? x "crossref")
-		      `(,(bib-format-edition x)
-			,(bib-format-volume-or-number x)
-			,(bib-format-field x "publisher")
-			,(bib-format-field x "address")
-			,(bib-format-field x "year")
-			,(bib-format-chapter-pages x))
-		      `((concat ,(bib-translate "in ")
-				(cite ,(bib-field x "crossref")))
-			,(bib-format-field x "edition")
-			,(bib-format-field x "year")))
-		,(bib-format-note x))))))
-
-(tm-define (bib-format-incollection n x)
-  (:mode bib-elsart-num?)
-  `(concat ,(bib-format-bibitem n x)
-	   ,(bib-label (list-ref x 2))
-	   ,(bib-new-block
-	     (bib-new-sentence
-	      `(,(bib-format-author x)
-		,(bib-format-field-Locase x "title")
-		,@(if (bib-empty? x "crossref")
-		      `((concat ,(bib-translate "in: ")
-				,(bib-format-editor x))
-			,(bib-format-field x "booktitle")
-			,(bib-format-edition x)
-			,(bib-format-volume-or-number x)
-			,(bib-format-field x "publisher")
-			,(bib-format-field x "address")
-			,(bib-format-field x "year"))
-		      `((concat ,(bib-translate "in ")
-				(cite ,(bib-field x "crossref")))))
-		,(bib-format-chapter-pages x)
-		,(bib-format-note x))))))
-
-(tm-define (bib-format-inproceedings n x)
-  (:mode bib-elsart-num?)
-  (bib-format-incollection n x))
-
-(tm-define (bib-format-manual n x)
-  (:mode bib-elsart-num?)
-  `(concat ,(bib-format-bibitem n x)
-	   ,(bib-label (list-ref x 2))
-	   ,(bib-new-block
-	     (bib-new-sentence
-	      `(,@(if (bib-empty? x "author")
-		      (if (bib-empty? x "organization")
-			  `()
-			  `(,(bib-format-field x "organization")
-			    ,(bib-format-field x "address")))
-		      `(,(bib-format-author x)))
-		,(bib-format-field x "title")
-		,(bib-format-field x "organization")
-		,(bib-format-field x "address")
-		,(bib-format-edition x)
-		(concat ,(if (bib-empty? x "note")
-			     ""
-			     `(concat ,(bib-format-note x) " "))
-			"(" ,(bib-format-date x) ")"))))))
-
-(tm-define (bib-format-mastersthesis n x)
-  (:mode bib-elsart-num?)
-  `(concat ,(bib-format-bibitem n x)
-	   ,(bib-label (list-ref x 2))
-	   ,(bib-new-block
-	     (bib-new-sentence
-	      `(,(bib-format-author x)
-		,(bib-format-field-Locase x "title")
-		,(if (bib-empty? x "type")
-		     (bib-translate "Master's thesis")
-		     (bib-format-field x "type"))
-		,(bib-format-field x "school")
-		,(bib-format-field x "address")
-		(concat ,(if (bib-empty? x "note")
-			     ""
-			     `(concat ,(bib-format-note x) " "))
-			"(" ,(bib-format-date x) ")"))))))
-
-(tm-define (bib-format-misc n x)
-  (:mode bib-plain?)
-  `(concat ,(bib-format-bibitem n x)
-	   ,(bib-label (list-ref x 2))
-	   ,(bib-new-block
-	     (bib-new-sentence
-	      `(,(bib-format-author x)
-		,(bib-format-field-Locase x "title")
-		,(bib-format-field-preserve-case x "howpublished")
-		(concat ,(if (bib-empty? x "note")
-			     ""
-			     `(concat ,(bib-format-note x) " "))
-			"(" ,(bib-format-date x) ")"))))))
-
-(tm-define (bib-format-phdthesis n x)
-  (:mode bib-elsart-num?)
-  (bib-format-mastersthesis n x))
-
-(tm-define (bib-format-proceedings n x)
-  (:mode bib-elsart-num?)
-  `(concat ,(bib-format-bibitem n x)
-	   ,(bib-label (list-ref x 2))
-	   ,(bib-new-block
-	     (bib-new-sentence
-	      `(,(if (bib-empty? x "editor")
-		     (bib-format-field x "organization")
-		     (bib-format-editor x))
-		,(bib-format-field x "title")
-		,(bib-format-volume-or-number x)
-		,(if (bib-empty? x "editor")
-		     ""
-		     (bib-format-field x "organization"))
-		,(bib-format-field x "publisher")
-		,(bib-format-field x "address")
-		,(bib-format-field x "year")
-		,(bib-format-note x))))))
-
-(tm-define (bib-format-techreport n x)
-  (:mode bib-elsart-num?)
-  `(concat ,(bib-format-bibitem n x)
-	   ,(bib-label (list-ref x 2))
-	   ,(bib-new-block
-	     (bib-new-sentence
-	      `(,(bib-format-author x)
-		,(bib-format-field-Locase x "title")
-		,(bib-format-tr-number x)
-		,(bib-format-field x "institution")
-		,(bib-format-field x "address")
-		(concat ,(if (bib-empty? x "note")
-			     ""
-			     `(concat ,(bib-format-note x) " "))
-			"(" ,(bib-format-date x) ")"))))))
-
-(tm-define (bib-format-unpublished n x)
-  (:mode bib-elsart-num?)
-  `(concat ,(bib-format-bibitem n x)
-	   ,(bib-label (list-ref x 2))
-	   :promptrepl
-           ,(bib-new-block
-	     (bib-new-sentence
-	      `(,(bib-format-author x)
-		,(bib-format-field-Locase x "title")
-		(concat ,(if (bib-empty? x "note")
-			     ""
-			     `(concat ,(bib-format-note x) " "))
-			"(" ,(bib-format-date x) ")"))))))
diff --git a/TeXmacs/plugins/latex/progs/bibtex/gbt7714-2015-author-year.scm b/TeXmacs/plugins/latex/progs/bibtex/gbt7714-2015-author-year.scm
deleted file mode 100644
index c8d2dd7f25..0000000000
--- a/TeXmacs/plugins/latex/progs/bibtex/gbt7714-2015-author-year.scm
+++ /dev/null
@@ -1,1071 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : gbt7714-2015-author-year.scm
-;; DESCRIPTION : GBT 7714-2015-author-year style for BibTeX files
-;; COPYRIGHT   : (C) 2026 Yuki Lu
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (bibtex gbt7714-2015-author-year)
-  (:use (bibtex bib-utils) (bibtex plain)))
-
-(bib-define-style "gbt7714-2015-author-year" "gbt7714-2015-author-year")
-
-;; 哈希表用于存储年份后缀
-(define gbt-year-suffix-table #f)
-(define gbt-author-year-count-table #f)
-
-;; 安全字符串转换：确保值转换为字符串，如果为#f则返回空字符串
-(define (safe-tm->string x)
-  (cond
-    ((string? x) x)
-    ((not x) "")
-    (else (let ((result (tm->string x)))
-            (if result result "")))))
-
-;; 获取作者键字符串（用于生成哈希表键）
-(define (gbt-get-author-key-string x)
-  (let* ((field-info (gbt-get-author-field x))
-         (field-type (car field-info))
-         (field-list (cdr field-info))
-         (has-author (not (equal? field-type 'empty)))
-         (chinese? (if has-author (authors-contain-chinese? field-list) #f)))
-    (if has-author
-        (let* ((n (length field-list))
-               (author-count (- n 1)))
-          ;; 辅助函数：提取作者姓氏（英文）或完整姓名（中文）
-          (define (get-author-key i)
-            (let ((author (list-ref field-list i)))
-              (if chinese?
-                  ;; 中文：使用bib-format-name获取完整姓名
-                  (let ((formatted-name (bib-format-name author)))
-                    (cond
-                      ((string? formatted-name) formatted-name)
-                      ((not formatted-name) "")
-                      (else (safe-tm->string formatted-name))))
-                  ;; 英文：只提取姓氏
-                  (let ((last-name-raw (list-ref author 3)))
-                    (if (bib-null? last-name-raw)
-                        ""
-                        (let ((last-name (bib-purify last-name-raw)))
-                          (cond
-                            ((string? last-name) last-name)
-                            ((not last-name) "")
-                            (else (safe-tm->string last-name)))))))))
-          (cond
-            ;; 作者数 ≥ 3：显示第一位 + et al/等
-            ((>= author-count 3)
-             (let ((first (get-author-key 1)))
-               (if chinese?
-                   (string-append first "<#7b49>")
-                   (string-append first " et al."))))
-            ;; 作者数 = 2：显示两位，用"and"或"和"连接
-            ((= author-count 2)
-             (let ((first (get-author-key 1))
-                   (second (get-author-key 2)))
-               (if chinese?
-                   (string-append first "<#548C>" second)
-                   (string-append first " & " second))))
-            ;; 作者数 = 1：显示一位
-            ((= author-count 1)
-             (get-author-key 1))
-            ;; 其他情况
-            (else "")))
-        "")))
-
-;; 预处理函数：计算同一年同一作者文献的年份后缀
-(tm-define (bib-preprocessing t)
-  (:mode bib-gbt7714-2015-author-year?)
-  ;; 初始化哈希表
-  (set! gbt-year-suffix-table (s7-make-hash-table 100))
-  (set! gbt-author-year-count-table (s7-make-hash-table 100))
-  ;; 第一遍：统计每个作者-年份组合的文献数量（所有条目）
-  (for-each (lambda (entry)
-              (when (func? entry 'bib-entry)
-                (let* ((author-short (gbt-get-author-key-string entry))
-                       (year-raw (bib-field entry "year"))
-                       (year-expr (cond ((bib-null? year-raw) "?")
-                                        ((string? year-raw) year-raw)
-                                        ((not year-raw) "?")
-                                        (else (safe-tm->string year-raw))))
-                       (year (cond ((string? year-expr) year-expr)
-                                   ((not year-expr) "?")
-                                   (else (safe-tm->string year-expr))))
-                       (author-year-key (string-append author-short ":" year)))
-                  (ahash-set! gbt-author-year-count-table
-                             author-year-key
-                             (+ 1 (or (ahash-ref gbt-author-year-count-table author-year-key) 0))))))
-            t)
-  ;; 第二遍：按排序顺序分配后缀
-  (let ((sorted-entries (bib-sorted-entries t)))
-    (for-each (lambda (entry)
-                (when (func? entry 'bib-entry)
-                  (let* ((key (list-ref entry 2))
-                         (author-short (gbt-get-author-key-string entry))
-                         (year-raw (bib-field entry "year"))
-                         (year-expr (cond ((bib-null? year-raw) "?")
-                                          ((string? year-raw) year-raw)
-                                          ((not year-raw) "?")
-                                          (else (safe-tm->string year-raw))))
-                         (year (cond ((string? year-expr) year-expr)
-                                     ((not year-expr) "?")
-                                     (else (safe-tm->string year-expr))))
-                         (author-year-key (string-append author-short ":" year))
-                         (count (ahash-ref gbt-author-year-count-table author-year-key)))
-                    (if (> count 1)
-                        ;; 需要后缀：分配a, b, c...
-                        ;; 使用哈希表记录已分配的后缀索引（按作者-年份组合）
-                        (let* ((suffix-index-key (string-append author-year-key ":index"))
-                               (next-index (or (ahash-ref gbt-year-suffix-table suffix-index-key) 0))
-                               (suffix-char (integer->char (+ 97 next-index))) ; 97 = 'a'
-                               (suffix (string suffix-char)))
-                          (ahash-set! gbt-year-suffix-table key suffix)
-                          (ahash-set! gbt-year-suffix-table suffix-index-key (+ next-index 1)))
-                        ;; 单一文献，无后缀
-                        (ahash-set! gbt-year-suffix-table key "")))))
-              sorted-entries)))
-
-;; 重写条目格式函数以支持所有文献类型
-(tm-define (bib-format-entry n x)
-  (:mode bib-gbt7714-2015-author-year?)
-  (if (and (list? x) (func? x 'bib-entry)
-           (= (length x) 4) (func? (list-ref x 3) 'document))
-      (with doctype (list-ref x 1)
-        (gbt-remove-keepcase
-         (cond
-           ((equal? doctype "article") (bib-format-article n x))
-           ((equal? doctype "book") (bib-format-book n x))
-           ((equal? doctype "booklet") (bib-format-booklet n x))
-           ((equal? doctype "inbook") (bib-format-inbook n x))
-           ((equal? doctype "incollection") (bib-format-incollection n x))
-           ((equal? doctype "inproceedings") (bib-format-inproceedings n x))
-           ((equal? doctype "conference") (bib-format-inproceedings n x))
-           ((equal? doctype "manual") (bib-format-manual n x))
-           ((equal? doctype "mastersthesis") (bib-format-mastersthesis n x))
-           ((equal? doctype "misc") (bib-format-misc n x))
-           ((equal? doctype "phdthesis") (bib-format-phdthesis n x))
-           ((equal? doctype "proceedings") (bib-format-proceedings n x))
-           ((equal? doctype "techreport") (bib-format-techreport n x))
-           ((equal? doctype "unpublished") (bib-format-unpublished n x))
-           ;; GBT 7714-2015 新增类型
-           ((equal? doctype "standard") (bib-format-standard n x))
-           ((equal? doctype "database") (bib-format-database n x))
-           ((equal? doctype "software") (bib-format-software n x))
-           ((equal? doctype "program") (bib-format-program n x))
-           ((equal? doctype "archive") (bib-format-archive n x))
-           ((equal? doctype "map") (bib-format-map n x))
-           ((equal? doctype "dataset") (bib-format-dataset n x))
-           ((equal? doctype "electronic") (bib-format-electronic n x))
-           ((equal? doctype "online") (bib-format-online n x))
-           ((equal? doctype "newspaper") (bib-format-newspaper n x))
-           ((equal? doctype "collection") (bib-format-collection n x))
-           ((equal? doctype "patent") (bib-format-patent n x))
-           (else (bib-format-misc n x)))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; cite相关
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; 获取作者字段（优先使用author，如果没有则使用editor）
-(define (gbt-get-author-field x)
-  ;; editor和author同逻辑：优先使用author，没有author才使用editor
-  (let ((author-field (bib-field x "author"))
-        (editor-field (bib-field x "editor")))
-    (cond
-      ((not (or (bib-null? author-field) (nlist? author-field))) (cons 'author author-field))
-      ((not (or (bib-null? editor-field) (nlist? editor-field))) (cons 'editor editor-field))
-      (else (cons 'empty '())))))
-
-;; 为作者字符串添加后缀（如果是editor）
-(define (gbt-add-suffix author-str field-type chinese? count)
-  ;; editor和author同逻辑：都不加后缀
-  author-str)
-
-;; 获取作者字符串（用于natbib-triple的author字段 - 完整格式，用于参考文献表）
-(tm-define (gbt-get-author-string x)
-  (:mode bib-gbt7714-2015-author-year?)
-  (let* ((field-info (gbt-get-author-field x))
-         (field-type (car field-info))
-         (field-list (cdr field-info))
-         (has-author (not (equal? field-type 'empty)))
-         (chinese? (if has-author (authors-contain-chinese? field-list) #f)))
-    (if has-author
-        (let* ((n (length field-list))
-               (author-count (- n 1))
-               ;; 参考文献表阈值：GB/T 7714-2015规定：≤3人全部列出，≥4人写"前3人+等"
-               (max-authors 3)
-               (show-count (min author-count max-authors))
-               (has-more (> author-count max-authors))
-               ;; 分隔符：中文和英文都加空格
-               (separator (if chinese? ", " ", ")))
-          (cond
-            ((= author-count 1)
-             (let ((author-name (bib-format-name (list-ref field-list 1))))
-               (gbt-add-suffix author-name field-type chinese? 1)))
-            (else
-             (let* ((first (bib-format-name (list-ref field-list 1)))
-                    ;; 收集中间作者
-                    ;; 如果有更多作者（>3）：收集第2到第3个作者（共2个中间作者）
-                    ;; 如果没有更多作者（<=3）：收集第2到第author-count-1个作者
-                    (middle (let loop ((i 2) (result ""))
-                              (if (or (>= i n)
-                                      (if has-more
-                                          (> i max-authors)
-                                          (>= i author-count)))
-                                  result
-                                  (loop (+ i 1)
-                                        (if (equal? result "")
-                                            (bib-format-name (list-ref field-list i))
-                                            `(concat ,result ,separator ,(bib-format-name (list-ref field-list i))))))))
-                    (last-part (if has-more
-                                   (if chinese? "<#7b49>" "et al") ;;等
-                                   (if (>= author-count 2)
-                                       (bib-format-name (list-ref field-list (- n 1)))
-                                       "")))
-                    ;; 构建作者字符串
-                    (author-str (cond
-                                  ((and (equal? middle "") (equal? last-part "")) first)
-                                  ((equal? middle "") `(concat ,first ,separator ,last-part))
-                                  ((equal? last-part "") `(concat ,first ,separator ,middle))
-                                  (else `(concat ,first ,separator ,middle ,separator ,last-part)))))
-               (gbt-add-suffix author-str field-type chinese? author-count)))))
-        "")))
-
-;; 获取短作者字符串（用于natbib-triple的author*字段 - 引用标签格式）
-(tm-define (gbt-get-author*-string x)
-  (:mode bib-gbt7714-2015-author-year?)
-  (let* ((field-info (gbt-get-author-field x))
-         (field-type (car field-info))
-         (field-list (cdr field-info))
-         (has-author (not (equal? field-type 'empty)))
-         (chinese? (if has-author (authors-contain-chinese? field-list) #f)))
-    (if has-author
-        (let* ((n (length field-list))
-               (author-count (- n 1)))
-          ;; 辅助函数：提取作者姓氏（英文）或完整姓名（中文）
-          (define (get-author-display i)
-            (let ((author (list-ref field-list i)))
-              (if chinese?
-                  (bib-format-name author)  ;; 中文：完整姓名
-                  ;; 英文：只提取姓氏，不大写
-                  (let ((last-name-raw (list-ref author 3)))
-                    (if (bib-null? last-name-raw)
-                        ""
-                        (bib-purify last-name-raw))))))
-          (cond
-            ;; 作者数 ≥ 3：显示第一位 + et al/等
-            ((>= author-count 3)
-             (let ((first (get-author-display 1)))
-               (if chinese?
-                   (gbt-add-suffix `(concat ,first "<#7b49>") field-type chinese? author-count)
-                   (gbt-add-suffix `(concat ,first " et al.") field-type chinese? author-count))))
-            ;; 作者数 = 2：显示两位，用"and"或"和"连接
-            ((= author-count 2)
-             (let ((first (get-author-display 1))
-                   (second (get-author-display 2)))
-               (if chinese?
-                   (gbt-add-suffix `(concat ,first "<#548C>" ,second) field-type chinese? author-count)
-                   (gbt-add-suffix `(concat ,first " & " ,second) field-type chinese? author-count))))
-            ;; 作者数 = 1：显示一位
-            ((= author-count 1)
-             (gbt-add-suffix (get-author-display 1) field-type chinese? author-count))
-            ;; 其他情况（应该不会发生）
-            (else "")))
-        "")))
-
-;; 获取年份字符串（带后缀）
-(tm-define (gbt-get-year-string x)
-  (:mode bib-gbt7714-2015-author-year?)
-  (let* ((key (list-ref x 2))
-         (y (bib-field x "year"))
-         (year-base-expr (cond ((bib-null? y) "?")
-                               ((string? y) y)
-                               ((not y) "?")
-                               (else (safe-tm->string y))))
-         (year-base (cond ((string? year-base-expr) year-base-expr)
-                          ((not year-base-expr) "?")
-                          (else (safe-tm->string year-base-expr))))
-         (suffix (if gbt-year-suffix-table
-                     (or (ahash-ref gbt-year-suffix-table key) "")
-                     "")))
-    (if (equal? suffix "")
-        year-base
-        (string-append year-base suffix))))
-
-;; 标签格式
-(tm-define (bib-format-bibitem n x)
-  (:mode bib-gbt7714-2015-author-year?)
-  ;; 返回作者(年份)格式用于cite-author-year包
-  (let ((author-str (gbt-get-author*-string x))
-        (year-str (gbt-get-year-string x)))
-    `(bibitem* (natbib-triple ,(gbt-get-author-string x)
-                              ,author-str
-                              ,year-str))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; 辅助函数
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; 检查是否有URL/DOI/urldate
-(tm-define (gbt-has-url-doi? x)
-  (:mode bib-gbt7714-2015-author-year?)
-  (let* ((url (bib-field x "url"))
-         (doi (bib-field x "doi"))
-         (urldate (bib-field x "urldate")))
-    (or (not (bib-null? url)) (not (bib-null? doi)) (not (bib-null? urldate)))))
-
-;; 智能句子函数：如果有URL/DOI/urldate则不添加句点，否则添加句点
-(tm-define (gbt-new-smart-sentence x ref)
-  (:mode bib-gbt7714-2015-author-year?)
-  (if (gbt-has-url-doi? ref)
-      (bib-upcase-first (bib-new-list ", " x))
-      (bib-add-period (bib-upcase-first (bib-new-list ", " x)))))
-
-;; 智能块函数：包装智能句子，包含URL/DOI，不添加额外空格
-(tm-define (gbt-new-smart-block-with-url x ref)
-  (:mode bib-gbt7714-2015-author-year?)
-  (if (bib-null? x) ""
-      `(concat ,(gbt-new-smart-sentence x ref)
-               ,(bib-new-case-preserved-block (bib-format-url-doi ref)))))
-
-;; 将URL里rsub表达式转换回下划线：将(rsub "x")转换为_x
-(define (convert-rsub-to-underscore expr)
-  (cond
-    ((and (list? expr) (= (length expr) 2) (equal? (car expr) 'rsub))
-     (let ((text (cadr expr)))
-       (if (string? text)
-           (string-append "_" text)
-           (string-append "_" (safe-tm->string text)))))
-    ((and (list? expr) (>= (length expr) 1) (equal? (car expr) 'concat))
-     `(concat ,@(map convert-rsub-to-underscore (cdr expr))))
-    ((list? expr)
-     (map convert-rsub-to-underscore expr))
-    ((string? expr) expr)
-    (else expr)))
-
-
-;; 通用版本格式化函数
-(tm-define (gbt-format-edition x chinese?)
-  (:mode bib-gbt7714-2015-author-year?)
-  (let ((edition-field (bib-field x "edition")))
-    (if (or (bib-null? edition-field) (equal? edition-field ""))
-        ""
-        (if chinese?
-            `(concat "<#7B2C>" ,edition-field "<#7248>")  ;; 第X版
-            `(concat ,edition-field " edition")))))
-
-;; 子字符串检查函数
-(define (substring? pat text)
-  (let ((pat-len (string-length pat))
-        (text-len (string-length text)))
-    (let outer ((i 0))
-      (cond
-        ((> (+ i pat-len) text-len) #f)
-        (else
-         (let inner ((j 0))
-           (cond
-             ((>= j pat-len) #t)
-             ((char=? (string-ref pat j)
-                      (string-ref text (+ i j)))
-              (inner (+ j 1)))
-             (else (outer (+ i 1))))))))))
-
-;; 检测字符串是否包含中文字符的辅助函数
-(define (contains-chinese? str)
-  (if (bib-null? str) #f
-      (let ((s (if (string? str) str "")))
-        ;; 检查是否包含中文 Unicode 字符的内部表示模式
-        (or (substring? "<#4" s)
-            (substring? "<#5" s)
-            (substring? "<#6" s)
-            (substring? "<#7" s)
-            (substring? "<#8" s)
-            (substring? "<#9" s)
-            ;; 检查实际的中文字符（基本中文范围 U+4E00-U+9FFF）
-            (let loop ((i 0) (len (string-length s)))
-              (if (>= i len) #f
-                  (let* ((c (string-ref s i))
-                         (code (char->integer c)))
-                    (if (and (>= code #x4e00) (<= code #x9fff))
-                        #t
-                        (loop (+ i 1) len)))))))))
-
-;; 检测作者列表是否包含中文作者
-(define (authors-contain-chinese? a)
-  (if (or (bib-null? a) (nlist? a)) #f
-      (let loop ((i 1) (n (length a)))
-        (if (>= i n) #f
-            (let* ((author-raw (list-ref a i))
-                   (author (gbt-remove-keepcase author-raw))
-                   ;; 将作者的所有字符串部分连接成一个字符串，然后检查是否包含中文
-                   (author-str (cond
-                                 ((string? author) author)
-                                 ((list? author)
-                                  (let part-loop ((j 1) (m (length author)) (result ""))
-                                    (if (>= j m) result
-                                        (let ((part (list-ref author j)))
-                                          (part-loop (+ j 1) m
-                                                     (if (string? part)
-                                                         (string-append result part)
-                                                         result))))))
-                                 (else ""))))
-              (if (contains-chinese? author-str)
-                  #t
-                  (loop (+ i 1) n)))))))
-
-;; 移除keepcase标签的辅助函数
-(define (gbt-remove-keepcase x)
-  (cond
-    ((list? x)
-     (if (not (null? x))
-         (if (equal? (car x) 'keepcase)
-             (gbt-remove-keepcase (cadr x))
-             (cons (car x) (map gbt-remove-keepcase (cdr x))))
-         '()))
-    ((string? x) x)
-    (else x)))
-
-;; 作者列表格式
-(tm-define (bib-format-names a)
-  (:mode bib-gbt7714-2015-author-year?)
-  (if (or (bib-null? a) (nlist? a))
-      ""
-      (let* ((n (length a))
-             (chinese? (authors-contain-chinese? a))
-             ;; GBT 7714-2015: 最多显示3个作者
-             (max-authors 3)
-             (author-count (- n 1))
-             (show-count (min author-count max-authors))
-             ;; 逗号分隔符：中文和英文都加空格
-             (comma-sep (if chinese? ", " ", ")))
-        (cond
-          ((equal? author-count 1)
-           (bib-format-name (list-ref a 1)))
-          (else
-           (let* ((first (bib-format-name (list-ref a 1)))
-                  (has-more (> author-count max-authors))
-                  ;; 收集中间作者
-                  ;; 如果有更多作者（>3）：收集第2到第3个作者（共2个中间作者）
-                  ;; 如果没有更多作者（<=3）：收集第2到第author-count-1个作者
-                  (middle (let loop ((i 2) (result ""))
-                            (if (or (>= i n)
-                                    (if has-more
-                                        (> i max-authors)
-                                        (>= i author-count)))
-                                result
-                                (loop (+ i 1)
-                                      (if (equal? result "")
-                                          (bib-format-name (list-ref a i))
-                                          `(concat ,result ,comma-sep ,(bib-format-name (list-ref a i))))))))
-                  (last-part (if has-more
-                                 (if chinese? "<#7b49>" "et al") ;;等
-                                 (if (>= author-count 2)
-                                     (bib-format-name (list-ref a (- n 1)))
-                                     "")))
-                  ;; 分隔符：无论是否有更多作者，都使用逗号分隔符
-                  ;; 中文：作者1,作者2,作者3,等
-                  ;; 英文：Author1, Author2, Author3, et al
-                  (separator comma-sep))
-             (cond
-               ((and (equal? middle "") (equal? last-part "")) first)
-               ((equal? middle "") `(concat ,first ,separator ,last-part))
-               ((equal? last-part "") `(concat ,first ,comma-sep ,middle))
-               (else `(concat ,first ,comma-sep ,middle ,separator ,last-part)))))))))
-
-;; 编者格式
-(tm-define (bib-format-editor x)
-  (:mode bib-gbt7714-2015-author-year?)
-  ;; 格式化编者字段，添加 ed. 或 eds. 后缀（中文为“编”或“主编”）
-  (let* ((e (bib-field x "editor"))
-         (chinese? (if (or (bib-null? e) (nlist? e)) #f (authors-contain-chinese? e))))
-    (if (or (bib-null? e) (nlist? e))
-        ""
-        (let* ((names (bib-format-names e))
-               (count (- (length e) 1)))
-          (if chinese?
-              (if (= count 1)
-                  `(concat ,names ",<#7F16>") ;;编
-                  `(concat ,names ",<#4E3B><#7F16>")) ;;主编
-              (if (= count 1)
-                  `(concat ,names ", ed.")
-                  `(concat ,names ", eds.")))))))
-
-;; 文献类型标识符函数
-(tm-define (bib-document-type-identifier x type)
-  (:mode bib-gbt7714-2015-author-year?)
-  ;; 根据文献类型和是否有在线访问信息返回标识符
-  ;; 优先使用note字段，如果note字段包含标识符
-  ;; 否则检查是否有url或doi字段来判断是否为在线文献
-  (let* ((note (bib-field x "note"))
-         (has-url (not (bib-null? (bib-field x "url"))))
-         (has-doi (not (bib-null? (bib-field x "doi"))))
-         (online (or has-url has-doi)))
-    (cond
-      ((and (not (bib-null? note)) (not (equal? note ""))) note)   ;; 优先使用note字段
-      ((equal? type "article") (if online "[J/OL]" "[J]"))         ;; 期刊
-      ((equal? type "book") (if online "[M/OL]" "[M]"))            ;; 普通图书
-      ((equal? type "inbook") (if online "[M/OL]" "[M]"))          ;; 析出图书
-      ((equal? type "inproceedings") (if online "[C/OL]" "[C]"))   ;; 会议录
-      ((equal? type "proceedings") (if online "[C/OL]" "[C]"))     ;; 会议录
-      ((equal? type "phdthesis") (if online "[D/OL]" "[D]"))       ;; 学位论文-博士
-      ((equal? type "mastersthesis") (if online "[D/OL]" "[D]"))   ;; 学位论文-硕士
-      ((equal? type "techreport") (if online "[R/OL]" "[R]"))      ;; 报告
-      ((equal? type "collection") (if online "[G/OL]" "[G]"))      ;; 汇编
-      ((equal? type "incollection") (if online "[G/OL]" "[G]"))    ;; 析出汇编
-      ((equal? type "manual") (if online "[M/OL]" "[M]"))          ;; 手册/说明书
-      ((equal? type "standard") (if online "[S/OL]" "[S]"))        ;; 标准
-      ((equal? type "patent") (if online "[P/OL]" "[P]"))          ;; 专利
-      ((equal? type "database") (if online "[DB/OL]" "[DB]"))      ;; 数据库
-      ((equal? type "software") (if online "[CP/OL]" "[CP]"))      ;; 计算机程序
-      ((equal? type "program") (if online "[CP/OL]" "[CP]"))       ;; 计算机程序
-      ((equal? type "online") (if online "[EB/OL]" "[EB]"))        ;; 电子公告
-      ((equal? type "electronic") (if online "[EB/OL]" "[EB]"))    ;; 电子公告
-      ((equal? type "archive") (if online "[A/OL]" "[A]"))         ;; 档案
-      ((equal? type "map") (if online "[CM/OL]" "[CM]"))           ;; 舆图
-      ((equal? type "dataset") (if online "[DS/OL]" "[DS]"))       ;; 数据集
-      ((equal? type "newspaper") (if online "[N/OL]" "[N]"))       ;; 报纸
-      ((equal? type "misc") (if online "[Z/OL]" "[Z]"))            ;; 其他
-      (else ""))))
-
-;; 地址:机构格式
-(tm-define (bib-format-address-institution x)
-  (:mode bib-gbt7714-2015-author-year?)
-  (let* ((addr (cond
-                 ((not (bib-empty? x "address")) (bib-field x "address"))
-                 ((not (bib-empty? x "location")) (bib-field x "location"))
-                 (else "")))
-         (inst-field (cond
-                       ((not (bib-empty? x "school")) (bib-field x "school"))
-                       ((not (bib-empty? x "organization")) (bib-field x "organization"))
-                       ((not (bib-empty? x "publisher")) (bib-field x "publisher"))
-                       ((not (bib-empty? x "institution")) (bib-field x "institution"))
-                       (else "")))
-         (inst-val (if (or (bib-null? inst-field) (equal? inst-field "")) "" inst-field)))
-    (cond
-      ((and (not (equal? addr "")) (not (equal? inst-val "")))
-       `(concat ,addr ": " ,inst-val))
-      ((not (equal? addr "")) addr)
-      ((not (equal? inst-val "")) inst-val)
-      (else ""))))
-
-;; 作者姓名格式
-(tm-define (bib-format-name x)
-  (:mode bib-gbt7714-2015-author-year?)
-  ;; 西文作者：姓在前（全大写），名缩写（如 "YU H B"）
-  ;; 中文作者：姓在前，名在后（全称）
-  ;; 使用双层花括号的机构名：不进行格式化处理
-  (let* ((first-name-raw (if (bib-null? (list-ref x 1)) "" (list-ref x 1)))
-         (last-name-raw (if (bib-null? (list-ref x 3)) "" (list-ref x 3)))
-         (chinese? (or (contains-chinese? first-name-raw) (contains-chinese? last-name-raw)))
-         (first-name (if chinese?
-                         first-name-raw  ;; 中文名不缩写
-                         (if (bib-null? first-name-raw) "" (bib-abbreviate first-name-raw "" " "))))
-         (last-name (if (bib-null? last-name-raw) "" (if chinese? (bib-purify last-name-raw) (string-upcase (bib-purify last-name-raw))))))
-    ;; 西文姓名处理：如果没有逗号分隔，保持原样
-    (if (not chinese?)
-        (cond
-          ((bib-null? last-name-raw) first-name-raw)   ;; 没有姓，返回名
-          ((bib-null? first-name-raw) last-name-raw)   ;; 没有名，返回姓
-          (else `(concat ,last-name " " ,first-name))) ;; 正常格式化
-        ;; 中文姓名处理：保持原有逻辑
-        (if (bib-null? last-name)
-            first-name
-            (if (bib-null? first-name)
-                last-name
-                `(concat ,last-name " " ,first-name))))))
-
-(tm-define (bib-format-date x)
-  (:mode bib-gbt7714-2015-author-year?)
-  ;; 日期处理函数，只处理date字段，加括号
-  (let ((d (bib-field x "date")))
-    (if (bib-null? d)
-        ""
-        `(concat "(" ,d ")"))))
-
-;; 书名格式
-(tm-define (bib-format-in-ed-booktitle x)
-  (:mode bib-gbt7714-2015-author-year?)
-  (let* ((b (bib-default-field x "booktitle"))
-         (e (bib-field x "editor")))
-    (if (bib-null? b)
-        ""
-        `(concat ,(bib-translate "in ") ,b))))
-
-;; 卷(期):页码格式
-(tm-define (bib-format-vol-num-pages x)
-  (:mode bib-gbt7714-2015-author-year?)
-  ;; GBT 7714-2015-author-year 格式：卷(期):页码（年份在标签中）
-  (let* ((v (bib-field x "volume"))
-         (n (bib-field x "number"))
-         (p (bib-field x "pages"))
-         (vol (if (bib-null? v) "" v))
-         (num (if (bib-null? n) "" `(concat "(" ,n ")")))
-         (pag (if (or (bib-null? p) (nlist? p))
-                  ""
-                  (cond
-                    ((equal? 1 (length p)) "")
-                    ((equal? 2 (length p)) `(concat ": " ,(list-ref p 1)))
-                    (else
-                     `(concat ": " ,(list-ref p 1)
-                              ,bib-range-symbol ,(list-ref p 2)))))))
-    `(concat ,vol ,num ,pag)))
-
-;; URL/DOI 信息格式
-(tm-define (bib-format-url-doi x)
-  (:mode bib-gbt7714-2015-author-year?)
-  (let* ((url-raw (bib-field x "url"))
-         (doi-raw (bib-field x "doi"))
-         (urldate (bib-field x "urldate"))
-         ;; 转换rsub表达式为下划线
-         (url (convert-rsub-to-underscore url-raw))
-         (doi (convert-rsub-to-underscore doi-raw))
-         (has-url (not (bib-null? url-raw)))
-         (has-doi (not (bib-null? doi-raw)))
-         (has-urldate (not (bib-null? urldate))))
-    (cond
-      (has-doi
-       ;; 有 DOI（优先使用，忽略 URL）：添加https://doi.org/前缀
-       (let ((doi-url `(concat "https://doi.org/" ,doi)))
-         (if has-urldate
-             `(concat "[" ,urldate "]. " ,doi-url)
-             doi-url)))
-      (has-url
-       ;; 只有 URL（没有 DOI）
-       (if has-urldate
-           `(concat "[" ,urldate "]. " ,url)
-           `(concat ,url)))
-      (else ""))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; 类型格式函数
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; 重写文章格式以添加文献类型标识符 [J]
-(tm-define (bib-format-article n x)
-  (:mode bib-gbt7714-2015-author-year?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-           `(concat ,(bib-format-field-preserve-case x "title")
-                    ,(bib-document-type-identifier x "article")))
-         ,(gbt-new-smart-block-with-url
-           `(,(bib-format-field x "journal")
-             ,(bib-format-vol-num-pages x)) x)))))
-
-;; 重写图书格式以添加文献类型标识符 [M]
-(tm-define (bib-format-book n x)
-  (:mode bib-gbt7714-2015-author-year?)
-  (let ((chinese? (authors-contain-chinese?
-                   (if (bib-empty? x "editor")
-                       (bib-field x "author")
-                       (bib-field x "editor")))))
-    `(concat
-       ,(bib-format-bibitem n x)
-       ,(bib-label (list-ref x 2))
-       ,(bib-new-list-spc
-         `(,(bib-new-block
-             (bib-new-sentence
-              `((concat ,(bib-format-field x "title")
-                        ,(bib-document-type-identifier x "book")))))
-           ,(bib-new-block
-             (let ((edition-str (gbt-format-edition x chinese?)))
-               (if (equal? edition-str "") "" edition-str)))
-           ,(gbt-new-smart-block-with-url
-             `(,(bib-format-number-series x)
-               ,(bib-format-address-institution x)) x))))))
-
-;; 重写析出图书格式以添加文献类型标识符 [M]
-(tm-define (bib-format-inbook n x)
-  (:mode bib-gbt7714-2015-author-year?)
-  (let ((chinese? (authors-contain-chinese?
-                   (if (bib-empty? x "editor")
-                       (bib-field x "author")
-                       (bib-field x "editor")))))
-    `(concat
-       ,(bib-format-bibitem n x)
-       ,(bib-label (list-ref x 2))
-       ,(bib-new-list-spc
-         `(,(bib-new-block
-             (let* ((bookauthor-field (bib-field x "bookauthor"))
-                    (editor-field (bib-field x "editor"))
-                    (booktitle-field (bib-field x "booktitle"))
-                    (edition-str (gbt-format-edition x chinese?))
-                    (has-bookauthor (not (bib-null? bookauthor-field)))
-                    (has-editor (not (bib-null? editor-field))))
-               (cond
-                 (has-bookauthor
-                  (let ((bookauthor-names (cond
-                                            ((bib-null? bookauthor-field) "")
-                                            ((nlist? bookauthor-field) bookauthor-field)
-                                            (else (bib-format-names bookauthor-field)))))
-                    `(concat ,(bib-format-field-preserve-case x "title")
-                             ,(bib-document-type-identifier x "book")
-                             "//"
-                             ,bookauthor-names ". "
-                             ,(bib-format-field-preserve-case x "booktitle")
-                             ,(if (equal? edition-str "") "" `(concat ": " ,edition-str))
-                             ".")))
-                 (has-editor
-                  (let ((editor-names (cond
-                                        ((bib-null? editor-field) "")
-                                        ((nlist? editor-field) editor-field)
-                                        (else (bib-format-names editor-field)))))
-                    `(concat ,(bib-format-field-preserve-case x "title")
-                             ,(bib-document-type-identifier x "book")
-                             "//"
-                             ,editor-names ". "
-                             ,(bib-format-field-preserve-case x "booktitle")
-                             ,(if (equal? edition-str "") "" `(concat ": " ,edition-str))
-                             ".")))
-                 (else
-                  `(concat ,(bib-format-field-preserve-case x "title")
-                           ,(bib-document-type-identifier x "book")
-                           "//. "
-                           ,(bib-format-field-preserve-case x "booktitle")
-                           ,(if (equal? edition-str "") "" `(concat ": " ,edition-str))
-                           ".")))))
-           ,(gbt-new-smart-block-with-url
-             `(,(bib-format-number-series x)
-               ,(bib-format-address-institution x)) x))))))
-
-;; 重写会议论文格式以添加文献类型标识符 [C]
-(tm-define (bib-format-inproceedings n x)
-  (:mode bib-gbt7714-2015-author-year?)
-  `(concat
-    ,(bib-format-bibitem n x)
-    ,(bib-label (list-ref x 2))
-    ,(bib-new-list-spc
-      `(,(bib-new-block
-              `(concat ,(bib-format-field-preserve-case x "title")
-                       ,(bib-document-type-identifier x "inproceedings")
-                       "//"
-                       ,(bib-format-field-preserve-case x "booktitle")
-                       "."))
-        ,(gbt-new-smart-block-with-url
-          `(,(bib-format-address-institution x)) x)))))
-
-;; 重写会议录格式以添加文献类型标识符 [C]
-(tm-define (bib-format-proceedings n x)
-  (:mode bib-gbt7714-2015-author-year?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-           `(concat ,(bib-format-field-preserve-case x "title")
-                    ,(bib-document-type-identifier x "proceedings")))
-         ,(gbt-new-smart-block-with-url
-               `(,(bib-format-address-institution x)) x)))))
-
-;; 重写手册格式以添加文献类型标识符 [M]
-(tm-define (bib-format-manual n x)
-  (:mode bib-gbt7714-2015-author-year?)
-  (let ((chinese? (authors-contain-chinese?
-                   (if (bib-empty? x "author")
-                       '()
-                       (bib-field x "author")))))
-    `(concat
-       ,(bib-format-bibitem n x)
-       ,(bib-label (list-ref x 2))
-       ,(bib-new-list-spc
-         `(,(bib-new-block
-             (let* ((title (bib-format-field-preserve-case x "title"))
-                    (number (bib-field x "number"))
-                    (edition-str (gbt-format-edition x chinese?))
-                    (identifier (bib-document-type-identifier x "manual"))
-                    (parts (list title)))
-               (if (not (equal? edition-str ""))
-                   (set! parts (append parts (list ": " edition-str))))
-               (if (not (bib-null? number))
-                   (set! parts (append parts (list ": " number))))
-               (set! parts (append parts (list identifier)))
-               (apply tmconcat parts)))
-           ,(gbt-new-smart-block-with-url
-               `(,(bib-format-address-institution x)) x))))))
-
-;; 重写博士论文格式以添加文献类型标识符 [D]
-(tm-define (bib-format-phdthesis n x)
-  (:mode bib-gbt7714-2015-author-year?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-           `(concat ,(bib-format-field-preserve-case x "title")
-                    ,(bib-document-type-identifier x "phdthesis")))
-         ,(gbt-new-smart-block-with-url
-               `(,(bib-format-address-institution x)) x)))))
-
-;; 重写硕士论文格式以添加文献类型标识符 [D]
-(tm-define (bib-format-mastersthesis n x)
-  (:mode bib-gbt7714-2015-author-year?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-           `(concat ,(bib-format-field-preserve-case x "title")
-                    ,(bib-document-type-identifier x "mastersthesis")))
-         ,(gbt-new-smart-block-with-url
-               `(,(bib-format-address-institution x)) x)))))
-
-;; 重写报告格式以添加文献类型标识符 [R]
-(tm-define (bib-format-techreport n x)
-  (:mode bib-gbt7714-2015-author-year?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-           `(concat ,(bib-format-field-preserve-case x "title")
-                    ,(bib-document-type-identifier x "techreport")))
-         ,(gbt-new-smart-block-with-url
-               `(,(let ((add-ins (bib-format-address-institution x))
-                        (number (bib-field x "number")))
-                    (if (bib-null? number)
-                        add-ins
-                        (if (equal? add-ins "")
-                            number
-                            `(concat ,add-ins ": " ,number))))) x)))))
-
-;; 重写杂项格式以添加文献类型标识符 [Z]
-(tm-define (bib-format-misc n x)
-  (:mode bib-gbt7714-2015-author-year?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-           `(concat ,(bib-format-field-preserve-case x "title")
-                    ,(bib-document-type-identifier x "misc")))
-         ,(gbt-new-smart-block-with-url '() x)))))
-
-;; 重写专利格式以添加文献类型标识符 [P]
-(tm-define (bib-format-patent n x)
-  (:mode bib-gbt7714-2015-author-year?)
-  `(concat
-       ,(bib-format-bibitem n x)
-       ,(bib-label (list-ref x 2))
-       ,(bib-new-list-spc
-         `(,(bib-new-block
-             (let* ((title (bib-format-field-preserve-case x "title"))
-                    (number (bib-field x "number"))
-                    (identifier (bib-document-type-identifier x "patent")))
-               (if (bib-null? number)
-                   `(concat ,title ,identifier)
-                   `(concat ,title ": " ,number ,identifier))))
-         ,(gbt-new-smart-block-with-url '() x)))))
-
-;; 重写标准格式以添加文献类型标识符 [S]
-(tm-define (bib-format-standard n x)
-  (:mode bib-gbt7714-2015-author-year?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-           (let* ((title (bib-format-field-preserve-case x "title"))
-                  (key (bib-field x "key"))
-                  (number (bib-field x "number"))
-                  (std-num (if (bib-null? key) number key))
-                  (identifier (bib-document-type-identifier x "standard")))
-             (if (bib-null? std-num)
-                 `(concat ,title ,identifier)
-                 `(concat ,std-num " " ,title ,identifier))))
-         ,(gbt-new-smart-block-with-url
-               `(,(bib-format-address-institution x)) x)))))
-
-;; 重写数据库格式以添加文献类型标识符 [DB]
-(tm-define (bib-format-database n x)
-  (:mode bib-gbt7714-2015-author-year?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-           `(concat ,(bib-format-field-preserve-case x "title")
-                    ,(bib-document-type-identifier x "database")))
-         ,(gbt-new-smart-block-with-url
-               `(,(bib-format-date x)) x)))))
-
-;; 重写电子公告格式以添加文献类型标识符 [EB]
-(tm-define (bib-format-electronic n x)
-  (:mode bib-gbt7714-2015-author-year?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-           `(concat ,(bib-format-field-preserve-case x "title")
-                    ,(bib-document-type-identifier x "electronic")))
-         ,(gbt-new-smart-block-with-url
-               `(,(bib-format-date x)) x)))))
-
-;; 重写在线网页格式以添加文献类型标识符 [EB]
-(tm-define (bib-format-online n x)
-  (:mode bib-gbt7714-2015-author-year?)
-  `(concat
-       ,(bib-format-bibitem n x)
-       ,(bib-label (list-ref x 2))
-       ,(bib-new-list-spc
-         `(,(bib-new-block
-             `(concat ,(bib-format-field-preserve-case x "title")
-                      ,(bib-document-type-identifier x "online")))
-         ,(gbt-new-smart-block-with-url
-               `(,(bib-format-date x)) x)))))
-
-;; 重写报纸格式以添加文献类型标识符 [N]
-(tm-define (bib-format-newspaper n x)
-  (:mode bib-gbt7714-2015-author-year?)
-  (let* ((p (bib-field x "pages"))
-         (pag (if (or (bib-null? p) (nlist? p))
-                  ""
-                  (cond
-                    ((equal? 1 (length p)) "")
-                    ((equal? 2 (length p)) (list-ref p 1))
-                    (else `(concat ,(list-ref p 1)
-                                   ,bib-range-symbol ,(list-ref p 2))))))
-         (journal-info (if (== pag "")
-                           (bib-format-field x "journal")
-                           `(concat ,(bib-format-field x "journal") ", " ,pag))))
-    `(concat
-       ,(bib-format-bibitem n x)
-       ,(bib-label (list-ref x 2))
-       ,(bib-new-list-spc
-         `(,(bib-new-block
-             `(concat ,(bib-format-field-preserve-case x "title")
-                      ,(bib-document-type-identifier x "newspaper")))
-           ,(gbt-new-smart-block-with-url
-                 `(,journal-info) x))))))
-
-;; 重写汇编格式以添加文献类型标识符 [G]
-(tm-define (bib-format-collection n x)
-  (:mode bib-gbt7714-2015-author-year?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-           `(concat ,(bib-format-field-preserve-case x "title")
-                    ,(bib-document-type-identifier x "collection")))
-         ,(gbt-new-smart-block-with-url
-               `(,(bib-format-address-institution x)) x)))))
-
-;; 重写析出汇编格式以添加文献类型标识符 [G]
-(tm-define (bib-format-incollection n x)
-  (:mode bib-gbt7714-2015-author-year?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-               (let* ((editor-field (bib-field x "editor"))
-                      (booktitle-field (bib-field x "booktitle"))
-                      (has-editor (not (bib-null? editor-field))))
-                 (if has-editor
-                     (let ((editor-names (cond
-                                           ((bib-null? editor-field) "")
-                                           ((nlist? editor-field) editor-field)
-                                           (else (bib-format-names editor-field)))))
-                       `(concat ,(bib-format-field-preserve-case x "title")
-                                ,(bib-document-type-identifier x "collection")
-                                "//"
-                                ,editor-names ". "
-                                ,(bib-format-field-preserve-case x "booktitle")
-                                "."))
-                     `(concat ,(bib-format-field-preserve-case x "title")
-                              ,(bib-document-type-identifier x "collection")
-                              "//"
-                              ,(bib-format-field-preserve-case x "booktitle")
-                              "."))))
-         ,(gbt-new-smart-block-with-url
-               `(,(bib-format-address-institution x)) x)))))
-
-;; 重写软件格式以添加文献类型标识符 [CP]
-(tm-define (bib-format-software n x)
-  (:mode bib-gbt7714-2015-author-year?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-           `(concat ,(bib-format-field-preserve-case x "title")
-                    ,(bib-document-type-identifier x "software")))
-         ,(gbt-new-smart-block-with-url
-               (let ((version (bib-field x "version")))
-                 (cond
-                   ((bib-null? version) '())
-                   (else `((concat "Version " ,version))))) x)))))
-
-;; 重写程序格式以添加文献类型标识符 [CP]
-(tm-define (bib-format-program n x)
-  (:mode bib-gbt7714-2015-author-year?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-           `(concat ,(bib-format-field-preserve-case x "title")
-                    ,(bib-document-type-identifier x "program")))
-         ,(gbt-new-smart-block-with-url
-               (let ((version (bib-field x "version")))
-                 (cond
-                   ((bib-null? version) '())
-                   (else `((concat "Version " ,version))))) x)))))
-
-;; 重写档案格式以添加文献类型标识符 [A]
-(tm-define (bib-format-archive n x)
-  (:mode bib-gbt7714-2015-author-year?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-           (let* ((title (bib-format-field-preserve-case x "title"))
-                  (number (bib-field x "number"))
-                  (identifier (bib-document-type-identifier x "archive")))
-             (if (bib-null? number)
-                 `(concat ,title ,identifier)
-                 `(concat ,title ": " ,number ,identifier))))
-         ,(gbt-new-smart-block-with-url
-               `(,(bib-format-address-institution x)) x)))))
-
-;; 重写舆图格式以添加文献类型标识符 [CM]
-(tm-define (bib-format-map n x)
-  (:mode bib-gbt7714-2015-author-year?)
-  (let ((chinese? (authors-contain-chinese?
-                   (if (bib-empty? x "editor")
-                       (bib-field x "author")
-                       (bib-field x "editor")))))
-    `(concat
-       ,(bib-format-bibitem n x)
-       ,(bib-label (list-ref x 2))
-       ,(bib-new-list-spc
-         `(,(bib-new-block
-             `(concat ,(bib-format-field-preserve-case x "title")
-                      ,(bib-document-type-identifier x "map")))
-           ,(bib-new-block
-             (let ((edition-str (gbt-format-edition x chinese?)))
-               (if (equal? edition-str "") "" edition-str)))
-           ,(gbt-new-smart-block-with-url
-                 `(,(bib-format-address-institution x)) x))))))
-
-;; 重写数据集格式以添加文献类型标识符 [DS]
-(tm-define (bib-format-dataset n x)
-  (:mode bib-gbt7714-2015-author-year?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-           `(concat ,(bib-format-field-preserve-case x "title")
-                    ,(bib-document-type-identifier x "dataset")))
-         ,(gbt-new-smart-block-with-url
-               `(,(bib-format-date x)) x)))))
diff --git a/TeXmacs/plugins/latex/progs/bibtex/gbt7714-2015.scm b/TeXmacs/plugins/latex/progs/bibtex/gbt7714-2015.scm
deleted file mode 100644
index 2dde47d56d..0000000000
--- a/TeXmacs/plugins/latex/progs/bibtex/gbt7714-2015.scm
+++ /dev/null
@@ -1,936 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : gbt7714-2015.scm
-;; DESCRIPTION : GBT 7714-2015 style for BibTeX files
-;; COPYRIGHT   : (C) 2025 Yuki Lu
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (bibtex gbt7714-2015)
-  (:use (bibtex bib-utils) (bibtex plain)))
-
-(bib-define-style "gbt7714-2015" "gbt7714-2015")
-
-(tm-define (bib-sorted-entries l)
-  (:mode bib-gbt7714-2015?)
-  (with is-entry? (lambda (x) (func? x 'bib-entry))
-    (list-filter l is-entry?)))
-
-;; 重写条目格式函数以支持所有文献类型
-(tm-define (bib-format-entry n x)
-  (:mode bib-gbt7714-2015?)
-  (if (and (list? x) (func? x 'bib-entry)
-           (= (length x) 4) (func? (list-ref x 3) 'document))
-      (with doctype (list-ref x 1)
-        (gbt-remove-keepcase
-         (cond
-           ((equal? doctype "article") (bib-format-article n x))
-           ((equal? doctype "book") (bib-format-book n x))
-           ((equal? doctype "booklet") (bib-format-booklet n x))
-           ((equal? doctype "inbook") (bib-format-inbook n x))
-           ((equal? doctype "incollection") (bib-format-incollection n x))
-           ((equal? doctype "inproceedings") (bib-format-inproceedings n x))
-           ((equal? doctype "conference") (bib-format-inproceedings n x))
-           ((equal? doctype "manual") (bib-format-manual n x))
-           ((equal? doctype "mastersthesis") (bib-format-mastersthesis n x))
-           ((equal? doctype "misc") (bib-format-misc n x))
-           ((equal? doctype "phdthesis") (bib-format-phdthesis n x))
-           ((equal? doctype "proceedings") (bib-format-proceedings n x))
-           ((equal? doctype "techreport") (bib-format-techreport n x))
-           ((equal? doctype "unpublished") (bib-format-unpublished n x))
-           ;; GBT 7714-2015 新增类型
-           ((equal? doctype "standard") (bib-format-standard n x))
-           ((equal? doctype "database") (bib-format-database n x))
-           ((equal? doctype "software") (bib-format-software n x))
-           ((equal? doctype "program") (bib-format-program n x))
-           ((equal? doctype "archive") (bib-format-archive n x))
-           ((equal? doctype "map") (bib-format-map n x))
-           ((equal? doctype "dataset") (bib-format-dataset n x))
-           ((equal? doctype "electronic") (bib-format-electronic n x))
-           ((equal? doctype "online") (bib-format-online n x))
-           ((equal? doctype "newspaper") (bib-format-newspaper n x))
-           ((equal? doctype "collection") (bib-format-collection n x))
-           ((equal? doctype "patent") (bib-format-patent n x))
-           (else (bib-format-misc n x)))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; 辅助函数
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; 将URL里rsub表达式转换回下划线：将(rsub "x")转换为_x
-(define (convert-rsub-to-underscore expr)
-  (cond
-    ((and (list? expr) (= (length expr) 2) (equal? (car expr) 'rsub))
-     (let ((text (cadr expr)))
-       (if (string? text)
-           (string-append "_" text)
-           (string-append "_" (tm->string text)))))
-    ((and (list? expr) (>= (length expr) 1) (equal? (car expr) 'concat))
-     `(concat ,@(map convert-rsub-to-underscore (cdr expr))))
-    ((list? expr)
-     (map convert-rsub-to-underscore expr))
-    ((string? expr) expr)
-    (else expr)))
-
-;; 检查是否有URL/DOI/urldate
-(tm-define (gbt-has-url-doi? x)
-  (:mode bib-gbt7714-2015?)
-  (let* ((url (bib-field x "url"))
-         (doi (bib-field x "doi"))
-         (urldate (bib-field x "urldate")))
-    (or (not (bib-null? url)) (not (bib-null? doi)) (not (bib-null? urldate)))))
-
-;; 智能句子函数：如果有URL/DOI/urldate则不添加句点，否则添加句点
-(tm-define (gbt-new-smart-sentence x ref)
-  (:mode bib-gbt7714-2015?)
-  (if (gbt-has-url-doi? ref)
-      (bib-upcase-first (bib-new-list ", " x))
-      (bib-add-period (bib-upcase-first (bib-new-list ", " x)))))
-
-;; 智能块函数：包装智能句子，包含URL/DOI，不添加额外空格
-(tm-define (gbt-new-smart-block-with-url x ref)
-  (:mode bib-gbt7714-2015?)
-  (if (bib-null? x) ""
-      `(concat ,(gbt-new-smart-sentence x ref)
-               ,(bib-new-case-preserved-block (bib-format-url-doi ref)))))
-
-;; 通用版本格式化函数
-(tm-define (gbt-format-edition x chinese?)
-  (:mode bib-gbt7714-2015?)
-  (let ((edition-field (bib-field x "edition")))
-    (if (or (bib-null? edition-field) (equal? edition-field ""))
-        ""
-        (if chinese?
-            `(concat "<#7B2C>" ,edition-field "<#7248>")  ;; 第X版
-            `(concat ,edition-field " edition")))))
-
-;; 子字符串检查函数
-(define (substring? pat text)
-  (let ((pat-len (string-length pat))
-        (text-len (string-length text)))
-    (let outer ((i 0))
-      (cond
-        ((> (+ i pat-len) text-len) #f)
-        (else
-         (let inner ((j 0))
-           (cond
-             ((>= j pat-len) #t)
-             ((char=? (string-ref pat j)
-                      (string-ref text (+ i j)))
-              (inner (+ j 1)))
-             (else (outer (+ i 1))))))))))
-
-;; 检测字符串是否包含中文字符的辅助函数
-(define (contains-chinese? str)
-  (if (bib-null? str) #f
-      (let ((s (if (string? str) str "")))
-        ;; 检查是否包含中文 Unicode 字符的内部表示模式
-        (or (substring? "<#4" s)
-            (substring? "<#5" s)
-            (substring? "<#6" s)
-            (substring? "<#7" s)
-            (substring? "<#8" s)
-            (substring? "<#9" s)
-            ;; 检查实际的中文字符（基本中文范围 U+4E00-U+9FFF）
-            (let loop ((i 0) (len (string-length s)))
-              (if (>= i len) #f
-                  (let* ((c (string-ref s i))
-                         (code (char->integer c)))
-                    (if (and (>= code #x4e00) (<= code #x9fff))
-                        #t
-                        (loop (+ i 1) len)))))))))
-
-;; 检测作者列表是否包含中文作者
-(define (authors-contain-chinese? a)
-  (if (or (bib-null? a) (nlist? a)) #f
-      (let loop ((i 1) (n (length a)))
-        (if (>= i n) #f
-            (let* ((author-raw (list-ref a i))
-                   (author (gbt-remove-keepcase author-raw))
-                   ;; 将作者的所有字符串部分连接成一个字符串，然后检查是否包含中文
-                   (author-str (cond
-                                 ((string? author) author)
-                                 ((list? author)
-                                  (let part-loop ((j 1) (m (length author)) (result ""))
-                                    (if (>= j m) result
-                                        (let ((part (list-ref author j)))
-                                          (part-loop (+ j 1) m
-                                                     (if (string? part)
-                                                         (string-append result part)
-                                                         result))))))
-                                 (else ""))))
-              (if (contains-chinese? author-str)
-                  #t
-                  (loop (+ i 1) n)))))))
-
-;; 移除keepcase标签的辅助函数
-(define (gbt-remove-keepcase x)
-  (cond
-    ((list? x)
-     (if (not (null? x))
-         (if (equal? (car x) 'keepcase)
-             (gbt-remove-keepcase (cadr x))
-             (cons (car x) (map gbt-remove-keepcase (cdr x))))
-         '()))
-    ((string? x) x)
-    (else x)))
-
-;; 作者列表格式
-(tm-define (bib-format-names a)
-  (:mode bib-gbt7714-2015?)
-  (if (or (bib-null? a) (nlist? a))
-      ""
-      (let* ((n (length a))
-             (chinese? (authors-contain-chinese? a))
-             ;; GBT 7714-2015: 最多显示3个作者
-             (max-authors 3)
-             (author-count (- n 1))
-             (show-count (min author-count max-authors))
-             ;; 逗号分隔符：中文和英文都加空格
-             (comma-sep (if chinese? ", " ", ")))
-        (cond
-          ((equal? author-count 1)
-           (bib-format-name (list-ref a 1)))
-          (else
-           (let* ((first (bib-format-name (list-ref a 1)))
-                  (has-more (> author-count max-authors))
-                  ;; 收集中间作者
-                  ;; 如果有更多作者（>3）：收集第2到第3个作者（共2个中间作者）
-                  ;; 如果没有更多作者（<=3）：收集第2到第author-count-1个作者
-                  (middle (let loop ((i 2) (result ""))
-                            (if (or (>= i n)
-                                    (if has-more
-                                        (> i max-authors)
-                                        (>= i author-count)))
-                                result
-                                (loop (+ i 1)
-                                      (if (equal? result "")
-                                          (bib-format-name (list-ref a i))
-                                          `(concat ,result ,comma-sep ,(bib-format-name (list-ref a i))))))))
-                  (last-part (if has-more
-                                 (if chinese? "<#7b49>" "et al") ;;等
-                                 (if (>= author-count 2)
-                                     (bib-format-name (list-ref a (- n 1)))
-                                     "")))
-                  ;; 分隔符：无论是否有更多作者，都使用逗号分隔符
-                  ;; 中文：作者1,作者2,作者3,等
-                  ;; 英文：Author1, Author2, Author3, et al
-                  (separator comma-sep))
-             (cond
-               ((and (equal? middle "") (equal? last-part "")) first)
-               ((equal? middle "") `(concat ,first ,separator ,last-part))
-               ((equal? last-part "") `(concat ,first ,comma-sep ,middle))
-               (else `(concat ,first ,comma-sep ,middle ,separator ,last-part)))))))))
-
-;; 编者格式
-(tm-define (bib-format-editor x)
-  (:mode bib-gbt7714-2015?)
-  ;; 格式化编者字段，添加 ed. 或 eds. 后缀（中文为“编”或“主编”）
-  (let* ((e (bib-field x "editor"))
-         (chinese? (if (or (bib-null? e) (nlist? e)) #f (authors-contain-chinese? e))))
-    (if (or (bib-null? e) (nlist? e))
-        ""
-        (let* ((names (bib-format-names e))
-               (count (- (length e) 1)))
-          (if chinese?
-              (if (= count 1)
-                  `(concat ,names ",<#7F16>") ;;编
-                  `(concat ,names ",<#4E3B><#7F16>")) ;;主编
-              (if (= count 1)
-                  `(concat ,names ", ed.")
-                  `(concat ,names ", eds.")))))))
-
-;; 文献类型标识符函数
-(tm-define (bib-document-type-identifier x type)
-  (:mode bib-gbt7714-2015?)
-  ;; 根据文献类型和是否有在线访问信息返回标识符
-  ;; 优先使用note字段，如果note字段包含标识符
-  ;; 否则检查是否有url或doi字段来判断是否为在线文献
-  (let* ((note (bib-field x "note"))
-         (has-url (not (bib-null? (bib-field x "url"))))
-         (has-doi (not (bib-null? (bib-field x "doi"))))
-         (online (or has-url has-doi)))
-    (cond
-      ((and (not (bib-null? note)) (not (equal? note ""))) note)   ;; 优先使用note字段
-      ((equal? type "article") (if online "[J/OL]" "[J]"))         ;; 期刊!
-      ((equal? type "book") (if online "[M/OL]" "[M]"))            ;; 普通图书!
-      ((equal? type "inbook") (if online "[M/OL]" "[M]"))          ;; 析出图书!
-      ((equal? type "inproceedings") (if online "[C/OL]" "[C]"))   ;; 会议录!
-      ((equal? type "proceedings") (if online "[C/OL]" "[C]"))     ;; 会议录!
-      ((equal? type "phdthesis") (if online "[D/OL]" "[D]"))       ;; 学位论文-博士!
-      ((equal? type "mastersthesis") (if online "[D/OL]" "[D]"))   ;; 学位论文-硕士!
-      ((equal? type "techreport") (if online "[R/OL]" "[R]"))      ;; 报告!
-      ((equal? type "collection") (if online "[G/OL]" "[G]"))      ;; 汇编!
-      ((equal? type "incollection") (if online "[G/OL]" "[G]"))    ;; 析出汇编!
-      ((equal? type "manual") (if online "[M/OL]" "[M]"))          ;; 手册/说明书!
-      ((equal? type "standard") (if online "[S/OL]" "[S]"))        ;; 标准!
-      ((equal? type "patent") (if online "[P/OL]" "[P]"))          ;; 专利!
-      ((equal? type "database") (if online "[DB/OL]" "[DB]"))      ;; 数据库!
-      ((equal? type "software") (if online "[CP/OL]" "[CP]"))      ;; 计算机程序!
-      ((equal? type "program") (if online "[CP/OL]" "[CP]"))       ;; 计算机程序!
-      ((equal? type "online") (if online "[EB/OL]" "[EB]"))        ;; 电子公告!
-      ((equal? type "electronic") (if online "[EB/OL]" "[EB]"))    ;; 电子公告!
-      ((equal? type "archive") (if online "[A/OL]" "[A]"))         ;; 档案!
-      ((equal? type "map") (if online "[CM/OL]" "[CM]"))           ;; 舆图!
-      ((equal? type "dataset") (if online "[DS/OL]" "[DS]"))       ;; 数据集!
-      ((equal? type "newspaper") (if online "[N/OL]" "[N]"))       ;; 报纸!
-      ((equal? type "misc") (if online "[Z/OL]" "[Z]"))            ;; 其他!
-      (else ""))))
-
-;; 地址:机构格式
-(tm-define (bib-format-address-institution x)
-  (:mode bib-gbt7714-2015?)
-  (let* ((addr (cond
-                 ((not (bib-empty? x "address")) (bib-field x "address"))
-                 ((not (bib-empty? x "location")) (bib-field x "location"))
-                 (else "")))
-         (inst-field (cond
-                       ((not (bib-empty? x "school")) (bib-field x "school"))
-                       ((not (bib-empty? x "organization")) (bib-field x "organization"))
-                       ((not (bib-empty? x "publisher")) (bib-field x "publisher"))
-                       ((not (bib-empty? x "institution")) (bib-field x "institution"))
-                       (else "")))
-         (inst-val (if (or (bib-null? inst-field) (equal? inst-field "")) "" inst-field)))
-    (cond
-      ((and (not (equal? addr "")) (not (equal? inst-val "")))
-       `(concat ,addr ": " ,inst-val))
-      ((not (equal? addr "")) addr)
-      ((not (equal? inst-val "")) inst-val)
-      (else ""))))
-
-;; 作者姓名格式
-(tm-define (bib-format-name x)
-  (:mode bib-gbt7714-2015?)
-  ;; 西文作者：姓在前（全大写），名缩写（如 "YU H B"）
-  ;; 中文作者：姓在前，名在后（全称）
-  ;; 使用双层花括号的机构名：不进行格式化处理
-  (let* ((first-name-raw (if (bib-null? (list-ref x 1)) "" (list-ref x 1)))
-         (last-name-raw (if (bib-null? (list-ref x 3)) "" (list-ref x 3)))
-         (chinese? (or (contains-chinese? first-name-raw) (contains-chinese? last-name-raw)))
-         (first-name (if chinese?
-                         first-name-raw  ;; 中文名不缩写
-                         (if (bib-null? first-name-raw) "" (bib-abbreviate first-name-raw "" " "))))
-         (last-name (if (bib-null? last-name-raw) "" (if chinese? (bib-purify last-name-raw) (string-upcase (bib-purify last-name-raw))))))
-    ;; 西文姓名处理：如果没有逗号分隔，保持原样
-    (if (not chinese?)
-        (cond
-          ((bib-null? last-name-raw) first-name-raw)   ;; 没有姓，返回名
-          ((bib-null? first-name-raw) last-name-raw)   ;; 没有名，返回姓
-          (else `(concat ,last-name " " ,first-name))) ;; 正常格式化
-        ;; 中文姓名处理：保持原有逻辑
-        (if (bib-null? last-name)
-            first-name
-            (if (bib-null? first-name)
-                last-name
-                `(concat ,last-name " " ,first-name))))))
-
-;; 日期格式
-(tm-define (bib-format-date x)
-  (:mode bib-gbt7714-2015?)
-  ;; 日期处理函数，支持date字段和year字段
-  ;; date字段加括号，year字段不加括号
-  ;; 如果有pages字段，则格式为"年份:页码"
-  (let* ((d (bib-field x "date"))
-         (y (bib-field x "year"))
-         (p (bib-field x "pages")))
-    (cond
-      ((not (bib-null? d)) `(concat "(" ,d ")"))
-      ((not (bib-null? y))
-       (let* ((year y)
-              (pag (if (or (bib-null? p) (nlist? p))
-                       ""
-                       (cond
-                         ((equal? 1 (length p)) "")
-                         ((equal? 2 (length p)) `(concat ": " ,(list-ref p 1)))
-                         (else
-                          `(concat ": " ,(list-ref p 1)
-                                   ,bib-range-symbol ,(list-ref p 2)))))))
-         (if (== pag "")
-             year
-             `(concat ,year ,pag))))
-      (else ""))))
-
-;; 书名格式
-(tm-define (bib-format-in-ed-booktitle x)
-  (:mode bib-gbt7714-2015?)
-  (let* ((b (bib-default-field x "booktitle"))
-         (e (bib-field x "editor")))
-    (if (bib-null? b)
-        ""
-        `(concat ,(bib-translate "in ") ,b))))
-
-;; 年份,卷(期):页码格式
-(tm-define (bib-format-vol-num-pages x)
-  (:mode bib-gbt7714-2015?)
-  ;; GBT 7714-2015 格式：年份,卷(期):页码
-  (let* ((y (bib-field x "year"))
-         (v (bib-field x "volume"))
-         (n (bib-field x "number"))
-         (p (bib-field x "pages"))
-         (year (if (bib-null? y) "" y))
-         (vol (if (bib-null? v) "" v))
-         (num (if (bib-null? n) "" `(concat "(" ,n ")")))
-         (pag (if (or (bib-null? p) (nlist? p))
-                  ""
-                  (cond
-                    ((equal? 1 (length p)) "")
-                    ((equal? 2 (length p)) `(concat ": " ,(list-ref p 1)))
-                    (else
-                     `(concat ": " ,(list-ref p 1)
-                              ,bib-range-symbol ,(list-ref p 2)))))))
-    (if (and (== vol "") (== num "") (== pag ""))
-        year
-        (if (bib-null? year)
-            `(concat ,vol ,num ,pag)
-            (if (not (== vol ""))
-                `(concat ,year ", " ,vol ,num ,pag)
-                `(concat ,year ,num ,pag))))))
-
-;; 数字标签格式
-(tm-define (bib-format-bibitem n x)
-  (:mode bib-gbt7714-2015?)
-  ;; 使用数字标签，如 [1], [2], ...
-  `(bibitem* ,(number->string n)))
-
-;; URL/DOI 信息格式
-(tm-define (bib-format-url-doi x)
-  (:mode bib-gbt7714-2015?)
-  (let* ((url-raw (bib-field x "url"))
-         (doi-raw (bib-field x "doi"))
-         (urldate (bib-field x "urldate"))
-         ;; 转换rsub表达式为下划线
-         (url (convert-rsub-to-underscore url-raw))
-         (doi (convert-rsub-to-underscore doi-raw))
-         (has-url (not (bib-null? url-raw)))
-         (has-doi (not (bib-null? doi-raw)))
-         (has-urldate (not (bib-null? urldate))))
-    (cond
-      (has-doi
-       ;; 有 DOI（优先使用，忽略 URL）：添加https://doi.org/前缀
-       (let ((doi-url `(concat "https://doi.org/" ,doi)))
-         (if has-urldate
-             `(concat "[" ,urldate "]. " ,doi-url)
-             doi-url)))
-      (has-url
-       ;; 只有 URL（没有 DOI）
-       (if has-urldate
-           `(concat "[" ,urldate "]. " ,url)
-           `(concat ,url)))
-      (else ""))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; 类型格式函数
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; 重写文章格式以添加文献类型标识符 [J]
-(tm-define (bib-format-article n x)
-  (:mode bib-gbt7714-2015?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block (bib-format-author x))
-         ,(bib-new-block
-           `(concat ,(bib-format-field-preserve-case x "title")
-                    ,(bib-document-type-identifier x "article")))
-         ,(gbt-new-smart-block-with-url
-           `(,(bib-format-field x "journal")
-             ,(bib-format-vol-num-pages x)) x)))))
-
-;; 重写图书格式以添加文献类型标识符 [M]
-(tm-define (bib-format-book n x)
-  (:mode bib-gbt7714-2015?)
-  (let ((chinese? (authors-contain-chinese?
-                   (if (bib-empty? x "editor")
-                       (bib-field x "author")
-                       (bib-field x "editor")))))
-    `(concat
-       ,(bib-format-bibitem n x)
-       ,(bib-label (list-ref x 2))
-       ,(bib-new-list-spc
-         `(,(bib-new-block
-             (if (bib-empty? x "editor")
-                 (bib-format-author x)
-                 (bib-format-editor x)))
-           ,(bib-new-block
-             (bib-new-sentence
-              `((concat ,(bib-format-field x "title")
-                        ,(bib-document-type-identifier x "book")))))
-           ,(bib-new-block
-             (let ((edition-str (gbt-format-edition x chinese?)))
-               (if (equal? edition-str "") "" edition-str)))
-           ,(gbt-new-smart-block-with-url
-             `(,(bib-format-number-series x)
-               ,(bib-format-address-institution x)
-               ,(bib-format-date x)) x))))))
-
-;; 重写析出图书格式以添加文献类型标识符 [M]
-(tm-define (bib-format-inbook n x)
-  (:mode bib-gbt7714-2015?)
-  (let ((chinese? (authors-contain-chinese?
-                   (if (bib-empty? x "editor")
-                       (bib-field x "author")
-                       (bib-field x "editor")))))
-    `(concat
-       ,(bib-format-bibitem n x)
-       ,(bib-label (list-ref x 2))
-       ,(bib-new-list-spc
-         `(,(bib-new-block
-             (if (bib-empty? x "editor")
-                 (bib-format-author x)
-                 (bib-format-editor x)))
-           ,(bib-new-block
-             (let* ((bookauthor-field (bib-field x "bookauthor"))
-                    (editor-field (bib-field x "editor"))
-                    (booktitle-field (bib-field x "booktitle"))
-                    (edition-str (gbt-format-edition x chinese?))
-                    (has-bookauthor (not (bib-null? bookauthor-field)))
-                    (has-editor (not (bib-null? editor-field))))
-               (cond
-                 (has-bookauthor
-                  (let ((bookauthor-names (cond
-                                            ((bib-null? bookauthor-field) "")
-                                            ((nlist? bookauthor-field) bookauthor-field)
-                                            (else (bib-format-names bookauthor-field)))))
-                    `(concat ,(bib-format-field-preserve-case x "title")
-                             ,(bib-document-type-identifier x "book")
-                             "//"
-                             ,bookauthor-names ". "
-                             ,(bib-format-field-preserve-case x "booktitle")
-                             ,(if (equal? edition-str "") "" `(concat ": " ,edition-str))
-                             ".")))
-                 (has-editor
-                  (let ((editor-names (cond
-                                        ((bib-null? editor-field) "")
-                                        ((nlist? editor-field) editor-field)
-                                        (else (bib-format-names editor-field)))))
-                    `(concat ,(bib-format-field-preserve-case x "title")
-                             ,(bib-document-type-identifier x "book")
-                             "//"
-                             ,editor-names ". "
-                             ,(bib-format-field-preserve-case x "booktitle")
-                             ,(if (equal? edition-str "") "" `(concat ": " ,edition-str))
-                             ".")))
-                 (else
-                  `(concat ,(bib-format-field-preserve-case x "title")
-                           ,(bib-document-type-identifier x "book")
-                           "//. "
-                           ,(bib-format-field-preserve-case x "booktitle")
-                           ,(if (equal? edition-str "") "" `(concat ": " ,edition-str))
-                           ".")))))
-           ,(gbt-new-smart-block-with-url
-             `(,(bib-format-number-series x)
-               ,(bib-format-address-institution x)
-               ,(bib-format-date x)) x))))))
-
-;; 重写会议论文格式以添加文献类型标识符 [C]
-(tm-define (bib-format-inproceedings n x)
-  (:mode bib-gbt7714-2015?)
-  `(concat
-    ,(bib-format-bibitem n x)
-    ,(bib-label (list-ref x 2))
-    ,(bib-new-list-spc
-      `(,(bib-new-block (bib-format-author x))
-        ,(bib-new-block
-              `(concat ,(bib-format-field-preserve-case x "title")
-                       ,(bib-document-type-identifier x "inproceedings")
-                       "//"
-                       ,(bib-format-field-preserve-case x "booktitle")
-                       "."))
-        ,(gbt-new-smart-block-with-url
-          `(,(bib-format-address-institution x)
-            ,(bib-format-date x)) x)))))
-
-;; 重写会议录格式以添加文献类型标识符 [C]
-(tm-define (bib-format-proceedings n x)
-  (:mode bib-gbt7714-2015?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block (bib-format-editor x))
-         ,(bib-new-block
-           `(concat ,(bib-format-field-preserve-case x "title")
-                    ,(bib-document-type-identifier x "proceedings")))
-         ,(gbt-new-smart-block-with-url
-               `(,(bib-format-address-institution x)
-                 ,(bib-format-date x)) x)))))
-
-;; 重写手册格式以添加文献类型标识符 [M]
-(tm-define (bib-format-manual n x)
-  (:mode bib-gbt7714-2015?)
-  (let ((chinese? (authors-contain-chinese?
-                   (if (bib-empty? x "author")
-                       '()
-                       (bib-field x "author")))))
-    `(concat
-       ,(bib-format-bibitem n x)
-       ,(bib-label (list-ref x 2))
-       ,(bib-new-list-spc
-         `(,(bib-new-block
-             (if (bib-empty? x "author")
-                 (bib-new-sentence `(,(bib-format-address-institution x)))
-                 (bib-format-author x)))
-           ,(bib-new-block
-             (let* ((title (bib-format-field-preserve-case x "title"))
-                    (number (bib-field x "number"))
-                    (edition-str (gbt-format-edition x chinese?))
-                    (identifier (bib-document-type-identifier x "manual"))
-                    (parts (list title)))
-               (if (not (equal? edition-str ""))
-                   (set! parts (append parts (list ": " edition-str))))
-               (if (not (bib-null? number))
-                   (set! parts (append parts (list ": " number))))
-               (set! parts (append parts (list identifier)))
-               (apply tmconcat parts)))
-           ,(gbt-new-smart-block-with-url
-               (if (bib-empty? x "author")
-                   (let ((address-institution (bib-format-address-institution x))
-                         (date (bib-format-date x)))
-                     (cond
-                       ((and (equal? address-institution "") (bib-null? date)) '())
-                       ((equal? address-institution "") `(,date))
-                       ((bib-null? date) `(,address-institution))
-                       (else `(,address-institution ,date))))
-                   `(,(bib-format-address-institution x)
-                     ,(bib-format-date x))) x))))))
-
-;; 重写博士论文格式以添加文献类型标识符 [D]
-(tm-define (bib-format-phdthesis n x)
-  (:mode bib-gbt7714-2015?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block (bib-format-author x))
-         ,(bib-new-block
-           `(concat ,(bib-format-field-preserve-case x "title")
-                    ,(bib-document-type-identifier x "phdthesis")))
-         ,(gbt-new-smart-block-with-url
-               `(,(if (bib-empty? x "type")
-                      (bib-format-field-Locase x "type"))
-                 ,(bib-format-address-institution x)
-                 ,(bib-format-date x)) x)))))
-
-;; 重写硕士论文格式以添加文献类型标识符 [D]
-(tm-define (bib-format-mastersthesis n x)
-  (:mode bib-gbt7714-2015?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block (bib-format-author x))
-         ,(bib-new-block
-           `(concat ,(bib-format-field-preserve-case x "title")
-                    ,(bib-document-type-identifier x "mastersthesis")))
-         ,(gbt-new-smart-block-with-url
-               `(,(if (bib-empty? x "type")
-                      (bib-format-field-Locase x "type"))
-                 ,(bib-format-address-institution x)
-                 ,(bib-format-date x)) x)))))
-
-;; 重写报告格式以添加文献类型标识符 [R]
-(tm-define (bib-format-techreport n x)
-  (:mode bib-gbt7714-2015?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block (bib-format-author x))
-         ,(bib-new-block
-           `(concat ,(bib-format-field-preserve-case x "title")
-                    ,(bib-document-type-identifier x "techreport")))
-         ,(gbt-new-smart-block-with-url
-               `(,(bib-format-address-institution x)
-                 ,(let ((date-str (bib-format-date x))
-                        (number (bib-field x "number")))
-                    (if (bib-null? number)
-                        date-str
-                        (if (equal? date-str "")
-                            number
-                            `(concat ,date-str ": " ,number))))) x)))))
-
-;; 重写杂项格式以添加文献类型标识符 [Z]
-(tm-define (bib-format-misc n x)
-  (:mode bib-gbt7714-2015?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block (bib-format-author x))
-         ,(bib-new-block
-           `(concat ,(bib-format-field-preserve-case x "title")
-                    ,(bib-document-type-identifier x "misc")))
-         ,(gbt-new-smart-block-with-url
-               `(,(bib-format-date x)) x)))))
-
-;; 重写专利格式以添加文献类型标识符 [P]
-(tm-define (bib-format-patent n x)
-  (:mode bib-gbt7714-2015?)
-  (let ((date-str (let ((d (bib-field x "date"))
-                        (y (bib-field x "year")))
-                    (cond
-                      ((not (bib-null? d)) d)
-                      ((not (bib-null? y)) y)
-                      (else "")))))
-    `(concat
-       ,(bib-format-bibitem n x)
-       ,(bib-label (list-ref x 2))
-       ,(bib-new-list-spc
-         `(,(bib-new-block (bib-format-author x))
-           ,(bib-new-block
-             (let* ((title (bib-format-field-preserve-case x "title"))
-                    (number (bib-field x "number"))
-                    (identifier (bib-document-type-identifier x "patent")))
-               (if (bib-null? number)
-                   `(concat ,title ,identifier)
-                   `(concat ,title ": " ,number ,identifier))))
-           ,(gbt-new-smart-block-with-url
-                 `(,date-str) x))))))
-
-;; 重写标准格式以添加文献类型标识符 [S]
-(tm-define (bib-format-standard n x)
-  (:mode bib-gbt7714-2015?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-           (let* ((title (bib-format-field-preserve-case x "title"))
-                  (key (bib-field x "key"))
-                  (number (bib-field x "number"))
-                  (std-num (if (bib-null? key) number key))
-                  (identifier (bib-document-type-identifier x "standard")))
-             (if (bib-null? std-num)
-                 `(concat ,title ,identifier)
-                 `(concat ,std-num " " ,title ,identifier))))
-         ,(gbt-new-smart-block-with-url
-               (let ((address-institution (bib-format-address-institution x))
-                     (date (bib-format-date x)))
-                 (cond
-                   ((and (equal? address-institution "") (bib-null? date)) '())
-                   ((equal? address-institution "") `(,date))
-                   ((bib-null? date) `(,address-institution))
-                   (else `(,address-institution ,date)))) x)))))
-
-;; 重写数据库格式以添加文献类型标识符 [DB]
-(tm-define (bib-format-database n x)
-  (:mode bib-gbt7714-2015?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block (bib-format-author x))
-         ,(bib-new-block
-           `(concat ,(bib-format-field-preserve-case x "title")
-                    ,(bib-document-type-identifier x "database")))
-         ,(gbt-new-smart-block-with-url
-               `(,(bib-format-date x)) x)))))
-
-;; 重写电子公告格式以添加文献类型标识符 [EB]
-(tm-define (bib-format-electronic n x)
-  (:mode bib-gbt7714-2015?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block (bib-format-author x))
-         ,(bib-new-block
-           `(concat ,(bib-format-field-preserve-case x "title")
-                    ,(bib-document-type-identifier x "electronic")))
-         ,(gbt-new-smart-block-with-url
-               `(,(bib-format-date x)) x)))))
-
-;; 重写在线网页格式以添加文献类型标识符 [EB]
-(tm-define (bib-format-online n x)
-  (:mode bib-gbt7714-2015?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block (bib-format-author x))
-         ,(bib-new-block
-           `(concat ,(bib-format-field-preserve-case x "title")
-                    ,(bib-document-type-identifier x "online")))
-         ,(gbt-new-smart-block-with-url
-               `(,(bib-format-date x)) x)))))
-
-;; 重写报纸格式以添加文献类型标识符 [N]
-(tm-define (bib-format-newspaper n x)
-  (:mode bib-gbt7714-2015?)
-  (let* ((date-str (let ((d (bib-field x "date"))
-                         (y (bib-field x "year")))
-                     (cond
-                       ((not (bib-null? d)) d)
-                       ((not (bib-null? y)) y)
-                       (else ""))))
-         (p (bib-field x "pages"))
-         (pag (if (or (bib-null? p) (nlist? p))
-                  ""
-                  (cond
-                    ((equal? 1 (length p)) "")
-                    ((equal? 2 (length p)) (list-ref p 1))
-                    (else `(concat ,(list-ref p 1)
-                                   ,bib-range-symbol ,(list-ref p 2))))))
-         (date-pages-str (if (== pag "")
-                             date-str
-                             `(concat ,date-str "(" ,pag ")"))))
-    `(concat
-       ,(bib-format-bibitem n x)
-       ,(bib-label (list-ref x 2))
-       ,(bib-new-list-spc
-         `(,(bib-new-block (bib-format-author x))
-           ,(bib-new-block
-             `(concat ,(bib-format-field-preserve-case x "title")
-                      ,(bib-document-type-identifier x "newspaper")))
-           ,(gbt-new-smart-block-with-url
-                 `(,(bib-format-field x "journal")
-                   ,date-pages-str) x))))))
-
-;; 重写汇编格式以添加文献类型标识符 [G]
-(tm-define (bib-format-collection n x)
-  (:mode bib-gbt7714-2015?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block (bib-format-editor x))
-         ,(bib-new-block
-           `(concat ,(bib-format-field-preserve-case x "title")
-                    ,(bib-document-type-identifier x "collection")))
-         ,(gbt-new-smart-block-with-url
-               `(,(bib-format-address-institution x)
-                 ,(bib-format-date x)) x)))))
-
-;; 重写析出汇编格式以添加文献类型标识符 [G]
-(tm-define (bib-format-incollection n x)
-  (:mode bib-gbt7714-2015?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-            (if (bib-empty? x "author")
-                (bib-format-editor x)
-                (bib-format-author x)))
-         ,(bib-new-block
-               (let* ((editor-field (bib-field x "editor"))
-                      (booktitle-field (bib-field x "booktitle"))
-                      (has-editor (not (bib-null? editor-field))))
-                 (if has-editor
-                     (let ((editor-names (cond
-                                           ((bib-null? editor-field) "")
-                                           ((nlist? editor-field) editor-field)
-                                           (else (bib-format-names editor-field)))))
-                       `(concat ,(bib-format-field-preserve-case x "title")
-                                ,(bib-document-type-identifier x "collection")
-                                "//"
-                                ,editor-names ". "
-                                ,(bib-format-field-preserve-case x "booktitle")
-                                "."))
-                     `(concat ,(bib-format-field-preserve-case x "title")
-                              ,(bib-document-type-identifier x "collection")
-                              "//"
-                              ,(bib-format-field-preserve-case x "booktitle")
-                              "."))))
-         ,(gbt-new-smart-block-with-url
-               `(,(bib-format-address-institution x)
-                 ,(bib-format-date x)) x)))))
-
-;; 重写软件格式以添加文献类型标识符 [CP]
-(tm-define (bib-format-software n x)
-  (:mode bib-gbt7714-2015?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block (bib-format-author x))
-         ,(bib-new-block
-           `(concat ,(bib-format-field-preserve-case x "title")
-                    ,(bib-document-type-identifier x "software")))
-         ,(gbt-new-smart-block-with-url
-               (let ((version (bib-field x "version"))
-                     (date (bib-format-date x)))
-                 (cond
-                   ((and (bib-null? version) (bib-null? date)) '())
-                   ((bib-null? version) `(,date))
-                   (else `((concat "Version " ,version) ,date)))) x)))))
-
-;; 重写程序格式以添加文献类型标识符 [CP]
-(tm-define (bib-format-program n x)
-  (:mode bib-gbt7714-2015?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block (bib-format-author x))
-         ,(bib-new-block
-           `(concat ,(bib-format-field-preserve-case x "title")
-                    ,(bib-document-type-identifier x "program")))
-         ,(gbt-new-smart-block-with-url
-               (let ((version (bib-field x "version"))
-                     (date (bib-format-date x)))
-                 (cond
-                   ((and (bib-null? version) (bib-null? date)) '())
-                   ((bib-null? version) `(,date))
-                   (else `((concat "Version " ,version) ,date)))) x)))))
-
-;; 重写档案格式以添加文献类型标识符 [A]
-(tm-define (bib-format-archive n x)
-  (:mode bib-gbt7714-2015?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block (bib-format-author x))
-         ,(bib-new-block
-           (let* ((title (bib-format-field-preserve-case x "title"))
-                  (number (bib-field x "number"))
-                  (identifier (bib-document-type-identifier x "archive")))
-             (if (bib-null? number)
-                 `(concat ,title ,identifier)
-                 `(concat ,title ": " ,number ,identifier))))
-         ,(gbt-new-smart-block-with-url
-               `(,(bib-format-address-institution x)
-                 ,(bib-format-date x)) x)))))
-
-;; 重写舆图格式以添加文献类型标识符 [CM]
-(tm-define (bib-format-map n x)
-  (:mode bib-gbt7714-2015?)
-  (let ((chinese? (authors-contain-chinese?
-                   (if (bib-empty? x "editor")
-                       (bib-field x "author")
-                       (bib-field x "editor")))))
-    `(concat
-       ,(bib-format-bibitem n x)
-       ,(bib-label (list-ref x 2))
-       ,(bib-new-list-spc
-         `(,(bib-new-block (bib-format-author x))
-           ,(bib-new-block
-             `(concat ,(bib-format-field-preserve-case x "title")
-                      ,(bib-document-type-identifier x "map")))
-           ,(bib-new-block
-             (let ((edition-str (gbt-format-edition x chinese?)))
-               (if (equal? edition-str "") "" edition-str)))
-           ,(gbt-new-smart-block-with-url
-                 `(,(bib-format-address-institution x)
-                   ,(bib-format-date x)) x))))))
-
-;; 重写数据集格式以添加文献类型标识符 [DS]
-(tm-define (bib-format-dataset n x)
-  (:mode bib-gbt7714-2015?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block (bib-format-author x))
-         ,(bib-new-block
-           `(concat ,(bib-format-field-preserve-case x "title")
-                    ,(bib-document-type-identifier x "dataset")))
-         ,(gbt-new-smart-block-with-url
-               `(,(bib-format-date x)) x)))))
diff --git a/TeXmacs/plugins/latex/progs/bibtex/ieeetr.scm b/TeXmacs/plugins/latex/progs/bibtex/ieeetr.scm
deleted file mode 100644
index 8c24c7ff20..0000000000
--- a/TeXmacs/plugins/latex/progs/bibtex/ieeetr.scm
+++ /dev/null
@@ -1,373 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : ieeetr.scm
-;; DESCRIPTION : ieeetr style for BibTeX files
-;; COPYRIGHT   : (C) 2010, 2015  David MICHEL, Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (bibtex ieeetr)
-  (:use (bibtex bib-utils) (bibtex plain)))
-
-(bib-define-style "ieeetr" "plain")
-
-(tm-define (bib-sorted-entries l)
-  (:mode bib-ieeetr?)
-	(with is-entry? (lambda (x) (func? x 'bib-entry))
-		(list-filter l is-entry?)))
-
-(tm-define (new-list-rec s x)
-  (:mode bib-ieeetr?)
-  (cond ((bib-null? x) "")
-        ((bib-null? (car x)) (new-list-rec s (cdr x)))
-        ((null? (cdr x)) (car x))
-        ((and (func? (car x) 'concat) (== (cAr (car x)) "''") (== s ", "))
-         `(concat ,@(cdr (cDr (car x))) ",'' " ,(new-list-rec s (cdr x))))
-        (else `(concat ,(car x) ,s ,(new-list-rec s (cdr x))))))
-
-(tm-define (bib-format-name x)
-  (:mode bib-ieeetr?)
-  (let* ((f (if (bib-null? (list-ref x 1)) ""
-		`(concat ,(bib-abbreviate (list-ref x 1) "." `(nbsp)) (nbsp))))
-	 (vv (if (bib-null? (list-ref x 2)) ""
-                 `(concat ,(list-ref x 2) (nbsp))))
-	 (ll (if (bib-null? (list-ref x 3)) ""
-                 (bib-purify (list-ref x 3))))
-	 (jj (if (bib-null? (list-ref x 4)) ""
-                 `(concat ", " ,(list-ref x 4)))))
-    `(concat ,f ,vv ,ll ,jj)))
-
-(tm-define (bib-last-name-sep a)
-  (:mode bib-ieeetr?)
-  (if (<= (length a) 3)
-      (bib-translate " and ")
-      (bib-translate ", and ")))
-
-(tm-define (bib-format-editor x)
-  (:mode bib-ieeetr?)
-  (with a (bib-field x "editor")
-    (if (or (bib-null? a) (nlist? a)) ""
-	(if (equal? (length a) 2)
-	    `(concat ,(bib-format-names a) ", ed.")
-	    `(concat ,(bib-format-names a) ", eds.")))))
-
-(tm-define (bib-format-bvolume x)
-  (:mode bib-ieeetr?)
-  (let* ((v (bib-field x "volume"))
-	 (s (bib-field x "series")))
-    (if (bib-null? v) ""
-	(let ((series (if (bib-null? s) ""
-			  `(concat ,(bib-translate " of ")
-				   (with "font-shape" "italic" ,s))))
-	      (sep (if (< (bib-text-length v) 3) `(nbsp) " ")))
-	  `(concat "vol." ,sep ,v ,series)))))
-
-(tm-define (bib-format-number-series x)
-  (:mode bib-ieeetr?)
-  (let* ((v (bib-field x "volume"))
-	 (n (bib-field x "number"))
-	 (s (bib-field x "series")))
-    (if (bib-null? v)
-	(if (bib-null? n)
-	    (if (bib-null? s) "" s)
-	    (let ((series (if (bib-null? s) ""
-			      `(concat ,(bib-translate " in ") ,s)))
-		  (sep (if (< (bib-text-length n) 3) `(nbsp) " ")))
-	      `(concat "no." ,sep ,n ,series)))
-	"")))
-
-(define (bib-format-edition x)
-  (with e (bib-field x "edition")
-    (if (bib-null? e) ""
-	`(concat ,e " ed."))))
-
-(tm-define (bib-format-in-ed-booktitle x)
-  (:mode bib-ieeetr?)
-  (let* ((b (bib-field x "booktitle"))
-	 (e (bib-field x "editor")))
-    (if (bib-null? b) ""
-	(if (bib-null? e)
-	    `(concat ,(bib-translate "in ") (with "font-shape" "italic" ,b))
-	    `(concat ,(bib-translate "in ") (with "font-shape" "italic" ,b)
-		     " (" ,(bib-format-editor x) ")")))))
-
-(define (bib-format-address-publisher x)
-  (let* ((a (bib-field x "address"))
-	 (p (bib-field x "publisher")))
-    (if (bib-null? a) p
-	(if (bib-null? p) a
-	    `(concat ,a ": " ,p)))))
-
-(tm-define (bib-format-pages x)
-  (:mode bib-ieeetr?)
-  (with p (bib-field x "pages")
-    (cond
-      ((or (bib-null? p) (nlist? p)) "")
-      ((== (length p) 1) "")
-      ((== (length p) 2) `(concat "p." (nbsp) ,(list-ref p 1)))
-      (else
-       `(concat "pp." (nbsp)
-                ,(list-ref p 1) ,bib-range-symbol ,(list-ref p 2))))))
-
-(tm-define (bib-format-article n x)
-  (:mode bib-ieeetr?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-           (bib-new-sentence
-            `(,(bib-format-author x)
-              (concat "``" ,(bib-format-field-Locase x "title") "''")
-              ,@(if (bib-empty? x "crossref")
-                    `(,(bib-emphasize (bib-format-field x "journal"))
-                      ,(if (bib-empty? x "volume") ""
-                           `(concat "vol." (nbsp) ,(bib-field x "volume")))
-                      ,(if (bib-empty? x "number") ""
-                           `(concat "no." (nbsp) ,(bib-field x "number")))
-                      ,(bib-format-pages x)
-                      ,(bib-format-date x))
-                    `((concat ,(bib-translate "in ")
-                              (cite ,(bib-field x "crossref")))
-                      ,(bib-format-pages x))))))
-         ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-book n x)
-  (:mode bib-ieeetr?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-	   (bib-new-sentence
-	    `(,(if (bib-empty? x "author") (bib-format-editor x) (bib-format-author x))
-	      ,(bib-emphasize (bib-format-field x "title"))
-	      ,(if (bib-empty? x "crossref") (bib-format-bvolume x) ""))))
-	 ,(bib-new-block
-	   (bib-new-sentence
-	    `(,@(if (bib-empty? x "crossref")
-		    `(,(bib-format-number-series x)
-		      ,(bib-format-address-publisher x)
-		      ,(bib-format-edition x)
-		      ,(bib-format-date x))
-		    `((concat ,(bib-translate "in ")
-			      (cite ,(bib-field x "crossref")))
-		      ,(bib-format-field x "edition")
-		      ,(bib-format-date x))))))
-	 ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-booklet n x)
-  (:mode bib-ieeetr?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-	   (bib-new-sentence
-	    `(,(bib-format-author x)
-	      (concat "``" ,(bib-format-field-Locase x "title") "''"))))
-	 ,(bib-new-block
-	   (bib-new-sentence
-	    `(,(bib-format-field-preserve-case x "howpublished")
-	      ,(bib-format-field x "address")
-	      ,(bib-format-date x))))
-	 ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-inbook n x)
-  (:mode bib-ieeetr?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-	   (bib-new-sentence
-	    `(,(if (bib-empty? x "author") (bib-format-editor x) (bib-format-author x))
-	      ,(bib-emphasize (bib-format-field x "title"))
-	      ,(bib-format-bvolume x)
-	      ,(bib-format-chapter-pages x))))
-	 ,(bib-new-block
-	   (bib-new-sentence
-	    `(,@(if (bib-empty? x "crossref")
-		    `(,(bib-format-number-series x)
-		      ,(bib-format-address-publisher x)
-		      ,(bib-format-edition x)
-		      ,(bib-format-date x))
-		    `((concat ,(bib-translate "in ")
-			      (cite ,(bib-field x "crossref")))
-		      ,(bib-format-date x))))))
-	 ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-incollection n x)
-  (:mode bib-ieeetr?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-	   (bib-new-sentence
-	    `(,(bib-format-author x)
-	      (concat "``" ,(bib-format-field-Locase x "title") "''")
-	      ,@(if (bib-empty? x "crossref")
-		    `(,(bib-format-in-ed-booktitle x)
-		      ,(bib-format-bvolume x)
-		      ,(bib-format-number-series x)
-		      ,(bib-format-chapter-pages x)
-		      ,(bib-format-address-publisher x)
-		      ,(bib-format-edition x)
-		      ,(bib-format-date x))
-		    `((concat ,(bib-translate "in ")
-			      (cite ,(bib-field x "crossref")))
-		      ,(bib-format-chapter-pages x))))))
-	 ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-inproceedings n x)
-  (:mode bib-ieeetr?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-	   (bib-new-sentence
-	    `(,(bib-format-author x)
-	      (concat "``" ,(bib-format-field-Locase x "title") "''")
-	      ,@(if (bib-empty? x "crossref")
-		    `(,(bib-format-in-ed-booktitle x)
-		      ,(bib-format-bvolume x)
-		      ,(bib-format-number-series x)
-		      (concat "(" ,(bib-format-field x "address") ")")
-		      ,(bib-format-pages x)
-		      ,(bib-format-field x "organization")
-		      ,(bib-format-field x "publisher")
-		      ,(bib-format-date x))
-		    `((concat ,(bib-translate "in ")
-			      (cite ,(bib-field x "crossref")))
-		      ,(bib-format-pages x))))))
-	 ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-manual n x)
-  (:mode bib-ieeetr?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-	   (bib-new-sentence
-	    `(,@(if (bib-empty? x "author")
-		    (if (bib-empty? x "organization") `()
-			`(,(bib-format-field x "organization")
-			  ,(bib-format-field x "address")))
-		    `(,(bib-format-author x)))
-	      ,(bib-emphasize (bib-format-field x "title")))))
-	 ,(bib-new-block
-	   (bib-new-sentence
-	    `(,(bib-format-field x "organization")
-	      ,(bib-format-field x "address")
-	      ,(bib-format-edition x)
-	      ,(bib-format-date x))))
-	 ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-mastersthesis n x)
-  (:mode bib-ieeetr?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-	   (bib-new-sentence
-	    `(,(bib-format-author x)
-	      (concat "``" ,(bib-format-field-Locase x "title") "''")
-	      ,(if (bib-empty? x "type")
-		   (bib-translate "Master's thesis")
-		   (bib-format-field x "type"))
-	      ,(bib-format-field x "school")
-	      ,(bib-format-field x "address")
-	      ,(bib-format-date x))))
-	 ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-misc n x)
-  (:mode bib-ieeetr?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-case-preserved-block
-	   (bib-new-case-preserved-sentence
-	    `(,(bib-format-author x)
-	      (concat "``" ,(bib-format-field-Locase x "title") "''")
-	      ,(bib-format-field-preserve-case x "howpublished")
-	      ,(bib-format-date x))))
-	 ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-phdthesis n x)
-  (:mode bib-ieeetr?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-	   (bib-new-sentence
-	    `(,(bib-format-author x)
-	      ,(bib-emphasize (bib-format-field-Locase x "title"))
-	      ,(if (bib-empty? x "type")
-		   (bib-translate "Master's thesis")
-		   (bib-format-field x "type"))
-	      ,(bib-format-field x "school")
-	      ,(bib-format-field x "address")
-	      ,(bib-format-date x))))
-	 ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-proceedings n x)
-  (:mode bib-ieeetr?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-	   (bib-new-sentence
-	    `(,(if (bib-empty? x "editor")
-		   (bib-format-field x "organization")
-		   (bib-format-editor x))
-	      ,(bib-emphasize (bib-format-field x "title"))
-	      ,(bib-format-bvolume x)
-	      ,(bib-format-number-series x)
-	      ,(if (bib-empty? x "editor") "" (bib-format-field x "organization"))
-	      (concat "(" ,(bib-format-field x "address") ")")
-	      ,(bib-format-field x "publisher")
-	      ,(bib-format-date x))))
-	 ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-techreport n x)
-  (:mode bib-ieeetr?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-	   (bib-new-sentence
-	    `(,(bib-format-author x)
-	      (concat "``" ,(bib-format-field-Locase x "title") "''")
-	      ,(bib-format-tr-number x)
-	      ,(bib-format-field x "institution")
-	      ,(bib-format-field x "address")
-	      ,(bib-format-date x))))
-	 ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-unpublished n x)
-  (:mode bib-ieeetr?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-	   (bib-new-sentence
-	    `(,(bib-format-author x)
-	      (concat "``" ,(bib-format-field-Locase x "title") "''"))))
-	 ,(bib-new-block
-	   (bib-new-sentence
-	    `(,(bib-format-field x "note")
-	      ,(bib-format-date x))))))))
diff --git a/TeXmacs/plugins/latex/progs/bibtex/plain.scm b/TeXmacs/plugins/latex/progs/bibtex/plain.scm
deleted file mode 100644
index da39be12b2..0000000000
--- a/TeXmacs/plugins/latex/progs/bibtex/plain.scm
+++ /dev/null
@@ -1,573 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : plain.scm
-;; DESCRIPTION : plain style for BibTeX files
-;; COPYRIGHT   : (C) 2010, 2015  David MICHEL, Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; To translate (except in french):
-;; "edition"
-;; "editor"
-;; "editors"
-;; "master's thesis"
-;; "in"
-;; "number" ???
-;; "of"
-;; "pages"
-;; "phd thesis"
-;; "technical report"
-;; "volume"
-
-(texmacs-module (bibtex plain)
-  (:use (bibtex bib-utils)))
-
-(bib-define-style "plain" "plain")
-
-(tm-define (bib-preprocessing t) (:mode bib-plain?) `())
-
-(define (bib-non-breaking x)
-  (cond ((tm-func? x 'concat)
-         (with l (map bib-non-breaking (tm-children x))
-           (apply tmconcat l)))
-        ((string? x)
-         (let* ((l (string-tokenize-by-char x #\space))
-                (r (list-intersperse l '(nbsp))))
-           (apply tmconcat r)))
-        (else x)))
-
-(tm-define (bib-name-ends? x s)
-  (cond ((tm-func? x 'concat) (bib-name-ends? (cAr x) s))
-        ((string? x) (string-ends? x s))
-        (else #f)))
-
-(tm-define (bib-format-first-name x)
-  (if (bib-null? (list-ref x 1)) ""
-      (with f (bib-non-breaking (list-ref x 1))
-        (if (bib-name-ends? f ".")
-            (tmconcat f '(nbsp))
-            (tmconcat f " ")))))
-
-(tm-define (bib-format-name x)
-  ;; (:mode bib-plain?)
-  (let* ((ff (bib-format-first-name x))
-	 (vv (if (bib-null? (list-ref x 2)) ""
-                 `(concat ,(list-ref x 2) (nbsp))))
-	 (ll (if (bib-null? (list-ref x 3)) ""
-                 (bib-purify (list-ref x 3))))
-	 (jj (if (bib-null? (list-ref x 4)) ""
-                 `(concat ", " ,(list-ref x 4)))))
-    `(concat ,ff ,vv ,ll ,jj)))
-
-(define (bib-format-names-rec n lim a)
-  (if (equal? n lim)
-      ""
-      `(concat ", "
-	       ,(bib-format-name (list-ref a n))
-	       ,(bib-format-names-rec (+ n 1) lim a))))
-
-(tm-define (bib-last-name-sep a)
-  ;; (:mode bib-plain?)
-  (if (<= (length a) 3)
-      (bib-translate " and ")
-      (bib-translate ", and ")))
-
-(tm-define (bib-format-names a)
-  ;; (:mode bib-plain?)
-  (if (or (bib-null? a) (nlist? a))
-      ""
-      (let* ((n (length a)))
-	(if (equal? n 2)
-	    (bib-format-name (list-ref a 1))
-	    (let* ((b (bib-format-name (list-ref a 1)))
-		   (m (bib-format-names-rec 2 (- n 1) a))
-		   (e (if (or (== (list-ref (list-ref a (- n 1)) 3) "others")
-                              (== (list-ref (list-ref a (- n 1)) 4) "others"))
-			  `(concat " et" (nbsp) "al")
-			  `(concat ,(bib-last-name-sep a)
-				   ,(bib-format-name (list-ref a (- n 1)))))))
-	      `(concat ,b ,m ,e))))))
-
-(tm-define (bib-format-author x)
-  ;; (:mode bib-plain?)
-  (with a (bib-field x "author")
-    (if (bib-null? a)
-	""
-	(bib-format-names a))))
-
-(tm-define (bib-format-editor x)
-  ;; (:mode bib-plain?)
-  (with a (bib-field x "editor")
-    (if (or (bib-null? a) (nlist? a))
-	""
-	(if (equal? (length a) 2)
-	    `(concat ,(bib-format-names a) ,(bib-translate ", editor"))
-	    `(concat ,(bib-format-names a) ,(bib-translate ", editors"))))))
-
-(tm-define (bib-format-in-ed-booktitle x)
-  ;; (:mode bib-plain?)
-  (let* ((b (bib-default-field x "booktitle"))
-	 (e (bib-field x "editor")))
-    (if (bib-null? b)
-        ""
-        (if (bib-null? e)
-            `(concat ,(bib-translate "in ") (with "font-shape" "italic" ,b))
-            `(concat ,(bib-translate "in ") ,(bib-format-editor x) ", "
-                     (with "font-shape" "italic" ,b))))))
-
-(tm-define (bib-format-bvolume x)
-  ;; (:mode bib-plain?)
-  (let* ((v (bib-field x "volume"))
-	 (s (bib-default-field x "series")))
-    (if (bib-null? v)
-	""
-	(let ((series (if (bib-null? s) ""
-			  `(concat ,(bib-translate " of ")
-				   (with "font-shape" "italic" ,s))))
-	      (sep (if (< (bib-text-length v) 3) `(nbsp) " ")))
-	  `(concat ,(bib-translate "volume") ,sep ,v ,series)))))
-
-(tm-define (bib-format-number-series x)
-  ;; (:mode bib-plain?)
-  (let* ((v (bib-field x "volume"))
-	 (n (bib-field x "number"))
-	 (s (bib-default-field x "series")))
-    (if (bib-null? v)
-	(if (bib-null? n)
-	    (if (bib-null? s) "" s)
-	    (let ((series (if (bib-null? s) ""
-			      `(concat ,(bib-translate " in ") ,s)))
-		  (sep (if (< (bib-text-length n) 3) `(nbsp) " ")))
-	      `(concat ,(bib-translate "number") ,sep ,n ,series)))
-	"")))
-
-(tm-define (bib-format-pages x)
-  ;; (:mode bib-plain?)
-  (with p (bib-field x "pages")
-    (cond
-      ((or (bib-null? p) (nlist? p)) "")
-      ((== (length p) 1) "")
-      ((== (length p) 2)
-       `(concat ,(bib-translate "page ") ,(list-ref p 1)))
-      (else
-	`(concat ,(bib-translate "pages ")
-		 ,(list-ref p 1) ,bib-range-symbol ,(list-ref p 2))))))
-
-(tm-define (bib-format-chapter-pages x)
-  ;; (:mode bib-plain?)
-  (let* ((c (bib-field x "chapter"))
-	 (t (bib-field x "type")))
-    (if (bib-null? c)
-	(bib-format-pages x)
-	(let ((type (if (bib-null? t)
-			(bib-translate "chapter")
-			(bib-locase t)))
-	      (pages `(concat ", " ,(bib-format-pages x))))
-	  `(concat ,type " " ,c ,pages)))))
-
-(tm-define (bib-format-vol-num-pages x)
-  ;; (:mode bib-plain?)
-  (let* ((v (bib-field x "volume"))
-	 (n (bib-field x "number"))
-	 (p (bib-field x "pages"))
-	 (vol (if (bib-null? v) "" v))
-	 (num (if (bib-null? n) "" `(concat "(" ,n ")")))
-	 (pag (if (or (bib-null? p) (nlist? p))
-		  ""
-		  (cond
-		    ((equal? 1 (length p)) "")
-		    ((equal? 2 (length p)) `(concat ":" ,(list-ref p 1)))
-		    (else
-		      `(concat ":" ,(list-ref p 1)
-                               ,bib-range-symbol ,(list-ref p 2)))))))
-    (if (and (== vol "") (== num ""))
-        (bib-format-pages x)
-        `(concat ,vol ,num ,pag))))
-
-(tm-define (bib-format-date x)
-  ;; (:mode bib-plain?)
-  (let* ((y (bib-field x "year"))
-	 (m (bib-field x "month")))
-    (if (bib-null? y)
-	(if (bib-null? m) "" m)
-	(if (bib-null? m) y `(concat ,m " " ,y)))))
-
-(tm-define (bib-format-tr-number x)
-  ;; (:mode bib-plain?)
-  (let* ((t (bib-field x "type"))
-	 (n (bib-field x "number"))
-	 (type (if (bib-null? t) (bib-translate "Technical Report") t))
-	 (number (if (bib-null? n) "" n))
-	 (sep (if (< (bib-text-length n) 3) `(nbsp) " ")))
-    (if (bib-null? n) type
-        `(concat ,type ,sep ,number))))
-
-(tm-define (bib-format-bibitem n x)
-  ;; (:mode bib-plain?)
-  `(bibitem* ,(number->string n)))
-
-(tm-define (bib-format-article n x)
-  ;; (:mode bib-plain?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block (bib-format-author x))
-	 ,(bib-new-block (bib-format-field-Locase x "title"))
-	 ,(bib-new-block
-	   (if (bib-empty? x "crossref")
-	       (bib-new-sentence
-		`(,(bib-emphasize (bib-format-field x "journal"))
-		  ,(bib-format-vol-num-pages x)
-		  ,(bib-format-date x)))
-	       (bib-new-sentence
-		`((concat ,(bib-translate "in ")
-			  (cite ,(bib-field x "crossref")))
-		  ,(bib-format-pages x)))))
-	 ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-book n x)
-  ;; (:mode bib-plain?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-	   (if (bib-empty? x "author")
-	       (bib-format-editor x)
-	       (bib-format-author x)))
-	 ,(bib-new-block
-	   (bib-new-sentence
-	    `(,(bib-emphasize (bib-format-field x "title"))
-	      ,(bib-format-bvolume x))))
-	 ,(bib-new-block
-	   (if (bib-empty? x "crossref")
-	       (bib-new-list-spc
-		`(,(bib-new-sentence
-		    `(,(bib-format-number-series x)))
-		  ,(bib-new-sentence
-		    `(,(bib-format-field x "publisher")
-		      ,(bib-format-field x "address")
-		      ,(if (bib-empty? x "edition") ""
-			   `(concat ,(bib-format-field x "edition")
-				    ,(bib-translate " edition")))
-		      ,(bib-format-date x)))))
-	       (bib-new-sentence
-		`((concat ,(bib-translate "in ")
-			  (cite ,(bib-field x "crossref")))
-		  ,(bib-format-field x "edition")
-		  ,(bib-format-date x)))))
-	 ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-booklet n x)
-  ;; (:mode bib-plain?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block (bib-format-author x))
-	 ,(bib-new-block (bib-format-field-Locase x "title"))
-	 ,(bib-new-case-preserved-block
-	   (bib-new-case-preserved-sentence
-	    `(,(bib-format-field-preserve-case x "howpublished")
-	      ,(bib-upcase-first (bib-format-field x "address"))
-	      ,(bib-format-date x))))
-	 ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-inbook n x)
-  ;; (:mode bib-plain?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block (if (bib-empty? x "author") (bib-format-editor x)
-			 (bib-format-author x)))
-	 ,(bib-new-block
-	   (bib-new-sentence
-	    `(,(bib-emphasize (bib-format-field x "title"))
-	      ,(bib-format-bvolume x)
-	      ,(bib-format-chapter-pages x))))
-	 ,(bib-new-block
-	   (if (bib-empty? x "crossref")
-	       (bib-new-list-spc
-		`(,(bib-new-sentence `(,(bib-format-number-series x)))
-		  ,(bib-new-sentence
-		    `(,(bib-format-field x "publisher")
-		      ,(bib-format-field x "address")
-		      ,(if (bib-empty? x "edition") ""
-			   `(concat ,(bib-format-field x "edition")
-				    ,(bib-translate " edition")))
-		      ,(bib-format-date x)))))
-	       (bib-new-sentence
-		`(,(bib-format-chapter-pages x)
-		  (concat ,(bib-translate "in ")
-			  (cite ,(bib-field x "crossref")))))))
-	 ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-incollection n x)
-  ;; (:mode bib-plain?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block (bib-format-author x))
-	 ,(bib-new-block (bib-format-field-Locase x "title"))
-	 ,(bib-new-block
-	   (if (bib-empty? x "crossref")
-	       (bib-new-list-spc
-		`(,(bib-new-sentence
-		    `(,(bib-format-in-ed-booktitle x)
-		      ,(bib-format-bvolume x)
-		      ,(bib-format-number-series x)
-		      ,(bib-format-chapter-pages x)))
-		  ,(bib-new-sentence
-		    `(,(bib-format-field x "publisher")
-		      ,(bib-format-field x "address")
-		      ,(bib-format-date x)))))
-	       (bib-new-sentence
-		`((concat ,(bib-translate "in ")
-			  (cite ,(bib-field x "crossref")))
-		  ,(bib-format-chapter-pages x)))))
-	 ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-inproceedings n x)
-  ;; (:mode bib-plain?)
-  `(concat
-    ,(bib-format-bibitem n x)
-    ,(bib-label (list-ref x 2))
-    ,(bib-new-list-spc
-      `(,(bib-new-block (bib-format-author x))
-	,(bib-new-block (bib-format-field-Locase x "title"))
-	,(bib-new-block
-	  (if (bib-empty? x "crossref")
-	      (bib-new-list-spc
-	       `(,(bib-new-sentence
-		   `(,(bib-format-in-ed-booktitle x)
-		     ,(bib-format-bvolume x)
-		     ,(bib-format-number-series x)
-		     ,(bib-format-pages x)))
-		 ,(if (bib-empty? x "address")
-		      (bib-new-sentence
-		       `(,(bib-format-field x "organization")
-			 ,(bib-format-field x "publisher")
-			 ,(bib-format-date x)))
-		      (bib-new-list-spc
-		       `(,(bib-new-sentence
-			   `(,(bib-format-field x "address")
-			     ,(bib-format-date x)))
-			 ,(bib-new-sentence
-			   `(,(bib-format-field x "organization")
-			     ,(bib-format-field x "publisher"))))))))
-	      (bib-new-sentence
-	       `((concat ,(bib-translate "in ")
-			 (cite ,(bib-field x "crossref")))
-		 ,(bib-format-pages x)))))
-	,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-manual n x)
-  ;; (:mode bib-plain?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-	   (if (bib-empty? x "author")
-	       (if (bib-empty? x "organization") ""
-		   (bib-new-sentence
-		    `(,(bib-format-field x "organization")
-		      ,(bib-format-field x "address"))))
-	       (bib-format-author x)))
-	 ,(bib-new-block (bib-emphasize (bib-format-field x "title")))
-	 ,(bib-new-block
-	   (bib-new-sentence
-	    `(,(bib-format-field x "organization")
-	      ,(bib-format-field x "address")
-	      ,(if (bib-empty? x "edition") ""
-		   `(concat ,(bib-format-field x "edition")
-			    ,(bib-translate " edition")))
-	      ,(bib-format-date x))))
-	 ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-mastersthesis n x)
-  ;; (:mode bib-plain?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block (bib-format-author x))
-	 ,(bib-new-block (bib-format-field-Locase x "title"))
-	 ,(bib-new-block
-	   (bib-new-sentence
-	    `(,(if (bib-empty? x "type")
-		   (bib-translate "Master's thesis")
-		   (bib-format-field-Locase x "type"))
-	      ,(bib-format-field x "school")
-	      ,(bib-format-field x "address")
-	      ,(bib-format-date x))))
-	 ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-misc n x)
-  ;; (:mode bib-plain?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block (bib-format-author x))
-	 ,(bib-new-block (bib-format-field-Locase x "title"))
-	 ,(bib-new-case-preserved-block
-	   (bib-new-case-preserved-sentence
-	    `(,(bib-format-field-preserve-case x "howpublished")
-	      ,(bib-format-date x))))
-	 ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-phdthesis n x)
-  ;; (:mode bib-plain?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block (bib-format-author x))
-	 ,(bib-new-block (bib-emphasize (bib-format-field x "title")))
-	 ,(bib-new-block
-	   (bib-new-sentence
-	    `(,(if (bib-empty? x "type")
-		   (bib-translate "PhD thesis")
-		   (bib-format-field-Locase x "type"))
-	      ,(bib-format-field x "school")
-	      ,(bib-format-field x "address")
-	      ,(bib-format-date x))))
-	 ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-proceedings n x)
-  ;; (:mode bib-plain?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-	   (if (bib-empty? x "editor")
-	       (bib-format-field x "organization")
-	       (bib-format-editor x)))
-	 ,(bib-new-block
-	   (bib-new-sentence
-	    `(,(bib-emphasize (bib-format-field x "title"))
-	      ,(bib-format-bvolume x)
-	      ,(bib-format-number-series x))))
-	 ,(bib-new-block
-	   (if (bib-empty? x "address")
-	       (bib-new-sentence
-		`(,(if (bib-empty? x "editor") ""
-		       (bib-format-field x "organization"))
-		  ,(bib-format-field x "publisher")
-		  ,(bib-format-date x)))
-	       (bib-new-list-spc
-		`(,(bib-new-sentence
-		    `(,(bib-format-field x "address")
-		      ,(bib-format-date x)))
-		  ,(bib-new-sentence
-		    `(,(if (bib-empty? x "editor") ""
-			   (bib-format-field x "organization"))
-		      ,(bib-format-field x "publisher")))))))
-	 ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-techreport n x)
-  ;; (:mode bib-plain?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block (bib-format-author x))
-	 ,(bib-new-block (bib-format-field-Locase x "title"))
-	 ,(bib-new-block
-	   (bib-new-sentence
-	    `(,(bib-format-tr-number x)
-	      ,(bib-format-field x "institution")
-	      ,(bib-format-field x "address")
-	      ,(bib-format-date x))))
-	 ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-unpublished n x)
-  ;; (:mode bib-plain?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block (bib-format-author x))
-	 ,(bib-new-block (bib-format-field-Locase x "title"))
-	 ,(bib-new-block
-	   (bib-new-sentence
-	    `(,(bib-format-field x "note")
-	      ,(bib-format-date x))))))))
-
-(tm-define (bib-format-entry n x)
-  ;; (:mode bib-plain?)
-  (if (and (list? x) (func? x 'bib-entry)
-	   (= (length x) 4) (func? (list-ref x 3) 'document))
-      (with doctype (list-ref x 1)
-	(cond
-	  ((equal? doctype "article") (bib-format-article n x))
-	  ((equal? doctype "book") (bib-format-book n x))
-	  ((equal? doctype "booklet") (bib-format-booklet n x))
-	  ((equal? doctype "inbook") (bib-format-inbook n x))
-	  ((equal? doctype "incollection") (bib-format-incollection n x))
-	  ((equal? doctype "inproceedings") (bib-format-inproceedings n x))
-	  ((equal? doctype "conference") (bib-format-inproceedings n x))
-	  ((equal? doctype "manual") (bib-format-manual n x))
-	  ((equal? doctype "mastersthesis") (bib-format-mastersthesis n x))
-	  ((equal? doctype "misc") (bib-format-misc n x))
-	  ((equal? doctype "phdthesis") (bib-format-phdthesis n x))
-	  ((equal? doctype "proceedings") (bib-format-proceedings n x))
-	  ((equal? doctype "techreport") (bib-format-techreport n x))
-	  ((equal? doctype "unpublished") (bib-format-unpublished n x))
-	  (else (bib-format-misc n x))))))
-
-(define (author-sort-format a)
-  (if (or (npair? a) (null? a))
-      ""
-      (with name
-	  (let* ((x (car a))
-		 (ff (if (equal? (list-ref x 1) "") ""
-			 (string-append (bib-purify (list-ref x 1)) " ")))
-		 (vv (if (equal? (list-ref x 2) "") ""
-			 (string-append (bib-purify (list-ref x 2)) " ")))
-		 (ll (if (equal? (list-ref x 3) "") ""
-			 (string-append (bib-purify (list-ref x 3)) " ")))
-		 (jj (if (equal? (list-ref x 4) "") ""
-			 (string-append (bib-purify (list-ref x 4)) " "))))
-	    (string-append vv ll ff jj))
-	(string-append name (author-sort-format (bib-cdr a))))))
-
-(define (author-editor-sort-key x)
-  (if (bib-empty? x "author")
-      (if (bib-empty? x "editor")
-	  (list-ref x 2)
-	  (string-upcase (author-sort-format
-                          (bib-cdr (bib-field x "editor")))))
-      (string-upcase (author-sort-format
-                      (bib-cdr (bib-field x "author"))))))
-
-(define (author-sort-key x ae)
-  (if (bib-empty? x ae)
-      (list-ref x 2)
-      ;;(author-sort-format (bib-cdr (bib-field x ae)))))
-      (string-upcase (author-sort-format (bib-cdr (bib-field x ae))))))
-
-(tm-define (bib-sort-key x)
-  ;; (:mode bib-plain?)
-  (let* ((doctype (list-ref x 1))
-	 (pre (cond
-		((or (equal? doctype "inbook") (equal? doctype "book"))
-		 (author-editor-sort-key x))
-		((equal? doctype "proceedings")
-		 (author-sort-key x "editor"))
-		(else
-		  (author-sort-key x "author")))))
-    (string-append pre "    "
-		   (if (bib-empty? x "year") "" (string-append (bib-field x "year") "    "))
-		   (bib-purify (bib-field x "title")))))
-
diff --git a/TeXmacs/plugins/latex/progs/bibtex/siam.scm b/TeXmacs/plugins/latex/progs/bibtex/siam.scm
deleted file mode 100644
index 2d4f6f81b3..0000000000
--- a/TeXmacs/plugins/latex/progs/bibtex/siam.scm
+++ /dev/null
@@ -1,358 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : siam.scm
-;; DESCRIPTION : siam style for BibTeX files
-;; COPYRIGHT   : (C) 2010, 2015  David MICHEL, Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (bibtex siam)
-  (:use (bibtex bib-utils) (bibtex plain)))
-
-(bib-define-style "siam" "plain")
-
-(tm-define (bib-format-name x)
-  (:mode bib-siam?)
-  (let* ((f (if (bib-null? (list-ref x 1)) ""
-		`(concat ,(bib-abbreviate (list-ref x 1) "." `(nbsp)) (nbsp))))
-	 (vv (if (bib-null? (list-ref x 2)) ""
-                 `(concat ,(list-ref x 2) (nbsp))))
-	 (ll (if (bib-null? (list-ref x 3)) ""
-                 (bib-purify (list-ref x 3))))
-	 (jj (if (bib-null? (list-ref x 4)) ""
-                 `(concat ", " ,(list-ref x 4)))))
-    `(with "font-shape" "small-caps" (concat ,f ,vv ,ll ,jj))))
-
-(tm-define (bib-format-editor x)
-  (:mode bib-siam?)
-  (with a (bib-field x "editor")
-    (if (or (bib-null? a) (nlist? a)) ""
-	(if (equal? (length a) 2)
-	    `(concat ,(bib-format-names a) ", ed.")
-	    `(concat ,(bib-format-names a) ", eds.")))))
-
-(tm-define (bib-format-bvolume x)
-  (:mode bib-siam?)
-  (let* ((v (bib-field x "volume"))
-	 (s (bib-field x "series")))
-    (if (bib-null? v) ""
-	(let ((series (if (bib-null? s) ""
-			  `(concat ,(bib-translate " of ") ,s)))
-	      (sep (if (< (bib-text-length v) 3) `(nbsp) " ")))
-	  `(concat "vol." ,sep ,v ,series)))))
-
-(tm-define (bib-format-number-series x)
-  (:mode bib-siam?)
-  (let* ((v (bib-field x "volume"))
-	 (n (bib-field x "number"))
-	 (s (bib-field x "series")))
-    (if (bib-null? v)
-	(if (bib-null? n)
-	    (if (bib-null? s) "" s)
-	    (let ((series (if (bib-null? s) ""
-			      `(concat ,(bib-translate " in ") ,s)))
-		  (sep (if (< (bib-text-length n) 3) `(nbsp) " ")))
-	      `(concat "no." ,sep ,n ,series)))
-	"")))
-
-(define (bib-format-edition x)
-  (with e (bib-field x "edition")
-    (if (bib-null? e)
-	""
-	`(concat ,e " ed."))))
-
-(tm-define (bib-format-in-ed-booktitle x)
-  (:mode bib-siam?)
-  (let* ((b (bib-field x "booktitle"))
-	 (e (bib-field x "editor")))
-    (if (bib-null? b) ""
-	(if (bib-null? e)
-	    `(concat ,(bib-translate "in ") ,b)
-	    `(concat ,(bib-translate "in ") ,b ", " ,(bib-format-editor x))))))
-
-(tm-define (bib-format-chapter-pages x)
-  (:mode bib-siam?)
-  (let* ((c (bib-field x "chapter"))
-	 (t (bib-field x "type")))
-    (if (bib-null? c)
-	(bib-format-pages x)
-	(let ((type (if (bib-null? t) (bib-translate "chapter") (bib-locase t)))
-	      (pages `(concat ", " ,(bib-format-pages x))))
-	  `(concat ,type " " ,c ,pages)))))
-
-(tm-define (bib-format-pages x)
-  (:mode bib-siam?)
-  (with p (bib-field x "pages")
-    (cond
-      ((or (bib-null? p) (nlist? p)) "")
-      ((== (length p) 1) "")
-      ((== (length p) 2) `(concat "p." (nbsp) ,(list-ref p 1)))
-      (else `(concat "pp." (nbsp)
-                     ,(list-ref p 1) ,bib-range-symbol ,(list-ref p 2))))))
-
-(tm-define (bib-format-article n x)
-  (:mode bib-siam?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-	   (bib-new-sentence
-	    `(,(bib-format-author x)
-	      ,(bib-emphasize (bib-format-field-Locase x "title"))
-	      ,@(if (bib-empty? x "crossref")
-		    `(,(bib-format-field x "journal")
-		      (concat
-			,(bib-field x "volume")
-			,(if (bib-empty? x "year") ""
-			     `(concat
-				,(if (bib-empty? x "volume") "" " ")
-				"(" ,(bib-field x "year") ")")))
-		      ,(bib-format-pages x))
-		    `((concat ,(bib-translate "in ")
-			      (cite ,(bib-field x "crossref")))
-		      ,(bib-format-pages x))))))
-	 ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-book n x)
-  (:mode bib-siam?)
-  `(concat
-    ,(bib-format-bibitem n x)
-    ,(bib-label (list-ref x 2))
-    ,(bib-new-list-spc
-      `(,(bib-new-block
-	  (bib-new-sentence
-	   `(,(if (bib-empty? x "author") (bib-format-editor x) (bib-format-author x))
-	     ,(bib-emphasize (bib-format-field x "title"))
-	     ,@(if (bib-empty? x "crossref")
-		   `(,(bib-format-bvolume x)
-		     ,(bib-format-number-series x)
-		     ,(bib-format-field x "publisher")
-		     ,(bib-format-field x "address")
-		     ,(bib-format-edition x)
-		     ,(bib-format-date x))
-		   `((concat ,(bib-translate "in ")
-			     (cite ,(bib-field x "crossref")))
-		     ,(bib-format-field x "edition")
-		     ,(bib-format-date x))))))
-	,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-booklet n x)
-  (:mode bib-siam?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-	   (bib-new-sentence
-	    `(,(bib-format-author x)
-	      ,(bib-emphasize (bib-format-field-Locase x "title")))))
-	 ,(bib-new-case-preserved-block
-	   (bib-new-case-preserved-sentence
-             `(,(bib-format-field-preserve-case x "howpublished")
-	       ,(bib-format-field x "address")
-	       ,(bib-format-date x))))
-	 ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-inbook n x)
-  (:mode bib-siam?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-	   (bib-new-sentence
-	    `(,(if (bib-empty? x "author") (bib-format-editor x) (bib-format-author x))
-	      ,(bib-emphasize (bib-format-field x "title"))
-	      ,@(if (bib-empty? x "crossref")
-		    `(,(bib-format-bvolume x)
-		      ,(bib-format-number-series x)
-		      ,(bib-format-field x "publisher")
-		      ,(bib-format-field x "address")
-		      ,(bib-format-edition x)
-		      ,(bib-format-date x)
-		      ,(bib-format-chapter-pages x))
-		    `((concat ,(bib-translate "in ")
-			      (cite ,(bib-field x "crossref")))
-		      ,(bib-format-date x))))))
-	 ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-incollection n x)
-  (:mode bib-siam?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-	   (bib-new-sentence
-	    `(,(bib-format-author x)
-	      ,(bib-emphasize (bib-format-field-Locase x "title"))
-	      ,@(if (bib-empty? x "crossref")
-		    `(,(bib-format-in-ed-booktitle x)
-		      ,(bib-format-bvolume x)
-		      ,(bib-format-number-series x)
-		      ,(bib-format-field x "publisher")
-		      ,(bib-format-field x "address")
-		      ,(bib-format-edition x)
-		      ,(bib-format-date x)
-		      ,(bib-format-chapter-pages x))
-		    `((concat ,(bib-translate "in ")
-			      (cite ,(bib-field x "crossref")))
-		      ,(bib-format-chapter-pages x))))))
-	 ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-inproceedings n x)
-  (:mode bib-siam?)
-  `(concat
-    ,(bib-format-bibitem n x)
-    ,(bib-label (list-ref x 2))
-    ,(bib-new-list-spc
-      `(,(bib-new-block
-	  (bib-new-sentence
-	   `(,(bib-format-author x)
-	     ,(bib-emphasize (bib-format-field-Locase x "title"))
-	     ,@(if (bib-empty? x "crossref")
-		   `(,(bib-format-in-ed-booktitle x)
-		     ,(bib-format-bvolume x)
-		     ,(bib-format-number-series x)
-		     ,(bib-format-field x "address")
-		     ,(bib-format-date x)
-		     ,(bib-format-field x "organization")
-		     ,(bib-format-field x "publisher")
-		     ,(bib-format-pages x))
-		   `((concat ,(bib-translate "in ")
-			     (cite ,(bib-field x "crossref")))
-		     ,(bib-format-pages x))))))
-	,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-manual n x)
-  (:mode bib-siam?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-	   (bib-new-sentence
-	    `(,@(if (bib-empty? x "author")
-		    (if (bib-empty? x "organization")
-			`()
-			`(,(bib-format-field x "organization")
-			  ,(bib-format-field x "address")))
-		    `(,(bib-format-author x)))
-	      ,(bib-emphasize (bib-format-field x "title")))))
-	 ,(bib-new-block
-	   (bib-new-sentence
-	    `(,(bib-format-field x "organization")
-	      ,(bib-format-field x "address")
-	      ,(bib-format-edition x)
-	      ,(bib-format-date x))))
-	 ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-mastersthesis n x)
-  (:mode bib-siam?)
-  `(concat
-    ,(bib-format-bibitem n x)
-    ,(bib-label (list-ref x 2))
-    ,(bib-new-list-spc
-      `(,(bib-new-block
-	  (bib-new-sentence
-	   `(,(bib-format-author x)
-	     ,(bib-emphasize (bib-format-field-Locase x "title"))
-	     ,(if (bib-empty? x "type")
-		  (bib-translate "Master's thesis")
-		  (bib-format-field x "type"))
-	     ,(bib-format-field x "school")
-	     ,(bib-format-field x "address")
-	     ,(bib-format-date x))))
-	,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-misc n x)
-  (:mode bib-siam?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-	   (bib-new-sentence
-	    `(,(bib-format-author x)
-	      ,(bib-emphasize (bib-format-field-Locase x "title")))))
-	 ,(bib-new-case-preserved-block
-	   (bib-new-case-preserved-sentence
-	    `(,(bib-format-field-preserve-case x "howpublished")
-	      ,(bib-format-date x))))
-	 ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-phdthesis n x)
-  (:mode bib-siam?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-	   (bib-new-sentence
-	    `(,(bib-format-author x)
-	      ,(bib-emphasize (bib-format-field x "title"))
-	      ,(if (bib-empty? x "type")
-		   (bib-translate "Master's thesis")
-		   (bib-format-field x "type"))
-	      ,(bib-format-field x "school")
-	      ,(bib-format-field x "address")
-	      ,(bib-format-date x))))
-	 ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-proceedings n x)
-  (:mode bib-siam?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-	   (bib-new-sentence
-	    `(,(if (bib-empty? x "editor")
-		   (bib-format-field x "organization")
-		   (bib-format-editor x))
-	      ,(bib-emphasize (bib-format-field x "title"))
-	      ,(bib-format-bvolume x)
-	      ,(bib-format-number-series x)
-	      ,(bib-format-field x "address")
-	      ,(bib-format-date x)
-	      ,(bib-format-field x "organization")
-	      ,(bib-format-field x "publisher"))))
-	 ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-techreport n x)
-  (:mode bib-siam?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-	   (bib-new-sentence
-	    `(,(bib-format-author x)
-	      ,(bib-emphasize (bib-format-field-Locase x "title"))
-	      ,(bib-format-tr-number x)
-	      ,(bib-format-field x "institution")
-	      ,(bib-format-field x "address")
-	      ,(bib-format-date x))))
-	 ,(bib-new-block (bib-format-field x "note"))))))
-
-(tm-define (bib-format-unpublished n x)
-  (:mode bib-siam?)
-  `(concat
-     ,(bib-format-bibitem n x)
-     ,(bib-label (list-ref x 2))
-     ,(bib-new-list-spc
-       `(,(bib-new-block
-	   (bib-new-sentence
-	    `(,(bib-format-author x)
-	      ,(bib-emphasize (bib-format-field-Locase x "title")))))
-	 ,(bib-new-block
-	   (bib-new-sentence
-	    `(,(bib-format-field x "note")
-	      ,(bib-format-date x))))))))
-
diff --git a/TeXmacs/plugins/latex/progs/bibtex/unsrt.scm b/TeXmacs/plugins/latex/progs/bibtex/unsrt.scm
deleted file mode 100644
index 26116039b9..0000000000
--- a/TeXmacs/plugins/latex/progs/bibtex/unsrt.scm
+++ /dev/null
@@ -1,22 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : abbrv.scm
-;; DESCRIPTION : abbrv style for BibTeX files
-;; COPYRIGHT   : (C) 2015  Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (bibtex unsrt)
-  (:use (bibtex bib-utils) (bibtex plain)))
-
-(bib-define-style "unsrt" "plain")
-
-(tm-define (bib-sorted-entries l)
-  (:mode bib-unsrt?)
-  (with is-entry? (lambda (x) (func? x 'bib-entry))
-    (list-filter l is-entry?)))
diff --git a/TeXmacs/plugins/latex/progs/convert/bibtex/bibtexout.scm b/TeXmacs/plugins/latex/progs/convert/bibtex/bibtexout.scm
deleted file mode 100644
index e437afd2e9..0000000000
--- a/TeXmacs/plugins/latex/progs/convert/bibtex/bibtexout.scm
+++ /dev/null
@@ -1,289 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : bibtexout.scm
-;; DESCRIPTION : generation of BibTeX from scheme expressions
-;; COPYRIGHT   : (C) 2010  David MICHEL
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (convert bibtex bibtexout)
-  (:use (convert tools output))
-  (:use (convert latex texout)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Entries output
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (bibtex-remove-keepcase x)
-  ;;(display* "REMOVE KEEPCASE: " x "\n")
-  (cond
-    ((list? x)
-     (if (not (null? x))
-	 (if (equal? (car x) 'keepcase)
-	     (if (null? (cdr x)) "{}"
-		 `(rigid ,(bibtex-remove-keepcase (cadr x))))
-	     (cons (car x) (map bibtex-remove-keepcase (cdr x))))
-	 `()))
-    ((string? x) x)))
-
-(define (bibtex-latex x)
-  (let ((options (list
-                   (cons "texmacs->latex:replace-style"      "on")
-                   (cons "texmacs->latex:expand-macros"      "on")
-                   (cons "texmacs->latex:expand-user-macros" "off")
-                   (cons "texmacs->latex:indirect-bib"       "off")
-                   (cons "texmacs->latex:encoding"           "UTF-8")
-                   (cons "texmacs->latex:use-macros"         "off"))))
-    (with old-exact (output-set-exact #t)
-      (output-flush)
-      (texout (texmacs->latex (bibtex-remove-keepcase x) options))
-      (output-set-exact old-exact))))
-
-(define (bibtex-match l s a)
-  (and (list? l) (>= (length l) (+ a 1)) (equal? (car l) s)))
-
-(define (bibtex-flat x)
-  (cond
-    ((list? x)
-     (if (not (null? x))
-	 (begin
-          (bibtex-flat (car x))
-          (bibtex-flat (cdr x)))))
-    ((string? x) (output-verbatim x))))
-
-(define (bibtex-has-var x)
-  (if (list? x)
-    (cond
-      ((null? x) #f)
-      ((bibtex-match (car x) 'bib-var 1) #t)
-      (else (bibtex-has-var (cdr x))))
-    #f))
-
-(define (bibtex-arg-var x)
-  ;; (display* "BIBTEX ARG VAR: " x "\n")
-  (if (not (null? x))
-    (let ((head (car x))
-	  (tail (cdr x)))
-      (begin
-	(cond
-	  ((bibtex-match head 'bib-var 1) (output-verbatim (cadr head)))
-	  ((string? head) (output-verbatim "{" head "}"))
-	  (else
-	    (begin
-	      (output-verbatim "{")
-	      (bibtex-latex head)
-	      (output-verbatim "}"))))
-	(if (not (null? tail))
-	    (begin
-	      (output-verbatim " # ")
-	      (bibtex-arg-var tail)))))))
-
-(define (bibtex-name x)
-  ;; (display* "BIBTEX NAME: " x "\n")
-  (if (bibtex-match x 'bib-name 4)
-      (let ((first (list-ref x 1))
-	    (von (list-ref x 2))
-	    (last (list-ref x 3))
-	    (jr (list-ref x 4)))
-	(begin
-	  (if (not (equal? von ""))
-	      (begin
-		(bibtex-latex von)
-		(output-verbatim " ")))
-	  (bibtex-latex last)
-	  (if (not (equal? first ""))
-	      (begin
-		(output-verbatim ", ")
-		(bibtex-latex first)))
-	  (if (not (equal? jr ""))
-	      (begin
-		(output-verbatim ", ")
-		(bibtex-latex jr)))))))
-
-(define (bibtex-names x)
-  ;; (display* "BIBTEX NAMES: " x "\n")
-  (if (not (null? x))
-    (let ((head (car x))
-	  (tail (cdr x)))
-      (if (bibtex-match head 'bib-name 4)
-          (begin
-            (bibtex-name head)
-            (if (> (length tail) 0) (output-verbatim " and "))
-            (bibtex-names tail))
-          (bibtex-names tail)))))
-
-(define (bibtex-arg x)
-  ;; (display* "BIBTEX ARG: " x "\n")
-  (cond
-    ((bibtex-match x 'bib-var 1) (output-verbatim (cadr x)))
-    ((bibtex-match x 'bib-names 0)
-     (begin
-       (output-verbatim "{")
-       (bibtex-names (cdr x))
-       (output-verbatim "}")))
-    ((bibtex-match x 'bib-pages 2)
-     (output-verbatim "{" (cadr x) "--" (caddr x) "}"))
-    ((bibtex-match x 'bib-pages 1)
-     (output-verbatim "{" (cadr x) "}"))
-    ((string? x) (output-verbatim "{" x "}"))
-    ((if (bibtex-has-var x)
-	 (bibtex-arg-var (cdr x))
-	 (begin
-	   (output-verbatim "{")
-	   (bibtex-latex x)
-	   (output-verbatim "}"))))))
-
-(define (bibtex-preamble pre x)
-  ;; (display* "PREAMBLE: " x "\n")
-  (begin
-    (output-verbatim pre "preamble{ ")
-    (bibtex-arg x)
-    (output-verbatim " }")
-    (output-lf-verbatim)))
-
-(define (bibtex-preambles pre)
-  (lambda (x)
-    (if (list? x)
-	(cond
-	  ((func? x 'document)
-	   (for-each (bibtex-preambles pre) (cdr x)))
-	  ((func? x 'bib-latex)
-	   (begin
-	     (bibtex-preamble pre (cadr x))
-	     (output-lf-verbatim)))
-	  ((func? x 'bib-comment)
-	   (for-each (bibtex-preambles "") (cdr x)))))))
-
-(define (bibtex-string pre x)
-  (if (list? x)
-      (begin
-	(output-verbatim pre "string{ " (car x) " = ")
-	(bibtex-arg (cadr x))
-	(output-verbatim " }")
-	(output-lf-verbatim))))
-      
-(define (bibtex-strings pre)
-  (lambda (x)
-    (if (list? x)
-	(cond
-	  ((func? x 'document) (for-each (bibtex-strings pre) (cdr x)))
-	  ((func? x 'bib-assign)
-	   (begin
-	     (bibtex-string pre (cdr x))
-	     (output-lf-verbatim)))
-	  ((func? x 'bib-comment) (for-each (bibtex-strings "") (cdr x)))))))
-
-(define (bibtex-padded s)
-  (cond ((nstring? s) s)
-        ((>= (string-length s) 12) s)
-        (else (bibtex-padded (string-append s " ")))))
-
-(define (bibtex-field x)
-  (if (and (list? x) (= 2 (length x)))
-      (begin
-	(output-verbatim "  " (bibtex-padded (car x)) " = ")
-	(bibtex-arg (cadr x)))))
-
-(define (bibtex-fields x)
-  (if (and (list? x) (not (null? x)))
-      (cond
-	((func? (car x) 'document) (bibtex-fields (cdar x)))
-	((func? (car x) 'bib-field) 
-	 (begin
-	   (bibtex-field (cdar x))
-	   (if (not (null? (cdr x)))
-	       (output-verbatim ","))
-	   (output-lf-verbatim)
-	   (bibtex-fields (cdr x)))))))
-
-(define (bibtex-entry pre x)
-  (let ((type (cadr x))
-	(id (caddr x))
-	(fields (cdddr x)))
-    (begin
-      (output-verbatim pre (upcase-first type) "{" (cork->utf8 id))
-      (if (not (null? fields))
-	  (begin
-	    (output-verbatim ",")
-	    (output-lf-verbatim)
-	    (bibtex-fields fields)))
-      (output-verbatim "}")
-      (output-lf-verbatim))))
-
-(define (bibtex-comment x)
-  (cond
-    ((list? x)
-     (if (not (null? x))
-	 (begin
-	   (cond
-	     ((func? (car x) 'document) (bibtex-comment (cdar x)))
-	     ((func? (car x) 'bib-entry) (bibtex-entry "" (car x)))
-	     ((func? (car x) 'bib-latex) (bibtex-preamble "" (cadar x)))
-	     ((func? (car x) 'bib-assign) (bibtex-string "" (cdar x)))
-	     (else
-	       (begin
-		 (output-verbatim "%")
-		 (bibtex-flat (car x))
-		 (output-lf-verbatim))))
-	   (bibtex-comment (cdr x)))))
-    ((string? x)
-     (begin
-       (output-verbatim "%" x)
-       (output-lf-verbatim)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Main output routines
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (bibtexout x)
-  (cond
-    ((string? x) 
-     (output-verbatim x))
-    ((func? x 'document)
-     (for-each bibtexout (cdr x)))
-    ((func? x 'bib-string)
-     (for-each (bibtex-strings "@") (cdr x)))
-    ((func? x 'bib-preamble)
-     (for-each (bibtex-preambles "@") (cdr x)))
-    ((func? x 'bib-entry)
-     (bibtex-entry "@" x)
-     (output-lf-verbatim))
-    ((func? x 'bib-comment)
-     (bibtex-comment (cdr x))
-     (output-lf-verbatim))
-    ((func? x 'bib-field)
-     (bibtex-field (cdr x))
-     (output-verbatim ",")
-     (output-lf-verbatim))
-    ((func? x 'bib-assign)
-     (bibtex-string "@" (cdr x))
-     (output-lf-verbatim))
-    ((func? x 'bib-line) (bibtex-comment (cdr x)))
-    ((func? x 'bib-var) (cdr x))
-    ((func? x 'bib-names)
-     (bibtex-names (cdr x))
-     (output-lf-verbatim))
-    ((func? x 'bib-name) (bibtex-name x))
-    ((func? x 'bib-latex)
-     (bibtex-preamble "@" (cadr x))
-     (output-lf-verbatim))))
-
-(tm-define (serialize-bibtex x)
-  (with old-line-length (output-set-line-length 999999)
-    (bibtexout x)
-    (output-set-line-length old-line-length)
-    (output-produce)))
-
-(tm-define (serialize-bibtex-arg x)
-  (with old-line-length (output-set-line-length 999999)
-    (bibtex-arg x)
-    (output-set-line-length old-line-length)
-    (with r (output-produce)
-      (if (and (string-starts? r "{") (string-ends? r "}"))
-          (substring r 1 (- (string-length r) 1))
-          r))))
diff --git a/TeXmacs/plugins/latex/progs/convert/bibtex/bibtextm.scm b/TeXmacs/plugins/latex/progs/convert/bibtex/bibtextm.scm
deleted file mode 100644
index ed194b8c76..0000000000
--- a/TeXmacs/plugins/latex/progs/convert/bibtex/bibtextm.scm
+++ /dev/null
@@ -1,37 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : bibtextm.scm
-;; DESCRIPTION : conversion of bibtex trees to TeXmacs trees
-;; COPYRIGHT   : (C) 2010  David MICHEL
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (convert bibtex bibtextm))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; User interface
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (parse-bibtex s)
-  (tree->stree (parse-bib s)))
-
-(tm-define (parse-bibtex-snippet s)
-  (parse-bibtex s))
-
-(tm-define (parse-bibtex-document s)
-  `(!file (document
-	    (style "bibliography")
-	    (body ,(parse-bibtex s)))))
-
-(tm-define (bibtex->texmacs bib)
-  (:type (-> stree stree))
-  (:synopsis "Convert a parsed BibTeX stree @t into a TeXmacs stree.")
-  (let* ((snippet? (not (func? bib '!file 1)))
-	 (body (if snippet? bib (cadr bib))))
-    body))
-
diff --git a/TeXmacs/plugins/latex/progs/convert/bibtex/tmbibtex.scm b/TeXmacs/plugins/latex/progs/convert/bibtex/tmbibtex.scm
deleted file mode 100644
index 9c30927089..0000000000
--- a/TeXmacs/plugins/latex/progs/convert/bibtex/tmbibtex.scm
+++ /dev/null
@@ -1,25 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : tmbibtex.scm
-;; DESCRIPTION : conversion of TeXmacs trees into BibTeX trees
-;; COPYRIGHT   : (C) 2010  David MICHEL
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (convert bibtex tmbibtex))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Interface
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (texmacs->bibtex x)
-  (if (tmfile? x)
-      (let ((body (tmfile-extract x 'body)))
-	(texmacs->bibtex body))
-      x))
-
diff --git a/TeXmacs/plugins/latex/progs/convert/latex/latex-command-drd.scm b/TeXmacs/plugins/latex/progs/convert/latex/latex-command-drd.scm
deleted file mode 100644
index 354e961fa8..0000000000
--- a/TeXmacs/plugins/latex/progs/convert/latex/latex-command-drd.scm
+++ /dev/null
@@ -1,1093 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : latex-command-drd.scm
-;; DESCRIPTION : Formal specification of standard LaTeX commands
-;; COPYRIGHT   : (C) 1999  Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (convert latex latex-command-drd))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Any LaTeX tag
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-rules ((latex-tag% 'x) (latex-arity% 'x 'y))
- ((latex-supports-option% 'x #t) (latex-optional-arg% 'x))
-) ;logic-rules
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; LaTeX commands
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-group latex-command-0%
-  ,(string->symbol " ")
-  ,(string->symbol ";")
-  ,(string->symbol ",")
-  ,(string->symbol ":")
-  -
-  /
-  [
-  ]
-  !
-  *
-  ,(string->symbol "|")
-  i
-  j
-  ss
-  SS
-  oe
-  OE
-  ae
-  AE
-  AA
-  DH
-  L
-  NG
-  O
-  S
-  TH
-  aa
-  dh
-  dj
-  l
-  ng
-  o
-  P
-  th
-  pounds
-  colon
-  and
-  lq
-  rq
-  quad
-  qquad
-  enspace
-  thinspace
-  par
-  smallskip
-  medskip
-  bigskip
-  noindent
-  newline
-  linebreak
-  nobreak
-  nolinebreak
-  strut
-  pagebreak
-  nopagebreak
-  newpage
-  newdoublepage
-  clearpage
-  cleardoublepage
-  newblock
-  bgroup
-  egroup
-  protect
-  cr
-  hfil
-  hfill
-  hfilll
-  appendix
-  limits
-  nolimits
-  dots
-  maketitle
-  tableofcontents
-  TeX
-  LaTeX
-  onecolumn
-  twocolumn
-  begingroup
-  endgroup
-  printindex
-  today
-  bmod
-  toprule
-  midrule
-  bottomrule
-
-  ;; AMS commands
-  dotsc
-  dotsb
-  dotsm
-  dotsi
-  dotso
-  qed
-  ;; mathtools
-  coloneqq
-  ;; temporarily
-  hline
-  hrulefill
-  ;; rewritten
-  notin
-  vert
-  Vert
-  addots
-  implies
-  iff
-  gets
-  ;; wikipedia
-  infin
-  rang
-  ;; bibtex
-  bysame
-  ;; for (e.g.) includegraphics
-  width
-  height
-  ;; miscellaneous
-  null
-  unskip
-
-  ;; Algorithms
-  AND
-  BlankLine
-  Ensure
-  ENSURE
-  FALSE
-  GLOBALS
-  NOT
-  OR
-  PRINT
-  Require
-  REQUIRE
-  Repeat
-  RETURN
-  State
-  STATE
-  TO
-  KwTo
-  TRUE
-  XOR
-  Else
-  ENDBODY
-  EndFor
-  ENDFOR
-  EndFunction
-  EndIf
-  ENDIF
-  ENDINPUTS
-  EndLoop
-  ENDLOOP
-  ENDOUTPUTS
-  EndProcedure
-  ENDWHILE
-  EndWhile
-  Loop
-) ;logic-group
-
-(logic-group latex-command-1%
-  part*
-  chapter*
-  section*
-  subsection*
-  subsubsection*
-  paragraph*
-  subparagraph*
-  nextbib
-  geometry
-  footnote
-  overline
-  underline
-  
-  
-  not
-  left
-  middle
-  right
-  big
-  Big
-  bigg
-  Bigg
-  bigl
-  Bigl
-  biggl
-  Biggl
-  bigm
-  Bigm
-  biggm
-  Biggm
-  bigr
-  Bigr
-  biggr
-  Biggr
-  bar
-  Bar
-  hat
-  Hat
-  tilde
-  Tilde
-  widehat
-  widetilde
-  vec
-  Vec
-  bm
-  ring
-  overrightarrow
-  overleftarrow
-  overleftrightarrow
-  underrightarrow
-  underleftarrow
-  underleftrightarrow
-  grave
-  Grave
-  acute
-  Acute
-  check
-  Check
-  breve
-  Breve
-  invbreve
-  abovering
-  mathring
-  dot
-  Dot
-  ddot
-  Ddot
-  dddot
-  ddddot
-  mod
-  pod
-  pmod
-  label
-  tag
-  ref
-  pageref
-  index
-  hspace
-  hspace*
-  vspace
-  vspace*
-  mspace
-  mbox
-  hbox
-  textnormal
-  text
-  not
-  substack
-  ,(string->symbol "'")
-  ,(string->symbol "`")
-  ,(string->symbol "\"")
-  ^
-  over
-  atop
-  choose
-  ~
-  =
-  u
-  v
-  H
-  t
-  c
-  d
-  b
-  k
-  r
-  textsuperscript
-  textsubscript
-  thispagestyle
-  ensuremath
-  mathord
-  mathbin
-  mathopen
-  mathpunct
-  mathop
-  mathrel
-  mathclose
-  mathalpha
-  mathinner
-  arabic
-  alph
-  Alph
-  roman
-  Roman
-  fnsymbol
-  displaylines
-  cases
-  underbrace
-  overbrace
-  phantom
-  hphantom
-  vphantom
-  smash
-  date
-  terms
-  newcounter
-  stepcounter
-  refstepcounter
-  value
-  citealt
-  citealt*
-  citealp*
-  citetext
-  citeauthor
-  citeauthor*
-  citeyear
-  onlinecite
-  citeN
-  epsfig
-  url
-  penalty
-  centerline
-  fbox
-  framebox
-  cline
-  cmidrule
-  enlargethispage
-  newlength
-  newdimen
-  newskip
-  Comment
-  COMMENT
-  For
-  ForAll
-  If
-  Input
-  KwData
-  KwResult
-  KwRet
-  lnl
-  nllabel
-  lElse
-  uElse
-  Output
-  Until
-  UNTIL
-  While
-  etalchar
-  MR
-  listpart
-  custombinding
-  cref
-  Cref
-) ;logic-group
-
-(logic-group latex-command-1%
-  ;; . needs a special treatment
-  ,(string->symbol ".")
-) ;logic-group
-
-(logic-group latex-command-2%
-  binom
-  tbinom
-  dbinom
-  cfrac
-  tfrac
-  equal
-  href
-  sideset
-  stackrel
-  underaccent
-  setcounter
-  addtocounter
-  setlength
-  addtolength
-  colorbox
-  scalebox
-  texorpdfstring
-  raisebox
-  foreignlanguage
-  Call
-  Function
-  Procedure
-  SetKw
-  SetKwData
-  SetKwFunction
-  SetKwInOut
-  ifthispageodd
-  adjustbox
-) ;logic-group
-
-(logic-group latex-command-3%
-  ifthenelse
-  resizebox
-  fcolorbox
-  @setfontsize
-  eIf
-  multicolumn
-) ;logic-group
-
-(logic-group latex-command-4% mathchoice)
-
-(logic-group latex-command-6% genfrac @startsection)
-
-(logic-rules ((latex-command% 'x) (latex-command-0% 'x))
- ((latex-arity% 'x 0) (latex-command-0% 'x))
- ((latex-command% 'x) (latex-command-1% 'x))
- ((latex-arity% 'x 1) (latex-command-1% 'x))
- ((latex-command% 'x) (latex-command-2% 'x))
- ((latex-arity% 'x 2) (latex-command-2% 'x))
- ((latex-command% 'x) (latex-command-3% 'x))
- ((latex-arity% 'x 3) (latex-command-3% 'x))
- ((latex-command% 'x) (latex-command-4% 'x))
- ((latex-arity% 'x 4) (latex-command-4% 'x))
- ((latex-command% 'x) (latex-command-6% 'x))
- ((latex-arity% 'x 6) (latex-command-6% 'x))
-) ;logic-rules
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; LaTeX commands with optional arguments
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-group latex-command-0*%
-  item
-  ,(string->symbol "\\")
-  BODY
-  ELSE
-  INPUTS
-  LOOP
-  OUTPUTS
-  REPEAT
-  hdashline
-) ;logic-group
-
-(logic-group latex-command-1*%
-  usepackage
-  documentclass
-  documentstyle
-  sqrt
-  bibitem
-  cite
-  caption
-  title
-  author
-  thanks
-  marginpar
-  part
-  chapter
-  section
-  subsection
-  subsubsection
-  paragraph
-  subparagraph
-  includegraphics
-  includegraphics*
-  makebox
-  subjclass
-  declaretheorem
-  footnotetext
-  xleftarrow
-  xrightarrow
-  xleftrightarrow
-  xminus
-  xLeftarrow
-  xRightarrow
-  xLeftrightarrow
-  xequal
-  xmapsto
-  xmapsfrom
-  citealp
-  citet
-  citep
-  citet*
-  citep*
-  Begin
-  ELSIF
-  FORALL
-  FOR
-  IF
-  WHILE
-  tcp
-  tcp*
-  tcc
-  tcc*
-  hyperref
-) ;logic-group
-
-(logic-group latex-command-2*%
-  def
-  newcommand
-  renewcommand
-  providecommand
-  newtheorem
-  newtheorem*
-  frac
-  parbox
-  ElseIf
-  uElseIf
-  lElseIf
-  ForEach
-  lForEach
-  lForAll
-  lFor
-) ;logic-group
-
-(logic-group latex-command-3*%
-  category
-  newenvironment
-  renewenvironment
-  multirow
-) ;logic-group
-
-(logic-rules ((latex-command-0% 'x) (latex-command-0*% 'x))
- ((latex-optional-arg% 'x) (latex-command-0*% 'x))
- ((latex-command-1% 'x) (latex-command-1*% 'x))
- ((latex-optional-arg% 'x) (latex-command-1*% 'x))
- ((latex-command-2% 'x) (latex-command-2*% 'x))
- ((latex-optional-arg% 'x) (latex-command-2*% 'x))
- ((latex-command-3% 'x) (latex-command-3*% 'x))
- ((latex-optional-arg% 'x) (latex-command-3*% 'x))
-) ;logic-rules
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Environments
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-group latex-environment-0%
-  begin-mdframed
-  begin-document
-  begin-abstract
-  begin-verbatim
-  begin-proof
-  begin-matrix
-  begin-pmatrix
-  begin-bmatrix
-  begin-vmatrix
-  begin-smallmatrix
-  begin-cases
-  begin-center
-  begin-flushleft
-  begin-flushright
-  begin-picture
-) ;logic-group
-
-(logic-group latex-environment-0*%
-  begin-figure
-  begin-table
-  begin-figure*
-  begin-table*
-  begin-algorithmic
-  begin-algorithm
-  begin-algorithm2e
-  begin-teaserfigure
-) ;logic-group
-
-(logic-group latex-environment-1%
-  begin-otherlanguage
-  begin-otherlanguage*
-  begin-tabbing
-  begin-thebibliography
-  begin-multicols
-) ;logic-group
-
-(logic-group latex-environment-1*% begin-array begin-tabular begin-minipage)
-
-(logic-group latex-environment-2*% begin-tabular* begin-tabularx)
-
-(logic-rules ((latex-environment% 'x) (latex-environment-0% 'x))
- ((latex-arity% 'x 0) (latex-environment-0% 'x))
- ((latex-environment% 'x) (latex-environment-1% 'x))
- ((latex-arity% 'x 1) (latex-environment-1% 'x))
- ((latex-environment% 'x) (latex-environment-2% 'x))
- ((latex-arity% 'x 2) (latex-environment-2% 'x))
- ((latex-environment% 'x) (latex-environment-3% 'x))
- ((latex-arity% 'x 3) (latex-environment-3% 'x))
- ((latex-environment-0% 'x) (latex-environment-0*% 'x))
- ((latex-optional-arg% 'x) (latex-environment-0*% 'x))
- ((latex-environment-1% 'x) (latex-environment-1*% 'x))
- ((latex-optional-arg% 'x) (latex-environment-1*% 'x))
- ((latex-environment-2% 'x) (latex-environment-2*% 'x))
- ((latex-optional-arg% 'x) (latex-environment-2*% 'x))
-) ;logic-rules
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Enunciations
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-group latex-enunciation%
-  begin-theorem
-  begin-proposition
-  begin-lemma
-  begin-corollary
-  begin-proof
-  begin-axiom
-  begin-definition
-  begin-notation
-  begin-conjecture
-  begin-remark
-  begin-note
-  begin-example
-  begin-warning
-  begin-convention
-  begin-acknowledgments
-  begin-exercise
-  begin-problem
-  begin-solution
-  begin-question
-  begin-answer
-  begin-quote-env
-  begin-quotation
-  begin-verse
-
-  begin-theorem*
-  begin-proposition*
-  begin-lemma*
-  begin-corollary*
-  begin-axiom*
-  begin-definition*
-  begin-notation*
-  begin-conjecture*
-  begin-remark*
-  begin-note*
-  begin-example*
-  begin-warning*
-  begin-convention*
-  begin-acknowledgments*
-  begin-exercise*
-  begin-problem*
-  begin-solution*
-  begin-question*
-  begin-answer*
-
-  ;; guessed
-  begin-th
-  begin-thm
-  begin-prop
-  begin-lem
-  begin-cor
-  begin-corr
-  begin-pf
-  begin-dem
-  begin-preuve
-  begin-IEEEproof
-  begin-ax
-  begin-def
-  begin-dfn
-  begin-defn
-  begin-not
-  begin-ex
-  begin-exa
-  begin-rem
-  begin-war
-  begin-conv
-  begin-exe
-  begin-exc
-  begin-exo
-  begin-prop
-  begin-sol
-  begin-ans
-  begin-acks
-) ;logic-group
-
-(logic-rules ((latex-environment-0*% 'x) (latex-enunciation% 'x)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Modifiers
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-group latex-modifier-0%
-  normalfont
-  rm
-  tt
-  sf
-  md
-  bf
-  it
-  em
-  sl
-  sc
-  rmfamily
-  ttfamily
-  sffamily
-  mdseries
-  bfseries
-  upshape
-  itshape
-  slshape
-  scshape
-  displaystyle
-  textstyle
-  scriptstyle
-  scriptscriptstyle
-  cal
-  frak
-  Bbb
-  boldmath
-  tiny
-  scriptsize
-  footnotesize
-  small
-  normalsize
-  large
-  Large
-  LARGE
-  huge
-  Huge
-  black
-  white
-  grey
-  red
-  blue
-  yellow
-  green
-  orange
-  magenta
-  brown
-  pink
-  centering
-  raggedleft
-  raggedright
-  flushleft
-  flushright
-) ;logic-group
-
-(logic-group latex-modifier-1%
-  textnormalfont
-  textrm
-  texttt
-  textsf
-  textmd
-  textbf
-  textup
-  textit
-  textsl
-  textsc
-  emph
-  mathrm
-  mathtt
-  mathsf
-  mathmd
-  mathbf
-  mathup
-  mathit
-  mathsl
-  mathnormal
-  mathcal
-  mathfrak
-  mathbb
-  mathbbm
-  mathscr
-  operatorname
-  boldsymbol
-  lowercase
-  MakeLowercase
-  uppercase
-  MakeUppercase
-  selectlanguage
-) ;logic-group
-
-(logic-group latex-modifier-1*% color)
-
-(logic-group latex-modifier-2*% textcolor)
-
-(logic-rules ((latex-modifier% 'x) (latex-modifier-0% 'x))
- ((latex-arity% 'x 0) (latex-modifier-0% 'x))
- ((latex-modifier% 'x) (latex-modifier-1% 'x))
- ((latex-arity% 'x 1) (latex-modifier-1% 'x))
- ((latex-optional-arg% 'x) (latex-modifier-1*% 'x))
- ((latex-modifier% 'x) (latex-modifier-1*% 'x))
- ((latex-arity% 'x 1) (latex-modifier-1*% 'x))
- ((latex-optional-arg% 'x) (latex-modifier-2*% 'x))
- ((latex-modifier% 'x) (latex-modifier-2*% 'x))
- ((latex-arity% 'x 2) (latex-modifier-2*% 'x))
-) ;logic-rules
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Special types of LaTeX primitives
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-group latex-control% $ & % ,(string->symbol "#") _ { }  )
-
-(logic-group latex-operator%
-  arccos
-  arcsin
-  arctan
-  arg
-  cos
-  cosh
-  cot
-  coth
-  csc
-  deg
-  det
-  dim
-  exp
-  gcd
-  hom
-  inf
-  ker
-  lg
-  lim
-  liminf
-  limsup
-  varliminf
-  varlimsup
-  ln
-  log
-  max
-  min
-  Pr
-  sec
-  sin
-  sinh
-  sup
-  tan
-  tanh
-) ;logic-group
-
-(logic-group latex-list%
-  begin-itemize
-  begin-enumerate
-  begin-description
-  begin-asparaitem
-  begin-inparaitem
-  begin-compactitem
-  begin-asparaenum
-  begin-inparaenum
-  begin-compactenum
-) ;logic-group
-
-(logic-group latex-math-environment-0%
-  begin-formula
-  begin-equation*
-  begin-math
-  begin-displaymath
-  begin-equation
-  begin-eqnarray
-  begin-eqnarray*
-  begin-flalign
-  begin-flalign*
-  begin-align
-  begin-align*
-  begin-multline
-  begin-multline*
-  begin-gather
-  begin-gather*
-  begin-eqsplit
-  begin-eqsplit*
-) ;logic-group
-
-(logic-group latex-math-environment-1% begin-alignat begin-alignat*)
-
-(logic-rules ((latex-arity% 'x 0) (latex-control% 'x))
- ((latex-arity% 'x 0) (latex-operator% 'x))
- ((latex-environment-0*% 'x) (latex-list% 'x))
- ((latex-math-environment% 'x) (latex-math-environment-0% 'x))
- ((latex-math-environment% 'x) (latex-math-environment-1% 'x))
- ((latex-environment-1% 'x) (latex-math-environment-1% 'x))
- ((latex-environment-0% 'x) (latex-math-environment-0% 'x))
-) ;logic-rules
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Counters
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-group latex-counter%
-  badness
-  enumi
-  enumii
-  enumiii
-  enumiv
-  equation
-  figure
-  inputlineno
-  mpfootnote
-  page
-  setlanguage
-  table
-) ;logic-group
-
-(logic-rules ((latex-arity% 'x 0) (latex-counter% 'x)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Names
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-group latex-name%
-  abstractname
-  appendixname
-  contentname
-  figurename
-  indexname
-  litfigurename
-  littablename
-  partname
-  refname
-  tablename
-) ;logic-group
-
-(logic-rules ((latex-arity% 'x 0) (latex-name% 'x)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Lengths
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-group latex-length%
-  ;; From latex.ltx
-  ;; -- lengths
-  @textfloatsheight
-  arraycolsep
-  arrayrulewidth
-  columnsep
-  columnseprule
-  columnwidth
-  doublerulesep
-  emergencystretch
-  evensidemargin
-  fboxrule
-  fboxsep
-  footnotesep
-  footskip
-  headheight
-  headsep
-  itemindent
-  labelsep
-  labelwidth
-  leftmargin
-  leftmargini
-  leftmarginii
-  leftmarginiii
-  leftmarginiv
-  leftmarginv
-  leftmarginvi
-  linewidth
-  listparindent
-  marginparpush
-  marginparsep
-  marginparwidth
-  oddsidemargin
-  p@
-  paperheight
-  paperwidth
-  rightmargin
-  tabbingsep
-  tabcolsep
-  textheight
-  textwidth
-  topmargin
-  unitlength
-  z@
-  @bls
-  @vpt
-  @vipt
-  @viipt
-  @viiipt
-  @ixpt
-  @xpt
-  @xipt
-  @xiipt
-  @xivpt
-  @xviipt
-  @xxpt
-  @xxvpt
-  ;; -- skips
-  topsep
-  partopsep
-  itemsep
-  parsep
-  floatsep
-  textfloatsep
-  intextsep
-  dblfloatsep
-  dbltextfloatsep
-  ;; From latex classes
-  abovecaptionskip
-  belowcaptionskip
-  bibindent
-  ;; From fleqn
-  mathindent
-  ;; Plain TeX
-  maxdimen
-  hfuzz
-  vfuzz
-  overfullrule
-  hsize
-  vsize
-  maxdepth
-  lineskiplimit
-  delimitershortfall
-  nulldelimiterspace
-  scriptspace
-  mathsurround
-  predisplaysize
-  displaywidth
-  displayindent
-  parindent
-  hangindent
-  hoffset
-  voffset
-  baselineskip
-  lineskip
-  parskip
-  abovedisplayskip
-  abovedisplayshortskip
-  belowdisplayskip
-  belowdisplayshortskip
-  leftskip
-  rightskip
-  topskip
-  splittopskip
-  tabskip
-  spaceskip
-  xspaceskip
-  parfillskip
-  thinmuskip
-  medmuskip
-  thickmuskip
-  hideskip
-  smallskipamount
-  medskipamount
-  bigskipamount
-  normalbaselineskip
-  normallineskip
-  normallineskiplimit
-  jot
-) ;logic-group
-
-(logic-rules ((latex-arity% 'x 0) (latex-length% 'x)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; To be imported as pictures
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-group latex-as-pic-0% begin-pspicture begin-pspicture* begin-tikzpicture)
-
-(logic-group latex-as-pic-1% xymatrix)
-
-(logic-rules ((latex-as-pic% 'x) (latex-as-pic-0% 'x))
- ((latex-as-pic% 'x) (latex-as-pic-1% 'x))
- ((latex-arity% 'x 0) (latex-as-pic-0% 'x))
- ((latex-arity% 'x 1) (latex-as-pic-1% 'x))
-) ;logic-rules
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; To be ignored
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-group latex-ignore-0%
-  allowbreak
-  notag
-  xspace
-  break
-  sloppy
-  makeatother
-  makeatletter
-  relax
-  qedhere
-  ignorespacesafterend
-  ignorespaces
-  balancecolumns
-  tightlist
-) ;logic-group
-
-(logic-group latex-ignore-0*% displaybreak allowdisplaybreaks)
-
-(logic-group latex-ignore-1% hyphenation)
-
-(logic-group latex-ignore-2% newdir)
-
-(logic-rules ((latex-ignore% 'x) (latex-ignore-0% 'x))
- ((latex-ignore% 'x) (latex-ignore-0*% 'x))
- ((latex-ignore% 'x) (latex-ignore-1% 'x))
- ((latex-ignore% 'x) (latex-ignore-2% 'x))
- ((latex-arity% 'x 0) (latex-ignore-0% 'x))
- ((latex-arity% 'x 0) (latex-ignore-0*% 'x))
- ((latex-arity% 'x 1) (latex-ignore-1% 'x))
- ((latex-arity% 'x 2) (latex-ignore-2% 'x))
- ((latex-optional-arg% 'x) (latex-ignore-1*% 'x))
-) ;logic-rules
diff --git a/TeXmacs/plugins/latex/progs/convert/latex/latex-define.scm b/TeXmacs/plugins/latex/progs/convert/latex/latex-define.scm
deleted file mode 100644
index 17840a041e..0000000000
--- a/TeXmacs/plugins/latex/progs/convert/latex/latex-define.scm
+++ /dev/null
@@ -1,1092 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : latex-define.scm
-;; DESCRIPTION : LaTeX definitions for TeXmacs extensions
-;; COPYRIGHT   : (C) 2005  Joris van der Hoeven
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (convert latex latex-define)
-  (:use (convert latex latex-texmacs-drd))
-) ;texmacs-module
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Extra TeXmacs symbols
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(smart-table latex-texmacs-macro
-  ;; arrows and other symbols with limits
-  (leftarrowlim "\\mathop{\\leftarrow}\\limits")
-  (rightarrowlim "\\mathop{\\rightarrow}\\limits")
-  (leftrightarrowlim "\\mathop{\\leftrightarrow}\\limits")
-  (mapstolim "\\mathop{\\mapsto}\\limits")
-  (longleftarrowlim "\\mathop{\\longleftarrow}\\limits")
-  (longrightarrowlim "\\mathop{\\longrightarrow}\\limits")
-  (longleftrightarrowlim "\\mathop{\\longleftrightarrow}\\limits")
-  (longmapstolim "\\mathop{\\longmapsto}\\limits")
-  (leftsquigarrowlim "\\mathop{\\leftsquigarrow}\\limits")
-  (rightsquigarrowlim "\\mathop{\\rightsquigarrow}\\limits")
-  (leftrightsquigarrowlim "\\mathop{\\leftrightsquigarrow}\\limits")
-  (equallim "\\mathop{=}\\limits")
-  (longequallim "\\mathop{\\longequal}\\limits")
-  (Leftarrowlim "\\mathop{\\leftarrow}\\limits")
-  (Rightarrowlim "\\mathop{\\rightarrow}\\limits")
-  (Leftrightarrowlim "\\mathop{\\leftrightarrow}\\limits")
-  (Longleftarrowlim "\\mathop{\\longleftarrow}\\limits")
-  (Longrightarrowlim "\\mathop{\\longrightarrow}\\limits")
-  (Longleftrightarrowlim "\\mathop{\\longleftrightarrow}\\limits")
-  (cdotslim "\\mathop{\\cdots}\\limits")
-
-  ;; rotated arrows and other symbols
-  (mapsfrom (!group (mbox (rotatebox (!option "origin=c") "180" (!math (mapsto)))))
-  ) ;mapsfrom
-  (longmapsfrom (!group (mbox (rotatebox (!option "origin=c") "180" (!math (longmapsto)))))
-  ) ;longmapsfrom
-  (mapmulti (!group (mbox (rotatebox (!option "origin=c") "180" (!math "\\multimap"))))
-  ) ;mapmulti
-  (leftsquigarrow (!group (mbox (rotatebox (!option "origin=c") "180" (!math (rightsquigarrow)))))
-  ) ;leftsquigarrow
-  (upequal (!group (mbox (rotatebox (!option "origin=c") "90" (!math "=")))))
-  (downequal (!group (mbox (rotatebox (!option "origin=c") "-90" (!math "=")))))
-  (longupequal (!group (mbox (rotatebox (!option "origin=c") "90" (!math (longequal)))))
-  ) ;longupequal
-  (longdownequal (!group (mbox (rotatebox (!option "origin=c") "-90" (!math (longequal)))))
-  ) ;longdownequal
-  (longupminus (!group (mbox (rotatebox (!option "origin=c") "90" (!math (longminus)))))
-  ) ;longupminus
-  (longdownminus (!group (mbox (rotatebox (!option "origin=c") "-90" (!math (longminus)))))
-  ) ;longdownminus
-  (longuparrow (!group (mbox (rotatebox (!option "origin=c") "90" (!math (longrightarrow)))))
-  ) ;longuparrow
-  (longdownarrow (!group (mbox (rotatebox (!option "origin=c") "-90" (!math (longrightarrow)))))
-  ) ;longdownarrow
-  (longupdownarrow (!group (mbox (rotatebox (!option "origin=c") "-90" (!math (longleftrightarrow))))
-                   ) ;!group
-  ) ;longupdownarrow
-  (Longuparrow (!group (mbox (rotatebox (!option "origin=c") "90" (!math (Longrightarrow)))))
-  ) ;Longuparrow
-  (Longdownarrow (!group (mbox (rotatebox (!option "origin=c") "-90" (!math (Longrightarrow)))))
-  ) ;Longdownarrow
-  (Longupdownarrow (!group (mbox (rotatebox (!option "origin=c") "-90" (!math (Longleftrightarrow))))
-                   ) ;!group
-  ) ;Longupdownarrow
-  (mapsup (!group (mbox (rotatebox (!option "origin=c") "90" (!math (mapsto))))))
-  (mapsdown (!group (mbox (rotatebox (!option "origin=c") "-90" (!math (mapsto)))))
-  ) ;mapsdown
-  (longmapsup (!group (mbox (rotatebox (!option "origin=c") "90" (!math (longmapsto)))))
-  ) ;longmapsup
-  (longmapsdown (!group (mbox (rotatebox (!option "origin=c") "-90" (!math (longmapsto)))))
-  ) ;longmapsdown
-  (upsquigarrow (!group (mbox (rotatebox (!option "origin=c") "90" (!math (rightsquigarrow)))))
-  ) ;upsquigarrow
-  (downsquigarrow (!group (mbox (rotatebox (!option "origin=c") "-90" (!math (rightsquigarrow)))))
-  ) ;downsquigarrow
-  (updownsquigarrow (!group (mbox (rotatebox (!option "origin=c") "-90" (!math (leftrightsquigarrow))))
-                    ) ;!group
-  ) ;updownsquigarrow
-  (hookuparrow (!group (mbox (rotatebox (!option "origin=c") "90" (!math (hookrightarrow)))))
-  ) ;hookuparrow
-  (hookdownarrow (!group (mbox (rotatebox (!option "origin=c") "-90" (!math (hookrightarrow)))))
-  ) ;hookdownarrow
-  (longhookuparrow (!group (mbox (rotatebox (!option "origin=c") "90" (!math (longhookrightarrow))))
-                   ) ;!group
-  ) ;longhookuparrow
-  (longhookdownarrow (!group (mbox (rotatebox (!option "origin=c") "-90" (!math (longhookrightarrow))))
-                     ) ;!group
-  ) ;longhookdownarrow
-  (Backepsilon (!group (mbox (rotatebox (!option "origin=c") "180" "E"))))
-  (Backsigma (!group (mbox (reflectbox (!math "\\Sigma")))))
-  (Mho (!group (mbox (rotatebox (!option "origin=c") "180" (!math "\\Omega")))))
-  (btimes (!group (mbox (rotatebox (!option "origin=c") "90" (!math "\\ltimes"))))
-  ) ;btimes
-
-  ;; asymptotic relations by Joris
-  (nasymp "\\not\\asymp")
-  (asympasymp "{\\asymp\\!\\!\\!\\!\\!\\!-}")
-  (nasympasymp "{\\not\\asymp\\!\\!\\!\\!\\!\\!-}")
-  (simsim "{\\approx\\!\\!\\!\\!\\!\\!-}")
-  (nsimsim "{\\not\\approx\\!\\!\\!\\!\\!\\!-}")
-  (triplesim "{\\approx\\!\\!\\!\\!\\!\\!\\sim}")
-  (ntriplesim "{\\not\\approx\\!\\!\\!\\!\\!\\!\\sim}")
-  (precprec "\\prec\\!\\!\\!\\prec")
-  (precpreceq "\\preceq\\!\\!\\!\\preceq")
-  (precprecprec "\\prec\\!\\!\\!\\prec\\!\\!\\!\\prec")
-  (precprecpreceq "\\preceq\\!\\!\\!\\preceq\\!\\!\\!\\preceq")
-  (succsucc "\\succ\\!\\!\\!\\succ")
-  (succsucceq "\\succeq\\!\\!\\!\\succeq")
-  (succsuccsucc "\\succ\\!\\!\\!\\succ\\!\\!\\!\\succ")
-  (succsuccsucceq "\\succeq\\!\\!\\!\\succeq\\!\\!\\!\\succeq")
-  (lleq "\\leq\\!\\!\\!\\leq")
-  (llleq "\\leq\\!\\!\\!\\leq\\!\\!\\!\\leq")
-  (ggeq "\\geq\\!\\!\\!\\geq")
-  (gggeq "\\geq\\!\\!\\!\\geq\\!\\!\\!\\geq")
-
-  ;; extra literal symbols
-  (mathcatalan "\\mathrm{C}")
-  (mathd "\\mathrm{d}")
-  (mathD "\\mathrm{D}")
-  (mathe "\\mathrm{e}")
-  (matheuler "\\gamma")
-  (mathGamma "\\Gamma")
-  (mathlambda "\\lambda")
-  (mathLaplace "\\Delta")
-  (mathi "\\mathrm{i}")
-  (mathpi "\\pi")
-  (Alpha "\\mathrm{A}")
-  (Beta "\\mathrm{B}")
-  (Epsilon "\\mathrm{E}")
-  (Eta "\\mathrm{H}")
-  (Iota "\\mathrm{I}")
-  (Kappa "\\mathrm{K}")
-  (Mu "\\mathrm{M}")
-  (Nu "\\mathrm{N}")
-  (Omicron "\\mathrm{O}")
-  (Chi "\\mathrm{X}")
-  (Rho "\\mathrm{P}")
-  (Tau "\\mathrm{T}")
-  (Zeta "\\mathrm{Z}")
-
-  ;; symbols from mathabx
-  ;; NOTE: we avoid using the mathabx package because it tends
-  ;; to be badly installed and incompatible with certain styles
-  (divides "\\mathrel{|}")
-  (ndivides "\\mathrel{\\nmid}")
-  (asterisk "\\mathord{*}")
-  (dottimes "\\mathbin{\\dot{\\times}}")
-  (precdot "\\mathrel{\\prec\\!\\!\\cdot")
-
-  ;; negations
-  (nin "\\not\\in")
-  (nni "\\not\\ni")
-  (notni "\\not\\ni")
-  (nequiv (!annotate "\\mathrel{\\not\\equiv}" (equiv)))
-  (nleadsto (!annotate "\\not\\leadsto" (leadsto)))
-  (napproxeq (!annotate "\\mathrel{\\not\\approxeq}" (approxeq)))
-  (nprecapprox (!annotate "\\mathrel{\\not\\precapprox}" (precapprox)))
-  (npreccurlyeq (!annotate "\\mathrel{\\not\\preccurlyeq}" (preccurlyeq)))
-  (npreceqq (!annotate "\\mathrel{\\not\\preceqq}" (preceqq)))
-  (nprecsim (!annotate "\\mathrel{\\not\\precsim}" (precsim)))
-  (nsimeq (!annotate "\\mathrel{\\not\\simeq}" (simeq)))
-  (nsubset (!annotate "\\mathrel{\\not\\subset}" (subset)))
-  (napprox (!annotate "\\mathrel{\\not\\approx}" (approx)))
-  (nsqsubset (!annotate "\\mathrel{\\not\\sqsubset}" (sqsubset)))
-  (nsqsubseteq (!annotate "\\mathrel{\\not\\sqsubseteq}" (sqsubseteq)))
-  (nsqsubseteqq (!annotate "\\mathrel{\\not\\sqsubseteqq}" (sqsubseteqq)))
-  (nsqsupset (!annotate "\\mathrel{\\not\\sqsupset}" (sqsupset)))
-  (nsqsupseteq (!annotate "\\mathrel{\\not\\sqsupseteq}" (sqsupseteq)))
-  (nsqsupseteqq (!annotate "\\mathrel{\\not\\sqsupseteqq}" (sqsupseteqq)))
-  (nsuccapprox (!annotate "\\mathrel{\\not\\succapprox}" (succapprox)))
-  (nsucccurlyeq (!annotate "\\mathrel{\\not\\succcurlyeq}" (succcurlyeq)))
-  (nsucceqq (!annotate "\\mathrel{\\not\\succeqq}" (succeqq)))
-  (nsuccsim (!annotate "\\mathrel{\\not\\succsim}" (succsim)))
-
-  ;; other extra symbols
-  (oempty "\\circ")
-  (exterior "\\wedge")
-  (Exists "\\exists")
-  (bigintwl "\\int")
-  (bigointwl "\\oint")
-  (bigintlim "\\int")
-  (bigointlim "\\oint")
-  (of ":")
-  (suchthat ":")
-  (barsuchthat "|")
-  (point ".")
-  (cdummy "\\cdot")
-  (comma "{,}")
-  (copyright "\\copyright")
-  (bignone "")
-  (nobracket "")
-  (nospace "")
-  (nocomma "")
-  (noplus "")
-  (nosymbol "")
-  (dotminus "\\mathaccent95{-}")
-  (dotpm "\\mathaccent95{\\pm}")
-  (dotmp "\\mathaccent95{\\mp}")
-  (dotamalg "\\mathaccent95{\\amalg}")
-  (dotoplus "\\mathaccent95{\\oplus}")
-  (dototimes "\\mathaccent95{\\otimes}")
-  (dotast "\\mathaccent95{*}")
-  (to "\\to")
-  (into "\\rightarrow")
-  (longminus "{-\\!\\!-}")
-  (longequal "{=\\!\\!=}")
-  (longhookrightarrow "{\\lhook\\joinrel\\relbar\\joinrel\\rightarrow}")
-  (longhookleftarrow "{\\leftarrow\\joinrel\\relbar\\joinrel\\rhook}")
-  (triangleup "\\triangle")
-  (tmprecdot "{\\prec\\hspace{-0.6em}\\cdot}\\;\\,")
-  (preceqdot "{\\preccurlyeq\\hspace{-0.6em}\\cdot}\\;\\,")
-  (llangle "{\\langle\\!\\langle}")
-  (rrangle "{\\rangle\\!\\rangle}")
-  (join "\\Join")
-  (um "-")
-  (upl "+")
-  (upm "\\pm")
-  (ump "\\mp")
-  (assign ":=")
-  (plusassign "+\\!\\!=")
-  (minusassign "-\\!\\!=")
-  (timesassign "\times\\!\\!=")
-  (overassign "/\\!\\!=")
-  (backassign "=:")
-  (pplus (mathbin "+\\!\\!\\!\\!+"))
-  (lflux "\\ll")
-  (gflux "\\gg")
-  (colons "\\,:\\,")
-  (transtype "\\,:\\!!>")
-  (tmxspace (hspace "1em"))
-  (lebar (mathrel (Yleft)))
-  (gebar (mathrel (Yright)))
-  (leangle (mathrel (angle)))
-  (geangle (mathrel (!group (mbox (reflectbox (!math (angle)))))))
-  (anglege (mathrel (!group (mbox (rotatebox (!option "origin=c") "180" (!math (angle))))))
-  ) ;anglege
-  (anglele (mathrel (!group (mbox (rotatebox (!option "origin=c") "180" (!math (!recurse (geangle)))))
-                    ) ;!group
-           ) ;mathrel
-  ) ;anglele
-  ;; (leqangle (mathrel (substack (!append (angle) "\\\\" (smash "-")))))
-  (leqangle (mathrel (!append (angle) " \\llap " (!group (raisebox "-1ex" (!math "-")))))
-  ) ;leqangle
-  (geqangle (mathrel (!group (mbox (reflectbox (!math (!recurse (leqangle))))))))
-  (legeangle (mathrel (substack (!append (leangle) "\\\\" (!recurse (anglege))))))
-  (geleangle (mathrel (substack (!append (geangle) "\\\\" (!recurse (anglele))))))
-  (udots "{\\mathinner{\\mskip1mu\\raise1pt\\vbox{\\kern7pt\\hbox{.}}\\mskip2mu\\raise4pt\\hbox{.}\\mskip2mu\\raise7pt\\hbox{.}\\mskip1mu}}"
-  ) ;udots
-  (subsetsim (underset (sim) (subset)))
-  (supsetsim (underset (sim) (supset)))
-  (rightmap (!group (!append (shortmid) "\\!\\!\\!-")))
-  (leftmap (!group (!append "-\\!\\!\\!" (shortmid))))
-  (leftrightmap (!group (!append (shortmid) "\\!\\!\\!-\\!\\!\\!" (shortmid))))
-  (LRleftrightarrow (!group (!append (Lleftarrow) "\\!\\!\\!" (Rrightarrow))))
-  (Llongleftarrow (!group (!append (Lleftarrow) "\\!" (equiv))))
-  (Llongrightarrow (!group (!append (equiv) "\\!" (Rrightarrow))))
-  (Llongleftrightarrow (!group (!append (Lleftarrow) "\\!" (equiv) "\\!" (Rrightarrow)))
-  ) ;Llongleftrightarrow
-  (threeleftarrows (mathrel (substack (!append (leftarrow) "\\\\[-0.6ex]" (leftarrow) "\\\\[-0.6ex]" (leftarrow))
-                            ) ;substack
-                   ) ;mathrel
-  ) ;threeleftarrows
-  (fourleftarrows (mathrel (substack (!append (leftarrow)
-                                       "\\\\[-0.6ex]"
-                                       (leftarrow)
-                                       "\\\\[-0.6ex]"
-                                       (leftarrow)
-                                       "\\\\[-0.6ex]"
-                                       (leftarrow)
-                                     ) ;!append
-                           ) ;substack
-                  ) ;mathrel
-  ) ;fourleftarrows
-  (threerightarrows (mathrel (substack (!append (rightarrow) "\\\\[-0.6ex]" (rightarrow) "\\\\[-0.6ex]" (rightarrow))
-                             ) ;substack
-                    ) ;mathrel
-  ) ;threerightarrows
-  (fourrightarrows (mathrel (substack (!append (rightarrow)
-                                        "\\\\[-0.6ex]"
-                                        (rightarrow)
-                                        "\\\\[-0.6ex]"
-                                        (rightarrow)
-                                        "\\\\[-0.6ex]"
-                                        (rightarrow)
-                                      ) ;!append
-                            ) ;substack
-                   ) ;mathrel
-  ) ;fourrightarrows
-  (longleftrightarrows (mathrel (substack (!append (longleftarrow) "\\\\[-0.6ex]" (longrightarrow))))
-  ) ;longleftrightarrows
-  (longleftleftarrows (mathrel (substack (!append (longleftarrow) "\\\\[-0.6ex]" (longleftarrow))))
-  ) ;longleftleftarrows
-  (longthreeleftarrows (mathrel (substack (!append (longleftarrow)
-                                            "\\\\[-0.6ex]"
-                                            (longleftarrow)
-                                            "\\\\[-0.6ex]"
-                                            (longleftarrow)
-                                          ) ;!append
-                                ) ;substack
-                       ) ;mathrel
-  ) ;longthreeleftarrows
-  (longfourleftarrows (mathrel (substack (!append (longleftarrow)
-                                           "\\\\[-0.6ex]"
-                                           (longleftarrow)
-                                           "\\\\[-0.6ex]"
-                                           (longleftarrow)
-                                           "\\\\[-0.6ex]"
-                                           (longleftarrow)
-                                         ) ;!append
-                               ) ;substack
-                      ) ;mathrel
-  ) ;longfourleftarrows
-  (longrightleftarrows (mathrel (substack (!append (longrightarrow) "\\\\[-0.6ex]" (longleftarrow))))
-  ) ;longrightleftarrows
-  (longrightrightarrows (mathrel (substack (!append (longrightarrow) "\\\\[-0.6ex]" (longrightarrow))))
-  ) ;longrightrightarrows
-  (longthreerightarrows (mathrel (substack (!append (longrightarrow)
-                                             "\\\\[-0.6ex]"
-                                             (longrightarrow)
-                                             "\\\\[-0.6ex]"
-                                             (longrightarrow)
-                                           ) ;!append
-                                 ) ;substack
-                        ) ;mathrel
-  ) ;longthreerightarrows
-  (longfourrightarrows (mathrel (substack (!append (longrightarrow)
-                                            "\\\\[-0.6ex]"
-                                            (longrightarrow)
-                                            "\\\\[-0.6ex]"
-                                            (longrightarrow)
-                                            "\\\\[-0.6ex]"
-                                            (longrightarrow)
-                                          ) ;!append
-                                ) ;substack
-                       ) ;mathrel
-  ) ;longfourrightarrows
-) ;smart-table
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Extra TeXmacs macros
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(smart-table latex-texmacs-macro
-  (three-line-table #f)
-  ;; Nullary macros
-  (tmunsc "\\_")
-  (emdash "---")
-  (tmat "\\symbol{\"40}")
-  (tmbsl "\\ensuremath{\\backslash}")
-  (tmdummy "$\\mbox{}$")
-  (TeXmacs "T\\kern-.1667em\\lower.5ex\\hbox{E}\\kern-.125emX\\kern-.1em\\lower.5ex\\hbox{\\textsc{m\\kern-.05ema\\kern-.125emc\\kern-.05ems}}"
-  ) ;TeXmacs
-  (madebyTeXmacs (footnote (!recurse (withTeXmacstext))))
-  (withTeXmacstext (!append (!translate "This document has been produced using the GNU")
-                     " "
-                     (!group (!recurse (TeXmacs)))
-                     " "
-                     (!translate "text editor")
-                     " ("
-                     (!translate "see")
-                     " "
-                     (url "https://www.texmacs.org")
-                     ")"
-                   ) ;!append
-  ) ;withTeXmacstext
-  (citewebsite (!append (!translate "This document has been written using")
-                 " GNU "
-                 (!group (!recurse (TeXmacs)))
-                 "; "
-                 (!translate "see")
-                 " "
-                 (url "https://www.texmacs.org")
-                 "."
-               ) ;!append
-  ) ;citewebsite
-  (tmmade (!recurse (tikzframe (Backsigma))))
-  (scheme "{\\sc Scheme}")
-  (tmsep ", ")
-  (tmSep "; ")
-  (pari "{\\sc Pari}")
-  (textdots "...")
-  (filldots "{\\dotfill\\hfill\\hbox{}}")
-  (infixand (text " and "))
-  (infixor (text " or "))
-  (infixiff (text " iff "))
-
-  ;; Unary macros
-  (tmrsub (ensuremath (!append "_{" (textrm 1) "}")))
-  (tmrsup (textsuperscript 1))
-  (tmverbatim (text (!group (ttfamily) (!group 1))))
-  (tmtextrm (text (!group (rmfamily) (!group 1))))
-  (tmtextsf (text (!group (sffamily) (!group 1))))
-  (tmtexttt (text (!group (ttfamily) (!group 1))))
-  (tmtextmd (text (!group (mdseries) (!group 1))))
-  (tmtextbf (text (!group (bfseries) (!group 1))))
-  (tmtextup (text (!group (upshape) (!group 1))))
-  (tmtextsl (text (!group (slshape) (!group 1))))
-  (tmtextit (text (!group (itshape) (!group 1))))
-  (tmtextsc (text (!group (scshape) (!group 1))))
-  (tmmathbf (ensuremath (!recurse (boldsymbol 1))))
-  (tmmathmd (ensuremath 1))
-  (tmop (ensuremath (operatorname 1)))
-  (tmstrong (textbf 1))
-  (tmem (!group "\\em " 1 "\\/"))
-  (tmtt (texttt 1))
-  (tmdate (today))
-  (tmname (textsc 1))
-  (tmsamp (textsf 1))
-  (tmabbr 1)
-  (tmdfn (textbf 1))
-  (tmkbd (texttt 1))
-  (tmvar (texttt 1))
-  (tmacronym (textsc 1))
-  (tmperson (textsc 1))
-  (tmscript (text (scriptsize (!math 1))))
-  (tmdef 1)
-  (dueto (textup (textbf (!append "(" 1 ") "))))
-  (op 1)
-  (todo (!group (!append (color "red!75!black") "[To do: " 1 "]")))
-  (tmoutput 1)
-  (tmerrput (!append (color "red!50!black") 1))
-  (tmtiming (!append (hfill) (footnotesize) (color "black!50") 1 (par)))
-  (tmsubtitle (thanks (!append (textit (!translate "Subtitle:")) " " 1)))
-  (tmrunningtitle (!append (!translate "Running title:") " " 1))
-  (tmrunningauthor (!append (!translate "Running author:") " " 1))
-  (tmaffiliation (!append (!nextline) 1))
-  (tmemail (!append (!nextline) (textit (!translate "Email:")) " " (texttt 1)))
-  (tmhomepage (!append (!nextline) (textit (!translate "Web:")) " " (texttt 1)))
-  (tmfnaffiliation (thanks (!append (textit (!translate "Affiliation:")) " " 1)))
-  (tmfnemail (thanks (!append (textit (!translate "Email:")) " " (texttt 1))))
-  (tmfnhomepage (thanks (!append (textit (!translate "Web:")) " " (texttt 1))))
-  (tmacmhomepage (titlenote (!append (textit (!translate "Web:")) " " 1)))
-  (tmacmmisc (titlenote (!append (textit (!translate "Misc:")) " " 1)))
-  (tmieeeemail (!append (textit (!translate "Email:")) " " 1))
-  (tmnote (thanks (!append (textit (!translate "Note:")) " " 1)))
-  (tmmisc (thanks (!append (textit (!translate "Misc:")) " " 1)))
-  (key (!append (fcolorbox "black"
-                  "gray!25!white"
-                  (raisebox "0pt" (!option "5pt") (!option "0pt") (texttt 1))
-                ) ;fcolorbox
-         (hspace "0.5pt")
-       ) ;!append
-  ) ;key
-  (uhat (underaccent (hat) 1))
-  (uwidehat (underaccent (widehat (hphantom 1)) 1))
-  (utilde (underaccent (tilde) 1))
-  (uwidetilde (underaccent (widetilde (hphantom 1)) 1))
-  (uvec (underaccent (vec) 1))
-  (ubreve (underaccent (breve) 1))
-  (uinvbreve (underaccent (invbreve) 1))
-  (ucheck (underaccent (check) 1))
-  (uring (underaccent (ring) 1))
-  (uacute (underaccent (acute) 1))
-  (ugrave (underaccent (grave) 1))
-  (underdot (underaccent (dot) 1))
-  (uddot (underaccent (ddot) 1))
-  (udddot (underaccent (dddot (hphantom 1)) 1))
-  (uddddot (underaccent (ddddot (hphantom 1)) 1))
-  (widespacing 1)
-  (gb (!append (texttt "[\\!\\![") 1 (texttt "]\\!\\!]")))
-  (gbt (!append (texttt "[\\!\\![\\!\\![") 1 (texttt "]\\!\\!]\\!\\!]")))
-
-  ;; With options
-  (tmcodeinline ((!option "") (!group (ttfamily) (!group 2))))
-
-  ;; Binary macros
-  (tmcolor (!group (color 1) (!group 2)))
-  (tmsummarizeddocumentation (trivlist (!append (item (!option "")) (mbox "") "\\large\\bf" 1))
-  ) ;tmsummarizeddocumentation
-  (tmsummarizedgrouped (trivlist (!append (item (!option "[")) (mbox "") 1)))
-  (tmsummarizedexplain (trivlist (!append (item (!option "")) (mbox "") "\\bf" 1))
-  ) ;tmsummarizedexplain
-  (tmsummarizedplain (trivlist (!append (item (!option "")) (mbox "") 1)))
-  (tmsummarizedtiny (trivlist (!append (item (!option "")) (mbox "") 1)))
-  (tmsummarizedraw (trivlist (!append (item (!option "")) (mbox "") 1)))
-  (tmsummarizedenv (trivlist (!append (item (!option "$\\bullet$")) (mbox "") 1)))
-  (tmsummarizedstd (trivlist (!append (item (!option "$\\bullet$")) (mbox "") 1)))
-  (tmsummarized (trivlist (!append (item (!option "$\\bullet$")) (mbox "") 1)))
-
-  (tmdetaileddocumentation (trivlist (!append (item (!option "")) (mbox "") "\\large\\bf" 2))
-  ) ;tmdetaileddocumentation
-  (tmdetailedgrouped (trivlist (!append (item (!option "[")) (mbox "") 2)))
-  (tmdetailedexplain (trivlist (!append (item (!option "")) (mbox "") "\\bf" 2)))
-  (tmdetailedplain (trivlist (!append (item (!option "")) (mbox "") 2)))
-  (tmdetailedtiny (trivlist (!append (item (!option "")) (mbox "") 2)))
-  (tmdetailedraw (trivlist (!append (item (!option "")) (mbox "") 2)))
-  (tmdetailedenv (trivlist (!append (item (!option "$\\circ$")) (mbox "") 2)))
-  (tmdetailedstd (trivlist (!append (item (!option "$\\circ$")) (mbox "") 2)))
-  (tmdetailed (trivlist (!append (item (!option "$\\circ$")) (mbox "") 2)))
-
-  (tmfoldeddocumentation (trivlist (!append (item (!option "")) (mbox "") "\\large\\bf" 1))
-  ) ;tmfoldeddocumentation
-  (tmunfoldeddocumentation (trivlist (!append (item (!option ""))
-                                       (mbox "")
-                                       (!group "\\large\\bf" 1)
-                                       "\\\\"
-                                       (item (!option ""))
-                                       (mbox "")
-                                       2
-                                     ) ;!append
-                           ) ;trivlist
-  ) ;tmunfoldeddocumentation
-  (tmfoldedsubsession (trivlist (!append (item (!option "$\\bullet$")) (mbox "") 1))
-  ) ;tmfoldedsubsession
-  (tmunfoldedsubsession (trivlist (!append (item (!option "$\\circ$"))
-                                    (mbox "")
-                                    1
-                                    "\\\\"
-                                    (item (!option ""))
-                                    (mbox "")
-                                    2
-                                  ) ;!append
-                        ) ;trivlist
-  ) ;tmunfoldedsubsession
-  (tmfoldedgrouped (trivlist (!append (item (!option "[")) (mbox "") 1)))
-  (tmunfoldedgrouped (trivlist (!append (item (!option "$\\lceil$"))
-                                 (mbox "")
-                                 1
-                                 "\\\\"
-                                 (item (!option "$\\lfloor$"))
-                                 (mbox "")
-                                 2
-                               ) ;!append
-                     ) ;trivlist
-  ) ;tmunfoldedgrouped
-  (tmfoldedexplain (trivlist (!append (item (!option "")) "\\bf" 1)))
-  (tmunfoldedexplain (trivlist (!append (item (!option ""))
-                                 (mbox "")
-                                 (!group "\\bf" 1)
-                                 "\\\\"
-                                 (item (!option ""))
-                                 (mbox "")
-                                 2
-                               ) ;!append
-                     ) ;trivlist
-  ) ;tmunfoldedexplain
-  (tmfoldedplain (trivlist (!append (item (!option "")) (mbox "") 1)))
-  (tmunfoldedplain (trivlist (!append (item (!option "")) (mbox "") 1 "\\\\" (item (!option "")) (mbox "") 2)
-                   ) ;trivlist
-  ) ;tmunfoldedplain
-  (tmfoldedenv (trivlist (!append (item (!option "$\\bullet$")) (mbox "") 1)))
-  (tmunfoldedenv (trivlist (!append (item (!option "$\\circ$"))
-                             (mbox "")
-                             1
-                             "\\\\"
-                             (item (!option ""))
-                             (mbox "")
-                             2
-                           ) ;!append
-                 ) ;trivlist
-  ) ;tmunfoldedenv
-  (tmfoldedstd (trivlist (!append (item (!option "$\\bullet$")) (mbox "") 1)))
-  (tmunfoldedstd (trivlist (!append (item (!option "$\\circ$"))
-                             (mbox "")
-                             1
-                             "\\\\"
-                             (item (!option ""))
-                             (mbox "")
-                             2
-                           ) ;!append
-                 ) ;trivlist
-  ) ;tmunfoldedstd
-  (tmfolded (trivlist (!append (item (!option "$\\bullet$")) (mbox "") 1)))
-  (tmunfolded (trivlist (!append (item (!option "$\\circ$"))
-                          (mbox "")
-                          1
-                          "\\\\"
-                          (item (!option ""))
-                          (mbox "")
-                          2
-                        ) ;!append
-              ) ;trivlist
-  ) ;tmunfolded
-  (tminput (trivlist (!append (item (!option (!append (color "rgb:black,10;red,9;green,4;yellow,2") 1)))
-                       (!group (!append (color "blue!50!black") (mbox "") 2))
-                     ) ;!append
-           ) ;trivlist
-  ) ;tminput
-  (tminputmath (trivlist (!append (item (!option 1)) (ensuremath 2))))
-  (tmhlink (!group (!append (color "blue") 1)))
-  (tmaction (!group (!append (color "blue") 1)))
-  (ontop (genfrac "" "" "0pt" "" 1 2))
-  (subindex (index (!append 1 "!" 2)))
-  (renderfootnote (footnotetext (!append (tmrsup 1) " " 2)))
-  (renderfootnotestar (footnotetext (!append (tmrsup 1) " " 3)))
-  (tmlinenumber (!append (custombinding 1) (tmlinenote (footnotesize 1) 2 "0cm")))
-
-  ;; Ternary macros
-  (tmsession (!group (!append (tt) 3)))
-  (tmfoldediomath (trivlist (!append (item (!option (!append (color "rgb:black,10;red,9;green,4;yellow,2") 1)))
-                              (!group (!append (color "blue!50!black") (ensuremath 2)))
-                            ) ;!append
-                  ) ;trivlist
-  ) ;tmfoldediomath
-  (tmunfoldediomath (trivlist (!append (item (!option (!append (color "rgb:black,10;red,9;green,4;yellow,2") 1)))
-                                (!group (!append (color "blue!50!black") (ensuremath 2)))
-                                (item (!option ""))
-                                (mbox "")
-                                3
-                              ) ;!append
-                    ) ;trivlist
-  ) ;tmunfoldediomath
-  (tmfoldedio (trivlist (!append (item (!option (!append (color "rgb:black,10;red,9;green,4;yellow,2") 1)))
-                          (mbox "")
-                          (!group (!append (color "blue!50!black") 2))
-                        ) ;!append
-              ) ;trivlist
-  ) ;tmfoldedio
-  (tmunfoldedio (trivlist (!append (item (!option (!append (color "rgb:black,10;red,9;green,4;yellow,2") 1)))
-                            (mbox "")
-                            (!group (!append (color "blue!50!black") 2))
-                            (item (!option ""))
-                            (mbox "")
-                            3
-                          ) ;!append
-                ) ;trivlist
-  ) ;tmunfoldedio
-  (tmlinenote (!append (tmdummy)
-                (marginpar (adjustbox (!append "right=0cm, lap=" 2 "-\\textwidth-\\marginparsep, raise=" 3)
-                             1
-                           ) ;adjustbox
-                ) ;marginpar
-              ) ;!append
-  ) ;tmlinenote
-  (subsubindex (index (!append 1 "!" 2 "!" 3)))
-  (tmref 1)
-  (glossaryentry (!append (item (!option (!append 1 (hfill)))) 2 (dotfill) 3))
-
-  ;; Tetrary macros
-  (tmscriptinput (fbox (!append (fbox (!append (sf) 2)) " " (!append (tt) 3))))
-  (tmscriptoutput (!append 4))
-  (tmconverterinput (fbox (!append (fbox (!append (sf) 2)) " " (!append (tt) 3))))
-  (tmconverteroutput (!append 4))
-  (subsubsubindex (index (!append 1 "!" 2 "!" 3 "!" 4)))
-) ;smart-table
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Deprecated extra macros
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(smart-table latex-texmacs-macro
-  (labeleqnum "\\addtocounter{equation}{-1}\\refstepcounter{equation}\\addtocounter{equation}{1})"
-  ) ;labeleqnum
-  (eqnumber (!append "\\hfill(\\theequation" (!recurse (labeleqnum)) ")"))
-  (leqnumber (!append "(\\theequation" (!recurse (labeleqnum)) ")\\hfill"))
-  (reqnumber (!append "\\hfill(\\theequation" (!recurse (labeleqnum)) ")"))
-  (skey (!recurse (key (!append "shift-" 1))))
-  (ckey (!recurse (key (!append "ctrl-" 1))))
-  (akey (!recurse (key (!append "alt-" 1))))
-  (mkey (!recurse (key (!append "meta-" 1))))
-  (hkey (!recurse (key (!append "hyper-" 1))))
-) ;smart-table
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Extra TeXmacs environments
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(smart-table latex-texmacs-environment
- ("proof" ((!begin "proof") ---))
- ("proof*" ((!begin "proof" (!option 1)) ---))
- ("leftaligned" ((!begin "flushleft") ---))
- ("rightaligned" ((!begin "flushright") ---))
- ("quoteenv" ((!begin "quote") ---))
- ("tmcode" ((!option "") ((!begin "alltt") ---)))
- ("tmparmod"
-  ((!begin "list"
-     ""
-     (!append "\\setlength{\\topsep}{0pt}"
-       "\\setlength{\\leftmargin}{"
-       1
-       "}"
-       "\\setlength{\\rightmargin}{"
-       2
-       "}"
-       "\\setlength{\\parindent}{"
-       3
-       "}"
-       "\\setlength{\\listparindent}{\\parindent}"
-       "\\setlength{\\itemindent}{\\parindent}"
-       "\\setlength{\\parsep}{\\parskip}"
-     ) ;!append
-   ) ;!begin
-   (!append "\\item[]" ---)
-  ) ;
- ) ;
- ("tmparsep"
-   (!append (begingroup) "\\setlength{\\parskip}{" 1 "}" --- (endgroup))
- ) ;
- ("tmcompact" ((!begin "tmparsep" "0em") ---))
- ("tmcompressed" ((!begin "tmparsep" "0.25em") ---))
- ("tmamplified" ((!begin "tmparsep" "0.75em") ---))
- ("tmjumpin" ((!begin "tmparmod" "1.5em" "0pt" "-1.5em") ---))
- ("tmindent" ((!begin "tmparmod" "1.5em" "0pt" "0pt") ---))
- ("tmlisting" ((!begin "linenumbers") (!append (resetlinenumber) ---)))
- ("elsequation" ((!begin "eqnarray") (!append --- "&&")))
- ("elsequation*" ((!begin "eqnarray*") (!append --- "&&")))
- ("theglossary"
-  ((!begin "list"
-     ""
-     (!append "\\setlength{\\labelwidth}{6.5em}"
-       "\\setlength{\\leftmargin}{7em}"
-       "\\small"
-     ) ;!append
-   ) ;!begin
-   ---
-  ) ;
- ) ;
-) ;smart-table
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; TeXmacs list environments
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define-macro (latex-texmacs-itemize env lab)
-  `(smart-table latex-texmacs-environment
-     (,env
-      ((!begin "itemize")
-       (!append ,"\\renewcommand{\\labelitemi}{"
-         ,lab
-         ,"}"
-         ,"\\renewcommand{\\labelitemii}{"
-         ,lab
-         ,"}"
-         ,"\\renewcommand{\\labelitemiii}{"
-         ,lab
-         ,"}"
-         ,"\\renewcommand{\\labelitemiv}{"
-         ,lab
-         ,"}"
-         ---))))
-) ;define-macro
-
-(define-macro (latex-texmacs-enumerate env lab)
-  `(smart-table latex-texmacs-environment
-     (,env ((!begin ,"enumerate" (!option ,lab)) ---)))
-) ;define-macro
-
-(define-macro (latex-texmacs-description env)
-  `(smart-table latex-texmacs-environment (,env ((!begin "description") ---)))
-) ;define-macro
-
-(latex-texmacs-itemize "itemizeminus" "$-$")
-(latex-texmacs-itemize "itemizedot" "$\\bullet$")
-(latex-texmacs-itemize "itemizearrow" "$\\rightarrow$")
-(latex-texmacs-enumerate "enumeratenumeric" "1.")
-(latex-texmacs-enumerate "enumeratenumericbracket" "1{\\textup{)}}")
-(latex-texmacs-enumerate "enumerateroman" "i.")
-(latex-texmacs-enumerate "enumerateromanbracket" "i{\\textup{)}}")
-(latex-texmacs-enumerate "enumerateromanparen" "(i)")
-(latex-texmacs-enumerate "enumerateromancap" "I.")
-(latex-texmacs-enumerate "enumeratealpha" "a{\\textup{)}}")
-(latex-texmacs-enumerate "enumeratealphabracket" "a{\\textup{)}}")
-(latex-texmacs-enumerate "enumeratealphafullparen" "(a)")
-(latex-texmacs-enumerate "enumeratealphacap" "A.")
-(latex-texmacs-description "descriptioncompact")
-(latex-texmacs-description "descriptionaligned")
-(latex-texmacs-description "descriptiondash")
-(latex-texmacs-description "descriptionlong")
-(latex-texmacs-description "descriptionparagraphs")
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Extra preamble definitions which are needed to export certain macros
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(smart-table latex-texmacs-preamble
-  (newmdenv (!append (mdfsetup (!append "linecolor=black,linewidth=0.5pt,"
-                                 "skipabove=0.5em,skipbelow=0.5em,"
-                                 "hidealllines=true,innerleftmargin=0pt,"
-                                 "innerrightmargin=0pt,innertopmargin=0pt,"
-                                 "innerbottommargin=0pt"
-                               ) ;!append
-                     ) ;mdfsetup
-              "\n"
-            ) ;!append
-  ) ;newmdenv
-  (tikzframe (!append (!ignore (tikz))
-               "\\newcommand{\\tikzframe}[1]{%\n"
-               "  \\tikz[baseline=(X.base)]\n"
-               "  \\node[draw=black,semithick,rectangle,inner sep=2pt,rounded corners=2pt]\n"
-               "  (X) {#1};}\n"
-             ) ;!append
-  ) ;tikzframe
-  (nonconverted (!append "\\newcommand{\\nonconverted}[1]{\\mbox{}}\n"))
-  (tmkeywords (!append (newcommand (tmkeywords) (!append (textbf (!translate "Keywords:")) " "))
-                "\n"
-              ) ;!append
-  ) ;tmkeywords
-  (tmacm (!append (newcommand (tmacm)
-                    (!append (textbf (!translate "A.C.M. subject classification:")) " ")
-                  ) ;newcommand
-           "\n"
-         ) ;!append
-  ) ;tmacm
-  (tmarxiv (!append (newcommand (tmarxiv)
-                      (!append (textbf (!translate "arXiv subject classification:")) " ")
-                    ) ;newcommand
-             "\n"
-           ) ;!append
-  ) ;tmarxiv
-  (tmpacs (!append (newcommand (tmpacs)
-                     (!append (textbf (!translate "P.A.C.S. subject classification:")) " ")
-                   ) ;newcommand
-            "\n"
-          ) ;!append
-  ) ;tmpacs
-  (tmmsc (!append (newcommand (tmmsc)
-                    (!append (textbf (!translate "A.M.S. subject classification:")) " ")
-                  ) ;newcommand
-           "\n"
-         ) ;!append
-  ) ;tmmsc
-  (fmtext (!append "\\newcommand{\\fmtext}[2][]{\\fntext[#1]{"
-            (!translate "Misc:")
-            " #2}}\n"
-          ) ;!append
-  ) ;fmtext
-  (tdatetext (!append "\\newcommand{\\tdatetext}[2][]{\\tnotetext[#1]{"
-               (!translate "Date:")
-               " #2}}\n"
-             ) ;!append
-  ) ;tdatetext
-  (tmisctext (!append "\\newcommand{\\tmisctext}[2][]{\\tnotetext[#1]{"
-               (!translate "Misc:")
-               " #2}}\n"
-             ) ;!append
-  ) ;tmisctext
-  (tsubtitletext (!append "\\newcommand{\\tsubtitletext}[2][]{\\tnotetext[#1]{"
-                   (!translate "Subtitle:")
-                   " #2}}\n"
-                 ) ;!append
-  ) ;tsubtitletext
-  (thankshomepage (!append "\\newcommand{\\thankshomepage}[2][]{\\thanks[#1]{"
-                    (!translate "URL:")
-                    " #2}}\n"
-                  ) ;!append
-  ) ;thankshomepage
-  (thanksemail (!append "\\newcommand{\\thanksemail}[2][]{\\thanks[#1]{"
-                 (!translate "Email:")
-                 " #2}}\n"
-               ) ;!append
-  ) ;thanksemail
-  (thanksdate (!append "\\newcommand{\\thanksdate}[2][]{\\thanks[#1]{"
-                (!translate "Date:")
-                " #2}}\n"
-              ) ;!append
-  ) ;thanksdate
-  (thanksamisc (!append "\\newcommand{\\thanksamisc}[2][]{\\thanks[#1]{"
-                 (!translate "Misc:")
-                 " #2}}\n"
-               ) ;!append
-  ) ;thanksamisc
-  (thanksmisc (!append "\\newcommand{\\thanksmisc}[2][]{\\thanks[#1]{"
-                (!translate "Misc:")
-                " #2}}\n"
-              ) ;!append
-  ) ;thanksmisc
-  (thankssubtitle (!append "\\newcommand{\\thankssubtitle}[2][]{\\thanks[#1]{"
-                    (!translate "Subtitle:")
-                    " #2}}\n"
-                  ) ;!append
-  ) ;thankssubtitle
-  (qed (!append (providecommand "\\qed" (ensuremath (Box))) "\n"))
-  (mho (!append "\\renewcommand{\\mho}{\\mbox{\\rotatebox[origin=c]{180}{$\\omega$}}}")
-  ) ;mho
-  (invbreve (!append "\\usepackage[T3,T1]{fontenc}\n"
-              "\\DeclareSymbolFont{tipa}{T3}{cmr}{m}{n}\n"
-              "\\DeclareMathAccent{\\invbreve}{\\mathalpha}{tipa}{16}\n"
-            ) ;!append
-  ) ;invbreve
-  (custombinding (!append "\\newcounter{tmcounter}\n"
-                   "\\newcommand{\\custombinding}[1]{%\n"
-                   "  \\setcounter{tmcounter}{#1}%\n"
-                   "  \\addtocounter{tmcounter}{-1}%\n"
-                   "  \\refstepcounter{tmcounter}}\n"
-                 ) ;!append
-  ) ;custombinding
-  (tmfloat (!append (!ignore (ifthenelse) (captionof) (widthof))
-             "\\newcommand{\\tmfloatcontents}{}\n"
-             "\\newlength{\\tmfloatwidth}\n"
-             "\\newcommand{\\tmfloat}[5]{\n"
-             "  \\renewcommand{\\tmfloatcontents}{#4}\n"
-             "  \\setlength{\\tmfloatwidth}{\\widthof{\\tmfloatcontents}+1in}\n"
-             "  \\ifthenelse{\\equal{#2}{small}}\n"
-             ;; FIXME: the length test frequently produces an error:
-             ;; '! Missing = inserted for \ifdim'.
-             ;; I (Joris) did not manage to understand this LaTeX mess.
-             ;; "    {\\ifthenelse{\\lengthtest{\\tmfloatwidth > \\linewidth}}\n"
-             ;; "      {\\setlength{\\tmfloatwidth}{\\linewidth}}{}}\n"
-             "    {\\setlength{\\tmfloatwidth}{0.45\\linewidth}}\n"
-             "    {\\setlength{\\tmfloatwidth}{\\linewidth}}\n"
-             "  \\begin{minipage}[#1]{\\tmfloatwidth}\n"
-             "    \\begin{center}\n"
-             "      \\tmfloatcontents\n"
-             "      \\captionof{#3}{#5}\n"
-             "    \\end{center}\n"
-             "  \\end{minipage}}\n"
-           ) ;!append
-  ) ;tmfloat
-  (addtocountergroup (!append "\\newcommand{\\addtocountergroup}[2]{}\n"))
-  (groupcommoncounter (!append "\\newcommand{\\groupcommoncounter}[1]{}\n"))
-) ;smart-table
-
-;; (define-macro (latex-texmacs-long prim x l m r)
-;;  `(smart-table latex-texmacs-preamble
-;;     (,(string->symbol (substring prim 1 (string-length prim)))
-;;      (!append
-;;       "\\def" ,prim "fill@{\\arrowfill@" ,l ,m ,r "}\n"
-;;       "\\providecommand{" ,prim "}[2][]{"
-;;       "\\ext@arrow 0099" ,prim "fill@{#1}{#2}}\n"))))
-
-(define-macro (latex-texmacs-long prim x l m r)
-  `(smart-table latex-texmacs-preamble
-     (,(string->symbol (substring prim 1 (string-length prim)))
-      (!append ,"\\providecommand{"
-        ,prim
-        ,"}[2][]{"
-        ,"\\mathop{"
-        ,x
-        ,"}\\limits_{#1}^{#2}}\n")))
-) ;define-macro
-
-(latex-texmacs-long "\\xminus"
-  "-"
-  "\\DOTSB\\relbar"
-  "\\relbar"
-  "\\DOTSB\\relbar"
-) ;latex-texmacs-long
-(latex-texmacs-long "\\xleftrightarrow"
-  "\\longleftrightarrow"
-  "\\leftarrow"
-  "\\relbar"
-  "\\rightarrow"
-) ;latex-texmacs-long
-(latex-texmacs-long "\\xmapsto"
-  "\\longmapsto"
-  "\\vdash"
-  "\\relbar"
-  "\\rightarrow"
-) ;latex-texmacs-long
-(latex-texmacs-long "\\xmapsfrom"
-  "\\leftarrow\\!\\!\\dashv"
-  "\\leftarrow"
-  "\\relbar"
-  "\\dashv"
-) ;latex-texmacs-long
-(latex-texmacs-long "\\xequal"
-  "="
-  "\\DOTSB\\Relbar"
-  "\\Relbar"
-  "\\DOTSB\\Relbar"
-) ;latex-texmacs-long
-(latex-texmacs-long "\\xLeftarrow"
-  "\\Longleftarrow"
-  "\\Leftarrow"
-  "\\Relbar"
-  "\\Relbar"
-) ;latex-texmacs-long
-(latex-texmacs-long "\\xRightarrow"
-  "\\Longrightarrow"
-  "\\Relbar"
-  "\\Relbar"
-  "\\Rightarrow"
-) ;latex-texmacs-long
-(latex-texmacs-long "\\xLeftrightarrow"
-  "\\Longleftrightarrow"
-  "\\Leftarrow"
-  "\\Relbar"
-  "\\Rightarrow"
-) ;latex-texmacs-long
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Plain style theorems
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define-macro (latex-texmacs-thmenv prim name before after . opt-mode)
-  (let* ((head (if (null? opt-mode) (list) (list `(,:mode ,(car opt-mode)))))
-         (prim* (string-append prim "*"))
-         (nonum (string-append "nn" prim))
-         (thenonum (string-append "\\the" nonum))
-        ) ;
-    `(smart-table latex-texmacs-env-preamble
-       ,@head
-       (,prim
-        (!append ,@before (newtheorem ,prim (!translate ,name)) ,@after ,"\n"))
-       (,prim*
-        (!append (newcounter ,nonum)
-          ,"\n"
-          ,"\\def"
-          ,thenonum
-          ,"{\\unskip}\n"
-          ,@before
-          (newtheorem ,prim* (!option ,nonum) (!translate ,name))
-          ,@after
-          ,"\n")))
-  ) ;let*
-) ;tm-define-macro
-
-(define-macro (latex-texmacs-theorem prim name)
-  `(latex-texmacs-thmenv ,prim ,name ,() ,())
-) ;define-macro
-
-(define-macro (latex-texmacs-remark prim name)
-  `(latex-texmacs-thmenv ,prim
-     ,name
-     ("{" (!recurse (theorembodyfont "\\rmfamily")))
-     ("}"))
-) ;define-macro
-
-(define-macro (latex-texmacs-exercise prim name)
-  `(latex-texmacs-thmenv ,prim
-     ,name
-     ("{" (!recurse (theorembodyfont "\\rmfamily\\small")))
-     ("}"))
-) ;define-macro
-
-(latex-texmacs-theorem "theorem" "Theorem")
-(latex-texmacs-theorem "proposition" "Proposition")
-(latex-texmacs-theorem "lemma" "Lemma")
-(latex-texmacs-theorem "corollary" "Corollary")
-(latex-texmacs-theorem "axiom" "Axiom")
-(latex-texmacs-remark "definition" "Definition")
-(latex-texmacs-remark "assumption" "Assumption")
-(latex-texmacs-theorem "notation" "Notation")
-(latex-texmacs-theorem "conjecture" "Conjecture")
-(latex-texmacs-remark "remark" "Remark")
-(latex-texmacs-remark "note" "Note")
-(latex-texmacs-remark "example" "Example")
-(latex-texmacs-remark "convention" "Convention")
-(latex-texmacs-remark "warning" "Warning")
-(latex-texmacs-remark "acknowledgments" "Acknowledgments")
-(latex-texmacs-remark "answer" "Answer")
-(latex-texmacs-remark "question" "Question")
-(latex-texmacs-exercise "exercise" "Exercise")
-(latex-texmacs-exercise "problem" "Problem")
-(latex-texmacs-exercise "solution" "Solution")
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Ornamented environments
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(smart-table latex-texmacs-env-preamble
- ("tmpadded" (!append (newmdenv (!option "") "tmpadded") "\n"))
- ("tmoverlined"
-   (!append (newmdenv (!option "topline=true,innertopmargin=1ex") "tmoverlined")
-     "\n"
-   ) ;!append
- ) ;
- ("tmunderlined"
-   (!append (newmdenv (!option "bottomline=true,innerbottommargin=1ex") "tmunderlined")
-     "\n"
-   ) ;!append
- ) ;
- ("tmbothlined"
-   (!append (newmdenv (!option "topline=true,bottomline=true,innertopmargin=1ex,innerbottommargin=1ex"
-                      ) ;!option
-              "tmbothlined"
-            ) ;newmdenv
-     "\n"
-   ) ;!append
- ) ;
- ("tmframed"
-   (!append (newmdenv (!option "hidealllines=false,innertopmargin=1ex,innerbottommargin=1ex,innerleftmargin=1ex,innerrightmargin=1ex"
-                      ) ;!option
-              "tmframed"
-            ) ;newmdenv
-     "\n"
-   ) ;!append
- ) ;
- ("tmornamented"
-   (!append (newmdenv (!option "hidealllines=false,innertopmargin=1ex,innerbottommargin=1ex,innerleftmargin=1ex,innerrightmargin=1ex"
-                      ) ;!option
-              "tmornamented"
-            ) ;newmdenv
-     "\n"
-   ) ;!append
- ) ;
-) ;smart-table
diff --git a/TeXmacs/plugins/latex/progs/convert/latex/latex-drd.scm b/TeXmacs/plugins/latex/progs/convert/latex/latex-drd.scm
deleted file mode 100644
index 01fb2d66b7..0000000000
--- a/TeXmacs/plugins/latex/progs/convert/latex/latex-drd.scm
+++ /dev/null
@@ -1,311 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : latex-drd.scm
-;; DESCRIPTION : Formal specification of the part of LaTeX
-;;               which is understood by TeXmacs
-;; COPYRIGHT   : (C) 1999-2022  Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (convert latex latex-drd) (:use (convert latex latex-overload)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Order in which packages should be included
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-table latex-package-priority%
- ("geometry" 10)
- ("amsmath" 20)
- ("amssymb" 30)
- ("graphicx" 40)
- ("wasysym" 50)
- ("stmaryrd" 60)
- ("textcomp" 60)
- ("enumerate" 70)
- ("epsfig" 80)
- ("mathrsfs" 90)
- ("bbm" 100)
- ("dsfont" 110)
- ("euscript" 120)
- ("multicol" 130)
- ("hyperref" 140)
- ("mathtools" 150)
- ("cleveref" 160)
-) ;logic-table
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Dependencies between style files and packages
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-table latex-depends%
- ("amsart" "amstex")
- ("amstex" "amsmath")
- ("amstex" "amsthm")
-) ;logic-table
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Dependencies of commands on packages
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-table latex-needs%
-  (!verbatim "alltt")
-  (!verbatim* "alltt")
-  (begin-alltt "alltt")
-  (begin-proof "amsthm")
-
-  (begin-tabularx "tabularx")
-  (toprule "booktabs")
-  (midrule "booktabs")
-  (bottomrule "booktabs")
-
-  (geometry "geometry")
-  (epsfig "epsfig")
-  (includegraphics "graphicx")
-  (rotatebox "graphicx")
-  (scalebox "graphicx")
-  (reflectbox "graphicx")
-  (adjustbox "adjustbox")
-
-  (mathscr "mathrsfs")
-  (EuScript "euscript")
-  (mathbbm "bbm")
-  (mathbbmss "bbm")
-  (mathds "dsfont")
-  (mathfrak "amssymb")
-  (mathbb "amssymb")
-  (theorembodyfont "theorem")
-  (substack "mathtools")
-
-  (begin-align "amsmath")
-  (begin-align* "amsmath")
-  (begin-alignat "amsmath")
-  (begin-alignat* "amsmath")
-  (begin-xalignat "amsmath")
-  (begin-xxalignat "amsmath")
-  (begin-flalign "amsmath")
-  (begin-flalign* "amsmath")
-  (begin-gather "amsmath")
-  (begin-gather* "amsmath")
-  (begin-multline "amsmath")
-  (begin-multline* "amsmath")
-  (begin-split "amsmath")
-
-  (text "amsmath")
-  (binom "amsmath")
-  (dbinom "amsmath")
-  (tbinom "amsmath")
-  (dddot "amsmath")
-  (ddddot "amsmath")
-  (genfrac "amsmath")
-  (mod "amsmath")
-  (pod "amsmath")
-  (overset "amsmath")
-  (underset "amsmath")
-  (operatorname "amsmath")
-  (boldsymbol "amsmath")
-  (overleftrightarrow "amsmath")
-  (underleftarrow "amsmath")
-  (underrightarrow "amsmath")
-  (underleftrightarrow "amsmath")
-
-  (underaccent "accents")
-  (ring "accents")
-
-  (ifthenelse "ifthen")
-  (captionof "capt-of")
-  (widthof "calc")
-
-  (color "xcolor")
-  (fcolorbox "xcolor")
-  (textcolor "xcolor")
-
-  (euro "eurosym")
-
-  (mdfsetup ("tikz" "mdframed"))
-  (begin-mdframed "mdframed")
-  (tikz "tikz")
-
-  (omicron "pslatex")
-  (multicols "multicol")
-  (bundle "epic")
-  (chunk "epic")
-  (bundle "ecltree")
-  (chunk "ecltree")
-
-  (url "hyperref")
-  (href "hyperref")
-  (hyperref "hyperref")
-
-  (cref "cleveref")
-  (Cref "cleveref")
-
-  (citet "natbib")
-  (citep "natbib")
-  (citet* "natbib")
-  (citep* "natbib")
-  (citealt "natbib")
-  (citealp "natbib")
-  (citealt* "natbib")
-  (citealp* "natbib")
-  (citetext "natbib")
-  (citeauthor "natbib")
-  (citeauthor* "natbib")
-  (citeyear "natbib")
-
-  (index "makeidx")
-  (printindex "makeidx")
-
-  (inparaenum "paralist")
-
-  (listpart "expdlist")
-
-  (ifthispageodd "scrextend")
-
-  (begin-linenumbers "lineno")
-  (resetlinenumber "lineno")
-) ;logic-table
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Page size settings
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-table latex-paper-opts%
- ("page-top" "top")
- ("page-bot" "bottom")
- ("page-odd" "left")
- ("page-even" "left")
- ("page-right" "right")
- ("page-height" "paperheight")
- ("page-width" "paperwidth")
- ("page-type" "page-type")
- ("page-orientation" "page-orientation")
-) ;logic-table
-
-(logic-table latex-paper-type%
- ("a0" "a0paper")
- ("a1" "a1paper")
- ("a2" "a2paper")
- ("a3" "a3paper")
- ("a4" "a4paper")
- ("a5" "a5paper")
- ("a6" "a6paper")
- ("a7" "papersize={74mm,105mm}")
- ("a8" "papersize={52mm,74mm")
- ("a9" "papersize={37mm,52mm}")
- ("b0" "b0paper")
- ("b1" "b1paper")
- ("b2" "b2paper")
- ("b3" "b3paper")
- ("b4" "b4paper")
- ("b5" "b5paper")
- ("b6" "b6paper")
- ("b7" "papersize={88mm,125mm}")
- ("b8" "papersize={62mm,88mm}")
- ("b9" "papersize={44mm,62mm}")
- ("legal" "legalpaper")
- ("letter" "letterpaper")
- ("executive" "executivepaper")
- ("archA" "papersize={9in,12in}")
- ("archB" "papersize={12in,18in}")
- ("archC" "papersize={18in,24in}")
- ("archD" "papersize={24in,36in}")
- ("archE" "papersize={36in,48in}")
- ("10x14" "papersize={10in,14in}")
- ("11x17" "papersize={11in,17in}")
- ("C5" "papersize={162mm,229mm}")
- ("Comm10" "papersize={297pt,684pt}")
- ("DL" "papersize={110mm,220mm}")
- ("halfletter" "papersize={140mm,216mm}")
- ("halfexecutive" "papersize={133mm,184mm}")
- ("ledger" "papersize={432mm,279mm}")
- ("Monarch" "papersize={98mm,190mm}")
- ("csheet" "papersize={432mm,559mm}")
- ("dsheet" "papersize={559mm,864mm}")
- ("esheet" "papersize={864mm,1118mm}")
- ("flsa" "papersize={216mm,330mm}")
- ("flse" "papersize={216mm,330mm}")
- ("folio" "papersize={216mm,330mm}")
- ("lecture note" "papersize={15.5cm,23.5cm}")
- ("note" "papersize={216mm,279mm}")
- ("quarto" "papersize={215mm,275mm}")
- ("statement" "papersize={140mm,216mm}")
- ("tabloid" "papersize={279mm,432mm}")
-) ;logic-table
-
-;; cpp interface with reversed access
-
-(tm-define (latex-paper-opts s)
-  (with r
-    (query `(latex-paper-opts% 'x ,s))
-    (if (nnull? r) (cdaar r) "undefined")
-  ) ;with
-) ;tm-define
-
-(tm-define (latex-paper-type s)
-  (with r
-    (query `(latex-paper-type% 'x ,s))
-    (if (nnull? r) (cdaar r) "undefined")
-  ) ;with
-) ;tm-define
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Routines for consulting the database (might become deprecated)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (latex-resolve s)
-  (define (safe-string2symbol s)
-    (if (== s "") (string->symbol " ") (string->symbol s))
-  ) ;define
-
-  (if (string-starts? s "\\") (set! s (substring s 1 (string-length s))))
-
-  (with arity
-    (logic-ref latex-arity% (safe-string2symbol s))
-    (if (logic-in? (safe-string2symbol s) latex-optional-arg%)
-      (set! arity (- -1 arity))
-    ) ;if
-    (if (string-starts? s "end-")
-      (begin
-        (set! s (string-append "begin-" (substring s 4 (string-length s))))
-        (set! arity 0)
-      ) ;begin
-    ) ;if
-    (values (safe-string2symbol s) arity)
-  ) ;with
-) ;define
-
-(tm-define (latex-arity tag)
-  "Get the arity of a LaTeX @tag"
-  (receive (s arity) (latex-resolve tag) (or arity 0))
-) ;tm-define
-
-(tm-define (latex-type tag)
-  "Get the type of a LaTeX @tag"
-  (receive (s arity)
-    (latex-resolve tag)
-    (cond ((not arity) "undefined")
-          ((logic-in? s latex-command%) "command")
-          ((logic-in? s latex-length%) "length")
-          ((logic-in? s latex-ignore%) "ignore")
-          ((logic-in? s latex-as-pic%) "as-picture")
-          ((logic-in? s latex-name%) "name")
-          ((logic-in? s latex-counter%) "counter")
-          ((logic-in? s latex-modifier%) "modifier")
-          ((logic-in? s latex-control%) "control")
-          ((logic-in? s latex-operator%) "operator")
-          ((logic-in? s latex-list%) "list")
-          ((logic-in? s latex-math-environment%) "math-environment")
-          ((logic-in? s latex-enunciation%) "enunciation")
-          ((logic-in? s latex-environment%) "environment")
-          ((logic-in? s latex-texmacs%) "texmacs")
-          ((logic-in? s latex-symbol%) "symbol")
-          ((logic-in? s latex-big-symbol%) "big-symbol")
-          (else "undefined")
-    ) ;cond
-  ) ;receive
-) ;tm-define
diff --git a/TeXmacs/plugins/latex/progs/convert/latex/latex-overload.scm b/TeXmacs/plugins/latex/progs/convert/latex/latex-overload.scm
deleted file mode 100644
index b9dd768ca4..0000000000
--- a/TeXmacs/plugins/latex/progs/convert/latex/latex-overload.scm
+++ /dev/null
@@ -1,144 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : latex-overload.scm
-;; DESCRIPTION : LaTeX re-definitions for specific styles/packages
-;; COPYRIGHT   : (C) 2005  Joris van der Hoeven
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (convert latex latex-overload)
-  (:use (convert latex latex-define)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Letter and article styles
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(smart-table latex-texmacs-macro
-  (:require (latex-has-style? "letter"))
-  (appendix ""))
-
-(define-macro (latex-texmacs-section name inside style)
-  `(smart-table latex-texmacs-macro
-     (:require (latex-has-style? ,style))
-     (,name (!append (medskip) (bigskip) "\n\n" (noindent) (textbf ,inside)))))
-
-(define-macro (latex-texmacs-paragraph name inside style)
-  `(smart-table latex-texmacs-macro
-     (:require (latex-has-style? ,style))
-     (,name (!append (smallskip) "\n\n" (noindent) (textbf ,inside)))))
-
-(latex-texmacs-section chapter (!append "\\huge " 1) "article")
-(latex-texmacs-section chapter (!append "\\huge " 1) "letter")
-(latex-texmacs-section section (!append "\\LARGE " 1) "letter")
-(latex-texmacs-section subsection (!append "\\Large " 1) "letter")
-(latex-texmacs-section subsubsection (!append "\\large " 1) "letter")
-(latex-texmacs-paragraph paragraph 1 "letter")
-(latex-texmacs-paragraph subparagraph 1 "letter")
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; amsthm package
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(smart-table latex-texmacs-macro
-  (:require (latex-depends? "amsthm"))
-  (qed #f))
-
-(smart-table latex-texmacs-environment
-  (:require (or (latex-depends? "amsthm")
-                (latex-has-texmacs-style? "amsart")))
-  ("proof" #f))
-
-(define-macro (ams-texmacs-theorem abbr full)
-  `(smart-table latex-texmacs-env-preamble
-     (:require (latex-depends? "amsthm"))
-     (,abbr (!append "\\theoremstyle{plain}\n"
-                     (newtheorem ,abbr (!translate ,full)) "\n"))))
-
-(define-macro (ams-texmacs-remark abbr full)
-  `(smart-table latex-texmacs-env-preamble
-     (:require (latex-depends? "amsthm"))
-     (,abbr (!append "\\theoremstyle{remark}\n"
-                     (newtheorem ,abbr (!translate ,full)) "\n"))))
-
-(define-macro (ams-texmacs-exercise abbr full)
-  `(smart-table latex-texmacs-env-preamble
-     (:require (latex-depends? "amsthm"))
-     (,abbr (!append "\\newtheoremstyle{indent-exercise}{3pt}{3pt}"
-                     "{\\small}{\\parindent}{\\bf\\small}{.}{.5em}{}{}\n"
-                     "\\theoremstyle{indent-exercise}\n"
-                     (newtheorem ,abbr (!translate ,full)) "\n"))))
-
-(ams-texmacs-theorem "theorem" "Theorem")
-(ams-texmacs-theorem "proposition" "Proposition")
-(ams-texmacs-theorem "lemma" "Lemma")
-(ams-texmacs-theorem "corollary" "Corollary")
-(ams-texmacs-theorem "axiom" "Axiom")
-(ams-texmacs-remark "definition" "Definition")
-(ams-texmacs-remark "assumption" "Assumption")
-(ams-texmacs-theorem "notation" "Notation")
-(ams-texmacs-theorem "conjecture" "Conjecture")
-(ams-texmacs-remark "remark" "Remark")
-(ams-texmacs-remark "note" "Note")
-(ams-texmacs-remark "example" "Example")
-(ams-texmacs-remark "convention" "Convention")
-(ams-texmacs-remark "acknowledgments" "Acknowledgments")
-(ams-texmacs-remark "warning" "Warning")
-(ams-texmacs-remark "answer" "Answer")
-(ams-texmacs-remark "question" "Question")
-(ams-texmacs-exercise "exercise" "Exercise")
-(ams-texmacs-exercise "problem" "Problem")
-(ams-texmacs-exercise "solution" "Solution")
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Framed session package
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(smart-table latex-texmacs-macro
-  (:require (latex-has-texmacs-package? "framed-session"))
-  (tmerrput ((!begin "tmframed" (!option "skipabove=0,skipbelow=0,backgroundcolor={red!15},linecolor={red!50!black}"))
-             (!append (color "red!50!black") 1)))
-  (tmfoldedsubsession
-   ((!begin "tmframed" (!option "skipabove=0,skipbelow=0,backgroundcolor={rgb:white,10;red,9;green,4;yellow,2},linecolor={black!50}"))
-    (trivlist (!append (item (!option "$\\bullet$")) (mbox "") 1))))
-  (tmunfoldedsubsession
-   (!append
-    ((!begin "tmframed" (!option "skipabove=0,skipbelow=0,backgroundcolor={rgb:white,10;red,9;green,4;yellow,2},linecolor={black!50}"))
-     (trivlist (!append (item (!option "$\\circ$")) (mbox "") 1)))
-    ((!begin "tmframed" (!option "skipabove=0,skipbelow=0,backgroundcolor={rgb:white,50;red,9;green,4;yellow,2},linecolor={black!50}"))
-     (trivlist (!append (item (!option "")) (mbox "") 2 )))))
-  (tminput
-   ((!begin "tmframed" (!option "skipabove=0,skipbelow=0,backgroundcolor={yellow!15},linecolor={black!15}"))
-    (trivlist (!append (item (!option (!append (color "rgb:black,10;red,9;green,4;yellow,2") 1)))
-                       (!group (!append (color "blue!50!black") (mbox "") 2))))))
-  (tminputmath
-   ((!begin "tmframed" (!option "skipabove=0,skipbelow=0,backgroundcolor={yellow!15},linecolor={black!15}"))
-    (trivlist (!append (item (!option 1)) (mbox "") (ensuremath 2)))))
-  
-
-  (tmfoldediomath
-   ((!begin "tmframed" (!option "skipabove=0,skipbelow=0,backgroundcolor={yellow!15},linecolor={black!15}"))
-    (trivlist (!append (item (!option (!append (color "rgb:black,10;red,9;green,4;yellow,2") 1)))
-                       (mbox "") (!group (!append (color "blue!50!black") (ensuremath 2)))))))
-  (tmunfoldediomath
-   (!append ((!begin "tmframed" (!option "skipabove=0,skipbelow=0,backgroundcolor={yellow!15},linecolor={black!15}"))
-             (trivlist (!append (item (!option (!append (color "rgb:black,10;red,9;green,4;yellow,2") 1)))
-                                (mbox "") (!group (!append (color "blue!50!black") (ensuremath 2))))))
-            ((!begin "tmframed" (!option "skipabove=0,skipbelow=0,backgroundcolor=white,linewidth=0pt"))
-             (trivlist (!append (item (!option "")) (mbox "") 3)))))
-  (tmfoldedio
-   ((!begin "tmframed" (!option "skipabove=0,skipbelow=0,backgroundcolor={yellow!15},linecolor={black!15}"))
-    (trivlist (!append (item (!option (!append (color "rgb:black,10;red,9;green,4;yellow,2") 1)))
-                       (mbox "") (!group (!append (color "blue!50!black") 2))))))
-  (tmunfoldedio
-   (!append ((!begin "tmframed" (!option "skipabove=0,skipbelow=0,backgroundcolor={yellow!15},linecolor={black!15}"))
-             (trivlist (!append (item (!option (!append (color "rgb:black,10;red,9;green,4;yellow,2") 1)))
-                                (mbox "") (!group (!append (color "blue!50!black") 2)))))
-            ((!begin "tmframed" (!option "skipabove=0,skipbelow=0,backgroundcolor=white,linewidth=0pt"))
-             (trivlist (!append (item (!option "")) (mbox "") 3))))))
diff --git a/TeXmacs/plugins/latex/progs/convert/latex/latex-symbol-drd.scm b/TeXmacs/plugins/latex/progs/convert/latex/latex-symbol-drd.scm
deleted file mode 100644
index c42ef9c733..0000000000
--- a/TeXmacs/plugins/latex/progs/convert/latex/latex-symbol-drd.scm
+++ /dev/null
@@ -1,260 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : latex-symbol-drd.scm
-;; DESCRIPTION : LaTeX symbols supported by TeXmacs
-;; COPYRIGHT   : (C) 1999  Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (convert latex latex-symbol-drd)
-  (:use (convert latex latex-command-drd)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Basic symbols and big symbols
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-group latex-symbol%
-  ;; Greek letters
-  Gamma Delta Theta Lambda Xi Pi Sigma Upsilon Phi Psi Omega varOmega
-  alpha beta gamma delta epsilon
-  varepsilon zeta eta theta vartheta
-  iota kappa lambda mu nu omicron
-  xi pi varpi rho
-  varrho sigma varsigma tau upsilon
-  phi varphi chi psi omega
-
-  ;; Binary operations
-  pm mp times div ast star circ bullet cdot
-  cap cup uplus sqcap sqcup vee wedge setminus wr
-  diamond triangleleft triangleright land lor lnot
-  oplus ominus otimes oslash odot bigcirc amalg notin
-
-  ;; Relations
-  leq le geq ge equiv models prec
-  succ sim perp preceq succeq
-  simeq mid ll gg asymp
-  parallel subset supset approx bowtie
-  subseteq supseteq cong
-  ne neq smile sqsubseteq sqsupseteq
-  doteq frown in ni propto
-  vdash dashv
-  
-  ;; Arrows
-  leftarrow rightarrow uparrow downarrow
-  Leftarrow Rightarrow Uparrow Downarrow
-  nearrow searrow swarrow nwarrow
-  leftrightarrow updownarrow Updownarrow Leftrightarrow 
-  leftharpoonup leftharpoondown rightharpoonup rightharpoondown
-  hookleftarrow hookrightarrow
-  to mapsto longmapsto
-  longrightarrow longleftarrow longleftrightarrow
-  Longrightarrow Longleftarrow Longleftrightarrow 
-  
-  ;; Miscellaneous symbols
-  ldots cdots vdots ddots hdots aleph
-  prime forall infty hbar emptyset
-  exists nabla surd triangle
-  imath jmath ell neg
-  top flat natural sharp wp
-  bot clubsuit diamondsuit heartsuit spadesuit
-  Re Im angle partial textbackslash
-  dag ddag dagger ddagger guillemotleft guillemotright
-
-  ;; Delimiters
-  uparrow Uparrow downarrow Downarrow
-  updownarrow Updownarrow
-  lfloor rfloor lceil rceil
-  langle rangle backslash
-
-  ;; Big delimiters
-  rmoustache lmoustache rgroup lgroup
-  lbrack rbrack lbrace rbrace
-  arrowvert Arrowvert bracevert)
-
-(logic-group latex-big-symbol%
-  sum prod coprod
-  bignone bigtimes bigoplus bigotimes bigodot
-  bigvee bigwedge bigsqcup bigcup bigcap bigpluscup
-  bigtriangledown bigtriangleup
-  int iint iiint iiiint idotsint bigint bigiint bigiiint bigiiiint bigidotsint
-  upint upiint upiiint upiiiint upidotsint bigupint bigupiint bigupiiint bigupiiiint bigupidotsint
-  oint oiint oiiint bigoint bigoiint bigoiiint
-  upoint upoiint upoiiint bigupoint bigupoiint bigupoiiint
-  intwl iintwl iiintwl iiiintwl idotsintwl bigintwl bigiintwl bigiiintwl bigiiiintwl bigidotsintwl
-  upintwl upiintwl upiiintwl upiiiintwl upidotsintwl bigupintwl bigupiintwl bigupiiintwl bigupiiiintwl bigupidotsintwl
-  ointwl oiintwl oiiintwl bigointwl bigoiintwl bigoiiintwl
-  upointwl upoiintwl upoiiintwl bigupointwl bigupoiintwl bigupoiiintwl)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Symbols from latexsym package
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-group latex-latexsym-symbol%
-  mho Join Box Diamond leadsto
-  sqsubset sqsupset lhd rhd unlhd unrhd)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Symbols from amssymb package
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-group latex-ams-symbol%
-  ;;`
-  ;; Box sqsubset sqsupset lhd unlhd rhd unrhd
-  Bbbk Bumpeq Cap Cup Finv Game Lleftarrow Lsh
-  Rrightarrow Rsh Subset Supset Vdash Vvdash
-  angle approxeq backepsilon backprime backsim backsimeq barwedge
-  because beth between bigstar blacklozenge blacksquare blacktriangle
-  blacktriangledown blacktriangleleft blacktriangleright box boxdot
-  boxminus boxplus boxtimes bumpeq centerdot checkmark circeq
-  circlearrowleft circlearrowright circledR circledS circledast
-  circledcirc circleddash complement curlyeqprec curlyeqsucc curlyvee
-  curlywedge curvearrowleft curvearrowright daleth diagdown diagup
-  digamma divideontimes doteqdot dotplus doublebarwedge downdownarrows
-  downharpoonleft downharpoonright eqcirc eqsim eqslantgtr eqslantless
-  eth fallingdotseq frown geqq geqslant ggg gimel gnapprox gneq gneqq
-  gnsim gtrapprox gtrdot gtreqless gtreqqless gtrless gtrsim gvertneqq
-  hslash intercal leftarrowtail leftleftarrows leftrightarrows
-  leftrightharpoons leftrightsquigarrow leftthreetimes leqq leqslant
-  lessapprox lessdot lesseqgtr lesseqqgtr lessgtr lesssim
-  llcorner lll lnapprox lneq lneqq lnsim looparrowleft looparrowright
-  lozenge lrcorner ltimes lvert lVert lvertneqq maltese measuredangle models
-  multimap nLeftarrow nLeftrightarrow nRightarrow nVDash nVdash
-  ncong nexists ngeq ngeqq ngeqslant ngtr nleftarrow nleftrightarrow
-  nleq nleqq nleqslant nless nmid nparallel nprec npreceq nrightarrow
-  nshortmid nshortparallel nsim nsubseteq nsubseteqq nsucc nsucceq
-  nsupseteq nsupseteqq ntriangleleft ntrianglelefteq ntriangleright
-  ntrianglerighteq nvDash nvdash pitchfork precapprox preccurlyeq
-  precnapprox precneqq precnsim precsim propto rhd rightarrowtail
-  rightleftarrows rightleftharpoons rightrightarrows rightsquigarrow
-  rightthreetimes risingdotseq rtimes rvert rVert shortleftarrow shortmid
-  shortparallel shortrightarrow smalldash smallfrown smallsetminus
-  smallsmile smile sphericalangle subseteqq
-  subsetneq subsetneqq succapprox succcurlyeq succnapprox succneqq
-  succnsim succsim supseteqq supsetneq supsetneqq therefore
-  thickapprox thicksim triangle triangledown trianglelefteq
-  triangleq trianglerighteq twoheadleftarrow twoheadrightarrow
-  ulcorner upharpoonleft upharpoonright upuparrows
-  urcorner vDash varkappa varnothing varpropto varsubsetneq
-  varsubsetneqq varsupsetneq varsupsetneqq vartriangle
-  vartriangleleft vartriangleright veebar yen)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Symbols from wasysym package
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-group latex-wasy-symbol%
-  agemO APLbox APLcomment APLdownarrowbox APLdown APLinput
-  APLleftarrowbox APLrightarrowbox APLstar APLuparrowbox APLup apprge
-  apprle aquarius ascnode ataribox bell blacksmiley
-  Bowtie brokenvert cancer capricornus cent checked
-  CIRCLE Circle clock conjunction currency davidsstar
-  descnode dh diameter DOWNarrow eighthnote female
-  frownie fullnote gemini halfnote hexagon hexstar
-  invdiameter inve invneg jupiter kreuz LEFTarrow
-  LEFTCIRCLE Leftcircle leftmoon leftturn libra logof
-  male mercury neptune octagon openo opposition
-  pentagon permil phone pisces pluto pointer
-  quarternote recorder RIGHTarrow RIGHTCIRCLE Rightcircle
-  rightmoon rightturn sagittarius saturn
-  scorpio smiley square sun taurus Thorn
-  thorn twonotes UParrow uranus varangle varhexagon
-  varhexstar varlightning vernal VHF virgo
-  ;;wasy-38 wasy-58 wasy-80 wasy-81 wasy-82
-  wasyBox wasyDiamond wasyleadsto wasylhd wasylozenge
-  wasypropto wasyrhd wasysqsubset wasysqsupset wasytherefore
-  wasyunlhd wasyunrhd XBox)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Symbols from stmaryrd package
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-group latex-stmary-symbol%
-  Arrownot arrownot baro bbslash binampersand bindnasrepma
-  boxast boxbar boxbox boxbslash boxcircle
-  ;;boxdot
-  boxempty boxslash curlyveedownarrow curlyveeuparrow
-  curlywedgedownarrow curlywedgeuparrow fatbslash fatsemi fatslash
-  inplus interleave large-llbracket large-rrbracket Lbag lbag
-  leftarrowtriangle leftrightarroweq leftrightarrowtriangle
-  leftslice lightning llbracket llceil llfloor llparenthesis
-  Mapsfromchar mapsfromchar Mapstochar merge minuso moo
-  niplus nnearrow nnwarrow nplus ntrianglelefteqslant
-  ntrianglerighteqslant obar oblong obslash ogreaterthan
-  olessthan ovee owedge Rbag rbag rightarrowtriangle rightslice
-  rrbracket rrceil rrfloor rrparenthesis shortdownarrow
-  shortleftarrow shortrightarrow shortuparrow ssearrow sslash
-  sswarrow subsetpluseq subsetplus supsetpluseq supsetplus talloblong
-  trianglelefteqslant trianglerighteqslant varbigcirc varcurlyvee
-  varcurlywedge varoast varobar varobslash varocircle
-  varodot varogreaterthan varolessthan varominus varoplus varoslash
-  varotimes varovee varowedge vartimes Ydown Yleft Yright Yup)
-
-(logic-group latex-stmary-big-symbol%
-  bigbox bigcurlyvee bigcurlywedge biginterleave
-  bignplus bigparallel bigsqcap)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Symbols from mathabx package
-;; NOTE: we avoid using the mathabx package because it tends
-;; to be badly installed and incompatible with certain styles
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;(logic-group latex-mathabx-symbol%
-;;  divides ndivides npreccurlyeq asterisk
-;;  dottimes nequiv precdot)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Symbols from textcomp package
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-group latex-textcomp-symbol%
-  textcent textcurrency textyen textbrokenbar textasciidieresis textlnot
-  textasciimacron textdegree degree textpm texttwosuperior textthreesuperior
-  textasciiacute textmu textonesuperior textonequarter textonehalf
-  textthreequarters texttimes textdiv)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Symbols from upgreek package
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-group latex-upgreek-symbol%
-  upalpha upbeta upgamma updelta upepsilon
-  upvarepsilon upzeta upeta uptheta upvartheta
-  upiota upkappa uplambda upmu upnu upomicron
-  upxi uppi upvarpi uprho
-  upvarrho upsigma upvarsigma uptau upupsilon
-  upphi upvarphi upchi uppsi upomega
-
-  Upalpha Upbeta Upgamma Updelta Upepsilon
-  Upzeta Upeta Uptheta Upiota Upkappa Uplambda
-  Upmu Upnu Upomicron Upxi Uppi Uprho Upsigma
-  Uptau Upupsilon Upphi Upchi Uppsi Upomega)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Rules
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-rules
-  ((latex-arity% 'x 0) (latex-symbol% 'x))
-  ((latex-arity% 'x 0) (latex-big-symbol% 'x))
-  ((latex-symbol% 'x) (latex-latexsym-symbol% 'x))
-  ((latex-needs% 'x "latexsym") (latex-latexsym-symbol% 'x))
-  ((latex-symbol% 'x) (latex-ams-symbol% 'x))
-  ((latex-needs% 'x "amssymb") (latex-ams-symbol% 'x))
-  ((latex-symbol% 'x) (latex-wasy-symbol% 'x))
-  ((latex-needs% 'x "wasysym") (latex-wasy-symbol% 'x))
-  ((latex-symbol% 'x) (latex-stmary-symbol% 'x))
-  ((latex-needs% 'x "stmaryrd") (latex-stmary-symbol% 'x))
-  ((latex-big-symbol% 'x) (latex-stmary-big-symbol% 'x))
-  ((latex-needs% 'x "stmaryrd") (latex-stmary-big-symbol% 'x))
-  ;;((latex-symbol% 'x) (latex-mathabx-symbol% 'x))
-  ;;((latex-needs% 'x "mathabx") (latex-mathabx-symbol% 'x))
-  ((latex-symbol% 'x) (latex-textcomp-symbol% 'x))
-  ((latex-needs% 'x "textcomp") (latex-textcomp-symbol% 'x))
-  ((latex-symbol% 'x) (latex-upgreek-symbol% 'x))
-  ((latex-needs% 'x "upgreek") (latex-upgreek-symbol% 'x)))
diff --git a/TeXmacs/plugins/latex/progs/convert/latex/latex-texmacs-drd.scm b/TeXmacs/plugins/latex/progs/convert/latex/latex-texmacs-drd.scm
deleted file mode 100644
index 3a4893fdb7..0000000000
--- a/TeXmacs/plugins/latex/progs/convert/latex/latex-texmacs-drd.scm
+++ /dev/null
@@ -1,712 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : latex-texmacs-drd.scm
-;; DESCRIPTION : TeXmacs extensions to LaTeX
-;; COPYRIGHT   : (C) 2005  Joris van der Hoeven
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (convert latex latex-texmacs-drd)
-  (:use (convert latex latex-symbol-drd))
-) ;texmacs-module
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Extra TeXmacs symbols
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-group latex-texmacs-symbol%
-  ;; arrows and other symbols with limits
-  leftarrowlim
-  rightarrowlim
-  leftrightarrowlim
-  mapstolim
-  longleftarrowlim
-  longrightarrowlim
-  longleftrightarrowlim
-  longmapstolim
-  leftsquigarrowlim
-  rightsquigarrowlim
-  leftrightsquigarrowlim
-  equallim
-  longequallim
-  Leftarrowlim
-  Rightarrowlim
-  Leftrightarrowlim
-  Longleftarrowlim
-  Longrightarrowlim
-  Longleftrightarrowlim
-  cdotslim
-
-  ;; further arrows
-  threeleftarrows
-  threerightarrows
-  fourleftarrows
-  fourrightarrows
-  longleftrightarrows
-  longleftleftarrows
-  longthreeleftarrows
-  longthreerightarrows
-  longrightleftarrows
-  longrightrightarrows
-  longfourleftarrows
-  longfourrightarrows
-  LRleftrightarrow
-  Llongleftarrow
-  Llongrightarrow
-  Llongleftrightarrow
-
-  ;; rotated arrows and other symbols
-  mapsfrom
-  longmapsfrom
-  mapmulti
-  leftsquigarrow
-  upequal
-  downequal
-  longupequal
-  longdownequal
-  longupminus
-  longdownminus
-  longuparrow
-  longdownarrow
-  longupdownarrow
-  Longuparrow
-  Longdownarrow
-  Longupdownarrow
-  mapsup
-  mapsdown
-  longmapsup
-  longmapsdown
-  upsquigarrow
-  downsquigarrow
-  updownsquigarrow
-  hookuparrow
-  hookdownarrow
-  longhookuparrow
-  longhookdownarrow
-  Backepsilon
-  Backsigma
-  Mho
-  btimes
-
-  ;; asymptotic relations by Joris
-  nasymp
-  asympasymp
-  nasympasymp
-  simsim
-  nsimsim
-  precprec
-  precpreceq
-  precprecprec
-  precprecpreceq
-  succsucc
-  succsucceq
-  succsuccsucc
-  succsuccsucceq
-  lleq
-  llleq
-  ggeq
-  gggeq
-  triplesim
-  ntriplesim
-
-  ;; replacements for symbols from mathabx
-  divides
-  ndivides
-  asterisk
-  dottimes
-  precdot
-
-  ;; extra literal symbols
-  mathcatalan
-  mathd
-  mathD
-  mathe
-  matheuler
-  mathGamma
-  mathlambda
-  mathLaplace
-  mathi
-  mathpi
-  Alpha
-  Beta
-  Epsilon
-  Eta
-  Iota
-  Kappa
-  Mu
-  Nu
-  Omicron
-  Chi
-  Rho
-  Tau
-  Zeta
-
-  ;; negations
-  nin
-  nni
-  notni
-  nequiv
-  nleadsto
-  npreccurlyeq
-  npreceqq
-  nprecsim
-  nsimeq
-  nsubset
-  napprox
-  nsqsubset
-  nsqsubseteq
-  nsqsubseteqq
-  nsqsupset
-  nsqsupseteq
-  nsqsupseteqq
-  nsucccurlyeq
-  nsucceqq
-  nsuccsim
-
-  ;; other extra symbols
-  oempty
-  exterior
-  Exists
-  bigintwl
-  bigointwl
-  of
-  suchthat
-  barsuchthat
-  asterisk
-  point
-  cdummy
-  comma
-  copyright
-  bignone
-  nobracket
-  nospace
-  nocomma
-  noplus
-  nosymbol
-  dotminus
-  dotpm
-  dotmp
-  dotamalg
-  dottimes
-  dotoplus
-  dototimes
-  dotast
-  into
-  longminus
-  longequal
-  longhookrightarrow
-  longhookleftarrow
-  triangleup
-  tmprecdot
-  preceqdot
-  llangle
-  rrangle
-  join
-  um
-  upl
-  upm
-  ump
-  pplus
-  assign
-  plusassign
-  minusassign
-  timesassign
-  overassign
-  backassign
-  lflux
-  gflux
-  colons
-  transtype
-  lebar
-  gebar
-  leangle
-  geangle
-  leqangle
-  geqangle
-  anglele
-  anglege
-  legeangle
-  geleangle
-  udots
-  subsetsim
-  supsetsim
-  rightmap
-  leftmap
-  leftrightmap
-  tmxspace
-) ;logic-group
-
-(logic-rules ((latex-texmacs-arity% 'x 0) (latex-texmacs-symbol% 'x))
- ((latex-symbol% 'x) (latex-texmacs-symbol% 'x))
-) ;logic-rules
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Extra TeXmacs macros
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-group latex-texmacs-0%
-  tmunsc
-  emdash
-  tmhrule
-  tmat
-  tmbsl
-  tmdummy
-  TeXmacs
-  madebyTeXmacs
-  withTeXmacstext
-  citewebsite
-  tmmade
-  scheme
-  tmsep
-  tmSep
-  pari
-  qed
-  textdots
-  hrule
-  filldots
-  infixand
-  infixor
-  infixiff
-) ;logic-group
-
-(logic-group latex-texmacs-1%
-  three-line-table
-  key
-  tmrsub
-  tmrsup
-  keepcase
-  tmtextrm
-  tmtextsf
-  tmtexttt
-  tmtextmd
-  tmtextbf
-  tmtextup
-  tmtextsl
-  tmtextit
-  tmtextsc
-  tmmathbf
-  tmmathmd
-  tmverbatim
-  tmop
-  tmstrong
-  tmem
-  tmtt
-  tmname
-  tmsamp
-  tmabbr
-  tmdfn
-  tmkbd
-  tmvar
-  tmacronym
-  tmperson
-  tmscript
-  tmdef
-  dueto
-  op
-  todo
-  tmdate
-  tmoutput
-  tmerrput
-  tmtiming
-  tmsubtitle
-  tmrunningtitle
-  tmrunningauthor
-  tmaffiliation
-  tmemail
-  tmhomepage
-  tmfnaffiliation
-  tmfnemail
-  tmfnhomepage
-  tmacmhomepage
-  tmacmmisc
-  tmieeeemail
-  tmnote
-  tmmisc
-  uhat
-  uwidehat
-  utilde
-  uwidetilde
-  uvec
-  ubreve
-  uinvbreve
-  ucheck
-  uring
-  uacute
-  ugrave
-  underdot
-  uddot
-  udddot
-  uddddot
-  widespacing
-  nonconverted
-  groupcommoncounter
-  ;; NOTE: for personal use from vdh style package
-  gb
-  gbt
-) ;logic-group
-
-(logic-group latex-texmacs-1*% tmcodeinline)
-
-(logic-group latex-texmacs-2%
-  tmcolor
-  tmsummarizeddocumentation
-  tmsummarizedgrouped
-  tmsummarizedexplain
-  tmsummarizedplain
-  tmsummarizedtiny
-  tmsummarizedraw
-  tmsummarizedenv
-  tmsummarizedstd
-  tmsummarized
-  tmdetaileddocumentation
-  tmdetailedgrouped
-  tmdetailedexplain
-  tmdetailedplain
-  tmdetailedtiny
-  tmdetailedraw
-  tmdetailedenv
-  tmdetailedstd
-  tmdetailed
-  tmfoldeddocumentation
-  tmunfoldeddocumentation
-  tmfoldedsubsession
-  tmunfoldedsubsession
-  tmfoldedgrouped
-  tmunfoldedgrouped
-  tmfoldedexplain
-  tmunfoldedexplain
-  tmfoldedplain
-  tmunfoldedplain
-  tmfoldedenv
-  tmunfoldedenv
-  tmfoldedstd
-  tmunfoldedstd
-  tmfolded
-  tmunfolded
-  tminput
-  tminputmath
-  tmhlink
-  tmaction
-  ontop
-  subindex
-  renderfootnote
-  tmlinenumber
-  addtocountergroup
-) ;logic-group
-
-(logic-group latex-texmacs-3%
-  tmsession
-  tmfoldedio
-  tmunfoldedio
-  tmfoldediomath
-  tmunfoldediomath
-  tmlinenote
-  subsubindex
-  tmref
-  glossaryentry
-  natbib-triple
-  renderfootnotestar
-) ;logic-group
-
-(logic-group latex-texmacs-4%
-  tmscriptinput
-  tmscriptoutput
-  tmconverterinput
-  tmconverteroutput
-  subsubsubindex
-) ;logic-group
-
-(logic-rules ((latex-texmacs% 'x) (latex-texmacs-0% 'x))
- ((latex-texmacs% 'x) (latex-texmacs-1% 'x))
- ((latex-texmacs% 'x) (latex-texmacs-1*% 'x))
- ((latex-texmacs% 'x) (latex-texmacs-2% 'x))
- ((latex-texmacs% 'x) (latex-texmacs-3% 'x))
- ((latex-texmacs% 'x) (latex-texmacs-4% 'x))
- ((latex-texmacs-arity% 'x 0) (latex-texmacs-0% 'x))
- ((latex-texmacs-arity% 'x 1) (latex-texmacs-1% 'x))
- ((latex-texmacs-arity% 'x 1) (latex-texmacs-1*% 'x))
- ((latex-texmacs-arity% 'x 2) (latex-texmacs-2% 'x))
- ((latex-texmacs-arity% 'x 3) (latex-texmacs-3% 'x))
- ((latex-texmacs-arity% 'x 4) (latex-texmacs-4% 'x))
- ((latex-texmacs-option% 'x #t) (latex-texmacs-1*% 'x))
- ((latex-command-0% 'x) (latex-texmacs-0% 'x))
- ((latex-command-1% 'x) (latex-texmacs-1% 'x))
- ((latex-command-1*% 'x) (latex-texmacs-1*% 'x))
- ((latex-command-2% 'x) (latex-texmacs-2% 'x))
- ((latex-command-3% 'x) (latex-texmacs-3% 'x))
- ((latex-command-4% 'x) (latex-texmacs-4% 'x))
-) ;logic-rules
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Extra TeXmacs environments
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-table latex-texmacs-env-arity%
- ("proof" 0)
- ("proof*" 1)
- ("leftaligned" 0)
- ("rightaligned" 0)
- ("tmcode" 0)
- ("tmparmod" 3)
- ("tmparsep" 1)
- ("tmcompact" 0)
- ("tmcompressed" 0)
- ("tmamplified" 0)
- ("tmjumpin" 0)
- ("tmindent" 0)
- ("tmlisting" 0)
- ("elsequation" 0)
- ("elsequation*" 0)
- ("theglossary" 1)
-) ;logic-table
-
-(logic-table latex-texmacs-option% ("tmcode" #t))
-
-(logic-group latex-texmacs-environment-0%
-  begin-proof
-  begin-leftaligned
-  begin-rightaligned
-  begin-quoteenv
-  begin-tmcompact
-  begin-tmcompressed
-  begin-tmamplified
-  begin-tmjumpin
-  begin-tmindent
-  begin-tmlisting
-  begin-elsequation
-  begin-elsequation*
-) ;logic-group
-
-(logic-group latex-texmacs-environment-0*% begin-tmcode)
-
-(logic-group latex-texmacs-environment-1%
-  begin-proof*
-  begin-tmparsep
-  begin-theglossary
-) ;logic-group
-
-(logic-group latex-texmacs-environment-3% begin-tmparmod)
-
-(logic-rules ((latex-texmacs-arity% 'x 0) (latex-texmacs-environment-0% 'x))
- ((latex-texmacs-arity% 'x 0) (latex-texmacs-environment-0*% 'x))
- ((latex-texmacs-arity% 'x 1) (latex-texmacs-environment-1% 'x))
- ((latex-texmacs-arity% 'x 3) (latex-texmacs-environment-3% 'x))
- ((latex-texmacs-option% 'x #t) (latex-texmacs-environment-0*% 'x))
- ((latex-environment-0% 'x) (latex-texmacs-environment-0% 'x))
- ((latex-environment-0*% 'x) (latex-texmacs-environment-0*% 'x))
- ((latex-environment-1% 'x) (latex-texmacs-environment-1% 'x))
- ((latex-environment-3% 'x) (latex-texmacs-environment-3% 'x))
-) ;logic-rules
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; TeXmacs list environments
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-table latex-texmacs-env-arity%
- ("itemizeminus" 0)
- ("itemizedot" 0)
- ("itemizearrow" 0)
- ("enumeratenumeric" 0)
- ("enumeratenumericbracket" 0)
- ("enumerateroman" 0)
- ("enumerateromanbracket" 0)
- ("enumerateromanparen" 0)
- ("enumerateromancap" 0)
- ("enumeratealpha" 0)
- ("enumeratealphabracket" 0)
- ("enumeratealphafullparen" 0)
- ("enumeratealphacap" 0)
- ("descriptioncompact" 0)
- ("descriptionaligned" 0)
- ("descriptiondash" 0)
- ("descriptionlong" 0)
- ("descriptionparagraphs" 0)
-) ;logic-table
-
-(logic-group latex-texmacs-list%
-  begin-itemizeminus
-  begin-itemizedot
-  begin-itemizearrow
-  begin-enumeratenumeric
-  begin-enumeratenumericbracket
-  begin-enumerateroman
-  begin-enumerateromanbracket
-  begin-enumerateromanparen
-  begin-enumerateromancap
-  begin-enumeratealpha
-  begin-enumeratealphabracket
-  begin-enumeratealphafullparen
-  begin-enumeratealphacap
-  begin-descriptioncompact
-  begin-descriptionaligned
-  begin-descriptiondash
-  begin-descriptionlong
-  begin-descriptionparagraphs
-) ;logic-group
-
-(logic-rules ((latex-texmacs-arity% 'x 0) (latex-texmacs-list% 'x))
- ((latex-list% 'x) (latex-texmacs-list% 'x))
-) ;logic-rules
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Commands requiring special definitions in the preamble
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-group latex-texmacs-preamble-command%
-  newmdenv
-  tikzframe
-  tmkeywords
-  tmacm
-  tmarxiv
-  tmpacs
-  tmmsc
-  fmtext
-  tdatetext
-  tmisctext
-  tsubtitletext
-  thankshomepage
-  thanksemail
-  thanksdate
-  thanksamisc
-  thanksmisc
-  thankssubtitle
-  mho
-  tmfloat
-
-  xminus
-  xleftrightarrow
-  xmapsto
-  xmapsfrom
-  xequal
-  xLeftarrow
-  xRightarrow
-  xLeftrightarrow
-) ;logic-group
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Environments requiring special definitions in the preamble
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-group latex-texmacs-env-preamble-environment%
-  "tmpadded"
-  "tmoverlined"
-  "tmunderlined"
-  "tmbothlined"
-  "tmframed"
-  "tmornamented"
-) ;logic-group
-
-(logic-group latex-texmacs-theorem-environment%
-  "theorem"
-  "proposition"
-  "lemma"
-  "corollary"
-  "axiom"
-  "definition"
-  "assumption"
-  "notation"
-  "conjecture"
-  "remark"
-  "note"
-  "example"
-  "convention"
-  "warning"
-  "acknowledgments"
-  "answer"
-  "question"
-  "exercise"
-  "problem"
-  "solution"
-
-  "theorem*"
-  "proposition*"
-  "lemma*"
-  "corollary*"
-  "axiom*"
-  "definition*"
-  "notation*"
-  "conjecture*"
-  "remark*"
-  "note*"
-  "example*"
-  "convention*"
-  "warning*"
-  "acknowledgments*"
-  "answer*"
-  "question*"
-  "exercise*"
-  "problem*"
-  "solution*"
-) ;logic-group
-
-(logic-group latex-texmacs-theorem%
-  begin-theorem
-  begin-proposition
-  begin-lemma
-  begin-corollary
-  begin-axiom
-  begin-definition
-  begin-notation
-  begin-conjecture
-  begin-remark
-  begin-note
-  begin-example
-  begin-convention
-  begin-warning
-  begin-acknowledgments
-  begin-answer
-  begin-question
-  begin-exercise
-  begin-problem
-  begin-solution
-
-  begin-theorem*
-  begin-proposition*
-  begin-lemma*
-  begin-corollary*
-  begin-axiom*
-  begin-definition*
-  begin-notation*
-  begin-conjecture*
-  begin-remark*
-  begin-note*
-  begin-example*
-  begin-convention*
-  begin-warning*
-  begin-acknowledgments*
-  begin-answer*
-  begin-question*
-  begin-exercise*
-  begin-problem*
-  begin-solution*
-) ;logic-group
-
-(logic-rules ((latex-texmacs-env-preamble-environment% 'x)
-              (latex-texmacs-theorem-environment% 'x)
-             ) ;
- ((latex-texmacs-arity% 'x 0) (latex-texmacs-theorem% 'x))
- ((latex-environment-0% 'x) (latex-texmacs-theorem% 'x))
-) ;logic-rules
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; These macros are defined by TeXmacs in certain styles
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-group latex-texmacs-0% appendix)
-
-(logic-group latex-texmacs-1% chapter section subsection paragraph subparagraph)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Deprecated extra macros
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-group latex-texmacs-0% labeleqnum eqnumber leqnumber reqnumber)
-
-(logic-group latex-texmacs-1% skey ckey akey mkey hkey)
diff --git a/TeXmacs/plugins/latex/progs/convert/latex/latex-tools.scm b/TeXmacs/plugins/latex/progs/convert/latex/latex-tools.scm
deleted file mode 100644
index 2b603f8273..0000000000
--- a/TeXmacs/plugins/latex/progs/convert/latex/latex-tools.scm
+++ /dev/null
@@ -1,630 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : latex-tools.scm
-;; DESCRIPTION : Routines for expansion of macros and preamble construction
-;; COPYRIGHT   : (C) 2005  Joris van der Hoeven
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (convert latex latex-tools)
-  (:use (convert latex latex-drd)
-        (convert latex texout)))
-
-(tm-define tmtex-cjk-document? #f)
-(tm-define tmtex-use-catcodes? #f)
-(tm-define tmtex-use-unicode? #f)
-(tm-define tmtex-use-macros? #f)
-
-(define latex-language "english")
-(define latex-style "generic")
-(define latex-packages '())
-(define latex-extra-packages '())
-(define latex-virtual-packages '())
-(define latex-all-packages '())
-(define latex-texmacs-style "generic")
-(define latex-texmacs-packages '())
-(define latex-dependencies '("generic"))
-
-(define latex-packages-option (make-ahash-table))
-(define latex-uses-table (make-ahash-table))
-(define latex-catcode-table (make-ahash-table))
-(define latex-macro-table (make-ahash-table))
-(define latex-env-table (make-ahash-table))
-(define latex-preamble-table (make-ahash-table))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Setting and testing global parameters
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (latex-set-language lan)
-  (set! latex-language lan))
-
-(tm-define (latex-set-style sty)
-  (set! latex-style sty)
-  (latex-set-dependencies))
-
-(tm-define (latex-set-packages ps)
-  (set! latex-packages ps)
-  (latex-set-dependencies))
-
-(tm-define (latex-set-extra ps)
-  (set! latex-extra-packages ps)
-  (latex-set-dependencies))
-
-(tm-define (latex-add-extra p)
-  (when (nin? p latex-extra-packages)
-    (set! latex-extra-packages (cons p latex-extra-packages))
-    (latex-set-dependencies)))
-
-(tm-define (latex-set-virtual-packages ps)
-  (set! latex-virtual-packages ps)
-  (latex-set-dependencies))
-
-(tm-define (latex-set-texmacs-style sty)
-  (set! latex-texmacs-style sty))
-
-(tm-define (latex-set-texmacs-packages l)
-  (set! latex-texmacs-packages l))
-
-(define (latex-set-dependencies)
-  (set! latex-all-packages
-        (list-remove-duplicates (append latex-packages
-                                        latex-extra-packages
-                                        latex-virtual-packages)))
-  (set! latex-dependencies
-        (latex-packages-dependencies (cons latex-style latex-all-packages))))
-
-(tm-define (latex-has-style? sty)
-  (== sty latex-style))
-
-(tm-define (latex-has-package? p)
-  (in? p latex-packages))
-
-(tm-define (latex-has-texmacs-style? sty)
-  (== sty latex-texmacs-style))
-
-(tm-define (latex-has-texmacs-package? p)
-  (in? p latex-texmacs-packages))
-
-(tm-define (latex-depends? p)
-  (in? p latex-dependencies))
-
-(tm-define (latex-book-style?)
-  (in? latex-style '("book" "svmono")))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Catcode generation
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (latex-catcode-defs-char c)
-  (let* ((s (string-convert (list->string (list c)) "Cork" "UTF-8"))
-         (r (string-convert s "UTF-8" "LaTeX")))
-    (if (and (!= r s) (!= (string c) "\n"))
-      (ahash-set! latex-catcode-table (string c) r))))
-
-(define (latex-catcode-defs-sub doc)
-  (cond ((string? doc) (for-each latex-catcode-defs-char (string->list doc)))
-        ((list? doc) (for-each latex-catcode-defs-sub doc))))
-
-(define (latex-catcode-defs-char* c)
-  (if (in? c '(#\< #\>))
-    (ahash-set! latex-catcode-table (string c)
-                (number->string (char->integer c)))))
-
-(define (env? t x)
-  (and (list>0? t) (func? (car t) '!begin) (list>1? (car t)) (== x (cadar t))))
-
-(define (latex-is-math? t)
-  (or (func? t '!math)
-      (func? t '!eqn)
-      (env? t "equation")
-      (env? t "gather")
-      (env? t "multline")
-      (env? t "split")
-      (env? t "equation*")
-      (env? t "gather*")
-      (env? t "multline*")
-      (env? t "align")
-      (env? t "flalign")
-      (env? t "alignat")
-      (env? t "align*")
-      (env? t "flalign*")
-      (env? t "alignat*")))
-
-(define (latex-is-text? t)
-  (func? t 'text))
-
-(define (latex-is-verb? t)
-  ;; TODO: consider also macros which expect verbatim args
-  (or (func? t '!verb)      (func? t '!verbatim)
-      (func? t '!verbatim*) (func? t 'tmverbatim)))
-
-(define (latex-catcode-defs-sub* doc text?)
-  (cond ((and text? (string? doc))
-         (for-each latex-catcode-defs-char* (string->list doc)))
-        ((and (list? doc) (latex-is-text? doc))
-         (for-each (cut latex-catcode-defs-sub* <> #t) doc))
-        ((and (list? doc) (or (latex-is-math? doc) (latex-is-verb? doc)))
-         (for-each (cut latex-catcode-defs-sub* <> #f) doc))
-        ((list? doc)
-         (for-each (cut latex-catcode-defs-sub* <> text?) doc))))
-
-(define (latex-catcode-def key im)
-  (string-append "\\catcode`\\" key "=\\active \\def" key "{" im "}\n"))
-
-(tm-define (latex-catcode-defs doc)
-  (:synopsis "Return necessary catcode definitions for @doc")
-  (string-append
-    (if tmtex-use-catcodes?
-      (begin
-        (set! latex-catcode-table (make-ahash-table))
-        (latex-catcode-defs-sub doc)
-        (let* ((l1 (ahash-table->list latex-catcode-table))
-               (l2 (list-sort l1 (lambda (x y) (string<=? (car x) (car y)))))
-               (l3 (map (lambda (x) (latex-catcode-def (car x) (cdr x))) l2)))
-          (apply string-append l3))) "")
-    (begin
-      (set! latex-catcode-table (make-ahash-table))
-      (latex-catcode-defs-sub* doc #t)
-      (let* ((l1 (ahash-table->list latex-catcode-table))
-             (l2 (list-sort l1 (lambda (x y) (string<=? (car x) (car y)))))
-             (keys (map car l2))
-             (ims (map (lambda (x)
-                         (string-append
-                           "\n\\fontencoding{T1}\\selectfont\\symbol{"
-                           (cdr x)
-                           "}\\fontencoding{\\encodingdefault}"))
-                       l2))
-             (l3 (map latex-catcode-def keys ims)))
-        (apply string-append l3)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Subroutines for reading the database
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (env-begin? x)
-  (or (func? x '!begin) (func? x '!begin*)))
-
-(define (latex-texmacs-arity x)
-  (if (env-begin? x)
-      (latex-texmacs-arity
-       (string->symbol (string-append "begin-" (tex-env-name (cadr x)))))
-      (logic-ref latex-texmacs-arity% x)))
-
-(define (latex-needs? x)
-  (if (env-begin? x)
-      (latex-needs?
-       (string->symbol (string-append "begin-" (tex-env-name (cadr x)))))
-      (logic-ref latex-needs% x)))
-
-(define (latex-texmacs-option? x)
-  (if (env-begin? x)
-      (latex-texmacs-option?
-       (string->symbol (string-append "begin-" (tex-env-name (cadr x)))))
-      (logic-ref latex-texmacs-option% x)))
-
-(define (latex-texmacs-macro-body x)
-  (smart-ref latex-texmacs-macro x))
-
-(define (latex-texmacs-environment-body x)
-  (smart-ref latex-texmacs-environment (tex-env-name x)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Macro and environment expansion
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (latex-substitute t args)
-  (cond ((number? t) (list-ref args t))
-        ((== t '---) (car args))
-        ((func? t '!recurse 1)
-         (latex-expand-macros (latex-substitute (cadr t) args)))
-        ((func? t '!translate 1)
-         (translate-from-to (cadr t) "english" latex-language))
-        ((list? t) (map (cut latex-substitute <> args) t))
-        (else t)))
-
-(tm-define (latex-expand-macros t)
-  (:synopsis "Expand all TeXmacs macros occurring in @t")
-  (if (npair? t) t
-      (let* ((head  (car t))
-             (tail  (map latex-expand-macros (cdr t)))
-             (body  (latex-texmacs-macro-body head))
-             (arity (and body (latex-texmacs-arity head)))
-             (env   (and (env-begin? head)
-                         (latex-texmacs-environment-body (cadr head))))
-             (envar (and env (latex-texmacs-arity head))))
-        (cond ((and body (== (length tail) arity))
-               ;;(latex-substitute body t)
-               (latex-substitute body (cons head tail)))
-              ((and env (== (length tail) 1) (== (length (cddr head)) envar))
-               ;;(latex-substitute env (append (cdr t) (cddr head)))
-               (latex-substitute env (append tail (cddr head))))
-              (else (cons head tail))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Compute macro and environment definitions
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (latex-expand-def t protect?)
-  (cond ((and protect? (number? t)) (set! t `(!group ,t)) (set! protect? #f))
-        ((and (not protect?) (func? t '!option) (set! protect? #t))))
-  (cond ((== t '---) "#-#-#")
-        ((number? t) (string-append "#" (number->string t)))
-        ((func? t '!recurse 1) (latex-expand-def (cadr t) protect?))
-        ((func? t '!translate 1)
-         (translate-from-to (cadr t) "english" latex-language))
-        ((list? t) (map (cut latex-expand-def <> protect?) t))
-        (else t)))
-
-;; TODO: to be rewritten with better factorisation
-(define (latex-macro-defs-sub t)
-  (when (pair? t)
-    (if (and (or (func? t 'newcommand) (func? t 'renewcommand))
-             (> (length t) 2))
-      (for-each latex-macro-defs-sub (cddr t))
-      (for-each latex-macro-defs-sub (cdr t)))
-    (let* ((body   (and (not (latex-needs? (car t)))
-                        (latex-texmacs-macro-body (car t))))
-           (arity  (and body (latex-texmacs-arity (car t))))
-           (option (and body (latex-texmacs-option? (car t))))
-           (args   (if option (filter (lambda (x)
-                                        (not (and (list? x)
-                                                  (== (car x) '!option))))
-                                      (cdr t))
-                     (cdr t))))
-      (when (and body (== (length args) arity))
-        (if option (set! arity (+ 1 arity)))
-        (ahash-set! latex-macro-table (car t)
-                    (list arity (latex-expand-def body #f)))
-        (latex-macro-defs-sub body)))
-    (let* ((body  (and (env-begin? (car t))
-                       (not (latex-needs? (car t)))
-                       (latex-texmacs-environment-body (cadar t))))
-           (arity (and body (latex-texmacs-arity (car t))))
-           (option (and body (latex-texmacs-option? (car t))))
-           (args   (and body
-                        (if option (filter (lambda (x)
-                                             (not (and (list? x)
-                                                       (== (car x) '!option))))
-                                           (car t))
-                            (car t)))))
-      (when (and body (== (length args) (+ arity 2)))
-        (if option (set! arity (+ 1 arity)))
-        (ahash-set! latex-env-table (cadar t)
-                    (list arity (latex-expand-def body #f)))
-        (latex-macro-defs-sub body)))
-    (with body (or (and (not (latex-needs? (car t)))
-                        (smart-ref latex-texmacs-preamble (car t)))
-                   (and (env-begin? (car t))
-                        (not (latex-needs? (car t)))
-                        (smart-ref latex-texmacs-env-preamble (cadar t))))
-      (when body
-        (ahash-set! latex-preamble-table
-                    (if (env-begin? (car t)) (cadar t) (car t)) body)
-        (latex-macro-defs-sub body)))))
-
-(define (latex<=? x y)
-  (if (symbol? x) (set! x (symbol->string x)))
-  (if (symbol? y) (set! y (symbol->string y)))
-  (if (env-begin? x) (set! x (cadr x)))
-  (if (env-begin? y) (set! y (cadr y)))
-  (string<=? x y))
-
-(tm-define (latex-macro-defs t)
-  (:synopsis "Return necessary macro and environment definitions for @doc")
-  (set! latex-macro-table (make-ahash-table))
-  (set! latex-env-table (make-ahash-table))
-  (set! latex-preamble-table (make-ahash-table))
-  (latex-macro-defs-sub t)
-  (let* ((c1 (ahash-table->list latex-macro-table))
-         (c2 (list-sort c1 (lambda (x y) (latex<=? (car x) (car y)))))
-         (c3 (map (cut cons '!newcommand <>) c2))
-         (e1 (ahash-table->list latex-env-table))
-         (e2 (list-sort e1 (lambda (x y) (latex<=? (car x) (car y)))))
-         (e3 (map (cut cons '!newenvironment <>) e2))
-         (p1 (ahash-table->list latex-preamble-table))
-         (p2 (list-sort p1 (lambda (x y) (latex<=? (car x) (car y)))))
-         (p3 (map cdr (map (cut latex-expand-def <> #f) p2))))
-    (cons '!append (append c3 e3 p3))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Serialization of TeXmacs preambles
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (latex-macro-def name arity body)
-  (with option ""
-    (if (and (list>1? body) (list? (car body)) (== (caar body) '!option))
-      (begin
-        (set! option (serialize-latex (latex-expand-def (cadar body) #f)))
-        (set! option (string-append "[" option "]"))
-        (set! body (cadr body))))
-    (set! body (serialize-latex (latex-expand-def body #f)))
-    (set! body (string-replace body "\n\n" "*/!!/*"))
-    (set! body (string-replace body "\n" " "))
-    (set! body (string-replace body "*/!!/*" "\n\n"))
-    (set! arity (if (= arity 0) ""
-                  (string-append "[" (number->string arity) "]")))
-    (string-append "\\newcommand{\\" (symbol->string name) "}"
-                   arity option "{" body "}\n")))
-
-(define (latex-env-def name arity body)
-  (with option ""
-    (if (and (list>1? body) (list? (car body)) (== (caar body) '!option))
-      (begin
-        (set! option (serialize-latex (latex-expand-def (cadar body) #f)))
-        (set! option (string-append "[" option "]"))
-        (set! body (cadr body))))
-    (set! body (serialize-latex (latex-expand-def body #f)))
-    (set! body (string-replace body "%\n#-#-#" "#-#-#"))
-    (set! body (string-replace body "%\n  #-#-#" "#-#-#"))
-    (set! body (string-replace body "\n\n" "*/!!/*"))
-    (set! body (string-replace body "\n  " " "))
-    (set! body (string-replace body "\n" " "))
-    (set! body (string-replace body "   #-#-# " "}{"))
-    (set! body (string-replace body "#-#-# " "}{"))
-    (set! body (string-replace body "#-#-#" "}{"))
-    (set! body (string-replace body "*/!!/*" "\n\n"))
-    (set! arity (if (= arity 0) ""
-                  (string-append "[" (number->string arity) "]")))
-    (string-append "\\newenvironment{" (tex-env-name name) "}"
-                   arity option "{" body "}\n")))
-
-(tm-define (latex-serialize-preamble t)
-  (:synopsis "Serialize a LaTeX preamble @t")
-  (cond ((string? t) t)
-        ((func? t '!append)
-         (apply string-append (map latex-serialize-preamble (cdr t))))
-        ((func? t '!newcommand 3) (apply latex-macro-def (cdr t)))
-        ((func? t '!newenvironment 3) (apply latex-env-def (cdr t)))
-        (else (serialize-latex t))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Package dependencies management
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (latex-package-direct-dependencies p)
-  (logic-ref-list latex-depends% p))
-
-(define (insert-dependencies l p)
-  (if (null? p) l
-      (if (in? (car p) l)
-          (insert-dependencies l (cdr p))
-          (with deps (latex-package-direct-dependencies (car p))
-            (insert-dependencies (append l (list (car p)))
-                                 (append deps (cdr p)))))))
-
-(tm-define (latex-packages-dependencies ps)
-  (:synopsis "Determine all dependencies of packages @ps")
-  (insert-dependencies (list) ps))
-
-(define (non-redundant-package? p among)
-  (with c (latex-packages-dependencies (list-difference among (list p)))
-    (not (in? p c))))
-
-(tm-define (latex-packages-simplify ps)
-  (:synopsis "Remove all implied packages in package list @ps")
-  (list-filter ps (lambda (p) (non-redundant-package? p ps))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Compute usepackage command for a document
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (latex-command-uses s)
-  (with packlist (logic-ref-list latex-needs% s)
-    (for-each (cut ahash-set! latex-uses-table <> #t) packlist)))
-
-(define (latex-use-which-package l)
-  (when (and (list? l) (nnull? l))
-    (let ((x (car l)))
-      (when (symbol? x)
-        (with s (symbol->string x)
-          (cond ((string-starts? s "left\\")
-                 (latex-command-uses (string->symbol (string-drop s 5))))
-                ((string-starts? s "right\\")
-                 (latex-command-uses (string->symbol (string-drop s 6))))
-                (else (latex-command-uses x)))))
-      (if (and (list? x) (>= (length l) 2) (== (car x) '!begin))
-          (latex-command-uses
-           (string->symbol (string-append "begin-" (cadr x)))))
-      (if (match? x '(!begin "enumerate" (!option :%1)))
-          (ahash-set! latex-uses-table "enumerate" #t))
-      (for-each latex-use-which-package (cdr l)))))
-
-(define (latex-use-package-compare l r)
-  (let* ((tl (logic-ref latex-package-priority% l))
-         (tr (logic-ref latex-package-priority% r))
-         (vl (if tl tl 999999))
-         (vr (if tr tr 999999)))
-    (< vl vr)))
-
-(define (filter-packages l)
-  (filter (lambda (x) (nin? x (tmtex-provided-packages))) l))
-
-(define (filter-packages* l)
-  (filter (lambda (x) (nin? (cAr x) (tmtex-provided-packages))) l))
-
-(define (make-use-package l)
-  (with po (ahash-ref latex-packages-option (cAr l))
-    (let* ((optl (if (not po) (cDr l) (append (cDr l) po)))
-           (opt  (apply string-append (list-intersperse optl ",")))
-           (sty  (cAr l)))
-      (with opts (if (== opt "") "" (string-append "["  opt "]"))
-        (string-append "\\usepackage" opts "{" sty "}\n")))))
-
-(tm-define (latex-ifacconf-style?)
-  (== tmtex-style "ifacconf"))
-
-(tm-define (latex-as-use-package l1)
-  (let* ((l2  (sort l1 latex-use-package-compare))
-         (l3  (filter
-                (lambda (x)
-                  (and (string? x)
-                       (not (ahash-ref latex-packages-option x))))
-                l2))
-         (l3* (map (lambda (x)
-                     (map force-string x))
-                   (filter
-                     list>0?
-                     (map
-                       (lambda (x)
-                         (if (ahash-ref latex-packages-option x) (list x) x))
-                       l2))))
-         (l4  (filter-packages  l3))
-         (l4* (filter-packages* l3*))
-         (l5  (list-intersperse l4 ","))
-         (s   (apply string-append l5))
-         (s*  (apply string-append (map make-use-package l4*))))
-    (if (== s "") s* (string-append "\\usepackage{" s "}\n" s*))))
-
-(tm-define (latex-use-package-command doc)
-  (:synopsis "Return the usepackage command for @doc")
-  (set! latex-uses-table (make-ahash-table))
-  (latex-use-which-package doc)
-  (for (p (ahash-table->list latex-packages-option))
-    (ahash-set! latex-uses-table (car p) #t))
-  (let* ((l1 latex-all-packages)
-         (s1 (latex-as-use-package (list-difference l1 '("amsthm"))))
-         (l2 (map car (ahash-table->list latex-uses-table)))
-         (s2 (latex-as-use-package (list-difference l2 l1))))
-    (string-append s1 s2)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Page size settings
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (latex-preamble-page-type init)
-  (let* ((l0 (ahash-table->list init))
-         (l1 (map car l0))
-         (l2 (map cdr l0))
-         (l3 (map (cut logic-ref latex-paper-opts% <>) l1))
-         (l4 (map (lambda (key val)
-                    (cond ((not val) #f)
-                          ((== key "page-type")
-                           (or (logic-ref latex-paper-type% val) '()))
-                          ((== key "page-orientation") val)
-                          ((and (string? key) (!= val "auto"))
-                           (string-append key "=" (tmtex-decode-length val)))
-                          (else #f))) l3 l2))
-         (l5 (filter string? l4))
-         (page-opts (list-intersperse l5 ",")))
-    (if (nnull? page-opts)
-      `(!append (geometry (!concat ,@page-opts)) "\n") "")))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Color definitions
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (html-color->latex-xcolor s)
-  "Take an hexa html color string and return an hex triplet string"
-  (upcase-all
-   (cond ((string-starts? s "#") (html-color->latex-xcolor (string-tail s 1)))
-         ((== 3 (string-length s))
-          (let ((r (substring s 0 1))
-                (g (substring s 1 2))
-                (b (substring s 2 3)))
-            (string-append r r g g b b)))
-         ((== 4 (string-length s)) (html-color->latex-xcolor (string-take s 3)))
-         ((== 6 (string-length s)) s)
-         ((== 8 (string-length s)) (string-take s 6))
-         (else s))))
-
-(define (latex-colors-defs colors)
-  (apply string-append
-         (map (lambda (x)
-                (string-append
-                  "\\definecolor{" (string-replace x " " "") "}{HTML}{"
-                  (html-color->latex-xcolor (get-hex-color x)) "}\n"))
-              colors)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Building the preamble
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (latex-make-option l)
-  (string-append "[" (apply string-append (list-intersperse l ",")) "]"))
-
-(define (set-packages-option pack opts colors)
-  (cond ((nnull? opts)
-         (ahash-set! latex-packages-option pack opts))
-        ((nnull? colors)
-         (ahash-set! latex-packages-option pack (list "")))))
-
-(tm-define (latex-extra-preamble) "")
-
-(tm-define (latex-preamble text style lan init colors colormaps)
-  (:synopsis "Compute preamble for @text")
-  (with-global tmtex-style (if (list? style) (cAr style) style)
-    (set! latex-packages-option (make-ahash-table))
-    (set-packages-option "xcolor" colormaps colors)
-    (let* ((Page         (latex-preamble-page-type init))
-           (Macro        (latex-macro-defs text))
-           (Colors       (latex-colors-defs colors))
-           (Text         (list '!tuple Page Macro Colors text))
-           (pre-page     (latex-serialize-preamble Page))
-           (pre-macro    (latex-serialize-preamble Macro))
-           (pre-colors   (latex-serialize-preamble Colors))
-           (pre-catcode  (latex-catcode-defs Text))
-           (pre-uses     (latex-use-package-command Text))
-           (pre-extra    (latex-extra-preamble)))
-      (values
-        (cond ((and (in? "amsthm" latex-all-packages)
-                    (== style "amsart")) "[amsthm]")
-              ((list? style) (latex-make-option (cDr style)))
-              (else ""))
-        (string-append pre-uses pre-extra)
-        (string-append pre-page)
-        (string-append pre-catcode pre-macro pre-colors)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Clean-up the produced LaTeX for use with MathJax
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (latex-mathjax-text l arg)
-  (with x (latex-mathjax-pre arg)
-    (cond ((or (npair? x) (nlist? x)) `(,l ,x))
-          ((func? x 'tmtextsf 1) (latex-mathjax-text 'textsf (cadr x)))
-          ((func? x 'tmtexttt 1) (latex-mathjax-text 'texttt (cadr x)))
-          ((func? x 'tmtextit 1) (latex-mathjax-text 'textit (cadr x)))
-          ((func? x 'tmtextbf 1) (latex-mathjax-text 'textbf (cadr x)))
-          ((func? x 'tmtextrm 1) (latex-mathjax-text l (cadr x)))
-          ((func? x 'tmtextup 1) (latex-mathjax-text l (cadr x)))
-          (else `(,l ,x)))))
-
-(tm-define (latex-mathjax-pre x)
-  (:synopsis "Produce cleaner LaTeX for @x for use with MathJax, pass 1")
-  (cond ((or (npair? x) (nlist? x)) x)
-        ((func? x 'text 1)
-         (latex-mathjax-text 'text (cadr x)))
-        ((func? x 'dotminus 0) `(dot "-"))
-        ((func? x 'dotpm 0) `(dot (pm)))
-        ((func? x 'dotmp 0) `(dot (mp)))
-        ((func? x 'dotamalg 0) `(dot (amalg)))
-        ((func? x 'dotplus 0) `(dot "+"))
-        ((func? x 'dottimes 0) `(dot (times)))
-        ((func? x 'dotast 0) `(dot (ast)))
-        ((func? x 'dag) `(dagger))
-        ((and (func? x 'color 2) (func? (cadr x) '!option 1))
-         ;; NOTE : MathJax has broken color support, so ignore certain colors
-         ;; FIXME: this hack may have to be suppressed when MathJax improves
-         "")
-        (else (cons (car x) (map latex-mathjax-pre (cdr x))))))
-
-(tm-define (latex-mathjax x)
-  (:synopsis "Produce cleaner LaTeX for @x for use with MathJax, pass 2")
-  (cond ((or (npair? x) (nlist? x)) x)
-        ((func? x 'ensuremath 1) (latex-mathjax (cadr x)))
-        ((func? x 'hspace* 1) `(hspace ,(latex-mathjax (cadr x))))
-        ((func? x 'mathbbm 1) `(mathbb ,(latex-mathjax (cadr x))))
-        ((func? x 'fill 0) "3cm")
-        ((func? x 'newcommand) "")
-        ((func? x 'custombinding) "")
-        ((func? x 'nobreak) "")
-        ((func? x 'label) "")
-        (else (cons (car x) (map latex-mathjax (cdr x))))))
diff --git a/TeXmacs/plugins/latex/progs/convert/latex/texout.scm b/TeXmacs/plugins/latex/progs/convert/latex/texout.scm
deleted file mode 100644
index a0e7d24c17..0000000000
--- a/TeXmacs/plugins/latex/progs/convert/latex/texout.scm
+++ /dev/null
@@ -1,468 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : texout.scm
-;; DESCRIPTION : generation of TeX/LaTeX from scheme expressions
-;; COPYRIGHT   : (C) 2002  Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (convert latex texout)
-  (:use (convert latex latex-tools)
-        (convert tools output)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Make environment names acceptable
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tex-env-name s)
-  (if (string? s) (string-replace s "-" "") s))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Interface for unicode output
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (output-tex s)
-  (output-text s))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Outputting preamble and postamble
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (collection->ahash-table init)
-  (let* ((t (make-ahash-table))
-         (l (if (func? init 'collection) (cdr init) '()))
-         (f (lambda (x) (ahash-set! t (cadr x) (caddr x)))))
-    (for-each f l)
-    t))
-
-(define (drop-blank s)
-  (string-replace s " " ""))
-
-(define (latex-stree-contains? t u)
-  (cond ((== t u) #t)
-        ((and (string? t) (string? u)) (string-contains? t (drop-blank u)))
-        ((nlist? t) #f)
-        ((null? t) #f)
-        (else (or (latex-stree-contains? (car t) u)
-                  (in? #t (map (lambda (x)
-                                 (latex-stree-contains? x u)) (cdr t)))))))
-(define (attached_macro? t)
-  (and (func? t '!concat 4)
-       (== (cadr t) '(!preamble "%%%%%%%%%% Start TeXmacs macros\n"))))
-
-(define (detach-macros t)
-  (cond ((attached_macro? t) (fifth t))
-        ((list>0? t) (map-in-order detach-macros t))
-        (else t)))
-
-(define (texout-file l)
-  (let* ((doc-body (car l))
-         (has-preamble? (latex-stree-contains? doc-body "\\begin{document}"))
-         (has-end?      (latex-stree-contains? doc-body "\\end{document}"))
-         (styles (if (null? (cadr l)) (list "article") (cadr l)))
-         (style (car styles))
-         (style* (if (nlist? style) style (cAr style)))
-         (needs (caddr l))
-         (prelan (car needs))
-         (colors (cadr needs))
-         (colormaps (caddr needs))
-         (lan (if (== prelan "") "english" prelan))
-         (init (collection->ahash-table (cadddr l)))
-         (doc-preamble (car (cddddr l)))
-         (doc-misc (append '(!concat) doc-preamble (list doc-body)))
-         (doc-src (cdr (cddddr l)))
-         (post-begin "")
-         (pre-end    ""))
-
-    (if (not has-preamble?)
-      (begin
-        (set! doc-body (detach-macros doc-body))
-        (receive
-            (tm-style-options tm-uses tm-init tm-preamble)
-            (latex-preamble doc-misc style lan init colors colormaps)
-          (output-verbatim "\\documentclass")
-          (output-verbatim tm-style-options)
-          (if (== (cAr lan) "chinese")
-            (output-verbatim "[UTF8]{ctexart}\n")
-            (output-verbatim "{" style* "}\n"))
-          (with main-lang (cAr lan)
-            (cond ((== main-lang "korean")
-                   (output-verbatim "\\usepackage{hangul}\n"))
-                  ((in? main-lang '("chinese" "chineset" "japanese"))
-                   (with opt (cond ((== main-lang "japanese")  "{min}")
-                                   ((== main-lang "chineset") "{bsmi}")
-                                   ((== main-lang "chinese")   "{gbsn}"))
-                     '()))
-                  (else
-                    (with langs
-                      (apply string-append (list-intersperse lan ", "))
-                      (output-verbatim "\\usepackage[" langs "]{babel}\n"))
-                    (if tmtex-use-unicode?
-                        (output-verbatim "\\usepackage[utf8]{inputenc}\n")))))
-          (when (and (string? style*)
-                     (or (string-starts? style* "acm")
-                         (string-starts? style* "sig"))
-                     (string? tm-uses)
-                     (string-occurs? "amssymb" tm-uses))
-            (output-verbatim "\\let\\Bbbk\\relax\n"))
-          (output-verbatim tm-uses)
-          (if (string-occurs? "makeidx" (latex-use-package-command doc-body))
-            (output-verbatim "\\makeindex\n"))
-          (output-verbatim tm-init)
-
-          (if (!= tm-preamble "")
-            (begin
-              (output-lf)
-              (output-verbatim "%%%%%%%%%% Start TeXmacs macros\n")
-              (output-verbatim tm-preamble)
-              (output-verbatim "%%%%%%%%%% End TeXmacs macros\n")))
-          (if (nnull? doc-preamble)
-            (begin
-              (output-lf)
-              (map-in-order (lambda (x) (texout x) (output-lf)) doc-preamble))))
-
-        (output-lf)
-        (output-tex "\\begin{document}")
-        (output-lf)
-        (output-tex post-begin)
-        (output-lf)))
-    (texout doc-body)
-    (if (not has-end?)
-      (begin
-        (output-lf)
-        (output-tex pre-end)
-        (output-lf)
-        (output-tex "\\end{document}")
-        (output-lf)))
-    (if (nnull? doc-src) (texout (car doc-src)))))
-
-(define (texout-usepackage x)
-  (output-verbatim "\\usepackage{" x "}\n"))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Outputting main flow
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (texout-comment l)
-    (set-output-comment #t)
-    (output-tex "% ")
-    (texout l)
-    (set-output-comment #f)
-    (output-lf))
-
-(tm-define (texout-preamble l)
-  (output-verbatim l))
-
-(define (empty-line? x)
-  (or (== x "")
-      (func? x '!marker)
-      (and (func? x '!concat)
-           (list-and (map empty-line? (cdr x))))))
-
-(tm-define (texout-document l)
-  (if (nnull? l)
-      (begin
-        (texout (car l))
-        (if (empty-line? (car l))
-            (output-tex "\\ "))
-        (if (nnull? (cdr l))
-            (begin
-              (output-lf)
-              (output-lf)))
-        (texout-document (cdr l)))))
-
-(define (texout-paragraph l)
-  (if (nnull? l)
-      (begin
-        (texout (car l))
-        (if (nnull? (cdr l)) (output-lf))
-        (texout-paragraph (cdr l)))))
-
-(define (texout-table l)
-  (if (nnull? l)
-      (begin
-        (if (func? (car l) '!row)
-            (begin
-              (texout-row* (cdar l))
-              (if (nnull? (cdr l))
-                  (begin
-                    (output-tex "\\\\")
-                    (output-lf))))
-            (begin
-              (texout (car l))
-              (if (nnull? (cdr l)) (output-lf))))
-        (texout-table (cdr l)))))
-
-(define (texout-row l)
-  (if (nnull? l)
-      (begin
-        (texout (car l))
-        (if (nnull? (cdr l)) (output-tex " & "))
-        (texout-row (cdr l)))))
-
-(define (texout-row* l)
-  ;; Dirty hack to avoid [ strings at start of a row
-  ;; because of confusion with optional argument of \\
-  (if (and (pair? l) (string? (car l)) (string-starts? (car l) "["))
-      (set! l `((!concat (!group "") ,(car l)) ,@(cdr l))))
-  (if (and (pair? l) (func? (car l) '!concat)
-           (string? (cadar l)) (string-starts? (cadar l) "["))
-      (set! l `((!concat (!group "") ,@(cdar l)) ,@(cdr l))))
-  (texout-row l))
-
-(define (texout-want-space x1 x2) ;; spacing rules
-  (and (not (or (and (string? x1) (!= x1 "")
-                     (in? (string-take-right x1 1) '("(" "[")))
-                (in? x1 '(({) (nobreak)))
-                (and (string? x2) (!= x2 "")
-                     (in? (string-take x2 1) '("," ")" "]")))
-                (in? x2 '((}) (nobreak)))
-                (== x1 " ") (== x2 " ")
-                (func? x2 '!nextline)
-                (== x2 "'") (func? x2 '!sub) (func? x2 '!sup)
-                (func? x1 '&) (func? x2 '&)
-                (func? x1 '!nbsp) (func? x2 '!nbsp)
-                (func? x1 '!nbhyph) (func? x2 '!nbhyph)
-                (and (== x1 "'") (nlist? x2))))
-       (or (in? x1 '("," ";" ":"))
-           (func? x1 'tmop) (func? x2 'tmop)
-           (func? x1 '!symbol) (func? x2 '!symbol)
-           (and (list-1? x1) (symbol? (car x1))
-                (string-alpha? (symbol->string (car x1)))
-                (string? x2) (> (string-length x2) 0))
-           (and (nlist? x1) (nlist? x2)))))
-
-(define (texout-concat-sub prev l)
-  (when (nnull? l)
-    (if (func? (car l) '!marker)
-        (begin
-          (texout (car l))
-          (texout-concat-sub prev (cdr l)))
-        (begin
-          (if (and prev (texout-want-space prev (car l))) (texout " "))
-          (texout (car l))
-          (texout-concat-sub (car l) (cdr l))))))
-
-(define (texout-concat l)
-  (texout-concat-sub #f l))
-
-(tm-define (texout-multiline? x)
-  (cond ((npair? x) #f)
-        ((in? (car x) '(!begin !nextline !newline !linefeed !eqn !table)) #t)
-        ((and (in? (car x) '(!document !paragraph)) (> (length (cdr x)) 1)) #t)
-        ((npair? (cdr x)) #f)
-        (else (or (texout-multiline? (cadr x))
-                  (texout-multiline? `(!concat ,@(cddr x)))))))
-
-(define (texout-indent x)
-  (if (texout-multiline? x)
-    (begin
-      (output-indent 2)
-      (output-lf)
-      (texout x)
-      (output-indent -2)
-      (output-lf))
-    (texout x)))
-
-(define (texout-unindent x)
-  (with old-indent (get-output-indent)
-    (set-output-indent 0)
-    (texout x)
-    (set-output-indent old-indent)))
-
-(define (texout-linefeed)
-  (output-lf))
-
-(define (texout-newline)
-  (output-lf)
-  (output-lf))
-
-(define (texout-nextline)
-  (output-tex "\\\\")
-  (output-lf))
-
-(define (texout-nbsp)
-  (output-tex "~"))
-
-(define (texout-nbhyph)
-  (output-tex "\\mbox{-}"))
-
-(define (texout-verb x)
-  (cond ((not (string-index x #\|)) (output-verb "\\verb|" x "|"))
-        ((not (string-index x #\$)) (output-verb "\\verb$" x "$"))
-        ((not (string-index x #\@)) (output-verb "\\verb@" x "@"))
-        ((not (string-index x #\!)) (output-verb "\\verb!" x "!"))
-        ((not (string-index x #\9)) (output-verb "\\verb9" x "9"))
-        ((not (string-index x #\X)) (output-verb "\\verbX" x "X"))
-        (else (output-verb "\\verbď" x "ď"))))
-
-(define (texout-verbatim x)
-  (output-lf-verbatim "\\begin{alltt}\n" x "\n\\end{alltt}"))
-
-(define (texout-verbatim* x)
-  (output-lf-verbatim x))
-
-(define (texout-invariant x)
-  (output-invariant x))
-
-(define (texout-group x)
-  (output-tex "{")
-  (texout x)
-  (output-tex "}"))
-
-(define (texout-marker tag arg)
-  (with s (string-append "{\\" (symbol->string tag) "{" arg "}}")
-    (output-marker s)))
-
-(define (texout-empty? x)
-  (cond ((== x "") #t)
-        ((func? x '!concat) (list-and (map-in-order texout-empty? (cdr x))))
-        ((func? x '!document 1) (texout-empty? (cadr x)))
-        (else #f)))
-
-(define (texout-double-math? x)
-  (or (and (match? x '((:or !document !concat) :%1))
-           (texout-double-math? (cadr x)))
-      (and (match? x '((!begin :%1) :%1))
-           (in? (cadar x) '("eqnarray" "eqnarray*" "leqnarray*")))))
-
-(define (texout-math x)
-  (cond ((texout-empty? x) (noop))
-        ((texout-double-math? x) (texout x))
-        ((match? x '((!begin "center") :%1))
-         (texout `((!begin "equation") ,(cadr x))))
-        ((and (output-test-end? "$") (not (output-test-end? "\\$")))
-         (output-remove 1)
-         (output-tex " ")
-         (texout x)
-         (output-tex "$"))
-        (else
-         (output-tex "$")
-         (texout x)
-         (output-tex "$"))))
-
-(define (texout-eqn x)
-  (output-tex "\\[ ")
-  (output-indent 3)
-  (texout x)
-  (output-indent -3)
-  (output-tex " \\]"))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Outputting macro applications and environments
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (texout-arg x)
-  (output-tex (string-append "#" x)))
-
-(define (texout-args l)
-  (if (nnull? l)
-      (begin
-        (if (and (list? (car l)) (== (caar l) '!option))
-            (begin
-              (output-tex "[")
-              (texout (cadar l))
-              (output-tex "]"))
-            (begin
-              (output-tex "{")
-              (texout (car l))
-              (output-tex "}")))
-        (texout-args (cdr l)))))
-
-(define (texout-apply what args)
-  (output-tex
-    (if (string? what) what (string-append "\\" (symbol->string what))))
-  (texout-args args))
-
-(define (texout-protect? env)
-  (in? env (list "tmparmod" "tmparsep")))
-
-(define (texout-begin* what args inside)
-  (set! what (tex-env-name what))
-  (output-tex (string-append "\\begin{" what "}"))
-  (texout-args args)
-  (if (texout-protect? what) (output-tex "%"))
-  (output-lf)
-  (texout inside)
-  (output-lf)
-  (output-tex (string-append "\\end{" what "}")))
-
-(define (texout-begin what args inside)
-  (set! what (tex-env-name what))
-  (output-tex (string-append "\\begin{" what "}"))
-  (texout-args args)
-  (if (texout-protect? what) (output-tex "%"))
-  (output-indent 2)
-  (output-lf)
-  (texout inside)
-  (output-indent -2)
-  (output-lf)
-  (output-tex (string-append "\\end{" what "}")))
-
-(define (texout-script where l)
-  (let ((x (car l)))
-    (cond ((and (== x '(prime)) (== where "^"))
-           (output-tex "'"))
-          ((and (func? x '!concat) (== where "^")
-                (pair? (cdr x)) (== (cadr x) '(prime))
-                (list-and (map (cut == <> '(prime)) (cdr x))))
-           (output-tex (apply string-append (map (lambda a "'") (cdr x)))))
-          ((and (string? x) (= (string-length x) 1) (nin? x (list "<" ">")))
-           (output-tex where)
-           (output-tex x))
-          (else
-           (output-tex where)
-           (texout-args l)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Main output routines
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (texout x)
-  (cond ((string? x) (output-tex x))
-        ((nlist>0? x) (display* "TeXmacs] badly formatted stree:\n" x "\n"))
-        ((== (car x) '!widechar) (output-tex (symbol->string (cadr x))))
-        ((== (car x) '!file) (texout-file (cdr x)))
-        ((== (car x) '!preamble) (texout-preamble (cadr x)))
-        ((== (car x) '!comment) (texout-comment (cadr x)))
-        ((== (car x) '!document) (texout-document (cdr x)))
-        ((== (car x) '!paragraph) (texout-paragraph (cdr x)))
-        ((== (car x) '!table) (texout-table (cdr x)))
-        ((== (car x) '!concat) (texout-concat (cdr x)))
-        ((== (car x) '!append) (for-each texout (cdr x)))
-        ((== (car x) '!symbol) (texout (cadr x)))
-        ((== (car x) '!linefeed) (texout-linefeed))
-        ((== (car x) '!indent) (texout-indent (cadr x)))
-        ((== (car x) '!unindent) (texout-unindent (cadr x)))
-        ((== (car x) '!newline) (texout-newline))
-        ((== (car x) '!nextline) (texout-nextline))
-        ((== (car x) '!nbsp) (texout-nbsp))
-        ((== (car x) '!nbhyph) (texout-nbhyph))
-        ((== (car x) '!verb) (texout-verb (cadr x)))
-        ((== (car x) '!verbatim) (texout-verbatim (cadr x)))
-        ((== (car x) '!verbatim*) (texout-verbatim* (cadr x)))
-        ((== (car x) '!invariant) (texout-invariant (cadr x)))
-        ((== (car x) '!arg) (texout-arg (cadr x)))
-        ((== (car x) '!group) (texout-group (cons '!append (cdr x))))
-        ((== (car x) '!marker) (texout-marker (cadr x) (caddr x)))
-        ((== (car x) '!math) (texout-math (cadr x)))
-        ((== (car x) '!eqn) (texout-eqn (cadr x)))
-        ((== (car x) '!sub) (texout-script "_" (cdr x)))
-        ((== (car x) '!sup) (texout-script "^" (cdr x)))
-        ((== (car x) '!annotate) (texout (cadr x)))
-        ((== (car x) '!ignore) (noop))
-        ((and (list? (car x)) (== (caar x) '!begin))
-         (texout-begin (cadar x) (cddar x) (cadr x)))
-        ((and (list? (car x)) (== (caar x) '!begin*))
-         (texout-begin* (cadar x) (cddar x) (cadr x)))
-        (else (texout-apply (car x) (cdr x)))))
-
-(tm-define (serialize-latex x)
-  (texout x)
-  (output-produce))
-
diff --git a/TeXmacs/plugins/latex/progs/convert/latex/tmtex-acm.scm b/TeXmacs/plugins/latex/progs/convert/latex/tmtex-acm.scm
deleted file mode 100644
index 761f96e010..0000000000
--- a/TeXmacs/plugins/latex/progs/convert/latex/tmtex-acm.scm
+++ /dev/null
@@ -1,369 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : tmtex-acm.scm
-;; DESCRIPTION : special conversions for acm styles
-;; COPYRIGHT   : (C) 2012  Joris van der Hoeven, Francois Poulain
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (convert latex tmtex-acm)
-  (:use (convert latex tmtex)
-        (convert latex latex-define)))
-
-(tm-define (tmtex-transform-style x)
-  (:mode acm-style?)
-  (cond ((== x "acmconf") "acm_proc_article-sp")
-        ((== x "sig-alternate") x)
-        ((== x "acmsmall") `("format=acmsmall" "acmart"))
-        ((== x "acmlarge") `("format=acmlarge" "acmart"))
-        ((== x "acmtog") `("format=acmtog" "acmart"))
-        ((== x "sigconf") `("format=sigconf" "acmart"))
-        ((== x "sigchi") `("format=sigchi" "acmart"))
-        ((== x "sigplan") `("format=sigplan" "acmart"))
-        (else x)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; New ACM metadata presentation
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (tmtex-make-acm-art-title titles miscs tr)
-  (let* ((titles (tmtex-concat-Sep (map cadr titles)))
-         (content `(,@titles ,@miscs)))
-    (if (null? content) '()
-      `((title (!indent (!paragraph ,@content)))))))
-
-(define (rewrite-author a)
-  (cond ((not (func? a 'author 1)) (list a))
-        ((not (func? (cadr a) '!paragraph)) (list a))
-        (else (cons `(author ,(cadr (cadr a))) (cddr (cadr a))))))
-
-(tm-define (tmtex-append-authors l)
-  (:mode acm-art-style?)
-  (set! l (filter nnull? l))
-  (with r (append-map rewrite-author l)
-    `((!document ,@r))))
-
-(tm-define (tmtex-make-doc-data titles subtitles authors dates miscs notes
-                                subtits-l dates-l miscs-l notes-l tr ar)
-  (:mode acm-art-style?)
-  `(!document
-     ,@(tmtex-make-acm-art-title titles miscs tr)
-     ,@subtitles
-     ,@notes
-     ,@(tmtex-append-authors authors)
-     ,@dates
-     (maketitle)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; New ACM specific titlemarkup
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-doc-subtitle t)
-  (:mode acm-art-style?)
-  `(subtitle ,(tmtex (cadr t))))
-
-(tm-define (tmtex-doc-note t)
-  (:mode acm-art-style?)
-  (set! t (tmtex-remove-line-feeds t))
-  `(titlenote ,(tmtex (cadr t))))
-
-(tm-define (tmtex-doc-misc t)
-  (:mode acm-art-style?)
-  (set! t (tmtex-remove-line-feeds t))
-  `(tmacmmisc ,(tmtex (cadr t))))
-
-(tm-define (tmtex-doc-date t)
-  (:mode acm-art-style?)
-  `(date ,(tmtex (cadr t))))
-
-(tm-define (tmtex-author-name t)
-  (:mode acm-art-style?)
-  `(author ,(tmtex-inline (cadr t))))
-
-(define (get-affiliation-lines aff)
-  (if (func? aff 'concat)
-      (list-filter (cdr aff) (lambda (x) (!= x '(next-line))))
-      (list aff)))
-
-(tm-define (tmtex-author-affiliation t)
-  (:mode acm-art-style?)
-  (let* ((l (if (null? (cdr t)) '() (get-affiliation-lines (cadr t))))
-         (r (list)))
-    (when (nnull? l)
-      (set! r (rcons r `(institution ,(tmtex (car l)))))
-      (set! l (cdr l)))
-    (when (nnull? l)
-      (set! r (rcons r `(streetaddress ,(tmtex (car l)))))
-      (set! l (cdr l)))
-    (when (nnull? l)
-      (set! r (rcons r `(city ,(tmtex (car l)))))
-      (set! l (cdr l)))
-    (when (nnull? l)
-      (set! r (rcons r `(country ,(tmtex (car l)))))
-      (set! l (cdr l)))
-    `(affiliation (!paragraph ,@r))))
-
-(tm-define (tmtex-author-email t)
-  (:mode acm-art-style?)
-  (set! t (tmtex-remove-line-feeds t))
-  `(email ,(tmtex (cadr t))))
-
-(tm-define (tmtex-author-homepage t)
-  (:mode acm-art-style?)
-  (set! t (tmtex-remove-line-feeds t))
-  `(tmacmhomepage ,(tmtex (cadr t))))
-
-(tm-define (tmtex-author-note t)
-  (:mode acm-art-style?)
-  (set! t (tmtex-remove-line-feeds t))
-  `(authornote ,(tmtex (cadr t))))
-
-(tm-define (tmtex-author-misc t)
-  (:mode acm-art-style?)
-  (set! t (tmtex-remove-line-feeds t))
-  `(tmacmmisc ,(tmtex (cadr t))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Old ACM metadata presentation
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-append-authors l)
-  (:mode acm-conf-style?)
-  (set! l (filter nnull? l))
-  (if (null? l) l
-    (let* ((n (number->string (length l)))
-           (sep '(!concat (!linefeed) (alignauthor) (!linefeed))))
-      (set! l (list-intersperse (map cadr l) sep))
-      `((!document (numberofauthors ,n)
-                   (author (!indent (!concat (alignauthor) " " ,@l))))))))
-
-(tm-define (tmtex-make-author names affiliations emails urls miscs notes
-                              affs-l emails-l urls-l miscs-l notes-l)
-  (:mode acm-conf-style?)
-  (let* ((names (tmtex-concat-Sep (map cadr names)))
-         (result `(,@names ,@urls ,@notes ,@miscs ,@affiliations ,@emails)))
-    (if (null? result) '()
-      `(author (!concat ,@result)))))
-
-(define (tmtex-make-acm-conf-title titles notes miscs)
-  (let* ((titles (tmtex-concat-Sep (map cadr titles)))
-         (result `(,@titles ,@notes ,@miscs)))
-    (if (null? result) '()
-      `((title (!concat ,@result))))))
-
-(tm-define (tmtex-make-doc-data titles subtitles authors dates miscs notes
-                                subtits-l dates-l miscs-l notes-l tr ar)
-  (:mode acm-conf-style?)
-  `(!document
-     ,@(tmtex-make-acm-conf-title titles notes miscs)
-     ,@subtitles 
-     ,@(tmtex-append-authors authors)
-     ,@dates
-     (maketitle)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Old ACM specific titlemarkup
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (acm-line-break t)
-  `(!concat (!nextline) ,t))
-
-(tm-define (tmtex-doc-subtitle t)
-  (:mode acm-conf-style?)
-  `(subtitle ,(tmtex (cadr t))))
-
-(tm-define (tmtex-doc-note t)
-  (:mode acm-conf-style?)
-  (set! t (tmtex-remove-line-feeds t))
-  `(titlenote ,(tmtex (cadr t))))
-
-(tm-define (tmtex-doc-misc t)
-  (:mode acm-conf-style?)
-  (set! t (tmtex-remove-line-feeds t))
-  `(tmacmmisc ,(tmtex (cadr t))))
-
-(tm-define (tmtex-doc-date t)
-  (:mode acm-conf-style?)
-  `(date ,(tmtex (cadr t))))
-
-(tm-define (tmtex-author-affiliation t)
-  (:mode acm-conf-style?)
-    (with aff-lines
-      (if (list>0? (cadr t))
-        (map (lambda (x)
-                (if (== x '(next-line))
-                  '(!nextline)
-                  `(affaddr ,(tmtex x))))
-             (cdadr t))
-        (if (null? (cdr t)) '() `((affaddr ,(tmtex (cadr t))))))
-    (acm-line-break `(!concat ,@aff-lines))))
-
-(tm-define (tmtex-author-email t)
-  (:mode acm-conf-style?)
-  (set! t (tmtex-remove-line-feeds t))
-  (acm-line-break `(email ,(tmtex (cadr t)))))
-
-(tm-define (tmtex-author-homepage t)
-  (:mode acm-conf-style?)
-  (set! t (tmtex-remove-line-feeds t))
-  `(tmacmhomepage ,(tmtex (cadr t))))
-
-(tm-define (tmtex-author-note t)
-  (:mode acm-conf-style?)
-  (set! t (tmtex-remove-line-feeds t))
-  `(titlenote ,(tmtex (cadr t))))
-
-(tm-define (tmtex-author-misc t)
-  (:mode acm-conf-style?)
-  (set! t (tmtex-remove-line-feeds t))
-  `(tmacmmisc ,(tmtex (cadr t))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; ACM specific abstract markup
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define  (tmtex-make-abstract-data keywords acm arxiv msc pacs abstract)
-  (:mode acm-style?)
-  (with result `(,@abstract ,@acm ,@arxiv ,@msc ,@pacs ,@keywords)
-    (if (null? result) "" `(!document ,@result))))
-
-(tm-define (tmtex-abstract-keywords t)
-  (:mode acm-style?)
-  (with args (tmtex-concat-sep (map tmtex (cdr t)))
-    `(keywords ,@(map tmtex args))))
-
-(tm-define (tmtex-abstract-acm t)
-  (:mode acm-style?)
-  (with l (cond ((== (length (cdr t)) 0) '("" "" ""))
-                ((== (length (cdr t)) 1) (append (cdr t) '("" "")))
-                ((== (length (cdr t)) 2) (append (cdr t) '("")))
-                ((== (length (cdr t)) 3) (cdr t))
-                (else (append (sublist (cdr t) 0 3)
-                              `((!option ,(fourth (cdr t))))
-                              (sublist (cdr t) 4 (length (cdr t))))))
-    `(category ,@(map tmtex l))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; ACM specific misc markup
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-acm-conferenceinfo s l)
-  (:mode acm-style?)
-  `(conferenceinfo ,@(map tmtex l)))
-
-(tm-define (tmtex-acm-copyright-year s l)
-  (:mode acm-style?)
-  `(CopyrightYear ,@(map tmtex l)))
-
-(tm-define (tmtex-acm-crdata s l)
-  (:mode acm-style?)
-  `(crdata ,@(map tmtex l)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Put 'maketitle' after abstract
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define removed-maketitle? #f)
-(define added-maketitle? #f)
-
-(define (remove-maketitle t)
-  (cond ((nlist? t) t)
-        ((and (func? t '!document) (== (cAr t) '(maketitle)))
-         (set! removed-maketitle? #t)
-         (cDr t))
-        (else (map remove-maketitle t))))
-
-(define (add-maketitle-sub l)
-  (cond ((null? l) l)
-        ((and (pair? (car l)) (== (caar l) '(!begin "abstract")))
-         (set! added-maketitle? #t)
-         (cons (car l) (cons '(maketitle) (cdr l))))
-        (else (cons (add-maketitle (car l))
-                    (add-maketitle-sub (cdr l))))))
-
-(define (add-maketitle t)
-  (cond ((nlist? t) t)
-        ((func? t '!document)
-         (cons (car t) (add-maketitle-sub (cdr t))))
-        (else (map add-maketitle t))))
-
-(tm-define (tmtex-postprocess x)
-  (:mode acm-style?)
-  (set! removed-maketitle? #f)
-  (set! added-maketitle? #f)
-  (let* ((y (remove-maketitle x))
-         (z (add-maketitle y)))
-    (if (and removed-maketitle? added-maketitle?) z x)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; ACM specific macros
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-group latex-texmacs-3%
-  (:mode acm-style?)
-  category)
-
-(smart-table latex-texmacs-macro
-  (:mode acm-style?)
-  (qed #f)
-  (nequiv #f)
-  (category ""))
-
-(smart-table latex-texmacs-environment
-  (:mode acm-style?)
-  ("proof" #f))
-
-;;(tm-define (tmtex-cite-detail s l)
-;;  (:mode acm-style?)
-;;  (tmtex-cite-detail-poor s l))
-
-(smart-table latex-texmacs-env-preamble
-  (:mode acm-art-style?)
-  ("theorem" #f)
-  ("conjecture" #f)
-  ("proposition" #f)
-  ("lemma" #f)
-  ("corollary" #f)
-  ("definition" #f)
-  ("example" #f))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Missing theorem types
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define-macro (acm-theorem prim name)
-  `(latex-texmacs-thmenv ,prim ,name () ()
-                         acm-art-style?))
-
-(define-macro (acm-remark prim name)
-  `(latex-texmacs-thmenv ,prim ,name
-                         ("\\theoremstyle{acmdefinition}\n")
-                         ("\n\\theoremstyle{acmplain}")
-                         acm-art-style?))
-
-(define-macro (acm-exercise prim name)
-  `(latex-texmacs-thmenv ,prim ,name
-                         ("\\theoremstyle{acmdefinition}\n")
-                         ("\n\\theoremstyle{acmplain}")
-                         acm-art-style?))
-
-(acm-theorem "axiom" "Axiom")
-(acm-theorem "notation" "Notation")
-(acm-remark "remark" "Remark")
-(acm-remark "note" "Note")
-(acm-remark "convention" "Convention")
-(acm-remark "warning" "Warning")
-(acm-remark "acknowledgments" "Acknowledgments")
-(acm-remark "answer" "Answer")
-(acm-remark "question" "Question")
-(acm-remark "remark" "Remark")
-(acm-remark "problem" "Problem")
-(acm-remark "solution" "Solution")
-(acm-exercise "exercise" "Exercise")
-(acm-exercise "problem" "Problem")
-(acm-exercise "solution" "Solution")
diff --git a/TeXmacs/plugins/latex/progs/convert/latex/tmtex-ams.scm b/TeXmacs/plugins/latex/progs/convert/latex/tmtex-ams.scm
deleted file mode 100644
index d715a5a7aa..0000000000
--- a/TeXmacs/plugins/latex/progs/convert/latex/tmtex-ams.scm
+++ /dev/null
@@ -1,177 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : tmtex-ams.scm
-;; DESCRIPTION : special conversions for AMS styles
-;; COPYRIGHT   : (C) 2012  Joris van der Hoeven, François Poulain
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (convert latex tmtex-ams)
-  (:use (convert latex tmtex)
-        (convert latex latex-define)))
-
-(tm-define (tmtex-transform-style x)
-  (:mode ams-style?) x)
-
-(tm-define (tmtex-provided-packages)
-  (:mode ams-style?)
-  '("amsmath"))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; AMS data preprocessing
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (stree-contains? t u)
-  (cond ((== t u) #t)
-        ((nlist? t) #f)
-        ((null? t) #f)
-        (else (or (stree-contains? (car t) u)
-                  (in? #t (map (lambda (x) (stree-contains? x u)) (cdr t)))))))
-
-(define (insert-maketitle-after t u)
-  (cond ((nlist? t) t)
-        ((== (car t) u) `(!document ,t (maketitle)))
-        (else `(,(car t) ,@(map (lambda (x) (insert-maketitle-after x u))
-                                (cdr t))))))
-
-(tm-define (tmtex-style-preprocess doc)
-  (:mode ams-style?)
-  (cond ((stree-contains? doc 'abstract-data)
-         (insert-maketitle-after doc 'abstract-data))
-        ((stree-contains? doc 'doc-data)
-         (insert-maketitle-after doc 'doc-data))
-        (else doc)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; AMS metadata presentation
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-make-author names affiliations emails urls miscs notes
-                              affs-l emails-l urls-l miscs-l notes-l)
-  (:mode ams-style?)
-  (let* ((names (map (lambda (x) `(author ,x))
-                     (list-intersperse (map cadr names) '(tmSep))))
-         (result `(,@names ,@affiliations ,@emails ,@urls ,@notes ,@miscs)))
-    (if (null? result) '() `(!paragraph ,@result))))
-
-(tm-define (tmtex-make-doc-data titles subtitles authors dates miscs notes
-                                subtits-l dates-l miscs-l notes-l tr ar)
-  (:mode ams-style?)
-  (let* ((title-opt  (if (null? tr) '() `((!option ,@(tmtex-concat-Sep tr)))))
-         (titles     (tmtex-concat-Sep (map cadr titles)))
-         (titles     (if (null? titles) '() `((title ,@title-opt ,@titles))))
-         (title-data `(,@titles ,@subtitles ,@notes ,@miscs))
-         (title-data (if (null? title-data) '() `((!paragraph ,@title-data))))
-         (authors*   (filter pair? authors)))
-    (if (and (null? title-data) (null? authors*) (null? dates)) '()
-        `(!document ,@title-data ,@authors* ,@dates))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; AMS specific titlemarkup
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-doc-running-title t)
-  (:mode ams-style?)
-  (tmtex (cadr t)))
-
-(tm-define (tmtex-doc-subtitle t)
-  (:mode ams-style?)
-  `(tmsubtitle ,(tmtex (cadr t))))
-
-(tm-define (tmtex-doc-note t)
-  (:mode ams-style?)
-  (set! t (tmtex-remove-line-feeds t))
-  `(tmnote ,(tmtex (cadr t))))
-
-(tm-define (tmtex-doc-misc t)
-  (:mode ams-style?)
-  (set! t (tmtex-remove-line-feeds t))
-  `(tmmisc ,(tmtex (cadr t))))
-
-(tm-define (tmtex-doc-date t)
-  (:mode ams-style?)
-  `(date ,(tmtex (cadr t))))
-
-(tm-define (tmtex-author-affiliation t)
-  (:mode ams-style?)
-  `(address ,(tmtex (cadr t))))
-
-(tm-define (tmtex-author-email t)
-  (:mode ams-style?)
-  (set! t (tmtex-remove-line-feeds t))
-  `(email ,(tmtex (cadr t))))
-
-(tm-define (tmtex-author-homepage t)
-  (:mode ams-style?)
-  (set! t (tmtex-remove-line-feeds t))
-  `(urladdr ,(tmtex (cadr t))))
-
-(tm-define (tmtex-author-note t)
-  (:mode ams-style?)
-  (set! t (tmtex-remove-line-feeds t))
-  `(tmnote ,(tmtex (cadr t))))
-
-(tm-define (tmtex-author-misc t)
-  (:mode ams-style?)
-  (set! t (tmtex-remove-line-feeds t))
-  `(tmmisc ,(tmtex (cadr t))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; AMS specific abstract markup
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (move-in-abstract what in)
-  (if (null? in)
-    (if (null? what) '() `(((!begin "abstract") (document ,@what))))
-    `(((!begin "abstract") (!document ,@(map cadr in) ,@what)))))
-
-(tm-define  (tmtex-make-abstract-data keywords acm arxiv msc pacs abstract)
-  (:mode ams-style?)
-  (with class `(,@acm ,@arxiv ,@pacs)
-    (set! abstract (move-in-abstract class abstract)))
-  (with result `(,@abstract ,@msc ,@keywords)
-    (if (null? result) "" `(!document ,@result))))
-
-(tm-define (tmtex-abstract-keywords t)
-  (:mode ams-style?)
-  (with args (tmtex-concat-sep (map tmtex (cdr t)))
-    `(keywords ,@args)))
-
-(tm-define (tmtex-abstract-msc t)
-  (:mode ams-style?)
-  (with args (tmtex-concat-Sep (map tmtex (cdr t)))
-    `(subjclass ,@args)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; AMS specific macros
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(smart-table latex-texmacs-macro
-  (:mode ams-style?)
-  (qed #f))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; AMS theorems
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define-macro (ams-latex-texmacs-remark prim name)
-  `(latex-texmacs-thmenv ,prim ,name
-                         ("{" (!recurse (theoremstyle "remark"))) ("}")
-                         ams-style?))
-
-(ams-latex-texmacs-remark "remark" "Remark")
-(ams-latex-texmacs-remark "note" "Note")
-(ams-latex-texmacs-remark "example" "Example")
-(ams-latex-texmacs-remark "convention" "Convention")
-(ams-latex-texmacs-remark "warning" "Warning")
-(ams-latex-texmacs-remark "acknowledgments" "Acknowledgments")
-(ams-latex-texmacs-remark "answer" "Answer")
-(ams-latex-texmacs-remark "question" "Question")
-(ams-latex-texmacs-remark "exercise" "Exercise")
-(ams-latex-texmacs-remark "problem" "Problem")
-(ams-latex-texmacs-remark "solution" "Solution")
diff --git a/TeXmacs/plugins/latex/progs/convert/latex/tmtex-beamer.scm b/TeXmacs/plugins/latex/progs/convert/latex/tmtex-beamer.scm
deleted file mode 100644
index 74ed19e7a2..0000000000
--- a/TeXmacs/plugins/latex/progs/convert/latex/tmtex-beamer.scm
+++ /dev/null
@@ -1,250 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : tmtex-beamer.scm
-;; DESCRIPTION : special conversions for Beamer style
-;; COPYRIGHT   : (C) 2012  Joris van der Hoeven, François Poulain
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (convert latex tmtex-beamer)
-  (:use (convert latex tmtex)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Beamer style options
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-transform-style x)
-  (:mode beamer-style?)
-  "beamer")
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Beamer document preprocessing
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (stree-transform l what by)
-  (cond ((or (null? l) (nlist? l)) l)
-        ((== (car l) what) `(,by ,@(cdr l)))
-        (else
-          (map (lambda (x) (stree-transform x what by)) l))))
-
-(define (beamer-make-slides doc)
-  (set! doc (stree-transform doc 'hidden 'slide))
-  (stree-transform doc 'shown 'slide))
-
-(tm-define (tmtex-style-preprocess doc)
-  (:mode beamer-style?)
-  (beamer-make-slides doc))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Beamer metadata presentation
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-make-author names affiliations emails urls miscs notes
-                              affs-l emails-l urls-l miscs-l notes-l)
-  (:mode beamer-style?)
-  (let* ((names (tmtex-concat-Sep (map cadr names)))
-         (result `(,@names ,@urls ,@notes ,@miscs)))
-    (if (null? result) '() `(author (!paragraph ,@result)))))
-
-(define (beamer-append in l)
-  (set! l (filter nnull? l))
-  (if (< (length l) 1) l
-    (with lf `(!concat (!linefeed) (and) (!linefeed))
-      `((,in
-          (!indent (!concat ,@(list-intersperse (map cadr l) lf))))))))
-
-(define (svjour-make-title titles notes miscs)
-  (let* ((titles (tmtex-concat-Sep (map cadr titles)))
-         (result `(,@titles ,@notes ,@miscs)))
-    (if (null? result) '()
-      `((title (!concat ,@result))))))
-
-(define (svjour-make-doc-data titles subtits authors affs dates miscs notes tr ar)
-  `(!document
-     ,@(svjour-make-title titles notes miscs)
-     ,@subtits
-     ,@tr
-     ,@ar
-     ,@(beamer-append 'author authors)
-     ,@(beamer-append 'institute affs)
-     ,@dates
-     (maketitle)))
-
-(tm-define (tmtex-doc-data s l)
-  (:mode beamer-style?)
-  (set! l (map tmtex-replace-documents l))
-  (let* ((subtitles (map tmtex-doc-subtitle
-                         (tmtex-select-args-by-func 'doc-subtitle l)))
-         (notes     (map tmtex-doc-note
-                         (tmtex-select-args-by-func 'doc-note l)))
-         (miscs     (map tmtex-doc-misc
-                         (tmtex-select-args-by-func 'doc-misc l)))
-         (dates     (map tmtex-doc-date
-                         (tmtex-select-args-by-func 'doc-date l)))
-         (authors   (map tmtex-doc-author
-                         (tmtex-select-args-by-func 'doc-author l)))
-         (ar        (map tmtex-doc-running-author
-                         (tmtex-select-args-by-func 'doc-running-author l)))
-         (titles    (map tmtex-doc-title
-                         (tmtex-select-args-by-func 'doc-title l)))
-         (tr        (map tmtex-doc-running-title
-                         (tmtex-select-args-by-func 'doc-running-title l)))
-         (affs      (map tmtex-affiliation-group
-                         (cluster-by-affiliations
-                           (tmtex-select-args-by-func 'doc-author l)))))
-    (svjour-make-doc-data titles subtitles authors affs dates miscs notes tr ar)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Beamer affiliation clustering
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (beamer-clear-aff aff a filter?)
-  (with datas (cdadr a)
-    (if (and filter?
-             (== `(,aff)
-                 (filter (lambda (x) (== 'author-affiliation (car x))) datas)))
-      '()
-      `(doc-author (author-data ,@(filter (lambda (x) (!= aff x)) datas))))))
-
-(define (next-affiliation l)
-  (cond ((or (null? l) (nlist? l)) #f)
-        ((in?   (car l) '(doc-author author-data)) (next-affiliation (cdr l)))
-        ((==    (car l) 'author-affiliation) l)
-        ((list? (car l))
-         (with na (next-affiliation (car l))
-           (if na na (next-affiliation (cdr l)))))
-        (else #f)))
-
-(define (cluster-by-affiliations l)
-  (if (nlist? l) l
-    (let* ((aff     (next-affiliation l))
-           (hasaff  (filter (lambda (x)
-                              (or (not aff)
-                                  (and (list? x) (list? (cdr x))
-                                       (list? (cadr x))
-                                       (in? aff (cdadr x))))) l))
-           (hasaff* (map (lambda (x) (beamer-clear-aff aff x #f)) hasaff))
-           (l*      (map (lambda (x) (beamer-clear-aff aff x #t)) l))
-           (l*      (filter nnull? l*))
-           (aff*    `(affiliation-group
-                       ,(if aff (cadr aff) '()) ,@hasaff*)))
-      (if aff (append `(,aff*) (cluster-by-affiliations l*)) `(,aff*)))))
-
-(tm-define (tmtex-affiliation-group t)
-  (with old-tmtex-make-author (eval tmtex-make-author)
-    (set! tmtex-make-author
-      (lambda (names affiliations emails urls miscs notes
-                     affs-l emails-l urls-l miscs-l notes-l)
-        (with names (tmtex-concat-Sep (map cadr names))
-          (cond ((and (null? names) (null? emails)) '())
-                ((or (null? names) (null? emails))
-                 `(!concat ,@names)) ;hack
-                (else `(!concat ,@names)))))) ;hack
-    (let* ((affs     (cadr t))
-           (affs     (if (null? affs) '()
-                       `((!concat (!linefeed)(at)(!linefeed) ,(tmtex affs)))))
-           (auth-sep '(!concat " " (and) " "))
-           (authors  (map tmtex-doc-author (cddr t)))
-           (authors  (list-intersperse authors auth-sep)))
-      (set! tmtex-make-author (eval old-tmtex-make-author))
-      (if (and (null? authors) (null? affs)) '()
-        `(institute (!concat ,@authors ,@affs))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Beamer specific titlemarkup
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-doc-running-title t)
-  (:mode beamer-style?)
-  `(titlerunning ,(tmtex (cadr t))))
-
-(tm-define (tmtex-doc-subtitle t)
-  (:mode beamer-style?)
-  `(subtitle ,(tmtex (cadr t))))
-
-(tm-define (tmtex-doc-note t)
-  (:mode beamer-style?)
-  `(tmnote ,(tmtex (cadr t))))
-
-(tm-define (tmtex-doc-misc t)
-  (:mode beamer-style?)
-  `(tmmisc ,(tmtex (cadr t))))
-
-(tm-define (tmtex-doc-date t)
-  (:mode beamer-style?)
-  `(date ,(tmtex (cadr t))))
-
-(tm-define (tmtex-doc-running-author t)
-  (:mode beamer-style?)
-  `(authorrunning ,(tmtex (cadr t))))
-
-(tm-define (tmtex-author-affiliation t)
-  (:mode beamer-style?)
-  `(institute ,(tmtex (cadr t))))
-
-(tm-define (tmtex-author-email t)
-  (:mode beamer-style?)
-  `(email ,(tmtex (cadr t))))
-
-(tm-define (tmtex-author-homepage t)
-  (:mode beamer-style?)
-  `(tmfnhomepage ,(tmtex (cadr t))))
-
-(tm-define (tmtex-author-note t)
-  (:mode beamer-style?)
-  `(tmnote ,(tmtex (cadr t))))
-
-(tm-define (tmtex-author-misc t)
-  (:mode beamer-style?)
-  `(tmmisc ,(tmtex (cadr t))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Beamer specific abstract markup
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define  (tmtex-make-abstract-data keywords acm arxiv msc pacs abstract)
-  (:mode beamer-style?)
-  (:require (not llncs?))
-  (with result `(,@abstract ,@arxiv ,@acm ,@msc ,@pacs ,@keywords)
-    (if (null? result) "" `(!document ,@result))))
-
-(tm-define (tmtex-abstract-keywords t)
-  (:mode beamer-style?)
-  (:require (not llncs?))
-  (with args (list-intersperse (map tmtex (cdr t)) '(!group (and)))
-    `(keywords (!concat ,@args))))
-
-(tm-define (tmtex-abstract-msc t)
-  (:mode beamer-style?)
-  (:require (not llncs?))
-  (with args (list-intersperse (map tmtex (cdr t)) '(!group (and)))
-    `(subclass (!concat ,@args))))
-
-(tm-define (tmtex-abstract-acm t)
-  (:mode beamer-style?)
-  (:require (not llncs?))
-  (with args (list-intersperse (map tmtex (cdr t)) '(!group (and)))
-    `(CRclass (!concat ,@args))))
-
-(tm-define (tmtex-abstract-pacs t)
-  (:mode beamer-style?)
-  (:require (not llncs?))
-  (with args (list-intersperse (map tmtex (cdr t)) '(!group (and)))
-    `(PACS (!concat ,@args))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Beamer specific frame markup
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-beamer-slide s l)
-  (:mode beamer-style?)
-  `((!begin "frame") ,(tmtex (car l))))
-
-(tm-define (tmtex-beamer-tit s l)
-  (:mode beamer-style?)
-  `(frametitle ,(tmtex (car l))))
diff --git a/TeXmacs/plugins/latex/progs/convert/latex/tmtex-elsevier.scm b/TeXmacs/plugins/latex/progs/convert/latex/tmtex-elsevier.scm
deleted file mode 100644
index 07704e45b8..0000000000
--- a/TeXmacs/plugins/latex/progs/convert/latex/tmtex-elsevier.scm
+++ /dev/null
@@ -1,449 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : tmtex-elsevier.scm
-;; DESCRIPTION : special conversions for elsevier styles
-;; COPYRIGHT   : (C) 2006  Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (convert latex tmtex-elsevier)
-  (:use (convert latex tmtex)))
-
-(tm-define (tmtex-transform-style x)
-  (:mode elsevier-style?)
-  (cond ((== x "elsart") "elsart")
-        ((== x "elsarticle") "elsarticle")
-        ((== x "ifac") "ifacconf")
-        ((== x "jsc") `("amsthm" "elsart"))
-        (else x)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Initialization of elsevier style
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define note-counter 0)
-(define author-counter 0)
-(define clustered? #f)
-
-(define (init-elsevier body)
-  (set! clustered? #f)
-  (set! note-counter 0)
-  (set! author-counter 0))
-
-(tm-define (tmtex-style-init body)
-  (:mode elsevier-style?)
-  (init-elsevier body))
-
-(tm-define (tmtex-style-init body)
-  (:mode ifac-style?)
-  (init-elsevier body)
-  (set! tmtex-packages (cons "cite-author-year" tmtex-packages))
-  (latex-set-packages '("natbib"))
-  )
-
-(tm-define (tmtex-style-init body)
-  (:mode jsc-style?)
-  (init-elsevier body)
-  ;;(set! tmtex-packages (cons "cite-author-year" tmtex-packages))
-  (latex-set-packages '("amsthm" "yjsco" ;;"natbib"
-                        )))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Hack for ifac incompatibility with hyperref package
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (latex-as-use-package l)
-  (:require (latex-ifacconf-style?))
-  (if (nin? "hyperref" l)
-      (former l)
-      (let* ((l* (list-remove l "hyperref"))
-             (s1 (if (null? l*) "" (former l*)))
-             (s2 (string-append
-                  "\\makeatletter\n"
-                  "\\let\\old@ssect\\@ssect\n"
-                  "\\makeatother\n"
-                  "\\usepackage{hyperref}\n"
-                  "\\makeatletter\n"
-                  "\\def\\@ssect#1#2#3#4#5#6{%\n"
-                  "  \\NR@gettitle{#6}%\n"
-                  "  \\old@ssect{#1}{#2}{#3}{#4}{#5}{#6}%\n"
-                  "}\n"
-                  "\\makeatother\n")))
-        (string-append s1 s2))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Hack for incomplete ifac list environments
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (latex-extra-preamble)
-  (:require (latex-ifacconf-style?))
-  (string-append "\\newcommand{\\labelitemiii}{\\labelitemi}\n"
-                 "\\newcommand{\\labelitemiv}{\\labelitemii}\n"))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Preprocessing data
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-style-preprocess doc)
-  (:mode elsevier-style?)
-  (elsevier-create-frontmatter doc))
-
-(define (elsarticle-frontmatter? t)
-  (or (func? t 'abstract-data) (func? t 'doc-data) (func? t 'abstract)))
-
-(define (partition l pred?)
-  (if (npair? l) l
-    (letrec ((npred? (lambda (x) (not (pred? x)))))
-      (if (pred? (car l))
-        (receive (h t) (list-break l npred?)
-          (cons h (partition t pred?)))
-        (receive (h t) (list-break l pred?)
-          (cons h (partition t pred?)))))))
-
-(define (elsevier-create-frontmatter t)
-  (if (or (npair? t) (npair? (cdr t))) t
-    (with l (map elsarticle-frontmatter? (cdr t))
-      (if (in? #t l)
-        (with parts (partition (cdr t) elsarticle-frontmatter?)
-          `(,(car t) ,@(map (lambda (x)
-                              (if (elsarticle-frontmatter? (car x))
-                                `(elsevier-frontmatter (,(car t) ,@x))
-                                `(,(car t) ,@x))) parts)))
-        `(,(car t) ,@(map elsevier-create-frontmatter (cdr t)))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Elsevier specific customizations
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-elsevier-frontmatter s l)
-  (:mode elsevier-style?)
-  `((!begin "frontmatter") ,(tmtex (car l))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Elsarticle specific title macros
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-replace-documents t)
-  (:mode elsevier-style?) t)
-
-(tm-define (springer-note-ref l r)
-  (if (list? r)
-    (set! r (tex-concat* (list-intersperse r ",")))
-    (set! r (string-append l r)))
-  `(tnoteref ,r))
-
-(tm-define (tmtex-doc-subtitle-ref s l)
-  (:mode elsevier-style?)
-  (springer-note-ref "sub-" (car l)))
-
-(tm-define (tmtex-doc-subtitle-label s l)
-  (:mode elsevier-style?)
-  (with label (string-append "sub-" (car l))
-    `(tsubtitletext (!option ,label) ,(tmtex (cadr l)))))
-
-(tm-define (tmtex-doc-note-ref s l)
-  (:mode elsevier-style?)
-  (springer-note-ref "note-" (car l)))
-
-(tm-define (tmtex-doc-note-label s l)
-  (:mode elsevier-style?)
-  (with label (string-append "note-" (car l))
-    `(tnotetext (!option ,label) ,(tmtex (cadr l)))))
-
-(tm-define (tmtex-doc-date-ref s l)
-  (:mode elsevier-style?)
-  (springer-note-ref "date-" (car l)))
-
-(tm-define (tmtex-doc-date-label s l)
-  (:mode elsevier-style?)
-  (with label (string-append "date-" (car l))
-    `(tdatetext (!option ,label) ,(tmtex (cadr l)))))
-
-(tm-define (tmtex-doc-misc-ref s l)
-  (:mode elsevier-style?)
-  (springer-note-ref "misc-" (car l)))
-
-(tm-define (tmtex-doc-misc-label s l)
-  (:mode elsevier-style?)
-  (with label (string-append "misc-" (car l))
-    `(tmisctext (!option ,label) ,(tmtex (cadr l)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Elsevier specific authors macros
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (springer-author-note-ref l r)
-  (if (list? r)
-    (set! r (tex-concat* (list-intersperse r ",")))
-    (set! r (string-append l r)))
-  `(fnref ,r))
-
-(tm-define (tmtex-author-note-ref s l)
-  (:mode elsevier-style?)
-  (springer-author-note-ref "author-note-" (car l)))
-
-(tm-define (tmtex-author-note-label s l)
-  (:mode elsevier-style?)
-  (with label (string-append "author-note-" (car l))
-    `(fntext (!option ,label) ,(tmtex (cadr l)))))
-
-(tm-define (tmtex-author-misc-ref s l)
-  (:mode elsevier-style?)
-  (springer-author-note-ref "author-misc-" (car l)))
-
-(tm-define (tmtex-author-misc-label s l)
-  (:mode elsevier-style?)
-  (with label (string-append "author-misc-" (car l))
-    `(fmtext (!option ,label) ,(tmtex (cadr l)))))
-
-(tm-define (tmtex-author-affiliation t)
-  (:mode elsevier-style?)
-  `(address ,(tmtex (cadr t))))
-
-(tm-define (tmtex-author-affiliation-ref s l)
-  (:mode elsevier-style?)
-  (springer-author-note-ref "affiliation-" (car l)))
-
-(tm-define (tmtex-author-affiliation-label s l)
-  (:mode elsevier-style?)
-  (with label (string-append "affiliation-" (car l))
-    `(address (!option ,label) ,(tmtex (cadr l)))))
-
-(tm-define (tmtex-author-email t)
-  (:mode elsevier-style?)
-  `(ead ,(tmtex (cadr t))))
-
-(tm-define (tmtex-author-email-ref s l)
-  (:mode elsevier-style?)
-  (springer-note-ref "author-email-" (car l)))
-
-(tm-define (tmtex-author-email-label s l)
-  (:mode elsevier-style?)
-  `(ead ,(tmtex (cadr l))))
-
-(tm-define (tmtex-author-homepage t)
-  (:mode elsevier-style?)
-  `(ead (!option "url") ,(tmtex (cadr t))))
-
-(tm-define (tmtex-author-homepage-ref s l)
-  (:mode elsevier-style?)
-  (springer-note-ref "author-url-" (car l)))
-
-(tm-define (tmtex-author-homepage-label s l)
-  (:mode elsevier-style?)
-  `(ead (!option "url") ,(tmtex (cadr l))))
-
-(tm-define (tmtex-author-name t)
-  (:mode elsevier-style?)
-  `(author ,(tmtex (cadr t))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Elsart and IFAC specific title macros
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-replace-documents t)
-  (:mode elsevier-style?)
-  (:require (or (elsart-style?) (jsc-style?) (ifac-style?)))
-  (if (npair? t) t
-    (with (r s) (list (car t) (map tmtex-replace-documents (cdr t)))
-      (if (!= r 'document) `(,r ,@s)
-        `(concat ,@(list-intersperse s '(next-line)))))))
-
-(tm-define (springer-note-ref l r)
-  (:mode elsevier-style?)
-  (:require (or (elsart-style?) (jsc-style?) (ifac-style?)))
-  (if (list? r)
-    `(!concat ,@(map (lambda (x) `(thanksref ,x)) r))
-    `(thanksref ,(string-append l r))))
-
-(tm-define (tmtex-doc-subtitle-label s l)
-  (:mode elsevier-style?)
-  (:require (or (elsart-style?) (jsc-style?) (ifac-style?)))
-  (with label (string-append "sub-" (car l))
-    `(thankssubtitle (!option ,label) ,(tmtex (cadr l)))))
-
-(tm-define (tmtex-doc-note-label s l)
-  (:mode elsevier-style?)
-  (:require (or (elsart-style?) (jsc-style?) (ifac-style?)))
-  (with label (string-append "note-" (car l))
-    `(thanks (!option ,label) ,(tmtex (cadr l)))))
-
-(tm-define (tmtex-doc-date-label s l)
-  (:mode elsevier-style?)
-  (:require (or (elsart-style?) (jsc-style?) (ifac-style?)))
-  (with label (string-append "date-" (car l))
-    `(thanksdate (!option ,label) ,(tmtex (cadr l)))))
-
-(tm-define (tmtex-doc-misc-label s l)
-  (:mode elsevier-style?)
-  (:require (or (elsart-style?) (jsc-style?) (ifac-style?)))
-  (with label (string-append "misc-" (car l))
-    `(thanksmisc (!option ,label) ,(tmtex (cadr l)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Elsart specific authors macros
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (springer-author-note-ref l r)
-  (:mode elsevier-style?)
-  (:require (or (elsart-style?) (jsc-style?) (ifac-style?)))
-  (springer-note-ref l r))
-
-(tm-define (tmtex-author-note-label s l)
-  (:mode elsevier-style?)
-  (:require (or (elsart-style?) (jsc-style?) (ifac-style?)))
-  (with label (string-append "author-note-" (car l))
-    `(thanks (!option ,label) ,(tmtex (cadr l)))))
-
-(tm-define (tmtex-author-misc-label s l)
-  (:mode elsevier-style?)
-  (:require (or (elsart-style?) (jsc-style?) (ifac-style?)))
-  (with label (string-append "author-misc-" (car l))
-    `(thanksamisc (!option ,label) ,(tmtex (cadr l)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; IFAC specific authors macros
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-author-email-label s l)
-  (:mode ifac-style?)
-  (with label (string-append "author-email-" (car l))
-    `(thanksemail (!option ,label) ,(tmtex (cadr l)))))
-
-(tm-define (tmtex-author-homepage-label s l)
-  (:mode ifac-style?)
-  (with label (string-append "author-url-" (car l))
-    `(thankshomepage (!option ,label) ,(tmtex (cadr l)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Elsevier title and author preprocessing
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-prepare-doc-data l)
-  (:mode elsevier-style?)
-  (set! clustered?
-    (or
-      (contains-stree? l '(doc-title-options "cluster-by-affiliation"))
-      (contains-stree? l '(doc-title-options "cluster-all"))))
-  (set! l (map tmtex-replace-documents l))
-  (set! l (make-references l 'doc-subtitle #f #f))
-  (set! l (make-references l 'doc-note #f #f))
-  (set! l (make-references l 'doc-misc #f #f))
-  (set! l (make-references l 'doc-date #f #f))
-  (set! l (make-references l 'author-note #t #f))
-  (set! l (make-references l 'author-misc #t #f))
-  (if (ifac-style?)
-    (begin
-      (set! l (make-references l 'author-email #t #f))
-      (set! l (make-references l 'author-homepage #t #f))))
-  (if clustered?
-    (set! l (make-references l 'author-affiliation #t #f)))
-  l)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Elsevier title and author presentation
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-make-doc-data titles subtitles authors dates miscs notes
-                                subtitles-l dates-l miscs-l notes-l tr ar)
-  (:mode elsevier-style?)
-  (let* ((authors (filter nnull? authors))
-         (authors (if (null? authors) '()
-                    `((!paragraph ,@authors))))
-         (titles (tmtex-concat-Sep (map cadr titles)))
-         (notes  `(,@subtitles ,@dates ,@miscs ,@notes))
-         (notes  (if (null? notes) '()
-                   `(,(springer-note-ref "" (map cadr notes)))))
-         (result `(,@titles ,@notes))
-         (result (if (null? result) '() `((title (!concat ,@result)))))
-         (result `(,@result ,@subtitles-l ,@notes-l
-                   ,@miscs-l ,@dates-l ,@authors)))
-    (if (null? result) "" `(!document ,@result))))
-
-(tm-define (tmtex-make-author names affs emails urls miscs notes
-                              affs* emails* urls* miscs* notes*)
-  (:mode elsevier-style?)
-  (let* ((names  (tmtex-concat-Sep (map cadr names)))
-         (notes* (if (ifac-style?)
-                   `(,@emails* ,@urls* ,@miscs* ,@notes*)
-                   `(,@miscs* ,@notes*)))
-         (notes* (if (null? notes*) '()
-                   `(,(springer-author-note-ref "" (map cadr notes*)))))
-         (affs*  (if (null? affs*) '()
-                   `((!option
-                       (!concat ,@(list-intersperse (map cadr affs*) ","))))))
-         (result `(,@names ,@notes*))
-         (result (if (null? result) '()
-                   `((author ,@affs* (!concat ,@result)))))
-         (result `(,@result ,@affs ,@emails ,@urls ,@miscs ,@notes)))
-    (if (null? result) '() `(!paragraph ,@result))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Elsevier abstract macros
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-abstract-keywords t)
-  (:mode elsevier-style?)
-  (with args (list-intersperse (map tmtex (cdr t)) '(!concat (sep) " "))
-    `((!begin "keyword") (!concat ,@args))))
-
-(tm-define (tmtex-abstract-msc t)
-  (:mode elsevier-style?)
-  (with args (list-intersperse (map tmtex (cdr t)) '(!concat (sep) " "))
-    `(!concat (MSC) " " (!concat ,@args))))
-
-(tm-define (tmtex-abstract-pacs t)
-  (:mode elsevier-style?)
-  (with args (list-intersperse (map tmtex (cdr t)) '(!concat (sep) " "))
-    `(!concat (PACS) " " (!concat ,@args))))
-
-(tm-define  (tmtex-make-abstract-data keywords acm arxiv msc pacs abstract)
-  (:mode elsevier-style?)
-  (if (or (nnull? msc) (nnull? pacs) (nnull? acm) (nnull? arxiv))
-    (set! keywords
-      `(((!begin "keyword") (!document ,@(map cadr keywords)
-                                       ,@pacs ,@msc ,@acm ,@arxiv)))))
-  `(!document ,@abstract ,@keywords))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; The Elsevier style is quite ugly.
-;; Transform equations into eqnarray* for more uniform alignment.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-equation s l)
-  (:mode elsevier-style?)
-  (tmtex-env-set "mode" "math")
-  (let ((r (tmtex (car l))))
-    (tmtex-env-reset "mode")
-    (if (== s "equation")
-        (list (list '!begin "eqnarray") r)  ;; FIXME: why do elsequation
-        (list (list '!begin "eqnarray*") r) ;; and elsequation* not work?
-        )))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; The elsarticle class does not insert a 'References' section title
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;(tm-define (tmtex-bib t)
-;;  (:mode elsevier-style?)
-;;  (:require (elsarticle-style?))
-;;  (tmtex-biblio (car t) (cdr t) #t))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Elsevier specific macros
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(smart-table latex-texmacs-macro
-  (:mode elsevier-style?)
-  (:require (elsarticle-style?))
-  (comma #f))
-
-(smart-table latex-texmacs-preamble
-  (:mode elsevier-style?)
-  (:require (elsarticle-style?))
-  (qed (!append (renewcommand "\\qed" "") "\n")))
diff --git a/TeXmacs/plugins/latex/progs/convert/latex/tmtex-ieee.scm b/TeXmacs/plugins/latex/progs/convert/latex/tmtex-ieee.scm
deleted file mode 100644
index a129a41391..0000000000
--- a/TeXmacs/plugins/latex/progs/convert/latex/tmtex-ieee.scm
+++ /dev/null
@@ -1,215 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : tmtex-ieee.scm
-;; DESCRIPTION : special conversions for ieee styles
-;; COPYRIGHT   : (C) 2013  Joris van der Hoeven, François Poulain
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (convert latex tmtex-ieee)
-  (:use (convert latex tmtex)))
-
-(define conference? #f)
-(define clustered? #f)
-
-(tm-define (tmtex-style-init doc)
-  (:mode ieee-tran-style?)
-  ;; ieeetran require to be in conference mode to print affiliations and emails
-  (set! conference? (contains-tags? doc '(author-email author-affiliation)))
-  (set! clustered?
-    (and
-      conference?
-      (or
-        (contains-stree? doc '(doc-title-options "cluster-all"))
-        (contains-stree? doc '(doc-title-options "cluster-by-affiliation"))))))
-
-(tm-define (tmtex-transform-style x)
-  (:mode ieee-style?)
-  (cond ((== x "ieeeconf") "IEEEconf")
-        ((and (or clustered? conference?) (== x "ieeetran"))
-         '("conference" "IEEEtran"))
-        ((== x "ieeetran") "IEEEtran")
-        (else x)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; IEEEconf metadata presentation
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-append-authors l)
-  (:mode ieee-conf-style?)
-  (set! l (filter nnull? l))
-  (if (null? l) l
-    (with sep '(!concat (!linefeed) (and) (!linefeed))
-      `((author (!indent (!concat ,@(list-intersperse (map cadr l) sep))))))))
-
-(tm-define (tmtex-make-author names affiliations emails urls miscs notes
-                              affs-l emails-l urls-l miscs-l notes-l)
-  (:mode ieee-conf-style?)
-  (let* ((names (tmtex-concat-Sep (map cadr names)))
-         (result `(,@names ,@urls ,@notes ,@miscs))
-         (result (if (null? result) '() `((!concat ,@result))))
-         (result `(,@result ,@affiliations ,@emails)))
-    (if (null? result) '() `(author (!paragraph ,@result)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; IEEEconf specific titlemarkup
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-author-affiliation t)
-  (:mode ieee-conf-style?)
-  `((!begin "affiliation") ,(tmtex (cadr t))))
-
-(tm-define (tmtex-author-email t)
-  (:mode ieee-conf-style?)
-  (set! t (tmtex-remove-line-feeds t))
-  `(email ,(tmtex (cadr t))))
-
-(tm-define (tmtex-author-homepage t)
-  (:mode ieee-conf-style?)
-  (set! t (tmtex-remove-line-feeds t))
-  `(tmfnhomepage ,(tmtex-inline (cadr t))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; IEEEtran metadata presentation
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-append-authors l)
-  (:mode ieee-tran-style?)
-  (set! l (filter nnull? l))
-  (if (null? l) l
-    (with sep '(!concat (!linefeed) "and~")
-      `((author (!indent (!concat ,@(list-intersperse (map cadr l) sep))))))))
-
-(tm-define (tmtex-append-authors l)
-  (:mode ieee-tran-style?)
-  (:require conference?)
-  (set! l (filter nnull? l))
-  (if (null? l) l
-    (with sep '(!concat (!linefeed) (and) (!linefeed))
-      `((author (!indent (!concat ,@(list-intersperse (map cadr l) sep))))))))
-
-(tm-define (tmtex-make-author names affs emails urls miscs notes
-                              affs* emails* urls* miscs* notes*)
-  (:mode ieee-tran-style?)
-  (:require conference?)
-  (let* ((names (tmtex-concat-Sep (map cadr names)))
-         (affs         (if clustered? affs (map cadr affs)))
-         (authorblockN `(,@names ,@affs* ,@emails* ,@urls ,@notes ,@miscs))
-         (authorblockN (if (null? authorblockN) '()
-                         `((IEEEauthorblockN (!concat ,@authorblockN)))))
-         (authorblockA `(,@affs ,@emails))
-         (authorblockA (if clustered?
-                         (map (lambda (x)
-                                `(IEEEauthorblockA ,x)) authorblockA)
-                         (list-intersperse authorblockA '(!nextline))))
-         (authorblockA (if (and (not clustered?) (nnull? authorblockA))
-                         `((IEEEauthorblockA (!concat ,@authorblockA)))
-                         authorblockA)))
-    (if (and (null? authorblockN) (null? authorblockA)) '()
-      (if clustered?
-        `(,@authorblockN ,@authorblockA)
-        `(author (!paragraph ,@authorblockN ,@authorblockA))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; IEEEtran clustered metadata presentation
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-prepare-doc-data l)
-  (:mode ieee-tran-style?)
-  (:require clustered?)
-  (set! l (map tmtex-replace-documents l))
-  (set! l (make-references l 'author-affiliation #t #t))
-  (set! l (make-references l 'author-email #t #t))
-  l)
-
-(tm-define (tmtex-append-authors l)
-  (:mode ieee-tran-style?)
-  (:require clustered?)
-  (set! l (filter nnull? l))
-  (if (null? l) ()
-    (let* ((sep   '(!concat (!linefeed)))
-           (names (map (lambda (au)
-                         (filter (lambda (x)
-                                   (== (car x) 'IEEEauthorblockN)) au)) l))
-           (names (map car (filter nnull? names)))
-           (names (tmtex-concat-sep (map cadr names)))
-           (l*    (map (lambda (au)
-                         (filter (lambda (x)
-                                   (!= (car x) 'IEEEauthorblockN)) au)) l))
-           (l*    (filter nnull? l*))
-           (l*    (apply append l*))
-           (names (if (null? names) '() `((IEEEauthorblockN ,@names))))
-           (r     `(,@names ,@l*)))
-      `((author (!indent (!concat ,@(list-intersperse r sep))))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; IEEEtran specific titlemarkup
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-author-affiliation-ref s l)
-  (:mode ieee-tran-style?)
-  `(IEEEauthorrefmark ,(car l)))
-
-(tm-define (tmtex-author-affiliation-label s l)
-  (:mode ieee-tran-style?)
-  `(!concat (IEEEauthorrefmark ,(car l))
-            ,(tmtex (cadr l))))
-
-(tm-define (tmtex-author-email-ref s l)
-  (:mode ieee-tran-style?)
-  `(IEEEauthorrefmark ,(car l)))
-
-(tm-define (tmtex-author-email-label s l)
-  (:mode ieee-tran-style?)
-  `(!concat (IEEEauthorrefmark ,(car l))
-                               ,(tmtex-author-email l)))
-
-(tm-define (tmtex-author-affiliation t)
-  (:mode ieee-tran-style?)
-  (:require conference?)
-  `(IEEEauthorblockA ,(tmtex (cadr t))))
-
-(tm-define (tmtex-author-email t)
-  (:mode ieee-tran-style?)
-  (:require conference?)
-  (set! t (tmtex-remove-line-feeds t))
-  `(tmieeeemail ,(tmtex (cadr t))))
-
-(tm-define (tmtex-abstract-keywords t)
-  (:mode ieee-tran-style?)
-  (with args (list-intersperse (map tmtex (cdr t)) '(!concat (tmsep) " "))
-    `((!begin "IEEEkeywords") (!concat ,@args))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Further tweaking for IEEE styles
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (ieee-replace t)
-  (cond ((nlist? t) t)
-        ((== t '(hbar)) '(ieeehbar))
-        ((== t '(jmath)) '(ieeejmath))
-        ((== t '(amalg)) '(ieeeamalg))
-        ((== t '(coprod)) '(ieeecoprod))
-        (else (map ieee-replace t))))
-
-(tm-define (tmtex-postprocess-body x)
-  (:mode ieee-conf-style?)
-  (ieee-replace x))
-
-(logic-group latex-texmacs-symbol%
-  ieeehbar ieeejmath ieeeamalg ieeecoprod)
-
-(smart-table latex-texmacs-macro
-  (ieeehbar (not "h"))
-  (ieeejmath "j")
-  (ieeecoprod
-   (!group (mathop (mbox (reflectbox (rotatebox
-     (!option "origin=c") "180" (!math (prod))))))))
-  (ieeeamalg
-   (!group (mathop (mbox (reflectbox (rotatebox
-     (!option "origin=c") "180" (!math (Pi)))))))))
diff --git a/TeXmacs/plugins/latex/progs/convert/latex/tmtex-revtex.scm b/TeXmacs/plugins/latex/progs/convert/latex/tmtex-revtex.scm
deleted file mode 100644
index 2610c4a6e6..0000000000
--- a/TeXmacs/plugins/latex/progs/convert/latex/tmtex-revtex.scm
+++ /dev/null
@@ -1,226 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : tmtex-revtex.scm
-;; DESCRIPTION : special conversions for RevTeX styles
-;; COPYRIGHT   : (C) 2012  Joris van der Hoeven, François Poulain
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (convert latex tmtex-revtex)
-  (:use (convert latex tmtex)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; RevTeX style options
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define revtex-style '("revtex4-1"))
-(define revtex-clustered? #f)
-
-(tm-define (tmtex-style-init body)
-  (:mode revtex-style?)
-  (set! revtex-style '("revtex4-1"))
-  (set! revtex-clustered? #f))
-
-(define (revtex-set-style-option s)
-    (set! revtex-style (append (list s) revtex-style)))
-
-(tm-define (tmtex-transform-style x)
-  (:mode revtex-style?) revtex-style)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; RevTeX data preprocessing
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (stree-contains? t u)
-  (cond ((== t u) #t)
-        ((nlist? t) #f)
-        ((null? t) #f)
-        (else (in? #t (map (lambda (x) (stree-contains? x u)) t)))))
-
-(define (insert-maketitle-after t u)
-  (cond ((nlist? t) t)
-        ((== (car t) u) `(!document ,t (maketitle)))
-        (else `(,(car t) ,@(map (lambda (x) (insert-maketitle-after x u))
-                                (cdr t))))))
-(define (revtex-style-preprocess doc)
-  (cond ((stree-contains? doc 'abstract-data)
-         (insert-maketitle-after doc 'abstract-data))
-        ((stree-contains? doc 'doc-data)
-         (insert-maketitle-after doc 'doc-data))
-        (else doc)))
-
-(tm-define (tmtex-style-preprocess doc)
-  (:mode aip-style?)
-  (revtex-set-style-option "aip")
-  (revtex-set-style-option "reprint")
-  (revtex-style-preprocess doc))
-
-(tm-define (tmtex-style-preprocess doc)
-  (:mode aps-style?)
-  (if (stree-contains? doc 'abstract-keywords)
-    (revtex-set-style-option "showkeys"))
-  (if (stree-contains? doc 'abstract-msc)
-    (revtex-set-style-option "showpacs"))
-  (revtex-set-style-option "aps")
-  (revtex-set-style-option "reprint")
-  (revtex-style-preprocess doc))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; RevTeX metadata presentation
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-make-author names affiliations emails urls miscs notes
-                              affs-l emails-l urls-l miscs-l notes-l)
-  (:mode revtex-style?)
-  (if (and (not revtex-clustered?) (null? affiliations))
-    (set! affiliations `((noaffiliation))))
-  (let* ((names (map (lambda (x) `(author ,x))
-                   (list-intersperse (map cadr names) '(tmSep))))
-         (result `(,@names ,@emails ,@urls ,@notes ,@miscs ,@affiliations)))
-    (if (null? result) '() `(!paragraph ,@result))))
-
-(tm-define (tmtex-make-doc-data titles subtitles authors dates miscs notes
-                                subtits-l dates-l miscs-l notes-l tr ar)
-  (:mode revtex-style?)
-  (let* ((title-data `(,@titles ,@subtitles ,@notes ,@miscs))
-         (title-data (if (null? title-data) '() `((!paragraph ,@title-data))))
-         (authors*   (filter pair? authors)))
-    (if (and (null? title-data) (null? authors*) (null? dates)) '()
-        `(!document ,@title-data ,@authors* ,@dates))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; RevTeX clustered authors presentation
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (merge-with tags l)
-  (if (null? l) '()
-    (letrec ((remove-tag
-               (lambda (x)
-                 (let* ((root  (car x))
-                        (args  (cdr x))
-                        (args* (filter (lambda (y) (nin? y tags)) args)))
-                   `(,root ,@args*)))))
-      (let* ((last    (cAr l))
-             (others  (cDr l))
-             (others* (map remove-tag others)))
-        (if (null? tags)
-          (set! last `(,(car last)
-                       ,@(cdr last) (author-affiliation (noaffiliation)))))
-        (map (lambda (x) `(doc-author ,x)) (append others* (list last)))))))
-
-(define (cluster-by tag l)
-  (if (or (null? l) (nlist? (car l))) '()
-      (letrec ((get-affiliations
-                (lambda (x) (tmtex-select-args-by-func tag x))))
-        (let* ((author (car l))
-               (aff    (get-affiliations author))
-               (same   (filter (lambda (x) (== aff (get-affiliations x))) l))
-               (others (filter (lambda (x) (!= aff (get-affiliations x))) l)))
-          (append (merge-with aff same) (cluster-by tag others))))))
-
-(tm-define (tmtex-doc-data s l)
-  (:mode revtex-style?)
-  (:require (or revtex-clustered?
-                (stree-contains?  l '(doc-title-options "cluster-all"))
-                (stree-contains?  l '(doc-title-options
-                                       "cluster-by-affiliation"))))
-  (if (not revtex-clustered?) (set! revtex-clustered? #t))
-  (set! l (map tmtex-replace-documents l))
-  (let* ((subtitles (map tmtex-doc-subtitle
-                         (tmtex-select-args-by-func 'doc-subtitle l)))
-         (notes     (map tmtex-doc-note
-                         (tmtex-select-args-by-func 'doc-note l)))
-         (miscs     (map tmtex-doc-misc
-                         (tmtex-select-args-by-func 'doc-misc l)))
-         (dates     (map tmtex-doc-date
-                         (tmtex-select-args-by-func 'doc-date l)))
-         (titles    (map tmtex-doc-title
-                         (tmtex-select-args-by-func 'doc-title l)))
-         (authors   (map cadr
-                         (tmtex-select-args-by-func 'doc-author l)))
-         (authors   `((!document ,@(map tmtex-doc-author
-                                        (cluster-by
-                                          'author-affiliation authors))))))
-    (with r (tmtex-make-doc-data titles subtitles authors dates miscs notes
-                                 '() '() '() '() '() '())
-    (set! revtex-clustered? #f)
-    r)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; RevTeX specific titlemarkup
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-doc-subtitle t)
-  (:mode revtex-style?)
-  `(tmsubtitle ,(tmtex (cadr t))))
-
-(tm-define (tmtex-doc-note t)
-  (:mode revtex-style?)
-  (set! t (tmtex-remove-line-feeds t))
-  `(tmnote ,(tmtex (cadr t))))
-
-(tm-define (tmtex-doc-misc t)
-  (:mode revtex-style?)
-  (set! t (tmtex-remove-line-feeds t))
-  `(tmmisc ,(tmtex (cadr t))))
-
-(tm-define (tmtex-doc-date t)
-  (:mode revtex-style?)
-  `(date ,(tmtex (cadr t))))
-
-(tm-define (tmtex-author-affiliation t)
-  (:mode revtex-style?)
-  (if (== t '(author-affiliation (noaffiliation)))
-    '(noaffiliation)
-    `(affiliation ,(tmtex (cadr t)))))
-
-(tm-define (tmtex-author-email t)
-  (:mode revtex-style?)
-  (set! t (tmtex-remove-line-feeds t))
-  `(email (!option "Email: ") ,(tmtex (cadr t))))
-
-(tm-define (tmtex-author-homepage t)
-  (:mode revtex-style?)
-  (set! t (tmtex-remove-line-feeds t))
-  `(homepage (!option "Web: ") ,(tmtex (cadr t))))
-
-(tm-define (tmtex-author-note t)
-  (:mode revtex-style?)
-  (set! t (tmtex-remove-line-feeds t))
-  `(tmnote ,(tmtex (cadr t))))
-
-(tm-define (tmtex-author-misc t)
-  (:mode revtex-style?)
-  (set! t (tmtex-remove-line-feeds t))
-  `(tmmisc ,(tmtex (cadr t))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; RevTeX specific abstract markup
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (move-in-abstract what in)
-  (if (null? in)
-    (if (null? what) '() `(((!begin "abstract") (document ,@what))))
-    `(((!begin "abstract") (!document ,@(map cadr in) ,@what)))))
-
-(tm-define  (tmtex-make-abstract-data keywords acm arxiv msc pacs abstract)
-  (:mode revtex-style?)
-  (with class `(,@acm ,@arxiv ,@msc)
-    (set! abstract (move-in-abstract class abstract)))
-  (with result `(,@abstract ,@pacs ,@keywords)
-    (if (null? result) "" `(!document ,@result))))
-
-(tm-define (tmtex-abstract-keywords t)
-  (:mode revtex-style?)
-  (with args (tmtex-concat-sep (map tmtex (cdr t)))
-    `(keywords ,@args)))
-
-(tm-define (tmtex-abstract-pacs t)
-  (:mode revtex-style?)
-  (with args (tmtex-concat-sep (map tmtex (cdr t)))
-    `(pacs ,@args)))
diff --git a/TeXmacs/plugins/latex/progs/convert/latex/tmtex-springer.scm b/TeXmacs/plugins/latex/progs/convert/latex/tmtex-springer.scm
deleted file mode 100644
index d9e8507769..0000000000
--- a/TeXmacs/plugins/latex/progs/convert/latex/tmtex-springer.scm
+++ /dev/null
@@ -1,409 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : tmtex-springer.scm
-;; DESCRIPTION : special conversions for Springer styles
-;; COPYRIGHT   : (C) 2012  Joris van der Hoeven, François Poulain
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (convert latex tmtex-springer)
-  (:use (convert latex tmtex)
-        (convert latex latex-define)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Springer style options
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define llncs? #f)
-
-(tm-define (tmtex-style-init body)
-  (:mode springer-style?)
-  (set! llncs? #f))
-
-(tm-define (tmtex-style-init body)
-  (:mode llncs-style?)
-  (set! llncs? #t))
-
-(tm-define (tmtex-transform-style x)
-  (:mode springer-style?)
-  (if (== x "llncs") x "svjour3"))
-
-(tm-define (tmtex-transform-style x)
-  (:mode svmono-style?)
-  x)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Springer metadata presentation
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-make-author names affiliations emails urls miscs notes
-                              affs-l emails-l urls-l miscs-l notes-l)
-  (:mode springer-style?)
-  (let* ((names (tmtex-concat-Sep (map cadr names)))
-         (result `(,@names ,@urls ,@notes ,@miscs)))
-    (if (null? result) '() `(author (!paragraph ,@result)))))
-
-(define (springer-append in l)
-  (set! l (filter nnull? l))
-  (if (< (length l) 1) l
-    (with lf `(!concat (!linefeed) (and) (!linefeed))
-      `((,in
-          (!indent (!concat ,@(list-intersperse (map cadr l) lf))))))))
-
-(define (svjour-make-title titles notes miscs)
-  (let* ((titles (tmtex-concat-Sep (map cadr titles)))
-         (result `(,@titles ,@notes ,@miscs)))
-    (if (null? result) '()
-      `((title (!concat ,@result))))))
-
-(define (svjour-make-doc-data
-         titles subtits authors affs dates miscs notes tr ar)
-  `(!document
-     ,@(svjour-make-title titles notes miscs)
-     ,@subtits
-     ,@tr
-     ,@ar
-     ,@(springer-append 'author authors)
-     ,@(springer-append 'institute affs)
-     ,@dates
-     (maketitle)))
-
-(tm-define (tmtex-doc-data s l)
-  (:mode springer-style?)
-  (set! l (map tmtex-replace-documents l))
-  (let* ((subtitles (map tmtex-doc-subtitle
-                         (tmtex-select-args-by-func 'doc-subtitle l)))
-         (notes     (map tmtex-doc-note
-                         (tmtex-select-args-by-func 'doc-note l)))
-         (miscs     (map tmtex-doc-misc
-                         (tmtex-select-args-by-func 'doc-misc l)))
-         (dates     (map tmtex-doc-date
-                         (tmtex-select-args-by-func 'doc-date l)))
-         (authors   (map tmtex-doc-author
-                         (tmtex-select-args-by-func 'doc-author l)))
-         (ar        (map tmtex-doc-running-author
-                         (tmtex-select-args-by-func 'doc-running-author l)))
-         (titles    (map tmtex-doc-title
-                         (tmtex-select-args-by-func 'doc-title l)))
-         (tr        (map tmtex-doc-running-title
-                         (tmtex-select-args-by-func 'doc-running-title l)))
-         (affs      (map tmtex-affiliation-group
-                         (cluster-by-affiliations
-                           (tmtex-select-args-by-func 'doc-author l)))))
-    (svjour-make-doc-data titles subtitles authors affs dates miscs notes tr ar)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Springer affiliation clustering
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (springer-clear-aff aff a filter?)
-  (if (pair? (cadr a))
-      (with datas (cdadr a)
-        (if (and filter?
-                 (== `(,aff)
-                     (filter (lambda (x) (func? x 'author-affiliation))
-                             datas)))
-            '()
-            `(doc-author
-              (author-data ,@(filter (lambda (x) (!= aff x)) datas)))))
-      '()))
-
-(define (next-affiliation l)
-  (cond ((or (null? l) (nlist? l)) #f)
-        ((in?   (car l) '(doc-author author-data)) (next-affiliation (cdr l)))
-        ((==    (car l) 'author-affiliation) l)
-        ((list? (car l))
-         (with na (next-affiliation (car l))
-           (if na na (next-affiliation (cdr l)))))
-        (else #f)))
-
-(define (cluster-by-affiliations l)
-  (if (nlist? l) l
-    (let* ((aff     (next-affiliation l))
-           (hasaff  (filter (lambda (x)
-                              (or (not aff)
-                                  (and (list? x) (list? (cdr x))
-                                       (list? (cadr x))
-                                       (in? aff (cdadr x))))) l))
-           (hasaff* (map (lambda (x) (springer-clear-aff aff x #f)) hasaff))
-           (l*      (map (lambda (x) (springer-clear-aff aff x #t)) l))
-           (l*      (filter nnull? l*))
-           (aff*    `(affiliation-group
-                       ,(if aff (cadr aff) '()) ,@hasaff*)))
-      (if aff (append `(,aff*) (cluster-by-affiliations l*)) `(,aff*)))))
-
-(tm-define (tmtex-affiliation-group t)
-  (with old-tmtex-make-author (eval tmtex-make-author)
-    (set! tmtex-make-author
-      (lambda (names affiliations emails urls miscs notes
-                     affs-l emails-l urls-l miscs-l notes-l)
-        (with names (tmtex-concat-Sep (map cadr names))
-          (cond ((and (null? names) (null? emails)) '())
-                ((or (null? names) (null? emails))
-                 `(!concat ,@names ,@emails))
-                (else `(!concat ,@names " " ,@emails))))))
-    (let* ((affs     (cadr t))
-           (affs     (if (null? affs) '()
-                       `((!concat (!linefeed)(at)(!linefeed) ,(tmtex affs)))))
-           (auth-sep '(!concat " " (and) " "))
-           (authors  (map tmtex-doc-author (cddr t)))
-           (authors  (list-intersperse authors auth-sep)))
-      (set! tmtex-make-author (eval old-tmtex-make-author))
-      (if (and (null? authors) (null? affs)) '()
-        `(institute (!concat ,@authors ,@affs))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Springer specific titlemarkup
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-doc-running-title t)
-  (:mode springer-style?)
-  `(titlerunning ,(tmtex (cadr t))))
-
-(tm-define (tmtex-doc-subtitle t)
-  (:mode springer-style?)
-  `(subtitle ,(tmtex (cadr t))))
-
-(tm-define (tmtex-doc-note t)
-  (:mode springer-style?)
-  `(tmnote ,(tmtex (cadr t))))
-
-(tm-define (tmtex-doc-misc t)
-  (:mode springer-style?)
-  `(tmmisc ,(tmtex (cadr t))))
-
-(tm-define (tmtex-doc-date t)
-  (:mode springer-style?)
-  `(date ,(tmtex (cadr t))))
-
-(tm-define (tmtex-doc-running-author t)
-  (:mode springer-style?)
-  `(authorrunning ,(tmtex (cadr t))))
-
-(tm-define (tmtex-author-affiliation t)
-  (:mode springer-style?)
-  `(institute ,(tmtex (cadr t))))
-
-(tm-define (tmtex-author-email t)
-  (:mode springer-style?)
-  `(email ,(tmtex (cadr t))))
-
-(tm-define (tmtex-author-homepage t)
-  (:mode springer-style?)
-  `(tmfnhomepage ,(tmtex (cadr t))))
-
-(tm-define (tmtex-author-note t)
-  (:mode springer-style?)
-  `(tmnote ,(tmtex (cadr t))))
-
-(tm-define (tmtex-author-misc t)
-  (:mode springer-style?)
-  `(tmmisc ,(tmtex (cadr t))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Springer specific abstract markup
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define  (tmtex-make-abstract-data keywords acm arxiv msc pacs abstract)
-  (:mode springer-style?)
-  (:require (not llncs?))
-  (with result `(,@abstract ,@arxiv ,@acm ,@msc ,@pacs ,@keywords)
-    (if (null? result) "" `(!document ,@result))))
-
-(tm-define (tmtex-abstract-keywords t)
-  (:mode springer-style?)
-  (:require (not llncs?))
-  (with args (list-intersperse (map tmtex (cdr t)) '(!group (and)))
-    `(keywords (!concat ,@args))))
-
-(tm-define (tmtex-abstract-msc t)
-  (:mode springer-style?)
-  (:require (not llncs?))
-  (with args (list-intersperse (map tmtex (cdr t)) '(!group (and)))
-    `(subclass (!concat ,@args))))
-
-(tm-define (tmtex-abstract-acm t)
-  (:mode springer-style?)
-  (:require (not llncs?))
-  (with args (list-intersperse (map tmtex (cdr t)) '(!group (and)))
-    `(CRclass (!concat ,@args))))
-
-(tm-define (tmtex-abstract-pacs t)
-  (:mode springer-style?)
-  (:require (not llncs?))
-  (with args (list-intersperse (map tmtex (cdr t)) '(!group (and)))
-    `(PACS (!concat ,@args))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Springer SVMono style (basically like default LaTeX class with subtitle)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-transform-style x)
-  (:mode svmono-style?) x)
-
-(tm-define (tmtex-doc-subtitle t)
-  (:mode svmono-style?)
-  `(subtitle ,(tmtex (cadr t))))
-
-(define (svmono-make-title titles notes miscs)
-  (let* ((titles (tmtex-concat-Sep (map cadr titles)))
-         (result `(,@titles ,@notes ,@miscs)))
-    (if (null? result) '()
-      `((title (!indent (!paragraph ,@result)))))))
-
-(tm-define (tmtex-make-doc-data titles subtitles authors dates miscs notes
-                                subtits-l dates-l miscs-l notes-l tr ar)
-  (:mode svmono-style?)
-  `(!document
-     ,@(svmono-make-title titles notes miscs)
-     ,@subtitles
-     ,@(tmtex-append-authors authors)
-     ,@dates
-     (maketitle)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Springer LLNCS metadata presentation
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-doc-data s l)
-  (:mode llncs-style?)
-  (set! l (map tmtex-replace-documents l))
-  (let* ((subtitles (map tmtex-doc-subtitle
-                         (tmtex-select-args-by-func 'doc-subtitle l)))
-         (notes     (map tmtex-doc-note
-                         (tmtex-select-args-by-func 'doc-note l)))
-         (miscs     (map tmtex-doc-misc
-                         (tmtex-select-args-by-func 'doc-misc l)))
-         (dates     (map tmtex-doc-date
-                         (tmtex-select-args-by-func 'doc-date l)))
-         (ar        (map tmtex-doc-running-author
-                         (tmtex-select-args-by-func 'doc-running-author l)))
-         (titles    (map tmtex-doc-title
-                         (tmtex-select-args-by-func 'doc-title l)))
-         (tr        (map tmtex-doc-running-title
-                         (tmtex-select-args-by-func 'doc-running-title l)))
-         (authors   (tmtex-select-args-by-func 'doc-author l))
-         (affs      (map tmtex-author-affiliation
-                         (collect-affiliations authors)))
-         (authors   (map tmtex-doc-author
-                         (replace-affiliations authors 0))))
-    (svjour-make-doc-data titles subtitles authors affs dates miscs notes tr ar)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Springer LLNCS affiliation clustering
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (collect-affiliations l)
-  (if (nlist? l) l
-    (let* ((aff     (next-affiliation l))
-           (l*      (map (lambda (x) (springer-clear-aff aff x #t)) l))
-           (l*      (filter nnull? l*))
-           (aff*    (if aff `(affiliation-group ,(cadr aff)))))
-      (if aff (append `(,aff*) (collect-affiliations l*)) '()))))
-
-(define (springer-replace-aff aff a n)
-  (let* ((ref   `(author-affiliation-ref ,(number->string n)))
-         (datas (cdadr a)))
-    `(doc-author (author-data ,@(map (lambda (x)
-                                       (if (!= aff x) x ref)) datas)))))
-
-(define (replace-affiliations l n)
-  (with aff (next-affiliation l)
-    (if (or (nlist? l) (not aff)) l
-        (let* ((n    (1+ n))
-               (l*   (filter (lambda (x) (pair? (cadr x))) l))
-               (l**  (map (lambda (x) (springer-replace-aff aff x n)) l*)))
-          (replace-affiliations l** n)))))
-
-(define (tmtex-author-affiliation-ref t)
-  `(inst ,(tmtex (cadr t))))
-
-(tm-define (tmtex-doc-author t)
-  (:mode llncs-style?)
-  (set! t (tmtex-replace-documents t))
-  (if (or (npair? t) (npair? (cdr t)) (not (func? (cadr t) 'author-data))) '()
-    (let* ((datas  (cdadr t))
-           (miscs  (map tmtex-author-misc
-                        (tmtex-select-args-by-func 'author-misc datas)))
-           (notes  (map tmtex-author-note
-                        (tmtex-select-args-by-func 'author-note datas)))
-           (emails (map tmtex-author-email
-                        (tmtex-select-args-by-func 'author-email datas)))
-           (urls   (map tmtex-author-homepage
-                        (tmtex-select-args-by-func 'author-homepage datas)))
-           (names  (map tmtex-author-name
-                        (tmtex-select-args-by-func 'author-name datas)))
-           (affs   (map tmtex-author-affiliation-ref
-                        (tmtex-select-args-by-func
-                          'author-affiliation-ref datas))))
-      (tmtex-make-author names affs emails urls miscs notes
-                         '() '() '() '() '()))))
-
-(tm-define (tmtex-make-author names affiliations emails urls miscs notes
-                              affs-l emails-l urls-l miscs-l notes-l)
-  (:mode llncs-style?)
-  (let* ((names (tmtex-concat-Sep (map cadr names)))
-         (result `(,@names ,@affiliations))
-         (result (if (null? result) '() `((!concat ,@result))))
-         (result `(,@result ,@urls ,@notes ,@miscs)))
-    (if (null? result) '() `(author (!paragraph ,@result)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; LLNCS specific abstract markup
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-abstract-keywords t)
-  (:mode springer-style?)
-  (:require llncs?)
-  (with args (list-intersperse (map tmtex (cdr t)) '(!group (tmsep)))
-    `(keywords (!concat ,@args))))
-
-(tm-define  (tmtex-make-abstract-data keywords acm arxiv msc pacs abstract)
-  (:mode springer-style?)
-  (:require llncs?)
-  (with class `(,@keywords ,@acm ,@arxiv ,@msc ,@pacs)
-    (if (nnull? class)
-      (set! abstract
-        `(((!begin "abstract")
-          (!document ,@(map cadr abstract) ,@class)))))
-    `(!document ,@abstract)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Springer specific macros
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(smart-table latex-texmacs-env-preamble
-  (:mode sv-style?)
-  ("theorem" #f)
-  ("proposition" #f)
-  ("lemma" #f)
-  ("corollary" #f)
-  ("definition" #f)
-  ("exercise" #f)
-  ("problem" #f)
-  ("solution" #f)
-  ("remark" #f)
-  ("note" #f)
-  ("case" #f)
-  ("conjecture" #f)
-  ("example" #f)
-  ("property" #f)
-  ("question" #f)
-  ("claim" #f))
-
-(smart-table latex-texmacs-environment
-  (:mode sv-style?)
-  ("proof" #f))
-
-(smart-table latex-texmacs-macro
-  (:mode sv-style?)
-  (qed #f))
-
-(smart-table latex-texmacs-macro
-  (:mode svmono-style?)
-  (chapter #f))
diff --git a/TeXmacs/plugins/latex/progs/convert/latex/tmtex-widgets.scm b/TeXmacs/plugins/latex/progs/convert/latex/tmtex-widgets.scm
deleted file mode 100644
index 3276a6e949..0000000000
--- a/TeXmacs/plugins/latex/progs/convert/latex/tmtex-widgets.scm
+++ /dev/null
@@ -1,115 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : tmtex-widgets.scm
-;; DESCRIPTION : manual debugging of LaTeX errors
-;; COPYRIGHT   : (C) 2015  Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (convert latex tmtex-widgets)
-  (:use (convert latex tmtex)
-        (utils library cursor)
-        (check check-master)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; The widget for examing LaTeX errors
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (latex-error-buffer)
-  (string->url "tmfs://aux/latex-error"))
-
-(define (latex-source-buffer)
-  (string->url "tmfs://aux/latex-source"))
-
-(define (latex-error-digest err)
-  (tree->string (tree-ref err 1)))
-
-(define (string->document s)
-  (with l (string-tokenize-by-char (string->tmstring s) #\newline)
-    `(document ,@l)))
-
-(define (latex-error-doc* err)
-  (if (<= (tree-arity err) 2)
-      (string->document (tree->string (tree-ref err 0)))
-      `(document
-         (padded
-           (with "color" "dark red"
-             ,(string->document (tree->string (tree-ref err 2))))
-           "0fn" "0.5fn")
-         (padded
-           (with "color" "black"
-             ,(string->document (tree->string (tree-ref err 3))))
-           "0fn" "0.5fn")
-         (padded
-           (with "color" "dark blue"
-             ,(string->document (tree->string (tree-ref err 4))))
-           "0fn" "0.5fn")
-         (padded
-           (with "color" "black"
-             ,(string->document (tree->string (tree-ref err 5))))
-           "0fn" "0.5fn"))))
-
-(define (latex-error-doc err)
-  `(document (code ,(latex-error-doc* err))))
-
-(define (decode-path t)
-  (and (tree-func? t 'tuple)
-       (list-and (map tree-integer? (tree-children t)))
-       (map tree->number (tree-children t))))
-
-(define (latex-error-track buf err)
-  (when (>= (tree-arity err) 8)
-    (let* ((p (decode-path (tree-ref err 7)))
-           (b (buffer-get-body buf))
-           (src (apply tree-ref (cons b p))))
-      (when src
-        (with-buffer buf
-          (tree-select src)
-          (tree-go-to src :start))))))
-
-(define (latex-error-show doc err)
-  (when (>= (tree-arity err) 7)
-    (let* ((pos (tree->number (tree-ref err 6)))
-           (l (- (get-line-number doc pos) 1))
-           (c (get-column-number doc pos))
-           (src (buffer-get-body "tmfs://aux/latex-source")))
-      (and-with line (tree-ref src l)
-        (when (and (tree-atomic? line)
-                   (<= c (string-length (tree->string line))))
-          (with-buffer "tmfs://aux/latex-source"
-            (let* ((p (tree->path line))
-                   (b (append p (list 0)))
-                   (e (append p (list c))))
-              (selection-set b e)
-              (tree-go-to line c))))))))
-
-(tm-widget ((latex-errors-widget buf doc errs) quit)
-  (let* ((digest (map latex-error-digest errs))
-         (errnr 0)
-         (err (list-ref errs errnr))
-         (sel (lambda (msg)
-                (set! errnr (or (list-find-index digest (cut == <> msg)) 0))
-                (set! err (list-ref errs errnr))
-                (buffer-set-body "tmfs://aux/latex-error"
-                                 (latex-error-doc (list-ref errs errnr)))
-                (latex-error-track buf err)
-                (latex-error-show doc err))))
-    (padded
-      (resize "800px" "200px"
-        (scrollable
-          (choice (sel answer) digest "")))
-      ======
-      (resize "800px" "150px"
-        (texmacs-input (latex-error-doc (list-ref errs errnr))
-                       `(style (tuple "generic"))
-                       (latex-error-buffer)))
-      ======
-      (resize "800px" "450px"
-        (texmacs-input (string->document doc)
-                       `(style (tuple "verbatim-source"))
-                       (latex-source-buffer))))))
diff --git a/TeXmacs/plugins/latex/progs/convert/latex/tmtex.scm b/TeXmacs/plugins/latex/progs/convert/latex/tmtex.scm
deleted file mode 100644
index 1c1b1cd356..0000000000
--- a/TeXmacs/plugins/latex/progs/convert/latex/tmtex.scm
+++ /dev/null
@@ -1,5062 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : tmtex.scm
-;; DESCRIPTION : conversion of TeXmacs trees into TeX/LaTeX trees
-;; COPYRIGHT   : (C) 2002  Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (convert latex tmtex)
-  (:use (convert tools tmpre)
-    (convert tools old-tmtable)
-    (convert tools tmlength)
-    (convert rewrite tmtm-brackets)
-    (convert latex texout)
-    (doc tmdoc-markup)
-    (convert latex latex-tools)
-  ) ;:use
-) ;texmacs-module
-
-
-(tm-define tmtex-debug-mode? #f)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Global variables
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define tmtex-style "generic")
-(tm-define tmtex-packages '())
-(tm-define tmtex-replace-style? #t)
-
-(define tmtex-languages '())
-
-(define tmtex-colors '())
-
-(define tmtex-colormaps '())
-
-(define tmtex-env (make-ahash-table))
-
-(define tmtex-macros (make-ahash-table))
-
-(define tmtex-dynamic (make-ahash-table))
-
-(define tmtex-serial 0)
-
-(define tmtex-ref-cnt 1)
-
-(define tmtex-auto-produce 0)
-
-(define tmtex-auto-consume 0)
-
-(define tmtex-image-root-url (unix->url "image"))
-
-(define tmtex-image-root-string "image")
-
-(define tmtex-appendices? #f)
-
-(define tmtex-indirect-bib? #f)
-
-(define tmtex-mathjax? #f)
-
-(define tmtex-image-progress 0)
-
-(define tmtex-image-total 0)
-
-(define tmtex-progress? #f)
-
-(define (tmtex-count-images t)
-  (cond ((null? t) 0)
-        ((npair? t) 0)
-        ((in? (car t)
-           '(image graphics
-              draw-over
-              draw-under
-              para
-              table
-              tformat
-              equation
-              equation*
-              eqnarray
-              eqnarray*
-              section
-              subsection
-              subsubsection)
-         ) ;in?
-         1
-        ) ;
-        (else (let loop
-                ((lst t) (sum 0))
-                (if (null? lst)
-                  sum
-                  (if (pair? lst)
-                    (loop (cdr lst) (+ sum (tmtex-count-images (car lst))))
-                    (+ sum (tmtex-count-images lst))
-                  ) ;if
-                ) ;if
-              ) ;let
-        ) ;else
-  ) ;cond
-) ;define
-
-(define (tmtex-image-increment)
-  (set! tmtex-image-progress (+ tmtex-image-progress 1))
-  (when (and tmtex-progress? (> tmtex-image-total 0))
-    (latex-progress-update tmtex-image-progress)
-  ) ;when
-) ;define
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Style
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-modes
-  ;;; Elsevier styles
-  (elsevier-style% (in? tmtex-style '("elsart" "jsc" "elsarticle" "ifac")))
-  (jsc-style% (in? tmtex-style '("jsc")) elsevier-style%)
-  (elsarticle-style% (in? tmtex-style '("elsarticle")) elsevier-style%)
-  (elsart-style% (in? tmtex-style '("elsart")) elsevier-style%)
-  (ifac-style% (in? tmtex-style '("ifac")) elsevier-style%)
-
-  ;;; ACM styles
-  (acm-style% (in? tmtex-style
-                '("acmconf"
-                  "sig-alternate"
-                  "acm_proc_article-sp"
-                  "acmsmall"
-                  "acmlarge"
-                  "acmtog"
-                  "sigconf"
-                  "sigchi"
-                  "sigplan"
-                  "acmart")
-              ) ;in?
-  ) ;acm-style%
-  (acm-art-style% (in? tmtex-style
-                    '("acmsmall"
-                      "acmlarge"
-                      "acmtog"
-                      "sigconf"
-                      "sigchi"
-                      "sigplan"
-                      "acmart")
-                  ) ;in?
-    acm-style%
-  ) ;acm-art-style%
-  (sig-alternate-style% (in? tmtex-style '("sig-alternate")) acm-style%)
-  (acm-conf-style% (in? tmtex-style '("acmconf"
-                                      "sig-alternate"
-                                      "acm_proc_article-sp"))
-    acm-style%
-  ) ;acm-conf-style%
-  (acm-small-style% (in? tmtex-style '("acmsmall")) acm-art-style%)
-  (acm-large-style% (in? tmtex-style '("acmlarge")) acm-art-style%)
-  (acm-tog-style% (in? tmtex-style '("acmtog")) acm-art-style%)
-  (acm-sigconf-style% (in? tmtex-style '("sigconf")) acm-art-style%)
-  (acm-sigchi-style% (in? tmtex-style '("sigchi")) acm-art-style%)
-  (acm-sigplan-style% (in? tmtex-style '("sigplan")) acm-art-style%)
-
-  ;; AMS styles
-  (ams-style% (in? tmtex-style '("amsart")))
-
-  ;; Revtex styles
-  (revtex-style% (in? tmtex-style '("aip" "aps")))
-  (aip-style% (in? tmtex-style '("aip")) revtex-style%)
-  (aps-style% (in? tmtex-style '("aps")) revtex-style%)
-  (sv-style% (in? tmtex-style '("svjour" "svjour3" "llncs" "svmono")))
-
-  ;; Springer styles
-  (springer-style% (in? tmtex-style '("svjour" "svjour3" "llncs" sv-style%)))
-  (svjour-style% (in? tmtex-style '("svjour" "svjour3")) springer-style%)
-  (llncs-style% (in? tmtex-style '("llncs")) springer-style%)
-  (svmono-style% (in? tmtex-style '("svmono")) sv-style%)
-
-  ;; IEEE styles
-  (ieee-style% (in? tmtex-style '("ieeeconf" "ieeetran")))
-  (ieee-conf-style% (in? tmtex-style '("ieeeconf")) ieee-style%)
-  (ieee-tran-style% (in? tmtex-style '("ieeetran")) ieee-style%)
-
-  ;; Other styles
-  (beamer-style% (in? tmtex-style '("beamer" "old-beamer")))
-  (natbib-package% (in? "cite-author-year" tmtex-packages))
-) ;texmacs-modes
-
-(tm-define (tmtex-style-init body) (noop))
-
-(tm-define (tmtex-style-preprocess doc) doc)
-
-(define (import-tmtex-styles)
-  (cond ((elsevier-style?) (import-from (convert latex tmtex-elsevier)))
-        ((acm-style?) (import-from (convert latex tmtex-acm)))
-        ((ams-style?) (import-from (convert latex tmtex-ams)))
-        ((revtex-style?) (import-from (convert latex tmtex-revtex)))
-        ((ieee-style?) (import-from (convert latex tmtex-ieee)))
-        ((beamer-style?) (import-from (convert latex tmtex-beamer)))
-        ((or (springer-style?) (svmono-style?))
-         (import-from (convert latex tmtex-springer))
-        ) ;
-        (else (noop))
-  ) ;cond
-) ;define
-
-(tm-define (tmtex-provided-packages) '())
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Initialization from options
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (tmtex-initialize opts)
-  (set! tmtex-image-progress 0)
-  (set! tmtex-progress? #f)
-  (set! tmtex-ref-cnt 1)
-  (set! tmtex-env (make-ahash-table))
-  (set! tmtex-macros (make-ahash-table))
-  (set! tmtex-dynamic (make-ahash-table))
-  (set! tmtex-serial 0)
-  (set! tmtex-auto-produce 0)
-  (set! tmtex-auto-consume 0)
-  (set! tmtex-mathjax? #f)
-  (if (== (url-suffix current-save-target) "tex")
-    (begin
-      (set! tmtex-image-root-url (url-unglue current-save-target 4))
-      (with suf
-        (url-suffix tmtex-image-root-url)
-        (when (!= suf "")
-          (set! tmtex-image-root-url
-            (url-unglue tmtex-image-root-url (+ (string-length suf) 1))
-          ) ;set!
-        ) ;when
-      ) ;with
-      (set! tmtex-image-root-string (url->unix (url-tail tmtex-image-root-url)))
-    ) ;begin
-    (begin
-      (set! tmtex-image-root-url (unix->url "image"))
-      (set! tmtex-image-root-string "image")
-    ) ;begin
-  ) ;if
-  (set! tmtex-appendices? #f)
-  (set! tmtex-replace-style?
-    (== (assoc-ref opts "texmacs->latex:replace-style") "on")
-  ) ;set!
-  (set! tmtex-indirect-bib?
-    (== (assoc-ref opts "texmacs->latex:indirect-bib") "on")
-  ) ;set!
-  (set! tmtex-use-macros? (== (assoc-ref opts "texmacs->latex:use-macros") "on"))
-  (when (== (assoc-ref opts "texmacs->latex:mathjax") "on")
-    (tmtex-env-set "mode" "math")
-    (set! tmtex-mathjax? #t)
-  ) ;when
-  (with charset
-    (or (assoc-ref opts "texmacs->latex:encoding") "utf-8")
-    (if tmtex-cjk-document? (set! charset "utf-8"))
-    (cond ((== (locase-all charset) "utf-8")
-           (set! tmtex-use-catcodes? #f)
-           (set! tmtex-use-unicode? #t)
-          ) ;
-          ((== charset "cork")
-           (set! tmtex-use-catcodes? #t)
-           (set! tmtex-use-unicode? #f)
-          ) ;
-    ) ;cond
-  ) ;with
-) ;define
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Determination of the mode in which commands are used
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define command-text-uses (make-ahash-table))
-
-(define command-math-uses (make-ahash-table))
-
-(define (compute-mode-stats t mode)
-  (when (tree-compound? t)
-    (let* ((h (if (== mode (tree "math")) command-math-uses command-text-uses))
-           (n (or (ahash-ref h (tree-label t)) 0))
-          ) ;
-      (ahash-set! h (tree-label t) (+ n 1))
-      (for-each (lambda (i)
-                  (with nmode
-                    (tree-child-env t i "mode" mode)
-                    (compute-mode-stats (tree-ref t i) nmode)
-                  ) ;with
-                ) ;lambda
-        (.. 0 (tree-arity t))
-      ) ;for-each
-    ) ;let*
-  ) ;when
-) ;define
-
-(define (init-mode-stats t)
-  (set! command-text-uses (make-ahash-table))
-  (set! command-math-uses (make-ahash-table))
-  (compute-mode-stats (tm->tree t) "text")
-) ;define
-
-(define (mode-protect t)
-  (cond ((and (pair? t)
-           (symbol? (car t))
-           (string-starts? (symbol->string (car t)) "tmtext")
-         ) ;and
-         `(text ,t)
-        ) ;
-        ((and (pair? t)
-           (symbol? (car t))
-           (or (string-starts? (symbol->string (car t)) "tmmath")
-             (string-starts? (symbol->string (car t)) "math")
-           ) ;or
-         ) ;and
-         `(ensuremath ,t)
-        ) ;
-        ((func? t '!concat) `(!concat ,@(map mode-protect (cdr t))))
-        (else t)
-  ) ;cond
-) ;define
-
-(define (tmtex-pre t)
-  (cond ((tm-func? t 'para) (cons '!paragraph (map-in-order tmtex-pre (tm-children t))))
-        ((tm-func? t 'concat)
-         (cons '!paragraph (map-in-order tmtex-pre (tm-children t)))
-        ) ;
-        ((tm-func? t 'mtm 2) `(mtm ,(cadr t) ,(tmtex-pre (caddr t))))
-        ((and (tm-func? t 'assign 2) (tm-atomic? (tm-ref t 0)))
-         (let* ((name (tm-ref t 0))
-                (tag (string->symbol name))
-                (tnr (or (ahash-ref command-text-uses tag) 0))
-                (mnr (or (ahash-ref command-math-uses tag) 0))
-               ) ;
-           ;; (display* tag ", " tnr ", " mnr "\n")
-           (cond ((and (string-ends? name "*")
-                    (or (string-starts? name "itemize")
-                      (string-starts? name "enumerate")
-                      (string-starts? name "description")
-                    ) ;or
-                  ) ;and
-                  ""
-                 ) ;
-                 ((>= tnr mnr)
-                  (with r
-                    (tmtex t)
-                    ;; (display* t " -> " r "\n")
-                    (when (and (> mnr 0) (func? r 'newcommand 2))
-                      (with val (mode-protect (caddr r)) (set! r (list (car r) (cadr r) val)))
-                    ) ;when
-                    r
-                  ) ;with
-                 ) ;
-                 (else (tmtex-env-set "mode" "math")
-                   (with r
-                     (tmtex t)
-                     (tmtex-env-reset "mode")
-                     ;; (display* t " -> " r "\n")
-                     (when (and (> tnr 0) (func? r 'newcommand 2))
-                       (with val (mode-protect (caddr r)) (set! r (list (car r) (cadr r) val)))
-                     ) ;when
-                     r
-                   ) ;with
-                 ) ;else
-           ) ;cond
-         ) ;let*
-        ) ;
-        (else (tmtex t))
-  ) ;cond
-) ;define
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Data
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-table tmtex-table-props%
-  (block ("" "l" "" #t))
-  (block* ("" "c" "" #t))
-  (wide-block ("{\\noindent}" "@{}X@{}" "" #t))
-  (tabular ("" "l" "" #f))
-  (tabular* ("" "c" "" #f))
-  (wide-tabular ("{\\noindent}" "@{}X@{}" "" #f))
-  (matrix ((,(string->symbol "left(")) "c" (,(string->symbol "right)")) #f))
-  (det ((left|) "c" (right|) #f))
-  (bmatrix ((,(string->symbol "left[")) "c" (,(string->symbol "right]")) #f))
-  (stack ("" "c" "" #f))
-  (choice ((left\{) "l" (right.) #f))
-  (tabbed ("" "l" "" #f))
-  (tabbed* ("" "l" "" #f))
-  (rcl-table ("{\\setlength\\arraylinesep{0.4em}\\everymath={\\displaystyle}" "rcl" "}" #f)
-  ) ;rcl-table
-  (three-line-table ("" "c" "" #f))
-) ;logic-table
-
-(logic-table tex-with-cmd%
- (("font-family" "rm") textrm)
- (("font-family" "ss") textsf)
- (("font-family" "tt") texttt)
- (("font-series" "medium") textmd)
- (("font-series" "bold") textbf)
- (("font-shape" "right") textup)
- (("font-shape" "slanted") textsl)
- (("font-shape" "italic") textit)
- (("font-shape" "small-caps") textsc)
- (("par-columns" "2") (!begin "multicols" "2"))
- (("par-columns" "3") (!begin "multicols" "3"))
- (("par-mode" "center") (!begin "center"))
- (("par-mode" "left") (!begin "flushleft"))
- (("par-mode" "right") (!begin "flushright"))
-) ;logic-table
-
-(logic-table tex-with-cmd-math%
- (("font" "cal") mathcal)
- (("font" "cal*") mathscr)
- (("font" "cal**") EuScript)
- (("font" "Euler") mathfrak)
- (("font" "Bbb") mathbb)
- (("font" "Bbb*") mathbbm)
- (("font" "Bbb**") mathbbmss)
- (("font" "Bbb***") mathbb)
- (("font" "Bbb****") mathds)
- (("font-family" "rm") mathrm)
- (("font-family" "ss") mathsf)
- (("font-family" "tt") mathtt)
- (("font-series" "medium") tmmathmd)
- (("font-series" "bold") tmmathbf)
- (("font-shape" "right") mathrm)
- (("font-shape" "slanted") mathit)
- (("font-shape" "italic") mathit)
- (("font-shape" "small-caps") mathrm)
- (("math-font" "cal") mathcal)
- (("math-font" "cal*") mathscr)
- (("math-font" "cal**") EuScript)
- (("math-font" "Euler") mathfrak)
- (("math-font" "Bbb") mathbb)
- (("math-font" "Bbb*") mathbbm)
- (("math-font" "Bbb**") mathbbmss)
- (("math-font" "Bbb***") mathbb)
- (("math-font" "Bbb****") mathds)
- (("math-font-family" "mr") mathrm)
- (("math-font-family" "ms") mathsf)
- (("math-font-family" "mt") mathtt)
- (("math-font-family" "normal") mathnormal)
- (("math-font-family" "rm") mathrm)
- (("math-font-family" "ss") mathsf)
- (("math-font-family" "tt") mathtt)
- (("math-font-family" "bf") mathbf)
- (("math-font-family" "it") mathit)
- (("math-font-series" "bold") tmmathbf)
-) ;logic-table
-
-(logic-table tex-assign-cmd%
- (("font-family" "rm") rmfamily)
- (("font-family" "ss") ssfamily)
- (("font-family" "tt") ttfamily)
- (("font-series" "medium") mdseries)
- (("font-series" "bold") bfseries)
- (("font-shape" "right") upshape)
- (("font-shape" "slanted") slshape)
- (("font-shape" "italic") itshape)
- (("font-shape" "small-caps") scshape)
-) ;logic-table
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Manipulation of the environment
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (tmtex-env-list var)
-  (let ((r (ahash-ref tmtex-env var)))
-    (if r r '())
-  ) ;let
-) ;define
-
-(define (tmtex-env-get var)
-  (let ((val (tmtex-env-list var)))
-    (and (pair? val) (car val))
-  ) ;let
-) ;define
-
-(define (tmtex-env-get-previous var)
-  (let ((val (tmtex-env-list var)))
-    (if (or (null? val) (null? (cdr val))) #f (cadr val))
-  ) ;let
-) ;define
-
-(define (tmtex-math-mode?)
-  (== (tmtex-env-get "mode") "math")
-) ;define
-
-(tm-define (tmtex-env-set var val)
-  (ahash-set! tmtex-env var (cons val (tmtex-env-list var)))
-) ;tm-define
-
-(tm-define (tmtex-env-reset var)
-  (let ((val (tmtex-env-list var)))
-    (if (nnull? val) (ahash-set! tmtex-env var (cdr val)))
-  ) ;let
-) ;tm-define
-
-(tm-define (tmtex-env-assign var val)
-  (tmtex-env-reset var)
-  (tmtex-env-set var val)
-) ;tm-define
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Frequently used TeX construction subroutines
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-concat-sep l)
-  (set! l (list-intersperse l '(!concat (tmsep) " ")))
-  (if (null? l) '() `((!concat ,@l)))
-) ;tm-define
-
-(tm-define (tmtex-concat-Sep l)
-  (set! l (list-intersperse l '(!concat (tmSep) " ")))
-  (if (null? l) '() `((!concat ,@l)))
-) ;tm-define
-
-(define (tex-concat-similar l)
-  (cond ((or (null? l) (null? (cdr l))) l)
-        ((> (length l) 1000)
-         (let* ((s (quotient (length l) 2)) (h (list-head l s)) (t (list-tail l s)))
-           (tex-concat-similar `((!concat ,@h) (!concat ,@t)))
-         ) ;let*
-        ) ;
-        (else (let ((r (tex-concat-similar (cdr l))))
-                (cond ((and (func? (car l) '!sub) (func? (car r) '!sub))
-                       (cons (list '!sub (tex-concat (list (cadar l) (cadar r)))) (cdr r))
-                      ) ;
-                      ((and (func? (car l) '!sup) (func? (car r) '!sup))
-                       (cons (list '!sup (tex-concat (list (cadar l) (cadar r)))) (cdr r))
-                      ) ;
-                      (else (cons (car l) r))
-                ) ;cond
-              ) ;let
-        ) ;else
-  ) ;cond
-) ;define
-
-(define (tex-concat-list l)
-  (cond ((null? l) l)
-        ((== (car l) "") (tex-concat-list (cdr l)))
-        ((func? (car l) '!concat) (append (cdar l) (tex-concat-list (cdr l))))
-        (else (cons (car l) (tex-concat-list (cdr l))))
-  ) ;cond
-) ;define
-
-(tm-define (tex-concat l)
-  (:synopsis "Horizontal concatenation of list of LaTeX expressions")
-  (let ((r (tex-concat-similar (tex-concat-list l))))
-    (if (null? r) "" (if (null? (cdr r)) (car r) (cons '!concat r)))
-  ) ;let
-) ;tm-define
-
-(define (tex-concat-strings l)
-  (cond ((< (length l) 2) l)
-        ((and (string? (car l)) (string? (cadr l)))
-         (tex-concat-strings (cons (string-append (car l) (cadr l)) (cddr l)))
-        ) ;
-        (else (cons (car l) (tex-concat-strings (cdr l))))
-  ) ;cond
-) ;define
-
-(tm-define (tex-concat* l)
-  (:synopsis "Variant of tex-concat which concatenates adjacent strings")
-  (tex-concat (tex-concat-strings l))
-) ;tm-define
-
-(tm-define (tex-apply . l)
-  (if (or (tmtex-math-mode?) (logic-in? (car l) tmpre-sectional%))
-    l
-    (list '!group l)
-  ) ;if
-) ;tm-define
-
-(tm-define (tex-math-apply . l) (if (tmtex-math-mode?) l (list 'ensuremath l)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Strings
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (string-starts? s r)
-  (and (>= (string-length s) (string-length r))
-    (== (substring s 0 (string-length r)) r)
-  ) ;and
-) ;define
-
-(define (tmtex-modified-token op s i)
-  (tex-math-apply op
-    (if (= (string-length s) (+ i 1))
-      (substring s i (string-length s))
-      (tex-apply (string->symbol (substring s i (string-length s))))
-    ) ;if
-  ) ;tex-math-apply
-) ;define
-
-(logic-table latex-special-symbols%
- ("less" #\<)
- ("gtr" #\>)
- ("box" (Box))
- ("over" #\:)
- ("||" (|))
- ;; |
- ("precdot" (tmprecdot))
-) ;logic-table
-
-(logic-table latex-text-symbols%
- ("#20AC" euro)
- ("cent" textcent)
- ("circledR" textregistered)
- ("copyright" textcopyright)
- ("currency" textcurrency)
- ("degree" textdegree)
- ("textdegree" textdegree)
- ("mu" textmu)
- ("onehalf" textonehalf)
- ("onequarter" textonequarter)
- ("onesuperior" textonesuperior)
- ("paragraph" P)
- ("threequarters" textthreequarters)
- ("threesuperior" textthreesuperior)
- ("trademark" texttrademark)
- ("twosuperior" texttwosuperior)
- ("yen" textyen)
-) ;logic-table
-
-(tm-define (tmtex-token-sub s group?)
-  (cond ((logic-ref latex-special-symbols% s) (logic-ref latex-special-symbols% s))
-        ((string-starts? s "up-") (tmtex-modified-token 'mathrm s 3))
-        ;; ((string-starts? s "bbb-") (tmtex-modified-token 'mathbbm s 4))
-        ((and (string-starts? s "bbb-")
-           (>= (string-length s) 5)
-           (string-number? (substring s 4 5))
-         ) ;and
-         (tmtex-modified-token 'mathbbm s 4)
-        ) ;
-        ((string-starts? s "bbb-") (tmtex-modified-token 'mathbb s 4))
-        ((string-starts? s "cal-") (tmtex-modified-token 'mathcal s 4))
-        ((and (string-starts? s "cal*-") (>= (string-length s) 6))
-         (tmtex-modified-token 'mathscr s 5)
-        ) ;
-        ((and (string-starts? s "cal**-") (>= (string-length s) 7))
-         (tmtex-modified-token 'EuScript s 6)
-        ) ;
-        ((string-starts? s "frak-") (tmtex-modified-token 'mathfrak s 5))
-        ((string-starts? s "b-cal-")
-         (tex-math-apply 'tmmathbf (tmtex-modified-token 'mathcal s 6))
-        ) ;
-        ((string-starts? s "b-up-") (tmtex-modified-token 'mathbf s 5))
-        ((string-starts? s "b-") (tmtex-modified-token 'tmmathbf s 2))
-        ((and (not (tmtex-math-mode?)) (logic-ref latex-text-symbols% s))
-         (list '!group (list (logic-ref latex-text-symbols% s)))
-        ) ;
-        ((and (string-starts? s "#") (not tmtex-use-catcodes?))
-         (let* ((qs (string-append "<" s ">")) (cv (string-convert qs "Cork" "UTF-8")))
-           (list '!widechar (string->symbol cv))
-         ) ;let*
-        ) ;
-        ((and (string-starts? s "#") tmtex-use-catcodes?)
-         (let* ((qs (string-append "<" s ">"))
-                (us (string-convert qs "Cork" "UTF-8"))
-                (cv (string-convert us "UTF-8" "LaTeX"))
-               ) ;
-           (list '!widechar (string->symbol cv))
-         ) ;let*
-        ) ;
-        (else (let* ((s2 (string-replace s "-" "")) (ss (list (string->symbol s2))))
-                (cond ((logic-in? (car ss) tmtex-protected-symbol%)
-                       (with sy (string->symbol (string-append "tmx" s2)) (list '!symbol (list sy)))
-                      ) ;
-                      ((not (logic-in? (car ss) latex-symbol%))
-                       (display* "TeXmacs] non converted symbol: " s "\n")
-                       (list '!symbol (list 'nonconverted s2))
-                      ) ;
-                      (group? (list '!group ss))
-                      (else (list '!symbol ss))
-                ) ;cond
-              ) ;let*
-        ) ;else
-  ) ;cond
-) ;tm-define
-
-(define (tmtex-token l routine group?)
-  (receive (p1 p2)
-    (list-break (cdr l) (lambda (x) (== x #\>)))
-    (let* ((s (list->string p1)) (q (if (null? p2) '() (cdr p2))) (r (routine q)))
-      (cons (tmtex-token-sub s group?) r)
-    ) ;let*
-  ) ;receive
-) ;define
-
-(define (tmtex-text-sub head l)
-  (if (string? head)
-    (append (string->list head) (tmtex-text-list (cdr l)))
-    (append (list head) (tmtex-text-list (cdr l)))
-  ) ;if
-) ;define
-
-(define (tmtex-special-char? c)
-  (string-index "#$%&_{}" c)
-) ;define
-
-(define (tmtex-break-char? c)
-  (string-index "+ -:=,?;()[]{}<>/" c)
-) ;define
-
-(define (tmtex-text-list-space l)
-  (cond ((null? l) l)
-        ((== (car l) #\space)
-         (cons (list (string->symbol " ")) (tmtex-text-list-space (cdr l)))
-        ) ;
-        (else (tmtex-text-list l))
-  ) ;cond
-) ;define
-
-(define (tmtex-text-list l)
-  (if (null? l)
-    l
-    (let ((c (car l)))
-      (cond ((== c #\<) (tmtex-token l tmtex-text-list #t))
-            ((== c #\space) (cons c (tmtex-text-list-space (cdr l))))
-            ((tmtex-special-char? c)
-             (cons (list (string->symbol (char->string c))) (tmtex-text-list (cdr l)))
-            ) ;
-            ((== c #\~) (tmtex-text-sub "\\~{}" l))
-            ((== c #\^) (tmtex-text-sub "\\^{}" l))
-            ((== c #\\) (tmtex-text-sub '(textbackslash) l))
-            ((== c #\`) (tmtex-text-sub "`" l))
-            ((== c #\x00) (tmtex-text-sub "\\`{}" l))
-            ((== c #\x01) (tmtex-text-sub "\\'{}" l))
-            ((== c #\x04) (tmtex-text-sub "\\\"{}" l))
-            ((== c #\x05) (tmtex-text-sub "\\H{}" l))
-            ((== c #\x06) (tmtex-text-sub "\\r{}" l))
-            ((== c #\x07) (tmtex-text-sub "\\v{}" l))
-            ((== c #\x08) (tmtex-text-sub "\\u{}" l))
-            ((== c #\x09) (tmtex-text-sub "\\={}" l))
-            ((== c #\x0A) (tmtex-text-sub "\\.{}" l))
-            ((== c #\x0E) (tmtex-text-sub "\\k{}" l))
-            ((== c #\x10) (tmtex-text-sub "``" l))
-            ((== c #\x11) (tmtex-text-sub "''" l))
-            ((== c #\x12) (tmtex-text-sub ",," l))
-            ((== c #\x15) (tmtex-text-sub "--" l))
-            ((== c #\x16) (tmtex-text-sub "---" l))
-            ((== c #\x17) (tmtex-text-sub "{}" l))
-            ((== c #\x1B) (tmtex-text-sub "ff" l))
-            ((== c #\x1C) (tmtex-text-sub '(textbackslash) l))
-            ((== c #\x1D) (tmtex-text-sub "fl" l))
-            ((== c #\x1E) (tmtex-text-sub "ffi" l))
-            ((== c #\x1F) (tmtex-text-sub "ffl" l))
-            ((== c #\|) (tmtex-text-sub '(textbar) l))
-            (else (append (if tmtex-use-unicode?
-                            (string->list (string-convert (char->string c) "Cork" "UTF-8"))
-                            (list c)
-                          ) ;if
-                    (tmtex-text-list (cdr l))
-                  ) ;append
-            ) ;else
-      ) ;cond
-    ) ;let
-  ) ;if
-) ;define
-
-(define (tmtex-math-operator l)
-  (receive (p q)
-    (list-break l (lambda (c) (not (char-alphabetic? c))))
-    (let* ((op (tmtex-textual (list->string p))) (tail (tmtex-math-list q)))
-      (if (logic-in? (string->symbol op) latex-operator%)
-        (cons (list '!symbol (tex-apply (string->symbol op))) tail)
-        (cons (post-process-math-text (tex-apply 'tmop op)) tail)
-      ) ;if
-    ) ;let*
-  ) ;receive
-) ;define
-
-(define (tmtex-math-list l)
-  (if (null? l)
-    l
-    (let ((c (car l)))
-      (cond ((== c #\<) (tmtex-token l tmtex-math-list #f))
-            ((tmtex-special-char? c)
-             (cons (list (string->symbol (char->string c))) (tmtex-math-list (cdr l)))
-            ) ;
-            ((== c #\~) (tmtex-math-list (cdr l)))
-            ((== c #\^) (tmtex-math-list (cdr l)))
-            ((== c #\\) (cons (list 'backslash) (tmtex-math-list (cdr l))))
-            ;;            ((== c #\*) (cons '(*) (tmtex-math-list (cdr l))))
-            ((== c #\*) (tmtex-math-list (cdr l)))
-            ((== c #\') (append (list '(prime)) (tmtex-math-list (cdr l))))
-            ((== c #\`) (append (list '(backprime)) (tmtex-math-list (cdr l))))
-            ;;            ((== c #\space) (tmtex-math-list (cdr l)))
-            ((and (char-alphabetic? c) (nnull? (cdr l)) (char-alphabetic? (cadr l)))
-             (tmtex-math-operator l)
-            ) ;
-            (else (with c
-                    (if tmtex-use-unicode?
-                      (string->list (string-convert (char->string c) "Cork" "UTF-8"))
-                      (list c)
-                    ) ;if
-                    (append c (tmtex-math-list (cdr l)))
-                  ) ;with
-            ) ;else
-      ) ;cond
-    ) ;let
-  ) ;if
-) ;define
-
-(define (tmtex-verb-list l)
-  (if (null? l)
-    l
-    (let ((c (car l)))
-      (if (== c #\<)
-        (let ((r (tmtex-token l tmtex-verb-list #t)))
-          (if (char? (car r)) r (cdr r))
-        ) ;let
-        (cons c (tmtex-verb-list (cdr l)))
-      ) ;if
-    ) ;let
-  ) ;if
-) ;define
-
-(define (tmtex-string-break? x start)
-  (or (not (char? x))
-    (and (tmtex-math-mode?)
-      (or (tmtex-break-char? x)
-        (and (char-alphabetic? x) (char-numeric? start))
-        (and (char-alphabetic? start) (char-numeric? x))
-      ) ;or
-    ) ;and
-  ) ;or
-) ;define
-
-(define (tmtex-string-produce l)
-  (if (null? l)
-    l
-    (if (not (tmtex-string-break? (car l) (car l)))
-      (receive (p q)
-        (list-break l (lambda (x) (tmtex-string-break? x (car l))))
-        (cons (list->string p) (tmtex-string-produce q))
-      ) ;receive
-      (if (equal? (car l) #\space)
-        (tmtex-string-produce (cdr l))
-        (cons (if (char? (car l)) (char->string (car l)) (car l))
-          (tmtex-string-produce (cdr l))
-        ) ;cons
-      ) ;if
-    ) ;if
-  ) ;if
-) ;define
-
-(define (tmtex-string s)
-  (if (> (string-length s) 1000)
-    `(!concat ,@(map tmtex (tmstring-split s)))
-    (let* ((l (string->list s))
-           (t (if (tmtex-math-mode?) (tmtex-math-list l) (tmtex-text-list l)))
-           (r (tmtex-string-produce t))
-          ) ;
-      (tex-concat r)
-    ) ;let*
-  ) ;if
-) ;define
-
-(define (string-convert* what from to)
-  (with c
-    (string->list what)
-    (apply string-append
-      (map (lambda (x) (string-convert (char->string x) from to)) c)
-    ) ;apply
-  ) ;with
-) ;define
-
-(define (tmtex-verb-string s)
-  (when (nstring? s)
-    (set! s (texmacs->verbatim (tm->tree s)))
-  ) ;when
-  (let* ((l (string->list s)) (t (tmtex-verb-list l)) (r (tmtex-string-produce t)))
-    (if tmtex-use-unicode?
-      (set! r (map (lambda (x) (string-convert* x "Cork" "UTF-8")) r))
-      (set! r (map unescape-angles r))
-    ) ;if
-    (tex-concat r)
-  ) ;let*
-) ;define
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Entire files
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-transform-style x)
-  (cond ((in? x
-           '("generic"
-             "exam"
-             "old-generic"
-             "old-article"
-             "tmarticle"
-             "tmdoc"
-             "mmxdoc")
-         ) ;in?
-         "article"
-        ) ;
-        ((in? x '("book" "old-book" "tmbook" "tmmanual")) "book")
-        ((in? x '("letter" "old-letter")) "letter")
-        ((in? x '("beamer" "old-beamer")) "beamer")
-        ((in? x '("seminar" "old-seminar")) "slides")
-        ((not tmtex-replace-style?) x)
-        (else #f)
-  ) ;cond
-) ;tm-define
-
-(define (tmtex-filter-styles l)
-  (if (null? l)
-    l
-    (let* ((next (tmtex-transform-style (car l))) (tail (tmtex-filter-styles (cdr l))))
-      (if next (cons next tail) tail)
-    ) ;let*
-  ) ;if
-) ;define
-
-(define (macro-definition? x)
-  (and (func? x 'assign 2) (string? (cadr x)) (func? (caddr x) 'macro))
-) ;define
-
-(define (tmtex-filter-style-macro t)
-  (letrec ((ndef-style? (lambda (x env) (or (not (macro-definition? x)) (nin? (cadr x) env)))
-           ) ;ndef-style?
-           (filter-style-macro (lambda (t env)
-                                 (cond ((nlist? t) t)
-                                       (else (map (cut filter-style-macro <> env) (filter (cut ndef-style? <> env) t)))
-                                 ) ;cond
-                               ) ;lambda
-           ) ;filter-style-macro
-          ) ;
-    (with env
-      (append (logic-first-list 'tmtex-methods%) (logic-first-list 'tmtex-tmstyle%))
-      (filter-style-macro t env)
-    ) ;with
-  ) ;letrec
-) ;define
-
-(define (comment-preamble t)
-  (cond ((string? t) `(!comment ,t))
-        ((or (func? t 'para) (func? t 'concat) (func? t 'document))
-         (map comment-preamble t)
-        ) ;
-        (else t)
-  ) ;cond
-) ;define
-
-(define (tmtex-filter-preamble l)
-  (cond ((or (nlist? l) (null? l)) '())
-        ((macro-definition? l) (list l))
-        ((and (func? l 'hide-preamble 1) (list>0? (cadr l)))
-         (map comment-preamble (cdadr l))
-        ) ;
-        (else (append-map tmtex-filter-preamble (cdr l)))
-  ) ;cond
-) ;define
-
-(define (tmtex-non-preamble-statement? l)
-  (cond ((or (nlist? l) (null? l)) #t)
-        ((== (car l) 'assign) #f)
-        ((== (car l) 'hide-preamble) #f)
-        ((func? l 'mtm 2) (tmtex-non-preamble-statement? (caddr l)))
-        (else #t)
-  ) ;cond
-) ;define
-
-(define (tmtex-filter-body l)
-  (cond ((or (nlist? l) (null? l)) l)
-        ((== (car l) 'assign) "")
-        ((== (car l) 'hide-preamble) "")
-        ((in? (car l) '(concat document))
-         (with a
-           (list-filter (cdr l) tmtex-non-preamble-statement?)
-           (if (null? a)
-             (if (== (car l) 'concat) "" '(document ""))
-             (cons (car l) (map tmtex-filter-body a))
-           ) ;if
-         ) ;with
-        ) ;
-        (else (cons (car l) (map tmtex-filter-body (cdr l))))
-  ) ;cond
-) ;define
-
-(define (tmtex-filter-duplicates* l t)
-  (cond ((null? l) l)
-        ((func? (car l) 'assign 2)
-         (let* ((var (cadr (car l)))
-                (r (tmtex-filter-duplicates* (cdr l) t))
-                (dup? (ahash-ref t var))
-               ) ;
-           (ahash-set! t var #t)
-           (if dup? r (cons (car l) r))
-         ) ;let*
-        ) ;
-        ((or (func? (car l) 'concat) (func? (car l) 'para) (func? (car l) 'document))
-         (with r
-           (tmtex-filter-duplicates* (cdr l) t)
-           (cons (cons (caar l) (tmtex-filter-duplicates* (cdar l) t)) r)
-         ) ;with
-        ) ;
-        (else (cons (car l) (tmtex-filter-duplicates* (cdr l) t)))
-  ) ;cond
-) ;define
-
-(define (tmtex-filter-duplicates l)
-  (with t (make-ahash-table) (tmtex-filter-duplicates* l t))
-) ;define
-
-(define (tmtex-apply-init body init)
-  ;; (display* "init= " init "\n")
-  (cond ((== (assoc-ref init "language") "verbatim")
-         (with init*
-           (assoc-remove! init "language")
-           (tmtex-apply-init `(verbatim ,body) init*)
-         ) ;with
-        ) ;
-        (else body)
-  ) ;cond
-) ;define
-
-(define (tmtex-clean-body b)
-  (when (and (func? b '!document) (> (length b) 1) (== (cadr b) '(!document "")))
-    (set! b (cons (car b) (cddr b)))
-  ) ;when
-  b
-) ;define
-
-(define (tmtex-file l)
-  (let* ((doc (car l))
-         (styles (cadr l))
-         (init* (cadddr l))
-         (init (or (and (!= init* "#f") init*) '(collection)))
-         (init-bis (if (list>1? init) (map (lambda (x) (cons (cadr x) (caddr x))) (cdr init)) '())
-         ) ;init-bis
-         (att (or (cadddr (cdr l)) '()))
-         (doc-pre (tmtex-filter-preamble (tmtex-filter-style-macro doc)))
-         (doc-preamble (tmtex-filter-duplicates doc-pre))
-         (doc-body-pre (tmtex-filter-body doc))
-         (doc-body (tmtex-apply-init doc-body-pre init-bis))
-        ) ;
-    (init-mode-stats doc-body-pre)
-    (latex-set-texmacs-style (if (pair? styles) (car styles) "none"))
-    (latex-set-texmacs-packages (if (pair? styles) (cdr styles) (list)))
-    (if (== (get-preference "texmacs->latex:expand-user-macros") "on")
-      (set! doc-preamble '())
-    ) ;if
-    (if (null? styles)
-      (tmtex doc)
-      (let* ((styles* (tmtex-filter-styles styles))
-             (styles** (if (and (== styles* (list "article")) (in? '(associate "par-columns"
-                                                                      "2") init))
-                         (list '("twocolumn" "article"))
-                         styles*
-                       ) ;if
-             ) ;styles**
-             (preamble* (ahash-with tmtex-env :preamble #t (map-in-order tmtex-pre doc-preamble))
-             ) ;preamble*
-             (body* (tmtex-postprocess-body (tmtex doc-body)))
-             (body** (tmtex-clean-body body*))
-             (needs (list tmtex-languages tmtex-colors tmtex-colormaps))
-            ) ;
-        (list '!file body** styles** needs init preamble*)
-      ) ;let*
-    ) ;if
-  ) ;let*
-) ;define
-
-(define (convert-charset t)
-  (cond ((string? t) (unescape-angles (utf8->cork t)))
-        ((list>0? t) `(,(car t) ,@(map convert-charset (cdr t))))
-  ) ;cond
-) ;define
-
-(define (tmtex-ilx l)
-  `(!invariant ,(car l))
-) ;define
-
-(define (tmtex-mtm l)
-  (cond ((null? l) "")
-        ((null? (cdr l)) (tmtex (car l)))
-        (else (with lab
-                (car l)
-                (when (func? lab 'mtm 1)
-                  (set! lab (cadr lab))
-                ) ;when
-                `(!concat (!marker btm ,lab)
-                   ,(tmtex (cadr l))
-                   (!marker etm ,lab))
-              ) ;with
-        ) ;else
-  ) ;cond
-) ;define
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Simple text
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (tmtex-noop . l)
-  ""
-) ;define
-
-(define (tmtex-default s l)
-  (cons (string->symbol s) (tmtex-list l))
-) ;define
-
-(define (tmtex-id l)
-  (tmtex (car l))
-) ;define
-
-(define (tmtex-first l)
-  (tmtex (car l))
-) ;define
-
-(define (tmtex-style-first s l)
-  (tmtex (car l))
-) ;define
-
-(define (tmtex-second l)
-  (tmtex (cadr l))
-) ;define
-
-(define (tmtex-style-second s l)
-  (tmtex (cadr l))
-) ;define
-
-(define (tmtex-hide-part s l)
-  ""
-) ;define
-
-(define (tmtex-show-part s l)
-  (tmtex (cadr l))
-) ;define
-
-(define (tmtex-error l)
-  (display* "TeXmacs] error in conversion: " l "\n")
-  (if tmtex-debug-mode? "(error)" "")
-) ;define
-
-(define (tmtex-line-note l)
-  `(tmlinenote ,(tmtex (car l))
-     ,(tmtex-decode-length (cadr l))
-     ,(tmtex-decode-length (caddr l)))
-) ;define
-
-(define (tmtex-marginal-left-note l)
-  `(marginpar (!option ,(tmtex (cAr l))) ,(tmtex '()))
-) ;define
-
-(define (tmtex-marginal-right-note l)
-  `(marginpar (!option "") ,(tmtex (cAr l)))
-) ;define
-
-(define (tmtex-marginal-note l)
-  (cond ((== (car l) "left") (tmtex-marginal-left-note (cdr l)))
-        ((== (car l) "right") (tmtex-marginal-right-note (cdr l)))
-        (else `(marginpar ,(tmtex (cAr l))))
-  ) ;cond
-) ;define
-
-(define (tmtex-document l)
-  (cons '!document (tmtex-list l))
-) ;define
-
-(define (tmtex-date l)
-  (tmtex-default "tmdate" l)
-) ;define
-
-(define (tmtex-para l)
-  (tmtex-image-increment)
-  (cons '!paragraph (tmtex-list l))
-) ;define
-
-(define (tmtex-surround-sub l z)
-  (if (null? (cdr l))
-    (list (tex-concat (list (car l) z)))
-    (cons (car l) (tmtex-surround-sub (cdr l) z))
-  ) ;if
-) ;define
-
-(define (tmtex-surround l)
-  (let* ((ll (tmtex-list l)) (x (car ll)) (y (caddr ll)) (z (cadr ll)))
-    (if (func? y '!document)
-      (let* ((a (cadr y)) (b (cddr y)))
-        (cons '!document (tmtex-surround-sub (cons (tex-concat (list x a)) b) z))
-      ) ;let*
-      (tex-concat (list x y z))
-    ) ;if
-  ) ;let*
-) ;define
-
-(define (tmtex-no-space-before? x)
-  (or (func? x '!sub)
-    (func? x '!sup)
-    (and (string? x) (!= x "") (in? (string-ref x 0) '(#\' #\, #\) #\])))
-    (and (func? x '!concat) (tmtex-no-space-before? (cadr x)))
-  ) ;or
-) ;define
-
-(define (tmtex-no-space-after? x)
-  (or (and (string? x) (!= x "") (in? (string-ref x 0) '(#\( #\[)))
-    (and (func? x '!concat) (tmtex-no-space-after? (cAr x)))
-  ) ;or
-) ;define
-
-(define (tmtex-math-concat-spaces l)
-  (if (or (null? l) (null? (cdr l)))
-    l
-    (let* ((head (car l)) (tail (tmtex-math-concat-spaces (cdr l))))
-      (if (or (tmtex-no-space-after? head) (tmtex-no-space-before? (car tail)))
-        (cons head tail)
-        (cons* head " " tail)
-      ) ;if
-    ) ;let*
-  ) ;if
-) ;define
-
-(define (tmtex-rewrite-no-break l)
-  (cond ((null? l) l)
-        ((and (string? (car l))
-           (string-ends? (car l) " ")
-           (nnull? (cdr l))
-           (== (cadr l) '(no-break))
-         ) ;and
-         (let* ((s (substring (car l) 0 (- (string-length (car l)) 1)))
-                (r (tmtex-rewrite-no-break (cddr l)))
-               ) ;
-           (if (== s "") (cons '(!nbsp) r) (cons* s '(!nbsp) r))
-         ) ;let*
-        ) ;
-        (else (cons (car l) (tmtex-rewrite-no-break (cdr l))))
-  ) ;cond
-) ;define
-
-(define (check-double-script? l sub? sup?)
-  (cond ((or (null? l) (npair? (car l))) #f)
-        ((== (caar l) 'rsub) (or sub? (check-double-script? (cdr l) #t sup?)))
-        ((in? (caar l) '(rsup rprime)) (or sup? (check-double-script? (cdr l) sub? #t)))
-        (else #f)
-  ) ;cond
-) ;define
-
-(define (pre-scripts l)
-  (cond ((or (null? l) (null? (cdr l))) l)
-        ((check-double-script? (cdr l) #f #f)
-         (if (== (== (caadr l) 'rsub) (== (caaddr l) 'rsub))
-           (pre-scripts (cons `(!group (concat ,(car l) ,(cadr l))) (cddr l)))
-           (pre-scripts (cons `(!group (concat ,(car l) ,(cadr l) ,(caddr l))) (cdddr l)))
-         ) ;if
-        ) ;
-        (else (cons (car l) (pre-scripts (cdr l))))
-  ) ;cond
-) ;define
-
-(define (tmtex-concat l)
-  ;; (display* "l= " l "\n")
-  (if (> (length l) 50)
-    (with s
-      (quotient (length l) 2)
-      (let ((h (list-head l s)) (t (list-tail l s)))
-        (tmtex-concat `((concat ,@h) (concat ,@t)))
-      ) ;let
-    ) ;with
-    (if (tmtex-math-mode?)
-      (with l*
-        (pre-scripts l)
-        ;; (when (!= l* l) (display* l " -> " l* "\n"))
-        ;; (display* "l1= " l* "\n")
-        ;; (display* "l2= " (pre-brackets-recurse l*) "\n")
-        ;; (display* "l3= " (tmtex-list (pre-brackets-recurse l*)) "\n")
-        (tex-concat (tmtex-math-concat-spaces (tmtex-list (pre-brackets-recurse l*))))
-      ) ;with
-      (tex-concat (tmtex-list (tmtex-rewrite-no-break l)))
-    ) ;if
-  ) ;if
-) ;define
-
-(define (tmtex-rigid l)
-  (tmtex-function '!group l)
-) ;define
-
-(define (tmtex-no-first-indentation l)
-  (tex-apply 'noindent)
-) ;define
-
-(define (tmtex-line-break l)
-  (tex-apply 'linebreak)
-) ;define
-
-(define (tmtex-page-break l)
-  (tex-apply 'pagebreak)
-) ;define
-
-(define (tmtex-new-page l)
-  (tex-apply 'newpage)
-) ;define
-
-(define (tmtex-no-page-break l)
-  (tex-apply 'nopagebreak)
-) ;define
-
-(define (tmtex-next-line l)
-  (list '!nextline)
-) ;define
-
-(define (tmtex-no-break l)
-  '(!group (nobreak))
-) ;define
-
-(define (tmtex-emdash l)
-  "---"
-) ;define
-
-(define (tmtex-new-line l)
-  (if (tmtex-math-mode?) (tmtex-next-line l) (tex-apply '!newline))
-) ;define
-
-(tm-define (tmtex-decode-length len)
-  ;; FIXME: should be completed
-  (with s
-    (force-string len)
-    (cond ((string-ends? s "fn") (string-replace s "fn" "em"))
-          ((string-ends? s "tab") (string-replace s "tab" "em"))
-          ((string-ends? s "spc") (string-replace s "spc" "em"))
-          ((string-ends? s "sep") (string-replace s "sep" "ex"))
-          ((string-ends? s "par") (string-replace s "par" "\\columnwidth"))
-          ((string-ends? s "pag") (string-replace s "pag" "\\textheight"))
-          (else s)
-    ) ;cond
-  ) ;with
-) ;tm-define
-
-(define (tmtex-hrule s l)
-  (list 'hrulefill)
-) ;define
-
-(define (tmtex-hspace l)
-  (let ((s (if (= (length l) 1) (car l) (cadr l))))
-    (cond ((== s "0.5fn") (list 'enspace))
-          ((== s "1fn") (list 'quad))
-          ((== s "2fn") (list 'qquad))
-          ((== s "0.5em") (list 'enspace))
-          ((== s "1em") (list 'quad))
-          ((== s "2em") (list 'qquad))
-          ((== s "0.2spc") (list (string->symbol ",")))
-          ((not (tmtex-math-mode?))
-           (cond ((== s "0.4spc") (list (string->symbol ",")))
-                 ((== s "0.6spc") (list (string->symbol ",")))
-                 ((== s "0.16667em") (list (string->symbol ",")))
-                 (else (tex-apply 'hspace (tmtex-decode-length s)))
-           ) ;cond
-          ) ;
-          ((== s "0.4spc") (list (string->symbol ":")))
-          ((== s "0.6spc") (list (string->symbol ";")))
-          ((== s "-0.6spc") '(!concat (!) (!) (!)))
-          ((== s "-0.4spc") '(!concat (!) (!)))
-          ((== s "-0.2spc") '(!concat (!)))
-          (else (tex-apply 'hspace (tmtex-decode-length s)))
-    ) ;cond
-  ) ;let
-) ;define
-
-(define (tmtex-hspace* s l)
-  (tmtex-hspace l)
-) ;define
-
-(define (tmtex-vspace l)
-  (let ((s (if (= (length l) 1) (car l) (cadr l))))
-    (cond ((== s "0.5fn") (tex-apply 'smallskip))
-          ((== s "1fn") (tex-apply 'medskip))
-          ((== s "2fn") (tex-apply 'bigskip))
-          (else (tex-apply 'vspace (tmtex-decode-length s)))
-    ) ;cond
-  ) ;let
-) ;define
-
-(define (tmtex-space l)
-  (tmtex-hspace (list (car l)))
-) ;define
-
-(define (into-single-paragraph t)
-  (set! t
-    (tm-replace t
-      (lambda (x) (tm-in? x '(equation equation*)))
-      (lambda (x)
-        (if (and (== (length x) 2) (tm-func? (cadr x) 'document 1))
-          `(math ,(cadr (cadr x)))
-          `(math ,@(cdr x))
-        ) ;if
-      ) ;lambda
-    ) ;tm-replace
-  ) ;set!
-  (set! t
-    (tm-replace t
-      (lambda (x) (tm-func? x 'document))
-      (lambda (x) `(para ,@(cdr x)))
-    ) ;tm-replace
-  ) ;set!
-  t
-) ;define
-
-(define (tmtex-float-make wide? size type position x capt)
-  (let* ((pos (string-replace position "f" ""))
-         (type* (if wide? (string-append type "*") type))
-         (body (tmtex x))
-         (caption (tmtex (into-single-paragraph capt)))
-         (body* (if (and (== type "table")
-                      (or (func? x 'three-line-table)
-                        (func? x 'three-line-table 1)
-                        (tmtex-is-three-line-table-tree? x)
-                      ) ;or
-                    ) ;and
-                  `(!paragraph ,(list 'centering) ,body (caption ,caption))
-                  `(!paragraph ,body (caption ,caption))
-                ) ;if
-         ) ;body*
-        ) ;
-    (cond ((and (== size "big") (== type "figure"))
-           (if (== pos "")
-             `((!begin ,type) ,body*)
-             `((!begin ,type* (!option ,pos)) ,body*)
-           ) ;if
-          ) ;
-          ((and (== size "big") (== type "table"))
-           (if (== pos "")
-             `((!begin ,type) ,body*)
-             `((!begin ,type* (!option ,pos)) ,body*)
-           ) ;if
-          ) ;
-          (else (list 'tmfloat pos size type* body caption))
-    ) ;cond
-  ) ;let*
-) ;define
-
-(define (tmtex-float-table? x)
-  (or (func? x 'small-table 2) (func? x 'big-table 2))
-) ;define
-
-(define (tmtex-float-figure? x)
-  (or (func? x 'small-figure 2) (func? x 'big-figure 2))
-) ;define
-
-(define (tmtex-float-size l)
-  (if (list? l)
-    (if (or (func? l 'small-table) (func? l 'small-figure)) "small" "big")
-    "big"
-  ) ;if
-) ;define
-
-(define (tmtex-float-sub wide? position l)
-  (with pos
-    (string-replace position "f" "")
-    (cond ((func? l 'document 1) (tmtex-float-sub wide? pos (cadr l)))
-          ((tmtex-float-figure? l)
-           (tmtex-float-make wide? (tmtex-float-size l) "figure" pos (cadr l) (caddr l))
-          ) ;
-          ((tmtex-float-table? l)
-           (tmtex-float-make wide? (tmtex-float-size l) "table" pos (cadr l) (caddr l))
-          ) ;
-          (else (tmtex-float-make wide? "big" "figure" pos l ""))
-    ) ;cond
-  ) ;with
-) ;define
-
-(define (tmtex-float l)
-  (tmtex-float-sub #f (force-string (cadr l)) (caddr l))
-) ;define
-
-(define (tmtex-wide-float l)
-  (tmtex-float-sub #t (force-string (cadr l)) (caddr l))
-) ;define
-
-(define (tmtex-htab l)
-  (tex-apply 'hspace* (list 'fill))
-) ;define
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Make brackets small when necessary
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (disable-large? x level)
-  (cond ((string? x) #t)
-        ((func? x 'concat) (list-and (map (cut disable-large? <> level) (cdr x))))
-        ((tm-in? x '(left mid right)) #t)
-        ((tm-in? x '(lsub lsup rsub rsup))
-         (and (> level 0) (disable-large? (cadr x) (- level 1)))
-        ) ;
-        ((tm-in? x '(lprime rprime)) #t)
-        ((tm-in? x '(wide wide*)) (disable-large? (cadr x) (- level 1)))
-        ((tm-in? x '(with rigid locus)) (disable-large? (cAr x) level))
-        ((tm-in? x '(math-up math-ss math-tt math-bf math-it math-sl))
-         (and (== (tm-arity x) 1) (disable-large? (cadr x) level))
-        ) ;
-        (else #f)
-  ) ;cond
-) ;define
-
-(define (make-small s)
-  (cond ((nstring? s) "")
-        ((== s ".") "")
-        ((<= (string-length s) 1) s)
-        ((and (string-starts? s "<") (string-ends? s ">")) s)
-        (else (string-append "<" s ">"))
-  ) ;cond
-) ;define
-
-(define (make-small-bracket x)
-  (if (tm-in? x '(left mid right)) (make-small (cadr x)) x)
-) ;define
-
-(define (find-right l)
-  (cond ((null? l) #f)
-        ((func? (car l) 'left) #f)
-        ((func? (car l) 'right) 2)
-        (else (with i (find-right (cdr l)) (and i (+ i 1))))
-  ) ;cond
-) ;define
-
-(define (pre-brackets l)
-  (cond ((null? l) l)
-        ((func? (car l) 'left)
-         (with n
-           (find-right (cdr l))
-           (if (not n)
-             (cons (car l) (pre-brackets (cdr l)))
-             (let* ((r (pre-brackets (sublist l n (length l)))) (m (sublist l 0 n)))
-               (if (disable-large? `(concat ,@m) 2)
-                 (begin
-                   ;; (display* "< " m "\n")
-                   ;; (display* "> " (map make-small-bracket m) "\n")
-                   (append (map make-small-bracket m) r)
-                 ) ;begin
-                 (append m r)
-               ) ;if
-             ) ;let*
-           ) ;if
-         ) ;with
-        ) ;
-        (else (cons (car l) (pre-brackets (cdr l))))
-  ) ;cond
-) ;define
-
-(define (pre-brackets-recurse l)
-  (with r (pre-brackets l) (if (== r l) r (pre-brackets-recurse r)))
-) ;define
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Mathematics
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (convert-around x)
-  (with d (downgrade-brackets x) (tmtex-concat (if (pair? d) (cdr d) (list d))))
-) ;define
-
-(define (tmtex-around l)
-  (convert-around (cons 'around l))
-) ;define
-
-(define (tmtex-around* l)
-  (convert-around (cons 'around* l))
-) ;define
-
-(define (tmtex-big-around l)
-  (convert-around (cons 'big-around l))
-) ;define
-
-(define (tmtex-large-decode s)
-  (cond ((nstring? s) ".")
-        ((in? s '("(" ")" "[" "]" "|" "/" ".")) s)
-        ((in? s '("||" "<||>")) "\\|")
-        ((== s "\\") "\\backslash")
-        ((and (string-starts? s "<") (string-ends? s ">"))
-         (string-append "\\" (substring s 1 (- (string-length s) 1)))
-        ) ;
-        (else (string-append "\\" s))
-  ) ;cond
-) ;define
-
-(define (tmtex-large-decode-text s)
-  (cond ((nstring? s) "")
-        ((== s ".") "")
-        ((in? s '("(" ")" "[" "]" "|" "/")) s)
-        ((in? s '("{" "}")) (string-append "\\" s))
-        (else (display* "TeXmacs] non converted bracket: " s "\n") "")
-  ) ;cond
-) ;define
-
-(define (tmtex-left l)
-  (if (tmtex-math-mode?)
-    (let* ((s (tmtex-large-decode (car l)))
-           (n (if (= (length l) 2) (string->number (cadr l)) 0))
-           (b (cond ((not n) "left")
-                    ((= n 1) "bigl")
-                    ((= n 2) "Bigl")
-                    ((= n 3) "biggl")
-                    ((= n 4) "Biggl")
-                    (else "left")
-              ) ;cond
-           ) ;b
-          ) ;
-      (list (string->symbol (string-append b s)))
-    ) ;let*
-    (tmtex-large-decode-text (car l))
-  ) ;if
-) ;define
-
-(define (tmtex-mid l)
-  (display* "TeXmacs] downgraded large middle delimiter: " (car l) "\n")
-  (if (tmtex-math-mode?)
-    (with s (tmtex-large-decode (car l)) (if (== s ".") "" s))
-    (tmtex-large-decode-text (car l))
-  ) ;if
-) ;define
-
-(define (tmtex-right l)
-  (if (tmtex-math-mode?)
-    (let* ((s (tmtex-large-decode (car l)))
-           (n (if (= (length l) 2) (string->number (cadr l)) 0))
-           (b (cond ((not n) "right")
-                    ((= n 1) "bigr")
-                    ((= n 2) "Bigr")
-                    ((= n 3) "biggr")
-                    ((= n 4) "Biggr")
-                    (else "right")
-              ) ;cond
-           ) ;b
-          ) ;
-      (list (string->symbol (string-append b s)))
-    ) ;let*
-    (tmtex-large-decode-text (car l))
-  ) ;if
-) ;define
-
-(define (tmtex-big-decode s)
-  (cond ((nstring? s) "bignone")
-        ((in? s '("sum" "prod" "int" "oint" "coprod")) s)
-        ((in? s '("iint" "iiint" "iiiint" "idotsint")) s)
-        ((in? s '("oiint" "oiiint")) s)
-        ((== s "amalg") "coprod")
-        ((== s "pluscup") "uplus")
-        ((== s ".") "bignone")
-        (else (string-append "big" s))
-  ) ;cond
-) ;define
-
-(define (tmtex-big l)
-  (list (string->symbol (tmtex-big-decode (car l))))
-) ;define
-
-(define (tmtex-decode-long-arrow s)
-  (cond ((nstring? s) #f)
-        ((and (string-starts? s ""))
-         (tmtex-decode-long-arrow (substring s 8 (- (string-length s) 1)))
-        ) ;
-        ((in? s
-           '("minus"
-             "leftarrow"
-             "rightarrow"
-             "leftrightarrow"
-             "equal"
-             "Leftarrow"
-             "Rightarrow"
-             "Leftrightarrow"
-             "mapsto"
-             "mapsfrom")
-         ) ;in?
-         (string->symbol (string-append "x" s))
-        ) ;
-        ((in? s
-           '("leftrightarrows"
-             "leftleftarrows"
-             "threeleftarrows"
-             "fourleftarrows"
-             "rightleftarrows"
-             "rightrightarrows"
-             "threerightarrows"
-             "fourrightarrows")
-         ) ;in?
-         (string-append "")
-        ) ;
-        ((== s "Lleftarrow") "")
-        ((== s "Rrightarrow") "")
-        ((== s "LRleftrightarrow") "")
-        (else (string-append "<" s ">"))
-  ) ;cond
-) ;define
-
-(define (tmtex-long-arrow l)
-  (with cmd
-    (tmtex-decode-long-arrow (car l))
-    (cond ((and (symbol? cmd) (== (length l) 2)) (list cmd (tmtex (cadr l))))
-          ((symbol? cmd) (list cmd (list '!option (tmtex (caddr l))) (tmtex (cadr l))))
-          ((== (length l) 2) (list 'overset (tmtex (cadr l)) (tmtex cmd)))
-          ((== (cadr l) "") (list 'underset (tmtex (caddr l)) (tmtex cmd)))
-          (else (list 'underset (tmtex (caddr l)) (list 'overset (tmtex (cadr l)) (tmtex cmd)))
-          ) ;else
-    ) ;cond
-  ) ;with
-) ;define
-
-(define (tmtex-below l)
-  (list 'underset (tmtex (cadr l)) (tmtex (car l)))
-) ;define
-
-(define (tmtex-above l)
-  (list 'overset (tmtex (cadr l)) (tmtex (car l)))
-) ;define
-
-(define (tmtex-lsub l)
-  (cond ((== (car l) "") "")
-        ((tmtex-math-mode?) (tmtex `(concat (!group) (rsub ,(car l)))))
-        (else (tmtex `(rsub ,(car l))))
-  ) ;cond
-) ;define
-
-(define (tmtex-lsup l)
-  (cond ((== (car l) "") "")
-        ((tmtex-math-mode?) (tmtex `(concat (!group) (rsup ,(car l)))))
-        (else (tmtex `(rsup ,(car l))))
-  ) ;cond
-) ;define
-
-(define (tmtex-contains-table? x)
-  (cond ((nlist? x) #f)
-        ((and (>= (length x) 2) (== (car x) '!table)) #t)
-        (else (list-or (map-in-order tmtex-contains-table? (cdr x))))
-  ) ;cond
-) ;define
-
-(define (tmtex-script which script)
-  (with r
-    (tmtex script)
-    (if (tmtex-contains-table? r) (list which (list 'tmscript r)) (list which r))
-  ) ;with
-) ;define
-
-(define (tmtex-rsub l)
-  (cond ((== (car l) "") "")
-        ((tmtex-math-mode?) (tmtex-script '!sub (car l)))
-        (else (list 'tmrsub (tmtex (car l))))
-  ) ;cond
-) ;define
-
-(define (tmtex-rsup l)
-  (cond ((== (car l) "") "")
-        ((tmtex-math-mode?) (tmtex-script '!sup (car l)))
-        (else (list 'tmrsup (tmtex (car l))))
-  ) ;cond
-) ;define
-
-(define (tmtex-modulo l)
-  (tmtex-script 'mod (car l))
-) ;define
-
-(define (tmtex-frac l)
-  (tmtex-function 'frac l)
-) ;define
-
-(define (tmtex-sqrt l)
-  (if (= (length l) 1)
-    (tmtex-function 'sqrt l)
-    (list 'sqrt (list '!option (tmtex (cadr l))) (tmtex (car l)))
-  ) ;if
-) ;define
-
-(define (tmtex-token? s)
-  (or (= (string-length s) 1)
-    (and (!= s "")
-      (== (string-ref s 0) #\<)
-      (== (string-index s #\>) (- (string-length s) 1))
-    ) ;and
-  ) ;or
-) ;define
-
-(define (tmtex-wide-star? x)
-  (cond ((func? x 'wide* 1) (tmtex-wide-star? (cadr x)))
-        ((nstring? x) #t)
-        (else (not (tmtex-token? x)))
-  ) ;cond
-) ;define
-
-(define (tmtex-wide-star l)
-  (let ((wide? (tmtex-wide-star? (car l)))
-        (arg (tmtex (car l)))
-        (acc (cadr l))
-        (text? (not (tmtex-math-mode?)))
-       ) ;
-    (if (and (string? acc) (string-starts? acc "" "^")) (list (if wide? 'uwidehat 'uhat) arg))
-          ((in? acc '("" "~")) (list (if wide? 'uwidetilde 'utilde) arg))
-          ((== acc "") (list 'underline arg))
-          ((== acc "") (list (if wide? 'underrightarrow 'uvec) arg))
-          ((== acc "") (list 'ubreve arg))
-          ((== acc "") (list 'uinvbreve arg))
-          ((== acc "") (list 'ucheck arg))
-          ((== acc "") (list 'uring arg))
-          ((== acc "") (list 'uacute arg))
-          ((== acc "") (list 'ugrave arg))
-          ((== acc "") (list 'underdot arg))
-          ((== acc "") (list 'uddot arg))
-          ((== acc "") (list 'udddot arg))
-          ((== acc "") (list 'uddddot arg))
-          ((== acc "") (list 'underrightarrow arg))
-          ((== acc "") (list 'underleftarrow arg))
-          ((== acc "") (list 'underleftrightarrow arg))
-          ((== acc "") (list 'underrightarrow arg))
-          ((== acc "") (list 'underleftarrow arg))
-          ((== acc "") (list 'underleftrightarrow arg))
-          ((in? acc '("" "")) (list 'underbrace arg))
-          ((in? acc '("" ""))
-           (tmtex-below `(,(car l) (text (downbracefill))))
-          ) ;
-          ((in? acc '("" "")) (list 'underbrace arg))
-          ((in? acc '("" ""))
-           (tmtex-below `(,(car l) (text (downbracefill))))
-          ) ;
-          ;; imperfect translations
-          ((in? acc '("" "")) (list 'underbrace arg))
-          ((in? acc '("" ""))
-           (tmtex-below `(,(car l) (text (downbracefill))))
-          ) ;
-          (else (display* "TeXmacs] non converted accent below: " acc "\n") arg)
-    ) ;cond
-  ) ;let
-) ;define
-
-(define (tmtex-wide? x)
-  (cond ((func? x 'wide 1) (tmtex-wide? (cadr x)))
-        ((nstring? x) #t)
-        (else (not (tmtex-token? x)))
-  ) ;cond
-) ;define
-
-(define (tmtex-wide l)
-  (let ((wide? (tmtex-wide? (car l)))
-        (arg (tmtex (car l)))
-        (acc (cadr l))
-        (text? (not (tmtex-math-mode?)))
-       ) ;
-    (if (and (string? acc) (string-starts? acc "" "^")) (list (if text? '^ (if wide? 'widehat 'hat)) arg))
-          ((in? acc '("" "~"))
-           (list (if text? '~ (if wide? 'widetilde 'tilde)) arg)
-          ) ;
-          ((== (cadr l) "") (list (if text? '= 'overline) arg))
-          ((== acc "") (list (if text? '= (if wide? 'overline 'bar)) arg))
-          ((== acc "") (list (if wide? 'overrightarrow 'vec) arg))
-          ((== acc "") (list (if text? 'u 'breve) arg))
-          ((== acc "") (list 'invbreve arg))
-          ((== acc "") (list (if text? 'v 'check) arg))
-          ((== acc "") (list (if text? 'r 'ring) arg))
-          ((== acc "") (list (if text? (string->symbol "'") 'acute) arg))
-          ((== acc "") (list (if text? (string->symbol "`") 'grave) arg))
-          ((== acc "") (list (if text? (string->symbol ".") 'dot) arg))
-          ((== acc "") (list (if text? (string->symbol "\"") 'ddot) arg))
-          ((== acc "") (list 'dddot arg))
-          ((== acc "") (list 'ddddot arg))
-          ((== acc "") (list 'overrightarrow arg))
-          ((== acc "") (list 'overleftarrow arg))
-          ((== acc "") (list 'overleftrightarrow arg))
-          ((== acc "") (list 'overrightarrow arg))
-          ((== acc "") (list 'overleftarrow arg))
-          ((== acc "") (list 'overleftrightarrow arg))
-          ((in? acc '("" "")) (list 'overbrace arg))
-          ((in? acc '("" ""))
-           (tmtex-above `(,(car l) (text (upbracefill))))
-          ) ;
-          ((in? acc '("" "")) (list 'overbrace arg))
-          ((in? acc '("" ""))
-           (tmtex-above `(,(car l) (text (upbracefill))))
-          ) ;
-          ;; FIXME: imperfect translations
-          ((in? acc '("" "")) (list 'overbrace arg))
-          ((in? acc '("" ""))
-           (tmtex-above `(,(car l) (text (upbracefill))))
-          ) ;
-          (else (display* "TeXmacs] non converted accent: " acc "\n") arg)
-    ) ;cond
-  ) ;let
-) ;define
-
-(define (tmtex-neg l)
-  (tmtex-function 'not l)
-) ;define
-
-(define (tmtex-tree l)
-  (let* ((root (list '!begin "bundle" (tmtex (car l))))
-         (children (map (lambda (x) (list 'chunk (tmtex x))) (cdr l)))
-        ) ;
-    (list root (tex-concat children))
-  ) ;let*
-) ;define
-
-(define (tmtex-tree-eps l)
-  (tmtex-eps (cons 'tree l))
-) ;define
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Hacks for tables with multi-paragraph cells
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (map-or l1 l2)
-  (if (or (null? l1) (null? l2))
-    (list)
-    (cons (or (car l1) (car l2)) (map-or (cdr l1) (cdr l2)))
-  ) ;if
-) ;define
-
-(define (tmtex-block-columns t)
-  (cond ((tm-func? t 'tformat) (tmtex-block-columns (cAr t)))
-        ((tm-func? t 'table 1) (tmtex-block-columns (cAr t)))
-        ((tm-func? t 'table)
-         (let* ((b1 (tmtex-block-columns `(table ,(cadr t))))
-                (b2 (tmtex-block-columns `(table ,@(cddr t))))
-               ) ;
-           (map-or b1 b2)
-         ) ;let*
-        ) ;
-        ((tm-func? t 'row) (map tmtex-block-columns (cdr t)))
-        ((tm-func? t 'cell) (tmtex-block-columns (cAr t)))
-        (else (tm-func? t 'document))
-  ) ;cond
-) ;define
-
-(define (column-numbers l i)
-  (cond ((null? l) (list))
-        ((car l) (cons i (column-numbers (cdr l) (+ i 1))))
-        (else (column-numbers (cdr l) (+ i 1)))
-  ) ;cond
-) ;define
-
-(define (block-align nr out-of)
-  (let* ((c (number->string nr))
-         (p (string-append "p{" (number->string (/ 12.0 out-of)) "cm}"))
-        ) ;
-    `(cwith ,"1" ,"-1" ,c ,c ,"cell-halign" ,p)
-  ) ;let*
-) ;define
-
-(define (tmtex-block-adjust t)
-  (cond ((tm-func? t 'tformat) (append (cDr t) (list (tmtex-block-adjust (cAr t)))))
-        ((tm-func? t 'table)
-         (let* ((b (tmtex-block-columns t)) (n (column-numbers b 1)))
-           (if (null? n) t `(tformat ,@(map (cut block-align <> (length n)) n)
-                              ,t))
-         ) ;let*
-        ) ;
-        (else t)
-  ) ;cond
-) ;define
-
-(define (tm-big-figure? t)
-  (tm-in? t '(big-figure big-table))
-) ;define
-
-(define (tm-replace-figure t)
-  (cond ((tm-func? t 'big-figure) (list 'tmfloat "h" "big" "figure" (cadr t) (caddr t)))
-        ((tm-func? t 'big-table) (list 'tmfloat "h" "big" "table" (cadr t) (caddr t)))
-        (else t)
-  ) ;cond
-) ;define
-
-(define (tmtex-figure-adjust t)
-  (tm-replace t tm-big-figure? tm-replace-figure)
-) ;define
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Tables
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (tmtex-table-rows-assemble tb bb rows)
-  (cond ((null? rows) (if (null? bb) '() (if (car bb) (list (list 'hline)) '())))
-        (else (append (if (or (car tb) (car bb)) (list (list 'hline)) '())
-                (cons (cons '!row (map tmtex (car rows)))
-                  (tmtex-table-rows-assemble (cdr tb) (cdr bb) (cdr rows))
-                ) ;cons
-              ) ;append
-        ) ;else
-  ) ;cond
-) ;define
-
-(define (tmtex-table-make p)
-  (let ((tb (p 'rows 'tborder)) (bb (p 'rows 'bborder)) (l (p 'rows 'content)))
-    (cons '!table (tmtex-table-rows-assemble tb (cons (car tb) bb) l))
-  ) ;let
-) ;define
-
-(define (tmtex-three-line-table-rows-assemble tb bb rows is-first)
-  (cond ((null? rows) (if (null? bb) '() (if (car bb) (list (list 'bottomrule)) '())))
-        (else (append (if (or (car tb) (car bb)) (list (list (if is-first 'toprule 'midrule))) '())
-                (cons (cons '!row (map tmtex (car rows)))
-                  (tmtex-three-line-table-rows-assemble (cdr tb) (cdr bb) (cdr rows) #f)
-                ) ;cons
-              ) ;append
-        ) ;else
-  ) ;cond
-) ;define
-
-(define (tmtex-three-line-table-make p)
-  (let ((tb (p 'rows 'tborder)) (bb (p 'rows 'bborder)) (l (p 'rows 'content)))
-    (cons '!table (tmtex-three-line-table-rows-assemble tb (cons (car tb) bb) l #t))
-  ) ;let
-) ;define
-
-(define (tmtex-table-args-assemble lb rb ha)
-  (cond ((null? ha) (if (null? rb) '() (list (if (car rb) "|" ""))))
-        (else (cons (if (or (car lb) (car rb)) "|" "")
-                (cons (car ha) (tmtex-table-args-assemble (cdr lb) (cdr rb) (cdr ha)))
-              ) ;cons
-        ) ;else
-  ) ;cond
-) ;define
-
-(define (tmtex-table-args p)
-  (let ((lb (p 'cols 'lborder)) (rb (p 'cols 'rborder)) (l (p 'cols 'halign)))
-    (apply string-append (tmtex-table-args-assemble lb (cons (car lb) rb) l))
-  ) ;let
-) ;define
-
-(define (tmtex-table-apply key args x)
-  (let* ((props (logic-ref tmtex-table-props% key))
-         (wide? (and props (string-contains? (cadr props) "X")))
-        ) ;
-    (when (== key 'rcl-table)
-      (latex-add-extra "tabls")
-    ) ;when
-    (when (and (not (tmtex-math-mode?)) (not wide?))
-      (set! x (tmtex-block-adjust x))
-      (set! x (tmtex-figure-adjust x))
-    ) ;when
-    (if props
-      (let* ((env (if (tmtex-math-mode?) "array" "tabular"))
-             (env* (if wide? (list "tabularx" "1.0\\textwidth") (list env)))
-             (before (car props))
-             (after (caddr props))
-             (defaults (append (tmtable-cell-halign (cadr props))
-                         (tmtable-block-borders (cadddr props))
-                       ) ;append
-             ) ;defaults
-             (p (tmtable-parser (if (== key 'three-line-table)
-                                  `(tformat ,@defaults ,@(cdr x))
-                                  `(tformat ,@defaults ,x)
-                                ) ;if
-                ) ;tmtable-parser
-             ) ;p
-             (e `(!begin ,@env* ,(tmtex-table-args p)))
-             (r (if (== key 'three-line-table)
-                  (tmtex-three-line-table-make p)
-                  (tmtex-table-make p)
-                ) ;if
-             ) ;r
-            ) ;
-        (tex-concat (list before (list e r) after))
-      ) ;let*
-      (begin
-        (list `(!begin ,(symbol->string key) ,@args)
-          (if (== key 'three-line-table)
-            (tmtex-three-line-table-make (tmtable-parser `(tformat ,@(cdr x))))
-            (tmtex-table-make (tmtable-parser x))
-          ) ;if
-        ) ;list
-      ) ;begin
-    ) ;if
-  ) ;let*
-) ;define
-
-(define (tmtex-is-three-line-table? l)
-  (let* ((has-tborder1 (list-or (map (lambda (x)
-                                       (and (pair? x) (== (car x) 'cwith) (member "cell-tborder" x) (member "1ln" x))
-                                     ) ;lambda
-                                  l
-                                ) ;map
-                       ) ;list-or
-         ) ;has-tborder1
-         (has-bborder1 (list-or (map (lambda (x)
-                                       (and (pair? x) (== (car x) 'cwith) (member "cell-bborder" x) (member "1ln" x))
-                                     ) ;lambda
-                                  l
-                                ) ;map
-                       ) ;list-or
-         ) ;has-bborder1
-         (has-bborder05 (list-or (map (lambda (x)
-                                        (and (pair? x) (== (car x) 'cwith) (member "cell-bborder" x) (member "0.5ln" x))
-                                      ) ;lambda
-                                   l
-                                 ) ;map
-                        ) ;list-or
-         ) ;has-bborder05
-        ) ;
-    (and has-tborder1 has-bborder1 has-bborder05)
-  ) ;let*
-) ;define
-
-(define (tmtex-is-three-line-table-tree? x)
-  (and (pair? x) (== (car x) 'tformat) (tmtex-is-three-line-table? (cdr x)))
-) ;define
-
-(define (tmtex-extract-table-element l)
-  (cond ((null? l) #f)
-        ((and (pair? (car l)) (in? (caar l) '(tformat table))) (car l))
-        (else (tmtex-extract-table-element (cdr l)))
-  ) ;cond
-) ;define
-
-(define (tmtex-inject-three-line-table-borders l)
-  (append (list '(cwith "1" "1" "1" "-1" "cell-tborder" "1ln")
-            '(cwith "-1" "-1" "1" "-1" "cell-bborder" "1ln")
-            '(cwith "1" "1" "1" "-1" "cell-bborder" "0.5ln")
-          ) ;list
-    l
-  ) ;append
-) ;define
-
-(define (tmtex-tformat l)
-  (if (tmtex-is-three-line-table? l)
-    (let* ((tbl (tmtex-extract-table-element l)))
-      (if tbl
-        (tmtex-three-line-table (tmtex-inject-three-line-table-borders (cdr tbl)))
-        (tmtex-table-apply 'tabular '() (cons 'tformat l))
-      ) ;if
-    ) ;let*
-    (tmtex-table-apply 'tabular '() (cons 'tformat l))
-  ) ;if
-) ;define
-
-(define (tmtex-table l)
-  (tmtex-image-increment)
-  (tmtex-table-apply 'tabular '() (cons 'table l))
-) ;define
-
-(define (tmtex-three-line-table l)
-  (tmtex-table-apply 'three-line-table '() (cons 'three-line-table l))
-) ;define
-
-(define (tmtex-stack l)
-  (when (nnull? l)
-    (let* ((x (car l)) (p (tmtable-parser x)) (rows (p 'rows 'content)))
-      (latex-add-extra "mathtools")
-      (tex-apply 'substack
-        (tex-concat (list-intersperse (map (lambda (row) (tex-concat (map tmtex row))) rows) "\\\\")
-        ) ;tex-concat
-      ) ;tex-apply
-    ) ;let*
-  ) ;when
-) ;define
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Local and global environment changes
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (tmtex-get-with-cmd var val)
-  (if (tmtex-math-mode?)
-    (or (logic-ref tex-with-cmd-math% (list var val))
-      (logic-ref tex-with-cmd% (list var val))
-    ) ;or
-    (logic-ref tex-with-cmd% (list var val))
-  ) ;if
-) ;define
-
-(define (tmtex-get-assign-cmd var val)
-  (if (== var "font-size")
-    (let ((x (* (string->number val) 10)))
-      (cond ((< x 1) #f)
-            ((< x 5.5) 'tiny)
-            ((< x 6.5) 'scriptsize)
-            ((< x 7.5) 'footnotesize)
-            ((< x 9.5) 'small)
-            ((< x 11.5) 'normalsize)
-            ((< x 13.5) 'large)
-            ((< x 15.5) 'Large)
-            ((< x 18.5) 'LARGE)
-            ((< x 22.5) 'huge)
-            ((< x 50) 'Huge)
-            (else #f)
-      ) ;cond
-    ) ;let
-    (logic-ref tex-assign-cmd% (list var val))
-  ) ;if
-) ;define
-
-(define (tmlength->texlength len)
-  ;; TODO: rewrite (quote x) -> x and (tmlen ...) -> ...pt
-  (with tmlen
-    (string->tmlength (force-string len))
-    (if (tmlength-null? tmlen)
-      "0pt"
-      (let* ((val (tmlength-value tmlen))
-             (unit (symbol->string (tmlength-unit tmlen)))
-             (val-string (number->string val))
-            ) ;
-        (cond ((== unit "fn") (string-append val-string "em"))
-              (else len)
-        ) ;cond
-      ) ;let*
-    ) ;if
-  ) ;with
-) ;define
-
-(define (tmtex-make-parmod x y z arg flag?)
-  (set! x (tmlength->texlength x))
-  (set! y (tmlength->texlength y))
-  (set! z (tmlength->texlength z))
-  (if (and (tmlength-zero? (string->tmlength x))
-        (tmlength-zero? (string->tmlength y))
-        (tmlength-zero? (string->tmlength z))
-        flag?
-      ) ;and
-    arg
-    (list (list '!begin "tmparmod" x y z) arg)
-  ) ;if
-) ;define
-
-(define (tmtex-make-parsep x arg)
-  (set! x (tmlength->texlength x))
-  (list (list '!begin "tmparsep" x) arg)
-) ;define
-
-(define (tmtex-make-lang val arg)
-  (if (== val "verbatim")
-    `(tt ,arg)
-    (begin
-      (if (nin? val tmtex-languages)
-        (set! tmtex-languages (append (list val) tmtex-languages))
-      ) ;if
-      (if (texout-multiline? arg)
-        `((!begin ,"otherlanguage" ,val) ,arg)
-        `(foreignlanguage ,val ,arg)
-      ) ;if
-    ) ;begin
-  ) ;if
-) ;define
-
-(define (tmtex-decode-color s . force-html)
-  (with cm
-    (if (string-starts? s "#") "HTML" (named-color->xcolormap s))
-    (cond ((and (== cm "none") (nnull? force-html))
-           (tmtex-decode-color (get-hex-color s) force-html)
-          ) ;
-          ((and (== cm "HTML") (nnull? force-html))
-           `((!option "HTML") ,(html-color->latex-xcolor s))
-          ) ;
-          ((== cm "texmacs")
-           (when (nin? s tmtex-colors)
-             (set! tmtex-colors (append (list s) tmtex-colors))
-           ) ;when
-           (string-replace s " " "")
-          ) ;
-          ((in? cm (list "x11names")) (tmtex-decode-color (get-hex-color s) #t))
-          (else (when (and (nin? cm tmtex-colormaps) (!= cm "xcolor") (!= cm "none"))
-                  (set! tmtex-colormaps (append (list cm) tmtex-colormaps))
-                ) ;when
-            (string-replace s " " "")
-          ) ;else
-    ) ;cond
-  ) ;with
-) ;define
-
-(define (tmtex-make-color val arg)
-  (with ltxcolor
-    (tmtex-decode-color val #t)
-    (if (list? ltxcolor)
-      `(!group (!append (color ,@ltxcolor) ,arg))
-      `(tmcolor ,ltxcolor ,arg)
-    ) ;if
-  ) ;with
-) ;define
-
-(define (post-process-math-text t)
-  (cond ((or (nlist? t) (!= (length t) 2)) t)
-        ((nin? (car t) '(mathrm mathbf mathsf mathit mathsl mathtt tmop)) t)
-        ((and (string? (cadr t)) (string-alpha? (cadr t))) t)
-        ((func? t 'mathrm 1) `(textrm ,(cadr t)))
-        ((func? t 'mathbf 1) `(textbf ,(cadr t)))
-        ((func? t 'mathsf 1) `(textsf ,(cadr t)))
-        ((func? t 'mathit 1) `(textit ,(cadr t)))
-        ((func? t 'mathsl 1) `(textsl ,(cadr t)))
-        ((func? t 'mathtt 1) `(texttt ,(cadr t)))
-        ((func? t 'tmop 1) `(textrm ,(cadr t)))
-        (else t)
-  ) ;cond
-) ;define
-
-(define (tmtex-with-one var val arg)
-  (if (== var "mode")
-    (let ((old (tmtex-env-get-previous "mode")))
-      (cond ((and (== val "text") (!= old "text")) (list 'text arg))
-            ((and (== val "math") (!= old "math") (ahash-ref tmtex-env :preamble))
-             (list 'ensuremath arg)
-            ) ;
-            ((and (== val "math") (!= old "math")) (list '!math arg))
-            ((and (== val "prog") (== old "text")) `(tt ,arg))
-            ((and (== val "prog") (== old "math")) `(text (tt ,arg)))
-            (else arg)
-      ) ;cond
-    ) ;let
-    (let ((w (tmtex-get-with-cmd var val)) (a (tmtex-get-assign-cmd var val)))
-      (cond ((and w (tm-func? arg w 1)) arg)
-            ((in? w '(mathrm mathbf mathsf mathit mathtt mathsl))
-             (post-process-math-text (list w arg))
-            ) ;
-            (w (list w arg))
-            (a (list '!group (tex-concat (list (list a) " " arg))))
-            ((== "par-left" var) (tmtex-make-parmod val "0pt" "0pt" arg #t))
-            ((== "par-right" var) (tmtex-make-parmod "0pt" val "0pt" arg #t))
-            ((== "par-first" var) (tmtex-make-parmod "0pt" "0pt" val arg #f))
-            ((== "par-par-sep" var) (tmtex-make-parsep val arg))
-            ((== var "language") (tmtex-make-lang val arg))
-            ((== var "color") (tmtex-make-color val arg))
-            (else arg)
-      ) ;cond
-    ) ;let
-  ) ;if
-) ;define
-
-(define (tmtex-with l)
-  (cond ((null? l) "")
-        ((null? (cdr l)) (tmtex (car l)))
-        ((func? (cAr l) 'graphics) (tmtex-eps (cons 'with l)))
-        (else (let ((var (force-string (car l))) (val (force-string (cadr l))) (next (cddr l)))
-                (tmtex-env-set var val)
-                (let ((r (tmtex-with-one var val (tmtex-with next))))
-                  (tmtex-env-reset var)
-                  r
-                ) ;let
-              ) ;let
-        ) ;else
-  ) ;cond
-) ;define
-
-(define (tmtex-with-wrapped l)
-  (if (and (== (length l) 3)
-        (== (car l) "par-columns")
-        (== (cadr l) "1")
-        (tm-in? (caddr l) '(small-figure big-figure small-table big-table))
-      ) ;and
-    (tmtex-float-sub #t "h" (caddr l))
-    (tmtex-with l)
-  ) ;if
-) ;define
-
-(define (tmtex-var-name-sub l)
-  (if (null? l)
-    l
-    (let ((c (car l)) (r (tmtex-var-name-sub (cdr l))))
-      (cond ((char-alphabetic? c) (cons c r))
-            ((char-numeric? c)
-             (cond ((char=? c #\0) (cons* #\z #\e #\r #\o r))
-                   ((char=? c #\1) (cons* #\o #\n #\e r))
-                   ((char=? c #\2) (cons* #\t #\w #\o r))
-                   ((char=? c #\3) (cons* #\t #\h #\r #\e #\e r))
-                   ((char=? c #\4) (cons* #\f #\o #\u #\r r))
-                   ((char=? c #\5) (cons* #\f #\i #\v #\e r))
-                   ((char=? c #\6) (cons* #\s #\i #\x r))
-                   ((char=? c #\7) (cons* #\s #\e #\v #\e #\n r))
-                   ((char=? c #\8) (cons* #\e #\i #\g #\h #\t r))
-                   ((char=? c #\9) (cons* #\n #\i #\n #\e r))
-                   (else r)
-             ) ;cond
-            ) ;
-            ((and (char=? c #\*) (null? (cdr l))) (list c))
-            (else r)
-      ) ;cond
-    ) ;let
-  ) ;if
-) ;define
-
-(define (tmtex-var-name var)
-  (cond ((nstring? var) "")
-        ((logic-in? (string->symbol var) tmtex-protected%) (string-append "tm" var))
-        ((<= (string-length var) 1) var)
-        (else (with r
-                (list->string (tmtex-var-name-sub (string->list var)))
-                (if (and (string-occurs? "*" r) (== (latex-type r) "undefined"))
-                  (string-replace r "*" "star")
-                  r
-                ) ;if
-              ) ;with
-        ) ;else
-  ) ;cond
-) ;define
-
-(define (tmtex-tex-arg l)
-  (cons '!arg l)
-) ;define
-
-(define (tmtex-args-search x args)
-  (cond ((null? args) #f)
-        ((== x (car args)) 1)
-        (else (let ((n (tmtex-args-search x (cdr args)))) (if n (+ 1 n) #f)))
-  ) ;cond
-) ;define
-
-(define (tmtex-args-sub l args)
-  (if (null? l) l (cons (tmtex-args (car l) args) (tmtex-args-sub (cdr l) args)))
-) ;define
-
-(define (tmtex-args x args)
-  (cond ((nlist? x) x)
-        ((or (func? x 'arg) (func? x 'value))
-         (let ((n (tmtex-args-search (cadr x) args)))
-           (if n (list '!arg (number->string n)) (tmtex-args-sub x args))
-         ) ;let
-        ) ;
-        (else (tmtex-args-sub x args))
-  ) ;cond
-) ;define
-
-(define (tmtex-assign l)
-  (let* ((var (tmtex-var-name (car l)))
-         (bsvar (string-append "\\" var))
-         (type (latex-type var))
-         (def (if (== type "undefined") 'newcommand 'providecommand))
-         (val (cadr l))
-        ) ;
-    (while (func? val 'quote 1) (set! val (cadr val)))
-    (if (!= var "")
-      (begin
-        (tmtex-env-assign var val)
-        (cond ((string? val)
-               (let ((a (tmtex-get-assign-cmd var val)))
-                 (if a (list a) (list def bsvar (tmtex val)))
-               ) ;let
-              ) ;
-              ((or (func? val 'macro) (func? val 'func))
-               (if (null? (cddr val))
-                 (list def bsvar (tmtex (cAr val)))
-                 (list def
-                   bsvar
-                   (list '!option (number->string (- (length val) 2)))
-                   (tmtex (tmtex-args (cAr val) (cDdr val)))
-                 ) ;list
-               ) ;if
-              ) ;
-              (else (list def bsvar (tmtex val)))
-        ) ;cond
-      ) ;begin
-      ""
-    ) ;if
-  ) ;let*
-) ;define
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Other primitives
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (tmtex-quote l)
-  (tmtex (car l))
-) ;define
-
-(define (tmtex-hidden-binding l)
-  (if (and (== (length l) 2) (string->number (force-string (cAr l))))
-    (list 'custombinding (force-string (cAr l)))
-    ""
-  ) ;if
-) ;define
-
-(define (tmtex-label l)
-  (list 'label (force-string (car l)))
-) ;define
-
-(define (tmtex-reference l)
-  (list 'ref (force-string (car l)))
-) ;define
-
-(define (tmtex-pageref l)
-  (list 'pageref (force-string (car l)))
-) ;define
-
-(define (tmtex-eqref s l)
-  (list 'eqref (force-string (car l)))
-) ;define
-
-(define (tmtex-smart-ref s l)
-  (let* ((ss (map force-string l)) (key (string-recompose ss ",")))
-    (list 'Cref key)
-  ) ;let*
-) ;define
-
-(define (tmtex-specific l)
-  (cond ((== (car l) "latex") (tmtex-tt (cadr l)))
-        ((== (car l) "image") (tmtex-eps (cadr l)))
-        ((== (car l) "printer") (tmtex (cadr l)))
-        ((== (car l) "odd") `(ifthispageodd ,(tmtex (cadr l)) ,""))
-        ((== (car l) "even") `(ifthispageodd ,"" ,(tmtex (cadr l))))
-        (else "")
-  ) ;cond
-) ;define
-
-(define (tmtex-eps-names)
-  (set! tmtex-serial (+ tmtex-serial 1))
-  (let* ((suffix ".pdf")
-         (postfix (string-append "-" (number->string tmtex-serial) suffix))
-         (name-url (url-glue tmtex-image-root-url postfix))
-         (name-string (string-append tmtex-image-root-string postfix))
-        ) ;
-    (values name-url name-string)
-  ) ;let*
-) ;define
-
-(define (tmtex-eps x)
-  (tmtex-image-increment)
-  (if (tmtex-math-mode?) (set! x `(with ,"mode" ,"math" ,x)))
-  (receive (name-url name-string)
-    (tmtex-eps-names)
-    (let* ((extents (print-snippet name-url x #t))
-           (unit (* (/ 1.0 60984.0) (/ 600.0 (tenth extents))))
-           (x3 (* unit (first extents)))
-           (y3 (* unit (second extents)))
-           (x4 (* unit (third extents)))
-           (y4 (* unit (fourth extents)))
-           (x1 (* unit (fifth extents)))
-           (y1 (* unit (sixth extents)))
-           (x2 (* unit (seventh extents)))
-           (y2 (* unit (eighth extents)))
-           (lm (string-append (number->string (- x3 x1)) "cm"))
-           (rm (string-append (number->string (- x2 x4)) "cm"))
-           (ww (string-append (number->string (- x4 x3)) "cm"))
-           (hh (string-append (number->string (- y4 y3)) "cm"))
-           (opt `(!option ,(string-append "width=" ww ",height=" hh)))
-           (rat (/ y3 (- y4 y3)))
-           (dy `(!concat ,(number->string rat) (height)))
-           (rb `(raisebox ,dy (includegraphics ,opt ,name-string)))
-          ) ;
-      ;; TODO: top and bottom margins
-      ;; (display* name-url ": " x1 ", " y1 "; " x2 ", " y2 "\n")
-      ;; (display* name-url ": " x3 ", " y3 "; " x4 ", " y4 "\n")
-      (if (and (< (abs (- x3 x1)) 0.01) (< (abs (- x2 x4)) 0.01))
-        rb
-        `(!concat (hspace ,lm) ,rb (hspace ,rm))
-      ) ;if
-    ) ;let*
-  ) ;receive
-) ;define
-
-(define (tmtex-make-eps s l)
-  (tmtex-eps (cons (string->symbol s) l))
-) ;define
-
-(define (tmtex-graphics l)
-  (tmtex-eps (cons 'graphics l))
-) ;define
-
-(define (tmtex-as-eps name)
-  (tmtex-image-increment)
-  (let* ((u (url-relative current-save-target (unix->url name)))
-         (suffix (url-suffix u))
-         (fm (string-append (format-from-suffix suffix) "-file"))
-        ) ;
-    (if (and (url-exists? u) (in? suffix (list "eps" "pdf" "png" "jpg")))
-      (with p
-        (url->string "$TEXMACS_PATH")
-        (set! name (string-replace name "$TEXMACS_PATH" p))
-        (set! name (string-replace name "file://" ""))
-        (list 'includegraphics name)
-      ) ;with
-      (receive (name-url name-string)
-        (tmtex-eps-names)
-        (when (string-starts? name "..")
-          (set! u (url-relative current-save-source (unix->url name)))
-        ) ;when
-        (with nfm
-          (if (== (url-suffix name-url) "pdf") "pdf-file" "postscript-file")
-          (convert-to-file u fm nfm name-url)
-        ) ;with
-        (list 'includegraphics name-string)
-      ) ;receive
-    ) ;if
-  ) ;let*
-) ;define
-
-(define (tmtex-image-length len)
-  (let* ((s (force-string len)) (unit (and (tm-length? s) (tm-length-unit len))))
-    (cond ((== s "") "!")
-          ((string-ends? s "%") "!")
-          ((in? unit '("w" "h")) "!")
-          (else (tmtex-decode-length len))
-    ) ;cond
-  ) ;let*
-) ;define
-
-(define (tmtex-image-mag len)
-  (let* ((s (force-string len))
-         (val (and (tm-length? s) (tm-length-value len)))
-         (unit (and (tm-length? s) (tm-length-unit len)))
-        ) ;
-    (cond ((== s "") 0.0)
-          ((string-ends? s "%")
-           (with x (string->number (string-drop-right s 1)) (if x (/ x 100.0) 0))
-          ) ;
-          ((in? unit '("w" "h")) (or val 0))
-          (else #f)
-    ) ;cond
-  ) ;let*
-) ;define
-
-(define (tmtex-image l)
-  (if (nstring? (car l))
-    (tmtex-eps (cons 'image l))
-    (let* ((fig (tmtex-as-eps (force-string (car l))))
-           (hor (tmtex-image-length (cadr l)))
-           (ver (tmtex-image-length (caddr l)))
-           (mhor (tmtex-image-mag (cadr l)))
-           (mver (tmtex-image-mag (caddr l)))
-          ) ;
-      (cond ((or (not mhor) (not mver)) (list 'resizebox hor ver fig))
-            ((and (== mhor 0.0) (== mver 0.0)) fig)
-            ((or (== mhor 1.0) (== mver 1.0)) fig)
-            ((== mhor 0.0) (list 'scalebox (number->string mver) fig))
-            (else (list 'scalebox (number->string mhor) fig))
-      ) ;cond
-    ) ;let*
-  ) ;if
-) ;define
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Metadata for documents
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (tmtex-make-inline t)
-  (tm-replace t '(new-line) '(next-line))
-) ;define
-
-(tm-define (tmtex-inline t) (tmtex (tmtex-make-inline t)))
-
-(tm-define (tmtex-doc-title t) `(title ,(tmtex-inline (cadr t))))
-
-(tm-define (tmtex-doc-running-title t)
-  `(tmrunningtitle ,(tmtex-inline (cadr t)))
-) ;tm-define
-
-(tm-define (tmtex-doc-subtitle t)
-  (set! t (tmtex-remove-line-feeds t))
-  `(tmsubtitle ,(tmtex-inline (cadr t)))
-) ;tm-define
-
-(tm-define (tmtex-doc-note t)
-  (set! t (tmtex-remove-line-feeds t))
-  `(tmnote ,(tmtex (cadr t)))
-) ;tm-define
-
-(tm-define (tmtex-doc-misc t)
-  (set! t (tmtex-remove-line-feeds t))
-  `(tmmisc ,(tmtex (cadr t)))
-) ;tm-define
-
-(tm-define (tmtex-doc-date t) `(date ,(tmtex-inline (cadr t))))
-
-(tm-define (tmtex-doc-running-author t)
-  `(tmrunningauthor ,(tmtex-inline (cadr t)))
-) ;tm-define
-
-(tm-define (tmtex-author-name t) `(author ,(tmtex-inline (cadr t))))
-
-(tm-define (tmtex-author-affiliation t)
-  ;; (set! t (tmtex-remove-line-feeds t))
-  `(tmaffiliation ,(tmtex (cadr t)))
-) ;tm-define
-
-(tm-define (tmtex-author-email t)
-  (set! t (tmtex-remove-line-feeds t))
-  `(tmemail ,(tmtex-inline (cadr t)))
-) ;tm-define
-
-(tm-define (tmtex-author-homepage t)
-  (set! t (tmtex-remove-line-feeds t))
-  `(tmhomepage ,(tmtex-inline (cadr t)))
-) ;tm-define
-
-(tm-define (tmtex-author-note t)
-  (set! t (tmtex-remove-line-feeds t))
-  `(tmnote ,(tmtex (cadr t)))
-) ;tm-define
-
-(tm-define (tmtex-author-misc t)
-  (set! t (tmtex-remove-line-feeds t))
-  `(tmmisc ,(tmtex (cadr t)))
-) ;tm-define
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Useful macros for metadata presentation
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-select-args-by-func n l) (filter (lambda (x) (func? x n)) l))
-
-(define (tmtex-get-transform l tag)
-  (let ((transform (symbol-append 'tmtex- tag)) (l* (tmtex-select-args-by-func tag l)))
-    (map tmtex l*)
-  ) ;let
-) ;define
-
-(tm-define (tmtex-remove-line-feeds t)
-  (if (npair? t)
-    t
-    (with (r s)
-      (list (car t) (map tmtex-remove-line-feeds (cdr t)))
-      (if (== r 'next-line) '(!concat (tmSep) (!linefeed)) `(,r ,@s))
-    ) ;with
-  ) ;if
-) ;tm-define
-
-(tm-define (tmtex-replace-documents t)
-  (if (npair? t)
-    t
-    (with (r s)
-      (list (car t) (map tmtex-replace-documents (cdr t)))
-      (if (!= r 'document) `(,r ,@s) `(concat ,@(list-intersperse s
-                                                  '(next-line))))
-    ) ;with
-  ) ;if
-) ;tm-define
-
-(tm-define (contains-tags? t l)
-  (cond ((or (nlist? t) (null? t)) #f)
-        ((in? (car t) l) #t)
-        (else (with found?
-                #f
-                (for-each (lambda (x) (set! found? (or found? (contains-tags? x l)))) t)
-                found?
-              ) ;with
-        ) ;else
-  ) ;cond
-) ;tm-define
-
-(tm-define (contains-stree? t u)
-  (cond ((== t u) #t)
-        ((or (null? t) (nlist? t)) #f)
-        (else (with found?
-                #f
-                (for-each (lambda (x) (set! found? (or found? (contains-stree? x u)))) t)
-                found?
-              ) ;with
-        ) ;else
-  ) ;cond
-) ;tm-define
-
-;; Metadata clustering
-
-(define (stree-replace l what by)
-  (cond ((or (null? l) (nlist? l)) l)
-        ((== l what) by)
-        (else (map (lambda (x) (stree-replace x what by)) l))
-  ) ;cond
-) ;define
-
-(define (next-stree-occurence l tag)
-  (cond ((or (null? l) (nlist? l)) #f)
-        ((== (car l) tag) l)
-        (else (with found?
-                #f
-                (map-in-order (lambda (x) (if (not found?) (set! found? (next-stree-occurence x tag))))
-                  l
-                ) ;map-in-order
-                found?
-              ) ;with
-        ) ;else
-  ) ;cond
-) ;define
-
-(define (add-refs l n tag tr tl global-counter?)
-  (with streetag
-    (next-stree-occurence (car l) tag)
-    (if (not streetag)
-      (begin
-        (if global-counter? (set! tmtex-ref-cnt n))
-        l
-      ) ;begin
-      (let* ((n* (number->string n))
-             (tagref (list tr n*))
-             (authors (stree-replace (car l) streetag tagref))
-             (taglist (if (null? (cdr l)) '() (cadr l)))
-             (taglist `(,@taglist (,tl ,n* ,(cadr streetag))))
-             (l* (list authors taglist))
-            ) ;
-        (add-refs l* (1+ n) tag tr tl global-counter?)
-      ) ;let*
-    ) ;if
-  ) ;with
-) ;define
-
-(tm-define (make-references l tag author? global-counter?)
-  (let* ((tag-ref (symbol-append tag '- 'ref))
-         (tag-label (symbol-append tag '- 'label))
-         (cnt (if global-counter? tmtex-ref-cnt 1))
-         (tmp (add-refs `(,l) cnt tag tag-ref tag-label global-counter?))
-         (data-refs (car tmp))
-         (data-labels (if (null? (cdr tmp)) '() (cadr tmp)))
-        ) ;
-    (if author? (set! data-labels `((doc-author (author-data ,@data-labels)))))
-    `(,@data-refs ,@data-labels)
-  ) ;let*
-) ;tm-define
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Author metadata presentation
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-prepare-author-data l) l)
-
-(tm-define (tmtex-make-author names
-             affiliations
-             emails
-             urls
-             miscs
-             notes
-             affs*
-             emails*
-             urls*
-             miscs*
-             notes*
-           ) ;tmtex-make-author
-  (let* ((names (tmtex-concat-Sep (map cadr names)))
-         (result `(,@names ,@notes ,@miscs ,@affiliations ,@emails ,@urls))
-        ) ;
-    (if (null? result) '() `(author (!paragraph ,@result)))
-  ) ;let*
-) ;tm-define
-
-(tm-define (tmtex-doc-author t)
-  (if (or (npair? t) (npair? (cdr t)) (not (func? (cadr t) 'author-data)))
-    '()
-    (let* ((l (tmtex-prepare-author-data (cdadr t)))
-           (names (tmtex-get-transform l 'author-name))
-           (emails (tmtex-get-transform l 'author-email))
-           (urls (tmtex-get-transform l 'author-homepage))
-           (affs (tmtex-get-transform l 'author-affiliation))
-           (miscs (tmtex-get-transform l 'author-misc))
-           (notes (tmtex-get-transform l 'author-note))
-           (emails* (tmtex-get-transform l 'author-email-ref))
-           (urls* (tmtex-get-transform l 'author-homepage-ref))
-           (affs* (tmtex-get-transform l 'author-affiliation-ref))
-           (miscs* (tmtex-get-transform l 'author-misc-ref))
-           (notes* (tmtex-get-transform l 'author-note-ref))
-           (affs (append affs (tmtex-get-transform l 'author-affiliation-label)))
-           (urls (append urls (tmtex-get-transform l 'author-homepage-label)))
-           (miscs (append miscs (tmtex-get-transform l 'author-misc-label)))
-           (notes (append notes (tmtex-get-transform l 'author-note-label)))
-           (emails (append emails (tmtex-get-transform l 'author-email-label)))
-          ) ;
-      (tmtex-make-author names
-        affs
-        emails
-        urls
-        miscs
-        notes
-        affs*
-        emails*
-        urls*
-        miscs*
-        notes*
-      ) ;tmtex-make-author
-    ) ;let*
-  ) ;if
-) ;tm-define
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Document metadata presentation
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-prepare-doc-data l)
-  (set! l (map tmtex-replace-documents l))
-  l
-) ;tm-define
-
-(define (tmtex-make-title titles subtitles notes miscs tr)
-  (let* ((titles (tmtex-concat-Sep (map cadr titles)))
-         (content `(,@titles ,@subtitles ,@notes ,@miscs))
-        ) ;
-    (if (null? content) '() `((title (!indent (!paragraph ,@content)))))
-  ) ;let*
-) ;define
-
-(tm-define (tmtex-append-authors l)
-  (set! l (filter nnull? l))
-  (cond ((null? l) '())
-        ((== (length l) 1) `((author (!indent (!concat ,@(cdar l))))))
-        (else (with lf
-                '(!concat (!linefeed) (and) (!linefeed))
-                `((author (!indent (!concat ,@(list-intersperse (map cadr l) lf)))))
-              ) ;with
-        ) ;else
-  ) ;cond
-) ;tm-define
-
-(tm-define (tmtex-make-doc-data titles
-             subtitles
-             authors
-             dates
-             miscs
-             notes
-             subtits-l
-             dates-l
-             miscs-l
-             notes-l
-             tr
-             ar
-           ) ;tmtex-make-doc-data
-  `(!document ,@(tmtex-make-title titles subtitles notes miscs tr)
-     ,@(tmtex-append-authors authors)
-     ,@dates
-     (maketitle))
-) ;tm-define
-
-(tm-define (tmtex-get-title-option l)
-  (apply append (map cdr (tmtex-select-args-by-func 'doc-title-options l)))
-) ;tm-define
-
-(tm-define (tmtex-doc-data s l)
-  (set! l (tmtex-prepare-doc-data l))
-  (let* ((titles (tmtex-get-transform l 'doc-title))
-         (tr (tmtex-get-transform l 'doc-running-title))
-         (subtits (tmtex-get-transform l 'doc-subtitle))
-         (authors (tmtex-get-transform l 'doc-author))
-         (ar (tmtex-get-transform l 'doc-running-author))
-         (dates (tmtex-get-transform l 'doc-date))
-         (miscs (tmtex-get-transform l 'doc-misc))
-         (notes (tmtex-get-transform l 'doc-note))
-         (subtits-l (tmtex-get-transform l 'doc-subtitle-label))
-         (dates-l (tmtex-get-transform l 'doc-date-label))
-         (miscs-l (tmtex-get-transform l 'doc-misc-label))
-         (notes-l (tmtex-get-transform l 'doc-note-label))
-         (subtits (append subtits (tmtex-get-transform l 'doc-subtitle-ref)))
-         (dates (append dates (tmtex-get-transform l 'doc-date-ref)))
-         (miscs (append miscs (tmtex-get-transform l 'doc-misc-ref)))
-         (notes (append notes (tmtex-get-transform l 'doc-note-ref)))
-        ) ;
-    (tmtex-make-doc-data titles
-      subtits
-      authors
-      dates
-      miscs
-      notes
-      subtits-l
-      dates-l
-      miscs-l
-      notes-l
-      tr
-      ar
-    ) ;tmtex-make-doc-data
-  ) ;let*
-) ;tm-define
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Abstract metadata presentation
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tmtex-abstract t) (tmtex-std-env "abstract" (cdr t)))
-
-(tm-define (tmtex-abstract-keywords t)
-  (with args
-    (list-intersperse (map tmtex (cdr t)) '(tmsep))
-    `(!concat (tmkeywords) ,@(map (lambda (x) `(!group ,x)) args))
-  ) ;with
-) ;tm-define
-
-(tm-define (tmtex-abstract-acm t)
-  (with args
-    (list-intersperse (map tmtex (cdr t)) '(tmsep))
-    `(!concat (tmacm) ,@(map (lambda (x) `(!group ,x)) args))
-  ) ;with
-) ;tm-define
-
-(tm-define (tmtex-abstract-arxiv t)
-  (with args
-    (list-intersperse (map tmtex (cdr t)) '(tmsep))
-    `(!concat (tmarxiv) ,@(map (lambda (x) `(!group ,x)) args))
-  ) ;with
-) ;tm-define
-
-(tm-define (tmtex-abstract-msc t)
-  (with args
-    (list-intersperse (map tmtex (cdr t)) '(tmsep))
-    `(!concat (tmmsc) ,@(map (lambda (x) `(!group ,x)) args))
-  ) ;with
-) ;tm-define
-
-(tm-define (tmtex-abstract-pacs t)
-  (with args
-    (list-intersperse (map tmtex (cdr t)) '(tmsep))
-    `(!concat (tmpacs) ,@(map (lambda (x) `(!group ,x)) args))
-  ) ;with
-) ;tm-define
-
-(tm-define (tmtex-make-abstract-data keywords acm arxiv msc pacs abstract)
-  (with result
-    `(,@abstract ,@acm ,@arxiv ,@msc ,@pacs ,@keywords)
-    (if (null? result) "" `(!document ,@result))
-  ) ;with
-) ;tm-define
-
-(tm-define (tmtex-abstract-data s l)
-  (let* ((acm (map tmtex-abstract-acm (tmtex-select-args-by-func 'abstract-acm l)))
-         (arxiv (map tmtex-abstract-arxiv (tmtex-select-args-by-func 'abstract-arxiv l)))
-         (msc (map tmtex-abstract-msc (tmtex-select-args-by-func 'abstract-msc l)))
-         (pacs (map tmtex-abstract-pacs (tmtex-select-args-by-func 'abstract-pacs l)))
-         (keywords (map tmtex-abstract-keywords (tmtex-select-args-by-func 'abstract-keywords l))
-         ) ;keywords
-         (abstract (map tmtex-abstract (tmtex-select-args-by-func 'abstract l)))
-        ) ;
-    (tmtex-make-abstract-data keywords acm arxiv msc pacs abstract)
-  ) ;let*
-) ;tm-define
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; TeXmacs style primitives
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (tmtex-std-env s l)
-  (if (== s "quote-env") (set! s "quote"))
-  (list (list '!begin s) (tmtex (car l)))
-) ;define
-
-(define (tmtex-footnote s l)
-  `(footnote ,(tmtex (car l)))
-) ;define
-
-(define (tmtex-footnotemark s l)
-  `(footnotemark (!option ,(tmtex (car l))))
-) ;define
-
-(define (filter-enunciation-due-to l)
-  (cond ((func? l 'dueto) (list l))
-        ((nlist>0? l) '())
-        (else (append-map filter-enunciation-due-to l))
-  ) ;cond
-) ;define
-
-(define (filter-enunciation-body l)
-  (cond ((func? l 'dueto) '())
-        ((nlist>0? l) l)
-        (else (filter nnull? (map filter-enunciation-body l)))
-  ) ;cond
-) ;define
-
-(define (tmtex-enunciation s l)
-  (let* ((t (car l))
-         (option (filter-enunciation-due-to t))
-         (option* (map (lambda (x) `(!option ,(tmtex (cadr x)))) option))
-         (body (filter-enunciation-body t))
-        ) ;
-    `((!begin ,s ,@option*) ,(tmtex body))
-  ) ;let*
-) ;define
-
-(define (find-label x)
-  (cond ((npair? x) #f)
-        ((func? x 'label) x)
-        (else (or (find-label (car x)) (find-label (cdr x))))
-  ) ;cond
-) ;define
-
-(define (remove-labels x)
-  (cond ((npair? x) x)
-        ((func? x 'label) "")
-        (else (cons (remove-labels (car x)) (remove-labels (cdr x))))
-  ) ;cond
-) ;define
-
-(define (tmtex-sectional s l)
-  (tmtex-image-increment)
-  (let* ((lab (find-label (car l)))
-         (tit (if lab (remove-labels (car l)) (car l)))
-         (sec (list (string->symbol s) (tmtex tit)))
-        ) ;
-    (if lab (list '!concat sec lab) sec)
-  ) ;let*
-) ;define
-
-(define (tmtex-appendix s l)
-  (with app
-    (list (if (latex-book-style?) 'chapter 'section) (tmtex (car l)))
-    (if tmtex-appendices?
-      app
-      (begin
-        (set! tmtex-appendices? #t)
-        (list '!concat '(appendix) app)
-      ) ;begin
-    ) ;if
-  ) ;with
-) ;define
-
-(define (tmtex-appendix* s l)
-  (with app
-    (list (if (latex-book-style?) 'chapter* 'section*) (tmtex (car l)))
-    (if tmtex-appendices?
-      app
-      (begin
-        (set! tmtex-appendices? #t)
-        (list '!concat '(appendix) app)
-      ) ;begin
-    ) ;if
-  ) ;with
-) ;define
-
-(define (tmtex-tt-document l)
-  (cond ((null? l) "")
-        ((null? (cdr l)) (tmtex-tt (car l)))
-        (else (string-append (tmtex-tt (car l)) "\n" (tmtex-tt-document (cdr l))))
-  ) ;cond
-) ;define
-
-(define (tmtex-tt x)
-  (cond ((string? x) (tmtex-verb-string x))
-        ((== x '(next-line)) "\n")
-        ((func? x 'document) (tmtex-tt-document (cdr x)))
-        ((func? x 'para) (tmtex-tt-document (cdr x)))
-        ((func? x 'concat) (apply string-append (map-in-order tmtex-tt (cdr x))))
-        ((func? x 'mtm 2) (tmtex-tt (cAr x)))
-        ((func? x 'surround 3)
-         (string-append (tmtex-tt (cadr x)) (tmtex-tt (cadddr x)) (tmtex-tt (caddr x)))
-        ) ;
-        ((or (func? x 'hgroup 1) (func? x 'vgroup 1)) (tmtex-tt (cadr x)))
-        ((func? x 'with)
-         (begin
-           (display* "TeXmacs] lost  in verbatim content: " (cDr x) "\n")
-           (tmtex-tt (cAr x))
-         ) ;begin
-        ) ;
-        ((func? x 'math)
-         (begin
-           (display* "TeXmacs] lost  in verbatim content: " (cDr x) "\n")
-           (tmtex-tt (cAr x))
-         ) ;begin
-        ) ;
-        (else (begin (display* "TeXmacs] non converted verbatim content: " x "\n") ""))
-  ) ;cond
-) ;define
-
-(define (unescape-angles l)
-  (cond ((string? l) (string-replace (string-replace l "" "<") "" ">"))
-        ((symbol? l) l)
-        (else (map unescape-angles l))
-  ) ;cond
-) ;define
-
-(define (escape-braces l)
-  (cond ((string? l) (string-replace (string-replace l "{" "\\{") "}" "\\}"))
-        ((symbol? l) l)
-        (else (map escape-braces l))
-  ) ;cond
-) ;define
-
-(define (escape-backslashes l)
-  (cond ((string? l) (string-replace l "\\" "\\textbackslash "))
-        ((symbol? l) l)
-        (else (map escape-backslashes l))
-  ) ;cond
-) ;define
-
-(define (tmtex-new-theorem s l)
-  (with var
-    (tmtex-var-name (car l))
-    (ahash-set! tmtex-dynamic (string->symbol (car l)) 'environment)
-    (ahash-set! tmtex-dynamic (string->symbol var) 'environment)
-    (if (and (logic-in? var latex-texmacs-theorem-environment%))
-      ""
-      `(newtheorem ,var (,@(cdr l)))
-    ) ;if
-  ) ;with
-) ;define
-
-(define (tmtex-verbatim s l)
-  (if (func? (car l) 'document)
-    (list '!verbatim (tmtex-tt (escape-braces (escape-backslashes (car l)))))
-    (list 'tmverbatim (tmtex (car l)))
-  ) ;if
-) ;define
-
-(define (sharp-fix t)
-  (cond ((and (func? t '!document) (nnull? (cdr t)))
-         `(!document ,(sharp-fix (cadr t)) ,@(cddr t))
-        ) ;
-        ((and (func? t '!concat) (nnull? (cdr t)))
-         `(!concat ,(sharp-fix (cadr t)) ,@(cddr t))
-        ) ;
-        ((and (string? t) (string-starts? t "#")) (string-append "\\" t))
-        (else t)
-  ) ;cond
-) ;define
-
-(define (tmtex-verbatim* s l)
-  (if (func? (car l) 'document)
-    (list '!verbatim* (sharp-fix (tmtex-tt (car l))))
-    (list 'tmverbatim (tmtex (car l)))
-  ) ;if
-) ;define
-
-(define (tmtex-code-inline s l)
-  (with lang `((!option ,s)) `(tmcodeinline ,@lang ,(tmtex (car l))))
-) ;define
-
-(define (tmtex-code-block s l)
-  (set! l (escape-backslashes l))
-  (set! l (escape-braces l))
-  (set! s (car (string-decompose s "-")))
-  (if (or (== s "verbatim") (== s "code"))
-    `((!begin* ,"alltt") ,(tmtex-verbatim* "" l))
-    (with lang `((!option ,s))
-      `((!begin* ,"tmcode" ,@lang) ,(tmtex-verbatim* "" l))
-    ) ;with
-  ) ;if
-) ;define
-
-(define (tmtex-add-preview-packages x)
-  (cond ((list? x) (for-each tmtex-add-preview-packages x))
-        ((nstring? x) (noop))
-        ((string-occurs? "tikzpicture" x) (latex-add-extra "tikz"))
-  ) ;cond
-) ;define
-
-(define (tmtex-mixed s l)
-  (if (func? (cadr l) 'text) (set! l `(,"" ,(cadadr l))))
-  ;; (set! l (unescape-angles l))
-  ;; NOTE: instead, we now unescape in tmtex-verb-string
-  (tmtex-env-set "mode" "text")
-  (with src
-    (list '!verbatim* (tmtex-tt (cadr l)))
-    (tmtex-add-preview-packages src)
-    (tmtex-env-reset "mode")
-    (list '!unindent src)
-  ) ;with
-) ;define
-
-(define (tmtex-listing s l)
-  (list (list '!begin "tmlisting") (tmtex (car l)))
-) ;define
-;; (list (list '!begin "linenumbers") (tmtex (car l))))
-
-(define (tmtex-minipage s l)
-  (let* ((pos (car l))
-         (opt (if (== pos "f") '() `((!option ,pos))))
-         (size (cadr l))
-         (body (caddr l))
-        ) ;
-    `((!begin ,"minipage" ,@opt ,(tmtex-decode-length size)) ,(tmtex body))
-  ) ;let*
-) ;define
-
-(define (tmtex-number-renderer l)
-  (let ((r (cond ((string? l) l) ((list? l) (tmtex-number-renderer (car l))) (else "")))
-       ) ;
-    (cond ((== r "alpha") "alph")
-          ((== r "Alpha") "Alph")
-          (else r)
-    ) ;cond
-  ) ;let
-) ;define
-
-(define (tmtex-number-counter l)
-  (cond ((func? l 'value) (tmtex-number-counter (cdr l)))
-        ((and (list? l) (== 1 (length l))) (tmtex-number-counter (car l)))
-        ((symbol? l) (tmtex-number-counter (symbol->string l)))
-        ((string? l) (if (string-ends? l "-nr") (string-drop-right l 3) l))
-        (else "")
-  ) ;cond
-) ;define
-
-(define (tmtex-number l)
-  (tmtex-default (tmtex-number-renderer (cdr l))
-    (list (tmtex-number-counter (car l)))
-  ) ;tmtex-default
-) ;define
-
-(define (tmtex-change-case l)
-  (cond ((== (cadr l) "UPCASE") (tex-apply 'MakeUppercase (tmtex (car l))))
-        ((== (cadr l) "locase") (tex-apply 'MakeLowercase (tmtex (car l))))
-        (else (tmtex (car l)))
-  ) ;cond
-) ;define
-
-(define (tmtex-frame s l)
-  `(fbox ,(tmtex (car l)))
-) ;define
-
-(define (tmtex-colored-frame s l)
-  `(colorbox ,(tmtex-decode-color (car l)) ,(tmtex (cadr l)))
-) ;define
-
-(define (tmtex-fcolorbox s l)
-  `(fcolorbox ,@(map tmtex-decode-color (cDr l)) ,(tmtex (cAr l)))
-) ;define
-
-(define (tmtex-rotate s l)
-  (let* ((body (tmtex (cadr l)))
-         (body* (if (tmtex-math-mode?) `(ensuremath ,body) body))
-        ) ;
-    `(rotatebox (!option "origin=c") ,(tmtex (car l)) ,body*)
-  ) ;let*
-) ;define
-
-(define (tmtex-translate s l)
-  (let ((from (cadr l)) (to (caddr l)) (body (car l)))
-    (tmtex (translate-from-to body from to))
-  ) ;let
-) ;define
-
-(define (tmtex-localize s l)
-  (with lan
-    (if (list>0? tmtex-languages) (cAr tmtex-languages) "english")
-    (tmtex `(translate ,(car l) ,"english" ,lan))
-  ) ;with
-) ;define
-
-(define (tmtex-render-key s l)
-  (with body
-    (tmtex (car l))
-    (if (func? body '!concat) (set! body `(!append ,@(cdr body))))
-    `(key ,body)
-  ) ;with
-) ;define
-
-(define (tmtex-key s l)
-  (tmtex (tm->stree (tmdoc-key (car l))))
-) ;define
-
-(define (tmtex-key* s l)
-  (tmtex (tm->stree (tmdoc-key* (car l))))
-) ;define
-
-(define (tmtex-padded-center s l)
-  (list (list '!begin "center") (tmtex (car l)))
-) ;define
-
-(define (tmtex-padded-left-aligned s l)
-  (list (list '!begin "flushleft") (tmtex (car l)))
-) ;define
-
-(define (tmtex-padded-right-aligned s l)
-  (list (list '!begin "flushright") (tmtex (car l)))
-) ;define
-
-(define (tmtex-compact s l)
-  (list (list '!begin "tmcompact") (tmtex (car l)))
-) ;define
-
-(define (tmtex-compressed s l)
-  (list (list '!begin "tmcompressed") (tmtex (car l)))
-) ;define
-
-(define (tmtex-amplified s l)
-  (list (list '!begin "tmamplified") (tmtex (car l)))
-) ;define
-
-(define (tmtex-indent s l)
-  (list (list '!begin "tmindent") (tmtex (car l)))
-) ;define
-
-(define (tmtex-jump-in s l)
-  (list (list '!begin "tmjumpin") (tmtex (car l)))
-) ;define
-
-(define (tmtex-script-inout s l)
-  (let ((name (string->symbol (string-append "tm" (string-replace s "-" ""))))
-        (lang (car l))
-        (lang* (session-name (car l)))
-        (in (tmtex (caddr l)))
-        (out (tmtex (cadddr l)))
-       ) ;
-    `(,name ,lang ,lang* ,in ,out)
-  ) ;let
-) ;define
-
-(define (tmtex-converter s l)
-  (let ((name (string->symbol (string-append "tm" (string-replace s "-" ""))))
-        (lang (car l))
-        (lang* (format-get-name (car l)))
-        (in (tmtex (cadr l)))
-        (out (tmtex (caddr l)))
-       ) ;
-    `(,name ,lang ,lang* ,in ,out)
-  ) ;let
-) ;define
-
-(define (tmtex-list-env s l)
-  (let* ((r (string-replace s "-" ""))
-         (t (cond ((== r "enumerateRoman") "enumerateromancap")
-                  ((== r "enumerateAlpha") "enumeratealphacap")
-                  (else r)
-            ) ;cond
-         ) ;t
-        ) ;
-    (list (list '!begin t) (tmtex (car l)))
-  ) ;let*
-) ;define
-
-(define (tmtex-tiny s l)
-  (tex-apply 'tiny (tmtex (car l)))
-) ;define
-
-(define (tmtex-scriptsize s l)
-  (tex-apply 'scriptsize (tmtex (car l)))
-) ;define
-
-(define (tmtex-footnotesize s l)
-  (tex-apply 'footnotesize (tmtex (car l)))
-) ;define
-
-(define (tmtex-small s l)
-  (tex-apply 'small (tmtex (car l)))
-) ;define
-
-(define (tmtex-normalsize s l)
-  (tex-apply 'normalsize (tmtex (car l)))
-) ;define
-
-(define (tmtex-large s l)
-  (tex-apply 'large (tmtex (car l)))
-) ;define
-
-(define (tmtex-Large s l)
-  (tex-apply 'Large (tmtex (car l)))
-) ;define
-
-(define (tmtex-LARGE s l)
-  (tex-apply 'LARGE (tmtex (car l)))
-) ;define
-
-(define (tmtex-Huge s l)
-  (list 'Huge (tmtex (car l)))
-) ;define
-
-(define (tmtex-specific-language s l)
-  (tmtex `(with ,"language" ,s ,(car l)))
-) ;define
-
-(tm-define (tmtex-equation s l)
-  (tmtex-image-increment)
-  (tmtex-env-set "mode" "math")
-  (let ((r (tmtex (car l))))
-    (tmtex-env-reset "mode")
-    (if (== s "equation") (list (list '!begin s) r) (list '!eqn r))
-  ) ;let
-) ;tm-define
-
-(define (tmtex-eqnarray s l)
-  (tmtex-image-increment)
-  (tmtex-env-set "mode" "math")
-  (let ((r (tmtex-table-apply (string->symbol s) '() (car l))))
-    (tmtex-env-reset "mode")
-    r
-  ) ;let
-) ;define
-
-(define (tmtex-math s l)
-  (cond ((tm-in? (car l) '(equation equation* eqnarray eqnarray*)) (tmtex (car l)))
-        ((not (tm-func? (car l) 'document)) (tmtex `(with ,"mode"
-                                                      ,"math"
-                                                      ,(car l))))
-        ((tm-func? (car l) 'document 1) (tmtex `(math ,(cadr (car l)))))
-        (else (with ps (map (lambda (x) `(math ,x)) (cdar l)) (tmtex `(document ,@ps))))
-  ) ;cond
-) ;define
-
-(define (tmtex-textual x)
-  (tmtex-env-set "mode" "text")
-  (with r (tmtex x) (tmtex-env-reset "mode") r)
-) ;define
-
-(define (tmtex-text s l)
-  (list 'text (tmtex-textual (car l)))
-) ;define
-
-(define (tmtex-math-up s l)
-  (post-process-math-text (list 'mathrm (tmtex-textual (car l))))
-) ;define
-
-(define (tmtex-math-ss s l)
-  (post-process-math-text (list 'mathsf (tmtex-textual (car l))))
-) ;define
-
-(define (tmtex-math-tt s l)
-  (post-process-math-text (list 'mathtt (tmtex-textual (car l))))
-) ;define
-
-(define (tmtex-math-bf s l)
-  (post-process-math-text (list 'mathbf (tmtex-textual (car l))))
-) ;define
-
-(define (tmtex-math-sl s l)
-  (post-process-math-text (list 'mathsl (tmtex-textual (car l))))
-) ;define
-
-(define (tmtex-math-it s l)
-  (post-process-math-text (list 'mathit (tmtex-textual (car l))))
-) ;define
-
-(define (tmtex-mathord s l)
-  (list 'mathord (tmtex (car l)))
-) ;define
-
-(define (tmtex-mathbin s l)
-  (list 'mathbin (tmtex (car l)))
-) ;define
-
-(define (tmtex-mathrel s l)
-  (list 'mathrel (tmtex (car l)))
-) ;define
-
-(define (tmtex-mathopen s l)
-  (list 'mathopen (tmtex (car l)))
-) ;define
-
-(define (tmtex-mathclose s l)
-  (list 'mathclose (tmtex (car l)))
-) ;define
-
-(define (tmtex-mathpunct s l)
-  (list 'mathpunct (tmtex (car l)))
-) ;define
-
-(define (tmtex-mathop s l)
-  (list 'mathop (tmtex (car l)))
-) ;define
-
-(define (tmtex-syntax l)
-  (tmtex (car l))
-) ;define
-
-(define (tmtex-theindex s l)
-  (list 'printindex)
-) ;define
-
-(define (tmtex-toc s l)
-  (tex-apply 'tableofcontents)
-) ;define
-
-(define (tmtex-bib-sub doc)
-  (cond ((nlist? doc) doc)
-        ((match? doc '(concat (bibitem* :%1) (label :string?) :*))
-         (let* ((l (cadr (caddr doc))) (s (if (string-starts? l "bib-") (string-drop l 4) l)))
-           (cons* 'concat (list 'bibitem* (cadadr doc) s) (cdddr doc))
-         ) ;let*
-        ) ;
-        ((func? doc 'bib-list 2) (tmtex-bib-sub (cAr doc)))
-        (else (map tmtex-bib-sub doc))
-  ) ;cond
-) ;define
-
-(define (tmtex-bib-max l)
-  (cond ((npair? l) "")
-        ((match? l '(bibitem* :string? :%1)) (cadr l))
-        (else (let* ((s1 (tmtex-bib-max (car l))) (s2 (tmtex-bib-max (cdr l))))
-                (if (< (string-length s1) (string-length s2)) s2 s1)
-              ) ;let*
-        ) ;else
-  ) ;cond
-) ;define
-
-(tm-define (tmtex-biblio s l titled?)
-  (if tmtex-indirect-bib?
-    (tex-concat (list (list 'bibliographystyle (force-string (cadr l)))
-                  (list 'bibliography (force-string (caddr l)))
-                ) ;list
-    ) ;tex-concat
-    (let* ((doc (tmtex-bib-sub (cadddr l)))
-           (max (tmtex-textual (tmtex-bib-max doc)))
-           (tls tmtex-languages)
-           (lan (or (and (pair? tls) (car tls)) "english"))
-           (txt (translate-from-to "References" "english" lan))
-           (bib (tmtex (list 'thebibliography max doc)))
-          ) ;
-      (if titled? `(!document (section* ,(tmtex txt)) ,bib) bib)
-    ) ;let*
-  ) ;if
-) ;tm-define
-
-(tm-define (tmtex-bib t) (tmtex-biblio (car t) (cdr t) #f))
-
-(define (tmtex-thebibliography s l)
-  (list (list '!begin s (car l)) (tmtex (cadr l)))
-) ;define
-
-(define (tmtex-bibitem*-std s l)
-  (cond ((= (length l) 1) `(bibitem ,(car l)))
-        ((= (length l) 2) `(bibitem (!option ,(tmtex (car l))) ,(cadr l)))
-        (else (begin
-                (display* "TeXmacs] non converted bibitem content: " (list s l) "\n")
-                ""
-              ) ;begin
-        ) ;else
-  ) ;cond
-) ;define
-
-(tm-define (tmtex-bibitem* s l) (tmtex-bibitem*-std s l))
-
-(define (split-year s pos)
-  (if (and (> pos 0)
-        (string>=? (substring s (- pos 1) pos) "0")
-        (string<=? (substring s (- pos 1) pos) "9")
-      ) ;and
-    (split-year s (- pos 1))
-    pos
-  ) ;if
-) ;define
-
-(define (natbibify s)
-  (let* ((pos (split-year s (string-length s)))
-         (auth (substring s 0 pos))
-         (year (substring s pos (string-length s)))
-        ) ;
-    (when (== (string-length year) 2)
-      (set! year (string-append (if (string>=? year "30") "19" "20") year))
-    ) ;when
-    (string-append auth "(" year ")")
-  ) ;let*
-) ;define
-
-(tm-define (tmtex-bibitem* s l)
-  (:mode natbib-package?)
-  (if (and (== (length l) 2) (string? (cadr l)) (not (string-occurs? "(" (cadr l))))
-    (tmtex-bibitem*-std s (list (natbibify (cadr l)) (cadr l)))
-    (tmtex-bibitem*-std s l)
-  ) ;if
-) ;tm-define
-
-(define (tmtex-figure s l)
-  (tmtex-float-sub #f "h" (cons (string->symbol s) l))
-) ;define
-
-(define (tmtex-item s l)
-  (tex-concat (list (list 'item) " "))
-) ;define
-
-(define (tmtex-item-arg s l)
-  (tex-concat (list (list 'item (list '!option (tmtex (car l)))) " "))
-) ;define
-
-(define (tmtex-render-proof s l)
-  (list (list '!begin "proof*" (tmtex (car l))) (tmtex (cadr l)))
-) ;define
-
-(define (tmtex-nbsp s l)
-  '(!nbsp)
-) ;define
-
-(define (tmtex-nbhyph s l)
-  '(!nbhyph)
-) ;define
-
-(define (tmtex-frac* s l)
-  (tex-concat (list (tmtex (car l)) "/" (tmtex (cadr l))))
-) ;define
-
-(define (tmtex-ornament-shape s)
-  (if (== s "rounded") "1.7ex" "0pt")
-) ;define
-
-(define (assign-ornament-env l)
-  (let* ((keys* (car l)) (val (cadr l)) (keys (cDr keys*)) (fun (cAr keys*)))
-    (apply string-append
-      (list-intersperse (map (lambda (key)
-                               (with arg (fun val) (if (nstring? arg) "" (string-append key "=" arg)))
-                             ) ;lambda
-                          keys
-                        ) ;map
-        ","
-      ) ;list-intersperse
-    ) ;apply
-  ) ;let*
-) ;define
-
-(define (get-ornament-env)
-  (let* ((l1 (ahash-set->list tmtex-env))
-         (l21 (map (cut logic-ref tex-ornament-opts% <>) l1))
-         (l22 (map (cut tmtex-env-get <>) l1))
-         (l3 (map (lambda (x y) (if (and x y) (list x y) '())) l21 l22))
-         (l4 (filter nnull? l3))
-         (l5 (map assign-ornament-env l4))
-        ) ;
-    (apply string-append (list-intersperse l5 ","))
-  ) ;let*
-) ;define
-
-(define (tmtex-ornamented s l)
-  (if (== s "framed")
-    (if (not (and (pair? (car l)) (in? (caar l) '(document para))))
-      `(fbox ,(tmtex (car l)))
-      `((!begin "mdframed") ,(tmtex (car l)))
-    ) ;if
-    (let* ((env (string-append "tm" s))
-           (option (get-ornament-env))
-           (option* (if (!= option "") `((!option ,option)) '()))
-          ) ;
-      `((!begin ,env ,@option*) ,(tmtex (car l)))
-    ) ;let*
-  ) ;if
-) ;define
-
-(logic-table tex-ornament-opts%
- ("padding-above" ("skipabove" ,tmtex-decode-length))
- ("padding-below" ("skipbelow" ,tmtex-decode-length))
- ("overlined-sep" ("innertopmargin" ,tmtex-decode-length))
- ("underlined-sep" ("innerbottommargin" ,tmtex-decode-length))
- ("framed-hsep" ("innerleftmargin" "innerrightmargin" ,tmtex-decode-length))
- ("framed-vsep" ("innertopmargin" "innerbottommargin" ,tmtex-decode-length))
- ("ornament-vpadding"
-  ("innertopmargin" "innerbottommargin" ,tmtex-decode-length)
- ) ;
- ("ornament-hpadding"
-  ("innerleftmargin" "innerrightmargin" ,tmtex-decode-length)
- ) ;
- ("ornament-color" ("backgroundcolor" ,tmtex-decode-color))
- ("ornament-shape" ("roundcorner" ,tmtex-ornament-shape))
-) ;logic-table
-
-(define (tmtex-tm s l)
-  (with tag
-    (string->symbol (string-append "tm" (string-replace s "-" "")))
-    `(,tag ,@(map tmtex l))
-  ) ;with
-) ;define
-
-(define (tmtex-input-math s l)
-  (let ((tag (string->symbol (string-append "tm" (string-replace s "-" ""))))
-        (a1 (tmtex (car l)))
-        (a2 (with r
-              (begin
-                (tmtex-env-set "mode" "math")
-                (tmtex (cadr l))
-              ) ;begin
-              (tmtex-env-reset "mode")
-              r
-            ) ;with
-        ) ;a2
-       ) ;
-    (list tag a1 a2)
-  ) ;let
-) ;define
-
-(define (tmtex-fold-io-math s l)
-  (let ((tag (string->symbol (string-append "tm" (string-replace s "-" ""))))
-        (a1 (tmtex (car l)))
-        (a2 (with r
-              (begin
-                (tmtex-env-set "mode" "math")
-                (tmtex (cadr l))
-              ) ;begin
-              (tmtex-env-reset "mode")
-              r
-            ) ;with
-        ) ;a2
-        (a3 (tmtex (caddr l)))
-       ) ;
-    (list tag a1 a2 a3)
-  ) ;let
-) ;define
-
-(define (tmtex-session s l)
-  (let* ((tag (string->symbol (string-append "tm" (string-replace s "-" ""))))
-         (arg (tmtex (car l)))
-         (lan (tmtex (cadr l)))
-         (lst (tmtex (caddr l)))
-        ) ;
-    (if (func? lst '!document) (set! lst `(!indent (!paragraph ,@(cdr lst)))))
-    `(!document (,tag ,arg ,lan ,lst))
-  ) ;let*
-) ;define
-
-(define (escape-hyperref-url l)
-  (cond ((string? l)
-         (let* ((r1 (string-replace l "\\" "\\\\"))
-                (r2 (string-replace r1 "#" "\\#"))
-                (r3 (string-replace r2 "_" "\\_"))
-               ) ;
-           r3
-         ) ;let*
-        ) ;
-        ((symbol? l) l)
-        (else (map escape-hyperref-url l))
-  ) ;cond
-) ;define
-
-(define (tmtex-hyperref u)
-  (tmtex-tt (escape-hyperref-url u))
-) ;define
-
-(define (tmtex-hlink s l)
-  (let* ((h (cadr l)) (d (tmtex (car l))))
-    (if (and (string? h) (string-starts? h "#"))
-      (list 'hyperref `(!option ,(string-drop h 1)) d)
-      (list 'href (tmtex-hyperref h) d)
-    ) ;if
-  ) ;let*
-) ;define
-
-(define (tmtex-href s l)
-  (list 'url (tmtex-verb-string (car l)))
-) ;define
-
-(define (tmtex-action s l)
-  (list 'tmaction (tmtex (car l)) (tmtex (cadr l)))
-) ;define
-
-(define (tmtex-choose s l)
-  (list 'binom (tmtex (car l)) (tmtex (cadr l)))
-) ;define
-
-(define (tmtex-text-tt s l)
-  (if (tmtex-math-mode?) (tmtex-math-tt s l) (tmtex-modifier s l))
-) ;define
-
-(define (tmtex-modifier s l)
-  (tex-apply (string->symbol (string-append "tm" s)) (tmtex (car l)))
-) ;define
-
-(define (tmtex-render-line-number s l)
-  (list 'tmlinenumber (tmtex (car l)) (tmtex-decode-length (tmtex (cadr l))))
-) ;define
-
-(define (tmtex-menu-one x)
-  (tmtex (list 'samp x))
-) ;define
-
-(define (tmtex-menu-list l)
-  (if (null? l)
-    l
-    (cons* (list '!math (list 'rightarrow))
-      (tmtex-menu-one (car l))
-      (tmtex-menu-list (cdr l))
-    ) ;cons*
-  ) ;if
-) ;define
-
-(define (tmtex-menu s l)
-  (tex-concat (cons (tmtex-menu-one (car l)) (tmtex-menu-list (cdr l))))
-) ;define
-
-(define ((tmtex-rename into) s l)
-  (tmtex-apply into (tmtex-list l))
-) ;define
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Citations
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (tmtex-cite-list l)
-  (cond ((null? l) "")
-        ((nstring? (car l))
-         (display* "TeXmacs] non converted citation: " (car l) "\n")
-         (tmtex-cite-list (cdr l))
-        ) ;
-        ((null? (cdr l)) (car l))
-        (else (string-append (car l) "," (tmtex-cite-list (cdr l))))
-  ) ;cond
-) ;define
-
-(tm-define (tmtex-cite s l) (tex-apply 'cite (tmtex-cite-list l)))
-
-(tm-define (tmtex-cite s l)
-  (:mode natbib-package?)
-  (tex-apply 'citep (tmtex-cite-list l))
-) ;tm-define
-
-(define (tmtex-nocite s l)
-  (tex-apply 'nocite (tmtex-cite-list l))
-) ;define
-
-(tm-define (tmtex-cite-detail s l)
-  (with c
-    (tmtex-cite-list (list (car l)))
-    (tex-apply 'cite `(!option ,(tmtex (cadr l))) c)
-  ) ;with
-) ;tm-define
-
-(tm-define (tmtex-cite-detail s l)
-  (:mode natbib-package?)
-  (with c
-    (tmtex-cite-list (list (car l)))
-    (tex-apply 'citetext `(!concat (citealp ,c) ,", " ,(tmtex (cadr l))))
-  ) ;with
-) ;tm-define
-
-(tm-define (tmtex-cite-detail-poor s l)
-  (with c
-    (tmtex-cite-list (list (car l)))
-    `(!concat ,(tex-apply 'cite c) ," (" ,(tmtex (cadr l)) ,")")
-  ) ;with
-) ;tm-define
-
-(define (tmtex-cite-detail-hook s l)
-  (tmtex-cite-detail s l)
-) ;define
-
-(define (tmtex-cite-raw s l)
-  (tex-apply 'citealp (tmtex-cite-list l))
-) ;define
-
-(define (tmtex-cite-raw* s l)
-  (tex-apply 'citealp* (tmtex-cite-list l))
-) ;define
-
-(define (tmtex-cite-textual s l)
-  (tex-apply 'citet (tmtex-cite-list l))
-) ;define
-
-(define (tmtex-cite-textual* s l)
-  (tex-apply 'citet* (tmtex-cite-list l))
-) ;define
-
-(define (tmtex-cite-parenthesized s l)
-  (tex-apply 'citep (tmtex-cite-list l))
-) ;define
-
-(define (tmtex-cite-parenthesized* s l)
-  (tex-apply 'citep* (tmtex-cite-list l))
-) ;define
-
-(define (tmtex-render-cite s l)
-  (tex-apply 'citetext (tmtex (car l)))
-) ;define
-
-(define (tmtex-cite-author s l)
-  (tex-apply 'citeauthor (tmtex (car l)))
-) ;define
-
-(define (tmtex-cite-author* s l)
-  (tex-apply 'citeauthor* (tmtex (car l)))
-) ;define
-
-(define (tmtex-cite-year s l)
-  (tex-apply 'citeyear (tmtex (car l)))
-) ;define
-
-(define (tmtex-natbib-triple s l)
-  `(protect (citeauthoryear ,@(map tmtex l)))
-) ;define
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Glossaries
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (tmtex-glossary s l)
-  (with nr
-    (+ tmtex-auto-produce 1)
-    (set! tmtex-auto-produce nr)
-    `(label ,(string-append "autolab" (number->string nr)))
-  ) ;with
-) ;define
-
-(define (tmtex-glossary-entry s l)
-  (with nr
-    (+ tmtex-auto-consume 1)
-    (with lab
-      (string-append "autolab" (number->string nr))
-      (set! tmtex-auto-consume nr)
-      `(glossaryentry ,(tmtex (car l)) ,(tmtex (cadr l)) (pageref ,lab))
-    ) ;with
-  ) ;with
-) ;define
-
-(define (tmtex-glossary-line t)
-  (with r (tmtex t) (if (func? r 'glossaryentry) r `(listpart ,r)))
-) ;define
-
-(define (tmtex-glossary-body b)
-  (if (not (tm-func? b 'document))
-    (tmtex b)
-    (cons '!document (map-in-order tmtex-glossary-line (cdr b)))
-  ) ;if
-) ;define
-
-(define (tmtex-the-glossary s l)
-  `(!document (,(if (latex-book-style?) 'chapter* 'section*) ,"Glossary")
-     ((!begin ,"theglossary" ,(car l)) ,(tmtex-glossary-body (cadr l))))
-) ;define
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; The main conversion routines
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (tmtex-apply key args)
-  (let ((n (length args))
-        (r (or (ahash-ref tmtex-dynamic key) (logic-ref tmtex-methods% key)))
-       ) ;
-    (if (in? key '(quote quasiquote unquote)) (set! r tmtex-noop))
-    (cond ((== r 'environment) (tmtex-std-env (symbol->string key) args))
-          (r (r args))
-          (else (let ((p (logic-ref tmtex-tmstyle% key)))
-                  (cond ((and p (or (= (cadr p) -1) (= (cadr p) n)))
-                         ((car p) (symbol->string key) args)
-                        ) ;
-                        ((and p (= (cadr p) -2)) ((car p) `(,key ,@args)))
-                        ((and (= n 1) (or (func? (car args) 'tformat) (func? (car args) 'table)))
-                         (tmtex-table-apply key '() (car args))
-                        ) ;
-                        ((and (= n 2) (or (func? (cAr args) 'tformat) (func? (cAr args) 'table)))
-                         (tmtex-table-apply key (cDr args) (cAr args))
-                        ) ;
-                        (else (tmtex-function key args))
-                  ) ;cond
-                ) ;let
-          ) ;else
-    ) ;cond
-  ) ;let
-) ;define
-
-(define (tmtex-function f l)
-  (if (== (string-ref (symbol->string f) 0) #\!)
-    (cons f (map-in-order tmtex l))
-    (let ((v (tmtex-var-name (symbol->string f))))
-      (if (== v "")
-        ""
-        (apply tex-apply (cons (string->symbol v) (map-in-order tmtex l)))
-      ) ;if
-    ) ;let
-  ) ;if
-) ;define
-
-(define (tmtex-compound l)
-  (if (string? (car l)) (tmtex-apply (string->symbol (car l)) (cdr l)) "")
-) ;define
-
-(define (tmtex-list l)
-  (map-in-order tmtex l)
-) ;define
-
-(tm-define (tmtex x)
-  (cond ((string? x) (tmtex-string x))
-        ((list>0? x) (tmtex-apply (car x) (cdr x)))
-        (else "")
-  ) ;cond
-) ;tm-define
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Dispatching
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-dispatcher tmtex-primitives%
- ((:or unknown uninit error raw-data) tmtex-error)
- (document tmtex-document)
- (para tmtex-para)
- (surround tmtex-surround)
- (concat tmtex-concat)
- (rigid tmtex-rigid)
- (hgroup tmtex-rigid)
- (vgroup tmtex-id)
- (hidden tmtex-noop)
- (hspace tmtex-hspace)
- (vspace* tmtex-noop)
- (vspace tmtex-vspace)
- (space tmtex-space)
- (htab tmtex-htab)
- (move tmtex-first)
- (shift tmtex-first)
- (resize tmtex-first)
- (clipped tmtex-first)
- (repeat tmtex-noop)
- (float tmtex-float)
- (datoms tmtex-second)
- ((:or dlines dpages dbox) tmtex-noop)
- (line-note tmtex-line-note)
-
- (with-limits tmtex-noop)
- (line-break tmtex-line-break)
- (new-line tmtex-new-line)
- (next-line tmtex-next-line)
- (emdash tmtex-emdash)
- (no-break tmtex-no-break)
- (no-indent tmtex-no-first-indentation)
- (yes-indent tmtex-noop)
- (no-indent* tmtex-noop)
- (yes-indent* tmtex-noop)
- (page-break* tmtex-noop)
- (page-break tmtex-page-break)
- (no-page-break* tmtex-noop)
- (no-page-break tmtex-no-page-break)
- (no-break-here* tmtex-noop)
- (no-break-here tmtex-no-page-break)
- (no-break-start tmtex-no-page-break)
- (no-break-end tmtex-noop)
- (new-page* tmtex-noop)
- (new-page tmtex-new-page)
- (new-dpage* tmtex-noop)
- (new-dpage tmtex-noop)
-
- (around tmtex-around)
- (around* tmtex-around*)
- (big-around tmtex-big-around)
- (left tmtex-left)
- (mid tmtex-mid)
- (right tmtex-right)
- (big tmtex-big)
- (long-arrow tmtex-long-arrow)
- (lprime tmtex-lsup)
- (rprime tmtex-rsup)
- (below tmtex-below)
- (above tmtex-above)
- (lsub tmtex-lsub)
- (lsup tmtex-lsup)
- (rsub tmtex-rsub)
- (rsup tmtex-rsup)
- (modulo tmtex-modulo)
- (frac tmtex-frac)
- (sqrt tmtex-sqrt)
- (wide tmtex-wide)
- (neg tmtex-neg)
- (wide* tmtex-wide-star)
- ;; (tree tmtex-tree)
- (tree tmtex-tree-eps)
-
- (tformat tmtex-tformat)
- ((:or twith cwith tmarker) tmtex-noop)
- (table tmtex-table)
- (three-line-table tmtex-three-line-table)
- ((:or row cell subtable) tmtex-noop)
-
- (assign tmtex-assign)
- (with tmtex-with-wrapped)
- (provides tmtex-noop)
- (value tmtex-compound)
- (quote-value tmtex-noop)
- ((:or quote-value drd-props arg quote-arg) tmtex-noop)
- (compound tmtex-compound)
- ((:or xmacro get-label get-arity map-args eval-args mark eval) tmtex-noop)
- ;; quote missing
- (quasi tmtex-noop)
- ;; quasiquote missing
- ;; unquote missing
- ((:or unquote* copy if if* case while for-each extern include use-package)
-  tmtex-noop
- ) ;
- (syntax tmtex-syntax)
-
- ((:or or
-    xor
-    and
-    not
-    plus
-    minus
-    times
-    over
-    div
-    mod
-    merge
-    length
-    range
-    find-file
-    is-tuple
-    look-up
-    equal
-    unequal
-    less
-    lesseq
-    greater
-    greatereq
-  ) ;:or
-  tmtex-noop
- ) ;
-
- (number tmtex-number)
- (change-case tmtex-change-case)
- (date tmtex-date)
-
- ((:or cm-length
-    mm-length
-    in-length
-    pt-length
-    bp-length
-    dd-length
-    pc-length
-    cc-length
-    fs-length
-    fbs-length
-    em-length
-    ln-length
-    sep-length
-    yfrac-length
-    ex-length
-    fn-length
-    fns-length
-    bls-length
-    spc-length
-    xspc-length
-    par-length
-    pag-length
-    gm-length
-    gh-length
-  ) ;:or
-  tmtex-noop
- ) ;
-
- ((:or style-with
-    style-with*
-    style-only
-    style-only*
-    active
-    active*
-    inactive
-    inactive*
-    rewrite-inactive
-    inline-tag
-    open-tag
-    middle-tag
-    close-tag
-    symbol
-    latex
-    hybrid
-  ) ;:or
-  tmtex-noop
- ) ;
-
- ((:or tuple attr tmlen collection associate backup) tmtex-noop)
- (set-binding tmtex-noop)
- (get-binding tmtex-noop)
- (hidden-binding tmtex-hidden-binding)
- (label tmtex-label)
- (reference tmtex-reference)
- (pageref tmtex-pageref)
- (write tmtex-noop)
- (specific tmtex-specific)
- ((:or tag meaning flag) tmtex-noop)
-
- ((:or anim-compose
-    anim-repeat
-    anim-constant
-    anim-translate
-    anim-progressive
-    video
-    sound
-  ) ;:or
-  tmtex-noop
- ) ;
-
- (graphics tmtex-graphics)
- (superpose tmtex-noop)
- ((:or gr-group gr-transform text-at cline arc carc spline spine* cspline fill)
-  tmtex-noop
- ) ;
- (image tmtex-image)
- ((:or box-info frame-direct frame-inverse) tmtex-noop)
-
- ((:or format
-    line-sep
-    split
-    delay
-    hold
-    release
-    old-matrix
-    old-table
-    old-mosaic
-    old-mosaic-item
-    set
-    reset
-    expand
-    expand*
-    hide-expand
-    display-baloon
-    apply
-    begin
-    end
-    func
-    env
-  ) ;:or
-  tmtex-noop
- ) ;
-
- (shown tmtex-id)
- (mtm tmtex-mtm)
- (!file tmtex-file)
- (!arg tmtex-tex-arg)
-) ;logic-dispatcher
-
-(logic-dispatcher tmtex-extra-methods%
-  (stack tmtex-stack)
-  (wide-float tmtex-wide-float)
-  (phantom-float tmtex-noop)
-  ((:or marginal-note marginal-normal-note) tmtex-marginal-note)
-  ((:or marginal-left-note marginal-even-left-note) tmtex-marginal-left-note)
-  ((:or marginal-right-note marginal-even-right-note) tmtex-marginal-right-note)
-  (!ilx tmtex-ilx)
-) ;logic-dispatcher
-
-(logic-rules ((tmtex-methods% 'x 'y) (tmtex-primitives% 'x 'y))
- ((tmtex-methods% 'x 'y) (tmtex-extra-methods% 'x 'y))
-) ;logic-rules
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Expansion of all macros which are not recognized by LaTeX
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-table tmtex-tmstyle%
- ((:or section subsection subsubsection paragraph subparagraph part chapter)
-  (,tmtex-sectional 1)
- ) ;
- ((:or hide-preamble show-preamble) (,tmtex-default -1))
- (hide-part (,tmtex-hide-part -1))
- (show-part (,tmtex-show-part -1))
- ((:or doc-title-options author-data) (,tmtex-default -1))
- (appendix (,tmtex-appendix 1))
- (appendix* (,tmtex-appendix* 1))
- ((:or theorem
-    proposition
-    lemma
-    corollary
-    proof
-    axiom
-    definition
-    notation
-    conjecture
-    remark
-    note
-    example
-    convention
-    warning
-    acknowledgments
-    exercise
-    problem
-    question
-    solution
-    answer
-    quote-env
-    quotation
-    verse
-    theorem*
-    proposition*
-    lemma*
-    corollary*
-    axiom*
-    definition*
-    notation*
-    conjecture*
-    remark*
-    note*
-    example*
-    convention*
-    warning*
-    acknowledgments*
-    exercise*
-    problem*
-    question*
-    solution*
-    answer*
-  ) ;:or
-  (,tmtex-enunciation 1)
- ) ;
- (new-theorem (,tmtex-new-theorem 2))
- (new-remark (,tmtex-new-theorem 2))
- (new-exercise (,tmtex-new-theorem 2))
- (verbatim (,tmtex-verbatim 1))
- (padded-center (,tmtex-padded-center 1))
- (padded-left-aligned (,tmtex-padded-left-aligned 1))
- (padded-right-aligned (,tmtex-padded-right-aligned 1))
- (compact (,tmtex-compact 1))
- (compressed (,tmtex-compressed 1))
- (amplified (,tmtex-amplified 1))
- (indent (,tmtex-indent 1))
- (jump-in (,tmtex-jump-in 1))
- (algorithm-indent (,tmtex-indent 1))
- ((:or footnote wide-footnote) (,tmtex-footnote 1))
- (footnotemark (,tmtex-default 0))
- (footnotemark* (,tmtex-footnotemark 1))
- ((:or description
-    description-compact
-    description-aligned
-    description-dash
-    description-long
-    description-paragraphs
-    itemize
-    itemize-minus
-    itemize-dot
-    itemize-arrow
-    enumerate
-    enumerate-numeric
-    enumerate-numeric-bracket
-    enumerate-roman
-    enumerate-roman-bracket
-    enumerate-roman-paren
-    enumerate-Roman
-    enumerate-alpha
-    enumerate-alpha-bracket
-    enumerate-alpha-full-paren
-    enumerate-Alpha
-    enumerate-hanzi
-  ) ;:or
-  (,tmtex-list-env 1)
- ) ;
- ((:or folded
-    unfolded
-    folded-plain
-    unfolded-plain
-    folded-std
-    unfolded-std
-    folded-explain
-    unfolded-explain
-    folded-env
-    unfolded-env
-    folded-documentation
-    unfolded-documentation
-    folded-grouped
-    unfolded-grouped
-    summarized
-    detailed
-    summarized-plain
-    summarized-std
-    summarized-env
-    summarized-documentation
-    summarized-grouped
-    summarized-raw
-    summarized-tiny
-    detailed-plain
-    detailed-std
-    detailed-env
-    detailed-documentation
-    detailed-grouped
-    detailed-raw
-    detailed-tiny
-    unfolded-subsession
-    folded-subsession
-    folded-io
-    unfolded-io
-    input
-    output
-    errput
-    timing
-  ) ;:or
-  (,tmtex-tm -1)
- ) ;
- ((:or padded underlined overlined bothlined framed ornamented)
-  (,tmtex-ornamented 1)
- ) ;
- ((:or folded-io-math unfolded-io-math) (,tmtex-fold-io-math 3))
- (input-math (,tmtex-input-math 2))
- (session (,tmtex-session 3))
- ((:or converter-input converter-output) (,tmtex-converter 3))
- ((:or script-input script-output) (,tmtex-script-inout 4))
- (really-tiny (,tmtex-tiny 1))
- (very-tiny (,tmtex-tiny 1))
- (tiny (,tmtex-tiny 1))
- (really-small (,tmtex-scriptsize 1))
- (very-small (,tmtex-scriptsize 1))
- (smaller (,tmtex-footnotesize 1))
- (small (,tmtex-small 1))
- (flat-size (,tmtex-small 1))
- (normal-size (,tmtex-normalsize 1))
- (sharp-size (,tmtex-large 1))
- (large (,tmtex-large 1))
- (larger (,tmtex-Large 1))
- (very-large (,tmtex-LARGE 1))
- (really-large (,tmtex-LARGE 1))
- (really-huge (,tmtex-Huge 1))
- ((:or british
-    bulgarian
-    chinese
-    croatian
-    czech
-    danish
-    dutch
-    english
-    esperanto
-    finnish
-    french
-    german
-    greek
-    hungarian
-    italian
-    japanese
-    korean
-    polish
-    portuguese
-    romanian
-    russian
-    slovak
-    slovene
-    spanish
-    swedish
-    chineset
-    ukrainian
-  ) ;:or
-  (,tmtex-specific-language 1)
- ) ;
-
- (math (,tmtex-math 1))
- (text (,tmtex-text 1))
- (math-up (,tmtex-math-up 1))
- (math-ss (,tmtex-math-ss 1))
- (math-tt (,tmtex-math-tt 1))
- (math-bf (,tmtex-math-bf 1))
- (math-sl (,tmtex-math-sl 1))
- (math-it (,tmtex-math-it 1))
- (math-separator (,tmtex-mathpunct 1))
- (math-quantifier (,tmtex-mathord 1))
- (math-imply (,tmtex-mathbin 1))
- (math-or (,tmtex-mathbin 1))
- (math-and (,tmtex-mathbin 1))
- (math-not (,tmtex-mathord 1))
- (math-relation (,tmtex-mathrel 1))
- (math-union (,tmtex-mathbin 1))
- (math-intersection (,tmtex-mathbin 1))
- (math-exclude (,tmtex-mathbin 1))
- (math-plus (,tmtex-mathbin 1))
- (math-minus (,tmtex-mathbin 1))
- (math-times (,tmtex-mathbin 1))
- (math-over (,tmtex-mathbin 1))
- (math-big (,tmtex-mathop 1))
- (math-prefix (,tmtex-mathord 1))
- (math-postfix (,tmtex-mathord 1))
- (math-open (,tmtex-mathopen 1))
- (math-close (,tmtex-mathclose 1))
- (math-ordinary (,tmtex-mathord 1))
- (math-ignore (,tmtex-mathord 1))
- ((:or eqnarray
-    eqnarray*
-    leqnarray*
-    gather
-    multline
-    gather*
-    multline*
-    align
-    flalign
-    alignat
-    align*
-    flalign*
-    alignat*
-  ) ;:or
-  (,tmtex-eqnarray 1)
- ) ;
-
- (eq-number (,tmtex-default -1))
- (separating-space (,tmtex-hspace* 1))
- (application-space (,tmtex-hspace* 1))
-
- ((:or code cpp-code mmx-code scm-code shell-code scilab-code verbatim-code)
-  (,tmtex-code-block 1)
- ) ;
- ((:or mmx cpp scm shell scilab) (,tmtex-code-inline 1))
-
- (frame (,tmtex-frame 1))
- (colored-frame (,tmtex-colored-frame 2))
- (fcolorbox (,tmtex-fcolorbox 3))
- (rotate (,tmtex-rotate 2))
- (condensed (,tmtex-style-first 1))
- (translate (,tmtex-translate 3))
- (localize (,tmtex-localize 1))
- (render-key (,tmtex-render-key 1))
- (key (,tmtex-key 1))
- (key* (,tmtex-key* 1))
- (minipage (,tmtex-minipage 3))
- (latex_preview (,tmtex-mixed 2))
- (picture-mixed (,tmtex-mixed 2))
- (source-mixed (,tmtex-mixed 2))
- (listing (,tmtex-listing 1))
- (draw-over (,tmtex-make-eps 3))
- (draw-under (,tmtex-make-eps 3))
- (version-old (,tmtex-style-first 2))
- (version-both (,tmtex-style-second 2))
- (version-new (,tmtex-style-second 2))
- (the-index (,tmtex-theindex -1))
- (glossary (,tmtex-glossary 1))
- (glossary-explain (,tmtex-glossary 2))
- (glossary-2 (,tmtex-glossary-entry 3))
- (the-glossary (,tmtex-the-glossary 2))
- ((:or table-of-contents) (,tmtex-toc 2))
- (thebibliography (,tmtex-thebibliography 2))
- (bib-list (,tmtex-style-second 2))
- (bibitem* (,tmtex-bibitem* -1))
- ((:or small-figure big-figure small-table big-table) (,tmtex-figure 2))
- (item (,tmtex-item 0))
- (item* (,tmtex-item-arg 1))
- (render-proof (,tmtex-render-proof 2))
- (nbsp (,tmtex-nbsp 0))
- (nbhyph (,tmtex-nbhyph 0))
- (hrule (,tmtex-hrule 0))
- (frac* (,tmtex-frac* 2))
- (hlink (,tmtex-hlink 2))
- (action (,tmtex-action -1))
- (href (,tmtex-href 1))
- (slink (,tmtex-href 1))
- (eqref (,tmtex-eqref 1))
- (smart-ref (,tmtex-smart-ref -1))
- (choose (,tmtex-choose 2))
- (tt (,tmtex-text-tt 1))
- ((:or strong em name samp abbr dfn kbd var acronym person) (,tmtex-modifier 1))
- (render-line-number (,tmtex-render-line-number 2))
- (menu (,tmtex-menu -1))
- (with-TeXmacs-text (,(tmtex-rename 'withTeXmacstext) 0))
- (made-by-TeXmacs (,(tmtex-rename 'madebyTeXmacs) 0))
- (cite-website (,(tmtex-rename 'citewebsite) 0))
- (tm-made (,(tmtex-rename 'tmmade) 0))
- (cite (,tmtex-cite -1))
- (nocite (,tmtex-nocite -1))
- (cite-detail (,tmtex-cite-detail-hook 2))
- (cite-raw (,tmtex-cite-raw -1))
- (cite-raw* (,tmtex-cite-raw* -1))
- (cite-textual (,tmtex-cite-textual -1))
- (cite-textual* (,tmtex-cite-textual* -1))
- (cite-parenthesized (,tmtex-cite-parenthesized -1))
- (cite-parenthesized* (,tmtex-cite-parenthesized* -1))
- (citet (,tmtex-cite-textual -1))
- (citet* (,tmtex-cite-textual* -1))
- (citep (,tmtex-cite-parenthesized -1))
- (citep* (,tmtex-cite-parenthesized* -1))
- (render-cite (,tmtex-render-cite 1))
- ((:or cite-author cite-author-link) (,tmtex-cite-author 1))
- ((:or cite-author* cite-author*-link) (,tmtex-cite-author* 1))
- ((:or cite-year cite-year-link) (,tmtex-cite-year 1))
- (natbib-triple (,tmtex-natbib-triple 3))
- (natexlab (,tmtex-noop -1))
-
- ;; FIXME: we should do something more useful with this information
- (set-header (,tmtex-noop -1))
- (set-footer (,tmtex-noop -1))
- (set-this-page-header (,tmtex-noop -1))
- (set-this-page-footer (,tmtex-noop -1))
-) ;logic-table
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Tags which are customized in particular style files
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (style-dependent-declare x)
-  (with (tag fun narg)
-    x
-    (with fun+bis
-      (symbol-append fun '+bis)
-      (if (== narg 2)
-        `(begin
-           (when (not (defined? (quote ,fun)))
-             (tm-define (,fun s l) (tmtex-function (string->symbol s) l)))
-           (when (not (defined? (quote ,fun+bis)))
-             (tm-define (,fun+bis s l) (,fun s l))))
-        `(begin
-           (when (not (defined? (quote ,fun)))
-             (tm-define (,fun t)
-               (tmtex-function (string->symbol (car t)) (cdr t))))
-           (when (not (defined? (quote ,fun+bis)))
-             (tm-define (,fun+bis s l)
-               (,fun (append (list (string->symbol s)) l)))))
-      ) ;if
-    ) ;with
-  ) ;with
-) ;tm-define
-
-(tm-define (style-dependent-transform x)
-  (with (tag fun narg)
-    x
-    (with fun+bis (symbol-append fun '+bis) `(,tag
-                                              (,(list 'unquote fun+bis) ,-1)))
-  ) ;with
-) ;tm-define
-
-(define-macro (tmtex-style-dependent . l)
-  `(begin
-     ,@(map style-dependent-declare l)
-     (logic-table tmtex-tmstyle% ,@(map style-dependent-transform l)))
-) ;define-macro
-
-(tmtex-style-dependent
-  ;; to be removed
-  (doc-data tmtex-doc-data 2)
-  (abstract-data tmtex-abstract-data 2)
-  ;; abstract markup
-  (abstract tmtex-abstract 1)
-  (abstract-acm tmtex-abstract-acm 1)
-  (abstract-arxiv tmtex-abstract-arxiv 1)
-  (abstract-msc tmtex-abstract-msc 1)
-  (abstract-pacs tmtex-abstract-pacs 1)
-  (abstract-keywords tmtex-abstract-keywords 1)
-  ;; metadata markup
-  (doc-title tmtex-doc-title 1)
-  (doc-running-title tmtex-doc-running-title 1)
-  (doc-subtitle tmtex-doc-subtitle 1)
-  (doc-note tmtex-doc-note 1)
-  (doc-misc tmtex-doc-misc 1)
-  (doc-date tmtex-doc-date 1)
-  (doc-running-author tmtex-doc-running-author 1)
-  (doc-author tmtex-doc-author 1)
-  (author-name tmtex-author-name 1)
-  (author-affiliation tmtex-author-affiliation 1)
-  (author-misc tmtex-author-misc 1)
-  (author-note tmtex-author-note 1)
-  (author-email tmtex-author-email 1)
-  (author-homepage tmtex-author-homepage 1)
-  ;; references
-  (doc-subtitle-ref tmtex-doc-subtitle-ref 2)
-  (doc-date-ref tmtex-doc-date-ref 2)
-  (doc-note-ref tmtex-doc-note-ref 2)
-  (doc-misc-ref tmtex-doc-misc-ref 2)
-  (author-affiliation-ref tmtex-author-affiliation-ref 2)
-  (author-email-ref tmtex-author-email-ref 2)
-  (author-homepage-ref tmtex-author-homepage-ref 2)
-  (author-note-ref tmtex-author-note-ref 2)
-  (author-misc-ref tmtex-author-misc-ref 2)
-  ;; labels
-  (doc-subtitle-label tmtex-doc-subtitle-label 2)
-  (doc-date-label tmtex-doc-date-label 2)
-  (doc-note-label tmtex-doc-note-label 2)
-  (doc-misc-label tmtex-doc-misc-label 2)
-  (author-affiliation-label tmtex-author-affiliation-label 2)
-  (author-email-label tmtex-author-email-label 2)
-  (author-homepage-label tmtex-author-homepage-label 2)
-  (author-note-label tmtex-author-note-label 2)
-  (author-misc-label tmtex-author-misc-label 2)
-  ;; misc
-  ((:or equation equation*) tmtex-equation 2)
-  (bibliography tmtex-bib 4)
-  (elsevier-frontmatter tmtex-elsevier-frontmatter 2)
-  (conferenceinfo tmtex-acm-conferenceinfo 2)
-  (CopyrightYear tmtex-acm-copyright-year 2)
-  (slide tmtex-beamer-slide 2)
-  (tit tmtex-beamer-tit 2)
-  (crdata tmtex-acm-crdata 2)
-) ;tmtex-style-dependent
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Protected tags
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(logic-group tmtex-protected%
-  a
-  b
-  c
-  d
-  i
-  j
-  k
-  l
-  o
-  r
-  t
-  u
-  v
-  H
-  L
-  O
-  P
-  S
-  aa
-  ae
-  bf
-  cr
-  dh
-  dj
-  dp
-  em
-  fi
-  ge
-  gg
-  ht
-  if
-  in
-  it
-  le
-  lg
-  ll
-  lu
-  lq
-  mp
-  mu
-  ne
-  ng
-  ni
-  nu
-  oe
-  or
-  pi
-  pm
-  rm
-  rq
-  sb
-  sc
-  sf
-  sl
-  sp
-  ss
-  th
-  tt
-  wd
-  wp
-  wr
-  xi
-  AA
-  AE
-  DH
-  DJ
-  Im
-  NG
-  OE
-  Pi
-  Pr
-  Re
-  SS
-  TH
-  Xi
-) ;logic-group
-
-(logic-group tmtex-protected-symbol% space)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Expansion of all macros which are not recognized by LaTeX
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define tmtex-user-defs-table (make-ahash-table))
-
-(define (user-definition? x)
-  (or (and (func? x 'new-theorem 2) (string? (cadr x)))
-    (and (func? x 'assign 2) (string? (cadr x)))
-  ) ;or
-) ;define
-
-(define (collect-user-defs-sub t)
-  (cond ((npair? t) (noop))
-        ((user-definition? t)
-         (ahash-set! tmtex-user-defs-table (string->symbol (cadr t)) #t)
-        ) ;
-        (else (for-each collect-user-defs-sub (cdr t)))
-  ) ;cond
-) ;define
-
-(define (collect-user-defs t)
-  (set! tmtex-user-defs-table (make-ahash-table))
-  (collect-user-defs-sub (cons 'document (tmtex-filter-preamble t)))
-  (ahash-set->list tmtex-user-defs-table)
-) ;define
-
-(define (as-string sym)
-  (with s
-    (symbol->string sym)
-    (if (string-starts? s "begin-") (substring s 6 (string-length s)) s)
-  ) ;with
-) ;define
-
-(define (logic-first-list name)
-  (let* ((l1 (query (cons name '('first 'second))))
-         (l2 (map (cut assoc-ref <> 'first) l1))
-        ) ;
-    (map as-string l2)
-  ) ;let*
-) ;define
-
-(define (collect-user-macros-in t h)
-  (when (tm-compound? t)
-    (when (tree-label-extension? (tm-label t))
-      (ahash-set! h (symbol->string (tm-label t)) #t)
-    ) ;when
-    (for-each (cut collect-user-macros-in <> h) (tm-children t))
-  ) ;when
-) ;define
-
-(define (collect-user-macros t)
-  (with h (make-ahash-table) (collect-user-macros-in t h) (ahash-set->list h))
-) ;define
-
-(define (tmtex-env-macro name)
-  `(associate ,name (xmacro "x" (eval-args "x")))
-) ;define
-
-(define tmtex-always-expand
-  ;; FIXME: find a cleaner way to handle these environments
-  (list "render-theorem"
-    "render-remark"
-    "render-exercise"
-    "render-proof"
-    "algorithm"
-    "algorithm*"
-    "named-algorithm"
-    "named-algorithm-old"
-    "specified-algorithm"
-    "specified-algorithm*"
-    "named-specified-algorithm"
-    "algorithm-body"
-    "numbered"
-
-    "short-item"
-    "short-question"
-    "question-arabic"
-    "question-alpha"
-    "question-Alpha"
-    "question-roman"
-    "question-Roman"
-    "question-item"
-    "answer-arabic"
-    "answer-alpha"
-    "answer-Alpha"
-    "answer-roman"
-    "answer-Roman"
-    "answer-item"
-
-    "gap"
-    "gap-dots"
-    "gap-underlined"
-    "gap-box"
-    "gap-wide"
-    "gap-dots-wide"
-    "gap-underlined-wide"
-    "gap-box-wide"
-    "gap-long"
-    "gap-dots-long"
-    "gap-underlined-long"
-    "gap-box-long"
-
-    "with-button-box"
-    "with-button-box*"
-    "with-button-circle"
-    "with-button-circle*"
-    "with-button-arabic"
-    "with-button-alpha"
-    "with-button-Alpha"
-    "with-button-roman"
-    "with-button-Roman"
-    "mc-field"
-    "mc-wide-field"
-    "show-reply"
-    "hide-reply"
-    "mc"
-    "mc-monospaced"
-    "mc-horizontal"
-    "mc-vertical"
-
-    "textual-table"
-    "numeric-dot-table"
-    "calc-table"
-    "calc-inert"
-    "calc-input"
-    "calc-output"
-    "calc-ref"
-    "cell-inert"
-    "cell-input"
-    "cell-output"
-    "cell-ref"
-    "cell-range"
-    "cell-sum"
-    "cell-plusses"
-    "cell-commas"
-
-    "tmdoc-title"
-    "icon"
-    "shortcut"
-    "key"
-    "prefix"
-    "menu"
-    "render-menu"
-    "submenu"
-    "subsubmenu"
-    "subsubsubmenu"
-    "markup"
-    "tmstyle"
-    "tmpackage"
-    "tmdtd"
-    "def-index"
-    "src-arg"
-    "src-var"
-    "scm-arg"
-    "scm-args"
-    "descriptive-table"
-    "tm-fragment"
-    "framed-fragment"
-    "explain"
-    "explain-synopsis"
-    "explain-macro"
-    "small-envbox"
-    "big-envbox"
-    "small-focus"
-    "big-focus"
-    "cursor"
-    "math-cursor"
-    "TeXmacs-version"
-    "c++"
-    "BibTeX"
-  ) ;list
-) ;define
-
-(tm-define (tmtex-env-patch t l0)
-  (let* ((st (tree->stree t))
-         (l0 (logic-first-list 'tmtex-primitives%))
-         (l1 (logic-first-list 'tmtex-extra-methods%))
-         (l2 (logic-first-list 'tmtex-tmstyle%))
-         (l3 (map as-string (logic-apply-list '(latex-tag%))))
-         (l4 (map as-string (logic-apply-list '(latex-symbol%))))
-         (l5 (list-difference l3 (list-union l4 tmtex-always-expand)))
-         (l6 (map as-string (collect-user-defs st)))
-         (l7 (if (preference-on? "texmacs->latex:expand-user-macros") '() l6))
-         (l8 (list-difference (collect-user-macros st)
-               (list-union l0 l6 tmtex-always-expand)
-             ) ;list-difference
-         ) ;l8
-         (l9 (list-difference (list-union l1 l2 l5 l7 l8) l0))
-         (l10 (list-filter l0 (lambda (s) (and (string? s) (<= (string-length s) 2)))))
-         (l11 (list-difference l10 (list "tt" "em" "op")))
-         (l12 (list-difference l9 l11))
-        ) ;
-    `(collection ,@(map tmtex-env-macro l12))
-  ) ;let*
-) ;tm-define
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Interface
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (tmtex-get-style sty)
-  (cond ((not sty) (set! sty (list "article")))
-        ((string? sty) (set! sty (list sty)))
-        ((func? sty 'tuple) (set! sty (cdr sty)))
-        ((null? sty) (set! sty '("article")))
-  ) ;cond
-  sty
-) ;define
-
-(tm-define (tmtex-postprocess x) x)
-(tm-define (tmtex-postprocess-body x) x)
-
-(tm-define (texmacs->latex x opts)
-  ;; (display* "texmacs->latex [" opts "], " x "\n")
-  (if (tmfile? x)
-    (let* ((body (tmfile-extract x 'body))
-           (style (tmtex-get-style (tmfile-extract x 'style)))
-           (main-style (or (tmtex-transform-style (car style)) "article"))
-           (lan (tmfile-language x))
-           (init (tmfile-extract x 'initial))
-           (att (tmfile-extract x 'attachments))
-           (doc (list '!file body style lan init att (url->string (get-texmacs-path))))
-          ) ;
-      (set! tmtex-cjk-document? (in? lan '("chinese"
-                                           "chineset"
-                                           "japanese"
-                                           "korean")))
-      (latex-set-style main-style)
-      (latex-set-packages '())
-      (latex-set-extra '())
-      (set! tmtex-style (car style))
-      (set! tmtex-packages (cdr style))
-      (set! tmtex-languages (list lan))
-      (set! tmtex-colors '())
-      (set! tmtex-colormaps '())
-      (import-tmtex-styles)
-      (tmtex-style-init body)
-      (set! doc (tmtex-style-preprocess doc))
-      (with result
-        (tmtex-postprocess (texmacs->latex doc opts))
-        (set! tmtex-style "generic")
-        (set! tmtex-packages '())
-        result
-      ) ;with
-    ) ;let*
-    (let* ((x2 (tree->stree (tmtm-eqnumber->nonumber (stree->tree x))))
-           (x3 (tmtm-match-brackets x2))
-          ) ;
-      (tmtex-initialize opts)
-      (set! tmtex-image-total (tmtex-count-images x3))
-      (set! tmtex-progress?
-        (and (qt-gui?)
-          (== (assoc-ref opts "texmacs->latex:progress") "on")
-          (> tmtex-image-total 0)
-        ) ;and
-      ) ;set!
-      (when tmtex-progress?
-        (latex-progress-start tmtex-image-total)
-      ) ;when
-      (with r
-        (tmtex (tmpre-produce x3))
-        (if tmtex-mathjax? (set! r (latex-mathjax-pre r)))
-        (if (not tmtex-use-macros?) (set! r (latex-expand-macros r)))
-        (if tmtex-mathjax? (set! r (latex-mathjax r)))
-        (when tmtex-progress?
-          (latex-progress-end)
-          (set! tmtex-progress? #f)
-        ) ;when
-        r
-      ) ;with
-    ) ;let*
-  ) ;if
-) ;tm-define
diff --git a/TeXmacs/plugins/latex/progs/data/bibtex.scm b/TeXmacs/plugins/latex/progs/data/bibtex.scm
deleted file mode 100644
index eb1cd76980..0000000000
--- a/TeXmacs/plugins/latex/progs/data/bibtex.scm
+++ /dev/null
@@ -1,76 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : bibtex.scm
-;; DESCRIPTION : bibtex data plugin
-;; COPYRIGHT   : (C) 2010, 2014  David MICHEL and Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (data bibtex))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Raw BibTeX, as implemented by David Michel
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define-format bibtex
-  (:name "RawBibTeX")
-  (:suffix "rawbib")
-  (:hidden))
-
-(lazy-define (convert bibtex bibtextm) parse-bibtex-snippet)
-(lazy-define (convert bibtex bibtextm) parse-bibtex-document)
-(lazy-define (convert bibtex bibtextm) bibtex->texmacs)
-(lazy-define (convert bibtex bibtexout) serialize-bibtex)
-(lazy-define (convert bibtex tmbibtex) texmacs->bibtex)
-
-(converter bibtex-snippet bibtex-stree
-  (:function parse-bibtex-snippet))
-
-(converter bibtex-document bibtex-stree
-  (:function parse-bibtex-document))
-
-(converter bibtex-stree texmacs-stree
-  (:function bibtex->texmacs))
-
-(converter bibtex-stree bibtex-document
-  (:function serialize-bibtex))
-
-(converter bibtex-stree bibtex-snippet
-  (:function serialize-bibtex))
-
-(converter texmacs-stree bibtex-stree
-  (:function texmacs->bibtex))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; BibTeX, presented using the TeXmacs database format
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define-format tmbib
-  (:name "BibTeX")
-  (:suffix "bib"))
-
-(lazy-define (database bib-db) tmbib-snippet->texmacs)
-(lazy-define (database bib-db) tmbib-document->texmacs)
-(lazy-define (database bib-db) texmacs->tmbib-snippet)
-(lazy-define (database bib-db) texmacs->tmbib-document)
-
-(converter tmbib-snippet texmacs-stree
-  (:function tmbib-snippet->texmacs))
-
-(converter tmbib-document texmacs-stree
-  (:function tmbib-document->texmacs))
-
-(converter texmacs-stree tmbib-snippet
-  (:function texmacs->tmbib-snippet))
-
-(converter texmacs-stree tmbib-document
-  (:function texmacs->tmbib-document))
-
-(define-preferences
-  ("bibtex->texmacs:conservative" "on" noop)
-  ("texmacs->bibtex:conservative" "on" noop))
diff --git a/TeXmacs/plugins/latex/progs/data/latex.scm b/TeXmacs/plugins/latex/progs/data/latex.scm
deleted file mode 100644
index bfb318e840..0000000000
--- a/TeXmacs/plugins/latex/progs/data/latex.scm
+++ /dev/null
@@ -1,907 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : init-latex.scm
-;; DESCRIPTION : setup latex converters
-;; COPYRIGHT   : (C) 2003  Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (data latex))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; LaTeX format
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (string-split-lines s)
-  (let ((len (if (>= (string-length s) 1000) 1000 (string-length s))))
-    (let loop
-      ((i 0) (start 0) (result '()))
-      (cond ((>= i len) (reverse (cons (substring s start i) result)))
-            ((char=? (string-ref s i) #\newline)
-             (loop (+ i 1) (+ i 1) (cons (substring s start i) result))
-            ) ;
-            (else (loop (+ i 1) start result))
-      ) ;cond
-    ) ;let
-  ) ;let
-) ;define
-
-(define (backslash-from-string s)
-  (if (not (string-null? s))
-    (let* ((len (string-length s)) (limit (if (>= len 1000) 1000 len)))
-      (let loop
-        ((ref 0) (count 0))
-        (if (>= ref limit)
-          (/ count len)
-          (loop (+ ref 1) (if (char=? (string-ref s ref) #\\) (+ count 1) count))
-        ) ;if
-      ) ;let
-    ) ;let*
-    #f
-  ) ;if
-) ;define
-
-(define (backslash-line-from-string s)
-  (let ((lines (string-split-lines s)))
-    (if (null? lines)
-      0
-      (let loop
-        ((count-lines 0) (count 0) (remaining-lines lines))
-        (if (null? remaining-lines)
-          (if (> count-lines 0) (/ count count-lines) 0)
-          (let ((line (car remaining-lines)))
-            (loop (+ count-lines 1)
-              (if (string-contains? line "\\") (+ count 1) count)
-              (cdr remaining-lines)
-            ) ;loop
-          ) ;let
-        ) ;if
-      ) ;let
-    ) ;if
-  ) ;let
-) ;define
-
-(define (parentheses-from-string s)
-  (if (not (string-null? s))
-    (let* ((len (string-length s)) (limit (if (>= len 1000) 1000 len)))
-      (let loop
-        ((ref 0) (count 0))
-        (if (>= ref limit)
-          (/ count len)
-          (loop (+ ref 1)
-            (if (or (char=? (string-ref s ref) (string-ref "{" 0))
-                  (char=? (string-ref s ref) (string-ref "}" 0))
-                ) ;or
-              (+ count 1)
-              count
-            ) ;if
-          ) ;loop
-        ) ;if
-      ) ;let
-    ) ;let*
-    #f
-  ) ;if
-) ;define
-
-(define (determine-short-string s)
-  (let* ((len (string-length s)))
-    (cond ((and (> len 2)
-             (char=? (string-ref s 0) #\$)
-             (char=? (string-ref s (- len 1)) #\$)
-           ) ;and
-           #t
-          ) ;
-          ((>= (backslash-from-string s) 0.02) #t)
-          (else #f)
-    ) ;cond
-  ) ;let*
-) ;define
-
-(define (is-short-latex-string? s)
-  (if (<= (string-length s) 50) (determine-short-string s) #f)
-) ;define
-
-(define (is-latex-string? s)
-  (let ((percent-slash (backslash-from-string s)))
-    (if (and (>= percent-slash 0.01) (<= percent-slash 0.25))
-      (let ((percent-parentheses (parentheses-from-string s)))
-        (if (>= percent-parentheses 0.01)
-          (let ((percent-backslash-line (backslash-line-from-string s)))
-            (if (>= percent-backslash-line 0.25) #t #f)
-          ) ;let
-          #f
-        ) ;if
-      ) ;let
-      #f
-    ) ;if
-  ) ;let
-) ;define
-
-(define (latex-recognizes-at? s pos)
-  (set! pos (format-skip-spaces s pos))
-  (cond ((format-test? s pos "\\document") #t)
-        ((format-test? s pos "\\documentclass") #t)
-        ((format-test? s pos "\\usepackage") #t)
-        ((format-test? s pos "\\title") #t)
-        ((format-test? s pos "\\newcommand") #t)
-        ((format-test? s pos "\\input") #t)
-        ((format-test? s pos "\\includeonly") #t)
-        ((format-test? s pos "\\chapter") #t)
-        ((format-test? s pos "\\appendix") #t)
-        ((format-test? s pos "\\section") #t)
-        ((format-test? s pos "\\footnote") #t)
-        ((format-test? s pos "\\marginpar") #t)
-        ((format-test? s pos "\\begin") #t)
-        ((format-test? s pos "\\end") #t)
-        ((format-test? s pos "\\begin{") #t)
-        ((format-test? s pos "\\end{") #t)
-        ((format-test? s pos "\\alpha") #t)
-        ((format-test? s pos "\\beta") #t)
-        ((format-test? s pos "\\gamma") #t)
-        ((format-test? s pos "\\ref") #t)
-        ((format-test? s pos "\\textbf") #t)
-        ((format-test? s pos "\\textit") #t)
-        ((format-test? s pos "\\mathbb") #t)
-        ((format-test? s pos "\\mathcal") #t)
-        ((format-test? s pos "\\frac") #t)
-        ((format-test? s pos "\\cite") #t)
-        ((format-test? s pos "\\item") #t)
-        ((format-test? s pos "\\[") #t)
-        ((format-test? s pos "\\(") #t)
-        ((is-short-latex-string? s) #t)
-        ((is-latex-string? s) #t)
-        (else #f)
-  ) ;cond
-) ;define
-
-(define (latex-recognizes? s)
-  (and (string? s) (latex-recognizes-at? s 0))
-) ;define
-
-(define-format latex
-  (:name "LaTeX")
-  (:suffix "tex")
-  (:recognize latex-recognizes?)
-) ;define-format
-
-(define-format latex-class (:name "LaTeX class") (:suffix "ltx" "sty" "cls"))
-
-(define-preferences ("texmacs->latex:transparent-tracking" "on" noop))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; TeXmacs->LaTeX
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(lazy-define (convert latex texout) serialize-latex)
-(lazy-define (convert latex tmtex) texmacs->latex)
-
-(converter texmacs-stree
-  latex-stree
-  (:function-with-options texmacs->latex)
-  (:option "texmacs->latex:source-tracking" "off")
-  (:option "texmacs->latex:conservative" "on")
-  (:option "texmacs->latex:transparent-source-tracking" "on")
-  (:option "texmacs->latex:attach-tracking-info" "on")
-  (:option "texmacs->latex:replace-style" "on")
-  (:option "texmacs->latex:expand-macros" "on")
-  (:option "texmacs->latex:expand-user-macros" "off")
-  (:option "texmacs->latex:indirect-bib" "off")
-  (:option "texmacs->latex:use-macros" "off")
-  (:option "texmacs->latex:encoding" "UTF-8")
-) ;converter
-
-(converter latex-stree latex-document (:function serialize-latex))
-
-(converter latex-stree latex-snippet (:function serialize-latex))
-
-(tm-define (texmacs->latex-document x opts)
-  (serialize-latex (texmacs->latex (tm->stree x) opts))
-) ;tm-define
-
-(converter texmacs-stree
-  latex-document
-  (:function-with-options conservative-texmacs->latex)
-  ;; (:function-with-options tracked-texmacs->latex)
-  (:option "texmacs->latex:source-tracking" "off")
-  (:option "texmacs->latex:conservative" "on")
-  (:option "texmacs->latex:transparent-source-tracking" "on")
-  (:option "texmacs->latex:attach-tracking-info" "on")
-  (:option "texmacs->latex:replace-style" "on")
-  (:option "texmacs->latex:expand-macros" "on")
-  (:option "texmacs->latex:expand-user-macros" "off")
-  (:option "texmacs->latex:indirect-bib" "off")
-  (:option "texmacs->latex:use-macros" "on")
-  (:option "texmacs->latex:encoding" "UTF-8")
-) ;converter
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; LaTeX -> TeXmacs
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (latex-document->texmacs x . opts)
-  (if (list-1? opts) (set! opts (car opts)))
-  (with as-pic
-    (== (get-preference "latex->texmacs:fallback-on-pictures") "on")
-    (conservative-latex->texmacs x as-pic)
-  ) ;with
-) ;tm-define
-
-(converter latex-document latex-tree (:function parse-latex-document))
-
-(converter latex-snippet latex-tree (:function parse-latex))
-
-(converter latex-class-document
-  texmacs-tree
-  (:function latex-class-document->texmacs)
-) ;converter
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Post-processing imported LaTeX: insert space between d and differential
-;; variables so they are not merged into a single operator in math mode.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (is-letter-char? c)
-  (and (char? c)
-    (or (and (char>=? c #\a) (char<=? c #\z)) (and (char>=? c #\A) (char<=? c #\Z)))
-  ) ;and
-) ;define
-
-(define (is-word-boundary-before? s i)
-  (or (= i 0) (not (is-letter-char? (string-ref s (- i 1)))))
-) ;define
-
-(define (is-word-boundary-after? s i)
-  (or (= i (- (string-length s) 1))
-    (not (is-letter-char? (string-ref s (+ i 1))))
-  ) ;or
-) ;define
-
-(define (match-differential s i)
-  (and (< i (- (string-length s) 1))
-    (char=? (string-ref s i) #\d)
-    (char=? (string-ref s (+ i 1)) #\*)
-    (let ((rest (substring s (+ i 2) (string-length s))))
-      (cond ((or (string-starts? rest "x")
-               (string-starts? rest "y")
-               (string-starts? rest "z")
-               (string-starts? rest "r")
-               (string-starts? rest "t")
-               (string-starts? rest "u")
-               (string-starts? rest "v")
-               (string-starts? rest "w")
-             ) ;or
-             (cons 1 (substring rest 0 1))
-            ) ;
-            ((string-starts? rest "") (cons 5 ""))
-            ((string-starts? rest "") (cons 8 ""))
-            ((string-starts? rest "") (cons 7 ""))
-            ((string-starts? rest "") (cons 10 ""))
-            ((string-starts? rest "") (cons 5 ""))
-            ((string-starts? rest "") (cons 9 ""))
-            ((string-starts? rest "") (cons 5 ""))
-            ((string-starts? rest "") (cons 8 ""))
-            ((string-starts? rest "") (cons 7 ""))
-            (else #f)
-      ) ;cond
-    ) ;let
-  ) ;and
-) ;define
-
-(define (match-math-index-combination s i)
-  (let ((rest (substring s i (string-length s))))
-    (cond ((or (string-starts? rest "i*j*k") (string-starts? rest "ijk"))
-           (let ((len (if (string-starts? rest "i*j*k") 5 3)))
-             (and (is-word-boundary-before? s i)
-               (is-word-boundary-after? s (+ i (- len 1)))
-               (cons len '("i" " " "j" " " "k"))
-             ) ;and
-           ) ;let
-          ) ;
-          ((or (string-starts? rest "x*y*z") (string-starts? rest "xyz"))
-           (let ((len (if (string-starts? rest "x*y*z") 5 3)))
-             (and (is-word-boundary-before? s i)
-               (is-word-boundary-after? s (+ i (- len 1)))
-               (cons len '("x" " " "y" " " "z"))
-             ) ;and
-           ) ;let
-          ) ;
-          ((or (string-starts? rest "i*j") (string-starts? rest "ij"))
-           (let ((len (if (string-starts? rest "i*j") 3 2)))
-             (and (is-word-boundary-before? s i)
-               (is-word-boundary-after? s (+ i (- len 1)))
-               (cons len '("i" " " "j"))
-             ) ;and
-           ) ;let
-          ) ;
-          ((or (string-starts? rest "j*k") (string-starts? rest "jk"))
-           (let ((len (if (string-starts? rest "j*k") 3 2)))
-             (and (is-word-boundary-before? s i)
-               (is-word-boundary-after? s (+ i (- len 1)))
-               (cons len '("j" " " "k"))
-             ) ;and
-           ) ;let
-          ) ;
-          ((or (string-starts? rest "k*l") (string-starts? rest "kl"))
-           (let ((len (if (string-starts? rest "k*l") 3 2)))
-             (and (is-word-boundary-before? s i)
-               (is-word-boundary-after? s (+ i (- len 1)))
-               (cons len '("k" " " "l"))
-             ) ;and
-           ) ;let
-          ) ;
-          ((or (string-starts? rest "l*m") (string-starts? rest "lm"))
-           (let ((len (if (string-starts? rest "l*m") 3 2)))
-             (and (is-word-boundary-before? s i)
-               (is-word-boundary-after? s (+ i (- len 1)))
-               (cons len '("l" " " "m"))
-             ) ;and
-           ) ;let
-          ) ;
-          ((or (string-starts? rest "m*n") (string-starts? rest "mn"))
-           (let ((len (if (string-starts? rest "m*n") 3 2)))
-             (and (is-word-boundary-before? s i)
-               (is-word-boundary-after? s (+ i (- len 1)))
-               (cons len '("m" " " "n"))
-             ) ;and
-           ) ;let
-          ) ;
-          ((or (string-starts? rest "p*q") (string-starts? rest "pq"))
-           (let ((len (if (string-starts? rest "p*q") 3 2)))
-             (and (is-word-boundary-before? s i)
-               (is-word-boundary-after? s (+ i (- len 1)))
-               (cons len '("p" " " "q"))
-             ) ;and
-           ) ;let
-          ) ;
-          ((or (string-starts? rest "r*s") (string-starts? rest "rs"))
-           (let ((len (if (string-starts? rest "r*s") 3 2)))
-             (and (is-word-boundary-before? s i)
-               (is-word-boundary-after? s (+ i (- len 1)))
-               (cons len '("r" " " "s"))
-             ) ;and
-           ) ;let
-          ) ;
-          ((or (string-starts? rest "x*y") (string-starts? rest "xy"))
-           (let ((len (if (string-starts? rest "x*y") 3 2)))
-             (and (is-word-boundary-before? s i)
-               (is-word-boundary-after? s (+ i (- len 1)))
-               (cons len '("x" " " "y"))
-             ) ;and
-           ) ;let
-          ) ;
-          ((or (string-starts? rest "a*b") (string-starts? rest "ab"))
-           (let ((len (if (string-starts? rest "a*b") 3 2)))
-             (and (is-word-boundary-before? s i)
-               (is-word-boundary-after? s (+ i (- len 1)))
-               (cons len '("a" " " "b"))
-             ) ;and
-           ) ;let
-          ) ;
-          ((or (string-starts? rest "c*d") (string-starts? rest "cd"))
-           (let ((len (if (string-starts? rest "c*d") 3 2)))
-             (and (is-word-boundary-before? s i)
-               (is-word-boundary-after? s (+ i (- len 1)))
-               (cons len '("c" " " "d"))
-             ) ;and
-           ) ;let
-          ) ;
-          ((or (string-starts? rest "u*v") (string-starts? rest "uv"))
-           (let ((len (if (string-starts? rest "u*v") 3 2)))
-             (and (is-word-boundary-before? s i)
-               (is-word-boundary-after? s (+ i (- len 1)))
-               (cons len '("u" " " "v"))
-             ) ;and
-           ) ;let
-          ) ;
-          (else #f)
-    ) ;cond
-  ) ;let
-) ;define
-
-(define (transform-math-string s)
-  (let* ((n (string-length s)) (res '()))
-    (let loop
-      ((i 0) (last-idx 0))
-      (cond ((>= i n)
-             (if (null? res)
-               s
-               (begin
-                 (if (< last-idx n) (set! res (append res (list (substring s last-idx n)))))
-                 (cons 'concat res)
-               ) ;begin
-             ) ;if
-            ) ;
-            (else (let ((idx-match (match-math-index-combination s i)))
-                    (if idx-match
-                      (let* ((match-len (car idx-match)) (chars (cdr idx-match)))
-                        (if (> i last-idx) (set! res (append res (list (substring s last-idx i)))))
-                        (set! res (append res chars))
-                        (loop (+ i match-len) (+ i match-len))
-                      ) ;let*
-                      (let ((diff-match (match-differential s i)))
-                        (if (and diff-match
-                              (is-word-boundary-before? s i)
-                              (is-word-boundary-after? s (+ i 1 (car diff-match)))
-                            ) ;and
-                          (let* ((match-len (car diff-match)) (var (cdr diff-match)))
-                            (if (> i last-idx) (set! res (append res (list (substring s last-idx i)))))
-                            (set! res (append res (list "d" " " var)))
-                            (loop (+ i 2 match-len) (+ i 2 match-len))
-                          ) ;let*
-                          (loop (+ i 1) last-idx)
-                        ) ;if
-                      ) ;let
-                    ) ;if
-                  ) ;let
-            ) ;else
-      ) ;cond
-    ) ;let
-  ) ;let*
-) ;define
-
-(define (transform-concat-children children)
-  (cond ((null? children) '())
-        ((and (pair? children) (pair? (cdr children)))
-         (let* ((c1 (car children)) (c2 (cadr children)))
-           (if (and (string? c1)
-                 (string? c2)
-                 (or (string=? c2 "")
-                   (string=? c2 "")
-                   (string=? c2 "")
-                   (string=? c2 "")
-                   (string=? c2 "")
-                   (string=? c2 "")
-                   (string=? c2 "")
-                   (string=? c2 "")
-                   (string=? c2 "")
-                 ) ;or
-                 (let ((len (string-length c1)))
-                   (and (> len 0)
-                     (char=? (string-ref c1 (- len 1)) #\d)
-                     (or (= len 1) (not (is-letter-char? (string-ref c1 (- len 2)))))
-                   ) ;and
-                 ) ;let
-               ) ;and
-             (let* ((len (string-length c1))
-                    (prefix (if (> len 1) (substring c1 0 (- len 1)) #f))
-                    (spaced-part (if prefix (list prefix "d" " " c2) (list "d" " " c2)))
-                   ) ;
-               (append spaced-part (transform-concat-children (cddr children)))
-             ) ;let*
-             (cons (car children) (transform-concat-children (cdr children)))
-           ) ;if
-         ) ;let*
-        ) ;
-        (else children)
-  ) ;cond
-) ;define
-
-(define math-environments
-  '(math equation equation* eqnarray eqnarray* align align* multline multline*)
-) ;define
-
-(define (upgrade-latex-differentials-stree t in-math)
-  (cond ((string? t) (if in-math (transform-math-string t) t))
-        ((pair? t)
-         (let* ((head (car t)) (next-in-math (or in-math (memq head math-environments))))
-           (if (and next-in-math (eq? head 'concat))
-             (let* ((new-children (map (lambda (x) (upgrade-latex-differentials-stree x #t)) (cdr t))
-                    ) ;new-children
-                    (transformed-children (transform-concat-children new-children))
-                   ) ;
-               (cons 'concat transformed-children)
-             ) ;let*
-             (cons head
-               (map (lambda (x) (upgrade-latex-differentials-stree x next-in-math)) (cdr t))
-             ) ;cons
-           ) ;if
-         ) ;let*
-        ) ;
-        (else t)
-  ) ;cond
-) ;define
-
-(define (has-cwith-property? options
-          row-start
-          row-end
-          col-start
-          col-end
-          property
-          value-pred
-        ) ;has-cwith-property?
-  (cond ((null? options) #f)
-        ((and (pair? (car options)) (eq? (caar options) 'cwith))
-         (let* ((opt (car options))
-                (r-start (and (> (length opt) 1) (list-ref opt 1)))
-                (r-end (and (> (length opt) 2) (list-ref opt 2)))
-                (c-start (and (> (length opt) 3) (list-ref opt 3)))
-                (c-end (and (> (length opt) 4) (list-ref opt 4)))
-                (prop (and (> (length opt) 5) (list-ref opt 5)))
-                (val (and (> (length opt) 6) (list-ref opt 6)))
-               ) ;
-           (if (and (or (not row-start) (equal? r-start row-start))
-                 (or (not row-end) (equal? r-end row-end))
-                 (or (not col-start) (equal? c-start col-start))
-                 (or (not col-end) (equal? c-end col-end))
-                 (or (not property) (equal? prop property))
-                 (and val (value-pred val))
-               ) ;and
-             #t
-             (has-cwith-property? (cdr options)
-               row-start
-               row-end
-               col-start
-               col-end
-               property
-               value-pred
-             ) ;has-cwith-property?
-           ) ;if
-         ) ;let*
-        ) ;
-        (else (has-cwith-property? (cdr options)
-                row-start
-                row-end
-                col-start
-                col-end
-                property
-                value-pred
-              ) ;has-cwith-property?
-        ) ;else
-  ) ;cond
-) ;define
-
-(define (find-table-num-rows children)
-  (cond ((null? children) 0)
-        ((and (pair? (car children)) (eq? (caar children) 'table))
-         (length (cdar children))
-        ) ;
-        (else (find-table-num-rows (cdr children)))
-  ) ;cond
-) ;define
-
-(define (is-three-line-table-tformat? x)
-  (if (and (pair? x) (eq? (car x) 'tformat))
-    (let* ((options (cdr x)) (num-rows (find-table-num-rows options)))
-      (if (> num-rows 0)
-        (let* ((has-top? (has-cwith-property? options
-                           "1"
-                           "1"
-                           #f
-                           #f
-                           "cell-tborder"
-                           (lambda (v) (not (equal? v "0ln")))
-                         ) ;has-cwith-property?
-               ) ;has-top?
-               (has-bottom? (has-cwith-property? options
-                              (number->string num-rows)
-                              (number->string num-rows)
-                              #f
-                              #f
-                              "cell-bborder"
-                              (lambda (v) (not (equal? v "0ln")))
-                            ) ;has-cwith-property?
-               ) ;has-bottom?
-               (has-vertical? (has-cwith-property? options
-                                #f
-                                #f
-                                #f
-                                #f
-                                "cell-lborder"
-                                (lambda (v) (not (equal? v "0ln")))
-                              ) ;has-cwith-property?
-               ) ;has-vertical?
-               (has-vertical-r? (has-cwith-property? options
-                                  #f
-                                  #f
-                                  #f
-                                  #f
-                                  "cell-rborder"
-                                  (lambda (v) (not (equal? v "0ln")))
-                                ) ;has-cwith-property?
-               ) ;has-vertical-r?
-              ) ;
-          (and has-top? has-bottom? (not has-vertical?) (not has-vertical-r?))
-        ) ;let*
-        #f
-      ) ;if
-    ) ;let*
-    #f
-  ) ;if
-) ;define
-
-(define (transform-three-line-tables x)
-  (cond ((null? x) '())
-        ((and (pair? x) (eq? (car x) 'tformat))
-         (let ((transformed-args (map transform-three-line-tables (cdr x))))
-           (let ((new-tformat (cons 'tformat transformed-args)))
-             (if (is-three-line-table-tformat? new-tformat)
-               (list 'three-line-table new-tformat)
-               new-tformat
-             ) ;if
-           ) ;let
-         ) ;let
-        ) ;
-        ((pair? x)
-         (cons (transform-three-line-tables (car x))
-           (transform-three-line-tables (cdr x))
-         ) ;cons
-        ) ;
-        (else x)
-  ) ;cond
-) ;define
-
-(define (clean-multirow t)
-  (cond ((null? t) (cons '() #f))
-        ((and (pair? t) (eq? (car t) 'multirow))
-         (let ((n (list-ref t 1))
-               (w (list-ref t 2))
-               (text (if (> (length t) 3) (list-ref t 3) ""))
-              ) ;
-           (cons text (cons n w))
-         ) ;let
-        ) ;
-        ((pair? t)
-         (let* ((res-car (clean-multirow (car t))) (res-cdr (clean-multirow (cdr t))))
-           (cond ((cdr res-car) (cons (cons (car res-car) (car res-cdr)) (cdr res-car)))
-                 ((cdr res-cdr) (cons (cons (car res-car) (car res-cdr)) (cdr res-cdr)))
-                 (else (cons (cons (car res-car) (car res-cdr)) #f))
-           ) ;cond
-         ) ;let*
-        ) ;
-        (else (cons t #f))
-  ) ;cond
-) ;define
-
-(define (process-row-cells cells r c options-acc new-cells-acc)
-  (cond ((null? cells) (cons (reverse new-cells-acc) options-acc))
-        (else (let* ((cell (car cells))
-                     (cleaned-res (clean-multirow cell))
-                     (new-cell (car cleaned-res))
-                     (info (cdr cleaned-res))
-                    ) ;
-                (if info
-                  (let* ((n (car info))
-                         (row-str (number->string r))
-                         (col-str (number->string c))
-                         (new-opt1 (list 'cwith row-str row-str col-str col-str "cell-row-span" n))
-                         (new-opt2 (list 'cwith row-str row-str col-str col-str "cell-valign" "c"))
-                        ) ;
-                    (process-row-cells (cdr cells)
-                      r
-                      (+ c 1)
-                      (cons new-opt1 (cons new-opt2 options-acc))
-                      (cons new-cell new-cells-acc)
-                    ) ;process-row-cells
-                  ) ;let*
-                  (process-row-cells (cdr cells) r (+ c 1) options-acc (cons cell new-cells-acc))
-                ) ;if
-              ) ;let*
-        ) ;else
-  ) ;cond
-) ;define
-
-(define (process-table-rows rows r options-acc new-rows-acc)
-  (cond ((null? rows) (cons (reverse new-rows-acc) options-acc))
-        (else (let* ((row (car rows))
-                     (cells (cdr row))
-                     (res-cells (process-row-cells cells r 1 '() '()))
-                    ) ;
-                (process-table-rows (cdr rows)
-                  (+ r 1)
-                  (append options-acc (cdr res-cells))
-                  (cons (cons 'row (car res-cells)) new-rows-acc)
-                ) ;process-table-rows
-              ) ;let*
-        ) ;else
-  ) ;cond
-) ;define
-
-(define (filter-table options)
-  (cond ((null? options) '())
-        ((and (pair? (car options)) (eq? (caar options) 'table))
-         (filter-table (cdr options))
-        ) ;
-        (else (cons (car options) (filter-table (cdr options))))
-  ) ;cond
-) ;define
-
-(define (collect-all-regions options num-rows)
-  (let loop-r
-    ((r 1) (regions '()))
-    (if (> r num-rows)
-      regions
-      (let* ((r-str (number->string r))
-             (row-regions (let loop-c
-                            ((c 1) (c-acc '()))
-                            (if (> c 50)
-                              c-acc
-                              (let* ((c-str (number->string c))
-                                     (h-val (let loop-opt
-                                              ((lst options))
-                                              (cond ((null? lst) #f)
-                                                    ((and (pair? (car lst))
-                                                       (eq? (caar lst) 'cwith)
-                                                       (equal? (list-ref (car lst) 1) r-str)
-                                                       (equal? (list-ref (car lst) 3) c-str)
-                                                       (equal? (list-ref (car lst) 5) "cell-row-span")
-                                                     ) ;and
-                                                     (list-ref (car lst) 6)
-                                                    ) ;
-                                                    (else (loop-opt (cdr lst)))
-                                              ) ;cond
-                                            ) ;let
-                                     ) ;h-val
-                                     (w-val (let loop-opt
-                                              ((lst options))
-                                              (cond ((null? lst) #f)
-                                                    ((and (pair? (car lst))
-                                                       (eq? (caar lst) 'cwith)
-                                                       (equal? (list-ref (car lst) 1) r-str)
-                                                       (equal? (list-ref (car lst) 3) c-str)
-                                                       (equal? (list-ref (car lst) 5) "cell-col-span")
-                                                     ) ;and
-                                                     (list-ref (car lst) 6)
-                                                    ) ;
-                                                    (else (loop-opt (cdr lst)))
-                                              ) ;cond
-                                            ) ;let
-                                     ) ;w-val
-                                     (h (if h-val (string->number h-val) 1))
-                                     (w (if w-val (string->number w-val) 1))
-                                    ) ;
-                                (if (or (> h 1) (> w 1))
-                                  (loop-c (+ c 1) (cons (list r c h w) c-acc))
-                                  (loop-c (+ c 1) c-acc)
-                                ) ;if
-                              ) ;let*
-                            ) ;if
-                          ) ;let
-             ) ;row-regions
-            ) ;
-        (loop-r (+ r 1) (append regions row-regions))
-      ) ;let*
-    ) ;if
-  ) ;let
-) ;define
-
-(define (is-cell-covered? ri ci regions)
-  (cond ((null? regions) #f)
-        (else (let* ((reg (car regions))
-                     (r (list-ref reg 0))
-                     (c (list-ref reg 1))
-                     (h (list-ref reg 2))
-                     (w (list-ref reg 3))
-                    ) ;
-                (if (and (>= ri r)
-                      (< ri (+ r h))
-                      (>= ci c)
-                      (< ci (+ c w))
-                      (not (and (= ri r) (= ci c)))
-                    ) ;and
-                  #t
-                  (is-cell-covered? ri ci (cdr regions))
-                ) ;if
-              ) ;let*
-        ) ;else
-  ) ;cond
-) ;define
-
-(define (clean-covered-cells-in-row cells r c regions new-cells-acc)
-  (cond ((null? cells) (reverse new-cells-acc))
-        (else (let* ((cell (car cells))
-                     (new-cell (if (is-cell-covered? r c regions) '(cell "") cell))
-                    ) ;
-                (clean-covered-cells-in-row (cdr cells)
-                  r
-                  (+ c 1)
-                  regions
-                  (cons new-cell new-cells-acc)
-                ) ;clean-covered-cells-in-row
-              ) ;let*
-        ) ;else
-  ) ;cond
-) ;define
-
-(define (clean-covered-cells-in-rows rows r regions new-rows-acc)
-  (cond ((null? rows) (reverse new-rows-acc))
-        (else (let* ((row (car rows))
-                     (cells (cdr row))
-                     (new-cells (clean-covered-cells-in-row cells r 1 regions '()))
-                     (new-row (cons 'row new-cells))
-                    ) ;
-                (clean-covered-cells-in-rows (cdr rows)
-                  (+ r 1)
-                  regions
-                  (cons new-row new-rows-acc)
-                ) ;clean-covered-cells-in-rows
-              ) ;let*
-        ) ;else
-  ) ;cond
-) ;define
-
-(define (transform-multirow-tformat x)
-  (if (and (pair? x) (eq? (car x) 'tformat))
-    (let* ((options (cdr x))
-           (table-cell-pair (let loop
-                              ((lst options))
-                              (cond ((null? lst) #f)
-                                    ((and (pair? (car lst)) (eq? (caar lst) 'table)) (car lst))
-                                    (else (loop (cdr lst)))
-                              ) ;cond
-                            ) ;let
-           ) ;table-cell-pair
-          ) ;
-      (if table-cell-pair
-        (let* ((table-rows (cdr table-cell-pair))
-               (processed (process-table-rows table-rows 1 '() '()))
-               (new-rows-temp (car processed))
-               (new-options (cdr processed))
-               (all-options (append (filter-table options) new-options))
-               (num-rows (length new-rows-temp))
-               (regions (collect-all-regions all-options num-rows))
-               (new-rows (clean-covered-cells-in-rows new-rows-temp 1 regions '()))
-               (rebuilt-options (append all-options (list (cons 'table new-rows))))
-              ) ;
-          (cons 'tformat rebuilt-options)
-        ) ;let*
-        x
-      ) ;if
-    ) ;let*
-    x
-  ) ;if
-) ;define
-
-(define (transform-multirow x)
-  (cond ((null? x) '())
-        ((and (pair? x) (eq? (car x) 'tformat))
-         (let* ((new-t (transform-multirow-tformat x))
-                (transformed-args (map transform-multirow (cdr new-t)))
-               ) ;
-           (cons 'tformat transformed-args)
-         ) ;let*
-        ) ;
-        ((pair? x) (cons (transform-multirow (car x)) (transform-multirow (cdr x))))
-        (else x)
-  ) ;cond
-) ;define
-
-(define latex->texmacs-original latex->texmacs)
-
-(tm-define (latex->texmacs t)
-  (let* ((res (latex->texmacs-original t))
-         (st (tree->stree res))
-         (new-st1 (upgrade-latex-differentials-stree st #f))
-         (new-st2 (transform-three-line-tables new-st1))
-         (new-st (transform-multirow new-st2))
-        ) ;
-    (stree->tree new-st)
-  ) ;let*
-) ;tm-define
-
-(define latex-document->texmacs-original latex-document->texmacs)
-
-(tm-define (latex-document->texmacs x . opts)
-  (let* ((res (apply latex-document->texmacs-original (cons x opts)))
-         (st (tree->stree res))
-         (new-st1 (upgrade-latex-differentials-stree st #f))
-         (new-st2 (transform-three-line-tables new-st1))
-         (new-st (transform-multirow new-st2))
-        ) ;
-    (stree->tree new-st)
-  ) ;let*
-) ;tm-define
-
-(converter latex-tree texmacs-tree (:function latex->texmacs))
-(converter latex-document
-  texmacs-tree
-  (:function-with-options latex-document->texmacs)
-  (:option "latex->texmacs:fallback-on-pictures" "on")
-  (:option "latex->texmacs:source-tracking" "off")
-  (:option "latex->texmacs:conservative" "off")
-  (:option "latex->texmacs:transparent-source-tracking" "off")
-) ;converter
diff --git a/TeXmacs/plugins/latex/progs/init-latex.scm b/TeXmacs/plugins/latex/progs/init-latex.scm
index 6a1f8652be..855e3d7322 100644
--- a/TeXmacs/plugins/latex/progs/init-latex.scm
+++ b/TeXmacs/plugins/latex/progs/init-latex.scm
@@ -12,7 +12,7 @@
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(lazy-format (data latex) latex)
-(lazy-format (data bibtex) bibtex)
+(lazy-format (latex latex-format) latex)
+(lazy-format (latex bibtex-format) bibtex)
 
-(import-from (latex-kbd))
+(import-from (latex latex-kbd))
diff --git a/TeXmacs/plugins/latex/progs/latex-kbd.scm b/TeXmacs/plugins/latex/progs/latex-kbd.scm
deleted file mode 100644
index 4e13ddfacf..0000000000
--- a/TeXmacs/plugins/latex/progs/latex-kbd.scm
+++ /dev/null
@@ -1,417 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : latex-kbd.scm
-;; DESCRIPTION : setup key combinations for frequently used commands
-;; COPYRIGHT   : (C) 1999  Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (latex-kbd)
-  (:use (utils edit auto-close)
-        (generic format-edit)
-        (generic generic-edit)
-        (text text-edit)))
-
-(kbd-symbols
-  "alpha" "beta" "gamma" "delta" "epsilon"
-  "zeta" "eta" "theta" "iota" "kappa"
-  "lambda" "mu" "nu" "xi" "omicron" "pi" "rho"
-  "sigma" "tau" "upsilon" "phi" "chi"
-  "psi" "omega" "varepsilon" "vartheta"
-  "varpi" "varrho" "varsigma" "varphi"
-  "leftharpoonup" "leftharpoondown"
-  "rightharpoonup" "rightharpoondown" "lefthook" "righthook"
-  "triangleright" "triangleleft" "star" "partial"
-  "flat" "natural" "sharp" "smile" "frown" "ell"
-  "imath" "jmath" "wp" "vect"
-  
-  "Alpha" "Beta" "Gamma" "Delta" "Epsilon"
-  "Zeta" "Eta" "Theta" "Iota" "Kappa" "Lambda"
-  "Mu" "Nu" "Xi" "Omicron" "Pi" "Rho"
-  "Sigma" "Tau" "Upsilon" "Phi" "Chi" "Psi" "Omega"
-  "varOmega"
-  "grave" "acute" "check" "breve" "invbreve" "bar"
-  "cedille"
-
-  "ast" "asterisk"
-  
-  "cdot" "times" "asterisk" "div" "diamond"
-  "pm" "mp" "oplus" "ominus" "otimes" "oslash"
-  "odot" "bigcirc" "circ" "bullet" "asymp" "equiv"
-  "subseteq" "supseteq" "leq" "geq" "preceq" "succeq"
-  "sim" "approx" "subset" "supset" "ll" "gg"
-  "prec" "succ" "leftarrow" "rightarrow" "uparrow"
-  "downarrow" "leftrightarrow" "nearrow" "searrow"
-  "simeq" "Leftarrow" "Rightarrow" "Uparrow"
-  "Downarrow" "Leftrightarrow" "nwarrow" "swarrow"
-  "propto" "infty" "in" "ni" "mid" "bigtriangleup" "triangle"
-  "bigtriangledown" "negate" "varshortmid" "forall" "exists"
-  "neg" "emptyset" "Re" "Im" "top" "bot" "aleph" "perp"
-  "cup" "cap" "uplus" "wedge" "vee" "vdash" "dashv"
-  "lfloor" "rfloor" "lceil" "rceil" "langle" "rangle"
-  "updownarrow" "Updownarrow" "wr" "amalg" "nabla"
-  "sqcup" "sqcap" "sqsubseteq" "sqsupseteq" "dag" "ddag"
-  "endofline" "clubsuit" "diamondsuit" "heartsuit" "spadesuit"
-  "backslash" "setminus"
-
-  "boxdot" "boxplus" "boxtimes" "box" "blacksquare"
-  "centerdot" "lozenge" "blacklozenge" "circlearrowright"
-  "circlearrowleft" "rightleftharpoons" "leftrightharpoons"
-  "boxminus" "Vdash" "Vvdash" "dashV" "twoheadrightarrow"
-  "twoheadleftarrow" "leftleftarrows" "rightrightarrows"
-  "upuparrows" "downdownarrows" "upharpoonright"
-  "downharpoonright" "upharpoonleft" "downharpoonleft"
-  "rightarrowtail" "leftarrowtail" "leftrightarrows"
-  "rightleftarrows" "Lsh" "Rsh" "rightsquigarrow"
-  "leftrightsquigarrow" "looparrowleft" "looparrowright"
-  "circeq" "succsim" "gtrsim" "gtrapprox" "multimap"
-  "therefore" "because" "doteqdot" "triangleq"
-  "precsim" "lesssim" "lessapprox" "eqslantless"
-  "eqslantgtr" "curlyeqprec" "curlyeqsucc" "preccurlyeq"
-  "leqq" "leqslant" "lessgtr" "smalldash"
-  "risingdotseq" "fallingdotseq" "succcurlyeq" "geqq"
-  "geqslant" "gtrless" "sqsubset" "sqsupset"
-  "vartriangleright" "vartriangleleft" "trianglerighteq"
-  "trianglelefteq" "bigstar" "between"
-  "blacktriangledown" "blacktriangleright" "blacktriangleleft"
-  "shortrightarrow" "shortleftarrow" "vartriangle"
-  "blacktriangle" "triangledown" "eqcirc"
-  "lesseqgtr" "gtreqless" "lesseqqgtr" "gtreqqless"
-  "yen" "Rrightarrow" "Lleftarrow" "checkmark"
-  "veebar" "barwedge" "doublebarwedge" "angle" "measuredangle"
-  "sphericalangle" "varpropto" "smallsmile" "smallfrown" "Subset"
-  "Supset" "Cup" "Cap" "curlyvee" "curlywedge"
-  "leftthreetimes" "rightthreetimes" "subseteqq" "supseteqq"
-  "bumpeq" "Bumpeq" "lll" "ggg" "ulcorner" "urcorner"
-  "circledR" "circledS" "pitchfork" "dotplus" "backsim"
-  "backsimeq" "llcorner" "lrcorner" "maltese"
-  "complement" "intercal" "circledcirc" "circledast" "circleddash"
-  
-  "lvertneqq" "gvertneqq" "nleq" "ngeq" "nless" "ngtr"
-  "nprec" "nsucc" "lneqq" "gneqq" "nleqslant" "ngeqslant"
-  "lneq" "gneq" "npreceq" "nsucceq" "precnsim"
-  "succnsim" "lnsim" "gnsim" "nleqq" "ngeqq"
-  "precneqq" "succneqq" "precnapprox" "succnapprox"
-  "lnapprox" "gnapprox" "nsim" "ncong" "diagup"
-  "diagdown" "varsubsetneq" "varsupsetneq"
-  "nsubseteqq" "nsupseteqq" "subsetneqq" "supsetneqq"
-  "varsubsetneqq" "varsupsetneqq" "subsetneq" "supsetneq"
-  "nsubseteq" "nsupseteq" "parallel" "nparallel" "nmid" "nshortmid"
-  "nshortparallel" "nvdash" "nVdash" "nvDash" "nVDash" "models"
-  "ntrianglerighteq" "ntrianglelefteq" "ntriangleleft"
-  "ntriangleright" "nleftarrow" "nrightarrow" "nLeftarrow"
-  "nRightarrow" "nLeftrightarrow" "nleftrightarrow"
-  "divideontimes" "varnothing" "nexists"
-  "Mho" "thorn" "eth" "eqsim" "beth" "gimel" "daleth"
-  "lessdot" "gtrdot" "ltimes" "rtimes" "shortmid"
-  "shortparallel" "smallsetminus" "thicksim" "thickapprox"
-  "approxeq" "succapprox" "precapprox" "curvearrowleft"
-  "curvearrowright" "digamma" "varkappa" "hslash"
-  "hbar" "backepsilon" "varparallel" "nvarparallel"
-  
-  "mapsto" "longmapsto" "longrightarrow" "longleftarrow"
-  "longleftrightarrow" "longRightarrow" "longLeftarrow"
-  "longLeftrightarrow" "ldots" "cdots" "vdots"
-  "ddots" "dotamalg" "dottimes" "dotoplus" "dototimes" "venus"
-  "mars" "earth" "aries" "fullmoon" "newmoon" "astrosun"
-  "leo" "LEFTcircle" "RIGHTcircle" "Square" "CheckedBox" "photon" "gluon"
-  "neq" "notin" "nin" "notni" "nni" "nll" "nlll" "ngg" "nggg"
-  "dagger" "ddagger" "boxbar" "checked" "obar" "kreuz")
-
-(kbd-commands
-  ("#" "Insert sharp" (insert "#"))
-  ("$" "Insert dollar" (insert "$"))
-  ("(" "Insert formula" (make-with "mode" "math"))
-  ("," "Insert small horizontal space" (make-space "0.2spc"))
-  (":" "Insert medium horizontal space" (make-space "0.4spc"))
-  (";" "Insert thick horizontal space" (make-space "0.6spc"))
-  (" " "Insert horizontal interword space" (make-space "1spc"))
-  ("!" "Insert negative horizontal space" (make-space "-0.2spc"))
-  ("|" "Insert norm" (insert "<||>"))
-  ("quad" "Insert a quad space" (make-space "1em"))
-  ("qquad" "Insert a qquad space" (make-space "2em"))
-  ("\\" "Go to the next line" (make 'next-line))
-
-  ("[" "Insert equation" (make-equation*))
-  ("equation" "Insert numbered equation" (make-equation))
-  ("eqnarray*" "Insert equation array" (make-eqnarray*))
-
-  ("cC" "Insert Ç" (insert "<#00C7>"))
-  ("cc" "Insert ç" (insert "<#00E7>"))
-  ("'E" "Insert É" (insert "<#00C9>"))
-  ("'e" "Insert é" (insert "<#00E9>"))
-  ("`A" "Insert À" (insert "<#00C0>"))
-  ("`E" "Insert È" (insert "<#00C8>"))
-  ("`U" "Insert Ù" (insert "<#00D9>"))
-  ("`a" "Insert à" (insert "<#00E0>"))
-  ("`e" "Insert è" (insert "<#00E8>"))
-  ("`u" "Insert ù" (insert "<#00F9>"))
-  ("^A" "Insert Â" (emulate-keyboard "hat A"))
-  ("^E" "Insert Ê" (emulate-keyboard "hat E"))
-  ("^I" "Insert Î" (emulate-keyboard "hat I"))
-  ("^O" "Insert Ô" (emulate-keyboard "hat O"))
-  ("^U" "Insert Û" (emulate-keyboard "hat U"))
-  ("^a" "Insert â" (emulate-keyboard "hat a"))
-  ("^e" "Insert ê" (emulate-keyboard "hat e"))
-  ("^i" "Insert î" (emulate-keyboard "hat i"))
-  ("^o" "Insert ô" (emulate-keyboard "hat o"))
-  ("^u" "Insert û" (emulate-keyboard "hat u"))
-  ("aa" "Insert å" (insert "<#00E5>"))
-  ("ae" "Insert æ" (insert "<#00E6>"))
-  ("dh" "Insert ð" (insert "<#00F0>"))
-  ("dj" "Insert đ" (insert "<#0111>"))
-  ("i" "Insert ı" (insert "<#0131>"))
-  ("j" "Insert ȷ" (insert "<#0237>"))
-  ("l" "Insert ł" (insert "<#0142>"))
-  ("ng" "Insert ŋ" (insert "<#014B>"))
-  ("o" "Insert ø" (insert "<#00F8>"))
-  ("oe" "Insert œ" (insert "<#0153>"))
-  ("ss" "Insert ö" (insert "<#00F6>"))
-  ("sz" "Insert ß" (insert "<#00DF>"))
-  ("th" "Insert þ" (insert "<#00FE>"))
-  ("AA" "Insert Å" (insert "<#00C5>"))
-  ("AE" "Insert Æ" (insert "<#00C6>"))
-  ("DH" "Insert Ð" (insert "<#00D0>"))
-  ("L" "Insert Ł" (insert "<#0141>"))
-  ("NG" "Insert Ŋ" (insert "<#014A>"))
-  ("O" "Insert Ø" (insert "<#00D8>"))
-  ("OE" "Insert Œ" (insert "<#0152>"))
-  ("S" "Insert §" (insert "<#00A7>"))
-  ("SS" "Insert ẞ" (insert "<#1E9E>"))
-  ("TH" "Insert Þ" (insert "<#00DE>"))
-  ("hookleftarrow" "insert ↩" (insert "<#21A9>"))
-  ("hookrightarrow" "insert ↪" (insert "<#21AA>"))
-
-  ("arccos" "Insert arccos" (insert "arccos"))
-  ("arcsin" "Insert arcsin" (insert "arcsin"))
-  ("arctan" "Insert arctan" (insert "arctan"))
-  ("arg" "Insert arg" (insert "arg"))
-  ("cos" "Insert cos" (insert "cos"))
-  ("cosh" "Insert cosh" (insert "cosh"))
-  ("cot" "Insert cot" (insert "cot"))
-  ("coth" "Insert coth" (insert "coth"))
-  ("csc" "Insert csc" (insert "csc"))
-  ("deg" "Insert deg" (insert "deg"))
-  ("det" "Insert det" (make 'det))
-  ("dim" "Insert dim" (insert "dim"))
-  ("exp" "Insert exp" (insert "exp"))
-  ("gcd" "Insert gcd" (insert "gcd"))
-  ("hom" "Insert hom" (insert "hom"))
-  ("inf" "Insert inf" (insert "inf"))
-  ("ker" "Insert ker" (insert "ker"))
-  ("lg" "Insert lg" (insert "lg"))
-  ("lim" "Insert lim" (insert "lim"))
-  ("liminf" "Insert liminf" (insert "liminf"))
-  ("limsup" "Insert limsup" (insert "limsup"))
-  ("varliminf" "Insert varliminf" (make 'varliminf))
-  ("varlimsup" "Insert varlimsup" (make 'varlimsup))
-  ("ln" "Insert ln" (insert "ln"))
-  ("log" "Insert log" (insert "log"))
-  ("max" "Insert max" (insert "max"))
-  ("min" "Insert min" (insert "min"))
-  ("Pr" "Insert Pr" (insert "Pr"))
-  ("sec" "Insert sec" (insert "sec"))
-  ("sin" "Insert sin" (insert "sin"))
-  ("sinh" "Insert sinh" (insert "sinh"))
-  ("sup" "Insert sup" (insert "sup"))
-  ("tan" "Insert tan" (insert "tan"))
-  ("tanh" "Insert tanh" (insert "tanh"))
-
-  ("abstract"  "Insert abstract" (make-abstract-data))
-  ("maketitle" "Insert title"    (make-doc-data))
-  ("tableofcontents" "Insert table of contents"
-   (make-aux "table-of-contents" "toc-prefix" "toc"))
-  ("appendix" "Insert appendix" (make-section 'appendix))
-  ("chapter" "Insert chapter" (make-section 'chapter))
-  ("section" "Insert section" (make-section 'section))
-  ("subsection" "Insert subsection" (make-section 'subsection))
-  ("subsubsection" "Insert subsubsection" (make-section 'subsubsection))
-  ("paragraph" "Insert paragraph" (make-section 'paragraph))
-  ("subparagraph" "Insert subparagraph" (make-section 'subparagraph))
-  ("table" "Insert a big table" (make 'big-table))
-  ("figure" "Insert a big figure" (make 'big-figure))
-
-  ("frac" "Make fraction" (make-fraction))
-  ("sqrt" "Make square root" (make-sqrt))
-  ("not" "Make negation" (make-neg))
-  ("acute" "Make acute" (make-wide ""))
-  ("bar" "Make bar" (make-wide ""))
-  ("breve" "Make breve" (make-wide ""))
-  ("invbreve" "Make inverted breve" (make-wide ""))
-  ("check" "Make check" (make-wide ""))
-  ("grave" "Make grave" (make-wide ""))
-  ("hat" "Make hat" (make-wide "^"))
-  ("tilde" "Make tilde" (make-wide "~"))
-  ("vect" "Make vector" (make-wide ""))
-  ("dot" "Make dot" (make-wide ""))
-  ("ddot" "Make double dot" (make-wide ""))
-  ("dddot" "Make triple dot" (make-wide ""))
-  ("ddddot" "Make quadruple dot" (make-wide ""))
-  ("widecheck" "Make check" (make-wide ""))
-  ("widehat" "Make hat" (make-wide "^"))
-  ("widetilde" "Make tilde" (make-wide "~"))
-
-  ("sum" "Insert big summation" (math-big-operator "sum"))
-  ("prod" "Insert big product" (math-big-operator "prod"))
-  ("coprod" "Insert big coproduct" (math-big-operator "amalg"))
-  ("int" "Insert big integral" (math-big-operator "int"))
-  ("iint" "Insert big integrals" (math-big-operator "iint"))
-  ("iiint" "Insert big integrals" (math-big-operator "iiint"))
-  ("oint" "Insert big contour integral" (math-big-operator "oint"))
-  ("oiint" "Insert big contour integrals" (math-big-operator "oiint"))
-  ("oiiint" "Insert big contour integrals" (math-big-operator "oiiint"))
-  ("bigcap" "Insert big intersection" (math-big-operator "cap"))
-  ("bigcup" "Insert big union" (math-big-operator "cup"))
-  ("bigsqcup" "Insert big square union" (math-big-operator "sqcup"))
-  ("bigvee" "Insert big logical or" (math-big-operator "vee"))
-  ("bigwedge" "Insert big logical and" (math-big-operator "wedge"))
-  ("bigodot" "Insert big dotted point" (math-big-operator "odot"))
-  ("bigotimes" "Insert big tensor product" (math-big-operator "otimes"))
-  ("bigoplus" "Insert big direct sum" (math-big-operator "oplus"))
-  ("biguplus" "Insert big union sum" (math-big-operator "uplus"))
-
-  ("left(" "Insert large (" (math-bracket-open "(" ")" #t))
-  ("left)" "Insert large left )" (math-bracket-open ")" "(" #t))
-  ("left[" "Insert large [" (math-bracket-open "[" "]" #t))
-  ("left]" "Insert large left ]" (math-bracket-open "]" "[" #t))
-  ("left\\{" "Insert large {" (math-bracket-open "{" "}" #t))
-  ("left\\}" "Insert large left }" (math-bracket-open "}" "{" #t))
-  ("left\\lfloor" "Insert large "
-   (math-bracket-open "" "" #t))
-  ("left\\rfloor" "Insert large left "
-   (math-bracket-open "" "" #t))
-  ("left\\lceil" "Insert large "
-   (math-bracket-open "" "" #t))
-  ("left\\rceil" "Insert large left "
-   (math-bracket-open "" "" #t))
-  ("left\\langle" "Insert large "
-   (math-bracket-open "" "" #t))
-  ("left\\rangle" "Insert large left "
-   (math-bracket-open "" "" #t))
-  ("left|" "Insert large left " (math-bracket-open "|" "|" #t))
-  ("left||" "Insert large left " (math-bracket-open "||" "||" #t))
-  ("left/" "Insert large left /" (math-bracket-open "/" "\\" #t))
-  ("left\\" "Insert large left \\" (math-bracket-open "\\" "/" #t))
-  ("left." "Insert large left ." (math-bracket-open "." "." #t))
-
-  ("right(" "Insert large right (" (math-bracket-close "(" ")" #t))
-  ("right)" "Insert large )" (math-bracket-close ")" "(" #t))
-  ("right[" "Insert large right [" (math-bracket-close "[" "]" #t))
-  ("right]" "Insert large ]" (math-bracket-close "]" "[" #t))
-  ("right\\{" "Insert large right {" (math-bracket-close "{" "}" #t))
-  ("right\\}" "Insert large }" (math-bracket-close "}" "{" #t))
-  ("right\\lfloor" "Insert large right "
-   (math-bracket-close "" "" #t))
-  ("right\\rfloor" "Insert large "
-   (math-bracket-close "" "" #t))
-  ("right\\lceil" "Insert large right "
-   (math-bracket-close "" "" #t))
-  ("right\\rceil" "Insert large "
-   (math-bracket-close "" "" #t))
-  ("right\\langle" "Insert large right "
-   (math-bracket-close "" "" #t))
-  ("right\\rangle" "Insert large "
-   (math-bracket-close "" "" #t))
-  ("right|" "Insert large right " (math-bracket-close "|" "|" #t))
-  ("right||" "Insert large right " (math-bracket-close "||" "||" #t))
-  ("right/" "Insert large right /" (math-bracket-close "/" "\\" #t))
-  ("right\\" "Insert large right \\" (math-bracket-close "\\" "/" #t))
-  ("right." "Insert large right ." (math-bracket-close "." "." #t))
-
-  ("rmfamily" "Use roman font family" (make-with "font-family" "rm"))
-  ("ttfamily" "Use typewriter font family" (make-with "font-family" "tt"))
-  ("sffamily" "Use sans serif font family" (make-with "font-family" "ss"))
-  ("mdseries" "Use medium font series" (make-with "font-series" "medium"))
-  ("bfseries" "Use bold font series" (make-with "font-series" "bold"))
-  ("upshape" "Use right font shape" (make-with "font-shape" "right"))
-  ("itshape" "Use italic font shape" (make-with "font-shape" "italic"))
-  ("slshape" "Use slanted font shape" (make-with "font-shape" "slanted"))
-  ("scshape" "Use small-caps font shape"
-   (make-with "font-shape" "small-caps"))
-  ("rm" "Use roman font family" (make-with "font-family" "rm"))
-  ("tt" "Use typewriter font family" (make 'tt))
-  ("sf" "Use sans serif font family" (make-with "font-family" "ss"))
-  ("md" "Use medium font series" (make-with "font-series" "medium"))
-  ("bf" "Use bold font series" (make-with "font-series" "bold"))
-  ("up" "Use right font shape" (make-with "font-shape" "right"))
-  ("it" "Use italic font shape" (make-with "font-shape" "italic"))
-  ("em" "Emphasize text" (make 'em))
-  ("sl" "Use slanted font shape" (make-with "font-shape" "slanted"))
-  ("sc" "Use small-caps font shape" (make-with "font-shape" "small-caps"))
-  ("textrm" "Use roman font family" (make-with "font-family" "rm"))
-  ("texttt" "Use typewriter font family" (make-with "font-family" "tt"))
-  ("textsf" "Use sans serif font family" (make-with "font-family" "ss"))
-  ("textmd" "Use medium font series" (make-with "font-series" "medium"))
-  ("textbf" "Use bold font series" (make-with "font-series" "bold"))
-  ("textup" "Use right font shape" (make-with "font-shape" "right"))
-  ("textit" "Use italic font shape" (make-with "font-shape" "italic"))
-  ("emph" "Use italic font shape" (make-with "font-shape" "italic"))
-  ("textsl" "Use slanted font shape" (make-with "font-shape" "slanted"))
-  ("textsc" "Use small-caps font shape" (make-with "font-shape" "small-caps"))
-  ("cal" "Use calligraphic font" (make-with "font" "cal"))
-  ("frak" "Use fraktur font" (make-with "font" "Euler"))
-  ("Bbb" "Use blackboard bold font" (make-with "font" "Bbb*"))
-  ("mathcal" "Use calligraphic font" (make-with "font" "cal"))
-  ("mathfrak" "Use fraktur font" (make-with "font" "Euler"))
-  ("mathbb" "Use blackboard math font" (make-with "font" "Bbb"))
-  ("mathbbm" "Use blackboard math font" (make-with "font" "Bbb*"))
-  ("mathrm" "Use roman font family" (make-with "font-family" "rm"))
-  ("mathtt" "Use typewriter font family" (make-with "font-family" "tt"))
-  ("mathsf" "Use sans serif font family" (make-with "font-family" "ss"))
-  ("mathmd" "Use medium font series" (make-with "font-series" "medium"))
-  ("mathbf" "Use bold font series" (make-with "font-series" "bold"))
-  ("mathup" "Use right font shape" (make-with "font-shape" "right"))
-  ("mathit" "Use italic font shape" (make-with "font-shape" "italic"))
-  ("tiny" "Use tiny font font size" (make 'tiny))
-  ("scriptsize" "Use script font size" (make 'very-small))
-  ("footnotesize" "Use footnote font size" (make 'smaller))
-  ("small" "Use small font size" (make 'small))
-  ("normalsize" "Use normal font size" (make 'normal-size))
-  ("large" "Use large font size" (make 'large))
-  ("Large" "Use very large font size" (make 'larger))
-  ("LARGE" "Use very large font size" (make 'very-large))
-  ("huge" "Use huge font size" (make 'huge))
-  ("Huge" "Use really huge font size" (make 'really-huge))
-  ("displaystyle" "Switch to formula style"
-   (make-with "math-display" "true"))
-
-  ("black" "Use a black color" (make-with "color" "black"))
-  ("white" "Use a white color" (make-with "color" "white"))
-  ("grey" "Use a grey color" (make-with "color" "grey"))
-  ("red" "Use a red color" (make-with "color" "red"))
-  ("blue" "Use a blue color" (make-with "color" "blue"))
-  ("yellow" "Use a yellow color" (make-with "color" "yellow"))
-  ("green" "Use a green color" (make-with "color" "green"))
-  ("orange" "Use a orange color" (make-with "color" "orange"))
-  ("magenta" "Use a magenta color" (make-with "color" "magenta"))
-  ("brown" "Use a brown color" (make-with "color" "brown"))
-  ("pink" "Use a pink color" (make-with "color" "pink"))
-
-  ("smallskip" "Insert small vertical space" (make-vspace-after "0.5fn"))
-  ("medskip" "Insert medium vertical space" (make-vspace-after "1fn"))
-  ("bigskip" "Insert big vertical space" (make-vspace-after "2fn"))
-  ("item" "Insert new item or number" (make-item))
-  ("label" "Make label" (make-label))
-  ("ref" "Make reference" (make 'reference))
-  ("pageref" "Make page reference" (make 'pageref))
-  ("footnote" "Insert a footnote" (make 'footnote))
-  ("input" "Include a document" (make 'include)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Extensions to LaTeX
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(kbd-commands
-  ("big." "Insert big ." (math-big-operator "."))
-  ("underbrace" "Insert underbrace" (make-wide-under ""))
-  ("overbrace" "Insert overbrace" (make-wide "")))
-
-(kbd-symbols
-  "ddots" "mho" "Backepsilon" "Backsigma" "homsim"
-  "mathcatalan" "mathD" "mathd" "mathe" "mathi"
-  "mathGamma" "mathLaplace" "matheuler" "mathlambda" "mathpi")
diff --git a/TeXmacs/plugins/latex/progs/latex/bibtex-abbrv.scm b/TeXmacs/plugins/latex/progs/latex/bibtex-abbrv.scm
new file mode 100644
index 0000000000..f792535994
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/bibtex-abbrv.scm
@@ -0,0 +1,29 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : abbrv.scm
+;; DESCRIPTION : abbrv style for BibTeX files
+;; COPYRIGHT   : (C) 2010, 2015  David MICHEL, Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex bibtex-abbrv)
+  (:use (latex bibtex-bib-utils) (latex bibtex-plain))
+) ;texmacs-module
+
+(bib-define-style "abbrv" "plain")
+
+(tm-define (bib-format-first-name x)
+  (:mode bib-abbrv?)
+  (if (bib-null? (list-ref x 1))
+    ""
+    (with f
+      (bib-abbreviate (list-ref x 1) "." '(nbsp))
+      (if (bib-name-ends? f ".") (tmconcat f '(nbsp)) (tmconcat f " "))
+    ) ;with
+  ) ;if
+) ;tm-define
diff --git a/TeXmacs/plugins/latex/progs/latex/bibtex-abstract.scm b/TeXmacs/plugins/latex/progs/latex/bibtex-abstract.scm
new file mode 100644
index 0000000000..14ba1cae45
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/bibtex-abstract.scm
@@ -0,0 +1,23 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : abstract.scm
+;; DESCRIPTION : abstract style for BibTeX files
+;; COPYRIGHT   : (C) 2017  Philippe Joyez
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex bibtex-abstract)
+  (:use (latex bibtex-bib-utils) (latex bibtex-plain))
+) ;texmacs-module
+
+(bib-define-style "abstract" "plain")
+
+(tm-define (bib-format-bibitem n x)
+  (:mode bib-abstract?)
+  `(bibitem* ,(list-ref x 2))
+) ;tm-define
diff --git a/TeXmacs/plugins/latex/progs/latex/bibtex-acm.scm b/TeXmacs/plugins/latex/progs/latex/bibtex-acm.scm
new file mode 100644
index 0000000000..66820807d9
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/bibtex-acm.scm
@@ -0,0 +1,333 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : acm.scm
+;; DESCRIPTION : acm style for BibTeX files
+;; COPYRIGHT   : (C) 2010, 2015  David MICHEL, Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex bibtex-acm)
+  (:use (latex bibtex-bib-utils) (latex bibtex-plain))
+) ;texmacs-module
+
+(bib-define-style "acm" "plain")
+
+(tm-define (bib-format-name x)
+  (:mode bib-acm?)
+  (let* ((f (if (bib-null? (list-ref x 1))
+              ""
+              `(concat ,", " ,(bib-abbreviate (list-ref x 1) "." '(nbsp)))
+            ) ;if
+         ) ;f
+         (vv (if (bib-null? (list-ref x 2)) "" `(concat ,(list-ref x 2) (nbsp))))
+         (ll (if (bib-null? (list-ref x 3)) "" (bib-purify (list-ref x 3))))
+         (jj (if (bib-null? (list-ref x 4)) "" `(concat ,", " ,(list-ref x 4))))
+        ) ;
+    `(with ,"font-shape" ,"small-caps" (concat ,vv ,ll ,jj ,f))
+  ) ;let*
+) ;tm-define
+
+(tm-define (bib-format-editor x)
+  (:mode bib-acm?)
+  (let* ((a (bib-field x "editor")))
+    (if (or (bib-null? a) (nlist? a))
+      ""
+      (if (equal? (length a) 2)
+        `(concat ,(bib-format-names a) ,(bib-translate ", Ed."))
+        `(concat ,(bib-format-names a) ,(bib-translate ", Eds."))
+      ) ;if
+    ) ;if
+  ) ;let*
+) ;tm-define
+
+(tm-define (bib-format-date x)
+  (:mode bib-acm?)
+  (let* ((y (bib-field x "year")) (m (bib-field x "month")))
+    (if (bib-null? y)
+      (if (bib-null? m) "" m)
+      (if (bib-null? m) y `(concat ,m ," " ,y))
+    ) ;if
+  ) ;let*
+) ;tm-define
+
+(tm-define (bib-format-in-ed-booktitle x)
+  (:mode bib-acm?)
+  (let* ((b (bib-field x "booktitle"))
+         (a (bib-field x "address"))
+         (cl `(concat ," ("
+                ,(bib-new-list ", " `(,a ,(bib-format-date x)))
+                ,")"))
+        ) ;
+    (if (bib-null? b)
+      ""
+      `(concat ,(bib-translate "in ") (with ,"font-shape" ,"italic" ,b) ,cl)
+    ) ;if
+  ) ;let*
+) ;tm-define
+
+(define (bib-format-volume-or-number x)
+  (let* ((v (bib-field x "volume"))
+         (n (bib-field x "number"))
+         (s (bib-field x "series"))
+        ) ;
+    (if (bib-null? v)
+      (if (bib-null? n)
+        (if (bib-null? s) "" s)
+        (let ((series (if (bib-null? s) "" `(concat ,(bib-translate " in ") ,s)))
+              (sep (if (< (bib-text-length n) 3) '(nbsp) " "))
+             ) ;
+          `(concat ,"no." ,sep ,n ,series)
+        ) ;let
+      ) ;if
+      (let ((series (if (bib-null? s)
+                      ""
+                      `(concat ,(bib-translate " of ")
+                         (with ,"font-shape" ,"italic" ,s))
+                    ) ;if
+            ) ;series
+            (sep (if (< (bib-text-length v) 3) '(nbsp) " "))
+           ) ;
+        `(concat ,"vol." ,sep ,v ,series)
+      ) ;let
+    ) ;if
+  ) ;let*
+) ;define
+
+(tm-define (bib-format-pages x)
+  (:mode bib-acm?)
+  (let* ((p (bib-field x "pages")))
+    (cond ((or (bib-null? p) (nlist? p)) "")
+          ((== (length p) 1) "")
+          ((== (length p) 2) (list-ref p 1))
+          (else `(concat ,(list-ref p 1) ,bib-range-symbol ,(list-ref p 2)))
+    ) ;cond
+  ) ;let*
+) ;tm-define
+
+(tm-define (bib-format-chapter-pages x)
+  (:mode bib-acm?)
+  (let* ((c (bib-field x "chapter")) (t (bib-field x "type")))
+    (if (bib-null? c)
+      (bib-format-pages x)
+      (let ((type (if (bib-null? t) (bib-translate "chapter") (bib-locase t)))
+            (pages `(concat ,", " ,(bib-format-pages x)))
+           ) ;
+        `(concat ,type ," " ,c ,pages)
+      ) ;let
+    ) ;if
+  ) ;let*
+) ;tm-define
+
+(tm-define (bib-format-tr-number x)
+  (:mode bib-acm?)
+  (let* ((t (bib-field x "type"))
+         (n (bib-field x "number"))
+         (type (if (bib-null? t) (bib-translate "Technical Report") t))
+         (number (if (bib-null? n) "" n))
+         (sep (if (< (bib-text-length n) 3) '(nbsp) " "))
+        ) ;
+    (if (bib-null? n) type `(concat ,type ,sep ,number))
+  ) ;let*
+) ;tm-define
+
+(define (bib-format-edition x)
+  (let* ((e (bib-field x "edition")))
+    (if (bib-null? e) "" `(concat ,e ," ed."))
+  ) ;let*
+) ;define
+
+(tm-define (bib-format-bibitem n x)
+  (:mode bib-acm?)
+  `(bibitem* ,(number->string n))
+) ;tm-define
+
+(define (bib-format-journal-volume-date x)
+  (bib-new-sentence `((concat ,(bib-emphasize `(concat ,(bib-format-field x
+                                                          "journal")
+                                                 ,(if (bib-null? (bib-field x
+                                                                   "volume"))
+                                                    ""
+                                                    " ")
+                                                 ,(bib-format-field x "volume")))
+                        ," ("
+                        ,(bib-format-date x)
+                        ,")")
+                      ,(bib-format-pages x))
+  ) ;bib-new-sentence
+) ;define
+
+(define (bib-format-journal-volume-number-date x)
+  (bib-new-sentence `(,(bib-emphasize `(concat ,(bib-format-field x "journal")
+                                         ,(if (bib-null? (bib-field x "volume"))
+                                            ""
+                                            " ")
+                                         ,(bib-format-field x "volume")))
+                      (concat ,(bib-format-field x "number")
+                        ," ("
+                        ,(bib-format-date x)
+                        ,")")
+                      ,(bib-format-pages x))
+  ) ;bib-new-sentence
+) ;define
+
+(tm-define (bib-format-article n x)
+  (:mode bib-acm?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-format-author x))
+                          ,(bib-new-block (bib-format-field-Locase x "title"))
+                          ,(bib-new-block (if (bib-empty? x "crossref")
+                                            (if (bib-null? (bib-field x
+                                                             "number"))
+                                              (bib-format-journal-volume-date x)
+                                              (bib-format-journal-volume-number-date x))
+                                            (bib-new-sentence `((concat ,(bib-translate "in ")
+                                                                  (cite ,(bib-field x
+                                                                           "crossref")))
+                                                                ,(bib-format-pages x)))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-book n x)
+  (:mode bib-acm?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (if (bib-empty? x "author")
+                                            (bib-format-editor x)
+                                            (bib-format-author x)))
+                          ,(bib-new-block (bib-new-sentence `(,(bib-emphasize (bib-format-field x
+                                                                                "title"))
+                                                              ,(bib-format-edition x))))
+                          ,(bib-new-block (if (bib-empty? x "crossref")
+                                            (bib-new-list-spc `(,(bib-new-sentence `(,(bib-format-number-series x)))
+                                                                ,(bib-new-sentence `(,(bib-format-field x
+                                                                                        "publisher")
+                                                                                     ,(bib-format-field x
+                                                                                        "address")
+                                                                                     ,(bib-format-date x)))))
+                                            (bib-new-sentence `((concat ,(bib-translate "in ")
+                                                                  (cite ,(bib-field x
+                                                                           "crossref")))
+                                                                ,(bib-format-field x
+                                                                   "edition")
+                                                                ,(bib-format-date x)))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-inbook n x)
+  (:mode bib-acm?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (if (bib-empty? x "author")
+                                            (bib-format-editor x)
+                                            (bib-format-author x)))
+                          ,(bib-new-block (bib-new-sentence `(,(bib-emphasize (bib-format-field x
+                                                                                "title")))))
+                          ,(bib-new-block (if (bib-empty? x "crossref")
+                                            (bib-new-list-spc `(,(bib-new-sentence `(,(bib-format-number-series x)))
+                                                                ,(bib-new-sentence `(,(bib-format-field x
+                                                                                        "publisher")
+                                                                                     ,(bib-format-field x
+                                                                                        "address")
+                                                                                     ,(bib-format-date x)
+                                                                                     ,(bib-format-chapter-pages x)))))
+                                            (bib-new-sentence `((concat ,(bib-translate "in ")
+                                                                  (cite ,(bib-field x
+                                                                           "crossref")))
+                                                                ,(bib-format-field x
+                                                                   "edition")
+                                                                ,(bib-format-date x)))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-incollection n x)
+  (:mode bib-acm?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-format-author x))
+                          ,(bib-new-block (bib-format-field-Locase x "title"))
+                          ,(bib-new-block (if (bib-empty? x "crossref")
+                                            (bib-new-list-spc `(,(bib-new-sentence `((concat ,(bib-translate "in ")
+                                                                                       ,(bib-emphasize (bib-format-field x
+                                                                                                         "booktitle")))
+                                                                                     ,(bib-format-editor x)
+                                                                                     ,(bib-format-edition x)
+                                                                                     ,(bib-format-volume-or-number x)))
+                                                                ,(bib-new-sentence `(,(bib-format-field x
+                                                                                        "publisher")
+                                                                                     ,(bib-format-field x
+                                                                                        "address")
+                                                                                     ,(bib-format-date x)
+                                                                                     ,(bib-format-chapter-pages x)))))
+                                            (bib-new-sentence `((concat ,(bib-translate "in ")
+                                                                  (cite ,(bib-field x
+                                                                           "crossref")))
+                                                                ,(bib-format-chapter-pages x)))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-inproceedings n x)
+  (:mode bib-acm?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-format-author x))
+                          ,(bib-new-block (bib-format-field-Locase x "title"))
+                          ,(bib-new-block (if (bib-empty? x "crossref")
+                                            (bib-new-list-spc `(,(bib-new-sentence `(,(bib-format-in-ed-booktitle x)
+                                                                                     ,(bib-format-editor x)
+                                                                                     ,(bib-format-volume-or-number x)
+                                                                                     ,(bib-format-field x
+                                                                                        "organization")
+                                                                                     ,(bib-format-field x
+                                                                                        "publisher")
+                                                                                     ,(bib-format-pages x)))))
+                                            (bib-new-sentence `((concat ,(bib-translate "in ")
+                                                                  (cite ,(bib-field x
+                                                                           "crossref")))
+                                                                ,(bib-format-pages x)))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-manual n x)
+  (:mode bib-acm?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-format-author x))
+                          ,(bib-new-block (bib-new-sentence `(,(bib-emphasize (bib-format-field x
+                                                                                "title"))
+                                                              ,(bib-format-edition x)
+                                                              ,(bib-format-field x
+                                                                 "organization")
+                                                              ,(bib-format-field x
+                                                                 "address")
+                                                              ,(bib-format-date x))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-proceedings n x)
+  (:mode bib-acm?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (if (bib-empty? x "editor")
+                                            (bib-format-field x "organization")
+                                            (bib-format-editor x)))
+                          ,(bib-new-block (bib-new-sentence `((concat ,(bib-emphasize (bib-format-field x
+                                                                                        "title"))
+                                                                ," ("
+                                                                ,(bib-new-list ", "
+                                                                   `(,(bib-format-field x
+                                                                        "address")
+                                                                     ,(bib-format-date x)))
+                                                                ,")")
+                                                              ,(bib-format-volume-or-number x)
+                                                              ,(bib-format-field x
+                                                                 "organization")
+                                                              ,(bib-format-field x
+                                                                 "publisher"))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
diff --git a/TeXmacs/plugins/latex/progs/latex/bibtex-alpha.scm b/TeXmacs/plugins/latex/progs/latex/bibtex-alpha.scm
new file mode 100644
index 0000000000..d4bd744a49
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/bibtex-alpha.scm
@@ -0,0 +1,173 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : alpha.scm
+;; DESCRIPTION : alpha style for BibTeX files
+;; COPYRIGHT   : (C) 2010  David MICHEL
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex bibtex-alpha)
+  (:use (latex bibtex-bib-utils) (latex bibtex-plain))
+) ;texmacs-module
+
+(bib-define-style "alpha" "plain")
+
+(define (bib-format-label-year x)
+  (if (bib-empty? x "year")
+    ""
+    (let* ((y (bib-field x "year")) (l (string-length y)))
+      (if (<= l 2) y (substring y (- l 2) l))
+    ) ;let*
+  ) ;if
+) ;define
+
+(define (bib-format-label-names a)
+  (if (or (bib-null? a) (nlist? a))
+    ""
+    (let* ((n (length a))
+           (pre (cond ((equal? n 2)
+                       (with von
+                         (bib-purify (bib-abbreviate (list-ref (list-ref a 1) 2) "" ""))
+                         (if (bib-null? von)
+                           (bib-prefix (list-ref (list-ref a 1) 3) 3)
+                           (string-append von (bib-prefix (list-ref (list-ref a 1) 3) 1))
+                         ) ;if
+                       ) ;with
+                      ) ;
+                      (else (with lab
+                              ""
+                              (do ((i 1 (+ 1 i)))
+                                ((>= i (min n (if (= 5 n) 5 4))))
+                                (with von
+                                  (bib-purify (bib-abbreviate (list-ref (list-ref a i) 2) "" ""))
+                                  (set! lab (string-append lab von (bib-prefix (list-ref (list-ref a i) 3) 1)))
+                                ) ;with
+                              ) ;do
+                              lab
+                            ) ;with
+                      ) ;else
+                ) ;cond
+           ) ;pre
+          ) ;
+      (if (> n 5) (string-append pre "+") pre)
+    ) ;let*
+  ) ;if
+) ;define
+
+(define (bib-format-book-inbook-label n x)
+  (with key
+    (list-ref x 2)
+    (if (bib-empty? x "author")
+      (if (bib-empty? x "editor")
+        (if (bib-null? key) (number->string n) (bib-prefix key 3))
+        (bib-format-label-names (bib-field x "editor"))
+      ) ;if
+      (bib-format-label-names (bib-field x "author"))
+    ) ;if
+  ) ;with
+) ;define
+
+(define (bib-format-proceedings-misc-label ae n x)
+  (with key
+    (list-ref x 2)
+    (if (bib-empty? x ae)
+      (if (bib-null? key) (number->string n) (bib-prefix key 3))
+      (bib-format-label-names (bib-field x ae))
+    ) ;if
+  ) ;with
+) ;define
+
+(define (bib-format-label-prefix n x)
+  (let* ((doctype (list-ref x 1))
+         (pre (cond ((or (equal? doctype "book") (equal? doctype "inbook"))
+                     (bib-format-book-inbook-label n x)
+                    ) ;
+                    ((equal? doctype "proceedings")
+                     (bib-format-proceedings-misc-label "editor" n x)
+                    ) ;
+                    (else (bib-format-proceedings-misc-label "author" n x))
+              ) ;cond
+         ) ;pre
+        ) ;
+    (string-append pre (bib-format-label-year x))
+  ) ;let*
+) ;define
+
+(define bib-label-table ())
+
+(define bib-key-table ())
+
+(tm-define (bib-preprocessing t)
+  (:mode bib-alpha?)
+  (set! bib-label-table (s7-make-hash-table 100))
+  (set! bib-key-table (s7-make-hash-table 100))
+  (do ((entry t (cdr entry)) (n 1 (+ n 1)))
+    ((null? entry))
+    (if (func? (car entry) 'bib-entry)
+      (let* ((label (bib-format-label-prefix 0 (car entry)))
+             (num (ahash-ref bib-label-table label))
+            ) ;
+        (ahash-set! bib-key-table (list-ref (car entry) 2) label)
+        (if num
+          (ahash-set! bib-label-table
+            label
+            (if (equal? num ()) '(1 2) `(,@num ,(+ 1 (length num))))
+          ) ;ahash-set!
+          (ahash-set! bib-label-table label ())
+        ) ;if
+      ) ;let*
+    ) ;if
+  ) ;do
+) ;tm-define
+
+(define (bib-format-label n x)
+  (let* ((pre (ahash-ref bib-key-table (list-ref x 2)))
+         (num (ahash-ref bib-label-table pre))
+        ) ;
+    (if (null? num)
+      pre
+      (with n
+        (car num)
+        (ahash-set! bib-label-table pre (cdr num))
+        (string-append pre (string (integer->char (+ 96 n))))
+      ) ;with
+    ) ;if
+  ) ;let*
+) ;define
+
+(tm-define (bib-format-bibitem n x)
+  (:mode bib-alpha?)
+  `(bibitem* ,(bib-format-label n x))
+) ;tm-define
+
+(define (invert-label l)
+  (with invert
+    (lambda (c)
+      (cond ((char-upper-case? c) (char-downcase c))
+            ((char-lower-case? c) (char-upcase c))
+            (else c)
+      ) ;cond
+    ) ;lambda
+    (string-map invert l)
+  ) ;with
+) ;define
+
+(tm-define (bib-sort-key x)
+  (:mode bib-alpha?)
+  (let* ((auths (bib-format-label-names (bib-field x "author")))
+         (label (ahash-ref bib-key-table (list-ref x 2)))
+         (year (bib-field x "year"))
+         (lplain (bib-with-style "plain" bib-sort-key x))
+        ) ;
+    (string-append (string-upcase (if (bib-null? auths) label auths))
+      (if (bib-null? year) "" year)
+      "    "
+      lplain
+    ) ;string-append
+  ) ;let*
+) ;tm-define
diff --git a/TeXmacs/plugins/latex/progs/latex/bibtex-bib-complete.scm b/TeXmacs/plugins/latex/progs/latex/bibtex-bib-complete.scm
new file mode 100644
index 0000000000..e8e46fd8fc
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/bibtex-bib-complete.scm
@@ -0,0 +1,92 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : bib-complete.scm
+;; DESCRIPTION : Autocompletion of bibtex citekeys
+;; COPYRIGHT   : (C) 2013 Miguel de Benito Delgado
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex bibtex-bib-complete) (:use (utils library ptrees)))
+
+(define parse-times (make-ahash-table))
+
+(define parse-results (make-ahash-table))
+
+(define bib-files-cache (make-ahash-table))
+
+(define bib-styles-cache (make-ahash-table))
+
+(define (get-citekeys-list l)
+  (list-fold (lambda (entry rest)
+               (if (tm-func? entry 'bib-entry) (cons (caddr entry) rest) rest)
+             ) ;lambda
+    '()
+    l
+  ) ;list-fold
+) ;define
+
+(define (get-citekeys-pt u)
+  (let ((mod-time (url-last-modified u)) (parse-time (or (ahash-ref parse-times u) 0)))
+    (if (> mod-time parse-time)
+      (begin
+        (ahash-set! parse-times u mod-time)
+        (ahash-set! parse-results
+          u
+          (pt-add-list (make-ptree)
+            (get-citekeys-list (tree->stree (parse-bib (string-load u))))
+          ) ;pt-add-list
+        ) ;ahash-set!
+      ) ;begin
+    ) ;if
+    (ahash-ref parse-results u)
+  ) ;let
+) ;define
+
+(tm-define (current-bib-file usecache?)
+  (:synopsis "Returns the (cached) name of the bibliography file")
+  (with u
+    (current-buffer-url)
+    (or (and usecache? (ahash-ref bib-files-cache u))
+      (with l
+        (select (buffer-tree) '(:* bibliography))
+        (if (nnull? l)
+          (ahash-set! bib-files-cache
+            u
+            (url-append (url-head u) (tm->string (tree-ref (car l) 2)))
+          ) ;ahash-set!
+          (url-none)
+        ) ;if
+      ) ;with
+    ) ;or
+  ) ;with
+) ;tm-define
+
+(tm-define (current-bib-style usecache?)
+  (:synopsis "Returns the (cached) style of the bibliography")
+  (with u
+    (current-buffer-url)
+    (or (and usecache? (ahash-ref bib-styles-cache u))
+      (with l
+        (select (buffer-tree) '(:* bibliography))
+        (if (nnull? l)
+          (ahash-set! bib-styles-cache u (tm->string (tree-ref (car l) 1)))
+          "tm-plain"
+        ) ;if
+      ) ;with
+    ) ;or
+  ) ;with
+) ;tm-define
+
+(tm-define (citekey-list u s)
+  (:synopsis "Completions for @s in the bibtex file @u as a list")
+  (if (url-none? u) '() (pt-words-below (pt-find (get-citekeys-pt u) s)))
+) ;tm-define
+
+(tm-define (citekey-completions u t)
+  (:synopsis "Completions for @t in the bibtex file @u for custom-complete")
+  `(tuple ,t ,@(map string->tmstring (citekey-list u (tree->string t))))
+) ;tm-define
diff --git a/TeXmacs/plugins/latex/progs/latex/bibtex-bib-utils.scm b/TeXmacs/plugins/latex/progs/latex/bibtex-bib-utils.scm
new file mode 100644
index 0000000000..6c28fcc4f3
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/bibtex-bib-utils.scm
@@ -0,0 +1,221 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : bib-utils.scm
+;; DESCRIPTION : helper functions for BibTeX styles
+;; COPYRIGHT   : (C) 2010, 2015  David MICHEL, Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex bibtex-bib-utils))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Private administrative functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define bib-current-prefix "bib")
+(tm-define bib-style "plain")
+(tm-define bib-default-style "plain")
+
+(tm-define (bib-label what)
+  `(label ,(string-append bib-current-prefix "-" what))
+) ;tm-define
+
+(tm-define (bib-preprocessing t) (noop))
+
+(tm-define (bib-sort-key x) "")
+
+(tm-define (bib-mode? s) (or (equal? bib-style s) (equal? bib-default-style s)))
+
+(define (format-entries n x)
+  (if (and (list? x) (nnull? x))
+    (cons (bib-format-entry n (car x)) (format-entries (+ n 1) (cdr x)))
+    ()
+  ) ;if
+) ;define
+
+(define (bib-with-sort-key t)
+  (if (null? t)
+    ()
+    (cons `(,(bib-sort-key (car t)) ,(car t)) (bib-with-sort-key (cdr t)))
+  ) ;if
+) ;define
+
+(define (bib-without-sort-key t)
+  (if (null? t) () (cons (cadar t) (bib-without-sort-key (cdr t))))
+) ;define
+
+(define (bib-compare x y)
+  (tmstring-before? (car x) (car y))
+) ;define
+
+(tm-define (bib-sorted-entries l)
+  ;; redefine when (e.g.) sorting should be disabled
+  (with is-entry?
+    (lambda (x) (func? x 'bib-entry))
+    (with l1
+      (list-filter l is-entry?)
+      (with l2
+        (list-sort (bib-with-sort-key l1) bib-compare)
+        (bib-without-sort-key l2)
+      ) ;with
+    ) ;with
+  ) ;with
+) ;tm-define
+
+(tm-define (bib-process prefix style t)
+  (set! bib-current-prefix prefix)
+  (set! bib-style style)
+  (bib-preprocessing (cdr t))
+  (if (and (list? t) (func? t 'document))
+    (with ts
+      (bib-sorted-entries (cdr t))
+      (bib-simplify `(bib-list ,(number->string (length ts))
+                       (document ,@(format-entries 1 ts)))
+      ) ;bib-simplify
+    ) ;with
+  ) ;if
+) ;tm-define
+
+(tm-define bib-functions-table (s7-make-hash-table 100))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Public functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (bib-standard-styles)
+  (list "tm-plain" "tm-abbrv" "tm-abstract" "tm-acm" "tm-alpha" "tm-elsart-num"
+    "tm-ieeetr" "tm-siam" "tm-unsrt" "tm-gbt7714-2015"
+    "tm-gbt7714-2015-author-year"
+  ) ;list
+) ;tm-define
+
+(tm-define-macro (bib-define-style s d)
+  (if (equal? s d)
+    `(begin
+       (set! bib-default-style ,s)
+       (texmacs-modes (,(string->symbol (string-append "bib-" s "%"))
+                       (bib-mode? ,s))))
+    `(begin
+       (set! bib-default-style ,d)
+       (texmacs-modes (,(string->symbol (string-append "bib-" s "%"))
+                       (bib-mode? ,s)
+                       ,(string->symbol (string-append "bib-" d "%")))))
+  ) ;if
+) ;tm-define-macro
+
+(tm-define (bib-with-style s f . args)
+  (with tmp-s
+    bib-style
+    (set! bib-style s)
+    (with res (apply f args) (set! bib-style tmp-s) res)
+  ) ;with
+) ;tm-define
+
+(tm-define (bib-car x) (if (pair? x) (car x) ""))
+
+(tm-define (bib-cdr x) (if (pair? x) (cdr x) ""))
+
+(tm-define (bib-null? x)
+  (cond ((tm-func? x 'with) (bib-null? (tm-ref x :last)))
+        ((list? x) (equal? x ()))
+        ((string? x) (equal? x ""))
+        ((symbol? x) (equal? (symbol->string x) ""))
+        (else #f)
+  ) ;cond
+) ;tm-define
+
+(tm-define (bib-simplify x) (tree->stree (tree-simplify (stree->tree x))))
+
+(tm-define (bib-new-block x)
+  (if (bib-null? x)
+    ""
+    `(concat ,(bib-add-period (bib-upcase-first x)) (newblock))
+  ) ;if
+) ;tm-define
+
+(tm-define (bib-new-case-preserved-block x)
+  (if (bib-null? x) "" `(concat ,(bib-add-period x) (newblock)))
+) ;tm-define
+
+(define (elim-empty x)
+  (if (bib-null? x)
+    ()
+    (if (bib-null? (car x)) (elim-empty (cdr x)) `(,(car x)
+                                                   ,@(elim-empty (cdr x))))
+  ) ;if
+) ;define
+
+(tm-define (new-list-rec s x)
+  ;; redefined in ieeetr.scm
+  (cond ((bib-null? x) "")
+        ((bib-null? (car x)) (new-list-rec s (cdr x)))
+        ((null? (cdr x)) `(concat ,(car x)))
+        ((and (tm-func? (car x) 'concat) (== (cAr (car x)) '(newblock)))
+         `(concat ,(cDr (car x)) ,s (newblock) ,(new-list-rec s (cdr x)))
+        ) ;
+        (else `(concat ,(car x) ,s ,(new-list-rec s (cdr x))))
+  ) ;cond
+) ;tm-define
+
+(tm-define (bib-new-list-spc x) (new-list-rec " " (elim-empty x)))
+
+(tm-define (bib-new-list c x) (new-list-rec c (elim-empty x)))
+
+(tm-define (bib-new-case-preserved-sentence x)
+  (bib-add-period (bib-new-list ", " x))
+) ;tm-define
+
+(tm-define (bib-new-sentence x)
+  (bib-add-period (bib-upcase-first (bib-new-list ", " x)))
+) ;tm-define
+
+(tm-define (bib-default-field x s)
+  (with e (bib-field x s) (if (bib-null? e) e (bib-default-upcase-first e)))
+) ;tm-define
+
+(tm-define (bib-format-field x s)
+  (with e (bib-field x s) (if (bib-null? e) "" (bib-default-upcase-first e)))
+) ;tm-define
+
+(tm-define (bib-format-field-preserve-case x s)
+  (with e (bib-field x s) (if (bib-null? e) "" (bib-default-preserve-case e)))
+) ;tm-define
+
+(tm-define (bib-format-field-locase-first x s)
+  (with e (bib-field x s) (if (bib-null? e) "" (bib-locase-first e)))
+) ;tm-define
+
+(tm-define (bib-format-field-Locase x s)
+  (with e (bib-field x s) (if (bib-null? e) "" (bib-upcase-first (bib-locase e))))
+) ;tm-define
+
+(tm-define (bib-emphasize x) `(with ,"font-shape" ,"italic" ,x))
+
+(tm-define (bib-translate s)
+  (if (== (get-env "bib-no-translate") "true") s `(localize ,s))
+) ;tm-define
+
+(tm-define bib-range-symbol "-")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Sample function
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (ext-first-last t)
+  (:secure #t)
+  (if (tree-compound? t)
+    t
+    (let* ((s (tree->string t))
+           (i (string-search-forwards " " 0 s))
+           (m (number->string i))
+           (e (number->string (string-length s)))
+          ) ;
+      (if (< i 0) t `(concat (range ,t ,"0" ,m) (name (range ,t ,m ,e))))
+    ) ;let*
+  ) ;if
+) ;tm-define
diff --git a/TeXmacs/plugins/latex/progs/latex/bibtex-bib-widgets.scm b/TeXmacs/plugins/latex/progs/latex/bibtex-bib-widgets.scm
new file mode 100644
index 0000000000..93d40600bb
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/bibtex-bib-widgets.scm
@@ -0,0 +1,241 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : bib-widgets.scm
+;; DESCRIPTION : Widgets for bibliography
+;; COPYRIGHT   : (C) 2014 Miguel de Benito Delgado
+;;                   2026 Yuki Lu
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; TODO:
+;;  - Handle external BibTeX.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex bibtex-bib-widgets)
+  (:use (latex bibtex-bib-complete)
+    (latex bibtex-bib-utils)
+    (generic document-edit)
+  ) ;:use
+) ;texmacs-module
+
+(define bibwid-url (string->url ""))
+
+(define bibwid-style "tm-plain")
+
+(define bibwid-default-style "tm-plain")
+
+(define bibwid-use-relative? #t)
+
+(define bibwid-update-buffer? #t)
+
+(define bibwid-buffer (string->url ""))
+
+(define (bibwid-set-url u)
+  (cond ((and (== bibwid-use-relative? #t) (url-rooted? u))
+         (set! bibwid-url (url-delta bibwid-buffer u))
+        ) ;
+        ((and (== bibwid-use-relative? #f) (not (url-rooted? u)))
+         (set! bibwid-url (url-append (url-head bibwid-buffer) u))
+        ) ;
+        (else (set! bibwid-url u))
+  ) ;cond
+) ;define
+
+(define (safe-bib-standard-styles)
+  (catch #t (lambda () (bib-standard-styles)) (lambda (key . args) '("tm-plain")))
+) ;define
+
+(define (bibwid-set-style answer)
+  (let ((styles (safe-bib-standard-styles)))
+    (if (and (string? answer) (in? answer styles))
+      (set! bibwid-style answer)
+      (set! bibwid-style bibwid-default-style)
+    ) ;if
+  ) ;let
+  (refresh-now "bibwid-preview")
+) ;define
+
+(define (bibwid-preview-bg-color)
+  (if (== (get-preference "gui theme") "liii-night") "#202020" "#ffffff")
+) ;define
+
+(define (bibwid-preview-fg-color)
+  (if (== (get-preference "gui theme") "liii-night") "#ffffff" "#000000")
+) ;define
+
+(define (bibwid-output-content t style)
+  (if (tree-is? t 'string)
+    `(with ,"bg-color"
+       ,(bibwid-preview-bg-color)
+       ,"color"
+       ,(bibwid-preview-fg-color)
+       (mini-paragraph ,"1250px"
+         (document ,(replace "Please choose a valid %1 file" "BibTeX"))))
+    `(with ,"bg-color"
+       ,(bibwid-preview-bg-color)
+       ,"color"
+       ,(bibwid-preview-fg-color)
+       (mini-paragraph ,"1250px" ,(bib-process "bib" style (tree->stree t))))
+  ) ;if
+) ;define
+
+(define (bibwid-output)
+  (with style
+    (if (and (>= (string-length bibwid-style) 3)
+          (== "tm-" (string-take bibwid-style 3))
+        ) ;and
+      (string-drop bibwid-style 3)
+      bibwid-style
+    ) ;if
+    (when (== style "")
+      (set! style bibwid-default-style)
+    ) ;when
+    (catch #t
+      (lambda () (eval '(use-modules (latex bibtex-, (string->symbol style)))))
+      (lambda (key . args) (noop))
+    ) ;catch
+    (with u
+      (if (and bibwid-use-relative? (not (url-rooted? bibwid-url)))
+        (url-append (url-head bibwid-buffer) bibwid-url)
+        bibwid-url
+      ) ;if
+      (with t
+        (if (url-exists? u) (parse-bib (string-load u)) (tree ""))
+        (stree->tree (bibwid-output-content t style))
+      ) ;with
+    ) ;with
+  ) ;with
+) ;define
+
+(define (bibwid-insert doit?)
+  (when doit?
+    (if (not (make-return-after))
+      (insert (list 'bibliography "bib" bibwid-style (url->string bibwid-url) '(document ""))
+      ) ;insert
+    ) ;if
+    (if bibwid-update-buffer? (update-document "bibliography"))
+  ) ;when
+) ;define
+
+(define (bibwid-modify doit?)
+  (when doit?
+    (with l
+      (select (buffer-tree) '(:* bibliography))
+      (when (> (length l) 0)
+        (with t
+          (car l)
+          (tree-set! t 1 bibwid-style)
+          (tree-set! t 2 (url->string bibwid-url))
+          (if bibwid-update-buffer? (update-document "bibliography"))
+        ) ;with
+      ) ;when
+    ) ;with
+  ) ;when
+) ;define
+
+(define (bibwid-set-filename u)
+  (bibwid-set-url u)
+  (refresh-now "bibwid-file-input")
+  (refresh-now "bibwid-preview")
+) ;define
+
+(define (bibwid-set-relative val)
+  (set! bibwid-use-relative? val)
+  (bibwid-set-filename bibwid-url)
+) ;define
+
+(tm-widget (bibwid-preview)
+  (resize '("520px" "520px" "9999px")
+    '("100px" "100px" "9999px")
+    (scrollable (refreshable "bibwid-preview"
+                  (texmacs-output (bibwid-output) '(style "generic"))
+                ) ;refreshable
+    ) ;scrollable
+  ) ;resize
+) ;tm-widget
+
+(tm-widget ((bibliography-widget modify? msg) cmd)
+  (padded (hlist >>> (text msg) >>>)
+    ===
+    (hlist (text "File:")
+      //
+      //
+      (refreshable "bibwid-file-input"
+        (hlist (input (when (and answer (!= answer (url->string bibwid-url)))
+                        (bibwid-set-url (string->url answer))
+                        (refresh-now "bibwid-preview")
+                      ) ;when
+                 "file"
+                 (list (url->string bibwid-url))
+                 "40em"
+               ) ;input
+          //
+          //
+          (explicit-buttons ("" (choose-file bibwid-set-filename "Choose" "tmbib")))
+        ) ;hlist
+      ) ;refreshable
+    ) ;hlist
+    ===
+    (hlist (text "Use relative path:")
+      //
+      (toggle (bibwid-set-relative answer) bibwid-use-relative?)
+      //
+      //
+      (text "Update buffer:")
+      //
+      (toggle (set! bibwid-update-buffer? answer) bibwid-update-buffer?)
+      //
+      //
+      (text "Style:")
+      //
+      //
+      (verb (enum (bibwid-set-style answer) (safe-bib-standard-styles) bibwid-style "10em")
+      ) ;verb
+    ) ;hlist
+    ===
+    (hlist // (dynamic (bibwid-preview)) //)
+    ===
+    (bottom-buttons >>>
+     ("Cancel" (cmd #f))
+     //
+     //
+     (if modify? ("Modify" (cmd #t)))
+     (if (not modify?) ("Insert" (cmd #t)))
+    ) ;bottom-buttons
+  ) ;padded
+) ;tm-widget
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Interface
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (open-bibliography-inserter)
+  (set! bibwid-buffer (current-buffer))
+  (let ((u (current-bib-file #f)) (s (current-bib-style #f)))
+    (if (and (not (url-none? u)) (!= s ""))
+      (with msg
+        (translate "Modifying bibliography in the current document")
+        (bibwid-set-url u)
+        (set! bibwid-style s)
+        (dialogue-window (bibliography-widget #t msg)
+          bibwid-modify
+          "Modify bibliography"
+        ) ;dialogue-window
+      ) ;with
+      (with msg
+        (translate "Inserting bibliography in the current document")
+        (bibwid-set-url (string->url ""))
+        (set! bibwid-style "tm-plain")
+        (dialogue-window (bibliography-widget #f msg)
+          bibwid-insert
+          "Insert bibliography"
+        ) ;dialogue-window
+      ) ;with
+    ) ;if
+  ) ;let
+) ;tm-define
diff --git a/TeXmacs/plugins/latex/progs/latex/bibtex-elsart-num.scm b/TeXmacs/plugins/latex/progs/latex/bibtex-elsart-num.scm
new file mode 100644
index 0000000000..fcd6493a03
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/bibtex-elsart-num.scm
@@ -0,0 +1,349 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : elsart-num.scm
+;; DESCRIPTION : elsart-num style for BibTeX files
+;; COPYRIGHT   : (C) 2010, 2015  David MICHEL, Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex bibtex-elsart-num)
+  (:use (latex bibtex-bib-utils) (latex bibtex-plain))
+) ;texmacs-module
+
+(bib-define-style "elsart-num" "plain")
+
+(tm-define (bib-sorted-entries l)
+  (:mode bib-elsart-num?)
+  (with is-entry? (lambda (x) (func? x 'bib-entry)) (list-filter l is-entry?))
+) ;tm-define
+
+(tm-define (bib-format-name x)
+  (:mode bib-elsart-num?)
+  (let* ((f (if (bib-null? (list-ref x 1))
+              ""
+              `(concat ,(bib-abbreviate (list-ref x 1) "." '(nbsp)) (nbsp))
+            ) ;if
+         ) ;f
+         (vv (if (bib-null? (list-ref x 2)) "" `(concat ,(list-ref x 2) (nbsp))))
+         (ll (if (bib-null? (list-ref x 3)) "" (bib-purify (list-ref x 3))))
+         (jj (if (bib-null? (list-ref x 4)) "" `(concat ,", " ,(list-ref x 4))))
+        ) ;
+    `(concat ,f ,vv ,ll ,jj)
+  ) ;let*
+) ;tm-define
+
+(tm-define (bib-last-name-sep a) (:mode bib-elsart-num?) ", ")
+
+(tm-define (bib-format-editor x)
+  (:mode bib-elsart-num?)
+  (let* ((a (bib-field x "editor")))
+    (if (or (bib-null? a) (nlist? a))
+      ""
+      (if (equal? (length a) 2)
+        `(concat ,(bib-format-names a) ,(bib-translate " (Ed.)"))
+        `(concat ,(bib-format-names a) ,(bib-translate " (Eds.)"))
+      ) ;if
+    ) ;if
+  ) ;let*
+) ;tm-define
+
+(define (bib-format-edition x)
+  (let* ((e (bib-field x "edition")))
+    (if (bib-null? e) "" `(concat ,e ," Edition"))
+  ) ;let*
+) ;define
+
+(define (bib-format-volume-or-number x)
+  (let* ((v (bib-field x "volume"))
+         (n (bib-field x "number"))
+         (s (bib-field x "series"))
+        ) ;
+    (if (bib-null? v)
+      (if (bib-null? n)
+        (if (bib-null? s) "" s)
+        (let ((series (if (bib-null? s) "" `(concat ,(bib-translate " in ") ,s)))
+              (sep (if (< (bib-text-length n) 3) '(nbsp) " "))
+             ) ;
+          `(concat ,"No." ,sep ,n ,series)
+        ) ;let
+      ) ;if
+      (let ((series (if (bib-null? s) "" `(concat ,(bib-translate " of ") ,s)))
+            (sep (if (< (bib-text-length v) 3) '(nbsp) " "))
+           ) ;
+        `(concat ,"Vol." ,sep ,v ,series)
+      ) ;let
+    ) ;if
+  ) ;let*
+) ;define
+
+(tm-define (bib-format-pages x)
+  (:mode bib-elsart-num?)
+  (let* ((p (bib-field x "pages")))
+    (cond ((or (bib-null? p) (nlist? p)) "")
+          ((== (length p) 1) "")
+          ((== (length p) 2) `(concat ,(bib-translate "p.")
+                                (nbsp)
+                                ,(list-ref p 1)))
+          (else `(concat ,(bib-translate "pp.")
+                   (nbsp)
+                   ,(list-ref p 1)
+                   ,bib-range-symbol
+                   ,(list-ref p 2))
+          ) ;else
+    ) ;cond
+  ) ;let*
+) ;tm-define
+
+(tm-define (bib-format-vol-num-pages x)
+  (:mode bib-elsart-num?)
+  (let* ((j (bib-field x "journal"))
+         (v (bib-field x "volume"))
+         (n (bib-field x "number"))
+         (y `(concat ,"(" ,(bib-field x "year") ,")"))
+         (p (let* ((pp (bib-field x "pages")))
+              (cond ((or (bib-null? pp) (nlist? pp)) "")
+                    ((equal? 1 (length pp)) "")
+                    ((equal? 2 (length pp)) (list-ref pp 1))
+                    (else `(concat ,(list-ref pp 1)
+                             ,bib-range-symbol
+                             ,(list-ref pp 2)))
+              ) ;cond
+            ) ;let*
+         ) ;p
+        ) ;
+    (when (not (bib-null? n))
+      (set! v `(concat ,v (nbsp) ,"(" ,n ,")"))
+    ) ;when
+    (bib-new-list " " `(,j ,v ,y ,p))
+  ) ;let*
+) ;tm-define
+
+(define (bib-format-note x)
+  (bib-format-field-locase-first x "note")
+) ;define
+
+(tm-define (bib-format-article n x)
+  (:mode bib-elsart-num?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-block (bib-new-sentence `(,(bib-format-author x)
+                                         ,(bib-format-field-Locase x "title")
+                                         ,@(if (bib-empty? x "crossref")
+                                             `(,(bib-format-vol-num-pages x))
+                                             `((concat ,(bib-translate "in ")
+                                                 (cite ,(bib-field x "crossref")))
+                                               ,(bib-format-pages x)))
+                                         ,(bib-format-note x)))))
+) ;tm-define
+
+(tm-define (bib-format-book n x)
+  (:mode bib-elsart-num?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-block (bib-new-sentence `(,(if (bib-empty? x "author")
+                                            (bib-format-editor x)
+                                            (bib-format-author x))
+                                         ,(bib-format-field x "title")
+                                         ,(bib-format-edition x)
+                                         ,@(if (bib-empty? x "crossref")
+                                             `(,(bib-format-volume-or-number x)
+                                               ,(bib-format-field x "publisher")
+                                               ,(bib-format-field x "address"))
+                                             `((concat ,(bib-translate "in ")
+                                                 (cite ,(bib-field x "crossref")))
+                                               ,(bib-format-edition x)))
+                                         ,(bib-format-field x "year")
+                                         ,(bib-format-note x)))))
+) ;tm-define
+
+(tm-define (bib-format-booklet n x)
+  (:mode bib-elsart-num?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-block (bib-new-case-preserved-sentence `(,(bib-format-author x)
+                                                        ,(bib-format-field-Locase x
+                                                           "title")
+                                                        ,(bib-format-field-preserve-case x
+                                                           "howpublished")
+                                                        ,(bib-format-field x
+                                                           "address")
+                                                        (concat ,(if (bib-empty? x
+                                                                       "note")
+                                                                   ""
+                                                                   `(concat ,(bib-format-note x)
+                                                                      ," "))
+                                                          ,"("
+                                                          ,(bib-format-date x)
+                                                          ,")")))))
+) ;tm-define
+
+(tm-define (bib-format-inbook n x)
+  (:mode bib-elsart-num?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-block (bib-new-sentence `(,(if (bib-empty? x "author")
+                                            (bib-format-editor x)
+                                            (bib-format-author x))
+                                         ,(bib-format-field x "title")
+                                         ,@(if (bib-empty? x "crossref")
+                                             `(,(bib-format-edition x)
+                                               ,(bib-format-volume-or-number x)
+                                               ,(bib-format-field x "publisher")
+                                               ,(bib-format-field x "address")
+                                               ,(bib-format-field x "year")
+                                               ,(bib-format-chapter-pages x))
+                                             `((concat ,(bib-translate "in ")
+                                                 (cite ,(bib-field x "crossref")))
+                                               ,(bib-format-field x "edition")
+                                               ,(bib-format-field x "year")))
+                                         ,(bib-format-note x)))))
+) ;tm-define
+
+(tm-define (bib-format-incollection n x)
+  (:mode bib-elsart-num?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-block (bib-new-sentence `(,(bib-format-author x)
+                                         ,(bib-format-field-Locase x "title")
+                                         ,@(if (bib-empty? x "crossref")
+                                             `((concat ,(bib-translate "in: ")
+                                                 ,(bib-format-editor x))
+                                               ,(bib-format-field x "booktitle")
+                                               ,(bib-format-edition x)
+                                               ,(bib-format-volume-or-number x)
+                                               ,(bib-format-field x "publisher")
+                                               ,(bib-format-field x "address")
+                                               ,(bib-format-field x "year"))
+                                             `((concat ,(bib-translate "in ")
+                                                 (cite ,(bib-field x "crossref")))))
+                                         ,(bib-format-chapter-pages x)
+                                         ,(bib-format-note x)))))
+) ;tm-define
+
+(tm-define (bib-format-inproceedings n x)
+  (:mode bib-elsart-num?)
+  (bib-format-incollection n x)
+) ;tm-define
+
+(tm-define (bib-format-manual n x)
+  (:mode bib-elsart-num?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-block (bib-new-sentence `(,@(if (bib-empty? x "author")
+                                             (if (bib-empty? x "organization")
+                                               ()
+                                               `(,(bib-format-field x
+                                                    "organization")
+                                                 ,(bib-format-field x "address")))
+                                             `(,(bib-format-author x)))
+                                         ,(bib-format-field x "title")
+                                         ,(bib-format-field x "organization")
+                                         ,(bib-format-field x "address")
+                                         ,(bib-format-edition x)
+                                         (concat ,(if (bib-empty? x "note")
+                                                    ""
+                                                    `(concat ,(bib-format-note x)
+                                                       ," "))
+                                           ,"("
+                                           ,(bib-format-date x)
+                                           ,")")))))
+) ;tm-define
+
+(tm-define (bib-format-mastersthesis n x)
+  (:mode bib-elsart-num?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-block (bib-new-sentence `(,(bib-format-author x)
+                                         ,(bib-format-field-Locase x "title")
+                                         ,(if (bib-empty? x "type")
+                                            (bib-translate "Master's thesis")
+                                            (bib-format-field x "type"))
+                                         ,(bib-format-field x "school")
+                                         ,(bib-format-field x "address")
+                                         (concat ,(if (bib-empty? x "note")
+                                                    ""
+                                                    `(concat ,(bib-format-note x)
+                                                       ," "))
+                                           ,"("
+                                           ,(bib-format-date x)
+                                           ,")")))))
+) ;tm-define
+
+(tm-define (bib-format-misc n x)
+  (:mode bib-plain?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-block (bib-new-sentence `(,(bib-format-author x)
+                                         ,(bib-format-field-Locase x "title")
+                                         ,(bib-format-field-preserve-case x
+                                            "howpublished")
+                                         (concat ,(if (bib-empty? x "note")
+                                                    ""
+                                                    `(concat ,(bib-format-note x)
+                                                       ," "))
+                                           ,"("
+                                           ,(bib-format-date x)
+                                           ,")")))))
+) ;tm-define
+
+(tm-define (bib-format-phdthesis n x)
+  (:mode bib-elsart-num?)
+  (bib-format-mastersthesis n x)
+) ;tm-define
+
+(tm-define (bib-format-proceedings n x)
+  (:mode bib-elsart-num?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-block (bib-new-sentence `(,(if (bib-empty? x "editor")
+                                            (bib-format-field x "organization")
+                                            (bib-format-editor x))
+                                         ,(bib-format-field x "title")
+                                         ,(bib-format-volume-or-number x)
+                                         ,(if (bib-empty? x "editor")
+                                            ""
+                                            (bib-format-field x "organization"))
+                                         ,(bib-format-field x "publisher")
+                                         ,(bib-format-field x "address")
+                                         ,(bib-format-field x "year")
+                                         ,(bib-format-note x)))))
+) ;tm-define
+
+(tm-define (bib-format-techreport n x)
+  (:mode bib-elsart-num?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-block (bib-new-sentence `(,(bib-format-author x)
+                                         ,(bib-format-field-Locase x "title")
+                                         ,(bib-format-tr-number x)
+                                         ,(bib-format-field x "institution")
+                                         ,(bib-format-field x "address")
+                                         (concat ,(if (bib-empty? x "note")
+                                                    ""
+                                                    `(concat ,(bib-format-note x)
+                                                       ," "))
+                                           ,"("
+                                           ,(bib-format-date x)
+                                           ,")")))))
+) ;tm-define
+
+(tm-define (bib-format-unpublished n x)
+  (:mode bib-elsart-num?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,:promptrepl
+     ,(bib-new-block (bib-new-sentence `(,(bib-format-author x)
+                                         ,(bib-format-field-Locase x "title")
+                                         (concat ,(if (bib-empty? x "note")
+                                                    ""
+                                                    `(concat ,(bib-format-note x)
+                                                       ," "))
+                                           ,"("
+                                           ,(bib-format-date x)
+                                           ,")")))))
+) ;tm-define
diff --git a/TeXmacs/plugins/latex/progs/latex/bibtex-format.scm b/TeXmacs/plugins/latex/progs/latex/bibtex-format.scm
new file mode 100644
index 0000000000..219f06b573
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/bibtex-format.scm
@@ -0,0 +1,61 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : bibtex.scm
+;; DESCRIPTION : bibtex data plugin
+;; COPYRIGHT   : (C) 2010, 2014  David MICHEL and Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex bibtex-format))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Raw BibTeX, as implemented by David Michel
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-format bibtex (:name "RawBibTeX") (:suffix "rawbib") (:hidden))
+
+(lazy-define (latex convert-bibtex-bibtextm) parse-bibtex-snippet)
+(lazy-define (latex convert-bibtex-bibtextm) parse-bibtex-document)
+(lazy-define (latex convert-bibtex-bibtextm) bibtex->texmacs)
+(lazy-define (latex convert-bibtex-bibtexout) serialize-bibtex)
+(lazy-define (latex convert-bibtex-tmbibtex) texmacs->bibtex)
+
+(converter bibtex-snippet bibtex-stree (:function parse-bibtex-snippet))
+
+(converter bibtex-document bibtex-stree (:function parse-bibtex-document))
+
+(converter bibtex-stree texmacs-stree (:function bibtex->texmacs))
+
+(converter bibtex-stree bibtex-document (:function serialize-bibtex))
+
+(converter bibtex-stree bibtex-snippet (:function serialize-bibtex))
+
+(converter texmacs-stree bibtex-stree (:function texmacs->bibtex))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; BibTeX, presented using the TeXmacs database format
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-format tmbib (:name "BibTeX") (:suffix "bib"))
+
+(lazy-define (database bib-db) tmbib-snippet->texmacs)
+(lazy-define (database bib-db) tmbib-document->texmacs)
+(lazy-define (database bib-db) texmacs->tmbib-snippet)
+(lazy-define (database bib-db) texmacs->tmbib-document)
+
+(converter tmbib-snippet texmacs-stree (:function tmbib-snippet->texmacs))
+
+(converter tmbib-document texmacs-stree (:function tmbib-document->texmacs))
+
+(converter texmacs-stree tmbib-snippet (:function texmacs->tmbib-snippet))
+
+(converter texmacs-stree tmbib-document (:function texmacs->tmbib-document))
+
+(define-preferences ("bibtex->texmacs:conservative" "on" noop)
+ ("texmacs->bibtex:conservative" "on" noop)
+) ;define-preferences
diff --git a/TeXmacs/plugins/latex/progs/latex/bibtex-gbt7714-2015-author-year.scm b/TeXmacs/plugins/latex/progs/latex/bibtex-gbt7714-2015-author-year.scm
new file mode 100644
index 0000000000..6d42a43c1f
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/bibtex-gbt7714-2015-author-year.scm
@@ -0,0 +1,1382 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : gbt7714-2015-author-year.scm
+;; DESCRIPTION : GBT 7714-2015-author-year style for BibTeX files
+;; COPYRIGHT   : (C) 2026 Yuki Lu
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex bibtex-gbt7714-2015-author-year)
+  (:use (latex bibtex-bib-utils) (latex bibtex-plain))
+) ;texmacs-module
+
+(bib-define-style "gbt7714-2015-author-year" "gbt7714-2015-author-year")
+
+;; 哈希表用于存储年份后缀
+
+(define gbt-year-suffix-table #f)
+
+(define gbt-author-year-count-table #f)
+
+;; 安全字符串转换：确保值转换为字符串，如果为#f则返回空字符串
+
+(define (safe-tm->string x)
+  (cond ((string? x) x)
+        ((not x) "")
+        (else (let ((result (tm->string x))) (if result result "")))
+  ) ;cond
+) ;define
+
+;; 获取作者键字符串（用于生成哈希表键）
+
+(define (gbt-get-author-key-string x)
+  (let* ((field-info (gbt-get-author-field x))
+         (field-type (car field-info))
+         (field-list (cdr field-info))
+         (has-author (not (equal? field-type 'empty)))
+         (chinese? (if has-author (authors-contain-chinese? field-list) #f))
+        ) ;
+    (if has-author
+      (let* ((n (length field-list)) (author-count (- n 1)))
+        ;; 辅助函数：提取作者姓氏（英文）或完整姓名（中文）
+        (define (get-author-key i)
+          (let ((author (list-ref field-list i)))
+            (if chinese?
+              ;; 中文：使用bib-format-name获取完整姓名
+              (let ((formatted-name (bib-format-name author)))
+                (cond ((string? formatted-name) formatted-name)
+                      ((not formatted-name) "")
+                      (else (safe-tm->string formatted-name))
+                ) ;cond
+              ) ;let
+              ;; 英文：只提取姓氏
+              (let ((last-name-raw (list-ref author 3)))
+                (if (bib-null? last-name-raw)
+                  ""
+                  (let ((last-name (bib-purify last-name-raw)))
+                    (cond ((string? last-name) last-name)
+                          ((not last-name) "")
+                          (else (safe-tm->string last-name))
+                    ) ;cond
+                  ) ;let
+                ) ;if
+              ) ;let
+            ) ;if
+          ) ;let
+        ) ;define
+        (cond
+          ;; 作者数 ≥ 3：显示第一位 + et al/等
+          ((>= author-count 3)
+           (let ((first (get-author-key 1)))
+             (if chinese? (string-append first "<#7b49>") (string-append first " et al."))
+           ) ;let
+          ) ;
+          ;; 作者数 = 2：显示两位，用"and"或"和"连接
+          ((= author-count 2)
+           (let ((first (get-author-key 1)) (second (get-author-key 2)))
+             (if chinese?
+               (string-append first "<#548C>" second)
+               (string-append first " & " second)
+             ) ;if
+           ) ;let
+          ) ;
+          ;; 作者数 = 1：显示一位
+          ((= author-count 1) (get-author-key 1))
+          ;; 其他情况
+          (else "")
+        ) ;cond
+      ) ;let*
+      ""
+    ) ;if
+  ) ;let*
+) ;define
+
+;; 预处理函数：计算同一年同一作者文献的年份后缀
+(tm-define (bib-preprocessing t)
+  (:mode bib-gbt7714-2015-author-year?)
+  ;; 初始化哈希表
+  (set! gbt-year-suffix-table (s7-make-hash-table 100))
+  (set! gbt-author-year-count-table (s7-make-hash-table 100))
+  ;; 第一遍：统计每个作者-年份组合的文献数量（所有条目）
+  (for-each (lambda (entry)
+              (when (func? entry 'bib-entry)
+                (let* ((author-short (gbt-get-author-key-string entry))
+                       (year-raw (bib-field entry "year"))
+                       (year-expr (cond ((bib-null? year-raw) "?")
+                                        ((string? year-raw) year-raw)
+                                        ((not year-raw) "?")
+                                        (else (safe-tm->string year-raw))
+                                  ) ;cond
+                       ) ;year-expr
+                       (year (cond ((string? year-expr) year-expr)
+                                   ((not year-expr) "?")
+                                   (else (safe-tm->string year-expr))
+                             ) ;cond
+                       ) ;year
+                       (author-year-key (string-append author-short ":" year))
+                      ) ;
+                  (ahash-set! gbt-author-year-count-table
+                    author-year-key
+                    (+ 1 (or (ahash-ref gbt-author-year-count-table author-year-key) 0))
+                  ) ;ahash-set!
+                ) ;let*
+              ) ;when
+            ) ;lambda
+    t
+  ) ;for-each
+  ;; 第二遍：按排序顺序分配后缀
+  (let ((sorted-entries (bib-sorted-entries t)))
+    (for-each (lambda (entry)
+                (when (func? entry 'bib-entry)
+                  (let* ((key (list-ref entry 2))
+                         (author-short (gbt-get-author-key-string entry))
+                         (year-raw (bib-field entry "year"))
+                         (year-expr (cond ((bib-null? year-raw) "?")
+                                          ((string? year-raw) year-raw)
+                                          ((not year-raw) "?")
+                                          (else (safe-tm->string year-raw))
+                                    ) ;cond
+                         ) ;year-expr
+                         (year (cond ((string? year-expr) year-expr)
+                                     ((not year-expr) "?")
+                                     (else (safe-tm->string year-expr))
+                               ) ;cond
+                         ) ;year
+                         (author-year-key (string-append author-short ":" year))
+                         (count (ahash-ref gbt-author-year-count-table author-year-key))
+                        ) ;
+                    (if (> count 1)
+                      ;; 需要后缀：分配a, b, c...
+                      ;; 使用哈希表记录已分配的后缀索引（按作者-年份组合）
+                      (let* ((suffix-index-key (string-append author-year-key ":index"))
+                             (next-index (or (ahash-ref gbt-year-suffix-table suffix-index-key) 0))
+                             (suffix-char (integer->char (+ 97 next-index)))
+                             (suffix (string suffix-char))
+                            ) ;
+                        (ahash-set! gbt-year-suffix-table key suffix)
+                        (ahash-set! gbt-year-suffix-table suffix-index-key (+ next-index 1))
+                      ) ;let*
+                      ;; 单一文献，无后缀
+                      (ahash-set! gbt-year-suffix-table key "")
+                    ) ;if
+                  ) ;let*
+                ) ;when
+              ) ;lambda
+      sorted-entries
+    ) ;for-each
+  ) ;let
+) ;tm-define
+
+;; 重写条目格式函数以支持所有文献类型
+(tm-define (bib-format-entry n x)
+  (:mode bib-gbt7714-2015-author-year?)
+  (if (and (list? x)
+        (func? x 'bib-entry)
+        (= (length x) 4)
+        (func? (list-ref x 3) 'document)
+      ) ;and
+    (with doctype
+      (list-ref x 1)
+      (gbt-remove-keepcase (cond ((equal? doctype "article") (bib-format-article n x))
+                                 ((equal? doctype "book") (bib-format-book n x))
+                                 ((equal? doctype "booklet") (bib-format-booklet n x))
+                                 ((equal? doctype "inbook") (bib-format-inbook n x))
+                                 ((equal? doctype "incollection") (bib-format-incollection n x))
+                                 ((equal? doctype "inproceedings") (bib-format-inproceedings n x))
+                                 ((equal? doctype "conference") (bib-format-inproceedings n x))
+                                 ((equal? doctype "manual") (bib-format-manual n x))
+                                 ((equal? doctype "mastersthesis") (bib-format-mastersthesis n x))
+                                 ((equal? doctype "misc") (bib-format-misc n x))
+                                 ((equal? doctype "phdthesis") (bib-format-phdthesis n x))
+                                 ((equal? doctype "proceedings") (bib-format-proceedings n x))
+                                 ((equal? doctype "techreport") (bib-format-techreport n x))
+                                 ((equal? doctype "unpublished") (bib-format-unpublished n x))
+                                 ;; GBT 7714-2015 新增类型
+                                 ((equal? doctype "standard") (bib-format-standard n x))
+                                 ((equal? doctype "database") (bib-format-database n x))
+                                 ((equal? doctype "software") (bib-format-software n x))
+                                 ((equal? doctype "program") (bib-format-program n x))
+                                 ((equal? doctype "archive") (bib-format-archive n x))
+                                 ((equal? doctype "map") (bib-format-map n x))
+                                 ((equal? doctype "dataset") (bib-format-dataset n x))
+                                 ((equal? doctype "electronic") (bib-format-electronic n x))
+                                 ((equal? doctype "online") (bib-format-online n x))
+                                 ((equal? doctype "newspaper") (bib-format-newspaper n x))
+                                 ((equal? doctype "collection") (bib-format-collection n x))
+                                 ((equal? doctype "patent") (bib-format-patent n x))
+                                 (else (bib-format-misc n x))
+                           ) ;cond
+      ) ;gbt-remove-keepcase
+    ) ;with
+  ) ;if
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; cite相关
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; 获取作者字段（优先使用author，如果没有则使用editor）
+
+(define (gbt-get-author-field x)
+  ;; editor和author同逻辑：优先使用author，没有author才使用editor
+  (let ((author-field (bib-field x "author")) (editor-field (bib-field x "editor")))
+    (cond ((not (or (bib-null? author-field) (nlist? author-field)))
+           (cons 'author author-field)
+          ) ;
+          ((not (or (bib-null? editor-field) (nlist? editor-field)))
+           (cons 'editor editor-field)
+          ) ;
+          (else (cons 'empty '()))
+    ) ;cond
+  ) ;let
+) ;define
+
+;; 为作者字符串添加后缀（如果是editor）
+
+(define (gbt-add-suffix author-str field-type chinese? count)
+  ;; editor和author同逻辑：都不加后缀
+  author-str
+) ;define
+
+;; 获取作者字符串（用于natbib-triple的author字段 - 完整格式，用于参考文献表）
+(tm-define (gbt-get-author-string x)
+  (:mode bib-gbt7714-2015-author-year?)
+  (let* ((field-info (gbt-get-author-field x))
+         (field-type (car field-info))
+         (field-list (cdr field-info))
+         (has-author (not (equal? field-type 'empty)))
+         (chinese? (if has-author (authors-contain-chinese? field-list) #f))
+        ) ;
+    (if has-author
+      (let* ((n (length field-list))
+             (author-count (- n 1))
+             ;; 参考文献表阈值：GB/T 7714-2015规定：≤3人全部列出，≥4人写"前3人+等"
+             (max-authors 3)
+             (show-count (min author-count max-authors))
+             (has-more (> author-count max-authors))
+             ;; 分隔符：中文和英文都加空格
+             (separator (if chinese? ", " ", "))
+            ) ;
+        (cond ((= author-count 1)
+               (let ((author-name (bib-format-name (list-ref field-list 1))))
+                 (gbt-add-suffix author-name field-type chinese? 1)
+               ) ;let
+              ) ;
+              (else (let* ((first (bib-format-name (list-ref field-list 1)))
+                           ;; 收集中间作者
+                           ;; 如果有更多作者（>3）：收集第2到第3个作者（共2个中间作者）
+                           ;; 如果没有更多作者（<=3）：收集第2到第author-count-1个作者
+                           (middle (let loop
+                                     ((i 2) (result ""))
+                                     (if (or (>= i n) (if has-more (> i max-authors) (>= i author-count)))
+                                       result
+                                       (loop (+ i 1)
+                                         (if (equal? result "")
+                                           (bib-format-name (list-ref field-list i))
+                                           `(concat ,result
+                                              ,separator
+                                              ,(bib-format-name (list-ref field-list
+                                                                  i)))
+                                         ) ;if
+                                       ) ;loop
+                                     ) ;if
+                                   ) ;let
+                           ) ;middle
+                           (last-part (if has-more
+                                        (if chinese? "<#7b49>" "et al")
+                                        ;; 等
+                                        (if (>= author-count 2) (bib-format-name (list-ref field-list (- n 1))) "")
+                                      ) ;if
+                           ) ;last-part
+                           ;; 构建作者字符串
+                           (author-str (cond ((and (equal? middle "") (equal? last-part "")) first)
+                                             ((equal? middle "") `(concat ,first
+                                                                    ,separator
+                                                                    ,last-part))
+                                             ((equal? last-part "") `(concat ,first
+                                                                       ,separator
+                                                                       ,middle))
+                                             (else `(concat ,first
+                                                      ,separator
+                                                      ,middle
+                                                      ,separator
+                                                      ,last-part))
+                                       ) ;cond
+                           ) ;author-str
+                          ) ;
+                      (gbt-add-suffix author-str field-type chinese? author-count)
+                    ) ;let*
+              ) ;else
+        ) ;cond
+      ) ;let*
+      ""
+    ) ;if
+  ) ;let*
+) ;tm-define
+
+;; 获取短作者字符串（用于natbib-triple的author*字段 - 引用标签格式）
+(tm-define (gbt-get-author*-string x)
+  (:mode bib-gbt7714-2015-author-year?)
+  (let* ((field-info (gbt-get-author-field x))
+         (field-type (car field-info))
+         (field-list (cdr field-info))
+         (has-author (not (equal? field-type 'empty)))
+         (chinese? (if has-author (authors-contain-chinese? field-list) #f))
+        ) ;
+    (if has-author
+      (let* ((n (length field-list)) (author-count (- n 1)))
+        ;; 辅助函数：提取作者姓氏（英文）或完整姓名（中文）
+        (define (get-author-display i)
+          (let ((author (list-ref field-list i)))
+            (if chinese?
+              (bib-format-name author)
+              ;; 中文：完整姓名
+              ;; 英文：只提取姓氏，不大写
+              (let ((last-name-raw (list-ref author 3)))
+                (if (bib-null? last-name-raw) "" (bib-purify last-name-raw))
+              ) ;let
+            ) ;if
+          ) ;let
+        ) ;define
+        (cond
+          ;; 作者数 ≥ 3：显示第一位 + et al/等
+          ((>= author-count 3)
+           (let ((first (get-author-display 1)))
+             (if chinese?
+               (gbt-add-suffix `(concat ,first ,"<#7b49>") field-type chinese? author-count)
+               (gbt-add-suffix `(concat ,first ," et al.") field-type chinese? author-count)
+             ) ;if
+           ) ;let
+          ) ;
+          ;; 作者数 = 2：显示两位，用"and"或"和"连接
+          ((= author-count 2)
+           (let ((first (get-author-display 1)) (second (get-author-display 2)))
+             (if chinese?
+               (gbt-add-suffix `(concat ,first ,"<#548C>" ,second)
+                 field-type
+                 chinese?
+                 author-count
+               ) ;gbt-add-suffix
+               (gbt-add-suffix `(concat ,first ," & " ,second)
+                 field-type
+                 chinese?
+                 author-count
+               ) ;gbt-add-suffix
+             ) ;if
+           ) ;let
+          ) ;
+          ;; 作者数 = 1：显示一位
+          ((= author-count 1)
+           (gbt-add-suffix (get-author-display 1) field-type chinese? author-count)
+          ) ;
+          ;; 其他情况（应该不会发生）
+          (else "")
+        ) ;cond
+      ) ;let*
+      ""
+    ) ;if
+  ) ;let*
+) ;tm-define
+
+;; 获取年份字符串（带后缀）
+(tm-define (gbt-get-year-string x)
+  (:mode bib-gbt7714-2015-author-year?)
+  (let* ((key (list-ref x 2))
+         (y (bib-field x "year"))
+         (year-base-expr (cond ((bib-null? y) "?")
+                               ((string? y) y)
+                               ((not y) "?")
+                               (else (safe-tm->string y))
+                         ) ;cond
+         ) ;year-base-expr
+         (year-base (cond ((string? year-base-expr) year-base-expr)
+                          ((not year-base-expr) "?")
+                          (else (safe-tm->string year-base-expr))
+                    ) ;cond
+         ) ;year-base
+         (suffix (if gbt-year-suffix-table (or (ahash-ref gbt-year-suffix-table key) "") "")
+         ) ;suffix
+        ) ;
+    (if (equal? suffix "") year-base (string-append year-base suffix))
+  ) ;let*
+) ;tm-define
+
+;; 标签格式
+(tm-define (bib-format-bibitem n x)
+  (:mode bib-gbt7714-2015-author-year?)
+  ;; 返回作者(年份)格式用于cite-author-year包
+  (let ((author-str (gbt-get-author*-string x)) (year-str (gbt-get-year-string x)))
+    `(bibitem* (natbib-triple ,(gbt-get-author-string x) ,author-str ,year-str))
+  ) ;let
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 辅助函数
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; 检查是否有URL/DOI/urldate
+(tm-define (gbt-has-url-doi? x)
+  (:mode bib-gbt7714-2015-author-year?)
+  (let* ((url (bib-field x "url"))
+         (doi (bib-field x "doi"))
+         (urldate (bib-field x "urldate"))
+        ) ;
+    (or (not (bib-null? url)) (not (bib-null? doi)) (not (bib-null? urldate)))
+  ) ;let*
+) ;tm-define
+
+;; 智能句子函数：如果有URL/DOI/urldate则不添加句点，否则添加句点
+(tm-define (gbt-new-smart-sentence x ref)
+  (:mode bib-gbt7714-2015-author-year?)
+  (if (gbt-has-url-doi? ref)
+    (bib-upcase-first (bib-new-list ", " x))
+    (bib-add-period (bib-upcase-first (bib-new-list ", " x)))
+  ) ;if
+) ;tm-define
+
+;; 智能块函数：包装智能句子，包含URL/DOI，不添加额外空格
+(tm-define (gbt-new-smart-block-with-url x ref)
+  (:mode bib-gbt7714-2015-author-year?)
+  (if (bib-null? x)
+    ""
+    `(concat ,(gbt-new-smart-sentence x ref)
+       ,(bib-new-case-preserved-block (bib-format-url-doi ref)))
+  ) ;if
+) ;tm-define
+
+;; 将URL里rsub表达式转换回下划线：将(rsub "x")转换为_x
+
+(define (convert-rsub-to-underscore expr)
+  (cond ((and (list? expr) (= (length expr) 2) (equal? (car expr) 'rsub))
+         (let ((text (cadr expr)))
+           (if (string? text)
+             (string-append "_" text)
+             (string-append "_" (safe-tm->string text))
+           ) ;if
+         ) ;let
+        ) ;
+        ((and (list? expr) (>= (length expr) 1) (equal? (car expr) 'concat))
+         `(concat ,@(map convert-rsub-to-underscore (cdr expr)))
+        ) ;
+        ((list? expr) (map convert-rsub-to-underscore expr))
+        ((string? expr) expr)
+        (else expr)
+  ) ;cond
+) ;define
+
+
+;; 通用版本格式化函数
+(tm-define (gbt-format-edition x chinese?)
+  (:mode bib-gbt7714-2015-author-year?)
+  (let ((edition-field (bib-field x "edition")))
+    (if (or (bib-null? edition-field) (equal? edition-field ""))
+      ""
+      (if chinese?
+        `(concat ,"<#7B2C>" ,edition-field ,"<#7248>")
+        ;; 第X版
+        `(concat ,edition-field ," edition")
+      ) ;if
+    ) ;if
+  ) ;let
+) ;tm-define
+
+;; 子字符串检查函数
+
+(define (substring? pat text)
+  (let ((pat-len (string-length pat)) (text-len (string-length text)))
+    (let outer
+      ((i 0))
+      (cond ((> (+ i pat-len) text-len) #f)
+            (else (let inner
+                    ((j 0))
+                    (cond ((>= j pat-len) #t)
+                          ((char=? (string-ref pat j) (string-ref text (+ i j))) (inner (+ j 1)))
+                          (else (outer (+ i 1)))
+                    ) ;cond
+                  ) ;let
+            ) ;else
+      ) ;cond
+    ) ;let
+  ) ;let
+) ;define
+
+;; 检测字符串是否包含中文字符的辅助函数
+
+(define (contains-chinese? str)
+  (if (bib-null? str)
+    #f
+    (let ((s (if (string? str) str "")))
+      ;; 检查是否包含中文 Unicode 字符的内部表示模式
+      (or (substring? "<#4" s)
+        (substring? "<#5" s)
+        (substring? "<#6" s)
+        (substring? "<#7" s)
+        (substring? "<#8" s)
+        (substring? "<#9" s)
+        ;; 检查实际的中文字符（基本中文范围 U+4E00-U+9FFF）
+        (let loop
+          ((i 0) (len (string-length s)))
+          (if (>= i len)
+            #f
+            (let* ((c (string-ref s i)) (code (char->integer c)))
+              (if (and (>= code 19968) (<= code 40959)) #t (loop (+ i 1) len))
+            ) ;let*
+          ) ;if
+        ) ;let
+      ) ;or
+    ) ;let
+  ) ;if
+) ;define
+
+;; 检测作者列表是否包含中文作者
+
+(define (authors-contain-chinese? a)
+  (if (or (bib-null? a) (nlist? a))
+    #f
+    (let loop
+      ((i 1) (n (length a)))
+      (if (>= i n)
+        #f
+        (let* ((author-raw (list-ref a i))
+               (author (gbt-remove-keepcase author-raw))
+               ;; 将作者的所有字符串部分连接成一个字符串，然后检查是否包含中文
+               (author-str (cond ((string? author) author)
+                                 ((list? author)
+                                  (let part-loop
+                                    ((j 1) (m (length author)) (result ""))
+                                    (if (>= j m)
+                                      result
+                                      (let ((part (list-ref author j)))
+                                        (part-loop (+ j 1) m (if (string? part) (string-append result part) result))
+                                      ) ;let
+                                    ) ;if
+                                  ) ;let
+                                 ) ;
+                                 (else "")
+                           ) ;cond
+               ) ;author-str
+              ) ;
+          (if (contains-chinese? author-str) #t (loop (+ i 1) n))
+        ) ;let*
+      ) ;if
+    ) ;let
+  ) ;if
+) ;define
+
+;; 移除keepcase标签的辅助函数
+
+(define (gbt-remove-keepcase x)
+  (cond ((list? x)
+         (if (not (null? x))
+           (if (equal? (car x) 'keepcase)
+             (gbt-remove-keepcase (cadr x))
+             (cons (car x) (map gbt-remove-keepcase (cdr x)))
+           ) ;if
+           '()
+         ) ;if
+        ) ;
+        ((string? x) x)
+        (else x)
+  ) ;cond
+) ;define
+
+;; 作者列表格式
+(tm-define (bib-format-names a)
+  (:mode bib-gbt7714-2015-author-year?)
+  (if (or (bib-null? a) (nlist? a))
+    ""
+    (let* ((n (length a))
+           (chinese? (authors-contain-chinese? a))
+           ;; GBT 7714-2015: 最多显示3个作者
+           (max-authors 3)
+           (author-count (- n 1))
+           (show-count (min author-count max-authors))
+           ;; 逗号分隔符：中文和英文都加空格
+           (comma-sep (if chinese? ", " ", "))
+          ) ;
+      (cond ((equal? author-count 1) (bib-format-name (list-ref a 1)))
+            (else (let* ((first (bib-format-name (list-ref a 1)))
+                         (has-more (> author-count max-authors))
+                         ;; 收集中间作者
+                         ;; 如果有更多作者（>3）：收集第2到第3个作者（共2个中间作者）
+                         ;; 如果没有更多作者（<=3）：收集第2到第author-count-1个作者
+                         (middle (let loop
+                                   ((i 2) (result ""))
+                                   (if (or (>= i n) (if has-more (> i max-authors) (>= i author-count)))
+                                     result
+                                     (loop (+ i 1)
+                                       (if (equal? result "")
+                                         (bib-format-name (list-ref a i))
+                                         `(concat ,result
+                                            ,comma-sep
+                                            ,(bib-format-name (list-ref a i)))
+                                       ) ;if
+                                     ) ;loop
+                                   ) ;if
+                                 ) ;let
+                         ) ;middle
+                         (last-part (if has-more
+                                      (if chinese? "<#7b49>" "et al")
+                                      ;; 等
+                                      (if (>= author-count 2) (bib-format-name (list-ref a (- n 1))) "")
+                                    ) ;if
+                         ) ;last-part
+                         ;; 分隔符：无论是否有更多作者，都使用逗号分隔符
+                         ;; 中文：作者1,作者2,作者3,等
+                         ;; 英文：Author1, Author2, Author3, et al
+                         (separator comma-sep)
+                        ) ;
+                    (cond ((and (equal? middle "") (equal? last-part "")) first)
+                          ((equal? middle "") `(concat ,first
+                                                 ,separator
+                                                 ,last-part))
+                          ((equal? last-part "") `(concat ,first
+                                                    ,comma-sep
+                                                    ,middle))
+                          (else `(concat ,first
+                                   ,comma-sep
+                                   ,middle
+                                   ,separator
+                                   ,last-part))
+                    ) ;cond
+                  ) ;let*
+            ) ;else
+      ) ;cond
+    ) ;let*
+  ) ;if
+) ;tm-define
+
+;; 编者格式
+(tm-define (bib-format-editor x)
+  (:mode bib-gbt7714-2015-author-year?)
+  ;; 格式化编者字段，添加 ed. 或 eds. 后缀（中文为“编”或“主编”）
+  (let* ((e (bib-field x "editor"))
+         (chinese? (if (or (bib-null? e) (nlist? e)) #f (authors-contain-chinese? e)))
+        ) ;
+    (if (or (bib-null? e) (nlist? e))
+      ""
+      (let* ((names (bib-format-names e)) (count (- (length e) 1)))
+        (if chinese?
+          (if (= count 1)
+            `(concat ,names ,",<#7F16>")
+            ;; 编
+            `(concat ,names ,",<#4E3B><#7F16>")
+          ) ;if
+          ;; 主编
+          (if (= count 1) `(concat ,names ,", ed.") `(concat ,names ,", eds."))
+        ) ;if
+      ) ;let*
+    ) ;if
+  ) ;let*
+) ;tm-define
+
+;; 文献类型标识符函数
+(tm-define (bib-document-type-identifier x type)
+  (:mode bib-gbt7714-2015-author-year?)
+  ;; 根据文献类型和是否有在线访问信息返回标识符
+  ;; 优先使用note字段，如果note字段包含标识符
+  ;; 否则检查是否有url或doi字段来判断是否为在线文献
+  (let* ((note (bib-field x "note"))
+         (has-url (not (bib-null? (bib-field x "url"))))
+         (has-doi (not (bib-null? (bib-field x "doi"))))
+         (online (or has-url has-doi))
+        ) ;
+    (cond ((and (not (bib-null? note)) (not (equal? note ""))) note)
+          ;; 优先使用note字段
+          ((equal? type "article") (if online "[J/OL]" "[J]"))
+          ;; 期刊
+          ((equal? type "book") (if online "[M/OL]" "[M]"))
+          ;; 普通图书
+          ((equal? type "inbook") (if online "[M/OL]" "[M]"))
+          ;; 析出图书
+          ((equal? type "inproceedings") (if online "[C/OL]" "[C]"))
+          ;; 会议录
+          ((equal? type "proceedings") (if online "[C/OL]" "[C]"))
+          ;; 会议录
+          ((equal? type "phdthesis") (if online "[D/OL]" "[D]"))
+          ;; 学位论文-博士
+          ((equal? type "mastersthesis") (if online "[D/OL]" "[D]"))
+          ;; 学位论文-硕士
+          ((equal? type "techreport") (if online "[R/OL]" "[R]"))
+          ;; 报告
+          ((equal? type "collection") (if online "[G/OL]" "[G]"))
+          ;; 汇编
+          ((equal? type "incollection") (if online "[G/OL]" "[G]"))
+          ;; 析出汇编
+          ((equal? type "manual") (if online "[M/OL]" "[M]"))
+          ;; 手册/说明书
+          ((equal? type "standard") (if online "[S/OL]" "[S]"))
+          ;; 标准
+          ((equal? type "patent") (if online "[P/OL]" "[P]"))
+          ;; 专利
+          ((equal? type "database") (if online "[DB/OL]" "[DB]"))
+          ;; 数据库
+          ((equal? type "software") (if online "[CP/OL]" "[CP]"))
+          ;; 计算机程序
+          ((equal? type "program") (if online "[CP/OL]" "[CP]"))
+          ;; 计算机程序
+          ((equal? type "online") (if online "[EB/OL]" "[EB]"))
+          ;; 电子公告
+          ((equal? type "electronic") (if online "[EB/OL]" "[EB]"))
+          ;; 电子公告
+          ((equal? type "archive") (if online "[A/OL]" "[A]"))
+          ;; 档案
+          ((equal? type "map") (if online "[CM/OL]" "[CM]"))
+          ;; 舆图
+          ((equal? type "dataset") (if online "[DS/OL]" "[DS]"))
+          ;; 数据集
+          ((equal? type "newspaper") (if online "[N/OL]" "[N]"))
+          ;; 报纸
+          ((equal? type "misc") (if online "[Z/OL]" "[Z]"))
+          ;; 其他
+          (else "")
+    ) ;cond
+  ) ;let*
+) ;tm-define
+
+;; 地址:机构格式
+(tm-define (bib-format-address-institution x)
+  (:mode bib-gbt7714-2015-author-year?)
+  (let* ((addr (cond ((not (bib-empty? x "address")) (bib-field x "address"))
+                     ((not (bib-empty? x "location")) (bib-field x "location"))
+                     (else "")
+               ) ;cond
+         ) ;addr
+         (inst-field (cond ((not (bib-empty? x "school")) (bib-field x "school"))
+                           ((not (bib-empty? x "organization")) (bib-field x "organization"))
+                           ((not (bib-empty? x "publisher")) (bib-field x "publisher"))
+                           ((not (bib-empty? x "institution")) (bib-field x "institution"))
+                           (else "")
+                     ) ;cond
+         ) ;inst-field
+         (inst-val (if (or (bib-null? inst-field) (equal? inst-field "")) "" inst-field))
+        ) ;
+    (cond ((and (not (equal? addr "")) (not (equal? inst-val "")))
+           `(concat ,addr ,": " ,inst-val)
+          ) ;
+          ((not (equal? addr "")) addr)
+          ((not (equal? inst-val "")) inst-val)
+          (else "")
+    ) ;cond
+  ) ;let*
+) ;tm-define
+
+;; 作者姓名格式
+(tm-define (bib-format-name x)
+  (:mode bib-gbt7714-2015-author-year?)
+  ;; 西文作者：姓在前（全大写），名缩写（如 "YU H B"）
+  ;; 中文作者：姓在前，名在后（全称）
+  ;; 使用双层花括号的机构名：不进行格式化处理
+  (let* ((first-name-raw (if (bib-null? (list-ref x 1)) "" (list-ref x 1)))
+         (last-name-raw (if (bib-null? (list-ref x 3)) "" (list-ref x 3)))
+         (chinese? (or (contains-chinese? first-name-raw) (contains-chinese? last-name-raw))
+         ) ;chinese?
+         (first-name (if chinese?
+                       first-name-raw
+                       ;; 中文名不缩写
+                       (if (bib-null? first-name-raw) "" (bib-abbreviate first-name-raw "" " "))
+                     ) ;if
+         ) ;first-name
+         (last-name (if (bib-null? last-name-raw)
+                      ""
+                      (if chinese?
+                        (bib-purify last-name-raw)
+                        (string-upcase (bib-purify last-name-raw))
+                      ) ;if
+                    ) ;if
+         ) ;last-name
+        ) ;
+    ;; 西文姓名处理：如果没有逗号分隔，保持原样
+    (if (not chinese?)
+      (cond ((bib-null? last-name-raw) first-name-raw)
+            ;; 没有姓，返回名
+            ((bib-null? first-name-raw) last-name-raw)
+            ;; 没有名，返回姓
+            (else `(concat ,last-name ," " ,first-name))
+      ) ;cond
+      ;; 正常格式化
+      ;; 中文姓名处理：保持原有逻辑
+      (if (bib-null? last-name)
+        first-name
+        (if (bib-null? first-name) last-name `(concat ,last-name
+                                                ," "
+                                                ,first-name))
+      ) ;if
+    ) ;if
+  ) ;let*
+) ;tm-define
+
+(tm-define (bib-format-date x)
+  (:mode bib-gbt7714-2015-author-year?)
+  ;; 日期处理函数，只处理date字段，加括号
+  (let ((d (bib-field x "date")))
+    (if (bib-null? d) "" `(concat ,"(" ,d ,")"))
+  ) ;let
+) ;tm-define
+
+;; 书名格式
+(tm-define (bib-format-in-ed-booktitle x)
+  (:mode bib-gbt7714-2015-author-year?)
+  (let* ((b (bib-default-field x "booktitle")) (e (bib-field x "editor")))
+    (if (bib-null? b) "" `(concat ,(bib-translate "in ") ,b))
+  ) ;let*
+) ;tm-define
+
+;; 卷(期):页码格式
+(tm-define (bib-format-vol-num-pages x)
+  (:mode bib-gbt7714-2015-author-year?)
+  ;; GBT 7714-2015-author-year 格式：卷(期):页码（年份在标签中）
+  (let* ((v (bib-field x "volume"))
+         (n (bib-field x "number"))
+         (p (bib-field x "pages"))
+         (vol (if (bib-null? v) "" v))
+         (num (if (bib-null? n) "" `(concat ,"(" ,n ,")")))
+         (pag (if (or (bib-null? p) (nlist? p))
+                ""
+                (cond ((equal? 1 (length p)) "")
+                      ((equal? 2 (length p)) `(concat ,": " ,(list-ref p 1)))
+                      (else `(concat ,": "
+                               ,(list-ref p 1)
+                               ,bib-range-symbol
+                               ,(list-ref p 2)))
+                ) ;cond
+              ) ;if
+         ) ;pag
+        ) ;
+    `(concat ,vol ,num ,pag)
+  ) ;let*
+) ;tm-define
+
+;; URL/DOI 信息格式
+(tm-define (bib-format-url-doi x)
+  (:mode bib-gbt7714-2015-author-year?)
+  (let* ((url-raw (bib-field x "url"))
+         (doi-raw (bib-field x "doi"))
+         (urldate (bib-field x "urldate"))
+         ;; 转换rsub表达式为下划线
+         (url (convert-rsub-to-underscore url-raw))
+         (doi (convert-rsub-to-underscore doi-raw))
+         (has-url (not (bib-null? url-raw)))
+         (has-doi (not (bib-null? doi-raw)))
+         (has-urldate (not (bib-null? urldate)))
+        ) ;
+    (cond (has-doi
+            ;; 有 DOI（优先使用，忽略 URL）：添加https://doi.org/前缀
+            (let ((doi-url `(concat ,"https://doi.org/" ,doi)))
+              (if has-urldate `(concat ,"[" ,urldate ,"]. " ,doi-url) doi-url)
+            ) ;let
+          ) ;has-doi
+          (has-url
+            ;; 只有 URL（没有 DOI）
+            (if has-urldate `(concat ,"[" ,urldate ,"]. " ,url) `(concat ,url))
+          ) ;has-url
+          (else "")
+    ) ;cond
+  ) ;let*
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 类型格式函数
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; 重写文章格式以添加文献类型标识符 [J]
+(tm-define (bib-format-article n x)
+  (:mode bib-gbt7714-2015-author-year?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block `(concat ,(bib-format-field-preserve-case x
+                                                      "title")
+                                             ,(bib-document-type-identifier x
+                                                "article")))
+                          ,(gbt-new-smart-block-with-url `(,(bib-format-field x
+                                                              "journal")
+                                                           ,(bib-format-vol-num-pages x))
+                             x))))
+) ;tm-define
+
+;; 重写图书格式以添加文献类型标识符 [M]
+(tm-define (bib-format-book n x)
+  (:mode bib-gbt7714-2015-author-year?)
+  (let ((chinese? (authors-contain-chinese? (if (bib-empty? x "editor") (bib-field x "author") (bib-field x "editor"))
+                  ) ;authors-contain-chinese?
+        ) ;chinese?
+       ) ;
+    `(concat ,(bib-format-bibitem n x)
+       ,(bib-label (list-ref x 2))
+       ,(bib-new-list-spc `(,(bib-new-block (bib-new-sentence `((concat ,(bib-format-field x
+                                                                           "title")
+                                                                  ,(bib-document-type-identifier x
+                                                                     "book")))))
+                            ,(bib-new-block (let ((edition-str (gbt-format-edition x
+                                                                 chinese?)))
+                                              (if (equal? edition-str "")
+                                                ""
+                                                edition-str)))
+                            ,(gbt-new-smart-block-with-url `(,(bib-format-number-series x)
+                                                             ,(bib-format-address-institution x))
+                               x))))
+  ) ;let
+) ;tm-define
+
+;; 重写析出图书格式以添加文献类型标识符 [M]
+(tm-define (bib-format-inbook n x)
+  (:mode bib-gbt7714-2015-author-year?)
+  (let ((chinese? (authors-contain-chinese? (if (bib-empty? x "editor") (bib-field x "author") (bib-field x "editor"))
+                  ) ;authors-contain-chinese?
+        ) ;chinese?
+       ) ;
+    `(concat ,(bib-format-bibitem n x)
+       ,(bib-label (list-ref x 2))
+       ,(bib-new-list-spc `(,(bib-new-block (let* ((bookauthor-field (bib-field x
+                                                                       "bookauthor"))
+                                                   (editor-field (bib-field x
+                                                                   "editor"))
+                                                   (booktitle-field (bib-field x
+                                                                      "booktitle"))
+                                                   (edition-str (gbt-format-edition x
+                                                                  chinese?))
+                                                   (has-bookauthor (not (bib-null? bookauthor-field)))
+                                                   (has-editor (not (bib-null? editor-field))))
+                                              (cond (has-bookauthor (let ((bookauthor-names (cond ((bib-null? bookauthor-field)
+                                                                                                   "")
+                                                                                                  ((nlist? bookauthor-field)
+                                                                                                   bookauthor-field)
+                                                                                                  (else (bib-format-names bookauthor-field)))))
+                                                                      `(concat ,(bib-format-field-preserve-case x
+                                                                                  "title")
+                                                                         ,(bib-document-type-identifier x
+                                                                            "book")
+                                                                         ,"//"
+                                                                         ,bookauthor-names
+                                                                         ,". "
+                                                                         ,(bib-format-field-preserve-case x
+                                                                            "booktitle")
+                                                                         ,(if (equal? edition-str
+                                                                                "")
+                                                                            ""
+                                                                            `(concat ,": "
+                                                                               ,edition-str))
+                                                                         ,".")))
+                                                    (has-editor (let ((editor-names (cond ((bib-null? editor-field)
+                                                                                           "")
+                                                                                          ((nlist? editor-field)
+                                                                                           editor-field)
+                                                                                          (else (bib-format-names editor-field)))))
+                                                                  `(concat ,(bib-format-field-preserve-case x
+                                                                              "title")
+                                                                     ,(bib-document-type-identifier x
+                                                                        "book")
+                                                                     ,"//"
+                                                                     ,editor-names
+                                                                     ,". "
+                                                                     ,(bib-format-field-preserve-case x
+                                                                        "booktitle")
+                                                                     ,(if (equal? edition-str
+                                                                            "")
+                                                                        ""
+                                                                        `(concat ,": "
+                                                                           ,edition-str))
+                                                                     ,".")))
+                                                    (else `(concat ,(bib-format-field-preserve-case x
+                                                                      "title")
+                                                             ,(bib-document-type-identifier x
+                                                                "book")
+                                                             ,"//. "
+                                                             ,(bib-format-field-preserve-case x
+                                                                "booktitle")
+                                                             ,(if (equal? edition-str
+                                                                    "")
+                                                                ""
+                                                                `(concat ,": "
+                                                                   ,edition-str))
+                                                             ,".")))))
+                            ,(gbt-new-smart-block-with-url `(,(bib-format-number-series x)
+                                                             ,(bib-format-address-institution x))
+                               x))))
+  ) ;let
+) ;tm-define
+
+;; 重写会议论文格式以添加文献类型标识符 [C]
+(tm-define (bib-format-inproceedings n x)
+  (:mode bib-gbt7714-2015-author-year?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block `(concat ,(bib-format-field-preserve-case x
+                                                      "title")
+                                             ,(bib-document-type-identifier x
+                                                "inproceedings")
+                                             ,"//"
+                                             ,(bib-format-field-preserve-case x
+                                                "booktitle")
+                                             ,"."))
+                          ,(gbt-new-smart-block-with-url `(,(bib-format-address-institution x))
+                             x))))
+) ;tm-define
+
+;; 重写会议录格式以添加文献类型标识符 [C]
+(tm-define (bib-format-proceedings n x)
+  (:mode bib-gbt7714-2015-author-year?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block `(concat ,(bib-format-field-preserve-case x
+                                                      "title")
+                                             ,(bib-document-type-identifier x
+                                                "proceedings")))
+                          ,(gbt-new-smart-block-with-url `(,(bib-format-address-institution x))
+                             x))))
+) ;tm-define
+
+;; 重写手册格式以添加文献类型标识符 [M]
+(tm-define (bib-format-manual n x)
+  (:mode bib-gbt7714-2015-author-year?)
+  (let ((chinese? (authors-contain-chinese? (if (bib-empty? x "author") '() (bib-field x "author"))
+                  ) ;authors-contain-chinese?
+        ) ;chinese?
+       ) ;
+    `(concat ,(bib-format-bibitem n x)
+       ,(bib-label (list-ref x 2))
+       ,(bib-new-list-spc `(,(bib-new-block (let* ((title (bib-format-field-preserve-case x
+                                                            "title"))
+                                                   (number (bib-field x
+                                                             "number"))
+                                                   (edition-str (gbt-format-edition x
+                                                                  chinese?))
+                                                   (identifier (bib-document-type-identifier x
+                                                                 "manual"))
+                                                   (parts (list title)))
+                                              (if (not (equal? edition-str ""))
+                                                (set! parts
+                                                  (append parts
+                                                    (list ": " edition-str))))
+                                              (if (not (bib-null? number))
+                                                (set! parts
+                                                  (append parts
+                                                    (list ": " number))))
+                                              (set! parts
+                                                (append parts (list identifier)))
+                                              (apply tmconcat parts)))
+                            ,(gbt-new-smart-block-with-url `(,(bib-format-address-institution x))
+                               x))))
+  ) ;let
+) ;tm-define
+
+;; 重写博士论文格式以添加文献类型标识符 [D]
+(tm-define (bib-format-phdthesis n x)
+  (:mode bib-gbt7714-2015-author-year?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block `(concat ,(bib-format-field-preserve-case x
+                                                      "title")
+                                             ,(bib-document-type-identifier x
+                                                "phdthesis")))
+                          ,(gbt-new-smart-block-with-url `(,(bib-format-address-institution x))
+                             x))))
+) ;tm-define
+
+;; 重写硕士论文格式以添加文献类型标识符 [D]
+(tm-define (bib-format-mastersthesis n x)
+  (:mode bib-gbt7714-2015-author-year?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block `(concat ,(bib-format-field-preserve-case x
+                                                      "title")
+                                             ,(bib-document-type-identifier x
+                                                "mastersthesis")))
+                          ,(gbt-new-smart-block-with-url `(,(bib-format-address-institution x))
+                             x))))
+) ;tm-define
+
+;; 重写报告格式以添加文献类型标识符 [R]
+(tm-define (bib-format-techreport n x)
+  (:mode bib-gbt7714-2015-author-year?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block `(concat ,(bib-format-field-preserve-case x
+                                                      "title")
+                                             ,(bib-document-type-identifier x
+                                                "techreport")))
+                          ,(gbt-new-smart-block-with-url `(,(let ((add-ins (bib-format-address-institution x))
+                                                                  (number (bib-field x
+                                                                            "number")))
+                                                              (if (bib-null? number)
+                                                                add-ins
+                                                                (if (equal? add-ins
+                                                                      "")
+                                                                  number
+                                                                  `(concat ,add-ins
+                                                                     ,": "
+                                                                     ,number)))))
+                             x))))
+) ;tm-define
+
+;; 重写杂项格式以添加文献类型标识符 [Z]
+(tm-define (bib-format-misc n x)
+  (:mode bib-gbt7714-2015-author-year?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block `(concat ,(bib-format-field-preserve-case x
+                                                      "title")
+                                             ,(bib-document-type-identifier x
+                                                "misc")))
+                          ,(gbt-new-smart-block-with-url '() x))))
+) ;tm-define
+
+;; 重写专利格式以添加文献类型标识符 [P]
+(tm-define (bib-format-patent n x)
+  (:mode bib-gbt7714-2015-author-year?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (let* ((title (bib-format-field-preserve-case x
+                                                          "title"))
+                                                 (number (bib-field x "number"))
+                                                 (identifier (bib-document-type-identifier x
+                                                               "patent")))
+                                            (if (bib-null? number)
+                                              `(concat ,title ,identifier)
+                                              `(concat ,title
+                                                 ,": "
+                                                 ,number
+                                                 ,identifier))))
+                          ,(gbt-new-smart-block-with-url '() x))))
+) ;tm-define
+
+;; 重写标准格式以添加文献类型标识符 [S]
+(tm-define (bib-format-standard n x)
+  (:mode bib-gbt7714-2015-author-year?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (let* ((title (bib-format-field-preserve-case x
+                                                          "title"))
+                                                 (key (bib-field x "key"))
+                                                 (number (bib-field x "number"))
+                                                 (std-num (if (bib-null? key)
+                                                            number
+                                                            key))
+                                                 (identifier (bib-document-type-identifier x
+                                                               "standard")))
+                                            (if (bib-null? std-num)
+                                              `(concat ,title ,identifier)
+                                              `(concat ,std-num
+                                                 ," "
+                                                 ,title
+                                                 ,identifier))))
+                          ,(gbt-new-smart-block-with-url `(,(bib-format-address-institution x))
+                             x))))
+) ;tm-define
+
+;; 重写数据库格式以添加文献类型标识符 [DB]
+(tm-define (bib-format-database n x)
+  (:mode bib-gbt7714-2015-author-year?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block `(concat ,(bib-format-field-preserve-case x
+                                                      "title")
+                                             ,(bib-document-type-identifier x
+                                                "database")))
+                          ,(gbt-new-smart-block-with-url `(,(bib-format-date x))
+                             x))))
+) ;tm-define
+
+;; 重写电子公告格式以添加文献类型标识符 [EB]
+(tm-define (bib-format-electronic n x)
+  (:mode bib-gbt7714-2015-author-year?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block `(concat ,(bib-format-field-preserve-case x
+                                                      "title")
+                                             ,(bib-document-type-identifier x
+                                                "electronic")))
+                          ,(gbt-new-smart-block-with-url `(,(bib-format-date x))
+                             x))))
+) ;tm-define
+
+;; 重写在线网页格式以添加文献类型标识符 [EB]
+(tm-define (bib-format-online n x)
+  (:mode bib-gbt7714-2015-author-year?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block `(concat ,(bib-format-field-preserve-case x
+                                                      "title")
+                                             ,(bib-document-type-identifier x
+                                                "online")))
+                          ,(gbt-new-smart-block-with-url `(,(bib-format-date x))
+                             x))))
+) ;tm-define
+
+;; 重写报纸格式以添加文献类型标识符 [N]
+(tm-define (bib-format-newspaper n x)
+  (:mode bib-gbt7714-2015-author-year?)
+  (let* ((p (bib-field x "pages"))
+         (pag (if (or (bib-null? p) (nlist? p))
+                ""
+                (cond ((equal? 1 (length p)) "")
+                      ((equal? 2 (length p)) (list-ref p 1))
+                      (else `(concat ,(list-ref p 1)
+                               ,bib-range-symbol
+                               ,(list-ref p 2)))
+                ) ;cond
+              ) ;if
+         ) ;pag
+         (journal-info (if (== pag "")
+                         (bib-format-field x "journal")
+                         `(concat ,(bib-format-field x "journal") ,", " ,pag)
+                       ) ;if
+         ) ;journal-info
+        ) ;
+    `(concat ,(bib-format-bibitem n x)
+       ,(bib-label (list-ref x 2))
+       ,(bib-new-list-spc `(,(bib-new-block `(concat ,(bib-format-field-preserve-case x
+                                                        "title")
+                                               ,(bib-document-type-identifier x
+                                                  "newspaper")))
+                            ,(gbt-new-smart-block-with-url `(,journal-info) x))))
+  ) ;let*
+) ;tm-define
+
+;; 重写汇编格式以添加文献类型标识符 [G]
+(tm-define (bib-format-collection n x)
+  (:mode bib-gbt7714-2015-author-year?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block `(concat ,(bib-format-field-preserve-case x
+                                                      "title")
+                                             ,(bib-document-type-identifier x
+                                                "collection")))
+                          ,(gbt-new-smart-block-with-url `(,(bib-format-address-institution x))
+                             x))))
+) ;tm-define
+
+;; 重写析出汇编格式以添加文献类型标识符 [G]
+(tm-define (bib-format-incollection n x)
+  (:mode bib-gbt7714-2015-author-year?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (let* ((editor-field (bib-field x
+                                                                 "editor"))
+                                                 (booktitle-field (bib-field x
+                                                                    "booktitle"))
+                                                 (has-editor (not (bib-null? editor-field))))
+                                            (if has-editor
+                                              (let ((editor-names (cond ((bib-null? editor-field)
+                                                                         "")
+                                                                        ((nlist? editor-field)
+                                                                         editor-field)
+                                                                        (else (bib-format-names editor-field)))))
+                                                `(concat ,(bib-format-field-preserve-case x
+                                                            "title")
+                                                   ,(bib-document-type-identifier x
+                                                      "collection")
+                                                   ,"//"
+                                                   ,editor-names
+                                                   ,". "
+                                                   ,(bib-format-field-preserve-case x
+                                                      "booktitle")
+                                                   ,"."))
+                                              `(concat ,(bib-format-field-preserve-case x
+                                                          "title")
+                                                 ,(bib-document-type-identifier x
+                                                    "collection")
+                                                 ,"//"
+                                                 ,(bib-format-field-preserve-case x
+                                                    "booktitle")
+                                                 ,"."))))
+                          ,(gbt-new-smart-block-with-url `(,(bib-format-address-institution x))
+                             x))))
+) ;tm-define
+
+;; 重写软件格式以添加文献类型标识符 [CP]
+(tm-define (bib-format-software n x)
+  (:mode bib-gbt7714-2015-author-year?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block `(concat ,(bib-format-field-preserve-case x
+                                                      "title")
+                                             ,(bib-document-type-identifier x
+                                                "software")))
+                          ,(gbt-new-smart-block-with-url (let ((version (bib-field x
+                                                                          "version")))
+                                                           (cond ((bib-null? version)
+                                                                  '())
+                                                                 (else `((concat ,"Version "
+                                                                           ,version)))))
+                             x))))
+) ;tm-define
+
+;; 重写程序格式以添加文献类型标识符 [CP]
+(tm-define (bib-format-program n x)
+  (:mode bib-gbt7714-2015-author-year?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block `(concat ,(bib-format-field-preserve-case x
+                                                      "title")
+                                             ,(bib-document-type-identifier x
+                                                "program")))
+                          ,(gbt-new-smart-block-with-url (let ((version (bib-field x
+                                                                          "version")))
+                                                           (cond ((bib-null? version)
+                                                                  '())
+                                                                 (else `((concat ,"Version "
+                                                                           ,version)))))
+                             x))))
+) ;tm-define
+
+;; 重写档案格式以添加文献类型标识符 [A]
+(tm-define (bib-format-archive n x)
+  (:mode bib-gbt7714-2015-author-year?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (let* ((title (bib-format-field-preserve-case x
+                                                          "title"))
+                                                 (number (bib-field x "number"))
+                                                 (identifier (bib-document-type-identifier x
+                                                               "archive")))
+                                            (if (bib-null? number)
+                                              `(concat ,title ,identifier)
+                                              `(concat ,title
+                                                 ,": "
+                                                 ,number
+                                                 ,identifier))))
+                          ,(gbt-new-smart-block-with-url `(,(bib-format-address-institution x))
+                             x))))
+) ;tm-define
+
+;; 重写舆图格式以添加文献类型标识符 [CM]
+(tm-define (bib-format-map n x)
+  (:mode bib-gbt7714-2015-author-year?)
+  (let ((chinese? (authors-contain-chinese? (if (bib-empty? x "editor") (bib-field x "author") (bib-field x "editor"))
+                  ) ;authors-contain-chinese?
+        ) ;chinese?
+       ) ;
+    `(concat ,(bib-format-bibitem n x)
+       ,(bib-label (list-ref x 2))
+       ,(bib-new-list-spc `(,(bib-new-block `(concat ,(bib-format-field-preserve-case x
+                                                        "title")
+                                               ,(bib-document-type-identifier x
+                                                  "map")))
+                            ,(bib-new-block (let ((edition-str (gbt-format-edition x
+                                                                 chinese?)))
+                                              (if (equal? edition-str "")
+                                                ""
+                                                edition-str)))
+                            ,(gbt-new-smart-block-with-url `(,(bib-format-address-institution x))
+                               x))))
+  ) ;let
+) ;tm-define
+
+;; 重写数据集格式以添加文献类型标识符 [DS]
+(tm-define (bib-format-dataset n x)
+  (:mode bib-gbt7714-2015-author-year?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block `(concat ,(bib-format-field-preserve-case x
+                                                      "title")
+                                             ,(bib-document-type-identifier x
+                                                "dataset")))
+                          ,(gbt-new-smart-block-with-url `(,(bib-format-date x))
+                             x))))
+) ;tm-define
diff --git a/TeXmacs/plugins/latex/progs/latex/bibtex-gbt7714-2015.scm b/TeXmacs/plugins/latex/progs/latex/bibtex-gbt7714-2015.scm
new file mode 100644
index 0000000000..57db9cbc87
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/bibtex-gbt7714-2015.scm
@@ -0,0 +1,1180 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : gbt7714-2015.scm
+;; DESCRIPTION : GBT 7714-2015 style for BibTeX files
+;; COPYRIGHT   : (C) 2025 Yuki Lu
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex bibtex-gbt7714-2015)
+  (:use (latex bibtex-bib-utils) (latex bibtex-plain))
+) ;texmacs-module
+
+(bib-define-style "gbt7714-2015" "gbt7714-2015")
+
+(tm-define (bib-sorted-entries l)
+  (:mode bib-gbt7714-2015?)
+  (with is-entry? (lambda (x) (func? x 'bib-entry)) (list-filter l is-entry?))
+) ;tm-define
+
+;; 重写条目格式函数以支持所有文献类型
+(tm-define (bib-format-entry n x)
+  (:mode bib-gbt7714-2015?)
+  (if (and (list? x)
+        (func? x 'bib-entry)
+        (= (length x) 4)
+        (func? (list-ref x 3) 'document)
+      ) ;and
+    (with doctype
+      (list-ref x 1)
+      (gbt-remove-keepcase (cond ((equal? doctype "article") (bib-format-article n x))
+                                 ((equal? doctype "book") (bib-format-book n x))
+                                 ((equal? doctype "booklet") (bib-format-booklet n x))
+                                 ((equal? doctype "inbook") (bib-format-inbook n x))
+                                 ((equal? doctype "incollection") (bib-format-incollection n x))
+                                 ((equal? doctype "inproceedings") (bib-format-inproceedings n x))
+                                 ((equal? doctype "conference") (bib-format-inproceedings n x))
+                                 ((equal? doctype "manual") (bib-format-manual n x))
+                                 ((equal? doctype "mastersthesis") (bib-format-mastersthesis n x))
+                                 ((equal? doctype "misc") (bib-format-misc n x))
+                                 ((equal? doctype "phdthesis") (bib-format-phdthesis n x))
+                                 ((equal? doctype "proceedings") (bib-format-proceedings n x))
+                                 ((equal? doctype "techreport") (bib-format-techreport n x))
+                                 ((equal? doctype "unpublished") (bib-format-unpublished n x))
+                                 ;; GBT 7714-2015 新增类型
+                                 ((equal? doctype "standard") (bib-format-standard n x))
+                                 ((equal? doctype "database") (bib-format-database n x))
+                                 ((equal? doctype "software") (bib-format-software n x))
+                                 ((equal? doctype "program") (bib-format-program n x))
+                                 ((equal? doctype "archive") (bib-format-archive n x))
+                                 ((equal? doctype "map") (bib-format-map n x))
+                                 ((equal? doctype "dataset") (bib-format-dataset n x))
+                                 ((equal? doctype "electronic") (bib-format-electronic n x))
+                                 ((equal? doctype "online") (bib-format-online n x))
+                                 ((equal? doctype "newspaper") (bib-format-newspaper n x))
+                                 ((equal? doctype "collection") (bib-format-collection n x))
+                                 ((equal? doctype "patent") (bib-format-patent n x))
+                                 (else (bib-format-misc n x))
+                           ) ;cond
+      ) ;gbt-remove-keepcase
+    ) ;with
+  ) ;if
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 辅助函数
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; 将URL里rsub表达式转换回下划线：将(rsub "x")转换为_x
+
+(define (convert-rsub-to-underscore expr)
+  (cond ((and (list? expr) (= (length expr) 2) (equal? (car expr) 'rsub))
+         (let ((text (cadr expr)))
+           (if (string? text)
+             (string-append "_" text)
+             (string-append "_" (tm->string text))
+           ) ;if
+         ) ;let
+        ) ;
+        ((and (list? expr) (>= (length expr) 1) (equal? (car expr) 'concat))
+         `(concat ,@(map convert-rsub-to-underscore (cdr expr)))
+        ) ;
+        ((list? expr) (map convert-rsub-to-underscore expr))
+        ((string? expr) expr)
+        (else expr)
+  ) ;cond
+) ;define
+
+;; 检查是否有URL/DOI/urldate
+(tm-define (gbt-has-url-doi? x)
+  (:mode bib-gbt7714-2015?)
+  (let* ((url (bib-field x "url"))
+         (doi (bib-field x "doi"))
+         (urldate (bib-field x "urldate"))
+        ) ;
+    (or (not (bib-null? url)) (not (bib-null? doi)) (not (bib-null? urldate)))
+  ) ;let*
+) ;tm-define
+
+;; 智能句子函数：如果有URL/DOI/urldate则不添加句点，否则添加句点
+(tm-define (gbt-new-smart-sentence x ref)
+  (:mode bib-gbt7714-2015?)
+  (if (gbt-has-url-doi? ref)
+    (bib-upcase-first (bib-new-list ", " x))
+    (bib-add-period (bib-upcase-first (bib-new-list ", " x)))
+  ) ;if
+) ;tm-define
+
+;; 智能块函数：包装智能句子，包含URL/DOI，不添加额外空格
+(tm-define (gbt-new-smart-block-with-url x ref)
+  (:mode bib-gbt7714-2015?)
+  (if (bib-null? x)
+    ""
+    `(concat ,(gbt-new-smart-sentence x ref)
+       ,(bib-new-case-preserved-block (bib-format-url-doi ref)))
+  ) ;if
+) ;tm-define
+
+;; 通用版本格式化函数
+(tm-define (gbt-format-edition x chinese?)
+  (:mode bib-gbt7714-2015?)
+  (let ((edition-field (bib-field x "edition")))
+    (if (or (bib-null? edition-field) (equal? edition-field ""))
+      ""
+      (if chinese?
+        `(concat ,"<#7B2C>" ,edition-field ,"<#7248>")
+        ;; 第X版
+        `(concat ,edition-field ," edition")
+      ) ;if
+    ) ;if
+  ) ;let
+) ;tm-define
+
+;; 子字符串检查函数
+
+(define (substring? pat text)
+  (let ((pat-len (string-length pat)) (text-len (string-length text)))
+    (let outer
+      ((i 0))
+      (cond ((> (+ i pat-len) text-len) #f)
+            (else (let inner
+                    ((j 0))
+                    (cond ((>= j pat-len) #t)
+                          ((char=? (string-ref pat j) (string-ref text (+ i j))) (inner (+ j 1)))
+                          (else (outer (+ i 1)))
+                    ) ;cond
+                  ) ;let
+            ) ;else
+      ) ;cond
+    ) ;let
+  ) ;let
+) ;define
+
+;; 检测字符串是否包含中文字符的辅助函数
+
+(define (contains-chinese? str)
+  (if (bib-null? str)
+    #f
+    (let ((s (if (string? str) str "")))
+      ;; 检查是否包含中文 Unicode 字符的内部表示模式
+      (or (substring? "<#4" s)
+        (substring? "<#5" s)
+        (substring? "<#6" s)
+        (substring? "<#7" s)
+        (substring? "<#8" s)
+        (substring? "<#9" s)
+        ;; 检查实际的中文字符（基本中文范围 U+4E00-U+9FFF）
+        (let loop
+          ((i 0) (len (string-length s)))
+          (if (>= i len)
+            #f
+            (let* ((c (string-ref s i)) (code (char->integer c)))
+              (if (and (>= code 19968) (<= code 40959)) #t (loop (+ i 1) len))
+            ) ;let*
+          ) ;if
+        ) ;let
+      ) ;or
+    ) ;let
+  ) ;if
+) ;define
+
+;; 检测作者列表是否包含中文作者
+
+(define (authors-contain-chinese? a)
+  (if (or (bib-null? a) (nlist? a))
+    #f
+    (let loop
+      ((i 1) (n (length a)))
+      (if (>= i n)
+        #f
+        (let* ((author-raw (list-ref a i))
+               (author (gbt-remove-keepcase author-raw))
+               ;; 将作者的所有字符串部分连接成一个字符串，然后检查是否包含中文
+               (author-str (cond ((string? author) author)
+                                 ((list? author)
+                                  (let part-loop
+                                    ((j 1) (m (length author)) (result ""))
+                                    (if (>= j m)
+                                      result
+                                      (let ((part (list-ref author j)))
+                                        (part-loop (+ j 1) m (if (string? part) (string-append result part) result))
+                                      ) ;let
+                                    ) ;if
+                                  ) ;let
+                                 ) ;
+                                 (else "")
+                           ) ;cond
+               ) ;author-str
+              ) ;
+          (if (contains-chinese? author-str) #t (loop (+ i 1) n))
+        ) ;let*
+      ) ;if
+    ) ;let
+  ) ;if
+) ;define
+
+;; 移除keepcase标签的辅助函数
+
+(define (gbt-remove-keepcase x)
+  (cond ((list? x)
+         (if (not (null? x))
+           (if (equal? (car x) 'keepcase)
+             (gbt-remove-keepcase (cadr x))
+             (cons (car x) (map gbt-remove-keepcase (cdr x)))
+           ) ;if
+           '()
+         ) ;if
+        ) ;
+        ((string? x) x)
+        (else x)
+  ) ;cond
+) ;define
+
+;; 作者列表格式
+(tm-define (bib-format-names a)
+  (:mode bib-gbt7714-2015?)
+  (if (or (bib-null? a) (nlist? a))
+    ""
+    (let* ((n (length a))
+           (chinese? (authors-contain-chinese? a))
+           ;; GBT 7714-2015: 最多显示3个作者
+           (max-authors 3)
+           (author-count (- n 1))
+           (show-count (min author-count max-authors))
+           ;; 逗号分隔符：中文和英文都加空格
+           (comma-sep (if chinese? ", " ", "))
+          ) ;
+      (cond ((equal? author-count 1) (bib-format-name (list-ref a 1)))
+            (else (let* ((first (bib-format-name (list-ref a 1)))
+                         (has-more (> author-count max-authors))
+                         ;; 收集中间作者
+                         ;; 如果有更多作者（>3）：收集第2到第3个作者（共2个中间作者）
+                         ;; 如果没有更多作者（<=3）：收集第2到第author-count-1个作者
+                         (middle (let loop
+                                   ((i 2) (result ""))
+                                   (if (or (>= i n) (if has-more (> i max-authors) (>= i author-count)))
+                                     result
+                                     (loop (+ i 1)
+                                       (if (equal? result "")
+                                         (bib-format-name (list-ref a i))
+                                         `(concat ,result
+                                            ,comma-sep
+                                            ,(bib-format-name (list-ref a i)))
+                                       ) ;if
+                                     ) ;loop
+                                   ) ;if
+                                 ) ;let
+                         ) ;middle
+                         (last-part (if has-more
+                                      (if chinese? "<#7b49>" "et al")
+                                      ;; 等
+                                      (if (>= author-count 2) (bib-format-name (list-ref a (- n 1))) "")
+                                    ) ;if
+                         ) ;last-part
+                         ;; 分隔符：无论是否有更多作者，都使用逗号分隔符
+                         ;; 中文：作者1,作者2,作者3,等
+                         ;; 英文：Author1, Author2, Author3, et al
+                         (separator comma-sep)
+                        ) ;
+                    (cond ((and (equal? middle "") (equal? last-part "")) first)
+                          ((equal? middle "") `(concat ,first
+                                                 ,separator
+                                                 ,last-part))
+                          ((equal? last-part "") `(concat ,first
+                                                    ,comma-sep
+                                                    ,middle))
+                          (else `(concat ,first
+                                   ,comma-sep
+                                   ,middle
+                                   ,separator
+                                   ,last-part))
+                    ) ;cond
+                  ) ;let*
+            ) ;else
+      ) ;cond
+    ) ;let*
+  ) ;if
+) ;tm-define
+
+;; 编者格式
+(tm-define (bib-format-editor x)
+  (:mode bib-gbt7714-2015?)
+  ;; 格式化编者字段，添加 ed. 或 eds. 后缀（中文为“编”或“主编”）
+  (let* ((e (bib-field x "editor"))
+         (chinese? (if (or (bib-null? e) (nlist? e)) #f (authors-contain-chinese? e)))
+        ) ;
+    (if (or (bib-null? e) (nlist? e))
+      ""
+      (let* ((names (bib-format-names e)) (count (- (length e) 1)))
+        (if chinese?
+          (if (= count 1)
+            `(concat ,names ,",<#7F16>")
+            ;; 编
+            `(concat ,names ,",<#4E3B><#7F16>")
+          ) ;if
+          ;; 主编
+          (if (= count 1) `(concat ,names ,", ed.") `(concat ,names ,", eds."))
+        ) ;if
+      ) ;let*
+    ) ;if
+  ) ;let*
+) ;tm-define
+
+;; 文献类型标识符函数
+(tm-define (bib-document-type-identifier x type)
+  (:mode bib-gbt7714-2015?)
+  ;; 根据文献类型和是否有在线访问信息返回标识符
+  ;; 优先使用note字段，如果note字段包含标识符
+  ;; 否则检查是否有url或doi字段来判断是否为在线文献
+  (let* ((note (bib-field x "note"))
+         (has-url (not (bib-null? (bib-field x "url"))))
+         (has-doi (not (bib-null? (bib-field x "doi"))))
+         (online (or has-url has-doi))
+        ) ;
+    (cond ((and (not (bib-null? note)) (not (equal? note ""))) note)
+          ;; 优先使用note字段
+          ((equal? type "article") (if online "[J/OL]" "[J]"))
+          ;; 期刊!
+          ((equal? type "book") (if online "[M/OL]" "[M]"))
+          ;; 普通图书!
+          ((equal? type "inbook") (if online "[M/OL]" "[M]"))
+          ;; 析出图书!
+          ((equal? type "inproceedings") (if online "[C/OL]" "[C]"))
+          ;; 会议录!
+          ((equal? type "proceedings") (if online "[C/OL]" "[C]"))
+          ;; 会议录!
+          ((equal? type "phdthesis") (if online "[D/OL]" "[D]"))
+          ;; 学位论文-博士!
+          ((equal? type "mastersthesis") (if online "[D/OL]" "[D]"))
+          ;; 学位论文-硕士!
+          ((equal? type "techreport") (if online "[R/OL]" "[R]"))
+          ;; 报告!
+          ((equal? type "collection") (if online "[G/OL]" "[G]"))
+          ;; 汇编!
+          ((equal? type "incollection") (if online "[G/OL]" "[G]"))
+          ;; 析出汇编!
+          ((equal? type "manual") (if online "[M/OL]" "[M]"))
+          ;; 手册/说明书!
+          ((equal? type "standard") (if online "[S/OL]" "[S]"))
+          ;; 标准!
+          ((equal? type "patent") (if online "[P/OL]" "[P]"))
+          ;; 专利!
+          ((equal? type "database") (if online "[DB/OL]" "[DB]"))
+          ;; 数据库!
+          ((equal? type "software") (if online "[CP/OL]" "[CP]"))
+          ;; 计算机程序!
+          ((equal? type "program") (if online "[CP/OL]" "[CP]"))
+          ;; 计算机程序!
+          ((equal? type "online") (if online "[EB/OL]" "[EB]"))
+          ;; 电子公告!
+          ((equal? type "electronic") (if online "[EB/OL]" "[EB]"))
+          ;; 电子公告!
+          ((equal? type "archive") (if online "[A/OL]" "[A]"))
+          ;; 档案!
+          ((equal? type "map") (if online "[CM/OL]" "[CM]"))
+          ;; 舆图!
+          ((equal? type "dataset") (if online "[DS/OL]" "[DS]"))
+          ;; 数据集!
+          ((equal? type "newspaper") (if online "[N/OL]" "[N]"))
+          ;; 报纸!
+          ((equal? type "misc") (if online "[Z/OL]" "[Z]"))
+          ;; 其他!
+          (else "")
+    ) ;cond
+  ) ;let*
+) ;tm-define
+
+;; 地址:机构格式
+(tm-define (bib-format-address-institution x)
+  (:mode bib-gbt7714-2015?)
+  (let* ((addr (cond ((not (bib-empty? x "address")) (bib-field x "address"))
+                     ((not (bib-empty? x "location")) (bib-field x "location"))
+                     (else "")
+               ) ;cond
+         ) ;addr
+         (inst-field (cond ((not (bib-empty? x "school")) (bib-field x "school"))
+                           ((not (bib-empty? x "organization")) (bib-field x "organization"))
+                           ((not (bib-empty? x "publisher")) (bib-field x "publisher"))
+                           ((not (bib-empty? x "institution")) (bib-field x "institution"))
+                           (else "")
+                     ) ;cond
+         ) ;inst-field
+         (inst-val (if (or (bib-null? inst-field) (equal? inst-field "")) "" inst-field))
+        ) ;
+    (cond ((and (not (equal? addr "")) (not (equal? inst-val "")))
+           `(concat ,addr ,": " ,inst-val)
+          ) ;
+          ((not (equal? addr "")) addr)
+          ((not (equal? inst-val "")) inst-val)
+          (else "")
+    ) ;cond
+  ) ;let*
+) ;tm-define
+
+;; 作者姓名格式
+(tm-define (bib-format-name x)
+  (:mode bib-gbt7714-2015?)
+  ;; 西文作者：姓在前（全大写），名缩写（如 "YU H B"）
+  ;; 中文作者：姓在前，名在后（全称）
+  ;; 使用双层花括号的机构名：不进行格式化处理
+  (let* ((first-name-raw (if (bib-null? (list-ref x 1)) "" (list-ref x 1)))
+         (last-name-raw (if (bib-null? (list-ref x 3)) "" (list-ref x 3)))
+         (chinese? (or (contains-chinese? first-name-raw) (contains-chinese? last-name-raw))
+         ) ;chinese?
+         (first-name (if chinese?
+                       first-name-raw
+                       ;; 中文名不缩写
+                       (if (bib-null? first-name-raw) "" (bib-abbreviate first-name-raw "" " "))
+                     ) ;if
+         ) ;first-name
+         (last-name (if (bib-null? last-name-raw)
+                      ""
+                      (if chinese?
+                        (bib-purify last-name-raw)
+                        (string-upcase (bib-purify last-name-raw))
+                      ) ;if
+                    ) ;if
+         ) ;last-name
+        ) ;
+    ;; 西文姓名处理：如果没有逗号分隔，保持原样
+    (if (not chinese?)
+      (cond ((bib-null? last-name-raw) first-name-raw)
+            ;; 没有姓，返回名
+            ((bib-null? first-name-raw) last-name-raw)
+            ;; 没有名，返回姓
+            (else `(concat ,last-name ," " ,first-name))
+      ) ;cond
+      ;; 正常格式化
+      ;; 中文姓名处理：保持原有逻辑
+      (if (bib-null? last-name)
+        first-name
+        (if (bib-null? first-name) last-name `(concat ,last-name
+                                                ," "
+                                                ,first-name))
+      ) ;if
+    ) ;if
+  ) ;let*
+) ;tm-define
+
+;; 日期格式
+(tm-define (bib-format-date x)
+  (:mode bib-gbt7714-2015?)
+  ;; 日期处理函数，支持date字段和year字段
+  ;; date字段加括号，year字段不加括号
+  ;; 如果有pages字段，则格式为"年份:页码"
+  (let* ((d (bib-field x "date")) (y (bib-field x "year")) (p (bib-field x "pages")))
+    (cond ((not (bib-null? d)) `(concat ,"(" ,d ,")"))
+          ((not (bib-null? y))
+           (let* ((year y)
+                  (pag (if (or (bib-null? p) (nlist? p))
+                         ""
+                         (cond ((equal? 1 (length p)) "")
+                               ((equal? 2 (length p)) `(concat ,": "
+                                                         ,(list-ref p 1)))
+                               (else `(concat ,": "
+                                        ,(list-ref p 1)
+                                        ,bib-range-symbol
+                                        ,(list-ref p 2)))
+                         ) ;cond
+                       ) ;if
+                  ) ;pag
+                 ) ;
+             (if (== pag "") year `(concat ,year ,pag))
+           ) ;let*
+          ) ;
+          (else "")
+    ) ;cond
+  ) ;let*
+) ;tm-define
+
+;; 书名格式
+(tm-define (bib-format-in-ed-booktitle x)
+  (:mode bib-gbt7714-2015?)
+  (let* ((b (bib-default-field x "booktitle")) (e (bib-field x "editor")))
+    (if (bib-null? b) "" `(concat ,(bib-translate "in ") ,b))
+  ) ;let*
+) ;tm-define
+
+;; 年份,卷(期):页码格式
+(tm-define (bib-format-vol-num-pages x)
+  (:mode bib-gbt7714-2015?)
+  ;; GBT 7714-2015 格式：年份,卷(期):页码
+  (let* ((y (bib-field x "year"))
+         (v (bib-field x "volume"))
+         (n (bib-field x "number"))
+         (p (bib-field x "pages"))
+         (year (if (bib-null? y) "" y))
+         (vol (if (bib-null? v) "" v))
+         (num (if (bib-null? n) "" `(concat ,"(" ,n ,")")))
+         (pag (if (or (bib-null? p) (nlist? p))
+                ""
+                (cond ((equal? 1 (length p)) "")
+                      ((equal? 2 (length p)) `(concat ,": " ,(list-ref p 1)))
+                      (else `(concat ,": "
+                               ,(list-ref p 1)
+                               ,bib-range-symbol
+                               ,(list-ref p 2)))
+                ) ;cond
+              ) ;if
+         ) ;pag
+        ) ;
+    (if (and (== vol "") (== num "") (== pag ""))
+      year
+      (if (bib-null? year)
+        `(concat ,vol ,num ,pag)
+        (if (not (== vol ""))
+          `(concat ,year ,", " ,vol ,num ,pag)
+          `(concat ,year ,num ,pag)
+        ) ;if
+      ) ;if
+    ) ;if
+  ) ;let*
+) ;tm-define
+
+;; 数字标签格式
+(tm-define (bib-format-bibitem n x)
+  (:mode bib-gbt7714-2015?)
+  ;; 使用数字标签，如 [1], [2], ...
+  `(bibitem* ,(number->string n))
+) ;tm-define
+
+;; URL/DOI 信息格式
+(tm-define (bib-format-url-doi x)
+  (:mode bib-gbt7714-2015?)
+  (let* ((url-raw (bib-field x "url"))
+         (doi-raw (bib-field x "doi"))
+         (urldate (bib-field x "urldate"))
+         ;; 转换rsub表达式为下划线
+         (url (convert-rsub-to-underscore url-raw))
+         (doi (convert-rsub-to-underscore doi-raw))
+         (has-url (not (bib-null? url-raw)))
+         (has-doi (not (bib-null? doi-raw)))
+         (has-urldate (not (bib-null? urldate)))
+        ) ;
+    (cond (has-doi
+            ;; 有 DOI（优先使用，忽略 URL）：添加https://doi.org/前缀
+            (let ((doi-url `(concat ,"https://doi.org/" ,doi)))
+              (if has-urldate `(concat ,"[" ,urldate ,"]. " ,doi-url) doi-url)
+            ) ;let
+          ) ;has-doi
+          (has-url
+            ;; 只有 URL（没有 DOI）
+            (if has-urldate `(concat ,"[" ,urldate ,"]. " ,url) `(concat ,url))
+          ) ;has-url
+          (else "")
+    ) ;cond
+  ) ;let*
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 类型格式函数
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; 重写文章格式以添加文献类型标识符 [J]
+(tm-define (bib-format-article n x)
+  (:mode bib-gbt7714-2015?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-format-author x))
+                          ,(bib-new-block `(concat ,(bib-format-field-preserve-case x
+                                                      "title")
+                                             ,(bib-document-type-identifier x
+                                                "article")))
+                          ,(gbt-new-smart-block-with-url `(,(bib-format-field x
+                                                              "journal")
+                                                           ,(bib-format-vol-num-pages x))
+                             x))))
+) ;tm-define
+
+;; 重写图书格式以添加文献类型标识符 [M]
+(tm-define (bib-format-book n x)
+  (:mode bib-gbt7714-2015?)
+  (let ((chinese? (authors-contain-chinese? (if (bib-empty? x "editor") (bib-field x "author") (bib-field x "editor"))
+                  ) ;authors-contain-chinese?
+        ) ;chinese?
+       ) ;
+    `(concat ,(bib-format-bibitem n x)
+       ,(bib-label (list-ref x 2))
+       ,(bib-new-list-spc `(,(bib-new-block (if (bib-empty? x "editor")
+                                              (bib-format-author x)
+                                              (bib-format-editor x)))
+                            ,(bib-new-block (bib-new-sentence `((concat ,(bib-format-field x
+                                                                           "title")
+                                                                  ,(bib-document-type-identifier x
+                                                                     "book")))))
+                            ,(bib-new-block (let ((edition-str (gbt-format-edition x
+                                                                 chinese?)))
+                                              (if (equal? edition-str "")
+                                                ""
+                                                edition-str)))
+                            ,(gbt-new-smart-block-with-url `(,(bib-format-number-series x)
+                                                             ,(bib-format-address-institution x)
+                                                             ,(bib-format-date x))
+                               x))))
+  ) ;let
+) ;tm-define
+
+;; 重写析出图书格式以添加文献类型标识符 [M]
+(tm-define (bib-format-inbook n x)
+  (:mode bib-gbt7714-2015?)
+  (let ((chinese? (authors-contain-chinese? (if (bib-empty? x "editor") (bib-field x "author") (bib-field x "editor"))
+                  ) ;authors-contain-chinese?
+        ) ;chinese?
+       ) ;
+    `(concat ,(bib-format-bibitem n x)
+       ,(bib-label (list-ref x 2))
+       ,(bib-new-list-spc `(,(bib-new-block (if (bib-empty? x "editor")
+                                              (bib-format-author x)
+                                              (bib-format-editor x)))
+                            ,(bib-new-block (let* ((bookauthor-field (bib-field x
+                                                                       "bookauthor"))
+                                                   (editor-field (bib-field x
+                                                                   "editor"))
+                                                   (booktitle-field (bib-field x
+                                                                      "booktitle"))
+                                                   (edition-str (gbt-format-edition x
+                                                                  chinese?))
+                                                   (has-bookauthor (not (bib-null? bookauthor-field)))
+                                                   (has-editor (not (bib-null? editor-field))))
+                                              (cond (has-bookauthor (let ((bookauthor-names (cond ((bib-null? bookauthor-field)
+                                                                                                   "")
+                                                                                                  ((nlist? bookauthor-field)
+                                                                                                   bookauthor-field)
+                                                                                                  (else (bib-format-names bookauthor-field)))))
+                                                                      `(concat ,(bib-format-field-preserve-case x
+                                                                                  "title")
+                                                                         ,(bib-document-type-identifier x
+                                                                            "book")
+                                                                         ,"//"
+                                                                         ,bookauthor-names
+                                                                         ,". "
+                                                                         ,(bib-format-field-preserve-case x
+                                                                            "booktitle")
+                                                                         ,(if (equal? edition-str
+                                                                                "")
+                                                                            ""
+                                                                            `(concat ,": "
+                                                                               ,edition-str))
+                                                                         ,".")))
+                                                    (has-editor (let ((editor-names (cond ((bib-null? editor-field)
+                                                                                           "")
+                                                                                          ((nlist? editor-field)
+                                                                                           editor-field)
+                                                                                          (else (bib-format-names editor-field)))))
+                                                                  `(concat ,(bib-format-field-preserve-case x
+                                                                              "title")
+                                                                     ,(bib-document-type-identifier x
+                                                                        "book")
+                                                                     ,"//"
+                                                                     ,editor-names
+                                                                     ,". "
+                                                                     ,(bib-format-field-preserve-case x
+                                                                        "booktitle")
+                                                                     ,(if (equal? edition-str
+                                                                            "")
+                                                                        ""
+                                                                        `(concat ,": "
+                                                                           ,edition-str))
+                                                                     ,".")))
+                                                    (else `(concat ,(bib-format-field-preserve-case x
+                                                                      "title")
+                                                             ,(bib-document-type-identifier x
+                                                                "book")
+                                                             ,"//. "
+                                                             ,(bib-format-field-preserve-case x
+                                                                "booktitle")
+                                                             ,(if (equal? edition-str
+                                                                    "")
+                                                                ""
+                                                                `(concat ,": "
+                                                                   ,edition-str))
+                                                             ,".")))))
+                            ,(gbt-new-smart-block-with-url `(,(bib-format-number-series x)
+                                                             ,(bib-format-address-institution x)
+                                                             ,(bib-format-date x))
+                               x))))
+  ) ;let
+) ;tm-define
+
+;; 重写会议论文格式以添加文献类型标识符 [C]
+(tm-define (bib-format-inproceedings n x)
+  (:mode bib-gbt7714-2015?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-format-author x))
+                          ,(bib-new-block `(concat ,(bib-format-field-preserve-case x
+                                                      "title")
+                                             ,(bib-document-type-identifier x
+                                                "inproceedings")
+                                             ,"//"
+                                             ,(bib-format-field-preserve-case x
+                                                "booktitle")
+                                             ,"."))
+                          ,(gbt-new-smart-block-with-url `(,(bib-format-address-institution x)
+                                                           ,(bib-format-date x))
+                             x))))
+) ;tm-define
+
+;; 重写会议录格式以添加文献类型标识符 [C]
+(tm-define (bib-format-proceedings n x)
+  (:mode bib-gbt7714-2015?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-format-editor x))
+                          ,(bib-new-block `(concat ,(bib-format-field-preserve-case x
+                                                      "title")
+                                             ,(bib-document-type-identifier x
+                                                "proceedings")))
+                          ,(gbt-new-smart-block-with-url `(,(bib-format-address-institution x)
+                                                           ,(bib-format-date x))
+                             x))))
+) ;tm-define
+
+;; 重写手册格式以添加文献类型标识符 [M]
+(tm-define (bib-format-manual n x)
+  (:mode bib-gbt7714-2015?)
+  (let ((chinese? (authors-contain-chinese? (if (bib-empty? x "author") '() (bib-field x "author"))
+                  ) ;authors-contain-chinese?
+        ) ;chinese?
+       ) ;
+    `(concat ,(bib-format-bibitem n x)
+       ,(bib-label (list-ref x 2))
+       ,(bib-new-list-spc `(,(bib-new-block (if (bib-empty? x "author")
+                                              (bib-new-sentence `(,(bib-format-address-institution x)))
+                                              (bib-format-author x)))
+                            ,(bib-new-block (let* ((title (bib-format-field-preserve-case x
+                                                            "title"))
+                                                   (number (bib-field x
+                                                             "number"))
+                                                   (edition-str (gbt-format-edition x
+                                                                  chinese?))
+                                                   (identifier (bib-document-type-identifier x
+                                                                 "manual"))
+                                                   (parts (list title)))
+                                              (if (not (equal? edition-str ""))
+                                                (set! parts
+                                                  (append parts
+                                                    (list ": " edition-str))))
+                                              (if (not (bib-null? number))
+                                                (set! parts
+                                                  (append parts
+                                                    (list ": " number))))
+                                              (set! parts
+                                                (append parts (list identifier)))
+                                              (apply tmconcat parts)))
+                            ,(gbt-new-smart-block-with-url (if (bib-empty? x
+                                                                 "author")
+                                                             (let ((address-institution (bib-format-address-institution x))
+                                                                   (date (bib-format-date x)))
+                                                               (cond ((and (equal? address-institution
+                                                                             "")
+                                                                        (bib-null? date))
+                                                                      '())
+                                                                     ((equal? address-institution
+                                                                        "")
+                                                                      `(,date))
+                                                                     ((bib-null? date)
+                                                                      `(,address-institution))
+                                                                     (else `(,address-institution
+                                                                             ,date))))
+                                                             `(,(bib-format-address-institution x)
+                                                               ,(bib-format-date x)))
+                               x))))
+  ) ;let
+) ;tm-define
+
+;; 重写博士论文格式以添加文献类型标识符 [D]
+(tm-define (bib-format-phdthesis n x)
+  (:mode bib-gbt7714-2015?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-format-author x))
+                          ,(bib-new-block `(concat ,(bib-format-field-preserve-case x
+                                                      "title")
+                                             ,(bib-document-type-identifier x
+                                                "phdthesis")))
+                          ,(gbt-new-smart-block-with-url `(,(if (bib-empty? x
+                                                                  "type")
+                                                              (bib-format-field-Locase x
+                                                                "type"))
+                                                           ,(bib-format-address-institution x)
+                                                           ,(bib-format-date x))
+                             x))))
+) ;tm-define
+
+;; 重写硕士论文格式以添加文献类型标识符 [D]
+(tm-define (bib-format-mastersthesis n x)
+  (:mode bib-gbt7714-2015?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-format-author x))
+                          ,(bib-new-block `(concat ,(bib-format-field-preserve-case x
+                                                      "title")
+                                             ,(bib-document-type-identifier x
+                                                "mastersthesis")))
+                          ,(gbt-new-smart-block-with-url `(,(if (bib-empty? x
+                                                                  "type")
+                                                              (bib-format-field-Locase x
+                                                                "type"))
+                                                           ,(bib-format-address-institution x)
+                                                           ,(bib-format-date x))
+                             x))))
+) ;tm-define
+
+;; 重写报告格式以添加文献类型标识符 [R]
+(tm-define (bib-format-techreport n x)
+  (:mode bib-gbt7714-2015?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-format-author x))
+                          ,(bib-new-block `(concat ,(bib-format-field-preserve-case x
+                                                      "title")
+                                             ,(bib-document-type-identifier x
+                                                "techreport")))
+                          ,(gbt-new-smart-block-with-url `(,(bib-format-address-institution x)
+                                                           ,(let ((date-str (bib-format-date x))
+                                                                  (number (bib-field x
+                                                                            "number")))
+                                                              (if (bib-null? number)
+                                                                date-str
+                                                                (if (equal? date-str
+                                                                      "")
+                                                                  number
+                                                                  `(concat ,date-str
+                                                                     ,": "
+                                                                     ,number)))))
+                             x))))
+) ;tm-define
+
+;; 重写杂项格式以添加文献类型标识符 [Z]
+(tm-define (bib-format-misc n x)
+  (:mode bib-gbt7714-2015?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-format-author x))
+                          ,(bib-new-block `(concat ,(bib-format-field-preserve-case x
+                                                      "title")
+                                             ,(bib-document-type-identifier x
+                                                "misc")))
+                          ,(gbt-new-smart-block-with-url `(,(bib-format-date x))
+                             x))))
+) ;tm-define
+
+;; 重写专利格式以添加文献类型标识符 [P]
+(tm-define (bib-format-patent n x)
+  (:mode bib-gbt7714-2015?)
+  (let ((date-str (let ((d (bib-field x "date")) (y (bib-field x "year")))
+                    (cond ((not (bib-null? d)) d)
+                          ((not (bib-null? y)) y)
+                          (else "")
+                    ) ;cond
+                  ) ;let
+        ) ;date-str
+       ) ;
+    `(concat ,(bib-format-bibitem n x)
+       ,(bib-label (list-ref x 2))
+       ,(bib-new-list-spc `(,(bib-new-block (bib-format-author x))
+                            ,(bib-new-block (let* ((title (bib-format-field-preserve-case x
+                                                            "title"))
+                                                   (number (bib-field x
+                                                             "number"))
+                                                   (identifier (bib-document-type-identifier x
+                                                                 "patent")))
+                                              (if (bib-null? number)
+                                                `(concat ,title ,identifier)
+                                                `(concat ,title
+                                                   ,": "
+                                                   ,number
+                                                   ,identifier))))
+                            ,(gbt-new-smart-block-with-url `(,date-str) x))))
+  ) ;let
+) ;tm-define
+
+;; 重写标准格式以添加文献类型标识符 [S]
+(tm-define (bib-format-standard n x)
+  (:mode bib-gbt7714-2015?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (let* ((title (bib-format-field-preserve-case x
+                                                          "title"))
+                                                 (key (bib-field x "key"))
+                                                 (number (bib-field x "number"))
+                                                 (std-num (if (bib-null? key)
+                                                            number
+                                                            key))
+                                                 (identifier (bib-document-type-identifier x
+                                                               "standard")))
+                                            (if (bib-null? std-num)
+                                              `(concat ,title ,identifier)
+                                              `(concat ,std-num
+                                                 ," "
+                                                 ,title
+                                                 ,identifier))))
+                          ,(gbt-new-smart-block-with-url (let ((address-institution (bib-format-address-institution x))
+                                                               (date (bib-format-date x)))
+                                                           (cond ((and (equal? address-institution
+                                                                         "")
+                                                                    (bib-null? date))
+                                                                  '())
+                                                                 ((equal? address-institution
+                                                                    "")
+                                                                  `(,date))
+                                                                 ((bib-null? date)
+                                                                  `(,address-institution))
+                                                                 (else `(,address-institution
+                                                                         ,date))))
+                             x))))
+) ;tm-define
+
+;; 重写数据库格式以添加文献类型标识符 [DB]
+(tm-define (bib-format-database n x)
+  (:mode bib-gbt7714-2015?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-format-author x))
+                          ,(bib-new-block `(concat ,(bib-format-field-preserve-case x
+                                                      "title")
+                                             ,(bib-document-type-identifier x
+                                                "database")))
+                          ,(gbt-new-smart-block-with-url `(,(bib-format-date x))
+                             x))))
+) ;tm-define
+
+;; 重写电子公告格式以添加文献类型标识符 [EB]
+(tm-define (bib-format-electronic n x)
+  (:mode bib-gbt7714-2015?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-format-author x))
+                          ,(bib-new-block `(concat ,(bib-format-field-preserve-case x
+                                                      "title")
+                                             ,(bib-document-type-identifier x
+                                                "electronic")))
+                          ,(gbt-new-smart-block-with-url `(,(bib-format-date x))
+                             x))))
+) ;tm-define
+
+;; 重写在线网页格式以添加文献类型标识符 [EB]
+(tm-define (bib-format-online n x)
+  (:mode bib-gbt7714-2015?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-format-author x))
+                          ,(bib-new-block `(concat ,(bib-format-field-preserve-case x
+                                                      "title")
+                                             ,(bib-document-type-identifier x
+                                                "online")))
+                          ,(gbt-new-smart-block-with-url `(,(bib-format-date x))
+                             x))))
+) ;tm-define
+
+;; 重写报纸格式以添加文献类型标识符 [N]
+(tm-define (bib-format-newspaper n x)
+  (:mode bib-gbt7714-2015?)
+  (let* ((date-str (let ((d (bib-field x "date")) (y (bib-field x "year")))
+                     (cond ((not (bib-null? d)) d)
+                           ((not (bib-null? y)) y)
+                           (else "")
+                     ) ;cond
+                   ) ;let
+         ) ;date-str
+         (p (bib-field x "pages"))
+         (pag (if (or (bib-null? p) (nlist? p))
+                ""
+                (cond ((equal? 1 (length p)) "")
+                      ((equal? 2 (length p)) (list-ref p 1))
+                      (else `(concat ,(list-ref p 1)
+                               ,bib-range-symbol
+                               ,(list-ref p 2)))
+                ) ;cond
+              ) ;if
+         ) ;pag
+         (date-pages-str (if (== pag "") date-str `(concat ,date-str
+                                                     ,"("
+                                                     ,pag
+                                                     ,")")))
+        ) ;
+    `(concat ,(bib-format-bibitem n x)
+       ,(bib-label (list-ref x 2))
+       ,(bib-new-list-spc `(,(bib-new-block (bib-format-author x))
+                            ,(bib-new-block `(concat ,(bib-format-field-preserve-case x
+                                                        "title")
+                                               ,(bib-document-type-identifier x
+                                                  "newspaper")))
+                            ,(gbt-new-smart-block-with-url `(,(bib-format-field x
+                                                                "journal")
+                                                             ,date-pages-str)
+                               x))))
+  ) ;let*
+) ;tm-define
+
+;; 重写汇编格式以添加文献类型标识符 [G]
+(tm-define (bib-format-collection n x)
+  (:mode bib-gbt7714-2015?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-format-editor x))
+                          ,(bib-new-block `(concat ,(bib-format-field-preserve-case x
+                                                      "title")
+                                             ,(bib-document-type-identifier x
+                                                "collection")))
+                          ,(gbt-new-smart-block-with-url `(,(bib-format-address-institution x)
+                                                           ,(bib-format-date x))
+                             x))))
+) ;tm-define
+
+;; 重写析出汇编格式以添加文献类型标识符 [G]
+(tm-define (bib-format-incollection n x)
+  (:mode bib-gbt7714-2015?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (if (bib-empty? x "author")
+                                            (bib-format-editor x)
+                                            (bib-format-author x)))
+                          ,(bib-new-block (let* ((editor-field (bib-field x
+                                                                 "editor"))
+                                                 (booktitle-field (bib-field x
+                                                                    "booktitle"))
+                                                 (has-editor (not (bib-null? editor-field))))
+                                            (if has-editor
+                                              (let ((editor-names (cond ((bib-null? editor-field)
+                                                                         "")
+                                                                        ((nlist? editor-field)
+                                                                         editor-field)
+                                                                        (else (bib-format-names editor-field)))))
+                                                `(concat ,(bib-format-field-preserve-case x
+                                                            "title")
+                                                   ,(bib-document-type-identifier x
+                                                      "collection")
+                                                   ,"//"
+                                                   ,editor-names
+                                                   ,". "
+                                                   ,(bib-format-field-preserve-case x
+                                                      "booktitle")
+                                                   ,"."))
+                                              `(concat ,(bib-format-field-preserve-case x
+                                                          "title")
+                                                 ,(bib-document-type-identifier x
+                                                    "collection")
+                                                 ,"//"
+                                                 ,(bib-format-field-preserve-case x
+                                                    "booktitle")
+                                                 ,"."))))
+                          ,(gbt-new-smart-block-with-url `(,(bib-format-address-institution x)
+                                                           ,(bib-format-date x))
+                             x))))
+) ;tm-define
+
+;; 重写软件格式以添加文献类型标识符 [CP]
+(tm-define (bib-format-software n x)
+  (:mode bib-gbt7714-2015?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-format-author x))
+                          ,(bib-new-block `(concat ,(bib-format-field-preserve-case x
+                                                      "title")
+                                             ,(bib-document-type-identifier x
+                                                "software")))
+                          ,(gbt-new-smart-block-with-url (let ((version (bib-field x
+                                                                          "version"))
+                                                               (date (bib-format-date x)))
+                                                           (cond ((and (bib-null? version)
+                                                                    (bib-null? date))
+                                                                  '())
+                                                                 ((bib-null? version)
+                                                                  `(,date))
+                                                                 (else `((concat ,"Version "
+                                                                           ,version)
+                                                                         ,date))))
+                             x))))
+) ;tm-define
+
+;; 重写程序格式以添加文献类型标识符 [CP]
+(tm-define (bib-format-program n x)
+  (:mode bib-gbt7714-2015?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-format-author x))
+                          ,(bib-new-block `(concat ,(bib-format-field-preserve-case x
+                                                      "title")
+                                             ,(bib-document-type-identifier x
+                                                "program")))
+                          ,(gbt-new-smart-block-with-url (let ((version (bib-field x
+                                                                          "version"))
+                                                               (date (bib-format-date x)))
+                                                           (cond ((and (bib-null? version)
+                                                                    (bib-null? date))
+                                                                  '())
+                                                                 ((bib-null? version)
+                                                                  `(,date))
+                                                                 (else `((concat ,"Version "
+                                                                           ,version)
+                                                                         ,date))))
+                             x))))
+) ;tm-define
+
+;; 重写档案格式以添加文献类型标识符 [A]
+(tm-define (bib-format-archive n x)
+  (:mode bib-gbt7714-2015?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-format-author x))
+                          ,(bib-new-block (let* ((title (bib-format-field-preserve-case x
+                                                          "title"))
+                                                 (number (bib-field x "number"))
+                                                 (identifier (bib-document-type-identifier x
+                                                               "archive")))
+                                            (if (bib-null? number)
+                                              `(concat ,title ,identifier)
+                                              `(concat ,title
+                                                 ,": "
+                                                 ,number
+                                                 ,identifier))))
+                          ,(gbt-new-smart-block-with-url `(,(bib-format-address-institution x)
+                                                           ,(bib-format-date x))
+                             x))))
+) ;tm-define
+
+;; 重写舆图格式以添加文献类型标识符 [CM]
+(tm-define (bib-format-map n x)
+  (:mode bib-gbt7714-2015?)
+  (let ((chinese? (authors-contain-chinese? (if (bib-empty? x "editor") (bib-field x "author") (bib-field x "editor"))
+                  ) ;authors-contain-chinese?
+        ) ;chinese?
+       ) ;
+    `(concat ,(bib-format-bibitem n x)
+       ,(bib-label (list-ref x 2))
+       ,(bib-new-list-spc `(,(bib-new-block (bib-format-author x))
+                            ,(bib-new-block `(concat ,(bib-format-field-preserve-case x
+                                                        "title")
+                                               ,(bib-document-type-identifier x
+                                                  "map")))
+                            ,(bib-new-block (let ((edition-str (gbt-format-edition x
+                                                                 chinese?)))
+                                              (if (equal? edition-str "")
+                                                ""
+                                                edition-str)))
+                            ,(gbt-new-smart-block-with-url `(,(bib-format-address-institution x)
+                                                             ,(bib-format-date x))
+                               x))))
+  ) ;let
+) ;tm-define
+
+;; 重写数据集格式以添加文献类型标识符 [DS]
+(tm-define (bib-format-dataset n x)
+  (:mode bib-gbt7714-2015?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-format-author x))
+                          ,(bib-new-block `(concat ,(bib-format-field-preserve-case x
+                                                      "title")
+                                             ,(bib-document-type-identifier x
+                                                "dataset")))
+                          ,(gbt-new-smart-block-with-url `(,(bib-format-date x))
+                             x))))
+) ;tm-define
diff --git a/TeXmacs/plugins/latex/progs/latex/bibtex-ieeetr.scm b/TeXmacs/plugins/latex/progs/latex/bibtex-ieeetr.scm
new file mode 100644
index 0000000000..23fdcbd9c0
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/bibtex-ieeetr.scm
@@ -0,0 +1,456 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : ieeetr.scm
+;; DESCRIPTION : ieeetr style for BibTeX files
+;; COPYRIGHT   : (C) 2010, 2015  David MICHEL, Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex bibtex-ieeetr)
+  (:use (latex bibtex-bib-utils) (latex bibtex-plain))
+) ;texmacs-module
+
+(bib-define-style "ieeetr" "plain")
+
+(tm-define (bib-sorted-entries l)
+  (:mode bib-ieeetr?)
+  (with is-entry? (lambda (x) (func? x 'bib-entry)) (list-filter l is-entry?))
+) ;tm-define
+
+(tm-define (new-list-rec s x)
+  (:mode bib-ieeetr?)
+  (cond ((bib-null? x) "")
+        ((bib-null? (car x)) (new-list-rec s (cdr x)))
+        ((null? (cdr x)) (car x))
+        ((and (func? (car x) 'concat) (== (cAr (car x)) "''") (== s ", "))
+         `(concat ,@(cdr (cDr (car x))) ,",'' " ,(new-list-rec s (cdr x)))
+        ) ;
+        (else `(concat ,(car x) ,s ,(new-list-rec s (cdr x))))
+  ) ;cond
+) ;tm-define
+
+(tm-define (bib-format-name x)
+  (:mode bib-ieeetr?)
+  (let* ((f (if (bib-null? (list-ref x 1))
+              ""
+              `(concat ,(bib-abbreviate (list-ref x 1) "." '(nbsp)) (nbsp))
+            ) ;if
+         ) ;f
+         (vv (if (bib-null? (list-ref x 2)) "" `(concat ,(list-ref x 2) (nbsp))))
+         (ll (if (bib-null? (list-ref x 3)) "" (bib-purify (list-ref x 3))))
+         (jj (if (bib-null? (list-ref x 4)) "" `(concat ,", " ,(list-ref x 4))))
+        ) ;
+    `(concat ,f ,vv ,ll ,jj)
+  ) ;let*
+) ;tm-define
+
+(tm-define (bib-last-name-sep a)
+  (:mode bib-ieeetr?)
+  (if (<= (length a) 3) (bib-translate " and ") (bib-translate ", and "))
+) ;tm-define
+
+(tm-define (bib-format-editor x)
+  (:mode bib-ieeetr?)
+  (with a
+    (bib-field x "editor")
+    (if (or (bib-null? a) (nlist? a))
+      ""
+      (if (equal? (length a) 2)
+        `(concat ,(bib-format-names a) ,", ed.")
+        `(concat ,(bib-format-names a) ,", eds.")
+      ) ;if
+    ) ;if
+  ) ;with
+) ;tm-define
+
+(tm-define (bib-format-bvolume x)
+  (:mode bib-ieeetr?)
+  (let* ((v (bib-field x "volume")) (s (bib-field x "series")))
+    (if (bib-null? v)
+      ""
+      (let ((series (if (bib-null? s)
+                      ""
+                      `(concat ,(bib-translate " of ")
+                         (with ,"font-shape" ,"italic" ,s))
+                    ) ;if
+            ) ;series
+            (sep (if (< (bib-text-length v) 3) '(nbsp) " "))
+           ) ;
+        `(concat ,"vol." ,sep ,v ,series)
+      ) ;let
+    ) ;if
+  ) ;let*
+) ;tm-define
+
+(tm-define (bib-format-number-series x)
+  (:mode bib-ieeetr?)
+  (let* ((v (bib-field x "volume"))
+         (n (bib-field x "number"))
+         (s (bib-field x "series"))
+        ) ;
+    (if (bib-null? v)
+      (if (bib-null? n)
+        (if (bib-null? s) "" s)
+        (let ((series (if (bib-null? s) "" `(concat ,(bib-translate " in ") ,s)))
+              (sep (if (< (bib-text-length n) 3) '(nbsp) " "))
+             ) ;
+          `(concat ,"no." ,sep ,n ,series)
+        ) ;let
+      ) ;if
+      ""
+    ) ;if
+  ) ;let*
+) ;tm-define
+
+(define (bib-format-edition x)
+  (with e (bib-field x "edition") (if (bib-null? e) "" `(concat ,e ," ed.")))
+) ;define
+
+(tm-define (bib-format-in-ed-booktitle x)
+  (:mode bib-ieeetr?)
+  (let* ((b (bib-field x "booktitle")) (e (bib-field x "editor")))
+    (if (bib-null? b)
+      ""
+      (if (bib-null? e)
+        `(concat ,(bib-translate "in ") (with ,"font-shape" ,"italic" ,b))
+        `(concat ,(bib-translate "in ")
+           (with ,"font-shape" ,"italic" ,b)
+           ," ("
+           ,(bib-format-editor x)
+           ,")")
+      ) ;if
+    ) ;if
+  ) ;let*
+) ;tm-define
+
+(define (bib-format-address-publisher x)
+  (let* ((a (bib-field x "address")) (p (bib-field x "publisher")))
+    (if (bib-null? a) p (if (bib-null? p) a `(concat ,a ,": " ,p)))
+  ) ;let*
+) ;define
+
+(tm-define (bib-format-pages x)
+  (:mode bib-ieeetr?)
+  (with p
+    (bib-field x "pages")
+    (cond ((or (bib-null? p) (nlist? p)) "")
+          ((== (length p) 1) "")
+          ((== (length p) 2) `(concat ,"p." (nbsp) ,(list-ref p 1)))
+          (else `(concat ,"pp."
+                   (nbsp)
+                   ,(list-ref p 1)
+                   ,bib-range-symbol
+                   ,(list-ref p 2)))
+    ) ;cond
+  ) ;with
+) ;tm-define
+
+(tm-define (bib-format-article n x)
+  (:mode bib-ieeetr?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-new-sentence `(,(bib-format-author x)
+                                                              (concat ,"``"
+                                                                ,(bib-format-field-Locase x
+                                                                   "title")
+                                                                ,"''")
+                                                              ,@(if (bib-empty? x
+                                                                      "crossref")
+                                                                  `(,(bib-emphasize (bib-format-field x
+                                                                                      "journal"))
+                                                                    ,(if (bib-empty? x
+                                                                           "volume")
+                                                                       ""
+                                                                       `(concat ,"vol."
+                                                                          (nbsp)
+                                                                          ,(bib-field x
+                                                                             "volume")))
+                                                                    ,(if (bib-empty? x
+                                                                           "number")
+                                                                       ""
+                                                                       `(concat ,"no."
+                                                                          (nbsp)
+                                                                          ,(bib-field x
+                                                                             "number")))
+                                                                    ,(bib-format-pages x)
+                                                                    ,(bib-format-date x))
+                                                                  `((concat ,(bib-translate "in ")
+                                                                      (cite ,(bib-field x
+                                                                               "crossref")))
+                                                                    ,(bib-format-pages x))))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-book n x)
+  (:mode bib-ieeetr?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-new-sentence `(,(if (bib-empty? x
+                                                                     "author")
+                                                                 (bib-format-editor x)
+                                                                 (bib-format-author x))
+                                                              ,(bib-emphasize (bib-format-field x
+                                                                                "title"))
+                                                              ,(if (bib-empty? x
+                                                                     "crossref")
+                                                                 (bib-format-bvolume x)
+                                                                 ""))))
+                          ,(bib-new-block (bib-new-sentence `(,@(if (bib-empty? x
+                                                                      "crossref")
+                                                                  `(,(bib-format-number-series x)
+                                                                    ,(bib-format-address-publisher x)
+                                                                    ,(bib-format-edition x)
+                                                                    ,(bib-format-date x))
+                                                                  `((concat ,(bib-translate "in ")
+                                                                      (cite ,(bib-field x
+                                                                               "crossref")))
+                                                                    ,(bib-format-field x
+                                                                       "edition")
+                                                                    ,(bib-format-date x))))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-booklet n x)
+  (:mode bib-ieeetr?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-new-sentence `(,(bib-format-author x)
+                                                              (concat ,"``"
+                                                                ,(bib-format-field-Locase x
+                                                                   "title")
+                                                                ,"''"))))
+                          ,(bib-new-block (bib-new-sentence `(,(bib-format-field-preserve-case x
+                                                                 "howpublished")
+                                                              ,(bib-format-field x
+                                                                 "address")
+                                                              ,(bib-format-date x))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-inbook n x)
+  (:mode bib-ieeetr?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-new-sentence `(,(if (bib-empty? x
+                                                                     "author")
+                                                                 (bib-format-editor x)
+                                                                 (bib-format-author x))
+                                                              ,(bib-emphasize (bib-format-field x
+                                                                                "title"))
+                                                              ,(bib-format-bvolume x)
+                                                              ,(bib-format-chapter-pages x))))
+                          ,(bib-new-block (bib-new-sentence `(,@(if (bib-empty? x
+                                                                      "crossref")
+                                                                  `(,(bib-format-number-series x)
+                                                                    ,(bib-format-address-publisher x)
+                                                                    ,(bib-format-edition x)
+                                                                    ,(bib-format-date x))
+                                                                  `((concat ,(bib-translate "in ")
+                                                                      (cite ,(bib-field x
+                                                                               "crossref")))
+                                                                    ,(bib-format-date x))))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-incollection n x)
+  (:mode bib-ieeetr?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-new-sentence `(,(bib-format-author x)
+                                                              (concat ,"``"
+                                                                ,(bib-format-field-Locase x
+                                                                   "title")
+                                                                ,"''")
+                                                              ,@(if (bib-empty? x
+                                                                      "crossref")
+                                                                  `(,(bib-format-in-ed-booktitle x)
+                                                                    ,(bib-format-bvolume x)
+                                                                    ,(bib-format-number-series x)
+                                                                    ,(bib-format-chapter-pages x)
+                                                                    ,(bib-format-address-publisher x)
+                                                                    ,(bib-format-edition x)
+                                                                    ,(bib-format-date x))
+                                                                  `((concat ,(bib-translate "in ")
+                                                                      (cite ,(bib-field x
+                                                                               "crossref")))
+                                                                    ,(bib-format-chapter-pages x))))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-inproceedings n x)
+  (:mode bib-ieeetr?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-new-sentence `(,(bib-format-author x)
+                                                              (concat ,"``"
+                                                                ,(bib-format-field-Locase x
+                                                                   "title")
+                                                                ,"''")
+                                                              ,@(if (bib-empty? x
+                                                                      "crossref")
+                                                                  `(,(bib-format-in-ed-booktitle x)
+                                                                    ,(bib-format-bvolume x)
+                                                                    ,(bib-format-number-series x)
+                                                                    (concat ,"("
+                                                                      ,(bib-format-field x
+                                                                         "address")
+                                                                      ,")")
+                                                                    ,(bib-format-pages x)
+                                                                    ,(bib-format-field x
+                                                                       "organization")
+                                                                    ,(bib-format-field x
+                                                                       "publisher")
+                                                                    ,(bib-format-date x))
+                                                                  `((concat ,(bib-translate "in ")
+                                                                      (cite ,(bib-field x
+                                                                               "crossref")))
+                                                                    ,(bib-format-pages x))))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-manual n x)
+  (:mode bib-ieeetr?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-new-sentence `(,@(if (bib-empty? x
+                                                                      "author")
+                                                                  (if (bib-empty? x
+                                                                        "organization")
+                                                                    ()
+                                                                    `(,(bib-format-field x
+                                                                         "organization")
+                                                                      ,(bib-format-field x
+                                                                         "address")))
+                                                                  `(,(bib-format-author x)))
+                                                              ,(bib-emphasize (bib-format-field x
+                                                                                "title")))))
+                          ,(bib-new-block (bib-new-sentence `(,(bib-format-field x
+                                                                 "organization")
+                                                              ,(bib-format-field x
+                                                                 "address")
+                                                              ,(bib-format-edition x)
+                                                              ,(bib-format-date x))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-mastersthesis n x)
+  (:mode bib-ieeetr?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-new-sentence `(,(bib-format-author x)
+                                                              (concat ,"``"
+                                                                ,(bib-format-field-Locase x
+                                                                   "title")
+                                                                ,"''")
+                                                              ,(if (bib-empty? x
+                                                                     "type")
+                                                                 (bib-translate "Master's thesis")
+                                                                 (bib-format-field x
+                                                                   "type"))
+                                                              ,(bib-format-field x
+                                                                 "school")
+                                                              ,(bib-format-field x
+                                                                 "address")
+                                                              ,(bib-format-date x))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-misc n x)
+  (:mode bib-ieeetr?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-case-preserved-block (bib-new-case-preserved-sentence `(,(bib-format-author x)
+                                                                                            (concat ,"``"
+                                                                                              ,(bib-format-field-Locase x
+                                                                                                 "title")
+                                                                                              ,"''")
+                                                                                            ,(bib-format-field-preserve-case x
+                                                                                               "howpublished")
+                                                                                            ,(bib-format-date x))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-phdthesis n x)
+  (:mode bib-ieeetr?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-new-sentence `(,(bib-format-author x)
+                                                              ,(bib-emphasize (bib-format-field-Locase x
+                                                                                "title"))
+                                                              ,(if (bib-empty? x
+                                                                     "type")
+                                                                 (bib-translate "Master's thesis")
+                                                                 (bib-format-field x
+                                                                   "type"))
+                                                              ,(bib-format-field x
+                                                                 "school")
+                                                              ,(bib-format-field x
+                                                                 "address")
+                                                              ,(bib-format-date x))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-proceedings n x)
+  (:mode bib-ieeetr?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-new-sentence `(,(if (bib-empty? x
+                                                                     "editor")
+                                                                 (bib-format-field x
+                                                                   "organization")
+                                                                 (bib-format-editor x))
+                                                              ,(bib-emphasize (bib-format-field x
+                                                                                "title"))
+                                                              ,(bib-format-bvolume x)
+                                                              ,(bib-format-number-series x)
+                                                              ,(if (bib-empty? x
+                                                                     "editor")
+                                                                 ""
+                                                                 (bib-format-field x
+                                                                   "organization"))
+                                                              (concat ,"("
+                                                                ,(bib-format-field x
+                                                                   "address")
+                                                                ,")")
+                                                              ,(bib-format-field x
+                                                                 "publisher")
+                                                              ,(bib-format-date x))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-techreport n x)
+  (:mode bib-ieeetr?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-new-sentence `(,(bib-format-author x)
+                                                              (concat ,"``"
+                                                                ,(bib-format-field-Locase x
+                                                                   "title")
+                                                                ,"''")
+                                                              ,(bib-format-tr-number x)
+                                                              ,(bib-format-field x
+                                                                 "institution")
+                                                              ,(bib-format-field x
+                                                                 "address")
+                                                              ,(bib-format-date x))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-unpublished n x)
+  (:mode bib-ieeetr?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-new-sentence `(,(bib-format-author x)
+                                                              (concat ,"``"
+                                                                ,(bib-format-field-Locase x
+                                                                   "title")
+                                                                ,"''"))))
+                          ,(bib-new-block (bib-new-sentence `(,(bib-format-field x
+                                                                 "note")
+                                                              ,(bib-format-date x)))))))
+) ;tm-define
diff --git a/TeXmacs/plugins/latex/progs/latex/bibtex-plain.scm b/TeXmacs/plugins/latex/progs/latex/bibtex-plain.scm
new file mode 100644
index 0000000000..6e336aed3b
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/bibtex-plain.scm
@@ -0,0 +1,654 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : plain.scm
+;; DESCRIPTION : plain style for BibTeX files
+;; COPYRIGHT   : (C) 2010, 2015  David MICHEL, Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; To translate (except in french):
+;; "edition"
+;; "editor"
+;; "editors"
+;; "master's thesis"
+;; "in"
+;; "number" ???
+;; "of"
+;; "pages"
+;; "phd thesis"
+;; "technical report"
+;; "volume"
+
+(texmacs-module (latex bibtex-plain) (:use (latex bibtex-bib-utils)))
+
+(bib-define-style "plain" "plain")
+
+(tm-define (bib-preprocessing t) (:mode bib-plain?) ())
+
+(define (bib-non-breaking x)
+  (cond ((tm-func? x 'concat)
+         (with l (map bib-non-breaking (tm-children x)) (apply tmconcat l))
+        ) ;
+        ((string? x)
+         (let* ((l (string-tokenize-by-char x #\space)) (r (list-intersperse l '(nbsp))))
+           (apply tmconcat r)
+         ) ;let*
+        ) ;
+        (else x)
+  ) ;cond
+) ;define
+
+(tm-define (bib-name-ends? x s)
+  (cond ((tm-func? x 'concat) (bib-name-ends? (cAr x) s))
+        ((string? x) (string-ends? x s))
+        (else #f)
+  ) ;cond
+) ;tm-define
+
+(tm-define (bib-format-first-name x)
+  (if (bib-null? (list-ref x 1))
+    ""
+    (with f
+      (bib-non-breaking (list-ref x 1))
+      (if (bib-name-ends? f ".") (tmconcat f '(nbsp)) (tmconcat f " "))
+    ) ;with
+  ) ;if
+) ;tm-define
+
+(tm-define (bib-format-name x)
+  ;; (:mode bib-plain?)
+  (let* ((ff (bib-format-first-name x))
+         (vv (if (bib-null? (list-ref x 2)) "" `(concat ,(list-ref x 2) (nbsp))))
+         (ll (if (bib-null? (list-ref x 3)) "" (bib-purify (list-ref x 3))))
+         (jj (if (bib-null? (list-ref x 4)) "" `(concat ,", " ,(list-ref x 4))))
+        ) ;
+    `(concat ,ff ,vv ,ll ,jj)
+  ) ;let*
+) ;tm-define
+
+(define (bib-format-names-rec n lim a)
+  (if (equal? n lim)
+    ""
+    `(concat ,", "
+       ,(bib-format-name (list-ref a n))
+       ,(bib-format-names-rec (+ n 1) lim a))
+  ) ;if
+) ;define
+
+(tm-define (bib-last-name-sep a)
+  ;; (:mode bib-plain?)
+  (if (<= (length a) 3) (bib-translate " and ") (bib-translate ", and "))
+) ;tm-define
+
+(tm-define (bib-format-names a)
+  ;; (:mode bib-plain?)
+  (if (or (bib-null? a) (nlist? a))
+    ""
+    (let* ((n (length a)))
+      (if (equal? n 2)
+        (bib-format-name (list-ref a 1))
+        (let* ((b (bib-format-name (list-ref a 1)))
+               (m (bib-format-names-rec 2 (- n 1) a))
+               (e (if (or (== (list-ref (list-ref a (- n 1)) 3) "others")
+                        (== (list-ref (list-ref a (- n 1)) 4) "others")
+                      ) ;or
+                    '(concat " et" (nbsp) "al")
+                    `(concat ,(bib-last-name-sep a)
+                       ,(bib-format-name (list-ref a (- n 1))))
+                  ) ;if
+               ) ;e
+              ) ;
+          `(concat ,b ,m ,e)
+        ) ;let*
+      ) ;if
+    ) ;let*
+  ) ;if
+) ;tm-define
+
+(tm-define (bib-format-author x)
+  ;; (:mode bib-plain?)
+  (with a (bib-field x "author") (if (bib-null? a) "" (bib-format-names a)))
+) ;tm-define
+
+(tm-define (bib-format-editor x)
+  ;; (:mode bib-plain?)
+  (with a
+    (bib-field x "editor")
+    (if (or (bib-null? a) (nlist? a))
+      ""
+      (if (equal? (length a) 2)
+        `(concat ,(bib-format-names a) ,(bib-translate ", editor"))
+        `(concat ,(bib-format-names a) ,(bib-translate ", editors"))
+      ) ;if
+    ) ;if
+  ) ;with
+) ;tm-define
+
+(tm-define (bib-format-in-ed-booktitle x)
+  ;; (:mode bib-plain?)
+  (let* ((b (bib-default-field x "booktitle")) (e (bib-field x "editor")))
+    (if (bib-null? b)
+      ""
+      (if (bib-null? e)
+        `(concat ,(bib-translate "in ") (with ,"font-shape" ,"italic" ,b))
+        `(concat ,(bib-translate "in ")
+           ,(bib-format-editor x)
+           ,", "
+           (with ,"font-shape" ,"italic" ,b))
+      ) ;if
+    ) ;if
+  ) ;let*
+) ;tm-define
+
+(tm-define (bib-format-bvolume x)
+  ;; (:mode bib-plain?)
+  (let* ((v (bib-field x "volume")) (s (bib-default-field x "series")))
+    (if (bib-null? v)
+      ""
+      (let ((series (if (bib-null? s)
+                      ""
+                      `(concat ,(bib-translate " of ")
+                         (with ,"font-shape" ,"italic" ,s))
+                    ) ;if
+            ) ;series
+            (sep (if (< (bib-text-length v) 3) '(nbsp) " "))
+           ) ;
+        `(concat ,(bib-translate "volume") ,sep ,v ,series)
+      ) ;let
+    ) ;if
+  ) ;let*
+) ;tm-define
+
+(tm-define (bib-format-number-series x)
+  ;; (:mode bib-plain?)
+  (let* ((v (bib-field x "volume"))
+         (n (bib-field x "number"))
+         (s (bib-default-field x "series"))
+        ) ;
+    (if (bib-null? v)
+      (if (bib-null? n)
+        (if (bib-null? s) "" s)
+        (let ((series (if (bib-null? s) "" `(concat ,(bib-translate " in ") ,s)))
+              (sep (if (< (bib-text-length n) 3) '(nbsp) " "))
+             ) ;
+          `(concat ,(bib-translate "number") ,sep ,n ,series)
+        ) ;let
+      ) ;if
+      ""
+    ) ;if
+  ) ;let*
+) ;tm-define
+
+(tm-define (bib-format-pages x)
+  ;; (:mode bib-plain?)
+  (with p
+    (bib-field x "pages")
+    (cond ((or (bib-null? p) (nlist? p)) "")
+          ((== (length p) 1) "")
+          ((== (length p) 2) `(concat ,(bib-translate "page ") ,(list-ref p 1)))
+          (else `(concat ,(bib-translate "pages ")
+                   ,(list-ref p 1)
+                   ,bib-range-symbol
+                   ,(list-ref p 2))
+          ) ;else
+    ) ;cond
+  ) ;with
+) ;tm-define
+
+(tm-define (bib-format-chapter-pages x)
+  ;; (:mode bib-plain?)
+  (let* ((c (bib-field x "chapter")) (t (bib-field x "type")))
+    (if (bib-null? c)
+      (bib-format-pages x)
+      (let ((type (if (bib-null? t) (bib-translate "chapter") (bib-locase t)))
+            (pages `(concat ,", " ,(bib-format-pages x)))
+           ) ;
+        `(concat ,type ," " ,c ,pages)
+      ) ;let
+    ) ;if
+  ) ;let*
+) ;tm-define
+
+(tm-define (bib-format-vol-num-pages x)
+  ;; (:mode bib-plain?)
+  (let* ((v (bib-field x "volume"))
+         (n (bib-field x "number"))
+         (p (bib-field x "pages"))
+         (vol (if (bib-null? v) "" v))
+         (num (if (bib-null? n) "" `(concat ,"(" ,n ,")")))
+         (pag (if (or (bib-null? p) (nlist? p))
+                ""
+                (cond ((equal? 1 (length p)) "")
+                      ((equal? 2 (length p)) `(concat ,":" ,(list-ref p 1)))
+                      (else `(concat ,":"
+                               ,(list-ref p 1)
+                               ,bib-range-symbol
+                               ,(list-ref p 2)))
+                ) ;cond
+              ) ;if
+         ) ;pag
+        ) ;
+    (if (and (== vol "") (== num "")) (bib-format-pages x) `(concat ,vol
+                                                              ,num
+                                                              ,pag))
+  ) ;let*
+) ;tm-define
+
+(tm-define (bib-format-date x)
+  ;; (:mode bib-plain?)
+  (let* ((y (bib-field x "year")) (m (bib-field x "month")))
+    (if (bib-null? y)
+      (if (bib-null? m) "" m)
+      (if (bib-null? m) y `(concat ,m ," " ,y))
+    ) ;if
+  ) ;let*
+) ;tm-define
+
+(tm-define (bib-format-tr-number x)
+  ;; (:mode bib-plain?)
+  (let* ((t (bib-field x "type"))
+         (n (bib-field x "number"))
+         (type (if (bib-null? t) (bib-translate "Technical Report") t))
+         (number (if (bib-null? n) "" n))
+         (sep (if (< (bib-text-length n) 3) '(nbsp) " "))
+        ) ;
+    (if (bib-null? n) type `(concat ,type ,sep ,number))
+  ) ;let*
+) ;tm-define
+
+(tm-define (bib-format-bibitem n x)
+  ;; (:mode bib-plain?)
+  `(bibitem* ,(number->string n))
+) ;tm-define
+
+(tm-define (bib-format-article n x)
+  ;; (:mode bib-plain?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-format-author x))
+                          ,(bib-new-block (bib-format-field-Locase x "title"))
+                          ,(bib-new-block (if (bib-empty? x "crossref")
+                                            (bib-new-sentence `(,(bib-emphasize (bib-format-field x
+                                                                                  "journal"))
+                                                                ,(bib-format-vol-num-pages x)
+                                                                ,(bib-format-date x)))
+                                            (bib-new-sentence `((concat ,(bib-translate "in ")
+                                                                  (cite ,(bib-field x
+                                                                           "crossref")))
+                                                                ,(bib-format-pages x)))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-book n x)
+  ;; (:mode bib-plain?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (if (bib-empty? x "author")
+                                            (bib-format-editor x)
+                                            (bib-format-author x)))
+                          ,(bib-new-block (bib-new-sentence `(,(bib-emphasize (bib-format-field x
+                                                                                "title"))
+                                                              ,(bib-format-bvolume x))))
+                          ,(bib-new-block (if (bib-empty? x "crossref")
+                                            (bib-new-list-spc `(,(bib-new-sentence `(,(bib-format-number-series x)))
+                                                                ,(bib-new-sentence `(,(bib-format-field x
+                                                                                        "publisher")
+                                                                                     ,(bib-format-field x
+                                                                                        "address")
+                                                                                     ,(if (bib-empty? x
+                                                                                            "edition")
+                                                                                        ""
+                                                                                        `(concat ,(bib-format-field x
+                                                                                                    "edition")
+                                                                                           ,(bib-translate " edition")))
+                                                                                     ,(bib-format-date x)))))
+                                            (bib-new-sentence `((concat ,(bib-translate "in ")
+                                                                  (cite ,(bib-field x
+                                                                           "crossref")))
+                                                                ,(bib-format-field x
+                                                                   "edition")
+                                                                ,(bib-format-date x)))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-booklet n x)
+  ;; (:mode bib-plain?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-format-author x))
+                          ,(bib-new-block (bib-format-field-Locase x "title"))
+                          ,(bib-new-case-preserved-block (bib-new-case-preserved-sentence `(,(bib-format-field-preserve-case x
+                                                                                               "howpublished")
+                                                                                            ,(bib-upcase-first (bib-format-field x
+                                                                                                                 "address"))
+                                                                                            ,(bib-format-date x))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-inbook n x)
+  ;; (:mode bib-plain?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (if (bib-empty? x "author")
+                                            (bib-format-editor x)
+                                            (bib-format-author x)))
+                          ,(bib-new-block (bib-new-sentence `(,(bib-emphasize (bib-format-field x
+                                                                                "title"))
+                                                              ,(bib-format-bvolume x)
+                                                              ,(bib-format-chapter-pages x))))
+                          ,(bib-new-block (if (bib-empty? x "crossref")
+                                            (bib-new-list-spc `(,(bib-new-sentence `(,(bib-format-number-series x)))
+                                                                ,(bib-new-sentence `(,(bib-format-field x
+                                                                                        "publisher")
+                                                                                     ,(bib-format-field x
+                                                                                        "address")
+                                                                                     ,(if (bib-empty? x
+                                                                                            "edition")
+                                                                                        ""
+                                                                                        `(concat ,(bib-format-field x
+                                                                                                    "edition")
+                                                                                           ,(bib-translate " edition")))
+                                                                                     ,(bib-format-date x)))))
+                                            (bib-new-sentence `(,(bib-format-chapter-pages x)
+                                                                (concat ,(bib-translate "in ")
+                                                                  (cite ,(bib-field x
+                                                                           "crossref")))))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-incollection n x)
+  ;; (:mode bib-plain?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-format-author x))
+                          ,(bib-new-block (bib-format-field-Locase x "title"))
+                          ,(bib-new-block (if (bib-empty? x "crossref")
+                                            (bib-new-list-spc `(,(bib-new-sentence `(,(bib-format-in-ed-booktitle x)
+                                                                                     ,(bib-format-bvolume x)
+                                                                                     ,(bib-format-number-series x)
+                                                                                     ,(bib-format-chapter-pages x)))
+                                                                ,(bib-new-sentence `(,(bib-format-field x
+                                                                                        "publisher")
+                                                                                     ,(bib-format-field x
+                                                                                        "address")
+                                                                                     ,(bib-format-date x)))))
+                                            (bib-new-sentence `((concat ,(bib-translate "in ")
+                                                                  (cite ,(bib-field x
+                                                                           "crossref")))
+                                                                ,(bib-format-chapter-pages x)))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-inproceedings n x)
+  ;; (:mode bib-plain?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-format-author x))
+                          ,(bib-new-block (bib-format-field-Locase x "title"))
+                          ,(bib-new-block (if (bib-empty? x "crossref")
+                                            (bib-new-list-spc `(,(bib-new-sentence `(,(bib-format-in-ed-booktitle x)
+                                                                                     ,(bib-format-bvolume x)
+                                                                                     ,(bib-format-number-series x)
+                                                                                     ,(bib-format-pages x)))
+                                                                ,(if (bib-empty? x
+                                                                       "address")
+                                                                   (bib-new-sentence `(,(bib-format-field x
+                                                                                          "organization")
+                                                                                       ,(bib-format-field x
+                                                                                          "publisher")
+                                                                                       ,(bib-format-date x)))
+                                                                   (bib-new-list-spc `(,(bib-new-sentence `(,(bib-format-field x
+                                                                                                               "address")
+                                                                                                            ,(bib-format-date x)))
+                                                                                       ,(bib-new-sentence `(,(bib-format-field x
+                                                                                                               "organization")
+                                                                                                            ,(bib-format-field x
+                                                                                                               "publisher"))))))))
+                                            (bib-new-sentence `((concat ,(bib-translate "in ")
+                                                                  (cite ,(bib-field x
+                                                                           "crossref")))
+                                                                ,(bib-format-pages x)))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-manual n x)
+  ;; (:mode bib-plain?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (if (bib-empty? x "author")
+                                            (if (bib-empty? x "organization")
+                                              ""
+                                              (bib-new-sentence `(,(bib-format-field x
+                                                                     "organization")
+                                                                  ,(bib-format-field x
+                                                                     "address"))))
+                                            (bib-format-author x)))
+                          ,(bib-new-block (bib-emphasize (bib-format-field x
+                                                           "title")))
+                          ,(bib-new-block (bib-new-sentence `(,(bib-format-field x
+                                                                 "organization")
+                                                              ,(bib-format-field x
+                                                                 "address")
+                                                              ,(if (bib-empty? x
+                                                                     "edition")
+                                                                 ""
+                                                                 `(concat ,(bib-format-field x
+                                                                             "edition")
+                                                                    ,(bib-translate " edition")))
+                                                              ,(bib-format-date x))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-mastersthesis n x)
+  ;; (:mode bib-plain?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-format-author x))
+                          ,(bib-new-block (bib-format-field-Locase x "title"))
+                          ,(bib-new-block (bib-new-sentence `(,(if (bib-empty? x
+                                                                     "type")
+                                                                 (bib-translate "Master's thesis")
+                                                                 (bib-format-field-Locase x
+                                                                   "type"))
+                                                              ,(bib-format-field x
+                                                                 "school")
+                                                              ,(bib-format-field x
+                                                                 "address")
+                                                              ,(bib-format-date x))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-misc n x)
+  ;; (:mode bib-plain?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-format-author x))
+                          ,(bib-new-block (bib-format-field-Locase x "title"))
+                          ,(bib-new-case-preserved-block (bib-new-case-preserved-sentence `(,(bib-format-field-preserve-case x
+                                                                                               "howpublished")
+                                                                                            ,(bib-format-date x))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-phdthesis n x)
+  ;; (:mode bib-plain?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-format-author x))
+                          ,(bib-new-block (bib-emphasize (bib-format-field x
+                                                           "title")))
+                          ,(bib-new-block (bib-new-sentence `(,(if (bib-empty? x
+                                                                     "type")
+                                                                 (bib-translate "PhD thesis")
+                                                                 (bib-format-field-Locase x
+                                                                   "type"))
+                                                              ,(bib-format-field x
+                                                                 "school")
+                                                              ,(bib-format-field x
+                                                                 "address")
+                                                              ,(bib-format-date x))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-proceedings n x)
+  ;; (:mode bib-plain?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (if (bib-empty? x "editor")
+                                            (bib-format-field x "organization")
+                                            (bib-format-editor x)))
+                          ,(bib-new-block (bib-new-sentence `(,(bib-emphasize (bib-format-field x
+                                                                                "title"))
+                                                              ,(bib-format-bvolume x)
+                                                              ,(bib-format-number-series x))))
+                          ,(bib-new-block (if (bib-empty? x "address")
+                                            (bib-new-sentence `(,(if (bib-empty? x
+                                                                       "editor")
+                                                                   ""
+                                                                   (bib-format-field x
+                                                                     "organization"))
+                                                                ,(bib-format-field x
+                                                                   "publisher")
+                                                                ,(bib-format-date x)))
+                                            (bib-new-list-spc `(,(bib-new-sentence `(,(bib-format-field x
+                                                                                        "address")
+                                                                                     ,(bib-format-date x)))
+                                                                ,(bib-new-sentence `(,(if (bib-empty? x
+                                                                                            "editor")
+                                                                                        ""
+                                                                                        (bib-format-field x
+                                                                                          "organization"))
+                                                                                     ,(bib-format-field x
+                                                                                        "publisher")))))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-techreport n x)
+  ;; (:mode bib-plain?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-format-author x))
+                          ,(bib-new-block (bib-format-field-Locase x "title"))
+                          ,(bib-new-block (bib-new-sentence `(,(bib-format-tr-number x)
+                                                              ,(bib-format-field x
+                                                                 "institution")
+                                                              ,(bib-format-field x
+                                                                 "address")
+                                                              ,(bib-format-date x))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-unpublished n x)
+  ;; (:mode bib-plain?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-format-author x))
+                          ,(bib-new-block (bib-format-field-Locase x "title"))
+                          ,(bib-new-block (bib-new-sentence `(,(bib-format-field x
+                                                                 "note")
+                                                              ,(bib-format-date x)))))))
+) ;tm-define
+
+(tm-define (bib-format-entry n x)
+  ;; (:mode bib-plain?)
+  (if (and (list? x)
+        (func? x 'bib-entry)
+        (= (length x) 4)
+        (func? (list-ref x 3) 'document)
+      ) ;and
+    (with doctype
+      (list-ref x 1)
+      (cond ((equal? doctype "article") (bib-format-article n x))
+            ((equal? doctype "book") (bib-format-book n x))
+            ((equal? doctype "booklet") (bib-format-booklet n x))
+            ((equal? doctype "inbook") (bib-format-inbook n x))
+            ((equal? doctype "incollection") (bib-format-incollection n x))
+            ((equal? doctype "inproceedings") (bib-format-inproceedings n x))
+            ((equal? doctype "conference") (bib-format-inproceedings n x))
+            ((equal? doctype "manual") (bib-format-manual n x))
+            ((equal? doctype "mastersthesis") (bib-format-mastersthesis n x))
+            ((equal? doctype "misc") (bib-format-misc n x))
+            ((equal? doctype "phdthesis") (bib-format-phdthesis n x))
+            ((equal? doctype "proceedings") (bib-format-proceedings n x))
+            ((equal? doctype "techreport") (bib-format-techreport n x))
+            ((equal? doctype "unpublished") (bib-format-unpublished n x))
+            (else (bib-format-misc n x))
+      ) ;cond
+    ) ;with
+  ) ;if
+) ;tm-define
+
+(define (author-sort-format a)
+  (if (or (npair? a) (null? a))
+    ""
+    (with name
+      (let* ((x (car a))
+             (ff (if (equal? (list-ref x 1) "")
+                   ""
+                   (string-append (bib-purify (list-ref x 1)) " ")
+                 ) ;if
+             ) ;ff
+             (vv (if (equal? (list-ref x 2) "")
+                   ""
+                   (string-append (bib-purify (list-ref x 2)) " ")
+                 ) ;if
+             ) ;vv
+             (ll (if (equal? (list-ref x 3) "")
+                   ""
+                   (string-append (bib-purify (list-ref x 3)) " ")
+                 ) ;if
+             ) ;ll
+             (jj (if (equal? (list-ref x 4) "")
+                   ""
+                   (string-append (bib-purify (list-ref x 4)) " ")
+                 ) ;if
+             ) ;jj
+            ) ;
+        (string-append vv ll ff jj)
+      ) ;let*
+      (string-append name (author-sort-format (bib-cdr a)))
+    ) ;with
+  ) ;if
+) ;define
+
+(define (author-editor-sort-key x)
+  (if (bib-empty? x "author")
+    (if (bib-empty? x "editor")
+      (list-ref x 2)
+      (string-upcase (author-sort-format (bib-cdr (bib-field x "editor"))))
+    ) ;if
+    (string-upcase (author-sort-format (bib-cdr (bib-field x "author"))))
+  ) ;if
+) ;define
+
+(define (author-sort-key x ae)
+  (if (bib-empty? x ae)
+    (list-ref x 2)
+    ;; (author-sort-format (bib-cdr (bib-field x ae)))))
+    (string-upcase (author-sort-format (bib-cdr (bib-field x ae))))
+  ) ;if
+) ;define
+
+(tm-define (bib-sort-key x)
+  ;; (:mode bib-plain?)
+  (let* ((doctype (list-ref x 1))
+         (pre (cond ((or (equal? doctype "inbook") (equal? doctype "book"))
+                     (author-editor-sort-key x)
+                    ) ;
+                    ((equal? doctype "proceedings") (author-sort-key x "editor"))
+                    (else (author-sort-key x "author"))
+              ) ;cond
+         ) ;pre
+        ) ;
+    (string-append pre
+      "    "
+      (if (bib-empty? x "year") "" (string-append (bib-field x "year") "    "))
+      (bib-purify (bib-field x "title"))
+    ) ;string-append
+  ) ;let*
+) ;tm-define
diff --git a/TeXmacs/plugins/latex/progs/latex/bibtex-siam.scm b/TeXmacs/plugins/latex/progs/latex/bibtex-siam.scm
new file mode 100644
index 0000000000..ff846b042e
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/bibtex-siam.scm
@@ -0,0 +1,414 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : siam.scm
+;; DESCRIPTION : siam style for BibTeX files
+;; COPYRIGHT   : (C) 2010, 2015  David MICHEL, Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex bibtex-siam)
+  (:use (latex bibtex-bib-utils) (latex bibtex-plain))
+) ;texmacs-module
+
+(bib-define-style "siam" "plain")
+
+(tm-define (bib-format-name x)
+  (:mode bib-siam?)
+  (let* ((f (if (bib-null? (list-ref x 1))
+              ""
+              `(concat ,(bib-abbreviate (list-ref x 1) "." '(nbsp)) (nbsp))
+            ) ;if
+         ) ;f
+         (vv (if (bib-null? (list-ref x 2)) "" `(concat ,(list-ref x 2) (nbsp))))
+         (ll (if (bib-null? (list-ref x 3)) "" (bib-purify (list-ref x 3))))
+         (jj (if (bib-null? (list-ref x 4)) "" `(concat ,", " ,(list-ref x 4))))
+        ) ;
+    `(with ,"font-shape" ,"small-caps" (concat ,f ,vv ,ll ,jj))
+  ) ;let*
+) ;tm-define
+
+(tm-define (bib-format-editor x)
+  (:mode bib-siam?)
+  (with a
+    (bib-field x "editor")
+    (if (or (bib-null? a) (nlist? a))
+      ""
+      (if (equal? (length a) 2)
+        `(concat ,(bib-format-names a) ,", ed.")
+        `(concat ,(bib-format-names a) ,", eds.")
+      ) ;if
+    ) ;if
+  ) ;with
+) ;tm-define
+
+(tm-define (bib-format-bvolume x)
+  (:mode bib-siam?)
+  (let* ((v (bib-field x "volume")) (s (bib-field x "series")))
+    (if (bib-null? v)
+      ""
+      (let ((series (if (bib-null? s) "" `(concat ,(bib-translate " of ") ,s)))
+            (sep (if (< (bib-text-length v) 3) '(nbsp) " "))
+           ) ;
+        `(concat ,"vol." ,sep ,v ,series)
+      ) ;let
+    ) ;if
+  ) ;let*
+) ;tm-define
+
+(tm-define (bib-format-number-series x)
+  (:mode bib-siam?)
+  (let* ((v (bib-field x "volume"))
+         (n (bib-field x "number"))
+         (s (bib-field x "series"))
+        ) ;
+    (if (bib-null? v)
+      (if (bib-null? n)
+        (if (bib-null? s) "" s)
+        (let ((series (if (bib-null? s) "" `(concat ,(bib-translate " in ") ,s)))
+              (sep (if (< (bib-text-length n) 3) '(nbsp) " "))
+             ) ;
+          `(concat ,"no." ,sep ,n ,series)
+        ) ;let
+      ) ;if
+      ""
+    ) ;if
+  ) ;let*
+) ;tm-define
+
+(define (bib-format-edition x)
+  (with e (bib-field x "edition") (if (bib-null? e) "" `(concat ,e ," ed.")))
+) ;define
+
+(tm-define (bib-format-in-ed-booktitle x)
+  (:mode bib-siam?)
+  (let* ((b (bib-field x "booktitle")) (e (bib-field x "editor")))
+    (if (bib-null? b)
+      ""
+      (if (bib-null? e)
+        `(concat ,(bib-translate "in ") ,b)
+        `(concat ,(bib-translate "in ") ,b ,", " ,(bib-format-editor x))
+      ) ;if
+    ) ;if
+  ) ;let*
+) ;tm-define
+
+(tm-define (bib-format-chapter-pages x)
+  (:mode bib-siam?)
+  (let* ((c (bib-field x "chapter")) (t (bib-field x "type")))
+    (if (bib-null? c)
+      (bib-format-pages x)
+      (let ((type (if (bib-null? t) (bib-translate "chapter") (bib-locase t)))
+            (pages `(concat ,", " ,(bib-format-pages x)))
+           ) ;
+        `(concat ,type ," " ,c ,pages)
+      ) ;let
+    ) ;if
+  ) ;let*
+) ;tm-define
+
+(tm-define (bib-format-pages x)
+  (:mode bib-siam?)
+  (with p
+    (bib-field x "pages")
+    (cond ((or (bib-null? p) (nlist? p)) "")
+          ((== (length p) 1) "")
+          ((== (length p) 2) `(concat ,"p." (nbsp) ,(list-ref p 1)))
+          (else `(concat ,"pp."
+                   (nbsp)
+                   ,(list-ref p 1)
+                   ,bib-range-symbol
+                   ,(list-ref p 2)))
+    ) ;cond
+  ) ;with
+) ;tm-define
+
+(tm-define (bib-format-article n x)
+  (:mode bib-siam?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-new-sentence `(,(bib-format-author x)
+                                                              ,(bib-emphasize (bib-format-field-Locase x
+                                                                                "title"))
+                                                              ,@(if (bib-empty? x
+                                                                      "crossref")
+                                                                  `(,(bib-format-field x
+                                                                       "journal")
+                                                                    (concat ,(bib-field x
+                                                                               "volume")
+                                                                      ,(if (bib-empty? x
+                                                                             "year")
+                                                                         ""
+                                                                         `(concat ,(if (bib-empty? x
+                                                                                         "volume")
+                                                                                     ""
+                                                                                     " ")
+                                                                            ,"("
+                                                                            ,(bib-field x
+                                                                               "year")
+                                                                            ,")")))
+                                                                    ,(bib-format-pages x))
+                                                                  `((concat ,(bib-translate "in ")
+                                                                      (cite ,(bib-field x
+                                                                               "crossref")))
+                                                                    ,(bib-format-pages x))))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-book n x)
+  (:mode bib-siam?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-new-sentence `(,(if (bib-empty? x
+                                                                     "author")
+                                                                 (bib-format-editor x)
+                                                                 (bib-format-author x))
+                                                              ,(bib-emphasize (bib-format-field x
+                                                                                "title"))
+                                                              ,@(if (bib-empty? x
+                                                                      "crossref")
+                                                                  `(,(bib-format-bvolume x)
+                                                                    ,(bib-format-number-series x)
+                                                                    ,(bib-format-field x
+                                                                       "publisher")
+                                                                    ,(bib-format-field x
+                                                                       "address")
+                                                                    ,(bib-format-edition x)
+                                                                    ,(bib-format-date x))
+                                                                  `((concat ,(bib-translate "in ")
+                                                                      (cite ,(bib-field x
+                                                                               "crossref")))
+                                                                    ,(bib-format-field x
+                                                                       "edition")
+                                                                    ,(bib-format-date x))))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-booklet n x)
+  (:mode bib-siam?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-new-sentence `(,(bib-format-author x)
+                                                              ,(bib-emphasize (bib-format-field-Locase x
+                                                                                "title")))))
+                          ,(bib-new-case-preserved-block (bib-new-case-preserved-sentence `(,(bib-format-field-preserve-case x
+                                                                                               "howpublished")
+                                                                                            ,(bib-format-field x
+                                                                                               "address")
+                                                                                            ,(bib-format-date x))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-inbook n x)
+  (:mode bib-siam?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-new-sentence `(,(if (bib-empty? x
+                                                                     "author")
+                                                                 (bib-format-editor x)
+                                                                 (bib-format-author x))
+                                                              ,(bib-emphasize (bib-format-field x
+                                                                                "title"))
+                                                              ,@(if (bib-empty? x
+                                                                      "crossref")
+                                                                  `(,(bib-format-bvolume x)
+                                                                    ,(bib-format-number-series x)
+                                                                    ,(bib-format-field x
+                                                                       "publisher")
+                                                                    ,(bib-format-field x
+                                                                       "address")
+                                                                    ,(bib-format-edition x)
+                                                                    ,(bib-format-date x)
+                                                                    ,(bib-format-chapter-pages x))
+                                                                  `((concat ,(bib-translate "in ")
+                                                                      (cite ,(bib-field x
+                                                                               "crossref")))
+                                                                    ,(bib-format-date x))))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-incollection n x)
+  (:mode bib-siam?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-new-sentence `(,(bib-format-author x)
+                                                              ,(bib-emphasize (bib-format-field-Locase x
+                                                                                "title"))
+                                                              ,@(if (bib-empty? x
+                                                                      "crossref")
+                                                                  `(,(bib-format-in-ed-booktitle x)
+                                                                    ,(bib-format-bvolume x)
+                                                                    ,(bib-format-number-series x)
+                                                                    ,(bib-format-field x
+                                                                       "publisher")
+                                                                    ,(bib-format-field x
+                                                                       "address")
+                                                                    ,(bib-format-edition x)
+                                                                    ,(bib-format-date x)
+                                                                    ,(bib-format-chapter-pages x))
+                                                                  `((concat ,(bib-translate "in ")
+                                                                      (cite ,(bib-field x
+                                                                               "crossref")))
+                                                                    ,(bib-format-chapter-pages x))))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-inproceedings n x)
+  (:mode bib-siam?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-new-sentence `(,(bib-format-author x)
+                                                              ,(bib-emphasize (bib-format-field-Locase x
+                                                                                "title"))
+                                                              ,@(if (bib-empty? x
+                                                                      "crossref")
+                                                                  `(,(bib-format-in-ed-booktitle x)
+                                                                    ,(bib-format-bvolume x)
+                                                                    ,(bib-format-number-series x)
+                                                                    ,(bib-format-field x
+                                                                       "address")
+                                                                    ,(bib-format-date x)
+                                                                    ,(bib-format-field x
+                                                                       "organization")
+                                                                    ,(bib-format-field x
+                                                                       "publisher")
+                                                                    ,(bib-format-pages x))
+                                                                  `((concat ,(bib-translate "in ")
+                                                                      (cite ,(bib-field x
+                                                                               "crossref")))
+                                                                    ,(bib-format-pages x))))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-manual n x)
+  (:mode bib-siam?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-new-sentence `(,@(if (bib-empty? x
+                                                                      "author")
+                                                                  (if (bib-empty? x
+                                                                        "organization")
+                                                                    ()
+                                                                    `(,(bib-format-field x
+                                                                         "organization")
+                                                                      ,(bib-format-field x
+                                                                         "address")))
+                                                                  `(,(bib-format-author x)))
+                                                              ,(bib-emphasize (bib-format-field x
+                                                                                "title")))))
+                          ,(bib-new-block (bib-new-sentence `(,(bib-format-field x
+                                                                 "organization")
+                                                              ,(bib-format-field x
+                                                                 "address")
+                                                              ,(bib-format-edition x)
+                                                              ,(bib-format-date x))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-mastersthesis n x)
+  (:mode bib-siam?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-new-sentence `(,(bib-format-author x)
+                                                              ,(bib-emphasize (bib-format-field-Locase x
+                                                                                "title"))
+                                                              ,(if (bib-empty? x
+                                                                     "type")
+                                                                 (bib-translate "Master's thesis")
+                                                                 (bib-format-field x
+                                                                   "type"))
+                                                              ,(bib-format-field x
+                                                                 "school")
+                                                              ,(bib-format-field x
+                                                                 "address")
+                                                              ,(bib-format-date x))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-misc n x)
+  (:mode bib-siam?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-new-sentence `(,(bib-format-author x)
+                                                              ,(bib-emphasize (bib-format-field-Locase x
+                                                                                "title")))))
+                          ,(bib-new-case-preserved-block (bib-new-case-preserved-sentence `(,(bib-format-field-preserve-case x
+                                                                                               "howpublished")
+                                                                                            ,(bib-format-date x))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-phdthesis n x)
+  (:mode bib-siam?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-new-sentence `(,(bib-format-author x)
+                                                              ,(bib-emphasize (bib-format-field x
+                                                                                "title"))
+                                                              ,(if (bib-empty? x
+                                                                     "type")
+                                                                 (bib-translate "Master's thesis")
+                                                                 (bib-format-field x
+                                                                   "type"))
+                                                              ,(bib-format-field x
+                                                                 "school")
+                                                              ,(bib-format-field x
+                                                                 "address")
+                                                              ,(bib-format-date x))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-proceedings n x)
+  (:mode bib-siam?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-new-sentence `(,(if (bib-empty? x
+                                                                     "editor")
+                                                                 (bib-format-field x
+                                                                   "organization")
+                                                                 (bib-format-editor x))
+                                                              ,(bib-emphasize (bib-format-field x
+                                                                                "title"))
+                                                              ,(bib-format-bvolume x)
+                                                              ,(bib-format-number-series x)
+                                                              ,(bib-format-field x
+                                                                 "address")
+                                                              ,(bib-format-date x)
+                                                              ,(bib-format-field x
+                                                                 "organization")
+                                                              ,(bib-format-field x
+                                                                 "publisher"))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-techreport n x)
+  (:mode bib-siam?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-new-sentence `(,(bib-format-author x)
+                                                              ,(bib-emphasize (bib-format-field-Locase x
+                                                                                "title"))
+                                                              ,(bib-format-tr-number x)
+                                                              ,(bib-format-field x
+                                                                 "institution")
+                                                              ,(bib-format-field x
+                                                                 "address")
+                                                              ,(bib-format-date x))))
+                          ,(bib-new-block (bib-format-field x "note")))))
+) ;tm-define
+
+(tm-define (bib-format-unpublished n x)
+  (:mode bib-siam?)
+  `(concat ,(bib-format-bibitem n x)
+     ,(bib-label (list-ref x 2))
+     ,(bib-new-list-spc `(,(bib-new-block (bib-new-sentence `(,(bib-format-author x)
+                                                              ,(bib-emphasize (bib-format-field-Locase x
+                                                                                "title")))))
+                          ,(bib-new-block (bib-new-sentence `(,(bib-format-field x
+                                                                 "note")
+                                                              ,(bib-format-date x)))))))
+) ;tm-define
diff --git a/TeXmacs/plugins/latex/progs/latex/bibtex-unsrt.scm b/TeXmacs/plugins/latex/progs/latex/bibtex-unsrt.scm
new file mode 100644
index 0000000000..195d7d6109
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/bibtex-unsrt.scm
@@ -0,0 +1,23 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : abbrv.scm
+;; DESCRIPTION : abbrv style for BibTeX files
+;; COPYRIGHT   : (C) 2015  Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex bibtex-unsrt)
+  (:use (latex bibtex-bib-utils) (latex bibtex-plain))
+) ;texmacs-module
+
+(bib-define-style "unsrt" "plain")
+
+(tm-define (bib-sorted-entries l)
+  (:mode bib-unsrt?)
+  (with is-entry? (lambda (x) (func? x 'bib-entry)) (list-filter l is-entry?))
+) ;tm-define
diff --git a/TeXmacs/plugins/latex/progs/latex/convert-bibtex-bibtexout.scm b/TeXmacs/plugins/latex/progs/latex/convert-bibtex-bibtexout.scm
new file mode 100644
index 0000000000..1219c37772
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/convert-bibtex-bibtexout.scm
@@ -0,0 +1,316 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : bibtexout.scm
+;; DESCRIPTION : generation of BibTeX from scheme expressions
+;; COPYRIGHT   : (C) 2010  David MICHEL
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex convert-bibtex-bibtexout)
+  (:use (convert tools output))
+  (:use (latex convert-latex-texout))
+) ;texmacs-module
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Entries output
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (bibtex-remove-keepcase x)
+  ;; (display* "REMOVE KEEPCASE: " x "\n")
+  (cond ((list? x)
+         (if (not (null? x))
+           (if (equal? (car x) 'keepcase)
+             (if (null? (cdr x)) "{}" `(rigid ,(bibtex-remove-keepcase (cadr x))))
+             (cons (car x) (map bibtex-remove-keepcase (cdr x)))
+           ) ;if
+           ()
+         ) ;if
+        ) ;
+        ((string? x) x)
+  ) ;cond
+) ;define
+
+(define (bibtex-latex x)
+  (let ((options (list (cons "texmacs->latex:replace-style" "on")
+                   (cons "texmacs->latex:expand-macros" "on")
+                   (cons "texmacs->latex:expand-user-macros" "off")
+                   (cons "texmacs->latex:indirect-bib" "off")
+                   (cons "texmacs->latex:encoding" "UTF-8")
+                   (cons "texmacs->latex:use-macros" "off")
+                 ) ;list
+        ) ;options
+       ) ;
+    (with old-exact
+      (output-set-exact #t)
+      (output-flush)
+      (texout (texmacs->latex (bibtex-remove-keepcase x) options))
+      (output-set-exact old-exact)
+    ) ;with
+  ) ;let
+) ;define
+
+(define (bibtex-match l s a)
+  (and (list? l) (>= (length l) (+ a 1)) (equal? (car l) s))
+) ;define
+
+(define (bibtex-flat x)
+  (cond ((list? x)
+         (if (not (null? x)) (begin (bibtex-flat (car x)) (bibtex-flat (cdr x))))
+        ) ;
+        ((string? x) (output-verbatim x))
+  ) ;cond
+) ;define
+
+(define (bibtex-has-var x)
+  (if (list? x)
+    (cond ((null? x) #f)
+          ((bibtex-match (car x) 'bib-var 1) #t)
+          (else (bibtex-has-var (cdr x)))
+    ) ;cond
+    #f
+  ) ;if
+) ;define
+
+(define (bibtex-arg-var x)
+  ;; (display* "BIBTEX ARG VAR: " x "\n")
+  (if (not (null? x))
+    (let ((head (car x)) (tail (cdr x)))
+      (begin
+        (cond ((bibtex-match head 'bib-var 1) (output-verbatim (cadr head)))
+              ((string? head) (output-verbatim "{" head "}"))
+              (else (begin (output-verbatim "{") (bibtex-latex head) (output-verbatim "}")))
+        ) ;cond
+        (if (not (null? tail)) (begin (output-verbatim " # ") (bibtex-arg-var tail)))
+      ) ;begin
+    ) ;let
+  ) ;if
+) ;define
+
+(define (bibtex-name x)
+  ;; (display* "BIBTEX NAME: " x "\n")
+  (if (bibtex-match x 'bib-name 4)
+    (let ((first (list-ref x 1))
+          (von (list-ref x 2))
+          (last (list-ref x 3))
+          (jr (list-ref x 4))
+         ) ;
+      (begin
+        (if (not (equal? von "")) (begin (bibtex-latex von) (output-verbatim " ")))
+        (bibtex-latex last)
+        (if (not (equal? first "")) (begin (output-verbatim ", ") (bibtex-latex first)))
+        (if (not (equal? jr "")) (begin (output-verbatim ", ") (bibtex-latex jr)))
+      ) ;begin
+    ) ;let
+  ) ;if
+) ;define
+
+(define (bibtex-names x)
+  ;; (display* "BIBTEX NAMES: " x "\n")
+  (if (not (null? x))
+    (let ((head (car x)) (tail (cdr x)))
+      (if (bibtex-match head 'bib-name 4)
+        (begin
+          (bibtex-name head)
+          (if (> (length tail) 0) (output-verbatim " and "))
+          (bibtex-names tail)
+        ) ;begin
+        (bibtex-names tail)
+      ) ;if
+    ) ;let
+  ) ;if
+) ;define
+
+(define (bibtex-arg x)
+  ;; (display* "BIBTEX ARG: " x "\n")
+  (cond ((bibtex-match x 'bib-var 1) (output-verbatim (cadr x)))
+        ((bibtex-match x 'bib-names 0)
+         (begin
+           (output-verbatim "{")
+           (bibtex-names (cdr x))
+           (output-verbatim "}")
+         ) ;begin
+        ) ;
+        ((bibtex-match x 'bib-pages 2)
+         (output-verbatim "{" (cadr x) "--" (caddr x) "}")
+        ) ;
+        ((bibtex-match x 'bib-pages 1) (output-verbatim "{" (cadr x) "}"))
+        ((string? x) (output-verbatim "{" x "}"))
+        ((if (bibtex-has-var x)
+           (bibtex-arg-var (cdr x))
+           (begin
+             (output-verbatim "{")
+             (bibtex-latex x)
+             (output-verbatim "}")
+           ) ;begin
+         ) ;if
+        ) ;
+  ) ;cond
+) ;define
+
+(define (bibtex-preamble pre x)
+  ;; (display* "PREAMBLE: " x "\n")
+  (begin
+    (output-verbatim pre "preamble{ ")
+    (bibtex-arg x)
+    (output-verbatim " }")
+    (output-lf-verbatim)
+  ) ;begin
+) ;define
+
+(define (bibtex-preambles pre)
+  (lambda (x)
+    (if (list? x)
+      (cond ((func? x 'document) (for-each (bibtex-preambles pre) (cdr x)))
+            ((func? x 'bib-latex)
+             (begin
+               (bibtex-preamble pre (cadr x))
+               (output-lf-verbatim)
+             ) ;begin
+            ) ;
+            ((func? x 'bib-comment) (for-each (bibtex-preambles "") (cdr x)))
+      ) ;cond
+    ) ;if
+  ) ;lambda
+) ;define
+
+(define (bibtex-string pre x)
+  (if (list? x)
+    (begin
+      (output-verbatim pre "string{ " (car x) " = ")
+      (bibtex-arg (cadr x))
+      (output-verbatim " }")
+      (output-lf-verbatim)
+    ) ;begin
+  ) ;if
+) ;define
+
+(define (bibtex-strings pre)
+  (lambda (x)
+    (if (list? x)
+      (cond ((func? x 'document) (for-each (bibtex-strings pre) (cdr x)))
+            ((func? x 'bib-assign) (begin (bibtex-string pre (cdr x)) (output-lf-verbatim)))
+            ((func? x 'bib-comment) (for-each (bibtex-strings "") (cdr x)))
+      ) ;cond
+    ) ;if
+  ) ;lambda
+) ;define
+
+(define (bibtex-padded s)
+  (cond ((nstring? s) s)
+        ((>= (string-length s) 12) s)
+        (else (bibtex-padded (string-append s " ")))
+  ) ;cond
+) ;define
+
+(define (bibtex-field x)
+  (if (and (list? x) (= 2 (length x)))
+    (begin
+      (output-verbatim "  " (bibtex-padded (car x)) " = ")
+      (bibtex-arg (cadr x))
+    ) ;begin
+  ) ;if
+) ;define
+
+(define (bibtex-fields x)
+  (if (and (list? x) (not (null? x)))
+    (cond ((func? (car x) 'document) (bibtex-fields (cdar x)))
+          ((func? (car x) 'bib-field)
+           (begin
+             (bibtex-field (cdar x))
+             (if (not (null? (cdr x))) (output-verbatim ","))
+             (output-lf-verbatim)
+             (bibtex-fields (cdr x))
+           ) ;begin
+          ) ;
+    ) ;cond
+  ) ;if
+) ;define
+
+(define (bibtex-entry pre x)
+  (let ((type (cadr x)) (id (caddr x)) (fields (cdddr x)))
+    (begin
+      (output-verbatim pre (upcase-first type) "{" (cork->utf8 id))
+      (if (not (null? fields))
+        (begin
+          (output-verbatim ",")
+          (output-lf-verbatim)
+          (bibtex-fields fields)
+        ) ;begin
+      ) ;if
+      (output-verbatim "}")
+      (output-lf-verbatim)
+    ) ;begin
+  ) ;let
+) ;define
+
+(define (bibtex-comment x)
+  (cond ((list? x)
+         (if (not (null? x))
+           (begin
+             (cond ((func? (car x) 'document) (bibtex-comment (cdar x)))
+                   ((func? (car x) 'bib-entry) (bibtex-entry "" (car x)))
+                   ((func? (car x) 'bib-latex) (bibtex-preamble "" (cadar x)))
+                   ((func? (car x) 'bib-assign) (bibtex-string "" (cdar x)))
+                   (else (begin (output-verbatim "%") (bibtex-flat (car x)) (output-lf-verbatim)))
+             ) ;cond
+             (bibtex-comment (cdr x))
+           ) ;begin
+         ) ;if
+        ) ;
+        ((string? x) (begin (output-verbatim "%" x) (output-lf-verbatim)))
+  ) ;cond
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Main output routines
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (bibtexout x)
+  (cond ((string? x) (output-verbatim x))
+        ((func? x 'document) (for-each bibtexout (cdr x)))
+        ((func? x 'bib-string) (for-each (bibtex-strings "@") (cdr x)))
+        ((func? x 'bib-preamble) (for-each (bibtex-preambles "@") (cdr x)))
+        ((func? x 'bib-entry) (bibtex-entry "@" x) (output-lf-verbatim))
+        ((func? x 'bib-comment) (bibtex-comment (cdr x)) (output-lf-verbatim))
+        ((func? x 'bib-field)
+         (bibtex-field (cdr x))
+         (output-verbatim ",")
+         (output-lf-verbatim)
+        ) ;
+        ((func? x 'bib-assign) (bibtex-string "@" (cdr x)) (output-lf-verbatim))
+        ((func? x 'bib-line) (bibtex-comment (cdr x)))
+        ((func? x 'bib-var) (cdr x))
+        ((func? x 'bib-names) (bibtex-names (cdr x)) (output-lf-verbatim))
+        ((func? x 'bib-name) (bibtex-name x))
+        ((func? x 'bib-latex) (bibtex-preamble "@" (cadr x)) (output-lf-verbatim))
+  ) ;cond
+) ;define
+
+(tm-define (serialize-bibtex x)
+  (with old-line-length
+    (output-set-line-length 999999)
+    (bibtexout x)
+    (output-set-line-length old-line-length)
+    (output-produce)
+  ) ;with
+) ;tm-define
+
+(tm-define (serialize-bibtex-arg x)
+  (with old-line-length
+    (output-set-line-length 999999)
+    (bibtex-arg x)
+    (output-set-line-length old-line-length)
+    (with r
+      (output-produce)
+      (if (and (string-starts? r "{") (string-ends? r "}"))
+        (substring r 1 (- (string-length r) 1))
+        r
+      ) ;if
+    ) ;with
+  ) ;with
+) ;tm-define
diff --git a/TeXmacs/plugins/latex/progs/latex/convert-bibtex-bibtextm.scm b/TeXmacs/plugins/latex/progs/latex/convert-bibtex-bibtextm.scm
new file mode 100644
index 0000000000..2ed9162deb
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/convert-bibtex-bibtextm.scm
@@ -0,0 +1,36 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : bibtextm.scm
+;; DESCRIPTION : conversion of bibtex trees to TeXmacs trees
+;; COPYRIGHT   : (C) 2010  David MICHEL
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex convert-bibtex-bibtextm))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; User interface
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (parse-bibtex s)
+  (tree->stree (parse-bib s))
+) ;define
+
+(tm-define (parse-bibtex-snippet s) (parse-bibtex s))
+
+(tm-define (parse-bibtex-document s)
+  `(!file (document (style "bibliography") (body ,(parse-bibtex s))))
+) ;tm-define
+
+(tm-define (bibtex->texmacs bib)
+  (:type (-> stree stree))
+  (:synopsis "Convert a parsed BibTeX stree @t into a TeXmacs stree.")
+  (let* ((snippet? (not (func? bib '!file 1))) (body (if snippet? bib (cadr bib))))
+    body
+  ) ;let*
+) ;tm-define
diff --git a/TeXmacs/plugins/latex/progs/latex/convert-bibtex-tmbibtex.scm b/TeXmacs/plugins/latex/progs/latex/convert-bibtex-tmbibtex.scm
new file mode 100644
index 0000000000..76a00a3d14
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/convert-bibtex-tmbibtex.scm
@@ -0,0 +1,27 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : tmbibtex.scm
+;; DESCRIPTION : conversion of TeXmacs trees into BibTeX trees
+;; COPYRIGHT   : (C) 2010  David MICHEL
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex convert-bibtex-tmbibtex))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Interface
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (texmacs->bibtex x)
+  (if (tmfile? x)
+    (let ((body (tmfile-extract x 'body)))
+      (texmacs->bibtex body)
+    ) ;let
+    x
+  ) ;if
+) ;tm-define
diff --git a/TeXmacs/plugins/latex/progs/latex/convert-latex-command-drd.scm b/TeXmacs/plugins/latex/progs/latex/convert-latex-command-drd.scm
new file mode 100644
index 0000000000..94f4daaa59
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/convert-latex-command-drd.scm
@@ -0,0 +1,819 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : latex-command-drd.scm
+;; DESCRIPTION : Formal specification of standard LaTeX commands
+;; COPYRIGHT   : (C) 1999  Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex convert-latex-command-drd))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Any LaTeX tag
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-rules ((latex-tag% 'x) (latex-arity% 'x 'y))
+ ((latex-supports-option% 'x #t) (latex-optional-arg% 'x))
+) ;logic-rules
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; LaTeX commands
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-group latex-command-0%
+  ,(string->symbol " ")
+  ,(string->symbol ";")
+  ,(string->symbol ",")
+  ,(string->symbol ":")
+  -
+  /
+  [
+  ]
+  !
+  *
+  ,(string->symbol "|")
+  i
+  j
+  ss
+  SS
+  oe
+  OE
+  ae
+  AE
+  AA
+  DH
+  L
+  NG
+  O
+  S
+  TH
+  aa
+  dh
+  dj
+  l
+  ng
+  o
+  P
+  th
+  pounds
+  colon
+  and
+  lq
+  rq
+  quad
+  qquad
+  enspace
+  thinspace
+  par
+  smallskip
+  medskip
+  bigskip
+  noindent
+  newline
+  linebreak
+  nobreak
+  nolinebreak
+  strut
+  pagebreak
+  nopagebreak
+  newpage
+  newdoublepage
+  clearpage
+  cleardoublepage
+  newblock
+  bgroup
+  egroup
+  protect
+  cr
+  hfil
+  hfill
+  hfilll
+  appendix
+  limits
+  nolimits
+  dots
+  maketitle
+  tableofcontents
+  TeX
+  LaTeX
+  onecolumn
+  twocolumn
+  begingroup
+  endgroup
+  printindex
+  today
+  bmod
+  toprule
+  midrule
+  bottomrule
+
+  ;; AMS commands
+  dotsc
+  dotsb
+  dotsm
+  dotsi
+  dotso
+  qed
+  ;; mathtools
+  coloneqq
+  ;; temporarily
+  hline
+  hrulefill
+  ;; rewritten
+  notin
+  vert
+  Vert
+  addots
+  implies
+  iff
+  gets
+  ;; wikipedia
+  infin
+  rang
+  ;; bibtex
+  bysame
+  ;; for (e.g.) includegraphics
+  width
+  height
+  ;; miscellaneous
+  null
+  unskip
+
+  ;; Algorithms
+  AND
+  BlankLine
+  Ensure
+  ENSURE
+  FALSE
+  GLOBALS
+  NOT
+  OR
+  PRINT
+  Require
+  REQUIRE
+  Repeat
+  RETURN
+  State
+  STATE
+  TO
+  KwTo
+  TRUE
+  XOR
+  Else
+  ENDBODY
+  EndFor
+  ENDFOR
+  EndFunction
+  EndIf
+  ENDIF
+  ENDINPUTS
+  EndLoop
+  ENDLOOP
+  ENDOUTPUTS
+  EndProcedure
+  ENDWHILE
+  EndWhile
+  Loop
+) ;logic-group
+
+(logic-group latex-command-1%
+  part*
+  chapter*
+  section*
+  subsection*
+  subsubsection*
+  paragraph*
+  subparagraph*
+  nextbib
+  geometry
+  footnote
+  overline
+  underline
+  
+  
+  not
+  left
+  middle
+  right
+  big
+  Big
+  bigg
+  Bigg
+  bigl
+  Bigl
+  biggl
+  Biggl
+  bigm
+  Bigm
+  biggm
+  Biggm
+  bigr
+  Bigr
+  biggr
+  Biggr
+  bar
+  Bar
+  hat
+  Hat
+  tilde
+  Tilde
+  widehat
+  widetilde
+  vec
+  Vec
+  bm
+  ring
+  overrightarrow
+  overleftarrow
+  overleftrightarrow
+  underrightarrow
+  underleftarrow
+  underleftrightarrow
+  grave
+  Grave
+  acute
+  Acute
+  check
+  Check
+  breve
+  Breve
+  invbreve
+  abovering
+  mathring
+  dot
+  Dot
+  ddot
+  Ddot
+  dddot
+  ddddot
+  mod
+  pod
+  pmod
+  label
+  tag
+  ref
+  pageref
+  index
+  hspace
+  hspace*
+  vspace
+  vspace*
+  mspace
+  mbox
+  hbox
+  textnormal
+  text
+  not
+  substack
+  ,(string->symbol "'")
+  ,(string->symbol "`")
+  ,(string->symbol "\"")
+  ^
+  over
+  atop
+  choose
+  ~
+  =
+  u
+  v
+  H
+  t
+  c
+  d
+  b
+  k
+  r
+  textsuperscript
+  textsubscript
+  thispagestyle
+  ensuremath
+  mathord
+  mathbin
+  mathopen
+  mathpunct
+  mathop
+  mathrel
+  mathclose
+  mathalpha
+  mathinner
+  arabic
+  alph
+  Alph
+  roman
+  Roman
+  fnsymbol
+  displaylines
+  cases
+  underbrace
+  overbrace
+  phantom
+  hphantom
+  vphantom
+  smash
+  date
+  terms
+  newcounter
+  stepcounter
+  refstepcounter
+  value
+  citealt
+  citealt*
+  citealp*
+  citetext
+  citeauthor
+  citeauthor*
+  citeyear
+  onlinecite
+  citeN
+  epsfig
+  url
+  penalty
+  centerline
+  fbox
+  framebox
+  cline
+  cmidrule
+  enlargethispage
+  newlength
+  newdimen
+  newskip
+  Comment
+  COMMENT
+  For
+  ForAll
+  If
+  Input
+  KwData
+  KwResult
+  KwRet
+  lnl
+  nllabel
+  lElse
+  uElse
+  Output
+  Until
+  UNTIL
+  While
+  etalchar
+  MR
+  listpart
+  custombinding
+  cref
+  Cref
+) ;logic-group
+
+(logic-group latex-command-1%
+  ;; . needs a special treatment
+  ,(string->symbol ".")
+) ;logic-group
+
+(logic-group latex-command-2% binom tbinom dbinom cfrac tfrac equal href sideset
+  stackrel underaccent setcounter addtocounter setlength addtolength colorbox
+  scalebox texorpdfstring raisebox foreignlanguage Call Function Procedure SetKw
+  SetKwData SetKwFunction SetKwInOut ifthispageodd adjustbox
+) ;logic-group
+
+(logic-group latex-command-3% ifthenelse resizebox fcolorbox @setfontsize eIf
+  multicolumn
+) ;logic-group
+
+(logic-group latex-command-4% mathchoice)
+
+(logic-group latex-command-6% genfrac @startsection)
+
+(logic-rules ((latex-command% 'x) (latex-command-0% 'x))
+ ((latex-arity% 'x 0) (latex-command-0% 'x))
+ ((latex-command% 'x) (latex-command-1% 'x))
+ ((latex-arity% 'x 1) (latex-command-1% 'x))
+ ((latex-command% 'x) (latex-command-2% 'x))
+ ((latex-arity% 'x 2) (latex-command-2% 'x))
+ ((latex-command% 'x) (latex-command-3% 'x))
+ ((latex-arity% 'x 3) (latex-command-3% 'x))
+ ((latex-command% 'x) (latex-command-4% 'x))
+ ((latex-arity% 'x 4) (latex-command-4% 'x))
+ ((latex-command% 'x) (latex-command-6% 'x))
+ ((latex-arity% 'x 6) (latex-command-6% 'x))
+) ;logic-rules
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; LaTeX commands with optional arguments
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-group latex-command-0*%
+  item
+  ,(string->symbol "\\")
+  BODY
+  ELSE
+  INPUTS
+  LOOP
+  OUTPUTS
+  REPEAT
+  hdashline
+) ;logic-group
+
+(logic-group latex-command-1*% usepackage documentclass documentstyle sqrt
+  bibitem cite caption title author thanks marginpar part chapter section
+  subsection subsubsection paragraph subparagraph includegraphics
+  includegraphics* makebox subjclass declaretheorem footnotetext xleftarrow
+  xrightarrow xleftrightarrow xminus xLeftarrow xRightarrow xLeftrightarrow
+  xequal xmapsto xmapsfrom citealp citet citep citet* citep* Begin ELSIF FORALL
+  FOR IF WHILE tcp tcp* tcc tcc* hyperref
+) ;logic-group
+
+(logic-group latex-command-2*% def newcommand renewcommand providecommand
+  newtheorem newtheorem* frac parbox ElseIf uElseIf lElseIf ForEach lForEach
+  lForAll lFor
+) ;logic-group
+
+(logic-group latex-command-3*% category newenvironment renewenvironment multirow
+) ;logic-group
+
+(logic-rules ((latex-command-0% 'x) (latex-command-0*% 'x))
+ ((latex-optional-arg% 'x) (latex-command-0*% 'x))
+ ((latex-command-1% 'x) (latex-command-1*% 'x))
+ ((latex-optional-arg% 'x) (latex-command-1*% 'x))
+ ((latex-command-2% 'x) (latex-command-2*% 'x))
+ ((latex-optional-arg% 'x) (latex-command-2*% 'x))
+ ((latex-command-3% 'x) (latex-command-3*% 'x))
+ ((latex-optional-arg% 'x) (latex-command-3*% 'x))
+) ;logic-rules
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Environments
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-group latex-environment-0% begin-mdframed begin-document begin-abstract
+  begin-verbatim begin-proof begin-matrix begin-pmatrix begin-bmatrix
+  begin-vmatrix begin-smallmatrix begin-cases begin-center begin-flushleft
+  begin-flushright begin-picture
+) ;logic-group
+
+(logic-group latex-environment-0*% begin-figure begin-table begin-figure*
+  begin-table* begin-algorithmic begin-algorithm begin-algorithm2e
+  begin-teaserfigure
+) ;logic-group
+
+(logic-group latex-environment-1% begin-otherlanguage begin-otherlanguage*
+  begin-tabbing begin-thebibliography begin-multicols
+) ;logic-group
+
+(logic-group latex-environment-1*% begin-array begin-tabular begin-minipage)
+
+(logic-group latex-environment-2*% begin-tabular* begin-tabularx)
+
+(logic-rules ((latex-environment% 'x) (latex-environment-0% 'x))
+ ((latex-arity% 'x 0) (latex-environment-0% 'x))
+ ((latex-environment% 'x) (latex-environment-1% 'x))
+ ((latex-arity% 'x 1) (latex-environment-1% 'x))
+ ((latex-environment% 'x) (latex-environment-2% 'x))
+ ((latex-arity% 'x 2) (latex-environment-2% 'x))
+ ((latex-environment% 'x) (latex-environment-3% 'x))
+ ((latex-arity% 'x 3) (latex-environment-3% 'x))
+ ((latex-environment-0% 'x) (latex-environment-0*% 'x))
+ ((latex-optional-arg% 'x) (latex-environment-0*% 'x))
+ ((latex-environment-1% 'x) (latex-environment-1*% 'x))
+ ((latex-optional-arg% 'x) (latex-environment-1*% 'x))
+ ((latex-environment-2% 'x) (latex-environment-2*% 'x))
+ ((latex-optional-arg% 'x) (latex-environment-2*% 'x))
+) ;logic-rules
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Enunciations
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-group latex-enunciation%
+  begin-theorem
+  begin-proposition
+  begin-lemma
+  begin-corollary
+  begin-proof
+  begin-axiom
+  begin-definition
+  begin-notation
+  begin-conjecture
+  begin-remark
+  begin-note
+  begin-example
+  begin-warning
+  begin-convention
+  begin-acknowledgments
+  begin-exercise
+  begin-problem
+  begin-solution
+  begin-question
+  begin-answer
+  begin-quote-env
+  begin-quotation
+  begin-verse
+
+  begin-theorem*
+  begin-proposition*
+  begin-lemma*
+  begin-corollary*
+  begin-axiom*
+  begin-definition*
+  begin-notation*
+  begin-conjecture*
+  begin-remark*
+  begin-note*
+  begin-example*
+  begin-warning*
+  begin-convention*
+  begin-acknowledgments*
+  begin-exercise*
+  begin-problem*
+  begin-solution*
+  begin-question*
+  begin-answer*
+
+  ;; guessed
+  begin-th
+  begin-thm
+  begin-prop
+  begin-lem
+  begin-cor
+  begin-corr
+  begin-pf
+  begin-dem
+  begin-preuve
+  begin-IEEEproof
+  begin-ax
+  begin-def
+  begin-dfn
+  begin-defn
+  begin-not
+  begin-ex
+  begin-exa
+  begin-rem
+  begin-war
+  begin-conv
+  begin-exe
+  begin-exc
+  begin-exo
+  begin-prop
+  begin-sol
+  begin-ans
+  begin-acks
+) ;logic-group
+
+(logic-rules ((latex-environment-0*% 'x) (latex-enunciation% 'x)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Modifiers
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-group latex-modifier-0% normalfont rm tt sf md bf it em sl sc rmfamily
+  ttfamily sffamily mdseries bfseries upshape itshape slshape scshape
+  displaystyle textstyle scriptstyle scriptscriptstyle cal frak Bbb boldmath
+  tiny scriptsize footnotesize small normalsize large Large LARGE huge Huge
+  black white grey red blue yellow green orange magenta brown pink centering
+  raggedleft raggedright flushleft flushright
+) ;logic-group
+
+(logic-group latex-modifier-1% textnormalfont textrm texttt textsf textmd textbf
+  textup textit textsl textsc emph mathrm mathtt mathsf mathmd mathbf mathup
+  mathit mathsl mathnormal mathcal mathfrak mathbb mathbbm mathscr operatorname
+  boldsymbol lowercase MakeLowercase uppercase MakeUppercase selectlanguage
+) ;logic-group
+
+(logic-group latex-modifier-1*% color)
+
+(logic-group latex-modifier-2*% textcolor)
+
+(logic-rules ((latex-modifier% 'x) (latex-modifier-0% 'x))
+ ((latex-arity% 'x 0) (latex-modifier-0% 'x))
+ ((latex-modifier% 'x) (latex-modifier-1% 'x))
+ ((latex-arity% 'x 1) (latex-modifier-1% 'x))
+ ((latex-optional-arg% 'x) (latex-modifier-1*% 'x))
+ ((latex-modifier% 'x) (latex-modifier-1*% 'x))
+ ((latex-arity% 'x 1) (latex-modifier-1*% 'x))
+ ((latex-optional-arg% 'x) (latex-modifier-2*% 'x))
+ ((latex-modifier% 'x) (latex-modifier-2*% 'x))
+ ((latex-arity% 'x 2) (latex-modifier-2*% 'x))
+) ;logic-rules
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Special types of LaTeX primitives
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-group latex-control% $ & % ,(string->symbol "#") _ { }  )
+
+(logic-group latex-operator% arccos arcsin arctan arg cos cosh cot coth csc deg
+  det dim exp gcd hom inf ker lg lim liminf limsup varliminf varlimsup ln log
+  max min Pr sec sin sinh sup tan tanh
+) ;logic-group
+
+(logic-group latex-list% begin-itemize begin-enumerate begin-description
+  begin-asparaitem begin-inparaitem begin-compactitem begin-asparaenum
+  begin-inparaenum begin-compactenum
+) ;logic-group
+
+(logic-group latex-math-environment-0% begin-formula begin-equation* begin-math
+  begin-displaymath begin-equation begin-eqnarray begin-eqnarray* begin-flalign
+  begin-flalign* begin-align begin-align* begin-multline begin-multline*
+  begin-gather begin-gather* begin-eqsplit begin-eqsplit*
+) ;logic-group
+
+(logic-group latex-math-environment-1% begin-alignat begin-alignat*)
+
+(logic-rules ((latex-arity% 'x 0) (latex-control% 'x))
+ ((latex-arity% 'x 0) (latex-operator% 'x))
+ ((latex-environment-0*% 'x) (latex-list% 'x))
+ ((latex-math-environment% 'x) (latex-math-environment-0% 'x))
+ ((latex-math-environment% 'x) (latex-math-environment-1% 'x))
+ ((latex-environment-1% 'x) (latex-math-environment-1% 'x))
+ ((latex-environment-0% 'x) (latex-math-environment-0% 'x))
+) ;logic-rules
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Counters
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-group latex-counter% badness enumi enumii enumiii enumiv equation figure
+  inputlineno mpfootnote page setlanguage table
+) ;logic-group
+
+(logic-rules ((latex-arity% 'x 0) (latex-counter% 'x)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Names
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-group latex-name% abstractname appendixname contentname figurename
+  indexname litfigurename littablename partname refname tablename
+) ;logic-group
+
+(logic-rules ((latex-arity% 'x 0) (latex-name% 'x)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Lengths
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-group latex-length%
+  ;; From latex.ltx
+  ;; -- lengths
+  @textfloatsheight
+  arraycolsep
+  arrayrulewidth
+  columnsep
+  columnseprule
+  columnwidth
+  doublerulesep
+  emergencystretch
+  evensidemargin
+  fboxrule
+  fboxsep
+  footnotesep
+  footskip
+  headheight
+  headsep
+  itemindent
+  labelsep
+  labelwidth
+  leftmargin
+  leftmargini
+  leftmarginii
+  leftmarginiii
+  leftmarginiv
+  leftmarginv
+  leftmarginvi
+  linewidth
+  listparindent
+  marginparpush
+  marginparsep
+  marginparwidth
+  oddsidemargin
+  p@
+  paperheight
+  paperwidth
+  rightmargin
+  tabbingsep
+  tabcolsep
+  textheight
+  textwidth
+  topmargin
+  unitlength
+  z@
+  @bls
+  @vpt
+  @vipt
+  @viipt
+  @viiipt
+  @ixpt
+  @xpt
+  @xipt
+  @xiipt
+  @xivpt
+  @xviipt
+  @xxpt
+  @xxvpt
+  ;; -- skips
+  topsep
+  partopsep
+  itemsep
+  parsep
+  floatsep
+  textfloatsep
+  intextsep
+  dblfloatsep
+  dbltextfloatsep
+  ;; From latex classes
+  abovecaptionskip
+  belowcaptionskip
+  bibindent
+  ;; From fleqn
+  mathindent
+  ;; Plain TeX
+  maxdimen
+  hfuzz
+  vfuzz
+  overfullrule
+  hsize
+  vsize
+  maxdepth
+  lineskiplimit
+  delimitershortfall
+  nulldelimiterspace
+  scriptspace
+  mathsurround
+  predisplaysize
+  displaywidth
+  displayindent
+  parindent
+  hangindent
+  hoffset
+  voffset
+  baselineskip
+  lineskip
+  parskip
+  abovedisplayskip
+  abovedisplayshortskip
+  belowdisplayskip
+  belowdisplayshortskip
+  leftskip
+  rightskip
+  topskip
+  splittopskip
+  tabskip
+  spaceskip
+  xspaceskip
+  parfillskip
+  thinmuskip
+  medmuskip
+  thickmuskip
+  hideskip
+  smallskipamount
+  medskipamount
+  bigskipamount
+  normalbaselineskip
+  normallineskip
+  normallineskiplimit
+  jot
+) ;logic-group
+
+(logic-rules ((latex-arity% 'x 0) (latex-length% 'x)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; To be imported as pictures
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-group latex-as-pic-0% begin-pspicture begin-pspicture* begin-tikzpicture)
+
+(logic-group latex-as-pic-1% xymatrix)
+
+(logic-rules ((latex-as-pic% 'x) (latex-as-pic-0% 'x))
+ ((latex-as-pic% 'x) (latex-as-pic-1% 'x))
+ ((latex-arity% 'x 0) (latex-as-pic-0% 'x))
+ ((latex-arity% 'x 1) (latex-as-pic-1% 'x))
+) ;logic-rules
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; To be ignored
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-group latex-ignore-0% allowbreak notag xspace break sloppy makeatother
+  makeatletter relax qedhere ignorespacesafterend ignorespaces balancecolumns
+  tightlist
+) ;logic-group
+
+(logic-group latex-ignore-0*% displaybreak allowdisplaybreaks)
+
+(logic-group latex-ignore-1% hyphenation)
+
+(logic-group latex-ignore-2% newdir)
+
+(logic-rules ((latex-ignore% 'x) (latex-ignore-0% 'x))
+ ((latex-ignore% 'x) (latex-ignore-0*% 'x))
+ ((latex-ignore% 'x) (latex-ignore-1% 'x))
+ ((latex-ignore% 'x) (latex-ignore-2% 'x))
+ ((latex-arity% 'x 0) (latex-ignore-0% 'x))
+ ((latex-arity% 'x 0) (latex-ignore-0*% 'x))
+ ((latex-arity% 'x 1) (latex-ignore-1% 'x))
+ ((latex-arity% 'x 2) (latex-ignore-2% 'x))
+ ((latex-optional-arg% 'x) (latex-ignore-1*% 'x))
+) ;logic-rules
diff --git a/TeXmacs/plugins/latex/progs/latex/convert-latex-define.scm b/TeXmacs/plugins/latex/progs/latex/convert-latex-define.scm
new file mode 100644
index 0000000000..ee1f859331
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/convert-latex-define.scm
@@ -0,0 +1,1060 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : latex-define.scm
+;; DESCRIPTION : LaTeX definitions for TeXmacs extensions
+;; COPYRIGHT   : (C) 2005  Joris van der Hoeven
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex convert-latex-define)
+  (:use (latex convert-latex-texmacs-drd))
+) ;texmacs-module
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Extra TeXmacs symbols
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(smart-table latex-texmacs-macro
+  ;; arrows and other symbols with limits
+  (leftarrowlim "\\mathop{\\leftarrow}\\limits")
+  (rightarrowlim "\\mathop{\\rightarrow}\\limits")
+  (leftrightarrowlim "\\mathop{\\leftrightarrow}\\limits")
+  (mapstolim "\\mathop{\\mapsto}\\limits")
+  (longleftarrowlim "\\mathop{\\longleftarrow}\\limits")
+  (longrightarrowlim "\\mathop{\\longrightarrow}\\limits")
+  (longleftrightarrowlim "\\mathop{\\longleftrightarrow}\\limits")
+  (longmapstolim "\\mathop{\\longmapsto}\\limits")
+  (leftsquigarrowlim "\\mathop{\\leftsquigarrow}\\limits")
+  (rightsquigarrowlim "\\mathop{\\rightsquigarrow}\\limits")
+  (leftrightsquigarrowlim "\\mathop{\\leftrightsquigarrow}\\limits")
+  (equallim "\\mathop{=}\\limits")
+  (longequallim "\\mathop{\\longequal}\\limits")
+  (Leftarrowlim "\\mathop{\\leftarrow}\\limits")
+  (Rightarrowlim "\\mathop{\\rightarrow}\\limits")
+  (Leftrightarrowlim "\\mathop{\\leftrightarrow}\\limits")
+  (Longleftarrowlim "\\mathop{\\longleftarrow}\\limits")
+  (Longrightarrowlim "\\mathop{\\longrightarrow}\\limits")
+  (Longleftrightarrowlim "\\mathop{\\longleftrightarrow}\\limits")
+  (cdotslim "\\mathop{\\cdots}\\limits")
+
+  ;; rotated arrows and other symbols
+  (mapsfrom (!group (mbox (rotatebox (!option "origin=c") "180" (!math (mapsto)))))
+  ) ;mapsfrom
+  (longmapsfrom (!group (mbox (rotatebox (!option "origin=c") "180" (!math (longmapsto)))))
+  ) ;longmapsfrom
+  (mapmulti (!group (mbox (rotatebox (!option "origin=c") "180" (!math "\\multimap"))))
+  ) ;mapmulti
+  (leftsquigarrow (!group (mbox (rotatebox (!option "origin=c") "180" (!math (rightsquigarrow)))))
+  ) ;leftsquigarrow
+  (upequal (!group (mbox (rotatebox (!option "origin=c") "90" (!math "=")))))
+  (downequal (!group (mbox (rotatebox (!option "origin=c") "-90" (!math "=")))))
+  (longupequal (!group (mbox (rotatebox (!option "origin=c") "90" (!math (longequal)))))
+  ) ;longupequal
+  (longdownequal (!group (mbox (rotatebox (!option "origin=c") "-90" (!math (longequal)))))
+  ) ;longdownequal
+  (longupminus (!group (mbox (rotatebox (!option "origin=c") "90" (!math (longminus)))))
+  ) ;longupminus
+  (longdownminus (!group (mbox (rotatebox (!option "origin=c") "-90" (!math (longminus)))))
+  ) ;longdownminus
+  (longuparrow (!group (mbox (rotatebox (!option "origin=c") "90" (!math (longrightarrow)))))
+  ) ;longuparrow
+  (longdownarrow (!group (mbox (rotatebox (!option "origin=c") "-90" (!math (longrightarrow)))))
+  ) ;longdownarrow
+  (longupdownarrow (!group (mbox (rotatebox (!option "origin=c") "-90" (!math (longleftrightarrow))))
+                   ) ;!group
+  ) ;longupdownarrow
+  (Longuparrow (!group (mbox (rotatebox (!option "origin=c") "90" (!math (Longrightarrow)))))
+  ) ;Longuparrow
+  (Longdownarrow (!group (mbox (rotatebox (!option "origin=c") "-90" (!math (Longrightarrow)))))
+  ) ;Longdownarrow
+  (Longupdownarrow (!group (mbox (rotatebox (!option "origin=c") "-90" (!math (Longleftrightarrow))))
+                   ) ;!group
+  ) ;Longupdownarrow
+  (mapsup (!group (mbox (rotatebox (!option "origin=c") "90" (!math (mapsto))))))
+  (mapsdown (!group (mbox (rotatebox (!option "origin=c") "-90" (!math (mapsto)))))
+  ) ;mapsdown
+  (longmapsup (!group (mbox (rotatebox (!option "origin=c") "90" (!math (longmapsto)))))
+  ) ;longmapsup
+  (longmapsdown (!group (mbox (rotatebox (!option "origin=c") "-90" (!math (longmapsto)))))
+  ) ;longmapsdown
+  (upsquigarrow (!group (mbox (rotatebox (!option "origin=c") "90" (!math (rightsquigarrow)))))
+  ) ;upsquigarrow
+  (downsquigarrow (!group (mbox (rotatebox (!option "origin=c") "-90" (!math (rightsquigarrow)))))
+  ) ;downsquigarrow
+  (updownsquigarrow (!group (mbox (rotatebox (!option "origin=c") "-90" (!math (leftrightsquigarrow))))
+                    ) ;!group
+  ) ;updownsquigarrow
+  (hookuparrow (!group (mbox (rotatebox (!option "origin=c") "90" (!math (hookrightarrow)))))
+  ) ;hookuparrow
+  (hookdownarrow (!group (mbox (rotatebox (!option "origin=c") "-90" (!math (hookrightarrow)))))
+  ) ;hookdownarrow
+  (longhookuparrow (!group (mbox (rotatebox (!option "origin=c") "90" (!math (longhookrightarrow))))
+                   ) ;!group
+  ) ;longhookuparrow
+  (longhookdownarrow (!group (mbox (rotatebox (!option "origin=c") "-90" (!math (longhookrightarrow))))
+                     ) ;!group
+  ) ;longhookdownarrow
+  (Backepsilon (!group (mbox (rotatebox (!option "origin=c") "180" "E"))))
+  (Backsigma (!group (mbox (reflectbox (!math "\\Sigma")))))
+  (Mho (!group (mbox (rotatebox (!option "origin=c") "180" (!math "\\Omega")))))
+  (btimes (!group (mbox (rotatebox (!option "origin=c") "90" (!math "\\ltimes"))))
+  ) ;btimes
+
+  ;; asymptotic relations by Joris
+  (nasymp "\\not\\asymp")
+  (asympasymp "{\\asymp\\!\\!\\!\\!\\!\\!-}")
+  (nasympasymp "{\\not\\asymp\\!\\!\\!\\!\\!\\!-}")
+  (simsim "{\\approx\\!\\!\\!\\!\\!\\!-}")
+  (nsimsim "{\\not\\approx\\!\\!\\!\\!\\!\\!-}")
+  (triplesim "{\\approx\\!\\!\\!\\!\\!\\!\\sim}")
+  (ntriplesim "{\\not\\approx\\!\\!\\!\\!\\!\\!\\sim}")
+  (precprec "\\prec\\!\\!\\!\\prec")
+  (precpreceq "\\preceq\\!\\!\\!\\preceq")
+  (precprecprec "\\prec\\!\\!\\!\\prec\\!\\!\\!\\prec")
+  (precprecpreceq "\\preceq\\!\\!\\!\\preceq\\!\\!\\!\\preceq")
+  (succsucc "\\succ\\!\\!\\!\\succ")
+  (succsucceq "\\succeq\\!\\!\\!\\succeq")
+  (succsuccsucc "\\succ\\!\\!\\!\\succ\\!\\!\\!\\succ")
+  (succsuccsucceq "\\succeq\\!\\!\\!\\succeq\\!\\!\\!\\succeq")
+  (lleq "\\leq\\!\\!\\!\\leq")
+  (llleq "\\leq\\!\\!\\!\\leq\\!\\!\\!\\leq")
+  (ggeq "\\geq\\!\\!\\!\\geq")
+  (gggeq "\\geq\\!\\!\\!\\geq\\!\\!\\!\\geq")
+
+  ;; extra literal symbols
+  (mathcatalan "\\mathrm{C}")
+  (mathd "\\mathrm{d}")
+  (mathD "\\mathrm{D}")
+  (mathe "\\mathrm{e}")
+  (matheuler "\\gamma")
+  (mathGamma "\\Gamma")
+  (mathlambda "\\lambda")
+  (mathLaplace "\\Delta")
+  (mathi "\\mathrm{i}")
+  (mathpi "\\pi")
+  (Alpha "\\mathrm{A}")
+  (Beta "\\mathrm{B}")
+  (Epsilon "\\mathrm{E}")
+  (Eta "\\mathrm{H}")
+  (Iota "\\mathrm{I}")
+  (Kappa "\\mathrm{K}")
+  (Mu "\\mathrm{M}")
+  (Nu "\\mathrm{N}")
+  (Omicron "\\mathrm{O}")
+  (Chi "\\mathrm{X}")
+  (Rho "\\mathrm{P}")
+  (Tau "\\mathrm{T}")
+  (Zeta "\\mathrm{Z}")
+
+  ;; symbols from mathabx
+  ;; NOTE: we avoid using the mathabx package because it tends
+  ;; to be badly installed and incompatible with certain styles
+  (divides "\\mathrel{|}")
+  (ndivides "\\mathrel{\\nmid}")
+  (asterisk "\\mathord{*}")
+  (dottimes "\\mathbin{\\dot{\\times}}")
+  (precdot "\\mathrel{\\prec\\!\\!\\cdot")
+
+  ;; negations
+  (nin "\\not\\in")
+  (nni "\\not\\ni")
+  (notni "\\not\\ni")
+  (nequiv (!annotate "\\mathrel{\\not\\equiv}" (equiv)))
+  (nleadsto (!annotate "\\not\\leadsto" (leadsto)))
+  (napproxeq (!annotate "\\mathrel{\\not\\approxeq}" (approxeq)))
+  (nprecapprox (!annotate "\\mathrel{\\not\\precapprox}" (precapprox)))
+  (npreccurlyeq (!annotate "\\mathrel{\\not\\preccurlyeq}" (preccurlyeq)))
+  (npreceqq (!annotate "\\mathrel{\\not\\preceqq}" (preceqq)))
+  (nprecsim (!annotate "\\mathrel{\\not\\precsim}" (precsim)))
+  (nsimeq (!annotate "\\mathrel{\\not\\simeq}" (simeq)))
+  (nsubset (!annotate "\\mathrel{\\not\\subset}" (subset)))
+  (napprox (!annotate "\\mathrel{\\not\\approx}" (approx)))
+  (nsqsubset (!annotate "\\mathrel{\\not\\sqsubset}" (sqsubset)))
+  (nsqsubseteq (!annotate "\\mathrel{\\not\\sqsubseteq}" (sqsubseteq)))
+  (nsqsubseteqq (!annotate "\\mathrel{\\not\\sqsubseteqq}" (sqsubseteqq)))
+  (nsqsupset (!annotate "\\mathrel{\\not\\sqsupset}" (sqsupset)))
+  (nsqsupseteq (!annotate "\\mathrel{\\not\\sqsupseteq}" (sqsupseteq)))
+  (nsqsupseteqq (!annotate "\\mathrel{\\not\\sqsupseteqq}" (sqsupseteqq)))
+  (nsuccapprox (!annotate "\\mathrel{\\not\\succapprox}" (succapprox)))
+  (nsucccurlyeq (!annotate "\\mathrel{\\not\\succcurlyeq}" (succcurlyeq)))
+  (nsucceqq (!annotate "\\mathrel{\\not\\succeqq}" (succeqq)))
+  (nsuccsim (!annotate "\\mathrel{\\not\\succsim}" (succsim)))
+
+  ;; other extra symbols
+  (oempty "\\circ")
+  (exterior "\\wedge")
+  (Exists "\\exists")
+  (bigintwl "\\int")
+  (bigointwl "\\oint")
+  (bigintlim "\\int")
+  (bigointlim "\\oint")
+  (of ":")
+  (suchthat ":")
+  (barsuchthat "|")
+  (point ".")
+  (cdummy "\\cdot")
+  (comma "{,}")
+  (copyright "\\copyright")
+  (bignone "")
+  (nobracket "")
+  (nospace "")
+  (nocomma "")
+  (noplus "")
+  (nosymbol "")
+  (dotminus "\\mathaccent95{-}")
+  (dotpm "\\mathaccent95{\\pm}")
+  (dotmp "\\mathaccent95{\\mp}")
+  (dotamalg "\\mathaccent95{\\amalg}")
+  (dotoplus "\\mathaccent95{\\oplus}")
+  (dototimes "\\mathaccent95{\\otimes}")
+  (dotast "\\mathaccent95{*}")
+  (to "\\to")
+  (into "\\rightarrow")
+  (longminus "{-\\!\\!-}")
+  (longequal "{=\\!\\!=}")
+  (longhookrightarrow "{\\lhook\\joinrel\\relbar\\joinrel\\rightarrow}")
+  (longhookleftarrow "{\\leftarrow\\joinrel\\relbar\\joinrel\\rhook}")
+  (triangleup "\\triangle")
+  (tmprecdot "{\\prec\\hspace{-0.6em}\\cdot}\\;\\,")
+  (preceqdot "{\\preccurlyeq\\hspace{-0.6em}\\cdot}\\;\\,")
+  (llangle "{\\langle\\!\\langle}")
+  (rrangle "{\\rangle\\!\\rangle}")
+  (join "\\Join")
+  (um "-")
+  (upl "+")
+  (upm "\\pm")
+  (ump "\\mp")
+  (assign ":=")
+  (plusassign "+\\!\\!=")
+  (minusassign "-\\!\\!=")
+  (timesassign "\times\\!\\!=")
+  (overassign "/\\!\\!=")
+  (backassign "=:")
+  (pplus (mathbin "+\\!\\!\\!\\!+"))
+  (lflux "\\ll")
+  (gflux "\\gg")
+  (colons "\\,:\\,")
+  (transtype "\\,:\\!!>")
+  (tmxspace (hspace "1em"))
+  (lebar (mathrel (Yleft)))
+  (gebar (mathrel (Yright)))
+  (leangle (mathrel (angle)))
+  (geangle (mathrel (!group (mbox (reflectbox (!math (angle)))))))
+  (anglege (mathrel (!group (mbox (rotatebox (!option "origin=c") "180" (!math (angle))))))
+  ) ;anglege
+  (anglele (mathrel (!group (mbox (rotatebox (!option "origin=c") "180" (!math (!recurse (geangle)))))
+                    ) ;!group
+           ) ;mathrel
+  ) ;anglele
+  ;; (leqangle (mathrel (substack (!append (angle) "\\\\" (smash "-")))))
+  (leqangle (mathrel (!append (angle) " \\llap " (!group (raisebox "-1ex" (!math "-")))))
+  ) ;leqangle
+  (geqangle (mathrel (!group (mbox (reflectbox (!math (!recurse (leqangle))))))))
+  (legeangle (mathrel (substack (!append (leangle) "\\\\" (!recurse (anglege))))))
+  (geleangle (mathrel (substack (!append (geangle) "\\\\" (!recurse (anglele))))))
+  (udots "{\\mathinner{\\mskip1mu\\raise1pt\\vbox{\\kern7pt\\hbox{.}}\\mskip2mu\\raise4pt\\hbox{.}\\mskip2mu\\raise7pt\\hbox{.}\\mskip1mu}}"
+  ) ;udots
+  (subsetsim (underset (sim) (subset)))
+  (supsetsim (underset (sim) (supset)))
+  (rightmap (!group (!append (shortmid) "\\!\\!\\!-")))
+  (leftmap (!group (!append "-\\!\\!\\!" (shortmid))))
+  (leftrightmap (!group (!append (shortmid) "\\!\\!\\!-\\!\\!\\!" (shortmid))))
+  (LRleftrightarrow (!group (!append (Lleftarrow) "\\!\\!\\!" (Rrightarrow))))
+  (Llongleftarrow (!group (!append (Lleftarrow) "\\!" (equiv))))
+  (Llongrightarrow (!group (!append (equiv) "\\!" (Rrightarrow))))
+  (Llongleftrightarrow (!group (!append (Lleftarrow) "\\!" (equiv) "\\!" (Rrightarrow)))
+  ) ;Llongleftrightarrow
+  (threeleftarrows (mathrel (substack (!append (leftarrow) "\\\\[-0.6ex]" (leftarrow) "\\\\[-0.6ex]" (leftarrow))
+                            ) ;substack
+                   ) ;mathrel
+  ) ;threeleftarrows
+  (fourleftarrows (mathrel (substack (!append (leftarrow)
+                                       "\\\\[-0.6ex]"
+                                       (leftarrow)
+                                       "\\\\[-0.6ex]"
+                                       (leftarrow)
+                                       "\\\\[-0.6ex]"
+                                       (leftarrow)
+                                     ) ;!append
+                           ) ;substack
+                  ) ;mathrel
+  ) ;fourleftarrows
+  (threerightarrows (mathrel (substack (!append (rightarrow) "\\\\[-0.6ex]" (rightarrow) "\\\\[-0.6ex]" (rightarrow))
+                             ) ;substack
+                    ) ;mathrel
+  ) ;threerightarrows
+  (fourrightarrows (mathrel (substack (!append (rightarrow)
+                                        "\\\\[-0.6ex]"
+                                        (rightarrow)
+                                        "\\\\[-0.6ex]"
+                                        (rightarrow)
+                                        "\\\\[-0.6ex]"
+                                        (rightarrow)
+                                      ) ;!append
+                            ) ;substack
+                   ) ;mathrel
+  ) ;fourrightarrows
+  (longleftrightarrows (mathrel (substack (!append (longleftarrow) "\\\\[-0.6ex]" (longrightarrow))))
+  ) ;longleftrightarrows
+  (longleftleftarrows (mathrel (substack (!append (longleftarrow) "\\\\[-0.6ex]" (longleftarrow))))
+  ) ;longleftleftarrows
+  (longthreeleftarrows (mathrel (substack (!append (longleftarrow)
+                                            "\\\\[-0.6ex]"
+                                            (longleftarrow)
+                                            "\\\\[-0.6ex]"
+                                            (longleftarrow)
+                                          ) ;!append
+                                ) ;substack
+                       ) ;mathrel
+  ) ;longthreeleftarrows
+  (longfourleftarrows (mathrel (substack (!append (longleftarrow)
+                                           "\\\\[-0.6ex]"
+                                           (longleftarrow)
+                                           "\\\\[-0.6ex]"
+                                           (longleftarrow)
+                                           "\\\\[-0.6ex]"
+                                           (longleftarrow)
+                                         ) ;!append
+                               ) ;substack
+                      ) ;mathrel
+  ) ;longfourleftarrows
+  (longrightleftarrows (mathrel (substack (!append (longrightarrow) "\\\\[-0.6ex]" (longleftarrow))))
+  ) ;longrightleftarrows
+  (longrightrightarrows (mathrel (substack (!append (longrightarrow) "\\\\[-0.6ex]" (longrightarrow))))
+  ) ;longrightrightarrows
+  (longthreerightarrows (mathrel (substack (!append (longrightarrow)
+                                             "\\\\[-0.6ex]"
+                                             (longrightarrow)
+                                             "\\\\[-0.6ex]"
+                                             (longrightarrow)
+                                           ) ;!append
+                                 ) ;substack
+                        ) ;mathrel
+  ) ;longthreerightarrows
+  (longfourrightarrows (mathrel (substack (!append (longrightarrow)
+                                            "\\\\[-0.6ex]"
+                                            (longrightarrow)
+                                            "\\\\[-0.6ex]"
+                                            (longrightarrow)
+                                            "\\\\[-0.6ex]"
+                                            (longrightarrow)
+                                          ) ;!append
+                                ) ;substack
+                       ) ;mathrel
+  ) ;longfourrightarrows
+) ;smart-table
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Extra TeXmacs macros
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(smart-table latex-texmacs-macro
+  (three-line-table #f)
+  ;; Nullary macros
+  (tmunsc "\\_")
+  (emdash "---")
+  (tmat "\\symbol{\"40}")
+  (tmbsl "\\ensuremath{\\backslash}")
+  (tmdummy "$\\mbox{}$")
+  (TeXmacs "T\\kern-.1667em\\lower.5ex\\hbox{E}\\kern-.125emX\\kern-.1em\\lower.5ex\\hbox{\\textsc{m\\kern-.05ema\\kern-.125emc\\kern-.05ems}}"
+  ) ;TeXmacs
+  (madebyTeXmacs (footnote (!recurse (withTeXmacstext))))
+  (withTeXmacstext (!append (!translate "This document has been produced using the GNU")
+                     " "
+                     (!group (!recurse (TeXmacs)))
+                     " "
+                     (!translate "text editor")
+                     " ("
+                     (!translate "see")
+                     " "
+                     (url "https://www.texmacs.org")
+                     ")"
+                   ) ;!append
+  ) ;withTeXmacstext
+  (citewebsite (!append (!translate "This document has been written using")
+                 " GNU "
+                 (!group (!recurse (TeXmacs)))
+                 "; "
+                 (!translate "see")
+                 " "
+                 (url "https://www.texmacs.org")
+                 "."
+               ) ;!append
+  ) ;citewebsite
+  (tmmade (!recurse (tikzframe (Backsigma))))
+  (scheme "{\\sc Scheme}")
+  (tmsep ", ")
+  (tmSep "; ")
+  (pari "{\\sc Pari}")
+  (textdots "...")
+  (filldots "{\\dotfill\\hfill\\hbox{}}")
+  (infixand (text " and "))
+  (infixor (text " or "))
+  (infixiff (text " iff "))
+
+  ;; Unary macros
+  (tmrsub (ensuremath (!append "_{" (textrm 1) "}")))
+  (tmrsup (textsuperscript 1))
+  (tmverbatim (text (!group (ttfamily) (!group 1))))
+  (tmtextrm (text (!group (rmfamily) (!group 1))))
+  (tmtextsf (text (!group (sffamily) (!group 1))))
+  (tmtexttt (text (!group (ttfamily) (!group 1))))
+  (tmtextmd (text (!group (mdseries) (!group 1))))
+  (tmtextbf (text (!group (bfseries) (!group 1))))
+  (tmtextup (text (!group (upshape) (!group 1))))
+  (tmtextsl (text (!group (slshape) (!group 1))))
+  (tmtextit (text (!group (itshape) (!group 1))))
+  (tmtextsc (text (!group (scshape) (!group 1))))
+  (tmmathbf (ensuremath (!recurse (boldsymbol 1))))
+  (tmmathmd (ensuremath 1))
+  (tmop (ensuremath (operatorname 1)))
+  (tmstrong (textbf 1))
+  (tmem (!group "\\em " 1 "\\/"))
+  (tmtt (texttt 1))
+  (tmdate (today))
+  (tmname (textsc 1))
+  (tmsamp (textsf 1))
+  (tmabbr 1)
+  (tmdfn (textbf 1))
+  (tmkbd (texttt 1))
+  (tmvar (texttt 1))
+  (tmacronym (textsc 1))
+  (tmperson (textsc 1))
+  (tmscript (text (scriptsize (!math 1))))
+  (tmdef 1)
+  (dueto (textup (textbf (!append "(" 1 ") "))))
+  (op 1)
+  (todo (!group (!append (color "red!75!black") "[To do: " 1 "]")))
+  (tmoutput 1)
+  (tmerrput (!append (color "red!50!black") 1))
+  (tmtiming (!append (hfill) (footnotesize) (color "black!50") 1 (par)))
+  (tmsubtitle (thanks (!append (textit (!translate "Subtitle:")) " " 1)))
+  (tmrunningtitle (!append (!translate "Running title:") " " 1))
+  (tmrunningauthor (!append (!translate "Running author:") " " 1))
+  (tmaffiliation (!append (!nextline) 1))
+  (tmemail (!append (!nextline) (textit (!translate "Email:")) " " (texttt 1)))
+  (tmhomepage (!append (!nextline) (textit (!translate "Web:")) " " (texttt 1)))
+  (tmfnaffiliation (thanks (!append (textit (!translate "Affiliation:")) " " 1)))
+  (tmfnemail (thanks (!append (textit (!translate "Email:")) " " (texttt 1))))
+  (tmfnhomepage (thanks (!append (textit (!translate "Web:")) " " (texttt 1))))
+  (tmacmhomepage (titlenote (!append (textit (!translate "Web:")) " " 1)))
+  (tmacmmisc (titlenote (!append (textit (!translate "Misc:")) " " 1)))
+  (tmieeeemail (!append (textit (!translate "Email:")) " " 1))
+  (tmnote (thanks (!append (textit (!translate "Note:")) " " 1)))
+  (tmmisc (thanks (!append (textit (!translate "Misc:")) " " 1)))
+  (key (!append (fcolorbox "black"
+                  "gray!25!white"
+                  (raisebox "0pt" (!option "5pt") (!option "0pt") (texttt 1))
+                ) ;fcolorbox
+         (hspace "0.5pt")
+       ) ;!append
+  ) ;key
+  (uhat (underaccent (hat) 1))
+  (uwidehat (underaccent (widehat (hphantom 1)) 1))
+  (utilde (underaccent (tilde) 1))
+  (uwidetilde (underaccent (widetilde (hphantom 1)) 1))
+  (uvec (underaccent (vec) 1))
+  (ubreve (underaccent (breve) 1))
+  (uinvbreve (underaccent (invbreve) 1))
+  (ucheck (underaccent (check) 1))
+  (uring (underaccent (ring) 1))
+  (uacute (underaccent (acute) 1))
+  (ugrave (underaccent (grave) 1))
+  (underdot (underaccent (dot) 1))
+  (uddot (underaccent (ddot) 1))
+  (udddot (underaccent (dddot (hphantom 1)) 1))
+  (uddddot (underaccent (ddddot (hphantom 1)) 1))
+  (widespacing 1)
+  (gb (!append (texttt "[\\!\\![") 1 (texttt "]\\!\\!]")))
+  (gbt (!append (texttt "[\\!\\![\\!\\![") 1 (texttt "]\\!\\!]\\!\\!]")))
+
+  ;; With options
+  (tmcodeinline ((!option "") (!group (ttfamily) (!group 2))))
+
+  ;; Binary macros
+  (tmcolor (!group (color 1) (!group 2)))
+  (tmsummarizeddocumentation (trivlist (!append (item (!option "")) (mbox "") "\\large\\bf" 1))
+  ) ;tmsummarizeddocumentation
+  (tmsummarizedgrouped (trivlist (!append (item (!option "[")) (mbox "") 1)))
+  (tmsummarizedexplain (trivlist (!append (item (!option "")) (mbox "") "\\bf" 1))
+  ) ;tmsummarizedexplain
+  (tmsummarizedplain (trivlist (!append (item (!option "")) (mbox "") 1)))
+  (tmsummarizedtiny (trivlist (!append (item (!option "")) (mbox "") 1)))
+  (tmsummarizedraw (trivlist (!append (item (!option "")) (mbox "") 1)))
+  (tmsummarizedenv (trivlist (!append (item (!option "$\\bullet$")) (mbox "") 1)))
+  (tmsummarizedstd (trivlist (!append (item (!option "$\\bullet$")) (mbox "") 1)))
+  (tmsummarized (trivlist (!append (item (!option "$\\bullet$")) (mbox "") 1)))
+
+  (tmdetaileddocumentation (trivlist (!append (item (!option "")) (mbox "") "\\large\\bf" 2))
+  ) ;tmdetaileddocumentation
+  (tmdetailedgrouped (trivlist (!append (item (!option "[")) (mbox "") 2)))
+  (tmdetailedexplain (trivlist (!append (item (!option "")) (mbox "") "\\bf" 2)))
+  (tmdetailedplain (trivlist (!append (item (!option "")) (mbox "") 2)))
+  (tmdetailedtiny (trivlist (!append (item (!option "")) (mbox "") 2)))
+  (tmdetailedraw (trivlist (!append (item (!option "")) (mbox "") 2)))
+  (tmdetailedenv (trivlist (!append (item (!option "$\\circ$")) (mbox "") 2)))
+  (tmdetailedstd (trivlist (!append (item (!option "$\\circ$")) (mbox "") 2)))
+  (tmdetailed (trivlist (!append (item (!option "$\\circ$")) (mbox "") 2)))
+
+  (tmfoldeddocumentation (trivlist (!append (item (!option "")) (mbox "") "\\large\\bf" 1))
+  ) ;tmfoldeddocumentation
+  (tmunfoldeddocumentation (trivlist (!append (item (!option ""))
+                                       (mbox "")
+                                       (!group "\\large\\bf" 1)
+                                       "\\\\"
+                                       (item (!option ""))
+                                       (mbox "")
+                                       2
+                                     ) ;!append
+                           ) ;trivlist
+  ) ;tmunfoldeddocumentation
+  (tmfoldedsubsession (trivlist (!append (item (!option "$\\bullet$")) (mbox "") 1))
+  ) ;tmfoldedsubsession
+  (tmunfoldedsubsession (trivlist (!append (item (!option "$\\circ$"))
+                                    (mbox "")
+                                    1
+                                    "\\\\"
+                                    (item (!option ""))
+                                    (mbox "")
+                                    2
+                                  ) ;!append
+                        ) ;trivlist
+  ) ;tmunfoldedsubsession
+  (tmfoldedgrouped (trivlist (!append (item (!option "[")) (mbox "") 1)))
+  (tmunfoldedgrouped (trivlist (!append (item (!option "$\\lceil$"))
+                                 (mbox "")
+                                 1
+                                 "\\\\"
+                                 (item (!option "$\\lfloor$"))
+                                 (mbox "")
+                                 2
+                               ) ;!append
+                     ) ;trivlist
+  ) ;tmunfoldedgrouped
+  (tmfoldedexplain (trivlist (!append (item (!option "")) "\\bf" 1)))
+  (tmunfoldedexplain (trivlist (!append (item (!option ""))
+                                 (mbox "")
+                                 (!group "\\bf" 1)
+                                 "\\\\"
+                                 (item (!option ""))
+                                 (mbox "")
+                                 2
+                               ) ;!append
+                     ) ;trivlist
+  ) ;tmunfoldedexplain
+  (tmfoldedplain (trivlist (!append (item (!option "")) (mbox "") 1)))
+  (tmunfoldedplain (trivlist (!append (item (!option "")) (mbox "") 1 "\\\\" (item (!option "")) (mbox "") 2)
+                   ) ;trivlist
+  ) ;tmunfoldedplain
+  (tmfoldedenv (trivlist (!append (item (!option "$\\bullet$")) (mbox "") 1)))
+  (tmunfoldedenv (trivlist (!append (item (!option "$\\circ$"))
+                             (mbox "")
+                             1
+                             "\\\\"
+                             (item (!option ""))
+                             (mbox "")
+                             2
+                           ) ;!append
+                 ) ;trivlist
+  ) ;tmunfoldedenv
+  (tmfoldedstd (trivlist (!append (item (!option "$\\bullet$")) (mbox "") 1)))
+  (tmunfoldedstd (trivlist (!append (item (!option "$\\circ$"))
+                             (mbox "")
+                             1
+                             "\\\\"
+                             (item (!option ""))
+                             (mbox "")
+                             2
+                           ) ;!append
+                 ) ;trivlist
+  ) ;tmunfoldedstd
+  (tmfolded (trivlist (!append (item (!option "$\\bullet$")) (mbox "") 1)))
+  (tmunfolded (trivlist (!append (item (!option "$\\circ$"))
+                          (mbox "")
+                          1
+                          "\\\\"
+                          (item (!option ""))
+                          (mbox "")
+                          2
+                        ) ;!append
+              ) ;trivlist
+  ) ;tmunfolded
+  (tminput (trivlist (!append (item (!option (!append (color "rgb:black,10;red,9;green,4;yellow,2") 1)))
+                       (!group (!append (color "blue!50!black") (mbox "") 2))
+                     ) ;!append
+           ) ;trivlist
+  ) ;tminput
+  (tminputmath (trivlist (!append (item (!option 1)) (ensuremath 2))))
+  (tmhlink (!group (!append (color "blue") 1)))
+  (tmaction (!group (!append (color "blue") 1)))
+  (ontop (genfrac "" "" "0pt" "" 1 2))
+  (subindex (index (!append 1 "!" 2)))
+  (renderfootnote (footnotetext (!append (tmrsup 1) " " 2)))
+  (renderfootnotestar (footnotetext (!append (tmrsup 1) " " 3)))
+  (tmlinenumber (!append (custombinding 1) (tmlinenote (footnotesize 1) 2 "0cm")))
+
+  ;; Ternary macros
+  (tmsession (!group (!append (tt) 3)))
+  (tmfoldediomath (trivlist (!append (item (!option (!append (color "rgb:black,10;red,9;green,4;yellow,2") 1)))
+                              (!group (!append (color "blue!50!black") (ensuremath 2)))
+                            ) ;!append
+                  ) ;trivlist
+  ) ;tmfoldediomath
+  (tmunfoldediomath (trivlist (!append (item (!option (!append (color "rgb:black,10;red,9;green,4;yellow,2") 1)))
+                                (!group (!append (color "blue!50!black") (ensuremath 2)))
+                                (item (!option ""))
+                                (mbox "")
+                                3
+                              ) ;!append
+                    ) ;trivlist
+  ) ;tmunfoldediomath
+  (tmfoldedio (trivlist (!append (item (!option (!append (color "rgb:black,10;red,9;green,4;yellow,2") 1)))
+                          (mbox "")
+                          (!group (!append (color "blue!50!black") 2))
+                        ) ;!append
+              ) ;trivlist
+  ) ;tmfoldedio
+  (tmunfoldedio (trivlist (!append (item (!option (!append (color "rgb:black,10;red,9;green,4;yellow,2") 1)))
+                            (mbox "")
+                            (!group (!append (color "blue!50!black") 2))
+                            (item (!option ""))
+                            (mbox "")
+                            3
+                          ) ;!append
+                ) ;trivlist
+  ) ;tmunfoldedio
+  (tmlinenote (!append (tmdummy)
+                (marginpar (adjustbox (!append "right=0cm, lap=" 2 "-\\textwidth-\\marginparsep, raise=" 3)
+                             1
+                           ) ;adjustbox
+                ) ;marginpar
+              ) ;!append
+  ) ;tmlinenote
+  (subsubindex (index (!append 1 "!" 2 "!" 3)))
+  (tmref 1)
+  (glossaryentry (!append (item (!option (!append 1 (hfill)))) 2 (dotfill) 3))
+
+  ;; Tetrary macros
+  (tmscriptinput (fbox (!append (fbox (!append (sf) 2)) " " (!append (tt) 3))))
+  (tmscriptoutput (!append 4))
+  (tmconverterinput (fbox (!append (fbox (!append (sf) 2)) " " (!append (tt) 3))))
+  (tmconverteroutput (!append 4))
+  (subsubsubindex (index (!append 1 "!" 2 "!" 3 "!" 4)))
+) ;smart-table
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Deprecated extra macros
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(smart-table latex-texmacs-macro
+  (labeleqnum "\\addtocounter{equation}{-1}\\refstepcounter{equation}\\addtocounter{equation}{1})"
+  ) ;labeleqnum
+  (eqnumber (!append "\\hfill(\\theequation" (!recurse (labeleqnum)) ")"))
+  (leqnumber (!append "(\\theequation" (!recurse (labeleqnum)) ")\\hfill"))
+  (reqnumber (!append "\\hfill(\\theequation" (!recurse (labeleqnum)) ")"))
+  (skey (!recurse (key (!append "shift-" 1))))
+  (ckey (!recurse (key (!append "ctrl-" 1))))
+  (akey (!recurse (key (!append "alt-" 1))))
+  (mkey (!recurse (key (!append "meta-" 1))))
+  (hkey (!recurse (key (!append "hyper-" 1))))
+) ;smart-table
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Extra TeXmacs environments
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(smart-table latex-texmacs-environment
+ ("proof" ((!begin "proof") ---))
+ ("proof*" ((!begin "proof" (!option 1)) ---))
+ ("leftaligned" ((!begin "flushleft") ---))
+ ("rightaligned" ((!begin "flushright") ---))
+ ("quoteenv" ((!begin "quote") ---))
+ ("tmcode" ((!option "") ((!begin "alltt") ---)))
+ ("tmparmod"
+  ((!begin "list"
+     ""
+     (!append "\\setlength{\\topsep}{0pt}" "\\setlength{\\leftmargin}{" 1 "}"
+       "\\setlength{\\rightmargin}{" 2 "}" "\\setlength{\\parindent}{" 3 "}"
+       "\\setlength{\\listparindent}{\\parindent}"
+       "\\setlength{\\itemindent}{\\parindent}"
+       "\\setlength{\\parsep}{\\parskip}"
+     ) ;!append
+   ) ;!begin
+   (!append "\\item[]" ---)
+  ) ;
+ ) ;
+ ("tmparsep"
+   (!append (begingroup) "\\setlength{\\parskip}{" 1 "}" --- (endgroup))
+ ) ;
+ ("tmcompact" ((!begin "tmparsep" "0em") ---))
+ ("tmcompressed" ((!begin "tmparsep" "0.25em") ---))
+ ("tmamplified" ((!begin "tmparsep" "0.75em") ---))
+ ("tmjumpin" ((!begin "tmparmod" "1.5em" "0pt" "-1.5em") ---))
+ ("tmindent" ((!begin "tmparmod" "1.5em" "0pt" "0pt") ---))
+ ("tmlisting" ((!begin "linenumbers") (!append (resetlinenumber) ---)))
+ ("elsequation" ((!begin "eqnarray") (!append --- "&&")))
+ ("elsequation*" ((!begin "eqnarray*") (!append --- "&&")))
+ ("theglossary"
+  ((!begin "list"
+     ""
+     (!append "\\setlength{\\labelwidth}{6.5em}"
+       "\\setlength{\\leftmargin}{7em}"
+       "\\small"
+     ) ;!append
+   ) ;!begin
+   ---
+  ) ;
+ ) ;
+) ;smart-table
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; TeXmacs list environments
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-macro (latex-texmacs-itemize env lab)
+  `(smart-table latex-texmacs-environment
+     (,env
+      ((!begin "itemize")
+       (!append ,"\\renewcommand{\\labelitemi}{"
+         ,lab
+         ,"}"
+         ,"\\renewcommand{\\labelitemii}{"
+         ,lab
+         ,"}"
+         ,"\\renewcommand{\\labelitemiii}{"
+         ,lab
+         ,"}"
+         ,"\\renewcommand{\\labelitemiv}{"
+         ,lab
+         ,"}"
+         ---))))
+) ;define-macro
+
+(define-macro (latex-texmacs-enumerate env lab)
+  `(smart-table latex-texmacs-environment
+     (,env ((!begin ,"enumerate" (!option ,lab)) ---)))
+) ;define-macro
+
+(define-macro (latex-texmacs-description env)
+  `(smart-table latex-texmacs-environment (,env ((!begin "description") ---)))
+) ;define-macro
+
+(latex-texmacs-itemize "itemizeminus" "$-$")
+(latex-texmacs-itemize "itemizedot" "$\\bullet$")
+(latex-texmacs-itemize "itemizearrow" "$\\rightarrow$")
+(latex-texmacs-enumerate "enumeratenumeric" "1.")
+(latex-texmacs-enumerate "enumeratenumericbracket" "1{\\textup{)}}")
+(latex-texmacs-enumerate "enumerateroman" "i.")
+(latex-texmacs-enumerate "enumerateromanbracket" "i{\\textup{)}}")
+(latex-texmacs-enumerate "enumerateromanparen" "(i)")
+(latex-texmacs-enumerate "enumerateromancap" "I.")
+(latex-texmacs-enumerate "enumeratealpha" "a{\\textup{)}}")
+(latex-texmacs-enumerate "enumeratealphabracket" "a{\\textup{)}}")
+(latex-texmacs-enumerate "enumeratealphafullparen" "(a)")
+(latex-texmacs-enumerate "enumeratealphacap" "A.")
+(latex-texmacs-description "descriptioncompact")
+(latex-texmacs-description "descriptionaligned")
+(latex-texmacs-description "descriptiondash")
+(latex-texmacs-description "descriptionlong")
+(latex-texmacs-description "descriptionparagraphs")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Extra preamble definitions which are needed to export certain macros
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(smart-table latex-texmacs-preamble
+  (newmdenv (!append (mdfsetup (!append "linecolor=black,linewidth=0.5pt,"
+                                 "skipabove=0.5em,skipbelow=0.5em,"
+                                 "hidealllines=true,innerleftmargin=0pt,"
+                                 "innerrightmargin=0pt,innertopmargin=0pt,"
+                                 "innerbottommargin=0pt"
+                               ) ;!append
+                     ) ;mdfsetup
+              "\n"
+            ) ;!append
+  ) ;newmdenv
+  (tikzframe (!append (!ignore (tikz))
+               "\\newcommand{\\tikzframe}[1]{%\n"
+               "  \\tikz[baseline=(X.base)]\n"
+               "  \\node[draw=black,semithick,rectangle,inner sep=2pt,rounded corners=2pt]\n"
+               "  (X) {#1};}\n"
+             ) ;!append
+  ) ;tikzframe
+  (nonconverted (!append "\\newcommand{\\nonconverted}[1]{\\mbox{}}\n"))
+  (tmkeywords (!append (newcommand (tmkeywords) (!append (textbf (!translate "Keywords:")) " "))
+                "\n"
+              ) ;!append
+  ) ;tmkeywords
+  (tmacm (!append (newcommand (tmacm)
+                    (!append (textbf (!translate "A.C.M. subject classification:")) " ")
+                  ) ;newcommand
+           "\n"
+         ) ;!append
+  ) ;tmacm
+  (tmarxiv (!append (newcommand (tmarxiv)
+                      (!append (textbf (!translate "arXiv subject classification:")) " ")
+                    ) ;newcommand
+             "\n"
+           ) ;!append
+  ) ;tmarxiv
+  (tmpacs (!append (newcommand (tmpacs)
+                     (!append (textbf (!translate "P.A.C.S. subject classification:")) " ")
+                   ) ;newcommand
+            "\n"
+          ) ;!append
+  ) ;tmpacs
+  (tmmsc (!append (newcommand (tmmsc)
+                    (!append (textbf (!translate "A.M.S. subject classification:")) " ")
+                  ) ;newcommand
+           "\n"
+         ) ;!append
+  ) ;tmmsc
+  (fmtext (!append "\\newcommand{\\fmtext}[2][]{\\fntext[#1]{"
+            (!translate "Misc:")
+            " #2}}\n"
+          ) ;!append
+  ) ;fmtext
+  (tdatetext (!append "\\newcommand{\\tdatetext}[2][]{\\tnotetext[#1]{"
+               (!translate "Date:")
+               " #2}}\n"
+             ) ;!append
+  ) ;tdatetext
+  (tmisctext (!append "\\newcommand{\\tmisctext}[2][]{\\tnotetext[#1]{"
+               (!translate "Misc:")
+               " #2}}\n"
+             ) ;!append
+  ) ;tmisctext
+  (tsubtitletext (!append "\\newcommand{\\tsubtitletext}[2][]{\\tnotetext[#1]{"
+                   (!translate "Subtitle:")
+                   " #2}}\n"
+                 ) ;!append
+  ) ;tsubtitletext
+  (thankshomepage (!append "\\newcommand{\\thankshomepage}[2][]{\\thanks[#1]{"
+                    (!translate "URL:")
+                    " #2}}\n"
+                  ) ;!append
+  ) ;thankshomepage
+  (thanksemail (!append "\\newcommand{\\thanksemail}[2][]{\\thanks[#1]{"
+                 (!translate "Email:")
+                 " #2}}\n"
+               ) ;!append
+  ) ;thanksemail
+  (thanksdate (!append "\\newcommand{\\thanksdate}[2][]{\\thanks[#1]{"
+                (!translate "Date:")
+                " #2}}\n"
+              ) ;!append
+  ) ;thanksdate
+  (thanksamisc (!append "\\newcommand{\\thanksamisc}[2][]{\\thanks[#1]{"
+                 (!translate "Misc:")
+                 " #2}}\n"
+               ) ;!append
+  ) ;thanksamisc
+  (thanksmisc (!append "\\newcommand{\\thanksmisc}[2][]{\\thanks[#1]{"
+                (!translate "Misc:")
+                " #2}}\n"
+              ) ;!append
+  ) ;thanksmisc
+  (thankssubtitle (!append "\\newcommand{\\thankssubtitle}[2][]{\\thanks[#1]{"
+                    (!translate "Subtitle:")
+                    " #2}}\n"
+                  ) ;!append
+  ) ;thankssubtitle
+  (qed (!append (providecommand "\\qed" (ensuremath (Box))) "\n"))
+  (mho (!append "\\renewcommand{\\mho}{\\mbox{\\rotatebox[origin=c]{180}{$\\omega$}}}")
+  ) ;mho
+  (invbreve (!append "\\usepackage[T3,T1]{fontenc}\n"
+              "\\DeclareSymbolFont{tipa}{T3}{cmr}{m}{n}\n"
+              "\\DeclareMathAccent{\\invbreve}{\\mathalpha}{tipa}{16}\n"
+            ) ;!append
+  ) ;invbreve
+  (custombinding (!append "\\newcounter{tmcounter}\n"
+                   "\\newcommand{\\custombinding}[1]{%\n"
+                   "  \\setcounter{tmcounter}{#1}%\n"
+                   "  \\addtocounter{tmcounter}{-1}%\n"
+                   "  \\refstepcounter{tmcounter}}\n"
+                 ) ;!append
+  ) ;custombinding
+  (tmfloat (!append (!ignore (ifthenelse) (captionof) (widthof))
+             "\\newcommand{\\tmfloatcontents}{}\n"
+             "\\newlength{\\tmfloatwidth}\n"
+             "\\newcommand{\\tmfloat}[5]{\n"
+             "  \\renewcommand{\\tmfloatcontents}{#4}\n"
+             "  \\setlength{\\tmfloatwidth}{\\widthof{\\tmfloatcontents}+1in}\n"
+             "  \\ifthenelse{\\equal{#2}{small}}\n"
+             ;; FIXME: the length test frequently produces an error:
+             ;; '! Missing = inserted for \ifdim'.
+             ;; I (Joris) did not manage to understand this LaTeX mess.
+             ;; "    {\\ifthenelse{\\lengthtest{\\tmfloatwidth > \\linewidth}}\n"
+             ;; "      {\\setlength{\\tmfloatwidth}{\\linewidth}}{}}\n"
+             "    {\\setlength{\\tmfloatwidth}{0.45\\linewidth}}\n"
+             "    {\\setlength{\\tmfloatwidth}{\\linewidth}}\n"
+             "  \\begin{minipage}[#1]{\\tmfloatwidth}\n"
+             "    \\begin{center}\n"
+             "      \\tmfloatcontents\n"
+             "      \\captionof{#3}{#5}\n"
+             "    \\end{center}\n"
+             "  \\end{minipage}}\n"
+           ) ;!append
+  ) ;tmfloat
+  (addtocountergroup (!append "\\newcommand{\\addtocountergroup}[2]{}\n"))
+  (groupcommoncounter (!append "\\newcommand{\\groupcommoncounter}[1]{}\n"))
+) ;smart-table
+
+;; (define-macro (latex-texmacs-long prim x l m r)
+;;  `(smart-table latex-texmacs-preamble
+;;     (,(string->symbol (substring prim 1 (string-length prim)))
+;;      (!append
+;;       "\\def" ,prim "fill@{\\arrowfill@" ,l ,m ,r "}\n"
+;;       "\\providecommand{" ,prim "}[2][]{"
+;;       "\\ext@arrow 0099" ,prim "fill@{#1}{#2}}\n"))))
+
+(define-macro (latex-texmacs-long prim x l m r)
+  `(smart-table latex-texmacs-preamble
+     (,(string->symbol (substring prim 1 (string-length prim)))
+      (!append ,"\\providecommand{"
+        ,prim
+        ,"}[2][]{"
+        ,"\\mathop{"
+        ,x
+        ,"}\\limits_{#1}^{#2}}\n")))
+) ;define-macro
+
+(latex-texmacs-long "\\xminus" "-" "\\DOTSB\\relbar" "\\relbar"
+  "\\DOTSB\\relbar"
+) ;latex-texmacs-long
+(latex-texmacs-long "\\xleftrightarrow" "\\longleftrightarrow" "\\leftarrow"
+  "\\relbar" "\\rightarrow"
+) ;latex-texmacs-long
+(latex-texmacs-long "\\xmapsto" "\\longmapsto" "\\vdash" "\\relbar"
+  "\\rightarrow"
+) ;latex-texmacs-long
+(latex-texmacs-long "\\xmapsfrom" "\\leftarrow\\!\\!\\dashv" "\\leftarrow"
+  "\\relbar" "\\dashv"
+) ;latex-texmacs-long
+(latex-texmacs-long "\\xequal" "=" "\\DOTSB\\Relbar" "\\Relbar"
+  "\\DOTSB\\Relbar"
+) ;latex-texmacs-long
+(latex-texmacs-long "\\xLeftarrow" "\\Longleftarrow" "\\Leftarrow" "\\Relbar"
+  "\\Relbar"
+) ;latex-texmacs-long
+(latex-texmacs-long "\\xRightarrow" "\\Longrightarrow" "\\Relbar" "\\Relbar"
+  "\\Rightarrow"
+) ;latex-texmacs-long
+(latex-texmacs-long "\\xLeftrightarrow" "\\Longleftrightarrow" "\\Leftarrow"
+  "\\Relbar" "\\Rightarrow"
+) ;latex-texmacs-long
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Plain style theorems
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define-macro (latex-texmacs-thmenv prim name before after . opt-mode)
+  (let* ((head (if (null? opt-mode) (list) (list `(,:mode ,(car opt-mode)))))
+         (prim* (string-append prim "*"))
+         (nonum (string-append "nn" prim))
+         (thenonum (string-append "\\the" nonum))
+        ) ;
+    `(smart-table latex-texmacs-env-preamble
+       ,@head
+       (,prim
+        (!append ,@before (newtheorem ,prim (!translate ,name)) ,@after ,"\n"))
+       (,prim*
+        (!append (newcounter ,nonum)
+          ,"\n"
+          ,"\\def"
+          ,thenonum
+          ,"{\\unskip}\n"
+          ,@before
+          (newtheorem ,prim* (!option ,nonum) (!translate ,name))
+          ,@after
+          ,"\n")))
+  ) ;let*
+) ;tm-define-macro
+
+(define-macro (latex-texmacs-theorem prim name)
+  `(latex-texmacs-thmenv ,prim ,name ,() ,())
+) ;define-macro
+
+(define-macro (latex-texmacs-remark prim name)
+  `(latex-texmacs-thmenv ,prim
+     ,name
+     ("{" (!recurse (theorembodyfont "\\rmfamily")))
+     ("}"))
+) ;define-macro
+
+(define-macro (latex-texmacs-exercise prim name)
+  `(latex-texmacs-thmenv ,prim
+     ,name
+     ("{" (!recurse (theorembodyfont "\\rmfamily\\small")))
+     ("}"))
+) ;define-macro
+
+(latex-texmacs-theorem "theorem" "Theorem")
+(latex-texmacs-theorem "proposition" "Proposition")
+(latex-texmacs-theorem "lemma" "Lemma")
+(latex-texmacs-theorem "corollary" "Corollary")
+(latex-texmacs-theorem "axiom" "Axiom")
+(latex-texmacs-remark "definition" "Definition")
+(latex-texmacs-remark "assumption" "Assumption")
+(latex-texmacs-theorem "notation" "Notation")
+(latex-texmacs-theorem "conjecture" "Conjecture")
+(latex-texmacs-remark "remark" "Remark")
+(latex-texmacs-remark "note" "Note")
+(latex-texmacs-remark "example" "Example")
+(latex-texmacs-remark "convention" "Convention")
+(latex-texmacs-remark "warning" "Warning")
+(latex-texmacs-remark "acknowledgments" "Acknowledgments")
+(latex-texmacs-remark "answer" "Answer")
+(latex-texmacs-remark "question" "Question")
+(latex-texmacs-exercise "exercise" "Exercise")
+(latex-texmacs-exercise "problem" "Problem")
+(latex-texmacs-exercise "solution" "Solution")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Ornamented environments
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(smart-table latex-texmacs-env-preamble
+ ("tmpadded" (!append (newmdenv (!option "") "tmpadded") "\n"))
+ ("tmoverlined"
+   (!append (newmdenv (!option "topline=true,innertopmargin=1ex") "tmoverlined")
+     "\n"
+   ) ;!append
+ ) ;
+ ("tmunderlined"
+   (!append (newmdenv (!option "bottomline=true,innerbottommargin=1ex") "tmunderlined")
+     "\n"
+   ) ;!append
+ ) ;
+ ("tmbothlined"
+   (!append (newmdenv (!option "topline=true,bottomline=true,innertopmargin=1ex,innerbottommargin=1ex"
+                      ) ;!option
+              "tmbothlined"
+            ) ;newmdenv
+     "\n"
+   ) ;!append
+ ) ;
+ ("tmframed"
+   (!append (newmdenv (!option "hidealllines=false,innertopmargin=1ex,innerbottommargin=1ex,innerleftmargin=1ex,innerrightmargin=1ex"
+                      ) ;!option
+              "tmframed"
+            ) ;newmdenv
+     "\n"
+   ) ;!append
+ ) ;
+ ("tmornamented"
+   (!append (newmdenv (!option "hidealllines=false,innertopmargin=1ex,innerbottommargin=1ex,innerleftmargin=1ex,innerrightmargin=1ex"
+                      ) ;!option
+              "tmornamented"
+            ) ;newmdenv
+     "\n"
+   ) ;!append
+ ) ;
+) ;smart-table
diff --git a/TeXmacs/plugins/latex/progs/latex/convert-latex-drd.scm b/TeXmacs/plugins/latex/progs/latex/convert-latex-drd.scm
new file mode 100644
index 0000000000..5fbd54ac38
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/convert-latex-drd.scm
@@ -0,0 +1,311 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : latex-drd.scm
+;; DESCRIPTION : Formal specification of the part of LaTeX
+;;               which is understood by TeXmacs
+;; COPYRIGHT   : (C) 1999-2022  Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex convert-latex-drd) (:use (latex convert-latex-overload)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Order in which packages should be included
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-table latex-package-priority%
+ ("geometry" 10)
+ ("amsmath" 20)
+ ("amssymb" 30)
+ ("graphicx" 40)
+ ("wasysym" 50)
+ ("stmaryrd" 60)
+ ("textcomp" 60)
+ ("enumerate" 70)
+ ("epsfig" 80)
+ ("mathrsfs" 90)
+ ("bbm" 100)
+ ("dsfont" 110)
+ ("euscript" 120)
+ ("multicol" 130)
+ ("hyperref" 140)
+ ("mathtools" 150)
+ ("cleveref" 160)
+) ;logic-table
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Dependencies between style files and packages
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-table latex-depends%
+ ("amsart" "amstex")
+ ("amstex" "amsmath")
+ ("amstex" "amsthm")
+) ;logic-table
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Dependencies of commands on packages
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-table latex-needs%
+  (!verbatim "alltt")
+  (!verbatim* "alltt")
+  (begin-alltt "alltt")
+  (begin-proof "amsthm")
+
+  (begin-tabularx "tabularx")
+  (toprule "booktabs")
+  (midrule "booktabs")
+  (bottomrule "booktabs")
+
+  (geometry "geometry")
+  (epsfig "epsfig")
+  (includegraphics "graphicx")
+  (rotatebox "graphicx")
+  (scalebox "graphicx")
+  (reflectbox "graphicx")
+  (adjustbox "adjustbox")
+
+  (mathscr "mathrsfs")
+  (EuScript "euscript")
+  (mathbbm "bbm")
+  (mathbbmss "bbm")
+  (mathds "dsfont")
+  (mathfrak "amssymb")
+  (mathbb "amssymb")
+  (theorembodyfont "theorem")
+  (substack "mathtools")
+
+  (begin-align "amsmath")
+  (begin-align* "amsmath")
+  (begin-alignat "amsmath")
+  (begin-alignat* "amsmath")
+  (begin-xalignat "amsmath")
+  (begin-xxalignat "amsmath")
+  (begin-flalign "amsmath")
+  (begin-flalign* "amsmath")
+  (begin-gather "amsmath")
+  (begin-gather* "amsmath")
+  (begin-multline "amsmath")
+  (begin-multline* "amsmath")
+  (begin-split "amsmath")
+
+  (text "amsmath")
+  (binom "amsmath")
+  (dbinom "amsmath")
+  (tbinom "amsmath")
+  (dddot "amsmath")
+  (ddddot "amsmath")
+  (genfrac "amsmath")
+  (mod "amsmath")
+  (pod "amsmath")
+  (overset "amsmath")
+  (underset "amsmath")
+  (operatorname "amsmath")
+  (boldsymbol "amsmath")
+  (overleftrightarrow "amsmath")
+  (underleftarrow "amsmath")
+  (underrightarrow "amsmath")
+  (underleftrightarrow "amsmath")
+
+  (underaccent "accents")
+  (ring "accents")
+
+  (ifthenelse "ifthen")
+  (captionof "capt-of")
+  (widthof "calc")
+
+  (color "xcolor")
+  (fcolorbox "xcolor")
+  (textcolor "xcolor")
+
+  (euro "eurosym")
+
+  (mdfsetup ("tikz" "mdframed"))
+  (begin-mdframed "mdframed")
+  (tikz "tikz")
+
+  (omicron "pslatex")
+  (multicols "multicol")
+  (bundle "epic")
+  (chunk "epic")
+  (bundle "ecltree")
+  (chunk "ecltree")
+
+  (url "hyperref")
+  (href "hyperref")
+  (hyperref "hyperref")
+
+  (cref "cleveref")
+  (Cref "cleveref")
+
+  (citet "natbib")
+  (citep "natbib")
+  (citet* "natbib")
+  (citep* "natbib")
+  (citealt "natbib")
+  (citealp "natbib")
+  (citealt* "natbib")
+  (citealp* "natbib")
+  (citetext "natbib")
+  (citeauthor "natbib")
+  (citeauthor* "natbib")
+  (citeyear "natbib")
+
+  (index "makeidx")
+  (printindex "makeidx")
+
+  (inparaenum "paralist")
+
+  (listpart "expdlist")
+
+  (ifthispageodd "scrextend")
+
+  (begin-linenumbers "lineno")
+  (resetlinenumber "lineno")
+) ;logic-table
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Page size settings
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-table latex-paper-opts%
+ ("page-top" "top")
+ ("page-bot" "bottom")
+ ("page-odd" "left")
+ ("page-even" "left")
+ ("page-right" "right")
+ ("page-height" "paperheight")
+ ("page-width" "paperwidth")
+ ("page-type" "page-type")
+ ("page-orientation" "page-orientation")
+) ;logic-table
+
+(logic-table latex-paper-type%
+ ("a0" "a0paper")
+ ("a1" "a1paper")
+ ("a2" "a2paper")
+ ("a3" "a3paper")
+ ("a4" "a4paper")
+ ("a5" "a5paper")
+ ("a6" "a6paper")
+ ("a7" "papersize={74mm,105mm}")
+ ("a8" "papersize={52mm,74mm")
+ ("a9" "papersize={37mm,52mm}")
+ ("b0" "b0paper")
+ ("b1" "b1paper")
+ ("b2" "b2paper")
+ ("b3" "b3paper")
+ ("b4" "b4paper")
+ ("b5" "b5paper")
+ ("b6" "b6paper")
+ ("b7" "papersize={88mm,125mm}")
+ ("b8" "papersize={62mm,88mm}")
+ ("b9" "papersize={44mm,62mm}")
+ ("legal" "legalpaper")
+ ("letter" "letterpaper")
+ ("executive" "executivepaper")
+ ("archA" "papersize={9in,12in}")
+ ("archB" "papersize={12in,18in}")
+ ("archC" "papersize={18in,24in}")
+ ("archD" "papersize={24in,36in}")
+ ("archE" "papersize={36in,48in}")
+ ("10x14" "papersize={10in,14in}")
+ ("11x17" "papersize={11in,17in}")
+ ("C5" "papersize={162mm,229mm}")
+ ("Comm10" "papersize={297pt,684pt}")
+ ("DL" "papersize={110mm,220mm}")
+ ("halfletter" "papersize={140mm,216mm}")
+ ("halfexecutive" "papersize={133mm,184mm}")
+ ("ledger" "papersize={432mm,279mm}")
+ ("Monarch" "papersize={98mm,190mm}")
+ ("csheet" "papersize={432mm,559mm}")
+ ("dsheet" "papersize={559mm,864mm}")
+ ("esheet" "papersize={864mm,1118mm}")
+ ("flsa" "papersize={216mm,330mm}")
+ ("flse" "papersize={216mm,330mm}")
+ ("folio" "papersize={216mm,330mm}")
+ ("lecture note" "papersize={15.5cm,23.5cm}")
+ ("note" "papersize={216mm,279mm}")
+ ("quarto" "papersize={215mm,275mm}")
+ ("statement" "papersize={140mm,216mm}")
+ ("tabloid" "papersize={279mm,432mm}")
+) ;logic-table
+
+;; cpp interface with reversed access
+
+(tm-define (latex-paper-opts s)
+  (with r
+    (query `(latex-paper-opts% 'x ,s))
+    (if (nnull? r) (cdaar r) "undefined")
+  ) ;with
+) ;tm-define
+
+(tm-define (latex-paper-type s)
+  (with r
+    (query `(latex-paper-type% 'x ,s))
+    (if (nnull? r) (cdaar r) "undefined")
+  ) ;with
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Routines for consulting the database (might become deprecated)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (latex-resolve s)
+  (define (safe-string2symbol s)
+    (if (== s "") (string->symbol " ") (string->symbol s))
+  ) ;define
+
+  (if (string-starts? s "\\") (set! s (substring s 1 (string-length s))))
+
+  (with arity
+    (logic-ref latex-arity% (safe-string2symbol s))
+    (if (logic-in? (safe-string2symbol s) latex-optional-arg%)
+      (set! arity (- -1 arity))
+    ) ;if
+    (if (string-starts? s "end-")
+      (begin
+        (set! s (string-append "begin-" (substring s 4 (string-length s))))
+        (set! arity 0)
+      ) ;begin
+    ) ;if
+    (values (safe-string2symbol s) arity)
+  ) ;with
+) ;define
+
+(tm-define (latex-arity tag)
+  "Get the arity of a LaTeX @tag"
+  (receive (s arity) (latex-resolve tag) (or arity 0))
+) ;tm-define
+
+(tm-define (latex-type tag)
+  "Get the type of a LaTeX @tag"
+  (receive (s arity)
+    (latex-resolve tag)
+    (cond ((not arity) "undefined")
+          ((logic-in? s latex-command%) "command")
+          ((logic-in? s latex-length%) "length")
+          ((logic-in? s latex-ignore%) "ignore")
+          ((logic-in? s latex-as-pic%) "as-picture")
+          ((logic-in? s latex-name%) "name")
+          ((logic-in? s latex-counter%) "counter")
+          ((logic-in? s latex-modifier%) "modifier")
+          ((logic-in? s latex-control%) "control")
+          ((logic-in? s latex-operator%) "operator")
+          ((logic-in? s latex-list%) "list")
+          ((logic-in? s latex-math-environment%) "math-environment")
+          ((logic-in? s latex-enunciation%) "enunciation")
+          ((logic-in? s latex-environment%) "environment")
+          ((logic-in? s latex-texmacs%) "texmacs")
+          ((logic-in? s latex-symbol%) "symbol")
+          ((logic-in? s latex-big-symbol%) "big-symbol")
+          (else "undefined")
+    ) ;cond
+  ) ;receive
+) ;tm-define
diff --git a/TeXmacs/plugins/latex/progs/latex/convert-latex-overload.scm b/TeXmacs/plugins/latex/progs/latex/convert-latex-overload.scm
new file mode 100644
index 0000000000..205a2dd994
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/convert-latex-overload.scm
@@ -0,0 +1,218 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : latex-overload.scm
+;; DESCRIPTION : LaTeX re-definitions for specific styles/packages
+;; COPYRIGHT   : (C) 2005  Joris van der Hoeven
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex convert-latex-overload)
+  (:use (latex convert-latex-define))
+) ;texmacs-module
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Letter and article styles
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(smart-table latex-texmacs-macro
+  (:require (latex-has-style? "letter"))
+  (appendix "")
+) ;smart-table
+
+(define-macro (latex-texmacs-section name inside style)
+  `(smart-table latex-texmacs-macro
+     (,:require (latex-has-style? ,style))
+     (,name (!append (medskip) (bigskip) ,"\n\n" (noindent) (textbf ,inside))))
+) ;define-macro
+
+(define-macro (latex-texmacs-paragraph name inside style)
+  `(smart-table latex-texmacs-macro
+     (,:require (latex-has-style? ,style))
+     (,name (!append (smallskip) ,"\n\n" (noindent) (textbf ,inside))))
+) ;define-macro
+
+(latex-texmacs-section chapter (!append "\\huge " 1) "article")
+(latex-texmacs-section chapter (!append "\\huge " 1) "letter")
+(latex-texmacs-section section (!append "\\LARGE " 1) "letter")
+(latex-texmacs-section subsection (!append "\\Large " 1) "letter")
+(latex-texmacs-section subsubsection (!append "\\large " 1) "letter")
+(latex-texmacs-paragraph paragraph 1 "letter")
+(latex-texmacs-paragraph subparagraph 1 "letter")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; amsthm package
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(smart-table latex-texmacs-macro (:require (latex-depends? "amsthm")) (qed #f))
+
+(smart-table latex-texmacs-environment
+  (:require (or (latex-depends? "amsthm") (latex-has-texmacs-style? "amsart")))
+  ("proof" #f)
+) ;smart-table
+
+(define-macro (ams-texmacs-theorem abbr full)
+  `(smart-table latex-texmacs-env-preamble
+     (:require (latex-depends? "amsthm"))
+     (,abbr
+      (!append ,"\\theoremstyle{plain}\n"
+        (newtheorem ,abbr (!translate ,full))
+        ,"\n")))
+) ;define-macro
+
+(define-macro (ams-texmacs-remark abbr full)
+  `(smart-table latex-texmacs-env-preamble
+     (:require (latex-depends? "amsthm"))
+     (,abbr
+      (!append ,"\\theoremstyle{remark}\n"
+        (newtheorem ,abbr (!translate ,full))
+        ,"\n")))
+) ;define-macro
+
+(define-macro (ams-texmacs-exercise abbr full)
+  `(smart-table latex-texmacs-env-preamble
+     (:require (latex-depends? "amsthm"))
+     (,abbr
+      (!append ,"\\newtheoremstyle{indent-exercise}{3pt}{3pt}"
+        ,"{\\small}{\\parindent}{\\bf\\small}{.}{.5em}{}{}\n"
+        ,"\\theoremstyle{indent-exercise}\n"
+        (newtheorem ,abbr (!translate ,full))
+        ,"\n")))
+) ;define-macro
+
+(ams-texmacs-theorem "theorem" "Theorem")
+(ams-texmacs-theorem "proposition" "Proposition")
+(ams-texmacs-theorem "lemma" "Lemma")
+(ams-texmacs-theorem "corollary" "Corollary")
+(ams-texmacs-theorem "axiom" "Axiom")
+(ams-texmacs-remark "definition" "Definition")
+(ams-texmacs-remark "assumption" "Assumption")
+(ams-texmacs-theorem "notation" "Notation")
+(ams-texmacs-theorem "conjecture" "Conjecture")
+(ams-texmacs-remark "remark" "Remark")
+(ams-texmacs-remark "note" "Note")
+(ams-texmacs-remark "example" "Example")
+(ams-texmacs-remark "convention" "Convention")
+(ams-texmacs-remark "acknowledgments" "Acknowledgments")
+(ams-texmacs-remark "warning" "Warning")
+(ams-texmacs-remark "answer" "Answer")
+(ams-texmacs-remark "question" "Question")
+(ams-texmacs-exercise "exercise" "Exercise")
+(ams-texmacs-exercise "problem" "Problem")
+(ams-texmacs-exercise "solution" "Solution")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Framed session package
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(smart-table latex-texmacs-macro
+  (:require (latex-has-texmacs-package? "framed-session"))
+  (tmerrput ((!begin "tmframed"
+               (!option "skipabove=0,skipbelow=0,backgroundcolor={red!15},linecolor={red!50!black}"
+               ) ;!option
+             ) ;!begin
+             (!append (color "red!50!black") 1)
+            ) ;
+  ) ;tmerrput
+  (tmfoldedsubsession ((!begin "tmframed"
+                         (!option "skipabove=0,skipbelow=0,backgroundcolor={rgb:white,10;red,9;green,4;yellow,2},linecolor={black!50}"
+                         ) ;!option
+                       ) ;!begin
+                       (trivlist (!append (item (!option "$\\bullet$")) (mbox "") 1))
+                      ) ;
+  ) ;tmfoldedsubsession
+  (tmunfoldedsubsession (!append ((!begin "tmframed"
+                                    (!option "skipabove=0,skipbelow=0,backgroundcolor={rgb:white,10;red,9;green,4;yellow,2},linecolor={black!50}"
+                                    ) ;!option
+                                  ) ;!begin
+                                  (trivlist (!append (item (!option "$\\circ$")) (mbox "") 1))
+                                 ) ;
+                         ((!begin "tmframed"
+                            (!option "skipabove=0,skipbelow=0,backgroundcolor={rgb:white,50;red,9;green,4;yellow,2},linecolor={black!50}"
+                            ) ;!option
+                          ) ;!begin
+                          (trivlist (!append (item (!option "")) (mbox "") 2))
+                         ) ;
+                        ) ;!append
+  ) ;tmunfoldedsubsession
+  (tminput ((!begin "tmframed"
+              (!option "skipabove=0,skipbelow=0,backgroundcolor={yellow!15},linecolor={black!15}"
+              ) ;!option
+            ) ;!begin
+            (trivlist (!append (item (!option (!append (color "rgb:black,10;red,9;green,4;yellow,2") 1)))
+                        (!group (!append (color "blue!50!black") (mbox "") 2))
+                      ) ;!append
+            ) ;trivlist
+           ) ;
+  ) ;tminput
+  (tminputmath ((!begin "tmframed"
+                  (!option "skipabove=0,skipbelow=0,backgroundcolor={yellow!15},linecolor={black!15}"
+                  ) ;!option
+                ) ;!begin
+                (trivlist (!append (item (!option 1)) (mbox "") (ensuremath 2)))
+               ) ;
+  ) ;tminputmath
+
+  (tmfoldediomath ((!begin "tmframed"
+                     (!option "skipabove=0,skipbelow=0,backgroundcolor={yellow!15},linecolor={black!15}"
+                     ) ;!option
+                   ) ;!begin
+                   (trivlist (!append (item (!option (!append (color "rgb:black,10;red,9;green,4;yellow,2") 1)))
+                               (mbox "")
+                               (!group (!append (color "blue!50!black") (ensuremath 2)))
+                             ) ;!append
+                   ) ;trivlist
+                  ) ;
+  ) ;tmfoldediomath
+  (tmunfoldediomath (!append ((!begin "tmframed"
+                                (!option "skipabove=0,skipbelow=0,backgroundcolor={yellow!15},linecolor={black!15}"
+                                ) ;!option
+                              ) ;!begin
+                              (trivlist (!append (item (!option (!append (color "rgb:black,10;red,9;green,4;yellow,2") 1)))
+                                          (mbox "")
+                                          (!group (!append (color "blue!50!black") (ensuremath 2)))
+                                        ) ;!append
+                              ) ;trivlist
+                             ) ;
+                     ((!begin "tmframed"
+                        (!option "skipabove=0,skipbelow=0,backgroundcolor=white,linewidth=0pt")
+                      ) ;!begin
+                      (trivlist (!append (item (!option "")) (mbox "") 3))
+                     ) ;
+                    ) ;!append
+  ) ;tmunfoldediomath
+  (tmfoldedio ((!begin "tmframed"
+                 (!option "skipabove=0,skipbelow=0,backgroundcolor={yellow!15},linecolor={black!15}"
+                 ) ;!option
+               ) ;!begin
+               (trivlist (!append (item (!option (!append (color "rgb:black,10;red,9;green,4;yellow,2") 1)))
+                           (mbox "")
+                           (!group (!append (color "blue!50!black") 2))
+                         ) ;!append
+               ) ;trivlist
+              ) ;
+  ) ;tmfoldedio
+  (tmunfoldedio (!append ((!begin "tmframed"
+                            (!option "skipabove=0,skipbelow=0,backgroundcolor={yellow!15},linecolor={black!15}"
+                            ) ;!option
+                          ) ;!begin
+                          (trivlist (!append (item (!option (!append (color "rgb:black,10;red,9;green,4;yellow,2") 1)))
+                                      (mbox "")
+                                      (!group (!append (color "blue!50!black") 2))
+                                    ) ;!append
+                          ) ;trivlist
+                         ) ;
+                 ((!begin "tmframed"
+                    (!option "skipabove=0,skipbelow=0,backgroundcolor=white,linewidth=0pt")
+                  ) ;!begin
+                  (trivlist (!append (item (!option "")) (mbox "") 3))
+                 ) ;
+                ) ;!append
+  ) ;tmunfoldedio
+) ;smart-table
diff --git a/TeXmacs/plugins/latex/progs/latex/convert-latex-symbol-drd.scm b/TeXmacs/plugins/latex/progs/latex/convert-latex-symbol-drd.scm
new file mode 100644
index 0000000000..a22337f2c4
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/convert-latex-symbol-drd.scm
@@ -0,0 +1,827 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : latex-symbol-drd.scm
+;; DESCRIPTION : LaTeX symbols supported by TeXmacs
+;; COPYRIGHT   : (C) 1999  Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex convert-latex-symbol-drd)
+  (:use (latex convert-latex-command-drd))
+) ;texmacs-module
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Basic symbols and big symbols
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-group latex-symbol%
+  ;; Greek letters
+  Gamma
+  Delta
+  Theta
+  Lambda
+  Xi
+  Pi
+  Sigma
+  Upsilon
+  Phi
+  Psi
+  Omega
+  varOmega
+  alpha
+  beta
+  gamma
+  delta
+  epsilon
+  varepsilon
+  zeta
+  eta
+  theta
+  vartheta
+  iota
+  kappa
+  lambda
+  mu
+  nu
+  omicron
+  xi
+  pi
+  varpi
+  rho
+  varrho
+  sigma
+  varsigma
+  tau
+  upsilon
+  phi
+  varphi
+  chi
+  psi
+  omega
+
+  ;; Binary operations
+  pm
+  mp
+  times
+  div
+  ast
+  star
+  circ
+  bullet
+  cdot
+  cap
+  cup
+  uplus
+  sqcap
+  sqcup
+  vee
+  wedge
+  setminus
+  wr
+  diamond
+  triangleleft
+  triangleright
+  land
+  lor
+  lnot
+  oplus
+  ominus
+  otimes
+  oslash
+  odot
+  bigcirc
+  amalg
+  notin
+
+  ;; Relations
+  leq
+  le
+  geq
+  ge
+  equiv
+  models
+  prec
+  succ
+  sim
+  perp
+  preceq
+  succeq
+  simeq
+  mid
+  ll
+  gg
+  asymp
+  parallel
+  subset
+  supset
+  approx
+  bowtie
+  subseteq
+  supseteq
+  cong
+  ne
+  neq
+  smile
+  sqsubseteq
+  sqsupseteq
+  doteq
+  frown
+  in
+  ni
+  propto
+  vdash
+  dashv
+
+  ;; Arrows
+  leftarrow
+  rightarrow
+  uparrow
+  downarrow
+  Leftarrow
+  Rightarrow
+  Uparrow
+  Downarrow
+  nearrow
+  searrow
+  swarrow
+  nwarrow
+  leftrightarrow
+  updownarrow
+  Updownarrow
+  Leftrightarrow
+  leftharpoonup
+  leftharpoondown
+  rightharpoonup
+  rightharpoondown
+  hookleftarrow
+  hookrightarrow
+  to
+  mapsto
+  longmapsto
+  longrightarrow
+  longleftarrow
+  longleftrightarrow
+  Longrightarrow
+  Longleftarrow
+  Longleftrightarrow
+
+  ;; Miscellaneous symbols
+  ldots
+  cdots
+  vdots
+  ddots
+  hdots
+  aleph
+  prime
+  forall
+  infty
+  hbar
+  emptyset
+  exists
+  nabla
+  surd
+  triangle
+  imath
+  jmath
+  ell
+  neg
+  top
+  flat
+  natural
+  sharp
+  wp
+  bot
+  clubsuit
+  diamondsuit
+  heartsuit
+  spadesuit
+  Re
+  Im
+  angle
+  partial
+  textbackslash
+  dag
+  ddag
+  dagger
+  ddagger
+  guillemotleft
+  guillemotright
+
+  ;; Delimiters
+  uparrow
+  Uparrow
+  downarrow
+  Downarrow
+  updownarrow
+  Updownarrow
+  lfloor
+  rfloor
+  lceil
+  rceil
+  langle
+  rangle
+  backslash
+
+  ;; Big delimiters
+  rmoustache
+  lmoustache
+  rgroup
+  lgroup
+  lbrack
+  rbrack
+  lbrace
+  rbrace
+  arrowvert
+  Arrowvert
+  bracevert
+) ;logic-group
+
+(logic-group latex-big-symbol% sum prod coprod bignone bigtimes bigoplus
+  bigotimes bigodot bigvee bigwedge bigsqcup bigcup bigcap bigpluscup
+  bigtriangledown bigtriangleup int iint iiint iiiint idotsint bigint bigiint
+  bigiiint bigiiiint bigidotsint upint upiint upiiint upiiiint upidotsint
+  bigupint bigupiint bigupiiint bigupiiiint bigupidotsint oint oiint oiiint
+  bigoint bigoiint bigoiiint upoint upoiint upoiiint bigupoint bigupoiint
+  bigupoiiint intwl iintwl iiintwl iiiintwl idotsintwl bigintwl bigiintwl
+  bigiiintwl bigiiiintwl bigidotsintwl upintwl upiintwl upiiintwl upiiiintwl
+  upidotsintwl bigupintwl bigupiintwl bigupiiintwl bigupiiiintwl bigupidotsintwl
+  ointwl oiintwl oiiintwl bigointwl bigoiintwl bigoiiintwl upointwl upoiintwl
+  upoiiintwl bigupointwl bigupoiintwl bigupoiiintwl
+) ;logic-group
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Symbols from latexsym package
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-group latex-latexsym-symbol% mho Join Box Diamond leadsto sqsubset
+  sqsupset lhd rhd unlhd unrhd
+) ;logic-group
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Symbols from amssymb package
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-group latex-ams-symbol%
+  ;; `
+  ;; Box sqsubset sqsupset lhd unlhd rhd unrhd
+  Bbbk
+  Bumpeq
+  Cap
+  Cup
+  Finv
+  Game
+  Lleftarrow
+  Lsh
+  Rrightarrow
+  Rsh
+  Subset
+  Supset
+  Vdash
+  Vvdash
+  angle
+  approxeq
+  backepsilon
+  backprime
+  backsim
+  backsimeq
+  barwedge
+  because
+  beth
+  between
+  bigstar
+  blacklozenge
+  blacksquare
+  blacktriangle
+  blacktriangledown
+  blacktriangleleft
+  blacktriangleright
+  box
+  boxdot
+  boxminus
+  boxplus
+  boxtimes
+  bumpeq
+  centerdot
+  checkmark
+  circeq
+  circlearrowleft
+  circlearrowright
+  circledR
+  circledS
+  circledast
+  circledcirc
+  circleddash
+  complement
+  curlyeqprec
+  curlyeqsucc
+  curlyvee
+  curlywedge
+  curvearrowleft
+  curvearrowright
+  daleth
+  diagdown
+  diagup
+  digamma
+  divideontimes
+  doteqdot
+  dotplus
+  doublebarwedge
+  downdownarrows
+  downharpoonleft
+  downharpoonright
+  eqcirc
+  eqsim
+  eqslantgtr
+  eqslantless
+  eth
+  fallingdotseq
+  frown
+  geqq
+  geqslant
+  ggg
+  gimel
+  gnapprox
+  gneq
+  gneqq
+  gnsim
+  gtrapprox
+  gtrdot
+  gtreqless
+  gtreqqless
+  gtrless
+  gtrsim
+  gvertneqq
+  hslash
+  intercal
+  leftarrowtail
+  leftleftarrows
+  leftrightarrows
+  leftrightharpoons
+  leftrightsquigarrow
+  leftthreetimes
+  leqq
+  leqslant
+  lessapprox
+  lessdot
+  lesseqgtr
+  lesseqqgtr
+  lessgtr
+  lesssim
+  llcorner
+  lll
+  lnapprox
+  lneq
+  lneqq
+  lnsim
+  looparrowleft
+  looparrowright
+  lozenge
+  lrcorner
+  ltimes
+  lvert
+  lVert
+  lvertneqq
+  maltese
+  measuredangle
+  models
+  multimap
+  nLeftarrow
+  nLeftrightarrow
+  nRightarrow
+  nVDash
+  nVdash
+  ncong
+  nexists
+  ngeq
+  ngeqq
+  ngeqslant
+  ngtr
+  nleftarrow
+  nleftrightarrow
+  nleq
+  nleqq
+  nleqslant
+  nless
+  nmid
+  nparallel
+  nprec
+  npreceq
+  nrightarrow
+  nshortmid
+  nshortparallel
+  nsim
+  nsubseteq
+  nsubseteqq
+  nsucc
+  nsucceq
+  nsupseteq
+  nsupseteqq
+  ntriangleleft
+  ntrianglelefteq
+  ntriangleright
+  ntrianglerighteq
+  nvDash
+  nvdash
+  pitchfork
+  precapprox
+  preccurlyeq
+  precnapprox
+  precneqq
+  precnsim
+  precsim
+  propto
+  rhd
+  rightarrowtail
+  rightleftarrows
+  rightleftharpoons
+  rightrightarrows
+  rightsquigarrow
+  rightthreetimes
+  risingdotseq
+  rtimes
+  rvert
+  rVert
+  shortleftarrow
+  shortmid
+  shortparallel
+  shortrightarrow
+  smalldash
+  smallfrown
+  smallsetminus
+  smallsmile
+  smile
+  sphericalangle
+  subseteqq
+  subsetneq
+  subsetneqq
+  succapprox
+  succcurlyeq
+  succnapprox
+  succneqq
+  succnsim
+  succsim
+  supseteqq
+  supsetneq
+  supsetneqq
+  therefore
+  thickapprox
+  thicksim
+  triangle
+  triangledown
+  trianglelefteq
+  triangleq
+  trianglerighteq
+  twoheadleftarrow
+  twoheadrightarrow
+  ulcorner
+  upharpoonleft
+  upharpoonright
+  upuparrows
+  urcorner
+  vDash
+  varkappa
+  varnothing
+  varpropto
+  varsubsetneq
+  varsubsetneqq
+  varsupsetneq
+  varsupsetneqq
+  vartriangle
+  vartriangleleft
+  vartriangleright
+  veebar
+  yen
+) ;logic-group
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Symbols from wasysym package
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-group latex-wasy-symbol%
+  agemO
+  APLbox
+  APLcomment
+  APLdownarrowbox
+  APLdown
+  APLinput
+  APLleftarrowbox
+  APLrightarrowbox
+  APLstar
+  APLuparrowbox
+  APLup
+  apprge
+  apprle
+  aquarius
+  ascnode
+  ataribox
+  bell
+  blacksmiley
+  Bowtie
+  brokenvert
+  cancer
+  capricornus
+  cent
+  checked
+  CIRCLE
+  Circle
+  clock
+  conjunction
+  currency
+  davidsstar
+  descnode
+  dh
+  diameter
+  DOWNarrow
+  eighthnote
+  female
+  frownie
+  fullnote
+  gemini
+  halfnote
+  hexagon
+  hexstar
+  invdiameter
+  inve
+  invneg
+  jupiter
+  kreuz
+  LEFTarrow
+  LEFTCIRCLE
+  Leftcircle
+  leftmoon
+  leftturn
+  libra
+  logof
+  male
+  mercury
+  neptune
+  octagon
+  openo
+  opposition
+  pentagon
+  permil
+  phone
+  pisces
+  pluto
+  pointer
+  quarternote
+  recorder
+  RIGHTarrow
+  RIGHTCIRCLE
+  Rightcircle
+  rightmoon
+  rightturn
+  sagittarius
+  saturn
+  scorpio
+  smiley
+  square
+  sun
+  taurus
+  Thorn
+  thorn
+  twonotes
+  UParrow
+  uranus
+  varangle
+  varhexagon
+  varhexstar
+  varlightning
+  vernal
+  VHF
+  virgo
+  ;; wasy-38 wasy-58 wasy-80 wasy-81 wasy-82
+  wasyBox
+  wasyDiamond
+  wasyleadsto
+  wasylhd
+  wasylozenge
+  wasypropto
+  wasyrhd
+  wasysqsubset
+  wasysqsupset
+  wasytherefore
+  wasyunlhd
+  wasyunrhd
+  XBox
+) ;logic-group
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Symbols from stmaryrd package
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-group latex-stmary-symbol%
+  Arrownot
+  arrownot
+  baro
+  bbslash
+  binampersand
+  bindnasrepma
+  boxast
+  boxbar
+  boxbox
+  boxbslash
+  boxcircle
+  ;; boxdot
+  boxempty
+  boxslash
+  curlyveedownarrow
+  curlyveeuparrow
+  curlywedgedownarrow
+  curlywedgeuparrow
+  fatbslash
+  fatsemi
+  fatslash
+  inplus
+  interleave
+  large-llbracket
+  large-rrbracket
+  Lbag
+  lbag
+  leftarrowtriangle
+  leftrightarroweq
+  leftrightarrowtriangle
+  leftslice
+  lightning
+  llbracket
+  llceil
+  llfloor
+  llparenthesis
+  Mapsfromchar
+  mapsfromchar
+  Mapstochar
+  merge
+  minuso
+  moo
+  niplus
+  nnearrow
+  nnwarrow
+  nplus
+  ntrianglelefteqslant
+  ntrianglerighteqslant
+  obar
+  oblong
+  obslash
+  ogreaterthan
+  olessthan
+  ovee
+  owedge
+  Rbag
+  rbag
+  rightarrowtriangle
+  rightslice
+  rrbracket
+  rrceil
+  rrfloor
+  rrparenthesis
+  shortdownarrow
+  shortleftarrow
+  shortrightarrow
+  shortuparrow
+  ssearrow
+  sslash
+  sswarrow
+  subsetpluseq
+  subsetplus
+  supsetpluseq
+  supsetplus
+  talloblong
+  trianglelefteqslant
+  trianglerighteqslant
+  varbigcirc
+  varcurlyvee
+  varcurlywedge
+  varoast
+  varobar
+  varobslash
+  varocircle
+  varodot
+  varogreaterthan
+  varolessthan
+  varominus
+  varoplus
+  varoslash
+  varotimes
+  varovee
+  varowedge
+  vartimes
+  Ydown
+  Yleft
+  Yright
+  Yup
+) ;logic-group
+
+(logic-group latex-stmary-big-symbol% bigbox bigcurlyvee bigcurlywedge
+  biginterleave bignplus bigparallel bigsqcap
+) ;logic-group
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Symbols from mathabx package
+;; NOTE: we avoid using the mathabx package because it tends
+;; to be badly installed and incompatible with certain styles
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; (logic-group latex-mathabx-symbol%
+;;  divides ndivides npreccurlyeq asterisk
+;;  dottimes nequiv precdot)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Symbols from textcomp package
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-group latex-textcomp-symbol% textcent textcurrency textyen textbrokenbar
+  textasciidieresis textlnot textasciimacron textdegree degree textpm
+  texttwosuperior textthreesuperior textasciiacute textmu textonesuperior
+  textonequarter textonehalf textthreequarters texttimes textdiv
+) ;logic-group
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Symbols from upgreek package
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-group latex-upgreek-symbol%
+  upalpha
+  upbeta
+  upgamma
+  updelta
+  upepsilon
+  upvarepsilon
+  upzeta
+  upeta
+  uptheta
+  upvartheta
+  upiota
+  upkappa
+  uplambda
+  upmu
+  upnu
+  upomicron
+  upxi
+  uppi
+  upvarpi
+  uprho
+  upvarrho
+  upsigma
+  upvarsigma
+  uptau
+  upupsilon
+  upphi
+  upvarphi
+  upchi
+  uppsi
+  upomega
+
+  Upalpha
+  Upbeta
+  Upgamma
+  Updelta
+  Upepsilon
+  Upzeta
+  Upeta
+  Uptheta
+  Upiota
+  Upkappa
+  Uplambda
+  Upmu
+  Upnu
+  Upomicron
+  Upxi
+  Uppi
+  Uprho
+  Upsigma
+  Uptau
+  Upupsilon
+  Upphi
+  Upchi
+  Uppsi
+  Upomega
+) ;logic-group
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Rules
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-rules ((latex-arity% 'x 0) (latex-symbol% 'x))
+ ((latex-arity% 'x 0) (latex-big-symbol% 'x))
+ ((latex-symbol% 'x) (latex-latexsym-symbol% 'x))
+ ((latex-needs% 'x "latexsym") (latex-latexsym-symbol% 'x))
+ ((latex-symbol% 'x) (latex-ams-symbol% 'x))
+ ((latex-needs% 'x "amssymb") (latex-ams-symbol% 'x))
+ ((latex-symbol% 'x) (latex-wasy-symbol% 'x))
+ ((latex-needs% 'x "wasysym") (latex-wasy-symbol% 'x))
+ ((latex-symbol% 'x) (latex-stmary-symbol% 'x))
+ ((latex-needs% 'x "stmaryrd") (latex-stmary-symbol% 'x))
+ ((latex-big-symbol% 'x) (latex-stmary-big-symbol% 'x))
+ ((latex-needs% 'x "stmaryrd") (latex-stmary-big-symbol% 'x))
+ ;; ((latex-symbol% 'x) (latex-mathabx-symbol% 'x))
+ ;; ((latex-needs% 'x "mathabx") (latex-mathabx-symbol% 'x))
+ ((latex-symbol% 'x) (latex-textcomp-symbol% 'x))
+ ((latex-needs% 'x "textcomp") (latex-textcomp-symbol% 'x))
+ ((latex-symbol% 'x) (latex-upgreek-symbol% 'x))
+ ((latex-needs% 'x "upgreek") (latex-upgreek-symbol% 'x))
+) ;logic-rules
diff --git a/TeXmacs/plugins/latex/progs/latex/convert-latex-texmacs-drd.scm b/TeXmacs/plugins/latex/progs/latex/convert-latex-texmacs-drd.scm
new file mode 100644
index 0000000000..f247e8d621
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/convert-latex-texmacs-drd.scm
@@ -0,0 +1,616 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : latex-texmacs-drd.scm
+;; DESCRIPTION : TeXmacs extensions to LaTeX
+;; COPYRIGHT   : (C) 2005  Joris van der Hoeven
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex convert-latex-texmacs-drd)
+  (:use (latex convert-latex-symbol-drd))
+) ;texmacs-module
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Extra TeXmacs symbols
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-group latex-texmacs-symbol%
+  ;; arrows and other symbols with limits
+  leftarrowlim
+  rightarrowlim
+  leftrightarrowlim
+  mapstolim
+  longleftarrowlim
+  longrightarrowlim
+  longleftrightarrowlim
+  longmapstolim
+  leftsquigarrowlim
+  rightsquigarrowlim
+  leftrightsquigarrowlim
+  equallim
+  longequallim
+  Leftarrowlim
+  Rightarrowlim
+  Leftrightarrowlim
+  Longleftarrowlim
+  Longrightarrowlim
+  Longleftrightarrowlim
+  cdotslim
+
+  ;; further arrows
+  threeleftarrows
+  threerightarrows
+  fourleftarrows
+  fourrightarrows
+  longleftrightarrows
+  longleftleftarrows
+  longthreeleftarrows
+  longthreerightarrows
+  longrightleftarrows
+  longrightrightarrows
+  longfourleftarrows
+  longfourrightarrows
+  LRleftrightarrow
+  Llongleftarrow
+  Llongrightarrow
+  Llongleftrightarrow
+
+  ;; rotated arrows and other symbols
+  mapsfrom
+  longmapsfrom
+  mapmulti
+  leftsquigarrow
+  upequal
+  downequal
+  longupequal
+  longdownequal
+  longupminus
+  longdownminus
+  longuparrow
+  longdownarrow
+  longupdownarrow
+  Longuparrow
+  Longdownarrow
+  Longupdownarrow
+  mapsup
+  mapsdown
+  longmapsup
+  longmapsdown
+  upsquigarrow
+  downsquigarrow
+  updownsquigarrow
+  hookuparrow
+  hookdownarrow
+  longhookuparrow
+  longhookdownarrow
+  Backepsilon
+  Backsigma
+  Mho
+  btimes
+
+  ;; asymptotic relations by Joris
+  nasymp
+  asympasymp
+  nasympasymp
+  simsim
+  nsimsim
+  precprec
+  precpreceq
+  precprecprec
+  precprecpreceq
+  succsucc
+  succsucceq
+  succsuccsucc
+  succsuccsucceq
+  lleq
+  llleq
+  ggeq
+  gggeq
+  triplesim
+  ntriplesim
+
+  ;; replacements for symbols from mathabx
+  divides
+  ndivides
+  asterisk
+  dottimes
+  precdot
+
+  ;; extra literal symbols
+  mathcatalan
+  mathd
+  mathD
+  mathe
+  matheuler
+  mathGamma
+  mathlambda
+  mathLaplace
+  mathi
+  mathpi
+  Alpha
+  Beta
+  Epsilon
+  Eta
+  Iota
+  Kappa
+  Mu
+  Nu
+  Omicron
+  Chi
+  Rho
+  Tau
+  Zeta
+
+  ;; negations
+  nin
+  nni
+  notni
+  nequiv
+  nleadsto
+  npreccurlyeq
+  npreceqq
+  nprecsim
+  nsimeq
+  nsubset
+  napprox
+  nsqsubset
+  nsqsubseteq
+  nsqsubseteqq
+  nsqsupset
+  nsqsupseteq
+  nsqsupseteqq
+  nsucccurlyeq
+  nsucceqq
+  nsuccsim
+
+  ;; other extra symbols
+  oempty
+  exterior
+  Exists
+  bigintwl
+  bigointwl
+  of
+  suchthat
+  barsuchthat
+  asterisk
+  point
+  cdummy
+  comma
+  copyright
+  bignone
+  nobracket
+  nospace
+  nocomma
+  noplus
+  nosymbol
+  dotminus
+  dotpm
+  dotmp
+  dotamalg
+  dottimes
+  dotoplus
+  dototimes
+  dotast
+  into
+  longminus
+  longequal
+  longhookrightarrow
+  longhookleftarrow
+  triangleup
+  tmprecdot
+  preceqdot
+  llangle
+  rrangle
+  join
+  um
+  upl
+  upm
+  ump
+  pplus
+  assign
+  plusassign
+  minusassign
+  timesassign
+  overassign
+  backassign
+  lflux
+  gflux
+  colons
+  transtype
+  lebar
+  gebar
+  leangle
+  geangle
+  leqangle
+  geqangle
+  anglele
+  anglege
+  legeangle
+  geleangle
+  udots
+  subsetsim
+  supsetsim
+  rightmap
+  leftmap
+  leftrightmap
+  tmxspace
+) ;logic-group
+
+(logic-rules ((latex-texmacs-arity% 'x 0) (latex-texmacs-symbol% 'x))
+ ((latex-symbol% 'x) (latex-texmacs-symbol% 'x))
+) ;logic-rules
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Extra TeXmacs macros
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-group latex-texmacs-0% tmunsc emdash tmhrule tmat tmbsl tmdummy TeXmacs
+  madebyTeXmacs withTeXmacstext citewebsite tmmade scheme tmsep tmSep pari qed
+  textdots hrule filldots infixand infixor infixiff
+) ;logic-group
+
+(logic-group latex-texmacs-1%
+  three-line-table
+  key
+  tmrsub
+  tmrsup
+  keepcase
+  tmtextrm
+  tmtextsf
+  tmtexttt
+  tmtextmd
+  tmtextbf
+  tmtextup
+  tmtextsl
+  tmtextit
+  tmtextsc
+  tmmathbf
+  tmmathmd
+  tmverbatim
+  tmop
+  tmstrong
+  tmem
+  tmtt
+  tmname
+  tmsamp
+  tmabbr
+  tmdfn
+  tmkbd
+  tmvar
+  tmacronym
+  tmperson
+  tmscript
+  tmdef
+  dueto
+  op
+  todo
+  tmdate
+  tmoutput
+  tmerrput
+  tmtiming
+  tmsubtitle
+  tmrunningtitle
+  tmrunningauthor
+  tmaffiliation
+  tmemail
+  tmhomepage
+  tmfnaffiliation
+  tmfnemail
+  tmfnhomepage
+  tmacmhomepage
+  tmacmmisc
+  tmieeeemail
+  tmnote
+  tmmisc
+  uhat
+  uwidehat
+  utilde
+  uwidetilde
+  uvec
+  ubreve
+  uinvbreve
+  ucheck
+  uring
+  uacute
+  ugrave
+  underdot
+  uddot
+  udddot
+  uddddot
+  widespacing
+  nonconverted
+  groupcommoncounter
+  ;; NOTE: for personal use from vdh style package
+  gb
+  gbt
+) ;logic-group
+
+(logic-group latex-texmacs-1*% tmcodeinline)
+
+(logic-group latex-texmacs-2% tmcolor tmsummarizeddocumentation
+  tmsummarizedgrouped tmsummarizedexplain tmsummarizedplain tmsummarizedtiny
+  tmsummarizedraw tmsummarizedenv tmsummarizedstd tmsummarized
+  tmdetaileddocumentation tmdetailedgrouped tmdetailedexplain tmdetailedplain
+  tmdetailedtiny tmdetailedraw tmdetailedenv tmdetailedstd tmdetailed
+  tmfoldeddocumentation tmunfoldeddocumentation tmfoldedsubsession
+  tmunfoldedsubsession tmfoldedgrouped tmunfoldedgrouped tmfoldedexplain
+  tmunfoldedexplain tmfoldedplain tmunfoldedplain tmfoldedenv tmunfoldedenv
+  tmfoldedstd tmunfoldedstd tmfolded tmunfolded tminput tminputmath tmhlink
+  tmaction ontop subindex renderfootnote tmlinenumber addtocountergroup
+) ;logic-group
+
+(logic-group latex-texmacs-3% tmsession tmfoldedio tmunfoldedio tmfoldediomath
+  tmunfoldediomath tmlinenote subsubindex tmref glossaryentry natbib-triple
+  renderfootnotestar
+) ;logic-group
+
+(logic-group latex-texmacs-4% tmscriptinput tmscriptoutput tmconverterinput
+  tmconverteroutput subsubsubindex
+) ;logic-group
+
+(logic-rules ((latex-texmacs% 'x) (latex-texmacs-0% 'x))
+ ((latex-texmacs% 'x) (latex-texmacs-1% 'x))
+ ((latex-texmacs% 'x) (latex-texmacs-1*% 'x))
+ ((latex-texmacs% 'x) (latex-texmacs-2% 'x))
+ ((latex-texmacs% 'x) (latex-texmacs-3% 'x))
+ ((latex-texmacs% 'x) (latex-texmacs-4% 'x))
+ ((latex-texmacs-arity% 'x 0) (latex-texmacs-0% 'x))
+ ((latex-texmacs-arity% 'x 1) (latex-texmacs-1% 'x))
+ ((latex-texmacs-arity% 'x 1) (latex-texmacs-1*% 'x))
+ ((latex-texmacs-arity% 'x 2) (latex-texmacs-2% 'x))
+ ((latex-texmacs-arity% 'x 3) (latex-texmacs-3% 'x))
+ ((latex-texmacs-arity% 'x 4) (latex-texmacs-4% 'x))
+ ((latex-texmacs-option% 'x #t) (latex-texmacs-1*% 'x))
+ ((latex-command-0% 'x) (latex-texmacs-0% 'x))
+ ((latex-command-1% 'x) (latex-texmacs-1% 'x))
+ ((latex-command-1*% 'x) (latex-texmacs-1*% 'x))
+ ((latex-command-2% 'x) (latex-texmacs-2% 'x))
+ ((latex-command-3% 'x) (latex-texmacs-3% 'x))
+ ((latex-command-4% 'x) (latex-texmacs-4% 'x))
+) ;logic-rules
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Extra TeXmacs environments
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-table latex-texmacs-env-arity%
+ ("proof" 0)
+ ("proof*" 1)
+ ("leftaligned" 0)
+ ("rightaligned" 0)
+ ("tmcode" 0)
+ ("tmparmod" 3)
+ ("tmparsep" 1)
+ ("tmcompact" 0)
+ ("tmcompressed" 0)
+ ("tmamplified" 0)
+ ("tmjumpin" 0)
+ ("tmindent" 0)
+ ("tmlisting" 0)
+ ("elsequation" 0)
+ ("elsequation*" 0)
+ ("theglossary" 1)
+) ;logic-table
+
+(logic-table latex-texmacs-option% ("tmcode" #t))
+
+(logic-group latex-texmacs-environment-0% begin-proof begin-leftaligned
+  begin-rightaligned begin-quoteenv begin-tmcompact begin-tmcompressed
+  begin-tmamplified begin-tmjumpin begin-tmindent begin-tmlisting
+  begin-elsequation begin-elsequation*
+) ;logic-group
+
+(logic-group latex-texmacs-environment-0*% begin-tmcode)
+
+(logic-group latex-texmacs-environment-1% begin-proof* begin-tmparsep
+  begin-theglossary
+) ;logic-group
+
+(logic-group latex-texmacs-environment-3% begin-tmparmod)
+
+(logic-rules ((latex-texmacs-arity% 'x 0) (latex-texmacs-environment-0% 'x))
+ ((latex-texmacs-arity% 'x 0) (latex-texmacs-environment-0*% 'x))
+ ((latex-texmacs-arity% 'x 1) (latex-texmacs-environment-1% 'x))
+ ((latex-texmacs-arity% 'x 3) (latex-texmacs-environment-3% 'x))
+ ((latex-texmacs-option% 'x #t) (latex-texmacs-environment-0*% 'x))
+ ((latex-environment-0% 'x) (latex-texmacs-environment-0% 'x))
+ ((latex-environment-0*% 'x) (latex-texmacs-environment-0*% 'x))
+ ((latex-environment-1% 'x) (latex-texmacs-environment-1% 'x))
+ ((latex-environment-3% 'x) (latex-texmacs-environment-3% 'x))
+) ;logic-rules
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; TeXmacs list environments
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-table latex-texmacs-env-arity%
+ ("itemizeminus" 0)
+ ("itemizedot" 0)
+ ("itemizearrow" 0)
+ ("enumeratenumeric" 0)
+ ("enumeratenumericbracket" 0)
+ ("enumerateroman" 0)
+ ("enumerateromanbracket" 0)
+ ("enumerateromanparen" 0)
+ ("enumerateromancap" 0)
+ ("enumeratealpha" 0)
+ ("enumeratealphabracket" 0)
+ ("enumeratealphafullparen" 0)
+ ("enumeratealphacap" 0)
+ ("descriptioncompact" 0)
+ ("descriptionaligned" 0)
+ ("descriptiondash" 0)
+ ("descriptionlong" 0)
+ ("descriptionparagraphs" 0)
+) ;logic-table
+
+(logic-group latex-texmacs-list% begin-itemizeminus begin-itemizedot
+  begin-itemizearrow begin-enumeratenumeric begin-enumeratenumericbracket
+  begin-enumerateroman begin-enumerateromanbracket begin-enumerateromanparen
+  begin-enumerateromancap begin-enumeratealpha begin-enumeratealphabracket
+  begin-enumeratealphafullparen begin-enumeratealphacap begin-descriptioncompact
+  begin-descriptionaligned begin-descriptiondash begin-descriptionlong
+  begin-descriptionparagraphs
+) ;logic-group
+
+(logic-rules ((latex-texmacs-arity% 'x 0) (latex-texmacs-list% 'x))
+ ((latex-list% 'x) (latex-texmacs-list% 'x))
+) ;logic-rules
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Commands requiring special definitions in the preamble
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-group latex-texmacs-preamble-command%
+  newmdenv
+  tikzframe
+  tmkeywords
+  tmacm
+  tmarxiv
+  tmpacs
+  tmmsc
+  fmtext
+  tdatetext
+  tmisctext
+  tsubtitletext
+  thankshomepage
+  thanksemail
+  thanksdate
+  thanksamisc
+  thanksmisc
+  thankssubtitle
+  mho
+  tmfloat
+
+  xminus
+  xleftrightarrow
+  xmapsto
+  xmapsfrom
+  xequal
+  xLeftarrow
+  xRightarrow
+  xLeftrightarrow
+) ;logic-group
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Environments requiring special definitions in the preamble
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-group latex-texmacs-env-preamble-environment% "tmpadded" "tmoverlined"
+  "tmunderlined" "tmbothlined" "tmframed" "tmornamented"
+) ;logic-group
+
+(logic-group latex-texmacs-theorem-environment%
+  "theorem"
+  "proposition"
+  "lemma"
+  "corollary"
+  "axiom"
+  "definition"
+  "assumption"
+  "notation"
+  "conjecture"
+  "remark"
+  "note"
+  "example"
+  "convention"
+  "warning"
+  "acknowledgments"
+  "answer"
+  "question"
+  "exercise"
+  "problem"
+  "solution"
+
+  "theorem*"
+  "proposition*"
+  "lemma*"
+  "corollary*"
+  "axiom*"
+  "definition*"
+  "notation*"
+  "conjecture*"
+  "remark*"
+  "note*"
+  "example*"
+  "convention*"
+  "warning*"
+  "acknowledgments*"
+  "answer*"
+  "question*"
+  "exercise*"
+  "problem*"
+  "solution*"
+) ;logic-group
+
+(logic-group latex-texmacs-theorem%
+  begin-theorem
+  begin-proposition
+  begin-lemma
+  begin-corollary
+  begin-axiom
+  begin-definition
+  begin-notation
+  begin-conjecture
+  begin-remark
+  begin-note
+  begin-example
+  begin-convention
+  begin-warning
+  begin-acknowledgments
+  begin-answer
+  begin-question
+  begin-exercise
+  begin-problem
+  begin-solution
+
+  begin-theorem*
+  begin-proposition*
+  begin-lemma*
+  begin-corollary*
+  begin-axiom*
+  begin-definition*
+  begin-notation*
+  begin-conjecture*
+  begin-remark*
+  begin-note*
+  begin-example*
+  begin-convention*
+  begin-warning*
+  begin-acknowledgments*
+  begin-answer*
+  begin-question*
+  begin-exercise*
+  begin-problem*
+  begin-solution*
+) ;logic-group
+
+(logic-rules ((latex-texmacs-env-preamble-environment% 'x)
+              (latex-texmacs-theorem-environment% 'x)
+             ) ;
+ ((latex-texmacs-arity% 'x 0) (latex-texmacs-theorem% 'x))
+ ((latex-environment-0% 'x) (latex-texmacs-theorem% 'x))
+) ;logic-rules
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; These macros are defined by TeXmacs in certain styles
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-group latex-texmacs-0% appendix)
+
+(logic-group latex-texmacs-1% chapter section subsection paragraph subparagraph)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Deprecated extra macros
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-group latex-texmacs-0% labeleqnum eqnumber leqnumber reqnumber)
+
+(logic-group latex-texmacs-1% skey ckey akey mkey hkey)
diff --git a/TeXmacs/plugins/latex/progs/latex/convert-latex-texout.scm b/TeXmacs/plugins/latex/progs/latex/convert-latex-texout.scm
new file mode 100644
index 0000000000..17d8c623e9
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/convert-latex-texout.scm
@@ -0,0 +1,583 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : texout.scm
+;; DESCRIPTION : generation of TeX/LaTeX from scheme expressions
+;; COPYRIGHT   : (C) 2002  Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex convert-latex-texout)
+  (:use (latex convert-latex-tools) (convert tools output))
+) ;texmacs-module
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Make environment names acceptable
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tex-env-name s) (if (string? s) (string-replace s "-" "") s))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Interface for unicode output
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (output-tex s)
+  (output-text s)
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Outputting preamble and postamble
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (collection->ahash-table init)
+  (let* ((t (make-ahash-table))
+         (l (if (func? init 'collection) (cdr init) '()))
+         (f (lambda (x) (ahash-set! t (cadr x) (caddr x))))
+        ) ;
+    (for-each f l)
+    t
+  ) ;let*
+) ;define
+
+(define (drop-blank s)
+  (string-replace s " " "")
+) ;define
+
+(define (latex-stree-contains? t u)
+  (cond ((== t u) #t)
+        ((and (string? t) (string? u)) (string-contains? t (drop-blank u)))
+        ((nlist? t) #f)
+        ((null? t) #f)
+        (else (or (latex-stree-contains? (car t) u)
+                (in? #t (map (lambda (x) (latex-stree-contains? x u)) (cdr t)))
+              ) ;or
+        ) ;else
+  ) ;cond
+) ;define
+
+(define (attached_macro? t)
+  (and (func? t '!concat 4)
+    (== (cadr t) '(!preamble "%%%%%%%%%% Start TeXmacs macros\n"))
+  ) ;and
+) ;define
+
+(define (detach-macros t)
+  (cond ((attached_macro? t) (fifth t))
+        ((list>0? t) (map-in-order detach-macros t))
+        (else t)
+  ) ;cond
+) ;define
+
+(define (texout-file l)
+  (let* ((doc-body (car l))
+         (has-preamble? (latex-stree-contains? doc-body "\\begin{document}"))
+         (has-end? (latex-stree-contains? doc-body "\\end{document}"))
+         (styles (if (null? (cadr l)) (list "article") (cadr l)))
+         (style (car styles))
+         (style* (if (nlist? style) style (cAr style)))
+         (needs (caddr l))
+         (prelan (car needs))
+         (colors (cadr needs))
+         (colormaps (caddr needs))
+         (lan (if (== prelan "") "english" prelan))
+         (init (collection->ahash-table (cadddr l)))
+         (doc-preamble (car (cddddr l)))
+         (doc-misc (append '(!concat) doc-preamble (list doc-body)))
+         (doc-src (cdr (cddddr l)))
+         (post-begin "")
+         (pre-end "")
+        ) ;
+
+    (if (not has-preamble?)
+      (begin
+        (set! doc-body (detach-macros doc-body))
+        (receive (tm-style-options tm-uses tm-init tm-preamble)
+          (latex-preamble doc-misc style lan init colors colormaps)
+          (output-verbatim "\\documentclass")
+          (output-verbatim tm-style-options)
+          (if (== (cAr lan) "chinese")
+            (output-verbatim "[UTF8]{ctexart}\n")
+            (output-verbatim "{" style* "}\n")
+          ) ;if
+          (with main-lang
+            (cAr lan)
+            (cond ((== main-lang "korean") (output-verbatim "\\usepackage{hangul}\n"))
+                  ((in? main-lang '("chinese" "chineset" "japanese"))
+                   (with opt
+                     (cond ((== main-lang "japanese") "{min}")
+                           ((== main-lang "chineset") "{bsmi}")
+                           ((== main-lang "chinese") "{gbsn}")
+                     ) ;cond
+                     '()
+                   ) ;with
+                  ) ;
+                  (else (with langs
+                          (apply string-append (list-intersperse lan ", "))
+                          (output-verbatim "\\usepackage[" langs "]{babel}\n")
+                        ) ;with
+                    (if tmtex-use-unicode? (output-verbatim "\\usepackage[utf8]{inputenc}\n"))
+                  ) ;else
+            ) ;cond
+          ) ;with
+          (when (and (string? style*)
+                  (or (string-starts? style* "acm") (string-starts? style* "sig"))
+                  (string? tm-uses)
+                  (string-occurs? "amssymb" tm-uses)
+                ) ;and
+            (output-verbatim "\\let\\Bbbk\\relax\n")
+          ) ;when
+          (output-verbatim tm-uses)
+          (if (string-occurs? "makeidx" (latex-use-package-command doc-body))
+            (output-verbatim "\\makeindex\n")
+          ) ;if
+          (output-verbatim tm-init)
+
+          (if (!= tm-preamble "")
+            (begin
+              (output-lf)
+              (output-verbatim "%%%%%%%%%% Start TeXmacs macros\n")
+              (output-verbatim tm-preamble)
+              (output-verbatim "%%%%%%%%%% End TeXmacs macros\n")
+            ) ;begin
+          ) ;if
+          (if (nnull? doc-preamble)
+            (begin
+              (output-lf)
+              (map-in-order (lambda (x) (texout x) (output-lf)) doc-preamble)
+            ) ;begin
+          ) ;if
+        ) ;receive
+
+        (output-lf)
+        (output-tex "\\begin{document}")
+        (output-lf)
+        (output-tex post-begin)
+        (output-lf)
+      ) ;begin
+    ) ;if
+    (texout doc-body)
+    (if (not has-end?)
+      (begin
+        (output-lf)
+        (output-tex pre-end)
+        (output-lf)
+        (output-tex "\\end{document}")
+        (output-lf)
+      ) ;begin
+    ) ;if
+    (if (nnull? doc-src) (texout (car doc-src)))
+  ) ;let*
+) ;define
+
+(define (texout-usepackage x)
+  (output-verbatim "\\usepackage{" x "}\n")
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Outputting main flow
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (texout-comment l)
+  (set-output-comment #t)
+  (output-tex "% ")
+  (texout l)
+  (set-output-comment #f)
+  (output-lf)
+) ;tm-define
+
+(tm-define (texout-preamble l) (output-verbatim l))
+
+(define (empty-line? x)
+  (or (== x "")
+    (func? x '!marker)
+    (and (func? x '!concat) (list-and (map empty-line? (cdr x))))
+  ) ;or
+) ;define
+
+(tm-define (texout-document l)
+  (if (nnull? l)
+    (begin
+      (texout (car l))
+      (if (empty-line? (car l)) (output-tex "\\ "))
+      (if (nnull? (cdr l)) (begin (output-lf) (output-lf)))
+      (texout-document (cdr l))
+    ) ;begin
+  ) ;if
+) ;tm-define
+
+(define (texout-paragraph l)
+  (if (nnull? l)
+    (begin
+      (texout (car l))
+      (if (nnull? (cdr l)) (output-lf))
+      (texout-paragraph (cdr l))
+    ) ;begin
+  ) ;if
+) ;define
+
+(define (texout-table l)
+  (if (nnull? l)
+    (begin
+      (if (func? (car l) '!row)
+        (begin
+          (texout-row* (cdar l))
+          (if (nnull? (cdr l)) (begin (output-tex "\\\\") (output-lf)))
+        ) ;begin
+        (begin
+          (texout (car l))
+          (if (nnull? (cdr l)) (output-lf))
+        ) ;begin
+      ) ;if
+      (texout-table (cdr l))
+    ) ;begin
+  ) ;if
+) ;define
+
+(define (texout-row l)
+  (if (nnull? l)
+    (begin
+      (texout (car l))
+      (if (nnull? (cdr l)) (output-tex " & "))
+      (texout-row (cdr l))
+    ) ;begin
+  ) ;if
+) ;define
+
+(define (texout-row* l)
+  ;; Dirty hack to avoid [ strings at start of a row
+  ;; because of confusion with optional argument of \\
+  (if (and (pair? l) (string? (car l)) (string-starts? (car l) "["))
+    (set! l `((!concat (!group "") ,(car l)) ,@(cdr l)))
+  ) ;if
+  (if (and (pair? l)
+        (func? (car l) '!concat)
+        (string? (cadar l))
+        (string-starts? (cadar l) "[")
+      ) ;and
+    (set! l `((!concat (!group "") ,@(cdar l)) ,@(cdr l)))
+  ) ;if
+  (texout-row l)
+) ;define
+
+(define (texout-want-space x1 x2)
+  ;; spacing rules
+  (and (not (or (and (string? x1) (!= x1 "") (in? (string-take-right x1 1) '("("
+                                                                             "[")))
+              (in? x1 '(({) (nobreak)))
+              (and (string? x2) (!= x2 "") (in? (string-take x2 1) '(","
+                                                                     ")"
+                                                                     "]")))
+              (in? x2 '((}) (nobreak)))
+              (== x1 " ")
+              (== x2 " ")
+              (func? x2 '!nextline)
+              (== x2 "'")
+              (func? x2 '!sub)
+              (func? x2 '!sup)
+              (func? x1 '&)
+              (func? x2 '&)
+              (func? x1 '!nbsp)
+              (func? x2 '!nbsp)
+              (func? x1 '!nbhyph)
+              (func? x2 '!nbhyph)
+              (and (== x1 "'") (nlist? x2))
+            ) ;or
+       ) ;not
+    (or (in? x1 '("," ";" ":"))
+      (func? x1 'tmop)
+      (func? x2 'tmop)
+      (func? x1 '!symbol)
+      (func? x2 '!symbol)
+      (and (list-1? x1)
+        (symbol? (car x1))
+        (string-alpha? (symbol->string (car x1)))
+        (string? x2)
+        (> (string-length x2) 0)
+      ) ;and
+      (and (nlist? x1) (nlist? x2))
+    ) ;or
+  ) ;and
+) ;define
+
+(define (texout-concat-sub prev l)
+  (when (nnull? l)
+    (if (func? (car l) '!marker)
+      (begin
+        (texout (car l))
+        (texout-concat-sub prev (cdr l))
+      ) ;begin
+      (begin
+        (if (and prev (texout-want-space prev (car l))) (texout " "))
+        (texout (car l))
+        (texout-concat-sub (car l) (cdr l))
+      ) ;begin
+    ) ;if
+  ) ;when
+) ;define
+
+(define (texout-concat l)
+  (texout-concat-sub #f l)
+) ;define
+
+(tm-define (texout-multiline? x)
+  (cond ((npair? x) #f)
+        ((in? (car x) '(!begin !nextline !newline !linefeed !eqn !table)) #t)
+        ((and (in? (car x) '(!document !paragraph)) (> (length (cdr x)) 1)) #t)
+        ((npair? (cdr x)) #f)
+        (else (or (texout-multiline? (cadr x)) (texout-multiline? `(!concat ,@(cddr x))))
+        ) ;else
+  ) ;cond
+) ;tm-define
+
+(define (texout-indent x)
+  (if (texout-multiline? x)
+    (begin
+      (output-indent 2)
+      (output-lf)
+      (texout x)
+      (output-indent -2)
+      (output-lf)
+    ) ;begin
+    (texout x)
+  ) ;if
+) ;define
+
+(define (texout-unindent x)
+  (with old-indent
+    (get-output-indent)
+    (set-output-indent 0)
+    (texout x)
+    (set-output-indent old-indent)
+  ) ;with
+) ;define
+
+(define (texout-linefeed)
+  (output-lf)
+) ;define
+
+(define (texout-newline)
+  (output-lf)
+  (output-lf)
+) ;define
+
+(define (texout-nextline)
+  (output-tex "\\\\")
+  (output-lf)
+) ;define
+
+(define (texout-nbsp)
+  (output-tex "~")
+) ;define
+
+(define (texout-nbhyph)
+  (output-tex "\\mbox{-}")
+) ;define
+
+(define (texout-verb x)
+  (cond ((not (string-index x #\|)) (output-verb "\\verb|" x "|"))
+        ((not (string-index x #\$)) (output-verb "\\verb$" x "$"))
+        ((not (string-index x #\@)) (output-verb "\\verb@" x "@"))
+        ((not (string-index x #\!)) (output-verb "\\verb!" x "!"))
+        ((not (string-index x #\9)) (output-verb "\\verb9" x "9"))
+        ((not (string-index x #\X)) (output-verb "\\verbX" x "X"))
+        (else (output-verb "\\verbď" x "ď"))
+  ) ;cond
+) ;define
+
+(define (texout-verbatim x)
+  (output-lf-verbatim "\\begin{alltt}\n" x "\n\\end{alltt}")
+) ;define
+
+(define (texout-verbatim* x)
+  (output-lf-verbatim x)
+) ;define
+
+(define (texout-invariant x)
+  (output-invariant x)
+) ;define
+
+(define (texout-group x)
+  (output-tex "{")
+  (texout x)
+  (output-tex "}")
+) ;define
+
+(define (texout-marker tag arg)
+  (with s
+    (string-append "{\\" (symbol->string tag) "{" arg "}}")
+    (output-marker s)
+  ) ;with
+) ;define
+
+(define (texout-empty? x)
+  (cond ((== x "") #t)
+        ((func? x '!concat) (list-and (map-in-order texout-empty? (cdr x))))
+        ((func? x '!document 1) (texout-empty? (cadr x)))
+        (else #f)
+  ) ;cond
+) ;define
+
+(define (texout-double-math? x)
+  (or (and (match? x '((:or !document !concat) :%1)) (texout-double-math? (cadr x)))
+    (and (match? x '((!begin :%1) :%1))
+      (in? (cadar x) '("eqnarray" "eqnarray*" "leqnarray*"))
+    ) ;and
+  ) ;or
+) ;define
+
+(define (texout-math x)
+  (cond ((texout-empty? x) (noop))
+        ((texout-double-math? x) (texout x))
+        ((match? x '((!begin "center") :%1)) (texout `((!begin "equation")
+                                                       ,(cadr x))))
+        ((and (output-test-end? "$") (not (output-test-end? "\\$")))
+         (output-remove 1)
+         (output-tex " ")
+         (texout x)
+         (output-tex "$")
+        ) ;
+        (else (output-tex "$") (texout x) (output-tex "$"))
+  ) ;cond
+) ;define
+
+(define (texout-eqn x)
+  (output-tex "\\[ ")
+  (output-indent 3)
+  (texout x)
+  (output-indent -3)
+  (output-tex " \\]")
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Outputting macro applications and environments
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (texout-arg x)
+  (output-tex (string-append "#" x))
+) ;define
+
+(define (texout-args l)
+  (if (nnull? l)
+    (begin
+      (if (and (list? (car l)) (== (caar l) '!option))
+        (begin
+          (output-tex "[")
+          (texout (cadar l))
+          (output-tex "]")
+        ) ;begin
+        (begin
+          (output-tex "{")
+          (texout (car l))
+          (output-tex "}")
+        ) ;begin
+      ) ;if
+      (texout-args (cdr l))
+    ) ;begin
+  ) ;if
+) ;define
+
+(define (texout-apply what args)
+  (output-tex (if (string? what) what (string-append "\\" (symbol->string what))))
+  (texout-args args)
+) ;define
+
+(define (texout-protect? env)
+  (in? env (list "tmparmod" "tmparsep"))
+) ;define
+
+(define (texout-begin* what args inside)
+  (set! what (tex-env-name what))
+  (output-tex (string-append "\\begin{" what "}"))
+  (texout-args args)
+  (if (texout-protect? what) (output-tex "%"))
+  (output-lf)
+  (texout inside)
+  (output-lf)
+  (output-tex (string-append "\\end{" what "}"))
+) ;define
+
+(define (texout-begin what args inside)
+  (set! what (tex-env-name what))
+  (output-tex (string-append "\\begin{" what "}"))
+  (texout-args args)
+  (if (texout-protect? what) (output-tex "%"))
+  (output-indent 2)
+  (output-lf)
+  (texout inside)
+  (output-indent -2)
+  (output-lf)
+  (output-tex (string-append "\\end{" what "}"))
+) ;define
+
+(define (texout-script where l)
+  (let ((x (car l)))
+    (cond ((and (== x '(prime)) (== where "^")) (output-tex "'"))
+          ((and (func? x '!concat)
+             (== where "^")
+             (pair? (cdr x))
+             (== (cadr x) '(prime))
+             (list-and (map (cut == <> '(prime)) (cdr x)))
+           ) ;and
+           (output-tex (apply string-append (map (lambda a "'") (cdr x))))
+          ) ;
+          ((and (string? x) (= (string-length x) 1) (nin? x (list "<" ">")))
+           (output-tex where)
+           (output-tex x)
+          ) ;
+          (else (output-tex where) (texout-args l))
+    ) ;cond
+  ) ;let
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Main output routines
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (texout x)
+  (cond ((string? x) (output-tex x))
+        ((nlist>0? x) (display* "TeXmacs] badly formatted stree:\n" x "\n"))
+        ((== (car x) '!widechar) (output-tex (symbol->string (cadr x))))
+        ((== (car x) '!file) (texout-file (cdr x)))
+        ((== (car x) '!preamble) (texout-preamble (cadr x)))
+        ((== (car x) '!comment) (texout-comment (cadr x)))
+        ((== (car x) '!document) (texout-document (cdr x)))
+        ((== (car x) '!paragraph) (texout-paragraph (cdr x)))
+        ((== (car x) '!table) (texout-table (cdr x)))
+        ((== (car x) '!concat) (texout-concat (cdr x)))
+        ((== (car x) '!append) (for-each texout (cdr x)))
+        ((== (car x) '!symbol) (texout (cadr x)))
+        ((== (car x) '!linefeed) (texout-linefeed))
+        ((== (car x) '!indent) (texout-indent (cadr x)))
+        ((== (car x) '!unindent) (texout-unindent (cadr x)))
+        ((== (car x) '!newline) (texout-newline))
+        ((== (car x) '!nextline) (texout-nextline))
+        ((== (car x) '!nbsp) (texout-nbsp))
+        ((== (car x) '!nbhyph) (texout-nbhyph))
+        ((== (car x) '!verb) (texout-verb (cadr x)))
+        ((== (car x) '!verbatim) (texout-verbatim (cadr x)))
+        ((== (car x) '!verbatim*) (texout-verbatim* (cadr x)))
+        ((== (car x) '!invariant) (texout-invariant (cadr x)))
+        ((== (car x) '!arg) (texout-arg (cadr x)))
+        ((== (car x) '!group) (texout-group (cons '!append (cdr x))))
+        ((== (car x) '!marker) (texout-marker (cadr x) (caddr x)))
+        ((== (car x) '!math) (texout-math (cadr x)))
+        ((== (car x) '!eqn) (texout-eqn (cadr x)))
+        ((== (car x) '!sub) (texout-script "_" (cdr x)))
+        ((== (car x) '!sup) (texout-script "^" (cdr x)))
+        ((== (car x) '!annotate) (texout (cadr x)))
+        ((== (car x) '!ignore) (noop))
+        ((and (list? (car x)) (== (caar x) '!begin))
+         (texout-begin (cadar x) (cddar x) (cadr x))
+        ) ;
+        ((and (list? (car x)) (== (caar x) '!begin*))
+         (texout-begin* (cadar x) (cddar x) (cadr x))
+        ) ;
+        (else (texout-apply (car x) (cdr x)))
+  ) ;cond
+) ;tm-define
+
+(tm-define (serialize-latex x) (texout x) (output-produce))
diff --git a/TeXmacs/plugins/latex/progs/latex/convert-latex-tmtex-acm.scm b/TeXmacs/plugins/latex/progs/latex/convert-latex-tmtex-acm.scm
new file mode 100644
index 0000000000..0ecac543e3
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/convert-latex-tmtex-acm.scm
@@ -0,0 +1,428 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : tmtex-acm.scm
+;; DESCRIPTION : special conversions for acm styles
+;; COPYRIGHT   : (C) 2012  Joris van der Hoeven, Francois Poulain
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex convert-latex-tmtex-acm)
+  (:use (latex convert-latex-tmtex) (latex convert-latex-define))
+) ;texmacs-module
+
+(tm-define (tmtex-transform-style x)
+  (:mode acm-style?)
+  (cond ((== x "acmconf") "acm_proc_article-sp")
+        ((== x "sig-alternate") x)
+        ((== x "acmsmall") '("format=acmsmall" "acmart"))
+        ((== x "acmlarge") '("format=acmlarge" "acmart"))
+        ((== x "acmtog") '("format=acmtog" "acmart"))
+        ((== x "sigconf") '("format=sigconf" "acmart"))
+        ((== x "sigchi") '("format=sigchi" "acmart"))
+        ((== x "sigplan") '("format=sigplan" "acmart"))
+        (else x)
+  ) ;cond
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; New ACM metadata presentation
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (tmtex-make-acm-art-title titles miscs tr)
+  (let* ((titles (tmtex-concat-Sep (map cadr titles))) (content `(,@titles
+                                                                  ,@miscs)))
+    (if (null? content) '() `((title (!indent (!paragraph ,@content)))))
+  ) ;let*
+) ;define
+
+(define (rewrite-author a)
+  (cond ((not (func? a 'author 1)) (list a))
+        ((not (func? (cadr a) '!paragraph)) (list a))
+        (else (cons `(author ,(cadr (cadr a))) (cddr (cadr a))))
+  ) ;cond
+) ;define
+
+(tm-define (tmtex-append-authors l)
+  (:mode acm-art-style?)
+  (set! l (filter nnull? l))
+  (with r (append-map rewrite-author l) `((!document ,@r)))
+) ;tm-define
+
+(tm-define (tmtex-make-doc-data titles subtitles authors dates miscs notes
+             subtits-l dates-l miscs-l notes-l tr ar
+           ) ;tmtex-make-doc-data
+  (:mode acm-art-style?)
+  `(!document ,@(tmtex-make-acm-art-title titles miscs tr)
+     ,@subtitles
+     ,@notes
+     ,@(tmtex-append-authors authors)
+     ,@dates
+     (maketitle))
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; New ACM specific titlemarkup
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-doc-subtitle t)
+  (:mode acm-art-style?)
+  `(subtitle ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-doc-note t)
+  (:mode acm-art-style?)
+  (set! t (tmtex-remove-line-feeds t))
+  `(titlenote ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-doc-misc t)
+  (:mode acm-art-style?)
+  (set! t (tmtex-remove-line-feeds t))
+  `(tmacmmisc ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-doc-date t) (:mode acm-art-style?) `(date ,(tmtex (cadr t))))
+
+(tm-define (tmtex-author-name t)
+  (:mode acm-art-style?)
+  `(author ,(tmtex-inline (cadr t)))
+) ;tm-define
+
+(define (get-affiliation-lines aff)
+  (if (func? aff 'concat)
+    (list-filter (cdr aff) (lambda (x) (!= x '(next-line))))
+    (list aff)
+  ) ;if
+) ;define
+
+(tm-define (tmtex-author-affiliation t)
+  (:mode acm-art-style?)
+  (let* ((l (if (null? (cdr t)) '() (get-affiliation-lines (cadr t)))) (r (list)))
+    (when (nnull? l)
+      (set! r (rcons r `(institution ,(tmtex (car l)))))
+      (set! l (cdr l))
+    ) ;when
+    (when (nnull? l)
+      (set! r (rcons r `(streetaddress ,(tmtex (car l)))))
+      (set! l (cdr l))
+    ) ;when
+    (when (nnull? l)
+      (set! r (rcons r `(city ,(tmtex (car l)))))
+      (set! l (cdr l))
+    ) ;when
+    (when (nnull? l)
+      (set! r (rcons r `(country ,(tmtex (car l)))))
+      (set! l (cdr l))
+    ) ;when
+    `(affiliation (!paragraph ,@r))
+  ) ;let*
+) ;tm-define
+
+(tm-define (tmtex-author-email t)
+  (:mode acm-art-style?)
+  (set! t (tmtex-remove-line-feeds t))
+  `(email ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-author-homepage t)
+  (:mode acm-art-style?)
+  (set! t (tmtex-remove-line-feeds t))
+  `(tmacmhomepage ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-author-note t)
+  (:mode acm-art-style?)
+  (set! t (tmtex-remove-line-feeds t))
+  `(authornote ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-author-misc t)
+  (:mode acm-art-style?)
+  (set! t (tmtex-remove-line-feeds t))
+  `(tmacmmisc ,(tmtex (cadr t)))
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Old ACM metadata presentation
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-append-authors l)
+  (:mode acm-conf-style?)
+  (set! l (filter nnull? l))
+  (if (null? l)
+    l
+    (let* ((n (number->string (length l)))
+           (sep '(!concat (!linefeed) (alignauthor) (!linefeed)))
+          ) ;
+      (set! l (list-intersperse (map cadr l) sep))
+      `((!document (numberofauthors ,n)
+          (author (!indent (!concat (alignauthor) ," " ,@l)))))
+    ) ;let*
+  ) ;if
+) ;tm-define
+
+(tm-define (tmtex-make-author names affiliations emails urls miscs notes affs-l
+             emails-l urls-l miscs-l notes-l
+           ) ;tmtex-make-author
+  (:mode acm-conf-style?)
+  (let* ((names (tmtex-concat-Sep (map cadr names)))
+         (result `(,@names ,@urls ,@notes ,@miscs ,@affiliations ,@emails))
+        ) ;
+    (if (null? result) '() `(author (!concat ,@result)))
+  ) ;let*
+) ;tm-define
+
+(define (tmtex-make-acm-conf-title titles notes miscs)
+  (let* ((titles (tmtex-concat-Sep (map cadr titles)))
+         (result `(,@titles ,@notes ,@miscs))
+        ) ;
+    (if (null? result) '() `((title (!concat ,@result))))
+  ) ;let*
+) ;define
+
+(tm-define (tmtex-make-doc-data titles subtitles authors dates miscs notes
+             subtits-l dates-l miscs-l notes-l tr ar
+           ) ;tmtex-make-doc-data
+  (:mode acm-conf-style?)
+  `(!document ,@(tmtex-make-acm-conf-title titles notes miscs)
+     ,@subtitles
+     ,@(tmtex-append-authors authors)
+     ,@dates
+     (maketitle))
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Old ACM specific titlemarkup
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (acm-line-break t)
+  `(!concat (!nextline) ,t)
+) ;define
+
+(tm-define (tmtex-doc-subtitle t)
+  (:mode acm-conf-style?)
+  `(subtitle ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-doc-note t)
+  (:mode acm-conf-style?)
+  (set! t (tmtex-remove-line-feeds t))
+  `(titlenote ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-doc-misc t)
+  (:mode acm-conf-style?)
+  (set! t (tmtex-remove-line-feeds t))
+  `(tmacmmisc ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-doc-date t) (:mode acm-conf-style?) `(date ,(tmtex (cadr t))))
+
+(tm-define (tmtex-author-affiliation t)
+  (:mode acm-conf-style?)
+  (with aff-lines
+    (if (list>0? (cadr t))
+      (map (lambda (x) (if (== x '(next-line)) '(!nextline) `(affaddr ,(tmtex x))))
+        (cdadr t)
+      ) ;map
+      (if (null? (cdr t)) '() `((affaddr ,(tmtex (cadr t)))))
+    ) ;if
+    (acm-line-break `(!concat ,@aff-lines))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-author-email t)
+  (:mode acm-conf-style?)
+  (set! t (tmtex-remove-line-feeds t))
+  (acm-line-break `(email ,(tmtex (cadr t))))
+) ;tm-define
+
+(tm-define (tmtex-author-homepage t)
+  (:mode acm-conf-style?)
+  (set! t (tmtex-remove-line-feeds t))
+  `(tmacmhomepage ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-author-note t)
+  (:mode acm-conf-style?)
+  (set! t (tmtex-remove-line-feeds t))
+  `(titlenote ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-author-misc t)
+  (:mode acm-conf-style?)
+  (set! t (tmtex-remove-line-feeds t))
+  `(tmacmmisc ,(tmtex (cadr t)))
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; ACM specific abstract markup
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-make-abstract-data keywords acm arxiv msc pacs abstract)
+  (:mode acm-style?)
+  (with result
+    `(,@abstract ,@acm ,@arxiv ,@msc ,@pacs ,@keywords)
+    (if (null? result) "" `(!document ,@result))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-abstract-keywords t)
+  (:mode acm-style?)
+  (with args
+    (tmtex-concat-sep (map tmtex (cdr t)))
+    `(keywords ,@(map tmtex args))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-abstract-acm t)
+  (:mode acm-style?)
+  (with l
+    (cond ((== (length (cdr t)) 0) '("" "" ""))
+          ((== (length (cdr t)) 1) (append (cdr t) '("" "")))
+          ((== (length (cdr t)) 2) (append (cdr t) '("")))
+          ((== (length (cdr t)) 3) (cdr t))
+          (else (append (sublist (cdr t) 0 3)
+                  `((!option ,(fourth (cdr t))))
+                  (sublist (cdr t) 4 (length (cdr t)))
+                ) ;append
+          ) ;else
+    ) ;cond
+    `(category ,@(map tmtex l))
+  ) ;with
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; ACM specific misc markup
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-acm-conferenceinfo s l)
+  (:mode acm-style?)
+  `(conferenceinfo ,@(map tmtex l))
+) ;tm-define
+
+(tm-define (tmtex-acm-copyright-year s l)
+  (:mode acm-style?)
+  `(CopyrightYear ,@(map tmtex l))
+) ;tm-define
+
+(tm-define (tmtex-acm-crdata s l) (:mode acm-style?) `(crdata ,@(map tmtex l)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Put 'maketitle' after abstract
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define removed-maketitle? #f)
+
+(define added-maketitle? #f)
+
+(define (remove-maketitle t)
+  (cond ((nlist? t) t)
+        ((and (func? t '!document) (== (cAr t) '(maketitle)))
+         (set! removed-maketitle? #t)
+         (cDr t)
+        ) ;
+        (else (map remove-maketitle t))
+  ) ;cond
+) ;define
+
+(define (add-maketitle-sub l)
+  (cond ((null? l) l)
+        ((and (pair? (car l)) (== (caar l) '(!begin "abstract")))
+         (set! added-maketitle? #t)
+         (cons (car l) (cons '(maketitle) (cdr l)))
+        ) ;
+        (else (cons (add-maketitle (car l)) (add-maketitle-sub (cdr l))))
+  ) ;cond
+) ;define
+
+(define (add-maketitle t)
+  (cond ((nlist? t) t)
+        ((func? t '!document) (cons (car t) (add-maketitle-sub (cdr t))))
+        (else (map add-maketitle t))
+  ) ;cond
+) ;define
+
+(tm-define (tmtex-postprocess x)
+  (:mode acm-style?)
+  (set! removed-maketitle? #f)
+  (set! added-maketitle? #f)
+  (let* ((y (remove-maketitle x)) (z (add-maketitle y)))
+    (if (and removed-maketitle? added-maketitle?) z x)
+  ) ;let*
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; ACM specific macros
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-group latex-texmacs-3% (:mode acm-style?) category)
+
+(smart-table latex-texmacs-macro
+  (:mode acm-style?)
+  (qed #f)
+  (nequiv #f)
+  (category "")
+) ;smart-table
+
+(smart-table latex-texmacs-environment (:mode acm-style?) ("proof" #f))
+
+;; (tm-define (tmtex-cite-detail s l)
+;;  (:mode acm-style?)
+;;  (tmtex-cite-detail-poor s l))
+
+(smart-table latex-texmacs-env-preamble
+  (:mode acm-art-style?)
+  ("theorem" #f)
+  ("conjecture" #f)
+  ("proposition" #f)
+  ("lemma" #f)
+  ("corollary" #f)
+  ("definition" #f)
+  ("example" #f)
+) ;smart-table
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Missing theorem types
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-macro (acm-theorem prim name)
+  `(latex-texmacs-thmenv ,prim ,name ,() ,() acm-art-style?)
+) ;define-macro
+
+(define-macro (acm-remark prim name)
+  `(latex-texmacs-thmenv ,prim
+     ,name
+     ("\\theoremstyle{acmdefinition}\n")
+     ("\n\\theoremstyle{acmplain}")
+     acm-art-style?)
+) ;define-macro
+
+(define-macro (acm-exercise prim name)
+  `(latex-texmacs-thmenv ,prim
+     ,name
+     ("\\theoremstyle{acmdefinition}\n")
+     ("\n\\theoremstyle{acmplain}")
+     acm-art-style?)
+) ;define-macro
+
+(acm-theorem "axiom" "Axiom")
+(acm-theorem "notation" "Notation")
+(acm-remark "remark" "Remark")
+(acm-remark "note" "Note")
+(acm-remark "convention" "Convention")
+(acm-remark "warning" "Warning")
+(acm-remark "acknowledgments" "Acknowledgments")
+(acm-remark "answer" "Answer")
+(acm-remark "question" "Question")
+(acm-remark "remark" "Remark")
+(acm-remark "problem" "Problem")
+(acm-remark "solution" "Solution")
+(acm-exercise "exercise" "Exercise")
+(acm-exercise "problem" "Problem")
+(acm-exercise "solution" "Solution")
diff --git a/TeXmacs/plugins/latex/progs/latex/convert-latex-tmtex-ams.scm b/TeXmacs/plugins/latex/progs/latex/convert-latex-tmtex-ams.scm
new file mode 100644
index 0000000000..7094b8c677
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/convert-latex-tmtex-ams.scm
@@ -0,0 +1,204 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : tmtex-ams.scm
+;; DESCRIPTION : special conversions for AMS styles
+;; COPYRIGHT   : (C) 2012  Joris van der Hoeven, François Poulain
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex convert-latex-tmtex-ams)
+  (:use (latex convert-latex-tmtex) (latex convert-latex-define))
+) ;texmacs-module
+
+(tm-define (tmtex-transform-style x) (:mode ams-style?) x)
+
+(tm-define (tmtex-provided-packages) (:mode ams-style?) '("amsmath"))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; AMS data preprocessing
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (stree-contains? t u)
+  (cond ((== t u) #t)
+        ((nlist? t) #f)
+        ((null? t) #f)
+        (else (or (stree-contains? (car t) u)
+                (in? #t (map (lambda (x) (stree-contains? x u)) (cdr t)))
+              ) ;or
+        ) ;else
+  ) ;cond
+) ;define
+
+(define (insert-maketitle-after t u)
+  (cond ((nlist? t) t)
+        ((== (car t) u) `(!document ,t (maketitle)))
+        (else `(,(car t)
+                ,@(map (lambda (x) (insert-maketitle-after x u)) (cdr t))))
+  ) ;cond
+) ;define
+
+(tm-define (tmtex-style-preprocess doc)
+  (:mode ams-style?)
+  (cond ((stree-contains? doc 'abstract-data)
+         (insert-maketitle-after doc 'abstract-data)
+        ) ;
+        ((stree-contains? doc 'doc-data) (insert-maketitle-after doc 'doc-data))
+        (else doc)
+  ) ;cond
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; AMS metadata presentation
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-make-author names affiliations emails urls miscs notes affs-l
+             emails-l urls-l miscs-l notes-l
+           ) ;tmtex-make-author
+  (:mode ams-style?)
+  (let* ((names (map (lambda (x) `(author ,x)) (list-intersperse (map cadr names) '(tmSep)))
+         ) ;names
+         (result `(,@names ,@affiliations ,@emails ,@urls ,@notes ,@miscs))
+        ) ;
+    (if (null? result) '() `(!paragraph ,@result))
+  ) ;let*
+) ;tm-define
+
+(tm-define (tmtex-make-doc-data titles subtitles authors dates miscs notes
+             subtits-l dates-l miscs-l notes-l tr ar
+           ) ;tmtex-make-doc-data
+  (:mode ams-style?)
+  (let* ((title-opt (if (null? tr) '() `((!option ,@(tmtex-concat-Sep tr)))))
+         (titles (tmtex-concat-Sep (map cadr titles)))
+         (titles (if (null? titles) '() `((title ,@title-opt ,@titles))))
+         (title-data `(,@titles ,@subtitles ,@notes ,@miscs))
+         (title-data (if (null? title-data) '() `((!paragraph ,@title-data))))
+         (authors* (filter pair? authors))
+        ) ;
+    (if (and (null? title-data) (null? authors*) (null? dates))
+      '()
+      `(!document ,@title-data ,@authors* ,@dates)
+    ) ;if
+  ) ;let*
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; AMS specific titlemarkup
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-doc-running-title t) (:mode ams-style?) (tmtex (cadr t)))
+
+(tm-define (tmtex-doc-subtitle t)
+  (:mode ams-style?)
+  `(tmsubtitle ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-doc-note t)
+  (:mode ams-style?)
+  (set! t (tmtex-remove-line-feeds t))
+  `(tmnote ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-doc-misc t)
+  (:mode ams-style?)
+  (set! t (tmtex-remove-line-feeds t))
+  `(tmmisc ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-doc-date t) (:mode ams-style?) `(date ,(tmtex (cadr t))))
+
+(tm-define (tmtex-author-affiliation t)
+  (:mode ams-style?)
+  `(address ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-author-email t)
+  (:mode ams-style?)
+  (set! t (tmtex-remove-line-feeds t))
+  `(email ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-author-homepage t)
+  (:mode ams-style?)
+  (set! t (tmtex-remove-line-feeds t))
+  `(urladdr ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-author-note t)
+  (:mode ams-style?)
+  (set! t (tmtex-remove-line-feeds t))
+  `(tmnote ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-author-misc t)
+  (:mode ams-style?)
+  (set! t (tmtex-remove-line-feeds t))
+  `(tmmisc ,(tmtex (cadr t)))
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; AMS specific abstract markup
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (move-in-abstract what in)
+  (if (null? in)
+    (if (null? what) '() `(((!begin "abstract") (document ,@what))))
+    `(((!begin "abstract") (!document ,@(map cadr in) ,@what)))
+  ) ;if
+) ;define
+
+(tm-define (tmtex-make-abstract-data keywords acm arxiv msc pacs abstract)
+  (:mode ams-style?)
+  (with class
+    `(,@acm ,@arxiv ,@pacs)
+    (set! abstract (move-in-abstract class abstract))
+  ) ;with
+  (with result
+    `(,@abstract ,@msc ,@keywords)
+    (if (null? result) "" `(!document ,@result))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-abstract-keywords t)
+  (:mode ams-style?)
+  (with args (tmtex-concat-sep (map tmtex (cdr t))) `(keywords ,@args))
+) ;tm-define
+
+(tm-define (tmtex-abstract-msc t)
+  (:mode ams-style?)
+  (with args (tmtex-concat-Sep (map tmtex (cdr t))) `(subjclass ,@args))
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; AMS specific macros
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(smart-table latex-texmacs-macro (:mode ams-style?) (qed #f))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; AMS theorems
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-macro (ams-latex-texmacs-remark prim name)
+  `(latex-texmacs-thmenv ,prim
+     ,name
+     ("{" (!recurse (theoremstyle "remark")))
+     ("}")
+     ams-style?)
+) ;define-macro
+
+(ams-latex-texmacs-remark "remark" "Remark")
+(ams-latex-texmacs-remark "note" "Note")
+(ams-latex-texmacs-remark "example" "Example")
+(ams-latex-texmacs-remark "convention" "Convention")
+(ams-latex-texmacs-remark "warning" "Warning")
+(ams-latex-texmacs-remark "acknowledgments" "Acknowledgments")
+(ams-latex-texmacs-remark "answer" "Answer")
+(ams-latex-texmacs-remark "question" "Question")
+(ams-latex-texmacs-remark "exercise" "Exercise")
+(ams-latex-texmacs-remark "problem" "Problem")
+(ams-latex-texmacs-remark "solution" "Solution")
diff --git a/TeXmacs/plugins/latex/progs/latex/convert-latex-tmtex-beamer.scm b/TeXmacs/plugins/latex/progs/latex/convert-latex-tmtex-beamer.scm
new file mode 100644
index 0000000000..959dfb6b55
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/convert-latex-tmtex-beamer.scm
@@ -0,0 +1,307 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : tmtex-beamer.scm
+;; DESCRIPTION : special conversions for Beamer style
+;; COPYRIGHT   : (C) 2012  Joris van der Hoeven, François Poulain
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex convert-latex-tmtex-beamer)
+  (:use (latex convert-latex-tmtex))
+) ;texmacs-module
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Beamer style options
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-transform-style x) (:mode beamer-style?) "beamer")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Beamer document preprocessing
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (stree-transform l what by)
+  (cond ((or (null? l) (nlist? l)) l)
+        ((== (car l) what) `(,by ,@(cdr l)))
+        (else (map (lambda (x) (stree-transform x what by)) l))
+  ) ;cond
+) ;define
+
+(define (beamer-make-slides doc)
+  (set! doc (stree-transform doc 'hidden 'slide))
+  (stree-transform doc 'shown 'slide)
+) ;define
+
+(tm-define (tmtex-style-preprocess doc)
+  (:mode beamer-style?)
+  (beamer-make-slides doc)
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Beamer metadata presentation
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-make-author names affiliations emails urls miscs notes affs-l
+             emails-l urls-l miscs-l notes-l
+           ) ;tmtex-make-author
+  (:mode beamer-style?)
+  (let* ((names (tmtex-concat-Sep (map cadr names)))
+         (result `(,@names ,@urls ,@notes ,@miscs))
+        ) ;
+    (if (null? result) '() `(author (!paragraph ,@result)))
+  ) ;let*
+) ;tm-define
+
+(define (beamer-append in l)
+  (set! l (filter nnull? l))
+  (if (< (length l) 1)
+    l
+    (with lf
+      '(!concat (!linefeed) (and) (!linefeed))
+      `((,in (!indent (!concat ,@(list-intersperse (map cadr l) lf)))))
+    ) ;with
+  ) ;if
+) ;define
+
+(define (svjour-make-title titles notes miscs)
+  (let* ((titles (tmtex-concat-Sep (map cadr titles)))
+         (result `(,@titles ,@notes ,@miscs))
+        ) ;
+    (if (null? result) '() `((title (!concat ,@result))))
+  ) ;let*
+) ;define
+
+(define (svjour-make-doc-data titles subtits authors affs dates miscs notes tr ar)
+  `(!document ,@(svjour-make-title titles notes miscs)
+     ,@subtits
+     ,@tr
+     ,@ar
+     ,@(beamer-append 'author authors)
+     ,@(beamer-append 'institute affs)
+     ,@dates
+     (maketitle))
+) ;define
+
+(tm-define (tmtex-doc-data s l)
+  (:mode beamer-style?)
+  (set! l (map tmtex-replace-documents l))
+  (let* ((subtitles (map tmtex-doc-subtitle (tmtex-select-args-by-func 'doc-subtitle l)))
+         (notes (map tmtex-doc-note (tmtex-select-args-by-func 'doc-note l)))
+         (miscs (map tmtex-doc-misc (tmtex-select-args-by-func 'doc-misc l)))
+         (dates (map tmtex-doc-date (tmtex-select-args-by-func 'doc-date l)))
+         (authors (map tmtex-doc-author (tmtex-select-args-by-func 'doc-author l)))
+         (ar (map tmtex-doc-running-author (tmtex-select-args-by-func 'doc-running-author l))
+         ) ;ar
+         (titles (map tmtex-doc-title (tmtex-select-args-by-func 'doc-title l)))
+         (tr (map tmtex-doc-running-title (tmtex-select-args-by-func 'doc-running-title l))
+         ) ;tr
+         (affs (map tmtex-affiliation-group
+                 (cluster-by-affiliations (tmtex-select-args-by-func 'doc-author l))
+               ) ;map
+         ) ;affs
+        ) ;
+    (svjour-make-doc-data titles subtitles authors affs dates miscs notes tr ar)
+  ) ;let*
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Beamer affiliation clustering
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (beamer-clear-aff aff a filter?)
+  (with datas
+    (cdadr a)
+    (if (and filter?
+          (== `(,aff) (filter (lambda (x) (== 'author-affiliation (car x))) datas))
+        ) ;and
+      '()
+      `(doc-author (author-data ,@(filter (lambda (x) (!= aff x)) datas)))
+    ) ;if
+  ) ;with
+) ;define
+
+(define (next-affiliation l)
+  (cond ((or (null? l) (nlist? l)) #f)
+        ((in? (car l) '(doc-author author-data)) (next-affiliation (cdr l)))
+        ((== (car l) 'author-affiliation) l)
+        ((list? (car l))
+         (with na (next-affiliation (car l)) (if na na (next-affiliation (cdr l))))
+        ) ;
+        (else #f)
+  ) ;cond
+) ;define
+
+(define (cluster-by-affiliations l)
+  (if (nlist? l)
+    l
+    (let* ((aff (next-affiliation l))
+           (hasaff (filter (lambda (x)
+                             (or (not aff)
+                               (and (list? x) (list? (cdr x)) (list? (cadr x)) (in? aff (cdadr x)))
+                             ) ;or
+                           ) ;lambda
+                     l
+                   ) ;filter
+           ) ;hasaff
+           (hasaff* (map (lambda (x) (beamer-clear-aff aff x #f)) hasaff))
+           (l* (map (lambda (x) (beamer-clear-aff aff x #t)) l))
+           (l* (filter nnull? l*))
+           (aff* `(affiliation-group ,(if aff (cadr aff) '()) ,@hasaff*))
+          ) ;
+      (if aff (append `(,aff*) (cluster-by-affiliations l*)) `(,aff*))
+    ) ;let*
+  ) ;if
+) ;define
+
+(tm-define (tmtex-affiliation-group t)
+  (with old-tmtex-make-author
+    (eval tmtex-make-author)
+    (set! tmtex-make-author
+      (lambda (names affiliations emails urls miscs notes affs-l emails-l urls-l
+                miscs-l notes-l
+              ) ;names
+        (with names
+          (tmtex-concat-Sep (map cadr names))
+          (cond ((and (null? names) (null? emails)) '())
+                ((or (null? names) (null? emails)) `(!concat ,@names))
+                (else `(!concat ,@names))
+          ) ;cond
+        ) ;with
+      ) ;lambda
+    ) ;set!
+    (let* ((affs (cadr t))
+           (affs (if (null? affs) '() `((!concat (!linefeed)
+                                          (at)
+                                          (!linefeed)
+                                          ,(tmtex affs))))
+           ) ;affs
+           (auth-sep '(!concat " " (and) " "))
+           (authors (map tmtex-doc-author (cddr t)))
+           (authors (list-intersperse authors auth-sep))
+          ) ;
+      (set! tmtex-make-author (eval old-tmtex-make-author))
+      (if (and (null? authors) (null? affs))
+        '()
+        `(institute (!concat ,@authors ,@affs))
+      ) ;if
+    ) ;let*
+  ) ;with
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Beamer specific titlemarkup
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-doc-running-title t)
+  (:mode beamer-style?)
+  `(titlerunning ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-doc-subtitle t)
+  (:mode beamer-style?)
+  `(subtitle ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-doc-note t) (:mode beamer-style?) `(tmnote ,(tmtex (cadr t))))
+
+(tm-define (tmtex-doc-misc t) (:mode beamer-style?) `(tmmisc ,(tmtex (cadr t))))
+
+(tm-define (tmtex-doc-date t) (:mode beamer-style?) `(date ,(tmtex (cadr t))))
+
+(tm-define (tmtex-doc-running-author t)
+  (:mode beamer-style?)
+  `(authorrunning ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-author-affiliation t)
+  (:mode beamer-style?)
+  `(institute ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-author-email t)
+  (:mode beamer-style?)
+  `(email ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-author-homepage t)
+  (:mode beamer-style?)
+  `(tmfnhomepage ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-author-note t)
+  (:mode beamer-style?)
+  `(tmnote ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-author-misc t)
+  (:mode beamer-style?)
+  `(tmmisc ,(tmtex (cadr t)))
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Beamer specific abstract markup
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-make-abstract-data keywords acm arxiv msc pacs abstract)
+  (:mode beamer-style?)
+  (:require (not llncs?))
+  (with result
+    `(,@abstract ,@arxiv ,@acm ,@msc ,@pacs ,@keywords)
+    (if (null? result) "" `(!document ,@result))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-abstract-keywords t)
+  (:mode beamer-style?)
+  (:require (not llncs?))
+  (with args
+    (list-intersperse (map tmtex (cdr t)) '(!group (and)))
+    `(keywords (!concat ,@args))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-abstract-msc t)
+  (:mode beamer-style?)
+  (:require (not llncs?))
+  (with args
+    (list-intersperse (map tmtex (cdr t)) '(!group (and)))
+    `(subclass (!concat ,@args))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-abstract-acm t)
+  (:mode beamer-style?)
+  (:require (not llncs?))
+  (with args
+    (list-intersperse (map tmtex (cdr t)) '(!group (and)))
+    `(CRclass (!concat ,@args))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-abstract-pacs t)
+  (:mode beamer-style?)
+  (:require (not llncs?))
+  (with args
+    (list-intersperse (map tmtex (cdr t)) '(!group (and)))
+    `(PACS (!concat ,@args))
+  ) ;with
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Beamer specific frame markup
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-beamer-slide s l)
+  (:mode beamer-style?)
+  `((!begin "frame") ,(tmtex (car l)))
+) ;tm-define
+
+(tm-define (tmtex-beamer-tit s l)
+  (:mode beamer-style?)
+  `(frametitle ,(tmtex (car l)))
+) ;tm-define
diff --git a/TeXmacs/plugins/latex/progs/latex/convert-latex-tmtex-elsevier.scm b/TeXmacs/plugins/latex/progs/latex/convert-latex-tmtex-elsevier.scm
new file mode 100644
index 0000000000..5046b8ae1e
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/convert-latex-tmtex-elsevier.scm
@@ -0,0 +1,579 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : tmtex-elsevier.scm
+;; DESCRIPTION : special conversions for elsevier styles
+;; COPYRIGHT   : (C) 2006  Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex convert-latex-tmtex-elsevier)
+  (:use (latex convert-latex-tmtex))
+) ;texmacs-module
+
+(tm-define (tmtex-transform-style x)
+  (:mode elsevier-style?)
+  (cond ((== x "elsart") "elsart")
+        ((== x "elsarticle") "elsarticle")
+        ((== x "ifac") "ifacconf")
+        ((== x "jsc") '("amsthm" "elsart"))
+        (else x)
+  ) ;cond
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Initialization of elsevier style
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define note-counter 0)
+
+(define author-counter 0)
+
+(define clustered? #f)
+
+(define (init-elsevier body)
+  (set! clustered? #f)
+  (set! note-counter 0)
+  (set! author-counter 0)
+) ;define
+
+(tm-define (tmtex-style-init body) (:mode elsevier-style?) (init-elsevier body))
+
+(tm-define (tmtex-style-init body)
+  (:mode ifac-style?)
+  (init-elsevier body)
+  (set! tmtex-packages (cons "cite-author-year" tmtex-packages))
+  (latex-set-packages '("natbib"))
+) ;tm-define
+
+(tm-define (tmtex-style-init body)
+  (:mode jsc-style?)
+  (init-elsevier body)
+  ;; (set! tmtex-packages (cons "cite-author-year" tmtex-packages))
+  (latex-set-packages '("amsthm"
+                        "yjsco"
+                        ;; "natbib"
+                       )
+  ) ;latex-set-packages
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Hack for ifac incompatibility with hyperref package
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (latex-as-use-package l)
+  (:require (latex-ifacconf-style?))
+  (if (nin? "hyperref" l)
+    (former l)
+    (let* ((l* (list-remove l "hyperref"))
+           (s1 (if (null? l*) "" (former l*)))
+           (s2 (string-append "\\makeatletter\n" "\\let\\old@ssect\\@ssect\n"
+                 "\\makeatother\n" "\\usepackage{hyperref}\n" "\\makeatletter\n"
+                 "\\def\\@ssect#1#2#3#4#5#6{%\n" "  \\NR@gettitle{#6}%\n"
+                 "  \\old@ssect{#1}{#2}{#3}{#4}{#5}{#6}%\n" "}\n"
+                 "\\makeatother\n"
+               ) ;string-append
+           ) ;s2
+          ) ;
+      (string-append s1 s2)
+    ) ;let*
+  ) ;if
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Hack for incomplete ifac list environments
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (latex-extra-preamble)
+  (:require (latex-ifacconf-style?))
+  (string-append "\\newcommand{\\labelitemiii}{\\labelitemi}\n"
+    "\\newcommand{\\labelitemiv}{\\labelitemii}\n"
+  ) ;string-append
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Preprocessing data
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-style-preprocess doc)
+  (:mode elsevier-style?)
+  (elsevier-create-frontmatter doc)
+) ;tm-define
+
+(define (elsarticle-frontmatter? t)
+  (or (func? t 'abstract-data) (func? t 'doc-data) (func? t 'abstract))
+) ;define
+
+(define (partition l pred?)
+  (if (npair? l)
+    l
+    (letrec ((npred? (lambda (x) (not (pred? x)))))
+      (if (pred? (car l))
+        (receive (h t) (list-break l npred?) (cons h (partition t pred?)))
+        (receive (h t) (list-break l pred?) (cons h (partition t pred?)))
+      ) ;if
+    ) ;letrec
+  ) ;if
+) ;define
+
+(define (elsevier-create-frontmatter t)
+  (if (or (npair? t) (npair? (cdr t)))
+    t
+    (with l
+      (map elsarticle-frontmatter? (cdr t))
+      (if (in? #t l)
+        (with parts
+          (partition (cdr t) elsarticle-frontmatter?)
+          `(,(car t)
+            ,@(map (lambda (x)
+                     (if (elsarticle-frontmatter? (car x))
+                       `(elsevier-frontmatter (,(car t) ,@x))
+                       `(,(car t) ,@x)))
+                parts))
+        ) ;with
+        `(,(car t) ,@(map elsevier-create-frontmatter (cdr t)))
+      ) ;if
+    ) ;with
+  ) ;if
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Elsevier specific customizations
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-elsevier-frontmatter s l)
+  (:mode elsevier-style?)
+  `((!begin "frontmatter") ,(tmtex (car l)))
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Elsarticle specific title macros
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-replace-documents t) (:mode elsevier-style?) t)
+
+(tm-define (springer-note-ref l r)
+  (if (list? r)
+    (set! r (tex-concat* (list-intersperse r ",")))
+    (set! r (string-append l r))
+  ) ;if
+  `(tnoteref ,r)
+) ;tm-define
+
+(tm-define (tmtex-doc-subtitle-ref s l)
+  (:mode elsevier-style?)
+  (springer-note-ref "sub-" (car l))
+) ;tm-define
+
+(tm-define (tmtex-doc-subtitle-label s l)
+  (:mode elsevier-style?)
+  (with label
+    (string-append "sub-" (car l))
+    `(tsubtitletext (!option ,label) ,(tmtex (cadr l)))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-doc-note-ref s l)
+  (:mode elsevier-style?)
+  (springer-note-ref "note-" (car l))
+) ;tm-define
+
+(tm-define (tmtex-doc-note-label s l)
+  (:mode elsevier-style?)
+  (with label
+    (string-append "note-" (car l))
+    `(tnotetext (!option ,label) ,(tmtex (cadr l)))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-doc-date-ref s l)
+  (:mode elsevier-style?)
+  (springer-note-ref "date-" (car l))
+) ;tm-define
+
+(tm-define (tmtex-doc-date-label s l)
+  (:mode elsevier-style?)
+  (with label
+    (string-append "date-" (car l))
+    `(tdatetext (!option ,label) ,(tmtex (cadr l)))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-doc-misc-ref s l)
+  (:mode elsevier-style?)
+  (springer-note-ref "misc-" (car l))
+) ;tm-define
+
+(tm-define (tmtex-doc-misc-label s l)
+  (:mode elsevier-style?)
+  (with label
+    (string-append "misc-" (car l))
+    `(tmisctext (!option ,label) ,(tmtex (cadr l)))
+  ) ;with
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Elsevier specific authors macros
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (springer-author-note-ref l r)
+  (if (list? r)
+    (set! r (tex-concat* (list-intersperse r ",")))
+    (set! r (string-append l r))
+  ) ;if
+  `(fnref ,r)
+) ;tm-define
+
+(tm-define (tmtex-author-note-ref s l)
+  (:mode elsevier-style?)
+  (springer-author-note-ref "author-note-" (car l))
+) ;tm-define
+
+(tm-define (tmtex-author-note-label s l)
+  (:mode elsevier-style?)
+  (with label
+    (string-append "author-note-" (car l))
+    `(fntext (!option ,label) ,(tmtex (cadr l)))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-author-misc-ref s l)
+  (:mode elsevier-style?)
+  (springer-author-note-ref "author-misc-" (car l))
+) ;tm-define
+
+(tm-define (tmtex-author-misc-label s l)
+  (:mode elsevier-style?)
+  (with label
+    (string-append "author-misc-" (car l))
+    `(fmtext (!option ,label) ,(tmtex (cadr l)))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-author-affiliation t)
+  (:mode elsevier-style?)
+  `(address ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-author-affiliation-ref s l)
+  (:mode elsevier-style?)
+  (springer-author-note-ref "affiliation-" (car l))
+) ;tm-define
+
+(tm-define (tmtex-author-affiliation-label s l)
+  (:mode elsevier-style?)
+  (with label
+    (string-append "affiliation-" (car l))
+    `(address (!option ,label) ,(tmtex (cadr l)))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-author-email t)
+  (:mode elsevier-style?)
+  `(ead ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-author-email-ref s l)
+  (:mode elsevier-style?)
+  (springer-note-ref "author-email-" (car l))
+) ;tm-define
+
+(tm-define (tmtex-author-email-label s l)
+  (:mode elsevier-style?)
+  `(ead ,(tmtex (cadr l)))
+) ;tm-define
+
+(tm-define (tmtex-author-homepage t)
+  (:mode elsevier-style?)
+  `(ead (!option "url") ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-author-homepage-ref s l)
+  (:mode elsevier-style?)
+  (springer-note-ref "author-url-" (car l))
+) ;tm-define
+
+(tm-define (tmtex-author-homepage-label s l)
+  (:mode elsevier-style?)
+  `(ead (!option "url") ,(tmtex (cadr l)))
+) ;tm-define
+
+(tm-define (tmtex-author-name t)
+  (:mode elsevier-style?)
+  `(author ,(tmtex (cadr t)))
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Elsart and IFAC specific title macros
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-replace-documents t)
+  (:mode elsevier-style?)
+  (:require (or (elsart-style?) (jsc-style?) (ifac-style?)))
+  (if (npair? t)
+    t
+    (with (r s)
+      (list (car t) (map tmtex-replace-documents (cdr t)))
+      (if (!= r 'document) `(,r ,@s) `(concat ,@(list-intersperse s
+                                                  '(next-line))))
+    ) ;with
+  ) ;if
+) ;tm-define
+
+(tm-define (springer-note-ref l r)
+  (:mode elsevier-style?)
+  (:require (or (elsart-style?) (jsc-style?) (ifac-style?)))
+  (if (list? r)
+    `(!concat ,@(map (lambda (x) `(thanksref ,x)) r))
+    `(thanksref ,(string-append l r))
+  ) ;if
+) ;tm-define
+
+(tm-define (tmtex-doc-subtitle-label s l)
+  (:mode elsevier-style?)
+  (:require (or (elsart-style?) (jsc-style?) (ifac-style?)))
+  (with label
+    (string-append "sub-" (car l))
+    `(thankssubtitle (!option ,label) ,(tmtex (cadr l)))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-doc-note-label s l)
+  (:mode elsevier-style?)
+  (:require (or (elsart-style?) (jsc-style?) (ifac-style?)))
+  (with label
+    (string-append "note-" (car l))
+    `(thanks (!option ,label) ,(tmtex (cadr l)))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-doc-date-label s l)
+  (:mode elsevier-style?)
+  (:require (or (elsart-style?) (jsc-style?) (ifac-style?)))
+  (with label
+    (string-append "date-" (car l))
+    `(thanksdate (!option ,label) ,(tmtex (cadr l)))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-doc-misc-label s l)
+  (:mode elsevier-style?)
+  (:require (or (elsart-style?) (jsc-style?) (ifac-style?)))
+  (with label
+    (string-append "misc-" (car l))
+    `(thanksmisc (!option ,label) ,(tmtex (cadr l)))
+  ) ;with
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Elsart specific authors macros
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (springer-author-note-ref l r)
+  (:mode elsevier-style?)
+  (:require (or (elsart-style?) (jsc-style?) (ifac-style?)))
+  (springer-note-ref l r)
+) ;tm-define
+
+(tm-define (tmtex-author-note-label s l)
+  (:mode elsevier-style?)
+  (:require (or (elsart-style?) (jsc-style?) (ifac-style?)))
+  (with label
+    (string-append "author-note-" (car l))
+    `(thanks (!option ,label) ,(tmtex (cadr l)))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-author-misc-label s l)
+  (:mode elsevier-style?)
+  (:require (or (elsart-style?) (jsc-style?) (ifac-style?)))
+  (with label
+    (string-append "author-misc-" (car l))
+    `(thanksamisc (!option ,label) ,(tmtex (cadr l)))
+  ) ;with
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; IFAC specific authors macros
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-author-email-label s l)
+  (:mode ifac-style?)
+  (with label
+    (string-append "author-email-" (car l))
+    `(thanksemail (!option ,label) ,(tmtex (cadr l)))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-author-homepage-label s l)
+  (:mode ifac-style?)
+  (with label
+    (string-append "author-url-" (car l))
+    `(thankshomepage (!option ,label) ,(tmtex (cadr l)))
+  ) ;with
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Elsevier title and author preprocessing
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-prepare-doc-data l)
+  (:mode elsevier-style?)
+  (set! clustered?
+    (or (contains-stree? l '(doc-title-options "cluster-by-affiliation"))
+      (contains-stree? l '(doc-title-options "cluster-all"))
+    ) ;or
+  ) ;set!
+  (set! l (map tmtex-replace-documents l))
+  (set! l (make-references l 'doc-subtitle #f #f))
+  (set! l (make-references l 'doc-note #f #f))
+  (set! l (make-references l 'doc-misc #f #f))
+  (set! l (make-references l 'doc-date #f #f))
+  (set! l (make-references l 'author-note #t #f))
+  (set! l (make-references l 'author-misc #t #f))
+  (if (ifac-style?)
+    (begin
+      (set! l (make-references l 'author-email #t #f))
+      (set! l (make-references l 'author-homepage #t #f))
+    ) ;begin
+  ) ;if
+  (if clustered? (set! l (make-references l 'author-affiliation #t #f)))
+  l
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Elsevier title and author presentation
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-make-doc-data titles subtitles authors dates miscs notes
+             subtitles-l dates-l miscs-l notes-l tr ar
+           ) ;tmtex-make-doc-data
+  (:mode elsevier-style?)
+  (let* ((authors (filter nnull? authors))
+         (authors (if (null? authors) '() `((!paragraph ,@authors))))
+         (titles (tmtex-concat-Sep (map cadr titles)))
+         (notes `(,@subtitles ,@dates ,@miscs ,@notes))
+         (notes (if (null? notes) '() `(,(springer-note-ref "" (map cadr notes)))))
+         (result `(,@titles ,@notes))
+         (result (if (null? result) '() `((title (!concat ,@result)))))
+         (result `(,@result
+                   ,@subtitles-l
+                   ,@notes-l
+                   ,@miscs-l
+                   ,@dates-l
+                   ,@authors))
+        ) ;
+    (if (null? result) "" `(!document ,@result))
+  ) ;let*
+) ;tm-define
+
+(tm-define (tmtex-make-author names affs emails urls miscs notes affs* emails*
+             urls* miscs* notes*
+           ) ;tmtex-make-author
+  (:mode elsevier-style?)
+  (let* ((names (tmtex-concat-Sep (map cadr names)))
+         (notes* (if (ifac-style?) `(,@emails* ,@urls* ,@miscs* ,@notes*) `(,@miscs*
+                                                                            ,@notes*))
+         ) ;notes*
+         (notes* (if (null? notes*) '() `(,(springer-author-note-ref ""
+                                             (map cadr notes*))))
+         ) ;notes*
+         (affs* (if (null? affs*)
+                  '()
+                  `((!option (!concat ,@(list-intersperse (map cadr affs*) ","))))
+                ) ;if
+         ) ;affs*
+         (result `(,@names ,@notes*))
+         (result (if (null? result) '() `((author ,@affs* (!concat ,@result)))))
+         (result `(,@result ,@affs ,@emails ,@urls ,@miscs ,@notes))
+        ) ;
+    (if (null? result) '() `(!paragraph ,@result))
+  ) ;let*
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Elsevier abstract macros
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-abstract-keywords t)
+  (:mode elsevier-style?)
+  (with args
+    (list-intersperse (map tmtex (cdr t)) '(!concat (sep) " "))
+    `((!begin "keyword") (!concat ,@args))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-abstract-msc t)
+  (:mode elsevier-style?)
+  (with args
+    (list-intersperse (map tmtex (cdr t)) '(!concat (sep) " "))
+    `(!concat (MSC) ," " (!concat ,@args))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-abstract-pacs t)
+  (:mode elsevier-style?)
+  (with args
+    (list-intersperse (map tmtex (cdr t)) '(!concat (sep) " "))
+    `(!concat (PACS) ," " (!concat ,@args))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-make-abstract-data keywords acm arxiv msc pacs abstract)
+  (:mode elsevier-style?)
+  (if (or (nnull? msc) (nnull? pacs) (nnull? acm) (nnull? arxiv))
+    (set! keywords
+      `(((!begin "keyword")
+         (!document ,@(map cadr keywords) ,@pacs ,@msc ,@acm ,@arxiv)))
+    ) ;set!
+  ) ;if
+  `(!document ,@abstract ,@keywords)
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; The Elsevier style is quite ugly.
+;; Transform equations into eqnarray* for more uniform alignment.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-equation s l)
+  (:mode elsevier-style?)
+  (tmtex-env-set "mode" "math")
+  (let ((r (tmtex (car l))))
+    (tmtex-env-reset "mode")
+    (if (== s "equation")
+      (list (list '!begin "eqnarray") r)
+      ;; FIXME: why do elsequation
+      (list (list '!begin "eqnarray*") r)
+      ;; and elsequation* not work?
+    ) ;if
+  ) ;let
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; The elsarticle class does not insert a 'References' section title
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; (tm-define (tmtex-bib t)
+;;  (:mode elsevier-style?)
+;;  (:require (elsarticle-style?))
+;;  (tmtex-biblio (car t) (cdr t) #t))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Elsevier specific macros
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(smart-table latex-texmacs-macro
+  (:mode elsevier-style?)
+  (:require (elsarticle-style?))
+  (comma #f)
+) ;smart-table
+
+(smart-table latex-texmacs-preamble
+  (:mode elsevier-style?)
+  (:require (elsarticle-style?))
+  (qed (!append (renewcommand "\\qed" "") "\n"))
+) ;smart-table
diff --git a/TeXmacs/plugins/latex/progs/latex/convert-latex-tmtex-ieee.scm b/TeXmacs/plugins/latex/progs/latex/convert-latex-tmtex-ieee.scm
new file mode 100644
index 0000000000..936b1c9bf0
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/convert-latex-tmtex-ieee.scm
@@ -0,0 +1,265 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : tmtex-ieee.scm
+;; DESCRIPTION : special conversions for ieee styles
+;; COPYRIGHT   : (C) 2013  Joris van der Hoeven, François Poulain
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex convert-latex-tmtex-ieee)
+  (:use (latex convert-latex-tmtex))
+) ;texmacs-module
+
+(define conference? #f)
+
+(define clustered? #f)
+
+(tm-define (tmtex-style-init doc)
+  (:mode ieee-tran-style?)
+  ;; ieeetran require to be in conference mode to print affiliations and emails
+  (set! conference? (contains-tags? doc '(author-email author-affiliation)))
+  (set! clustered?
+    (and conference?
+      (or (contains-stree? doc '(doc-title-options "cluster-all"))
+        (contains-stree? doc '(doc-title-options "cluster-by-affiliation"))
+      ) ;or
+    ) ;and
+  ) ;set!
+) ;tm-define
+
+(tm-define (tmtex-transform-style x)
+  (:mode ieee-style?)
+  (cond ((== x "ieeeconf") "IEEEconf")
+        ((and (or clustered? conference?) (== x "ieeetran")) '("conference"
+                                                               "IEEEtran"))
+        ((== x "ieeetran") "IEEEtran")
+        (else x)
+  ) ;cond
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; IEEEconf metadata presentation
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-append-authors l)
+  (:mode ieee-conf-style?)
+  (set! l (filter nnull? l))
+  (if (null? l)
+    l
+    (with sep
+      '(!concat (!linefeed) (and) (!linefeed))
+      `((author (!indent (!concat ,@(list-intersperse (map cadr l) sep)))))
+    ) ;with
+  ) ;if
+) ;tm-define
+
+(tm-define (tmtex-make-author names affiliations emails urls miscs notes affs-l
+             emails-l urls-l miscs-l notes-l
+           ) ;tmtex-make-author
+  (:mode ieee-conf-style?)
+  (let* ((names (tmtex-concat-Sep (map cadr names)))
+         (result `(,@names ,@urls ,@notes ,@miscs))
+         (result (if (null? result) '() `((!concat ,@result))))
+         (result `(,@result ,@affiliations ,@emails))
+        ) ;
+    (if (null? result) '() `(author (!paragraph ,@result)))
+  ) ;let*
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; IEEEconf specific titlemarkup
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-author-affiliation t)
+  (:mode ieee-conf-style?)
+  `((!begin "affiliation") ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-author-email t)
+  (:mode ieee-conf-style?)
+  (set! t (tmtex-remove-line-feeds t))
+  `(email ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-author-homepage t)
+  (:mode ieee-conf-style?)
+  (set! t (tmtex-remove-line-feeds t))
+  `(tmfnhomepage ,(tmtex-inline (cadr t)))
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; IEEEtran metadata presentation
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-append-authors l)
+  (:mode ieee-tran-style?)
+  (set! l (filter nnull? l))
+  (if (null? l)
+    l
+    (with sep
+      '(!concat (!linefeed) "and~")
+      `((author (!indent (!concat ,@(list-intersperse (map cadr l) sep)))))
+    ) ;with
+  ) ;if
+) ;tm-define
+
+(tm-define (tmtex-append-authors l)
+  (:mode ieee-tran-style?)
+  (:require conference?)
+  (set! l (filter nnull? l))
+  (if (null? l)
+    l
+    (with sep
+      '(!concat (!linefeed) (and) (!linefeed))
+      `((author (!indent (!concat ,@(list-intersperse (map cadr l) sep)))))
+    ) ;with
+  ) ;if
+) ;tm-define
+
+(tm-define (tmtex-make-author names affs emails urls miscs notes affs* emails*
+             urls* miscs* notes*
+           ) ;tmtex-make-author
+  (:mode ieee-tran-style?)
+  (:require conference?)
+  (let* ((names (tmtex-concat-Sep (map cadr names)))
+         (affs (if clustered? affs (map cadr affs)))
+         (authorblockN `(,@names ,@affs* ,@emails* ,@urls ,@notes ,@miscs))
+         (authorblockN (if (null? authorblockN) '() `((IEEEauthorblockN (!concat ,@authorblockN))))
+         ) ;authorblockN
+         (authorblockA `(,@affs ,@emails))
+         (authorblockA (if clustered?
+                         (map (lambda (x) `(IEEEauthorblockA ,x)) authorblockA)
+                         (list-intersperse authorblockA '(!nextline))
+                       ) ;if
+         ) ;authorblockA
+         (authorblockA (if (and (not clustered?) (nnull? authorblockA))
+                         `((IEEEauthorblockA (!concat ,@authorblockA)))
+                         authorblockA
+                       ) ;if
+         ) ;authorblockA
+        ) ;
+    (if (and (null? authorblockN) (null? authorblockA))
+      '()
+      (if clustered?
+        `(,@authorblockN ,@authorblockA)
+        `(author (!paragraph ,@authorblockN ,@authorblockA))
+      ) ;if
+    ) ;if
+  ) ;let*
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; IEEEtran clustered metadata presentation
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-prepare-doc-data l)
+  (:mode ieee-tran-style?)
+  (:require clustered?)
+  (set! l (map tmtex-replace-documents l))
+  (set! l (make-references l 'author-affiliation #t #t))
+  (set! l (make-references l 'author-email #t #t))
+  l
+) ;tm-define
+
+(tm-define (tmtex-append-authors l)
+  (:mode ieee-tran-style?)
+  (:require clustered?)
+  (set! l (filter nnull? l))
+  (if (null? l)
+    ()
+    (let* ((sep '(!concat (!linefeed)))
+           (names (map (lambda (au) (filter (lambda (x) (== (car x) 'IEEEauthorblockN)) au)) l)
+           ) ;names
+           (names (map car (filter nnull? names)))
+           (names (tmtex-concat-sep (map cadr names)))
+           (l* (map (lambda (au) (filter (lambda (x) (!= (car x) 'IEEEauthorblockN)) au)) l)
+           ) ;l*
+           (l* (filter nnull? l*))
+           (l* (apply append l*))
+           (names (if (null? names) '() `((IEEEauthorblockN ,@names))))
+           (r `(,@names ,@l*))
+          ) ;
+      `((author (!indent (!concat ,@(list-intersperse r sep)))))
+    ) ;let*
+  ) ;if
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; IEEEtran specific titlemarkup
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-author-affiliation-ref s l)
+  (:mode ieee-tran-style?)
+  `(IEEEauthorrefmark ,(car l))
+) ;tm-define
+
+(tm-define (tmtex-author-affiliation-label s l)
+  (:mode ieee-tran-style?)
+  `(!concat (IEEEauthorrefmark ,(car l)) ,(tmtex (cadr l)))
+) ;tm-define
+
+(tm-define (tmtex-author-email-ref s l)
+  (:mode ieee-tran-style?)
+  `(IEEEauthorrefmark ,(car l))
+) ;tm-define
+
+(tm-define (tmtex-author-email-label s l)
+  (:mode ieee-tran-style?)
+  `(!concat (IEEEauthorrefmark ,(car l)) ,(tmtex-author-email l))
+) ;tm-define
+
+(tm-define (tmtex-author-affiliation t)
+  (:mode ieee-tran-style?)
+  (:require conference?)
+  `(IEEEauthorblockA ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-author-email t)
+  (:mode ieee-tran-style?)
+  (:require conference?)
+  (set! t (tmtex-remove-line-feeds t))
+  `(tmieeeemail ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-abstract-keywords t)
+  (:mode ieee-tran-style?)
+  (with args
+    (list-intersperse (map tmtex (cdr t)) '(!concat (tmsep) " "))
+    `((!begin "IEEEkeywords") (!concat ,@args))
+  ) ;with
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Further tweaking for IEEE styles
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (ieee-replace t)
+  (cond ((nlist? t) t)
+        ((== t '(hbar)) '(ieeehbar))
+        ((== t '(jmath)) '(ieeejmath))
+        ((== t '(amalg)) '(ieeeamalg))
+        ((== t '(coprod)) '(ieeecoprod))
+        (else (map ieee-replace t))
+  ) ;cond
+) ;define
+
+(tm-define (tmtex-postprocess-body x) (:mode ieee-conf-style?) (ieee-replace x))
+
+(logic-group latex-texmacs-symbol% ieeehbar ieeejmath ieeeamalg ieeecoprod)
+
+(smart-table latex-texmacs-macro
+  (ieeehbar (not "h"))
+  (ieeejmath "j")
+  (ieeecoprod (!group (mathop (mbox (reflectbox (rotatebox (!option "origin=c") "180" (!math (prod)))))
+                      ) ;mathop
+              ) ;!group
+  ) ;ieeecoprod
+  (ieeeamalg (!group (mathop (mbox (reflectbox (rotatebox (!option "origin=c") "180" (!math (Pi))))))
+             ) ;!group
+  ) ;ieeeamalg
+) ;smart-table
diff --git a/TeXmacs/plugins/latex/progs/latex/convert-latex-tmtex-revtex.scm b/TeXmacs/plugins/latex/progs/latex/convert-latex-tmtex-revtex.scm
new file mode 100644
index 0000000000..fb561c966a
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/convert-latex-tmtex-revtex.scm
@@ -0,0 +1,285 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : tmtex-revtex.scm
+;; DESCRIPTION : special conversions for RevTeX styles
+;; COPYRIGHT   : (C) 2012  Joris van der Hoeven, François Poulain
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex convert-latex-tmtex-revtex)
+  (:use (latex convert-latex-tmtex))
+) ;texmacs-module
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; RevTeX style options
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define revtex-style '("revtex4-1"))
+
+(define revtex-clustered? #f)
+
+(tm-define (tmtex-style-init body)
+  (:mode revtex-style?)
+  (set! revtex-style '("revtex4-1"))
+  (set! revtex-clustered? #f)
+) ;tm-define
+
+(define (revtex-set-style-option s)
+  (set! revtex-style (append (list s) revtex-style))
+) ;define
+
+(tm-define (tmtex-transform-style x) (:mode revtex-style?) revtex-style)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; RevTeX data preprocessing
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (stree-contains? t u)
+  (cond ((== t u) #t)
+        ((nlist? t) #f)
+        ((null? t) #f)
+        (else (in? #t (map (lambda (x) (stree-contains? x u)) t)))
+  ) ;cond
+) ;define
+
+(define (insert-maketitle-after t u)
+  (cond ((nlist? t) t)
+        ((== (car t) u) `(!document ,t (maketitle)))
+        (else `(,(car t)
+                ,@(map (lambda (x) (insert-maketitle-after x u)) (cdr t))))
+  ) ;cond
+) ;define
+
+(define (revtex-style-preprocess doc)
+  (cond ((stree-contains? doc 'abstract-data)
+         (insert-maketitle-after doc 'abstract-data)
+        ) ;
+        ((stree-contains? doc 'doc-data) (insert-maketitle-after doc 'doc-data))
+        (else doc)
+  ) ;cond
+) ;define
+
+(tm-define (tmtex-style-preprocess doc)
+  (:mode aip-style?)
+  (revtex-set-style-option "aip")
+  (revtex-set-style-option "reprint")
+  (revtex-style-preprocess doc)
+) ;tm-define
+
+(tm-define (tmtex-style-preprocess doc)
+  (:mode aps-style?)
+  (if (stree-contains? doc 'abstract-keywords)
+    (revtex-set-style-option "showkeys")
+  ) ;if
+  (if (stree-contains? doc 'abstract-msc) (revtex-set-style-option "showpacs"))
+  (revtex-set-style-option "aps")
+  (revtex-set-style-option "reprint")
+  (revtex-style-preprocess doc)
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; RevTeX metadata presentation
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-make-author names affiliations emails urls miscs notes affs-l
+             emails-l urls-l miscs-l notes-l
+           ) ;tmtex-make-author
+  (:mode revtex-style?)
+  (if (and (not revtex-clustered?) (null? affiliations))
+    (set! affiliations '((noaffiliation)))
+  ) ;if
+  (let* ((names (map (lambda (x) `(author ,x)) (list-intersperse (map cadr names) '(tmSep)))
+         ) ;names
+         (result `(,@names ,@emails ,@urls ,@notes ,@miscs ,@affiliations))
+        ) ;
+    (if (null? result) '() `(!paragraph ,@result))
+  ) ;let*
+) ;tm-define
+
+(tm-define (tmtex-make-doc-data titles subtitles authors dates miscs notes
+             subtits-l dates-l miscs-l notes-l tr ar
+           ) ;tmtex-make-doc-data
+  (:mode revtex-style?)
+  (let* ((title-data `(,@titles ,@subtitles ,@notes ,@miscs))
+         (title-data (if (null? title-data) '() `((!paragraph ,@title-data))))
+         (authors* (filter pair? authors))
+        ) ;
+    (if (and (null? title-data) (null? authors*) (null? dates))
+      '()
+      `(!document ,@title-data ,@authors* ,@dates)
+    ) ;if
+  ) ;let*
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; RevTeX clustered authors presentation
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (merge-with tags l)
+  (if (null? l)
+    '()
+    (letrec ((remove-tag (lambda (x)
+                           (let* ((root (car x)) (args (cdr x)) (args* (filter (lambda (y) (nin? y tags)) args)))
+                             `(,root ,@args*)
+                           ) ;let*
+                         ) ;lambda
+             ) ;remove-tag
+            ) ;
+      (let* ((last (cAr l)) (others (cDr l)) (others* (map remove-tag others)))
+        (if (null? tags)
+          (set! last `(,(car last)
+                       ,@(cdr last)
+                       (author-affiliation (noaffiliation))))
+        ) ;if
+        (map (lambda (x) `(doc-author ,x)) (append others* (list last)))
+      ) ;let*
+    ) ;letrec
+  ) ;if
+) ;define
+
+(define (cluster-by tag l)
+  (if (or (null? l) (nlist? (car l)))
+    '()
+    (letrec ((get-affiliations (lambda (x) (tmtex-select-args-by-func tag x))))
+      (let* ((author (car l))
+             (aff (get-affiliations author))
+             (same (filter (lambda (x) (== aff (get-affiliations x))) l))
+             (others (filter (lambda (x) (!= aff (get-affiliations x))) l))
+            ) ;
+        (append (merge-with aff same) (cluster-by tag others))
+      ) ;let*
+    ) ;letrec
+  ) ;if
+) ;define
+
+(tm-define (tmtex-doc-data s l)
+  (:mode revtex-style?)
+  (:require (or revtex-clustered?
+              (stree-contains? l '(doc-title-options "cluster-all"))
+              (stree-contains? l '(doc-title-options "cluster-by-affiliation"))
+            ) ;or
+  ) ;:require
+  (if (not revtex-clustered?) (set! revtex-clustered? #t))
+  (set! l (map tmtex-replace-documents l))
+  (let* ((subtitles (map tmtex-doc-subtitle (tmtex-select-args-by-func 'doc-subtitle l)))
+         (notes (map tmtex-doc-note (tmtex-select-args-by-func 'doc-note l)))
+         (miscs (map tmtex-doc-misc (tmtex-select-args-by-func 'doc-misc l)))
+         (dates (map tmtex-doc-date (tmtex-select-args-by-func 'doc-date l)))
+         (titles (map tmtex-doc-title (tmtex-select-args-by-func 'doc-title l)))
+         (authors (map cadr (tmtex-select-args-by-func 'doc-author l)))
+         (authors `((!document ,@(map tmtex-doc-author
+                                   (cluster-by 'author-affiliation authors))))
+         ) ;authors
+        ) ;
+    (with r
+      (tmtex-make-doc-data titles
+        subtitles
+        authors
+        dates
+        miscs
+        notes
+        '()
+        '()
+        '()
+        '()
+        '()
+        '()
+      ) ;tmtex-make-doc-data
+      (set! revtex-clustered? #f)
+      r
+    ) ;with
+  ) ;let*
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; RevTeX specific titlemarkup
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-doc-subtitle t)
+  (:mode revtex-style?)
+  `(tmsubtitle ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-doc-note t)
+  (:mode revtex-style?)
+  (set! t (tmtex-remove-line-feeds t))
+  `(tmnote ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-doc-misc t)
+  (:mode revtex-style?)
+  (set! t (tmtex-remove-line-feeds t))
+  `(tmmisc ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-doc-date t) (:mode revtex-style?) `(date ,(tmtex (cadr t))))
+
+(tm-define (tmtex-author-affiliation t)
+  (:mode revtex-style?)
+  (if (== t '(author-affiliation (noaffiliation)))
+    '(noaffiliation)
+    `(affiliation ,(tmtex (cadr t)))
+  ) ;if
+) ;tm-define
+
+(tm-define (tmtex-author-email t)
+  (:mode revtex-style?)
+  (set! t (tmtex-remove-line-feeds t))
+  `(email (!option "Email: ") ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-author-homepage t)
+  (:mode revtex-style?)
+  (set! t (tmtex-remove-line-feeds t))
+  `(homepage (!option "Web: ") ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-author-note t)
+  (:mode revtex-style?)
+  (set! t (tmtex-remove-line-feeds t))
+  `(tmnote ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-author-misc t)
+  (:mode revtex-style?)
+  (set! t (tmtex-remove-line-feeds t))
+  `(tmmisc ,(tmtex (cadr t)))
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; RevTeX specific abstract markup
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (move-in-abstract what in)
+  (if (null? in)
+    (if (null? what) '() `(((!begin "abstract") (document ,@what))))
+    `(((!begin "abstract") (!document ,@(map cadr in) ,@what)))
+  ) ;if
+) ;define
+
+(tm-define (tmtex-make-abstract-data keywords acm arxiv msc pacs abstract)
+  (:mode revtex-style?)
+  (with class
+    `(,@acm ,@arxiv ,@msc)
+    (set! abstract (move-in-abstract class abstract))
+  ) ;with
+  (with result
+    `(,@abstract ,@pacs ,@keywords)
+    (if (null? result) "" `(!document ,@result))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-abstract-keywords t)
+  (:mode revtex-style?)
+  (with args (tmtex-concat-sep (map tmtex (cdr t))) `(keywords ,@args))
+) ;tm-define
+
+(tm-define (tmtex-abstract-pacs t)
+  (:mode revtex-style?)
+  (with args (tmtex-concat-sep (map tmtex (cdr t))) `(pacs ,@args))
+) ;tm-define
diff --git a/TeXmacs/plugins/latex/progs/latex/convert-latex-tmtex-springer.scm b/TeXmacs/plugins/latex/progs/latex/convert-latex-tmtex-springer.scm
new file mode 100644
index 0000000000..04aa06767c
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/convert-latex-tmtex-springer.scm
@@ -0,0 +1,481 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : tmtex-springer.scm
+;; DESCRIPTION : special conversions for Springer styles
+;; COPYRIGHT   : (C) 2012  Joris van der Hoeven, François Poulain
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex convert-latex-tmtex-springer)
+  (:use (latex convert-latex-tmtex) (latex convert-latex-define))
+) ;texmacs-module
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Springer style options
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define llncs? #f)
+
+(tm-define (tmtex-style-init body) (:mode springer-style?) (set! llncs? #f))
+
+(tm-define (tmtex-style-init body) (:mode llncs-style?) (set! llncs? #t))
+
+(tm-define (tmtex-transform-style x)
+  (:mode springer-style?)
+  (if (== x "llncs") x "svjour3")
+) ;tm-define
+
+(tm-define (tmtex-transform-style x) (:mode svmono-style?) x)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Springer metadata presentation
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-make-author names affiliations emails urls miscs notes affs-l
+             emails-l urls-l miscs-l notes-l
+           ) ;tmtex-make-author
+  (:mode springer-style?)
+  (let* ((names (tmtex-concat-Sep (map cadr names)))
+         (result `(,@names ,@urls ,@notes ,@miscs))
+        ) ;
+    (if (null? result) '() `(author (!paragraph ,@result)))
+  ) ;let*
+) ;tm-define
+
+(define (springer-append in l)
+  (set! l (filter nnull? l))
+  (if (< (length l) 1)
+    l
+    (with lf
+      '(!concat (!linefeed) (and) (!linefeed))
+      `((,in (!indent (!concat ,@(list-intersperse (map cadr l) lf)))))
+    ) ;with
+  ) ;if
+) ;define
+
+(define (svjour-make-title titles notes miscs)
+  (let* ((titles (tmtex-concat-Sep (map cadr titles)))
+         (result `(,@titles ,@notes ,@miscs))
+        ) ;
+    (if (null? result) '() `((title (!concat ,@result))))
+  ) ;let*
+) ;define
+
+(define (svjour-make-doc-data titles subtits authors affs dates miscs notes tr ar)
+  `(!document ,@(svjour-make-title titles notes miscs)
+     ,@subtits
+     ,@tr
+     ,@ar
+     ,@(springer-append 'author authors)
+     ,@(springer-append 'institute affs)
+     ,@dates
+     (maketitle))
+) ;define
+
+(tm-define (tmtex-doc-data s l)
+  (:mode springer-style?)
+  (set! l (map tmtex-replace-documents l))
+  (let* ((subtitles (map tmtex-doc-subtitle (tmtex-select-args-by-func 'doc-subtitle l)))
+         (notes (map tmtex-doc-note (tmtex-select-args-by-func 'doc-note l)))
+         (miscs (map tmtex-doc-misc (tmtex-select-args-by-func 'doc-misc l)))
+         (dates (map tmtex-doc-date (tmtex-select-args-by-func 'doc-date l)))
+         (authors (map tmtex-doc-author (tmtex-select-args-by-func 'doc-author l)))
+         (ar (map tmtex-doc-running-author (tmtex-select-args-by-func 'doc-running-author l))
+         ) ;ar
+         (titles (map tmtex-doc-title (tmtex-select-args-by-func 'doc-title l)))
+         (tr (map tmtex-doc-running-title (tmtex-select-args-by-func 'doc-running-title l))
+         ) ;tr
+         (affs (map tmtex-affiliation-group
+                 (cluster-by-affiliations (tmtex-select-args-by-func 'doc-author l))
+               ) ;map
+         ) ;affs
+        ) ;
+    (svjour-make-doc-data titles subtitles authors affs dates miscs notes tr ar)
+  ) ;let*
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Springer affiliation clustering
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (springer-clear-aff aff a filter?)
+  (if (pair? (cadr a))
+    (with datas
+      (cdadr a)
+      (if (and filter?
+            (== `(,aff) (filter (lambda (x) (func? x 'author-affiliation)) datas))
+          ) ;and
+        '()
+        `(doc-author (author-data ,@(filter (lambda (x) (!= aff x)) datas)))
+      ) ;if
+    ) ;with
+    '()
+  ) ;if
+) ;define
+
+(define (next-affiliation l)
+  (cond ((or (null? l) (nlist? l)) #f)
+        ((in? (car l) '(doc-author author-data)) (next-affiliation (cdr l)))
+        ((== (car l) 'author-affiliation) l)
+        ((list? (car l))
+         (with na (next-affiliation (car l)) (if na na (next-affiliation (cdr l))))
+        ) ;
+        (else #f)
+  ) ;cond
+) ;define
+
+(define (cluster-by-affiliations l)
+  (if (nlist? l)
+    l
+    (let* ((aff (next-affiliation l))
+           (hasaff (filter (lambda (x)
+                             (or (not aff)
+                               (and (list? x) (list? (cdr x)) (list? (cadr x)) (in? aff (cdadr x)))
+                             ) ;or
+                           ) ;lambda
+                     l
+                   ) ;filter
+           ) ;hasaff
+           (hasaff* (map (lambda (x) (springer-clear-aff aff x #f)) hasaff))
+           (l* (map (lambda (x) (springer-clear-aff aff x #t)) l))
+           (l* (filter nnull? l*))
+           (aff* `(affiliation-group ,(if aff (cadr aff) '()) ,@hasaff*))
+          ) ;
+      (if aff (append `(,aff*) (cluster-by-affiliations l*)) `(,aff*))
+    ) ;let*
+  ) ;if
+) ;define
+
+(tm-define (tmtex-affiliation-group t)
+  (with old-tmtex-make-author
+    (eval tmtex-make-author)
+    (set! tmtex-make-author
+      (lambda (names affiliations emails urls miscs notes affs-l emails-l urls-l
+                miscs-l notes-l
+              ) ;names
+        (with names
+          (tmtex-concat-Sep (map cadr names))
+          (cond ((and (null? names) (null? emails)) '())
+                ((or (null? names) (null? emails)) `(!concat ,@names ,@emails))
+                (else `(!concat ,@names ," " ,@emails))
+          ) ;cond
+        ) ;with
+      ) ;lambda
+    ) ;set!
+    (let* ((affs (cadr t))
+           (affs (if (null? affs) '() `((!concat (!linefeed)
+                                          (at)
+                                          (!linefeed)
+                                          ,(tmtex affs))))
+           ) ;affs
+           (auth-sep '(!concat " " (and) " "))
+           (authors (map tmtex-doc-author (cddr t)))
+           (authors (list-intersperse authors auth-sep))
+          ) ;
+      (set! tmtex-make-author (eval old-tmtex-make-author))
+      (if (and (null? authors) (null? affs))
+        '()
+        `(institute (!concat ,@authors ,@affs))
+      ) ;if
+    ) ;let*
+  ) ;with
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Springer specific titlemarkup
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-doc-running-title t)
+  (:mode springer-style?)
+  `(titlerunning ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-doc-subtitle t)
+  (:mode springer-style?)
+  `(subtitle ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-doc-note t)
+  (:mode springer-style?)
+  `(tmnote ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-doc-misc t)
+  (:mode springer-style?)
+  `(tmmisc ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-doc-date t) (:mode springer-style?) `(date ,(tmtex (cadr t))))
+
+(tm-define (tmtex-doc-running-author t)
+  (:mode springer-style?)
+  `(authorrunning ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-author-affiliation t)
+  (:mode springer-style?)
+  `(institute ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-author-email t)
+  (:mode springer-style?)
+  `(email ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-author-homepage t)
+  (:mode springer-style?)
+  `(tmfnhomepage ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-author-note t)
+  (:mode springer-style?)
+  `(tmnote ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-author-misc t)
+  (:mode springer-style?)
+  `(tmmisc ,(tmtex (cadr t)))
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Springer specific abstract markup
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-make-abstract-data keywords acm arxiv msc pacs abstract)
+  (:mode springer-style?)
+  (:require (not llncs?))
+  (with result
+    `(,@abstract ,@arxiv ,@acm ,@msc ,@pacs ,@keywords)
+    (if (null? result) "" `(!document ,@result))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-abstract-keywords t)
+  (:mode springer-style?)
+  (:require (not llncs?))
+  (with args
+    (list-intersperse (map tmtex (cdr t)) '(!group (and)))
+    `(keywords (!concat ,@args))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-abstract-msc t)
+  (:mode springer-style?)
+  (:require (not llncs?))
+  (with args
+    (list-intersperse (map tmtex (cdr t)) '(!group (and)))
+    `(subclass (!concat ,@args))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-abstract-acm t)
+  (:mode springer-style?)
+  (:require (not llncs?))
+  (with args
+    (list-intersperse (map tmtex (cdr t)) '(!group (and)))
+    `(CRclass (!concat ,@args))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-abstract-pacs t)
+  (:mode springer-style?)
+  (:require (not llncs?))
+  (with args
+    (list-intersperse (map tmtex (cdr t)) '(!group (and)))
+    `(PACS (!concat ,@args))
+  ) ;with
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Springer SVMono style (basically like default LaTeX class with subtitle)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-transform-style x) (:mode svmono-style?) x)
+
+(tm-define (tmtex-doc-subtitle t)
+  (:mode svmono-style?)
+  `(subtitle ,(tmtex (cadr t)))
+) ;tm-define
+
+(define (svmono-make-title titles notes miscs)
+  (let* ((titles (tmtex-concat-Sep (map cadr titles)))
+         (result `(,@titles ,@notes ,@miscs))
+        ) ;
+    (if (null? result) '() `((title (!indent (!paragraph ,@result)))))
+  ) ;let*
+) ;define
+
+(tm-define (tmtex-make-doc-data titles subtitles authors dates miscs notes
+             subtits-l dates-l miscs-l notes-l tr ar
+           ) ;tmtex-make-doc-data
+  (:mode svmono-style?)
+  `(!document ,@(svmono-make-title titles notes miscs)
+     ,@subtitles
+     ,@(tmtex-append-authors authors)
+     ,@dates
+     (maketitle))
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Springer LLNCS metadata presentation
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-doc-data s l)
+  (:mode llncs-style?)
+  (set! l (map tmtex-replace-documents l))
+  (let* ((subtitles (map tmtex-doc-subtitle (tmtex-select-args-by-func 'doc-subtitle l)))
+         (notes (map tmtex-doc-note (tmtex-select-args-by-func 'doc-note l)))
+         (miscs (map tmtex-doc-misc (tmtex-select-args-by-func 'doc-misc l)))
+         (dates (map tmtex-doc-date (tmtex-select-args-by-func 'doc-date l)))
+         (ar (map tmtex-doc-running-author (tmtex-select-args-by-func 'doc-running-author l))
+         ) ;ar
+         (titles (map tmtex-doc-title (tmtex-select-args-by-func 'doc-title l)))
+         (tr (map tmtex-doc-running-title (tmtex-select-args-by-func 'doc-running-title l))
+         ) ;tr
+         (authors (tmtex-select-args-by-func 'doc-author l))
+         (affs (map tmtex-author-affiliation (collect-affiliations authors)))
+         (authors (map tmtex-doc-author (replace-affiliations authors 0)))
+        ) ;
+    (svjour-make-doc-data titles subtitles authors affs dates miscs notes tr ar)
+  ) ;let*
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Springer LLNCS affiliation clustering
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (collect-affiliations l)
+  (if (nlist? l)
+    l
+    (let* ((aff (next-affiliation l))
+           (l* (map (lambda (x) (springer-clear-aff aff x #t)) l))
+           (l* (filter nnull? l*))
+           (aff* (if aff `(affiliation-group ,(cadr aff))))
+          ) ;
+      (if aff (append `(,aff*) (collect-affiliations l*)) '())
+    ) ;let*
+  ) ;if
+) ;define
+
+(define (springer-replace-aff aff a n)
+  (let* ((ref `(author-affiliation-ref ,(number->string n))) (datas (cdadr a)))
+    `(doc-author (author-data ,@(map (lambda (x) (if (!= aff x) x ref)) datas)))
+  ) ;let*
+) ;define
+
+(define (replace-affiliations l n)
+  (with aff
+    (next-affiliation l)
+    (if (or (nlist? l) (not aff))
+      l
+      (let* ((n (1+ n))
+             (l* (filter (lambda (x) (pair? (cadr x))) l))
+             (l** (map (lambda (x) (springer-replace-aff aff x n)) l*))
+            ) ;
+        (replace-affiliations l** n)
+      ) ;let*
+    ) ;if
+  ) ;with
+) ;define
+
+(define (tmtex-author-affiliation-ref t)
+  `(inst ,(tmtex (cadr t)))
+) ;define
+
+(tm-define (tmtex-doc-author t)
+  (:mode llncs-style?)
+  (set! t (tmtex-replace-documents t))
+  (if (or (npair? t) (npair? (cdr t)) (not (func? (cadr t) 'author-data)))
+    '()
+    (let* ((datas (cdadr t))
+           (miscs (map tmtex-author-misc (tmtex-select-args-by-func 'author-misc datas)))
+           (notes (map tmtex-author-note (tmtex-select-args-by-func 'author-note datas)))
+           (emails (map tmtex-author-email (tmtex-select-args-by-func 'author-email datas))
+           ) ;emails
+           (urls (map tmtex-author-homepage (tmtex-select-args-by-func 'author-homepage datas))
+           ) ;urls
+           (names (map tmtex-author-name (tmtex-select-args-by-func 'author-name datas)))
+           (affs (map tmtex-author-affiliation-ref
+                   (tmtex-select-args-by-func 'author-affiliation-ref datas)
+                 ) ;map
+           ) ;affs
+          ) ;
+      (tmtex-make-author names affs emails urls miscs notes '() '() '() '() '())
+    ) ;let*
+  ) ;if
+) ;tm-define
+
+(tm-define (tmtex-make-author names affiliations emails urls miscs notes affs-l
+             emails-l urls-l miscs-l notes-l
+           ) ;tmtex-make-author
+  (:mode llncs-style?)
+  (let* ((names (tmtex-concat-Sep (map cadr names)))
+         (result `(,@names ,@affiliations))
+         (result (if (null? result) '() `((!concat ,@result))))
+         (result `(,@result ,@urls ,@notes ,@miscs))
+        ) ;
+    (if (null? result) '() `(author (!paragraph ,@result)))
+  ) ;let*
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; LLNCS specific abstract markup
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-abstract-keywords t)
+  (:mode springer-style?)
+  (:require llncs?)
+  (with args
+    (list-intersperse (map tmtex (cdr t)) '(!group (tmsep)))
+    `(keywords (!concat ,@args))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-make-abstract-data keywords acm arxiv msc pacs abstract)
+  (:mode springer-style?)
+  (:require llncs?)
+  (with class
+    `(,@keywords ,@acm ,@arxiv ,@msc ,@pacs)
+    (if (nnull? class)
+      (set! abstract
+        `(((!begin "abstract") (!document ,@(map cadr abstract) ,@class)))
+      ) ;set!
+    ) ;if
+    `(!document ,@abstract)
+  ) ;with
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Springer specific macros
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(smart-table latex-texmacs-env-preamble
+  (:mode sv-style?)
+  ("theorem" #f)
+  ("proposition" #f)
+  ("lemma" #f)
+  ("corollary" #f)
+  ("definition" #f)
+  ("exercise" #f)
+  ("problem" #f)
+  ("solution" #f)
+  ("remark" #f)
+  ("note" #f)
+  ("case" #f)
+  ("conjecture" #f)
+  ("example" #f)
+  ("property" #f)
+  ("question" #f)
+  ("claim" #f)
+) ;smart-table
+
+(smart-table latex-texmacs-environment (:mode sv-style?) ("proof" #f))
+
+(smart-table latex-texmacs-macro (:mode sv-style?) (qed #f))
+
+(smart-table latex-texmacs-macro (:mode svmono-style?) (chapter #f))
diff --git a/TeXmacs/plugins/latex/progs/latex/convert-latex-tmtex-widgets.scm b/TeXmacs/plugins/latex/progs/latex/convert-latex-tmtex-widgets.scm
new file mode 100644
index 0000000000..6f5d537dee
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/convert-latex-tmtex-widgets.scm
@@ -0,0 +1,147 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : tmtex-widgets.scm
+;; DESCRIPTION : manual debugging of LaTeX errors
+;; COPYRIGHT   : (C) 2015  Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex convert-latex-tmtex-widgets)
+  (:use (latex convert-latex-tmtex) (utils library cursor) (check check-master))
+) ;texmacs-module
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; The widget for examing LaTeX errors
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (latex-error-buffer)
+  (string->url "tmfs://aux/latex-error")
+) ;define
+
+(define (latex-source-buffer)
+  (string->url "tmfs://aux/latex-source")
+) ;define
+
+(define (latex-error-digest err)
+  (tree->string (tree-ref err 1))
+) ;define
+
+(define (string->document s)
+  (with l
+    (string-tokenize-by-char (string->tmstring s) #\newline)
+    `(document ,@l)
+  ) ;with
+) ;define
+
+(define (latex-error-doc* err)
+  (if (<= (tree-arity err) 2)
+    (string->document (tree->string (tree-ref err 0)))
+    `(document (padded (with ,"color"
+                         ,"dark red"
+                         ,(string->document (tree->string (tree-ref err 2))))
+                 ,"0fn"
+                 ,"0.5fn")
+       (padded (with ,"color"
+                 ,"black"
+                 ,(string->document (tree->string (tree-ref err 3))))
+         ,"0fn"
+         ,"0.5fn")
+       (padded (with ,"color"
+                 ,"dark blue"
+                 ,(string->document (tree->string (tree-ref err 4))))
+         ,"0fn"
+         ,"0.5fn")
+       (padded (with ,"color"
+                 ,"black"
+                 ,(string->document (tree->string (tree-ref err 5))))
+         ,"0fn"
+         ,"0.5fn"))
+  ) ;if
+) ;define
+
+(define (latex-error-doc err)
+  `(document (code ,(latex-error-doc* err)))
+) ;define
+
+(define (decode-path t)
+  (and (tree-func? t 'tuple)
+    (list-and (map tree-integer? (tree-children t)))
+    (map tree->number (tree-children t))
+  ) ;and
+) ;define
+
+(define (latex-error-track buf err)
+  (when (>= (tree-arity err) 8)
+    (let* ((p (decode-path (tree-ref err 7)))
+           (b (buffer-get-body buf))
+           (src (apply tree-ref (cons b p)))
+          ) ;
+      (when src
+        (with-buffer buf (tree-select src) (tree-go-to src :start))
+      ) ;when
+    ) ;let*
+  ) ;when
+) ;define
+
+(define (latex-error-show doc err)
+  (when (>= (tree-arity err) 7)
+    (let* ((pos (tree->number (tree-ref err 6)))
+           (l (- (get-line-number doc pos) 1))
+           (c (get-column-number doc pos))
+           (src (buffer-get-body "tmfs://aux/latex-source"))
+          ) ;
+      (and-with line
+        (tree-ref src l)
+        (when (and (tree-atomic? line) (<= c (string-length (tree->string line))))
+          (with-buffer "tmfs://aux/latex-source"
+            (let* ((p (tree->path line)) (b (append p (list 0))) (e (append p (list c))))
+              (selection-set b e)
+              (tree-go-to line c)
+            ) ;let*
+          ) ;with-buffer
+        ) ;when
+      ) ;and-with
+    ) ;let*
+  ) ;when
+) ;define
+
+(tm-widget ((latex-errors-widget buf doc errs) quit)
+  (let* ((digest (map latex-error-digest errs))
+         (errnr 0)
+         (err (list-ref errs errnr))
+         (sel (lambda (msg)
+                (set! errnr (or (list-find-index digest (cut == <> msg)) 0))
+                (set! err (list-ref errs errnr))
+                (buffer-set-body "tmfs://aux/latex-error"
+                  (latex-error-doc (list-ref errs errnr))
+                ) ;buffer-set-body
+                (latex-error-track buf err)
+                (latex-error-show doc err)
+              ) ;lambda
+         ) ;sel
+        ) ;
+    (padded (resize "800px" "200px" (scrollable (choice (sel answer) digest "")))
+      ======
+      (resize "800px"
+        "150px"
+        (texmacs-input (latex-error-doc (list-ref errs errnr))
+          '(style (tuple "generic"))
+          (latex-error-buffer)
+        ) ;texmacs-input
+      ) ;resize
+      ======
+      (resize "800px"
+        "450px"
+        (texmacs-input (string->document doc)
+          '(style (tuple "verbatim-source"))
+          (latex-source-buffer)
+        ) ;texmacs-input
+      ) ;resize
+    ) ;padded
+  ) ;let*
+) ;tm-widget
diff --git a/TeXmacs/plugins/latex/progs/latex/convert-latex-tmtex.scm b/TeXmacs/plugins/latex/progs/latex/convert-latex-tmtex.scm
new file mode 100644
index 0000000000..c7e8b4c938
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/convert-latex-tmtex.scm
@@ -0,0 +1,4713 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : tmtex.scm
+;; DESCRIPTION : conversion of TeXmacs trees into TeX/LaTeX trees
+;; COPYRIGHT   : (C) 2002  Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex convert-latex-tmtex)
+  (:use (convert tools tmpre)
+    (convert tools old-tmtable)
+    (convert tools tmlength)
+    (convert rewrite tmtm-brackets)
+    (latex convert-latex-texout)
+    (doc tmdoc-markup)
+    (latex convert-latex-tools)
+  ) ;:use
+) ;texmacs-module
+
+
+(tm-define tmtex-debug-mode? #f)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Global variables
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define tmtex-style "generic")
+(tm-define tmtex-packages '())
+(tm-define tmtex-replace-style? #t)
+
+(define tmtex-languages '())
+
+(define tmtex-colors '())
+
+(define tmtex-colormaps '())
+
+(define tmtex-env (make-ahash-table))
+
+(define tmtex-macros (make-ahash-table))
+
+(define tmtex-dynamic (make-ahash-table))
+
+(define tmtex-serial 0)
+
+(define tmtex-ref-cnt 1)
+
+(define tmtex-auto-produce 0)
+
+(define tmtex-auto-consume 0)
+
+(define tmtex-image-root-url (unix->url "image"))
+
+(define tmtex-image-root-string "image")
+
+(define tmtex-appendices? #f)
+
+(define tmtex-indirect-bib? #f)
+
+(define tmtex-mathjax? #f)
+
+(define tmtex-image-progress 0)
+
+(define tmtex-image-total 0)
+
+(define tmtex-progress? #f)
+
+(define (tmtex-count-images t)
+  (cond ((null? t) 0)
+        ((npair? t) 0)
+        ((in? (car t)
+           '(image graphics draw-over draw-under para table tformat equation
+              equation* eqnarray eqnarray* section subsection subsubsection)
+         ) ;in?
+         1
+        ) ;
+        (else (let loop
+                ((lst t) (sum 0))
+                (if (null? lst)
+                  sum
+                  (if (pair? lst)
+                    (loop (cdr lst) (+ sum (tmtex-count-images (car lst))))
+                    (+ sum (tmtex-count-images lst))
+                  ) ;if
+                ) ;if
+              ) ;let
+        ) ;else
+  ) ;cond
+) ;define
+
+(define (tmtex-image-increment)
+  (set! tmtex-image-progress (+ tmtex-image-progress 1))
+  (when (and tmtex-progress? (> tmtex-image-total 0))
+    (latex-progress-update tmtex-image-progress)
+  ) ;when
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Style
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-modes
+  ;;; Elsevier styles
+  (elsevier-style% (in? tmtex-style '("elsart" "jsc" "elsarticle" "ifac")))
+  (jsc-style% (in? tmtex-style '("jsc")) elsevier-style%)
+  (elsarticle-style% (in? tmtex-style '("elsarticle")) elsevier-style%)
+  (elsart-style% (in? tmtex-style '("elsart")) elsevier-style%)
+  (ifac-style% (in? tmtex-style '("ifac")) elsevier-style%)
+
+  ;;; ACM styles
+  (acm-style% (in? tmtex-style
+                '("acmconf" "sig-alternate" "acm_proc_article-sp" "acmsmall"
+                  "acmlarge" "acmtog" "sigconf" "sigchi" "sigplan" "acmart")
+              ) ;in?
+  ) ;acm-style%
+  (acm-art-style% (in? tmtex-style
+                    '("acmsmall" "acmlarge" "acmtog" "sigconf" "sigchi"
+                      "sigplan" "acmart")
+                  ) ;in?
+    acm-style%
+  ) ;acm-art-style%
+  (sig-alternate-style% (in? tmtex-style '("sig-alternate")) acm-style%)
+  (acm-conf-style% (in? tmtex-style '("acmconf"
+                                      "sig-alternate"
+                                      "acm_proc_article-sp"))
+    acm-style%
+  ) ;acm-conf-style%
+  (acm-small-style% (in? tmtex-style '("acmsmall")) acm-art-style%)
+  (acm-large-style% (in? tmtex-style '("acmlarge")) acm-art-style%)
+  (acm-tog-style% (in? tmtex-style '("acmtog")) acm-art-style%)
+  (acm-sigconf-style% (in? tmtex-style '("sigconf")) acm-art-style%)
+  (acm-sigchi-style% (in? tmtex-style '("sigchi")) acm-art-style%)
+  (acm-sigplan-style% (in? tmtex-style '("sigplan")) acm-art-style%)
+
+  ;; AMS styles
+  (ams-style% (in? tmtex-style '("amsart")))
+
+  ;; Revtex styles
+  (revtex-style% (in? tmtex-style '("aip" "aps")))
+  (aip-style% (in? tmtex-style '("aip")) revtex-style%)
+  (aps-style% (in? tmtex-style '("aps")) revtex-style%)
+  (sv-style% (in? tmtex-style '("svjour" "svjour3" "llncs" "svmono")))
+
+  ;; Springer styles
+  (springer-style% (in? tmtex-style '("svjour" "svjour3" "llncs" sv-style%)))
+  (svjour-style% (in? tmtex-style '("svjour" "svjour3")) springer-style%)
+  (llncs-style% (in? tmtex-style '("llncs")) springer-style%)
+  (svmono-style% (in? tmtex-style '("svmono")) sv-style%)
+
+  ;; IEEE styles
+  (ieee-style% (in? tmtex-style '("ieeeconf" "ieeetran")))
+  (ieee-conf-style% (in? tmtex-style '("ieeeconf")) ieee-style%)
+  (ieee-tran-style% (in? tmtex-style '("ieeetran")) ieee-style%)
+
+  ;; Other styles
+  (beamer-style% (in? tmtex-style '("beamer" "old-beamer")))
+  (natbib-package% (in? "cite-author-year" tmtex-packages))
+) ;texmacs-modes
+
+(tm-define (tmtex-style-init body) (noop))
+
+(tm-define (tmtex-style-preprocess doc) doc)
+
+(define (import-tmtex-styles)
+  (cond ((elsevier-style?) (import-from (latex convert-latex-tmtex-elsevier)))
+        ((acm-style?) (import-from (latex convert-latex-tmtex-acm)))
+        ((ams-style?) (import-from (latex convert-latex-tmtex-ams)))
+        ((revtex-style?) (import-from (latex convert-latex-tmtex-revtex)))
+        ((ieee-style?) (import-from (latex convert-latex-tmtex-ieee)))
+        ((beamer-style?) (import-from (latex convert-latex-tmtex-beamer)))
+        ((or (springer-style?) (svmono-style?))
+         (import-from (latex convert-latex-tmtex-springer))
+        ) ;
+        (else (noop))
+  ) ;cond
+) ;define
+
+(tm-define (tmtex-provided-packages) '())
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Initialization from options
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (tmtex-initialize opts)
+  (set! tmtex-image-progress 0)
+  (set! tmtex-progress? #f)
+  (set! tmtex-ref-cnt 1)
+  (set! tmtex-env (make-ahash-table))
+  (set! tmtex-macros (make-ahash-table))
+  (set! tmtex-dynamic (make-ahash-table))
+  (set! tmtex-serial 0)
+  (set! tmtex-auto-produce 0)
+  (set! tmtex-auto-consume 0)
+  (set! tmtex-mathjax? #f)
+  (if (== (url-suffix current-save-target) "tex")
+    (begin
+      (set! tmtex-image-root-url (url-unglue current-save-target 4))
+      (with suf
+        (url-suffix tmtex-image-root-url)
+        (when (!= suf "")
+          (set! tmtex-image-root-url
+            (url-unglue tmtex-image-root-url (+ (string-length suf) 1))
+          ) ;set!
+        ) ;when
+      ) ;with
+      (set! tmtex-image-root-string (url->unix (url-tail tmtex-image-root-url)))
+    ) ;begin
+    (begin
+      (set! tmtex-image-root-url (unix->url "image"))
+      (set! tmtex-image-root-string "image")
+    ) ;begin
+  ) ;if
+  (set! tmtex-appendices? #f)
+  (set! tmtex-replace-style?
+    (== (assoc-ref opts "texmacs->latex:replace-style") "on")
+  ) ;set!
+  (set! tmtex-indirect-bib?
+    (== (assoc-ref opts "texmacs->latex:indirect-bib") "on")
+  ) ;set!
+  (set! tmtex-use-macros? (== (assoc-ref opts "texmacs->latex:use-macros") "on"))
+  (when (== (assoc-ref opts "texmacs->latex:mathjax") "on")
+    (tmtex-env-set "mode" "math")
+    (set! tmtex-mathjax? #t)
+  ) ;when
+  (with charset
+    (or (assoc-ref opts "texmacs->latex:encoding") "utf-8")
+    (if tmtex-cjk-document? (set! charset "utf-8"))
+    (cond ((== (locase-all charset) "utf-8")
+           (set! tmtex-use-catcodes? #f)
+           (set! tmtex-use-unicode? #t)
+          ) ;
+          ((== charset "cork") (set! tmtex-use-catcodes? #t) (set! tmtex-use-unicode? #f))
+    ) ;cond
+  ) ;with
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Determination of the mode in which commands are used
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define command-text-uses (make-ahash-table))
+
+(define command-math-uses (make-ahash-table))
+
+(define (compute-mode-stats t mode)
+  (when (tree-compound? t)
+    (let* ((h (if (== mode (tree "math")) command-math-uses command-text-uses))
+           (n (or (ahash-ref h (tree-label t)) 0))
+          ) ;
+      (ahash-set! h (tree-label t) (+ n 1))
+      (for-each (lambda (i)
+                  (with nmode
+                    (tree-child-env t i "mode" mode)
+                    (compute-mode-stats (tree-ref t i) nmode)
+                  ) ;with
+                ) ;lambda
+        (.. 0 (tree-arity t))
+      ) ;for-each
+    ) ;let*
+  ) ;when
+) ;define
+
+(define (init-mode-stats t)
+  (set! command-text-uses (make-ahash-table))
+  (set! command-math-uses (make-ahash-table))
+  (compute-mode-stats (tm->tree t) "text")
+) ;define
+
+(define (mode-protect t)
+  (cond ((and (pair? t)
+           (symbol? (car t))
+           (string-starts? (symbol->string (car t)) "tmtext")
+         ) ;and
+         `(text ,t)
+        ) ;
+        ((and (pair? t)
+           (symbol? (car t))
+           (or (string-starts? (symbol->string (car t)) "tmmath")
+             (string-starts? (symbol->string (car t)) "math")
+           ) ;or
+         ) ;and
+         `(ensuremath ,t)
+        ) ;
+        ((func? t '!concat) `(!concat ,@(map mode-protect (cdr t))))
+        (else t)
+  ) ;cond
+) ;define
+
+(define (tmtex-pre t)
+  (cond ((tm-func? t 'para) (cons '!paragraph (map-in-order tmtex-pre (tm-children t))))
+        ((tm-func? t 'concat)
+         (cons '!paragraph (map-in-order tmtex-pre (tm-children t)))
+        ) ;
+        ((tm-func? t 'mtm 2) `(mtm ,(cadr t) ,(tmtex-pre (caddr t))))
+        ((and (tm-func? t 'assign 2) (tm-atomic? (tm-ref t 0)))
+         (let* ((name (tm-ref t 0))
+                (tag (string->symbol name))
+                (tnr (or (ahash-ref command-text-uses tag) 0))
+                (mnr (or (ahash-ref command-math-uses tag) 0))
+               ) ;
+           ;; (display* tag ", " tnr ", " mnr "\n")
+           (cond ((and (string-ends? name "*")
+                    (or (string-starts? name "itemize")
+                      (string-starts? name "enumerate")
+                      (string-starts? name "description")
+                    ) ;or
+                  ) ;and
+                  ""
+                 ) ;
+                 ((>= tnr mnr)
+                  (with r
+                    (tmtex t)
+                    ;; (display* t " -> " r "\n")
+                    (when (and (> mnr 0) (func? r 'newcommand 2))
+                      (with val (mode-protect (caddr r)) (set! r (list (car r) (cadr r) val)))
+                    ) ;when
+                    r
+                  ) ;with
+                 ) ;
+                 (else (tmtex-env-set "mode" "math")
+                   (with r
+                     (tmtex t)
+                     (tmtex-env-reset "mode")
+                     ;; (display* t " -> " r "\n")
+                     (when (and (> tnr 0) (func? r 'newcommand 2))
+                       (with val (mode-protect (caddr r)) (set! r (list (car r) (cadr r) val)))
+                     ) ;when
+                     r
+                   ) ;with
+                 ) ;else
+           ) ;cond
+         ) ;let*
+        ) ;
+        (else (tmtex t))
+  ) ;cond
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Data
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-table tmtex-table-props%
+  (block ("" "l" "" #t))
+  (block* ("" "c" "" #t))
+  (wide-block ("{\\noindent}" "@{}X@{}" "" #t))
+  (tabular ("" "l" "" #f))
+  (tabular* ("" "c" "" #f))
+  (wide-tabular ("{\\noindent}" "@{}X@{}" "" #f))
+  (matrix ((,(string->symbol "left(")) "c" (,(string->symbol "right)")) #f))
+  (det ((left|) "c" (right|) #f))
+  (bmatrix ((,(string->symbol "left[")) "c" (,(string->symbol "right]")) #f))
+  (stack ("" "c" "" #f))
+  (choice ((left\{) "l" (right.) #f))
+  (tabbed ("" "l" "" #f))
+  (tabbed* ("" "l" "" #f))
+  (rcl-table ("{\\setlength\\arraylinesep{0.4em}\\everymath={\\displaystyle}" "rcl" "}" #f)
+  ) ;rcl-table
+  (three-line-table ("" "c" "" #f))
+) ;logic-table
+
+(logic-table tex-with-cmd%
+ (("font-family" "rm") textrm)
+ (("font-family" "ss") textsf)
+ (("font-family" "tt") texttt)
+ (("font-series" "medium") textmd)
+ (("font-series" "bold") textbf)
+ (("font-shape" "right") textup)
+ (("font-shape" "slanted") textsl)
+ (("font-shape" "italic") textit)
+ (("font-shape" "small-caps") textsc)
+ (("par-columns" "2") (!begin "multicols" "2"))
+ (("par-columns" "3") (!begin "multicols" "3"))
+ (("par-mode" "center") (!begin "center"))
+ (("par-mode" "left") (!begin "flushleft"))
+ (("par-mode" "right") (!begin "flushright"))
+) ;logic-table
+
+(logic-table tex-with-cmd-math%
+ (("font" "cal") mathcal)
+ (("font" "cal*") mathscr)
+ (("font" "cal**") EuScript)
+ (("font" "Euler") mathfrak)
+ (("font" "Bbb") mathbb)
+ (("font" "Bbb*") mathbbm)
+ (("font" "Bbb**") mathbbmss)
+ (("font" "Bbb***") mathbb)
+ (("font" "Bbb****") mathds)
+ (("font-family" "rm") mathrm)
+ (("font-family" "ss") mathsf)
+ (("font-family" "tt") mathtt)
+ (("font-series" "medium") tmmathmd)
+ (("font-series" "bold") tmmathbf)
+ (("font-shape" "right") mathrm)
+ (("font-shape" "slanted") mathit)
+ (("font-shape" "italic") mathit)
+ (("font-shape" "small-caps") mathrm)
+ (("math-font" "cal") mathcal)
+ (("math-font" "cal*") mathscr)
+ (("math-font" "cal**") EuScript)
+ (("math-font" "Euler") mathfrak)
+ (("math-font" "Bbb") mathbb)
+ (("math-font" "Bbb*") mathbbm)
+ (("math-font" "Bbb**") mathbbmss)
+ (("math-font" "Bbb***") mathbb)
+ (("math-font" "Bbb****") mathds)
+ (("math-font-family" "mr") mathrm)
+ (("math-font-family" "ms") mathsf)
+ (("math-font-family" "mt") mathtt)
+ (("math-font-family" "normal") mathnormal)
+ (("math-font-family" "rm") mathrm)
+ (("math-font-family" "ss") mathsf)
+ (("math-font-family" "tt") mathtt)
+ (("math-font-family" "bf") mathbf)
+ (("math-font-family" "it") mathit)
+ (("math-font-series" "bold") tmmathbf)
+) ;logic-table
+
+(logic-table tex-assign-cmd%
+ (("font-family" "rm") rmfamily)
+ (("font-family" "ss") ssfamily)
+ (("font-family" "tt") ttfamily)
+ (("font-series" "medium") mdseries)
+ (("font-series" "bold") bfseries)
+ (("font-shape" "right") upshape)
+ (("font-shape" "slanted") slshape)
+ (("font-shape" "italic") itshape)
+ (("font-shape" "small-caps") scshape)
+) ;logic-table
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Manipulation of the environment
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (tmtex-env-list var)
+  (let ((r (ahash-ref tmtex-env var)))
+    (if r r '())
+  ) ;let
+) ;define
+
+(define (tmtex-env-get var)
+  (let ((val (tmtex-env-list var)))
+    (and (pair? val) (car val))
+  ) ;let
+) ;define
+
+(define (tmtex-env-get-previous var)
+  (let ((val (tmtex-env-list var)))
+    (if (or (null? val) (null? (cdr val))) #f (cadr val))
+  ) ;let
+) ;define
+
+(define (tmtex-math-mode?)
+  (== (tmtex-env-get "mode") "math")
+) ;define
+
+(tm-define (tmtex-env-set var val)
+  (ahash-set! tmtex-env var (cons val (tmtex-env-list var)))
+) ;tm-define
+
+(tm-define (tmtex-env-reset var)
+  (let ((val (tmtex-env-list var)))
+    (if (nnull? val) (ahash-set! tmtex-env var (cdr val)))
+  ) ;let
+) ;tm-define
+
+(tm-define (tmtex-env-assign var val)
+  (tmtex-env-reset var)
+  (tmtex-env-set var val)
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Frequently used TeX construction subroutines
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-concat-sep l)
+  (set! l (list-intersperse l '(!concat (tmsep) " ")))
+  (if (null? l) '() `((!concat ,@l)))
+) ;tm-define
+
+(tm-define (tmtex-concat-Sep l)
+  (set! l (list-intersperse l '(!concat (tmSep) " ")))
+  (if (null? l) '() `((!concat ,@l)))
+) ;tm-define
+
+(define (tex-concat-similar l)
+  (cond ((or (null? l) (null? (cdr l))) l)
+        ((> (length l) 1000)
+         (let* ((s (quotient (length l) 2)) (h (list-head l s)) (t (list-tail l s)))
+           (tex-concat-similar `((!concat ,@h) (!concat ,@t)))
+         ) ;let*
+        ) ;
+        (else (let ((r (tex-concat-similar (cdr l))))
+                (cond ((and (func? (car l) '!sub) (func? (car r) '!sub))
+                       (cons (list '!sub (tex-concat (list (cadar l) (cadar r)))) (cdr r))
+                      ) ;
+                      ((and (func? (car l) '!sup) (func? (car r) '!sup))
+                       (cons (list '!sup (tex-concat (list (cadar l) (cadar r)))) (cdr r))
+                      ) ;
+                      (else (cons (car l) r))
+                ) ;cond
+              ) ;let
+        ) ;else
+  ) ;cond
+) ;define
+
+(define (tex-concat-list l)
+  (cond ((null? l) l)
+        ((== (car l) "") (tex-concat-list (cdr l)))
+        ((func? (car l) '!concat) (append (cdar l) (tex-concat-list (cdr l))))
+        (else (cons (car l) (tex-concat-list (cdr l))))
+  ) ;cond
+) ;define
+
+(tm-define (tex-concat l)
+  (:synopsis "Horizontal concatenation of list of LaTeX expressions")
+  (let ((r (tex-concat-similar (tex-concat-list l))))
+    (if (null? r) "" (if (null? (cdr r)) (car r) (cons '!concat r)))
+  ) ;let
+) ;tm-define
+
+(define (tex-concat-strings l)
+  (cond ((< (length l) 2) l)
+        ((and (string? (car l)) (string? (cadr l)))
+         (tex-concat-strings (cons (string-append (car l) (cadr l)) (cddr l)))
+        ) ;
+        (else (cons (car l) (tex-concat-strings (cdr l))))
+  ) ;cond
+) ;define
+
+(tm-define (tex-concat* l)
+  (:synopsis "Variant of tex-concat which concatenates adjacent strings")
+  (tex-concat (tex-concat-strings l))
+) ;tm-define
+
+(tm-define (tex-apply . l)
+  (if (or (tmtex-math-mode?) (logic-in? (car l) tmpre-sectional%))
+    l
+    (list '!group l)
+  ) ;if
+) ;tm-define
+
+(tm-define (tex-math-apply . l) (if (tmtex-math-mode?) l (list 'ensuremath l)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Strings
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (string-starts? s r)
+  (and (>= (string-length s) (string-length r))
+    (== (substring s 0 (string-length r)) r)
+  ) ;and
+) ;define
+
+(define (tmtex-modified-token op s i)
+  (tex-math-apply op
+    (if (= (string-length s) (+ i 1))
+      (substring s i (string-length s))
+      (tex-apply (string->symbol (substring s i (string-length s))))
+    ) ;if
+  ) ;tex-math-apply
+) ;define
+
+(logic-table latex-special-symbols%
+ ("less" #\<)
+ ("gtr" #\>)
+ ("box" (Box))
+ ("over" #\:)
+ ("||" (|))
+ ;; |
+ ("precdot" (tmprecdot))
+) ;logic-table
+
+(logic-table latex-text-symbols%
+ ("#20AC" euro)
+ ("cent" textcent)
+ ("circledR" textregistered)
+ ("copyright" textcopyright)
+ ("currency" textcurrency)
+ ("degree" textdegree)
+ ("textdegree" textdegree)
+ ("mu" textmu)
+ ("onehalf" textonehalf)
+ ("onequarter" textonequarter)
+ ("onesuperior" textonesuperior)
+ ("paragraph" P)
+ ("threequarters" textthreequarters)
+ ("threesuperior" textthreesuperior)
+ ("trademark" texttrademark)
+ ("twosuperior" texttwosuperior)
+ ("yen" textyen)
+) ;logic-table
+
+(tm-define (tmtex-token-sub s group?)
+  (cond ((logic-ref latex-special-symbols% s) (logic-ref latex-special-symbols% s))
+        ((string-starts? s "up-") (tmtex-modified-token 'mathrm s 3))
+        ;; ((string-starts? s "bbb-") (tmtex-modified-token 'mathbbm s 4))
+        ((and (string-starts? s "bbb-")
+           (>= (string-length s) 5)
+           (string-number? (substring s 4 5))
+         ) ;and
+         (tmtex-modified-token 'mathbbm s 4)
+        ) ;
+        ((string-starts? s "bbb-") (tmtex-modified-token 'mathbb s 4))
+        ((string-starts? s "cal-") (tmtex-modified-token 'mathcal s 4))
+        ((and (string-starts? s "cal*-") (>= (string-length s) 6))
+         (tmtex-modified-token 'mathscr s 5)
+        ) ;
+        ((and (string-starts? s "cal**-") (>= (string-length s) 7))
+         (tmtex-modified-token 'EuScript s 6)
+        ) ;
+        ((string-starts? s "frak-") (tmtex-modified-token 'mathfrak s 5))
+        ((string-starts? s "b-cal-")
+         (tex-math-apply 'tmmathbf (tmtex-modified-token 'mathcal s 6))
+        ) ;
+        ((string-starts? s "b-up-") (tmtex-modified-token 'mathbf s 5))
+        ((string-starts? s "b-") (tmtex-modified-token 'tmmathbf s 2))
+        ((and (not (tmtex-math-mode?)) (logic-ref latex-text-symbols% s))
+         (list '!group (list (logic-ref latex-text-symbols% s)))
+        ) ;
+        ((and (string-starts? s "#") (not tmtex-use-catcodes?))
+         (let* ((qs (string-append "<" s ">")) (cv (string-convert qs "Cork" "UTF-8")))
+           (list '!widechar (string->symbol cv))
+         ) ;let*
+        ) ;
+        ((and (string-starts? s "#") tmtex-use-catcodes?)
+         (let* ((qs (string-append "<" s ">"))
+                (us (string-convert qs "Cork" "UTF-8"))
+                (cv (string-convert us "UTF-8" "LaTeX"))
+               ) ;
+           (list '!widechar (string->symbol cv))
+         ) ;let*
+        ) ;
+        (else (let* ((s2 (string-replace s "-" "")) (ss (list (string->symbol s2))))
+                (cond ((logic-in? (car ss) tmtex-protected-symbol%)
+                       (with sy (string->symbol (string-append "tmx" s2)) (list '!symbol (list sy)))
+                      ) ;
+                      ((not (logic-in? (car ss) latex-symbol%))
+                       (display* "TeXmacs] non converted symbol: " s "\n")
+                       (list '!symbol (list 'nonconverted s2))
+                      ) ;
+                      (group? (list '!group ss))
+                      (else (list '!symbol ss))
+                ) ;cond
+              ) ;let*
+        ) ;else
+  ) ;cond
+) ;tm-define
+
+(define (tmtex-token l routine group?)
+  (receive (p1 p2)
+    (list-break (cdr l) (lambda (x) (== x #\>)))
+    (let* ((s (list->string p1)) (q (if (null? p2) '() (cdr p2))) (r (routine q)))
+      (cons (tmtex-token-sub s group?) r)
+    ) ;let*
+  ) ;receive
+) ;define
+
+(define (tmtex-text-sub head l)
+  (if (string? head)
+    (append (string->list head) (tmtex-text-list (cdr l)))
+    (append (list head) (tmtex-text-list (cdr l)))
+  ) ;if
+) ;define
+
+(define (tmtex-special-char? c)
+  (string-index "#$%&_{}" c)
+) ;define
+
+(define (tmtex-break-char? c)
+  (string-index "+ -:=,?;()[]{}<>/" c)
+) ;define
+
+(define (tmtex-text-list-space l)
+  (cond ((null? l) l)
+        ((== (car l) #\space)
+         (cons (list (string->symbol " ")) (tmtex-text-list-space (cdr l)))
+        ) ;
+        (else (tmtex-text-list l))
+  ) ;cond
+) ;define
+
+(define (tmtex-text-list l)
+  (if (null? l)
+    l
+    (let ((c (car l)))
+      (cond ((== c #\<) (tmtex-token l tmtex-text-list #t))
+            ((== c #\space) (cons c (tmtex-text-list-space (cdr l))))
+            ((tmtex-special-char? c)
+             (cons (list (string->symbol (char->string c))) (tmtex-text-list (cdr l)))
+            ) ;
+            ((== c #\~) (tmtex-text-sub "\\~{}" l))
+            ((== c #\^) (tmtex-text-sub "\\^{}" l))
+            ((== c #\\) (tmtex-text-sub '(textbackslash) l))
+            ((== c #\`) (tmtex-text-sub "`" l))
+            ((== c #\x00) (tmtex-text-sub "\\`{}" l))
+            ((== c #\x01) (tmtex-text-sub "\\'{}" l))
+            ((== c #\x04) (tmtex-text-sub "\\\"{}" l))
+            ((== c #\x05) (tmtex-text-sub "\\H{}" l))
+            ((== c #\x06) (tmtex-text-sub "\\r{}" l))
+            ((== c #\x07) (tmtex-text-sub "\\v{}" l))
+            ((== c #\x08) (tmtex-text-sub "\\u{}" l))
+            ((== c #\x09) (tmtex-text-sub "\\={}" l))
+            ((== c #\x0A) (tmtex-text-sub "\\.{}" l))
+            ((== c #\x0E) (tmtex-text-sub "\\k{}" l))
+            ((== c #\x10) (tmtex-text-sub "``" l))
+            ((== c #\x11) (tmtex-text-sub "''" l))
+            ((== c #\x12) (tmtex-text-sub ",," l))
+            ((== c #\x15) (tmtex-text-sub "--" l))
+            ((== c #\x16) (tmtex-text-sub "---" l))
+            ((== c #\x17) (tmtex-text-sub "{}" l))
+            ((== c #\x1B) (tmtex-text-sub "ff" l))
+            ((== c #\x1C) (tmtex-text-sub '(textbackslash) l))
+            ((== c #\x1D) (tmtex-text-sub "fl" l))
+            ((== c #\x1E) (tmtex-text-sub "ffi" l))
+            ((== c #\x1F) (tmtex-text-sub "ffl" l))
+            ((== c #\|) (tmtex-text-sub '(textbar) l))
+            (else (append (if tmtex-use-unicode?
+                            (string->list (string-convert (char->string c) "Cork" "UTF-8"))
+                            (list c)
+                          ) ;if
+                    (tmtex-text-list (cdr l))
+                  ) ;append
+            ) ;else
+      ) ;cond
+    ) ;let
+  ) ;if
+) ;define
+
+(define (tmtex-math-operator l)
+  (receive (p q)
+    (list-break l (lambda (c) (not (char-alphabetic? c))))
+    (let* ((op (tmtex-textual (list->string p))) (tail (tmtex-math-list q)))
+      (if (logic-in? (string->symbol op) latex-operator%)
+        (cons (list '!symbol (tex-apply (string->symbol op))) tail)
+        (cons (post-process-math-text (tex-apply 'tmop op)) tail)
+      ) ;if
+    ) ;let*
+  ) ;receive
+) ;define
+
+(define (tmtex-math-list l)
+  (if (null? l)
+    l
+    (let ((c (car l)))
+      (cond ((== c #\<) (tmtex-token l tmtex-math-list #f))
+            ((tmtex-special-char? c)
+             (cons (list (string->symbol (char->string c))) (tmtex-math-list (cdr l)))
+            ) ;
+            ((== c #\~) (tmtex-math-list (cdr l)))
+            ((== c #\^) (tmtex-math-list (cdr l)))
+            ((== c #\\) (cons (list 'backslash) (tmtex-math-list (cdr l))))
+            ;;            ((== c #\*) (cons '(*) (tmtex-math-list (cdr l))))
+            ((== c #\*) (tmtex-math-list (cdr l)))
+            ((== c #\') (append (list '(prime)) (tmtex-math-list (cdr l))))
+            ((== c #\`) (append (list '(backprime)) (tmtex-math-list (cdr l))))
+            ;;            ((== c #\space) (tmtex-math-list (cdr l)))
+            ((and (char-alphabetic? c) (nnull? (cdr l)) (char-alphabetic? (cadr l)))
+             (tmtex-math-operator l)
+            ) ;
+            (else (with c
+                    (if tmtex-use-unicode?
+                      (string->list (string-convert (char->string c) "Cork" "UTF-8"))
+                      (list c)
+                    ) ;if
+                    (append c (tmtex-math-list (cdr l)))
+                  ) ;with
+            ) ;else
+      ) ;cond
+    ) ;let
+  ) ;if
+) ;define
+
+(define (tmtex-verb-list l)
+  (if (null? l)
+    l
+    (let ((c (car l)))
+      (if (== c #\<)
+        (let ((r (tmtex-token l tmtex-verb-list #t)))
+          (if (char? (car r)) r (cdr r))
+        ) ;let
+        (cons c (tmtex-verb-list (cdr l)))
+      ) ;if
+    ) ;let
+  ) ;if
+) ;define
+
+(define (tmtex-string-break? x start)
+  (or (not (char? x))
+    (and (tmtex-math-mode?)
+      (or (tmtex-break-char? x)
+        (and (char-alphabetic? x) (char-numeric? start))
+        (and (char-alphabetic? start) (char-numeric? x))
+      ) ;or
+    ) ;and
+  ) ;or
+) ;define
+
+(define (tmtex-string-produce l)
+  (if (null? l)
+    l
+    (if (not (tmtex-string-break? (car l) (car l)))
+      (receive (p q)
+        (list-break l (lambda (x) (tmtex-string-break? x (car l))))
+        (cons (list->string p) (tmtex-string-produce q))
+      ) ;receive
+      (if (equal? (car l) #\space)
+        (tmtex-string-produce (cdr l))
+        (cons (if (char? (car l)) (char->string (car l)) (car l))
+          (tmtex-string-produce (cdr l))
+        ) ;cons
+      ) ;if
+    ) ;if
+  ) ;if
+) ;define
+
+(define (tmtex-string s)
+  (if (> (string-length s) 1000)
+    `(!concat ,@(map tmtex (tmstring-split s)))
+    (let* ((l (string->list s))
+           (t (if (tmtex-math-mode?) (tmtex-math-list l) (tmtex-text-list l)))
+           (r (tmtex-string-produce t))
+          ) ;
+      (tex-concat r)
+    ) ;let*
+  ) ;if
+) ;define
+
+(define (string-convert* what from to)
+  (with c
+    (string->list what)
+    (apply string-append
+      (map (lambda (x) (string-convert (char->string x) from to)) c)
+    ) ;apply
+  ) ;with
+) ;define
+
+(define (tmtex-verb-string s)
+  (when (nstring? s)
+    (set! s (texmacs->verbatim (tm->tree s)))
+  ) ;when
+  (let* ((l (string->list s)) (t (tmtex-verb-list l)) (r (tmtex-string-produce t)))
+    (if tmtex-use-unicode?
+      (set! r (map (lambda (x) (string-convert* x "Cork" "UTF-8")) r))
+      (set! r (map unescape-angles r))
+    ) ;if
+    (tex-concat r)
+  ) ;let*
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Entire files
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-transform-style x)
+  (cond ((in? x
+           '("generic" "exam" "old-generic" "old-article" "tmarticle" "tmdoc"
+             "mmxdoc")
+         ) ;in?
+         "article"
+        ) ;
+        ((in? x '("book" "old-book" "tmbook" "tmmanual")) "book")
+        ((in? x '("letter" "old-letter")) "letter")
+        ((in? x '("beamer" "old-beamer")) "beamer")
+        ((in? x '("seminar" "old-seminar")) "slides")
+        ((not tmtex-replace-style?) x)
+        (else #f)
+  ) ;cond
+) ;tm-define
+
+(define (tmtex-filter-styles l)
+  (if (null? l)
+    l
+    (let* ((next (tmtex-transform-style (car l))) (tail (tmtex-filter-styles (cdr l))))
+      (if next (cons next tail) tail)
+    ) ;let*
+  ) ;if
+) ;define
+
+(define (macro-definition? x)
+  (and (func? x 'assign 2) (string? (cadr x)) (func? (caddr x) 'macro))
+) ;define
+
+(define (tmtex-filter-style-macro t)
+  (letrec ((ndef-style? (lambda (x env) (or (not (macro-definition? x)) (nin? (cadr x) env)))
+           ) ;ndef-style?
+           (filter-style-macro (lambda (t env)
+                                 (cond ((nlist? t) t)
+                                       (else (map (cut filter-style-macro <> env) (filter (cut ndef-style? <> env) t)))
+                                 ) ;cond
+                               ) ;lambda
+           ) ;filter-style-macro
+          ) ;
+    (with env
+      (append (logic-first-list 'tmtex-methods%) (logic-first-list 'tmtex-tmstyle%))
+      (filter-style-macro t env)
+    ) ;with
+  ) ;letrec
+) ;define
+
+(define (comment-preamble t)
+  (cond ((string? t) `(!comment ,t))
+        ((or (func? t 'para) (func? t 'concat) (func? t 'document))
+         (map comment-preamble t)
+        ) ;
+        (else t)
+  ) ;cond
+) ;define
+
+(define (tmtex-filter-preamble l)
+  (cond ((or (nlist? l) (null? l)) '())
+        ((macro-definition? l) (list l))
+        ((and (func? l 'hide-preamble 1) (list>0? (cadr l)))
+         (map comment-preamble (cdadr l))
+        ) ;
+        (else (append-map tmtex-filter-preamble (cdr l)))
+  ) ;cond
+) ;define
+
+(define (tmtex-non-preamble-statement? l)
+  (cond ((or (nlist? l) (null? l)) #t)
+        ((== (car l) 'assign) #f)
+        ((== (car l) 'hide-preamble) #f)
+        ((func? l 'mtm 2) (tmtex-non-preamble-statement? (caddr l)))
+        (else #t)
+  ) ;cond
+) ;define
+
+(define (tmtex-filter-body l)
+  (cond ((or (nlist? l) (null? l)) l)
+        ((== (car l) 'assign) "")
+        ((== (car l) 'hide-preamble) "")
+        ((in? (car l) '(concat document))
+         (with a
+           (list-filter (cdr l) tmtex-non-preamble-statement?)
+           (if (null? a)
+             (if (== (car l) 'concat) "" '(document ""))
+             (cons (car l) (map tmtex-filter-body a))
+           ) ;if
+         ) ;with
+        ) ;
+        (else (cons (car l) (map tmtex-filter-body (cdr l))))
+  ) ;cond
+) ;define
+
+(define (tmtex-filter-duplicates* l t)
+  (cond ((null? l) l)
+        ((func? (car l) 'assign 2)
+         (let* ((var (cadr (car l)))
+                (r (tmtex-filter-duplicates* (cdr l) t))
+                (dup? (ahash-ref t var))
+               ) ;
+           (ahash-set! t var #t)
+           (if dup? r (cons (car l) r))
+         ) ;let*
+        ) ;
+        ((or (func? (car l) 'concat) (func? (car l) 'para) (func? (car l) 'document))
+         (with r
+           (tmtex-filter-duplicates* (cdr l) t)
+           (cons (cons (caar l) (tmtex-filter-duplicates* (cdar l) t)) r)
+         ) ;with
+        ) ;
+        (else (cons (car l) (tmtex-filter-duplicates* (cdr l) t)))
+  ) ;cond
+) ;define
+
+(define (tmtex-filter-duplicates l)
+  (with t (make-ahash-table) (tmtex-filter-duplicates* l t))
+) ;define
+
+(define (tmtex-apply-init body init)
+  ;; (display* "init= " init "\n")
+  (cond ((== (assoc-ref init "language") "verbatim")
+         (with init*
+           (assoc-remove! init "language")
+           (tmtex-apply-init `(verbatim ,body) init*)
+         ) ;with
+        ) ;
+        (else body)
+  ) ;cond
+) ;define
+
+(define (tmtex-clean-body b)
+  (when (and (func? b '!document) (> (length b) 1) (== (cadr b) '(!document "")))
+    (set! b (cons (car b) (cddr b)))
+  ) ;when
+  b
+) ;define
+
+(define (tmtex-file l)
+  (let* ((doc (car l))
+         (styles (cadr l))
+         (init* (cadddr l))
+         (init (or (and (!= init* "#f") init*) '(collection)))
+         (init-bis (if (list>1? init) (map (lambda (x) (cons (cadr x) (caddr x))) (cdr init)) '())
+         ) ;init-bis
+         (att (or (cadddr (cdr l)) '()))
+         (doc-pre (tmtex-filter-preamble (tmtex-filter-style-macro doc)))
+         (doc-preamble (tmtex-filter-duplicates doc-pre))
+         (doc-body-pre (tmtex-filter-body doc))
+         (doc-body (tmtex-apply-init doc-body-pre init-bis))
+        ) ;
+    (init-mode-stats doc-body-pre)
+    (latex-set-texmacs-style (if (pair? styles) (car styles) "none"))
+    (latex-set-texmacs-packages (if (pair? styles) (cdr styles) (list)))
+    (if (== (get-preference "texmacs->latex:expand-user-macros") "on")
+      (set! doc-preamble '())
+    ) ;if
+    (if (null? styles)
+      (tmtex doc)
+      (let* ((styles* (tmtex-filter-styles styles))
+             (styles** (if (and (== styles* (list "article")) (in? '(associate "par-columns"
+                                                                      "2") init))
+                         (list '("twocolumn" "article"))
+                         styles*
+                       ) ;if
+             ) ;styles**
+             (preamble* (ahash-with tmtex-env :preamble #t (map-in-order tmtex-pre doc-preamble))
+             ) ;preamble*
+             (body* (tmtex-postprocess-body (tmtex doc-body)))
+             (body** (tmtex-clean-body body*))
+             (needs (list tmtex-languages tmtex-colors tmtex-colormaps))
+            ) ;
+        (list '!file body** styles** needs init preamble*)
+      ) ;let*
+    ) ;if
+  ) ;let*
+) ;define
+
+(define (convert-charset t)
+  (cond ((string? t) (unescape-angles (utf8->cork t)))
+        ((list>0? t) `(,(car t) ,@(map convert-charset (cdr t))))
+  ) ;cond
+) ;define
+
+(define (tmtex-ilx l)
+  `(!invariant ,(car l))
+) ;define
+
+(define (tmtex-mtm l)
+  (cond ((null? l) "")
+        ((null? (cdr l)) (tmtex (car l)))
+        (else (with lab
+                (car l)
+                (when (func? lab 'mtm 1)
+                  (set! lab (cadr lab))
+                ) ;when
+                `(!concat (!marker btm ,lab)
+                   ,(tmtex (cadr l))
+                   (!marker etm ,lab))
+              ) ;with
+        ) ;else
+  ) ;cond
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Simple text
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (tmtex-noop . l)
+  ""
+) ;define
+
+(define (tmtex-default s l)
+  (cons (string->symbol s) (tmtex-list l))
+) ;define
+
+(define (tmtex-id l)
+  (tmtex (car l))
+) ;define
+
+(define (tmtex-first l)
+  (tmtex (car l))
+) ;define
+
+(define (tmtex-style-first s l)
+  (tmtex (car l))
+) ;define
+
+(define (tmtex-second l)
+  (tmtex (cadr l))
+) ;define
+
+(define (tmtex-style-second s l)
+  (tmtex (cadr l))
+) ;define
+
+(define (tmtex-hide-part s l)
+  ""
+) ;define
+
+(define (tmtex-show-part s l)
+  (tmtex (cadr l))
+) ;define
+
+(define (tmtex-error l)
+  (display* "TeXmacs] error in conversion: " l "\n")
+  (if tmtex-debug-mode? "(error)" "")
+) ;define
+
+(define (tmtex-line-note l)
+  `(tmlinenote ,(tmtex (car l))
+     ,(tmtex-decode-length (cadr l))
+     ,(tmtex-decode-length (caddr l)))
+) ;define
+
+(define (tmtex-marginal-left-note l)
+  `(marginpar (!option ,(tmtex (cAr l))) ,(tmtex '()))
+) ;define
+
+(define (tmtex-marginal-right-note l)
+  `(marginpar (!option "") ,(tmtex (cAr l)))
+) ;define
+
+(define (tmtex-marginal-note l)
+  (cond ((== (car l) "left") (tmtex-marginal-left-note (cdr l)))
+        ((== (car l) "right") (tmtex-marginal-right-note (cdr l)))
+        (else `(marginpar ,(tmtex (cAr l))))
+  ) ;cond
+) ;define
+
+(define (tmtex-document l)
+  (cons '!document (tmtex-list l))
+) ;define
+
+(define (tmtex-date l)
+  (tmtex-default "tmdate" l)
+) ;define
+
+(define (tmtex-para l)
+  (tmtex-image-increment)
+  (cons '!paragraph (tmtex-list l))
+) ;define
+
+(define (tmtex-surround-sub l z)
+  (if (null? (cdr l))
+    (list (tex-concat (list (car l) z)))
+    (cons (car l) (tmtex-surround-sub (cdr l) z))
+  ) ;if
+) ;define
+
+(define (tmtex-surround l)
+  (let* ((ll (tmtex-list l)) (x (car ll)) (y (caddr ll)) (z (cadr ll)))
+    (if (func? y '!document)
+      (let* ((a (cadr y)) (b (cddr y)))
+        (cons '!document (tmtex-surround-sub (cons (tex-concat (list x a)) b) z))
+      ) ;let*
+      (tex-concat (list x y z))
+    ) ;if
+  ) ;let*
+) ;define
+
+(define (tmtex-no-space-before? x)
+  (or (func? x '!sub)
+    (func? x '!sup)
+    (and (string? x) (!= x "") (in? (string-ref x 0) '(#\' #\, #\) #\])))
+    (and (func? x '!concat) (tmtex-no-space-before? (cadr x)))
+  ) ;or
+) ;define
+
+(define (tmtex-no-space-after? x)
+  (or (and (string? x) (!= x "") (in? (string-ref x 0) '(#\( #\[)))
+    (and (func? x '!concat) (tmtex-no-space-after? (cAr x)))
+  ) ;or
+) ;define
+
+(define (tmtex-math-concat-spaces l)
+  (if (or (null? l) (null? (cdr l)))
+    l
+    (let* ((head (car l)) (tail (tmtex-math-concat-spaces (cdr l))))
+      (if (or (tmtex-no-space-after? head) (tmtex-no-space-before? (car tail)))
+        (cons head tail)
+        (cons* head " " tail)
+      ) ;if
+    ) ;let*
+  ) ;if
+) ;define
+
+(define (tmtex-rewrite-no-break l)
+  (cond ((null? l) l)
+        ((and (string? (car l))
+           (string-ends? (car l) " ")
+           (nnull? (cdr l))
+           (== (cadr l) '(no-break))
+         ) ;and
+         (let* ((s (substring (car l) 0 (- (string-length (car l)) 1)))
+                (r (tmtex-rewrite-no-break (cddr l)))
+               ) ;
+           (if (== s "") (cons '(!nbsp) r) (cons* s '(!nbsp) r))
+         ) ;let*
+        ) ;
+        (else (cons (car l) (tmtex-rewrite-no-break (cdr l))))
+  ) ;cond
+) ;define
+
+(define (check-double-script? l sub? sup?)
+  (cond ((or (null? l) (npair? (car l))) #f)
+        ((== (caar l) 'rsub) (or sub? (check-double-script? (cdr l) #t sup?)))
+        ((in? (caar l) '(rsup rprime)) (or sup? (check-double-script? (cdr l) sub? #t)))
+        (else #f)
+  ) ;cond
+) ;define
+
+(define (pre-scripts l)
+  (cond ((or (null? l) (null? (cdr l))) l)
+        ((check-double-script? (cdr l) #f #f)
+         (if (== (== (caadr l) 'rsub) (== (caaddr l) 'rsub))
+           (pre-scripts (cons `(!group (concat ,(car l) ,(cadr l))) (cddr l)))
+           (pre-scripts (cons `(!group (concat ,(car l) ,(cadr l) ,(caddr l))) (cdddr l)))
+         ) ;if
+        ) ;
+        (else (cons (car l) (pre-scripts (cdr l))))
+  ) ;cond
+) ;define
+
+(define (tmtex-concat l)
+  ;; (display* "l= " l "\n")
+  (if (> (length l) 50)
+    (with s
+      (quotient (length l) 2)
+      (let ((h (list-head l s)) (t (list-tail l s)))
+        (tmtex-concat `((concat ,@h) (concat ,@t)))
+      ) ;let
+    ) ;with
+    (if (tmtex-math-mode?)
+      (with l*
+        (pre-scripts l)
+        ;; (when (!= l* l) (display* l " -> " l* "\n"))
+        ;; (display* "l1= " l* "\n")
+        ;; (display* "l2= " (pre-brackets-recurse l*) "\n")
+        ;; (display* "l3= " (tmtex-list (pre-brackets-recurse l*)) "\n")
+        (tex-concat (tmtex-math-concat-spaces (tmtex-list (pre-brackets-recurse l*))))
+      ) ;with
+      (tex-concat (tmtex-list (tmtex-rewrite-no-break l)))
+    ) ;if
+  ) ;if
+) ;define
+
+(define (tmtex-rigid l)
+  (tmtex-function '!group l)
+) ;define
+
+(define (tmtex-no-first-indentation l)
+  (tex-apply 'noindent)
+) ;define
+
+(define (tmtex-line-break l)
+  (tex-apply 'linebreak)
+) ;define
+
+(define (tmtex-page-break l)
+  (tex-apply 'pagebreak)
+) ;define
+
+(define (tmtex-new-page l)
+  (tex-apply 'newpage)
+) ;define
+
+(define (tmtex-no-page-break l)
+  (tex-apply 'nopagebreak)
+) ;define
+
+(define (tmtex-next-line l)
+  (list '!nextline)
+) ;define
+
+(define (tmtex-no-break l)
+  '(!group (nobreak))
+) ;define
+
+(define (tmtex-emdash l)
+  "---"
+) ;define
+
+(define (tmtex-new-line l)
+  (if (tmtex-math-mode?) (tmtex-next-line l) (tex-apply '!newline))
+) ;define
+
+(tm-define (tmtex-decode-length len)
+  ;; FIXME: should be completed
+  (with s
+    (force-string len)
+    (cond ((string-ends? s "fn") (string-replace s "fn" "em"))
+          ((string-ends? s "tab") (string-replace s "tab" "em"))
+          ((string-ends? s "spc") (string-replace s "spc" "em"))
+          ((string-ends? s "sep") (string-replace s "sep" "ex"))
+          ((string-ends? s "par") (string-replace s "par" "\\columnwidth"))
+          ((string-ends? s "pag") (string-replace s "pag" "\\textheight"))
+          (else s)
+    ) ;cond
+  ) ;with
+) ;tm-define
+
+(define (tmtex-hrule s l)
+  (list 'hrulefill)
+) ;define
+
+(define (tmtex-hspace l)
+  (let ((s (if (= (length l) 1) (car l) (cadr l))))
+    (cond ((== s "0.5fn") (list 'enspace))
+          ((== s "1fn") (list 'quad))
+          ((== s "2fn") (list 'qquad))
+          ((== s "0.5em") (list 'enspace))
+          ((== s "1em") (list 'quad))
+          ((== s "2em") (list 'qquad))
+          ((== s "0.2spc") (list (string->symbol ",")))
+          ((not (tmtex-math-mode?))
+           (cond ((== s "0.4spc") (list (string->symbol ",")))
+                 ((== s "0.6spc") (list (string->symbol ",")))
+                 ((== s "0.16667em") (list (string->symbol ",")))
+                 (else (tex-apply 'hspace (tmtex-decode-length s)))
+           ) ;cond
+          ) ;
+          ((== s "0.4spc") (list (string->symbol ":")))
+          ((== s "0.6spc") (list (string->symbol ";")))
+          ((== s "-0.6spc") '(!concat (!) (!) (!)))
+          ((== s "-0.4spc") '(!concat (!) (!)))
+          ((== s "-0.2spc") '(!concat (!)))
+          (else (tex-apply 'hspace (tmtex-decode-length s)))
+    ) ;cond
+  ) ;let
+) ;define
+
+(define (tmtex-hspace* s l)
+  (tmtex-hspace l)
+) ;define
+
+(define (tmtex-vspace l)
+  (let ((s (if (= (length l) 1) (car l) (cadr l))))
+    (cond ((== s "0.5fn") (tex-apply 'smallskip))
+          ((== s "1fn") (tex-apply 'medskip))
+          ((== s "2fn") (tex-apply 'bigskip))
+          (else (tex-apply 'vspace (tmtex-decode-length s)))
+    ) ;cond
+  ) ;let
+) ;define
+
+(define (tmtex-space l)
+  (tmtex-hspace (list (car l)))
+) ;define
+
+(define (into-single-paragraph t)
+  (set! t
+    (tm-replace t
+      (lambda (x) (tm-in? x '(equation equation*)))
+      (lambda (x)
+        (if (and (== (length x) 2) (tm-func? (cadr x) 'document 1))
+          `(math ,(cadr (cadr x)))
+          `(math ,@(cdr x))
+        ) ;if
+      ) ;lambda
+    ) ;tm-replace
+  ) ;set!
+  (set! t
+    (tm-replace t
+      (lambda (x) (tm-func? x 'document))
+      (lambda (x) `(para ,@(cdr x)))
+    ) ;tm-replace
+  ) ;set!
+  t
+) ;define
+
+(define (tmtex-float-make wide? size type position x capt)
+  (let* ((pos (string-replace position "f" ""))
+         (type* (if wide? (string-append type "*") type))
+         (body (tmtex x))
+         (caption (tmtex (into-single-paragraph capt)))
+         (body* (if (and (== type "table")
+                      (or (func? x 'three-line-table)
+                        (func? x 'three-line-table 1)
+                        (tmtex-is-three-line-table-tree? x)
+                      ) ;or
+                    ) ;and
+                  `(!paragraph ,(list 'centering) ,body (caption ,caption))
+                  `(!paragraph ,body (caption ,caption))
+                ) ;if
+         ) ;body*
+        ) ;
+    (cond ((and (== size "big") (== type "figure"))
+           (if (== pos "")
+             `((!begin ,type) ,body*)
+             `((!begin ,type* (!option ,pos)) ,body*)
+           ) ;if
+          ) ;
+          ((and (== size "big") (== type "table"))
+           (if (== pos "")
+             `((!begin ,type) ,body*)
+             `((!begin ,type* (!option ,pos)) ,body*)
+           ) ;if
+          ) ;
+          (else (list 'tmfloat pos size type* body caption))
+    ) ;cond
+  ) ;let*
+) ;define
+
+(define (tmtex-float-table? x)
+  (or (func? x 'small-table 2) (func? x 'big-table 2))
+) ;define
+
+(define (tmtex-float-figure? x)
+  (or (func? x 'small-figure 2) (func? x 'big-figure 2))
+) ;define
+
+(define (tmtex-float-size l)
+  (if (list? l)
+    (if (or (func? l 'small-table) (func? l 'small-figure)) "small" "big")
+    "big"
+  ) ;if
+) ;define
+
+(define (tmtex-float-sub wide? position l)
+  (with pos
+    (string-replace position "f" "")
+    (cond ((func? l 'document 1) (tmtex-float-sub wide? pos (cadr l)))
+          ((tmtex-float-figure? l)
+           (tmtex-float-make wide? (tmtex-float-size l) "figure" pos (cadr l) (caddr l))
+          ) ;
+          ((tmtex-float-table? l)
+           (tmtex-float-make wide? (tmtex-float-size l) "table" pos (cadr l) (caddr l))
+          ) ;
+          (else (tmtex-float-make wide? "big" "figure" pos l ""))
+    ) ;cond
+  ) ;with
+) ;define
+
+(define (tmtex-float l)
+  (tmtex-float-sub #f (force-string (cadr l)) (caddr l))
+) ;define
+
+(define (tmtex-wide-float l)
+  (tmtex-float-sub #t (force-string (cadr l)) (caddr l))
+) ;define
+
+(define (tmtex-htab l)
+  (tex-apply 'hspace* (list 'fill))
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Make brackets small when necessary
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (disable-large? x level)
+  (cond ((string? x) #t)
+        ((func? x 'concat) (list-and (map (cut disable-large? <> level) (cdr x))))
+        ((tm-in? x '(left mid right)) #t)
+        ((tm-in? x '(lsub lsup rsub rsup))
+         (and (> level 0) (disable-large? (cadr x) (- level 1)))
+        ) ;
+        ((tm-in? x '(lprime rprime)) #t)
+        ((tm-in? x '(wide wide*)) (disable-large? (cadr x) (- level 1)))
+        ((tm-in? x '(with rigid locus)) (disable-large? (cAr x) level))
+        ((tm-in? x '(math-up math-ss math-tt math-bf math-it math-sl))
+         (and (== (tm-arity x) 1) (disable-large? (cadr x) level))
+        ) ;
+        (else #f)
+  ) ;cond
+) ;define
+
+(define (make-small s)
+  (cond ((nstring? s) "")
+        ((== s ".") "")
+        ((<= (string-length s) 1) s)
+        ((and (string-starts? s "<") (string-ends? s ">")) s)
+        (else (string-append "<" s ">"))
+  ) ;cond
+) ;define
+
+(define (make-small-bracket x)
+  (if (tm-in? x '(left mid right)) (make-small (cadr x)) x)
+) ;define
+
+(define (find-right l)
+  (cond ((null? l) #f)
+        ((func? (car l) 'left) #f)
+        ((func? (car l) 'right) 2)
+        (else (with i (find-right (cdr l)) (and i (+ i 1))))
+  ) ;cond
+) ;define
+
+(define (pre-brackets l)
+  (cond ((null? l) l)
+        ((func? (car l) 'left)
+         (with n
+           (find-right (cdr l))
+           (if (not n)
+             (cons (car l) (pre-brackets (cdr l)))
+             (let* ((r (pre-brackets (sublist l n (length l)))) (m (sublist l 0 n)))
+               (if (disable-large? `(concat ,@m) 2)
+                 (begin
+                   ;; (display* "< " m "\n")
+                   ;; (display* "> " (map make-small-bracket m) "\n")
+                   (append (map make-small-bracket m) r)
+                 ) ;begin
+                 (append m r)
+               ) ;if
+             ) ;let*
+           ) ;if
+         ) ;with
+        ) ;
+        (else (cons (car l) (pre-brackets (cdr l))))
+  ) ;cond
+) ;define
+
+(define (pre-brackets-recurse l)
+  (with r (pre-brackets l) (if (== r l) r (pre-brackets-recurse r)))
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Mathematics
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (convert-around x)
+  (with d (downgrade-brackets x) (tmtex-concat (if (pair? d) (cdr d) (list d))))
+) ;define
+
+(define (tmtex-around l)
+  (convert-around (cons 'around l))
+) ;define
+
+(define (tmtex-around* l)
+  (convert-around (cons 'around* l))
+) ;define
+
+(define (tmtex-big-around l)
+  (convert-around (cons 'big-around l))
+) ;define
+
+(define (tmtex-large-decode s)
+  (cond ((nstring? s) ".")
+        ((in? s '("(" ")" "[" "]" "|" "/" ".")) s)
+        ((in? s '("||" "<||>")) "\\|")
+        ((== s "\\") "\\backslash")
+        ((and (string-starts? s "<") (string-ends? s ">"))
+         (string-append "\\" (substring s 1 (- (string-length s) 1)))
+        ) ;
+        (else (string-append "\\" s))
+  ) ;cond
+) ;define
+
+(define (tmtex-large-decode-text s)
+  (cond ((nstring? s) "")
+        ((== s ".") "")
+        ((in? s '("(" ")" "[" "]" "|" "/")) s)
+        ((in? s '("{" "}")) (string-append "\\" s))
+        (else (display* "TeXmacs] non converted bracket: " s "\n") "")
+  ) ;cond
+) ;define
+
+(define (tmtex-left l)
+  (if (tmtex-math-mode?)
+    (let* ((s (tmtex-large-decode (car l)))
+           (n (if (= (length l) 2) (string->number (cadr l)) 0))
+           (b (cond ((not n) "left")
+                    ((= n 1) "bigl")
+                    ((= n 2) "Bigl")
+                    ((= n 3) "biggl")
+                    ((= n 4) "Biggl")
+                    (else "left")
+              ) ;cond
+           ) ;b
+          ) ;
+      (list (string->symbol (string-append b s)))
+    ) ;let*
+    (tmtex-large-decode-text (car l))
+  ) ;if
+) ;define
+
+(define (tmtex-mid l)
+  (display* "TeXmacs] downgraded large middle delimiter: " (car l) "\n")
+  (if (tmtex-math-mode?)
+    (with s (tmtex-large-decode (car l)) (if (== s ".") "" s))
+    (tmtex-large-decode-text (car l))
+  ) ;if
+) ;define
+
+(define (tmtex-right l)
+  (if (tmtex-math-mode?)
+    (let* ((s (tmtex-large-decode (car l)))
+           (n (if (= (length l) 2) (string->number (cadr l)) 0))
+           (b (cond ((not n) "right")
+                    ((= n 1) "bigr")
+                    ((= n 2) "Bigr")
+                    ((= n 3) "biggr")
+                    ((= n 4) "Biggr")
+                    (else "right")
+              ) ;cond
+           ) ;b
+          ) ;
+      (list (string->symbol (string-append b s)))
+    ) ;let*
+    (tmtex-large-decode-text (car l))
+  ) ;if
+) ;define
+
+(define (tmtex-big-decode s)
+  (cond ((nstring? s) "bignone")
+        ((in? s '("sum" "prod" "int" "oint" "coprod")) s)
+        ((in? s '("iint" "iiint" "iiiint" "idotsint")) s)
+        ((in? s '("oiint" "oiiint")) s)
+        ((== s "amalg") "coprod")
+        ((== s "pluscup") "uplus")
+        ((== s ".") "bignone")
+        (else (string-append "big" s))
+  ) ;cond
+) ;define
+
+(define (tmtex-big l)
+  (list (string->symbol (tmtex-big-decode (car l))))
+) ;define
+
+(define (tmtex-decode-long-arrow s)
+  (cond ((nstring? s) #f)
+        ((and (string-starts? s ""))
+         (tmtex-decode-long-arrow (substring s 8 (- (string-length s) 1)))
+        ) ;
+        ((in? s
+           '("minus" "leftarrow" "rightarrow" "leftrightarrow" "equal"
+             "Leftarrow" "Rightarrow" "Leftrightarrow" "mapsto" "mapsfrom")
+         ) ;in?
+         (string->symbol (string-append "x" s))
+        ) ;
+        ((in? s
+           '("leftrightarrows" "leftleftarrows" "threeleftarrows"
+             "fourleftarrows" "rightleftarrows" "rightrightarrows"
+             "threerightarrows" "fourrightarrows")
+         ) ;in?
+         (string-append "")
+        ) ;
+        ((== s "Lleftarrow") "")
+        ((== s "Rrightarrow") "")
+        ((== s "LRleftrightarrow") "")
+        (else (string-append "<" s ">"))
+  ) ;cond
+) ;define
+
+(define (tmtex-long-arrow l)
+  (with cmd
+    (tmtex-decode-long-arrow (car l))
+    (cond ((and (symbol? cmd) (== (length l) 2)) (list cmd (tmtex (cadr l))))
+          ((symbol? cmd) (list cmd (list '!option (tmtex (caddr l))) (tmtex (cadr l))))
+          ((== (length l) 2) (list 'overset (tmtex (cadr l)) (tmtex cmd)))
+          ((== (cadr l) "") (list 'underset (tmtex (caddr l)) (tmtex cmd)))
+          (else (list 'underset (tmtex (caddr l)) (list 'overset (tmtex (cadr l)) (tmtex cmd)))
+          ) ;else
+    ) ;cond
+  ) ;with
+) ;define
+
+(define (tmtex-below l)
+  (list 'underset (tmtex (cadr l)) (tmtex (car l)))
+) ;define
+
+(define (tmtex-above l)
+  (list 'overset (tmtex (cadr l)) (tmtex (car l)))
+) ;define
+
+(define (tmtex-lsub l)
+  (cond ((== (car l) "") "")
+        ((tmtex-math-mode?) (tmtex `(concat (!group) (rsub ,(car l)))))
+        (else (tmtex `(rsub ,(car l))))
+  ) ;cond
+) ;define
+
+(define (tmtex-lsup l)
+  (cond ((== (car l) "") "")
+        ((tmtex-math-mode?) (tmtex `(concat (!group) (rsup ,(car l)))))
+        (else (tmtex `(rsup ,(car l))))
+  ) ;cond
+) ;define
+
+(define (tmtex-contains-table? x)
+  (cond ((nlist? x) #f)
+        ((and (>= (length x) 2) (== (car x) '!table)) #t)
+        (else (list-or (map-in-order tmtex-contains-table? (cdr x))))
+  ) ;cond
+) ;define
+
+(define (tmtex-script which script)
+  (with r
+    (tmtex script)
+    (if (tmtex-contains-table? r) (list which (list 'tmscript r)) (list which r))
+  ) ;with
+) ;define
+
+(define (tmtex-rsub l)
+  (cond ((== (car l) "") "")
+        ((tmtex-math-mode?) (tmtex-script '!sub (car l)))
+        (else (list 'tmrsub (tmtex (car l))))
+  ) ;cond
+) ;define
+
+(define (tmtex-rsup l)
+  (cond ((== (car l) "") "")
+        ((tmtex-math-mode?) (tmtex-script '!sup (car l)))
+        (else (list 'tmrsup (tmtex (car l))))
+  ) ;cond
+) ;define
+
+(define (tmtex-modulo l)
+  (tmtex-script 'mod (car l))
+) ;define
+
+(define (tmtex-frac l)
+  (tmtex-function 'frac l)
+) ;define
+
+(define (tmtex-sqrt l)
+  (if (= (length l) 1)
+    (tmtex-function 'sqrt l)
+    (list 'sqrt (list '!option (tmtex (cadr l))) (tmtex (car l)))
+  ) ;if
+) ;define
+
+(define (tmtex-token? s)
+  (or (= (string-length s) 1)
+    (and (!= s "")
+      (== (string-ref s 0) #\<)
+      (== (string-index s #\>) (- (string-length s) 1))
+    ) ;and
+  ) ;or
+) ;define
+
+(define (tmtex-wide-star? x)
+  (cond ((func? x 'wide* 1) (tmtex-wide-star? (cadr x)))
+        ((nstring? x) #t)
+        (else (not (tmtex-token? x)))
+  ) ;cond
+) ;define
+
+(define (tmtex-wide-star l)
+  (let ((wide? (tmtex-wide-star? (car l)))
+        (arg (tmtex (car l)))
+        (acc (cadr l))
+        (text? (not (tmtex-math-mode?)))
+       ) ;
+    (if (and (string? acc) (string-starts? acc "" "^")) (list (if wide? 'uwidehat 'uhat) arg))
+          ((in? acc '("" "~")) (list (if wide? 'uwidetilde 'utilde) arg))
+          ((== acc "") (list 'underline arg))
+          ((== acc "") (list (if wide? 'underrightarrow 'uvec) arg))
+          ((== acc "") (list 'ubreve arg))
+          ((== acc "") (list 'uinvbreve arg))
+          ((== acc "") (list 'ucheck arg))
+          ((== acc "") (list 'uring arg))
+          ((== acc "") (list 'uacute arg))
+          ((== acc "") (list 'ugrave arg))
+          ((== acc "") (list 'underdot arg))
+          ((== acc "") (list 'uddot arg))
+          ((== acc "") (list 'udddot arg))
+          ((== acc "") (list 'uddddot arg))
+          ((== acc "") (list 'underrightarrow arg))
+          ((== acc "") (list 'underleftarrow arg))
+          ((== acc "") (list 'underleftrightarrow arg))
+          ((== acc "") (list 'underrightarrow arg))
+          ((== acc "") (list 'underleftarrow arg))
+          ((== acc "") (list 'underleftrightarrow arg))
+          ((in? acc '("" "")) (list 'underbrace arg))
+          ((in? acc '("" ""))
+           (tmtex-below `(,(car l) (text (downbracefill))))
+          ) ;
+          ((in? acc '("" "")) (list 'underbrace arg))
+          ((in? acc '("" ""))
+           (tmtex-below `(,(car l) (text (downbracefill))))
+          ) ;
+          ;; imperfect translations
+          ((in? acc '("" "")) (list 'underbrace arg))
+          ((in? acc '("" ""))
+           (tmtex-below `(,(car l) (text (downbracefill))))
+          ) ;
+          (else (display* "TeXmacs] non converted accent below: " acc "\n") arg)
+    ) ;cond
+  ) ;let
+) ;define
+
+(define (tmtex-wide? x)
+  (cond ((func? x 'wide 1) (tmtex-wide? (cadr x)))
+        ((nstring? x) #t)
+        (else (not (tmtex-token? x)))
+  ) ;cond
+) ;define
+
+(define (tmtex-wide l)
+  (let ((wide? (tmtex-wide? (car l)))
+        (arg (tmtex (car l)))
+        (acc (cadr l))
+        (text? (not (tmtex-math-mode?)))
+       ) ;
+    (if (and (string? acc) (string-starts? acc "" "^")) (list (if text? '^ (if wide? 'widehat 'hat)) arg))
+          ((in? acc '("" "~"))
+           (list (if text? '~ (if wide? 'widetilde 'tilde)) arg)
+          ) ;
+          ((== (cadr l) "") (list (if text? '= 'overline) arg))
+          ((== acc "") (list (if text? '= (if wide? 'overline 'bar)) arg))
+          ((== acc "") (list (if wide? 'overrightarrow 'vec) arg))
+          ((== acc "") (list (if text? 'u 'breve) arg))
+          ((== acc "") (list 'invbreve arg))
+          ((== acc "") (list (if text? 'v 'check) arg))
+          ((== acc "") (list (if text? 'r 'ring) arg))
+          ((== acc "") (list (if text? (string->symbol "'") 'acute) arg))
+          ((== acc "") (list (if text? (string->symbol "`") 'grave) arg))
+          ((== acc "") (list (if text? (string->symbol ".") 'dot) arg))
+          ((== acc "") (list (if text? (string->symbol "\"") 'ddot) arg))
+          ((== acc "") (list 'dddot arg))
+          ((== acc "") (list 'ddddot arg))
+          ((== acc "") (list 'overrightarrow arg))
+          ((== acc "") (list 'overleftarrow arg))
+          ((== acc "") (list 'overleftrightarrow arg))
+          ((== acc "") (list 'overrightarrow arg))
+          ((== acc "") (list 'overleftarrow arg))
+          ((== acc "") (list 'overleftrightarrow arg))
+          ((in? acc '("" "")) (list 'overbrace arg))
+          ((in? acc '("" ""))
+           (tmtex-above `(,(car l) (text (upbracefill))))
+          ) ;
+          ((in? acc '("" "")) (list 'overbrace arg))
+          ((in? acc '("" ""))
+           (tmtex-above `(,(car l) (text (upbracefill))))
+          ) ;
+          ;; FIXME: imperfect translations
+          ((in? acc '("" "")) (list 'overbrace arg))
+          ((in? acc '("" ""))
+           (tmtex-above `(,(car l) (text (upbracefill))))
+          ) ;
+          (else (display* "TeXmacs] non converted accent: " acc "\n") arg)
+    ) ;cond
+  ) ;let
+) ;define
+
+(define (tmtex-neg l)
+  (tmtex-function 'not l)
+) ;define
+
+(define (tmtex-tree l)
+  (let* ((root (list '!begin "bundle" (tmtex (car l))))
+         (children (map (lambda (x) (list 'chunk (tmtex x))) (cdr l)))
+        ) ;
+    (list root (tex-concat children))
+  ) ;let*
+) ;define
+
+(define (tmtex-tree-eps l)
+  (tmtex-eps (cons 'tree l))
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Hacks for tables with multi-paragraph cells
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (map-or l1 l2)
+  (if (or (null? l1) (null? l2))
+    (list)
+    (cons (or (car l1) (car l2)) (map-or (cdr l1) (cdr l2)))
+  ) ;if
+) ;define
+
+(define (tmtex-block-columns t)
+  (cond ((tm-func? t 'tformat) (tmtex-block-columns (cAr t)))
+        ((tm-func? t 'table 1) (tmtex-block-columns (cAr t)))
+        ((tm-func? t 'table)
+         (let* ((b1 (tmtex-block-columns `(table ,(cadr t))))
+                (b2 (tmtex-block-columns `(table ,@(cddr t))))
+               ) ;
+           (map-or b1 b2)
+         ) ;let*
+        ) ;
+        ((tm-func? t 'row) (map tmtex-block-columns (cdr t)))
+        ((tm-func? t 'cell) (tmtex-block-columns (cAr t)))
+        (else (tm-func? t 'document))
+  ) ;cond
+) ;define
+
+(define (column-numbers l i)
+  (cond ((null? l) (list))
+        ((car l) (cons i (column-numbers (cdr l) (+ i 1))))
+        (else (column-numbers (cdr l) (+ i 1)))
+  ) ;cond
+) ;define
+
+(define (block-align nr out-of)
+  (let* ((c (number->string nr))
+         (p (string-append "p{" (number->string (/ 12.0 out-of)) "cm}"))
+        ) ;
+    `(cwith ,"1" ,"-1" ,c ,c ,"cell-halign" ,p)
+  ) ;let*
+) ;define
+
+(define (tmtex-block-adjust t)
+  (cond ((tm-func? t 'tformat) (append (cDr t) (list (tmtex-block-adjust (cAr t)))))
+        ((tm-func? t 'table)
+         (let* ((b (tmtex-block-columns t)) (n (column-numbers b 1)))
+           (if (null? n) t `(tformat ,@(map (cut block-align <> (length n)) n)
+                              ,t))
+         ) ;let*
+        ) ;
+        (else t)
+  ) ;cond
+) ;define
+
+(define (tm-big-figure? t)
+  (tm-in? t '(big-figure big-table))
+) ;define
+
+(define (tm-replace-figure t)
+  (cond ((tm-func? t 'big-figure) (list 'tmfloat "h" "big" "figure" (cadr t) (caddr t)))
+        ((tm-func? t 'big-table) (list 'tmfloat "h" "big" "table" (cadr t) (caddr t)))
+        (else t)
+  ) ;cond
+) ;define
+
+(define (tmtex-figure-adjust t)
+  (tm-replace t tm-big-figure? tm-replace-figure)
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Tables
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (tmtex-table-rows-assemble tb bb rows)
+  (cond ((null? rows) (if (null? bb) '() (if (car bb) (list (list 'hline)) '())))
+        (else (append (if (or (car tb) (car bb)) (list (list 'hline)) '())
+                (cons (cons '!row (map tmtex (car rows)))
+                  (tmtex-table-rows-assemble (cdr tb) (cdr bb) (cdr rows))
+                ) ;cons
+              ) ;append
+        ) ;else
+  ) ;cond
+) ;define
+
+(define (tmtex-table-make p)
+  (let ((tb (p 'rows 'tborder)) (bb (p 'rows 'bborder)) (l (p 'rows 'content)))
+    (cons '!table (tmtex-table-rows-assemble tb (cons (car tb) bb) l))
+  ) ;let
+) ;define
+
+(define (tmtex-three-line-table-rows-assemble tb bb rows is-first)
+  (cond ((null? rows) (if (null? bb) '() (if (car bb) (list (list 'bottomrule)) '())))
+        (else (append (if (or (car tb) (car bb)) (list (list (if is-first 'toprule 'midrule))) '())
+                (cons (cons '!row (map tmtex (car rows)))
+                  (tmtex-three-line-table-rows-assemble (cdr tb) (cdr bb) (cdr rows) #f)
+                ) ;cons
+              ) ;append
+        ) ;else
+  ) ;cond
+) ;define
+
+(define (tmtex-three-line-table-make p)
+  (let ((tb (p 'rows 'tborder)) (bb (p 'rows 'bborder)) (l (p 'rows 'content)))
+    (cons '!table (tmtex-three-line-table-rows-assemble tb (cons (car tb) bb) l #t))
+  ) ;let
+) ;define
+
+(define (tmtex-table-args-assemble lb rb ha)
+  (cond ((null? ha) (if (null? rb) '() (list (if (car rb) "|" ""))))
+        (else (cons (if (or (car lb) (car rb)) "|" "")
+                (cons (car ha) (tmtex-table-args-assemble (cdr lb) (cdr rb) (cdr ha)))
+              ) ;cons
+        ) ;else
+  ) ;cond
+) ;define
+
+(define (tmtex-table-args p)
+  (let ((lb (p 'cols 'lborder)) (rb (p 'cols 'rborder)) (l (p 'cols 'halign)))
+    (apply string-append (tmtex-table-args-assemble lb (cons (car lb) rb) l))
+  ) ;let
+) ;define
+
+(define (tmtex-table-apply key args x)
+  (let* ((props (logic-ref tmtex-table-props% key))
+         (wide? (and props (string-contains? (cadr props) "X")))
+        ) ;
+    (when (== key 'rcl-table)
+      (latex-add-extra "tabls")
+    ) ;when
+    (when (and (not (tmtex-math-mode?)) (not wide?))
+      (set! x (tmtex-block-adjust x))
+      (set! x (tmtex-figure-adjust x))
+    ) ;when
+    (if props
+      (let* ((env (if (tmtex-math-mode?) "array" "tabular"))
+             (env* (if wide? (list "tabularx" "1.0\\textwidth") (list env)))
+             (before (car props))
+             (after (caddr props))
+             (defaults (append (tmtable-cell-halign (cadr props))
+                         (tmtable-block-borders (cadddr props))
+                       ) ;append
+             ) ;defaults
+             (p (tmtable-parser (if (== key 'three-line-table)
+                                  `(tformat ,@defaults ,@(cdr x))
+                                  `(tformat ,@defaults ,x)
+                                ) ;if
+                ) ;tmtable-parser
+             ) ;p
+             (e `(!begin ,@env* ,(tmtex-table-args p)))
+             (r (if (== key 'three-line-table)
+                  (tmtex-three-line-table-make p)
+                  (tmtex-table-make p)
+                ) ;if
+             ) ;r
+            ) ;
+        (tex-concat (list before (list e r) after))
+      ) ;let*
+      (begin
+        (list `(!begin ,(symbol->string key) ,@args)
+          (if (== key 'three-line-table)
+            (tmtex-three-line-table-make (tmtable-parser `(tformat ,@(cdr x))))
+            (tmtex-table-make (tmtable-parser x))
+          ) ;if
+        ) ;list
+      ) ;begin
+    ) ;if
+  ) ;let*
+) ;define
+
+(define (tmtex-is-three-line-table? l)
+  (let* ((has-tborder1 (list-or (map (lambda (x)
+                                       (and (pair? x) (== (car x) 'cwith) (member "cell-tborder" x) (member "1ln" x))
+                                     ) ;lambda
+                                  l
+                                ) ;map
+                       ) ;list-or
+         ) ;has-tborder1
+         (has-bborder1 (list-or (map (lambda (x)
+                                       (and (pair? x) (== (car x) 'cwith) (member "cell-bborder" x) (member "1ln" x))
+                                     ) ;lambda
+                                  l
+                                ) ;map
+                       ) ;list-or
+         ) ;has-bborder1
+         (has-bborder05 (list-or (map (lambda (x)
+                                        (and (pair? x) (== (car x) 'cwith) (member "cell-bborder" x) (member "0.5ln" x))
+                                      ) ;lambda
+                                   l
+                                 ) ;map
+                        ) ;list-or
+         ) ;has-bborder05
+        ) ;
+    (and has-tborder1 has-bborder1 has-bborder05)
+  ) ;let*
+) ;define
+
+(define (tmtex-is-three-line-table-tree? x)
+  (and (pair? x) (== (car x) 'tformat) (tmtex-is-three-line-table? (cdr x)))
+) ;define
+
+(define (tmtex-extract-table-element l)
+  (cond ((null? l) #f)
+        ((and (pair? (car l)) (in? (caar l) '(tformat table))) (car l))
+        (else (tmtex-extract-table-element (cdr l)))
+  ) ;cond
+) ;define
+
+(define (tmtex-inject-three-line-table-borders l)
+  (append (list '(cwith "1" "1" "1" "-1" "cell-tborder" "1ln")
+            '(cwith "-1" "-1" "1" "-1" "cell-bborder" "1ln")
+            '(cwith "1" "1" "1" "-1" "cell-bborder" "0.5ln")
+          ) ;list
+    l
+  ) ;append
+) ;define
+
+(define (tmtex-tformat l)
+  (if (tmtex-is-three-line-table? l)
+    (let* ((tbl (tmtex-extract-table-element l)))
+      (if tbl
+        (tmtex-three-line-table (tmtex-inject-three-line-table-borders (cdr tbl)))
+        (tmtex-table-apply 'tabular '() (cons 'tformat l))
+      ) ;if
+    ) ;let*
+    (tmtex-table-apply 'tabular '() (cons 'tformat l))
+  ) ;if
+) ;define
+
+(define (tmtex-table l)
+  (tmtex-image-increment)
+  (tmtex-table-apply 'tabular '() (cons 'table l))
+) ;define
+
+(define (tmtex-three-line-table l)
+  (tmtex-table-apply 'three-line-table '() (cons 'three-line-table l))
+) ;define
+
+(define (tmtex-stack l)
+  (when (nnull? l)
+    (let* ((x (car l)) (p (tmtable-parser x)) (rows (p 'rows 'content)))
+      (latex-add-extra "mathtools")
+      (tex-apply 'substack
+        (tex-concat (list-intersperse (map (lambda (row) (tex-concat (map tmtex row))) rows) "\\\\")
+        ) ;tex-concat
+      ) ;tex-apply
+    ) ;let*
+  ) ;when
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Local and global environment changes
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (tmtex-get-with-cmd var val)
+  (if (tmtex-math-mode?)
+    (or (logic-ref tex-with-cmd-math% (list var val))
+      (logic-ref tex-with-cmd% (list var val))
+    ) ;or
+    (logic-ref tex-with-cmd% (list var val))
+  ) ;if
+) ;define
+
+(define (tmtex-get-assign-cmd var val)
+  (if (== var "font-size")
+    (let ((x (* (string->number val) 10)))
+      (cond ((< x 1) #f)
+            ((< x 5.5) 'tiny)
+            ((< x 6.5) 'scriptsize)
+            ((< x 7.5) 'footnotesize)
+            ((< x 9.5) 'small)
+            ((< x 11.5) 'normalsize)
+            ((< x 13.5) 'large)
+            ((< x 15.5) 'Large)
+            ((< x 18.5) 'LARGE)
+            ((< x 22.5) 'huge)
+            ((< x 50) 'Huge)
+            (else #f)
+      ) ;cond
+    ) ;let
+    (logic-ref tex-assign-cmd% (list var val))
+  ) ;if
+) ;define
+
+(define (tmlength->texlength len)
+  ;; TODO: rewrite (quote x) -> x and (tmlen ...) -> ...pt
+  (with tmlen
+    (string->tmlength (force-string len))
+    (if (tmlength-null? tmlen)
+      "0pt"
+      (let* ((val (tmlength-value tmlen))
+             (unit (symbol->string (tmlength-unit tmlen)))
+             (val-string (number->string val))
+            ) ;
+        (cond ((== unit "fn") (string-append val-string "em"))
+              (else len)
+        ) ;cond
+      ) ;let*
+    ) ;if
+  ) ;with
+) ;define
+
+(define (tmtex-make-parmod x y z arg flag?)
+  (set! x (tmlength->texlength x))
+  (set! y (tmlength->texlength y))
+  (set! z (tmlength->texlength z))
+  (if (and (tmlength-zero? (string->tmlength x))
+        (tmlength-zero? (string->tmlength y))
+        (tmlength-zero? (string->tmlength z))
+        flag?
+      ) ;and
+    arg
+    (list (list '!begin "tmparmod" x y z) arg)
+  ) ;if
+) ;define
+
+(define (tmtex-make-parsep x arg)
+  (set! x (tmlength->texlength x))
+  (list (list '!begin "tmparsep" x) arg)
+) ;define
+
+(define (tmtex-make-lang val arg)
+  (if (== val "verbatim")
+    `(tt ,arg)
+    (begin
+      (if (nin? val tmtex-languages)
+        (set! tmtex-languages (append (list val) tmtex-languages))
+      ) ;if
+      (if (texout-multiline? arg)
+        `((!begin ,"otherlanguage" ,val) ,arg)
+        `(foreignlanguage ,val ,arg)
+      ) ;if
+    ) ;begin
+  ) ;if
+) ;define
+
+(define (tmtex-decode-color s . force-html)
+  (with cm
+    (if (string-starts? s "#") "HTML" (named-color->xcolormap s))
+    (cond ((and (== cm "none") (nnull? force-html))
+           (tmtex-decode-color (get-hex-color s) force-html)
+          ) ;
+          ((and (== cm "HTML") (nnull? force-html))
+           `((!option "HTML") ,(html-color->latex-xcolor s))
+          ) ;
+          ((== cm "texmacs")
+           (when (nin? s tmtex-colors)
+             (set! tmtex-colors (append (list s) tmtex-colors))
+           ) ;when
+           (string-replace s " " "")
+          ) ;
+          ((in? cm (list "x11names")) (tmtex-decode-color (get-hex-color s) #t))
+          (else (when (and (nin? cm tmtex-colormaps) (!= cm "xcolor") (!= cm "none"))
+                  (set! tmtex-colormaps (append (list cm) tmtex-colormaps))
+                ) ;when
+            (string-replace s " " "")
+          ) ;else
+    ) ;cond
+  ) ;with
+) ;define
+
+(define (tmtex-make-color val arg)
+  (with ltxcolor
+    (tmtex-decode-color val #t)
+    (if (list? ltxcolor)
+      `(!group (!append (color ,@ltxcolor) ,arg))
+      `(tmcolor ,ltxcolor ,arg)
+    ) ;if
+  ) ;with
+) ;define
+
+(define (post-process-math-text t)
+  (cond ((or (nlist? t) (!= (length t) 2)) t)
+        ((nin? (car t) '(mathrm mathbf mathsf mathit mathsl mathtt tmop)) t)
+        ((and (string? (cadr t)) (string-alpha? (cadr t))) t)
+        ((func? t 'mathrm 1) `(textrm ,(cadr t)))
+        ((func? t 'mathbf 1) `(textbf ,(cadr t)))
+        ((func? t 'mathsf 1) `(textsf ,(cadr t)))
+        ((func? t 'mathit 1) `(textit ,(cadr t)))
+        ((func? t 'mathsl 1) `(textsl ,(cadr t)))
+        ((func? t 'mathtt 1) `(texttt ,(cadr t)))
+        ((func? t 'tmop 1) `(textrm ,(cadr t)))
+        (else t)
+  ) ;cond
+) ;define
+
+(define (tmtex-with-one var val arg)
+  (if (== var "mode")
+    (let ((old (tmtex-env-get-previous "mode")))
+      (cond ((and (== val "text") (!= old "text")) (list 'text arg))
+            ((and (== val "math") (!= old "math") (ahash-ref tmtex-env :preamble))
+             (list 'ensuremath arg)
+            ) ;
+            ((and (== val "math") (!= old "math")) (list '!math arg))
+            ((and (== val "prog") (== old "text")) `(tt ,arg))
+            ((and (== val "prog") (== old "math")) `(text (tt ,arg)))
+            (else arg)
+      ) ;cond
+    ) ;let
+    (let ((w (tmtex-get-with-cmd var val)) (a (tmtex-get-assign-cmd var val)))
+      (cond ((and w (tm-func? arg w 1)) arg)
+            ((in? w '(mathrm mathbf mathsf mathit mathtt mathsl))
+             (post-process-math-text (list w arg))
+            ) ;
+            (w (list w arg))
+            (a (list '!group (tex-concat (list (list a) " " arg))))
+            ((== "par-left" var) (tmtex-make-parmod val "0pt" "0pt" arg #t))
+            ((== "par-right" var) (tmtex-make-parmod "0pt" val "0pt" arg #t))
+            ((== "par-first" var) (tmtex-make-parmod "0pt" "0pt" val arg #f))
+            ((== "par-par-sep" var) (tmtex-make-parsep val arg))
+            ((== var "language") (tmtex-make-lang val arg))
+            ((== var "color") (tmtex-make-color val arg))
+            (else arg)
+      ) ;cond
+    ) ;let
+  ) ;if
+) ;define
+
+(define (tmtex-with l)
+  (cond ((null? l) "")
+        ((null? (cdr l)) (tmtex (car l)))
+        ((func? (cAr l) 'graphics) (tmtex-eps (cons 'with l)))
+        (else (let ((var (force-string (car l))) (val (force-string (cadr l))) (next (cddr l)))
+                (tmtex-env-set var val)
+                (let ((r (tmtex-with-one var val (tmtex-with next))))
+                  (tmtex-env-reset var)
+                  r
+                ) ;let
+              ) ;let
+        ) ;else
+  ) ;cond
+) ;define
+
+(define (tmtex-with-wrapped l)
+  (if (and (== (length l) 3)
+        (== (car l) "par-columns")
+        (== (cadr l) "1")
+        (tm-in? (caddr l) '(small-figure big-figure small-table big-table))
+      ) ;and
+    (tmtex-float-sub #t "h" (caddr l))
+    (tmtex-with l)
+  ) ;if
+) ;define
+
+(define (tmtex-var-name-sub l)
+  (if (null? l)
+    l
+    (let ((c (car l)) (r (tmtex-var-name-sub (cdr l))))
+      (cond ((char-alphabetic? c) (cons c r))
+            ((char-numeric? c)
+             (cond ((char=? c #\0) (cons* #\z #\e #\r #\o r))
+                   ((char=? c #\1) (cons* #\o #\n #\e r))
+                   ((char=? c #\2) (cons* #\t #\w #\o r))
+                   ((char=? c #\3) (cons* #\t #\h #\r #\e #\e r))
+                   ((char=? c #\4) (cons* #\f #\o #\u #\r r))
+                   ((char=? c #\5) (cons* #\f #\i #\v #\e r))
+                   ((char=? c #\6) (cons* #\s #\i #\x r))
+                   ((char=? c #\7) (cons* #\s #\e #\v #\e #\n r))
+                   ((char=? c #\8) (cons* #\e #\i #\g #\h #\t r))
+                   ((char=? c #\9) (cons* #\n #\i #\n #\e r))
+                   (else r)
+             ) ;cond
+            ) ;
+            ((and (char=? c #\*) (null? (cdr l))) (list c))
+            (else r)
+      ) ;cond
+    ) ;let
+  ) ;if
+) ;define
+
+(define (tmtex-var-name var)
+  (cond ((nstring? var) "")
+        ((logic-in? (string->symbol var) tmtex-protected%) (string-append "tm" var))
+        ((<= (string-length var) 1) var)
+        (else (with r
+                (list->string (tmtex-var-name-sub (string->list var)))
+                (if (and (string-occurs? "*" r) (== (latex-type r) "undefined"))
+                  (string-replace r "*" "star")
+                  r
+                ) ;if
+              ) ;with
+        ) ;else
+  ) ;cond
+) ;define
+
+(define (tmtex-tex-arg l)
+  (cons '!arg l)
+) ;define
+
+(define (tmtex-args-search x args)
+  (cond ((null? args) #f)
+        ((== x (car args)) 1)
+        (else (let ((n (tmtex-args-search x (cdr args)))) (if n (+ 1 n) #f)))
+  ) ;cond
+) ;define
+
+(define (tmtex-args-sub l args)
+  (if (null? l) l (cons (tmtex-args (car l) args) (tmtex-args-sub (cdr l) args)))
+) ;define
+
+(define (tmtex-args x args)
+  (cond ((nlist? x) x)
+        ((or (func? x 'arg) (func? x 'value))
+         (let ((n (tmtex-args-search (cadr x) args)))
+           (if n (list '!arg (number->string n)) (tmtex-args-sub x args))
+         ) ;let
+        ) ;
+        (else (tmtex-args-sub x args))
+  ) ;cond
+) ;define
+
+(define (tmtex-assign l)
+  (let* ((var (tmtex-var-name (car l)))
+         (bsvar (string-append "\\" var))
+         (type (latex-type var))
+         (def (if (== type "undefined") 'newcommand 'providecommand))
+         (val (cadr l))
+        ) ;
+    (while (func? val 'quote 1) (set! val (cadr val)))
+    (if (!= var "")
+      (begin
+        (tmtex-env-assign var val)
+        (cond ((string? val)
+               (let ((a (tmtex-get-assign-cmd var val)))
+                 (if a (list a) (list def bsvar (tmtex val)))
+               ) ;let
+              ) ;
+              ((or (func? val 'macro) (func? val 'func))
+               (if (null? (cddr val))
+                 (list def bsvar (tmtex (cAr val)))
+                 (list def
+                   bsvar
+                   (list '!option (number->string (- (length val) 2)))
+                   (tmtex (tmtex-args (cAr val) (cDdr val)))
+                 ) ;list
+               ) ;if
+              ) ;
+              (else (list def bsvar (tmtex val)))
+        ) ;cond
+      ) ;begin
+      ""
+    ) ;if
+  ) ;let*
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Other primitives
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (tmtex-quote l)
+  (tmtex (car l))
+) ;define
+
+(define (tmtex-hidden-binding l)
+  (if (and (== (length l) 2) (string->number (force-string (cAr l))))
+    (list 'custombinding (force-string (cAr l)))
+    ""
+  ) ;if
+) ;define
+
+(define (tmtex-label l)
+  (list 'label (force-string (car l)))
+) ;define
+
+(define (tmtex-reference l)
+  (list 'ref (force-string (car l)))
+) ;define
+
+(define (tmtex-pageref l)
+  (list 'pageref (force-string (car l)))
+) ;define
+
+(define (tmtex-eqref s l)
+  (list 'eqref (force-string (car l)))
+) ;define
+
+(define (tmtex-smart-ref s l)
+  (let* ((ss (map force-string l)) (key (string-join ss ",")))
+    (list 'Cref key)
+  ) ;let*
+) ;define
+
+(define (tmtex-specific l)
+  (cond ((== (car l) "latex") (tmtex-tt (cadr l)))
+        ((== (car l) "image") (tmtex-eps (cadr l)))
+        ((== (car l) "printer") (tmtex (cadr l)))
+        ((== (car l) "odd") `(ifthispageodd ,(tmtex (cadr l)) ,""))
+        ((== (car l) "even") `(ifthispageodd ,"" ,(tmtex (cadr l))))
+        (else "")
+  ) ;cond
+) ;define
+
+(define (tmtex-eps-names)
+  (set! tmtex-serial (+ tmtex-serial 1))
+  (let* ((suffix ".pdf")
+         (postfix (string-append "-" (number->string tmtex-serial) suffix))
+         (name-url (url-glue tmtex-image-root-url postfix))
+         (name-string (string-append tmtex-image-root-string postfix))
+        ) ;
+    (values name-url name-string)
+  ) ;let*
+) ;define
+
+(define (tmtex-eps x)
+  (tmtex-image-increment)
+  (if (tmtex-math-mode?) (set! x `(with ,"mode" ,"math" ,x)))
+  (receive (name-url name-string)
+    (tmtex-eps-names)
+    (let* ((extents (print-snippet name-url x #t))
+           (unit (* (/ 1.0 60984.0) (/ 600.0 (tenth extents))))
+           (x3 (* unit (first extents)))
+           (y3 (* unit (second extents)))
+           (x4 (* unit (third extents)))
+           (y4 (* unit (fourth extents)))
+           (x1 (* unit (fifth extents)))
+           (y1 (* unit (sixth extents)))
+           (x2 (* unit (seventh extents)))
+           (y2 (* unit (eighth extents)))
+           (lm (string-append (number->string (- x3 x1)) "cm"))
+           (rm (string-append (number->string (- x2 x4)) "cm"))
+           (ww (string-append (number->string (- x4 x3)) "cm"))
+           (hh (string-append (number->string (- y4 y3)) "cm"))
+           (opt `(!option ,(string-append "width=" ww ",height=" hh)))
+           (rat (/ y3 (- y4 y3)))
+           (dy `(!concat ,(number->string rat) (height)))
+           (rb `(raisebox ,dy (includegraphics ,opt ,name-string)))
+          ) ;
+      ;; TODO: top and bottom margins
+      ;; (display* name-url ": " x1 ", " y1 "; " x2 ", " y2 "\n")
+      ;; (display* name-url ": " x3 ", " y3 "; " x4 ", " y4 "\n")
+      (if (and (< (abs (- x3 x1)) 0.01) (< (abs (- x2 x4)) 0.01))
+        rb
+        `(!concat (hspace ,lm) ,rb (hspace ,rm))
+      ) ;if
+    ) ;let*
+  ) ;receive
+) ;define
+
+(define (tmtex-make-eps s l)
+  (tmtex-eps (cons (string->symbol s) l))
+) ;define
+
+(define (tmtex-graphics l)
+  (tmtex-eps (cons 'graphics l))
+) ;define
+
+(define (tmtex-as-eps name)
+  (tmtex-image-increment)
+  (let* ((u (url-relative current-save-target (unix->url name)))
+         (suffix (url-suffix u))
+         (fm (string-append (format-from-suffix suffix) "-file"))
+        ) ;
+    (if (and (url-exists? u) (in? suffix (list "eps" "pdf" "png" "jpg")))
+      (with p
+        (url->string "$TEXMACS_PATH")
+        (set! name (string-replace name "$TEXMACS_PATH" p))
+        (set! name (string-replace name "file://" ""))
+        (list 'includegraphics name)
+      ) ;with
+      (receive (name-url name-string)
+        (tmtex-eps-names)
+        (when (string-starts? name "..")
+          (set! u (url-relative current-save-source (unix->url name)))
+        ) ;when
+        (with nfm
+          (if (== (url-suffix name-url) "pdf") "pdf-file" "postscript-file")
+          (convert-to-file u fm nfm name-url)
+        ) ;with
+        (list 'includegraphics name-string)
+      ) ;receive
+    ) ;if
+  ) ;let*
+) ;define
+
+(define (tmtex-image-length len)
+  (let* ((s (force-string len)) (unit (and (tm-length? s) (tm-length-unit len))))
+    (cond ((== s "") "!")
+          ((string-ends? s "%") "!")
+          ((in? unit '("w" "h")) "!")
+          (else (tmtex-decode-length len))
+    ) ;cond
+  ) ;let*
+) ;define
+
+(define (tmtex-image-mag len)
+  (let* ((s (force-string len))
+         (val (and (tm-length? s) (tm-length-value len)))
+         (unit (and (tm-length? s) (tm-length-unit len)))
+        ) ;
+    (cond ((== s "") 0.0)
+          ((string-ends? s "%")
+           (with x (string->number (string-drop-right s 1)) (if x (/ x 100.0) 0))
+          ) ;
+          ((in? unit '("w" "h")) (or val 0))
+          (else #f)
+    ) ;cond
+  ) ;let*
+) ;define
+
+(define (tmtex-image l)
+  (if (nstring? (car l))
+    (tmtex-eps (cons 'image l))
+    (let* ((fig (tmtex-as-eps (force-string (car l))))
+           (hor (tmtex-image-length (cadr l)))
+           (ver (tmtex-image-length (caddr l)))
+           (mhor (tmtex-image-mag (cadr l)))
+           (mver (tmtex-image-mag (caddr l)))
+          ) ;
+      (cond ((or (not mhor) (not mver)) (list 'resizebox hor ver fig))
+            ((and (== mhor 0.0) (== mver 0.0)) fig)
+            ((or (== mhor 1.0) (== mver 1.0)) fig)
+            ((== mhor 0.0) (list 'scalebox (number->string mver) fig))
+            (else (list 'scalebox (number->string mhor) fig))
+      ) ;cond
+    ) ;let*
+  ) ;if
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Metadata for documents
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (tmtex-make-inline t)
+  (tm-replace t '(new-line) '(next-line))
+) ;define
+
+(tm-define (tmtex-inline t) (tmtex (tmtex-make-inline t)))
+
+(tm-define (tmtex-doc-title t) `(title ,(tmtex-inline (cadr t))))
+
+(tm-define (tmtex-doc-running-title t)
+  `(tmrunningtitle ,(tmtex-inline (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-doc-subtitle t)
+  (set! t (tmtex-remove-line-feeds t))
+  `(tmsubtitle ,(tmtex-inline (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-doc-note t)
+  (set! t (tmtex-remove-line-feeds t))
+  `(tmnote ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-doc-misc t)
+  (set! t (tmtex-remove-line-feeds t))
+  `(tmmisc ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-doc-date t) `(date ,(tmtex-inline (cadr t))))
+
+(tm-define (tmtex-doc-running-author t)
+  `(tmrunningauthor ,(tmtex-inline (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-author-name t) `(author ,(tmtex-inline (cadr t))))
+
+(tm-define (tmtex-author-affiliation t)
+  ;; (set! t (tmtex-remove-line-feeds t))
+  `(tmaffiliation ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-author-email t)
+  (set! t (tmtex-remove-line-feeds t))
+  `(tmemail ,(tmtex-inline (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-author-homepage t)
+  (set! t (tmtex-remove-line-feeds t))
+  `(tmhomepage ,(tmtex-inline (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-author-note t)
+  (set! t (tmtex-remove-line-feeds t))
+  `(tmnote ,(tmtex (cadr t)))
+) ;tm-define
+
+(tm-define (tmtex-author-misc t)
+  (set! t (tmtex-remove-line-feeds t))
+  `(tmmisc ,(tmtex (cadr t)))
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Useful macros for metadata presentation
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-select-args-by-func n l) (filter (lambda (x) (func? x n)) l))
+
+(define (tmtex-get-transform l tag)
+  (let ((transform (symbol-append 'tmtex- tag)) (l* (tmtex-select-args-by-func tag l)))
+    (map tmtex l*)
+  ) ;let
+) ;define
+
+(tm-define (tmtex-remove-line-feeds t)
+  (if (npair? t)
+    t
+    (with (r s)
+      (list (car t) (map tmtex-remove-line-feeds (cdr t)))
+      (if (== r 'next-line) '(!concat (tmSep) (!linefeed)) `(,r ,@s))
+    ) ;with
+  ) ;if
+) ;tm-define
+
+(tm-define (tmtex-replace-documents t)
+  (if (npair? t)
+    t
+    (with (r s)
+      (list (car t) (map tmtex-replace-documents (cdr t)))
+      (if (!= r 'document) `(,r ,@s) `(concat ,@(list-intersperse s
+                                                  '(next-line))))
+    ) ;with
+  ) ;if
+) ;tm-define
+
+(tm-define (contains-tags? t l)
+  (cond ((or (nlist? t) (null? t)) #f)
+        ((in? (car t) l) #t)
+        (else (with found?
+                #f
+                (for-each (lambda (x) (set! found? (or found? (contains-tags? x l)))) t)
+                found?
+              ) ;with
+        ) ;else
+  ) ;cond
+) ;tm-define
+
+(tm-define (contains-stree? t u)
+  (cond ((== t u) #t)
+        ((or (null? t) (nlist? t)) #f)
+        (else (with found?
+                #f
+                (for-each (lambda (x) (set! found? (or found? (contains-stree? x u)))) t)
+                found?
+              ) ;with
+        ) ;else
+  ) ;cond
+) ;tm-define
+
+;; Metadata clustering
+
+(define (stree-replace l what by)
+  (cond ((or (null? l) (nlist? l)) l)
+        ((== l what) by)
+        (else (map (lambda (x) (stree-replace x what by)) l))
+  ) ;cond
+) ;define
+
+(define (next-stree-occurence l tag)
+  (cond ((or (null? l) (nlist? l)) #f)
+        ((== (car l) tag) l)
+        (else (with found?
+                #f
+                (map-in-order (lambda (x) (if (not found?) (set! found? (next-stree-occurence x tag))))
+                  l
+                ) ;map-in-order
+                found?
+              ) ;with
+        ) ;else
+  ) ;cond
+) ;define
+
+(define (add-refs l n tag tr tl global-counter?)
+  (with streetag
+    (next-stree-occurence (car l) tag)
+    (if (not streetag)
+      (begin
+        (if global-counter? (set! tmtex-ref-cnt n))
+        l
+      ) ;begin
+      (let* ((n* (number->string n))
+             (tagref (list tr n*))
+             (authors (stree-replace (car l) streetag tagref))
+             (taglist (if (null? (cdr l)) '() (cadr l)))
+             (taglist `(,@taglist (,tl ,n* ,(cadr streetag))))
+             (l* (list authors taglist))
+            ) ;
+        (add-refs l* (1+ n) tag tr tl global-counter?)
+      ) ;let*
+    ) ;if
+  ) ;with
+) ;define
+
+(tm-define (make-references l tag author? global-counter?)
+  (let* ((tag-ref (symbol-append tag '- 'ref))
+         (tag-label (symbol-append tag '- 'label))
+         (cnt (if global-counter? tmtex-ref-cnt 1))
+         (tmp (add-refs `(,l) cnt tag tag-ref tag-label global-counter?))
+         (data-refs (car tmp))
+         (data-labels (if (null? (cdr tmp)) '() (cadr tmp)))
+        ) ;
+    (if author? (set! data-labels `((doc-author (author-data ,@data-labels)))))
+    `(,@data-refs ,@data-labels)
+  ) ;let*
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Author metadata presentation
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-prepare-author-data l) l)
+
+(tm-define (tmtex-make-author names affiliations emails urls miscs notes affs*
+             emails* urls* miscs* notes*
+           ) ;tmtex-make-author
+  (let* ((names (tmtex-concat-Sep (map cadr names)))
+         (result `(,@names ,@notes ,@miscs ,@affiliations ,@emails ,@urls))
+        ) ;
+    (if (null? result) '() `(author (!paragraph ,@result)))
+  ) ;let*
+) ;tm-define
+
+(tm-define (tmtex-doc-author t)
+  (if (or (npair? t) (npair? (cdr t)) (not (func? (cadr t) 'author-data)))
+    '()
+    (let* ((l (tmtex-prepare-author-data (cdadr t)))
+           (names (tmtex-get-transform l 'author-name))
+           (emails (tmtex-get-transform l 'author-email))
+           (urls (tmtex-get-transform l 'author-homepage))
+           (affs (tmtex-get-transform l 'author-affiliation))
+           (miscs (tmtex-get-transform l 'author-misc))
+           (notes (tmtex-get-transform l 'author-note))
+           (emails* (tmtex-get-transform l 'author-email-ref))
+           (urls* (tmtex-get-transform l 'author-homepage-ref))
+           (affs* (tmtex-get-transform l 'author-affiliation-ref))
+           (miscs* (tmtex-get-transform l 'author-misc-ref))
+           (notes* (tmtex-get-transform l 'author-note-ref))
+           (affs (append affs (tmtex-get-transform l 'author-affiliation-label)))
+           (urls (append urls (tmtex-get-transform l 'author-homepage-label)))
+           (miscs (append miscs (tmtex-get-transform l 'author-misc-label)))
+           (notes (append notes (tmtex-get-transform l 'author-note-label)))
+           (emails (append emails (tmtex-get-transform l 'author-email-label)))
+          ) ;
+      (tmtex-make-author names affs emails urls miscs notes affs* emails* urls*
+        miscs* notes*
+      ) ;tmtex-make-author
+    ) ;let*
+  ) ;if
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Document metadata presentation
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-prepare-doc-data l)
+  (set! l (map tmtex-replace-documents l))
+  l
+) ;tm-define
+
+(define (tmtex-make-title titles subtitles notes miscs tr)
+  (let* ((titles (tmtex-concat-Sep (map cadr titles)))
+         (content `(,@titles ,@subtitles ,@notes ,@miscs))
+        ) ;
+    (if (null? content) '() `((title (!indent (!paragraph ,@content)))))
+  ) ;let*
+) ;define
+
+(tm-define (tmtex-append-authors l)
+  (set! l (filter nnull? l))
+  (cond ((null? l) '())
+        ((== (length l) 1) `((author (!indent (!concat ,@(cdar l))))))
+        (else (with lf
+                '(!concat (!linefeed) (and) (!linefeed))
+                `((author (!indent (!concat ,@(list-intersperse (map cadr l) lf)))))
+              ) ;with
+        ) ;else
+  ) ;cond
+) ;tm-define
+
+(tm-define (tmtex-make-doc-data titles subtitles authors dates miscs notes
+             subtits-l dates-l miscs-l notes-l tr ar
+           ) ;tmtex-make-doc-data
+  `(!document ,@(tmtex-make-title titles subtitles notes miscs tr)
+     ,@(tmtex-append-authors authors)
+     ,@dates
+     (maketitle))
+) ;tm-define
+
+(tm-define (tmtex-get-title-option l)
+  (apply append (map cdr (tmtex-select-args-by-func 'doc-title-options l)))
+) ;tm-define
+
+(tm-define (tmtex-doc-data s l)
+  (set! l (tmtex-prepare-doc-data l))
+  (let* ((titles (tmtex-get-transform l 'doc-title))
+         (tr (tmtex-get-transform l 'doc-running-title))
+         (subtits (tmtex-get-transform l 'doc-subtitle))
+         (authors (tmtex-get-transform l 'doc-author))
+         (ar (tmtex-get-transform l 'doc-running-author))
+         (dates (tmtex-get-transform l 'doc-date))
+         (miscs (tmtex-get-transform l 'doc-misc))
+         (notes (tmtex-get-transform l 'doc-note))
+         (subtits-l (tmtex-get-transform l 'doc-subtitle-label))
+         (dates-l (tmtex-get-transform l 'doc-date-label))
+         (miscs-l (tmtex-get-transform l 'doc-misc-label))
+         (notes-l (tmtex-get-transform l 'doc-note-label))
+         (subtits (append subtits (tmtex-get-transform l 'doc-subtitle-ref)))
+         (dates (append dates (tmtex-get-transform l 'doc-date-ref)))
+         (miscs (append miscs (tmtex-get-transform l 'doc-misc-ref)))
+         (notes (append notes (tmtex-get-transform l 'doc-note-ref)))
+        ) ;
+    (tmtex-make-doc-data titles subtits authors dates miscs notes subtits-l
+      dates-l miscs-l notes-l tr ar
+    ) ;tmtex-make-doc-data
+  ) ;let*
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Abstract metadata presentation
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tmtex-abstract t) (tmtex-std-env "abstract" (cdr t)))
+
+(tm-define (tmtex-abstract-keywords t)
+  (with args
+    (list-intersperse (map tmtex (cdr t)) '(tmsep))
+    `(!concat (tmkeywords) ,@(map (lambda (x) `(!group ,x)) args))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-abstract-acm t)
+  (with args
+    (list-intersperse (map tmtex (cdr t)) '(tmsep))
+    `(!concat (tmacm) ,@(map (lambda (x) `(!group ,x)) args))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-abstract-arxiv t)
+  (with args
+    (list-intersperse (map tmtex (cdr t)) '(tmsep))
+    `(!concat (tmarxiv) ,@(map (lambda (x) `(!group ,x)) args))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-abstract-msc t)
+  (with args
+    (list-intersperse (map tmtex (cdr t)) '(tmsep))
+    `(!concat (tmmsc) ,@(map (lambda (x) `(!group ,x)) args))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-abstract-pacs t)
+  (with args
+    (list-intersperse (map tmtex (cdr t)) '(tmsep))
+    `(!concat (tmpacs) ,@(map (lambda (x) `(!group ,x)) args))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-make-abstract-data keywords acm arxiv msc pacs abstract)
+  (with result
+    `(,@abstract ,@acm ,@arxiv ,@msc ,@pacs ,@keywords)
+    (if (null? result) "" `(!document ,@result))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-abstract-data s l)
+  (let* ((acm (map tmtex-abstract-acm (tmtex-select-args-by-func 'abstract-acm l)))
+         (arxiv (map tmtex-abstract-arxiv (tmtex-select-args-by-func 'abstract-arxiv l)))
+         (msc (map tmtex-abstract-msc (tmtex-select-args-by-func 'abstract-msc l)))
+         (pacs (map tmtex-abstract-pacs (tmtex-select-args-by-func 'abstract-pacs l)))
+         (keywords (map tmtex-abstract-keywords (tmtex-select-args-by-func 'abstract-keywords l))
+         ) ;keywords
+         (abstract (map tmtex-abstract (tmtex-select-args-by-func 'abstract l)))
+        ) ;
+    (tmtex-make-abstract-data keywords acm arxiv msc pacs abstract)
+  ) ;let*
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; TeXmacs style primitives
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (tmtex-std-env s l)
+  (if (== s "quote-env") (set! s "quote"))
+  (list (list '!begin s) (tmtex (car l)))
+) ;define
+
+(define (tmtex-footnote s l)
+  `(footnote ,(tmtex (car l)))
+) ;define
+
+(define (tmtex-footnotemark s l)
+  `(footnotemark (!option ,(tmtex (car l))))
+) ;define
+
+(define (filter-enunciation-due-to l)
+  (cond ((func? l 'dueto) (list l))
+        ((nlist>0? l) '())
+        (else (append-map filter-enunciation-due-to l))
+  ) ;cond
+) ;define
+
+(define (filter-enunciation-body l)
+  (cond ((func? l 'dueto) '())
+        ((nlist>0? l) l)
+        (else (filter nnull? (map filter-enunciation-body l)))
+  ) ;cond
+) ;define
+
+(define (tmtex-enunciation s l)
+  (let* ((t (car l))
+         (option (filter-enunciation-due-to t))
+         (option* (map (lambda (x) `(!option ,(tmtex (cadr x)))) option))
+         (body (filter-enunciation-body t))
+        ) ;
+    `((!begin ,s ,@option*) ,(tmtex body))
+  ) ;let*
+) ;define
+
+(define (find-label x)
+  (cond ((npair? x) #f)
+        ((func? x 'label) x)
+        (else (or (find-label (car x)) (find-label (cdr x))))
+  ) ;cond
+) ;define
+
+(define (remove-labels x)
+  (cond ((npair? x) x)
+        ((func? x 'label) "")
+        (else (cons (remove-labels (car x)) (remove-labels (cdr x))))
+  ) ;cond
+) ;define
+
+(define (tmtex-sectional s l)
+  (tmtex-image-increment)
+  (let* ((lab (find-label (car l)))
+         (tit (if lab (remove-labels (car l)) (car l)))
+         (sec (list (string->symbol s) (tmtex tit)))
+        ) ;
+    (if lab (list '!concat sec lab) sec)
+  ) ;let*
+) ;define
+
+(define (tmtex-appendix s l)
+  (with app
+    (list (if (latex-book-style?) 'chapter 'section) (tmtex (car l)))
+    (if tmtex-appendices?
+      app
+      (begin
+        (set! tmtex-appendices? #t)
+        (list '!concat '(appendix) app)
+      ) ;begin
+    ) ;if
+  ) ;with
+) ;define
+
+(define (tmtex-appendix* s l)
+  (with app
+    (list (if (latex-book-style?) 'chapter* 'section*) (tmtex (car l)))
+    (if tmtex-appendices?
+      app
+      (begin
+        (set! tmtex-appendices? #t)
+        (list '!concat '(appendix) app)
+      ) ;begin
+    ) ;if
+  ) ;with
+) ;define
+
+(define (tmtex-tt-document l)
+  (cond ((null? l) "")
+        ((null? (cdr l)) (tmtex-tt (car l)))
+        (else (string-append (tmtex-tt (car l)) "\n" (tmtex-tt-document (cdr l))))
+  ) ;cond
+) ;define
+
+(define (tmtex-tt x)
+  (cond ((string? x) (tmtex-verb-string x))
+        ((== x '(next-line)) "\n")
+        ((func? x 'document) (tmtex-tt-document (cdr x)))
+        ((func? x 'para) (tmtex-tt-document (cdr x)))
+        ((func? x 'concat) (apply string-append (map-in-order tmtex-tt (cdr x))))
+        ((func? x 'mtm 2) (tmtex-tt (cAr x)))
+        ((func? x 'surround 3)
+         (string-append (tmtex-tt (cadr x)) (tmtex-tt (cadddr x)) (tmtex-tt (caddr x)))
+        ) ;
+        ((or (func? x 'hgroup 1) (func? x 'vgroup 1)) (tmtex-tt (cadr x)))
+        ((func? x 'with)
+         (begin
+           (display* "TeXmacs] lost  in verbatim content: " (cDr x) "\n")
+           (tmtex-tt (cAr x))
+         ) ;begin
+        ) ;
+        ((func? x 'math)
+         (begin
+           (display* "TeXmacs] lost  in verbatim content: " (cDr x) "\n")
+           (tmtex-tt (cAr x))
+         ) ;begin
+        ) ;
+        (else (begin (display* "TeXmacs] non converted verbatim content: " x "\n") ""))
+  ) ;cond
+) ;define
+
+(define (unescape-angles l)
+  (cond ((string? l) (string-replace (string-replace l "" "<") "" ">"))
+        ((symbol? l) l)
+        (else (map unescape-angles l))
+  ) ;cond
+) ;define
+
+(define (escape-braces l)
+  (cond ((string? l) (string-replace (string-replace l "{" "\\{") "}" "\\}"))
+        ((symbol? l) l)
+        (else (map escape-braces l))
+  ) ;cond
+) ;define
+
+(define (escape-backslashes l)
+  (cond ((string? l) (string-replace l "\\" "\\textbackslash "))
+        ((symbol? l) l)
+        (else (map escape-backslashes l))
+  ) ;cond
+) ;define
+
+(define (tmtex-new-theorem s l)
+  (with var
+    (tmtex-var-name (car l))
+    (ahash-set! tmtex-dynamic (string->symbol (car l)) 'environment)
+    (ahash-set! tmtex-dynamic (string->symbol var) 'environment)
+    (if (and (logic-in? var latex-texmacs-theorem-environment%))
+      ""
+      `(newtheorem ,var (,@(cdr l)))
+    ) ;if
+  ) ;with
+) ;define
+
+(define (tmtex-verbatim s l)
+  (if (func? (car l) 'document)
+    (list '!verbatim (tmtex-tt (escape-braces (escape-backslashes (car l)))))
+    (list 'tmverbatim (tmtex (car l)))
+  ) ;if
+) ;define
+
+(define (sharp-fix t)
+  (cond ((and (func? t '!document) (nnull? (cdr t)))
+         `(!document ,(sharp-fix (cadr t)) ,@(cddr t))
+        ) ;
+        ((and (func? t '!concat) (nnull? (cdr t)))
+         `(!concat ,(sharp-fix (cadr t)) ,@(cddr t))
+        ) ;
+        ((and (string? t) (string-starts? t "#")) (string-append "\\" t))
+        (else t)
+  ) ;cond
+) ;define
+
+(define (tmtex-verbatim* s l)
+  (if (func? (car l) 'document)
+    (list '!verbatim* (sharp-fix (tmtex-tt (car l))))
+    (list 'tmverbatim (tmtex (car l)))
+  ) ;if
+) ;define
+
+(define (tmtex-code-inline s l)
+  (with lang `((!option ,s)) `(tmcodeinline ,@lang ,(tmtex (car l))))
+) ;define
+
+(define (tmtex-code-block s l)
+  (set! l (escape-backslashes l))
+  (set! l (escape-braces l))
+  (set! s (car (string-decompose s "-")))
+  (if (or (== s "verbatim") (== s "code"))
+    `((!begin* "alltt") ,(tmtex-verbatim* "" l))
+    (with lang
+      `((!option ,s))
+      `((!begin* ,"tmcode" ,@lang) ,(tmtex-verbatim* "" l))
+    ) ;with
+  ) ;if
+) ;define
+
+(define (tmtex-add-preview-packages x)
+  (cond ((list? x) (for-each tmtex-add-preview-packages x))
+        ((nstring? x) (noop))
+        ((string-occurs? "tikzpicture" x) (latex-add-extra "tikz"))
+  ) ;cond
+) ;define
+
+(define (tmtex-mixed s l)
+  (if (func? (cadr l) 'text) (set! l `(,"" ,(cadadr l))))
+  ;; (set! l (unescape-angles l))
+  ;; NOTE: instead, we now unescape in tmtex-verb-string
+  (tmtex-env-set "mode" "text")
+  (with src
+    (list '!verbatim* (tmtex-tt (cadr l)))
+    (tmtex-add-preview-packages src)
+    (tmtex-env-reset "mode")
+    (list '!unindent src)
+  ) ;with
+) ;define
+
+(define (tmtex-listing s l)
+  (list (list '!begin "tmlisting") (tmtex (car l)))
+) ;define
+;; (list (list '!begin "linenumbers") (tmtex (car l))))
+
+(define (tmtex-minipage s l)
+  (let* ((pos (car l))
+         (opt (if (== pos "f") '() `((!option ,pos))))
+         (size (cadr l))
+         (body (caddr l))
+        ) ;
+    `((!begin ,"minipage" ,@opt ,(tmtex-decode-length size)) ,(tmtex body))
+  ) ;let*
+) ;define
+
+(define (tmtex-number-renderer l)
+  (let ((r (cond ((string? l) l) ((list? l) (tmtex-number-renderer (car l))) (else "")))
+       ) ;
+    (cond ((== r "alpha") "alph")
+          ((== r "Alpha") "Alph")
+          (else r)
+    ) ;cond
+  ) ;let
+) ;define
+
+(define (tmtex-number-counter l)
+  (cond ((func? l 'value) (tmtex-number-counter (cdr l)))
+        ((and (list? l) (== 1 (length l))) (tmtex-number-counter (car l)))
+        ((symbol? l) (tmtex-number-counter (symbol->string l)))
+        ((string? l) (if (string-ends? l "-nr") (string-drop-right l 3) l))
+        (else "")
+  ) ;cond
+) ;define
+
+(define (tmtex-number l)
+  (tmtex-default (tmtex-number-renderer (cdr l))
+    (list (tmtex-number-counter (car l)))
+  ) ;tmtex-default
+) ;define
+
+(define (tmtex-change-case l)
+  (cond ((== (cadr l) "UPCASE") (tex-apply 'MakeUppercase (tmtex (car l))))
+        ((== (cadr l) "locase") (tex-apply 'MakeLowercase (tmtex (car l))))
+        (else (tmtex (car l)))
+  ) ;cond
+) ;define
+
+(define (tmtex-frame s l)
+  `(fbox ,(tmtex (car l)))
+) ;define
+
+(define (tmtex-colored-frame s l)
+  `(colorbox ,(tmtex-decode-color (car l)) ,(tmtex (cadr l)))
+) ;define
+
+(define (tmtex-fcolorbox s l)
+  `(fcolorbox ,@(map tmtex-decode-color (cDr l)) ,(tmtex (cAr l)))
+) ;define
+
+(define (tmtex-rotate s l)
+  (let* ((body (tmtex (cadr l)))
+         (body* (if (tmtex-math-mode?) `(ensuremath ,body) body))
+        ) ;
+    `(rotatebox (!option "origin=c") ,(tmtex (car l)) ,body*)
+  ) ;let*
+) ;define
+
+(define (tmtex-translate s l)
+  (let ((from (cadr l)) (to (caddr l)) (body (car l)))
+    (tmtex (translate-from-to body from to))
+  ) ;let
+) ;define
+
+(define (tmtex-localize s l)
+  (with lan
+    (if (list>0? tmtex-languages) (cAr tmtex-languages) "english")
+    (tmtex `(translate ,(car l) ,"english" ,lan))
+  ) ;with
+) ;define
+
+(define (tmtex-render-key s l)
+  (with body
+    (tmtex (car l))
+    (if (func? body '!concat) (set! body `(!append ,@(cdr body))))
+    `(key ,body)
+  ) ;with
+) ;define
+
+(define (tmtex-key s l)
+  (tmtex (tm->stree (tmdoc-key (car l))))
+) ;define
+
+(define (tmtex-key* s l)
+  (tmtex (tm->stree (tmdoc-key* (car l))))
+) ;define
+
+(define (tmtex-padded-center s l)
+  (list (list '!begin "center") (tmtex (car l)))
+) ;define
+
+(define (tmtex-padded-left-aligned s l)
+  (list (list '!begin "flushleft") (tmtex (car l)))
+) ;define
+
+(define (tmtex-padded-right-aligned s l)
+  (list (list '!begin "flushright") (tmtex (car l)))
+) ;define
+
+(define (tmtex-compact s l)
+  (list (list '!begin "tmcompact") (tmtex (car l)))
+) ;define
+
+(define (tmtex-compressed s l)
+  (list (list '!begin "tmcompressed") (tmtex (car l)))
+) ;define
+
+(define (tmtex-amplified s l)
+  (list (list '!begin "tmamplified") (tmtex (car l)))
+) ;define
+
+(define (tmtex-indent s l)
+  (list (list '!begin "tmindent") (tmtex (car l)))
+) ;define
+
+(define (tmtex-jump-in s l)
+  (list (list '!begin "tmjumpin") (tmtex (car l)))
+) ;define
+
+(define (tmtex-script-inout s l)
+  (let ((name (string->symbol (string-append "tm" (string-replace s "-" ""))))
+        (lang (car l))
+        (lang* (session-name (car l)))
+        (in (tmtex (caddr l)))
+        (out (tmtex (cadddr l)))
+       ) ;
+    `(,name ,lang ,lang* ,in ,out)
+  ) ;let
+) ;define
+
+(define (tmtex-converter s l)
+  (let ((name (string->symbol (string-append "tm" (string-replace s "-" ""))))
+        (lang (car l))
+        (lang* (format-get-name (car l)))
+        (in (tmtex (cadr l)))
+        (out (tmtex (caddr l)))
+       ) ;
+    `(,name ,lang ,lang* ,in ,out)
+  ) ;let
+) ;define
+
+(define (tmtex-list-env s l)
+  (let* ((r (string-replace s "-" ""))
+         (t (cond ((== r "enumerateRoman") "enumerateromancap")
+                  ((== r "enumerateAlpha") "enumeratealphacap")
+                  (else r)
+            ) ;cond
+         ) ;t
+        ) ;
+    (list (list '!begin t) (tmtex (car l)))
+  ) ;let*
+) ;define
+
+(define (tmtex-tiny s l)
+  (tex-apply 'tiny (tmtex (car l)))
+) ;define
+
+(define (tmtex-scriptsize s l)
+  (tex-apply 'scriptsize (tmtex (car l)))
+) ;define
+
+(define (tmtex-footnotesize s l)
+  (tex-apply 'footnotesize (tmtex (car l)))
+) ;define
+
+(define (tmtex-small s l)
+  (tex-apply 'small (tmtex (car l)))
+) ;define
+
+(define (tmtex-normalsize s l)
+  (tex-apply 'normalsize (tmtex (car l)))
+) ;define
+
+(define (tmtex-large s l)
+  (tex-apply 'large (tmtex (car l)))
+) ;define
+
+(define (tmtex-Large s l)
+  (tex-apply 'Large (tmtex (car l)))
+) ;define
+
+(define (tmtex-LARGE s l)
+  (tex-apply 'LARGE (tmtex (car l)))
+) ;define
+
+(define (tmtex-Huge s l)
+  (list 'Huge (tmtex (car l)))
+) ;define
+
+(define (tmtex-specific-language s l)
+  (tmtex `(with ,"language" ,s ,(car l)))
+) ;define
+
+(tm-define (tmtex-equation s l)
+  (tmtex-image-increment)
+  (tmtex-env-set "mode" "math")
+  (let ((r (tmtex (car l))))
+    (tmtex-env-reset "mode")
+    (if (== s "equation") (list (list '!begin s) r) (list '!eqn r))
+  ) ;let
+) ;tm-define
+
+(define (tmtex-eqnarray s l)
+  (tmtex-image-increment)
+  (tmtex-env-set "mode" "math")
+  (let ((r (tmtex-table-apply (string->symbol s) '() (car l))))
+    (tmtex-env-reset "mode")
+    r
+  ) ;let
+) ;define
+
+(define (tmtex-math s l)
+  (cond ((tm-in? (car l) '(equation equation* eqnarray eqnarray*)) (tmtex (car l)))
+        ((not (tm-func? (car l) 'document)) (tmtex `(with ,"mode"
+                                                      ,"math"
+                                                      ,(car l))))
+        ((tm-func? (car l) 'document 1) (tmtex `(math ,(cadr (car l)))))
+        (else (with ps (map (lambda (x) `(math ,x)) (cdar l)) (tmtex `(document ,@ps))))
+  ) ;cond
+) ;define
+
+(define (tmtex-textual x)
+  (tmtex-env-set "mode" "text")
+  (with r (tmtex x) (tmtex-env-reset "mode") r)
+) ;define
+
+(define (tmtex-text s l)
+  (list 'text (tmtex-textual (car l)))
+) ;define
+
+(define (tmtex-math-up s l)
+  (post-process-math-text (list 'mathrm (tmtex-textual (car l))))
+) ;define
+
+(define (tmtex-math-ss s l)
+  (post-process-math-text (list 'mathsf (tmtex-textual (car l))))
+) ;define
+
+(define (tmtex-math-tt s l)
+  (post-process-math-text (list 'mathtt (tmtex-textual (car l))))
+) ;define
+
+(define (tmtex-math-bf s l)
+  (post-process-math-text (list 'mathbf (tmtex-textual (car l))))
+) ;define
+
+(define (tmtex-math-sl s l)
+  (post-process-math-text (list 'mathsl (tmtex-textual (car l))))
+) ;define
+
+(define (tmtex-math-it s l)
+  (post-process-math-text (list 'mathit (tmtex-textual (car l))))
+) ;define
+
+(define (tmtex-mathord s l)
+  (list 'mathord (tmtex (car l)))
+) ;define
+
+(define (tmtex-mathbin s l)
+  (list 'mathbin (tmtex (car l)))
+) ;define
+
+(define (tmtex-mathrel s l)
+  (list 'mathrel (tmtex (car l)))
+) ;define
+
+(define (tmtex-mathopen s l)
+  (list 'mathopen (tmtex (car l)))
+) ;define
+
+(define (tmtex-mathclose s l)
+  (list 'mathclose (tmtex (car l)))
+) ;define
+
+(define (tmtex-mathpunct s l)
+  (list 'mathpunct (tmtex (car l)))
+) ;define
+
+(define (tmtex-mathop s l)
+  (list 'mathop (tmtex (car l)))
+) ;define
+
+(define (tmtex-syntax l)
+  (tmtex (car l))
+) ;define
+
+(define (tmtex-theindex s l)
+  (list 'printindex)
+) ;define
+
+(define (tmtex-toc s l)
+  (tex-apply 'tableofcontents)
+) ;define
+
+(define (tmtex-bib-sub doc)
+  (cond ((nlist? doc) doc)
+        ((match? doc '(concat (bibitem* :%1) (label :string?) :*))
+         (let* ((l (cadr (caddr doc))) (s (if (string-starts? l "bib-") (string-drop l 4) l)))
+           (cons* 'concat (list 'bibitem* (cadadr doc) s) (cdddr doc))
+         ) ;let*
+        ) ;
+        ((func? doc 'bib-list 2) (tmtex-bib-sub (cAr doc)))
+        (else (map tmtex-bib-sub doc))
+  ) ;cond
+) ;define
+
+(define (tmtex-bib-max l)
+  (cond ((npair? l) "")
+        ((match? l '(bibitem* :string? :%1)) (cadr l))
+        (else (let* ((s1 (tmtex-bib-max (car l))) (s2 (tmtex-bib-max (cdr l))))
+                (if (< (string-length s1) (string-length s2)) s2 s1)
+              ) ;let*
+        ) ;else
+  ) ;cond
+) ;define
+
+(tm-define (tmtex-biblio s l titled?)
+  (if tmtex-indirect-bib?
+    (tex-concat (list (list 'bibliographystyle (force-string (cadr l)))
+                  (list 'bibliography (force-string (caddr l)))
+                ) ;list
+    ) ;tex-concat
+    (let* ((doc (tmtex-bib-sub (cadddr l)))
+           (max (tmtex-textual (tmtex-bib-max doc)))
+           (tls tmtex-languages)
+           (lan (or (and (pair? tls) (car tls)) "english"))
+           (txt (translate-from-to "References" "english" lan))
+           (bib (tmtex (list 'thebibliography max doc)))
+          ) ;
+      (if titled? `(!document (section* ,(tmtex txt)) ,bib) bib)
+    ) ;let*
+  ) ;if
+) ;tm-define
+
+(tm-define (tmtex-bib t) (tmtex-biblio (car t) (cdr t) #f))
+
+(define (tmtex-thebibliography s l)
+  (list (list '!begin s (car l)) (tmtex (cadr l)))
+) ;define
+
+(define (tmtex-bibitem*-std s l)
+  (cond ((= (length l) 1) `(bibitem ,(car l)))
+        ((= (length l) 2) `(bibitem (!option ,(tmtex (car l))) ,(cadr l)))
+        (else (begin
+                (display* "TeXmacs] non converted bibitem content: " (list s l) "\n")
+                ""
+              ) ;begin
+        ) ;else
+  ) ;cond
+) ;define
+
+(tm-define (tmtex-bibitem* s l) (tmtex-bibitem*-std s l))
+
+(define (split-year s pos)
+  (if (and (> pos 0)
+        (string>=? (substring s (- pos 1) pos) "0")
+        (string<=? (substring s (- pos 1) pos) "9")
+      ) ;and
+    (split-year s (- pos 1))
+    pos
+  ) ;if
+) ;define
+
+(define (natbibify s)
+  (let* ((pos (split-year s (string-length s)))
+         (auth (substring s 0 pos))
+         (year (substring s pos (string-length s)))
+        ) ;
+    (when (== (string-length year) 2)
+      (set! year (string-append (if (string>=? year "30") "19" "20") year))
+    ) ;when
+    (string-append auth "(" year ")")
+  ) ;let*
+) ;define
+
+(tm-define (tmtex-bibitem* s l)
+  (:mode natbib-package?)
+  (if (and (== (length l) 2) (string? (cadr l)) (not (string-occurs? "(" (cadr l))))
+    (tmtex-bibitem*-std s (list (natbibify (cadr l)) (cadr l)))
+    (tmtex-bibitem*-std s l)
+  ) ;if
+) ;tm-define
+
+(define (tmtex-figure s l)
+  (tmtex-float-sub #f "h" (cons (string->symbol s) l))
+) ;define
+
+(define (tmtex-item s l)
+  (tex-concat (list (list 'item) " "))
+) ;define
+
+(define (tmtex-item-arg s l)
+  (tex-concat (list (list 'item (list '!option (tmtex (car l)))) " "))
+) ;define
+
+(define (tmtex-render-proof s l)
+  (list (list '!begin "proof*" (tmtex (car l))) (tmtex (cadr l)))
+) ;define
+
+(define (tmtex-nbsp s l)
+  '(!nbsp)
+) ;define
+
+(define (tmtex-nbhyph s l)
+  '(!nbhyph)
+) ;define
+
+(define (tmtex-frac* s l)
+  (tex-concat (list (tmtex (car l)) "/" (tmtex (cadr l))))
+) ;define
+
+(define (tmtex-ornament-shape s)
+  (if (== s "rounded") "1.7ex" "0pt")
+) ;define
+
+(define (assign-ornament-env l)
+  (let* ((keys* (car l)) (val (cadr l)) (keys (cDr keys*)) (fun (cAr keys*)))
+    (apply string-append
+      (list-intersperse (map (lambda (key)
+                               (with arg (fun val) (if (nstring? arg) "" (string-append key "=" arg)))
+                             ) ;lambda
+                          keys
+                        ) ;map
+        ","
+      ) ;list-intersperse
+    ) ;apply
+  ) ;let*
+) ;define
+
+(define (get-ornament-env)
+  (let* ((l1 (ahash-set->list tmtex-env))
+         (l21 (map (cut logic-ref tex-ornament-opts% <>) l1))
+         (l22 (map (cut tmtex-env-get <>) l1))
+         (l3 (map (lambda (x y) (if (and x y) (list x y) '())) l21 l22))
+         (l4 (filter nnull? l3))
+         (l5 (map assign-ornament-env l4))
+        ) ;
+    (apply string-append (list-intersperse l5 ","))
+  ) ;let*
+) ;define
+
+(define (tmtex-ornamented s l)
+  (if (== s "framed")
+    (if (not (and (pair? (car l)) (in? (caar l) '(document para))))
+      `(fbox ,(tmtex (car l)))
+      `((!begin "mdframed") ,(tmtex (car l)))
+    ) ;if
+    (let* ((env (string-append "tm" s))
+           (option (get-ornament-env))
+           (option* (if (!= option "") `((!option ,option)) '()))
+          ) ;
+      `((!begin ,env ,@option*) ,(tmtex (car l)))
+    ) ;let*
+  ) ;if
+) ;define
+
+(logic-table tex-ornament-opts%
+ ("padding-above" ("skipabove" ,tmtex-decode-length))
+ ("padding-below" ("skipbelow" ,tmtex-decode-length))
+ ("overlined-sep" ("innertopmargin" ,tmtex-decode-length))
+ ("underlined-sep" ("innerbottommargin" ,tmtex-decode-length))
+ ("framed-hsep" ("innerleftmargin" "innerrightmargin" ,tmtex-decode-length))
+ ("framed-vsep" ("innertopmargin" "innerbottommargin" ,tmtex-decode-length))
+ ("ornament-vpadding"
+  ("innertopmargin" "innerbottommargin" ,tmtex-decode-length)
+ ) ;
+ ("ornament-hpadding"
+  ("innerleftmargin" "innerrightmargin" ,tmtex-decode-length)
+ ) ;
+ ("ornament-color" ("backgroundcolor" ,tmtex-decode-color))
+ ("ornament-shape" ("roundcorner" ,tmtex-ornament-shape))
+) ;logic-table
+
+(define (tmtex-tm s l)
+  (with tag
+    (string->symbol (string-append "tm" (string-replace s "-" "")))
+    `(,tag ,@(map tmtex l))
+  ) ;with
+) ;define
+
+(define (tmtex-input-math s l)
+  (let ((tag (string->symbol (string-append "tm" (string-replace s "-" ""))))
+        (a1 (tmtex (car l)))
+        (a2 (with r
+              (begin
+                (tmtex-env-set "mode" "math")
+                (tmtex (cadr l))
+              ) ;begin
+              (tmtex-env-reset "mode")
+              r
+            ) ;with
+        ) ;a2
+       ) ;
+    (list tag a1 a2)
+  ) ;let
+) ;define
+
+(define (tmtex-fold-io-math s l)
+  (let ((tag (string->symbol (string-append "tm" (string-replace s "-" ""))))
+        (a1 (tmtex (car l)))
+        (a2 (with r
+              (begin
+                (tmtex-env-set "mode" "math")
+                (tmtex (cadr l))
+              ) ;begin
+              (tmtex-env-reset "mode")
+              r
+            ) ;with
+        ) ;a2
+        (a3 (tmtex (caddr l)))
+       ) ;
+    (list tag a1 a2 a3)
+  ) ;let
+) ;define
+
+(define (tmtex-session s l)
+  (let* ((tag (string->symbol (string-append "tm" (string-replace s "-" ""))))
+         (arg (tmtex (car l)))
+         (lan (tmtex (cadr l)))
+         (lst (tmtex (caddr l)))
+        ) ;
+    (if (func? lst '!document) (set! lst `(!indent (!paragraph ,@(cdr lst)))))
+    `(!document (,tag ,arg ,lan ,lst))
+  ) ;let*
+) ;define
+
+(define (escape-hyperref-url l)
+  (cond ((string? l)
+         (let* ((r1 (string-replace l "\\" "\\\\"))
+                (r2 (string-replace r1 "#" "\\#"))
+                (r3 (string-replace r2 "_" "\\_"))
+               ) ;
+           r3
+         ) ;let*
+        ) ;
+        ((symbol? l) l)
+        (else (map escape-hyperref-url l))
+  ) ;cond
+) ;define
+
+(define (tmtex-hyperref u)
+  (tmtex-tt (escape-hyperref-url u))
+) ;define
+
+(define (tmtex-hlink s l)
+  (let* ((h (cadr l)) (d (tmtex (car l))))
+    (if (and (string? h) (string-starts? h "#"))
+      (list 'hyperref `(!option ,(string-drop h 1)) d)
+      (list 'href (tmtex-hyperref h) d)
+    ) ;if
+  ) ;let*
+) ;define
+
+(define (tmtex-href s l)
+  (list 'url (tmtex-verb-string (car l)))
+) ;define
+
+(define (tmtex-action s l)
+  (list 'tmaction (tmtex (car l)) (tmtex (cadr l)))
+) ;define
+
+(define (tmtex-choose s l)
+  (list 'binom (tmtex (car l)) (tmtex (cadr l)))
+) ;define
+
+(define (tmtex-text-tt s l)
+  (if (tmtex-math-mode?) (tmtex-math-tt s l) (tmtex-modifier s l))
+) ;define
+
+(define (tmtex-modifier s l)
+  (tex-apply (string->symbol (string-append "tm" s)) (tmtex (car l)))
+) ;define
+
+(define (tmtex-render-line-number s l)
+  (list 'tmlinenumber (tmtex (car l)) (tmtex-decode-length (tmtex (cadr l))))
+) ;define
+
+(define (tmtex-menu-one x)
+  (tmtex (list 'samp x))
+) ;define
+
+(define (tmtex-menu-list l)
+  (if (null? l)
+    l
+    (cons* (list '!math (list 'rightarrow))
+      (tmtex-menu-one (car l))
+      (tmtex-menu-list (cdr l))
+    ) ;cons*
+  ) ;if
+) ;define
+
+(define (tmtex-menu s l)
+  (tex-concat (cons (tmtex-menu-one (car l)) (tmtex-menu-list (cdr l))))
+) ;define
+
+(define ((tmtex-rename into) s l)
+  (tmtex-apply into (tmtex-list l))
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Citations
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (tmtex-cite-list l)
+  (cond ((null? l) "")
+        ((nstring? (car l))
+         (display* "TeXmacs] non converted citation: " (car l) "\n")
+         (tmtex-cite-list (cdr l))
+        ) ;
+        ((null? (cdr l)) (car l))
+        (else (string-append (car l) "," (tmtex-cite-list (cdr l))))
+  ) ;cond
+) ;define
+
+(tm-define (tmtex-cite s l) (tex-apply 'cite (tmtex-cite-list l)))
+
+(tm-define (tmtex-cite s l)
+  (:mode natbib-package?)
+  (tex-apply 'citep (tmtex-cite-list l))
+) ;tm-define
+
+(define (tmtex-nocite s l)
+  (tex-apply 'nocite (tmtex-cite-list l))
+) ;define
+
+(tm-define (tmtex-cite-detail s l)
+  (with c
+    (tmtex-cite-list (list (car l)))
+    (tex-apply 'cite `(!option ,(tmtex (cadr l))) c)
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-cite-detail s l)
+  (:mode natbib-package?)
+  (with c
+    (tmtex-cite-list (list (car l)))
+    (tex-apply 'citetext `(!concat (citealp ,c) ,", " ,(tmtex (cadr l))))
+  ) ;with
+) ;tm-define
+
+(tm-define (tmtex-cite-detail-poor s l)
+  (with c
+    (tmtex-cite-list (list (car l)))
+    `(!concat ,(tex-apply 'cite c) ," (" ,(tmtex (cadr l)) ,")")
+  ) ;with
+) ;tm-define
+
+(define (tmtex-cite-detail-hook s l)
+  (tmtex-cite-detail s l)
+) ;define
+
+(define (tmtex-cite-raw s l)
+  (tex-apply 'citealp (tmtex-cite-list l))
+) ;define
+
+(define (tmtex-cite-raw* s l)
+  (tex-apply 'citealp* (tmtex-cite-list l))
+) ;define
+
+(define (tmtex-cite-textual s l)
+  (tex-apply 'citet (tmtex-cite-list l))
+) ;define
+
+(define (tmtex-cite-textual* s l)
+  (tex-apply 'citet* (tmtex-cite-list l))
+) ;define
+
+(define (tmtex-cite-parenthesized s l)
+  (tex-apply 'citep (tmtex-cite-list l))
+) ;define
+
+(define (tmtex-cite-parenthesized* s l)
+  (tex-apply 'citep* (tmtex-cite-list l))
+) ;define
+
+(define (tmtex-render-cite s l)
+  (tex-apply 'citetext (tmtex (car l)))
+) ;define
+
+(define (tmtex-cite-author s l)
+  (tex-apply 'citeauthor (tmtex (car l)))
+) ;define
+
+(define (tmtex-cite-author* s l)
+  (tex-apply 'citeauthor* (tmtex (car l)))
+) ;define
+
+(define (tmtex-cite-year s l)
+  (tex-apply 'citeyear (tmtex (car l)))
+) ;define
+
+(define (tmtex-natbib-triple s l)
+  `(protect (citeauthoryear ,@(map tmtex l)))
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Glossaries
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (tmtex-glossary s l)
+  (with nr
+    (+ tmtex-auto-produce 1)
+    (set! tmtex-auto-produce nr)
+    `(label ,(string-append "autolab" (number->string nr)))
+  ) ;with
+) ;define
+
+(define (tmtex-glossary-entry s l)
+  (with nr
+    (+ tmtex-auto-consume 1)
+    (with lab
+      (string-append "autolab" (number->string nr))
+      (set! tmtex-auto-consume nr)
+      `(glossaryentry ,(tmtex (car l)) ,(tmtex (cadr l)) (pageref ,lab))
+    ) ;with
+  ) ;with
+) ;define
+
+(define (tmtex-glossary-line t)
+  (with r (tmtex t) (if (func? r 'glossaryentry) r `(listpart ,r)))
+) ;define
+
+(define (tmtex-glossary-body b)
+  (if (not (tm-func? b 'document))
+    (tmtex b)
+    (cons '!document (map-in-order tmtex-glossary-line (cdr b)))
+  ) ;if
+) ;define
+
+(define (tmtex-the-glossary s l)
+  `(!document (,(if (latex-book-style?) 'chapter* 'section*) ,"Glossary")
+     ((!begin ,"theglossary" ,(car l)) ,(tmtex-glossary-body (cadr l))))
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; The main conversion routines
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (tmtex-apply key args)
+  (let ((n (length args))
+        (r (or (ahash-ref tmtex-dynamic key) (logic-ref tmtex-methods% key)))
+       ) ;
+    (if (in? key '(quote quasiquote unquote)) (set! r tmtex-noop))
+    (cond ((== r 'environment) (tmtex-std-env (symbol->string key) args))
+          (r (r args))
+          (else (let ((p (logic-ref tmtex-tmstyle% key)))
+                  (cond ((and p (or (= (cadr p) -1) (= (cadr p) n)))
+                         ((car p) (symbol->string key) args)
+                        ) ;
+                        ((and p (= (cadr p) -2)) ((car p) `(,key ,@args)))
+                        ((and (= n 1) (or (func? (car args) 'tformat) (func? (car args) 'table)))
+                         (tmtex-table-apply key '() (car args))
+                        ) ;
+                        ((and (= n 2) (or (func? (cAr args) 'tformat) (func? (cAr args) 'table)))
+                         (tmtex-table-apply key (cDr args) (cAr args))
+                        ) ;
+                        (else (tmtex-function key args))
+                  ) ;cond
+                ) ;let
+          ) ;else
+    ) ;cond
+  ) ;let
+) ;define
+
+(define (tmtex-function f l)
+  (if (== (string-ref (symbol->string f) 0) #\!)
+    (cons f (map-in-order tmtex l))
+    (let ((v (tmtex-var-name (symbol->string f))))
+      (if (== v "")
+        ""
+        (apply tex-apply (cons (string->symbol v) (map-in-order tmtex l)))
+      ) ;if
+    ) ;let
+  ) ;if
+) ;define
+
+(define (tmtex-compound l)
+  (if (string? (car l)) (tmtex-apply (string->symbol (car l)) (cdr l)) "")
+) ;define
+
+(define (tmtex-list l)
+  (map-in-order tmtex l)
+) ;define
+
+(tm-define (tmtex x)
+  (cond ((string? x) (tmtex-string x))
+        ((list>0? x) (tmtex-apply (car x) (cdr x)))
+        (else "")
+  ) ;cond
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Dispatching
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-dispatcher tmtex-primitives%
+ ((:or unknown uninit error raw-data) tmtex-error)
+ (document tmtex-document)
+ (para tmtex-para)
+ (surround tmtex-surround)
+ (concat tmtex-concat)
+ (rigid tmtex-rigid)
+ (hgroup tmtex-rigid)
+ (vgroup tmtex-id)
+ (hidden tmtex-noop)
+ (hspace tmtex-hspace)
+ (vspace* tmtex-noop)
+ (vspace tmtex-vspace)
+ (space tmtex-space)
+ (htab tmtex-htab)
+ (move tmtex-first)
+ (shift tmtex-first)
+ (resize tmtex-first)
+ (clipped tmtex-first)
+ (repeat tmtex-noop)
+ (float tmtex-float)
+ (datoms tmtex-second)
+ ((:or dlines dpages dbox) tmtex-noop)
+ (line-note tmtex-line-note)
+
+ (with-limits tmtex-noop)
+ (line-break tmtex-line-break)
+ (new-line tmtex-new-line)
+ (next-line tmtex-next-line)
+ (emdash tmtex-emdash)
+ (no-break tmtex-no-break)
+ (no-indent tmtex-no-first-indentation)
+ (yes-indent tmtex-noop)
+ (no-indent* tmtex-noop)
+ (yes-indent* tmtex-noop)
+ (page-break* tmtex-noop)
+ (page-break tmtex-page-break)
+ (no-page-break* tmtex-noop)
+ (no-page-break tmtex-no-page-break)
+ (no-break-here* tmtex-noop)
+ (no-break-here tmtex-no-page-break)
+ (no-break-start tmtex-no-page-break)
+ (no-break-end tmtex-noop)
+ (new-page* tmtex-noop)
+ (new-page tmtex-new-page)
+ (new-dpage* tmtex-noop)
+ (new-dpage tmtex-noop)
+
+ (around tmtex-around)
+ (around* tmtex-around*)
+ (big-around tmtex-big-around)
+ (left tmtex-left)
+ (mid tmtex-mid)
+ (right tmtex-right)
+ (big tmtex-big)
+ (long-arrow tmtex-long-arrow)
+ (lprime tmtex-lsup)
+ (rprime tmtex-rsup)
+ (below tmtex-below)
+ (above tmtex-above)
+ (lsub tmtex-lsub)
+ (lsup tmtex-lsup)
+ (rsub tmtex-rsub)
+ (rsup tmtex-rsup)
+ (modulo tmtex-modulo)
+ (frac tmtex-frac)
+ (sqrt tmtex-sqrt)
+ (wide tmtex-wide)
+ (neg tmtex-neg)
+ (wide* tmtex-wide-star)
+ ;; (tree tmtex-tree)
+ (tree tmtex-tree-eps)
+
+ (tformat tmtex-tformat)
+ ((:or twith cwith tmarker) tmtex-noop)
+ (table tmtex-table)
+ (three-line-table tmtex-three-line-table)
+ ((:or row cell subtable) tmtex-noop)
+
+ (assign tmtex-assign)
+ (with tmtex-with-wrapped)
+ (provides tmtex-noop)
+ (value tmtex-compound)
+ (quote-value tmtex-noop)
+ ((:or quote-value drd-props arg quote-arg) tmtex-noop)
+ (compound tmtex-compound)
+ ((:or xmacro get-label get-arity map-args eval-args mark eval) tmtex-noop)
+ ;; quote missing
+ (quasi tmtex-noop)
+ ;; quasiquote missing
+ ;; unquote missing
+ ((:or unquote* copy if if* case while for-each extern include use-package)
+  tmtex-noop
+ ) ;
+ (syntax tmtex-syntax)
+
+ ((:or or xor and not plus minus times over div mod merge length range find-file
+    is-tuple look-up equal unequal less lesseq greater greatereq
+  ) ;:or
+  tmtex-noop
+ ) ;
+
+ (number tmtex-number)
+ (change-case tmtex-change-case)
+ (date tmtex-date)
+
+ ((:or cm-length mm-length in-length pt-length bp-length dd-length pc-length
+    cc-length fs-length fbs-length em-length ln-length sep-length yfrac-length
+    ex-length fn-length fns-length bls-length spc-length xspc-length par-length
+    pag-length gm-length gh-length
+  ) ;:or
+  tmtex-noop
+ ) ;
+
+ ((:or style-with style-with* style-only style-only* active active* inactive
+    inactive* rewrite-inactive inline-tag open-tag middle-tag close-tag symbol
+    latex hybrid
+  ) ;:or
+  tmtex-noop
+ ) ;
+
+ ((:or tuple attr tmlen collection associate backup) tmtex-noop)
+ (set-binding tmtex-noop)
+ (get-binding tmtex-noop)
+ (hidden-binding tmtex-hidden-binding)
+ (label tmtex-label)
+ (reference tmtex-reference)
+ (pageref tmtex-pageref)
+ (write tmtex-noop)
+ (specific tmtex-specific)
+ ((:or tag meaning flag) tmtex-noop)
+
+ ((:or anim-compose anim-repeat anim-constant anim-translate anim-progressive
+    video sound
+  ) ;:or
+  tmtex-noop
+ ) ;
+
+ (graphics tmtex-graphics)
+ (superpose tmtex-noop)
+ ((:or gr-group gr-transform text-at cline arc carc spline spine* cspline fill)
+  tmtex-noop
+ ) ;
+ (image tmtex-image)
+ ((:or box-info frame-direct frame-inverse) tmtex-noop)
+
+ ((:or format line-sep split delay hold release old-matrix old-table old-mosaic
+    old-mosaic-item set reset expand expand* hide-expand display-baloon apply
+    begin end func env
+  ) ;:or
+  tmtex-noop
+ ) ;
+
+ (shown tmtex-id)
+ (mtm tmtex-mtm)
+ (!file tmtex-file)
+ (!arg tmtex-tex-arg)
+) ;logic-dispatcher
+
+(logic-dispatcher tmtex-extra-methods%
+  (stack tmtex-stack)
+  (wide-float tmtex-wide-float)
+  (phantom-float tmtex-noop)
+  ((:or marginal-note marginal-normal-note) tmtex-marginal-note)
+  ((:or marginal-left-note marginal-even-left-note) tmtex-marginal-left-note)
+  ((:or marginal-right-note marginal-even-right-note) tmtex-marginal-right-note)
+  (!ilx tmtex-ilx)
+) ;logic-dispatcher
+
+(logic-rules ((tmtex-methods% 'x 'y) (tmtex-primitives% 'x 'y))
+ ((tmtex-methods% 'x 'y) (tmtex-extra-methods% 'x 'y))
+) ;logic-rules
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Expansion of all macros which are not recognized by LaTeX
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-table tmtex-tmstyle%
+ ((:or section subsection subsubsection paragraph subparagraph part chapter)
+  (,tmtex-sectional 1)
+ ) ;
+ ((:or hide-preamble show-preamble) (,tmtex-default -1))
+ (hide-part (,tmtex-hide-part -1))
+ (show-part (,tmtex-show-part -1))
+ ((:or doc-title-options author-data) (,tmtex-default -1))
+ (appendix (,tmtex-appendix 1))
+ (appendix* (,tmtex-appendix* 1))
+ ((:or theorem proposition lemma corollary proof axiom definition notation
+    conjecture remark note example convention warning acknowledgments exercise
+    problem question solution answer quote-env quotation verse theorem*
+    proposition* lemma* corollary* axiom* definition* notation* conjecture*
+    remark* note* example* convention* warning* acknowledgments* exercise*
+    problem* question* solution* answer*
+  ) ;:or
+  (,tmtex-enunciation 1)
+ ) ;
+ (new-theorem (,tmtex-new-theorem 2))
+ (new-remark (,tmtex-new-theorem 2))
+ (new-exercise (,tmtex-new-theorem 2))
+ (verbatim (,tmtex-verbatim 1))
+ (padded-center (,tmtex-padded-center 1))
+ (padded-left-aligned (,tmtex-padded-left-aligned 1))
+ (padded-right-aligned (,tmtex-padded-right-aligned 1))
+ (compact (,tmtex-compact 1))
+ (compressed (,tmtex-compressed 1))
+ (amplified (,tmtex-amplified 1))
+ (indent (,tmtex-indent 1))
+ (jump-in (,tmtex-jump-in 1))
+ (algorithm-indent (,tmtex-indent 1))
+ ((:or footnote wide-footnote) (,tmtex-footnote 1))
+ (footnotemark (,tmtex-default 0))
+ (footnotemark* (,tmtex-footnotemark 1))
+ ((:or description description-compact description-aligned description-dash
+    description-long description-paragraphs itemize itemize-minus itemize-dot
+    itemize-arrow enumerate enumerate-numeric enumerate-numeric-bracket
+    enumerate-roman enumerate-roman-bracket enumerate-roman-paren
+    enumerate-Roman enumerate-alpha enumerate-alpha-bracket
+    enumerate-alpha-full-paren enumerate-Alpha enumerate-hanzi
+  ) ;:or
+  (,tmtex-list-env 1)
+ ) ;
+ ((:or folded unfolded folded-plain unfolded-plain folded-std unfolded-std
+    folded-explain unfolded-explain folded-env unfolded-env folded-documentation
+    unfolded-documentation folded-grouped unfolded-grouped summarized detailed
+    summarized-plain summarized-std summarized-env summarized-documentation
+    summarized-grouped summarized-raw summarized-tiny detailed-plain
+    detailed-std detailed-env detailed-documentation detailed-grouped
+    detailed-raw detailed-tiny unfolded-subsession folded-subsession folded-io
+    unfolded-io input output errput timing
+  ) ;:or
+  (,tmtex-tm -1)
+ ) ;
+ ((:or padded underlined overlined bothlined framed ornamented)
+  (,tmtex-ornamented 1)
+ ) ;
+ ((:or folded-io-math unfolded-io-math) (,tmtex-fold-io-math 3))
+ (input-math (,tmtex-input-math 2))
+ (session (,tmtex-session 3))
+ ((:or converter-input converter-output) (,tmtex-converter 3))
+ ((:or script-input script-output) (,tmtex-script-inout 4))
+ (really-tiny (,tmtex-tiny 1))
+ (very-tiny (,tmtex-tiny 1))
+ (tiny (,tmtex-tiny 1))
+ (really-small (,tmtex-scriptsize 1))
+ (very-small (,tmtex-scriptsize 1))
+ (smaller (,tmtex-footnotesize 1))
+ (small (,tmtex-small 1))
+ (flat-size (,tmtex-small 1))
+ (normal-size (,tmtex-normalsize 1))
+ (sharp-size (,tmtex-large 1))
+ (large (,tmtex-large 1))
+ (larger (,tmtex-Large 1))
+ (very-large (,tmtex-LARGE 1))
+ (really-large (,tmtex-LARGE 1))
+ (really-huge (,tmtex-Huge 1))
+ ((:or british bulgarian chinese croatian czech danish dutch english esperanto
+    finnish french german greek hungarian italian japanese korean polish
+    portuguese romanian russian slovak slovene spanish swedish chineset
+    ukrainian
+  ) ;:or
+  (,tmtex-specific-language 1)
+ ) ;
+
+ (math (,tmtex-math 1))
+ (text (,tmtex-text 1))
+ (math-up (,tmtex-math-up 1))
+ (math-ss (,tmtex-math-ss 1))
+ (math-tt (,tmtex-math-tt 1))
+ (math-bf (,tmtex-math-bf 1))
+ (math-sl (,tmtex-math-sl 1))
+ (math-it (,tmtex-math-it 1))
+ (math-separator (,tmtex-mathpunct 1))
+ (math-quantifier (,tmtex-mathord 1))
+ (math-imply (,tmtex-mathbin 1))
+ (math-or (,tmtex-mathbin 1))
+ (math-and (,tmtex-mathbin 1))
+ (math-not (,tmtex-mathord 1))
+ (math-relation (,tmtex-mathrel 1))
+ (math-union (,tmtex-mathbin 1))
+ (math-intersection (,tmtex-mathbin 1))
+ (math-exclude (,tmtex-mathbin 1))
+ (math-plus (,tmtex-mathbin 1))
+ (math-minus (,tmtex-mathbin 1))
+ (math-times (,tmtex-mathbin 1))
+ (math-over (,tmtex-mathbin 1))
+ (math-big (,tmtex-mathop 1))
+ (math-prefix (,tmtex-mathord 1))
+ (math-postfix (,tmtex-mathord 1))
+ (math-open (,tmtex-mathopen 1))
+ (math-close (,tmtex-mathclose 1))
+ (math-ordinary (,tmtex-mathord 1))
+ (math-ignore (,tmtex-mathord 1))
+ ((:or eqnarray eqnarray* leqnarray* gather multline gather* multline* align
+    flalign alignat align* flalign* alignat*
+  ) ;:or
+  (,tmtex-eqnarray 1)
+ ) ;
+
+ (eq-number (,tmtex-default -1))
+ (separating-space (,tmtex-hspace* 1))
+ (application-space (,tmtex-hspace* 1))
+
+ ((:or code cpp-code mmx-code scm-code shell-code scilab-code verbatim-code)
+  (,tmtex-code-block 1)
+ ) ;
+ ((:or mmx cpp scm shell scilab) (,tmtex-code-inline 1))
+
+ (frame (,tmtex-frame 1))
+ (colored-frame (,tmtex-colored-frame 2))
+ (fcolorbox (,tmtex-fcolorbox 3))
+ (rotate (,tmtex-rotate 2))
+ (condensed (,tmtex-style-first 1))
+ (translate (,tmtex-translate 3))
+ (localize (,tmtex-localize 1))
+ (render-key (,tmtex-render-key 1))
+ (key (,tmtex-key 1))
+ (key* (,tmtex-key* 1))
+ (minipage (,tmtex-minipage 3))
+ (latex_preview (,tmtex-mixed 2))
+ (picture-mixed (,tmtex-mixed 2))
+ (source-mixed (,tmtex-mixed 2))
+ (listing (,tmtex-listing 1))
+ (draw-over (,tmtex-make-eps 3))
+ (draw-under (,tmtex-make-eps 3))
+ (version-old (,tmtex-style-first 2))
+ (version-both (,tmtex-style-second 2))
+ (version-new (,tmtex-style-second 2))
+ (the-index (,tmtex-theindex -1))
+ (glossary (,tmtex-glossary 1))
+ (glossary-explain (,tmtex-glossary 2))
+ (glossary-2 (,tmtex-glossary-entry 3))
+ (the-glossary (,tmtex-the-glossary 2))
+ ((:or table-of-contents) (,tmtex-toc 2))
+ (thebibliography (,tmtex-thebibliography 2))
+ (bib-list (,tmtex-style-second 2))
+ (bibitem* (,tmtex-bibitem* -1))
+ ((:or small-figure big-figure small-table big-table) (,tmtex-figure 2))
+ (item (,tmtex-item 0))
+ (item* (,tmtex-item-arg 1))
+ (render-proof (,tmtex-render-proof 2))
+ (nbsp (,tmtex-nbsp 0))
+ (nbhyph (,tmtex-nbhyph 0))
+ (hrule (,tmtex-hrule 0))
+ (frac* (,tmtex-frac* 2))
+ (hlink (,tmtex-hlink 2))
+ (action (,tmtex-action -1))
+ (href (,tmtex-href 1))
+ (slink (,tmtex-href 1))
+ (eqref (,tmtex-eqref 1))
+ (smart-ref (,tmtex-smart-ref -1))
+ (choose (,tmtex-choose 2))
+ (tt (,tmtex-text-tt 1))
+ ((:or strong em name samp abbr dfn kbd var acronym person) (,tmtex-modifier 1))
+ (render-line-number (,tmtex-render-line-number 2))
+ (menu (,tmtex-menu -1))
+ (with-TeXmacs-text (,(tmtex-rename 'withTeXmacstext) 0))
+ (made-by-TeXmacs (,(tmtex-rename 'madebyTeXmacs) 0))
+ (cite-website (,(tmtex-rename 'citewebsite) 0))
+ (tm-made (,(tmtex-rename 'tmmade) 0))
+ (cite (,tmtex-cite -1))
+ (nocite (,tmtex-nocite -1))
+ (cite-detail (,tmtex-cite-detail-hook 2))
+ (cite-raw (,tmtex-cite-raw -1))
+ (cite-raw* (,tmtex-cite-raw* -1))
+ (cite-textual (,tmtex-cite-textual -1))
+ (cite-textual* (,tmtex-cite-textual* -1))
+ (cite-parenthesized (,tmtex-cite-parenthesized -1))
+ (cite-parenthesized* (,tmtex-cite-parenthesized* -1))
+ (citet (,tmtex-cite-textual -1))
+ (citet* (,tmtex-cite-textual* -1))
+ (citep (,tmtex-cite-parenthesized -1))
+ (citep* (,tmtex-cite-parenthesized* -1))
+ (render-cite (,tmtex-render-cite 1))
+ ((:or cite-author cite-author-link) (,tmtex-cite-author 1))
+ ((:or cite-author* cite-author*-link) (,tmtex-cite-author* 1))
+ ((:or cite-year cite-year-link) (,tmtex-cite-year 1))
+ (natbib-triple (,tmtex-natbib-triple 3))
+ (natexlab (,tmtex-noop -1))
+
+ ;; FIXME: we should do something more useful with this information
+ (set-header (,tmtex-noop -1))
+ (set-footer (,tmtex-noop -1))
+ (set-this-page-header (,tmtex-noop -1))
+ (set-this-page-footer (,tmtex-noop -1))
+) ;logic-table
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Tags which are customized in particular style files
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (style-dependent-declare x)
+  (with (tag fun narg)
+    x
+    (with fun+bis
+      (symbol-append fun '+bis)
+      (if (== narg 2)
+        `(begin
+           (when (not (defined? (quote ,fun)))
+             (tm-define (,fun s l) (tmtex-function (string->symbol s) l)))
+           (when (not (defined? (quote ,fun+bis)))
+             (tm-define (,fun+bis s l) (,fun s l))))
+        `(begin
+           (when (not (defined? (quote ,fun)))
+             (tm-define (,fun t)
+               (tmtex-function (string->symbol (car t)) (cdr t))))
+           (when (not (defined? (quote ,fun+bis)))
+             (tm-define (,fun+bis s l)
+               (,fun (append (list (string->symbol s)) l)))))
+      ) ;if
+    ) ;with
+  ) ;with
+) ;tm-define
+
+(tm-define (style-dependent-transform x)
+  (with (tag fun narg)
+    x
+    (with fun+bis (symbol-append fun '+bis) `(,tag
+                                              (,(list 'unquote fun+bis) ,-1)))
+  ) ;with
+) ;tm-define
+
+(define-macro (tmtex-style-dependent . l)
+  `(begin
+     ,@(map style-dependent-declare l)
+     (logic-table tmtex-tmstyle% ,@(map style-dependent-transform l)))
+) ;define-macro
+
+(tmtex-style-dependent
+  ;; to be removed
+  (doc-data tmtex-doc-data 2)
+  (abstract-data tmtex-abstract-data 2)
+  ;; abstract markup
+  (abstract tmtex-abstract 1)
+  (abstract-acm tmtex-abstract-acm 1)
+  (abstract-arxiv tmtex-abstract-arxiv 1)
+  (abstract-msc tmtex-abstract-msc 1)
+  (abstract-pacs tmtex-abstract-pacs 1)
+  (abstract-keywords tmtex-abstract-keywords 1)
+  ;; metadata markup
+  (doc-title tmtex-doc-title 1)
+  (doc-running-title tmtex-doc-running-title 1)
+  (doc-subtitle tmtex-doc-subtitle 1)
+  (doc-note tmtex-doc-note 1)
+  (doc-misc tmtex-doc-misc 1)
+  (doc-date tmtex-doc-date 1)
+  (doc-running-author tmtex-doc-running-author 1)
+  (doc-author tmtex-doc-author 1)
+  (author-name tmtex-author-name 1)
+  (author-affiliation tmtex-author-affiliation 1)
+  (author-misc tmtex-author-misc 1)
+  (author-note tmtex-author-note 1)
+  (author-email tmtex-author-email 1)
+  (author-homepage tmtex-author-homepage 1)
+  ;; references
+  (doc-subtitle-ref tmtex-doc-subtitle-ref 2)
+  (doc-date-ref tmtex-doc-date-ref 2)
+  (doc-note-ref tmtex-doc-note-ref 2)
+  (doc-misc-ref tmtex-doc-misc-ref 2)
+  (author-affiliation-ref tmtex-author-affiliation-ref 2)
+  (author-email-ref tmtex-author-email-ref 2)
+  (author-homepage-ref tmtex-author-homepage-ref 2)
+  (author-note-ref tmtex-author-note-ref 2)
+  (author-misc-ref tmtex-author-misc-ref 2)
+  ;; labels
+  (doc-subtitle-label tmtex-doc-subtitle-label 2)
+  (doc-date-label tmtex-doc-date-label 2)
+  (doc-note-label tmtex-doc-note-label 2)
+  (doc-misc-label tmtex-doc-misc-label 2)
+  (author-affiliation-label tmtex-author-affiliation-label 2)
+  (author-email-label tmtex-author-email-label 2)
+  (author-homepage-label tmtex-author-homepage-label 2)
+  (author-note-label tmtex-author-note-label 2)
+  (author-misc-label tmtex-author-misc-label 2)
+  ;; misc
+  ((:or equation equation*) tmtex-equation 2)
+  (bibliography tmtex-bib 4)
+  (elsevier-frontmatter tmtex-elsevier-frontmatter 2)
+  (conferenceinfo tmtex-acm-conferenceinfo 2)
+  (CopyrightYear tmtex-acm-copyright-year 2)
+  (slide tmtex-beamer-slide 2)
+  (tit tmtex-beamer-tit 2)
+  (crdata tmtex-acm-crdata 2)
+) ;tmtex-style-dependent
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Protected tags
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(logic-group tmtex-protected% a b c d i j k l o r t u v H L O P S aa ae bf cr dh
+  dj dp em fi ge gg ht if in it le lg ll lu lq mp mu ne ng ni nu oe or pi pm rm
+  rq sb sc sf sl sp ss th tt wd wp wr xi AA AE DH DJ Im NG OE Pi Pr Re SS TH Xi
+) ;logic-group
+
+(logic-group tmtex-protected-symbol% space)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Expansion of all macros which are not recognized by LaTeX
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define tmtex-user-defs-table (make-ahash-table))
+
+(define (user-definition? x)
+  (or (and (func? x 'new-theorem 2) (string? (cadr x)))
+    (and (func? x 'assign 2) (string? (cadr x)))
+  ) ;or
+) ;define
+
+(define (collect-user-defs-sub t)
+  (cond ((npair? t) (noop))
+        ((user-definition? t)
+         (ahash-set! tmtex-user-defs-table (string->symbol (cadr t)) #t)
+        ) ;
+        (else (for-each collect-user-defs-sub (cdr t)))
+  ) ;cond
+) ;define
+
+(define (collect-user-defs t)
+  (set! tmtex-user-defs-table (make-ahash-table))
+  (collect-user-defs-sub (cons 'document (tmtex-filter-preamble t)))
+  (ahash-set->list tmtex-user-defs-table)
+) ;define
+
+(define (as-string sym)
+  (with s
+    (symbol->string sym)
+    (if (string-starts? s "begin-") (substring s 6 (string-length s)) s)
+  ) ;with
+) ;define
+
+(define (logic-first-list name)
+  (let* ((l1 (query (cons name '('first 'second))))
+         (l2 (map (cut assoc-ref <> 'first) l1))
+        ) ;
+    (map as-string l2)
+  ) ;let*
+) ;define
+
+(define (collect-user-macros-in t h)
+  (when (tm-compound? t)
+    (when (tree-label-extension? (tm-label t))
+      (ahash-set! h (symbol->string (tm-label t)) #t)
+    ) ;when
+    (for-each (cut collect-user-macros-in <> h) (tm-children t))
+  ) ;when
+) ;define
+
+(define (collect-user-macros t)
+  (with h (make-ahash-table) (collect-user-macros-in t h) (ahash-set->list h))
+) ;define
+
+(define (tmtex-env-macro name)
+  `(associate ,name (xmacro "x" (eval-args "x")))
+) ;define
+
+(define tmtex-always-expand
+  ;; FIXME: find a cleaner way to handle these environments
+  (list "render-theorem"
+    "render-remark"
+    "render-exercise"
+    "render-proof"
+    "algorithm"
+    "algorithm*"
+    "named-algorithm"
+    "named-algorithm-old"
+    "specified-algorithm"
+    "specified-algorithm*"
+    "named-specified-algorithm"
+    "algorithm-body"
+    "numbered"
+
+    "short-item"
+    "short-question"
+    "question-arabic"
+    "question-alpha"
+    "question-Alpha"
+    "question-roman"
+    "question-Roman"
+    "question-item"
+    "answer-arabic"
+    "answer-alpha"
+    "answer-Alpha"
+    "answer-roman"
+    "answer-Roman"
+    "answer-item"
+
+    "gap"
+    "gap-dots"
+    "gap-underlined"
+    "gap-box"
+    "gap-wide"
+    "gap-dots-wide"
+    "gap-underlined-wide"
+    "gap-box-wide"
+    "gap-long"
+    "gap-dots-long"
+    "gap-underlined-long"
+    "gap-box-long"
+
+    "with-button-box"
+    "with-button-box*"
+    "with-button-circle"
+    "with-button-circle*"
+    "with-button-arabic"
+    "with-button-alpha"
+    "with-button-Alpha"
+    "with-button-roman"
+    "with-button-Roman"
+    "mc-field"
+    "mc-wide-field"
+    "show-reply"
+    "hide-reply"
+    "mc"
+    "mc-monospaced"
+    "mc-horizontal"
+    "mc-vertical"
+
+    "textual-table"
+    "numeric-dot-table"
+    "calc-table"
+    "calc-inert"
+    "calc-input"
+    "calc-output"
+    "calc-ref"
+    "cell-inert"
+    "cell-input"
+    "cell-output"
+    "cell-ref"
+    "cell-range"
+    "cell-sum"
+    "cell-plusses"
+    "cell-commas"
+
+    "tmdoc-title"
+    "icon"
+    "shortcut"
+    "key"
+    "prefix"
+    "menu"
+    "render-menu"
+    "submenu"
+    "subsubmenu"
+    "subsubsubmenu"
+    "markup"
+    "tmstyle"
+    "tmpackage"
+    "tmdtd"
+    "def-index"
+    "src-arg"
+    "src-var"
+    "scm-arg"
+    "scm-args"
+    "descriptive-table"
+    "tm-fragment"
+    "framed-fragment"
+    "explain"
+    "explain-synopsis"
+    "explain-macro"
+    "small-envbox"
+    "big-envbox"
+    "small-focus"
+    "big-focus"
+    "cursor"
+    "math-cursor"
+    "TeXmacs-version"
+    "c++"
+    "BibTeX"
+  ) ;list
+) ;define
+
+(tm-define (tmtex-env-patch t l0)
+  (let* ((st (tree->stree t))
+         (l0 (logic-first-list 'tmtex-primitives%))
+         (l1 (logic-first-list 'tmtex-extra-methods%))
+         (l2 (logic-first-list 'tmtex-tmstyle%))
+         (l3 (map as-string (logic-apply-list '(latex-tag%))))
+         (l4 (map as-string (logic-apply-list '(latex-symbol%))))
+         (l5 (list-difference l3 (list-union l4 tmtex-always-expand)))
+         (l6 (map as-string (collect-user-defs st)))
+         (l7 (if (preference-on? "texmacs->latex:expand-user-macros") '() l6))
+         (l8 (list-difference (collect-user-macros st)
+               (list-union l0 l6 tmtex-always-expand)
+             ) ;list-difference
+         ) ;l8
+         (l9 (list-difference (list-union l1 l2 l5 l7 l8) l0))
+         (l10 (list-filter l0 (lambda (s) (and (string? s) (<= (string-length s) 2)))))
+         (l11 (list-difference l10 (list "tt" "em" "op")))
+         (l12 (list-difference l9 l11))
+        ) ;
+    `(collection ,@(map tmtex-env-macro l12))
+  ) ;let*
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Interface
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (tmtex-get-style sty)
+  (cond ((not sty) (set! sty (list "article")))
+        ((string? sty) (set! sty (list sty)))
+        ((func? sty 'tuple) (set! sty (cdr sty)))
+        ((null? sty) (set! sty '("article")))
+  ) ;cond
+  sty
+) ;define
+
+(tm-define (tmtex-postprocess x) x)
+(tm-define (tmtex-postprocess-body x) x)
+
+(tm-define (texmacs->latex x opts)
+  ;; (display* "texmacs->latex [" opts "], " x "\n")
+  (if (tmfile? x)
+    (let* ((body (tmfile-extract x 'body))
+           (style (tmtex-get-style (tmfile-extract x 'style)))
+           (main-style (or (tmtex-transform-style (car style)) "article"))
+           (lan (tmfile-language x))
+           (init (tmfile-extract x 'initial))
+           (att (tmfile-extract x 'attachments))
+           (doc (list '!file body style lan init att (url->string (get-texmacs-path))))
+          ) ;
+      (set! tmtex-cjk-document? (in? lan '("chinese" "chineset" "japanese"
+                                           "korean")))
+      (latex-set-style main-style)
+      (latex-set-packages '())
+      (latex-set-extra '())
+      (set! tmtex-style (car style))
+      (set! tmtex-packages (cdr style))
+      (set! tmtex-languages (list lan))
+      (set! tmtex-colors '())
+      (set! tmtex-colormaps '())
+      (import-tmtex-styles)
+      (tmtex-style-init body)
+      (set! doc (tmtex-style-preprocess doc))
+      (with result
+        (tmtex-postprocess (texmacs->latex doc opts))
+        (set! tmtex-style "generic")
+        (set! tmtex-packages '())
+        result
+      ) ;with
+    ) ;let*
+    (let* ((x2 (tree->stree (tmtm-eqnumber->nonumber (stree->tree x))))
+           (x3 (tmtm-match-brackets x2))
+          ) ;
+      (tmtex-initialize opts)
+      (set! tmtex-image-total (tmtex-count-images x3))
+      (set! tmtex-progress?
+        (and (qt-gui?)
+          (== (assoc-ref opts "texmacs->latex:progress") "on")
+          (> tmtex-image-total 0)
+        ) ;and
+      ) ;set!
+      (when tmtex-progress?
+        (latex-progress-start tmtex-image-total)
+      ) ;when
+      (with r
+        (tmtex (tmpre-produce x3))
+        (if tmtex-mathjax? (set! r (latex-mathjax-pre r)))
+        (if (not tmtex-use-macros?) (set! r (latex-expand-macros r)))
+        (if tmtex-mathjax? (set! r (latex-mathjax r)))
+        (when tmtex-progress?
+          (latex-progress-end)
+          (set! tmtex-progress? #f)
+        ) ;when
+        r
+      ) ;with
+    ) ;let*
+  ) ;if
+) ;tm-define
diff --git a/TeXmacs/plugins/latex/progs/latex/convert-latex-tools.scm b/TeXmacs/plugins/latex/progs/latex/convert-latex-tools.scm
new file mode 100644
index 0000000000..3e5ba6cc7c
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/convert-latex-tools.scm
@@ -0,0 +1,805 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : latex-tools.scm
+;; DESCRIPTION : Routines for expansion of macros and preamble construction
+;; COPYRIGHT   : (C) 2005  Joris van der Hoeven
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex convert-latex-tools)
+  (:use (latex convert-latex-drd) (latex convert-latex-texout))
+) ;texmacs-module
+
+(tm-define tmtex-cjk-document? #f)
+(tm-define tmtex-use-catcodes? #f)
+(tm-define tmtex-use-unicode? #f)
+(tm-define tmtex-use-macros? #f)
+
+(define latex-language "english")
+
+(define latex-style "generic")
+
+(define latex-packages '())
+
+(define latex-extra-packages '())
+
+(define latex-virtual-packages '())
+
+(define latex-all-packages '())
+
+(define latex-texmacs-style "generic")
+
+(define latex-texmacs-packages '())
+
+(define latex-dependencies '("generic"))
+
+(define latex-packages-option (make-ahash-table))
+
+(define latex-uses-table (make-ahash-table))
+
+(define latex-catcode-table (make-ahash-table))
+
+(define latex-macro-table (make-ahash-table))
+
+(define latex-env-table (make-ahash-table))
+
+(define latex-preamble-table (make-ahash-table))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Setting and testing global parameters
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (latex-set-language lan) (set! latex-language lan))
+
+(tm-define (latex-set-style sty)
+  (set! latex-style sty)
+  (latex-set-dependencies)
+) ;tm-define
+
+(tm-define (latex-set-packages ps)
+  (set! latex-packages ps)
+  (latex-set-dependencies)
+) ;tm-define
+
+(tm-define (latex-set-extra ps)
+  (set! latex-extra-packages ps)
+  (latex-set-dependencies)
+) ;tm-define
+
+(tm-define (latex-add-extra p)
+  (when (nin? p latex-extra-packages)
+    (set! latex-extra-packages (cons p latex-extra-packages))
+    (latex-set-dependencies)
+  ) ;when
+) ;tm-define
+
+(tm-define (latex-set-virtual-packages ps)
+  (set! latex-virtual-packages ps)
+  (latex-set-dependencies)
+) ;tm-define
+
+(tm-define (latex-set-texmacs-style sty) (set! latex-texmacs-style sty))
+
+(tm-define (latex-set-texmacs-packages l) (set! latex-texmacs-packages l))
+
+(define (latex-set-dependencies)
+  (set! latex-all-packages
+    (list-remove-duplicates (append latex-packages latex-extra-packages latex-virtual-packages)
+    ) ;list-remove-duplicates
+  ) ;set!
+  (set! latex-dependencies
+    (latex-packages-dependencies (cons latex-style latex-all-packages))
+  ) ;set!
+) ;define
+
+(tm-define (latex-has-style? sty) (== sty latex-style))
+
+(tm-define (latex-has-package? p) (in? p latex-packages))
+
+(tm-define (latex-has-texmacs-style? sty) (== sty latex-texmacs-style))
+
+(tm-define (latex-has-texmacs-package? p) (in? p latex-texmacs-packages))
+
+(tm-define (latex-depends? p) (in? p latex-dependencies))
+
+(tm-define (latex-book-style?) (in? latex-style '("book" "svmono")))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Catcode generation
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (latex-catcode-defs-char c)
+  (let* ((s (string-convert (list->string (list c)) "Cork" "UTF-8"))
+         (r (string-convert s "UTF-8" "LaTeX"))
+        ) ;
+    (if (and (!= r s) (!= (string c) "\n"))
+      (ahash-set! latex-catcode-table (string c) r)
+    ) ;if
+  ) ;let*
+) ;define
+
+(define (latex-catcode-defs-sub doc)
+  (cond ((string? doc) (for-each latex-catcode-defs-char (string->list doc)))
+        ((list? doc) (for-each latex-catcode-defs-sub doc))
+  ) ;cond
+) ;define
+
+(define (latex-catcode-defs-char* c)
+  (if (in? c '(#\< #\>))
+    (ahash-set! latex-catcode-table (string c) (number->string (char->integer c)))
+  ) ;if
+) ;define
+
+(define (env? t x)
+  (and (list>0? t) (func? (car t) '!begin) (list>1? (car t)) (== x (cadar t)))
+) ;define
+
+(define (latex-is-math? t)
+  (or (func? t '!math)
+    (func? t '!eqn)
+    (env? t "equation")
+    (env? t "gather")
+    (env? t "multline")
+    (env? t "split")
+    (env? t "equation*")
+    (env? t "gather*")
+    (env? t "multline*")
+    (env? t "align")
+    (env? t "flalign")
+    (env? t "alignat")
+    (env? t "align*")
+    (env? t "flalign*")
+    (env? t "alignat*")
+  ) ;or
+) ;define
+
+(define (latex-is-text? t)
+  (func? t 'text)
+) ;define
+
+(define (latex-is-verb? t)
+  ;; TODO: consider also macros which expect verbatim args
+  (or (func? t '!verb)
+    (func? t '!verbatim)
+    (func? t '!verbatim*)
+    (func? t 'tmverbatim)
+  ) ;or
+) ;define
+
+(define (latex-catcode-defs-sub* doc text?)
+  (cond ((and text? (string? doc))
+         (for-each latex-catcode-defs-char* (string->list doc))
+        ) ;
+        ((and (list? doc) (latex-is-text? doc))
+         (for-each (cut latex-catcode-defs-sub* <> #t) doc)
+        ) ;
+        ((and (list? doc) (or (latex-is-math? doc) (latex-is-verb? doc)))
+         (for-each (cut latex-catcode-defs-sub* <> #f) doc)
+        ) ;
+        ((list? doc) (for-each (cut latex-catcode-defs-sub* <> text?) doc))
+  ) ;cond
+) ;define
+
+(define (latex-catcode-def key im)
+  (string-append "\\catcode`\\" key "=\\active \\def" key "{" im "}\n")
+) ;define
+
+(tm-define (latex-catcode-defs doc)
+  (:synopsis "Return necessary catcode definitions for @doc")
+  (string-append (if tmtex-use-catcodes?
+                   (begin
+                     (set! latex-catcode-table (make-ahash-table))
+                     (latex-catcode-defs-sub doc)
+                     (let* ((l1 (ahash-table->list latex-catcode-table))
+                            (l2 (list-sort l1 (lambda (x y) (string<=? (car x) (car y)))))
+                            (l3 (map (lambda (x) (latex-catcode-def (car x) (cdr x))) l2))
+                           ) ;
+                       (apply string-append l3)
+                     ) ;let*
+                   ) ;begin
+                   ""
+                 ) ;if
+    (begin
+      (set! latex-catcode-table (make-ahash-table))
+      (latex-catcode-defs-sub* doc #t)
+      (let* ((l1 (ahash-table->list latex-catcode-table))
+             (l2 (list-sort l1 (lambda (x y) (string<=? (car x) (car y)))))
+             (keys (map car l2))
+             (ims (map (lambda (x)
+                         (string-append "\n\\fontencoding{T1}\\selectfont\\symbol{"
+                           (cdr x)
+                           "}\\fontencoding{\\encodingdefault}"
+                         ) ;string-append
+                       ) ;lambda
+                    l2
+                  ) ;map
+             ) ;ims
+             (l3 (map latex-catcode-def keys ims))
+            ) ;
+        (apply string-append l3)
+      ) ;let*
+    ) ;begin
+  ) ;string-append
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Subroutines for reading the database
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (env-begin? x)
+  (or (func? x '!begin) (func? x '!begin*))
+) ;define
+
+(define (latex-texmacs-arity x)
+  (if (env-begin? x)
+    (latex-texmacs-arity (string->symbol (string-append "begin-" (tex-env-name (cadr x))))
+    ) ;latex-texmacs-arity
+    (logic-ref latex-texmacs-arity% x)
+  ) ;if
+) ;define
+
+(define (latex-needs? x)
+  (if (env-begin? x)
+    (latex-needs? (string->symbol (string-append "begin-" (tex-env-name (cadr x)))))
+    (logic-ref latex-needs% x)
+  ) ;if
+) ;define
+
+(define (latex-texmacs-option? x)
+  (if (env-begin? x)
+    (latex-texmacs-option? (string->symbol (string-append "begin-" (tex-env-name (cadr x))))
+    ) ;latex-texmacs-option?
+    (logic-ref latex-texmacs-option% x)
+  ) ;if
+) ;define
+
+(define (latex-texmacs-macro-body x)
+  (smart-ref latex-texmacs-macro x)
+) ;define
+
+(define (latex-texmacs-environment-body x)
+  (smart-ref latex-texmacs-environment (tex-env-name x))
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Macro and environment expansion
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (latex-substitute t args)
+  (cond ((number? t) (list-ref args t))
+        ((== t '---) (car args))
+        ((func? t '!recurse 1) (latex-expand-macros (latex-substitute (cadr t) args)))
+        ((func? t '!translate 1) (translate-from-to (cadr t) "english" latex-language))
+        ((list? t) (map (cut latex-substitute <> args) t))
+        (else t)
+  ) ;cond
+) ;define
+
+(tm-define (latex-expand-macros t)
+  (:synopsis "Expand all TeXmacs macros occurring in @t")
+  (if (npair? t)
+    t
+    (let* ((head (car t))
+           (tail (map latex-expand-macros (cdr t)))
+           (body (latex-texmacs-macro-body head))
+           (arity (and body (latex-texmacs-arity head)))
+           (env (and (env-begin? head) (latex-texmacs-environment-body (cadr head))))
+           (envar (and env (latex-texmacs-arity head)))
+          ) ;
+      (cond ((and body (== (length tail) arity))
+             ;; (latex-substitute body t)
+             (latex-substitute body (cons head tail))
+            ) ;
+            ((and env (== (length tail) 1) (== (length (cddr head)) envar))
+             ;; (latex-substitute env (append (cdr t) (cddr head)))
+             (latex-substitute env (append tail (cddr head)))
+            ) ;
+            (else (cons head tail))
+      ) ;cond
+    ) ;let*
+  ) ;if
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Compute macro and environment definitions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (latex-expand-def t protect?)
+  (cond ((and protect? (number? t)) (set! t `(!group ,t)) (set! protect? #f))
+        ((and (not protect?) (func? t '!option) (set! protect? #t)))
+  ) ;cond
+  (cond ((== t '---) "#-#-#")
+        ((number? t) (string-append "#" (number->string t)))
+        ((func? t '!recurse 1) (latex-expand-def (cadr t) protect?))
+        ((func? t '!translate 1) (translate-from-to (cadr t) "english" latex-language))
+        ((list? t) (map (cut latex-expand-def <> protect?) t))
+        (else t)
+  ) ;cond
+) ;define
+
+;; TODO: to be rewritten with better factorisation
+
+(define (latex-macro-defs-sub t)
+  (when (pair? t)
+    (if (and (or (func? t 'newcommand) (func? t 'renewcommand)) (> (length t) 2))
+      (for-each latex-macro-defs-sub (cddr t))
+      (for-each latex-macro-defs-sub (cdr t))
+    ) ;if
+    (let* ((body (and (not (latex-needs? (car t))) (latex-texmacs-macro-body (car t))))
+           (arity (and body (latex-texmacs-arity (car t))))
+           (option (and body (latex-texmacs-option? (car t))))
+           (args (if option
+                   (filter (lambda (x) (not (and (list? x) (== (car x) '!option)))) (cdr t))
+                   (cdr t)
+                 ) ;if
+           ) ;args
+          ) ;
+      (when (and body (== (length args) arity))
+        (if option (set! arity (+ 1 arity)))
+        (ahash-set! latex-macro-table (car t) (list arity (latex-expand-def body #f)))
+        (latex-macro-defs-sub body)
+      ) ;when
+    ) ;let*
+    (let* ((body (and (env-begin? (car t))
+                   (not (latex-needs? (car t)))
+                   (latex-texmacs-environment-body (cadar t))
+                 ) ;and
+           ) ;body
+           (arity (and body (latex-texmacs-arity (car t))))
+           (option (and body (latex-texmacs-option? (car t))))
+           (args (and body
+                   (if option
+                     (filter (lambda (x) (not (and (list? x) (== (car x) '!option)))) (car t))
+                     (car t)
+                   ) ;if
+                 ) ;and
+           ) ;args
+          ) ;
+      (when (and body (== (length args) (+ arity 2)))
+        (if option (set! arity (+ 1 arity)))
+        (ahash-set! latex-env-table (cadar t) (list arity (latex-expand-def body #f)))
+        (latex-macro-defs-sub body)
+      ) ;when
+    ) ;let*
+    (with body
+      (or (and (not (latex-needs? (car t))) (smart-ref latex-texmacs-preamble (car t)))
+        (and (env-begin? (car t))
+          (not (latex-needs? (car t)))
+          (smart-ref latex-texmacs-env-preamble (cadar t))
+        ) ;and
+      ) ;or
+      (when body
+        (ahash-set! latex-preamble-table
+          (if (env-begin? (car t)) (cadar t) (car t))
+          body
+        ) ;ahash-set!
+        (latex-macro-defs-sub body)
+      ) ;when
+    ) ;with
+  ) ;when
+) ;define
+
+(define (latex<=? x y)
+  (if (symbol? x) (set! x (symbol->string x)))
+  (if (symbol? y) (set! y (symbol->string y)))
+  (if (env-begin? x) (set! x (cadr x)))
+  (if (env-begin? y) (set! y (cadr y)))
+  (string<=? x y)
+) ;define
+
+(tm-define (latex-macro-defs t)
+  (:synopsis "Return necessary macro and environment definitions for @doc")
+  (set! latex-macro-table (make-ahash-table))
+  (set! latex-env-table (make-ahash-table))
+  (set! latex-preamble-table (make-ahash-table))
+  (latex-macro-defs-sub t)
+  (let* ((c1 (ahash-table->list latex-macro-table))
+         (c2 (list-sort c1 (lambda (x y) (latex<=? (car x) (car y)))))
+         (c3 (map (cut cons '!newcommand <>) c2))
+         (e1 (ahash-table->list latex-env-table))
+         (e2 (list-sort e1 (lambda (x y) (latex<=? (car x) (car y)))))
+         (e3 (map (cut cons '!newenvironment <>) e2))
+         (p1 (ahash-table->list latex-preamble-table))
+         (p2 (list-sort p1 (lambda (x y) (latex<=? (car x) (car y)))))
+         (p3 (map cdr (map (cut latex-expand-def <> #f) p2)))
+        ) ;
+    (cons '!append (append c3 e3 p3))
+  ) ;let*
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Serialization of TeXmacs preambles
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (latex-macro-def name arity body)
+  (with option
+    ""
+    (if (and (list>1? body) (list? (car body)) (== (caar body) '!option))
+      (begin
+        (set! option (serialize-latex (latex-expand-def (cadar body) #f)))
+        (set! option (string-append "[" option "]"))
+        (set! body (cadr body))
+      ) ;begin
+    ) ;if
+    (set! body (serialize-latex (latex-expand-def body #f)))
+    (set! body (string-replace body "\n\n" "*/!!/*"))
+    (set! body (string-replace body "\n" " "))
+    (set! body (string-replace body "*/!!/*" "\n\n"))
+    (set! arity (if (= arity 0) "" (string-append "[" (number->string arity) "]")))
+    (string-append "\\newcommand{\\"
+      (symbol->string name)
+      "}"
+      arity
+      option
+      "{"
+      body
+      "}\n"
+    ) ;string-append
+  ) ;with
+) ;define
+
+(define (latex-env-def name arity body)
+  (with option
+    ""
+    (if (and (list>1? body) (list? (car body)) (== (caar body) '!option))
+      (begin
+        (set! option (serialize-latex (latex-expand-def (cadar body) #f)))
+        (set! option (string-append "[" option "]"))
+        (set! body (cadr body))
+      ) ;begin
+    ) ;if
+    (set! body (serialize-latex (latex-expand-def body #f)))
+    (set! body (string-replace body "%\n#-#-#" "#-#-#"))
+    (set! body (string-replace body "%\n  #-#-#" "#-#-#"))
+    (set! body (string-replace body "\n\n" "*/!!/*"))
+    (set! body (string-replace body "\n  " " "))
+    (set! body (string-replace body "\n" " "))
+    (set! body (string-replace body "   #-#-# " "}{"))
+    (set! body (string-replace body "#-#-# " "}{"))
+    (set! body (string-replace body "#-#-#" "}{"))
+    (set! body (string-replace body "*/!!/*" "\n\n"))
+    (set! arity (if (= arity 0) "" (string-append "[" (number->string arity) "]")))
+    (string-append "\\newenvironment{"
+      (tex-env-name name)
+      "}"
+      arity
+      option
+      "{"
+      body
+      "}\n"
+    ) ;string-append
+  ) ;with
+) ;define
+
+(tm-define (latex-serialize-preamble t)
+  (:synopsis "Serialize a LaTeX preamble @t")
+  (cond ((string? t) t)
+        ((func? t '!append)
+         (apply string-append (map latex-serialize-preamble (cdr t)))
+        ) ;
+        ((func? t '!newcommand 3) (apply latex-macro-def (cdr t)))
+        ((func? t '!newenvironment 3) (apply latex-env-def (cdr t)))
+        (else (serialize-latex t))
+  ) ;cond
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Package dependencies management
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (latex-package-direct-dependencies p)
+  (logic-ref-list latex-depends% p)
+) ;define
+
+(define (insert-dependencies l p)
+  (if (null? p)
+    l
+    (if (in? (car p) l)
+      (insert-dependencies l (cdr p))
+      (with deps
+        (latex-package-direct-dependencies (car p))
+        (insert-dependencies (append l (list (car p))) (append deps (cdr p)))
+      ) ;with
+    ) ;if
+  ) ;if
+) ;define
+
+(tm-define (latex-packages-dependencies ps)
+  (:synopsis "Determine all dependencies of packages @ps")
+  (insert-dependencies (list) ps)
+) ;tm-define
+
+(define (non-redundant-package? p among)
+  (with c
+    (latex-packages-dependencies (list-difference among (list p)))
+    (not (in? p c))
+  ) ;with
+) ;define
+
+(tm-define (latex-packages-simplify ps)
+  (:synopsis "Remove all implied packages in package list @ps")
+  (list-filter ps (lambda (p) (non-redundant-package? p ps)))
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Compute usepackage command for a document
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (latex-command-uses s)
+  (with packlist
+    (logic-ref-list latex-needs% s)
+    (for-each (cut ahash-set! latex-uses-table <> #t) packlist)
+  ) ;with
+) ;define
+
+(define (latex-use-which-package l)
+  (when (and (list? l) (nnull? l))
+    (let ((x (car l)))
+      (when (symbol? x)
+        (with s
+          (symbol->string x)
+          (cond ((string-starts? s "left\\")
+                 (latex-command-uses (string->symbol (string-drop s 5)))
+                ) ;
+                ((string-starts? s "right\\")
+                 (latex-command-uses (string->symbol (string-drop s 6)))
+                ) ;
+                (else (latex-command-uses x))
+          ) ;cond
+        ) ;with
+      ) ;when
+      (if (and (list? x) (>= (length l) 2) (== (car x) '!begin))
+        (latex-command-uses (string->symbol (string-append "begin-" (cadr x))))
+      ) ;if
+      (if (match? x '(!begin "enumerate" (!option :%1)))
+        (ahash-set! latex-uses-table "enumerate" #t)
+      ) ;if
+      (for-each latex-use-which-package (cdr l))
+    ) ;let
+  ) ;when
+) ;define
+
+(define (latex-use-package-compare l r)
+  (let* ((tl (logic-ref latex-package-priority% l))
+         (tr (logic-ref latex-package-priority% r))
+         (vl (if tl tl 999999))
+         (vr (if tr tr 999999))
+        ) ;
+    (< vl vr)
+  ) ;let*
+) ;define
+
+(define (filter-packages l)
+  (filter (lambda (x) (nin? x (tmtex-provided-packages))) l)
+) ;define
+
+(define (filter-packages* l)
+  (filter (lambda (x) (nin? (cAr x) (tmtex-provided-packages))) l)
+) ;define
+
+(define (make-use-package l)
+  (with po
+    (ahash-ref latex-packages-option (cAr l))
+    (let* ((optl (if (not po) (cDr l) (append (cDr l) po)))
+           (opt (apply string-append (list-intersperse optl ",")))
+           (sty (cAr l))
+          ) ;
+      (with opts
+        (if (== opt "") "" (string-append "[" opt "]"))
+        (string-append "\\usepackage" opts "{" sty "}\n")
+      ) ;with
+    ) ;let*
+  ) ;with
+) ;define
+
+(tm-define (latex-ifacconf-style?) (== tmtex-style "ifacconf"))
+
+(tm-define (latex-as-use-package l1)
+  (let* ((l2 (sort l1 latex-use-package-compare))
+         (l3 (filter (lambda (x) (and (string? x) (not (ahash-ref latex-packages-option x))))
+               l2
+             ) ;filter
+         ) ;l3
+         (l3* (map (lambda (x) (map force-string x))
+                (filter list>0?
+                  (map (lambda (x) (if (ahash-ref latex-packages-option x) (list x) x)) l2)
+                ) ;filter
+              ) ;map
+         ) ;l3*
+         (l4 (filter-packages l3))
+         (l4* (filter-packages* l3*))
+         (l5 (list-intersperse l4 ","))
+         (s (apply string-append l5))
+         (s* (apply string-append (map make-use-package l4*)))
+        ) ;
+    (if (== s "") s* (string-append "\\usepackage{" s "}\n" s*))
+  ) ;let*
+) ;tm-define
+
+(tm-define (latex-use-package-command doc)
+  (:synopsis "Return the usepackage command for @doc")
+  (set! latex-uses-table (make-ahash-table))
+  (latex-use-which-package doc)
+  (for (p (ahash-table->list latex-packages-option))
+    (ahash-set! latex-uses-table (car p) #t)
+  ) ;for
+  (let* ((l1 latex-all-packages)
+         (s1 (latex-as-use-package (list-difference l1 '("amsthm"))))
+         (l2 (map car (ahash-table->list latex-uses-table)))
+         (s2 (latex-as-use-package (list-difference l2 l1)))
+        ) ;
+    (string-append s1 s2)
+  ) ;let*
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Page size settings
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (latex-preamble-page-type init)
+  (let* ((l0 (ahash-table->list init))
+         (l1 (map car l0))
+         (l2 (map cdr l0))
+         (l3 (map (cut logic-ref latex-paper-opts% <>) l1))
+         (l4 (map (lambda (key val)
+                    (cond ((not val) #f)
+                          ((== key "page-type") (or (logic-ref latex-paper-type% val) '()))
+                          ((== key "page-orientation") val)
+                          ((and (string? key) (!= val "auto"))
+                           (string-append key "=" (tmtex-decode-length val))
+                          ) ;
+                          (else #f)
+                    ) ;cond
+                  ) ;lambda
+               l3
+               l2
+             ) ;map
+         ) ;l4
+         (l5 (filter string? l4))
+         (page-opts (list-intersperse l5 ","))
+        ) ;
+    (if (nnull? page-opts) `(!append (geometry (!concat ,@page-opts)) ,"\n") "")
+  ) ;let*
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Color definitions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (html-color->latex-xcolor s)
+  "Take an hexa html color string and return an hex triplet string"
+  (upcase-all (cond ((string-starts? s "#") (html-color->latex-xcolor (string-tail s 1)))
+                    ((== 3 (string-length s))
+                     (let ((r (substring s 0 1)) (g (substring s 1 2)) (b (substring s 2 3)))
+                       (string-append r r g g b b)
+                     ) ;let
+                    ) ;
+                    ((== 4 (string-length s)) (html-color->latex-xcolor (string-take s 3)))
+                    ((== 6 (string-length s)) s)
+                    ((== 8 (string-length s)) (string-take s 6))
+                    (else s)
+              ) ;cond
+  ) ;upcase-all
+) ;tm-define
+
+(define (latex-colors-defs colors)
+  (apply string-append
+    (map (lambda (x)
+           (string-append "\\definecolor{"
+             (string-replace x " " "")
+             "}{HTML}{"
+             (html-color->latex-xcolor (get-hex-color x))
+             "}\n"
+           ) ;string-append
+         ) ;lambda
+      colors
+    ) ;map
+  ) ;apply
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Building the preamble
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (latex-make-option l)
+  (string-append "[" (apply string-append (list-intersperse l ",")) "]")
+) ;define
+
+(define (set-packages-option pack opts colors)
+  (cond ((nnull? opts) (ahash-set! latex-packages-option pack opts))
+        ((nnull? colors) (ahash-set! latex-packages-option pack (list "")))
+  ) ;cond
+) ;define
+
+(tm-define (latex-extra-preamble) "")
+
+(tm-define (latex-preamble text style lan init colors colormaps)
+  (:synopsis "Compute preamble for @text")
+  (with-global tmtex-style
+    (if (list? style) (cAr style) style)
+    (set! latex-packages-option (make-ahash-table))
+    (set-packages-option "xcolor" colormaps colors)
+    (let* ((Page (latex-preamble-page-type init))
+           (Macro (latex-macro-defs text))
+           (Colors (latex-colors-defs colors))
+           (Text (list '!tuple Page Macro Colors text))
+           (pre-page (latex-serialize-preamble Page))
+           (pre-macro (latex-serialize-preamble Macro))
+           (pre-colors (latex-serialize-preamble Colors))
+           (pre-catcode (latex-catcode-defs Text))
+           (pre-uses (latex-use-package-command Text))
+           (pre-extra (latex-extra-preamble))
+          ) ;
+      (values (cond ((and (in? "amsthm" latex-all-packages) (== style "amsart")) "[amsthm]")
+                    ((list? style) (latex-make-option (cDr style)))
+                    (else "")
+              ) ;cond
+        (string-append pre-uses pre-extra)
+        (string-append pre-page)
+        (string-append pre-catcode pre-macro pre-colors)
+      ) ;values
+    ) ;let*
+  ) ;with-global
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Clean-up the produced LaTeX for use with MathJax
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (latex-mathjax-text l arg)
+  (with x
+    (latex-mathjax-pre arg)
+    (cond ((or (npair? x) (nlist? x)) `(,l ,x))
+          ((func? x 'tmtextsf 1) (latex-mathjax-text 'textsf (cadr x)))
+          ((func? x 'tmtexttt 1) (latex-mathjax-text 'texttt (cadr x)))
+          ((func? x 'tmtextit 1) (latex-mathjax-text 'textit (cadr x)))
+          ((func? x 'tmtextbf 1) (latex-mathjax-text 'textbf (cadr x)))
+          ((func? x 'tmtextrm 1) (latex-mathjax-text l (cadr x)))
+          ((func? x 'tmtextup 1) (latex-mathjax-text l (cadr x)))
+          (else `(,l ,x))
+    ) ;cond
+  ) ;with
+) ;define
+
+(tm-define (latex-mathjax-pre x)
+  (:synopsis "Produce cleaner LaTeX for @x for use with MathJax, pass 1")
+  (cond ((or (npair? x) (nlist? x)) x)
+        ((func? x 'text 1) (latex-mathjax-text 'text (cadr x)))
+        ((func? x 'dotminus 0) '(dot "-"))
+        ((func? x 'dotpm 0) '(dot (pm)))
+        ((func? x 'dotmp 0) '(dot (mp)))
+        ((func? x 'dotamalg 0) '(dot (amalg)))
+        ((func? x 'dotplus 0) '(dot "+"))
+        ((func? x 'dottimes 0) '(dot (times)))
+        ((func? x 'dotast 0) '(dot (ast)))
+        ((func? x 'dag) '(dagger))
+        ((and (func? x 'color 2) (func? (cadr x) '!option 1))
+         ;; NOTE : MathJax has broken color support, so ignore certain colors
+         ;; FIXME: this hack may have to be suppressed when MathJax improves
+         ""
+        ) ;
+        (else (cons (car x) (map latex-mathjax-pre (cdr x))))
+  ) ;cond
+) ;tm-define
+
+(tm-define (latex-mathjax x)
+  (:synopsis "Produce cleaner LaTeX for @x for use with MathJax, pass 2")
+  (cond ((or (npair? x) (nlist? x)) x)
+        ((func? x 'ensuremath 1) (latex-mathjax (cadr x)))
+        ((func? x 'hspace* 1) `(hspace ,(latex-mathjax (cadr x))))
+        ((func? x 'mathbbm 1) `(mathbb ,(latex-mathjax (cadr x))))
+        ((func? x 'fill 0) "3cm")
+        ((func? x 'newcommand) "")
+        ((func? x 'custombinding) "")
+        ((func? x 'nobreak) "")
+        ((func? x 'label) "")
+        (else (cons (car x) (map latex-mathjax (cdr x))))
+  ) ;cond
+) ;tm-define
diff --git a/TeXmacs/plugins/latex/progs/latex/latex-format.scm b/TeXmacs/plugins/latex/progs/latex/latex-format.scm
new file mode 100644
index 0000000000..9110951983
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/latex-format.scm
@@ -0,0 +1,902 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : init-latex.scm
+;; DESCRIPTION : setup latex converters
+;; COPYRIGHT   : (C) 2003  Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex latex-format))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; LaTeX format
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (string-split-lines s)
+  (let ((len (if (>= (string-length s) 1000) 1000 (string-length s))))
+    (let loop
+      ((i 0) (start 0) (result '()))
+      (cond ((>= i len) (reverse (cons (substring s start i) result)))
+            ((char=? (string-ref s i) #\newline)
+             (loop (+ i 1) (+ i 1) (cons (substring s start i) result))
+            ) ;
+            (else (loop (+ i 1) start result))
+      ) ;cond
+    ) ;let
+  ) ;let
+) ;define
+
+(define (backslash-from-string s)
+  (if (not (string-null? s))
+    (let* ((len (string-length s)) (limit (if (>= len 1000) 1000 len)))
+      (let loop
+        ((ref 0) (count 0))
+        (if (>= ref limit)
+          (/ count len)
+          (loop (+ ref 1) (if (char=? (string-ref s ref) #\\) (+ count 1) count))
+        ) ;if
+      ) ;let
+    ) ;let*
+    #f
+  ) ;if
+) ;define
+
+(define (backslash-line-from-string s)
+  (let ((lines (string-split-lines s)))
+    (if (null? lines)
+      0
+      (let loop
+        ((count-lines 0) (count 0) (remaining-lines lines))
+        (if (null? remaining-lines)
+          (if (> count-lines 0) (/ count count-lines) 0)
+          (let ((line (car remaining-lines)))
+            (loop (+ count-lines 1)
+              (if (string-contains? line "\\") (+ count 1) count)
+              (cdr remaining-lines)
+            ) ;loop
+          ) ;let
+        ) ;if
+      ) ;let
+    ) ;if
+  ) ;let
+) ;define
+
+(define (parentheses-from-string s)
+  (if (not (string-null? s))
+    (let* ((len (string-length s)) (limit (if (>= len 1000) 1000 len)))
+      (let loop
+        ((ref 0) (count 0))
+        (if (>= ref limit)
+          (/ count len)
+          (loop (+ ref 1)
+            (if (or (char=? (string-ref s ref) (string-ref "{" 0))
+                  (char=? (string-ref s ref) (string-ref "}" 0))
+                ) ;or
+              (+ count 1)
+              count
+            ) ;if
+          ) ;loop
+        ) ;if
+      ) ;let
+    ) ;let*
+    #f
+  ) ;if
+) ;define
+
+(define (determine-short-string s)
+  (let* ((len (string-length s)))
+    (cond ((and (> len 2)
+             (char=? (string-ref s 0) #\$)
+             (char=? (string-ref s (- len 1)) #\$)
+           ) ;and
+           #t
+          ) ;
+          ((>= (backslash-from-string s) 0.02) #t)
+          (else #f)
+    ) ;cond
+  ) ;let*
+) ;define
+
+(define (is-short-latex-string? s)
+  (if (<= (string-length s) 50) (determine-short-string s) #f)
+) ;define
+
+(define (is-latex-string? s)
+  (let ((percent-slash (backslash-from-string s)))
+    (if (and (>= percent-slash 0.01) (<= percent-slash 0.25))
+      (let ((percent-parentheses (parentheses-from-string s)))
+        (if (>= percent-parentheses 0.01)
+          (let ((percent-backslash-line (backslash-line-from-string s)))
+            (if (>= percent-backslash-line 0.25) #t #f)
+          ) ;let
+          #f
+        ) ;if
+      ) ;let
+      #f
+    ) ;if
+  ) ;let
+) ;define
+
+(define (latex-recognizes-at? s pos)
+  (set! pos (format-skip-spaces s pos))
+  (cond ((format-test? s pos "\\document") #t)
+        ((format-test? s pos "\\documentclass") #t)
+        ((format-test? s pos "\\usepackage") #t)
+        ((format-test? s pos "\\title") #t)
+        ((format-test? s pos "\\newcommand") #t)
+        ((format-test? s pos "\\input") #t)
+        ((format-test? s pos "\\includeonly") #t)
+        ((format-test? s pos "\\chapter") #t)
+        ((format-test? s pos "\\appendix") #t)
+        ((format-test? s pos "\\section") #t)
+        ((format-test? s pos "\\footnote") #t)
+        ((format-test? s pos "\\marginpar") #t)
+        ((format-test? s pos "\\begin") #t)
+        ((format-test? s pos "\\end") #t)
+        ((format-test? s pos "\\begin{") #t)
+        ((format-test? s pos "\\end{") #t)
+        ((format-test? s pos "\\alpha") #t)
+        ((format-test? s pos "\\beta") #t)
+        ((format-test? s pos "\\gamma") #t)
+        ((format-test? s pos "\\ref") #t)
+        ((format-test? s pos "\\textbf") #t)
+        ((format-test? s pos "\\textit") #t)
+        ((format-test? s pos "\\mathbb") #t)
+        ((format-test? s pos "\\mathcal") #t)
+        ((format-test? s pos "\\frac") #t)
+        ((format-test? s pos "\\cite") #t)
+        ((format-test? s pos "\\item") #t)
+        ((format-test? s pos "\\[") #t)
+        ((format-test? s pos "\\(") #t)
+        ((is-short-latex-string? s) #t)
+        ((is-latex-string? s) #t)
+        (else #f)
+  ) ;cond
+) ;define
+
+(define (latex-recognizes? s)
+  (and (string? s) (latex-recognizes-at? s 0))
+) ;define
+
+(define-format latex
+  (:name "LaTeX")
+  (:suffix "tex")
+  (:recognize latex-recognizes?)
+) ;define-format
+
+(define-format latex-class (:name "LaTeX class") (:suffix "ltx" "sty" "cls"))
+
+(define-preferences ("texmacs->latex:transparent-tracking" "on" noop))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; TeXmacs->LaTeX
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(lazy-define (latex convert-latex-texout) serialize-latex)
+(lazy-define (latex convert-latex-tmtex) texmacs->latex)
+
+(converter texmacs-stree
+  latex-stree
+  (:function-with-options texmacs->latex)
+  (:option "texmacs->latex:source-tracking" "off")
+  (:option "texmacs->latex:conservative" "on")
+  (:option "texmacs->latex:transparent-source-tracking" "on")
+  (:option "texmacs->latex:attach-tracking-info" "on")
+  (:option "texmacs->latex:replace-style" "on")
+  (:option "texmacs->latex:expand-macros" "on")
+  (:option "texmacs->latex:expand-user-macros" "off")
+  (:option "texmacs->latex:indirect-bib" "off")
+  (:option "texmacs->latex:use-macros" "off")
+  (:option "texmacs->latex:encoding" "UTF-8")
+) ;converter
+
+(converter latex-stree latex-document (:function serialize-latex))
+
+(converter latex-stree latex-snippet (:function serialize-latex))
+
+(tm-define (texmacs->latex-document x opts)
+  (serialize-latex (texmacs->latex (tm->stree x) opts))
+) ;tm-define
+
+(converter texmacs-stree
+  latex-document
+  (:function-with-options conservative-texmacs->latex)
+  ;; (:function-with-options tracked-texmacs->latex)
+  (:option "texmacs->latex:source-tracking" "off")
+  (:option "texmacs->latex:conservative" "on")
+  (:option "texmacs->latex:transparent-source-tracking" "on")
+  (:option "texmacs->latex:attach-tracking-info" "on")
+  (:option "texmacs->latex:replace-style" "on")
+  (:option "texmacs->latex:expand-macros" "on")
+  (:option "texmacs->latex:expand-user-macros" "off")
+  (:option "texmacs->latex:indirect-bib" "off")
+  (:option "texmacs->latex:use-macros" "on")
+  (:option "texmacs->latex:encoding" "UTF-8")
+) ;converter
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; LaTeX -> TeXmacs
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (latex-document->texmacs x . opts)
+  (if (list-1? opts) (set! opts (car opts)))
+  (with as-pic
+    (== (get-preference "latex->texmacs:fallback-on-pictures") "on")
+    (conservative-latex->texmacs x as-pic)
+  ) ;with
+) ;tm-define
+
+(converter latex-document latex-tree (:function parse-latex-document))
+
+(converter latex-snippet latex-tree (:function parse-latex))
+
+(converter latex-class-document
+  texmacs-tree
+  (:function latex-class-document->texmacs)
+) ;converter
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Post-processing imported LaTeX: insert space between d and differential
+;; variables so they are not merged into a single operator in math mode.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (is-letter-char? c)
+  (and (char? c)
+    (or (and (char>=? c #\a) (char<=? c #\z)) (and (char>=? c #\A) (char<=? c #\Z)))
+  ) ;and
+) ;define
+
+(define (is-word-boundary-before? s i)
+  (or (= i 0) (not (is-letter-char? (string-ref s (- i 1)))))
+) ;define
+
+(define (is-word-boundary-after? s i)
+  (or (= i (- (string-length s) 1))
+    (not (is-letter-char? (string-ref s (+ i 1))))
+  ) ;or
+) ;define
+
+(define (match-differential s i)
+  (and (< i (- (string-length s) 1))
+    (char=? (string-ref s i) #\d)
+    (char=? (string-ref s (+ i 1)) #\*)
+    (let ((rest (substring s (+ i 2) (string-length s))))
+      (cond ((or (string-starts? rest "x")
+               (string-starts? rest "y")
+               (string-starts? rest "z")
+               (string-starts? rest "r")
+               (string-starts? rest "t")
+               (string-starts? rest "u")
+               (string-starts? rest "v")
+               (string-starts? rest "w")
+             ) ;or
+             (cons 1 (substring rest 0 1))
+            ) ;
+            ((string-starts? rest "") (cons 5 ""))
+            ((string-starts? rest "") (cons 8 ""))
+            ((string-starts? rest "") (cons 7 ""))
+            ((string-starts? rest "") (cons 10 ""))
+            ((string-starts? rest "") (cons 5 ""))
+            ((string-starts? rest "") (cons 9 ""))
+            ((string-starts? rest "") (cons 5 ""))
+            ((string-starts? rest "") (cons 8 ""))
+            ((string-starts? rest "") (cons 7 ""))
+            (else #f)
+      ) ;cond
+    ) ;let
+  ) ;and
+) ;define
+
+(define (match-math-index-combination s i)
+  (let ((rest (substring s i (string-length s))))
+    (cond ((or (string-starts? rest "i*j*k") (string-starts? rest "ijk"))
+           (let ((len (if (string-starts? rest "i*j*k") 5 3)))
+             (and (is-word-boundary-before? s i)
+               (is-word-boundary-after? s (+ i (- len 1)))
+               (cons len '("i" " " "j" " " "k"))
+             ) ;and
+           ) ;let
+          ) ;
+          ((or (string-starts? rest "x*y*z") (string-starts? rest "xyz"))
+           (let ((len (if (string-starts? rest "x*y*z") 5 3)))
+             (and (is-word-boundary-before? s i)
+               (is-word-boundary-after? s (+ i (- len 1)))
+               (cons len '("x" " " "y" " " "z"))
+             ) ;and
+           ) ;let
+          ) ;
+          ((or (string-starts? rest "i*j") (string-starts? rest "ij"))
+           (let ((len (if (string-starts? rest "i*j") 3 2)))
+             (and (is-word-boundary-before? s i)
+               (is-word-boundary-after? s (+ i (- len 1)))
+               (cons len '("i" " " "j"))
+             ) ;and
+           ) ;let
+          ) ;
+          ((or (string-starts? rest "j*k") (string-starts? rest "jk"))
+           (let ((len (if (string-starts? rest "j*k") 3 2)))
+             (and (is-word-boundary-before? s i)
+               (is-word-boundary-after? s (+ i (- len 1)))
+               (cons len '("j" " " "k"))
+             ) ;and
+           ) ;let
+          ) ;
+          ((or (string-starts? rest "k*l") (string-starts? rest "kl"))
+           (let ((len (if (string-starts? rest "k*l") 3 2)))
+             (and (is-word-boundary-before? s i)
+               (is-word-boundary-after? s (+ i (- len 1)))
+               (cons len '("k" " " "l"))
+             ) ;and
+           ) ;let
+          ) ;
+          ((or (string-starts? rest "l*m") (string-starts? rest "lm"))
+           (let ((len (if (string-starts? rest "l*m") 3 2)))
+             (and (is-word-boundary-before? s i)
+               (is-word-boundary-after? s (+ i (- len 1)))
+               (cons len '("l" " " "m"))
+             ) ;and
+           ) ;let
+          ) ;
+          ((or (string-starts? rest "m*n") (string-starts? rest "mn"))
+           (let ((len (if (string-starts? rest "m*n") 3 2)))
+             (and (is-word-boundary-before? s i)
+               (is-word-boundary-after? s (+ i (- len 1)))
+               (cons len '("m" " " "n"))
+             ) ;and
+           ) ;let
+          ) ;
+          ((or (string-starts? rest "p*q") (string-starts? rest "pq"))
+           (let ((len (if (string-starts? rest "p*q") 3 2)))
+             (and (is-word-boundary-before? s i)
+               (is-word-boundary-after? s (+ i (- len 1)))
+               (cons len '("p" " " "q"))
+             ) ;and
+           ) ;let
+          ) ;
+          ((or (string-starts? rest "r*s") (string-starts? rest "rs"))
+           (let ((len (if (string-starts? rest "r*s") 3 2)))
+             (and (is-word-boundary-before? s i)
+               (is-word-boundary-after? s (+ i (- len 1)))
+               (cons len '("r" " " "s"))
+             ) ;and
+           ) ;let
+          ) ;
+          ((or (string-starts? rest "x*y") (string-starts? rest "xy"))
+           (let ((len (if (string-starts? rest "x*y") 3 2)))
+             (and (is-word-boundary-before? s i)
+               (is-word-boundary-after? s (+ i (- len 1)))
+               (cons len '("x" " " "y"))
+             ) ;and
+           ) ;let
+          ) ;
+          ((or (string-starts? rest "a*b") (string-starts? rest "ab"))
+           (let ((len (if (string-starts? rest "a*b") 3 2)))
+             (and (is-word-boundary-before? s i)
+               (is-word-boundary-after? s (+ i (- len 1)))
+               (cons len '("a" " " "b"))
+             ) ;and
+           ) ;let
+          ) ;
+          ((or (string-starts? rest "c*d") (string-starts? rest "cd"))
+           (let ((len (if (string-starts? rest "c*d") 3 2)))
+             (and (is-word-boundary-before? s i)
+               (is-word-boundary-after? s (+ i (- len 1)))
+               (cons len '("c" " " "d"))
+             ) ;and
+           ) ;let
+          ) ;
+          ((or (string-starts? rest "u*v") (string-starts? rest "uv"))
+           (let ((len (if (string-starts? rest "u*v") 3 2)))
+             (and (is-word-boundary-before? s i)
+               (is-word-boundary-after? s (+ i (- len 1)))
+               (cons len '("u" " " "v"))
+             ) ;and
+           ) ;let
+          ) ;
+          (else #f)
+    ) ;cond
+  ) ;let
+) ;define
+
+(define (transform-math-string s)
+  (let* ((n (string-length s)) (res '()))
+    (let loop
+      ((i 0) (last-idx 0))
+      (cond ((>= i n)
+             (if (null? res)
+               s
+               (begin
+                 (if (< last-idx n) (set! res (append res (list (substring s last-idx n)))))
+                 (cons 'concat res)
+               ) ;begin
+             ) ;if
+            ) ;
+            (else (let ((idx-match (match-math-index-combination s i)))
+                    (if idx-match
+                      (let* ((match-len (car idx-match)) (chars (cdr idx-match)))
+                        (if (> i last-idx) (set! res (append res (list (substring s last-idx i)))))
+                        (set! res (append res chars))
+                        (loop (+ i match-len) (+ i match-len))
+                      ) ;let*
+                      (let ((diff-match (match-differential s i)))
+                        (if (and diff-match
+                              (is-word-boundary-before? s i)
+                              (is-word-boundary-after? s (+ i 1 (car diff-match)))
+                            ) ;and
+                          (let* ((match-len (car diff-match)) (var (cdr diff-match)))
+                            (if (> i last-idx) (set! res (append res (list (substring s last-idx i)))))
+                            (set! res (append res (list "d" " " var)))
+                            (loop (+ i 2 match-len) (+ i 2 match-len))
+                          ) ;let*
+                          (loop (+ i 1) last-idx)
+                        ) ;if
+                      ) ;let
+                    ) ;if
+                  ) ;let
+            ) ;else
+      ) ;cond
+    ) ;let
+  ) ;let*
+) ;define
+
+(define (transform-concat-children children)
+  (cond ((null? children) '())
+        ((and (pair? children) (pair? (cdr children)))
+         (let* ((c1 (car children)) (c2 (cadr children)))
+           (if (and (string? c1)
+                 (string? c2)
+                 (or (string=? c2 "")
+                   (string=? c2 "")
+                   (string=? c2 "")
+                   (string=? c2 "")
+                   (string=? c2 "")
+                   (string=? c2 "")
+                   (string=? c2 "")
+                   (string=? c2 "")
+                   (string=? c2 "")
+                 ) ;or
+                 (let ((len (string-length c1)))
+                   (and (> len 0)
+                     (char=? (string-ref c1 (- len 1)) #\d)
+                     (or (= len 1) (not (is-letter-char? (string-ref c1 (- len 2)))))
+                   ) ;and
+                 ) ;let
+               ) ;and
+             (let* ((len (string-length c1))
+                    (prefix (if (> len 1) (substring c1 0 (- len 1)) #f))
+                    (spaced-part (if prefix (list prefix "d" " " c2) (list "d" " " c2)))
+                   ) ;
+               (append spaced-part (transform-concat-children (cddr children)))
+             ) ;let*
+             (cons (car children) (transform-concat-children (cdr children)))
+           ) ;if
+         ) ;let*
+        ) ;
+        (else children)
+  ) ;cond
+) ;define
+
+(define math-environments
+  '(math equation equation* eqnarray eqnarray* align align* multline multline*)
+) ;define
+
+(define (upgrade-latex-differentials-stree t in-math)
+  (cond ((string? t) (if in-math (transform-math-string t) t))
+        ((pair? t)
+         (let* ((head (car t)) (next-in-math (or in-math (memq head math-environments))))
+           (if (and next-in-math (eq? head 'concat))
+             (let* ((new-children (map (lambda (x) (upgrade-latex-differentials-stree x #t)) (cdr t))
+                    ) ;new-children
+                    (transformed-children (transform-concat-children new-children))
+                   ) ;
+               (cons 'concat transformed-children)
+             ) ;let*
+             (cons head
+               (map (lambda (x) (upgrade-latex-differentials-stree x next-in-math)) (cdr t))
+             ) ;cons
+           ) ;if
+         ) ;let*
+        ) ;
+        (else t)
+  ) ;cond
+) ;define
+
+(define (has-cwith-property? options row-start row-end col-start col-end
+          property value-pred
+        ) ;has-cwith-property?
+  (cond ((null? options) #f)
+        ((and (pair? (car options)) (eq? (caar options) 'cwith))
+         (let* ((opt (car options))
+                (r-start (and (> (length opt) 1) (list-ref opt 1)))
+                (r-end (and (> (length opt) 2) (list-ref opt 2)))
+                (c-start (and (> (length opt) 3) (list-ref opt 3)))
+                (c-end (and (> (length opt) 4) (list-ref opt 4)))
+                (prop (and (> (length opt) 5) (list-ref opt 5)))
+                (val (and (> (length opt) 6) (list-ref opt 6)))
+               ) ;
+           (if (and (or (not row-start) (equal? r-start row-start))
+                 (or (not row-end) (equal? r-end row-end))
+                 (or (not col-start) (equal? c-start col-start))
+                 (or (not col-end) (equal? c-end col-end))
+                 (or (not property) (equal? prop property))
+                 (and val (value-pred val))
+               ) ;and
+             #t
+             (has-cwith-property? (cdr options)
+               row-start
+               row-end
+               col-start
+               col-end
+               property
+               value-pred
+             ) ;has-cwith-property?
+           ) ;if
+         ) ;let*
+        ) ;
+        (else (has-cwith-property? (cdr options)
+                row-start
+                row-end
+                col-start
+                col-end
+                property
+                value-pred
+              ) ;has-cwith-property?
+        ) ;else
+  ) ;cond
+) ;define
+
+(define (find-table-num-rows children)
+  (cond ((null? children) 0)
+        ((and (pair? (car children)) (eq? (caar children) 'table))
+         (length (cdar children))
+        ) ;
+        (else (find-table-num-rows (cdr children)))
+  ) ;cond
+) ;define
+
+(define (is-three-line-table-tformat? x)
+  (if (and (pair? x) (eq? (car x) 'tformat))
+    (let* ((options (cdr x)) (num-rows (find-table-num-rows options)))
+      (if (> num-rows 0)
+        (let* ((has-top? (has-cwith-property? options
+                           "1"
+                           "1"
+                           #f
+                           #f
+                           "cell-tborder"
+                           (lambda (v) (not (equal? v "0ln")))
+                         ) ;has-cwith-property?
+               ) ;has-top?
+               (has-bottom? (has-cwith-property? options
+                              (number->string num-rows)
+                              (number->string num-rows)
+                              #f
+                              #f
+                              "cell-bborder"
+                              (lambda (v) (not (equal? v "0ln")))
+                            ) ;has-cwith-property?
+               ) ;has-bottom?
+               (has-vertical? (has-cwith-property? options
+                                #f
+                                #f
+                                #f
+                                #f
+                                "cell-lborder"
+                                (lambda (v) (not (equal? v "0ln")))
+                              ) ;has-cwith-property?
+               ) ;has-vertical?
+               (has-vertical-r? (has-cwith-property? options
+                                  #f
+                                  #f
+                                  #f
+                                  #f
+                                  "cell-rborder"
+                                  (lambda (v) (not (equal? v "0ln")))
+                                ) ;has-cwith-property?
+               ) ;has-vertical-r?
+              ) ;
+          (and has-top? has-bottom? (not has-vertical?) (not has-vertical-r?))
+        ) ;let*
+        #f
+      ) ;if
+    ) ;let*
+    #f
+  ) ;if
+) ;define
+
+(define (transform-three-line-tables x)
+  (cond ((null? x) '())
+        ((and (pair? x) (eq? (car x) 'tformat))
+         (let ((transformed-args (map transform-three-line-tables (cdr x))))
+           (let ((new-tformat (cons 'tformat transformed-args)))
+             (if (is-three-line-table-tformat? new-tformat)
+               (list 'three-line-table new-tformat)
+               new-tformat
+             ) ;if
+           ) ;let
+         ) ;let
+        ) ;
+        ((pair? x)
+         (cons (transform-three-line-tables (car x))
+           (transform-three-line-tables (cdr x))
+         ) ;cons
+        ) ;
+        (else x)
+  ) ;cond
+) ;define
+
+(define (clean-multirow t)
+  (cond ((null? t) (cons '() #f))
+        ((and (pair? t) (eq? (car t) 'multirow))
+         (let ((n (list-ref t 1))
+               (w (list-ref t 2))
+               (text (if (> (length t) 3) (list-ref t 3) ""))
+              ) ;
+           (cons text (cons n w))
+         ) ;let
+        ) ;
+        ((pair? t)
+         (let* ((res-car (clean-multirow (car t))) (res-cdr (clean-multirow (cdr t))))
+           (cond ((cdr res-car) (cons (cons (car res-car) (car res-cdr)) (cdr res-car)))
+                 ((cdr res-cdr) (cons (cons (car res-car) (car res-cdr)) (cdr res-cdr)))
+                 (else (cons (cons (car res-car) (car res-cdr)) #f))
+           ) ;cond
+         ) ;let*
+        ) ;
+        (else (cons t #f))
+  ) ;cond
+) ;define
+
+(define (process-row-cells cells r c options-acc new-cells-acc)
+  (cond ((null? cells) (cons (reverse new-cells-acc) options-acc))
+        (else (let* ((cell (car cells))
+                     (cleaned-res (clean-multirow cell))
+                     (new-cell (car cleaned-res))
+                     (info (cdr cleaned-res))
+                    ) ;
+                (if info
+                  (let* ((n (car info))
+                         (row-str (number->string r))
+                         (col-str (number->string c))
+                         (new-opt1 (list 'cwith row-str row-str col-str col-str "cell-row-span" n))
+                         (new-opt2 (list 'cwith row-str row-str col-str col-str "cell-valign" "c"))
+                        ) ;
+                    (process-row-cells (cdr cells)
+                      r
+                      (+ c 1)
+                      (cons new-opt1 (cons new-opt2 options-acc))
+                      (cons new-cell new-cells-acc)
+                    ) ;process-row-cells
+                  ) ;let*
+                  (process-row-cells (cdr cells) r (+ c 1) options-acc (cons cell new-cells-acc))
+                ) ;if
+              ) ;let*
+        ) ;else
+  ) ;cond
+) ;define
+
+(define (process-table-rows rows r options-acc new-rows-acc)
+  (cond ((null? rows) (cons (reverse new-rows-acc) options-acc))
+        (else (let* ((row (car rows))
+                     (cells (cdr row))
+                     (res-cells (process-row-cells cells r 1 '() '()))
+                    ) ;
+                (process-table-rows (cdr rows)
+                  (+ r 1)
+                  (append options-acc (cdr res-cells))
+                  (cons (cons 'row (car res-cells)) new-rows-acc)
+                ) ;process-table-rows
+              ) ;let*
+        ) ;else
+  ) ;cond
+) ;define
+
+(define (filter-table options)
+  (cond ((null? options) '())
+        ((and (pair? (car options)) (eq? (caar options) 'table))
+         (filter-table (cdr options))
+        ) ;
+        (else (cons (car options) (filter-table (cdr options))))
+  ) ;cond
+) ;define
+
+(define (collect-all-regions options num-rows)
+  (let loop-r
+    ((r 1) (regions '()))
+    (if (> r num-rows)
+      regions
+      (let* ((r-str (number->string r))
+             (row-regions (let loop-c
+                            ((c 1) (c-acc '()))
+                            (if (> c 50)
+                              c-acc
+                              (let* ((c-str (number->string c))
+                                     (h-val (let loop-opt
+                                              ((lst options))
+                                              (cond ((null? lst) #f)
+                                                    ((and (pair? (car lst))
+                                                       (eq? (caar lst) 'cwith)
+                                                       (equal? (list-ref (car lst) 1) r-str)
+                                                       (equal? (list-ref (car lst) 3) c-str)
+                                                       (equal? (list-ref (car lst) 5) "cell-row-span")
+                                                     ) ;and
+                                                     (list-ref (car lst) 6)
+                                                    ) ;
+                                                    (else (loop-opt (cdr lst)))
+                                              ) ;cond
+                                            ) ;let
+                                     ) ;h-val
+                                     (w-val (let loop-opt
+                                              ((lst options))
+                                              (cond ((null? lst) #f)
+                                                    ((and (pair? (car lst))
+                                                       (eq? (caar lst) 'cwith)
+                                                       (equal? (list-ref (car lst) 1) r-str)
+                                                       (equal? (list-ref (car lst) 3) c-str)
+                                                       (equal? (list-ref (car lst) 5) "cell-col-span")
+                                                     ) ;and
+                                                     (list-ref (car lst) 6)
+                                                    ) ;
+                                                    (else (loop-opt (cdr lst)))
+                                              ) ;cond
+                                            ) ;let
+                                     ) ;w-val
+                                     (h (if h-val (string->number h-val) 1))
+                                     (w (if w-val (string->number w-val) 1))
+                                    ) ;
+                                (if (or (> h 1) (> w 1))
+                                  (loop-c (+ c 1) (cons (list r c h w) c-acc))
+                                  (loop-c (+ c 1) c-acc)
+                                ) ;if
+                              ) ;let*
+                            ) ;if
+                          ) ;let
+             ) ;row-regions
+            ) ;
+        (loop-r (+ r 1) (append regions row-regions))
+      ) ;let*
+    ) ;if
+  ) ;let
+) ;define
+
+(define (is-cell-covered? ri ci regions)
+  (cond ((null? regions) #f)
+        (else (let* ((reg (car regions))
+                     (r (list-ref reg 0))
+                     (c (list-ref reg 1))
+                     (h (list-ref reg 2))
+                     (w (list-ref reg 3))
+                    ) ;
+                (if (and (>= ri r)
+                      (< ri (+ r h))
+                      (>= ci c)
+                      (< ci (+ c w))
+                      (not (and (= ri r) (= ci c)))
+                    ) ;and
+                  #t
+                  (is-cell-covered? ri ci (cdr regions))
+                ) ;if
+              ) ;let*
+        ) ;else
+  ) ;cond
+) ;define
+
+(define (clean-covered-cells-in-row cells r c regions new-cells-acc)
+  (cond ((null? cells) (reverse new-cells-acc))
+        (else (let* ((cell (car cells))
+                     (new-cell (if (is-cell-covered? r c regions) '(cell "") cell))
+                    ) ;
+                (clean-covered-cells-in-row (cdr cells)
+                  r
+                  (+ c 1)
+                  regions
+                  (cons new-cell new-cells-acc)
+                ) ;clean-covered-cells-in-row
+              ) ;let*
+        ) ;else
+  ) ;cond
+) ;define
+
+(define (clean-covered-cells-in-rows rows r regions new-rows-acc)
+  (cond ((null? rows) (reverse new-rows-acc))
+        (else (let* ((row (car rows))
+                     (cells (cdr row))
+                     (new-cells (clean-covered-cells-in-row cells r 1 regions '()))
+                     (new-row (cons 'row new-cells))
+                    ) ;
+                (clean-covered-cells-in-rows (cdr rows)
+                  (+ r 1)
+                  regions
+                  (cons new-row new-rows-acc)
+                ) ;clean-covered-cells-in-rows
+              ) ;let*
+        ) ;else
+  ) ;cond
+) ;define
+
+(define (transform-multirow-tformat x)
+  (if (and (pair? x) (eq? (car x) 'tformat))
+    (let* ((options (cdr x))
+           (table-cell-pair (let loop
+                              ((lst options))
+                              (cond ((null? lst) #f)
+                                    ((and (pair? (car lst)) (eq? (caar lst) 'table)) (car lst))
+                                    (else (loop (cdr lst)))
+                              ) ;cond
+                            ) ;let
+           ) ;table-cell-pair
+          ) ;
+      (if table-cell-pair
+        (let* ((table-rows (cdr table-cell-pair))
+               (processed (process-table-rows table-rows 1 '() '()))
+               (new-rows-temp (car processed))
+               (new-options (cdr processed))
+               (all-options (append (filter-table options) new-options))
+               (num-rows (length new-rows-temp))
+               (regions (collect-all-regions all-options num-rows))
+               (new-rows (clean-covered-cells-in-rows new-rows-temp 1 regions '()))
+               (rebuilt-options (append all-options (list (cons 'table new-rows))))
+              ) ;
+          (cons 'tformat rebuilt-options)
+        ) ;let*
+        x
+      ) ;if
+    ) ;let*
+    x
+  ) ;if
+) ;define
+
+(define (transform-multirow x)
+  (cond ((null? x) '())
+        ((and (pair? x) (eq? (car x) 'tformat))
+         (let* ((new-t (transform-multirow-tformat x))
+                (transformed-args (map transform-multirow (cdr new-t)))
+               ) ;
+           (cons 'tformat transformed-args)
+         ) ;let*
+        ) ;
+        ((pair? x) (cons (transform-multirow (car x)) (transform-multirow (cdr x))))
+        (else x)
+  ) ;cond
+) ;define
+
+(define latex->texmacs-original latex->texmacs)
+
+(tm-define (latex->texmacs t)
+  (let* ((res (latex->texmacs-original t))
+         (st (tree->stree res))
+         (new-st1 (upgrade-latex-differentials-stree st #f))
+         (new-st2 (transform-three-line-tables new-st1))
+         (new-st (transform-multirow new-st2))
+        ) ;
+    (stree->tree new-st)
+  ) ;let*
+) ;tm-define
+
+(define latex-document->texmacs-original latex-document->texmacs)
+
+(tm-define (latex-document->texmacs x . opts)
+  (let* ((res (apply latex-document->texmacs-original (cons x opts)))
+         (st (tree->stree res))
+         (new-st1 (upgrade-latex-differentials-stree st #f))
+         (new-st2 (transform-three-line-tables new-st1))
+         (new-st (transform-multirow new-st2))
+        ) ;
+    (stree->tree new-st)
+  ) ;let*
+) ;tm-define
+
+(converter latex-tree texmacs-tree (:function latex->texmacs))
+(converter latex-document
+  texmacs-tree
+  (:function-with-options latex-document->texmacs)
+  (:option "latex->texmacs:fallback-on-pictures" "on")
+  (:option "latex->texmacs:source-tracking" "off")
+  (:option "latex->texmacs:conservative" "off")
+  (:option "latex->texmacs:transparent-source-tracking" "off")
+) ;converter
diff --git a/TeXmacs/plugins/latex/progs/latex/latex-kbd.scm b/TeXmacs/plugins/latex/progs/latex/latex-kbd.scm
new file mode 100644
index 0000000000..c7befda1bd
--- /dev/null
+++ b/TeXmacs/plugins/latex/progs/latex/latex-kbd.scm
@@ -0,0 +1,793 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : latex-kbd.scm
+;; DESCRIPTION : setup key combinations for frequently used commands
+;; COPYRIGHT   : (C) 1999  Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (latex latex-kbd)
+  (:use (utils edit auto-close)
+    (generic format-edit)
+    (generic generic-edit)
+    (text text-edit)
+  ) ;:use
+) ;texmacs-module
+
+(kbd-symbols "alpha"
+  "beta"
+  "gamma"
+  "delta"
+  "epsilon"
+  "zeta"
+  "eta"
+  "theta"
+  "iota"
+  "kappa"
+  "lambda"
+  "mu"
+  "nu"
+  "xi"
+  "omicron"
+  "pi"
+  "rho"
+  "sigma"
+  "tau"
+  "upsilon"
+  "phi"
+  "chi"
+  "psi"
+  "omega"
+  "varepsilon"
+  "vartheta"
+  "varpi"
+  "varrho"
+  "varsigma"
+  "varphi"
+  "leftharpoonup"
+  "leftharpoondown"
+  "rightharpoonup"
+  "rightharpoondown"
+  "lefthook"
+  "righthook"
+  "triangleright"
+  "triangleleft"
+  "star"
+  "partial"
+  "flat"
+  "natural"
+  "sharp"
+  "smile"
+  "frown"
+  "ell"
+  "imath"
+  "jmath"
+  "wp"
+  "vect"
+
+  "Alpha"
+  "Beta"
+  "Gamma"
+  "Delta"
+  "Epsilon"
+  "Zeta"
+  "Eta"
+  "Theta"
+  "Iota"
+  "Kappa"
+  "Lambda"
+  "Mu"
+  "Nu"
+  "Xi"
+  "Omicron"
+  "Pi"
+  "Rho"
+  "Sigma"
+  "Tau"
+  "Upsilon"
+  "Phi"
+  "Chi"
+  "Psi"
+  "Omega"
+  "varOmega"
+  "grave"
+  "acute"
+  "check"
+  "breve"
+  "invbreve"
+  "bar"
+  "cedille"
+
+  "ast"
+  "asterisk"
+
+  "cdot"
+  "times"
+  "asterisk"
+  "div"
+  "diamond"
+  "pm"
+  "mp"
+  "oplus"
+  "ominus"
+  "otimes"
+  "oslash"
+  "odot"
+  "bigcirc"
+  "circ"
+  "bullet"
+  "asymp"
+  "equiv"
+  "subseteq"
+  "supseteq"
+  "leq"
+  "geq"
+  "preceq"
+  "succeq"
+  "sim"
+  "approx"
+  "subset"
+  "supset"
+  "ll"
+  "gg"
+  "prec"
+  "succ"
+  "leftarrow"
+  "rightarrow"
+  "uparrow"
+  "downarrow"
+  "leftrightarrow"
+  "nearrow"
+  "searrow"
+  "simeq"
+  "Leftarrow"
+  "Rightarrow"
+  "Uparrow"
+  "Downarrow"
+  "Leftrightarrow"
+  "nwarrow"
+  "swarrow"
+  "propto"
+  "infty"
+  "in"
+  "ni"
+  "mid"
+  "bigtriangleup"
+  "triangle"
+  "bigtriangledown"
+  "negate"
+  "varshortmid"
+  "forall"
+  "exists"
+  "neg"
+  "emptyset"
+  "Re"
+  "Im"
+  "top"
+  "bot"
+  "aleph"
+  "perp"
+  "cup"
+  "cap"
+  "uplus"
+  "wedge"
+  "vee"
+  "vdash"
+  "dashv"
+  "lfloor"
+  "rfloor"
+  "lceil"
+  "rceil"
+  "langle"
+  "rangle"
+  "updownarrow"
+  "Updownarrow"
+  "wr"
+  "amalg"
+  "nabla"
+  "sqcup"
+  "sqcap"
+  "sqsubseteq"
+  "sqsupseteq"
+  "dag"
+  "ddag"
+  "endofline"
+  "clubsuit"
+  "diamondsuit"
+  "heartsuit"
+  "spadesuit"
+  "backslash"
+  "setminus"
+
+  "boxdot"
+  "boxplus"
+  "boxtimes"
+  "box"
+  "blacksquare"
+  "centerdot"
+  "lozenge"
+  "blacklozenge"
+  "circlearrowright"
+  "circlearrowleft"
+  "rightleftharpoons"
+  "leftrightharpoons"
+  "boxminus"
+  "Vdash"
+  "Vvdash"
+  "dashV"
+  "twoheadrightarrow"
+  "twoheadleftarrow"
+  "leftleftarrows"
+  "rightrightarrows"
+  "upuparrows"
+  "downdownarrows"
+  "upharpoonright"
+  "downharpoonright"
+  "upharpoonleft"
+  "downharpoonleft"
+  "rightarrowtail"
+  "leftarrowtail"
+  "leftrightarrows"
+  "rightleftarrows"
+  "Lsh"
+  "Rsh"
+  "rightsquigarrow"
+  "leftrightsquigarrow"
+  "looparrowleft"
+  "looparrowright"
+  "circeq"
+  "succsim"
+  "gtrsim"
+  "gtrapprox"
+  "multimap"
+  "therefore"
+  "because"
+  "doteqdot"
+  "triangleq"
+  "precsim"
+  "lesssim"
+  "lessapprox"
+  "eqslantless"
+  "eqslantgtr"
+  "curlyeqprec"
+  "curlyeqsucc"
+  "preccurlyeq"
+  "leqq"
+  "leqslant"
+  "lessgtr"
+  "smalldash"
+  "risingdotseq"
+  "fallingdotseq"
+  "succcurlyeq"
+  "geqq"
+  "geqslant"
+  "gtrless"
+  "sqsubset"
+  "sqsupset"
+  "vartriangleright"
+  "vartriangleleft"
+  "trianglerighteq"
+  "trianglelefteq"
+  "bigstar"
+  "between"
+  "blacktriangledown"
+  "blacktriangleright"
+  "blacktriangleleft"
+  "shortrightarrow"
+  "shortleftarrow"
+  "vartriangle"
+  "blacktriangle"
+  "triangledown"
+  "eqcirc"
+  "lesseqgtr"
+  "gtreqless"
+  "lesseqqgtr"
+  "gtreqqless"
+  "yen"
+  "Rrightarrow"
+  "Lleftarrow"
+  "checkmark"
+  "veebar"
+  "barwedge"
+  "doublebarwedge"
+  "angle"
+  "measuredangle"
+  "sphericalangle"
+  "varpropto"
+  "smallsmile"
+  "smallfrown"
+  "Subset"
+  "Supset"
+  "Cup"
+  "Cap"
+  "curlyvee"
+  "curlywedge"
+  "leftthreetimes"
+  "rightthreetimes"
+  "subseteqq"
+  "supseteqq"
+  "bumpeq"
+  "Bumpeq"
+  "lll"
+  "ggg"
+  "ulcorner"
+  "urcorner"
+  "circledR"
+  "circledS"
+  "pitchfork"
+  "dotplus"
+  "backsim"
+  "backsimeq"
+  "llcorner"
+  "lrcorner"
+  "maltese"
+  "complement"
+  "intercal"
+  "circledcirc"
+  "circledast"
+  "circleddash"
+
+  "lvertneqq"
+  "gvertneqq"
+  "nleq"
+  "ngeq"
+  "nless"
+  "ngtr"
+  "nprec"
+  "nsucc"
+  "lneqq"
+  "gneqq"
+  "nleqslant"
+  "ngeqslant"
+  "lneq"
+  "gneq"
+  "npreceq"
+  "nsucceq"
+  "precnsim"
+  "succnsim"
+  "lnsim"
+  "gnsim"
+  "nleqq"
+  "ngeqq"
+  "precneqq"
+  "succneqq"
+  "precnapprox"
+  "succnapprox"
+  "lnapprox"
+  "gnapprox"
+  "nsim"
+  "ncong"
+  "diagup"
+  "diagdown"
+  "varsubsetneq"
+  "varsupsetneq"
+  "nsubseteqq"
+  "nsupseteqq"
+  "subsetneqq"
+  "supsetneqq"
+  "varsubsetneqq"
+  "varsupsetneqq"
+  "subsetneq"
+  "supsetneq"
+  "nsubseteq"
+  "nsupseteq"
+  "parallel"
+  "nparallel"
+  "nmid"
+  "nshortmid"
+  "nshortparallel"
+  "nvdash"
+  "nVdash"
+  "nvDash"
+  "nVDash"
+  "models"
+  "ntrianglerighteq"
+  "ntrianglelefteq"
+  "ntriangleleft"
+  "ntriangleright"
+  "nleftarrow"
+  "nrightarrow"
+  "nLeftarrow"
+  "nRightarrow"
+  "nLeftrightarrow"
+  "nleftrightarrow"
+  "divideontimes"
+  "varnothing"
+  "nexists"
+  "Mho"
+  "thorn"
+  "eth"
+  "eqsim"
+  "beth"
+  "gimel"
+  "daleth"
+  "lessdot"
+  "gtrdot"
+  "ltimes"
+  "rtimes"
+  "shortmid"
+  "shortparallel"
+  "smallsetminus"
+  "thicksim"
+  "thickapprox"
+  "approxeq"
+  "succapprox"
+  "precapprox"
+  "curvearrowleft"
+  "curvearrowright"
+  "digamma"
+  "varkappa"
+  "hslash"
+  "hbar"
+  "backepsilon"
+  "varparallel"
+  "nvarparallel"
+
+  "mapsto"
+  "longmapsto"
+  "longrightarrow"
+  "longleftarrow"
+  "longleftrightarrow"
+  "longRightarrow"
+  "longLeftarrow"
+  "longLeftrightarrow"
+  "ldots"
+  "cdots"
+  "vdots"
+  "ddots"
+  "dotamalg"
+  "dottimes"
+  "dotoplus"
+  "dototimes"
+  "venus"
+  "mars"
+  "earth"
+  "aries"
+  "fullmoon"
+  "newmoon"
+  "astrosun"
+  "leo"
+  "LEFTcircle"
+  "RIGHTcircle"
+  "Square"
+  "CheckedBox"
+  "photon"
+  "gluon"
+  "neq"
+  "notin"
+  "nin"
+  "notni"
+  "nni"
+  "nll"
+  "nlll"
+  "ngg"
+  "nggg"
+  "dagger"
+  "ddagger"
+  "boxbar"
+  "checked"
+  "obar"
+  "kreuz"
+) ;kbd-symbols
+
+(kbd-commands ("#" "Insert sharp" (insert "#"))
+ ("$" "Insert dollar" (insert "$"))
+ ("(" "Insert formula" (make-with "mode" "math"))
+ ("," "Insert small horizontal space" (make-space "0.2spc"))
+ (":" "Insert medium horizontal space" (make-space "0.4spc"))
+ (";" "Insert thick horizontal space" (make-space "0.6spc"))
+ (" " "Insert horizontal interword space" (make-space "1spc"))
+ ("!" "Insert negative horizontal space" (make-space "-0.2spc"))
+ ("|" "Insert norm" (insert "<||>"))
+ ("quad" "Insert a quad space" (make-space "1em"))
+ ("qquad" "Insert a qquad space" (make-space "2em"))
+ ("\\" "Go to the next line" (make 'next-line))
+
+ ("[" "Insert equation" (make-equation*))
+ ("equation" "Insert numbered equation" (make-equation))
+ ("eqnarray*" "Insert equation array" (make-eqnarray*))
+
+ ("cC" "Insert Ç" (insert "<#00C7>"))
+ ("cc" "Insert ç" (insert "<#00E7>"))
+ ("'E" "Insert É" (insert "<#00C9>"))
+ ("'e" "Insert é" (insert "<#00E9>"))
+ ("`A" "Insert À" (insert "<#00C0>"))
+ ("`E" "Insert È" (insert "<#00C8>"))
+ ("`U" "Insert Ù" (insert "<#00D9>"))
+ ("`a" "Insert à" (insert "<#00E0>"))
+ ("`e" "Insert è" (insert "<#00E8>"))
+ ("`u" "Insert ù" (insert "<#00F9>"))
+ ("^A" "Insert Â" (emulate-keyboard "hat A"))
+ ("^E" "Insert Ê" (emulate-keyboard "hat E"))
+ ("^I" "Insert Î" (emulate-keyboard "hat I"))
+ ("^O" "Insert Ô" (emulate-keyboard "hat O"))
+ ("^U" "Insert Û" (emulate-keyboard "hat U"))
+ ("^a" "Insert â" (emulate-keyboard "hat a"))
+ ("^e" "Insert ê" (emulate-keyboard "hat e"))
+ ("^i" "Insert î" (emulate-keyboard "hat i"))
+ ("^o" "Insert ô" (emulate-keyboard "hat o"))
+ ("^u" "Insert û" (emulate-keyboard "hat u"))
+ ("aa" "Insert å" (insert "<#00E5>"))
+ ("ae" "Insert æ" (insert "<#00E6>"))
+ ("dh" "Insert ð" (insert "<#00F0>"))
+ ("dj" "Insert đ" (insert "<#0111>"))
+ ("i" "Insert ı" (insert "<#0131>"))
+ ("j" "Insert ȷ" (insert "<#0237>"))
+ ("l" "Insert ł" (insert "<#0142>"))
+ ("ng" "Insert ŋ" (insert "<#014B>"))
+ ("o" "Insert ø" (insert "<#00F8>"))
+ ("oe" "Insert œ" (insert "<#0153>"))
+ ("ss" "Insert ö" (insert "<#00F6>"))
+ ("sz" "Insert ß" (insert "<#00DF>"))
+ ("th" "Insert þ" (insert "<#00FE>"))
+ ("AA" "Insert Å" (insert "<#00C5>"))
+ ("AE" "Insert Æ" (insert "<#00C6>"))
+ ("DH" "Insert Ð" (insert "<#00D0>"))
+ ("L" "Insert Ł" (insert "<#0141>"))
+ ("NG" "Insert Ŋ" (insert "<#014A>"))
+ ("O" "Insert Ø" (insert "<#00D8>"))
+ ("OE" "Insert Œ" (insert "<#0152>"))
+ ("S" "Insert §" (insert "<#00A7>"))
+ ("SS" "Insert ẞ" (insert "<#1E9E>"))
+ ("TH" "Insert Þ" (insert "<#00DE>"))
+ ("hookleftarrow" "insert ↩" (insert "<#21A9>"))
+ ("hookrightarrow" "insert ↪" (insert "<#21AA>"))
+
+ ("arccos" "Insert arccos" (insert "arccos"))
+ ("arcsin" "Insert arcsin" (insert "arcsin"))
+ ("arctan" "Insert arctan" (insert "arctan"))
+ ("arg" "Insert arg" (insert "arg"))
+ ("cos" "Insert cos" (insert "cos"))
+ ("cosh" "Insert cosh" (insert "cosh"))
+ ("cot" "Insert cot" (insert "cot"))
+ ("coth" "Insert coth" (insert "coth"))
+ ("csc" "Insert csc" (insert "csc"))
+ ("deg" "Insert deg" (insert "deg"))
+ ("det" "Insert det" (make 'det))
+ ("dim" "Insert dim" (insert "dim"))
+ ("exp" "Insert exp" (insert "exp"))
+ ("gcd" "Insert gcd" (insert "gcd"))
+ ("hom" "Insert hom" (insert "hom"))
+ ("inf" "Insert inf" (insert "inf"))
+ ("ker" "Insert ker" (insert "ker"))
+ ("lg" "Insert lg" (insert "lg"))
+ ("lim" "Insert lim" (insert "lim"))
+ ("liminf" "Insert liminf" (insert "liminf"))
+ ("limsup" "Insert limsup" (insert "limsup"))
+ ("varliminf" "Insert varliminf" (make 'varliminf))
+ ("varlimsup" "Insert varlimsup" (make 'varlimsup))
+ ("ln" "Insert ln" (insert "ln"))
+ ("log" "Insert log" (insert "log"))
+ ("max" "Insert max" (insert "max"))
+ ("min" "Insert min" (insert "min"))
+ ("Pr" "Insert Pr" (insert "Pr"))
+ ("sec" "Insert sec" (insert "sec"))
+ ("sin" "Insert sin" (insert "sin"))
+ ("sinh" "Insert sinh" (insert "sinh"))
+ ("sup" "Insert sup" (insert "sup"))
+ ("tan" "Insert tan" (insert "tan"))
+ ("tanh" "Insert tanh" (insert "tanh"))
+
+ ("abstract" "Insert abstract" (make-abstract-data))
+ ("maketitle" "Insert title" (make-doc-data))
+ ("tableofcontents"
+   "Insert table of contents"
+   (make-aux "table-of-contents" "toc-prefix" "toc")
+ ) ;
+ ("appendix" "Insert appendix" (make-section 'appendix))
+ ("chapter" "Insert chapter" (make-section 'chapter))
+ ("section" "Insert section" (make-section 'section))
+ ("subsection" "Insert subsection" (make-section 'subsection))
+ ("subsubsection" "Insert subsubsection" (make-section 'subsubsection))
+ ("paragraph" "Insert paragraph" (make-section 'paragraph))
+ ("subparagraph" "Insert subparagraph" (make-section 'subparagraph))
+ ("table" "Insert a big table" (make 'big-table))
+ ("figure" "Insert a big figure" (make 'big-figure))
+
+ ("frac" "Make fraction" (make-fraction))
+ ("sqrt" "Make square root" (make-sqrt))
+ ("not" "Make negation" (make-neg))
+ ("acute" "Make acute" (make-wide ""))
+ ("bar" "Make bar" (make-wide ""))
+ ("breve" "Make breve" (make-wide ""))
+ ("invbreve" "Make inverted breve" (make-wide ""))
+ ("check" "Make check" (make-wide ""))
+ ("grave" "Make grave" (make-wide ""))
+ ("hat" "Make hat" (make-wide "^"))
+ ("tilde" "Make tilde" (make-wide "~"))
+ ("vect" "Make vector" (make-wide ""))
+ ("dot" "Make dot" (make-wide ""))
+ ("ddot" "Make double dot" (make-wide ""))
+ ("dddot" "Make triple dot" (make-wide ""))
+ ("ddddot" "Make quadruple dot" (make-wide ""))
+ ("widecheck" "Make check" (make-wide ""))
+ ("widehat" "Make hat" (make-wide "^"))
+ ("widetilde" "Make tilde" (make-wide "~"))
+
+ ("sum" "Insert big summation" (math-big-operator "sum"))
+ ("prod" "Insert big product" (math-big-operator "prod"))
+ ("coprod" "Insert big coproduct" (math-big-operator "amalg"))
+ ("int" "Insert big integral" (math-big-operator "int"))
+ ("iint" "Insert big integrals" (math-big-operator "iint"))
+ ("iiint" "Insert big integrals" (math-big-operator "iiint"))
+ ("oint" "Insert big contour integral" (math-big-operator "oint"))
+ ("oiint" "Insert big contour integrals" (math-big-operator "oiint"))
+ ("oiiint" "Insert big contour integrals" (math-big-operator "oiiint"))
+ ("bigcap" "Insert big intersection" (math-big-operator "cap"))
+ ("bigcup" "Insert big union" (math-big-operator "cup"))
+ ("bigsqcup" "Insert big square union" (math-big-operator "sqcup"))
+ ("bigvee" "Insert big logical or" (math-big-operator "vee"))
+ ("bigwedge" "Insert big logical and" (math-big-operator "wedge"))
+ ("bigodot" "Insert big dotted point" (math-big-operator "odot"))
+ ("bigotimes" "Insert big tensor product" (math-big-operator "otimes"))
+ ("bigoplus" "Insert big direct sum" (math-big-operator "oplus"))
+ ("biguplus" "Insert big union sum" (math-big-operator "uplus"))
+
+ ("left(" "Insert large (" (math-bracket-open "(" ")" #t))
+ ("left)" "Insert large left )" (math-bracket-open ")" "(" #t))
+ ("left[" "Insert large [" (math-bracket-open "[" "]" #t))
+ ("left]" "Insert large left ]" (math-bracket-open "]" "[" #t))
+ ("left\\{" "Insert large {" (math-bracket-open "{" "}" #t))
+ ("left\\}" "Insert large left }" (math-bracket-open "}" "{" #t))
+ ("left\\lfloor"
+   "Insert large "
+   (math-bracket-open "" "" #t)
+ ) ;
+ ("left\\rfloor"
+   "Insert large left "
+   (math-bracket-open "" "" #t)
+ ) ;
+ ("left\\lceil"
+   "Insert large "
+   (math-bracket-open "" "" #t)
+ ) ;
+ ("left\\rceil"
+   "Insert large left "
+   (math-bracket-open "" "" #t)
+ ) ;
+ ("left\\langle"
+   "Insert large "
+   (math-bracket-open "" "" #t)
+ ) ;
+ ("left\\rangle"
+   "Insert large left "
+   (math-bracket-open "" "" #t)
+ ) ;
+ ("left|" "Insert large left " (math-bracket-open "|" "|" #t))
+ ("left||" "Insert large left " (math-bracket-open "||" "||" #t))
+ ("left/" "Insert large left /" (math-bracket-open "/" "\\" #t))
+ ("left\\" "Insert large left \\" (math-bracket-open "\\" "/" #t))
+ ("left." "Insert large left ." (math-bracket-open "." "." #t))
+
+ ("right(" "Insert large right (" (math-bracket-close "(" ")" #t))
+ ("right)" "Insert large )" (math-bracket-close ")" "(" #t))
+ ("right[" "Insert large right [" (math-bracket-close "[" "]" #t))
+ ("right]" "Insert large ]" (math-bracket-close "]" "[" #t))
+ ("right\\{" "Insert large right {" (math-bracket-close "{" "}" #t))
+ ("right\\}" "Insert large }" (math-bracket-close "}" "{" #t))
+ ("right\\lfloor"
+   "Insert large right "
+   (math-bracket-close "" "" #t)
+ ) ;
+ ("right\\rfloor"
+   "Insert large "
+   (math-bracket-close "" "" #t)
+ ) ;
+ ("right\\lceil"
+   "Insert large right "
+   (math-bracket-close "" "" #t)
+ ) ;
+ ("right\\rceil"
+   "Insert large "
+   (math-bracket-close "" "" #t)
+ ) ;
+ ("right\\langle"
+   "Insert large right "
+   (math-bracket-close "" "" #t)
+ ) ;
+ ("right\\rangle"
+   "Insert large "
+   (math-bracket-close "" "" #t)
+ ) ;
+ ("right|" "Insert large right " (math-bracket-close "|" "|" #t))
+ ("right||" "Insert large right " (math-bracket-close "||" "||" #t))
+ ("right/" "Insert large right /" (math-bracket-close "/" "\\" #t))
+ ("right\\" "Insert large right \\" (math-bracket-close "\\" "/" #t))
+ ("right." "Insert large right ." (math-bracket-close "." "." #t))
+
+ ("rmfamily" "Use roman font family" (make-with "font-family" "rm"))
+ ("ttfamily" "Use typewriter font family" (make-with "font-family" "tt"))
+ ("sffamily" "Use sans serif font family" (make-with "font-family" "ss"))
+ ("mdseries" "Use medium font series" (make-with "font-series" "medium"))
+ ("bfseries" "Use bold font series" (make-with "font-series" "bold"))
+ ("upshape" "Use right font shape" (make-with "font-shape" "right"))
+ ("itshape" "Use italic font shape" (make-with "font-shape" "italic"))
+ ("slshape" "Use slanted font shape" (make-with "font-shape" "slanted"))
+ ("scshape" "Use small-caps font shape" (make-with "font-shape" "small-caps"))
+ ("rm" "Use roman font family" (make-with "font-family" "rm"))
+ ("tt" "Use typewriter font family" (make 'tt))
+ ("sf" "Use sans serif font family" (make-with "font-family" "ss"))
+ ("md" "Use medium font series" (make-with "font-series" "medium"))
+ ("bf" "Use bold font series" (make-with "font-series" "bold"))
+ ("up" "Use right font shape" (make-with "font-shape" "right"))
+ ("it" "Use italic font shape" (make-with "font-shape" "italic"))
+ ("em" "Emphasize text" (make 'em))
+ ("sl" "Use slanted font shape" (make-with "font-shape" "slanted"))
+ ("sc" "Use small-caps font shape" (make-with "font-shape" "small-caps"))
+ ("textrm" "Use roman font family" (make-with "font-family" "rm"))
+ ("texttt" "Use typewriter font family" (make-with "font-family" "tt"))
+ ("textsf" "Use sans serif font family" (make-with "font-family" "ss"))
+ ("textmd" "Use medium font series" (make-with "font-series" "medium"))
+ ("textbf" "Use bold font series" (make-with "font-series" "bold"))
+ ("textup" "Use right font shape" (make-with "font-shape" "right"))
+ ("textit" "Use italic font shape" (make-with "font-shape" "italic"))
+ ("emph" "Use italic font shape" (make-with "font-shape" "italic"))
+ ("textsl" "Use slanted font shape" (make-with "font-shape" "slanted"))
+ ("textsc" "Use small-caps font shape" (make-with "font-shape" "small-caps"))
+ ("cal" "Use calligraphic font" (make-with "font" "cal"))
+ ("frak" "Use fraktur font" (make-with "font" "Euler"))
+ ("Bbb" "Use blackboard bold font" (make-with "font" "Bbb*"))
+ ("mathcal" "Use calligraphic font" (make-with "font" "cal"))
+ ("mathfrak" "Use fraktur font" (make-with "font" "Euler"))
+ ("mathbb" "Use blackboard math font" (make-with "font" "Bbb"))
+ ("mathbbm" "Use blackboard math font" (make-with "font" "Bbb*"))
+ ("mathrm" "Use roman font family" (make-with "font-family" "rm"))
+ ("mathtt" "Use typewriter font family" (make-with "font-family" "tt"))
+ ("mathsf" "Use sans serif font family" (make-with "font-family" "ss"))
+ ("mathmd" "Use medium font series" (make-with "font-series" "medium"))
+ ("mathbf" "Use bold font series" (make-with "font-series" "bold"))
+ ("mathup" "Use right font shape" (make-with "font-shape" "right"))
+ ("mathit" "Use italic font shape" (make-with "font-shape" "italic"))
+ ("tiny" "Use tiny font font size" (make 'tiny))
+ ("scriptsize" "Use script font size" (make 'very-small))
+ ("footnotesize" "Use footnote font size" (make 'smaller))
+ ("small" "Use small font size" (make 'small))
+ ("normalsize" "Use normal font size" (make 'normal-size))
+ ("large" "Use large font size" (make 'large))
+ ("Large" "Use very large font size" (make 'larger))
+ ("LARGE" "Use very large font size" (make 'very-large))
+ ("huge" "Use huge font size" (make 'huge))
+ ("Huge" "Use really huge font size" (make 'really-huge))
+ ("displaystyle" "Switch to formula style" (make-with "math-display" "true"))
+
+ ("black" "Use a black color" (make-with "color" "black"))
+ ("white" "Use a white color" (make-with "color" "white"))
+ ("grey" "Use a grey color" (make-with "color" "grey"))
+ ("red" "Use a red color" (make-with "color" "red"))
+ ("blue" "Use a blue color" (make-with "color" "blue"))
+ ("yellow" "Use a yellow color" (make-with "color" "yellow"))
+ ("green" "Use a green color" (make-with "color" "green"))
+ ("orange" "Use a orange color" (make-with "color" "orange"))
+ ("magenta" "Use a magenta color" (make-with "color" "magenta"))
+ ("brown" "Use a brown color" (make-with "color" "brown"))
+ ("pink" "Use a pink color" (make-with "color" "pink"))
+
+ ("smallskip" "Insert small vertical space" (make-vspace-after "0.5fn"))
+ ("medskip" "Insert medium vertical space" (make-vspace-after "1fn"))
+ ("bigskip" "Insert big vertical space" (make-vspace-after "2fn"))
+ ("item" "Insert new item or number" (make-item))
+ ("label" "Make label" (make-label))
+ ("ref" "Make reference" (make 'reference))
+ ("pageref" "Make page reference" (make 'pageref))
+ ("footnote" "Insert a footnote" (make 'footnote))
+ ("input" "Include a document" (make 'include))
+) ;kbd-commands
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Extensions to LaTeX
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(kbd-commands ("big." "Insert big ." (math-big-operator "."))
+ ("underbrace" "Insert underbrace" (make-wide-under ""))
+ ("overbrace" "Insert overbrace" (make-wide ""))
+) ;kbd-commands
+
+(kbd-symbols "ddots" "mho" "Backepsilon" "Backsigma" "homsim" "mathcatalan"
+  "mathD" "mathd" "mathe" "mathi" "mathGamma" "mathLaplace" "matheuler"
+  "mathlambda" "mathpi"
+) ;kbd-symbols
diff --git a/TeXmacs/plugins/latex/styles/article/ACM/acmart.stem b/TeXmacs/plugins/latex/styles/article/ACM/acmart.stem
new file mode 100644
index 0000000000..f90f9755aa
--- /dev/null
+++ b/TeXmacs/plugins/latex/styles/article/ACM/acmart.stem
@@ -0,0 +1,306 @@
+(document (TeXmacs "1.99.19")
+  (style "source")
+  (body (document (active* (document (src-title (document (src-style-file "acmart" "1.0")
+                                                  (src-purpose (document "New ACM base style."))
+                                                  (src-copyright "2018" (document "Joris van der Hoeven"))
+                                                  (src-license (document (concat "This software falls under the "
+                                                                           (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE")
+                                                                           ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see "
+                                                                           (hlink "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                             "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                           ) ;hlink
+                                                                           "."
+                                                                         ) ;concat
+                                                               ) ;document
+                                                  ) ;src-license
+                                                ) ;document
+                                     ) ;src-title
+                           ) ;document
+                  ) ;active*
+          (use-package "std" "env" "title-generic" "header-article"
+            "section-base" "std-latex-base" "html-font-size"
+          ) ;use-package
+          (active* (src-comment "Global layout parameters"))
+          (assign "font" "Linux Libertine")
+          (assign "font" "math basic-letters=Linux Libertine,math=termes,Linux Libertine")
+          (assign "math-font-sizes" (tuple (tuple "all" "*0.8" "*0.6" "*0.5")))
+          (assign "par-first" (macro "10pt"))
+          (active* (src-comment "Font sizes"))
+          (assign "tiny" (macro "x" (with "font-size" "0.5" "par-sep" "1pt" (arg "x"))))
+          (assign "very-small"
+            (macro "x" (with "font-size" "0.7" "par-sep" "1pt" (arg "x")))
+          ) ;assign
+          (assign "small" (macro "x" (with "font-size" "0.9" "par-sep" "1pt" (arg "x"))))
+          (assign "flat-size"
+            (macro "x" (with "font-size" "0.9" "par-sep" "1pt" (arg "x")))
+          ) ;assign
+          (assign "normal-size"
+            (macro "x" (with "font-size" "1.0" "par-sep" "1pt" (arg "x")))
+          ) ;assign
+          (assign "sharp-size"
+            (macro "x" (with "font-size" "1.1" "par-sep" "1.5pt" (arg "x")))
+          ) ;assign
+          (assign "large" (macro "x" (with "font-size" "1.2" "par-sep" "2pt" (arg "x"))))
+          (assign "larger" (macro "x" (with "font-size" "1.4" "par-sep" "4pt" (arg "x"))))
+          (assign "very-large"
+            (macro "x" (with "font-size" "1.7" "par-sep" "5pt" (arg "x")))
+          ) ;assign
+          (assign "huge" (macro "x" (with "font-size" "2.0" "par-sep" "5pt" (arg "x"))))
+          (assign "really-huge"
+            (macro "x" (with "font-size" "2.5" "par-sep" "5pt" (arg "x")))
+          ) ;assign
+          (active* (src-comment "Sectional macros"))
+          (assign "sectional-sep" (macro (space "4spc")))
+          (assign "section-font"
+            (macro "name"
+              (normal-size (with "font-family" "ss" (change-case (arg "name") "UPCASE")))
+            ) ;macro
+          ) ;assign
+          (assign "subsection-font"
+            (macro "name" (normal-size (with "font-family" "ss" (arg "name"))))
+          ) ;assign
+          (assign "subsubsection-font"
+            (macro "name" (normal-size (with "font-family" "ss" (arg "name"))))
+          ) ;assign
+          (assign "paragraph-font" (macro "name" (normal-size (arg "name"))))
+          (assign "subparagraph-font" (macro "name" (normal-size (arg "name"))))
+          (assign "section-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-normal-bold (concat (vspace* (tmlen "0.75bls" "0.55bls" "0.95bls"))
+                                         (section-font (arg "name"))
+                                         (vspace "0.25bls")
+                                       ) ;concat
+                ) ;sectional-normal-bold
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "subsection-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-normal-bold (concat (vspace* (tmlen "0.75bls" "0.55bls" "0.55bls"))
+                                         (subsection-font (arg "name"))
+                                         (vspace "0.25bls")
+                                       ) ;concat
+                ) ;sectional-normal-bold
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "subsubsection-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-normal-italic (concat (vspace* (tmlen "0.5bls" "0.3bls" "0.7bls"))
+                                           (subsubsection-font (arg "name"))
+                                           (vspace "3.5pt")
+                                         ) ;concat
+                ) ;sectional-normal-italic
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "paragraph-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-normal-italic (concat (vspace* (tmlen "0.5bls" "0.3bls" "0.7bls"))
+                                           (paragraph-font (arg "name"))
+                                           (space "1em")
+                                         ) ;concat
+                ) ;sectional-normal-italic
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "subparagraph-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-normal-italic (concat (vspace* (tmlen "0.25bls" "0.15bls" "0.35bls"))
+                                           (subparagraph-font (arg "name"))
+                                           (space "1em")
+                                         ) ;concat
+                ) ;sectional-normal-italic
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (active* (document (src-comment (document "Rendering of theorem-like environments and exercises."))
+                   ) ;document
+          ) ;active*
+          (assign "render-enunciation"
+            (macro "which"
+              "body"
+              (document (padded* (document (surround (concat (yes-indent) (arg "which")) (yes-indent*) (arg "body"))
+                                 ) ;document
+                        ) ;padded*
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "render-proof"
+            (macro "which"
+              "body"
+              (document (render-enunciation (concat (theorem-name (arg "which")) (remark-sep))
+                          (document (surround ""
+                                      (if (occurs-inside '(qed) "body") "" (concat (htab "5mm") (qed)))
+                                      (arg "body")
+                                    ) ;surround
+                          ) ;document
+                        ) ;render-enunciation
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "theorem-name"
+            (macro "name" (with "font-shape" "small-caps" (arg "name")))
+          ) ;assign
+          (assign "remark-name" (macro "name" (with "font-shape" "italic" (arg "name"))))
+          (active* (document (src-comment (document "Headers."))))
+          (assign "odd-page-text"
+            (macro "s"
+              (assign "page-odd-header"
+                (style-with "src-compact"
+                  "none"
+                  (concat (no-indent)
+                    (with "font-family" "ss" (arg "s"))
+                    (htab "5mm")
+                    (page-number)
+                  ) ;concat
+                ) ;style-with
+              ) ;assign
+            ) ;macro
+          ) ;assign
+          (assign "even-page-text"
+            (macro "s"
+              (assign "page-even-header"
+                (style-with "src-compact"
+                  "none"
+                  (concat (no-indent)
+                    (page-number)
+                    (htab "5mm")
+                    (with "font-family" "ss" (arg "s"))
+                  ) ;concat
+                ) ;style-with
+              ) ;assign
+            ) ;macro
+          ) ;assign
+          ""
+          (assign "page-odd-header" "")
+          (assign "page-even-header" "")
+          (assign "page-odd-footer" "")
+          (assign "page-even-footer" "")
+          ""
+          (assign "header-title"
+            (macro "name" (concat (odd-page-text (arg "name")) (blanc-page)))
+          ) ;assign
+          (assign "header-author"
+            (macro "name" (concat (even-page-text (arg "name")) (blanc-page)))
+          ) ;assign
+          (assign "header-primary" (macro "name" "nr" "what" ""))
+          (assign "header-secondary" (macro "name" "nr" "what" ""))
+          (active* (document (src-comment (document "Title information."))))
+          (assign "doc-block"
+            (macro "body"
+              (document (wide-tabular (document (tformat (cwith "1" "1" "1" "1" "cell-vcorrect" "n")
+                                                  (table (row (cell (document (with "par-first"
+                                                                                "0fn"
+                                                                                "par-sep"
+                                                                                "0fn"
+                                                                                "par-par-sep"
+                                                                                "0fn"
+                                                                                (document (arg "body"))
+                                                                              ) ;with
+                                                                    ) ;document
+                                                              ) ;cell
+                                                         ) ;row
+                                                  ) ;table
+                                                ) ;tformat
+                                      ) ;document
+                        ) ;wide-tabular
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "doc-title-block"
+            (macro "body" (document (doc-block (document (arg "body")))))
+          ) ;assign
+          (assign "doc-author-block"
+            (macro "body" (document (doc-block (document (arg "body")))))
+          ) ;assign
+          (assign "doc-authors-block"
+            (macro "body" (document (doc-block (document (arg "body")))))
+          ) ;assign
+          (assign "doc-title"
+            (macro "x"
+              (surround (vspace* "0.5fn")
+                (vspace "0.5fn")
+                (document (doc-title-block (font-magnify "1.412" (with "font-family" "ss" "font-series" "bold" (arg "x")))
+                          ) ;doc-title-block
+                ) ;document
+              ) ;surround
+            ) ;macro
+          ) ;assign
+          (assign "doc-make-title"
+            (macro "body"
+              (surround ""
+                (vspace "0.5fn")
+                (document (compact (document (doc-title-block (document (arg "body") "")))))
+              ) ;surround
+            ) ;macro
+          ) ;assign
+          (assign "doc-data"
+            (xmacro "args"
+              (extern "doc-data"
+                (quote-arg "args")
+                (tuple "abbreviate-authors" "cluster-by-affiliation")
+              ) ;extern
+            ) ;xmacro
+          ) ;assign
+          (active* (document (src-comment (document "Author information."))))
+          (assign "author-name"
+            (macro "author"
+              (surround (vspace* "0.5fn")
+                (vspace "0.5fn")
+                (doc-author-block (large (with "font-family" "ss" (change-case (arg "author") "UPCASE")))
+                ) ;doc-author-block
+              ) ;surround
+            ) ;macro
+          ) ;assign
+          (assign "author-name-affiliation"
+            (macro "author"
+              "address"
+              (surround (vspace* "0.5fn")
+                (vspace "0.5fn")
+                (doc-author-block (concat (large (with "font-family" "ss" (concat (change-case (arg "author") "UPCASE") ", "))
+                                          ) ;large
+                                    (arg "address")
+                                  ) ;concat
+                ) ;doc-author-block
+              ) ;surround
+            ) ;macro
+          ) ;assign
+          (assign "vertical-author" (macro "data" (document (arg "data"))))
+          (assign "doc-authors"
+            (xmacro "data"
+              (document (style-with "src-compact"
+                          "none"
+                          (document (quasi (document (doc-author (document (with "doc-author"
+                                                                             (value "doc-author*")
+                                                                             (document (unquote* (map "vertical-author" (quote-arg "data"))))
+                                                                           ) ;with
+                                                                 ) ;document
+                                                     ) ;doc-author
+                                           ) ;document
+                                    ) ;quasi
+                          ) ;document
+                        ) ;style-with
+              ) ;document
+            ) ;xmacro
+          ) ;assign
+          (active* (document (src-comment (document "Abstracts."))))
+          (assign "render-abstract"
+            (macro "body"
+              (document (surround (no-indent) "" (document (small (document (arg "body"))))))
+            ) ;macro
+          ) ;assign
+        ) ;document
+  ) ;body
+  (initial (collection (associate "preamble" "true")))
+) ;document
diff --git a/TeXmacs/plugins/latex/styles/article/ACM/acmart.ts b/TeXmacs/plugins/latex/styles/article/ACM/acmart.ts
deleted file mode 100644
index da86985e8b..0000000000
--- a/TeXmacs/plugins/latex/styles/article/ACM/acmart.ts
+++ /dev/null
@@ -1,236 +0,0 @@
-
-
-
-
-<\body>
-  <\active*>
-    <\src-title>
-      
-
-      <\src-purpose>
-        New ACM base style.
-      
-
-      <\src-copyright|2018>
-        Joris van der Hoeven
-      
-
-      <\src-license>
-        This software falls under the . It comes WITHOUT ANY
-        WARRANTY WHATSOEVER. You should have received a copy of the license
-        which the software. If not, see .
-      
-    
-  
-
-  
-
-  >
-
-  
-
-  
-
-  >>
-
-  >
-
-  >
-
-  >>>
-
-  >>>
-
-  >>>
-
-  >>>
-
-  >>>
-
-  >>>
-
-  >>>
-
-  >>>
-
-  >>>
-
-  >>>
-
-  >>>
-
-  >
-
-  >>
-
-  |UPCASE>>>>>
-
-  >>>>
-
-  >>>>
-
-  >>>
-
-  >>>
-
-  >>>>>>
-
-  >>>>>>
-
-  >>>>>>
-
-  >>>>>>
-
-  >>>>>>
-
-  <\active*>
-    <\src-comment>
-      Rendering of theorem-like environments and exercises.
-    
-  
-
-  
-    <\padded*>
-      ||>
-    
-  >
-
-  
-    <\render-enunciation|>>
-      >|body>||>|>
-    
-  >
-
-  >>>
-
-  >>>
-
-  <\active*>
-    <\src-comment>
-      Headers.
-    
-  
-
-  >>>>>
-
-  >>>>>
-
-  \;
-
-  
-
-  
-
-  
-
-  
-
-  \;
-
-  >>>
-
-  >>>
-
-  >
-
-  >
-
-  <\active*>
-    <\src-comment>
-      Title information.
-    
-  
-
-  
-    <\wide-tabular>
-      |
-        <\with|par-first|0fn|par-sep|0fn|par-par-sep|0fn>
-          
-        
-      >>>
-    
-  >
-
-  
-    <\doc-block>
-      
-    
-  >
-
-  
-    <\doc-block>
-      
-    
-  >
-
-  
-    <\doc-block>
-      
-    
-  >
-
-  |>
-    >>>
-  >>
-
-  >
-    <\compact>
-      <\doc-title-block>
-        
-
-        \;
-      
-    
-  >>
-
-  |>>>
-
-  <\active*>
-    <\src-comment>
-      Author information.
-    
-  
-
-  |||UPCASE>>>>>>>
-
-  |||UPCASE>,
-  >>>>>>
-
-  
-    
-  >
-
-  
-    <\style-with|src-compact|none>
-      <\quasi>
-        <\doc-author>
-          <\with|doc-author|>
-            >>
-          
-        
-      
-    
-  >
-
-  <\active*>
-    <\src-comment>
-      Abstracts.
-    
-  
-
-  
-    <\surround||>
-      <\small>
-        
-      
-    
-  >
-
-
-<\initial>
-  <\collection>
-    
-  
-
\ No newline at end of file
diff --git a/TeXmacs/plugins/latex/styles/article/ACM/acmlarge.stem b/TeXmacs/plugins/latex/styles/article/ACM/acmlarge.stem
new file mode 100644
index 0000000000..6a5e8108df
--- /dev/null
+++ b/TeXmacs/plugins/latex/styles/article/ACM/acmlarge.stem
@@ -0,0 +1,39 @@
+(document (TeXmacs "1.99.6")
+  (style "source")
+  (body (document (active* (document (src-title (document (src-style-file "acmlarge" "1.0")
+                                                  (src-purpose (document "The acmlarge style."))
+                                                  (src-copyright "2018" (document "Joris van der Hoeven"))
+                                                  (src-license (document (concat "This software falls under the "
+                                                                           (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE")
+                                                                           ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see "
+                                                                           (hlink "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                             "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                           ) ;hlink
+                                                                           "."
+                                                                         ) ;concat
+                                                               ) ;document
+                                                  ) ;src-license
+                                                ) ;document
+                                     ) ;src-title
+                           ) ;document
+                  ) ;active*
+          (use-package "acmart")
+          (active* (src-comment "Global layout parameters"))
+          (assign "page-width" "8.5in")
+          (assign "page-height" "11in")
+          (assign "page-type" "user")
+          ""
+          (assign "page-odd" "81pt")
+          (assign "page-even" "81pt")
+          (assign "page-right" "81pt")
+          (assign "page-top" (plus "78pt" "13pt" "16pt"))
+          (assign "page-bot" (plus "114pt" "2pc" "0pt"))
+          (assign "page-head-sep" (plus "13pt" "4pt"))
+          (assign "page-foot-sep" "2pc")
+          ""
+          (assign "marginal-note-width" "4pc")
+          (assign "marginal-note-sep" "11pt")
+        ) ;document
+  ) ;body
+  (initial (collection (associate "preamble" "true")))
+) ;document
diff --git a/TeXmacs/plugins/latex/styles/article/ACM/acmlarge.ts b/TeXmacs/plugins/latex/styles/article/ACM/acmlarge.ts
deleted file mode 100644
index 754bb091c9..0000000000
--- a/TeXmacs/plugins/latex/styles/article/ACM/acmlarge.ts
+++ /dev/null
@@ -1,64 +0,0 @@
-
-
-
-
-<\body>
-  <\active*>
-    <\src-title>
-      
-
-      <\src-purpose>
-        The acmlarge style.
-      
-
-      <\src-copyright|2018>
-        Joris van der Hoeven
-      
-
-      <\src-license>
-        This software falls under the . It comes WITHOUT ANY
-        WARRANTY WHATSOEVER. You should have received a copy of the license
-        which the software. If not, see .
-      
-    
-  
-
-  
-
-  >
-
-  
-
-  
-
-  
-
-  \;
-
-  
-
-  
-
-  
-
-  >
-
-  >
-
-  >
-
-  
-
-  \;
-
-  
-
-  
-
-
-<\initial>
-  <\collection>
-    
-  
-
\ No newline at end of file
diff --git a/TeXmacs/plugins/latex/styles/article/ACM/acmsmall.stem b/TeXmacs/plugins/latex/styles/article/ACM/acmsmall.stem
new file mode 100644
index 0000000000..d1ac92f63b
--- /dev/null
+++ b/TeXmacs/plugins/latex/styles/article/ACM/acmsmall.stem
@@ -0,0 +1,39 @@
+(document (TeXmacs "1.99.6")
+  (style "source")
+  (body (document (active* (document (src-title (document (src-style-file "acmsmall" "1.0")
+                                                  (src-purpose (document "The acmsmall style."))
+                                                  (src-copyright "2018" (document "Joris van der Hoeven"))
+                                                  (src-license (document (concat "This software falls under the "
+                                                                           (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE")
+                                                                           ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see "
+                                                                           (hlink "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                             "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                           ) ;hlink
+                                                                           "."
+                                                                         ) ;concat
+                                                               ) ;document
+                                                  ) ;src-license
+                                                ) ;document
+                                     ) ;src-title
+                           ) ;document
+                  ) ;active*
+          (use-package "acmart")
+          (active* (src-comment "Global layout parameters"))
+          (assign "page-width" "6.75in")
+          (assign "page-height" "10in")
+          (assign "page-type" "user")
+          ""
+          (assign "page-odd" "46pt")
+          (assign "page-even" "46pt")
+          (assign "page-right" "46pt")
+          (assign "page-top" (plus "58pt" "13pt" "16pt"))
+          (assign "page-bot" (plus "44pt" "2pc" "-5pt"))
+          (assign "page-head-sep" (plus "13pt" "4pt"))
+          (assign "page-foot-sep" "2pc")
+          ""
+          (assign "marginal-note-width" "2pc")
+          (assign "marginal-note-sep" "11pt")
+        ) ;document
+  ) ;body
+  (initial (collection (associate "preamble" "true")))
+) ;document
diff --git a/TeXmacs/plugins/latex/styles/article/ACM/acmsmall.ts b/TeXmacs/plugins/latex/styles/article/ACM/acmsmall.ts
deleted file mode 100644
index 662e782a11..0000000000
--- a/TeXmacs/plugins/latex/styles/article/ACM/acmsmall.ts
+++ /dev/null
@@ -1,64 +0,0 @@
-
-
-
-
-<\body>
-  <\active*>
-    <\src-title>
-      
-
-      <\src-purpose>
-        The acmsmall style.
-      
-
-      <\src-copyright|2018>
-        Joris van der Hoeven
-      
-
-      <\src-license>
-        This software falls under the . It comes WITHOUT ANY
-        WARRANTY WHATSOEVER. You should have received a copy of the license
-        which the software. If not, see .
-      
-    
-  
-
-  
-
-  >
-
-  
-
-  
-
-  
-
-  \;
-
-  
-
-  
-
-  
-
-  >
-
-  >
-
-  >
-
-  
-
-  \;
-
-  
-
-  
-
-
-<\initial>
-  <\collection>
-    
-  
-
\ No newline at end of file
diff --git a/TeXmacs/plugins/latex/styles/article/ACM/acmtog.stem b/TeXmacs/plugins/latex/styles/article/ACM/acmtog.stem
new file mode 100644
index 0000000000..4fa8e8b2a8
--- /dev/null
+++ b/TeXmacs/plugins/latex/styles/article/ACM/acmtog.stem
@@ -0,0 +1,121 @@
+(document (TeXmacs "1.99.19")
+  (style "source")
+  (body (document (active* (document (src-title (document (src-style-file "acmtog" "1.0")
+                                                  (src-purpose (document "The acmtog style."))
+                                                  (src-copyright "2018" (document "Joris van der Hoeven"))
+                                                  (src-license (document (concat "This software falls under the "
+                                                                           (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE")
+                                                                           ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see "
+                                                                           (hlink "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                             "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                           ) ;hlink
+                                                                           "."
+                                                                         ) ;concat
+                                                               ) ;document
+                                                  ) ;src-license
+                                                ) ;document
+                                     ) ;src-title
+                           ) ;document
+                  ) ;active*
+          (use-package "acmart" "two-columns")
+          (active* (src-comment "Global layout parameters"))
+          (assign "page-width" "8.5in")
+          (assign "page-height" "11in")
+          (assign "page-type" "user")
+          (assign "font-base-size" "9")
+          ""
+          (assign "page-odd" "52pt")
+          (assign "page-even" "52pt")
+          (assign "page-right" "52pt")
+          (assign "page-top" (plus "57pt" "13pt" "12pt"))
+          (assign "page-bot" (plus "73pt" "30pt" "-5pt"))
+          (assign "page-head-sep" (plus "13pt" "6pt"))
+          (assign "page-foot-sep" "30pt")
+          ""
+          (assign "par-columns-sep" "24pt")
+          (assign "marginal-note-width" "2pc")
+          (assign "marginal-note-sep" "11pt")
+          (active* (src-comment (document "Sizes.")))
+          (assign "tiny"
+            (macro "x" (with "font-size" (over "5" "9") "par-sep" "1pt" (arg "x")))
+          ) ;assign
+          (assign "very-small"
+            (macro "x" (with "font-size" (over "6" "9") "par-sep" "1pt" (arg "x")))
+          ) ;assign
+          (assign "smaller"
+            (macro "x" (with "font-size" (over "7" "9") "par-sep" "1pt" (arg "x")))
+          ) ;assign
+          (assign "small"
+            (macro "x" (with "font-size" (over "7" "9") "par-sep" "2pt" (arg "x")))
+          ) ;assign
+          (assign "flat-size"
+            (macro "x" (with "font-size" (over "8" "9") "par-sep" "1.5pt" (arg "x")))
+          ) ;assign
+          (assign "normal-size"
+            (macro "x" (with "font-size" (over "9" "9") "par-sep" "1.5pt" (arg "x")))
+          ) ;assign
+          (assign "sharp-size"
+            (macro "x" (with "font-size" (over "10" "9") "par-sep" "1.5pt" (arg "x")))
+          ) ;assign
+          (assign "large"
+            (macro "x" (with "font-size" (over "12" "9") "par-sep" "2pt" (arg "x")))
+          ) ;assign
+          (assign "larger"
+            (macro "x" (with "font-size" (over "14" "9") "par-sep" "4pt" (arg "x")))
+          ) ;assign
+          (assign "very-large"
+            (macro "x" (with "font-size" (over "17" "9") "par-sep" "3pt" (arg "x")))
+          ) ;assign
+          (assign "huge"
+            (macro "x" (with "font-size" (over "20" "9") "par-sep" "5pt" (arg "x")))
+          ) ;assign
+          (assign "really-huge"
+            (macro "x" (with "font-size" (over "25" "9") "par-sep" "5pt" (arg "x")))
+          ) ;assign
+          (active* (src-comment "Sectional macros"))
+          (assign "section-font"
+            (macro "name"
+              (sharp-size (with "font-family" "ss" (change-case (arg "name") "UPCASE")))
+            ) ;macro
+          ) ;assign
+          (assign "subsection-font"
+            (macro "name" (sharp-size (with "font-family" "ss" (arg "name"))))
+          ) ;assign
+          (assign "section-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-normal (concat (vspace* (tmlen "0.75bls" "0.55bls" "0.95bls"))
+                                    (section-font (arg "name"))
+                                    (vspace "0.25bls")
+                                  ) ;concat
+                ) ;sectional-normal
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "subsection-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-normal (concat (vspace* (tmlen "0.75bls" "0.55bls" "0.55bls"))
+                                    (subsection-font (arg "name"))
+                                    (vspace "0.25bls")
+                                  ) ;concat
+                ) ;sectional-normal
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (active* (src-comment "Title information"))
+          (assign "doc-title"
+            (macro "x"
+              (surround (vspace* "0.5fn")
+                (vspace "0.5fn")
+                (document (doc-title-block (font-magnify "1.9" (with "font-family" "ss" (arg "x"))))
+                ) ;document
+              ) ;surround
+            ) ;macro
+          ) ;assign
+        ) ;document
+  ) ;body
+  (initial (collection (associate "preamble" "true")))
+) ;document
diff --git a/TeXmacs/plugins/latex/styles/article/ACM/acmtog.ts b/TeXmacs/plugins/latex/styles/article/ACM/acmtog.ts
deleted file mode 100644
index bd22898955..0000000000
--- a/TeXmacs/plugins/latex/styles/article/ACM/acmtog.ts
+++ /dev/null
@@ -1,112 +0,0 @@
-
-
-
-
-<\body>
-  <\active*>
-    <\src-title>
-      
-
-      <\src-purpose>
-        The acmtog style.
-      
-
-      <\src-copyright|2018>
-        Joris van der Hoeven
-      
-
-      <\src-license>
-        This software falls under the . It comes WITHOUT ANY
-        WARRANTY WHATSOEVER. You should have received a copy of the license
-        which the software. If not, see .
-      
-    
-  
-
-  
-
-  >
-
-  
-
-  
-
-  
-
-  
-
-  \;
-
-  
-
-  
-
-  
-
-  >
-
-  >
-
-  >
-
-  
-
-  \;
-
-  
-
-  
-
-  
-
-  
-    Sizes.
-  >
-
-  |par-sep|1pt|>>>
-
-  |par-sep|1pt|>>>
-
-  |par-sep|1pt|>>>
-
-  |par-sep|2pt|>>>
-
-  |par-sep|1.5pt|>>>
-
-  |par-sep|1.5pt|>>>
-
-  |par-sep|1.5pt|>>>
-
-  |par-sep|2pt|>>>
-
-  |par-sep|4pt|>>>
-
-  |par-sep|3pt|>>>
-
-  |par-sep|5pt|>>>
-
-  |par-sep|5pt|>>>
-
-  >
-
-  |UPCASE>>>>>
-
-  >>>>
-
-  >>>>>>
-
-  >>>>>>
-
-  >
-
-  |>
-    >>>
-  >>
-
-
-<\initial>
-  <\collection>
-    
-  
-
\ No newline at end of file
diff --git a/TeXmacs/plugins/latex/styles/article/ACM/sigchi.stem b/TeXmacs/plugins/latex/styles/article/ACM/sigchi.stem
new file mode 100644
index 0000000000..31f2f59aa0
--- /dev/null
+++ b/TeXmacs/plugins/latex/styles/article/ACM/sigchi.stem
@@ -0,0 +1,67 @@
+(document (TeXmacs "1.99.19")
+  (style "source")
+  (body (document (active* (document (src-title (document (src-style-file "sigchi" "1.0")
+                                                  (src-purpose (document "The ACM sigchi style."))
+                                                  (src-copyright "2018" (document "Joris van der Hoeven"))
+                                                  (src-license (document (concat "This software falls under the "
+                                                                           (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE")
+                                                                           ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see "
+                                                                           (hlink "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                             "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                           ) ;hlink
+                                                                           "."
+                                                                         ) ;concat
+                                                               ) ;document
+                                                  ) ;src-license
+                                                ) ;document
+                                     ) ;src-title
+                           ) ;document
+                  ) ;active*
+          (use-package "sigconf")
+          (active* (src-comment (document "Global style parameters.")))
+          (assign "font-base-size" "10")
+          ""
+          (assign "page-odd" "54pt")
+          (assign "page-even" "54pt")
+          (assign "page-right" "54pt")
+          (assign "page-top" (plus "66pt" "13pt" "12pt"))
+          (assign "page-bot" (plus "73pt" "30pt" "-24pt"))
+          (assign "page-head-sep" "13pt")
+          (assign "page-foot-sep" "30pt")
+          ""
+          (assign "par-columns-sep" "2pc")
+          (assign "marginal-note-width" "2pc")
+          (assign "marginal-note-sep" "11pt")
+          (active* (src-comment "Font sizes"))
+          (assign "tiny" (macro "x" (with "font-size" "0.5" "par-sep" "1pt" (arg "x"))))
+          (assign "very-small"
+            (macro "x" (with "font-size" "0.7" "par-sep" "1pt" (arg "x")))
+          ) ;assign
+          (assign "small" (macro "x" (with "font-size" "0.9" "par-sep" "1pt" (arg "x"))))
+          (assign "flat-size"
+            (macro "x" (with "font-size" "0.9" "par-sep" "1pt" (arg "x")))
+          ) ;assign
+          (assign "normal-size"
+            (macro "x" (with "font-size" "1.0" "par-sep" "1pt" (arg "x")))
+          ) ;assign
+          (assign "sharp-size"
+            (macro "x" (with "font-size" "1.1" "par-sep" "1.5pt" (arg "x")))
+          ) ;assign
+          (assign "large" (macro "x" (with "font-size" "1.2" "par-sep" "2pt" (arg "x"))))
+          (assign "larger" (macro "x" (with "font-size" "1.4" "par-sep" "4pt" (arg "x"))))
+          (assign "very-large"
+            (macro "x" (with "font-size" "1.7" "par-sep" "5pt" (arg "x")))
+          ) ;assign
+          (assign "huge" (macro "x" (with "font-size" "2.0" "par-sep" "5pt" (arg "x"))))
+          (assign "really-huge"
+            (macro "x" (with "font-size" "2.5" "par-sep" "5pt" (arg "x")))
+          ) ;assign
+          (active* (src-comment "Sectional macros"))
+          (assign "section-font"
+            (macro "name" (with "font-family" "ss" (change-case (arg "name") "UPCASE")))
+          ) ;assign
+          (assign "subsection-font" (macro "name" (with "font-family" "ss" (arg "name"))))
+        ) ;document
+  ) ;body
+  (initial (collection (associate "preamble" "true")))
+) ;document
diff --git a/TeXmacs/plugins/latex/styles/article/ACM/sigchi.ts b/TeXmacs/plugins/latex/styles/article/ACM/sigchi.ts
deleted file mode 100644
index 610935673a..0000000000
--- a/TeXmacs/plugins/latex/styles/article/ACM/sigchi.ts
+++ /dev/null
@@ -1,94 +0,0 @@
-
-
-
-
-<\body>
-  <\active*>
-    <\src-title>
-      
-
-      <\src-purpose>
-        The ACM sigchi style.
-      
-
-      <\src-copyright|2018>
-        Joris van der Hoeven
-      
-
-      <\src-license>
-        This software falls under the . It comes WITHOUT ANY
-        WARRANTY WHATSOEVER. You should have received a copy of the license
-        which the software. If not, see .
-      
-    
-  
-
-  
-
-  
-    Global style parameters.
-  >
-
-  
-
-  \;
-
-  
-
-  
-
-  
-
-  >
-
-  >
-
-  
-
-  
-
-  \;
-
-  
-
-  
-
-  
-
-  >
-
-  >>>
-
-  >>>
-
-  >>>
-
-  >>>
-
-  >>>
-
-  >>>
-
-  >>>
-
-  >>>
-
-  >>>
-
-  >>>
-
-  >>>
-
-  >
-
-  |UPCASE>>>>
-
-  >>>
-
-
-<\initial>
-  <\collection>
-    
-  
-
\ No newline at end of file
diff --git a/TeXmacs/plugins/latex/styles/article/ACM/sigconf.stem b/TeXmacs/plugins/latex/styles/article/ACM/sigconf.stem
new file mode 100644
index 0000000000..7143e30fac
--- /dev/null
+++ b/TeXmacs/plugins/latex/styles/article/ACM/sigconf.stem
@@ -0,0 +1,341 @@
+(document (TeXmacs "1.99.19")
+  (style "source")
+  (body (document (active* (document (src-title (document (src-style-file "sigconf" "1.0")
+                                                  (src-purpose (document "The ACM sigconf style."))
+                                                  (src-copyright "2018" (document "Joris van der Hoeven"))
+                                                  (src-license (document (concat "This software falls under the "
+                                                                           (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE")
+                                                                           ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see "
+                                                                           (hlink "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                             "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                           ) ;hlink
+                                                                           "."
+                                                                         ) ;concat
+                                                               ) ;document
+                                                  ) ;src-license
+                                                ) ;document
+                                     ) ;src-title
+                           ) ;document
+                  ) ;active*
+          (use-package "acmart" "two-columns")
+          (active* (src-comment (document "Global style parameters.")))
+          (assign "page-type" "letter")
+          (assign "page-width" "auto")
+          (assign "page-height" "auto")
+          (assign "font-base-size" "9")
+          ""
+          (assign "page-odd" "54pt")
+          (assign "page-even" "54pt")
+          (assign "page-right" "54pt")
+          (assign "page-top" (plus "52pt" "13pt" "21pt"))
+          (assign "page-bot" (plus "75pt" "2pc" "-18pt"))
+          (assign "page-head-sep" (plus "13pt" "3pt"))
+          (assign "page-foot-sep" "2pc")
+          ""
+          (assign "par-columns-sep" "2pc")
+          (assign "marginal-note-width" "2pc")
+          (assign "marginal-note-sep" "11pt")
+          (active* (src-comment (document "Sizes.")))
+          (assign "tiny"
+            (macro "x" (with "font-size" (over "5" "9") "par-sep" "1pt" (arg "x")))
+          ) ;assign
+          (assign "very-small"
+            (macro "x" (with "font-size" (over "6" "9") "par-sep" "1pt" (arg "x")))
+          ) ;assign
+          (assign "smaller"
+            (macro "x" (with "font-size" (over "7" "9") "par-sep" "1pt" (arg "x")))
+          ) ;assign
+          (assign "small"
+            (macro "x" (with "font-size" (over "7" "9") "par-sep" "2pt" (arg "x")))
+          ) ;assign
+          (assign "flat-size"
+            (macro "x" (with "font-size" (over "8" "9") "par-sep" "1.5pt" (arg "x")))
+          ) ;assign
+          (assign "normal-size"
+            (macro "x" (with "font-size" (over "9" "9") "par-sep" "1.5pt" (arg "x")))
+          ) ;assign
+          (assign "sharp-size"
+            (macro "x" (with "font-size" (over "11" "9") "par-sep" "1.5pt" (arg "x")))
+          ) ;assign
+          (assign "large"
+            (macro "x" (with "font-size" (over "12" "9") "par-sep" "2pt" (arg "x")))
+          ) ;assign
+          (assign "larger"
+            (macro "x" (with "font-size" (over "14" "9") "par-sep" "4pt" (arg "x")))
+          ) ;assign
+          (assign "very-large"
+            (macro "x" (with "font-size" (over "17" "9") "par-sep" "3pt" (arg "x")))
+          ) ;assign
+          (assign "huge"
+            (macro "x" (with "font-size" (over "20" "9") "par-sep" "5pt" (arg "x")))
+          ) ;assign
+          (assign "really-huge"
+            (macro "x" (with "font-size" (over "25" "9") "par-sep" "5pt" (arg "x")))
+          ) ;assign
+          (active* (src-comment "Sectional macros"))
+          (assign "section-font"
+            (macro "name" (sharp-size (change-case (arg "name") "UPCASE")))
+          ) ;assign
+          (assign "subsection-font" (macro "name" (sharp-size (arg "name"))))
+          (active* (src-comment (document "Conference information and copyrights")))
+          (assign "conference-boilerplate"
+            "Permission to make digital or hard copies of all or part of this work for personal or classroom use is granted without fee provided that copies are not made or distributed for profit or commercial advantage and that copies bear this notice and the full citation on the first page.  To copy otherwise, to republish, to post on servers or to redistribute to lists, requires prior specific permission and/or a fee."
+          ) ;assign
+          (assign "conference-name"
+            (concat "(Please declare "
+              (with "font-shape" "right" (src-macro "conferenceinfo"))
+              ", "
+              (with "font-shape" "right" (src-macro "CopyrightYear"))
+              ", and "
+              (with "font-shape" "right" (src-macro "crdata"))
+              " in your preamble, following ACM guidelines:"
+              (next-line)
+              (hlink "http://www.acm.org/sigs/publications/proceedings-templates"
+                "http://www.acm.org/sigs/publications/proceedings-templates"
+              ) ;hlink
+              ")"
+            ) ;concat
+          ) ;assign
+          (assign "conference-info" "")
+          (assign "conference-copyright-year" "20XX")
+          (assign "conference-cr-data" "XXX-X-XXXX-XXXX-X/XX/XX")
+          (assign "conference-price" "$15.00")
+          (assign "conferenceinfo"
+            (macro "name"
+              "infos"
+              (concat (assign "conference-name" (arg "name"))
+                (assign "conference-info" (arg "infos"))
+              ) ;concat
+            ) ;macro
+          ) ;assign
+          (assign "CopyrightYear"
+            (macro "year" (assign "conference-copyright-year" (arg "year")))
+          ) ;assign
+          (assign "crdata" (macro "data" (assign "conference-cr-data" (arg "data"))))
+          (assign "permission"
+            (macro "data" (assign "conference-boilerplate" (arg "data")))
+          ) ;assign
+          (assign "conference-copyrightetc"
+            (concat "Copyright "
+              (value "conference-copyright-year")
+              " ACM "
+              (value "conference-cr-data")
+              " ..."
+              (value "conference-price")
+              "."
+            ) ;concat
+          ) ;assign
+          (assign "copyrightetc"
+            (macro "data" (assign "conference-copyrightetc" (arg "data")))
+          ) ;assign
+          (assign "conference-permission-par-line-sep" "0pt")
+          (assign "conference-permission-font-base-size" "7")
+          (assign "make-conference-permissions"
+            (macro (with "par-par-sep"
+                     "0pt"
+                     "par-line-sep"
+                     (value "conference-permission-par-line-sep")
+                     "par-sep"
+                     "1pt"
+                     "font-base-size"
+                     (value "conference-permission-font-base-size")
+                     (concat (no-indent)
+                       (value "conference-boilerplate")
+                       (new-line)
+                       (no-indent)
+                       (with "font-shape" "italic" (value "conference-name"))
+                       ", "
+                       (value "conference-info")
+                       (new-line)
+                       (no-indent)
+                       (value "conference-copyrightetc")
+                     ) ;concat
+                   ) ;with
+            ) ;macro
+          ) ;assign
+          (active* (document (src-comment (document "Title information."))))
+          (assign "doc-title-block"
+            (macro "body"
+              (document (tabular* (tformat (twith "table-width" "1par")
+                                    (cwith "1" "1" "1" "1" "cell-lsep" "0spc")
+                                    (cwith "1" "1" "1" "1" "cell-rsep" "0spc")
+                                    (cwith "1" "1" "1" "1" "cell-bsep" "0spc")
+                                    (cwith "1" "1" "1" "1" "cell-tsep" "0spc")
+                                    (cwith "1" "1" "1" "1" "cell-hyphen" "t")
+                                    (table (row (cell (document (with "par-mode" "center" (document (arg "body"))))))
+                                    ) ;table
+                                  ) ;tformat
+                        ) ;tabular*
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "doc-author-block"
+            (macro "body"
+              (document (style-with "src-compact"
+                          "none"
+                          (concat (space "0pt")
+                            (tabular* (tformat (cwith "1" "1" "1" "1" "cell-lsep" "0spc")
+                                        (cwith "1" "1" "1" "1" "cell-rsep" "0spc")
+                                        (cwith "1" "1" "1" "1" "cell-tsep" "0spc")
+                                        (cwith "1" "1" "1" "1" "cell-hyphen" "t")
+                                        (cwith "1" "1" "1" "1" "cell-hmode" "min")
+                                        (cwith "1" "1" "1" "1" "cell-width" "1par")
+                                        (cwith "1" "-1" "1" "-1" "cell-bsep" "-3pt")
+                                        (table (row (cell (document (with "par-mode" "center" (document (arg "body"))))))
+                                        ) ;table
+                                      ) ;tformat
+                            ) ;tabular*
+                          ) ;concat
+                        ) ;style-with
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "doc-authors-block"
+            (macro "body"
+              (document (style-with "src-compact"
+                          "none"
+                          (concat (space "0pt")
+                            (tabular* (tformat (twith "table-valign" "T")
+                                        (cwith "1" "1" "1" "1" "cell-lsep" "0spc")
+                                        (cwith "1" "1" "1" "1" "cell-rsep" "0spc")
+                                        (cwith "1" "1" "1" "1" "cell-bsep" "0.75fn")
+                                        (cwith "1" "1" "1" "1" "cell-tsep" "0.75fn")
+                                        (cwith "1" "1" "1" "1" "cell-hyphen" "t")
+                                        (cwith "1" "1" "1" "1" "cell-hmode" "min")
+                                        (cwith "1" "1" "1" "1" "cell-width" "1par")
+                                        (table (row (cell (document (with "par-mode" "center" (document (arg "body"))))))
+                                        ) ;table
+                                      ) ;tformat
+                            ) ;tabular*
+                          ) ;concat
+                        ) ;style-with
+              ) ;document
+            ) ;macro
+          ) ;assign
+          ""
+          (assign "doc-title"
+            (macro "x"
+              (document (surround (concat (new-line) (vspace* (minus "2em" "10pt")))
+                          (vspace "1em")
+                          (document (doc-title-block (with "font-family"
+                                                       "ss"
+                                                       "font-series"
+                                                       "bold"
+                                                       "font-size"
+                                                       (over "18" "9")
+                                                       (arg "x")
+                                                     ) ;with
+                                    ) ;doc-title-block
+                          ) ;document
+                        ) ;surround
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "doc-subtitle"
+            (macro "x"
+              (surround (vspace* "0.25fn")
+                (vspace "0.25fn")
+                (document (doc-title-block (font-magnify "1.297" (with "font-family" "ss" (arg "x"))))
+                ) ;document
+              ) ;surround
+            ) ;macro
+          ) ;assign
+          (assign "doc-data" (xmacro "args" (extern "doc-data" (quote-arg "args") "")))
+          (active* (document (src-comment (document "Author information."))))
+          (assign "doc-authors"
+            (xmacro "data"
+              (document (style-with "src-compact"
+                          "none"
+                          (document (quasi (document (doc-author (document (with "doc-author"
+                                                                             (value "doc-author*")
+                                                                             (document (concat (space "0spc") (unquote* (map "padded-author" (quote-arg "data"))))
+                                                                             ) ;document
+                                                                           ) ;with
+                                                                 ) ;document
+                                                     ) ;doc-author
+                                           ) ;document
+                                    ) ;quasi
+                          ) ;document
+                        ) ;style-with
+              ) ;document
+            ) ;xmacro
+          ) ;assign
+          (assign "author-name"
+            (macro "author"
+              (surround (vspace* "0.25fn")
+                (vspace "0.5fn")
+                (doc-author-block (with "font-size" (over "12" "9") (arg "author")))
+              ) ;surround
+            ) ;macro
+          ) ;assign
+          (assign "author-affiliation"
+            (macro "address"
+              (document (surround (vspace* "0.25fn")
+                          (vspace "0.25fn")
+                          (doc-author-block (with "font-size" (over "10" "9") (arg "address")))
+                        ) ;surround
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "author-email" (macro "email" (doc-author-block (arg "email"))))
+          (assign "author-homepage"
+            (macro "homepage" (doc-author-block (arg "homepage")))
+          ) ;assign
+          (active* (document (src-comment (document "Abstract information."))))
+          (assign "render-abstract"
+            (macro "body"
+              (document (section* (abstract-text))
+                (surround (no-indent)
+                  (float "footnote" "" (smaller (make-conference-permissions)))
+                  (arg "body")
+                ) ;surround
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "render-abstract*"
+            (macro "body"
+              "notes"
+              (document (render-abstract (document (arg "body") (arg "notes"))))
+            ) ;macro
+          ) ;assign
+          (assign "abstract-category-item"
+            (macro "ind"
+              "cat"
+              "sub"
+              "det"
+              (concat (arg "ind")
+                (if (unequal (arg "cat") (uninit))
+                  (concat " [" (with "font-series" "bold" (arg "cat")) "]")
+                ) ;if
+                (if (unequal (arg "sub") (uninit)) (concat ": " (arg "sub")))
+                (if (unequal (arg "det") (uninit))
+                  (concat "\x16;" (with "font-shape" "italic" (arg "det")))
+                ) ;if
+              ) ;concat
+            ) ;macro
+          ) ;assign
+          (assign "abstract-category"
+            (xmacro "args"
+              (document (section* "CSS Concepts")
+                (concat (no-indent) (concat-tuple (quote-arg "args") "; "))
+              ) ;document
+            ) ;xmacro
+          ) ;assign
+          (assign "abstract-terms"
+            (xmacro "args"
+              (document (section* "General Terms")
+                (concat (no-indent) (concat-tuple (quote-arg "args") ", "))
+              ) ;document
+            ) ;xmacro
+          ) ;assign
+          (assign "abstract-keywords"
+            (xmacro "args"
+              (document (section* (keywords-text))
+                (concat (no-indent) (concat-tuple (quote-arg "args") ", "))
+              ) ;document
+            ) ;xmacro
+          ) ;assign
+        ) ;document
+  ) ;body
+  (initial (collection (associate "preamble" "true")))
+) ;document
diff --git a/TeXmacs/plugins/latex/styles/article/ACM/sigconf.ts b/TeXmacs/plugins/latex/styles/article/ACM/sigconf.ts
deleted file mode 100644
index 23ca61a317..0000000000
--- a/TeXmacs/plugins/latex/styles/article/ACM/sigconf.ts
+++ /dev/null
@@ -1,263 +0,0 @@
-
-
-
-
-<\body>
-  <\active*>
-    <\src-title>
-      
-
-      <\src-purpose>
-        The ACM sigconf style.
-      
-
-      <\src-copyright|2018>
-        Joris van der Hoeven
-      
-
-      <\src-license>
-        This software falls under the . It comes WITHOUT ANY
-        WARRANTY WHATSOEVER. You should have received a copy of the license
-        which the software. If not, see .
-      
-    
-  
-
-  
-
-  
-    Global style parameters.
-  >
-
-  
-
-  
-
-  
-
-  
-
-  \;
-
-  
-
-  
-
-  
-
-  >
-
-  >
-
-  >
-
-  
-
-  \;
-
-  
-
-  
-
-  
-
-  
-    Sizes.
-  >
-
-  |par-sep|1pt|>>>
-
-  |par-sep|1pt|>>>
-
-  |par-sep|1pt|>>>
-
-  |par-sep|2pt|>>>
-
-  |par-sep|1.5pt|>>>
-
-  |par-sep|1.5pt|>>>
-
-  |par-sep|1.5pt|>>>
-
-  |par-sep|2pt|>>>
-
-  |par-sep|4pt|>>>
-
-  |par-sep|3pt|>>>
-
-  |par-sep|5pt|>>>
-
-  |par-sep|5pt|>>>
-
-  >
-
-  |UPCASE>>>>
-
-  >>>
-
-  
-    Conference information and copyrights
-  >
-
-  
-
-  >,
-  >, and
-  > in your preamble, following ACM
-  guidelines:)>
-
-  
-
-  
-
-  
-
-  
-
-  >>>>
-
-  >>>
-
-  >>>
-
-  >>>
-
-  
-  ACM  ....>
-
-  >>>
-
-  
-
-  
-
-  |par-sep|1pt|font-base-size||>,
-  >>>
-
-  <\active*>
-    <\src-comment>
-      Title information.
-    
-  
-
-  
-    ||||||
-      <\with|par-mode|center>
-        
-      
-    >>>>
-  >
-
-  
-    |||||||
-      <\with|par-mode|center>
-        
-      
-    >>>>>
-  >
-
-  
-    ||||||||
-      <\with|par-mode|center>
-        
-      
-    >>>>>
-  >
-
-  \;
-
-  
-    <\surround|>|>
-      |>>
-    
-  >
-
-  |>
-    >>>
-  >>
-
-  |>>>
-
-  <\active*>
-    <\src-comment>
-      Author information.
-    
-  
-
-  
-    <\style-with|src-compact|none>
-      <\quasi>
-        <\doc-author>
-          <\with|doc-author|>
-            >>
-          
-        
-      
-    
-  >
-
-  |||>>>>>
-
-  
-    |||>>>
-  >
-
-  >>>
-
-  >>>
-
-  <\active*>
-    <\src-comment>
-      Abstract information.
-    
-  
-
-  
-    >
-
-    |>>|>
-  >
-
-  
-    <\render-abstract>
-      
-
-      
-    
-  >
-
-  |>|
-  [>]>|>|:
-  >|>|\V>>>>
-
-  
-    
-
-    |; >
-  >
-
-  
-    
-
-    |, >
-  >
-
-  
-    >
-
-    |, >
-  >
-
-
-<\initial>
-  <\collection>
-    
-  
-
\ No newline at end of file
diff --git a/TeXmacs/plugins/latex/styles/article/ACM/sigplan.stem b/TeXmacs/plugins/latex/styles/article/ACM/sigplan.stem
new file mode 100644
index 0000000000..46bcd79e2b
--- /dev/null
+++ b/TeXmacs/plugins/latex/styles/article/ACM/sigplan.stem
@@ -0,0 +1,65 @@
+(document (TeXmacs "1.99.19")
+  (style "source")
+  (body (document (active* (document (src-title (document (src-style-file "sigplan" "1.0")
+                                                  (src-purpose (document "The ACM sigplan style."))
+                                                  (src-copyright "2018" (document "Joris van der Hoeven"))
+                                                  (src-license (document (concat "This software falls under the "
+                                                                           (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE")
+                                                                           ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see "
+                                                                           (hlink "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                             "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                           ) ;hlink
+                                                                           "."
+                                                                         ) ;concat
+                                                               ) ;document
+                                                  ) ;src-license
+                                                ) ;document
+                                     ) ;src-title
+                           ) ;document
+                  ) ;active*
+          (use-package "sigconf")
+          (active* (src-comment (document "Global style parameters.")))
+          (assign "font-base-size" "10")
+          ""
+          (assign "page-odd" "0.75in")
+          (assign "page-even" "0.75in")
+          (assign "page-right" "0.75in")
+          (assign "page-top" (plus "1in" "13pt" "-12pt"))
+          (assign "page-bot" (plus "1in" "30pt" "-20pt"))
+          (assign "page-head-sep" (plus "13pt" "4pt"))
+          (assign "page-foot-sep" "30pt")
+          ""
+          (assign "par-columns-sep" "2pc")
+          (assign "marginal-note-width" "2pc")
+          (assign "marginal-note-sep" "11pt")
+          (active* (src-comment "Font sizes"))
+          (assign "tiny" (macro "x" (with "font-size" "0.5" "par-sep" "1pt" (arg "x"))))
+          (assign "very-small"
+            (macro "x" (with "font-size" "0.7" "par-sep" "1pt" (arg "x")))
+          ) ;assign
+          (assign "small" (macro "x" (with "font-size" "0.9" "par-sep" "1pt" (arg "x"))))
+          (assign "flat-size"
+            (macro "x" (with "font-size" "0.9" "par-sep" "1pt" (arg "x")))
+          ) ;assign
+          (assign "normal-size"
+            (macro "x" (with "font-size" "1.0" "par-sep" "1pt" (arg "x")))
+          ) ;assign
+          (assign "sharp-size"
+            (macro "x" (with "font-size" "1.1" "par-sep" "1.5pt" (arg "x")))
+          ) ;assign
+          (assign "large" (macro "x" (with "font-size" "1.2" "par-sep" "2pt" (arg "x"))))
+          (assign "larger" (macro "x" (with "font-size" "1.4" "par-sep" "4pt" (arg "x"))))
+          (assign "very-large"
+            (macro "x" (with "font-size" "1.7" "par-sep" "5pt" (arg "x")))
+          ) ;assign
+          (assign "huge" (macro "x" (with "font-size" "2.0" "par-sep" "5pt" (arg "x"))))
+          (assign "really-huge"
+            (macro "x" (with "font-size" "2.5" "par-sep" "5pt" (arg "x")))
+          ) ;assign
+          (active* (src-comment "Sectional macros"))
+          (assign "section-font" (macro "name" (large (arg "name"))))
+          (assign "subsection-font" (macro "name" (arg "name")))
+        ) ;document
+  ) ;body
+  (initial (collection (associate "preamble" "true")))
+) ;document
diff --git a/TeXmacs/plugins/latex/styles/article/ACM/sigplan.ts b/TeXmacs/plugins/latex/styles/article/ACM/sigplan.ts
deleted file mode 100644
index 6c1a8949ba..0000000000
--- a/TeXmacs/plugins/latex/styles/article/ACM/sigplan.ts
+++ /dev/null
@@ -1,94 +0,0 @@
-
-
-
-
-<\body>
-  <\active*>
-    <\src-title>
-      
-
-      <\src-purpose>
-        The ACM sigplan style.
-      
-
-      <\src-copyright|2018>
-        Joris van der Hoeven
-      
-
-      <\src-license>
-        This software falls under the . It comes WITHOUT ANY
-        WARRANTY WHATSOEVER. You should have received a copy of the license
-        which the software. If not, see .
-      
-    
-  
-
-  
-
-  
-    Global style parameters.
-  >
-
-  
-
-  \;
-
-  
-
-  
-
-  
-
-  >
-
-  >
-
-  >
-
-  
-
-  \;
-
-  
-
-  
-
-  
-
-  >
-
-  >>>
-
-  >>>
-
-  >>>
-
-  >>>
-
-  >>>
-
-  >>>
-
-  >>>
-
-  >>>
-
-  >>>
-
-  >>>
-
-  >>>
-
-  >
-
-  >>>
-
-  >>
-
-
-<\initial>
-  <\collection>
-    
-  
-
\ No newline at end of file
diff --git a/TeXmacs/plugins/latex/styles/article/AMS/amsart.stem b/TeXmacs/plugins/latex/styles/article/AMS/amsart.stem
new file mode 100644
index 0000000000..414d57aa21
--- /dev/null
+++ b/TeXmacs/plugins/latex/styles/article/AMS/amsart.stem
@@ -0,0 +1,353 @@
+(document (TeXmacs "2.1.1")
+  (style "source")
+  (body (document (active* (document (src-title (document (src-style-file "amsart" "1.0")
+                                                  (src-purpose (document "The amsart style."))
+                                                  (src-copyright "2002--2004" (document "Joris van der Hoeven"))
+                                                  (src-license (document (concat "This software falls under the "
+                                                                           (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE")
+                                                                           ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see "
+                                                                           (hlink "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                             "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                           ) ;hlink
+                                                                           "."
+                                                                         ) ;concat
+                                                               ) ;document
+                                                  ) ;src-license
+                                                ) ;document
+                                     ) ;src-title
+                           ) ;document
+                  ) ;active*
+          (use-package "std" "env" "title-generic" "header-article"
+            "section-article" "std-latex"
+          ) ;use-package
+          (active* (document (src-comment (document "Global style parameters."))))
+          (assign "tex-text-width" (macro "30pc"))
+          (assign "tex-odd-side-margin"
+            (macro (minus (maximum (over (minus "1paw" (tex-text-width)) "2") "1.5in") "1in")
+            ) ;macro
+          ) ;assign
+          (assign "tex-even-side-margin" (value "tex-odd-side-margin"))
+          (assign "tex-head-height" (macro "8pt"))
+          (assign "tex-top-skip" (macro "10pt"))
+          (assign "tex-text-height" (macro "50.5pc"))
+          (assign "tex-foot-skip" (macro "12pt"))
+          (assign "tex-column-sep" (macro "10pt"))
+          (assign "tex-margin-par-width" (macro "90pt"))
+          (assign "par-first" (macro "12pt"))
+          (assign "page-fnote-barlen" "6em")
+          (active* (document (src-comment (document "Footnotes for titles and abstracts.")))
+          ) ;active*
+          (assign "render-plain-footnote"
+            (macro "body"
+              (style-with "src-compact"
+                "none"
+                (float "footnote"
+                  ""
+                  (document (style-with "src-compact"
+                              "none"
+                              (document (smaller (with "par-mode"
+                                                   "justify"
+                                                   "par-left"
+                                                   "0cm"
+                                                   "par-right"
+                                                   "0cm"
+                                                   "font-shape"
+                                                   "right"
+                                                   "dummy"
+                                                   (value "page-fnote-sep")
+                                                   "dummy"
+                                                   (value "page-fnote-barlen")
+                                                   (style-with "src-compact" "none" (style-with "src-compact" "none" (arg "body")))
+                                                 ) ;with
+                                        ) ;smaller
+                              ) ;document
+                            ) ;style-with
+                  ) ;document
+                ) ;float
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (active* (document (src-comment (document "Titles."))))
+          (assign "doc-title-name" (macro "x" (strong (change-case (arg "x") "UPCASE"))))
+          (assign "doc-title"
+            (macro "x"
+              (document ""
+                (surround (vspace* (minus (tex-len "42pt" "5pc" "5pc") "1bls"))
+                  ""
+                  (document (doc-title-block (doc-title-name (arg "x"))))
+                ) ;surround
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "author-name"
+            (macro "author"
+              (surround (vspace* (minus "18pt" "1em"))
+                ""
+                (doc-author-block (small (change-case (arg "author") "UPCASE")))
+              ) ;surround
+            ) ;macro
+          ) ;assign
+          ""
+          (assign "date-text" (macro (localize "Date")))
+          (assign "note-text" (macro (localize "Note")))
+          (assign "email-text" (macro (localize "E-mail address")))
+          (assign "homepage-text" (macro (localize "Homepage")))
+          (assign "doc-date"
+            (macro "x" (surround (concat (em (date-text)) (localize ":") " ") "" (arg "x")))
+          ) ;assign
+          (assign "doc-note"
+            (macro "x" (surround (concat (em (note-text)) (localize ":") " ") "" (arg "x")))
+          ) ;assign
+          (assign "author-affiliation" (macro "x" (quasi (concat-tuple ,(arg "x") ", "))))
+          (assign "prepend-comma" (macro "x" (concat ", " (arg "x"))))
+          (assign "author-affiliation"
+            (macro "x"
+              (with "font-shape"
+                "small-caps"
+                (concat (arg "x" "0") (map-args "prepend-comma" "concat" "x" "1"))
+              ) ;with
+            ) ;macro
+          ) ;assign
+          (assign "author-email"
+            (macro "x"
+              (surround (concat (em (email-text)) (localize ":") " ") "" (verbatim (arg "x")))
+            ) ;macro
+          ) ;assign
+          (assign "author-homepage"
+            (macro "x"
+              (surround (concat (em (homepage-text)) (localize ":") " ")
+                ""
+                (verbatim (arg "x"))
+              ) ;surround
+            ) ;macro
+          ) ;assign
+          (assign "author-note"
+            (macro "x" (surround (concat (em (note-text)) (localize ":") " ") "" (arg "x")))
+          ) ;assign
+          (assign "author-misc" (macro "x" (arg "x")))
+          ""
+          (assign "doc-data"
+            (xmacro "args" (extern "doc-data" (quote-arg "args") (tuple "ams-title")))
+          ) ;assign
+          (active* (document (src-comment (document "Abstracts."))))
+          (assign "render-abstract"
+            (macro "body"
+              (document (padded-normal "20pt"
+                          "20pt"
+                          (document (with "par-left"
+                                      "3pc"
+                                      "par-right"
+                                      "3pc"
+                                      (document (small (document (surround (concat (with "font-shape" "small-caps" (abstract-text)) ". ")
+                                                                   ""
+                                                                   (arg "body")
+                                                                 ) ;surround
+                                                       ) ;document
+                                                ) ;small
+                                      ) ;document
+                                    ) ;with
+                          ) ;document
+                        ) ;padded-normal
+              ) ;document
+            ) ;macro
+          ) ;assign
+          ""
+          (assign "AMS-class-text"
+            (macro (localize "Mathematics Subject Classification"))
+          ) ;assign
+          (assign "keywords-text" (macro (localize "Key words and phrases")))
+          (assign "abstract-acm"
+            (xmacro "args"
+              (concat (em (ACM-class-text)) ". " (concat-tuple (quote-arg "args") "; "))
+            ) ;xmacro
+          ) ;assign
+          (assign "abstract-arxiv"
+            (xmacro "args"
+              (concat (em (arXiv-class-text))
+                ". "
+                (concat-tuple (map "arxiv-ref" (quote-arg "args")) "; ")
+              ) ;concat
+            ) ;xmacro
+          ) ;assign
+          (assign "abstract-msc"
+            (xmacro "args"
+              (concat "1991 "
+                (em (AMS-class-text))
+                ". "
+                (concat-tuple (map "msc-ref" (quote-arg "args")) "; ")
+              ) ;concat
+            ) ;xmacro
+          ) ;assign
+          (assign "abstract-pacs"
+            (xmacro "args"
+              (concat (em (PACS-class-text)) ". " (concat-tuple (quote-arg "args") "; "))
+            ) ;xmacro
+          ) ;assign
+          (assign "abstract-keywords"
+            (xmacro "args"
+              (concat (em (keywords-text)) ". " (concat-tuple (quote-arg "args") ", "))
+            ) ;xmacro
+          ) ;assign
+          ""
+          (assign "render-abstract*"
+            (macro "body"
+              "note"
+              (document (quasi (document (render-abstract (document (surround (render-plain-footnote ,(quote-arg "note"))
+                                                                      ""
+                                                                      (document ,(quote-arg "body"))
+                                                                    ) ;surround
+                                                          ) ;document
+                                         ) ;render-abstract
+                               ) ;document
+                        ) ;quasi
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (active* (document (src-comment (document "Headers."))))
+          (assign "header-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (concat (simple-page)
+                  (assign "page-odd-header"
+                    (with "font-size"
+                      "0.707"
+                      (style-with "src-compact"
+                        "none"
+                        (concat (no-indent)
+                          (htab "0mm")
+                          (change-case (arg "name") "UPCASE")
+                          (htab "5mm")
+                          (page-number)
+                        ) ;concat
+                      ) ;style-with
+                    ) ;with
+                  ) ;assign
+                ) ;concat
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "header-author"
+            (macro "name"
+              (assign "page-even-header"
+                (with "font-size"
+                  "0.707"
+                  (style-with "src-compact"
+                    "none"
+                    (concat (no-indent)
+                      (page-number)
+                      (htab "5mm")
+                      (change-case (arg "name") "UPCASE")
+                      (htab "0mm")
+                    ) ;concat
+                  ) ;style-with
+                ) ;with
+              ) ;assign
+            ) ;macro
+          ) ;assign
+          (assign "header-primary" (macro "name" "nr" "what" ""))
+          (assign "header-secondary" (macro "name" "nr" "what" ""))
+          (assign "simple-page"
+            (macro (style-with "src-compact"
+                     "none"
+                     (concat (assign "page-this-header" "")
+                       (assign "page-this-footer"
+                         (concat (no-indent)
+                           (htab "5mm")
+                           (with "font-size" "0.707" (page-number))
+                           (htab "5mm")
+                         ) ;concat
+                       ) ;assign
+                     ) ;concat
+                   ) ;style-with
+            ) ;macro
+          ) ;assign
+          (active* (document (src-comment (document "Sections."))))
+          (assign "sectional-sep" (macro (concat "." (space "2spc"))))
+          (assign "sectional-post-sep" (macro ". "))
+          (assign "part-post-sep" (macro ""))
+          (assign "chapter-post-sep" (macro ""))
+          (assign "section-post-sep" (macro ""))
+          (assign "enrich-subsection-long" "false")
+          (assign "enrich-subsubsection-long" "false")
+          ""
+          (assign "sectional-normal"
+            (macro "name" (wide-normal (concat (arg "name") (no-page-break))))
+          ) ;assign
+          (assign "sectional-centered"
+            (macro "name" (wide-centered (concat (arg "name") (no-page-break))))
+          ) ;assign
+          (assign "part-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-normal-bold (concat (vspace* (tmlen "1bls" "1bls" "2bls")) (arg "name") (vspace "0.5bls"))
+                ) ;sectional-normal-bold
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "chapter-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-centered-bold (concat (vspace* (tmlen "1bls" "1bls" "2bls")) (arg "name") (vspace "0.5bls"))
+                ) ;sectional-centered-bold
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "section-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-centered (concat (vspace* (tmlen "0.7bls" "0.7bls" "1.7bls"))
+                                      (with "font-shape" "small-caps" (arg "name"))
+                                      (vspace "0.5bls")
+                                    ) ;concat
+                ) ;sectional-centered
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (active* (document (src-comment (document "Subections and subsubsections."))))
+          (assign "subsection-title"
+            (macro "name"
+              (with "sectional-prefixed"
+                (macro "prefix"
+                  "name"
+                  (prefixed-line (with "font-series" "medium" (arg "prefix")) (arg "name"))
+                ) ;macro
+                (style-with "src-compact"
+                  "none"
+                  (sectional-short-bold (concat (vspace* (tmlen "0.5bls" "0.5bls" "1.2bls")) (arg "name"))
+                  ) ;sectional-short-bold
+                ) ;style-with
+              ) ;with
+            ) ;macro
+          ) ;assign
+          (assign "subsubsection-title"
+            (macro "name"
+              (with "sectional-prefixed"
+                (macro "prefix"
+                  "name"
+                  (prefixed-line (with "font-shape" "right" (arg "prefix")) (arg "name"))
+                ) ;macro
+                (style-with "src-compact"
+                  "none"
+                  (sectional-short-italic (concat (vspace* (tmlen "0.5bls" "0.5bls" "1.2bls")) (arg "name"))
+                  ) ;sectional-short-italic
+                ) ;style-with
+              ) ;with
+            ) ;macro
+          ) ;assign
+          (active* (document (src-comment (document "Paragraphs."))))
+          (assign "paragraph-title" (macro "name" (sectional-short (arg "name"))))
+          (assign "subparagraph-title" (macro "name" (sectional-short (arg "name"))))
+          (active* (document (src-comment (document "Bibliographies."))))
+          (assign "transform-bibitem" (macro "body" (concat "[" (arg "body") "] ")))
+          (active* (document (src-comment (document "Theorems."))))
+          (assign "large-padding-above" "0.6666fn")
+          (assign "large-padding-below" "0.6666fn")
+          (assign "remark-name" (macro "name" (with "font-shape" "italic" (arg "name"))))
+        ) ;document
+  ) ;body
+  (initial (collection (associate "preamble" "true")))
+) ;document
diff --git a/TeXmacs/plugins/latex/styles/article/AMS/amsart.ts b/TeXmacs/plugins/latex/styles/article/AMS/amsart.ts
deleted file mode 100644
index 19d349b354..0000000000
--- a/TeXmacs/plugins/latex/styles/article/AMS/amsart.ts
+++ /dev/null
@@ -1,269 +0,0 @@
-
-
-
-
-<\body>
-  <\active*>
-    <\src-title>
-      
-
-      <\src-purpose>
-        The amsart style.
-      
-
-      <\src-copyright|2002--2004>
-        Joris van der Hoeven
-      
-
-      <\src-license>
-        This software falls under the . It comes WITHOUT ANY
-        WARRANTY WHATSOEVER. You should have received a copy of the license
-        which the software. If not, see .
-      
-    
-  
-
-  
-
-  <\active*>
-    <\src-comment>
-      Global style parameters.
-    
-  
-
-  >
-
-  >|2>|1.5in>|1in>>>
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  
-
-  <\active*>
-    <\src-comment>
-      Footnotes for titles and abstracts.
-    
-  
-
-  
-    <\style-with|src-compact|none>
-      |dummy||>>>>
-    
-  >>>
-
-  <\active*>
-    <\src-comment>
-      Titles.
-    
-  
-
-  |UPCASE>>>>
-
-  
-    \;
-
-    <\surround||1bls>>|>
-      >>
-    
-  >
-
-  >|||UPCASE>>>>>>
-
-  \;
-
-  >>
-
-  >>
-
-  >>
-
-  >>
-
-  >
-  ||>>>
-
-  >
-  ||>>>
-
-  >|,
-  >>>>
-
-  >>
-
-  >>>
-
-  >
-  ||>>>>
-
-  >
-  ||>>>>
-
-  >
-  ||>>>
-
-  >>
-
-  \;
-
-  |>>>
-
-  <\active*>
-    <\src-comment>
-      Abstracts.
-    
-  
-
-  
-    <\padded-normal|20pt|20pt>
-      <\with|par-left|3pc|par-right|3pc>
-        <\small>
-          >.
-          ||>
-        
-      
-    
-  >
-
-  \;
-
-  >>
-
-  >>
-
-  >.
-  |; >>>
-
-  >.
-  >|; >>>
-
-  >.
-  >|; >>>
-
-  >.
-  |; >>>
-
-  >.
-  |, >>>
-
-  \;
-
-  
-    <\quasi>
-      <\render-abstract>
-        <\surround|>>|>
-          >
-        
-      
-    
-  >
-
-  <\active*>
-    <\src-comment>
-      Headers.
-    
-  
-
-  |UPCASE>>>>>>>
-
-  |UPCASE>>>>>>
-
-  >
-
-  >
-
-  >>>>>
-
-  <\active*>
-    <\src-comment>
-      Sections.
-    
-  
-
-  >>
-
-  >
-
-  >
-
-  >
-
-  >
-
-  
-
-  
-
-  \;
-
-  >>>
-
-  >>>
-
-  >>>>>
-
-  >>>>>
-
-  >>>>>>
-
-  <\active*>
-    <\src-comment>
-      Subections and subsubsections.
-    
-  
-
-  >|>>|>>>>>>
-
-  >|>>|>>>>>>
-
-  <\active*>
-    <\src-comment>
-      Paragraphs.
-    
-  
-
-  >>>
-
-  >>>
-
-  <\active*>
-    <\src-comment>
-      Bibliographies.
-    
-  
-
-  ] >>
-
-  <\active*>
-    <\src-comment>
-      Theorems.
-    
-  
-
-  
-
-  
-
-  >>>
-
-
-<\initial>
-  <\collection>
-    
-  
-
\ No newline at end of file
diff --git a/TeXmacs/plugins/latex/styles/article/IEEE/ieeeconf.stem b/TeXmacs/plugins/latex/styles/article/IEEE/ieeeconf.stem
new file mode 100644
index 0000000000..f673f2dd06
--- /dev/null
+++ b/TeXmacs/plugins/latex/styles/article/IEEE/ieeeconf.stem
@@ -0,0 +1,117 @@
+(document (TeXmacs "2.1.2")
+  (style "source")
+  (body (document (active* (document (src-title (document (src-style-file "ieeeconf" "0.1")
+                                                  (src-purpose (document "The IEEEconf style."))
+                                                  (src-copyright "2013" (document "Franois Poulain, Joris van der Hoeven"))
+                                                  (src-license (document (concat "This software falls under the "
+                                                                           (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE")
+                                                                           ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see "
+                                                                           (hlink "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                             "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                           ) ;hlink
+                                                                           "."
+                                                                         ) ;concat
+                                                               ) ;document
+                                                  ) ;src-license
+                                                ) ;document
+                                     ) ;src-title
+                           ) ;document
+                  ) ;active*
+          (use-package "article" "std-latex" "two-columns")
+          (active* (src-comment "Global style parameters"))
+          (assign "par-sep" "0.2fn")
+          (assign "par-ver-sep" "0.1fn")
+          (active* (src-comment "Global layout parameters"))
+          (assign "tex-odd-side-margin" (macro "-.304in"))
+          (assign "tex-even-side-margin" (macro "-.304in"))
+          (assign "tex-text-width" (macro "6.875in"))
+          (assign "tex-top-margin" (macro "0in"))
+          (assign "tex-head-height" (macro "0in"))
+          (assign "tex-text-height" (macro "8.875in"))
+          (assign "tex-column-sep" (macro "0.3125in"))
+          (assign "par-first" (macro "0.25in"))
+          (active* (document (src-comment (document "Title."))))
+          (assign "doc-make-title"
+            (macro "body"
+              (document (with "par-columns"
+                          "1"
+                          (document (surround "" (right-flush) (document (doc-title-block (arg "body")) "" ""))
+                          ) ;document
+                        ) ;with
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "by-text" (macro ""))
+          (assign "author-name"
+            (macro "author" (doc-author-block (author-by (arg "author"))))
+          ) ;assign
+          (assign "author-email"
+            (macro "email"
+              (doc-author-block (concat (with "font-shape" "italic" (concat (email-text) (localize ":") " "))
+                                  " "
+                                  (arg "email")
+                                ) ;concat
+              ) ;doc-author-block
+            ) ;macro
+          ) ;assign
+          (assign "author-email-note"
+            (macro "sym"
+              "id"
+              "email"
+              (doc-author-block (doc-note-text (arg "sym")
+                                  (arg "id")
+                                  (concat (with "font-shape" "italic" (concat (email-text) (localize ":") " "))
+                                    (arg "email")
+                                  ) ;concat
+                                ) ;doc-note-text
+              ) ;doc-author-block
+            ) ;macro
+          ) ;assign
+          (active* (document (src-comment (document "Abstract."))))
+          (assign "render-abstract"
+            (macro "body"
+              (document (concat (sectional-centered-bold (abstract-text)) (vspace "0.5fn"))
+                (with "font-shape" "italic" (document (arg "body")))
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "render-abstract*"
+            (macro "body"
+              "note"
+              (document (quasi (document (render-abstract (document (surround "" (vspace "0.5fn") ,(quote-arg "body"))
+                                                            (with "par-par-sep"
+                                                              "0.25fn"
+                                                              "font-shape"
+                                                              "right"
+                                                              (document (unquote* (arg "note")))
+                                                            ) ;with
+                                                          ) ;document
+                                         ) ;render-abstract
+                               ) ;document
+                        ) ;quasi
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (active* (document (src-comment (document "Headers."))))
+          (assign "header-title"
+            (macro "name"
+              (concat (assign "page-odd-header" "") (assign "page-even-header" ""))
+            ) ;macro
+          ) ;assign
+          (assign "header-author"
+            (macro "name"
+              (concat (assign "page-odd-header" "") (assign "page-even-header" ""))
+            ) ;macro
+          ) ;assign
+          (assign "header-primary" (macro "name" "nr" "what" ""))
+          (assign "header-secondary" (macro "name" "nr" "what" ""))
+          (active* (document (src-comment (document "Sections."))))
+          (assign "sectional-sep" (macro (concat "." (space "2spc"))))
+          (assign "sectional-post-sep" (macro (space "2spc")))
+          (assign "sectional-no-indent" (macro ""))
+          (active* (document (src-comment (document "Lists."))))
+          (assign "transform-bibitem" (macro "body" (concat "[" (arg "body") "] ")))
+        ) ;document
+  ) ;body
+  (initial (collection (associate "preamble" "true")))
+) ;document
diff --git a/TeXmacs/plugins/latex/styles/article/IEEE/ieeeconf.ts b/TeXmacs/plugins/latex/styles/article/IEEE/ieeeconf.ts
deleted file mode 100644
index 14a80d4443..0000000000
--- a/TeXmacs/plugins/latex/styles/article/IEEE/ieeeconf.ts
+++ /dev/null
@@ -1,146 +0,0 @@
-
-
-
-
-<\body>
-  <\active*>
-    <\src-title>
-      
-
-      <\src-purpose>
-        The IEEEconf style.
-      
-
-      <\src-copyright|2013>
-        Franois Poulain, Joris van der Hoeven
-      
-
-      <\src-license>
-        This software falls under the . It comes WITHOUT ANY
-        WARRANTY WHATSOEVER. You should have received a copy of the license
-        which the software. If not, see .
-      
-    
-  
-
-  
-
-  >
-
-  
-
-  
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  <\active*>
-    <\src-comment>
-      Title.
-    
-  
-
-  
-    <\with|par-columns|1>
-      <\surround||>
-        >
-
-        \;
-
-        \;
-      
-    
-  >
-
-  >
-
-  >>>>
-
-  
-  > >>>
-
-  ||
-  >>>>>
-
-  <\active*>
-    <\src-comment>
-      Abstract.
-    
-  
-
-  
-    >
-
-    <\with|font-shape|italic>
-      
-    
-  >
-
-  
-    <\quasi>
-      <\render-abstract>
-        |>>
-
-        <\with|par-par-sep|0.25fn|font-shape|right>
-          >
-        
-      
-    
-  >
-
-  <\active*>
-    <\src-comment>
-      Headers.
-    
-  
-
-  >>
-
-  >>
-
-  >
-
-  >
-
-  <\active*>
-    <\src-comment>
-      Sections.
-    
-  
-
-  >>
-
-  >>
-
-  >
-
-  <\active*>
-    <\src-comment>
-      Lists.
-    
-  
-
-  ] >>
-
-
-<\initial>
-  <\collection>
-    
-  
-
\ No newline at end of file
diff --git a/TeXmacs/plugins/latex/styles/article/IEEE/ieeetran.stem b/TeXmacs/plugins/latex/styles/article/IEEE/ieeetran.stem
new file mode 100644
index 0000000000..c6140a5dcf
--- /dev/null
+++ b/TeXmacs/plugins/latex/styles/article/IEEE/ieeetran.stem
@@ -0,0 +1,165 @@
+(document (TeXmacs "2.1.2")
+  (style "source")
+  (body (document (active* (document (src-title (document (src-style-file "ieeetran" "0.1")
+                                                  (src-purpose (document "The IEEEtran style."))
+                                                  (src-copyright "2013" (document "Franois Poulain, Joris van der Hoeven"))
+                                                  (src-license (document (concat "This software falls under the "
+                                                                           (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE")
+                                                                           ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see "
+                                                                           (hlink "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                             "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                           ) ;hlink
+                                                                           "."
+                                                                         ) ;concat
+                                                               ) ;document
+                                                  ) ;src-license
+                                                ) ;document
+                                     ) ;src-title
+                           ) ;document
+                  ) ;active*
+          (use-package "article" "std-latex" "two-columns")
+          (active* (src-comment "Global style parameters"))
+          (assign "par-sep" "0.2fn")
+          (assign "par-ver-sep" "0.1fn")
+          (active* (src-comment "Global layout parameters"))
+          (assign "tex-text-width" (macro "43pc"))
+          (assign "tex-head-height" (macro "12pt"))
+          (assign "tex-foot-skip" (macro "0.4in"))
+          (assign "tex-column-sep" (macro "1pc"))
+          (assign "tex-margin-par-width" (macro "20pt"))
+          (assign "tex-above-display-skip" (macro (tex-len "1.5ex" "3pt" "1pt")))
+          (assign "tex-below-display-skip" (macro (tex-len "1.5ex" "3pt" "1pt")))
+          (assign "tex-above-display-short-skip" (macro (tex-len "1.5ex" "3pt" "1pt")))
+          (assign "tex-below-display-short-skip" (macro (tex-len "0pt" "3pt" "0pt")))
+          (assign "par-first" (macro "1.0em"))
+          (active* (document (src-comment (document "Title."))))
+          (assign "doc-title-name" (macro "x" (arg "x")))
+          (assign "doc-title"
+            (macro "x"
+              (surround (vspace* "0.5fn")
+                (vspace "0.5fn")
+                (document (doc-title-block (font-magnify "2" (doc-title-name (arg "x")))))
+              ) ;surround
+            ) ;macro
+          ) ;assign
+          (assign "doc-make-title"
+            (macro "body"
+              (document (with "par-columns"
+                          "1"
+                          (document (surround "" (right-flush) (document (doc-title-block (arg "body")) "" ""))
+                          ) ;document
+                        ) ;with
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "by-text" (macro ""))
+          (assign "author-name"
+            (macro "author" (doc-author-block (author-by (arg "author"))))
+          ) ;assign
+          (assign "author-email"
+            (macro "email"
+              (doc-author-block (concat (with "font-shape" "italic" (concat (email-text) (localize ":") " "))
+                                  " "
+                                  (arg "email")
+                                ) ;concat
+              ) ;doc-author-block
+            ) ;macro
+          ) ;assign
+          (assign "author-email-note"
+            (macro "sym"
+              "id"
+              "email"
+              (doc-author-block (doc-note-text (arg "sym")
+                                  (arg "id")
+                                  (concat (with "font-shape" "italic" (concat (email-text) (localize ":") " "))
+                                    (arg "email")
+                                  ) ;concat
+                                ) ;doc-note-text
+              ) ;doc-author-block
+            ) ;macro
+          ) ;assign
+          (active* (document (src-comment (document "Abstract."))))
+          (assign "render-abstract"
+            (macro "body"
+              (document (flat-size (document (with "font-series"
+                                               "bold"
+                                               (document (surround (concat (em (abstract-text)) "\x16;") "" (arg "body")))
+                                             ) ;with
+                                   ) ;document
+                        ) ;flat-size
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "render-classify"
+            (macro "scheme" "text" (concat (em (arg "scheme")) "\x16;" (arg "text")))
+          ) ;assign
+          (assign "keywords-text" (macro (localize "Index terms")))
+          (active* (document (src-comment (document "Headers."))))
+          (assign "header-title"
+            (macro "name"
+              (concat (assign "page-odd-header" "") (assign "page-even-header" ""))
+            ) ;macro
+          ) ;assign
+          (assign "header-author"
+            (macro "name"
+              (concat (assign "page-odd-header" "") (assign "page-even-header" ""))
+            ) ;macro
+          ) ;assign
+          (assign "header-primary" (macro "name" "nr" "what" ""))
+          (assign "header-secondary" (macro "name" "nr" "what" ""))
+          (active* (document (src-comment (document "Sections"))))
+          (assign "sectional-sep" (macro (concat "." (space "2spc"))))
+          (assign "sectional-post-sep" (macro (space "2spc")))
+          (assign "sectional-no-indent" (macro ""))
+          (assign "the-section" (macro (number (section-nr) "Roman")))
+          (assign "the-subsection" (macro (number (subsection-nr) "Alpha")))
+          (assign "the-subsubsection" (macro (number (subsection-nr) "roman")))
+          (assign "the-paragraph" (macro (number (subsection-nr) "alpha")))
+          (assign "section-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-centered (concat (vspace* (tex-len "1.5ex" "1.5ex" "0.5ex"))
+                                      (with "font-shape" "small-caps" (arg "name"))
+                                      (vspace (tex-len "0.7ex" "1ex" "0ex"))
+                                    ) ;concat
+                ) ;sectional-centered
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "subsection-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-normal-italic (concat (vspace* (tex-len "1.5ex" "1.5ex" "0.5ex"))
+                                           (arg "name")
+                                           (vspace (tex-len "0.7ex" "0.5ex" "0ex"))
+                                         ) ;concat
+                ) ;sectional-normal-italic
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "subsubsection-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-normal-italic (concat (vspace* (tex-len "0ex" "0.1ex" "0.1ex")) (arg "name"))
+                ) ;sectional-normal-italic
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "paragraph-title" (value "subsubsection-title"))
+          (assign "subparagraph-title" (value "subsubsection-title"))
+          (active* (src-comment "Lists"))
+          (assign "item-1" (macro (active* (with "mode" "math" ""))))
+          (assign "item-2" (macro (active* (with "mode" "math" (rigid "-")))))
+          (assign "item-3" (macro (math "")))
+          (assign "item-4" (macro (math "")))
+          (assign "itemize-reduce" (macro "nr" (minimum (arg "nr") "4")))
+          (assign "enumerate-reduce" (macro "nr" (minimum (arg "nr") "4")))
+          (assign "transform-bibitem" (macro "body" (concat "[" (arg "body") "] ")))
+          ""
+        ) ;document
+  ) ;body
+  (initial (collection (associate "preamble" "true")))
+) ;document
diff --git a/TeXmacs/plugins/latex/styles/article/IEEE/ieeetran.ts b/TeXmacs/plugins/latex/styles/article/IEEE/ieeetran.ts
deleted file mode 100644
index 1edd428ec8..0000000000
--- a/TeXmacs/plugins/latex/styles/article/IEEE/ieeetran.ts
+++ /dev/null
@@ -1,176 +0,0 @@
-
-
-
-
-<\body>
-  <\active*>
-    <\src-title>
-      
-
-      <\src-purpose>
-        The IEEEtran style.
-      
-
-      <\src-copyright|2013>
-        Franois Poulain, Joris van der Hoeven
-      
-
-      <\src-license>
-        This software falls under the . It comes WITHOUT ANY
-        WARRANTY WHATSOEVER. You should have received a copy of the license
-        which the software. If not, see .
-      
-    
-  
-
-  
-
-  >
-
-  
-
-  
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >>
-
-  >>
-
-  >>
-
-  >>
-
-  >
-
-  <\active*>
-    <\src-comment>
-      Title.
-    
-  
-
-  >>
-
-  |>
-    >>>
-  >>
-
-  
-    <\with|par-columns|1>
-      <\surround||>
-        >
-
-        \;
-
-        \;
-      
-    
-  >
-
-  >
-
-  >>>>
-
-  
-  > >>>
-
-  ||
-  >>>>>
-
-  <\active*>
-    <\src-comment>
-      Abstract.
-    
-  
-
-  
-    <\flat-size>
-      <\with|font-series|bold>
-        >\V||>
-      
-    
-  >
-
-  >\V>>
-
-  >>
-
-  <\active*>
-    <\src-comment>
-      Headers.
-    
-  
-
-  >>
-
-  >>
-
-  >
-
-  >
-
-  <\active*>
-    <\src-comment>
-      Sections
-    
-  
-
-  >>
-
-  >>
-
-  >
-
-  |Roman>>>
-
-  |Alpha>>>
-
-  |roman>>>
-
-  |alpha>>>
-
-  >>>>>>>
-
-  >>>>>>
-
-  >>>>>
-
-  >
-
-  >
-
-  >
-
-  >>>>
-
-  >>>>
-
-  >>>
-
-  >>>
-
-  |4>>>
-
-  |4>>>
-
-  ] >>
-
-  \;
-
-
-<\initial>
-  <\collection>
-    
-  
-
\ No newline at end of file
diff --git a/TeXmacs/plugins/latex/styles/article/elsevier/elsarticle.stem b/TeXmacs/plugins/latex/styles/article/elsevier/elsarticle.stem
new file mode 100644
index 0000000000..bee15b1657
--- /dev/null
+++ b/TeXmacs/plugins/latex/styles/article/elsevier/elsarticle.stem
@@ -0,0 +1,430 @@
+(document (TeXmacs "1.99.19")
+  (style "source")
+  (body (document (active* (document (src-title (document (src-style-file "elsarticle" "1.0")
+                                                  (src-purpose (document "The elsarticle style."))
+                                                  (src-copyright "2002--2004" (document "Franois Poulain, Joris van der Hoeven"))
+                                                  (src-license (document (concat "This software falls under the "
+                                                                           (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE")
+                                                                           ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see "
+                                                                           (hlink "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                             "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                           ) ;hlink
+                                                                           "."
+                                                                         ) ;concat
+                                                               ) ;document
+                                                  ) ;src-license
+                                                ) ;document
+                                     ) ;src-title
+                           ) ;document
+                  ) ;active*
+          (use-package "std" "env" "title-generic" "header-article"
+            "section-article" "std-latex" "cite-author-year" "html-font-size"
+          ) ;use-package
+          (active* (src-comment (document "TeX-like style parameters.")))
+          (assign "tex-odd-side-margin"
+            (macro (if (equal (value "par-columns") "1") "20pt" "20pt"))
+          ) ;assign
+          (assign "tex-even-side-margin"
+            (macro (if (equal (value "par-columns") "1") "20pt" "20pt"))
+          ) ;assign
+          (assign "tex-text-width"
+            (macro (if (equal (value "par-columns") "1") "33pc" "33pc"))
+          ) ;assign
+          ""
+          (assign "tex-top-margin" (macro "0pt"))
+          (assign "tex-head-height" (macro "0pt"))
+          (assign "tex-head-sep" (macro "10pt"))
+          (assign "tex-top-skip" (macro "12pt"))
+          (assign "tex-text-height"
+            (macro (if (equal (value "par-columns") "1") "651pt" "651pt"))
+          ) ;assign
+          (assign "tex-foot-height-heuristic" (macro "1em"))
+          (assign "tex-foot-skip" (macro "40pt"))
+          ""
+          (assign "tex-footnote-sep" (macro "8.4pt"))
+          (assign "tex-footnote-tm-barlen" (macro "3pc"))
+          (assign "tex-column-sep" (macro "2pc"))
+          (assign "tex-float-sep" (macro (tmlen "6pt" "8pt" "12pt")))
+          (assign "tex-margin-par-width"
+            (macro (if (equal (value "par-columns") "1") "10pt" "2pc"))
+          ) ;assign
+          (assign "tex-margin-par-sep" (macro "20pt"))
+          (active* (src-comment (document "Global layout.")))
+          (assign "font-base-size" "12")
+          (assign "par-par-sep" "14.5pt")
+          (assign "par-first" "0fn")
+          (assign "padded-par-par-sep" "14.5pt")
+          (assign "indent-par-first" "1.5fn")
+          ""
+          (assign "tex-jot" (macro "2pt"))
+          (assign "tex-math-indent"
+            (macro (if (equal (value "par-columns") "1") "2em" "0em"))
+          ) ;assign
+          (assign "tex-above-display-skip" (macro (tex-len "12pt" "2pt" "2pt")))
+          (assign "tex-below-display-skip" (macro (tex-len "12pt" "2pt" "2pt")))
+          (assign "tex-above-display-short-skip" (macro (tex-len "0pt" "2pt" "0pt")))
+          (assign "tex-below-display-short-skip" (macro (tex-len "3.5pt" "2pt" "2pt")))
+          (active* (src-comment (document "Headers and footers.")))
+          (set-header "")
+          (set-footer (concat (htab "5mm") (page-number) (htab "5mm")))
+          (assign "header-title" (macro "name" ""))
+          (assign "header-author" (macro "name" ""))
+          (assign "header-primary" (macro "name" "nr" "what" ""))
+          (assign "header-secondary" (macro "name" "nr" "what" ""))
+          (active* (src-comment (document "Sizes.")))
+          (assign "tiny"
+            (macro "x" (with "font-size" (over "6" "12") "par-sep" "1pt" (arg "x")))
+          ) ;assign
+          (assign "very-small"
+            (macro "x" (with "font-size" (over "8" "12") "par-sep" "1.5pt" (arg "x")))
+          ) ;assign
+          (assign "small"
+            (macro "x"
+              (style-with "src-compact"
+                "none"
+                (with "font-size"
+                  (over "11" "12")
+                  "par-sep"
+                  "2.6pt"
+                  "tex-above-display-skip"
+                  (macro (tex-len "11pt" "3pt" "6pt"))
+                  "tex-below-display-skip"
+                  (macro (tex-len "11pt" "3pt" "6pt"))
+                  "tex-above-display-short-skip"
+                  (macro (tex-len "0pt" "3pt" "0pt"))
+                  "tex-below-display-short-skip"
+                  (macro (tex-len "6.5pt" "3.5pt" "3pt"))
+                  (arg "x")
+                ) ;with
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "normal-size"
+            (macro "x"
+              (style-with "src-compact"
+                "none"
+                (with "font-size"
+                  (over "12" "12")
+                  "par-sep"
+                  "0.2em"
+                  "tex-above-display-skip"
+                  (macro (tex-len "12pt" "2pt" "2pt"))
+                  "tex-below-display-skip"
+                  (macro (tex-len "12pt" "2pt" "2pt"))
+                  "tex-above-display-short-skip"
+                  (macro (tex-len "0pt" "2pt" "0pt"))
+                  "texs-below-display-short-skip"
+                  (macro (tex-len "3.5pt" "2pt" "2pt"))
+                  (arg "x")
+                ) ;with
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "large"
+            (macro "x" (with "font-size" (over "14" "12") "par-sep" "4pt" (arg "x")))
+          ) ;assign
+          (assign "larger"
+            (macro "x" (with "font-size" (over "17" "12") "par-sep" "5pt" (arg "x")))
+          ) ;assign
+          (assign "very-large"
+            (macro "x" (with "font-size" (over "20" "12") "par-sep" "2pt" (arg "x")))
+          ) ;assign
+          (assign "huge"
+            (macro "x" (with "font-size" (over "25" "12") "par-sep" "2pt" (arg "x")))
+          ) ;assign
+          (assign "really-huge" (macro "x" (huge (arg "x"))))
+          (active* (src-comment (document "Sectional macros.")))
+          (assign "section-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-normal-bold (concat (vspace* (tmlen "1.7bls" "1.6bls" "2.1bls"))
+                                         (normal-size (arg "name"))
+                                         (vspace "1bls")
+                                       ) ;concat
+                ) ;sectional-normal-bold
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "subsection-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-normal-italic (concat (vspace* (tmlen "0.9bls" "1bls" "1.3bls"))
+                                           (normal-size (arg "name"))
+                                           (vspace "1bls")
+                                         ) ;concat
+                ) ;sectional-normal-italic
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "subsubsection-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-normal-italic (concat (vspace* (tmlen "1bls" "1bls" "1.2bls")) (normal-size (arg "name")))
+                ) ;sectional-normal-italic
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "paragraph-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-short-bold (concat (vspace* (tmlen "3.05ex" "3.25ex" "5.25ex"))
+                                        (normal-size (arg "name"))
+                                        (space "1em")
+                                      ) ;concat
+                ) ;sectional-short-bold
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (active* (src-comment (document "Section and environment numbering.")))
+          (assign "sectional-sep" (macro (space "1.1fn")))
+          (assign "subparagraph-title" (macro "name" (paragraph-title (arg "name"))))
+          (assign "section-clean" (macro (reset-subsection)))
+          (assign "display-std-env" (macro "nr" (arg "nr")))
+          (assign "paragraph-display-numbers" (macro "true"))
+          (assign "subparagraph-display-numbers" (macro "true"))
+          (active* (src-comment (document "Theorem-like environments.")))
+          (assign "enunciation-name"
+            (macro "name" (with "font-series" "bold" (arg "name")))
+          ) ;assign
+          (assign "enunciation-sep" (space "1em"))
+          (assign "remark-name" (macro "name" (with "font-shape" "italic" (arg "name"))))
+          (new-theorem "claim" (localize "Claim"))
+          (new-theorem "fact" (localize "Fact"))
+          (new-theorem "hypothesis" (localize "Hypothesis"))
+          (new-theorem "assumption" (localize "Assumption"))
+          (new-theorem "criterion" (localize "Criterion"))
+          (new-theorem "principle" (localize "Principle"))
+          (active* (src-comment (document "Customization of other environments.")))
+          (assign "figure-text" (macro (localize "Fig.")))
+          (assign "bibliography-text" (macro (localize "References")))
+          (assign "table-of-contents-text" (macro (localize "Table of Contents")))
+          (assign "list-of-figures-text" (macro (localize "List of Figures")))
+          (assign "list-of-tables-text" (macro (localize "List of Tables")))
+          (active* (document (src-comment (document "List environments."))))
+          (assign "aligned-item"
+            (macro "x"
+              (style-with "src-compact"
+                "none"
+                (concat (vspace* "0.0fn")
+                  (with "par-first" "-2.5em" (yes-indent))
+                  (resize (arg "x") (minus "1r" "2.2em") "" "" "")
+                  (hspace "0.3em")
+                ) ;concat
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "render-list"
+            (macro "body"
+              (surround (no-page-break*)
+                (concat (right-flush) (no-indent*))
+                (with "par-left"
+                  (plus (value "par-left") "1.5em")
+                  "par-sep"
+                  "0.2fn"
+                  "par-par-sep"
+                  "0fn"
+                  (arg "body")
+                ) ;with
+              ) ;surround
+            ) ;macro
+          ) ;assign
+          ""
+          (assign "item-1" (macro (active* (with "mode" "math" ""))))
+          (assign "item-2" (macro (active* (with "mode" "math" (rigid "")))))
+          (assign "item-3" (macro ""))
+          (active* (document (src-comment (document "Bibliographies."))))
+          (assign "bibitem-width" "2em")
+          (assign "transform-bibitem" (macro "body" (concat "[" (arg "body") "] ")))
+          (assign "elsart-bibitem*"
+            (macro "text"
+              (style-with "src-compact"
+                "none"
+                (concat (assign "bibitem-nr" (plus (value "bibitem-nr") "1"))
+                  (render-bibitem (transform-bibitem (value "bibitem-nr")))
+                  (set-binding (value "bibitem-nr"))
+                ) ;concat
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "render-bibliography"
+            (macro "name"
+              "body"
+              (document (concat (principal-section* (arg "name")) (yes-indent*))
+                (with "par-first" "0fn" "par-par-sep" "0fn" "font-size" "0.84" (arg "body"))
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "bib-list"
+            (macro "largest"
+              "body"
+              (document (description (document (with "par-left"
+                                                 "2em"
+                                                 "par-first"
+                                                 "0em"
+                                                 "font-size"
+                                                 "1"
+                                                 "bibitem-nr"
+                                                 "0"
+                                                 "xbibitem*"
+                                                 (value "elsart-bibitem*")
+                                                 (document (arg "body"))
+                                               ) ;with
+                                     ) ;document
+                        ) ;description
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (active* (src-comment (document "Title rendering.")))
+          (assign "doc-title"
+            (macro "x"
+              (surround (vspace* "0.5fn")
+                (vspace "0.5fn")
+                (document (doc-title-block (with "font-size" "1.414" (arg "x"))))
+              ) ;surround
+            ) ;macro
+          ) ;assign
+          (assign "by-text" (macro ""))
+          (assign "author-name"
+            (macro "author" (doc-author-block (author-by (arg "author"))))
+          ) ;assign
+          (assign "author-affiliation"
+            (macro "address"
+              (document (surround (vspace* "0.5fn")
+                          (vspace "0.5fn")
+                          (doc-author-block (smaller (em (arg "address"))))
+                        ) ;surround
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "author-email"
+            (macro "email"
+              (doc-author-block (smaller (concat (with "font-shape" "italic" (concat (email-text) (localize ":") " "))
+                                           " "
+                                           (verbatim (arg "email"))
+                                         ) ;concat
+                                ) ;smaller
+              ) ;doc-author-block
+            ) ;macro
+          ) ;assign
+          (assign "author-email-note"
+            (macro "sym"
+              "id"
+              "email"
+              (doc-author-block (smaller (doc-note-text (arg "sym")
+                                           (arg "id")
+                                           (concat (with "font-shape" "italic" (concat (email-text) (localize ":") " "))
+                                             (verbatim (arg "email"))
+                                           ) ;concat
+                                         ) ;doc-note-text
+                                ) ;smaller
+              ) ;doc-author-block
+            ) ;macro
+          ) ;assign
+          (active* (src-comment (document "Abstract.")))
+          (assign "render-abstract"
+            (macro "body"
+              (surround (vspace* "2fn")
+                (concat (right-flush) (vspace "1fn"))
+                (document (with "par-first"
+                            "10pt"
+                            "par-par-sep"
+                            "5pt"
+                            "font-size"
+                            (over "9" "12")
+                            (document (surround (concat (hrule) (next-line))
+                                        (concat (next-line) (hrule) (yes-indent))
+                                        (document (concat (no-indent)
+                                                    (with "font-series" "bold" (abstract-text))
+                                                    (vspace "5pt")
+                                                    (no-page-break)
+                                                  ) ;concat
+                                          (surround (no-indent) "" (arg "body"))
+                                        ) ;document
+                                      ) ;surround
+                            ) ;document
+                          ) ;with
+                ) ;document
+              ) ;surround
+            ) ;macro
+          ) ;assign
+          (assign "render-classify"
+            (macro "scheme"
+              "text"
+              (concat (no-indent)
+                (em (concat (arg "scheme") (localize ":")))
+                " "
+                (arg "text")
+              ) ;concat
+            ) ;macro
+          ) ;assign
+          (active* (src-comment (document "Specific macros for Elsevier styles.")))
+          (style-only (with "mode"
+                        "math"
+                        (document (assign "reduce"
+                                    (macro "x"
+                                      (resize (arg "x")
+                                        (plus "1l" "0.1fn")
+                                        (plus "1b" "0.15fn")
+                                        (minus "1r" "0.1fn")
+                                        (minus "1t" "0.15fn")
+                                      ) ;resize
+                                    ) ;macro
+                                  ) ;assign
+                          (assign "smfrac"
+                            (macro "x"
+                              "y"
+                              (with "math-display"
+                                "false"
+                                (style-with "src-compact"
+                                  "none"
+                                  (frac (move (reduce (arg "x")) "" "-0.175fn")
+                                    (move (reduce (arg "y")) "" "0.125fn")
+                                  ) ;frac
+                                ) ;style-with
+                              ) ;with
+                            ) ;macro
+                          ) ;assign
+                          ""
+                          (assign "half" (smfrac "1" "2"))
+                          (assign "threehalf" (smfrac "3" "2"))
+                          (assign "quart" (smfrac "1" "4"))
+                          ""
+                          (assign "d" "")
+                          (assign "e" "")
+                          ""
+                          (assign "Nset" "")
+                          (assign "Zset" "")
+                          (assign "Qset" "")
+                          (assign "Rset" "")
+                          (assign "Cset" "")
+                          (assign "Hset" "")
+                          ""
+                          (assign "nuc"
+                            (macro "nr" "el" (concat (lsup (arg "nr")) (with "mode" "text" (arg "el"))))
+                          ) ;assign
+                          (assign "vec" (macro "sym" (wide (arg "sym") "")))
+                          (assign "pol" (macro "sym" (wide (arg "sym") "")))
+                          (assign "FMslash" (macro "sym" (neg (arg "sym"))))
+                          (assign "FMSlash"
+                            (macro "sym"
+                              (neg (resize (arg "sym")
+                                     (minus "1l" "0.1fn")
+                                     (minus "1b" "0.1fn")
+                                     (plus "1r" "0.1fn")
+                                     (plus "1t" "0.1fn")
+                                   ) ;resize
+                              ) ;neg
+                            ) ;macro
+                          ) ;assign
+                        ) ;document
+                      ) ;with
+          ) ;style-only
+          ""
+        ) ;document
+  ) ;body
+  (initial (collection (associate "preamble" "true") (associate "sfactor" "7")))
+) ;document
diff --git a/TeXmacs/plugins/latex/styles/article/elsevier/elsarticle.ts b/TeXmacs/plugins/latex/styles/article/elsevier/elsarticle.ts
deleted file mode 100644
index ec30c74e7f..0000000000
--- a/TeXmacs/plugins/latex/styles/article/elsevier/elsarticle.ts
+++ /dev/null
@@ -1,340 +0,0 @@
-
-
-
-
-<\body>
-  <\active*>
-    <\src-title>
-      
-
-      <\src-purpose>
-        The elsarticle style.
-      
-
-      <\src-copyright|2002--2004>
-        Franois Poulain, Joris van der Hoeven
-      
-
-      <\src-license>
-        This software falls under the . It comes WITHOUT ANY
-        WARRANTY WHATSOEVER. You should have received a copy of the license
-        which the software. If not, see .
-      
-    
-  
-
-  
-
-  
-    TeX-like style parameters.
-  >
-
-  |1>|20pt|20pt>>>
-
-  |1>|20pt|20pt>>>
-
-  |1>|33pc|33pc>>>
-
-  \;
-
-  >
-
-  >
-
-  >
-
-  >
-
-  |1>|651pt|651pt>>>
-
-  >
-
-  >
-
-  \;
-
-  >
-
-  >
-
-  >
-
-  >>
-
-  |1>|10pt|2pc>>>
-
-  >
-
-  
-    Global layout.
-  >
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  \;
-
-  >
-
-  |1>|2em|0em>>>
-
-  >>
-
-  >>
-
-  >>
-
-  >>
-
-  
-    Headers and footers.
-  >
-
-  
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  
-    Sizes.
-  >
-
-  |par-sep|1pt|>>>
-
-  |par-sep|1.5pt|>>>
-
-  |par-sep|2.6pt|tex-above-display-skip|>|tex-below-display-skip|>|tex-above-display-short-skip|>|tex-below-display-short-skip|>|>>>>
-
-  |par-sep|0.2em|tex-above-display-skip|>|tex-below-display-skip|>|tex-above-display-short-skip|>|texs-below-display-short-skip|>|>>>>
-
-  |par-sep|4pt|>>>
-
-  |par-sep|5pt|>>>
-
-  |par-sep|2pt|>>>
-
-  |par-sep|2pt|>>>
-
-  >>>
-
-  
-    Sectional macros.
-  >
-
-  >>>>>>
-
-  >>>>>>
-
-  >>>>>>
-
-  >>>>>>
-
-  
-    Section and environment numbering.
-  >
-
-  >>
-
-  >>>
-
-  >>
-
-  >>
-
-  >
-
-  >
-
-  
-    Theorem-like environments.
-  >
-
-  >>>
-
-  >
-
-  >>>
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  
-    Customization of other environments.
-  >
-
-  >>
-
-  >>
-
-  >>
-
-  >>
-
-  >>
-
-  <\active*>
-    <\src-comment>
-      List environments.
-    
-  
-
-  >||||>>>>
-
-  |||1.5em>|par-sep|0.2fn|par-par-sep|0fn|>>>>
-
-  \;
-
-  >>>>
-
-  >>>>>
-
-  >
-
-  <\active*>
-    <\src-comment>
-      Bibliographies.
-    
-  
-
-  
-
-  ] >>
-
-  |1>>>>>>>>
-
-  
-    >
-
-    >
-  >
-
-  
-    <\description>
-      <\with|par-left|2em|par-first|0em|font-size|1|bibitem-nr|0|xbibitem*|>
-        
-      
-    
-  >
-
-  
-    Title rendering.
-  >
-
-  |>
-    >>
-  >>
-
-  >
-
-  >>>>
-
-  
-    ||>>>>
-  >
-
-  
-  > >>>>>
-
-  ||
-  >>>>>>>
-
-  
-    Abstract.
-  >
-
-  |>
-    <\with|par-first|10pt|par-par-sep|5pt|font-size|>
-      <\surround||>
-        >
-
-        ||>
-      
-    
-  >>
-
-  >
-  >>
-
-  
-    Specific macros for Elsevier styles.
-  >
-
-  
-    ||||>>>
-
-    >||-0.175fn>|>||0.125fn>>>>>>
-
-    \;
-
-    >
-
-    >
-
-    >
-
-    \;
-
-    >
-
-    >
-
-    \;
-
-    >
-
-    >
-
-    >
-
-    >
-
-    >
-
-    >
-
-    \;
-
-    >>>>
-
-    |\>>>
-
-    |\>>>
-
-    >>>
-
-    ||||>>>>
-  >
-
-  \;
-
-
-<\initial>
-  <\collection>
-    
-    
-  
-
\ No newline at end of file
diff --git a/TeXmacs/plugins/latex/styles/article/elsevier/ifac.stem b/TeXmacs/plugins/latex/styles/article/elsevier/ifac.stem
new file mode 100644
index 0000000000..83e7eeddae
--- /dev/null
+++ b/TeXmacs/plugins/latex/styles/article/elsevier/ifac.stem
@@ -0,0 +1,378 @@
+(document (TeXmacs "1.99.19")
+  (style "source")
+  (body (document (active* (document (src-title (document (src-style-file "ifac" "1.0")
+                                                  (src-purpose (document "The ifac style."))
+                                                  (src-copyright "2002--2004" (document "Adrien Bourdet"))
+                                                  (src-license (document (concat "This software falls under the "
+                                                                           (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE")
+                                                                           ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see "
+                                                                           (hlink "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                             "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                           ) ;hlink
+                                                                           "."
+                                                                         ) ;concat
+                                                               ) ;document
+                                                  ) ;src-license
+                                                ) ;document
+                                     ) ;src-title
+                           ) ;document
+                  ) ;active*
+          (concat (active* "") (use-package "elsarticle" "env-math" "two-columns"))
+          (active* (src-comment (document "LaTeX-like page layout parameters.")))
+          (assign "tex-odd-side-margin" (macro "-11mm"))
+          (assign "tex-even-side-margin" (macro "-11mm"))
+          (assign "tex-text-width" (macro "180mm"))
+          ""
+          (assign "tex-voffset" (macro "-12.5mm"))
+          (assign "tex-top-margin" (macro "2mm"))
+          (assign "tex-head-height" (macro "10pt"))
+          (assign "tex-head-sep" (macro "20pt"))
+          (assign "tex-top-skip" (macro "10pt"))
+          (assign "tex-text-height" (macro "245mm"))
+          (assign "tex-foot-height-heuristic" (macro "1em"))
+          (assign "tex-foot-skip" (macro "10pt"))
+          ""
+          (assign "tex-footnote-sep" (macro "6.65pt"))
+          (assign "tex-footnote-tm-barlen" (macro "2in"))
+          (assign "tex-column-sep" (macro "5mm"))
+          (assign "tex-float-sep" (macro (tmlen "8pt" "4pt" "2pt")))
+          (assign "tex-margin-par-width" (macro "1pc"))
+          (assign "tex-margin-par-sep" (macro "10pt"))
+          (active* (src-comment (document "Global layout.")))
+          (assign "font-base-size" "10")
+          (assign "par-columns" "2")
+          (assign "par-par-sep" "5pt")
+          (assign "par-sep" "1pt")
+          (assign "par-first" "0fn")
+          (assign "padded-par-par-sep" "5pt")
+          (assign "indent-par-first" "1.5fn")
+          ""
+          (assign "tex-jot" "2pt")
+          (assign "tex-above-display-skip" (macro (tex-len "3pt" "1pt" "1pt")))
+          (assign "tex-below-display-skip" (macro (tex-len "3pt" "1pt" "1pt")))
+          (assign "tex-above-display-short-skip" (macro (tex-len "0pt" "2pt" "0pt")))
+          (assign "tex-below-display-short-skip" (macro (tex-len "2pt" "1pt" "1pt")))
+          (active* (src-comment (document "Sizes.")))
+          (assign "tiny" (macro "x" (with "font-size" "0.6" "par-sep" "1pt" (arg "x"))))
+          (assign "very-small"
+            (macro "x" (with "font-size" "0.7" "par-sep" "1pt" (arg "x")))
+          ) ;assign
+          (assign "small"
+            (macro "x"
+              (style-with "src-compact"
+                "none"
+                (with "font-size"
+                  "0.8"
+                  "par-sep"
+                  "2pt"
+                  "tex-above-display-skip"
+                  (macro (tex-len "7pt" "2pt" "4pt"))
+                  "tex-below-display-skip"
+                  (macro (tex-len "7pt" "2pt" "4pt"))
+                  "tex-above-display-short-skip"
+                  (macro (tex-len "0pt" "1pt" "0pt"))
+                  "tex-below-display-short-skip"
+                  (macro (tex-len "3pt" "1pt" "2pt"))
+                  (arg "x")
+                ) ;with
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "normal-size"
+            (macro "x"
+              (style-with "src-compact"
+                "none"
+                (with "font-size"
+                  "1.0"
+                  "par-sep"
+                  "0.2em"
+                  "tex-above-display-skip"
+                  (macro (tex-len "5.75pt" "2pt" "2pt"))
+                  "tex-below-display-skip"
+                  (macro (tex-len "5.75pt" "2pt" "2pt"))
+                  "tex-above-display-short-skip"
+                  (macro (tex-len "0pt" "2pt" "0pt"))
+                  "tex-below-display-short-skip"
+                  (macro (tex-len "3.5pt" "2pt" "2pt"))
+                  (arg "x")
+                ) ;with
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "large" (macro "x" (with "font-size" "1.3" "par-sep" "1pt" (arg "x"))))
+          (assign "larger" (macro "x" (with "font-size" "1.7" "par-sep" "3pt" (arg "x"))))
+          (assign "very-large"
+            (macro "x" (with "font-size" "1.8" "par-sep" "4pt" (arg "x")))
+          ) ;assign
+          (assign "huge" (macro "x" (with "font-size" "2.0" "par-sep" "2pt" (arg "x"))))
+          (assign "really-huge"
+            (macro "x" (with "font-size" "2.5" "par-sep" "2pt" (arg "x")))
+          ) ;assign
+          (active* (src-comment (document "Sectional macros.")))
+          (assign "display-part"
+            (macro "nr"
+              (concat (change-case (localize "Part") "UPCASE")
+                " "
+                (number (arg "nr") "Roman")
+              ) ;concat
+            ) ;macro
+          ) ;assign
+          (assign "part-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-normal (concat (vspace* (tmlen "0.8bls" "0.4bls" "0bls"))
+                                    (normal-size (change-case (arg "name") "UPCASE"))
+                                    (vspace "1bls")
+                                  ) ;concat
+                ) ;sectional-normal
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "section-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-centered (concat (vspace* (tmlen "0.5bls" "0.2bls" "0.1bls"))
+                                      (normal-size (change-case (arg "name") "UPCASE"))
+                                      (vspace "0.5bls")
+                                    ) ;concat
+                ) ;sectional-centered
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "section-numbered-title"
+            (macro "name"
+              (section-title (sectional-prefixed (concat (the-section) (section-sep))
+                               (concat (change-case (arg "name") "UPCASE") (section-post-sep))
+                             ) ;sectional-prefixed
+              ) ;section-title
+            ) ;macro
+          ) ;assign
+          (assign "subsection-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-normal-italic (concat (vspace* (tmlen "0.3bls" "0.2bls" "0.1bls"))
+                                           (normal-size (arg "name"))
+                                           (vspace "0.3bls")
+                                         ) ;concat
+                ) ;sectional-normal-italic
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "subsubsection-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-normal-italic (concat (vspace* (tmlen "0.3bls" "0.1bls" "0bls"))
+                                           (normal-size (arg "name"))
+                                           (vspace "0.001bls")
+                                         ) ;concat
+                ) ;sectional-normal-italic
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "paragraph-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-short-bold (concat (vspace* "3.25ex" "2ex" "0.2ex")
+                                        (normal-size (arg "name"))
+                                        (space "1em")
+                                      ) ;concat
+                ) ;sectional-short-bold
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "subparagraph-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-short-bold (concat (vspace* "3.25ex" "2ex" "0.2ex")
+                                        (space "1em")
+                                        (normal-size (arg "name"))
+                                        (space "1em")
+                                      ) ;concat
+                ) ;sectional-short-bold
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (active* (src-comment (document "Section and environment numbering.")))
+          (assign "section-sep" (macro (concat "." (space "0.6fn"))))
+          (assign "part-sep" (macro (concat "." (space "0.6fn"))))
+          (assign "paragraph-display-numbers" (macro "true"))
+          (assign "subparagraph-display-numbers" (macro "true"))
+          (active* (src-comment (document "Theorem-like environments.")))
+          (assign "enunciation-name"
+            (macro "name" (with "font-shape" "italic" (arg "name")))
+          ) ;assign
+          (assign "enunciation-sep" ". ")
+          (assign "render-theorem"
+            (macro "which"
+              "body"
+              (document (render-enunciation (theorem-name (concat (arg "which") (theorem-sep)))
+                          (arg "body")
+                        ) ;render-enunciation
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "render-proof"
+            (macro "which"
+              "body"
+              (surround (concat (with "font-series" "bold" "font-shape" "right" (arg "which"))
+                          (space "1em")
+                        ) ;concat
+                (tab-qed)
+                (arg "body")
+              ) ;surround
+            ) ;macro
+          ) ;assign
+          (active* (src-comment (document "Rendering of floating objects.")))
+          (assign "render-big-figure"
+            (macro "type"
+              "name"
+              "fig"
+              "cap"
+              (document (padded-normal "1fn"
+                          "1fn"
+                          (style-with "src-compact"
+                            "none"
+                            (tabular* (tformat (twith "table-width" "1par")
+                                        (cwith "1" "-1" "1" "-1" "cell-lsep" "0spc")
+                                        (cwith "1" "-1" "1" "-1" "cell-rsep" "0spc")
+                                        (cwith "1" "1" "1" "1" "cell-hyphen" "t")
+                                        (cwith "1" "1" "1" "1" "cell-valign" "b")
+                                        (table (row (cell (document (with "par-left"
+                                                                      (plus (value "par-left") "4em")
+                                                                      (document ""
+                                                                        (surround (concat (figure-name (concat (arg "name") (figure-sep)))
+                                                                                    (list-caption (arg "type") (arg "cap"))
+                                                                                  ) ;concat
+                                                                          ""
+                                                                          (document (arg "cap"))
+                                                                        ) ;surround
+                                                                      ) ;document
+                                                                    ) ;with
+                                                          ) ;document
+                                                    ) ;cell
+                                               ) ;row
+                                          (row (cell ""))
+                                          (row (cell (arg "fig")))
+                                        ) ;table
+                                      ) ;tformat
+                            ) ;tabular*
+                          ) ;style-with
+                        ) ;padded-normal
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "render-footnote"
+            (macro "nr"
+              "body"
+              (style-with "src-compact"
+                "none"
+                (float "footnote"
+                  ""
+                  (with "font-size"
+                    "0.84"
+                    "par-mode"
+                    "justify"
+                    "par-left"
+                    "0cm"
+                    "par-right"
+                    "0cm"
+                    (style-with "src-compact"
+                      "none"
+                      (surround (concat (arg "nr") (footnote-sep) (label (merge "footnote-" (arg "nr"))))
+                        (right-flush)
+                        (style-with "src-compact" "none" (with "font-shape" "right" (arg "body")))
+                      ) ;surround
+                    ) ;style-with
+                  ) ;with
+                ) ;float
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (active* (src-comment (document "Title rendering.")))
+          (assign "doc-title"
+            (macro "x"
+              (document ""
+                (surround (vspace* "0.5fn")
+                  (vspace "0.5fn")
+                  (document (doc-title-block (with "font-size" "1.414" (strong (arg "x")))))
+                ) ;surround
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "author-name"
+            (macro "author" (doc-author-block (strong (author-by (arg "author")))))
+          ) ;assign
+          (assign "author-affiliation"
+            (macro "address"
+              (document (surround (vspace* "0.5fn")
+                          (vspace "0.5fn")
+                          (doc-author-block (em (arg "address")))
+                        ) ;surround
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "author-email"
+            (macro "email"
+              (doc-author-block (concat (with "font-shape" "italic" (concat (email-text) (localize ":") " "))
+                                  " "
+                                  (verbatim (arg "email"))
+                                ) ;concat
+              ) ;doc-author-block
+            ) ;macro
+          ) ;assign
+          (assign "author-email-note"
+            (macro "sym"
+              "id"
+              "email"
+              (doc-author-block (doc-note-text (arg "sym")
+                                  (arg "id")
+                                  (concat (with "font-shape" "italic" (concat (email-text) (localize ":") " "))
+                                    (verbatim (arg "email"))
+                                  ) ;concat
+                                ) ;doc-note-text
+              ) ;doc-author-block
+            ) ;macro
+          ) ;assign
+          (active* (src-comment (document "Abstract.")))
+          (assign "render-abstract"
+            (macro "body"
+              (document (with "par-columns"
+                          "1"
+                          "par-left"
+                          "17mm"
+                          "par-right"
+                          "17mm"
+                          "overlined-sep"
+                          "1spc"
+                          "underlined-sep"
+                          "1spc"
+                          (document (wide-std-bothlined (document (surround (concat (abstract-text) (localize ":") " ")
+                                                                    (right-flush)
+                                                                    (arg "body")
+                                                                  ) ;surround
+                                                        ) ;document
+                                    ) ;wide-std-bothlined
+                            ""
+                          ) ;document
+                        ) ;with
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (active* (document (src-comment (document "Headers."))))
+          (set-header "")
+          (set-footer "")
+          (assign "header-title" (macro "name" ""))
+          (assign "header-author" (macro "name" ""))
+          (assign "header-primary" (macro "name" "nr" "what" ""))
+          (assign "header-secondary" (macro "name" "nr" "what" ""))
+          ""
+        ) ;document
+  ) ;body
+  (initial (collection (associate "preamble" "true") (associate "sfactor" "7")))
+) ;document
diff --git a/TeXmacs/plugins/latex/styles/article/elsevier/ifac.ts b/TeXmacs/plugins/latex/styles/article/elsevier/ifac.ts
deleted file mode 100644
index 784fe3b2da..0000000000
--- a/TeXmacs/plugins/latex/styles/article/elsevier/ifac.ts
+++ /dev/null
@@ -1,252 +0,0 @@
-
-
-
-
-<\body>
-  <\active*>
-    <\src-title>
-      
-
-      <\src-purpose>
-        The ifac style.
-      
-
-      <\src-copyright|2002--2004>
-        Adrien Bourdet
-      
-
-      <\src-license>
-        This software falls under the . It comes WITHOUT ANY
-        WARRANTY WHATSOEVER. You should have received a copy of the license
-        which the software. If not, see .
-      
-    
-  
-
-  
-
-  
-    LaTeX-like page layout parameters.
-  >
-
-  >
-
-  >
-
-  >
-
-  \;
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  \;
-
-  >
-
-  >
-
-  >
-
-  >>
-
-  >
-
-  >
-
-  
-    Global layout.
-  >
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  \;
-
-  
-
-  >>
-
-  >>
-
-  >>
-
-  >>
-
-  
-    Sizes.
-  >
-
-  >>>
-
-  >>>
-
-  >|tex-below-display-skip|>|tex-above-display-short-skip|>|tex-below-display-short-skip|>|>>>>
-
-  >|tex-below-display-skip|>|tex-above-display-short-skip|>|tex-below-display-short-skip|>|>>>>
-
-  >>>
-
-  >>>
-
-  >>>
-
-  >>>
-
-  >>>
-
-  
-    Sectional macros.
-  >
-
-  |UPCASE>
-  |Roman>>>
-
-  >|UPCASE>>>>>>
-
-  >|UPCASE>>>>>>
-
-  ||UPCASE>>>>>
-
-  >>>>>>
-
-  >>>>>>
-
-  >>>>>
-
-  >>>>>
-
-  
-    Section and environment numbering.
-  >
-
-  >>
-
-  >>
-
-  >
-
-  >
-
-  
-    Theorem-like environments.
-  >
-
-  >>>
-
-  
-
-  
-    >|>
-  >
-
-  >||>>>
-
-  
-    Rendering of floating objects.
-  >
-
-  
-    |||||
-      <\with|par-left||4em>>
-        \;
-
-        <\surround|>|>|>
-          
-        
-      
-    >|>|>>>>>>>
-  >
-
-  >>||>>>>>>>>>
-
-  
-    Title rendering.
-  >
-
-  
-    \;
-
-    <\surround||>
-      >>>
-    
-  >
-
-  >>>>>
-
-  
-    ||>>>
-  >
-
-  
-  > >>>>
-
-  ||
-  >>>>>>
-
-  
-    Abstract.
-  >
-
-  
-    <\with|par-columns|1|par-left|17mm|par-right|17mm|overlined-sep|1spc|underlined-sep|1spc>
-      <\wide-std-bothlined>
-         ||>
-      
-
-      \;
-    
-  >
-
-  <\active*>
-    <\src-comment>
-      Headers.
-    
-  
-
-  
-
-  
-
-  >
-
-  >
-
-  >
-
-  >
-
-  \;
-
-
-<\initial>
-  <\collection>
-    
-    
-  
-
\ No newline at end of file
diff --git a/TeXmacs/plugins/latex/styles/article/revtex/aip.stem b/TeXmacs/plugins/latex/styles/article/revtex/aip.stem
new file mode 100644
index 0000000000..41aaa5866d
--- /dev/null
+++ b/TeXmacs/plugins/latex/styles/article/revtex/aip.stem
@@ -0,0 +1,720 @@
+(document (TeXmacs "1.99.19")
+  (style "source")
+  (body (document (active* (document (src-title (document (src-style-file "aip" "1.0")
+                                                  (src-purpose (document "The Revtex's American Institude of Physic style."))
+                                                  (src-copyright "2012--2012" (document "Joris van der Hoeven, Franois Poulain"))
+                                                  (src-license (document (concat "This software falls under the "
+                                                                           (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE")
+                                                                           ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see "
+                                                                           (hlink "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                             "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                           ) ;hlink
+                                                                           "."
+                                                                         ) ;concat
+                                                               ) ;document
+                                                  ) ;src-license
+                                                ) ;document
+                                     ) ;src-title
+                           ) ;document
+                  ) ;active*
+          (use-package "std" "env" "header-generic" "section-book"
+            "title-generic" "std-latex" "cite-author-year" "std-automatic"
+            "two-columns" "html-font-size"
+          ) ;use-package
+          (active* (src-comment (document "Page layout.")))
+          (assign "par-first" "1em")
+          (assign "parindent" (value "par-first"))
+          (assign "page-type" "a4")
+          (assign "par-columns" "2")
+          (assign "tex-odd-side-margin" "0pt")
+          (assign "tex-even-side-margin" "0pt")
+          (assign "tex-margin-par-width" "60pt")
+          (assign "tex-margin-par-sep" "10pt")
+          (assign "tex-top-margin" "-37pt")
+          (assign "tex-head-height" "12pt")
+          (assign "tex-head-sep" "25pt")
+          (assign "tex-top-skip" "25pt")
+          (assign "tex-text-height" "665.5pt")
+          (assign "tex-text-width" "468pt")
+          (assign "tex-column-sep" "10pt")
+          (assign "tex-footnote-sep" "10pt")
+          (assign "tex-float-sep" (texlen "14pt" "2pt" "4pt"))
+          (assign "tex-text-float-sep" (texlen "20pt" "2pt" "4pt"))
+          (assign "tex-in-text-sep" (texlen "14pt" "2pt" "4pt"))
+          (active* (src-comment (document "Sectionning macros.")))
+          (style-with "src-compact"
+            "none"
+            (assign "part-title"
+              (style-with "src-compact"
+                "none"
+                (macro "name"
+                  (style-with "src-compact"
+                    "none"
+                    (sectional-normal-bold (concat (vspace* "4ex") (really-huge (arg "name")) (vspace "3ex") (new-line))
+                    ) ;sectional-normal-bold
+                  ) ;style-with
+                ) ;macro
+              ) ;style-with
+            ) ;assign
+          ) ;style-with
+          (style-with "src-compact"
+            "none"
+            (assign (style-with "src-compact" "none" "part-numbered-title")
+              (style-with "src-compact"
+                "none"
+                (macro (style-with "src-compact" "all" "name")
+                  (style-with "src-compact"
+                    "none"
+                    (sectional-short-bold (concat (vspace* "4ex")
+                                            (very-large (concat (part-text) " " (the-part) (new-line) (vspace* (value "parindent")))
+                                            ) ;very-large
+                                            (huge (arg "name"))
+                                            (vspace "3ex")
+                                            (new-line)
+                                          ) ;concat
+                    ) ;sectional-short-bold
+                  ) ;style-with
+                ) ;macro
+              ) ;style-with
+            ) ;assign
+          ) ;style-with
+          (assign "section-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-short-bold (concat (vspace* (tex-len "0.8cm" "1ex" "0.2ex"))
+                                        (with "font-family" "ss" (small (change-case (arg "name") "UPCASE")))
+                                        (vspace "0.5cm")
+                                      ) ;concat
+                ) ;sectional-short-bold
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "section-numbered-title"
+            (macro "name"
+              (section-title (sectional-prefixed (concat (the-section) (section-sep))
+                               (concat (change-case (arg "name") "UPCASE") (section-post-sep))
+                             ) ;sectional-prefixed
+              ) ;section-title
+            ) ;macro
+          ) ;assign
+          (assign "subsection-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-normal-bold (concat (vspace* (tex-len "0.8cm" "1ex" "0.2ex"))
+                                         (with "font-family" "ss" (small (arg "name")))
+                                         (vspace "0.5cm")
+                                       ) ;concat
+                ) ;sectional-normal-bold
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "subsubsection-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-normal-bold (concat (vspace* (tex-len "0.8cm" "1ex" "0.2ex"))
+                                         (with "font-family" "ss" (small (arg "name")))
+                                         (vspace "0.5cm")
+                                       ) ;concat
+                ) ;sectional-normal-bold
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "paragraph-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-short-italic (concat (space (parindent))
+                                          (normal-size (arg "name"))
+                                          (space (value "parindent"))
+                                          (vspace "-1em")
+                                        ) ;concat
+                ) ;sectional-short-italic
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "subparagraph-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-short-bold (concat (vspace* (tex-len "3.25ex" "1ex" "0.2ex"))
+                                        (space (value "parindent"))
+                                        (normal-size (arg "name"))
+                                        (space (value "parindent"))
+                                        (vspace "-1em")
+                                      ) ;concat
+                ) ;sectional-short-bold
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "appendix-text" "Appendix")
+          (assign "appendix-numbered-title"
+            (macro "title"
+              (document (assign "display-equation"
+                          (macro "nr" (concat (the-appendix) (number (arg "nr") "arabic")))
+                        ) ;assign
+                (concat (assign "subsection-display" "arabic")
+                  (subsection-title (concat (appendix-text) " " (the-appendix) ": " (arg "title"))
+                  ) ;subsection-title
+                ) ;concat
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (active* (src-comment (document "Section and environment numbering.")))
+          (assign "sectional-sep" (macro (space "1.1fn")))
+          (assign "section-clean" (macro (reset-subsection)))
+          (style-with "src-compact"
+            "all"
+            (assign "display-std-env" (macro "nr" (document (arg "nr"))))
+          ) ;style-with
+          (assign "part-display-numbers" (macro "true"))
+          (assign "section-display-numbers" (macro "true"))
+          (assign "subsection-display-numbers" (macro "true"))
+          (assign "subsubsection-display-numbers" (macro "true"))
+          (assign "paragraph-display-numbers" (macro "true"))
+          (assign "subparagraph-display-numbers" (macro "false"))
+          (assign "display-section" (macro "nr" (concat (number (arg "nr") "Roman") ".")))
+          (assign "subsection-display" "Alpha")
+          (assign "display-subsection"
+            (macro "nr" (concat (number (arg "nr") (subsection-display)) "."))
+          ) ;assign
+          (assign "display-subsubsection" (macro "nr" (concat (arg "nr") ".")))
+          (assign "display-paragraph"
+            (macro "nr" (concat (number (arg "nr") "alpha") "."))
+          ) ;assign
+          (assign "display-subparagraph" "")
+          (active* (src-comment (document "Headers and footers.")))
+          (set-header (concat (no-indent)
+                        (tabular (tformat (twith "table-width" "1par")
+                                   (cwith "1" "-1" "1" "1" "cell-halign" "r")
+                                   (table (row (cell (page-number))))
+                                 ) ;tformat
+                        ) ;tabular
+                      ) ;concat
+          ) ;set-header
+          (set-footer "")
+          (assign "header-title" (macro "name" ""))
+          (assign "header-author" (macro "name" ""))
+          (assign "header-primary" (macro "name" "nr" "what" ""))
+          (assign "header-secondary" (macro "name" "nr" "what" ""))
+          (assign "start-page" (macro "s" ""))
+          (active* (src-comment (document "Footnotes.")))
+          (assign "footnote-sep" "")
+          (assign "display-footnote" (macro "nr" (number (arg "nr") "alpha")))
+          (assign "render-footnote"
+            (macro "nr"
+              "body"
+              (style-with "src-compact"
+                "none"
+                (float "footnote"
+                  ""
+                  (document (smaller (with "par-mode"
+                                       "justify"
+                                       "par-left"
+                                       "0cm"
+                                       "par-right"
+                                       "0cm"
+                                       (style-with "src-compact"
+                                         "none"
+                                         (surround (concat (rsup (concat (locus (id (hard-id (arg "body")))
+                                                                           (link "hyperlink"
+                                                                             (id (hard-id (arg "body")))
+                                                                             (url (merge "#footnr-" (arg "nr")))
+                                                                           ) ;link
+                                                                           (arg "nr")
+                                                                         ) ;locus
+                                                                   ")"
+                                                                 ) ;concat
+                                                           ) ;rsup
+                                                     (footnote-sep)
+                                                   ) ;concat
+                                           (concat (set-binding (merge "footnote-" (arg "nr")) (value "the-label") "body")
+                                             (right-flush)
+                                           ) ;concat
+                                           (style-with "src-compact" "none" (arg "body"))
+                                         ) ;surround
+                                       ) ;style-with
+                                     ) ;with
+                            ) ;smaller
+                  ) ;document
+                ) ;float
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "footnote"
+            (macro "body"
+              (style-with "src-compact"
+                "none"
+                (concat (next-footnote)
+                  (render-footnote (the-footnote) (arg "body"))
+                  (space "0spc")
+                  (label (merge "footnr-" (the-footnote)))
+                  (rsup (concat (reference (merge "footnote-" (the-footnote))) ")"))
+                ) ;concat
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (active* (document (src-comment (document "List environments."))))
+          (assign "render-list"
+            (macro "body"
+              (surround (no-page-break*)
+                (concat (right-flush) (no-indent*))
+                (with "par-left"
+                  (plus (value ,(merge "left-margin-"
+                                  (plus (itemize-level) (enumerate-level))))
+                    (value "par-left")
+                  ) ;plus
+                  "par-par-sep"
+                  (value ,(merge "par-par-sep-"
+                            (plus (itemize-level) (enumerate-level))))
+                  (arg "body")
+                ) ;with
+              ) ;surround
+            ) ;macro
+          ) ;assign
+          ""
+          (assign "item-1" (macro (active* (with "mode" "math" ""))))
+          (assign "item-2" (macro (active* (with "mode" "math" (rigid "-")))))
+          (assign "item-3" (macro (active* (math ""))))
+          (assign "item-4" (macro (active* (math ""))))
+          (new-list "itemize-1" (value "aligned-item") (macro "name" (item-tag)))
+          (new-list "itemize-2" (value "aligned-item") (macro "name" (item-tag)))
+          (new-list "itemize-3" (value "aligned-item") (macro "name" (item-tag)))
+          (new-list "itemize-4" (value "aligned-item") (macro "name" (item-tag)))
+          ""
+          (assign "item-hsep" (macro "6pt"))
+          ""
+          (assign "left-margin-0" "24pt")
+          (assign "left-margin-1" "24pt")
+          (assign "left-margin-2" "20pt")
+          (assign "left-margin-3" "16pt")
+          (assign "left-margin-4" "14pt")
+          (assign "left-margin-5" "6pt")
+          (assign "left-margin-6" "6pt")
+          ""
+          (assign "top-sep-0" (tex-len "10pt" "4pt" "6pt"))
+          (assign "top-sep-1" (tex-len "10pt" "4pt" "6pt"))
+          (assign "top-sep-2" (tex-len "5pt" "2.5pt" "1pt"))
+          (assign "top-sep-3" (tex-len "2.5pt" "1pt" "1pt"))
+          ""
+          (assign "par-par-sep-0" (tex-len "5pt" "2.5pt" "1pt"))
+          (assign "par-par-sep-1" (tex-len "5pt" "2.5pt" "1pt"))
+          (assign "par-par-sep-2" (tex-len "2.5pt" "1pt" "1pt"))
+          (assign "par-par-sep-3" (tex-len "0pt" "1pt" "1pt"))
+          ""
+          (assign "enumerate-level" "0")
+          (assign "enum-1" (macro "name" (number (arg "name") "arabic")))
+          (assign "enum-2" (macro "name" (number (arg "name") "alpha")))
+          (assign "enum-3" (macro "name" (number (arg "name") "roman")))
+          (assign "enum-4" (macro "name" (number (arg "name") "Alpha")))
+          (new-list "enumerate-1"
+            (value "aligned-dot-item")
+            (macro "name" (enum-tag (arg "name")))
+          ) ;new-list
+          (new-list "enumerate-2"
+            (value "aligned-item")
+            (macro "name" (enum-tag (arg "name")))
+          ) ;new-list
+          (new-list "enumerate-3"
+            (value "aligned-dot-item")
+            (macro "name" (enum-tag (arg "name")))
+          ) ;new-list
+          (new-list "enumerate-4"
+            (value "aligned-dot-item")
+            (macro "name" (enum-tag (arg "name")))
+          ) ;new-list
+          (assign "enumerate-reduce"
+            (macro "nr" (plus (mod (minus (arg "nr") "1") "4") "1"))
+          ) ;assign
+          (active* (src-comment (document "Rendering of tables.")))
+          (assign "table-text" (macro (localize "TABLE")))
+          (assign "list-of-tables-text" (macro (localize "List of Tables")))
+          (assign "the-table" (macro (number (value "table-nr") "Roman")))
+          (assign "ruledtabular"
+            (macro "body"
+              (with "tabular"
+                (value "ruled-tabular")
+                "tabular*"
+                (value "ruled-tabular*")
+                (arg "body")
+              ) ;with
+            ) ;macro
+          ) ;assign
+          (assign "table*" (macro "body" (with "par-columns" "1" (arg "body"))))
+          (assign "ruled-tabular"
+            (macro "body"
+              (tformat (twith "table-width" "1par")
+                (cwith "1" "1" "1" "-1" "cell-bborder" "0.5pt")
+                (cwith "1" "1" "1" "-1" "cell-tborder" "1pt")
+                (cwith "-1" "-1" "1" "-1" "cell-bborder" "1pt")
+                (arg "body")
+              ) ;tformat
+            ) ;macro
+          ) ;assign
+          (assign "ruled-tabular*"
+            (macro "body"
+              (with "par-columns"
+                "1"
+                (tformat (twith "table-width" "1par")
+                  (cwith "1" "1" "1" "-1" "cell-bborder" "0.5pt")
+                  (cwith "1" "1" "1" "-1" "cell-tborder" "1pt")
+                  (cwith "-1" "-1" "1" "-1" "cell-bborder" "1pt")
+                  (arg "body")
+                ) ;tformat
+              ) ;with
+            ) ;macro
+          ) ;assign
+          (assign "big-table-enlarge"
+            (macro "contents"
+              "body"
+              (if (greater (times "2" (look-up (box-info (arg "contents") "w") "0"))
+                    (look-up (box-info (space (tex-text-width)) "w") "0")
+                  ) ;greater
+                (with "par-columns" "1" (arg "body"))
+                (arg "body")
+              ) ;if
+            ) ;macro
+          ) ;assign
+          (assign "big-table"
+            (macro "body"
+              "caption"
+              (document (big-table-enlarge (arg "body")
+                          (document (surround (compound "next-table")
+                                      ""
+                                      (document (render-big-table (document "table")
+                                                  (concat (compound "table-text") " " (compound "the-table"))
+                                                  (arg "body")
+                                                  (arg "caption")
+                                                ) ;render-big-table
+                                      ) ;document
+                                    ) ;surround
+                          ) ;document
+                        ) ;big-table-enlarge
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "render-big-table"
+            (macro "type"
+              "name"
+              "fig"
+              "cap"
+              (document (padded-normal "1fn"
+                          "1fn"
+                          (tabular* (tformat (twith "table-width" "1par")
+                                      (cwith "1" "1" "1" "1" "cell-hyphen" "t")
+                                      (cwith "1" "-1" "1" "-1" "cell-lsep" "0spc")
+                                      (cwith "1" "-1" "1" "-1" "cell-rsep" "0spc")
+                                      (cwith "2" "2" "1" "1" "cell-height" "0.5fn")
+                                      (cwith "1" "1" "1" "1" "cell-lsep" "1.5fn")
+                                      (cwith "1" "1" "1" "1" "cell-rsep" "1.5fn")
+                                      (table (row (cell (document (small (surround (concat (figure-name (concat (arg "name") (figure-sep)))
+                                                                                     (list-caption (arg "type") (arg "cap"))
+                                                                                   ) ;concat
+                                                                           ""
+                                                                           (document (arg "cap"))
+                                                                         ) ;surround
+                                                                  ) ;small
+                                                        ) ;document
+                                                  ) ;cell
+                                             ) ;row
+                                        (row (cell ""))
+                                        (row (cell (arg "fig")))
+                                      ) ;table
+                                    ) ;tformat
+                          ) ;tabular*
+                        ) ;padded-normal
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (active* (src-comment (document "Rendering of figures.")))
+          (assign "figure-text" (macro (localize "FIG.")))
+          (assign "figure*" (macro "body" (with "par-columns" "1" (arg "body"))))
+          (assign "list-of-figures-text" (macro (localize "List of Figures")))
+          (assign "big-figure"
+            (macro "body"
+              "caption"
+              (document (surround (next-figure)
+                          ""
+                          (document (render-big-figure "figure"
+                                      (concat (figure-text) " " (the-figure))
+                                      (arg "body")
+                                      (arg "caption")
+                                    ) ;render-big-figure
+                          ) ;document
+                        ) ;surround
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "figure-name" (macro "name" (arg "name")))
+          (assign "caption-left-padding" "0fn")
+          (assign "caption-right-padding" "0fn")
+          (assign "figure-width" "1par")
+          (assign "render-big-figure"
+            (macro "type"
+              "name"
+              "fig"
+              "cap"
+              (document (padded-normal "1fn"
+                          "1fn"
+                          (tabular* (tformat (twith "table-width" (value "figure-width"))
+                                      (cwith "3" "3" "1" "1" "cell-hyphen" "t")
+                                      (cwith "1" "-1" "1" "-1" "cell-lsep" (value "figure-left-padding"))
+                                      (cwith "1" "-1" "1" "-1" "cell-rsep" (value "figure-right-padding"))
+                                      (cwith "2" "2" "1" "1" "cell-height" (value "figure-caption-sep"))
+                                      (cwith "3" "3" "1" "1" "cell-lsep" (value "caption-left-padding"))
+                                      (cwith "3" "3" "1" "1" "cell-rsep" (value "caption-right-padding"))
+                                      (table (row (cell (arg "fig")))
+                                        (row (cell ""))
+                                        (row (cell (document (small (surround (concat (figure-name (concat (arg "name") (figure-sep)))
+                                                                                (list-caption (arg "type") (arg "cap"))
+                                                                              ) ;concat
+                                                                      ""
+                                                                      (document (arg "cap"))
+                                                                    ) ;surround
+                                                             ) ;small
+                                                   ) ;document
+                                             ) ;cell
+                                        ) ;row
+                                      ) ;table
+                                    ) ;tformat
+                          ) ;tabular*
+                        ) ;padded-normal
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (active* (document (src-comment (document "Bibliography."))))
+          (assign "bibitem-width" "2em")
+          (assign "transform-bibitem" (macro "body" (concat "[" (arg "body") "] ")))
+          (assign "xtransform-bibitem" (macro "body" (rsup (arg "body"))))
+          (assign "xrender-bibitem"
+            (macro "text"
+              (style-with "src-compact"
+                "none"
+                (concat (with "par-first" (minus "1tmpt" (value "bibitem-width")) (yes-indent))
+                  (hspace (maximum "0cm" (minus (value "bibitem-width") (box-info (arg "text") "w.")))
+                  ) ;hspace
+                  (arg "text")
+                ) ;concat
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "bib-list"
+            (macro "largest"
+              "body"
+              (document (small (document (with "bibitem-width"
+                                           (minimum (box-info (concat (transform-bibitem (arg "largest")) ".") "w.") "2em")
+                                           "item-hsep"
+                                           (value "bibitem-hsep")
+                                           "bibitem-nr"
+                                           "0"
+                                           "par-flexibility"
+                                           "2.0"
+                                           (document (description (document (arg "body"))))
+                                         ) ;with
+                               ) ;document
+                        ) ;small
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "bibliography-text" (macro (rule "9cm" "1pt")))
+          (assign "bibliography-text"
+            (macro (document (with "par-columns"
+                               "1"
+                               (document (tabular (tformat (cwith "1" "-1" "1" "-1" "cell-width" "1cm")
+                                                    (cwith "1" "-1" "1" "-1" "cell-hmode" "exact")
+                                                    (cwith "1" "-1" "1" "-1" "cell-height" "0.1pt")
+                                                    (cwith "1" "-1" "1" "-1" "cell-vmode" "exact")
+                                                    (cwith "1" "1" "4" "6" "cell-bborder" "0.7pt")
+                                                    (cwith "1" "1" "3" "3" "cell-bborder" "0.5pt")
+                                                    (cwith "1" "1" "7" "7" "cell-bborder" "0.5pt")
+                                                    (cwith "1" "1" "8" "8" "cell-bborder" "0.4pt")
+                                                    (cwith "1" "1" "2" "2" "cell-bborder" "0.4pt")
+                                                    (cwith "1" "1" "1" "1" "cell-bborder" "0.3pt")
+                                                    (cwith "1" "1" "9" "9" "cell-bborder" "0.3pt")
+                                                    (table (row (cell "")
+                                                             (cell "")
+                                                             (cell "")
+                                                             (cell "")
+                                                             (cell "")
+                                                             (cell "")
+                                                             (cell "")
+                                                             (cell "")
+                                                             (cell "")
+                                                           ) ;row
+                                                      (row (cell "")
+                                                        (cell "")
+                                                        (cell "")
+                                                        (cell "")
+                                                        (cell "")
+                                                        (cell "")
+                                                        (cell "")
+                                                        (cell "")
+                                                        (cell "")
+                                                      ) ;row
+                                                    ) ;table
+                                                  ) ;tformat
+                                         ) ;tabular
+                               ) ;document
+                             ) ;with
+                   ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "bibliography-text" (macro (localize "References")))
+          (assign "render-bibliography"
+            (macro "name" "body" (document (section* (arg "name")) (arg "body")))
+          ) ;assign
+          (active* (src-comment (document "Title rendering.")))
+          (assign "doc-footnote-ref"
+            (macro "body"
+              (style-with "src-compact"
+                "none"
+                (if (quasi (unequal (get-arity ,(quote-arg "body")) "0"))
+                  (with "font-family" "rm" (rsup (concat (doc-author-note-next) ")")))
+                ) ;if
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "the-doc-note" (macro (number (value "doc-note-nr") "alpha")))
+          (assign "by-text" (macro (localize "")))
+          (assign "author-render-name"
+            (macro "author" (doc-author-block (with "font-family" "ss" (arg "author"))))
+          ) ;assign
+          (assign "author-affiliation"
+            (macro "address"
+              (document (surround (vspace* "0.5fn")
+                          (vspace "0.5fn")
+                          (doc-author-block (with "font-shape" "italic" (arg "address")))
+                        ) ;surround
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "doc-author-main"
+            (macro "data"
+              (document (quasi (document (unquote* (select (quote-arg "data") "author-name"))
+                                 (unquote* (select (quote-arg "data") "author-affiliation"))
+                               ) ;document
+                        ) ;quasi
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "doc-author-data-note"
+            (xmacro "data"
+              (quasi (document (unquote* (select (quote-arg "data") "author-homepage" (pat-any)))
+                       (unquote* (select (quote-arg "data") "author-note" "document" (pat-any)))
+                     ) ;document
+              ) ;quasi
+            ) ;xmacro
+          ) ;assign
+          (assign "doc-date"
+            (macro "body" (doc-author-block (concat "(Dated: " (arg "body") ")")))
+          ) ;assign
+          (assign "abstract-text" "")
+          (assign "render-abstract"
+            (macro "body" (surround "" (vspace "2fn") (doc-author-block (arg "body"))))
+          ) ;assign
+          (assign "doc-authors-block" (macro "body" (doc-author-block (arg "body"))))
+          (assign "doc-author-block"
+            (macro "body"
+              (document (with "par-columns"
+                          "1"
+                          (document (with "par-mode"
+                                      "right"
+                                      (document (tabular (tformat (cwith "1" "1" "1" "1" "cell-width" "400pt")
+                                                           (cwith "1" "1" "1" "1" "cell-hmode" "exact")
+                                                           (cwith "1" "1" "1" "1" "cell-hyphen" "t")
+                                                           (table (row (cell (document (arg "body")))))
+                                                         ) ;tformat
+                                                ) ;tabular
+                                      ) ;document
+                                    ) ;with
+                          ) ;document
+                        ) ;with
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "doc-data"
+            (xmacro "args"
+              (with "par-columns"
+                "1"
+                "par-first"
+                "0em"
+                (extern "doc-data" (quote-arg "args") "")
+              ) ;with
+            ) ;xmacro
+          ) ;assign
+          (assign "doc-render-title"
+            (macro "x"
+              (surround (vspace* "0.5fn")
+                ""
+                (document (doc-title-block (font-magnify "1.682"
+                                             (with "math-font-series"
+                                               "bold"
+                                               "font-series"
+                                               "bold"
+                                               "font-family"
+                                               "ss"
+                                               (arg "x")
+                                             ) ;with
+                                           ) ;font-magnify
+                          ) ;doc-title-block
+                ) ;document
+              ) ;surround
+            ) ;macro
+          ) ;assign
+          (assign "doc-title" (value "doc-render-title"))
+          (assign "doc-title-block" (macro "body" (arg "body")))
+          (assign "doc-authors-data"
+            (xmacro "data"
+              (document (style-with "src-compact"
+                          "none"
+                          (document (quasi (document (unquote* (quote-arg "data")))))
+                        ) ;style-with
+              ) ;document
+            ) ;xmacro
+          ) ;assign
+          (assign "render-doc-author" (macro "body" (arg "body")))
+          (assign "render-doc-authors" (macro "body" (arg "body")))
+          (active* (src-comment (document "Customization of other environments.")))
+          (assign "table-of-contents-text" (macro (localize "Contents")))
+          (active* (src-comment (document "Specific macros from Revtex style.")))
+          (style-with "src-compact"
+            "none"
+            (assign "widetext"
+              (macro "body"
+                (with "par-columns"
+                  "1"
+                  (document (tabular (tformat (twith "table-hmode" "exact")
+                                       (twith "table-width" "1par")
+                                       (cwith "1" "1" "1" "-1" "cell-height" "1ex")
+                                       (cwith "1" "1" "1" "-1" "cell-vmode" "exact")
+                                       (cwith "1" "-1" "1" "1" "cell-bborder" "0.1pt")
+                                       (cwith "1" "-1" "1" "1" "cell-rborder" "0.1pt")
+                                       (table (row (cell "") (cell "")))
+                                     ) ;tformat
+                            ) ;tabular
+                    (arg "body")
+                    (tabular (tformat (twith "table-hmode" "exact")
+                               (twith "table-width" "1par")
+                               (cwith "1" "1" "1" "2" "cell-height" "1ex")
+                               (cwith "1" "1" "1" "2" "cell-vmode" "exact")
+                               (cwith "1" "1" "2" "2" "cell-lborder" "0.1pt")
+                               (cwith "1" "1" "2" "2" "cell-tborder" "0.1pt")
+                               (table (row (cell "") (cell "")))
+                             ) ;tformat
+                    ) ;tabular
+                  ) ;document
+                ) ;with
+              ) ;macro
+            ) ;assign
+          ) ;style-with
+          (assign "acknowledgments*"
+            (macro "body" (document (section* (localize "Acknowledgments")) (arg "body")))
+          ) ;assign
+          (active* (src-comment (document "Font sizes and AIP layout from Revtex.")))
+          (use-package (merge "revtex-" (value "font-base-size") "pt"))
+        ) ;document
+  ) ;body
+  (initial (collection))
+) ;document
diff --git a/TeXmacs/plugins/latex/styles/article/revtex/aip.ts b/TeXmacs/plugins/latex/styles/article/revtex/aip.ts
deleted file mode 100644
index 362dee0f69..0000000000
--- a/TeXmacs/plugins/latex/styles/article/revtex/aip.ts
+++ /dev/null
@@ -1,471 +0,0 @@
-
-
-
-
-<\body>
-  <\active*>
-    <\src-title>
-      
-
-      <\src-purpose>
-        The Revtex's American Institude of Physic style.
-      
-
-      <\src-copyright|2012--2012>
-        Joris van der Hoeven, Franois Poulain
-      
-
-      <\src-license>
-        This software falls under the . It comes WITHOUT ANY
-        WARRANTY WHATSOEVER. You should have received a copy of the license
-        which the software. If not, see .
-      
-    
-  
-
-  
-
-  
-    Page layout.
-  >
-
-  
-
-  >
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  >
-
-  >
-
-  >
-
-  
-    Sectionning macros.
-  >
-
-  >>>>>>>
-
-  ||
-  >>>>>>>>>
-
-  >|UPCASE>>>>>>>
-
-  ||UPCASE>>>>>
-
-  >>>>>>>
-
-  >>>>>>>
-
-  >>>>>>>
-
-  >>>>>>>>
-
-  
-
-  
-    |arabic>>>
-
-    
-    : >
-  >
-
-  
-    Section and environment numbering.
-  >
-
-  >>
-
-  >>
-
-  
-    
-  >>
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  |Roman>.>>
-
-  
-
-  |>.>>
-
-  .>>
-
-  |alpha>.>>
-
-  
-
-  
-    Headers and footers.
-  >
-
-  ||>>>>>>
-
-  
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  
-    Footnotes.
-  >
-
-  
-
-  |alpha>>>
-
-  
-    >>|>>|>>>|>)>|>||body>|>>>>>
-  >>>
-
-  |>>>>>)>>>>
-
-  <\active*>
-    <\src-comment>
-      List environments.
-    
-  
-
-  |||>>>>|>|par-par-sep||>>>>|>>>>
-
-  \;
-
-  >>>>
-
-  >>>>
-
-  >>>>
-
-  >>>>
-
-  |>>
-
-  |>>
-
-  |>>
-
-  |>>
-
-  \;
-
-  >
-
-  \;
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  \;
-
-  >
-
-  >
-
-  >
-
-  >
-
-  \;
-
-  >
-
-  >
-
-  >
-
-  >
-
-  \;
-
-  
-
-  |arabic>>>
-
-  |alpha>>>
-
-  |roman>>>
-
-  |Alpha>>>
-
-  |>>>
-
-  |>>>
-
-  |>>>
-
-  |>>>
-
-  |1>|4>|1>>>
-
-  
-    Rendering of tables.
-  >
-
-  >>
-
-  >>
-
-  |Roman>>>
-
-  |tabular*||>>>
-
-  >>>
-
-  ||||>>>
-
-  ||||>>>>
-
-  |w>|0>>|>|w>|0>>|>|>>>
-
-  
-    <\big-table-enlarge|>
-      <\surround||>
-        <\render-big-table>
-          table
-        
-        ||>
-      
-    
-  >
-
-  
-    |||||||
-      >|>|>
-        
-      >
-    >|>|>>>>>>
-  >
-
-  
-    Rendering of figures.
-  >
-
-  >>
-
-  >>>
-
-  >>
-
-  
-    <\surround||>
-      
-      ||>
-    
-  >
-
-  >>
-
-  
-
-  
-
-  
-
-  
-    >||>|>|>|>|>|>>|>|
-      >|>|>
-        
-      >
-    >>>>>
-  >
-
-  <\active*>
-    <\src-comment>
-      Bibliography.
-    
-  
-
-  
-
-  ] >>
-
-  >>>
-
-  >|>||w.>>>>>>>
-
-  
-    <\small>
-      <\with|bibitem-width|>.|w.>|2em>|item-hsep||bibitem-nr|0|par-flexibility|2.0>
-        <\description>
-          
-        
-      
-    
-  >
-
-  >>
-
-  
-    <\with|par-columns|1>
-      |||||||||||||||||||>|||||||||>>>>
-    
-  >
-
-  >>
-
-  
-    >
-
-    
-  >
-
-  
-    Title rendering.
-  >
-
-  >>|0>>|)>>>>>>
-
-  |alpha>>>
-
-  >>
-
-  >>>>
-
-  
-    ||>>>
-  >
-
-  
-    <\quasi>
-      |author-name>>
-
-      |author-affiliation>>
-    
-  >
-
-  
-    |author-homepage|>>
-
-    |author-note|document|>>
-  >>
-
-  )>>>
-
-  
-
-  |>>>>
-
-  >>>
-
-  
-    <\with|par-columns|1>
-      <\with|par-mode|right>
-        |||
-          
-        >>>>
-      
-    
-  >
-
-  |>>>>
-
-  |>
-    >>>
-  >>
-
-  >
-
-  >>
-
-  
-    <\style-with|src-compact|none>
-      <\quasi>
-        >
-      
-    
-  >
-
-  >>
-
-  >>
-
-  
-    Customization of other environments.
-  >
-
-  >>
-
-  
-    Specific macros from Revtex style.
-  >
-
-  
-    |||||||>>>>
-
-    
-
-    |||||||>>>>
-  >>>
-
-  
-    >
-
-    
-  >
-
-  
-    Font sizes and AIP layout from Revtex.
-  >
-
-  |pt>>
-
-
-
->
\ No newline at end of file
diff --git a/TeXmacs/plugins/latex/styles/article/revtex/aps.stem b/TeXmacs/plugins/latex/styles/article/revtex/aps.stem
new file mode 100644
index 0000000000..6a82d1d641
--- /dev/null
+++ b/TeXmacs/plugins/latex/styles/article/revtex/aps.stem
@@ -0,0 +1,684 @@
+(document (TeXmacs "1.99.19")
+  (style "source")
+  (body (document (active* (document (src-title (document (src-style-file "aps" "1.0")
+                                                  (src-purpose (document "The Revtex's American Physical Society style."))
+                                                  (src-copyright "2012--2012" (document "Joris van der Hoeven, Franois Poulain"))
+                                                  (src-license (document (concat "This software falls under the "
+                                                                           (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE")
+                                                                           ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see "
+                                                                           (hlink "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                             "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                           ) ;hlink
+                                                                           "."
+                                                                         ) ;concat
+                                                               ) ;document
+                                                  ) ;src-license
+                                                ) ;document
+                                     ) ;src-title
+                           ) ;document
+                  ) ;active*
+          (use-package "std" "env" "header-generic" "section-book"
+            "title-generic" "std-latex" "cite-author-year" "std-automatic"
+            "two-columns" "html-font-size"
+          ) ;use-package
+          (active* (src-comment (document "Page layout.")))
+          (assign "par-first" "1em")
+          (assign "parindent" (value "par-first"))
+          (assign "page-type" "a4")
+          (assign "par-columns" "2")
+          (assign "tex-odd-side-margin" "0pt")
+          (assign "tex-even-side-margin" "0pt")
+          (assign "tex-margin-par-width" "60pt")
+          (assign "tex-margin-par-sep" "10pt")
+          (assign "tex-top-margin" "-37pt")
+          (assign "tex-head-height" "12pt")
+          (assign "tex-head-sep" "25pt")
+          (assign "tex-top-skip" "25pt")
+          (assign "tex-text-height" "665.5pt")
+          (assign "tex-text-width" "468pt")
+          (assign "tex-column-sep" "10pt")
+          (assign "tex-footnote-sep" "10pt")
+          (assign "tex-float-sep" (texlen "14pt" "2pt" "4pt"))
+          (assign "tex-text-float-sep" (texlen "20pt" "2pt" "4pt"))
+          (assign "tex-in-text-sep" (texlen "14pt" "2pt" "4pt"))
+          (active* (src-comment (document "Sectionning macros.")))
+          (style-with "src-compact"
+            "none"
+            (assign "part-title"
+              (style-with "src-compact"
+                "none"
+                (macro "name"
+                  (style-with "src-compact"
+                    "none"
+                    (sectional-normal-bold (concat (vspace* "4ex") (really-huge (arg "name")) (vspace "3ex") (new-line))
+                    ) ;sectional-normal-bold
+                  ) ;style-with
+                ) ;macro
+              ) ;style-with
+            ) ;assign
+          ) ;style-with
+          (style-with "src-compact"
+            "none"
+            (assign (style-with "src-compact" "none" "part-numbered-title")
+              (style-with "src-compact"
+                "none"
+                (macro (style-with "src-compact" "all" "name")
+                  (style-with "src-compact"
+                    "none"
+                    (sectional-short-bold (concat (vspace* "4ex")
+                                            (very-large (concat (part-text) " " (the-part) (new-line) (vspace* (value "parindent")))
+                                            ) ;very-large
+                                            (huge (arg "name"))
+                                            (vspace "3ex")
+                                            (new-line)
+                                          ) ;concat
+                    ) ;sectional-short-bold
+                  ) ;style-with
+                ) ;macro
+              ) ;style-with
+            ) ;assign
+          ) ;style-with
+          (assign "section-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-centered-bold (concat (vspace* (tex-len "0.8cm" "1ex" "0.2ex"))
+                                           (small (change-case (arg "name") "UPCASE"))
+                                           (vspace "0.5cm")
+                                         ) ;concat
+                ) ;sectional-centered-bold
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "section-numbered-title"
+            (macro "name"
+              (section-title (sectional-prefixed (concat (the-section) (section-sep))
+                               (concat (change-case (arg "name") "UPCASE") (section-post-sep))
+                             ) ;sectional-prefixed
+              ) ;section-title
+            ) ;macro
+          ) ;assign
+          (assign "subsection-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-centered-bold (concat (vspace* (tex-len "0.8cm" "1ex" "0.2ex"))
+                                           (small (arg "name"))
+                                           (vspace "0.5cm")
+                                         ) ;concat
+                ) ;sectional-centered-bold
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "subsubsection-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-centered-italic (concat (vspace* (tex-len "0.8cm" "1ex" "0.2ex"))
+                                             (small (arg "name"))
+                                             (vspace "0.5cm")
+                                           ) ;concat
+                ) ;sectional-centered-italic
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "paragraph-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-short-italic (concat (space (parindent))
+                                          (normal-size (arg "name"))
+                                          (space (value "parindent"))
+                                          (vspace "-1em")
+                                        ) ;concat
+                ) ;sectional-short-italic
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "subparagraph-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-short-bold (concat (vspace* (tex-len "3.25ex" "1ex" "0.2ex"))
+                                        (space (value "parindent"))
+                                        (normal-size (arg "name"))
+                                        (space (value "parindent"))
+                                        (vspace "-1em")
+                                      ) ;concat
+                ) ;sectional-short-bold
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "appendix-text" "Appendix")
+          (assign "appendix-numbered-title"
+            (macro "title"
+              (document (assign "display-equation"
+                          (macro "nr" (concat (the-appendix) (number (arg "nr") "arabic")))
+                        ) ;assign
+                (concat (assign "subsection-display" "arabic")
+                  (subsection-title (concat (appendix-text) " " (the-appendix) ": " (arg "title"))
+                  ) ;subsection-title
+                ) ;concat
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (active* (src-comment (document "Section and environment numbering.")))
+          (assign "sectional-sep" (macro (space "1.1fn")))
+          (assign "section-clean" (macro (reset-subsection)))
+          (style-with "src-compact"
+            "all"
+            (assign "display-std-env" (macro "nr" (document (arg "nr"))))
+          ) ;style-with
+          (assign "part-display-numbers" (macro "true"))
+          (assign "section-display-numbers" (macro "true"))
+          (assign "subsection-display-numbers" (macro "true"))
+          (assign "subsubsection-display-numbers" (macro "true"))
+          (assign "paragraph-display-numbers" (macro "true"))
+          (assign "subparagraph-display-numbers" (macro "false"))
+          (assign "display-section" (macro "nr" (concat (number (arg "nr") "Roman") ".")))
+          (assign "subsection-display" "Alpha")
+          (assign "display-subsection"
+            (macro "nr" (number (arg "nr") (subsection-display)))
+          ) ;assign
+          (assign "display-subsubsection" (macro "nr" (concat (arg "nr") ".")))
+          (assign "display-paragraph"
+            (macro "nr" (concat (number (arg "nr") "alpha") "."))
+          ) ;assign
+          (assign "display-subparagraph" "")
+          (active* (src-comment (document "Headers and footers.")))
+          (set-header (concat (no-indent)
+                        (tabular (tformat (twith "table-width" "1par")
+                                   (cwith "1" "-1" "1" "1" "cell-halign" "r")
+                                   (table (row (cell (page-number))))
+                                 ) ;tformat
+                        ) ;tabular
+                      ) ;concat
+          ) ;set-header
+          (set-footer "")
+          (assign "header-title" (macro "name" ""))
+          (assign "header-author" (macro "name" ""))
+          (assign "header-primary" (macro "name" "nr" "what" ""))
+          (assign "header-secondary" (macro "name" "nr" "what" ""))
+          (assign "start-page" (macro "s" ""))
+          (active* (src-comment (document "Footnotes.")))
+          (assign "footnote-sep" "")
+          (assign "render-footnote"
+            (macro "nr"
+              "body"
+              (style-with "src-compact"
+                "none"
+                (float "footnote"
+                  ""
+                  (document (smaller (with "par-mode"
+                                       "justify"
+                                       "par-left"
+                                       "0cm"
+                                       "par-right"
+                                       "0cm"
+                                       (style-with "src-compact"
+                                         "none"
+                                         (surround (concat (rsup (locus (id (hard-id (arg "body")))
+                                                                   (link "hyperlink"
+                                                                     (id (hard-id (arg "body")))
+                                                                     (url (merge "#footnr-" (arg "nr")))
+                                                                   ) ;link
+                                                                   (arg "nr")
+                                                                 ) ;locus
+                                                           ) ;rsup
+                                                     (footnote-sep)
+                                                   ) ;concat
+                                           (concat (set-binding (merge "footnote-" (arg "nr")) (value "the-label") "body")
+                                             (right-flush)
+                                           ) ;concat
+                                           (style-with "src-compact" "none" (arg "body"))
+                                         ) ;surround
+                                       ) ;style-with
+                                     ) ;with
+                            ) ;smaller
+                  ) ;document
+                ) ;float
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (active* (document (src-comment (document "List environments."))))
+          (assign "render-list"
+            (macro "body"
+              (surround (no-page-break*)
+                (concat (right-flush) (no-indent*))
+                (with "par-left"
+                  (plus (value ,(merge "left-margin-"
+                                  (plus (itemize-level) (enumerate-level))))
+                    (value "par-left")
+                  ) ;plus
+                  "par-par-sep"
+                  (value ,(merge "par-par-sep-"
+                            (plus (itemize-level) (enumerate-level))))
+                  (arg "body")
+                ) ;with
+              ) ;surround
+            ) ;macro
+          ) ;assign
+          ""
+          (assign "item-1" (macro (active* (with "mode" "math" ""))))
+          (assign "item-2" (macro (active* (with "mode" "math" (rigid "-")))))
+          (assign "item-3" (macro (active* (math ""))))
+          (assign "item-4" (macro (active* (math ""))))
+          (new-list "itemize-1" (value "aligned-item") (macro "name" (item-tag)))
+          (new-list "itemize-2" (value "aligned-item") (macro "name" (item-tag)))
+          (new-list "itemize-3" (value "aligned-item") (macro "name" (item-tag)))
+          (new-list "itemize-4" (value "aligned-item") (macro "name" (item-tag)))
+          ""
+          (assign "item-hsep" (macro "6pt"))
+          ""
+          (assign "left-margin-0" "24pt")
+          (assign "left-margin-1" "24pt")
+          (assign "left-margin-2" "20pt")
+          (assign "left-margin-3" "16pt")
+          (assign "left-margin-4" "14pt")
+          (assign "left-margin-5" "6pt")
+          (assign "left-margin-6" "6pt")
+          ""
+          (assign "top-sep-0" (tex-len "10pt" "4pt" "6pt"))
+          (assign "top-sep-1" (tex-len "10pt" "4pt" "6pt"))
+          (assign "top-sep-2" (tex-len "5pt" "2.5pt" "1pt"))
+          (assign "top-sep-3" (tex-len "2.5pt" "1pt" "1pt"))
+          ""
+          (assign "par-par-sep-0" (tex-len "5pt" "2.5pt" "1pt"))
+          (assign "par-par-sep-1" (tex-len "5pt" "2.5pt" "1pt"))
+          (assign "par-par-sep-2" (tex-len "2.5pt" "1pt" "1pt"))
+          (assign "par-par-sep-3" (tex-len "0pt" "1pt" "1pt"))
+          ""
+          (assign "enumerate-level" "0")
+          (assign "enum-1" (macro "name" (number (arg "name") "arabic")))
+          (assign "enum-2" (macro "name" (number (arg "name") "alpha")))
+          (assign "enum-3" (macro "name" (number (arg "name") "roman")))
+          (assign "enum-4" (macro "name" (number (arg "name") "Alpha")))
+          (new-list "enumerate-1"
+            (value "aligned-dot-item")
+            (macro "name" (enum-tag (arg "name")))
+          ) ;new-list
+          (new-list "enumerate-2"
+            (value "aligned-item")
+            (macro "name" (enum-tag (arg "name")))
+          ) ;new-list
+          (new-list "enumerate-3"
+            (value "aligned-dot-item")
+            (macro "name" (enum-tag (arg "name")))
+          ) ;new-list
+          (new-list "enumerate-4"
+            (value "aligned-dot-item")
+            (macro "name" (enum-tag (arg "name")))
+          ) ;new-list
+          (assign "enumerate-reduce"
+            (macro "nr" (plus (mod (minus (arg "nr") "1") "4") "1"))
+          ) ;assign
+          (active* (src-comment (document "Rendering of tables.")))
+          (assign "table-text" (macro (localize "TABLE")))
+          (assign "list-of-tables-text" (macro (localize "List of Tables")))
+          (assign "the-table" (macro (number (value "table-nr") "Roman")))
+          (assign "ruledtabular"
+            (macro "body"
+              (with "tabular"
+                (value "ruled-tabular")
+                "tabular*"
+                (value "ruled-tabular*")
+                (arg "body")
+              ) ;with
+            ) ;macro
+          ) ;assign
+          (assign "table*" (macro "body" (with "par-columns" "1" (arg "body"))))
+          (assign "ruled-tabular"
+            (macro "body"
+              (tformat (twith "table-width" "1par")
+                (cwith "1" "1" "1" "-1" "cell-bborder" "0.5pt")
+                (cwith "1" "1" "1" "-1" "cell-tborder" "1pt")
+                (cwith "-1" "-1" "1" "-1" "cell-bborder" "1pt")
+                (arg "body")
+              ) ;tformat
+            ) ;macro
+          ) ;assign
+          (assign "ruled-tabular*"
+            (macro "body"
+              (with "par-columns"
+                "1"
+                (tformat (twith "table-width" "1par")
+                  (cwith "1" "1" "1" "-1" "cell-bborder" "0.5pt")
+                  (cwith "1" "1" "1" "-1" "cell-tborder" "1pt")
+                  (cwith "-1" "-1" "1" "-1" "cell-bborder" "1pt")
+                  (arg "body")
+                ) ;tformat
+              ) ;with
+            ) ;macro
+          ) ;assign
+          (assign "big-table-enlarge"
+            (macro "contents"
+              "body"
+              (if (greater (times "2" (look-up (box-info (arg "contents") "w") "0"))
+                    (look-up (box-info (space (tex-text-width)) "w") "0")
+                  ) ;greater
+                (with "par-columns" "1" (arg "body"))
+                (arg "body")
+              ) ;if
+            ) ;macro
+          ) ;assign
+          (assign "big-table"
+            (macro "body"
+              "caption"
+              (document (big-table-enlarge (arg "body")
+                          (document (surround (compound "next-table")
+                                      ""
+                                      (document (render-big-table (document "table")
+                                                  (concat (compound "table-text") " " (compound "the-table"))
+                                                  (arg "body")
+                                                  (arg "caption")
+                                                ) ;render-big-table
+                                      ) ;document
+                                    ) ;surround
+                          ) ;document
+                        ) ;big-table-enlarge
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "render-big-table"
+            (macro "type"
+              "name"
+              "fig"
+              "cap"
+              (document (padded-normal "1fn"
+                          "1fn"
+                          (tabular* (tformat (twith "table-width" "1par")
+                                      (cwith "1" "1" "1" "1" "cell-hyphen" "t")
+                                      (cwith "1" "-1" "1" "-1" "cell-lsep" "0spc")
+                                      (cwith "1" "-1" "1" "-1" "cell-rsep" "0spc")
+                                      (cwith "2" "2" "1" "1" "cell-height" "0.5fn")
+                                      (cwith "1" "1" "1" "1" "cell-lsep" "1.5fn")
+                                      (cwith "1" "1" "1" "1" "cell-rsep" "1.5fn")
+                                      (table (row (cell (document (small (surround (concat (figure-name (concat (arg "name") (figure-sep)))
+                                                                                     (list-caption (arg "type") (arg "cap"))
+                                                                                   ) ;concat
+                                                                           ""
+                                                                           (document (arg "cap"))
+                                                                         ) ;surround
+                                                                  ) ;small
+                                                        ) ;document
+                                                  ) ;cell
+                                             ) ;row
+                                        (row (cell ""))
+                                        (row (cell (arg "fig")))
+                                      ) ;table
+                                    ) ;tformat
+                          ) ;tabular*
+                        ) ;padded-normal
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (active* (src-comment (document "Rendering of figures.")))
+          (assign "figure-text" (macro (localize "FIG.")))
+          (assign "figure*" (macro "body" (with "par-columns" "1" (arg "body"))))
+          (assign "list-of-figures-text" (macro (localize "List of Figures")))
+          (assign "big-figure"
+            (macro "body"
+              "caption"
+              (document (surround (next-figure)
+                          ""
+                          (document (render-big-figure "figure"
+                                      (concat (figure-text) " " (the-figure))
+                                      (arg "body")
+                                      (arg "caption")
+                                    ) ;render-big-figure
+                          ) ;document
+                        ) ;surround
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "figure-name" (macro "name" (arg "name")))
+          (assign "caption-left-padding" "0fn")
+          (assign "caption-right-padding" "0fn")
+          (assign "figure-width" "1par")
+          (assign "render-big-figure"
+            (macro "type"
+              "name"
+              "fig"
+              "cap"
+              (document (padded-normal "1fn"
+                          "1fn"
+                          (tabular* (tformat (twith "table-width" (value "figure-width"))
+                                      (cwith "3" "3" "1" "1" "cell-hyphen" "t")
+                                      (cwith "1" "-1" "1" "-1" "cell-lsep" (value "figure-left-padding"))
+                                      (cwith "1" "-1" "1" "-1" "cell-rsep" (value "figure-right-padding"))
+                                      (cwith "2" "2" "1" "1" "cell-height" (value "figure-caption-sep"))
+                                      (cwith "3" "3" "1" "1" "cell-lsep" (value "caption-left-padding"))
+                                      (cwith "3" "3" "1" "1" "cell-rsep" (value "caption-right-padding"))
+                                      (table (row (cell (arg "fig")))
+                                        (row (cell ""))
+                                        (row (cell (document (small (surround (concat (figure-name (concat (arg "name") (figure-sep)))
+                                                                                (list-caption (arg "type") (arg "cap"))
+                                                                              ) ;concat
+                                                                      ""
+                                                                      (document (arg "cap"))
+                                                                    ) ;surround
+                                                             ) ;small
+                                                   ) ;document
+                                             ) ;cell
+                                        ) ;row
+                                      ) ;table
+                                    ) ;tformat
+                          ) ;tabular*
+                        ) ;padded-normal
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (active* (document (src-comment (document "Bibliography."))))
+          (assign "bibitem-width" "2em")
+          (assign "transform-bibitem" (macro "body" (concat "[" (arg "body") "] ")))
+          (assign "bib-list"
+            (macro "largest"
+              "body"
+              (document (small (document (with "bibitem-width"
+                                           (minimum (box-info (concat (transform-bibitem (arg "largest")) ".") "w.") "2em")
+                                           "item-hsep"
+                                           (value "bibitem-hsep")
+                                           "bibitem-nr"
+                                           "0"
+                                           "par-flexibility"
+                                           "2.0"
+                                           (document (description (document (arg "body"))))
+                                         ) ;with
+                               ) ;document
+                        ) ;small
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "bibliography-text" (macro (rule "9cm" "1pt")))
+          (assign "bibliography-text"
+            (macro (document (with "par-columns"
+                               "1"
+                               (document (tabular (tformat (cwith "1" "-1" "1" "-1" "cell-width" "0.04par")
+                                                    (cwith "1" "-1" "1" "-1" "cell-hmode" "exact")
+                                                    (cwith "1" "-1" "1" "-1" "cell-height" "0.1pt")
+                                                    (cwith "1" "-1" "1" "-1" "cell-vmode" "exact")
+                                                    (cwith "1" "1" "4" "6" "cell-bborder" "0.7pt")
+                                                    (cwith "1" "1" "3" "3" "cell-bborder" "0.5pt")
+                                                    (cwith "1" "1" "7" "7" "cell-bborder" "0.5pt")
+                                                    (cwith "1" "1" "8" "8" "cell-bborder" "0.4pt")
+                                                    (cwith "1" "1" "2" "2" "cell-bborder" "0.4pt")
+                                                    (cwith "1" "1" "1" "1" "cell-bborder" "0.3pt")
+                                                    (cwith "1" "1" "9" "9" "cell-bborder" "0.3pt")
+                                                    (table (row (cell "")
+                                                             (cell "")
+                                                             (cell "")
+                                                             (cell "")
+                                                             (cell "")
+                                                             (cell "")
+                                                             (cell "")
+                                                             (cell "")
+                                                             (cell "")
+                                                           ) ;row
+                                                      (row (cell "")
+                                                        (cell "")
+                                                        (cell "")
+                                                        (cell "")
+                                                        (cell "")
+                                                        (cell "")
+                                                        (cell "")
+                                                        (cell "")
+                                                        (cell "")
+                                                      ) ;row
+                                                    ) ;table
+                                                  ) ;tformat
+                                         ) ;tabular
+                               ) ;document
+                             ) ;with
+                   ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "render-bibliography"
+            (macro "name"
+              "body"
+              (document (with "par-columns" "1" (document (center (section* (arg "name")))))
+                (arg "body")
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (active* (src-comment (document "Title rendering.")))
+          (assign "by-text" (macro (localize "")))
+          (assign "author-render-name"
+            (macro "author"
+              (surround (vspace* "0.5fn") (vspace "0.5fn") (doc-author-block (arg "author")))
+            ) ;macro
+          ) ;assign
+          (assign "author-affiliation"
+            (macro "address"
+              (document (surround (vspace* "0.5fn")
+                          (vspace "0.5fn")
+                          (doc-author-block (with "font-shape" "italic" (arg "address")))
+                        ) ;surround
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "doc-author-main"
+            (macro "data"
+              (document (quasi (document (unquote* (select (quote-arg "data") "author-name"))
+                                 (unquote* (select (quote-arg "data") "author-affiliation"))
+                               ) ;document
+                        ) ;quasi
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "doc-author-data-note"
+            (xmacro "data"
+              (quasi (document (unquote* (select (quote-arg "data") "author-homepage" (pat-any)))
+                       (unquote* (select (quote-arg "data") "author-note" "document" (pat-any)))
+                     ) ;document
+              ) ;quasi
+            ) ;xmacro
+          ) ;assign
+          (assign "doc-date"
+            (macro "body"
+              (style-with "src-compact"
+                "none"
+                (doc-title-block (concat "(Dated: " (arg "body") ")"))
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "abstract-text" "")
+          (assign "render-abstract"
+            (macro "body"
+              (surround (vspace "2fn")
+                ""
+                (document (with "par-columns"
+                            "1"
+                            (document (with "par-mode"
+                                        "center"
+                                        (document (tabular (tformat (cwith "1" "1" "1" "1" "cell-width" "400pt")
+                                                             (cwith "1" "1" "1" "1" "cell-hmode" "exact")
+                                                             (cwith "1" "1" "1" "1" "cell-hyphen" "t")
+                                                             (table (row (cell (document (arg "body")))))
+                                                           ) ;tformat
+                                                  ) ;tabular
+                                        ) ;document
+                                      ) ;with
+                            ) ;document
+                          ) ;with
+                ) ;document
+              ) ;surround
+            ) ;macro
+          ) ;assign
+          (assign "doc-data"
+            (xmacro "args"
+              (with "par-columns" "1" (extern "doc-data" (quote-arg "args") ""))
+            ) ;xmacro
+          ) ;assign
+          (active* (src-comment (document "Customization of other environments.")))
+          (assign "table-of-contents-text" (macro (localize "Contents")))
+          (active* (src-comment (document "Specific macros from Revtex styles.")))
+          (style-with "src-compact"
+            "none"
+            (assign "widetext"
+              (macro "body"
+                (with "par-columns"
+                  "1"
+                  (document (tabular (tformat (twith "table-hmode" "exact")
+                                       (twith "table-width" "1par")
+                                       (cwith "1" "1" "1" "-1" "cell-height" "1ex")
+                                       (cwith "1" "1" "1" "-1" "cell-vmode" "exact")
+                                       (cwith "1" "-1" "1" "1" "cell-bborder" "0.1pt")
+                                       (cwith "1" "-1" "1" "1" "cell-rborder" "0.1pt")
+                                       (table (row (cell "") (cell "")))
+                                     ) ;tformat
+                            ) ;tabular
+                    (arg "body")
+                    (tabular (tformat (twith "table-hmode" "exact")
+                               (twith "table-width" "1par")
+                               (cwith "1" "1" "1" "2" "cell-height" "1ex")
+                               (cwith "1" "1" "1" "2" "cell-vmode" "exact")
+                               (cwith "1" "1" "2" "2" "cell-lborder" "0.1pt")
+                               (cwith "1" "1" "2" "2" "cell-tborder" "0.1pt")
+                               (table (row (cell "") (cell "")))
+                             ) ;tformat
+                    ) ;tabular
+                  ) ;document
+                ) ;with
+              ) ;macro
+            ) ;assign
+          ) ;style-with
+          (assign "acknowledgments*"
+            (macro "body" (document (section* (localize "Acknowledgments")) (arg "body")))
+          ) ;assign
+          (active* (src-comment (document "Abbreviations from APS style.")))
+          (assign "ao" (macro "Appl. Opt."))
+          (assign "ap" (macro "Appl. Phys."))
+          (assign "apl" (macro "Appl. Phys. Lett."))
+          (assign "apj" (macro "Astrophys. J."))
+          (assign "bell" (macro "Bell Syst. Tech. J."))
+          (assign "jqe" (macro "IEEE J. Quantum Electron."))
+          (assign "assp" (macro "IEEE Trans. Acoust. Speech Signal Process."))
+          (assign "aprop" (macro "IEEE Trans. Antennas Propag."))
+          (assign "mtt" (macro "IEEE Trans. Microwave Theory Tech."))
+          (assign "iovs" (macro "Invest. Ophthalmol. Vis. Sci."))
+          (assign "jcp" (macro "J. Chem. Phys."))
+          (assign "jmo" (macro "J. Mod. Opt."))
+          (assign "josa" (macro "J. Opt. Soc. Am."))
+          (assign "josaa" (macro "J. Opt. Soc. Am. A"))
+          (assign "josab" (macro "J. Opt. Soc. Am. B"))
+          (assign "jpp" (macro "J. Phys. (Paris)"))
+          (assign "nat" (macro "Nature (London)"))
+          (assign "oc" (macro "Opt. Commun."))
+          (assign "ol" (macro "Opt. Lett."))
+          (assign "pl" (macro "Phys. Lett."))
+          (assign "pra" (macro "Phys. Rev. A"))
+          (assign "prb" (macro "Phys. Rev. B"))
+          (assign "prc" (macro "Phys. Rev. C"))
+          (assign "prd" (macro "Phys. Rev. D"))
+          (assign "pre" (macro "Phys. Rev. E"))
+          (assign "prl" (macro "Phys. Rev. Lett."))
+          (assign "rmp" (macro "Rev. Mod. Phys."))
+          (assign "pspie" (macro "Proc. Soc. Photo-Opt. Instrum. Eng."))
+          (assign "sjqe" (macro "Sov. J. Quantum Electron."))
+          (assign "vr" (macro "Vision Res."))
+          (active* (src-comment (document "Font sizes and APS layout.")))
+          (use-package (merge "revtex-" (value "font-base-size") "pt"))
+        ) ;document
+  ) ;body
+  (initial (collection))
+) ;document
diff --git a/TeXmacs/plugins/latex/styles/article/revtex/aps.ts b/TeXmacs/plugins/latex/styles/article/revtex/aps.ts
deleted file mode 100644
index 6bc6d0bccc..0000000000
--- a/TeXmacs/plugins/latex/styles/article/revtex/aps.ts
+++ /dev/null
@@ -1,500 +0,0 @@
-
-
-
-
-<\body>
-  <\active*>
-    <\src-title>
-      
-
-      <\src-purpose>
-        The Revtex's American Physical Society style.
-      
-
-      <\src-copyright|2012--2012>
-        Joris van der Hoeven, Franois Poulain
-      
-
-      <\src-license>
-        This software falls under the . It comes WITHOUT ANY
-        WARRANTY WHATSOEVER. You should have received a copy of the license
-        which the software. If not, see .
-      
-    
-  
-
-  
-
-  
-    Page layout.
-  >
-
-  
-
-  >
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  >
-
-  >
-
-  >
-
-  
-    Sectionning macros.
-  >
-
-  >>>>>>>
-
-  ||
-  >>>>>>>>>
-
-  >|UPCASE>>>>>>
-
-  ||UPCASE>>>>>
-
-  >>>>>>
-
-  >>>>>>
-
-  >>>>>>>
-
-  >>>>>>>>
-
-  
-
-  
-    |arabic>>>
-
-    
-    : >
-  >
-
-  
-    Section and environment numbering.
-  >
-
-  >>
-
-  >>
-
-  
-    
-  >>
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  |Roman>.>>
-
-  
-
-  |>>>
-
-  .>>
-
-  |alpha>.>>
-
-  
-
-  
-    Headers and footers.
-  >
-
-  ||>>>>>>
-
-  
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  
-    Footnotes.
-  >
-
-  
-
-  
-    >>|>>|>>>|>>|>||body>|>>>>>
-  >>>
-
-  <\active*>
-    <\src-comment>
-      List environments.
-    
-  
-
-  |||>>>>|>|par-par-sep||>>>>|>>>>
-
-  \;
-
-  >>>>
-
-  >>>>
-
-  >>>>
-
-  >>>>
-
-  |>>
-
-  |>>
-
-  |>>
-
-  |>>
-
-  \;
-
-  >
-
-  \;
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  \;
-
-  >
-
-  >
-
-  >
-
-  >
-
-  \;
-
-  >
-
-  >
-
-  >
-
-  >
-
-  \;
-
-  
-
-  |arabic>>>
-
-  |alpha>>>
-
-  |roman>>>
-
-  |Alpha>>>
-
-  |>>>
-
-  |>>>
-
-  |>>>
-
-  |>>>
-
-  |1>|4>|1>>>
-
-  
-    Rendering of tables.
-  >
-
-  >>
-
-  >>
-
-  |Roman>>>
-
-  |tabular*||>>>
-
-  >>>
-
-  ||||>>>
-
-  ||||>>>>
-
-  |w>|0>>|>|w>|0>>|>|>>>
-
-  
-    <\big-table-enlarge|>
-      <\surround||>
-        <\render-big-table>
-          table
-        
-        ||>
-      
-    
-  >
-
-  
-    |||||||
-      >|>|>
-        
-      >
-    >|>|>>>>>>
-  >
-
-  
-    Rendering of figures.
-  >
-
-  >>
-
-  >>>
-
-  >>
-
-  
-    <\surround||>
-      
-      ||>
-    
-  >
-
-  >>
-
-  
-
-  
-
-  
-
-  
-    >||>|>|>|>|>|>>|>|
-      >|>|>
-        
-      >
-    >>>>>
-  >
-
-  <\active*>
-    <\src-comment>
-      Bibliography.
-    
-  
-
-  
-
-  ] >>
-
-  
-    <\small>
-      <\with|bibitem-width|>.|w.>|2em>|item-hsep||bibitem-nr|0|par-flexibility|2.0>
-        <\description>
-          
-        
-      
-    
-  >
-
-  >>
-
-  
-    <\with|par-columns|1>
-      |||||||||||||||||||>|||||||||>>>>
-    
-  >
-
-  
-    <\with|par-columns|1>
-      >>
-    
-
-    
-  >
-
-  
-    Title rendering.
-  >
-
-  >>
-
-  ||>>>>
-
-  
-    ||>>>
-  >
-
-  
-    <\quasi>
-      |author-name>>
-
-      |author-affiliation>>
-    
-  >
-
-  
-    |author-homepage|>>
-
-    |author-note|document|>>
-  >>
-
-  )>>>>
-
-  
-
-  |>
-    <\with|par-columns|1>
-      <\with|par-mode|center>
-        |||
-          
-        >>>>
-      
-    
-  >>
-
-  |>>>>
-
-  
-    Customization of other environments.
-  >
-
-  >>
-
-  
-    Specific macros from Revtex styles.
-  >
-
-  
-    |||||||>>>>
-
-    
-
-    |||||||>>>>
-  >>>
-
-  
-    >
-
-    
-  >
-
-  
-    Abbreviations from APS style.
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  
-    Font sizes and APS layout.
-  >
-
-  |pt>>
-
-
-
->
\ No newline at end of file
diff --git a/TeXmacs/plugins/latex/styles/article/springer/llncs.stem b/TeXmacs/plugins/latex/styles/article/springer/llncs.stem
new file mode 100644
index 0000000000..3fe7c81dba
--- /dev/null
+++ b/TeXmacs/plugins/latex/styles/article/springer/llncs.stem
@@ -0,0 +1,127 @@
+(document (TeXmacs "1.0.7.17")
+  (style "source")
+  (body (document (active* (document (src-title (document (src-style-file "llncs" "1.0")
+                                                  (src-purpose (document "The style for Lecture Notes in Computer Science."))
+                                                  (src-copyright "2012" (document "Joris van der Hoeven and Franois Poulain"))
+                                                  (src-license (document (concat "This software falls under the "
+                                                                           (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE")
+                                                                           ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see "
+                                                                           (hlink "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                             "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                           ) ;hlink
+                                                                           "."
+                                                                         ) ;concat
+                                                               ) ;document
+                                                  ) ;src-license
+                                                ) ;document
+                                     ) ;src-title
+                           ) ;document
+                  ) ;active*
+          (use-package "article" "std-latex" "section-base")
+          (active* (src-comment "Global layout parameters"))
+          (assign "tex-odd-side-margin" (macro "63pt"))
+          (assign "tex-even-side-margin" (macro "63pt"))
+          (assign "tex-text-width" (macro "12.2cm"))
+          (assign "tex-text-height" (macro "19.3cm"))
+          (assign "tex-footnote-sep" (macro "7.7pt"))
+          (assign "tex-margin-par-width" (macro "90pt"))
+          (assign "tex-below-display-skip" (macro (tex-above-display-skip)))
+          (active* (src-comment "Font sizes"))
+          (active* (src-comment "Sectional macros"))
+          (assign "section-title"
+            (macro "name"
+              (sectional-normal (with "font-size"
+                                  "1.19"
+                                  "font-series"
+                                  "bold"
+                                  "math-font-series"
+                                  "bold"
+                                  (concat (vspace* (tex-len "18pt" "4pt" "4pt"))
+                                    (hspace "0pt")
+                                    (arg "name")
+                                    (vspace (tex-len "12pt" "4pt" "4pt"))
+                                  ) ;concat
+                                ) ;with
+              ) ;sectional-normal
+            ) ;macro
+          ) ;assign
+          (assign "subsection-title"
+            (macro "name"
+              (sectional-normal (with "font-size"
+                                  "1"
+                                  "font-series"
+                                  "bold"
+                                  "math-font-series"
+                                  "bold"
+                                  (concat (vspace* (tex-len "18pt" "4pt" "4pt"))
+                                    (hspace "0pt")
+                                    (arg "name")
+                                    (vspace (tex-len "8pt" "4pt" "4pt"))
+                                  ) ;concat
+                                ) ;with
+              ) ;sectional-normal
+            ) ;macro
+          ) ;assign
+          (assign "subsubsection-title"
+            (macro "name"
+              (with "font-size"
+                "1"
+                "font-series"
+                "bold"
+                "math-font-series"
+                "bold"
+                (concat (vspace* (tex-len "18pt" "4pt" "4pt"))
+                  (hspace "0pt")
+                  (arg "name")
+                  (hspace (tex-len "0.5em" "0.22em" "0.1em"))
+                ) ;concat
+              ) ;with
+            ) ;macro
+          ) ;assign
+          (assign "paragraph-title"
+            (macro "name"
+              (with "font-size"
+                "1"
+                "font-shape"
+                "italic"
+                (concat (vspace* (tex-len "12pt" "4pt" "4pt"))
+                  (hspace "0pt")
+                  (arg "name")
+                  (hspace (tex-len "0.5em" "0.22em" "0.1em"))
+                ) ;concat
+              ) ;with
+            ) ;macro
+          ) ;assign
+          (active* (src-comment "Theorems-like macros"))
+          (active* (src-comment "Itemize lists"))
+          (assign "itemize-1"
+            (macro "body"
+              (list (macro "name" (aligned-item (with "font-series" "bold" "--")))
+                (macro "x" (arg "x"))
+                (arg "body")
+              ) ;list
+            ) ;macro
+          ) ;assign
+          (assign "itemize-2"
+            (macro "body"
+              (list (macro "name" (aligned-item (math "")))
+                (macro "x" (arg "x"))
+                (arg "body")
+              ) ;list
+            ) ;macro
+          ) ;assign
+          (assign "itemize-reduce" (macro "nr" (minimum (arg "nr") "2")))
+          (active* (src-comment "Enumerate lists"))
+          (active* (src-comment "Counter rendering"))
+          (active* (src-comment "Customization of environments"))
+          (active* (src-comment "Headers and footers"))
+          (active* (src-comment "Rendering of floating objects"))
+          (active* (src-comment "Title rendering"))
+          (active* (src-comment "Bibliography"))
+          (active* (src-comment "Miscellaneous macros provided by the style"))
+          (active* (src-comment "Tables of contents"))
+          (active* (src-comment "Indexes and glossaries"))
+        ) ;document
+  ) ;body
+  (initial (collection (associate "preamble" "true")))
+) ;document
diff --git a/TeXmacs/plugins/latex/styles/article/springer/llncs.ts b/TeXmacs/plugins/latex/styles/article/springer/llncs.ts
deleted file mode 100644
index fb055add01..0000000000
--- a/TeXmacs/plugins/latex/styles/article/springer/llncs.ts
+++ /dev/null
@@ -1,92 +0,0 @@
-
-
-
-
-<\body>
-  <\active*>
-    <\src-title>
-      
-
-      <\src-purpose>
-        The style for Lecture Notes in Computer Science.
-      
-
-      <\src-copyright|2012>
-        Joris van der Hoeven and Franois Poulain
-      
-
-      <\src-license>
-        This software falls under the . It comes WITHOUT ANY
-        WARRANTY WHATSOEVER. You should have received a copy of the license
-        which the software. If not, see .
-      
-    
-  
-
-  
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >>
-
-  >
-
-  >
-
-  >>>>>>
-
-  >>>>>>
-
-  >>>>>
-
-  >>>>>
-
-  >
-
-  >
-
-  >>|>|>>>
-
-  >>>|>|>>>
-
-  |2>>>
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-
-<\initial>
-  <\collection>
-    
-  
-
\ No newline at end of file
diff --git a/TeXmacs/plugins/latex/styles/article/springer/svjour.stem b/TeXmacs/plugins/latex/styles/article/springer/svjour.stem
new file mode 100644
index 0000000000..33893d2e7b
--- /dev/null
+++ b/TeXmacs/plugins/latex/styles/article/springer/svjour.stem
@@ -0,0 +1,540 @@
+(document (TeXmacs "1.99.19")
+  (style "source")
+  (body (document (active* (document (src-title (document (src-style-file "svjour" "1.0")
+                                                  (src-purpose (document "The SVJour style."))
+                                                  (src-copyright "2004--2005"
+                                                    (document "Joris van der Hoeven and Adrien Bourdet")
+                                                  ) ;src-copyright
+                                                  (src-license (document (concat "This software falls under the "
+                                                                           (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE")
+                                                                           ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see "
+                                                                           (hlink "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                             "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                           ) ;hlink
+                                                                           "."
+                                                                         ) ;concat
+                                                               ) ;document
+                                                  ) ;src-license
+                                                ) ;document
+                                     ) ;src-title
+                           ) ;document
+                  ) ;active*
+          (use-package "std" "env-base" "env-math" "env-enunciation" "env-float"
+            "env-program" "header-article" "title-base" "section-article"
+            "std-latex" "html-font-size"
+          ) ;use-package
+          (assign "env-theorem-dtd" "1.0")
+          (active* (src-comment (document "TeX-like style parameters.")))
+          (assign "tex-odd-side-margin"
+            (macro (if (equal (value "par-columns") "1") "0pt" "-30pt"))
+          ) ;assign
+          (assign "tex-even-side-margin"
+            (macro (if (equal (value "par-columns") "1") "0pt" "-30pt"))
+          ) ;assign
+          (assign "tex-text-width"
+            (macro (if (equal (value "par-columns") "1") "25.5cc" "17.8cm"))
+          ) ;assign
+          ""
+          (assign "tex-voffset" (macro "0pt"))
+          (assign "tex-top-margin" (macro "-10pt"))
+          (assign "tex-head-height" (macro "12pt"))
+          (assign "tex-head-sep" (macro "16.74pt"))
+          (assign "tex-top-skip" (macro "10pt"))
+          (assign "tex-text-height"
+            (macro (if (equal (value "par-columns") "1") "517.5dd" "640dd"))
+          ) ;assign
+          (assign "tex-foot-height-heuristic" (macro "1em"))
+          (assign "tex-foot-skip" (macro "30pt"))
+          ""
+          (assign "tex-footnote-sep" (macro "8pt"))
+          (assign "tex-footnote-tm-barlen" (macro "0.4par"))
+          (assign "tex-column-sep" (macro "1.5cc"))
+          (assign "tex-float-sep" (macro (tmlen "10pt" "12pt" "14pt")))
+          (assign "tex-margin-par-width" (macro "48pt"))
+          (assign "tex-margin-par-sep" (macro "10pt"))
+          (active* (src-comment (document "Global layout.")))
+          (assign "font-base-size" "10")
+          (assign "par-sep" "0.2em")
+          (assign "par-first" "15pt")
+          ""
+          (assign "tex-jot" (macro "2pt"))
+          (assign "tex-above-display-skip" (macro (tex-len "3mm" "6pt" "4pt")))
+          (assign "tex-below-display-skip" (macro (tex-len "3mm" "6pt" "4pt")))
+          (active* (src-short-comment "orig- for original value"))
+          (assign "orig-tex-above-display-short-skip" (macro (tex-len "2mm" "6pt" "0pt")))
+          (assign "tex-above-display-short-skip" (macro (tex-len "1mm" "6pt" "0pt")))
+          (assign "tex-below-display-short-skip" (macro (tex-len "2mm" "4pt" "4pt")))
+          (active* (src-comment (document "Sizes.")))
+          (assign "tiny" (macro "x" (with "font-size" "0.5" "par-sep" "1pt" (arg "x"))))
+          (assign "very-small"
+            (macro "x" (with "font-size" "0.7" "par-sep" "1pt" (arg "x")))
+          ) ;assign
+          (assign "smaller"
+            (macro "x" (with "font-size" "0.9" "par-sep" "2pt" (arg "x")))
+          ) ;assign
+          (assign "small"
+            (macro "x"
+              (style-with "src-compact"
+                "none"
+                (with "font-size"
+                  "0.9"
+                  "par-sep"
+                  "2pt"
+                  "tex-above-display-skip"
+                  (macro (tex-len "8.5pt" "3pt" "4pt"))
+                  "tex-below-display-skip"
+                  (macro (tex-len "8.5pt" "3pt" "4pt"))
+                  "tex-above-display-short-skip"
+                  (macro (tex-len "0pt" "2pt" "0pt"))
+                  "tex-below-display-short-skip"
+                  (macro (tex-len "4pt" "2pt" "2pt"))
+                  (arg "x")
+                ) ;with
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "normal-size"
+            (macro "x"
+              (style-with "src-compact"
+                "none"
+                (with "font-size"
+                  "1.0"
+                  "par-sep"
+                  "0.2em"
+                  "tex-above-display-skip"
+                  (macro (tex-len "3mm" "6pt" "4pt"))
+                  "tex-below-display-skip"
+                  (macro (tex-len "3mm" "6pt" "4pt"))
+                  "tex-above-display-short-skip"
+                  (macro (tex-len "0mm" "6pt" "0pt"))
+                  "tex-below-display-short-skip"
+                  (macro (tex-len "2mm" "4pt" "4pt"))
+                  (arg "x")
+                ) ;with
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "large" (macro "x" (with "font-size" "1.2" "par-sep" "2pt" (arg "x"))))
+          (assign "larger"
+            (macro "x"
+              (with "font-size"
+                "1.4"
+                "par-sep"
+                (minus (tmlen "16dd") (tmlen "14pt"))
+                (arg "x")
+              ) ;with
+            ) ;macro
+          ) ;assign
+          (assign "very-large"
+            (macro "x"
+              (with "font-size"
+                "1.7"
+                "par-sep"
+                (minus (tmlen "17dd") (tmlen "17pt"))
+                (arg "x")
+              ) ;with
+            ) ;macro
+          ) ;assign
+          (assign "huge" (macro "x" (with "font-size" "2.0" "par-sep" "5pt" (arg "x"))))
+          (assign "really-huge"
+            (macro "x" (with "font-size" "2.5" "par-sep" "5pt" (arg "x")))
+          ) ;assign
+          (active* (src-comment (document "Sectional macros.")))
+          (assign "section-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-normal-bold (style-with "src-compact"
+                                         "none"
+                                         (concat (vspace* (tex-len "21dd" "4pt" "4pt"))
+                                           (normal-size (arg "name"))
+                                           (vspace (tex-len "10.5dd" "4pt" "4pt"))
+                                         ) ;concat
+                                       ) ;style-with
+                ) ;sectional-normal-bold
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "subsection-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-normal-italic (style-with "src-compact"
+                                           "none"
+                                           (concat (vspace* (tex-len "21dd" "4pt" "4pt"))
+                                             (normal-size (arg "name"))
+                                             (vspace (tex-len "10.5dd" "4pt" "4pt"))
+                                           ) ;concat
+                                         ) ;style-with
+                ) ;sectional-normal-italic
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "subsubsection-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-short-italic (concat (vspace* (tex-len "13dd" "4pt" "4pt"))
+                                          (normal-size (arg "name"))
+                                          (space "5.5pt")
+                                        ) ;concat
+                ) ;sectional-short-italic
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "paragraph-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-short-italic (concat (vspace* (tex-len "13dd" "4pt" "4pt"))
+                                          (normal-size (arg "name"))
+                                          (space "5.5pt")
+                                        ) ;concat
+                ) ;sectional-short-italic
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (active* (src-comment (document "Section and environment numbering.")))
+          (assign "sectional-sep" (macro (space "0.3fn")))
+          (assign "part-sep" (macro (concat "." (space "0.6fn"))))
+          (assign "paragraph-display-numbers" (macro "true"))
+          (assign "subparagraph-display-numbers" (macro "true"))
+          (active* (document (src-comment (document "Headers."))))
+          (assign "header-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (concat (simple-page)
+                  (assign "page-odd-header"
+                    (small (style-with "src-compact"
+                             "none"
+                             (concat (no-indent) (arg "name") (htab "5mm") (page-number))
+                           ) ;style-with
+                    ) ;small
+                  ) ;assign
+                ) ;concat
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "header-author"
+            (macro "name"
+              (assign "page-even-header"
+                (small (style-with "src-compact"
+                         "none"
+                         (concat (no-indent) (page-number) (htab "5mm") (arg "name"))
+                       ) ;style-with
+                ) ;small
+              ) ;assign
+            ) ;macro
+          ) ;assign
+          (assign "header-primary" (macro "name" "nr" "what" ""))
+          (assign "header-secondary" (macro "name" "nr" "what" ""))
+          (active* (src-comment (document "Theorem-like environemments rendering.")))
+          (group-common-counter "theorem-env")
+          (assign "enunciation-sep" (macro (space "1spc")))
+          (assign "env-number" (macro "num" (arg "num")))
+          (assign "remark-name" (macro "name" (with "font-shape" "italic" (arg "name"))))
+          (assign "smart-qed" (macro ""))
+          ""
+          (assign "render-enunciation"
+            (macro "which"
+              "body"
+              (document (padded-normal "1fn" "1fn" (surround (arg "which") "" (arg "body"))))
+            ) ;macro
+          ) ;assign
+          (assign "render-exercise"
+            (macro "which"
+              "body"
+              (document (padded-normal "1fn"
+                          "1fn"
+                          (surround (exercise-name (concat (arg "which") (exercise-sep))) "" (arg "body"))
+                        ) ;padded-normal
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "render-proof"
+            (macro "which"
+              "body"
+              (document (surround ""
+                          (smart-qed)
+                          (document (render-remark (arg "which") (document (arg "body"))))
+                        ) ;surround
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (active* (src-comment (document "Theorem-like environments.")))
+          (new-theorem "theorem" "Theorem")
+          (new-theorem "corollary" "Corollary")
+          (new-theorem "definition" "Definition")
+          (new-theorem "lemma" "Lemma")
+          (new-theorem "proposition" "Proposition")
+          ""
+          (new-exercise "exercise" "Exercise")
+          (new-exercise "problem" "Problem")
+          (new-exercise "solution" "Solution")
+          ""
+          (new-remark "math-case" "Case")
+          (new-remark "conjecture" "Conjecture")
+          (new-remark "example" "Example")
+          (new-remark "note" "Note")
+          (new-remark "property" "Property")
+          (new-remark "question" "Question")
+          (new-remark "remark" "Remark")
+          ""
+          (active* (src-short-comment (concat (TeXmacs) " environments")))
+          (new-theorem "axiom" "Axiom")
+          (new-theorem "notation" "Notation")
+          (new-remark "warning" "Warning")
+          (new-remark "acknowledgments" "Acknowledgments")
+          (active* (document (src-comment (document "Customization of other environments.")))
+          ) ;active*
+          (assign "figure-text" (macro (localize "Fig.")))
+          (assign "bibliography-text" (macro (localize "References")))
+          (assign "table-of-contents-text" (macro (localize "Table of Contents")))
+          (assign "list-of-figures-text" (macro (localize "List of Figures")))
+          (assign "list-of-tables-text" (macro (localize "List of Tables")))
+          (active* (document (src-comment (document "List environments."))))
+          (assign "aligned-item"
+            (macro "x"
+              (style-with "src-compact"
+                "none"
+                (concat (with "par-first" "-15pt" (yes-indent))
+                  (resize (concat (arg "x") " ") (minus "1r" "15pt") "" (plus "1r" "0pt") "")
+                ) ;concat
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "compact-item"
+            (macro "x"
+              (style-with "src-compact"
+                "none"
+                (concat (with "par-first" "-15pt" (yes-indent))
+                  (resize (arg "x") "" "" (maximum "1r" "15pt") "")
+                ) ;concat
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          ""
+          (assign "list-level" "0")
+          (assign "render-list"
+            (macro "body"
+              (document (padded-normal (if (equal (value "list-level") "0") "0.5fn" "0fn")
+                          (if (equal (value "list-level") "0") "0.5fn" "0fn")
+                          (document (indent-left "15pt"
+                                      (document (surround (no-page-break*)
+                                                  (no-indent*)
+                                                  (document (with "list-level"
+                                                              (plus (mod (value "list-level") "3") "1")
+                                                              (document (arg "body"))
+                                                            ) ;with
+                                                  ) ;document
+                                                ) ;surround
+                                      ) ;document
+                                    ) ;indent-left
+                          ) ;document
+                        ) ;padded-normal
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "bib-list-nosvjour" (value "bib-list"))
+          (assign "bib-list"
+            (macro "largest"
+              "body"
+              (document (bib-list-nosvjour (arg "largest")
+                          (document (with "par-left" (plus (value "par-left") "10pt") (document (arg "body")))
+                          ) ;document
+                        ) ;bib-list-nosvjour
+              ) ;document
+            ) ;macro
+          ) ;assign
+          ""
+          (assign "item-1" (macro (active* (with "mode" "math" (rigid "-")))))
+          (assign "item-2" (macro (active* (with "mode" "math" (rigid "-")))))
+          (assign "item-3" (macro (active* (with "mode" "math" ""))))
+          (new-list "itemize-1" (value "aligned-item") (macro "x" (item-tag)))
+          (new-list "itemize-2" (value "aligned-item") (macro "x" (item-tag)))
+          (new-list "itemize-3" (value "aligned-item") (macro "x" (item-tag)))
+          (new-list "itemize-minus"
+            (value "aligned-item")
+            (macro "x" (active* (with "mode" "math" (rigid "-"))))
+          ) ;new-list
+          (new-list "itemize-dot"
+            (value "aligned-item")
+            (macro "x" (active* (with "mode" "math" "")))
+          ) ;new-list
+          (new-list "itemize-arrow"
+            (value "aligned-item")
+            (macro "x" (active* (with "mode" "math" (rigid ""))))
+          ) ;new-list
+          ""
+          (assign "aligned-accolade-item"
+            (macro "x"
+              (aligned-item (with "font-shape" "right" (concat "{" (arg "x") "}")))
+            ) ;macro
+          ) ;assign
+          (assign "enum-1" (macro "name" (arg "name")))
+          (assign "enum-2" (macro "name" (number (arg "name") "alpha")))
+          (assign "enum-3" (macro "name" (number (arg "name") "roman")))
+          (new-list "enumerate-1"
+            (value "aligned-dot-item")
+            (macro "x" (enum-tag (arg "x")))
+          ) ;new-list
+          (new-list "enumerate-2"
+            (value "aligned-accolade-item")
+            (macro "x" (enum-tag (arg "x")))
+          ) ;new-list
+          (new-list "enumerate-3"
+            (value "aligned-dot-item")
+            (macro "x" (enum-tag (arg "x")))
+          ) ;new-list
+          ""
+          (assign "compact-dash-item"
+            (macro "x" (compact-item (concat (arg "x") " " (emdash) " ")))
+          ) ;assign
+          (assign "long-compact-space-item"
+            (macro "x" (item-long (compact-space-item (arg "x"))))
+          ) ;assign
+          (new-list "description-compact"
+            (value "compact-space-item")
+            (macro "x"
+              (active* (with "mode"
+                         "math"
+                         (with "font-series" "bold" "math-font-series" "bold" (rigid ""))
+                       ) ;with
+              ) ;active*
+            ) ;macro
+          ) ;new-list
+          (new-list "description-aligned"
+            (value "aligned-item")
+            (macro "x"
+              (active* (with "mode"
+                         "math"
+                         (with "font-series" "bold" "math-font-series" "bold" (rigid ""))
+                       ) ;with
+              ) ;active*
+            ) ;macro
+          ) ;new-list
+          (new-list "description-dash"
+            (value "compact-dash-item")
+            (macro "x"
+              (active* (with "mode"
+                         "math"
+                         (with "font-series" "bold" "math-font-series" "bold" (rigid ""))
+                       ) ;with
+              ) ;active*
+            ) ;macro
+          ) ;new-list
+          (new-list "description-long"
+            (value "long-compact-space-item")
+            (macro "x"
+              (active* (with "mode"
+                         "math"
+                         (with "font-series" "bold" "math-font-series" "bold" (rigid ""))
+                       ) ;with
+              ) ;active*
+            ) ;macro
+          ) ;new-list
+          (new-list "description"
+            (value "compact-space-item")
+            (macro "x"
+              (active* (with "mode"
+                         "math"
+                         (with "font-series" "bold" "math-font-series" "bold" (rigid ""))
+                       ) ;with
+              ) ;active*
+            ) ;macro
+          ) ;new-list
+          (active* (document (src-comment (document "Title information."))))
+          (assign "doc-title-block"
+            (macro "body"
+              (tabular (tformat (twith "table-width" "1par")
+                         (cwith "1" "1" "1" "1" "cell-lsep" "0spc")
+                         (cwith "1" "1" "1" "1" "cell-rsep" "0spc")
+                         (cwith "1" "1" "1" "1" "cell-bsep" "0spc")
+                         (cwith "1" "1" "1" "1" "cell-tsep" "0spc")
+                         (cwith "1" "1" "1" "1" "cell-hyphen" "t")
+                         (table (row (cell (document (with "par-first" "0fn" (arg "body"))))))
+                       ) ;tformat
+              ) ;tabular
+            ) ;macro
+          ) ;assign
+          (assign "doc-make-title"
+            (macro "body" (surround "" (vspace "22.47pt") (doc-title-block (arg "body"))))
+          ) ;assign
+          (assign "doc-render-title"
+            (macro "x"
+              (surround ""
+                (vspace "11.24pt")
+                (document (doc-title-block (larger (with "math-font-series" "bold" "font-series" "bold" (arg "x")))
+                          ) ;doc-title-block
+                ) ;document
+              ) ;surround
+            ) ;macro
+          ) ;assign
+          (assign "doc-subtitle"
+            (macro "x"
+              (surround ""
+                (vspace "11.24pt")
+                (document (doc-title-block (large (with "math-font-series" "bold" "font-series" "bold" (arg "x")))
+                          ) ;doc-title-block
+                ) ;document
+              ) ;surround
+            ) ;macro
+          ) ;assign
+          (assign "doc-date" (macro "body" (document (doc-title-block (arg "body")))))
+          (assign "render-abstract"
+            (macro "body"
+              (document (padded-normal "1fn"
+                          "1.85fn"
+                          (surround (concat (sectional-short-bold (abstract-text)) (space "4mm"))
+                            ""
+                            (arg "body")
+                          ) ;surround
+                        ) ;padded-normal
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (active* (document (src-comment (document "Author information."))))
+          (assign "doc-author-block"
+            (macro "body"
+              (document (style-with "src-compact"
+                          "none"
+                          (concat (space "0pt")
+                            (tabular (tformat (cwith "1" "1" "1" "1" "cell-lsep" "0spc")
+                                       (cwith "1" "1" "1" "1" "cell-rsep" "0spc")
+                                       (cwith "1" "1" "1" "1" "cell-bsep" "0spc")
+                                       (cwith "1" "1" "1" "1" "cell-tsep" "0spc")
+                                       (cwith "1" "1" "1" "1" "cell-hyphen" "t")
+                                       (cwith "1" "1" "1" "1" "cell-hmode" "min")
+                                       (cwith "1" "1" "1" "1" "cell-width" "1par")
+                                       (table (row (cell (document (arg "body")))))
+                                     ) ;tformat
+                            ) ;tabular
+                          ) ;concat
+                        ) ;style-with
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "author-by" (macro "body" (arg "body")))
+          (assign "author-render-name"
+            (macro "x"
+              (surround (vspace* "0.5fn")
+                (vspace "0.5fn")
+                (doc-author-block (with "font-series" "bold" (arg "x")))
+              ) ;surround
+            ) ;macro
+          ) ;assign
+          (assign "doc-authors-data"
+            (xmacro "data"
+              (document (style-with "src-compact"
+                          "none"
+                          (document (quasi (document (unquote* (quote-arg "data")))))
+                        ) ;style-with
+              ) ;document
+            ) ;xmacro
+          ) ;assign
+          ""
+        ) ;document
+  ) ;body
+  (initial (collection (associate "preamble" "true") (associate "sfactor" "6")))
+) ;document
diff --git a/TeXmacs/plugins/latex/styles/article/springer/svjour.ts b/TeXmacs/plugins/latex/styles/article/springer/svjour.ts
deleted file mode 100644
index 2e12546d8c..0000000000
--- a/TeXmacs/plugins/latex/styles/article/springer/svjour.ts
+++ /dev/null
@@ -1,408 +0,0 @@
-
-
-
-
-<\body>
-  <\active*>
-    <\src-title>
-      
-
-      <\src-purpose>
-        The SVJour style.
-      
-
-      <\src-copyright|2004--2005>
-        Joris van der Hoeven and Adrien Bourdet
-      
-
-      <\src-license>
-        This software falls under the . It comes WITHOUT ANY
-        WARRANTY WHATSOEVER. You should have received a copy of the license
-        which the software. If not, see .
-      
-    
-  
-
-  
-
-  
-
-  
-    TeX-like style parameters.
-  >
-
-  |1>|0pt|-30pt>>>
-
-  |1>|0pt|-30pt>>>
-
-  |1>|25.5cc|17.8cm>>>
-
-  \;
-
-  >
-
-  >
-
-  >
-
-  >
-
-  >
-
-  |1>|517.5dd|640dd>>>
-
-  >
-
-  >
-
-  \;
-
-  >
-
-  >
-
-  >
-
-  >>
-
-  >
-
-  >
-
-  
-    Global layout.
-  >
-
-  
-
-  
-
-  
-
-  \;
-
-  >
-
-  >>
-
-  >>
-
-  >
-
-  >>
-
-  >>
-
-  >>
-
-  
-    Sizes.
-  >
-
-  >>>
-
-  >>>
-
-  >>>
-
-  >|tex-below-display-skip|>|tex-above-display-short-skip|>|tex-below-display-short-skip|>|>>>>
-
-  >|tex-below-display-skip|>|tex-above-display-short-skip|>|tex-below-display-short-skip|>|>>>>
-
-  >>>
-
-  |>|>>>
-
-  |>|>>>
-
-  >>>
-
-  >>>
-
-  
-    Sectional macros.
-  >
-
-  >>>>>>>>
-
-  >>>>>>>>
-
-  >>>>>>
-
-  >>>>>>
-
-  
-    Section and environment numbering.
-  >
-
-  >>
-
-  >>
-
-  >
-
-  >
-
-  <\active*>
-    <\src-comment>
-      Headers.
-    
-  
-
-  >>>>>>
-
-  >>>>>
-
-  >
-
-  >
-
-  
-    Theorem-like environemments rendering.
-  >
-
-  
-
-  >>
-
-  >>
-
-  >>>
-
-  >
-
-  \;
-
-  
-    ||>>
-  >
-
-  
-    >||>>
-  >
-
-  
-    <\surround||>
-      <\render-remark|>
-        
-      
-    
-  >
-
-  
-    Theorem-like environments.
-  >
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  \;
-
-  
-
-  
-
-  
-
-  \;
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  \;
-
-   environments>>
-
-  
-
-  
-
-  
-
-  
-
-  <\active*>
-    <\src-comment>
-      Customization of other environments.
-    
-  
-
-  >>
-
-  >>
-
-  >>
-
-  >>
-
-  >>
-
-  <\active*>
-    <\src-comment>
-      List environments.
-    
-  
-
-  >
-  ||||>>>>
-
-  >||||>>>>
-
-  \;
-
-  
-
-  
-    <\padded-normal||0>|0.5fn|0fn>||0>|0.5fn|0fn>>
-      <\indent-left|15pt>
-        <\surround||>
-          <\with|list-level||3>|1>>
-            
-          
-        
-      
-    
-  >
-
-  >
-
-  
-    <\bib-list-nosvjour|>
-      <\with|par-left||10pt>>
-        
-      
-    
-  >
-
-  \;
-
-  >>>>
-
-  >>>>
-
-  >>>>
-
-  |>>
-
-  |>>
-
-  |>>
-
-  |>>>>
-
-  |>>>>
-
-  |>>>>>
-
-  \;
-
-  }>>>>
-
-  >>
-
-  |alpha>>>
-
-  |roman>>>
-
-  |>>>
-
-  |>>>
-
-  |>>>
-
-  \;
-
-    >>>
-
-  >>>>
-
-  |>>>>>>
-
-  |>>>>>>
-
-  |>>>>>>
-
-  |>>>>>>
-
-  |>>>>>>
-
-  <\active*>
-    <\src-comment>
-      Title information.
-    
-  
-
-  ||||||
-    >
-  >>>>>>
-
-  |>>>>
-
-  >
-    >>>
-  >>
-
-  >
-    >>>
-  >>
-
-  
-    >
-  >
-
-  
-    >||>>
-  >
-
-  <\active*>
-    <\src-comment>
-      Author information.
-    
-  
-
-  
-    |||||||
-      
-    >>>>>
-  >
-
-  >>
-
-  ||>>>>>
-
-  
-    <\style-with|src-compact|none>
-      <\quasi>
-        >
-      
-    
-  >
-
-  \;
-
-
-<\initial>
-  <\collection>
-    
-    
-  
-
\ No newline at end of file
diff --git a/TeXmacs/plugins/latex/styles/article/texmacs/tmarticle.stem b/TeXmacs/plugins/latex/styles/article/texmacs/tmarticle.stem
new file mode 100644
index 0000000000..b90f9e0892
--- /dev/null
+++ b/TeXmacs/plugins/latex/styles/article/texmacs/tmarticle.stem
@@ -0,0 +1,220 @@
+(document (TeXmacs "1.99.13")
+  (style "source")
+  (body (document (active* (document (src-title (document (src-style-file "tmarticle" "1.0")
+                                                  (src-purpose (document (concat "A future style for " (TeXmacs) " articles.")))
+                                                  (src-copyright "1998--2004" (document "Joris van der Hoeven"))
+                                                  (src-license (document (concat "This software falls under the "
+                                                                           (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE")
+                                                                           ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see "
+                                                                           (hlink "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                             "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                           ) ;hlink
+                                                                           "."
+                                                                         ) ;concat
+                                                               ) ;document
+                                                  ) ;src-license
+                                                ) ;document
+                                     ) ;src-title
+                           ) ;document
+                  ) ;active*
+          (use-package "article")
+          (active* (document (src-comment (document "Titles."))))
+          (assign "render-abstract"
+            (macro "body"
+              (document (with "par-left"
+                          "15mm"
+                          "par-right"
+                          "15mm"
+                          (document (small (document (padded-bothlined "2.5bls"
+                                                       "2.5bls"
+                                                       "1ln"
+                                                       "1ln"
+                                                       "0.5bls"
+                                                       "0.5bls"
+                                                       (document (arg "body"))
+                                                     ) ;padded-bothlined
+                                           ) ;document
+                                    ) ;small
+                          ) ;document
+                        ) ;with
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "doc-render-title"
+            (macro "x"
+              (surround (vspace* "0.5fn")
+                (vspace "0.5fn")
+                (doc-title-block (with "math-font-series"
+                                   "bold"
+                                   "font-series"
+                                   "bold"
+                                   "font-shape"
+                                   "small-caps"
+                                   (style-with "src-compact" "none" (really-large (arg "x")))
+                                 ) ;with
+                ) ;doc-title-block
+              ) ;surround
+            ) ;macro
+          ) ;assign
+          (assign "author-by" (macro "body" (arg "body")))
+          (assign "author-render-name"
+            (macro "x"
+              (surround (vspace* "0.5fn")
+                (vspace "0.5fn")
+                (doc-author-block (with "font-shape" "italic" (font-magnify "1.189" (arg "x"))))
+              ) ;surround
+            ) ;macro
+          ) ;assign
+          (active* (document (src-comment (document "Headers."))))
+          (assign "header-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (concat (simple-page)
+                  (assign "page-even-header"
+                    `(small (style-with ,"src-compact"
+                              ,"none"
+                              (wide-std-underlined (style-with ,"src-compact"
+                                                     ,"none"
+                                                     (concat ,(page-number)
+                                                       (htab "5mm")
+                                                       (with ,"font-shape"
+                                                         ,"small-caps"
+                                                         ,(arg "name")))))))
+                  ) ;assign
+                ) ;concat
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "header-author"
+            (macro "name"
+              (assign "page-odd-header"
+                `(small (style-with ,"src-compact"
+                          ,"none"
+                          (wide-std-underlined (concat (with ,"font-shape"
+                                                         ,"small-caps"
+                                                         ,(arg "name"))
+                                                 (htab "5mm")
+                                                 ,(page-number)))))
+              ) ;assign
+            ) ;macro
+          ) ;assign
+          (assign "header-primary" (macro "name" "nr" "what" ""))
+          (assign "header-secondary" (macro "name" "nr" "what" ""))
+          (active* (document (src-comment (document "Sectional tags."))))
+          (assign "sectional-sep" (macro (concat "." (space "2spc"))))
+          (assign "sectional-post-sep" (macro (space "2spc")))
+          (assign "chapter-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-centered-bold (concat (vspace* "3fn")
+                                           (with "font-shape" "small-caps" (really-large (arg "name")))
+                                           (vspace "2fn")
+                                         ) ;concat
+                ) ;sectional-centered-bold
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "chapter-numbered-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (chapter* (style-with "src-compact"
+                            "none"
+                            (concat (very-huge (concat (chapter-text) " " (the-chapter)))
+                              (right-flush)
+                              (vspace "1.5fn")
+                              (new-line)
+                              (left-flush)
+                              (arg "name")
+                            ) ;concat
+                          ) ;style-with
+                ) ;chapter*
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "section-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-centered-bold (concat (vspace* "2fn")
+                                           (with "font-shape" "small-caps" (larger (arg "name")))
+                                           (vspace "1fn")
+                                         ) ;concat
+                ) ;sectional-centered-bold
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "subsection-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-normal-bold (concat (vspace* "1.5fn") (large (arg "name")) (vspace "0.5fn"))
+                ) ;sectional-normal-bold
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "subsubsection-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-normal-bold (concat (vspace* "1fn") (arg "name") (vspace "0.5fn")))
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (active* (document (src-comment (document "Other customization."))))
+          (assign "tmhtml-render-enunciation"
+            (macro "which"
+              "body"
+              (document (padded* (document (surround (html-class "enunciation-name" (arg "which"))
+                                             (yes-indent*)
+                                             (arg "body")
+                                           ) ;surround
+                                 ) ;document
+                        ) ;padded*
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "tmhtml-render-theorem"
+            (macro "which"
+              "body"
+              (document (html-div-class "theorem"
+                          (document (render-enunciation (theorem-name (concat (arg "which") (theorem-sep)))
+                                      (with "font-shape" "italic" (arg "body"))
+                                    ) ;render-enunciation
+                          ) ;document
+                        ) ;html-div-class
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "theorem-name"
+            (macro "name" (with "font-shape" "small-caps" (arg "name")))
+          ) ;assign
+          (assign "toc-strong-2"
+            (macro "left"
+              "right"
+              (style-with "src-compact"
+                "none"
+                (concat (vspace* "1fn")
+                  (with "font-series"
+                    "bold"
+                    "math-font-series"
+                    "bold"
+                    "font-shape"
+                    "small-caps"
+                    (arg "left")
+                  ) ;with
+                  (toc-dots)
+                  (arg "right")
+                  (vspace "0.5fn")
+                ) ;concat
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          ""
+          ""
+        ) ;document
+  ) ;body
+  (initial (collection (associate "preamble" "true")))
+) ;document
diff --git a/TeXmacs/plugins/latex/styles/article/texmacs/tmarticle.ts b/TeXmacs/plugins/latex/styles/article/texmacs/tmarticle.ts
deleted file mode 100644
index b8811fd331..0000000000
--- a/TeXmacs/plugins/latex/styles/article/texmacs/tmarticle.ts
+++ /dev/null
@@ -1,117 +0,0 @@
-
-
-
-
-<\body>
-  <\active*>
-    <\src-title>
-      
-
-      <\src-purpose>
-        A future style for  articles.
-      
-
-      <\src-copyright|1998--2004>
-        Joris van der Hoeven
-      
-
-      <\src-license>
-        This software falls under the . It comes WITHOUT ANY
-        WARRANTY WHATSOEVER. You should have received a copy of the license
-        which the software. If not, see .
-      
-    
-  
-
-  
-
-  <\active*>
-    <\src-comment>
-      Titles.
-    
-  
-
-  
-    <\with|par-left|15mm|par-right|15mm>
-      <\small>
-        <\padded-bothlined|2.5bls|2.5bls|1ln|1ln|0.5bls|0.5bls>
-          
-        
-      
-    
-  >
-
-  ||>>>>>>>
-
-  >>
-
-  ||>>>>>>
-
-  <\active*>
-    <\src-comment>
-      Headers.
-    
-  
-
-  >>>>>>>>>>>>
-
-  >>>>>>>>>>
-
-  >
-
-  >
-
-  <\active*>
-    <\src-comment>
-      Sectional tags.
-    
-  
-
-  >>
-
-  >>
-
-  >>>>>>
-
-  
-  >>>>>>
-
-  >>>>>>
-
-  >>>>>
-
-  >>>>
-
-  <\active*>
-    <\src-comment>
-      Other customization.
-    
-  
-
-  
-    <\padded*>
-      >||>
-    
-  >
-
-  
-    <\html-div-class|theorem>
-      >|>>
-    
-  >
-
-  >>>
-
-  >>>>
-
-  \;
-
-  \;
-
-
-<\initial>
-  <\collection>
-    
-  
-
\ No newline at end of file
diff --git a/TeXmacs/plugins/latex/styles/article/texmacs/tmconf.stem b/TeXmacs/plugins/latex/styles/article/texmacs/tmconf.stem
new file mode 100644
index 0000000000..536f3487c8
--- /dev/null
+++ b/TeXmacs/plugins/latex/styles/article/texmacs/tmconf.stem
@@ -0,0 +1,205 @@
+(document (TeXmacs "1.99.19")
+  (style "source")
+  (body (document (active* (document (src-title (document (src-style-file "tmconf" "1.0")
+                                                  (src-purpose (document (concat "A future style for " (TeXmacs) " conference papers."))
+                                                  ) ;src-purpose
+                                                  (src-copyright "2021" (document "Joris van der Hoeven"))
+                                                  (src-license (document (concat "This software falls under the "
+                                                                           (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE")
+                                                                           ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see "
+                                                                           (hlink "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                             "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                           ) ;hlink
+                                                                           "."
+                                                                         ) ;concat
+                                                               ) ;document
+                                                  ) ;src-license
+                                                ) ;document
+                                     ) ;src-title
+                           ) ;document
+                  ) ;active*
+          (use-package "tmarticle" "two-columns")
+          (active* (document (src-comment (document "Style parameters."))))
+          (assign "page-type" "letter")
+          (assign "page-odd" "2cm")
+          (assign "page-even" "2cm")
+          (assign "page-right" "2cm")
+          (assign "page-top" "2.25cm")
+          (assign "page-bot" "2cm")
+          (active* (document (src-comment (document "Title + abstract."))))
+          (assign "headline" (macro "body" (with "font" "Linux Biolinum" (arg "body"))))
+          (assign "doc-render-title"
+            (macro "x"
+              (surround (vspace* "0.5fn")
+                (vspace "0.5fn")
+                (doc-title-block (headline (with "math-font-series"
+                                             "bold"
+                                             "font-series"
+                                             "bold"
+                                             "font-shape"
+                                             "small-caps"
+                                             (style-with "src-compact" "none" (very-large (arg "x")))
+                                           ) ;with
+                                 ) ;headline
+                ) ;doc-title-block
+              ) ;surround
+            ) ;macro
+          ) ;assign
+          (assign "doc-title-name" (macro "x" (headline (strong (arg "x")))))
+          (assign "xdoc-title"
+            (macro "x"
+              (surround (vspace* "0.5fn")
+                (vspace "0.5fn")
+                (document (doc-title-block (font-magnify "1.682" (doc-title-name (arg "x")))))
+              ) ;surround
+            ) ;macro
+          ) ;assign
+          (assign "xdoc-subtitle"
+            (macro "x"
+              (surround (vspace* "0.25fn")
+                (vspace "0.5fn")
+                (document (doc-title-block (font-magnify "1.297" (doc-title-name (arg "x")))))
+              ) ;surround
+            ) ;macro
+          ) ;assign
+          (assign "render-abstract"
+            (macro "body"
+              (document (padded-bothlined "2.5bls"
+                          "2.5bls"
+                          "1ln"
+                          "1ln"
+                          "0.5bls"
+                          "0.5bls"
+                          (document (headline (document (surround (concat (no-indent) (strong (concat (abstract-text) ". ")))
+                                                          ""
+                                                          (document (em (document (arg "body"))))
+                                                        ) ;surround
+                                              ) ;document
+                                    ) ;headline
+                          ) ;document
+                        ) ;padded-bothlined
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "render-classify"
+            (macro "scheme"
+              "text"
+              (concat (with "font-shape"
+                        "right"
+                        (concat (no-indent) (strong (concat (arg "scheme") (localize ":"))))
+                      ) ;with
+                " "
+                (arg "text")
+              ) ;concat
+            ) ;macro
+          ) ;assign
+          (active* (document (src-comment (document "Headers."))))
+          (assign "simple-page"
+            (macro (style-with "src-compact"
+                     "none"
+                     (concat (assign "page-this-header" "")
+                       (assign "page-this-footer"
+                         (headline (concat (no-indent) (htab "5mm") (page-number) (htab "5mm")))
+                       ) ;assign
+                     ) ;concat
+                   ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "header-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (concat (simple-page)
+                  (assign "page-even-header"
+                    `(small (style-with ,"src-compact"
+                              ,"none"
+                              (wide-std-underlined (headline (concat ,(page-number)
+                                                               (htab "5mm")
+                                                               ,(arg "name"))))))
+                  ) ;assign
+                ) ;concat
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "header-author"
+            (macro "name"
+              (assign "page-odd-header"
+                `(small (style-with ,"src-compact"
+                          ,"none"
+                          (wide-std-underlined (headline (concat ,(arg "name")
+                                                           (htab "5mm")
+                                                           ,(page-number))))))
+              ) ;assign
+            ) ;macro
+          ) ;assign
+          (assign "header-primary" (macro "name" "nr" "what" ""))
+          (assign "header-secondary" (macro "name" "nr" "what" ""))
+          (active* (document (src-comment (document "Sectional tags."))))
+          (assign "sectional-sep" (macro (space "2spc")))
+          (assign "sectional-post-sep" (macro (space "2spc")))
+          (assign "chapter-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-centered-bold (concat (vspace* "2fn") (headline (very-large (arg "name"))) (vspace "1fn"))
+                ) ;sectional-centered-bold
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "chapter-numbered-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (chapter* (style-with "src-compact"
+                            "none"
+                            (concat (headline (very-large (concat (chapter-text) " " (the-chapter))))
+                              (right-flush)
+                              (vspace "1.5fn")
+                              (new-line)
+                              (left-flush)
+                              (headline (arg "name"))
+                            ) ;concat
+                          ) ;style-with
+                ) ;chapter*
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "section-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-normal-bold (concat (vspace* "1fn") (headline (large (arg "name"))) (vspace "0.5fn"))
+                ) ;sectional-normal-bold
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "subsection-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-normal-bold (concat (vspace* "1fn") (headline (sharp-size (arg "name"))) (vspace "0.5fn"))
+                ) ;sectional-normal-bold
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (assign "subsubsection-title"
+            (macro "name"
+              (style-with "src-compact"
+                "none"
+                (sectional-normal (concat (vspace* "0.5fn") (headline (arg "name")) (vspace "0.25fn"))
+                ) ;sectional-normal
+              ) ;style-with
+            ) ;macro
+          ) ;assign
+          (active* (document (src-comment (document "Lists."))))
+          (assign "item-hsep" "1.5tab")
+          (assign "item-vsep" "0.5spc")
+          (assign "bibitem-width" "1.5tab")
+          (assign "transform-bibitem"
+            (macro "body" (strong (concat "[" (arg "body") "] ")))
+          ) ;assign
+          ""
+        ) ;document
+  ) ;body
+  (initial (collection (associate "preamble" "true")))
+) ;document
diff --git a/TeXmacs/plugins/latex/styles/article/texmacs/tmconf.ts b/TeXmacs/plugins/latex/styles/article/texmacs/tmconf.ts
deleted file mode 100644
index 572724215d..0000000000
--- a/TeXmacs/plugins/latex/styles/article/texmacs/tmconf.ts
+++ /dev/null
@@ -1,140 +0,0 @@
-
-
-
-
-<\body>
-  <\active*>
-    <\src-title>
-      
-
-      <\src-purpose>
-        A future style for  conference papers.
-      
-
-      <\src-copyright|2021>
-        Joris van der Hoeven
-      
-
-      <\src-license>
-        This software falls under the . It comes WITHOUT ANY
-        WARRANTY WHATSOEVER. You should have received a copy of the license
-        which the software. If not, see .
-      
-    
-  
-
-  
-
-  <\active*>
-    <\src-comment>
-      Style parameters.
-    
-  
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  <\active*>
-    <\src-comment>
-      Title + abstract.
-    
-  
-
-  >>>
-
-  ||>>>>>>>>
-
-  >>>>
-
-  |>
-    >>>
-  >>
-
-  |>
-    >>>
-  >>
-
-  
-    <\padded-bothlined|2.5bls|2.5bls|1ln|1ln|0.5bls|0.5bls>
-      <\headline>
-        <\surround|. >|>
-          <\em>
-            
-          
-        
-      
-    
-  >
-
-  >>
-  >>
-
-  <\active*>
-    <\src-comment>
-      Headers.
-    
-  
-
-  >>>>>
-
-  >>>>>>>>>>>
-
-  >>>>>>>>>>
-
-  >
-
-  >
-
-  <\active*>
-    <\src-comment>
-      Sectional tags.
-    
-  
-
-  >>
-
-  >>
-
-  >>>>>>
-
-  
-  >>>>>>>>
-
-  >>>>>>
-
-  >>>>>>
-
-  >>>>>
-
-  <\active*>
-    <\src-comment>
-      Lists.
-    
-  
-
-  
-
-  
-
-  
-
-  ] >>>
-
-  \;
-
-
-<\initial>
-  <\collection>
-    
-  
-
\ No newline at end of file
diff --git a/TeXmacs/plugins/latex/styles/article/texmacs/web-article.stem b/TeXmacs/plugins/latex/styles/article/texmacs/web-article.stem
new file mode 100644
index 0000000000..15d262a909
--- /dev/null
+++ b/TeXmacs/plugins/latex/styles/article/texmacs/web-article.stem
@@ -0,0 +1,42 @@
+(document (TeXmacs "1.99.13")
+  (style "source")
+  (body (document (active* (document (src-title (document (src-style-file "web" "article-1.0")
+                                                  (src-purpose (document "Article style that mimicks web pages."))
+                                                  (src-copyright "2020" (document "Joris van der Hoeven"))
+                                                  (src-license (document (concat "This software falls under the "
+                                                                           (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE")
+                                                                           ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see "
+                                                                           (hlink "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                             "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                           ) ;hlink
+                                                                           "."
+                                                                         ) ;concat
+                                                               ) ;document
+                                                  ) ;src-license
+                                                ) ;document
+                                     ) ;src-title
+                           ) ;document
+                  ) ;active*
+          (use-package "generic" "biolinum-font")
+          (active* (document (src-comment (document "Global page style."))))
+          (assign "page-medium" "automatic")
+          (assign "page-screen-margin" "false")
+          ""
+          (assign "page-odd" "5em")
+          (assign "page-even" "5em")
+          (assign "page-right" "5em")
+          (assign "page-top" "5em")
+          (assign "page-bot" "5em")
+          ""
+          (assign "page-screen-left" "5em")
+          (assign "page-screen-right" "5em")
+          (assign "page-screen-top" "5em")
+          (assign "page-screen-bot" "5em")
+          ""
+          (assign "page-odd-footer" "")
+          (assign "page-even-footer" "")
+          ""
+        ) ;document
+  ) ;body
+  (initial (collection (associate "preamble" "true")))
+) ;document
diff --git a/TeXmacs/plugins/latex/styles/article/texmacs/web-article.ts b/TeXmacs/plugins/latex/styles/article/texmacs/web-article.ts
deleted file mode 100644
index a6132d0869..0000000000
--- a/TeXmacs/plugins/latex/styles/article/texmacs/web-article.ts
+++ /dev/null
@@ -1,74 +0,0 @@
-
-
-
-
-<\body>
-  <\active*>
-    <\src-title>
-      
-
-      <\src-purpose>
-        Article style that mimicks web pages.
-      
-
-      <\src-copyright|2020>
-        Joris van der Hoeven
-      
-
-      <\src-license>
-        This software falls under the . It comes WITHOUT ANY
-        WARRANTY WHATSOEVER. You should have received a copy of the license
-        which the software. If not, see .
-      
-    
-  
-
-  
-
-  <\active*>
-    <\src-comment>
-      Global page style.
-    
-  
-
-  
-
-  
-
-  \;
-
-  
-
-  
-
-  
-
-  
-
-  
-
-  \;
-
-  
-
-  
-
-  
-
-  
-
-  \;
-
-  
-
-  
-
-  \;
-
-
-<\initial>
-  <\collection>
-    
-  
-
\ No newline at end of file
diff --git a/TeXmacs/plugins/literate/packages/utilities/literate.stem b/TeXmacs/plugins/literate/packages/utilities/literate.stem
new file mode 100644
index 0000000000..6763fd9855
--- /dev/null
+++ b/TeXmacs/plugins/literate/packages/utilities/literate.stem
@@ -0,0 +1,352 @@
+(document (TeXmacs "2.1.4")
+  (style "source")
+  (body (document (active* (src-title (document (src-package "literate" "1.0")
+                                        (src-purpose (document "Literate programming based on chunks"))
+                                        (src-copyright "1998--2015" "Joris van der Hoeven")
+                                        (src-license (document (concat "This software falls under the "
+                                                                 (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE")
+                                                                 ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see "
+                                                                 (hlink "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                   "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                 ) ;hlink
+                                                                 "."
+                                                               ) ;concat
+                                                     ) ;document
+                                        ) ;src-license
+                                      ) ;document
+                           ) ;src-title
+                  ) ;active*
+          (use-module "(literate lp-menu)")
+          (active* (document (src-comment (document "Presentation macros"))))
+          (assign "wide-bothlined-named"
+            (macro "top-border"
+              "bot-border"
+              "top-sep"
+              "bot-sep"
+              "body"
+              "title"
+              (surround (no-indent)
+                ""
+                (tabular (tformat (twith "table-width" "1par")
+                           (cwith "1" "2" "1" "1" "cell-width" "1par")
+                           (cwith "1" "2" "1" "1" "cell-lsep" "0pt")
+                           (cwith "1" "2" "1" "1" "cell-rsep" "0pt")
+                           (cwith "2" "2" "1" "1" "cell-hyphen" "t")
+                           (cwith "2" "2" "1" "1" "cell-tborder" (arg "top-border"))
+                           (cwith "2" "2" "1" "1" "cell-bborder" (arg "bot-border"))
+                           (cwith "1" "2" "1" "1" "cell-tsep" (arg "top-sep"))
+                           (cwith "1" "1" "1" "1" "cell-bsep" (arg "top-sep"))
+                           (cwith "2" "2" "1" "1" "cell-bsep" (arg "bot-sep"))
+                           (cwith "1" "1" "1" "1" "cell-tsep" "0spc")
+                           (cwith "1" "1" "1" "1" "cell-vcorrect" "b")
+                           (cwith "1" "1" "1" "1" "cell-hyphen" "t")
+                           (table (row (cell (document (arg "title"))))
+                             (row (cell (document (arg "body"))))
+                           ) ;table
+                         ) ;tformat
+                ) ;tabular
+              ) ;surround
+            ) ;macro
+          ) ;assign
+          (assign "wide-std-bothlined-named"
+            (macro "body"
+              "title"
+              (wide-bothlined-named (value "overlined-width")
+                (value "underlined-width")
+                (value "overlined-sep")
+                (value "underlined-sep")
+                (arg "body")
+                (arg "title")
+              ) ;wide-bothlined-named
+            ) ;macro
+          ) ;assign
+          (assign "bothlined-named"
+            (macro "body"
+              "title"
+              (document (padded (wide-std-bothlined-named (arg "body") (arg "title"))))
+            ) ;macro
+          ) ;assign
+          (active* (document (src-comment (document "Generic chunks"))))
+          (assign "chunk-number" (macro "name" (value (merge (arg "name") "-nr"))))
+          (assign "chunk-inc"
+            (macro "name"
+              (if (provides (merge (arg "name") "-nr"))
+                (assign (merge (arg "name") "-nr")
+                  (plus (value (merge (arg "name") "-nr")) "1")
+                ) ;assign
+                (assign (merge (arg "name") "-nr") "1")
+              ) ;if
+            ) ;macro
+          ) ;assign
+          ""
+          (assign "chunk-label"
+            (macro "name"
+              (if (provides (merge (arg "name") "-nr"))
+                (concat (assign "the-label" (arg "name"))
+                  (label (merge "chunk-" (arg "name") "-" (value (merge (arg "name") "-nr"))))
+                ) ;concat
+              ) ;if
+            ) ;macro
+          ) ;assign
+          (assign "chunk-ref"
+            (macro "name"
+              (concat (math "")
+                (hlink (arg "name") (merge "#chunk-" (arg "name") "-1"))
+                (math "")
+              ) ;concat
+            ) ;macro
+          ) ;assign
+          (assign "chunk-up"
+            (macro "name"
+              (hlink (math "")
+                (merge "#chunk-"
+                  (arg "name")
+                  "-"
+                  (minus (value (merge (arg "name") "-nr")) "1")
+                ) ;merge
+              ) ;hlink
+            ) ;macro
+          ) ;assign
+          (assign "chunk-down"
+            (macro "name"
+              (hlink (math "")
+                (merge "#chunk-" (arg "name") "-" (plus (value (merge (arg "name") "-nr")) "1"))
+              ) ;hlink
+            ) ;macro
+          ) ;assign
+          ""
+          (assign "chunk-link"
+            (macro "name"
+              (if (unequal (find-file (arg "name")) "false")
+                (slink (arg "name"))
+                (arg "name")
+              ) ;if
+            ) ;macro
+          ) ;assign
+          (assign "chunk-this"
+            (macro "name" (with "color" "#404050" (chunk-link (arg "name"))))
+          ) ;assign
+          (assign "chunk-assign"
+            (macro "prev"
+              "next"
+              (if (arg "prev")
+                (math "+")
+                (if (arg "next") (concat ":" (math "")) (math ""))
+              ) ;if
+            ) ;macro
+          ) ;assign
+          (assign "chunk-assign" (macro "prev" "next" ""))
+          ""
+          (assign "generic-chunk"
+            (macro "name"
+              "prev"
+              "next"
+              "body"
+              (document (surround (if (arg "prev")
+                                    (chunk-inc (arg "name"))
+                                    (assign (merge (arg "name") "-nr") "1")
+                                  ) ;if
+                          ""
+                          (document (bothlined-named (document (compact (document (surround (chunk-label (arg "name")) "" (concat (yes-indent*) (arg "body")))
+                                                                        ) ;document
+                                                               ) ;compact
+                                                     ) ;document
+                                      (small (concat (chunk-this (arg "name"))
+                                               " "
+                                               (chunk-assign (arg "prev") (arg "next"))
+                                               (htab "5mm")
+                                               (if (arg "prev") (chunk-up (arg "name")) (phantom (math "")))
+                                               " "
+                                               (if (or (arg "prev") (arg "next")) (chunk-number (arg "name")))
+                                               " "
+                                               (if (arg "next") (chunk-down (arg "name")) (phantom (math "")))
+                                             ) ;concat
+                                      ) ;small
+                                    ) ;bothlined-named
+                          ) ;document
+                        ) ;surround
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (active* (document (src-comment (document "Chunks for specific programming languages")))
+          ) ;active*
+          (assign "scm-chunk"
+            (macro "name"
+              "prev"
+              "next"
+              "body"
+              (document (generic-chunk (arg "name")
+                          (arg "prev")
+                          (arg "next")
+                          (scm (document (arg "body")))
+                        ) ;generic-chunk
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "goldfish-chunk"
+            (macro "name"
+              "prev"
+              "next"
+              "body"
+              (document (generic-chunk (arg "name")
+                          (arg "prev")
+                          (arg "next")
+                          (document (goldfish-lang (document (arg "body"))))
+                        ) ;generic-chunk
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "elvish-chunk"
+            (macro "name"
+              "prev"
+              "next"
+              "body"
+              (document (generic-chunk (arg "name")
+                          (arg "prev")
+                          (arg "next")
+                          (document (elvish-lang (arg "body")))
+                        ) ;generic-chunk
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "cpp-chunk"
+            (macro "name"
+              "prev"
+              "next"
+              "body"
+              (document (generic-chunk (arg "name")
+                          (arg "prev")
+                          (arg "next")
+                          (cpp (document (arg "body")))
+                        ) ;generic-chunk
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "java-chunk"
+            (macro "name"
+              "prev"
+              "next"
+              "body"
+              (document (generic-chunk (arg "name")
+                          (arg "prev")
+                          (arg "next")
+                          (document (java (document (arg "body"))))
+                        ) ;generic-chunk
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "mmx-chunk"
+            (macro "name"
+              "prev"
+              "next"
+              "body"
+              (document (generic-chunk (arg "name")
+                          (arg "prev")
+                          (arg "next")
+                          (mmx (document (arg "body")))
+                        ) ;generic-chunk
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "python-chunk"
+            (macro "name"
+              "prev"
+              "next"
+              "body"
+              (document (generic-chunk (arg "name")
+                          (arg "prev")
+                          (arg "next")
+                          (python (document (arg "body")))
+                        ) ;generic-chunk
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "scala-chunk"
+            (macro "name"
+              "prev"
+              "next"
+              "body"
+              (document (generic-chunk (arg "name")
+                          (arg "prev")
+                          (arg "next")
+                          (scala (document (arg "body")))
+                        ) ;generic-chunk
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "scilab-chunk"
+            (macro "name"
+              "prev"
+              "next"
+              "body"
+              (document (generic-chunk (arg "name")
+                          (arg "prev")
+                          (arg "next")
+                          (scilab (document (arg "body")))
+                        ) ;generic-chunk
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "shell-chunk"
+            (macro "name"
+              "prev"
+              "next"
+              "body"
+              (document (generic-chunk (arg "name")
+                          (arg "prev")
+                          (arg "next")
+                          (shell (document (arg "body")))
+                        ) ;generic-chunk
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "verbatim-chunk"
+            (macro "name"
+              "prev"
+              "next"
+              "body"
+              (document (generic-chunk (arg "name")
+                          (arg "prev")
+                          (arg "next")
+                          (verbatim (document (arg "body")))
+                        ) ;generic-chunk
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (active* (document (src-comment (document "Macros to keep parts of the chunks invisible while editing. This can typically be used for adding some newlines during the actual generation of code, or inserting some copyright information into the header."
+                                          ) ;document
+                             ) ;src-comment
+                   ) ;document
+          ) ;active*
+          (assign "unfolded-newline-before"
+            (macro "body" (document "" (wide-normal (document (arg "body")))))
+          ) ;assign
+          (assign "folded-newline-before"
+            (macro "body" (document (wide-normal (document (arg "body")))))
+          ) ;assign
+          (assign "unfolded-opening"
+            (macro "before"
+              "body"
+              (document (greyed (document (wide-normal (document (arg "before")))))
+                (wide-normal (document (arg "body")))
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "folded-opening"
+            (macro "before" "body" (document (wide-normal (document (arg "body")))))
+          ) ;assign
+          (assign "unfolded-ending"
+            (macro "body"
+              "after"
+              (document (wide-normal (document (arg "body")))
+                (greyed (document (wide-normal (document (arg "after")))))
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "folded-ending"
+            (macro "body" "after" (document (wide-normal (document (arg "body")))))
+          ) ;assign
+        ) ;document
+  ) ;body
+  (initial (collection (associate "preamble" "true")))
+) ;document
diff --git a/TeXmacs/plugins/literate/packages/utilities/literate.ts b/TeXmacs/plugins/literate/packages/utilities/literate.ts
deleted file mode 100644
index ee5e276ea5..0000000000
--- a/TeXmacs/plugins/literate/packages/utilities/literate.ts
+++ /dev/null
@@ -1,227 +0,0 @@
-
-
-
-
-<\body>
-  
-    
-
-    <\src-purpose>
-      Literate programming based on chunks
-    
-
-    
-
-    <\src-license>
-      This software falls under the . It comes WITHOUT ANY
-      WARRANTY WHATSOEVER. You should have received a copy of the license
-      which the software. If not, see .
-    
-  >
-
-  
-
-  <\active*>
-    <\src-comment>
-      Presentation macros
-    
-  
-
-  |||||||>|>|>|>|>||||
-    
-  >|
-    
-  >>>>>>>
-
-  |||||>>>
-
-  
-    |>>
-  >
-
-  <\active*>
-    <\src-comment>
-      Generic chunks
-    
-  
-
-  |-nr>>>>
-
-  |-nr>>||-nr>||-nr>>|1>>||-nr>|1>>>>
-
-  \;
-
-  |-nr>>|>|-||-nr>>>>>>>
-
-  >||-1>>>>>
-
-  >||-||-nr>>|1>>>>>
-
-  >||-||-nr>>|1>>>>>
-
-  \;
-
-  >|false>|>|>>>
-
-  >>>>
-
-  |>||:>|>>>>>
-
-  >
-
-  \;
-
-  
-    <\surround||>||-nr>|1>>|>
-      <\bothlined-named>
-        <\compact>
-          >||>
-        
-      >
-      |>|>|>>>
-      |>|>>
-      |>|>>>>>
-    
-  >
-
-  <\active*>
-    <\src-comment>
-      Chunks for specific programming languages
-    
-  
-
-  
-    |||<\scm>
-      
-    >
-  >
-
-  
-    <\generic-chunk|||>
-      <\goldfish-lang>
-        
-      
-    
-  >
-
-  
-    <\generic-chunk|||>
-      >
-    
-  >
-
-  
-    |||<\cpp>
-      
-    >
-  >
-
-  
-    <\generic-chunk|||>
-      <\java>
-        
-      
-    
-  >
-
-  
-    |||<\mmx>
-      
-    >
-  >
-
-  
-    |||<\python>
-      
-    >
-  >
-
-  
-    |||<\scala>
-      
-    >
-  >
-
-  
-    |||<\scilab>
-      
-    >
-  >
-
-  
-    |||<\shell>
-      
-    >
-  >
-
-  
-    |||<\verbatim>
-      
-    >
-  >
-
-  <\active*>
-    <\src-comment>
-      Macros to keep parts of the chunks invisible while editing. This can
-      typically be used for adding some newlines during the actual generation
-      of code, or inserting some copyright information into the header.
-    
-  
-
-  
-    \;
-
-    <\wide-normal>
-      
-    
-  >
-
-  
-    <\wide-normal>
-      
-    
-  >
-
-  
-    <\greyed>
-      <\wide-normal>
-        
-      
-    
-
-    <\wide-normal>
-      
-    
-  >
-
-  
-    <\wide-normal>
-      
-    
-  >
-
-  
-    <\wide-normal>
-      
-    
-
-    <\greyed>
-      <\wide-normal>
-        
-      
-    
-  >
-
-  
-    <\wide-normal>
-      
-    
-  >
-
-
-<\initial>
-  <\collection>
-    
-  
-
\ No newline at end of file
diff --git a/TeXmacs/plugins/literate/progs/literate/lp-build.scm b/TeXmacs/plugins/literate/progs/literate/lp-build.scm
new file mode 100644
index 0000000000..6f60143e24
--- /dev/null
+++ b/TeXmacs/plugins/literate/progs/literate/lp-build.scm
@@ -0,0 +1,327 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : lp-build.scm
+;; DESCRIPTION : building programs from literate source files
+;; COPYRIGHT   : (C) 2015  Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (literate lp-build) (:use (literate lp-edit)))
+
+(import (liii hash-table) (liii base) (liii list))
+
+(define code-table (s7-make-hash-table))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Building the initial table (without substitutions)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (extract-lines t)
+  (cond ((tm-atomic? t) (list t))
+        ((tm-func? t 'document) (flat-map extract-lines (tm-children t)))
+        ((or (tm-func? t 'folded-newline-before 1)
+           (tm-func? t 'unfolded-newline-before 1)
+         ) ;or
+         (cons "" (extract-lines (tm-ref t 0)))
+        ) ;
+        (else (with l
+                (filter (cut tm-func? <> 'document) (tm-children t))
+                (if (null? l) (list t) (flat-map extract-lines l))
+              ) ;with
+        ) ;else
+  ) ;cond
+) ;define
+
+(define (build-table t)
+  (let* ((l (get-all-chunks)) (ht (s7-make-hash-table)))
+    (for (c l)
+      (let* ((name (tm->string (tm-ref c 0)))
+             (body0 (tm-ref c 3))
+             (body (if (not (tm-func? body0 'document)) `(document ,body0) body0))
+             (old (tm-children (hash-table-ref/default ht name '(document))))
+             (new (append old (extract-lines body)))
+            ) ;
+        (hash-table-set! ht name `(document ,@new))
+      ) ;let*
+    ) ;for
+    ht
+  ) ;let*
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Performing the necessary substitutions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (ahash-table-split t pred?)
+  (let* ((t1 (make-ahash-table)) (t2 (make-ahash-table)))
+    (for (key (hash-table-keys t))
+      (with im
+        (ahash-ref t key)
+        (if (pred? (ahash-ref t key)) (ahash-set! t1 key im) (ahash-set! t2 key im))
+      ) ;with
+    ) ;for
+    (list t1 t2)
+  ) ;let*
+) ;define
+
+(define (should-expand? t)
+  (cond ((tm-atomic? t) #f)
+        ((tm-func? t 'chunk-ref 1) #t)
+        (else (list-or (map should-expand? (tm-children t))))
+  ) ;cond
+) ;define
+
+(define (expand-names x t)
+  (cond ((tm-atomic? x) x)
+        ((tm-func? x 'document)
+         (let* ((l1 (map (cut expand-names <> t) (tm-children x)))
+                (l2 (map (lambda (y) (if (tm-func? y 'document) (tm-children y) (list y))) l1))
+               ) ;
+           `(document ,@(apply append l2))
+         ) ;let*
+        ) ;
+        ((tm-func? x 'chunk-ref 1)
+         (if (and (tm-atomic? (tm-ref x 0)) (ahash-ref t (tm->string (tm-ref x 0))))
+           (ahash-ref t (tm->string (tm-ref x 0)))
+           x
+         ) ;if
+        ) ;
+        ((tm-func? x 'concat)
+         (if (and (tm-func? (tm-ref x :last) 'chunk-ref 1)
+               (tm-atomic? (tm-ref x :last 0))
+               (ahash-ref t (tm->string (tm-ref x :last 0)))
+             ) ;and
+           (let* ((count (lambda (x) (if (tm-atomic? x) (tmstring-length (tm->string x)) 0)))
+                  (i (apply + (map count (cDr (tm-children x)))))
+                  (pre (apply string-append (map (lambda (y) " ") (.. 0 i))))
+                  (doc (ahash-ref t (tm->string (tm-ref x :last 0))))
+                  (lines (tm-children doc))
+                 ) ;
+             `(document (concat ,@(cDr (tm-children x)) ,(car lines))
+                ,@(map (lambda (x) (tmconcat pre x)) (cdr lines)))
+           ) ;let*
+           x
+         ) ;if
+        ) ;
+        (else x)
+  ) ;cond
+) ;define
+
+(define (expand-table t)
+  (with (todo done)
+    (ahash-table-split t should-expand?)
+    (with ok?
+      #f
+      (for (key (map car (ahash-table->list todo)))
+        (with subst
+          (expand-names (ahash-ref todo key) done)
+          (when (not (should-expand? subst))
+            (ahash-set! done key subst)
+            (set! ok? #t)
+          ) ;when
+        ) ;with
+      ) ;for
+      (cond ((== (ahash-size todo) 0) done)
+            (ok? (for (key (map car (ahash-table->list todo)))
+                   (when (not (ahash-ref done key))
+                     (ahash-set! done key (ahash-ref todo key))
+                   ) ;when
+                 ) ;for
+              (expand-table done)
+            ) ;ok?
+            (else (for (key (map car (ahash-table->list todo)))
+                    (display* "TeXmacs] Problematic chunk: " key "\n")
+                  ) ;for
+              (set-message "Error: cyclic or missing chunks detected" "build-all")
+              done
+            ) ;else
+      ) ;cond
+    ) ;with
+  ) ;with
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Debugging subroutines
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (display-table t)
+  (for (key (map car (ahash-table->list t)))
+    (display* key "\n----------------------------------\n")
+    (with im (tm-children (ahash-ref t key)) (for (l im) (display* "  " l "\n")))
+    (display* "----------------------------------\n\n")
+  ) ;for
+) ;define
+
+(define (display-table* t*)
+  (with t
+    (verbatim-table t*)
+    (for (key (map car (ahash-table->list t)))
+      (display* key "\n----------------------------------\n")
+      (display* (ahash-ref t key))
+      (display* "----------------------------------\n\n")
+    ) ;for
+  ) ;with
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Memorize which files have been built
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define lp-db (url->url "$TEXMACS_HOME_PATH/system/database/lp-master.tmdb"))
+
+(define (lp-set-time-stamp src dir)
+  (tmdb-keep-history lp-db #f)
+  (let* ((src* (url->system src))
+         (dir* (url->system dir))
+         (id (string-append src* "-" dir*))
+         (time (number->string (url-last-modified src)))
+        ) ;
+    (tmdb-set-field lp-db id "time-stamp" (list time) (current-time))
+  ) ;let*
+) ;define
+
+(define (lp-get-time-stamp src dir)
+  (tmdb-keep-history lp-db #f)
+  (let* ((src* (url->system src))
+         (dir* (url->system dir))
+         (id (string-append src* "-" dir*))
+        ) ;
+    (with l
+      (tmdb-get-field lp-db id "time-stamp" (current-time))
+      (and l (nnull? l) (car l))
+    ) ;with
+  ) ;let*
+) ;define
+
+(define (lp-build-conditional src dir fun)
+  (with stamp
+    (lp-get-time-stamp src dir)
+    (when (or (not stamp)
+            (not (url-exists? src))
+            (not (url-exists? dir))
+            (< (string->number stamp) (url-last-modified src))
+          ) ;or
+      (fun src dir)
+      (when (and (url-exists? src) (url-exists? dir))
+        (lp-set-time-stamp src dir)
+      ) ;when
+    ) ;when
+  ) ;with
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Main build process
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (verbatim-table ht)
+  (with r
+    (s7-make-hash-table)
+    (for-each (lambda (key-val)
+                (let* ((key (car key-val))
+                       (val (cdr key-val))
+                       (l (tm-children (tm->stree val)))
+                       (l-code (map (cut texmacs->code <> "SourceCode") l))
+                       (l-code-nl (map (cut string-append <> "\n") l-code))
+                       (s-code (apply string-append l-code-nl))
+                      ) ;
+                  (hash-table-set! r key s-code)
+                ) ;let*
+              ) ;lambda
+      (map values ht)
+    ) ;for-each
+    r
+  ) ;with
+) ;define
+
+(define (write-table ht dir)
+ ((box (map values ht))
+  :for-each
+  (lambda (pair)
+    (let* ((key (car pair)) (val (cdr pair)))
+      (with target
+        (url-append dir key)
+        (when (not (url-exists? (url-head target)))
+          (system-mkdir (url-head target))
+        ) ;when
+        (when (!= (hash-table-ref/default code-table key "") val)
+          (display* "TeXmacs] Building " (url->system target) "\n")
+          (string-save val target)
+          (hash-table-set! code-table key val)
+        ) ;when
+      ) ;with
+    ) ;let*
+  ) ;lambda
+ ) ;
+) ;define
+
+(define (lp-build* file dir)
+  (with doc
+    (if (buffer-exists? file)
+      (buffer-get-body file)
+      (tmfile-extract (tree-import file "texmacs") 'body)
+    ) ;if
+    (with t
+      (build-table doc)
+      (with x (expand-table t) (with v (verbatim-table x) (write-table v dir)))
+    ) ;with
+  ) ;with
+) ;define
+
+(define (lp-build file dir)
+  (if (buffer-exists? file)
+    (lp-build* file dir)
+    (lp-build-conditional file dir lp-build*)
+  ) ;if
+) ;define
+
+(tm-define (lp-build-buffer)
+  (update-all-chunk-states)
+  (lp-build (current-buffer) (url-head (current-buffer)))
+) ;tm-define
+
+(tm-define (lp-build-buffer-in dir)
+  (:argument dir "Build directory")
+  (update-all-chunk-states)
+  (lp-build (current-buffer) dir)
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Building all files in a directory
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (lp-build-directory source target)
+  (let* ((f (url-append (url-append source (url-any)) (url-wildcard "*.tm")))
+         (l (url->list (url-expand (url-complete f "r"))))
+        ) ;
+    (for (src l)
+      (let* ((rel (url-delta (url-append source "dummy") src))
+             (obj (url-append target rel))
+            ) ;
+        (lp-build src (url-head obj))
+      ) ;let*
+    ) ;for
+  ) ;let*
+) ;define
+
+(tm-define (lp-interactive-build-directory)
+  (:interactive #t)
+  (user-url "Directory" "directory" (lambda (src) (lp-build-directory src src)))
+) ;tm-define
+
+(tm-define (lp-interactive-build-directory-in)
+  (:interactive #t)
+  (user-url "Source directory"
+    "directory"
+    (lambda (src)
+      (user-url "Destination directory"
+        "directory"
+        (lambda (dest) (lp-build-directory src dest))
+      ) ;user-url
+    ) ;lambda
+  ) ;user-url
+) ;tm-define
diff --git a/TeXmacs/plugins/literate/progs/literate/lp-edit.scm b/TeXmacs/plugins/literate/progs/literate/lp-edit.scm
new file mode 100644
index 0000000000..6d3f735015
--- /dev/null
+++ b/TeXmacs/plugins/literate/progs/literate/lp-edit.scm
@@ -0,0 +1,288 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : lp-edit.scm
+;; DESCRIPTION : editing literate programs
+;; COPYRIGHT   : (C) 2015  Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (literate lp-edit)
+  (:use (utils library cursor) (generic document-edit) (dynamic dynamic-drd))
+) ;texmacs-module
+
+(import (liii list))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; DRD properties
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-group chunk-tag generic-chunk verbatim-chunk scm-chunk cpp-chunk
+  mmx-chunk python-chunk scilab-chunk shell-chunk scala-chunk java-chunk
+  goldfish-chunk elvish-chunk json-chunk
+) ;define-group
+
+(define-group variant-tag (chunk-tag))
+
+(define-group similar-tag (chunk-tag))
+
+(define-group appended-tag folded-newline-before unfolded-newline-before
+  folded-opening unfolded-opening folded-ending unfolded-ending
+) ;define-group
+
+(define-fold folded-newline-before unfolded-newline-before)
+(define-fold folded-opening unfolded-opening)
+(define-fold folded-ending unfolded-ending)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Searching chunks in document
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tm-chunk? t) (and (tm-in? t (chunk-tag-list)) (== (tm-arity t) 4)))
+
+(define (search-chunks t)
+  (cond ((tm-atomic? t) (list))
+        ((tm-func? t 'document) (flat-map search-chunks (tm-children t)))
+        ((tm-chunk? t) (if (and (tm-atomic? (tm-ref t 0))) (list t) (list)))
+        (else (with l
+                (list-filter (tm-children t) (cut tm-func? <> 'document))
+                (flat-map search-chunks l)
+              ) ;with
+        ) ;else
+  ) ;cond
+) ;define
+
+(tm-define (get-all-chunks) (search-chunks (buffer-tree)))
+
+(define (search-named-chunks name all-chunks)
+  (list-filter all-chunks (lambda (c) (== (tm->string (tm-ref c 0)) name)))
+) ;define
+
+(tm-define (search-chunk-types all-chunks)
+  (let* ((l all-chunks) (r (map (lambda (c) (tm->string (tm-ref c 0))) l)))
+    (list-remove-duplicates r)
+  ) ;let*
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Maintaining states (links to previous and next chunks)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (update-chunk-states name all-chunks)
+  (with l
+    (search-named-chunks name all-chunks)
+    (when (nnull? l)
+      (tree-set (tm-ref (car l) 1) "false")
+      (for (x (cdr l)) (tree-set (tm-ref x 1) "true"))
+      (tree-set (tm-ref (cAr l) 2) "false")
+      (for (x (cDr l)) (tree-set (tm-ref x 2) "true"))
+    ) ;when
+  ) ;with
+) ;tm-define
+
+(tm-define (update-all-chunk-states)
+  (with all-chunks
+    (get-all-chunks)
+    (for (name (search-chunk-types all-chunks))
+      (update-chunk-states name all-chunks)
+    ) ;for
+  ) ;with
+) ;tm-define
+
+(tm-define (update-document what)
+  (:require (style-has? "literate-dtd"))
+  (former what)
+  (when (or (== what "all") (== what "chunks"))
+    (update-all-chunk-states)
+  ) ;when
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Inserting new chunks; semi-automatic determination of appropriate language
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (chunk-format name)
+  (with suffix
+    (locase-all (url-suffix name))
+    (cond ((== suffix "") "generic")
+          ((in? suffix '("txt")) "verbatim")
+          ((in? suffix '("scm")) "scm")
+          ((in? suffix '("scala")) "scala")
+          ((in? suffix '("java")) "java")
+          ((in? suffix '("c" "cc" "cpp" "h" "hh" "hpp")) "cpp")
+          ((in? suffix '("mmx" "mmh")) "mmx")
+          ((in? suffix '("py")) "python")
+          ((in? suffix '("sce" "sci")) "scilab")
+          ((in? suffix '("bat" "sh")) "shell")
+          (else "verbatim")
+    ) ;cond
+  ) ;with
+) ;define
+
+(define (chunk-tag name)
+  (string->symbol (string-append (chunk-format name) "-chunk"))
+) ;define
+
+(define (similar-chunk-tag name all-chunks)
+  (with l
+    (search-named-chunks name all-chunks)
+    (if (null? l) (chunk-tag name) (tree-label (car l)))
+  ) ;with
+) ;define
+
+(tm-define (insert-new-chunk tag)
+  (insert-go-to `(,tag ,"" ,"false" ,"false" (document "")) '(0 0))
+) ;tm-define
+
+(tm-define (insert-next-chunk name)
+  (:argument name "Chunk name")
+  (with all-chunks
+    (get-all-chunks)
+    (with tag
+      (similar-chunk-tag name all-chunks)
+      (insert-go-to `(,tag ,name ,"true" ,"false" (document "")) '(3 0))
+      (update-chunk-states name all-chunks)
+    ) ;with
+  ) ;with
+) ;tm-define
+
+(tm-define (kbd-enter t shift?)
+  (:require (and (tm-chunk? t) (cursor-inside? (tm-ref t 0))))
+  (let* ((name (if (tm-atomic? (tm-ref t 0)) (tm->string (tm-ref t 0)) ""))
+         (tag (chunk-tag name))
+        ) ;
+    (when (!= tag 'generic-chunk)
+      (tree-assign-node! t tag)
+    ) ;when
+    (tree-go-to t 3 :start)
+  ) ;let*
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Removing chunks
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (kbd-remove t forwards?)
+  (:require (tm-chunk? t))
+  (cond ((selection-active-any?) (former t forwards?))
+        ((and (tree-empty? (tm-ref t 0)) (tree-empty? (tm-ref t 3)))
+         (tree-select t)
+         (clipboard-cut "nowhere")
+        ) ;
+        ((and (tree-cursor-at? t 0 :start) (not forwards?)) (tree-go-to t :start))
+        ((and (tree-cursor-at? t 0 :end) forwards?) (tree-go-to t 3 :start))
+        ((and (tree-cursor-at? t 3 :start) (not forwards?)) (tree-go-to t 0 :end))
+        ((and (tree-cursor-at? t 3 :end) forwards?) (tree-go-to t :end))
+        ((cursor-inside? (tree-ref t 0)) (former t forwards?))
+        (else (former t forwards?))
+  ) ;cond
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Cursor movement
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define ((inside-named-chunk? name nr same-type? other?) t)
+  (and-with c
+    (tree-search-upwards t tm-chunk?)
+    (and (or (not same-type?) (tm-equal? (tm-ref c 0) name))
+      (or (not other?) (!= (tree->path (tree-ref c 0)) (tree->path name)))
+      (cursor-inside? (tm-ref c nr))
+    ) ;and
+  ) ;and-with
+) ;define
+
+(define (go-to-next-in-chunk fun same-type? other?)
+  (with-innermost t
+    tm-chunk?
+    (if (not t)
+      (fun)
+      (let* ((name (tm-ref t 0))
+             (nr (tree-index (tree-down t)))
+             (inside? (inside-named-chunk? name nr same-type? other?))
+            ) ;
+        ;; (go-to-next-inside fun inside?)))))
+        (go-to-next-such-that fun inside?)
+      ) ;let*
+    ) ;if
+  ) ;with-innermost
+) ;define
+
+(define (go-to-start-chunk)
+  (with-innermost t
+    tm-chunk?
+    (when (and t (tree-down t))
+      (with nr (tree-index (tree-down t)) (tree-go-to t nr :start))
+    ) ;when
+  ) ;with-innermost
+) ;define
+
+;; (tm-define (kbd-horizontal t forwards?)
+;;  (:require (tm-chunk? t))
+;;  (go-to-next-in-chunk (if forwards? go-right go-left) #f #f))
+
+(tm-define (kbd-vertical t downwards?)
+  (:require (tm-chunk? t))
+  (go-to-next-in-chunk (if downwards? go-down go-up) #f #f)
+) ;tm-define
+
+(tm-define (kbd-incremental t downwards?)
+  (:require (tm-chunk? t))
+  (go-to-next-in-chunk (if downwards? go-down go-up) #f #t)
+  (go-to-start-chunk)
+) ;tm-define
+
+(tm-define (traverse-extremal t forwards?)
+  (:require (tm-chunk? t))
+  (with move
+    (if forwards? go-down go-up)
+    (with chunk-move
+      (lambda () (go-to-next-in-chunk move #t #t) (go-to-start-chunk))
+      (go-to-repeat chunk-move)
+    ) ;with
+  ) ;with
+) ;tm-define
+
+(tm-define (traverse-incremental t downwards?)
+  (:require (tm-chunk? t))
+  (go-to-next-in-chunk (if downwards? go-down go-up) #t #t)
+  (go-to-start-chunk)
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Folding
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (tm-appended? t) (tm-in? t (appended-tag-list)))
+
+(tm-define (search-appended t)
+  (cond ((tm-atomic? t) (list))
+        ((tm-func? t 'document) (flat-map search-appended (tm-children t)))
+        ((tm-appended? t) (list t))
+        (else (with l
+                (list-filter (tm-children t) (cut tm-func? <> 'document))
+                (flat-map search-appended l)
+              ) ;with
+        ) ;else
+  ) ;cond
+) ;tm-define
+
+(tm-define (search-appended-folded t)
+  (list-filter (search-appended t) alternate-standard-first?)
+) ;tm-define
+
+(tm-define (search-appended-unfolded t)
+  (list-filter (search-appended t) alternate-standard-second?)
+) ;tm-define
+
+(tm-define (fold-appended)
+  (with l (search-appended (buffer-tree)) (for-each alternate-fold l))
+) ;tm-define
+
+(tm-define (unfold-appended)
+  (with l (search-appended (buffer-tree)) (for-each alternate-unfold l))
+) ;tm-define
diff --git a/TeXmacs/plugins/literate/progs/literate/lp-menu.scm b/TeXmacs/plugins/literate/progs/literate/lp-menu.scm
new file mode 100644
index 0000000000..79668774a4
--- /dev/null
+++ b/TeXmacs/plugins/literate/progs/literate/lp-menu.scm
@@ -0,0 +1,101 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : lp-menu.scm
+;; DESCRIPTION : menus for literate programming
+;; COPYRIGHT   : (C) 2015  Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (literate lp-menu) (:use (literate lp-build)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Main literate programming menu
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(menu-bind literate-menu
+  (-> "First chunk"
+   ("Scheme" (insert-new-chunk 'scm-chunk))
+   ("C++" (insert-new-chunk 'cpp-chunk))
+   ("Generic" (insert-new-chunk 'generic-chunk))
+   ("Verbatim" (insert-new-chunk 'verbatim-chunk))
+   ("Shell" (insert-new-chunk 'shell-chunk))
+   ---
+   (when (style-has? "json")
+     ("JSON" (insert-new-chunk 'json-chunk))
+   ) ;when
+   (when (style-has? "elvish-lang")
+     ("Elvish" (insert-new-chunk 'elvish-chunk))
+   ) ;when
+   (when (style-has? "goldfish-lang")
+     ("Goldfish" (insert-new-chunk 'goldfish-chunk))
+   ) ;when
+   (when (style-has? "scala")
+     ("Scala" (insert-new-chunk 'scala-chunk))
+   ) ;when
+   (when (style-has? "java")
+     ("Java" (insert-new-chunk 'java-chunk))
+   ) ;when
+   (when (style-has? "python")
+     ("Python" (insert-new-chunk 'python-chunk))
+   ) ;when
+  ) ;->
+  (with all-chunks
+    (get-all-chunks)
+    (when (nnull? (search-chunk-types all-chunks))
+      (if (null? (search-chunk-types all-chunks))
+       ("Next chunk" (interactive insert-next-chunk))
+      ) ;if
+      (if (nnull? (search-chunk-types all-chunks))
+        (-> "Next chunk"
+          (for (name (search-chunk-types all-chunks))
+           ((eval `(verbatim ,name)) (insert-next-chunk name))
+          ) ;for
+          ---
+          ("Other" (interactive insert-next-chunk))
+        ) ;->
+      ) ;if
+      (if (null? (search-chunk-types all-chunks)) ("Reference" (make 'chunk-ref)))
+      (if (nnull? (search-chunk-types all-chunks))
+        (-> "Reference"
+          (for (name (search-chunk-types all-chunks))
+           ((eval `(verbatim ,name)) (insert `(chunk-ref ,name)))
+          ) ;for
+          ---
+          ("Other" (make 'chunk-ref))
+        ) ;->
+      ) ;if
+    ) ;when
+  ) ;with
+
+  ---
+  ("Invisible newline" (make 'folded-newline-before))
+  ("Invisible opening" (make 'unfolded-opening))
+  ("Invisible ending" (make 'unfolded-ending))
+  (when (nnull? (search-appended-unfolded (buffer-tree)))
+    ("Fold all" (fold-appended))
+  ) ;when
+  (when (nnull? (search-appended-folded (buffer-tree)))
+    ("Unfold all" (unfold-appended))
+  ) ;when
+  ---
+  (when (nnull? (search-chunk-types (get-all-chunks)))
+    ("Build buffer" (lp-build-buffer))
+    ("Build buffer in" (interactive lp-build-buffer-in))
+  ) ;when
+  ("Build directory" (lp-interactive-build-directory))
+  ("Build directory in" (lp-interactive-build-directory-in))
+) ;menu-bind
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Insert menu as extra top level menu
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(menu-bind texmacs-extra-menu
+  (former)
+  (if (style-has? "literate-dtd") (=> "Literate" (link literate-menu)))
+) ;menu-bind
diff --git a/TeXmacs/plugins/literate/progs/utils/literate/lp-build.scm b/TeXmacs/plugins/literate/progs/utils/literate/lp-build.scm
deleted file mode 100644
index 8954a630eb..0000000000
--- a/TeXmacs/plugins/literate/progs/utils/literate/lp-build.scm
+++ /dev/null
@@ -1,253 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : lp-build.scm
-;; DESCRIPTION : building programs from literate source files
-;; COPYRIGHT   : (C) 2015  Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (utils literate lp-build)
-  (:use (utils literate lp-edit)))
-
-(import (liii hash-table)
-        (liii base)
-        (liii list))
-
-(define code-table (s7-make-hash-table))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Building the initial table (without substitutions)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (extract-lines t)
-  (cond ((tm-atomic? t) (list t))
-        ((tm-func? t 'document)
-         (flat-map extract-lines (tm-children t)))
-        ((or (tm-func? t 'folded-newline-before 1)
-             (tm-func? t 'unfolded-newline-before 1))
-         (cons "" (extract-lines (tm-ref t 0))))
-        (else
-         (with l (filter (cut tm-func? <> 'document) (tm-children t))
-           (if (null? l)
-               (list t)
-               (flat-map extract-lines l))))))
-
-(define (build-table t)
-  (let* ((l (get-all-chunks))
-         (ht (s7-make-hash-table)))
-    (for (c l)
-      (let* ((name (tm->string (tm-ref c 0)))
-             (body0 (tm-ref c 3))
-             (body (if (not (tm-func? body0 'document))
-                       `(document ,body0)
-                       body0))
-             (old (tm-children (hash-table-ref/default ht name `(document))))
-             (new (append old (extract-lines body))))
-        (hash-table-set! ht name `(document ,@new))))
-    ht))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Performing the necessary substitutions
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (ahash-table-split t pred?)
-  (let* ((t1 (make-ahash-table))
-         (t2 (make-ahash-table)))
-    (for (key (hash-table-keys t))
-      (with im (ahash-ref t key)
-        (if (pred? (ahash-ref t key))
-            (ahash-set! t1 key im)
-            (ahash-set! t2 key im))))
-    (list t1 t2)))
-
-(define (should-expand? t)
-  (cond ((tm-atomic? t) #f)
-        ((tm-func? t 'chunk-ref 1) #t)
-        (else (list-or (map should-expand? (tm-children t))))))
-
-(define (expand-names x t)
-  (cond ((tm-atomic? x) x)
-        ((tm-func? x 'document)
-         (let* ((l1 (map (cut expand-names <> t) (tm-children x)))
-                (l2 (map (lambda (y) (if (tm-func? y 'document)
-                                         (tm-children y) (list y))) l1)))
-           `(document ,@(apply append l2))))
-        ((tm-func? x 'chunk-ref 1)
-         (if (and (tm-atomic? (tm-ref x 0))
-                  (ahash-ref t (tm->string (tm-ref x 0))))
-             (ahash-ref t (tm->string (tm-ref x 0)))
-             x))
-        ((tm-func? x 'concat)
-         (if (and (tm-func? (tm-ref x :last) 'chunk-ref 1)
-                  (tm-atomic? (tm-ref x :last 0))
-                  (ahash-ref t (tm->string (tm-ref x :last 0))))
-             (let* ((count (lambda (x) (if (tm-atomic? x)
-                                           (tmstring-length (tm->string x))
-                                           0)))
-                    (i (apply + (map count (cDr (tm-children x)))))
-                    (pre (apply string-append (map (lambda (y) " ") (.. 0 i))))
-                    (doc (ahash-ref t (tm->string (tm-ref x :last 0))))
-                    (lines (tm-children doc)))
-               `(document (concat ,@(cDr (tm-children x)) ,(car lines))
-                          ,@(map (lambda (x) (tmconcat pre x))
-                                 (cdr lines))))
-             x))
-        (else x)))
-
-(define (expand-table t)
-  (with (todo done) (ahash-table-split t should-expand?)
-    (with ok? #f
-      (for (key (map car (ahash-table->list todo)))
-        (with subst (expand-names (ahash-ref todo key) done)
-          (when (not (should-expand? subst))
-            (ahash-set! done key subst)
-            (set! ok? #t))))
-      (cond ((== (ahash-size todo) 0)
-             done)
-            (ok?
-             (for (key (map car (ahash-table->list todo)))
-               (when (not (ahash-ref done key))
-                 (ahash-set! done key (ahash-ref todo key))))
-             (expand-table done))
-            (else
-              (for (key (map car (ahash-table->list todo)))
-                (display* "TeXmacs] Problematic chunk: " key "\n"))
-              (set-message "Error: cyclic or missing chunks detected"
-                           "build-all")
-              done)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Debugging subroutines
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (display-table t)
-  (for (key (map car (ahash-table->list t)))
-    (display* key "\n----------------------------------\n")
-    (with im (tm-children (ahash-ref t key))
-      (for (l im)
-        (display* "  " l "\n")))
-    (display* "----------------------------------\n\n")))
-
-(define (display-table* t*)
-  (with t (verbatim-table t*)
-    (for (key (map car (ahash-table->list t)))
-      (display* key "\n----------------------------------\n")
-      (display* (ahash-ref t key))
-      (display* "----------------------------------\n\n"))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Memorize which files have been built
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define lp-db (url->url "$TEXMACS_HOME_PATH/system/database/lp-master.tmdb"))
-
-(define (lp-set-time-stamp src dir)
-  (tmdb-keep-history lp-db #f)
-  (let* ((src* (url->system src))
-         (dir* (url->system dir))
-         (id (string-append src* "-" dir*))
-         (time (number->string (url-last-modified src))))
-    (tmdb-set-field lp-db id "time-stamp" (list time) (current-time))))
-
-(define (lp-get-time-stamp src dir)
-  (tmdb-keep-history lp-db #f)
-  (let* ((src* (url->system src))
-         (dir* (url->system dir))
-         (id (string-append src* "-" dir*)))
-    (with l (tmdb-get-field lp-db id "time-stamp" (current-time))
-      (and l (nnull? l) (car l)))))
-
-(define (lp-build-conditional src dir fun)
-  (with stamp (lp-get-time-stamp src dir)
-    (when (or (not stamp)
-              (not (url-exists? src))
-              (not (url-exists? dir))
-              (< (string->number stamp) (url-last-modified src)))
-      (fun src dir)
-      (when (and (url-exists? src)
-                 (url-exists? dir))
-        (lp-set-time-stamp src dir)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Main build process
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (verbatim-table ht)
-  (with r (s7-make-hash-table)
-    (for-each
-      (lambda (key-val)
-        (let* ((key (car key-val))
-               (val (cdr key-val))
-               (l (tm-children (tm->stree val)))
-               (l-code (map (cut texmacs->code <> "SourceCode") l))
-               (l-code-nl (map (cut string-append <> "\n") l-code))
-               (s-code (apply string-append l-code-nl)))
-          (hash-table-set! r key s-code)))
-      (map values ht))
-    r))
-
-(define (write-table ht dir)
-  ((box (map values ht))
-   :for-each
-    (lambda (pair)
-      (let* ((key (car pair))
-             (val (cdr pair)))
-        (with target (url-append dir key)
-          (when (not (url-exists? (url-head target)))
-            (system-mkdir (url-head target)))
-          ; Dump the code only when there are modifications
-          (when (!= (hash-table-ref/default code-table key "") val)
-            (display* "TeXmacs] Building " (url->system target) "\n")
-            (string-save val target)
-            (hash-table-set! code-table key val)))))))
-
-(define (lp-build* file dir)
-  (with doc (if (buffer-exists? file)
-                (buffer-get-body file)
-                (tmfile-extract (tree-import file "texmacs") 'body))
-    (with t (build-table doc)
-      (with x (expand-table t)
-        (with v (verbatim-table x)
-          (write-table v dir))))))
-
-(define (lp-build file dir)
-  (if (buffer-exists? file)
-      (lp-build* file dir)
-      (lp-build-conditional file dir lp-build*)))
-
-(tm-define (lp-build-buffer)
-  (update-all-chunk-states)
-  (lp-build (current-buffer) (url-head (current-buffer))))
-
-(tm-define (lp-build-buffer-in dir)
-  (:argument dir "Build directory")
-  (update-all-chunk-states)
-  (lp-build (current-buffer) dir))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Building all files in a directory
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (lp-build-directory source target)
-  (let* ((f (url-append (url-append source (url-any)) (url-wildcard "*.tm")))
-         (l (url->list (url-expand (url-complete f "r")))))
-    (for (src l)
-      (let* ((rel (url-delta (url-append source "dummy") src))
-             (obj (url-append target rel)))
-        (lp-build src (url-head obj))))))
-
-(tm-define (lp-interactive-build-directory)
-  (:interactive #t)
-  (user-url "Directory" "directory" 
-    (lambda (src) (lp-build-directory src src))))
-
-(tm-define (lp-interactive-build-directory-in)
-  (:interactive #t)
-  (user-url "Source directory" "directory" 
-    (lambda (src) (user-url "Destination directory" "directory"
-      (lambda (dest) (lp-build-directory src dest))))))
diff --git a/TeXmacs/plugins/literate/progs/utils/literate/lp-edit.scm b/TeXmacs/plugins/literate/progs/utils/literate/lp-edit.scm
deleted file mode 100644
index 2fede1970b..0000000000
--- a/TeXmacs/plugins/literate/progs/utils/literate/lp-edit.scm
+++ /dev/null
@@ -1,245 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : lp-edit.scm
-;; DESCRIPTION : editing literate programs
-;; COPYRIGHT   : (C) 2015  Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (utils literate lp-edit)
-  (:use (utils library cursor)
-        (generic document-edit)
-        (dynamic dynamic-drd)))
-
-(import (liii list))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; DRD properties
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define-group chunk-tag
-  generic-chunk verbatim-chunk scm-chunk cpp-chunk mmx-chunk
-  python-chunk scilab-chunk shell-chunk scala-chunk java-chunk
-  goldfish-chunk elvish-chunk json-chunk)
-
-(define-group variant-tag
-  (chunk-tag))
-
-(define-group similar-tag
-  (chunk-tag))
-
-(define-group appended-tag
-  folded-newline-before unfolded-newline-before
-  folded-opening unfolded-opening
-  folded-ending unfolded-ending)
-
-(define-fold folded-newline-before unfolded-newline-before)
-(define-fold folded-opening unfolded-opening)
-(define-fold folded-ending unfolded-ending)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Searching chunks in document
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tm-chunk? t)
-  (and (tm-in? t (chunk-tag-list)) (== (tm-arity t) 4)))
-
-(define (search-chunks t)
-  (cond ((tm-atomic? t) (list))
-        ((tm-func? t 'document)
-         (flat-map search-chunks (tm-children t)))
-        ((tm-chunk? t)
-         (if (and (tm-atomic? (tm-ref t 0))) (list t) (list)))
-        (else
-          (with l (list-filter (tm-children t) (cut tm-func? <> 'document))
-            (flat-map search-chunks l)))))
-
-(tm-define (get-all-chunks)
-  (search-chunks (buffer-tree)))
-
-(define (search-named-chunks name all-chunks)
-  (list-filter all-chunks (lambda (c) (== (tm->string (tm-ref c 0)) name))))
-
-(tm-define (search-chunk-types all-chunks)
-  (let* ((l all-chunks)
-         (r (map (lambda (c) (tm->string (tm-ref c 0))) l)))
-    (list-remove-duplicates r)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Maintaining states (links to previous and next chunks)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (update-chunk-states name all-chunks)
-  (with l (search-named-chunks name all-chunks)
-    (when (nnull? l)
-      (tree-set (tm-ref (car l) 1) "false")
-      (for (x (cdr l))
-        (tree-set (tm-ref x 1) "true"))
-      (tree-set (tm-ref (cAr l) 2) "false")
-      (for (x (cDr l))
-        (tree-set (tm-ref x 2) "true")))))
-
-(tm-define (update-all-chunk-states)
-  (with all-chunks (get-all-chunks)
-    (for (name (search-chunk-types all-chunks))
-    (update-chunk-states name all-chunks))))
-
-(tm-define (update-document what)
-  (:require (style-has? "literate-dtd"))
-  (former what)
-  (when (or (== what "all") (== what "chunks"))
-    (update-all-chunk-states)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Inserting new chunks; semi-automatic determination of appropriate language
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (chunk-format name)
-  (with suffix (locase-all (url-suffix name))
-    (cond ((== suffix "") "generic")
-          ((in? suffix '("txt")) "verbatim")
-          ((in? suffix '("scm")) "scm")
-          ((in? suffix '("scala")) "scala")
-          ((in? suffix '("java")) "java")
-          ((in? suffix '("c" "cc" "cpp" "h" "hh" "hpp")) "cpp")
-          ((in? suffix '("mmx" "mmh")) "mmx")
-          ((in? suffix '("py")) "python")
-          ((in? suffix '("sce" "sci")) "scilab")
-          ((in? suffix '("bat" "sh")) "shell")
-          (else "verbatim"))))
-
-(define (chunk-tag name)
-  (string->symbol (string-append (chunk-format name) "-chunk")))
-
-(define (similar-chunk-tag name all-chunks)
-  (with l (search-named-chunks name all-chunks)
-    (if (null? l) (chunk-tag name) (tree-label (car l)))))
-
-(tm-define (insert-new-chunk tag)
-  (insert-go-to `(,tag "" "false" "false" (document "")) '(0 0)))
-
-(tm-define (insert-next-chunk name)
-  (:argument name "Chunk name")
-  (with all-chunks (get-all-chunks)
-    (with tag (similar-chunk-tag name all-chunks)
-      (insert-go-to `(,tag ,name "true" "false" (document "")) '(3 0))
-      (update-chunk-states name all-chunks))))
-
-(tm-define (kbd-enter t shift?)
-  (:require (and (tm-chunk? t) (cursor-inside? (tm-ref t 0))))
-  (let* ((name (if (tm-atomic? (tm-ref t 0)) (tm->string (tm-ref t 0)) ""))
-         (tag (chunk-tag name)))
-    (when (!= tag 'generic-chunk)
-      (tree-assign-node! t tag))
-    (tree-go-to t 3 :start)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Removing chunks
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (kbd-remove t forwards?)
-  (:require (tm-chunk? t))
-  (cond ((selection-active-any?)
-         (former t forwards?))
-        ((and (tree-empty? (tm-ref t 0)) (tree-empty? (tm-ref t 3)))
-         (tree-select t)
-         (clipboard-cut "nowhere"))
-        ((and (tree-cursor-at? t 0 :start) (not forwards?))
-         (tree-go-to t :start))
-        ((and (tree-cursor-at? t 0 :end) forwards?)
-         (tree-go-to t 3 :start))
-        ((and (tree-cursor-at? t 3 :start) (not forwards?))
-         (tree-go-to t 0 :end))
-        ((and (tree-cursor-at? t 3 :end) forwards?)
-         (tree-go-to t :end))
-        ((cursor-inside? (tree-ref t 0))
-         (former t forwards?))
-        (else (former t forwards?))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Cursor movement
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define ((inside-named-chunk? name nr same-type? other?) t)
-  (and-with c (tree-search-upwards t tm-chunk?)
-    (and (or (not same-type?)
-             (tm-equal? (tm-ref c 0) name))
-         (or (not other?)
-             (!= (tree->path (tree-ref c 0))
-                 (tree->path name)))
-         (cursor-inside? (tm-ref c nr)))))
-
-(define (go-to-next-in-chunk fun same-type? other?)
-  (with-innermost t tm-chunk?
-    (if (not t) (fun)
-        (let* ((name (tm-ref t 0))
-               (nr (tree-index (tree-down t)))
-               (inside? (inside-named-chunk? name nr same-type? other?)))
-          ;;(go-to-next-inside fun inside?)))))
-          (go-to-next-such-that fun inside?)))))
-
-(define (go-to-start-chunk)
-  (with-innermost t tm-chunk?
-    (when (and t (tree-down t))
-      (with nr (tree-index (tree-down t))
-        (tree-go-to t nr :start)))))
-
-;;(tm-define (kbd-horizontal t forwards?)
-;;  (:require (tm-chunk? t))
-;;  (go-to-next-in-chunk (if forwards? go-right go-left) #f #f))
-
-(tm-define (kbd-vertical t downwards?)
-  (:require (tm-chunk? t))
-  (go-to-next-in-chunk (if downwards? go-down go-up) #f #f))
-
-(tm-define (kbd-incremental t downwards?)
-  (:require (tm-chunk? t))
-  (go-to-next-in-chunk (if downwards? go-down go-up) #f #t)
-  (go-to-start-chunk))
-
-(tm-define (traverse-extremal t forwards?)
-  (:require (tm-chunk? t))
-  (with move (if forwards? go-down go-up)
-    (with chunk-move (lambda ()
-                       (go-to-next-in-chunk move #t #t)
-                       (go-to-start-chunk))
-      (go-to-repeat chunk-move))))
-
-(tm-define (traverse-incremental t downwards?)
-  (:require (tm-chunk? t))
-  (go-to-next-in-chunk (if downwards? go-down go-up) #t #t)
-  (go-to-start-chunk))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Folding
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (tm-appended? t)
-  (tm-in? t (appended-tag-list)))
-
-(tm-define (search-appended t)
-  (cond ((tm-atomic? t) (list))
-        ((tm-func? t 'document) (flat-map search-appended (tm-children t)))
-        ((tm-appended? t) (list t))
-        (else
-          (with l (list-filter (tm-children t) (cut tm-func? <> 'document))
-            (flat-map search-appended l)))))
-
-(tm-define (search-appended-folded t)
-  (list-filter (search-appended t) alternate-standard-first?))
-
-(tm-define (search-appended-unfolded t)
-  (list-filter (search-appended t) alternate-standard-second?))
-
-(tm-define (fold-appended)
-  (with l (search-appended (buffer-tree))
-    (for-each alternate-fold l)))
-
-(tm-define (unfold-appended)
-  (with l (search-appended (buffer-tree))
-    (for-each alternate-unfold l)))
diff --git a/TeXmacs/plugins/literate/progs/utils/literate/lp-menu.scm b/TeXmacs/plugins/literate/progs/utils/literate/lp-menu.scm
deleted file mode 100644
index fdfdcb2bc8..0000000000
--- a/TeXmacs/plugins/literate/progs/utils/literate/lp-menu.scm
+++ /dev/null
@@ -1,83 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : lp-menu.scm
-;; DESCRIPTION : menus for literate programming
-;; COPYRIGHT   : (C) 2015  Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (utils literate lp-menu)
-  (:use (utils literate lp-build)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Main literate programming menu
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(menu-bind literate-menu
-  (-> "First chunk"
-      ("Scheme" (insert-new-chunk 'scm-chunk))
-      ("C++" (insert-new-chunk 'cpp-chunk))
-      ("Generic" (insert-new-chunk 'generic-chunk))
-      ("Verbatim" (insert-new-chunk 'verbatim-chunk))
-      ("Shell" (insert-new-chunk 'shell-chunk))
-      ---
-      (when (style-has? "json")
-        ("JSON" (insert-new-chunk 'json-chunk)))
-      (when (style-has? "elvish-lang")
-        ("Elvish" (insert-new-chunk 'elvish-chunk)))
-      (when (style-has? "goldfish-lang")
-        ("Goldfish" (insert-new-chunk 'goldfish-chunk)))
-      (when (style-has? "scala")
-        ("Scala" (insert-new-chunk 'scala-chunk)))
-      (when (style-has? "java")
-        ("Java" (insert-new-chunk 'java-chunk)))
-      (when (style-has? "python")
-        ("Python" (insert-new-chunk 'python-chunk))))
-  (with all-chunks (get-all-chunks)
-    (when (nnull? (search-chunk-types all-chunks))
-       (if (null? (search-chunk-types all-chunks))
-           ("Next chunk" (interactive insert-next-chunk)))
-       (if (nnull? (search-chunk-types all-chunks))
-           (-> "Next chunk"
-               (for (name (search-chunk-types all-chunks))
-                 ((eval `(verbatim ,name)) (insert-next-chunk name)))
-               ---
-               ("Other" (interactive insert-next-chunk))))
-       (if (null? (search-chunk-types all-chunks))
-           ("Reference" (make 'chunk-ref)))
-       (if (nnull? (search-chunk-types all-chunks))
-           (-> "Reference"
-               (for (name (search-chunk-types all-chunks))
-                 ((eval `(verbatim ,name)) (insert `(chunk-ref ,name))))
-               ---
-               ("Other" (make 'chunk-ref))))))
- 
-  ---
-  ("Invisible newline" (make 'folded-newline-before))
-  ("Invisible opening" (make 'unfolded-opening))
-  ("Invisible ending" (make 'unfolded-ending))
-  (when (nnull? (search-appended-unfolded (buffer-tree)))
-    ("Fold all" (fold-appended)))
-  (when (nnull? (search-appended-folded (buffer-tree)))
-    ("Unfold all" (unfold-appended)))
-  ---
-  (when (nnull? (search-chunk-types (get-all-chunks)))
-    ("Build buffer" (lp-build-buffer))
-    ("Build buffer in" (interactive lp-build-buffer-in)))
-  ("Build directory" (lp-interactive-build-directory))
-  ("Build directory in" (lp-interactive-build-directory-in)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Insert menu as extra top level menu
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(menu-bind texmacs-extra-menu
-  (former)
-  (if (style-has? "literate-dtd")
-      (=> "Literate"
-          (link literate-menu))))
diff --git a/TeXmacs/plugins/llm/goldfish/data/liii_llm_menu.json b/TeXmacs/plugins/llm/goldfish/data/liii_llm_menu.json
new file mode 100644
index 0000000000..43f79f3bd6
--- /dev/null
+++ b/TeXmacs/plugins/llm/goldfish/data/liii_llm_menu.json
@@ -0,0 +1,19 @@
+{
+  "default": "kimi-k3",
+  "models": [
+    {
+      "model": "kimi-k3",
+      "name": "K3",
+      "base_url": "",
+      "default_system": "",
+      "thinking": true,
+      "search": true,
+      "enable": true,
+      "allow_thinking": true,
+      "allow_search": true,
+      "icon": "kimi",
+      "description": "",
+      "dsc_color": "orange"
+    }
+  ]
+}
diff --git a/TeXmacs/plugins/llm/packages/session/llm.stem b/TeXmacs/plugins/llm/packages/session/llm.stem
new file mode 100644
index 0000000000..6f10dce309
--- /dev/null
+++ b/TeXmacs/plugins/llm/packages/session/llm.stem
@@ -0,0 +1,149 @@
+(document (TeXmacs "2.1.4")
+  (style "source")
+  (body (document (active* (src-title (document (src-package "llm" "1.0")
+                                        (src-purpose (document "Markup for LLM sessions."))
+                                        (src-copyright "2021"
+                                          (document "Joris van der Hoeven"
+                                            "    2024 by Darcy Shen"
+                                            "    2025 by Jack Yansong Li"
+                                          ) ;document
+                                        ) ;src-copyright
+                                        (src-license (document (concat "This software falls under the "
+                                                                 (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE")
+                                                                 ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see "
+                                                                 (hlink "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                   "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                 ) ;hlink
+                                                                 "."
+                                                               ) ;concat
+                                                     ) ;document
+                                        ) ;src-license
+                                      ) ;document
+                           ) ;src-title
+                  ) ;active*
+          (use-package "session")
+          (assign "session"
+            (macro "language"
+              "session"
+              "body"
+              (document (with "prog-language"
+                          (arg "language")
+                          "prog-session"
+                          (arg "session")
+                          (document (render-session (arg "body")) "")
+                        ) ;with
+              ) ;document
+            ) ;macro
+          ) ;assign
+          ""
+          (assign "llm-input-bg-color"
+            (macro (if (equal (value "color") "white") "#9ba8c2" "#f0f4ff"))
+          ) ;assign
+          (assign "llm-prompt-color" "#4d6cff")
+          (assign "llm-input-color"
+            (macro (if (equal (value "color") "white") "#242938" "dark blue"))
+          ) ;assign
+          (active* (document (src-comment (document "Input field with background color")))
+          ) ;active*
+          (macro "indent-both"
+            (macro "left-indentation"
+              "right-indentation"
+              "body"
+              (document (with "par-left"
+                          (plus (value "par-left") (arg "left-indentation"))
+                          "par-right"
+                          (plus (value "par-right") (arg "right-indentation"))
+                          (arg "body")
+                        ) ;with
+              ) ;document
+            ) ;macro
+          ) ;macro
+          (assign "llm-indent" (macro (if (greater "1par" "20cm") "0.1par" "0par")))
+          (assign "llm-input"
+            (macro "prompt"
+              "body"
+              (document (indent-both (llm-indent)
+                          (llm-indent)
+                          (document (with "ornament-shape"
+                                      "classic"
+                                      "ornament-color"
+                                      (llm-input-bg-color)
+                                      "ornament-border"
+                                      "0ln"
+                                      "ornament-vpadding"
+                                      "0.3fn"
+                                      (document (ornament (document (tabular (tformat (twith "table-width" "1par")
+                                                                               (cwith "1" "1" "2" "2" "cell-hpart" "1")
+                                                                               (cwith "1" "1" "1" "1" "cell-lsep" "0fn")
+                                                                               (cwith "1" "1" "1" "1" "cell-rsep" "0fn")
+                                                                               (cwith "1" "1" "2" "2" "cell-lsep" "0fn")
+                                                                               (cwith "1" "1" "2" "2" "cell-rsep" "0fn")
+                                                                               (cwith "1" "1" "2" "2" "cell-hyphen" "t")
+                                                                               (twith "table-hyphen" "y")
+                                                                               (table (row (cell (id-function (with "color" (value "llm-prompt-color") (arg "prompt"))))
+                                                                                        (cell (document (with "color" (llm-input-color) "math-display" "true" (arg "body")))
+                                                                                        ) ;cell
+                                                                                      ) ;row
+                                                                               ) ;table
+                                                                             ) ;tformat
+                                                                    ) ;tabular
+                                                          ) ;document
+                                                ) ;ornament
+                                      ) ;document
+                                    ) ;with
+                          ) ;document
+                        ) ;indent-both
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (active* (document (src-comment (document "Use verbatim output"))))
+          (assign "llm-output"
+            (macro "body"
+              (document (indent-both (llm-indent)
+                          (llm-indent)
+                          (document (with "info-flag"
+                                      "none"
+                                      "font-family"
+                                      "CMU"
+                                      (document (generic-output (document (text (arg "body")))))
+                                    ) ;with
+                          ) ;document
+                        ) ;indent-both
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "llm-errput"
+            (macro "body"
+              (document (with "mode"
+                          "text"
+                          "language"
+                          "verbatim"
+                          "font-family"
+                          "CMU"
+                          (document (generic-errput (document (arg "body"))))
+                        ) ;with
+              ) ;document
+            ) ;macro
+          ) ;assign
+          (assign "llm-thinking-dots"
+            (macro (anim-repeat (anim-compose (anim-constant "" "0.35sec")
+                                  (anim-constant "." "0.35sec")
+                                  (anim-constant ".." "0.35sec")
+                                  (anim-constant "..." "0.35sec")
+                                ) ;anim-compose
+                   ) ;anim-repeat
+            ) ;macro
+          ) ;assign
+          (assign "script-busy"
+            (macro "msg"
+              (script-status (if (equal (arg "msg") (uninit))
+                               (concat (localize "Thinking") (llm-thinking-dots))
+                               (arg "msg")
+                             ) ;if
+              ) ;script-status
+            ) ;macro
+          ) ;assign
+        ) ;document
+  ) ;body
+  (initial (collection (associate "preamble" "true")))
+) ;document
diff --git a/TeXmacs/plugins/llm/packages/session/llm.ts b/TeXmacs/plugins/llm/packages/session/llm.ts
deleted file mode 100644
index bd0dba21e0..0000000000
--- a/TeXmacs/plugins/llm/packages/session/llm.ts
+++ /dev/null
@@ -1,104 +0,0 @@
-
-
-
-
-<\body>
-  
-    
-
-    <\src-purpose>
-      Markup for LLM sessions.
-    
-
-    <\src-copyright|2021>
-      Joris van der Hoeven
-
-      \ \ \ \ 2024 by Darcy Shen
-
-      \ \ \ \ 2025 by Jack Yansong Li
-    
-
-    <\src-license>
-      This software falls under the . It comes WITHOUT ANY
-      WARRANTY WHATSOEVER. You should have received a copy of the license
-      which the software. If not, see .
-    
-  >
-
-  
-
-  
-    <\with|prog-language||prog-session|>
-      >
-
-      \;
-    
-  >
-
-  \;
-
-  |white>|#9ba8c2|#f0f4ff>>>
-
-  
-
-  |white>|#242938|dark blue>>>
-
-  <\active*>
-    <\src-comment>
-      Input field with background color
-    
-  
-
-  
-    |>|par-right||>|>
-  >
-
-  |0.1par|0par>>>
-
-  
-    <\indent-both||>
-      <\with|ornament-shape|classic|ornament-color||ornament-border|0ln|ornament-vpadding|0.3fn>
-        <\ornament>
-          |||||||||>>>|<\cell>
-            |math-display|true|>
-          >>>>
-        
-      
-    
-  >
-
-  <\active*>
-    <\src-comment>
-      Use verbatim output
-    
-  
-
-  
-    <\indent-both||>
-      <\with|info-flag|none|font-family|CMU>
-        <\generic-output>
-          >
-        
-      
-    
-  >
-
-  
-    <\with|mode|text|language|verbatim|font-family|CMU>
-      <\generic-errput>
-        
-      
-    
-  >
-
-  |||>>>>
-
-  |>||>|>>>>
-
-
-<\initial>
-  <\collection>
-    
-  
-
diff --git a/TeXmacs/plugins/llm/progs/llm/chat-list.scm b/TeXmacs/plugins/llm/progs/llm/chat-list.scm
new file mode 100644
index 0000000000..08023dcc18
--- /dev/null
+++ b/TeXmacs/plugins/llm/progs/llm/chat-list.scm
@@ -0,0 +1,225 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : chat-list.scm
+;; DESCRIPTION : Chat session list persistence (manifest and entries)
+;; COPYRIGHT   : (C) 2026 Mogan STEM
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (llm chat-list))
+
+(import (liii njson))
+
+;;; ---------- 路径工具 ----------
+
+(tm-define (chat-persist-home-path) (url->system (get-texmacs-home-path)))
+
+(tm-define (chat-persist-base-dir)
+  (string-append (chat-persist-home-path) "/system/ai-chat-sessions")
+) ;tm-define
+
+(tm-define (chat-persist-manifest-path)
+  (string-append (chat-persist-base-dir) "/manifest.json")
+) ;tm-define
+
+(tm-define (chat-persist-message-path session-id)
+  (string-append (chat-persist-base-dir) "/" session-id "/message.tmu")
+) ;tm-define
+
+;;; ---------- 目录管理 ----------
+
+(tm-define (chat-persist-parent-dir dir)
+  (url->system (url-head (system->url dir)))
+) ;tm-define
+
+(tm-define (chat-persist-ensure-dir! dir)
+  (if (not (file-exists? dir))
+    (begin
+      (chat-persist-ensure-dir! (chat-persist-parent-dir dir))
+      (mkdir dir)
+    ) ;begin
+  ) ;if
+) ;tm-define
+
+;;; ---------- JSON 条目 ----------
+
+(tm-define (chat-persist-make-entry sid title model archived . rest)
+  (let* ((created-at (if (and (pair? rest) (car rest)) (car rest) (number->string (current-time)))
+         ) ;created-at
+         (opts (if (pair? rest) (cdr rest) '()))
+         (thinking (if (and (pair? opts) (car opts)) (car opts) "disabled"))
+         (opts2 (if (pair? opts) (cdr opts) '()))
+         (search (if (and (pair? opts2) (car opts2)) (car opts2) "disabled"))
+         (updated-at (if (and (pair? opts2) (pair? (cdr opts2)) (cadr opts2)) (cadr opts2) #f)
+         ) ;updated-at
+         (entry (string->njson "{}"))
+        ) ;
+    (njson-set! entry "sessionId" sid)
+    (njson-set! entry "title" title)
+    (njson-set! entry "model" model)
+    (njson-set! entry
+      "archived"
+      (if (or (not archived) (== archived "false")) "false" "true")
+    ) ;njson-set!
+    (njson-set! entry "createdAt" (or created-at ""))
+    (njson-set! entry "defaultExpandCount" 5)
+    (njson-set! entry "thinking" thinking)
+    (njson-set! entry "search" search)
+    ;; updateAt: 最近活跃时间戳，用于排序索引；缺失时回退到 createdAt
+    (njson-set! entry "updateAt" (or updated-at created-at ""))
+    entry
+  ) ;let*
+) ;tm-define
+
+;;; ---------- 加载状态 ----------
+
+(tm-define (chat-persist-load-all)
+  (let ((manifest-path (chat-persist-manifest-path)))
+    (if (not (file-exists? manifest-path))
+      (noop)
+      (let* ((manifest (file->njson manifest-path))
+             (sessions-json (njson-ref manifest "sessions"))
+             (entries (njson-array->list sessions-json))
+            ) ;
+        (for-each (lambda (entry)
+                    ;; njson-array->list 返回 alist，用 assoc 访问字段
+                    (let* ((sid (cdr (assoc "sessionId" entry)))
+                           (title (cdr (assoc "title" entry)))
+                           (model (cdr (assoc "model" entry)))
+                           (archived-str (cdr (assoc "archived" entry)))
+                           (created-at-pair (assoc "createdAt" entry))
+                           (created-at (if created-at-pair (cdr created-at-pair) ""))
+                           (updated-at-pair (assoc "updateAt" entry))
+                           ;; updateAt 缺失时回退到 createdAt（兼容旧 manifest）
+                           (updated-at (if updated-at-pair (cdr updated-at-pair) created-at))
+                           (expand-count-pair (assoc "defaultExpandCount" entry))
+                           (expand-count (if expand-count-pair (cdr expand-count-pair) 5))
+                           (thinking-pair (assoc "thinking" entry))
+                           (thinking (if thinking-pair (cdr thinking-pair) "disabled"))
+                           (search-pair (assoc "search" entry))
+                           (search (if search-pair (cdr search-pair) "disabled"))
+                          ) ;
+                      ;; 只传元数据给 C++，不加载 buffer 内容
+                      (qt-chat-tab-restore-session sid title model archived-str
+                        created-at updated-at expand-count thinking search
+                      ) ;qt-chat-tab-restore-session
+                    ) ;let*
+                  ) ;lambda
+          entries
+        ) ;for-each
+        (njson-free manifest)
+      ) ;let*
+    ) ;if
+  ) ;let
+) ;tm-define
+
+;;; ---------- 增量保存 ----------
+
+(tm-define (chat-persist-update-manifest session-id title model archived . rest)
+  (let* ((created-at (if (and (pair? rest) (car rest)) (car rest) (number->string (current-time)))
+         ) ;created-at
+         (opts (if (pair? rest) (cdr rest) '()))
+         (thinking (if (and (pair? opts) (car opts)) (car opts) "disabled"))
+         (opts2 (if (pair? opts) (cdr opts) '()))
+         (search (if (and (pair? opts2) (car opts2)) (car opts2) "disabled"))
+         (updated-at (if (and (pair? opts2) (pair? (cdr opts2)) (cadr opts2)) (cadr opts2) #f)
+         ) ;updated-at
+         (manifest-path (chat-persist-manifest-path))
+         (entry (chat-persist-make-entry session-id title model archived
+                  created-at thinking search updated-at
+                ) ;chat-persist-make-entry
+         ) ;entry
+        ) ;
+    (chat-persist-ensure-dir! (chat-persist-base-dir))
+    (if (not (file-exists? manifest-path))
+      ;; manifest 不存在：创建新的，直接构建包含 entry 的数组
+      (let* ((manifest (string->njson "{\"version\":1,\"sessions\":[]}"))
+             (new-arr (string->njson "[]"))
+            ) ;
+        (njson-append! new-arr entry)
+        (njson-set! manifest "sessions" new-arr)
+        (njson->file manifest-path manifest)
+        (njson-free new-arr)
+        (njson-free manifest)
+      ) ;let*
+      ;; manifest 存在：读取，查找并更新或追加
+      (let* ((manifest (file->njson manifest-path))
+             (sessions-arr (njson-ref manifest "sessions"))
+             (entries (njson-array->list sessions-arr))
+            ) ;
+        (let ((new-arr (string->njson "[]")) (found #f))
+          (for-each (lambda (e)
+                      (let ((sid-pair (assoc "sessionId" e)))
+                        (if (and sid-pair (== (cdr sid-pair) session-id))
+                          (begin
+                            (njson-append! new-arr entry)
+                            (set! found #t)
+                          ) ;begin
+                          (njson-append! new-arr (json->njson e))
+                        ) ;if
+                      ) ;let
+                    ) ;lambda
+            entries
+          ) ;for-each
+          (when (not found)
+            (njson-append! new-arr entry)
+          ) ;when
+          (njson-drop! manifest "sessions")
+          (njson-set! manifest "sessions" new-arr)
+          (njson->file manifest-path manifest)
+          (njson-free new-arr)
+          (njson-free manifest)
+        ) ;let
+      ) ;let*
+    ) ;if
+    (njson-free entry)
+  ) ;let*
+) ;tm-define
+
+;;; ---------- 删除持久化会话 ----------
+
+(tm-define (chat-persist-delete-one session-id)
+  (:synopsis "Delete a chat session from persistent storage")
+  (:argument session-id "Session UUID")
+  ;; 1. 删除会话目录及消息文件
+  (let ((session-dir (string-append (chat-persist-base-dir) "/" session-id)))
+    (when (file-exists? session-dir)
+      (let ((msg-path (chat-persist-message-path session-id)))
+        (when (file-exists? msg-path)
+          (system-remove (system->url msg-path))
+        ) ;when
+      ) ;let
+      (system-rmdir (system->url session-dir))
+    ) ;when
+  ) ;let
+  ;; 2. 从 manifest 中移除条目
+  (let ((manifest-path (chat-persist-manifest-path)))
+    (when (file-exists? manifest-path)
+      (let* ((manifest (file->njson manifest-path))
+             (sessions-arr (njson-ref manifest "sessions"))
+             (entries (njson-array->list sessions-arr))
+            ) ;
+        (let ((new-arr (string->njson "[]")))
+          (for-each (lambda (e)
+                      (let ((sid-pair (assoc "sessionId" e)))
+                        (when (not (and sid-pair (== (cdr sid-pair) session-id)))
+                          (njson-append! new-arr (json->njson e))
+                        ) ;when
+                      ) ;let
+                    ) ;lambda
+            entries
+          ) ;for-each
+          (njson-drop! manifest "sessions")
+          (njson-set! manifest "sessions" new-arr)
+          (njson->file manifest-path manifest)
+          (njson-free new-arr)
+          (njson-free manifest)
+        ) ;let
+      ) ;let*
+    ) ;when
+  ) ;let
+) ;tm-define
diff --git a/TeXmacs/plugins/llm/progs/llm/chat-loader.scm b/TeXmacs/plugins/llm/progs/llm/chat-loader.scm
index b9f6b9d0fb..a9afbe503c 100644
--- a/TeXmacs/plugins/llm/progs/llm/chat-loader.scm
+++ b/TeXmacs/plugins/llm/progs/llm/chat-loader.scm
@@ -20,4 +20,6 @@
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(texmacs-module (llm chat-loader) (:use (llm chat-protocol) (llm chat-persist)))
+(texmacs-module (llm chat-loader)
+  (:use (llm chat-style) (llm chat-protocol) (llm chat-list) (llm chat-persist))
+) ;texmacs-module
diff --git a/TeXmacs/plugins/llm/progs/llm/chat-persist.scm b/TeXmacs/plugins/llm/progs/llm/chat-persist.scm
index 898c9237e1..43f24c881a 100644
--- a/TeXmacs/plugins/llm/progs/llm/chat-persist.scm
+++ b/TeXmacs/plugins/llm/progs/llm/chat-persist.scm
@@ -11,76 +11,15 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (texmacs-module (llm chat-persist)
-  (:use (llm chat-protocol)
+  (:use (llm chat-list)
+    (llm chat-style)
+    (llm chat-protocol)
     (dynamic session-edit)
     (texmacs texmacs tm-files)
     (utils library cursor)
   ) ;:use
 ) ;texmacs-module
 
-(import (liii njson) (liii os))
-
-;;; ---------- 路径工具 ----------
-
-(tm-define (chat-persist-home-path) (url->system (get-texmacs-home-path)))
-
-(tm-define (chat-persist-base-dir)
-  (string-append (chat-persist-home-path) "/system/ai-chat-sessions")
-) ;tm-define
-
-(tm-define (chat-persist-manifest-path)
-  (string-append (chat-persist-base-dir) "/manifest.json")
-) ;tm-define
-
-(tm-define (chat-persist-message-path session-id)
-  (string-append (chat-persist-base-dir) "/" session-id "/message.tmu")
-) ;tm-define
-
-;;; ---------- 目录管理 ----------
-
-(tm-define (chat-persist-parent-dir dir)
-  (url->system (url-head (system->url dir)))
-) ;tm-define
-
-(tm-define (chat-persist-ensure-dir! dir)
-  (if (not (file-exists? dir))
-    (begin
-      (chat-persist-ensure-dir! (chat-persist-parent-dir dir))
-      (mkdir dir)
-    ) ;begin
-  ) ;if
-) ;tm-define
-
-;;; ---------- JSON 条目 ----------
-
-(tm-define (chat-persist-make-entry sid title model archived . rest)
-  (let* ((created-at (if (and (pair? rest) (car rest)) (car rest) (number->string (current-time)))
-         ) ;created-at
-         (opts (if (pair? rest) (cdr rest) '()))
-         (thinking (if (and (pair? opts) (car opts)) (car opts) "disabled"))
-         (opts2 (if (pair? opts) (cdr opts) '()))
-         (search (if (and (pair? opts2) (car opts2)) (car opts2) "disabled"))
-         (updated-at (if (and (pair? opts2) (pair? (cdr opts2)) (cadr opts2)) (cadr opts2) #f)
-         ) ;updated-at
-         (entry (string->njson "{}"))
-        ) ;
-    (njson-set! entry "sessionId" sid)
-    (njson-set! entry "title" title)
-    (njson-set! entry "model" model)
-    (njson-set! entry
-      "archived"
-      (if (or (not archived) (== archived "false")) "false" "true")
-    ) ;njson-set!
-    (njson-set! entry "createdAt" (or created-at ""))
-    (njson-set! entry "defaultExpandCount" 5)
-    (njson-set! entry "thinking" thinking)
-    (njson-set! entry "search" search)
-    ;; updateAt: 最近活跃时间戳，用于排序索引；缺失时回退到 createdAt
-    (njson-set! entry "updateAt" (or updated-at created-at ""))
-    entry
-  ) ;let*
-) ;tm-define
-
 ;;; ---------- 标题提取 ----------
 
 (tm-define (chat-persist-extract-title session-id)
@@ -93,54 +32,7 @@
   ) ;let*
 ) ;tm-define
 
-;;; ---------- 加载状态 ----------
-
-(tm-define (chat-persist-load-all)
-  (let ((manifest-path (chat-persist-manifest-path)))
-    (if (not (file-exists? manifest-path))
-      (noop)
-      (let* ((manifest (file->njson manifest-path))
-             (sessions-json (njson-ref manifest "sessions"))
-             (entries (njson-array->list sessions-json))
-            ) ;
-        (for-each (lambda (entry)
-                    ;; njson-array->list 返回 alist，用 assoc 访问字段
-                    (let* ((sid (cdr (assoc "sessionId" entry)))
-                           (title (cdr (assoc "title" entry)))
-                           (model (cdr (assoc "model" entry)))
-                           (archived-str (cdr (assoc "archived" entry)))
-                           (created-at-pair (assoc "createdAt" entry))
-                           (created-at (if created-at-pair (cdr created-at-pair) ""))
-                           (updated-at-pair (assoc "updateAt" entry))
-                           ;; updateAt 缺失时回退到 createdAt（兼容旧 manifest）
-                           (updated-at (if updated-at-pair (cdr updated-at-pair) created-at))
-                           (expand-count-pair (assoc "defaultExpandCount" entry))
-                           (expand-count (if expand-count-pair (cdr expand-count-pair) 5))
-                           (thinking-pair (assoc "thinking" entry))
-                           (thinking (if thinking-pair (cdr thinking-pair) "disabled"))
-                           (search-pair (assoc "search" entry))
-                           (search (if search-pair (cdr search-pair) "disabled"))
-                          ) ;
-                      ;; 只传元数据给 C++，不加载 buffer 内容
-                      (qt-chat-tab-restore-session sid
-                        title
-                        model
-                        archived-str
-                        created-at
-                        updated-at
-                        expand-count
-                        thinking
-                        search
-                      ) ;qt-chat-tab-restore-session
-                    ) ;let*
-                  ) ;lambda
-          entries
-        ) ;for-each
-        (njson-free manifest)
-      ) ;let*
-    ) ;if
-  ) ;let
-) ;tm-define
+;;; ---------- 加载会话内容 ----------
 
 (tm-define (chat-persist-load-session-content session-id n)
   (let ((msg-path (chat-persist-message-path session-id))
@@ -186,117 +78,6 @@
   ) ;let
 ) ;tm-define
 
-(tm-define (chat-persist-update-manifest session-id title model archived . rest)
-  (let* ((created-at (if (and (pair? rest) (car rest)) (car rest) (number->string (current-time)))
-         ) ;created-at
-         (opts (if (pair? rest) (cdr rest) '()))
-         (thinking (if (and (pair? opts) (car opts)) (car opts) "disabled"))
-         (opts2 (if (pair? opts) (cdr opts) '()))
-         (search (if (and (pair? opts2) (car opts2)) (car opts2) "disabled"))
-         (updated-at (if (and (pair? opts2) (pair? (cdr opts2)) (cadr opts2)) (cadr opts2) #f)
-         ) ;updated-at
-         (manifest-path (chat-persist-manifest-path))
-         (entry (chat-persist-make-entry session-id
-                  title
-                  model
-                  archived
-                  created-at
-                  thinking
-                  search
-                  updated-at
-                ) ;chat-persist-make-entry
-         ) ;entry
-        ) ;
-    (chat-persist-ensure-dir! (chat-persist-base-dir))
-    (if (not (file-exists? manifest-path))
-      ;; manifest 不存在：创建新的，直接构建包含 entry 的数组
-      (let* ((manifest (string->njson "{\"version\":1,\"sessions\":[]}"))
-             (new-arr (string->njson "[]"))
-            ) ;
-        (njson-append! new-arr entry)
-        (njson-set! manifest "sessions" new-arr)
-        (njson->file manifest-path manifest)
-        (njson-free new-arr)
-        (njson-free manifest)
-      ) ;let*
-      ;; manifest 存在：读取，查找并更新或追加
-      (let* ((manifest (file->njson manifest-path))
-             (sessions-arr (njson-ref manifest "sessions"))
-             (entries (njson-array->list sessions-arr))
-            ) ;
-        (let ((new-arr (string->njson "[]")) (found #f))
-          (for-each (lambda (e)
-                      (let ((sid-pair (assoc "sessionId" e)))
-                        (if (and sid-pair (== (cdr sid-pair) session-id))
-                          (begin
-                            (njson-append! new-arr entry)
-                            (set! found #t)
-                          ) ;begin
-                          (njson-append! new-arr (json->njson e))
-                        ) ;if
-                      ) ;let
-                    ) ;lambda
-            entries
-          ) ;for-each
-          (when (not found)
-            (njson-append! new-arr entry)
-          ) ;when
-          (njson-drop! manifest "sessions")
-          (njson-set! manifest "sessions" new-arr)
-          (njson->file manifest-path manifest)
-          (njson-free new-arr)
-          (njson-free manifest)
-        ) ;let
-      ) ;let*
-    ) ;if
-    (njson-free entry)
-  ) ;let*
-) ;tm-define
-
-;;; ---------- 删除持久化会话 ----------
-
-(tm-define (chat-persist-delete-one session-id)
-  (:synopsis "Delete a chat session from persistent storage")
-  (:argument session-id "Session UUID")
-  ;; 1. 删除会话目录及消息文件
-  (let ((session-dir (string-append (chat-persist-base-dir) "/" session-id)))
-    (when (file-exists? session-dir)
-      (let ((msg-path (chat-persist-message-path session-id)))
-        (when (file-exists? msg-path)
-          (system-remove (system->url msg-path))
-        ) ;when
-      ) ;let
-      (system-rmdir (system->url session-dir))
-    ) ;when
-  ) ;let
-  ;; 2. 从 manifest 中移除条目
-  (let ((manifest-path (chat-persist-manifest-path)))
-    (when (file-exists? manifest-path)
-      (let* ((manifest (file->njson manifest-path))
-             (sessions-arr (njson-ref manifest "sessions"))
-             (entries (njson-array->list sessions-arr))
-            ) ;
-        (let ((new-arr (string->njson "[]")))
-          (for-each (lambda (e)
-                      (let ((sid-pair (assoc "sessionId" e)))
-                        (when (not (and sid-pair (== (cdr sid-pair) session-id)))
-                          (njson-append! new-arr (json->njson e))
-                        ) ;when
-                      ) ;let
-                    ) ;lambda
-            entries
-          ) ;for-each
-          (njson-drop! manifest "sessions")
-          (njson-set! manifest "sessions" new-arr)
-          (njson->file manifest-path manifest)
-          (njson-free new-arr)
-          (njson-free manifest)
-        ) ;let
-      ) ;let*
-    ) ;when
-  ) ;let
-) ;tm-define
-
 ;;; ---------- 导出会话到指定路径 ----------
 
 (tm-define (chat-persist-export-session-to session-id target-path)
diff --git a/TeXmacs/plugins/llm/progs/llm/chat-protocol.scm b/TeXmacs/plugins/llm/progs/llm/chat-protocol.scm
index c4d08d5057..6d48bd6c80 100644
--- a/TeXmacs/plugins/llm/progs/llm/chat-protocol.scm
+++ b/TeXmacs/plugins/llm/progs/llm/chat-protocol.scm
@@ -1,4 +1,3 @@
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
 ;; MODULE      : chat-protocol.scm
@@ -12,7 +11,8 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (texmacs-module (llm chat-protocol)
-  (:use (llm chat-tree-ops)
+  (:use (llm chat-style)
+    (llm chat-tree-ops)
     (utils library tree)
     (utils library cursor)
     (utils plugins plugin-eval)
@@ -21,7 +21,7 @@
     (kernel texmacs tm-plugins)
     (texmacs texmacs tm-files)
     (texmacs texmacs tm-server)
-    (data latex)
+    (latex latex-format)
   ) ;:use
 ) ;texmacs-module
 
@@ -39,20 +39,6 @@
   (search chat-input-search)
 ) ;define-record-type
 
-;;; ---------- 全局常量 ----------
-
-(define chat-tab-session-name "llm")
-
-;;; ---------- Buffer URL 推导函数 ----------
-
-(tm-define (chat-tab-session->message-buffer session-id)
-  (string->url (string-append "tmfs://chat/" session-id "/message"))
-) ;tm-define
-
-(tm-define (chat-tab-session->input-buffer session-id)
-  (string->url (string-append "tmfs://chat/" session-id "/input"))
-) ;tm-define
-
 ;;; ---------- Buffer 类型检测 ----------
 
 (tm-define (chat-message-buffer? buf)
@@ -83,6 +69,29 @@
   ) ;with
 ) ;tm-define
 
+(tm-define (chat-tab-prefillable-source? buf)
+  (:synopsis "Whether BUF is a valid source for chat input prefill")
+  ;; chat 相关 buffer（含 tmfs://chat-tab 与 tmfs://chat//*）不作为来源，
+  ;; 避免把聊天输入区自身的内容填回自身
+  (and buf (not (string-starts? (url->system buf) "tmfs://chat")))
+) ;tm-define
+
+(tm-define (chat-tab-prefill-session-input! session-id sel)
+  (:synopsis "Prefill the chat input for SESSION-ID with selection tree SEL")
+  (:argument session-id "Session UUID")
+  (:argument sel "Selection tree")
+  (chat-tab-prefill-input! (chat-tab-session->input-buffer session-id) sel)
+) ;tm-define
+
+(tm-define (chat-tab-prefill-from-selection! session-id)
+  (:synopsis "Prefill the chat input with the current document selection")
+  (:argument session-id "Session UUID")
+  ;; 须在焦点离开文档编辑器之前调用，selection-tree 取自 current editor
+  (when (and (chat-tab-prefillable-source? (current-buffer)) (selection-active-any?))
+    (chat-tab-prefill-session-input! session-id (selection-tree))
+  ) ;when
+) ;tm-define
+
 ;;; ---------- 会话初始化 ----------
 
 (tm-define (chat-tab-init-session! session-id model)
@@ -94,11 +103,15 @@
   (let ((plugin-ses (string-append "chat-tab:" session-id)))
     ;; Step 1: 注册 text-input 模式
     (session-enable-text-input chat-tab-session-name plugin-ses)
-    ;; Step 2: 初始化 buffer
+    ;; Step 2: 初始化 buffer（message buffer 可能尚未创建，
+    ;; with-buffer 对不存在的 buffer 静默返回 #f，需先创建）
+    (when (not (buffer-exists? (chat-tab-session->message-buffer session-id)))
+      (buffer-set (chat-tab-session->message-buffer session-id) '(document ""))
+    ) ;when
     (let* ((msg-buf (chat-tab-session->message-buffer session-id))
            (in-buf (chat-tab-session->input-buffer session-id))
           ) ;
-      (with-buffer msg-buf
+      (chat-tab-with-buffer msg-buf
         (let ((body (buffer-get-body msg-buf)))
           (when (chat-tab-buffer-empty? body)
             (buffer-set-body msg-buf
@@ -107,8 +120,10 @@
             (buffer-pretend-saved msg-buf)
           ) ;when
         ) ;let
-        (chat-tab-add-default-style-packages! chat-tab-session-name)
-      ) ;with-buffer
+        (when chat-tab-focus-ok?
+          (chat-tab-add-default-style-packages! chat-tab-session-name)
+        ) ;when
+      ) ;chat-tab-with-buffer
       (with-buffer in-buf
         (chat-tab-add-default-style-packages! chat-tab-session-name)
       ) ;with-buffer
@@ -116,42 +131,10 @@
   ) ;let
 ) ;tm-define
 
-(tm-define (chat-tab-load-input-styles! session-id)
-  (:synopsis "Load style packages for input buffer only (new conversation)")
-  (:argument session-id "Session UUID")
-  (let ((in-buf (chat-tab-session->input-buffer session-id)))
-    (with-buffer in-buf
-      (chat-tab-add-default-style-packages! chat-tab-session-name)
-    ) ;with-buffer
-  ) ;let
-) ;tm-define
-
-(tm-define (chat-tab-sync-dark-style! session-id)
-  ;; C++ 侧创建 panel 后调用，同步暗色样式包
-  (when (== (get-preference "gui theme") "liii-night")
-    (let ((msg-buf (chat-tab-session->message-buffer session-id))
-          (in-buf (chat-tab-session->input-buffer session-id))
-         ) ;
-      (with-buffer msg-buf
-        (when (not (has-style-package? "dark"))
-          (add-style-package "dark")
-        ) ;when
-      ) ;with-buffer
-      (with-buffer in-buf
-        (when (not (has-style-package? "dark"))
-          (add-style-package "dark")
-        ) ;when
-      ) ;with-buffer
-    ) ;let
-  ) ;when
-) ;tm-define
-
 ;;; ---------- 编码/解码 ----------
 
 (define (chat-tab-session-encode input session-id out opts)
-  (list (list chat-tab-session-do
-          chat-tab-session-notify
-          chat-tab-session-next
+  (list (list chat-tab-session-do chat-tab-session-notify chat-tab-session-next
           chat-tab-session-cancel
         ) ;list
     input
@@ -196,7 +179,7 @@
       (with (input session-id out opts)
         (chat-tab-session-decode (car l))
         (let ((msg-buf (chat-tab-session->message-buffer session-id)))
-          (with-buffer msg-buf
+          (chat-tab-with-buffer msg-buf
             (when (and (tm-func? out 'document)
                     (> (tree-arity out) 0)
                     (tm-func? (tree-ref out :last) 'script-busy)
@@ -204,7 +187,7 @@
               (tree-remove! out (- (tree-arity out) 1) 1)
             ) ;when
             (buffer-pretend-saved msg-buf)
-          ) ;with-buffer
+          ) ;chat-tab-with-buffer
         ) ;let
         (chat-tab-session-detach (car l))
         ;; 通知 C++ 生成结束
@@ -228,7 +211,7 @@
                    ;; t 包含 reasoning-delta → 提取并追加到 unfolded-explain
                    ;; 注意：t 可能同时包含 fold-explain-reasoning，需要一并处理
                    ((tree-contains-label? t 'reasoning-delta)
-                    (with-buffer msg-buf
+                    (chat-tab-with-buffer msg-buf
                       (let* ((text (tree-extract-reasoning-delta! t))
                              (has-fold? (tree-contains-label? t 'fold-explain-reasoning))
                             ) ;
@@ -247,28 +230,34 @@
                         ) ;when
                       ) ;let*
                       (buffer-pretend-saved msg-buf)
-                    ) ;with-buffer
+                    ) ;chat-tab-with-buffer
                    ) ;
                    ;; t 仅包含 fold-explain-reasoning → 直接折叠
                    ((tree-contains-label? t 'fold-explain-reasoning)
-                    (with-buffer msg-buf
+                    (chat-tab-with-buffer msg-buf
                       (chat-tab-fold-last-explain! out)
                       (buffer-pretend-saved msg-buf)
-                    ) ;with-buffer
+                    ) ;chat-tab-with-buffer
                    ) ;
                    ;; 正常输出
-                   (else (with-buffer msg-buf (chat-tab-output out t) (buffer-pretend-saved msg-buf))
+                   (else (chat-tab-with-buffer msg-buf
+                           (chat-tab-output out t)
+                           (buffer-pretend-saved msg-buf)
+                         ) ;chat-tab-with-buffer
                    ) ;else
                  ) ;cond
                 ) ;
                 ((== ch "error")
-                 (with-buffer msg-buf (chat-tab-errput out t) (buffer-pretend-saved msg-buf))
+                 (chat-tab-with-buffer msg-buf
+                   (chat-tab-errput out t)
+                   (buffer-pretend-saved msg-buf)
+                 ) ;chat-tab-with-buffer
                 ) ;
                 ((== ch "prompt")
-                 (with-buffer msg-buf
+                 (chat-tab-with-buffer msg-buf
                    (tree-set out :up 0 (tree-copy t))
                    (buffer-pretend-saved msg-buf)
-                 ) ;with-buffer
+                 ) ;chat-tab-with-buffer
                 ) ;
                 ((and (== ch "input") (null? (cdr l))) (chat-tab-set-input-body! in-buf t))
           ) ;cond
@@ -278,6 +267,38 @@
   ) ;with
 ) ;define
 
+(tm-define (chat-tab-busy-message msg)
+  (:synopsis "Update script-busy node for pending chat-tab rounds")
+  ;; goldfish 会话经 flush-command 在 message buffer 上下文中调用。
+  ;; 不能用通用 session-busy-message：它以 generic session-decode 解码
+  ;; pending 队列，而 chat-tab 条目第三位是 session-id 字符串，
+  ;; 会被误当作 tree-pointer 求值导致 "is a string" 错误。
+  (let* ((lan (get-env "prog-language")) (ses (get-env "prog-session")))
+    (when (and (== lan chat-tab-session-name)
+            (>= (string-length ses) 9)
+            (== (substring ses 0 9) "chat-tab:")
+          ) ;and
+      (let ((l (pending-ref lan ses)))
+        (for-each (lambda (entry)
+                    (with (input entry-session-id out opts)
+                      (chat-tab-session-decode entry)
+                      (chat-tab-with-buffer (chat-tab-session->message-buffer entry-session-id)
+                        (when (and (tm-func? out 'document)
+                                (> (tree-arity out) 0)
+                                (tm-func? (tree-ref out :last) 'script-busy)
+                              ) ;and
+                          (tree-assign (tree-ref out :last) `(script-busy ,msg))
+                        ) ;when
+                      ) ;chat-tab-with-buffer
+                    ) ;with
+                  ) ;lambda
+          l
+        ) ;for-each
+      ) ;let
+    ) ;when
+  ) ;let*
+) ;tm-define
+
 (define (chat-tab-session-cancel lan ses dead?)
   (with l
     (pending-ref lan ses)
@@ -285,7 +306,7 @@
       (with (input session-id out opts)
         (chat-tab-session-decode (car l))
         (let ((msg-buf (chat-tab-session->message-buffer session-id)))
-          (with-buffer msg-buf
+          (chat-tab-with-buffer msg-buf
             (when (and (tm-func? out 'document)
                     (> (tree-arity out) 0)
                     (tm-func? (tree-ref out :last) 'script-busy)
@@ -293,7 +314,7 @@
               (tree-assign (tree-ref out :last) '(script-interrupted))
             ) ;when
             (buffer-pretend-saved msg-buf)
-          ) ;with-buffer
+          ) ;chat-tab-with-buffer
         ) ;let
         (chat-tab-session-detach (car l))
         ;; 通知 C++ 生成结束
@@ -410,7 +431,9 @@
     (let ((json-str (njson->string obj)))
       (njson-free params)
       (njson-free obj)
-      (stree->tree `(document ,(string-append "%chat " json-str)))
+      (let ((cork-json (utf8->cork json-str)))
+        (stree->tree `(document ,(string-append "%chat " cork-json)))
+      ) ;let
     ) ;let
   ) ;let*
 ) ;define
@@ -423,9 +446,9 @@
         (session-id (chat-input-session-id ctx))
        ) ;
     (set! input (plugin-preprocess lan ses input opts))
-    (with-buffer (chat-tab-session->message-buffer session-id)
+    (chat-tab-with-buffer (chat-tab-session->message-buffer session-id)
       (tree-assign! out '(document (script-busy)))
-    ) ;with-buffer
+    ) ;chat-tab-with-buffer
     ;; 通知 C++ 进入 Generating 状态，切换按钮为 Stop
     (chat-tab-notify-state session-id "generating")
     (with x
@@ -453,7 +476,12 @@
             ) ;
         ;; 延迟初始化：首次发送时设置 session body 并加载样式包
         (let ((plugin-ses (string-append "chat-tab:" session-id)))
-          (with-buffer msg-buf
+          ;; 新会话的 message buffer 尚不存在（with-buffer 对不存在的
+          ;; buffer 静默返回 #f），必须先创建
+          (when (not (buffer-exists? msg-buf))
+            (buffer-set msg-buf '(document ""))
+          ) ;when
+          (chat-tab-with-buffer msg-buf
             (let ((msg-body (buffer-get-body msg-buf)))
               (when (chat-tab-buffer-empty? msg-body)
                 (session-enable-text-input chat-tab-session-name plugin-ses)
@@ -461,10 +489,14 @@
                   `(session ,chat-tab-session-name ,plugin-ses (document))
                 ) ;buffer-set-body
                 (buffer-pretend-saved msg-buf)
-                (chat-tab-add-default-style-packages! chat-tab-session-name)
+                ;; 样式包操作依赖当前 buffer；无视图时跳过，
+                ;; C++ 侧 ensureMessageWidget 会以嵌入样式初始化
+                (when chat-tab-focus-ok?
+                  (chat-tab-add-default-style-packages! chat-tab-session-name)
+                ) ;when
               ) ;when
             ) ;let
-          ) ;with-buffer
+          ) ;chat-tab-with-buffer
           (let* ((out (chat-tab-append-round! msg-buf input model)))
             (if (not out)
               #f
@@ -472,7 +504,10 @@
                 (chat-tab-clear-input! in-buf)
                 (if (not (connection-defined? chat-tab-session-name))
                   (begin
-                    (with-buffer msg-buf (chat-tab-output out input) (buffer-pretend-saved msg-buf))
+                    (chat-tab-with-buffer msg-buf
+                      (chat-tab-output out input)
+                      (buffer-pretend-saved msg-buf)
+                    ) ;chat-tab-with-buffer
                     #t
                   ) ;begin
                   (begin
diff --git a/TeXmacs/plugins/llm/progs/llm/chat-style.scm b/TeXmacs/plugins/llm/progs/llm/chat-style.scm
new file mode 100644
index 0000000000..a51d845d5d
--- /dev/null
+++ b/TeXmacs/plugins/llm/progs/llm/chat-style.scm
@@ -0,0 +1,89 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : chat-style.scm
+;; DESCRIPTION : Chat session buffer addressing and style packages
+;; COPYRIGHT   : (C) 2026 Mogan STEM
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (llm chat-style)
+  (:use (utils library cursor) (generic document-style) (llm chat-tree-ops))
+) ;texmacs-module
+
+;;; ---------- 全局常量 ----------
+
+(define-public chat-tab-session-name "llm")
+
+;;; ---------- Buffer URL 推导函数 ----------
+
+(tm-define (chat-tab-session->message-buffer session-id)
+  (string->url (string-append "tmfs://chat/" session-id "/message"))
+) ;tm-define
+
+(tm-define (chat-tab-session->input-buffer session-id)
+  (string->url (string-append "tmfs://chat/" session-id "/input"))
+) ;tm-define
+
+;;; ---------- 样式包管理 ----------
+
+(tm-define (chat-tab-add-default-style-packages! session-name)
+  ;; 偏好驱动，参考 buffer-set-default-style（tm-files.scm:130-146）
+  ;; 一次性 set-style-list：逐包 add 会每包触发一次样式树重建，耗时成倍
+  (let ((packs (list "number-europe")) (lan (get-preference "language")))
+    (when (and (!= lan "english") (in? lan supported-languages))
+      (set! packs (append packs (list lan)))
+      ;; 中文等 CJK 语言自动加载对应样式包
+      (when (== lan "chinese")
+        (set! packs (append packs (list "table-captions-above")))
+      ) ;when
+    ) ;when
+    ;; 插件样式包：动态检测
+    (when (url-exists? (url-append (get-texmacs-path)
+                         (string-append "plugins/" session-name
+                           "/packages/session/" session-name ".stem"
+                         ) ;string-append
+                       ) ;url-append
+          ) ;url-exists?
+      (set! packs (append packs (list session-name)))
+    ) ;when
+    ;; 深色主题下自动带上 dark 样式包，新建对话的输入/消息区跟随主题
+    (when (== (get-preference "gui theme") "liii-night")
+      (set! packs (append packs (list "dark")))
+    ) ;when
+    (set-style-list (append (get-style-list) packs))
+  ) ;let
+) ;tm-define
+
+(tm-define (chat-tab-load-input-styles! session-id)
+  (:synopsis "Load style packages for input buffer only (new conversation)")
+  (:argument session-id "Session UUID")
+  (let ((in-buf (chat-tab-session->input-buffer session-id)))
+    (with-buffer in-buf
+      (chat-tab-add-default-style-packages! chat-tab-session-name)
+    ) ;with-buffer
+  ) ;let
+) ;tm-define
+
+(tm-define (chat-tab-sync-session-styles! session-id)
+  ;; C++ 侧在消息嵌入编辑器建立（含 set_buffer_tree 覆盖）后调用。
+  ;; 无视图阶段 with-buffer 会静默跳过样式操作，而 texmacs_input_widget
+  ;; 对已有 buffer 会整体覆盖样式，故须在视图就绪后按当前 buffer 补齐
+  ;; 默认样式包，点击历史会话恢复后 llm 等插件包才不缺失。
+  ;; set-style-list 归一化去重，包已齐时重复调用不触发样式树重建。
+  (let ((msg-buf (chat-tab-session->message-buffer session-id))
+        (in-buf (chat-tab-session->input-buffer session-id))
+       ) ;
+    (chat-tab-with-buffer msg-buf
+      (when chat-tab-focus-ok?
+        (chat-tab-add-default-style-packages! chat-tab-session-name)
+      ) ;when
+    ) ;chat-tab-with-buffer
+    (with-buffer in-buf
+      (chat-tab-add-default-style-packages! chat-tab-session-name)
+    ) ;with-buffer
+  ) ;let
+) ;tm-define
diff --git a/TeXmacs/plugins/llm/progs/llm/chat-tree-ops.scm b/TeXmacs/plugins/llm/progs/llm/chat-tree-ops.scm
index 735008c6d6..136541af4f 100644
--- a/TeXmacs/plugins/llm/progs/llm/chat-tree-ops.scm
+++ b/TeXmacs/plugins/llm/progs/llm/chat-tree-ops.scm
@@ -12,13 +12,41 @@
 
 (texmacs-module (llm chat-tree-ops)
   (:use (utils library tree)
-    (data latex)
+    (latex latex-format)
     (utils edit variants)
     (texmacs texmacs tm-files)
     (utils library cursor)
   ) ;:use
 ) ;texmacs-module
 
+
+;;; ---------- 视图无关的 with-buffer 变体 ----------
+
+;; 社区版 with-buffer（cursor.scm）要求目标 buffer 有关联视图：
+;; (buffer-focus name #f) 返回 #f 时整个 and 链短路，body 被静默跳过。
+;; 新会话的 message buffer 嵌入编辑器由 C++ 侧懒创建（首次发送成功后
+;; enterConversationMode 才建立视图），发送时必然无视图。
+;; 此变体在 focus 失败时仍执行 body；body 内可通过 chat-tab-focus-ok?
+;; 判断是否需要执行依赖当前视图的操作（如 tree-go-to、add-style-package）。
+
+(define chat-tab-focus-ok? #f)
+
+(define-public-macro (chat-tab-with-buffer name . body)
+  (let* ((old (gensym)) (res (gensym)))
+    `(if (== ,name (current-buffer))
+       (begin ,@body)
+       (let* ((,old (current-buffer)))
+         (with chat-tab-focus-ok?
+           (and (or (url? ,name) (string? ,name))
+             (buffer-exists? ,name)
+             (buffer-focus ,name ,#f))
+           (with ,res
+             (begin ,@body)
+             (when chat-tab-focus-ok? (buffer-focus ,old ,#f))
+             ,res))))
+  ) ;let*
+) ;define-public-macro
+
 ;;; ---------- 文档处理工具 ----------
 
 (tm-define (chat-tab-normalize-document body)
@@ -279,7 +307,9 @@
       (if (and (> i 0) (tm-func? (tree-ref t (- i 1)) 'errput)) (set! i (- i 1)))
       (when (tm-func? u 'document)
         (tree-insert! t i (var-tree-children u))
-        (tree-go-to t :end)
+        (when chat-tab-focus-ok?
+          (tree-go-to t :end)
+        ) ;when
       ) ;when
     ) ;with
   ) ;when
@@ -333,7 +363,7 @@
 ) ;define
 
 (tm-define (chat-tab-message-document message-buffer)
-  (with-buffer message-buffer
+  (chat-tab-with-buffer message-buffer
     (let ((doc (buffer-get-body message-buffer)))
       (cond ((tree-is? doc 'session)
              (with d (tree-ref doc 2) (if (tree-is? d 'document) d doc))
@@ -350,7 +380,7 @@
             ) ;else
       ) ;cond
     ) ;let
-  ) ;with-buffer
+  ) ;chat-tab-with-buffer
 ) ;tm-define
 
 ;;; ---------- 输入操作 ----------
@@ -366,13 +396,30 @@
   (with-buffer input-buffer
     (buffer-set-body input-buffer (chat-tab-normalize-document body))
     (buffer-pretend-saved input-buffer)
+    (go-end)
   ) ;with-buffer
 ) ;tm-define
 
+(tm-define (chat-tab-should-prefill? input-buffer sel)
+  (:synopsis "Whether SEL should be prefilled into INPUT-BUFFER")
+  ;; 仅在输入区为空且选区内容非空白时预填，避免覆盖用户已输入内容
+  (and sel
+    (not (chat-tab-empty-body? sel))
+    (chat-tab-buffer-empty? (buffer-get-body input-buffer))
+  ) ;and
+) ;tm-define
+
+(tm-define (chat-tab-prefill-input! input-buffer sel)
+  (:synopsis "Prefill the chat input buffer with the selected content")
+  (when (chat-tab-should-prefill? input-buffer sel)
+    (chat-tab-set-input-body! input-buffer sel)
+  ) ;when
+) ;tm-define
+
 ;;; ---------- 追加对话轮次 ----------
 
 (tm-define (chat-tab-append-round! message-buffer body model)
-  (with-buffer message-buffer
+  (chat-tab-with-buffer message-buffer
     (let* ((doc (chat-tab-message-document message-buffer))
            (prompt (chat-tab-model-prompt model))
            (input-children (chat-tab-body-children body))
@@ -384,35 +431,13 @@
            ) ;io-node
           ) ;
       (tree-insert! doc (tree-arity doc) (list io-node))
-      (tree-go-to doc :end)
+      (when chat-tab-focus-ok?
+        (tree-go-to doc :end)
+      ) ;when
       (buffer-pretend-saved message-buffer)
       (let ((last-node (tree-ref doc :last)))
         (and (tree-is? last-node 'unfolded-io-text) (tree-ref last-node 2))
       ) ;let
     ) ;let*
-  ) ;with-buffer
-) ;tm-define
-
-;;; ---------- 样式包管理 ----------
-
-(tm-define (chat-tab-add-default-style-packages! session-name)
-  ;; 偏好驱动，参考 buffer-set-default-style（tm-files.scm:130-146）
-  (add-style-package "number-europe")
-  (add-style-package "preview-ref")
-  (with lan
-    (get-preference "language")
-    (when (!= lan "english")
-      (set-document-language lan)
-      ;; 中文等 CJK 语言自动加载对应样式包
-      (when (== lan "chinese")
-        (add-style-package "chinese")
-        (add-style-package "table-captions-above")
-      ) ;when
-    ) ;when
-  ) ;with
-  ;; 插件样式包：动态检测，参考 session-edit 的 make-session
-  (when (url-exists? (url-unix "$TEXMACS_STYLE_PATH" (string-append session-name ".ts"))
-        ) ;url-exists?
-    (add-style-package session-name)
-  ) ;when
+  ) ;chat-tab-with-buffer
 ) ;tm-define
diff --git a/TeXmacs/plugins/lua/packages/code/lua.stem b/TeXmacs/plugins/lua/packages/code/lua.stem
new file mode 100644
index 0000000000..01e19d47b2
--- /dev/null
+++ b/TeXmacs/plugins/lua/packages/code/lua.stem
@@ -0,0 +1,31 @@
+(document (TeXmacs "2.1.2")
+  (style (tuple "source" "std"))
+  (body (document (active* (src-title (document (compound "src-package" "lua" "1.0")
+                                        (src-purpose (document "lua Language"))
+                                        (src-copyright "2020-2024" "Darcy Shen")
+                                        (src-license (document (concat "This software falls under the "
+                                                                 (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE")
+                                                                 ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see "
+                                                                 (hlink "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                   "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                 ) ;hlink
+                                                                 "."
+                                                               ) ;concat
+                                                     ) ;document
+                                        ) ;src-license
+                                      ) ;document
+                           ) ;src-title
+                  ) ;active*
+          (concat (use-module "(lua lua-format)") " " (use-module "(lua lua-edit)"))
+          (assign "lua"
+            (macro "body"
+              (with "mode" "prog" "prog-language" "lua" "font-family" "rm" (arg "body"))
+            ) ;macro
+          ) ;assign
+          (assign "lua-code"
+            (macro "body" (document (pseudo-code (document (lua (arg "body"))))))
+          ) ;assign
+        ) ;document
+  ) ;body
+  (initial (collection (associate "preamble" "true") (associate "sfactor" "5")))
+) ;document
diff --git a/TeXmacs/plugins/lua/packages/code/lua.ts b/TeXmacs/plugins/lua/packages/code/lua.ts
deleted file mode 100644
index 82872b07c7..0000000000
--- a/TeXmacs/plugins/lua/packages/code/lua.ts
+++ /dev/null
@@ -1,41 +0,0 @@
-
-
->
-
-<\body>
-  
-    
-
-    <\src-purpose>
-      lua Language
-    
-
-    
-
-    <\src-license>
-      This software falls under the . It comes WITHOUT ANY
-      WARRANTY WHATSOEVER. You should have received a copy of the license
-      which the software. If not, see .
-    
-  >
-
-  
-  
-
-  >>>
-
-  
-    <\pseudo-code>
-      >
-    
-  >
-
-
-<\initial>
-  <\collection>
-    
-    
-  
-
-
diff --git a/TeXmacs/plugins/lua/progs/code/lua-edit.scm b/TeXmacs/plugins/lua/progs/code/lua-edit.scm
deleted file mode 100644
index 6ea3a6219a..0000000000
--- a/TeXmacs/plugins/lua/progs/code/lua-edit.scm
+++ /dev/null
@@ -1,86 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : lua-edit.scm
-;; DESCRIPTION : editing lua programs
-;; COPYRIGHT   : (C) 2025  Fanjie Meng
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (code lua-edit)
-  (:use (prog prog-edit)
-        (code lua-mode)))          ; 确保已有 lua-mode.scm 或 lua-lang.scm
-
-(tm-define (get-tabstop)
-  (:mode in-prog-lua?)
-  2)
-
-;; 定义Lua特定的配对关键字，这些关键字会减少缩进
-(define lua-decrease-indent-keys 
-  '("end" "until"))
-
-;; 去除字符串右侧的空白字符
-(define (string-strip-right s)
-  (with char-set:not-whitespace (char-set-complement char-set:whitespace)
-    (with n (string-length s)
-      (with r (or (string-rindex s char-set:not-whitespace) n)
-        (string-take s (min n (+ 1 r)))))))
-
-;; 检查字符串是否以特定关键字结尾
-(define (ends-with-keyword? s keys)
-  (and (nnull? keys)
-      (or (string-ends? s (car keys))
-        (ends-with-keyword? s (cdr keys)))))
-
-;; 检查字符串是否以特定关键字开头
-(define (starts-with-keyword? s keys)
-  (and (nnull? keys)
-      (or (string-starts? s (string-append (car keys) " "))
-        (starts-with-keyword? s (cdr keys)))))
-
-;; 定义Lua代码的缩进计算函数
-(tm-define (program-compute-indentation doc row col)
-  (:mode in-prog-lua?)
-  (if (<= row 0) 0
-      (let* ((prev-row (- row 1))
-             (prev-line (program-row prev-row))
-             (stripped-prev (string-strip-right (if prev-line prev-line "")))
-             (prev-indent (string-get-indent stripped-prev))
-             (tab-width (get-tabstop)))
-        (cond 
-          ;; 如果当前行以减少缩进的关键字开头，则减少缩进
-          ((starts-with-keyword? (program-row row) lua-decrease-indent-keys)
-           (max 0 (- prev-indent tab-width)))
-          ;; 否则保持前行的缩进
-          (else prev-indent)))))
-
-(tm-define (lua-bracket-open lbr rbr)
-  (bracket-open lbr rbr "\\"))
-
-(tm-define (lua-bracket-close lbr rbr)
-  (bracket-close lbr rbr "\\"))
-
-(tm-define (notify-cursor-moved status)
-  (:require prog-highlight-brackets?)
-  (:mode in-prog-lua?)
-  (select-brackets-after-movement "([{" ")]}" "\\"))
-
-(tm-define (kbd-paste)
-  (:mode in-prog-lua?)
-  (clipboard-paste-import "lua" "primary"))
-
-(kbd-map
-  (:mode in-prog-lua?)
-  ("{"   (lua-bracket-open "{" "}"))
-  ("}"   (lua-bracket-close "{" "}"))
-  ("("   (lua-bracket-open "(" ")"))
-  (")"   (lua-bracket-close "(" ")"))
-  ("["   (lua-bracket-open "[" "]"))
-  ("]"   (lua-bracket-close "[" "]"))
-  ("\"" (lua-bracket-open "\"" "\""))
-  ("'"  (lua-bracket-open "'" "'"))
-  ("A-tab" (insert-tabstop))
-  ("S-tab" (remove-tabstop)))
diff --git a/TeXmacs/plugins/lua/progs/code/lua-lang.scm b/TeXmacs/plugins/lua/progs/code/lua-lang.scm
deleted file mode 100644
index 02b8231cb2..0000000000
--- a/TeXmacs/plugins/lua/progs/code/lua-lang.scm
+++ /dev/null
@@ -1,82 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : lua-lang.scm
-;; DESCRIPTION : Lua Language Support for Syntax Highlighting
-;; COPYRIGHT   : (C) 2025  Fanjie Meng
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (code lua-lang)
-  (:use (prog default-lang)))
-
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "lua") (== key "keyword")))
-  `(,(string->symbol key)
-    (extra_chars "_")
-    (constant
-      "nil" "true" "false" "_G" "_VERSION" "arg" "self")
-    (declare_function "function")
-    (keyword
-      "and" "break" "do" "else" "elseif" "end" "for" "if" "in"
-      "local" "not" "or" "repeat" "return" "then" "until" "while")
-    (keyword_control
-      "break" "return" "do" "end" "while" "repeat" "until" "for")
-    (keyword_conditional
-      "if" "then" "else" "elseif")))
-
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "lua") (== key "operator")))
-  `(,(string->symbol key)
-    (operator
-      "+" "-" "*" "/" "%" "^" "==" "~=" "<=" ">=" "<" ">"
-      "=" ".." "#")
-    (operator_special ":")
-    (operator_field ".")
-    (operator_openclose "(" ")" "{" "}" "[" "]")))
-
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "lua") (== key "number")))
-  `(,(string->symbol key)
-    (bool_features
-      "prefix_0x" "sci_notation")
-    (suffix
-      (imaginary "i"))))
-
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "lua") (== key "string")))
-  `(,(string->symbol key)
-    (bool_features
-      "hex_with_8_bits" "hex_with_16_bits")
-    (escape_sequences "\\" "\"" "'" "a" "b" "f" "n" "r" "t" "v")))
-
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "lua") (== key "comment")))
-  `(,(string->symbol key)
-    (inline "--")
-    (block "--[[" "]]")))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Preferences for syntax highlighting
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (notify-lua-syntax var val)
-  (syntax-read-preferences "lua"))
-
-(define-preferences
-  ("syntax:lua:none" "black" notify-lua-syntax)
-  ("syntax:lua:comment" "gray" notify-lua-syntax)
-  ("syntax:lua:error" "dark red" notify-lua-syntax)
-  ("syntax:lua:constant" "blue" notify-lua-syntax)
-  ("syntax:lua:constant_number" "purple" notify-lua-syntax)
-  ("syntax:lua:constant_string" "brown" notify-lua-syntax)
-  ("syntax:lua:declare_function" "dark blue" notify-lua-syntax)
-  ("syntax:lua:operator" "magenta" notify-lua-syntax)
-  ("syntax:lua:operator_openclose" "red" notify-lua-syntax)
-  ("syntax:lua:operator_field" "gray" notify-lua-syntax)
-  ("syntax:lua:keyword" "dark green" notify-lua-syntax)
-  ("syntax:lua:keyword_conditional" "dark green" notify-lua-syntax)
-  ("syntax:lua:keyword_control" "dark green" notify-lua-syntax))
\ No newline at end of file
diff --git a/TeXmacs/plugins/lua/progs/code/lua-mode.scm b/TeXmacs/plugins/lua/progs/code/lua-mode.scm
deleted file mode 100644
index f193ff495c..0000000000
--- a/TeXmacs/plugins/lua/progs/code/lua-mode.scm
+++ /dev/null
@@ -1,19 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : lua-lang.scm
-;; DESCRIPTION : Lua Language mode
-;; COPYRIGHT   : (C) 2025  Fanjie Meng
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (code lua-mode)
-  (:use (kernel texmacs tm-modes)))
-
-(texmacs-modes
-  (in-lua% (== (get-env "prog-language") "lua"))
-  (in-prog-lua% #t in-prog% in-lua%))
diff --git a/TeXmacs/plugins/lua/progs/data/lua.scm b/TeXmacs/plugins/lua/progs/data/lua.scm
deleted file mode 100644
index ad0f5d588c..0000000000
--- a/TeXmacs/plugins/lua/progs/data/lua.scm
+++ /dev/null
@@ -1,43 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : init-prog_lua.scm
-;; DESCRIPTION : prog format for lua
-;; COPYRIGHT   : (C) 2025  Fanjie Meng
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (data lua))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; lua source files
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define-format lua
-  (:name "Lua source code")
-  (:suffix "lua"))
-
-(define (texmacs->lua x . opts)
-  (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '())))
-
-(define (lua->texmacs x . opts)
-  (code->texmacs x))
-
-(define (lua-snippet->texmacs x . opts)
-  (code-snippet->texmacs x))
-
-(converter texmacs-tree lua-document
-  (:function texmacs->lua))
-
-(converter lua-document texmacs-tree
-  (:function lua->texmacs))
-  
-(converter texmacs-tree lua-snippet
-  (:function texmacs->lua))
-
-(converter lua-snippet texmacs-tree
-  (:function lua-snippet->texmacs))
diff --git a/TeXmacs/plugins/lua/progs/lua/lua-edit.scm b/TeXmacs/plugins/lua/progs/lua/lua-edit.scm
new file mode 100644
index 0000000000..084c135e03
--- /dev/null
+++ b/TeXmacs/plugins/lua/progs/lua/lua-edit.scm
@@ -0,0 +1,103 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : lua-edit.scm
+;; DESCRIPTION : editing lua programs
+;; COPYRIGHT   : (C) 2025  Fanjie Meng
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (lua lua-edit) (:use (prog prog-edit) (lua lua-mode)))
+
+(tm-define (get-tabstop) (:mode in-prog-lua?) 2)
+
+;; 定义Lua特定的配对关键字，这些关键字会减少缩进
+
+(define lua-decrease-indent-keys '("end" "until"))
+
+;; 去除字符串右侧的空白字符
+
+(define (string-strip-right s)
+  (with char-set:not-whitespace
+    (char-set-complement char-set:whitespace)
+    (with n
+      (string-length s)
+      (with r
+        (or (string-rindex s char-set:not-whitespace) n)
+        (string-take s (min n (+ 1 r)))
+      ) ;with
+    ) ;with
+  ) ;with
+) ;define
+
+;; 检查字符串是否以特定关键字结尾
+
+(define (ends-with-keyword? s keys)
+  (and (nnull? keys)
+    (or (string-ends? s (car keys)) (ends-with-keyword? s (cdr keys)))
+  ) ;and
+) ;define
+
+;; 检查字符串是否以特定关键字开头
+
+(define (starts-with-keyword? s keys)
+  (and (nnull? keys)
+    (or (string-starts? s (string-append (car keys) " "))
+      (starts-with-keyword? s (cdr keys))
+    ) ;or
+  ) ;and
+) ;define
+
+;; 定义Lua代码的缩进计算函数
+(tm-define (program-compute-indentation doc row col)
+  (:mode in-prog-lua?)
+  (if (<= row 0)
+    0
+    (let* ((prev-row (- row 1))
+           (prev-line (program-row prev-row))
+           (stripped-prev (string-strip-right (if prev-line prev-line "")))
+           (prev-indent (string-get-indent stripped-prev))
+           (tab-width (get-tabstop))
+          ) ;
+      (cond
+        ;; 如果当前行以减少缩进的关键字开头，则减少缩进
+        ((starts-with-keyword? (program-row row) lua-decrease-indent-keys)
+         (max 0 (- prev-indent tab-width))
+        ) ;
+        ;; 否则保持前行的缩进
+        (else prev-indent)
+      ) ;cond
+    ) ;let*
+  ) ;if
+) ;tm-define
+
+(tm-define (lua-bracket-open lbr rbr) (bracket-open lbr rbr "\\"))
+
+(tm-define (lua-bracket-close lbr rbr) (bracket-close lbr rbr "\\"))
+
+(tm-define (notify-cursor-moved status)
+  (:require prog-highlight-brackets?)
+  (:mode in-prog-lua?)
+  (select-brackets-after-movement "([{" ")]}" "\\")
+) ;tm-define
+
+(tm-define (kbd-paste)
+  (:mode in-prog-lua?)
+  (clipboard-paste-import "lua" "primary")
+) ;tm-define
+
+(kbd-map (:mode in-prog-lua?)
+ ("{" (lua-bracket-open "{" "}"))
+ ("}" (lua-bracket-close "{" "}"))
+ ("(" (lua-bracket-open "(" ")"))
+ (")" (lua-bracket-close "(" ")"))
+ ("[" (lua-bracket-open "[" "]"))
+ ("]" (lua-bracket-close "[" "]"))
+ ("\"" (lua-bracket-open "\"" "\""))
+ ("'" (lua-bracket-open "'" "'"))
+ ("A-tab" (insert-tabstop))
+ ("S-tab" (remove-tabstop))
+) ;kbd-map
diff --git a/TeXmacs/plugins/lua/progs/lua/lua-format.scm b/TeXmacs/plugins/lua/progs/lua/lua-format.scm
new file mode 100644
index 0000000000..06d9fb76bc
--- /dev/null
+++ b/TeXmacs/plugins/lua/progs/lua/lua-format.scm
@@ -0,0 +1,40 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : init-prog_lua.scm
+;; DESCRIPTION : prog format for lua
+;; COPYRIGHT   : (C) 2025  Fanjie Meng
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (lua lua-format))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; lua source files
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-format lua (:name "Lua source code") (:suffix "lua"))
+
+(define (texmacs->lua x . opts)
+  (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '()))
+) ;define
+
+(define (lua->texmacs x . opts)
+  (code->texmacs x)
+) ;define
+
+(define (lua-snippet->texmacs x . opts)
+  (code-snippet->texmacs x)
+) ;define
+
+(converter texmacs-tree lua-document (:function texmacs->lua))
+
+(converter lua-document texmacs-tree (:function lua->texmacs))
+
+(converter texmacs-tree lua-snippet (:function texmacs->lua))
+
+(converter lua-snippet texmacs-tree (:function lua-snippet->texmacs))
diff --git a/TeXmacs/plugins/lua/progs/lua/lua-lang.scm b/TeXmacs/plugins/lua/progs/lua/lua-lang.scm
new file mode 100644
index 0000000000..942a429c31
--- /dev/null
+++ b/TeXmacs/plugins/lua/progs/lua/lua-lang.scm
@@ -0,0 +1,76 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : lua-lang.scm
+;; DESCRIPTION : Lua Language Support for Syntax Highlighting
+;; COPYRIGHT   : (C) 2025  Fanjie Meng
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (lua lua-lang) (:use (prog default-lang)))
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "lua") (== key "keyword")))
+  `(,(string->symbol key)
+    (extra_chars "_")
+    (constant "nil" "true" "false" "_G" "_VERSION" "arg" "self")
+    (declare_function "function")
+    (keyword "and" "break" "do" "else" "elseif" "end" "for" "if" "in" "local"
+      "not" "or" "repeat" "return" "then" "until" "while")
+    (keyword_control "break" "return" "do" "end" "while" "repeat" "until" "for")
+    (keyword_conditional "if" "then" "else" "elseif"))
+) ;tm-define
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "lua") (== key "operator")))
+  `(,(string->symbol key)
+    (operator "+" "-" "*" "/" "%" "^" "==" "~=" "<=" ">=" "<" ">" "=" ".." "#")
+    (operator_special ":")
+    (operator_field ".")
+    (operator_openclose "(" ")" "{" "}" "[" "]"))
+) ;tm-define
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "lua") (== key "number")))
+  `(,(string->symbol key)
+    (bool_features "prefix_0x" "sci_notation")
+    (suffix (imaginary "i")))
+) ;tm-define
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "lua") (== key "string")))
+  `(,(string->symbol key)
+    (bool_features "hex_with_8_bits" "hex_with_16_bits")
+    (escape_sequences "\\" "\"" "'" "a" "b" "f" "n" "r" "t" "v"))
+) ;tm-define
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "lua") (== key "comment")))
+  `(,(string->symbol key) (inline "--") (block "--[[" "]]"))
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Preferences for syntax highlighting
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (notify-lua-syntax var val)
+  (syntax-read-preferences "lua")
+) ;define
+
+(define-preferences ("syntax:lua:none" "black" notify-lua-syntax)
+ ("syntax:lua:comment" "gray" notify-lua-syntax)
+ ("syntax:lua:error" "dark red" notify-lua-syntax)
+ ("syntax:lua:constant" "blue" notify-lua-syntax)
+ ("syntax:lua:constant_number" "purple" notify-lua-syntax)
+ ("syntax:lua:constant_string" "brown" notify-lua-syntax)
+ ("syntax:lua:declare_function" "dark blue" notify-lua-syntax)
+ ("syntax:lua:operator" "magenta" notify-lua-syntax)
+ ("syntax:lua:operator_openclose" "red" notify-lua-syntax)
+ ("syntax:lua:operator_field" "gray" notify-lua-syntax)
+ ("syntax:lua:keyword" "dark green" notify-lua-syntax)
+ ("syntax:lua:keyword_conditional" "dark green" notify-lua-syntax)
+ ("syntax:lua:keyword_control" "dark green" notify-lua-syntax)
+) ;define-preferences
diff --git a/TeXmacs/plugins/lua/progs/lua/lua-mode.scm b/TeXmacs/plugins/lua/progs/lua/lua-mode.scm
new file mode 100644
index 0000000000..ce328cd440
--- /dev/null
+++ b/TeXmacs/plugins/lua/progs/lua/lua-mode.scm
@@ -0,0 +1,18 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : lua-lang.scm
+;; DESCRIPTION : Lua Language mode
+;; COPYRIGHT   : (C) 2025  Fanjie Meng
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (lua lua-mode) (:use (kernel texmacs tm-modes)))
+
+(texmacs-modes (in-lua% (== (get-env "prog-language") "lua"))
+  (in-prog-lua% #t in-prog% in-lua%)
+) ;texmacs-modes
diff --git a/TeXmacs/plugins/macos/progs/init-macos.scm b/TeXmacs/plugins/macos/progs/init-macos.scm
new file mode 100644
index 0000000000..e59268f87d
--- /dev/null
+++ b/TeXmacs/plugins/macos/progs/init-macos.scm
@@ -0,0 +1,98 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : init-macos.scm
+;; DESCRIPTION : Initialize the 'macos' plugin (Mac OS look and feel keymap)
+;; COPYRIGHT   : (C) 1999  Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(when (like-macos?)
+  (kbd-map (:profile macos)
+
+    ;; standard macOS keyboard shortcuts
+    ("macos ;" (interactive-spell))
+    ("macos ?" (interactive docgrep-in-doc))
+    ("macos [" (cursor-history-backward))
+    ("macos ]" (cursor-history-forward))
+    ("macos _" (make 'nbhyph))
+    ("macos up" (go-start))
+    ("macos down" (go-end))
+    ("macos left" (kbd-select-if-active traverse-left))
+    ("macos right" (kbd-select-if-active traverse-right))
+    ("macos S-left" (kbd-select kbd-start-line))
+    ("macos S-right" (kbd-select kbd-end-line))
+    ("macos S-up" (kbd-select go-start))
+    ("macos S-down" (kbd-select go-end))
+
+    ("search macos g" (search-next-match #t))
+    ("search macos G" (search-next-match #f))
+
+    ;; not yet supported
+    ;; ("macos :" (display-spelling-window))
+    ;; ("macos ," (open-preferences))
+    ;; ("macos A-/" (toggle-antialising))
+    ;; ("macos #" (capture-screen-to-file))
+    ;; ("macos C-#" (capture-screen-to-clipboard))
+    ;; ("macos $" (capture-selection-to-file))
+    ;; ("macos C-$" (capture-selection-to-clipboard))
+    ;; ("macos C" (show-colors-window))
+    ;; ("macos C-c" (copy-style))
+    ;; ("macos A-c" (copy-formatting))
+    ;; ("macos C-d" (show-definition-word))
+    ;; ("macos A-d" (toggle-doc))
+    ;; ("macos e" (search-selection))
+    ;; ("macos h" (hide-window))
+    ;; ("macos A-h" (hide-other-windows))
+    ;; ("macos A-i" (show-inspector-window))
+    ;; ("macos j" (scroll-to-selection))
+    ;; ("macos m" (minimize-window))
+    ;; ("macos A-m" (minimize-all-windows))
+    ;; ("macos P" (printer-setup))
+    ;; ("macos t" (show-fonts-window))
+    ;; ("macos A-t" (toggle-toolbar))
+    ;; ("macos C-v" (paste-style))
+    ;; ("macos C-V" (paste-match-style))
+    ;; ("macos A-v" (paste-formatting))
+    ;; ("macos A-w" (safely-kill-all-windows))
+    ;; ("macos C-x" (cut-style))       ;; TeXmacs addition
+    ;; ("macos A-x" (cut-formatting))  ;; TeXmacs addition
+
+    ;; further shortcuts for MacOS look and feel
+    ("macos r" (interactive-replace))
+    ("macos F" (toggle-full-screen-mode))
+    ("macos C-f" (toggle-full-screen-edit-mode))
+
+    ("macos S-=" (zoom-in (sqrt (sqrt 2.0))))
+    ("macos S-+" (zoom-in (sqrt (sqrt 2.0))))
+    ("macos S--" (zoom-out (sqrt (sqrt 2.0))))
+    ("macos S-_" (zoom-out (sqrt (sqrt 2.0))))
+
+    ("altcmd x" (interactive footer-eval))
+    ("A-x" (interactive exec-interactive-command))
+
+    ("A-space var" (make 'nbsp))
+
+    ("C-a" (kbd-start-line))
+    ("C-e" (kbd-end-line))
+    ("C-b" (kbd-left))
+    ("C-f" (kbd-right))
+    ("C-g" (selection-cancel))
+    ("C-k" (kill-paragraph))
+    ("C-l" (refresh-window))
+    ("C-y" (yank-paragraph))
+    ("C-n" (kbd-down))
+    ("C-p" (kbd-up))
+    ("C-h" (kbd-backspace))
+    ("C-d" (kbd-delete))
+    ("A-q" (make 'symbol))
+
+    ("C-O" (toggle-source-mode))
+    ("C-P" (toggle-preamble-mode))
+    ("M-A-v" (interactive-paste-special))
+  ) ;kbd-map
+) ;when
diff --git a/TeXmacs/plugins/markdown/progs/markdown/markdown-format.scm b/TeXmacs/plugins/markdown/progs/markdown/markdown-format.scm
new file mode 100644
index 0000000000..df02d12e57
--- /dev/null
+++ b/TeXmacs/plugins/markdown/progs/markdown/markdown-format.scm
@@ -0,0 +1,19 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : markdown-format.scm
+;; DESCRIPTION : Markdown 格式定义（仅非社区版生效）
+;; COPYRIGHT   : (C) 2026  MoganLab
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (markdown markdown-format))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Markdown
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-format markdown (:name "Markdown") (:suffix "md" "markdown"))
diff --git a/TeXmacs/plugins/math-kbd/progs/init-math-kbd.scm b/TeXmacs/plugins/math-kbd/progs/init-math-kbd.scm
new file mode 100644
index 0000000000..2896f16dad
--- /dev/null
+++ b/TeXmacs/plugins/math-kbd/progs/init-math-kbd.scm
@@ -0,0 +1,15 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : init-math-kbd.scm
+;; DESCRIPTION : Initialize the math-kbd plugin
+;; COPYRIGHT   : (C) 2026  Darcy Shen
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; math-kbd 的绑定经 delayed-kbd-map 分片注册，无需在插件初始化时强载
+(lazy-keyboard (math math-kbd) in-math?)
+(lazy-keyboard (math math-sem-edit) in-sem-math?)
diff --git a/TeXmacs/plugins/matlab/packages/code/matlab.stem b/TeXmacs/plugins/matlab/packages/code/matlab.stem
new file mode 100644
index 0000000000..d22be69048
--- /dev/null
+++ b/TeXmacs/plugins/matlab/packages/code/matlab.stem
@@ -0,0 +1,23 @@
+(document (TeXmacs "2.1.2")
+  (style (tuple "source" "std"))
+  (body (document (active* (src-title (document (compound "src-package" "matlab" "1.0")
+                                        (src-purpose (document "matlab Language"))
+                                      ) ;document
+                           ) ;src-title
+                  ) ;active*
+          (concat (use-module "(matlab matlab-format)")
+            " "
+            (use-module "(matlab matlab-edit)")
+          ) ;concat
+          (assign "matlab"
+            (macro "body"
+              (with "mode" "prog" "prog-language" "matlab" "font-family" "rm" (arg "body"))
+            ) ;macro
+          ) ;assign
+          (assign "matlab-code"
+            (macro "body" (document (pseudo-code (document (matlab (arg "body"))))))
+          ) ;assign
+        ) ;document
+  ) ;body
+  (initial (collection (associate "preamble" "true") (associate "sfactor" "5")))
+) ;document
diff --git a/TeXmacs/plugins/matlab/packages/code/matlab.ts b/TeXmacs/plugins/matlab/packages/code/matlab.ts
deleted file mode 100644
index 09153a280f..0000000000
--- a/TeXmacs/plugins/matlab/packages/code/matlab.ts
+++ /dev/null
@@ -1,32 +0,0 @@
-
-
->
-
-<\body>
-  
-    
-
-    <\src-purpose>
-      matlab Language
-    
-  >
-
-  
-  
-
-  >>>
-
-  
-    <\pseudo-code>
-      >
-    
-  >
-
-
-<\initial>
-  <\collection>
-    
-    
-  
-
-
diff --git a/TeXmacs/plugins/matlab/progs/code/matlab-edit.scm b/TeXmacs/plugins/matlab/progs/code/matlab-edit.scm
deleted file mode 100644
index 94736651e0..0000000000
--- a/TeXmacs/plugins/matlab/progs/code/matlab-edit.scm
+++ /dev/null
@@ -1,128 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : matlab-edit.scm
-;; DESCRIPTION : editing Matlab programs
-;; COPYRIGHT   : (C) 2025   vesita
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; DESCRIPTION:
-;;;   This module provides editing functionalities for MATLAB language within
-;;;   TeXmacs. It defines language-specific behaviors such as indentation,
-;;;   commenting, and paste operations for MATLAB code snippets.
-;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; 定义模块，使用 prog-edit 和 matlab-mode 模块
-(texmacs-module (code matlab-edit)
-  (:use (prog prog-edit)
-    (code matlab-mode)))
-
-;;------------------------------------------------------------------------------
-;; 缩进设置
-;;
-
-;; 定义MATLAB代码的制表符停止位为4个空格（符合MATLAB标准）
-(tm-define (get-tabstop)
-  (:mode in-prog-matlab?)
-  4)
-
-;; 定义MATLAB特定的关键字，这些关键字后面需要增加缩进
-(define matlab-increase-indent-keys 
-  '("for" "if" "while" "switch" "try" "classdef" "methods" "properties" "events"))
-
-;; 定义MATLAB特定的配对关键字，这些关键字会减少缩进
-(define matlab-decrease-indent-keys 
-  '("elseif" "else" "catch" "case" "otherwise"))
-
-;; 定义MATLAB特定的结束关键字，这些关键字会减少缩进
-(define matlab-end-keys
-  '("end"))
-
-;; 去除字符串右侧的空白字符
-(define (string-strip-right s)
-  (with char-set:not-whitespace (char-set-complement char-set:whitespace)
-    (with n (string-length s)
-      (with r (or (string-rindex s char-set:not-whitespace) n)
-        (string-take s (min n (+ 1 r)))))))
-
-;; 检查字符串是否以特定关键字结尾
-(define (ends-with-keyword? s keys)
-  (and (nnull? keys)
-    (or (string-ends? s (car keys))
-      (ends-with-keyword? s (cdr keys)))))
-
-;; 检查字符串是否以特定关键字开头
-(define (starts-with-keyword? s keys)
-  (and (nnull? keys)
-    (or (string-starts? s (string-append (car keys) " "))
-      (starts-with-keyword? s (cdr keys)))))
-
-;; 定义MATLAB代码的缩进计算函数
-(tm-define (program-compute-indentation doc row col)
-  (:mode in-prog-matlab?)
-  (if (<= row 0) 0
-    (let* ((prev-row (- row 1))
-           (prev-line (program-row prev-row))
-           (stripped-prev (string-strip-right (if prev-line prev-line "")))
-           (prev-indent (string-get-indent stripped-prev))
-           (tab-width (get-tabstop)))
-      (cond 
-        ;; 如果前行以增加缩进的关键字结尾，则当前行应增加缩进
-        ((ends-with-keyword? stripped-prev matlab-increase-indent-keys)
-          (+ prev-indent tab-width))
-        ;; 如果当前行以减少缩进的关键字开头，则减少缩进
-        ((starts-with-keyword? (program-row row) matlab-decrease-indent-keys)
-          (max 0 (- prev-indent tab-width)))
-        ;; 如果当前行以结束关键字开头，则减少缩进
-        ((starts-with-keyword? (program-row row) matlab-end-keys)
-          (max 0 (- prev-indent tab-width)))
-        ;; 否则保持前行的缩进
-        (else prev-indent)))))
-
-;;------------------------------------------------------------------------------
-;; 自动插入、高亮和选择括号和引号
-;;
-
-(tm-define (matlab-bracket-open lbr rbr)
-  ;; 插入一对括号或引号，并将光标定位在中间
-  (bracket-open lbr rbr "\\"))
-
-(tm-define (matlab-bracket-close lbr rbr)
-  ;; 处理闭合括号或引号，并正确放置光标位置
-  (bracket-close lbr rbr "\\"))
-
-(tm-define (notify-cursor-moved status)
-  (:require prog-highlight-brackets?)
-  (:mode in-prog-matlab?)
-  ;; 当光标移动时高亮匹配的括号
-  (select-brackets-after-movement "([{" ")]}" "\\"))
-
-;;------------------------------------------------------------------------------
-;; 粘贴操作
-;;
-
-;; 定义MATLAB代码环境中的粘贴操作，使用MATLAB格式导入剪贴板内容
-(tm-define (kbd-paste)
-  (:mode in-prog-matlab?)
-  (clipboard-paste-import "matlab" "primary"))
-
-(kbd-map
-  (:mode in-prog-matlab?)
-  ;; MATLAB编程模式下的键盘快捷键
-  ("A-tab" (insert-tabstop))                 ;; Alt+Tab：插入制表符
-  ("cmd S-tab" (remove-tabstop))             ;; Cmd+Shift+Tab：移除制表符
-  ("{" (matlab-bracket-open "{" "}" ))       ;; 自动插入匹配的大括号
-  ("}" (matlab-bracket-close "{" "}" ))      ;; 处理闭合大括号
-  ("(" (matlab-bracket-open "(" ")" ))       ;; 自动插入匹配的小括号
-  (")" (matlab-bracket-close "(" ")" ))      ;; 处理闭合小括号
-  ("[" (matlab-bracket-open "[" "]" ))       ;; 自动插入匹配的方括号
-  ("]" (matlab-bracket-close "[" "]" ))      ;; 处理闭合方括号
-  ("\"" (matlab-bracket-open "\"" "\"" ))    ;; 自动插入匹配的双引号
-  ("'" (matlab-bracket-open "'" "'" )))      ;; 自动插入匹配的单引号
\ No newline at end of file
diff --git a/TeXmacs/plugins/matlab/progs/code/matlab-lang.scm b/TeXmacs/plugins/matlab/progs/code/matlab-lang.scm
deleted file mode 100644
index 0dc39edc90..0000000000
--- a/TeXmacs/plugins/matlab/progs/code/matlab-lang.scm
+++ /dev/null
@@ -1,146 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : matlab-lang.scm
-;; DESCRIPTION : Matlab language support
-;; COPYRIGHT   : (C) 2025  veista
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; DESCRIPTION:
-;;;   This module provides language support for MATLAB within TeXmacs. It 
-;;;   defines language features such as keywords, operators, number formats,
-;;;   string formats, and comment formats for proper syntax highlighting and
-;;;   parsing of MATLAB code.
-;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; 定义matlab语言支持模块，使用默认语言支持模块
-(texmacs-module (code matlab-lang)
-  (:use (prog default-lang)))
-
-;;------------------------------------------------------------------------------
-;; 关键字定义
-;;
-
-;; 定义MATLAB语言的关键字分类
-;; 包括常量、函数声明、类型声明、模块导入、标识符声明、条件关键字、控制关键字等
-;; src/System/Language/language.cpp中定义了关键字分类
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "matlab") (== key "keyword")))
-  `(,(string->symbol key)
-    (constant
-      "Inf" "NaN" "eps" "pi" "i" "j" "true" "false" "ans" "realmin" "realmax")
-    (declare_function
-      "function")
-    (declare_type
-      "classdef" "properties" "methods" "events" "enumerate" "struct" "attributes")
-    (declare_module
-      "import")
-    (declare_identifier
-      "global" "persistent")
-    (keyword
-      "nargin" "nargout" "varargin" "varargout" "parsing")
-    (keyword_conditional
-      "if" "else" "elseif" "switch" "case" "otherwise")
-    (keyword_control
-      "for" "while" "break" "continue" "return" "try" "catch" "end")))
-
-;;------------------------------------------------------------------------------
-;; 操作符定义
-;;
-
-;; 定义MATLAB语言的操作符符号
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "matlab") (== key "operator")))
-  `(,(string->symbol key)
-    (operator
-      ;; 算术运算符
-      "+" "-" "*" "/" "\\" "^" ".^" ".*" "./" ".\\" "'" ".'"
-      ;; 关系运算符
-      "==" "~=" "<" ">" "<=" ">=" 
-      ;; 逻辑运算符
-      "&" "|" "~" "&&" "||"
-      ;; 其他运算符
-      ":" "(" ")" "[" "]" "{" "}" ";" "," "." ".." "..." "=" "!" "@")))
-
-;;------------------------------------------------------------------------------
-;; 数字格式定义
-;;
-
-;; 定义MATLAB语言的数字格式，包括前缀和后缀
-;; 支持16进制(0x)和二进制(0b)前缀，科学计数法
-;; 支持无符号整数、有符号整数和浮点数后缀
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "matlab") (== key "number")))
-  `(,(string->symbol key)
-    (bool_features
-      "prefix_0x" "prefix_0b"
-      "sci_notation")
-    (suffix
-      (unsigned_integer 
-        "u8" "u16" "u32" "u64")
-      (signed_integer
-        "s8" "s16" "s32" "s64")
-      (float "f" "F"))))
-
-;;------------------------------------------------------------------------------
-;; 字符串格式定义
-;;
-
-;; 定义MATLAB语言的字符串格式，支持转义字符
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "matlab") (== key "string")))
-  `(,(string->symbol key)
-    (bool_features
-      "escape_char_after_backslash")
-    (escape_sequences "\\" "\"" "n" "t" "b" "r" "f" "a" "v" "0")
-    (double_escape "'")
-    (start_disallow_after
-      "alpha" "digit" "underscore" ")" "]" "}" "." "'")))
-
-;;------------------------------------------------------------------------------
-;; 注释格式定义
-;;
-
-;; 定义MATLAB语言的注释格式，支持行注释和块注释
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "matlab") (== key "comment")))
-  `(,(string->symbol key)
-    (inline "%")
-    (block_comment "%{" "%}")))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Preferences for syntax highlighting
-;; 语法高亮偏好设置
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; 通知MATLAB语法更改的函数
-(define (notify-matlab-syntax var val)
-  (syntax-read-preferences "matlab"))
-
-;; 定义MATLAB语法高亮颜色偏好设置
-;; 已验证可生效
-(define-preferences
-  ("syntax:matlab:none" "red" notify-matlab-syntax)
-  ("syntax:matlab:comment" "brown" notify-matlab-syntax)
-  ("syntax:matlab:error" "dark red" notify-matlab-syntax)
-  ("syntax:matlab:constant" "#4040c0" notify-matlab-syntax)
-  ("syntax:matlab:constant_number" "#3030b0" notify-matlab-syntax)
-  ("syntax:matlab:constant_string" "dark grey" notify-matlab-syntax)
-  ("syntax:matlab:constant_char" "#333333" notify-matlab-syntax)
-  ("syntax:matlab:declare_function" "#0000c0" notify-matlab-syntax)
-  ("syntax:matlab:declare_type" "#0000c0" notify-matlab-syntax)
-  ("syntax:matlab:declare_module" "#0000c0" notify-matlab-syntax)
-  ("syntax:matlab:operator" "#8b008b" notify-matlab-syntax)
-  ("syntax:matlab:operator_openclose" "#B02020" notify-matlab-syntax)
-  ("syntax:matlab:operator_field" "#888888" notify-matlab-syntax)
-  ("syntax:matlab:operator_special" "orange" notify-matlab-syntax)
-  ("syntax:matlab:keyword" "#309090" notify-matlab-syntax)
-  ("syntax:matlab:keyword_conditional" "#309090" notify-matlab-syntax)
-  ("syntax:matlab:keyword_control" "#008080ff" notify-matlab-syntax))
diff --git a/TeXmacs/plugins/matlab/progs/data/matlab.scm b/TeXmacs/plugins/matlab/progs/data/matlab.scm
deleted file mode 100644
index 8f75c31622..0000000000
--- a/TeXmacs/plugins/matlab/progs/data/matlab.scm
+++ /dev/null
@@ -1,68 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : matlab.scm
-;; DESCRIPTION : prog format for Matlab
-;; COPYRIGHT   : (C) 2022-2025  Darcy Shen, Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; DESCRIPTION:
-;;;   This module defines the format conversion for MATLAB files. It specifies
-;;;   how to convert between TeXmacs document tree format and MATLAB source 
-;;;   code format, allowing users to import and export MATLAB code.
-;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; 定义matlab格式模块
-(texmacs-module (data matlab))
-
-;;------------------------------------------------------------------------------
-;; 格式定义
-;;
-
-;; 定义MATLAB格式，指定名称和文件后缀
-(define-format matlab
-  (:name "Matlab source code")
-  (:suffix "m"))
-
-;;------------------------------------------------------------------------------
-;; 转换函数定义
-;;
-
-;; 定义从TeXmacs格式转换为MATLAB格式的函数
-(define (texmacs->matlab x . opts)
-  (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '())))
-
-;; 定义从MATLAB格式转换为TeXmacs格式的函数
-(define (matlab->texmacs x . opts)
-  (code->texmacs x))
-
-;; 定义从MATLAB代码片段转换为TeXmacs格式的函数
-(define (matlab-snippet->texmacs x . opts)
-  (code-snippet->texmacs x))
-
-;;------------------------------------------------------------------------------
-;; 转换器注册
-;;
-
-;; 注册TeXmacs文档树到MATLAB文档的转换器
-(converter texmacs-tree matlab-document
-  (:function texmacs->matlab))
-
-;; 注册MATLAB文档到TeXmacs文档树的转换器
-(converter matlab-document texmacs-tree
-  (:function matlab->texmacs))
-  
-;; 注册TeXmacs文档树到MATLAB代码片段的转换器
-(converter texmacs-tree matlab-snippet
-  (:function texmacs->matlab))
-
-;; 注册MATLAB代码片段到TeXmacs文档树的转换器
-(converter matlab-snippet texmacs-tree
-  (:function matlab-snippet->texmacs))
\ No newline at end of file
diff --git a/TeXmacs/plugins/matlab/progs/matlab/matlab-edit.scm b/TeXmacs/plugins/matlab/progs/matlab/matlab-edit.scm
new file mode 100644
index 0000000000..d4f83b47c2
--- /dev/null
+++ b/TeXmacs/plugins/matlab/progs/matlab/matlab-edit.scm
@@ -0,0 +1,167 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : matlab-edit.scm
+;; DESCRIPTION : editing Matlab programs
+;; COPYRIGHT   : (C) 2025   vesita
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; DESCRIPTION:
+;;;   This module provides editing functionalities for MATLAB language within
+;;;   TeXmacs. It defines language-specific behaviors such as indentation,
+;;;   commenting, and paste operations for MATLAB code snippets.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; 定义模块，使用 prog-edit 和 matlab-mode 模块
+(texmacs-module (matlab matlab-edit)
+  (:use (prog prog-edit) (matlab matlab-mode))
+) ;texmacs-module
+
+;; ------------------------------------------------------------------------------
+;; 缩进设置
+;;
+
+;; 定义MATLAB代码的制表符停止位为4个空格（符合MATLAB标准）
+(tm-define (get-tabstop) (:mode in-prog-matlab?) 4)
+
+;; 定义MATLAB特定的关键字，这些关键字后面需要增加缩进
+
+(define matlab-increase-indent-keys
+  '("for" "if" "while" "switch" "try" "classdef" "methods" "properties" "events")
+) ;define
+
+;; 定义MATLAB特定的配对关键字，这些关键字会减少缩进
+
+(define matlab-decrease-indent-keys
+  '("elseif" "else" "catch" "case" "otherwise")
+) ;define
+
+;; 定义MATLAB特定的结束关键字，这些关键字会减少缩进
+
+(define matlab-end-keys '("end"))
+
+;; 去除字符串右侧的空白字符
+
+(define (string-strip-right s)
+  (with char-set:not-whitespace
+    (char-set-complement char-set:whitespace)
+    (with n
+      (string-length s)
+      (with r
+        (or (string-rindex s char-set:not-whitespace) n)
+        (string-take s (min n (+ 1 r)))
+      ) ;with
+    ) ;with
+  ) ;with
+) ;define
+
+;; 检查字符串是否以特定关键字结尾
+
+(define (ends-with-keyword? s keys)
+  (and (nnull? keys)
+    (or (string-ends? s (car keys)) (ends-with-keyword? s (cdr keys)))
+  ) ;and
+) ;define
+
+;; 检查字符串是否以特定关键字开头
+
+(define (starts-with-keyword? s keys)
+  (and (nnull? keys)
+    (or (string-starts? s (string-append (car keys) " "))
+      (starts-with-keyword? s (cdr keys))
+    ) ;or
+  ) ;and
+) ;define
+
+;; 定义MATLAB代码的缩进计算函数
+(tm-define (program-compute-indentation doc row col)
+  (:mode in-prog-matlab?)
+  (if (<= row 0)
+    0
+    (let* ((prev-row (- row 1))
+           (prev-line (program-row prev-row))
+           (stripped-prev (string-strip-right (if prev-line prev-line "")))
+           (prev-indent (string-get-indent stripped-prev))
+           (tab-width (get-tabstop))
+          ) ;
+      (cond
+        ;; 如果前行以增加缩进的关键字结尾，则当前行应增加缩进
+        ((ends-with-keyword? stripped-prev matlab-increase-indent-keys)
+         (+ prev-indent tab-width)
+        ) ;
+        ;; 如果当前行以减少缩进的关键字开头，则减少缩进
+        ((starts-with-keyword? (program-row row) matlab-decrease-indent-keys)
+         (max 0 (- prev-indent tab-width))
+        ) ;
+        ;; 如果当前行以结束关键字开头，则减少缩进
+        ((starts-with-keyword? (program-row row) matlab-end-keys)
+         (max 0 (- prev-indent tab-width))
+        ) ;
+        ;; 否则保持前行的缩进
+        (else prev-indent)
+      ) ;cond
+    ) ;let*
+  ) ;if
+) ;tm-define
+
+;; ------------------------------------------------------------------------------
+;; 自动插入、高亮和选择括号和引号
+;;
+
+(tm-define (matlab-bracket-open lbr rbr)
+  ;; 插入一对括号或引号，并将光标定位在中间
+  (bracket-open lbr rbr "\\")
+) ;tm-define
+
+(tm-define (matlab-bracket-close lbr rbr)
+  ;; 处理闭合括号或引号，并正确放置光标位置
+  (bracket-close lbr rbr "\\")
+) ;tm-define
+
+(tm-define (notify-cursor-moved status)
+  (:require prog-highlight-brackets?)
+  (:mode in-prog-matlab?)
+  ;; 当光标移动时高亮匹配的括号
+  (select-brackets-after-movement "([{" ")]}" "\\")
+) ;tm-define
+
+;; ------------------------------------------------------------------------------
+;; 粘贴操作
+;;
+
+;; 定义MATLAB代码环境中的粘贴操作，使用MATLAB格式导入剪贴板内容
+(tm-define (kbd-paste)
+  (:mode in-prog-matlab?)
+  (clipboard-paste-import "matlab" "primary")
+) ;tm-define
+
+(kbd-map (:mode in-prog-matlab?)
+  ;; MATLAB编程模式下的键盘快捷键
+  ("A-tab" (insert-tabstop))
+  ;; Alt+Tab：插入制表符
+  ("cmd S-tab" (remove-tabstop))
+  ;; Cmd+Shift+Tab：移除制表符
+  ("{" (matlab-bracket-open "{" "}"))
+  ;; 自动插入匹配的大括号
+  ("}" (matlab-bracket-close "{" "}"))
+  ;; 处理闭合大括号
+  ("(" (matlab-bracket-open "(" ")"))
+  ;; 自动插入匹配的小括号
+  (")" (matlab-bracket-close "(" ")"))
+  ;; 处理闭合小括号
+  ("[" (matlab-bracket-open "[" "]"))
+  ;; 自动插入匹配的方括号
+  ("]" (matlab-bracket-close "[" "]"))
+  ;; 处理闭合方括号
+  ("\"" (matlab-bracket-open "\"" "\""))
+  ;; 自动插入匹配的双引号
+  ("'" (matlab-bracket-open "'" "'"))
+) ;kbd-map
+;; 自动插入匹配的单引号
diff --git a/TeXmacs/plugins/matlab/progs/matlab/matlab-format.scm b/TeXmacs/plugins/matlab/progs/matlab/matlab-format.scm
new file mode 100644
index 0000000000..0f04cc13a1
--- /dev/null
+++ b/TeXmacs/plugins/matlab/progs/matlab/matlab-format.scm
@@ -0,0 +1,68 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : matlab.scm
+;; DESCRIPTION : prog format for Matlab
+;; COPYRIGHT   : (C) 2022-2025  Darcy Shen, Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; DESCRIPTION:
+;;;   This module defines the format conversion for MATLAB files. It specifies
+;;;   how to convert between TeXmacs document tree format and MATLAB source
+;;;   code format, allowing users to import and export MATLAB code.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; 定义matlab格式模块
+(texmacs-module (matlab matlab-format))
+
+;; ------------------------------------------------------------------------------
+;; 格式定义
+;;
+
+;; 定义MATLAB格式，指定名称和文件后缀
+(define-format matlab (:name "Matlab source code") (:suffix "m"))
+
+;; ------------------------------------------------------------------------------
+;; 转换函数定义
+;;
+
+;; 定义从TeXmacs格式转换为MATLAB格式的函数
+
+(define (texmacs->matlab x . opts)
+  (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '()))
+) ;define
+
+;; 定义从MATLAB格式转换为TeXmacs格式的函数
+
+(define (matlab->texmacs x . opts)
+  (code->texmacs x)
+) ;define
+
+;; 定义从MATLAB代码片段转换为TeXmacs格式的函数
+
+(define (matlab-snippet->texmacs x . opts)
+  (code-snippet->texmacs x)
+) ;define
+
+;; ------------------------------------------------------------------------------
+;; 转换器注册
+;;
+
+;; 注册TeXmacs文档树到MATLAB文档的转换器
+(converter texmacs-tree matlab-document (:function texmacs->matlab))
+
+;; 注册MATLAB文档到TeXmacs文档树的转换器
+(converter matlab-document texmacs-tree (:function matlab->texmacs))
+
+;; 注册TeXmacs文档树到MATLAB代码片段的转换器
+(converter texmacs-tree matlab-snippet (:function texmacs->matlab))
+
+;; 注册MATLAB代码片段到TeXmacs文档树的转换器
+(converter matlab-snippet texmacs-tree (:function matlab-snippet->texmacs))
diff --git a/TeXmacs/plugins/matlab/progs/matlab/matlab-lang.scm b/TeXmacs/plugins/matlab/progs/matlab/matlab-lang.scm
new file mode 100644
index 0000000000..3569c1b125
--- /dev/null
+++ b/TeXmacs/plugins/matlab/progs/matlab/matlab-lang.scm
@@ -0,0 +1,171 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : matlab-lang.scm
+;; DESCRIPTION : Matlab language support
+;; COPYRIGHT   : (C) 2025  veista
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; DESCRIPTION:
+;;;   This module provides language support for MATLAB within TeXmacs. It
+;;;   defines language features such as keywords, operators, number formats,
+;;;   string formats, and comment formats for proper syntax highlighting and
+;;;   parsing of MATLAB code.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; 定义matlab语言支持模块，使用默认语言支持模块
+(texmacs-module (matlab matlab-lang) (:use (prog default-lang)))
+
+;; ------------------------------------------------------------------------------
+;; 关键字定义
+;;
+
+;; 定义MATLAB语言的关键字分类
+;; 包括常量、函数声明、类型声明、模块导入、标识符声明、条件关键字、控制关键字等
+;; src/System/Language/language.cpp中定义了关键字分类
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "matlab") (== key "keyword")))
+  `(,(string->symbol key)
+    (constant "Inf" "NaN" "eps" "pi" "i" "j" "true" "false" "ans" "realmin"
+      "realmax")
+    (declare_function "function")
+    (declare_type "classdef" "properties" "methods" "events" "enumerate"
+      "struct" "attributes")
+    (declare_module "import")
+    (declare_identifier "global" "persistent")
+    (keyword "nargin" "nargout" "varargin" "varargout" "parsing")
+    (keyword_conditional "if" "else" "elseif" "switch" "case" "otherwise")
+    (keyword_control "for" "while" "break" "continue" "return" "try" "catch"
+      "end"))
+) ;tm-define
+
+;; ------------------------------------------------------------------------------
+;; 操作符定义
+;;
+
+;; 定义MATLAB语言的操作符符号
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "matlab") (== key "operator")))
+  `(,(string->symbol key)
+    (operator ;; 算术运算符
+      "+"
+      "-"
+      "*"
+      "/"
+      "\\"
+      "^"
+      ".^"
+      ".*"
+      "./"
+      ".\\"
+      "'"
+      ".'"
+      ;; 关系运算符
+      "=="
+      "~="
+      "<"
+      ">"
+      "<="
+      ">="
+      ;; 逻辑运算符
+      "&"
+      "|"
+      "~"
+      "&&"
+      "||"
+      ;; 其他运算符
+      ":"
+      "("
+      ")"
+      "["
+      "]"
+      "{"
+      "}"
+      ";"
+      ","
+      "."
+      ".."
+      "..."
+      "="
+      "!"
+      "@"))
+) ;tm-define
+
+;; ------------------------------------------------------------------------------
+;; 数字格式定义
+;;
+
+;; 定义MATLAB语言的数字格式，包括前缀和后缀
+;; 支持16进制(0x)和二进制(0b)前缀，科学计数法
+;; 支持无符号整数、有符号整数和浮点数后缀
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "matlab") (== key "number")))
+  `(,(string->symbol key)
+    (bool_features "prefix_0x" "prefix_0b" "sci_notation")
+    (suffix (unsigned_integer "u8" "u16" "u32" "u64")
+      (signed_integer "s8" "s16" "s32" "s64")
+      (float "f" "F")))
+) ;tm-define
+
+;; ------------------------------------------------------------------------------
+;; 字符串格式定义
+;;
+
+;; 定义MATLAB语言的字符串格式，支持转义字符
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "matlab") (== key "string")))
+  `(,(string->symbol key)
+    (bool_features "escape_char_after_backslash")
+    (escape_sequences "\\" "\"" "n" "t" "b" "r" "f" "a" "v" "0")
+    (double_escape "'")
+    (start_disallow_after "alpha" "digit" "underscore" ")" "]" "}" "." "'"))
+) ;tm-define
+
+;; ------------------------------------------------------------------------------
+;; 注释格式定义
+;;
+
+;; 定义MATLAB语言的注释格式，支持行注释和块注释
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "matlab") (== key "comment")))
+  `(,(string->symbol key) (inline "%") (block_comment "%{" "%}"))
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Preferences for syntax highlighting
+;; 语法高亮偏好设置
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; 通知MATLAB语法更改的函数
+
+(define (notify-matlab-syntax var val)
+  (syntax-read-preferences "matlab")
+) ;define
+
+;; 定义MATLAB语法高亮颜色偏好设置
+;; 已验证可生效
+(define-preferences ("syntax:matlab:none" "red" notify-matlab-syntax)
+ ("syntax:matlab:comment" "brown" notify-matlab-syntax)
+ ("syntax:matlab:error" "dark red" notify-matlab-syntax)
+ ("syntax:matlab:constant" "#4040c0" notify-matlab-syntax)
+ ("syntax:matlab:constant_number" "#3030b0" notify-matlab-syntax)
+ ("syntax:matlab:constant_string" "dark grey" notify-matlab-syntax)
+ ("syntax:matlab:constant_char" "#333333" notify-matlab-syntax)
+ ("syntax:matlab:declare_function" "#0000c0" notify-matlab-syntax)
+ ("syntax:matlab:declare_type" "#0000c0" notify-matlab-syntax)
+ ("syntax:matlab:declare_module" "#0000c0" notify-matlab-syntax)
+ ("syntax:matlab:operator" "#8b008b" notify-matlab-syntax)
+ ("syntax:matlab:operator_openclose" "#B02020" notify-matlab-syntax)
+ ("syntax:matlab:operator_field" "#888888" notify-matlab-syntax)
+ ("syntax:matlab:operator_special" "orange" notify-matlab-syntax)
+ ("syntax:matlab:keyword" "#309090" notify-matlab-syntax)
+ ("syntax:matlab:keyword_conditional" "#309090" notify-matlab-syntax)
+ ("syntax:matlab:keyword_control" "#008080ff" notify-matlab-syntax)
+) ;define-preferences
diff --git a/TeXmacs/plugins/matlab/progs/code/matlab-mode.scm b/TeXmacs/plugins/matlab/progs/matlab/matlab-mode.scm
similarity index 81%
rename from TeXmacs/plugins/matlab/progs/code/matlab-mode.scm
rename to TeXmacs/plugins/matlab/progs/matlab/matlab-mode.scm
index c4a0ae34da..6f14e09acc 100644
--- a/TeXmacs/plugins/matlab/progs/code/matlab-mode.scm
+++ b/TeXmacs/plugins/matlab/progs/matlab/matlab-mode.scm
@@ -20,17 +20,16 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 ;; 定义matlab语言模式模块，使用基础的texmacs模式功能
-(texmacs-module (code matlab-mode)
-  (:use (kernel texmacs tm-modes)))
+(texmacs-module (matlab matlab-mode) (:use (kernel texmacs tm-modes)))
 
-;;------------------------------------------------------------------------------
+;; ------------------------------------------------------------------------------
 ;; 模式定义
 ;;
 
 ;; 定义MATLAB相关的模式谓词
 ;; in-matlab% 检测当前环境是否为MATLAB编程语言环境
 ;; in-prog-matlab% 检测是否在程序模式下的MATLAB代码环境中
-(texmacs-modes
-  (in-matlab% (== (get-env "prog-language") "matlab"))
+(texmacs-modes (in-matlab% (== (get-env "prog-language") "matlab"))
   ;; 判断是否处于matlab代码模式
-  (in-prog-matlab% #t in-prog% in-matlab%))
\ No newline at end of file
+  (in-prog-matlab% #t in-prog% in-matlab%)
+) ;texmacs-modes
diff --git a/TeXmacs/plugins/maxima/packages/session/maxima.stem b/TeXmacs/plugins/maxima/packages/session/maxima.stem
new file mode 100644
index 0000000000..5a4322fa2a
--- /dev/null
+++ b/TeXmacs/plugins/maxima/packages/session/maxima.stem
@@ -0,0 +1,28 @@
+(document (TeXmacs "1.0.7.20")
+  (style "source")
+  (body (document (active* (src-title (document (src-package "maxima" "1.0")
+                                        (src-purpose (document "Markup for Maxima sessions."))
+                                        (src-copyright "2002--2004" "Joris van der Hoeven")
+                                        (src-license (document (concat "This software falls under the "
+                                                                 (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE")
+                                                                 ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see "
+                                                                 (hlink "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                   "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                 ) ;hlink
+                                                                 "."
+                                                               ) ;concat
+                                                     ) ;document
+                                        ) ;src-license
+                                      ) ;document
+                           ) ;src-title
+                  ) ;active*
+          (use-module "(maxima maxima-menu)")
+          (use-module "(maxima maxima-kbd)")
+          (assign "maxima-output"
+            (macro "body" (document (padded (document (generic-output* (arg "body"))))))
+          ) ;assign
+          ""
+        ) ;document
+  ) ;body
+  (initial (collection (associate "preamble" "true")))
+) ;document
diff --git a/TeXmacs/plugins/maxima/packages/session/maxima.ts b/TeXmacs/plugins/maxima/packages/session/maxima.ts
deleted file mode 100644
index 11014eb2d1..0000000000
--- a/TeXmacs/plugins/maxima/packages/session/maxima.ts
+++ /dev/null
@@ -1,36 +0,0 @@
-
-
-
-
-<\body>
-  
-    
-
-    <\src-purpose>
-      Markup for Maxima sessions.
-    
-
-    
-
-    <\src-license>
-      This software falls under the . It comes WITHOUT ANY
-      WARRANTY WHATSOEVER. You should have received a copy of the license
-      which the software. If not, see .
-    
-  >
-
-  
-    <\padded>
-      >
-    
-  >
-
-  \;
-
-
-<\initial>
-  <\collection>
-    
-  
-
\ No newline at end of file
diff --git a/TeXmacs/plugins/maxima/progs/binary/maxima.scm b/TeXmacs/plugins/maxima/progs/binary/maxima.scm
deleted file mode 100644
index ca6c12c008..0000000000
--- a/TeXmacs/plugins/maxima/progs/binary/maxima.scm
+++ /dev/null
@@ -1,36 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : maxima.scm
-;; DESCRIPTION : maxima Binary plugin
-;; COPYRIGHT   : (C) 2024  Darcy Shen
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (binary maxima)
-  (:use (binary common)))
-
-(define (maxima-binary-candidates)
-  (cond ((os-macos?)
-         (list "/opt/homebrew/bin/maxima"
-               "/usr/local/bin/maxima"
-               "/Applications/Maxima.app/Contents/Resources/opt/bin/maxima"))
-        ((os-win32?)
-         (list "C:\\maxima-*\\bin\\maxima.bat"))
-        (else
-         (list
-          "/usr/bin/maxima"))))
-
-(tm-define (find-binary-maxima)
-  (:synopsis "Find the url to the maxima binary, return (url-none) if not found")
-  (find-binary (maxima-binary-candidates) "maxima"))
-
-(tm-define (has-binary-maxima?)
-  (not (url-none? (find-binary-maxima))))
-
-(tm-define (version-binary-maxima)
-  (version-binary (find-binary-maxima)))
diff --git a/TeXmacs/plugins/maxima/progs/init-maxima.scm b/TeXmacs/plugins/maxima/progs/init-maxima.scm
index 6e1fc79304..266156e06f 100644
--- a/TeXmacs/plugins/maxima/progs/init-maxima.scm
+++ b/TeXmacs/plugins/maxima/progs/init-maxima.scm
@@ -11,46 +11,54 @@
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(use-modules (binary maxima))
+(use-modules (maxima maxima-binary))
 
 (define (maxima-serialize lan t)
-  (with s (string-drop-right (utf8raw-serialize lan t) 1)
+  (with s
+    (string-drop-right (utf8raw-serialize lan t) 1)
     (cond ((== s "") "0;\n")
-          ((in? (string-ref s (- (string-length s) 1)) '(#\; #\$))
-           (string-append s "\n"))
-          (else (string-append s ";\n")))))
+          ((in? (string-ref s (- (string-length s) 1)) '(#\; #\$)) (string-append s "\n"))
+          (else (string-append s ";\n"))
+    ) ;cond
+  ) ;with
+) ;define
 
 (define (maxima-entry)
-  (string-quote
-    (if (url-exists? "$TEXMACS_HOME_PATH/plugins/maxima")
-      (url->system "$TEXMACS_HOME_PATH/plugins/maxima/lisp/texmacs-maxima.lisp")
-      (url->system "$TEXMACS_PATH/plugins/maxima/lisp/texmacs-maxima.lisp"))))
+  (string-quote (if (url-exists? "$TEXMACS_HOME_PATH/plugins/maxima")
+                  (url->system "$TEXMACS_HOME_PATH/plugins/maxima/lisp/texmacs-maxima.lisp")
+                  (url->system "$TEXMACS_PATH/plugins/maxima/lisp/texmacs-maxima.lisp")
+                ) ;if
+  ) ;string-quote
+) ;define
 
 (define (maxima-launchers)
-  (if (os-win32?)
-      `((:launch ,(string-append "cmd.exe /c " (url->system (find-binary-maxima)) " -p " (maxima-entry))))
-      `((:launch ,(string-append (url->system (find-binary-maxima)) " -p " (maxima-entry))))))
+  (if (os-windows?)
+    `((,:launch
+       ,(string-append "cmd.exe /c "
+          (url->system (find-binary-maxima))
+          " -p "
+          (maxima-entry))))
+    `((,:launch
+       ,(string-append (url->system (find-binary-maxima)) " -p " (maxima-entry))))
+  ) ;if
+) ;define
 
-(when (and (has-binary-maxima?) (string-starts? (url->system (find-binary-maxima)) "/opt/homebrew/bin"))
-  (plugin-add-macos-path "gnuplot" "/opt/homebrew/bin" #t))
+(when (and (has-binary-maxima?)
+        (string-starts? (url->system (find-binary-maxima)) "/opt/homebrew/bin")
+      ) ;and
+  (plugin-add-macos-path "gnuplot" "/opt/homebrew/bin" #t)
+) ;when
 
-(when (and (has-binary-maxima?) (string-starts? (url->system (find-binary-maxima)) "/usr/local/bin"))
-  (plugin-add-macos-path "gnuplot" "/usr/local/bin" #t))
+(when (and (has-binary-maxima?)
+        (string-starts? (url->system (find-binary-maxima)) "/usr/local/bin")
+      ) ;and
+  (plugin-add-macos-path "gnuplot" "/usr/local/bin" #t)
+) ;when
 
 (plugin-configure maxima
   (:require (has-binary-maxima?))
   ,@(maxima-launchers)
   (:serializer ,maxima-serialize)
   (:session "Maxima")
-  (:scripts "Maxima"))
-
-(when (supports-maxima?)
-  (import-from (maxima-kbd))
-  (import-from (maxima-menus))
-  (lazy-input-converter (maxima-input) maxima)
-  (plugin-approx-command-set! "maxima" "float")
-
-  (kbd-map
-    (:mode in-maxima?)
-    (:mode in-math?)
-    ("$" "$")))
+  (:scripts "Maxima")
+) ;plugin-configure
diff --git a/TeXmacs/plugins/maxima/progs/maxima-input.scm b/TeXmacs/plugins/maxima/progs/maxima-input.scm
deleted file mode 100644
index 70eff29352..0000000000
--- a/TeXmacs/plugins/maxima/progs/maxima-input.scm
+++ /dev/null
@@ -1,155 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : maxima-input.scm
-;; DESCRIPTION : Initialize maxima plugin
-;; COPYRIGHT   : (C) 1999  Joris van der Hoeven, 2005  Andrey Grozin
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (maxima-input)
-  (:use (utils plugins plugin-convert)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Specific conversion routines
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (maxima-input-var-row r)
-  (if (nnull? r)
-      (begin
-	(display ", ")
-	(plugin-input (car r))
-	(maxima-input-var-row (cdr r)))))
-
-(define (maxima-input-row r)
-  (display "[")
-  (plugin-input (car r))
-  (maxima-input-var-row (cdr r))
-  (display "]"))
-
-(define (maxima-input-var-rows t)
-  (if (nnull? t)
-      (begin
-	(display ", ")
-	(maxima-input-row (car t))
-	(maxima-input-var-rows (cdr t)))))
-
-(define (maxima-input-rows t)
-  (display "matrix(")
-  (maxima-input-row (car t))
-  (maxima-input-var-rows (cdr t))
-  (display ")"))
-
-(define (maxima-input-descend-last args)
-  (if (null? (cdr args))
-      (plugin-input (car args))
-      (maxima-input-descend-last (cdr args))))
-
-(define (maxima-input-det args)
-  (display "determinant(")
-  (maxima-input-descend-last args)
-  (display ")"))
-
-(define (maxima-input-binom args)
-  (display "binomial(")
-  (plugin-input (car args))
-  (display ",")
-  (plugin-input (cadr args))
-  (display ")"))
-
-(define (maxima-input-sqrt args)
-  (if (= (length args) 1)
-      (begin
-        (display "sqrt(")
-        (plugin-input (car args))
-        (display ")"))
-      (begin
-        (display "(")
-        (plugin-input (car args))
-        (display ")^(1/(")
-        (plugin-input (cadr args))
-        (display "))"))))
-
-(define (maxima-input-sum args)
-  (if (nnull? args)
-      (if (nnull? (cdr args))
-          (begin ;; both lower and upper index
-            (display "tmsum(")
-            (plugin-input (car args))
-            (display ",")
-            (plugin-input (cadr args))
-            (display ","))
-          (begin ;; lower index only
-            (display "tmlsum(")
-            (plugin-input (car args))
-            (display ",")))
-      (display "tmsum(")))
-
-(define (maxima-input-prod args)
-  (if (nnull? args)
-      (begin
-        (display "tmprod(")
-        (plugin-input (car args))
-        (if (nnull? (cdr args))
-            (begin
-              (display ",")
-              (plugin-input (cadr args))))
-        (display ","))
-      (display "tmprod(")))
-
-(define (maxima-input-int args)
-  (if (nnull? args)
-      (begin
-        (display "tmint(")
-        (plugin-input (car args))
-        (if (nnull? (cdr args))
-            (begin
-              (display ",")
-              (plugin-input (cadr args))))
-        (display ","))
-      (display "integrate(")))
-
-
-(define (maxima-input-big-around args)
-  (let* ((b `(big-around ,@args))
-	 (op (big-name b))
-	 (sub (big-subscript b))
-	 (sup (big-supscript b))
-	 (body (big-body b))
-	 (l (cond ((and sub sup) (list sub sup))
-		  (sub (list sub))
-		  (else (list)))))
-    (cond ((== op "sum")  (maxima-input-sum l))
-	  ((== op "prod") (maxima-input-prod l))
-	  ((== op "int")  (maxima-input-int l))
-	  (else (display op) (display "(")))
-    (plugin-input body)
-    (display ")")))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Initialization
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(plugin-input-converters maxima
-  (rows maxima-input-rows)
-  (det maxima-input-det)
-  (sqrt maxima-input-sqrt)
-  (big-around maxima-input-big-around)
-  (binom maxima-input-binom)
-
-  (""      "inf")
-  (""   "[]")
-  (""      "1,")
-  (""      "%i")
-  (""      "%e")
-  (""         "=")
-
-  (""	  "~")
-  (""	  ".")
-
-  (""      "%gamma")
-  (""         "%pi"))
diff --git a/TeXmacs/plugins/maxima/progs/maxima-kbd.scm b/TeXmacs/plugins/maxima/progs/maxima-kbd.scm
deleted file mode 100644
index f421d93fcd..0000000000
--- a/TeXmacs/plugins/maxima/progs/maxima-kbd.scm
+++ /dev/null
@@ -1,22 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : maxima-kbd.scm
-;; DESCRIPTION : Keyboard shortcuts for Maxima
-;; COPYRIGHT   : (C) 2005  Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (maxima-kbd)
-  (:use (dynamic scripts-kbd)))
-
-(texmacs-modes
-  (maxima-scripts-math% #t maxima-scripts% in-math%))
-
-(kbd-map
-  (:mode maxima-scripts-math?)
-  (": =" (insert '(script-assign))))
diff --git a/TeXmacs/plugins/maxima/progs/maxima-menus.scm b/TeXmacs/plugins/maxima/progs/maxima-menus.scm
deleted file mode 100644
index 06eea819f8..0000000000
--- a/TeXmacs/plugins/maxima/progs/maxima-menus.scm
+++ /dev/null
@@ -1,150 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : maxima-menus.scm
-;; DESCRIPTION : Menus for the maxima plugin
-;; COPYRIGHT   : (C) 2005  Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (maxima-menus)
-  (:use (utils plugins plugin-cmd)
-	(doc help-funcs)
-	(dynamic scripts-edit)
-        (dynamic session-menu)
-	(convert tools tmconcat)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Several subroutines for the evaluation of Maxima expressions
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (maxima-spaces? t)
-  (and (string? t) (in? t (list "" " " "  " "   " "    "))))
-
-(define (maxima-prompt? t)
-  (or (match? t '(text (with "font-family" "tt" "color" "red" :*)))
-      (match? t '(with "font-family" "tt" "color" "red" :*))
-      (match? t '(with "mode" "text" "font-family" "tt" "color" "red" :*))))
-
-(define (maxima-output-simplify t)
-  ;;(display* "Simplify " t "\n")
-  (cond ((and (func? t 'concat) (> (length t) 2) (maxima-prompt? (cadr t)))
-	 (plugin-output-std-simplify "maxima" (cons 'concat (cddr t))))
-	((match? t '(with "math-display" "true" :%1))
-	 (maxima-output-simplify (cAr t)))
-	((match? t '(with "mode" "math" "math-display" "true" :%1))
-	 `(math ,(maxima-output-simplify (cAr t))))
-	((func? t 'text 1)
-	 `(text ,(maxima-output-simplify (cAr t))))
-	((func? t 'math 1)
-	 `(math ,(maxima-output-simplify (cAr t))))
-	((func? t 'with 1)
-	 (maxima-output-simplify (cAr t)))
-	((func? t 'with)
-	 (rcons (cDr t) (maxima-output-simplify (cAr t))))
-        ((and (func? t 'concat) (pair? (cdr t)) (maxima-spaces? (cadr t)))
-         (maxima-output-simplify (cons (car t) (cddr t))))
-	((func? t 'concat)
-	 (apply tmconcat (map maxima-output-simplify (cdr t))))
-	(else (plugin-output-std-simplify "maxima" t))))
-
-(define (maxima-contains-prompt? t)
-  (cond ((maxima-prompt? t) #t)
-	((func? t 'concat)
-	 (list-or (map maxima-contains-prompt? (cdr t))))
-	((and (func? t 'with) (nnull? (cdr t)))
-	 (maxima-contains-prompt? (cAr t)))
-	((or (func? t 'text 1) (func? t 'math 1))
-	 (maxima-contains-prompt? (cAr t)))
-	(else #f)))
-
-(tm-define (plugin-output-simplify name t)
-  (:require (== name "maxima"))
-  ;;(display* "Simplify output " t "\n")
-  (if (func? t 'document)
-      (with u (list-find (cdr t) maxima-contains-prompt?)
-	(if u (maxima-output-simplify u) (maxima-output-simplify t)))
-      (maxima-output-simplify t)))
-
-(define maxima-apply script-apply)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; The Maxima menu
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(menu-bind maxima-menu
-  (if (not-in-session?)
-      (link scripts-eval-menu)
-      ---)
-  (-> "Simplification"
-      ("Simplify" (maxima-apply "fullratsimp"))
-      ("Factor" (maxima-apply "factor"))
-      ("Expand" (maxima-apply "expand"))
-      ((eval '(concat "Expand " "w.r.t."))
-       (maxima-apply "expandwrt" 2)))
-  (-> "Solving equations"
-      ("Solve" (maxima-apply "solve"))
-      ("Solve in" (maxima-apply "solve" 2)))
-  (-> "Arithmetic"
-      ("Factor" (maxima-apply "factor"))
-      ("Gcd" (maxima-apply "gcd"))
-      ("Lcm" (maxima-apply "lcm")))
-  (-> "Logarithms"
-      ("Exponential" (maxima-apply "exp"))
-      ("Logarithm" (maxima-apply "log"))
-      ("Square root" (maxima-apply "sqrt"))
-      ---
-      ("Contract logarithms" (maxima-apply "logcontract"))
-      ("Expand logarithms" (maxima-apply "logexpand")))
-  (-> "Trigonometry"
-      ("Cosine" (maxima-apply "cos"))
-      ("Sine" (maxima-apply "sin"))
-      ("Tangent" (maxima-apply "tan"))
-      ("Arc cosine" (maxima-apply "acos"))
-      ("Arc sine" (maxima-apply "asin"))
-      ("Arc tangent" (maxima-apply "atan"))
-      ---
-      ("Reduce trigonometric functions" (maxima-apply "trigreduce"))
-      ((eval '(concat "Reduce trigonometric functions " "w.r.t."))
-       (maxima-apply "trigreduce" 2))
-      ("Expand trigonometric functions" (maxima-apply "trigexpand")))
-  (-> "Special functions"
-      ("Airy" (maxima-apply "Airy"))
-      ("Erf" (maxima-apply "erf"))
-      ("Gamma" (maxima-apply "Gamma"))
-      ("Psi" (maxima-apply "Psi")))
-  (-> "Calculus"
-      ("Differentiate" (maxima-apply "diff" 2))
-      ("Integrate" (maxima-apply "integrate" 2)))
-  (-> "Linear algebra"
-      ("Determinant" (maxima-apply "determinant"))
-      ("Echelon" (maxima-apply "echelon"))
-      ("Eigenvalues" (maxima-apply "eigenvalues"))
-      ("Invert" (maxima-apply "invert"))
-      ("Rank" (maxima-apply "rank"))
-      ("Transpose" (maxima-apply "transpose"))
-      ("Triangularize" (maxima-apply "triangularize")))
-  (if (not-in-session?)
-      ---
-      (link scripts-eval-toggle-menu)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Additional icons
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(menu-bind maxima-help-icons
-  (if (in-maxima?)
-    /
-    ((balloon (icon "tm_help.xpm") "Maxima manual")
-     (load-buffer "https://maxima.sourceforge.io/docs/manual/maxima_toc.html"))))
-
-(menu-bind session-help-icons
-  (:require (and (in-maxima?) (in-session?)))
-  (link maxima-help-icons))
-
-(menu-bind plugin-menu
-  (:require (or (in-maxima?) (and (not-in-session?) (maxima-scripts?))))
-  (=> "Maxima" (link maxima-menu)))
diff --git a/TeXmacs/plugins/maxima/progs/maxima/maxima-binary.scm b/TeXmacs/plugins/maxima/progs/maxima/maxima-binary.scm
new file mode 100644
index 0000000000..ff51fc1ae6
--- /dev/null
+++ b/TeXmacs/plugins/maxima/progs/maxima/maxima-binary.scm
@@ -0,0 +1,35 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : maxima.scm
+;; DESCRIPTION : maxima Binary plugin
+;; COPYRIGHT   : (C) 2024  Darcy Shen
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (maxima maxima-binary) (:use (binary common)))
+
+(define (maxima-binary-candidates)
+  (cond ((os-macos?)
+         (list "/opt/homebrew/bin/maxima"
+           "/usr/local/bin/maxima"
+           "/Applications/Maxima.app/Contents/Resources/opt/bin/maxima"
+         ) ;list
+        ) ;
+        ((os-windows?) (list "C:\\maxima-*\\bin\\maxima.bat"))
+        (else (list "/usr/bin/maxima"))
+  ) ;cond
+) ;define
+
+(tm-define (find-binary-maxima)
+  (:synopsis "Find the url to the maxima binary, return (url-none) if not found")
+  (find-binary (maxima-binary-candidates) "maxima")
+) ;tm-define
+
+(tm-define (has-binary-maxima?) (not (url-none? (find-binary-maxima))))
+
+(tm-define (version-binary-maxima) (version-binary (find-binary-maxima)))
diff --git a/TeXmacs/plugins/maxima/progs/maxima/maxima-input.scm b/TeXmacs/plugins/maxima/progs/maxima/maxima-input.scm
new file mode 100644
index 0000000000..98ae751698
--- /dev/null
+++ b/TeXmacs/plugins/maxima/progs/maxima/maxima-input.scm
@@ -0,0 +1,180 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : maxima-input.scm
+;; DESCRIPTION : Initialize maxima plugin
+;; COPYRIGHT   : (C) 1999  Joris van der Hoeven, 2005  Andrey Grozin
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (maxima maxima-input) (:use (utils plugins plugin-convert)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Specific conversion routines
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (maxima-input-var-row r)
+  (if (nnull? r)
+    (begin
+      (plugin-output ", ")
+      (plugin-input (car r))
+      (maxima-input-var-row (cdr r))
+    ) ;begin
+  ) ;if
+) ;define
+
+(define (maxima-input-row r)
+  (plugin-output "[")
+  (plugin-input (car r))
+  (maxima-input-var-row (cdr r))
+  (plugin-output "]")
+) ;define
+
+(define (maxima-input-var-rows t)
+  (if (nnull? t)
+    (begin
+      (plugin-output ", ")
+      (maxima-input-row (car t))
+      (maxima-input-var-rows (cdr t))
+    ) ;begin
+  ) ;if
+) ;define
+
+(define (maxima-input-rows t)
+  (plugin-output "matrix(")
+  (maxima-input-row (car t))
+  (maxima-input-var-rows (cdr t))
+  (plugin-output ")")
+) ;define
+
+(define (maxima-input-descend-last args)
+  (if (null? (cdr args))
+    (plugin-input (car args))
+    (maxima-input-descend-last (cdr args))
+  ) ;if
+) ;define
+
+(define (maxima-input-det args)
+  (plugin-output "determinant(")
+  (maxima-input-descend-last args)
+  (plugin-output ")")
+) ;define
+
+(define (maxima-input-binom args)
+  (plugin-output "binomial(")
+  (plugin-input (car args))
+  (plugin-output ",")
+  (plugin-input (cadr args))
+  (plugin-output ")")
+) ;define
+
+(define (maxima-input-sqrt args)
+  (if (= (length args) 1)
+    (begin
+      (plugin-output "sqrt(")
+      (plugin-input (car args))
+      (plugin-output ")")
+    ) ;begin
+    (begin
+      (plugin-output "(")
+      (plugin-input (car args))
+      (plugin-output ")^(1/(")
+      (plugin-input (cadr args))
+      (plugin-output "))")
+    ) ;begin
+  ) ;if
+) ;define
+
+(define (maxima-input-sum args)
+  (if (nnull? args)
+    (if (nnull? (cdr args))
+      (begin
+        ;; both lower and upper index
+        (plugin-output "tmsum(")
+        (plugin-input (car args))
+        (plugin-output ",")
+        (plugin-input (cadr args))
+        (plugin-output ",")
+      ) ;begin
+      (begin
+        ;; lower index only
+        (plugin-output "tmlsum(")
+        (plugin-input (car args))
+        (plugin-output ",")
+      ) ;begin
+    ) ;if
+    (plugin-output "tmsum(")
+  ) ;if
+) ;define
+
+(define (maxima-input-prod args)
+  (if (nnull? args)
+    (begin
+      (plugin-output "tmprod(")
+      (plugin-input (car args))
+      (if (nnull? (cdr args)) (begin (plugin-output ",") (plugin-input (cadr args))))
+      (plugin-output ",")
+    ) ;begin
+    (plugin-output "tmprod(")
+  ) ;if
+) ;define
+
+(define (maxima-input-int args)
+  (if (nnull? args)
+    (begin
+      (plugin-output "tmint(")
+      (plugin-input (car args))
+      (if (nnull? (cdr args)) (begin (plugin-output ",") (plugin-input (cadr args))))
+      (plugin-output ",")
+    ) ;begin
+    (plugin-output "integrate(")
+  ) ;if
+) ;define
+
+
+(define (maxima-input-big-around args)
+  (let* ((b `(big-around ,@args))
+         (op (big-name b))
+         (sub (big-subscript b))
+         (sup (big-supscript b))
+         (body (big-body b))
+         (l (cond ((and sub sup) (list sub sup)) (sub (list sub)) (else (list))))
+        ) ;
+    (cond ((== op "sum") (maxima-input-sum l))
+          ((== op "prod") (maxima-input-prod l))
+          ((== op "int") (maxima-input-int l))
+          (else (plugin-output op) (plugin-output "("))
+    ) ;cond
+    (plugin-input body)
+    (plugin-output ")")
+  ) ;let*
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Initialization
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(plugin-input-converters maxima
+  (rows maxima-input-rows)
+  (det maxima-input-det)
+  (sqrt maxima-input-sqrt)
+  (big-around maxima-input-big-around)
+  (binom maxima-input-binom)
+
+  ("" "inf")
+  ("" "[]")
+  ("" "1,")
+  ("" "%i")
+  ("" "%e")
+  ("" "=")
+
+  ("" "~")
+  ("" ".")
+
+  ("" "%gamma")
+  ("" "%pi")
+) ;plugin-input-converters
diff --git a/TeXmacs/plugins/maxima/progs/maxima/maxima-kbd.scm b/TeXmacs/plugins/maxima/progs/maxima/maxima-kbd.scm
new file mode 100644
index 0000000000..38fbc1e92f
--- /dev/null
+++ b/TeXmacs/plugins/maxima/progs/maxima/maxima-kbd.scm
@@ -0,0 +1,30 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : maxima-kbd.scm
+;; DESCRIPTION : Keyboard shortcuts for Maxima
+;; COPYRIGHT   : (C) 2005  Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (maxima maxima-kbd)
+  (:use (dynamic scripts-kbd)
+    (utils plugins plugin-cmd)
+    (utils plugins plugin-convert)
+  ) ;:use
+) ;texmacs-module
+
+(texmacs-modes (maxima-scripts-math% #t maxima-scripts% in-math%))
+
+(kbd-map (:mode maxima-scripts-math?) (": =" (insert '(script-assign))))
+
+(kbd-map (:mode in-maxima?) (:mode in-math?) ("$" "$"))
+
+(when (supports-maxima?)
+  (lazy-input-converter (maxima maxima-input) maxima)
+  (plugin-approx-command-set! "maxima" "float")
+) ;when
diff --git a/TeXmacs/plugins/maxima/progs/maxima/maxima-menu.scm b/TeXmacs/plugins/maxima/progs/maxima/maxima-menu.scm
new file mode 100644
index 0000000000..1f2c526178
--- /dev/null
+++ b/TeXmacs/plugins/maxima/progs/maxima/maxima-menu.scm
@@ -0,0 +1,167 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : maxima-menu.scm
+;; DESCRIPTION : Menus for the maxima plugin
+;; COPYRIGHT   : (C) 2005  Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (maxima maxima-menu)
+  (:use (utils plugins plugin-cmd)
+    (doc help-funcs)
+    (dynamic scripts-edit)
+    (dynamic session-menu)
+    (convert tools tmconcat)
+  ) ;:use
+) ;texmacs-module
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Several subroutines for the evaluation of Maxima expressions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (maxima-spaces? t)
+  (and (string? t) (in? t (list "" " " "  " "   " "    ")))
+) ;define
+
+(define (maxima-prompt? t)
+  (or (match? t '(text (with "font-family" "tt" "color" "red" :*)))
+    (match? t '(with "font-family" "tt" "color" "red" :*))
+    (match? t '(with "mode" "text" "font-family" "tt" "color" "red" :*))
+  ) ;or
+) ;define
+
+(define (maxima-output-simplify t)
+  ;; (display* "Simplify " t "\n")
+  (cond ((and (func? t 'concat) (> (length t) 2) (maxima-prompt? (cadr t)))
+         (plugin-output-std-simplify "maxima" (cons 'concat (cddr t)))
+        ) ;
+        ((match? t '(with "math-display" "true" :%1)) (maxima-output-simplify (cAr t)))
+        ((match? t '(with "mode" "math" "math-display" "true" :%1))
+         `(math ,(maxima-output-simplify (cAr t)))
+        ) ;
+        ((func? t 'text 1) `(text ,(maxima-output-simplify (cAr t))))
+        ((func? t 'math 1) `(math ,(maxima-output-simplify (cAr t))))
+        ((func? t 'with 1) (maxima-output-simplify (cAr t)))
+        ((func? t 'with) (rcons (cDr t) (maxima-output-simplify (cAr t))))
+        ((and (func? t 'concat) (pair? (cdr t)) (maxima-spaces? (cadr t)))
+         (maxima-output-simplify (cons (car t) (cddr t)))
+        ) ;
+        ((func? t 'concat) (apply tmconcat (map maxima-output-simplify (cdr t))))
+        (else (plugin-output-std-simplify "maxima" t))
+  ) ;cond
+) ;define
+
+(define (maxima-contains-prompt? t)
+  (cond ((maxima-prompt? t) #t)
+        ((func? t 'concat) (list-or (map maxima-contains-prompt? (cdr t))))
+        ((and (func? t 'with) (nnull? (cdr t))) (maxima-contains-prompt? (cAr t)))
+        ((or (func? t 'text 1) (func? t 'math 1)) (maxima-contains-prompt? (cAr t)))
+        (else #f)
+  ) ;cond
+) ;define
+
+(tm-define (plugin-output-simplify name t)
+  (:require (== name "maxima"))
+  ;; (display* "Simplify output " t "\n")
+  (if (func? t 'document)
+    (with u
+      (list-find (cdr t) maxima-contains-prompt?)
+      (if u (maxima-output-simplify u) (maxima-output-simplify t))
+    ) ;with
+    (maxima-output-simplify t)
+  ) ;if
+) ;tm-define
+
+(define maxima-apply script-apply)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; The Maxima menu
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(menu-bind maxima-menu
+  (if (not-in-session?) (link scripts-eval-menu) ---)
+  (-> "Simplification"
+   ("Simplify" (maxima-apply "fullratsimp"))
+   ("Factor" (maxima-apply "factor"))
+   ("Expand" (maxima-apply "expand"))
+   ((eval '(concat "Expand " "w.r.t.")) (maxima-apply "expandwrt" 2))
+  ) ;->
+  (-> "Solving equations"
+   ("Solve" (maxima-apply "solve"))
+   ("Solve in" (maxima-apply "solve" 2))
+  ) ;->
+  (-> "Arithmetic"
+   ("Factor" (maxima-apply "factor"))
+   ("Gcd" (maxima-apply "gcd"))
+   ("Lcm" (maxima-apply "lcm"))
+  ) ;->
+  (-> "Logarithms"
+   ("Exponential" (maxima-apply "exp"))
+   ("Logarithm" (maxima-apply "log"))
+   ("Square root" (maxima-apply "sqrt"))
+   ---
+   ("Contract logarithms" (maxima-apply "logcontract"))
+   ("Expand logarithms" (maxima-apply "logexpand"))
+  ) ;->
+  (-> "Trigonometry"
+   ("Cosine" (maxima-apply "cos"))
+   ("Sine" (maxima-apply "sin"))
+   ("Tangent" (maxima-apply "tan"))
+   ("Arc cosine" (maxima-apply "acos"))
+   ("Arc sine" (maxima-apply "asin"))
+   ("Arc tangent" (maxima-apply "atan"))
+   ---
+   ("Reduce trigonometric functions" (maxima-apply "trigreduce"))
+   ((eval '(concat "Reduce trigonometric functions " "w.r.t."))
+    (maxima-apply "trigreduce" 2)
+   ) ;
+   ("Expand trigonometric functions" (maxima-apply "trigexpand"))
+  ) ;->
+  (-> "Special functions"
+   ("Airy" (maxima-apply "Airy"))
+   ("Erf" (maxima-apply "erf"))
+   ("Gamma" (maxima-apply "Gamma"))
+   ("Psi" (maxima-apply "Psi"))
+  ) ;->
+  (-> "Calculus"
+   ("Differentiate" (maxima-apply "diff" 2))
+   ("Integrate" (maxima-apply "integrate" 2))
+  ) ;->
+  (-> "Linear algebra"
+   ("Determinant" (maxima-apply "determinant"))
+   ("Echelon" (maxima-apply "echelon"))
+   ("Eigenvalues" (maxima-apply "eigenvalues"))
+   ("Invert" (maxima-apply "invert"))
+   ("Rank" (maxima-apply "rank"))
+   ("Transpose" (maxima-apply "transpose"))
+   ("Triangularize" (maxima-apply "triangularize"))
+  ) ;->
+  (if (not-in-session?) --- (link scripts-eval-toggle-menu))
+) ;menu-bind
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Additional icons
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(menu-bind maxima-help-icons
+  (if (in-maxima?)
+    /
+    ((balloon (icon "tm_help.xpm") "Maxima manual")
+     (load-buffer "https://maxima.sourceforge.io/docs/manual/maxima_toc.html")
+    ) ;
+  ) ;if
+) ;menu-bind
+
+(menu-bind session-help-icons
+  (:require (and (in-maxima?) (in-session?)))
+  (link maxima-help-icons)
+) ;menu-bind
+
+(menu-bind plugin-menu
+  (:require (or (in-maxima?) (and (not-in-session?) (maxima-scripts?))))
+  (=> "Maxima" (link maxima-menu))
+) ;menu-bind
diff --git a/TeXmacs/plugins/moonbit/packages/code/moonbit.stem b/TeXmacs/plugins/moonbit/packages/code/moonbit.stem
new file mode 100644
index 0000000000..adcd540bf0
--- /dev/null
+++ b/TeXmacs/plugins/moonbit/packages/code/moonbit.stem
@@ -0,0 +1,34 @@
+(document (TeXmacs "2.1.4")
+  (style (tuple "source" "std"))
+  (body (document (active* (src-title (document (compound "src-package" "moonbit" "1.0")
+                                        (src-purpose (document "moonbit Language"))
+                                        (src-copyright "2025" "Jack Yansong Li")
+                                        (src-license (document (concat "This software falls under the "
+                                                                 (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE")
+                                                                 ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see "
+                                                                 (hlink "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                   "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                 ) ;hlink
+                                                                 "."
+                                                               ) ;concat
+                                                     ) ;document
+                                        ) ;src-license
+                                      ) ;document
+                           ) ;src-title
+                  ) ;active*
+          (concat (use-module "(moonbit moonbit-format)")
+            " "
+            (use-module "(moonbit moonbit-edit)")
+          ) ;concat
+          (assign "moonbit"
+            (macro "body"
+              (with "mode" "prog" "prog-language" "moonbit" "font-family" "rm" (arg "body"))
+            ) ;macro
+          ) ;assign
+          (assign "moonbit-code"
+            (macro "body" (document (pseudo-code (document (moonbit (arg "body"))))))
+          ) ;assign
+        ) ;document
+  ) ;body
+  (initial (collection (associate "preamble" "true") (associate "sfactor" "5")))
+) ;document
diff --git a/TeXmacs/plugins/moonbit/packages/code/moonbit.ts b/TeXmacs/plugins/moonbit/packages/code/moonbit.ts
deleted file mode 100644
index 14504d65e4..0000000000
--- a/TeXmacs/plugins/moonbit/packages/code/moonbit.ts
+++ /dev/null
@@ -1,39 +0,0 @@
-
-
->
-
-<\body>
-  
-    
-
-    <\src-purpose>
-      moonbit Language
-    
-
-    
-
-    <\src-license>
-      This software falls under the . It comes WITHOUT ANY
-      WARRANTY WHATSOEVER. You should have received a copy of the license
-      which the software. If not, see .
-    
-  >
-
-   
-
-  >>>
-
-  
-    <\pseudo-code>
-      >
-    
-  >
-
-
-<\initial>
-  <\collection>
-    
-    
-  
-
\ No newline at end of file
diff --git a/TeXmacs/plugins/moonbit/progs/code/moonbit-edit.scm b/TeXmacs/plugins/moonbit/progs/code/moonbit-edit.scm
deleted file mode 100644
index f8f232063f..0000000000
--- a/TeXmacs/plugins/moonbit/progs/code/moonbit-edit.scm
+++ /dev/null
@@ -1,23 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : moonbit-edit.scm
-;; DESCRIPTION : editing Moonbit programs
-;; COPYRIGHT   : (C) 2025  (Jack) Yansong Li
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (code moonbit-edit)
-  (:use (prog prog-edit)
-        (code moonbit-mode)))
-
-(tm-define (get-tabstop)
-  (:mode in-prog-moonbit?)
-  2)
-
-(tm-define (kbd-paste)
-  (:mode in-prog-moonbit?)
-  (clipboard-paste-import "moonbit" "primary"))
diff --git a/TeXmacs/plugins/moonbit/progs/code/moonbit-lang.scm b/TeXmacs/plugins/moonbit/progs/code/moonbit-lang.scm
deleted file mode 100644
index 856799fe80..0000000000
--- a/TeXmacs/plugins/moonbit/progs/code/moonbit-lang.scm
+++ /dev/null
@@ -1,102 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : moonbit-lang.scm
-;; DESCRIPTION : Moonbit Language
-;; COPYRIGHT   : (C) 2025 (Jack) Yansong Li
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (code moonbit-lang)
-  (:use (prog default-lang)))
-
-;; https://docs.moonbitlang.cn/language/introduction.html
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "moonbit") (== key "keyword")))
-  `(,(string->symbol key)
-    ;; Keywords based on the official MoonBit documentation.
-    (constant
-      "true" "false" "_")
-
-    ;; Built-in Types and Type Definition Keywords
-    (declare_type
-      ;; Keywords for defining new types
-      "type" "struct" "enum" "trait" "typealias" "traitalias"
-
-      ;; Built-in primitive types
-      "Bool" "Byte" "Char" "String"
-      "Int" "Int64" "UInt" "UInt64" "BigInt"
-      "Float" "Double" "Float64"
-      "Unit"
-
-      ;; Core functional types
-      "Option" "Result"
-
-      ;; Collection types
-      "Array" "List" "Map" "Set" "StringBuilder"
-
-      ;; Concurrency and state
-      "Ref")
-
-    ;; Declarations and Functions
-    (declare_function "fn" "let" "const")
-
-    ;; Control Flow & Expressions
-    (keyword_conditional
-      "if" "else" "while" "loop" "for" "in" "match")
-
-    ;; Keywords for program structure and visibility
-    (declare_module "import" "pub")
-
-    ;; Other keywords from the official list
-    (keyword
-      "as" "extern" "fnalias" "typealias" "traitalias" "mut"
-      "derive" "break" "continue" "return" "throw" "raise"
-      "try" "catch" "with" "guard" "async" "is" "suberror" "and" "letrec"
-      "enumview" "noraise" "defer" "test" "impl")))
-
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "moonbit") (== key "operator")))
-  `(,(string->symbol key)
-    ;; Common operators in MoonBit
-    (operator
-      "+" "-" "/" "*" "%" ;; Arithmetic
-      "|" "&" "^" "!"      ;; Bitwise and Logical NOT
-      "&&" "||"            ;; Boolean
-      "==" "!=" "<" ">" "<=" ">=") ;; Comparison
-    (operator_assignment ;; Corrected assignment operators
-      "=" "+=" "-=" "*=" "/=" "%=")
-    (operator_special ;; Special operators and symbols used in MoonBit syntax
-      ":" "->" "|" "." "::" "#")
-    (operator_openclose "{" "[" "(" ")" "]" "}")))
-
-(define (moonbit-number-suffix)
-  ;; Suffixes for integer types in MoonBit
-  `(suffix
-    (long "L")         ;; For Int64
-    (unsigned "U")     ;; For UInt
-    (unsigned_long "UL") ;; For UInt64
-    (bigint "N")))      ;; For BigInt
-
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "moonbit") (== key "number")))
-  `(,(string->symbol key)
-    ;; MoonBit supports hex, binary, and octal prefixes, as well as scientific notation.
-    (bool_features
-     "prefix_0x" "prefix_0b" "prefix_0o"
-     "sci_notation")
-    ,(moonbit-number-suffix)))
-
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "moonbit") (== key "string")))
-  `(,(string->symbol key)
-    (bool_features
-      ;; MoonBit supports unicode escapes
-      "unicode_escape_braces")
-    ;; Standard C-style escape sequences
-    (escape_sequences "\\" "\"" "'" "b" "f" "n" "r" "t")))
-
diff --git a/TeXmacs/plugins/moonbit/progs/code/moonbit-mode.scm b/TeXmacs/plugins/moonbit/progs/code/moonbit-mode.scm
deleted file mode 100644
index d8bd5f5524..0000000000
--- a/TeXmacs/plugins/moonbit/progs/code/moonbit-mode.scm
+++ /dev/null
@@ -1,19 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : moonbit-lang.scm
-;; DESCRIPTION : Moonbit Language mode
-;; COPYRIGHT   : (C) 2025  (Jack) Yansong Li
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (code moonbit-mode)
-  (:use (kernel texmacs tm-modes)))
-
-(texmacs-modes
-  (in-moonbit% (== (get-env "prog-language") "moonbit"))
-  (in-prog-moonbit% #t in-prog% in-moonbit%))
diff --git a/TeXmacs/plugins/moonbit/progs/data/moonbit.scm b/TeXmacs/plugins/moonbit/progs/data/moonbit.scm
deleted file mode 100644
index a6d13aaeb1..0000000000
--- a/TeXmacs/plugins/moonbit/progs/data/moonbit.scm
+++ /dev/null
@@ -1,43 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : init-prog_moonbit.scm
-;; DESCRIPTION : prog format for Moonbit
-;; COPYRIGHT   : (C) 2025  (Jack) Yansong Li
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (data moonbit))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Moonbit source files
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define-format moonbit
-  (:name "Moonbit source code")
-  (:suffix "moonbit" "mbt"))
-
-(define (texmacs->moonbit x . opts)
-  (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '())))
-
-(define (moonbit->texmacs x . opts)
-  (code->texmacs x))
-
-(define (moonbit-snippet->texmacs x . opts)
-  (code-snippet->texmacs x))
-
-(converter texmacs-tree moonbit-document
-  (:function texmacs->moonbit))
-
-(converter moonbit-document texmacs-tree
-  (:function moonbit->texmacs))
-  
-(converter texmacs-tree moonbit-snippet
-  (:function texmacs->moonbit))
-
-(converter moonbit-snippet texmacs-tree
-  (:function moonbit-snippet->texmacs))
diff --git a/TeXmacs/plugins/moonbit/progs/moonbit/moonbit-edit.scm b/TeXmacs/plugins/moonbit/progs/moonbit/moonbit-edit.scm
new file mode 100644
index 0000000000..54f27fd777
--- /dev/null
+++ b/TeXmacs/plugins/moonbit/progs/moonbit/moonbit-edit.scm
@@ -0,0 +1,22 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : moonbit-edit.scm
+;; DESCRIPTION : editing Moonbit programs
+;; COPYRIGHT   : (C) 2025  (Jack) Yansong Li
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (moonbit moonbit-edit)
+  (:use (prog prog-edit) (moonbit moonbit-mode))
+) ;texmacs-module
+
+(tm-define (get-tabstop) (:mode in-prog-moonbit?) 2)
+
+(tm-define (kbd-paste)
+  (:mode in-prog-moonbit?)
+  (clipboard-paste-import "moonbit" "primary")
+) ;tm-define
diff --git a/TeXmacs/plugins/moonbit/progs/moonbit/moonbit-format.scm b/TeXmacs/plugins/moonbit/progs/moonbit/moonbit-format.scm
new file mode 100644
index 0000000000..a99d516150
--- /dev/null
+++ b/TeXmacs/plugins/moonbit/progs/moonbit/moonbit-format.scm
@@ -0,0 +1,40 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : init-prog_moonbit.scm
+;; DESCRIPTION : prog format for Moonbit
+;; COPYRIGHT   : (C) 2025  (Jack) Yansong Li
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (moonbit moonbit-format))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Moonbit source files
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-format moonbit (:name "Moonbit source code") (:suffix "moonbit" "mbt"))
+
+(define (texmacs->moonbit x . opts)
+  (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '()))
+) ;define
+
+(define (moonbit->texmacs x . opts)
+  (code->texmacs x)
+) ;define
+
+(define (moonbit-snippet->texmacs x . opts)
+  (code-snippet->texmacs x)
+) ;define
+
+(converter texmacs-tree moonbit-document (:function texmacs->moonbit))
+
+(converter moonbit-document texmacs-tree (:function moonbit->texmacs))
+
+(converter texmacs-tree moonbit-snippet (:function texmacs->moonbit))
+
+(converter moonbit-snippet texmacs-tree (:function moonbit-snippet->texmacs))
diff --git a/TeXmacs/plugins/moonbit/progs/moonbit/moonbit-lang.scm b/TeXmacs/plugins/moonbit/progs/moonbit/moonbit-lang.scm
new file mode 100644
index 0000000000..f88d80a871
--- /dev/null
+++ b/TeXmacs/plugins/moonbit/progs/moonbit/moonbit-lang.scm
@@ -0,0 +1,137 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : moonbit-lang.scm
+;; DESCRIPTION : Moonbit Language
+;; COPYRIGHT   : (C) 2025 (Jack) Yansong Li
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (moonbit moonbit-lang) (:use (prog default-lang)))
+
+;; https://docs.moonbitlang.cn/language/introduction.html
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "moonbit") (== key "keyword")))
+  `(,(string->symbol key)
+    ;; Keywords based on the official MoonBit documentation.
+    (constant "true" "false" "_")
+    ;; Built-in Types and Type Definition Keywords
+    (declare_type ;; Keywords for defining new types
+      "type"
+      "struct"
+      "enum"
+      "trait"
+      "typealias"
+      "traitalias"
+      ;; Built-in primitive types
+      "Bool"
+      "Byte"
+      "Char"
+      "String"
+      "Int"
+      "Int64"
+      "UInt"
+      "UInt64"
+      "BigInt"
+      "Float"
+      "Double"
+      "Float64"
+      "Unit"
+      ;; Core functional types
+      "Option"
+      "Result"
+      ;; Collection types
+      "Array"
+      "List"
+      "Map"
+      "Set"
+      "StringBuilder"
+      ;; Concurrency and state
+      "Ref")
+    ;; Declarations and Functions
+    (declare_function "fn" "let" "const")
+    ;; Control Flow & Expressions
+    (keyword_conditional "if" "else" "while" "loop" "for" "in" "match")
+    ;; Keywords for program structure and visibility
+    (declare_module "import" "pub")
+    ;; Other keywords from the official list
+    (keyword "as" "extern" "fnalias" "typealias" "traitalias" "mut" "derive"
+      "break" "continue" "return" "throw" "raise" "try" "catch" "with" "guard"
+      "async" "is" "suberror" "and" "letrec" "enumview" "noraise" "defer" "test"
+      "impl"))
+) ;tm-define
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "moonbit") (== key "operator")))
+  `(,(string->symbol key)
+    ;; Common operators in MoonBit
+    (operator "+"
+      "-"
+      "/"
+      "*"
+      "%"
+      ;; Arithmetic
+      "|"
+      "&"
+      "^"
+      "!"
+      ;; Bitwise and Logical NOT
+      "&&"
+      "||"
+      ;; Boolean
+      "=="
+      "!="
+      "<"
+      ">"
+      "<="
+      ">=")
+    ;; Comparison
+    (operator_assignment ;; Corrected assignment operators
+      "="
+      "+="
+      "-="
+      "*="
+      "/="
+      "%=")
+    (operator_special ;; Special operators and symbols used in MoonBit syntax
+      ":"
+      "->"
+      "|"
+      "."
+      "::"
+      "#")
+    (operator_openclose "{" "[" "(" ")" "]" "}"))
+) ;tm-define
+
+(define (moonbit-number-suffix)
+  ;; Suffixes for integer types in MoonBit
+  '(suffix (long "L")
+     ;; For Int64
+     (unsigned "U")
+     ;; For UInt
+     (unsigned_long "UL")
+     ;; For UInt64
+     (bigint "N"))
+) ;define
+;; For BigInt
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "moonbit") (== key "number")))
+  `(,(string->symbol key)
+    ;; MoonBit supports hex, binary, and octal prefixes, as well as scientific notation.
+    (bool_features "prefix_0x" "prefix_0b" "prefix_0o" "sci_notation")
+    ,(moonbit-number-suffix))
+) ;tm-define
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "moonbit") (== key "string")))
+  `(,(string->symbol key)
+    (bool_features ;; MoonBit supports unicode escapes
+      "unicode_escape_braces")
+    ;; Standard C-style escape sequences
+    (escape_sequences "\\" "\"" "'" "b" "f" "n" "r" "t"))
+) ;tm-define
diff --git a/TeXmacs/plugins/moonbit/progs/moonbit/moonbit-mode.scm b/TeXmacs/plugins/moonbit/progs/moonbit/moonbit-mode.scm
new file mode 100644
index 0000000000..94a11ecb18
--- /dev/null
+++ b/TeXmacs/plugins/moonbit/progs/moonbit/moonbit-mode.scm
@@ -0,0 +1,18 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : moonbit-lang.scm
+;; DESCRIPTION : Moonbit Language mode
+;; COPYRIGHT   : (C) 2025  (Jack) Yansong Li
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (moonbit moonbit-mode) (:use (kernel texmacs tm-modes)))
+
+(texmacs-modes (in-moonbit% (== (get-env "prog-language") "moonbit"))
+  (in-prog-moonbit% #t in-prog% in-moonbit%)
+) ;texmacs-modes
diff --git a/TeXmacs/plugins/ocr/progs/liii/ocr.scm b/TeXmacs/plugins/ocr/progs/liii/ocr.scm
deleted file mode 100644
index 71fbb50d13..0000000000
--- a/TeXmacs/plugins/ocr/progs/liii/ocr.scm
+++ /dev/null
@@ -1,148 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : ocr.scm
-;; DESCRIPTION : ocr
-;; COPYRIGHT   : (C) 2025  Mogan STEM authors
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (liii ocr))
-(import (liii os))
-(import (liii base64))
-(import (liii time))
-(import (only (srfi srfi-19) current-time time-second))
-
-(define temp-dir (os-temp-dir))
-
-(define (get-image t i bool)
-  (if (tree-is? t 'image)
-    (get-image-tuple t 0 bool)
-    (let* ((cur-t (tree-ref t i)))
-      (cond ((not cur-t) #f)
-            ((tree-is? cur-t 'image) (get-image-tuple cur-t 0 bool))
-            (else (get-image t (+ i 1) bool))
-      ) ;cond
-    ) ;let*
-  ) ;if
-) ;define
-
-(define (get-image-tuple t i bool)
-  (if bool
-    (let* ((cur-t (tree-ref t i)))
-      (cond ((not cur-t) #f)
-            ((tree-is? cur-t 'tuple) (get-image-name cur-t 0))
-            (else (get-image-tuple t (+ i 1)))
-      ) ;cond
-    ) ;let*
-    (let* ((cur-t (tree-ref t i)))
-      (cond ((not cur-t) #f)
-            ((tree-is? cur-t 'tuple) (get-image-data cur-t 0))
-            (else (get-image-tuple t (+ i 1)))
-      ) ;cond
-    ) ;let*
-  ) ;if
-) ;define
-
-(define (get-image-name t i)
-  (let* ((cur-t (tree-ref t i)))
-    (cond ((not cur-t) #f)
-          ((not (string=? (tree->string cur-t) "")) (tree->string cur-t))
-          (else (get-image-name t (+ i 1)))
-    ) ;cond
-  ) ;let*
-) ;define
-
-(define (get-image-data t i)
-  (let* ((cur-t (tree-ref t i)))
-    (cond ((not cur-t) #f)
-          ((tree-is? cur-t 'raw-data) (cdr (tree->stree cur-t)))
-          (else (get-image-name t (+ i 1)))
-    ) ;cond
-  ) ;let*
-) ;define
-
-(define (get-image-extension name)
-  (let* ((parts (string-split name #\.)))
-    (if (> (length parts) 1) (last parts) name)
-  ) ;let*
-) ;define
-
-(define (insert-tips)
-  (go-to (cursor-path))
-  (go-to-next-node)
-  (kbd-return)
-  (let* ((content (string-load (unix->url "$TEXMACS_PATH/plugins/ocr/data/ocr.md"))))
-    (insert `(with ,"par-mode" ,"center" (document ,(utf8->cork content))))
-  ) ;let*
-) ;define
-
-(define (insert-latex-by-cursor)
-  (let* ((mode (get-env "mode"))
-         (latex-code (if (== mode "math")
-                       "E=m*c^2"
-                       ;; 数学模式下返回 E=m*c^2 的 LaTeX
-                       (string-load (unix->url "$TEXMACS_PATH/plugins/ocr/data/ocr.tex"))
-                     ) ;if
-         ) ;latex-code
-         (parsed-latex (parse-latex latex-code))
-         (texmacs-latex (latex->texmacs parsed-latex))
-        ) ;
-    (insert texmacs-latex)
-  ) ;let*
-) ;define
-
-
-(tm-define (ocr-to-latex-by-cursor t)
-  (let* ((extension (get-image-extension (get-image t 0 #t)))
-         (temp-name (string-append temp-dir
-                      "/temp-"
-                      (number->string (time-second (current-time)))
-                      "."
-                      extension
-                    ) ;string-append
-         ) ;temp-name
-         (data-list (get-image t 0 #f))
-        ) ;
-    (when (and (list? data-list) (not (null? data-list)))
-      (let* ((base64-str (car data-list)) (binary-data (decode-base64 base64-str)))
-        (string-save binary-data temp-name)
-        (display* "Image has saved to " temp-name "\n")
-      ) ;let*
-    ) ;when
-  ) ;let*
-  (insert-latex-by-cursor)
-) ;tm-define
-
-
-(define (insert-latex-by-image t)
-  (tree-go-to t :end)
-  (kbd-return)
-  (insert-latex-by-cursor)
-) ;define
-
-
-(tm-define (ocr-to-latex-by-image t)
-  (let* ((extention (get-image-extension (get-image t 0 #t)))
-         (temp-name (string-append temp-dir
-                      "/temp-"
-                      (number->string (time-second (current-time)))
-                      "."
-                      extention
-                    ) ;string-append
-         ) ;temp-name
-         (data-list (get-image t 0 #f))
-        ) ;
-    (when (and (list? data-list) (not (null? data-list)))
-      (let* ((base64-str (car data-list)) (binary-data (decode-base64 base64-str)))
-        (string-save binary-data temp-name)
-        (display* "Image has saved to " temp-name "\n")
-      ) ;let*
-    ) ;when
-  ) ;let*
-  (insert-latex-by-image t)
-) ;tm-define
diff --git a/TeXmacs/plugins/ocr/progs/ocr/liii-ocr.scm b/TeXmacs/plugins/ocr/progs/ocr/liii-ocr.scm
new file mode 100644
index 0000000000..6a23c190cc
--- /dev/null
+++ b/TeXmacs/plugins/ocr/progs/ocr/liii-ocr.scm
@@ -0,0 +1,147 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : ocr.scm
+;; DESCRIPTION : ocr
+;; COPYRIGHT   : (C) 2025  Mogan STEM authors
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (ocr liii-ocr))
+(import (liii base64))
+(import (liii time))
+(import (only (srfi srfi-19) current-time time-second))
+
+(define temp-dir (os-temp-dir))
+
+(define (get-image t i bool)
+  (if (tree-is? t 'image)
+    (get-image-tuple t 0 bool)
+    (let* ((cur-t (tree-ref t i)))
+      (cond ((not cur-t) #f)
+            ((tree-is? cur-t 'image) (get-image-tuple cur-t 0 bool))
+            (else (get-image t (+ i 1) bool))
+      ) ;cond
+    ) ;let*
+  ) ;if
+) ;define
+
+(define (get-image-tuple t i bool)
+  (if bool
+    (let* ((cur-t (tree-ref t i)))
+      (cond ((not cur-t) #f)
+            ((tree-is? cur-t 'tuple) (get-image-name cur-t 0))
+            (else (get-image-tuple t (+ i 1)))
+      ) ;cond
+    ) ;let*
+    (let* ((cur-t (tree-ref t i)))
+      (cond ((not cur-t) #f)
+            ((tree-is? cur-t 'tuple) (get-image-data cur-t 0))
+            (else (get-image-tuple t (+ i 1)))
+      ) ;cond
+    ) ;let*
+  ) ;if
+) ;define
+
+(define (get-image-name t i)
+  (let* ((cur-t (tree-ref t i)))
+    (cond ((not cur-t) #f)
+          ((not (string=? (tree->string cur-t) "")) (tree->string cur-t))
+          (else (get-image-name t (+ i 1)))
+    ) ;cond
+  ) ;let*
+) ;define
+
+(define (get-image-data t i)
+  (let* ((cur-t (tree-ref t i)))
+    (cond ((not cur-t) #f)
+          ((tree-is? cur-t 'raw-data) (cdr (tree->stree cur-t)))
+          (else (get-image-name t (+ i 1)))
+    ) ;cond
+  ) ;let*
+) ;define
+
+(define (get-image-extension name)
+  (let* ((parts (string-split name #\.)))
+    (if (> (length parts) 1) (last parts) name)
+  ) ;let*
+) ;define
+
+(define (insert-tips)
+  (go-to (cursor-path))
+  (go-to-next-node)
+  (kbd-return)
+  (let* ((content (string-load (unix->url "$TEXMACS_PATH/plugins/ocr/data/ocr.md"))))
+    (insert `(with ,"par-mode" ,"center" (document ,(utf8->cork content))))
+  ) ;let*
+) ;define
+
+(define (insert-latex-by-cursor)
+  (let* ((mode (get-env "mode"))
+         (latex-code (if (== mode "math")
+                       "E=m*c^2"
+                       ;; 数学模式下返回 E=m*c^2 的 LaTeX
+                       (string-load (unix->url "$TEXMACS_PATH/plugins/ocr/data/ocr.tex"))
+                     ) ;if
+         ) ;latex-code
+         (parsed-latex (parse-latex latex-code))
+         (texmacs-latex (latex->texmacs parsed-latex))
+        ) ;
+    (insert texmacs-latex)
+  ) ;let*
+) ;define
+
+
+(tm-define (ocr-to-latex-by-cursor t)
+  (let* ((extension (get-image-extension (get-image t 0 #t)))
+         (temp-name (string-append temp-dir
+                      "/temp-"
+                      (number->string (time-second (current-time)))
+                      "."
+                      extension
+                    ) ;string-append
+         ) ;temp-name
+         (data-list (get-image t 0 #f))
+        ) ;
+    (when (and (list? data-list) (not (null? data-list)))
+      (let* ((base64-str (car data-list)) (binary-data (decode-base64 base64-str)))
+        (string-save binary-data temp-name)
+        (display* "Image has saved to " temp-name "\n")
+      ) ;let*
+    ) ;when
+  ) ;let*
+  (insert-latex-by-cursor)
+) ;tm-define
+
+
+(define (insert-latex-by-image t)
+  (tree-go-to t :end)
+  (kbd-return)
+  (insert-latex-by-cursor)
+) ;define
+
+
+(tm-define (ocr-to-latex-by-image t)
+  (let* ((extention (get-image-extension (get-image t 0 #t)))
+         (temp-name (string-append temp-dir
+                      "/temp-"
+                      (number->string (time-second (current-time)))
+                      "."
+                      extention
+                    ) ;string-append
+         ) ;temp-name
+         (data-list (get-image t 0 #f))
+        ) ;
+    (when (and (list? data-list) (not (null? data-list)))
+      (let* ((base64-str (car data-list)) (binary-data (decode-base64 base64-str)))
+        (string-save binary-data temp-name)
+        (display* "Image has saved to " temp-name "\n")
+      ) ;let*
+    ) ;when
+  ) ;let*
+  (insert-latex-by-image t)
+) ;tm-define
diff --git a/TeXmacs/plugins/physics/packages/contrib/physics.stem b/TeXmacs/plugins/physics/packages/contrib/physics.stem
new file mode 100644
index 0000000000..c40576b957
--- /dev/null
+++ b/TeXmacs/plugins/physics/packages/contrib/physics.stem
@@ -0,0 +1,119 @@
+(document (TeXmacs "2.1.4")
+  (style (tuple "source" "std"))
+  (body (document (active* (src-title (document (src-package "physics" "1.1.0")
+                                        (src-purpose (document "This package contains macros for physics"))
+                                        (src-copyright "2026" "Darcy Shen and (Jack) Yansong Li")
+                                        (src-license (document (concat "This software falls under the "
+                                                                 (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE")
+                                                                 ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see "
+                                                                 (hlink "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                   "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                 ) ;hlink
+                                                                 "."
+                                                               ) ;concat
+                                                     ) ;document
+                                        ) ;src-license
+                                      ) ;document
+                           ) ;src-title
+                  ) ;active*
+          (use-module "(physics physics-drd)")
+          (active* (src-comment (document "Braket operators")))
+          (assign "bra" (macro "x" (around* "" (arg "x") "|")))
+          (assign "bra*" (macro "x" (concat "" (arg "x") "|")))
+          (assign "ket" (macro "x" (around* "|" (arg "x") "")))
+          (assign "ket*" (macro "x" (concat "|" (arg "x") "")))
+          (assign "braket"
+            (macro "var1"
+              "var2"
+              (around* "" (concat (arg "var1") (mid "|") (arg "var2")) "")
+            ) ;macro
+          ) ;assign
+          (assign "braket*"
+            (macro "var1"
+              "var2"
+              (concat "" (arg "var1") "|" (arg "var2") "")
+            ) ;macro
+          ) ;assign
+          (assign "comm"
+            (macro "var1" "var2" (around* "[" (concat (arg "var1") "," (arg "var2")) "]"))
+          ) ;assign
+          (assign "comm*"
+            (macro "var1" "var2" (concat "[" (arg "var1") "," (arg "var2") "]"))
+          ) ;assign
+          (assign "commutator"
+            (macro "var1" "var2" (around* "[" (concat (arg "var1") "," (arg "var2")) "]"))
+          ) ;assign
+          (assign "commutator*"
+            (macro "var1" "var2" (concat "[" (arg "var1") "," (arg "var2") "]"))
+          ) ;assign
+          (assign "acomm"
+            (macro "var1" "var2" (around* "{" (concat (arg "var1") "," (arg "var2")) "}"))
+          ) ;assign
+          (assign "acomm*"
+            (macro "var1" "var2" (concat "{" (arg "var1") "," (arg "var2") "}"))
+          ) ;assign
+          (assign "anticommutator"
+            (macro "var1" "var2" (around* "{" (concat (arg "var1") "," (arg "var2")) "}"))
+          ) ;assign
+          (assign "anticommutator*"
+            (macro "var1" "var2" (concat "{" (arg "var1") "," (arg "var2") "}"))
+          ) ;assign
+          (assign "mel"
+            (macro "var1"
+              "var2"
+              "var3"
+              (around* ""
+                (concat (arg "var1") (mid "|") (arg "var2") (mid "|") (arg "var3"))
+                ""
+              ) ;around*
+            ) ;macro
+          ) ;assign
+          (assign "mel*"
+            (macro "var1"
+              "var2"
+              "var3"
+              (concat "" (arg "var1") "|" (arg "var2") "|" (arg "var3") "")
+            ) ;macro
+          ) ;assign
+          ""
+          (active* (src-comment (document "vectors")))
+          (assign "vb" (macro "var" (with "font-series" "bold" (arg "var"))))
+          (assign "vb*" (macro "var" (with "font-series" "bold" (arg "var"))))
+          (assign "vu"
+            (macro "var"
+              (tabular (tformat (cwith "1" "1" "1" "1" "cell-halign" "c")
+                         (cwith "1" "1" "1" "1" "cell-tsep" "0sep")
+                         (cwith "1" "1" "1" "1" "cell-rsep" "0spc")
+                         (cwith "1" "1" "1" "1" "cell-lsep" "0spc")
+                         (cwith "1" "1" "1" "1" "cell-valign" "b")
+                         (cwith "1" "1" "1" "1" "cell-bsep" "-9sep")
+                         (cwith "2" "2" "1" "1" "cell-tsep" "0sep")
+                         (cwith "2" "2" "1" "1" "cell-valign" "b")
+                         (cwith "2" "2" "1" "1" "cell-bsep" "-2sep")
+                         (table (row (cell "^")) (row (cell (with "font-series" "bold" (arg "var")))))
+                       ) ;tformat
+              ) ;tabular
+            ) ;macro
+          ) ;assign
+          (assign "va"
+            (macro "var"
+              (tabular (tformat (cwith "1" "1" "1" "1" "cell-halign" "c")
+                         (cwith "1" "1" "1" "1" "cell-tsep" "0sep")
+                         (cwith "1" "1" "1" "1" "cell-rsep" "0spc")
+                         (cwith "1" "1" "1" "1" "cell-lsep" "0spc")
+                         (cwith "1" "1" "1" "1" "cell-valign" "b")
+                         (cwith "1" "1" "1" "1" "cell-bsep" "-9sep")
+                         (cwith "2" "2" "1" "1" "cell-tsep" "0sep")
+                         (cwith "2" "2" "1" "1" "cell-valign" "b")
+                         (cwith "2" "2" "1" "1" "cell-bsep" "-2sep")
+                         (table (row (cell ""))
+                           (row (cell (with "font-series" "bold" (arg "var"))))
+                         ) ;table
+                       ) ;tformat
+              ) ;tabular
+            ) ;macro
+          ) ;assign
+        ) ;document
+  ) ;body
+  (initial (collection))
+) ;document
diff --git a/TeXmacs/plugins/physics/packages/contrib/physics.ts b/TeXmacs/plugins/physics/packages/contrib/physics.ts
deleted file mode 100644
index 47f60d21fc..0000000000
--- a/TeXmacs/plugins/physics/packages/contrib/physics.ts
+++ /dev/null
@@ -1,77 +0,0 @@
-
-
->
-
-<\body>
-  
-    
-
-    <\src-purpose>
-      This package contains macros for physics
-    
-
-    
-
-    <\src-license>
-      This software falls under the . It comes WITHOUT ANY
-      WARRANTY WHATSOEVER. You should have received a copy of the license
-      which the software. If not, see .
-    
-  >
-
-  
-
-  
-    Braket operators
-  >
-
-  ||\|>>>
-
-  \|>>
-
-  |\>>>
-
-  \>>
-
-  ||\>>>
-
-  \|\>>
-
-  ,|]>>>
-
-  ,]>>
-
-  ,|]>>>
-
-  ,]>>
-
-  ,|}>>>
-
-  ,}>>
-
-  ,|}>>>
-
-  ,}>>
-
-  ||\>>>
-
-  \|\|\>>
-
-  \;
-
-  
-    vectors
-  >
-
-  >>>
-
-  >>>
-
-  |||||||||>|>>>>>>>>
-
-  |||||||||>>|>>>>>>>>
-
-
-
->
\ No newline at end of file
diff --git a/TeXmacs/plugins/physics/progs/contrib/physics/physics-drd.scm b/TeXmacs/plugins/physics/progs/contrib/physics/physics-drd.scm
deleted file mode 100644
index 198ec353e2..0000000000
--- a/TeXmacs/plugins/physics/progs/contrib/physics/physics-drd.scm
+++ /dev/null
@@ -1,8 +0,0 @@
-(texmacs-module (contrib physics physics-drd)
-  (:use (utils edit variants)))
-
-(define-group variant-tag (physics-dirac-tag))
-
-(define-group physics-dirac-tag
-  bra bra* ket ket*)
-
diff --git a/TeXmacs/plugins/physics/progs/physics/physics-drd.scm b/TeXmacs/plugins/physics/progs/physics/physics-drd.scm
new file mode 100644
index 0000000000..95fca778e6
--- /dev/null
+++ b/TeXmacs/plugins/physics/progs/physics/physics-drd.scm
@@ -0,0 +1,5 @@
+(texmacs-module (physics physics-drd) (:use (utils edit variants)))
+
+(define-group variant-tag (physics-dirac-tag))
+
+(define-group physics-dirac-tag bra bra* ket ket*)
diff --git a/TeXmacs/plugins/python/packages/code/python.stem b/TeXmacs/plugins/python/packages/code/python.stem
index 2ae2f8fe7f..98aba0b913 100644
--- a/TeXmacs/plugins/python/packages/code/python.stem
+++ b/TeXmacs/plugins/python/packages/code/python.stem
@@ -18,8 +18,8 @@
                                       ) ;document
                            ) ;src-title
                   ) ;active*
-          (use-module "(data python)")
-          (use-module "(code python-edit)")
+          (use-module "(python python-format)")
+          (use-module "(python python-edit)")
           (assign "python"
             (macro "body"
               (with "mode" "prog" "prog-language" "python" "font-family" "rm" (arg "body"))
diff --git a/TeXmacs/plugins/python/progs/code/python-edit.scm b/TeXmacs/plugins/python/progs/code/python-edit.scm
deleted file mode 100644
index 47052f6ed1..0000000000
--- a/TeXmacs/plugins/python/progs/code/python-edit.scm
+++ /dev/null
@@ -1,89 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : python-edit.scm
-;; DESCRIPTION : Editing python programs
-;; COPYRIGHT   : (C) 2014
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (code python-edit)
-  (:use (prog prog-edit)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Automatic indentation
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (string-strip-right s)
-  ;; 移除字符串末尾的空白字符
-  (with char-set:not-whitespace (char-set-complement char-set:whitespace)
-    (with n (string-length s)
-      (with r (or (string-rindex s char-set:not-whitespace) n)
-	(string-take s (min n (+ 1 r)))))))
-
-; FIXME: '#' in a string is interpreted as a comment
-(define (strip-comment-buggy s)
-  "Removes comment from python line."
-  (with i (string-index s #\#)
-    (if i (string-take s i) s)))
-
-(tm-define (program-compute-indentation doc row col)
-  (:mode in-prog-python?)
-  ;; 根据前一行计算当前行的缩进量
-  ;; 如果前一行以冒号(:)结尾，则增加一个制表位的缩进
-  (if (<= row 0) 0
-      (let* ((r (program-row (- row 1)))
-             (s (string-strip-right (strip-comment-buggy (if r r ""))))
-             (i (string-get-indent s))
-             (c (if (== s "") "" (string-take-right s 1))))
-        (if (== c ":") (+ i (get-tabstop)) i))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Automatic insertion, highlighting and selection of brackets and quotes
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (python-bracket-open lbr rbr)
-  ;; 插入一对括号或引号，并将光标定位在中间
-  (bracket-open lbr rbr "\\"))
-
-(tm-define (python-bracket-close lbr rbr)
-  ;; 处理闭合括号或引号，并正确放置光标位置
-  (bracket-close lbr rbr "\\"))
-
-; TODO: select strings first
-;(tm-define (kbd-select-enlarge)
-;  (:require prog-select-brackets?)
-;  (:mode in-prog-python?)
-;  (program-select-enlarge "(" ")"))
-
-(tm-define (notify-cursor-moved status)
-  (:require prog-highlight-brackets?)
-  (:mode in-prog-python?)
-  ;; 当光标移动时高亮匹配的括号
-  (select-brackets-after-movement "([{" ")]}" "\\"))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Copy and Paste
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (kbd-paste)
-  (:mode in-prog-python?)
-  ;; 使用Python特定格式粘贴剪贴板内容
-  (clipboard-paste-import "python" "primary"))
-
-(kbd-map
-  (:mode in-prog-python?)
-  ;; Python编程模式下的键盘快捷键
-  ("A-tab" (insert-tabstop))                 ;; Alt+Tab：插入制表符
-  ("cmd S-tab" (remove-tabstop))             ;; Cmd+Shift+Tab：移除制表符
-  ("{" (python-bracket-open "{" "}" ))       ;; 自动插入匹配的大括号
-  ("}" (python-bracket-close "{" "}" ))      ;; 处理闭合大括号
-  ("(" (python-bracket-open "(" ")" ))       ;; 自动插入匹配的小括号
-  (")" (python-bracket-close "(" ")" ))      ;; 处理闭合小括号
-  ("[" (python-bracket-open "[" "]" ))       ;; 自动插入匹配的方括号
-  ("]" (python-bracket-close "[" "]" ))      ;; 处理闭合方括号
-  ("\"" (python-bracket-open "\"" "\"" ))    ;; 自动插入匹配的双引号
-  ("'" (python-bracket-open "'" "'" )))      ;; 自动插入匹配的单引号
\ No newline at end of file
diff --git a/TeXmacs/plugins/python/progs/code/python-lang.scm b/TeXmacs/plugins/python/progs/code/python-lang.scm
deleted file mode 100644
index 8d1def5a84..0000000000
--- a/TeXmacs/plugins/python/progs/code/python-lang.scm
+++ /dev/null
@@ -1,133 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : python-lang.scm
-;; DESCRIPTION : Python Language
-;; COPYRIGHT   : (C) 2014-2020  François Poulain, Darcy Shen
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (code python-lang)
-  (:use (prog default-lang)))
-
-;; 定义解析器特性函数，用于获取Python语言的关键字定义
-;; 当语言为"python"且键为"keyword"时返回关键字分类
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "python") (== key "keyword")))
-  `(,(string->symbol key)
-    (extra_chars "_")  ;; 额外字符，关键字中允许包含下划线
-    (constant          ;; 常量关键字
-      "Ellipsis" "False" "None" "NotImplemented" "True" "__debug__" "__import__" "abs"
-      "all" "any" "apply" "ascii" "basestring" "bin" "bool" "buffer" "__main__"
-      "bytearray" "bytes" "callable" "chr" "classmethod" "cmp" "coerce" "compile"
-      "complex" "delattr" "dict" "dir" "divmod" "enumerate" "eval" "execfile"
-      "file" "filter" "float" "format" "frozenset" "getattr" "globals" "hasattr"
-      "hash" "help" "hex" "id" "input" "int" "intern" "isinstance"
-      "issubclass" "iter" "len" "list" "locals" "long" "map" "max"
-      "memoryview" "min" "next" "nonlocal" "object" "oct" "open" "ord"
-      "pow" "property" "range" "raw_input" "reduce" "reload" "repr" "reversed"
-      "round" "set" "setattr" "slice" "sorted" "staticmethod" "str" "sum"
-      "super" "tuple" "type" "unichr" "unicode" "vars" "xrange" "zip"
-      "BaseException" "Exception" "ArithmeticError" "EnvironmentError" "LookupError"
-      "StandardError" "AssertionError" "AttributeError" "BufferError" "EOFError"
-      "FloatingPointError" "GeneratorExit" "IOError" "ImportError" "IndentationError"
-      "IndexError" "KeyError" "KeyboardInterrupt" "MemoryError" "NameError"
-      "NotImplementedError" "OSError" "OverflowError" "ReferenceError" "RuntimeError"
-      "StopIteration" "SyntaxError" "SystemError" "SystemExit" "TabError"
-      "TypeError" "UnboundLocalError" "UnicodeError" "UnicodeDecodeError" "UnicodeEncodeError"
-      "UnicodeTranslateError" "ValueError" "VMSError" "WindowsError" "ZeroDivisionError"
-      "BytesWarning" "DeprecationWarning" "FutureWarning" "ImportWarning" "PendingDeprecationWarning"
-      "RuntimeWarning" "SyntaxWarning" "UnicodeWarning" "UserWarning" "Warning")
-    (declare_function "def" "lambda")     ;; 函数声明关键字
-    (declare_module "import")             ;; 模块声明关键字
-    (declare_type "class")                ;; 类型声明关键字
-    (keyword                              ;; 一般关键字
-      "and" "not" "or" "as" "del" "from" "global" "in" "is" "with")
-    (keyword_conditional                  ;; 条件语句关键字
-      "break" "continue" "elif" "else" "for" "if" "while")
-    (keyword_control                      ;; 控制流关键字
-      "assert" "except" "exec" "finally" "pass" "print" "raise" "return"
-      "try" "yield")))
-
-;; 定义解析器特性函数，用于获取Python语言的运算符定义
-;; 当语言为"python"且键为"operator"时返回运算符分类
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "python") (== key "operator")))
-  `(,(string->symbol key)
-    (operator         ;; 基本运算符
-      "+" "-" "/" "*" "**" "//" "%" "|" "&" "^"
-      "<<" ">>" "==" "!=" "<>" "<" ">" "<=" ">="
-      "=" "+=" "-=" "/=" "*=" "%=" "|=" "&=" "^="
-      "**=" "//=" "<<=" ">>="
-      "~")
-   (operator_special ":")        ;; 特殊运算符
-   (operator_decoration "@")     ;; 装饰器运算符
-   (operator_field ".")          ;; 字段访问运算符
-   (operator_openclose "{" "[" "(" ")" "]" "}")))  ;; 开闭运算符（括号）
-
-;; 定义Python数字后缀函数，用于处理虚数单位
-(define (python-number-suffix)
-  `(suffix
-    (imaginary "j" "J")))  ;; 虚数单位后缀
-
-;; https://docs.python.org/3.8/reference/lexical_analysis.html#numeric-literals
-;; 定义解析器特性函数，用于获取Python语言的数字字面量定义
-;; 当语言为"python"且键为"number"时返回数字格式定义
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "python") (== key "number")))
-  `(,(string->symbol key)
-   (bool_features     ;; 数字特性
-     "prefix_0x" "prefix_0b" "prefix_0o" "no_suffix_with_box"
-     "sci_notation")            ;; 支持十六进制、二进制、八进制前缀和科学计数法
-   ,(python-number-suffix)      ;; 包含数字后缀定义
-   (separator "_")))            ;; 数字分隔符
-
-;; 定义解析器特性函数，用于获取Python语言的字符串定义
-;; 当语言为"python"且键为"string"时返回字符串特性
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "python") (== key "string")))
-  `(,(string->symbol key)
-    (bool_features 
-     "hex_with_8_bits" "hex_with_16_bits"        ;; 支持8位和16位十六进制
-     "hex_with_32_bits" "octal_upto_3_digits")   ;; 支持32位十六进制和最多3位八进制
-    (escape_sequences "\\" "\"" "'" "a" "b" "f" "n" "r" "t" "v" "newline")))  ;; 转义序列
-
-;; 定义解析器特性函数，用于获取Python语言的注释定义
-;; 当语言为"python"且键为"comment"时返回注释格式
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "python") (== key "comment")))
-  `(,(string->symbol key)
-    (inline "#")))  ;; 行内注释，以#开头
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Preferences for syntax highlighting
-;; 语法高亮偏好设置
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; 通知Python语法更改的函数
-(define (notify-python-syntax var val)
-  (syntax-read-preferences "python"))
-
-;; 定义语法高亮颜色偏好设置
-(define-preferences
-  ("syntax:python:none" "#ff6b6b" notify-python-syntax)                   ;; 浅红色 (light red)
-  ("syntax:python:comment" "#d4a373" notify-python-syntax)                ;; 浅棕色 (light brown)
-  ("syntax:python:error" "#ff4d4d" notify-python-syntax)                  ;; 亮红色 (bright red)
-  ("syntax:python:constant" "#6a8cff" notify-python-syntax)               ;; 浅蓝色 (light blue)
-  ("syntax:python:constant_number" "#6a8cff" notify-python-syntax)        ;; 浅蓝色 (light blue)
-  ("syntax:python:constant_string" "#a9a9a9" notify-python-syntax)        ;; 浅灰色 (light grey)
-  ("syntax:python:constant_char" "#b0b0b0" notify-python-syntax)          ;; 浅灰色 (light grey)
-  ("syntax:python:declare_function" "#4d7eff" notify-python-syntax)       ;; 浅蓝色 (light blue)
-  ("syntax:python:declare_type" "#4d7eff" notify-python-syntax)           ;; 浅蓝色 (light blue)
-  ("syntax:python:declare_module" "#4d7eff" notify-python-syntax)         ;; 浅蓝色 (light blue)
-  ("syntax:python:operator" "#e066ff" notify-python-syntax)               ;; 浅洋红色 (light magenta)
-  ("syntax:python:operator_openclose" "#ff6666" notify-python-syntax)     ;; 浅红色 (light red)
-  ("syntax:python:operator_field" "#d1d1d1" notify-python-syntax)         ;; 浅灰色 (light grey)
-  ("syntax:python:operator_special" "#ffb347" notify-python-syntax)       ;; 浅橙色 (light orange)
-  ("syntax:python:keyword" "#4db8b8" notify-python-syntax)                ;; 浅青色 (light teal/cyan)
-  ("syntax:python:keyword_conditional" "#4db8b8" notify-python-syntax)    ;; 浅青色 (light teal/cyan)
-  ("syntax:python:keyword_control" "#4db8b8" notify-python-syntax))
\ No newline at end of file
diff --git a/TeXmacs/plugins/python/progs/data/python.scm b/TeXmacs/plugins/python/progs/data/python.scm
deleted file mode 100644
index 89e76b7098..0000000000
--- a/TeXmacs/plugins/python/progs/data/python.scm
+++ /dev/null
@@ -1,43 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : python.scm
-;; DESCRIPTION : prog format for Python
-;; COPYRIGHT   : (C) 2022  Darcy Shen, Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (data python))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; python source files
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define-format python
-  (:name "Python source code")
-  (:suffix "py" "pants"))
-  
-(define (texmacs->python x . opts)
-  (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '())))
-
-(define (python->texmacs x . opts)
-  (code->texmacs x))
-
-(define (python-snippet->texmacs x . opts)
-  (code-snippet->texmacs x))
-
-(converter texmacs-tree python-document
-  (:function texmacs->python))
-
-(converter python-document texmacs-tree
-  (:function python->texmacs))
-  
-(converter texmacs-tree python-snippet
-  (:function texmacs->python))
-
-(converter python-snippet texmacs-tree
-  (:function python-snippet->texmacs))
diff --git a/TeXmacs/plugins/python/progs/init-python.scm b/TeXmacs/plugins/python/progs/init-python.scm
index 6aa336ade3..0cf6e7c698 100644
--- a/TeXmacs/plugins/python/progs/init-python.scm
+++ b/TeXmacs/plugins/python/progs/init-python.scm
@@ -13,13 +13,9 @@
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(use-modules
-  (dynamic session-edit)
-  (dynamic program-edit)
-  (binary python3)
-  (binary conda))
+(use-modules (python python-binary) (binary conda))
 
-(lazy-format (data python) python)
+(lazy-format (python python-format) python)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Plugin configuration
@@ -33,70 +29,72 @@
 ;; from TeXmacs, but, at the time of this writing, it did not work.--A
 
 (define (python-serialize lan t)
-  (with u (pre-serialize lan t)
-    (with s (texmacs->utf8raw (stree->tree u))
-      (string-append  s  "\n\n"))))
+  (with u
+    (pre-serialize lan t)
+    (with s (texmacs->utf8raw (stree->tree u)) (string-append s "\n\n"))
+  ) ;with
+) ;define
 
 (define (python-utf8-command)
-  (string-append (url->system (find-binary-python3)) " -X utf8 "))
+  (string-append (url->system (find-binary-python3)) " -X utf8 ")
+) ;define
 
 (define (python-launcher)
   (if (url-exists? "$TEXMACS_HOME_PATH/plugins/python")
-      (string-append (python-utf8-command)
-       (string-quote
-        (url->string
-         (string->url
-          "$TEXMACS_HOME_PATH/plugins/python/bin/python.pex"))))
-      (string-append (python-utf8-command)
-       (string-quote
-        (url->string
-         (string->url
-          "$TEXMACS_PATH/plugins/python/bin/python.pex"))))))
+    (string-append (python-utf8-command)
+      (string-quote (url->string (string->url "$TEXMACS_HOME_PATH/plugins/python/bin/python.pex"))
+      ) ;string-quote
+    ) ;string-append
+    (string-append (python-utf8-command)
+      (string-quote (url->string (string->url "$TEXMACS_PATH/plugins/python/bin/python.pex"))
+      ) ;string-quote
+    ) ;string-append
+  ) ;if
+) ;define
 
 (define (conda-launcher path)
   (if (url-exists? "$TEXMACS_HOME_PATH/plugins/python")
-      (string-append
-       (url->system path)
-       " -X utf8 "
-       (string-quote
-        (url->string
-         (string->url
-          "$TEXMACS_HOME_PATH/plugins/python/bin/python.pex"))))
-      (string-append
-       (url->system path)
-       " -X utf8 "
-       (string-quote
-        (url->string
-         (string->url
-          "$TEXMACS_PATH/plugins/python/bin/python.pex"))))))
+    (string-append (url->system path)
+      " -X utf8 "
+      (string-quote (url->string (string->url "$TEXMACS_HOME_PATH/plugins/python/bin/python.pex"))
+      ) ;string-quote
+    ) ;string-append
+    (string-append (url->system path)
+      " -X utf8 "
+      (string-quote (url->string (string->url "$TEXMACS_PATH/plugins/python/bin/python.pex"))
+      ) ;string-quote
+    ) ;string-append
+  ) ;if
+) ;define
 
 (define (conda-launchers)
   (map (lambda (path)
          (list :launch
-               (string-append "conda_" (conda-env-name path)) (conda-launcher path)))
-       (conda-env-python-list)))
+           (string-append "conda_" (conda-env-name path))
+           (conda-launcher path)
+         ) ;list
+       ) ;lambda
+    (conda-env-python-list)
+  ) ;map
+) ;define
 
 (define (all-python-launchers)
   (let* ((launchers (conda-launchers))
-         (default-launcher
-           (cond ((has-binary-python3?) (python-launcher))
-                 ((has-binary-conda?) (caddr (car launchers)))
-                 (else ""))))
-    (cons (list :launch default-launcher)
-          launchers)))
+         (default-launcher (cond ((has-binary-python3?) (python-launcher))
+                                 ((has-binary-conda?) (caddr (car launchers)))
+                                 (else "")
+                           ) ;cond
+         ) ;default-launcher
+        ) ;
+    (cons (list :launch default-launcher) launchers)
+  ) ;let*
+) ;define
 
 (plugin-configure python
-  (:require (or (has-binary-conda?)
-                (has-binary-python3?)))
+  (:require (or (has-binary-conda?) (has-binary-python3?)))
   ,@(all-python-launchers)
   (:tab-completion #t)
   (:serializer ,python-serialize)
   (:session "Python")
-  (:scripts "Python"))
-
-;(set-session-multiline-input "python" "default" #t)
-;(set-program-multiline-input "python" "default" #t)
-
-(when (supports-python?)
-  (import-from (python-menus)))
-
+  (:scripts "Python")
+) ;plugin-configure
diff --git a/TeXmacs/plugins/python/progs/python-menus.scm b/TeXmacs/plugins/python/progs/python-menus.scm
deleted file mode 100644
index 1a9b7c9a78..0000000000
--- a/TeXmacs/plugins/python/progs/python-menus.scm
+++ /dev/null
@@ -1,19 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : python-menus.scm
-;; DESCRIPTION : Menus for the python plugin
-;; COPYRIGHT   : (C) 2014  Miguel de Benito Delgado
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (python-menus)
-  (:use (kernel gui menu-define) (kernel gui menu-widget)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Toolbars and menus
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
diff --git a/TeXmacs/plugins/python/progs/python/python-binary.scm b/TeXmacs/plugins/python/progs/python/python-binary.scm
new file mode 100644
index 0000000000..073a26ceb7
--- /dev/null
+++ b/TeXmacs/plugins/python/progs/python/python-binary.scm
@@ -0,0 +1,32 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : python3.scm
+;; DESCRIPTION : python3 Binary plugin
+;; COPYRIGHT   : (C) 2024  Darcy Shen
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (python python-binary) (:use (binary common)))
+
+(define (python3-binary-candidates)
+  (cond ((os-macos?)
+         (list "/usr/bin/python3" "/opt/homebrew/bin/python3" "/usr/local/bin/python3")
+        ) ;
+        ((os-windows?) (list "$LOCALAPPDATA/Programs/Python/Python3*/python.exe"))
+        (else (list "/usr/bin/python3"))
+  ) ;cond
+) ;define
+
+(tm-define (find-binary-python3)
+  (:synopsis "Find the url to the python3 binary, return (url-none) if not found")
+  (find-binary (python3-binary-candidates) "python3")
+) ;tm-define
+
+(tm-define (has-binary-python3?) (not (url-none? (find-binary-python3))))
+
+(tm-define (version-binary-python3) (version-binary (find-binary-python3)))
diff --git a/TeXmacs/plugins/python/progs/python/python-edit.scm b/TeXmacs/plugins/python/progs/python/python-edit.scm
new file mode 100644
index 0000000000..a5c618f9da
--- /dev/null
+++ b/TeXmacs/plugins/python/progs/python/python-edit.scm
@@ -0,0 +1,108 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : python-edit.scm
+;; DESCRIPTION : Editing python programs
+;; COPYRIGHT   : (C) 2014
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (python python-edit) (:use (prog prog-edit)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Automatic indentation
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (string-strip-right s)
+  ;; 移除字符串末尾的空白字符
+  (with char-set:not-whitespace
+    (char-set-complement char-set:whitespace)
+    (with n
+      (string-length s)
+      (with r
+        (or (string-rindex s char-set:not-whitespace) n)
+        (string-take s (min n (+ 1 r)))
+      ) ;with
+    ) ;with
+  ) ;with
+) ;define
+
+(define (strip-comment-buggy s)
+  "Removes comment from python line."
+  (with i (string-index s #\#) (if i (string-take s i) s))
+) ;define
+
+(tm-define (program-compute-indentation doc row col)
+  (:mode in-prog-python?)
+  ;; 根据前一行计算当前行的缩进量
+  ;; 如果前一行以冒号(:)结尾，则增加一个制表位的缩进
+  (if (<= row 0)
+    0
+    (let* ((r (program-row (- row 1)))
+           (s (string-strip-right (strip-comment-buggy (if r r ""))))
+           (i (string-get-indent s))
+           (c (if (== s "") "" (string-take-right s 1)))
+          ) ;
+      (if (== c ":") (+ i (get-tabstop)) i)
+    ) ;let*
+  ) ;if
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Automatic insertion, highlighting and selection of brackets and quotes
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (python-bracket-open lbr rbr)
+  ;; 插入一对括号或引号，并将光标定位在中间
+  (bracket-open lbr rbr "\\")
+) ;tm-define
+
+(tm-define (python-bracket-close lbr rbr)
+  ;; 处理闭合括号或引号，并正确放置光标位置
+  (bracket-close lbr rbr "\\")
+) ;tm-define
+
+
+(tm-define (notify-cursor-moved status)
+  (:require prog-highlight-brackets?)
+  (:mode in-prog-python?)
+  ;; 当光标移动时高亮匹配的括号
+  (select-brackets-after-movement "([{" ")]}" "\\")
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Copy and Paste
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (kbd-paste)
+  (:mode in-prog-python?)
+  ;; 使用Python特定格式粘贴剪贴板内容
+  (clipboard-paste-import "python" "primary")
+) ;tm-define
+
+(kbd-map (:mode in-prog-python?)
+  ;; Python编程模式下的键盘快捷键
+  ("A-tab" (insert-tabstop))
+  ;; Alt+Tab：插入制表符
+  ("cmd S-tab" (remove-tabstop))
+  ;; Cmd+Shift+Tab：移除制表符
+  ("{" (python-bracket-open "{" "}"))
+  ;; 自动插入匹配的大括号
+  ("}" (python-bracket-close "{" "}"))
+  ;; 处理闭合大括号
+  ("(" (python-bracket-open "(" ")"))
+  ;; 自动插入匹配的小括号
+  (")" (python-bracket-close "(" ")"))
+  ;; 处理闭合小括号
+  ("[" (python-bracket-open "[" "]"))
+  ;; 自动插入匹配的方括号
+  ("]" (python-bracket-close "[" "]"))
+  ;; 处理闭合方括号
+  ("\"" (python-bracket-open "\"" "\""))
+  ;; 自动插入匹配的双引号
+  ("'" (python-bracket-open "'" "'"))
+) ;kbd-map
+;; 自动插入匹配的单引号
diff --git a/TeXmacs/plugins/python/progs/python/python-format.scm b/TeXmacs/plugins/python/progs/python/python-format.scm
new file mode 100644
index 0000000000..6b248fd6fe
--- /dev/null
+++ b/TeXmacs/plugins/python/progs/python/python-format.scm
@@ -0,0 +1,40 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : python.scm
+;; DESCRIPTION : prog format for Python
+;; COPYRIGHT   : (C) 2022  Darcy Shen, Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (python python-format))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; python source files
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-format python (:name "Python source code") (:suffix "py" "pants"))
+
+(define (texmacs->python x . opts)
+  (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '()))
+) ;define
+
+(define (python->texmacs x . opts)
+  (code->texmacs x)
+) ;define
+
+(define (python-snippet->texmacs x . opts)
+  (code-snippet->texmacs x)
+) ;define
+
+(converter texmacs-tree python-document (:function texmacs->python))
+
+(converter python-document texmacs-tree (:function python->texmacs))
+
+(converter texmacs-tree python-snippet (:function texmacs->python))
+
+(converter python-snippet texmacs-tree (:function python-snippet->texmacs))
diff --git a/TeXmacs/plugins/python/progs/python/python-lang.scm b/TeXmacs/plugins/python/progs/python/python-lang.scm
new file mode 100644
index 0000000000..231e0b27eb
--- /dev/null
+++ b/TeXmacs/plugins/python/progs/python/python-lang.scm
@@ -0,0 +1,344 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : python-lang.scm
+;; DESCRIPTION : Python Language
+;; COPYRIGHT   : (C) 2014-2020  François Poulain, Darcy Shen
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (python python-lang) (:use (prog default-lang)))
+
+;; 定义解析器特性函数，用于获取Python语言的关键字定义
+;; 当语言为"python"且键为"keyword"时返回关键字分类
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "python") (== key "keyword")))
+  `(,(string->symbol key)
+    (extra_chars "_")
+    ;; 额外字符，关键字中允许包含下划线
+    (constant ;; 常量关键字
+      "Ellipsis"
+      "False"
+      "None"
+      "NotImplemented"
+      "True"
+      "__debug__"
+      "__import__"
+      "abs"
+      "all"
+      "any"
+      "apply"
+      "ascii"
+      "basestring"
+      "bin"
+      "bool"
+      "buffer"
+      "__main__"
+      "bytearray"
+      "bytes"
+      "callable"
+      "chr"
+      "classmethod"
+      "cmp"
+      "coerce"
+      "compile"
+      "complex"
+      "delattr"
+      "dict"
+      "dir"
+      "divmod"
+      "enumerate"
+      "eval"
+      "execfile"
+      "file"
+      "filter"
+      "float"
+      "format"
+      "frozenset"
+      "getattr"
+      "globals"
+      "hasattr"
+      "hash"
+      "help"
+      "hex"
+      "id"
+      "input"
+      "int"
+      "intern"
+      "isinstance"
+      "issubclass"
+      "iter"
+      "len"
+      "list"
+      "locals"
+      "long"
+      "map"
+      "max"
+      "memoryview"
+      "min"
+      "next"
+      "nonlocal"
+      "object"
+      "oct"
+      "open"
+      "ord"
+      "pow"
+      "property"
+      "range"
+      "raw_input"
+      "reduce"
+      "reload"
+      "repr"
+      "reversed"
+      "round"
+      "set"
+      "setattr"
+      "slice"
+      "sorted"
+      "staticmethod"
+      "str"
+      "sum"
+      "super"
+      "tuple"
+      "type"
+      "unichr"
+      "unicode"
+      "vars"
+      "xrange"
+      "zip"
+      "BaseException"
+      "Exception"
+      "ArithmeticError"
+      "EnvironmentError"
+      "LookupError"
+      "StandardError"
+      "AssertionError"
+      "AttributeError"
+      "BufferError"
+      "EOFError"
+      "FloatingPointError"
+      "GeneratorExit"
+      "IOError"
+      "ImportError"
+      "IndentationError"
+      "IndexError"
+      "KeyError"
+      "KeyboardInterrupt"
+      "MemoryError"
+      "NameError"
+      "NotImplementedError"
+      "OSError"
+      "OverflowError"
+      "ReferenceError"
+      "RuntimeError"
+      "StopIteration"
+      "SyntaxError"
+      "SystemError"
+      "SystemExit"
+      "TabError"
+      "TypeError"
+      "UnboundLocalError"
+      "UnicodeError"
+      "UnicodeDecodeError"
+      "UnicodeEncodeError"
+      "UnicodeTranslateError"
+      "ValueError"
+      "VMSError"
+      "WindowsError"
+      "ZeroDivisionError"
+      "BytesWarning"
+      "DeprecationWarning"
+      "FutureWarning"
+      "ImportWarning"
+      "PendingDeprecationWarning"
+      "RuntimeWarning"
+      "SyntaxWarning"
+      "UnicodeWarning"
+      "UserWarning"
+      "Warning")
+    (declare_function "def" "lambda")
+    ;; 函数声明关键字
+    (declare_module "import")
+    ;; 模块声明关键字
+    (declare_type "class")
+    ;; 类型声明关键字
+    (keyword ;; 一般关键字
+      "and"
+      "not"
+      "or"
+      "as"
+      "del"
+      "from"
+      "global"
+      "in"
+      "is"
+      "with")
+    (keyword_conditional ;; 条件语句关键字
+      "break"
+      "continue"
+      "elif"
+      "else"
+      "for"
+      "if"
+      "while")
+    (keyword_control ;; 控制流关键字
+      "assert"
+      "except"
+      "exec"
+      "finally"
+      "pass"
+      "print"
+      "raise"
+      "return"
+      "try"
+      "yield"))
+) ;tm-define
+
+;; 定义解析器特性函数，用于获取Python语言的运算符定义
+;; 当语言为"python"且键为"operator"时返回运算符分类
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "python") (== key "operator")))
+  `(,(string->symbol key)
+    (operator ;; 基本运算符
+      "+"
+      "-"
+      "/"
+      "*"
+      "**"
+      "//"
+      "%"
+      "|"
+      "&"
+      "^"
+      "<<"
+      ">>"
+      "=="
+      "!="
+      "<>"
+      "<"
+      ">"
+      "<="
+      ">="
+      "="
+      "+="
+      "-="
+      "/="
+      "*="
+      "%="
+      "|="
+      "&="
+      "^="
+      "**="
+      "//="
+      "<<="
+      ">>="
+      "~")
+    (operator_special ":")
+    ;; 特殊运算符
+    (operator_decoration "@")
+    ;; 装饰器运算符
+    (operator_field ".")
+    ;; 字段访问运算符
+    (operator_openclose "{" "[" "(" ")" "]" "}"))
+) ;tm-define
+;; 开闭运算符（括号）
+
+;; 定义Python数字后缀函数，用于处理虚数单位
+
+(define (python-number-suffix)
+  '(suffix (imaginary "j" "J"))
+) ;define
+;; 虚数单位后缀
+
+;; https://docs.python.org/3.8/reference/lexical_analysis.html#numeric-literals
+;; 定义解析器特性函数，用于获取Python语言的数字字面量定义
+;; 当语言为"python"且键为"number"时返回数字格式定义
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "python") (== key "number")))
+  `(,(string->symbol key)
+    (bool_features ;; 数字特性
+      "prefix_0x"
+      "prefix_0b"
+      "prefix_0o"
+      "no_suffix_with_box"
+      "sci_notation")
+    ;; 支持十六进制、二进制、八进制前缀和科学计数法
+    ,(python-number-suffix)
+    ;; 包含数字后缀定义
+    (separator "_"))
+) ;tm-define
+;; 数字分隔符
+
+;; 定义解析器特性函数，用于获取Python语言的字符串定义
+;; 当语言为"python"且键为"string"时返回字符串特性
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "python") (== key "string")))
+  `(,(string->symbol key)
+    (bool_features "hex_with_8_bits"
+      "hex_with_16_bits"
+      ;; 支持8位和16位十六进制
+      "hex_with_32_bits"
+      "octal_upto_3_digits")
+    ;; 支持32位十六进制和最多3位八进制
+    (escape_sequences "\\" "\"" "'" "a" "b" "f" "n" "r" "t" "v" "newline"))
+) ;tm-define
+;; 转义序列
+
+;; 定义解析器特性函数，用于获取Python语言的注释定义
+;; 当语言为"python"且键为"comment"时返回注释格式
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "python") (== key "comment")))
+  `(,(string->symbol key) (inline "#"))
+) ;tm-define
+;; 行内注释，以#开头
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Preferences for syntax highlighting
+;; 语法高亮偏好设置
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; 通知Python语法更改的函数
+
+(define (notify-python-syntax var val)
+  (syntax-read-preferences "python")
+) ;define
+
+;; 定义语法高亮颜色偏好设置
+(define-preferences ("syntax:python:none" "#ff6b6b" notify-python-syntax)
+  ;; 浅红色 (light red)
+  ("syntax:python:comment" "#d4a373" notify-python-syntax)
+  ;; 浅棕色 (light brown)
+  ("syntax:python:error" "#ff4d4d" notify-python-syntax)
+  ;; 亮红色 (bright red)
+  ("syntax:python:constant" "#6a8cff" notify-python-syntax)
+  ;; 浅蓝色 (light blue)
+  ("syntax:python:constant_number" "#6a8cff" notify-python-syntax)
+  ;; 浅蓝色 (light blue)
+  ("syntax:python:constant_string" "#a9a9a9" notify-python-syntax)
+  ;; 浅灰色 (light grey)
+  ("syntax:python:constant_char" "#b0b0b0" notify-python-syntax)
+  ;; 浅灰色 (light grey)
+  ("syntax:python:declare_function" "#4d7eff" notify-python-syntax)
+  ;; 浅蓝色 (light blue)
+  ("syntax:python:declare_type" "#4d7eff" notify-python-syntax)
+  ;; 浅蓝色 (light blue)
+  ("syntax:python:declare_module" "#4d7eff" notify-python-syntax)
+  ;; 浅蓝色 (light blue)
+  ("syntax:python:operator" "#e066ff" notify-python-syntax)
+  ;; 浅洋红色 (light magenta)
+  ("syntax:python:operator_openclose" "#ff6666" notify-python-syntax)
+  ;; 浅红色 (light red)
+  ("syntax:python:operator_field" "#d1d1d1" notify-python-syntax)
+  ;; 浅灰色 (light grey)
+  ("syntax:python:operator_special" "#ffb347" notify-python-syntax)
+  ;; 浅橙色 (light orange)
+  ("syntax:python:keyword" "#4db8b8" notify-python-syntax)
+  ;; 浅青色 (light teal/cyan)
+  ("syntax:python:keyword_conditional" "#4db8b8" notify-python-syntax)
+  ;; 浅青色 (light teal/cyan)
+  ("syntax:python:keyword_control" "#4db8b8" notify-python-syntax)
+) ;define-preferences
diff --git a/TeXmacs/plugins/quiver/progs/init-quiver.scm b/TeXmacs/plugins/quiver/progs/init-quiver.scm
index 3ef2db3b9a..2c47606379 100644
--- a/TeXmacs/plugins/quiver/progs/init-quiver.scm
+++ b/TeXmacs/plugins/quiver/progs/init-quiver.scm
@@ -10,46 +10,35 @@
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(define-library (session quiver)
-  (import (scheme base) (liii list))
-  (export init-quiver)
-  (begin
-    (use-modules (binary pdflatex) (binary goldfish))
+(use-modules (binary pdflatex) (binary goldfish))
 
-    (define (quiver-serialize lan t)
-      (let* ((u (pre-serialize lan t))
-             (s (texmacs->utf8raw (stree->tree u))))
-        (string-append s "\n\n")
-      )
-    )
+(define (quiver-serialize lan t)
+  (let* ((u (pre-serialize lan t)) (s (texmacs->utf8raw (stree->tree u))))
+    (string-append s "\n\n")
+  ) ;let*
+) ;define
 
-    (define (quiver-launcher)
-      (string-append
-        (string-quote (url->system (find-binary-goldfish)))
-        " "
-        "load"
-        " "
-        (string-quote
-          (string-append (url->system (get-texmacs-path))
-            "/plugins/quiver/goldfish/tm-quiver.scm"
-          )
-        )
-        " "
-        (string-quote (url->system (find-binary-pdflatex)))
-      )
-    )
+(define (quiver-launcher)
+  (string-append (string-quote (url->system (find-binary-goldfish)))
+    " "
+    "load"
+    " "
+    (string-quote (string-append (url->system (get-texmacs-path))
+                    "/plugins/quiver/goldfish/tm-quiver.scm"
+                  ) ;string-append
+    ) ;string-quote
+    " "
+    (string-quote (url->system (find-binary-pdflatex)))
+  ) ;string-append
+) ;define
 
-    (define (init-quiver)
-      (plugin-configure quiver
-        (:require (and (has-binary-goldfish?)
-                       (has-binary-pdflatex?)))
-        (:launch ,(quiver-launcher))
-        (:serializer ,quiver-serialize)
-        (:session "Quiver")
-      )
-    )
-  )
-)
+(define (init-quiver)
+  (plugin-configure quiver
+    (:require (and (has-binary-goldfish?) (has-binary-pdflatex?)))
+    (:launch ,(quiver-launcher))
+    (:serializer ,quiver-serialize)
+    (:session "Quiver")
+  ) ;plugin-configure
+) ;define
 
-(import (session quiver))
 (init-quiver)
diff --git a/TeXmacs/plugins/quiver/tests/tm-quiver-test.scm b/TeXmacs/plugins/quiver/tests/tm-quiver-test.scm
index 1b0adc31ef..2837288927 100644
--- a/TeXmacs/plugins/quiver/tests/tm-quiver-test.scm
+++ b/TeXmacs/plugins/quiver/tests/tm-quiver-test.scm
@@ -10,260 +10,222 @@
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(import (scheme base)
-  (liii check)
-  (liii string)
-  (liii list)
-  (liii path)
-)
+(import (scheme base) (liii check) (liii string) (liii list) (liii path))
 
-; Simulate the wrap-quiver-code logic from tm-quiver.scm
 (define (string-trim-both s)
-  (string-trim-right (string-trim s)))
+  (string-trim-right (string-trim s))
+) ;define
 
 (define (strip-math-delimiters str)
-  (let* ((s (string-trim-both str))
-         (len (string-length s)))
-    (cond ((and (>= len 4)
-                (string-starts? s "\\[")
-                (string-ends? s "\\]"))
-           (strip-math-delimiters (substring s 2 (- len 2))))
-          ((and (>= len 4)
-                (string-starts? s "$$")
-                (string-ends? s "$$"))
-           (strip-math-delimiters (substring s 2 (- len 2))))
-          ((and (>= len 2)
-                (string-starts? s "$")
-                (string-ends? s "$"))
-           (strip-math-delimiters (substring s 1 (- len 1))))
+  (let* ((s (string-trim-both str)) (len (string-length s)))
+    (cond ((and (>= len 4) (string-starts? s "\\[") (string-ends? s "\\]"))
+           (strip-math-delimiters (substring s 2 (- len 2)))
+          ) ;
+          ((and (>= len 4) (string-starts? s "$$") (string-ends? s "$$"))
+           (strip-math-delimiters (substring s 2 (- len 2)))
+          ) ;
+          ((and (>= len 2) (string-starts? s "$") (string-ends? s "$"))
+           (strip-math-delimiters (substring s 1 (- len 1)))
+          ) ;
           ((and (>= len 32)
-                (string-starts? s "\\begin{equation*}")
-                (string-ends? s "\\end{equation*}"))
-           (strip-math-delimiters (substring s 17 (- len 15))))
+             (string-starts? s "\\begin{equation*}")
+             (string-ends? s "\\end{equation*}")
+           ) ;and
+           (strip-math-delimiters (substring s 17 (- len 15)))
+          ) ;
           ((and (>= len 30)
-                (string-starts? s "\\begin{equation}")
-                (string-ends? s "\\end{equation}"))
-           (strip-math-delimiters (substring s 16 (- len 14))))
+             (string-starts? s "\\begin{equation}")
+             (string-ends? s "\\end{equation}")
+           ) ;and
+           (strip-math-delimiters (substring s 16 (- len 14)))
+          ) ;
           ((and (>= len 36)
-                (string-starts? s "\\begin{displaymath}")
-                (string-ends? s "\\end{displaymath}"))
-           (strip-math-delimiters (substring s 19 (- len 17))))
-          (else s))))
+             (string-starts? s "\\begin{displaymath}")
+             (string-ends? s "\\end{displaymath}")
+           ) ;and
+           (strip-math-delimiters (substring s 19 (- len 17)))
+          ) ;
+          (else s)
+    ) ;cond
+  ) ;let*
+) ;define
 
 (define (wrap-quiver-code raw-code)
-  (let* ((code (strip-math-delimiters raw-code))
-         (trimmed (string-trim-left code)))
+  (let* ((code (strip-math-delimiters raw-code)) (trimmed (string-trim-left code)))
     (if (string-starts? trimmed "\\documentclass")
-        code
-        (let* ((lines (string-split code #\newline))
-               (library-lines
-                 (filter (lambda (line)
-                           (string-starts? (string-trim-left line) "\\usetikzlibrary"))
-                         lines))
-               (package-lines
-                 (filter (lambda (line)
-                           (string-starts? (string-trim-left line) "\\usepackage"))
-                         lines))
-               (other-lines
-                 (filter (lambda (line)
-                           (let ((trimmed-line (string-trim-left line)))
-                             (and (not (string-null? trimmed-line))
-                                  (not (string-starts? trimmed-line "\\usetikzlibrary"))
-                                  (not (string-starts? trimmed-line "\\usepackage")))))
-                         lines))
-               (body (string-join other-lines "\n"))
-               (body-trimmed (string-trim-left body)))
-          (let* ((has-tikzcd? (string-starts? body-trimmed "\\begin{tikzcd}"))
-                 (inner-code
-                   (if (or (string-null? body-trimmed)
-                           has-tikzcd?)
-                       body
-                       (string-append "\\begin{tikzcd}[nodes in empty cells]\n" body "\n\\end{tikzcd}"))))
-            (string-append
-              "\\documentclass[tikz]{standalone}\n"
-              "\\usepackage{tikz-cd}\n"
-              "\\usepackage{amssymb}\n"
-              "\\usetikzlibrary{calc}\n"
-              "\\usetikzlibrary{decorations.pathmorphing}\n"
-              "\\usetikzlibrary{spath3}\n"
-              "\n"
-              "\\tikzset{curve/.style={settings={#1},to path={(\\tikztostart)\n"
-              "    .. controls ($(\\tikztostart)!\\pv{pos}!(\\tikztotarget)!\\pv{height}!270:(\\tikztotarget)$)\n"
-              "    and ($(\\tikztostart)!1-\\pv{pos}!(\\tikztotarget)!\\pv{height}!270:(\\tikztotarget)$)\n"
-              "    .. (\\tikztostart)\\tikztonodes}},\n"
-              "    settings/.code={\\tikzset{quiver/.cd,#1}\n"
-              "        \\def\\pv##1{\\pgfkeysvalueof{/tikz/quiver/##1}}},\n"
-              "    quiver/.cd,pos/.initial=0.35,height/.initial=0}\n"
-              "\n"
-              "\\tikzset{between/.style n args={2}{/tikz/execute at end to={\n"
-              "    \\tikzset{spath/split at keep middle={current}{#1}{#2}}\n"
-              "}}}\n"
-              "\n"
-              "\\tikzset{tail reversed/.code={\\pgfsetarrowsstart{tikzcd to}}}\n"
-              "\\tikzset{2tail/.code={\\pgfsetarrowsstart{Implies[reversed]}}}\n"
-              "\\tikzset{2tail reversed/.code={\\pgfsetarrowsstart{Implies}}}\n"
-              "\\tikzset{no body/.style={/tikz/dash pattern=on 0 off 1mm}}\n"
-              "\n"
-              (if (null? package-lines) "" (string-append (string-join package-lines "\n") "\n"))
-              "\\begin{document}\n"
-              (if (null? library-lines) "" (string-append (string-join library-lines "\n") "\n"))
-              inner-code
-              "\n\\end{document}"))))))
+      code
+      (let* ((lines (string-split code #\newline))
+             (library-lines (filter (lambda (line) (string-starts? (string-trim-left line) "\\usetikzlibrary"))
+                              lines
+                            ) ;filter
+             ) ;library-lines
+             (package-lines (filter (lambda (line) (string-starts? (string-trim-left line) "\\usepackage"))
+                              lines
+                            ) ;filter
+             ) ;package-lines
+             (other-lines (filter (lambda (line)
+                                    (let ((trimmed-line (string-trim-left line)))
+                                      (and (not (string-null? trimmed-line))
+                                        (not (string-starts? trimmed-line "\\usetikzlibrary"))
+                                        (not (string-starts? trimmed-line "\\usepackage"))
+                                      ) ;and
+                                    ) ;let
+                                  ) ;lambda
+                            lines
+                          ) ;filter
+             ) ;other-lines
+             (body (string-join other-lines "\n"))
+             (body-trimmed (string-trim-left body))
+            ) ;
+        (let* ((has-tikzcd? (string-starts? body-trimmed "\\begin{tikzcd}"))
+               (inner-code (if (or (string-null? body-trimmed) has-tikzcd?)
+                             body
+                             (string-append "\\begin{tikzcd}[nodes in empty cells]\n" body "\n\\end{tikzcd}")
+                           ) ;if
+               ) ;inner-code
+              ) ;
+          (string-append "\\documentclass[tikz]{standalone}\n"
+            "\\usepackage{tikz-cd}\n"
+            "\\usepackage{amssymb}\n"
+            "\\usetikzlibrary{calc}\n"
+            "\\usetikzlibrary{decorations.pathmorphing}\n"
+            "\\usetikzlibrary{spath3}\n"
+            "\n"
+            "\\tikzset{curve/.style={settings={#1},to path={(\\tikztostart)\n"
+            "    .. controls ($(\\tikztostart)!\\pv{pos}!(\\tikztotarget)!\\pv{height}!270:(\\tikztotarget)$)\n"
+            "    and ($(\\tikztostart)!1-\\pv{pos}!(\\tikztotarget)!\\pv{height}!270:(\\tikztotarget)$)\n"
+            "    .. (\\tikztostart)\\tikztonodes}},\n"
+            "    settings/.code={\\tikzset{quiver/.cd,#1}\n"
+            "        \\def\\pv##1{\\pgfkeysvalueof{/tikz/quiver/##1}}},\n"
+            "    quiver/.cd,pos/.initial=0.35,height/.initial=0}\n"
+            "\n"
+            "\\tikzset{between/.style n args={2}{/tikz/execute at end to={\n"
+            "    \\tikzset{spath/split at keep middle={current}{#1}{#2}}\n"
+            "}}}\n"
+            "\n"
+            "\\tikzset{tail reversed/.code={\\pgfsetarrowsstart{tikzcd to}}}\n"
+            "\\tikzset{2tail/.code={\\pgfsetarrowsstart{Implies[reversed]}}}\n"
+            "\\tikzset{2tail reversed/.code={\\pgfsetarrowsstart{Implies}}}\n"
+            "\\tikzset{no body/.style={/tikz/dash pattern=on 0 off 1mm}}\n"
+            "\n"
+            (if (null? package-lines)
+              ""
+              (string-append (string-join package-lines "\n") "\n")
+            ) ;if
+            "\\begin{document}\n"
+            (if (null? library-lines)
+              ""
+              (string-append (string-join library-lines "\n") "\n")
+            ) ;if
+            inner-code
+            "\n\\end{document}"
+          ) ;string-append
+        ) ;let*
+      ) ;let*
+    ) ;if
+  ) ;let*
+) ;define
 
-(check
-  (wrap-quiver-code "\\documentclass{article}\n\\begin{document}\n\\end{document}")
+(check (wrap-quiver-code "\\documentclass{article}\n\\begin{document}\n\\end{document}"
+       ) ;wrap-quiver-code
   =>
   "\\documentclass{article}\n\\begin{document}\n\\end{document}"
-)
+) ;check
 
-(check
-  (wrap-quiver-code "A \\arrow[r] & B")
+(check (wrap-quiver-code "A \\arrow[r] & B")
   =>
-  (string-append
-    "\\documentclass[tikz]{standalone}\n"
-    "\\usepackage{tikz-cd}\n"
-    "\\usepackage{amssymb}\n"
-    "\\usetikzlibrary{calc}\n"
-    "\\usetikzlibrary{decorations.pathmorphing}\n"
-    "\\usetikzlibrary{spath3}\n"
-    "\n"
-    "\\tikzset{curve/.style={settings={#1},to path={(\\tikztostart)\n"
+  (string-append "\\documentclass[tikz]{standalone}\n" "\\usepackage{tikz-cd}\n"
+    "\\usepackage{amssymb}\n" "\\usetikzlibrary{calc}\n"
+    "\\usetikzlibrary{decorations.pathmorphing}\n" "\\usetikzlibrary{spath3}\n"
+    "\n" "\\tikzset{curve/.style={settings={#1},to path={(\\tikztostart)\n"
     "    .. controls ($(\\tikztostart)!\\pv{pos}!(\\tikztotarget)!\\pv{height}!270:(\\tikztotarget)$)\n"
     "    and ($(\\tikztostart)!1-\\pv{pos}!(\\tikztotarget)!\\pv{height}!270:(\\tikztotarget)$)\n"
     "    .. (\\tikztostart)\\tikztonodes}},\n"
     "    settings/.code={\\tikzset{quiver/.cd,#1}\n"
     "        \\def\\pv##1{\\pgfkeysvalueof{/tikz/quiver/##1}}},\n"
-    "    quiver/.cd,pos/.initial=0.35,height/.initial=0}\n"
-    "\n"
+    "    quiver/.cd,pos/.initial=0.35,height/.initial=0}\n" "\n"
     "\\tikzset{between/.style n args={2}{/tikz/execute at end to={\n"
-    "    \\tikzset{spath/split at keep middle={current}{#1}{#2}}\n"
-    "}}}\n"
-    "\n"
+    "    \\tikzset{spath/split at keep middle={current}{#1}{#2}}\n" "}}}\n" "\n"
     "\\tikzset{tail reversed/.code={\\pgfsetarrowsstart{tikzcd to}}}\n"
     "\\tikzset{2tail/.code={\\pgfsetarrowsstart{Implies[reversed]}}}\n"
     "\\tikzset{2tail reversed/.code={\\pgfsetarrowsstart{Implies}}}\n"
-    "\\tikzset{no body/.style={/tikz/dash pattern=on 0 off 1mm}}\n"
-    "\n"
-    "\\begin{document}\n"
-    "\\begin{tikzcd}[nodes in empty cells]\n"
-    "A \\arrow[r] & B\n"
-    "\\end{tikzcd}\n"
-    "\\end{document}"
-  )
-)
+    "\\tikzset{no body/.style={/tikz/dash pattern=on 0 off 1mm}}\n" "\n"
+    "\\begin{document}\n" "\\begin{tikzcd}[nodes in empty cells]\n"
+    "A \\arrow[r] & B\n" "\\end{tikzcd}\n" "\\end{document}"
+  ) ;string-append
+) ;check
 
-(check
-  (wrap-quiver-code "\\begin{tikzcd}\nA \\arrow[r] & B\n\\end{tikzcd}")
+(check (wrap-quiver-code "\\begin{tikzcd}\nA \\arrow[r] & B\n\\end{tikzcd}")
   =>
-  (string-append
-    "\\documentclass[tikz]{standalone}\n"
-    "\\usepackage{tikz-cd}\n"
-    "\\usepackage{amssymb}\n"
-    "\\usetikzlibrary{calc}\n"
-    "\\usetikzlibrary{decorations.pathmorphing}\n"
-    "\\usetikzlibrary{spath3}\n"
-    "\n"
-    "\\tikzset{curve/.style={settings={#1},to path={(\\tikztostart)\n"
+  (string-append "\\documentclass[tikz]{standalone}\n" "\\usepackage{tikz-cd}\n"
+    "\\usepackage{amssymb}\n" "\\usetikzlibrary{calc}\n"
+    "\\usetikzlibrary{decorations.pathmorphing}\n" "\\usetikzlibrary{spath3}\n"
+    "\n" "\\tikzset{curve/.style={settings={#1},to path={(\\tikztostart)\n"
     "    .. controls ($(\\tikztostart)!\\pv{pos}!(\\tikztotarget)!\\pv{height}!270:(\\tikztotarget)$)\n"
     "    and ($(\\tikztostart)!1-\\pv{pos}!(\\tikztotarget)!\\pv{height}!270:(\\tikztotarget)$)\n"
     "    .. (\\tikztostart)\\tikztonodes}},\n"
     "    settings/.code={\\tikzset{quiver/.cd,#1}\n"
     "        \\def\\pv##1{\\pgfkeysvalueof{/tikz/quiver/##1}}},\n"
-    "    quiver/.cd,pos/.initial=0.35,height/.initial=0}\n"
-    "\n"
+    "    quiver/.cd,pos/.initial=0.35,height/.initial=0}\n" "\n"
     "\\tikzset{between/.style n args={2}{/tikz/execute at end to={\n"
-    "    \\tikzset{spath/split at keep middle={current}{#1}{#2}}\n"
-    "}}}\n"
-    "\n"
+    "    \\tikzset{spath/split at keep middle={current}{#1}{#2}}\n" "}}}\n" "\n"
     "\\tikzset{tail reversed/.code={\\pgfsetarrowsstart{tikzcd to}}}\n"
     "\\tikzset{2tail/.code={\\pgfsetarrowsstart{Implies[reversed]}}}\n"
     "\\tikzset{2tail reversed/.code={\\pgfsetarrowsstart{Implies}}}\n"
-    "\\tikzset{no body/.style={/tikz/dash pattern=on 0 off 1mm}}\n"
-    "\n"
-    "\\begin{document}\n"
-    "\\begin{tikzcd}\n"
-    "A \\arrow[r] & B\n"
-    "\\end{tikzcd}\n"
-    "\\end{document}"
-  )
-)
+    "\\tikzset{no body/.style={/tikz/dash pattern=on 0 off 1mm}}\n" "\n"
+    "\\begin{document}\n" "\\begin{tikzcd}\n" "A \\arrow[r] & B\n"
+    "\\end{tikzcd}\n" "\\end{document}"
+  ) ;string-append
+) ;check
 
-(check
-  (wrap-quiver-code "\\[\\begin{tikzcd}\n&& \\bullet && \\bullet \\\\\n\\bullet && \\bullet\n\\arrow[from=1-3, to=2-1]\n\\arrow[from=2-3, to=1-5]\n\\end{tikzcd}\\]")
+(check (wrap-quiver-code "\\[\\begin{tikzcd}\n&& \\bullet && \\bullet \\\\\n\\bullet && \\bullet\n\\arrow[from=1-3, to=2-1]\n\\arrow[from=2-3, to=1-5]\n\\end{tikzcd}\\]"
+       ) ;wrap-quiver-code
   =>
-  (string-append
-    "\\documentclass[tikz]{standalone}\n"
-    "\\usepackage{tikz-cd}\n"
-    "\\usepackage{amssymb}\n"
-    "\\usetikzlibrary{calc}\n"
-    "\\usetikzlibrary{decorations.pathmorphing}\n"
-    "\\usetikzlibrary{spath3}\n"
-    "\n"
-    "\\tikzset{curve/.style={settings={#1},to path={(\\tikztostart)\n"
+  (string-append "\\documentclass[tikz]{standalone}\n" "\\usepackage{tikz-cd}\n"
+    "\\usepackage{amssymb}\n" "\\usetikzlibrary{calc}\n"
+    "\\usetikzlibrary{decorations.pathmorphing}\n" "\\usetikzlibrary{spath3}\n"
+    "\n" "\\tikzset{curve/.style={settings={#1},to path={(\\tikztostart)\n"
     "    .. controls ($(\\tikztostart)!\\pv{pos}!(\\tikztotarget)!\\pv{height}!270:(\\tikztotarget)$)\n"
     "    and ($(\\tikztostart)!1-\\pv{pos}!(\\tikztotarget)!\\pv{height}!270:(\\tikztotarget)$)\n"
     "    .. (\\tikztostart)\\tikztonodes}},\n"
     "    settings/.code={\\tikzset{quiver/.cd,#1}\n"
     "        \\def\\pv##1{\\pgfkeysvalueof{/tikz/quiver/##1}}},\n"
-    "    quiver/.cd,pos/.initial=0.35,height/.initial=0}\n"
-    "\n"
+    "    quiver/.cd,pos/.initial=0.35,height/.initial=0}\n" "\n"
     "\\tikzset{between/.style n args={2}{/tikz/execute at end to={\n"
-    "    \\tikzset{spath/split at keep middle={current}{#1}{#2}}\n"
-    "}}}\n"
-    "\n"
+    "    \\tikzset{spath/split at keep middle={current}{#1}{#2}}\n" "}}}\n" "\n"
     "\\tikzset{tail reversed/.code={\\pgfsetarrowsstart{tikzcd to}}}\n"
     "\\tikzset{2tail/.code={\\pgfsetarrowsstart{Implies[reversed]}}}\n"
     "\\tikzset{2tail reversed/.code={\\pgfsetarrowsstart{Implies}}}\n"
-    "\\tikzset{no body/.style={/tikz/dash pattern=on 0 off 1mm}}\n"
-    "\n"
-    "\\begin{document}\n"
-    "\\begin{tikzcd}\n"
-    "&& \\bullet && \\bullet \\\\\n"
-    "\\bullet && \\bullet\n"
-    "\\arrow[from=1-3, to=2-1]\n"
-    "\\arrow[from=2-3, to=1-5]\n"
-    "\\end{tikzcd}\n"
-    "\\end{document}"
-  )
-)
+    "\\tikzset{no body/.style={/tikz/dash pattern=on 0 off 1mm}}\n" "\n"
+    "\\begin{document}\n" "\\begin{tikzcd}\n" "&& \\bullet && \\bullet \\\\\n"
+    "\\bullet && \\bullet\n" "\\arrow[from=1-3, to=2-1]\n"
+    "\\arrow[from=2-3, to=1-5]\n" "\\end{tikzcd}\n" "\\end{document}"
+  ) ;string-append
+) ;check
 
-(check
-  (wrap-quiver-code "\\begin{equation*}\n\\begin{tikzcd}\n&& \\bullet && \\bullet \\\\\n\\bullet && \\bullet\n\\arrow[from=1-3, to=2-1]\n\\arrow[from=2-3, to=1-5]\n\\end{tikzcd}\n\\end{equation*}")
+(check (wrap-quiver-code "\\begin{equation*}\n\\begin{tikzcd}\n&& \\bullet && \\bullet \\\\\n\\bullet && \\bullet\n\\arrow[from=1-3, to=2-1]\n\\arrow[from=2-3, to=1-5]\n\\end{tikzcd}\n\\end{equation*}"
+       ) ;wrap-quiver-code
   =>
-  (string-append
-    "\\documentclass[tikz]{standalone}\n"
-    "\\usepackage{tikz-cd}\n"
-    "\\usepackage{amssymb}\n"
-    "\\usetikzlibrary{calc}\n"
-    "\\usetikzlibrary{decorations.pathmorphing}\n"
-    "\\usetikzlibrary{spath3}\n"
-    "\n"
-    "\\tikzset{curve/.style={settings={#1},to path={(\\tikztostart)\n"
+  (string-append "\\documentclass[tikz]{standalone}\n" "\\usepackage{tikz-cd}\n"
+    "\\usepackage{amssymb}\n" "\\usetikzlibrary{calc}\n"
+    "\\usetikzlibrary{decorations.pathmorphing}\n" "\\usetikzlibrary{spath3}\n"
+    "\n" "\\tikzset{curve/.style={settings={#1},to path={(\\tikztostart)\n"
     "    .. controls ($(\\tikztostart)!\\pv{pos}!(\\tikztotarget)!\\pv{height}!270:(\\tikztotarget)$)\n"
     "    and ($(\\tikztostart)!1-\\pv{pos}!(\\tikztotarget)!\\pv{height}!270:(\\tikztotarget)$)\n"
     "    .. (\\tikztostart)\\tikztonodes}},\n"
     "    settings/.code={\\tikzset{quiver/.cd,#1}\n"
     "        \\def\\pv##1{\\pgfkeysvalueof{/tikz/quiver/##1}}},\n"
-    "    quiver/.cd,pos/.initial=0.35,height/.initial=0}\n"
-    "\n"
+    "    quiver/.cd,pos/.initial=0.35,height/.initial=0}\n" "\n"
     "\\tikzset{between/.style n args={2}{/tikz/execute at end to={\n"
-    "    \\tikzset{spath/split at keep middle={current}{#1}{#2}}\n"
-    "}}}\n"
-    "\n"
+    "    \\tikzset{spath/split at keep middle={current}{#1}{#2}}\n" "}}}\n" "\n"
     "\\tikzset{tail reversed/.code={\\pgfsetarrowsstart{tikzcd to}}}\n"
     "\\tikzset{2tail/.code={\\pgfsetarrowsstart{Implies[reversed]}}}\n"
     "\\tikzset{2tail reversed/.code={\\pgfsetarrowsstart{Implies}}}\n"
-    "\\tikzset{no body/.style={/tikz/dash pattern=on 0 off 1mm}}\n"
-    "\n"
-    "\\begin{document}\n"
-    "\\begin{tikzcd}\n"
-    "&& \\bullet && \\bullet \\\\\n"
-    "\\bullet && \\bullet\n"
-    "\\arrow[from=1-3, to=2-1]\n"
-    "\\arrow[from=2-3, to=1-5]\n"
-    "\\end{tikzcd}\n"
-    "\\end{document}"
-  )
-)
+    "\\tikzset{no body/.style={/tikz/dash pattern=on 0 off 1mm}}\n" "\n"
+    "\\begin{document}\n" "\\begin{tikzcd}\n" "&& \\bullet && \\bullet \\\\\n"
+    "\\bullet && \\bullet\n" "\\arrow[from=1-3, to=2-1]\n"
+    "\\arrow[from=2-3, to=1-5]\n" "\\end{tikzcd}\n" "\\end{document}"
+  ) ;string-append
+) ;check
 
 (check-report "Quiver plugin unit tests")
diff --git a/TeXmacs/plugins/r/packages/code/r.stem b/TeXmacs/plugins/r/packages/code/r.stem
new file mode 100644
index 0000000000..28c25ec991
--- /dev/null
+++ b/TeXmacs/plugins/r/packages/code/r.stem
@@ -0,0 +1,20 @@
+(document (TeXmacs "2.1.4")
+  (style (tuple "source" "std"))
+  (body (document (active* (src-title (document (compound "src-package" "r" "1.0")
+                                        (src-purpose (document "r Language"))
+                                      ) ;document
+                           ) ;src-title
+                  ) ;active*
+          (concat (use-module "(r r-format)") " " (use-module "(r r-edit)"))
+          (assign "r"
+            (macro "body"
+              (with "mode" "prog" "prog-language" "r" "font-family" "rm" (arg "body"))
+            ) ;macro
+          ) ;assign
+          (assign "r-code"
+            (macro "body" (document (pseudo-code (document (r (arg "body"))))))
+          ) ;assign
+        ) ;document
+  ) ;body
+  (initial (collection (associate "preamble" "true") (associate "sfactor" "5")))
+) ;document
diff --git a/TeXmacs/plugins/r/packages/code/r.ts b/TeXmacs/plugins/r/packages/code/r.ts
deleted file mode 100644
index 8c90bcf586..0000000000
--- a/TeXmacs/plugins/r/packages/code/r.ts
+++ /dev/null
@@ -1,30 +0,0 @@
-
-
->
-
-<\body>
-  
-    
-
-    <\src-purpose>
-      r Language
-    
-  >
-
-   
-
-  >>>
-
-  
-    <\pseudo-code>
-      >
-    
-  >
-
-
-<\initial>
-  <\collection>
-    
-    
-  
-
\ No newline at end of file
diff --git a/TeXmacs/plugins/r/progs/code/r-edit.scm b/TeXmacs/plugins/r/progs/code/r-edit.scm
deleted file mode 100644
index 31766a6c4a..0000000000
--- a/TeXmacs/plugins/r/progs/code/r-edit.scm
+++ /dev/null
@@ -1,167 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; MODULE      : r-edit.scm
-;; DESCRIPTION : editing R programs
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (code r-edit)
-  (:use (prog prog-edit)
-        (code r-mode)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Indentation policy
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (r-tabstop) 2)
-
-(tm-define (get-tabstop)
-  (:mode in-prog-r?)
-  (r-tabstop))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Helpers (lightweight, line-based)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (r-string-prefix? s p)
-  (and (>= (string-length s) (string-length p))
-       (== (substring s 0 (string-length p)) p)))
-
-(define (r-trim-left s)
-  (let loop ((i 0) (n (string-length s)))
-    (if (or (>= i n)
-            (not (char-whitespace? (string-ref s i))))
-        (substring s i n)
-        (loop (+ i 1) n))))
-
-(define (r-trim-right s)
-  (let loop ((i (- (string-length s) 1)))
-    (if (< i 0) ""
-        (if (char-whitespace? (string-ref s i))
-            (loop (- i 1))
-            (substring s 0 (+ i 1))))))
-
-(define (r-trim s) (r-trim-right (r-trim-left s)))
-
-;; Continuation cues: pipe, common operators, trailing comma, %...% infix
-(define (r-line-continues? line)
-  (let* ((t (r-trim-right line))
-         (n (string-length t)))
-    (if (<= n 0) #f
-        (or
-          (r-string-prefix? (r-trim-left t) "|>")
-          (let ((ops '("+" "-" "*" "/" "^" "=" "<-" "<<-" "->" "->>" "&" "|" "&&" "||" ":" ",")))
-            (let loop ((xs ops))
-              (if (null? xs) #f
-                  (let* ((op (car xs))
-                         (m (string-length op)))
-                    (if (and (>= n m)
-                             (== (substring t (- n m) n) op))
-                        #t
-                        (loop (cdr xs)))))))
-          (and (>= n 2)
-               (== (string-ref t (- n 1)) #\%)
-               (let ((j (- n 2)))
-                 (let loop ((k j))
-                   (cond
-                     ((< k 0) #f)
-                     ((== (string-ref t k) #\%) #t)
-                     (else (loop (- k 1)))))))))))
-
-(define (r-line-starts-with-closing-brace? line)
-  (let ((t (r-trim-left line)))
-    (and (> (string-length t) 0)
-         (== (string-ref t 0) #\}))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Line access 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (r-get-line row)
-  (let ((s (program-row row)))
-    (if s s "")))
-
-(define (r-prev-nonempty-row row)
-  (let loop ((r (- row 1)))
-    (if (< r 0) -1
-        (let* ((line (r-get-line r))
-               (t (r-trim line)))
-          (if (== t "") (loop (- r 1)) r)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Indentation computation
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (r-indent-level-from-prev row)
-  (let* ((pr (r-prev-nonempty-row row)))
-    (if (< pr 0) 0
-        (let* ((pline   (r-get-line pr))
-               (trimmed (r-trim pline))
-               (base    (string-get-indent pline))
-               (tab     (get-tabstop))
-               (inc?
-                 (or
-                   (r-line-continues? pline)
-                   ;; previous line ends with "{"
-                   (and (> (string-length trimmed) 0)
-                        (== (string-ref trimmed (- (string-length trimmed) 1)) #\{)))))
-          (+ base (if inc? tab 0))))))
-
-(tm-define (program-compute-indentation doc row col)
-  (:mode in-prog-r?)
-  (let* ((tab  (get-tabstop))
-         (line (r-get-line row))
-         (base (r-indent-level-from-prev row)))
-    (if (r-line-starts-with-closing-brace? line)
-        (max 0 (- base tab))
-        base)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Commenting
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (program-comment-start)
-  (:mode in-prog-r?)
-  "#")
-
-(tm-define (program-toggle-comment)
-  (:mode in-prog-r?)
-  (prog-toggle-line-comment "#"))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Paste import hook
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (kbd-paste)
-  (:mode in-prog-r?)
-  (clipboard-paste-import "r" "primary"))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Brackets / quotes
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (r-bracket-open lbr rbr)
-  (bracket-open lbr rbr "\\"))
-
-(tm-define (r-bracket-close lbr rbr)
-  (bracket-close lbr rbr "\\"))
-
-(tm-define (notify-cursor-moved status)
-  (:require prog-highlight-brackets?)
-  (:mode in-prog-r?)
-  (select-brackets-after-movement "([{" ")]}" "\\"))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Keyboard mappings
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(kbd-map
-  (:mode in-prog-r?)
-  ("A-tab" (insert-tabstop))
-  ("cmd S-tab" (remove-tabstop))
-  ("{" (r-bracket-open "{" "}" ))
-  ("}" (r-bracket-close "{" "}" ))
-  ("(" (r-bracket-open "(" ")" ))
-  (")" (r-bracket-close "(" ")" ))
-  ("[" (r-bracket-open "[" "]" ))
-  ("]" (r-bracket-close "[" "]" ))
-  ("\"" (r-bracket-open "\"" "\"" ))
-  ("'" (r-bracket-open "'" "'" )))
diff --git a/TeXmacs/plugins/r/progs/code/r-lang.scm b/TeXmacs/plugins/r/progs/code/r-lang.scm
deleted file mode 100644
index fef537461a..0000000000
--- a/TeXmacs/plugins/r/progs/code/r-lang.scm
+++ /dev/null
@@ -1,106 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : r-lang.scm
-;; DESCRIPTION : R Language
-;; COPYRIGHT   : (C) 2026 Hongli Zha
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (code r-lang)
-  (:use (prog default-lang)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Parser Features
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; R关键字、函数、常量等
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "r") (== key "keyword")))
-  `(,(string->symbol key)
-    (extra_chars "_") 
-  ;; 变量/关键字可包含下划线
-    (constant ;; 常量
-      "NULL" "NA" "NaN" "Inf" "TRUE" "FALSE" "T" "F")
-    (declare_function ;; 内置函数
-      "abs" "sign" "sqrt" "ceiling" "floor" "trunc" "round"
-      "exp" "log" "log10" "log2" "cos" "sin" "tan" "acos" "asin" "atan"
-      "cosh" "sinh" "tanh" "gamma" "lgamma" "max" "min" "sum" "prod" "mean" "median" "var" "sd"
-      "range" "cumsum" "cumprod" "cummax" "cummin" "c" "seq" "rep" "length" "unique" "sort" "order" "rank"
-      "rev" "which" "any" "all" "is.na" "is.nan"
-      "paste" "paste0" "substr" "nchar" "sprintf" "grep" "grepl" "sub" "gsub" "strsplit" "toupper" "tolower" "trimws"
-      "list" "data.frame" "matrix" "array" "factor"
-      "function" "args" "body" "environment" "formals" "quote" "eval" "do.call" "match.call" "get" "assign" "exists"
-      "print" "cat" "read.table" "read.csv" "write.table" "write.csv" "scan" "readLines" "writeLines" "source"
-      "detach" "search" "ls"
-      "subset" "transform" "with" "within"
-      "system" "Sys.time" "Sys.Date" "version" "setwd" "getwd"
-      "sample" "set.seed" "duplicated")
-    (declare_type ;; 类型
-      "numeric" "integer" "logical" "character")
-    (declare_module ;; 包/模块
-      "library" "require" "attach" "detach")
-    (keyword ;; 基本关键字
-      "if" "else" "for" "while" "repeat" "break" "next" "in" "return" "...")
-    (keyword_control ;; 控制/异常关键字
-      "stop" "warning" "message" "switch" "try" "tryCatch")))
-
-;; 运算符
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "r") (== key "operator")))
-  `(,(string->symbol key)
-    (operator
-      "+" "-" "*" "/" "^" ":" "%%" "%/%" "<" ">" "<=" ">=" "==" "!=" "&" "&&" "|" "||" "!" "~" "$" "@")
-    (operator_special "::" ":::" "|>")
-    (operator_openclose "(" "[" "{" ")" "]" "}")
-    (operator_field "$" "@" "<-" "=" "<<-" "->" "->>")))
-
-;; 数字特性
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "r") (== key "number")))
-  `(,(string->symbol key)
-    (bool_features "decimal" "sci_notation" "prefix_0x") ; 支持 0x 十六进制
-    (separator "_")
-    (suffix
-      (integer "L" "l")  ; 整数后缀
-      (imag "i"))))       ; 复数后缀
-
-;; 字符串特性
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "r") (== key "string")))
-  `(,(string->symbol key)
-      (bool_features "single_quote" "double_quote" "multi_byte" "unicode_escape" "hex_escape")
-      (escape_sequences "\\" "\"" "'" "a" "b" "f" "n" "r" "t" "v" "newline" "x" "u" "U")))
-
-;; 注释格式
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "r") (== key "comment")))
-  `(,(string->symbol key)
-    (inline "#")))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Preferences for syntax highlighting
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (notify-r-syntax var val)
-  (syntax-read-preferences "r"))
-
-(define-preferences
-  ("syntax:r:none" "red" notify-r-syntax)
-  ("syntax:r:comment" "brown" notify-r-syntax)
-  ("syntax:r:error" "dark red" notify-r-syntax)
-  ("syntax:r:constant" "#4040c0" notify-r-syntax)
-  ("syntax:r:constant_number" "#4040c0" notify-r-syntax)
-  ("syntax:r:constant_string" "dark grey" notify-r-syntax)
-  ("syntax:r:constant_char" "#333333" notify-r-syntax)
-  ("syntax:r:declare_function" "#0000c0" notify-r-syntax)
-  ("syntax:r:declare_type" "#0000c0" notify-r-syntax)
-  ("syntax:r:operator" "#8b008b" notify-r-syntax)
-  ("syntax:r:operator_openclose" "#B02020" notify-r-syntax)
-  ("syntax:r:operator_field" "#B02020" notify-r-syntax)
-  ("syntax:r:operator_special" "orange" notify-r-syntax)
-  ("syntax:r:keyword" "#309090" notify-r-syntax)
-  ("syntax:r:keyword_control" "#309090" notify-r-syntax))
diff --git a/TeXmacs/plugins/r/progs/code/r-mode.scm b/TeXmacs/plugins/r/progs/code/r-mode.scm
deleted file mode 100644
index e1d70d3360..0000000000
--- a/TeXmacs/plugins/r/progs/code/r-mode.scm
+++ /dev/null
@@ -1,12 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; MODULE      : r-mode.scm
-;; DESCRIPTION : mode predicate for R programs
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-(texmacs-module (code r-mode)
-  (:use (kernel texmacs tm-modes)))
-
-(texmacs-modes
-  (in-r% (== (get-env "prog-language") "r"))
-  (in-prog-r% #t in-prog% in-r%))
\ No newline at end of file
diff --git a/TeXmacs/plugins/r/progs/data/r.scm b/TeXmacs/plugins/r/progs/data/r.scm
deleted file mode 100644
index 95c81687f2..0000000000
--- a/TeXmacs/plugins/r/progs/data/r.scm
+++ /dev/null
@@ -1,35 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; MODULE      : r.scm
-;; DESCRIPTION : R format definition (minimal)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (data r))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; R source files
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define-format r
-  (:name "R source code")
-  (:suffix "r" "R"))
-
-(define (texmacs->r x . opts)
-  (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '())))
-
-(define (r->texmacs x . opts)
-  (code->texmacs x))
-
-(define (r-snippet->texmacs x . opts)
-  (code-snippet->texmacs x))
-
-(converter texmacs-tree r-document
-  (:function texmacs->r))
-
-(converter r-document texmacs-tree
-  (:function r->texmacs))
-  
-(converter texmacs-tree r-snippet
-  (:function texmacs->r))
-
-(converter r-snippet texmacs-tree
-  (:function r-snippet->texmacs))
\ No newline at end of file
diff --git a/TeXmacs/plugins/r/progs/r/r-edit.scm b/TeXmacs/plugins/r/progs/r/r-edit.scm
new file mode 100644
index 0000000000..d160231f15
--- /dev/null
+++ b/TeXmacs/plugins/r/progs/r/r-edit.scm
@@ -0,0 +1,200 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; MODULE      : r-edit.scm
+;; DESCRIPTION : editing R programs
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (r r-edit) (:use (prog prog-edit) (r r-mode)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Indentation policy
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (r-tabstop) 2)
+
+(tm-define (get-tabstop) (:mode in-prog-r?) (r-tabstop))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Helpers (lightweight, line-based)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (r-string-prefix? s p)
+  (and (>= (string-length s) (string-length p))
+    (== (substring s 0 (string-length p)) p)
+  ) ;and
+) ;define
+
+(define (r-trim-left s)
+  (let loop
+    ((i 0) (n (string-length s)))
+    (if (or (>= i n) (not (char-whitespace? (string-ref s i))))
+      (substring s i n)
+      (loop (+ i 1) n)
+    ) ;if
+  ) ;let
+) ;define
+
+(define (r-trim-right s)
+  (let loop
+    ((i (- (string-length s) 1)))
+    (if (< i 0)
+      ""
+      (if (char-whitespace? (string-ref s i)) (loop (- i 1)) (substring s 0 (+ i 1)))
+    ) ;if
+  ) ;let
+) ;define
+
+(define (r-trim s)
+  (r-trim-right (r-trim-left s))
+) ;define
+
+;; Continuation cues: pipe, common operators, trailing comma, %...% infix
+
+(define (r-line-continues? line)
+  (let* ((t (r-trim-right line)) (n (string-length t)))
+    (if (<= n 0)
+      #f
+      (or (r-string-prefix? (r-trim-left t) "|>")
+        (let ((ops '("+" "-" "*" "/" "^" "=" "<-" "<<-" "->" "->>" "&" "|" "&&"
+                     "||" ":" ","))
+             ) ;
+          (let loop
+            ((xs ops))
+            (if (null? xs)
+              #f
+              (let* ((op (car xs)) (m (string-length op)))
+                (if (and (>= n m) (== (substring t (- n m) n) op)) #t (loop (cdr xs)))
+              ) ;let*
+            ) ;if
+          ) ;let
+        ) ;let
+        (and (>= n 2)
+          (== (string-ref t (- n 1)) #\%)
+          (let ((j (- n 2)))
+            (let loop
+              ((k j))
+              (cond ((< k 0) #f)
+                    ((== (string-ref t k) #\%) #t)
+                    (else (loop (- k 1)))
+              ) ;cond
+            ) ;let
+          ) ;let
+        ) ;and
+      ) ;or
+    ) ;if
+  ) ;let*
+) ;define
+
+(define (r-line-starts-with-closing-brace? line)
+  (let ((t (r-trim-left line)))
+    (and (> (string-length t) 0) (== (string-ref t 0) #\}))
+  ) ;let
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Line access
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (r-get-line row)
+  (let ((s (program-row row)))
+    (if s s "")
+  ) ;let
+) ;define
+
+(define (r-prev-nonempty-row row)
+  (let loop
+    ((r (- row 1)))
+    (if (< r 0)
+      -1
+      (let* ((line (r-get-line r)) (t (r-trim line)))
+        (if (== t "") (loop (- r 1)) r)
+      ) ;let*
+    ) ;if
+  ) ;let
+) ;define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Indentation computation
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (r-indent-level-from-prev row)
+  (let* ((pr (r-prev-nonempty-row row)))
+    (if (< pr 0)
+      0
+      (let* ((pline (r-get-line pr))
+             (trimmed (r-trim pline))
+             (base (string-get-indent pline))
+             (tab (get-tabstop))
+             (inc? (or (r-line-continues? pline)
+                     ;; previous line ends with "{"
+                     (and (> (string-length trimmed) 0)
+                       (== (string-ref trimmed (- (string-length trimmed) 1)) #\{)
+                     ) ;and
+                   ) ;or
+             ) ;inc?
+            ) ;
+        (+ base (if inc? tab 0))
+      ) ;let*
+    ) ;if
+  ) ;let*
+) ;define
+
+(tm-define (program-compute-indentation doc row col)
+  (:mode in-prog-r?)
+  (let* ((tab (get-tabstop))
+         (line (r-get-line row))
+         (base (r-indent-level-from-prev row))
+        ) ;
+    (if (r-line-starts-with-closing-brace? line) (max 0 (- base tab)) base)
+  ) ;let*
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Commenting
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (program-comment-start) (:mode in-prog-r?) "#")
+
+(tm-define (program-toggle-comment)
+  (:mode in-prog-r?)
+  (prog-toggle-line-comment "#")
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Paste import hook
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (kbd-paste)
+  (:mode in-prog-r?)
+  (clipboard-paste-import "r" "primary")
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Brackets / quotes
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (r-bracket-open lbr rbr) (bracket-open lbr rbr "\\"))
+
+(tm-define (r-bracket-close lbr rbr) (bracket-close lbr rbr "\\"))
+
+(tm-define (notify-cursor-moved status)
+  (:require prog-highlight-brackets?)
+  (:mode in-prog-r?)
+  (select-brackets-after-movement "([{" ")]}" "\\")
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Keyboard mappings
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(kbd-map (:mode in-prog-r?)
+ ("A-tab" (insert-tabstop))
+ ("cmd S-tab" (remove-tabstop))
+ ("{" (r-bracket-open "{" "}"))
+ ("}" (r-bracket-close "{" "}"))
+ ("(" (r-bracket-open "(" ")"))
+ (")" (r-bracket-close "(" ")"))
+ ("[" (r-bracket-open "[" "]"))
+ ("]" (r-bracket-close "[" "]"))
+ ("\"" (r-bracket-open "\"" "\""))
+ ("'" (r-bracket-open "'" "'"))
+) ;kbd-map
diff --git a/TeXmacs/plugins/r/progs/r/r-format.scm b/TeXmacs/plugins/r/progs/r/r-format.scm
new file mode 100644
index 0000000000..1089e8c986
--- /dev/null
+++ b/TeXmacs/plugins/r/progs/r/r-format.scm
@@ -0,0 +1,32 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; MODULE      : r.scm
+;; DESCRIPTION : R format definition (minimal)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (r r-format))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; R source files
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-format r (:name "R source code") (:suffix "r" "R"))
+
+(define (texmacs->r x . opts)
+  (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '()))
+) ;define
+
+(define (r->texmacs x . opts)
+  (code->texmacs x)
+) ;define
+
+(define (r-snippet->texmacs x . opts)
+  (code-snippet->texmacs x)
+) ;define
+
+(converter texmacs-tree r-document (:function texmacs->r))
+
+(converter r-document texmacs-tree (:function r->texmacs))
+
+(converter texmacs-tree r-snippet (:function texmacs->r))
+
+(converter r-snippet texmacs-tree (:function r-snippet->texmacs))
diff --git a/TeXmacs/plugins/r/progs/r/r-lang.scm b/TeXmacs/plugins/r/progs/r/r-lang.scm
new file mode 100644
index 0000000000..55d1746406
--- /dev/null
+++ b/TeXmacs/plugins/r/progs/r/r-lang.scm
@@ -0,0 +1,229 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : r-lang.scm
+;; DESCRIPTION : R Language
+;; COPYRIGHT   : (C) 2026 Hongli Zha
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (r r-lang) (:use (prog default-lang)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Parser Features
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; R关键字、函数、常量等
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "r") (== key "keyword")))
+  `(,(string->symbol key)
+    (extra_chars "_")
+    ;; 变量/关键字可包含下划线
+    (constant ;; 常量
+      "NULL"
+      "NA"
+      "NaN"
+      "Inf"
+      "TRUE"
+      "FALSE"
+      "T"
+      "F")
+    (declare_function ;; 内置函数
+      "abs"
+      "sign"
+      "sqrt"
+      "ceiling"
+      "floor"
+      "trunc"
+      "round"
+      "exp"
+      "log"
+      "log10"
+      "log2"
+      "cos"
+      "sin"
+      "tan"
+      "acos"
+      "asin"
+      "atan"
+      "cosh"
+      "sinh"
+      "tanh"
+      "gamma"
+      "lgamma"
+      "max"
+      "min"
+      "sum"
+      "prod"
+      "mean"
+      "median"
+      "var"
+      "sd"
+      "range"
+      "cumsum"
+      "cumprod"
+      "cummax"
+      "cummin"
+      "c"
+      "seq"
+      "rep"
+      "length"
+      "unique"
+      "sort"
+      "order"
+      "rank"
+      "rev"
+      "which"
+      "any"
+      "all"
+      "is.na"
+      "is.nan"
+      "paste"
+      "paste0"
+      "substr"
+      "nchar"
+      "sprintf"
+      "grep"
+      "grepl"
+      "sub"
+      "gsub"
+      "strsplit"
+      "toupper"
+      "tolower"
+      "trimws"
+      "list"
+      "data.frame"
+      "matrix"
+      "array"
+      "factor"
+      "function"
+      "args"
+      "body"
+      "environment"
+      "formals"
+      "quote"
+      "eval"
+      "do.call"
+      "match.call"
+      "get"
+      "assign"
+      "exists"
+      "print"
+      "cat"
+      "read.table"
+      "read.csv"
+      "write.table"
+      "write.csv"
+      "scan"
+      "readLines"
+      "writeLines"
+      "source"
+      "detach"
+      "search"
+      "ls"
+      "subset"
+      "transform"
+      "with"
+      "within"
+      "system"
+      "Sys.time"
+      "Sys.Date"
+      "version"
+      "setwd"
+      "getwd"
+      "sample"
+      "set.seed"
+      "duplicated")
+    (declare_type ;; 类型
+      "numeric"
+      "integer"
+      "logical"
+      "character")
+    (declare_module ;; 包/模块
+      "library"
+      "require"
+      "attach"
+      "detach")
+    (keyword ;; 基本关键字
+      "if"
+      "else"
+      "for"
+      "while"
+      "repeat"
+      "break"
+      "next"
+      "in"
+      "return"
+      "...")
+    (keyword_control ;; 控制/异常关键字
+      "stop"
+      "warning"
+      "message"
+      "switch"
+      "try"
+      "tryCatch"))
+) ;tm-define
+
+;; 运算符
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "r") (== key "operator")))
+  `(,(string->symbol key)
+    (operator "+" "-" "*" "/" "^" ":" "%%" "%/%" "<" ">" "<=" ">=" "==" "!=" "&"
+      "&&" "|" "||" "!" "~" "$" "@")
+    (operator_special "::" ":::" "|>")
+    (operator_openclose "(" "[" "{" ")" "]" "}")
+    (operator_field "$" "@" "<-" "=" "<<-" "->" "->>"))
+) ;tm-define
+
+;; 数字特性
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "r") (== key "number")))
+  `(,(string->symbol key)
+    (bool_features "decimal" "sci_notation" "prefix_0x")
+    (separator "_")
+    (suffix (integer "L" "l") (imag "i")))
+) ;tm-define
+
+;; 字符串特性
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "r") (== key "string")))
+  `(,(string->symbol key)
+    (bool_features "single_quote" "double_quote" "multi_byte" "unicode_escape"
+      "hex_escape")
+    (escape_sequences "\\" "\"" "'" "a" "b" "f" "n" "r" "t" "v" "newline" "x"
+      "u" "U"))
+) ;tm-define
+
+;; 注释格式
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "r") (== key "comment")))
+  `(,(string->symbol key) (inline "#"))
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Preferences for syntax highlighting
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (notify-r-syntax var val)
+  (syntax-read-preferences "r")
+) ;define
+
+(define-preferences ("syntax:r:none" "red" notify-r-syntax)
+ ("syntax:r:comment" "brown" notify-r-syntax)
+ ("syntax:r:error" "dark red" notify-r-syntax)
+ ("syntax:r:constant" "#4040c0" notify-r-syntax)
+ ("syntax:r:constant_number" "#4040c0" notify-r-syntax)
+ ("syntax:r:constant_string" "dark grey" notify-r-syntax)
+ ("syntax:r:constant_char" "#333333" notify-r-syntax)
+ ("syntax:r:declare_function" "#0000c0" notify-r-syntax)
+ ("syntax:r:declare_type" "#0000c0" notify-r-syntax)
+ ("syntax:r:operator" "#8b008b" notify-r-syntax)
+ ("syntax:r:operator_openclose" "#B02020" notify-r-syntax)
+ ("syntax:r:operator_field" "#B02020" notify-r-syntax)
+ ("syntax:r:operator_special" "orange" notify-r-syntax)
+ ("syntax:r:keyword" "#309090" notify-r-syntax)
+ ("syntax:r:keyword_control" "#309090" notify-r-syntax)
+) ;define-preferences
diff --git a/TeXmacs/plugins/r/progs/r/r-mode.scm b/TeXmacs/plugins/r/progs/r/r-mode.scm
new file mode 100644
index 0000000000..deb24398b8
--- /dev/null
+++ b/TeXmacs/plugins/r/progs/r/r-mode.scm
@@ -0,0 +1,11 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; MODULE      : r-mode.scm
+;; DESCRIPTION : mode predicate for R programs
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(texmacs-module (r r-mode) (:use (kernel texmacs tm-modes)))
+
+(texmacs-modes (in-r% (== (get-env "prog-language") "r"))
+  (in-prog-r% #t in-prog% in-r%)
+) ;texmacs-modes
diff --git a/TeXmacs/plugins/r7rs/packages/code/r7rs.stem b/TeXmacs/plugins/r7rs/packages/code/r7rs.stem
new file mode 100644
index 0000000000..7242a52b53
--- /dev/null
+++ b/TeXmacs/plugins/r7rs/packages/code/r7rs.stem
@@ -0,0 +1,63 @@
+(document (TeXmacs "2.1.2")
+  (style "source")
+  (body (document (active* (src-title (document (src-package "r7rs" "1.0")
+                                        (src-purpose (document "Markup for Scheme defined in R7RS."))
+                                        (src-copyright "2024" "Darcy Shen")
+                                        (src-license (document (concat "This software falls under the "
+                                                                 (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE")
+                                                                 ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see "
+                                                                 (hlink "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                   "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                 ) ;hlink
+                                                                 "."
+                                                               ) ;concat
+                                                     ) ;document
+                                        ) ;src-license
+                                      ) ;document
+                           ) ;src-title
+                  ) ;active*
+          (use-module "(r7rs r7rs-format)")
+          (use-module "(r7rs r7rs-edit)")
+          (assign "goldfish-prompt-color" "dark green")
+          (assign "r7rs"
+            (macro "body"
+              (with "mode" "prog" "prog-language" "r7rs" "font-family" "rm" (arg "body"))
+            ) ;macro
+          ) ;assign
+          (assign "r7rs-code"
+            (macro "body" (document (pseudo-code (document (r7rs (arg "body"))))))
+          ) ;assign
+          (assign "r7rs-input"
+            (macro "prompt"
+              "body"
+              (document (with "generic-prompt-color"
+                          (value "goldfish-prompt-color")
+                          "generic-input-color"
+                          (value "scheme-input-color")
+                          (document (generic-input (arg "prompt") (arg "body")))
+                        ) ;with
+              ) ;document
+            ) ;macro
+          ) ;assign
+          ""
+          (assign "r7rs-result"
+            (macro "body"
+              (document (with "ornament-border"
+                          "0ln"
+                          "ornament-hpadding"
+                          "0spc"
+                          "padding-above"
+                          "0fn"
+                          "padding-below"
+                          "0fn"
+                          "ornament-color"
+                          "pastel green"
+                          (ornamented (document (arg "body")))
+                        ) ;with
+              ) ;document
+            ) ;macro
+          ) ;assign
+        ) ;document
+  ) ;body
+  (initial (collection))
+) ;document
diff --git a/TeXmacs/plugins/r7rs/packages/code/r7rs.ts b/TeXmacs/plugins/r7rs/packages/code/r7rs.ts
deleted file mode 100644
index ce29c70900..0000000000
--- a/TeXmacs/plugins/r7rs/packages/code/r7rs.ts
+++ /dev/null
@@ -1,54 +0,0 @@
-
-
-
-
-<\body>
-  
-    
-
-    <\src-purpose>
-      Markup for Scheme defined in R7RS.
-    
-
-    
-
-    <\src-license>
-      This software falls under the . It comes WITHOUT ANY
-      WARRANTY WHATSOEVER. You should have received a copy of the license
-      which the software. If not, see .
-    
-  >
-
-  
-
-  
-
-  
-
-  >>>
-
-  
-    <\pseudo-code>
-      >
-    
-  >
-
-  
-    <\with|generic-prompt-color||generic-input-color|>
-      |>
-    
-  >
-
-  \;
-
-  
-    
-      
-    >
-  >
-
-
-
->
diff --git a/TeXmacs/plugins/r7rs/progs/code/r7rs-edit.scm b/TeXmacs/plugins/r7rs/progs/code/r7rs-edit.scm
deleted file mode 100644
index 71a4679982..0000000000
--- a/TeXmacs/plugins/r7rs/progs/code/r7rs-edit.scm
+++ /dev/null
@@ -1,49 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : r7rs-edit.scm
-;; DESCRIPTION : Editing r7rs programs
-;; COPYRIGHT   : (C) 2024   Darcy Shen
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (code r7rs-edit)
-  (:use (prog prog-edit)))
-
-(texmacs-modes
-  (in-r7rs% (== (get-env "prog-language") "r7rs"))
-  (in-prog-r7rs% #t in-prog% in-r7rs%))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Automatic insertion, highlighting and selection of brackets and quotes
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (r7rs-bracket-open lbr rbr)
-  (bracket-open lbr rbr "\\"))
-
-(tm-define (r7rs-bracket-close lbr rbr)
-  (bracket-close lbr rbr "\\"))
-
-(tm-define (kbd-select-enlarge)
-  (:require prog-select-brackets?)
-  (:mode in-prog-r7rs?)
-  (program-select-enlarge "(" ")"))
-
-(tm-define (notify-cursor-moved status)
-  (:require prog-highlight-brackets?)
-  (:mode in-prog-r7rs?)
-  (select-brackets-after-movement "([{" ")]}" "\\"))
-
-(kbd-map
-  (:mode in-prog-r7rs?)
-  ("{" (r7rs-bracket-open "{" "}" ))
-  ("}" (r7rs-bracket-close "{" "}" ))
-  ("(" (r7rs-bracket-open "(" ")" ))
-  (")" (r7rs-bracket-close "(" ")" ))
-  ("[" (r7rs-bracket-open "[" "]" ))
-  ("]" (r7rs-bracket-close "[" "]" ))
-  ("\"" (r7rs-bracket-open "\"" "\"" )))
diff --git a/TeXmacs/plugins/r7rs/progs/code/r7rs-keyword.scm b/TeXmacs/plugins/r7rs/progs/code/r7rs-keyword.scm
deleted file mode 100644
index 7dc2dfa258..0000000000
--- a/TeXmacs/plugins/r7rs/progs/code/r7rs-keyword.scm
+++ /dev/null
@@ -1,78 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : r7rs-keyword.scm
-;; DESCRIPTION : the Scheme Keyword defined in R7RS
-;; COPYRIGHT   : (C) 2024  Darcy Shen
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (code r7rs-keyword))
-
-(define (r7rs-scheme-base)
-  (map symbol->string
-    '(abs and append assoc assq assv binary-port? boolean=? boolean? bytevector bytevector-append bytevector-copy bytevector-copy! bytevector-length bytevector-u8-ref bytevector-u8-set! bytevector? caar cadr call-with-current-continuation call-with-port call-with-values call/cc car case cdar cddr cdr ceiling char->integer char-ready? char<=? char=? char>? char? close-input-port close-output-port close-port complex? cond cond-expand cons current-error-port current-input-port current-output-port denominator do dynamic-wind else eof-object eof-object? eq? equal? eqv? error-object-irritants error-object-message error-object? even? exact exact-integer-sqrt exact-integer? exact? expt features file-error? floor floor-quotient floor-remainder floor/ flush-output-port for-each gcd get-output-bytevector get-output-string include include-ci inexact inexact? input-port-open? input-port? integer->char integer? lambda lcm length list list->string list->vector list-copy list-ref list-set! list-tail list? make-bytevector make-list make-parameter make-string make-vector map max member memq memv min modulo negative? newline not null? number->string number? numerator odd? open-input-bytevector open-input-string open-output-bytevector open-output-string or output-port-open? output-port? pair? parameterize peek-char peek-u8 port? positive? procedure? quasiquote quote quotient raise raise-continuable rational? rationalize read-bytevector read-bytevector! read-char read-error? read-line read-string read-u8 real? remainder reverse round set-car! set-cdr! sin sqrt string string->list string->number string->symbol string->utf8 string->vector string-append string-copy string-copy! string-fill! string-for-each string-length string-map string-ref string-set! string<=? string=? string>? string? substring symbol->string symbol=? symbol? syntax-error syntax-rules textual-port? truncate truncate-quotient truncate-remainder truncate/ u8-ready? unless unquote unquote-splicing utf8->string vector vector->list vector->string vector-append vector-copy vector-copy! vector-fill! vector-for-each vector-length vector-map vector-ref vector-set! vector? write-bytevector write-char write-string write-u8 zero?)))
-
-(define (r7rs-scheme-case-lambda)
-  (map symbol->string '(case-lambda)))
-
-(define (r7rs-scheme-char)
-  (map symbol->string
-    '(char-alphabetic? char-ci<=? char-ci=? char-ci>? char-downcase char-foldcase char-lower-case? char-numeric? char-upcase char-upper-case? char-whitespace? digit-value string-ci<=? string-ci=? string-ci>? string-downcase string-foldcase string-upcase)))
-
-(define (r7rs-scheme-complex)
-  (map symbol->string
-    '(angle imag-part magnitude make-polar make-rectangular real-part)))
-
-(define (r7rs-scheme-CxR)
-  (map symbol->string
-    '(caaaar caaadr caaar caadar caaddr caadr cadaar cadadr cadar caddar cadddr caddr cdaaar cdaadr cdaar cdadar cdaddr cdadr cddaar cddadr cddar cdddar cddddr cdddr)))
-
-(define (r7rs-scheme-file)
-  (map symbol->string
-    '(call-with-input-file call-with-output-file delete-file file-exists? open-binary-input-file open-binary-output-file open-input-file open-output-file with-input-from-file with-output-to-file)))
-
-(define (r7rs-scheme-inexact)
-  (map symbol->string '(acos asin atan cos exp finite? infinite? log nan? sin sqrt tan)))
-
-(define (r7rs-scheme-lazy)
-  (map symbol->string '(delay delay-force force make-promise promise?)))
-
-(define (r7rs-scheme-process-context)
-  (map symbol->string
-    '(command-line emergency-exit exit get-environment-variable get-environment-variables)))
-
-(define (r7rs-scheme-read)
-  (map symbol->string '(read)))
-
-(define (r7rs-scheme-repl)
-  (map symbol->string
-    '(interaction-environment)))
-
-(define (r7rs-scheme-time)
-  (map symbol->string
-    '(current-jiffy current-second jiffies-per-second)))
-
-(define (r7rs-scheme-write)
-  (map symbol->string
-    '(display write write-shared write-simple)))
-
-(tm-define (r7rs-keywords-others)
-  `(,@(r7rs-scheme-base) ,@(r7rs-scheme-case-lambda) ,@(r7rs-scheme-char) ,@(r7rs-scheme-complex) ,@(r7rs-scheme-CxR) ,@(r7rs-scheme-file) ,@(r7rs-scheme-inexact) ,@(r7rs-scheme-lazy) ,@(r7rs-scheme-process-context) ,@(r7rs-scheme-read) ,@(r7rs-scheme-repl) ,@(r7rs-scheme-time) ,@(r7rs-scheme-write)))
-
-(tm-define (r7rs-keywords-constant)
-  (list "+inf.0" "-inf.0" "+nan.0" "-nan.0" "#t" "#true" "#f" "#false"))
-
-(tm-define (r7rs-keywords-branch)
-  (list "if" "cond" "else" "case" "when"))
-
-(tm-define (r7rs-keywords-define)
-  (list
-    "define" "define-record-type" "define-syntax" "define-values" "set!" "lambda" "let" "let*" "let-values" "let*-values" "letrec" "letrec*" "let-syntax" "letrec-syntax" "apply" "eval" "environment" "load" "values" "begin" "import" "export" "define-library"))
-
-(tm-define (r7rs-keywords-exception)
-  (list "error" "guard" "with-exception-handler"))
diff --git a/TeXmacs/plugins/r7rs/progs/code/r7rs-lang.scm b/TeXmacs/plugins/r7rs/progs/code/r7rs-lang.scm
deleted file mode 100644
index c4d3ffffb1..0000000000
--- a/TeXmacs/plugins/r7rs/progs/code/r7rs-lang.scm
+++ /dev/null
@@ -1,83 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : r7rs-lang.scm
-;; DESCRIPTION : the Scheme Language defined in R7RS
-;; COPYRIGHT   : (C) 2024  Darcy Shen
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (code r7rs-lang)
-  (:use (prog default-lang)
-        (code r7rs-keyword)))
-
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "r7rs") (== key "identifier")))
-  `(,(string->symbol key)
-    (extra_chars "?" "+" "-" "." "!" "*" ">" "=" "<" "#")
-    (start_chars "?" "+" "-" "." "!" "*" ">" "=" "<" "#")))
-
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "r7rs") (== key "keyword")))
-  `(,(string->symbol key)
-    (extra_chars "?" "+" "-" "." "!" "*" ">" "=" "<" "#")
-    (constant ,@(r7rs-keywords-constant))
-    (keyword ,@(r7rs-keywords-others))
-    (declare_type ,@(r7rs-keywords-define))
-    (keyword_conditional ,@(r7rs-keywords-branch))
-    (keyword_control ,@(r7rs-keywords-exception))))
-
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "r7rs") (== key "operator")))
-  `(,(string->symbol key)
-    (operator "=" "+" "-" "*" "/" "=>" "->" ">" "<" ">=" "<=")
-    (operator_special "@" "," "'" "`")
-    (operator_openclose "{" "[" "(" ")" "]" "}")))
-
-(define (r7rs-number-suffix)
-  `(suffix
-    (imaginary "i")))
-
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "r7rs") (== key "number")))
-  `(,(string->symbol key)
-    (bool_features "prefix_#")
-    (separator "_")
-    ,(r7rs-number-suffix)))
-
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "r7rs") (== key "string")))
-  `(,(string->symbol key)
-    (bool_features 
-     "hex_with_8_bits" "hex_with_16_bits"
-     "hex_with_32_bits" "octal_upto_3_digits")
-    (escape_sequences "\\" "\"" "a" "b" "f" "n" "r" "t" "v")
-    (pairs "\"")))
-
-; See: https://r7rs.org/doc/v6.1.0/Single-Line-Comments.html
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "r7rs") (== key "comment")))
-  `(,(string->symbol key)
-    (inline ";")))
-
-(define (notify-r7rs-syntax var val)
-  (syntax-read-preferences "r7rs"))
-
-(define-preferences
-  ("syntax:r7rs:none" "red" notify-r7rs-syntax)
-  ("syntax:r7rs:comment" "brown" notify-r7rs-syntax)
-  ("syntax:r7rs:declare_type" "#309090" notify-r7rs-syntax)
-  ("syntax:r7rs:keyword_conditional" "#309090" notify-r7rs-syntax)
-  ("syntax:r7rs:keyword_control" "#309090" notify-r7rs-syntax)
-  ("syntax:r7rs:keyword" "#204080" notify-r7rs-syntax)
-  ("syntax:r7rs:constant_number" "#4040c0" notify-r7rs-syntax)
-  ("syntax:r7rs:constant_string" "dark grey" notify-r7rs-syntax)
-  ("syntax:r7rs:constant_char" "#333333" notify-r7rs-syntax)
-  ("syntax:r7rs:operator_special" "dark magenta" notify-r7rs-syntax)
-  ("syntax:r7rs:operator_openclose" "dark" notify-r7rs-syntax)
-  ("syntax:r7rs:variable_identifier" "#204080" notify-r7rs-syntax)
-  ("syntax:r7rs:declare_category" "#d030d0" notify-r7rs-syntax))
diff --git a/TeXmacs/plugins/r7rs/progs/code/srfi-keyword.scm b/TeXmacs/plugins/r7rs/progs/code/srfi-keyword.scm
deleted file mode 100644
index 5de20f3aee..0000000000
--- a/TeXmacs/plugins/r7rs/progs/code/srfi-keyword.scm
+++ /dev/null
@@ -1,122 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : srfi-keyword.scm
-;; DESCRIPTION : the Scheme Keyword defined in R7RS
-;; COPYRIGHT   : (C) 2024  Darcy Shen
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (code srfi-keyword))
-
-(tm-define (srfi-1-keywords)
-  (list
-    "srfi-1" ; List Library
-    ; SRFI-1: List constructors
-    "list" "cons" "xcons" "cons*" "make-list"
-    "list-tabulate" "list-copy" "circular-list" "iota"
-    ; SRFI-1: List predicates
-    "pair?" "null?" "proper-list?" "circular-list?" "dotted-list?"
-    "not-pair?" "null-list?" "list=" "list?"
-    ; SRFI-1: List selectors
-    "car" "caar" "cdar" "cadr" "caddr" "cadddr"
-    "cdr" "cddr" "cdddr" "cddddr"
-    "list-ref"
-    "first" "second" "third" "fourth" "fifth"
-    "sixth" "seventh" "eighth" "ninth" "tenth"
-    "take" "drop" "take-right" "drop-right" "last"
-    "last-pair"
-    ; SRFI-1: MISC
-    "concatenate" "reverse" "append-reverse" "zip" "count"
-    ; SRFI-1: fold, unfold, map
-    "fold" "fold-right" "reduce" "reduce-right" "map"
-    "unfold" "unfold-right" "for-each" "map-in-order"
-    ; SRFI-1: Filtering & Parititioning
-    "filter" "partition" "remove"
-    ; SRFI-1: Searching
-    "find" "find-tail" "take-while" "drop-while" "span"
-    "any" "every" "list-index" "member" "memq" "memv"
-    ; SRFI-1: Deletion
-    "delete" "delete-duplicates"))
-
-(tm-define (srfi-8-keywords)
-  (list
-    "srfi-8"
-    "call-with-values" "receive"))
-
-(tm-define (srfi-13-keywords)
-  (list
-    "srfi-13" ; String Library
-    ; SRFI-13: String predicates
-    "string?" "string-null?" "string-every" "string-any"
-    ; SRFI-13: String constructors
-    "make-string" "string" "string-tabulate"
-    ; SRFI-13: List & String Conversion
-    "string->list" "list->string" "reverse-list->string" "string-join"
-    ; SRFI-13: String selection
-    "string-length" "string-ref" "string-copy" "substring" "string-copy!"
-    "string-take" "string-take-right" "string-drop" "string-drop-right" "string-pad"
-    "string-pad-right" "string-trim" "string-trim-right" "string-trim-both"
-    ; SRFI-13: String comparison
-    "string-compare" "string=" "string<>"
-    ; SRFI-13: String searching
-    "string-index" "string-index-right" "string-skip" "string-skip-right" "string-count"
-    "string-contains"
-    "string-reverse" "string-append"
-    ; SRFI-13: Functional programming
-    "string-map" "string-fold" "string-fold-right" "string-for-each" "string-for-each-index"
-    ; SRFI-13: String insertion and parsing
-    "string-replace" "string-tokenize"
-    ; SRFI-13: Filtering & Deleting
-    "string-filter" "string-delete"))
-
-(tm-define (srfi-60-keywords)
-  (list
-    "bitwise-and" "bitwise-ior" "bitwise-xor" "bitwise-not"
-    "arithmetic-shift" "ash"))
-
-(tm-define (srfi-70-keywords)
-  (list
-    "srfi-70" ; Numbers
-    "number?" "complex?" "real?" "rational?" "integer?"
-    "exact?" "inexact?" "finite?" "infinite?" "zero?"
-    "positive?" "negative?" "odd?" "even?" "floor?"
-    "max" "min" "abs" "quotient" "remainder" "modulo"
-    "gcd" "lcm" "numerator" "denominator" "floor"
-    "ceiling" "truncate" "round" "rationalize"
-    "expt" "log" "complex" "real-part" "imag-part"
-    "sin" "cos" "tan" "asin" "acos" "atan"
-    "sinh" "cosh" "tanh" "asinh" "acosh" "atanh"
-    "sqrt" "expt" "make-rectangular" "make-polar" "magnitude"
-    "angle" "exact->inexact" "inexact->exact" "string->number" "number->string"))
-
-(tm-define (srfi-78-keywords)
-  (list
-    "srfi-78" ; Light-weighted Test framework
-    "check" "check-set-mode!" "check-report" "check-reset!"))
-
-(tm-define (srfi-125-keywords)
-  (map symbol->string
-    '(make-hash-table hash-table hash-table-unfold alist->hash-table
-      hash-table? hash-table-contains? hash-table-empty? hash-table=?
-      hash-table-mutable?
-      hash-table-ref hash-table-ref/default
-      hash-table-set! hash-table-delete! hash-table-intern! hash-table-update!
-      hash-table-update!/default hash-table-pop! hash-table-clear!
-      hash-table-size hash-table-keys hash-table-values hash-table-entries
-      hash-table-find hash-table-count)))
-
-(tm-define (srfi-133-keywords)
-  (map symbol->string
-    '(vector-empty? vector-count
-      vector-any vector-every vector-copy vector-copy!
-      vector-index vector-index-right vector-partition
-      vector-swap!)))
-
-(tm-define (srfi-151-keywords)
-  (map symbol->string
-    '(bitwise-not bitwise-and bitwise-ior bitwise-xor bitwise-or bitwise-nor bitwise-nand bit-count arithmetic-shift)))
diff --git a/TeXmacs/plugins/r7rs/progs/data/r7rs.scm b/TeXmacs/plugins/r7rs/progs/data/r7rs.scm
deleted file mode 100644
index ff7a4fa2c0..0000000000
--- a/TeXmacs/plugins/r7rs/progs/data/r7rs.scm
+++ /dev/null
@@ -1,43 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : r7rs.scm
-;; DESCRIPTION : prog format for r7rs
-;; COPYRIGHT   : (C) 2022  Darcy Shen, Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (data r7rs))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; r7rs source files
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define-format r7rs
-  (:name "R7RS source code")
-  (:suffix "scm" ".sld" ".ss"))
-  
-(define (texmacs->r7rs x . opts)
-  (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '())))
-
-(define (r7rs->texmacs x . opts)
-  (code->texmacs x))
-
-(define (r7rs-snippet->texmacs x . opts)
-  (code-snippet->texmacs x))
-
-(converter texmacs-tree r7rs-document
-  (:function texmacs->r7rs))
-
-(converter r7rs-document texmacs-tree
-  (:function r7rs->texmacs))
-  
-(converter texmacs-tree r7rs-snippet
-  (:function texmacs->r7rs))
-
-(converter r7rs-snippet texmacs-tree
-  (:function r7rs-snippet->texmacs))
diff --git a/TeXmacs/plugins/r7rs/progs/r7rs/r7rs-edit.scm b/TeXmacs/plugins/r7rs/progs/r7rs/r7rs-edit.scm
new file mode 100644
index 0000000000..c1b4a1e988
--- /dev/null
+++ b/TeXmacs/plugins/r7rs/progs/r7rs/r7rs-edit.scm
@@ -0,0 +1,48 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : r7rs-edit.scm
+;; DESCRIPTION : Editing r7rs programs
+;; COPYRIGHT   : (C) 2024   Darcy Shen
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (r7rs r7rs-edit) (:use (prog prog-edit)))
+
+(texmacs-modes (in-r7rs% (== (get-env "prog-language") "r7rs"))
+  (in-prog-r7rs% #t in-prog% in-r7rs%)
+) ;texmacs-modes
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Automatic insertion, highlighting and selection of brackets and quotes
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (r7rs-bracket-open lbr rbr) (bracket-open lbr rbr "\\"))
+
+(tm-define (r7rs-bracket-close lbr rbr) (bracket-close lbr rbr "\\"))
+
+(tm-define (kbd-select-enlarge)
+  (:require prog-select-brackets?)
+  (:mode in-prog-r7rs?)
+  (program-select-enlarge "(" ")")
+) ;tm-define
+
+(tm-define (notify-cursor-moved status)
+  (:require prog-highlight-brackets?)
+  (:mode in-prog-r7rs?)
+  (select-brackets-after-movement "([{" ")]}" "\\")
+) ;tm-define
+
+(kbd-map (:mode in-prog-r7rs?)
+ ("{" (r7rs-bracket-open "{" "}"))
+ ("}" (r7rs-bracket-close "{" "}"))
+ ("(" (r7rs-bracket-open "(" ")"))
+ (")" (r7rs-bracket-close "(" ")"))
+ ("[" (r7rs-bracket-open "[" "]"))
+ ("]" (r7rs-bracket-close "[" "]"))
+ ("\"" (r7rs-bracket-open "\"" "\""))
+) ;kbd-map
diff --git a/TeXmacs/plugins/r7rs/progs/r7rs/r7rs-format.scm b/TeXmacs/plugins/r7rs/progs/r7rs/r7rs-format.scm
new file mode 100644
index 0000000000..b1a2d1925c
--- /dev/null
+++ b/TeXmacs/plugins/r7rs/progs/r7rs/r7rs-format.scm
@@ -0,0 +1,40 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : r7rs.scm
+;; DESCRIPTION : prog format for r7rs
+;; COPYRIGHT   : (C) 2022  Darcy Shen, Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (r7rs r7rs-format))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; r7rs source files
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-format r7rs (:name "R7RS source code") (:suffix "scm" ".sld" ".ss"))
+
+(define (texmacs->r7rs x . opts)
+  (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '()))
+) ;define
+
+(define (r7rs->texmacs x . opts)
+  (code->texmacs x)
+) ;define
+
+(define (r7rs-snippet->texmacs x . opts)
+  (code-snippet->texmacs x)
+) ;define
+
+(converter texmacs-tree r7rs-document (:function texmacs->r7rs))
+
+(converter r7rs-document texmacs-tree (:function r7rs->texmacs))
+
+(converter texmacs-tree r7rs-snippet (:function texmacs->r7rs))
+
+(converter r7rs-snippet texmacs-tree (:function r7rs-snippet->texmacs))
diff --git a/TeXmacs/plugins/r7rs/progs/r7rs/r7rs-keyword.scm b/TeXmacs/plugins/r7rs/progs/r7rs/r7rs-keyword.scm
new file mode 100644
index 0000000000..01287d7693
--- /dev/null
+++ b/TeXmacs/plugins/r7rs/progs/r7rs/r7rs-keyword.scm
@@ -0,0 +1,155 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : r7rs-keyword.scm
+;; DESCRIPTION : the Scheme Keyword defined in R7RS
+;; COPYRIGHT   : (C) 2024  Darcy Shen
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (r7rs r7rs-keyword))
+
+(define (r7rs-scheme-base)
+  (map symbol->string
+    '(abs and append assoc assq assv binary-port? boolean=? boolean? bytevector
+       bytevector-append bytevector-copy bytevector-copy! bytevector-length
+       bytevector-u8-ref bytevector-u8-set! bytevector? caar cadr
+       call-with-current-continuation call-with-port call-with-values call/cc
+       car case cdar cddr cdr ceiling char->integer char-ready? char<=? char=? char>? char? close-input-port close-output-port close-port
+       complex? cond cond-expand cons current-error-port current-input-port
+       current-output-port denominator do dynamic-wind else eof-object
+       eof-object? eq? equal? eqv? error-object-irritants error-object-message
+       error-object? even? exact exact-integer-sqrt exact-integer? exact? expt
+       features file-error? floor floor-quotient floor-remainder floor/
+       flush-output-port for-each gcd get-output-bytevector get-output-string
+       include include-ci inexact inexact? input-port-open? input-port?
+       integer->char integer? lambda lcm length list list->string list->vector
+       list-copy list-ref list-set! list-tail list? make-bytevector make-list
+       make-parameter make-string make-vector map max member memq memv min
+       modulo negative? newline not null? number->string number? numerator odd?
+       open-input-bytevector open-input-string open-output-bytevector
+       open-output-string or output-port-open? output-port? pair? parameterize
+       peek-char peek-u8 port? positive? procedure? quasiquote quote quotient
+       raise raise-continuable rational? rationalize read-bytevector
+       read-bytevector! read-char read-error? read-line read-string read-u8
+       real? remainder reverse round set-car! set-cdr! sin sqrt string
+       string->list string->number string->symbol string->utf8 string->vector
+       string-append string-copy string-copy! string-fill! string-for-each
+       string-length string-map string-ref string-set! string<=? string=? string>? string? substring symbol->string symbol=?
+       symbol? syntax-error syntax-rules textual-port? truncate
+       truncate-quotient truncate-remainder truncate/ u8-ready? unless unquote
+       unquote-splicing utf8->string vector vector->list vector->string
+       vector-append vector-copy vector-copy! vector-fill! vector-for-each
+       vector-length vector-map vector-ref vector-set! vector? write-bytevector
+       write-char write-string write-u8 zero?)
+  ) ;map
+) ;define
+
+(define (r7rs-scheme-case-lambda)
+  (map symbol->string '(case-lambda))
+) ;define
+
+(define (r7rs-scheme-char)
+  (map symbol->string
+    '(char-alphabetic? char-ci<=? char-ci=? char-ci>?
+       char-downcase char-foldcase char-lower-case? char-numeric? char-upcase
+       char-upper-case? char-whitespace? digit-value string-ci<=? string-ci=? string-ci>? string-downcase string-foldcase
+       string-upcase)
+  ) ;map
+) ;define
+
+(define (r7rs-scheme-complex)
+  (map symbol->string
+    '(angle imag-part magnitude make-polar make-rectangular real-part)
+  ) ;map
+) ;define
+
+(define (r7rs-scheme-CxR)
+  (map symbol->string
+    '(caaaar caaadr caaar caadar caaddr caadr cadaar cadadr cadar caddar cadddr
+       caddr cdaaar cdaadr cdaar cdadar cdaddr cdadr cddaar cddadr cddar cdddar
+       cddddr cdddr)
+  ) ;map
+) ;define
+
+(define (r7rs-scheme-file)
+  (map symbol->string
+    '(call-with-input-file call-with-output-file delete-file file-exists?
+       open-binary-input-file open-binary-output-file open-input-file
+       open-output-file with-input-from-file with-output-to-file)
+  ) ;map
+) ;define
+
+(define (r7rs-scheme-inexact)
+  (map symbol->string
+    '(acos asin atan cos exp finite? infinite? log nan? sin sqrt tan)
+  ) ;map
+) ;define
+
+(define (r7rs-scheme-lazy)
+  (map symbol->string '(delay delay-force force make-promise promise?))
+) ;define
+
+(define (r7rs-scheme-process-context)
+  (map symbol->string
+    '(command-line emergency-exit exit get-environment-variable
+       get-environment-variables)
+  ) ;map
+) ;define
+
+(define (r7rs-scheme-read)
+  (map symbol->string '(read))
+) ;define
+
+(define (r7rs-scheme-repl)
+  (map symbol->string '(interaction-environment))
+) ;define
+
+(define (r7rs-scheme-time)
+  (map symbol->string '(current-jiffy current-second jiffies-per-second))
+) ;define
+
+(define (r7rs-scheme-write)
+  (map symbol->string '(display write write-shared write-simple))
+) ;define
+
+(tm-define (r7rs-keywords-others)
+  `(,@(r7rs-scheme-base)
+    ,@(r7rs-scheme-case-lambda)
+    ,@(r7rs-scheme-char)
+    ,@(r7rs-scheme-complex)
+    ,@(r7rs-scheme-CxR)
+    ,@(r7rs-scheme-file)
+    ,@(r7rs-scheme-inexact)
+    ,@(r7rs-scheme-lazy)
+    ,@(r7rs-scheme-process-context)
+    ,@(r7rs-scheme-read)
+    ,@(r7rs-scheme-repl)
+    ,@(r7rs-scheme-time)
+    ,@(r7rs-scheme-write))
+) ;tm-define
+
+(tm-define (r7rs-keywords-constant)
+  (list "+inf.0" "-inf.0" "+nan.0" "-nan.0" "#t" "#true" "#f" "#false")
+) ;tm-define
+
+(tm-define (r7rs-keywords-branch) (list "if" "cond" "else" "case" "when"))
+
+(tm-define (r7rs-keywords-define)
+  (list "define" "define-record-type" "define-syntax" "define-values" "set!"
+    "lambda" "let" "let*" "let-values" "let*-values" "letrec" "letrec*"
+    "let-syntax" "letrec-syntax" "apply" "eval" "environment" "load" "values"
+    "begin" "import" "export" "define-library"
+  ) ;list
+) ;tm-define
+
+(tm-define (r7rs-keywords-exception)
+  (list "error" "guard" "with-exception-handler")
+) ;tm-define
diff --git a/TeXmacs/plugins/r7rs/progs/r7rs/r7rs-lang.scm b/TeXmacs/plugins/r7rs/progs/r7rs/r7rs-lang.scm
new file mode 100644
index 0000000000..bf57622a28
--- /dev/null
+++ b/TeXmacs/plugins/r7rs/progs/r7rs/r7rs-lang.scm
@@ -0,0 +1,85 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : r7rs-lang.scm
+;; DESCRIPTION : the Scheme Language defined in R7RS
+;; COPYRIGHT   : (C) 2024  Darcy Shen
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (r7rs r7rs-lang) (:use (prog default-lang) (r7rs r7rs-keyword)))
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "r7rs") (== key "identifier")))
+  `(,(string->symbol key)
+    (extra_chars "?" "+" "-" "." "!" "*" ">" "=" "<" "#")
+    (start_chars "?" "+" "-" "." "!" "*" ">" "=" "<" "#"))
+) ;tm-define
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "r7rs") (== key "keyword")))
+  `(,(string->symbol key)
+    (extra_chars "?" "+" "-" "." "!" "*" ">" "=" "<" "#")
+    (constant ,@(r7rs-keywords-constant))
+    (keyword ,@(r7rs-keywords-others))
+    (declare_type ,@(r7rs-keywords-define))
+    (keyword_conditional ,@(r7rs-keywords-branch))
+    (keyword_control ,@(r7rs-keywords-exception)))
+) ;tm-define
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "r7rs") (== key "operator")))
+  `(,(string->symbol key)
+    (operator "=" "+" "-" "*" "/" "=>" "->" ">" "<" ">=" "<=")
+    (operator_special "@" "," "'" "`")
+    (operator_openclose "{" "[" "(" ")" "]" "}"))
+) ;tm-define
+
+(define (r7rs-number-suffix)
+  '(suffix (imaginary "i"))
+) ;define
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "r7rs") (== key "number")))
+  `(,(string->symbol key)
+    (bool_features "prefix_#")
+    (separator "_")
+    ,(r7rs-number-suffix))
+) ;tm-define
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "r7rs") (== key "string")))
+  `(,(string->symbol key)
+    (bool_features "hex_with_8_bits" "hex_with_16_bits" "hex_with_32_bits"
+      "octal_upto_3_digits")
+    (escape_sequences "\\" "\"" "a" "b" "f" "n" "r" "t" "v")
+    (pairs "\""))
+) ;tm-define
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "r7rs") (== key "comment")))
+  `(,(string->symbol key) (inline ";"))
+) ;tm-define
+
+(define (notify-r7rs-syntax var val)
+  (syntax-read-preferences "r7rs")
+) ;define
+
+(define-preferences ("syntax:r7rs:none" "red" notify-r7rs-syntax)
+ ("syntax:r7rs:comment" "brown" notify-r7rs-syntax)
+ ("syntax:r7rs:declare_type" "#309090" notify-r7rs-syntax)
+ ("syntax:r7rs:keyword_conditional" "#309090" notify-r7rs-syntax)
+ ("syntax:r7rs:keyword_control" "#309090" notify-r7rs-syntax)
+ ("syntax:r7rs:keyword" "#204080" notify-r7rs-syntax)
+ ("syntax:r7rs:constant_number" "#4040c0" notify-r7rs-syntax)
+ ("syntax:r7rs:constant_string" "dark grey" notify-r7rs-syntax)
+ ("syntax:r7rs:constant_char" "#333333" notify-r7rs-syntax)
+ ("syntax:r7rs:operator_special" "dark magenta" notify-r7rs-syntax)
+ ("syntax:r7rs:operator_openclose" "dark" notify-r7rs-syntax)
+ ("syntax:r7rs:variable_identifier" "#204080" notify-r7rs-syntax)
+ ("syntax:r7rs:declare_category" "#d030d0" notify-r7rs-syntax)
+) ;define-preferences
diff --git a/TeXmacs/plugins/r7rs/progs/r7rs/srfi-keyword.scm b/TeXmacs/plugins/r7rs/progs/r7rs/srfi-keyword.scm
new file mode 100644
index 0000000000..1ebbe9c630
--- /dev/null
+++ b/TeXmacs/plugins/r7rs/progs/r7rs/srfi-keyword.scm
@@ -0,0 +1,94 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : srfi-keyword.scm
+;; DESCRIPTION : the Scheme Keyword defined in R7RS
+;; COPYRIGHT   : (C) 2024  Darcy Shen
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (r7rs srfi-keyword))
+
+(tm-define (srfi-1-keywords)
+  (list "srfi-1" "list" "cons" "xcons" "cons*" "make-list" "list-tabulate"
+    "list-copy" "circular-list" "iota" "pair?" "null?" "proper-list?"
+    "circular-list?" "dotted-list?" "not-pair?" "null-list?" "list=" "list?"
+    "car" "caar" "cdar" "cadr" "caddr" "cadddr" "cdr" "cddr" "cdddr" "cddddr"
+    "list-ref" "first" "second" "third" "fourth" "fifth" "sixth" "seventh"
+    "eighth" "ninth" "tenth" "take" "drop" "take-right" "drop-right" "last"
+    "last-pair" "concatenate" "reverse" "append-reverse" "zip" "count" "fold"
+    "fold-right" "reduce" "reduce-right" "map" "unfold" "unfold-right"
+    "for-each" "map-in-order" "filter" "partition" "remove" "find" "find-tail"
+    "take-while" "drop-while" "span" "any" "every" "list-index" "member" "memq"
+    "memv" "delete" "delete-duplicates"
+  ) ;list
+) ;tm-define
+
+(tm-define (srfi-8-keywords) (list "srfi-8" "call-with-values" "receive"))
+
+(tm-define (srfi-13-keywords)
+  (list "srfi-13" "string?" "string-null?" "string-every" "string-any"
+    "make-string" "string" "string-tabulate" "string->list" "list->string"
+    "reverse-list->string" "string-join" "string-length" "string-ref"
+    "string-copy" "substring" "string-copy!" "string-take" "string-take-right"
+    "string-drop" "string-drop-right" "string-pad" "string-pad-right"
+    "string-trim" "string-trim-right" "string-trim-both" "string-compare"
+    "string=" "string<>" "string-index" "string-index-right" "string-skip"
+    "string-skip-right" "string-count" "string-contains" "string-reverse"
+    "string-append" "string-map" "string-fold" "string-fold-right"
+    "string-for-each" "string-for-each-index" "string-replace" "string-tokenize"
+    "string-filter" "string-delete"
+  ) ;list
+) ;tm-define
+
+(tm-define (srfi-60-keywords)
+  (list "bitwise-and" "bitwise-ior" "bitwise-xor" "bitwise-not"
+    "arithmetic-shift" "ash"
+  ) ;list
+) ;tm-define
+
+(tm-define (srfi-70-keywords)
+  (list "srfi-70" "number?" "complex?" "real?" "rational?" "integer?" "exact?"
+    "inexact?" "finite?" "infinite?" "zero?" "positive?" "negative?" "odd?"
+    "even?" "floor?" "max" "min" "abs" "quotient" "remainder" "modulo" "gcd"
+    "lcm" "numerator" "denominator" "floor" "ceiling" "truncate" "round"
+    "rationalize" "expt" "log" "complex" "real-part" "imag-part" "sin" "cos"
+    "tan" "asin" "acos" "atan" "sinh" "cosh" "tanh" "asinh" "acosh" "atanh"
+    "sqrt" "expt" "make-rectangular" "make-polar" "magnitude" "angle"
+    "exact->inexact" "inexact->exact" "string->number" "number->string"
+  ) ;list
+) ;tm-define
+
+(tm-define (srfi-78-keywords)
+  (list "srfi-78" "check" "check-set-mode!" "check-report" "check-reset!")
+) ;tm-define
+
+(tm-define (srfi-125-keywords)
+  (map symbol->string
+    '(make-hash-table hash-table hash-table-unfold alist->hash-table hash-table?
+       hash-table-contains? hash-table-empty? hash-table=? hash-table-mutable?
+       hash-table-ref hash-table-ref/default hash-table-set! hash-table-delete!
+       hash-table-intern! hash-table-update! hash-table-update!/default
+       hash-table-pop! hash-table-clear! hash-table-size hash-table-keys
+       hash-table-values hash-table-entries hash-table-find hash-table-count)
+  ) ;map
+) ;tm-define
+
+(tm-define (srfi-133-keywords)
+  (map symbol->string
+    '(vector-empty? vector-count vector-any vector-every vector-copy
+       vector-copy! vector-index vector-index-right vector-partition
+       vector-swap!)
+  ) ;map
+) ;tm-define
+
+(tm-define (srfi-151-keywords)
+  (map symbol->string
+    '(bitwise-not bitwise-and bitwise-ior bitwise-xor bitwise-or bitwise-nor
+       bitwise-nand bit-count arithmetic-shift)
+  ) ;map
+) ;tm-define
diff --git a/TeXmacs/plugins/scala/packages/code/scala.stem b/TeXmacs/plugins/scala/packages/code/scala.stem
new file mode 100644
index 0000000000..5e0c7de599
--- /dev/null
+++ b/TeXmacs/plugins/scala/packages/code/scala.stem
@@ -0,0 +1,34 @@
+(document (TeXmacs "2.1.2")
+  (style (tuple "source" "std"))
+  (body (document (active* (src-title (document (compound "src-package" "scala" "1.0")
+                                        (src-purpose (document "scala Language"))
+                                        (src-copyright "2020-2024" "Darcy Shen")
+                                        (src-license (document (concat "This software falls under the "
+                                                                 (hlink "GNU general public license, version 3 or later" "$TEXMACS_PATH/LICENSE")
+                                                                 ". It comes WITHOUT ANY WARRANTY WHATSOEVER. You should have received a copy of the license which the software. If not, see "
+                                                                 (hlink "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                   "http://www.gnu.org/licenses/gpl-3.0.html"
+                                                                 ) ;hlink
+                                                                 "."
+                                                               ) ;concat
+                                                     ) ;document
+                                        ) ;src-license
+                                      ) ;document
+                           ) ;src-title
+                  ) ;active*
+          (concat (use-module "(scala scala-format)")
+            " "
+            (use-module "(scala scala-edit)")
+          ) ;concat
+          (assign "scala"
+            (macro "body"
+              (with "mode" "prog" "prog-language" "scala" "font-family" "rm" (arg "body"))
+            ) ;macro
+          ) ;assign
+          (assign "scala-code"
+            (macro "body" (document (pseudo-code (document (scala (arg "body"))))))
+          ) ;assign
+        ) ;document
+  ) ;body
+  (initial (collection (associate "preamble" "true") (associate "sfactor" "5")))
+) ;document
diff --git a/TeXmacs/plugins/scala/packages/code/scala.ts b/TeXmacs/plugins/scala/packages/code/scala.ts
deleted file mode 100644
index 879a2f2ab8..0000000000
--- a/TeXmacs/plugins/scala/packages/code/scala.ts
+++ /dev/null
@@ -1,41 +0,0 @@
-
-
->
-
-<\body>
-  
-    
-
-    <\src-purpose>
-      scala Language
-    
-
-    
-
-    <\src-license>
-      This software falls under the . It comes WITHOUT ANY
-      WARRANTY WHATSOEVER. You should have received a copy of the license
-      which the software. If not, see .
-    
-  >
-
-  
-  
-
-  >>>
-
-  
-    <\pseudo-code>
-      >
-    
-  >
-
-
-<\initial>
-  <\collection>
-    
-    
-  
-
-
diff --git a/TeXmacs/plugins/scala/progs/code/scala-edit.scm b/TeXmacs/plugins/scala/progs/code/scala-edit.scm
deleted file mode 100644
index 5a4fbeb43e..0000000000
--- a/TeXmacs/plugins/scala/progs/code/scala-edit.scm
+++ /dev/null
@@ -1,23 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : scala-edit.scm
-;; DESCRIPTION : editing Scala programs
-;; COPYRIGHT   : (C) 2019  Darcy Shen
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (code scala-edit)
-  (:use (prog prog-edit)
-        (code scala-mode)))
-
-(tm-define (get-tabstop)
-  (:mode in-prog-scala?)
-  2)
-
-(tm-define (kbd-paste)
-  (:mode in-prog-scala?)
-  (clipboard-paste-import "scala" "primary"))
diff --git a/TeXmacs/plugins/scala/progs/code/scala-lang.scm b/TeXmacs/plugins/scala/progs/code/scala-lang.scm
deleted file mode 100644
index ec639f5526..0000000000
--- a/TeXmacs/plugins/scala/progs/code/scala-lang.scm
+++ /dev/null
@@ -1,89 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : scala-lang.scm
-;; DESCRIPTION : Scala Language
-;; COPYRIGHT   : (C) 2017-2020  Darcy Shen
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (code scala-lang)
-  (:use (prog default-lang)))
-
-;; https://www.scala-lang.org/files/archive/spec/2.13/13-syntax-summary.html
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "scala") (== key "keyword")))
-  `(,(string->symbol key)
-    (constant
-      "false" "true" "null"
-      "Byte" "Short" "Int" "Long" "Char" "String" "Float" "Double" "Boolean"
-      "Array" "List" "Map" "Set" "Function" "Class"
-      "aggregate" "collect" "map" "filter" "filterNot" "foreach" "forall" "fold"
-      "foldLeft" "foldRight" "reduce" "reduceLeft" "reduceRight" "scan" "scanLeft"
-      "scanRight" "zip" "unzip" "flatMap" "grouped" "groupBy"
-      "IllegalArgumentException" "NullPointerException" "Exception" "RuntimeException")
-    (declare_function "def")
-    (declare_type "type" "class" "object" "trait")
-    (declare_identifier "val" "var")
-    (declare_module "package" "import")
-    (keyword
-      "case"  "match" ;; Pattern Matching
-      "extends" "new" "with" "super" "this" ;; Object Oriented
-      "override" ;; Modifier
-      "abstract" "final" "sealed" "implicit" "lazy" ;; Local Modifiers
-      "private" "protected" ;; Access Modifiers
-      "requires" "synchronized")
-    (keyword_conditional
-      "break" "do" "else" "for" "if" "while")
-    (keyword_control
-      "throw" "catch" "finally" "return" "try" "yield")))
-
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "scala") (== key "operator")))
-  `(,(string->symbol key)
-    (operator
-      "+" "-" "/" "*" "%" ;; Arith
-      "|" "&" "^" ;; Bit
-      "&&" "||" "!" "==" "!=" "<" ">" "<=" ">=" ;; Boolean
-      ">>>" "<<" ">>"
-      "+=" "-=" "/=" "*=" "%=" "|=" "&=" "^=" ;; Assignment
-      "=" ";")
-    (operator_special
-      ":" "=>" "::" ":::" "++"
-      "+:" ":+" "++:" "/:" ":\\" "<-")
-    (operator_decoration "@")
-    (operator_field ".")
-    (operator_openclose "{" "[" "(" ")" "]" "}")))
-
-(define (scala-number-suffix)
-  `(suffix
-    (long "l" "L")
-    (double "d" "D")
-    (float "f" "F")))
-
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "scala") (== key "number")))
-  `(,(string->symbol key)
-    (bool_features
-     "prefix_0x" "prefix_0b"
-     "sci_notation")
-    ,(scala-number-suffix)))
-
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "scala") (== key "string")))
-  `(,(string->symbol key)
-    (bool_features
-     "hex_with_8_bits" "hex_with_16_bits"
-     "hex_with_32_bits" "octal_upto_3_digits")
-    (escape_sequences "\\" "\"" "'" "b" "f" "n" "r" "t")))
-
-;; array start_chars, extra_chars;
-;; // The ‘$’ character is reserved for compiler-synthesized identifiers.
-;; start_chars << '_' << '$';
-;; extra_chars << '_';
-;; identifier_parser.set_start_chars (start_chars);
-;; identifier_parser.set_extra_chars (extra_chars);
diff --git a/TeXmacs/plugins/scala/progs/code/scala-mode.scm b/TeXmacs/plugins/scala/progs/code/scala-mode.scm
deleted file mode 100644
index a999adba02..0000000000
--- a/TeXmacs/plugins/scala/progs/code/scala-mode.scm
+++ /dev/null
@@ -1,19 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : scala-lang.scm
-;; DESCRIPTION : Scala Language mode
-;; COPYRIGHT   : (C) 2017-2020  Darcy Shen
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (code scala-mode)
-  (:use (kernel texmacs tm-modes)))
-
-(texmacs-modes
-  (in-scala% (== (get-env "prog-language") "scala"))
-  (in-prog-scala% #t in-prog% in-scala%))
diff --git a/TeXmacs/plugins/scala/progs/data/scala.scm b/TeXmacs/plugins/scala/progs/data/scala.scm
deleted file mode 100644
index 67330f5770..0000000000
--- a/TeXmacs/plugins/scala/progs/data/scala.scm
+++ /dev/null
@@ -1,43 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : init-prog_scala.scm
-;; DESCRIPTION : prog format for Scala
-;; COPYRIGHT   : (C) 2022  Darcy Shen, Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (data scala))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Scala source files
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define-format scala
-  (:name "Scala source code")
-  (:suffix "scala" "sc" "sbt"))
-
-(define (texmacs->scala x . opts)
-  (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '())))
-
-(define (scala->texmacs x . opts)
-  (code->texmacs x))
-
-(define (scala-snippet->texmacs x . opts)
-  (code-snippet->texmacs x))
-
-(converter texmacs-tree scala-document
-  (:function texmacs->scala))
-
-(converter scala-document texmacs-tree
-  (:function scala->texmacs))
-  
-(converter texmacs-tree scala-snippet
-  (:function texmacs->scala))
-
-(converter scala-snippet texmacs-tree
-  (:function scala-snippet->texmacs))
diff --git a/TeXmacs/plugins/scala/progs/scala/scala-edit.scm b/TeXmacs/plugins/scala/progs/scala/scala-edit.scm
new file mode 100644
index 0000000000..3996dbebd7
--- /dev/null
+++ b/TeXmacs/plugins/scala/progs/scala/scala-edit.scm
@@ -0,0 +1,20 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : scala-edit.scm
+;; DESCRIPTION : editing Scala programs
+;; COPYRIGHT   : (C) 2019  Darcy Shen
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (scala scala-edit) (:use (prog prog-edit) (scala scala-mode)))
+
+(tm-define (get-tabstop) (:mode in-prog-scala?) 2)
+
+(tm-define (kbd-paste)
+  (:mode in-prog-scala?)
+  (clipboard-paste-import "scala" "primary")
+) ;tm-define
diff --git a/TeXmacs/plugins/scala/progs/scala/scala-format.scm b/TeXmacs/plugins/scala/progs/scala/scala-format.scm
new file mode 100644
index 0000000000..3bfe7eace4
--- /dev/null
+++ b/TeXmacs/plugins/scala/progs/scala/scala-format.scm
@@ -0,0 +1,40 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : init-prog_scala.scm
+;; DESCRIPTION : prog format for Scala
+;; COPYRIGHT   : (C) 2022  Darcy Shen, Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (scala scala-format))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Scala source files
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-format scala (:name "Scala source code") (:suffix "scala" "sc" "sbt"))
+
+(define (texmacs->scala x . opts)
+  (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '()))
+) ;define
+
+(define (scala->texmacs x . opts)
+  (code->texmacs x)
+) ;define
+
+(define (scala-snippet->texmacs x . opts)
+  (code-snippet->texmacs x)
+) ;define
+
+(converter texmacs-tree scala-document (:function texmacs->scala))
+
+(converter scala-document texmacs-tree (:function scala->texmacs))
+
+(converter texmacs-tree scala-snippet (:function texmacs->scala))
+
+(converter scala-snippet texmacs-tree (:function scala-snippet->texmacs))
diff --git a/TeXmacs/plugins/scala/progs/scala/scala-lang.scm b/TeXmacs/plugins/scala/progs/scala/scala-lang.scm
new file mode 100644
index 0000000000..fe7ba4be96
--- /dev/null
+++ b/TeXmacs/plugins/scala/progs/scala/scala-lang.scm
@@ -0,0 +1,124 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : scala-lang.scm
+;; DESCRIPTION : Scala Language
+;; COPYRIGHT   : (C) 2017-2020  Darcy Shen
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (scala scala-lang) (:use (prog default-lang)))
+
+;; https://www.scala-lang.org/files/archive/spec/2.13/13-syntax-summary.html
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "scala") (== key "keyword")))
+  `(,(string->symbol key)
+    (constant "false" "true" "null" "Byte" "Short" "Int" "Long" "Char" "String"
+      "Float" "Double" "Boolean" "Array" "List" "Map" "Set" "Function" "Class"
+      "aggregate" "collect" "map" "filter" "filterNot" "foreach" "forall" "fold"
+      "foldLeft" "foldRight" "reduce" "reduceLeft" "reduceRight" "scan"
+      "scanLeft" "scanRight" "zip" "unzip" "flatMap" "grouped" "groupBy"
+      "IllegalArgumentException" "NullPointerException" "Exception"
+      "RuntimeException")
+    (declare_function "def")
+    (declare_type "type" "class" "object" "trait")
+    (declare_identifier "val" "var")
+    (declare_module "package" "import")
+    (keyword "case"
+      "match"
+      ;; Pattern Matching
+      "extends"
+      "new"
+      "with"
+      "super"
+      "this"
+      ;; Object Oriented
+      "override"
+      ;; Modifier
+      "abstract"
+      "final"
+      "sealed"
+      "implicit"
+      "lazy"
+      ;; Local Modifiers
+      "private"
+      "protected"
+      ;; Access Modifiers
+      "requires"
+      "synchronized")
+    (keyword_conditional "break" "do" "else" "for" "if" "while")
+    (keyword_control "throw" "catch" "finally" "return" "try" "yield"))
+) ;tm-define
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "scala") (== key "operator")))
+  `(,(string->symbol key)
+    (operator "+"
+      "-"
+      "/"
+      "*"
+      "%"
+      ;; Arith
+      "|"
+      "&"
+      "^"
+      ;; Bit
+      "&&"
+      "||"
+      "!"
+      "=="
+      "!="
+      "<"
+      ">"
+      "<="
+      ">="
+      ;; Boolean
+      ">>>"
+      "<<"
+      ">>"
+      "+="
+      "-="
+      "/="
+      "*="
+      "%="
+      "|="
+      "&="
+      "^="
+      ;; Assignment
+      "="
+      ";")
+    (operator_special ":" "=>" "::" ":::" "++" "+:" ":+" "++:" "/:" ":\\" "<-")
+    (operator_decoration "@")
+    (operator_field ".")
+    (operator_openclose "{" "[" "(" ")" "]" "}"))
+) ;tm-define
+
+(define (scala-number-suffix)
+  '(suffix (long "l" "L") (double "d" "D") (float "f" "F"))
+) ;define
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "scala") (== key "number")))
+  `(,(string->symbol key)
+    (bool_features "prefix_0x" "prefix_0b" "sci_notation")
+    ,(scala-number-suffix))
+) ;tm-define
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "scala") (== key "string")))
+  `(,(string->symbol key)
+    (bool_features "hex_with_8_bits" "hex_with_16_bits" "hex_with_32_bits"
+      "octal_upto_3_digits")
+    (escape_sequences "\\" "\"" "'" "b" "f" "n" "r" "t"))
+) ;tm-define
+
+;; array start_chars, extra_chars;
+;; // The ‘$’ character is reserved for compiler-synthesized identifiers.
+;; start_chars << '_' << '$';
+;; extra_chars << '_';
+;; identifier_parser.set_start_chars (start_chars);
+;; identifier_parser.set_extra_chars (extra_chars);
diff --git a/TeXmacs/plugins/scala/progs/scala/scala-mode.scm b/TeXmacs/plugins/scala/progs/scala/scala-mode.scm
new file mode 100644
index 0000000000..8d4d34f3ad
--- /dev/null
+++ b/TeXmacs/plugins/scala/progs/scala/scala-mode.scm
@@ -0,0 +1,18 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : scala-lang.scm
+;; DESCRIPTION : Scala Language mode
+;; COPYRIGHT   : (C) 2017-2020  Darcy Shen
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (scala scala-mode) (:use (kernel texmacs tm-modes)))
+
+(texmacs-modes (in-scala% (== (get-env "prog-language") "scala"))
+  (in-prog-scala% #t in-prog% in-scala%)
+) ;texmacs-modes
diff --git a/TeXmacs/plugins/sql/packages/code/sql.stem b/TeXmacs/plugins/sql/packages/code/sql.stem
new file mode 100644
index 0000000000..64c74696df
--- /dev/null
+++ b/TeXmacs/plugins/sql/packages/code/sql.stem
@@ -0,0 +1,20 @@
+(document (TeXmacs "2.1.4")
+  (style (tuple "source" "std"))
+  (body (document (active* (src-title (document (compound "src-package" "sql" "1.0")
+                                        (src-purpose (document "SQL Language support for TeXmacs"))
+                                      ) ;document
+                           ) ;src-title
+                  ) ;active*
+          (concat (use-module "(sql sql-format)") " " (use-module "(sql sql-edit)"))
+          (assign "sql"
+            (macro "body"
+              (with "mode" "prog" "prog-language" "sql" "font-family" "rm" (arg "body"))
+            ) ;macro
+          ) ;assign
+          (assign "sql-code"
+            (macro "body" (document (pseudo-code (document (sql (arg "body"))))))
+          ) ;assign
+        ) ;document
+  ) ;body
+  (initial (collection (associate "preamble" "true") (associate "sfactor" "5")))
+) ;document
diff --git a/TeXmacs/plugins/sql/packages/code/sql.ts b/TeXmacs/plugins/sql/packages/code/sql.ts
deleted file mode 100644
index cf740ef720..0000000000
--- a/TeXmacs/plugins/sql/packages/code/sql.ts
+++ /dev/null
@@ -1,31 +0,0 @@
-
-
->
-
-<\body>
-  
-    
-
-    <\src-purpose>
-      SQL Language support for TeXmacs
-    
-  >
-
-  
-  
-
-  >>>
-
-  
-    <\pseudo-code>
-      >
-    
-  >
-
-
-<\initial>
-  <\collection>
-    
-    
-  
-
\ No newline at end of file
diff --git a/TeXmacs/plugins/sql/progs/code/sql-edit.scm b/TeXmacs/plugins/sql/progs/code/sql-edit.scm
deleted file mode 100644
index 38a2fbc5ba..0000000000
--- a/TeXmacs/plugins/sql/progs/code/sql-edit.scm
+++ /dev/null
@@ -1,146 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; MODULE      : sql-edit.scm
-;; DESCRIPTION : Editing SQL programs
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (code sql-edit)
-  (:use (prog prog-edit)
-        (code sql-mode)))
-
-(import (liii string))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Indentation settings
-;;
-;; SQL typically uses 2 or 4 spaces for indentation.
-;; Common SQL style guides recommend 2 spaces for compactness.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (sql-tabstop) 2)
-
-(tm-define (get-tabstop)
-  (:mode in-prog-sql?)
-  (sql-tabstop))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Basic indentation heuristics for SQL
-;;
-;; SQL indentation patterns:
-;; - Increase indent after SELECT (for multi-column lists), FROM (for subqueries)
-;; - Increase indent after JOIN, WHERE, GROUP BY, HAVING, ORDER BY
-;; - Increase indent after opening parenthesis '('
-;; - Decrease indent before closing parenthesis ')'
-;; - Decrease indent before keywords like END (for CASE statements)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define sql-increase-indent-keys
-  '("SELECT" "FROM" "WHERE" "JOIN" "INNER" "LEFT" "RIGHT" "FULL" "OUTER"
-    "GROUP" "HAVING" "ORDER" "WITH" "CASE" "WHEN" "AND" "OR"
-    "select" "from" "where" "join" "inner" "left" "right" "full" "outer"
-    "group" "having" "order" "with" "case" "when" "and" "or"))
-
-(define sql-decrease-indent-keys
-  '("END" "ELSE" "ELSEIF"
-    "end" "else" "elseif"))
-
-(define sql-end-keys
-  '(")" "END"
-        "end"))
-
-;; Trim whitespace from left side of string
-(define (string-strip-left s)
-  (with char-set:not-whitespace (char-set-complement char-set:whitespace)
-    (with n (string-length s)
-      (with r (or (string-index s char-set:not-whitespace) 0)
-        ; (string-take s (min n (+ 1 r)))
-        (substring s r n)))))
-
-;; Trim whitespace from right side of string
-(define (string-strip-right s)
-  (with char-set:not-whitespace (char-set-complement char-set:whitespace)
-    (with n (string-length s)
-      (with r (or (string-rindex s char-set:not-whitespace) n)
-        (string-take s (min n (+ 1 r)))))))
-
-(define (string-strip s) (string-strip-right (string-strip-left s)))
-
-;; Helper function to check if string ends with a keyword
-(define (ends-with-keyword? s keys)
-  (and (not (null? keys))
-       (or (string-ends? s (car keys))
-           (ends-with-keyword? s (cdr keys)))))
-
-;; Helper function to check if string starts with a keyword
-(define (starts-with-keyword? s keys)
-  (and (not (null? keys))
-       (or (string-starts? s (string-append (car keys) " "))
-           (starts-with-keyword? s (cdr keys)))))
-
-;; Get indentation level of a line (number of leading spaces)
-(define (string-get-indent s)
-  (let loop ((i 0) (n (string-length s)))
-    (if (or (>= i n) (not (char-whitespace? (string-ref s i))))
-        i
-        (loop (+ i 1) n))))
-
-;; Compute indentation for SQL code
-(tm-define (program-compute-indentation doc row col)
-  (:mode in-prog-sql?)
-  (if (<= row 0) 0
-      (let* ((prev-row (- row 1))
-             (prev-line (program-row prev-row))
-             (stripped-prev (string-strip-right (if prev-line prev-line "")))
-             (prev-indent (string-get-indent stripped-prev))
-             (tab-width (get-tabstop))
-             (current-line (program-row row))
-             (stripped-current (string-strip-left (if current-line current-line ""))))
-
-        ;; Check for parentheses
-        (let ((open-parens (string-count stripped-prev #\())
-              (close-parens (string-count stripped-prev #\))))
-          (cond
-            ;; If previous line has more open than close parens, increase indent
-            ((> open-parens close-parens)
-             (+ prev-indent tab-width))
-
-            ;; If previous line ends with increase-indent keyword
-            ((ends-with-keyword? stripped-prev sql-increase-indent-keys)
-             (+ prev-indent tab-width))
-
-            ;; If current line starts with decrease-indent keyword
-            ((starts-with-keyword? stripped-current sql-decrease-indent-keys)
-             (max 0 (- prev-indent tab-width)))
-
-            ;; If current line starts with closing paren or END keyword, decrease indent
-            ((or (and stripped-current (string-starts? stripped-current ")"))
-                 (starts-with-keyword? stripped-current sql-end-keys))
-             (max 0 (- prev-indent tab-width)))
-
-            ;; Otherwise maintain previous indent
-            (else prev-indent))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Bracket and quote handling
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (sql-bracket-open lbr rbr)
-  ;; Insert a pair of brackets/quotes and position cursor between them
-  (bracket-open lbr rbr "\\"))
-
-(tm-define (sql-bracket-close lbr rbr)
-  ;; Handle closing bracket/quote and position cursor appropriately
-  (bracket-close lbr rbr "\\"))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Comment toggling
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (program-comment-toggle)
-  (:mode in-prog-sql?)
-  ;; SQL uses -- for single-line comments
-  (program-comment-toggle-line "--"))
\ No newline at end of file
diff --git a/TeXmacs/plugins/sql/progs/code/sql-lang.scm b/TeXmacs/plugins/sql/progs/code/sql-lang.scm
deleted file mode 100644
index 52ccf07af1..0000000000
--- a/TeXmacs/plugins/sql/progs/code/sql-lang.scm
+++ /dev/null
@@ -1,242 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : sql-lang.scm
-;; DESCRIPTION : SQL Language support (syntax highlighting / parser features)
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (code sql-lang)
-  (:use (prog default-lang)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Keywords / identifiers
-;;
-;; SQL keywords categorized by function:
-;; - Data Query Language (DQL): SELECT, FROM, WHERE, etc.
-;; - Data Manipulation Language (DML): INSERT, UPDATE, DELETE, etc.
-;; - Data Definition Language (DDL): CREATE, DROP, ALTER, etc.
-;; - Data Control Language (DCL): GRANT, REVOKE, etc.
-;; - Transaction Control Language (TCL): COMMIT, ROLLBACK, etc.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "sql") (== key "keyword")))
-  `(,(string->symbol key)
-
-    ;; SQL constants
-    (constant
-      "TRUE" "FALSE" "NULL" "UNKNOWN"
-      "true" "false" "null" "unknown")
-
-    ;; SQL function and procedure declarations
-    (declare_function
-      "FUNCTION" "PROCEDURE"
-      "function" "procedure")
-
-    ;; SQL type and object declarations
-    (declare_type
-      "CREATE" "DROP" "ALTER" "TABLE" "VIEW" "INDEX" "SEQUENCE" "TRIGGER"
-      "TYPE" "DOMAIN" "CONSTRAINT"
-
-      "create" "drop" "alter" "table" "view" "index" "sequence" "trigger"
-      "type" "domain" "constraint")
-
-    ;; SQL module declarations (schemas, databases)
-    (declare_module
-      "SCHEMA" "DATABASE"
-      "schema" "database")
-
-    ;; SQL identifier declarations
-    (declare_identifier
-      "PRIMARY" "FOREIGN" "REFERENCES" "UNIQUE" "CHECK" "DEFAULT"
-      "NOT" "NULL" "AUTO_INCREMENT" "IDENTITY" "SERIAL" "BIGSERIAL"
-
-      "primary" "foreign" "references" "unique" "check" "default"
-      "not" "null" "auto_increment" "identity" "serial" "bigserial")
-
-    ;; General SQL keywords
-    (keyword
-      "SELECT" "FROM" "WHERE" "GROUP" "BY" "HAVING" "ORDER" "ASC" "DESC"
-      "DISTINCT" "AS" "ON" "USING" "WITH" "RECURSIVE"
-      "JOIN" "INNER" "LEFT" "RIGHT" "FULL" "OUTER" "CROSS" "NATURAL"
-      "INSERT" "INTO" "VALUES" "UPDATE" "SET" "DELETE" "MERGE" "UPSERT"
-      "GRANT" "REVOKE" "DENY"
-      "UNION" "INTERSECT" "EXCEPT" "MINUS" "LIMIT" "OFFSET" "FETCH" "NEXT"
-      "ONLY" "CAST" "COALESCE" "NULLIF" "IFNULL" "NVL" "KEY"
-
-      "select" "from" "where" "group" "by" "having" "order" "asc" "desc"
-      "distinct" "as" "on" "using" "with" "recursive"
-      "join" "inner" "left" "right" "full" "outer" "cross" "natural"
-      "insert" "into" "values" "update" "set" "delete" "merge" "upsert"
-      "grant" "revoke" "deny"
-      "union" "intersect" "except" "minus" "limit" "offset" "fetch" "next"
-      "only" "cast" "coalesce" "nullif" "ifnull" "nvl" "key")
-
-    ;; SQL conditional keywords
-    (keyword_conditional
-      "CASE" "WHEN" "THEN" "ELSE" "END"
-      "case" "when" "then" "else" "end")
-
-    ;; SQL control keywords (transactions, etc.)
-    (keyword_control
-      "BEGIN" "COMMIT" "ROLLBACK" "SAVEPOINT" "TRANSACTION"
-      "begin" "commit" "rollback" "savepoint" "transaction")
-
-    ;; SQL functions and aggregates (treated as keywords for highlighting)
-    (keyword
-      "COUNT" "SUM" "AVG" "MIN" "MAX" "ROUND" "TRUNC" "CEIL" "FLOOR"
-      "ABS" "MOD" "POWER" "SQRT" "EXP" "LOG" "LN" "SIN" "COS" "TAN"
-      "ASIN" "ACOS" "ATAN" "ATAN2" "RANDOM" "RAND" "NOW" "CURRENT_DATE"
-      "CURRENT_TIME" "CURRENT_TIMESTAMP" "DATE" "TIME" "TIMESTAMP"
-      "INTERVAL" "EXTRACT" "DATE_PART" "DATE_TRUNC" "TO_CHAR" "TO_DATE"
-      "TO_NUMBER" "TO_TIMESTAMP" "CONCAT" "SUBSTR" "SUBSTRING" "TRIM"
-      "LTRIM" "RTRIM" "UPPER" "LOWER" "INITCAP" "LENGTH" "CHAR_LENGTH"
-      "POSITION" "INSTR" "REPLACE" "TRANSLATE" "REGEXP_MATCH" "REGEXP_REPLACE"
-
-      "count" "sum" "avg" "min" "max" "round" "trunc" "ceil" "floor"
-      "abs" "mod" "power" "sqrt" "exp" "log" "ln" "sin" "cos" "tan"
-      "asin" "acos" "atan" "atan2" "random" "rand" "now" "current_date"
-      "current_time" "current_timestamp" "date" "time" "timestamp"
-      "interval" "extract" "date_part" "date_trunc" "to_char" "to_date"
-      "to_number" "to_timestamp" "concat" "substr" "substring" "trim"
-      "ltrim" "rtrim" "upper" "lower" "initcap" "length" "char_length"
-      "position" "instr" "replace" "translate" "regexp_match" "regexp_replace")
-
-    ;; SQL data types (treated as keywords for highlighting)
-    (keyword
-      "INT" "INTEGER" "SMALLINT" "BIGINT" "TINYINT" "MEDIUMINT" "DECIMAL"
-      "NUMERIC" "REAL" "FLOAT" "DOUBLE" "PRECISION" "BOOLEAN" "BOOL"
-      "CHAR" "CHARACTER" "VARCHAR" "TEXT" "CLOB" "BLOB" "BYTEA"
-      "DATE" "TIME" "TIMESTAMP" "DATETIME" "YEAR" "MONTH" "DAY"
-      "HOUR" "MINUTE" "SECOND" "INTERVAL" "ENUM" "SET" "JSON" "XML"
-      "UUID" "ARRAY" "RECORD" "ROW" "OBJECT"
-      
-      "int" "integer" "smallint" "bigint" "tinyint" "mediumint" "decimal"
-      "numeric" "real" "float" "double" "precision" "boolean" "bool"
-      "char" "character" "varchar" "text" "clob" "blob" "bytea"
-      "date" "time" "timestamp" "datetime" "year" "month" "day"
-      "hour" "minute" "second" "interval" "enum" "set" "json" "xml"
-      "uuid" "array" "record" "row" "object")))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Operators
-;;
-;; SQL operators include:
-;; - Arithmetic: + - * / %
-;; - Comparison: = <> != < <= > >=
-;; - Logical: AND OR NOT
-;; - String: || (concatenation in some dialects)
-;; - Bitwise: & | ^ ~ << >>
-;; - Special: LIKE, ILIKE, BETWEEN, IN, IS, IS NOT
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "sql") (== key "operator")))
-  `(,(string->symbol key)
-
-    ;; SQL operators
-    (operator
-      "+" "-" "*" "/" "%" "||"
-      "=" "<>" "!=" "<" "<=" ">" ">="
-      "&" "|" "^" "~" "<<" ">>"
-      "LIKE" "ILIKE" "BETWEEN" "IN" "IS" "EXISTS" "ANY" "ALL" "SOME" "AND" "OR" "NOT"
-      "like" "ilike" "between" "in" "is" "exists" "any" "all" "some" "and" "or" "not")
-
-    ;; Brackets / braces / parentheses
-    (operator_openclose
-      "{" "}" "(" ")" "[" "]" ";" "," ".")))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Numbers
-;;
-;; SQL numeric literals:
-;; - Decimal: 123, 123.456, .456, 123.
-;; - Scientific: 1.23e4, 1.23E-4
-;; - Hex: 0x1F, 0XFF (in some dialects)
-;; - Binary: 0b1010, 0B1010 (in some dialects)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "sql") (== key "number")))
-  `(,(string->symbol key)
-    (bool_features
-      ;; Hex prefix: 0x / 0X (MySQL, PostgreSQL)
-      "prefix_0x"
-      ;; Binary prefix: 0b / 0B (MySQL)
-      "prefix_0b"
-      ;; Scientific notation: e/E
-      "sci_notation")
-    (suffix
-      ;; No standard numeric suffixes in SQL
-      )))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Strings
-;;
-;; SQL strings:
-;; - Single-quoted: 'text'
-;; - Double-quoted: "text" (for identifiers in some dialects)
-;; - Escape sequences: \' \" \\ \n \r \t \b \f
-;; - Unicode escapes: \uXXXX, \UXXXXXXXX
-;; - Hex escapes: \xHH
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "sql") (== key "string")))
-  `(,(string->symbol key)
-    (bool_features
-      ;; Escape sequences after backslash
-      "escape_char_after_backslash"
-      ;; Unicode escapes
-      "unicode_escape"
-      ;; Hex escapes
-      "hex_escape")
-    (escape_sequences
-      "\\" "'" "\""
-      "a" "b" "f" "n" "r" "t" "v"
-      "x" "u" "U")))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Comments
-;;
-;; SQL comments:
-;; - Single line: -- (two hyphens)
-;; - Multi-line: /* ... */ (C-style)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "sql") (== key "comment")))
-  `(,(string->symbol key)
-    (inline "--")
-    (block_comment "/*" "*/")))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Preferences for syntax highlighting
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (notify-sql-syntax var val)
-  (syntax-read-preferences "sql"))
-
-(define-preferences
-  ("syntax:sql:none" "red" notify-sql-syntax)
-  ("syntax:sql:comment" "brown" notify-sql-syntax)
-  ("syntax:sql:error" "dark red" notify-sql-syntax)
-  ("syntax:sql:constant" "#4040c0" notify-sql-syntax)
-  ("syntax:sql:constant_number" "#3030b0" notify-sql-syntax)
-  ("syntax:sql:constant_string" "dark grey" notify-sql-syntax)
-  ("syntax:sql:constant_char" "#333333" notify-sql-syntax)
-  ("syntax:sql:declare_function" "#0000c0" notify-sql-syntax)
-  ("syntax:sql:declare_type" "#0000c0" notify-sql-syntax)
-  ("syntax:sql:declare_module" "#0000c0" notify-sql-syntax)
-  ("syntax:sql:declare_identifier" "#0000c0" notify-sql-syntax)
-  ("syntax:sql:operator" "#8b008b" notify-sql-syntax)
-  ("syntax:sql:operator_openclose" "#B02020" notify-sql-syntax)
-  ("syntax:sql:operator_field" "#888888" notify-sql-syntax)
-  ("syntax:sql:operator_special" "orange" notify-sql-syntax)
-  ("syntax:sql:keyword" "#309090" notify-sql-syntax)
-  ("syntax:sql:keyword_conditional" "#309090" notify-sql-syntax)
-  ("syntax:sql:keyword_control" "#008080ff" notify-sql-syntax))
\ No newline at end of file
diff --git a/TeXmacs/plugins/sql/progs/code/sql-mode.scm b/TeXmacs/plugins/sql/progs/code/sql-mode.scm
deleted file mode 100644
index c06f993d6e..0000000000
--- a/TeXmacs/plugins/sql/progs/code/sql-mode.scm
+++ /dev/null
@@ -1,16 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; MODULE      : sql-mode.scm
-;; DESCRIPTION : Mode predicate for SQL programs
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (code sql-mode)
-  (:use (kernel texmacs tm-modes)))
-
-(texmacs-modes
-  (in-sql% (== (get-env "prog-language") "sql"))
-  (in-prog-sql% #t in-prog% in-sql%))
\ No newline at end of file
diff --git a/TeXmacs/plugins/sql/progs/data/sql.scm b/TeXmacs/plugins/sql/progs/data/sql.scm
deleted file mode 100644
index dd6a1fe213..0000000000
--- a/TeXmacs/plugins/sql/progs/data/sql.scm
+++ /dev/null
@@ -1,41 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; MODULE      : sql.scm
-;; DESCRIPTION : SQL format definition
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (data sql))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; SQL source files
-;; Common extensions: .sql (standard), .ddl, .dml, .pks, .pkb (Oracle)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define-format sql
-  (:name "SQL source code")
-  (:suffix "sql" "SQL" "ddl" "dml"))
-
-(define (texmacs->sql x . opts)
-  (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '())))
-
-(define (sql->texmacs x . opts)
-  (code->texmacs x))
-
-(define (sql-snippet->texmacs x . opts)
-  (code-snippet->texmacs x))
-
-(converter texmacs-tree sql-document
-  (:function texmacs->sql))
-
-(converter sql-document texmacs-tree
-  (:function sql->texmacs))
-
-(converter texmacs-tree sql-snippet
-  (:function texmacs->sql))
-
-(converter sql-snippet texmacs-tree
-  (:function sql-snippet->texmacs))
\ No newline at end of file
diff --git a/TeXmacs/plugins/sql/progs/sql/sql-edit.scm b/TeXmacs/plugins/sql/progs/sql/sql-edit.scm
new file mode 100644
index 0000000000..5ee201c85e
--- /dev/null
+++ b/TeXmacs/plugins/sql/progs/sql/sql-edit.scm
@@ -0,0 +1,175 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; MODULE      : sql-edit.scm
+;; DESCRIPTION : Editing SQL programs
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (sql sql-edit) (:use (prog prog-edit) (sql sql-mode)))
+
+(import (liii string))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Indentation settings
+;;
+;; SQL typically uses 2 or 4 spaces for indentation.
+;; Common SQL style guides recommend 2 spaces for compactness.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (sql-tabstop) 2)
+
+(tm-define (get-tabstop) (:mode in-prog-sql?) (sql-tabstop))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Basic indentation heuristics for SQL
+;;
+;; SQL indentation patterns:
+;; - Increase indent after SELECT (for multi-column lists), FROM (for subqueries)
+;; - Increase indent after JOIN, WHERE, GROUP BY, HAVING, ORDER BY
+;; - Increase indent after opening parenthesis '('
+;; - Decrease indent before closing parenthesis ')'
+;; - Decrease indent before keywords like END (for CASE statements)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define sql-increase-indent-keys
+  '("SELECT" "FROM" "WHERE" "JOIN" "INNER" "LEFT" "RIGHT" "FULL" "OUTER" "GROUP"
+    "HAVING" "ORDER" "WITH" "CASE" "WHEN" "AND" "OR" "select" "from" "where"
+    "join" "inner" "left" "right" "full" "outer" "group" "having" "order" "with"
+    "case" "when" "and" "or")
+) ;define
+
+(define sql-decrease-indent-keys '("END" "ELSE" "ELSEIF" "end" "else" "elseif"))
+
+(define sql-end-keys '(")" "END" "end"))
+
+;; Trim whitespace from left side of string
+
+(define (string-strip-left s)
+  (with char-set:not-whitespace
+    (char-set-complement char-set:whitespace)
+    (with n
+      (string-length s)
+      (with r (or (string-index s char-set:not-whitespace) 0) (substring s r n))
+    ) ;with
+  ) ;with
+) ;define
+
+;; Trim whitespace from right side of string
+
+(define (string-strip-right s)
+  (with char-set:not-whitespace
+    (char-set-complement char-set:whitespace)
+    (with n
+      (string-length s)
+      (with r
+        (or (string-rindex s char-set:not-whitespace) n)
+        (string-take s (min n (+ 1 r)))
+      ) ;with
+    ) ;with
+  ) ;with
+) ;define
+
+(define (string-strip s)
+  (string-strip-right (string-strip-left s))
+) ;define
+
+;; Helper function to check if string ends with a keyword
+
+(define (ends-with-keyword? s keys)
+  (and (not (null? keys))
+    (or (string-ends? s (car keys)) (ends-with-keyword? s (cdr keys)))
+  ) ;and
+) ;define
+
+;; Helper function to check if string starts with a keyword
+
+(define (starts-with-keyword? s keys)
+  (and (not (null? keys))
+    (or (string-starts? s (string-append (car keys) " "))
+      (starts-with-keyword? s (cdr keys))
+    ) ;or
+  ) ;and
+) ;define
+
+;; Get indentation level of a line (number of leading spaces)
+
+(define (string-get-indent s)
+  (let loop
+    ((i 0) (n (string-length s)))
+    (if (or (>= i n) (not (char-whitespace? (string-ref s i)))) i (loop (+ i 1) n))
+  ) ;let
+) ;define
+
+;; Compute indentation for SQL code
+(tm-define (program-compute-indentation doc row col)
+  (:mode in-prog-sql?)
+  (if (<= row 0)
+    0
+    (let* ((prev-row (- row 1))
+           (prev-line (program-row prev-row))
+           (stripped-prev (string-strip-right (if prev-line prev-line "")))
+           (prev-indent (string-get-indent stripped-prev))
+           (tab-width (get-tabstop))
+           (current-line (program-row row))
+           (stripped-current (string-strip-left (if current-line current-line "")))
+          ) ;
+
+      ;; Check for parentheses
+      (let ((open-parens (string-count stripped-prev #\())
+            (close-parens (string-count stripped-prev #\)))
+           ) ;
+        (cond
+          ;; If previous line has more open than close parens, increase indent
+          ((> open-parens close-parens) (+ prev-indent tab-width))
+
+          ;; If previous line ends with increase-indent keyword
+          ((ends-with-keyword? stripped-prev sql-increase-indent-keys)
+           (+ prev-indent tab-width)
+          ) ;
+
+          ;; If current line starts with decrease-indent keyword
+          ((starts-with-keyword? stripped-current sql-decrease-indent-keys)
+           (max 0 (- prev-indent tab-width))
+          ) ;
+
+          ;; If current line starts with closing paren or END keyword, decrease indent
+          ((or (and stripped-current (string-starts? stripped-current ")"))
+             (starts-with-keyword? stripped-current sql-end-keys)
+           ) ;or
+           (max 0 (- prev-indent tab-width))
+          ) ;
+
+          ;; Otherwise maintain previous indent
+          (else prev-indent)
+        ) ;cond
+      ) ;let
+    ) ;let*
+  ) ;if
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Bracket and quote handling
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (sql-bracket-open lbr rbr)
+  ;; Insert a pair of brackets/quotes and position cursor between them
+  (bracket-open lbr rbr "\\")
+) ;tm-define
+
+(tm-define (sql-bracket-close lbr rbr)
+  ;; Handle closing bracket/quote and position cursor appropriately
+  (bracket-close lbr rbr "\\")
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Comment toggling
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (program-comment-toggle)
+  (:mode in-prog-sql?)
+  ;; SQL uses -- for single-line comments
+  (program-comment-toggle-line "--")
+) ;tm-define
diff --git a/TeXmacs/plugins/sql/progs/sql/sql-format.scm b/TeXmacs/plugins/sql/progs/sql/sql-format.scm
new file mode 100644
index 0000000000..1b0861f366
--- /dev/null
+++ b/TeXmacs/plugins/sql/progs/sql/sql-format.scm
@@ -0,0 +1,38 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; MODULE      : sql.scm
+;; DESCRIPTION : SQL format definition
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (sql sql-format))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; SQL source files
+;; Common extensions: .sql (standard), .ddl, .dml, .pks, .pkb (Oracle)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-format sql (:name "SQL source code") (:suffix "sql" "SQL" "ddl" "dml"))
+
+(define (texmacs->sql x . opts)
+  (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '()))
+) ;define
+
+(define (sql->texmacs x . opts)
+  (code->texmacs x)
+) ;define
+
+(define (sql-snippet->texmacs x . opts)
+  (code-snippet->texmacs x)
+) ;define
+
+(converter texmacs-tree sql-document (:function texmacs->sql))
+
+(converter sql-document texmacs-tree (:function sql->texmacs))
+
+(converter texmacs-tree sql-snippet (:function texmacs->sql))
+
+(converter sql-snippet texmacs-tree (:function sql-snippet->texmacs))
diff --git a/TeXmacs/plugins/sql/progs/sql/sql-lang.scm b/TeXmacs/plugins/sql/progs/sql/sql-lang.scm
new file mode 100644
index 0000000000..c7949382b1
--- /dev/null
+++ b/TeXmacs/plugins/sql/progs/sql/sql-lang.scm
@@ -0,0 +1,201 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : sql-lang.scm
+;; DESCRIPTION : SQL Language support (syntax highlighting / parser features)
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (sql sql-lang) (:use (prog default-lang)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Keywords / identifiers
+;;
+;; SQL keywords categorized by function:
+;; - Data Query Language (DQL): SELECT, FROM, WHERE, etc.
+;; - Data Manipulation Language (DML): INSERT, UPDATE, DELETE, etc.
+;; - Data Definition Language (DDL): CREATE, DROP, ALTER, etc.
+;; - Data Control Language (DCL): GRANT, REVOKE, etc.
+;; - Transaction Control Language (TCL): COMMIT, ROLLBACK, etc.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "sql") (== key "keyword")))
+  `(,(string->symbol key)
+    ;; SQL constants
+    (constant "TRUE" "FALSE" "NULL" "UNKNOWN" "true" "false" "null" "unknown")
+    ;; SQL function and procedure declarations
+    (declare_function "FUNCTION" "PROCEDURE" "function" "procedure")
+    ;; SQL type and object declarations
+    (declare_type "CREATE" "DROP" "ALTER" "TABLE" "VIEW" "INDEX" "SEQUENCE"
+      "TRIGGER" "TYPE" "DOMAIN" "CONSTRAINT" "create" "drop" "alter" "table"
+      "view" "index" "sequence" "trigger" "type" "domain" "constraint")
+    ;; SQL module declarations (schemas, databases)
+    (declare_module "SCHEMA" "DATABASE" "schema" "database")
+    ;; SQL identifier declarations
+    (declare_identifier "PRIMARY" "FOREIGN" "REFERENCES" "UNIQUE" "CHECK"
+      "DEFAULT" "NOT" "NULL" "AUTO_INCREMENT" "IDENTITY" "SERIAL" "BIGSERIAL"
+      "primary" "foreign" "references" "unique" "check" "default" "not" "null"
+      "auto_increment" "identity" "serial" "bigserial")
+    ;; General SQL keywords
+    (keyword "SELECT" "FROM" "WHERE" "GROUP" "BY" "HAVING" "ORDER" "ASC" "DESC"
+      "DISTINCT" "AS" "ON" "USING" "WITH" "RECURSIVE" "JOIN" "INNER" "LEFT"
+      "RIGHT" "FULL" "OUTER" "CROSS" "NATURAL" "INSERT" "INTO" "VALUES" "UPDATE"
+      "SET" "DELETE" "MERGE" "UPSERT" "GRANT" "REVOKE" "DENY" "UNION"
+      "INTERSECT" "EXCEPT" "MINUS" "LIMIT" "OFFSET" "FETCH" "NEXT" "ONLY" "CAST"
+      "COALESCE" "NULLIF" "IFNULL" "NVL" "KEY" "select" "from" "where" "group"
+      "by" "having" "order" "asc" "desc" "distinct" "as" "on" "using" "with"
+      "recursive" "join" "inner" "left" "right" "full" "outer" "cross" "natural"
+      "insert" "into" "values" "update" "set" "delete" "merge" "upsert" "grant"
+      "revoke" "deny" "union" "intersect" "except" "minus" "limit" "offset"
+      "fetch" "next" "only" "cast" "coalesce" "nullif" "ifnull" "nvl" "key")
+    ;; SQL conditional keywords
+    (keyword_conditional "CASE" "WHEN" "THEN" "ELSE" "END" "case" "when" "then"
+      "else" "end")
+    ;; SQL control keywords (transactions, etc.)
+    (keyword_control "BEGIN" "COMMIT" "ROLLBACK" "SAVEPOINT" "TRANSACTION"
+      "begin" "commit" "rollback" "savepoint" "transaction")
+    ;; SQL functions and aggregates (treated as keywords for highlighting)
+    (keyword "COUNT" "SUM" "AVG" "MIN" "MAX" "ROUND" "TRUNC" "CEIL" "FLOOR"
+      "ABS" "MOD" "POWER" "SQRT" "EXP" "LOG" "LN" "SIN" "COS" "TAN" "ASIN"
+      "ACOS" "ATAN" "ATAN2" "RANDOM" "RAND" "NOW" "CURRENT_DATE" "CURRENT_TIME"
+      "CURRENT_TIMESTAMP" "DATE" "TIME" "TIMESTAMP" "INTERVAL" "EXTRACT"
+      "DATE_PART" "DATE_TRUNC" "TO_CHAR" "TO_DATE" "TO_NUMBER" "TO_TIMESTAMP"
+      "CONCAT" "SUBSTR" "SUBSTRING" "TRIM" "LTRIM" "RTRIM" "UPPER" "LOWER"
+      "INITCAP" "LENGTH" "CHAR_LENGTH" "POSITION" "INSTR" "REPLACE" "TRANSLATE"
+      "REGEXP_MATCH" "REGEXP_REPLACE" "count" "sum" "avg" "min" "max" "round"
+      "trunc" "ceil" "floor" "abs" "mod" "power" "sqrt" "exp" "log" "ln" "sin"
+      "cos" "tan" "asin" "acos" "atan" "atan2" "random" "rand" "now"
+      "current_date" "current_time" "current_timestamp" "date" "time"
+      "timestamp" "interval" "extract" "date_part" "date_trunc" "to_char"
+      "to_date" "to_number" "to_timestamp" "concat" "substr" "substring" "trim"
+      "ltrim" "rtrim" "upper" "lower" "initcap" "length" "char_length"
+      "position" "instr" "replace" "translate" "regexp_match" "regexp_replace")
+    ;; SQL data types (treated as keywords for highlighting)
+    (keyword "INT" "INTEGER" "SMALLINT" "BIGINT" "TINYINT" "MEDIUMINT" "DECIMAL"
+      "NUMERIC" "REAL" "FLOAT" "DOUBLE" "PRECISION" "BOOLEAN" "BOOL" "CHAR"
+      "CHARACTER" "VARCHAR" "TEXT" "CLOB" "BLOB" "BYTEA" "DATE" "TIME"
+      "TIMESTAMP" "DATETIME" "YEAR" "MONTH" "DAY" "HOUR" "MINUTE" "SECOND"
+      "INTERVAL" "ENUM" "SET" "JSON" "XML" "UUID" "ARRAY" "RECORD" "ROW"
+      "OBJECT" "int" "integer" "smallint" "bigint" "tinyint" "mediumint"
+      "decimal" "numeric" "real" "float" "double" "precision" "boolean" "bool"
+      "char" "character" "varchar" "text" "clob" "blob" "bytea" "date" "time"
+      "timestamp" "datetime" "year" "month" "day" "hour" "minute" "second"
+      "interval" "enum" "set" "json" "xml" "uuid" "array" "record" "row"
+      "object"))
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Operators
+;;
+;; SQL operators include:
+;; - Arithmetic: + - * / %
+;; - Comparison: = <> != < <= > >=
+;; - Logical: AND OR NOT
+;; - String: || (concatenation in some dialects)
+;; - Bitwise: & | ^ ~ << >>
+;; - Special: LIKE, ILIKE, BETWEEN, IN, IS, IS NOT
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "sql") (== key "operator")))
+  `(,(string->symbol key)
+    ;; SQL operators
+    (operator "+" "-" "*" "/" "%" "||" "=" "<>" "!=" "<" "<=" ">" ">=" "&" "|"
+      "^" "~" "<<" ">>" "LIKE" "ILIKE" "BETWEEN" "IN" "IS" "EXISTS" "ANY" "ALL"
+      "SOME" "AND" "OR" "NOT" "like" "ilike" "between" "in" "is" "exists" "any"
+      "all" "some" "and" "or" "not")
+    ;; Brackets / braces / parentheses
+    (operator_openclose "{" "}" "(" ")" "[" "]" ";" "," "."))
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Numbers
+;;
+;; SQL numeric literals:
+;; - Decimal: 123, 123.456, .456, 123.
+;; - Scientific: 1.23e4, 1.23E-4
+;; - Hex: 0x1F, 0XFF (in some dialects)
+;; - Binary: 0b1010, 0B1010 (in some dialects)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "sql") (== key "number")))
+  `(,(string->symbol key)
+    (bool_features ;; Hex prefix: 0x / 0X (MySQL, PostgreSQL)
+      "prefix_0x"
+      ;; Binary prefix: 0b / 0B (MySQL)
+      "prefix_0b"
+      ;; Scientific notation: e/E
+      "sci_notation")
+    (suffix)
+    ;; No standard numeric suffixes in SQL
+   )
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Strings
+;;
+;; SQL strings:
+;; - Single-quoted: 'text'
+;; - Double-quoted: "text" (for identifiers in some dialects)
+;; - Escape sequences: \' \" \\ \n \r \t \b \f
+;; - Unicode escapes: \uXXXX, \UXXXXXXXX
+;; - Hex escapes: \xHH
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "sql") (== key "string")))
+  `(,(string->symbol key)
+    (bool_features ;; Escape sequences after backslash
+      "escape_char_after_backslash"
+      ;; Unicode escapes
+      "unicode_escape"
+      ;; Hex escapes
+      "hex_escape")
+    (escape_sequences "\\" "'" "\"" "a" "b" "f" "n" "r" "t" "v" "x" "u" "U"))
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Comments
+;;
+;; SQL comments:
+;; - Single line: -- (two hyphens)
+;; - Multi-line: /* ... */ (C-style)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "sql") (== key "comment")))
+  `(,(string->symbol key) (inline "--") (block_comment "/*" "*/"))
+) ;tm-define
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Preferences for syntax highlighting
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (notify-sql-syntax var val)
+  (syntax-read-preferences "sql")
+) ;define
+
+(define-preferences ("syntax:sql:none" "red" notify-sql-syntax)
+ ("syntax:sql:comment" "brown" notify-sql-syntax)
+ ("syntax:sql:error" "dark red" notify-sql-syntax)
+ ("syntax:sql:constant" "#4040c0" notify-sql-syntax)
+ ("syntax:sql:constant_number" "#3030b0" notify-sql-syntax)
+ ("syntax:sql:constant_string" "dark grey" notify-sql-syntax)
+ ("syntax:sql:constant_char" "#333333" notify-sql-syntax)
+ ("syntax:sql:declare_function" "#0000c0" notify-sql-syntax)
+ ("syntax:sql:declare_type" "#0000c0" notify-sql-syntax)
+ ("syntax:sql:declare_module" "#0000c0" notify-sql-syntax)
+ ("syntax:sql:declare_identifier" "#0000c0" notify-sql-syntax)
+ ("syntax:sql:operator" "#8b008b" notify-sql-syntax)
+ ("syntax:sql:operator_openclose" "#B02020" notify-sql-syntax)
+ ("syntax:sql:operator_field" "#888888" notify-sql-syntax)
+ ("syntax:sql:operator_special" "orange" notify-sql-syntax)
+ ("syntax:sql:keyword" "#309090" notify-sql-syntax)
+ ("syntax:sql:keyword_conditional" "#309090" notify-sql-syntax)
+ ("syntax:sql:keyword_control" "#008080ff" notify-sql-syntax)
+) ;define-preferences
diff --git a/TeXmacs/plugins/sql/progs/sql/sql-mode.scm b/TeXmacs/plugins/sql/progs/sql/sql-mode.scm
new file mode 100644
index 0000000000..ba38627516
--- /dev/null
+++ b/TeXmacs/plugins/sql/progs/sql/sql-mode.scm
@@ -0,0 +1,15 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; MODULE      : sql-mode.scm
+;; DESCRIPTION : Mode predicate for SQL programs
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (sql sql-mode) (:use (kernel texmacs tm-modes)))
+
+(texmacs-modes (in-sql% (== (get-env "prog-language") "sql"))
+  (in-prog-sql% #t in-prog% in-sql%)
+) ;texmacs-modes
diff --git a/TeXmacs/plugins/stem/progs/data/stem.scm b/TeXmacs/plugins/stem/progs/data/stem.scm
deleted file mode 100644
index 4f8ea91ab7..0000000000
--- a/TeXmacs/plugins/stem/progs/data/stem.scm
+++ /dev/null
@@ -1,48 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : data/stem.scm
-;; DESCRIPTION : STEM (.stem) data format
-;; COPYRIGHT   : (C) 2025  Darcy Shen
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (data stem))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Scheme format for TeXmacs source files (no information loss)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (stem-recognizes? s)
-  (and (string? s) (string-starts? s "(document (TeXmacs"))
-) ;define
-
-(define-format stem
-  (:name "STEM")
-  (:suffix "stem")
-  (:must-recognize stem-recognizes?)
-) ;define-format
-
-(define (texmacs->stem t)
-  (texmacs->stm (herk-tree->utf8-tree t))
-) ;define
-
-(define (stem->texmacs text)
-  (utf8-tree->herk-tree (stm->texmacs text))
-) ;define
-
-(define (stem-snippet->texmacs text)
-  (utf8-tree->herk-tree (stm-snippet->texmacs text))
-) ;define
-
-(converter texmacs-tree stem-document (:function texmacs->stem))
-
-(converter stem-document texmacs-tree (:function stem->texmacs))
-
-(converter texmacs-tree stem-snippet (:function texmacs->stem))
-
-(converter stem-snippet texmacs-tree (:function stem-snippet->texmacs))
diff --git a/TeXmacs/plugins/stem/progs/stem/stem-format.scm b/TeXmacs/plugins/stem/progs/stem/stem-format.scm
new file mode 100644
index 0000000000..6083ebe33b
--- /dev/null
+++ b/TeXmacs/plugins/stem/progs/stem/stem-format.scm
@@ -0,0 +1,40 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : data/stem.scm
+;; DESCRIPTION : STEM (.stem) data format
+;; COPYRIGHT   : (C) 2025  Darcy Shen
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (stem stem-format))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Scheme format for TeXmacs source files (no information loss)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-format stem (:name "STEM") (:suffix "stem"))
+
+(define (texmacs->stem t)
+  (texmacs->stm (herk-tree->utf8-tree t))
+) ;define
+
+(define (stem->texmacs text)
+  (utf8-tree->herk-tree (stm->texmacs text))
+) ;define
+
+(define (stem-snippet->texmacs text)
+  (utf8-tree->herk-tree (stm-snippet->texmacs text))
+) ;define
+
+(converter texmacs-tree stem-document (:function texmacs->stem))
+
+(converter stem-document texmacs-tree (:function stem->texmacs))
+
+(converter texmacs-tree stem-snippet (:function texmacs->stem))
+
+(converter stem-snippet texmacs-tree (:function stem-snippet->texmacs))
diff --git a/TeXmacs/plugins/stm/progs/data/stm.scm b/TeXmacs/plugins/stm/progs/data/stm.scm
deleted file mode 100644
index 2a3d004ea4..0000000000
--- a/TeXmacs/plugins/stm/progs/data/stm.scm
+++ /dev/null
@@ -1,38 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : data/stm.scm
-;; DESCRIPTION : stm data format
-;; COPYRIGHT   : (C) 2003  Joris van der Hoeven
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (data stm))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Scheme format for TeXmacs (no information loss)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (stm-recognizes? s)
-  (and (string? s) (string-starts? s "(document (TeXmacs")))
-
-(define-format stm
-  (:name "TeXmacs Scheme")
-  (:suffix "stm")
-  (:must-recognize stm-recognizes?))
-
-(converter texmacs-tree stm-document
-  (:function texmacs->stm))
-
-(converter stm-document texmacs-tree
-  (:function stm->texmacs))
-
-(converter texmacs-tree stm-snippet
-  (:function texmacs->stm))
-
-(converter stm-snippet texmacs-tree
-  (:function stm-snippet->texmacs))
diff --git a/TeXmacs/plugins/stm/progs/stm/stm-format.scm b/TeXmacs/plugins/stm/progs/stm/stm-format.scm
new file mode 100644
index 0000000000..dbc65d57cd
--- /dev/null
+++ b/TeXmacs/plugins/stm/progs/stm/stm-format.scm
@@ -0,0 +1,36 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : data/stm.scm
+;; DESCRIPTION : stm data format
+;; COPYRIGHT   : (C) 2003  Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (stm stm-format))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Scheme format for TeXmacs (no information loss)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (stm-recognizes? s)
+  (and (string? s) (string-starts? s "(document (TeXmacs"))
+) ;define
+
+(define-format stm
+  (:name "TeXmacs Scheme")
+  (:suffix "stm")
+  (:must-recognize stm-recognizes?)
+) ;define-format
+
+(converter texmacs-tree stm-document (:function texmacs->stm))
+
+(converter stm-document texmacs-tree (:function stm->texmacs))
+
+(converter texmacs-tree stm-snippet (:function texmacs->stm))
+
+(converter stm-snippet texmacs-tree (:function stm-snippet->texmacs))
diff --git a/TeXmacs/plugins/telemetry/progs/init-telemetry.scm b/TeXmacs/plugins/telemetry/progs/init-telemetry.scm
index 0afbb8ae3d..591d88aa16 100644
--- a/TeXmacs/plugins/telemetry/progs/init-telemetry.scm
+++ b/TeXmacs/plugins/telemetry/progs/init-telemetry.scm
@@ -12,7 +12,10 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (use-modules (binary goldfish))
-(use-modules (plugin telemetry))
+(use-modules (telemetry telemetry-utils)
+  (telemetry telemetry-track)
+  (telemetry telemetry-init)
+) ;use-modules
 (import (liii path))
 
 (define (telemetry-serialize lan t)
@@ -46,9 +49,9 @@
   (:serializer ,telemetry-serialize)
 ) ;plugin-configure
 
-;; 启动初始化与周期 flush 调度由插件懒加载触发（插件在事件循环启动
-;; ~3s 后由 lazy-plugin-initialize 加载，因此 telemetry-clean-orphans、
-;; on-exit CLOSE 上报、周期 flush 均不在启动关键路径上）
+;; 启动初始化与周期 flush 调度：telemetry 与文档无关，lazy-plugin-initialize
+;; 对其直接初始化（不走 idle 延迟），故 telemetry-clean-orphans、on-exit
+;; CLOSE 上报、周期 flush 在启动时即注册
 (catch #t
   (lambda () (init-telemetry))
   (lambda args
@@ -56,7 +59,7 @@
           ) ;msg
          ) ;
       (display msg (current-error-port))
-      (force-output (current-error-port))
+      (flush-output-port (current-error-port))
     ) ;let
   ) ;lambda
 ) ;catch
diff --git a/TeXmacs/plugins/telemetry/progs/plugin/init-telemetry.scm b/TeXmacs/plugins/telemetry/progs/plugin/init-telemetry.scm
deleted file mode 100644
index 11cd8ed2d4..0000000000
--- a/TeXmacs/plugins/telemetry/progs/plugin/init-telemetry.scm
+++ /dev/null
@@ -1,92 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : init-telemetry.scm
-;; DESCRIPTION : Telemetry initialization and periodic flush
-;; COPYRIGHT   : (C) 2026 Yuki Lu
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (plugin init-telemetry)
-  (:use (plugin telemetry-track) (plugin telemetry-utils))
-) ;texmacs-module
-
-(import (scheme base))
-
-(define telemetry-scheduled? #f)
-
-(define (telemetry-scheduler-step)
-  (when (telemetry-enabled?)
-    (telemetry-flush-if-needed)
-  ) ;when
-  (telemetry-delayed)
-) ;define
-
-(define (telemetry-delayed)
-  (delayed (:pause (telemetry-get-flush-interval)) (telemetry-scheduler-step))
-) ;define
-
-(define (telemetry-clean-orphans)
-  ;; 启动时清理：删除不在 meta 列表中的孤儿 jsonl
-  (let* ((meta (telemetry-read-meta))
-         (valid-files (map (lambda (e) (assoc-ref e "filename")) meta))
-         (dir-url (system->url (telemetry-main-dir)))
-         (pattern (url-append dir-url (url-wildcard "*.jsonl")))
-         (files (url->list (url-expand (url-complete pattern "fr"))))
-        ) ;
-    (for-each (lambda (f)
-                (let ((fname (url->string (url-tail f))))
-                  (when (and (string-starts? fname "detail-telemetry-")
-                          (not (member fname valid-files))
-                        ) ;and
-                    (catch #t (lambda () (path-unlink (url->system f))) (lambda args #f))
-                  ) ;when
-                ) ;let
-              ) ;lambda
-      files
-    ) ;for-each
-  ) ;let*
-) ;define
-
-(tm-define (init-telemetry)
-  ;; 先消费 *telemetry-pending*：插件加载前 C++ 上报入队的事件在此一次性
-  ;; 补 track（若 telemetry-disabled?，track-event 内部会直接返回 #f，
-  ;; 符合预期）。drain 完成后清空 pending，后续上报走 track-event 直接路径。
-  ;; telemetry-drain-pending! 注入在 rootlet，这里直接调用。
-  (telemetry-drain-pending!)
-  (if telemetry-scheduled?
-    (debug-message "debug-events" "[telemetry] init: already initialized\n")
-    (if (telemetry-enabled?)
-      (begin
-        (telemetry-clean-orphans)
-        (set! telemetry-scheduled? #t)
-        (debug-message "debug-events"
-          (string-append "[telemetry] init: enabled, buffer="
-            (number->string (telemetry-get-buffer-size))
-            ", interval="
-            (number->string (telemetry-get-flush-interval))
-            "ms\n"
-          ) ;string-append
-        ) ;debug-message
-        (on-exit (catch #t
-                   (lambda () (track-event "CLOSE" '()) (telemetry-flush-if-needed))
-                   (lambda args
-                     (debug-message "debug-events"
-                       (string-append "[telemetry] error: exit flush failed: "
-                         (object->string args)
-                         "\n"
-                       ) ;string-append
-                     ) ;debug-message
-                   ) ;lambda
-                 ) ;catch
-        ) ;on-exit
-        (telemetry-delayed)
-      ) ;begin
-      (debug-message "debug-events" "[telemetry] init: disabled\n")
-    ) ;if
-  ) ;if
-) ;define-public
diff --git a/TeXmacs/plugins/telemetry/progs/plugin/telemetry.scm b/TeXmacs/plugins/telemetry/progs/plugin/telemetry.scm
deleted file mode 100644
index a3e7976bfe..0000000000
--- a/TeXmacs/plugins/telemetry/progs/plugin/telemetry.scm
+++ /dev/null
@@ -1,29 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : telemetry.scm
-;; DESCRIPTION : Entry point of the (plugin telemetry) module
-;;
-;; This module serves as the entry point loaded by init-telemetry.scm.
-;; It MUST NOT contain (import ...) statements.
-;;
-;; Rationale: S7's R7RS (import ...) modifies the evaluation environment
-;; in a way that breaks the texmacs module system when the importing module
-;; is loaded directly by (use-modules ...). By keeping this top-level loader
-;; free of (import ...), the deeper dependency modules can safely use
-;; (import ...).
-;;
-;; COPYRIGHT   : (C) 2026  Mogan Developers
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (plugin telemetry)
-  (:use (plugin telemetry-utils)
-    (plugin telemetry-track)
-    (plugin init-telemetry)
-  ) ;:use
-) ;texmacs-module
diff --git a/TeXmacs/plugins/telemetry/progs/telemetry/telemetry-init.scm b/TeXmacs/plugins/telemetry/progs/telemetry/telemetry-init.scm
new file mode 100644
index 0000000000..a6e72ac18b
--- /dev/null
+++ b/TeXmacs/plugins/telemetry/progs/telemetry/telemetry-init.scm
@@ -0,0 +1,92 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : telemetry-init.scm
+;; DESCRIPTION : Telemetry initialization and periodic flush
+;; COPYRIGHT   : (C) 2026 Yuki Lu
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (telemetry telemetry-init)
+  (:use (telemetry telemetry-track) (telemetry telemetry-utils))
+) ;texmacs-module
+
+(import (scheme base))
+
+(define telemetry-scheduled? #f)
+
+(define (telemetry-scheduler-step)
+  (when (telemetry-enabled?)
+    (telemetry-flush-if-needed)
+  ) ;when
+  (telemetry-delayed)
+) ;define
+
+(define (telemetry-delayed)
+  (delayed (:pause (telemetry-get-flush-interval)) (telemetry-scheduler-step))
+) ;define
+
+(define (telemetry-clean-orphans)
+  ;; 启动时清理：删除不在 meta 列表中的孤儿 jsonl
+  (let* ((meta (telemetry-read-meta))
+         (valid-files (map (lambda (e) (assoc-ref e "filename")) meta))
+         (dir-url (system->url (telemetry-main-dir)))
+         (pattern (url-append dir-url (url-wildcard "*.jsonl")))
+         (files (url->list (url-expand (url-complete pattern "fr"))))
+        ) ;
+    (for-each (lambda (f)
+                (let ((fname (url->string (url-tail f))))
+                  (when (and (string-starts? fname "detail-telemetry-")
+                          (not (member fname valid-files))
+                        ) ;and
+                    (catch #t (lambda () (path-unlink (url->system f))) (lambda args #f))
+                  ) ;when
+                ) ;let
+              ) ;lambda
+      files
+    ) ;for-each
+  ) ;let*
+) ;define
+
+(tm-define (init-telemetry)
+  ;; 先消费 *telemetry-pending*：插件加载前 C++ 上报入队的事件在此一次性
+  ;; 补 track（若 telemetry-disabled?，track-event 内部会直接返回 #f，
+  ;; 符合预期）。drain 完成后清空 pending，后续上报走 track-event 直接路径。
+  ;; telemetry-drain-pending! 注入在 rootlet，这里直接调用。
+  (telemetry-drain-pending!)
+  (if telemetry-scheduled?
+    (debug-message "debug-events" "[telemetry] init: already initialized\n")
+    (if (telemetry-enabled?)
+      (begin
+        (telemetry-clean-orphans)
+        (set! telemetry-scheduled? #t)
+        (debug-message "debug-events"
+          (string-append "[telemetry] init: enabled, buffer="
+            (number->string (telemetry-get-buffer-size))
+            ", interval="
+            (number->string (telemetry-get-flush-interval))
+            "ms\n"
+          ) ;string-append
+        ) ;debug-message
+        (on-exit (catch #t
+                   (lambda () (track-event "CLOSE" '()) (telemetry-flush-if-needed))
+                   (lambda args
+                     (debug-message "debug-events"
+                       (string-append "[telemetry] error: exit flush failed: "
+                         (object->string args)
+                         "\n"
+                       ) ;string-append
+                     ) ;debug-message
+                   ) ;lambda
+                 ) ;catch
+        ) ;on-exit
+        (telemetry-delayed)
+      ) ;begin
+      (debug-message "debug-events" "[telemetry] init: disabled\n")
+    ) ;if
+  ) ;if
+) ;tm-define
diff --git a/TeXmacs/plugins/telemetry/progs/plugin/telemetry-track.scm b/TeXmacs/plugins/telemetry/progs/telemetry/telemetry-track.scm
similarity index 93%
rename from TeXmacs/plugins/telemetry/progs/plugin/telemetry-track.scm
rename to TeXmacs/plugins/telemetry/progs/telemetry/telemetry-track.scm
index 40bf8cb56b..58f46149b0 100644
--- a/TeXmacs/plugins/telemetry/progs/plugin/telemetry-track.scm
+++ b/TeXmacs/plugins/telemetry/progs/telemetry/telemetry-track.scm
@@ -11,17 +11,11 @@
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(texmacs-module (plugin telemetry-track)
-  (:use (plugin telemetry-utils) (utils plugins plugin-eval))
+(texmacs-module (telemetry telemetry-track)
+  (:use (telemetry telemetry-utils) (utils plugins plugin-eval))
 ) ;texmacs-module
 
-(import (scheme base)
-  (liii base)
-  (liii os)
-  (liii path)
-  (liii string)
-  (liii list)
-) ;import
+(import (scheme base) (liii base) (liii path) (liii string) (liii list))
 
 (define-public *telemetry-event-queue* '())
 
@@ -51,10 +45,10 @@
 ;; event 仅供日志，worker 不消费。
 
 (define (build-upload-payload event)
-  (let ((payload `((,"event" unquote event)
-                   (,"main-dir" unquote (telemetry-main-dir))
-                   (,"api-url" unquote (telemetry-api-url))
-                   (,"api-key" unquote (telemetry-current-token)))
+  (let ((payload `((,"event" . ,event)
+                   (,"main-dir" . ,(telemetry-main-dir))
+                   (,"api-url" . ,(telemetry-api-url))
+                   (,"api-key" . ,(telemetry-current-token)))
         ) ;payload
        ) ;
     (telemetry->json payload)
@@ -139,7 +133,7 @@
       #f
     ) ;if
   ) ;if
-) ;define-public
+) ;tm-define
 
 (define-public (telemetry-queue-length) (length *telemetry-event-queue*))
 
diff --git a/TeXmacs/plugins/telemetry/progs/plugin/telemetry-utils.scm b/TeXmacs/plugins/telemetry/progs/telemetry/telemetry-utils.scm
similarity index 91%
rename from TeXmacs/plugins/telemetry/progs/plugin/telemetry-utils.scm
rename to TeXmacs/plugins/telemetry/progs/telemetry/telemetry-utils.scm
index 150fc75bce..a825ba0098 100644
--- a/TeXmacs/plugins/telemetry/progs/plugin/telemetry-utils.scm
+++ b/TeXmacs/plugins/telemetry/progs/telemetry/telemetry-utils.scm
@@ -11,12 +11,11 @@
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(texmacs-module (plugin telemetry-utils))
+(texmacs-module (telemetry telemetry-utils))
 
 (import (scheme base)
   (liii base)
   (liii njson)
-  (liii os)
   (liii path)
   (liii string)
   (liii uuid)
@@ -54,9 +53,7 @@
   ) ;if
 ) ;define-public
 
-(define-public (telemetry-home-path)
-  (url->system (get-texmacs-home-path))
-) ;define
+(define-public (telemetry-home-path) (url->system (get-texmacs-home-path)))
 
 (define (telemetry-ensure-dir dir)
   (if (not (path-exists? dir))
@@ -268,9 +265,8 @@
 
 (define-public (telemetry-meta-add-entry filename)
   (let* ((entries (telemetry-read-meta))
-         (new-entry `((,"filename" unquote filename)
-                      (,"timestamp" unquote (telemetry-now)))
-         ) ;new-entry
+         (new-entry `((,"filename" . ,filename)
+                      (,"timestamp" . ,(telemetry-now))))
          (updated (cons new-entry entries))
         ) ;
     (if (> (length updated) telemetry-meta-max-entries)
@@ -301,15 +297,15 @@
 ) ;define-public
 
 (define-public (telemetry-make-event event-type properties)
-  `((,"eventType" unquote event-type)
-    (,"timestamp" unquote (telemetry-now))
-    (,"distinctId" unquote (telemetry-device-id))
-    (,"sessionId" unquote (telemetry-session-id))
-    (,"eventId" unquote (uuid4))
-    (,"appVersion" unquote (telemetry-app-version))
-    (,"deviceId" unquote (telemetry-device-id))
-    (,"platform" unquote (telemetry-platform))
-    (,"language" unquote (telemetry-language))
-    (,"timezone" unquote (telemetry-timezone))
-    (,"properties" unquote (if (null? properties) '(()) properties)))
+  `((,"eventType" . ,event-type)
+    (,"timestamp" . ,(telemetry-now))
+    (,"distinctId" . ,(telemetry-device-id))
+    (,"sessionId" . ,(telemetry-session-id))
+    (,"eventId" . ,(uuid4))
+    (,"appVersion" . ,(telemetry-app-version))
+    (,"deviceId" . ,(telemetry-device-id))
+    (,"platform" . ,(telemetry-platform))
+    (,"language" . ,(telemetry-language))
+    (,"timezone" . ,(telemetry-timezone))
+    (,"properties" . ,(if (null? properties) '(()) properties)))
 ) ;define-public
diff --git a/TeXmacs/plugins/tikz/packages/code/tikz.stem b/TeXmacs/plugins/tikz/packages/code/tikz.stem
new file mode 100644
index 0000000000..434d5e023f
--- /dev/null
+++ b/TeXmacs/plugins/tikz/packages/code/tikz.stem
@@ -0,0 +1,20 @@
+(document (TeXmacs "2.1.2")
+  (style (tuple "source" "std"))
+  (body (document (active* (src-title (document (compound "src-package" "tikz" "1.0")
+                                        (src-purpose (document "TikZ Language"))
+                                      ) ;document
+                           ) ;src-title
+                  ) ;active*
+          (concat (use-module "(tikz tikz-format)") " " (use-module "(tikz tikz-edit)"))
+          (assign "tikz"
+            (macro "body"
+              (with "mode" "prog" "prog-language" "tikz" "font-family" "rm" (arg "body"))
+            ) ;macro
+          ) ;assign
+          (assign "tikz-code"
+            (macro "body" (document (pseudo-code (document (tikz (arg "body"))))))
+          ) ;assign
+        ) ;document
+  ) ;body
+  (initial (collection (associate "preamble" "true") (associate "sfactor" "5")))
+) ;document
diff --git a/TeXmacs/plugins/tikz/packages/code/tikz.ts b/TeXmacs/plugins/tikz/packages/code/tikz.ts
deleted file mode 100644
index f71e89fa3f..0000000000
--- a/TeXmacs/plugins/tikz/packages/code/tikz.ts
+++ /dev/null
@@ -1,31 +0,0 @@
-
-
->
-
-<\body>
-  
-    
-
-    <\src-purpose>
-      TikZ Language
-    
-  >
-
-  
-  
-
-  >>>
-
-  
-    <\pseudo-code>
-      >
-    
-  >
-
-
-<\initial>
-  <\collection>
-    
-    
-  
-
diff --git a/TeXmacs/plugins/tikz/progs/binary/pdflatex.scm b/TeXmacs/plugins/tikz/progs/binary/pdflatex.scm
deleted file mode 100644
index 712ac9dc57..0000000000
--- a/TeXmacs/plugins/tikz/progs/binary/pdflatex.scm
+++ /dev/null
@@ -1,47 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : pdflatex.scm
-;; DESCRIPTION : TikZ Binary plugin (pdflatex)
-;; COPYRIGHT   : (C) 2024  Darcy Shen
-;;                   2026  (Jack) Yansong Li
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (binary pdflatex)
-  (:use (binary common)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; pdflatex
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (pdflatex-binary-candidates)
-  (cond ((os-macos?)
-         (list "/Library/TeX/texbin/pdflatex"
-           "/usr/texbin/pdflatex"
-           "/opt/homebrew/bin/pdflatex"
-           "/usr/local/bin/pdflatex"
-         ))
-        ((os-win32?)
-         (list
-          "C:\\Program Files*\\MiKTeX*\\miktex\\bin\\x64\\pdflatex.exe"
-          "C:\\Program Files*\\MiKTeX*\\miktex\\bin\\pdflatex.exe"
-         ))
-        (else
-         (list "/usr/bin/pdflatex"
-           "/usr/local/bin/pdflatex"
-         ))))
-
-(tm-define (find-binary-pdflatex)
-  (:synopsis "Find the url to the pdflatex binary, return (url-none) if not found")
-  (find-binary (pdflatex-binary-candidates) "pdflatex"))
-
-(tm-define (has-binary-pdflatex?)
-  (not (url-none? (find-binary-pdflatex))))
-
-(tm-define (version-binary-pdflatex)
-  (version-binary (find-binary-pdflatex)))
diff --git a/TeXmacs/plugins/tikz/progs/code/tikz-edit.scm b/TeXmacs/plugins/tikz/progs/code/tikz-edit.scm
deleted file mode 100644
index 71d1377328..0000000000
--- a/TeXmacs/plugins/tikz/progs/code/tikz-edit.scm
+++ /dev/null
@@ -1,47 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : tikz-edit.scm
-;; DESCRIPTION : Editing TikZ code
-;; COPYRIGHT   : (C) 2026  Jack Yansong Li
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (code tikz-edit)
-  (:use (prog prog-edit)
-    (code tikz-mode)))
-
-(tm-define (get-tabstop)
-  (:mode in-prog-tikz?)
-  2)
-
-(tm-define (tikz-bracket-open lbr rbr)
-  (bracket-open lbr rbr "\\"))
-
-(tm-define (tikz-bracket-close lbr rbr)
-  (bracket-close lbr rbr "\\"))
-
-(tm-define (notify-cursor-moved status)
-  (:require prog-highlight-brackets?)
-  (:mode in-prog-tikz?)
-  (select-brackets-after-movement "([{" ")]}" "\\"))
-
-(tm-define (kbd-paste)
-  (:mode in-prog-tikz?)
-  (clipboard-paste-import "tikz" "primary"))
-
-(kbd-map
-  (:mode in-prog-tikz?)
-  ("A-tab" (insert-tabstop))
-  ("cmd S-tab" (remove-tabstop))
-  ("{" (tikz-bracket-open "{" "}"))
-  ("}" (tikz-bracket-close "{" "}"))
-  ("(" (tikz-bracket-open "(" ")"))
-  (")" (tikz-bracket-close "(" ")"))
-  ("[" (tikz-bracket-open "[" "]"))
-  ("]" (tikz-bracket-close "[" "]"))
-  ("\"" (tikz-bracket-open "\"" "\""))
-  ("'" (tikz-bracket-open "'" "'")))
diff --git a/TeXmacs/plugins/tikz/progs/code/tikz-lang.scm b/TeXmacs/plugins/tikz/progs/code/tikz-lang.scm
deleted file mode 100644
index aecbf2c949..0000000000
--- a/TeXmacs/plugins/tikz/progs/code/tikz-lang.scm
+++ /dev/null
@@ -1,108 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : tikz-lang.scm
-;; DESCRIPTION : TikZ language support for syntax highlighting
-;; COPYRIGHT   : (C) 2026  Jack Yansong Li
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (code tikz-lang)
-  (:use (prog default-lang)))
-
-;;------------------------------------------------------------------------------
-;; Keywords definition
-;;
-
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "tikz") (== key "keyword")))
-  `(,(string->symbol key)
-    (extra_chars "_.-")
-    (constant
-      "true" "false" "none" "solid" "dashed" "dotted" "thick" "thin" "ultra" "very" "semithick"
-      "help" "lines" "densely" "loosely" "double" "double distance" "smooth" "tension")
-    (constant_identifier
-      "red" "green" "blue" "cyan" "magenta" "yellow" "black" "white" "gray" "darkgray"
-      "lightgray" "brown" "lime" "olive" "orange" "pink" "purple" "teal" "violet" "help lines")
-    (constant_type
-      "circle" "rectangle" "coordinate" "ellipse" "diamond" "trapezium" "semicircle"
-      "regular polygon" "star" "isosceles triangle" "kite" "dart" "circular sector" "cylinder")
-    (declare_function
-      "draw" "node" "path" "fill" "clip" "filldraw" "shadedraw" "shade" "select" "foreach"
-      "definecolor" "colorlet" "tikzset" "tikzstyle" "useasboundingbox" "matrix" "pic"
-      "graph" "calendar" "scoped" "scope" "pgfextra" "pgfmathsetmacro" "pgfmathtruncatemacro")
-    (declare_module
-      "arrows" "shapes" "backgrounds" "calc" "positioning" "fit" "petri" "mindmap" "intersections"
-      "tangent" "shapes.geometric" "shapes.symbols" "shapes.arrows" "shapes.multipart"
-      "shapes.callouts" "shapes.misc" "svg.path")
-    (variable_identifier
-      "above" "below" "left" "right" "anchor" "above left" "above right" "below left" "below right"
-      "mid" "base" "inner sep" "inner xsep" "inner ysep" "outer sep" "outer xsep" "outer ysep"
-      "minimum height" "minimum width" "minimum size" "font" "node font" "text" "text width" "align"
-      "line width" "opacity" "fill opacity" "draw opacity" "text opacity" "shading" "shading angle"
-      "top color" "bottom color" "left color" "right color" "inner color" "outer color"
-      "variable" "samples" "domain" "preaction" "postaction" "start angle" "end angle" "radius"
-      "x radius" "y radius" "in" "out" "looseness" "bend" "step" "xstep" "ystep" "bend pos"
-      "parabola height" "mark" "mark size" "mark options" "double" "double distance" "scale"
-      "xscale" "yscale" "rotate" "rotate around" "shift" "xshift" "yshift" "xslant" "yslant" "transform shape")
-    (keyword
-      "at" "cycle" "circle" "rectangle" "ellipse" "arc" "to" "grid" "step" "controls" "plot"
-      "coordinates" "parabola" "sin" "cos" "child" "edge" "svg")
-    (keyword_control
-      "begin" "end" "foreach" "usetikzlibrary")))
-
-;;------------------------------------------------------------------------------
-;; Operators definition
-;;
-
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "tikz") (== key "operator")))
-  `(,(string->symbol key)
-    (operator
-      "+" "-" "*" "/" "\\" "^" "_" "=" "!" "?"
-      ";" "," ":" "&" "|" "$")
-    (operator_openclose
-      "(" ")" "[" "]" "{" "}")
-    (operator_special
-      "--" "->" "<-" "<->" "++" "+")))
-
-;;------------------------------------------------------------------------------
-;; Comments definition
-;;
-
-(tm-define (parser-feature lan key)
-  (:require (and (== lan "tikz") (== key "comment")))
-  `(,(string->symbol key)
-    (inline "%")))
-
-;;------------------------------------------------------------------------------
-;; Preferences for syntax highlighting
-;;
-
-(define (notify-tikz-syntax var val)
-  (syntax-read-preferences "tikz"))
-
-(define-preferences
-  ("syntax:tikz:none" "red" notify-tikz-syntax)
-  ("syntax:tikz:comment" "brown" notify-tikz-syntax)
-  ("syntax:tikz:error" "dark red" notify-tikz-syntax)
-  ("syntax:tikz:constant" "#4040c0" notify-tikz-syntax)
-  ("syntax:tikz:constant_identifier" "#228b22" notify-tikz-syntax)
-  ("syntax:tikz:constant_type" "#0000c0" notify-tikz-syntax)
-  ("syntax:tikz:constant_number" "#3030b0" notify-tikz-syntax)
-  ("syntax:tikz:constant_string" "dark grey" notify-tikz-syntax)
-  ("syntax:tikz:constant_char" "#333333" notify-tikz-syntax)
-  ("syntax:tikz:variable_identifier" "#a020f0" notify-tikz-syntax)
-  ("syntax:tikz:declare_function" "#0000c0" notify-tikz-syntax)
-  ("syntax:tikz:declare_type" "#0000c0" notify-tikz-syntax)
-  ("syntax:tikz:declare_module" "#0000c0" notify-tikz-syntax)
-  ("syntax:tikz:operator" "#8b008b" notify-tikz-syntax)
-  ("syntax:tikz:operator_openclose" "#B02020" notify-tikz-syntax)
-  ("syntax:tikz:operator_field" "#888888" notify-tikz-syntax)
-  ("syntax:tikz:operator_special" "orange" notify-tikz-syntax)
-  ("syntax:tikz:keyword" "#309090" notify-tikz-syntax)
-  ("syntax:tikz:keyword_conditional" "#309090" notify-tikz-syntax)
-  ("syntax:tikz:keyword_control" "#008080ff" notify-tikz-syntax))
diff --git a/TeXmacs/plugins/tikz/progs/code/tikz-mode.scm b/TeXmacs/plugins/tikz/progs/code/tikz-mode.scm
deleted file mode 100644
index 90268b5ec4..0000000000
--- a/TeXmacs/plugins/tikz/progs/code/tikz-mode.scm
+++ /dev/null
@@ -1,18 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : tikz-mode.scm
-;; DESCRIPTION : TikZ language mode
-;; COPYRIGHT   : (C) 2026  Jack Yansong Li
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (code tikz-mode)
-  (:use (kernel texmacs tm-modes)))
-
-(texmacs-modes
-  (in-tikz% (== (get-env "prog-language") "tikz"))
-  (in-prog-tikz% #t in-prog% in-tikz%))
diff --git a/TeXmacs/plugins/tikz/progs/data/tikz.scm b/TeXmacs/plugins/tikz/progs/data/tikz.scm
deleted file mode 100644
index 872b84b00d..0000000000
--- a/TeXmacs/plugins/tikz/progs/data/tikz.scm
+++ /dev/null
@@ -1,50 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : tikz.scm
-;; DESCRIPTION : prog format for TikZ
-;; COPYRIGHT   : (C) 2026  Jack Yansong Li
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (data tikz))
-
-;;------------------------------------------------------------------------------
-;; Format definition
-;;
-
-(define-format tikz
-  (:name "TikZ source code")
-  (:suffix "tikz"))
-
-;;------------------------------------------------------------------------------
-;; Conversion functions
-;;
-
-(define (texmacs->tikz x . opts)
-  (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '())))
-
-(define (tikz->texmacs x . opts)
-  (code->texmacs x))
-
-(define (tikz-snippet->texmacs x . opts)
-  (code-snippet->texmacs x))
-
-;;------------------------------------------------------------------------------
-;; Converter registration
-;;
-
-(converter texmacs-tree tikz-document
-  (:function texmacs->tikz))
-
-(converter tikz-document texmacs-tree
-  (:function tikz->texmacs))
-
-(converter texmacs-tree tikz-snippet
-  (:function texmacs->tikz))
-
-(converter tikz-snippet texmacs-tree
-  (:function tikz-snippet->texmacs))
diff --git a/TeXmacs/plugins/tikz/progs/init-tikz.scm b/TeXmacs/plugins/tikz/progs/init-tikz.scm
index 8f96af1d8f..7988b0878a 100644
--- a/TeXmacs/plugins/tikz/progs/init-tikz.scm
+++ b/TeXmacs/plugins/tikz/progs/init-tikz.scm
@@ -12,48 +12,37 @@
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(define-library (session tikz)
-  (import (scheme base) (liii list))
-  (export init-tikz)
-  (begin
-    (use-modules (binary pdflatex) (binary goldfish))
+(use-modules (binary pdflatex) (binary goldfish))
 
-    (define (tikz-serialize lan t)
-      (let* ((u (pre-serialize lan t))
-             (s (texmacs->utf8raw (stree->tree u))))
-        (string-append s "\n\n")
-      )
-    )
+(define (tikz-serialize lan t)
+  (let* ((u (pre-serialize lan t)) (s (texmacs->utf8raw (stree->tree u))))
+    (string-append s "\n\n")
+  ) ;let*
+) ;define
 
-    (define (tikz-launcher)
-      (string-append
-        (string-quote (url->system (find-binary-goldfish)))
-        " "
-        "load"
-        " "
-        (string-quote
-          (string-append (url->system (get-texmacs-path))
-            "/plugins/tikz/goldfish/tm-tikz.scm"
-          )
-        )
-        " "
-        (string-quote (url->system (find-binary-pdflatex)))
-      )
-    )
+(define (tikz-launcher)
+  (string-append (string-quote (url->system (find-binary-goldfish)))
+    " "
+    "load"
+    " "
+    (string-quote (string-append (url->system (get-texmacs-path))
+                    "/plugins/tikz/goldfish/tm-tikz.scm"
+                  ) ;string-append
+    ) ;string-quote
+    " "
+    (string-quote (url->system (find-binary-pdflatex)))
+  ) ;string-append
+) ;define
 
-    (define (init-tikz)
-      (plugin-configure tikz
-        (:require (and (has-binary-goldfish?)
-                       (has-binary-pdflatex?)))
-        (:launch ,(tikz-launcher))
-        (:serializer ,tikz-serialize)
-        (:session "TikZ")
-      )
-    )
-  )
-)
+(define (init-tikz)
+  (plugin-configure tikz
+    (:require (and (has-binary-goldfish?) (has-binary-pdflatex?)))
+    (:launch ,(tikz-launcher))
+    (:serializer ,tikz-serialize)
+    (:session "TikZ")
+  ) ;plugin-configure
+) ;define
 
-(import (session tikz))
 (init-tikz)
-(lazy-format (data tikz) tikz)
-(use-modules (code tikz-mode) (code tikz-edit))
+(lazy-format (tikz tikz-format) tikz)
+(use-modules (tikz tikz-mode) (tikz tikz-edit))
diff --git a/TeXmacs/plugins/tikz/progs/tikz/tikz-edit.scm b/TeXmacs/plugins/tikz/progs/tikz/tikz-edit.scm
new file mode 100644
index 0000000000..9a7df0cff9
--- /dev/null
+++ b/TeXmacs/plugins/tikz/progs/tikz/tikz-edit.scm
@@ -0,0 +1,43 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : tikz-edit.scm
+;; DESCRIPTION : Editing TikZ code
+;; COPYRIGHT   : (C) 2026  Jack Yansong Li
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (tikz tikz-edit) (:use (prog prog-edit) (tikz tikz-mode)))
+
+(tm-define (get-tabstop) (:mode in-prog-tikz?) 2)
+
+(tm-define (tikz-bracket-open lbr rbr) (bracket-open lbr rbr "\\"))
+
+(tm-define (tikz-bracket-close lbr rbr) (bracket-close lbr rbr "\\"))
+
+(tm-define (notify-cursor-moved status)
+  (:require prog-highlight-brackets?)
+  (:mode in-prog-tikz?)
+  (select-brackets-after-movement "([{" ")]}" "\\")
+) ;tm-define
+
+(tm-define (kbd-paste)
+  (:mode in-prog-tikz?)
+  (clipboard-paste-import "tikz" "primary")
+) ;tm-define
+
+(kbd-map (:mode in-prog-tikz?)
+ ("A-tab" (insert-tabstop))
+ ("cmd S-tab" (remove-tabstop))
+ ("{" (tikz-bracket-open "{" "}"))
+ ("}" (tikz-bracket-close "{" "}"))
+ ("(" (tikz-bracket-open "(" ")"))
+ (")" (tikz-bracket-close "(" ")"))
+ ("[" (tikz-bracket-open "[" "]"))
+ ("]" (tikz-bracket-close "[" "]"))
+ ("\"" (tikz-bracket-open "\"" "\""))
+ ("'" (tikz-bracket-open "'" "'"))
+) ;kbd-map
diff --git a/TeXmacs/plugins/tikz/progs/tikz/tikz-format.scm b/TeXmacs/plugins/tikz/progs/tikz/tikz-format.scm
new file mode 100644
index 0000000000..462a3fe8dc
--- /dev/null
+++ b/TeXmacs/plugins/tikz/progs/tikz/tikz-format.scm
@@ -0,0 +1,47 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : tikz.scm
+;; DESCRIPTION : prog format for TikZ
+;; COPYRIGHT   : (C) 2026  Jack Yansong Li
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (tikz tikz-format))
+
+;; ------------------------------------------------------------------------------
+;; Format definition
+;;
+
+(define-format tikz (:name "TikZ source code") (:suffix "tikz"))
+
+;; ------------------------------------------------------------------------------
+;; Conversion functions
+;;
+
+(define (texmacs->tikz x . opts)
+  (texmacs->verbatim x (acons "texmacs->verbatim:encoding" "SourceCode" '()))
+) ;define
+
+(define (tikz->texmacs x . opts)
+  (code->texmacs x)
+) ;define
+
+(define (tikz-snippet->texmacs x . opts)
+  (code-snippet->texmacs x)
+) ;define
+
+;; ------------------------------------------------------------------------------
+;; Converter registration
+;;
+
+(converter texmacs-tree tikz-document (:function texmacs->tikz))
+
+(converter tikz-document texmacs-tree (:function tikz->texmacs))
+
+(converter texmacs-tree tikz-snippet (:function texmacs->tikz))
+
+(converter tikz-snippet texmacs-tree (:function tikz-snippet->texmacs))
diff --git a/TeXmacs/plugins/tikz/progs/tikz/tikz-lang.scm b/TeXmacs/plugins/tikz/progs/tikz/tikz-lang.scm
new file mode 100644
index 0000000000..05f703d53f
--- /dev/null
+++ b/TeXmacs/plugins/tikz/progs/tikz/tikz-lang.scm
@@ -0,0 +1,108 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : tikz-lang.scm
+;; DESCRIPTION : TikZ language support for syntax highlighting
+;; COPYRIGHT   : (C) 2026  Jack Yansong Li
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (tikz tikz-lang) (:use (prog default-lang)))
+
+;; ------------------------------------------------------------------------------
+;; Keywords definition
+;;
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "tikz") (== key "keyword")))
+  `(,(string->symbol key)
+    (extra_chars "_.-")
+    (constant "true" "false" "none" "solid" "dashed" "dotted" "thick" "thin"
+      "ultra" "very" "semithick" "help" "lines" "densely" "loosely" "double"
+      "double distance" "smooth" "tension")
+    (constant_identifier "red" "green" "blue" "cyan" "magenta" "yellow" "black"
+      "white" "gray" "darkgray" "lightgray" "brown" "lime" "olive" "orange"
+      "pink" "purple" "teal" "violet" "help lines")
+    (constant_type "circle" "rectangle" "coordinate" "ellipse" "diamond"
+      "trapezium" "semicircle" "regular polygon" "star" "isosceles triangle"
+      "kite" "dart" "circular sector" "cylinder")
+    (declare_function "draw" "node" "path" "fill" "clip" "filldraw" "shadedraw"
+      "shade" "select" "foreach" "definecolor" "colorlet" "tikzset" "tikzstyle"
+      "useasboundingbox" "matrix" "pic" "graph" "calendar" "scoped" "scope"
+      "pgfextra" "pgfmathsetmacro" "pgfmathtruncatemacro")
+    (declare_module "arrows" "shapes" "backgrounds" "calc" "positioning" "fit"
+      "petri" "mindmap" "intersections" "tangent" "shapes.geometric"
+      "shapes.symbols" "shapes.arrows" "shapes.multipart" "shapes.callouts"
+      "shapes.misc" "svg.path")
+    (variable_identifier "above" "below" "left" "right" "anchor" "above left"
+      "above right" "below left" "below right" "mid" "base" "inner sep"
+      "inner xsep" "inner ysep" "outer sep" "outer xsep" "outer ysep"
+      "minimum height" "minimum width" "minimum size" "font" "node font" "text"
+      "text width" "align" "line width" "opacity" "fill opacity" "draw opacity"
+      "text opacity" "shading" "shading angle" "top color" "bottom color"
+      "left color" "right color" "inner color" "outer color" "variable"
+      "samples" "domain" "preaction" "postaction" "start angle" "end angle"
+      "radius" "x radius" "y radius" "in" "out" "looseness" "bend" "step"
+      "xstep" "ystep" "bend pos" "parabola height" "mark" "mark size"
+      "mark options" "double" "double distance" "scale" "xscale" "yscale"
+      "rotate" "rotate around" "shift" "xshift" "yshift" "xslant" "yslant"
+      "transform shape")
+    (keyword "at" "cycle" "circle" "rectangle" "ellipse" "arc" "to" "grid"
+      "step" "controls" "plot" "coordinates" "parabola" "sin" "cos" "child"
+      "edge" "svg")
+    (keyword_control "begin" "end" "foreach" "usetikzlibrary"))
+) ;tm-define
+
+;; ------------------------------------------------------------------------------
+;; Operators definition
+;;
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "tikz") (== key "operator")))
+  `(,(string->symbol key)
+    (operator "+" "-" "*" "/" "\\" "^" "_" "=" "!" "?" ";" "," ":" "&" "|" "$")
+    (operator_openclose "(" ")" "[" "]" "{" "}")
+    (operator_special "--" "->" "<-" "<->" "++" "+"))
+) ;tm-define
+
+;; ------------------------------------------------------------------------------
+;; Comments definition
+;;
+
+(tm-define (parser-feature lan key)
+  (:require (and (== lan "tikz") (== key "comment")))
+  `(,(string->symbol key) (inline "%"))
+) ;tm-define
+
+;; ------------------------------------------------------------------------------
+;; Preferences for syntax highlighting
+;;
+
+(define (notify-tikz-syntax var val)
+  (syntax-read-preferences "tikz")
+) ;define
+
+(define-preferences ("syntax:tikz:none" "red" notify-tikz-syntax)
+ ("syntax:tikz:comment" "brown" notify-tikz-syntax)
+ ("syntax:tikz:error" "dark red" notify-tikz-syntax)
+ ("syntax:tikz:constant" "#4040c0" notify-tikz-syntax)
+ ("syntax:tikz:constant_identifier" "#228b22" notify-tikz-syntax)
+ ("syntax:tikz:constant_type" "#0000c0" notify-tikz-syntax)
+ ("syntax:tikz:constant_number" "#3030b0" notify-tikz-syntax)
+ ("syntax:tikz:constant_string" "dark grey" notify-tikz-syntax)
+ ("syntax:tikz:constant_char" "#333333" notify-tikz-syntax)
+ ("syntax:tikz:variable_identifier" "#a020f0" notify-tikz-syntax)
+ ("syntax:tikz:declare_function" "#0000c0" notify-tikz-syntax)
+ ("syntax:tikz:declare_type" "#0000c0" notify-tikz-syntax)
+ ("syntax:tikz:declare_module" "#0000c0" notify-tikz-syntax)
+ ("syntax:tikz:operator" "#8b008b" notify-tikz-syntax)
+ ("syntax:tikz:operator_openclose" "#B02020" notify-tikz-syntax)
+ ("syntax:tikz:operator_field" "#888888" notify-tikz-syntax)
+ ("syntax:tikz:operator_special" "orange" notify-tikz-syntax)
+ ("syntax:tikz:keyword" "#309090" notify-tikz-syntax)
+ ("syntax:tikz:keyword_conditional" "#309090" notify-tikz-syntax)
+ ("syntax:tikz:keyword_control" "#008080ff" notify-tikz-syntax)
+) ;define-preferences
diff --git a/TeXmacs/plugins/tikz/progs/tikz/tikz-mode.scm b/TeXmacs/plugins/tikz/progs/tikz/tikz-mode.scm
new file mode 100644
index 0000000000..c145a4d343
--- /dev/null
+++ b/TeXmacs/plugins/tikz/progs/tikz/tikz-mode.scm
@@ -0,0 +1,17 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : tikz-mode.scm
+;; DESCRIPTION : TikZ language mode
+;; COPYRIGHT   : (C) 2026  Jack Yansong Li
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (tikz tikz-mode) (:use (kernel texmacs tm-modes)))
+
+(texmacs-modes (in-tikz% (== (get-env "prog-language") "tikz"))
+  (in-prog-tikz% #t in-prog% in-tikz%)
+) ;texmacs-modes
diff --git a/TeXmacs/plugins/tmu/progs/data/tmu.scm b/TeXmacs/plugins/tmu/progs/data/tmu.scm
deleted file mode 100644
index 9b5ace886d..0000000000
--- a/TeXmacs/plugins/tmu/progs/data/tmu.scm
+++ /dev/null
@@ -1,39 +0,0 @@
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; MODULE      : data/tmu.scm
-;; DESCRIPTION : tmu data format
-;; COPYRIGHT   : (C) 2024   Darcy Shen
-;;
-;; This software falls under the GNU general public license version 3 or later.
-;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
-;; in the root directory or .
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(texmacs-module (data tmu))
-
-(define-format tmu 
-  (:name "TMU")
-  (:suffix "tmu"))
-
-(tm-define (texmacs->tmu t)
-  (serialize-tmu (herk-tree->utf8-tree t)))
-
-(tm-define (tmu->texmacs t)
-  (utf8-tree->herk-tree (parse-tmu t)))
-
-(define (tmu-snippet->texmacs t)
-  (utf8-tree->herk-tree (parse-tmu-snippet t)))
-
-(converter tmu-document texmacs-tree
-  (:function tmu->texmacs))
-
-(converter texmacs-tree tmu-document
-  (:function texmacs->tmu))
-
-(converter tmu-snippet texmacs-tree
-  (:function tmu-snippet->texmacs))
-
-(converter texmacs-tree tmu-snippet
-  (:function texmacs->tmu))
diff --git a/TeXmacs/plugins/tmu/progs/tmu/tmu-format.scm b/TeXmacs/plugins/tmu/progs/tmu/tmu-format.scm
new file mode 100644
index 0000000000..d854d8edee
--- /dev/null
+++ b/TeXmacs/plugins/tmu/progs/tmu/tmu-format.scm
@@ -0,0 +1,32 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : data/tmu.scm
+;; DESCRIPTION : tmu data format
+;; COPYRIGHT   : (C) 2024   Darcy Shen
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (tmu tmu-format))
+
+(define-format tmu (:name "TMU") (:suffix "tmu"))
+
+(tm-define (texmacs->tmu t) (serialize-tmu (herk-tree->utf8-tree t)))
+
+(tm-define (tmu->texmacs t) (utf8-tree->herk-tree (parse-tmu t)))
+
+(define (tmu-snippet->texmacs t)
+  (utf8-tree->herk-tree (parse-tmu-snippet t))
+) ;define
+
+(converter tmu-document texmacs-tree (:function tmu->texmacs))
+
+(converter texmacs-tree tmu-document (:function texmacs->tmu))
+
+(converter tmu-snippet texmacs-tree (:function tmu-snippet->texmacs))
+
+(converter texmacs-tree tmu-snippet (:function texmacs->tmu))
diff --git a/TeXmacs/plugins/windows/progs/init-windows.scm b/TeXmacs/plugins/windows/progs/init-windows.scm
new file mode 100644
index 0000000000..72eb932361
--- /dev/null
+++ b/TeXmacs/plugins/windows/progs/init-windows.scm
@@ -0,0 +1,135 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : init-windows.scm
+;; DESCRIPTION : Initialize the 'windows' plugin (Windows look and feel keymap)
+;; COPYRIGHT   : (C) 1999  Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(when (like-windows?)
+  (kbd-map (:profile windows)
+
+    ;; standard Windows shortcuts
+    ("windows F4" (close-document))
+    ("windows S-F4" (close-document*))
+    ("windows left" (traverse-left))
+    ("windows right" (traverse-right))
+    ("windows home" (go-start))
+    ("windows end" (go-end))
+    ("windows S-left" (kbd-select traverse-left))
+    ("windows S-right" (kbd-select traverse-right))
+    ("windows S-home" (kbd-select go-start))
+    ("windows S-end" (kbd-select go-end))
+    ("windows S-space" (make 'nbsp))
+    ("windows _" (make 'nbhyph))
+    ("windows A-." "")
+    ("windows A-c" (make 'copyright))
+    ("windows e" (make 'footnote))
+    ("windows F" (make 'footnote))
+    ("windows h" (interactive-replace))
+    ("windows K" (toggle-small-caps))
+    ("windows A-r" (make 'registered))
+    ("windows A-t" (make 'trademark))
+    ("windows y" (redo 0))
+
+    ("F2" (interactive-replace))
+    ("A-F4" (close-document))
+    ("A-S-F4" (close-document*))
+
+    ("search windows g" (search-next-match #t))
+    ("search windows G" (search-next-match #f))
+    ("search F3" (search-next-match #t))
+    ("search S-F3" (search-next-match #f))
+
+    ;; not yet implemented
+    ;; ("F4" (go-to-different-folder))
+    ;; ("F5" (refresh-window))
+    ;; ("F6" (switch-to-next-pane))
+    ;; ("F8" (kbd-select-enlarge))
+    ;; ("F9" (refresh-web-page))
+    ;; ("C-F9" (insert-field))
+    ;; ("F10" (menu-bar-options))
+    ;; ("S-F10" (open-contextual-menu))
+    ;; ("windows F4" (close-mdi-window))
+    ;; ("windows F6" (next-tab))
+    ;; ("windows S-F6" (previous-tab))
+    ;; ("windows delete" (delete-end-word))
+    ;; ("windows backspace" (delete-start-word))
+    ;; ("windows tab" (switch-to-next-child))
+    ;; ("windows escape" (open-start-menu))
+    ;; ("windows S-escape" (open-task-manager))
+    ;; ("windows S-return" (insert-section-break))
+    ;; ("windows C" (copy-formatting))
+    ;; ("windows D" (insert-endnote))
+    ;; ("windows E" (review-toggle-track-changes))
+    ;; ("windows g" (go-to-location))
+    ;; ("windows A-m" (review-insert-comment))
+    ;; ("windows V" (paste-formatting))
+    ;; ("windows A-y" (search-repeat))
+    ;; ("windows <" (decrease-font-size))
+    ;; ("windows >" (increase-font-size))
+    ;; ("windows [" (decrease-font-size-one-point))
+    ;; ("windows ]" (increase-font-size-one-point))
+    ;; ("windows ` `" (open-single-quotation))
+    ;; ("windows ' '" (close-single-quotation))
+    ;; ("windows ` C-`" (open-double-quotation))
+    ;; ("windows ' C-'" (close-double-quotation))
+    ;; ("S-delete" (delete-selection-immediately))
+    ;; ("A-F6" (switch-to-next-window))
+    ;; ("A-tab" (switch-to-next-program))
+    ;; ("A-down" (open-drop-down-list-box))
+    ;; ("A-space" (open-system-menu))
+    ;; ("A-return" (open-properties-window))
+    ;; ("A-I" (insert-citation-entry))
+    ;; ("A-O" (insert-toc-entry))
+    ;; ("A-X" (insert-index-entry))
+    ;; ("A--" (open-child-system-menu))
+    ;; ("A-_" (open-menu))
+    ;; ("M-F1" (run-dialog-box))
+    ;; ("M-tab" (cycle-taskbar-button))
+    ;; ("M-space" (show-keyboard-shortcuts))
+    ;; ("M-c" (open-control-panel))
+    ;; ("M-d" (minimize-all-open-windows))
+    ;; ("M-e" (open-explorer-window))
+    ;; ("M-C-f" (find-computer))
+    ;; ("M-f" (open-finder-window))
+    ;; ("M-i" (open-mouse-properties-window))
+    ;; ("M-k" (open-keyboard-properties-window))
+    ;; ("M-l" (log-off-windows))
+    ;; ("M-m" (minimize-all-windows))
+    ;; ("M-M" (unminimize-all-windows))
+    ;; ("M-p" (start-print-manager))
+    ;; ("M-r" (run-dialog-box))
+    ;; ("M-s" (toggle-caps-lock))
+    ;; ("M-v" (start-clipboard))
+    ;; ("forward" (next-tab))
+    ;; ("back" (previous-tab))
+
+    ;; further shortcuts for Windows look and feel
+    ("windows g" (selection-cancel))
+    ("windows l" (refresh-window))
+
+    ("cmd q" (make 'symbol))
+    ("altcmd g" (kbd-cancel))
+    ("altcmd x" (interactive footer-eval))
+    ("A-x" (interactive exec-interactive-command))
+    ("altcmd $" (interactive-spell))
+
+    ("structured:cmd left" (kbd-select-if-active traverse-left))
+    ("structured:cmd right" (kbd-select-if-active traverse-right))
+
+    ("C-O" (toggle-source-mode))
+    ("C-P" (toggle-preamble-mode))
+  ) ;kbd-map
+
+  (kbd-map (:profile windows)
+    (:require (and (not (in-prog?)) (not (in-verbatim?))))
+    ("M-space" (make-space "0.2spc"))
+    ("M-S-space" (make-space "-0.2spc"))
+  ) ;kbd-map
+) ;when
diff --git a/TeXmacs/progs/convert/images/tmimage.scm b/TeXmacs/progs/convert/images/tmimage.scm
index ec6187f6fb..c9dcce25f0 100644
--- a/TeXmacs/progs/convert/images/tmimage.scm
+++ b/TeXmacs/progs/convert/images/tmimage.scm
@@ -403,30 +403,14 @@
                                                          ,"1"
                                                          ,"cell-background"
                                                          ,fillcolor)
-                                                       (cwith "1"
-                                                         "1"
-                                                         "1"
-                                                         "1"
-                                                         "cell-lsep"
-                                                         "0spc")
-                                                       (cwith "1"
-                                                         "1"
-                                                         "1"
-                                                         "1"
-                                                         "cell-tsep"
-                                                         "0sep")
-                                                       (cwith "1"
-                                                         "1"
-                                                         "1"
-                                                         "1"
-                                                         "cell-rsep"
-                                                         "0spc")
-                                                       (cwith "1"
-                                                         "1"
-                                                         "1"
-                                                         "1"
-                                                         "cell-bsep"
-                                                         "0sep")
+                                                       (cwith "1" "1" "1" "1"
+                                                         "cell-lsep" "0spc")
+                                                       (cwith "1" "1" "1" "1"
+                                                         "cell-tsep" "0sep")
+                                                       (cwith "1" "1" "1" "1"
+                                                         "cell-rsep" "0spc")
+                                                       (cwith "1" "1" "1" "1"
+                                                         "cell-bsep" "0sep")
                                                        (table (row (cell ,tm-fragment1))))))
                                      ;; otherwise (multiline selection) use doc-at to get proper pagewidth
                                      `(with ,"fill-color"
@@ -434,9 +418,7 @@
                                         ,"doc-at-width"
                                         ,parcm
                                         ,"doc-at-hmode"
-                                        ,(if (or iseqnarray
-                                               indisplaymath
-                                               inmath)
+                                        ,(if (or iseqnarray indisplaymath inmath)
                                            "min"
                                            "exact")
                                         ,"doc-at-padding"
diff --git a/TeXmacs/progs/convert/tools/environment.scm b/TeXmacs/progs/convert/tools/environment.scm
index 20b778d5f1..85188f1b1a 100644
--- a/TeXmacs/progs/convert/tools/environment.scm
+++ b/TeXmacs/progs/convert/tools/environment.scm
@@ -93,8 +93,7 @@
      (list ,@(map-in-order (lambda (b)
                              (if (not (list-length=2? b))
                                (syntax-error "with-environment"
-                                 "Ill-formed binding: ~A"
-                                 b))
+                                 "Ill-formed binding: ~A" b))
                              `(list (quote ,(first b)) ,(second b)))
                bindings))
      (lambda (,env) ,@body))
diff --git a/TeXmacs/progs/convert/tools/old-tmtable.scm b/TeXmacs/progs/convert/tools/old-tmtable.scm
index f17f3d7bc4..4fe19691a3 100644
--- a/TeXmacs/progs/convert/tools/old-tmtable.scm
+++ b/TeXmacs/progs/convert/tools/old-tmtable.scm
@@ -242,39 +242,17 @@
 
 (define (stm-table-length-name? name)
   (in? name
-    '("cell-width"
-      "cell-height"
-      "cell-lsep"
-      "cell-rsep"
-      "cell-bsep"
-      "cell-tsep"
-      "cell-lborder"
-      "cell-rborder"
-      "cell-bborder"
-      "cell-tborder"
-      "table-width"
-      "table-height"
-      "table-lsep"
-      "table-rsep"
-      "table-bsep"
-      "table-tsep"
-      "table-lborder"
-      "table-rborder"
-      "table-bborder"
-      "table-tborder")
+    '("cell-width" "cell-height" "cell-lsep" "cell-rsep" "cell-bsep" "cell-tsep"
+      "cell-lborder" "cell-rborder" "cell-bborder" "cell-tborder" "table-width"
+      "table-height" "table-lsep" "table-rsep" "table-bsep" "table-tsep"
+      "table-lborder" "table-rborder" "table-bborder" "table-tborder")
   ) ;in?
 ) ;define
 
 (define (stm-table-number-name? name)
   (in? name
-    '("cell-row-span"
-      "cell-col-span"
-      "table-row-origin"
-      "table-col-origin"
-      "table-min-rows"
-      "table-min-cols"
-      "table-max-rows"
-      "table-max-cols")
+    '("cell-row-span" "cell-col-span" "table-row-origin" "table-col-origin"
+      "table-min-rows" "table-min-cols" "table-max-rows" "table-max-cols")
   ) ;in?
 ) ;define
 
diff --git a/TeXmacs/progs/convert/tools/tmpre.scm b/TeXmacs/progs/convert/tools/tmpre.scm
index c50993b45d..1b5acc4576 100644
--- a/TeXmacs/progs/convert/tools/tmpre.scm
+++ b/TeXmacs/progs/convert/tools/tmpre.scm
@@ -17,90 +17,25 @@
 ;; Data
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(logic-group tmpre-inline-env%
-  verbatim
-  code
-  center
-  indent
-  description
-  itemize
-  itemize-minus
-  itemize-dot
-  itemize-arrow
-  enumerate
-  enumerate-numeric
-  enumerate-numeric-bracket
-  enumerate-roman
-  enumerate-roman-bracket
-  enumerate-roman-paren
-  enumerate-Roman
-  enumerate-alpha
-  enumerate-alpha-bracket
-  enumerate-alpha-full-paren
-  enumerate-Alpha
-  enumerate-circle
-  enumerate-hanzi
-  enumerate-numeric-paren
-  equation
-  equation*
-  eqnarray
-  eqnarray*
-  leqnarray
-  leqnarray*
-  elsequation
-  elsequation*
+(logic-group tmpre-inline-env% verbatim code center indent description itemize
+  itemize-minus itemize-dot itemize-arrow enumerate enumerate-numeric
+  enumerate-numeric-bracket enumerate-roman enumerate-roman-bracket
+  enumerate-roman-paren enumerate-Roman enumerate-alpha enumerate-alpha-bracket
+  enumerate-alpha-full-paren enumerate-Alpha enumerate-circle enumerate-hanzi
+  enumerate-numeric-paren equation equation* eqnarray eqnarray* leqnarray
+  leqnarray* elsequation elsequation*
 ) ;logic-group
 
-(logic-group tmpre-sectional%
-  part
-  chapter
-  appendix
-  section
-  subsection
-  subsubsection
-  paragraph
-  subparagraph
-  part*
-  chapter*
-  appendix*
-  section*
-  subsection*
-  subsubsection*
-  paragraph*
-  subparagraph*
+(logic-group tmpre-sectional% part chapter appendix section subsection
+  subsubsection paragraph subparagraph part* chapter* appendix* section*
+  subsection* subsubsection* paragraph* subparagraph*
 ) ;logic-group
 
-(logic-group tmpre-theorem-env%
-  theorem
-  proposition
-  lemma
-  corollary
-  axiom
-  definition
-  notation
-  conjecture
-  remark
-  note
-  example
-  warning
-  convention
-  acknowledgments
-  exercise
-  theorem*
-  proposition*
-  lemma*
-  corollary*
-  axiom*
-  definition*
-  notation*
-  conjecture*
-  remark*
-  note*
-  example*
-  warning*
-  convention*
-  acknowledgments*
-  exercise*
+(logic-group tmpre-theorem-env% theorem proposition lemma corollary axiom
+  definition notation conjecture remark note example warning convention
+  acknowledgments exercise theorem* proposition* lemma* corollary* axiom*
+  definition* notation* conjecture* remark* note* example* warning* convention*
+  acknowledgments* exercise*
 ) ;logic-group
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
diff --git a/TeXmacs/progs/database/bib-db.scm b/TeXmacs/progs/database/bib-db.scm
index d3309ea8eb..dbfc61ae8a 100644
--- a/TeXmacs/progs/database/bib-db.scm
+++ b/TeXmacs/progs/database/bib-db.scm
@@ -14,8 +14,8 @@
 (texmacs-module (database bib-db)
   (:use (database db-convert)
         (database db-edit)
-        (data bibtex)
-        (convert bibtex bibtexout)))
+        (latex bibtex-format)
+        (latex convert-bibtex-bibtexout)))
 
 (tm-define (bib-database) (user-database "bib"))
 
diff --git a/TeXmacs/progs/database/bib-manage.scm b/TeXmacs/progs/database/bib-manage.scm
index cfa91f9d37..41d2315f5d 100644
--- a/TeXmacs/progs/database/bib-manage.scm
+++ b/TeXmacs/progs/database/bib-manage.scm
@@ -394,7 +394,7 @@
 
 (tm-define (bib-generate prefix style doc)
   (with m
-    `(bibtex ,(string->symbol style))
+    '(latex bibtex-, (string->symbol style))
     (module-provide m)
     (bib-process prefix style doc)
   ) ;with
diff --git a/TeXmacs/progs/database/db-menu.scm b/TeXmacs/progs/database/db-menu.scm
index 117f096daf..e891b2726c 100644
--- a/TeXmacs/progs/database/db-menu.scm
+++ b/TeXmacs/progs/database/db-menu.scm
@@ -26,7 +26,7 @@
 (define (db-toolbar-search search)
   (let* ((u-search (cork->utf8 search))
          (keys (compute-keys-string u-search "verbatim"))
-         (s (string-recompose keys ","))
+         (s (string-join keys ","))
         ) ;
     (db-set-query-preference (current-buffer) "exact-search" search)
     (db-set-query-preference (current-buffer) "search" s)
diff --git a/TeXmacs/progs/doc/apidoc-kbd.scm b/TeXmacs/progs/doc/apidoc-kbd.scm
index d0383afe9f..ab38f27a8d 100644
--- a/TeXmacs/progs/doc/apidoc-kbd.scm
+++ b/TeXmacs/progs/doc/apidoc-kbd.scm
@@ -14,6 +14,7 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (texmacs-module (doc apidoc-kbd) (:use (doc apidoc-widgets)))
+(debug-message "keyboard" "(doc apidoc-kbd): registering kbd-map ...\n")
 
 (tm-define (macro-popup-help)
   (:synopsis "Pops up the help window for the innermost TeXmacs macro")
@@ -26,3 +27,4 @@
 (kbd-map (:require (and developer-mode? (not (in-prog-scheme?))))
  ("A-F1" (macro-popup-help))
 ) ;kbd-map
+(debug-message "keyboard" "(doc apidoc-kbd): kbd-map registered\n")
diff --git a/TeXmacs/progs/doc/docgrep.scm b/TeXmacs/progs/doc/docgrep.scm
index 6c568b96ce..effeb49e80 100644
--- a/TeXmacs/progs/doc/docgrep.scm
+++ b/TeXmacs/progs/doc/docgrep.scm
@@ -126,7 +126,7 @@
 
 (define url-collect-cache (make-ahash-table))
 
-(define path-separator (if (or (os-mingw?) (os-win32?)) #\; #\:))
+(define path-separator (if (os-windows?) #\; #\:))
 
 (define (url-collect path pattern)
   (or (ahash-ref url-collect-cache (string-append path pattern))
@@ -185,12 +185,8 @@
           ) ;
           ((== type "C++") (srcgrep what "$TEXMACS_SOURCE_PATH/src" "*.hpp" "*.cpp"))
           ((== type "All code")
-           (srcgrep what
-             "$TEXMACS_PATH:$TEXMACS_SOURCE_PATH/src"
-             "*.scm"
-             "*.hpp"
-             "*.cpp"
-             "*.ts"
+           (srcgrep what "$TEXMACS_PATH:$TEXMACS_SOURCE_PATH/src" "*.scm"
+             "*.hpp" "*.cpp" "*.ts"
            ) ;srcgrep
           ) ;
           ((== type "texts") (docgrep what "$TEXMACS_FILE_PATH" "*.tm"))
@@ -247,3 +243,25 @@
     (load-document (string-append "tmfs://grep/" query))
   ) ;with
 ) ;tm-define
+
+;; 从 cpp-search-recent-dialog 的返回 tree 里取搜索词。OK 返回
+;; (tuple (tuple "what" ))，Cancel / 关闭返回空 tuple。#f 表示没有有效搜索词。
+
+(define (recent-grep-what result)
+  (with kvs (cdr (tree->stree result)) (if (nnull? kvs) (caddr (car kvs)) #f))
+) ;define
+
+;; 编辑 → 搜索最近打开的文档：专用 QML 弹窗（DialogShell + InputField，
+;; run_qml_dialog）。OK 走 docgrep-in-recent 对最近文档内容做 grep（保持原语义：
+;; 内容搜索，非按文件名模糊打开）。空串 / Cancel / 关闭不触发搜索。
+
+(tm-define (docgrep-in-recent-dialog)
+  (:interactive #t)
+  (with result
+    (cpp-search-recent-dialog)
+    (with what
+      (recent-grep-what result)
+      (if (and (string? what) (!= what "")) (docgrep-in-recent what))
+    ) ;with
+  ) ;with
+) ;tm-define
diff --git a/TeXmacs/progs/doc/help-funcs.scm b/TeXmacs/progs/doc/help-funcs.scm
index 57a697a2ca..f0e9586d27 100644
--- a/TeXmacs/progs/doc/help-funcs.scm
+++ b/TeXmacs/progs/doc/help-funcs.scm
@@ -232,6 +232,14 @@
   ) ;with
 ) ;define
 
+(define (show-version-dialog msg url open-website?)
+  (when (cpp-version-dialog (translate "Version") msg)
+    (when open-website?
+      (open-url url)
+    ) ;when
+  ) ;when
+) ;define
+
 ;; 显示Mogan版本信息
 (tm-define (mogan-version)
   (let* ((cur-ver (xmacs-version))
@@ -250,20 +258,22 @@
     (if community?
       ;; 社区版：同时展示社区版和商业版的最新稳定版
       (let ((msg (if community-latest?
-                   (replace (string-append "You are using v%1.\n"
-                              "The latest stable version of Mogan STEM is v%2, "
-                              "and the latest stable version of Liii STEM is v%3."
-                            ) ;string-append
+                   (replace (translate (string-append "You are using v%1.\n"
+                                         "The latest stable version of Mogan STEM is v%2, "
+                                         "and the latest stable version of Liii STEM is v%3."
+                                       ) ;string-append
+                            ) ;translate
                      cur-ver
                      community-ver
                      commercial-ver
                    ) ;replace
-                   (replace (string-append "You are using v%1.\n"
-                              "The latest stable version of Mogan STEM is v%2, "
-                              "and the latest stable version of Liii STEM is v%3.\n"
-                              "Please click OK to visit the official website "
-                              "to download the latest stable version."
-                            ) ;string-append
+                   (replace (translate (string-append "You are using v%1.\n"
+                                         "The latest stable version of Mogan STEM is v%2, "
+                                         "and the latest stable version of Liii STEM is v%3.\n"
+                                         "Please click OK to visit the official website "
+                                         "to download the latest stable version."
+                                       ) ;string-append
+                            ) ;translate
                      cur-ver
                      community-ver
                      commercial-ver
@@ -271,31 +281,27 @@
                  ) ;if
             ) ;msg
            ) ;
-        (if community-latest?
-          (show-message msg (translate "Version"))
-          (show-message-with-callback msg (translate "Version") (lambda x (open-url url)))
-        ) ;if
+        (show-version-dialog msg url (not community-latest?))
       ) ;let
       ;; 商业版：只展示商业版的最新稳定版
       (let ((msg (if commercial-latest?
-                   (replace "You are using v%1, and the latest stable version of Liii STEM is v%2."
+                   (replace (translate "You are using v%1, and the latest stable version of Liii STEM is v%2."
+                            ) ;translate
                      cur-ver
                      commercial-ver
                    ) ;replace
-                   (replace (string-append "You are using v%1, and the latest stable version of Liii STEM is v%2.\n"
-                              "Please click OK to visit the official website "
-                              "to download the latest stable version."
-                            ) ;string-append
+                   (replace (translate (string-append "You are using v%1, and the latest stable version of Liii STEM is v%2.\n"
+                                         "Please click OK to visit the official website "
+                                         "to download the latest stable version."
+                                       ) ;string-append
+                            ) ;translate
                      cur-ver
                      commercial-ver
                    ) ;replace
                  ) ;if
             ) ;msg
            ) ;
-        (if commercial-latest?
-          (show-message msg (translate "Version"))
-          (show-message-with-callback msg (translate "Version") (lambda x (open-url url)))
-        ) ;if
+        (show-version-dialog msg url (not commercial-latest?))
       ) ;let
     ) ;if
   ) ;let*
@@ -315,10 +321,7 @@
   ;; 根据语言设置加载远程文档的本地化版本
   (let* ((lan (string-take (language-to-locale (get-output-language)) 2))
          (lan_doc (string-append "http://git.tmml.wiki/texmacs/doc/raw/master/"
-                    path
-                    "."
-                    lan
-                    ".tm"
+                    path "." lan ".tm"
                   ) ;string-append
          ) ;lan_doc
          (en_doc (string-append "http://git.tmml.wiki/texmacs/doc/raw/master/" path ".en.tm")
diff --git a/TeXmacs/progs/doc/tmdoc-drd.scm b/TeXmacs/progs/doc/tmdoc-drd.scm
index d333607331..4617f7b0e0 100644
--- a/TeXmacs/progs/doc/tmdoc-drd.scm
+++ b/TeXmacs/progs/doc/tmdoc-drd.scm
@@ -41,22 +41,12 @@
 
 (define-group tmdoc-traversal-tag branch extra-branch continue optional-branch)
 
-(define-group tmdoc-menu-tag
-  menu
-  submenu
-  subsubmenu
-  subsubsubmenu
+(define-group tmdoc-menu-tag menu submenu subsubmenu subsubsubmenu
   subsubsubsubmenu
 ) ;define-group
 
-(define-group tmdoc-annotation-tag
-  markup
-  src-arg
-  src-var
-  src-length
-  src-tt
-  src-numeric
-  src-textual
+(define-group tmdoc-annotation-tag markup src-arg src-var src-length src-tt
+  src-numeric src-textual
 ) ;define-group
 
 (define-group tmdoc-style-annotation-tag tmstyle tmpackage tmdtd)
@@ -65,10 +55,7 @@
 
 (define-group tmdoc-big-box-tag big-focus big-envbox)
 
-(define-group tmdoc-if-ref-tag
-  tmdoc-if-ref
-  tmdoc-if-ref*
-  tmdoc-if-nref
+(define-group tmdoc-if-ref-tag tmdoc-if-ref tmdoc-if-ref* tmdoc-if-nref
   tmdoc-if-nref*
 ) ;define-group
 
diff --git a/TeXmacs/progs/doc/tmdoc-kbd.scm b/TeXmacs/progs/doc/tmdoc-kbd.scm
index 0c956ba5c2..1358dba2b4 100644
--- a/TeXmacs/progs/doc/tmdoc-kbd.scm
+++ b/TeXmacs/progs/doc/tmdoc-kbd.scm
@@ -12,9 +12,11 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (texmacs-module (doc tmdoc-kbd) (:use (text text-kbd)))
+(debug-message "keyboard" "(doc tmdoc-kbd): registering kbd-map ...\n")
 
 (kbd-map (:mode in-manual?)
  ("S-F7" (make 'scm))
  ("C-F7" (make 'scm-arg))
  ("M-F7" (make 'scm-code))
 ) ;kbd-map
+(debug-message "keyboard" "(doc tmdoc-kbd): kbd-map registered\n")
diff --git a/TeXmacs/progs/doc/tmdoc-menu.scm b/TeXmacs/progs/doc/tmdoc-menu.scm
index 9dc42a11e8..c7eb4e6d2d 100644
--- a/TeXmacs/progs/doc/tmdoc-menu.scm
+++ b/TeXmacs/progs/doc/tmdoc-menu.scm
@@ -123,9 +123,7 @@
 
 (tm-define (focus-can-move? t)
   (:require (tree-in? t
-              '(tmdoc-title tmweb-title
-                 tmdoc-copyright
-                 tmdoc-license
+              '(tmdoc-title tmweb-title tmdoc-copyright tmdoc-license
                  tmweb-license)
             ) ;tree-in?
   ) ;:require
diff --git a/TeXmacs/progs/doc/tmweb.scm b/TeXmacs/progs/doc/tmweb.scm
index 9b89449ba0..10e6be1cfd 100644
--- a/TeXmacs/progs/doc/tmweb.scm
+++ b/TeXmacs/progs/doc/tmweb.scm
@@ -195,79 +195,3 @@
     ) ;lambda
   ) ;user-url
 ) ;tm-define
-
-(tm-widget ((website-widget src-dir dest-dir) cmd)
-  (padded ===
-    ===
-    (refreshable "website-tool-directories"
-      (aligned (item (text "Source directory:")
-                 (hlist (input (when answer (set! src-dir answer)) "file" (list src-dir) "30em")
-                   //
-                   //
-                   (explicit-buttons ((balloon (icon "tm_find.xpm") "Choose source directory")
-                                      (cpp-choose-file (lambda (u)
-                                                         (set! src-dir (url->string u))
-                                                         (refresh-now "website-tool-directories")
-                                                       ) ;lambda
-                                        "Choose source dir"
-                                        "directory"
-                                        ""
-                                        (string->url src-dir)
-                                      ) ;cpp-choose-file
-                                     ) ;
-                   ) ;explicit-buttons
-                 ) ;hlist
-               ) ;item
-        (item (text "Destination directory:")
-          (hlist (input (when answer (set! dest-dir answer)) "file" (list dest-dir) "30em")
-            //
-            //
-            (explicit-buttons ((balloon (icon "tm_find.xpm") "Choose destination directory")
-                               (cpp-choose-file (lambda (u)
-                                                  (set! dest-dir (url->string u))
-                                                  (refresh-now "website-tool-directories")
-                                                ) ;lambda
-                                 "Choose dest dir"
-                                 "directory"
-                                 ""
-                                 (string->url dest-dir)
-                               ) ;cpp-choose-file
-                              ) ;
-            ) ;explicit-buttons
-          ) ;hlist
-        ) ;item
-      ) ;aligned
-    ) ;refreshable
-    ===
-    ===
-    (refreshable "website-tool-dialog-buttons"
-      (bottom-buttons >>>
-       ("Cancel" (cmd #f src-dir dest-dir #f))
-       //
-       //
-       ("Create" (cmd #t src-dir dest-dir #f))
-       //
-       //
-       ("Update" (cmd #t src-dir dest-dir #t))
-      ) ;bottom-buttons
-    ) ;refreshable
-  ) ;padded
-) ;tm-widget
-
-(tm-define (open-website-builder)
-  (:interactive #t)
-  (let ((src (get-preference "website:src-dir"))
-        (dest (get-preference "website:dest-dir"))
-       ) ;
-    (dialogue-window (website-widget src dest)
-      (lambda (flag? src dest update?)
-        (when flag?
-          (set-preference "website:src-dir" src)
-          (set-preference "website:dest-dir" dest)
-          (if update? (tmweb-update-dir src dest) (tmweb-convert-dir src dest))
-        ) ;when
-      ) ;lambda
-      "Create web site"
-    ) ;dialogue-window
-  ) ;let
-) ;tm-define
diff --git a/TeXmacs/progs/dynamic/animate-edit.scm b/TeXmacs/progs/dynamic/animate-edit.scm
index e40ad89c0d..7f8c5e6e5a 100644
--- a/TeXmacs/progs/dynamic/animate-edit.scm
+++ b/TeXmacs/progs/dynamic/animate-edit.scm
@@ -145,17 +145,7 @@
 (tm-define (parameter-choice-list var)
   (:require (or (string-starts? var "emboss-start-") (string-starts? var "emboss-end-"))
   ) ;:require
-  (list "-5ln"
-    "-4ln"
-    "-3ln"
-    "-2ln"
-    "-1ln"
-    "0ln"
-    "1ln"
-    "2ln"
-    "3ln"
-    "4ln"
-    "5ln"
+  (list "-5ln" "-4ln" "-3ln" "-2ln" "-1ln" "0ln" "1ln" "2ln" "3ln" "4ln" "5ln"
     :other
   ) ;list
 ) ;tm-define
diff --git a/TeXmacs/progs/dynamic/calc-drd.scm b/TeXmacs/progs/dynamic/calc-drd.scm
index 776f28b344..c8c63f97b2 100644
--- a/TeXmacs/progs/dynamic/calc-drd.scm
+++ b/TeXmacs/progs/dynamic/calc-drd.scm
@@ -17,25 +17,12 @@
 ;; Groups
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(define-group calc-table-tag
-  textual-table
-  numeric-dot-table
-  numeric-comma-table
+(define-group calc-table-tag textual-table numeric-dot-table numeric-comma-table
 ) ;define-group
 
-(define-group calc-labeled-tag
-  calc-inert
-  calc-input
-  calc-output
-  cell-input
-  cell-output
-  calc-generate
-  calc-generate-command
-  calc-answer
-  calc-answer-command
-  calc-check
-  calc-check-predicate
-  calc-check-command
+(define-group calc-labeled-tag calc-inert calc-input calc-output cell-input
+  cell-output calc-generate calc-generate-command calc-answer
+  calc-answer-command calc-check calc-check-predicate calc-check-command
   calc-suggest
 ) ;define-group
 
diff --git a/TeXmacs/progs/dynamic/calc-edit.scm b/TeXmacs/progs/dynamic/calc-edit.scm
index 81e15f51a3..917834ab23 100644
--- a/TeXmacs/progs/dynamic/calc-edit.scm
+++ b/TeXmacs/progs/dynamic/calc-edit.scm
@@ -452,8 +452,7 @@
 
 (tm-define (alternate-toggle t)
   (:require (tree-in? t
-              '(calc-input calc-generate-command
-                 calc-answer-command
+              '(calc-input calc-generate-command calc-answer-command
                  calc-check-predicate)
             ) ;tree-in?
   ) ;:require
diff --git a/TeXmacs/progs/dynamic/calc-kbd.scm b/TeXmacs/progs/dynamic/calc-kbd.scm
index e3935608f1..ed49c66625 100644
--- a/TeXmacs/progs/dynamic/calc-kbd.scm
+++ b/TeXmacs/progs/dynamic/calc-kbd.scm
@@ -12,6 +12,7 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (texmacs-module (dynamic calc-kbd) (:use (math math-kbd) (dynamic calc-table)))
+(debug-message "keyboard" "(dynamic calc-kbd): registering kbd-map ...\n")
 
 (kbd-map (:require (inside? 'calc-table))
  (", ," (make 'cell-commas))
@@ -33,3 +34,4 @@
  ("C-!" (calc-solutions #f))
  ("C-?" (calc-solutions #t))
 ) ;kbd-map
+(debug-message "keyboard" "(dynamic calc-kbd): kbd-map registered\n")
diff --git a/TeXmacs/progs/dynamic/dynamic-drd.scm b/TeXmacs/progs/dynamic/dynamic-drd.scm
index f7847e5abf..208531728c 100644
--- a/TeXmacs/progs/dynamic/dynamic-drd.scm
+++ b/TeXmacs/progs/dynamic/dynamic-drd.scm
@@ -108,10 +108,7 @@
 
 (define-group overlays-tag (std-overlays-tag) gr-overlays)
 
-(define-group std-overlays-tag
-  overlays
-  overlays-compressed
-  overlays-phantoms
+(define-group std-overlays-tag overlays overlays-compressed overlays-phantoms
   overlays-greyed
 ) ;define-group
 
@@ -121,25 +118,15 @@
   (binary-overlay-tag)
 ) ;define-group
 
-(define-group nullary-overlay-tag
-  show-always
-  show-from
-  show-until
-  show-this
+(define-group nullary-overlay-tag show-always show-from show-until show-this
   show-other
 ) ;define-group
 
-(define-group unary-overlay-tag
-  overlay-from
-  overlay-until
-  overlay-this
+(define-group unary-overlay-tag overlay-from overlay-until overlay-this
   overlay-other
 ) ;define-group
 
-(define-group binary-overlay-tag
-  alternate-from
-  alternate-until
-  alternate-this
+(define-group binary-overlay-tag alternate-from alternate-until alternate-this
   alternate-other
 ) ;define-group
 
@@ -177,16 +164,11 @@
 
 (define-group disappear-tag translate-out progressive-out fade-out zoom-out)
 
-(define-group smooth-tag
-  translate-smooth
-  progressive-smooth
-  fade-smooth
+(define-group smooth-tag translate-smooth progressive-smooth fade-smooth
   zoom-smooth
 ) ;define-group
 
-(define-group anim-emphasize-tag
-  shadowed-smooth
-  emboss-smooth
+(define-group anim-emphasize-tag shadowed-smooth emboss-smooth
   outlined-emboss-smooth
 ) ;define-group
 
diff --git a/TeXmacs/progs/dynamic/fold-edit.scm b/TeXmacs/progs/dynamic/fold-edit.scm
index 4e0e3417d4..0dad2dd7cb 100644
--- a/TeXmacs/progs/dynamic/fold-edit.scm
+++ b/TeXmacs/progs/dynamic/fold-edit.scm
@@ -26,20 +26,9 @@
 ;; Style package rules for beamer
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (tm-define (beamer-themes)
-  (list "bluish"
-    "dark"
-    "boring-white"
-    "dark-vador"
-    "granite"
-    "ice"
-    "manila-paper"
-    "metal"
-    "pale-blue"
-    "pine"
-    "reddish"
-    "ridged-paper"
-    "rough-paper"
-    "xperiment"
+  (list "bluish" "dark" "boring-white" "dark-vador" "granite" "ice"
+    "manila-paper" "metal" "pale-blue" "pine" "reddish" "ridged-paper"
+    "rough-paper" "xperiment"
   ) ;list
 ) ;tm-define
 
diff --git a/TeXmacs/progs/dynamic/fold-kbd.scm b/TeXmacs/progs/dynamic/fold-kbd.scm
index 17f4c8c774..f358b3004c 100644
--- a/TeXmacs/progs/dynamic/fold-kbd.scm
+++ b/TeXmacs/progs/dynamic/fold-kbd.scm
@@ -14,6 +14,7 @@
 (texmacs-module (dynamic fold-kbd)
   (:use (generic generic-kbd) (dynamic fold-edit))
 ) ;texmacs-module
+(debug-message "keyboard" "(dynamic fold-kbd): registering kbd-map ...\n")
 
 (define (reset-buffer-players)
   (players-set-elapsed (buffer-tree) 0.0)
@@ -47,3 +48,4 @@
  ("F10" (screens-switch-to :previous))
  ("F11" (screens-switch-to :next))
 ) ;kbd-map
+(debug-message "keyboard" "(dynamic fold-kbd): kbd-map registered\n")
diff --git a/TeXmacs/progs/dynamic/fold-menu.scm b/TeXmacs/progs/dynamic/fold-menu.scm
index 24daea15de..ee093d2a12 100644
--- a/TeXmacs/progs/dynamic/fold-menu.scm
+++ b/TeXmacs/progs/dynamic/fold-menu.scm
@@ -514,24 +514,13 @@
       (hlist (refreshable "slide-color-sample"
                (resize "150px"
                  "100px"
-                 (texmacs-output `(document (block (tformat (cwith "1"
-                                                              "1"
-                                                              "1"
-                                                              "1"
-                                                              "cell-width"
+                 (texmacs-output `(document (block (tformat (cwith "1" "1" "1"
+                                                              "1" "cell-width"
                                                               "140px")
-                                                     (cwith "1"
-                                                       "1"
-                                                       "1"
-                                                       "1"
-                                                       "cell-height"
-                                                       "90px")
-                                                     (cwith "1"
-                                                       "1"
-                                                       "1"
-                                                       "1"
-                                                       "cell-vmode"
-                                                       "exact")
+                                                     (cwith "1" "1" "1" "1"
+                                                       "cell-height" "90px")
+                                                     (cwith "1" "1" "1" "1"
+                                                       "cell-vmode" "exact")
                                                      (cwith ,"1"
                                                        ,"1"
                                                        ,"1"
diff --git a/TeXmacs/progs/dynamic/program-edit.scm b/TeXmacs/progs/dynamic/program-edit.scm
index 4496cb1251..e315475aba 100644
--- a/TeXmacs/progs/dynamic/program-edit.scm
+++ b/TeXmacs/progs/dynamic/program-edit.scm
@@ -417,10 +417,7 @@
 ) ;tm-define
 
 (tm-define prog-field-tags
-  '(input unfolded-prog-io
-     folded-prog-io
-     input-math
-     unfolded-prog-io-math
+  '(input unfolded-prog-io folded-prog-io input-math unfolded-prog-io-math
      folded-prog-io-math)
 ) ;tm-define
 
@@ -682,7 +679,7 @@
       prog-field-input-context?
       (with u
         (tree-ref t :previous 0)
-        (if (url-exists? (url-unix "$TEXMACS_STYLE_PATH" (string-append lan ".ts")))
+        (if (url-exists? (url-unix "$TEXMACS_STYLE_PATH" (string-append lan ".stem")))
           (add-style-package lan)
         ) ;if
         (program-feed lan ses :start u t '())
diff --git a/TeXmacs/progs/dynamic/scripts-edit.scm b/TeXmacs/progs/dynamic/scripts-edit.scm
index 856e2a0bc4..f0c5eb30ab 100644
--- a/TeXmacs/progs/dynamic/scripts-edit.scm
+++ b/TeXmacs/progs/dynamic/scripts-edit.scm
@@ -138,7 +138,7 @@
 (tm-define (evaluate-context? t) (tree-in? t '(script-input script-output)))
 
 (tm-define (make-script-input* lan ses)
-  (if (url-exists? (url-unix "$TEXMACS_STYLE_PATH" (string-append lan ".ts")))
+  (if (url-exists? (url-unix "$TEXMACS_STYLE_PATH" (string-append lan ".stem")))
     (add-style-package lan)
   ) ;if
   (insert-go-to `(script-input ,lan ,ses ,"" ,"") '(2 0))
diff --git a/TeXmacs/progs/dynamic/scripts-kbd.scm b/TeXmacs/progs/dynamic/scripts-kbd.scm
index c9c9ee6e2c..97b6129171 100644
--- a/TeXmacs/progs/dynamic/scripts-kbd.scm
+++ b/TeXmacs/progs/dynamic/scripts-kbd.scm
@@ -14,6 +14,7 @@
 (texmacs-module (dynamic scripts-kbd)
   (:use (math math-kbd) (dynamic scripts-edit))
 ) ;texmacs-module
+(debug-message "keyboard" "(dynamic scripts-kbd): registering kbd-map ...\n")
 
 (kbd-map ("script *" (make 'script-eval))
  ("script !" (make-script-input))
@@ -26,3 +27,4 @@
  ("std \\" (insert-go-to '(converter-eval "latex" "") '(1 0)))
  ("std \\ var" (insert-go-to '(converter-input "latex" "" "") '(1 0)))
 ) ;kbd-map
+(debug-message "keyboard" "(dynamic scripts-kbd): kbd-map registered\n")
diff --git a/TeXmacs/progs/dynamic/scripts-plot.scm b/TeXmacs/progs/dynamic/scripts-plot.scm
index 06fa6b6988..00e750f59b 100644
--- a/TeXmacs/progs/dynamic/scripts-plot.scm
+++ b/TeXmacs/progs/dynamic/scripts-plot.scm
@@ -165,40 +165,31 @@
 (define sine (list "($graph2d -10 10 200 sin)"))
 
 (define sine-cosine
-  (list "($graphical"
-    "  ($pen-color \"dark blue\""
-    "    ($graph2d -10 10 200 sin))"
-    "  ($pen-color \"dark green\""
+  (list "($graphical" "  ($pen-color \"dark blue\""
+    "    ($graph2d -10 10 200 sin))" "  ($pen-color \"dark green\""
     "    ($graph2d -10 10 200 cos)))"
   ) ;list
 ) ;define
 
 (define lissajous
-  (list "($fill-color \"pastel yellow\""
-    "  ($curve2d -3.14159 3.14159 500"
+  (list "($fill-color \"pastel yellow\"" "  ($curve2d -3.14159 3.14159 500"
     "    (lambda (t) (* 4 (sin (* 6 t))))"
     "    (lambda (t) (* 3 (cos (* 10 t))))))"
   ) ;list
 ) ;define
 
 (define animation-1
-  (list "($animation \"0.2s\""
-    "  ($for (t (.. 1 40))"
-    "    ($graph2d -10 10 (* 20 t)"
-    "      (lambda (x)"
+  (list "($animation \"0.2s\"" "  ($for (t (.. 1 40))"
+    "    ($graph2d -10 10 (* 20 t)" "      (lambda (x)"
     "        (/ (sin (* 0.2 x t)) (+ (* x x) 1))))))"
   ) ;list
 ) ;define
 
 (define animation-2
-  (list "($animation \"0.2s\""
-    "  ($for (k (.. 0 101))"
-    "    ($fill-color \"pastel yellow\""
-    "      ($curve2d -3.14159 3.14159 400"
-    "        (lambda (t)"
-    "          (* 4 (sin (+ (* 6 t) (* k 0.0314159)))))"
-    "        (lambda (t)"
-    "          (* 3 (cos (* 10 t))))))))"
+  (list "($animation \"0.2s\"" "  ($for (k (.. 0 101))"
+    "    ($fill-color \"pastel yellow\"" "      ($curve2d -3.14159 3.14159 400"
+    "        (lambda (t)" "          (* 4 (sin (+ (* 6 t) (* k 0.0314159)))))"
+    "        (lambda (t)" "          (* 3 (cos (* 10 t))))))))"
   ) ;list
 ) ;define
 
diff --git a/TeXmacs/progs/dynamic/session-edit.scm b/TeXmacs/progs/dynamic/session-edit.scm
index 23cb81e0af..115b90ece8 100644
--- a/TeXmacs/progs/dynamic/session-edit.scm
+++ b/TeXmacs/progs/dynamic/session-edit.scm
@@ -610,14 +610,8 @@
 ) ;tm-define
 
 (tm-define field-tags
-  '(input unfolded-io
-     folded-io
-     input-math
-     unfolded-io-math
-     folded-io-math
-     input-text
-     unfolded-io-text
-     folded-io-text)
+  '(input unfolded-io folded-io input-math unfolded-io-math folded-io-math
+     input-text unfolded-io-text folded-io-text)
 ) ;tm-define
 
 (tm-define (field-context? t)
@@ -946,7 +940,7 @@
       field-input-context?
       (with u
         (tree-ref t :previous 0)
-        (if (url-exists? (url-unix "$TEXMACS_STYLE_PATH" (string-append lan ".ts")))
+        (if (url-exists? (url-unix "$TEXMACS_STYLE_PATH" (string-append lan ".stem")))
           (add-style-package lan)
         ) ;if
         (if (not (has-style-package? "framed-session"))
diff --git a/TeXmacs/progs/dynamic/session-menu.scm b/TeXmacs/progs/dynamic/session-menu.scm
index 98fdcad1be..ffc9623f1a 100644
--- a/TeXmacs/progs/dynamic/session-menu.scm
+++ b/TeXmacs/progs/dynamic/session-menu.scm
@@ -19,8 +19,6 @@
   ) ;:use
 ) ;texmacs-module
 
-(import (liii os) (liii sys))
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Remote plugins
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -131,20 +129,8 @@
 (define binary-path "")
 
 (define binary-list
-  (list "python"
-    "aspell"
-    "conda"
-    "convert"
-    "goldfish"
-    "ghostscript"
-    "hunspell"
-    "identify"
-    "inkscape"
-    "julia"
-    "pandoc"
-    "pdftocairo"
-    "rsvg-convert"
-    "maxima"
+  (list "python" "aspell" "conda" "convert" "goldfish" "ghostscript" "hunspell"
+    "identify" "inkscape" "julia" "pandoc" "pdftocairo" "rsvg-convert" "maxima"
   ) ;list
 ) ;define
 
@@ -232,7 +218,7 @@
                                             (refresh-now "input-path-widget")
                                           ) ;lambda
                                "Choose binary file"
-                               (if (os-win32?) "windows-executables" "generic")
+                               (if (os-windows?) "windows-executables" "generic")
                              ) ;choose-file
                             ) ;
           ) ;explicit-buttons
diff --git a/TeXmacs/progs/education/edu-drd.scm b/TeXmacs/progs/education/edu-drd.scm
index 535d13b3b9..157b393bbf 100644
--- a/TeXmacs/progs/education/edu-drd.scm
+++ b/TeXmacs/progs/education/edu-drd.scm
@@ -25,36 +25,18 @@
 
 (define-group similar-tag (short-question-tag) (short-answer-tag))
 
-(define-group short-question-tag
-  question-arabic
-  question-alpha
-  question-Alpha
-  question-roman
-  question-Roman
-  question-item
+(define-group short-question-tag question-arabic question-alpha question-Alpha
+  question-roman question-Roman question-item
 ) ;define-group
 
-(define-group short-answer-tag
-  answer-arabic
-  answer-alpha
-  answer-Alpha
-  answer-roman
-  answer-Roman
-  answer-item
+(define-group short-answer-tag answer-arabic answer-alpha answer-Alpha
+  answer-roman answer-Roman answer-item
 ) ;define-group
 
 ;; Buttons
 
-(define-group button-tag
-  button-box
-  button-box*
-  button-circle
-  button-circle*
-  button-arabic
-  button-alpha
-  button-Alpha
-  button-roman
-  button-Roman
+(define-group button-tag button-box button-box* button-circle button-circle*
+  button-arabic button-alpha button-Alpha button-roman button-Roman
 ) ;define-group
 
 (define-group variant-tag (button-tag))
@@ -62,17 +44,9 @@
 
 ;; Buttons themes
 
-(define-group with-button-tag
-  with-button-box
-  with-button-box*
-  with-button-circle
-  with-button-circle*
-  with-button-arabic
-  with-button-alpha
-  with-button-Alpha
-  with-button-roman
-  with-button-Roman
-  with-button-ornament
+(define-group with-button-tag with-button-box with-button-box*
+  with-button-circle with-button-circle* with-button-arabic with-button-alpha
+  with-button-Alpha with-button-roman with-button-Roman with-button-ornament
 ) ;define-group
 
 (define-group variant-tag (with-button-tag))
diff --git a/TeXmacs/progs/education/edu-kbd.scm b/TeXmacs/progs/education/edu-kbd.scm
index ce1cd4550d..ada7463d6e 100644
--- a/TeXmacs/progs/education/edu-kbd.scm
+++ b/TeXmacs/progs/education/edu-kbd.scm
@@ -12,6 +12,7 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (texmacs-module (education edu-kbd) (:use (education edu-edit)))
+(debug-message "keyboard" "(education edu-kbd): registering kbd-map ...\n")
 
 (kbd-map (:mode in-edu-text?)
  ("text c" (make-mc 'mc))
@@ -30,3 +31,4 @@
  (". . ." (make 'gap))
  (". . . ." (make 'gap-wide))
 ) ;kbd-map
+(debug-message "keyboard" "(education edu-kbd): kbd-map registered\n")
diff --git a/TeXmacs/progs/fonts/font-new-widgets.scm b/TeXmacs/progs/fonts/font-new-widgets.scm
index dfdfc1241a..ed3bb140b7 100644
--- a/TeXmacs/progs/fonts/font-new-widgets.scm
+++ b/TeXmacs/progs/fonts/font-new-widgets.scm
@@ -98,23 +98,9 @@
 ) ;define
 
 (define customize-vars
-  (list "bold"
-    "italic"
-    "smallcaps"
-    "sansserif"
-    "typewriter"
-    "math"
-    "greek"
-    "bbb"
-    "cal"
-    "frak"
-    "embold"
-    "embbb"
-    "slant"
-    "hmagnify"
-    "vmagnify"
-    "hextended"
-    "vextended"
+  (list "bold" "italic" "smallcaps" "sansserif" "typewriter" "math" "greek"
+    "bbb" "cal" "frak" "embold" "embbb" "slant" "hmagnify" "vmagnify"
+    "hextended" "vextended"
   ) ;list
 ) ;define
 
@@ -193,14 +179,17 @@
        ,"Special: ([{|}]) \"`,.:;!?'\" @#$%&_\\~"
        ,(string-append "Accented: <#E0><#E1><#E4><#E2><#E3><#E8><#E9><#EB><#EA><#EC><#ED><#EF>"
           "<#EE><#F2><#F3><#F6><#F4><#F5><#F9><#FA><#FC><#FB>")
-       ,(string-append "Greek: "
+       ,(string-append
+          "Greek: "
           ""
           "")
-       ,(string-append "Cyrillic: <#430><#431><#432><#433><#434><#435><#436><#437>"
+       ,(string-append
+          "Cyrillic: <#430><#431><#432><#433><#434><#435><#436><#437>"
           "<#438><#439><#43A><#43B><#43C><#43D><#43E><#43F>"
           "<#440><#441><#442><#443><#444><#445><#446><#447>"
           "<#448><#449><#44A><#44B><#44C><#44D><#44E><#44F>")
-       ,(string-append "Mathematics:  "
+       ,(string-append
+          "Mathematics:  "
           " "
           "")
        (concat "Variants: "
@@ -223,27 +212,32 @@
        (concat "Uppercase Roman: "
          (math "A B C D E F G H I J K L M N O P Q R S T U V W X Y Z"))
        (concat ,"Lowercase Greek: "
-         (math ,(string-append "      "
+         (math ,(string-append
+                  "      "
                   "        "
                   "       "
                   "  ")))
        (concat ,"Uppercase Greek: "
-         (math ,(string-append "      "
+         (math ,(string-append
+                  "      "
                   "        "
                   "       "
                   "  ")))
        (concat ,"Blackboard bold: "
-         (math ,(string-append "      "
+         (math ,(string-append
+                  "      "
                   "       "
                   "       "
                   "     ")))
        (concat ,"Calligraphic: "
-         (math ,(string-append "      "
+         (math ,(string-append
+                  "      "
                   "       "
                   "       "
                   "     ")))
        (concat ,"Fraktur: "
-         (math ,(string-append "     "
+         (math ,(string-append
+                  "     "
                   "      "
                   "      "
                   "      "
@@ -378,7 +372,7 @@
          (lf (logical-font-private fam var ser sh))
          (fn2 (logical-font-search lf))
          (fn1 (list (selector-get specs :family) (selector-get specs :style)))
-         (sel (string-recompose (selected-properties specs) " "))
+         (sel (string-join (selected-properties specs) " "))
          (nm1 (string-append (car fn1) " " (cadr fn1)))
          (nm2 (string-append (car fn2) " " (cadr fn2)))
          (nm+ (if (== sel "") nm1 (string-append nm1 " + " sel)))
@@ -602,7 +596,7 @@
       (add "bold" embold)
       (add "bbb" embbb)
       (add "slant" slant)
-      (string-recompose effs ",")
+      (string-join effs ",")
     ) ;with
   ) ;let*
 ) ;define
@@ -612,50 +606,12 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (tm-define (font-default-sizes)
-  '("5"
-    "5.5"
-    "6.5"
-    "7.5"
-    "8"
-    "9"
-    "10"
-    "10.5"
-    "12"
-    "14"
-    "15"
-    "16"
-    "18"
-    "20"
-    "22"
-    "24"
-    "26"
-    "36"
-    "42"
-    "48"
-    "64"
-    "72"
-    "96"
-    "128"
-    "144"
-    "192")
+  '("5" "5.5" "6.5" "7.5" "8" "9" "10" "10.5" "12" "14" "15" "16" "18" "20" "22"
+    "24" "26" "36" "42" "48" "64" "72" "96" "128" "144" "192")
 ) ;tm-define
 
 (tm-define (font-default-sizes*)
-  '("8"
-    "8.5"
-    "9"
-    "9.5"
-    "10"
-    "10.5"
-    "11"
-    "11.5"
-    "12"
-    "14"
-    "16"
-    "18"
-    "20"
-    "24"
-    "")
+  '("8" "8.5" "9" "9.5" "10" "10.5" "11" "11.5" "12" "14" "16" "18" "20" "24" "")
 ) ;tm-define
 
 (tm-widget (font-family-selector* specs)
@@ -764,22 +720,9 @@
     ) ;item
     (item (text "Category:")
       (enum (selector-set* specs :category answer)
-        '("Any"
-          "Ancient"
-          "Attached"
-          "Calligraphic"
-          "Comic"
-          "Decorative"
-          "Distorted"
-          "Gothic"
-          "Handwritten"
-          "Initials"
-          "Medieval"
-          "Miscellaneous"
-          "Outline"
-          "Retro"
-          "Scifi"
-          "Title")
+        '("Any" "Ancient" "Attached" "Calligraphic" "Comic" "Decorative"
+          "Distorted" "Gothic" "Handwritten" "Initials" "Medieval"
+          "Miscellaneous" "Outline" "Retro" "Scifi" "Title")
         (selector-get specs :category)
         "150px"
       ) ;enum
@@ -787,16 +730,8 @@
     (item ====== ======)
     (item (text "Glyphs:")
       (enum (selector-set* specs :glyphs answer)
-        '("Any"
-          "ASCII"
-          "Latin"
-          "Greek"
-          "Cyrillic"
-          "CJK"
-          "Hangul"
-          "Math Symbols"
-          "Math Extra"
-          "Math Letters")
+        '("Any" "ASCII" "Latin" "Greek" "Cyrillic" "CJK" "Hangul" "Math Symbols"
+          "Math Extra" "Math Letters")
         (selector-get specs :glyphs)
         "150px"
       ) ;enum
@@ -814,35 +749,11 @@
   (cond ((== which "embold") '("1" "1.25" "1.5" "2" "2.5" "3" "3.5" "4" ""))
         ((== which "embbb") '("1" "1.5" "2" "2.5" "3" "3.5" "4" "4.5" "5" ""))
         ((== which "slant")
-         '("-0.5"
-           "-0.25"
-           "-0.1"
-           "0"
-           "0.1"
-           "0.2"
-           "0.25"
-           "0.3"
-           "0.4"
-           "0.5"
-           "0.75"
-           "1"
-           "")
+         '("-0.5" "-0.25" "-0.1" "0" "0.1" "0.2" "0.25" "0.3" "0.4" "0.5" "0.75"
+           "1" "")
         ) ;
-        (else '("0.5"
-                "0.6"
-                "0.7"
-                "0.8"
-                "0.9"
-                "1"
-                "1.1"
-                "1.2"
-                "1.3"
-                "1.4"
-                "1.5"
-                "1.6"
-                "1.8"
-                "2"
-                "")
+        (else '("0.5" "0.6" "0.7" "0.8" "0.9" "1" "1.1" "1.2" "1.3" "1.4" "1.5"
+                "1.6" "1.8" "2" "")
         ) ;else
   ) ;cond
 ) ;define
@@ -880,12 +791,8 @@
 ) ;tm-widget
 
 (define (default-subfonts-list which)
-  '("TeXmacs Computer Modern"
-    "Stix"
-    "TeX Gyre Bonum"
-    "TeX Gyre Pagella"
-    "TeX Gyre Schola"
-    "TeX Gyre Termes")
+  '("TeXmacs Computer Modern" "Stix" "TeX Gyre Bonum" "TeX Gyre Pagella"
+    "TeX Gyre Schola" "TeX Gyre Termes")
 ) ;define
 
 (define (default-subfonts which)
@@ -1139,17 +1046,17 @@
 ;; 往返。返回 assoc list，bridge 转 QVariantMap。family 改动刷新 style 列表。
 (tm-define (font-selector-set-family key family)
   (font-selector-set key :family family)
-  `((styles unquote (font-selector-styles key family))
-    (preview unquote (font-selector-preview key)))
+  `((styles . ,(font-selector-styles key family))
+    (preview . ,(font-selector-preview key)))
 ) ;tm-define
 
 (tm-define (font-selector-set-style key style)
   (font-selector-set key :style style)
-  `((preview unquote (font-selector-preview key)))
+  `((preview . ,(font-selector-preview key)))
 ) ;tm-define
 (tm-define (font-selector-set-size key size)
   (font-selector-set key :size size)
-  `((preview unquote (font-selector-preview key)))
+  `((preview . ,(font-selector-preview key)))
 ) ;tm-define
 
 ;; 9 项 Filter 的可选项（集中自原 tm-widget 内联）。var 用 string（无冒号），facade
@@ -1166,34 +1073,13 @@
       '("Any" "Print" "Typewriter" "Digital" "Pen" "Art Pen" "Chalk" "Marker")
     ) ;cons
     (cons "category"
-      '("Any"
-        "Ancient"
-        "Attached"
-        "Calligraphic"
-        "Comic"
-        "Decorative"
-        "Distorted"
-        "Gothic"
-        "Handwritten"
-        "Initials"
-        "Medieval"
-        "Miscellaneous"
-        "Outline"
-        "Retro"
-        "Scifi"
-        "Title")
+      '("Any" "Ancient" "Attached" "Calligraphic" "Comic" "Decorative"
+        "Distorted" "Gothic" "Handwritten" "Initials" "Medieval" "Miscellaneous"
+        "Outline" "Retro" "Scifi" "Title")
     ) ;cons
     (cons "glyphs"
-      '("Any"
-        "ASCII"
-        "Latin"
-        "Greek"
-        "Cyrillic"
-        "CJK"
-        "Hangul"
-        "Math Symbols"
-        "Math Extra"
-        "Math Letters")
+      '("Any" "ASCII" "Latin" "Greek" "Cyrillic" "CJK" "Hangul" "Math Symbols"
+        "Math Extra" "Math Letters")
     ) ;cons
   ) ;list
 ) ;define
@@ -1239,8 +1125,8 @@
 ;; 转 keyword。
 (tm-define (font-selector-set-filter key var val)
   (selector-set (font-selector-lookup-specs key) (string->keyword var) val)
-  `((families unquote (font-selector-families key))
-    (preview unquote (font-selector-preview key)))
+  `((families . ,(font-selector-families key))
+    (preview . ,(font-selector-preview key)))
 ) ;tm-define
 
 ;; 预览光栅化：同步返回 data URL。bg-color/magnification 包裹照搬 font-sample-text。
@@ -1263,23 +1149,10 @@
 ;; 样本类型。
 
 (define font-sample-kinds
-  '("Standard"
-    "Mathematics"
-    "Selection"
-    "ASCII"
-    "Latin"
-    "Greek"
-    "Cyrillic"
-    "CJK"
-    "Hangul"
-    "Math Symbols"
-    "Math Extra"
-    "Math Letters"
-    "Unicode 0000-0fff"
-    "Unicode 1000-1fff"
-    "Unicode 2000-2fff"
-    "Unicode 3000-3fff"
-    "Unicode 4000-4fff")
+  '("Standard" "Mathematics" "Selection" "ASCII" "Latin" "Greek" "Cyrillic"
+    "CJK" "Hangul" "Math Symbols" "Math Extra" "Math Letters"
+    "Unicode 0000-0fff" "Unicode 1000-1fff" "Unicode 2000-2fff"
+    "Unicode 3000-3fff" "Unicode 4000-4fff")
 ) ;define
 
 (tm-define (font-selector-sample-kinds key) font-sample-kinds)
@@ -1287,7 +1160,7 @@
 ;; 设样本类型，返回 {preview}（样本内容随类型变）。
 (tm-define (font-selector-set-sample-kind key kind)
   (set-font-sample-kind kind)
-  `((preview unquote (font-selector-preview key)))
+  `((preview . ,(font-selector-preview key)))
 ) ;tm-define
 
 ;; Advanced 定制（Effects / Variants / Mathematics）。每项返回
@@ -1325,16 +1198,8 @@
 
 (define (font-selector-subfont? which)
   (in? which
-    '("bold"
-      "italic"
-      "smallcaps"
-      "sansserif"
-      "typewriter"
-      "math"
-      "greek"
-      "bbb"
-      "cal"
-      "frak")
+    '("bold" "italic" "smallcaps" "sansserif" "typewriter" "math" "greek" "bbb"
+      "cal" "frak")
   ) ;in?
 ) ;define
 
@@ -1477,15 +1342,15 @@
 ;; 固定 UI 文案的翻译，供 QML 一次性拉取。key 为稳定标识符，value 经 translate
 ;; 跟随界面语言。
 (tm-define (font-selector-ui-labels key)
-  `((family unquote (translate "Font family"))
-    (style unquote (translate "Style"))
-    (size unquote (translate "Size"))
-    (sample unquote (translate "Sample"))
-    (filter unquote (translate "Filter"))
-    (advanced unquote (translate "Advanced"))
-    (import unquote (translate "Import"))
-    (reset unquote (translate "Reset"))
-    (ok unquote (translate "Ok"))
-    (cancel unquote (translate "Cancel"))
-    (done unquote (translate "Done")))
+  `((family . ,(translate "Font family"))
+    (style . ,(translate "Style"))
+    (size . ,(translate "Size"))
+    (sample . ,(translate "Sample"))
+    (filter . ,(translate "Filter"))
+    (advanced . ,(translate "Advanced"))
+    (import . ,(translate "Import"))
+    (reset . ,(translate "Reset"))
+    (ok . ,(translate "Ok"))
+    (cancel . ,(translate "Cancel"))
+    (done . ,(translate "Done")))
 ) ;tm-define
diff --git a/TeXmacs/progs/fonts/font-sample.scm b/TeXmacs/progs/fonts/font-sample.scm
index 3d2abde357..df6d3772de 100644
--- a/TeXmacs/progs/fonts/font-sample.scm
+++ b/TeXmacs/progs/fonts/font-sample.scm
@@ -343,22 +343,8 @@
     (new-local-fonts)
     ;; '(("Arial" "Italic") ("Fava" "Regular"))
     (with kinds
-      (list :name
-        :thin
-        :light
-        :bold
-        :black
-        :oblique
-        :italic
-        :condensed
-        :wide
-        :smallcaps
-        :mono
-        :sansserif
-        :typewriter
-        "abc"
-        "ABC"
-        "123"
+      (list :name :thin :light :bold :black :oblique :italic :condensed :wide
+        :smallcaps :mono :sansserif :typewriter "abc" "ABC" "123"
       ) ;list
       (tm->tree (build-font-table fns kinds))
     ) ;with
diff --git a/TeXmacs/progs/fonts/fonts-math.scm b/TeXmacs/progs/fonts/fonts-math.scm
index 7bed2be9a9..cad0b02ebf 100644
--- a/TeXmacs/progs/fonts/fonts-math.scm
+++ b/TeXmacs/progs/fonts/fonts-math.scm
@@ -18,27 +18,9 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (set-font-rules '(;; Main math font
-                  ((math $ecrm
-                     $cmr
-                     $cmmi
-                     $cmsy
-                     $msam
-                     $msbm
-                     $stmary
-                     $wasy
-                     $line
-                     $cal
-                     $calstar
-                     $frak
-                     $bbb
-                     $bbbcap
-                     $upgreek
-                     $bold1
-                     $bold2
-                     $boldcal
-                     $cmex
-                     $s
-                     $d)
+                  ((math $ecrm $cmr $cmmi $cmsy $msam $msbm $stmary $wasy $line
+                     $cal $calstar $frak $bbb $bbbcap $upgreek $bold1 $bold2
+                     $boldcal $cmex $s $d)
                    (math (math (tex $cmr $s $d)
                            (tex $cmmi $s $d)
                            (tex $cmsy $s $d)
@@ -67,115 +49,23 @@
                      (ec $ecrm $s $d)
                      (ec ecrm $s $d)))
                   ((math-std $ecrm $cmr $cmmi $s $d)
-                   (math $ecrm
-                     $cmr
-                     $cmmi
-                     cmsy
-                     msam
-                     msbm
-                     stmary
-                     wasy
-                     line
-                     cmsy
-                     rsfs
-                     eufm
-                     bbm
-                     bbold
-                     grmn
-                     cmbx
-                     cmmib
-                     cmbsy
-                     cmex
-                     $s
-                     $d))
+                   (math $ecrm $cmr $cmmi cmsy msam msbm stmary wasy line cmsy
+                     rsfs eufm bbm bbold grmn cmbx cmmib cmbsy cmex $s $d))
                   ((bold-math-std $ecrm $cmr $cmmi $s $d)
-                   (math $ecrm
-                     $cmr
-                     $cmmi
-                     cmbsy
-                     msam
-                     msbm
-                     stmary
-                     wasyb
-                     linew
-                     cmbsy
-                     rsfs
-                     eufb
-                     bbmbx
-                     bbold
-                     grxn
-                     cmbx
-                     cmmib
-                     cmbsy
-                     cmexb
-                     $s
+                   (math $ecrm $cmr $cmmi cmbsy msam msbm stmary wasyb linew
+                     cmbsy rsfs eufb bbmbx bbold grxn cmbx cmmib cmbsy cmexb $s
                      $d))
                   ((math-conc $ecrm $cmr $cmmi $s $d)
-                   (math $ecrm
-                     $cmr
-                     $cmmi
-                     xccsy
-                     xccam
-                     xccbm
-                     stmary
-                     wasy
-                     line
-                     cmsy
-                     rsfs
-                     eufm
-                     bbm
-                     bbold
-                     grmn
-                     cmbx
-                     cmmib
-                     cmbsy
-                     xccex
-                     $s
-                     $d))
+                   (math $ecrm $cmr $cmmi xccsy xccam xccbm stmary wasy line
+                     cmsy rsfs eufm bbm bbold grmn cmbx cmmib cmbsy xccex $s $d))
                   ((math-bright $ecrm $cmr $cmmi $s $d)
-                   (math $ecrm
-                     $cmr
-                     $cmmi
-                     cmbrsy
-                     cmbram
-                     cmbrbm
-                     stmary
-                     wasy
-                     line
-                     cmbrsy
-                     rsfs
-                     eufb
-                     bbmbx
-                     bbold
-                     grxn
-                     cmbx
-                     cmmib
-                     cmbsy
-                     cmex
-                     $s
+                   (math $ecrm $cmr $cmmi cmbrsy cmbram cmbrbm stmary wasy line
+                     cmbrsy rsfs eufb bbmbx bbold grxn cmbx cmmib cmbsy cmex $s
                      $d))
                   ;; Upright math font
-                  ((var-math $ecrm
-                     $cmr
-                     $cmmi
-                     $cmsy
-                     $msam
-                     $msbm
-                     $stmary
-                     $wasy
-                     $line
-                     $cal
-                     $calstar
-                     $frak
-                     $bbb
-                     $bbbcap
-                     $upgreek
-                     $bold1
-                     $bold2
-                     $boldcal
-                     $cmex
-                     $s
-                     $d)
+                  ((var-math $ecrm $cmr $cmmi $cmsy $msam $msbm $stmary $wasy
+                     $line $cal $calstar $frak $bbb $bbbcap $upgreek $bold1
+                     $bold2 $boldcal $cmex $s $d)
                    (math (var-math (tex $cmmi $s $d)
                            (tex $cmr $s $d)
                            (tex $cmsy $s $d)
@@ -204,28 +94,9 @@
                      (ec $ecrm $s $d)
                      (ec ecrm $s $d)))
                   ;; Math font with modified italic math letters
-                  ((alt-math $ecrm
-                     $ecti
-                     $cmr
-                     $cmmi
-                     $cmsy
-                     $msam
-                     $msbm
-                     $stmary
-                     $wasy
-                     $line
-                     $cal
-                     $calstar
-                     $frak
-                     $bbb
-                     $bbbcap
-                     $upgreek
-                     $bold1
-                     $bold2
-                     $boldcal
-                     $cmex
-                     $s
-                     $d)
+                  ((alt-math $ecrm $ecti $cmr $cmmi $cmsy $msam $msbm $stmary
+                     $wasy $line $cal $calstar $frak $bbb $bbbcap $upgreek
+                     $bold1 $bold2 $boldcal $cmex $s $d)
                    (math (alt-math (tex $cmr $s $d)
                            (tex $cmmi $s $d)
                            (tex $ecti $s $d)
@@ -255,273 +126,49 @@
                      (ec $ecrm $s $d)
                      (ec ecrm $s $d)))
                   ((math-std $ecrm $cmr $cmmi $s $d)
-                   (math $ecrm
-                     $cmr
-                     $cmmi
-                     cmsy
-                     msam
-                     msbm
-                     stmary
-                     wasy
-                     line
-                     cmsy
-                     rsfs
-                     eufm
-                     bbm
-                     msbm
-                     grmn
-                     cmbx
-                     cmmib
-                     cmbsy
-                     cmex
-                     $s
-                     $d))
+                   (math $ecrm $cmr $cmmi cmsy msam msbm stmary wasy line cmsy
+                     rsfs eufm bbm msbm grmn cmbx cmmib cmbsy cmex $s $d))
                   ((bold-math-std $ecrm $cmr $cmmi $s $d)
-                   (math $ecrm
-                     $cmr
-                     $cmmi
-                     cmbsy
-                     msam
-                     msbm
-                     stmary
-                     wasyb
-                     linew
-                     cmbsy
-                     rsfs
-                     eufb
-                     bbmbx
-                     msbm
-                     grxn
-                     cmbx
-                     cmmib
-                     cmbsy
-                     cmexb
-                     $s
+                   (math $ecrm $cmr $cmmi cmbsy msam msbm stmary wasyb linew
+                     cmbsy rsfs eufb bbmbx msbm grxn cmbx cmmib cmbsy cmexb $s
                      $d))
                   ((math-conc $ecrm $cmr $cmmi $s $d)
-                   (math $ecrm
-                     $cmr
-                     $cmmi
-                     xccsy
-                     xccam
-                     xccbm
-                     stmary
-                     wasy
-                     line
-                     cmsy
-                     rsfs
-                     eufm
-                     bbm
-                     msbm
-                     grmn
-                     cmbx
-                     cmmib
-                     cmbsy
-                     xccex
-                     $s
-                     $d))
+                   (math $ecrm $cmr $cmmi xccsy xccam xccbm stmary wasy line
+                     cmsy rsfs eufm bbm msbm grmn cmbx cmmib cmbsy xccex $s $d))
                   ((math-bright $ecrm $cmr $cmmi $s $d)
-                   (math $ecrm
-                     $cmr
-                     $cmmi
-                     cmbrsy
-                     cmbram
-                     cmbrbm
-                     stmary
-                     wasy
-                     line
-                     cmbrsy
-                     rsfs
-                     eufb
-                     bbmbx
-                     msbm
-                     grxn
-                     cmbx
-                     cmmib
-                     cmbsy
-                     cmex
-                     $s
+                   (math $ecrm $cmr $cmmi cmbrsy cmbram cmbrbm stmary wasy line
+                     cmbrsy rsfs eufb bbmbx msbm grxn cmbx cmmib cmbsy cmex $s
                      $d))
                   ((math-var $ecrm $cmr $cmmi $s $d)
-                   (var-math $ecrm
-                     $cmr
-                     $cmmi
-                     cmsy
-                     msam
-                     msbm
-                     stmary
-                     wasy
-                     line
-                     cmsy
-                     rsfs
-                     eufm
-                     bbm
-                     bbold
-                     grmn
-                     cmbx
-                     cmmib
-                     cmbsy
-                     cmex
-                     $s
-                     $d))
+                   (var-math $ecrm $cmr $cmmi cmsy msam msbm stmary wasy line
+                     cmsy rsfs eufm bbm bbold grmn cmbx cmmib cmbsy cmex $s $d))
                   ((bold-math-var $ecrm $cmr $cmmi $s $d)
-                   (var-math $ecrm
-                     $cmr
-                     $cmmi
-                     cmbsy
-                     msam
-                     msbm
-                     stmary
-                     wasyb
-                     linew
-                     cmsy
-                     rsfs
-                     eufm
-                     bbmbx
-                     bbold
-                     grxn
-                     cmbx
-                     cmmib
-                     cmbsy
-                     cmexb
-                     $s
+                   (var-math $ecrm $cmr $cmmi cmbsy msam msbm stmary wasyb linew
+                     cmsy rsfs eufm bbmbx bbold grxn cmbx cmmib cmbsy cmexb $s
                      $d))
                   ((math-conc-var $ecrm $cmr $cmmi $s $d)
-                   (var-math $ecrm
-                     $cmr
-                     $cmmi
-                     xccsy
-                     xccam
-                     xccbm
-                     stmary
-                     wasy
-                     line
-                     cmsy
-                     rsfs
-                     eufm
-                     bbm
-                     bbold
-                     grmn
-                     cmbx
-                     cmmib
-                     cmbsy
-                     xccex
-                     $s
-                     $d))
+                   (var-math $ecrm $cmr $cmmi xccsy xccam xccbm stmary wasy line
+                     cmsy rsfs eufm bbm bbold grmn cmbx cmmib cmbsy xccex $s $d))
                   ((math-bright-var $ecrm $cmr $cmmi $s $d)
-                   (var-math $ecrm
-                     $cmr
-                     $cmmi
-                     cmbrsy
-                     cmbram
-                     cmbrbm
-                     stmary
-                     wasy
-                     line
-                     cmbrsy
-                     rsfs
-                     eufm
-                     bbm
-                     bbold
-                     grmn
-                     cmbx
-                     cmmib
-                     cmbsy
-                     cmex
-                     $s
-                     $d))
+                   (var-math $ecrm $cmr $cmmi cmbrsy cmbram cmbrbm stmary wasy
+                     line cmbrsy rsfs eufm bbm bbold grmn cmbx cmmib cmbsy cmex
+                     $s $d))
                   ((math-alt $ecrm $ecti $cmr $cmmi $s $d)
-                   (alt-math $ecrm
-                     $ecti
-                     $cmr
-                     $cmmi
-                     cmsy
-                     msam
-                     msbm
-                     stmary
-                     wasy
-                     line
-                     cmsy
-                     rsfs
-                     eufm
-                     bbm
-                     bbold
-                     grmn
-                     cmbx
-                     cmmib
-                     cmbsy
-                     cmex
-                     $s
+                   (alt-math $ecrm $ecti $cmr $cmmi cmsy msam msbm stmary wasy
+                     line cmsy rsfs eufm bbm bbold grmn cmbx cmmib cmbsy cmex $s
                      $d))
                   ((bold-math-alt $ecrm $ecti $cmr $cmmi $s $d)
-                   (alt-math $ecrm
-                     $ecti
-                     $cmr
-                     $cmmi
-                     cmbsy
-                     msam
-                     msbm
-                     stmary
-                     wasyb
-                     linew
-                     cmbsy
-                     rsfs
-                     eufb
-                     bbmbx
-                     bbold
-                     grxn
-                     cmbx
-                     cmmib
-                     cmbsy
-                     cmexb
-                     $s
-                     $d))
+                   (alt-math $ecrm $ecti $cmr $cmmi cmbsy msam msbm stmary wasyb
+                     linew cmbsy rsfs eufb bbmbx bbold grxn cmbx cmmib cmbsy
+                     cmexb $s $d))
                   ((math-conc-alt $ecrm $ecti $cmr $cmmi $s $d)
-                   (alt-math $ecrm
-                     $ecti
-                     $cmr
-                     $cmmi
-                     xccsy
-                     xccam
-                     xccbm
-                     stmary
-                     wasy
-                     line
-                     cmsy
-                     rsfs
-                     eufm
-                     bbm
-                     bbold
-                     grmn
-                     cmbx
-                     cmmib
-                     cmbsy
-                     xccex
-                     $s
-                     $d))
+                   (alt-math $ecrm $ecti $cmr $cmmi xccsy xccam xccbm stmary
+                     wasy line cmsy rsfs eufm bbm bbold grmn cmbx cmmib cmbsy
+                     xccex $s $d))
                   ((math-bright-alt $ecrm $ecti $cmr $cmmi $s $d)
-                   (alt-math $ecrm
-                     $ecti
-                     $cmr
-                     $cmmi
-                     cmbrsy
-                     cmbram
-                     cmbrbm
-                     stmary
-                     wasy
-                     line
-                     cmbrsy
-                     rsfs
-                     eufb
-                     bbmbx
-                     bbold
-                     grxn
-                     cmbx
-                     cmmib
-                     cmbsy
-                     cmex
-                     $s
-                     $d))
+                   (alt-math $ecrm $ecti $cmr $cmmi cmbrsy cmbram cmbrbm stmary
+                     wasy line cmbrsy rsfs eufb bbmbx bbold grxn cmbx cmmib
+                     cmbsy cmex $s $d))
                   ((roman mr medium right $s $d) (math-var ecrm cmr cmmi $s $d))
                   ((roman mr bold right $s $d)
                    (bold-math-var ecbx cmbx cmmib $s $d))
@@ -595,28 +242,9 @@
 ;; Mathematical fonts with special capital letters
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(set-font-rules '(((capital-math $name
-                     $ecrm
-                     $cmr
-                     $cmmi
-                     $cmsy
-                     $msam
-                     $msbm
-                     $stmary
-                     $wasy
-                     $line
-                     $cal
-                     $calstar
-                     $frak
-                     $bbb
-                     $bbbcap
-                     $upgreek
-                     $bold1
-                     $bold2
-                     $boldcal
-                     $cmex
-                     $s
-                     $d)
+(set-font-rules '(((capital-math $name $ecrm $cmr $cmmi $cmsy $msam $msbm
+                     $stmary $wasy $line $cal $calstar $frak $bbb $bbbcap
+                     $upgreek $bold1 $bold2 $boldcal $cmex $s $d)
                    (math (capital-math (tex $cmr $s $d)
                            (tex $cmmi $s $d)
                            (tex $name $s $d)
@@ -646,51 +274,13 @@
                      (ec $ecrm $s $d)
                      (ec ecrm $s $d)))
                   ((math-capital $name $s $d)
-                   (capital-math $name
-                     ecrm
-                     cmr
-                     cmmi
-                     cmsy
-                     msam
-                     msbm
-                     stmary
-                     wasy
-                     line
-                     cmsy
-                     rsfs
-                     eufm
-                     bbm
-                     bbold
-                     grmn
-                     cmbx
-                     cmmib
-                     cmbsy
-                     cmex
-                     $s
+                   (capital-math $name ecrm cmr cmmi cmsy msam msbm stmary wasy
+                     line cmsy rsfs eufm bbm bbold grmn cmbx cmmib cmbsy cmex $s
                      $d))
                   ((bold-math-capital $name $s $d)
-                   (capital-math $name
-                     ecbx
-                     cmbx
-                     cmmib
-                     cmbsy
-                     msam
-                     msbm
-                     stmary
-                     wasyb
-                     linew
-                     cmbsy
-                     rsfs
-                     eufb
-                     bbmbx
-                     bbold
-                     grxn
-                     cmbx
-                     cmmib
-                     cmbsy
-                     cmexb
-                     $s
-                     $d))
+                   (capital-math $name ecbx cmbx cmmib cmbsy msam msbm stmary
+                     wasyb linew cmbsy rsfs eufb bbmbx bbold grxn cmbx cmmib
+                     cmbsy cmexb $s $d))
                   ((cal mr medium $a $s $d) (math-capital cmsy $s $d))
                   ((cal mr bold $a $s $d) (bold-math-capital cmbsy $s $d))
                   ((cal* mr medium $a $s $d) (math-capital rsfs $s $d))
@@ -702,28 +292,9 @@
 ;; Mathematical fonts with special alpha-numerical letters
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(set-font-rules '(((alphanum-math $name
-                     $ecrm
-                     $cmr
-                     $cmmi
-                     $cmsy
-                     $msam
-                     $msbm
-                     $stmary
-                     $wasy
-                     $line
-                     $cal
-                     $calstar
-                     $frak
-                     $bbb
-                     $bbbcap
-                     $upgreek
-                     $bold1
-                     $bold2
-                     $boldcal
-                     $cmex
-                     $s
-                     $d)
+(set-font-rules '(((alphanum-math $name $ecrm $cmr $cmmi $cmsy $msam $msbm
+                     $stmary $wasy $line $cal $calstar $frak $bbb $bbbcap
+                     $upgreek $bold1 $bold2 $boldcal $cmex $s $d)
                    (math (alphanum-math (tex $cmr $s $d)
                            (tex $cmmi $s $d)
                            (tex $name $s $d)
@@ -753,51 +324,13 @@
                      (ec $ecrm $s $d)
                      (ec ecrm $s $d)))
                   ((math-alphanum $name $s $d)
-                   (alphanum-math $name
-                     ecrm
-                     cmr
-                     cmmi
-                     cmsy
-                     msam
-                     msbm
-                     stmary
-                     wasy
-                     line
-                     cmsy
-                     rsfs
-                     eufm
-                     bbm
-                     bbold
-                     grmn
-                     cmbx
-                     cmmib
-                     cmbsy
-                     cmex
-                     $s
+                   (alphanum-math $name ecrm cmr cmmi cmsy msam msbm stmary wasy
+                     line cmsy rsfs eufm bbm bbold grmn cmbx cmmib cmbsy cmex $s
                      $d))
                   ((bold-math-alphanum $name $s $d)
-                   (alphanum-math $name
-                     ecbx
-                     cmbx
-                     cmmib
-                     cmbsy
-                     msam
-                     msbm
-                     stmary
-                     wasyb
-                     linew
-                     cmbsy
-                     rsfs
-                     eufb
-                     bbmbx
-                     bbold
-                     grxn
-                     cmbx
-                     cmmib
-                     cmbsy
-                     cmexb
-                     $s
-                     $d))
+                   (alphanum-math $name ecbx cmbx cmmib cmbsy msam msbm stmary
+                     wasyb linew cmbsy rsfs eufb bbmbx bbold grxn cmbx cmmib
+                     cmbsy cmexb $s $d))
                   ((Duerer mr medium slanted $s $d) (math-alphanum cdsl $s $d))
                   ((Duerer mr medium italic $s $d) (math-alphanum cdi $s $d))
                   ((Duerer mr medium $a $s $d) (math-alphanum cdr $s $d))
@@ -824,28 +357,9 @@
 ;; Support for the Euler New Roman fonts
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(set-font-rules '(((enr-math $name
-                     $ecrm
-                     $cmr
-                     $cmmi
-                     $cmsy
-                     $msam
-                     $msbm
-                     $stmary
-                     $wasy
-                     $line
-                     $cal
-                     $calstar
-                     $frak
-                     $bbb
-                     $bbbcap
-                     $upgreek
-                     $bold1
-                     $bold2
-                     $boldcal
-                     $cmex
-                     $s
-                     $d)
+(set-font-rules '(((enr-math $name $ecrm $cmr $cmmi $cmsy $msam $msbm $stmary
+                     $wasy $line $cal $calstar $frak $bbb $bbbcap $upgreek
+                     $bold1 $bold2 $boldcal $cmex $s $d)
                    (math (enr-math (tex $cmr $s $d)
                            (tex $cmmi $s $d)
                            (tex $name $s $d)
@@ -875,51 +389,12 @@
                      (ec $ecrm $s $d)
                      (ec ecrm $s $d)))
                   ((math-enr $name $s $d)
-                   (enr-math $name
-                     ecrm
-                     cmr
-                     cmmi
-                     cmsy
-                     msam
-                     msbm
-                     stmary
-                     wasy
-                     line
-                     cmsy
-                     rsfs
-                     eufm
-                     bbm
-                     bbold
-                     grmn
-                     eurb
-                     eurb
-                     cmbsy
-                     cmex
-                     $s
-                     $d))
+                   (enr-math $name ecrm cmr cmmi cmsy msam msbm stmary wasy line
+                     cmsy rsfs eufm bbm bbold grmn eurb eurb cmbsy cmex $s $d))
                   ((bold-math-enr $name $s $d)
-                   (enr-math $name
-                     ecbx
-                     cmbx
-                     cmmib
-                     cmbsy
-                     msam
-                     msbm
-                     stmary
-                     wasyb
-                     linew
-                     cmbsy
-                     rsfs
-                     eufb
-                     bbmbx
-                     bbold
-                     grxn
-                     eurb
-                     eurb
-                     cmbsy
-                     cmexb
-                     $s
-                     $d))
+                   (enr-math $name ecbx cmbx cmmib cmbsy msam msbm stmary wasyb
+                     linew cmbsy rsfs eufb bbmbx bbold grxn eurb eurb cmbsy
+                     cmexb $s $d))
                   ((ENR mr medium $a $s $d) (math-enr eurm $s $d))
                   ((ENR mr bold $a $s $d) (math-enr eurb $s $d)))
 ) ;set-font-rules
@@ -939,305 +414,115 @@
                   ;; 		  texgyrebonum-bold texgyrebonum-bold
                   ;; 		  $t $a $b $s $d))
                   ((math-bonum $t $a right $s $d)
-                   (unicode-math texgyrebonum-math
-                     texgyrebonum-math
-                     texgyrebonum-bold
-                     texgyrebonum-bold
-                     $t
-                     $a
-                     $b
-                     $s
-                     $d))
+                   (unicode-math texgyrebonum-math texgyrebonum-math
+                     texgyrebonum-bold texgyrebonum-bold $t $a $b $s $d))
                   ;; ((math-bonum $t bold $b $s $d)
                   ;; (unicode-math texgyrebonum-bold texgyrebonum-bolditalic
                   ;; 		  texgyrebonum-bold texgyrebonum-bolditalic
                   ;; 		  $t $a $b $s $d))
                   ((math-bonum $t $a $b $s $d)
-                   (unicode-math texgyrebonum-math
-                     texgyrebonum-italic
-                     texgyrebonum-bold
-                     texgyrebonum-bolditalic
-                     $t
-                     $a
-                     $b
-                     $s
-                     $d))
+                   (unicode-math texgyrebonum-math texgyrebonum-italic
+                     texgyrebonum-bold texgyrebonum-bolditalic $t $a $b $s $d))
                   ;; ((math-pagella $t bold right $s $d)
                   ;; (unicode-math texgyrepagella-bold texgyrepagella-bold
                   ;; 		  texgyrepagella-bold texgyrepagella-bold
                   ;; 		  $t $a $b $s $d))
                   ((math-pagella $t $a right $s $d)
-                   (unicode-math texgyrepagella-math
-                     texgyrepagella-math
-                     texgyrepagella-bold
-                     texgyrepagella-bold
-                     $t
-                     $a
-                     $b
-                     $s
-                     $d))
+                   (unicode-math texgyrepagella-math texgyrepagella-math
+                     texgyrepagella-bold texgyrepagella-bold $t $a $b $s $d))
                   ;; ((math-pagella $t bold $b $s $d)
                   ;; (unicode-math texgyrepagella-bold texgyrepagella-bolditalic
                   ;; 		  texgyrepagella-bold texgyrepagella-bolditalic
                   ;; 		  $t $a $b $s $d))
                   ((math-pagella $t $a $b $s $d)
-                   (unicode-math texgyrepagella-math
-                     texgyrepagella-italic
-                     texgyrepagella-bold
-                     texgyrepagella-bolditalic
-                     $t
-                     $a
-                     $b
-                     $s
+                   (unicode-math texgyrepagella-math texgyrepagella-italic
+                     texgyrepagella-bold texgyrepagella-bolditalic $t $a $b $s
                      $d))
                   ;; ((math-schola $t bold right $s $d)
                   ;; (unicode-math texgyreschola-bold texgyreschola-bold
                   ;; 		  texgyreschola-bold texgyreschola-bold
                   ;; 		  $t $a $b $s $d))
                   ((math-schola $t $a right $s $d)
-                   (unicode-math texgyreschola-math
-                     texgyreschola-math
-                     texgyreschola-bold
-                     texgyreschola-bold
-                     $t
-                     $a
-                     $b
-                     $s
-                     $d))
+                   (unicode-math texgyreschola-math texgyreschola-math
+                     texgyreschola-bold texgyreschola-bold $t $a $b $s $d))
                   ;; ((math-schola $t bold $b $s $d)
                   ;; (unicode-math texgyreschola-bold texgyreschola-bolditalic
                   ;; 		  texgyreschola-bold texgyreschola-bolditalic
                   ;; 		  $t $a $b $s $d))
                   ((math-schola $t $a $b $s $d)
-                   (unicode-math texgyreschola-math
-                     texgyreschola-italic
-                     texgyreschola-bold
-                     texgyreschola-bolditalic
-                     $t
-                     $a
-                     $b
-                     $s
-                     $d))
+                   (unicode-math texgyreschola-math texgyreschola-italic
+                     texgyreschola-bold texgyreschola-bolditalic $t $a $b $s $d))
                   ;; ((math-termes $t bold right $s $d)
                   ;; (unicode-math texgyretermes-bold texgyretermes-bold
                   ;; 		  texgyretermes-bold texgyretermes-bold
                   ;; 		  $t $a $b $s $d))
                   ((math-termes $t $a right $s $d)
-                   (unicode-math texgyretermes-math
-                     texgyretermes-math
-                     texgyretermes-bold
-                     texgyretermes-bold
-                     $t
-                     $a
-                     $b
-                     $s
-                     $d))
+                   (unicode-math texgyretermes-math texgyretermes-math
+                     texgyretermes-bold texgyretermes-bold $t $a $b $s $d))
                   ;; ((math-termes $t bold $b $s $d)
                   ;; (unicode-math texgyretermes-bold texgyretermes-bolditalic
                   ;; 		  texgyretermes-bold texgyretermes-bolditalic
                   ;; 		  $t $a $b $s $d))
                   ((math-termes $t $a $b $s $d)
-                   (unicode-math texgyretermes-math
-                     texgyretermes-italic
-                     texgyretermes-bold
-                     texgyretermes-bolditalic
-                     $t
-                     $a
-                     $b
-                     $s
-                     $d))
+                   (unicode-math texgyretermes-math texgyretermes-italic
+                     texgyretermes-bold texgyretermes-bolditalic $t $a $b $s $d))
                   ((math-stix $t bold right $s $d)
-                   (unicode-math STIX-Bold
-                     STIX-Bold
-                     STIX-Bold
-                     STIX-Bold
-                     $t
-                     bold
-                     $b
-                     $s
-                     $d))
+                   (unicode-math STIX-Bold STIX-Bold STIX-Bold STIX-Bold $t bold
+                     $b $s $d))
                   ((math-stix $t $a right $s $d)
-                   (unicode-math STIX-Regular
-                     STIX-Regular
-                     STIX-Bold
-                     STIX-Bold
-                     $t
-                     $a
-                     $b
-                     $s
-                     $d))
+                   (unicode-math STIX-Regular STIX-Regular STIX-Bold STIX-Bold
+                     $t $a $b $s $d))
                   ((math-stix $t bold $b $s $d)
-                   (unicode-math STIX-Bold
-                     STIX-BoldItalic
-                     STIX-Bold
-                     STIX-BoldItalic
-                     $t
-                     bold
-                     $b
-                     $s
-                     $d))
+                   (unicode-math STIX-Bold STIX-BoldItalic STIX-Bold
+                     STIX-BoldItalic $t bold $b $s $d))
                   ((math-stix $t $a $b $s $d)
-                   (unicode-math STIX-Regular
-                     STIX-Italic
-                     STIX-Bold
-                     STIX-BoldItalic
-                     $t
-                     $a
-                     $b
-                     $s
-                     $d))
+                   (unicode-math STIX-Regular STIX-Italic STIX-Bold
+                     STIX-BoldItalic $t $a $b $s $d))
                   ((math-asana $t $a $b $s $d)
-                   (unicode-math Asana-Math
-                     Asana-Math
-                     Asana-Math
-                     Asana-Math
-                     $t
-                     $a
-                     $b
-                     $s
-                     $d))
+                   (unicode-math Asana-Math Asana-Math Asana-Math Asana-Math $t
+                     $a $b $s $d))
                   ((math-lucida $t $a $b $s $d)
-                   (unicode-math LucidaGrande
-                     LucidaGrande
-                     LucidaGrande
-                     LucidaGrande
-                     $t
-                     $a
-                     $b
-                     $s
-                     $d))
+                   (unicode-math LucidaGrande LucidaGrande LucidaGrande
+                     LucidaGrande $t $a $b $s $d))
                   ((math-apple $t $a $b $s $d)
-                   (unicode-math #{Apple
-                     Symbols}#
-                     #{Apple
-                     Symbols}#
-                     #{Apple
-                     Symbols}#
-                     #{Apple
-                     Symbols}#
-                     $t
-                     $a
-                     $b
-                     $s
-                     $d))
+                   (unicode-math #{Apple Symbols}# #{Apple Symbols}# #{Apple
+                     Symbols}# #{Apple Symbols}# $t $a $b $s $d))
                   ((math-dejavu ms bold right $s $d)
-                   (unicode-math DejaVuSans-Bold
-                     DejaVuSans-Bold
-                     DejaVuSans-Bold
-                     DejaVuSans-Bold
-                     ms
-                     bold
-                     $b
-                     $s
-                     $d))
+                   (unicode-math DejaVuSans-Bold DejaVuSans-Bold DejaVuSans-Bold
+                     DejaVuSans-Bold ms bold $b $s $d))
                   ((math-dejavu ms $a right $s $d)
-                   (unicode-math DejaVuSans
-                     DejaVuSans
-                     DejaVuSans-Bold
-                     DejaVuSans-Bold
-                     ms
-                     $a
-                     $b
-                     $s
-                     $d))
+                   (unicode-math DejaVuSans DejaVuSans DejaVuSans-Bold
+                     DejaVuSans-Bold ms $a $b $s $d))
                   ((math-dejavu ms bold $b $s $d)
-                   (unicode-math DejaVuSans-Bold
-                     DejaVuSans-BoldOblique
-                     DejaVuSans-Bold
-                     DejaVuSans-BoldOblique
-                     ms
-                     bold
-                     $b
-                     $s
-                     $d))
+                   (unicode-math DejaVuSans-Bold DejaVuSans-BoldOblique
+                     DejaVuSans-Bold DejaVuSans-BoldOblique ms bold $b $s $d))
                   ((math-dejavu ms $a $b $s $d)
-                   (unicode-math DejaVuSans
-                     DejaVuSans-Oblique
-                     DejaVuSans-Bold
-                     DejaVuSans-BoldOblique
-                     ms
-                     $a
-                     $b
-                     $s
-                     $d))
+                   (unicode-math DejaVuSans DejaVuSans-Oblique DejaVuSans-Bold
+                     DejaVuSans-BoldOblique ms $a $b $s $d))
                   ((math-dejavu mt bold right $s $d)
-                   (unicode-math DejaVuSansMono-Bold
-                     DejaVuSansMono-Bold
-                     DejaVuSansMono-Bold
-                     DejaVuSansMono-Bold
-                     mt
-                     bold
-                     $b
-                     $s
-                     $d))
+                   (unicode-math DejaVuSansMono-Bold DejaVuSansMono-Bold
+                     DejaVuSansMono-Bold DejaVuSansMono-Bold mt bold $b $s $d))
                   ((math-dejavu mt $a right $s $d)
-                   (unicode-math DejaVuSansMono
-                     DejaVuSansMono
-                     DejaVuSansMono-Bold
-                     DejaVuSansMono-Bold
-                     mt
-                     $a
-                     $b
-                     $s
-                     $d))
+                   (unicode-math DejaVuSansMono DejaVuSansMono
+                     DejaVuSansMono-Bold DejaVuSansMono-Bold mt $a $b $s $d))
                   ((math-dejavu mt bold $b $s $d)
-                   (unicode-math DejaVuSansMono-Bold
-                     DejaVuSansMono-BoldOblique
-                     DejaVuSansMono-Bold
-                     DejaVuSansMono-BoldOblique
-                     mt
-                     bold
-                     $b
-                     $s
-                     $d))
+                   (unicode-math DejaVuSansMono-Bold DejaVuSansMono-BoldOblique
+                     DejaVuSansMono-Bold DejaVuSansMono-BoldOblique mt bold $b
+                     $s $d))
                   ((math-dejavu mt $a $b $s $d)
-                   (unicode-math DejaVuSansMono
-                     DejaVuSansMono-Oblique
-                     DejaVuSansMono-Bold
-                     DejaVuSansMono-BoldOblique
-                     mt
-                     $a
-                     $b
-                     $s
+                   (unicode-math DejaVuSansMono DejaVuSansMono-Oblique
+                     DejaVuSansMono-Bold DejaVuSansMono-BoldOblique mt $a $b $s
                      $d))
                   ((math-dejavu $t bold right $s $d)
-                   (unicode-math DejaVuSerif-Bold
-                     DejaVuSerif-Bold
-                     DejaVuSerif-Bold
-                     DejaVuSerif-Bold
-                     $t
-                     bold
-                     $b
-                     $s
-                     $d))
+                   (unicode-math DejaVuSerif-Bold DejaVuSerif-Bold
+                     DejaVuSerif-Bold DejaVuSerif-Bold $t bold $b $s $d))
                   ((math-dejavu $t $a right $s $d)
-                   (unicode-math DejaVuSerif
-                     DejaVuSerif
-                     DejaVuSerif-Bold
-                     DejaVuSerif-Bold
-                     $t
-                     $a
-                     $b
-                     $s
-                     $d))
+                   (unicode-math DejaVuSerif DejaVuSerif DejaVuSerif-Bold
+                     DejaVuSerif-Bold $t $a $b $s $d))
                   ((math-dejavu $t bold $b $s $d)
-                   (unicode-math DejaVuSerif-Bold
-                     DejaVuSerif-BoldItalic
-                     DejaVuSerif-Bold
-                     DejaVuSerif-BoldItalic
-                     $t
-                     bold
-                     $b
-                     $s
-                     $d))
+                   (unicode-math DejaVuSerif-Bold DejaVuSerif-BoldItalic
+                     DejaVuSerif-Bold DejaVuSerif-BoldItalic $t bold $b $s $d))
                   ((math-dejavu $t $a $b $s $d)
-                   (unicode-math DejaVuSerif
-                     DejaVuSerif-Italic
-                     DejaVuSerif-Bold
-                     DejaVuSerif-BoldItalic
-                     $t
-                     $a
-                     $b
-                     $s
-                     $d)))
+                   (unicode-math DejaVuSerif DejaVuSerif-Italic DejaVuSerif-Bold
+                     DejaVuSerif-BoldItalic $t $a $b $s $d)))
 ) ;set-font-rules
diff --git a/TeXmacs/progs/generic/diff-text.scm b/TeXmacs/progs/generic/diff-text.scm
index 9063a16577..dfb20d42ed 100644
--- a/TeXmacs/progs/generic/diff-text.scm
+++ b/TeXmacs/progs/generic/diff-text.scm
@@ -18,66 +18,17 @@
 ;; Helper functions
 ;; =============================================================================
 
-(define (remove-random-thes words count)
-  (cond ((null? words) '())
-        ((<= count 0) words)
-        ((== (car words) "the")
-         (cond ((<= (random 3) 1) (remove-random-thes (cdr words) (- count 1)))
-               (else (cons (car words) (remove-random-thes (cdr words) count)))
-         ) ;cond
-        ) ;
-        (else (cons (car words) (remove-random-thes (cdr words) count)))
-  ) ;cond
-) ;define
-
-(define (insert-random-as words count)
-  (cond ((null? words)
-         (if (> count 0) (cons "a" (insert-random-as '() (- count 1))) '())
-        ) ;
-        ((<= count 0) words)
-        (else (if (== (random 5) 0)
-                (cons "a" (insert-random-as words (- count 1)))
-                (cons (car words) (insert-random-as (cdr words) count))
-              ) ;if
-        ) ;else
-  ) ;cond
-) ;define
-
-(define (upcase-random-words words count)
-  (cond ((or (null? words) (<= count 0)) words)
-        ((> (string-length (car words)) 1)
-         (if (== (random 4) 0)
-           (cons (upcase-all (car words)) (upcase-random-words (cdr words) (- count 1)))
-           (cons (car words) (upcase-random-words (cdr words) count))
-         ) ;if
-        ) ;
-        (else (cons (car words) (upcase-random-words (cdr words) count)))
-  ) ;cond
-) ;define
-
-(define (demo-suggest t)
-  (cond ((not t) #f)
-        ((string? t)
-         (let* ((words (string-split t #\space))
-                (words-no-the (remove-random-thes words 2))
-                (words-with-a (insert-random-as words-no-the 2))
-                (final-words (upcase-random-words words-with-a 3))
-               ) ;
-           (string-recompose final-words " ")
-         ) ;let*
-        ) ;
-        ((pair? t) (cons (car t) (map demo-suggest (cdr t))))
-        (else t)
-  ) ;cond
-) ;define
-
 (define (diff-check-popup)
-  ;; 先隐藏弹窗，避免位置错乱
+  ;; 先隐藏弹窗，避免位置错乱；弹窗函数由插件提供，社区版未定义时仅跟踪不显示
   (set! diff-active? #f)
-  (hide-diff-popup)
+  (when (defined? 'hide-diff-popup)
+    (hide-diff-popup)
+  ) ;when
   (when (tree-innermost 'version-both)
     (set! diff-active? #t)
-    (show-diff-popup)
+    (when (defined? 'show-diff-popup)
+      (show-diff-popup)
+    ) ;when
   ) ;when
 ) ;define
 
@@ -97,47 +48,107 @@
 ;; State variables for Diff Text
 ;; =============================================================================
 
+(define diff-serial 0)
+
 (define diff-active? #f)
 
 (tm-define (is-diff-active?) diff-active?)
 
-(tm-define (diff-enable?) (not (community-stem?)))
+(tm-define (diff-enable?) (defined? 'diff-cloud-polish))
+
+;; 树锚点（tree pin）：触发时把选区两端点所在的树节点钉住，
+;; 树引用随编辑自动追踪，选区取消/光标移动后仍能找回原区域
+
+(define (diff-pin->path pin offset)
+  ;; 锚点节点存活则重建「当前路径 + 原偏移」，节点被删（区域已移除）返回 #f
+  (let ((p (tree->path pin)))
+    (if (pair? p) (append p (list offset)) #f)
+  ) ;let
+) ;define
 
 ;; =============================================================================
 ;; Diff Text core control flow
 ;; =============================================================================
 
 (tm-define (trigger-diff-text)
-  (let* ((sel (selection-tree))
-         (origin_stree (tree->stree sel))
-         (suggested_stree (demo-suggest origin_stree))
-         (pre-cur (cursor-path))
-         (pre-grain (get-preference "versioning grain"))
-        ) ;
-    ;; 设为字符级精度 "detailed"；其余选项："block" (块级)、"rough" (粗粒度)
-    (set-preference "versioning grain" "detailed")
-    (let* ((diff-stree (compare-versions origin_stree suggested_stree))
-           (diff-tree (stree->tree diff-stree))
+  (when (diff-enable?)
+    (set! diff-serial (+ diff-serial 1))
+    (let* ((current diff-serial)
+           (sel (selection-tree))
+           (origin-stree (tree->stree sel))
+           (p1 (selection-get-start))
+           (p2 (selection-get-end))
+           (pin1 (path->tree (cDr p1)))
+           (pin2 (path->tree (cDr p2)))
+           (off1 (cAr p1))
+           (off2 (cAr p2))
+           (stree-str (object->string origin-stree))
           ) ;
-      (clipboard-cut "primary")
-      (insert diff-tree)
-      (go-to pre-cur)
-      (diff-scan-next)
+      (debug-message "debug-io"
+        (string-append "diff-request: stree=[" (herk->utf8 stree-str) "]\n")
+      ) ;debug-message
+      (diff-cloud-polish stree-str
+        (lambda (suggested-str)
+          (diff-apply-suggestion current origin-stree suggested-str pin1 off1 pin2 off2)
+        ) ;lambda
+      ) ;diff-cloud-polish
     ) ;let*
-    ;; 还原精度
-    (set-preference "versioning grain" pre-grain)
-  ) ;let*
+  ) ;when
 ) ;tm-define
 
+(define (diff-apply-suggestion current origin-stree suggested-str pin1 off1 pin2 off2)
+  (let ((new-p1 (diff-pin->path pin1 off1)) (new-p2 (diff-pin->path pin2 off2)))
+    (when (and (== current diff-serial)
+            (string? suggested-str)
+            (not (string=? suggested-str ""))
+          ) ;and
+      (if (and new-p1 new-p2)
+        (begin
+          (debug-message "debug-io"
+            (string-append "diff-predict: suggested=[" (herk->utf8 suggested-str) "]\n")
+          ) ;debug-message
+          (let ((suggested-stree (catch #t (lambda () (string->object suggested-str)) (lambda args #f))
+                ) ;suggested-stree
+               ) ;
+            (when suggested-stree
+              (let ((pre-grain (get-preference "versioning grain")))
+                ;; 设为字符级精度 "detailed"；其余选项："block" (块级)、"rough" (粗粒度)
+                (set-preference "versioning grain" "detailed")
+                (let* ((diff-stree (compare-versions origin-stree suggested-stree))
+                       (diff-tree (stree->tree diff-stree))
+                      ) ;
+                  ;; 经树锚点重建选区，与当前活跃选区无关
+                  (selection-set new-p1 new-p2)
+                  (clipboard-cut "primary")
+                  (insert diff-tree)
+                  (go-to new-p1)
+                  (diff-scan-next)
+                ) ;let*
+                ;; 还原精度
+                (set-preference "versioning grain" pre-grain)
+              ) ;let
+            ) ;when
+          ) ;let
+        ) ;begin
+        (debug-message "debug-io" "diff-predict: dropped (region deleted)\n")
+      ) ;if
+    ) ;when
+  ) ;let
+) ;define
+
 (tm-define (accept-diff)
   (let ((t (tree-innermost 'version-both)))
     (when t
-      (let* ((new-val (tree-ref t 1)) (p (tree-up t)) (i (tree-index t)))
-        (tree-remove! p i 1)
-        (when (not (tree-is? new-val 'version-suppressed))
-          (insert new-val)
-        ) ;when
-      ) ;let*
+      (let ((new-val (tree-ref t 1)))
+        ;; 用 tree-set! 原位替换，不走「删除 + 光标处 insert」：
+        ;; 父节点是 with 时，光标式 insert 会把文本粘进 with 的参数位
+        (if (tree-is? new-val 'version-suppressed)
+          (let ((p (tree-up t)) (i (tree-index t)))
+            (tree-remove! p i 1)
+          ) ;let
+          (tree-set! t new-val)
+        ) ;if
+      ) ;let
     ) ;when
   ) ;let
   (diff-feedback 'accept)
@@ -148,12 +159,14 @@
 (tm-define (reject-diff)
   (let ((t (tree-innermost 'version-both)))
     (when t
-      (let* ((old-val (tree-ref t 0)) (p (tree-up t)) (i (tree-index t)))
-        (tree-remove! p i 1)
-        (when (not (tree-is? old-val 'version-suppressed))
-          (insert old-val)
-        ) ;when
-      ) ;let*
+      (let ((old-val (tree-ref t 0)))
+        (if (tree-is? old-val 'version-suppressed)
+          (let ((p (tree-up t)) (i (tree-index t)))
+            (tree-remove! p i 1)
+          ) ;let
+          (tree-set! t old-val)
+        ) ;if
+      ) ;let
     ) ;when
   ) ;let
   (diff-feedback 'reject)
@@ -173,19 +186,17 @@
 (tm-define (keyboard-press key time)
   (:require (is-diff-active?))
   (cond ((== key "return") (accept-diff))
-        ((== key "backspace") (reject-diff))
+        ((== key "escape") (reject-diff))
         (else (former key time))
   ) ;cond
 ) ;tm-define
 
 (tm-define (keyboard-press key time)
-  (:require (diff-enable?))
   (former key time)
   (delayed (:idle 0) (diff-check-popup))
 ) ;tm-define
 
 (tm-define (mouse-event key x y mods time data)
-  (:require (diff-enable?))
   (former key x y mods time data)
   (when (not (== key "move"))
     (delayed (:idle 0) (diff-check-popup))
diff --git a/TeXmacs/progs/generic/document-menu.scm b/TeXmacs/progs/generic/document-menu.scm
index a999bc9a8a..fe15d04251 100644
--- a/TeXmacs/progs/generic/document-menu.scm
+++ b/TeXmacs/progs/generic/document-menu.scm
@@ -380,7 +380,7 @@
 ) ;tm-define
 
 (menu-bind document-short-chinese-font-menu
-  (cond ((os-win32?)
+  (cond ((os-windows?)
          (if (font-exists-in-tt? "simhei") ("SimHei" (init-font "simhei")))
          (if (font-exists-in-tt? "simfang") ("SimFang" (init-font "simfang")))
          (if (font-exists-in-tt? "simkai") ("SimKai" (init-font "simkai")))
@@ -771,17 +771,9 @@
   ) ;->
   (-> "Margins"
    ("Default"
-     (init-default "page-width-margin"
-       "page-height-margin"
-       "page-odd"
-       "page-even"
-       "page-right"
-       "par-width"
-       "page-odd-shift"
-       "page-even-shift"
-       "page-top"
-       "page-bot"
-       "page-height-margin"
+     (init-default "page-width-margin" "page-height-margin" "page-odd"
+       "page-even" "page-right" "par-width" "page-odd-shift" "page-even-shift"
+       "page-top" "page-bot" "page-height-margin"
      ) ;init-default
    ) ;
    ---
@@ -809,11 +801,8 @@
   ) ;->
   (-> "Screen margins"
    ("Default"
-     (init-default "page-screen-margin"
-       "page-screen-left"
-       "page-screen-right"
-       "page-screen-top"
-       "page-screen-bot"
+     (init-default "page-screen-margin" "page-screen-left" "page-screen-right"
+       "page-screen-top" "page-screen-bot"
      ) ;init-default
    ) ;
    ("Margins as on paper" (toggle-page-screen-margin))
@@ -936,7 +925,6 @@
  ("Palette" (interactive-background set-background '()))
  ("Pattern" (open-pattern-selector set-background "1cm"))
  ("Gradient" (open-gradient-selector set-background))
- ("Picture" (open-background-picture-selector set-background))
  ("Other" (init-interactive-env "bg-color"))
 ) ;menu-bind
 
diff --git a/TeXmacs/progs/generic/document-widgets.scm b/TeXmacs/progs/generic/document-widgets.scm
index 74c28defa7..00a03ed192 100644
--- a/TeXmacs/progs/generic/document-widgets.scm
+++ b/TeXmacs/progs/generic/document-widgets.scm
@@ -33,16 +33,9 @@
 ) ;tm-widget
 
 (tm-widget (select-common-style-widget)
-  (dynamic (select-style-among-widget (list "article"
-                                        "beamer"
-                                        "book"
-                                        "browser"
-                                        "exam"
-                                        "generic"
-                                        "letter"
-                                        "manual"
-                                        "seminar"
-                                        "source"
+  (dynamic (select-style-among-widget (list "article" "beamer" "book" "browser"
+                                        "exam" "generic" "letter" "manual"
+                                        "seminar" "source"
                                       ) ;list
            ) ;select-style-among-widget
   ) ;dynamic
@@ -488,15 +481,9 @@
   ======
   (explicit-buttons (hlist >>>
                      ("Reset"
-                       (initial-default u
-                         "page-medium"
-                         "page-type"
-                         "page-orientation"
-                         "page-border"
-                         "page-packet"
-                         "page-offset"
-                         "page-width"
-                         "page-height"
+                       (initial-default u "page-medium" "page-type"
+                         "page-orientation" "page-border" "page-packet"
+                         "page-offset" "page-width" "page-height"
                          "page-crop-marks"
                        ) ;initial-default
                        (refresh-now "page-format-settings")
@@ -691,21 +678,11 @@
   ======
   (explicit-buttons (hlist >>>
                      ("Reset"
-                       (initial-default u
-                         "page-odd"
-                         "page-even"
-                         "page-right"
-                         "page-top"
-                         "page-bot"
-                         "par-width"
-                         "page-odd-shift"
-                         "page-even-shift"
-                         "page-screen-left"
-                         "page-screen-right"
-                         "page-screen-top"
-                         "page-screen-bot"
-                         "page-width-margin"
-                         "page-screen-margin"
+                       (initial-default u "page-odd" "page-even" "page-right"
+                         "page-top" "page-bot" "par-width" "page-odd-shift"
+                         "page-even-shift" "page-screen-left"
+                         "page-screen-right" "page-screen-top" "page-screen-bot"
+                         "page-width-margin" "page-screen-margin"
                        ) ;initial-default
                        (refresh-now "page-margin-toggles")
                        (refresh-now "page-margin-settings")
@@ -865,22 +842,12 @@
   ======
   (explicit-buttons (hlist >>>
                      ("Reset"
-                       (initial-default u
-                         "tex-odd-side-margin"
-                         "tex-even-side-margin"
-                         "tex-text-width"
-                         "tex-line-width"
-                         "tex-column-width"
-                         "tex-top-margin"
-                         "tex-head-height"
-                         "tex-head-sep"
-                         "tex-text-height"
-                         "tex-foot-skip"
-                         "page-screen-left"
-                         "page-screen-right"
-                         "page-screen-top"
-                         "page-screen-bot"
-                         "page-width-margin"
+                       (initial-default u "tex-odd-side-margin"
+                         "tex-even-side-margin" "tex-text-width"
+                         "tex-line-width" "tex-column-width" "tex-top-margin"
+                         "tex-head-height" "tex-head-sep" "tex-text-height"
+                         "tex-foot-skip" "page-screen-left" "page-screen-right"
+                         "page-screen-top" "page-screen-bot" "page-width-margin"
                          "page-screen-margin"
                        ) ;initial-default
                        (refresh-now "page-margin-toggles")
@@ -910,9 +877,7 @@
                      ) ;item
               (item (text "Allowed page height reduction:")
                 (enum (initial-set u "page-shrink" answer)
-                  (cons-new (initial-get u "page-shrink") '("0cm"
-                                                            "0.5cm"
-                                                            "1cm"
+                  (cons-new (initial-get u "page-shrink") '("0cm" "0.5cm" "1cm"
                                                             ""))
                   (initial-get u "page-shrink")
                   "10em"
@@ -920,9 +885,7 @@
               ) ;item
               (item (text "Allowed page height extension:")
                 (enum (initial-set u "page-extend" answer)
-                  (cons-new (initial-get u "page-extend") '("0cm"
-                                                            "0.5cm"
-                                                            "1cm"
+                  (cons-new (initial-get u "page-extend") '("0cm" "0.5cm" "1cm"
                                                             ""))
                   (initial-get u "page-extend")
                   "10em"
@@ -930,12 +893,9 @@
               ) ;item
               (item (text "Vertical space stretchability:")
                 (enum (initial-set u "page-flexibility" answer)
-                  (cons-new (initial-get u "page-flexibility") '("0"
-                                                                 "0.25"
-                                                                 "0.5"
-                                                                 "0.75"
-                                                                 "1"
-                                                                 ""))
+                  (cons-new (initial-get u "page-flexibility") '("0" "0.25"
+                                                                 "0.5" "0.75"
+                                                                 "1" ""))
                   (initial-get u "page-flexibility")
                   "10em"
                 ) ;enum
@@ -947,11 +907,8 @@
   ===
   (explicit-buttons (hlist >>>
                      ("Reset"
-                       (initial-default u
-                         "page-breaking"
-                         "page-shrink"
-                         "page-extend"
-                         "page-flexibility"
+                       (initial-default u "page-breaking" "page-shrink"
+                         "page-extend" "page-flexibility"
                        ) ;initial-default
                        (refresh-now "page-breaking-settings")
                      ) ;
diff --git a/TeXmacs/progs/generic/format-drd.scm b/TeXmacs/progs/generic/format-drd.scm
index 737645289e..b197818a12 100644
--- a/TeXmacs/progs/generic/format-drd.scm
+++ b/TeXmacs/progs/generic/format-drd.scm
@@ -65,11 +65,7 @@
 
 (define-group new-page-tag new-page new-page* new-dpage new-dpage*)
 
-(define-group page-break-tag
-  page-break
-  page-break*
-  no-break-here
-  no-break-here*
+(define-group page-break-tag page-break page-break* no-break-here no-break-here*
 ) ;define-group
 
 ;; Various geometry adjustment tags
@@ -84,35 +80,14 @@
 
 (define-group reduce-by-tag reduce-by reduce-bottom-by reduce-top-by)
 
-(define-group font-effect-tag
-  embold
-  embbb
-  slanted
-  hmagnified
-  vmagnified
-  condensed
-  extended
-  degraded
-  distorted
-  gnawed
+(define-group font-effect-tag embold embbb slanted hmagnified vmagnified
+  condensed extended degraded distorted gnawed
 ) ;define-group
 
 (define-group eff-tag eff-blur eff-outline eff-thicken eff-erode)
 
-(define-group basic-effect-tag
-  blur
-  outline
-  thicken
-  erode
-  shadow
-  engrave
-  emboss
-  shadowed-raise
-  outlined-engrave
-  outlined-emboss
-  degrade
-  distort
-  gnaw
+(define-group basic-effect-tag blur outline thicken erode shadow engrave emboss
+  shadowed-raise outlined-engrave outlined-emboss degrade distort gnaw
 ) ;define-group
 
 (define-group color-effect-tag make-transparent make-opaque recolor skin)
@@ -128,25 +103,16 @@
   (motion-effect-tag)
 ) ;define-group
 
-(define-group gaussian-effect-tag
-  gaussian-blur
-  gaussian-outline
-  gaussian-thicken
-  gaussian-erode
+(define-group gaussian-effect-tag gaussian-blur gaussian-outline
+  gaussian-thicken gaussian-erode
 ) ;define-group
 
 (define-group oval-effect-tag oval-blur oval-outline oval-thicken oval-erode)
 
-(define-group rectangular-effect-tag
-  rectangular-blur
-  rectangular-outline
-  rectangular-thicken
-  rectangular-erode
+(define-group rectangular-effect-tag rectangular-blur rectangular-outline
+  rectangular-thicken rectangular-erode
 ) ;define-group
 
-(define-group motion-effect-tag
-  motion-blur
-  motion-outline
-  motion-thicken
+(define-group motion-effect-tag motion-blur motion-outline motion-thicken
   motion-erode
 ) ;define-group
diff --git a/TeXmacs/progs/generic/format-edit.scm b/TeXmacs/progs/generic/format-edit.scm
index a37f1334bc..a78be91372 100644
--- a/TeXmacs/progs/generic/format-edit.scm
+++ b/TeXmacs/progs/generic/format-edit.scm
@@ -760,21 +760,8 @@
 
 (tm-define (parameter-choice-list var)
   (:require (in? var (list "slanted-slope")))
-  (list "-1"
-    "-0.5"
-    "-0.33"
-    "-0.25"
-    "-0.2"
-    "-0.15"
-    "-0.1"
-    "0.1"
-    "0.15"
-    "0.2"
-    "0.25"
-    "0.33"
-    "0.5"
-    "1"
-    :other
+  (list "-1" "-0.5" "-0.33" "-0.25" "-0.2" "-0.15" "-0.1" "0.1" "0.15" "0.2"
+    "0.25" "0.33" "0.5" "1" :other
   ) ;list
 ) ;tm-define
 
@@ -896,8 +883,7 @@
 ) ;tm-define
 
 (tm-define (customizable-parameters t)
-  (:require (tree-in? t '(outline gaussian-outline
-                           oval-outline
+  (:require (tree-in? t '(outline gaussian-outline oval-outline
                            rectangular-outline))
   ) ;:require
   (list (list "outline-pen-width" "Pen width")
@@ -912,8 +898,7 @@
 ) ;tm-define
 
 (tm-define (customizable-parameters t)
-  (:require (tree-in? t '(thicken gaussian-thicken
-                           oval-thicken
+  (:require (tree-in? t '(thicken gaussian-thicken oval-thicken
                            rectangular-thicken))
   ) ;:require
   (list (list "thicken-pen-width" "Pen width")
@@ -945,18 +930,8 @@
               (list "shadow-dx" "shadow-dy" "engrave-dx" "engrave-dy" "emboss-dx" "emboss-dy")
             ) ;in?
   ) ;:require
-  (list "-2.5ln"
-    "-2ln"
-    "-1.5ln"
-    "-1ln"
-    "-0.5ln"
-    "0ln"
-    "0.5ln"
-    "1ln"
-    "1.5ln"
-    "2ln"
-    "2.5ln"
-    :other
+  (list "-2.5ln" "-2ln" "-1.5ln" "-1ln" "-0.5ln" "0ln" "0.5ln" "1ln" "1.5ln"
+    "2ln" "2.5ln" :other
   ) ;list
 ) ;tm-define
 
@@ -1105,10 +1080,7 @@
     (set! t (tree-innermost pen-effect-context?))
   ) ;when
   (cond ((not (tree? t)) (noop))
-        ((tree-in? t '(blur gaussian-blur
-                        oval-blur
-                        rectangular-blur
-                        motion-blur))
+        ((tree-in? t '(blur gaussian-blur oval-blur rectangular-blur motion-blur))
          (cond ((== pen "gaussian") (variant-set t 'gaussian-blur))
                ((== pen "oval") (variant-set t 'oval-blur))
                ((== pen "rectangular") (variant-set t 'rectangular-blur))
@@ -1116,9 +1088,7 @@
          ) ;cond
         ) ;
         ((tree-in? t
-           '(outline gaussian-outline
-              oval-outline
-              rectangular-outline
+           '(outline gaussian-outline oval-outline rectangular-outline
               motion-outline)
          ) ;tree-in?
          (cond ((== pen "gaussian") (variant-set t 'gaussian-outline))
@@ -1128,9 +1098,7 @@
          ) ;cond
         ) ;
         ((tree-in? t
-           '(thicken gaussian-thicken
-              oval-thicken
-              rectangular-thicken
+           '(thicken gaussian-thicken oval-thicken rectangular-thicken
               motion-thicken)
          ) ;tree-in?
          (cond ((== pen "gaussian") (variant-set t 'gaussian-thicken))
@@ -1139,9 +1107,7 @@
                ((== pen "motion") (variant-set t 'motion-thicken))
          ) ;cond
         ) ;
-        ((tree-in? t '(erode gaussian-erode
-                        oval-erode
-                        rectangular-erode
+        ((tree-in? t '(erode gaussian-erode oval-erode rectangular-erode
                         motion-erode))
          (cond ((== pen "gaussian") (variant-set t 'gaussian-erode))
                ((== pen "oval") (variant-set t 'oval-erode))
diff --git a/TeXmacs/progs/generic/format-geometry-edit.scm b/TeXmacs/progs/generic/format-geometry-edit.scm
index 6b94f81816..860d39e873 100644
--- a/TeXmacs/progs/generic/format-geometry-edit.scm
+++ b/TeXmacs/progs/generic/format-geometry-edit.scm
@@ -128,7 +128,7 @@
   (cond ((tm-atomic? t) (tm->string t))
         ((tm-is? t 'plus)
          (with s
-           (string-recompose (map tm->rich-length (tm-children t)) "+")
+           (string-join (map tm->rich-length (tm-children t)) "+")
            (string-replace s "+-" "-")
          ) ;with
         ) ;
@@ -413,12 +413,7 @@
          (r (kbd-find-inv-system-binding '(geometry-right)))
         ) ;
     (if (and l r)
-      (set-message (string-append s
-                     " using "
-                     l
-                     ", "
-                     r
-                     ", etc. or "
+      (set-message (string-append s " using " l ", " r ", etc. or "
                      "via the fields in the focus bar"
                    ) ;string-append
         c
diff --git a/TeXmacs/progs/generic/format-menu.scm b/TeXmacs/progs/generic/format-menu.scm
index b89d1dd023..68b59f345e 100644
--- a/TeXmacs/progs/generic/format-menu.scm
+++ b/TeXmacs/progs/generic/format-menu.scm
@@ -329,15 +329,9 @@
 
 (tm-define (page-numbering-context? t)
   (tree-in? t
-    '(set-this-page-header set-this-page-footer
-       set-header
-       set-footer
-       set-odd-page-header
-       set-even-page-header
-       set-odd-page-footer
-       set-even-page-footer
-       set-page-number
-       set-page-number-macro)
+    '(set-this-page-header set-this-page-footer set-header set-footer
+       set-odd-page-header set-even-page-header set-odd-page-footer
+       set-even-page-footer set-page-number set-page-number-macro)
   ) ;tree-in?
 ) ;tm-define
 
diff --git a/TeXmacs/progs/generic/format-tools.scm b/TeXmacs/progs/generic/format-tools.scm
index 5db9b5c2ac..59d22e9897 100644
--- a/TeXmacs/progs/generic/format-tools.scm
+++ b/TeXmacs/progs/generic/format-tools.scm
@@ -71,20 +71,16 @@
         (item ====== ======)
         (item (text "Left margin:")
           (enum (window-set-env win "par-left" answer mode)
-            (cons-new (window-get-env win "par-left" mode) '("0tab"
-                                                             "1tab"
-                                                             "2tab"
-                                                             ""))
+            (cons-new (window-get-env win "par-left" mode) '("0tab" "1tab"
+                                                             "2tab" ""))
             (window-get-env win "par-left" mode)
             "10em"
           ) ;enum
         ) ;item
         (item (text "Right margin:")
           (enum (window-set-env win "par-right" answer mode)
-            (cons-new (window-get-env win "par-right" mode) '("0tab"
-                                                              "1tab"
-                                                              "2tab"
-                                                              ""))
+            (cons-new (window-get-env win "par-right" mode) '("0tab" "1tab"
+                                                              "2tab" ""))
             (window-get-env win "par-right" mode)
             "10em"
           ) ;enum
@@ -92,10 +88,8 @@
       ) ;assuming
       (item (text "First indentation:")
         (enum (window-set-env win "par-first" answer mode)
-          (cons-new (window-get-env win "par-first" mode) '("0tab"
-                                                            "1tab"
-                                                            "-1tab"
-                                                            ""))
+          (cons-new (window-get-env win "par-first" mode) '("0tab" "1tab"
+                                                            "-1tab" ""))
           (window-get-env win "par-first" mode)
           "10em"
         ) ;enum
@@ -103,11 +97,8 @@
       (item ====== ======)
       (item (text "Interline space:")
         (enum (window-set-env win "par-sep" answer mode)
-          (cons-new (window-get-env win "par-sep" mode) '("0fn"
-                                                          "0.2fn"
-                                                          "0.5fn"
-                                                          "1fn"
-                                                          ""))
+          (cons-new (window-get-env win "par-sep" mode) '("0fn" "0.2fn" "0.5fn"
+                                                          "1fn" ""))
           (window-get-env win "par-sep" mode)
           "10em"
         ) ;enum
@@ -140,8 +131,7 @@
             (enum (window-set-env win "par-columns-sep" answer mode)
               (cons-new (window-get-env win "par-columns-sep" mode) '("1fn"
                                                                       "2fn"
-                                                                      "3fn"
-                                                                      ""))
+                                                                      "3fn" ""))
               (window-get-env win "par-columns-sep" mode)
               "10em"
             ) ;enum
@@ -189,11 +179,8 @@
         (item ====== ======)
         (item (text "Space stretchability:")
           (enum (window-set-env win "par-flexibility" answer mode)
-            (cons-new (window-get-env win "par-flexibility" mode) '("1"
-                                                                    "2"
-                                                                    "4"
-                                                                    "1000"
-                                                                    ""))
+            (cons-new (window-get-env win "par-flexibility" mode) '("1" "2" "4"
+                                                                    "1000" ""))
             (window-get-env win "par-flexibility" mode)
             "10em"
           ) ;enum
@@ -339,11 +326,7 @@
 
 (define (page-rendering-options)
   (if (in-beamer?)
-    '("Single Page"
-      "Continuous Scroll"
-      "Beamer"
-      "Two Page"
-      "Panorama"
+    '("Single Page" "Continuous Scroll" "Beamer" "Two Page" "Panorama"
       "Slideshow")
     '("Single Page" "Continuous Scroll" "Two Page" "Panorama")
   ) ;if
@@ -435,15 +418,8 @@
     (division "discrete"
       (hlist >>
        ("Restore defaults"
-         (window-reset-init win
-           "page-medium"
-           "page-type"
-           "page-orientation"
-           "page-border"
-           "page-packet"
-           "page-offset"
-           "page-width"
-           "page-height"
+         (window-reset-init win "page-medium" "page-type" "page-orientation"
+           "page-border" "page-packet" "page-offset" "page-width" "page-height"
            "page-crop-marks"
          ) ;window-reset-init
        ) ;
@@ -639,21 +615,10 @@
   (division "discrete"
     (hlist >>
      ("Restore defaults"
-       (window-reset-init win
-         "page-odd"
-         "page-even"
-         "page-right"
-         "page-top"
-         "page-bot"
-         "par-width"
-         "page-odd-shift"
-         "page-even-shift"
-         "page-screen-left"
-         "page-screen-right"
-         "page-screen-top"
-         "page-screen-bot"
-         "page-width-margin"
-         "page-screen-margin"
+       (window-reset-init win "page-odd" "page-even" "page-right" "page-top"
+         "page-bot" "par-width" "page-odd-shift" "page-even-shift"
+         "page-screen-left" "page-screen-right" "page-screen-top"
+         "page-screen-bot" "page-width-margin" "page-screen-margin"
        ) ;window-reset-init
        (refresh-now "page-margin-toggles")
        (refresh-now "page-margin-settings")
@@ -799,23 +764,11 @@
   (division "discrete"
     (hlist >>
      ("Restore defaults"
-       (window-reset-init win
-         "tex-odd-side-margin"
-         "tex-even-side-margin"
-         "tex-text-width"
-         "tex-line-width"
-         "tex-column-width"
-         "tex-top-margin"
-         "tex-head-height"
-         "tex-head-sep"
-         "tex-text-height"
-         "tex-foot-skip"
-         "page-screen-left"
-         "page-screen-right"
-         "page-screen-top"
-         "page-screen-bot"
-         "page-width-margin"
-         "page-screen-margin"
+       (window-reset-init win "tex-odd-side-margin" "tex-even-side-margin"
+         "tex-text-width" "tex-line-width" "tex-column-width" "tex-top-margin"
+         "tex-head-height" "tex-head-sep" "tex-text-height" "tex-foot-skip"
+         "page-screen-left" "page-screen-right" "page-screen-top"
+         "page-screen-bot" "page-width-margin" "page-screen-margin"
        ) ;window-reset-init
        (refresh-now "page-margin-toggles")
        (refresh-now "page-tex-hor-margins")
@@ -842,20 +795,14 @@
              ) ;item
       (item (text "Allowed page height reduction:")
         (enum (window-set-init win "page-shrink" answer)
-          (cons-new (window-get-init win "page-shrink") '("0cm"
-                                                          "0.5cm"
-                                                          "1cm"
-                                                          ""))
+          (cons-new (window-get-init win "page-shrink") '("0cm" "0.5cm" "1cm" ""))
           (window-get-init win "page-shrink")
           "10em"
         ) ;enum
       ) ;item
       (item (text "Allowed page height extension:")
         (enum (window-set-init win "page-extend" answer)
-          (cons-new (window-get-init win "page-extend") '("0cm"
-                                                          "0.5cm"
-                                                          "1cm"
-                                                          ""))
+          (cons-new (window-get-init win "page-extend") '("0cm" "0.5cm" "1cm" ""))
           (window-get-init win "page-extend")
           "10em"
         ) ;enum
@@ -874,10 +821,7 @@
     (division "discrete"
       (hlist >>
        ("Restore defaults"
-         (window-reset-init win
-           "page-breaking"
-           "page-shrink"
-           "page-extend"
+         (window-reset-init win "page-breaking" "page-shrink" "page-extend"
            "page-flexibility"
          ) ;window-reset-init
          (refresh-now "page-breaking-settings")
diff --git a/TeXmacs/progs/generic/format-widgets.scm b/TeXmacs/progs/generic/format-widgets.scm
index 863e00f3fe..7df2a60237 100644
--- a/TeXmacs/progs/generic/format-widgets.scm
+++ b/TeXmacs/progs/generic/format-widgets.scm
@@ -81,28 +81,11 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (tm-define paragraph-parameters
-  (list "par-mode"
-    "par-flexibility"
-    "par-hyphen"
-    "par-spacing"
-    "par-kerning-stretch"
-    "par-kerning-reduce"
-    "par-expansion"
-    "par-contraction"
-    "par-kerning-margin"
-    "par-width"
-    "par-left"
-    "par-right"
-    "par-first"
-    "par-no-first"
-    "par-sep"
-    "par-hor-sep"
-    "par-ver-sep"
-    "par-line-sep"
-    "par-par-sep"
-    "par-fnote-sep"
-    "par-columns"
-    "par-columns-sep"
+  (list "par-mode" "par-flexibility" "par-hyphen" "par-spacing"
+    "par-kerning-stretch" "par-kerning-reduce" "par-expansion" "par-contraction"
+    "par-kerning-margin" "par-width" "par-left" "par-right" "par-first"
+    "par-no-first" "par-sep" "par-hor-sep" "par-ver-sep" "par-line-sep"
+    "par-par-sep" "par-fnote-sep" "par-columns" "par-columns-sep"
   ) ;list
 ) ;tm-define
 
diff --git a/TeXmacs/progs/generic/generic-edit.scm b/TeXmacs/progs/generic/generic-edit.scm
index 4806400cb5..a8f6104d8f 100644
--- a/TeXmacs/progs/generic/generic-edit.scm
+++ b/TeXmacs/progs/generic/generic-edit.scm
@@ -16,7 +16,7 @@
     (utils library cursor)
     (utils edit variants)
     (utils misc tooltip)
-    (bibtex bib-complete)
+    (latex bibtex-bib-complete)
     (source macro-search)
   ) ;:use
 ) ;texmacs-module
@@ -110,16 +110,8 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (define algo-macro-tags
-  '(algo-if algo-else-if
-     algo-else
-     algo-while
-     algo-for
-     algo-for-all
-     algo-for-each
-     algo-repeat
-     algo-loop
-     algo-procedure
-     algo-function
+  '(algo-if algo-else-if algo-else algo-while algo-for algo-for-all
+     algo-for-each algo-repeat algo-loop algo-procedure algo-function
      algo-if-else-if)
 ) ;define
 
@@ -594,19 +586,10 @@
 ;; 辅助函数：定义 enumerate-tag-list
 
 (define (enumerate-tag-list)
-  '(enumerate enumerate-numeric
-     enumerate-numeric-bracket
-     enumerate-roman
-     enumerate-roman-bracket
-     enumerate-roman-paren
-     enumerate-Roman
-     enumerate-alpha
-     enumerate-alpha-bracket
-     enumerate-alpha-full-paren
-     enumerate-Alpha
-     enumerate-circle
-     enumerate-hanzi
-     enumerate-numeric-paren)
+  '(enumerate enumerate-numeric enumerate-numeric-bracket enumerate-roman
+     enumerate-roman-bracket enumerate-roman-paren enumerate-Roman
+     enumerate-alpha enumerate-alpha-bracket enumerate-alpha-full-paren
+     enumerate-Alpha enumerate-circle enumerate-hanzi enumerate-numeric-paren)
 ) ;define
 
 ;; 辅助函数：定义 itemize-tag-list
@@ -618,11 +601,8 @@
 ;; 辅助函数：定义 description-tag-list
 
 (define (description-tag-list)
-  '(description description-compact
-     description-aligned
-     description-dash
-     description-long
-     description-paragraphs)
+  '(description description-compact description-aligned description-dash
+     description-long description-paragraphs)
 ) ;define
 
 ;; 辅助函数：检查是否在有序列表环境中
@@ -1245,12 +1225,13 @@
 
 (tm-define (ocr-paste source-format)
   (when (not (defined? 'ocr-to-latex-by-cursor))
-    (use-modules (liii ocr))
+    (use-modules (ocr liii-ocr))
   ) ;when
   (with data
     (if (string=? source-format "texmacs-snippet")
       (tree-ref (clipboard-get "primary") 0)
-      (parse-texmacs-snippet (tree->string (tree-ref (clipboard-get "primary") 0)))
+      ;; 剪贴板树为 (clipboard 

       
+      
       
       
       
       
+      
       
       
+      
+      
       
模拟目标: DialogShell / DialogButtons / EnumCombo / SelectableList / PreviewPane 组合逻辑。

     
 
@@ -1029,6 +1073,32 @@ 
是否保存当前更改？

         

       
 
+      

+        

+          

+            
PDF导出完成，是否要打开文件？

+            

+              
+              
+            

+          

+
+          

+            
PDF导出完成，是否要打开文件？

+            

+              
+              
+            

+          

+        

+        

+          对应 QML: message: dialogMessage
+          buttonLabels: dialogButtons（显示序与语义序相反，默认按钮居右）
+          dialogPrimary 指向默认按钮
+          onActivate -> choose(primaryIndex + 1)（Enter = 是）
+        

+      

+
       

         

           

@@ -1321,6 +1391,25 @@ 
Document statistics

           onClicked -> closeBridge.choose(0)
         

       

+      

+        

+          
Version

+          

+            You are using v2026.2.6.

+            The latest stable version of Mogan STEM is v2026.2.6, and the latest stable version of Liii STEM is v2026.2.6.

+            Please click OK to visit the official website to download the latest stable version.
+          

+          

+            
+          

+        

+        

+          对应 QML: versionTitle + versionLines + dialogButtons
+          onClicked -> closeBridge.choose(index + 1)
+          Scheme 根据确认结果决定是否打开官网
+          单行超宽自动换行（Text.Wrap），弹窗高度随内容自适应（implicitHeight 绑定，C++ 定宽后读值锁高）
+        

+      

       

         

           

@@ -1577,6 +1666,75 @@ 
切换界面语言

         

       

 
+      
+      

+        

+          

+            
+            
正在下载更新…

+            
无按钮、Esc 已禁用；下载完成后由 scheme 调 cpp-updater-dialog-close 关窗，再弹重启确认

+          

+        

+        

+          对应 QML: dialogMessage + dpScale/isDark/closeBridge
+          onCancel 覆盖为 no-op（禁 Esc）
+          run_modal_qml_dialog(setModal+show)——选非阻塞模态非为 live 重绘，而是 exec 嵌套事件循环会阻塞 scheme 的 delayed 轮询链；
+          全局单例宿主（QPointer，重复 open 不重弹）+ cpp-updater-dialog-open/close 成对 glue
+        

+      

+
+      

+        

+          

+            
Choose color

+            

+              

+                

+                

+              

+              

+                

+                
+                HEX 
+                R 
+                G 
+                B 
+                H 
+                S 
+                V 
+              

+            

+            
基本颜色

+            

+              

+              

+            

+            
自定义颜色

+            

+              

+                

+                

+              

+              

+                
+                
+              

+            

+            

+              
+              
+            

+          

+        

+        

+          对应 QML: pickerTitleProp + proposalsProp + customColorsProp + labelsProp
+          OK -> closeBridge.submit({color: "#rrggbb", customColors})
+          屏幕取色走 ColorPickerBridge（抓屏 overlay 点选，Esc 取消）
+          自定义颜色 16 格，OK 时经 preference 持久化；满格拒绝添加并显示提示行。
+        

+      

+
@@ -1590,28 +1748,37 @@

切换界面语言

font: document.getElementById('panel-font'), paragraph: document.getElementById('panel-paragraph'), statistics: document.getElementById('panel-statistics'), + version: document.getElementById('panel-version'), preferences: document.getElementById('panel-preferences'), - confirmRestart: document.getElementById('panel-confirm-restart') + confirmRestart: document.getElementById('panel-confirm-restart'), + updater: document.getElementById('panel-updater'), + colorPicker: document.getElementById('panel-colorpicker') }; const titleMap = { + version: 'Version.qml preview', confirm: 'ConfirmClose.qml 模拟', form: 'FormDialog.qml 模拟', font: 'FontSelector.qml 模拟', paragraph: 'ParagraphFormat.qml 模拟', statistics: 'Statistics.qml 模拟', preferences: 'Preferences.qml 模拟', - confirmRestart: 'ConfirmRestart.qml 模拟' + confirmRestart: 'ConfirmRestart.qml 模拟', + updater: 'UpdaterProgress.qml 模拟', + colorPicker: 'ColorPicker.qml 模拟' }; const codeMap = { + version: 'versionTitle + versionLines + closeBridge.choose(1)', confirm: 'dialogMessage + dialogButtons + closeBridge.choose()', form: 'formFields + values 收集 + closeBridge.submit(values)', font: 'fontBridge 联动: family/style/filter/customize/preview', paragraph: 'EnumCombo x N + tabs(基础/高级) + make-multi-line-with 写回', statistics: 'statsModel: [{label, value}, ...] + closeBridge.choose(0) 关闭', preferences: 'prefTabs(5) + subTabs(6) + EnumCombo + Toggle + 纯 OK 提交', - confirmRestart: 'message + buttonLabels + closeBridge.choose(index)' + confirmRestart: 'message + buttonLabels + closeBridge.choose(index)', + updater: 'dialogMessage + onCancel no-op + open/close 成对 glue', + colorPicker: 'pickerTitleProp + proposals + customColors + submit({color, customColors})' }; const viewTitle = document.getElementById('view-title'); @@ -1871,4 +2038,4 @@

切换界面语言

})(); - \ No newline at end of file + diff --git a/devel/0511.md b/devel/0511.md new file mode 100644 index 0000000000..f80e1e6f8b --- /dev/null +++ b/devel/0511.md @@ -0,0 +1,52 @@ +# 0511: 移除全部 SPARKLE 死代码 + +## 2026/08/08 移除全部 SPARKLE 死代码 + +### What（本次改动做了什么） + +删除 Windows WinSparkle 与 macOS Sparkle 两个自动更新框架的全部死代码： +删除 `tm_winsparkle.*`、`tm_sparkle.*` 四个文件，精简 `tm_updater.*` +的 SPARKLE 分支与描述，移除 `USE_PLUGIN_SPARKLE` 宏及其在 xmake、 +config.h、glue 初始化、资源文件中的全部引用。 + +### Why（为什么这么做） + +- `USE_PLUGIN_SPARKLE` 在 `xmake/targets/libmogan.lua` 被**无条件硬编码为 `false`**， + `git log -S "USE_PLUGIN_SPARKLE = true" --all` 零历史命中——两处 SPARKLE + 自始至终从未启用，属死代码。 +- Windows 端 WinSparkle 编译产物不被任何构建配置引用；macOS 端 `tm_sparkle.mm` + 甚至不被 `src/Plugins/Updater/**.cpp` 收集规则纳入构建。 +- 用户决策：两处 SPARKLE 全部移除，后续不再维护。 + +### How（怎么做的） + +1. **删除 4 个文件**：`src/Plugins/Updater/tm_winsparkle.cpp`、 + `tm_winsparkle.hpp`、`tm_sparkle.hpp`、`tm_sparkle.mm`。 +2. **`tm_updater.cpp`**：删除 include 块与 `instance()` 中的两个 SPARKLE 分支， + 由于本分支无 Velopack 改动，条件块删空后不再保留 `#if`，直接 + `_instance= new tm_updater ();`；头部 DESCRIPTION 去掉 "(Win)Sparkle"。 +3. **`tm_updater.hpp`**：头部 DESCRIPTION 去掉 "(Win)Sparkle"。 +4. **`src/System/config.h.xmake`**：删除第 66、89 行两处 `${define USE_PLUGIN_SPARKLE}`。 +5. **`xmake/targets/libmogan.lua`**：删除 `USE_PLUGIN_SPARKLE = false,`。 +6. **`src/Scheme/Plugins/glue_plugin_extra.hpp`**：`use_plugin_updater()` + 去掉 `#ifdef USE_PLUGIN_SPARKLE` 条件，恒返回 `false`。 +7. **`src/Scheme/Plugins/init_glue_plugins.cpp`**：删除 + `#ifdef USE_PLUGIN_SPARKLE / initialize_glue_updater (); / #endif` 整块 + （main 现状该调用本就因宏恒 false 不执行，行为无回归）。 +8. **`packages/windows/resource.rc.in`**：第 9 行注释去掉 WinSparkle 字样， + VERSIONINFO 块本身保留（仍被 Windows 使用）。 + +### 涉及文件 + +- `src/Plugins/Updater/tm_updater.cpp`、`tm_updater.hpp` +- 删除：`src/Plugins/Updater/tm_winsparkle.cpp`、`tm_winsparkle.hpp`、`tm_sparkle.hpp`、`tm_sparkle.mm` +- `src/System/config.h.xmake`、`xmake/targets/libmogan.lua` +- `src/Scheme/Plugins/glue_plugin_extra.hpp`、`src/Scheme/Plugins/init_glue_plugins.cpp` +- `packages/windows/resource.rc.in` + +### 验证门槛 + +- `grep -rni "sparkle" src/ xmake/ packages/windows/` 无 SPARKLE 残留引用 + （`devel/` 历史文档除外）。 +- `grep -rn "USE_PLUGIN_SPARKLE" src/ xmake/` 为空。 +- Windows 构建通过：`xmake b stem`（vcvars64 MSVC）。 diff --git a/devel/0512.md b/devel/0512.md new file mode 100644 index 0000000000..db92b44dd9 --- /dev/null +++ b/devel/0512.md @@ -0,0 +1,349 @@ +# 0512: 迁移到 Velopack 打包与自动更新 + +## 2026/08/07 迁移到 Velopack 打包与自动更新 + +### What（本次改动做了什么） + +把 Mogan STEM 的 Windows 发布与自动更新从"客户端下载完整 NSIS 安装包后静默执行"迁移到 +Velopack：以 Velopack 作为安装/更新事务的唯一所有者，产出 `Setup.exe`/MSI 与 `releases..json` +静态 feed + delta 增量包；应用内通过 Velopack C++ runtime 检查、后台下载、用户确认后安装并重启。 + +### Why（为什么这么做） + +- 常规升级路径下载整包且静默执行，更新体积大、耗时长；Velopack delta 让已装用户只下载增量。 +- 文件占用、版本目录替换、重启与 delta 链选择交给 Velopack，避免自研 `MoganUpdater`/HDiffPatch/提权 worker。 +- 三平台共用 Velopack 发布版本、渠道与客户端更新 API，各平台仍产出各自安装格式。 + +### How（怎么做的） + +1. **C++ runtime 集成（Windows）**：`velopack_libc_1.2.0` vendor 到 `3rdparty/velopack/`； + xmake 为 `stem` 引入头文件/导入库/动态库；`research.cpp` 的 `main()` 首行 + `Velopack::VelopackApp::Build().Run()`（早于 `lolly::init_tbox()` 等副作用）。 +2. **tm_velopack 抽象**：保留 `tm_updater` 内部边界，新增状态机 + `idle/checking/available/downloading/ready/applying/failed` 与版本/进度/错误码/发行说明， + 以及 `downloadUpdate`/`applyUpdate`；`instance()` 在 Windows 下走 `USE_PLUGIN_VELOPACK` 分支， + WinSparkle/Sparkle 原分支不变。 +3. **Scheme 自动更新闭环（本次）**：在 `tm_updater` 之上提供 Scheme 层能力—— + 增强 `updater-initialize`（启动时无条件检查一次并启动 `updater-scheduled-check` + 定时检查循环，固定 1 小时节流，不读取 `updater:interval` 偏好），并提供静默下载/应用包装 + （`updater-download-update`/`updater-apply-update`）， + 供后续自动下载（状态监听循环）消费； + 并为 `updater-state/download/apply` 补 3 个 glue 符号声明。 + 更新模型：使用过程中后台静默检查与下载、不打扰用户；已下载更新在下次启动时由 + `VelopackApp::Build().Run()` 自动应用（显示 Velopack 自带进度条）； + 不做任何确认框（`updater-maybe-restart-to-update` 不引入）。 + 旧 `updater:interval` 偏好及 preferences 相关字段的删除留待后续清理。 + 前台手动检查与状态显示（帮助 → 版本「检查更新」按钮）不属于本迁移规划， + 本次不引入任何界面改动。 +4. **tm_velopack 状态机重构（本次）**：保留 `UPDATER_CHECKING` 表达「检查进行中」， + `do_check` 结果驱动——检查启动时保存检查前状态，复查不冲掉 READY「待应用」状态 + （同版/更旧版本保持 READY）、无更新时恢复检查前状态并清 FAILED 标记、按 semver + 优先级比较版本（处理 rc9/rc10 等字符串序失效场景）；`applyUpdate` 不再在 C++ 层 + `exit(0)`，改由 scheme 调用方走 `(safely-quit-TeXmacs)` 正常退出通道；并发修复 + （`call_once`/`unique_ptr` 管理 UpdateManager、下载/应用锁内快照后锁外执行、 + 应用期间拒绝新检查）。 +5. **自动下载（本次）**：新增 `updater-auto-download-loop` 状态监听循环——运行中每秒 + 轮询 `updater-state`，available 时自动触发 `updater-download-update` 静默下载； + 下载就绪（ready）后不再动作，下次启动由 `VelopackApp::Build().Run()` 自动应用； + 下载失败（failed）不立即重试，等下一次定时检查（1 小时）重新发现更新后再试。 + 自动下载默认启用、不提供独立配置入口（后续统一入口统一管理）。 +6. **旧代码清理（本次）**：删除旧 WinSparkle 时代的 `updater:interval` 偏好骨架—— + `define-preferences`、`pref-updater-interval`、preferences 的 "Check for automatic + updates" 字段与 `updater:last-check` 显示行、`updater-last-check-formatted`/ + `last-check-string` helper、`updater-only` 平台过滤；同时删除无人消费的 glue 与 + C++ 死代码：`updater-running?`/`updater-check-foreground`/`updater-set-interval` + （含 `isRunning`/`checkInForeground`/`setCheckInterval`/`getCheckInterval`/ + `setAppcast` 与 `appcast`/`interval` 成员）。检查节奏已由 scheme 硬编码 1 小时， + interval 配置不再需要。 +5. **测试期望回归修复（本次）**：清理提交把 `preferences-widgets-test.scm` 中 + `"other"` tab 字段数期望从 `(if (os-macos?) 17 15)` 误改为 `15 13`。但测试环境 + `use-plugin-updater?` 为 `#f`，旧代码 `updater-only` 平台过滤本就把两个 updater + 字段滤掉，测试计数从未包含它们——从字段列表删除它们不改变计数。实际计数 + macOS 仍为 17（misc 5 + experimental 12）、Debian 为 15；Windows CI + （`ci-xmake-windows.yml`）不运行 scheme 单元测试，静态同为 15。恢复期望为 + `(if (os-macos?) 17 15)`，`xmake r preferences-widgets-test` 426 checks 全过。 + +### 涉及文件 + +- `src/Mogan/Research/research.cpp`、`xmake/targets/stem.lua`、`xmake/targets/libmogan.lua` +- `src/Plugins/Updater/tm_updater.*`、`tm_velopack.*`（新增）、`src/Scheme/Plugins/glue_updater.lua` +- `TeXmacs/progs/utils/misc/updater.scm`、`TeXmacs/progs/prog/glue-symbols.scm` +- `TeXmacs/progs/texmacs/menus/tests/preferences-widgets-test.scm`（期望值回归修复） + +### 如何测试 + +#### 开发版本运行正常 +``` +xmake b stem ; xmake i stem ; xmake r stem +``` + +#### CI 流水线正常通过 + +github 检查 + +#### CD 流水线正常通过 + +github 检查 + +## 2026/08/12 Velopack 打包 + +### What（本次改动做了什么） + +新增 `tools/release/stage_velopack.lua` 与 `pack_velopack.lua`，接管常规 Windows +发布：stage 把 stem 安装树装配为 Velopack 扁平暂存根，pack 调用 `vpk pack` 产出 +Setup.exe、全量/增量 nupkg 与 `releases..json`。NSIS（`xmake pack`）仅 +迁移期桥接保留。 + +### Why（为什么这么做） + +- Velopack `--mainExe` 必须是 packDir 根部的文件名，主 exe 与 Qt DLL、数据必须同根平铺； +- 应用按 `$TEXMACS_PATH/progs` 等扁平查找资源，`TeXmacs/` 包装目录会解析失败； +- `find-binary`/pandoc 按 `$TEXMACS_PATH/bin` 查找辅助程序，`bin/` 子目录保留； +- `TEXMACS_PATH` 不能再用 `exedir/".."`：Velopack 下 exe 位于 `current/` 根、数据同根。 +- Qt DLL 为 `/MD`，依赖 VC++ 14.3（VS2022）运行库：运行库以 app-local 方式随包 + （stage 从 `vc_redist.x64.exe` 提取 DLL 进暂存根；该文件由 Qt 部署 windeployqt + 从构建机 VS 的 `VC\Redist` 自动拷入安装树，版本即构建机 VS 自带版本），不用 + `vpk --framework`，避免 Setup.exe 在目标机缺库时从微软 CDN 下载安装。 + +### How（怎么做的） + +1. **`init_texmacs.cpp` Windows 分支**：`exists (exedir * "progs")` 为真时取 `exedir` + （Velopack 扁平布局），否则取 `exedir * ".."`（NSIS：exe 在 bin/、数据在父目录）。 +2. **stage_velopack.lua**：`bin/` 拆分（Qt DLL/主 exe 摊到根、辅助程序进 `bin/`、 + `.pdb` 跳过）、数据平铺到暂存根、`texmacs_entries` 排除 `tests`（格式回归样例， + 无运行期作用）、`dark -x` 解包 `vc_redist.x64.exe` + `msiexec /a` 提取运行库 + DLL 到暂存根（app-local CRT）。 +3. **pack_velopack.lua**：`vpk pack` 生成发布物（不带 `--framework`，运行库已在 + payload 内）；CI 不签名（`VPK_SIGN_PARAMS` 空），正式签名在签名机注入 + signtool 参数。 +4. **CD 流水线**：`cd_research_on_windows.yml` 从 `xmake pack` 切换到 + stage → pack；scoop 增加 `dark`；`vc_redist.x64.exe` 由 Qt 部署在 + `xmake install` 时自动拷入安装树（与旧 NSIS 流程一致），CI 不额外下载； + 上传/发布产物改为 `build/velopack_release/*`。 + +### 涉及文件 + +- `tools/release/pack_velopack.lua`、`stage_velopack.lua`（新增）、`xmake/targets/xpack.lua` +- `.github/workflows/cd_research_on_windows.yml`、`src/System/Boot/init_texmacs.cpp` + +### 如何测试 + +#### 本地打包验证 + +``` +xmake b stem ; xmake i stem +xmake l tools/release/stage_velopack.lua +xmake l tools/release/pack_velopack.lua +``` + +#### 开发 vs 发版命令对照 + +| 场景 | 命令 | +|------|------| +| 改代码本地验证 | `xmake b stem`（GUI 用 `xmake r stem`） | +| 改 scheme 后跑单测 | `xmake b stem` → `xmake i stem` → `xmake r ` | +| 改打包脚本 | `xmake l tools/release/stage_velopack.lua` → pack | +| 发版 | `xmake b stem` → `xmake i stem` → stage → pack（CI 执行） | + +## 2026/08/13 版本号规范：预发布段改用 rc.N + +### What（本次改动做了什么） + +把发布版本号的预发布段从 `rcN`（如 `2026.3.0-rc12`）改为 `rc.N`（如 +`2026.3.1-rc.1`），并同步更新 bump version workflow 的格式校验。 + +### Why（为什么这么做） + +SemVer 2.0 规定：`rcN` 是字母数字混合标识符，预发布段按**字典序**比较，导致 +同一版本线下 `rc9` 会被判定为比 `rc10`/`rc11`/`rc12` 更新（`rc10 < rc2 < +rc9`）。Velopack 的 feed 排序、delta 基线选择、`vpk pack` 的防重打保护全部 +依赖这个排序： + +- 已装 rc10/11/12 的客户端会被判定为可以“升级”回 rc9（实际是回退）； +- 继续按 `rc13` 打包会被 vpk 拒绝（rc13 < rc9）。 + +`rc.N` 拆开后数字段按**数值**比较（`rc.9 < rc.10`），排序永远正确。 + +### How（怎么做的） + +1. **格式约定**：预发布段统一写 `rc.<纯数字>`，禁止再写 `rcN`；纯数字段 + 不补前导零（`rc.01` 与 `rc.1` 数值相等，会混淆）。 +2. **迁移约束**：同一版本线下旧格式 `rc9` 是语义最大版本，任何 `rc.N` 与它 + 比较时第一个标识符 `"rc" < "rc9"`，仍然判旧。因此首个 `rc.N` 版本必须 + 升版本线（当前从 `2026.3.0-rc12` 切到 `2026.3.1-rc.1`），靠核心数字段 + `2026.3.1 > 2026.3.0` 压过旧线所有 rc。 +3. **bump workflow**：版本格式正则从 `(-rc[0-9]+)?$` 改为 `(-rc\.[0-9]+)?$`。 + +### 涉及文件 + +- `xmake/vars.lua`（XMACS_VERSION 值） +- `.github/workflows/ci_bump_version.yml`（格式正则与提示文案） +- `src/Plugins/Updater/tm_velopack.cpp`（注释，比较器本身已支持 `rc.N`） +- `tools/release/pack_velopack.lua`、stage 脚本无需改动（版本号原样透传） + +### 对 NSIS→Velopack 过渡的影响 + +无影响。NSIS 桥接（`xmake/targets/xpack.lua`）取版本号是截断到第一个 `-` +再补 `.0`（`2026.3.1-rc.1` → `2026.3.1.0`），与旧格式处理方式一致； +`research.nsis` 的版本资源本来就不带 rc 后缀。Debian/Fedora 去 rc 后缀用 +`${VERSION%-*}`，行为不变。格式修改只影响 Velopack 侧的版本排序，恰好是 +修复对象。 + +### 如何测试 + +#### 版本格式校验 + +``` +echo v2026.3.1-rc.1 | grep -qE '^v[0-9]{4}\.[0-9]{1,2}(\.[0-9]+)?(-rc\.[0-9]+)?$' && echo OK +``` + +#### 本地打包验证（顺序不可颠倒） + +``` +xmake b stem ; xmake i stem +xmake l tools/release/stage_velopack.lua +xmake l tools/release/pack_velopack.lua +``` + +注意：outputDir 已有旧线版本（如 `2026.3.0-rc12`）时，`2026.3.1-rc.1` +核心段更大，vpk 可正常接受并从旧线 full 生成 delta；若仍在旧线内打 `rc.N` +会被 vpk 拒绝（属预期行为）。 + +## 2026/08/13 GitHub Release 基线改为单压缩包 + +### What（本次改动做了什么） + +CD 流水线不再用 `vpk download github` 拉取 delta 基线；GitHub Release 每版 +只上传一个 `mogan-release-<版本>-win-x64.zip`（内含 Setup、Portable、 +full/delta nupkg、feed json 等整个发布目录；Windows CD 为 x64 单平台，文件名 +直接写明平台架构，与 vpk `--runtime win-x64` 一致）。下次发版时，基线步骤 +通过 GitHub API 找到上一版本的 release，用 `wget` 下载该 zip，解压后自行拣出 +`*-stable-full.nupkg` 放进 `build/velopack_release`，供 `vpk pack` 生成 delta。 + +### Why（为什么这么做） + +- `vpk download github` 要求 release 资产按 Velopack 约定散装命名 + （`Mogan-<版本>-stable-full.nupkg` 等），且会把整个 feed 目录一并拉下来； +- 单 zip 既是 delta 基线的下载源，也是 OSS 手动上传的整包，GitHub Release + 每版不再堆积 Setup/Portable/full/delta/json 六七个大文件； +- 用户手动上传 OSS 时，下载这一个 zip 解压即可得到全部产物。 + +### How（怎么做的） + +1. **Fetch delta baseline 步骤**：`Invoke-RestMethod` 列最近 100 个 release， + 排除 draft 与当前 tag（`GITHUB_REF_NAME`，重跑同 tag 时不把自己当基线）， + 取最新非当前发布；优先下载其中的 `mogan-release-*.zip` 并 `Expand-Archive`， + 兼容回退：旧 release 无 zip 时直接下载散装 `*-stable-full.nupkg`。 + API 地址用 `${{ github.repository }}`（仓库已由 XmacsLabs/mogan 改名为 + MoganLab/mogan，跟随当前仓库避免依赖重定向）。 +2. **拣选规则**：从下载物中找 `*-stable-full.nupkg`，解析文件名版本 + （`Mogan-<版本>-stable-full.nupkg`），与 `xmake/vars.lua` 的 + `XMACS_VERSION` 比较；版本不同才复制进 `build/velopack_release`（避免 + 重跑同版本时把同版本 full 放进 outputDir 导致 vpk 防重打拒绝）。 +3. **Create release archive 步骤**：Pack 后把整个 `build/velopack_release` + 用 `Compress-Archive` 打成 `build/mogan-release-<版本>-win-x64.zip` + （文件名带平台架构）。 +4. **Release 步骤**：`softprops/action-gh-release` 只上传 + `build/mogan-release-*.zip`；非 tag 触发的 artifact 上传追加该 zip。 + +### 涉及文件 + +- `.github/workflows/cd_research_on_windows.yml` + +### 边界情况 + +- 首次发布或上一版本还没有 zip：基线步骤失败属正常（`continue-on-error`）， + pack 只出 full 包； +- release 全部是 prerelease，`releases/latest` 接口拿不到，必须列全部再筛选； +- runner 的 `wget` 来自 scoop（workflow 已安装），与 Noto 字体下载同源。 +- **GITHUB_TOKEN 不会自动注入为环境变量**：必须显式 + `env: GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}`，否则 `$env:GITHUB_TOKEN` + 为空、`Authorization: Bearer ` 触发 401 Bad credentials（实测踩坑）。脚本内 + 做了兜底：token 为空时回退匿名访问（公开仓库可用，限 60 次/小时/IP）。 +- 本地验证：用 `build/velopack_release` 整目录 `Compress-Archive` 成 zip 后跑 + 拣选逻辑，能正确取出 `*-stable-full.nupkg`；当前版本与基线相同时跳过复制。 + +## 2026/08/14 updater 定时调度改用 :pause（修复自动更新静默） + +### What（本次改动做了什么） + +把 updater 的延迟调度从 `(delayed (:idle N) ...)` 改为 `(delayed (:pause N) ...)`： +- `init-research.scm` 启动钩子：`(:idle 2000)` → `(:pause 2000)` +- `updater-scheduled-check` 定时复查：`(:idle 600000)` → `(:pause 600000)` +- `updater-auto-download-loop` 轮询：`(:idle 1000)` → `(:pause 1000)` + +### Why（为什么这么做） + +本 Qt 环境下 `delayed :idle` 不触发：实测 GUI 里 `(delayed (:idle 5000) ...)` 等 +14 秒无反应，而 `(delayed (:pause 3000) ...)` 立即触发。这导致 `updater-initialize` +从不执行——启动不检查、下载轮询不跑，自动更新完全静默。telemetry 用 `:pause` +一直工作正常，是项目内可信任的范式；`:idle` 在本 GUI 的延迟命令队列里排不上。 + +### How（怎么做的） + +逐处把 `delayed` 第一参数由 `:idle` 改为 `:pause`，同步注释中的引用。 + +端到端验证（rc.14 装机 + 本修复注入 current\progs）：启动自动检查（日志 +`Downloading releases ... localVersion=2026.3.0-rc.14`）→ 自动下载 delta 并组装 +full → 就绪（READY）→ 用户再次启动时 `VelopackApp` 自动应用 +（`Package version 2026.3.0-rc.15 applied successfully`）并换壳重启，版本升到 rc.15。 + +### 涉及文件 + +- `TeXmacs/progs/init-research.scm` +- `TeXmacs/progs/utils/misc/updater.scm` + +### 边界情况 + +- 服务器上已发布的 rc.15 包是修复前打的，自带旧 `:idle` 代码；升级会把 + `current\progs` 覆盖回旧调度。本修复必须打进下一个版本（rc.16+）才能让 + 更新器在升级后持续可用。 + +## 2026/08/14 打包后处理：清理历史 full 包（release 只留当前版本产物） + +### What（本次改动做了什么） + +`pack_velopack.lua` 在 vpk pack 完成后新增后处理 `prune_old_full`： +1. 删除 outputDir 中除当前版本外所有 `*-stable-full.nupkg`（当前版本 full 保留）； +2. 重写 `releases..json`，去掉旧版本 full 条目，只留当前版本 full 与 + 历史 delta。 + +另新增 `VPK_PRUNE_ONLY=1` 模式：跳过 vpk pack / 改名 / assets 同步，只跑后处理 +（可独立重跑清理，也是本次本地验证的入口）。 + +### Why（为什么这么做） + +vpk pack 把 outputDir 当作 channel 累积目录：上一版本 full 会留在 outputDir 并 +被写进 `releases..json`。那份旧 full 只是生成 delta 的基线，客户端走 +delta 用的是**本地 packages 目录**里的旧 full（联调日志 `Found ...-rc.14-full.nupkg` +证实），feed 上的旧 full 不会被拉取，纯属冗余。它的存在让手动 OSS 上传流程被迫 +多传/判断，且一旦旧 full 文件被清而 manifest 仍引用，就埋下 404 暗雷。回滚另走 +OSS 保留策略，与新 release 的 manifest 无关。 + +### How（怎么做的） + +- `prune_old_full (out_dir, channel, version)`：`os.files` 扫 + `Mogan-*--full.nupkg`，非当前版本 `os.rm`；`json.decode` 后过滤 + `Type == "Full"` 且 `Version ~= 当前版本` 的条目，`json.encode` 写回。 +- 在 pack 流程末尾（改名、assets 同步之后）无条件调用；`VPK_PRUNE_ONLY` 时 + 跳过 pack 主体直接调用。 +- 坑：xmake lua 沙箱**无 `pcall`**（函数体引用 `pcall` 即导致整个文件加载失败， + `try/catch` 在该上下文也不生效）。防御改为「内容含 `"Assets"`」结构检查 + + 直接 `json.decode`（vpk 生成的 manifest 必然合法，损坏时大声失败）。 + +本地验证（rc.15 full 为基线完整重打 rc.16）：vpk 自动生成 rc.15→rc.16 delta +（1.5MB），prune 删除 rc.15 full 并清 manifest，outputDir 只剩 rc.16 full + +delta + Setup/Portable；delta 哈希与旧基线产物完全一致（`62CD1F...`/`2B84F0...`）。 + +### 涉及文件 + +- `tools/release/pack_velopack.lua` + +### 边界情况 + +- outputDir 保留当前版本 full，作为下一次 pack 的 delta 基线，delta 链路不受影响 + （下次打 rc.17 时 vpk 拿 rc.16 full 自动出 rc.16→rc.17 delta）； +- prune-only 模式必须显式传 `VPK_VERSION`（否则从 vars.lua 读到 rc13，会把当前 + 版本 full 也当旧包删掉）； +- 客户端本地基线包损坏时不能从 feed 补下旧 full 走 delta，会退化为全量下载 + （概率极低，可接受）。 diff --git a/devel/0513.md b/devel/0513.md new file mode 100644 index 0000000000..e6b6622aa8 --- /dev/null +++ b/devel/0513.md @@ -0,0 +1,15 @@ +# [0513] 修复括号不匹配问题 + +## 如何测试 + +``` +gf fmt +``` + +运行格式化，不出现 read-error 即可 + +## What + +#4311 引入了 `convert-latex-tmtex-elsevier.scm` 的括号不匹配问题 + +`uk_UA.scm` 缺少一个引号，这个应该是历史遗留，只是一直被 fmt 忽略 diff --git a/devel/0514.md b/devel/0514.md new file mode 100644 index 0000000000..89b6732980 --- /dev/null +++ b/devel/0514.md @@ -0,0 +1,52 @@ +# [0514] 首选项统一存放位置 + +## 1 相关文档 +- [0515.md](0515.md) — 首选项配置文件改为 JSON 格式（本任务依赖其引入的 JSON 读写与 nlohmann_json 库能力） + +## 2 任务相关的代码文件 +- `src/System/Misc/tm_sys_utils.cpp` — `get_tm_preference_path()` 由 `system//` 改为统一位置 + `system/preferences.json`（不再随版本号变化） +- `src/System/Config/preferences.cpp` — 简化 `load_user_preferences`：只读统一位置 JSON，删除跨版本迁移逻辑 +- `tests/System/Config/preferences_test.cpp` — 删除迁移用例 +- `CLAUDE.md` — 更新「首选项（preferences）与旧版本配置文件兼容性」规范 + +## 3 如何测试 + +### 3.1 确定性测试（单元测试） +```bash +xmake b preferences_test && xmake r preferences_test +``` +用例：写入含特殊字符的值 → 保存 → 统一位置 `preferences.json` 合法 JSON 且转义正确 → 重新加载取回原值； +文件缺失（首次运行）→ 走默认值。 + +### 3.2 非确定性测试（交互验证） +1. 修改任意首选项（如界面语言）→ 退出重启，确认设置保留； +2. 查看 `$TEXMACS_HOME_PATH/system/preferences.json`，确认是合法 JSON；值含引号/反斜杠（如 Windows 路径）时不损坏； +3. bump `XMACS_VERSION` 后重启，确认仍读同一文件、首选项不重置； +4. 开发者菜单 "Open preferences.json" 打开文本缓冲。 + +## 4 What +- 首选项统一存放于 `$TEXMACS_HOME_PATH/system/preferences.json`，不再按版本分目录： + `get_tm_preference_path ()` 去掉版本号，一次写入后路径永久固定，版本 bump 不再影响首选项位置。 +- 删除 0515 分支早期设计中的跨版本迁移逻辑（`compare_versions`/`load_legacy_preferences`/ + `migrate_legacy_preferences`）——Mogan 历史上即不保留个人配置，无需迁移旧版本目录。 +- `CLAUDE.md` 更新「涉及首选项改动务必适配旧版本配置文件」规范。 + +## 5 Why +- 旧方案首选项按版本分目录存储（`system//preferences.json`），版本号 bump 后新版本 + 读写新目录，旧首选项永远不会被读 → 用户升级后表现为「每次更新都重置」。 +- 统一位置彻底解决：所有版本读写同一个文件，路径固定，升级不丢配置；且无需为旧版本目录编写 + 迁移合并逻辑（Mogan 从未承诺保留跨版本配置）。 +- 顺带修正 0515 记录的已知问题——开发者菜单「Open preferences.json」指向的 + `$TEXMACS_HOME_PATH/system/preferences.json` 从 stale 路径变成真实路径。 + +## 6 How +- `get_tm_preference_path ()`：返回 `get_texmacs_home_path () * "system/preferences.json"`， + 不再拼接 `XMACS_VERSION`。 +- `load_user_preferences ()`：统一位置 `preferences.json` 存在 → `load_json_preferences`；否则留空 + （默认值）；不再扫描/合并任何旧版本目录。 +- 保留 `save_user_preferences ()` 的 `merge_sort` 排序，保证 JSON 输出确定性。 + +## 7 已知问题 +- 历史遗留的旧版本目录（`system/<版本>/preferences.scm` / `.json`）不再被读取，也不会被清理； + 升级前已存在的个人配置不会被迁移（Mogan 一贯如此）。 diff --git a/devel/0515.md b/devel/0515.md new file mode 100644 index 0000000000..8cd1db248d --- /dev/null +++ b/devel/0515.md @@ -0,0 +1,50 @@ +# [0515] 首选项配置文件改为 JSON 格式 + +## 1 相关文档 +- [0514.md](0514.md) — 跨版本首选项迁移（依赖本任务引入的 JSON 读写能力） +- 说明：任务原拟编号 0513，但 `devel/0513.md` 已被已合并任务「修复括号不匹配问题 (#4318)」占用， + 故改编号 0515；迁移任务保持用户指定的 0514。 + +## 2 任务相关的代码文件 +- `src/System/Misc/tm_sys_utils.cpp` — `get_tm_preference_path()` 返回 `preferences.json` 路径 +- `src/System/Config/preferences.cpp` — 首选项读写改为 JSON（用项目已引入的 `nlohmann/json`， + 新增 `load_json_preferences`；`save_user_preferences` 输出 JSON） +- `TeXmacs/progs/texmacs/menus/developer-menu.scm` — "Open preferences.scm" → `preferences.json`（仅改扩展名） +- `tests/System/Config/preferences_test.cpp` — 新增：JSON 往返测试 + +## 3 如何测试 + +### 3.1 确定性测试（单元测试） +```bash +xmake b preferences_test && xmake r preferences_test +``` + +### 3.2 非确定性测试（交互验证） +1. 修改任意首选项（如界面语言）→ 退出重启，确认设置保留； +2. 查看 `$TEXMACS_HOME_PATH/system/<版本>/preferences.json`，确认是合法 JSON；值含引号/反斜杠（如 Windows 路径）时不损坏； +3. 开发者菜单 "Open preferences.json" 打开文本缓冲。 + +## 4 What +- 首选项存储文件由 scheme 列表格式 `preferences.scm` 改为标准 JSON `preferences.json`； +- 解析/序列化复用项目 3rdparty 已引入的 `nlohmann_json`，不手写 JSON 解析器。 + +## 5 Why +1. `.scm` 是 TeXmacs 遗留内部格式，不利于外部工具解析/编辑；JSON 是通用的用户可读配置格式； +2. 项目已自带 `nlohmann/json`（单头文件、被 libstem/goldfish 使用，`3rdparty/nlohmann_json/include`）， + 解析与转义由成熟库保证，无需手写递归下降解析器（手写解析易漏边界，且 lolly 的 `json` 库本身 + 没有解析器、`dump()` 转义不完整）。 + +## 6 How +- `preferences.cpp` 改用 `nlohmann::json`： + - `load_json_preferences (url)`：`json::parse (std::string, nullptr, false)`（不抛异常）→ + `is_discarded () || !is_object ()` 时降级为默认；遍历 `items ()`，仅导入**值为字符串**的键 + （数字/布尔/null 跳过，容错）； + - `save_user_preferences ()`：`json::object ()` 逐键赋值后 `dump ()`（nlohmann 默认转义标准， + 非 ASCII 保持字面 UTF-8），仍按 `merge_sort` 排序保证确定性输出； + - lolly `string` ↔ `std::string` 用两个静态转换辅助函数衔接； +- 旧 `.scm` 解析逻辑本任务删除，由 [0514](0514.md) 以跨版本迁移形式回归。 + +## 7 已知问题 +- 开发者菜单 "Open preferences.json" 打开 `$TEXMACS_HOME_PATH/system/preferences.json`（无版本号）—— + 该路径本就 stale（实际文件在 `system/<版本>/` 下），本任务仅改扩展名，未修正版本路径； +- 本任务落地后新版本只读 `preferences.json`，旧 `.scm` 首选项的兼容由 [0514](0514.md) 跨版本迁移保证。 diff --git a/devel/0516.md b/devel/0516.md new file mode 100644 index 0000000000..3dce61bb93 --- /dev/null +++ b/devel/0516.md @@ -0,0 +1,39 @@ +# 0516: 更新源按社区版/商业版区分 + +## 2026/08/17 更新源按社区版/商业版区分 + +### What（本次改动做了什么） + +Velopack 自动更新的 feed 根 URL（`default_feed_url`）由单一写死地址改为按 +社区版/商业版编译期二选一： + +- 社区版（`IS_COMMUNITY`）：`https://liiistem.cn/api/v1/public/update/win-x64`（不变） +- 商业版：`https://liiistem.cn/api/v1/public/commercial/update/win-x64` + +### Why（为什么这么做） + +社区版与商业版需要走不同的更新通道，各自发布各自的版本节奏；此前共用一个 +feed URL，商业版构建无法指向商业版更新服务器。 + +### How（怎么做的） + +1. 利用构建期已有的版本开关：`xmake/options.lua` 的 `is_community` 选项经 + `xmake/targets/libmogan.lua` 注入 `IS_COMMUNITY` 宏，`tm_velopack.cpp` 中 + 以 `#ifdef IS_COMMUNITY` 选定 `default_feed_url`，其余检查/下载/应用逻辑 + 完全复用，无需任何运行期配置。 +2. 跨通道升级依赖 Velopack 资产匹配机制：两通道 packageId 一致时，社区版 + 切到商业版 feed 后，Velopack 找不到匹配 baseVersion 的 delta 会自动回退 + full 包，可直接跨通道升级；无需商业版以社区版为基线打 delta。 + 注意反向（商业版降回社区版）不可行：版本号不高于本机版本时视为无更新。 + +### 涉及文件 + +- `src/Plugins/Updater/tm_velopack.cpp`：`default_feed_url` 按 `IS_COMMUNITY` 二选一。 + +### 验证与遗留 + +- 该代码块仅在 `USE_PLUGIN_VELOPACK && OS_WIN` 下编译，Linux 上不参与构建， + 本机无法编译验证；待 Windows 构建机分别以 `--is_community=y/n` 构建后 + `strings MoganSTEM.exe | grep liiistem.cn` 确认各含且仅含对应 URL。 +- 商业版后端（`/api/v1/public/commercial/`）尚未开发，商业版 feed 联调待 + 后端上线后进行；当前商业版构建检查更新会进入 `UPDATER_FAILED`，属预期。 diff --git a/devel/0517.md b/devel/0517.md new file mode 100644 index 0000000000..26a7de3b19 --- /dev/null +++ b/devel/0517.md @@ -0,0 +1,55 @@ +# 0517: 更新源 base URL 按 stem-profile 运行时切换 + +## 2026/08/xx 更新源 base URL 按 stem-profile 运行时切换 + +### What（本次改动做了什么） + +Velopack 自动更新的 feed URL 由「编译期写死」改为「base URL 运行期按 +`stem-profile` 首选项选定」： + +- `stem-profile` 为 `default` 或 `production`：`https://liiistem.cn/...` +- `stem-profile` 为 `staging`：`https://test.liiistem.cn/...` + +路径段（`/api/v1/public/update/win-x64` 或 `/api/v1/public/commercial/update/win-x64`） +仍按社区版/商业版（`IS_COMMUNITY` 宏）编译期选定，与 0516 保持一致。 + +### Why（为什么这么做） + +staging 环境需要独立于生产环境的更新通道：测试环境验证升级流程时不能把 +staging 构建指向生产 feed（既污染生产发布数据，也拿不到 staging 的候选版本）。 +账户/邀请等其它模块已按 `stem-profile` 切换服务器（见 liii.scm 的 +`current-stem-site`），更新源需要跟随同一约定。 + +### How（怎么做的） + +1. `src/Plugins/Updater/tm_velopack.cpp`： + - 新增 `feed_base_url ()`：读 `stem-profile` 首选项（`get_user_preference`， + 直接读 C++ 侧 `user_prefs` 哈希表，避免走 scheme 回调）， + `staging` → `https://test.liiistem.cn`，其余（含 `default`/`production`）→ + `https://liiistem.cn`。 + - 新增 `feed_url (base)`：base URL + 编译期按 `IS_COMMUNITY` 选定的路径段。 + - `tm_velopack_rep` 用 `mgr_base`/`feed_base` 取代 `mgr_once`：`feed_base` + 是检查/下载启动时主线程快照的 base URL；`ensure_mgr ()` 比较 + `mgr_base != feed_base` 时重建 `UpdateManager` 换源。 + - `checkInBackground`/`downloadUpdate` 在 spawn worker 前（主线程）刷新 + `feed_base` 快照；worker 内 `ensure_mgr` 只用快照，不触碰首选项 + （scheme 回调非线程安全，避免工作线程跨线程调 `get_preference`）。 +2. 重建时机与并发：`ensure_mgr` 只在 worker 内、mgr 未被并发使用发生 + （状态机保证同一时刻至多一个 worker，`APPLYING` 期间不接受新检查）， + `mgr` 指针在检查/下载/应用期间保持有效，无需额外同步。 + +### 涉及文件 + +- `src/Plugins/Updater/tm_velopack.cpp`：feed URL 改为 base URL 运行期按 + `stem-profile` 选定，`ensure_mgr` 按 profile 快照重建 mgr。 + +### 验证与遗留 + +- 该代码块仅在 `USE_PLUGIN_VELOPACK && OS_WIN` 下编译，Linux 上不参与构建； + 待 Windows 构建机以不同 `stem-profile` 配置启动后确认 feed URL 跟随切换。 +- **开发环境（build 目录直跑）更新检查必然 `UPDATER_FAILED`**：`UpdateManager` + 构造时 Velopack 找不到 app manifest（`This application is not properly + installed: Could not auto-locate app manifest`），属预期，非 bug； + 只有经 `Setup.exe` 安装的构建才能正常检查。验证换源需在安装版上做。 +- `stem-profile` 切换后需等下一次定时检查（默认 1 小时节流）才换源； + 如要立即验证，可 `(updater-check-background)` 手动触发。 diff --git a/devel/0518.md b/devel/0518.md new file mode 100644 index 0000000000..d2b084bdde --- /dev/null +++ b/devel/0518.md @@ -0,0 +1,320 @@ +# 0518: Velopack 更新通道(stable/beta)软件内切换 + +## 2026/08/26 更新通道 stable/beta 软件内切换 + +### What(本次改动做了什么) + +1. C++ 侧 `tm_velopack` 支持 `update-channel` 首选项(`stable`/`beta`,默认 + `stable`):构造 `UpdateManager` 时传 `UpdateOptions`—— + `ExplicitChannel` 显式取首选项值,`AllowVersionDowngrade` 常态开启。 + mgr 重建的判断键从 base URL 扩展为 base + channel,与 `stem-profile` + 换源逻辑(0517)正交组合。 +2. `do_check` 放行跨通道版本:缓存 `info` 的来源 channel 与本次检查的 + channel 不同时,接受 Velopack 返回的目标(可能同版本或更低版本), + 不再被本地 `newer_version`/`keep_ready` 逻辑挡住。 +3. Scheme 侧:`编辑→首选项→Other` 新增「Update channel」单选下拉 + (Stable/Beta 两选项,仅 Velopack 平台显示)。切换时两步确认:第一步 + 确认切换方向,第二步确认强制重启走 download+apply;任一步取消则 + 什么都不动。 +4. 确认后写 `update-channel` 首选项并启动异步切换链:后台检查 → 自动 + 下载 → 就绪后 `apply`(更新器进程接管,`safely-quit-TeXmacs` 正常退出 + 后应用并重启)。目标通道暂无可用版本时仅写首选项并提示,该通道下一 + 个版本发布后自动更新。 +5. CI(`cd_research_on_windows.yml`):每次 tag 都打 beta 包;仅无 `-rc` + 的 tag 额外打 stable 包。delta 基线按 channel 分开查找——beta 取最新 + release 的 beta full;stable 向前找最近非 rc release 的 stable full。 + `ci_bump_version.yml` 不动(channel 由 tag 名携带 `-rc` 与否推导, + 无需透传)。 + +### Why(为什么这么做) + +- beta 发版节奏(stable 大版本间的 rc 迭代)需要独立于 stable 的更新线路; + Velopack 原生支持多 channel(同一 feed URL 下 `releases..json`), + 客户端用 `ExplicitChannel` 即可免重装切换。 +- `AllowVersionDowngrade` 常态开启:beta→stable 回退时目标版本往往更低; + Velopack 源码语义是「仅当降级允许 且 ExplicitChannel 与安装包默认 + channel 不同时,同版本条目才会作为更新返回」——正好覆盖「切到版本号 + 相同的另一通道」的场景。 +- 本仓库自研的 `newer_version`/`keep_ready` 过滤会挡同版本/更低版本, + 跨通道检查必须放行,否则切换后 `CheckForUpdates` 返回的目标被丢弃。 +- tag 名(`-rc` 与否)已完整携带「是否打 stable 包」的信息,CD 侧自行 + 解析 `github.ref_name` 即可,bump-version 流水线无需透传输入。 + +### How(怎么做的) + +1. `src/Plugins/Updater/tm_velopack.cpp`: + - `update_channel ()`:主线程读 `update-channel` 首选项,仅 `beta` 视为 + beta,其余(含缺省)归一为 `stable`。 + - `tm_velopack_rep` 增加 `mgr_channel`/`feed_channel`/`info_channel`: + `feed_channel` 是检查/下载启动时主线程快照的 channel(与 `feed_base` + 同步刷新);`ensure_mgr` 比较 base + channel 任一变化即重建,并显式 + 填 `UpdateOptions{AllowVersionDowngrade=true, ExplicitChannel=channel, + MaximumDeltasBeforeFallback=10}`;`info_channel` 记录缓存 `info` 的 + 来源 channel。 + - `do_check`:`channel_switched = info_channel != feed_channel` 时 + `keep_ready` 不成立,直接接受返回的目标并更新 `info_channel`。 +2. `src/Scheme/L5/glue_qt.lua`:补 `cpp-confirm-question` 的 glue + (两按钮确认弹窗,已有 C++ 实现与 `MOGAN_TEST_CONFIRM_QUESTION` 钩子)。 +3. `TeXmacs/progs/utils/misc/updater.scm`: + - `updater-current-channel`:读首选项(缺省 `stable`)。 + - `updater-switch-channel target`:两次 `cpp-confirm-question` 确认; + 取消即返回。确认后写首选项 + 存盘,触发 `updater-check-background`, + `delayed` 轮询状态机:AVAILABLE(2) → `updater-download-update`; + READY(4) → `updater-apply-update`(内部 `safely-quit-TeXmacs`); + IDLE(0,目标通道无更新)→ 提示已切换、新版本发布后自动更新; + FAILED(6) → 提示失败、可稍后手动检查。 +4. `TeXmacs/progs/kernel/texmacs/pref-keys.scm`:`pref-update-channel` + (`"update-channel"`)。 +5. `TeXmacs/progs/texmacs/menus/preferences-widgets.scm`:Other/Misc 追加 + combo 字段(仅 `use-plugin-updater?` 时)+ `define-preference-names` + 注册 stable/beta 编解码;`preferences-qml-set-field` 对该键路由到 + `updater-switch-channel`(选回当前通道时 no-op)。 +6. `TeXmacs/progs/utils/misc/updater.scm`:注册 `update-channel` 缺省值 + `stable`(combo 未写值时显示正确)。 +7. `.github/workflows/cd_research_on_windows.yml`: + - Fetch 基线按 channel 参数化,stable 额外按非 rc tag 过滤。 + - Pack 步骤跑两次(beta 必跑;stable 仅非 rc tag),`VPK_CHANNEL` + 注入,beta/stable 各用独立输出目录,每通道各打一个 zip + (`mogan-release--win-x64-.zip`)分开上传;fetch 基线 + 按通道名匹配 zip,兼容旧版合并 zip(无通道后缀)回退。 + +### 涉及文件 + +- `src/Plugins/Updater/tm_velopack.cpp` +- `src/Scheme/L5/glue_qt.lua` +- `TeXmacs/progs/utils/misc/updater.scm` +- `TeXmacs/progs/kernel/texmacs/pref-keys.scm` +- `TeXmacs/progs/texmacs/menus/preferences-widgets.scm` +- `TeXmacs/progs/texmacs/menus/preferences-tools.scm` +- `TeXmacs/progs/utils/misc/updater-test.scm`(补 update-channel 归一断言) +- `TeXmacs/plugins/lang/dic/en_US/zh_CN.scm`(Update channel / Stable / + Beta / 两步确认弹窗与 footer 提示的中文翻译) +- `.github/workflows/cd_research_on_windows.yml` + +### 验证与遗留 + +- 更新检查/切换仅在安装版(Setup.exe)上生效;开发目录直跑 `UpdateManager` + 构造即失败(见 devel/0517.md),属预期。 +- 切换链的状态码轮询依赖现有 glue(`updater-state` 等),与 + `updater-auto-download-loop` 并存不冲突(auto loop 只在 AVAILABLE 触发 + 下载,切换链下载就绪后立即 apply;两者幂等)。 +- beta 通道首发无基线时 vpk 只出 full 包,客户端全量更新,合法状态。 +- 服务端(OSS)需将 beta 产物上传到与 stable 相同的 feed 目录,不在本 + 任务范围。 + +## 2026/08/26 双通道产物分开上传(每通道各一个 zip) + +- 此前所有通道合并进单一 `mogan-release--win-x64.zip`;现改为每通道 + 各打一个 `mogan-release--win-x64-.zip` 分开上传,Release + 资产与下游 delta 基线按通道取用,避免下载无关通道的整包(1.5GB)。 +- 下游 fetch 基线逻辑同步适配:优先按通道名匹配 zip(`*beta*.zip` / + `*stable*.zip`,新格式),只下载目标通道归档;找不到再回退旧合并 zip + (无通道后缀,内含全部通道包)。 +- 涉及文件 `.github/workflows/cd_research_on_windows.yml` 的 + `Create release archive` 与 `Fetch delta baselines` 两步;Upload/Release + 的 `build/mogan-release-*.zip` glob 不变(已覆盖多 zip)。 + +## 2026/08/26 修复切换通道确认后不自动重启 + +- 现象:点确认弹窗的 Restart 后,下载正常完成(手动关闭后更新能应用), + 但 Mogan 进程不自动退出重启。 +- 根因:`updater-switch-chain-poll` 的超时机制把检查(1)/下载(3)这类「进行中」 + 状态计入 ticks 防御上限(每秒 +1,600s 后 set-message 超时并结束轮询)。下载 + 全量包(266MB)超过 10 分钟时,poll 在下载完成前退出,失去在 READY 触发 + `updater-apply-update`(apply + safely-quit-TeXmacs 退出)的机会。下载完成后 + 只能靠下次启动 VelopackApp 自动应用,进程本身不退出不重启。 +- 修复:`updater-switch-chain-poll` 增加 `(or (== st 1) (== st 3))` 独立分支, + 检查/下载期间不消耗 ticks(ticks 只防御状态异常卡死);`st==4` apply 后继续 + 轮询一次,apply 失败时读到 FAILED 报错,不再静默。 +- 涉及文件 `TeXmacs/progs/utils/misc/updater.scm`。 + +## 2026/08/26 切换通道下载中间态弹窗 + 就绪后重启确认 + +### What(本次改动做了什么) + +1. 切换通道确认后进入下载时,弹出「正在下载更新,请稍候...」进度弹窗 + (UpdaterProgress.qml),随下载进度实时刷新百分比进度条。 +2. 下载完成(READY)关闭进度弹窗,再弹阻塞确认「更新已下载完成,是否立即重启 + 以应用更新?」:点 Restart 走 `updater-apply-update`(apply + + safely-quit-TeXmacs 退出,更新器接管重启);取消则提示「更新将在下次启动 + 应用时自动应用」,本次不退出,由下次启动 VelopackApp 自动应用。 +3. 下载中弹窗不可 ESC/X 取消(QML onCancel no-op)——切通道的下载是强制步骤, + 关窗只丢进度反馈,下载本身照常。 + +### Why(为什么这么做) + +- 切换通道下载全量包可能持续数分钟,此前下载期间无任何反馈,用户无从得知进度; + 下载完成后直接退出重启也缺少「是否立即重启」的选择。 +- 进度弹窗必须走 `run_modal_qml_dialog`(setModal+show,非 exec):切换链由 + scheme `delayed` 轮询驱动,exec 的嵌套事件循环会冻结轮询,重新引入「下载超 + 10 分钟 poll 先退出、READY 后失去触发重启机会」的旧 bug。READY 后的重启 + 确认用阻塞 exec 无碍——下载已结束,poll 无需再跑。 + +### How(怎么做的) + +1. `src/Plugins/Qt/qml/UpdaterProgress.qml`:DialogShell + 消息 + 进度条 + (track=fieldBg, fill=accent)+ 百分比;`onCancel` no-op。 +2. `src/Plugins/Qt/moganqml.qrc`:注册 UpdaterProgress.qml。 +3. `src/Plugins/Qt/UpdaterProgressBridge.hpp`:Q_OBJECT 桥,`progress` 属性 + (setProgress 钳 0..100)+ `closeDialog()`;宿主 close 后 deleteLater 自清。 + 方法全内联,无需 .cpp(xmake 自动 moc 头文件)。 +4. `src/Plugins/Qt/QTMQmlDialog.{hpp,cpp}`:新增 `cpp_updater_dialog_open + (message)` / `cpp_updater_dialog_progress(int)` / `cpp_updater_dialog_close()`, + 经 `run_modal_qml_dialog` 开窗;文件级 `QPointer` + 持引用,宿主析构自动置空,close/progress 调用天然安全。 +5. `src/Scheme/L5/glue_qt.lua`:注册三个 glue 入口(scm 名 + cpp-updater-dialog-open/progress/close)。 +6. `TeXmacs/progs/utils/misc/updater.scm`:标志 `updater-switch-dialog-open?` + 控制仅首次进入 DOWNLOADING 时开窗;`st==3` 每秒 `(cpp-updater-dialog-progress + (updater-progress))` 推进度;`st==4` 关窗 + `updater-question` 阻塞确认—— + 选 Restart 走 apply 并继续轮询(apply 失败读到 FAILED 报错),选取消则链路 + 结束(READY 状态不前自动进,继续轮询会每秒重弹确认),下次启动 VelopackApp + 自动应用;`st==0/6/超时` 与 `updater-switch-chain-start` 入口清理弹窗与标志。 +7. `TeXmacs/plugins/lang/dic/en_US/zh_CN.scm`:补 3 条翻译(下载中/就绪确认/ + 下次启动应用)。 +8. `TeXmacs/progs/prog/glue-symbols.scm`:符号表加 3 个新 glue 名(仅供 + 补全/apidoc,非功能注册)。 + +### 验证与遗留 + +- 进度推进依赖 `updater-progress` glue 返回 0..100;全量包下载中途进度反映实际 + 下载进度,小包/秒下完时进度可能瞬间跳到完成,属预期。 +- 与 `updater-auto-download-loop` 并存不冲突:该 loop 仅在 AVAILABLE 触发下载, + READY 后不动;切换链在 READY 弹确认。 +- 涉及文件: + - `src/Plugins/Qt/qml/UpdaterProgress.qml` + - `src/Plugins/Qt/moganqml.qrc` + - `src/Plugins/Qt/UpdaterProgressBridge.hpp` + - `src/Plugins/Qt/QTMQmlDialog.hpp` + - `src/Plugins/Qt/QTMQmlDialog.cpp` + - `src/Scheme/L5/glue_qt.lua` + - `TeXmacs/progs/prog/glue-symbols.scm` + - `TeXmacs/progs/utils/misc/updater.scm` + - `TeXmacs/plugins/lang/dic/en_US/zh_CN.scm` + +## 2026/08/27 下载中间态弹窗改为无条件打开 + 无限转圈(不依赖 Velopack 状态) + +### What(本次改动做了什么) + +1. 弹窗出现时机从「状态机报出 DOWNLOADING(3)」改为「scheme 触发下载的瞬间 + (AVAILABLE==2)无条件打开」:`updater-switch-chain-poll` 在 `st==2` 分支先 + `updater-switch-dialog-open` 再 `updater-download-update`;`st==3` 分支保留 + 一次幂等兜底(防 auto-download-loop 抢先触发下载、poll 直接看到 DOWNLOADING + 而错过 `st==2`)。 +2. 弹窗不再显示进度条/百分比,改为无限转圈 + 文案「正在下载更新,请稍候...」; + 移除 `cpp-updater-dialog-progress` glue 与 `updater-progress` 推进,弹窗不再 + 读更新器任何输出。 +3. 删除 `UpdaterProgressBridge.hpp`(桥对象):C++ 侧改为 `QPointer` + 持宿主,`cpp_updater_dialog_close` 走 `host->close()` 关窗。 +4. 下载/检查失败(FAILED==6)时,关中间态弹窗后弹阻塞确认提示「更新检查失败: + <错误码>」(单 OK 按钮),不再只写状态栏 set-message。 + +### Why(为什么这么做) + +- 现象:切换通道下载时,有时 Velopack 没有任何状态/日志输出(不报 DOWNLOADING) + 但下载仍在进行,此时 `st==3` 分支不进入,弹窗不弹出——下载过程完全无反馈。 + 根本原因就是弹窗出现依赖了 Velopack 的输出。改为在触发下载时固定打开,与 + Velopack 是否报状态解耦。 +- 失败提示用弹窗而非状态栏 set-message:下载失败对用户是重要事件,状态栏消息 + 易错过;弹窗带错误码便于反馈。链路到 FAILED 即终止,阻塞 exec 安全。 +- 无进度条:进度值仍依赖 Velopack `updater-progress` 上报,同样存在不输出的情况; + 且用户只要「正在下载」的转圈反馈,精确百分比不是诉求。 +- 必须走 `host->close()` 而非 `closeBridge->cancel()`:`QmlDialogBridge::cancel()` + 调 `QDialog::done(Rejected)`,对 show() 型弹窗只 hide() 不触发 + WA_DeleteOnClose 析构,宿主泄漏、`QPointer` 悬垂;`close()` 同步析构宿主。 + +### How(怎么做的) + +1. `TeXmacs/progs/utils/misc/updater.scm`:新增幂等助手 + `updater-switch-dialog-open`(标志 `updater-switch-dialog-open?` 防重复弹); + `st==2` 无条件打开 + 触发下载;`st==3` 兜底再开一次(幂等)、移除进度推进; + `st==4` 关窗 + 重启确认;新增 `updater-notify-failure`,`st==6` 关窗后弹阻塞 + 确认提示失败(带错误码);`st==0/超时` 清理。 +2. `src/Plugins/Qt/qml/UpdaterProgress.qml`:DialogShell + 无限转圈 + (fieldBg 轨道环 + Canvas 120° accent 弧 + RotationAnimation 无限旋转) + + 居中文案;`onCancel` no-op;移除进度条/百分比/updBridge。 +3. `src/Plugins/Qt/UpdaterProgressBridge.hpp`:删除。 +4. `src/Plugins/Qt/QTMQmlDialog.{hpp,cpp}`:删 `cpp_updater_dialog_progress` + 声明与实现;文件级引用改 `QPointer g_updater_dialog_host`; + `cpp_updater_dialog_close` 改 `g_updater_dialog_host->close()` 后显式置空。 +5. `src/Scheme/L5/glue_qt.lua` / `TeXmacs/progs/prog/glue-symbols.scm`:移除 + `cpp-updater-dialog-progress` 的 glue 声明与符号表条目。 + +### 验证与遗留 + +- 弹窗现于触发下载时固定出现,不依赖 Velopack 是否报 DOWNLOADING;转圈无进度。 +- 下载完成(READY)关窗后仍走既有重启确认;取消则下次启动自动应用,逻辑不变。 +- 失败(6)提示为阻塞确认弹窗,带 Velopack 错误码;断网/服务端不可达可复现。 +- 涉及文件: + - `TeXmacs/progs/utils/misc/updater.scm` + - `src/Plugins/Qt/qml/UpdaterProgress.qml` + - `src/Plugins/Qt/UpdaterProgressBridge.hpp`(删除) + - `src/Plugins/Qt/QTMQmlDialog.hpp` + - `src/Plugins/Qt/QTMQmlDialog.cpp` + - `src/Scheme/L5/glue_qt.lua` + - `TeXmacs/progs/prog/glue-symbols.scm` + +## 2026/08/27 修复第二次切换不弹中间态窗(auto-download-loop 抢先触发下载) + +### 现象 + +- 安装后第一次启动,切换渠道会弹「正在下载更新」转圈窗,正常下载并重启应用; + 这次切换成功之后,再尝试切换渠道:弹窗不出现,但后台在下载,过一会自动重启。 + +### 根因 + +- 弹窗打开时机绑在切换链 poll 读到 AVAILABLE(2)/DOWNLOADING(3) 上。第二次切换时, + 上一轮下载已让 Velopack 状态机进入 READY(4) 并保持,`updater-auto-download-loop` + (每 1s 轮询,见 2 就触发下载)会抢先触发新下载;切换链的 `updater-check-background` + 因已有任务进行而返回 #f,`updater-switch-chain-start` 只能每秒重试等待。等旧任务 + 结束、链 poll 真正开始读状态时,下载已被 auto-download-loop 触发并推进,poll 一 + 进来就只看到 DOWNLOADING(3)/READY(4),弹窗的开窗分支(2/3)可能从未命中——READY(4) + 直接走重启确认,中间态窗从未出现,但后台照常下载、就绪后自动重启,正是用户所见。 +- 附带问题:scheme 侧标志 `updater-switch-dialog-open?` 冗余且脆弱——真正的幂等 + 由 C++ `g_updater_dialog_host` 保证;且 `updater-switch-chain-start` 入口每次 + 复位该标志,与 poll 内清理相互覆盖,时序下可能漏关窗。 + +### What(本次改动做了什么) + +1. 弹窗打开时机改为「切换确认后立即无条件打开」:`updater-switch-channel` 在 + `(save-preferences)` 之后、`(updater-switch-chain-start 0)` 之前直接调 + `updater-switch-dialog-open`——无论 poll 是否还能读到 2/3,弹窗必然出现。 +2. 移除 scheme 标志 `updater-switch-dialog-open?` 与其所有 `set!`/`when` 引用: + `updater-switch-dialog-open` / `updater-switch-dialog-cleanup` 退化为直接调 + `cpp-updater-dialog-open` / `cpp-updater-dialog-close`,幂等完全交给 C++ 侧 + `g_updater_dialog_host`(已打开 no-op)。 +3. poll 的 `st==2` / `st==3` 分支保留 `(updater-switch-dialog-open)` 作兜底 + (防 auto-download-loop 抢先、poll 进链即 DOWNLOADING 的时序),不再承担「首次 + 开窗」职责。 +4. `updater-switch-chain-start` 移除入口处标志复位;超时分支(等旧任务 >600s) + 补 `(updater-switch-dialog-cleanup)` 关窗——弹窗由确认处打开,超时退出时必须 + 收掉,否则转圈窗滞留。 + +### Why(为什么这么做) + +- 打开时机与 Velopack 状态机彻底解耦:第二次切换时状态机/auto-loop 的行为与 + 首次不同,poll 不一定能读到开窗所需的状态,唯有把开窗提前到「用户确认之后、 + 任何异步检查之前」才能保证固定出现(用户原始诉求「不要依赖 Velopack 输出决定 + 是否弹出」「固定出现」)。 +- 移除标志:弹窗生命周期收敛为「确认时开、终态(0/4/6/超时)关」,由 C++ 宿主指针 + 单点幂等,消除 scheme 状态与真实窗口状态分叉的隐患。 + +### How(怎么做的) + +1. `TeXmacs/progs/utils/misc/updater.scm`: + - `updater-switch-channel`:确认后 `(updater-switch-dialog-open)`。 + - 删 `(define updater-switch-dialog-open? #f)`;两个助手去掉标志读写。 + - `updater-switch-chain-start`:删入口 `set!`,超时分支加 cleanup + set-message。 + - 段注释 / poll 注释 / `st==3` 内联注释改为描述「确认时无条件打开 + poll 兜底」。 +2. 更新本节任务文档。 + +### 验证与遗留 + +- 首次与第二次切换路径统一:确认点下即弹转圈窗;下载结束(READY)关窗后照旧弹 + 重启确认,逻辑不变。 +- 弹窗滞留兜底:确认后 `updater-check-background` 长时间 #f(旧任务 >600s)或 poll + 超时都会 cleanup 关窗,不会永久滞留。 +- 涉及文件: + - `TeXmacs/progs/utils/misc/updater.scm` + - `devel/0518.md`(本任务文档) + diff --git a/devel/0519.md b/devel/0519.md new file mode 100644 index 0000000000..9bc5f4fced --- /dev/null +++ b/devel/0519.md @@ -0,0 +1,166 @@ +# 0519: macOS arm64 Velopack 打包与自动更新 + +## 2026/08/27 macOS arm64 接入 Velopack + +### What(本次改动做了什么) + +把 macOS arm64 接入与 Windows 相同的 Velopack 发布/更新链路: + +1. vendor macOS libc 运行时动态库(上游 release 1.2.0 的 universal + `velopack_libc_osx.dylib`,前置任务单独提交); +2. xmake/C++ 运行时集成:`USE_PLUGIN_VELOPACK` 扩展到 macOS arm64, + 启动钩子/更新器后端/feed 平台段全部放开平台 guard; +3. release 脚本(`stage_velopack.lua`/`pack_velopack.lua`)增加 macOS + 分支,产出 vpk 原生 `.pkg` 安装器 + portable `.zip` + full/delta + nupkg + `releases..json` feed。 + +### Why(为什么这么做) + +- 0512 立下的目标是三平台共用 Velopack 的发布版本/渠道/客户端更新 API, + 各平台产出各自安装格式;macOS 是第二个接入的平台。 +- 现有 macOS 发布(.dmg)无自动更新;Velopack delta 增量 + 应用内更新 + 与 Windows 侧体验拉齐。 +- 发布物选 vpk 原生 `.pkg` + `.zip`(不做 DMG):`.pkg` 走系统安装流程 + (用户可选 /Applications 或 ~/Applications),更新链路天然支持;DMG + 可后续从 portable zip 自行生成,不在本任务。 + +### How(怎么做的) + +按提交顺序分四步: + +1. **任务文档**(本文件)。 +2. **vendor macOS dylib(前置任务,单独提交)**:从 + `velopack_libc_1.2.0.zip` 取 `lib/velopack_libc_osx.dylib` + (universal x86_64+arm64),改名 `libvelopack_libc.dylib`(lib 前缀 + 使 `add_links("velopack_libc")` 可解析;macOS 链接期文件名须与磁盘 + 名一致,故 vendor 时改名,与 Windows 安装期改名不同), + `install_name_tool -id @rpath/libvelopack_libc.dylib` 重写 install id + (上游是 CI 构建路径;id 必须与磁盘文件名一致,loader 按该文件名在 + rpath 目录查找),随后 `codesign --force --sign -` 重签(改 id + 会破坏原签名,arm64 上签名损坏的 dylib 会被 AMFI 拒载)。 + lib-static 的 `.a` 不 vendor:dylib 已预链 Rust 依赖,免手动补 + framework。 +3. **C++/xmake 运行时集成**: + - `xmake/velopack.lua`:`add_velopack_runtime()` 平台分发,macOS + arm64 直链 dylib;`velopack_startup_test` 目标扩到 mac。 + - `xmake/velopack.lua` 增加 `velopack_libc` shared target(on_build 拷 + 预编译产物,targetdir 定在 `/Frameworks`):qt.widgetapp + 的部署规则会把 shared 依赖的 targetfile 自动拷进 .app 的 + `Contents/Frameworks`,裸二进制(dev 运行/CI scheme 测试走 + `target:targetfile()`,bundle 外)靠自带 `@executable_path/Frameworks` + rpath 找到同一份。自写 after_build 拷贝不可行——qt 部署规则会 + `os.tryrm` 整个 .app 重建,时机上必然被清掉。 + - `xmake/targets/libmogan.lua`:`USE_PLUGIN_VELOPACK = win x64 或 + macosx arm64`,不按构建模式 gate(CI releasedbg 跑 scheme 测试, + 模式 gate 会使测试期望随模式漂移)。 + - `research.cpp` 启动钩子、`tm_updater.cpp`/`tm_velopack.cpp` 后端 + 选择 guard 扩为 `OS_WIN || OS_MACOS`。 + - `tm_velopack.cpp` feed 平台段改编译期宏 `UPDATER_FEED_PLATFORM` + (`win-x64`/`osx-arm64`/`osx-x64`),替换硬编码 `win-x64`;不走 + config.h.xmake(单消费者不值得动全局配置头)。 + - `preferences-widgets-test.scm`:other tab 字段数期望改为 + `(+ (if (os-macos?) 17 15) (if (use-plugin-updater?) 1 0))`, + 不硬编码 18(osx-x64 未开启时仍正确)。 +4. **release 脚本 macOS 分支**: + - `stage_velopack.lua`:按 `os.host()` 分发;定位 + `build/macosx/*/release/MoganSTEM.app`,`ditto` 拷贝(保 Qt + framework 符号链接,xmake `os.cp` 默认解引用会打坏 bundle); + 从 `packages/macos/Info.plist.in` 生成真 plist(替换 + `@STEM_NAME@`/`@XMACS_VERSION@`,不依赖 stem_packager——它 + release-only、依赖 create-dmg、会产 DMG);ad-hoc 签 staging + 副本;结构与禁发文件校验。 + - `pack_velopack.lua`:vpk 定位加 mac 候选路径;args 用 + `--runtime osx-arm64`、`--mainExe MoganSTEM`、`--packDir` 指向 + `.app`;显式传 `--channel`(vpk mac 默认 channel 是 `osx`, + 不传会拆渠道);签名参数 `VPK_SIGN_APP_IDENTITY` 等五个环境变量 + 透传(本阶段默认不签,凭据留给 CI);产物从 + `assets..json` 发现 `.pkg`/`.zip` 后按 + `MoganSTEM-v<版本>-arm64-<渠道>-Setup.pkg`/`-Portable.zip` 改名; + `prune_old_full` 后处理平台无关,不动。 + +feed 平台段为 `osx-arm64`(服务端 `/api/v1/public/update/osx-arm64` +目录不在本任务范围)。版本纪律沿用 0512 的 `rc.N` 预发布格式。 + +### 不做什么 + +- CI workflow 改造(`cd_on_macos_arm64.yml` 仍走 package.scm 产 DMG, + 接入 velopack 是后续任务); +- DMG 产物;osx-x64(dylib 为 universal,后续加成本低); +- 正式 Developer ID 签名/公证(环境变量已接好,凭据后续配)。 + +### 涉及文件 + +- `3rdparty/velopack/lib/libvelopack_libc.dylib`(新)、`3rdparty/velopack/README.md` +- `xmake/velopack.lua`、`xmake/targets/stem.lua`、`xmake/targets/libmogan.lua` +- `src/Mogan/Research/research.cpp`、`src/Plugins/Updater/tm_updater.cpp`、 + `src/Plugins/Updater/tm_velopack.cpp` +- `tools/velopack/velopack_startup_test.cpp` +- `TeXmacs/progs/texmacs/menus/preferences-widgets.scm`(注释)、 + `TeXmacs/progs/texmacs/menus/tests/preferences-widgets-test.scm` +- `tools/release/stage_velopack.lua`、`tools/release/pack_velopack.lua` + +### 如何测试 + +```bash +# 运行时集成(releasedbg,对齐 macOS CI) +xmake f -c -m releasedbg --yes && xmake b stem +otool -L build/macosx/arm64/releasedbg/MoganSTEM.app/Contents/MacOS/MoganSTEM | grep velopack +xmake r updater-test && xmake r preferences-widgets-test +xmake b velopack_startup_test && xmake r velopack_startup_test +xmake run --group=scheme_tests + +# 打包(release) +xmake f -c -m release --yes && xmake b stem && xmake i stem +xmake l tools/release/stage_velopack.lua +xmake l tools/release/pack_velopack.lua +``` + +## 2026/08/27 验证结果 + +### 运行时集成（releasedbg，对齐 ci-macos-arm64.yml） + +- `otool -L` 裸二进制与 .app 内二进制均记录 `@rpath/libvelopack_libc.dylib`； + dylib 两处落位：`/Frameworks/`（裸二进制，dev 运行与 CI scheme + 测试走 `target:targetfile()`）与 `.app/Contents/Frameworks/`（qt 部署规则 + 按 shared 依赖拷贝）。 +- `xmake r updater-test`：9 correct, 0 failed——macOS 首次以 `tm_velopack` + 激活状态跑该测试（Windows CI 不跑 scheme 测试，Linux 编的是基类空实现）。 +- `xmake r preferences-widgets-test`：434 correct, 0 failed（other tab + 18 字段，含 Update channel）。 +- `xmake r velopack_startup_test`：输出 `velopack startup hook: ok`。 +- `xmake run --group=scheme_tests` 全组合计 1152 correct, 0 failed。 + +### 打包（release，本机 ad-hoc，未接正式签名） + +- stage：4203 文件 / 420.4 MB；`plutil -lint` 通过；CFBundleIdentifier= + app.mogan、CFBundleExecutable=MoganSTEM、版本 2026.3.2。 +- vpk 1.2.0（dotnet tool，需 `DOTNET_ROOT=/opt/homebrew/opt/dotnet/libexec`） + 实测 macOS 产物名与 Windows 同约定：`Mogan--Setup.pkg` / + `Mogan--Portable.zip`；改名后为 + `MoganSTEM-v2026.3.2-arm64-stable-{Setup.pkg,Portable.zip}`（pkg 168MB / + zip 172MB），assets.stable.json 同步更新。注意 assets.json 是顶层数组 + （字段 `RelativeFileName`），与 releases.json 的 `{Assets:[...]}` 结构不同。 +- 无签名参数时 vpk 明确告警跳过签名/公证（Package will not be signed or + notarized），流程不失败。 +- delta：同 outputDir 下以 `VPK_VERSION=2026.3.3` 二次 pack，产出 + `Mogan-2026.3.3-stable-delta.nupkg`（4141 unchanged / 1 patched / 10 + removed），增量链可用（测试产物已清理）。 + +### 端到端 + +- Portable.zip 解压到 /tmp 直接运行：headless 冒烟 + `(use-plugin-updater?)` ⇒ `#t`、`(updater-state)` ⇒ 0（IDLE），进程正常 + 退出——bundle 内 dylib 加载、`$TEXMACS_PATH` 从 bundle 解析均正常。 +- GUI `open` 启动存活（越过 2s 的 updater-initialize 窗口，feed 尚未就绪 + 也不崩）；首选项 → Other 可见 Update channel。 +- .pkg 解包检查：Distribution 引用 app.mogan@2026.3.2 主 bundle， + `enable_currentUserHome="true"` 支持 ~/Applications 安装。 + +### 后续（非本任务） + +- CI 接入（cd_on_macos_arm64.yml 或新 workflow）+ Developer ID 签名/公证 + （`VPK_SIGN_APP_IDENTITY` 等五个环境变量已接好）； +- 服务端 `/api/v1/public/update/osx-arm64` feed； +- 本机跑 vpk 需 dotnet + `dotnet tool install -g vpk`；brew 安装的 dotnet + 不在 vpk 默认 runtime 搜索路径，pack 脚本已自动探测注入 + `DOTNET_ROOT=/opt/homebrew/opt/dotnet/libexec`，无需手动 export。 diff --git a/devel/0520.md b/devel/0520.md new file mode 100644 index 0000000000..058344afdd --- /dev/null +++ b/devel/0520.md @@ -0,0 +1,108 @@ +# 0520: macOS CD 接入 Velopack（对齐 Windows CD） + +## 2026/08/28 macOS CD 从 DMG 切换到 Velopack + +### What(本次改动做了什么) + +重写 `.github/workflows/cd_on_macos_arm64.yml`：移除旧的 goldfish + +package.scm DMG 打包/签名/公证流程，改为与 +`cd_research_on_windows.yml` 行为一致的 Velopack 流程——build/install stem、 +安装 vpk、stage、从 GitHub Release 拉取各通道 delta 基线、beta/stable 双通道 +pack、按通道产出归档 zip `mogan-release-<版本>-osx-arm64-<渠道>.zip`、 +上传 artifact / 发布 Release。CI 内完成 Developer ID 签名 + 公证（复用现有 +APPLE_* secrets 构建 keychain 与 notarytool profile，经 0519 接好的 +VPK_SIGN_* 环境变量注入 vpk）。 + +### Why(为什么这么做) + +- 0519 已落地 macOS 侧 Velopack 运行时与本地 stage/pack 脚本，CI 是最后一环； + release 产物从 DMG 迁移到 vpk 原生 .pkg + portable zip + nupkg feed， + 获得 delta 增量更新与应用内自动更新能力。 +- 严格镜像 Windows CD 的步骤结构、通道规则与基线回退语义，两平台发布行为 + 可预测、可对照排障。 +- 签名公证留在 CI 内完成（而非像 Windows 那样事后签名机）：mac 未签名 pkg + 下载即被 Gatekeeper 拦截，且现有 secrets 齐备，vpk 原生支持。 + +### How(怎么做的) + +1. **Noto 字体外置**：原 package.scm 内部下载的 4 个 CJK ttc 改为独立步骤 + （与 Windows CD 相同 URL），在 `xmake install stem` 前落进 + `TeXmacs/fonts/opentype/noto/`。 +2. **签名 setup（mac 独有步骤）**：keychain 构建命令序列照搬 + `packages/macos/package.scm`（create/unlock/import P12/import Developer ID + CA/set-key-partition-list/搜索列表+默认钥匙串）；App Store Connect API key + 解出后 `xcrun notarytool store-credentials` 建 profile；身份名动态解析 + （`security find-identity`），`VPK_SIGN_APP_IDENTITY`/ + `VPK_SIGN_INSTALL_IDENTITY`（存在才导出）/`VPK_NOTARY_PROFILE`/ + `VPK_KEYCHAIN` 写 GITHUB_ENV。 +3. **基线拉取**：逐行镜像 Windows CD 的 pwsh 逻辑（列 100 个 release、排除 + draft 与当前 tag、beta 必查 + 无 `-rc` 才查 stable、stable 只认非 rc + release、同版本跳过、解 zip 取 `*-$channel-full.nupkg` 拷入 + `build/velopack_release_<渠道>/`）。差异仅两处：zip 匹配模式带 + `-osx-arm64` 平台段（release 上已有 Windows 同前缀 zip，不带平台段会抓 + 错平台基线）；**不做裸 nupkg 回退**（Windows 的该回退对应其过渡期历史， + mac 沿用会抓到 Windows 旧 full）。`wget` 换 `curl`。 +4. **双通道 pack / 归档 / 发布**：与 Windows CD 完全一致——beta 每个 tag 打、 + tag 不含 `-rc` 加打 stable，各用独立 outputDir；归档 + `build/mogan-release-<版本>-osx-arm64-<渠道>.zip`；非 tag 上传 artifact、 + tag 以 prerelease 发布 `build/mogan-release-*.zip`。 + +### 已知关联缺陷（本次不处理） + +Windows CD 的基线 zip 匹配模式（`*beta*.zip` 等）不带平台段，mac 归档上传到 +同一 release 后会被其误抓为基线；用户决定另行任务收紧 Windows CD 模式。 + +### 不做什么 + +- 不动 Windows CD（含上述缺陷）； +- `packages/macos/package.scm` 文件保留在仓库（不再被 CD 引用，后续另行清理）； +- osx-x64；服务端 feed 目录（/api/v1/public/update/osx-arm64）。 + +### 涉及文件 + +- `devel/0520.md`（本文件） +- `.github/workflows/cd_on_macos_arm64.yml`（重写） + +### 如何测试 + +- 本地：`python3 -c "import yaml; yaml.safe_load(open('.github/workflows/cd_on_macos_arm64.yml'))"` + 过语法；actionlint（若可用）过两个 workflow；与 Windows CD 逐步骤结构对照。 +- 真实验证依赖首个 tag：观察双通道 pack、基线拉取日志（首版无基线只出 full + 属正常）、zip 命名与 release 资产、vpk 日志确认签名/公证完成。签名链路 + （vpk × hardened runtime × notarytool profile）是唯一无法本地验证的部分， + 若公证被拒，在 `--signEntitlements` 补最小权利文件。 + +## 2026/08/28 CD 三轮 tag 实测（PR #4451） + +测试 tag：`v2026.4.0` → `v2026.4.1-rc.1` → `v2026.4.1`（均 prerelease）， +Windows 与 macOS CD 同跑同 tag。首轮 mac 两次失败，定位并修复两处： + +1. **vpk 找不到 .NET runtime**：vpk 1.2.0 的 apphost 需要 net10.0， + macos-14 arm64 镜像自带 dotnet 版本旧且不在 apphost 搜索路径。修复： + `actions/setup-dotnet@v4` 装 .NET 10（自动设 `DOTNET_ROOT`）。 +2. **公证判 Invalid**：两个未签名嵌套二进制——(a) xmake 安装 stem 时把 + velopack shared 依赖额外装进 `Contents/Resources/lib/`（vpk 的 + `codesign --deep` 只遍历 bundle/framework/PlugIns 结构，签不到）， + 修复：stem 的 after_install 清理该错位副本（与重复二进制清理同模式）， + stage 加硬校验兜底；(b) `Resources/.../goldfish` 裸可执行文件同样对 + `--deep` 不可见，修复：stage 在配置了 `VPK_SIGN_APP_IDENTITY` 时用 + 正式身份逐个预签 Resources 裸 Mach-O（`.dSYM` 按旧 DMG 流程先例不签）， + bundle 本体仍交给 vpk 深签。修复后公证 **Accepted**（beta/stable 各 + 一次，~90s/次）+ staple 通过 + spctl 校验通过。 + +三轮结果（两平台行为一致）： + +| 轮次 | tag | 断言 | 结果 | +|------|-----|------|------| +| 1 | v2026.4.0（无 rc） | 双渠道产出 | ✓ win/mac × beta/stable 四归档；win 基线取真实 release 2026.3.2 的对应通道 full（新模式 `mogan-release-*-win-x64-.zip` 生效），mac 首发无基线只出 full | +| 2 | v2026.4.1-rc.1（rc） | 仅 beta + 以轮 1 beta 为基线 | ✓ 两平台仅 beta 归档；基线 `Mogan-2026.4.0-beta-full.nupkg`；delta 2026.4.0→2026.4.1-rc.1 | +| 3 | v2026.4.1（无 rc） | 双渠道 + 基线穿越 | ✓ 四归档；stable 基线 `Mogan-2026.4.0-stable-full.nupkg`（跳过 rc release）；beta 基线 `Mogan-2026.4.1-rc.1-beta-full.nupkg`；delta 2026.4.0→2026.4.1 / 2026.4.1-rc.1→2026.4.1 | + +测试遗留（已于 2026/09/01 全部处理完毕）： + +- ~~三个测试 release+tag（v2026.4.0 / v2026.4.1-rc.1 / v2026.4.1）~~ 已删除， + 基线链自动回落到真实 release（下一个正式版本的基线仍取自 v2026.3.2 等 + 真实发布）； +- ~~分支上 `xmake/vars.lua` 为测试版本 2026.4.1~~ 已恢复为 2026.3.2（与 + main 一致，PR 净 diff 不含版本号变更）； +- ~~Debian13/Fedora CD 的 tag 触发为注释状态~~ 已恢复，正式发版即正常触发。 diff --git a/devel/0700.md b/devel/0700.md new file mode 100644 index 0000000000..668635655e --- /dev/null +++ b/devel/0700.md @@ -0,0 +1,9 @@ +# [0700] Loro Collab: 适配 Window +## 如何测试： +在 Windows 中 +``` +xmake f --loro=y +xmake b stem +xmake i stem +xmake r stem +``` diff --git a/devel/0701.md b/devel/0701.md new file mode 100644 index 0000000000..46dc266170 --- /dev/null +++ b/devel/0701.md @@ -0,0 +1,15 @@ +# [0701] Loro Collab: 适配 ImGUI +## 如何测试 + +``` +xmake f --loro=yes --qt_frontend=no +xmake b stem +xmake r stem +``` + +起服务器 +``` +cd tools/loro-server/ && npm install && node server.js +``` + +使用多 ImGui 客户端测试协作 diff --git a/devel/0702.md b/devel/0702.md new file mode 100644 index 0000000000..3940b462f7 --- /dev/null +++ b/devel/0702.md @@ -0,0 +1,8 @@ +# [0702] fix: ImGui 中多光标颜色异常 +## 如何测试 +``` +xmake f --loro=yes --qt_frontend=no +xmake b stem +xmake r stem +``` +多个客户端，测试协同编辑中光标颜色可见 diff --git a/devel/0703.md b/devel/0703.md new file mode 100644 index 0000000000..bcf5ca65a3 --- /dev/null +++ b/devel/0703.md @@ -0,0 +1,88 @@ +# [0703] WASM 前端外壳 React/Vite 重构与 ImGui 菜单桥接 + +## 1 相关文档 +- [dddd.md](dddd.md) - 任务文档模板 + +## 2 任务相关的代码文件 +- `web/` (React 外壳前端代码：`src/MenuBar.tsx`, `MenuItems.tsx`, `ContextMenu.tsx`, `FooterBar.tsx`, `bridge.ts` 等) +- `src/Plugins/ImGui/im_react_bridge.hpp`, `src/Plugins/ImGui/im_react_bridge.cpp` (C++ 与 React Shell 的 WASM 桥接层) +- `src/Plugins/ImGui/im_menu.hpp`, `src/Plugins/ImGui/im_menu.cpp` (ImGui 菜单逻辑与 tile_menu 格子布局支持) +- `src/Plugins/ImGui/im_tm_widget.cpp` (WASM 下 Chrome Metrics 与 React 外壳分发对接) +- `src/Edit/Interface/edit_interface.cpp` (WASM 下跳过未使用的 Icons/Tools 菜单求值优化) +- `src/Edit/Modify/edit_collab.cpp`, `src/Plugins/Collab/loro_collab.cpp` (协同编辑菜单状态刷新与 remote 光标标记) +- `xmake/targets/web_shell.lua`, `xmake/targets/stem.lua`, `xmake.lua` (WASM 构建流程与 React Shell 编译打包集成) +- `.github/workflows/ci-macos-wasm.yml`, `.github/workflows/cd-research-mogan-app.yml` (CI/CD 自动化构建工作流) + +## 3 如何测试 + +### 3.1 确定性测试（单元测试） + +1. **前端类型检查与构建测试**： + ```bash + cd web + npm install + npm run build + ``` + +2. **C++ 代码编译测试**： + ```bash + xmake b stem + ``` + +### 3.2 非确定性测试（Web WASM 运行验证） + +1. **配置并构建 WASM 目标**： + ```bash + xmake config -p wasm --qt_frontend=no --pdfhummus=no --goldfish=no -m releasedbg --yes + xmake b stem + ``` + +2. **启动本地 WASM 测试服务**： + ```bash + python3 tools/wasm/wasm_server.py + ``` + 在浏览器中打开 `http://localhost:8000` 进行功能验证： + - **主菜单（MenuBar）**：验证菜单项能否正确显示、子菜单能否惰性展开，点击菜单项能否触发正确的 Scheme/C++ 命令。 + - **右键菜单（ContextMenu）**：在编辑区右键点击，验证上下文菜单能否在正确位置弹出并响应操作。 + - **状态栏（FooterBar）**：验证底部状态栏（左/中/右部分及交互模式）是否正确渲染并随编辑器状态更新。 + - **Canvas 布局（Chrome Metrics）**：调整浏览器窗口大小或缩放，验证 C++ 画布区能否准确填满菜单栏与状态栏之间的空间。 + - **协同编辑菜单刷新**：连接/断开 Loro 协同服务后，验证菜单中的协同状态是否即时刷新。 + +## 4 如何提交 + +提交前执行以下最少步骤： + +```bash +gf fmt --changed-since=main +``` + +## 5 What +1. **构建全新的 WASM React Web Shell (`web/`)**：使用 React + TypeScript + Vite 实现替代原有 ImGui 渲染的主菜单栏 (MenuBar)、右键上下文菜单 (ContextMenu) 及底部状态栏 (FooterBar)。 +2. **实现 ImGui ↔ React Bridge 桥接层 (`im_react_bridge`)**： + - 将 C++ 侧 ImGui 菜单结构递归序列化为 JSON 推送到 JS 侧。 + - 支持子菜单按需/惰性展开（Submenu Lazy Expansion），大幅降低菜单推送到前端的序列化与求值开销。 + - 通过 JS 侧 `Module.ccall` 将菜单指令以延迟队列（`im_queue_menu_command`）形式回调 C++ 执行，维持 C++ 侧无重入约束。 + - 动态回报 Web Shell 的菜单栏与状态栏实际像素高度（Chrome Metrics），保持 C++ 画布（Canvas）在网页上的精确坐标对齐与裁剪。 +3. **优化 WASM 模式下的 Scheme 菜单求值开销**：在 WASM 构建下，`update_menus` 自动跳过 Web 端未使用的图标栏 (ICONS) 和侧边工具栏 (SIDE_TOOLS) 的 Scheme 求值，大幅提升 WASM 下菜单更新的流畅度。 +4. **集成 xmake 构建与 CI/CD 流程**： + - 新增 `web_shell` 目标，使 `xmake build stem` 在 WASM 模式下自动触发 `npm install` 与 `npm run build`。 + - 自动将打包产物安装至 WASM 输出目录（`index.html` / `stem.html`）。 + - 更新 CI/CD 配置，在 GitHub Actions 中集成 Node.js 环境与 npm 依赖缓存。 + +## 6 Why +原本 Mogan 的 WASM 版本使用 ImGui 纯 C++ 绘制主菜单、弹出菜单与状态栏。这种方式存在以下问题： +1. **界面美观与交互体验不足**：ImGui 默认的 UI 风格与标准 Web 应用/桌面应用有较大差距，缺少现代 Web UI 的流畅动画、样式可定制性及良好的移动/触摸屏适配。 +2. **性能浪费**：每次 `update_menus` 都需要对所有的图标栏、侧栏等 Scheme 表达式进行计算和构建，在 WASM 环境下开销较大。 +3. **分离 UI 与核心渲染引擎**：将 Chrome (菜单、状态栏等外壳) 移至 React 层实现，能更好地利用 Web 生态，同时让 WASM 核心专心处理文档排版与 ImGui Canvas 绘制。 + +## 7 How +1. **序列化与指令回调（Bridge）**： + - C++ 侧维护命令注册表 `g_cmd_registry` 和惰性子菜单注册表 `g_submenu_registry`，为每个可点击项生成唯一 ID。 + - 叶子按钮被点击时，JS 调用 `mogan_menu_invoke(id)`，通过 ImGui 的延迟命令队列 `im_queue_menu_command` 统一在主循环帧末尾 flush，避免在 React 事件回调中重入 C++ 菜单树。 + - 惰性子菜单仅在用户 hover/click 展开时由 JS 调用 `mogan_menu_expand(id)` 触发 Scheme 表达式求值并推回子节点，避免一次性生成全量深层菜单树。 +2. **画布布局计算（Chrome Metrics）**： + - React Shell 组件挂载及窗口 resize 时，测量 React DOM 的实际 height 并通过 `mogan_set_chrome_metrics` 通知的 C++ 侧。 + - `im_tm_widget.cpp` 根据收到的 `header_h` 与 `footer_h` 计算文档 Canvas 的起始位置与可用高度，确保输入事件的物理坐标到 SI 逻辑坐标的转换精准对齐。 +3. **xmake 自动化打包**： + - `web_shell.lua` Target 在检测到 `package-lock.json` 更新时智能增量执行 `npm install` 和 `npm run build`。 + - `stem.lua` 的 `after_build` 阶段把 `web/dist` 中的静态文件打平复制到 WASM 目标目录，并将 `index.html` 复制为 `stem.html` 以兼容既有的 WASM Dev Server 和 CI 部署路径。 diff --git a/devel/0704.md b/devel/0704.md new file mode 100644 index 0000000000..f0cad5e423 --- /dev/null +++ b/devel/0704.md @@ -0,0 +1,69 @@ +# [0704] 共享文档支持自定义文件名 + +## What + +共享文档（Loro Collab）支持创建时指定自定义显示名；不再只能靠 UUID 识别文档。 + +## Why + +此前共享文档由服务端 `crypto.randomUUID()` 分配 docId，菜单项、buffer 标题 +均直接显示 UUID，用户需「记住 uuid」才能加入文档，可用性差。 + +## How + +UUID 仍是唯一 docId（磁盘目录名、JOIN 协议、内部标识不变）；自定义名存 +`meta.json` 的 `name` 字段，仅用于显示。允许重名，菜单显示 +`name (uuid前8位)` 消歧。 + +### 协议 + +``` +C→S CREATE 带显示名创建（裸 CREATE 兼容旧行为） +S→C DOC 成功确认携带 name（无 name 文档仍仅 uuid） +S→C ERR BAD_NAME name 校验失败 +GET /docs 每行 \t（无名文档行仅 uuid） +``` + +### 命名规则（服务端权威校验，Scheme 侧同规则预校验） + +trim 后长度 1–64（按字符/code point 计），禁止 `\ / : * ? " < > |` 及 +控制字符（U+0000–001F、U+007F）。空/全空格视为「未提供」，按无名文档处理。 + +### 涉及文件 + +- 服务端： + - `tools/loro-server/validate.js`（新）：`validateDocName`，权威校验 + - `tools/loro-server/store.js`：`createDoc(docId, name)`、 + `listDocsWithNames()`（单篇 meta 损坏不拖垮列表） + - `tools/loro-server/registry.js`：`DocEntry.name`，`load()` 从 meta 回填 + - `tools/loro-server/server.js`：CREATE 带 name、DOC 帧携带 name、 + /docs 输出 `uuid\tname` +- C++ 客户端： + - `src/Plugins/Collab/loro_collab.cpp/hpp`、`loro_collab_ws.hpp`： + `doc_name` 成员；CREATE 帧携带 name；DOC 帧按首个空格拆 uuid/name； + `become_ready` 标题用 name（回退 uuid）；新增 `loro_collab_doc_name()` + - `src/Plugins/Collab/loro_collab_docs_native.cpp` / `_wasm.cpp`： + `loro_collab_docs()` 改为扁平交替数组 [uuid0, name0, ...] + - `src/Scheme/Plugins/glue_collab.lua`：create/join 签名扩展、 + 新增 `loro-collab-doc-name` +- Scheme： + - `TeXmacs/progs/texmacs/texmacs/tm-collab.scm`： + `collab-valid-doc-name?`（`utf8-string-length` 按字符计长）、 + `collab-docs-pairs`、`collab-doc-label` 纯函数； + `collab-new-document` 加 `(:argument name ...)` 交互输入； + Join 子菜单显示 name；`collab-join-document` 支持 name 预填 + +### 测试 + +- `tools/loro-server/test/validate.test.js`（新）：纯函数边界/禁字符 +- `tools/loro-server/test/server.test.js`：CREATE 带名/非法名/全空格、 + /docs 带 name、JOIN 后 DOC 帧带 name +- `TeXmacs/progs/texmacs/texmacs/tests/tm-collab-test.scm`（新）： + scheme 侧三个纯函数 +- `TeXmacs/tests/0759_collab.scm`、`0772_collab_meta.scm`：调用点改新签名 + （传 `""` 走无名路径） + +### 兼容性 + +- 旧文档（meta 无 name 字段）：/docs 行无 TAB、DOC 帧无 name，显示回退 uuid +- 客户端与服务端同仓发布，DOC 帧格式升级不做版本握手 diff --git a/devel/0705.md b/devel/0705.md new file mode 100644 index 0000000000..40313506ee --- /dev/null +++ b/devel/0705.md @@ -0,0 +1,13 @@ +# [0705] Qt 客户端添加配置协作服务器的菜单选项 +## 如何测试 +### 确定性测试 +``` +xmake r tm-collab-test +``` + +### 非确定性测试 +``` +xmake f --loro=yes +xmake b stem +``` +手动测试在 File - Collaborative 下，可以配置协作服务器地址 diff --git a/devel/0706.md b/devel/0706.md new file mode 100644 index 0000000000..35f6ffa70d --- /dev/null +++ b/devel/0706.md @@ -0,0 +1,98 @@ +# [0706] 修复 LAN 下大帧 WebSocket 上行卡死（升级 vendored libcurl 到 8.21.0） + +## What + +客户端向协作服务端上行**大体量 Loro update**（粘贴大图，单帧 ~0.5–1.3 MB+）时，在 LAN +下连接卡死、服务端收不到、客户端 worker 100% CPU 钉死。根治方案：**把 mogan 内置的 +libcurl 从系统 8.7.1 升级到 vendored 8.21.0**（源码置于 `3rdparty/curl-8.21.0`，由 xmake +直接构建），客户端代码回退原版。 + +## Why + +根因在 libcurl 8.7.1 的 `ws_flush(complete=TRUE)`：内核发送缓冲满、`send()` 返回 `EAGAIN` +时，源码是 + +```c +if (result == CURLE_AGAIN) { + if (!complete) return result; + n = 0; + continue; // 纯用户态忙循环：不 sleep、不等事件、无退出 +} +``` + +而 `curl_ws_send` 固定调 `ws_flush(..., TRUE)`，故 `if(!complete)` 永不命中、每次走 +`n = 0; continue;`。大帧突发填满内核 send buffer → EAGAIN → worker 被钉在这个循环里 → +**100% CPU、发不出一字节、连接卡死**。环回无背压（对端瞬时排空、缓冲永不满）故本地不复现； +这也是为何早前尝试的客户端侧缓解（调大 `SO_SNDBUF`、自定义 `CURLWS_OFFSET` 分帧 + `poll(POLLOUT)` +闸门）只是绕路、且都无法覆盖 `wss://`（直写 socket 会绕开 TLS）。 + +属于 libcurl WebSocket 的 busy-loop 类问题，公开记录可参考： + +- [CVE-2025-5399](https://curl.se/docs/CVE-2025-5399.html) —— WebSocket endless loop（8.14.1 修；与本 bug 同类但路径不同）。 +- [curl#15865](https://github.com/curl/curl/issues/15865) —— 大帧 `curl_ws_send` 返回 `CURLE_AGAIN`，应用须 `poll` 等待可写而非忙循环。 + +8.21.0 已修复（见 `3rdparty/curl-8.21.0/lib/ws.c`）： + +```c +if (result == CURLE_AGAIN) { + CURL_TRC_WS(data, "flush EAGAIN, %zu bytes remain in buffer", ...); + return result; // 直接把 CURLE_AGAIN 返回给调用方，不再忙转 +} +``` + +且 `curl_ws_send` 不再强制阻塞——普通（非 callback）模式下非阻塞，缓冲满即返回 `CURLE_AGAIN` +交应用 `poll` 后重试。于是客户端原版的 `CURLE_AGAIN → break → 下一轮重试` 即正确，无需任何 +客户端改动。`ws://` 与 `wss://` 均生效（TLS 仍由 libcurl 处理）。 + +## How + +### xmake 接入 vendored libcurl（不再用系统库、不再联网下载） + +- `xmake/packages/l/libcurl/xmake.lua`（mogan 自有 `liii-repo` 包，覆盖 xmake-repo 同名包）： + - 删 `set_urls`/`add_versions`，改 `set_sourcedir(path.join(os.projectdir(), "3rdparty/curl-8.21.0"))`； + 包名仍为 `libcurl`，消费方（`xmake/targets/libmogan.lua` 的 `add_packages("libcurl")`、`cpr` + 的依赖）无需改动。 + - `on_install`：`set_sourcedir` 不带版本号（调 `package:version()` 会报 nil），而原 `version:ge("7.81")` + 等条件对 8.21 全为真，故硬编码现代 CMake 选项：`CURL_USE_OPENSSL` / `CURL_USE_SECTRANSP`(macOS) / + `CURL_USE_SCHANNEL`(Windows) / `CURL_USE_MBEDTLS` / `CURL_USE_LIBSSH2` 等，并删去仅旧版需要的 mingw + `io.replace` 补丁。 + - vendored 源码已删去 `docs/` 与 `tests/`（减体积），故传 `-DBUILD_EXAMPLES=OFF` + （跳过 `docs/examples`）、`-DCMAKE_DISABLE_FIND_PACKAGE_Perl=ON`（跳过手册页 `docs/cmdline-opts`； + `tests/` 由 `-DBUILD_TESTING=OFF` 跳过），避免 CMake 引用已删目录而配置失败。 + - Windows/mingw `syslinks` 补 `iphlpapi`、`secur32`、`bcrypt`、`normaliz`：libcurl 8.21 + （SCHANNEL）在 Windows 上的系统依赖（见其 `CMakeLists.txt` 的 `CURL_LIBS`），旧表缺这 4 个 + 会让消费方/`on_test` 链接报 LNK2019（`if_nametoindex` / `InitSecurityInterfaceA` / + `BCryptGenRandom` / `IdnToAscii`）。 +- `xmake/vars.lua`：`CURL_VERSION = "8.21.0"`（同步标注；当前未被引用）。 +- macOS 走系统 Security 框架的 `CURL_USE_SECTRANSP`，无需联网下 TLS 依赖；Linux 走 openssl + （由 xmake 拉取或系统 `openssl-dev` 提供）。 + +### 客户端 + +- `src/Plugins/WebSocket/libcurl/tm_curl_websocket_client.cpp|.hpp` **回退原版**：升级后 + `curl_ws_send` 不再忙转，原版的 `CURLE_AGAIN → break → 重试` 即正确。早前尝试过的 + `SO_SNDBUF`、`CURLWS_OFFSET` 自定义分帧、`poll(POLLOUT)` 闸门、`header_written` 等均已撤销。 + +## 涉及文件 + +- `3rdparty/curl-8.21.0/`（vendored 源码，8.21.0，含 `ws_flush` 修复）。 +- `xmake/packages/l/libcurl/xmake.lua`（改）：`set_sourcedir` + 硬编码 8.21 CMake 选项、删除下载 URL。 +- `xmake/vars.lua`（改）：`CURL_VERSION = "8.21.0"`。 + +## 验证 + +- `xmake f -c --yes` 配置通过（包定义加载无 lua 错误）。 +- 确认 vendored 源码含修复：`3rdparty/curl-8.21.0/lib/ws.c` 中 `CURL_TRC_WS(data, "flush EAGAIN, …"); return result;` + （直接返回），旧的 `n = 0; continue;` 忙转已不在。 +- 实测（待非沙箱机器）：`xmake b stem`（首次从源码编译 libcurl 8.21.0）→ `MOGAN_LORO_DEBUG=1 xmake r stem` + → LAN 粘大图：应不再卡、客户端不再 100% CPU、服务端正常收到大帧。 +- 沙箱限制：包构建被 filelock 拦截（`cannot create filelock for package(...)`），端到端构建须在非沙箱环境完成。 + +## 备注 + +- 本根治方案为**依赖升级**，无新增可单测的 C++ 逻辑；libcurl 自带测试覆盖 `ws_flush`，故不新增本项目单测。 +- `ws://` 与 `wss://` 均受益（TLS 不被绕开）——优于「自组帧 + 直写 socket」方案（后者无法过 TLS，且与 + libcurl 在 `curl_ws_recv` 内自动回 PONG 存在同一 socket 的并发写风险）。 +- macOS 系统 libcurl 为 8.7.1（SecureTransport），不便直接升级，故走 vendored 路线。 + `xmake/requires.lua` 中 Linux apt/fedora 分支当前仍用系统 libcurl；如需 Linux 也统一走 vendored 8.21.0， + 把对应分支改为 `add_requires("libcurl", {system=false})` 即可（需构建环境提供 `openssl-dev`）。 diff --git a/devel/0707.md b/devel/0707.md new file mode 100644 index 0000000000..22e4b33d16 --- /dev/null +++ b/devel/0707.md @@ -0,0 +1,37 @@ +# [0707] Collab 文档禁用 IM 预编辑（preedit） + +## What & Why +协作文档下，输入法的实时预编辑（preedit，即正在拼写的候选拼音/字符装饰）会干扰 CRDT +协同，需要禁用。参考 `(set-preference "IM:preedit" "off")` 的效果，但**不应改用户配置** +——不能持久写 `IM:preedit` 偏好，只在运行期、按当前文档是否处于协作会话判定。 + +## How +复刻既有 `in-math?` 的运行期门控模式：数学模式下同样会在不改偏好的前提下强制关 preedit。 +Scheme 谓词 `(collab-enabled?)` **已存在**（`src/Scheme/Glue/glue_editor.lua`，glue 规则 +生成 `get_current_editor()->collab_enabled()`），其实现为 `edit_modify_rep::collab_enabled()` +→ 返回 `loro_collab_on`（`src/Edit/Modify/edit_collab.cpp`）。故无需新增 glue，只在 3 处 +预编辑入口各加一行判断： + +- Qt：`QTMWidget::inputMethodEvent` — `if (as_bool (call ("collab-enabled?"))) im_preedit_switch= false;` +- ImGui/web：`mogan_ime_preedit` — `if (as_bool (call ("collab-enabled?"))) return;` +- ImGui/macOS：`im_macos_enqueue_preedit` — 同上 + +提交文本（commit string）路径不经过这些门控，协作文档中正常输入提交文本不受影响；只压制 +实时 preedit 装饰。亦未动 `inputMethodQuery` 的 `Qt::ImEnabled`（那会整体关掉 IME，连提交 +文本一起禁，过重）。 + +行为：普通文档 preedit 跟随用户 `IM:preedit` 偏好（默认开）；协作文档强制关（即使偏好为 on）。 + +## 涉及文件 +- `src/Plugins/Qt/QTMWidget.cpp`：`inputMethodEvent` 加协作门控 +- `src/Plugins/ImGui/im_tm_widget.cpp`：`mogan_ime_preedit`（web）、 + `im_macos_enqueue_preedit`（macOS）各加协作门控 + +## 如何测试 +需 `--loro=y` 构建后 GUI 验证（preedit 是真实 IME 行为，headless 跑不出）： +``` +xmake f --loro=y && xmake b stem && xmake r stem +``` +1. 普通文档：中文输入法拼写时 preedit 候选正常显示（偏好未变）。 +2. 开协作会话（CREATE/JOIN，触发 `collab_enable`）后：同一输入法拼写时不再显示 preedit + 装饰，但提交文本（选词后上屏）仍正常。 diff --git a/devel/0708.md b/devel/0708.md new file mode 100644 index 0000000000..ed4dc42a79 --- /dev/null +++ b/devel/0708.md @@ -0,0 +1,84 @@ +# [0708] 协作文档支持中文文件名 + +## What + +共享文档（Loro Collab）新建时支持中文（及任意非 ASCII）文件名。此前在 +GUI 输入中文文档名点 OK 无反应——文档无法创建、不连服务端。 + +## Why + +Qt 文本框回传 scheme 的字符串经过 Cork 编码层 `from_qstring → +utf8_to_cork`（`src/Plugins/Qt/qt_utilities.cpp`）。CJK 等无 Cork 映射的 +码点被 `utf8_to_cork` 改写成 `<#XXXX>` 转义串（`lolly/lolly/data/cork.cpp`）： + +``` +「测试文档」 → <#6D4B><#8BD5><#6587><#6863> +``` + +这个串含 `<` `>`，正是 `collab-doc-name-forbidden-chars` 禁止的字符，导致 +`collab-valid-doc-name?` 返回 `#f`，`collab-new-document-named` 走「Invalid +name」分支——只弹一句 footer 提示、不建 buffer、不连服务端（footer 不显眼， +用户感知为「点 OK 无反应」）。ASCII 不受影响（Cork 对码点 <128 透明），所以 +英文文档名一直正常，问题仅限中文等非 ASCII 名字。 + +诊断期一度误判为「校验逻辑 bug」：纯逻辑测试和诊断脚本用 UTF-8 字面量直接 +调用 `collab-valid-doc-name?`，**绕过了 Qt 编码层**，校验通过；只有真实 GUI +路径才 cork 化。这正是原 `tm-collab-test.scm` 漏网的原因——它全用 UTF-8 字面量。 + +次生问题：即便校验放行，cork name 直接传 C++ `loro-collab-create` 会让服务端 +存 `<#XXXX>` 乱码；且 C++ `doc_name` 既用于 WS 传输（要 UTF-8）又用于 buffer +标题（标题层期望 Cork），存在编码矛盾。 + +## How + +collab 链路统一为「外部传输用 UTF-8、内部标题用 Cork」，在 scheme 入口解耦。 + +### Scheme 入口 cork→utf8（`TeXmacs/progs/texmacs/texmacs/tm-collab.scm`） + +`name` 来自 Qt 是 Cork。两个创建入口用 `(let ((uname (cork->utf8 name))) ...)`： + +- 校验 `collab-valid-doc-name?` 与传输 `loro-collab-create` 用 UTF-8 的 `uname` +- `buffer-set-title` 保持原 Cork `name`（标题层期望 Cork，渲染时 `<#XXXX>` + 还原为中文） + +涉及： +- `collab-new-document-named` +- `collab-new-document-from-file-named` + +### C++ 标题编码解耦（`src/Plugins/Collab/loro_collab.cpp`） + +`become_ready` 的 `title` 改为 `lolly::data::utf8_to_cork(...)`：修复后 +`doc_name` 是 UTF-8（scheme 传 utf-8），WS 传输（`on_connect` 的 `CREATE` +帧，:320）直接用 UTF-8 即正确；但 buffer 标题与 footer 消息走显示层、期望 +Cork，故此处 `title` 转 Cork 再用于 `set_title_buffer` / `set_message`。补 +`#include `（mogan 有两个 cork.hpp，引号 include 解析到 +遗留空文件，须用尖括号完整路径指向 lolly 库头）。 + +### 涉及文件 + +- `TeXmacs/progs/texmacs/texmacs/tm-collab.scm`：两创建入口加 `cork->utf8` +- `src/Plugins/Collab/loro_collab.cpp`：`become_ready` 标题 + `lolly::data::utf8_to_cork` + `` +- `TeXmacs/progs/texmacs/texmacs/tests/tm-collab-test.scm`：补 cork 解码路径测试 + +## How to test + +### 单元测试（纯逻辑，headless） + +补 `test-cork-decode`：验证 `cork->utf8` 还原 `<#XXXX>`、ASCII 透明、混合串， +以及「Cork 化的中文文档名还原为 UTF-8 后通过校验」——覆盖修复的核心转换， +堵上原测试用 UTF-8 字面量绕过编码层的盲区。 + +```bash +xmake b stem && xmake r tm-collab-test +``` + +### GUI 端到端 + +1. 启服务端：`cd tools/loro-server && npm start` +2. 菜单 → 新建协作文档 → 输入「测试文档」→ OK → 应创建新 buffer，标题显示 + 「测试文档」（非 `<#...>`、非乱码） +3. `curl http://localhost:8765/docs` → 应见 `\t测试文档`（服务端存 + UTF-8，不是 `<#XXXX>`） +4. 回归：英文文档名「test」→ 正常创建（ASCII 不受 Cork 影响） +5. 重新加入：Join 菜单选刚建的中文文档 → 正常加入、标题正确 diff --git a/devel/0712.md b/devel/0712.md new file mode 100644 index 0000000000..144cdbb880 --- /dev/null +++ b/devel/0712.md @@ -0,0 +1,75 @@ +# [0712] 打开（上传）tmu 文件成为共享文档 + +## What + +Qt（及 ImGui）客户端支持把本地 `.tmu`/`.tm` 文件作为初始内容，创建一个新的 +共享文档（Loro Collab 云文档），即「上传文件成为共享文档」。 + +## Why + +此前「New shared document」只能从空 buffer 创建云文档（`collab-new-document-named` +先 `(new-buffer)` 再 `loro-collab-create`）。用户无法把已有的本地文件内容作为 +云文档的初始全量推到服务端——只能创建空文档后手工把内容重新输入/粘贴；且即便先 +加载文件再创建，内容也不会即时上传（见下）。 + +## How + +### 关键问题：seed 时机 + +`collab_enable()` 只置位 `loro_collab_on` 标志，并不 seed。真正的 CRDT seed +（`loro_doc->seed(the_buffer())` + `broadcast_update()`）在 `ensure_loro_seeded()` +里，**仅在首次编辑时**经 `edit_announce`/`mirror_loro` 延迟触发。 + +因此「先 `load-buffer` 加载文件、再 `loro-collab-create`」并不够：文件内容在 +用户首次编辑前不会上行，期间他人 JOIN 拿到的是空文档。 + +### 修复：CREATE 就绪即 eager-seed + +在 `collab_session::become_ready()` 里 `collab_enable()` 之后，CREATE 模式立即 +调用 `ed->ensure_loro_seeded()`：把当前 buffer（含已加载文件内容）seed 进 shadow +并广播初始全量。这样「上传文件」在会话就绪时即把内容推到服务端，无需等待首次 +编辑。空文档 seed 无副作用（仅多一次空全量广播，与原延迟 seed 行为等价）。 +JOIN 路径不受影响（`want_create()` 为假，且 JOIN 的 shadow 已从远端帧导入）。 + +### 交互流程 + +Collaborative 子菜单新增「New shared document from file」： + +1. 文件对话框（`action_open`，复用现有 `.tmu *.tm ...` 过滤器）选文件 +2. 显示名输入框，预填文件名（去目录、去后缀，如 `foo.tmu` → `foo`） +3. `load-buffer`/`load-buffer-in-new-window` 加载文件到 buffer + （`window-per-buffer?` 开新窗口，否则新标签页） +4. `collab-mark-current-buffer` 标记为 collab buffer（继承云文档特殊语义： + 不标修改、Save 提示用 Save as 导出本地副本） +5. `loro-collab-create`；会话就绪时 C++ eager-seed 上传内容 + +显示名复用 [0704] 的 `collab-valid-doc-name?` 预校验，最终以服务端权威校验为准。 + +### 涉及文件 + +- C++： + - `src/Plugins/Collab/loro_collab.cpp`：`become_ready()` 在 CREATE 模式下 + `collab_enable()` 后调用 `ed->ensure_loro_seeded()`（eager-seed） +- Scheme： + - `TeXmacs/progs/texmacs/texmacs/tm-collab.scm`：新增 + `collab-file->doc-name`（文件名→显示名）、 + `collab-share-file-prompt-name`（预填文件名的显示名输入）、 + `collab-new-document-from-file`（交互入口）、 + `collab-new-document-from-file-named`（加载文件→标记→CREATE） + - `TeXmacs/progs/texmacs/menus/file-menu.scm`：Collaborative 子菜单新增 + 「New shared document from file」项 + +### 测试 + +- `xmake b stem` 编译通过 +- 既有 collab 回归：`TeXmacs/tests/0759_collab.scm`、`0772_collab_meta.scm`、 + `TeXmacs/progs/texmacs/texmacs/tests/tm-collab-test.scm` +- 手动：起 `tools/loro-server`，开 MoganSTEM，Collaborative → New shared document + from file → 选 `.tmu` → 确认显示名 → 文档就绪后标题为显示名；另一端 JOIN + 该 UUID 应能立即看到文件内容（验证 eager-seed 生效，无需首编辑） + +### 兼容性 + +- 仅扩展 CREATE 就绪路径，空文档创建行为等价不变 +- JOIN 路径不动 +- 纯前端 + 协议会话层改动，服务端无需改动（仍按收到的 CRDT update 持久化） diff --git a/devel/0713.md b/devel/0713.md new file mode 100644 index 0000000000..0bc05062cf --- /dev/null +++ b/devel/0713.md @@ -0,0 +1,70 @@ +# [0713] 共享文档不被标脏 + +## What + +共享文档（Loro Collab 云文档）不再被标脏：tab/窗口标题不出现 `*`，关闭 +tab / 关闭窗口 / 退出 TeXmacs 时不再弹出 "Save scratch buffer?"。云文档内容 +权威在云端，本地"需保存"语义对其无意义。 + +## Why + +此前云文档会被当成普通脏文档处理： + +- dirty 并非一个布尔位，而是由 C++ archiver 的 `conform_save()`（撤销深度 == + 已存深度）推导。协作会话把远端内容经 `editor::apply_remote()` 落进 buffer + 会真实 bump 撤销深度，故 buffer 在 C++ 层确为脏。 +- tab/窗口标题的 `*` 走 C++：`edit_interface_rep::update_menus` 直接读 + `need_save()` 再 `set_modified()`，Scheme 侧的 `buffer-modified?` 覆盖根本 + 拦不到。 +- 关闭提示虽经 Scheme `buffer-modified?` → glue `buffer_modified` → + `needs_to_be_saved` → `editor::need_save()`，但对 glue 函数的 `tm-define` + 覆盖不能可靠传播到 `tm-server.scm` 的直接调用点，提示依旧弹出。 + +结论：`zzy/docname` 分支里已有的 Scheme `buffer-modified?` 覆盖既漏掉 C++ +标题星号路径又不可靠传播。需要在所有消费者的公共收敛点统一处理。 + +## How + +`editor::need_save()` 是标题星号、关闭提示、Scheme tab 星号、自动保存四条路径 +的共同收敛点（`update_menus` 与 `needs_to_be_saved`/`needs_to_be_autosaved` +最终都经此）。在 buffer 上加一个"云文档"标志，让 `need_save` 对云文档直接 +返回 false： + +1. `tm_buffer_rep` 新增公开成员 `bool cloud`（构造函数初始化 `false`）。 +2. `edit_modify_rep::need_save` 首行：`if (!is_nil (buf) && buf->cloud) return false;` + 一处改动即盖住标题星号、关闭提示、tab 星号、自动保存；`pretend_buffer_modified` + 之类强制标脏也无法绕过（`need_save` 是最后一道关）。 +3. 会话层置位 `concrete_buffer(buf_url)->cloud = true`，放在 + `collab_session_manager::get_or_create`（create/join 的共同入口）。**必须在 + get_or_create、不能只在 `collab_session` 构造函数**：`get_or_create` 命中残留 + 会话（如 `no_name_` 的 url 被新一轮 create/join 复用）时只复用旧会话、构造 + 函数不跑，而 buffer 可能是新 `tm_buffer_rep`（`cloud` 默认 false）→ 云文档被 + 当脏文档。曾表现为「第一次 join 不标脏、第二次（及 New）标脏」。在 get_or_create + 每次挂接时显式置位即根治。该文件仅在 `LORO_ENABLED` 下编译，核心代码无需 + `#ifdef`，解耦干净。 +4. 删除 `tm-collab.scm` 中冗余且脆弱的 `buffer-modified?` monkey-patch（C++ + 成为唯一真相源后，glue `buffer-modified?` 自然返回 `#f`）。保留 `save-buffer` + 覆盖（把 Save 重定向到"用 Save as 导出本地副本"提示）及其依赖的 + `collab-buffer?` / `collab-buffer-url` / `collab-mark-current-buffer`。 +5. `collab-new-document-named` 在发 CREATE 前即 `(buffer-set-title (current-buffer) + name)`（与 join 一致），避免 tab 在服务端 DOC 帧返回前暂显 `No Name[n]`。 + +断开语义：`collab-leave` 后 `cloud` 不回退，与既有"挂上即永久"意图一致。 + +## 涉及文件 + +- `src/Texmacs/tm_buffer.hpp`：`tm_buffer_rep` 加 `cloud` 成员 +- `src/Edit/Modify/edit_modify.cpp`：`need_save` 加云文档拦截 +- `src/Plugins/Collab/loro_collab.cpp`：`get_or_create` 每次挂接置位 `cloud` +- `TeXmacs/progs/texmacs/texmacs/tm-collab.scm`：删除冗余 `buffer-modified?` + 覆盖、更新段落注释（保留 `save-buffer` 覆盖）；CREATE 预设标题 + +## 验证 + +GUI 手测（需 loro-server 运行）： + +1. Collaborative → New shared document / Join，连上服务端。 +2. 远端/本地编辑后确认：tab 与窗口标题**无 `*`**。 +3. 关闭该 tab / 关闭窗口 / 退出 TeXmacs：**不弹** "Save scratch buffer?"。 +4. 回归：普通本地文档编辑后仍出 `*`、关闭仍弹提示（未误伤）。 +5. Save（Ctrl+S）仍提示"用 Save as 导出本地副本"；Save as 正常导出。 diff --git a/devel/0731.md b/devel/0731.md new file mode 100644 index 0000000000..b42c03a11a --- /dev/null +++ b/devel/0731.md @@ -0,0 +1,3 @@ +# [0731] fix cd on Debian 13 +## How +移除系统 Qt 安装，让 xmake 管理 Qt 安装 diff --git a/devel/0784.md b/devel/0784.md index 5f83c3a994..98a2f684d9 100644 --- a/devel/0784.md +++ b/devel/0784.md @@ -11,3 +11,41 @@ TODO: revise simplify & revise archiver xmake b stem xamke r stem ``` + +--- + +## 细化：编译期全局禁用 → 运行期按文档禁用（2026-08-10） + +### What & Why +初版的 `#ifdef LORO_ENABLED ... return; #endif` 是编译期开关，粒度太粗：`loro=y` 构建下 +**所有文档**（含纯本地文档）都失去历史压缩，本地文档 undo 历史无谓膨胀。改为运行期、 +按文档判定——只在文档真正进入协作会话（`loro_collab_on == true`）时跳过 simplify，其余 +照常压缩。 + +### How +`archiver_rep` 无 editor/buffer 反向引用，且 simplify 的调用点 `global_confirm`/ +`global_cancel` 遍历所有 pending 归档器、无 editor 上下文，故在归档器上加运行期标志， +由 editor 在 `collab_enable()` 置位（复刻既有 `versioning` / `set_versioning()` 模式）： + +- 新增字段 `bool collab;`（恒声明，默认 false）+ 公开 setter `set_collab(bool)`。 +- `simplify()` 用 `if (collab) return;` 替换原 `#ifdef LORO_ENABLED return;`。 +- `edit_modify_rep::collab_enable()` 置 `loro_collab_on= true;` 后调用 `arch->set_collab(true)`。 + +行为矩阵：loro=n → simplify 恒运行（与现状一致）；loro=y 本地文档 → simplify 恢复运行 +（修复点）；loro=y 协作文档 → simplify 跳过（保留原规避）。无对称 disable：会话一旦开启 +随文档生命周期常驻，代码中无 `collab_disable`。 + +### 涉及文件 +- `src/Data/History/archiver.hpp`：新增 `collab` 字段、`set_collab` 声明 +- `src/Data/History/archiver.cpp`：构造初始化 `collab(false)`、`simplify()` 改运行期判断、 + `set_collab` 实现 +- `src/Edit/Modify/edit_collab.cpp`：`collab_enable()` 通知归档器 + +### 如何测试 +``` +xmake f --loro=y +xmake b stem +xmake r stem +``` +打开客户端，在正常文档中输入 `test` 按下 cmd-z，检查输入内容`test`被撤回。 +在协作文档中输入 `test` 按下 cmd-z，检查输入内容`t`被撤回 diff --git a/devel/0788.md b/devel/0788.md new file mode 100644 index 0000000000..117576d270 --- /dev/null +++ b/devel/0788.md @@ -0,0 +1,14 @@ +# [0788] Collab 性能提升：对 Poll 设计节流 +## What +当前对 Poll 没有节流机制，导致如果远端高速输入，则本端几乎每一帧都 Poll 收到 on_message 并处理输入事件，导致卡顿。 + +## Why +模仿本地键盘事件的节流机制，给 Poll 设计 1000 / 6 ms 的节流，从而规避这一问题。 + +## 如何测试 +``` +xmake f --loro=yes +xmake b stem +xmake r stem +``` +在两端同时进行高速输入，检查无卡顿 diff --git a/devel/0789.md b/devel/0789.md new file mode 100644 index 0000000000..680a87f5ae --- /dev/null +++ b/devel/0789.md @@ -0,0 +1,162 @@ +# [0789] IR Spaghettification Refactor +## Context（背景与动机） + +Mogan STEM 的实时协同（`LORO_ENABLED`）当前把 moebius 文档树 1:1 映射到 Loro 的**可移动树容器（LoroTree）**：每个树节点绑定一个 `mogan_tree_id`（= Loro `TreeID {peer, counter}`），见 [loro_shadow.hpp:33-39](moebius/Data/Convert/loro/loro_shadow.hpp:33)。结构操作（SPLIT/JOIN/INSERT_NODE/REMOVE_NODE）必然让 TreeID 消亡或新建，因为**在 LoroTree 模型里身份与树节点本身耦合**——这正是 ID 漂移、关联光标/选区/批注丢失的根因。 + +代码确认的 churn 点（全部在 [loro_shadow_mod.cpp](moebius/Data/Convert/loro/loro_shadow_mod.cpp)）： +- `mirror_split`（L104）为后半段**新建**节点 y_id； +- `mirror_join`（L256）**删除** y_id； +- `mirror_insert_node`（L158）/`mirror_remove_node`（L194）新建/删除 wrapper； +- `mirror_mod` 兜底（L318）整块 delete + re-seed。 + +**目标**：把 body 的同步模型从「树容器」改为「单条线性 LoroText 标记流」。结构不再是 CRDT 直接同步对象，而是标记流的解释结果。SPLIT/JOIN/INSERT_NODE/REMOVE_NODE 变成标记 token 的插入/删除，**所有存活字符的 Loro op-id 保持不变**。 + +--- + +## 目标架构 + +``` +Mogan Tree (tree_rep*) + ↕ tree ↔ linear_ir (Phase 1–2，纯 C++，无 Loro 依赖) +Linear IR (array：OPEN/CLOSE/TEXT/BINARY/MARKER) + ↕ linear_ir ↔ markup 文本 (Phase 1，转义编解码) +单条 markup 字符串 + ↕ FFI（单 LoroText 容器） (Phase 3) +LoroDoc： LoroText "body" + LoroTree（仅 meta-section，不变） +``` + +身份模型变更（Phase 4）： +- body 节点身份：`tree_rep*` → **Loro Cursor**（锚定在该节点 OPEN token 首字符的 op-id），存为 hex。Cursor 在并发编辑下自动位移，无需手维护数值偏移。 +- meta-section 身份：保持 `mogan_tree_id`（TreeID）不变。 + +前向镜像不变量：`mirror_mod` 在 **post-apply** buffer 上运行（[edit_collab.cpp:96](src/Edit/Modify/edit_collab.cpp:96)），依赖 `raw_apply` 不改 `tree_rep*` 指针——新模型继续复用此不变量，用 id_map(tree_rep*) 定位 LoroText 中的 token 位置。 + +--- + +## 线性 IR 与标记设计 + +### linear_item 类型（Phase 1 新增） +```cpp +enum linear_item_kind { LI_OPEN, LI_CLOSE, LI_TEXT, LI_BINARY, LI_MARKER }; +enum linear_marker_kind { LM_SPLIT }; // MARKER 子类型 +struct linear_item { + linear_item_kind kind; + string label; // OPEN: 标签名或 "generic:"（atomic 为空） + string text; // TEXT: 原文；BINARY: base64 + linear_marker_kind marker; // MARKER 用 +}; +// array 即整篇 body 的线性 IR +``` + +### tree ↔ linear_ir（Phase 1–2，复用 [loro_ir.cpp](moebius/Data/Convert/loro/loro_ir.cpp) 的标签处理） +- `tree_to_linear_ir(t)`：先序遍历。复合/泛型节点 → `OPEN(label) …children… CLOSE`；原子 → `OPEN("") TEXT(content) CLOSE`（**统一包裹**，避免相邻原子串歧义，无需 SEP）。复用 `as_string(L(t))` / `moebius::make_tree_label` / `"generic:"` 前缀逻辑。 +- `linear_ir_to_tree(items)`：栈式解析 OPEN…CLOSE 重建树。 +- 纯函数、无 Loro 依赖，可直接 round-trip 单测（对标现有 `loro_ir_test.cpp`）。 + +### MARKER(SPLIT) 语义（核心） +`SPLIT` 标记出现在某节点内部时，表示「关闭当前最内层节点，并以**相同 label** 开一个新兄弟」。故： +``` +[OPEN(para), TEXT("hel"), MARKER(SPLIT), TEXT("lo"), CLOSE] + → (para "hel")(para "lo") +``` +- **SPLIT 操作** = 在切分偏移处插入 1 个 `MARKER(SPLIT)` token（后半段字符原地保留，op-id 不变）。 +- **JOIN 操作** = 删除该 `MARKER(SPLIT)` token（两段 TEXT 成为同一节点的两个原子子节点，字符 op-id 不变）。 +- **INSERT_NODE**（包裹）= 在内容前后插入 `OPEN(label)` / `CLOSE` 两个 token。 +- **REMOVE_NODE**（脱壳）= 删除对应的 `OPEN` / `CLOSE` token。 + +> 待 Phase 1–2 用 round-trip 锁定的语义点：JOIN 后两段 TEXT 是否需合并为单原子以匹配 moebius `raw_join` 的 `(para "hello")`。若 moebius 期望合并，则 `linear_ir_to_tree` 对「同一节点内相邻 TEXT」做归一化合并；以线性 IR 为唯一真相源，tree 解释与之对齐。 + +### markup 文本编码（Phase 1，进/出 LoroText） +用转义引入符 `\x01`（用户文本中出现的 `\x01`/`\x02` 双写转义，故用户文本永不裸含 `\x01`）： +- `OPEN(label)` → `\x01 L